diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/compiler/Bytecodes.h b/compiler/Bytecodes.h
deleted file mode 100644
--- a/compiler/Bytecodes.h
+++ /dev/null
@@ -1,109 +0,0 @@
-/* -----------------------------------------------------------------------------
- *
- * (c) The GHC Team, 1998-2009
- *
- * Bytecode definitions.
- *
- * ---------------------------------------------------------------------------*/
-
-/* --------------------------------------------------------------------------
- * Instructions
- *
- * Notes:
- * o CASEFAIL is generated by the compiler whenever it tests an "irrefutable"
- *   pattern which fails.  If we don't see too many of these, we could
- *   optimise out the redundant test.
- * ------------------------------------------------------------------------*/
-
-/* NOTE:
-
-   THIS FILE IS INCLUDED IN HASKELL SOURCES (ghc/compiler/GHC/ByteCode/Asm.hs).
-   DO NOT PUT C-SPECIFIC STUFF IN HERE!
-
-   I hope that's clear :-)
-*/
-
-#define bci_STKCHECK                    1
-#define bci_PUSH_L                      2
-#define bci_PUSH_LL                     3
-#define bci_PUSH_LLL                    4
-#define bci_PUSH8                       5
-#define bci_PUSH16                      6
-#define bci_PUSH32                      7
-#define bci_PUSH8_W                     8
-#define bci_PUSH16_W                    9
-#define bci_PUSH32_W                    10
-#define bci_PUSH_G                      11
-#define bci_PUSH_ALTS                   12
-#define bci_PUSH_ALTS_P                 13
-#define bci_PUSH_ALTS_N                 14
-#define bci_PUSH_ALTS_F                 15
-#define bci_PUSH_ALTS_D                 16
-#define bci_PUSH_ALTS_L                 17
-#define bci_PUSH_ALTS_V                 18
-#define bci_PUSH_PAD8                   19
-#define bci_PUSH_PAD16                  20
-#define bci_PUSH_PAD32                  21
-#define bci_PUSH_UBX8                   22
-#define bci_PUSH_UBX16                  23
-#define bci_PUSH_UBX32                  24
-#define bci_PUSH_UBX                    25
-#define bci_PUSH_APPLY_N                26
-#define bci_PUSH_APPLY_F                27
-#define bci_PUSH_APPLY_D                28
-#define bci_PUSH_APPLY_L                29
-#define bci_PUSH_APPLY_V                30
-#define bci_PUSH_APPLY_P                31
-#define bci_PUSH_APPLY_PP               32
-#define bci_PUSH_APPLY_PPP              33
-#define bci_PUSH_APPLY_PPPP             34
-#define bci_PUSH_APPLY_PPPPP            35
-#define bci_PUSH_APPLY_PPPPPP           36
-/* #define bci_PUSH_APPLY_PPPPPPP          37 */
-#define bci_SLIDE                       38
-#define bci_ALLOC_AP                    39
-#define bci_ALLOC_AP_NOUPD              40
-#define bci_ALLOC_PAP                   41
-#define bci_MKAP                        42
-#define bci_MKPAP                       43
-#define bci_UNPACK                      44
-#define bci_PACK                        45
-#define bci_TESTLT_I                    46
-#define bci_TESTEQ_I                    47
-#define bci_TESTLT_F                    48
-#define bci_TESTEQ_F                    49
-#define bci_TESTLT_D                    50
-#define bci_TESTEQ_D                    51
-#define bci_TESTLT_P                    52
-#define bci_TESTEQ_P                    53
-#define bci_CASEFAIL                    54
-#define bci_JMP                         55
-#define bci_CCALL                       56
-#define bci_SWIZZLE                     57
-#define bci_ENTER                       58
-#define bci_RETURN                      59
-#define bci_RETURN_P                    60
-#define bci_RETURN_N                    61
-#define bci_RETURN_F                    62
-#define bci_RETURN_D                    63
-#define bci_RETURN_L                    64
-#define bci_RETURN_V                    65
-#define bci_BRK_FUN                     66
-#define bci_TESTLT_W                    67
-#define bci_TESTEQ_W                    68
-
-#define bci_RETURN_T                    69
-#define bci_PUSH_ALTS_T                 70
-/* If you need to go past 255 then you will run into the flags */
-
-/* If you need to go below 0x0100 then you will run into the instructions */
-#define bci_FLAG_LARGE_ARGS 0x8000
-
-/* If a BCO definitely requires less than this many words of stack,
-   don't include an explicit STKCHECK insn in it.  The interpreter
-   will check for this many words of stack before running each BCO,
-   rendering an explicit check unnecessary in the majority of
-   cases. */
-#define INTERP_STACK_CHECK_THRESH 50
-
-/*-------------------------------------------------------------------------*/
diff --git a/compiler/ClosureTypes.h b/compiler/ClosureTypes.h
deleted file mode 100644
--- a/compiler/ClosureTypes.h
+++ /dev/null
@@ -1,91 +0,0 @@
-/* ----------------------------------------------------------------------------
- *
- * (c) The GHC Team, 1998-2005
- *
- * Closure Type Constants: out here because the native code generator
- * needs to get at them.
- *
- * -------------------------------------------------------------------------- */
-
-#pragma once
-
-/*
- * WARNING WARNING WARNING
- *
- * If you add or delete any closure types, don't forget to update the following,
- *   - the closure flags table in rts/ClosureFlags.c
- *   - isRetainer in rts/RetainerProfile.c
- *   - the closure_type_names list in rts/Printer.c
- */
-
-/* CONSTR/THUNK/FUN_$A_$B mean they have $A pointers followed by $B
- * non-pointers in their payloads.
- */
-
-/* Object tag 0 raises an internal error */
-#define INVALID_OBJECT                0
-#define CONSTR                        1
-#define CONSTR_1_0                    2
-#define CONSTR_0_1                    3
-#define CONSTR_2_0                    4
-#define CONSTR_1_1                    5
-#define CONSTR_0_2                    6
-#define CONSTR_NOCAF                  7
-#define FUN                           8
-#define FUN_1_0                       9
-#define FUN_0_1                       10
-#define FUN_2_0                       11
-#define FUN_1_1                       12
-#define FUN_0_2                       13
-#define FUN_STATIC                    14
-#define THUNK                         15
-#define THUNK_1_0                     16
-#define THUNK_0_1                     17
-#define THUNK_2_0                     18
-#define THUNK_1_1                     19
-#define THUNK_0_2                     20
-#define THUNK_STATIC                  21
-#define THUNK_SELECTOR                22
-#define BCO                           23
-#define AP                            24
-#define PAP                           25
-#define AP_STACK                      26
-#define IND                           27
-#define IND_STATIC                    28
-#define RET_BCO                       29
-#define RET_SMALL                     30
-#define RET_BIG                       31
-#define RET_FUN                       32
-#define UPDATE_FRAME                  33
-#define CATCH_FRAME                   34
-#define UNDERFLOW_FRAME               35
-#define STOP_FRAME                    36
-#define BLOCKING_QUEUE                37
-#define BLACKHOLE                     38
-#define MVAR_CLEAN                    39
-#define MVAR_DIRTY                    40
-#define TVAR                          41
-#define ARR_WORDS                     42
-#define MUT_ARR_PTRS_CLEAN            43
-#define MUT_ARR_PTRS_DIRTY            44
-#define MUT_ARR_PTRS_FROZEN_DIRTY     45
-#define MUT_ARR_PTRS_FROZEN_CLEAN     46
-#define MUT_VAR_CLEAN                 47
-#define MUT_VAR_DIRTY                 48
-#define WEAK                          49
-#define PRIM                          50
-#define MUT_PRIM                      51
-#define TSO                           52
-#define STACK                         53
-#define TREC_CHUNK                    54
-#define ATOMICALLY_FRAME              55
-#define CATCH_RETRY_FRAME             56
-#define CATCH_STM_FRAME               57
-#define WHITEHOLE                     58
-#define SMALL_MUT_ARR_PTRS_CLEAN      59
-#define SMALL_MUT_ARR_PTRS_DIRTY      60
-#define SMALL_MUT_ARR_PTRS_FROZEN_DIRTY 61
-#define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62
-#define COMPACT_NFDATA                63
-#define CONTINUATION                  64
-#define N_CLOSURE_TYPES               65
diff --git a/compiler/CodeGen.Platform.h b/compiler/CodeGen.Platform.h
deleted file mode 100644
--- a/compiler/CodeGen.Platform.h
+++ /dev/null
@@ -1,1023 +0,0 @@
-
-import GHC.Cmm.Expr
-#if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \
-    || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64))
-import GHC.Utils.Panic.Plain
-#endif
-import GHC.Platform.Reg
-
-#include "MachRegs.h"
-
-#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)
-
-# if defined(MACHREGS_i386)
-#  define eax 0
-#  define ebx 1
-#  define ecx 2
-#  define edx 3
-#  define esi 4
-#  define edi 5
-#  define ebp 6
-#  define esp 7
-# endif
-
-# if defined(MACHREGS_x86_64)
-#  define rax   0
-#  define rbx   1
-#  define rcx   2
-#  define rdx   3
-#  define rsi   4
-#  define rdi   5
-#  define rbp   6
-#  define rsp   7
-#  define r8    8
-#  define r9    9
-#  define r10   10
-#  define r11   11
-#  define r12   12
-#  define r13   13
-#  define r14   14
-#  define r15   15
-# endif
-
-
--- N.B. XMM, YMM, and ZMM are all aliased to the same hardware registers hence
--- being assigned the same RegNos.
-# define xmm0  16
-# define xmm1  17
-# define xmm2  18
-# define xmm3  19
-# define xmm4  20
-# define xmm5  21
-# define xmm6  22
-# define xmm7  23
-# define xmm8  24
-# define xmm9  25
-# define xmm10 26
-# define xmm11 27
-# define xmm12 28
-# define xmm13 29
-# define xmm14 30
-# define xmm15 31
-
-# define ymm0  16
-# define ymm1  17
-# define ymm2  18
-# define ymm3  19
-# define ymm4  20
-# define ymm5  21
-# define ymm6  22
-# define ymm7  23
-# define ymm8  24
-# define ymm9  25
-# define ymm10 26
-# define ymm11 27
-# define ymm12 28
-# define ymm13 29
-# define ymm14 30
-# define ymm15 31
-
-# define zmm0  16
-# define zmm1  17
-# define zmm2  18
-# define zmm3  19
-# define zmm4  20
-# define zmm5  21
-# define zmm6  22
-# define zmm7  23
-# define zmm8  24
-# define zmm9  25
-# define zmm10 26
-# define zmm11 27
-# define zmm12 28
-# define zmm13 29
-# define zmm14 30
-# define zmm15 31
-
--- Note: these are only needed for ARM/AArch64 because globalRegMaybe is now used in CmmSink.hs.
--- Since it's only used to check 'isJust', the actual values don't matter, thus
--- I'm not sure if these are the correct numberings.
--- Normally, the register names are just stringified as part of the REG() macro
-
-#elif defined(MACHREGS_powerpc) || defined(MACHREGS_arm) \
-    || defined(MACHREGS_aarch64)
-
-# define r0 0
-# define r1 1
-# define r2 2
-# define r3 3
-# define r4 4
-# define r5 5
-# define r6 6
-# define r7 7
-# define r8 8
-# define r9 9
-# define r10 10
-# define r11 11
-# define r12 12
-# define r13 13
-# define r14 14
-# define r15 15
-# define r16 16
-# define r17 17
-# define r18 18
-# define r19 19
-# define r20 20
-# define r21 21
-# define r22 22
-# define r23 23
-# define r24 24
-# define r25 25
-# define r26 26
-# define r27 27
-# define r28 28
-# define r29 29
-# define r30 30
-# define r31 31
-
--- See note above. These aren't actually used for anything except satisfying the compiler for globalRegMaybe
--- so I'm unsure if they're the correct numberings, should they ever be attempted to be used in the NCG.
-#if defined(MACHREGS_aarch64) || defined(MACHREGS_arm)
-# define s0 32
-# define s1 33
-# define s2 34
-# define s3 35
-# define s4 36
-# define s5 37
-# define s6 38
-# define s7 39
-# define s8 40
-# define s9 41
-# define s10 42
-# define s11 43
-# define s12 44
-# define s13 45
-# define s14 46
-# define s15 47
-# define s16 48
-# define s17 49
-# define s18 50
-# define s19 51
-# define s20 52
-# define s21 53
-# define s22 54
-# define s23 55
-# define s24 56
-# define s25 57
-# define s26 58
-# define s27 59
-# define s28 60
-# define s29 61
-# define s30 62
-# define s31 63
-
-# define d0 32
-# define d1 33
-# define d2 34
-# define d3 35
-# define d4 36
-# define d5 37
-# define d6 38
-# define d7 39
-# define d8 40
-# define d9 41
-# define d10 42
-# define d11 43
-# define d12 44
-# define d13 45
-# define d14 46
-# define d15 47
-# define d16 48
-# define d17 49
-# define d18 50
-# define d19 51
-# define d20 52
-# define d21 53
-# define d22 54
-# define d23 55
-# define d24 56
-# define d25 57
-# define d26 58
-# define d27 59
-# define d28 60
-# define d29 61
-# define d30 62
-# define d31 63
-#endif
-
-# if defined(MACHREGS_darwin)
-#  define f0  32
-#  define f1  33
-#  define f2  34
-#  define f3  35
-#  define f4  36
-#  define f5  37
-#  define f6  38
-#  define f7  39
-#  define f8  40
-#  define f9  41
-#  define f10 42
-#  define f11 43
-#  define f12 44
-#  define f13 45
-#  define f14 46
-#  define f15 47
-#  define f16 48
-#  define f17 49
-#  define f18 50
-#  define f19 51
-#  define f20 52
-#  define f21 53
-#  define f22 54
-#  define f23 55
-#  define f24 56
-#  define f25 57
-#  define f26 58
-#  define f27 59
-#  define f28 60
-#  define f29 61
-#  define f30 62
-#  define f31 63
-# else
-#  define fr0  32
-#  define fr1  33
-#  define fr2  34
-#  define fr3  35
-#  define fr4  36
-#  define fr5  37
-#  define fr6  38
-#  define fr7  39
-#  define fr8  40
-#  define fr9  41
-#  define fr10 42
-#  define fr11 43
-#  define fr12 44
-#  define fr13 45
-#  define fr14 46
-#  define fr15 47
-#  define fr16 48
-#  define fr17 49
-#  define fr18 50
-#  define fr19 51
-#  define fr20 52
-#  define fr21 53
-#  define fr22 54
-#  define fr23 55
-#  define fr24 56
-#  define fr25 57
-#  define fr26 58
-#  define fr27 59
-#  define fr28 60
-#  define fr29 61
-#  define fr30 62
-#  define fr31 63
-# endif
-
-#elif defined(MACHREGS_s390x)
-
-# define r0   0
-# define r1   1
-# define r2   2
-# define r3   3
-# define r4   4
-# define r5   5
-# define r6   6
-# define r7   7
-# define r8   8
-# define r9   9
-# define r10 10
-# define r11 11
-# define r12 12
-# define r13 13
-# define r14 14
-# define r15 15
-
-# define f0  16
-# define f1  17
-# define f2  18
-# define f3  19
-# define f4  20
-# define f5  21
-# define f6  22
-# define f7  23
-# define f8  24
-# define f9  25
-# define f10 26
-# define f11 27
-# define f12 28
-# define f13 29
-# define f14 30
-# define f15 31
-
-#elif defined(MACHREGS_riscv64)
-
-# define zero 0
-# define ra   1
-# define sp   2
-# define gp   3
-# define tp   4
-# define t0   5
-# define t1   6
-# define t2   7
-# define s0   8
-# define s1   9
-# define a0  10
-# define a1  11
-# define a2  12
-# define a3  13
-# define a4  14
-# define a5  15
-# define a6  16
-# define a7  17
-# define s2  18
-# define s3  19
-# define s4  20
-# define s5  21
-# define s6  22
-# define s7  23
-# define s8  24
-# define s9  25
-# define s10 26
-# define s11 27
-# define t3  28
-# define t4  29
-# define t5  30
-# define t6  31
-
-# define ft0  32
-# define ft1  33
-# define ft2  34
-# define ft3  35
-# define ft4  36
-# define ft5  37
-# define ft6  38
-# define ft7  39
-# define fs0  40
-# define fs1  41
-# define fa0  42
-# define fa1  43
-# define fa2  44
-# define fa3  45
-# define fa4  46
-# define fa5  47
-# define fa6  48
-# define fa7  49
-# define fs2  50
-# define fs3  51
-# define fs4  52
-# define fs5  53
-# define fs6  54
-# define fs7  55
-# define fs8  56
-# define fs9  57
-# define fs10 58
-# define fs11 59
-# define ft8  60
-# define ft9  61
-# define ft10 62
-# define ft11 63
-
-#endif
-
-callerSaves :: GlobalReg -> Bool
-#if defined(CALLER_SAVES_Base)
-callerSaves BaseReg           = True
-#endif
-#if defined(CALLER_SAVES_R1)
-callerSaves (VanillaReg 1 _)  = True
-#endif
-#if defined(CALLER_SAVES_R2)
-callerSaves (VanillaReg 2 _)  = True
-#endif
-#if defined(CALLER_SAVES_R3)
-callerSaves (VanillaReg 3 _)  = True
-#endif
-#if defined(CALLER_SAVES_R4)
-callerSaves (VanillaReg 4 _)  = True
-#endif
-#if defined(CALLER_SAVES_R5)
-callerSaves (VanillaReg 5 _)  = True
-#endif
-#if defined(CALLER_SAVES_R6)
-callerSaves (VanillaReg 6 _)  = True
-#endif
-#if defined(CALLER_SAVES_R7)
-callerSaves (VanillaReg 7 _)  = True
-#endif
-#if defined(CALLER_SAVES_R8)
-callerSaves (VanillaReg 8 _)  = True
-#endif
-#if defined(CALLER_SAVES_R9)
-callerSaves (VanillaReg 9 _)  = True
-#endif
-#if defined(CALLER_SAVES_R10)
-callerSaves (VanillaReg 10 _) = True
-#endif
-#if defined(CALLER_SAVES_F1)
-callerSaves (FloatReg 1)      = True
-#endif
-#if defined(CALLER_SAVES_F2)
-callerSaves (FloatReg 2)      = True
-#endif
-#if defined(CALLER_SAVES_F3)
-callerSaves (FloatReg 3)      = True
-#endif
-#if defined(CALLER_SAVES_F4)
-callerSaves (FloatReg 4)      = True
-#endif
-#if defined(CALLER_SAVES_F5)
-callerSaves (FloatReg 5)      = True
-#endif
-#if defined(CALLER_SAVES_F6)
-callerSaves (FloatReg 6)      = True
-#endif
-#if defined(CALLER_SAVES_D1)
-callerSaves (DoubleReg 1)     = True
-#endif
-#if defined(CALLER_SAVES_D2)
-callerSaves (DoubleReg 2)     = True
-#endif
-#if defined(CALLER_SAVES_D3)
-callerSaves (DoubleReg 3)     = True
-#endif
-#if defined(CALLER_SAVES_D4)
-callerSaves (DoubleReg 4)     = True
-#endif
-#if defined(CALLER_SAVES_D5)
-callerSaves (DoubleReg 5)     = True
-#endif
-#if defined(CALLER_SAVES_D6)
-callerSaves (DoubleReg 6)     = True
-#endif
-#if defined(CALLER_SAVES_L1)
-callerSaves (LongReg 1)       = True
-#endif
-#if defined(CALLER_SAVES_Sp)
-callerSaves Sp                = True
-#endif
-#if defined(CALLER_SAVES_SpLim)
-callerSaves SpLim             = True
-#endif
-#if defined(CALLER_SAVES_Hp)
-callerSaves Hp                = True
-#endif
-#if defined(CALLER_SAVES_HpLim)
-callerSaves HpLim             = True
-#endif
-#if defined(CALLER_SAVES_CCCS)
-callerSaves CCCS              = True
-#endif
-#if defined(CALLER_SAVES_CurrentTSO)
-callerSaves CurrentTSO        = True
-#endif
-#if defined(CALLER_SAVES_CurrentNursery)
-callerSaves CurrentNursery    = True
-#endif
-callerSaves _                 = False
-
-activeStgRegs :: [GlobalReg]
-activeStgRegs = [
-#if defined(REG_Base)
-    BaseReg
-#endif
-#if defined(REG_Sp)
-    ,Sp
-#endif
-#if defined(REG_Hp)
-    ,Hp
-#endif
-#if defined(REG_R1)
-    ,VanillaReg 1 VGcPtr
-#endif
-#if defined(REG_R2)
-    ,VanillaReg 2 VGcPtr
-#endif
-#if defined(REG_R3)
-    ,VanillaReg 3 VGcPtr
-#endif
-#if defined(REG_R4)
-    ,VanillaReg 4 VGcPtr
-#endif
-#if defined(REG_R5)
-    ,VanillaReg 5 VGcPtr
-#endif
-#if defined(REG_R6)
-    ,VanillaReg 6 VGcPtr
-#endif
-#if defined(REG_R7)
-    ,VanillaReg 7 VGcPtr
-#endif
-#if defined(REG_R8)
-    ,VanillaReg 8 VGcPtr
-#endif
-#if defined(REG_R9)
-    ,VanillaReg 9 VGcPtr
-#endif
-#if defined(REG_R10)
-    ,VanillaReg 10 VGcPtr
-#endif
-#if defined(REG_SpLim)
-    ,SpLim
-#endif
-#if MAX_REAL_XMM_REG != 0
-#if defined(REG_F1)
-    ,FloatReg 1
-#endif
-#if defined(REG_D1)
-    ,DoubleReg 1
-#endif
-#if defined(REG_XMM1)
-    ,XmmReg 1
-#endif
-#if defined(REG_YMM1)
-    ,YmmReg 1
-#endif
-#if defined(REG_ZMM1)
-    ,ZmmReg 1
-#endif
-#if defined(REG_F2)
-    ,FloatReg 2
-#endif
-#if defined(REG_D2)
-    ,DoubleReg 2
-#endif
-#if defined(REG_XMM2)
-    ,XmmReg 2
-#endif
-#if defined(REG_YMM2)
-    ,YmmReg 2
-#endif
-#if defined(REG_ZMM2)
-    ,ZmmReg 2
-#endif
-#if defined(REG_F3)
-    ,FloatReg 3
-#endif
-#if defined(REG_D3)
-    ,DoubleReg 3
-#endif
-#if defined(REG_XMM3)
-    ,XmmReg 3
-#endif
-#if defined(REG_YMM3)
-    ,YmmReg 3
-#endif
-#if defined(REG_ZMM3)
-    ,ZmmReg 3
-#endif
-#if defined(REG_F4)
-    ,FloatReg 4
-#endif
-#if defined(REG_D4)
-    ,DoubleReg 4
-#endif
-#if defined(REG_XMM4)
-    ,XmmReg 4
-#endif
-#if defined(REG_YMM4)
-    ,YmmReg 4
-#endif
-#if defined(REG_ZMM4)
-    ,ZmmReg 4
-#endif
-#if defined(REG_F5)
-    ,FloatReg 5
-#endif
-#if defined(REG_D5)
-    ,DoubleReg 5
-#endif
-#if defined(REG_XMM5)
-    ,XmmReg 5
-#endif
-#if defined(REG_YMM5)
-    ,YmmReg 5
-#endif
-#if defined(REG_ZMM5)
-    ,ZmmReg 5
-#endif
-#if defined(REG_F6)
-    ,FloatReg 6
-#endif
-#if defined(REG_D6)
-    ,DoubleReg 6
-#endif
-#if defined(REG_XMM6)
-    ,XmmReg 6
-#endif
-#if defined(REG_YMM6)
-    ,YmmReg 6
-#endif
-#if defined(REG_ZMM6)
-    ,ZmmReg 6
-#endif
-#else /* MAX_REAL_XMM_REG == 0 */
-#if defined(REG_F1)
-    ,FloatReg 1
-#endif
-#if defined(REG_F2)
-    ,FloatReg 2
-#endif
-#if defined(REG_F3)
-    ,FloatReg 3
-#endif
-#if defined(REG_F4)
-    ,FloatReg 4
-#endif
-#if defined(REG_F5)
-    ,FloatReg 5
-#endif
-#if defined(REG_F6)
-    ,FloatReg 6
-#endif
-#if defined(REG_D1)
-    ,DoubleReg 1
-#endif
-#if defined(REG_D2)
-    ,DoubleReg 2
-#endif
-#if defined(REG_D3)
-    ,DoubleReg 3
-#endif
-#if defined(REG_D4)
-    ,DoubleReg 4
-#endif
-#if defined(REG_D5)
-    ,DoubleReg 5
-#endif
-#if defined(REG_D6)
-    ,DoubleReg 6
-#endif
-#endif /* MAX_REAL_XMM_REG == 0 */
-    ]
-
-haveRegBase :: Bool
-#if defined(REG_Base)
-haveRegBase = True
-#else
-haveRegBase = False
-#endif
-
---  | Returns 'Nothing' if this global register is not stored
--- in a real machine register, otherwise returns @'Just' reg@, where
--- reg is the machine register it is stored in.
-globalRegMaybe :: GlobalReg -> Maybe RealReg
-#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \
-    || defined(MACHREGS_powerpc) \
-    || defined(MACHREGS_arm) || defined(MACHREGS_aarch64) \
-    || defined(MACHREGS_s390x) || defined(MACHREGS_riscv64) \
-    || defined(MACHREGS_wasm32)
-# if defined(REG_Base)
-globalRegMaybe BaseReg                  = Just (RealRegSingle REG_Base)
-# endif
-# if defined(REG_R1)
-globalRegMaybe (VanillaReg 1 _)         = Just (RealRegSingle REG_R1)
-# endif
-# if defined(REG_R2)
-globalRegMaybe (VanillaReg 2 _)         = Just (RealRegSingle REG_R2)
-# endif
-# if defined(REG_R3)
-globalRegMaybe (VanillaReg 3 _)         = Just (RealRegSingle REG_R3)
-# endif
-# if defined(REG_R4)
-globalRegMaybe (VanillaReg 4 _)         = Just (RealRegSingle REG_R4)
-# endif
-# if defined(REG_R5)
-globalRegMaybe (VanillaReg 5 _)         = Just (RealRegSingle REG_R5)
-# endif
-# if defined(REG_R6)
-globalRegMaybe (VanillaReg 6 _)         = Just (RealRegSingle REG_R6)
-# endif
-# if defined(REG_R7)
-globalRegMaybe (VanillaReg 7 _)         = Just (RealRegSingle REG_R7)
-# endif
-# if defined(REG_R8)
-globalRegMaybe (VanillaReg 8 _)         = Just (RealRegSingle REG_R8)
-# endif
-# if defined(REG_R9)
-globalRegMaybe (VanillaReg 9 _)         = Just (RealRegSingle REG_R9)
-# endif
-# if defined(REG_R10)
-globalRegMaybe (VanillaReg 10 _)        = Just (RealRegSingle REG_R10)
-# endif
-# if defined(REG_F1)
-globalRegMaybe (FloatReg 1)             = Just (RealRegSingle REG_F1)
-# endif
-# if defined(REG_F2)
-globalRegMaybe (FloatReg 2)             = Just (RealRegSingle REG_F2)
-# endif
-# if defined(REG_F3)
-globalRegMaybe (FloatReg 3)             = Just (RealRegSingle REG_F3)
-# endif
-# if defined(REG_F4)
-globalRegMaybe (FloatReg 4)             = Just (RealRegSingle REG_F4)
-# endif
-# if defined(REG_F5)
-globalRegMaybe (FloatReg 5)             = Just (RealRegSingle REG_F5)
-# endif
-# if defined(REG_F6)
-globalRegMaybe (FloatReg 6)             = Just (RealRegSingle REG_F6)
-# endif
-# if defined(REG_D1)
-globalRegMaybe (DoubleReg 1)            = Just (RealRegSingle REG_D1)
-# endif
-# if defined(REG_D2)
-globalRegMaybe (DoubleReg 2)            = Just (RealRegSingle REG_D2)
-# endif
-# if defined(REG_D3)
-globalRegMaybe (DoubleReg 3)            = Just (RealRegSingle REG_D3)
-# endif
-# if defined(REG_D4)
-globalRegMaybe (DoubleReg 4)            = Just (RealRegSingle REG_D4)
-# endif
-# if defined(REG_D5)
-globalRegMaybe (DoubleReg 5)            = Just (RealRegSingle REG_D5)
-# endif
-# if defined(REG_D6)
-globalRegMaybe (DoubleReg 6)            = Just (RealRegSingle REG_D6)
-# endif
-# if MAX_REAL_XMM_REG != 0
-#  if defined(REG_XMM1)
-globalRegMaybe (XmmReg 1)               = Just (RealRegSingle REG_XMM1)
-#  endif
-#  if defined(REG_XMM2)
-globalRegMaybe (XmmReg 2)               = Just (RealRegSingle REG_XMM2)
-#  endif
-#  if defined(REG_XMM3)
-globalRegMaybe (XmmReg 3)               = Just (RealRegSingle REG_XMM3)
-#  endif
-#  if defined(REG_XMM4)
-globalRegMaybe (XmmReg 4)               = Just (RealRegSingle REG_XMM4)
-#  endif
-#  if defined(REG_XMM5)
-globalRegMaybe (XmmReg 5)               = Just (RealRegSingle REG_XMM5)
-#  endif
-#  if defined(REG_XMM6)
-globalRegMaybe (XmmReg 6)               = Just (RealRegSingle REG_XMM6)
-#  endif
-# endif
-# if defined(MAX_REAL_YMM_REG) && MAX_REAL_YMM_REG != 0
-#  if defined(REG_YMM1)
-globalRegMaybe (YmmReg 1)               = Just (RealRegSingle REG_YMM1)
-#  endif
-#  if defined(REG_YMM2)
-globalRegMaybe (YmmReg 2)               = Just (RealRegSingle REG_YMM2)
-#  endif
-#  if defined(REG_YMM3)
-globalRegMaybe (YmmReg 3)               = Just (RealRegSingle REG_YMM3)
-#  endif
-#  if defined(REG_YMM4)
-globalRegMaybe (YmmReg 4)               = Just (RealRegSingle REG_YMM4)
-#  endif
-#  if defined(REG_YMM5)
-globalRegMaybe (YmmReg 5)               = Just (RealRegSingle REG_YMM5)
-#  endif
-#  if defined(REG_YMM6)
-globalRegMaybe (YmmReg 6)               = Just (RealRegSingle REG_YMM6)
-#  endif
-# endif
-# if defined(MAX_REAL_ZMM_REG) && MAX_REAL_ZMM_REG != 0
-#  if defined(REG_ZMM1)
-globalRegMaybe (ZmmReg 1)               = Just (RealRegSingle REG_ZMM1)
-#  endif
-#  if defined(REG_ZMM2)
-globalRegMaybe (ZmmReg 2)               = Just (RealRegSingle REG_ZMM2)
-#  endif
-#  if defined(REG_ZMM3)
-globalRegMaybe (ZmmReg 3)               = Just (RealRegSingle REG_ZMM3)
-#  endif
-#  if defined(REG_ZMM4)
-globalRegMaybe (ZmmReg 4)               = Just (RealRegSingle REG_ZMM4)
-#  endif
-#  if defined(REG_ZMM5)
-globalRegMaybe (ZmmReg 5)               = Just (RealRegSingle REG_ZMM5)
-#  endif
-#  if defined(REG_ZMM6)
-globalRegMaybe (ZmmReg 6)               = Just (RealRegSingle REG_ZMM6)
-#  endif
-# endif
-# if defined(REG_Sp)
-globalRegMaybe Sp                       = Just (RealRegSingle REG_Sp)
-# endif
-# if defined(REG_Lng1)
-globalRegMaybe (LongReg 1)              = Just (RealRegSingle REG_Lng1)
-# endif
-# if defined(REG_Lng2)
-globalRegMaybe (LongReg 2)              = Just (RealRegSingle REG_Lng2)
-# endif
-# if defined(REG_SpLim)
-globalRegMaybe SpLim                    = Just (RealRegSingle REG_SpLim)
-# endif
-# if defined(REG_Hp)
-globalRegMaybe Hp                       = Just (RealRegSingle REG_Hp)
-# endif
-# if defined(REG_HpLim)
-globalRegMaybe HpLim                    = Just (RealRegSingle REG_HpLim)
-# endif
-# if defined(REG_CurrentTSO)
-globalRegMaybe CurrentTSO               = Just (RealRegSingle REG_CurrentTSO)
-# endif
-# if defined(REG_CurrentNursery)
-globalRegMaybe CurrentNursery           = Just (RealRegSingle REG_CurrentNursery)
-# endif
-# if defined(REG_MachSp)
-globalRegMaybe MachSp                   = Just (RealRegSingle REG_MachSp)
-# endif
-globalRegMaybe _                        = Nothing
-#elif defined(MACHREGS_NO_REGS)
-globalRegMaybe _ = Nothing
-#else
-globalRegMaybe = panic "globalRegMaybe not defined for this platform"
-#endif
-
-freeReg :: RegNo -> Bool
-
-#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)
-
-# if defined(MACHREGS_i386)
-freeReg esp = False -- %esp is the C stack pointer
-freeReg esi = False -- See Note [esi/edi/ebp not allocatable]
-freeReg edi = False
-freeReg ebp = False
-# endif
-# if defined(MACHREGS_x86_64)
-freeReg rsp = False  --        %rsp is the C stack pointer
-# endif
-
-{-
-Note [esi/edi/ebp not allocatable]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-%esi is mapped to R1, so %esi would normally be allocatable while it
-is not being used for R1.  However, %esi has no 8-bit version on x86,
-and the linear register allocator is not sophisticated enough to
-handle this irregularity (we need more RegClasses).  The
-graph-colouring allocator also cannot handle this - it was designed
-with more flexibility in mind, but the current implementation is
-restricted to the same set of classes as the linear allocator.
-
-Hence, on x86 esi, edi and ebp are treated as not allocatable.
--}
-
--- split patterns in two functions to prevent overlaps
-freeReg r         = freeRegBase r
-
-freeRegBase :: RegNo -> Bool
-# if defined(REG_Base)
-freeRegBase REG_Base  = False
-# endif
-# if defined(REG_Sp)
-freeRegBase REG_Sp    = False
-# endif
-# if defined(REG_SpLim)
-freeRegBase REG_SpLim = False
-# endif
-# if defined(REG_Hp)
-freeRegBase REG_Hp    = False
-# endif
-# if defined(REG_HpLim)
-freeRegBase REG_HpLim = False
-# endif
--- All other regs are considered to be "free", because we can track
--- their liveness accurately.
-freeRegBase _ = True
-
-#elif defined(MACHREGS_powerpc)
-
-freeReg 0 = False -- Used by code setting the back chain pointer
-                  -- in stack reallocations on Linux.
-                  -- Moreover r0 is not usable in all insns.
-freeReg 1 = False -- The Stack Pointer
--- most ELF PowerPC OSes use r2 as a TOC pointer
-freeReg 2 = False
-freeReg 13 = False -- reserved for system thread ID on 64 bit
--- at least linux in -fPIC relies on r30 in PLT stubs
-freeReg 30 = False
-{- TODO: reserve r13 on 64 bit systems only and r30 on 32 bit respectively.
-   For now we use r30 on 64 bit and r13 on 32 bit as a temporary register
-   in stack handling code. See compiler/GHC/CmmToAsm/PPC/Instr.hs.
-
-   Later we might want to reserve r13 and r30 only where it is required.
-   Then use r12 as temporary register, which is also what the C ABI does.
--}
-
-# if defined(REG_Base)
-freeReg REG_Base  = False
-# endif
-# if defined(REG_Sp)
-freeReg REG_Sp    = False
-# endif
-# if defined(REG_SpLim)
-freeReg REG_SpLim = False
-# endif
-# if defined(REG_Hp)
-freeReg REG_Hp    = False
-# endif
-# if defined(REG_HpLim)
-freeReg REG_HpLim = False
-# endif
-freeReg _ = True
-
-#elif defined(MACHREGS_aarch64)
-
--- stack pointer / zero reg
-freeReg 31 = False
--- link register
-freeReg 30 = False
--- frame pointer
-freeReg 29 = False
--- ip0 -- used for spill offset computations
-freeReg 16 = False
-
-#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)
--- x18 is reserved by the platform on Darwin/iOS, and can not be used
--- More about ARM64 ABI that Apple platforms support:
--- https://developer.apple.com/documentation/xcode/writing-arm64-code-for-apple-platforms
--- https://github.com/Siguza/ios-resources/blob/master/bits/arm64.md
-freeReg 18 = False
-#endif
-
-# if defined(REG_Base)
-freeReg REG_Base  = False
-# endif
-# if defined(REG_Sp)
-freeReg REG_Sp    = False
-# endif
-# if defined(REG_SpLim)
-freeReg REG_SpLim = False
-# endif
-# if defined(REG_Hp)
-freeReg REG_Hp    = False
-# endif
-# if defined(REG_HpLim)
-freeReg REG_HpLim = False
-# endif
-
-# if defined(REG_R1)
-freeReg REG_R1    = False
-# endif
-# if defined(REG_R2)
-freeReg REG_R2    = False
-# endif
-# if defined(REG_R3)
-freeReg REG_R3    = False
-# endif
-# if defined(REG_R4)
-freeReg REG_R4    = False
-# endif
-# if defined(REG_R5)
-freeReg REG_R5    = False
-# endif
-# if defined(REG_R6)
-freeReg REG_R6    = False
-# endif
-# if defined(REG_R7)
-freeReg REG_R7    = False
-# endif
-# if defined(REG_R8)
-freeReg REG_R8    = False
-# endif
-
-# if defined(REG_F1)
-freeReg REG_F1    = False
-# endif
-# if defined(REG_F2)
-freeReg REG_F2    = False
-# endif
-# if defined(REG_F3)
-freeReg REG_F3    = False
-# endif
-# if defined(REG_F4)
-freeReg REG_F4    = False
-# endif
-# if defined(REG_F5)
-freeReg REG_F5    = False
-# endif
-# if defined(REG_F6)
-freeReg REG_F6    = False
-# endif
-
-# if defined(REG_D1)
-freeReg REG_D1    = False
-# endif
-# if defined(REG_D2)
-freeReg REG_D2    = False
-# endif
-# if defined(REG_D3)
-freeReg REG_D3    = False
-# endif
-# if defined(REG_D4)
-freeReg REG_D4    = False
-# endif
-# if defined(REG_D5)
-freeReg REG_D5    = False
-# endif
-# if defined(REG_D6)
-freeReg REG_D6    = False
-# endif
-
-freeReg _ = True
-
-#else
-
-freeReg = panic "freeReg not defined for this platform"
-
-#endif
diff --git a/compiler/FunTypes.h b/compiler/FunTypes.h
deleted file mode 100644
--- a/compiler/FunTypes.h
+++ /dev/null
@@ -1,54 +0,0 @@
-/* -----------------------------------------------------------------------------
- *
- * (c) The GHC Team, 2002
- *
- * Things for functions.
- *
- * ---------------------------------------------------------------------------*/
-
-#pragma once
-
-/* generic - function comes with a small bitmap */
-#define ARG_GEN      0
-
-/* generic - function comes with a large bitmap */
-#define ARG_GEN_BIG  1
-
-/* BCO - function is really a BCO */
-#define ARG_BCO      2
-
-/*
- * Specialised function types: bitmaps and calling sequences
- * for these functions are pre-generated: see ghc/utils/genapply and
- * generated code in ghc/rts/AutoApply.cmm.
- *
- *  NOTE: other places to change if you change this table:
- *       - utils/genapply/Main.hs: stackApplyTypes
- *       - GHC.StgToCmm.Layout: stdPattern
- */
-#define ARG_NONE     3
-#define ARG_N        4
-#define ARG_P        5
-#define ARG_F        6
-#define ARG_D        7
-#define ARG_L        8
-#define ARG_V16      9
-#define ARG_V32      10
-#define ARG_V64      11
-#define ARG_NN       12
-#define ARG_NP       13
-#define ARG_PN       14
-#define ARG_PP       15
-#define ARG_NNN      16
-#define ARG_NNP      17
-#define ARG_NPN      18
-#define ARG_NPP      19
-#define ARG_PNN      20
-#define ARG_PNP      21
-#define ARG_PPN      22
-#define ARG_PPP      23
-#define ARG_PPPP     24
-#define ARG_PPPPP    25
-#define ARG_PPPPPP   26
-#define ARG_PPPPPPP  27
-#define ARG_PPPPPPPP 28
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
deleted file mode 100644
--- a/compiler/GHC.hs
+++ /dev/null
@@ -1,1951 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections, NamedFieldPuns #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TypeFamilies #-}
-
--- -----------------------------------------------------------------------------
---
--- (c) The University of Glasgow, 2005-2012
---
--- The GHC API
---
--- -----------------------------------------------------------------------------
-
-module GHC (
-        -- * Initialisation
-        defaultErrorHandler,
-        defaultCleanupHandler,
-        prettyPrintGhcErrors,
-        withSignalHandlers,
-        withCleanupSession,
-
-        -- * GHC Monad
-        Ghc, GhcT, GhcMonad(..), HscEnv,
-        runGhc, runGhcT, initGhcMonad,
-        printException,
-        handleSourceError,
-
-        -- * Flags and settings
-        DynFlags(..), GeneralFlag(..), Severity(..), Backend, gopt,
-        ncgBackend, llvmBackend, viaCBackend, interpreterBackend, noBackend,
-        GhcMode(..), GhcLink(..),
-        parseDynamicFlags, parseTargetFiles,
-        getSessionDynFlags,
-        setTopSessionDynFlags,
-        setSessionDynFlags,
-        setUnitDynFlags,
-        getProgramDynFlags, setProgramDynFlags,
-        getInteractiveDynFlags, setInteractiveDynFlags,
-        interpretPackageEnv,
-
-        -- * Logging
-        Logger, getLogger,
-        pushLogHook, popLogHook,
-        pushLogHookM, popLogHookM, modifyLogger,
-        putMsgM, putLogMsgM,
-
-
-        -- * Targets
-        Target(..), TargetId(..), Phase,
-        setTargets,
-        getTargets,
-        addTarget,
-        removeTarget,
-        guessTarget,
-
-        -- * Loading\/compiling the program
-        depanal, depanalE,
-        load, loadWithCache, LoadHowMuch(..), InteractiveImport(..),
-        SuccessFlag(..), succeeded, failed,
-        defaultWarnErrLogger, WarnErrLogger,
-        workingDirectoryChanged,
-        parseModule, typecheckModule, desugarModule,
-        ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
-        TypecheckedSource, ParsedSource, RenamedSource,   -- ditto
-        TypecheckedMod, ParsedMod,
-        moduleInfo, renamedSource, typecheckedSource,
-        parsedSource, coreModule,
-        PkgQual(..),
-
-        -- ** Compiling to Core
-        CoreModule(..),
-        compileToCoreModule, compileToCoreSimplified,
-
-        -- * Inspecting the module structure of the program
-        ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
-        mgLookupModule,
-        ModSummary(..), ms_mod_name, ModLocation(..),
-        getModSummary,
-        getModuleGraph,
-        isLoaded,
-        isLoadedModule,
-        topSortModuleGraph,
-
-        -- * Inspecting modules
-        ModuleInfo,
-        getModuleInfo,
-        modInfoTyThings,
-        modInfoTopLevelScope,
-        modInfoExports,
-        modInfoExportsWithSelectors,
-        modInfoInstances,
-        modInfoIsExportedName,
-        modInfoLookupName,
-        modInfoIface,
-        modInfoRdrEnv,
-        modInfoSafe,
-        lookupGlobalName,
-        findGlobalAnns,
-        mkNamePprCtxForModule,
-        ModIface, ModIface_(..),
-        SafeHaskellMode(..),
-
-        -- * Printing
-        NamePprCtx, alwaysQualify,
-
-        -- * Interactive evaluation
-
-        -- ** Executing statements
-        execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..),
-        resumeExec,
-
-        -- ** Adding new declarations
-        runDecls, runDeclsWithLocation, runParsedDecls,
-
-        -- ** Get/set the current context
-        parseImportDecl,
-        setContext, getContext,
-        setGHCiMonad, getGHCiMonad,
-
-        -- ** Inspecting the current context
-        getBindings, getInsts, getNamePprCtx,
-        findModule, lookupModule,
-        findQualifiedModule, lookupQualifiedModule,
-        renamePkgQualM, renameRawPkgQualM,
-        isModuleTrusted, moduleTrustReqs,
-        getNamesInScope,
-        getRdrNamesInScope,
-        getGRE,
-        moduleIsInterpreted,
-        getInfo,
-        showModule,
-        moduleIsBootOrNotObjectLinkable,
-        getNameToInstancesIndex,
-
-        -- ** Inspecting types and kinds
-        exprType, TcRnExprMode(..),
-        typeKind,
-
-        -- ** Looking up a Name
-        parseName,
-        lookupName,
-
-        -- ** Compiling expressions
-        HValue, parseExpr, compileParsedExpr,
-        GHC.Runtime.Eval.compileExpr, dynCompileExpr,
-        ForeignHValue,
-        compileExprRemote, compileParsedExprRemote,
-
-        -- ** Docs
-        getDocs, GetDocsFailure(..),
-
-        -- ** Other
-        runTcInteractive,   -- Desired by some clients (#8878)
-        isStmt, hasImport, isImport, isDecl,
-
-        -- ** The debugger
-        SingleStep(..),
-        Resume(..),
-        History(historyBreakInfo, historyEnclosingDecls),
-        GHC.getHistorySpan, getHistoryModule,
-        abandon, abandonAll,
-        getResumeContext,
-        GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
-        modInfoModBreaks,
-        ModBreaks(..), BreakIndex,
-        BreakInfo(..),
-        GHC.Runtime.Eval.back,
-        GHC.Runtime.Eval.forward,
-        GHC.Runtime.Eval.setupBreakpoint,
-
-        -- * Abstract syntax elements
-
-        -- ** Units
-        Unit,
-
-        -- ** Modules
-        Module, mkModule, pprModule, moduleName, moduleUnit,
-
-        -- ** Names
-        Name,
-        isExternalName, nameModule, pprParenSymName, nameSrcSpan,
-        NamedThing(..),
-        RdrName(Qual,Unqual),
-
-        -- ** Identifiers
-        Id, idType,
-        isImplicitId, isDeadBinder,
-        isExportedId, isLocalId, isGlobalId,
-        isRecordSelector,
-        isPrimOpId, isFCallId, isClassOpId_maybe,
-        isDataConWorkId, idDataCon,
-        isDeadEndId, isDictonaryId,
-        recordSelectorTyCon,
-
-        -- ** Type constructors
-        TyCon,
-        tyConTyVars, tyConDataCons, tyConArity,
-        isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon,
-        isPrimTyCon,
-        isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon,
-        tyConClass_maybe,
-        synTyConRhs_maybe, synTyConDefn_maybe, tyConKind,
-
-        -- ** Type variables
-        TyVar,
-        alphaTyVars,
-
-        -- ** Data constructors
-        DataCon,
-        dataConType, dataConTyCon, dataConFieldLabels,
-        dataConIsInfix, isVanillaDataCon, dataConWrapperType,
-        dataConSrcBangs,
-        StrictnessMark(..), isMarkedStrict,
-
-        -- ** Classes
-        Class,
-        classMethods, classSCTheta, classTvsFds, classATs,
-        pprFundeps,
-
-        -- ** Instances
-        ClsInst,
-        instanceDFunId,
-        pprInstance, pprInstanceHdr,
-        pprFamInst,
-
-        FamInst,
-
-        -- ** Types and Kinds
-        Type, splitForAllTyCoVars, funResultTy,
-        pprParendType, pprTypeApp,
-        Kind,
-        PredType,
-        ThetaType, pprForAll, pprThetaArrowTy,
-        parseInstanceHead,
-        getInstancesForType,
-
-        -- ** Entities
-        TyThing(..),
-
-        -- ** Syntax
-        module GHC.Hs, -- ToDo: remove extraneous bits
-
-        -- ** Fixities
-        FixityDirection(..),
-        defaultFixity, maxPrecedence,
-        negateFixity,
-        compareFixity,
-        LexicalFixity(..),
-
-        -- ** Source locations
-        SrcLoc(..), RealSrcLoc,
-        mkSrcLoc, noSrcLoc,
-        srcLocFile, srcLocLine, srcLocCol,
-        SrcSpan(..), RealSrcSpan,
-        mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
-        srcSpanStart, srcSpanEnd,
-        srcSpanFile,
-        srcSpanStartLine, srcSpanEndLine,
-        srcSpanStartCol, srcSpanEndCol,
-
-        -- ** Located
-        GenLocated(..), Located, RealLocated,
-
-        -- *** Constructing Located
-        noLoc, mkGeneralLocated,
-
-        -- *** Deconstructing Located
-        getLoc, unLoc,
-        getRealSrcSpan, unRealSrcSpan,
-
-        -- *** Combining and comparing Located values
-        eqLocated, cmpLocated, combineLocs, addCLoc,
-        leftmost_smallest, leftmost_largest, rightmost_smallest,
-        spans, isSubspanOf,
-
-        -- * Exceptions
-        GhcException(..), showGhcException,
-        GhcApiError(..),
-
-        -- * Token stream manipulations
-        Token,
-        getTokenStream, getRichTokenStream,
-        showRichTokenStream, addSourceToTokens,
-
-        -- * Pure interface to the parser
-        parser,
-
-        -- * API Annotations
-        AnnKeywordId(..),EpaComment(..),
-
-        -- * Miscellaneous
-        --sessionHscEnv,
-        cyclicModuleErr,
-  ) where
-
-{-
- ToDo:
-
-  * inline bits of GHC.Driver.Main here to simplify layering: hscTcExpr, hscStmt.
--}
-
-import GHC.Prelude hiding (init)
-
-import GHC.Platform
-import GHC.Platform.Ways
-
-import GHC.Driver.Phases   ( Phase(..), isHaskellSrcFilename
-                           , isSourceFilename, startPhase )
-import GHC.Driver.Env
-import GHC.Driver.Errors
-import GHC.Driver.Errors.Types
-import GHC.Driver.CmdLine
-import GHC.Driver.Session
-import GHC.Driver.Backend
-import GHC.Driver.Config.Finder (initFinderOpts)
-import GHC.Driver.Config.Parser (initParserOpts)
-import GHC.Driver.Config.Logger (initLogFlags)
-import GHC.Driver.Config.Diagnostic
-import GHC.Driver.Main
-import GHC.Driver.Make
-import GHC.Driver.Hooks
-import GHC.Driver.Monad
-import GHC.Driver.Ppr
-
-import GHC.ByteCode.Types
-import qualified GHC.Linker.Loader as Loader
-import GHC.Runtime.Loader
-import GHC.Runtime.Eval
-import GHC.Runtime.Interpreter
-import GHC.Runtime.Context
-import GHCi.RemoteTypes
-
-import qualified GHC.Parser as Parser
-import GHC.Parser.Lexer
-import GHC.Parser.Annotation
-import GHC.Parser.Utils
-
-import GHC.Iface.Load        ( loadSysInterface )
-import GHC.Hs
-import GHC.Builtin.Types.Prim ( alphaTyVars )
-import GHC.Data.StringBuffer
-import GHC.Data.FastString
-import qualified GHC.LanguageExtensions as LangExt
-import GHC.Rename.Names (renamePkgQual, renameRawPkgQual)
-
-import GHC.Tc.Utils.Monad    ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
-import GHC.Tc.Types
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Module
-import GHC.Tc.Utils.Instantiate
-import GHC.Tc.Instance.Family
-
-import GHC.Utils.TmpFs
-import GHC.Utils.Error
-import GHC.Utils.Monad
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Logger
-import GHC.Utils.Fingerprint
-
-import GHC.Core.Predicate
-import GHC.Core.Type  hiding( typeKind )
-import GHC.Core.TyCon
-import GHC.Core.TyCo.Ppr   ( pprForAll )
-import GHC.Core.Class
-import GHC.Core.DataCon
-import GHC.Core.FVs        ( orphNamesOfFamInst )
-import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts )
-import GHC.Core.InstEnv
-import GHC.Core
-
-import GHC.Types.Id
-import GHC.Types.Name      hiding ( varName )
-import GHC.Types.Avail
-import GHC.Types.SrcLoc
-import GHC.Types.TyThing.Ppr  ( pprFamInst )
-import GHC.Types.Annotations
-import GHC.Types.Name.Set
-import GHC.Types.Name.Reader
-import GHC.Types.SourceError
-import GHC.Types.SafeHaskell
-import GHC.Types.Error
-import GHC.Types.Fixity
-import GHC.Types.Target
-import GHC.Types.Basic
-import GHC.Types.TyThing
-import GHC.Types.Name.Env
-import GHC.Types.Name.Ppr
-import GHC.Types.TypeEnv
-import GHC.Types.BreakInfo
-import GHC.Types.PkgQual
-
-import GHC.Unit
-import GHC.Unit.Env
-import GHC.Unit.External
-import GHC.Unit.Finder
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.ModGuts
-import GHC.Unit.Module.ModDetails
-import GHC.Unit.Module.ModSummary
-import GHC.Unit.Module.Graph
-import GHC.Unit.Home.ModInfo
-
-import Data.Foldable
-import qualified Data.Map.Strict as Map
-import Data.Set (Set)
-import qualified Data.Sequence as Seq
-import Data.Maybe
-import Data.Typeable    ( Typeable )
-import Data.Word        ( Word8 )
-import Control.Monad
-import System.Exit      ( exitWith, ExitCode(..) )
-import GHC.Utils.Exception
-import Data.IORef
-import System.FilePath
-import Control.Concurrent
-import Control.Applicative ((<|>))
-import Control.Monad.Catch as MC
-
-import GHC.Data.Maybe
-import System.IO.Error  ( isDoesNotExistError )
-import System.Environment ( getEnv, getProgName )
-import System.Directory
-import Data.List (isPrefixOf)
-import qualified Data.Set as S
-
-
--- %************************************************************************
--- %*                                                                      *
---             Initialisation: exception handlers
--- %*                                                                      *
--- %************************************************************************
-
-
--- | Install some default exception handlers and run the inner computation.
--- Unless you want to handle exceptions yourself, you should wrap this around
--- the top level of your program.  The default handlers output the error
--- message(s) to stderr and exit cleanly.
-defaultErrorHandler :: (ExceptionMonad m)
-                    => FatalMessager -> FlushOut -> m a -> m a
-defaultErrorHandler fm (FlushOut flushOut) inner =
-  -- top-level exception handler: any unrecognised exception is a compiler bug.
-  MC.handle (\exception -> liftIO $ do
-           flushOut
-           case fromException exception of
-                -- an IO exception probably isn't our fault, so don't panic
-                Just (ioe :: IOException) ->
-                  fm (show ioe)
-                _ -> case fromException exception of
-                     Just UserInterrupt ->
-                         -- Important to let this one propagate out so our
-                         -- calling process knows we were interrupted by ^C
-                         liftIO $ throwIO UserInterrupt
-                     Just StackOverflow ->
-                         fm "stack overflow: use +RTS -K<size> to increase it"
-                     _ -> case fromException exception of
-                          Just (ex :: ExitCode) -> liftIO $ throwIO ex
-                          _ ->
-                              fm (show (Panic (show exception)))
-           exitWith (ExitFailure 1)
-         ) $
-
-  -- error messages propagated as exceptions
-  handleGhcException
-            (\ge -> liftIO $ do
-                flushOut
-                case ge of
-                  Signal _       -> return ()
-                  ProgramError _ -> fm (show ge)
-                  CmdLineError _ -> fm ("<command line>: " ++ show ge)
-                  _              -> do
-                                    progName <- getProgName
-                                    fm (progName ++ ": " ++ show ge)
-                exitWith (ExitFailure 1)
-            ) $
-  inner
-
--- | This function is no longer necessary, cleanup is now done by
--- runGhc/runGhcT.
-{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-}
-defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a
-defaultCleanupHandler _ m = m
- where _warning_suppression = m `MC.onException` undefined
-
-
--- %************************************************************************
--- %*                                                                      *
---             The Ghc Monad
--- %*                                                                      *
--- %************************************************************************
-
--- | Run function for the 'Ghc' monad.
---
--- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call
--- to this function will create a new session which should not be shared among
--- several threads.
---
--- Any errors not handled inside the 'Ghc' action are propagated as IO
--- exceptions.
-
-runGhc :: Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
-       -> Ghc a           -- ^ The action to perform.
-       -> IO a
-runGhc mb_top_dir ghc = do
-  ref <- newIORef (panic "empty session")
-  let session = Session ref
-  flip unGhc session $ withSignalHandlers $ do -- catch ^C
-    initGhcMonad mb_top_dir
-    withCleanupSession ghc
-
--- | Run function for 'GhcT' monad transformer.
---
--- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call
--- to this function will create a new session which should not be shared among
--- several threads.
-
-runGhcT :: ExceptionMonad m =>
-           Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
-        -> GhcT m a        -- ^ The action to perform.
-        -> m a
-runGhcT mb_top_dir ghct = do
-  ref <- liftIO $ newIORef (panic "empty session")
-  let session = Session ref
-  flip unGhcT session $ withSignalHandlers $ do -- catch ^C
-    initGhcMonad mb_top_dir
-    withCleanupSession ghct
-
-withCleanupSession :: GhcMonad m => m a -> m a
-withCleanupSession ghc = ghc `MC.finally` cleanup
-  where
-   cleanup = do
-      hsc_env <- getSession
-      let dflags = hsc_dflags hsc_env
-      let logger = hsc_logger hsc_env
-      let tmpfs  = hsc_tmpfs hsc_env
-      liftIO $ do
-          unless (gopt Opt_KeepTmpFiles dflags) $ do
-            cleanTempFiles logger tmpfs
-            cleanTempDirs logger tmpfs
-          traverse_ stopInterp (hsc_interp hsc_env)
-          --  exceptions will be blocked while we clean the temporary files,
-          -- so there shouldn't be any difficulty if we receive further
-          -- signals.
-
--- | Initialise a GHC session.
---
--- If you implement a custom 'GhcMonad' you must call this function in the
--- monad run function.  It will initialise the session variable and clear all
--- warnings.
---
--- The first argument should point to the directory where GHC's library files
--- reside.  More precisely, this should be the output of @ghc --print-libdir@
--- of the version of GHC the module using this API is compiled with.  For
--- portability, you should use the @ghc-paths@ package, available at
--- <http://hackage.haskell.org/package/ghc-paths>.
-
-initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
-initGhcMonad mb_top_dir = setSession =<< liftIO (initHscEnv mb_top_dir)
-
--- %************************************************************************
--- %*                                                                      *
---             Flags & settings
--- %*                                                                      *
--- %************************************************************************
-
--- $DynFlags
---
--- The GHC session maintains two sets of 'DynFlags':
---
---   * The "interactive" @DynFlags@, which are used for everything
---     related to interactive evaluation, including 'runStmt',
---     'runDecls', 'exprType', 'lookupName' and so on (everything
---     under \"Interactive evaluation\" in this module).
---
---   * The "program" @DynFlags@, which are used when loading
---     whole modules with 'load'
---
--- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the
--- interactive @DynFlags@.
---
--- 'setProgramDynFlags', 'getProgramDynFlags' work with the
--- program @DynFlags@.
---
--- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags'
--- retrieves the program @DynFlags@ (for backwards compatibility).
-
--- This is a compatibility function which sets dynflags for the top session
--- as well as the unit.
-setSessionDynFlags :: (HasCallStack, GhcMonad m) => DynFlags -> m ()
-setSessionDynFlags dflags0 = do
-  hsc_env <- getSession
-  logger <- getLogger
-  dflags <- checkNewDynFlags logger dflags0
-  let all_uids = hsc_all_home_unit_ids hsc_env
-  case S.toList all_uids of
-    [uid] -> do
-      setUnitDynFlagsNoCheck uid dflags
-      modifySession (hscUpdateLoggerFlags . hscSetActiveUnitId (homeUnitId_ dflags))
-      dflags' <- getDynFlags
-      setTopSessionDynFlags dflags'
-    [] -> panic "nohue"
-    _ -> panic "setSessionDynFlags can only be used with a single home unit"
-
-
-setUnitDynFlags :: GhcMonad m => UnitId -> DynFlags -> m ()
-setUnitDynFlags uid dflags0 = do
-  logger <- getLogger
-  dflags1 <- checkNewDynFlags logger dflags0
-  setUnitDynFlagsNoCheck uid dflags1
-
-setUnitDynFlagsNoCheck :: GhcMonad m => UnitId -> DynFlags -> m ()
-setUnitDynFlagsNoCheck uid dflags1 = do
-  logger <- getLogger
-  hsc_env <- getSession
-
-  let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)
-  let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue
-  (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
-  updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
-
-  let upd hue =
-       hue
-          { homeUnitEnv_units = unit_state
-          , homeUnitEnv_unit_dbs = Just dbs
-          , homeUnitEnv_dflags = updated_dflags
-          , homeUnitEnv_home_unit = Just home_unit
-          }
-
-  let unit_env = ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env)
-
-  let dflags = updated_dflags
-
-  let unit_env0 = unit_env
-        { ue_platform        = targetPlatform dflags
-        , ue_namever         = ghcNameVersion dflags
-        }
-
-  -- if necessary, change the key for the currently active unit
-  -- as the dynflags might have been changed
-
-  -- This function is called on every --make invocation because at the start of
-  -- the session there is one fake unit called main which is immediately replaced
-  -- after the DynFlags are parsed.
-  let !unit_env1 =
-        if homeUnitId_ dflags /= uid
-          then
-            ue_renameUnitId
-                  uid
-                  (homeUnitId_ dflags)
-                  unit_env0
-          else unit_env0
-
-  modifySession $ \h -> h{ hsc_unit_env  = unit_env1
-                         }
-
-  invalidateModSummaryCache
-
-
-
-
-setTopSessionDynFlags :: GhcMonad m => DynFlags -> m ()
-setTopSessionDynFlags dflags = do
-  hsc_env <- getSession
-  logger  <- getLogger
-
-  -- Interpreter
-  interp <- if gopt Opt_ExternalInterpreter dflags
-    then do
-         let
-           prog = pgm_i dflags ++ flavour
-           profiled = ways dflags `hasWay` WayProf
-           dynamic  = ways dflags `hasWay` WayDyn
-           flavour
-             | profiled  = "-prof" -- FIXME: can't we have both?
-             | dynamic   = "-dyn"
-             | otherwise = ""
-           msg = text "Starting " <> text prog
-         tr <- if verbosity dflags >= 3
-                then return (logInfo logger $ withPprStyle defaultDumpStyle msg)
-                else return (pure ())
-         let
-          conf = IServConfig
-            { iservConfProgram  = prog
-            , iservConfOpts     = getOpts dflags opt_i
-            , iservConfProfiled = profiled
-            , iservConfDynamic  = dynamic
-            , iservConfHook     = createIservProcessHook (hsc_hooks hsc_env)
-            , iservConfTrace    = tr
-            }
-         s <- liftIO $ newMVar IServPending
-         loader <- liftIO Loader.uninitializedLoader
-         return (Just (Interp (ExternalInterp conf (IServ s)) loader))
-    else
-#if defined(HAVE_INTERNAL_INTERPRETER)
-     do
-      loader <- liftIO Loader.uninitializedLoader
-      return (Just (Interp InternalInterp loader))
-#else
-      return Nothing
-#endif
-
-
-  modifySession $ \h -> hscSetFlags dflags
-                        h{ hsc_IC = (hsc_IC h){ ic_dflags = dflags }
-                         , hsc_interp = hsc_interp h <|> interp
-                         }
-
-  invalidateModSummaryCache
-
--- | Sets the program 'DynFlags'.  Note: this invalidates the internal
--- cached module graph, causing more work to be done the next time
--- 'load' is called.
---
--- Returns a boolean indicating if preload units have changed and need to be
--- reloaded.
-setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool
-setProgramDynFlags dflags = setProgramDynFlags_ True dflags
-
-setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool
-setProgramDynFlags_ invalidate_needed dflags = do
-  logger <- getLogger
-  dflags0 <- checkNewDynFlags logger dflags
-  dflags_prev <- getProgramDynFlags
-  let changed = packageFlagsChanged dflags_prev dflags0
-  if changed
-    then do
-        -- additionally, set checked dflags so we don't lose fixes
-        old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession
-
-        home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do
-          let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
-              dflags = homeUnitEnv_dflags homeUnitEnv
-              old_hpt = homeUnitEnv_hpt homeUnitEnv
-              home_units = unitEnv_keys (ue_home_unit_graph old_unit_env)
-
-          (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
-
-          updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
-          pure HomeUnitEnv
-            { homeUnitEnv_units = unit_state
-            , homeUnitEnv_unit_dbs = Just dbs
-            , homeUnitEnv_dflags = updated_dflags
-            , homeUnitEnv_hpt = old_hpt
-            , homeUnitEnv_home_unit = Just home_unit
-            }
-
-        let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph
-        let unit_env = UnitEnv
-              { ue_platform        = targetPlatform dflags1
-              , ue_namever         = ghcNameVersion dflags1
-              , ue_home_unit_graph = home_unit_graph
-              , ue_current_unit    = ue_currentUnit old_unit_env
-              , ue_eps             = ue_eps old_unit_env
-              }
-        modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
-    else modifySession (hscSetFlags dflags0)
-
-  when invalidate_needed $ invalidateModSummaryCache
-  return changed
-
-
--- When changing the DynFlags, we want the changes to apply to future
--- loads, but without completely discarding the program.  But the
--- DynFlags are cached in each ModSummary in the hsc_mod_graph, so
--- after a change to DynFlags, the changes would apply to new modules
--- but not existing modules; this seems undesirable.
---
--- Furthermore, the GHC API client might expect that changing
--- log_action would affect future compilation messages, but for those
--- modules we have cached ModSummaries for, we'll continue to use the
--- old log_action.  This is definitely wrong (#7478).
---
--- Hence, we invalidate the ModSummary cache after changing the
--- DynFlags.  We do this by tweaking the hash on each ModSummary, so
--- that the next downsweep will think that all the files have changed
--- and preprocess them again.  This won't necessarily cause everything
--- to be recompiled, because by the time we check whether we need to
--- recompile a module, we'll have re-summarised the module and have a
--- correct ModSummary.
---
-invalidateModSummaryCache :: GhcMonad m => m ()
-invalidateModSummaryCache =
-  modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) }
- where
-  inval ms = ms { ms_hs_hash = fingerprint0 }
-
--- | Returns the program 'DynFlags'.
-getProgramDynFlags :: GhcMonad m => m DynFlags
-getProgramDynFlags = getSessionDynFlags
-
--- | Set the 'DynFlags' used to evaluate interactive expressions.
--- Also initialise (load) plugins.
---
--- Note: this cannot be used for changes to packages.  Use
--- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the
--- 'unitState' into the interactive @DynFlags@.
-setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
-setInteractiveDynFlags dflags = do
-  logger <- getLogger
-  dflags' <- checkNewDynFlags logger dflags
-  dflags'' <- checkNewInteractiveDynFlags logger dflags'
-  modifySessionM $ \hsc_env0 -> do
-    let ic0 = hsc_IC hsc_env0
-
-    -- Initialise (load) plugins in the interactive environment with the new
-    -- DynFlags
-    plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $
-                    hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }}
-
-    -- Update both plugins cache and DynFlags in the interactive context.
-    return $ hsc_env0
-                { hsc_IC = ic0
-                    { ic_plugins = hsc_plugins plugin_env
-                    , ic_dflags  = hsc_dflags  plugin_env
-                    }
-                }
-
-
--- | Get the 'DynFlags' used to evaluate interactive expressions.
-getInteractiveDynFlags :: GhcMonad m => m DynFlags
-getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))
-
-
-parseDynamicFlags
-    :: MonadIO m
-    => Logger
-    -> DynFlags
-    -> [Located String]
-    -> m (DynFlags, [Located String], [Warn])
-parseDynamicFlags logger dflags cmdline = do
-  (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline
-  -- flags that have just been read are used by the logger when loading package
-  -- env (this is checked by T16318)
-  let logger1 = setLogFlags logger (initLogFlags dflags1)
-  dflags2 <- liftIO $ interpretPackageEnv logger1 dflags1
-  return (dflags2, leftovers, warns)
-
--- | Parse command line arguments that look like files.
--- First normalises its arguments and then splits them into source files
--- and object files.
--- A source file can be turned into a 'Target' via 'guessTarget'
-parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe Phase)], [String])
-parseTargetFiles dflags0 fileish_args =
-  let
-    normal_fileish_paths = map normalise_hyp fileish_args
-    (srcs, raw_objs)         = partition_args normal_fileish_paths [] []
-    objs = map (augmentByWorkingDirectory dflags0) raw_objs
-
-    dflags1 = dflags0 { ldInputs = map (FileOption "") objs
-                                   ++ ldInputs dflags0 }
-    {-
-      We split out the object files (.o, .dll) and add them
-      to ldInputs for use by the linker.
-
-      The following things should be considered compilation manager inputs:
-
-       - haskell source files (strings ending in .hs, .lhs or other
-         haskellish extension),
-
-       - module names (not forgetting hierarchical module names),
-
-       - things beginning with '-' are flags that were not recognised by
-         the flag parser, and we want them to generate errors later in
-         checkOptions, so we class them as source files (#5921)
-
-       - and finally we consider everything without an extension to be
-         a comp manager input, as shorthand for a .hs or .lhs filename.
-
-      Everything else is considered to be a linker object, and passed
-      straight through to the linker.
-    -}
-  in (dflags1, srcs, objs)
-
--- -----------------------------------------------------------------------------
-
--- | Splitting arguments into source files and object files.  This is where we
--- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
--- file indicating the phase specified by the -x option in force, if any.
-partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
-               -> ([(String, Maybe Phase)], [String])
-partition_args [] srcs objs = (reverse srcs, reverse objs)
-partition_args ("-x":suff:args) srcs objs
-  | "none" <- suff      = partition_args args srcs objs
-  | StopLn <- phase     = partition_args args srcs (slurp ++ objs)
-  | otherwise           = partition_args rest (these_srcs ++ srcs) objs
-        where phase = startPhase suff
-              (slurp,rest) = break (== "-x") args
-              these_srcs = zip slurp (repeat (Just phase))
-partition_args (arg:args) srcs objs
-  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
-  | otherwise               = partition_args args srcs (arg:objs)
-
-
-looks_like_an_input :: String -> Bool
-looks_like_an_input m =  isSourceFilename m
-                      || looksLikeModuleName m
-                      || "-" `isPrefixOf` m
-                      || not (hasExtension m)
-
-
--- | To simplify the handling of filepaths, we normalise all filepaths right
--- away. Note the asymmetry of FilePath.normalise:
---    Linux:   p\/q -> p\/q; p\\q -> p\\q
---    Windows: p\/q -> p\\q; p\\q -> p\\q
--- #12674: Filenames starting with a hyphen get normalised from ./-foo.hs
--- to -foo.hs. We have to re-prepend the current directory.
-normalise_hyp :: FilePath -> FilePath
-normalise_hyp fp
-  | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp
-  | otherwise                           = nfp
-  where
-#if defined(mingw32_HOST_OS)
-    strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
-#else
-    strt_dot_sl = "./" `isPrefixOf` fp
-#endif
-    cur_dir = '.' : [pathSeparator]
-    nfp = normalise fp
-
------------------------------------------------------------------------------
-
--- | Checks the set of new DynFlags for possibly erroneous option
--- combinations when invoking 'setSessionDynFlags' and friends, and if
--- found, returns a fixed copy (if possible).
-checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
-checkNewDynFlags logger dflags = do
-  -- See Note [DynFlags consistency]
-  let (dflags', warnings) = makeDynFlagsConsistent dflags
-  let diag_opts = initDiagOpts dflags
-      print_config = initPrintConfig dflags
-  liftIO $ handleFlagWarnings logger print_config diag_opts (map (Warn WarningWithoutFlag) warnings)
-  return dflags'
-
-checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
-checkNewInteractiveDynFlags logger dflags0 = do
-  -- We currently don't support use of StaticPointers in expressions entered on
-  -- the REPL. See #12356.
-  if xopt LangExt.StaticPointers dflags0
-  then do
-    let diag_opts = initDiagOpts dflags0
-        print_config = initPrintConfig dflags0
-    liftIO $ printOrThrowDiagnostics logger print_config diag_opts $ singleMessage
-      $ fmap GhcDriverMessage
-      $ mkPlainMsgEnvelope diag_opts interactiveSrcSpan DriverStaticPointersNotSupported
-    return $ xopt_unset dflags0 LangExt.StaticPointers
-  else return dflags0
-
-
--- %************************************************************************
--- %*                                                                      *
---             Setting, getting, and modifying the targets
--- %*                                                                      *
--- %************************************************************************
-
--- ToDo: think about relative vs. absolute file paths. And what
--- happens when the current directory changes.
-
--- | Sets the targets for this session.  Each target may be a module name
--- or a filename.  The targets correspond to the set of root modules for
--- the program\/library.  Unloading the current program is achieved by
--- setting the current set of targets to be empty, followed by 'load'.
-setTargets :: GhcMonad m => [Target] -> m ()
-setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
-
--- | Returns the current set of targets
-getTargets :: GhcMonad m => m [Target]
-getTargets = withSession (return . hsc_targets)
-
--- | Add another target.
-addTarget :: GhcMonad m => Target -> m ()
-addTarget target
-  = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
-
--- | Remove a target
-removeTarget :: GhcMonad m => TargetId -> m ()
-removeTarget target_id
-  = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
-  where
-   filter targets = [ t | t@Target { targetId = id } <- targets, id /= target_id ]
-
--- | Attempts to guess what Target a string refers to.  This function
--- implements the @--make@/GHCi command-line syntax for filenames:
---
---   - if the string looks like a Haskell source filename, then interpret it
---     as such
---
---   - if adding a .hs or .lhs suffix yields the name of an existing file,
---     then use that
---
---   - otherwise interpret the string as a module name
---
-guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe Phase -> m Target
-guessTarget str mUnitId (Just phase)
-   = do
-     tuid <- unitIdOrHomeUnit mUnitId
-     return (Target (TargetFile str (Just phase)) True tuid Nothing)
-guessTarget str mUnitId Nothing
-   | isHaskellSrcFilename file
-   = target (TargetFile file Nothing)
-   | otherwise
-   = do exists <- liftIO $ doesFileExist hs_file
-        if exists
-           then target (TargetFile hs_file Nothing)
-           else do
-        exists <- liftIO $ doesFileExist lhs_file
-        if exists
-           then target (TargetFile lhs_file Nothing)
-           else do
-        if looksLikeModuleName file
-           then target (TargetModule (mkModuleName file))
-           else do
-        dflags <- getDynFlags
-        liftIO $ throwGhcExceptionIO
-                 (ProgramError (showSDoc dflags $
-                 text "target" <+> quotes (text file) <+>
-                 text "is not a module name or a source file"))
-     where
-         (file,obj_allowed)
-                | '*':rest <- str = (rest, False)
-                | otherwise       = (str,  True)
-
-         hs_file  = file <.> "hs"
-         lhs_file = file <.> "lhs"
-
-         target tid = do
-           tuid <- unitIdOrHomeUnit mUnitId
-           pure $ Target tid obj_allowed tuid Nothing
-
--- | Unwrap 'UnitId' or retrieve the 'UnitId'
--- of the current 'HomeUnit'.
-unitIdOrHomeUnit :: GhcMonad m => Maybe UnitId -> m UnitId
-unitIdOrHomeUnit mUnitId = do
-  currentHomeUnitId <- homeUnitId . hsc_home_unit <$> getSession
-  pure (fromMaybe currentHomeUnitId mUnitId)
-
--- | Inform GHC that the working directory has changed.  GHC will flush
--- its cache of module locations, since it may no longer be valid.
---
--- Note: Before changing the working directory make sure all threads running
--- in the same session have stopped.  If you change the working directory,
--- you should also unload the current program (set targets to empty,
--- followed by load).
-workingDirectoryChanged :: GhcMonad m => m ()
-workingDirectoryChanged = do
-  hsc_env <- getSession
-  liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)
-
-
--- %************************************************************************
--- %*                                                                      *
---             Running phases one at a time
--- %*                                                                      *
--- %************************************************************************
-
-class ParsedMod m where
-  modSummary   :: m -> ModSummary
-  parsedSource :: m -> ParsedSource
-
-class ParsedMod m => TypecheckedMod m where
-  renamedSource     :: m -> Maybe RenamedSource
-  typecheckedSource :: m -> TypecheckedSource
-  moduleInfo        :: m -> ModuleInfo
-  tm_internals      :: m -> (TcGblEnv, ModDetails)
-        -- ToDo: improvements that could be made here:
-        --  if the module succeeded renaming but not typechecking,
-        --  we can still get back the GlobalRdrEnv and exports, so
-        --  perhaps the ModuleInfo should be split up into separate
-        --  fields.
-
-class TypecheckedMod m => DesugaredMod m where
-  coreModule :: m -> ModGuts
-
--- | The result of successful parsing.
-data ParsedModule =
-  ParsedModule { pm_mod_summary   :: ModSummary
-               , pm_parsed_source :: ParsedSource
-               , pm_extra_src_files :: [FilePath] }
-
-instance ParsedMod ParsedModule where
-  modSummary m    = pm_mod_summary m
-  parsedSource m = pm_parsed_source m
-
--- | The result of successful typechecking.  It also contains the parser
---   result.
-data TypecheckedModule =
-  TypecheckedModule { tm_parsed_module       :: ParsedModule
-                    , tm_renamed_source      :: Maybe RenamedSource
-                    , tm_typechecked_source  :: TypecheckedSource
-                    , tm_checked_module_info :: ModuleInfo
-                    , tm_internals_          :: (TcGblEnv, ModDetails)
-                    }
-
-instance ParsedMod TypecheckedModule where
-  modSummary m   = modSummary (tm_parsed_module m)
-  parsedSource m = parsedSource (tm_parsed_module m)
-
-instance TypecheckedMod TypecheckedModule where
-  renamedSource m     = tm_renamed_source m
-  typecheckedSource m = tm_typechecked_source m
-  moduleInfo m        = tm_checked_module_info m
-  tm_internals m      = tm_internals_ m
-
--- | The result of successful desugaring (i.e., translation to core).  Also
---  contains all the information of a typechecked module.
-data DesugaredModule =
-  DesugaredModule { dm_typechecked_module :: TypecheckedModule
-                  , dm_core_module        :: ModGuts
-             }
-
-instance ParsedMod DesugaredModule where
-  modSummary m   = modSummary (dm_typechecked_module m)
-  parsedSource m = parsedSource (dm_typechecked_module m)
-
-instance TypecheckedMod DesugaredModule where
-  renamedSource m     = renamedSource (dm_typechecked_module m)
-  typecheckedSource m = typecheckedSource (dm_typechecked_module m)
-  moduleInfo m        = moduleInfo (dm_typechecked_module m)
-  tm_internals m      = tm_internals_ (dm_typechecked_module m)
-
-instance DesugaredMod DesugaredModule where
-  coreModule m = dm_core_module m
-
-type ParsedSource      = Located (HsModule GhcPs)
-type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
-                          Maybe (LHsDoc GhcRn))
-type TypecheckedSource = LHsBinds GhcTc
-
--- NOTE:
---   - things that aren't in the output of the typechecker right now:
---     - the export list
---     - the imports
---     - type signatures
---     - type/data/newtype declarations
---     - class declarations
---     - instances
---   - extra things in the typechecker's output:
---     - default methods are turned into top-level decls.
---     - dictionary bindings
-
--- | Return the 'ModSummary' of a module with the given name.
---
--- The module must be part of the module graph (see 'hsc_mod_graph' and
--- 'ModuleGraph').  If this is not the case, this function will throw a
--- 'GhcApiError'.
---
--- This function ignores boot modules and requires that there is only one
--- non-boot module with the given name.
-getModSummary :: GhcMonad m => ModuleName -> m ModSummary
-getModSummary mod = do
-   mg <- liftM hsc_mod_graph getSession
-   let mods_by_name = [ ms | ms <- mgModSummaries mg
-                      , ms_mod_name ms == mod
-                      , isBootSummary ms == NotBoot ]
-   case mods_by_name of
-     [] -> do dflags <- getDynFlags
-              liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")
-     [ms] -> return ms
-     multiple -> do dflags <- getDynFlags
-                    liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)
-
--- | Parse a module.
---
--- Throws a 'SourceError' on parse error.
-parseModule :: GhcMonad m => ModSummary -> m ParsedModule
-parseModule ms = do
-   hsc_env <- getSession
-   liftIO $ do
-     let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms) hsc_env
-     hpm <- hscParse lcl_hsc_env ms
-     return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))
-               -- See Note [exact print annotations] in GHC.Parser.Annotation
-
--- | Typecheck and rename a parsed module.
---
--- Throws a 'SourceError' if either fails.
-typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
-typecheckModule pmod = do
- hsc_env <- getSession
-
- liftIO $ do
-   let ms          = modSummary pmod
-   let lcl_dflags  = ms_hspp_opts ms -- take into account pragmas (OPTIONS_GHC, etc.)
-   let lcl_hsc_env = hscSetFlags lcl_dflags hsc_env
-   let lcl_logger  = hsc_logger lcl_hsc_env
-   (tc_gbl_env, rn_info) <- hscTypecheckRename lcl_hsc_env ms $
-                        HsParsedModule { hpm_module = parsedSource pmod,
-                                         hpm_src_files = pm_extra_src_files pmod }
-   details <- makeSimpleDetails lcl_logger tc_gbl_env
-   safe    <- finalSafeMode lcl_dflags tc_gbl_env
-
-   return $
-     TypecheckedModule {
-       tm_internals_          = (tc_gbl_env, details),
-       tm_parsed_module       = pmod,
-       tm_renamed_source      = rn_info,
-       tm_typechecked_source  = tcg_binds tc_gbl_env,
-       tm_checked_module_info =
-         ModuleInfo {
-           minf_type_env  = md_types details,
-           minf_exports   = md_exports details,
-           minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),
-           minf_instances = fixSafeInstances safe $ instEnvElts $ md_insts details,
-           minf_iface     = Nothing,
-           minf_safe      = safe,
-           minf_modBreaks = emptyModBreaks
-         }}
-
--- | Desugar a typechecked module.
-desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
-desugarModule tcm = do
- hsc_env <- getSession
- liftIO $ do
-   let ms = modSummary tcm
-   let (tcg, _) = tm_internals tcm
-   let lcl_hsc_env = hscSetFlags (ms_hspp_opts ms) hsc_env
-   guts <- hscDesugar lcl_hsc_env ms tcg
-   return $
-     DesugaredModule {
-       dm_typechecked_module = tcm,
-       dm_core_module        = guts
-     }
-
-
-
--- %************************************************************************
--- %*                                                                      *
---             Dealing with Core
--- %*                                                                      *
--- %************************************************************************
-
--- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for
--- the 'GHC.compileToCoreModule' interface.
-data CoreModule
-  = CoreModule {
-      -- | Module name
-      cm_module   :: !Module,
-      -- | Type environment for types declared in this module
-      cm_types    :: !TypeEnv,
-      -- | Declarations
-      cm_binds    :: CoreProgram,
-      -- | Safe Haskell mode
-      cm_safe     :: SafeHaskellMode
-    }
-
-instance Outputable CoreModule where
-   ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb,
-                    cm_safe = sf})
-    = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te
-      $$ vcat (map ppr cb)
-
--- | This is the way to get access to the Core bindings corresponding
--- to a module. 'compileToCore' parses, typechecks, and
--- desugars the module, then returns the resulting Core module (consisting of
--- the module name, type declarations, and function declarations) if
--- successful.
-compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
-compileToCoreModule = compileCore False
-
--- | Like compileToCoreModule, but invokes the simplifier, so
--- as to return simplified and tidied Core.
-compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
-compileToCoreSimplified = compileCore True
-
-compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
-compileCore simplify fn = do
-   -- First, set the target to the desired filename
-   target <- guessTarget fn Nothing Nothing
-   addTarget target
-   _ <- load LoadAllTargets
-   -- Then find dependencies
-   modGraph <- depanal [] True
-   case find ((== fn) . msHsFilePath) (mgModSummaries modGraph) of
-     Just modSummary -> do
-       -- Now we have the module name;
-       -- parse, typecheck and desugar the module
-       (tcg, mod_guts) <- -- TODO: space leaky: call hsc* directly?
-         do tm <- typecheckModule =<< parseModule modSummary
-            let tcg = fst (tm_internals tm)
-            (,) tcg . coreModule <$> desugarModule tm
-       liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $
-         if simplify
-          then do
-             -- If simplify is true: simplify (hscSimplify), then tidy
-             -- (hscTidy).
-             hsc_env <- getSession
-             simpl_guts <- liftIO $ do
-               plugins <- readIORef (tcg_th_coreplugins tcg)
-               hscSimplify hsc_env plugins mod_guts
-             tidy_guts <- liftIO $ hscTidy hsc_env simpl_guts
-             return $ Left tidy_guts
-          else
-             return $ Right mod_guts
-
-     Nothing -> panic "compileToCoreModule: target FilePath not found in\
-                           module dependency graph"
-  where -- two versions, based on whether we simplify (thus run tidyProgram,
-        -- which returns a (CgGuts, ModDetails) pair, or not (in which case
-        -- we just have a ModGuts.
-        gutsToCoreModule :: SafeHaskellMode
-                         -> Either (CgGuts, ModDetails) ModGuts
-                         -> CoreModule
-        gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule {
-          cm_module = cg_module cg,
-          cm_types  = md_types md,
-          cm_binds  = cg_binds cg,
-          cm_safe   = safe_mode
-        }
-        gutsToCoreModule safe_mode (Right mg) = CoreModule {
-          cm_module  = mg_module mg,
-          cm_types   = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
-                                           (mg_tcs mg) (mg_patsyns mg)
-                                           (mg_fam_insts mg),
-          cm_binds   = mg_binds mg,
-          cm_safe    = safe_mode
-         }
-
--- %************************************************************************
--- %*                                                                      *
---             Inspecting the session
--- %*                                                                      *
--- %************************************************************************
-
--- | Get the module dependency graph.
-getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
-getModuleGraph = liftM hsc_mod_graph getSession
-
--- | Return @True@ \<==> module is loaded.
-isLoaded :: GhcMonad m => ModuleName -> m Bool
-isLoaded m = withSession $ \hsc_env ->
-  return $! isJust (lookupHpt (hsc_HPT hsc_env) m)
-
-isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool
-isLoadedModule uid m = withSession $ \hsc_env ->
-  return $! isJust (lookupHug (hsc_HUG hsc_env) uid m)
-
--- | Return the bindings for the current interactive session.
-getBindings :: GhcMonad m => m [TyThing]
-getBindings = withSession $ \hsc_env ->
-    return $ icInScopeTTs $ hsc_IC hsc_env
-
--- | Return the instances for the current interactive session.
-getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
-getInsts = withSession $ \hsc_env ->
-    let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env)
-    in return (instEnvElts inst_env, fam_env)
-
-getNamePprCtx :: GhcMonad m => m NamePprCtx
-getNamePprCtx = withSession $ \hsc_env -> do
-  return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)
-
--- | Container for information about a 'Module'.
-data ModuleInfo = ModuleInfo {
-        minf_type_env  :: TypeEnv,
-        minf_exports   :: [AvailInfo],
-        minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
-        minf_instances :: [ClsInst],
-        minf_iface     :: Maybe ModIface,
-        minf_safe      :: SafeHaskellMode,
-        minf_modBreaks :: ModBreaks
-  }
-        -- We don't want HomeModInfo here, because a ModuleInfo applies
-        -- to package modules too.
-
-
--- | Request information about a loaded 'Module'
-getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X
-getModuleInfo mdl = withSession $ \hsc_env -> do
-  if moduleUnitId mdl `S.member` hsc_all_home_unit_ids hsc_env
-        then liftIO $ getHomeModuleInfo hsc_env mdl
-        else liftIO $ getPackageModuleInfo hsc_env mdl
-
-getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
-getPackageModuleInfo hsc_env mdl
-  = do  eps <- hscEPS hsc_env
-        iface <- hscGetModuleInterface hsc_env mdl
-        let
-            avails = mi_exports iface
-            pte    = eps_PTE eps
-            tys    = [ ty | name <- concatMap availNames avails,
-                            Just ty <- [lookupTypeEnv pte name] ]
-        --
-        return (Just (ModuleInfo {
-                        minf_type_env  = mkTypeEnv tys,
-                        minf_exports   = avails,
-                        minf_rdr_env   = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
-                        minf_instances = error "getModuleInfo: instances for package module unimplemented",
-                        minf_iface     = Just iface,
-                        minf_safe      = getSafeMode $ mi_trust iface,
-                        minf_modBreaks = emptyModBreaks
-                }))
-
-availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
-availsToGlobalRdrEnv mod_name avails
-  = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)
-  where
-      -- We're building a GlobalRdrEnv as if the user imported
-      -- all the specified modules into the global interactive module
-    imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
-    decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
-                         is_qual = False,
-                         is_dloc = srcLocSpan interactiveSrcLoc }
-
-
-getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
-getHomeModuleInfo hsc_env mdl =
-  case lookupHugByModule mdl (hsc_HUG hsc_env) of
-    Nothing  -> return Nothing
-    Just hmi -> do
-      let details = hm_details hmi
-          iface   = hm_iface hmi
-      return (Just (ModuleInfo {
-                        minf_type_env  = md_types details,
-                        minf_exports   = md_exports details,
-                        minf_rdr_env   = mi_globals $! hm_iface hmi,
-                        minf_instances = instEnvElts $ md_insts details,
-                        minf_iface     = Just iface,
-                        minf_safe      = getSafeMode $ mi_trust iface
-                       ,minf_modBreaks = getModBreaks hmi
-                        }))
-
--- | The list of top-level entities defined in a module
-modInfoTyThings :: ModuleInfo -> [TyThing]
-modInfoTyThings minf = typeEnvElts (minf_type_env minf)
-
-modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
-modInfoTopLevelScope minf
-  = fmap (map greMangledName . globalRdrEnvElts) (minf_rdr_env minf)
-
-modInfoExports :: ModuleInfo -> [Name]
-modInfoExports minf = concatMap availNames $! minf_exports minf
-
-modInfoExportsWithSelectors :: ModuleInfo -> [Name]
-modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf
-
--- | Returns the instances defined by the specified module.
--- Warning: currently unimplemented for package modules.
-modInfoInstances :: ModuleInfo -> [ClsInst]
-modInfoInstances = minf_instances
-
-modInfoIsExportedName :: ModuleInfo -> Name -> Bool
-modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf))
-
-mkNamePprCtxForModule ::
-  GhcMonad m =>
-  ModuleInfo ->
-  m (Maybe NamePprCtx) -- XXX: returns a Maybe X
-mkNamePprCtxForModule minf = withSession $ \hsc_env -> do
-  let mk_name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env)
-      ptc = initPromotionTickContext (hsc_dflags hsc_env)
-  return (fmap mk_name_ppr_ctx (minf_rdr_env minf))
-
-modInfoLookupName :: GhcMonad m =>
-                     ModuleInfo -> Name
-                  -> m (Maybe TyThing) -- XXX: returns a Maybe X
-modInfoLookupName minf name = withSession $ \hsc_env -> do
-   case lookupTypeEnv (minf_type_env minf) name of
-     Just tyThing -> return (Just tyThing)
-     Nothing      -> liftIO (lookupType hsc_env name)
-
-modInfoIface :: ModuleInfo -> Maybe ModIface
-modInfoIface = minf_iface
-
-modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv
-modInfoRdrEnv = minf_rdr_env
-
--- | Retrieve module safe haskell mode
-modInfoSafe :: ModuleInfo -> SafeHaskellMode
-modInfoSafe = minf_safe
-
-modInfoModBreaks :: ModuleInfo -> ModBreaks
-modInfoModBreaks = minf_modBreaks
-
-isDictonaryId :: Id -> Bool
-isDictonaryId id
-  = case tcSplitSigmaTy (idType id) of {
-      (_tvs, _theta, tau) -> isDictTy tau }
-
--- | Looks up a global name: that is, any top-level name in any
--- visible module.  Unlike 'lookupName', lookupGlobalName does not use
--- the interactive context, and therefore does not require a preceding
--- 'setContext'.
-lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
-lookupGlobalName name = withSession $ \hsc_env -> do
-   liftIO $ lookupType hsc_env name
-
-findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
-findGlobalAnns deserialize target = withSession $ \hsc_env -> do
-    ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
-    return (findAnns deserialize ann_env target)
-
--- | get the GlobalRdrEnv for a session
-getGRE :: GhcMonad m => m GlobalRdrEnv
-getGRE = withSession $ \hsc_env-> return $ icReaderEnv (hsc_IC hsc_env)
-
--- | Retrieve all type and family instances in the environment, indexed
--- by 'Name'. Each name's lists will contain every instance in which that name
--- is mentioned in the instance head.
-getNameToInstancesIndex :: GhcMonad m
-  => [Module]        -- ^ visible modules. An orphan instance will be returned
-                     -- if it is visible from at least one module in the list.
-  -> Maybe [Module]  -- ^ modules to load. If this is not specified, we load
-                     -- modules for everything that is in scope unqualified.
-  -> m (Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst])))
-getNameToInstancesIndex visible_mods mods_to_load = do
-  hsc_env <- getSession
-  liftIO $ runTcInteractive hsc_env $
-    do { case mods_to_load of
-           Nothing -> loadUnqualIfaces hsc_env (hsc_IC hsc_env)
-           Just mods ->
-             let doc = text "Need interface for reporting instances in scope"
-             in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods
-
-       ; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs
-       ; let visible_mods' = mkModuleSet visible_mods
-       ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
-       -- We use Data.Sequence.Seq because we are creating left associated
-       -- mappends.
-       -- cls_index and fam_index below are adapted from GHC.Tc.Module.lookupInsts
-       ; let cls_index = Map.fromListWith mappend
-                 [ (n, Seq.singleton ispec)
-                 | ispec <- instEnvElts ie_local ++ instEnvElts ie_global
-                 , instIsVisible visible_mods' ispec
-                 , n <- nameSetElemsStable $ orphNamesOfClsInst ispec
-                 ]
-       ; let fam_index = Map.fromListWith mappend
-                 [ (n, Seq.singleton fispec)
-                 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
-                 , n <- nameSetElemsStable $ orphNamesOfFamInst fispec
-                 ]
-       ; return $ mkNameEnv $
-           [ (nm, (toList clss, toList fams))
-           | (nm, (clss, fams)) <- Map.toList $ Map.unionWith mappend
-               (fmap (,Seq.empty) cls_index)
-               (fmap (Seq.empty,) fam_index)
-           ] }
-
--- -----------------------------------------------------------------------------
--- Misc exported utils
-
-dataConType :: DataCon -> Type
-dataConType dc = idType (dataConWrapId dc)
-
--- | print a 'NamedThing', adding parentheses if the name is an operator.
-pprParenSymName :: NamedThing a => a -> SDoc
-pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
-
--- ----------------------------------------------------------------------------
-
-
--- ToDo:
---   - Data and Typeable instances for HsSyn.
-
--- ToDo: check for small transformations that happen to the syntax in
--- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
-
--- ToDo: maybe use TH syntax instead of Iface syntax?  There's already a way
--- to get from TyCons, Ids etc. to TH syntax (reify).
-
--- :browse will use either lm_toplev or inspect lm_interface, depending
--- on whether the module is interpreted or not.
-
-
--- Extract the filename, stringbuffer content and dynflags associed to a ModSummary
--- Given an initialised GHC session a ModSummary can be retrieved for
--- a module by using 'getModSummary'
---
--- XXX: Explain pre-conditions
-getModuleSourceAndFlags :: ModSummary -> IO (String, StringBuffer, DynFlags)
-getModuleSourceAndFlags m = do
-  case ml_hs_file $ ms_location m of
-    Nothing -> throwIO $ mkApiErr (ms_hspp_opts m) (text "No source available for module " <+> ppr (ms_mod m))
-    Just sourceFile -> do
-        source <- hGetStringBuffer sourceFile
-        return (sourceFile, source, ms_hspp_opts m)
-
-
--- | Return module source as token stream, including comments.
---
--- A 'Module' can be turned into a 'ModSummary' using 'getModSummary' if
--- your session is fully initialised.
--- Throws a 'GHC.Driver.Env.SourceError' on parse error.
-getTokenStream :: ModSummary -> IO [Located Token]
-getTokenStream mod = do
-  (sourceFile, source, dflags) <- getModuleSourceAndFlags mod
-  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
-  case lexTokenStream (initParserOpts dflags) source startLoc of
-    POk _ ts    -> return ts
-    PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst)
-
--- | Give even more information on the source than 'getTokenStream'
--- This function allows reconstructing the source completely with
--- 'showRichTokenStream'.
-getRichTokenStream :: ModSummary -> IO [(Located Token, String)]
-getRichTokenStream mod = do
-  (sourceFile, source, dflags) <- getModuleSourceAndFlags mod
-  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
-  case lexTokenStream (initParserOpts dflags) source startLoc of
-    POk _ ts    -> return $ addSourceToTokens startLoc source ts
-    PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst)
-
--- | Given a source location and a StringBuffer corresponding to this
--- location, return a rich token stream with the source associated to the
--- tokens.
-addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
-                  -> [(Located Token, String)]
-addSourceToTokens _ _ [] = []
-addSourceToTokens loc buf (t@(L span _) : ts)
-    = case span of
-      UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
-      RealSrcSpan s _ -> (t,str) : addSourceToTokens newLoc newBuf ts
-        where
-          (newLoc, newBuf, str) = go "" loc buf
-          start = realSrcSpanStart s
-          end = realSrcSpanEnd s
-          go acc loc buf | loc < start = go acc nLoc nBuf
-                         | start <= loc && loc < end = go (ch:acc) nLoc nBuf
-                         | otherwise = (loc, buf, reverse acc)
-              where (ch, nBuf) = nextChar buf
-                    nLoc = advanceSrcLoc loc ch
-
-
--- | Take a rich token stream such as produced from 'getRichTokenStream' and
--- return source code almost identical to the original code (except for
--- insignificant whitespace.)
-showRichTokenStream :: [(Located Token, String)] -> String
-showRichTokenStream ts = go startLoc ts ""
-    where sourceFile = getFile $ map (getLoc . fst) ts
-          getFile [] = panic "showRichTokenStream: No source file found"
-          getFile (UnhelpfulSpan _ : xs) = getFile xs
-          getFile (RealSrcSpan s _ : _) = srcSpanFile s
-          startLoc = mkRealSrcLoc sourceFile 1 1
-          go _ [] = id
-          go loc ((L span _, str):ts)
-              = case span of
-                UnhelpfulSpan _ -> go loc ts
-                RealSrcSpan s _
-                 | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)
-                                       . (str ++)
-                                       . go tokEnd ts
-                 | otherwise -> ((replicate (tokLine - locLine) '\n') ++)
-                               . ((replicate (tokCol - 1) ' ') ++)
-                              . (str ++)
-                              . go tokEnd ts
-                  where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
-                        (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s)
-                        tokEnd = realSrcSpanEnd s
-
--- -----------------------------------------------------------------------------
--- Interactive evaluation
-
--- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the
--- filesystem and package database to find the corresponding 'Module',
--- using the algorithm that is used for an @import@ declaration.
-findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
-findModule mod_name maybe_pkg = do
-  pkg_qual <- renamePkgQualM mod_name maybe_pkg
-  findQualifiedModule pkg_qual mod_name
-
-
-findQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module
-findQualifiedModule pkgqual mod_name = withSession $ \hsc_env -> do
-  let mhome_unit = hsc_home_unit_maybe hsc_env
-  let dflags    = hsc_dflags hsc_env
-  case pkgqual of
-    ThisPkg uid -> do
-      home <- lookupLoadedHomeModule uid mod_name
-      case home of
-        Just m  -> return m
-        Nothing -> liftIO $ do
-           res <- findImportedModule hsc_env mod_name pkgqual
-           case res of
-             Found loc m | notHomeModuleMaybe mhome_unit m -> return m
-                         | otherwise -> modNotLoadedError dflags m loc
-             err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
-
-    _ -> liftIO $ do
-      res <- findImportedModule hsc_env mod_name pkgqual
-      case res of
-        Found _ m -> return m
-        err       -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
-
-
-modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
-modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $
-   text "module is not loaded:" <+>
-   quotes (ppr (moduleName m)) <+>
-   parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
-
-renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual
-renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)
-
-renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual
-renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)
-
--- | Like 'findModule', but differs slightly when the module refers to
--- a source file, and the file has not been loaded via 'load'.  In
--- this case, 'findModule' will throw an error (module not loaded),
--- but 'lookupModule' will check to see whether the module can also be
--- found in a package, and if so, that package 'Module' will be
--- returned.  If not, the usual module-not-found error will be thrown.
---
-lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
-lookupModule mod_name maybe_pkg = do
-  pkgqual <- renamePkgQualM mod_name maybe_pkg
-  lookupQualifiedModule pkgqual mod_name
-
-lookupQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module
-lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do
-  home <- lookupLoadedHomeModule (homeUnitId $ hsc_home_unit hsc_env) mod_name
-  case home of
-    Just m  -> return m
-    Nothing -> liftIO $ do
-      let fc     = hsc_FC hsc_env
-      let units  = hsc_units hsc_env
-      let dflags = hsc_dflags hsc_env
-      let fopts  = initFinderOpts dflags
-      res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
-      case res of
-        Found _ m -> return m
-        err       -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
-lookupQualifiedModule pkgqual mod_name = findQualifiedModule pkgqual mod_name
-
-lookupLoadedHomeModule :: GhcMonad m => UnitId -> ModuleName -> m (Maybe Module)
-lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env ->
-  case lookupHug  (hsc_HUG hsc_env) uid mod_name  of
-    Just mod_info      -> return (Just (mi_module (hm_iface mod_info)))
-    _not_a_home_module -> return Nothing
-
--- | Check that a module is safe to import (according to Safe Haskell).
---
--- We return True to indicate the import is safe and False otherwise
--- although in the False case an error may be thrown first.
-isModuleTrusted :: GhcMonad m => Module -> m Bool
-isModuleTrusted m = withSession $ \hsc_env ->
-    liftIO $ hscCheckSafe hsc_env m noSrcSpan
-
--- | Return if a module is trusted and the pkgs it depends on to be trusted.
-moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId)
-moduleTrustReqs m = withSession $ \hsc_env ->
-    liftIO $ hscGetSafe hsc_env m noSrcSpan
-
--- | Set the monad GHCi lifts user statements into.
---
--- Checks that a type (in string form) is an instance of the
--- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is,
--- throws an error otherwise.
-setGHCiMonad :: GhcMonad m => String -> m ()
-setGHCiMonad name = withSession $ \hsc_env -> do
-    ty <- liftIO $ hscIsGHCiMonad hsc_env name
-    modifySession $ \s ->
-        let ic = (hsc_IC s) { ic_monad = ty }
-        in s { hsc_IC = ic }
-
--- | Get the monad GHCi lifts user statements into.
-getGHCiMonad :: GhcMonad m => m Name
-getGHCiMonad = fmap (ic_monad . hsc_IC) getSession
-
-getHistorySpan :: GhcMonad m => History -> m SrcSpan
-getHistorySpan h = withSession $ \hsc_env ->
-    return $ GHC.Runtime.Eval.getHistorySpan hsc_env h
-
-obtainTermFromVal :: GhcMonad m => Int ->  Bool -> Type -> a -> m Term
-obtainTermFromVal bound force ty a = withSession $ \hsc_env ->
-    liftIO $ GHC.Runtime.Eval.obtainTermFromVal hsc_env bound force ty a
-
-obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
-obtainTermFromId bound force id = withSession $ \hsc_env ->
-    liftIO $ GHC.Runtime.Eval.obtainTermFromId hsc_env bound force id
-
-
--- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
--- entity known to GHC, including 'Name's defined using 'runStmt'.
-lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
-lookupName name =
-     withSession $ \hsc_env ->
-       liftIO $ hscTcRcLookupName hsc_env name
-
--- -----------------------------------------------------------------------------
--- Pure API
-
--- | A pure interface to the module parser.
---
-parser :: String         -- ^ Haskell module source text (full Unicode is supported)
-       -> DynFlags       -- ^ the flags
-       -> FilePath       -- ^ the filename (for source locations)
-       -> (WarningMessages, Either ErrorMessages (Located (HsModule GhcPs)))
-
-parser str dflags filename =
-   let
-       loc  = mkRealSrcLoc (mkFastString filename) 1 1
-       buf  = stringToStringBuffer str
-   in
-   case unP Parser.parseModule (initParserState (initParserOpts dflags) buf loc) of
-
-     PFailed pst ->
-         let (warns,errs) = getPsMessages pst in
-         (GhcPsMessage <$> warns, Left $ GhcPsMessage <$> errs)
-
-     POk pst rdr_module ->
-         let (warns,_) = getPsMessages pst in
-         (GhcPsMessage <$> warns, Right rdr_module)
-
--- -----------------------------------------------------------------------------
--- | Find the package environment (if one exists)
---
--- We interpret the package environment as a set of package flags; to be
--- specific, if we find a package environment file like
---
--- > clear-package-db
--- > global-package-db
--- > package-db blah/package.conf.d
--- > package-id id1
--- > package-id id2
---
--- we interpret this as
---
--- > [ -hide-all-packages
--- > , -clear-package-db
--- > , -global-package-db
--- > , -package-db blah/package.conf.d
--- > , -package-id id1
--- > , -package-id id2
--- > ]
---
--- There's also an older syntax alias for package-id, which is just an
--- unadorned package id
---
--- > id1
--- > id2
---
-interpretPackageEnv :: Logger -> DynFlags -> IO DynFlags
-interpretPackageEnv logger dflags = do
-    mPkgEnv <- runMaybeT $ msum $ [
-                   getCmdLineArg >>= \env -> msum [
-                       probeNullEnv env
-                     , probeEnvFile env
-                     , probeEnvName env
-                     , cmdLineError env
-                     ]
-                 , getEnvVar >>= \env -> msum [
-                       probeNullEnv env
-                     , probeEnvFile env
-                     , probeEnvName env
-                     , envError     env
-                     ]
-                 , notIfHideAllPackages >> msum [
-                       findLocalEnvFile >>= probeEnvFile
-                     , probeEnvName defaultEnvName
-                     ]
-                 ]
-    case mPkgEnv of
-      Nothing ->
-        -- No environment found. Leave DynFlags unchanged.
-        return dflags
-      Just "-" -> do
-        -- Explicitly disabled environment file. Leave DynFlags unchanged.
-        return dflags
-      Just envfile -> do
-        content <- readFile envfile
-        compilationProgressMsg logger (text "Loaded package environment from " <> text envfile)
-        let (_, dflags') = runCmdLineP (runEwM (setFlagsFromEnvFile envfile content)) dflags
-
-        return dflags'
-  where
-    -- Loading environments (by name or by location)
-
-    archOS = platformArchOS (targetPlatform dflags)
-
-    namedEnvPath :: String -> MaybeT IO FilePath
-    namedEnvPath name = do
-     appdir <- versionedAppDir (programName dflags) archOS
-     return $ appdir </> "environments" </> name
-
-    probeEnvName :: String -> MaybeT IO FilePath
-    probeEnvName name = probeEnvFile =<< namedEnvPath name
-
-    probeEnvFile :: FilePath -> MaybeT IO FilePath
-    probeEnvFile path = do
-      guard =<< liftMaybeT (doesFileExist path)
-      return path
-
-    probeNullEnv :: FilePath -> MaybeT IO FilePath
-    probeNullEnv "-" = return "-"
-    probeNullEnv _   = mzero
-
-    -- Various ways to define which environment to use
-
-    getCmdLineArg :: MaybeT IO String
-    getCmdLineArg = MaybeT $ return $ packageEnv dflags
-
-    getEnvVar :: MaybeT IO String
-    getEnvVar = do
-      mvar <- liftMaybeT $ MC.try $ getEnv "GHC_ENVIRONMENT"
-      case mvar of
-        Right var -> return var
-        Left err  -> if isDoesNotExistError err then mzero
-                                                else liftMaybeT $ throwIO err
-
-    notIfHideAllPackages :: MaybeT IO ()
-    notIfHideAllPackages =
-      guard (not (gopt Opt_HideAllPackages dflags))
-
-    defaultEnvName :: String
-    defaultEnvName = "default"
-
-    -- e.g. .ghc.environment.x86_64-linux-7.6.3
-    localEnvFileName :: FilePath
-    localEnvFileName = ".ghc.environment" <.> versionedFilePath archOS
-
-    -- Search for an env file, starting in the current dir and looking upwards.
-    -- Fail if we get to the users home dir or the filesystem root. That is,
-    -- we don't look for an env file in the user's home dir. The user-wide
-    -- env lives in ghc's versionedAppDir/environments/default
-    findLocalEnvFile :: MaybeT IO FilePath
-    findLocalEnvFile = do
-        curdir  <- liftMaybeT getCurrentDirectory
-        homedir <- tryMaybeT getHomeDirectory
-        let probe dir | isDrive dir || dir == homedir
-                      = mzero
-            probe dir = do
-              let file = dir </> localEnvFileName
-              exists <- liftMaybeT (doesFileExist file)
-              if exists
-                then return file
-                else probe (takeDirectory dir)
-        probe curdir
-
-    -- Error reporting
-
-    cmdLineError :: String -> MaybeT IO a
-    cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $
-      "Package environment " ++ show env ++ " not found"
-
-    envError :: String -> MaybeT IO a
-    envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $
-         "Package environment "
-      ++ show env
-      ++ " (specified in GHC_ENVIRONMENT) not found"
-
--- | An error thrown if the GHC API is used in an incorrect fashion.
-newtype GhcApiError = GhcApiError String
-
-instance Show GhcApiError where
-  show (GhcApiError msg) = msg
-
-instance Exception GhcApiError
-
-mkApiErr :: DynFlags -> SDoc -> GhcApiError
-mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)
diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs
deleted file mode 100644
--- a/compiler/GHC/Builtin/Names/TH.hs
+++ /dev/null
@@ -1,1136 +0,0 @@
--- %************************************************************************
--- %*                                                                   *
---              The known-key names for Template Haskell
--- %*                                                                   *
--- %************************************************************************
-
-module GHC.Builtin.Names.TH where
-
-import GHC.Prelude ()
-
-import GHC.Builtin.Names( mk_known_key_name )
-import GHC.Unit.Types
-import GHC.Types.Name( Name )
-import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName )
-import GHC.Types.Name.Reader( RdrName, nameRdrName )
-import GHC.Types.Unique
-import GHC.Builtin.Uniques
-import GHC.Data.FastString
-
-import Language.Haskell.Syntax.Module.Name
-
--- To add a name, do three things
---
---  1) Allocate a key
---  2) Make a "Name"
---  3) Add the name to templateHaskellNames
-
-templateHaskellNames :: [Name]
--- The names that are implicitly mentioned by ``bracket''
--- Should stay in sync with the import list of GHC.HsToCore.Quote
-
-templateHaskellNames = [
-    returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,
-    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
-    mkNameSName,
-    mkModNameName,
-    liftStringName,
-    unTypeName, unTypeCodeName,
-    unsafeCodeCoerceName,
-
-    -- Lit
-    charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
-    floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,
-    charPrimLName,
-    -- Pat
-    litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName,
-    conPName, tildePName, bangPName, infixPName,
-    asPName, wildPName, recPName, listPName, sigPName, viewPName,
-    -- FieldPat
-    fieldPatName,
-    -- Match
-    matchName,
-    -- Clause
-    clauseName,
-    -- Exp
-    varEName, conEName, litEName, appEName, appTypeEName, infixEName,
-    infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
-    lamCasesEName, tupEName, unboxedTupEName, unboxedSumEName,
-    condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,
-    fromEName, fromThenEName, fromToEName, fromThenToEName,
-    listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
-    labelEName, implicitParamVarEName, getFieldEName, projectionEName,
-    -- FieldExp
-    fieldExpName,
-    -- Body
-    guardedBName, normalBName,
-    -- Guard
-    normalGEName, patGEName,
-    -- Stmt
-    bindSName, letSName, noBindSName, parSName, recSName,
-    -- Dec
-    funDName, valDName, dataDName, newtypeDName, tySynDName,
-    classDName, instanceWithOverlapDName,
-    standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,
-    pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
-    pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, defaultDName,
-    dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
-    dataInstDName, newtypeInstDName, tySynInstDName,
-    infixLDName, infixRDName, infixNDName,
-    roleAnnotDName, patSynDName, patSynSigDName,
-    implicitParamBindDName,
-    -- Cxt
-    cxtName,
-
-    -- SourceUnpackedness
-    noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName,
-    -- SourceStrictness
-    noSourceStrictnessName, sourceLazyName, sourceStrictName,
-    -- Con
-    normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName,
-    -- Bang
-    bangName,
-    -- BangType
-    bangTypeName,
-    -- VarBangType
-    varBangTypeName,
-    -- PatSynDir (for pattern synonyms)
-    unidirPatSynName, implBidirPatSynName, explBidirPatSynName,
-    -- PatSynArgs (for pattern synonyms)
-    prefixPatSynName, infixPatSynName, recordPatSynName,
-    -- Type
-    forallTName, forallVisTName, varTName, conTName, infixTName, appTName,
-    appKindTName, equalityTName, tupleTName, unboxedTupleTName,
-    unboxedSumTName, arrowTName, mulArrowTName, listTName, sigTName, litTName,
-    promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
-    wildCardTName, implicitParamTName,
-    -- TyLit
-    numTyLitName, strTyLitName, charTyLitName,
-    -- TyVarBndr
-    plainTVName, kindedTVName,
-    plainInvisTVName, kindedInvisTVName,
-    -- Specificity
-    specifiedSpecName, inferredSpecName,
-    -- Role
-    nominalRName, representationalRName, phantomRName, inferRName,
-    -- Kind
-    starKName, constraintKName,
-    -- FamilyResultSig
-    noSigName, kindSigName, tyVarSigName,
-    -- InjectivityAnn
-    injectivityAnnName,
-    -- Callconv
-    cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName,
-    -- Safety
-    unsafeName,
-    safeName,
-    interruptibleName,
-    -- Inline
-    noInlineDataConName, inlineDataConName, inlinableDataConName,
-    -- RuleMatch
-    conLikeDataConName, funLikeDataConName,
-    -- Phases
-    allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,
-    -- Overlap
-    overlappableDataConName, overlappingDataConName, overlapsDataConName,
-    incoherentDataConName,
-    -- DerivStrategy
-    stockStrategyName, anyclassStrategyName,
-    newtypeStrategyName, viaStrategyName,
-    -- RuleBndr
-    ruleVarName, typedRuleVarName,
-    -- FunDep
-    funDepName,
-    -- TySynEqn
-    tySynEqnName,
-    -- AnnTarget
-    valueAnnotationName, typeAnnotationName, moduleAnnotationName,
-    -- DerivClause
-    derivClauseName,
-
-    -- The type classes
-    liftClassName, quoteClassName,
-
-    -- And the tycons
-    qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchTyConName,
-    expQTyConName, fieldExpTyConName, predTyConName,
-    stmtTyConName,  decsTyConName, conTyConName, bangTypeTyConName,
-    varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName,
-    typeTyConName, tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, clauseTyConName,
-    patQTyConName, funDepTyConName, decsQTyConName,
-    ruleBndrTyConName, tySynEqnTyConName,
-    roleTyConName, codeTyConName, injAnnTyConName, kindTyConName,
-    overlapTyConName, derivClauseTyConName, derivStrategyTyConName,
-    modNameTyConName,
-
-    -- Quasiquoting
-    quoteDecName, quoteTypeName, quoteExpName, quotePatName]
-
-thSyn, thLib, qqLib :: Module
-thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
-thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal")
-qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
-
-mkTHModule :: FastString -> Module
-mkTHModule m = mkModule thUnit (mkModuleNameFS m)
-
-libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name
-libFun = mk_known_key_name varName  thLib
-libTc  = mk_known_key_name tcName   thLib
-thFun  = mk_known_key_name varName  thSyn
-thTc   = mk_known_key_name tcName   thSyn
-thCls  = mk_known_key_name clsName  thSyn
-thCon  = mk_known_key_name dataName thSyn
-qqFun  = mk_known_key_name varName  qqLib
-
--------------------- TH.Syntax -----------------------
-liftClassName :: Name
-liftClassName = thCls (fsLit "Lift") liftClassKey
-
-quoteClassName :: Name
-quoteClassName = thCls (fsLit "Quote") quoteClassKey
-
-qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
-    fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
-    matchTyConName, clauseTyConName, funDepTyConName, predTyConName,
-    codeTyConName, injAnnTyConName, overlapTyConName, decsTyConName,
-    modNameTyConName :: Name
-qTyConName             = thTc (fsLit "Q")              qTyConKey
-nameTyConName          = thTc (fsLit "Name")           nameTyConKey
-fieldExpTyConName      = thTc (fsLit "FieldExp")       fieldExpTyConKey
-patTyConName           = thTc (fsLit "Pat")            patTyConKey
-fieldPatTyConName      = thTc (fsLit "FieldPat")       fieldPatTyConKey
-expTyConName           = thTc (fsLit "Exp")            expTyConKey
-decTyConName           = thTc (fsLit "Dec")            decTyConKey
-decsTyConName          = libTc (fsLit "Decs")           decsTyConKey
-typeTyConName          = thTc (fsLit "Type")           typeTyConKey
-matchTyConName         = thTc (fsLit "Match")          matchTyConKey
-clauseTyConName        = thTc (fsLit "Clause")         clauseTyConKey
-funDepTyConName        = thTc (fsLit "FunDep")         funDepTyConKey
-predTyConName          = thTc (fsLit "Pred")           predTyConKey
-codeTyConName          = thTc (fsLit "Code")           codeTyConKey
-injAnnTyConName        = thTc (fsLit "InjectivityAnn") injAnnTyConKey
-overlapTyConName       = thTc (fsLit "Overlap")        overlapTyConKey
-modNameTyConName       = thTc (fsLit "ModName")        modNameTyConKey
-
-returnQName, bindQName, sequenceQName, newNameName, liftName,
-    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
-    mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName,
-    unsafeCodeCoerceName, liftTypedName, mkModNameName :: Name
-returnQName    = thFun (fsLit "returnQ")   returnQIdKey
-bindQName      = thFun (fsLit "bindQ")     bindQIdKey
-sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey
-newNameName    = thFun (fsLit "newName")   newNameIdKey
-liftName       = thFun (fsLit "lift")      liftIdKey
-liftStringName = thFun (fsLit "liftString")  liftStringIdKey
-mkNameName     = thFun (fsLit "mkName")     mkNameIdKey
-mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey
-mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey
-mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
-mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey
-mkNameSName    = thFun (fsLit "mkNameS")    mkNameSIdKey
-mkModNameName  = thFun (fsLit "mkModName")  mkModNameIdKey
-unTypeName     = thFun (fsLit "unType")     unTypeIdKey
-unTypeCodeName    = thFun (fsLit "unTypeCode") unTypeCodeIdKey
-unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey
-liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey
-
-
--------------------- TH.Lib -----------------------
--- data Lit = ...
-charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
-    floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,
-    charPrimLName :: Name
-charLName       = libFun (fsLit "charL")       charLIdKey
-stringLName     = libFun (fsLit "stringL")     stringLIdKey
-integerLName    = libFun (fsLit "integerL")    integerLIdKey
-intPrimLName    = libFun (fsLit "intPrimL")    intPrimLIdKey
-wordPrimLName   = libFun (fsLit "wordPrimL")   wordPrimLIdKey
-floatPrimLName  = libFun (fsLit "floatPrimL")  floatPrimLIdKey
-doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
-rationalLName   = libFun (fsLit "rationalL")     rationalLIdKey
-stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey
-charPrimLName   = libFun (fsLit "charPrimL")   charPrimLIdKey
-
--- data Pat = ...
-litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName,
-    infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName,
-    sigPName, viewPName :: Name
-litPName   = libFun (fsLit "litP")   litPIdKey
-varPName   = libFun (fsLit "varP")   varPIdKey
-tupPName   = libFun (fsLit "tupP")   tupPIdKey
-unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey
-unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey
-conPName   = libFun (fsLit "conP")   conPIdKey
-infixPName = libFun (fsLit "infixP") infixPIdKey
-tildePName = libFun (fsLit "tildeP") tildePIdKey
-bangPName  = libFun (fsLit "bangP")  bangPIdKey
-asPName    = libFun (fsLit "asP")    asPIdKey
-wildPName  = libFun (fsLit "wildP")  wildPIdKey
-recPName   = libFun (fsLit "recP")   recPIdKey
-listPName  = libFun (fsLit "listP")  listPIdKey
-sigPName   = libFun (fsLit "sigP")   sigPIdKey
-viewPName  = libFun (fsLit "viewP")  viewPIdKey
-
--- type FieldPat = ...
-fieldPatName :: Name
-fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
-
--- data Match = ...
-matchName :: Name
-matchName = libFun (fsLit "match") matchIdKey
-
--- data Clause = ...
-clauseName :: Name
-clauseName = libFun (fsLit "clause") clauseIdKey
-
--- data Exp = ...
-varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,
-    sectionLName, sectionRName, lamEName, lamCaseEName, lamCasesEName, tupEName,
-    unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,
-    caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,
-    labelEName, implicitParamVarEName, getFieldEName, projectionEName :: Name
-varEName              = libFun (fsLit "varE")              varEIdKey
-conEName              = libFun (fsLit "conE")              conEIdKey
-litEName              = libFun (fsLit "litE")              litEIdKey
-appEName              = libFun (fsLit "appE")              appEIdKey
-appTypeEName          = libFun (fsLit "appTypeE")          appTypeEIdKey
-infixEName            = libFun (fsLit "infixE")            infixEIdKey
-infixAppName          = libFun (fsLit "infixApp")          infixAppIdKey
-sectionLName          = libFun (fsLit "sectionL")          sectionLIdKey
-sectionRName          = libFun (fsLit "sectionR")          sectionRIdKey
-lamEName              = libFun (fsLit "lamE")              lamEIdKey
-lamCaseEName          = libFun (fsLit "lamCaseE")          lamCaseEIdKey
-lamCasesEName         = libFun (fsLit "lamCasesE")         lamCasesEIdKey
-tupEName              = libFun (fsLit "tupE")              tupEIdKey
-unboxedTupEName       = libFun (fsLit "unboxedTupE")       unboxedTupEIdKey
-unboxedSumEName       = libFun (fsLit "unboxedSumE")       unboxedSumEIdKey
-condEName             = libFun (fsLit "condE")             condEIdKey
-multiIfEName          = libFun (fsLit "multiIfE")          multiIfEIdKey
-letEName              = libFun (fsLit "letE")              letEIdKey
-caseEName             = libFun (fsLit "caseE")             caseEIdKey
-doEName               = libFun (fsLit "doE")               doEIdKey
-mdoEName              = libFun (fsLit "mdoE")              mdoEIdKey
-compEName             = libFun (fsLit "compE")             compEIdKey
--- ArithSeq skips a level
-fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
-fromEName             = libFun (fsLit "fromE")             fromEIdKey
-fromThenEName         = libFun (fsLit "fromThenE")         fromThenEIdKey
-fromToEName           = libFun (fsLit "fromToE")           fromToEIdKey
-fromThenToEName       = libFun (fsLit "fromThenToE")       fromThenToEIdKey
--- end ArithSeq
-listEName, sigEName, recConEName, recUpdEName :: Name
-listEName             = libFun (fsLit "listE")             listEIdKey
-sigEName              = libFun (fsLit "sigE")              sigEIdKey
-recConEName           = libFun (fsLit "recConE")           recConEIdKey
-recUpdEName           = libFun (fsLit "recUpdE")           recUpdEIdKey
-staticEName           = libFun (fsLit "staticE")           staticEIdKey
-unboundVarEName       = libFun (fsLit "unboundVarE")       unboundVarEIdKey
-labelEName            = libFun (fsLit "labelE")            labelEIdKey
-implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey
-getFieldEName         = libFun (fsLit "getFieldE")         getFieldEIdKey
-projectionEName       = libFun (fsLit "projectionE")       projectionEIdKey
-
--- type FieldExp = ...
-fieldExpName :: Name
-fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
-
--- data Body = ...
-guardedBName, normalBName :: Name
-guardedBName = libFun (fsLit "guardedB") guardedBIdKey
-normalBName  = libFun (fsLit "normalB")  normalBIdKey
-
--- data Guard = ...
-normalGEName, patGEName :: Name
-normalGEName = libFun (fsLit "normalGE") normalGEIdKey
-patGEName    = libFun (fsLit "patGE")    patGEIdKey
-
--- data Stmt = ...
-bindSName, letSName, noBindSName, parSName, recSName :: Name
-bindSName   = libFun (fsLit "bindS")   bindSIdKey
-letSName    = libFun (fsLit "letS")    letSIdKey
-noBindSName = libFun (fsLit "noBindS") noBindSIdKey
-parSName    = libFun (fsLit "parS")    parSIdKey
-recSName    = libFun (fsLit "recS")    recSIdKey
-
--- data Dec = ...
-funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
-    instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,
-    pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,
-    pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,
-    dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
-    openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
-    infixNDName, roleAnnotDName, patSynDName, patSynSigDName,
-    pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name
-funDName                         = libFun (fsLit "funD")                         funDIdKey
-valDName                         = libFun (fsLit "valD")                         valDIdKey
-dataDName                        = libFun (fsLit "dataD")                        dataDIdKey
-newtypeDName                     = libFun (fsLit "newtypeD")                     newtypeDIdKey
-tySynDName                       = libFun (fsLit "tySynD")                       tySynDIdKey
-classDName                       = libFun (fsLit "classD")                       classDIdKey
-instanceWithOverlapDName         = libFun (fsLit "instanceWithOverlapD")         instanceWithOverlapDIdKey
-standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey
-sigDName                         = libFun (fsLit "sigD")                         sigDIdKey
-kiSigDName                       = libFun (fsLit "kiSigD")                       kiSigDIdKey
-defaultDName                     = libFun (fsLit "defaultD")                     defaultDIdKey
-defaultSigDName                  = libFun (fsLit "defaultSigD")                  defaultSigDIdKey
-forImpDName                      = libFun (fsLit "forImpD")                      forImpDIdKey
-pragInlDName                     = libFun (fsLit "pragInlD")                     pragInlDIdKey
-pragOpaqueDName                  = libFun (fsLit "pragOpaqueD")                  pragOpaqueDIdKey
-pragSpecDName                    = libFun (fsLit "pragSpecD")                    pragSpecDIdKey
-pragSpecInlDName                 = libFun (fsLit "pragSpecInlD")                 pragSpecInlDIdKey
-pragSpecInstDName                = libFun (fsLit "pragSpecInstD")                pragSpecInstDIdKey
-pragRuleDName                    = libFun (fsLit "pragRuleD")                    pragRuleDIdKey
-pragCompleteDName                = libFun (fsLit "pragCompleteD")                pragCompleteDIdKey
-pragAnnDName                     = libFun (fsLit "pragAnnD")                     pragAnnDIdKey
-dataInstDName                    = libFun (fsLit "dataInstD")                    dataInstDIdKey
-newtypeInstDName                 = libFun (fsLit "newtypeInstD")                 newtypeInstDIdKey
-tySynInstDName                   = libFun (fsLit "tySynInstD")                   tySynInstDIdKey
-openTypeFamilyDName              = libFun (fsLit "openTypeFamilyD")              openTypeFamilyDIdKey
-closedTypeFamilyDName            = libFun (fsLit "closedTypeFamilyD")            closedTypeFamilyDIdKey
-dataFamilyDName                  = libFun (fsLit "dataFamilyD")                  dataFamilyDIdKey
-infixLDName                      = libFun (fsLit "infixLD")                      infixLDIdKey
-infixRDName                      = libFun (fsLit "infixRD")                      infixRDIdKey
-infixNDName                      = libFun (fsLit "infixND")                      infixNDIdKey
-roleAnnotDName                   = libFun (fsLit "roleAnnotD")                   roleAnnotDIdKey
-patSynDName                      = libFun (fsLit "patSynD")                      patSynDIdKey
-patSynSigDName                   = libFun (fsLit "patSynSigD")                   patSynSigDIdKey
-implicitParamBindDName           = libFun (fsLit "implicitParamBindD")           implicitParamBindDIdKey
-
--- type Ctxt = ...
-cxtName :: Name
-cxtName = libFun (fsLit "cxt") cxtIdKey
-
--- data SourceUnpackedness = ...
-noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name
-noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey
-sourceNoUnpackName       = libFun (fsLit "sourceNoUnpack")       sourceNoUnpackKey
-sourceUnpackName         = libFun (fsLit "sourceUnpack")         sourceUnpackKey
-
--- data SourceStrictness = ...
-noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name
-noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey
-sourceLazyName         = libFun (fsLit "sourceLazy")         sourceLazyKey
-sourceStrictName       = libFun (fsLit "sourceStrict")       sourceStrictKey
-
--- data Con = ...
-normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name
-normalCName  = libFun (fsLit "normalC" ) normalCIdKey
-recCName     = libFun (fsLit "recC"    ) recCIdKey
-infixCName   = libFun (fsLit "infixC"  ) infixCIdKey
-forallCName  = libFun (fsLit "forallC" ) forallCIdKey
-gadtCName    = libFun (fsLit "gadtC"   ) gadtCIdKey
-recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey
-
--- data Bang = ...
-bangName :: Name
-bangName = libFun (fsLit "bang") bangIdKey
-
--- type BangType = ...
-bangTypeName :: Name
-bangTypeName = libFun (fsLit "bangType") bangTKey
-
--- type VarBangType = ...
-varBangTypeName :: Name
-varBangTypeName = libFun (fsLit "varBangType") varBangTKey
-
--- data PatSynDir = ...
-unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: Name
-unidirPatSynName    = libFun (fsLit "unidir")    unidirPatSynIdKey
-implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey
-explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey
-
--- data PatSynArgs = ...
-prefixPatSynName, infixPatSynName, recordPatSynName :: Name
-prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey
-infixPatSynName  = libFun (fsLit "infixPatSyn")  infixPatSynIdKey
-recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey
-
--- data Type = ...
-forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName,
-    unboxedTupleTName, unboxedSumTName, arrowTName, mulArrowTName, listTName,
-    appTName, appKindTName, sigTName, equalityTName, litTName, promotedTName,
-    promotedTupleTName, promotedNilTName, promotedConsTName,
-    wildCardTName, implicitParamTName :: Name
-forallTName         = libFun (fsLit "forallT")        forallTIdKey
-forallVisTName      = libFun (fsLit "forallVisT")     forallVisTIdKey
-varTName            = libFun (fsLit "varT")           varTIdKey
-conTName            = libFun (fsLit "conT")           conTIdKey
-tupleTName          = libFun (fsLit "tupleT")         tupleTIdKey
-unboxedTupleTName   = libFun (fsLit "unboxedTupleT")  unboxedTupleTIdKey
-unboxedSumTName     = libFun (fsLit "unboxedSumT")    unboxedSumTIdKey
-arrowTName          = libFun (fsLit "arrowT")         arrowTIdKey
-mulArrowTName       = libFun (fsLit "mulArrowT")      mulArrowTIdKey
-listTName           = libFun (fsLit "listT")          listTIdKey
-appTName            = libFun (fsLit "appT")           appTIdKey
-appKindTName        = libFun (fsLit "appKindT")       appKindTIdKey
-sigTName            = libFun (fsLit "sigT")           sigTIdKey
-equalityTName       = libFun (fsLit "equalityT")      equalityTIdKey
-litTName            = libFun (fsLit "litT")           litTIdKey
-promotedTName       = libFun (fsLit "promotedT")      promotedTIdKey
-promotedTupleTName  = libFun (fsLit "promotedTupleT") promotedTupleTIdKey
-promotedNilTName    = libFun (fsLit "promotedNilT")   promotedNilTIdKey
-promotedConsTName   = libFun (fsLit "promotedConsT")  promotedConsTIdKey
-wildCardTName       = libFun (fsLit "wildCardT")      wildCardTIdKey
-infixTName          = libFun (fsLit "infixT")         infixTIdKey
-implicitParamTName  = libFun (fsLit "implicitParamT") implicitParamTIdKey
-
--- data TyLit = ...
-numTyLitName, strTyLitName, charTyLitName :: Name
-numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey
-strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey
-charTyLitName = libFun (fsLit "charTyLit") charTyLitIdKey
-
--- data TyVarBndr = ...
-plainTVName, kindedTVName :: Name
-plainTVName  = libFun (fsLit "plainTV")  plainTVIdKey
-kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
-
-plainInvisTVName, kindedInvisTVName :: Name
-plainInvisTVName  = libFun (fsLit "plainInvisTV")  plainInvisTVIdKey
-kindedInvisTVName = libFun (fsLit "kindedInvisTV") kindedInvisTVIdKey
-
--- data Specificity = ...
-specifiedSpecName, inferredSpecName :: Name
-specifiedSpecName = libFun (fsLit "specifiedSpec") specifiedSpecKey
-inferredSpecName  = libFun (fsLit "inferredSpec")  inferredSpecKey
-
--- data Role = ...
-nominalRName, representationalRName, phantomRName, inferRName :: Name
-nominalRName          = libFun (fsLit "nominalR")          nominalRIdKey
-representationalRName = libFun (fsLit "representationalR") representationalRIdKey
-phantomRName          = libFun (fsLit "phantomR")          phantomRIdKey
-inferRName            = libFun (fsLit "inferR")            inferRIdKey
-
--- data Kind = ...
-starKName, constraintKName :: Name
-starKName       = libFun (fsLit "starK")        starKIdKey
-constraintKName = libFun (fsLit "constraintK")  constraintKIdKey
-
--- data FamilyResultSig = ...
-noSigName, kindSigName, tyVarSigName :: Name
-noSigName    = libFun (fsLit "noSig")    noSigIdKey
-kindSigName  = libFun (fsLit "kindSig")  kindSigIdKey
-tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey
-
--- data InjectivityAnn = ...
-injectivityAnnName :: Name
-injectivityAnnName = libFun (fsLit "injectivityAnn") injectivityAnnIdKey
-
--- data Callconv = ...
-cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name
-cCallName = libFun (fsLit "cCall") cCallIdKey
-stdCallName = libFun (fsLit "stdCall") stdCallIdKey
-cApiCallName = libFun (fsLit "cApi") cApiCallIdKey
-primCallName = libFun (fsLit "prim") primCallIdKey
-javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey
-
--- data Safety = ...
-unsafeName, safeName, interruptibleName :: Name
-unsafeName     = libFun (fsLit "unsafe") unsafeIdKey
-safeName       = libFun (fsLit "safe") safeIdKey
-interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
-
--- data RuleBndr = ...
-ruleVarName, typedRuleVarName :: Name
-ruleVarName      = libFun (fsLit ("ruleVar"))      ruleVarIdKey
-typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey
-
--- data FunDep = ...
-funDepName :: Name
-funDepName     = libFun (fsLit "funDep") funDepIdKey
-
--- data TySynEqn = ...
-tySynEqnName :: Name
-tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey
-
--- data AnnTarget = ...
-valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name
-valueAnnotationName  = libFun (fsLit "valueAnnotation")  valueAnnotationIdKey
-typeAnnotationName   = libFun (fsLit "typeAnnotation")   typeAnnotationIdKey
-moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey
-
--- type DerivClause = ...
-derivClauseName :: Name
-derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey
-
--- data DerivStrategy = ...
-stockStrategyName, anyclassStrategyName, newtypeStrategyName,
-  viaStrategyName :: Name
-stockStrategyName    = libFun (fsLit "stockStrategy")    stockStrategyIdKey
-anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey
-newtypeStrategyName  = libFun (fsLit "newtypeStrategy")  newtypeStrategyIdKey
-viaStrategyName      = libFun (fsLit "viaStrategy")      viaStrategyIdKey
-
-patQTyConName, expQTyConName, stmtTyConName,
-    conTyConName, bangTypeTyConName,
-    varBangTypeTyConName, typeQTyConName,
-    decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName,
-    derivClauseTyConName, kindTyConName,
-    tyVarBndrUnitTyConName, tyVarBndrSpecTyConName,
-    derivStrategyTyConName :: Name
--- These are only used for the types of top-level splices
-expQTyConName           = libTc (fsLit "ExpQ")           expQTyConKey
-decsQTyConName          = libTc (fsLit "DecsQ")          decsQTyConKey  -- Q [Dec]
-typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey
-patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey
-
--- These are used in GHC.HsToCore.Quote but always wrapped in a type variable
-stmtTyConName           = thTc (fsLit "Stmt")            stmtTyConKey
-conTyConName            = thTc (fsLit "Con")             conTyConKey
-bangTypeTyConName       = thTc (fsLit "BangType")      bangTypeTyConKey
-varBangTypeTyConName    = thTc (fsLit "VarBangType")     varBangTypeTyConKey
-ruleBndrTyConName      = thTc (fsLit "RuleBndr")      ruleBndrTyConKey
-tySynEqnTyConName       = thTc  (fsLit "TySynEqn")       tySynEqnTyConKey
-roleTyConName           = libTc (fsLit "Role")           roleTyConKey
-derivClauseTyConName   = thTc (fsLit "DerivClause")   derivClauseTyConKey
-kindTyConName          = thTc (fsLit "Kind")          kindTyConKey
-tyVarBndrUnitTyConName = libTc (fsLit "TyVarBndrUnit") tyVarBndrUnitTyConKey
-tyVarBndrSpecTyConName = libTc (fsLit "TyVarBndrSpec") tyVarBndrSpecTyConKey
-derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey
-
--- quasiquoting
-quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
-quoteExpName        = qqFun (fsLit "quoteExp")  quoteExpKey
-quotePatName        = qqFun (fsLit "quotePat")  quotePatKey
-quoteDecName        = qqFun (fsLit "quoteDec")  quoteDecKey
-quoteTypeName       = qqFun (fsLit "quoteType") quoteTypeKey
-
--- data Inline = ...
-noInlineDataConName, inlineDataConName, inlinableDataConName :: Name
-noInlineDataConName  = thCon (fsLit "NoInline")  noInlineDataConKey
-inlineDataConName    = thCon (fsLit "Inline")    inlineDataConKey
-inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey
-
--- data RuleMatch = ...
-conLikeDataConName, funLikeDataConName :: Name
-conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey
-funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey
-
--- data Phases = ...
-allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name
-allPhasesDataConName   = thCon (fsLit "AllPhases")   allPhasesDataConKey
-fromPhaseDataConName   = thCon (fsLit "FromPhase")   fromPhaseDataConKey
-beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey
-
--- data Overlap = ...
-overlappableDataConName,
-  overlappingDataConName,
-  overlapsDataConName,
-  incoherentDataConName :: Name
-overlappableDataConName = thCon (fsLit "Overlappable") overlappableDataConKey
-overlappingDataConName  = thCon (fsLit "Overlapping")  overlappingDataConKey
-overlapsDataConName     = thCon (fsLit "Overlaps")     overlapsDataConKey
-incoherentDataConName   = thCon (fsLit "Incoherent")   incoherentDataConKey
-
-{- *********************************************************************
-*                                                                      *
-                     Class keys
-*                                                                      *
-********************************************************************* -}
-
--- ClassUniques available: 200-299
--- Check in GHC.Builtin.Names if you want to change this
-
-liftClassKey :: Unique
-liftClassKey = mkPreludeClassUnique 200
-
-quoteClassKey :: Unique
-quoteClassKey = mkPreludeClassUnique 201
-
-{- *********************************************************************
-*                                                                      *
-                     TyCon keys
-*                                                                      *
-********************************************************************* -}
-
--- TyConUniques available: 200-299
--- Check in GHC.Builtin.Names if you want to change this
-
-expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
-    patTyConKey,
-    stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey,
-    tyVarBndrUnitTyConKey, tyVarBndrSpecTyConKey,
-    decTyConKey, bangTypeTyConKey, varBangTypeTyConKey,
-    fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
-    funDepTyConKey, predTyConKey,
-    predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey,
-    roleTyConKey, codeTyConKey, injAnnTyConKey, kindTyConKey,
-    overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey,
-    modNameTyConKey  :: Unique
-expTyConKey             = mkPreludeTyConUnique 200
-matchTyConKey           = mkPreludeTyConUnique 201
-clauseTyConKey          = mkPreludeTyConUnique 202
-qTyConKey               = mkPreludeTyConUnique 203
-expQTyConKey            = mkPreludeTyConUnique 204
-patTyConKey             = mkPreludeTyConUnique 206
-stmtTyConKey            = mkPreludeTyConUnique 209
-conTyConKey             = mkPreludeTyConUnique 210
-typeQTyConKey           = mkPreludeTyConUnique 211
-typeTyConKey            = mkPreludeTyConUnique 212
-decTyConKey             = mkPreludeTyConUnique 213
-bangTypeTyConKey        = mkPreludeTyConUnique 214
-varBangTypeTyConKey     = mkPreludeTyConUnique 215
-fieldExpTyConKey        = mkPreludeTyConUnique 216
-fieldPatTyConKey        = mkPreludeTyConUnique 217
-nameTyConKey            = mkPreludeTyConUnique 218
-patQTyConKey            = mkPreludeTyConUnique 219
-funDepTyConKey          = mkPreludeTyConUnique 222
-predTyConKey            = mkPreludeTyConUnique 223
-predQTyConKey           = mkPreludeTyConUnique 224
-tyVarBndrUnitTyConKey   = mkPreludeTyConUnique 225
-decsQTyConKey           = mkPreludeTyConUnique 226
-ruleBndrTyConKey        = mkPreludeTyConUnique 227
-tySynEqnTyConKey        = mkPreludeTyConUnique 228
-roleTyConKey            = mkPreludeTyConUnique 229
-injAnnTyConKey          = mkPreludeTyConUnique 231
-kindTyConKey            = mkPreludeTyConUnique 232
-overlapTyConKey         = mkPreludeTyConUnique 233
-derivClauseTyConKey     = mkPreludeTyConUnique 234
-derivStrategyTyConKey   = mkPreludeTyConUnique 235
-decsTyConKey            = mkPreludeTyConUnique 236
-tyVarBndrSpecTyConKey   = mkPreludeTyConUnique 237
-codeTyConKey            = mkPreludeTyConUnique 238
-modNameTyConKey         = mkPreludeTyConUnique 239
-
-{- *********************************************************************
-*                                                                      *
-                     DataCon keys
-*                                                                      *
-********************************************************************* -}
-
--- DataConUniques available: 100-150
--- If you want to change this, make sure you check in GHC.Builtin.Names
-
--- data Inline = ...
-noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
-noInlineDataConKey  = mkPreludeDataConUnique 200
-inlineDataConKey    = mkPreludeDataConUnique 201
-inlinableDataConKey = mkPreludeDataConUnique 202
-
--- data RuleMatch = ...
-conLikeDataConKey, funLikeDataConKey :: Unique
-conLikeDataConKey = mkPreludeDataConUnique 204
-funLikeDataConKey = mkPreludeDataConUnique 205
-
--- data Phases = ...
-allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique
-allPhasesDataConKey   = mkPreludeDataConUnique 206
-fromPhaseDataConKey   = mkPreludeDataConUnique 207
-beforePhaseDataConKey = mkPreludeDataConUnique 208
-
--- data Overlap = ..
-overlappableDataConKey,
-  overlappingDataConKey,
-  overlapsDataConKey,
-  incoherentDataConKey :: Unique
-overlappableDataConKey = mkPreludeDataConUnique 209
-overlappingDataConKey  = mkPreludeDataConUnique 210
-overlapsDataConKey     = mkPreludeDataConUnique 211
-incoherentDataConKey   = mkPreludeDataConUnique 212
-
-{- *********************************************************************
-*                                                                      *
-                     Id keys
-*                                                                      *
-********************************************************************* -}
-
--- IdUniques available: 200-499
--- If you want to change this, make sure you check in GHC.Builtin.Names
-
-returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
-    mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
-    mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey,
-    unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey :: Unique
-returnQIdKey        = mkPreludeMiscIdUnique 200
-bindQIdKey          = mkPreludeMiscIdUnique 201
-sequenceQIdKey      = mkPreludeMiscIdUnique 202
-liftIdKey           = mkPreludeMiscIdUnique 203
-newNameIdKey         = mkPreludeMiscIdUnique 204
-mkNameIdKey          = mkPreludeMiscIdUnique 205
-mkNameG_vIdKey       = mkPreludeMiscIdUnique 206
-mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
-mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
-mkNameLIdKey         = mkPreludeMiscIdUnique 209
-mkNameSIdKey         = mkPreludeMiscIdUnique 210
-unTypeIdKey          = mkPreludeMiscIdUnique 211
-unTypeCodeIdKey      = mkPreludeMiscIdUnique 212
-liftTypedIdKey        = mkPreludeMiscIdUnique 214
-mkModNameIdKey        = mkPreludeMiscIdUnique 215
-unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216
-
-
--- data Lit = ...
-charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
-    floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey, stringPrimLIdKey,
-    charPrimLIdKey:: Unique
-charLIdKey        = mkPreludeMiscIdUnique 220
-stringLIdKey      = mkPreludeMiscIdUnique 221
-integerLIdKey     = mkPreludeMiscIdUnique 222
-intPrimLIdKey     = mkPreludeMiscIdUnique 223
-wordPrimLIdKey    = mkPreludeMiscIdUnique 224
-floatPrimLIdKey   = mkPreludeMiscIdUnique 225
-doublePrimLIdKey  = mkPreludeMiscIdUnique 226
-rationalLIdKey    = mkPreludeMiscIdUnique 227
-stringPrimLIdKey  = mkPreludeMiscIdUnique 228
-charPrimLIdKey    = mkPreludeMiscIdUnique 229
-
-liftStringIdKey :: Unique
-liftStringIdKey     = mkPreludeMiscIdUnique 230
-
--- data Pat = ...
-litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey,
-  infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey,
-  listPIdKey, sigPIdKey, viewPIdKey :: Unique
-litPIdKey         = mkPreludeMiscIdUnique 240
-varPIdKey         = mkPreludeMiscIdUnique 241
-tupPIdKey         = mkPreludeMiscIdUnique 242
-unboxedTupPIdKey  = mkPreludeMiscIdUnique 243
-unboxedSumPIdKey  = mkPreludeMiscIdUnique 244
-conPIdKey         = mkPreludeMiscIdUnique 245
-infixPIdKey       = mkPreludeMiscIdUnique 246
-tildePIdKey       = mkPreludeMiscIdUnique 247
-bangPIdKey        = mkPreludeMiscIdUnique 248
-asPIdKey          = mkPreludeMiscIdUnique 249
-wildPIdKey        = mkPreludeMiscIdUnique 250
-recPIdKey         = mkPreludeMiscIdUnique 251
-listPIdKey        = mkPreludeMiscIdUnique 252
-sigPIdKey         = mkPreludeMiscIdUnique 253
-viewPIdKey        = mkPreludeMiscIdUnique 254
-
--- type FieldPat = ...
-fieldPatIdKey :: Unique
-fieldPatIdKey       = mkPreludeMiscIdUnique 260
-
--- data Match = ...
-matchIdKey :: Unique
-matchIdKey          = mkPreludeMiscIdUnique 261
-
--- data Clause = ...
-clauseIdKey :: Unique
-clauseIdKey         = mkPreludeMiscIdUnique 262
-
-
--- data Exp = ...
-varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,
-    infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey,
-    lamCasesEIdKey, tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey,
-    multiIfEIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
-    fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
-    listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
-    unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey,
-    getFieldEIdKey, projectionEIdKey :: Unique
-varEIdKey              = mkPreludeMiscIdUnique 270
-conEIdKey              = mkPreludeMiscIdUnique 271
-litEIdKey              = mkPreludeMiscIdUnique 272
-appEIdKey              = mkPreludeMiscIdUnique 273
-appTypeEIdKey          = mkPreludeMiscIdUnique 274
-infixEIdKey            = mkPreludeMiscIdUnique 275
-infixAppIdKey          = mkPreludeMiscIdUnique 276
-sectionLIdKey          = mkPreludeMiscIdUnique 277
-sectionRIdKey          = mkPreludeMiscIdUnique 278
-lamEIdKey              = mkPreludeMiscIdUnique 279
-lamCaseEIdKey          = mkPreludeMiscIdUnique 280
-lamCasesEIdKey         = mkPreludeMiscIdUnique 281
-tupEIdKey              = mkPreludeMiscIdUnique 282
-unboxedTupEIdKey       = mkPreludeMiscIdUnique 283
-unboxedSumEIdKey       = mkPreludeMiscIdUnique 284
-condEIdKey             = mkPreludeMiscIdUnique 285
-multiIfEIdKey          = mkPreludeMiscIdUnique 286
-letEIdKey              = mkPreludeMiscIdUnique 287
-caseEIdKey             = mkPreludeMiscIdUnique 288
-doEIdKey               = mkPreludeMiscIdUnique 289
-compEIdKey             = mkPreludeMiscIdUnique 290
-fromEIdKey             = mkPreludeMiscIdUnique 291
-fromThenEIdKey         = mkPreludeMiscIdUnique 292
-fromToEIdKey           = mkPreludeMiscIdUnique 293
-fromThenToEIdKey       = mkPreludeMiscIdUnique 294
-listEIdKey             = mkPreludeMiscIdUnique 295
-sigEIdKey              = mkPreludeMiscIdUnique 296
-recConEIdKey           = mkPreludeMiscIdUnique 297
-recUpdEIdKey           = mkPreludeMiscIdUnique 298
-staticEIdKey           = mkPreludeMiscIdUnique 299
-unboundVarEIdKey       = mkPreludeMiscIdUnique 300
-labelEIdKey            = mkPreludeMiscIdUnique 301
-implicitParamVarEIdKey = mkPreludeMiscIdUnique 302
-mdoEIdKey              = mkPreludeMiscIdUnique 303
-getFieldEIdKey         = mkPreludeMiscIdUnique 304
-projectionEIdKey       = mkPreludeMiscIdUnique 305
-
--- type FieldExp = ...
-fieldExpIdKey :: Unique
-fieldExpIdKey       = mkPreludeMiscIdUnique 306
-
--- data Body = ...
-guardedBIdKey, normalBIdKey :: Unique
-guardedBIdKey     = mkPreludeMiscIdUnique 307
-normalBIdKey      = mkPreludeMiscIdUnique 308
-
--- data Guard = ...
-normalGEIdKey, patGEIdKey :: Unique
-normalGEIdKey     = mkPreludeMiscIdUnique 309
-patGEIdKey        = mkPreludeMiscIdUnique 310
-
--- data Stmt = ...
-bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique
-bindSIdKey       = mkPreludeMiscIdUnique 311
-letSIdKey        = mkPreludeMiscIdUnique 312
-noBindSIdKey     = mkPreludeMiscIdUnique 313
-parSIdKey        = mkPreludeMiscIdUnique 314
-recSIdKey        = mkPreludeMiscIdUnique 315
-
--- data Dec = ...
-funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
-    instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,
-    pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey,
-    pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,
-    openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
-    newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
-    infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
-    patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,
-    kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey :: Unique
-funDIdKey                         = mkPreludeMiscIdUnique 320
-valDIdKey                         = mkPreludeMiscIdUnique 321
-dataDIdKey                        = mkPreludeMiscIdUnique 322
-newtypeDIdKey                     = mkPreludeMiscIdUnique 323
-tySynDIdKey                       = mkPreludeMiscIdUnique 324
-classDIdKey                       = mkPreludeMiscIdUnique 325
-instanceWithOverlapDIdKey         = mkPreludeMiscIdUnique 326
-instanceDIdKey                    = mkPreludeMiscIdUnique 327
-sigDIdKey                         = mkPreludeMiscIdUnique 328
-forImpDIdKey                      = mkPreludeMiscIdUnique 329
-pragInlDIdKey                     = mkPreludeMiscIdUnique 330
-pragSpecDIdKey                    = mkPreludeMiscIdUnique 331
-pragSpecInlDIdKey                 = mkPreludeMiscIdUnique 332
-pragSpecInstDIdKey                = mkPreludeMiscIdUnique 333
-pragRuleDIdKey                    = mkPreludeMiscIdUnique 334
-pragAnnDIdKey                     = mkPreludeMiscIdUnique 335
-dataFamilyDIdKey                  = mkPreludeMiscIdUnique 336
-openTypeFamilyDIdKey              = mkPreludeMiscIdUnique 337
-dataInstDIdKey                    = mkPreludeMiscIdUnique 338
-newtypeInstDIdKey                 = mkPreludeMiscIdUnique 339
-tySynInstDIdKey                   = mkPreludeMiscIdUnique 340
-closedTypeFamilyDIdKey            = mkPreludeMiscIdUnique 341
-infixLDIdKey                      = mkPreludeMiscIdUnique 342
-infixRDIdKey                      = mkPreludeMiscIdUnique 343
-infixNDIdKey                      = mkPreludeMiscIdUnique 344
-roleAnnotDIdKey                   = mkPreludeMiscIdUnique 345
-standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346
-defaultSigDIdKey                  = mkPreludeMiscIdUnique 347
-patSynDIdKey                      = mkPreludeMiscIdUnique 348
-patSynSigDIdKey                   = mkPreludeMiscIdUnique 349
-pragCompleteDIdKey                = mkPreludeMiscIdUnique 350
-implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351
-kiSigDIdKey                       = mkPreludeMiscIdUnique 352
-defaultDIdKey                     = mkPreludeMiscIdUnique 353
-pragOpaqueDIdKey                   = mkPreludeMiscIdUnique 354
-
--- type Cxt = ...
-cxtIdKey :: Unique
-cxtIdKey               = mkPreludeMiscIdUnique 361
-
--- data SourceUnpackedness = ...
-noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique
-noSourceUnpackednessKey = mkPreludeMiscIdUnique 362
-sourceNoUnpackKey       = mkPreludeMiscIdUnique 363
-sourceUnpackKey         = mkPreludeMiscIdUnique 364
-
--- data SourceStrictness = ...
-noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique
-noSourceStrictnessKey   = mkPreludeMiscIdUnique 365
-sourceLazyKey           = mkPreludeMiscIdUnique 366
-sourceStrictKey         = mkPreludeMiscIdUnique 367
-
--- data Con = ...
-normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,
-  recGadtCIdKey :: Unique
-normalCIdKey      = mkPreludeMiscIdUnique 368
-recCIdKey         = mkPreludeMiscIdUnique 369
-infixCIdKey       = mkPreludeMiscIdUnique 370
-forallCIdKey      = mkPreludeMiscIdUnique 371
-gadtCIdKey        = mkPreludeMiscIdUnique 372
-recGadtCIdKey     = mkPreludeMiscIdUnique 373
-
--- data Bang = ...
-bangIdKey :: Unique
-bangIdKey         = mkPreludeMiscIdUnique 374
-
--- type BangType = ...
-bangTKey :: Unique
-bangTKey          = mkPreludeMiscIdUnique 375
-
--- type VarBangType = ...
-varBangTKey :: Unique
-varBangTKey       = mkPreludeMiscIdUnique 376
-
--- data PatSynDir = ...
-unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique
-unidirPatSynIdKey    = mkPreludeMiscIdUnique 377
-implBidirPatSynIdKey = mkPreludeMiscIdUnique 378
-explBidirPatSynIdKey = mkPreludeMiscIdUnique 379
-
--- data PatSynArgs = ...
-prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique
-prefixPatSynIdKey = mkPreludeMiscIdUnique 380
-infixPatSynIdKey  = mkPreludeMiscIdUnique 381
-recordPatSynIdKey = mkPreludeMiscIdUnique 382
-
--- data Type = ...
-forallTIdKey, forallVisTIdKey, varTIdKey, conTIdKey, tupleTIdKey,
-    unboxedTupleTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey,
-    appKindTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey,
-    promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey,
-    wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique
-forallTIdKey        = mkPreludeMiscIdUnique 390
-forallVisTIdKey     = mkPreludeMiscIdUnique 391
-varTIdKey           = mkPreludeMiscIdUnique 392
-conTIdKey           = mkPreludeMiscIdUnique 393
-tupleTIdKey         = mkPreludeMiscIdUnique 394
-unboxedTupleTIdKey  = mkPreludeMiscIdUnique 395
-unboxedSumTIdKey    = mkPreludeMiscIdUnique 396
-arrowTIdKey         = mkPreludeMiscIdUnique 397
-listTIdKey          = mkPreludeMiscIdUnique 398
-appTIdKey           = mkPreludeMiscIdUnique 399
-appKindTIdKey       = mkPreludeMiscIdUnique 400
-sigTIdKey           = mkPreludeMiscIdUnique 401
-equalityTIdKey      = mkPreludeMiscIdUnique 402
-litTIdKey           = mkPreludeMiscIdUnique 403
-promotedTIdKey      = mkPreludeMiscIdUnique 404
-promotedTupleTIdKey = mkPreludeMiscIdUnique 405
-promotedNilTIdKey   = mkPreludeMiscIdUnique 406
-promotedConsTIdKey  = mkPreludeMiscIdUnique 407
-wildCardTIdKey      = mkPreludeMiscIdUnique 408
-implicitParamTIdKey = mkPreludeMiscIdUnique 409
-infixTIdKey         = mkPreludeMiscIdUnique 410
-
--- data TyLit = ...
-numTyLitIdKey, strTyLitIdKey, charTyLitIdKey :: Unique
-numTyLitIdKey  = mkPreludeMiscIdUnique 411
-strTyLitIdKey  = mkPreludeMiscIdUnique 412
-charTyLitIdKey = mkPreludeMiscIdUnique 413
-
--- data TyVarBndr = ...
-plainTVIdKey, kindedTVIdKey :: Unique
-plainTVIdKey       = mkPreludeMiscIdUnique 414
-kindedTVIdKey      = mkPreludeMiscIdUnique 415
-
-plainInvisTVIdKey, kindedInvisTVIdKey :: Unique
-plainInvisTVIdKey       = mkPreludeMiscIdUnique 482
-kindedInvisTVIdKey      = mkPreludeMiscIdUnique 483
-
--- data Role = ...
-nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique
-nominalRIdKey          = mkPreludeMiscIdUnique 416
-representationalRIdKey = mkPreludeMiscIdUnique 417
-phantomRIdKey          = mkPreludeMiscIdUnique 418
-inferRIdKey            = mkPreludeMiscIdUnique 419
-
--- data Kind = ...
-starKIdKey, constraintKIdKey :: Unique
-starKIdKey        = mkPreludeMiscIdUnique 425
-constraintKIdKey  = mkPreludeMiscIdUnique 426
-
--- data FamilyResultSig = ...
-noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique
-noSigIdKey        = mkPreludeMiscIdUnique 427
-kindSigIdKey      = mkPreludeMiscIdUnique 428
-tyVarSigIdKey     = mkPreludeMiscIdUnique 429
-
--- data InjectivityAnn = ...
-injectivityAnnIdKey :: Unique
-injectivityAnnIdKey = mkPreludeMiscIdUnique 430
-
--- data Callconv = ...
-cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey,
-  javaScriptCallIdKey :: Unique
-cCallIdKey          = mkPreludeMiscIdUnique 431
-stdCallIdKey        = mkPreludeMiscIdUnique 432
-cApiCallIdKey       = mkPreludeMiscIdUnique 433
-primCallIdKey       = mkPreludeMiscIdUnique 434
-javaScriptCallIdKey = mkPreludeMiscIdUnique 435
-
--- data Safety = ...
-unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
-unsafeIdKey        = mkPreludeMiscIdUnique 440
-safeIdKey          = mkPreludeMiscIdUnique 441
-interruptibleIdKey = mkPreludeMiscIdUnique 442
-
--- data FunDep = ...
-funDepIdKey :: Unique
-funDepIdKey = mkPreludeMiscIdUnique 445
-
--- mulArrow
-mulArrowTIdKey :: Unique
-mulArrowTIdKey = mkPreludeMiscIdUnique 446
-
--- data TySynEqn = ...
-tySynEqnIdKey :: Unique
-tySynEqnIdKey = mkPreludeMiscIdUnique 460
-
--- quasiquoting
-quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
-quoteExpKey  = mkPreludeMiscIdUnique 470
-quotePatKey  = mkPreludeMiscIdUnique 471
-quoteDecKey  = mkPreludeMiscIdUnique 472
-quoteTypeKey = mkPreludeMiscIdUnique 473
-
--- data RuleBndr = ...
-ruleVarIdKey, typedRuleVarIdKey :: Unique
-ruleVarIdKey      = mkPreludeMiscIdUnique 480
-typedRuleVarIdKey = mkPreludeMiscIdUnique 481
-
--- data AnnTarget = ...
-valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique
-valueAnnotationIdKey  = mkPreludeMiscIdUnique 490
-typeAnnotationIdKey   = mkPreludeMiscIdUnique 491
-moduleAnnotationIdKey = mkPreludeMiscIdUnique 492
-
--- type DerivPred = ...
-derivClauseIdKey :: Unique
-derivClauseIdKey = mkPreludeMiscIdUnique 493
-
--- data DerivStrategy = ...
-stockStrategyIdKey, anyclassStrategyIdKey, newtypeStrategyIdKey,
-  viaStrategyIdKey :: Unique
-stockStrategyIdKey    = mkPreludeDataConUnique 494
-anyclassStrategyIdKey = mkPreludeDataConUnique 495
-newtypeStrategyIdKey  = mkPreludeDataConUnique 496
-viaStrategyIdKey      = mkPreludeDataConUnique 497
-
--- data Specificity = ...
-specifiedSpecKey, inferredSpecKey :: Unique
-specifiedSpecKey = mkPreludeMiscIdUnique 498
-inferredSpecKey  = mkPreludeMiscIdUnique 499
-
-{-
-************************************************************************
-*                                                                      *
-                        RdrNames
-*                                                                      *
-************************************************************************
--}
-
-lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR, unsafeCodeCoerce_RDR :: RdrName
-lift_RDR     = nameRdrName liftName
-liftTyped_RDR = nameRdrName liftTypedName
-unsafeCodeCoerce_RDR = nameRdrName unsafeCodeCoerceName
-mkNameG_dRDR = nameRdrName mkNameG_dName
-mkNameG_vRDR = nameRdrName mkNameG_vName
-
--- data Exp = ...
-conE_RDR, litE_RDR, appE_RDR, infixApp_RDR :: RdrName
-conE_RDR     = nameRdrName conEName
-litE_RDR     = nameRdrName litEName
-appE_RDR     = nameRdrName appEName
-infixApp_RDR = nameRdrName infixAppName
-
--- data Lit = ...
-stringL_RDR, intPrimL_RDR, wordPrimL_RDR, floatPrimL_RDR,
-    doublePrimL_RDR, stringPrimL_RDR, charPrimL_RDR :: RdrName
-stringL_RDR     = nameRdrName stringLName
-intPrimL_RDR    = nameRdrName intPrimLName
-wordPrimL_RDR   = nameRdrName wordPrimLName
-floatPrimL_RDR  = nameRdrName floatPrimLName
-doublePrimL_RDR = nameRdrName doublePrimLName
-stringPrimL_RDR = nameRdrName stringPrimLName
-charPrimL_RDR   = nameRdrName charPrimLName
diff --git a/compiler/GHC/Builtin/PrimOps/Casts.hs b/compiler/GHC/Builtin/PrimOps/Casts.hs
deleted file mode 100644
--- a/compiler/GHC/Builtin/PrimOps/Casts.hs
+++ /dev/null
@@ -1,212 +0,0 @@
-{-
-This module contains helpers to cast variables
-between different Int/WordReps in StgLand.
-
--}
-
-module GHC.Builtin.PrimOps.Casts
-    ( getCasts )
-where
-
-import GHC.Prelude
-
-import GHC.Core.TyCon
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Types.RepType
-import GHC.Core.Type
-import GHC.Builtin.Types.Prim
-
-import GHC.Builtin.PrimOps
-import GHC.Plugins (HasDebugCallStack)
-
-{- Note [PrimRep based casting]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This module contains a number of utility functions useful when
-converting between variables of differing PrimReps.
-
-The general pattern is:
-* We have two primReps `from_rep` and `to_rep`.
-* We want a list of PrimOps we can apply to a variable of rep `from_rep`.
-Applying the list of primOps in order takes us to `to_rep` from `from_rep` giving
-us a variable of the returned type at each step.
-
-E.g. we call `getCasts from_rep to_rep` and get back [(op1#,ty1),(op2#,ty2)].
-We can use this result to construct a function of type
-`StgExpr -> StgExpr` by construction an expression
-
-    case op1# <from> of (x' :: ty1) -> case op2# x' of x' -> <rhs_hole>
-
-Ideally backends will compile the sequence of PrimOps to a no-op. E.g. by reusing
-the same register but just relabeling it as another width.
-However this is might not always be possible or the required optimizations
-simply not implemented in the backend. This means currently many of these casts
-will be cheap but not all of them will be completely zero-cost.
-
--}
-
--- | `getCasts from_rep to_rep` gives us a list of primops which when applied in order convert from_rep to to_rep.
--- See Note [PrimRep based casting]
-getCasts :: PrimRep -> PrimRep -> [(PrimOp,Type)]
-getCasts from_rep to_rep
-  -- No-op
-  | -- pprTrace "getCasts" (ppr (from_rep,to_rep)) $
-    to_rep == from_rep
-  = []
-
-  -- Float <-> Double
-  | to_rep == FloatRep =
-    assertPpr (from_rep == DoubleRep) (ppr from_rep <+> ppr to_rep) $
-    [(DoubleToFloatOp,floatPrimTy)]
-  | to_rep == DoubleRep =
-    assertPpr (from_rep == FloatRep) (ppr from_rep <+> ppr to_rep) $
-    [(FloatToDoubleOp,doublePrimTy)]
-
-  -- Addr <-> Word/Int
-  | to_rep == AddrRep = wordOrIntToAddrRep from_rep
-  | from_rep == AddrRep = addrToWordOrIntRep to_rep
-
-  -- Int* -> Int*
-  | primRepIsInt from_rep
-  , primRepIsInt to_rep
-  = sizedIntToSizedInt from_rep to_rep
-
-  -- Word* -> Word*
-  | primRepIsWord from_rep
-  , primRepIsWord to_rep
-  = sizedWordToSizedWord from_rep to_rep
-
-  -- Word* -> Int*
-  | primRepIsWord from_rep
-  , primRepIsInt to_rep
-  = let (op1,r1) = wordToIntRep from_rep
-    in (op1,primRepToType r1):sizedIntToSizedInt r1 to_rep
-
-  -- Int* -> Word*
-  | primRepIsInt from_rep
-  , primRepIsWord to_rep
-  = let (op1,r1) = intToWordRep from_rep
-    in (op1,primRepToType r1):sizedWordToSizedWord r1 to_rep
-
-  | otherwise = pprPanic "getCasts:Unexpect rep combination"
-                          (ppr (from_rep,to_rep))
-
-wordOrIntToAddrRep :: HasDebugCallStack => PrimRep -> [(PrimOp,Type)]
-wordOrIntToAddrRep AddrRep = [] -- No-op argument is already AddrRep
-wordOrIntToAddrRep IntRep = [(IntToAddrOp, addrPrimTy)]
-wordOrIntToAddrRep WordRep = [(WordToIntOp,intPrimTy), (IntToAddrOp,addrPrimTy)]
-wordOrIntToAddrRep r
-    | primRepIsInt r = (intToMachineInt r,intPrimTy):[(IntToAddrOp,addrPrimTy)]
-    | primRepIsWord r =
-        let (op1,r1) = wordToIntRep r
-        in (op1, primRepToType r1):[(intToMachineInt r1,intPrimTy), (IntToAddrOp,addrPrimTy)]
-    | otherwise = pprPanic "Rep not word or int rep" (ppr r)
-
-addrToWordOrIntRep :: HasDebugCallStack => PrimRep -> [(PrimOp,Type)]
--- Machine sizes
-addrToWordOrIntRep IntRep = [(AddrToIntOp, intPrimTy)]
-addrToWordOrIntRep WordRep = [(AddrToIntOp,intPrimTy), (IntToWordOp,wordPrimTy)]
--- Explicitly sized reps
-addrToWordOrIntRep r
-    | primRepIsWord r = (AddrToIntOp,intPrimTy) : (IntToWordOp,wordPrimTy) : sizedWordToSizedWord WordRep r
-    | primRepIsInt r = (AddrToIntOp,intPrimTy) : sizedIntToSizedInt IntRep r
-    | otherwise = pprPanic "Target rep not word or int rep" (ppr r)
-
-
--- WordX# -> IntX# (same size), argument is source rep
-wordToIntRep :: HasDebugCallStack => PrimRep -> (PrimOp,PrimRep)
-wordToIntRep rep
-    = case rep of
-        (WordRep) -> (WordToIntOp, IntRep)
-        (Word8Rep) -> (Word8ToInt8Op, Int8Rep)
-        (Word16Rep) -> (Word16ToInt16Op, Int16Rep)
-        (Word32Rep) -> (Word32ToInt32Op, Int32Rep)
-        (Word64Rep) -> (Word64ToInt64Op, Int64Rep)
-        _ -> pprPanic "Rep not a wordRep" (ppr rep)
-
--- IntX# -> WordX#, argument is source rep
-intToWordRep :: HasDebugCallStack => PrimRep -> (PrimOp,PrimRep)
-intToWordRep rep
-    = case rep of
-        (IntRep) -> (IntToWordOp, WordRep)
-        (Int8Rep) -> (Int8ToWord8Op, Word8Rep)
-        (Int16Rep) -> (Int16ToWord16Op, Word16Rep)
-        (Int32Rep) -> (Int32ToWord32Op, Word32Rep)
-        (Int64Rep) -> (Int64ToWord64Op, Word64Rep)
-        _ -> pprPanic "Rep not a wordRep" (ppr rep)
-
--- Casts between any size int to any other size of int
-sizedIntToSizedInt :: HasDebugCallStack => PrimRep -> PrimRep -> [(PrimOp,Type)]
-sizedIntToSizedInt r1 r2
-    | r1 == r2 = []
--- Cast to Int#
-sizedIntToSizedInt r IntRep = [(intToMachineInt r,intPrimTy)]
--- Cast from Int#
-sizedIntToSizedInt IntRep r = [(intFromMachineInt r,primRepToType r)]
--- Sized to differently sized must go over machine word.
-sizedIntToSizedInt r1 r2 = (intToMachineInt r1,intPrimTy) : [(intFromMachineInt r2,primRepToType r2)]
-
--- Casts between any size Word to any other size of Word
-sizedWordToSizedWord :: HasDebugCallStack => PrimRep -> PrimRep -> [(PrimOp,Type)]
-sizedWordToSizedWord r1 r2
-    | r1 == r2 = []
--- Cast to Word#
-sizedWordToSizedWord r WordRep = [(wordToMachineWord r,wordPrimTy)]
--- Cast from Word#
-sizedWordToSizedWord WordRep r = [(wordFromMachineWord r, primRepToType r)]
--- Conversion between different non-machine sizes must go via machine word.
-sizedWordToSizedWord r1 r2 = (wordToMachineWord r1,wordPrimTy) : [(wordFromMachineWord r2, primRepToType r2)]
-
-
--- Prefer the definitions above this line if possible
-----------------------
-
-
--- Int*# to Int#
-{-# INLINE intToMachineInt #-}
-intToMachineInt :: HasDebugCallStack => PrimRep -> PrimOp
-intToMachineInt r =
-    assertPpr (primRepIsInt r) (ppr r) $
-    case r of
-        (Int8Rep) -> Int8ToIntOp
-        (Int16Rep) -> Int16ToIntOp
-        (Int32Rep) -> Int32ToIntOp
-        (Int64Rep) -> Int64ToIntOp
-        _ -> pprPanic "Source rep not int" $ ppr r
-
--- Int# to Int*#
-{-# INLINE intFromMachineInt #-}
-intFromMachineInt :: HasDebugCallStack => PrimRep -> PrimOp
-intFromMachineInt r =
-    assertPpr (primRepIsInt r) (ppr r) $
-    case r of
-        Int8Rep -> IntToInt8Op
-        Int16Rep -> IntToInt16Op
-        Int32Rep -> IntToInt32Op
-        Int64Rep -> IntToInt64Op
-        _ -> pprPanic "Dest rep not sized int" $ ppr r
-
--- Word# to Word*#
-{-# INLINE wordFromMachineWord #-}
-wordFromMachineWord :: HasDebugCallStack => PrimRep -> PrimOp
-wordFromMachineWord r =
-    assert (primRepIsWord r) $
-    case r of
-        Word8Rep -> WordToWord8Op
-        Word16Rep -> WordToWord16Op
-        Word32Rep -> WordToWord32Op
-        Word64Rep -> WordToWord64Op
-        _ -> pprPanic "Dest rep not sized word" $ ppr r
-
--- Word*# to Word#
-{-# INLINE wordToMachineWord #-}
-wordToMachineWord :: HasDebugCallStack => PrimRep -> PrimOp
-wordToMachineWord r =
-    assertPpr (primRepIsWord r) (text "Not a word rep:" <> ppr r) $
-    case r of
-        Word8Rep -> Word8ToWordOp
-        Word16Rep -> Word16ToWordOp
-        Word32Rep -> Word32ToWordOp
-        Word64Rep -> Word64ToWordOp
-        _ -> pprPanic "Dest rep not sized word" $ ppr r
diff --git a/compiler/GHC/Builtin/Types/Literals.hs b/compiler/GHC/Builtin/Types/Literals.hs
deleted file mode 100644
--- a/compiler/GHC/Builtin/Types/Literals.hs
+++ /dev/null
@@ -1,1163 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
-module GHC.Builtin.Types.Literals
-  ( typeNatTyCons
-  , typeNatCoAxiomRules
-  , BuiltInSynFamily(..)
-
-    -- If you define a new built-in type family, make sure to export its TyCon
-    -- from here as well.
-    -- See Note [Adding built-in type families]
-  , typeNatAddTyCon
-  , typeNatMulTyCon
-  , typeNatExpTyCon
-  , typeNatSubTyCon
-  , typeNatDivTyCon
-  , typeNatModTyCon
-  , typeNatLogTyCon
-  , typeNatCmpTyCon
-  , typeSymbolCmpTyCon
-  , typeSymbolAppendTyCon
-  , typeCharCmpTyCon
-  , typeConsSymbolTyCon
-  , typeUnconsSymbolTyCon
-  , typeCharToNatTyCon
-  , typeNatToCharTyCon
-  ) where
-
-import GHC.Prelude
-
-import GHC.Core.Type
-import GHC.Data.Pair
-import GHC.Core.TyCon    ( TyCon, FamTyConFlav(..), mkFamilyTyCon
-                         , Injectivity(..) )
-import GHC.Core.Coercion ( Role(..) )
-import GHC.Tc.Types.Constraint ( Xi )
-import GHC.Core.Coercion.Axiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn )
-import GHC.Core.TyCo.Compare   ( tcEqType )
-import GHC.Types.Name          ( Name, BuiltInSyntax(..) )
-import GHC.Types.Unique.FM
-import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim  ( mkTemplateAnonTyConBinders )
-import GHC.Builtin.Names
-                  ( gHC_TYPELITS
-                  , gHC_TYPELITS_INTERNAL
-                  , gHC_TYPENATS
-                  , gHC_TYPENATS_INTERNAL
-                  , typeNatAddTyFamNameKey
-                  , typeNatMulTyFamNameKey
-                  , typeNatExpTyFamNameKey
-                  , typeNatSubTyFamNameKey
-                  , typeNatDivTyFamNameKey
-                  , typeNatModTyFamNameKey
-                  , typeNatLogTyFamNameKey
-                  , typeNatCmpTyFamNameKey
-                  , typeSymbolCmpTyFamNameKey
-                  , typeSymbolAppendFamNameKey
-                  , typeCharCmpTyFamNameKey
-                  , typeConsSymbolTyFamNameKey
-                  , typeUnconsSymbolTyFamNameKey
-                  , typeCharToNatTyFamNameKey
-                  , typeNatToCharTyFamNameKey
-                  )
-import GHC.Data.FastString
-import Control.Monad ( guard )
-import Data.List  ( isPrefixOf, isSuffixOf )
-import qualified Data.Char as Char
-
-{-
-Note [Type-level literals]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are currently three forms of type-level literals: natural numbers, symbols, and
-characters.
-
-Type-level literals are supported by CoAxiomRules (conditional axioms), which
-power the built-in type families (see Note [Adding built-in type families]).
-Currently, all built-in type families are for the express purpose of supporting
-type-level literals.
-
-See also the Wiki page:
-
-    https://gitlab.haskell.org/ghc/ghc/wikis/type-nats
-
-Note [Adding built-in type families]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are a few steps to adding a built-in type family:
-
-* Adding a unique for the type family TyCon
-
-  These go in GHC.Builtin.Names. It will likely be of the form
-  @myTyFamNameKey = mkPreludeTyConUnique xyz@, where @xyz@ is a number that
-  has not been chosen before in GHC.Builtin.Names. There are several examples already
-  in GHC.Builtin.Names—see, for instance, typeNatAddTyFamNameKey.
-
-* Adding the type family TyCon itself
-
-  This goes in GHC.Builtin.Types.Literals. There are plenty of examples of how to define
-  these—see, for instance, typeNatAddTyCon.
-
-  Once your TyCon has been defined, be sure to:
-
-  - Export it from GHC.Builtin.Types.Literals. (Not doing so caused #14632.)
-  - Include it in the typeNatTyCons list, defined in GHC.Builtin.Types.Literals.
-
-* Exposing associated type family axioms
-
-  When defining the type family TyCon, you will need to define an axiom for
-  the type family in general (see, for instance, axAddDef), and perhaps other
-  auxiliary axioms for special cases of the type family (see, for instance,
-  axAdd0L and axAdd0R).
-
-  After you have defined all of these axioms, be sure to include them in the
-  typeNatCoAxiomRules list, defined in GHC.Builtin.Types.Literals.
-  (Not doing so caused #14934.)
-
-* Define the type family somewhere
-
-  Finally, you will need to define the type family somewhere, likely in @base@.
-  Currently, all of the built-in type families are defined in GHC.TypeLits or
-  GHC.TypeNats, so those are likely candidates.
-
-  Since the behavior of your built-in type family is specified in GHC.Builtin.Types.Literals,
-  you should give an open type family definition with no instances, like so:
-
-    type family MyTypeFam (m :: Nat) (n :: Nat) :: Nat
-
-  Changing the argument and result kinds as appropriate.
-
-* Update the relevant test cases
-
-  The GHC test suite will likely need to be updated after you add your built-in
-  type family. For instance:
-
-  - The T9181 test prints the :browse contents of GHC.TypeLits, so if you added
-    a test there, the expected output of T9181 will need to change.
-  - The TcTypeNatSimple and TcTypeSymbolSimple tests have compile-time unit
-    tests, as well as TcTypeNatSimpleRun and TcTypeSymbolSimpleRun, which have
-    runtime unit tests. Consider adding further unit tests to those if your
-    built-in type family deals with Nats or Symbols, respectively.
--}
-
-{-------------------------------------------------------------------------------
-Built-in type constructors for functions on type-level nats
--}
-
--- The list of built-in type family TyCons that GHC uses.
--- If you define a built-in type family, make sure to add it to this list.
--- See Note [Adding built-in type families]
-typeNatTyCons :: [TyCon]
-typeNatTyCons =
-  [ typeNatAddTyCon
-  , typeNatMulTyCon
-  , typeNatExpTyCon
-  , typeNatSubTyCon
-  , typeNatDivTyCon
-  , typeNatModTyCon
-  , typeNatLogTyCon
-  , typeNatCmpTyCon
-  , typeSymbolCmpTyCon
-  , typeSymbolAppendTyCon
-  , typeCharCmpTyCon
-  , typeConsSymbolTyCon
-  , typeUnconsSymbolTyCon
-  , typeCharToNatTyCon
-  , typeNatToCharTyCon
-  ]
-
-typeNatAddTyCon :: TyCon
-typeNatAddTyCon = mkTypeNatFunTyCon2 name
-  BuiltInSynFamily
-    { sfMatchFam      = matchFamAdd
-    , sfInteractTop   = interactTopAdd
-    , sfInteractInert = interactInertAdd
-    }
-  where
-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "+")
-            typeNatAddTyFamNameKey typeNatAddTyCon
-
-typeNatSubTyCon :: TyCon
-typeNatSubTyCon = mkTypeNatFunTyCon2 name
-  BuiltInSynFamily
-    { sfMatchFam      = matchFamSub
-    , sfInteractTop   = interactTopSub
-    , sfInteractInert = interactInertSub
-    }
-  where
-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "-")
-            typeNatSubTyFamNameKey typeNatSubTyCon
-
-typeNatMulTyCon :: TyCon
-typeNatMulTyCon = mkTypeNatFunTyCon2 name
-  BuiltInSynFamily
-    { sfMatchFam      = matchFamMul
-    , sfInteractTop   = interactTopMul
-    , sfInteractInert = interactInertMul
-    }
-  where
-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "*")
-            typeNatMulTyFamNameKey typeNatMulTyCon
-
-typeNatDivTyCon :: TyCon
-typeNatDivTyCon = mkTypeNatFunTyCon2 name
-  BuiltInSynFamily
-    { sfMatchFam      = matchFamDiv
-    , sfInteractTop   = interactTopDiv
-    , sfInteractInert = interactInertDiv
-    }
-  where
-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Div")
-            typeNatDivTyFamNameKey typeNatDivTyCon
-
-typeNatModTyCon :: TyCon
-typeNatModTyCon = mkTypeNatFunTyCon2 name
-  BuiltInSynFamily
-    { sfMatchFam      = matchFamMod
-    , sfInteractTop   = interactTopMod
-    , sfInteractInert = interactInertMod
-    }
-  where
-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod")
-            typeNatModTyFamNameKey typeNatModTyCon
-
-typeNatExpTyCon :: TyCon
-typeNatExpTyCon = mkTypeNatFunTyCon2 name
-  BuiltInSynFamily
-    { sfMatchFam      = matchFamExp
-    , sfInteractTop   = interactTopExp
-    , sfInteractInert = interactInertExp
-    }
-  where
-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "^")
-                typeNatExpTyFamNameKey typeNatExpTyCon
-
-typeNatLogTyCon :: TyCon
-typeNatLogTyCon = mkTypeNatFunTyCon1 name
-  BuiltInSynFamily
-    { sfMatchFam      = matchFamLog
-    , sfInteractTop   = interactTopLog
-    , sfInteractInert = interactInertLog
-    }
-  where
-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2")
-            typeNatLogTyFamNameKey typeNatLogTyCon
-
-
-
-typeNatCmpTyCon :: TyCon
-typeNatCmpTyCon =
-  mkFamilyTyCon name
-    (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ])
-    orderingKind
-    Nothing
-    (BuiltInSynFamTyCon ops)
-    Nothing
-    NotInjective
-
-  where
-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS_INTERNAL (fsLit "CmpNat")
-                typeNatCmpTyFamNameKey typeNatCmpTyCon
-  ops = BuiltInSynFamily
-    { sfMatchFam      = matchFamCmpNat
-    , sfInteractTop   = interactTopCmpNat
-    , sfInteractInert = \_ _ _ _ -> []
-    }
-
-typeSymbolCmpTyCon :: TyCon
-typeSymbolCmpTyCon =
-  mkFamilyTyCon name
-    (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ])
-    orderingKind
-    Nothing
-    (BuiltInSynFamTyCon ops)
-    Nothing
-    NotInjective
-
-  where
-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS_INTERNAL (fsLit "CmpSymbol")
-                typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon
-  ops = BuiltInSynFamily
-    { sfMatchFam      = matchFamCmpSymbol
-    , sfInteractTop   = interactTopCmpSymbol
-    , sfInteractInert = \_ _ _ _ -> []
-    }
-
-typeSymbolAppendTyCon :: TyCon
-typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name
-  BuiltInSynFamily
-    { sfMatchFam      = matchFamAppendSymbol
-    , sfInteractTop   = interactTopAppendSymbol
-    , sfInteractInert = interactInertAppendSymbol
-    }
-  where
-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "AppendSymbol")
-                typeSymbolAppendFamNameKey typeSymbolAppendTyCon
-
-typeConsSymbolTyCon :: TyCon
-typeConsSymbolTyCon =
-  mkFamilyTyCon name
-    (mkTemplateAnonTyConBinders [ charTy, typeSymbolKind ])
-    typeSymbolKind
-    Nothing
-    (BuiltInSynFamTyCon ops)
-    Nothing
-    (Injective [True, True])
-  where
-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "ConsSymbol")
-                  typeConsSymbolTyFamNameKey typeConsSymbolTyCon
-  ops = BuiltInSynFamily
-      { sfMatchFam      = matchFamConsSymbol
-      , sfInteractTop   = interactTopConsSymbol
-      , sfInteractInert = interactInertConsSymbol
-      }
-
-typeUnconsSymbolTyCon :: TyCon
-typeUnconsSymbolTyCon =
-  mkFamilyTyCon name
-    (mkTemplateAnonTyConBinders [ typeSymbolKind ])
-    (mkMaybeTy charSymbolPairKind)
-    Nothing
-    (BuiltInSynFamTyCon ops)
-    Nothing
-    (Injective [True])
-  where
-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "UnconsSymbol")
-                  typeUnconsSymbolTyFamNameKey typeUnconsSymbolTyCon
-  ops = BuiltInSynFamily
-      { sfMatchFam      = matchFamUnconsSymbol
-      , sfInteractTop   = interactTopUnconsSymbol
-      , sfInteractInert = interactInertUnconsSymbol
-      }
-
-typeCharToNatTyCon :: TyCon
-typeCharToNatTyCon =
-  mkFamilyTyCon name
-    (mkTemplateAnonTyConBinders [ charTy ])
-    naturalTy
-    Nothing
-    (BuiltInSynFamTyCon ops)
-    Nothing
-    (Injective [True])
-  where
-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CharToNat")
-                  typeCharToNatTyFamNameKey typeCharToNatTyCon
-  ops = BuiltInSynFamily
-      { sfMatchFam      = matchFamCharToNat
-      , sfInteractTop   = interactTopCharToNat
-      , sfInteractInert = \_ _ _ _ -> []
-      }
-
-
-typeNatToCharTyCon :: TyCon
-typeNatToCharTyCon =
-  mkFamilyTyCon name
-    (mkTemplateAnonTyConBinders [ naturalTy ])
-    charTy
-    Nothing
-    (BuiltInSynFamTyCon ops)
-    Nothing
-    (Injective [True])
-  where
-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "NatToChar")
-                  typeNatToCharTyFamNameKey typeNatToCharTyCon
-  ops = BuiltInSynFamily
-      { sfMatchFam      = matchFamNatToChar
-      , sfInteractTop   = interactTopNatToChar
-      , sfInteractInert = \_ _ _ _ -> []
-      }
-
--- Make a unary built-in constructor of kind: Nat -> Nat
-mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon
-mkTypeNatFunTyCon1 op tcb =
-  mkFamilyTyCon op
-    (mkTemplateAnonTyConBinders [ naturalTy ])
-    naturalTy
-    Nothing
-    (BuiltInSynFamTyCon tcb)
-    Nothing
-    NotInjective
-
--- Make a binary built-in constructor of kind: Nat -> Nat -> Nat
-mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon
-mkTypeNatFunTyCon2 op tcb =
-  mkFamilyTyCon op
-    (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ])
-    naturalTy
-    Nothing
-    (BuiltInSynFamTyCon tcb)
-    Nothing
-    NotInjective
-
--- Make a binary built-in constructor of kind: Symbol -> Symbol -> Symbol
-mkTypeSymbolFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon
-mkTypeSymbolFunTyCon2 op tcb =
-  mkFamilyTyCon op
-    (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ])
-    typeSymbolKind
-    Nothing
-    (BuiltInSynFamTyCon tcb)
-    Nothing
-    NotInjective
-
-{-------------------------------------------------------------------------------
-Built-in rules axioms
--------------------------------------------------------------------------------}
-
--- If you add additional rules, please remember to add them to
--- `typeNatCoAxiomRules` also.
--- See Note [Adding built-in type families]
-axAddDef
-  , axMulDef
-  , axExpDef
-  , axCmpNatDef
-  , axCmpSymbolDef
-  , axAppendSymbolDef
-  , axConsSymbolDef
-  , axUnconsSymbolDef
-  , axCharToNatDef
-  , axNatToCharDef
-  , axAdd0L
-  , axAdd0R
-  , axMul0L
-  , axMul0R
-  , axMul1L
-  , axMul1R
-  , axExp1L
-  , axExp0R
-  , axExp1R
-  , axCmpNatRefl
-  , axCmpSymbolRefl
-  , axSubDef
-  , axSub0R
-  , axAppendSymbol0R
-  , axAppendSymbol0L
-  , axDivDef
-  , axDiv1
-  , axModDef
-  , axMod1
-  , axLogDef
-  :: CoAxiomRule
-
-axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon isNumLitTy isNumLitTy $
-              \x y -> Just $ num (x + y)
-
-axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon isNumLitTy isNumLitTy $
-              \x y -> Just $ num (x * y)
-
-axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon isNumLitTy isNumLitTy $
-              \x y -> Just $ num (x ^ y)
-
-axCmpNatDef   = mkBinAxiom "CmpNatDef" typeNatCmpTyCon isNumLitTy isNumLitTy
-              $ \x y -> Just $ ordering (compare x y)
-
-axCmpSymbolDef =
-  CoAxiomRule
-    { coaxrName      = fsLit "CmpSymbolDef"
-    , coaxrAsmpRoles = [Nominal, Nominal]
-    , coaxrRole      = Nominal
-    , coaxrProves    = \cs ->
-        do [Pair s1 s2, Pair t1 t2] <- return cs
-           s2' <- isStrLitTy s2
-           t2' <- isStrLitTy t2
-           return (mkTyConApp typeSymbolCmpTyCon [s1,t1] ===
-                   ordering (lexicalCompareFS s2' t2')) }
-
-axAppendSymbolDef = CoAxiomRule
-    { coaxrName      = fsLit "AppendSymbolDef"
-    , coaxrAsmpRoles = [Nominal, Nominal]
-    , coaxrRole      = Nominal
-    , coaxrProves    = \cs ->
-        do [Pair s1 s2, Pair t1 t2] <- return cs
-           s2' <- isStrLitTy s2
-           t2' <- isStrLitTy t2
-           let z = mkStrLitTy (appendFS s2' t2')
-           return (mkTyConApp typeSymbolAppendTyCon [s1, t1] === z)
-    }
-
-axConsSymbolDef =
-  mkBinAxiom "ConsSymbolDef" typeConsSymbolTyCon isCharLitTy isStrLitTy $
-    \c str -> Just $ mkStrLitTy (consFS c str)
-
-axUnconsSymbolDef =
-  mkUnAxiom "UnconsSymbolDef" typeUnconsSymbolTyCon isStrLitTy $
-    \str -> Just $
-      mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS str))
-
-axCharToNatDef =
-  mkUnAxiom "CharToNatDef" typeCharToNatTyCon isCharLitTy $
-    \c -> Just $ num (charToInteger c)
-
-axNatToCharDef =
-  mkUnAxiom "NatToCharDef" typeNatToCharTyCon isNumLitTy $
-    \n -> fmap mkCharLitTy (integerToChar n)
-
-axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon isNumLitTy isNumLitTy $
-              \x y -> fmap num (minus x y)
-
-axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon isNumLitTy isNumLitTy $
-              \x y -> do guard (y /= 0)
-                         return (num (div x y))
-
-axModDef = mkBinAxiom "ModDef" typeNatModTyCon isNumLitTy isNumLitTy $
-              \x y -> do guard (y /= 0)
-                         return (num (mod x y))
-
-axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon isNumLitTy $
-              \x -> do (a,_) <- genLog x 2
-                       return (num a)
-
-axAdd0L     = mkAxiom1 "Add0L"    $ \(Pair s t) -> (num 0 .+. s) === t
-axAdd0R     = mkAxiom1 "Add0R"    $ \(Pair s t) -> (s .+. num 0) === t
-axSub0R     = mkAxiom1 "Sub0R"    $ \(Pair s t) -> (s .-. num 0) === t
-axMul0L     = mkAxiom1 "Mul0L"    $ \(Pair s _) -> (num 0 .*. s) === num 0
-axMul0R     = mkAxiom1 "Mul0R"    $ \(Pair s _) -> (s .*. num 0) === num 0
-axMul1L     = mkAxiom1 "Mul1L"    $ \(Pair s t) -> (num 1 .*. s) === t
-axMul1R     = mkAxiom1 "Mul1R"    $ \(Pair s t) -> (s .*. num 1) === t
-axDiv1      = mkAxiom1 "Div1"     $ \(Pair s t) -> (tDiv s (num 1) === t)
-axMod1      = mkAxiom1 "Mod1"     $ \(Pair s _) -> (tMod s (num 1) === num 0)
-                                    -- XXX: Shouldn't we check that _ is 0?
-axExp1L     = mkAxiom1 "Exp1L"    $ \(Pair s _) -> (num 1 .^. s) === num 1
-axExp0R     = mkAxiom1 "Exp0R"    $ \(Pair s _) -> (s .^. num 0) === num 1
-axExp1R     = mkAxiom1 "Exp1R"    $ \(Pair s t) -> (s .^. num 1) === t
-axCmpNatRefl    = mkAxiom1 "CmpNatRefl"
-                $ \(Pair s _) -> (cmpNat s s) === ordering EQ
-axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl"
-                $ \(Pair s _) -> (cmpSymbol s s) === ordering EQ
-axAppendSymbol0R  = mkAxiom1 "Concat0R"
-            $ \(Pair s t) -> (mkStrLitTy nilFS `appendSymbol` s) === t
-axAppendSymbol0L  = mkAxiom1 "Concat0L"
-            $ \(Pair s t) -> (s `appendSymbol` mkStrLitTy nilFS) === t
-
--- The list of built-in type family axioms that GHC uses.
--- If you define new axioms, make sure to include them in this list.
--- See Note [Adding built-in type families]
-typeNatCoAxiomRules :: UniqFM FastString CoAxiomRule
-typeNatCoAxiomRules = listToUFM $ map (\x -> (coaxrName x, x))
-  [ axAddDef
-  , axMulDef
-  , axExpDef
-  , axCmpNatDef
-  , axCmpSymbolDef
-  , axCmpCharDef
-  , axAppendSymbolDef
-  , axConsSymbolDef
-  , axUnconsSymbolDef
-  , axCharToNatDef
-  , axNatToCharDef
-  , axAdd0L
-  , axAdd0R
-  , axMul0L
-  , axMul0R
-  , axMul1L
-  , axMul1R
-  , axExp1L
-  , axExp0R
-  , axExp1R
-  , axCmpNatRefl
-  , axCmpSymbolRefl
-  , axCmpCharRefl
-  , axSubDef
-  , axSub0R
-  , axAppendSymbol0R
-  , axAppendSymbol0L
-  , axDivDef
-  , axDiv1
-  , axModDef
-  , axMod1
-  , axLogDef
-  ]
-
-
-
-{-------------------------------------------------------------------------------
-Various utilities for making axioms and types
--------------------------------------------------------------------------------}
-
-(.+.) :: Type -> Type -> Type
-s .+. t = mkTyConApp typeNatAddTyCon [s,t]
-
-(.-.) :: Type -> Type -> Type
-s .-. t = mkTyConApp typeNatSubTyCon [s,t]
-
-(.*.) :: Type -> Type -> Type
-s .*. t = mkTyConApp typeNatMulTyCon [s,t]
-
-tDiv :: Type -> Type -> Type
-tDiv s t = mkTyConApp typeNatDivTyCon [s,t]
-
-tMod :: Type -> Type -> Type
-tMod s t = mkTyConApp typeNatModTyCon [s,t]
-
-(.^.) :: Type -> Type -> Type
-s .^. t = mkTyConApp typeNatExpTyCon [s,t]
-
-cmpNat :: Type -> Type -> Type
-cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t]
-
-cmpSymbol :: Type -> Type -> Type
-cmpSymbol s t = mkTyConApp typeSymbolCmpTyCon [s,t]
-
-appendSymbol :: Type -> Type -> Type
-appendSymbol s t = mkTyConApp typeSymbolAppendTyCon [s, t]
-
-(===) :: Type -> Type -> Pair Type
-x === y = Pair x y
-
-num :: Integer -> Type
-num = mkNumLitTy
-
-charSymbolPair :: Type -> Type -> Type
-charSymbolPair = mkPromotedPairTy charTy typeSymbolKind
-
-charSymbolPairKind :: Kind
-charSymbolPairKind = mkTyConApp pairTyCon [charTy, typeSymbolKind]
-
-orderingKind :: Kind
-orderingKind = mkTyConApp orderingTyCon []
-
-ordering :: Ordering -> Type
-ordering o =
-  case o of
-    LT -> mkTyConApp promotedLTDataCon []
-    EQ -> mkTyConApp promotedEQDataCon []
-    GT -> mkTyConApp promotedGTDataCon []
-
-isOrderingLitTy :: Type -> Maybe Ordering
-isOrderingLitTy tc =
-  do (tc1,[]) <- splitTyConApp_maybe tc
-     case () of
-       _ | tc1 == promotedLTDataCon -> return LT
-         | tc1 == promotedEQDataCon -> return EQ
-         | tc1 == promotedGTDataCon -> return GT
-         | otherwise                -> Nothing
-
-known :: (Integer -> Bool) -> Type -> Bool
-known p x = case isNumLitTy x of
-              Just a  -> p a
-              Nothing -> False
-
-mkUnAxiom :: String -> TyCon -> (Type -> Maybe a) -> (a -> Maybe Type) -> CoAxiomRule
-mkUnAxiom str tc isReqTy f =
-  CoAxiomRule
-    { coaxrName      = fsLit str
-    , coaxrAsmpRoles = [Nominal]
-    , coaxrRole      = Nominal
-    , coaxrProves    = \cs ->
-        do [Pair s1 s2] <- return cs
-           s2' <- isReqTy s2
-           z   <- f s2'
-           return (mkTyConApp tc [s1] === z)
-    }
-
--- For the definitional axioms
-mkBinAxiom :: String -> TyCon ->
-              (Type -> Maybe a) ->
-              (Type -> Maybe b) ->
-              (a -> b -> Maybe Type) -> CoAxiomRule
-mkBinAxiom str tc isReqTy1 isReqTy2 f =
-  CoAxiomRule
-    { coaxrName      = fsLit str
-    , coaxrAsmpRoles = [Nominal, Nominal]
-    , coaxrRole      = Nominal
-    , coaxrProves    = \cs ->
-        do [Pair s1 s2, Pair t1 t2] <- return cs
-           s2' <- isReqTy1 s2
-           t2' <- isReqTy2 t2
-           z   <- f s2' t2'
-           return (mkTyConApp tc [s1,t1] === z)
-    }
-
-mkAxiom1 :: String -> (TypeEqn -> TypeEqn) -> CoAxiomRule
-mkAxiom1 str f =
-  CoAxiomRule
-    { coaxrName      = fsLit str
-    , coaxrAsmpRoles = [Nominal]
-    , coaxrRole      = Nominal
-    , coaxrProves    = \case [eqn] -> Just (f eqn)
-                             _     -> Nothing
-    }
-
-
-{-------------------------------------------------------------------------------
-Evaluation
--------------------------------------------------------------------------------}
-
-matchFamAdd :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
-matchFamAdd [s,t]
-  | Just 0 <- mbX = Just (axAdd0L, [t], t)
-  | Just 0 <- mbY = Just (axAdd0R, [s], s)
-  | Just x <- mbX, Just y <- mbY =
-    Just (axAddDef, [s,t], num (x + y))
-  where mbX = isNumLitTy s
-        mbY = isNumLitTy t
-matchFamAdd _ = Nothing
-
-matchFamSub :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
-matchFamSub [s,t]
-  | Just 0 <- mbY = Just (axSub0R, [s], s)
-  | Just x <- mbX, Just y <- mbY, Just z <- minus x y =
-    Just (axSubDef, [s,t], num z)
-  where mbX = isNumLitTy s
-        mbY = isNumLitTy t
-matchFamSub _ = Nothing
-
-matchFamMul :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
-matchFamMul [s,t]
-  | Just 0 <- mbX = Just (axMul0L, [t], num 0)
-  | Just 0 <- mbY = Just (axMul0R, [s], num 0)
-  | Just 1 <- mbX = Just (axMul1L, [t], t)
-  | Just 1 <- mbY = Just (axMul1R, [s], s)
-  | Just x <- mbX, Just y <- mbY =
-    Just (axMulDef, [s,t], num (x * y))
-  where mbX = isNumLitTy s
-        mbY = isNumLitTy t
-matchFamMul _ = Nothing
-
-matchFamDiv :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
-matchFamDiv [s,t]
-  | Just 1 <- mbY = Just (axDiv1, [s], s)
-  | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axDivDef, [s,t], num (div x y))
-  where mbX = isNumLitTy s
-        mbY = isNumLitTy t
-matchFamDiv _ = Nothing
-
-matchFamMod :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
-matchFamMod [s,t]
-  | Just 1 <- mbY = Just (axMod1, [s], num 0)
-  | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axModDef, [s,t], num (mod x y))
-  where mbX = isNumLitTy s
-        mbY = isNumLitTy t
-matchFamMod _ = Nothing
-
-matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
-matchFamExp [s,t]
-  | Just 0 <- mbY = Just (axExp0R, [s], num 1)
-  | Just 1 <- mbX = Just (axExp1L, [t], num 1)
-  | Just 1 <- mbY = Just (axExp1R, [s], s)
-  | Just x <- mbX, Just y <- mbY =
-    Just (axExpDef, [s,t], num (x ^ y))
-  where mbX = isNumLitTy s
-        mbY = isNumLitTy t
-matchFamExp _ = Nothing
-
-matchFamLog :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
-matchFamLog [s]
-  | Just x <- mbX, Just (n,_) <- genLog x 2 = Just (axLogDef, [s], num n)
-  where mbX = isNumLitTy s
-matchFamLog _ = Nothing
-
-
-matchFamCmpNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
-matchFamCmpNat [s,t]
-  | Just x <- mbX, Just y <- mbY =
-    Just (axCmpNatDef, [s,t], ordering (compare x y))
-  | tcEqType s t = Just (axCmpNatRefl, [s], ordering EQ)
-  where mbX = isNumLitTy s
-        mbY = isNumLitTy t
-matchFamCmpNat _ = Nothing
-
-matchFamCmpSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
-matchFamCmpSymbol [s,t]
-  | Just x <- mbX, Just y <- mbY =
-    Just (axCmpSymbolDef, [s,t], ordering (lexicalCompareFS x y))
-  | tcEqType s t = Just (axCmpSymbolRefl, [s], ordering EQ)
-  where mbX = isStrLitTy s
-        mbY = isStrLitTy t
-matchFamCmpSymbol _ = Nothing
-
-matchFamAppendSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
-matchFamAppendSymbol [s,t]
-  | Just x <- mbX, nullFS x = Just (axAppendSymbol0R, [t], t)
-  | Just y <- mbY, nullFS y = Just (axAppendSymbol0L, [s], s)
-  | Just x <- mbX, Just y <- mbY =
-    Just (axAppendSymbolDef, [s,t], mkStrLitTy (appendFS x y))
-  where
-  mbX = isStrLitTy s
-  mbY = isStrLitTy t
-matchFamAppendSymbol _ = Nothing
-
-matchFamConsSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
-matchFamConsSymbol [s,t]
-  | Just x <- mbX, Just y <- mbY =
-    Just (axConsSymbolDef, [s,t], mkStrLitTy (consFS x y))
-  where
-  mbX = isCharLitTy s
-  mbY = isStrLitTy t
-matchFamConsSymbol _ = Nothing
-
-reifyCharSymbolPairTy :: (Char, FastString) -> Type
-reifyCharSymbolPairTy (c, s) = charSymbolPair (mkCharLitTy c) (mkStrLitTy s)
-
-matchFamUnconsSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
-matchFamUnconsSymbol [s]
-  | Just x <- mbX =
-    Just (axUnconsSymbolDef, [s]
-         , mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS x)))
-  where
-  mbX = isStrLitTy s
-matchFamUnconsSymbol _ = Nothing
-
-matchFamCharToNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
-matchFamCharToNat [c]
-  | Just c' <- isCharLitTy c, n <- charToInteger c'
-  = Just (axCharToNatDef, [c], mkNumLitTy n)
-  | otherwise = Nothing
-matchFamCharToNat _ = Nothing
-
-matchFamNatToChar :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
-matchFamNatToChar [n]
-  | Just n' <- isNumLitTy n, Just c <- integerToChar n'
-  = Just (axNatToCharDef, [n], mkCharLitTy c)
-  | otherwise = Nothing
-matchFamNatToChar _ = Nothing
-
-charToInteger :: Char -> Integer
-charToInteger c = fromIntegral (Char.ord c)
-
-integerToChar :: Integer -> Maybe Char
-integerToChar n | inBounds = Just (Char.chr (fromInteger n))
-  where inBounds = n >= charToInteger minBound &&
-                   n <= charToInteger maxBound
-integerToChar _ = Nothing
-
-{-------------------------------------------------------------------------------
-Interact with axioms
--------------------------------------------------------------------------------}
-
-interactTopAdd :: [Xi] -> Xi -> [Pair Type]
-interactTopAdd [s,t] r
-  | Just 0 <- mbZ = [ s === num 0, t === num 0 ]                          -- (s + t ~ 0) => (s ~ 0, t ~ 0)
-  | Just x <- mbX, Just z <- mbZ, Just y <- minus z x = [t === num y]     -- (5 + t ~ 8) => (t ~ 3)
-  | Just y <- mbY, Just z <- mbZ, Just x <- minus z y = [s === num x]     -- (s + 5 ~ 8) => (s ~ 3)
-  where
-  mbX = isNumLitTy s
-  mbY = isNumLitTy t
-  mbZ = isNumLitTy r
-interactTopAdd _ _ = []
-
-{-
-Note [Weakened interaction rule for subtraction]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-A simpler interaction here might be:
-
-  `s - t ~ r` --> `t + r ~ s`
-
-This would enable us to reuse all the code for addition.
-Unfortunately, this works a little too well at the moment.
-Consider the following example:
-
-    0 - 5 ~ r --> 5 + r ~ 0 --> (5 = 0, r = 0)
-
-This (correctly) spots that the constraint cannot be solved.
-
-However, this may be a problem if the constraint did not
-need to be solved in the first place!  Consider the following example:
-
-f :: Proxy (If (5 <=? 0) (0 - 5) (5 - 0)) -> Proxy 5
-f = id
-
-Currently, GHC is strict while evaluating functions, so this does not
-work, because even though the `If` should evaluate to `5 - 0`, we
-also evaluate the "then" branch which generates the constraint `0 - 5 ~ r`,
-which fails.
-
-So, for the time being, we only add an improvement when the RHS is a constant,
-which happens to work OK for the moment, although clearly we need to do
-something more general.
--}
-interactTopSub :: [Xi] -> Xi -> [Pair Type]
-interactTopSub [s,t] r
-  | Just z <- mbZ = [ s === (num z .+. t) ]         -- (s - t ~ 5) => (5 + t ~ s)
-  where
-  mbZ = isNumLitTy r
-interactTopSub _ _ = []
-
-
-
-
-
-interactTopMul :: [Xi] -> Xi -> [Pair Type]
-interactTopMul [s,t] r
-  | Just 1 <- mbZ = [ s === num 1, t === num 1 ]                        -- (s * t ~ 1)  => (s ~ 1, t ~ 1)
-  | Just x <- mbX, Just z <- mbZ, Just y <- divide z x = [t === num y]  -- (3 * t ~ 15) => (t ~ 5)
-  | Just y <- mbY, Just z <- mbZ, Just x <- divide z y = [s === num x]  -- (s * 3 ~ 15) => (s ~ 5)
-  where
-  mbX = isNumLitTy s
-  mbY = isNumLitTy t
-  mbZ = isNumLitTy r
-interactTopMul _ _ = []
-
-interactTopDiv :: [Xi] -> Xi -> [Pair Type]
-interactTopDiv _ _ = []   -- I can't think of anything...
-
-interactTopMod :: [Xi] -> Xi -> [Pair Type]
-interactTopMod _ _ = []   -- I can't think of anything...
-
-interactTopExp :: [Xi] -> Xi -> [Pair Type]
-interactTopExp [s,t] r
-  | Just 0 <- mbZ = [ s === num 0 ]                                       -- (s ^ t ~ 0) => (s ~ 0)
-  | Just x <- mbX, Just z <- mbZ, Just y <- logExact  z x = [t === num y] -- (2 ^ t ~ 8) => (t ~ 3)
-  | Just y <- mbY, Just z <- mbZ, Just x <- rootExact z y = [s === num x] -- (s ^ 2 ~ 9) => (s ~ 3)
-  where
-  mbX = isNumLitTy s
-  mbY = isNumLitTy t
-  mbZ = isNumLitTy r
-interactTopExp _ _ = []
-
-interactTopLog :: [Xi] -> Xi -> [Pair Type]
-interactTopLog _ _ = []   -- I can't think of anything...
-
-
-
-interactTopCmpNat :: [Xi] -> Xi -> [Pair Type]
-interactTopCmpNat [s,t] r
-  | Just EQ <- isOrderingLitTy r = [ s === t ]
-interactTopCmpNat _ _ = []
-
-interactTopCmpSymbol :: [Xi] -> Xi -> [Pair Type]
-interactTopCmpSymbol [s,t] r
-  | Just EQ <- isOrderingLitTy r = [ s === t ]
-interactTopCmpSymbol _ _ = []
-
-interactTopAppendSymbol :: [Xi] -> Xi -> [Pair Type]
-interactTopAppendSymbol [s,t] r
-  -- (AppendSymbol a b ~ "") => (a ~ "", b ~ "")
-  | Just z <- mbZ, nullFS z =
-    [s === mkStrLitTy nilFS, t === mkStrLitTy nilFS ]
-
-  -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar")
-  | Just x <- fmap unpackFS mbX, Just z <- fmap unpackFS mbZ, x `isPrefixOf` z =
-    [ t === mkStrLitTy (mkFastString $ drop (length x) z) ]
-
-  -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo")
-  | Just y <- fmap unpackFS mbY, Just z <- fmap unpackFS mbZ, y `isSuffixOf` z =
-    [ t === mkStrLitTy (mkFastString $ take (length z - length y) z) ]
-
-  where
-  mbX = isStrLitTy s
-  mbY = isStrLitTy t
-  mbZ = isStrLitTy r
-
-interactTopAppendSymbol _ _ = []
-
-interactTopConsSymbol :: [Xi] -> Xi -> [Pair Type]
-interactTopConsSymbol [s,t] r
-  -- ConsSymbol a b ~ "blah" => (a ~ 'b', b ~ "lah")
-  | Just fs <- isStrLitTy r
-  , Just (x, xs) <- unconsFS fs =
-    [ s === mkCharLitTy x, t === mkStrLitTy xs ]
-
-interactTopConsSymbol _ _ = []
-
-interactTopUnconsSymbol :: [Xi] -> Xi -> [Pair Type]
-interactTopUnconsSymbol [s] r
-  -- (UnconsSymbol b ~ Nothing) => (b ~ "")
-  | Just Nothing <- mbX =
-    [ s === mkStrLitTy nilFS ]
-  -- (UnconsSymbol b ~ Just ('f',"oobar")) => (b ~ "foobar")
-  | Just (Just r) <- mbX
-  , Just (c, str) <- isPromotedPairType r
-  , Just chr <- isCharLitTy c
-  , Just str1 <- isStrLitTy str =
-    [ s === (mkStrLitTy $ consFS chr str1) ]
-
-  where
-  mbX = isPromotedMaybeTy r
-
-interactTopUnconsSymbol _ _ = []
-
-interactTopCharToNat :: [Xi] -> Xi -> [Pair Type]
-interactTopCharToNat [s] r
-  -- (CharToNat c ~ 122) => (c ~ 'z')
-  | Just n <- isNumLitTy r
-  , Just c <- integerToChar n
-  = [ s === mkCharLitTy c ]
-interactTopCharToNat _ _ = []
-
-interactTopNatToChar :: [Xi] -> Xi -> [Pair Type]
-interactTopNatToChar [s] r
-  -- (NatToChar n ~ 'z') => (n ~ 122)
-  | Just c <- isCharLitTy r
-  = [ s === mkNumLitTy (charToInteger c) ]
-interactTopNatToChar _ _ = []
-
-{-------------------------------------------------------------------------------
-Interaction with inerts
--------------------------------------------------------------------------------}
-
-interactInertAdd :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
-interactInertAdd [x1,y1] z1 [x2,y2] z2
-  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]
-  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]
-  where sameZ = tcEqType z1 z2
-interactInertAdd _ _ _ _ = []
-
-interactInertSub :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
-interactInertSub [x1,y1] z1 [x2,y2] z2
-  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]
-  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]
-  where sameZ = tcEqType z1 z2
-interactInertSub _ _ _ _ = []
-
-interactInertMul :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
-interactInertMul [x1,y1] z1 [x2,y2] z2
-  | sameZ && known (/= 0) x1 && tcEqType x1 x2 = [ y1 === y2 ]
-  | sameZ && known (/= 0) y1 && tcEqType y1 y2 = [ x1 === x2 ]
-  where sameZ   = tcEqType z1 z2
-
-interactInertMul _ _ _ _ = []
-
-interactInertDiv :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
-interactInertDiv _ _ _ _ = []
-
-interactInertMod :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
-interactInertMod _ _ _ _ = []
-
-interactInertExp :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
-interactInertExp [x1,y1] z1 [x2,y2] z2
-  | sameZ && known (> 1) x1 && tcEqType x1 x2 = [ y1 === y2 ]
-  | sameZ && known (> 0) y1 && tcEqType y1 y2 = [ x1 === x2 ]
-  where sameZ = tcEqType z1 z2
-
-interactInertExp _ _ _ _ = []
-
-interactInertLog :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
-interactInertLog _ _ _ _ = []
-
-
-interactInertAppendSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
-interactInertAppendSymbol [x1,y1] z1 [x2,y2] z2
-  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]
-  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]
-  where sameZ = tcEqType z1 z2
-interactInertAppendSymbol _ _ _ _ = []
-
-
-interactInertConsSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
-interactInertConsSymbol [x1, y1] z1 [x2, y2] z2
-  | sameZ         = [ x1 === x2, y1 === y2 ]
-  where sameZ = tcEqType z1 z2
-interactInertConsSymbol _ _ _ _ = []
-
-interactInertUnconsSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
-interactInertUnconsSymbol [x1] z1 [x2] z2
-  | tcEqType z1 z2 = [ x1 === x2 ]
-interactInertUnconsSymbol _ _ _ _ = []
-
-
-{- -----------------------------------------------------------------------------
-These inverse functions are used for simplifying propositions using
-concrete natural numbers.
------------------------------------------------------------------------------ -}
-
--- | Subtract two natural numbers.
-minus :: Integer -> Integer -> Maybe Integer
-minus x y = if x >= y then Just (x - y) else Nothing
-
--- | Compute the exact logarithm of a natural number.
--- The logarithm base is the second argument.
-logExact :: Integer -> Integer -> Maybe Integer
-logExact x y = do (z,True) <- genLog x y
-                  return z
-
-
--- | Divide two natural numbers.
-divide :: Integer -> Integer -> Maybe Integer
-divide _ 0  = Nothing
-divide x y  = case divMod x y of
-                (a,0) -> Just a
-                _     -> Nothing
-
--- | Compute the exact root of a natural number.
--- The second argument specifies which root we are computing.
-rootExact :: Integer -> Integer -> Maybe Integer
-rootExact x y = do (z,True) <- genRoot x y
-                   return z
-
-
-
-{- | Compute the n-th root of a natural number, rounded down to
-the closest natural number.  The boolean indicates if the result
-is exact (i.e., True means no rounding was done, False means rounded down).
-The second argument specifies which root we are computing. -}
-genRoot :: Integer -> Integer -> Maybe (Integer, Bool)
-genRoot _  0    = Nothing
-genRoot x0 1    = Just (x0, True)
-genRoot x0 root = Just (search 0 (x0+1))
-  where
-  search from to = let x = from + div (to - from) 2
-                       a = x ^ root
-                   in case compare a x0 of
-                        EQ              -> (x, True)
-                        LT | x /= from  -> search x to
-                           | otherwise  -> (from, False)
-                        GT | x /= to    -> search from x
-                           | otherwise  -> (from, False)
-
-{- | Compute the logarithm of a number in the given base, rounded down to the
-closest integer.  The boolean indicates if we the result is exact
-(i.e., True means no rounding happened, False means we rounded down).
-The logarithm base is the second argument. -}
-genLog :: Integer -> Integer -> Maybe (Integer, Bool)
-genLog x 0    = if x == 1 then Just (0, True) else Nothing
-genLog _ 1    = Nothing
-genLog 0 _    = Nothing
-genLog x base = Just (exactLoop 0 x)
-  where
-  exactLoop s i
-    | i == 1     = (s,True)
-    | i < base   = (s,False)
-    | otherwise  =
-        let s1 = s + 1
-        in s1 `seq` case divMod i base of
-                      (j,r)
-                        | r == 0    -> exactLoop s1 j
-                        | otherwise -> (underLoop s1 j, False)
-
-  underLoop s i
-    | i < base  = s
-    | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base)
-
------------------------------------------------------------------------------
-
-typeCharCmpTyCon :: TyCon
-typeCharCmpTyCon =
-  mkFamilyTyCon name
-    (mkTemplateAnonTyConBinders [ charTy, charTy ])
-    orderingKind
-    Nothing
-    (BuiltInSynFamTyCon ops)
-    Nothing
-    NotInjective
-  where
-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS_INTERNAL (fsLit "CmpChar")
-                  typeCharCmpTyFamNameKey typeCharCmpTyCon
-  ops = BuiltInSynFamily
-      { sfMatchFam      = matchFamCmpChar
-      , sfInteractTop   = interactTopCmpChar
-      , sfInteractInert = \_ _ _ _ -> []
-      }
-
-interactTopCmpChar :: [Xi] -> Xi -> [Pair Type]
-interactTopCmpChar [s,t] r
-  | Just EQ <- isOrderingLitTy r = [ s === t ]
-interactTopCmpChar _ _ = []
-
-cmpChar :: Type -> Type -> Type
-cmpChar s t = mkTyConApp typeCharCmpTyCon [s,t]
-
-axCmpCharDef, axCmpCharRefl :: CoAxiomRule
-axCmpCharDef =
-  mkBinAxiom "CmpCharDef" typeCharCmpTyCon isCharLitTy isCharLitTy $
-    \chr1 chr2 -> Just $ ordering $ compare chr1 chr2
-axCmpCharRefl = mkAxiom1 "CmpCharRefl"
-  $ \(Pair s _) -> (cmpChar s s) === ordering EQ
-
-matchFamCmpChar :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
-matchFamCmpChar [s,t]
-  | Just x <- mbX, Just y <- mbY =
-    Just (axCmpCharDef, [s,t], ordering (compare x y))
-  | tcEqType s t = Just (axCmpCharRefl, [s], ordering EQ)
-  where mbX = isCharLitTy s
-        mbY = isCharLitTy t
-matchFamCmpChar _ = Nothing
diff --git a/compiler/GHC/Builtin/Utils.hs b/compiler/GHC/Builtin/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/Builtin/Utils.hs
+++ /dev/null
@@ -1,286 +0,0 @@
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
-
-
--- | The @GHC.Builtin.Utils@ interface to the compiler's prelude knowledge.
---
--- This module serves as the central gathering point for names which the
--- compiler knows something about. This includes functions for,
---
---  * discerning whether a 'Name' is known-key
---
---  * given a 'Unique', looking up its corresponding known-key 'Name'
---
--- See Note [Known-key names] and Note [About wired-in things] for information
--- about the two types of prelude things in GHC.
---
-module GHC.Builtin.Utils (
-        -- * Known-key names
-        isKnownKeyName,
-        lookupKnownKeyName,
-        lookupKnownNameInfo,
-
-        -- ** Internal use
-        -- | 'knownKeyNames' is exported to seed the original name cache only;
-        -- if you find yourself wanting to look at it you might consider using
-        -- 'lookupKnownKeyName' or 'isKnownKeyName'.
-        knownKeyNames,
-
-        -- * Miscellaneous
-        wiredInIds, ghcPrimIds,
-
-        ghcPrimExports,
-        ghcPrimDeclDocs,
-
-        -- * Random other things
-        maybeCharLikeCon, maybeIntLikeCon,
-
-        -- * Class categories
-        isNumericClass, isStandardClass
-
-    ) where
-
-import GHC.Prelude
-
-import GHC.Builtin.Uniques
-import GHC.Builtin.PrimOps
-import GHC.Builtin.PrimOps.Ids
-import GHC.Builtin.Types
-import GHC.Builtin.Types.Literals ( typeNatTyCons )
-import GHC.Builtin.Types.Prim
-import GHC.Builtin.Names.TH ( templateHaskellNames )
-import GHC.Builtin.Names
-
-import GHC.Core.ConLike ( ConLike(..) )
-import GHC.Core.DataCon
-import GHC.Core.Class
-import GHC.Core.TyCon
-
-import GHC.Types.Avail
-import GHC.Types.Id
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.Id.Make
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Map
-import GHC.Types.TyThing
-import GHC.Types.Unique ( isValidKnownKeyUnique )
-
-import GHC.Utils.Outputable
-import GHC.Utils.Misc as Utils
-import GHC.Utils.Panic
-import GHC.Utils.Constants (debugIsOn)
-import GHC.Hs.Doc
-import GHC.Unit.Module.ModIface (IfaceExport)
-
-import GHC.Data.List.SetOps
-
-import Control.Applicative ((<|>))
-import Data.List        ( intercalate , find )
-import Data.Maybe
-
-{-
-************************************************************************
-*                                                                      *
-\subsection[builtinNameInfo]{Lookup built-in names}
-*                                                                      *
-************************************************************************
-
-Note [About wired-in things]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* Wired-in things are Ids\/TyCons that are completely known to the compiler.
-  They are global values in GHC, (e.g.  listTyCon :: TyCon).
-
-* A wired-in Name contains the thing itself inside the Name:
-        see Name.wiredInNameTyThing_maybe
-  (E.g. listTyConName contains listTyCon.
-
-* The name cache is initialised with (the names of) all wired-in things
-  (except tuples and sums; see Note [Infinite families of known-key names])
-
-* The type environment itself contains no wired in things. The type
-  checker sees if the Name is wired in before looking up the name in
-  the type environment.
-
-* GHC.Iface.Make prunes out wired-in things before putting them in an interface file.
-  So interface files never contain wired-in things.
--}
-
-
--- | This list is used to ensure that when you say "Prelude.map" in your source
--- code, or in an interface file, you get a Name with the correct known key (See
--- Note [Known-key names] in "GHC.Builtin.Names")
-knownKeyNames :: [Name]
-knownKeyNames
-  | debugIsOn
-  , Just badNamesStr <- knownKeyNamesOkay all_names
-  = panic ("badAllKnownKeyNames:\n" ++ badNamesStr)
-       -- NB: We can't use ppr here, because this is sometimes evaluated in a
-       -- context where there are no DynFlags available, leading to a cryptic
-       -- "<<details unavailable>>" error. (This seems to happen only in the
-       -- stage 2 compiler, for reasons I [Richard] have no clue of.)
-  | otherwise
-  = all_names
-  where
-    all_names =
-      concat [ concatMap wired_tycon_kk_names primTyCons
-             , concatMap wired_tycon_kk_names wiredInTyCons
-             , concatMap wired_tycon_kk_names typeNatTyCons
-             , map idName wiredInIds
-             , map idName allThePrimOpIds
-             , map (idName . primOpWrapperId) allThePrimOps
-             , basicKnownKeyNames
-             , templateHaskellNames
-             ]
-    -- All of the names associated with a wired-in TyCon.
-    -- This includes the TyCon itself, its DataCons and promoted TyCons.
-    wired_tycon_kk_names :: TyCon -> [Name]
-    wired_tycon_kk_names tc =
-        tyConName tc : (rep_names tc ++ implicits)
-      where implicits = concatMap thing_kk_names (implicitTyConThings tc)
-
-    wired_datacon_kk_names :: DataCon -> [Name]
-    wired_datacon_kk_names dc =
-      dataConName dc : rep_names (promoteDataCon dc)
-
-    thing_kk_names :: TyThing -> [Name]
-    thing_kk_names (ATyCon tc)                 = wired_tycon_kk_names tc
-    thing_kk_names (AConLike (RealDataCon dc)) = wired_datacon_kk_names dc
-    thing_kk_names thing                       = [getName thing]
-
-    -- The TyConRepName for a known-key TyCon has a known key,
-    -- but isn't itself an implicit thing.  Yurgh.
-    -- NB: if any of the wired-in TyCons had record fields, the record
-    --     field names would be in a similar situation.  Ditto class ops.
-    --     But it happens that there aren't any
-    rep_names tc = case tyConRepName_maybe tc of
-                        Just n  -> [n]
-                        Nothing -> []
-
--- | Check the known-key names list of consistency.
-knownKeyNamesOkay :: [Name] -> Maybe String
-knownKeyNamesOkay all_names
-  | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names
-  = Just $ "    Out-of-range known-key uniques: ["
-        ++ intercalate ", " (map (occNameString . nameOccName) ns) ++
-         "]"
-  | null badNamesPairs
-  = Nothing
-  | otherwise
-  = Just badNamesStr
-  where
-    namesEnv      = foldl' (\m n -> extendNameEnv_Acc (:) Utils.singleton m n n)
-                           emptyUFM all_names
-    badNamesEnv   = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv
-    badNamesPairs = nonDetUFMToList badNamesEnv
-      -- It's OK to use nonDetUFMToList here because the ordering only affects
-      -- the message when we get a panic
-    badNamesStrs  = map pairToStr badNamesPairs
-    badNamesStr   = unlines badNamesStrs
-
-    pairToStr (uniq, ns) = "        " ++
-                           show uniq ++
-                           ": [" ++
-                           intercalate ", " (map (occNameString . nameOccName) ns) ++
-                           "]"
-
--- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a
--- known-key thing.
-lookupKnownKeyName :: Unique -> Maybe Name
-lookupKnownKeyName u =
-    knownUniqueName u <|> lookupUFM_Directly knownKeysMap u
-
--- | Is a 'Name' known-key?
-isKnownKeyName :: Name -> Bool
-isKnownKeyName n =
-    isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap
-
--- | Maps 'Unique's to known-key names.
---
--- The type is @UniqFM Name Name@ to denote that the 'Unique's used
--- in the domain are 'Unique's associated with 'Name's (as opposed
--- to some other namespace of 'Unique's).
-knownKeysMap :: UniqFM Name Name
-knownKeysMap = listToIdentityUFM knownKeyNames
-
--- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by
--- GHCi's ':info' command.
-lookupKnownNameInfo :: Name -> SDoc
-lookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of
-    -- If we do find a doc, we add comment delimiters to make the output
-    -- of ':info' valid Haskell.
-    Nothing  -> empty
-    Just doc -> vcat [text "{-", doc, text "-}"]
-
--- A map from Uniques to SDocs, used in GHCi's ':info' command. (#12390)
-knownNamesInfo :: NameEnv SDoc
-knownNamesInfo = unitNameEnv coercibleTyConName $
-    vcat [ text "Coercible is a special constraint with custom solving rules."
-         , text "It is not a class."
-         , text "Please see section `The Coercible constraint`"
-         , text "of the user's guide for details." ]
-
-{-
-We let a lot of "non-standard" values be visible, so that we can make
-sense of them in interface pragmas. It's cool, though they all have
-"non-standard" names, so they won't get past the parser in user code.
--}
-
-{-
-************************************************************************
-*                                                                      *
-            Export lists for pseudo-modules (GHC.Prim)
-*                                                                      *
-************************************************************************
--}
-
-ghcPrimExports :: [IfaceExport]
-ghcPrimExports
- = map (avail . idName) ghcPrimIds ++
-   map (avail . idName) allThePrimOpIds ++
-   [ availTC n [n] []
-   | tc <- exposedPrimTyCons, let n = tyConName tc  ]
-
-ghcPrimDeclDocs :: Docs
-ghcPrimDeclDocs = emptyDocs { docs_decls = listToUniqMap $ mapMaybe findName primOpDocs }
-  where
-    names = map idName ghcPrimIds ++
-            map idName allThePrimOpIds ++
-            map tyConName exposedPrimTyCons
-    findName (nameStr, doc)
-      | Just name <- find ((nameStr ==) . getOccString) names
-      = Just (name, [WithHsDocIdentifiers (mkGeneratedHsDocString doc) []])
-      | otherwise = Nothing
-
-{-
-************************************************************************
-*                                                                      *
-            Built-in keys
-*                                                                      *
-************************************************************************
-
-ToDo: make it do the ``like'' part properly (as in 0.26 and before).
--}
-
-maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool
-maybeCharLikeCon con = con `hasKey` charDataConKey
-maybeIntLikeCon  con = con `hasKey` intDataConKey
-
-{-
-************************************************************************
-*                                                                      *
-            Class predicates
-*                                                                      *
-************************************************************************
--}
-
-isNumericClass, isStandardClass :: Class -> Bool
-
-isNumericClass     clas = classKey clas `is_elem` numericClassKeys
-isStandardClass    clas = classKey clas `is_elem` standardClassKeys
-
-is_elem :: Eq a => a -> [a] -> Bool
-is_elem = isIn "is_X_Class"
diff --git a/compiler/GHC/ByteCode/Asm.hs b/compiler/GHC/ByteCode/Asm.hs
deleted file mode 100644
--- a/compiler/GHC/ByteCode/Asm.hs
+++ /dev/null
@@ -1,650 +0,0 @@
-{-# LANGUAGE CPP             #-}
-{-# LANGUAGE DeriveFunctor   #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
---
---  (c) The University of Glasgow 2002-2006
---
-
--- | Bytecode assembler and linker
-module GHC.ByteCode.Asm (
-        assembleBCOs, assembleOneBCO,
-        bcoFreeNames,
-        SizedSeq, sizeSS, ssElts,
-        iNTERP_STACK_CHECK_THRESH,
-        mkTupleInfoLit
-  ) where
-
-import GHC.Prelude
-
-import GHC.ByteCode.Instr
-import GHC.ByteCode.InfoTable
-import GHC.ByteCode.Types
-import GHCi.RemoteTypes
-import GHC.Runtime.Interpreter
-import GHC.Runtime.Heap.Layout hiding ( WordOff )
-
-import GHC.Types.Name
-import GHC.Types.Name.Set
-import GHC.Types.Literal
-import GHC.Types.Unique
-import GHC.Types.Unique.DSet
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-import GHC.Core.TyCon
-import GHC.Data.FastString
-import GHC.Data.SizedSeq
-
-import GHC.StgToCmm.Layout     ( ArgRep(..) )
-import GHC.Cmm.Expr
-import GHC.Cmm.CallConv        ( tupleRegsCover )
-import GHC.Platform
-import GHC.Platform.Profile
-
-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 hiding (shiftL, shiftR)
-import Data.Char        ( ord )
-import Data.List        ( genericLength )
-import Data.Map.Strict (Map)
-import Data.Maybe (fromMaybe)
-import qualified Data.Map.Strict 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
-  :: Interp
-  -> Profile
-  -> [ProtoBCO Name]
-  -> [TyCon]
-  -> [RemotePtr ()]
-  -> Maybe ModBreaks
-  -> IO CompiledByteCode
-assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
-  -- TODO: the profile should be bundled with the interpreter: the rts ways are
-  -- fixed for an interpreter
-  itblenv <- mkITbls interp profile tycons
-  bcos    <- mapM (assembleBCO (profilePlatform profile)) proto_bcos
-  (bcos',ptrs) <- mallocStrings interp bcos
-  return CompiledByteCode
-    { bc_bcos = bcos'
-    , bc_itbls =  itblenv
-    , bc_ffis = concatMap 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 :: Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
-mallocStrings interp ulbcos = do
-  let bytestrings = reverse (execState (mapM_ collect ulbcos) [])
-  ptrs <- interpCmd interp (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 :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO
-assembleOneBCO interp profile pbco = do
-  -- TODO: the profile should be bundled with the interpreter: the rts ways are
-  -- fixed for an interpreter
-  ubco <- assembleBCO (profilePlatform profile) pbco
-  ([ubco'], _ptrs) <- mallocStrings interp [ubco]
-  return ubco'
-
-assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
-assembleBCO platform (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 platform) 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 platform False initial_offset asm
-      ((n_insns, lbl_map), long_jumps)
-        | isLarge (fromIntegral $ Map.size lbl_map0)
-          || isLarge n_insns0
-                    = (inspectAsm platform True initial_offset asm, True)
-        | otherwise = ((n_insns0, lbl_map0), False)
-
-      env :: LocalLabel -> 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 platform long_jumps env asm
-
-  -- precomputed size should be equal to final size
-  massert (n_insns == sizeSS final_insns)
-
-  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 LocalLabel
--- (unused)  | LargeOp Word
-
-data Assembler a
-  = AllocPtr (IO BCOPtr) (Word -> Assembler a)
-  | AllocLit [BCONPtr] (Word -> Assembler a)
-  | AllocLabel LocalLabel (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 :: LocalLabel -> Assembler ()
-label w = AllocLabel w (return ())
-
-emit :: Word16 -> [Operand] -> Assembler ()
-emit w ops = Emit w ops (return ())
-
-type LabelEnv = LocalLabel -> Word
-
-largeOp :: Bool -> Operand -> Bool
-largeOp long_jumps op = case op of
-   SmallOp _ -> False
-   Op w      -> isLarge w
-   LabelOp _ -> long_jumps
--- LargeOp _ -> True
-
-runAsm :: Platform -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
-runAsm platform 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 platform (fromIntegral w) else [fromIntegral w]
---        expand (LargeOp w) = largeArg platform 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 LocalLabel Word
-
-data InspectState = InspectState
-  { instrCount :: !Word
-  , ptrCount :: !Word
-  , litCount :: !Word
-  , lblEnv :: LabelEnvMap
-  }
-
-inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
-inspectAsm platform 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 platform else 1
---      count (LargeOp _) = largeArg16s platform
-
--- Bring in all the bci_ bytecode constants.
-#include "Bytecodes.h"
-
-largeArgInstr :: Word16 -> Word16
-largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
-
-largeArg :: Platform -> Word64 -> [Word16]
-largeArg platform w = case platformWordSize platform of
-   PW8 -> [fromIntegral (w `shiftR` 48),
-           fromIntegral (w `shiftR` 32),
-           fromIntegral (w `shiftR` 16),
-           fromIntegral w]
-   PW4 -> assert (w < fromIntegral (maxBound :: Word32)) $
-          [fromIntegral (w `shiftR` 16),
-           fromIntegral w]
-
-largeArg16s :: Platform -> Word
-largeArg16s platform = case platformWordSize platform of
-   PW8 -> 4
-   PW4 -> 2
-
-assembleI :: Platform
-          -> BCInstr
-          -> Assembler ()
-assembleI platform 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 platform proto
-                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
-                                 emit bci_PUSH_G [Op p]
-  PUSH_ALTS proto          -> do let ul_bco = assembleBCO platform proto
-                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
-                                 emit bci_PUSH_ALTS [Op p]
-  PUSH_ALTS_UNLIFTED proto pk
-                           -> do let ul_bco = assembleBCO platform proto
-                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
-                                 emit (push_alts pk) [Op p]
-  PUSH_ALTS_TUPLE proto tuple_info tuple_proto
-                           -> do let ul_bco = assembleBCO platform proto
-                                     ul_tuple_bco = assembleBCO platform
-                                                                tuple_proto
-                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
-                                 p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)
-                                 info <- int (fromIntegral $
-                                              mkTupleInfoSig platform tuple_info)
-                                 emit bci_PUSH_ALTS_T
-                                      [Op p, Op info, Op p_tup]
-  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_UNLIFTED rep      -> emit (return_unlifted rep) []
-  RETURN_TUPLE             -> emit bci_RETURN_T []
-  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 platform == 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)
-      LitNumInt8    -> int8 (fromIntegral i)
-      LitNumWord8   -> int8 (fromIntegral i)
-      LitNumInt16   -> int16 (fromIntegral i)
-      LitNumWord16  -> int16 (fromIntegral i)
-      LitNumInt32   -> int32 (fromIntegral i)
-      LitNumWord32  -> int32 (fromIntegral i)
-      LitNumInt64   -> int64 (fromIntegral i)
-      LitNumWord64  -> int64 (fromIntegral i)
-      LitNumBigNat  -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat"
-
-    -- 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 platform
-    double = words . mkLitD platform
-    int = words . mkLitI
-    int8 = words . mkLitI64 platform
-    int16 = words . mkLitI64 platform
-    int32 = words . mkLitI64 platform
-    int64 = words . mkLitI64 platform
-    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_unlifted :: ArgRep -> Word16
-return_unlifted V   = bci_RETURN_V
-return_unlifted P   = bci_RETURN_P
-return_unlifted N   = bci_RETURN_N
-return_unlifted L   = bci_RETURN_L
-return_unlifted F   = bci_RETURN_F
-return_unlifted D   = bci_RETURN_D
-return_unlifted V16 = error "return_unlifted: vector"
-return_unlifted V32 = error "return_unlifted: vector"
-return_unlifted V64 = error "return_unlifted: vector"
-
-{-
-  we can only handle up to a fixed number of words on the stack,
-  because we need a stg_ctoi_tN stack frame for each size N. See
-  Note [unboxed tuple bytecodes and tuple_BCO].
-
-  If needed, you can support larger tuples by adding more in
-  StgMiscClosures.cmm, Interpreter.c and MiscClosures.h and
-  raising this limit.
-
-  Note that the limit is the number of words passed on the stack.
-  If the calling convention passes part of the tuple in registers, the
-  maximum number of tuple elements may be larger. Elements can also
-  take multiple words on the stack (for example Double# on a 32 bit
-  platform).
-
- -}
-maxTupleNativeStackSize :: WordOff
-maxTupleNativeStackSize = 62
-
-{-
-  Construct the tuple_info word that stg_ctoi_t and stg_ret_t use
-  to convert a tuple between the native calling convention and the
-  interpreter.
-
-  See Note [GHCi tuple layout] for more information.
- -}
-mkTupleInfoSig :: Platform -> TupleInfo -> Word32
-mkTupleInfoSig platform TupleInfo{..}
-  | tupleNativeStackSize > maxTupleNativeStackSize
-  = pprPanic "mkTupleInfoSig: tuple too big for the bytecode compiler"
-             (ppr tupleNativeStackSize <+> text "stack words." <+>
-              text "Use -fobject-code to get around this limit"
-             )
-  | otherwise
-  = assert (length regs <= 24) {- 24 bits for bitmap -}
-    assert (tupleNativeStackSize < 255) {- 8 bits for stack size -}
-    assert (all (`elem` regs) (regSetToList tupleRegs)) {- all regs accounted for -}
-    foldl' reg_bit 0 (zip regs [0..]) .|.
-      (fromIntegral tupleNativeStackSize `shiftL` 24)
-  where
-    reg_bit :: Word32 -> (GlobalReg, Int) -> Word32
-    reg_bit x (r, n)
-      | r `elemRegSet` tupleRegs = x .|. 1 `shiftL` n
-      | otherwise                = x
-    regs = tupleRegsCover platform
-
-mkTupleInfoLit :: Platform -> TupleInfo -> Literal
-mkTupleInfoLit platform tuple_info =
-  mkLitWord platform . fromIntegral $ mkTupleInfoSig platform tuple_info
-
--- 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   :: Platform -> Float  -> [Word]
-mkLitD   :: Platform -> Double -> [Word]
-mkLitI64 :: Platform -> Int64  -> [Word]
-
-mkLitF platform f = case platformWordSize platform of
-  PW4 -> runST $ do
-        arr <- newArray_ ((0::Int),0)
-        writeArray arr 0 f
-        f_arr <- castSTUArray arr
-        w0 <- readArray f_arr 0
-        return [w0 :: Word]
-
-  PW8 -> runST $ do
-        arr <- newArray_ ((0::Int),1)
-        writeArray arr 0 f
-        -- on 64-bit architectures we read two (32-bit) Float cells when we read
-        -- a (64-bit) Word: so we write a dummy value in the second cell to
-        -- avoid an out-of-bound read.
-        writeArray arr 1 0.0
-        f_arr <- castSTUArray arr
-        w0 <- readArray f_arr 0
-        return [w0 :: Word]
-
-mkLitD platform d = case platformWordSize platform of
-   PW4 -> 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]
-     )
-   PW8 -> runST (do
-        arr <- newArray_ ((0::Int),0)
-        writeArray arr 0 d
-        d_arr <- castSTUArray arr
-        w0 <- readArray d_arr 0
-        return [w0 :: Word]
-     )
-
-mkLitI64 platform ii = case platformWordSize platform of
-   PW4 -> 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]
-     )
-   PW8 -> runST (do
-        arr <- newArray_ ((0::Int),0)
-        writeArray arr 0 ii
-        d_arr <- castSTUArray arr
-        w0 <- readArray d_arr 0
-        return [w0 :: Word]
-     )
-
-mkLitI i = [fromIntegral i :: Word]
-
-iNTERP_STACK_CHECK_THRESH :: Int
-iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH
diff --git a/compiler/GHC/ByteCode/InfoTable.hs b/compiler/GHC/ByteCode/InfoTable.hs
deleted file mode 100644
--- a/compiler/GHC/ByteCode/InfoTable.hs
+++ /dev/null
@@ -1,85 +0,0 @@
-
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
---
---  (c) The University of Glasgow 2002-2006
---
-
--- | Generate infotables for interpreter-made bytecodes
-module GHC.ByteCode.InfoTable ( mkITbls ) where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Platform.Profile
-
-import GHC.ByteCode.Types
-import GHC.Runtime.Interpreter
-
-import GHC.Types.Name       ( Name, getName )
-import GHC.Types.Name.Env
-import GHC.Types.RepType
-
-import GHC.Core.DataCon     ( DataCon, dataConRepArgTys, dataConIdentity )
-import GHC.Core.TyCon       ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
-import GHC.Core.Multiplicity     ( scaledThing )
-
-import GHC.StgToCmm.Layout  ( mkVirtConstrSizes )
-import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) )
-
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-
-{-
-  Manufacturing of info tables for DataCons
--}
-
--- Make info tables for the data decls in this module
-mkITbls :: Interp -> Profile -> [TyCon] -> IO ItblEnv
-mkITbls interp profile tcs =
-  foldr plusNameEnv emptyNameEnv <$>
-    mapM mkITbl (filter isDataTyCon tcs)
- where
-  mkITbl :: TyCon -> IO ItblEnv
-  mkITbl tc
-    | dcs `lengthIs` n -- paranoia; this is an assertion.
-    = make_constr_itbls interp profile 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 :: Interp -> Profile -> [DataCon] -> IO ItblEnv
-make_constr_itbls interp profile cons =
-  -- TODO: the profile should be bundled with the interpreter: the rts ways are
-  -- fixed for an interpreter
-  mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])
- where
-  mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)
-  mk_itbl dcon conNo = do
-     let rep_args = [ NonVoid prim_rep
-                    | arg <- dataConRepArgTys dcon
-                    , prim_rep <- typePrimRep (scaledThing arg) ]
-
-         (tot_wds, ptr_wds) =
-             mkVirtConstrSizes profile rep_args
-
-         ptrs'  = ptr_wds
-         nptrs' = tot_wds - ptr_wds
-         nptrs_really
-            | ptrs' + nptrs' >= pc_MIN_PAYLOAD_SIZE constants = nptrs'
-            | otherwise = pc_MIN_PAYLOAD_SIZE constants - ptrs'
-
-         descr = dataConIdentity dcon
-
-         platform = profilePlatform profile
-         constants = platformConstants platform
-         tables_next_to_code = platformTablesNextToCode platform
-
-     r <- interpCmd interp (MkConInfoTable tables_next_to_code ptrs' nptrs_really
-                              conNo (tagForCon platform dcon) descr)
-     return (getName dcon, ItblPtr r)
diff --git a/compiler/GHC/ByteCode/Instr.hs b/compiler/GHC/ByteCode/Instr.hs
deleted file mode 100644
--- a/compiler/GHC/ByteCode/Instr.hs
+++ /dev/null
@@ -1,404 +0,0 @@
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# OPTIONS_GHC -funbox-strict-fields #-}
---
---  (c) The University of Glasgow 2002-2006
---
-
--- | Bytecode instruction definitions
-module GHC.ByteCode.Instr (
-        BCInstr(..), ProtoBCO(..), bciStackUse, LocalLabel(..)
-  ) where
-
-import GHC.Prelude
-
-import GHC.ByteCode.Types
-import GHCi.RemoteTypes
-import GHCi.FFI (C_ffi_cif)
-import GHC.StgToCmm.Layout     ( ArgRep(..) )
-import GHC.Utils.Outputable
-import GHC.Types.Name
-import GHC.Types.Unique
-import GHC.Types.Literal
-import GHC.Core.DataCon
-import GHC.Builtin.PrimOps
-import GHC.Runtime.Heap.Layout
-
-import Data.Word
-import GHC.Stack.CCS (CostCentre)
-
-import GHC.Stg.Syntax
-
--- ----------------------------------------------------------------------------
--- 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 [CgStgAlt] CgStgRhs,
-        -- malloc'd pointers
-        protoBCOFFIs       :: [FFIInfo]
-   }
-
--- | A local block label (e.g. identifying a case alternative).
-newtype LocalLabel = LocalLabel { getLocalLabel :: Word32 }
-  deriving (Eq, Ord)
-
-instance Outputable LocalLabel where
-  ppr (LocalLabel lbl) = text "lbl:" <> ppr lbl
-
-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 specified 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 constructing 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
-   | PUSH_ALTS_TUPLE    (ProtoBCO Name) -- continuation
-                        !TupleInfo
-                        (ProtoBCO Name) -- tuple return BCO
-
-   -- 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_UNLIFTED ArgRep -- return an unlifted value, here's its rep
-   | RETURN_TUPLE           -- return an unboxed tuple (info already on stack)
-
-   -- 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 (pprStgAltShort shortStgPprOpts) alts))
-                      Right rhs ->
-                        pprStgRhsShort shortStgPprOpts rhs
-                  )
-        $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap)
-        $$ nest 3 (vcat (map ppr instrs))
-
--- Print enough of the STG expression to enable the reader to find
--- the expression in the -ddump-stg output.  That is, we need to
--- include at least a binder.
-
-pprStgExprShort :: OutputablePass pass => StgPprOpts -> GenStgExpr pass -> SDoc
-pprStgExprShort _ (StgCase _expr var _ty _alts) =
-  text "case of" <+> ppr var
-pprStgExprShort _ (StgLet _ bnd _) =
-  text "let" <+> pprStgBindShort bnd <+> text "in ..."
-pprStgExprShort _ (StgLetNoEscape _ bnd _) =
-  text "let-no-escape" <+> pprStgBindShort bnd <+> text "in ..."
-pprStgExprShort opts (StgTick t e) = ppr t <+> pprStgExprShort opts e
-pprStgExprShort opts e = pprStgExpr opts e
-
-pprStgBindShort :: OutputablePass pass => GenStgBinding pass -> SDoc
-pprStgBindShort (StgNonRec x _) =
-  ppr x <+> text "= ..."
-pprStgBindShort (StgRec bs) =
-  char '{' <+> ppr (fst (head bs)) <+> text "= ...; ... }"
-
-pprStgAltShort :: OutputablePass pass => StgPprOpts -> GenStgAlt pass -> SDoc
-pprStgAltShort opts GenStgAlt{alt_con=con, alt_bndrs=args, alt_rhs=expr} =
-  ppr con <+> sep (map ppr args) <+> text "->" <+> pprStgExprShort opts expr
-
-pprStgRhsShort :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc
-pprStgRhsShort opts (StgRhsClosure _ext _cc upd_flag args body) =
-  hang (hsep [ char '\\' <> ppr upd_flag, brackets (interppSP args) ])
-       4 (pprStgExprShort opts body)
-pprStgRhsShort opts rhs = pprStgRhs opts rhs
-
-
-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_ALTS_TUPLE bco tuple_info tuple_bco) =
-                               hang (text "PUSH_ALTS_TUPLE" <+> ppr tuple_info)
-                                    2
-                                    (ppr tuple_bco $+$ 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 marshal_addr flags) = text "CCALL   " <+> ppr off
-                                                <+> text "marshal code at"
-                                               <+> text (show marshal_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_UNLIFTED pk)  = text "RETURN_UNLIFTED  " <+> ppr pk
-   ppr (RETURN_TUPLE)        = text "RETURN_TUPLE"
-   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 {- profiling only, restore CCCS -} +
-                                    3 + protoBCOStackUse bco
-bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 {- profiling only, restore CCCS -} +
-                                         4 + protoBCOStackUse bco
-bciStackUse (PUSH_ALTS_TUPLE bco info _) =
-   -- (tuple_bco, tuple_info word, cont_bco, stg_ctoi_t)
-   -- tuple
-   -- (tuple_info, tuple_bco, stg_ret_t)
-   1 {- profiling only -} +
-   7 + fromIntegral (tupleSize info) + 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_UNLIFTED{}     = 1 -- pushes stg_ret_X for some X
-bciStackUse RETURN_TUPLE{}        = 1 -- pushes stg_ret_t header
-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/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs
deleted file mode 100644
--- a/compiler/GHC/ByteCode/Linker.hs
+++ /dev/null
@@ -1,212 +0,0 @@
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE MagicHash             #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
---
---  (c) The University of Glasgow 2002-2006
---
-
--- | Bytecode assembler and linker
-module GHC.ByteCode.Linker
-  ( ClosureEnv
-  , emptyClosureEnv
-  , extendClosureEnv
-  , linkBCO
-  , lookupStaticPtr
-  , lookupIE
-  , nameToCLabel
-  , linkFail
-  )
-where
-
-import GHC.Prelude
-
-import GHC.Runtime.Interpreter
-import GHC.ByteCode.Types
-import GHCi.RemoteTypes
-import GHCi.ResolvedBCO
-import GHCi.BreakArray
-
-import GHC.Builtin.PrimOps
-import GHC.Builtin.Names
-
-import GHC.Unit.Types
-
-import GHC.Data.FastString
-import GHC.Data.SizedSeq
-
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Outputable
-
-import GHC.Types.Name
-import GHC.Types.Name.Env
-
-import Language.Haskell.Syntax.Module.Name
-
--- 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
-  :: Interp
-  -> ItblEnv
-  -> ClosureEnv
-  -> NameEnv Int
-  -> RemoteRef BreakArray
-  -> UnlinkedBCO
-  -> IO ResolvedBCO
-linkBCO interp 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 interp ie) (ssElts lits0)
-  ptrs <- mapM (resolvePtr interp ie ce bco_ix breakarray) (ssElts ptrs0)
-  return (ResolvedBCO isLittleEndian arity insns bitmap
-              (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
-              (addListToSS emptySS ptrs))
-
-lookupLiteral :: Interp -> ItblEnv -> BCONPtr -> IO Word
-lookupLiteral interp ie ptr = case ptr of
-  BCONPtrWord lit -> return lit
-  BCONPtrLbl  sym -> do
-    Ptr a# <- lookupStaticPtr interp sym
-    return (W# (int2Word# (addr2Int# a#)))
-  BCONPtrItbl nm -> do
-    Ptr a# <- lookupIE interp ie nm
-    return (W# (int2Word# (addr2Int# a#)))
-  BCONPtrStr _ ->
-    -- should be eliminated during assembleBCOs
-    panic "lookupLiteral: BCONPtrStr"
-
-lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())
-lookupStaticPtr interp addr_of_label_string = do
-  m <- lookupSymbol interp addr_of_label_string
-  case m of
-    Just ptr -> return ptr
-    Nothing  -> linkFail "GHC.ByteCode.Linker: can't find label"
-                  (unpackFS addr_of_label_string)
-
-lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())
-lookupIE interp 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 interp 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 interp sym_to_find2
-                   case n of
-                      Just addr -> return addr
-                      Nothing   -> linkFail "GHC.ByteCode.Linker.lookupIE"
-                                      (unpackFS sym_to_find1 ++ " or " ++
-                                       unpackFS sym_to_find2)
-
-lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())
-lookupPrimOp interp primop = do
-  let sym_to_find = primopToCLabel primop "closure"
-  m <- lookupSymbol interp (mkFastString sym_to_find)
-  case m of
-    Just p -> return (toRemotePtr p)
-    Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find
-
-resolvePtr
-  :: Interp
-  -> ItblEnv
-  -> ClosureEnv
-  -> NameEnv Int
-  -> RemoteRef BreakArray
-  -> BCOPtr
-  -> IO ResolvedBCOPtr
-resolvePtr interp ie ce bco_ix breakarray ptr = case ptr of
-  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
-    -> assertPpr (isExternalName nm) (ppr nm) $
-       do
-          let sym_to_find = nameToCLabel nm "closure"
-          m <- lookupSymbol interp sym_to_find
-          case m of
-            Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
-            Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)
-
-  BCOPtrPrimOp op
-    -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op
-
-  BCOPtrBCO bco
-    -> ResolvedBCOPtrBCO <$> linkBCO interp ie ce bco_ix breakarray bco
-
-  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) $ case nameModule n of
-        -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers
-        -- See Note [Primop wrappers] in GHC.Builtin.PrimOps.
-        mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS
-        mod -> mod
-    packagePart = encodeZ (unitFS pkgKey)
-    modulePart  = encodeZ (moduleNameFS modName)
-    occPart     = encodeZ (occNameFS (nameOccName n))
-
-    label = concat
-        [ if pkgKey == mainUnit then "" else packagePart ++ "_"
-        , modulePart
-        , '_':occPart
-        , '_':suffix
-        ]
-
-
--- See Note [Primop wrappers] in GHC.Builtin.PrimOps
-primopToCLabel :: PrimOp -> String -> String
-primopToCLabel primop suffix = concat
-    [ "ghczmprim_GHCziPrimopWrappers_"
-    , zString (zEncodeFS (occNameFS (primOpOcc primop)))
-    , '_':suffix
-    ]
diff --git a/compiler/GHC/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/CallConv.hs
+++ /dev/null
@@ -1,231 +0,0 @@
-module GHC.Cmm.CallConv (
-  ParamLocation(..),
-  assignArgumentsPos,
-  assignStack,
-  realArgRegsCover,
-  tupleRegsCover
-) where
-
-import GHC.Prelude
-import Data.List (nub)
-
-import GHC.Cmm.Expr
-import GHC.Runtime.Heap.Layout
-import GHC.Cmm (Convention(..))
-
-import GHC.Platform
-import GHC.Platform.Profile
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
--- Calculate the 'GlobalReg' or stack locations for function call
--- parameters as used by the Cmm calling convention.
-
-data ParamLocation
-  = RegisterParam GlobalReg
-  | StackParam ByteOff
-
-instance Outputable ParamLocation where
-  ppr (RegisterParam g) = ppr g
-  ppr (StackParam p)    = ppr p
-
--- |
--- Given a list of arguments, and a function that tells their types,
--- return a list showing where each argument is passed
---
-assignArgumentsPos :: Profile
-                   -> ByteOff           -- stack offset to start with
-                   -> Convention
-                   -> (a -> CmmType)    -- how to get a type from an arg
-                   -> [a]               -- args
-                   -> (
-                        ByteOff              -- bytes of stack args
-                      , [(a, ParamLocation)] -- args and locations
-                      )
-
-assignArgumentsPos profile off conv arg_ty reps = (stk_off, assignments)
-    where
-      platform = profilePlatform profile
-      regs = case (reps, conv) of
-               (_,   NativeNodeCall)   -> getRegsWithNode platform
-               (_,   NativeDirectCall) -> getRegsWithoutNode platform
-               ([_], NativeReturn)     -> allRegs platform
-               (_,   NativeReturn)     -> getRegsWithNode platform
-               -- GC calling convention *must* put values in registers
-               (_,   GC)               -> allRegs platform
-               (_,   Slow)             -> nodeOnly
-      -- The calling conventions first assign arguments to registers,
-      -- then switch to the stack when we first run out of registers
-      -- (even if there are still available registers for args of a
-      -- different type).  When returning an unboxed tuple, we also
-      -- separate the stack arguments by pointerhood.
-      (reg_assts, stk_args)  = assign_regs [] reps regs
-      (stk_off,   stk_assts) = assignStack platform off arg_ty stk_args
-      assignments = reg_assts ++ stk_assts
-
-      assign_regs assts []     _    = (assts, [])
-      assign_regs assts (r:rs) regs | isVecType ty   = vec
-                                    | isFloatType ty = float
-                                    | otherwise      = int
-        where vec = case (w, regs) of
-                      (W128, (vs, fs, ds, ls, s:ss))
-                          | passVectorInReg W128 profile -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))
-                      (W256, (vs, fs, ds, ls, s:ss))
-                          | passVectorInReg W256 profile -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))
-                      (W512, (vs, fs, ds, ls, s:ss))
-                          | passVectorInReg W512 profile -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))
-                      _ -> (assts, (r:rs))
-              float = case (w, regs) of
-                        (W32, (vs, fs, ds, ls, s:ss))
-                            | passFloatInXmm          -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss))
-                        (W32, (vs, f:fs, ds, ls, ss))
-                            | not passFloatInXmm      -> k (RegisterParam f, (vs, fs, ds, ls, ss))
-                        (W64, (vs, fs, ds, ls, s:ss))
-                            | passFloatInXmm          -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))
-                        (W64, (vs, fs, d:ds, ls, ss))
-                            | not passFloatInXmm      -> k (RegisterParam d, (vs, fs, ds, ls, ss))
-                        _ -> (assts, (r:rs))
-              int = case (w, regs) of
-                      (W128, _) -> panic "W128 unsupported register type"
-                      (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth platform)
-                          -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss))
-                      (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth platform)
-                          -> k (RegisterParam l, (vs, fs, ds, ls, ss))
-                      _   -> (assts, (r:rs))
-              k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
-              ty = arg_ty r
-              w  = typeWidth ty
-              !gcp | isGcPtrType ty = VGcPtr
-                   | otherwise      = VNonGcPtr
-              passFloatInXmm = passFloatArgsInXmm platform
-
-passFloatArgsInXmm :: Platform -> Bool
-passFloatArgsInXmm platform = case platformArch platform of
-                              ArchX86_64 -> True
-                              ArchX86    -> False
-                              _          -> False
-
--- We used to spill vector registers to the stack since the LLVM backend didn't
--- support vector registers in its calling convention. However, this has now
--- been fixed. This function remains only as a convenient way to re-enable
--- spilling when debugging code generation.
-passVectorInReg :: Width -> Profile -> Bool
-passVectorInReg _ _ = True
-
-assignStack :: Platform -> ByteOff -> (a -> CmmType) -> [a]
-            -> (
-                 ByteOff              -- bytes of stack args
-               , [(a, ParamLocation)] -- args and locations
-               )
-assignStack platform offset arg_ty args = assign_stk offset [] (reverse args)
- where
-      assign_stk offset assts [] = (offset, assts)
-      assign_stk offset assts (r:rs)
-        = assign_stk off' ((r, StackParam off') : assts) rs
-        where w    = typeWidth (arg_ty r)
-              off' = offset + size
-              -- Stack arguments always take a whole number of words, we never
-              -- pack them unlike constructor fields.
-              size = roundUpToWords platform (widthInBytes w)
-
------------------------------------------------------------------------------
--- Local information about the registers available
-
-type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.
-                 , [GlobalReg]   -- floats
-                 , [GlobalReg]   -- doubles
-                 , [GlobalReg]   -- longs (int64 and word64)
-                 , [Int]         -- XMM (floats and doubles)
-                 )
-
--- Vanilla registers can contain pointers, Ints, Chars.
--- Floats and doubles have separate register supplies.
---
--- We take these register supplies from the *real* registers, i.e. those
--- that are guaranteed to map to machine registers.
-
-getRegsWithoutNode, getRegsWithNode :: Platform -> AvailRegs
-getRegsWithoutNode platform =
-  ( filter (\r -> r VGcPtr /= node) (realVanillaRegs platform)
-  , realFloatRegs platform
-  , realDoubleRegs platform
-  , realLongRegs platform
-  , realXmmRegNos platform)
-
--- getRegsWithNode uses R1/node even if it isn't a register
-getRegsWithNode platform =
-  ( if null (realVanillaRegs platform)
-    then [VanillaReg 1]
-    else realVanillaRegs platform
-  , realFloatRegs platform
-  , realDoubleRegs platform
-  , realLongRegs platform
-  , realXmmRegNos platform)
-
-allFloatRegs, allDoubleRegs, allLongRegs :: Platform -> [GlobalReg]
-allVanillaRegs :: Platform -> [VGcPtr -> GlobalReg]
-allXmmRegs :: Platform -> [Int]
-
-allVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Vanilla_REG (platformConstants platform))
-allFloatRegs   platform = map FloatReg   $ regList (pc_MAX_Float_REG   (platformConstants platform))
-allDoubleRegs  platform = map DoubleReg  $ regList (pc_MAX_Double_REG  (platformConstants platform))
-allLongRegs    platform = map LongReg    $ regList (pc_MAX_Long_REG    (platformConstants platform))
-allXmmRegs     platform =                  regList (pc_MAX_XMM_REG     (platformConstants platform))
-
-realFloatRegs, realDoubleRegs, realLongRegs :: Platform -> [GlobalReg]
-realVanillaRegs :: Platform -> [VGcPtr -> GlobalReg]
-
-realVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Real_Vanilla_REG (platformConstants platform))
-realFloatRegs   platform = map FloatReg   $ regList (pc_MAX_Real_Float_REG   (platformConstants platform))
-realDoubleRegs  platform = map DoubleReg  $ regList (pc_MAX_Real_Double_REG  (platformConstants platform))
-realLongRegs    platform = map LongReg    $ regList (pc_MAX_Real_Long_REG    (platformConstants platform))
-
-realXmmRegNos :: Platform -> [Int]
-realXmmRegNos platform
-    | isSse2Enabled platform = regList (pc_MAX_Real_XMM_REG (platformConstants platform))
-    | otherwise              = []
-
-regList :: Int -> [Int]
-regList n = [1 .. n]
-
-allRegs :: Platform -> AvailRegs
-allRegs platform = ( allVanillaRegs platform
-                   , allFloatRegs   platform
-                   , allDoubleRegs  platform
-                   , allLongRegs    platform
-                   , allXmmRegs     platform
-                   )
-
-nodeOnly :: AvailRegs
-nodeOnly = ([VanillaReg 1], [], [], [], [])
-
--- This returns the set of global registers that *cover* the machine registers
--- used for argument passing. On platforms where registers can overlap---right
--- now just x86-64, where Float and Double registers overlap---passing this set
--- of registers is guaranteed to preserve the contents of all live registers. We
--- only use this functionality in hand-written C-- code in the RTS.
-realArgRegsCover :: Platform -> [GlobalReg]
-realArgRegsCover platform
-    | passFloatArgsInXmm platform
-    = map ($ VGcPtr) (realVanillaRegs platform) ++
-      realLongRegs platform ++
-      realDoubleRegs platform -- we only need to save the low Double part of XMM registers.
-                              -- Moreover, the NCG can't load/store full XMM
-                              -- registers for now...
-
-    | otherwise
-    = map ($ VGcPtr) (realVanillaRegs platform) ++
-      realFloatRegs  platform ++
-      realDoubleRegs platform ++
-      realLongRegs   platform
-      -- we don't save XMM registers if they are not used for parameter passing
-
--- Like realArgRegsCover but always includes the node. This covers the real
--- and virtual registers used for unboxed tuples.
---
--- Note: if anything changes in how registers for unboxed tuples overlap,
---       make sure to also update GHC.StgToByteCode.layoutTuple.
-
-tupleRegsCover :: Platform -> [GlobalReg]
-tupleRegsCover platform =
-  nub (VanillaReg 1 VGcPtr : realArgRegsCover platform)
diff --git a/compiler/GHC/Cmm/CommonBlockElim.hs b/compiler/GHC/Cmm/CommonBlockElim.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/CommonBlockElim.hs
+++ /dev/null
@@ -1,308 +0,0 @@
-{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}
-
-module GHC.Cmm.CommonBlockElim
-  ( elimCommonBlocks
-  )
-where
-
-
-import GHC.Prelude hiding (iterate, succ, unzip, zip)
-
-import GHC.Cmm.BlockId
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Cmm.Switch (eqSwitchTargetWith)
-import GHC.Cmm.ContFlowOpt
-
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.Dataflow.Collections
-import Data.Functor.Classes (liftEq)
-import Data.Maybe (mapMaybe)
-import qualified Data.List as List
-import Data.Word
-import qualified Data.Map as M
-import qualified GHC.Data.TrieMap as TM
-import GHC.Types.Unique.FM
-import GHC.Types.Unique
-import Control.Arrow (first, second)
-import Data.List.NonEmpty (NonEmpty (..))
-import qualified Data.List.NonEmpty as NE
-
--- -----------------------------------------------------------------------------
--- Eliminate common blocks
-
--- If two blocks are identical except for the label on the first node,
--- then we can eliminate one of the blocks. To ensure that the semantics
--- of the program are preserved, we have to rewrite each predecessor of the
--- eliminated block to proceed with the block we keep.
-
--- The algorithm iterates over the blocks in the graph,
--- checking whether it has seen another block that is equal modulo labels.
--- If so, then it adds an entry in a map indicating that the new block
--- is made redundant by the old block.
--- Otherwise, it is added to the useful blocks.
-
--- To avoid comparing every block with every other block repeatedly, we group
--- them by
---   * a hash of the block, ignoring labels (explained below)
---   * the list of outgoing labels
--- The hash is invariant under relabeling, so we only ever compare within
--- the same group of blocks.
---
--- The list of outgoing labels is updated as we merge blocks (that is why they
--- are not included in the hash, which we want to calculate only once).
---
--- All in all, two blocks should never be compared if they have different
--- hashes, and at most once otherwise. Previously, we were slower, and people
--- rightfully complained: #10397
-
--- TODO: Use optimization fuel
-elimCommonBlocks :: CmmGraph -> CmmGraph
-elimCommonBlocks g = replaceLabels env $ copyTicks env g
-  where
-     env = iterate mapEmpty blocks_with_key
-     -- The order of blocks doesn't matter here. While we could use
-     -- revPostorder which drops unreachable blocks this is done in
-     -- ContFlowOpt already which runs before this pass. So we use
-     -- toBlockList since it is faster.
-     groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]]
-     blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
-
--- Invariant: The blocks in the list are pairwise distinct
--- (so avoid comparing them again)
-type DistinctBlocks = [CmmBlock]
-type Key = [Label]
-type Subst = LabelMap BlockId
-
--- The outer list groups by hash. We retain this grouping throughout.
-iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
-iterate subst blocks
-    | mapNull new_substs = subst
-    | otherwise = iterate subst' updated_blocks
-  where
-    grouped_blocks :: [[(Key, NonEmpty DistinctBlocks)]]
-    grouped_blocks = map groupByLabel blocks
-
-    merged_blocks :: [[(Key, DistinctBlocks)]]
-    (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks
-      where
-        go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))
-          where
-            (new_subst2, db) = mergeBlockList subst dbs
-
-    subst' = subst `mapUnion` new_substs
-    updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
-
--- Combine two lists of blocks.
--- While they are internally distinct they can still share common blocks.
-mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
-mergeBlocks subst existing new = go new
-  where
-    go [] = (mapEmpty, existing)
-    go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of
-        -- This block is a duplicate. Drop it, and add it to the substitution
-        Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs
-        -- This block is not a duplicate, keep it.
-        Nothing -> second (b:) $ go bs
-
-mergeBlockList :: Subst -> NonEmpty DistinctBlocks -> (Subst, DistinctBlocks)
-mergeBlockList subst (b:|bs) = go mapEmpty b bs
-  where
-    go !new_subst1 b [] = (new_subst1, b)
-    go !new_subst1 b1 (b2:bs) = go new_subst b bs
-      where
-        (new_subst2, b) =  mergeBlocks subst b1 b2
-        new_subst = new_subst1 `mapUnion` new_subst2
-
-
--- -----------------------------------------------------------------------------
--- Hashing and equality on blocks
-
--- Below here is mostly boilerplate: hashing blocks ignoring labels,
--- and comparing blocks modulo a label mapping.
-
--- To speed up comparisons, we hash each basic block modulo jump labels.
--- The hashing is a bit arbitrary (the numbers are completely arbitrary),
--- but it should be fast and good enough.
-
--- We want to get as many small buckets as possible, as comparing blocks is
--- expensive. So include as much as possible in the hash. Ideally everything
--- that is compared with (==) in eqBlockBodyWith.
-
-type HashCode = Int
-
-hash_block :: CmmBlock -> HashCode
-hash_block block =
-  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
-  -- UniqFM doesn't like negative Ints
-  where hash_fst _ h = h
-        hash_mid m h = hash_node m + h `shiftL` 1
-        hash_lst m h = hash_node m + h `shiftL` 1
-
-        hash_node :: CmmNode O x -> Word32
-        hash_node n | dont_care n = 0 -- don't care
-        hash_node (CmmAssign r e) = hash_reg r + hash_e e
-        hash_node (CmmStore e e' _) = hash_e e + hash_e e'
-        hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
-        hash_node (CmmBranch _) = 23 -- NB. ignore the label
-        hash_node (CmmCondBranch p _ _ _) = hash_e p
-        hash_node (CmmCall e _ _ _ _ _) = hash_e e
-        hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
-        hash_node (CmmSwitch e _) = hash_e e
-        hash_node _ = error "hash_node: unknown Cmm node!"
-
-        hash_reg :: CmmReg -> Word32
-        hash_reg   (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397
-        hash_reg   (CmmGlobal _)    = 19
-
-        hash_e :: CmmExpr -> Word32
-        hash_e (CmmLit l) = hash_lit l
-        hash_e (CmmLoad e _ _) = 67 + hash_e e
-        hash_e (CmmReg r) = hash_reg r
-        hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
-        hash_e (CmmRegOff r i) = hash_reg r + cvt i
-        hash_e (CmmStackSlot _ _) = 13
-
-        hash_lit :: CmmLit -> Word32
-        hash_lit (CmmInt i _) = fromInteger i
-        hash_lit (CmmFloat r _) = truncate r
-        hash_lit (CmmVec ls) = hash_list hash_lit ls
-        hash_lit (CmmLabel _) = 119 -- ugh
-        hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
-        hash_lit (CmmLabelDiffOff _ _ i _) = cvt $ 299 + i
-        hash_lit (CmmBlock _) = 191 -- ugh
-        hash_lit (CmmHighStackMark) = cvt 313
-
-        hash_tgt (ForeignTarget e _) = hash_e e
-        hash_tgt (PrimTarget _) = 31 -- lots of these
-
-        hash_list f = foldl' (\z x -> f x + z) (0::Word32)
-
-        cvt = fromInteger . toInteger
-
-        hash_unique :: Uniquable a => a -> Word32
-        hash_unique = cvt . getKey . getUnique
-
--- | Ignore these node types for equality
-dont_care :: CmmNode O x -> Bool
-dont_care CmmComment {}  = True
-dont_care CmmTick {}     = True
-dont_care CmmUnwind {}   = True
-dont_care _other         = False
-
--- Utilities: equality and substitution on the graph.
-
--- Given a map ``subst'' from BlockID -> BlockID, we define equality.
-eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool
-eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
-lookupBid :: LabelMap BlockId -> BlockId -> BlockId
-lookupBid subst bid = case mapLookup bid subst of
-                        Just bid  -> lookupBid subst bid
-                        Nothing -> bid
-
--- Middle nodes and expressions can contain BlockIds, in particular in
--- CmmStackSlot and CmmBlock, so we have to use a special equality for
--- these.
---
-eqMiddleWith :: (BlockId -> BlockId -> Bool)
-             -> CmmNode O O -> CmmNode O O -> Bool
-eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
-  = r1 == r2 && eqExprWith eqBid e1 e2
-eqMiddleWith eqBid (CmmStore l1 r1 _) (CmmStore l2 r2 _)
-  = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2
-eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)
-                   (CmmUnsafeForeignCall t2 r2 a2)
-  = t1 == t2 && r1 == r2 && liftEq (eqExprWith eqBid) a1 a2
-eqMiddleWith _ _ _ = False
-
-eqExprWith :: (BlockId -> BlockId -> Bool)
-           -> CmmExpr -> CmmExpr -> Bool
-eqExprWith eqBid = eq
- where
-  CmmLit l1          `eq` CmmLit l2          = eqLit l1 l2
-  CmmLoad e1 t1 a1   `eq` CmmLoad e2 t2 a2   = t1 `cmmEqType` t2 && e1 `eq` e2 && a1==a2
-  CmmReg r1          `eq` CmmReg r2          = r1==r2
-  CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2
-  CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && liftEq eq es1 es2
-  CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2
-  _e1                `eq` _e2                = False
-
-  eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2
-  eqLit l1 l2 = l1 == l2
-
-  eqArea Old Old = True
-  eqArea (Young id1) (Young id2) = eqBid id1 id2
-  eqArea _ _ = False
-
--- Equality on the body of a block, modulo a function mapping block
--- IDs to block IDs.
-eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
-eqBlockBodyWith eqBid block block'
-  {-
-  | equal     = pprTrace "equal" (vcat [ppr block, ppr block']) True
-  | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False
-  -}
-  = equal
-  where (_,m,l)   = blockSplit block
-        nodes     = filter (not . dont_care) (blockToList m)
-        (_,m',l') = blockSplit block'
-        nodes'    = filter (not . dont_care) (blockToList m')
-
-        equal = liftEq (eqMiddleWith eqBid) nodes nodes' &&
-                eqLastWith eqBid l l'
-
-
-eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
-eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
-eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) =
-  c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2
-eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =
-  t1 == t2 && liftEq eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
-eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =
-  e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2
-eqLastWith _ _ _ = False
-
--- | Given a block map, ensure that all "target" blocks are covered by
--- the same ticks as the respective "source" blocks. This not only
--- means copying ticks, but also adjusting tick scopes where
--- necessary.
-copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph
-copyTicks env g
-  | mapNull env = g
-  | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
-  where -- Reverse block merge map
-        blockMap = toBlockMap g
-        revEnv = mapFoldlWithKey insertRev M.empty env
-        insertRev m k x = M.insertWith (const (k:)) x [k] m
-        -- Copy ticks and scopes into the given block
-        copyTo block = case M.lookup (entryLabel block) revEnv of
-          Nothing -> block
-          Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls
-        copy from to =
-          let ticks = blockTicks from
-              CmmEntry  _   scp0        = firstNode from
-              (CmmEntry lbl scp1, code) = blockSplitHead to
-          in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`
-             foldr blockCons code (map CmmTick ticks)
-
--- Group by [Label]
--- See Note [Compressed TrieMap] in GHC.Core.Map.Expr about the usage of GenMap.
-groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, NonEmpty DistinctBlocks)]
-groupByLabel =
-  go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, NonEmpty DistinctBlocks))
-    where
-      go !m [] = TM.foldTM (:) m []
-      go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries
-        where --k' = map (getKey . getUnique) k
-              adjust Nothing       = Just (k, pure v)
-              adjust (Just (_,vs)) = Just (k, v NE.<| vs)
-
-groupByInt :: (a -> Int) -> [a] -> [[a]]
-groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs
-   -- See Note [Unique Determinism and code generation]
-  where
-    go m x = alterUFM addEntry m (f x)
-      where
-        addEntry xs = Just $! maybe [x] (x:) xs
diff --git a/compiler/GHC/Cmm/Config.hs b/compiler/GHC/Cmm/Config.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Config.hs
+++ /dev/null
@@ -1,31 +0,0 @@
--- | Cmm compilation configuration
-
-{-# LANGUAGE DerivingStrategies         #-}
-
-module GHC.Cmm.Config
-  ( CmmConfig(..)
-  , cmmPlatform
-  ) where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Platform.Profile
-
-
-data CmmConfig = CmmConfig
-  { cmmProfile             :: !Profile -- ^ Target Profile
-  , cmmOptControlFlow      :: !Bool    -- ^ Optimize Cmm Control Flow or not
-  , cmmDoLinting           :: !Bool    -- ^ Do Cmm Linting Optimization or not
-  , cmmOptElimCommonBlks   :: !Bool    -- ^ Eliminate common blocks or not
-  , cmmOptSink             :: !Bool    -- ^ Perform sink after stack layout or not
-  , cmmGenStackUnwindInstr :: !Bool    -- ^ Generate stack unwinding instructions (for debugging)
-  , cmmExternalDynamicRefs :: !Bool    -- ^ Generate code to link against dynamic libraries
-  , cmmDoCmmSwitchPlans    :: !Bool    -- ^ Should the Cmm pass replace Stg switch statements
-  , cmmSplitProcPoints     :: !Bool    -- ^ Should Cmm split proc points or not
-  }
-
--- | retrieve the target Cmm platform
-cmmPlatform :: CmmConfig -> Platform
-cmmPlatform = profilePlatform . cmmProfile
-
diff --git a/compiler/GHC/Cmm/ContFlowOpt.hs b/compiler/GHC/Cmm/ContFlowOpt.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/ContFlowOpt.hs
+++ /dev/null
@@ -1,450 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE BangPatterns #-}
-module GHC.Cmm.ContFlowOpt
-    ( cmmCfgOpts
-    , cmmCfgOptsProc
-    , removeUnreachableBlocksProc
-    , replaceLabels
-    )
-where
-
-import GHC.Prelude hiding (succ, unzip, zip)
-
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.BlockId
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Cmm.Switch (mapSwitchTargets, switchTargetsToList)
-import GHC.Data.Maybe
-import GHC.Platform
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import Control.Monad
-
-
--- Note [What is shortcutting]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Consider this Cmm code:
---
--- L1: ...
---     goto L2;
--- L2: goto L3;
--- L3: ...
---
--- Here L2 is an empty block and contains only an unconditional branch
--- to L3. In this situation any block that jumps to L2 can jump
--- directly to L3:
---
--- L1: ...
---     goto L3;
--- L2: goto L3;
--- L3: ...
---
--- In this situation we say that we shortcut L2 to L3. One of
--- consequences of shortcutting is that some blocks of code may become
--- unreachable (in the example above this is true for L2).
-
-
--- Note [Control-flow optimisations]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- This optimisation does three things:
---
---   - If a block finishes in an unconditional branch to another block
---     and that is the only jump to that block we concatenate the
---     destination block at the end of the current one.
---
---   - If a block finishes in a call whose continuation block is a
---     goto, then we can shortcut the destination, making the
---     continuation block the destination of the goto - but see Note
---     [Shortcut call returns].
---
---   - For any block that is not a call we try to shortcut the
---     destination(s). Additionally, if a block ends with a
---     conditional branch we try to invert the condition.
---
--- Blocks are processed using postorder DFS traversal. A side effect
--- of determining traversal order with a graph search is elimination
--- of any blocks that are unreachable.
---
--- Transformations are improved by working from the end of the graph
--- towards the beginning, because we may be able to perform many
--- shortcuts in one go.
-
-
--- Note [Shortcut call returns]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- We are going to maintain the "current" graph (LabelMap CmmBlock) as
--- we go, and also a mapping from BlockId to BlockId, representing
--- continuation labels that we have renamed.  This latter mapping is
--- important because we might shortcut a CmmCall continuation.  For
--- example:
---
---    Sp[0] = L
---    call g returns to L
---    L: goto M
---    M: ...
---
--- So when we shortcut the L block, we need to replace not only
--- the continuation of the call, but also references to L in the
--- code (e.g. the assignment Sp[0] = L):
---
---    Sp[0] = M
---    call g returns to M
---    M: ...
---
--- So we keep track of which labels we have renamed and apply the mapping
--- at the end with replaceLabels.
-
-
--- Note [Shortcut call returns and proc-points]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Consider this code that you might get from a recursive
--- let-no-escape:
---
---       goto L1
---      L1:
---       if (Hp > HpLim) then L2 else L3
---      L2:
---       call stg_gc_noregs returns to L4
---      L4:
---       goto L1
---      L3:
---       ...
---       goto L1
---
--- Then the control-flow optimiser shortcuts L4.  But that turns L1
--- into the call-return proc point, and every iteration of the loop
--- has to shuffle variables to and from the stack.  So we must *not*
--- shortcut L4.
---
--- Moreover not shortcutting call returns is probably fine.  If L4 can
--- concat with its branch target then it will still do so.  And we
--- save some compile time because we don't have to traverse all the
--- code in replaceLabels.
---
--- However, we probably do want to do this if we are splitting proc
--- points, because L1 will be a proc-point anyway, so merging it with
--- L4 reduces the number of proc points.  Unfortunately recursive
--- let-no-escapes won't generate very good code with proc-point
--- splitting on - we should probably compile them to explicitly use
--- the native calling convention instead.
-
-cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
-cmmCfgOpts split g = fst (blockConcat split g)
-
-cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
-cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g'
-    where (g', env) = blockConcat split g
-          info' = info{ info_tbls = new_info_tbls }
-          new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))
-
-          -- If we changed any labels, then we have to update the info tables
-          -- too, except for the top-level info table because that might be
-          -- referred to by other procs.
-          upd_info (k,info)
-             | Just k' <- mapLookup k env
-             = (k', if k' == g_entry g'
-                       then info
-                       else info{ cit_lbl = infoTblLbl k' })
-             | otherwise
-             = (k,info)
-cmmCfgOptsProc _ top = top
-
-
-blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
-blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
-  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')
-  where
-     -- We might be able to shortcut the entry BlockId itself.
-     -- Remember to update the shortcut_map, since we also have to
-     -- update the info_tbls mapping now.
-     (new_entry, shortcut_map')
-       | Just entry_blk <- mapLookup entry_id new_blocks
-       , Just dest      <- canShortcut entry_blk
-       = (dest, mapInsert entry_id dest shortcut_map)
-       | otherwise
-       = (entry_id, shortcut_map)
-
-     -- blocks are sorted in reverse postorder, but we want to go from the exit
-     -- towards beginning, so we use foldr below.
-     blocks = revPostorder g
-     blockmap = foldl' (flip addBlock) emptyBody blocks
-
-     -- Accumulator contains three components:
-     --  * map of blocks in a graph
-     --  * map of shortcut labels. See Note [Shortcut call returns]
-     --  * map containing number of predecessors for each block. We discard
-     --    it after we process all blocks.
-     (new_blocks, shortcut_map, _) =
-           foldr maybe_concat (blockmap, mapEmpty, initialBackEdges) blocks
-
-     -- Map of predecessors for initial graph. We increase number of
-     -- predecessors for entry block by one to denote that it is
-     -- target of a jump, even if no block in the current graph jumps
-     -- to it.
-     initialBackEdges = incPreds entry_id (predMap blocks)
-
-     maybe_concat :: CmmBlock
-                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
-                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
-     maybe_concat block (!blocks, !shortcut_map, !backEdges)
-        -- If:
-        --   (1) current block ends with unconditional branch to b' and
-        --   (2) it has exactly one predecessor (namely, current block)
-        --
-        -- Then:
-        --   (1) append b' block at the end of current block
-        --   (2) remove b' from the map of blocks
-        --   (3) remove information about b' from predecessors map
-        --
-        -- Since we know that the block has only one predecessor we call
-        -- mapDelete directly instead of calling decPreds.
-        --
-        -- Note that we always maintain an up-to-date list of predecessors, so
-        -- we can ignore the contents of shortcut_map
-        | CmmBranch b' <- last
-        , hasOnePredecessor b'
-        , Just blk' <- mapLookup b' blocks
-        = let bid' = entryLabel blk'
-          in ( mapDelete bid' $ mapInsert bid (splice head blk') blocks
-             , shortcut_map
-             , mapDelete b' backEdges )
-
-        -- If:
-        --   (1) we are splitting proc points (see Note
-        --       [Shortcut call returns and proc-points]) and
-        --   (2) current block is a CmmCall or CmmForeignCall with
-        --       continuation b' and
-        --   (3) we can shortcut that continuation to dest
-        -- Then:
-        --   (1) we change continuation to point to b'
-        --   (2) create mapping from b' to dest
-        --   (3) increase number of predecessors of dest by 1
-        --   (4) decrease number of predecessors of b' by 1
-        --
-        -- Later we will use replaceLabels to substitute all occurrences of b'
-        -- with dest.
-        | splitting_procs
-        , Just b'   <- callContinuation_maybe last
-        , Just blk' <- mapLookup b' blocks
-        , Just dest <- canShortcut blk'
-        = ( mapInsert bid (blockJoinTail head (update_cont dest)) blocks
-          , mapInsert b' dest shortcut_map
-          , decPreds b' $ incPreds dest backEdges )
-
-        -- If:
-        --   (1) a block does not end with a call
-        -- Then:
-        --   (1) if it ends with a conditional attempt to invert the
-        --       conditional
-        --   (2) attempt to shortcut all destination blocks
-        --   (3) if new successors of a block are different from the old ones
-        --       update the of predecessors accordingly
-        --
-        -- A special case of this is a situation when a block ends with an
-        -- unconditional jump to a block that can be shortcut.
-        | Nothing <- callContinuation_maybe last
-        = let oldSuccs = successors last
-              newSuccs = successors rewrite_last
-          in ( mapInsert bid (blockJoinTail head rewrite_last) blocks
-             , shortcut_map
-             , if oldSuccs == newSuccs
-               then backEdges
-               else foldr incPreds (foldr decPreds backEdges oldSuccs) newSuccs )
-
-        -- Otherwise don't do anything
-        | otherwise
-        = ( blocks, shortcut_map, backEdges )
-        where
-          (head, last) = blockSplitTail block
-          bid = entryLabel block
-
-          -- Changes continuation of a call to a specified label
-          update_cont dest =
-              case last of
-                CmmCall{}        -> last { cml_cont = Just dest }
-                CmmForeignCall{} -> last { succ = dest }
-                _                -> panic "Can't shortcut continuation."
-
-          -- Attempts to shortcut successors of last node
-          shortcut_last = mapSuccessors shortcut last
-            where
-              shortcut l =
-                 case mapLookup l blocks of
-                   Just b | Just dest <- canShortcut b -> dest
-                   _otherwise -> l
-
-          rewrite_last
-            -- Sometimes we can get rid of the conditional completely.
-            | CmmCondBranch _cond t f _l <- shortcut_last
-            , t == f
-            = CmmBranch t
-
-            -- See Note [Invert Cmm conditionals]
-            | CmmCondBranch cond t f l <- shortcut_last
-            , hasOnePredecessor t -- inverting will make t a fallthrough
-            , likelyTrue l || (numPreds f > 1)
-            , Just cond' <- maybeInvertCmmExpr cond
-            = CmmCondBranch cond' f t (invertLikeliness l)
-
-            -- If all jump destinations of a switch go to the
-            -- same target eliminate the switch.
-            | CmmSwitch _expr targets <- shortcut_last
-            , (t:ts) <- switchTargetsToList targets
-            , all (== t) ts
-            = CmmBranch t
-
-            | otherwise
-            = shortcut_last
-
-          likelyTrue (Just True)   = True
-          likelyTrue _             = False
-
-          invertLikeliness :: Maybe Bool -> Maybe Bool
-          invertLikeliness         = fmap not
-
-          -- Number of predecessors for a block
-          numPreds bid = mapLookup bid backEdges `orElse` 0
-
-          hasOnePredecessor b = numPreds b == 1
-
-{-
-  Note [Invert Cmm conditionals]
-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  The native code generator always produces jumps to the true branch.
-  Falling through to the false branch is however faster. So we try to
-  arrange for that to happen.
-  This means we invert the condition if:
-  * The likely path will become a fallthrough.
-  * We can't guarantee a fallthrough for the false branch but for the
-    true branch.
-
-  In some cases it's faster to avoid inverting when the false branch is likely.
-  However determining when that is the case is neither easy nor cheap so for
-  now we always invert as this produces smaller binaries and code that is
-  equally fast on average. (On an i7-6700K)
-
-  TODO:
-  There is also the edge case when both branches have multiple predecessors.
-  In this case we could assume that we will end up with a jump for BOTH
-  branches. In this case it might be best to put the likely path in the true
-  branch especially if there are large numbers of predecessors as this saves
-  us the jump that's not taken. However I haven't tested this and as of early
-  2018 we almost never generate cmm where this would apply.
--}
-
--- Functions for incrementing and decrementing number of predecessors. If
--- decrementing would set the predecessor count to 0, we remove entry from the
--- map.
--- Invariant: if a block has no predecessors it should be dropped from the
--- graph because it is unreachable. maybe_concat is constructed to maintain
--- that invariant, but calling replaceLabels may introduce unreachable blocks.
--- We rely on subsequent passes in the Cmm pipeline to remove unreachable
--- blocks.
-incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int
-incPreds bid edges = mapInsertWith (+) bid 1 edges
-decPreds bid edges = case mapLookup bid edges of
-                       Just preds | preds > 1 -> mapInsert bid (preds - 1) edges
-                       Just _                 -> mapDelete bid edges
-                       _                      -> edges
-
-
--- Checks if a block consists only of "goto dest". If it does than we return
--- "Just dest" label. See Note [What is shortcutting]
-canShortcut :: CmmBlock -> Maybe BlockId
-canShortcut block
-    | (_, middle, CmmBranch dest) <- blockSplit block
-    , all dont_care $ blockToList middle
-    = Just dest
-    | otherwise
-    = Nothing
-    where dont_care CmmComment{} = True
-          dont_care CmmTick{}    = True
-          dont_care _other       = False
-
--- Concatenates two blocks. First one is assumed to be open on exit, the second
--- is assumed to be closed on entry (i.e. it has a label attached to it, which
--- the splice function removes by calling snd on result of blockSplitHead).
-splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
-splice head rest = entry `blockJoinHead` code0 `blockAppend` code1
-  where (CmmEntry lbl sc0, code0) = blockSplitHead head
-        (CmmEntry _   sc1, code1) = blockSplitHead rest
-        entry = CmmEntry lbl (combineTickScopes sc0 sc1)
-
--- If node is a call with continuation call return Just label of that
--- continuation. Otherwise return Nothing.
-callContinuation_maybe :: CmmNode O C -> Maybe BlockId
-callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b
-callContinuation_maybe (CmmForeignCall { succ = b })   = Just b
-callContinuation_maybe _ = Nothing
-
-
--- Map over the CmmGraph, replacing each label with its mapping in the
--- supplied LabelMap.
-replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph
-replaceLabels env g
-  | mapNull env = g
-  | otherwise   = replace_eid $ mapGraphNodes1 txnode g
-   where
-     replace_eid g = g {g_entry = lookup (g_entry g)}
-     lookup id = mapLookup id env `orElse` id
-
-     txnode :: CmmNode e x -> CmmNode e x
-     txnode (CmmBranch bid) = CmmBranch (lookup bid)
-     txnode (CmmCondBranch p t f l) =
-       mkCmmCondBranch (exp p) (lookup t) (lookup f) l
-     txnode (CmmSwitch e ids) =
-       CmmSwitch (exp e) (mapSwitchTargets lookup ids)
-     txnode (CmmCall t k rg a res r) =
-       CmmCall (exp t) (liftM lookup k) rg a res r
-     txnode fc@CmmForeignCall{} =
-       fc{ args = map exp (args fc), succ = lookup (succ fc) }
-     txnode other = mapExpDeep exp other
-
-     exp :: CmmExpr -> CmmExpr
-     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))
-     exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i
-     exp e                                      = e
-
-mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C
-mkCmmCondBranch p t f l =
-  if t == f then CmmBranch t else CmmCondBranch p t f l
-
--- Build a map from a block to its set of predecessors.
-predMap :: [CmmBlock] -> LabelMap Int
-predMap blocks = foldr add_preds mapEmpty blocks
-  where
-    add_preds block env = foldr add env (successors block)
-      where add lbl env = mapInsertWith (+) lbl 1 env
-
--- Remove unreachable blocks from procs
-removeUnreachableBlocksProc :: Platform -> CmmDecl -> CmmDecl
-removeUnreachableBlocksProc _ proc@(CmmProc info lbl live g)
-   | used_blocks `lengthLessThan` mapSize (toBlockMap g)
-   = CmmProc info' lbl live g'
-   | otherwise
-   = proc
-   where
-     g'    = ofBlockList (g_entry g) used_blocks
-     info' = info { info_tbls = keep_used (info_tbls info) }
-             -- Remove any info_tbls for unreachable
-
-     keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable
-     keep_used bs = mapFoldlWithKey keep mapEmpty bs
-
-     keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable
-     keep env l i | l `setMember` used_lbls = mapInsert l i env
-                  | otherwise               = env
-
-     used_blocks :: [CmmBlock]
-     used_blocks = revPostorder g
-
-     used_lbls :: LabelSet
-     used_lbls = setFromList $ map entryLabel used_blocks
-removeUnreachableBlocksProc platform data'@(CmmData _ _) =
-    pprPanic "removeUnreachableBlocksProc: passed data declaration instead of procedure" (pdoc platform data')
diff --git a/compiler/GHC/Cmm/Dataflow.hs b/compiler/GHC/Cmm/Dataflow.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Dataflow.hs
+++ /dev/null
@@ -1,457 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses  #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-
---
--- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,
--- and Norman Ramsey
---
--- Modifications copyright (c) The University of Glasgow 2012
---
--- This module is a specialised and optimised version of
--- Compiler.Hoopl.Dataflow in the hoopl package.  In particular it is
--- specialised to the UniqSM monad.
---
-
-module GHC.Cmm.Dataflow
-  ( C, O, Block
-  , lastNode, entryLabel
-  , foldNodesBwdOO
-  , foldRewriteNodesBwdOO
-  , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..)
-  , TransferFun, RewriteFun
-  , Fact, FactBase
-  , getFact, mkFactBase
-  , analyzeCmmFwd, analyzeCmmBwd
-  , rewriteCmmBwd
-  , changedIf
-  , joinOutFacts
-  , joinFacts
-  )
-where
-
-import GHC.Prelude
-
-import GHC.Cmm
-import GHC.Types.Unique.Supply
-
-import Data.Array
-import Data.Maybe
-import Data.IntSet (IntSet)
-import qualified Data.IntSet as IntSet
-import Data.Kind (Type)
-
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Label
-
-type family   Fact (x :: Extensibility) f :: Type
-type instance Fact C f = FactBase f
-type instance Fact O f = f
-
-newtype OldFact a = OldFact a
-
-newtype NewFact a = NewFact a
-
--- | The result of joining OldFact and NewFact.
-data JoinedFact a
-    = Changed !a     -- ^ Result is different than OldFact.
-    | NotChanged !a  -- ^ Result is the same as OldFact.
-
-getJoined :: JoinedFact a -> a
-getJoined (Changed a) = a
-getJoined (NotChanged a) = a
-
-changedIf :: Bool -> a -> JoinedFact a
-changedIf True = Changed
-changedIf False = NotChanged
-
-type JoinFun a = OldFact a -> NewFact a -> JoinedFact a
-
-data DataflowLattice a = DataflowLattice
-    { fact_bot :: a
-    , fact_join :: JoinFun a
-    }
-
-data Direction = Fwd | Bwd
-
-type TransferFun f = CmmBlock -> FactBase f -> FactBase f
-
--- | `TransferFun` abstracted over `n` (the node type)
-type TransferFun' (n :: Extensibility -> Extensibility -> Type) f =
-    Block n C C -> FactBase f -> FactBase f
-
-
--- | Function for rewriting and analysis combined. To be used with
--- @rewriteCmm@.
---
--- Currently set to work with @UniqSM@ monad, but we could probably abstract
--- that away (if we do that, we might want to specialize the fixpoint algorithms
--- to the particular monads through SPECIALIZE).
-type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f)
-
--- | `RewriteFun` abstracted over `n` (the node type)
-type RewriteFun' (n :: Extensibility -> Extensibility -> Type) f =
-    Block n C C -> FactBase f -> UniqSM (Block n C C, FactBase f)
-
-analyzeCmmBwd, analyzeCmmFwd
-    :: (NonLocal node)
-    => DataflowLattice f
-    -> TransferFun' node f
-    -> GenCmmGraph node
-    -> FactBase f
-    -> FactBase f
-analyzeCmmBwd = analyzeCmm Bwd
-analyzeCmmFwd = analyzeCmm Fwd
-
-analyzeCmm
-    :: (NonLocal node)
-    => Direction
-    -> DataflowLattice f
-    -> TransferFun' node f
-    -> GenCmmGraph node
-    -> FactBase f
-    -> FactBase f
-analyzeCmm dir lattice transfer cmmGraph initFact =
-    {-# SCC analyzeCmm #-}
-    let entry = g_entry cmmGraph
-        hooplGraph = g_graph cmmGraph
-        blockMap =
-            case hooplGraph of
-                GMany NothingO bm NothingO -> bm
-    in fixpointAnalysis dir lattice transfer entry blockMap initFact
-
--- Fixpoint algorithm.
-fixpointAnalysis
-    :: forall f node.
-       (NonLocal node)
-    => Direction
-    -> DataflowLattice f
-    -> TransferFun' node f
-    -> Label
-    -> LabelMap (Block node C C)
-    -> FactBase f
-    -> FactBase f
-fixpointAnalysis direction lattice do_block entry blockmap = loop start
-  where
-    -- Sorting the blocks helps to minimize the number of times we need to
-    -- process blocks. For instance, for forward analysis we want to look at
-    -- blocks in reverse postorder. Also, see comments for sortBlocks.
-    blocks     = sortBlocks direction entry blockmap
-    num_blocks = length blocks
-    block_arr  = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks
-    start      = {-# SCC "start" #-} IntSet.fromDistinctAscList
-      [0 .. num_blocks - 1]
-    dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks
-    join       = fact_join lattice
-
-    loop
-        :: IntHeap     -- Worklist, i.e., blocks to process
-        -> FactBase f  -- Current result (increases monotonically)
-        -> FactBase f
-    loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo =
-        let block = block_arr ! index
-            out_facts = {-# SCC "do_block" #-} do_block block fbase1
-            -- For each of the outgoing edges, we join it with the current
-            -- information in fbase1 and (if something changed) we update it
-            -- and add the affected blocks to the worklist.
-            (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-}
-                mapFoldlWithKey
-                    (updateFact join dep_blocks) (todo1, fbase1) out_facts
-        in loop todo2 fbase2
-    loop _ !fbase1 = fbase1
-
-rewriteCmmBwd
-    :: (NonLocal node)
-    => DataflowLattice f
-    -> RewriteFun' node f
-    -> GenCmmGraph node
-    -> FactBase f
-    -> UniqSM (GenCmmGraph node, FactBase f)
-rewriteCmmBwd = rewriteCmm Bwd
-
-rewriteCmm
-    :: (NonLocal node)
-    => Direction
-    -> DataflowLattice f
-    -> RewriteFun' node f
-    -> GenCmmGraph node
-    -> FactBase f
-    -> UniqSM (GenCmmGraph node, FactBase f)
-rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do
-    let entry = g_entry cmmGraph
-        hooplGraph = g_graph cmmGraph
-        blockMap1 =
-            case hooplGraph of
-                GMany NothingO bm NothingO -> bm
-    (blockMap2, facts) <-
-        fixpointRewrite dir lattice rwFun entry blockMap1 initFact
-    return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts)
-
-fixpointRewrite
-    :: forall f node.
-       NonLocal node
-    => Direction
-    -> DataflowLattice f
-    -> RewriteFun' node f
-    -> Label
-    -> LabelMap (Block node C C)
-    -> FactBase f
-    -> UniqSM (LabelMap (Block node C C), FactBase f)
-fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap
-  where
-    -- Sorting the blocks helps to minimize the number of times we need to
-    -- process blocks. For instance, for forward analysis we want to look at
-    -- blocks in reverse postorder. Also, see comments for sortBlocks.
-    blocks     = sortBlocks dir entry blockmap
-    num_blocks = length blocks
-    block_arr  = {-# SCC "block_arr_rewrite" #-}
-                 listArray (0, num_blocks - 1) blocks
-    start      = {-# SCC "start_rewrite" #-}
-                 IntSet.fromDistinctAscList [0 .. num_blocks - 1]
-    dep_blocks = {-# SCC "dep_blocks_rewrite" #-} mkDepBlocks dir blocks
-    join       = fact_join lattice
-
-    loop
-        :: IntHeap                    -- Worklist, i.e., blocks to process
-        -> LabelMap (Block node C C)  -- Rewritten blocks.
-        -> FactBase f                 -- Current facts.
-        -> UniqSM (LabelMap (Block node C C), FactBase f)
-    loop todo !blocks1 !fbase1
-      | Just (index, todo1) <- IntSet.minView todo = do
-        -- Note that we use the *original* block here. This is important.
-        -- We're optimistically rewriting blocks even before reaching the fixed
-        -- point, which means that the rewrite might be incorrect. So if the
-        -- facts change, we need to rewrite the original block again (taking
-        -- into account the new facts).
-        let block = block_arr ! index
-        (new_block, out_facts) <- {-# SCC "do_block_rewrite" #-}
-            do_block block fbase1
-        let blocks2 = mapInsert (entryLabel new_block) new_block blocks1
-            (todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-}
-                mapFoldlWithKey
-                    (updateFact join dep_blocks) (todo1, fbase1) out_facts
-        loop todo2 blocks2 fbase2
-    loop _ !blocks1 !fbase1 = return (blocks1, fbase1)
-
-
-{-
-Note [Unreachable blocks]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-A block that is not in the domain of tfb_fbase is "currently unreachable".
-A currently-unreachable block is not even analyzed.  Reason: consider
-constant prop and this graph, with entry point L1:
-  L1: x:=3; goto L4
-  L2: x:=4; goto L4
-  L4: if x>3 goto L2 else goto L5
-Here L2 is actually unreachable, but if we process it with bottom input fact,
-we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.
-
-* If a currently-unreachable block is not analyzed, then its rewritten
-  graph will not be accumulated in tfb_rg.  And that is good:
-  unreachable blocks simply do not appear in the output.
-
-* Note that clients must be careful to provide a fact (even if bottom)
-  for each entry point. Otherwise useful blocks may be garbage collected.
-
-* Note that updateFact must set the change-flag if a label goes from
-  not-in-fbase to in-fbase, even if its fact is bottom.  In effect the
-  real fact lattice is
-       UNR
-       bottom
-       the points above bottom
-
-* Even if the fact is going from UNR to bottom, we still call the
-  client's fact_join function because it might give the client
-  some useful debugging information.
-
-* All of this only applies for *forward* ixpoints.  For the backward
-  case we must treat every block as reachable; it might finish with a
-  'return', and therefore have no successors, for example.
--}
-
-
------------------------------------------------------------------------------
---  Pieces that are shared by fixpoint and fixpoint_anal
------------------------------------------------------------------------------
-
--- | Sort the blocks into the right order for analysis. This means reverse
--- postorder for a forward analysis. For the backward one, we simply reverse
--- that (see Note [Backward vs forward analysis]).
-sortBlocks
-    :: NonLocal n
-    => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]
-sortBlocks direction entry blockmap =
-    case direction of
-        Fwd -> fwd
-        Bwd -> reverse fwd
-  where
-    fwd = revPostorderFrom blockmap entry
-
--- Note [Backward vs forward analysis]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- The forward and backward cases are not dual.  In the forward case, the entry
--- points are known, and one simply traverses the body blocks from those points.
--- In the backward case, something is known about the exit points, but a
--- backward analysis must also include reachable blocks that don't reach the
--- exit, as in a procedure that loops forever and has side effects.)
--- For instance, let E be the entry and X the exit blocks (arrows indicate
--- control flow)
---   E -> X
---   E -> B
---   B -> C
---   C -> B
--- We do need to include B and C even though they're unreachable in the
--- *reverse* graph (that we could use for backward analysis):
---   E <- X
---   E <- B
---   B <- C
---   C <- B
--- So when sorting the blocks for the backward analysis, we simply take the
--- reverse of what is used for the forward one.
-
-
--- | Construct a mapping from a @Label@ to the block indexes that should be
--- re-analyzed if the facts at that @Label@ change.
---
--- Note that we're considering here the entry point of the block, so if the
--- facts change at the entry:
--- * for a backward analysis we need to re-analyze all the predecessors, but
--- * for a forward analysis, we only need to re-analyze the current block
---   (and that will in turn propagate facts into its successors).
-mkDepBlocks :: NonLocal node => Direction -> [Block node C C] -> LabelMap IntSet
-mkDepBlocks Fwd blocks = go blocks 0 mapEmpty
-  where
-    go []     !_ !dep_map = dep_map
-    go (b:bs) !n !dep_map =
-        go bs (n + 1) $ mapInsert (entryLabel b) (IntSet.singleton n) dep_map
-mkDepBlocks Bwd blocks = go blocks 0 mapEmpty
-  where
-    go []     !_ !dep_map = dep_map
-    go (b:bs) !n !dep_map =
-        let insert m l = mapInsertWith IntSet.union l (IntSet.singleton n) m
-        in go bs (n + 1) $ foldl' insert dep_map (successors b)
-
--- | After some new facts have been generated by analysing a block, we
--- fold this function over them to generate (a) a list of block
--- indices to (re-)analyse, and (b) the new FactBase.
-updateFact
-    :: JoinFun f
-    -> LabelMap IntSet
-    -> (IntHeap, FactBase f)
-    -> Label
-    -> f -- out fact
-    -> (IntHeap, FactBase f)
-updateFact fact_join dep_blocks (todo, fbase) lbl new_fact
-  = case lookupFact lbl fbase of
-      Nothing ->
-          -- See Note [No old fact]
-          let !z = mapInsert lbl new_fact fbase in (changed, z)
-      Just old_fact ->
-          case fact_join (OldFact old_fact) (NewFact new_fact) of
-              (NotChanged _) -> (todo, fbase)
-              (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)
-  where
-    changed = todo `IntSet.union`
-              mapFindWithDefault IntSet.empty lbl dep_blocks
-
-{-
-Note [No old fact]
-~~~~~~~~~~~~~~~~~~
-We know that the new_fact is >= _|_, so we don't need to join.  However,
-if the new fact is also _|_, and we have already analysed its block,
-we don't need to record a change.  So there's a tradeoff here.  It turns
-out that always recording a change is faster.
--}
-
-----------------------------------------------------------------
---       Utilities
-----------------------------------------------------------------
-
--- Fact lookup: the fact `orelse` bottom
-getFact  :: DataflowLattice f -> Label -> FactBase f -> f
-getFact lat l fb = case lookupFact l fb of Just  f -> f
-                                           Nothing -> fact_bot lat
-
--- | Returns the result of joining the facts from all the successors of the
--- provided node or block.
-joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f
-joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts
-  where
-    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
-    facts =
-        [ fromJust fact
-        | s <- successors nonLocal
-        , let fact = lookupFact s fact_base
-        , isJust fact
-        ]
-
-joinFacts :: DataflowLattice f -> [f] -> f
-joinFacts lattice facts  = foldl' join (fact_bot lattice) facts
-  where
-    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
-
--- | Returns the joined facts for each label.
-mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
-mkFactBase lattice = foldl' add mapEmpty
-  where
-    join = fact_join lattice
-
-    add result (l, f1) =
-        let !newFact =
-                case mapLookup l result of
-                    Nothing -> f1
-                    Just f2 -> getJoined $ join (OldFact f1) (NewFact f2)
-        in mapInsert l newFact result
-
--- | Folds backward over all nodes of an open-open block.
--- Strict in the accumulator.
-foldNodesBwdOO :: (node O O -> f -> f) -> Block node O O -> f -> f
-foldNodesBwdOO funOO = go
-  where
-    go (BCat b1 b2) f = go b1 $! go b2 f
-    go (BSnoc h n) f = go h $! funOO n f
-    go (BCons n t) f = funOO n $! go t f
-    go (BMiddle n) f = funOO n f
-    go BNil f = f
-{-# INLINABLE foldNodesBwdOO #-}
-
--- | Folds backward over all the nodes of an open-open block and allows
--- rewriting them. The accumulator is both the block of nodes and @f@ (usually
--- dataflow facts).
--- Strict in both accumulated parts.
-foldRewriteNodesBwdOO
-    :: forall f node.
-       (node O O -> f -> UniqSM (Block node O O, f))
-    -> Block node O O
-    -> f
-    -> UniqSM (Block node O O, f)
-foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts
-  where
-    go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1
-    go (BSnoc block1 node1) !fact1 = (go block1 `comp` rewriteOO node1) fact1
-    go (BCat blockA1 blockB1) !fact1 = (go blockA1 `comp` go blockB1) fact1
-    go (BMiddle node) !fact1 = rewriteOO node fact1
-    go BNil !fact = return (BNil, fact)
-
-    comp rew1 rew2 = \f1 -> do
-        (b, f2) <- rew2 f1
-        (a, !f3) <- rew1 f2
-        let !c = joinBlocksOO a b
-        return (c, f3)
-    {-# INLINE comp #-}
-{-# INLINABLE foldRewriteNodesBwdOO #-}
-
-joinBlocksOO :: Block n O O -> Block n O O -> Block n O O
-joinBlocksOO BNil b = b
-joinBlocksOO b BNil = b
-joinBlocksOO (BMiddle n) b = blockCons n b
-joinBlocksOO b (BMiddle n) = blockSnoc b n
-joinBlocksOO b1 b2 = BCat b1 b2
-
-type IntHeap = IntSet
diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/DebugBlock.hs
+++ /dev/null
@@ -1,575 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE LambdaCase #-}
-
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
------------------------------------------------------------------------------
---
--- Debugging data
---
--- Association of debug data on the Cmm level, with methods to encode it in
--- event log format for later inclusion in profiling event logs.
---
------------------------------------------------------------------------------
-
-module GHC.Cmm.DebugBlock (
-
-  DebugBlock(..),
-  cmmDebugGen,
-  cmmDebugLabels,
-  cmmDebugLink,
-  debugToMap,
-
-  -- * Unwinding information
-  UnwindTable, UnwindPoint(..),
-  UnwindExpr(..), toUnwindExpr,
-  pprUnwindTable
-  ) where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Cmm.BlockId
-import GHC.Cmm.CLabel
-import GHC.Cmm
-import GHC.Cmm.Reg ( pprGlobalReg )
-import GHC.Cmm.Utils
-import GHC.Data.FastString ( nilFS, mkFastString )
-import GHC.Unit.Module
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Types.SrcLoc
-import GHC.Types.Tickish
-import GHC.Utils.Misc      ( seqList )
-
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
-
-import Data.Maybe
-import Data.List     ( minimumBy, nubBy )
-import Data.Ord      ( comparing )
-import qualified Data.Map as Map
-import Data.Either   ( partitionEithers )
-
--- | Debug information about a block of code. Ticks scope over nested
--- blocks.
-data DebugBlock =
-  DebugBlock
-  { dblProcedure  :: !Label        -- ^ Entry label of containing proc
-  , dblLabel      :: !Label        -- ^ Hoopl label
-  , dblCLabel     :: !CLabel       -- ^ Output label
-  , dblHasInfoTbl :: !Bool         -- ^ Has an info table?
-  , dblParent     :: !(Maybe DebugBlock)
-    -- ^ The parent of this proc. See Note [Splitting DebugBlocks]
-  , dblTicks      :: ![CmmTickish] -- ^ Ticks defined in this block
-  , dblSourceTick :: !(Maybe CmmTickish) -- ^ Best source tick covering block
-  , dblPosition   :: !(Maybe Int)  -- ^ Output position relative to
-                                   -- other blocks. @Nothing@ means
-                                   -- the block was optimized out
-  , dblUnwind     :: [UnwindPoint]
-  , dblBlocks     :: ![DebugBlock] -- ^ Nested blocks
-  }
-
-instance OutputableP Platform DebugBlock where
-  pdoc env blk =
-            (if | dblProcedure blk == dblLabel blk
-                -> text "proc"
-                | dblHasInfoTbl blk
-                -> text "pp-blk"
-                | otherwise
-                -> text "blk") <+>
-            ppr (dblLabel blk) <+> parens (pprAsmLabel env (dblCLabel blk)) <+>
-            (maybe empty ppr (dblSourceTick blk)) <+>
-            (maybe (text "removed") ((text "pos " <>) . ppr)
-                   (dblPosition blk)) <+>
-            (pdoc env (dblUnwind blk)) $+$
-            (if null (dblBlocks blk) then empty else nest 4 (pdoc env (dblBlocks blk)))
-
--- | Intermediate data structure holding debug-relevant context information
--- about a block.
-type BlockContext = (CmmBlock, RawCmmDecl)
-
--- | Extract debug data from a group of procedures. We will prefer
--- source notes that come from the given module (presumably the module
--- that we are currently compiling).
-cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]
-cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
-  where
-      blockCtxs :: Map.Map CmmTickScope [BlockContext]
-      blockCtxs = blockContexts decls
-
-      -- Analyse tick scope structure: Each one is either a top-level
-      -- tick scope, or the child of another.
-      (topScopes, childScopes)
-        = partitionEithers $ map (\a -> findP a a) $ Map.keys blockCtxs
-      findP tsc GlobalScope = Left tsc -- top scope
-      findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)
-                    | otherwise                   = findP tsc scp'
-        where -- Note that we only following the left parent of
-              -- combined scopes. This loses us ticks, which we will
-              -- recover by copying ticks below.
-              scp' | SubScope _ scp' <- scp      = scp'
-                   | CombinedScope scp' _ <- scp = scp'
-#if __GLASGOW_HASKELL__ < 901
-                   | otherwise                   = panic "findP impossible"
-#endif
-
-      scopeMap = foldl' (\acc (key, scope) -> insertMulti key scope acc) Map.empty childScopes
-
-      -- This allows us to recover ticks that we lost by flattening
-      -- the graph. Basically, if the parent is A but the child is
-      -- CBA, we know that there is no BA, because it would have taken
-      -- priority - but there might be a B scope, with ticks that
-      -- would not be associated with our child anymore. Note however
-      -- that there might be other childs (DB), which we have to
-      -- filter out.
-      --
-      -- We expect this to be called rarely, which is why we are not
-      -- trying too hard to be efficient here. In many cases we won't
-      -- have to construct blockCtxsU in the first place.
-      ticksToCopy :: CmmTickScope -> [CmmTickish]
-      ticksToCopy (CombinedScope scp s) = go s
-        where go s | scp `isTickSubScope` s   = [] -- done
-                   | SubScope _ s' <- s       = ticks ++ go s'
-                   | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2
-                   | otherwise                = panic "ticksToCopy impossible"
-                where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs
-      ticksToCopy _ = []
-      bCtxsTicks = concatMap (blockTicks . fst)
-
-      -- Finding the "best" source tick is somewhat arbitrary -- we
-      -- select the first source span, while preferring source ticks
-      -- from the same source file.  Furthermore, dumps take priority
-      -- (if we generated one, we probably want debug information to
-      -- refer to it).
-      bestSrcTick = minimumBy (comparing rangeRating)
-      rangeRating (SourceNote span _)
-        | srcSpanFile span == thisFile = 1
-        | otherwise                    = 2 :: Int
-      rangeRating note                 = pprPanic "rangeRating" (ppr note)
-      thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc
-
-      -- Returns block tree for this scope as well as all nested
-      -- scopes. Note that if there are multiple blocks in the (exact)
-      -- same scope we elect one as the "branch" node and add the rest
-      -- as children.
-      blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock
-      blocksForScope cstick scope = mkBlock True (head bctxs)
-        where bctxs = fromJust $ Map.lookup scope blockCtxs
-              nested = fromMaybe [] $ Map.lookup scope scopeMap
-              childs = map (mkBlock False) (tail bctxs) ++
-                       map (blocksForScope stick) nested
-
-              mkBlock :: Bool -> BlockContext -> DebugBlock
-              mkBlock top (block, prc)
-                = DebugBlock { dblProcedure    = g_entry graph
-                             , dblLabel        = label
-                             , dblCLabel       = case info of
-                                 Just (CmmStaticsRaw infoLbl _) -> infoLbl
-                                 Nothing
-                                   | g_entry graph == label -> entryLbl
-                                   | otherwise              -> blockLbl label
-                             , dblHasInfoTbl   = isJust info
-                             , dblParent       = Nothing
-                             , dblTicks        = ticks
-                             , dblPosition     = Nothing -- see cmmDebugLink
-                             , dblSourceTick   = stick
-                             , dblBlocks       = blocks
-                             , dblUnwind       = []
-                             }
-                where (CmmProc infos entryLbl _ graph) = prc
-                      label = entryLabel block
-                      info = mapLookup label infos
-                      blocks | top       = seqList childs childs
-                             | otherwise = []
-
-              -- A source tick scopes over all nested blocks. However
-              -- their source ticks might take priority.
-              isSourceTick SourceNote {} = True
-              isSourceTick _             = False
-              -- Collect ticks from all blocks inside the tick scope.
-              -- We attempt to filter out duplicates while we're at it.
-              ticks = nubBy (flip tickishContains) $
-                      bCtxsTicks bctxs ++ ticksToCopy scope
-              stick = case filter isSourceTick ticks of
-                []     -> cstick
-                sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)
-
--- | Build a map of blocks sorted by their tick scopes
---
--- This involves a pre-order traversal, as we want blocks in rough
--- control flow order (so ticks have a chance to be sorted in the
--- right order).
-blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]
-blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls
-  where walkProc :: RawCmmDecl
-                 -> Map.Map CmmTickScope [BlockContext]
-                 -> Map.Map CmmTickScope [BlockContext]
-        walkProc CmmData{}                 m = m
-        walkProc prc@(CmmProc _ _ _ graph) m
-          | mapNull blocks = m
-          | otherwise      = snd $ walkBlock prc entry (emptyLbls, m)
-          where blocks = toBlockMap graph
-                entry  = [mapFind (g_entry graph) blocks]
-                emptyLbls = setEmpty :: LabelSet
-
-        walkBlock :: RawCmmDecl -> [Block CmmNode C C]
-                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])
-                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])
-        walkBlock _   []             c            = c
-        walkBlock prc (block:blocks) (visited, m)
-          | lbl `setMember` visited
-          = walkBlock prc blocks (visited, m)
-          | otherwise
-          = walkBlock prc blocks $
-            walkBlock prc succs
-              (lbl `setInsert` visited,
-               insertMulti scope (block, prc) m)
-          where CmmEntry lbl scope = firstNode block
-                (CmmProc _ _ _ graph) = prc
-                succs = map (flip mapFind (toBlockMap graph))
-                            (successors (lastNode block))
-        mapFind = mapFindWithDefault (error "contextTree: block not found!")
-
-insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a]
-insertMulti k v = Map.insertWith (const (v:)) k [v]
-
-cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
-cmmDebugLabels isMeta nats = seqList lbls lbls
-  where -- Find order in which procedures will be generated by the
-        -- back-end (that actually matters for DWARF generation).
-        --
-        -- Note that we might encounter blocks that are missing or only
-        -- consist of meta instructions -- we will declare them missing,
-        -- which will skip debug data generation without messing up the
-        -- block hierarchy.
-        lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats
-        getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs
-        getBlocks _other                         = []
-        allMeta (BasicBlock _ instrs) = all isMeta instrs
-
--- | Sets position and unwind table fields in the debug block tree according to
--- native generated code.
-cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]
-             -> [DebugBlock] -> [DebugBlock]
-cmmDebugLink labels unwindPts blocks = map link blocks
-  where blockPos :: LabelMap Int
-        blockPos = mapFromList $ flip zip [0..] labels
-        link block = block { dblPosition = mapLookup (dblLabel block) blockPos
-                           , dblBlocks   = map link (dblBlocks block)
-                           , dblUnwind   = fromMaybe mempty
-                                         $ mapLookup (dblLabel block) unwindPts
-                           }
-
--- | Converts debug blocks into a label map for easier lookups
-debugToMap :: [DebugBlock] -> LabelMap DebugBlock
-debugToMap = mapUnions . map go
-   where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b)
-
-{-
-Note [What is this unwinding business?]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Unwinding tables are a variety of debugging information used by debugging tools
-to reconstruct the execution history of a program at runtime. These tables
-consist of sets of "instructions", one set for every instruction in the program,
-which describe how to reconstruct the state of the machine at the point where
-the current procedure was called. For instance, consider the following annotated
-pseudo-code,
-
-  a_fun:
-    add rsp, 8            -- unwind: rsp = rsp - 8
-    mov rax, 1            -- unwind: rax = unknown
-    call another_block
-    sub rsp, 8            -- unwind: rsp = rsp
-
-We see that attached to each instruction there is an "unwind" annotation, which
-provides a relationship between each updated register and its value at the
-time of entry to a_fun. This is the sort of information that allows gdb to give
-you a stack backtrace given the execution state of your program. This
-unwinding information is captured in various ways by various debug information
-formats; in the case of DWARF (the only format supported by GHC) it is known as
-Call Frame Information (CFI) and can be found in the .debug.frames section of
-your object files.
-
-Currently we only bother to produce unwinding information for registers which
-are necessary to reconstruct flow-of-execution. On x86_64 this includes $rbp
-(which is the STG stack pointer) and $rsp (the C stack pointer).
-
-Let's consider how GHC would annotate a C-- program with unwinding information
-with a typical C-- procedure as would come from the STG-to-Cmm code generator,
-
-  entry()
-     { c2fe:
-           v :: P64 = R2;
-           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;
-       c2ff:
-           R2 = v :: P64;
-           R1 = test_closure;
-           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
-       c2fg:
-           I64[Sp - 8] = c2dD;
-           R1 = v :: P64;
-           Sp = Sp - 8;          // Sp updated here
-           if (R1 & 7 != 0) goto c2dD; else goto c2dE;
-       c2dE:
-           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;
-       c2dD:
-           w :: P64 = R1;
-           Hp = Hp + 48;
-           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;
-       ...
-  },
-
-Let's consider how this procedure will be decorated with unwind information
-(largely by GHC.Cmm.LayoutStack). Naturally, when we enter the procedure `entry` the
-value of Sp is no different from what it was at its call site. Therefore we will
-add an `unwind` statement saying this at the beginning of its unwind-annotated
-code,
-
-  entry()
-     { c2fe:
-           unwind Sp = Just Sp + 0;
-           v :: P64 = R2;
-           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;
-
-After c2fe we may pass to either c2ff or c2fg; let's first consider the
-former. In this case there is nothing in particular that we need to do other
-than reiterate what we already know about Sp,
-
-       c2ff:
-           unwind Sp = Just Sp + 0;
-           R2 = v :: P64;
-           R1 = test_closure;
-           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
-
-In contrast, c2fg updates Sp midway through its body. To ensure that unwinding
-can happen correctly after this point we must include an unwind statement there,
-in addition to the usual beginning-of-block statement,
-
-       c2fg:
-           unwind Sp = Just Sp + 0;
-           I64[Sp - 8] = c2dD;
-           R1 = v :: P64;
-           Sp = Sp - 8;
-           unwind Sp = Just Sp + 8;
-           if (R1 & 7 != 0) goto c2dD; else goto c2dE;
-
-The remaining blocks are simple,
-
-       c2dE:
-           unwind Sp = Just Sp + 8;
-           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;
-       c2dD:
-           unwind Sp = Just Sp + 8;
-           w :: P64 = R1;
-           Hp = Hp + 48;
-           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;
-       ...
-  },
-
-
-The flow of unwinding information through the compiler is a bit convoluted:
-
- * C-- begins life in StgToCmm without any unwind information. This is because we
-   haven't actually done any register assignment or stack layout yet, so there
-   is no need for unwind information.
-
- * GHC.Cmm.LayoutStack figures out how to layout each procedure's stack, and produces
-   appropriate unwinding nodes for each adjustment of the STG Sp register.
-
- * The unwind nodes are carried through the sinking pass. Currently this is
-   guaranteed not to invalidate unwind information since it won't touch stores
-   to Sp, but this will need revisiting if CmmSink gets smarter in the future.
-
- * Eventually we make it to the native code generator backend which can then
-   preserve the unwind nodes in its machine-specific instructions. In so doing
-   the backend can also modify or add unwinding information; this is necessary,
-   for instance, in the case of x86-64, where adjustment of $rsp may be
-   necessary during calls to native foreign code due to the native calling
-   convention.
-
- * The NCG then retrieves the final unwinding table for each block from the
-   backend with extractUnwindPoints.
-
- * This unwind information is converted to DebugBlocks by Debug.cmmDebugGen
-
- * These DebugBlocks are then converted to, e.g., DWARF unwinding tables
-   (by the Dwarf module) and emitted in the final object.
-
-See also:
-  Note [Unwinding information in the NCG] in "GHC.CmmToAsm",
-  Note [Unwind pseudo-instruction in Cmm],
-  Note [Debugging DWARF unwinding info].
-
-
-Note [Debugging DWARF unwinding info]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-For debugging generated unwinding info I've found it most useful to dump the
-disassembled binary with objdump -D and dump the debug info with
-readelf --debug-dump=frames-interp.
-
-You should get something like this:
-
-  0000000000000010 <stg_catch_frame_info>:
-    10:   48 83 c5 18             add    $0x18,%rbp
-    14:   ff 65 00                jmpq   *0x0(%rbp)
-
-and:
-
-  Contents of the .debug_frame section:
-
-  00000000 0000000000000014 ffffffff CIE "" cf=1 df=-8 ra=16
-     LOC           CFA      rbp   rsp   ra
-  0000000000000000 rbp+0    v+0   s     c+0
-
-  00000018 0000000000000024 00000000 FDE cie=00000000 pc=000000000000000f..0000000000000017
-     LOC           CFA      rbp   rsp   ra
-  000000000000000f rbp+0    v+0   s     c+0
-  000000000000000f rbp+24   v+0   s     c+0
-
-To read it http://www.dwarfstd.org/doc/dwarf-2.0.0.pdf has a nice example in
-Appendix 5 (page 101 of the pdf) and more details in the relevant section.
-
-The key thing to keep in mind is that the value at LOC is the value from
-*before* the instruction at LOC executes. In other words it answers the
-question: if my $rip is at LOC, how do I get the relevant values given the
-values obtained through unwinding so far.
-
-If the readelf --debug-dump=frames-interp output looks wrong, it may also be
-useful to look at readelf --debug-dump=frames, which is closer to the
-information that GHC generated.
-
-It's also useful to dump the relevant Cmm with -ddump-cmm -ddump-opt-cmm
--ddump-cmm-proc -ddump-cmm-verbose. Note [Unwind pseudo-instruction in Cmm]
-explains how to interpret it.
-
-Inside gdb there are a couple useful commands for inspecting frames.
-For example:
-
-  gdb> info frame <num>
-
-It shows the values of registers obtained through unwinding.
-
-Another useful thing to try when debugging the DWARF unwinding is to enable
-extra debugging output in GDB:
-
-  gdb> set debug frame 1
-
-This makes GDB produce a trace of its internal workings. Having gone this far,
-it's just a tiny step to run GDB in GDB. Make sure you install debugging
-symbols for gdb if you obtain it through a package manager.
-
-Keep in mind that the current release of GDB has an instruction pointer handling
-heuristic that works well for C-like languages, but doesn't always work for
-Haskell. See Note [Info Offset] in "GHC.CmmToAsm.Dwarf.Types" for more details.
-
-Note [Unwind pseudo-instruction in Cmm]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-One of the possible CmmNodes is a CmmUnwind pseudo-instruction. It doesn't
-generate any assembly, but controls what DWARF unwinding information gets
-generated.
-
-It's important to understand what ranges of code the unwind pseudo-instruction
-refers to.
-For a sequence of CmmNodes like:
-
-  A // starts at addr X and ends at addr Y-1
-  unwind Sp = Just Sp + 16;
-  B // starts at addr Y and ends at addr Z
-
-the unwind statement reflects the state after A has executed, but before B
-has executed. If you consult the Note [Debugging DWARF unwinding info], the
-LOC this information will end up in is Y.
--}
-
--- | A label associated with an 'UnwindTable'
-data UnwindPoint = UnwindPoint !CLabel !UnwindTable
-
-instance OutputableP Platform UnwindPoint where
-  pdoc env (UnwindPoint lbl uws) =
-      braces $ pprAsmLabel env lbl <> colon
-      <+> hsep (punctuate comma $ map pprUw $ Map.toList uws)
-    where
-      pprUw (g, expr) = ppr g <> char '=' <> pdoc env expr
-
--- | Maps registers to expressions that yield their "old" values
--- further up the stack. Most interesting for the stack pointer @Sp@,
--- but might be useful to document saved registers, too. Note that a
--- register's value will be 'Nothing' when the register's previous
--- value cannot be reconstructed.
-type UnwindTable = Map.Map GlobalReg (Maybe UnwindExpr)
-
--- | Expressions, used for unwind information
-data UnwindExpr = UwConst !Int                  -- ^ literal value
-                | UwReg !GlobalReg !Int         -- ^ register plus offset
-                | UwDeref UnwindExpr            -- ^ pointer dereferencing
-                | UwLabel CLabel
-                | UwPlus UnwindExpr UnwindExpr
-                | UwMinus UnwindExpr UnwindExpr
-                | UwTimes UnwindExpr UnwindExpr
-                deriving (Eq)
-
-instance OutputableP Platform UnwindExpr where
-  pdoc = pprUnwindExpr 0
-
-pprUnwindTable :: IsLine doc => Platform -> UnwindTable -> doc
-pprUnwindTable platform u = brackets (fsep (punctuate comma (map print_entry (Map.toList u))))
-  where print_entry (reg, Nothing) =
-          parens (sep [pprGlobalReg reg, text "Nothing"])
-        print_entry (reg, Just x)  =
-          parens (sep [pprGlobalReg reg, text "Just" <+> pprUnwindExpr 0 platform x])
-  -- Follow instance Outputable (Map.Map GlobalReg (Maybe UnwindExpr))
-
-pprUnwindExpr :: IsLine doc => Rational -> Platform -> UnwindExpr -> doc
-pprUnwindExpr p env = \case
-  UwConst i     -> int i
-  UwReg g 0     -> pprGlobalReg g
-  UwReg g x     -> pprUnwindExpr p env (UwPlus (UwReg g 0) (UwConst x))
-  UwDeref e     -> char '*' <> pprUnwindExpr 3 env e
-  UwLabel l     -> pprAsmLabel env l
-  UwPlus e0 e1
-   | p <= 0     -> pprUnwindExpr 0 env e0 <> char '+' <> pprUnwindExpr 0 env e1
-  UwMinus e0 e1
-   | p <= 0     -> pprUnwindExpr 1 env e0 <> char '-' <> pprUnwindExpr 1 env e1
-  UwTimes e0 e1
-   | p <= 1     -> pprUnwindExpr 2 env e0 <> char '*' <> pprUnwindExpr 2 env e1
-  other         -> parens (pprUnwindExpr 0 env other)
-{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> SDoc #-}
-{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Conversion of Cmm expressions to unwind expressions. We check for
--- unsupported operator usages and simplify the expression as far as
--- possible.
-toUnwindExpr :: Platform -> CmmExpr -> UnwindExpr
-toUnwindExpr _ (CmmLit (CmmInt i _))       = UwConst (fromIntegral i)
-toUnwindExpr _ (CmmLit (CmmLabel l))       = UwLabel l
-toUnwindExpr _ (CmmRegOff (CmmGlobal g) i) = UwReg g i
-toUnwindExpr _ (CmmReg (CmmGlobal g))      = UwReg g 0
-toUnwindExpr platform (CmmLoad e _ _)             = UwDeref (toUnwindExpr platform e)
-toUnwindExpr platform e@(CmmMachOp op [e1, e2])   =
-  case (op, toUnwindExpr platform e1, toUnwindExpr platform e2) of
-    (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)
-    (MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y)
-    (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y)
-    (MO_Add{}, UwConst x, UwConst y) -> UwConst (x + y)
-    (MO_Sub{}, UwConst x, UwConst y) -> UwConst (x - y)
-    (MO_Mul{}, UwConst x, UwConst y) -> UwConst (x * y)
-    (MO_Add{}, u1,        u2       ) -> UwPlus u1 u2
-    (MO_Sub{}, u1,        u2       ) -> UwMinus u1 u2
-    (MO_Mul{}, u1,        u2       ) -> UwTimes u1 u2
-    _otherwise -> pprPanic "Unsupported operator in unwind expression!"
-                           (pdoc platform e)
-toUnwindExpr platform e
-  = pprPanic "Unsupported unwind expression!" (pdoc platform e)
diff --git a/compiler/GHC/Cmm/Dominators.hs b/compiler/GHC/Cmm/Dominators.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Dominators.hs
+++ /dev/null
@@ -1,213 +0,0 @@
-{-# LANGUAGE GADTs #-}
-
-module GHC.Cmm.Dominators
-  (
-  -- * Dominator analysis and representation of results
-    DominatorSet(..)
-  , GraphWithDominators(..)
-  , RPNum
-  , graphWithDominators
-
-  -- * Utility functions on graphs or graphs-with-dominators
-  , graphMap
-  , gwdRPNumber
-  , gwdDominatorsOf
-  , gwdDominatorTree
-
-  -- * Utility functions on dominator sets
-  , dominatorsMember
-  , intersectDominators
-  )
-where
-
-import GHC.Prelude
-
-import Data.Array.IArray
-import Data.Foldable()
-import qualified Data.Tree as Tree
-
-import qualified Data.IntMap.Strict as IM
-import qualified Data.IntSet as IS
-
-import qualified GHC.CmmToAsm.CFG.Dominators as LT
-
-import GHC.Cmm.Dataflow
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm
-
-import GHC.Utils.Outputable( Outputable(..), text, int, hcat, (<+>))
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-
-
--- | =Dominator sets
---
--- Node X dominates node Y if and only if every path from the entry to
--- Y includes X.  Node Y technically dominates itself, but it is
--- never included in the *representation* of its dominator set.
---
--- A dominator set is represented as a linked list in which each node
--- points to its *immediate* dominator, which is its parent in the
--- dominator tree.  In many circumstances the immediate dominator
--- will be the only dominator of interest.
-
-data DominatorSet = ImmediateDominator { ds_label  :: Label -- ^ Label of the immediate dominator.
-                                       , ds_parent :: DominatorSet -- ^ Set of nodes dominating the immediate dominator.
-                                       }
-                  | EntryNode
-  deriving (Eq)
-
-instance Outputable DominatorSet where
-  ppr EntryNode = text "entry"
-  ppr (ImmediateDominator l parent) = ppr l <+> text "->" <+> ppr parent
-
-
-
--- | Reverse postorder number of a node in a CFG
-newtype RPNum = RPNum Int
-  deriving (Eq, Ord)
--- in reverse postorder, nodes closer to the entry have smaller numbers
-
-instance Show RPNum where
-  show (RPNum i) = "RP" ++ show i
-
-instance Outputable RPNum where
-  ppr (RPNum i) = hcat [text "RP", int i]
-   -- using `(<>)` would conflict with Semigroup
-
-
-
-dominatorsMember :: Label -> DominatorSet -> Bool
--- ^ Use to tell if the given label is in the given
--- dominator set.  Which is to say, does the bloc
--- with with given label _properly_ and _non-vacuously_
--- dominate the node whose dominator set this is?
---
--- Takes linear time in the height of the dominator tree,
--- but uses space efficiently.
-dominatorsMember lbl (ImmediateDominator l p) = l == lbl || dominatorsMember lbl p
-dominatorsMember _   EntryNode = False
-
-
--- | Intersect two dominator sets to produce a third dominator set.
--- This function takes time linear in the size of the sets.
--- As such it is inefficient and should be used only for things
--- like visualizations or linters.
-intersectDominators :: DominatorSet -> DominatorSet -> DominatorSet
-intersectDominators ds ds' = commonPrefix (revDoms ds []) (revDoms ds' []) EntryNode
-  where revDoms EntryNode prev = prev
-        revDoms (ImmediateDominator lbl doms) prev = revDoms doms (lbl:prev)
-        commonPrefix (a:as) (b:bs) doms
-            | a == b = commonPrefix as bs (ImmediateDominator a doms)
-        commonPrefix _ _ doms = doms
-
-
--- | The result of dominator analysis.  Also includes a reverse
--- postorder numbering, which is needed for dominator analysis
--- and for other (downstream) analyses.
---
--- Invariant: Dominators, graph, and RP numberings include only *reachable* blocks.
-data GraphWithDominators node =
-    GraphWithDominators { gwd_graph :: GenCmmGraph node
-                        , gwd_dominators :: LabelMap DominatorSet
-                        , gwd_rpnumbering :: LabelMap RPNum
-                        }
-
-
--- | Call this function with a `CmmGraph` to get back the results of a
--- dominator analysis of that graph (as well as a reverse postorder
--- numbering).  The result also includes the subgraph of the original
--- graph that contains only the reachable blocks.
-graphWithDominators :: forall node .
-       (NonLocal node, HasDebugCallStack)
-       => GenCmmGraph node
-       -> GraphWithDominators node
-
--- The implementation uses the Lengauer-Tarjan algorithm from the x86
--- back end.
-
-graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap
-      where rpblocks = revPostorderFrom (graphMap g) (g_entry g)
-            rplabels' = map entryLabel rpblocks
-            rplabels :: Array Int Label
-            rplabels = listArray bounds rplabels'
-
-            rpmap :: LabelMap RPNum
-            rpmap = mapFromList $ zipWith kvpair rpblocks [0..]
-              where kvpair block i = (entryLabel block, RPNum i)
-
-            labelIndex :: Label -> Int
-            labelIndex = flip findLabelIn imap
-              where imap :: LabelMap Int
-                    imap = mapFromList $ zip rplabels' [0..]
-            blockIndex = labelIndex . entryLabel
-
-            bounds = (0, length rpblocks - 1)
-
-            ltGraph :: [Block node C C] -> LT.Graph
-            ltGraph [] = IM.empty
-            ltGraph (block:blocks) =
-                IM.insert
-                      (blockIndex block)
-                      (IS.fromList $ map labelIndex $ successors block)
-                      (ltGraph blocks)
-
-            idom_array :: Array Int LT.Node
-            idom_array = array bounds $ LT.idom (0, ltGraph rpblocks)
-
-            domSet 0 = EntryNode
-            domSet i = ImmediateDominator (rplabels ! d) (doms ! d)
-                where d = idom_array ! i
-            doms = tabulate bounds domSet
-
-            dmap = mapFromList $ zipWith (\lbl i -> (lbl, domSet i)) rplabels' [0..]
-
-reachable :: NonLocal node => [Block node C C] -> GenCmmGraph node -> GenCmmGraph node
-reachable blocks g = g { g_graph = GMany NothingO blockmap NothingO }
-  where blockmap = mapFromList [(entryLabel b, b) | b <- blocks]
-
-
--- | =Utility functions
-
--- | Call `graphMap` to get the mapping from `Label` to `Block` that
--- is embedded in every `CmmGraph`.
-graphMap :: GenCmmGraph n -> LabelMap (Block n C C)
-graphMap (CmmGraph { g_graph = GMany NothingO blockmap NothingO }) = blockmap
-
--- | Use `gwdRPNumber` on the result of the dominator analysis to get
--- a mapping from the `Label` of each reachable block to the reverse
--- postorder number of that block.
-gwdRPNumber :: HasDebugCallStack => GraphWithDominators node -> Label -> RPNum
-gwdRPNumber g l = findLabelIn l (gwd_rpnumbering g)
-
-findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a
-findLabelIn lbl = mapFindWithDefault failed lbl
-  where failed =
-            pprPanic "label not found in result of analysis" (ppr lbl)
-
--- | Use `gwdDominatorsOf` on the result of the dominator analysis to get
--- a mapping from the `Label` of each reachable block to the dominator
--- set (and the immediate dominator) of that block.  The
--- implementation is space-efficient: intersecting dominator
--- sets share the representation of their intersection.
-
-gwdDominatorsOf :: HasDebugCallStack => GraphWithDominators node -> Label -> DominatorSet
-gwdDominatorsOf g lbl = findLabelIn lbl (gwd_dominators g)
-
-gwdDominatorTree :: GraphWithDominators node -> Tree.Tree Label
-gwdDominatorTree gwd = subtreeAt (g_entry (gwd_graph gwd))
-  where subtreeAt label = Tree.Node label $ map subtreeAt $ children label
-        children l = mapFindWithDefault [] l child_map
-        child_map :: LabelMap [Label]
-        child_map = mapFoldlWithKey addParent mapEmpty $ gwd_dominators gwd
-          where addParent cm _ EntryNode = cm
-                addParent cm lbl (ImmediateDominator p _) =
-                    mapInsertWith (++) p [lbl] cm
-
-
--- | Turn a function into an array.  Inspired by SML's `Array.tabulate`
-tabulate :: (Ix i) => (i, i) -> (i -> e) -> Array i e
-tabulate b f = listArray b $ map f $ range b
diff --git a/compiler/GHC/Cmm/Graph.hs b/compiler/GHC/Cmm/Graph.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Graph.hs
+++ /dev/null
@@ -1,488 +0,0 @@
-{-# LANGUAGE BangPatterns, GADTs #-}
-
-module GHC.Cmm.Graph
-  ( CmmAGraph, CmmAGraphScoped, CgStmt(..)
-  , (<*>), catAGraphs
-  , mkLabel, mkMiddle, mkLast, outOfLine
-  , lgraphOfAGraph, labelAGraph
-
-  , stackStubExpr
-  , mkNop, mkAssign, mkStore
-  , mkUnsafeCall, mkFinalCall, mkCallReturnsTo
-  , mkJumpReturnsTo
-  , mkJump, mkJumpExtra
-  , mkRawJump
-  , mkCbranch, mkSwitch
-  , mkReturn, mkComment, mkCallEntry, mkBranch
-  , mkUnwind
-  , copyInOflow, copyOutOflow
-  , noExtraStack
-  , toCall, Transfer(..)
-  )
-where
-
-import GHC.Prelude hiding ( (<*>) ) -- avoid importing (<*>)
-
-import GHC.Platform.Profile
-
-import GHC.Cmm.BlockId
-import GHC.Cmm
-import GHC.Cmm.CallConv
-import GHC.Cmm.Switch (SwitchTargets)
-
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
-import GHC.Data.FastString
-import GHC.Types.ForeignCall
-import GHC.Data.OrdList
-import GHC.Runtime.Heap.Layout (ByteOff)
-import GHC.Types.Unique.Supply
-import GHC.Utils.Panic
-import GHC.Utils.Constants (debugIsOn)
-
-
------------------------------------------------------------------------------
--- Building Graphs
-
-
--- | CmmAGraph is a chunk of code consisting of:
---
---   * ordinary statements (assignments, stores etc.)
---   * jumps
---   * labels
---   * out-of-line labelled blocks
---
--- The semantics is that control falls through labels and out-of-line
--- blocks.  Everything after a jump up to the next label is by
--- definition unreachable code, and will be discarded.
---
--- Two CmmAGraphs can be stuck together with <*>, with the meaning that
--- control flows from the first to the second.
---
--- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends)
--- by providing a label for the entry point and a tick scope; see
--- 'labelAGraph'.
-type CmmAGraph = OrdList CgStmt
--- | Unlabeled graph with tick scope
-type CmmAGraphScoped = (CmmAGraph, CmmTickScope)
-
-data CgStmt
-  = CgLabel BlockId CmmTickScope
-  | CgStmt  (CmmNode O O)
-  | CgLast  (CmmNode O C)
-  | CgFork  BlockId CmmAGraph CmmTickScope
-
-flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
-flattenCmmAGraph id (stmts_t, tscope) =
-    CmmGraph { g_entry = id,
-               g_graph = GMany NothingO body NothingO }
-  where
-  body = foldr addBlock emptyBody $ flatten id stmts_t tscope []
-
-  --
-  -- flatten: given an entry label and a CmmAGraph, make a list of blocks.
-  --
-  -- NB. avoid the quadratic-append trap by passing in the tail of the
-  -- list.  This is important for Very Long Functions (e.g. in T783).
-  --
-  flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C]
-          -> [Block CmmNode C C]
-  flatten id g tscope blocks
-      = flatten1 (fromOL g) block' blocks
-      where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock
-  --
-  -- flatten0: we are outside a block at this point: any code before
-  -- the first label is unreachable, so just drop it.
-  --
-  flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
-  flatten0 [] blocks = blocks
-
-  flatten0 (CgLabel id tscope : stmts) blocks
-    = flatten1 stmts block blocks
-    where !block = blockJoinHead (CmmEntry id tscope) emptyBlock
-
-  flatten0 (CgFork fork_id stmts_t tscope : rest) blocks
-    = flatten fork_id stmts_t tscope $ flatten0 rest blocks
-
-  flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks
-  flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks
-
-  --
-  -- flatten1: we have a partial block, collect statements until the
-  -- next last node to make a block, then call flatten0 to get the rest
-  -- of the blocks
-  --
-  flatten1 :: [CgStmt] -> Block CmmNode C O
-           -> [Block CmmNode C C] -> [Block CmmNode C C]
-
-  -- The current block falls through to the end of a function or fork:
-  -- this code should not be reachable, but it may be referenced by
-  -- other code that is not reachable.  We'll remove it later with
-  -- dead-code analysis, but for now we have to keep the graph
-  -- well-formed, so we terminate the block with a branch to the
-  -- beginning of the current block.
-  flatten1 [] block blocks
-    = blockJoinTail block (CmmBranch (entryLabel block)) : blocks
-
-  flatten1 (CgLast stmt : stmts) block blocks
-    = block' : flatten0 stmts blocks
-    where !block' = blockJoinTail block stmt
-
-  flatten1 (CgStmt stmt : stmts) block blocks
-    = flatten1 stmts block' blocks
-    where !block' = blockSnoc block stmt
-
-  flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks
-    = flatten fork_id stmts_t tscope $ flatten1 rest block blocks
-
-  -- a label here means that we should start a new block, and the
-  -- current block should fall through to the new block.
-  flatten1 (CgLabel id tscp : stmts) block blocks
-    = blockJoinTail block (CmmBranch id) :
-      flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks
-
-
-
----------- AGraph manipulation
-
-(<*>)          :: CmmAGraph -> CmmAGraph -> CmmAGraph
-(<*>)           = appOL
-
-catAGraphs     :: [CmmAGraph] -> CmmAGraph
-catAGraphs      = concatOL
-
--- | creates a sequence "goto id; id:" as an AGraph
-mkLabel        :: BlockId -> CmmTickScope -> CmmAGraph
-mkLabel bid scp = unitOL (CgLabel bid scp)
-
--- | creates an open AGraph from a given node
-mkMiddle        :: CmmNode O O -> CmmAGraph
-mkMiddle middle = unitOL (CgStmt middle)
-
--- | creates a closed AGraph from a given node
-mkLast         :: CmmNode O C -> CmmAGraph
-mkLast last     = unitOL (CgLast last)
-
--- | A labelled code block; should end in a last node
-outOfLine      :: BlockId -> CmmAGraphScoped -> CmmAGraph
-outOfLine l (c,s) = unitOL (CgFork l c s)
-
--- | allocate a fresh label for the entry point
-lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph
-lgraphOfAGraph g = do
-  u <- getUniqueM
-  return (labelAGraph (mkBlockId u) g)
-
--- | use the given BlockId as the label of the entry point
-labelAGraph    :: BlockId -> CmmAGraphScoped -> CmmGraph
-labelAGraph lbl ag = flattenCmmAGraph lbl ag
-
----------- No-ops
-mkNop        :: CmmAGraph
-mkNop         = nilOL
-
-mkComment    :: FastString -> CmmAGraph
-mkComment fs
-  -- SDM: generating all those comments takes time, this saved about 4% for me
-  | debugIsOn = mkMiddle $ CmmComment fs
-  | otherwise = nilOL
-
----------- Assignment and store
-mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
-mkAssign l (CmmReg r) | l == r  = mkNop
-mkAssign l r  = mkMiddle $ CmmAssign l r
-
--- | Assumes natural alignment
-mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
-mkStore  l r  = mkMiddle $ CmmStore  l r NaturallyAligned
-
----------- Control transfer
-mkJump          :: Profile -> Convention -> CmmExpr
-                -> [CmmExpr]
-                -> UpdFrameOffset
-                -> CmmAGraph
-mkJump profile conv e actuals updfr_off =
-  lastWithArgs profile Jump Old conv actuals updfr_off $
-    toCall e Nothing updfr_off 0
-
--- | A jump where the caller says what the live GlobalRegs are.  Used
--- for low-level hand-written Cmm.
-mkRawJump       :: Profile -> CmmExpr -> UpdFrameOffset -> [GlobalReg]
-                -> CmmAGraph
-mkRawJump profile e updfr_off vols =
-  lastWithArgs profile Jump Old NativeNodeCall [] updfr_off $
-    \arg_space _  -> toCall e Nothing updfr_off 0 arg_space vols
-
-
-mkJumpExtra :: Profile -> Convention -> CmmExpr -> [CmmExpr]
-                -> UpdFrameOffset -> [CmmExpr]
-                -> CmmAGraph
-mkJumpExtra profile conv e actuals updfr_off extra_stack =
-  lastWithArgsAndExtraStack profile Jump Old conv actuals updfr_off extra_stack $
-    toCall e Nothing updfr_off 0
-
-mkCbranch       :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
-mkCbranch pred ifso ifnot likely =
-  mkLast (CmmCondBranch pred ifso ifnot likely)
-
-mkSwitch        :: CmmExpr -> SwitchTargets -> CmmAGraph
-mkSwitch e tbl   = mkLast $ CmmSwitch e tbl
-
-mkReturn        :: Profile -> CmmExpr -> [CmmExpr] -> UpdFrameOffset
-                -> CmmAGraph
-mkReturn profile e actuals updfr_off =
-  lastWithArgs profile Ret  Old NativeReturn actuals updfr_off $
-    toCall e Nothing updfr_off 0
-
-mkBranch        :: BlockId -> CmmAGraph
-mkBranch bid     = mkLast (CmmBranch bid)
-
-mkFinalCall   :: Profile
-              -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset
-              -> CmmAGraph
-mkFinalCall profile f _ actuals updfr_off =
-  lastWithArgs profile Call Old NativeDirectCall actuals updfr_off $
-    toCall f Nothing updfr_off 0
-
-mkCallReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]
-                -> BlockId
-                -> ByteOff
-                -> UpdFrameOffset
-                -> [CmmExpr]
-                -> CmmAGraph
-mkCallReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off extra_stack =
-  lastWithArgsAndExtraStack profile Call (Young ret_lbl) callConv actuals
-    updfr_off extra_stack $
-      toCall f (Just ret_lbl) updfr_off ret_off
-
--- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
--- already on the stack).
-mkJumpReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]
-                -> BlockId
-                -> ByteOff
-                -> UpdFrameOffset
-                -> CmmAGraph
-mkJumpReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off =
-  lastWithArgs profile JumpRet (Young ret_lbl) callConv actuals updfr_off $
-    toCall f (Just ret_lbl) updfr_off ret_off
-
-mkUnsafeCall  :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
-mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
-
--- | Construct a 'CmmUnwind' node for the given register and unwinding
--- expression.
-mkUnwind     :: GlobalReg -> CmmExpr -> CmmAGraph
-mkUnwind r e  = mkMiddle $ CmmUnwind [(r, Just e)]
-
---------------------------------------------------------------------------
-
-
-
-
--- Why are we inserting extra blocks that simply branch to the successors?
--- Because in addition to the branch instruction, @mkBranch@ will insert
--- a necessary adjustment to the stack pointer.
-
-
--- For debugging purposes, we can stub out dead stack slots:
-stackStubExpr :: Width -> CmmExpr
-stackStubExpr w = CmmLit (CmmInt 0 w)
-
--- When we copy in parameters, we usually want to put overflow
--- parameters on the stack, but sometimes we want to pass the
--- variables in their spill slots.  Therefore, for copying arguments
--- and results, we provide different functions to pass the arguments
--- in an overflow area and to pass them in spill slots.
-copyInOflow  :: Profile -> Convention -> Area
-             -> [CmmFormal]
-             -> [CmmFormal]
-             -> (Int, [GlobalReg], CmmAGraph)
-
-copyInOflow profile conv area formals extra_stk
-  = (offset, gregs, catAGraphs $ map mkMiddle nodes)
-  where (offset, gregs, nodes) = copyIn profile conv area formals extra_stk
-
--- Return the number of bytes used for copying arguments, as well as the
--- instructions to copy the arguments.
-copyIn :: Profile -> Convention -> Area
-       -> [CmmFormal]
-       -> [CmmFormal]
-       -> (ByteOff, [GlobalReg], [CmmNode O O])
-copyIn profile conv area formals extra_stk
-  = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
-  where
-    platform = profilePlatform profile
-    -- See Note [Width of parameters]
-    ci (reg, RegisterParam r@(VanillaReg {})) =
-        let local = CmmLocal reg
-            global = CmmReg (CmmGlobal r)
-            width = cmmRegWidth platform local
-            expr
-                | width == wordWidth platform = global
-                | width < wordWidth platform =
-                    CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global]
-                | otherwise = panic "Parameter width greater than word width"
-
-        in CmmAssign local expr
-
-    -- Non VanillaRegs
-    ci (reg, RegisterParam r) =
-        CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))
-
-    ci (reg, StackParam off)
-      | isBitsType $ localRegType reg
-      , typeWidth (localRegType reg) < wordWidth platform =
-        let
-          stack_slot = CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform) NaturallyAligned
-          local = CmmLocal reg
-          width = cmmRegWidth platform local
-          expr  = CmmMachOp (MO_XX_Conv (wordWidth platform) width) [stack_slot]
-        in CmmAssign local expr
-
-      | otherwise =
-         CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty NaturallyAligned)
-         where ty = localRegType reg
-
-    init_offset = widthInBytes (wordWidth platform) -- infotable
-
-    (stk_off, stk_args) = assignStack platform init_offset localRegType extra_stk
-
-    (stk_size, args) = assignArgumentsPos profile stk_off conv
-                                          localRegType formals
-
--- Factoring out the common parts of the copyout functions yielded something
--- more complicated:
-
-data Transfer = Call | JumpRet | Jump | Ret deriving Eq
-
-copyOutOflow :: Profile -> Convention -> Transfer -> Area -> [CmmExpr]
-             -> UpdFrameOffset
-             -> [CmmExpr] -- extra stack args
-             -> (Int, [GlobalReg], CmmAGraph)
-
--- Generate code to move the actual parameters into the locations
--- required by the calling convention.  This includes a store for the
--- return address.
---
--- The argument layout function ignores the pointer to the info table,
--- so we slot that in here. When copying-out to a young area, we set
--- the info table for return and adjust the offsets of the other
--- parameters.  If this is a call instruction, we adjust the offsets
--- of the other parameters.
-copyOutOflow profile conv transfer area actuals updfr_off extra_stack_stuff
-  = (stk_size, regs, graph)
-  where
-    platform = profilePlatform profile
-    (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
-
-    -- See Note [Width of parameters]
-    co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =
-        let width = cmmExprWidth platform v
-            value
-                | width == wordWidth platform = v
-                | width < wordWidth platform =
-                    CmmMachOp (MO_XX_Conv width (wordWidth platform)) [v]
-                | otherwise = panic "Parameter width greater than word width"
-
-        in (r:rs, mkAssign (CmmGlobal r) value <*> ms)
-
-    -- Non VanillaRegs
-    co (v, RegisterParam r) (rs, ms) =
-        (r:rs, mkAssign (CmmGlobal r) v <*> ms)
-
-    -- See Note [Width of parameters]
-    co (v, StackParam off)  (rs, ms)
-      = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms)
-
-    width v = cmmExprWidth platform v
-    value v
-      | isBitsType $ cmmExprType platform v
-      , width v < wordWidth platform =
-        CmmMachOp (MO_XX_Conv (width v) (wordWidth platform)) [v]
-      | otherwise = v
-
-    (setRA, init_offset) =
-      case area of
-            Young id ->  -- Generate a store instruction for
-                         -- the return address if making a call
-                  case transfer of
-                     Call ->
-                       ([(CmmLit (CmmBlock id), StackParam init_offset)],
-                       widthInBytes (wordWidth platform))
-                     JumpRet ->
-                       ([],
-                       widthInBytes (wordWidth platform))
-                     _other ->
-                       ([], 0)
-            Old -> ([], updfr_off)
-
-    (extra_stack_off, stack_params) =
-       assignStack platform init_offset (cmmExprType platform) extra_stack_stuff
-
-    args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it
-    (stk_size, args) = assignArgumentsPos profile extra_stack_off conv
-                                          (cmmExprType platform) actuals
-
-
--- Note [Width of parameters]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Consider passing a small (< word width) primitive like Int8# to a function.
--- It's actually non-trivial to do this without extending/narrowing:
--- * Global registers are considered to have native word width (i.e., 64-bits on
---   x86-64), so CmmLint would complain if we assigned an 8-bit parameter to a
---   global register.
--- * Same problem exists with LLVM IR.
--- * Lowering gets harder since on x86-32 not every register exposes its lower
---   8 bits (e.g., for %eax we can use %al, but there isn't a corresponding
---   8-bit register for %edi). So we would either need to extend/narrow anyway,
---   or complicate the calling convention.
--- * Passing a small integer in a stack slot, which has native word width,
---   requires extending to word width when writing to the stack and narrowing
---   when reading off the stack (see #16258).
--- So instead, we always extend every parameter smaller than native word width
--- in copyOutOflow and then truncate it back to the expected width in copyIn.
--- Note that we do this in cmm using MO_XX_Conv to avoid requiring
--- zero-/sign-extending - it's up to a backend to handle this in a most
--- efficient way (e.g., a simple register move or a smaller size store).
--- This convention (of ignoring the upper bits) is different from some C ABIs,
--- e.g. all PowerPC ELF ABIs, that require sign or zero extending parameters.
---
--- There was some discussion about this on this PR:
--- https://github.com/ghc-proposals/ghc-proposals/pull/74
-
-
-mkCallEntry :: Profile -> Convention -> [CmmFormal] -> [CmmFormal]
-            -> (Int, [GlobalReg], CmmAGraph)
-mkCallEntry profile conv formals extra_stk
-  = copyInOflow profile conv Old formals extra_stk
-
-lastWithArgs :: Profile -> Transfer -> Area -> Convention -> [CmmExpr]
-             -> UpdFrameOffset
-             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
-             -> CmmAGraph
-lastWithArgs profile transfer area conv actuals updfr_off last =
-  lastWithArgsAndExtraStack profile transfer area conv actuals
-                            updfr_off noExtraStack last
-
-lastWithArgsAndExtraStack :: Profile
-             -> Transfer -> Area -> Convention -> [CmmExpr]
-             -> UpdFrameOffset -> [CmmExpr]
-             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
-             -> CmmAGraph
-lastWithArgsAndExtraStack profile transfer area conv actuals updfr_off
-                          extra_stack last =
-  copies <*> last outArgs regs
- where
-  (outArgs, regs, copies) = copyOutOflow profile conv transfer area actuals
-                               updfr_off extra_stack
-
-
-noExtraStack :: [CmmExpr]
-noExtraStack = []
-
-toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
-       -> ByteOff -> [GlobalReg]
-       -> CmmAGraph
-toCall e cont updfr_off res_space arg_space regs =
-  mkLast $ CmmCall e cont regs arg_space res_space updfr_off
diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Info.hs
+++ /dev/null
@@ -1,604 +0,0 @@
-
-module GHC.Cmm.Info (
-  mkEmptyContInfoTable,
-  cmmToRawCmm,
-  srtEscape,
-
-  -- info table accessors
-  closureInfoPtr,
-  entryCode,
-  getConstrTag,
-  cmmGetClosureType,
-  infoTable,
-  infoTableConstrTag,
-  infoTableSrtBitmap,
-  infoTableClosureType,
-  infoTablePtrs,
-  infoTableNonPtrs,
-  funInfoTable,
-  funInfoArity,
-
-  -- info table sizes and offsets
-  stdInfoTableSizeW,
-  fixedInfoTableSizeW,
-  profInfoTableSizeW,
-  maxStdInfoTableSizeW,
-  maxRetInfoTableSizeW,
-  stdInfoTableSizeB,
-  conInfoTableSizeB,
-  stdSrtBitmapOffset,
-  stdClosureTypeOffset,
-  stdPtrsOffset, stdNonPtrsOffset,
-) where
-
-import GHC.Prelude
-
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Cmm.CLabel
-import GHC.Runtime.Heap.Layout
-import GHC.Data.Bitmap
-import GHC.Data.Stream (Stream)
-import qualified GHC.Data.Stream as Stream
-import GHC.Cmm.Dataflow.Collections
-
-import GHC.Platform
-import GHC.Platform.Profile
-import GHC.Data.Maybe
-import GHC.Utils.Error (withTimingSilent)
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Types.Unique.Supply
-import GHC.Utils.Logger
-import GHC.Utils.Monad
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-
-import Data.ByteString (ByteString)
-
--- When we split at proc points, we need an empty info table.
-mkEmptyContInfoTable :: CLabel -> CmmInfoTable
-mkEmptyContInfoTable info_lbl
-  = CmmInfoTable { cit_lbl  = info_lbl
-                 , cit_rep  = mkStackRep []
-                 , cit_prof = NoProfilingInfo
-                 , cit_srt  = Nothing
-                 , cit_clo  = Nothing }
-
-cmmToRawCmm :: Logger -> Profile -> Stream IO CmmGroupSRTs a
-            -> IO (Stream IO RawCmmGroup a)
-cmmToRawCmm logger profile cmms
-  = do {
-       ; let do_one :: [CmmDeclSRTs] -> IO [RawCmmDecl]
-             do_one cmm = do
-               uniqs <- mkSplitUniqSupply 'i'
-               -- NB. strictness fixes a space leak.  DO NOT REMOVE.
-               withTimingSilent logger (text "Cmm -> Raw Cmm") (\x -> seqList x ())
-                  -- TODO: It might be better to make `mkInfoTable` run in
-                  -- IO as well so we don't have to pass around
-                  -- a UniqSupply (see #16843)
-                 (return $ initUs_ uniqs $ concatMapM (mkInfoTable profile) cmm)
-       ; return (Stream.mapM do_one cmms)
-       }
-
-
--- Make a concrete info table, represented as a list of CmmStatic
--- (it can't be simply a list of Word, because the SRT field is
--- represented by a label+offset expression).
---
--- With tablesNextToCode, the layout is
---      <reversed variable part>
---      <normal forward StgInfoTable, but without
---              an entry point at the front>
---      <code>
---
--- Without tablesNextToCode, the layout of an info table is
---      <entry label>
---      <normal forward rest of StgInfoTable>
---      <forward variable part>
---
---      See rts/include/rts/storage/InfoTables.h
---
--- For return-points these are as follows
---
--- Tables next to code:
---
---                      <srt slot>
---                      <standard info table>
---      ret-addr -->    <entry code (if any)>
---
--- Not tables-next-to-code:
---
---      ret-addr -->    <ptr to entry code>
---                      <standard info table>
---                      <srt slot>
---
---  * The SRT slot is only there if there is SRT info to record
-
-mkInfoTable :: Profile -> CmmDeclSRTs -> UniqSM [RawCmmDecl]
-mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat]
-
-mkInfoTable profile proc@(CmmProc infos entry_lbl live blocks)
-  --
-  -- in the non-tables-next-to-code case, procs can have at most a
-  -- single info table associated with the entry label of the proc.
-  --
-  | not (platformTablesNextToCode platform)
-  = case topInfoTable proc of   --  must be at most one
-      -- no info table
-      Nothing ->
-         return [CmmProc mapEmpty entry_lbl live blocks]
-
-      Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
-        (top_decls, (std_info, extra_bits)) <-
-             mkInfoTableContents profile info Nothing
-        let
-          rel_std_info   = map (makeRelativeRefTo platform info_lbl) std_info
-          rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits
-        --
-        -- Separately emit info table (with the function entry
-        -- point as first entry) and the entry code
-        --
-        return (top_decls ++
-                [CmmProc mapEmpty entry_lbl live blocks,
-                 mkRODataLits info_lbl
-                    (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
-
-  --
-  -- With tables-next-to-code, we can have many info tables,
-  -- associated with some of the BlockIds of the proc.  For each info
-  -- table we need to turn it into CmmStatics, and collect any new
-  -- CmmDecls that arise from doing so.
-  --
-  | otherwise
-  = do
-    (top_declss, raw_infos) <-
-       unzip `fmap` mapM do_one_info (mapToList (info_tbls infos))
-    return (concat top_declss ++
-            [CmmProc (mapFromList raw_infos) entry_lbl live blocks])
-
-  where
-   platform = profilePlatform profile
-   do_one_info (lbl,itbl) = do
-     (top_decls, (std_info, extra_bits)) <-
-         mkInfoTableContents profile itbl Nothing
-     let
-        info_lbl = cit_lbl itbl
-        rel_std_info   = map (makeRelativeRefTo platform info_lbl) std_info
-        rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits
-     --
-     return (top_decls, (lbl, CmmStaticsRaw info_lbl $ map CmmStaticLit $
-                              reverse rel_extra_bits ++ rel_std_info))
-
------------------------------------------------------
-type InfoTableContents = ( [CmmLit]          -- The standard part
-                         , [CmmLit] )        -- The "extra bits"
--- These Lits have *not* had mkRelativeTo applied to them
-
-mkInfoTableContents :: Profile
-                    -> CmmInfoTable
-                    -> Maybe Int               -- Override default RTS type tag?
-                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls
-                               InfoTableContents)       -- Info tbl + extra bits
-
-mkInfoTableContents profile
-                    info@(CmmInfoTable { cit_lbl  = info_lbl
-                                       , cit_rep  = smrep
-                                       , cit_prof = prof
-                                       , cit_srt = srt })
-                    mb_rts_tag
-  | RTSRep rts_tag rep <- smrep
-  = mkInfoTableContents profile info{cit_rep = rep} (Just rts_tag)
-    -- Completely override the rts_tag that mkInfoTableContents would
-    -- otherwise compute, with the rts_tag stored in the RTSRep
-    -- (which in turn came from a handwritten .cmm file)
-
-  | StackRep frame <- smrep
-  = do { (prof_lits, prof_data) <- mkProfLits platform prof
-       ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt
-       ; (liveness_lit, liveness_data) <- mkLivenessBits platform frame
-       ; let
-             std_info = mkStdInfoTable profile prof_lits rts_tag srt_bitmap liveness_lit
-             rts_tag | Just tag <- mb_rts_tag = tag
-                     | null liveness_data     = rET_SMALL -- Fits in extra_bits
-                     | otherwise              = rET_BIG   -- Does not; extra_bits is
-                                                          -- a label
-       ; return (prof_data ++ liveness_data, (std_info, srt_label)) }
-
-  | HeapRep _ ptrs nonptrs closure_type <- smrep
-  = do { let layout  = packIntsCLit platform ptrs nonptrs
-       ; (prof_lits, prof_data) <- mkProfLits platform prof
-       ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt
-       ; (mb_srt_field, mb_layout, extra_bits, ct_data)
-                                <- mk_pieces closure_type srt_label
-       ; let std_info = mkStdInfoTable profile prof_lits
-                                       (mb_rts_tag   `orElse` rtsClosureType smrep)
-                                       (mb_srt_field `orElse` srt_bitmap)
-                                       (mb_layout    `orElse` layout)
-       ; return (prof_data ++ ct_data, (std_info, extra_bits)) }
-  where
-    platform = profilePlatform profile
-    mk_pieces :: ClosureTypeInfo -> [CmmLit]
-              -> UniqSM ( Maybe CmmLit  -- Override the SRT field with this
-                        , Maybe CmmLit  -- Override the layout field with this
-                        , [CmmLit]           -- "Extra bits" for info table
-                        , [RawCmmDecl])      -- Auxiliary data decls
-    mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor
-      = do { (descr_lit, decl) <- newStringLit con_descr
-           ; return ( Just (CmmInt (fromIntegral con_tag)
-                                   (halfWordWidth platform))
-                    , Nothing, [descr_lit], [decl]) }
-
-    mk_pieces Thunk srt_label
-      = return (Nothing, Nothing, srt_label, [])
-
-    mk_pieces (ThunkSelector offset) _no_srt
-      = return (Just (CmmInt 0 (halfWordWidth platform)),
-                Just (mkWordCLit platform (fromIntegral offset)), [], [])
-         -- Layout known (one free var); we use the layout field for offset
-
-    mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
-      = do { let extra_bits = packIntsCLit platform fun_type arity : srt_label
-           ; return (Nothing, Nothing,  extra_bits, []) }
-
-    mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
-      = do { (liveness_lit, liveness_data) <- mkLivenessBits platform arg_bits
-           ; let fun_type | null liveness_data = aRG_GEN
-                          | otherwise          = aRG_GEN_BIG
-                 extra_bits = [ packIntsCLit platform fun_type arity ]
-                           ++ (if inlineSRT platform then [] else [ srt_lit ])
-                           ++ [ liveness_lit, slow_entry ]
-           ; return (Nothing, Nothing, extra_bits, liveness_data) }
-      where
-        slow_entry = CmmLabel (toSlowEntryLbl platform info_lbl)
-        srt_lit = case srt_label of
-                    []          -> mkIntCLit platform 0
-                    (lit:_rest) -> assert (null _rest) lit
-
-    mk_pieces other _ = pprPanic "mk_pieces" (ppr other)
-
-mkInfoTableContents _ _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier
-
-packIntsCLit :: Platform -> Int -> Int -> CmmLit
-packIntsCLit platform a b = packHalfWordsCLit platform
-                           (toStgHalfWord platform (fromIntegral a))
-                           (toStgHalfWord platform (fromIntegral b))
-
-
-mkSRTLit :: Platform
-         -> CLabel
-         -> Maybe CLabel
-         -> ([CmmLit],    -- srt_label, if any
-             CmmLit)      -- srt_bitmap
-mkSRTLit platform info_lbl (Just lbl)
-  | inlineSRT platform
-  = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth platform))
-mkSRTLit platform _ Nothing    = ([], CmmInt 0 (halfWordWidth platform))
-mkSRTLit platform _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth platform))
-
-
--- | Is the SRT offset field inline in the info table on this platform?
---
--- See the section "Referring to an SRT from the info table" in
--- Note [SRTs] in "GHC.Cmm.Info.Build"
-inlineSRT :: Platform -> Bool
-inlineSRT = pc_USE_INLINE_SRT_FIELD . platformConstants
-
--------------------------------------------------------------------------
---
---      Lay out the info table and handle relative offsets
---
--------------------------------------------------------------------------
-
--- This function takes
---   * the standard info table portion (StgInfoTable)
---   * the "extra bits" (StgFunInfoExtraRev etc.)
---   * the entry label
---   * the code
--- and lays them out in memory, producing a list of RawCmmDecl
-
--------------------------------------------------------------------------
---
---      Position independent code
---
--------------------------------------------------------------------------
--- In order to support position independent code, we mustn't put absolute
--- references into read-only space. Info tables in the tablesNextToCode
--- case must be in .text, which is read-only, so we doctor the CmmLits
--- to use relative offsets instead.
-
--- Note that this is done even when the -fPIC flag is not specified,
--- as we want to keep binary compatibility between PIC and non-PIC.
-
-makeRelativeRefTo :: Platform -> CLabel -> CmmLit -> CmmLit
-makeRelativeRefTo platform info_lbl lit
-  = if platformTablesNextToCode platform
-      then case lit of
-         CmmLabel lbl        -> CmmLabelDiffOff lbl info_lbl 0   (wordWidth platform)
-         CmmLabelOff lbl off -> CmmLabelDiffOff lbl info_lbl off (wordWidth platform)
-         _                   -> lit
-      else lit
-
--------------------------------------------------------------------------
---
---              Build a liveness mask for the stack layout
---
--------------------------------------------------------------------------
-
--- There are four kinds of things on the stack:
---
---      - pointer variables (bound in the environment)
---      - non-pointer variables (bound in the environment)
---      - free slots (recorded in the stack free list)
---      - non-pointer data slots (recorded in the stack free list)
---
--- The first two are represented with a 'Just' of a 'LocalReg'.
--- The last two with one or more 'Nothing' constructors.
--- Each 'Nothing' represents one used word.
---
--- The head of the stack layout is the top of the stack and
--- the least-significant bit.
-
-mkLivenessBits :: Platform -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
-              -- ^ Returns:
-              --   1. The bitmap (literal value or label)
-              --   2. Large bitmap CmmData if needed
-
-mkLivenessBits platform liveness
-  | n_bits > mAX_SMALL_BITMAP_SIZE platform -- does not fit in one word
-  = do { uniq <- getUniqueM
-       ; let bitmap_lbl = mkBitmapLabel uniq
-       ; return (CmmLabel bitmap_lbl,
-                 [mkRODataLits bitmap_lbl lits]) }
-
-  | otherwise -- Fits in one word
-  = return (mkStgWordCLit platform bitmap_word, [])
-  where
-    n_bits = length liveness
-
-    bitmap :: Bitmap
-    bitmap = mkBitmap platform liveness
-
-    small_bitmap = case bitmap of
-                     []  -> toStgWord platform 0
-                     [b] -> b
-                     _   -> panic "mkLiveness"
-    bitmap_word = toStgWord platform (fromIntegral n_bits)
-              .|. (small_bitmap `shiftL` pc_BITMAP_BITS_SHIFT (platformConstants platform))
-
-    lits = mkWordCLit platform (fromIntegral n_bits)
-         : map (mkStgWordCLit platform) bitmap
-      -- The first word is the size.  The structure must match
-      -- StgLargeBitmap in rts/include/rts/storage/InfoTable.h
-
--------------------------------------------------------------------------
---
---      Generating a standard info table
---
--------------------------------------------------------------------------
-
--- The standard bits of an info table.  This part of the info table
--- corresponds to the StgInfoTable type defined in
--- rts/include/rts/storage/InfoTables.h.
---
--- Its shape varies with ticky/profiling/tables next to code etc
--- so we can't use constant offsets from Constants
-
-mkStdInfoTable
-   :: Profile
-   -> (CmmLit,CmmLit)   -- Closure type descr and closure descr  (profiling)
-   -> Int               -- Closure RTS tag
-   -> CmmLit            -- SRT length
-   -> CmmLit            -- layout field
-   -> [CmmLit]
-
-mkStdInfoTable profile (type_descr, closure_descr) cl_type srt layout_lit
- =      -- Parallel revertible-black hole field
-    prof_info
-        -- Ticky info (none at present)
-        -- Debug info (none at present)
- ++ [layout_lit, tag, srt]
-
- where
-    platform = profilePlatform profile
-    prof_info
-        | profileIsProfiling profile = [type_descr, closure_descr]
-        | otherwise = []
-
-    tag = CmmInt (fromIntegral cl_type) (halfWordWidth platform)
-
--------------------------------------------------------------------------
---
---      Making string literals
---
--------------------------------------------------------------------------
-
-mkProfLits :: Platform -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
-mkProfLits platform NoProfilingInfo = return ((zeroCLit platform, zeroCLit platform), [])
-mkProfLits _ (ProfilingInfo td cd)
-  = do { (td_lit, td_decl) <- newStringLit td
-       ; (cd_lit, cd_decl) <- newStringLit cd
-       ; return ((td_lit,cd_lit), [td_decl,cd_decl]) }
-
-newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)
-newStringLit bytes
-  = do { uniq <- getUniqueM
-       ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }
-
-
--- Misc utils
-
--- | Value of the srt field of an info table when using an StgLargeSRT
-srtEscape :: Platform -> StgHalfWord
-srtEscape platform = toStgHalfWord platform (-1)
-
--------------------------------------------------------------------------
---
---      Accessing fields of an info table
---
--------------------------------------------------------------------------
-
--- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is
--- enabled.
-wordAligned :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr
-wordAligned platform align_check e
-  | align_check
-  = CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e]
-  | otherwise
-  = e
-
--- | Takes a closure pointer and returns the info table pointer
-closureInfoPtr :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr
-closureInfoPtr platform align_check e =
-    cmmLoadBWord platform (wordAligned platform align_check e)
-
--- | Takes an info pointer (the first word of a closure) and returns its entry
--- code
-entryCode :: Platform -> CmmExpr -> CmmExpr
-entryCode platform e =
- if platformTablesNextToCode platform
-      then e
-      else cmmLoadBWord platform e
-
--- | Takes a closure pointer, and return the *zero-indexed*
--- constructor tag obtained from the info table
--- This lives in the SRT field of the info table
--- (constructors don't need SRTs).
-getConstrTag :: Profile -> DoAlignSanitisation -> CmmExpr -> CmmExpr
-getConstrTag profile align_check closure_ptr
-  = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag profile info_table]
-  where
-    info_table = infoTable profile (closureInfoPtr platform align_check closure_ptr)
-    platform   = profilePlatform profile
-
--- | Takes a closure pointer, and return the closure type
--- obtained from the info table
-cmmGetClosureType :: Profile -> DoAlignSanitisation -> CmmExpr -> CmmExpr
-cmmGetClosureType profile align_check closure_ptr
-  = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType profile info_table]
-  where
-    info_table = infoTable profile (closureInfoPtr platform align_check closure_ptr)
-    platform   = profilePlatform profile
-
--- | Takes an info pointer (the first word of a closure)
--- and returns a pointer to the first word of the standard-form
--- info table, excluding the entry-code word (if present)
-infoTable :: Profile -> CmmExpr -> CmmExpr
-infoTable profile info_ptr
-  | platformTablesNextToCode platform = cmmOffsetB platform info_ptr (- stdInfoTableSizeB profile)
-  | otherwise                         = cmmOffsetW platform info_ptr 1 -- Past the entry code pointer
-  where platform = profilePlatform profile
-
--- | Takes an info table pointer (from infoTable) and returns the constr tag
--- field of the info table (same as the srt_bitmap field)
-infoTableConstrTag :: Profile -> CmmExpr -> CmmExpr
-infoTableConstrTag = infoTableSrtBitmap
-
--- | Takes an info table pointer (from infoTable) and returns the srt_bitmap
--- field of the info table
-infoTableSrtBitmap :: Profile -> CmmExpr -> CmmExpr
-infoTableSrtBitmap profile info_tbl
-  = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset profile)) (bHalfWord platform) NaturallyAligned
-    where platform = profilePlatform profile
-
--- | Takes an info table pointer (from infoTable) and returns the closure type
--- field of the info table.
-infoTableClosureType :: Profile -> CmmExpr -> CmmExpr
-infoTableClosureType profile info_tbl
-  = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset profile)) (bHalfWord platform) NaturallyAligned
-    where platform = profilePlatform profile
-
-infoTablePtrs :: Profile -> CmmExpr -> CmmExpr
-infoTablePtrs profile info_tbl
-  = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset profile)) (bHalfWord platform) NaturallyAligned
-    where platform = profilePlatform profile
-
-infoTableNonPtrs :: Profile -> CmmExpr -> CmmExpr
-infoTableNonPtrs profile info_tbl
-  = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset profile)) (bHalfWord platform) NaturallyAligned
-    where platform = profilePlatform profile
-
--- | Takes the info pointer of a function, and returns a pointer to the first
--- word of the StgFunInfoExtra struct in the info table.
-funInfoTable :: Profile -> CmmExpr -> CmmExpr
-funInfoTable profile info_ptr
-  | platformTablesNextToCode platform
-  = cmmOffsetB platform info_ptr (- stdInfoTableSizeB profile - pc_SIZEOF_StgFunInfoExtraRev (platformConstants platform))
-  | otherwise
-  = cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW profile)
-                                  -- Past the entry code pointer
-  where
-    platform = profilePlatform profile
-
--- | Takes the info pointer of a function, returns the function's arity
-funInfoArity :: Profile -> CmmExpr -> CmmExpr
-funInfoArity profile iptr
-  = cmmToWord platform (cmmLoadIndex platform rep fun_info (offset `div` rep_bytes))
-  where
-   platform = profilePlatform profile
-   fun_info = funInfoTable profile iptr
-   rep = cmmBits (widthFromBytes rep_bytes)
-   tablesNextToCode = platformTablesNextToCode platform
-
-   (rep_bytes, offset)
-    | tablesNextToCode = ( pc_REP_StgFunInfoExtraRev_arity pc
-                         , pc_OFFSET_StgFunInfoExtraRev_arity pc )
-    | otherwise        = ( pc_REP_StgFunInfoExtraFwd_arity pc
-                         , pc_OFFSET_StgFunInfoExtraFwd_arity pc )
-
-   pc = platformConstants platform
-
------------------------------------------------------------------------------
---
---      Info table sizes & offsets
---
------------------------------------------------------------------------------
-
-stdInfoTableSizeW :: Profile -> WordOff
--- The size of a standard info table varies with profiling/ticky etc,
--- so we can't get it from Constants
--- It must vary in sync with mkStdInfoTable
-stdInfoTableSizeW profile
-  = fixedInfoTableSizeW
-  + if profileIsProfiling profile
-       then profInfoTableSizeW
-       else 0
-
-fixedInfoTableSizeW :: WordOff
-fixedInfoTableSizeW = 2 -- layout, type
-
-profInfoTableSizeW :: WordOff
-profInfoTableSizeW = 2
-
-maxStdInfoTableSizeW :: WordOff
-maxStdInfoTableSizeW =
-  1 {- entry, when !tablesNextToCode -}
-  + fixedInfoTableSizeW
-  + profInfoTableSizeW
-
-maxRetInfoTableSizeW :: WordOff
-maxRetInfoTableSizeW =
-  maxStdInfoTableSizeW
-  + 1 {- srt label -}
-
-stdInfoTableSizeB  :: Profile -> ByteOff
-stdInfoTableSizeB profile = stdInfoTableSizeW profile * profileWordSizeInBytes profile
-
--- | Byte offset of the SRT bitmap half-word which is in the *higher-addressed*
--- part of the type_lit
-stdSrtBitmapOffset :: Profile -> ByteOff
-stdSrtBitmapOffset profile = stdInfoTableSizeB profile - halfWordSize (profilePlatform profile)
-
--- | Byte offset of the closure type half-word
-stdClosureTypeOffset :: Profile -> ByteOff
-stdClosureTypeOffset profile = stdInfoTableSizeB profile - profileWordSizeInBytes profile
-
-stdPtrsOffset :: Profile -> ByteOff
-stdPtrsOffset profile = stdInfoTableSizeB profile - 2 * profileWordSizeInBytes profile
-
-stdNonPtrsOffset :: Profile -> ByteOff
-stdNonPtrsOffset profile = stdInfoTableSizeB profile - 2 * profileWordSizeInBytes profile
-                                                     + halfWordSize (profilePlatform profile)
-
-conInfoTableSizeB :: Profile -> Int
-conInfoTableSizeB profile = stdInfoTableSizeB profile + profileWordSizeInBytes profile
diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Info/Build.hs
+++ /dev/null
@@ -1,1338 +0,0 @@
-{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
-    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,
-    ScopedTypeVariables, OverloadedStrings, LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-
-module GHC.Cmm.Info.Build
-  ( CAFSet, CAFEnv, cafAnal, cafAnalData
-  , doSRTs, ModuleSRTInfo (..), emptySRT
-  , SRTMap, srtMapNonCAFs
-  ) where
-
-import GHC.Prelude hiding (succ)
-
-import GHC.Platform
-import GHC.Platform.Profile
-
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Cmm.BlockId
-import GHC.Cmm.Config
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow
-import GHC.Unit.Module
-import GHC.Data.Graph.Directed
-import GHC.Cmm.CLabel
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Data.Maybe
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Runtime.Heap.Layout
-import GHC.Types.Unique.Supply
-import GHC.Types.CostCentre
-import GHC.StgToCmm.Heap
-
-import Control.Monad
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Control.Monad.Trans.State
-import Control.Monad.Trans.Class
-import Data.List (unzip4)
-
-import GHC.Types.Name.Set
-
-{- Note [SRTs]
-   ~~~~~~~~~~~
-Static Reference Tables (SRTs) are the mechanism by which the garbage collector
-can determine the live CAFs in the program. An SRT is a static table associated
-with a CAFfy closure which record which CAFfy objects are reachable from
-the closure's code.
-
-Representation
-^^^^^^^^^^^^^^
-
-+------+
-| info |
-|      |     +-----+---+---+---+
-|   -------->|SRT_2| | | | | 0 |
-|------|     +-----+-|-+-|-+---+
-|      |             |   |
-| code |             |   |
-|      |             v   v
-
-An SRT is simply an object in the program's data segment. It has the
-same representation as a static constructor.  There are 16
-pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info,
-representing SRT objects with 1-16 pointers, respectively.
-
-The entries of an SRT object point to static closures, which are either
-- FUN_STATIC, THUNK_STATIC or CONSTR
-- Another SRT (actually just a CONSTR)
-
-The final field of the SRT is the static link field, used by the
-garbage collector to chain together static closures that it visits and
-to determine whether a static closure has been visited or not. (see
-Note [STATIC_LINK fields])
-
-By traversing the transitive closure of an SRT, the GC will reach all
-of the CAFs that are reachable from the code associated with this SRT.
-
-If we need to create an SRT with more than 16 entries, we build a
-chain of SRT objects with all but the last having 16 entries.
-
-+-----+---+- -+---+---+
-|SRT16| | |   | | | 0 |
-+-----+-|-+- -+-|-+---+
-        |       |
-        v       v
-              +----+---+---+---+
-              |SRT2| | | | | 0 |
-              +----+-|-+-|-+---+
-                     |   |
-                     |   |
-                     v   v
-
-Referring to an SRT from the info table
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-The following things have SRTs:
-
-- Static functions (FUN)
-- Static thunks (THUNK), ie. CAFs
-- Continuations (RET_SMALL, etc.)
-
-In each case, the info table points to the SRT, if there is one.
-
-- info->srt is 0 if there's no SRT
-- otherwise, there are three ways which we may encode the location of the SRT in
-  the info table, described below.
-
-USE_SRT_POINTER
----------------
-Most general implementation. Can always be used, but other ways are more efficient.
-
-- info->srt is a pointer
-
-We encode an **absolute pointer** to the SRT in info->srt. e.g. for a FUN
-with an SRT:
-
-StgInfoTable          +------+
-  info->layout.ptrs   | ...  |
-  info->layout.nptrs  | ...  |
-  info->srt           |  ------------> pointer to SRT object
-  info->type          | ...  |
-                      |------|
-
-USE_SRT_OFFSET
---------------
-Requires:
-  - tables-next-to-code enabled
-
-In this case we use the info->srt to encode whether or not there is an SRT and
-if so encode the offset to its location in info->f.srt_offset:
-
-- info->srt is a half-word
-- info->f.srt_offset is a 32-bit int
-- info->srt is 0 if there's no SRT, otherwise,
-- info->srt == 1 and info->f.srt_offset is a offset to the SRT, relative to the
-field address itself
-
-e.g. for a FUN with an SRT:
-
-StgFunInfoTable       +------+
-  info->f.srt_offset  |  ------------> offset to SRT object
-StgInfoTable          +------+
-  info->layout.ptrs   | ...  |
-  info->layout.nptrs  | ...  |
-  info->srt           |  1   |
-  info->type          | ...  |
-                      |------|
-
-USE_INLINE_SRT_FIELD
---------------------
-Requires:
-  - tables-next-to-code enabled
-  - 64-bit architecture
-  - small memory model
-
-We optimise the info table representation further.  The offset to the SRT can
-be stored in 32 bits (all code lives within a 2GB region in x86_64's small
-memory model), so we can save a word in the info table by storing the
-srt_offset in the srt field, which is half a word.
-
-- info->srt is a half-word
-- info->srt is 0 if there's no SRT, otherwise:
-- info->srt is an offset from the info pointer to the SRT object
-
-StgInfoTable          +------+
-  info->layout.ptrs   |      |
-  info->layout.nptrs  |      |
-  info->srt           |  ------------> offset to SRT object
-                      |------|
-
-
-EXAMPLE
-^^^^^^^
-
-f = \x. ... g ...
-  where
-    g = \y. ... h ... c1 ...
-    h = \z. ... c2 ...
-
-c1 & c2 are CAFs
-
-g and h are local functions, but they have no static closures.  When
-we generate code for f, we start with a CmmGroup of four CmmDecls:
-
-   [ f_closure, f_entry, g_entry, h_entry ]
-
-we process each CmmDecl separately in cpsTop, giving us a list of
-CmmDecls. e.g. for f_entry, we might end up with
-
-   [ f_entry, f1_ret, f2_proc ]
-
-where f1_ret is a return point, and f2_proc is a proc-point.  We have
-a CAFSet for each of these CmmDecls, let's suppose they are
-
-   [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ]
-   [ g_entry{h_info, c1_closure} ]
-   [ h_entry{c2_closure} ]
-
-Next, we make an SRT for each of these functions:
-
-  f_srt : [g_info]
-  g_srt : [h_info, c1_closure]
-  h_srt : [c2_closure]
-
-Now, for g_info and h_info, we want to refer to the SRTs for g and h
-respectively, which we'll label g_srt and h_srt:
-
-  f_srt : [g_srt]
-  g_srt : [h_srt, c1_closure]
-  h_srt : [c2_closure]
-
-Now, when an SRT has a single entry, we don't actually generate an SRT
-closure for it, instead we just replace references to it with its
-single element.  So, since h_srt == c2_closure, we have
-
-  f_srt : [g_srt]
-  g_srt : [c2_closure, c1_closure]
-  h_srt : [c2_closure]
-
-and the only SRT closure we generate is
-
-  g_srt = SRT_2 [c2_closure, c1_closure]
-
-Algorithm
-^^^^^^^^^
-
-0. let srtMap :: Map CAFfyLabel (Maybe SRTEntry) = {}
-   Maps closures to their SRT entries (i.e. how they appear in a SRT payload)
-
-1. Start with decls :: [CmmDecl]. This corresponds to an SCC of bindings in STG
-   after code-generation.
-
-2. CPS-convert each CmmDecl (GHC.Cmm.Pipeline.cpsTop), resulting in a list
-   [CmmDecl]. There might be multiple CmmDecls in the result, due to proc-point
-   splitting.
-
-3. In cpsTop, *before* proc-point splitting, when we still have a single
-   CmmDecl, we do cafAnal for procs:
-
-   * cafAnal performs a backwards analysis on the code blocks
-
-   * For each labelled block, the analysis produces a CAFSet (= Set CAFfyLabel),
-     representing all the CAFfyLabels reachable from this label.
-
-   * A label is added to the set if it refers to a FUN, THUNK, or RET,
-     and its CafInfo /= NoCafRefs.
-     (NB. all CafInfo for Ids in the current module should be initialised to
-     MayHaveCafRefs)
-
-   * The result is CAFEnv = LabelMap CAFSet
-
-   (Why *before* proc-point splitting? Because the analysis needs to propagate
-   information across branches, and proc-point splitting turns branches into
-   CmmCalls to top-level CmmDecls.  The analysis would fail to find all the
-   references to CAFFY labels if we did it after proc-point splitting.)
-
-   For static data, cafAnalData simply returns set of all labels that refer to a
-   FUN, THUNK, and RET whose CafInfos /= NoCafRefs.
-
-4. The result of cpsTop is (CAFEnv, [CmmDecl]) for procs and (CAFSet, CmmDecl)
-   for static data. So after `mapM cpsTop decls` we have
-   [Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)]
-
-5. For procs concat the decls and union the CAFEnvs to get (CAFEnv, [CmmDecl])
-
-6. For static data generate a Map CLabel CAFSet (maps static data to their CAFSets)
-
-7. Dependency-analyse the decls using CAFEnv and CAFSets, giving us SCC CAFfyLabel
-
-8. For each SCC in dependency order
-   - Let lbls :: [CAFfyLabel] be the non-recursive labels in this SCC
-   - Apply CAFEnv to each label and concat the result :: [CAFfyLabel]
-   - For each CAFfyLabel in the set apply srtMap (and ignore Nothing) to get
-     srt :: [SRTEntry]
-   - Make a label for this SRT, call it l
-   - If the SRT is not empty (i.e. the group is CAFFY) add FUN_STATICs in the
-     group to the SRT (see Note [Invalid optimisation: shortcutting])
-   - Add to srtMap: lbls -> if null srt then Nothing else Just l
-
-9. At the end, update the IdInfo for every top-level binding x:
-   if srtMap x == Nothing, then the binding is non-CAFFY, otherwise it is
-   CAFFY.
-
-Optimisations
-^^^^^^^^^^^^^
-
-To reduce the code size overhead and the cost of traversing SRTs in
-the GC, we want to simplify SRTs where possible. We therefore apply
-the following optimisations.  Each has a [keyword]; search for the
-keyword in the code below to see where the optimisation is
-implemented.
-
-1. [Inline] we never create an SRT with a single entry, instead we
-   point to the single entry directly from the info table.
-
-   i.e. instead of
-
-    +------+
-    | info |
-    |      |     +-----+---+---+
-    |   -------->|SRT_1| | | 0 |
-    |------|     +-----+-|-+---+
-    |      |             |
-    | code |             |
-    |      |             v
-                         C
-
-   we can point directly to the closure:
-
-    +------+
-    | info |
-    |      |
-    |   -------->C
-    |------|
-    |      |
-    | code |
-    |      |
-
-
-   Furthermore, the SRT for any code that refers to this info table
-   can point directly to C.
-
-   The exception to this is when we're doing dynamic linking. In that
-   case, if the closure is not locally defined then we can't point to
-   it directly from the info table, because this is the text section
-   which cannot contain runtime relocations. In this case we skip this
-   optimisation and generate the singleton SRT, because SRTs are in the
-   data section and *can* have relocatable references.
-
-2. [FUN] A static function closure can also be an SRT, we simply put
-   the SRT entries as fields in the static closure.  This makes a lot
-   of sense: the static references are just like the free variables of
-   the FUN closure.
-
-   i.e. instead of
-
-   f_closure:
-   +-----+---+
-   |  |  | 0 |
-   +- |--+---+
-      |            +------+
-      |            | info |     f_srt:
-      |            |      |     +-----+---+---+---+
-      |            |   -------->|SRT_2| | | | + 0 |
-      `----------->|------|     +-----+-|-+-|-+---+
-                   |      |             |   |
-                   | code |             |   |
-                   |      |             v   v
-
-
-   We can generate:
-
-   f_closure:
-   +-----+---+---+---+
-   |  |  | | | | | 0 |
-   +- |--+-|-+-|-+---+
-      |    |   |   +------+
-      |    v   v   | info |
-      |            |      |
-      |            |   0  |
-      `----------->|------|
-                   |      |
-                   | code |
-                   |      |
-
-
-   (note: we can't do this for THUNKs, because the thunk gets
-   overwritten when it is entered, so we wouldn't be able to share
-   this SRT with other info tables that want to refer to it (see
-   [Common] below). FUNs are immutable so don't have this problem.)
-
-3. [Common] Identical SRTs can be commoned up.
-
-4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also
-   refers to C (perhaps transitively), then we can omit the reference
-   to C from A.
-
-
-Note that there are many other optimisations that we could do, but
-aren't implemented. In general, we could omit any reference from an
-SRT if everything reachable from it is also reachable from the other
-fields in the SRT. Our [Filter] optimisation is a special case of
-this.
-
-Another opportunity we don't exploit is this:
-
-A = {X,Y,Z}
-B = {Y,Z}
-C = {X,B}
-
-Here we could use C = {A} and therefore [Inline] C = A.
--}
-
--- ---------------------------------------------------------------------
-{-
-Note [No static object resurrection]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The "static flag" mechanism (see Note [STATIC_LINK fields] in smStorage.h) that
-the GC uses to track liveness of static objects assumes that unreachable
-objects will never become reachable again (i.e. are never "resurrected").
-Breaking this assumption can result in extremely subtle GC soundness issues
-(e.g. #15544, #20959).
-
-Guaranteeing that this assumption is not violated requires that all CAFfy
-static objects reachable from the object's code are reachable from its SRT.  In
-the past we have gotten this wrong in a few ways:
-
- * shortcutting references to FUN_STATICs to instead point to the FUN_STATIC's
-   SRT. This lead to #15544 and is described in more detail in Note [Invalid
-   optimisation: shortcutting].
-
- * omitting references to static data constructor applications. This previously
-   happened due to an oversight (#20959): when generating an SRT for a
-   recursive group we would drop references to the CAFfy static data
-   constructors.
-
-To see why we cannot allow object resurrection, see the examples in the
-above-mentioned Notes.
-
-If a static closure definitely does not transitively refer to any CAFs, then it
-*may* be advertised as not-CAFfy in the interface file and consequently *may*
-be omitted from SRTs. Regardless of whether the closure is advertised as CAFfy
-or non-CAFfy, its STATIC_LINK field *must* be set to 3, so that it never
-appears on the static closure list.
--}
-
-{-
-Note [Invalid optimisation: shortcutting]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-You might think that if we have something like
-
-A's SRT = {B}
-B's SRT = {X}
-
-that we could replace the reference to B in A's SRT with X.
-
-A's SRT = {X}
-B's SRT = {X}
-
-and thereby perhaps save a little work at runtime, because we don't
-have to visit B.
-
-But this is NOT valid.
-
-Consider these cases:
-
-0. B can't be a constructor, because constructors don't have SRTs
-
-1. B is a CAF. This is the easy one. Obviously we want A's SRT to
-   point to B, so that it keeps B alive.
-
-2. B is a function.  This is the tricky one. The reason we can't
-   shortcut in this case is that we aren't allowed to resurrect static
-   objects for the reason described in Note [No static object resurrection].
-   We noticed this in #15544.
-
-The particular case that cropped up when we tried this in #15544 was:
-
-- A is a thunk
-- B is a static function
-- X is a CAF
-- suppose we GC when A is alive, and B is not otherwise reachable.
-- B is "collected", meaning that it doesn't make it onto the static
-  objects list during this GC, but nothing bad happens yet.
-- Next, suppose we enter A, and then call B. (remember that A refers to B)
-  At the entry point to B, we GC. This puts B on the stack, as part of the
-  RET_FUN stack frame that gets pushed when we GC at a function entry point.
-- This GC will now reach B
-- But because B was previous "collected", it breaks the assumption
-  that static objects are never resurrected. See Note [STATIC_LINK
-  fields] in rts/sm/Storage.h for why this is bad.
-- In practice, the GC thinks that B has already been visited, and so
-  doesn't visit X, and catastrophe ensues.
-
-
-
-Note [Ticky labels in SRT analysis]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Raw Cmm data (CmmStaticsRaw) can't contain pointers so they're considered
-non-CAFFY in SRT analysis and we update the SRTMap mapping them to `Nothing`
-(meaning they're not CAFFY).
-
-However when building with -ticky we generate ticky CLabels using the function's
-`Name`. For example, if we have a top-level function `sat_s1rQ`, in a ticky
-build we get two IdLabels using the name `sat_s1rQ`:
-
-- For the function itself: IdLabel sat_s1rQ ... Entry
-- For the ticky counter: IdLabel sat_s1rQ ... RednCounts
-
-In these cases we really want to use the function definition for the SRT
-analysis of this Name, because that's what we export for this Name -- ticky
-counters are not exported. So we ignore ticky counters in SRT analysis (which
-are never CAFFY and never exported).
-
-Not doing this caused #17947 where we analysed the function first mapped the
-name to CAFFY. We then saw the ticky constructor, and because it has the same
-Name as the function and is not CAFFY we overrode the CafInfo of the name as
-non-CAFFY.
--}
-
--- ---------------------------------------------------------------------
--- Label types
-
--- |
--- The label of a CAFfy thing.
---
--- Labels that come from 'cafAnal' can be:
---   - @_closure@ labels for static functions, static data constructor
---     applications, or static thunks
---   - @_info@ labels for dynamic functions, thunks, or continuations
---   - @_entry@ labels for functions or thunks
---
--- Meanwhile the labels on top-level blocks are @_entry@ labels.
---
--- To put everything in the same namespace we convert all labels to
--- closure labels using 'toClosureLbl'.  Note that some of these
--- labels will not actually exist; that's ok because we're going to
--- map them to SRTEntry later, which ranges over labels that do exist.
---
-newtype CAFfyLabel = CAFfyLabel CLabel
-  deriving (Eq,Ord)
-
-deriving newtype instance OutputableP env CLabel => OutputableP env CAFfyLabel
-
-type CAFSet = Set CAFfyLabel
-type CAFEnv = LabelMap CAFSet
-
--- | Records the CAFfy references of a set of static data decls.
-type DataCAFEnv = Map CLabel CAFSet
-
-
-mkCAFfyLabel :: Platform -> CLabel -> CAFfyLabel
-mkCAFfyLabel platform lbl = CAFfyLabel (toClosureLbl platform lbl)
-
--- This is a label that we can put in an SRT.  It *must* be a closure label,
--- pointing to either a @FUN_STATIC@, @THUNK_STATIC@, or @CONSTR@.
-newtype SRTEntry = SRTEntry CLabel
-  deriving (Eq, Ord)
-
-deriving newtype instance OutputableP env CLabel => OutputableP env SRTEntry
-
-
--- ---------------------------------------------------------------------
--- CAF analysis
-
-addCafLabel :: Platform -> CLabel -> CAFSet -> CAFSet
-addCafLabel platform l s
-  | Just _ <- hasHaskellName l
-  , let caf_label = mkCAFfyLabel platform l
-    -- For imported Ids hasCAF will have accurate CafInfo
-    -- Locals are initialized as CAFFY. We turn labels with empty SRTs into
-    -- non-CAFFYs in doSRTs
-  , hasCAF l
-  = Set.insert caf_label s
-  | otherwise
-  = s
-
--- | Collect possible CAFfy references from a 'CmmData' decl.
-cafAnalData
-  :: Platform
-  -> CmmStatics
-  -> CAFSet
-cafAnalData platform st = case st of
-   CmmStaticsRaw _lbl _data           -> Set.empty
-   CmmStatics _lbl _itbl _ccs payload _extras ->
-       foldl' analyzeStatic Set.empty payload
-     where
-       analyzeStatic s lit =
-         case lit of
-           CmmLabel c -> addCafLabel platform c s
-           CmmLabelOff c _ -> addCafLabel platform c s
-           CmmLabelDiffOff c1 c2 _ _ -> addCafLabel platform c1 $! addCafLabel platform c2 s
-           _ -> s
-
--- |
--- For each code block:
---   - collect the references reachable from this code block to FUN,
---     THUNK or RET labels for which @hasCAF == True@
---
--- This gives us a 'CAFEnv': a mapping from code block to sets of labels
---
-cafAnal
-  :: Platform
-  -> LabelSet   -- ^ The blocks representing continuations, ie. those
-                -- that will get RET info tables.  These labels will
-                -- get their own SRTs, so we don't aggregate CAFs from
-                -- references to these labels, we just use the label.
-  -> CLabel     -- ^ The top label of the proc
-  -> CmmGraph
-  -> CAFEnv
-cafAnal platform contLbls topLbl cmmGraph =
-  analyzeCmmBwd cafLattice
-    (cafTransfers platform contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty
-
-
-cafLattice :: DataflowLattice CAFSet
-cafLattice = DataflowLattice Set.empty add
-  where
-    add (OldFact old) (NewFact new) =
-        let !new' = old `Set.union` new
-        in changedIf (Set.size new' > Set.size old) new'
-
-
-cafTransfers :: Platform -> LabelSet -> Label -> CLabel -> TransferFun CAFSet
-cafTransfers platform contLbls entry topLbl
-  block@(BlockCC eNode middle xNode) fBase =
-    let joined :: CAFSet
-        joined = cafsInNode xNode $! live'
-
-        result :: CAFSet
-        !result = foldNodesBwdOO cafsInNode middle joined
-
-        facts :: [Set CAFfyLabel]
-        facts = mapMaybe successorFact (successors xNode)
-
-        live' :: CAFSet
-        live' = joinFacts cafLattice facts
-
-        successorFact :: Label -> Maybe (Set CAFfyLabel)
-        successorFact s
-          -- If this is a loop back to the entry, we can refer to the
-          -- entry label.
-          | s == entry = Just (addCafLabel platform topLbl Set.empty)
-          -- If this is a continuation, we want to refer to the
-          -- SRT for the continuation's info table
-          | s `setMember` contLbls
-          = Just (Set.singleton (mkCAFfyLabel platform (infoTblLbl s)))
-          -- Otherwise, takes the CAF references from the destination
-          | otherwise
-          = lookupFact s fBase
-
-        cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
-        cafsInNode node set = foldExpDeep addCafExpr node set
-
-        addCafExpr :: CmmExpr -> Set CAFfyLabel -> Set CAFfyLabel
-        addCafExpr expr !set =
-          case expr of
-            CmmLit (CmmLabel c) ->
-              addCafLabel platform c set
-            CmmLit (CmmLabelOff c _) ->
-              addCafLabel platform c set
-            CmmLit (CmmLabelDiffOff c1 c2 _ _) ->
-              addCafLabel platform c1 $! addCafLabel platform c2 set
-            _ ->
-              set
-    in
-      srtTrace "cafTransfers" (text "block:"         <+> pdoc platform block $$
-                                text "contLbls:"     <+> ppr contLbls $$
-                                text "entry:"        <+> ppr entry $$
-                                text "topLbl:"       <+> pdoc platform topLbl $$
-                                text "cafs in exit:" <+> pdoc platform joined $$
-                                text "result:"       <+> pdoc platform result) $
-        mapSingleton (entryLabel eNode) result
-
-
--- -----------------------------------------------------------------------------
--- ModuleSRTInfo
-
-data ModuleSRTInfo = ModuleSRTInfo
-  { thisModule :: Module
-    -- ^ Current module being compiled. Required for calling labelDynamic.
-  , dedupSRTs :: Map (Set SRTEntry) SRTEntry
-    -- ^ previous SRTs we've emitted, so we can de-duplicate.
-    -- Used to implement the [Common] optimisation.
-  , flatSRTs :: Map SRTEntry (Set SRTEntry)
-    -- ^ The reverse mapping, so that we can remove redundant
-    -- entries. e.g.  if we have an SRT [a,b,c], and we know that b
-    -- points to [c,d], we can omit c and emit [a,b].
-    -- Used to implement the [Filter] optimisation.
-  , moduleSRTMap :: SRTMap
-  }
-
-instance OutputableP env CLabel => OutputableP env ModuleSRTInfo where
-  pdoc env ModuleSRTInfo{..} =
-    text "ModuleSRTInfo {" $$
-      (nest 4 $ text "dedupSRTs ="    <+> pdoc env dedupSRTs $$
-                text "flatSRTs ="     <+> pdoc env flatSRTs $$
-                text "moduleSRTMap =" <+> pdoc env moduleSRTMap) $$ char '}'
-
-emptySRT :: Module -> ModuleSRTInfo
-emptySRT mod =
-  ModuleSRTInfo
-    { thisModule = mod
-    , dedupSRTs = Map.empty
-    , flatSRTs = Map.empty
-    , moduleSRTMap = Map.empty
-    }
-
--- -----------------------------------------------------------------------------
--- Constructing SRTs
-
-{- Implementation notes
-
-- In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable
-
-- The entry in info_tbls corresponding to g_entry is the closure info
-  table, the rest are continuations.
-
-- Each entry in info_tbls possibly needs an SRT.  We need to make a
-  label for each of these.
-
-- We get the CAFSet for each entry from the CAFEnv
-
--}
-
-data SomeLabel
-  = BlockLabel !Label
-  | DeclLabel CLabel
-  deriving (Eq, Ord)
-
-instance OutputableP env CLabel => OutputableP env SomeLabel where
-   pdoc env = \case
-      BlockLabel l -> text "b:" <+> pdoc env l
-      DeclLabel l  -> text "s:" <+> pdoc env l
-
-getBlockLabel :: SomeLabel -> Maybe Label
-getBlockLabel (BlockLabel l) = Just l
-getBlockLabel (DeclLabel _) = Nothing
-
-getBlockLabels :: [SomeLabel] -> [Label]
-getBlockLabels = mapMaybe getBlockLabel
-
--- | Return a @(Label,CLabel)@ pair for each labelled block of a 'CmmDecl',
---   where the label is
---   - the info label for a continuation or dynamic closure
---   - the closure label for a top-level function (not a CAF)
-getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFfyLabel)]
-getLabelledBlocks platform decl = case decl of
-   CmmData _ (CmmStaticsRaw _ _)    -> []
-   CmmData _ (CmmStatics lbl info _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl)
-                                            | not (isThunkRep (cit_rep info))
-                                            ]
-   CmmProc top_info _ _ _           -> [ (BlockLabel blockId, caf_lbl)
-                                       | (blockId, info) <- mapToList (info_tbls top_info)
-                                       , let rep = cit_rep info
-                                       , not (isStaticRep rep) || not (isThunkRep rep)
-                                       , let !caf_lbl = mkCAFfyLabel platform (cit_lbl info)
-                                       ]
-
--- | Put the labelled blocks that we will be annotating with SRTs into
--- dependency order.  This is so that we can process them one at a
--- time, resolving references to earlier blocks to point to their
--- SRTs. CAFs themselves are not included here; see 'getCAFs' below.
-depAnalSRTs
-  :: Platform
-  -> CAFEnv            -- ^ 'CAFEnv' for procedures. From 'cafAnal'.
-  -> Map CLabel CAFSet -- ^ CAFEnv for statics. Maps statics to the set of the
-                       -- CAFfy things which they refer to. From 'cafAnalData'.
-  -> [CmmDecl]         -- ^ the decls to analyse.
-  -> [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]
-depAnalSRTs platform cafEnv cafEnv_static decls =
-  srtTrace "depAnalSRTs" (text "decls:"  <+> pdoc platform decls $$
-                           text "nodes:" <+> pdoc platform (map node_payload nodes) $$
-                           text "graph:" <+> pdoc platform graph) graph
- where
-  labelledBlocks :: [(SomeLabel, CAFfyLabel)]
-  labelledBlocks = concatMap (getLabelledBlocks platform) decls
-  labelToBlock :: Map CAFfyLabel SomeLabel
-  labelToBlock = foldl' (\m (v,k) -> Map.insert k v m) Map.empty labelledBlocks
-
-  -- the set of graph nodes. A node is identified by either a BlockLabel (in
-  -- the case of code) or a DeclLabel (in the case of static data).
-  nodes :: [Node SomeLabel (SomeLabel, CAFfyLabel, Set CAFfyLabel)]
-  nodes = [ DigraphNode (l,lbl,cafs') l
-              (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))
-          | (l, lbl) <- labelledBlocks
-          , Just (cafs :: Set CAFfyLabel) <-
-              [case l of
-                 BlockLabel l -> mapLookup l cafEnv
-                 DeclLabel cl -> Map.lookup cl cafEnv_static]
-          , let cafs' = Set.delete lbl cafs
-          ]
-
-  graph :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]
-  graph = stronglyConnCompFromEdgedVerticesOrd nodes
-
--- | Get @(Maybe Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block.
--- The @Set CAFfyLabel@ represents the set of CAFfy things which this CAF's code
--- depends upon.
---
---  - The 'Label' represents the entry code of the closure. This may be
---    'Nothing' if it is a standard closure type (e.g. @stg_unpack_cstring@; see
---    Note [unpack_cstring closures] in StgStdThunks.cmm).
---  - The 'CAFLabel' is the label of the CAF closure.
---  - The @Set CAFLabel@ is the set of CAFfy closures which should be included
---    in the closure's SRT.
---
--- Note that CAFs are treated differently from other labelled blocks:
---
---  - we never shortcut a reference to a CAF to the contents of its
---    SRT, since the point of SRTs is to keep CAFs alive.
---
---  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
---    instead we generate their SRTs after everything else.
-getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Maybe Label, CAFfyLabel, Set CAFfyLabel)]
-getCAFs platform cafEnv = mapMaybe getCAFLabel
-  where
-    getCAFLabel :: CmmDecl -> Maybe (Maybe Label, CAFfyLabel, Set CAFfyLabel)
-
-    getCAFLabel (CmmProc top_info top_lbl _ g)
-      | Just info <- mapLookup (g_entry g) (info_tbls top_info)
-      , let rep = cit_rep info
-      , isStaticRep rep && isThunkRep rep
-      , Just cafs <- mapLookup (g_entry g) cafEnv
-      = Just (Just (g_entry g), mkCAFfyLabel platform top_lbl, cafs)
-
-      | otherwise
-      = Nothing
-
-    getCAFLabel (CmmData _ (CmmStatics top_lbl info _ccs _payload _extras))
-      | isThunkRep (cit_rep info)
-      = Just (Nothing, mkCAFfyLabel platform top_lbl, Set.empty)
-
-      | otherwise
-      = Nothing
-
-    getCAFLabel (CmmData _ (CmmStaticsRaw _lbl _payload))
-      = Nothing
-
--- | Get the list of blocks that correspond to the entry points for
--- @FUN_STATIC@ closures.  These are the blocks for which if we have an
--- SRT we can merge it with the static closure. [FUN]
-getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)]
-getStaticFuns decls =
-  [ (g_entry g, lbl)
-  | CmmProc top_info _ _ g <- decls
-  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
-  , Just (id, _) <- [cit_clo info]
-  , let rep = cit_rep info
-  , isStaticRep rep && isFunRep rep
-  , let !lbl = mkClosureLabel (idName id) (idCafInfo id)
-  ]
-
-
--- | Maps labels from 'cafAnal' to the final CLabel that will appear
--- in the SRT.
---   - closures with singleton SRTs resolve to their single entry
---   - closures with larger SRTs map to the label for that SRT
---   - CAFs must not map to anything!
---   - if a labels maps to Nothing, we found that this label's SRT
---     is empty, so we don't need to refer to it from other SRTs.
-type SRTMap = Map CAFfyLabel (Maybe SRTEntry)
-
-
--- | Given 'SRTMap' of a module, returns the set of non-CAFFY names in the
--- module.  Any 'Name's not in the set are CAFFY.
-srtMapNonCAFs :: SRTMap -> NonCaffySet
-srtMapNonCAFs srtMap =
-    NonCaffySet $ mkNameSet (mapMaybe get_name (Map.toList srtMap))
-  where
-    get_name (CAFfyLabel l, Nothing) = hasHaskellName l
-    get_name (_l, Just _srt_entry) = Nothing
-
--- | Resolve a CAFfyLabel to its 'SRTEntry' using the 'SRTMap'.
-resolveCAF :: Platform -> SRTMap -> CAFfyLabel -> Maybe SRTEntry
-resolveCAF platform srtMap lbl@(CAFfyLabel l) =
-    srtTrace "resolveCAF" ("l:" <+> pdoc platform l <+> "resolved:" <+> pdoc platform ret) ret
-  where
-    ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl platform l))) lbl srtMap
-
-anyCafRefs :: [CafInfo] -> CafInfo
-anyCafRefs caf_infos = case any mayHaveCafRefs caf_infos of
-                         True -> MayHaveCafRefs
-                         False -> NoCafRefs
-
--- | Attach SRTs to all info tables in the 'CmmDecl's, and add SRT
--- declarations to the 'ModuleSRTInfo'.
---
-doSRTs
-  :: CmmConfig
-  -> ModuleSRTInfo
-  -> [(CAFEnv, [CmmDecl])]   -- ^ 'CAFEnv's and 'CmmDecl's for code blocks
-  -> [(CAFSet, CmmDecl)]     -- ^ static data decls and their 'CAFSet's
-  -> IO (ModuleSRTInfo, [CmmDeclSRTs])
-
-doSRTs cfg moduleSRTInfo procs data_ = do
-  us <- mkSplitUniqSupply 'u'
-
-  let profile = cmmProfile cfg
-
-  -- Ignore the original grouping of decls, and combine all the
-  -- CAFEnvs into a single CAFEnv.
-  let static_data_env :: DataCAFEnv
-      static_data_env =
-        Map.fromList $
-        flip map data_ $
-        \(set, decl) ->
-          case decl of
-            CmmProc{} ->
-              pprPanic "doSRTs" (text "Proc in static data list:" <+> pdoc platform decl)
-            CmmData _ static ->
-              case static of
-                CmmStatics lbl _ _ _ _ -> (lbl, set)
-                CmmStaticsRaw lbl _ -> (lbl, set)
-
-      (proc_envs, procss) = unzip procs
-      cafEnv = mapUnions proc_envs
-      decls = map snd data_ ++ concat procss
-      staticFuns = mapFromList (getStaticFuns decls)
-
-      platform = cmmPlatform cfg
-
-  -- Put the decls in dependency order. Why? So that we can implement
-  -- [Inline] and [Filter].  If we need to refer to an SRT that has
-  -- a single entry, we use the entry itself, which means that we
-  -- don't need to generate the singleton SRT in the first place.  But
-  -- to do this we need to process blocks before things that depend on
-  -- them.
-  let
-    sccs :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]
-    sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls
-
-    cafsWithSRTs :: [(Maybe Label, CAFfyLabel, Set CAFfyLabel)]
-    cafsWithSRTs = getCAFs platform cafEnv decls
-
-  srtTraceM "doSRTs" (text "data:"            <+> pdoc platform data_ $$
-                      text "procs:"           <+> pdoc platform procs $$
-                      text "static_data_env:" <+> pdoc platform static_data_env $$
-                      text "sccs:"            <+> pdoc platform sccs $$
-                      text "cafsWithSRTs:"    <+> pdoc platform cafsWithSRTs)
-
-  -- On each strongly-connected group of decls, construct the SRT
-  -- closures and the SRT fields for info tables.
-  let result ::
-        [ ( [CmmDeclSRTs]          -- generated SRTs
-          , [(Label, CLabel)]      -- SRT fields for info tables
-          , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
-          , CafInfo                -- Whether the group has CAF references
-          ) ]
-
-      (result, moduleSRTInfo') =
-        initUs_ us $
-        flip runStateT moduleSRTInfo $ do
-          nonCAFs <- mapM (doSCC cfg staticFuns static_data_env) sccs
-          cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->
-            oneSRT cfg staticFuns (map BlockLabel (maybeToList l)) [cafLbl]
-                   True{-is a CAF-} cafs static_data_env
-          return (nonCAFs ++ cAFs)
-
-      (srt_declss, pairs, funSRTs, has_caf_refs) = unzip4 result
-      srt_decls = concat srt_declss
-
-  -- Next, update the info tables with the SRTs
-  let
-    srtFieldMap = mapFromList (concat pairs)
-    funSRTMap = mapFromList (concat funSRTs)
-    has_caf_refs' = anyCafRefs has_caf_refs
-    decls' =
-      concatMap (updInfoSRTs profile srtFieldMap funSRTMap has_caf_refs') decls
-
-  -- Finally update CafInfos for raw static literals (CmmStaticsRaw). Those are
-  -- not analysed in oneSRT so we never add entries for them to the SRTMap.
-  let srtMap_w_raws =
-        foldl' (\(srtMap :: SRTMap) (_, decl) ->
-                  case decl of
-                    CmmData _ CmmStatics{} ->
-                      -- already updated by oneSRT
-                      srtMap
-                    CmmData _ (CmmStaticsRaw lbl _)
-                      | isIdLabel lbl && not (isTickyLabel lbl) ->
-                          -- Raw data are not analysed by oneSRT and they can't
-                          -- be CAFFY.
-                          -- See Note [Ticky labels in SRT analysis] above for
-                          -- why we exclude ticky labels here.
-                          Map.insert (mkCAFfyLabel platform lbl) Nothing srtMap
-                      | otherwise ->
-                          -- Not an IdLabel, ignore
-                          srtMap
-                    CmmProc{} ->
-                      pprPanic "doSRTs" (text "Found Proc in static data list:" <+> pdoc platform decl))
-               (moduleSRTMap moduleSRTInfo') data_
-
-  return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')
-
-
--- | Build the SRT for a strongly-connected component of blocks.
-doSCC
-  :: CmmConfig
-  -> LabelMap CLabel -- ^ which blocks are static function entry points
-  -> DataCAFEnv      -- ^ static data
-  -> SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)
-  -> StateT ModuleSRTInfo UniqSM
-        ( [CmmDeclSRTs]          -- generated SRTs
-        , [(Label, CLabel)]      -- SRT fields for info tables
-        , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
-        , CafInfo                -- Whether the group has CAF references
-        )
-
-doSCC cfg staticFuns static_data_env (AcyclicSCC (l, cafLbl, cafs)) =
-  oneSRT cfg staticFuns [l] [cafLbl] False cafs static_data_env
-
-doSCC cfg staticFuns static_data_env (CyclicSCC nodes) = do
-  -- build a single SRT for the whole cycle, see Note [recursive SRTs]
-  let (lbls, caf_lbls, cafsets) = unzip3 nodes
-      cafs = Set.unions cafsets
-  oneSRT cfg staticFuns lbls caf_lbls False cafs static_data_env
-
-
-{- Note [recursive SRTs]
-   ~~~~~~~~~~~~~~~~~~~~~
-If the dependency analyser has found us a recursive group of
-declarations, then we build a single SRT for the whole group, on the
-grounds that everything in the group is reachable from everything
-else, so we lose nothing by having a single SRT.
-
-However, there are a couple of wrinkles to be aware of.
-
-* The Set CAFfyLabel for this SRT will contain labels in the group
-  itself. The SRTMap will therefore not contain entries for these labels
-  yet, so we can't turn them into SRTEntries using resolveCAF. BUT we
-  can just remove recursive references from the Set CAFLabel before
-  generating the SRT - the group SRT will consist of the union of the SRTs of
-  each of group's constituents minus recursive references.
-
-* That is, EXCEPT for static function closures and static data constructor
-  applications. For the same reason described in Note [No static object
-  resurrection], we cannot omit references to static function closures and
-  constructor applications.
-
-  But, since we will merge the SRT with one of the static function
-  closures (see [FUN]), we can omit references to *that* static
-  function closure from the SRT.
-
-* Similarly, we must reintroduce recursive references to static data
-  constructor applications into the group's SRT.
--}
-
--- | Build an SRT for a set of blocks
-oneSRT
-  :: CmmConfig
-  -> LabelMap CLabel            -- ^ which blocks are static function entry points
-  -> [SomeLabel]                -- ^ blocks in this set
-  -> [CAFfyLabel]               -- ^ labels for those blocks
-  -> Bool                       -- ^ True <=> this SRT is for a CAF
-  -> Set CAFfyLabel             -- ^ SRT for this set
-  -> DataCAFEnv                 -- Static data labels in this group
-  -> StateT ModuleSRTInfo UniqSM
-       ( [CmmDeclSRTs]                -- SRT objects we built
-       , [(Label, CLabel)]            -- SRT fields for these blocks' itbls
-       , [(Label, [SRTEntry])]        -- SRTs to attach to static functions
-       , CafInfo                      -- Whether the group has CAF references
-       )
-
-oneSRT cfg staticFuns lbls caf_lbls isCAF cafs static_data_env = do
-  topSRT <- get
-
-  let
-    this_mod = thisModule topSRT
-    profile  = cmmProfile cfg
-    platform = profilePlatform profile
-    srtMap   = moduleSRTMap topSRT
-
-    blockids = getBlockLabels lbls
-
-    -- Can we merge this SRT with a FUN_STATIC closure?
-    maybeFunClosure :: Maybe (CLabel, Label)
-    otherFunLabels :: [CLabel]
-    (maybeFunClosure, otherFunLabels) =
-      case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of
-        [] -> (Nothing, [])
-        ((l,b):xs) -> (Just (l,b), map fst xs)
-
-    -- Remove recursive references from the SRT as described in
-    -- Note [recursive SRTs]. We carefully reintroduce references to static
-    -- functions and data constructor applications below, as is necessary due
-    -- to Note [No static object resurrection].
-    nonRec :: Set CAFfyLabel
-    nonRec = cafs `Set.difference` Set.fromList caf_lbls
-
-    -- Resolve references to their SRT entries
-    resolved :: [SRTEntry]
-    resolved = mapMaybe (resolveCAF platform srtMap) (Set.toList nonRec)
-
-    -- The set of all SRTEntries in SRTs that we refer to from here.
-    allBelow =
-      Set.unions [ lbls | caf <- resolved
-                        , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ]
-
-    -- Remove SRTEntries that are also in an SRT that we refer to.
-    -- Implements the [Filter] optimisation.
-    filtered0 = Set.fromList resolved `Set.difference` allBelow
-
-  srtTraceM "oneSRT:"
-     (text "srtMap:"          <+> pdoc platform srtMap $$
-      text "nonRec:"          <+> pdoc platform nonRec $$
-      text "lbls:"            <+> pdoc platform lbls $$
-      text "caf_lbls:"        <+> pdoc platform caf_lbls $$
-      text "static_data_env:" <+> pdoc platform static_data_env $$
-      text "cafs:"            <+> pdoc platform cafs $$
-      text "blockids:"        <+> ppr blockids $$
-      text "maybeFunClosure:" <+> pdoc platform maybeFunClosure $$
-      text "otherFunLabels:"  <+> pdoc platform otherFunLabels $$
-      text "resolved:"        <+> pdoc platform resolved $$
-      text "allBelow:"        <+> pdoc platform allBelow $$
-      text "filtered0:"       <+> pdoc platform filtered0)
-
-  let
-    isStaticFun = isJust maybeFunClosure
-
-    -- For a label without a closure (e.g. a continuation), we must
-    -- update the SRTMap for the label to point to a closure. It's
-    -- important that we don't do this for static functions or CAFs,
-    -- see Note [Invalid optimisation: shortcutting].
-    updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
-    updateSRTMap srtEntry =
-      srtTrace "updateSRTMap"
-        (pdoc platform srtEntry <+> "isCAF:" <+> ppr isCAF <+>
-         "isStaticFun:" <+> ppr isStaticFun) $
-      when (not isCAF && (not isStaticFun || isNothing srtEntry)) $
-        modify' $ \state ->
-           let !srt_map =
-                 foldl' (\srt_map cafLbl@(CAFfyLabel clbl) ->
-                          -- Only map static data to Nothing (== not CAFFY). For CAFFY
-                          -- statics we refer to the static itself instead of a SRT.
-                          if not (Map.member clbl static_data_env) || isNothing srtEntry then
-                            Map.insert cafLbl srtEntry srt_map
-                          else
-                            srt_map)
-                        (moduleSRTMap state)
-                        caf_lbls
-           in
-               state{ moduleSRTMap = srt_map }
-
-    allStaticData =
-      all (\(CAFfyLabel clbl) -> Map.member clbl static_data_env) caf_lbls
-
-  if Set.null filtered0 then do
-    srtTraceM "oneSRT: empty" (pdoc platform caf_lbls)
-    updateSRTMap Nothing
-    return ([], [], [], NoCafRefs)
-  else do
-    -- We're going to build an SRT for this group, which should include function
-    -- references in the group. See Note [recursive SRTs].
-    let allBelow_funs =
-          Set.fromList (map (SRTEntry . toClosureLbl platform) otherFunLabels)
-    -- We must also ensure that all CAFfy static data constructor applications
-    -- are included. See Note [recursive SRTs] and #20959.
-    let allBelow_data =
-          Set.fromList
-          [ SRTEntry $ toClosureLbl platform lbl
-          | DeclLabel lbl <- lbls
-          , Just refs <- pure $ Map.lookup lbl static_data_env
-          , not $ Set.null refs
-          ]
-    let filtered = filtered0 `Set.union` allBelow_funs `Set.union` allBelow_data
-    srtTraceM "oneSRT" (text "filtered:"      <+> pdoc platform filtered $$
-                        text "allBelow_funs:" <+> pdoc platform allBelow_funs)
-    case Set.toList filtered of
-      [] -> pprPanic "oneSRT" empty -- unreachable
-
-      -- [Inline] - when we have only one entry there is no need to
-      -- build an SRT object at all, instead we put the singleton SRT
-      -- entry in the info table.
-      [one@(SRTEntry lbl)]
-        | -- Info tables refer to SRTs by offset (as noted in the section
-          -- "Referring to an SRT from the info table" of Note [SRTs]). However,
-          -- when dynamic linking is used we cannot guarantee that the offset
-          -- between the SRT and the info table will fit in the offset field.
-          -- Consequently we build a singleton SRT in this case.
-          not (labelDynamic this_mod platform (cmmExternalDynamicRefs cfg) lbl)
-
-          -- MachO relocations can't express offsets between compilation units at
-          -- all, so we are always forced to build a singleton SRT in this case
-          -- (cf #15169)
-            && (not (osMachOTarget $ platformOS $ profilePlatform profile)
-               || isLocalCLabel this_mod lbl) -> do
-
-          -- If we have a static function closure, then it becomes the
-          -- SRT object, and everything else points to it. (the only way
-          -- we could have multiple labels here is if this is a
-          -- recursive group, see Note [recursive SRTs])
-          case maybeFunClosure of
-            Just (staticFunLbl,staticFunBlock) ->
-                return ([], withLabels, [], MayHaveCafRefs)
-              where
-                withLabels =
-                  [ (b, if b == staticFunBlock then lbl else staticFunLbl)
-                  | b <- blockids ]
-            Nothing -> do
-              srtTraceM "oneSRT: one" (text "caf_lbls:" <+> pdoc platform caf_lbls $$
-                                       text "one:"      <+> pdoc platform one)
-              updateSRTMap (Just one)
-              return ([], map (,lbl) blockids, [], MayHaveCafRefs)
-
-      cafList | allStaticData ->
-        let caffiness = if null cafList then NoCafRefs else MayHaveCafRefs
-        in return ([], [], [], caffiness)
-
-      cafList ->
-        -- Check whether an SRT with the same entries has been emitted already.
-        -- Implements the [Common] optimisation.
-        case Map.lookup filtered (dedupSRTs topSRT) of
-          Just srtEntry@(SRTEntry srtLbl)  -> do
-            srtTraceM "oneSRT [Common]" (pdoc platform caf_lbls <+> pdoc platform srtLbl)
-            updateSRTMap (Just srtEntry)
-            return ([], map (,srtLbl) blockids, [], MayHaveCafRefs)
-          Nothing -> do
-            -- No duplicates: we have to build a new SRT object
-            (decls, funSRTs, srtEntry) <-
-              case maybeFunClosure of
-                Just (fun,block) ->
-                  return ( [], [(block, cafList)], SRTEntry fun )
-                Nothing -> do
-                  (decls, entry) <- lift $ buildSRTChain profile cafList
-                  return (decls, [], entry)
-            updateSRTMap (Just srtEntry)
-            let allBelowThis = Set.union allBelow filtered
-                newFlatSRTs = Map.insert srtEntry allBelowThis (flatSRTs topSRT)
-                -- When all definition in this group are static data we don't
-                -- generate any SRTs.
-                newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT)
-            modify' (\state -> state{ dedupSRTs = newDedupSRTs,
-                                      flatSRTs = newFlatSRTs })
-            srtTraceM "oneSRT: new" (text "caf_lbls:"      <+> pdoc platform caf_lbls $$
-                                      text "filtered:"     <+> pdoc platform filtered $$
-                                      text "srtEntry:"     <+> pdoc platform srtEntry $$
-                                      text "newDedupSRTs:" <+> pdoc platform newDedupSRTs $$
-                                      text "newFlatSRTs:"  <+> pdoc platform newFlatSRTs)
-            let SRTEntry lbl = srtEntry
-            return (decls, map (,lbl) blockids, funSRTs, MayHaveCafRefs)
-
-
--- | Build a static SRT object (or a chain of objects) from a list of
--- 'SRTEntry's.
-buildSRTChain
-   :: Profile
-   -> [SRTEntry]
-   -> UniqSM
-        ( [CmmDeclSRTs] -- The SRT object(s)
-        , SRTEntry      -- label to use in the info table
-        )
-buildSRTChain profile cafSet =
-  case splitAt mAX_SRT_SIZE cafSet of
-    ([], _) -> panic "buildSRT: empty"
-    (these, []) -> do
-      (decl,lbl) <- buildSRT profile these
-      return ([decl], lbl)
-    (this:these,those) -> do
-      (rest, rest_lbl) <- buildSRTChain profile (this : those)
-      (decl,lbl) <- buildSRT profile (rest_lbl : these)
-      return (decl:rest, lbl)
-  where
-    mAX_SRT_SIZE = 16
-
-
-buildSRT :: Profile -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)
-buildSRT profile refs = do
-  id <- getUniqueM
-  let
-    lbl = mkSRTLabel id
-    platform = profilePlatform profile
-    srt_n_info = mkSRTInfoLabel (length refs)
-    fields =
-      mkStaticClosure profile srt_n_info dontCareCCS
-        [ CmmLabel lbl | SRTEntry lbl <- refs ]
-        [] -- no padding
-        [mkIntCLit platform 0] -- link field
-        [] -- no saved info
-        [] -- no extras
-  return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
-
--- | Update info tables with references to their SRTs. Also generate
--- static closures, splicing in SRT fields as necessary.
-updInfoSRTs
-  :: Profile
-  -> LabelMap CLabel               -- ^ SRT labels for each block
-  -> LabelMap [SRTEntry]           -- ^ SRTs to merge into FUN_STATIC closures
-  -> CafInfo                       -- ^ Whether the CmmDecl's group has CAF references
-  -> CmmDecl
-  -> [CmmDeclSRTs]
-
-updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics))
-  = [CmmData s (CmmStaticsRaw lbl statics)]
-
-updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload extras))
-  = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))]
-  where
-    field_lits = mkStaticClosureFields profile itbl ccs caffy payload extras
-
-updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)
-  | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]
-  | otherwise = [ proc ]
-  where
-    proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g
-    newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)
-    updInfoTbl l info_tbl
-      | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf
-      | otherwise  = info_tbl { cit_srt = mapLookup l srt_env }
-
-    -- Generate static closures [FUN].  Note that this also generates
-    -- static closures for thunks (CAFs), because it's easier to treat
-    -- them uniformly in the code generator.
-    maybeStaticClosure :: Maybe (CmmInfoTable, CmmDeclSRTs)
-    maybeStaticClosure
-      | Just info_tbl@CmmInfoTable{..} <-
-           mapLookup (g_entry g) (info_tbls top_info)
-      , Just (id, ccs) <- cit_clo
-      , isStaticRep cit_rep =
-        let
-          (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of
-            Nothing ->
-              -- if we don't add SRT entries to this closure, then we
-              -- want to set the srt field in its info table as usual
-              (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, [])
-            Just srtEntries -> srtTrace "maybeStaticFun" (pdoc (profilePlatform profile) res)
-              (info_tbl { cit_rep = new_rep }, res)
-              where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]
-          fields = mkStaticClosureFields profile info_tbl ccs caffy srtEntries []
-          new_rep = case cit_rep of
-             HeapRep sta ptrs nptrs ty ->
-               HeapRep sta (ptrs + length srtEntries) nptrs ty
-             _other -> panic "maybeStaticFun"
-          lbl = mkClosureLabel (idName id) caffy
-        in
-          Just (newInfo, mkDataLits (Section Data lbl) lbl fields)
-      | otherwise = Nothing
-
-
-srtTrace :: String -> SDoc -> b -> b
--- srtTrace = pprTrace
-srtTrace _ _ b = b
-
-srtTraceM :: Applicative f => String -> SDoc -> f ()
-srtTraceM str doc = srtTrace str doc (pure ())
diff --git a/compiler/GHC/Cmm/InitFini.hs b/compiler/GHC/Cmm/InitFini.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/InitFini.hs
+++ /dev/null
@@ -1,78 +0,0 @@
--- | Utilities for dealing with constructors/destructors.
-module GHC.Cmm.InitFini
-    ( InitOrFini(..)
-    , isInitOrFiniArray
-    ) where
-
-import GHC.Prelude
-
-import GHC.Cmm.CLabel
-import GHC.Cmm
-import GHC.Utils.Panic
-import GHC.Utils.Outputable
-
-{-
-Note [Initializers and finalizers in Cmm]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Most platforms support some mechanism for marking a procedure to be run when a
-program is loaded (in which case the procedure is known as an "initializer",
-"constructor", or "ctor") or unloaded (a "finalizer", "deconstructor", or
-"dtor").
-
-For instance, on ELF platforms pointers to initializer and finalizer functions
-are listed in .init_array and .fini_array sections, which are traversed by libc
-during program startup and shutdown.
-
-In GHC-generated code, initializers are used for a few things:
-
- * registration of cost-centres and cost-centre stacks for profiling
- * registration of info-table provenance entries
- * registration of ticky tickers
- * registration of HPC ticks
-
-All of these initializers are implemented as C functions, emitted by the
-compiler as ForeignStubs. Consequently the GHC.Types.ForeignStubs.CStub type
-carries with it lists of functions which should be marked as initializers or
-finalizers.
-
-These initializer and finalizer lists are then turned into CmmData declarations
-which are fed to the backend. These declarations are distinguished by their
-Section (e.g. InitArray or FiniArray) and consist of an array of words, where each
-word is a pointer to an initializer/finalizer function. Since this is the same
-form that most platforms expect initializer or finalizer lists to appear in
-assembler, the NCG backends naturally emit the appropriate assembler.
-
-However, for non-NCG backends (e.g. the C and LLVM backends) these
-initializer/finalizer list declarations need to be detected and dealt with
-appropriately. We provide isInitOrFiniArray to distinguish such declarations
-and turn them back into a list of CLabels.
-
-On Windows initializers/finalizers are a bit tricky due to the inability to
-merge objects (due to the lld linker's lack of `-r` support on Windows; see
-Note [Object merging] in GHC.Driver.Pipeline.Execute) since we instead must
-package foreign stubs into static archives.  However, the linker is free to not
-include any constituent objects of a static library in the final object code if
-nothing depends upon them. Consequently, we must ensure that the initializer
-list for a module is defined in the module's object code, not its foreign
-stubs. This happens naturally with the plan laid out above.
-
-Note that we maintain the invariant that at most one initializer and one
-finalizer CmmDecl will be emitted per module.
--}
-
-data InitOrFini = IsInitArray | IsFiniArray
-
-isInitOrFiniArray :: RawCmmDecl -> Maybe (InitOrFini, [CLabel])
-isInitOrFiniArray (CmmData sect (CmmStaticsRaw _ lits))
-  | Just initOrFini <- isInitOrFiniSection sect
-  = Just (initOrFini, map get_label lits)
-  where
-    get_label :: CmmStatic -> CLabel
-    get_label (CmmStaticLit (CmmLabel lbl)) = lbl
-    get_label static = pprPanic "isInitOrFiniArray: invalid entry" (ppr static)
-isInitOrFiniArray _ = Nothing
-
-isInitOrFiniSection :: Section -> Maybe InitOrFini
-isInitOrFiniSection (Section InitArray _) = Just IsInitArray
-isInitOrFiniSection (Section FiniArray _) = Just IsFiniArray
-isInitOrFiniSection _                     = Nothing
diff --git a/compiler/GHC/Cmm/LRegSet.hs b/compiler/GHC/Cmm/LRegSet.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/LRegSet.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module GHC.Cmm.LRegSet (
-    LRegSet,
-    LRegKey,
-
-    emptyLRegSet,
-    nullLRegSet,
-    insertLRegSet,
-    elemLRegSet,
-
-    deleteFromLRegSet,
-    sizeLRegSet,
-
-    plusLRegSet,
-    elemsLRegSet
-  ) where
-
-import GHC.Prelude
-import GHC.Types.Unique
-import GHC.Cmm.Expr
-
-import Data.IntSet as IntSet
-
--- Compact sets for membership tests of local variables.
-
-type LRegSet = IntSet.IntSet
-type LRegKey = Int
-
-emptyLRegSet :: LRegSet
-emptyLRegSet = IntSet.empty
-
-nullLRegSet :: LRegSet -> Bool
-nullLRegSet = IntSet.null
-
-insertLRegSet :: LocalReg -> LRegSet -> LRegSet
-insertLRegSet l = IntSet.insert (getKey (getUnique l))
-
-elemLRegSet :: LocalReg -> LRegSet -> Bool
-elemLRegSet l = IntSet.member (getKey (getUnique l))
-
-deleteFromLRegSet :: LRegSet -> LocalReg -> LRegSet
-deleteFromLRegSet set reg = IntSet.delete (getKey . getUnique $ reg) set
-
-sizeLRegSet :: IntSet -> Int
-sizeLRegSet = IntSet.size
-
-plusLRegSet :: IntSet -> IntSet -> IntSet
-plusLRegSet = IntSet.union
-
-elemsLRegSet :: IntSet -> [Int]
-elemsLRegSet = IntSet.toList
diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/LayoutStack.hs
+++ /dev/null
@@ -1,1237 +0,0 @@
-{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-}
-module GHC.Cmm.LayoutStack (
-       cmmLayoutStack, setInfoTableStackMap
-  ) where
-
-import GHC.Prelude hiding ((<*>))
-
-import GHC.Platform
-import GHC.Platform.Profile
-
-import GHC.StgToCmm.Monad      ( newTemp  ) -- XXX layering violation
-import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs  ) -- XXX layering violation
-import GHC.StgToCmm.Foreign    ( saveThreadState, loadThreadState ) -- XXX layering violation
-
-import GHC.Cmm
-import GHC.Cmm.Info
-import GHC.Cmm.BlockId
-import GHC.Cmm.Config
-import GHC.Cmm.Utils
-import GHC.Cmm.Graph
-import GHC.Cmm.Liveness
-import GHC.Cmm.ProcPoint
-import GHC.Runtime.Heap.Layout
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
-import GHC.Types.Unique.Supply
-import GHC.Data.Maybe
-import GHC.Types.Unique.FM
-import GHC.Utils.Misc
-
-import GHC.Utils.Outputable hiding ( isEmpty )
-import GHC.Utils.Panic
-import qualified Data.Set as Set
-import Control.Monad.Fix
-import Data.Array as Array
-import Data.List (nub)
-
-{- Note [Stack Layout]
-   ~~~~~~~~~~~~~~~~~~~
-The job of this pass is to
-
- - replace references to abstract stack Areas with fixed offsets from Sp.
-
- - replace the CmmHighStackMark constant used in the stack check with
-   the maximum stack usage of the proc.
-
- - save any variables that are live across a call, and reload them as
-   necessary.
-
-Before stack allocation, local variables remain live across native
-calls (CmmCall{ cmm_cont = Just _ }), and after stack allocation local
-variables are clobbered by native calls.
-
-We want to do stack allocation so that as far as possible
- - stack use is minimized, and
- - unnecessary stack saves and loads are avoided.
-
-The algorithm we use is a variant of linear-scan register allocation,
-where the stack is our register file.
-
-We proceed in two passes, see Note [Two pass approach] for why they are not easy
-to merge into one.
-
-Pass 1:
-
- - First, we do a liveness analysis, which annotates every block with
-   the variables live on entry to the block.
-
- - We traverse blocks in reverse postorder DFS; that is, we visit at
-   least one predecessor of a block before the block itself.  The
-   stack layout flowing from the predecessor of the block will
-   determine the stack layout on entry to the block.
-
- - We maintain a data structure
-
-     Map Label StackMap
-
-   which describes the contents of the stack and the stack pointer on
-   entry to each block that is a successor of a block that we have
-   visited.
-
- - For each block we visit:
-
-    - Look up the StackMap for this block.
-
-    - If this block is a proc point (or a call continuation, if we aren't
-      splitting proc points), we need to reload all the live variables from the
-      stack - but this is done in Pass 2, which calculates more precise liveness
-      information (see description of Pass 2).
-
-    - Walk forwards through the instructions:
-      - At an assignment  x = Sp[loc]
-        - Record the fact that Sp[loc] contains x, so that we won't
-          need to save x if it ever needs to be spilled.
-      - At an assignment  x = E
-        - If x was previously on the stack, it isn't any more
-      - At the last node, if it is a call or a jump to a proc point
-        - Lay out the stack frame for the call (see setupStackFrame)
-        - emit instructions to save all the live variables
-        - Remember the StackMaps for all the successors
-        - emit an instruction to adjust Sp
-      - If the last node is a branch, then the current StackMap is the
-        StackMap for the successors.
-
-    - Manifest Sp: replace references to stack areas in this block
-      with real Sp offsets. We cannot do this until we have laid out
-      the stack area for the successors above.
-
-      In this phase we also eliminate redundant stores to the stack;
-      see elimStackStores.
-
-  - There is one important gotcha: sometimes we'll encounter a control
-    transfer to a block that we've already processed (a join point),
-    and in that case we might need to rearrange the stack to match
-    what the block is expecting. (exactly the same as in linear-scan
-    register allocation, except here we have the luxury of an infinite
-    supply of temporary variables).
-
-  - Finally, we update the magic CmmHighStackMark constant with the
-    stack usage of the function, and eliminate the whole stack check
-    if there was no stack use. (in fact this is done as part of the
-    main traversal, by feeding the high-water-mark output back in as
-    an input. I hate cyclic programming, but it's just too convenient
-    sometimes.)
-
-  There are plenty of tricky details: update frames, proc points, return
-  addresses, foreign calls, and some ad-hoc optimisations that are
-  convenient to do here and effective in common cases.  Comments in the
-  code below explain these.
-
-Pass 2:
-
-- Calculate live registers, but taking into account that nothing is live at the
-  entry to a proc point.
-
-- At each proc point and call continuation insert reloads of live registers from
-  the stack (they were saved by Pass 1).
-
-
-Note [Two pass approach]
-~~~~~~~~~~~~~~~~~~~~~~~~
-The main reason for Pass 2 is being able to insert only the reloads that are
-needed and the fact that the two passes need different liveness information.
-Let's consider an example:
-
-  .....
-   \ /
-    D   <- proc point
-   / \
-  E   F
-   \ /
-    G   <- proc point
-    |
-    X
-
-Pass 1 needs liveness assuming that local variables are preserved across calls.
-This is important because it needs to save any local registers to the stack
-(e.g., if register a is used in block X, it must be saved before any native
-call).
-However, for Pass 2, where we want to reload registers from stack (in a proc
-point), this is overly conservative and would lead us to generate reloads in D
-for things used in X, even though we're going to generate reloads in G anyway
-(since it's also a proc point).
-So Pass 2 calculates liveness knowing that nothing is live at the entry to a
-proc point. This means that in D we only need to reload things used in E or F.
-This can be quite important, for an extreme example see testcase for #3294.
-
-Merging the two passes is not trivial - Pass 2 is a backward rewrite and Pass 1
-is a forward one. Furthermore, Pass 1 is creating code that uses local registers
-(saving them before a call), which the liveness analysis for Pass 2 must see to
-be correct.
-
--}
-
-
--- All stack locations are expressed as positive byte offsets from the
--- "base", which is defined to be the address above the return address
--- on the stack on entry to this CmmProc.
---
--- Lower addresses have higher StackLocs.
---
-type StackLoc = ByteOff
-
-{-
- A StackMap describes the stack at any given point.  At a continuation
- it has a particular layout, like this:
-
-         |             | <- base
-         |-------------|
-         |     ret0    | <- base + 8
-         |-------------|
-         .  upd frame  . <- base + sm_ret_off
-         |-------------|
-         |             |
-         .    vars     .
-         . (live/dead) .
-         |             | <- base + sm_sp - sm_args
-         |-------------|
-         |    ret1     |
-         .  ret vals   . <- base + sm_sp    (<--- Sp points here)
-         |-------------|
-
-Why do we include the final return address (ret0) in our stack map?  I
-have absolutely no idea, but it seems to be done that way consistently
-in the rest of the code generator, so I played along here. --SDM
-
-Note that we will be constructing an info table for the continuation
-(ret1), which needs to describe the stack down to, but not including,
-the update frame (or ret0, if there is no update frame).
--}
-
-data StackMap = StackMap
- {  sm_sp   :: StackLoc
-       -- ^ the offset of Sp relative to the base on entry
-       -- to this block.
- ,  sm_args :: ByteOff
-       -- ^ the number of bytes of arguments in the area for this block
-       -- Defn: the offset of young(L) relative to the base is given by
-       -- (sm_sp - sm_args) of the StackMap for block L.
- ,  sm_ret_off :: ByteOff
-       -- ^ Number of words of stack that we do not describe with an info
-       -- table, because it contains an update frame.
- ,  sm_regs :: UniqFM LocalReg (LocalReg,StackLoc)
-       -- ^ regs on the stack
- }
-
-instance Outputable StackMap where
-  ppr StackMap{..} =
-     text "Sp = " <> int sm_sp $$
-     text "sm_args = " <> int sm_args $$
-     text "sm_ret_off = " <> int sm_ret_off $$
-     text "sm_regs = " <> pprUFM sm_regs ppr
-
-
-cmmLayoutStack :: CmmConfig -> ProcPointSet -> ByteOff -> CmmGraph
-               -> UniqSM (CmmGraph, LabelMap StackMap)
-cmmLayoutStack cfg procpoints entry_args
-               graph@(CmmGraph { g_entry = entry })
-  = do
-    -- We need liveness info. Dead assignments are removed later
-    -- by the sinking pass.
-    let liveness = cmmLocalLiveness platform graph
-        blocks   = revPostorder graph
-        profile  = cmmProfile   cfg
-        platform = profilePlatform profile
-
-    (final_stackmaps, _final_high_sp, new_blocks) <-
-          mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
-            layout cfg procpoints liveness entry entry_args
-                   rec_stackmaps rec_high_sp blocks
-
-    blocks_with_reloads <-
-        insertReloadsAsNeeded platform procpoints final_stackmaps entry new_blocks
-    new_blocks' <- mapM (lowerSafeForeignCall profile) blocks_with_reloads
-    return (ofBlockList entry new_blocks', final_stackmaps)
-
--- -----------------------------------------------------------------------------
--- Pass 1
--- -----------------------------------------------------------------------------
-
-layout :: CmmConfig
-       -> LabelSet                      -- proc points
-       -> LabelMap CmmLocalLive         -- liveness
-       -> BlockId                       -- entry
-       -> ByteOff                       -- stack args on entry
-
-       -> LabelMap StackMap             -- [final] stack maps
-       -> ByteOff                       -- [final] Sp high water mark
-
-       -> [CmmBlock]                    -- [in] blocks
-
-       -> UniqSM
-          ( LabelMap StackMap           -- [out] stack maps
-          , ByteOff                     -- [out] Sp high water mark
-          , [CmmBlock]                  -- [out] new blocks
-          )
-
-layout cfg procpoints liveness entry entry_args final_stackmaps final_sp_high blocks
-  = go blocks init_stackmap entry_args []
-  where
-    (updfr, cont_info)  = collectContInfo blocks
-
-    init_stackmap = mapSingleton entry StackMap{ sm_sp   = entry_args
-                                               , sm_args = entry_args
-                                               , sm_ret_off = updfr
-                                               , sm_regs = emptyUFM
-                                               }
-
-    go [] acc_stackmaps acc_hwm acc_blocks
-      = return (acc_stackmaps, acc_hwm, acc_blocks)
-
-    go (b0 : bs) acc_stackmaps acc_hwm acc_blocks
-      = do
-       let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0
-
-       let stack0@StackMap { sm_sp = sp0 }
-               = mapFindWithDefault
-                     (pprPanic "no stack map for" (ppr entry_lbl))
-                     entry_lbl acc_stackmaps
-
-       -- (a) Update the stack map to include the effects of
-       --     assignments in this block
-       let stack1 = foldBlockNodesF (procMiddle acc_stackmaps) middle0 stack0
-
-       -- (b) Look at the last node and if we are making a call or
-       --     jumping to a proc point, we must save the live
-       --     variables, adjust Sp, and construct the StackMaps for
-       --     each of the successor blocks.  See handleLastNode for
-       --     details.
-       (middle1, sp_off, last1, fixup_blocks, out)
-           <- handleLastNode cfg procpoints liveness cont_info
-                             acc_stackmaps stack1 tscope middle0 last0
-
-       -- (c) Manifest Sp: run over the nodes in the block and replace
-       --     CmmStackSlot with CmmLoad from Sp with a concrete offset.
-       --
-       -- our block:
-       --    middle0          -- the original middle nodes
-       --    middle1          -- live variable saves from handleLastNode
-       --    Sp = Sp + sp_off -- Sp adjustment goes here
-       --    last1            -- the last node
-       --
-       let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1
-
-       let final_blocks =
-               manifestSp cfg final_stackmaps stack0 sp0 final_sp_high
-                          entry0 middle_pre sp_off last1 fixup_blocks
-
-       let acc_stackmaps' = mapUnion acc_stackmaps out
-
-           -- If this block jumps to the GC, then we do not take its
-           -- stack usage into account for the high-water mark.
-           -- Otherwise, if the only stack usage is in the stack-check
-           -- failure block itself, we will do a redundant stack
-           -- check.  The stack has a buffer designed to accommodate
-           -- the largest amount of stack needed for calling the GC.
-           --
-           this_sp_hwm | isGcJump last0 = 0
-                       | otherwise      = sp0 - sp_off
-
-           hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out))
-
-       go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks)
-
-
--- -----------------------------------------------------------------------------
-
--- Not foolproof, but GCFun is the culprit we most want to catch
-isGcJump :: CmmNode O C -> Bool
-isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) })
-  = l == GCFun || l == GCEnter1
-isGcJump _something_else = False
-
--- -----------------------------------------------------------------------------
-
--- This doesn't seem right somehow.  We need to find out whether this
--- proc will push some update frame material at some point, so that we
--- can avoid using that area of the stack for spilling. Ideally we would
--- capture this information in the CmmProc (e.g. in CmmStackInfo; see #18232
--- for details on one ill-fated attempt at this).
---
--- So we'll just take the max of all the cml_ret_offs.  This could be
--- unnecessarily pessimistic, but probably not in the code we
--- generate.
-
-collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff)
-collectContInfo blocks
-  = (maximum ret_offs, mapFromList (catMaybes mb_argss))
- where
-  (mb_argss, ret_offs) = mapAndUnzip get_cont blocks
-
-  get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)
-  get_cont b =
-     case lastNode b of
-        CmmCall { cml_cont = Just l, .. }
-           -> (Just (l, cml_ret_args), cml_ret_off)
-        CmmForeignCall { .. }
-           -> (Just (succ, ret_args), ret_off)
-        _other -> (Nothing, 0)
-
-
--- -----------------------------------------------------------------------------
--- Updating the StackMap from middle nodes
-
--- Look for loads from stack slots, and update the StackMap.  This is
--- purely for optimisation reasons, so that we can avoid saving a
--- variable back to a different stack slot if it is already on the
--- stack.
---
--- This happens a lot: for example when function arguments are passed
--- on the stack and need to be immediately saved across a call, we
--- want to just leave them where they are on the stack.
---
-procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
-procMiddle stackmaps node sm
-  = case node of
-     CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _ _)
-       -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) }
-        where loc = getStackLoc area off stackmaps
-     CmmAssign (CmmLocal r) _other
-       -> sm { sm_regs = delFromUFM (sm_regs sm) r }
-     _other
-       -> sm
-
-getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc
-getStackLoc Old       n _         = n
-getStackLoc (Young l) n stackmaps =
-  case mapLookup l stackmaps of
-    Nothing -> pprPanic "getStackLoc" (ppr l)
-    Just sm -> sm_sp sm - sm_args sm + n
-
-
--- -----------------------------------------------------------------------------
--- Handling stack allocation for a last node
-
--- We take a single last node and turn it into:
---
---    C1 (some statements)
---    Sp = Sp + N
---    C2 (some more statements)
---    call f()          -- the actual last node
---
--- plus possibly some more blocks (we may have to add some fixup code
--- between the last node and the continuation).
---
--- C1: is the code for saving the variables across this last node onto
--- the stack, if the continuation is a call or jumps to a proc point.
---
--- C2: if the last node is a safe foreign call, we have to inject some
--- extra code that goes *after* the Sp adjustment.
-
-handleLastNode
-   :: CmmConfig -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff
-   -> LabelMap StackMap -> StackMap -> CmmTickScope
-   -> Block CmmNode O O
-   -> CmmNode O C
-   -> UniqSM
-      ( [CmmNode O O]      -- nodes to go *before* the Sp adjustment
-      , ByteOff            -- amount to adjust Sp
-      , CmmNode O C        -- new last node
-      , [CmmBlock]         -- new blocks
-      , LabelMap StackMap  -- stackmaps for the continuations
-      )
-
-handleLastNode cfg procpoints liveness cont_info stackmaps
-               stack0@StackMap { sm_sp = sp0 } tscp middle last
-  = case last of
-      --  At each return / tail call,
-      --  adjust Sp to point to the last argument pushed, which
-      --  is cml_args, after popping any other junk from the stack.
-      CmmCall{ cml_cont = Nothing, .. } -> do
-        let sp_off = sp0 - cml_args
-        return ([], sp_off, last, [], mapEmpty)
-
-      --  At each CmmCall with a continuation:
-      CmmCall{ cml_cont = Just cont_lbl, .. } ->
-        return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off
-
-      CmmForeignCall{ succ = cont_lbl, .. } ->
-        return $ lastCall cont_lbl (platformWordSizeInBytes platform) ret_args ret_off
-              -- one word of args: the return address
-
-      CmmBranch {}     ->  handleBranches
-      CmmCondBranch {} ->  handleBranches
-      CmmSwitch {}     ->  handleBranches
-  where
-     platform = cmmPlatform cfg
-     -- Calls and ForeignCalls are handled the same way:
-     lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff
-              -> ( [CmmNode O O]
-                 , ByteOff
-                 , CmmNode O C
-                 , [CmmBlock]
-                 , LabelMap StackMap
-                 )
-     lastCall lbl cml_args cml_ret_args cml_ret_off
-      =  ( assignments
-         , spOffsetForCall sp0 cont_stack cml_args
-         , last
-         , [] -- no new blocks
-         , mapSingleton lbl cont_stack )
-      where
-         (assignments, cont_stack) = prepareStack lbl cml_ret_args cml_ret_off
-
-
-     prepareStack lbl cml_ret_args cml_ret_off
-       | Just cont_stack <- mapLookup lbl stackmaps
-             -- If we have already seen this continuation before, then
-             -- we just have to make the stack look the same:
-       = (fixupStack stack0 cont_stack, cont_stack)
-             -- Otherwise, we have to allocate the stack frame
-       | otherwise
-       = (save_assignments, new_cont_stack)
-       where
-        (new_cont_stack, save_assignments)
-           = setupStackFrame platform lbl liveness cml_ret_off cml_ret_args stack0
-
-
-     -- For other last nodes (branches), if any of the targets is a
-     -- proc point, we have to set up the stack to match what the proc
-     -- point is expecting.
-     --
-     handleBranches :: UniqSM ( [CmmNode O O]
-                                , ByteOff
-                                , CmmNode O C
-                                , [CmmBlock]
-                                , LabelMap StackMap )
-
-     handleBranches
-         -- See Note [diamond proc point]
-       | Just l <- futureContinuation middle
-       , (nub $ filter (`setMember` procpoints) $ successors last) == [l]
-       = do
-         let cont_args = mapFindWithDefault 0 l cont_info
-             (assigs, cont_stack) = prepareStack l cont_args (sm_ret_off stack0)
-             out = mapFromList [ (l', cont_stack)
-                               | l' <- successors last ]
-         return ( assigs
-                , spOffsetForCall sp0 cont_stack (platformWordSizeInBytes platform)
-                , last
-                , []
-                , out)
-
-        | otherwise = do
-          pps <- mapM handleBranch (successors last)
-          let lbl_map :: LabelMap Label
-              lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ]
-              fix_lbl l = mapFindWithDefault l l lbl_map
-          return ( []
-                 , 0
-                 , mapSuccessors fix_lbl last
-                 , concat [ blk | (_,_,_,blk) <- pps ]
-                 , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )
-
-     -- For each successor of this block
-     handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
-     handleBranch l
-        --   (a) if the successor already has a stackmap, we need to
-        --       shuffle the current stack to make it look the same.
-        --       We have to insert a new block to make this happen.
-        | Just stack2 <- mapLookup l stackmaps
-        = do
-             let assigs = fixupStack stack0 stack2
-             (tmp_lbl, block) <- makeFixupBlock cfg sp0 l stack2 tscp assigs
-             return (l, tmp_lbl, stack2, block)
-
-        --   (b) if the successor is a proc point, save everything
-        --       on the stack.
-        | l `setMember` procpoints
-        = do
-             let cont_args = mapFindWithDefault 0 l cont_info
-                 (stack2, assigs) =
-                      setupStackFrame platform l liveness (sm_ret_off stack0)
-                                                        cont_args stack0
-             (tmp_lbl, block) <- makeFixupBlock cfg sp0 l stack2 tscp assigs
-             return (l, tmp_lbl, stack2, block)
-
-        --   (c) otherwise, the current StackMap is the StackMap for
-        --       the continuation.  But we must remember to remove any
-        --       variables from the StackMap that are *not* live at
-        --       the destination, because this StackMap might be used
-        --       by fixupStack if this is a join point.
-        | otherwise = return (l, l, stack1, [])
-        where live = mapFindWithDefault (panic "handleBranch") l liveness
-              stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) }
-              is_live (r,_) = r `elemRegSet` live
-
-
-makeFixupBlock :: CmmConfig -> ByteOff -> Label -> StackMap
-               -> CmmTickScope -> [CmmNode O O]
-               -> UniqSM (Label, [CmmBlock])
-makeFixupBlock cfg sp0 l stack tscope assigs
-  | null assigs && sp0 == sm_sp stack = return (l, [])
-  | otherwise = do
-    tmp_lbl <- newBlockId
-    let sp_off = sp0 - sm_sp stack
-        block = blockJoin (CmmEntry tmp_lbl tscope)
-                          ( maybeAddSpAdj cfg sp0 sp_off
-                           $ blockFromList assigs )
-                          (CmmBranch l)
-    return (tmp_lbl, [block])
-
-
--- Sp is currently pointing to current_sp,
--- we want it to point to
---    (sm_sp cont_stack - sm_args cont_stack + args)
--- so the difference is
---    sp0 - (sm_sp cont_stack - sm_args cont_stack + args)
-spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff
-spOffsetForCall current_sp cont_stack args
-  = current_sp - (sm_sp cont_stack - sm_args cont_stack + args)
-
-
--- | create a sequence of assignments to establish the new StackMap,
--- given the old StackMap.
-fixupStack :: StackMap -> StackMap -> [CmmNode O O]
-fixupStack old_stack new_stack = concatMap move new_locs
- where
-     old_map  = sm_regs old_stack
-     new_locs = stackSlotRegs new_stack
-
-     move (r,n)
-       | Just (_,m) <- lookupUFM old_map r, n == m = []
-       | otherwise = [CmmStore (CmmStackSlot Old n)
-                               (CmmReg (CmmLocal r))
-                               NaturallyAligned]
-
-
-
-setupStackFrame
-             :: Platform
-             -> BlockId                 -- label of continuation
-             -> LabelMap CmmLocalLive   -- liveness
-             -> ByteOff      -- updfr
-             -> ByteOff      -- bytes of return values on stack
-             -> StackMap     -- current StackMap
-             -> (StackMap, [CmmNode O O])
-
-setupStackFrame platform lbl liveness updfr_off ret_args stack0
-  = (cont_stack, assignments)
-  where
-      -- get the set of LocalRegs live in the continuation
-      live = mapFindWithDefault Set.empty lbl liveness
-
-      -- the stack from the base to updfr_off is off-limits.
-      -- our new stack frame contains:
-      --   * saved live variables
-      --   * the return address [young(C) + 8]
-      --   * the args for the call,
-      --     which are replaced by the return values at the return
-      --     point.
-
-      -- everything up to updfr_off is off-limits
-      -- stack1 contains updfr_off, plus everything we need to save
-      (stack1, assignments) = allocate platform updfr_off live stack0
-
-      -- And the Sp at the continuation is:
-      --   sm_sp stack1 + ret_args
-      cont_stack = stack1{ sm_sp = sm_sp stack1 + ret_args
-                         , sm_args = ret_args
-                         , sm_ret_off = updfr_off
-                         }
-
-
--- Note [diamond proc point]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~
--- This special case looks for the pattern we get from a typical
--- tagged case expression:
---
---    Sp[young(L1)] = L1
---    if (R1 & 7) != 0 goto L1 else goto L2
---  L2:
---    call [R1] returns to L1
---  L1: live: {y}
---    x = R1
---
--- If we let the generic case handle this, we get
---
---    Sp[-16] = L1
---    if (R1 & 7) != 0 goto L1a else goto L2
---  L2:
---    Sp[-8] = y
---    Sp = Sp - 16
---    call [R1] returns to L1
---  L1a:
---    Sp[-8] = y
---    Sp = Sp - 16
---    goto L1
---  L1:
---    x = R1
---
--- The code for saving the live vars is duplicated in each branch, and
--- furthermore there is an extra jump in the fast path (assuming L1 is
--- a proc point, which it probably is if there is a heap check).
---
--- So to fix this we want to set up the stack frame before the
--- conditional jump.  How do we know when to do this, and when it is
--- safe?  The basic idea is, when we see the assignment
---
---   Sp[young(L)] = L
---
--- we know that
---   * we are definitely heading for L
---   * there can be no more reads from another stack area, because young(L)
---     overlaps with it.
---
--- We don't necessarily know that everything live at L is live now
--- (some might be assigned between here and the jump to L).  So we
--- simplify and only do the optimisation when we see
---
---   (1) a block containing an assignment of a return address L
---   (2) ending in a branch where one (and only) continuation goes to L,
---       and no other continuations go to proc points.
---
--- then we allocate the stack frame for L at the end of the block,
--- before the branch.
---
--- We could generalise (2), but that would make it a bit more
--- complicated to handle, and this currently catches the common case.
-
-futureContinuation :: Block CmmNode O O -> Maybe BlockId
-futureContinuation middle = foldBlockNodesB f middle Nothing
-   where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId
-         f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _)) _) _
-               = Just l
-         f _ r = r
-
--- -----------------------------------------------------------------------------
--- Saving live registers
-
--- | Given a set of live registers and a StackMap, save all the registers
--- on the stack and return the new StackMap and the assignments to do
--- the saving.
---
-allocate :: Platform -> ByteOff -> LocalRegSet -> StackMap
-         -> (StackMap, [CmmNode O O])
-allocate platform ret_off live stackmap@StackMap{ sm_sp = sp0
-                                              , sm_regs = regs0 }
- =
-   -- we only have to save regs that are not already in a slot
-   let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live)
-       regs1   = filterUFM (\(r,_) -> elemRegSet r live) regs0
-   in
-
-   -- make a map of the stack
-   let stack = reverse $ Array.elems $
-               accumArray (\_ x -> x) Empty (1, toWords platform (max sp0 ret_off)) $
-                 ret_words ++ live_words
-            where ret_words =
-                   [ (x, Occupied)
-                   | x <- [ 1 .. toWords platform ret_off] ]
-                  live_words =
-                   [ (toWords platform x, Occupied)
-                   | (r,off) <- nonDetEltsUFM regs1,
-                   -- See Note [Unique Determinism and code generation]
-                     let w = localRegBytes platform r,
-                     x <- [ off, off - platformWordSizeInBytes platform .. off - w + 1] ]
-   in
-
-   -- Pass over the stack: find slots to save all the new live variables,
-   -- choosing the oldest slots first (hence a foldr).
-   let
-       save slot ([], stack, n, assigs, regs) -- no more regs to save
-          = ([], slot:stack, plusW platform n 1, assigs, regs)
-       save slot (to_save, stack, n, assigs, regs)
-          = case slot of
-               Occupied ->  (to_save, Occupied:stack, plusW platform n 1, assigs, regs)
-               Empty
-                 | Just (stack', r, to_save') <-
-                       select_save to_save (slot:stack)
-                 -> let assig = CmmStore (CmmStackSlot Old n')
-                                         (CmmReg (CmmLocal r))
-                                         NaturallyAligned
-                        n' = plusW platform n 1
-                   in
-                        (to_save', stack', n', assig : assigs, (r,(r,n')):regs)
-
-                 | otherwise
-                 -> (to_save, slot:stack, plusW platform n 1, assigs, regs)
-
-       -- we should do better here: right now we'll fit the smallest first,
-       -- but it would make more sense to fit the biggest first.
-       select_save :: [LocalReg] -> [StackSlot]
-                   -> Maybe ([StackSlot], LocalReg, [LocalReg])
-       select_save regs stack = go regs []
-         where go []     _no_fit = Nothing
-               go (r:rs) no_fit
-                 | Just rest <- dropEmpty words stack
-                 = Just (replicate words Occupied ++ rest, r, rs++no_fit)
-                 | otherwise
-                 = go rs (r:no_fit)
-                 where words = localRegWords platform r
-
-       -- fill in empty slots as much as possible
-       (still_to_save, save_stack, n, save_assigs, save_regs)
-          = foldr save (to_save, [], 0, [], []) stack
-
-       -- push any remaining live vars on the stack
-       (push_sp, push_assigs, push_regs)
-          = foldr push (n, [], []) still_to_save
-          where
-              push r (n, assigs, regs)
-                = (n', assig : assigs, (r,(r,n')) : regs)
-                where
-                  n' = n + localRegBytes platform r
-                  assig = CmmStore (CmmStackSlot Old n')
-                                   (CmmReg (CmmLocal r))
-                                   NaturallyAligned
-
-       trim_sp
-          | not (null push_regs) = push_sp
-          | otherwise
-          = plusW platform n (- length (takeWhile isEmpty save_stack))
-
-       final_regs = regs1 `addListToUFM` push_regs
-                          `addListToUFM` save_regs
-
-   in
-  -- XXX should be an assert
-   if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else
-
-   if (trim_sp .&. (platformWordSizeInBytes platform - 1)) /= 0  then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
-
-   ( stackmap { sm_regs = final_regs , sm_sp = trim_sp }
-   , push_assigs ++ save_assigs )
-
-
--- -----------------------------------------------------------------------------
--- Manifesting Sp
-
--- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp.  The
--- block looks like this:
---
---    middle_pre       -- the middle nodes
---    Sp = Sp + sp_off -- Sp adjustment goes here
---    last             -- the last node
---
--- And we have some extra blocks too (that don't contain Sp adjustments)
---
--- The adjustment for middle_pre will be different from that for
--- middle_post, because the Sp adjustment intervenes.
---
-manifestSp
-   :: CmmConfig
-   -> LabelMap StackMap  -- StackMaps for other blocks
-   -> StackMap           -- StackMap for this block
-   -> ByteOff            -- Sp on entry to the block
-   -> ByteOff            -- SpHigh
-   -> CmmNode C O        -- first node
-   -> [CmmNode O O]      -- middle
-   -> ByteOff            -- sp_off
-   -> CmmNode O C        -- last node
-   -> [CmmBlock]         -- new blocks
-   -> [CmmBlock]         -- final blocks with Sp manifest
-
-manifestSp cfg stackmaps stack0 sp0 sp_high
-           first middle_pre sp_off last fixup_blocks
-  = final_block : fixup_blocks'
-  where
-    area_off = getAreaOff stackmaps
-    platform = cmmPlatform cfg
-
-    adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
-    adj_pre_sp  = mapExpDeep (areaToSp platform sp0            sp_high area_off)
-    adj_post_sp = mapExpDeep (areaToSp platform (sp0 - sp_off) sp_high area_off)
-
-    final_middle = maybeAddSpAdj cfg sp0 sp_off
-                 . blockFromList
-                 . map adj_pre_sp
-                 . elimStackStores stack0 stackmaps area_off
-                 $ middle_pre
-    final_last    = optStackCheck (adj_post_sp last)
-
-    final_block   = blockJoin first final_middle final_last
-
-    fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks
-
-getAreaOff :: LabelMap StackMap -> (Area -> StackLoc)
-getAreaOff _ Old = 0
-getAreaOff stackmaps (Young l) =
-  case mapLookup l stackmaps of
-    Just sm -> sm_sp sm - sm_args sm
-    Nothing -> pprPanic "getAreaOff" (ppr l)
-
-
-maybeAddSpAdj
-  :: CmmConfig -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
-maybeAddSpAdj cfg sp0 sp_off block =
-  add_initial_unwind $ add_adj_unwind $ adj block
-  where
-    platform             = cmmPlatform            cfg
-    do_stk_unwinding_gen = cmmGenStackUnwindInstr cfg
-    adj block
-      | sp_off /= 0
-      = block `blockSnoc` CmmAssign spReg (cmmOffset platform spExpr sp_off)
-      | otherwise = block
-    -- Add unwind pseudo-instruction at the beginning of each block to
-    -- document Sp level for debugging
-    add_initial_unwind block
-      | do_stk_unwinding_gen
-      = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block
-      | otherwise
-      = block
-      where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform)
-
-    -- Add unwind pseudo-instruction right after the Sp adjustment
-    -- if there is one.
-    add_adj_unwind block
-      | do_stk_unwinding_gen
-      , sp_off /= 0
-      = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]
-      | otherwise
-      = block
-      where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform - sp_off)
-
-{- Note [SP old/young offsets]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Sp(L) is the Sp offset on entry to block L relative to the base of the
-OLD area.
-
-SpArgs(L) is the size of the young area for L, i.e. the number of
-arguments.
-
- - in block L, each reference to [old + N] turns into
-   [Sp + Sp(L) - N]
-
- - in block L, each reference to [young(L') + N] turns into
-   [Sp + Sp(L) - Sp(L') + SpArgs(L') - N]
-
- - be careful with the last node of each block: Sp has already been adjusted
-   to be Sp + Sp(L) - Sp(L')
--}
-
-areaToSp :: Platform -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
-
-areaToSp platform sp_old _sp_hwm area_off (CmmStackSlot area n)
-  = cmmOffset platform spExpr (sp_old - area_off area - n)
-    -- Replace (CmmStackSlot area n) with an offset from Sp
-
-areaToSp platform _ sp_hwm _ (CmmLit CmmHighStackMark)
-  = mkIntExpr platform sp_hwm
-    -- Replace CmmHighStackMark with the number of bytes of stack used,
-    -- the sp_hwm.   See Note [Stack usage] in GHC.StgToCmm.Heap
-
-areaToSp platform _ _ _ (CmmMachOp (MO_U_Lt _) args)
-  | falseStackCheck args
-  = zeroExpr platform
-areaToSp platform _ _ _ (CmmMachOp (MO_U_Ge _) args)
-  | falseStackCheck args
-  = mkIntExpr platform 1
-    -- Replace a stack-overflow test that cannot fail with a no-op
-    -- See Note [Always false stack check]
-
-areaToSp _ _ _ _ other = other
-
--- | Determine whether a stack check cannot fail.
-falseStackCheck :: [CmmExpr] -> Bool
-falseStackCheck [ CmmMachOp (MO_Sub _)
-                      [ CmmRegOff (CmmGlobal Sp) x_off
-                      , CmmLit (CmmInt y_lit _)]
-                , CmmReg (CmmGlobal SpLim)]
-  = fromIntegral x_off >= y_lit
-falseStackCheck _ = False
-
--- Note [Always false stack check]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- We can optimise stack checks of the form
---
---   if ((Sp + x) - y < SpLim) then .. else ..
---
--- where are non-negative integer byte offsets.  Since we know that
--- SpLim <= Sp (remember the stack grows downwards), this test must
--- yield False if (x >= y), so we can rewrite the comparison to False.
--- A subsequent sinking pass will later drop the dead code.
--- Optimising this away depends on knowing that SpLim <= Sp, so it is
--- really the job of the stack layout algorithm, hence we do it now.
---
--- The control flow optimiser may negate a conditional to increase
--- the likelihood of a fallthrough if the branch is not taken.  But
--- not every conditional is inverted as the control flow optimiser
--- places some requirements on the predecessors of both branch targets.
--- So we better look for the inverted comparison too.
-
-optStackCheck :: CmmNode O C -> CmmNode O C
-optStackCheck n = -- Note [Always false stack check]
- case n of
-   CmmCondBranch (CmmLit (CmmInt 0 _)) _true false _ -> CmmBranch false
-   CmmCondBranch (CmmLit (CmmInt _ _)) true _false _ -> CmmBranch true
-   other -> other
-
-
--- -----------------------------------------------------------------------------
-
--- | Eliminate stores of the form
---
---    Sp[area+n] = r
---
--- when we know that r is already in the same slot as Sp[area+n].  We
--- could do this in a later optimisation pass, but that would involve
--- a separate analysis and we already have the information to hand
--- here.  It helps clean up some extra stack stores in common cases.
---
--- Note that we may have to modify the StackMap as we walk through the
--- code using procMiddle, since an assignment to a variable in the
--- StackMap will invalidate its mapping there.
---
-elimStackStores :: StackMap
-                -> LabelMap StackMap
-                -> (Area -> ByteOff)
-                -> [CmmNode O O]
-                -> [CmmNode O O]
-elimStackStores stackmap stackmaps area_off nodes
-  = go stackmap nodes
-  where
-    go _stackmap [] = []
-    go stackmap (n:ns)
-     = case n of
-         CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r)) _
-            | Just (_,off) <- lookupUFM (sm_regs stackmap) r
-            , area_off area + m == off
-            -> go stackmap ns
-         _otherwise
-            -> n : go (procMiddle stackmaps n stackmap) ns
-
-
--- -----------------------------------------------------------------------------
--- Update info tables to include stack liveness
-
-
-setInfoTableStackMap :: Platform -> LabelMap StackMap -> CmmDecl -> CmmDecl
-setInfoTableStackMap platform stackmaps (CmmProc top_info@TopInfo{..} l v g)
-  = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
-  where
-    fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
-       info_tbl { cit_rep = StackRep (get_liveness lbl) }
-    fix_info _ other = other
-
-    get_liveness :: BlockId -> Liveness
-    get_liveness lbl
-      = case mapLookup lbl stackmaps of
-          Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> pdoc platform info_tbls)
-          Just sm -> stackMapToLiveness platform sm
-
-setInfoTableStackMap _ _ d = d
-
-
-stackMapToLiveness :: Platform -> StackMap -> Liveness
-stackMapToLiveness platform StackMap{..} =
-   reverse $ Array.elems $
-        accumArray (\_ x -> x) True (toWords platform sm_ret_off + 1,
-                                     toWords platform (sm_sp - sm_args)) live_words
-   where
-     live_words =  [ (toWords platform off, False)
-                   | (r,off) <- nonDetEltsUFM sm_regs
-                   , isGcPtrType (localRegType r) ]
-                   -- See Note [Unique Determinism and code generation]
-
--- -----------------------------------------------------------------------------
--- Pass 2
--- -----------------------------------------------------------------------------
-
-insertReloadsAsNeeded
-    :: Platform
-    -> ProcPointSet
-    -> LabelMap StackMap
-    -> BlockId
-    -> [CmmBlock]
-    -> UniqSM [CmmBlock]
-insertReloadsAsNeeded platform procpoints final_stackmaps entry blocks =
-    toBlockList . fst <$>
-        rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty
-  where
-    rewriteCC :: RewriteFun CmmLocalLive
-    rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do
-        let entry_label = entryLabel e_node
-            stackmap = case mapLookup entry_label final_stackmaps of
-                Just sm -> sm
-                Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap"
-
-            -- Merge the liveness from successor blocks and analyse the last
-            -- node.
-            joined = gen_kill platform x_node $!
-                         joinOutFacts liveLattice x_node fact_base0
-            -- What is live at the start of middle0.
-            live_at_middle0 = foldNodesBwdOO (gen_kill platform) middle0 joined
-
-            -- If this is a procpoint we need to add the reloads, but only if
-            -- they're actually live. Furthermore, nothing is live at the entry
-            -- to a proc point.
-            (middle1, live_with_reloads)
-                | entry_label `setMember` procpoints
-                = let reloads = insertReloads platform stackmap live_at_middle0
-                  in (foldr blockCons middle0 reloads, emptyRegSet)
-                | otherwise
-                = (middle0, live_at_middle0)
-
-            -- Final liveness for this block.
-            !fact_base2 = mapSingleton entry_label live_with_reloads
-
-        return (BlockCC e_node middle1 x_node, fact_base2)
-
-insertReloads :: Platform -> StackMap -> CmmLocalLive -> [CmmNode O O]
-insertReloads platform stackmap live =
-     [ CmmAssign (CmmLocal reg)
-                 -- This cmmOffset basically corresponds to manifesting
-                 -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]
-                 (CmmLoad (cmmOffset platform spExpr (sp_off - reg_off))
-                          (localRegType reg)
-                          NaturallyAligned)
-     | (reg, reg_off) <- stackSlotRegs stackmap
-     , reg `elemRegSet` live
-     ]
-   where
-     sp_off = sm_sp stackmap
-
--- -----------------------------------------------------------------------------
--- Lowering safe foreign calls
-
-{-
-Note [Lower safe foreign calls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We start with
-
-   Sp[young(L1)] = L1
- ,-----------------------
- | r1 = foo(x,y,z) returns to L1
- '-----------------------
- L1:
-   R1 = r1 -- copyIn, inserted by mkSafeCall
-   ...
-
-the stack layout algorithm will arrange to save and reload everything
-live across the call.  Our job now is to expand the call so we get
-
-   Sp[young(L1)] = L1
- ,-----------------------
- | SAVE_THREAD_STATE()
- | token = suspendThread(BaseReg, interruptible)
- | r = foo(x,y,z)
- | BaseReg = resumeThread(token)
- | LOAD_THREAD_STATE()
- | R1 = r  -- copyOut
- | jump Sp[0]
- '-----------------------
- L1:
-   r = R1 -- copyIn, inserted by mkSafeCall
-   ...
-
-Note the copyOut, which saves the results in the places that L1 is
-expecting them (see Note [safe foreign call convention]). Note also
-that safe foreign call is replace by an unsafe one in the Cmm graph.
--}
-
-lowerSafeForeignCall :: Profile -> CmmBlock -> UniqSM CmmBlock
-lowerSafeForeignCall profile block
-  | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block
-  = do
-    let platform = profilePlatform profile
-    -- Both 'id' and 'new_base' are KindNonPtr because they're
-    -- RTS-only objects and are not subject to garbage collection
-    id <- newTemp (bWord platform)
-    new_base <- newTemp (cmmRegType platform baseReg)
-    let (caller_save, caller_load) = callerSaveVolatileRegs platform
-    save_state_code <- saveThreadState profile
-    load_state_code <- loadThreadState profile
-    let suspend = save_state_code  <*>
-                  caller_save <*>
-                  mkMiddle (callSuspendThread platform id intrbl)
-        midCall = mkUnsafeCall tgt res args
-        resume  = mkMiddle (callResumeThread new_base id) <*>
-                  -- Assign the result to BaseReg: we
-                  -- might now have a different Capability!
-                  mkAssign baseReg (CmmReg (CmmLocal new_base)) <*>
-                  caller_load <*>
-                  load_state_code
-
-        (_, regs, copyout) =
-             copyOutOflow profile NativeReturn Jump (Young succ)
-                            (map (CmmReg . CmmLocal) res)
-                            ret_off []
-
-        -- NB. after resumeThread returns, the top-of-stack probably contains
-        -- the stack frame for succ, but it might not: if the current thread
-        -- received an exception during the call, then the stack might be
-        -- different.  Hence we continue by jumping to the top stack frame,
-        -- not by jumping to succ.
-        jump = CmmCall { cml_target    = entryCode platform $
-                                         cmmLoadBWord platform spExpr
-                       , cml_cont      = Just succ
-                       , cml_args_regs = regs
-                       , cml_args      = widthInBytes (wordWidth platform)
-                       , cml_ret_args  = ret_args
-                       , cml_ret_off   = ret_off }
-
-    graph' <- lgraphOfAGraph ( suspend <*>
-                               midCall <*>
-                               resume  <*>
-                               copyout <*>
-                               mkLast jump, tscp)
-
-    case toBlockList graph' of
-      [one] -> let (_, middle', last) = blockSplit one
-               in return (blockJoin entry (middle `blockAppend` middle') last)
-      _ -> panic "lowerSafeForeignCall0"
-
-  -- Block doesn't end in a safe foreign call:
-  | otherwise = return block
-
-
-callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O
-callSuspendThread platform id intrbl =
-  CmmUnsafeForeignCall (PrimTarget MO_SuspendThread)
-       [id] [baseExpr, mkIntExpr platform (fromEnum intrbl)]
-
-callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
-callResumeThread new_base id =
-  CmmUnsafeForeignCall (PrimTarget MO_ResumeThread)
-       [new_base] [CmmReg (CmmLocal id)]
-
--- -----------------------------------------------------------------------------
-
-plusW :: Platform -> ByteOff -> WordOff -> ByteOff
-plusW platform b w = b + w * platformWordSizeInBytes platform
-
-data StackSlot = Occupied | Empty
-     -- Occupied: a return address or part of an update frame
-
-instance Outputable StackSlot where
-  ppr Occupied = text "XXX"
-  ppr Empty    = text "---"
-
-dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]
-dropEmpty 0 ss           = Just ss
-dropEmpty n (Empty : ss) = dropEmpty (n-1) ss
-dropEmpty _ _            = Nothing
-
-isEmpty :: StackSlot -> Bool
-isEmpty Empty = True
-isEmpty _ = False
-
-localRegBytes :: Platform -> LocalReg -> ByteOff
-localRegBytes platform r
-    = roundUpToWords platform (widthInBytes (typeWidth (localRegType r)))
-
-localRegWords :: Platform -> LocalReg -> WordOff
-localRegWords platform = toWords platform . localRegBytes platform
-
-toWords :: Platform -> ByteOff -> WordOff
-toWords platform x = x `quot` platformWordSizeInBytes platform
-
-
-stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
-stackSlotRegs sm = nonDetEltsUFM (sm_regs sm)
-  -- See Note [Unique Determinism and code generation]
diff --git a/compiler/GHC/Cmm/Lexer.x b/compiler/GHC/Cmm/Lexer.x
deleted file mode 100644
--- a/compiler/GHC/Cmm/Lexer.x
+++ /dev/null
@@ -1,373 +0,0 @@
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow, 2004-2006
---
--- Lexer for concrete Cmm.  We try to stay close to the C-- spec, but there
--- are a few minor differences:
---
---   * extra keywords for our macros, and float32/float64 types
---   * global registers (Sp,Hp, etc.)
---
------------------------------------------------------------------------------
-
-{
-module GHC.Cmm.Lexer (
-   CmmToken(..), cmmlex,
-  ) where
-
-import GHC.Prelude
-
-import GHC.Cmm.Expr
-
-import GHC.Parser.Lexer
-import GHC.Cmm.Parser.Monad
-import GHC.Types.SrcLoc
-import GHC.Types.Unique.FM
-import GHC.Data.StringBuffer
-import GHC.Data.FastString
-import GHC.Parser.CharClass
-import GHC.Parser.Errors.Types
-import GHC.Parser.Errors.Ppr ()
-import GHC.Utils.Error
-import GHC.Utils.Misc
---import TRACE
-
-import Data.Word
-import Data.Char
-}
-
-$whitechar   = [\ \t\n\r\f\v\xa0] -- \xa0 is Unicode no-break space
-$white_no_nl = $whitechar # \n
-
-$ascdigit  = 0-9
-$unidigit  = \x01 -- Trick Alex into handling Unicode. See alexGetChar.
-$digit     = [$ascdigit $unidigit]
-$octit     = 0-7
-$hexit     = [$digit A-F a-f]
-
-$unilarge  = \x03 -- Trick Alex into handling Unicode. See alexGetChar.
-$asclarge  = [A-Z \xc0-\xd6 \xd8-\xde]
-$large     = [$asclarge $unilarge]
-
-$unismall  = \x04 -- Trick Alex into handling Unicode. See alexGetChar.
-$ascsmall  = [a-z \xdf-\xf6 \xf8-\xff]
-$small     = [$ascsmall $unismall \_]
-
-$namebegin = [$large $small \. \$ \@]
-$namechar  = [$namebegin $digit]
-
-@decimal     = $digit+
-@octal       = $octit+
-@hexadecimal = $hexit+
-@exponent    = [eE] [\-\+]? @decimal
-
-@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
-
-@escape      = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3})
-@strchar     = ($printable # [\"\\]) | @escape
-
-cmm :-
-
-$white_no_nl+           ;
-^\# pragma .* \n        ; -- Apple GCC 3.3 CPP generates pragmas in its output
-
-^\# (line)?             { begin line_prag }
-
--- single-line line pragmas, of the form
---    # <line> "<file>" <extra-stuff> \n
-<line_prag> $digit+                     { setLine line_prag1 }
-<line_prag1> \" [^\"]* \"       { setFile line_prag2 }
-<line_prag2> .*                         { pop }
-
-<0> {
-  \n                    ;
-
-  [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!]      { special_char }
-
-  ".."                  { kw CmmT_DotDot }
-  "::"                  { kw CmmT_DoubleColon }
-  ">>"                  { kw CmmT_Shr }
-  "<<"                  { kw CmmT_Shl }
-  ">="                  { kw CmmT_Ge }
-  "<="                  { kw CmmT_Le }
-  "=="                  { kw CmmT_Eq }
-  "!="                  { kw CmmT_Ne }
-  "&&"                  { kw CmmT_BoolAnd }
-  "||"                  { kw CmmT_BoolOr }
-
-  "True"                { kw CmmT_True  }
-  "False"               { kw CmmT_False }
-  "likely"              { kw CmmT_likely}
-
-  P@decimal             { global_regN (\n -> VanillaReg n VGcPtr) }
-  R@decimal             { global_regN (\n -> VanillaReg n VNonGcPtr) }
-  F@decimal             { global_regN FloatReg }
-  D@decimal             { global_regN DoubleReg }
-  L@decimal             { global_regN LongReg }
-  Sp                    { global_reg Sp }
-  SpLim                 { global_reg SpLim }
-  Hp                    { global_reg Hp }
-  HpLim                 { global_reg HpLim }
-  CCCS                  { global_reg CCCS }
-  CurrentTSO            { global_reg CurrentTSO }
-  CurrentNursery        { global_reg CurrentNursery }
-  HpAlloc               { global_reg HpAlloc }
-  BaseReg               { global_reg BaseReg }
-  MachSp                { global_reg MachSp }
-  UnwindReturnReg       { global_reg UnwindReturnReg }
-
-  $namebegin $namechar* { name }
-
-  0 @octal              { tok_octal }
-  @decimal              { tok_decimal }
-  0[xX] @hexadecimal    { tok_hexadecimal }
-  @floating_point       { strtoken tok_float }
-
-  \" @strchar* \"       { strtoken tok_string }
-}
-
-{
-data CmmToken
-  = CmmT_SpecChar  Char
-  | CmmT_DotDot
-  | CmmT_DoubleColon
-  | CmmT_Shr
-  | CmmT_Shl
-  | CmmT_Ge
-  | CmmT_Le
-  | CmmT_Eq
-  | CmmT_Ne
-  | CmmT_BoolAnd
-  | CmmT_BoolOr
-  | CmmT_CLOSURE
-  | CmmT_INFO_TABLE
-  | CmmT_INFO_TABLE_RET
-  | CmmT_INFO_TABLE_FUN
-  | CmmT_INFO_TABLE_CONSTR
-  | CmmT_INFO_TABLE_SELECTOR
-  | CmmT_else
-  | CmmT_export
-  | CmmT_section
-  | CmmT_goto
-  | CmmT_if
-  | CmmT_call
-  | CmmT_jump
-  | CmmT_foreign
-  | CmmT_never
-  | CmmT_prim
-  | CmmT_reserve
-  | CmmT_return
-  | CmmT_returns
-  | CmmT_import
-  | CmmT_switch
-  | CmmT_case
-  | CmmT_default
-  | CmmT_push
-  | CmmT_unwind
-  | CmmT_bits8
-  | CmmT_bits16
-  | CmmT_bits32
-  | CmmT_bits64
-  | CmmT_bits128
-  | CmmT_bits256
-  | CmmT_bits512
-  | CmmT_float32
-  | CmmT_float64
-  | CmmT_gcptr
-  | CmmT_GlobalReg GlobalReg
-  | CmmT_Name      FastString
-  | CmmT_String    String
-  | CmmT_Int       Integer
-  | CmmT_Float     Rational
-  | CmmT_EOF
-  | CmmT_False
-  | CmmT_True
-  | CmmT_likely
-  deriving (Show)
-
--- -----------------------------------------------------------------------------
--- Lexer actions
-
-type Action = PsSpan -> StringBuffer -> Int -> PD (PsLocated CmmToken)
-
-begin :: Int -> Action
-begin code _span _str _len = do liftP (pushLexState code); lexToken
-
-pop :: Action
-pop _span _buf _len = liftP popLexState >> lexToken
-
-special_char :: Action
-special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf)))
-
-kw :: CmmToken -> Action
-kw tok span _buf _len = return (L span tok)
-
-global_regN :: (Int -> GlobalReg) -> Action
-global_regN con span buf len
-  = return (L span (CmmT_GlobalReg (con (fromIntegral n))))
-  where buf' = stepOn buf
-        n = parseUnsignedInteger buf' (len-1) 10 octDecDigit
-
-global_reg :: GlobalReg -> Action
-global_reg r span _buf _len = return (L span (CmmT_GlobalReg r))
-
-strtoken :: (String -> CmmToken) -> Action
-strtoken f span buf len =
-  return (L span $! (f $! lexemeToString buf len))
-
-name :: Action
-name span buf len =
-  case lookupUFM reservedWordsFM fs of
-        Just tok -> return (L span tok)
-        Nothing  -> return (L span (CmmT_Name fs))
-  where
-        fs = lexemeToFastString buf len
-
-reservedWordsFM = listToUFM $
-        map (\(x, y) -> (mkFastString x, y)) [
-        ( "CLOSURE",            CmmT_CLOSURE ),
-        ( "INFO_TABLE",         CmmT_INFO_TABLE ),
-        ( "INFO_TABLE_RET",     CmmT_INFO_TABLE_RET ),
-        ( "INFO_TABLE_FUN",     CmmT_INFO_TABLE_FUN ),
-        ( "INFO_TABLE_CONSTR",  CmmT_INFO_TABLE_CONSTR ),
-        ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),
-        ( "else",               CmmT_else ),
-        ( "export",             CmmT_export ),
-        ( "section",            CmmT_section ),
-        ( "goto",               CmmT_goto ),
-        ( "if",                 CmmT_if ),
-        ( "call",               CmmT_call ),
-        ( "jump",               CmmT_jump ),
-        ( "foreign",            CmmT_foreign ),
-        ( "never",              CmmT_never ),
-        ( "prim",               CmmT_prim ),
-        ( "reserve",            CmmT_reserve ),
-        ( "return",             CmmT_return ),
-        ( "returns",            CmmT_returns ),
-        ( "import",             CmmT_import ),
-        ( "switch",             CmmT_switch ),
-        ( "case",               CmmT_case ),
-        ( "default",            CmmT_default ),
-        ( "push",               CmmT_push ),
-        ( "unwind",             CmmT_unwind ),
-        ( "bits8",              CmmT_bits8 ),
-        ( "bits16",             CmmT_bits16 ),
-        ( "bits32",             CmmT_bits32 ),
-        ( "bits64",             CmmT_bits64 ),
-        ( "bits128",            CmmT_bits128 ),
-        ( "bits256",            CmmT_bits256 ),
-        ( "bits512",            CmmT_bits512 ),
-        ( "float32",            CmmT_float32 ),
-        ( "float64",            CmmT_float64 ),
--- New forms
-        ( "b8",                 CmmT_bits8 ),
-        ( "b16",                CmmT_bits16 ),
-        ( "b32",                CmmT_bits32 ),
-        ( "b64",                CmmT_bits64 ),
-        ( "b128",               CmmT_bits128 ),
-        ( "b256",               CmmT_bits256 ),
-        ( "b512",               CmmT_bits512 ),
-        ( "f32",                CmmT_float32 ),
-        ( "f64",                CmmT_float64 ),
-        ( "gcptr",              CmmT_gcptr ),
-        ( "likely",             CmmT_likely),
-        ( "True",               CmmT_True  ),
-        ( "False",              CmmT_False )
-        ]
-
-tok_decimal span buf len
-  = return (L span (CmmT_Int  $! parseUnsignedInteger buf len 10 octDecDigit))
-
-tok_octal span buf len
-  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))
-
-tok_hexadecimal span buf len
-  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))
-
-tok_float str = CmmT_Float $! readRational str
-
-tok_string str = CmmT_String (read str)
-                 -- urk, not quite right, but it'll do for now
-
--- -----------------------------------------------------------------------------
--- Line pragmas
-
-setLine :: Int -> Action
-setLine code (PsSpan span _) buf len = do
-  let line = parseUnsignedInteger buf len 10 octDecDigit
-  liftP $ do
-    setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
-          -- subtract one: the line number refers to the *following* line
-    -- trace ("setLine "  ++ show line) $ do
-    popLexState >> pushLexState code
-  lexToken
-
-setFile :: Int -> Action
-setFile code (PsSpan span _) buf len = do
-  let file = lexemeToFastString (stepOn buf) (len-2)
-  liftP $ do
-    setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
-    popLexState >> pushLexState code
-  lexToken
-
--- -----------------------------------------------------------------------------
--- This is the top-level function: called from the parser each time a
--- new token is to be read from the input.
-
-cmmlex :: (Located CmmToken -> PD a) -> PD a
-cmmlex cont = do
-  (L span tok) <- lexToken
-  --trace ("token: " ++ show tok) $ do
-  cont (L (mkSrcSpanPs span) tok)
-
-lexToken :: PD (PsLocated CmmToken)
-lexToken = do
-  inp@(loc1,buf) <- getInput
-  sc <- liftP getLexState
-  case alexScan inp sc of
-    AlexEOF -> do let span = mkPsSpan loc1 loc1
-                  liftP (setLastToken span 0)
-                  return (L span CmmT_EOF)
-    AlexError (loc2,_) ->
-      let msg srcLoc = mkPlainErrorMsgEnvelope srcLoc PsErrCmmLexer
-      in liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) msg
-    AlexSkip inp2 _ -> do
-        setInput inp2
-        lexToken
-    AlexToken inp2@(end,_buf2) len t -> do
-        setInput inp2
-        let span = mkPsSpan loc1 end
-        span `seq` liftP (setLastToken span len)
-        t span buf len
-
--- -----------------------------------------------------------------------------
--- Monad stuff
-
--- Stuff that Alex needs to know about our input type:
-type AlexInput = (PsLoc,StringBuffer)
-
-alexInputPrevChar :: AlexInput -> Char
-alexInputPrevChar (_,s) = prevChar s '\n'
-
--- backwards compatibility for Alex 2.x
-alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
-alexGetChar inp = case alexGetByte inp of
-                    Nothing    -> Nothing
-                    Just (b,i) -> c `seq` Just (c,i)
-                       where c = chr $ fromIntegral b
-
-alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
-alexGetByte (loc,s)
-  | atEnd s   = Nothing
-  | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s'))
-  where c    = currentChar s
-        b    = fromIntegral $ ord $ c
-        loc' = advancePsLoc loc c
-        s'   = stepOn s
-
-getInput :: PD AlexInput
-getInput = PD $ \_ _ s@PState{ loc=l, buffer=b } -> POk s (l,b)
-
-setInput :: AlexInput -> PD ()
-setInput (l,b) = PD $ \_ _ s -> POk s{ loc=l, buffer=b } ()
-}
diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Lint.hs
+++ /dev/null
@@ -1,321 +0,0 @@
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow 2011
---
--- CmmLint: checking the correctness of Cmm statements and expressions
---
------------------------------------------------------------------------------
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-module GHC.Cmm.Lint (
-    cmmLint, cmmLintGraph
-  ) where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Platform.Regs (callerSaves)
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm
-import GHC.Cmm.Liveness
-import GHC.Cmm.Switch (switchTargetsToList)
-import GHC.Cmm.CLabel (pprDebugCLabel)
-import GHC.Utils.Outputable
-
-import Control.Monad (unless)
-import Control.Monad.Trans.Except (ExceptT (..), Except)
-import Control.Monad.Trans.Reader (ReaderT (..))
-import Data.Functor.Identity (Identity (..))
-
--- Things to check:
---     - invariant on CmmBlock in GHC.Cmm.Expr (see comment there)
---     - check for branches to blocks that don't exist
---     - check types
-
--- -----------------------------------------------------------------------------
--- Exported entry points:
-
-cmmLint :: (OutputableP Platform d, OutputableP Platform h)
-        => Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc
-cmmLint platform tops = runCmmLint platform (mapM_ lintCmmDecl) tops
-
-cmmLintGraph :: Platform -> CmmGraph -> Maybe SDoc
-cmmLintGraph platform g = runCmmLint platform lintCmmGraph g
-
-runCmmLint :: OutputableP Platform a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc
-runCmmLint platform l p =
-   case unCL (l p) platform of
-     Left err -> Just (withPprStyle defaultDumpStyle $ vcat
-                            [text "Cmm lint error:",
-                             nest 2 err,
-                             text "Program was:",
-                             nest 2 (pdoc platform p)])
-     Right _  -> Nothing
-
-lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint ()
-lintCmmDecl (CmmProc _ lbl _ g)
-  = do
-    platform <- getPlatform
-    addLintInfo (text "in proc " <> pprDebugCLabel platform lbl) $ lintCmmGraph g
-lintCmmDecl (CmmData {})
-  = return ()
-
-
-lintCmmGraph :: CmmGraph -> CmmLint ()
-lintCmmGraph g = do
-   platform <- getPlatform
-   let
-      blocks = toBlockList g
-      labels = setFromList (map entryLabel blocks)
-   cmmLocalLiveness platform g `seq` mapM_ (lintCmmBlock labels) blocks
-   -- cmmLiveness throws an error if there are registers
-   -- live on entry to the graph (i.e. undefined
-   -- variables)
-
-
-lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()
-lintCmmBlock labels block
-  = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do
-        let (_, middle, last) = blockSplit block
-        mapM_ lintCmmMiddle (blockToList middle)
-        lintCmmLast labels last
-
--- -----------------------------------------------------------------------------
--- lintCmmExpr
-
--- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
--- byte/word mismatches.
-
-lintCmmExpr :: CmmExpr -> CmmLint CmmType
-lintCmmExpr (CmmLoad expr rep _alignment) = do
-  _ <- lintCmmExpr expr
-  -- Disabled, if we have the inlining phase before the lint phase,
-  -- we can have funny offsets due to pointer tagging. -- EZY
-  -- when (widthInBytes (typeWidth rep) >= platformWordSizeInBytes platform) $
-  --   cmmCheckWordAddress expr
-  return rep
-lintCmmExpr expr@(CmmMachOp op args) = do
-  platform <- getPlatform
-  tys <- mapM lintCmmExpr args
-  lintShiftOp op (zip args tys)
-  if map (typeWidth . cmmExprType platform) args == machOpArgReps platform op
-        then cmmCheckMachOp op args tys
-        else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op)
-lintCmmExpr (CmmRegOff reg offset)
-  = do platform <- getPlatform
-       let rep = typeWidth (cmmRegType platform reg)
-       lintCmmExpr (CmmMachOp (MO_Add rep)
-                [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
-lintCmmExpr expr =
-  do platform <- getPlatform
-     return (cmmExprType platform expr)
-
--- | Check for obviously out-of-bounds shift operations
-lintShiftOp :: MachOp -> [(CmmExpr, CmmType)] -> CmmLint ()
-lintShiftOp op [(_, arg_ty), (CmmLit (CmmInt n _), _)]
-  | isShiftOp op
-  , n >= fromIntegral (widthInBits (typeWidth arg_ty))
-  = cmmLintErr (text "Shift operation" <+> pprMachOp op
-                <+> text "has out-of-range offset" <+> ppr n
-                <> text ". This will result in undefined behavior")
-lintShiftOp _ _ = return ()
-
-isShiftOp :: MachOp -> Bool
-isShiftOp (MO_Shl _)   = True
-isShiftOp (MO_U_Shr _) = True
-isShiftOp (MO_S_Shr _) = True
-isShiftOp _            = False
-
--- Check for some common byte/word mismatches (eg. Sp + 1)
-cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
-cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
-  = cmmCheckMachOp op [reg, lit] tys
-cmmCheckMachOp op _ tys
-  = do platform <- getPlatform
-       return (machOpResultType platform op tys)
-
-{-
-isOffsetOp :: MachOp -> Bool
-isOffsetOp (MO_Add _) = True
-isOffsetOp (MO_Sub _) = True
-isOffsetOp _ = False
-
--- This expression should be an address from which a word can be loaded:
--- check for funny-looking sub-word offsets.
-_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
-_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
-  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0
-  = cmmLintDubiousWordOffset e
-_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
-  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0
-  = cmmLintDubiousWordOffset e
-_cmmCheckWordAddress _
-  = return ()
-
--- No warnings for unaligned arithmetic with the node register,
--- which is used to extract fields from tagged constructor closures.
-notNodeReg :: CmmExpr -> Bool
-notNodeReg (CmmReg reg) | reg == nodeReg = False
-notNodeReg _                             = True
--}
-
-lintCmmMiddle :: CmmNode O O -> CmmLint ()
-lintCmmMiddle node = case node of
-  CmmComment _ -> return ()
-  CmmTick _    -> return ()
-  CmmUnwind{}  -> return ()
-
-  CmmAssign reg expr -> do
-            platform <- getPlatform
-            erep <- lintCmmExpr expr
-            let reg_ty = cmmRegType platform reg
-            unless (compat_regs erep reg_ty) $
-              cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
-    where
-      compat_regs :: CmmType -> CmmType -> Bool
-      compat_regs ty1 ty2
-        -- As noted in #22297, SIMD vector registers can be used for
-        -- multiple different purposes, e.g. xmm1 can be used to hold 4 Floats,
-        -- or 4 Int32s, or 2 Word64s, ...
-        -- To allow this, we relax the check: we only ensure that the widths
-        -- match, until we can find a more robust solution.
-        | isVecType ty1
-        , isVecType ty2
-        = typeWidth ty1 == typeWidth ty2
-        | otherwise
-        = cmmEqType_ignoring_ptrhood ty1 ty2
-
-  CmmStore l r _alignment -> do
-            _ <- lintCmmExpr l
-            _ <- lintCmmExpr r
-            return ()
-
-  CmmUnsafeForeignCall target _formals actuals -> do
-            lintTarget target
-            let lintArg expr = do
-                  -- Arguments can't mention caller-saved
-                  -- registers. See Note [Register parameter passing].
-                  mayNotMentionCallerSavedRegs (text "foreign call argument") expr
-                  lintCmmExpr expr
-
-            mapM_ lintArg actuals
-
-
-lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
-lintCmmLast labels node = case node of
-  CmmBranch id -> checkTarget id
-
-  CmmCondBranch e t f _ -> do
-            platform <- getPlatform
-            mapM_ checkTarget [t,f]
-            _ <- lintCmmExpr e
-            checkCond platform e
-
-  CmmSwitch e ids -> do
-            platform <- getPlatform
-            mapM_ checkTarget $ switchTargetsToList ids
-            erep <- lintCmmExpr e
-            unless (isWordAny erep) $
-              cmmLintErr (text "switch scrutinee is not a word (of any size): " <>
-                          pdoc platform e <> text " :: " <> ppr erep)
-
-  CmmCall { cml_target = target, cml_cont = cont } -> do
-          _ <- lintCmmExpr target
-          maybe (return ()) checkTarget cont
-
-  CmmForeignCall tgt _ args succ _ _ _ -> do
-          lintTarget tgt
-          let lintArg expr = do
-                -- Arguments can't mention caller-saved
-                -- registers. See Note [Register
-                -- parameter passing].
-                -- N.B. This won't catch local registers
-                -- which the NCG's register allocator later
-                -- places in caller-saved registers.
-                mayNotMentionCallerSavedRegs (text "foreign call argument") expr
-                lintCmmExpr expr
-          mapM_ lintArg args
-          checkTarget succ
- where
-  checkTarget id
-     | setMember id labels = return ()
-     | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
-
-lintTarget :: ForeignTarget -> CmmLint ()
-lintTarget (ForeignTarget e _) = do
-    mayNotMentionCallerSavedRegs (text "foreign target") e
-    _ <- lintCmmExpr e
-    return ()
-lintTarget (PrimTarget {})     = return ()
-
--- | As noted in Note [Register parameter passing], the arguments and
--- 'ForeignTarget' of a foreign call mustn't mention
--- caller-saved registers.
-mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, OutputableP Platform a)
-                             => SDoc -> a -> CmmLint ()
-mayNotMentionCallerSavedRegs what thing = do
-    platform <- getPlatform
-    let badRegs = filter (callerSaves platform)
-                  $ foldRegsUsed platform (flip (:)) [] thing
-    unless (null badRegs)
-      $ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ pdoc platform thing)
-
-checkCond :: Platform -> CmmExpr -> CmmLint ()
-checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
-checkCond platform (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth platform = return () -- constant values
-checkCond platform expr
-    = cmmLintErr (hang (text "expression is not a conditional:") 2
-                         (pdoc platform expr))
-
--- -----------------------------------------------------------------------------
--- CmmLint monad
-
--- just a basic error monad:
-
-newtype CmmLint a = CmmLint { unCL :: Platform -> Either SDoc a }
-  deriving stock (Functor)
-  deriving (Applicative, Monad) via ReaderT Platform (Except SDoc)
-
-getPlatform :: CmmLint Platform
-getPlatform = CmmLint $ \platform -> Right platform
-
-cmmLintErr :: SDoc -> CmmLint a
-cmmLintErr msg = CmmLint (\_ -> Left msg)
-
-addLintInfo :: SDoc -> CmmLint a -> CmmLint a
-addLintInfo info thing = CmmLint $ \platform ->
-   case unCL thing platform of
-        Left err -> Left (hang info 2 err)
-        Right a  -> Right a
-
-cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
-cmmLintMachOpErr expr argsRep opExpectsRep
-     = do
-       platform <- getPlatform
-       cmmLintErr (text "in MachOp application: " $$
-                   nest 2 (pdoc platform expr) $$
-                      (text "op is expecting: " <+> ppr opExpectsRep) $$
-                      (text "arguments provide: " <+> ppr argsRep))
-
-cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
-cmmLintAssignErr stmt e_ty r_ty
-  = do
-    platform <- getPlatform
-    cmmLintErr (text "in assignment: " $$
-                nest 2 (vcat [pdoc platform stmt,
-                              text "Reg ty:" <+> ppr r_ty,
-                              text "Rhs ty:" <+> ppr e_ty]))
-
-
-{-
-cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
-cmmLintDubiousWordOffset expr
-   = cmmLintErr (text "offset is not a multiple of words: " $$
-                 nest 2 (ppr expr))
--}
-
diff --git a/compiler/GHC/Cmm/Liveness.hs b/compiler/GHC/Cmm/Liveness.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Liveness.hs
+++ /dev/null
@@ -1,164 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module GHC.Cmm.Liveness
-    ( CmmLocalLive
-    , cmmLocalLiveness
-    , cmmLocalLivenessL
-    , cmmGlobalLiveness
-    , liveLattice
-    , liveLatticeL
-    , gen_kill
-    , gen_killL
-    )
-where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Cmm.BlockId
-import GHC.Cmm
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.LRegSet
-
-import GHC.Data.Maybe
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import GHC.Types.Unique
-
------------------------------------------------------------------------------
--- Calculating what variables are live on entry to a basic block
------------------------------------------------------------------------------
-
--- | The variables live on entry to a block
-type CmmLive r = RegSet r
-type CmmLocalLive = CmmLive LocalReg
-
--- | The dataflow lattice
-liveLattice :: Ord r => DataflowLattice (CmmLive r)
-{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-}
-{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-}
-liveLattice = DataflowLattice emptyRegSet add
-  where
-    add (OldFact old) (NewFact new) =
-        let !join = plusRegSet old new
-        in changedIf (sizeRegSet join > sizeRegSet old) join
-
--- | A mapping from block labels to the variables live on entry
-type BlockEntryLiveness r = LabelMap (CmmLive r)
-
------------------------------------------------------------------------------
--- | Calculated liveness info for a CmmGraph
------------------------------------------------------------------------------
-
-cmmLocalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness LocalReg
-cmmLocalLiveness platform graph =
-    check $ analyzeCmmBwd liveLattice (xferLive platform) graph mapEmpty
-  where
-    entry = g_entry graph
-    check facts =
-        noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts
-
-cmmGlobalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness GlobalReg
-cmmGlobalLiveness platform graph =
-    analyzeCmmBwd liveLattice (xferLive platform) graph mapEmpty
-
--- | On entry to the procedure, there had better not be any LocalReg's live-in.
--- If you see this error it most likely means you are trying to use a variable
--- without it being defined in the given scope.
-noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a
-noLiveOnEntry bid in_fact x =
-  if nullRegSet in_fact then x
-  else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
-
-gen_kill
-    :: (DefinerOfRegs r n, UserOfRegs r n)
-    => Platform -> n -> CmmLive r -> CmmLive r
-gen_kill platform node set =
-    let !afterKill = foldRegsDefd platform deleteFromRegSet set node
-    in foldRegsUsed platform extendRegSet afterKill node
-{-# INLINE gen_kill #-}
-
-xferLive
-    :: forall r.
-       ( UserOfRegs r (CmmNode O O)
-       , DefinerOfRegs r (CmmNode O O)
-       , UserOfRegs r (CmmNode O C)
-       , DefinerOfRegs r (CmmNode O C)
-       )
-    => Platform -> TransferFun (CmmLive r)
-xferLive platform (BlockCC eNode middle xNode) fBase =
-    let joined = gen_kill platform xNode $! joinOutFacts liveLattice xNode fBase
-        !result = foldNodesBwdOO (gen_kill platform) middle joined
-    in mapSingleton (entryLabel eNode) result
-{-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive LocalReg) #-}
-{-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive GlobalReg) #-}
-
------------------------------------------------------------------------------
--- | Specialization that only retains the keys for local variables.
---
--- Local variables are mostly glorified Ints, and some parts of the compiler
--- really don't care about anything but the Int part. So we can avoid some
--- overhead by computing a IntSet instead of a Set LocalReg which (unsurprisingly)
--- is quite a bit faster.
------------------------------------------------------------------------------
-
-type BlockEntryLivenessL  = LabelMap LRegSet
-
--- | The dataflow lattice
-liveLatticeL :: DataflowLattice LRegSet
-liveLatticeL = DataflowLattice emptyLRegSet add
-  where
-    add (OldFact old) (NewFact new) =
-        let !join = plusLRegSet old new
-        in changedIf (sizeLRegSet join > sizeLRegSet old) join
-
-
-cmmLocalLivenessL :: Platform -> CmmGraph -> BlockEntryLivenessL
-cmmLocalLivenessL platform graph =
-    check $ analyzeCmmBwd liveLatticeL (xferLiveL platform) graph mapEmpty
-  where
-    entry = g_entry graph
-    check facts =
-        noLiveOnEntryL entry (expectJust "check" $ mapLookup entry facts) facts
-
--- | On entry to the procedure, there had better not be any LocalReg's live-in.
-noLiveOnEntryL :: BlockId -> LRegSet -> a -> a
-noLiveOnEntryL bid in_fact x =
-  if nullLRegSet in_fact then x
-  else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr reg_uniques)
-    where
-        -- We convert the int's to uniques so that the printing matches that
-        -- of registers.
-        reg_uniques = map mkUniqueGrimily $ elemsLRegSet in_fact
-
-
-
-
-gen_killL
-    :: (DefinerOfRegs LocalReg n, UserOfRegs LocalReg n)
-    => Platform -> n -> LRegSet -> LRegSet
-gen_killL platform node set =
-    let !afterKill = foldRegsDefd platform deleteFromLRegSet set node
-    in foldRegsUsed platform (flip insertLRegSet) afterKill node
-{-# INLINE gen_killL #-}
-
-xferLiveL
-    :: ( UserOfRegs LocalReg (CmmNode O O)
-       , DefinerOfRegs LocalReg (CmmNode O O)
-       , UserOfRegs LocalReg (CmmNode O C)
-       , DefinerOfRegs LocalReg (CmmNode O C)
-       )
-    => Platform -> TransferFun LRegSet
-xferLiveL platform (BlockCC eNode middle xNode) fBase =
-    let joined = gen_killL platform xNode $! joinOutFacts liveLatticeL xNode fBase
-        !result = foldNodesBwdOO (gen_killL platform) middle joined
-    in mapSingleton (entryLabel eNode) result
-
-
diff --git a/compiler/GHC/Cmm/Opt.hs b/compiler/GHC/Cmm/Opt.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Opt.hs
+++ /dev/null
@@ -1,429 +0,0 @@
------------------------------------------------------------------------------
---
--- Cmm optimisation
---
--- (c) The University of Glasgow 2006
---
------------------------------------------------------------------------------
-
-module GHC.Cmm.Opt (
-        constantFoldNode,
-        constantFoldExpr,
-        cmmMachOpFold,
-        cmmMachOpFoldM
- ) where
-
-import GHC.Prelude
-
-import GHC.Cmm.Utils
-import GHC.Cmm
-import GHC.Utils.Misc
-
-import GHC.Utils.Panic
-import GHC.Platform
-
-import Data.Maybe
-
-
-constantFoldNode :: Platform -> CmmNode e x -> CmmNode e x
-constantFoldNode platform = mapExp (constantFoldExpr platform)
-
-constantFoldExpr :: Platform -> CmmExpr -> CmmExpr
-constantFoldExpr platform = wrapRecExp f
-  where f (CmmMachOp op args) = cmmMachOpFold platform op args
-        f (CmmRegOff r 0) = CmmReg r
-        f e = e
-
--- -----------------------------------------------------------------------------
--- MachOp constant folder
-
--- Now, try to constant-fold the MachOps.  The arguments have already
--- been optimized and folded.
-
-cmmMachOpFold
-    :: Platform
-    -> MachOp       -- The operation from an CmmMachOp
-    -> [CmmExpr]    -- The optimized arguments
-    -> CmmExpr
-
-cmmMachOpFold platform op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM platform op args)
-
--- Returns Nothing if no changes, useful for Hoopl, also reduces
--- allocation!
-cmmMachOpFoldM
-    :: Platform
-    -> MachOp
-    -> [CmmExpr]
-    -> Maybe CmmExpr
-
-cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]
-  = Just $! case op of
-      MO_S_Neg _ -> CmmLit (CmmInt (-x) rep)
-      MO_Not _   -> CmmLit (CmmInt (complement x) rep)
-
-        -- these are interesting: we must first narrow to the
-        -- "from" type, in order to truncate to the correct size.
-        -- The final narrow/widen to the destination type
-        -- is implicit in the CmmLit.
-      MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to)
-      MO_SS_Conv  from to -> CmmLit (CmmInt (narrowS from x) to)
-      MO_UU_Conv  from to -> CmmLit (CmmInt (narrowU from x) to)
-      MO_XX_Conv  from to -> CmmLit (CmmInt (narrowS from x) to)
-
-      _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op
-
--- Eliminate shifts that are wider than the shiftee
-cmmMachOpFoldM _ op [_shiftee, CmmLit (CmmInt shift _)]
-  | Just width <- isShift op
-  , shift >= fromIntegral (widthInBits width)
-  = Just $! CmmLit (CmmInt 0 width)
-  where
-    isShift (MO_Shl   w) = Just w
-    isShift (MO_U_Shr w) = Just w
-    isShift (MO_S_Shr w) = Just w
-    isShift _            = Nothing
-
--- Eliminate conversion NOPs
-cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
-cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
-cmmMachOpFoldM _ (MO_XX_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
-
--- Eliminate nested conversions where possible
-cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]]
-  | Just (rep1,rep2,signed1) <- isIntConversion conv_inner,
-    Just (_,   rep3,signed2) <- isIntConversion conv_outer
-  = case () of
-        -- widen then narrow to the same size is a nop
-      _ | rep1 < rep2 && rep1 == rep3 -> Just x
-        -- Widen then narrow to different size: collapse to single conversion
-        -- but remember to use the signedness from the widening, just in case
-        -- the final conversion is a widen.
-        | rep1 < rep2 && rep2 > rep3 ->
-            Just $! cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]
-        -- Nested widenings: collapse if the signedness is the same
-        | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->
-            Just $! cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]
-        -- Nested narrowings: collapse
-        | rep1 > rep2 && rep2 > rep3 ->
-            Just $! cmmMachOpFold platform (MO_UU_Conv rep1 rep3) [x]
-        | otherwise ->
-            Nothing
-  where
-        isIntConversion (MO_UU_Conv rep1 rep2)
-          = Just (rep1,rep2,False)
-        isIntConversion (MO_SS_Conv rep1 rep2)
-          = Just (rep1,rep2,True)
-        isIntConversion _ = Nothing
-
-        intconv True  = MO_SS_Conv
-        intconv False = MO_UU_Conv
-
-cmmMachOpFoldM platform mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
-  = case mop of
-        -- for comparisons: don't forget to narrow the arguments before
-        -- comparing, since they might be out of range.
-        MO_Eq _   -> Just $! CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth platform))
-        MO_Ne _   -> Just $! CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth platform))
-
-        MO_U_Gt _ -> Just $! CmmLit (CmmInt (if x_u >  y_u then 1 else 0) (wordWidth platform))
-        MO_U_Ge _ -> Just $! CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth platform))
-        MO_U_Lt _ -> Just $! CmmLit (CmmInt (if x_u <  y_u then 1 else 0) (wordWidth platform))
-        MO_U_Le _ -> Just $! CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth platform))
-
-        MO_S_Gt _ -> Just $! CmmLit (CmmInt (if x_s >  y_s then 1 else 0) (wordWidth platform))
-        MO_S_Ge _ -> Just $! CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth platform))
-        MO_S_Lt _ -> Just $! CmmLit (CmmInt (if x_s <  y_s then 1 else 0) (wordWidth platform))
-        MO_S_Le _ -> Just $! CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth platform))
-
-        MO_Add r -> Just $! CmmLit (CmmInt (x + y) r)
-        MO_Sub r -> Just $! CmmLit (CmmInt (x - y) r)
-        MO_Mul r -> Just $! CmmLit (CmmInt (x * y) r)
-        MO_U_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `quot` y_u) r)
-        MO_U_Rem  r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `rem`  y_u) r)
-        MO_S_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_s `quot` y_s) r)
-        MO_S_Rem  r | y /= 0 -> Just $! CmmLit (CmmInt (x_s `rem`  y_s) r)
-
-        MO_And   r -> Just $! CmmLit (CmmInt (x .&. y) r)
-        MO_Or    r -> Just $! CmmLit (CmmInt (x .|. y) r)
-        MO_Xor   r -> Just $! CmmLit (CmmInt (x `xor` y) r)
-
-        MO_Shl   r -> Just $! CmmLit (CmmInt (x   `shiftL` fromIntegral y) r)
-        MO_U_Shr r -> Just $! CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)
-        MO_S_Shr r -> Just $! CmmLit (CmmInt (x_s `shiftR` fromIntegral y) r)
-
-        _          -> Nothing
-
-   where
-        x_u = narrowU xrep x
-        y_u = narrowU xrep y
-        x_s = narrowS xrep x
-        y_s = narrowS xrep y
-
-
--- When possible, shift the constants to the right-hand side, so that we
--- can match for strength reductions.  Note that the code generator will
--- also assume that constants have been shifted to the right when
--- possible.
-
-cmmMachOpFoldM platform op [x@(CmmLit _), y]
-   | not (isLit y) && isCommutableMachOp op
-   = Just $! (cmmMachOpFold platform op [y, x])
-
--- Turn (a+b)+c into a+(b+c) where possible.  Because literals are
--- moved to the right, it is more likely that we will find
--- opportunities for constant folding when the expression is
--- right-associated.
---
--- ToDo: this appears to introduce a quadratic behaviour due to the
--- nested cmmMachOpFold.  Can we fix this?
---
--- Why do we check isLit arg1?  If arg1 is a lit, it means that arg2
--- is also a lit (otherwise arg1 would be on the right).  If we
--- put arg1 on the left of the rearranged expression, we'll get into a
--- loop:  (x1+x2)+x3 => x1+(x2+x3)  => (x2+x3)+x1 => x2+(x3+x1) ...
---
--- Also don't do it if arg1 is PicBaseReg, so that we don't separate the
--- PicBaseReg from the corresponding label (or label difference).
---
-cmmMachOpFoldM platform mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
-   | mop2 `associates_with` mop1
-     && not (isLit arg1) && not (isPicReg arg1)
-   = Just $! (cmmMachOpFold platform mop2 [arg1, cmmMachOpFold platform mop1 [arg2,arg3]])
-   where
-     MO_Add{} `associates_with` MO_Sub{} = True
-     mop1 `associates_with` mop2 =
-        mop1 == mop2 && isAssociativeMachOp mop1
-
--- special case: (a - b) + c  ==>  a + (c - b)
-cmmMachOpFoldM platform mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]
-   | not (isLit arg1) && not (isPicReg arg1)
-   = Just $! (cmmMachOpFold platform mop1 [arg1, cmmMachOpFold platform mop2 [arg3,arg2]])
-
--- special case: (PicBaseReg + lit) + N  ==>  PicBaseReg + (lit+N)
---
--- this is better because lit+N is a single link-time constant (e.g. a
--- CmmLabelOff), so the right-hand expression needs only one
--- instruction, whereas the left needs two.  This happens when pointer
--- tagging gives us label+offset, and PIC turns the label into
--- PicBaseReg + label.
---
-cmmMachOpFoldM _ MO_Add{} [ CmmMachOp op@MO_Add{} [pic, CmmLit lit]
-                          , CmmLit (CmmInt n rep) ]
-  | isPicReg pic
-  = Just $! CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ]
-  where off = fromIntegral (narrowS rep n)
-
--- Make a RegOff if we can
-cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]
-  = Just $! cmmRegOff reg (fromIntegral (narrowS rep n))
-cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
-  = Just $! cmmRegOff reg (off + fromIntegral (narrowS rep n))
-cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]
-  = Just $! cmmRegOff reg (- fromIntegral (narrowS rep n))
-cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
-  = Just $! cmmRegOff reg (off - fromIntegral (narrowS rep n))
-
--- Fold label(+/-)offset into a CmmLit where possible
-
-cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)]
-  = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))
-cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit]
-  = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))
-cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]
-  = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i))))
-
-
--- Comparison of literal with widened operand: perform the comparison
--- at the smaller width, as long as the literal is within range.
-
--- We can't do the reverse trick, when the operand is narrowed:
--- narrowing throws away bits from the operand, there's no way to do
--- the same comparison at the larger size.
-
-cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
-  |     -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try
-    platformArch platform `elem` [ArchX86, ArchX86_64],
-        -- if the operand is widened:
-    Just (rep, signed, narrow_fn) <- maybe_conversion conv,
-        -- and this is a comparison operation:
-    Just narrow_cmp <- maybe_comparison cmp rep signed,
-        -- and the literal fits in the smaller size:
-    i == narrow_fn rep i
-        -- then we can do the comparison at the smaller size
-  = Just $! (cmmMachOpFold platform narrow_cmp [x, CmmLit (CmmInt i rep)])
- where
-    maybe_conversion (MO_UU_Conv from to)
-        | to > from
-        = Just (from, False, narrowU)
-    maybe_conversion (MO_SS_Conv from to)
-        | to > from
-        = Just (from, True, narrowS)
-
-        -- don't attempt to apply this optimisation when the source
-        -- is a float; see #1916
-    maybe_conversion _ = Nothing
-
-        -- careful (#2080): if the original comparison was signed, but
-        -- we were doing an unsigned widen, then we must do an
-        -- unsigned comparison at the smaller size.
-    maybe_comparison (MO_U_Gt _) rep _     = Just (MO_U_Gt rep)
-    maybe_comparison (MO_U_Ge _) rep _     = Just (MO_U_Ge rep)
-    maybe_comparison (MO_U_Lt _) rep _     = Just (MO_U_Lt rep)
-    maybe_comparison (MO_U_Le _) rep _     = Just (MO_U_Le rep)
-    maybe_comparison (MO_Eq   _) rep _     = Just (MO_Eq   rep)
-    maybe_comparison (MO_S_Gt _) rep True  = Just (MO_S_Gt rep)
-    maybe_comparison (MO_S_Ge _) rep True  = Just (MO_S_Ge rep)
-    maybe_comparison (MO_S_Lt _) rep True  = Just (MO_S_Lt rep)
-    maybe_comparison (MO_S_Le _) rep True  = Just (MO_S_Le rep)
-    maybe_comparison (MO_S_Gt _) rep False = Just (MO_U_Gt rep)
-    maybe_comparison (MO_S_Ge _) rep False = Just (MO_U_Ge rep)
-    maybe_comparison (MO_S_Lt _) rep False = Just (MO_U_Lt rep)
-    maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep)
-    maybe_comparison _ _ _ = Nothing
-
--- We can often do something with constants of 0 and 1 ...
--- See Note [Comparison operators]
-
-cmmMachOpFoldM platform mop [x, y@(CmmLit (CmmInt 0 _))]
-  = case mop of
-        -- Arithmetic
-        MO_Add   _ -> Just x   -- x + 0 = x
-        MO_Sub   _ -> Just x   -- x - 0 = x
-        MO_Mul   _ -> Just y   -- x * 0 = 0
-
-        -- Logical operations
-        MO_And   _ -> Just y   -- x &     0 = 0
-        MO_Or    _ -> Just x   -- x |     0 = x
-        MO_Xor   _ -> Just x   -- x `xor` 0 = x
-
-        -- Shifts
-        MO_Shl   _ -> Just x   -- x << 0 = x
-        MO_S_Shr _ -> Just x   -- ditto shift-right
-        MO_U_Shr _ -> Just x
-
-        -- Comparisons; these ones are trickier
-        -- See Note [Comparison operators]
-        MO_Ne    _ | isComparisonExpr x -> Just x                -- (x > y) != 0  =  x > y
-        MO_Eq    _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x > y) == 0  =  x <= y
-        MO_U_Gt  _ | isComparisonExpr x -> Just x                -- (x > y) > 0   =  x > y
-        MO_S_Gt  _ | isComparisonExpr x -> Just x                -- ditto
-        MO_U_Lt  _ | isComparisonExpr x -> Just zero             -- (x > y) < 0  =  0
-        MO_S_Lt  _ | isComparisonExpr x -> Just zero
-        MO_U_Ge  _ | isComparisonExpr x -> Just one              -- (x > y) >= 0  =  1
-        MO_S_Ge  _ | isComparisonExpr x -> Just one
-
-        MO_U_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x > y) <= 0  =  x <= y
-        MO_S_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'
-        _ -> Nothing
-  where
-    zero = CmmLit (CmmInt 0 (wordWidth platform))
-    one  = CmmLit (CmmInt 1 (wordWidth platform))
-
-cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt 1 rep))]
-  = case mop of
-        -- Arithmetic: x*1 = x, etc
-        MO_Mul    _ -> Just x
-        MO_S_Quot _ -> Just x
-        MO_U_Quot _ -> Just x
-        MO_S_Rem  _ -> Just $! CmmLit (CmmInt 0 rep)
-        MO_U_Rem  _ -> Just $! CmmLit (CmmInt 0 rep)
-
-        -- Comparisons; trickier
-        -- See Note [Comparison operators]
-        MO_Ne    _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) != 1  =  x<=y
-        MO_Eq    _ | isComparisonExpr x -> Just x                -- (x>y) == 1  =  x>y
-        MO_U_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) < 1   =  x<=y
-        MO_S_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- ditto
-        MO_U_Gt  _ | isComparisonExpr x -> Just zero             -- (x>y) > 1   = 0
-        MO_S_Gt  _ | isComparisonExpr x -> Just zero
-        MO_U_Le  _ | isComparisonExpr x -> Just one              -- (x>y) <= 1  = 1
-        MO_S_Le  _ | isComparisonExpr x -> Just one
-        MO_U_Ge  _ | isComparisonExpr x -> Just x                -- (x>y) >= 1  = x>y
-        MO_S_Ge  _ | isComparisonExpr x -> Just x
-        _ -> Nothing
-  where
-    zero = CmmLit (CmmInt 0 (wordWidth platform))
-    one  = CmmLit (CmmInt 1 (wordWidth platform))
-
--- Now look for multiplication/division by powers of 2 (integers).
-
-cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))]
-  = case mop of
-        MO_Mul rep
-           | Just p <- exactLog2 n ->
-                 Just $! (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p $ wordWidth platform)])
-        MO_U_Quot rep
-           | Just p <- exactLog2 n ->
-                 Just $! (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p $ wordWidth platform)])
-        MO_U_Rem rep
-           | Just _ <- exactLog2 n ->
-                 Just $! (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])
-        MO_S_Quot rep
-           | Just p <- exactLog2 n,
-             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require
-                                -- it is a reg.  FIXME: remove this restriction.
-                Just $! (cmmMachOpFold platform (MO_S_Shr rep)
-                  [signedQuotRemHelper rep p, CmmLit (CmmInt p $ wordWidth platform)])
-        MO_S_Rem rep
-           | Just p <- exactLog2 n,
-             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require
-                                -- it is a reg.  FIXME: remove this restriction.
-                -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).
-                -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)
-                -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.
-                Just $! (cmmMachOpFold platform (MO_Sub rep)
-                    [x, cmmMachOpFold platform (MO_And rep)
-                      [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])
-        _ -> Nothing
-  where
-    -- In contrast with unsigned integers, for signed ones
-    -- shift right is not the same as quot, because it rounds
-    -- to minus infinity, whereas quot rounds toward zero.
-    -- To fix this up, we add one less than the divisor to the
-    -- dividend if it is a negative number.
-    --
-    -- to avoid a test/jump, we use the following sequence:
-    --      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)
-    --      x2 = y & (divisor-1)
-    --      result = x + x2
-    -- this could be done a bit more simply using conditional moves,
-    -- but we're processor independent here.
-    --
-    -- we optimise the divide by 2 case slightly, generating
-    --      x1 = x >> word_size-1  (unsigned)
-    --      return = x + x1
-    signedQuotRemHelper :: Width -> Integer -> CmmExpr
-    signedQuotRemHelper rep p = CmmMachOp (MO_Add rep) [x, x2]
-      where
-        bits = fromIntegral (widthInBits rep) - 1
-        shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep
-        x1 = CmmMachOp shr [x, CmmLit (CmmInt bits $ wordWidth platform)]
-        x2 = if p == 1 then x1 else
-             CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]
-
--- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x
--- Unfortunately this needs a unique supply because x might not be a
--- register.  See #2253 (program 6) for an example.
-
-
--- Anything else is just too hard.
-
-cmmMachOpFoldM _ _ _ = Nothing
-
-{- Note [Comparison operators]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we have
-   CmmCondBranch ((x>#y) == 1) t f
-we really want to convert to
-   CmmCondBranch (x>#y) t f
-
-That's what the constant-folding operations on comparison operators do above.
--}
-
-
--- -----------------------------------------------------------------------------
--- Utils
-
-isPicReg :: CmmExpr -> Bool
-isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True
-isPicReg _ = False
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
deleted file mode 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ /dev/null
@@ -1,1533 +0,0 @@
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow, 2004-2012
---
--- Parser for concrete Cmm.
---
------------------------------------------------------------------------------
-
-{-
-Note [Syntax of .cmm files]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-NOTE: You are very much on your own in .cmm.  There is very little
-error checking at all:
-
-  * Type errors are detected by the (optional) -dcmm-lint pass, if you
-    don't turn this on then a type error will likely result in a panic
-    from the native code generator.
-
-  * Passing the wrong number of arguments or arguments of the wrong
-    type is not detected.
-
-There are two ways to write .cmm code:
-
- (1) High-level Cmm code delegates the stack handling to GHC, and
-     never explicitly mentions Sp or registers.
-
- (2) Low-level Cmm manages the stack itself, and must know about
-     calling conventions.
-
-Whether you want high-level or low-level Cmm is indicated by the
-presence of an argument list on a procedure.  For example:
-
-foo ( gcptr a, bits32 b )
-{
-  // this is high-level cmm code
-
-  if (b > 0) {
-     // we can make tail calls passing arguments:
-     jump stg_ap_0_fast(a);
-  }
-
-  push (stg_upd_frame_info, a) {
-    // stack frames can be explicitly pushed
-
-    (x,y) = call wibble(a,b,3,4);
-      // calls pass arguments and return results using the native
-      // Haskell calling convention.  The code generator will automatically
-      // construct a stack frame and an info table for the continuation.
-
-    return (x,y);
-      // we can return multiple values from the current proc
-  }
-}
-
-bar
-{
-  // this is low-level cmm code, indicated by the fact that we did not
-  // put an argument list on bar.
-
-  x = R1;  // the calling convention is explicit: better be careful
-           // that this works on all platforms!
-
-  jump %ENTRY_CODE(Sp(0))
-}
-
-Here is a list of rules for high-level and low-level code.  If you
-break the rules, you get a panic (for using a high-level construct in
-a low-level proc), or wrong code (when using low-level code in a
-high-level proc).  This stuff isn't checked! (TODO!)
-
-High-level only:
-
-  - tail-calls with arguments, e.g.
-    jump stg_fun (arg1, arg2);
-
-  - function calls:
-    (ret1,ret2) = call stg_fun (arg1, arg2);
-
-    This makes a call with the NativeNodeCall convention, and the
-    values are returned to the following code using the NativeReturn
-    convention.
-
-  - returning:
-    return (ret1, ret2)
-
-    These use the NativeReturn convention to return zero or more
-    results to the caller.
-
-  - pushing stack frames:
-    push (info_ptr, field1, ..., fieldN) { ... statements ... }
-
-  - reserving temporary stack space:
-
-      reserve N = x { ... }
-
-    this reserves an area of size N (words) on the top of the stack,
-    and binds its address to x (a local register).  Typically this is
-    used for allocating temporary storage for passing to foreign
-    functions.
-
-    Note that if you make any native calls or invoke the GC in the
-    scope of the reserve block, you are responsible for ensuring that
-    the stack you reserved is laid out correctly with an info table.
-
-Low-level only:
-
-  - References to Sp, R1-R8, F1-F4 etc.
-
-    NB. foreign calls may clobber the argument registers R1-R8, F1-F4
-    etc., so ensure they are saved into variables around foreign
-    calls.
-
-  - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp
-    directly.
-
-Both high-level and low-level code can use a raw tail-call:
-
-    jump stg_fun [R1,R2]
-
-NB. you *must* specify the list of GlobalRegs that are passed via a
-jump, otherwise the register allocator will assume that all the
-GlobalRegs are dead at the jump.
-
-
-Calling Conventions
--------------------
-
-High-level procedures use the NativeNode calling convention, or the
-NativeReturn convention if the 'return' keyword is used (see Stack
-Frames below).
-
-Low-level procedures implement their own calling convention, so it can
-be anything at all.
-
-If a low-level procedure implements the NativeNode calling convention,
-then it can be called by high-level code using an ordinary function
-call.  In general this is hard to arrange because the calling
-convention depends on the number of physical registers available for
-parameter passing, but there are two cases where the calling
-convention is platform-independent:
-
- - Zero arguments.
-
- - One argument of pointer or non-pointer word type; this is always
-   passed in R1 according to the NativeNode convention.
-
- - Returning a single value; these conventions are fixed and platform
-   independent.
-
-
-Stack Frames
-------------
-
-A stack frame is written like this:
-
-INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN )
-               return ( arg1, ..., argM )
-{
-  ... code ...
-}
-
-where field1 ... fieldN are the fields of the stack frame (with types)
-arg1...argN are the values returned to the stack frame (with types).
-The return values are assumed to be passed according to the
-NativeReturn convention.
-
-On entry to the code, the stack frame looks like:
-
-   |----------|
-   | fieldN   |
-   |   ...    |
-   | field1   |
-   |----------|
-   | info_ptr |
-   |----------|
-   |  argN    |
-   |   ...    | <- Sp
-
-and some of the args may be in registers.
-
-We prepend the code by a copyIn of the args, and assign all the stack
-frame fields to their formals.  The initial "arg offset" for stack
-layout purposes consists of the whole stack frame plus any args that
-might be on the stack.
-
-A tail-call may pass a stack frame to the callee using the following
-syntax:
-
-jump f (info_ptr, field1,..,fieldN) (arg1,..,argN)
-
-where info_ptr and field1..fieldN describe the stack frame, and
-arg1..argN are the arguments passed to f using the NativeNodeCall
-convention. Note if a field is longer than a word (e.g. a D_ on
-a 32-bit machine) then the call will push as many words as
-necessary to the stack to accommodate it (e.g. 2).
-
-
------------------------------------------------------------------------------ -}
-
-{
-{-# LANGUAGE TupleSections #-}
-
-module GHC.Cmm.Parser ( parseCmmFile, CmmParserConfig(..) ) where
-
-import GHC.Prelude
-import qualified Prelude -- for happy-generated code
-
-import GHC.Platform
-import GHC.Platform.Profile
-
-import GHC.StgToCmm.ExtCode
-import GHC.StgToCmm.Heap
-import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit
-                                 , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff
-                                 , getUpdFrameOff, getProfile, getPlatform, getContext)
-import qualified GHC.StgToCmm.Monad as F
-import GHC.StgToCmm.Utils
-import GHC.StgToCmm.Foreign
-import GHC.StgToCmm.Expr
-import GHC.StgToCmm.Lit
-import GHC.StgToCmm.Closure
-import GHC.StgToCmm.Config
-import GHC.StgToCmm.Layout     hiding (ArgRep(..))
-import GHC.StgToCmm.Ticky
-import GHC.StgToCmm.Prof
-import GHC.StgToCmm.Bind  ( emitBlackHoleCode, emitUpdateFrame )
-import GHC.StgToCmm.InfoTableProv
-
-import GHC.Cmm.Opt
-import GHC.Cmm.Graph
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Cmm.Switch     ( mkSwitchTargets )
-import GHC.Cmm.Info
-import GHC.Cmm.BlockId
-import GHC.Cmm.Lexer
-import GHC.Cmm.CLabel
-import GHC.Cmm.Parser.Config
-import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile)
-import qualified GHC.Cmm.Parser.Monad as PD
-import GHC.Cmm.CallConv
-import GHC.Runtime.Heap.Layout
-import GHC.Parser.Lexer
-import GHC.Parser.Errors.Types
-import GHC.Parser.Errors.Ppr
-
-import GHC.Types.CostCentre
-import GHC.Types.ForeignCall
-import GHC.Unit.Module
-import GHC.Unit.Home
-import GHC.Types.Literal
-import GHC.Types.Unique
-import GHC.Types.Unique.FM
-import GHC.Types.SrcLoc
-import GHC.Types.Tickish  ( GenTickish(SourceNote) )
-import GHC.Utils.Error
-import GHC.Data.StringBuffer
-import GHC.Data.FastString
-import GHC.Utils.Panic
-import GHC.Settings.Constants
-import GHC.Utils.Outputable
-import GHC.Types.Basic
-import GHC.Data.Bag     ( Bag, emptyBag, unitBag, isEmptyBag )
-import GHC.Types.Var
-
-import Control.Monad
-import Data.Array
-import Data.Char        ( ord )
-import System.Exit
-import Data.Maybe
-import qualified Data.Map as M
-import qualified Data.ByteString.Char8 as BS8
-}
-
-%expect 0
-
-%token
-        ':'     { L _ (CmmT_SpecChar ':') }
-        ';'     { L _ (CmmT_SpecChar ';') }
-        '{'     { L _ (CmmT_SpecChar '{') }
-        '}'     { L _ (CmmT_SpecChar '}') }
-        '['     { L _ (CmmT_SpecChar '[') }
-        ']'     { L _ (CmmT_SpecChar ']') }
-        '('     { L _ (CmmT_SpecChar '(') }
-        ')'     { L _ (CmmT_SpecChar ')') }
-        '='     { L _ (CmmT_SpecChar '=') }
-        '`'     { L _ (CmmT_SpecChar '`') }
-        '~'     { L _ (CmmT_SpecChar '~') }
-        '/'     { L _ (CmmT_SpecChar '/') }
-        '*'     { L _ (CmmT_SpecChar '*') }
-        '%'     { L _ (CmmT_SpecChar '%') }
-        '-'     { L _ (CmmT_SpecChar '-') }
-        '+'     { L _ (CmmT_SpecChar '+') }
-        '&'     { L _ (CmmT_SpecChar '&') }
-        '^'     { L _ (CmmT_SpecChar '^') }
-        '|'     { L _ (CmmT_SpecChar '|') }
-        '>'     { L _ (CmmT_SpecChar '>') }
-        '<'     { L _ (CmmT_SpecChar '<') }
-        ','     { L _ (CmmT_SpecChar ',') }
-        '!'     { L _ (CmmT_SpecChar '!') }
-
-        '..'    { L _ (CmmT_DotDot) }
-        '::'    { L _ (CmmT_DoubleColon) }
-        '>>'    { L _ (CmmT_Shr) }
-        '<<'    { L _ (CmmT_Shl) }
-        '>='    { L _ (CmmT_Ge) }
-        '<='    { L _ (CmmT_Le) }
-        '=='    { L _ (CmmT_Eq) }
-        '!='    { L _ (CmmT_Ne) }
-        '&&'    { L _ (CmmT_BoolAnd) }
-        '||'    { L _ (CmmT_BoolOr) }
-
-        'True'  { L _ (CmmT_True ) }
-        'False' { L _ (CmmT_False) }
-        'likely'{ L _ (CmmT_likely)}
-
-        'CLOSURE'       { L _ (CmmT_CLOSURE) }
-        'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }
-        'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
-        'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
-        'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
-        'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
-        'else'          { L _ (CmmT_else) }
-        'export'        { L _ (CmmT_export) }
-        'section'       { L _ (CmmT_section) }
-        'goto'          { L _ (CmmT_goto) }
-        'if'            { L _ (CmmT_if) }
-        'call'          { L _ (CmmT_call) }
-        'jump'          { L _ (CmmT_jump) }
-        'foreign'       { L _ (CmmT_foreign) }
-        'never'         { L _ (CmmT_never) }
-        'prim'          { L _ (CmmT_prim) }
-        'reserve'       { L _ (CmmT_reserve) }
-        'return'        { L _ (CmmT_return) }
-        'returns'       { L _ (CmmT_returns) }
-        'import'        { L _ (CmmT_import) }
-        'switch'        { L _ (CmmT_switch) }
-        'case'          { L _ (CmmT_case) }
-        'default'       { L _ (CmmT_default) }
-        'push'          { L _ (CmmT_push) }
-        'unwind'        { L _ (CmmT_unwind) }
-        'bits8'         { L _ (CmmT_bits8) }
-        'bits16'        { L _ (CmmT_bits16) }
-        'bits32'        { L _ (CmmT_bits32) }
-        'bits64'        { L _ (CmmT_bits64) }
-        'bits128'       { L _ (CmmT_bits128) }
-        'bits256'       { L _ (CmmT_bits256) }
-        'bits512'       { L _ (CmmT_bits512) }
-        'float32'       { L _ (CmmT_float32) }
-        'float64'       { L _ (CmmT_float64) }
-        'gcptr'         { L _ (CmmT_gcptr) }
-
-        GLOBALREG       { L _ (CmmT_GlobalReg   $$) }
-        NAME            { L _ (CmmT_Name        $$) }
-        STRING          { L _ (CmmT_String      $$) }
-        INT             { L _ (CmmT_Int         $$) }
-        FLOAT           { L _ (CmmT_Float       $$) }
-
-%monad { PD } { >>= } { return }
-%lexer { cmmlex } { L _ CmmT_EOF }
-%name cmmParse cmm
-%tokentype { Located CmmToken }
-
--- C-- operator precedences, taken from the C-- spec
-%right '||'     -- non-std extension, called %disjoin in C--
-%right '&&'     -- non-std extension, called %conjoin in C--
-%right '!'
-%nonassoc '>=' '>' '<=' '<' '!=' '=='
-%left '|'
-%left '^'
-%left '&'
-%left '>>' '<<'
-%left '-' '+'
-%left '/' '*' '%'
-%right '~'
-
-%%
-
-cmm     :: { CmmParse () }
-        : {- empty -}                   { return () }
-        | cmmtop cmm                    { do $1; $2 }
-
-cmmtop  :: { CmmParse () }
-        : cmmproc                       { $1 }
-        | cmmdata                       { $1 }
-        | decl                          { $1 }
-        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
-                {% do
-                      home_unit_id <- getHomeUnitId
-                      liftP $ pure $ do
-                        lits <- sequence $6;
-                        staticClosure home_unit_id $3 $5 (map getLit lits) }
-
--- The only static closures in the RTS are dummy closures like
--- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need
--- to provide the full generality of static closures here.
--- In particular:
---      * CCS can always be CCS_DONT_CARE
---      * closure is always extern
---      * payload is always empty
---      * we can derive closure and info table labels from a single NAME
-
-cmmdata :: { CmmParse () }
-        : 'section' STRING '{' data_label statics '}'
-                { do lbl <- $4;
-                     ss <- sequence $5;
-                     code (emitDecl (CmmData (Section (section $2) lbl) (CmmStaticsRaw lbl (concat ss)))) }
-
-data_label :: { CmmParse CLabel }
-    : NAME ':'
-                {% do
-                   home_unit_id <- getHomeUnitId
-                   liftP $ pure $ do
-                     pure (mkCmmDataLabel home_unit_id (NeedExternDecl False) $1) }
-
-statics :: { [CmmParse [CmmStatic]] }
-        : {- empty -}                   { [] }
-        | static statics                { $1 : $2 }
-
-static  :: { CmmParse [CmmStatic] }
-        : type expr ';' { do e <- $2;
-                             return [CmmStaticLit (getLit e)] }
-        | type ';'                      { return [CmmUninitialised
-                                                        (widthInBytes (typeWidth $1))] }
-        | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
-        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised
-                                                        (fromIntegral $3)] }
-        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised
-                                                (widthInBytes (typeWidth $1) *
-                                                        fromIntegral $3)] }
-        | 'CLOSURE' '(' NAME lits ')'
-                { do { lits <- sequence $4
-                ; profile <- getProfile
-                     ; return $ map CmmStaticLit $
-                        mkStaticClosure profile (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
-                         -- mkForeignLabel because these are only used
-                         -- for CHARLIKE and INTLIKE closures in the RTS.
-                        dontCareCCS (map getLit lits) [] [] [] [] } }
-        -- arrays of closures required for the CHARLIKE & INTLIKE arrays
-
-lits    :: { [CmmParse CmmExpr] }
-        : {- empty -}           { [] }
-        | ',' expr lits         { $2 : $3 }
-
-cmmproc :: { CmmParse () }
-        : info maybe_conv maybe_formals maybe_body
-                { do ((entry_ret_label, info, stk_formals, formals), agraph) <-
-                       getCodeScoped $ loopDecls $ do {
-                         (entry_ret_label, info, stk_formals) <- $1;
-                         platform <- getPlatform;
-                         ctx      <- getContext;
-                         formals <- sequence (fromMaybe [] $3);
-                         withName (showSDocOneLine ctx (pprCLabel platform entry_ret_label))
-                           $4;
-                         return (entry_ret_label, info, stk_formals, formals) }
-                     let do_layout = isJust $3
-                     code (emitProcWithStackFrame $2 info
-                                entry_ret_label stk_formals formals agraph
-                                do_layout ) }
-
-maybe_conv :: { Convention }
-           : {- empty -}        { NativeNodeCall }
-           | 'return'           { NativeReturn }
-
-maybe_body :: { CmmParse () }
-           : ';'                { return () }
-           | '{' body '}'       { withSourceNote $1 $3 $2 }
-
-info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
-        : NAME
-                {% do
-                     home_unit_id <- getHomeUnitId
-                     liftP $ pure $ do
-                       newFunctionName $1 home_unit_id
-                       return (mkCmmCodeLabel home_unit_id $1, Nothing, []) }
-
-
-        | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-                -- ptrs, nptrs, closure type, description, type
-                {% do
-                      home_unit_id <- getHomeUnitId
-                      liftP $ pure $ do
-                        profile <- getProfile
-                        let prof = profilingInfo profile $11 $13
-                            rep  = mkRTSRep (fromIntegral $9) $
-                                     mkHeapRep profile False (fromIntegral $5)
-                                                     (fromIntegral $7) Thunk
-                                -- not really Thunk, but that makes the info table
-                                -- we want.
-                        return (mkCmmEntryLabel home_unit_id $3,
-                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3
-                                             , cit_rep = rep
-                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
-                                []) }
-
-        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')'
-                -- ptrs, nptrs, closure type, description, type, arity, fun type
-                {% do
-                      home_unit_id <- getHomeUnitId
-                      liftP $ pure $ do
-                        profile <- getProfile
-                        let prof = profilingInfo profile $11 $13
-                            ty   = Fun (fromIntegral $15) (ArgSpec (fromIntegral $17))
-                            rep = mkRTSRep (fromIntegral $9) $
-                                      mkHeapRep profile False (fromIntegral $5)
-                                                      (fromIntegral $7) ty
-                        return (mkCmmEntryLabel home_unit_id $3,
-                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3
-                                             , cit_rep = rep
-                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
-                                []) }
-                -- we leave most of the fields zero here.  This is only used
-                -- to generate the BCO and CONTINUATION info tables in the RTS at the moment.
-
-        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-                -- ptrs, nptrs, tag, closure type, description, type
-                {% do
-                      home_unit_id <- getHomeUnitId
-                      liftP $ pure $ do
-                        profile <- getProfile
-                        let prof = profilingInfo profile $13 $15
-                            ty  = Constr (fromIntegral $9)  -- Tag
-                                         (BS8.pack $13)
-                            rep = mkRTSRep (fromIntegral $11) $
-                                    mkHeapRep profile False (fromIntegral $5)
-                                                    (fromIntegral $7) ty
-                        return (mkCmmEntryLabel home_unit_id $3,
-                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3
-                                             , cit_rep = rep
-                                             , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },
-                                []) }
-
-                     -- If profiling is on, this string gets duplicated,
-                     -- but that's the way the old code did it we can fix it some other time.
-
-        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-                -- selector, closure type, description, type
-                {% do
-                      home_unit_id <- getHomeUnitId
-                      liftP $ pure $ do
-                        profile <- getProfile
-                        let prof = profilingInfo profile $9 $11
-                            ty  = ThunkSelector (fromIntegral $5)
-                            rep = mkRTSRep (fromIntegral $7) $
-                                     mkHeapRep profile False 0 0 ty
-                        return (mkCmmEntryLabel home_unit_id $3,
-                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3
-                                             , cit_rep = rep
-                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
-                                []) }
-
-        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
-                -- closure type (no live regs)
-                {% do
-                      home_unit_id <- getHomeUnitId
-                      liftP $ pure $ do
-                        let prof = NoProfilingInfo
-                            rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
-                        return (mkCmmRetLabel home_unit_id $3,
-                                Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id $3
-                                             , cit_rep = rep
-                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
-                                []) }
-
-        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
-                -- closure type, live regs
-                {% do
-                      home_unit_id <- getHomeUnitId
-                      liftP $ pure $ do
-                        platform <- getPlatform
-                        live <- sequence $7
-                        let prof = NoProfilingInfo
-                            -- drop one for the info pointer
-                            bitmap = mkLiveness platform (drop 1 live)
-                            rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
-                        return (mkCmmRetLabel home_unit_id $3,
-                                Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id $3
-                                             , cit_rep = rep
-                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
-                                live) }
-
-body    :: { CmmParse () }
-        : {- empty -}                   { return () }
-        | decl body                     { do $1; $2 }
-        | stmt body                     { do $1; $2 }
-
-decl    :: { CmmParse () }
-        : type names ';'                { mapM_ (newLocal $1) $2 }
-        | 'import' importNames ';'      { mapM_ newImport $2 }
-        | 'export' names ';'            { return () }  -- ignore exports
-
-
--- an imported function name, with optional packageId
-importNames
-        :: { [(FastString, CLabel)] }
-        : importName                    { [$1] }
-        | importName ',' importNames    { $1 : $3 }
-
-importName
-        :: { (FastString,  CLabel) }
-
-        -- A label imported without an explicit packageId.
-        --      These are taken to come from some foreign, unnamed package.
-        : NAME
-        { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
-
-        -- as previous 'NAME', but 'IsData'
-        | 'CLOSURE' NAME
-        { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }
-
-        -- A label imported with an explicit UnitId.
-        | STRING NAME
-        { ($2, mkCmmCodeLabel (UnitId (mkFastString $1)) $2) }
-
-
-names   :: { [FastString] }
-        : NAME                          { [$1] }
-        | NAME ',' names                { $1 : $3 }
-
-stmt    :: { CmmParse () }
-        : ';'                                   { return () }
-
-        | NAME ':'
-                { do l <- newLabel $1; emitLabel l }
-
-
-
-        | lreg '=' expr ';'
-                { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) }
-        | type '[' expr ']' '=' expr ';'
-                { withSourceNote $2 $7 (doStore $1 $3 $6) }
-
-        -- Gah! We really want to say "foreign_results" but that causes
-        -- a shift/reduce conflict with assignment.  We either
-        -- we expand out the no-result and single result cases or
-        -- we tweak the syntax to avoid the conflict.  The later
-        -- option is taken here because the other way would require
-        -- multiple levels of expanding and get unwieldy.
-        | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
-                {% foreignCall $3 $1 $4 $6 $8 $9 }
-        | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'
-                {% primCall $1 $4 $6 }
-        -- stmt-level macros, stealing syntax from ordinary C-- function calls.
-        -- Perhaps we ought to use the %%-form?
-        | NAME '(' exprs0 ')' ';'
-                {% stmtMacro $1 $3  }
-        | 'switch' maybe_range expr '{' arms default '}'
-                { do as <- sequence $5; doSwitch $2 $3 as $6 }
-        | 'goto' NAME ';'
-                { do l <- lookupLabel $2; emit (mkBranch l) }
-        | 'return' '(' exprs0 ')' ';'
-                { doReturn $3 }
-        | 'jump' expr vols ';'
-                { doRawJump $2 $3 }
-        | 'jump' expr '(' exprs0 ')' ';'
-                { doJumpWithStack $2 [] $4 }
-        | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';'
-                { doJumpWithStack $2 $4 $7 }
-        | 'call' expr '(' exprs0 ')' ';'
-                { doCall $2 [] $4 }
-        | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'
-                { doCall $6 $2 $8 }
-        | 'if' bool_expr cond_likely 'goto' NAME
-                { do l <- lookupLabel $5; cmmRawIf $2 l $3 }
-        | 'if' bool_expr cond_likely '{' body '}' else
-                { cmmIfThenElse $2 (withSourceNote $4 $6 $5) $7 $3 }
-        | 'push' '(' exprs0 ')' maybe_body
-                { pushStackFrame $3 $5 }
-        | 'reserve' expr '=' lreg maybe_body
-                { reserveStackFrame $2 $4 $5 }
-        | 'unwind' unwind_regs ';'
-                { $2 >>= code . emitUnwind }
-
-unwind_regs
-        :: { CmmParse [(GlobalReg, Maybe CmmExpr)] }
-        : GLOBALREG '=' expr_or_unknown ',' unwind_regs
-                { do e <- $3; rest <- $5; return (($1, e) : rest) }
-        | GLOBALREG '=' expr_or_unknown
-                { do e <- $3; return [($1, e)] }
-
--- | Used by unwind to indicate unknown unwinding values.
-expr_or_unknown
-        :: { CmmParse (Maybe CmmExpr) }
-        : 'return'
-                { do return Nothing }
-        | expr
-                { do e <- $1; return (Just e) }
-
-foreignLabel     :: { CmmParse CmmExpr }
-        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }
-
-opt_never_returns :: { CmmReturnInfo }
-        :                               { CmmMayReturn }
-        | 'never' 'returns'             { CmmNeverReturns }
-
-bool_expr :: { CmmParse BoolExpr }
-        : bool_op                       { $1 }
-        | expr                          { do e <- $1; return (BoolTest e) }
-
-bool_op :: { CmmParse BoolExpr }
-        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3;
-                                          return (BoolAnd e1 e2) }
-        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3;
-                                          return (BoolOr e1 e2)  }
-        | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
-        | '(' bool_op ')'               { $2 }
-
-safety  :: { Safety }
-        : {- empty -}                   { PlayRisky }
-        | STRING                        {% parseSafety $1 }
-
-vols    :: { [GlobalReg] }
-        : '[' ']'                       { [] }
-        | '[' '*' ']'                   {% do platform <- PD.getPlatform
-                                         ; return (realArgRegsCover platform) }
-                                           -- All of them. See comment attached
-                                           -- to realArgRegsCover
-        | '[' globals ']'               { $2 }
-
-globals :: { [GlobalReg] }
-        : GLOBALREG                     { [$1] }
-        | GLOBALREG ',' globals         { $1 : $3 }
-
-maybe_range :: { Maybe (Integer,Integer) }
-        : '[' INT '..' INT ']'  { Just ($2, $4) }
-        | {- empty -}           { Nothing }
-
-arms    :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] }
-        : {- empty -}                   { [] }
-        | arm arms                      { $1 : $2 }
-
-arm     :: { CmmParse ([Integer],Either BlockId (CmmParse ())) }
-        : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
-
-arm_body :: { CmmParse (Either BlockId (CmmParse ())) }
-        : '{' body '}'                  { return (Right (withSourceNote $1 $3 $2)) }
-        | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
-
-ints    :: { [Integer] }
-        : INT                           { [ $1 ] }
-        | INT ',' ints                  { $1 : $3 }
-
-default :: { Maybe (CmmParse ()) }
-        : 'default' ':' '{' body '}'    { Just (withSourceNote $3 $5 $4) }
-        -- taking a few liberties with the C-- syntax here; C-- doesn't have
-        -- 'default' branches
-        | {- empty -}                   { Nothing }
-
--- Note: OldCmm doesn't support a first class 'else' statement, though
--- CmmNode does.
-else    :: { CmmParse () }
-        : {- empty -}                   { return () }
-        | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }
-
-cond_likely :: { Maybe Bool }
-        : '(' 'likely' ':' 'True'  ')'  { Just True  }
-        | '(' 'likely' ':' 'False' ')'  { Just False }
-        | {- empty -}                   { Nothing }
-
-
--- we have to write this out longhand so that Happy's precedence rules
--- can kick in.
-expr    :: { CmmParse CmmExpr }
-        : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
-        | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
-        | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
-        | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
-        | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
-        | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
-        | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
-        | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
-        | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
-        | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
-        | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
-        | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
-        | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
-        | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
-        | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
-        | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
-        | '~' expr                      { mkMachOp MO_Not [$2] }
-        | '-' expr                      { mkMachOp MO_S_Neg [$2] }
-        | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
-                                                return (mkMachOp mo [$1,$5]) } }
-        | expr0                         { $1 }
-
-expr0   :: { CmmParse CmmExpr }
-        : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
-        | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
-        | STRING                 { do s <- code (newStringCLit $1);
-                                      return (CmmLit s) }
-        | reg                    { $1 }
-        | type dereference       { do (align, ptr) <- $2; return (CmmLoad ptr $1 align) }
-        | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
-        | '(' expr ')'           { $2 }
-
-dereference :: { CmmParse (AlignmentSpec, CmmExpr) }
-        : '^' '[' expr ']'       { do ptr <- $3; return (Unaligned, ptr) }
-        | '[' expr ']'           { do ptr <- $2; return (NaturallyAligned, ptr) }
-
--- leaving out the type of a literal gives you the native word size in C--
-maybe_ty :: { CmmType }
-        : {- empty -}                   {% do platform <- PD.getPlatform; return $ bWord platform }
-        | '::' type                     { $2 }
-
-cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
-        : {- empty -}                   { [] }
-        | cmm_hint_exprs                { $1 }
-
-cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }
-        : cmm_hint_expr                 { [$1] }
-        | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
-
-cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }
-        : expr                          { do e <- $1;
-                                             return (e, inferCmmHint e) }
-        | expr STRING                   {% do h <- parseCmmHint $2;
-                                              return $ do
-                                                e <- $1; return (e, h) }
-
-exprs0  :: { [CmmParse CmmExpr] }
-        : {- empty -}                   { [] }
-        | exprs                         { $1 }
-
-exprs   :: { [CmmParse CmmExpr] }
-        : expr                          { [ $1 ] }
-        | expr ',' exprs                { $1 : $3 }
-
-reg     :: { CmmParse CmmExpr }
-        : NAME                  { lookupName $1 }
-        | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
-
-foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }
-        : {- empty -}                   { [] }
-        | '(' foreign_formals ')' '='   { $2 }
-
-foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }
-        : foreign_formal                        { [$1] }
-        | foreign_formal ','                    { [$1] }
-        | foreign_formal ',' foreign_formals    { $1 : $3 }
-
-foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
-        : local_lreg            { do e <- $1; return (e, inferCmmHint (CmmReg (CmmLocal e))) }
-        | STRING local_lreg     {% do h <- parseCmmHint $1;
-                                      return $ do
-                                         e <- $2; return (e,h) }
-
-local_lreg :: { CmmParse LocalReg }
-        : NAME                  { do e <- lookupName $1;
-                                     return $
-                                       case e of
-                                        CmmReg (CmmLocal r) -> r
-                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
-
-lreg    :: { CmmParse CmmReg }
-        : NAME                  { do e <- lookupName $1;
-                                     return $
-                                       case e of
-                                        CmmReg r -> r
-                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
-        | GLOBALREG             { return (CmmGlobal $1) }
-
-maybe_formals :: { Maybe [CmmParse LocalReg] }
-        : {- empty -}           { Nothing }
-        | '(' formals0 ')'      { Just $2 }
-
-formals0 :: { [CmmParse LocalReg] }
-        : {- empty -}           { [] }
-        | formals               { $1 }
-
-formals :: { [CmmParse LocalReg] }
-        : formal ','            { [$1] }
-        | formal                { [$1] }
-        | formal ',' formals       { $1 : $3 }
-
-formal :: { CmmParse LocalReg }
-        : type NAME             { newLocal $1 $2 }
-
-type    :: { CmmType }
-        : 'bits8'               { b8 }
-        | typenot8              { $1 }
-
-typenot8 :: { CmmType }
-        : 'bits16'              { b16 }
-        | 'bits32'              { b32 }
-        | 'bits64'              { b64 }
-        | 'bits128'             { b128 }
-        | 'bits256'             { b256 }
-        | 'bits512'             { b512 }
-        | 'float32'             { f32 }
-        | 'float64'             { f64 }
-        | 'gcptr'               {% do platform <- PD.getPlatform; return $ gcWord platform }
-
-{
-section :: String -> SectionType
-section "text"      = Text
-section "data"      = Data
-section "rodata"    = ReadOnlyData
-section "relrodata" = RelocatableReadOnlyData
-section "bss"       = UninitialisedData
-section s           = OtherSection s
-
-mkString :: String -> CmmStatic
-mkString s = CmmString (BS8.pack s)
-
--- mkMachOp infers the type of the MachOp from the type of its first
--- argument.  We assume that this is correct: for MachOps that don't have
--- symmetrical args (e.g. shift ops), the first arg determines the type of
--- the op.
-mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
-mkMachOp fn args = do
-  platform <- getPlatform
-  arg_exprs <- sequence args
-  return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs)
-
-getLit :: CmmExpr -> CmmLit
-getLit (CmmLit l) = l
-getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
-getLit _ = panic "invalid literal" -- TODO messy failure
-
-nameToMachOp :: FastString -> PD (Width -> MachOp)
-nameToMachOp name =
-  case lookupUFM machOps name of
-        Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name)
-        Just m  -> return m
-
-exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
-exprOp name args_code = do
-  pdc     <- PD.getPDConfig
-  let profile = PD.pdProfile pdc
-  let align_check = PD.pdSanitizeAlignment pdc
-  case lookupUFM (exprMacros profile align_check) name of
-     Just f  -> return $ do
-        args <- sequence args_code
-        return (f args)
-     Nothing -> do
-        mo <- nameToMachOp name
-        return $ mkMachOp mo args_code
-
-exprMacros :: Profile -> DoAlignSanitisation -> UniqFM FastString ([CmmExpr] -> CmmExpr)
-exprMacros profile align_check = listToUFM [
-  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode platform x ),
-  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr platform align_check x ),
-  ( fsLit "STD_INFO",     \ [x] -> infoTable    profile x ),
-  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable profile x ),
-  ( fsLit "GET_ENTRY",    \ [x] -> entryCode platform   (closureInfoPtr platform align_check x) ),
-  ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile    (closureInfoPtr platform align_check x) ),
-  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr platform align_check x) ),
-  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType profile x ),
-  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs profile x ),
-  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs profile x )
-  ]
-  where
-    platform = profilePlatform profile
-
--- we understand a subset of C-- primitives:
-machOps = listToUFM $
-        map (\(x, y) -> (mkFastString x, y)) [
-        ( "add",        MO_Add ),
-        ( "sub",        MO_Sub ),
-        ( "eq",         MO_Eq ),
-        ( "ne",         MO_Ne ),
-        ( "mul",        MO_Mul ),
-        ( "mulmayoflo",  MO_S_MulMayOflo ),
-        ( "neg",        MO_S_Neg ),
-        ( "quot",       MO_S_Quot ),
-        ( "rem",        MO_S_Rem ),
-        ( "divu",       MO_U_Quot ),
-        ( "modu",       MO_U_Rem ),
-
-        ( "ge",         MO_S_Ge ),
-        ( "le",         MO_S_Le ),
-        ( "gt",         MO_S_Gt ),
-        ( "lt",         MO_S_Lt ),
-
-        ( "geu",        MO_U_Ge ),
-        ( "leu",        MO_U_Le ),
-        ( "gtu",        MO_U_Gt ),
-        ( "ltu",        MO_U_Lt ),
-
-        ( "and",        MO_And ),
-        ( "or",         MO_Or ),
-        ( "xor",        MO_Xor ),
-        ( "com",        MO_Not ),
-        ( "shl",        MO_Shl ),
-        ( "shrl",       MO_U_Shr ),
-        ( "shra",       MO_S_Shr ),
-
-        ( "fadd",       MO_F_Add ),
-        ( "fsub",       MO_F_Sub ),
-        ( "fneg",       MO_F_Neg ),
-        ( "fmul",       MO_F_Mul ),
-        ( "fquot",      MO_F_Quot ),
-
-        ( "feq",        MO_F_Eq ),
-        ( "fne",        MO_F_Ne ),
-        ( "fge",        MO_F_Ge ),
-        ( "fle",        MO_F_Le ),
-        ( "fgt",        MO_F_Gt ),
-        ( "flt",        MO_F_Lt ),
-
-        ( "lobits8",  flip MO_UU_Conv W8  ),
-        ( "lobits16", flip MO_UU_Conv W16 ),
-        ( "lobits32", flip MO_UU_Conv W32 ),
-        ( "lobits64", flip MO_UU_Conv W64 ),
-
-        ( "zx16",     flip MO_UU_Conv W16 ),
-        ( "zx32",     flip MO_UU_Conv W32 ),
-        ( "zx64",     flip MO_UU_Conv W64 ),
-
-        ( "sx16",     flip MO_SS_Conv W16 ),
-        ( "sx32",     flip MO_SS_Conv W32 ),
-        ( "sx64",     flip MO_SS_Conv W64 ),
-
-        ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode
-        ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode
-        ( "f2i8",     flip MO_FS_Conv W8 ),
-        ( "f2i16",    flip MO_FS_Conv W16 ),
-        ( "f2i32",    flip MO_FS_Conv W32 ),
-        ( "f2i64",    flip MO_FS_Conv W64 ),
-        ( "i2f32",    flip MO_SF_Conv W32 ),
-        ( "i2f64",    flip MO_SF_Conv W64 )
-        ]
-
-callishMachOps :: Platform -> UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
-callishMachOps platform = listToUFM $
-        map (\(x, y) -> (mkFastString x, y)) [
-
-        ( "pow64f", (MO_F64_Pwr,) ),
-        ( "sin64f", (MO_F64_Sin,) ),
-        ( "cos64f", (MO_F64_Cos,) ),
-        ( "tan64f", (MO_F64_Tan,) ),
-        ( "sinh64f", (MO_F64_Sinh,) ),
-        ( "cosh64f", (MO_F64_Cosh,) ),
-        ( "tanh64f", (MO_F64_Tanh,) ),
-        ( "asin64f", (MO_F64_Asin,) ),
-        ( "acos64f", (MO_F64_Acos,) ),
-        ( "atan64f", (MO_F64_Atan,) ),
-        ( "asinh64f", (MO_F64_Asinh,) ),
-        ( "acosh64f", (MO_F64_Acosh,) ),
-        ( "log64f", (MO_F64_Log,) ),
-        ( "log1p64f", (MO_F64_Log1P,) ),
-        ( "exp64f", (MO_F64_Exp,) ),
-        ( "expM164f", (MO_F64_ExpM1,) ),
-        ( "fabs64f", (MO_F64_Fabs,) ),
-        ( "sqrt64f", (MO_F64_Sqrt,) ),
-
-        ( "pow32f", (MO_F32_Pwr,) ),
-        ( "sin32f", (MO_F32_Sin,) ),
-        ( "cos32f", (MO_F32_Cos,) ),
-        ( "tan32f", (MO_F32_Tan,) ),
-        ( "sinh32f", (MO_F32_Sinh,) ),
-        ( "cosh32f", (MO_F32_Cosh,) ),
-        ( "tanh32f", (MO_F32_Tanh,) ),
-        ( "asin32f", (MO_F32_Asin,) ),
-        ( "acos32f", (MO_F32_Acos,) ),
-        ( "atan32f", (MO_F32_Atan,) ),
-        ( "asinh32f", (MO_F32_Asinh,) ),
-        ( "acosh32f", (MO_F32_Acosh,) ),
-        ( "log32f", (MO_F32_Log,) ),
-        ( "log1p32f", (MO_F32_Log1P,) ),
-        ( "exp32f", (MO_F32_Exp,) ),
-        ( "expM132f", (MO_F32_ExpM1,) ),
-        ( "fabs32f", (MO_F32_Fabs,) ),
-        ( "sqrt32f", (MO_F32_Sqrt,) ),
-
-        ( "read_barrier", (MO_ReadBarrier,)),
-        ( "write_barrier", (MO_WriteBarrier,)),
-        ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
-        ( "memset", memcpyLikeTweakArgs MO_Memset ),
-        ( "memmove", memcpyLikeTweakArgs MO_Memmove ),
-        ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),
-
-        ( "suspendThread", (MO_SuspendThread,) ),
-        ( "resumeThread",  (MO_ResumeThread,) ),
-
-        ("prefetch0", (MO_Prefetch_Data 0,)),
-        ("prefetch1", (MO_Prefetch_Data 1,)),
-        ("prefetch2", (MO_Prefetch_Data 2,)),
-        ("prefetch3", (MO_Prefetch_Data 3,)),
-
-        ( "popcnt8",  (MO_PopCnt W8,)),
-        ( "popcnt16", (MO_PopCnt W16,)),
-        ( "popcnt32", (MO_PopCnt W32,)),
-        ( "popcnt64", (MO_PopCnt W64,)),
-
-        ( "pdep8",  (MO_Pdep W8,)),
-        ( "pdep16", (MO_Pdep W16,)),
-        ( "pdep32", (MO_Pdep W32,)),
-        ( "pdep64", (MO_Pdep W64,)),
-
-        ( "pext8",  (MO_Pext W8,)),
-        ( "pext16", (MO_Pext W16,)),
-        ( "pext32", (MO_Pext W32,)),
-        ( "pext64", (MO_Pext W64,)),
-
-        ( "cmpxchg8",  (MO_Cmpxchg W8,)),
-        ( "cmpxchg16", (MO_Cmpxchg W16,)),
-        ( "cmpxchg32", (MO_Cmpxchg W32,)),
-        ( "cmpxchg64", (MO_Cmpxchg W64,)),
-
-        ( "xchg8",  (MO_Xchg W8,)),
-        ( "xchg16", (MO_Xchg W16,)),
-        ( "xchg32", (MO_Xchg W32,)),
-        ( "xchg64", (MO_Xchg W64,))
-    ]
-  where
-    memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])
-    memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"
-    memcpyLikeTweakArgs op args@(_:_) =
-        (op align, args')
-      where
-        args' = init args
-        align = case last args of
-          CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger
-          e -> pgmErrorDoc "Non-constant alignment in memcpy-like function:" (pdoc platform e)
-        -- The alignment of memcpy-ish operations must be a
-        -- compile-time constant. We verify this here, passing it around
-        -- in the MO_* constructor. In order to do this, however, we
-        -- must intercept the arguments in primCall.
-
-parseSafety :: String -> PD Safety
-parseSafety "safe"   = return PlaySafe
-parseSafety "unsafe" = return PlayRisky
-parseSafety "interruptible" = return PlayInterruptible
-parseSafety str      = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $
-                                              PsErrCmmParser (CmmUnrecognisedSafety str)
-
-parseCmmHint :: String -> PD ForeignHint
-parseCmmHint "ptr"    = return AddrHint
-parseCmmHint "signed" = return SignedHint
-parseCmmHint str      = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $
-                                               PsErrCmmParser (CmmUnrecognisedHint str)
-
--- labels are always pointers, so we might as well infer the hint
-inferCmmHint :: CmmExpr -> ForeignHint
-inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
-inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
-inferCmmHint _ = NoHint
-
-isPtrGlobalReg Sp                    = True
-isPtrGlobalReg SpLim                 = True
-isPtrGlobalReg Hp                    = True
-isPtrGlobalReg HpLim                 = True
-isPtrGlobalReg CCCS                  = True
-isPtrGlobalReg CurrentTSO            = True
-isPtrGlobalReg CurrentNursery        = True
-isPtrGlobalReg (VanillaReg _ VGcPtr) = True
-isPtrGlobalReg _                     = False
-
-happyError :: PD a
-happyError = PD $ \_ _ s -> unP srcParseFail s
-
--- -----------------------------------------------------------------------------
--- Statement-level macros
-
-stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())
-stmtMacro fun args_code = do
-  case lookupUFM stmtMacros fun of
-    Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownMacro fun)
-    Just fcode -> return $ do
-        args <- sequence args_code
-        code (fcode args)
-
-stmtMacros :: UniqFM FastString ([CmmExpr] -> FCode ())
-stmtMacros = listToUFM [
-  ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
-  ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),
-
-  ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
-  ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
-
-  -- completely generic heap and stack checks, for use in high-level cmm.
-  ( fsLit "HP_CHK_GEN",            \[bytes] ->
-                                      heapStackCheckGen Nothing (Just bytes) ),
-  ( fsLit "STK_CHK_GEN",           \[] ->
-                                      heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),
-
-  -- A stack check for a fixed amount of stack.  Sounds a bit strange, but
-  -- we use the stack for a bit of temporary storage in a couple of primops
-  ( fsLit "STK_CHK_GEN_N",         \[bytes] ->
-                                      heapStackCheckGen (Just bytes) Nothing ),
-
-  -- A stack check on entry to a thunk, where the argument is the thunk pointer.
-  ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),
-
-  ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),
-  ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),
-
-  ( fsLit "SAVE_REGS",             \[] -> emitSaveRegs ),
-  ( fsLit "RESTORE_REGS",          \[] -> emitRestoreRegs ),
-
-  ( fsLit "PUSH_TUPLE_REGS",      \[live_regs] -> emitPushTupleRegs live_regs ),
-  ( fsLit "POP_TUPLE_REGS",       \[live_regs] -> emitPopTupleRegs live_regs ),
-
-  ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),
-  ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),
-
-  ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
-  ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
-                                        emitSetDynHdr ptr info ccs ),
-  ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
-                                        tickyAllocPrim hdr goods slop ),
-  ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->
-                                        tickyAllocPAP goods slop ),
-  ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->
-                                        tickyAllocThunk goods slop ),
-  ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )
- ]
-
-emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
-emitPushUpdateFrame sp e = do
-  emitUpdateFrame sp mkUpdInfoLabel e
-
-pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()
-pushStackFrame fields body = do
-  profile <- getProfile
-  exprs <- sequence fields
-  updfr_off <- getUpdFrameOff
-  let (new_updfr_off, _, g) = copyOutOflow profile NativeReturn Ret Old
-                                           [] updfr_off exprs
-  emit g
-  withUpdFrameOff new_updfr_off body
-
-reserveStackFrame
-  :: CmmParse CmmExpr
-  -> CmmParse CmmReg
-  -> CmmParse ()
-  -> CmmParse ()
-reserveStackFrame psize preg body = do
-  platform <- getPlatform
-  old_updfr_off <- getUpdFrameOff
-  reg <- preg
-  esize <- psize
-  let size = case constantFoldExpr platform esize of
-               CmmLit (CmmInt n _) -> n
-               _other -> pprPanic "CmmParse: not a compile-time integer: "
-                            (pdoc platform esize)
-  let frame = old_updfr_off + platformWordSizeInBytes platform * fromIntegral size
-  emitAssign reg (CmmStackSlot Old frame)
-  withUpdFrameOff frame body
-
-profilingInfo profile desc_str ty_str
-  = if not (profileIsProfiling profile)
-    then NoProfilingInfo
-    else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)
-
-staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
-staticClosure pkg cl_label info payload
-  = do profile <- getProfile
-       let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] []
-       code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits
-
-foreignCall
-        :: String
-        -> [CmmParse (LocalReg, ForeignHint)]
-        -> CmmParse CmmExpr
-        -> [CmmParse (CmmExpr, ForeignHint)]
-        -> Safety
-        -> CmmReturnInfo
-        -> PD (CmmParse ())
-foreignCall conv_string results_code expr_code args_code safety ret
-  = do  conv <- case conv_string of
-          "C"       -> return CCallConv
-          "stdcall" -> return StdCallConv
-          _         -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $
-                                              PsErrCmmParser (CmmUnknownCConv conv_string)
-        return $ do
-          platform <- getPlatform
-          results <- sequence results_code
-          expr <- expr_code
-          args <- sequence args_code
-          let
-                  expr' = adjCallTarget platform conv expr args
-                  (arg_exprs, arg_hints) = unzip args
-                  (res_regs,  res_hints) = unzip results
-                  fc = ForeignConvention conv arg_hints res_hints ret
-                  target = ForeignTarget expr' fc
-          _ <- code $ emitForeignCall safety res_regs target arg_exprs
-          return ()
-
-
-doReturn :: [CmmParse CmmExpr] -> CmmParse ()
-doReturn exprs_code = do
-  profile <- getProfile
-  exprs <- sequence exprs_code
-  updfr_off <- getUpdFrameOff
-  emit (mkReturnSimple profile exprs updfr_off)
-
-mkReturnSimple  :: Profile -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
-mkReturnSimple profile actuals updfr_off =
-  mkReturn profile e actuals updfr_off
-  where e = entryCode platform (cmmLoadGCWord platform (CmmStackSlot Old updfr_off))
-        platform = profilePlatform profile
-
-doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
-doRawJump expr_code vols = do
-  profile <- getProfile
-  expr <- expr_code
-  updfr_off <- getUpdFrameOff
-  emit (mkRawJump profile expr updfr_off vols)
-
-doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
-                -> [CmmParse CmmExpr] -> CmmParse ()
-doJumpWithStack expr_code stk_code args_code = do
-  profile <- getProfile
-  expr <- expr_code
-  stk_args <- sequence stk_code
-  args <- sequence args_code
-  updfr_off <- getUpdFrameOff
-  emit (mkJumpExtra profile NativeNodeCall expr args updfr_off stk_args)
-
-doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
-       -> CmmParse ()
-doCall expr_code res_code args_code = do
-  expr <- expr_code
-  args <- sequence args_code
-  ress <- sequence res_code
-  updfr_off <- getUpdFrameOff
-  c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
-  emit c
-
-adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
-              -> CmmExpr
--- On Windows, we have to add the '@N' suffix to the label when making
--- a call with the stdcall calling convention.
-adjCallTarget platform StdCallConv (CmmLit (CmmLabel lbl)) args
- | platformOS platform == OSMinGW32
-  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
-  where size (e, _) = max (platformWordSizeInBytes platform) (widthInBytes (typeWidth (cmmExprType platform e)))
-                 -- c.f. CgForeignCall.emitForeignCall
-adjCallTarget _ _ expr _
-  = expr
-
-primCall
-        :: [CmmParse (CmmFormal, ForeignHint)]
-        -> FastString
-        -> [CmmParse CmmExpr]
-        -> PD (CmmParse ())
-primCall results_code name args_code
-  = do
-    platform <- PD.getPlatform
-    case lookupUFM (callishMachOps platform) name of
-        Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name)
-        Just f  -> return $ do
-                results <- sequence results_code
-                args <- sequence args_code
-                let (p, args') = f args
-                code (emitPrimCall (map fst results) p args')
-
-doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()
-doStore rep addr_code val_code
-  = do platform <- getPlatform
-       addr <- addr_code
-       val <- val_code
-        -- if the specified store type does not match the type of the expr
-        -- on the rhs, then we insert a coercion that will cause the type
-        -- mismatch to be flagged by cmm-lint.  If we don't do this, then
-        -- the store will happen at the wrong type, and the error will not
-        -- be noticed.
-       let val_width = typeWidth (cmmExprType platform val)
-           rep_width = typeWidth rep
-       let coerce_val
-                | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
-                | otherwise              = val
-       emitStore addr coerce_val
-
--- -----------------------------------------------------------------------------
--- If-then-else and boolean expressions
-
-data BoolExpr
-  = BoolExpr `BoolAnd` BoolExpr
-  | BoolExpr `BoolOr`  BoolExpr
-  | BoolNot BoolExpr
-  | BoolTest CmmExpr
-
--- ToDo: smart constructors which simplify the boolean expression.
-
-cmmIfThenElse cond then_part else_part likely = do
-     then_id <- newBlockId
-     join_id <- newBlockId
-     c <- cond
-     emitCond c then_id likely
-     else_part
-     emit (mkBranch join_id)
-     emitLabel then_id
-     then_part
-     -- fall through to join
-     emitLabel join_id
-
-cmmRawIf cond then_id likely = do
-    c <- cond
-    emitCond c then_id likely
-
--- 'emitCond cond true_id'  emits code to test whether the cond is true,
--- branching to true_id if so, and falling through otherwise.
-emitCond (BoolTest e) then_id likely = do
-  else_id <- newBlockId
-  emit (mkCbranch e then_id else_id likely)
-  emitLabel else_id
-emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely
-  | Just op' <- maybeInvertComparison op
-  = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely)
-emitCond (BoolNot e) then_id likely = do
-  else_id <- newBlockId
-  emitCond e else_id likely
-  emit (mkBranch then_id)
-  emitLabel else_id
-emitCond (e1 `BoolOr` e2) then_id likely = do
-  emitCond e1 then_id likely
-  emitCond e2 then_id likely
-emitCond (e1 `BoolAnd` e2) then_id likely = do
-        -- we'd like to invert one of the conditionals here to avoid an
-        -- extra branch instruction, but we can't use maybeInvertComparison
-        -- here because we can't look too closely at the expression since
-        -- we're in a loop.
-  and_id <- newBlockId
-  else_id <- newBlockId
-  emitCond e1 and_id likely
-  emit (mkBranch else_id)
-  emitLabel and_id
-  emitCond e2 then_id likely
-  emitLabel else_id
-
--- -----------------------------------------------------------------------------
--- Source code notes
-
--- | Generate a source note spanning from "a" to "b" (inclusive), then
--- proceed with parsing. This allows debugging tools to reason about
--- locations in Cmm code.
-withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c
-withSourceNote a b parse = do
-  name <- getName
-  case combineSrcSpans (getLoc a) (getLoc b) of
-    RealSrcSpan span _ -> code (emitTick (SourceNote span name)) >> parse
-    _other           -> parse
-
--- -----------------------------------------------------------------------------
--- Table jumps
-
--- We use a simplified form of C-- switch statements for now.  A
--- switch statement always compiles to a table jump.  Each arm can
--- specify a list of values (not ranges), and there can be a single
--- default branch.  The range of the table is given either by the
--- optional range on the switch (eg. switch [0..7] {...}), or by
--- the minimum/maximum values from the branches.
-
-doSwitch :: Maybe (Integer,Integer)
-         -> CmmParse CmmExpr
-         -> [([Integer],Either BlockId (CmmParse ()))]
-         -> Maybe (CmmParse ()) -> CmmParse ()
-doSwitch mb_range scrut arms deflt
-   = do
-        -- Compile code for the default branch
-        dflt_entry <-
-                case deflt of
-                  Nothing -> return Nothing
-                  Just e  -> do b <- forkLabelledCode e; return (Just b)
-
-        -- Compile each case branch
-        table_entries <- mapM emitArm arms
-        let table = M.fromList (concat table_entries)
-
-        platform <- getPlatform
-        let range = fromMaybe (0, platformMaxWord platform) mb_range
-
-        expr <- scrut
-        -- ToDo: check for out of range and jump to default if necessary
-        emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)
-   where
-        emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]
-        emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
-        emitArm (ints,Right code) = do
-           blockid <- forkLabelledCode code
-           return [ (i,blockid) | i <- ints ]
-
-forkLabelledCode :: CmmParse () -> CmmParse BlockId
-forkLabelledCode p = do
-  (_,ag) <- getCodeScoped p
-  l <- newBlockId
-  emitOutOfLine l ag
-  return l
-
--- -----------------------------------------------------------------------------
--- Putting it all together
-
--- The initial environment: we define some constants that the compiler
--- knows about here.
-initEnv :: Profile -> Env
-initEnv profile = listToUFM [
-  ( fsLit "SIZEOF_StgHeader",
-    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize profile)) (wordWidth platform)) )),
-  ( fsLit "SIZEOF_StgInfoTable",
-    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB profile)) (wordWidth platform)) ))
-  ]
-  where platform = profilePlatform profile
-
-parseCmmFile :: CmmParserConfig
-             -> Module
-             -> HomeUnit
-             -> FilePath
-             -> IO (Messages PsMessage, Messages PsMessage, Maybe (CmmGroup, [InfoProvEnt]))
-parseCmmFile cmmpConfig this_mod home_unit filename = do
-  buf <- hGetStringBuffer filename
-  let
-        init_loc = mkRealSrcLoc (mkFastString filename) 1 1
-        init_state = (initParserState (cmmpParserOpts cmmpConfig) buf init_loc) { lex_state = [0] }
-                -- reset the lex_state: the Lexer monad leaves some stuff
-                -- in there we don't want.
-        pdConfig = cmmpPDConfig cmmpConfig
-  case unPD cmmParse pdConfig home_unit init_state of
-    PFailed pst -> do
-        let (warnings,errors) = getPsMessages pst
-        return (warnings, errors, Nothing)
-    POk pst code -> do
-        st <- initC
-        let fstate = F.initFCodeState (profilePlatform $ pdProfile pdConfig)
-        let fcode = do
-              ((), cmm) <- getCmm $ unEC code "global" (initEnv (pdProfile pdConfig)) [] >> return ()
-              -- See Note [Mapping Info Tables to Source Positions] (IPE Maps)
-              let used_info
-                    | do_ipe    = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTable cmm)
-                    | otherwise = []
-                    where
-                      do_ipe = stgToCmmInfoTableMap $ cmmpStgToCmmConfig cmmpConfig
-              ((), cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info
-              return (cmm ++ cmm2, used_info)
-            (cmm, _) = runC (cmmpStgToCmmConfig cmmpConfig) fstate st fcode
-            (warnings,errors) = getPsMessages pst
-        if not (isEmptyMessages errors)
-         then return (warnings, errors, Nothing)
-         else return (warnings, errors, Just cmm)
-
-}
diff --git a/compiler/GHC/Cmm/Parser/Config.hs b/compiler/GHC/Cmm/Parser/Config.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Parser/Config.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-module GHC.Cmm.Parser.Config (
-    PDConfig(..)
-  , CmmParserConfig(..)
-) where
-
-import GHC.Prelude
-
-import GHC.Platform.Profile
-
-import GHC.StgToCmm.Config
-
-import GHC.Parser.Lexer
-
-
-data PDConfig = PDConfig
-  { pdProfile :: !Profile
-  , pdSanitizeAlignment :: !Bool -- ^ Insert alignment checks (cf @-falignment-sanitisation@)
-  }
-
-data CmmParserConfig = CmmParserConfig
-  { cmmpParserOpts :: !ParserOpts
-  , cmmpPDConfig :: !PDConfig
-  , cmmpStgToCmmConfig :: !StgToCmmConfig
-  }
diff --git a/compiler/GHC/Cmm/Parser/Monad.hs b/compiler/GHC/Cmm/Parser/Monad.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Parser/Monad.hs
+++ /dev/null
@@ -1,75 +0,0 @@
------------------------------------------------------------------------------
--- A Parser monad with access to the 'DynFlags'.
---
--- The 'P' monad only has access to the subset of 'DynFlags'
--- required for parsing Haskell.
-
--- The parser for C-- requires access to a lot more of the 'DynFlags',
--- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.
------------------------------------------------------------------------------
-module GHC.Cmm.Parser.Monad (
-    PD(..)
-  , liftP
-  , failMsgPD
-  , getPDConfig
-  , getProfile
-  , getPlatform
-  , getHomeUnitId
-  , PDConfig(..)
-  ) where
-
-import GHC.Prelude
-
-import GHC.Cmm.Parser.Config
-
-import GHC.Platform
-import GHC.Platform.Profile
-
-import Control.Monad
-
-import GHC.Parser.Lexer
-import GHC.Parser.Errors.Types
-import GHC.Types.Error ( MsgEnvelope )
-import GHC.Types.SrcLoc
-import GHC.Unit.Types
-import GHC.Unit.Home
-
-newtype PD a = PD { unPD :: PDConfig -> HomeUnit -> PState -> ParseResult a }
-
-instance Functor PD where
-  fmap = liftM
-
-instance Applicative PD where
-  pure = returnPD
-  (<*>) = ap
-
-instance Monad PD where
-  (>>=) = thenPD
-
-liftP :: P a -> PD a
-liftP (P f) = PD $ \_ _ s -> f s
-
-failMsgPD :: (SrcSpan -> MsgEnvelope PsMessage) -> PD a
-failMsgPD = liftP . failMsgP
-
-returnPD :: a -> PD a
-returnPD = liftP . return
-
-thenPD :: PD a -> (a -> PD b) -> PD b
-(PD m) `thenPD` k = PD $ \d hu s ->
-        case m d hu s of
-                POk s1 a   -> unPD (k a) d hu s1
-                PFailed s1 -> PFailed s1
-
-getPDConfig :: PD PDConfig
-getPDConfig = PD $ \pdc _ s -> POk s pdc
-
-getProfile :: PD Profile
-getProfile = PD $ \pdc _ s -> POk s (pdProfile pdc)
-
-getPlatform :: PD Platform
-getPlatform = profilePlatform <$> getProfile
-
--- | Return the UnitId of the home-unit. This is used to create labels.
-getHomeUnitId :: PD UnitId
-getHomeUnitId = PD $ \_ hu s -> POk s (homeUnitId hu)
diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Pipeline.hs
+++ /dev/null
@@ -1,372 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-
-module GHC.Cmm.Pipeline (
-  cmmPipeline
-) where
-
-import GHC.Prelude
-
-import GHC.Driver.Flags
-
-import GHC.Cmm
-import GHC.Cmm.Config
-import GHC.Cmm.ContFlowOpt
-import GHC.Cmm.CommonBlockElim
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Info.Build
-import GHC.Cmm.Lint
-import GHC.Cmm.LayoutStack
-import GHC.Cmm.ProcPoint
-import GHC.Cmm.Sink
-import GHC.Cmm.Switch.Implement
-
-import GHC.Types.Unique.Supply
-
-import GHC.Utils.Error
-import GHC.Utils.Logger
-import GHC.Utils.Outputable
-
-import GHC.Platform
-
-import Control.Monad
-import Data.Either (partitionEithers)
-
------------------------------------------------------------------------------
--- | Top level driver for C-- pipeline
------------------------------------------------------------------------------
-
--- | Converts C-- with an implicit stack and native C-- calls into
--- optimized, CPS converted and native-call-less C--.  The latter
--- C-- can be used to generate assembly.
-cmmPipeline
- :: Logger
- -> CmmConfig
- -> ModuleSRTInfo        -- Info about SRTs generated so far
- -> CmmGroup             -- Input C-- with Procedures
- -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C--
-
-cmmPipeline logger cmm_config srtInfo prog = do
-  let forceRes (info, group) = info `seq` foldr seq () group
-  let platform = cmmPlatform cmm_config
-  withTimingSilent logger (text "Cmm pipeline") forceRes $ do
-     tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmm_config) prog
-
-     let (procs, data_) = partitionEithers tops
-     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo procs data_
-     dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)
-
-     return (srtInfo, cmms)
-
-
--- | The Cmm pipeline for a single 'CmmDecl'. Returns:
---
---   - in the case of a 'CmmProc': 'Left' of the resulting (possibly
---     proc-point-split) 'CmmDecl's and their 'CafEnv'. CAF analysis
---     necessarily happens *before* proc-point splitting, as described in Note
---     [SRTs].
---
---   - in the case of a `CmmData`, the unmodified 'CmmDecl' and a 'CAFSet' containing
-cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))
-cpsTop _logger platform _ p@(CmmData _ statics) = return (Right (cafAnalData platform statics, p))
-cpsTop logger platform cfg proc =
-    do
-      ----------- Control-flow optimisations ----------------------------------
-
-      -- The first round of control-flow optimisation speeds up the
-      -- later passes by removing lots of empty blocks, so we do it
-      -- even when optimisation isn't turned on.
-      --
-      CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}
-           return $ cmmCfgOptsProc splitting_proc_points proc
-      dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
-
-      let !TopInfo {stack_info=StackInfo { arg_space = entry_off
-                                         , do_layout = do_layout }} = h
-
-      ----------- Eliminate common blocks -------------------------------------
-      g <- {-# SCC "elimCommonBlocks" #-}
-           condPass (cmmOptElimCommonBlks cfg) elimCommonBlocks g
-                         Opt_D_dump_cmm_cbe "Post common block elimination"
-
-      -- Any work storing block Labels must be performed _after_
-      -- elimCommonBlocks
-
-      ----------- Implement switches ------------------------------------------
-      g <- if cmmDoCmmSwitchPlans cfg
-             then {-# SCC "createSwitchPlans" #-}
-                  runUniqSM $ cmmImplementSwitchPlans platform g
-             else pure g
-      dump Opt_D_dump_cmm_switch "Post switch plan" g
-
-      ----------- Proc points -------------------------------------------------
-      let
-        call_pps :: ProcPointSet -- LabelMap
-        call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
-      proc_points <-
-         if splitting_proc_points
-            then do
-              pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
-                 minimalProcPointSet platform call_pps g
-              dumpWith logger Opt_D_dump_cmm_proc "Proc points"
-                    FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g)
-              return pp
-            else
-              return call_pps
-
-      ----------- Layout the stack and manifest Sp ----------------------------
-      (g, stackmaps) <-
-           {-# SCC "layoutStack" #-}
-           if do_layout
-              then runUniqSM $ cmmLayoutStack cfg proc_points entry_off g
-              else return (g, mapEmpty)
-      dump Opt_D_dump_cmm_sp "Layout Stack" g
-
-      ----------- Sink and inline assignments  --------------------------------
-      g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]
-           condPass (cmmOptSink cfg) (cmmSink platform) g
-                    Opt_D_dump_cmm_sink "Sink assignments"
-
-      ------------- CAF analysis ----------------------------------------------
-      let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g
-      dumpWith logger Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv)
-
-      g <- if splitting_proc_points
-           then do
-             ------------- Split into separate procedures -----------------------
-             let pp_map = {-# SCC "procPointAnalysis" #-}
-                          procPointAnalysis proc_points g
-             dumpWith logger Opt_D_dump_cmm_procmap "procpoint map"
-                FormatCMM (ppr pp_map)
-             g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
-                  splitAtProcPoints platform l call_pps proc_points pp_map
-                                    (CmmProc h l v g)
-             dumps Opt_D_dump_cmm_split "Post splitting" g
-             return g
-           else
-             -- attach info tables to return points
-             return $ [attachContInfoTables call_pps (CmmProc h l v g)]
-
-      ------------- Populate info tables with stack info -----------------
-      g <- {-# SCC "setInfoTableStackMap" #-}
-           return $ map (setInfoTableStackMap platform stackmaps) g
-      dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g
-
-      ----------- Control-flow optimisations -----------------------------
-      g <- {-# SCC "cmmCfgOpts(2)" #-}
-           return $ if cmmOptControlFlow cfg
-                    then map (cmmCfgOptsProc splitting_proc_points) g
-                    else g
-      g <- return $ map (removeUnreachableBlocksProc platform) g
-           -- See Note [unreachable blocks]
-      dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
-
-      return (Left (cafEnv, g))
-
-  where dump = dumpGraph logger platform (cmmDoLinting cfg)
-
-        dumps flag name
-           = mapM_ (dumpWith logger flag name FormatCMM . pdoc platform)
-
-        condPass do_opt pass g dumpflag dumpname =
-            if do_opt
-               then do
-                    g <- return $ pass g
-                    dump dumpflag dumpname g
-                    return g
-               else return g
-
-        -- we don't need to split proc points for the NCG, unless
-        -- tablesNextToCode is off.  The latter is because we have no
-        -- label to put on info tables for basic blocks that are not
-        -- the entry point.
-        splitting_proc_points = cmmSplitProcPoints cfg
-
--- Note [Sinking after stack layout]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- In the past we considered running sinking pass also before stack
--- layout, but after making some measurements we realized that:
---
---   a) running sinking only before stack layout produces slower
---      code than running sinking only before stack layout
---
---   b) running sinking both before and after stack layout produces
---      code that has the same performance as when running sinking
---      only after stack layout.
---
--- In other words sinking before stack layout doesn't buy as anything.
---
--- An interesting question is "why is it better to run sinking after
--- stack layout"? It seems that the major reason are stores and loads
--- generated by stack layout. Consider this code before stack layout:
---
---  c1E:
---      _c1C::P64 = R3;
---      _c1B::P64 = R2;
---      _c1A::P64 = R1;
---      I64[(young<c1D> + 8)] = c1D;
---      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
---  c1D:
---      R3 = _c1C::P64;
---      R2 = _c1B::P64;
---      R1 = _c1A::P64;
---      call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8;
---
--- Stack layout pass will save all local variables live across a call
--- (_c1C, _c1B and _c1A in this example) on the stack just before
--- making a call and reload them from the stack after returning from a
--- call:
---
---  c1E:
---      _c1C::P64 = R3;
---      _c1B::P64 = R2;
---      _c1A::P64 = R1;
---      I64[Sp - 32] = c1D;
---      P64[Sp - 24] = _c1A::P64;
---      P64[Sp - 16] = _c1B::P64;
---      P64[Sp - 8] = _c1C::P64;
---      Sp = Sp - 32;
---      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
---  c1D:
---      _c1A::P64 = P64[Sp + 8];
---      _c1B::P64 = P64[Sp + 16];
---      _c1C::P64 = P64[Sp + 24];
---      R3 = _c1C::P64;
---      R2 = _c1B::P64;
---      R1 = _c1A::P64;
---      Sp = Sp + 32;
---      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
---
--- If we don't run sinking pass after stack layout we are basically
--- left with such code. However, running sinking on this code can lead
--- to significant improvements:
---
---  c1E:
---      I64[Sp - 32] = c1D;
---      P64[Sp - 24] = R1;
---      P64[Sp - 16] = R2;
---      P64[Sp - 8] = R3;
---      Sp = Sp - 32;
---      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
---  c1D:
---      R3 = P64[Sp + 24];
---      R2 = P64[Sp + 16];
---      R1 = P64[Sp + 8];
---      Sp = Sp + 32;
---      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
---
--- Now we only have 9 assignments instead of 15.
---
--- There is one case when running sinking before stack layout could
--- be beneficial. Consider this:
---
---   L1:
---      x = y
---      call f() returns L2
---   L2: ...x...y...
---
--- Since both x and y are live across a call to f, they will be stored
--- on the stack during stack layout and restored after the call:
---
---   L1:
---      x = y
---      P64[Sp - 24] = L2
---      P64[Sp - 16] = x
---      P64[Sp - 8]  = y
---      Sp = Sp - 24
---      call f() returns L2
---   L2:
---      y = P64[Sp + 16]
---      x = P64[Sp + 8]
---      Sp = Sp + 24
---      ...x...y...
---
--- However, if we run sinking before stack layout we would propagate x
--- to its usage place (both x and y must be local register for this to
--- be possible - global registers cannot be floated past a call):
---
---   L1:
---      x = y
---      call f() returns L2
---   L2: ...y...y...
---
--- Thus making x dead at the call to f(). If we ran stack layout now
--- we would generate less stores and loads:
---
---   L1:
---      x = y
---      P64[Sp - 16] = L2
---      P64[Sp - 8]  = y
---      Sp = Sp - 16
---      call f() returns L2
---   L2:
---      y = P64[Sp + 8]
---      Sp = Sp + 16
---      ...y...y...
---
--- But since we don't see any benefits from running sinking before stack
--- layout, this situation probably doesn't arise too often in practice.
---
-
-{- Note [inconsistent-pic-reg]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-On x86/Darwin, PIC is implemented by inserting a sequence like
-
-    call 1f
- 1: popl %reg
-
-at the proc entry point, and then referring to labels as offsets from
-%reg.  If we don't split proc points, then we could have many entry
-points in a proc that would need this sequence, and each entry point
-would then get a different value for %reg.  If there are any join
-points, then at the join point we don't have a consistent value for
-%reg, so we don't know how to refer to labels.
-
-Hence, on x86/Darwin, we have to split proc points, and then each proc
-point will get its own PIC initialisation sequence.
-
-This isn't an issue on x86/ELF, where the sequence is
-
-    call 1f
- 1: popl %reg
-    addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg
-
-so %reg always has a consistent value: the address of
-_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.
-
--}
-
-{- Note [unreachable blocks]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~
-The control-flow optimiser sometimes leaves unreachable blocks behind
-containing junk code.  These aren't necessarily a problem, but
-removing them is good because it might save time in the native code
-generator later.
-
--}
-
-runUniqSM :: UniqSM a -> IO a
-runUniqSM m = do
-  us <- mkSplitUniqSupply 'u'
-  return (initUs_ us m)
-
-
-dumpGraph :: Logger -> Platform -> Bool -> DumpFlag -> String -> CmmGraph -> IO ()
-dumpGraph logger platform do_linting flag name g = do
-  when do_linting $ do_lint g
-  dumpWith logger flag name FormatCMM (pdoc platform g)
- where
-  do_lint g = case cmmLintGraph platform g of
-                 Just err -> do { fatalErrorMsg logger err
-                                ; ghcExit logger 1
-                                }
-                 Nothing  -> return ()
-
-dumpWith :: Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
-dumpWith logger flag txt fmt sdoc = do
-  putDumpFileMaybe logger flag txt fmt sdoc
-  when (not (logHasDumpFlag logger flag)) $
-    -- If `-ddump-cmm-verbose -ddump-to-file` is specified,
-    -- dump each Cmm pipeline stage output to a separate file.  #16930
-    when (logHasDumpFlag logger Opt_D_dump_cmm_verbose)
-      $ logDumpFile logger (mkDumpStyle alwaysQualify) flag txt fmt sdoc
-  putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc
diff --git a/compiler/GHC/Cmm/ProcPoint.hs b/compiler/GHC/Cmm/ProcPoint.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/ProcPoint.hs
+++ /dev/null
@@ -1,494 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DisambiguateRecordFields #-}
-{-# LANGUAGE GADTs #-}
-
-module GHC.Cmm.ProcPoint
-    ( ProcPointSet, Status(..)
-    , callProcPoints, minimalProcPointSet
-    , splitAtProcPoints, procPointAnalysis
-    , attachContInfoTables
-    )
-where
-
-import GHC.Prelude hiding (last, unzip, succ, zip)
-
-import GHC.Cmm.BlockId
-import GHC.Cmm.CLabel
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Cmm.Info
-import GHC.Cmm.Liveness
-import GHC.Cmm.Switch
-import Data.List (sortBy)
-import GHC.Data.Maybe
-import Control.Monad
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Platform
-import GHC.Types.Unique.Supply
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
-
--- Compute a minimal set of proc points for a control-flow graph.
-
--- Determine a protocol for each proc point (which live variables will
--- be passed as arguments and which will be on the stack).
-
-{-
-A proc point is a basic block that, after CPS transformation, will
-start a new function.  The entry block of the original function is a
-proc point, as is the continuation of each function call.
-A third kind of proc point arises if we want to avoid copying code.
-Suppose we have code like the following:
-
-  f() {
-    if (...) { ..1..; call foo(); ..2..}
-    else     { ..3..; call bar(); ..4..}
-    x = y + z;
-    return x;
-  }
-
-The statement 'x = y + z' can be reached from two different proc
-points: the continuations of foo() and bar().  We would prefer not to
-put a copy in each continuation; instead we would like 'x = y + z' to
-be the start of a new procedure to which the continuations can jump:
-
-  f_cps () {
-    if (...) { ..1..; push k_foo; jump foo_cps(); }
-    else     { ..3..; push k_bar; jump bar_cps(); }
-  }
-  k_foo() { ..2..; jump k_join(y, z); }
-  k_bar() { ..4..; jump k_join(y, z); }
-  k_join(y, z) { x = y + z; return x; }
-
-You might think then that a criterion to make a node a proc point is
-that it is directly reached by two distinct proc points.  (Note
-[Direct reachability].)  But this criterion is a bit too simple; for
-example, 'return x' is also reached by two proc points, yet there is
-no point in pulling it out of k_join.  A good criterion would be to
-say that a node should be made a proc point if it is reached by a set
-of proc points that is different than its immediate dominator.  NR
-believes this criterion can be shown to produce a minimum set of proc
-points, and given a dominator tree, the proc points can be chosen in
-time linear in the number of blocks.  Lacking a dominator analysis,
-however, we turn instead to an iterative solution, starting with no
-proc points and adding them according to these rules:
-
-  1. The entry block is a proc point.
-  2. The continuation of a call is a proc point.
-  3. A node is a proc point if it is directly reached by more proc
-     points than one of its predecessors.
-
-Because we don't understand the problem very well, we apply rule 3 at
-most once per iteration, then recompute the reachability information.
-(See Note [No simple dataflow].)  The choice of the new proc point is
-arbitrary, and I don't know if the choice affects the final solution,
-so I don't know if the number of proc points chosen is the
-minimum---but the set will be minimal.
-
-
-
-Note [Proc-point analysis]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Given a specified set of proc-points (a set of block-ids), "proc-point
-analysis" figures out, for every block, which proc-point it belongs to.
-All the blocks belonging to proc-point P will constitute a single
-top-level C procedure.
-
-A non-proc-point block B "belongs to" a proc-point P iff B is
-reachable from P without going through another proc-point.
-
-Invariant: a block B should belong to at most one proc-point; if it
-belongs to two, that's a bug.
-
-Note [Non-existing proc-points]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-On some architectures it might happen that the list of proc-points
-computed before stack layout pass will be invalidated by the stack
-layout. This will happen if stack layout removes from the graph
-blocks that were determined to be proc-points. Later on in the pipeline
-we use list of proc-points to perform [Proc-point analysis], but
-if a proc-point does not exist anymore then we will get compiler panic.
-See #8205.
--}
-
-type ProcPointSet = LabelSet
-
-data Status
-  = ReachedBy ProcPointSet  -- set of proc points that directly reach the block
-  | ProcPoint               -- this block is itself a proc point
-
-instance Outputable Status where
-  ppr (ReachedBy ps)
-      | setNull ps = text "<not-reached>"
-      | otherwise = text "reached by" <+>
-                    (hsep $ punctuate comma $ map ppr $ setElems ps)
-  ppr ProcPoint = text "<procpt>"
-
---------------------------------------------------
--- Proc point analysis
-
--- Once you know what the proc-points are, figure out
--- what proc-points each block is reachable from
--- See Note [Proc-point analysis]
-procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status
-procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =
-    analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints
-  where
-    initProcPoints =
-        mkFactBase
-            procPointLattice
-            [ (id, ProcPoint)
-            | id <- setElems procPoints
-            -- See Note [Non-existing proc-points]
-            , id `setMember` labelsInGraph
-            ]
-    labelsInGraph = labelsDefined graph
-
-procPointTransfer :: TransferFun Status
-procPointTransfer block facts =
-    let label = entryLabel block
-        !fact = case getFact procPointLattice label facts of
-            ProcPoint -> ReachedBy $! setSingleton label
-            f -> f
-        result = map (\id -> (id, fact)) (successors block)
-    in mkFactBase procPointLattice result
-
-procPointLattice :: DataflowLattice Status
-procPointLattice = DataflowLattice unreached add_to
-  where
-    unreached = ReachedBy setEmpty
-    add_to (OldFact ProcPoint) _ = NotChanged ProcPoint
-    add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case
-    add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
-        | setSize union > setSize p = Changed (ReachedBy union)
-        | otherwise = NotChanged (ReachedBy p)
-      where
-        union = setUnion p' p
-
-----------------------------------------------------------------------
-
--- It is worth distinguishing two sets of proc points: those that are
--- induced by calls in the original graph and those that are
--- introduced because they're reachable from multiple proc points.
---
--- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
-callProcPoints      :: CmmGraph -> ProcPointSet
-callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g
-  where add :: LabelSet -> CmmBlock -> LabelSet
-        add set b = case lastNode b of
-                      CmmCall {cml_cont = Just k} -> setInsert k set
-                      CmmForeignCall {succ=k}     -> setInsert k set
-                      _ -> set
-
-minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
-                    -> UniqSM ProcPointSet
--- Given the set of successors of calls (which must be proc-points)
--- figure out the minimal set of necessary proc-points
-minimalProcPointSet platform callProcPoints g
-  = extendPPSet platform g (revPostorder g) callProcPoints
-
-extendPPSet
-    :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
-extendPPSet platform g blocks procPoints =
-    let env = procPointAnalysis procPoints g
-        add pps block = let id = entryLabel block
-                        in  case mapLookup id env of
-                              Just ProcPoint -> setInsert id pps
-                              _ -> pps
-        procPoints' = foldlGraphBlocks add setEmpty g
-        newPoints = mapMaybe ppSuccessor blocks
-        newPoint  = listToMaybe newPoints
-        ppSuccessor b =
-            let nreached id = case mapLookup id env `orElse`
-                                    pprPanic "no ppt" (ppr id <+> pdoc platform b) of
-                                ProcPoint -> 1
-                                ReachedBy ps -> setSize ps
-                block_procpoints = nreached (entryLabel b)
-                -- Looking for a successor of b that is reached by
-                -- more proc points than b and is not already a proc
-                -- point.  If found, it can become a proc point.
-                newId succ_id = not (setMember succ_id procPoints') &&
-                                nreached succ_id > block_procpoints
-            in  listToMaybe $ filter newId $ successors b
-
-    in case newPoint of
-         Just id ->
-             if setMember id procPoints'
-                then panic "added old proc pt"
-                else extendPPSet platform g blocks (setInsert id procPoints')
-         Nothing -> return procPoints'
-
-
--- At this point, we have found a set of procpoints, each of which should be
--- the entry point of a procedure.
--- Now, we create the procedure for each proc point,
--- which requires that we:
--- 1. build a map from proc points to the blocks reachable from the proc point
--- 2. turn each branch to a proc point into a jump
--- 3. turn calls and returns into jumps
--- 4. build info tables for the procedures -- and update the info table for
---    the SRTs in the entry procedure as well.
--- Input invariant: A block should only be reachable from a single ProcPoint.
--- ToDo: use the _ret naming convention that the old code generator
--- used. -- EZY
-splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> CmmDecl
-                  -> UniqSM [CmmDecl]
-splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
-splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do
-  -- Build a map from procpoints to the blocks they reach
-  let (CmmProc (TopInfo {info_tbls = info_tbls}) top_l _ g@(CmmGraph {g_entry=entry})) = cmmProc
-
-  let add graphEnv procId bid b = mapInsert procId graph' graphEnv
-        where
-          graph' = mapInsert bid b graph
-          graph  = mapLookup procId graphEnv `orElse` mapEmpty
-
-  let add_block :: LabelMap (LabelMap CmmBlock) -> CmmBlock -> LabelMap (LabelMap CmmBlock)
-      add_block graphEnv b =
-        case mapLookup bid procMap of
-          Just ProcPoint -> add graphEnv bid bid b
-          Just (ReachedBy set) ->
-            case setElems set of
-              []   -> graphEnv
-              [id] -> add graphEnv id bid b
-              _    -> panic "Each block should be reachable from only one ProcPoint"
-          Nothing -> graphEnv
-        where
-          bid = entryLabel b
-
-
-  let liveness = cmmGlobalLiveness platform g
-  let ppLiveness pp = filter isArgReg $ regSetToList $
-                        expectJust "ppLiveness" $ mapLookup pp liveness
-  graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g
-
-  -- Build a map from proc point BlockId to pairs of:
-  --  * Labels for their new procedures
-  --  * Labels for the info tables of their new procedures (only if
-  --    the proc point is a callPP)
-  -- Due to common blockification, we may overestimate the set of procpoints.
-  let add_label map pp = mapInsert pp lbls map
-        where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))
-                   | otherwise   = (block_lbl, guard (setMember pp callPPs) >>
-                                                 Just info_table_lbl)
-                   where block_lbl      = blockLbl pp
-                         info_table_lbl = infoTblLbl pp
-
-      procLabels :: LabelMap (CLabel, Maybe CLabel)
-      procLabels = foldl' add_label mapEmpty
-                          (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
-
-  -- In each new graph, add blocks jumping off to the new procedures,
-  -- and replace branches to procpoints with branches to the jump-off blocks
-  let add_jump_block :: (LabelMap Label, [CmmBlock])
-                     -> (Label, CLabel)
-                     -> UniqSM (LabelMap Label, [CmmBlock])
-      add_jump_block (env, bs) (pp, l) = do
-        bid <- liftM mkBlockId getUniqueM
-        let b    = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump
-            live = ppLiveness pp
-            jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
-        return (mapInsert pp bid env, b : bs)
-
-  -- when jumping to a PP that has an info table, if
-  -- tablesNextToCode is off we must jump to the entry
-  -- label instead.
-  let tablesNextToCode = platformTablesNextToCode platform
-
-  let jump_label (Just info_lbl) _
-                 | tablesNextToCode = info_lbl
-                 | otherwise        = toEntryLbl platform info_lbl
-      jump_label Nothing  block_lbl = block_lbl
-
-  let add_if_pp id rst =
-        case mapLookup id procLabels of
-          Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
-          Nothing                 -> rst
-
-  let add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
-      add_if_branch_to_pp block rst =
-        case lastNode block of
-          CmmBranch id            -> add_if_pp id rst
-          CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)
-          CmmSwitch _ ids         -> foldr add_if_pp rst $ switchTargetsToList ids
-          _                       -> rst
-
-  let add_jumps :: LabelMap CmmGraph -> (Label, LabelMap CmmBlock) -> UniqSM (LabelMap CmmGraph)
-      add_jumps newGraphEnv (ppId, blockEnv) = do
-        -- find which procpoints we currently branch to
-        let needed_jumps = mapFoldr add_if_branch_to_pp [] blockEnv
-
-        (jumpEnv, jumpBlocks) <-
-           foldM add_jump_block (mapEmpty, []) needed_jumps
-            -- update the entry block
-        let b = expectJust "block in env" $ mapLookup ppId blockEnv
-            blockEnv' = mapInsert ppId b blockEnv
-            -- replace branches to procpoints with branches to jumps
-            blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
-            -- add the jump blocks to the graph
-            blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks
-        let g' = ofBlockMap ppId blockEnv'''
-        -- pprTrace "g' pre jumps" (ppr g') $ do
-        return (mapInsert ppId g' newGraphEnv)
-
-  graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv
-
-  let to_proc (bid, g)
-          | bid == entry
-          =  CmmProc (TopInfo {info_tbls  = info_tbls,
-                               stack_info = stack_info})
-                     top_l live g'
-          | otherwise
-          = case expectJust "pp label" $ mapLookup bid procLabels of
-              (lbl, Just info_lbl)
-                 -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)
-                                     , stack_info=stack_info})
-                            lbl live g'
-              (lbl, Nothing)
-                 -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
-                            lbl live g'
-             where
-              g' = replacePPIds g
-              live = ppLiveness (g_entry g')
-              stack_info = StackInfo { arg_space = 0
-                                     , do_layout = True }
-                            -- cannot use panic, this is printed by -ddump-cmm
-
-      -- References to procpoint IDs can now be replaced with the
-      -- infotable's label
-      replacePPIds g = {-# SCC "replacePPIds" #-}
-                       mapGraphNodes (id, mapExp repl, mapExp repl) g
-        where repl e@(CmmLit (CmmBlock bid)) =
-                case mapLookup bid procLabels of
-                  Just (_, Just info_lbl)  -> CmmLit (CmmLabel info_lbl)
-                  _ -> e
-              repl e = e
-
-  -- The C back end expects to see return continuations before the
-  -- call sites.  Here, we sort them in reverse order -- it gets
-  -- reversed later.
-  let add_block_num (i, map) block =
-        (i + 1, mapInsert (entryLabel block) i map)
-  let (_, block_order) =
-          foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)
-                (revPostorder g)
-  let sort_fn (bid, _) (bid', _) =
-        compare (expectJust "block_order" $ mapLookup bid  block_order)
-                (expectJust "block_order" $ mapLookup bid' block_order)
-
-  return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
-
--- Only called from GHC.Cmm.ProcPoint.splitAtProcPoints. NB. does a
--- recursive lookup, see comment below.
-replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph
-replaceBranches env cmmg
-  = {-# SCC "replaceBranches" #-}
-    ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg
-  where
-    f block = replaceLastNode block $ last (lastNode block)
-
-    last :: CmmNode O C -> CmmNode O C
-    last (CmmBranch id)          = CmmBranch (lookup id)
-    last (CmmCondBranch e ti fi l) = CmmCondBranch e (lookup ti) (lookup fi) l
-    last (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets lookup ids)
-    last l@(CmmCall {})          = l { cml_cont = Nothing }
-            -- NB. remove the continuation of a CmmCall, since this
-            -- label will now be in a different CmmProc.  Not only
-            -- is this tidier, it stops CmmLint from complaining.
-    last l@(CmmForeignCall {})   = l
-    lookup id = fmap lookup (mapLookup id env) `orElse` id
-            -- XXX: this is a recursive lookup, it follows chains
-            -- until the lookup returns Nothing, at which point we
-            -- return the last BlockId
-
--- --------------------------------------------------------------
--- Not splitting proc points: add info tables for continuations
-
-attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
-attachContInfoTables call_proc_points (CmmProc top_info top_l live g)
- = CmmProc top_info{info_tbls = info_tbls'} top_l live g
- where
-   info_tbls' = mapUnion (info_tbls top_info) $
-                mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))
-                            | l <- setElems call_proc_points
-                            , l /= g_entry g ]
-attachContInfoTables _ other_decl
- = other_decl
-
-----------------------------------------------------------------
-
-{-
-Note [Direct reachability]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Block B is directly reachable from proc point P iff control can flow
-from P to B without passing through an intervening proc point.
--}
-
-----------------------------------------------------------------
-
-{-
-Note [No simple dataflow]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Sadly, it seems impossible to compute the proc points using a single
-dataflow pass.  One might attempt to use this simple lattice:
-
-  data Location = Unknown
-                | InProc BlockId -- node is in procedure headed by the named proc point
-                | ProcPoint      -- node is itself a proc point
-
-At a join, a node in two different blocks becomes a proc point.
-The difficulty is that the change of information during iterative
-computation may promote a node prematurely.  Here's a program that
-illustrates the difficulty:
-
-  f () {
-  entry:
-    ....
-  L1:
-    if (...) { ... }
-    else { ... }
-
-  L2: if (...) { g(); goto L1; }
-      return x + y;
-  }
-
-The only proc-point needed (besides the entry) is L1.  But in an
-iterative analysis, consider what happens to L2.  On the first pass
-through, it rises from Unknown to 'InProc entry', but when L1 is
-promoted to a proc point (because it's the successor of g()), L1's
-successors will be promoted to 'InProc L1'.  The problem hits when the
-new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.
-The join operation makes it a proc point when in fact it needn't be,
-because its immediate dominator L1 is already a proc point and there
-are no other proc points that directly reach L2.
--}
-
-
-
-{- Note [Separate Adams optimization]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It may be worthwhile to attempt the Adams optimization by rewriting
-the graph before the assignment of proc-point protocols.  Here are a
-couple of rules:
-
-  g() returns to k;                    g() returns to L;
-  k: CopyIn c ress; goto L:
-   ...                        ==>        ...
-  L: // no CopyIn node here            L: CopyIn c ress;
-
-
-And when c == c' and ress == ress', this also:
-
-  g() returns to k;                    g() returns to L;
-  k: CopyIn c ress; goto L:
-   ...                        ==>        ...
-  L: CopyIn c' ress'                   L: CopyIn c' ress' ;
-
-In both cases the goal is to eliminate k.
--}
diff --git a/compiler/GHC/Cmm/Reducibility.hs b/compiler/GHC/Cmm/Reducibility.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Reducibility.hs
+++ /dev/null
@@ -1,224 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-
-{-|
-Module      : GHC.Cmm.Reducibility
-Description : Tell if a `CmmGraph` is reducible, or make it so
-
-Test a Cmm control-flow graph for reducibility.  And provide a
-function that, when given an arbitrary control-flow graph, returns an
-equivalent, reducible control-flow graph.  The equivalent graph is
-obtained by "splitting" (copying) nodes of the original graph.
-The resulting equivalent graph has the same dynamic behavior as the
-original, but it is larger.
-
-Documentation uses the language of control-flow analysis, in which a
-basic block is called a "node."  These "nodes" are `CmmBlock`s or
-equivalent; they have nothing to do with a `CmmNode`.
-
-For more on reducibility and related analyses and algorithms, see
-Note [Reducibility resources]
--}
-
-module GHC.Cmm.Reducibility
-  ( Reducibility(..)
-  , reducibility
-
-  , asReducible
-  )
-where
-
-import GHC.Prelude hiding (splitAt, succ)
-
-import Control.Monad
-import Data.List (nub)
-import Data.Maybe
-import Data.Semigroup
-import qualified Data.Sequence as Seq
-
-import GHC.Cmm
-import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dominators
-import GHC.Cmm.Dataflow.Graph hiding (addBlock)
-import GHC.Cmm.Dataflow.Label
-import GHC.Data.Graph.Collapse
-import GHC.Data.Graph.Inductive.Graph
-import GHC.Data.Graph.Inductive.PatriciaTree
-import GHC.Types.Unique.Supply
-import GHC.Utils.Panic
-
--- | Represents the result of a reducibility analysis.
-data Reducibility = Reducible | Irreducible
-  deriving (Eq, Show)
-
--- | Given a graph, say whether the graph is reducible.  The graph must
--- be bundled with a dominator analysis and a reverse postorder
--- numbering, as these results are needed to perform the test.
-
-reducibility :: NonLocal node
-             => GraphWithDominators node
-             -> Reducibility
-reducibility gwd =
-    if all goodBlock blockmap then Reducible else Irreducible
-  where goodBlock b = all (goodEdge (entryLabel b)) (successors b)
-        goodEdge from to = rpnum to > rpnum from || to `dominates` from
-        rpnum = gwdRPNumber gwd
-        blockmap = graphMap $ gwd_graph gwd
-        dominators = gwdDominatorsOf gwd
-        dominates lbl blockname =
-            lbl == blockname || dominatorsMember lbl (dominators blockname)
-
--- | Given a graph, return an equivalent reducible graph, by
--- "splitting" (copying) nodes if necessary.  The input
--- graph must be bundled with a dominator analysis and a reverse
--- postorder numbering.  The computation is monadic because when a
--- node is split, the new copy needs a fresh label.
---
--- Use this function whenever a downstream algorithm needs a reducible
--- control-flow graph.
-
-asReducible :: GraphWithDominators CmmNode
-            -> UniqSM (GraphWithDominators CmmNode)
-asReducible gwd = case reducibility gwd of
-                    Reducible -> return gwd
-                    Irreducible -> assertReducible <$> nodeSplit gwd
-
-assertReducible :: GraphWithDominators CmmNode -> GraphWithDominators CmmNode
-assertReducible gwd = case reducibility gwd of
-                        Reducible -> gwd
-                        Irreducible -> panic "result not reducible"
-
-----------------------------------------------------------------
-
--- | Split one or more nodes of the given graph, which must be
--- irreducible.
-
-nodeSplit :: GraphWithDominators CmmNode
-          -> UniqSM (GraphWithDominators CmmNode)
-nodeSplit gwd =
-    graphWithDominators <$> inflate (g_entry g) <$> runNullCollapse collapsed
-  where g = gwd_graph gwd
-        collapsed :: NullCollapseViz (Gr CmmSuper ())
-        collapsed = collapseInductiveGraph (cgraphOfCmm g)
-
-type CGraph = Gr CmmSuper ()
-
--- | Turn a collapsed supernode back into a control-flow graph
-inflate :: Label -> CGraph -> CmmGraph
-inflate entry cg = CmmGraph entry graph
-  where graph = GMany NothingO body NothingO
-        body :: LabelMap CmmBlock
-        body = foldl (\map block -> mapInsert (entryLabel block) block map) mapEmpty $
-               blocks super
-        super = case labNodes cg of
-                  [(_, s)] -> s
-                  _ -> panic "graph given to `inflate` is not singleton"
-
-
--- | Convert a `CmmGraph` into an inductive graph.
--- (The function coalesces duplicate edges into a single edge.)
-cgraphOfCmm :: CmmGraph -> CGraph
-cgraphOfCmm g = foldl' addSuccEdges (mkGraph cnodes []) blocks
-   where blocks = zip [0..] $ revPostorderFrom (graphMap g) (g_entry g)
-         cnodes = [(k, super block) | (k, block) <- blocks]
-          where super block = Nodes (entryLabel block) (Seq.singleton block)
-         labelNumber = \lbl -> fromJust $ mapLookup lbl numbers
-             where numbers :: LabelMap Int
-                   numbers = mapFromList $ map swap blocks
-                   swap (k, block) = (entryLabel block, k)
-         addSuccEdges :: CGraph -> (Node, CmmBlock) -> CGraph
-         addSuccEdges graph (k, block) =
-             insEdges [(k, labelNumber lbl, ()) | lbl <- nub $ successors block] graph
-{-
-Note [Reducibility resources]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-*Flow Analysis of Computer Programs.* Matthew S. Hecht North Holland, 1977.
-Available to borrow from archive.org.
-
-Matthew S. Hecht and Jeffrey D. Ullman (1972).
-Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202.
-https://doi.org/10.1137/0201014
-
-Johan Janssen and Henk Corporaal. 1997. Making graphs reducible with
-controlled node splitting. ACM TOPLAS 19, 6 (Nov. 1997),
-1031–1052. DOI:https://doi.org/10.1145/267959.269971
-
-Sebastian Unger and Frank Mueller. 2002. Handling irreducible loops:
-optimized node splitting versus DJ-graphs. ACM TOPLAS 24, 4 (July
-2002), 299–333. https://doi.org/10.1145/567097.567098.  (This one
-contains the most detailed account of how the Hecht/Ullman algorithm
-is used to modify an actual control-flow graph.  But still not much detail.)
-
-https://rgrig.blogspot.com/2009/10/dtfloatleftclearleft-summary-of-some.html
- (Nice summary of useful facts)
-
--}
-
-
-
-type Seq = Seq.Seq
-
--- | A "supernode" contains a single-entry, multiple-exit, reducible subgraph.
--- The entry point is the given label, and the block with that label
--- dominates all the other blocks in the supernode.  When an entire
--- graph is collapsed into a single supernode, the graph is reducible.
--- More detail can be found in "GHC.Data.Graph.Collapse".
-
-data CmmSuper
-    = Nodes { label :: Label
-            , blocks :: Seq CmmBlock
-            }
-
-instance Semigroup CmmSuper where
-  s <> s' = Nodes (label s) (blocks s <> blocks s')
-
-instance PureSupernode CmmSuper where
-  superLabel = label
-  mapLabels = changeLabels
-
-instance Supernode CmmSuper NullCollapseViz where
-  freshen s = liftUniqSM $ relabel s
-
-
--- | Return all labels defined within a supernode.
-definedLabels :: CmmSuper -> Seq Label
-definedLabels = fmap entryLabel . blocks
-
-
-
--- | Map the given function over every use and definition of a label
--- in the given supernode.
-changeLabels :: (Label -> Label) -> (CmmSuper -> CmmSuper)
-changeLabels f (Nodes l blocks) = Nodes (f l) (fmap (changeBlockLabels f) blocks)
-
--- | Map the given function over every use and definition of a label
--- in the given block.
-changeBlockLabels :: (Label -> Label) -> CmmBlock -> CmmBlock
-changeBlockLabels f block = blockJoin entry' middle exit'
-  where (entry, middle, exit) = blockSplit block
-        entry' = let CmmEntry l scope = entry
-                 in  CmmEntry (f l) scope
-        exit' = case exit of
-                  -- unclear why mapSuccessors doesn't touch these
-                  CmmCall { cml_cont = Just l } -> exit { cml_cont = Just (f l) }
-                  CmmForeignCall { succ = l } -> exit { succ = f l }
-                  _ -> mapSuccessors f exit
-
-
--- | Within the given supernode, replace every defined label (and all
--- of its uses) with a fresh label.
-
-relabel :: CmmSuper -> UniqSM CmmSuper
-relabel node = do
-     finite_map <- foldM addPair mapEmpty $ definedLabels node
-     return $ changeLabels (labelChanger finite_map) node
-  where addPair :: LabelMap Label -> Label -> UniqSM (LabelMap Label)
-        addPair map old = do new <- newBlockId
-                             return $ mapInsert old new map
-        labelChanger :: LabelMap Label -> (Label -> Label)
-        labelChanger mapping = \lbl -> mapFindWithDefault lbl lbl mapping
diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Sink.hs
+++ /dev/null
@@ -1,954 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module GHC.Cmm.Sink (
-     cmmSink
-  ) where
-
-import GHC.Prelude
-
-import GHC.Cmm
-import GHC.Cmm.Opt
-import GHC.Cmm.Liveness
-import GHC.Cmm.LRegSet
-import GHC.Cmm.Utils
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Graph
-import GHC.Platform.Regs
-
-import GHC.Platform
-import GHC.Types.Unique.FM
-
-import qualified Data.IntSet as IntSet
-import Data.List (partition)
-import Data.Maybe
-
-import GHC.Exts (inline)
-
--- -----------------------------------------------------------------------------
--- Sinking and inlining
-
--- This is an optimisation pass that
---  (a) moves assignments closer to their uses, to reduce register pressure
---  (b) pushes assignments into a single branch of a conditional if possible
---  (c) inlines assignments to registers that are mentioned only once
---  (d) discards dead assignments
---
--- This tightens up lots of register-heavy code.  It is particularly
--- helpful in the Cmm generated by the Stg->Cmm code generator, in
--- which every function starts with a copyIn sequence like:
---
---    x1 = R1
---    x2 = Sp[8]
---    x3 = Sp[16]
---    if (Sp - 32 < SpLim) then L1 else L2
---
--- we really want to push the x1..x3 assignments into the L2 branch.
---
--- Algorithm:
---
---  * Start by doing liveness analysis.
---
---  * Keep a list of assignments A; earlier ones may refer to later ones.
---    Currently we only sink assignments to local registers, because we don't
---    have liveness information about global registers.
---
---  * Walk forwards through the graph, look at each node N:
---
---    * If it is a dead assignment, i.e. assignment to a register that is
---      not used after N, discard it.
---
---    * Try to inline based on current list of assignments
---      * If any assignments in A (1) occur only once in N, and (2) are
---        not live after N, inline the assignment and remove it
---        from A.
---
---      * If an assignment in A is cheap (RHS is local register), then
---        inline the assignment and keep it in A in case it is used afterwards.
---
---      * Otherwise don't inline.
---
---    * If N is assignment to a local register pick up the assignment
---      and add it to A.
---
---    * If N is not an assignment to a local register:
---      * remove any assignments from A that conflict with N, and
---        place them before N in the current block.  We call this
---        "dropping" the assignments.
---
---      * An assignment conflicts with N if it:
---        - assigns to a register mentioned in N
---        - mentions a register assigned by N
---        - reads from memory written by N
---      * do this recursively, dropping dependent assignments
---
---    * At an exit node:
---      * drop any assignments that are live on more than one successor
---        and are not trivial
---      * if any successor has more than one predecessor (a join-point),
---        drop everything live in that successor. Since we only propagate
---        assignments that are not dead at the successor, we will therefore
---        eliminate all assignments dead at this point. Thus analysis of a
---        join-point will always begin with an empty list of assignments.
---
---
--- As a result of above algorithm, sinking deletes some dead assignments
--- (transitively, even).  This isn't as good as removeDeadAssignments,
--- but it's much cheaper.
-
--- -----------------------------------------------------------------------------
--- things that we aren't optimising very well yet.
---
--- -----------
--- (1) From GHC's FastString.hashStr:
---
---  s2ay:
---      if ((_s2an::I64 == _s2ao::I64) >= 1) goto c2gn; else goto c2gp;
---  c2gn:
---      R1 = _s2au::I64;
---      call (I64[Sp])(R1) args: 8, res: 0, upd: 8;
---  c2gp:
---      _s2cO::I64 = %MO_S_Rem_W64(%MO_UU_Conv_W8_W64(I8[_s2aq::I64 + (_s2an::I64 << 0)]) + _s2au::I64 * 128,
---                                 4091);
---      _s2an::I64 = _s2an::I64 + 1;
---      _s2au::I64 = _s2cO::I64;
---      goto s2ay;
---
--- a nice loop, but we didn't eliminate the silly assignment at the end.
--- See Note [dependent assignments], which would probably fix this.
--- This is #8336.
---
--- -----------
--- (2) From stg_atomically_frame in PrimOps.cmm
---
--- We have a diamond control flow:
---
---     x = ...
---       |
---      / \
---     A   B
---      \ /
---       |
---    use of x
---
--- Now x won't be sunk down to its use, because we won't push it into
--- both branches of the conditional.  We certainly do have to check
--- that we can sink it past all the code in both A and B, but having
--- discovered that, we could sink it to its use.
---
-
--- -----------------------------------------------------------------------------
-
-type Assignment = (LocalReg, CmmExpr, AbsMem)
-  -- Assignment caches AbsMem, an abstraction of the memory read by
-  -- the RHS of the assignment.
-
-type Assignments = [Assignment]
-  -- A sequence of assignments; kept in *reverse* order
-  -- So the list [ x=e1, y=e2 ] means the sequence of assignments
-  --     y = e2
-  --     x = e1
-
-cmmSink :: Platform -> CmmGraph -> CmmGraph
-cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
-  where
-  liveness = cmmLocalLivenessL platform graph
-  getLive l = mapFindWithDefault emptyLRegSet l liveness
-
-  blocks = revPostorder graph
-
-  join_pts = findJoinPoints blocks
-
-  sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
-  sink _ [] = []
-  sink sunk (b:bs) =
-    -- pprTrace "sink" (ppr lbl) $
-    blockJoin first final_middle final_last : sink sunk' bs
-    where
-      lbl = entryLabel b
-      (first, middle, last) = blockSplit b
-
-      succs = successors last
-
-      -- Annotate the middle nodes with the registers live *after*
-      -- the node.  This will help us decide whether we can inline
-      -- an assignment in the current node or not.
-      live = IntSet.unions (map getLive succs)
-      live_middle = gen_killL platform last live
-      ann_middles = annotate platform live_middle (blockToList middle)
-
-      -- Now sink and inline in this block
-      (middle', assigs) = walk platform ann_middles (mapFindWithDefault [] lbl sunk)
-      fold_last = constantFoldNode platform last
-      (final_last, assigs') = tryToInline platform live fold_last assigs
-
-      -- We cannot sink into join points (successors with more than
-      -- one predecessor), so identify the join points and the set
-      -- of registers live in them.
-      (joins, nonjoins) = partition (`mapMember` join_pts) succs
-      live_in_joins = IntSet.unions (map getLive joins)
-
-      -- We do not want to sink an assignment into multiple branches,
-      -- so identify the set of registers live in multiple successors.
-      -- This is made more complicated because when we sink an assignment
-      -- into one branch, this might change the set of registers that are
-      -- now live in multiple branches.
-      init_live_sets = map getLive nonjoins
-      live_in_multi live_sets r =
-         case filter (elemLRegSet r) live_sets of
-           (_one:_two:_) -> True
-           _ -> False
-
-      -- Now, drop any assignments that we will not sink any further.
-      (dropped_last, assigs'') = dropAssignments platform drop_if init_live_sets assigs'
-
-      drop_if :: (LocalReg, CmmExpr, AbsMem)
-                      -> [LRegSet] -> (Bool, [LRegSet])
-      drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')
-          where
-            should_drop =  conflicts platform a final_last
-                        || not (isTrivial platform rhs) && live_in_multi live_sets r
-                        || r `elemLRegSet` live_in_joins
-
-            live_sets' | should_drop = live_sets
-                       | otherwise   = map upd live_sets
-
-            upd set | r `elemLRegSet` set = set `IntSet.union` live_rhs
-                    | otherwise          = set
-
-            live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs
-
-      final_middle = foldl' blockSnoc middle' dropped_last
-
-      sunk' = mapUnion sunk $
-                 mapFromList [ (l, filterAssignments platform (getLive l) assigs'')
-                             | l <- succs ]
-
-{- TODO: enable this later, when we have some good tests in place to
-   measure the effect and tune it.
-
--- small: an expression we don't mind duplicating
-isSmall :: CmmExpr -> Bool
-isSmall (CmmReg (CmmLocal _)) = True  --
-isSmall (CmmLit _) = True
-isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y
-isSmall (CmmRegOff (CmmLocal _) _) = True
-isSmall _ = False
--}
-
---
--- We allow duplication of trivial expressions: registers (both local and
--- global) and literals.
---
-isTrivial :: Platform -> CmmExpr -> Bool
-isTrivial _ (CmmReg (CmmLocal _)) = True
-isTrivial platform (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?]
-  if isARM (platformArch platform)
-  then True -- CodeGen.Platform.ARM does not have globalRegMaybe
-  else isJust (globalRegMaybe platform r)
-  -- GlobalRegs that are loads from BaseReg are not trivial
-isTrivial _ (CmmLit _) = True
-isTrivial _ _          = False
-
---
--- annotate each node with the set of registers live *after* the node
---
-annotate :: Platform -> LRegSet -> [CmmNode O O] -> [(LRegSet, CmmNode O O)]
-annotate platform live nodes = snd $ foldr ann (live,[]) nodes
-  where ann n (live,nodes) = (gen_killL platform n live, (live,n) : nodes)
-
---
--- Find the blocks that have multiple successors (join points)
---
-findJoinPoints :: [CmmBlock] -> LabelMap Int
-findJoinPoints blocks = mapFilter (>1) succ_counts
- where
-  all_succs = concatMap successors blocks
-
-  succ_counts :: LabelMap Int
-  succ_counts = foldl' (\acc l -> mapInsertWith (+) l 1 acc) mapEmpty all_succs
-
---
--- filter the list of assignments to remove any assignments that
--- are not live in a continuation.
---
-filterAssignments :: Platform -> LRegSet -> Assignments -> Assignments
-filterAssignments platform live assigs = reverse (go assigs [])
-  where go []             kept = kept
-        go (a@(r,_,_):as) kept | needed    = go as (a:kept)
-                               | otherwise = go as kept
-           where
-              needed = r `elemLRegSet` live
-                       || any (conflicts platform a) (map toNode kept)
-                       --  Note that we must keep assignments that are
-                       -- referred to by other assignments we have
-                       -- already kept.
-
--- -----------------------------------------------------------------------------
--- Walk through the nodes of a block, sinking and inlining assignments
--- as we go.
---
--- On input we pass in a:
---    * list of nodes in the block
---    * a list of assignments that appeared *before* this block and
---      that are being sunk.
---
--- On output we get:
---    * a new block
---    * a list of assignments that will be placed *after* that block.
---
-
-walk :: Platform
-     -> [(LRegSet, CmmNode O O)]    -- nodes of the block, annotated with
-                                        -- the set of registers live *after*
-                                        -- this node.
-
-     -> Assignments                     -- The current list of
-                                        -- assignments we are sinking.
-                                        -- Earlier assignments may refer
-                                        -- to later ones.
-
-     -> ( Block CmmNode O O             -- The new block
-        , Assignments                   -- Assignments to sink further
-        )
-
-walk platform nodes assigs = go nodes emptyBlock assigs
- where
-   go []               block as = (block, as)
-   go ((live,node):ns) block as
-    -- discard nodes representing dead assignment
-    | shouldDiscard node live             = go ns block as
-    -- sometimes only after simplification we can tell we can discard the node.
-    -- See Note [Discard simplified nodes]
-    | noOpAssignment node2                = go ns block as
-    -- Pick up interesting assignments
-    | Just a <- shouldSink platform node2 = go ns block (a : as1)
-    -- Try inlining, drop assignments and move on
-    | otherwise                           = go ns block' as'
-    where
-      -- Simplify node
-      node1 = constantFoldNode platform node
-
-      -- Inline assignments
-      (node2, as1) = tryToInline platform live node1 as
-
-      -- Drop any earlier assignments conflicting with node2
-      (dropped, as') = dropAssignmentsSimple platform
-                          (\a -> conflicts platform a node2) as1
-
-      -- Walk over the rest of the block. Includes dropped assignments
-      block' = foldl' blockSnoc block dropped `blockSnoc` node2
-
-{- Note [Discard simplified nodes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider a sequence like this:
-
-      _c1::P64 = R1;
-      _c3::I64 = I64[_c1::P64 + 1];
-      R1 = _c1::P64;
-      P64[Sp - 72] = _c1::P64;
-      I64[Sp - 64] = _c3::I64;
-
-If we discard assignments *before* simplifying nodes when we get to `R1 = _c1`.
-This is then simplified into `R1 = `R1` and as a consequence prevents sinking of
-loads from R1. What happens is that we:
-    * Check if we can discard the node `R1 = _c1 (no)
-    * Simplify the node to R1 = R1
-    * We check all remaining assignments for conflicts.
-    * The assignment `_c3 = [R1 + 1]`; (R1 already inlined on pickup)
-      conflicts with R1 = R1, because it reads `R1` and the node writes
-      to R1
-    * This is clearly nonsensical because `R1 = R1` doesn't affect R1's value.
-
-The solutions is to check if we can discard nodes before and *after* simplifying
-them. We could only do it after as well, but I assume doing it early might save
-some work.
-
-That is if we process a assignment node we now:
-    * Check if it can be discarded (because it's dead or a no-op)
-    * Simplify the rhs of the assignment.
-    * New: Check again if it might be a no-op now.
-    * ...
-
-This can help with problems like the one reported in #20334. For a full example see the test
-cmm_sink_sp.
-
--}
-
---
--- Heuristic to decide whether to pick up and sink an assignment
--- Currently we pick up all assignments to local registers.  It might
--- be profitable to sink assignments to global regs too, but the
--- liveness analysis doesn't track those (yet) so we can't.
---
-shouldSink :: Platform -> CmmNode e x -> Maybe Assignment
-shouldSink platform (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem platform e)
-  where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e
-shouldSink _ _other = Nothing
-
---
--- discard dead assignments.  This doesn't do as good a job as
--- removeDeadAssignments, because it would need multiple passes
--- to get all the dead code, but it catches the common case of
--- superfluous reloads from the stack that the stack allocator
--- leaves behind.
---
--- Also we catch "r = r" here.  You might think it would fall
--- out of inlining, but the inliner will see that r is live
--- after the instruction and choose not to inline r in the rhs.
---
-shouldDiscard :: CmmNode e x -> LRegSet -> Bool
-shouldDiscard node live
-   = case node of
-       -- r = r
-       CmmAssign r (CmmReg r') | r == r' -> True
-       -- r = e, r is dead after assignment
-       CmmAssign (CmmLocal r) _ -> not (r `elemLRegSet` live)
-       _otherwise -> False
-
-noOpAssignment :: CmmNode e x -> Bool
-noOpAssignment node
-   = case node of
-       -- r = r
-       CmmAssign r (CmmReg r') | r == r' -> True
-       _otherwise -> False
-
-
-toNode :: Assignment -> CmmNode O O
-toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs
-
-dropAssignmentsSimple :: Platform -> (Assignment -> Bool) -> Assignments
-                      -> ([CmmNode O O], Assignments)
-dropAssignmentsSimple platform f = dropAssignments platform (\a _ -> (f a, ())) ()
-
-dropAssignments :: Platform -> (Assignment -> s -> (Bool, s)) -> s -> Assignments
-                -> ([CmmNode O O], Assignments)
-dropAssignments platform should_drop state assigs
- = (dropped, reverse kept)
- where
-   (dropped,kept) = go state assigs [] []
-
-   go _ []             dropped kept = (dropped, kept)
-   go state (assig : rest) dropped kept
-      | conflict  =
-          let !node = toNode assig
-          in  go state' rest (node : dropped) kept
-      | otherwise = go state' rest dropped (assig:kept)
-      where
-        (dropit, state') = should_drop assig state
-        conflict = dropit || any (conflicts platform assig) dropped
-
-
--- -----------------------------------------------------------------------------
--- Try to inline assignments into a node.
--- This also does constant folding for primops, since
--- inlining opens up opportunities for doing so.
-
-tryToInline
-   :: forall x. Platform
-   -> LRegSet               -- set of registers live after this
-                                -- node.  We cannot inline anything
-                                -- that is live after the node, unless
-                                -- it is small enough to duplicate.
-   -> CmmNode O x               -- The node to inline into
-   -> Assignments               -- Assignments to inline
-   -> (
-        CmmNode O x             -- New node
-      , Assignments             -- Remaining assignments
-      )
-
-tryToInline platform liveAfter node assigs =
-  -- pprTrace "tryToInline assig length:" (ppr $ length assigs) $
-    go usages liveAfter node emptyLRegSet assigs
- where
-  usages :: UniqFM LocalReg Int -- Maps each LocalReg to a count of how often it is used
-  usages = foldLocalRegsUsed platform addUsage emptyUFM node
-
-  go :: UniqFM LocalReg Int -> LRegSet -> CmmNode O x -> LRegSet -> Assignments
-     -> (CmmNode O x, Assignments)
-  go _usages _live node _skipped [] = (node, [])
-
-  go usages live node skipped (a@(l,rhs,_) : rest)
-   | cannot_inline            = dont_inline
-   | occurs_none              = discard  -- See Note [discard during inlining]
-   | occurs_once              = inline_and_discard
-   | isTrivial platform rhs   = inline_and_keep
-   | otherwise                = dont_inline
-   where
-        inline_and_discard = go usages' live inl_node skipped rest
-          where usages' = foldLocalRegsUsed platform addUsage usages rhs
-
-        discard = go usages live node skipped rest
-
-        dont_inline        = keep node  -- don't inline the assignment, keep it
-        inline_and_keep    = keep inl_node -- inline the assignment, keep it
-
-        keep :: CmmNode O x -> (CmmNode O x, Assignments)
-        keep node' = (final_node, a : rest')
-          where (final_node, rest') = go usages live' node' (insertLRegSet l skipped) rest
-
-                -- Avoid discarding of assignments to vars on the rhs.
-                -- See Note [Keeping assignments mentioned in skipped RHSs]
-                -- usages' = foldLocalRegsUsed platform (\m r -> addToUFM m r 2)
-                                            -- usages rhs
-                live' = inline foldLocalRegsUsed platform (\m r -> insertLRegSet r m)
-                                            live rhs
-
-        cannot_inline = skipped `regsUsedIn` rhs -- See Note [dependent assignments]
-                        || l `elemLRegSet` skipped
-                        || not (okToInline platform rhs node)
-
-        -- How often is l used in the current node.
-        l_usages = lookupUFM usages l
-        l_live   = l `elemLRegSet` live
-
-        occurs_once = not l_live && l_usages == Just 1
-        occurs_none = not l_live && l_usages == Nothing
-
-        inl_node = improveConditional (mapExpDeep inl_exp node)
-
-        inl_exp :: CmmExpr -> CmmExpr
-        -- inl_exp is where the inlining actually takes place!
-        inl_exp (CmmReg    (CmmLocal l'))     | l == l' = rhs
-        inl_exp (CmmRegOff (CmmLocal l') off) | l == l'
-                    = cmmOffset platform rhs off
-                    -- re-constant fold after inlining
-        inl_exp (CmmMachOp op args) = cmmMachOpFold platform op args
-        inl_exp other = other
-
-{- Note [Keeping assignments mentioned in skipped RHSs]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-    If we have to assignments: [z = y, y = e1] and we skip
-    z we *must* retain the assignment y = e1. This is because
-    we might inline "z = y" into another node later on so we
-    must ensure y is still defined at this point.
-
-    If we dropped the assignment of "y = e1" then we would end up
-    referencing a variable which hasn't been mentioned after
-    inlining.
-
-    We use a hack to do this.
-
-    We pretend the regs from the rhs are live after the current
-    node. Since we only discard assignments to variables
-    which are dead after the current block this prevents discarding of the
-    assignment. It still allows inlining should e1 be a trivial rhs
-    however.
-
--}
-
-{- Note [improveConditional]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~
-cmmMachOpFold tries to simplify conditionals to turn things like
-  (a == b) != 1
-into
-  (a != b)
-but there's one case it can't handle: when the comparison is over
-floating-point values, we can't invert it, because floating-point
-comparisons aren't invertible (because of NaNs).
-
-But we *can* optimise this conditional by swapping the true and false
-branches. Given
-  CmmCondBranch ((a >## b) != 1) t f
-we can turn it into
-  CmmCondBranch (a >## b) f t
-
-So here we catch conditionals that weren't optimised by cmmMachOpFold,
-and apply above transformation to eliminate the comparison against 1.
-
-It's tempting to just turn every != into == and then let cmmMachOpFold
-do its thing, but that risks changing a nice fall-through conditional
-into one that requires two jumps. (see swapcond_last in
-GHC.Cmm.ContFlowOpt), so instead we carefully look for just the cases where
-we can eliminate a comparison.
--}
-improveConditional :: CmmNode O x -> CmmNode O x
-improveConditional
-  (CmmCondBranch (CmmMachOp mop [x, CmmLit (CmmInt 1 _)]) t f l)
-  | neLike mop, isComparisonExpr x
-  = CmmCondBranch x f t (fmap not l)
-  where
-    neLike (MO_Ne _) = True
-    neLike (MO_U_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1
-    neLike (MO_S_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1
-    neLike _ = False
-improveConditional other = other
-
--- Note [dependent assignments]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- If our assignment list looks like
---
---    [ y = e,  x = ... y ... ]
---
--- We cannot inline x.  Remember this list is really in reverse order,
--- so it means  x = ... y ...; y = e
---
--- Hence if we inline x, the outer assignment to y will capture the
--- reference in x's right hand side.
---
--- In this case we should rename the y in x's right-hand side,
--- i.e. change the list to [ y = e, x = ... y1 ..., y1 = y ]
--- Now we can go ahead and inline x.
---
--- For now we do nothing, because this would require putting
--- everything inside UniqSM.
---
--- One more variant of this (#7366):
---
---   [ y = e, y = z ]
---
--- If we don't want to inline y = e, because y is used many times, we
--- might still be tempted to inline y = z (because we always inline
--- trivial rhs's).  But of course we can't, because y is equal to e,
--- not z.
-
--- Note [discard during inlining]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Opportunities to discard assignments sometimes appear after we've
--- done some inlining.  Here's an example:
---
---      x = R1;
---      y = P64[x + 7];
---      z = P64[x + 15];
---      /* z is dead */
---      R1 = y & (-8);
---
--- The x assignment is trivial, so we inline it in the RHS of y, and
--- keep both x and y.  z gets dropped because it is dead, then we
--- inline y, and we have a dead assignment to x.  If we don't notice
--- that x is dead in tryToInline, we end up retaining it.
-
-addUsage :: UniqFM LocalReg Int -> LocalReg -> UniqFM LocalReg Int
-addUsage m r = addToUFM_C (+) m r 1
-
-regsUsedIn :: LRegSet -> CmmExpr -> Bool
-regsUsedIn ls _ | nullLRegSet ls = False
-regsUsedIn ls e = go ls e False
-  where use :: LRegSet -> CmmExpr -> Bool -> Bool
-        use ls (CmmReg (CmmLocal l))      _ | l `elemLRegSet` ls = True
-        use ls (CmmRegOff (CmmLocal l) _) _ | l `elemLRegSet` ls = True
-        use _ls _ z = z
-
-        go :: LRegSet -> CmmExpr -> Bool -> Bool
-        go ls (CmmMachOp _ es)   z = foldr (go ls) z es
-        go ls (CmmLoad addr _ _) z = go ls addr z
-        go ls e                  z = use ls e z
-
--- we don't inline into CmmUnsafeForeignCall if the expression refers
--- to global registers.  This is a HACK to avoid global registers
--- clashing with C argument-passing registers, really the back-end
--- ought to be able to handle it properly, but currently neither PprC
--- nor the NCG can do it.  See Note [Register parameter passing]
--- See also GHC.StgToCmm.Foreign.load_args_into_temps.
-okToInline :: Platform -> CmmExpr -> CmmNode e x -> Bool
-okToInline platform expr node@(CmmUnsafeForeignCall{}) =
-    not (globalRegistersConflict platform expr node)
-okToInline _ _ _ = True
-
--- -----------------------------------------------------------------------------
-
--- | @conflicts (r,e) node@ is @False@ if and only if the assignment
--- @r = e@ can be safely commuted past statement @node@.
-conflicts :: Platform -> Assignment -> CmmNode O x -> Bool
-conflicts platform (r, rhs, addr) node
-
-  -- (1) node defines registers used by rhs of assignment. This catches
-  -- assignments and all three kinds of calls. See Note [Sinking and calls]
-  | globalRegistersConflict platform rhs node                       = True
-  | localRegistersConflict  platform rhs node                       = True
-
-  -- (2) node uses register defined by assignment
-  | foldRegsUsed platform (\b r' -> r == r' || b) False node        = True
-
-  -- (3) a store to an address conflicts with a read of the same memory
-  | CmmStore addr' e _ <- node
-  , memConflicts addr (loadAddr platform addr' (cmmExprWidth platform e)) = True
-
-  -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively
-  | HeapMem    <- addr, CmmAssign (CmmGlobal Hp) _ <- node        = True
-  | StackMem   <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True
-  | SpMem{}    <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True
-
-  -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap]
-  | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem      = True
-
-  -- (6) suspendThread clobbers every global register not backed by a real
-  -- register. It also clobbers heap and stack but this is handled by (5)
-  | CmmUnsafeForeignCall (PrimTarget MO_SuspendThread) _ _ <- node
-  , foldRegsUsed platform (\b g -> globalRegMaybe platform g == Nothing || b) False rhs
-  = True
-
-  -- (7) native calls clobber any memory
-  | CmmCall{} <- node, memConflicts addr AnyMem                   = True
-
-  -- (8) otherwise, no conflict
-  | otherwise = False
-
-{- Note [Inlining foldRegsDefd]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-   foldRegsDefd is, after optimization, *not* a small function so
-   it's only marked INLINEABLE, but not INLINE.
-
-   However in some specific cases we call it *very* often making it
-   important to avoid the overhead of allocating the folding function.
-
-   So we simply force inlining via the magic inline function.
-   For T3294 this improves allocation with -O by ~1%.
-
--}
-
--- Returns True if node defines any global registers that are used in the
--- Cmm expression
-globalRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool
-globalRegistersConflict platform expr node =
-    -- See Note [Inlining foldRegsDefd]
-    inline foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmGlobal r) expr)
-                 False node
-
--- Returns True if node defines any local registers that are used in the
--- Cmm expression
-localRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool
-localRegistersConflict platform expr node =
-    -- See Note [Inlining foldRegsDefd]
-    inline foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmLocal  r) expr)
-                 False node
-
--- Note [Sinking and calls]
--- ~~~~~~~~~~~~~~~~~~~~~~~~
--- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall)
--- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after
--- stack layout (see Note [Sinking after stack layout]) which leads to two
--- invariants related to calls:
---
---   a) during stack layout phase all safe foreign calls are turned into
---      unsafe foreign calls (see Note [Lower safe foreign calls]). This
---      means that we will never encounter CmmForeignCall node when running
---      sinking after stack layout
---
---   b) stack layout saves all variables live across a call on the stack
---      just before making a call (remember we are not sinking assignments to
---      stack):
---
---       L1:
---          x = R1
---          P64[Sp - 16] = L2
---          P64[Sp - 8]  = x
---          Sp = Sp - 16
---          call f() returns L2
---       L2:
---
---      We will attempt to sink { x = R1 } but we will detect conflict with
---      { P64[Sp - 8]  = x } and hence we will drop { x = R1 } without even
---      checking whether it conflicts with { call f() }. In this way we will
---      never need to check any assignment conflicts with CmmCall. Remember
---      that we still need to check for potential memory conflicts.
---
--- So the result is that we only need to worry about CmmUnsafeForeignCall nodes
--- when checking conflicts (see Note [Unsafe foreign calls clobber caller-save registers]).
--- This assumption holds only when we do sinking after stack layout. If we run
--- it before stack layout we need to check for possible conflicts with all three
--- kinds of calls. Our `conflicts` function does that by using a generic
--- foldRegsDefd and foldRegsUsed functions defined in DefinerOfRegs and
--- UserOfRegs typeclasses.
---
-
--- An abstraction of memory read or written.
-data AbsMem
-  = NoMem            -- no memory accessed
-  | AnyMem           -- arbitrary memory
-  | HeapMem          -- definitely heap memory
-  | StackMem         -- definitely stack memory
-  | SpMem            -- <size>[Sp+n]
-       {-# UNPACK #-} !Int
-       {-# UNPACK #-} !Int
-
--- Having SpMem is important because it lets us float loads from Sp
--- past stores to Sp as long as they don't overlap, and this helps to
--- unravel some long sequences of
---    x1 = [Sp + 8]
---    x2 = [Sp + 16]
---    ...
---    [Sp + 8]  = xi
---    [Sp + 16] = xj
---
--- Note that SpMem is invalidated if Sp is changed, but the definition
--- of 'conflicts' above handles that.
-
--- ToDo: this won't currently fix the following commonly occurring code:
---    x1 = [R1 + 8]
---    x2 = [R1 + 16]
---    ..
---    [Hp - 8] = x1
---    [Hp - 16] = x2
---    ..
-
--- because [R1 + 8] and [Hp - 8] are both HeapMem.  We know that
--- assignments to [Hp + n] do not conflict with any other heap memory,
--- but this is tricky to nail down.  What if we had
---
---   x = Hp + n
---   [x] = ...
---
---  the store to [x] should be "new heap", not "old heap".
---  Furthermore, you could imagine that if we started inlining
---  functions in Cmm then there might well be reads of heap memory
---  that was written in the same basic block.  To take advantage of
---  non-aliasing of heap memory we will have to be more clever.
-
--- Note [Foreign calls clobber heap]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- It is tempting to say that foreign calls clobber only
--- non-heap/stack memory, but unfortunately we break this invariant in
--- the RTS.  For example, in stg_catch_retry_frame we call
--- stmCommitNestedTransaction() which modifies the contents of the
--- TRec it is passed (this actually caused incorrect code to be
--- generated).
---
--- Since the invariant is true for the majority of foreign calls,
--- perhaps we ought to have a special annotation for calls that can
--- modify heap/stack memory.  For now we just use the conservative
--- definition here.
---
--- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and
--- therefore we should never float any memory operations across one of
--- these calls.
---
--- `suspendThread` releases the capability used by the thread, hence we mustn't
--- float accesses to heap, stack or virtual global registers stored in the
--- capability (e.g. with unregisterised build, see #19237).
-
-
-bothMems :: AbsMem -> AbsMem -> AbsMem
-bothMems NoMem    x         = x
-bothMems x        NoMem     = x
-bothMems HeapMem  HeapMem   = HeapMem
-bothMems StackMem StackMem     = StackMem
-bothMems (SpMem o1 w1) (SpMem o2 w2)
-  | o1 == o2  = SpMem o1 (max w1 w2)
-  | otherwise = StackMem
-bothMems SpMem{}  StackMem  = StackMem
-bothMems StackMem SpMem{}   = StackMem
-bothMems _         _        = AnyMem
-
-memConflicts :: AbsMem -> AbsMem -> Bool
-memConflicts NoMem      _          = False
-memConflicts _          NoMem      = False
-memConflicts HeapMem    StackMem   = False
-memConflicts StackMem   HeapMem    = False
-memConflicts SpMem{}    HeapMem    = False
-memConflicts HeapMem    SpMem{}    = False
-memConflicts (SpMem o1 w1) (SpMem o2 w2)
-  | o1 < o2   = o1 + w1 > o2
-  | otherwise = o2 + w2 > o1
-memConflicts _         _         = True
-
-exprMem :: Platform -> CmmExpr -> AbsMem
-exprMem platform (CmmLoad addr w _)  = bothMems (loadAddr platform addr (typeWidth w)) (exprMem platform addr)
-exprMem platform (CmmMachOp _ es)    = foldr bothMems NoMem (map (exprMem platform) es)
-exprMem _        _                   = NoMem
-
-loadAddr :: Platform -> CmmExpr -> Width -> AbsMem
-loadAddr platform e w =
-  case e of
-   CmmReg r       -> regAddr platform r 0 w
-   CmmRegOff r i  -> regAddr platform r i w
-   _other | regUsedIn platform spReg e -> StackMem
-          | otherwise                  -> AnyMem
-
-regAddr :: Platform -> CmmReg -> Int -> Width -> AbsMem
-regAddr _      (CmmGlobal Sp) i w = SpMem i (widthInBytes w)
-regAddr _      (CmmGlobal Hp) _ _ = HeapMem
-regAddr _      (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps
-regAddr platform r _ _ | isGcPtrType (cmmRegType platform r) = HeapMem -- yay! GCPtr pays for itself
-regAddr _      _ _ _ = AnyMem
-
-{-
-Note [Inline GlobalRegs?]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Should we freely inline GlobalRegs?
-
-Actually it doesn't make a huge amount of difference either way, so we
-*do* currently treat GlobalRegs as "trivial" and inline them
-everywhere, but for what it's worth, here is what I discovered when I
-(SimonM) looked into this:
-
-Common sense says we should not inline GlobalRegs, because when we
-have
-
-  x = R1
-
-the register allocator will coalesce this assignment, generating no
-code, and simply record the fact that x is bound to $rbx (or
-whatever).  Furthermore, if we were to sink this assignment, then the
-range of code over which R1 is live increases, and the range of code
-over which x is live decreases.  All things being equal, it is better
-for x to be live than R1, because R1 is a fixed register whereas x can
-live in any register.  So we should neither sink nor inline 'x = R1'.
-
-However, not inlining GlobalRegs can have surprising
-consequences. e.g. (cgrun020)
-
-  c3EN:
-      _s3DB::P64 = R1;
-      _c3ES::P64 = _s3DB::P64 & 7;
-      if (_c3ES::P64 >= 2) goto c3EU; else goto c3EV;
-  c3EU:
-      _s3DD::P64 = P64[_s3DB::P64 + 6];
-      _s3DE::P64 = P64[_s3DB::P64 + 14];
-      I64[Sp - 8] = c3F0;
-      R1 = _s3DE::P64;
-      P64[Sp] = _s3DD::P64;
-
-inlining the GlobalReg gives:
-
-  c3EN:
-      if (R1 & 7 >= 2) goto c3EU; else goto c3EV;
-  c3EU:
-      I64[Sp - 8] = c3F0;
-      _s3DD::P64 = P64[R1 + 6];
-      R1 = P64[R1 + 14];
-      P64[Sp] = _s3DD::P64;
-
-but if we don't inline the GlobalReg, instead we get:
-
-      _s3DB::P64 = R1;
-      if (_s3DB::P64 & 7 >= 2) goto c3EU; else goto c3EV;
-  c3EU:
-      I64[Sp - 8] = c3F0;
-      R1 = P64[_s3DB::P64 + 14];
-      P64[Sp] = P64[_s3DB::P64 + 6];
-
-This looks better - we managed to inline _s3DD - but in fact it
-generates an extra reg-reg move:
-
-.Lc3EU:
-        movq $c3F0_info,-8(%rbp)
-        movq %rbx,%rax
-        movq 14(%rbx),%rbx
-        movq 6(%rax),%rax
-        movq %rax,(%rbp)
-
-because _s3DB is now live across the R1 assignment, we lost the
-benefit of coalescing.
-
-Who is at fault here?  Perhaps if we knew that _s3DB was an alias for
-R1, then we would not sink a reference to _s3DB past the R1
-assignment.  Or perhaps we *should* do that - we might gain by sinking
-it, despite losing the coalescing opportunity.
-
-Sometimes not inlining global registers wins by virtue of the rule
-about not inlining into arguments of a foreign call, e.g. (T7163) this
-is what happens when we inlined F1:
-
-      _s3L2::F32 = F1;
-      _c3O3::F32 = %MO_F_Mul_W32(F1, 10.0 :: W32);
-      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(_c3O3::F32);
-
-but if we don't inline F1:
-
-      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(%MO_F_Mul_W32(_s3L2::F32,
-                                                                                            10.0 :: W32));
--}
diff --git a/compiler/GHC/Cmm/Switch/Implement.hs b/compiler/GHC/Cmm/Switch/Implement.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Switch/Implement.hs
+++ /dev/null
@@ -1,117 +0,0 @@
-{-# LANGUAGE GADTs #-}
-module GHC.Cmm.Switch.Implement
-  ( cmmImplementSwitchPlans
-  )
-where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.BlockId
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Cmm.Switch
-import GHC.Types.Unique.Supply
-import GHC.Utils.Monad (concatMapM)
-
---
--- This module replaces Switch statements as generated by the Stg -> Cmm
--- transformation, which might be huge and sparse and hence unsuitable for
--- assembly code, by proper constructs (if-then-else trees, dense jump tables).
---
--- The actual, abstract strategy is determined by createSwitchPlan in
--- GHC.Cmm.Switch and returned as a SwitchPlan; here is just the implementation in
--- terms of Cmm code. See Note [Cmm Switches, the general plan] in GHC.Cmm.Switch.
---
--- This division into different modules is both to clearly separate concerns,
--- but also because createSwitchPlan needs access to the constructors of
--- SwitchTargets, a data type exported abstractly by GHC.Cmm.Switch.
---
-
--- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for
--- code generation.
-cmmImplementSwitchPlans :: Platform -> CmmGraph -> UniqSM CmmGraph
-cmmImplementSwitchPlans platform g =
-    -- Switch generation done by backend (LLVM/C)
-    do
-    blocks' <- concatMapM (visitSwitches platform) (toBlockList g)
-    return $ ofBlockList (g_entry g) blocks'
-
-visitSwitches :: Platform -> CmmBlock -> UniqSM [CmmBlock]
-visitSwitches platform block
-  | (entry@(CmmEntry _ scope), middle, CmmSwitch vanillaExpr ids) <- blockSplit block
-  = do
-    let plan = createSwitchPlan ids
-    -- See Note [Floating switch expressions]
-    (assignSimple, simpleExpr) <- floatSwitchExpr platform vanillaExpr
-
-    (newTail, newBlocks) <- implementSwitchPlan platform scope simpleExpr plan
-
-    let block' = entry `blockJoinHead` middle `blockAppend` assignSimple `blockAppend` newTail
-
-    return $ block' : newBlocks
-
-  | otherwise
-  = return [block]
-
--- Note [Floating switch expressions]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- When we translate a sparse switch into a search tree we would like
--- to compute the value we compare against only once.
---
--- For this purpose we assign the switch expression to a local register
--- and then use this register when constructing the actual binary tree.
---
--- This is important as the expression could contain expensive code like
--- memory loads or divisions which we REALLY don't want to duplicate.
---
--- This happened in parts of the handwritten RTS Cmm code. See also #16933
-
--- See Note [Floating switch expressions]
-floatSwitchExpr :: Platform -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)
-floatSwitchExpr _        reg@(CmmReg {})  = return (emptyBlock, reg)
-floatSwitchExpr platform expr             = do
-  (assign, expr') <- cmmMkAssign platform expr <$> getUniqueM
-  return (BMiddle assign, expr')
-
-
--- Implementing a switch plan (returning a tail block)
-implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])
-implementSwitchPlan platform scope expr = go
-  where
-    width = typeWidth $ cmmExprType platform expr
-
-    go (Unconditionally l)
-      = return (emptyBlock `blockJoinTail` CmmBranch l, [])
-    go (JumpTable ids)
-      = return (emptyBlock `blockJoinTail` CmmSwitch expr ids, [])
-    go (IfLT signed i ids1 ids2)
-      = do
-        (bid1, newBlocks1) <- go' ids1
-        (bid2, newBlocks2) <- go' ids2
-
-        let lt | signed    = MO_S_Lt
-               | otherwise = MO_U_Lt
-            scrut = CmmMachOp (lt width) [expr, CmmLit $ CmmInt i width]
-            lastNode = CmmCondBranch scrut bid1 bid2 Nothing
-            lastBlock = emptyBlock `blockJoinTail` lastNode
-        return (lastBlock, newBlocks1++newBlocks2)
-    go (IfEqual i l ids2)
-      = do
-        (bid2, newBlocks2) <- go' ids2
-
-        let scrut = CmmMachOp (MO_Ne width) [expr, CmmLit $ CmmInt i width]
-            lastNode = CmmCondBranch scrut bid2 l Nothing
-            lastBlock = emptyBlock `blockJoinTail` lastNode
-        return (lastBlock, newBlocks2)
-
-    -- Same but returning a label to branch to
-    go' (Unconditionally l)
-      = return (l, [])
-    go' p
-      = do
-        bid <- mkBlockId `fmap` getUniqueM
-        (last, newBlocks) <- go p
-        let block = CmmEntry bid scope `blockJoinHead` last
-        return (bid, block: newBlocks)
diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/Cmm/Utils.hs
+++ /dev/null
@@ -1,582 +0,0 @@
-{-# LANGUAGE GADTs, RankNTypes #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE LambdaCase #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
------------------------------------------------------------------------------
---
--- Cmm utilities.
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module GHC.Cmm.Utils(
-        -- CmmType
-        primRepCmmType, slotCmmType,
-        typeCmmType, typeForeignHint, primRepForeignHint,
-
-        -- CmmLit
-        zeroCLit, mkIntCLit,
-        mkWordCLit, packHalfWordsCLit,
-        mkByteStringCLit, mkFileEmbedLit,
-        mkDataLits, mkRODataLits,
-        mkStgWordCLit,
-
-        -- CmmExpr
-        mkIntExpr, zeroExpr,
-        mkLblExpr,
-        cmmRegOff,  cmmOffset,  cmmLabelOff,  cmmOffsetLit,  cmmOffsetExpr,
-        cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,
-        cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,
-        cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,
-        cmmLoadBWord, cmmLoadGCWord,
-        cmmNegate,
-        cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
-        cmmSLtWord,
-        cmmNeWord, cmmEqWord,
-        cmmOrWord, cmmAndWord,
-        cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,
-        cmmToWord,
-
-        cmmMkAssign,
-
-        baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
-        currentTSOExpr, currentNurseryExpr, cccsExpr,
-
-        -- Tagging
-        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged, cmmIsNotTagged,
-        cmmConstrTag1, mAX_PTR_TAG, tAG_MASK,
-
-        -- Overlap and usage
-        regsOverlap, regUsedIn,
-
-        -- Liveness and bitmaps
-        mkLiveness,
-
-        -- * Operations that probably don't belong here
-        modifyGraph,
-
-        ofBlockMap, toBlockMap,
-        ofBlockList, toBlockList,
-        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
-        foldlGraphBlocks, mapGraphNodes, mapGraphNodes1,
-
-        -- * Ticks
-        blockTicks
-  ) where
-
-import GHC.Prelude
-
-import GHC.Core.TyCon     ( PrimRep(..), PrimElemRep(..) )
-import GHC.Types.RepType  ( UnaryType, SlotTy (..), typePrimRep1 )
-
-import GHC.Platform
-import GHC.Runtime.Heap.Layout
-import GHC.Cmm
-import GHC.Cmm.BlockId
-import GHC.Cmm.CLabel
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Types.Unique
-import GHC.Platform.Regs
-
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Collections
-
----------------------------------------------------
---
---      CmmTypes
---
----------------------------------------------------
-
-primRepCmmType :: Platform -> PrimRep -> CmmType
-primRepCmmType platform = \case
-   VoidRep          -> panic "primRepCmmType:VoidRep"
-   LiftedRep        -> gcWord platform
-   UnliftedRep      -> gcWord platform
-   IntRep           -> bWord platform
-   WordRep          -> bWord platform
-   Int8Rep          -> b8
-   Word8Rep         -> b8
-   Int16Rep         -> b16
-   Word16Rep        -> b16
-   Int32Rep         -> b32
-   Word32Rep        -> b32
-   Int64Rep         -> b64
-   Word64Rep        -> b64
-   AddrRep          -> bWord platform
-   FloatRep         -> f32
-   DoubleRep        -> f64
-   VecRep len rep   -> vec len (primElemRepCmmType rep)
-
-slotCmmType :: Platform -> SlotTy -> CmmType
-slotCmmType platform = \case
-   PtrUnliftedSlot -> gcWord platform
-   PtrLiftedSlot   -> gcWord platform
-   WordSlot        -> bWord platform
-   Word64Slot      -> b64
-   FloatSlot       -> f32
-   DoubleSlot      -> f64
-   VecSlot l e     -> vec l (primElemRepCmmType e)
-
-primElemRepCmmType :: PrimElemRep -> CmmType
-primElemRepCmmType Int8ElemRep   = b8
-primElemRepCmmType Int16ElemRep  = b16
-primElemRepCmmType Int32ElemRep  = b32
-primElemRepCmmType Int64ElemRep  = b64
-primElemRepCmmType Word8ElemRep  = b8
-primElemRepCmmType Word16ElemRep = b16
-primElemRepCmmType Word32ElemRep = b32
-primElemRepCmmType Word64ElemRep = b64
-primElemRepCmmType FloatElemRep  = f32
-primElemRepCmmType DoubleElemRep = f64
-
-typeCmmType :: Platform -> UnaryType -> CmmType
-typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty)
-
-primRepForeignHint :: PrimRep -> ForeignHint
-primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"
-primRepForeignHint LiftedRep    = AddrHint
-primRepForeignHint UnliftedRep  = AddrHint
-primRepForeignHint IntRep       = SignedHint
-primRepForeignHint Int8Rep      = SignedHint
-primRepForeignHint Int16Rep     = SignedHint
-primRepForeignHint Int32Rep     = SignedHint
-primRepForeignHint Int64Rep     = SignedHint
-primRepForeignHint WordRep      = NoHint
-primRepForeignHint Word8Rep     = NoHint
-primRepForeignHint Word16Rep    = NoHint
-primRepForeignHint Word32Rep    = NoHint
-primRepForeignHint Word64Rep    = NoHint
-primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg
-primRepForeignHint FloatRep     = NoHint
-primRepForeignHint DoubleRep    = NoHint
-primRepForeignHint (VecRep {})  = NoHint
-
-typeForeignHint :: UnaryType -> ForeignHint
-typeForeignHint = primRepForeignHint . typePrimRep1
-
----------------------------------------------------
---
---      CmmLit
---
----------------------------------------------------
-
--- XXX: should really be Integer, since Int doesn't necessarily cover
--- the full range of target Ints.
-mkIntCLit :: Platform -> Int -> CmmLit
-mkIntCLit platform i = CmmInt (toInteger i) (wordWidth platform)
-
-mkIntExpr :: Platform -> Int -> CmmExpr
-mkIntExpr platform i = CmmLit $! mkIntCLit platform i
-
-zeroCLit :: Platform -> CmmLit
-zeroCLit platform = CmmInt 0 (wordWidth platform)
-
-zeroExpr :: Platform -> CmmExpr
-zeroExpr platform = CmmLit (zeroCLit platform)
-
-mkWordCLit :: Platform -> Integer -> CmmLit
-mkWordCLit platform wd = CmmInt wd (wordWidth platform)
-
--- | We make a top-level decl for the string, and return a label pointing to it
-mkByteStringCLit
-  :: CLabel -> ByteString -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
-mkByteStringCLit lbl bytes
-  = (CmmLabel lbl, CmmData (Section sec lbl) $ CmmStaticsRaw lbl [CmmString bytes])
-  where
-    -- This can not happen for String literals (as there \NUL is replaced by
-    -- C0 80). However, it can happen with Addr# literals.
-    sec = if 0 `BS.elem` bytes then ReadOnlyData else CString
-
--- | We make a top-level decl for the embedded binary file, and return a label pointing to it
-mkFileEmbedLit
-  :: CLabel -> FilePath -> Int -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
-mkFileEmbedLit lbl path len
-  = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path len]))
-
-
--- | Build a data-segment data block
-mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
-mkDataLits section lbl lits
-  = CmmData section (CmmStaticsRaw lbl $ map CmmStaticLit lits)
-
-mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
--- Build a read-only data block
-mkRODataLits lbl lits
-  = mkDataLits section lbl lits
-  where
-    section | any needsRelocation lits = Section RelocatableReadOnlyData lbl
-            | otherwise                = Section ReadOnlyData lbl
-    needsRelocation (CmmLabel _)      = True
-    needsRelocation (CmmLabelOff _ _) = True
-    needsRelocation _                 = False
-
-mkStgWordCLit :: Platform -> StgWord -> CmmLit
-mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform)
-
-packHalfWordsCLit :: Platform -> StgHalfWord -> StgHalfWord -> CmmLit
--- Make a single word literal in which the lower_half_word is
--- at the lower address, and the upper_half_word is at the
--- higher address
--- ToDo: consider using half-word lits instead
---       but be careful: that's vulnerable when reversed
-packHalfWordsCLit platform lower_half_word upper_half_word
-   = case platformByteOrder platform of
-       BigEndian    -> mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u)
-       LittleEndian -> mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform))
-    where l = fromStgHalfWord lower_half_word
-          u = fromStgHalfWord upper_half_word
-
----------------------------------------------------
---
---      CmmExpr
---
----------------------------------------------------
-
-mkLblExpr :: CLabel -> CmmExpr
-mkLblExpr lbl = CmmLit (CmmLabel lbl)
-
-cmmOffsetExpr :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
--- assumes base and offset have the same CmmType
-cmmOffsetExpr platform e (CmmLit (CmmInt n _)) = cmmOffset platform e (fromInteger n)
-cmmOffsetExpr platform e byte_off = CmmMachOp (MO_Add (cmmExprWidth platform e)) [e, byte_off]
-
-cmmOffset :: Platform -> CmmExpr -> Int -> CmmExpr
-cmmOffset _platform e 0        = e
-cmmOffset platform  e byte_off = case e of
-   CmmReg reg            -> cmmRegOff reg byte_off
-   CmmRegOff reg m       -> cmmRegOff reg (m+byte_off)
-   CmmLit lit            -> CmmLit (cmmOffsetLit lit byte_off)
-   CmmStackSlot area off -> CmmStackSlot area (off - byte_off)
-  -- note stack area offsets increase towards lower addresses
-   CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]
-      -> let !lit_off = (byte_off1 + toInteger byte_off)
-         in CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt lit_off rep)]
-   _ -> let !width = cmmExprWidth platform e
-        in
-        CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger byte_off) width)]
-
--- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.
-cmmRegOff :: CmmReg -> Int -> CmmExpr
-cmmRegOff reg 0        = CmmReg reg
-cmmRegOff reg byte_off = CmmRegOff reg byte_off
-
-cmmOffsetLit :: CmmLit -> Int -> CmmLit
-cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff l byte_off
-cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)
-cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off
-                                        = CmmLabelDiffOff l1 l2 (m+byte_off) w
-cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep
-cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
-
-cmmLabelOff :: CLabel -> Int -> CmmLit
--- Smart constructor for CmmLabelOff
-cmmLabelOff lbl 0        = CmmLabel lbl
-cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off
-
--- | Useful for creating an index into an array, with a statically known offset.
--- The type is the element type; used for making the multiplier
-cmmIndex :: Platform
-         -> Width       -- Width w
-         -> CmmExpr     -- Address of vector of items of width w
-         -> Int         -- Which element of the vector (0 based)
-         -> CmmExpr     -- Address of i'th element
-cmmIndex platform width base idx = cmmOffset platform base (idx * widthInBytes width)
-
--- | Useful for creating an index into an array, with an unknown offset.
-cmmIndexExpr :: Platform
-             -> Width           -- Width w
-             -> CmmExpr         -- Address of vector of items of width w
-             -> CmmExpr         -- Which element of the vector (0 based)
-             -> CmmExpr         -- Address of i'th element
-cmmIndexExpr platform width base (CmmLit (CmmInt n _)) = cmmIndex platform width base (fromInteger n)
-cmmIndexExpr platform width base idx =
-  cmmOffsetExpr platform base byte_off
-  where
-    idx_w = cmmExprWidth platform idx
-    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)]
-
-cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr
-cmmLoadIndex platform ty expr ix =
-    CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty NaturallyAligned -- TODO: Audit uses
-
--- | Load a naturally-aligned non-pointer word.
-cmmLoadBWord :: Platform -> CmmExpr -> CmmExpr
-cmmLoadBWord platform ptr = CmmLoad ptr (bWord platform) NaturallyAligned
-
--- | Load a naturally-aligned GC pointer.
-cmmLoadGCWord :: Platform -> CmmExpr -> CmmExpr
-cmmLoadGCWord platform ptr = CmmLoad ptr (gcWord platform) NaturallyAligned
-
--- The "B" variants take byte offsets
-cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
-cmmRegOffB = cmmRegOff
-
-cmmOffsetB :: Platform -> CmmExpr -> ByteOff -> CmmExpr
-cmmOffsetB = cmmOffset
-
-cmmOffsetExprB :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
-cmmOffsetExprB = cmmOffsetExpr
-
-cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
-cmmLabelOffB = cmmLabelOff
-
-cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
-cmmOffsetLitB = cmmOffsetLit
-
------------------------
--- The "W" variants take word offsets
-
-cmmOffsetExprW :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
--- The second arg is a *word* offset; need to change it to bytes
-cmmOffsetExprW platform  e (CmmLit (CmmInt n _)) = cmmOffsetW platform e (fromInteger n)
-cmmOffsetExprW platform e wd_off = cmmIndexExpr platform (wordWidth platform) e wd_off
-
-cmmOffsetW :: Platform -> CmmExpr -> WordOff -> CmmExpr
-cmmOffsetW platform e n = cmmOffsetB platform e (wordsToBytes platform n)
-
-cmmRegOffW :: Platform -> CmmReg -> WordOff -> CmmExpr
-cmmRegOffW platform reg wd_off = cmmRegOffB reg (wordsToBytes platform wd_off)
-
-cmmOffsetLitW :: Platform -> CmmLit -> WordOff -> CmmLit
-cmmOffsetLitW platform lit wd_off = cmmOffsetLitB lit (wordsToBytes platform wd_off)
-
-cmmLabelOffW :: Platform -> CLabel -> WordOff -> CmmLit
-cmmLabelOffW platform lbl wd_off = cmmLabelOffB lbl (wordsToBytes platform wd_off)
-
-cmmLoadIndexW :: Platform -> CmmExpr -> Int -> CmmType -> CmmExpr
-cmmLoadIndexW platform base off ty =
-    CmmLoad (cmmOffsetW platform base off) ty NaturallyAligned -- TODO: Audit ses
-
------------------------
-cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
-  cmmSLtWord,
-  cmmNeWord, cmmEqWord,
-  cmmOrWord, cmmAndWord,
-  cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord
-  :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
-cmmOrWord platform  e1 e2 = CmmMachOp (mo_wordOr platform)  [e1, e2]
-cmmAndWord platform e1 e2 = CmmMachOp (mo_wordAnd platform) [e1, e2]
-cmmNeWord platform  e1 e2 = CmmMachOp (mo_wordNe platform)  [e1, e2]
-cmmEqWord platform  e1 e2 = CmmMachOp (mo_wordEq platform)  [e1, e2]
-cmmULtWord platform e1 e2 = CmmMachOp (mo_wordULt platform) [e1, e2]
-cmmUGeWord platform e1 e2 = CmmMachOp (mo_wordUGe platform) [e1, e2]
-cmmUGtWord platform e1 e2 = CmmMachOp (mo_wordUGt platform) [e1, e2]
-cmmSLtWord platform e1 e2 = CmmMachOp (mo_wordSLt platform) [e1, e2]
-cmmUShrWord platform e1 e2 = CmmMachOp (mo_wordUShr platform) [e1, e2]
-cmmAddWord platform e1 e2 = CmmMachOp (mo_wordAdd platform) [e1, e2]
-cmmSubWord platform e1 e2 = CmmMachOp (mo_wordSub platform) [e1, e2]
-cmmMulWord platform e1 e2 = CmmMachOp (mo_wordMul platform) [e1, e2]
-cmmQuotWord platform e1 e2 = CmmMachOp (mo_wordUQuot platform) [e1, e2]
-
-cmmNegate :: Platform -> CmmExpr -> CmmExpr
-cmmNegate platform = \case
-   (CmmLit (CmmInt n rep))
-     -> CmmLit (CmmInt (-n) rep)
-   e -> CmmMachOp (MO_S_Neg (cmmExprWidth platform e)) [e]
-
-cmmToWord :: Platform -> CmmExpr -> CmmExpr
-cmmToWord platform e
-  | w == word  = e
-  | otherwise  = CmmMachOp (MO_UU_Conv w word) [e]
-  where
-    w = cmmExprWidth platform e
-    word = wordWidth platform
-
-cmmMkAssign :: Platform -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)
-cmmMkAssign platform expr uq =
-  let !ty = cmmExprType platform expr
-      reg = (CmmLocal (LocalReg uq ty))
-  in  (CmmAssign reg expr, CmmReg reg)
-
-
----------------------------------------------------
---
---      Tagging
---
----------------------------------------------------
-
-tAG_MASK :: Platform -> Int
-tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1
-
-mAX_PTR_TAG :: Platform -> Int
-mAX_PTR_TAG = tAG_MASK
-
--- Tag bits mask
-cmmTagMask, cmmPointerMask :: Platform -> CmmExpr
-cmmTagMask platform = mkIntExpr platform (tAG_MASK platform)
-cmmPointerMask platform = mkIntExpr platform (complement (tAG_MASK platform))
-
--- Used to untag a possibly tagged pointer
--- A static label need not be untagged
-cmmUntag, cmmIsTagged, cmmIsNotTagged, cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr
-cmmUntag _ e@(CmmLit (CmmLabel _)) = e
--- Default case
-cmmUntag platform e = cmmAndWord platform e (cmmPointerMask platform)
-
--- Test if a closure pointer is untagged/tagged.
-cmmIsTagged platform e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform)
-cmmIsNotTagged platform e = cmmEqWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform)
-
--- Get constructor tag, but one based.
-cmmConstrTag1 platform e = cmmAndWord platform e (cmmTagMask platform)
-
-
------------------------------------------------------------------------------
--- Overlap and usage
-
--- | Returns True if the two STG registers overlap on the specified
--- platform, in the sense that writing to one will clobber the
--- other. This includes the case that the two registers are the same
--- STG register. See Note [Overlapping global registers] for details.
-regsOverlap :: Platform -> CmmReg -> CmmReg -> Bool
-regsOverlap platform (CmmGlobal g) (CmmGlobal g')
-  | Just real  <- globalRegMaybe platform g,
-    Just real' <- globalRegMaybe platform g',
-    real == real'
-    = True
-regsOverlap _ reg reg' = reg == reg'
-
--- | Returns True if the STG register is used by the expression, in
--- the sense that a store to the register might affect the value of
--- the expression.
---
--- We must check for overlapping registers and not just equal
--- registers here, otherwise CmmSink may incorrectly reorder
--- assignments that conflict due to overlap. See #10521 and Note
--- [Overlapping global registers].
-regUsedIn :: Platform -> CmmReg -> CmmExpr -> Bool
-regUsedIn platform = regUsedIn_ where
-  _   `regUsedIn_` CmmLit _         = False
-  reg `regUsedIn_` CmmLoad e _ _    = reg `regUsedIn_` e
-  reg `regUsedIn_` CmmReg reg'      = regsOverlap platform reg reg'
-  reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap platform reg reg'
-  reg `regUsedIn_` CmmMachOp _ es   = any (reg `regUsedIn_`) es
-  _   `regUsedIn_` CmmStackSlot _ _ = False
-
---------------------------------------------
---
---        mkLiveness
---
----------------------------------------------
-
-mkLiveness :: Platform -> [LocalReg] -> Liveness
-mkLiveness _      [] = []
-mkLiveness platform (reg:regs)
-  = bits ++ mkLiveness platform regs
-  where
-    word_size = platformWordSizeInBytes platform
-    sizeW = (widthInBytes (typeWidth (localRegType reg)) + word_size - 1)
-            `quot` word_size
-            -- number of words, rounded up
-    bits = replicate sizeW is_non_ptr -- True <=> Non Ptr
-
-    is_non_ptr = not $ isGcPtrType (localRegType reg)
-
-
--- ============================================== -
--- ============================================== -
--- ============================================== -
-
----------------------------------------------------
---
---      Manipulating CmmGraphs
---
----------------------------------------------------
-
-modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
-modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}
-
-ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
-ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
-
--- | like 'toBlockList', but the entry block always comes first
-toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
-toBlockListEntryFirst g
-  | mapNull m  = []
-  | otherwise  = entry_block : others
-  where
-    m = toBlockMap g
-    entry_id = g_entry g
-    Just entry_block = mapLookup entry_id m
-    others = filter ((/= entry_id) . entryLabel) (mapElems m)
-
--- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks
--- so that the false case of a conditional jumps to the next block in the output
--- list of blocks. This matches the way OldCmm blocks were output since in
--- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches
--- have both true and false successors. Block ordering can make a big difference
--- in performance in the LLVM backend. Note that we rely crucially on the order
--- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode
--- defined in "GHC.Cmm.Node". -GBM
-toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]
-toBlockListEntryFirstFalseFallthrough g
-  | mapNull m  = []
-  | otherwise  = dfs setEmpty [entry_block]
-  where
-    m = toBlockMap g
-    entry_id = g_entry g
-    Just entry_block = mapLookup entry_id m
-
-    dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]
-    dfs _ [] = []
-    dfs visited (block:bs)
-      | id `setMember` visited = dfs visited bs
-      | otherwise              = block : dfs (setInsert id visited) bs'
-      where id = entryLabel block
-            bs' = foldr add_id bs (successors block)
-            add_id id bs = case mapLookup id m of
-                              Just b  -> b : bs
-                              Nothing -> bs
-
-ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
-ofBlockList entry blocks = CmmGraph { g_entry = entry
-                                    , g_graph = GMany NothingO body NothingO }
-  where body = foldr addBlock emptyBody blocks
-
-mapGraphNodes :: ( CmmNode C O -> CmmNode C O
-                 , CmmNode O O -> CmmNode O O
-                 , CmmNode O C -> CmmNode O C)
-              -> CmmGraph -> CmmGraph
-mapGraphNodes funs@(mf,_,_) g =
-  ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $
-  mapMap (mapBlock3' funs) $ toBlockMap g
-
-mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
-mapGraphNodes1 f = modifyGraph (mapGraph f)
-
-
-foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
-foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g
-
--------------------------------------------------
--- Tick utilities
-
--- | Extract all tick annotations from the given block
-blockTicks :: Block CmmNode C C -> [CmmTickish]
-blockTicks b = reverse $ foldBlockNodesF goStmt b []
-  where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]
-        goStmt  (CmmTick t) ts = t:ts
-        goStmt  _other      ts = ts
-
-
--- -----------------------------------------------------------------------------
--- Access to common global registers
-
-baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,
-  spLimExpr, hpLimExpr, cccsExpr :: CmmExpr
-baseExpr = CmmReg baseReg
-spExpr = CmmReg spReg
-spLimExpr = CmmReg spLimReg
-hpExpr = CmmReg hpReg
-hpLimExpr = CmmReg hpLimReg
-currentTSOExpr = CmmReg currentTSOReg
-currentNurseryExpr = CmmReg currentNurseryReg
-cccsExpr = CmmReg cccsReg
diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm.hs
+++ /dev/null
@@ -1,1125 +0,0 @@
--- -----------------------------------------------------------------------------
---
--- (c) The University of Glasgow 1993-2004
---
---
--- -----------------------------------------------------------------------------
-
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE UnboxedTuples #-}
-
--- | Native code generator
---
--- The native-code generator has machine-independent and
--- machine-dependent modules.
---
--- This module ("GHC.CmmToAsm") is the top-level machine-independent
--- module.  Before entering machine-dependent land, we do some
--- machine-independent optimisations (defined below) on the
--- 'CmmStmts's.
---
--- We convert to the machine-specific 'Instr' datatype with
--- 'cmmCodeGen', assuming an infinite supply of registers.  We then use
--- a machine-independent register allocator ('regAlloc') to rejoin
--- reality.  Obviously, 'regAlloc' has machine-specific helper
--- functions (see about "RegAllocInfo" below).
---
--- Finally, we order the basic blocks of the function so as to minimise
--- the number of jumps between blocks, by utilising fallthrough wherever
--- possible.
---
--- The machine-dependent bits break down as follows:
---
---   * ["MachRegs"]  Everything about the target platform's machine
---     registers (and immediate operands, and addresses, which tend to
---     intermingle/interact with registers).
---
---   * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should
---     have a module of its own), plus a miscellany of other things
---     (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
---
---   * ["MachCodeGen"]  is where 'Cmm' stuff turns into
---     machine instructions.
---
---   * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
---     a 'SDoc').
---
---   * ["RegAllocInfo"] In the register allocator, we manipulate
---     'MRegsState's, which are 'BitSet's, one bit per machine register.
---     When we want to say something about a specific machine register
---     (e.g., ``it gets clobbered by this instruction''), we set/unset
---     its bit.  Obviously, we do this 'BitSet' thing for efficiency
---     reasons.
---
---     The 'RegAllocInfo' module collects together the machine-specific
---     info needed to do register allocation.
---
---    * ["RegisterAlloc"] The (machine-independent) register allocator.
--- -}
---
-module GHC.CmmToAsm
-   ( nativeCodeGen
-
-   -- * Test-only exports: see trac #12744
-   -- used by testGraphNoSpills, which needs to access
-   -- the register allocator intermediate data structures
-   -- cmmNativeGen emits
-   , cmmNativeGen
-   , NcgImpl(..)
-   )
-where
-
-import GHC.Prelude hiding (head)
-
-import qualified GHC.CmmToAsm.X86   as X86
-import qualified GHC.CmmToAsm.PPC   as PPC
-import qualified GHC.CmmToAsm.AArch64 as AArch64
-import qualified GHC.CmmToAsm.Wasm as Wasm32
-
-import GHC.CmmToAsm.Reg.Liveness
-import qualified GHC.CmmToAsm.Reg.Linear                as Linear
-
-import qualified GHC.Data.Graph.Color                   as Color
-import qualified GHC.CmmToAsm.Reg.Graph                 as Color
-import qualified GHC.CmmToAsm.Reg.Graph.Stats           as Color
-import qualified GHC.CmmToAsm.Reg.Graph.TrivColorable   as Color
-
-import GHC.Utils.Asm
-import GHC.CmmToAsm.Reg.Target
-import GHC.Platform
-import GHC.CmmToAsm.BlockLayout as BlockLayout
-import GHC.Settings.Config
-import GHC.CmmToAsm.Instr
-import GHC.CmmToAsm.PIC
-import GHC.Platform.Reg
-import GHC.Platform.Reg.Class (RegClass)
-import GHC.CmmToAsm.Monad
-import GHC.CmmToAsm.CFG
-import GHC.CmmToAsm.Dwarf
-import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Types
-import GHC.Cmm.DebugBlock
-
-import GHC.Cmm.BlockId
-import GHC.StgToCmm.CgUtils ( fixStgRegisters )
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Opt           ( cmmMachOpFold )
-import GHC.Cmm.CLabel
-
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Supply
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Utils.Misc
-import GHC.Utils.Logger
-
-import GHC.Utils.BufHandle
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Error
-import GHC.Utils.Exception (evaluate)
-import GHC.Utils.Constants (debugIsOn)
-
-import GHC.Data.FastString
-import GHC.Types.Unique.Set
-import GHC.Unit
-import GHC.Data.Stream (Stream)
-import qualified GHC.Data.Stream as Stream
-
-import Data.List (sortBy)
-import Data.List.NonEmpty (groupAllWith, head)
-import Data.Maybe
-import Data.Ord         ( comparing )
-import Control.Monad
-import System.IO
-import System.Directory ( getCurrentDirectory )
-
---------------------
-nativeCodeGen :: forall a . Logger -> NCGConfig -> ModLocation -> Handle -> UniqSupply
-              -> Stream IO RawCmmGroup a
-              -> IO a
-nativeCodeGen logger config modLoc h us cmms
- = let platform = ncgPlatform config
-       nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr)
-            => NcgImpl statics instr jumpDest -> IO a
-       nCG' ncgImpl = nativeCodeGen' logger config modLoc ncgImpl h us cmms
-   in case platformArch platform of
-      ArchX86       -> nCG' (X86.ncgX86     config)
-      ArchX86_64    -> nCG' (X86.ncgX86_64  config)
-      ArchPPC       -> nCG' (PPC.ncgPPC     config)
-      ArchPPC_64 _  -> nCG' (PPC.ncgPPC     config)
-      ArchS390X     -> panic "nativeCodeGen: No NCG for S390X"
-      ArchARM {}    -> panic "nativeCodeGen: No NCG for ARM"
-      ArchAArch64   -> nCG' (AArch64.ncgAArch64 config)
-      ArchAlpha     -> panic "nativeCodeGen: No NCG for Alpha"
-      ArchMipseb    -> panic "nativeCodeGen: No NCG for mipseb"
-      ArchMipsel    -> panic "nativeCodeGen: No NCG for mipsel"
-      ArchRISCV64   -> panic "nativeCodeGen: No NCG for RISCV64"
-      ArchUnknown   -> panic "nativeCodeGen: No NCG for unknown arch"
-      ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"
-      ArchWasm32    -> Wasm32.ncgWasm platform us modLoc h cmms
-
--- | Data accumulated during code generation. Mostly about statistics,
--- but also collects debug data for DWARF generation.
-data NativeGenAcc statics instr
-  = NGS { ngs_imports     :: ![[CLabel]]
-        , ngs_natives     :: ![[NatCmmDecl statics instr]]
-             -- ^ Native code generated, for statistics. This might
-             -- hold a lot of data, so it is important to clear this
-             -- field as early as possible if it isn't actually
-             -- required.
-        , ngs_colorStats  :: ![[Color.RegAllocStats statics instr]]
-        , ngs_linearStats :: ![[Linear.RegAllocStats]]
-        , ngs_labels      :: ![Label]
-        , ngs_debug       :: ![DebugBlock]
-        , ngs_dwarfFiles  :: !DwarfFiles
-        , ngs_unwinds     :: !(LabelMap [UnwindPoint])
-             -- ^ see Note [Unwinding information in the NCG]
-             -- and Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
-        }
-
-{-
-Note [Unwinding information in the NCG]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Unwind information is a type of metadata which allows a debugging tool
-to reconstruct the values of machine registers at the time a procedure was
-entered. For the most part, the production of unwind information is handled by
-the Cmm stage, where it is represented by CmmUnwind nodes.
-
-Unfortunately, the Cmm stage doesn't know everything necessary to produce
-accurate unwinding information. For instance, the x86-64 calling convention
-requires that the stack pointer be aligned to 16 bytes, which in turn means that
-GHC must sometimes add padding to $sp prior to performing a foreign call. When
-this happens unwind information must be updated accordingly.
-For this reason, we make the NCG backends responsible for producing
-unwinding tables (with the extractUnwindPoints function in NcgImpl).
-
-We accumulate the produced unwind tables over CmmGroups in the ngs_unwinds
-field of NativeGenAcc. This is a label map which contains an entry for each
-procedure, containing a list of unwinding points (e.g. a label and an associated
-unwinding table).
-
-See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
--}
-
-nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr)
-               => Logger
-               -> NCGConfig
-               -> ModLocation
-               -> NcgImpl statics instr jumpDest
-               -> Handle
-               -> UniqSupply
-               -> Stream IO RawCmmGroup a
-               -> IO a
-nativeCodeGen' logger config modLoc ncgImpl h us cmms
- = do
-        -- BufHandle is a performance hack.  We could hide it inside
-        -- Pretty if it weren't for the fact that we do lots of little
-        -- printDocs here (in order to do codegen in constant space).
-        bufh <- newBufHandle h
-        let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty
-        (ngs, us', a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh us
-                                         cmms ngs0
-        _ <- finishNativeGen logger config modLoc bufh us' ngs
-        return a
-
-finishNativeGen :: Instruction instr
-                => Logger
-                -> NCGConfig
-                -> ModLocation
-                -> BufHandle
-                -> UniqSupply
-                -> NativeGenAcc statics instr
-                -> IO UniqSupply
-finishNativeGen logger config modLoc bufh us ngs
- = withTimingSilent logger (text "NCG") (`seq` ()) $ do
-        -- Write debug data and finish
-        us' <- if not (ncgDwarfEnabled config)
-                  then return us
-                  else do
-                     compPath <- getCurrentDirectory
-                     let (dwarf_h, us') = dwarfGen compPath config modLoc us (ngs_debug ngs)
-                         (dwarf_s, _)   = dwarfGen compPath config modLoc us (ngs_debug ngs)
-                     emitNativeCode logger config bufh dwarf_h dwarf_s
-                     return us'
-
-        -- dump global NCG stats for graph coloring allocator
-        let stats = concat (ngs_colorStats ngs)
-        unless (null stats) $ do
-
-          -- build the global register conflict graph
-          let graphGlobal
-                  = foldl' Color.union Color.initGraph
-                  $ [ Color.raGraph stat
-                          | stat@Color.RegAllocStatsStart{} <- stats]
-
-          dump_stats (Color.pprStats stats graphGlobal)
-
-          let platform = ncgPlatform config
-          putDumpFileMaybe logger
-                  Opt_D_dump_asm_conflicts "Register conflict graph"
-                  FormatText
-                  $ Color.dotGraph
-                          (targetRegDotColor platform)
-                          (Color.trivColorable platform
-                                  (targetVirtualRegSqueeze platform)
-                                  (targetRealRegSqueeze platform))
-                  $ graphGlobal
-
-
-        -- dump global NCG stats for linear allocator
-        let linearStats = concat (ngs_linearStats ngs)
-        unless (null linearStats) $
-          dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)
-
-        -- write out the imports
-        let ctx = ncgAsmContext config
-        bPutHDoc bufh ctx $ makeImportsDoc config (concat (ngs_imports ngs))
-        bFlush bufh
-
-        return us'
-  where
-    dump_stats = logDumpFile logger (mkDumpStyle alwaysQualify)
-                   Opt_D_dump_asm_stats "NCG stats"
-                   FormatText
-
-cmmNativeGenStream :: forall statics jumpDest instr a . (OutputableP Platform statics, Outputable jumpDest, Instruction instr)
-              => Logger
-              -> NCGConfig
-              -> ModLocation
-              -> NcgImpl statics instr jumpDest
-              -> BufHandle
-              -> UniqSupply
-              -> Stream.Stream IO RawCmmGroup a
-              -> NativeGenAcc statics instr
-              -> IO (NativeGenAcc statics instr, UniqSupply, a)
-
-cmmNativeGenStream logger config modLoc ncgImpl h us cmm_stream ngs
- = loop us (Stream.runStream cmm_stream) ngs
-  where
-    ncglabel = text "NCG"
-    loop :: UniqSupply
-              -> Stream.StreamS IO RawCmmGroup a
-              -> NativeGenAcc statics instr
-              -> IO (NativeGenAcc statics instr, UniqSupply, a)
-    loop us s ngs =
-      case s of
-        Stream.Done a ->
-          return (ngs { ngs_imports = reverse $ ngs_imports ngs
-                      , ngs_natives = reverse $ ngs_natives ngs
-                      , ngs_colorStats = reverse $ ngs_colorStats ngs
-                      , ngs_linearStats = reverse $ ngs_linearStats ngs
-                      },
-                  us,
-                  a)
-        Stream.Effect m -> m >>= \cmm_stream' -> loop us cmm_stream' ngs
-        Stream.Yield cmms cmm_stream' -> do
-          (us', ngs'') <-
-            withTimingSilent logger
-                ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do
-              -- Generate debug information
-              let !ndbgs | ncgDwarfEnabled config = cmmDebugGen modLoc cmms
-                         | otherwise              = []
-                  dbgMap = debugToMap ndbgs
-
-              -- Generate native code
-              (ngs',us') <- cmmNativeGens logger config ncgImpl h
-                                          dbgMap us cmms ngs 0
-
-              -- Link native code information into debug blocks
-              -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
-              let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
-                  platform = ncgPlatform config
-              unless (null ldbgs) $
-                putDumpFileMaybe logger Opt_D_dump_debug "Debug Infos" FormatText
-                  (vcat $ map (pdoc platform) ldbgs)
-
-              -- Accumulate debug information for emission in finishNativeGen.
-              let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
-              return (us', ngs'')
-
-          loop us' cmm_stream' ngs''
-
-
--- | Do native code generation on all these cmms.
---
-cmmNativeGens :: forall statics instr jumpDest.
-                 (OutputableP Platform statics, Outputable jumpDest, Instruction instr)
-              => Logger
-              -> NCGConfig
-              -> NcgImpl statics instr jumpDest
-              -> BufHandle
-              -> LabelMap DebugBlock
-              -> UniqSupply
-              -> [RawCmmDecl]
-              -> NativeGenAcc statics instr
-              -> Int
-              -> IO (NativeGenAcc statics instr, UniqSupply)
-
-cmmNativeGens logger config ncgImpl h dbgMap = go
-  where
-    go :: UniqSupply -> [RawCmmDecl]
-       -> NativeGenAcc statics instr -> Int
-       -> IO (NativeGenAcc statics instr, UniqSupply)
-
-    go us [] ngs !_ =
-        return (ngs, us)
-
-    go us (cmm : cmms) ngs count = do
-        let fileIds = ngs_dwarfFiles ngs
-        (us', fileIds', native, imports, colorStats, linearStats, unwinds)
-          <- {-# SCC "cmmNativeGen" #-}
-             cmmNativeGen logger ncgImpl us fileIds dbgMap
-                          cmm count
-
-        -- Generate .file directives for every new file that has been
-        -- used. Note that it is important that we generate these in
-        -- ascending order, as Clang's 3.6 assembler complains.
-        let newFileIds = sortBy (comparing snd) $
-                         nonDetEltsUFM $ fileIds' `minusUFM` fileIds
-            -- See Note [Unique Determinism and code generation]
-            pprDecl (f,n) = line $ text "\t.file " <> int n <+>
-                                   pprFilePathString (unpackFS f)
-
-        -- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad
-        emitNativeCode logger config h
-          (vcat $
-           map pprDecl newFileIds ++
-           map (pprNatCmmDeclH ncgImpl) native)
-          (vcat $
-           map pprDecl newFileIds ++
-           map (pprNatCmmDeclS ncgImpl) native)
-
-        -- force evaluation all this stuff to avoid space leaks
-        let platform = ncgPlatform config
-        {-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pprAsmLabel platform) imports) ()
-
-        let !labels' = if ncgDwarfEnabled config
-                       then cmmDebugLabels isMetaInstr native else []
-            !natives' = if logHasDumpFlag logger Opt_D_dump_asm_stats
-                        then native : ngs_natives ngs else []
-
-            mCon = maybe id (:)
-            ngs' = ngs{ ngs_imports     = imports : ngs_imports ngs
-                      , ngs_natives     = natives'
-                      , ngs_colorStats  = colorStats `mCon` ngs_colorStats ngs
-                      , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs
-                      , ngs_labels      = ngs_labels ngs ++ labels'
-                      , ngs_dwarfFiles  = fileIds'
-                      , ngs_unwinds     = ngs_unwinds ngs `mapUnion` unwinds
-                      }
-        go us' cmms ngs' (count + 1)
-
-
--- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad
-emitNativeCode :: Logger -> NCGConfig -> BufHandle -> HDoc -> SDoc -> IO ()
-emitNativeCode logger config h hdoc sdoc = do
-        let ctx = ncgAsmContext config
-        {-# SCC "pprNativeCode" #-} bPutHDoc h ctx hdoc
-
-        -- dump native code
-        putDumpFileMaybe logger
-                Opt_D_dump_asm "Asm code" FormatASM
-                sdoc
-
--- | Complete native code generation phase for a single top-level chunk of Cmm.
---      Dumping the output of each stage along the way.
---      Global conflict graph and NGC stats
-cmmNativeGen
-    :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest)
-    => Logger
-    -> NcgImpl statics instr jumpDest
-        -> UniqSupply
-        -> DwarfFiles
-        -> LabelMap DebugBlock
-        -> RawCmmDecl                                   -- ^ the cmm to generate code for
-        -> Int                                          -- ^ sequence number of this top thing
-        -> IO   ( UniqSupply
-                , DwarfFiles
-                , [NatCmmDecl statics instr]                -- native code
-                , [CLabel]                                  -- things imported by this cmm
-                , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
-                , Maybe [Linear.RegAllocStats]              -- stats for the linear register allocators
-                , LabelMap [UnwindPoint]                    -- unwinding information for blocks
-                )
-
-cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
- = do
-        let config   = ncgConfig ncgImpl
-        let platform = ncgPlatform config
-        let weights  = ncgCfgWeights config
-
-        let proc_name = case cmm of
-                (CmmProc _ entry_label _ _) -> pprAsmLabel platform entry_label
-                _                           -> text "DataChunk"
-
-        -- rewrite assignments to global regs
-        let fixed_cmm =
-                {-# SCC "fixStgRegisters" #-}
-                fixStgRegisters platform cmm
-
-        -- cmm to cmm optimisations
-        let (opt_cmm, imports) =
-                {-# SCC "cmmToCmm" #-}
-                cmmToCmm config fixed_cmm
-
-        putDumpFileMaybe logger
-                Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM
-                (pprCmmGroup platform [opt_cmm])
-
-        let cmmCfg = {-# SCC "getCFG" #-}
-                     getCfgProc platform weights opt_cmm
-
-        -- generate native code from cmm
-        let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) =
-                {-# SCC "genMachCode" #-}
-                initUs us $ genMachCode config
-                                        (cmmTopCodeGen ncgImpl)
-                                        fileIds dbgMap opt_cmm cmmCfg
-
-        putDumpFileMaybe logger
-                Opt_D_dump_asm_native "Native code" FormatASM
-                (vcat $ map (pprNatCmmDeclS ncgImpl) native)
-
-        maybeDumpCfg logger (Just nativeCfgWeights) "CFG Weights - Native" proc_name
-
-        -- tag instructions with register liveness information
-        -- also drops dead code. We don't keep the cfg in sync on
-        -- some backends, so don't use it there.
-        let livenessCfg = if ncgEnableDeadCodeElimination config
-                                then Just nativeCfgWeights
-                                else Nothing
-        let (withLiveness, usLive) =
-                {-# SCC "regLiveness" #-}
-                initUs usGen
-                        $ mapM (cmmTopLiveness livenessCfg platform) native
-
-        putDumpFileMaybe logger
-                Opt_D_dump_asm_liveness "Liveness annotations added"
-                FormatCMM
-                (vcat $ map (pprLiveCmmDecl platform) withLiveness)
-
-        -- allocate registers
-        (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear, raStats, stack_updt_blks) <-
-         if ( ncgRegsGraph config || ncgRegsIterative config )
-          then do
-                -- the regs usable for allocation
-                let (alloc_regs :: UniqFM RegClass (UniqSet RealReg))
-                        = foldr (\r -> plusUFM_C unionUniqSets
-                                        $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
-                                emptyUFM
-                        $ allocatableRegs ncgImpl
-
-                -- do the graph coloring register allocation
-                let ((alloced, maybe_more_stack, regAllocStats), usAlloc)
-                        = {-# SCC "RegAlloc-color" #-}
-                          initUs usLive
-                          $ Color.regAlloc
-                                config
-                                alloc_regs
-                                (mkUniqSet [0 .. maxSpillSlots ncgImpl])
-                                (maxSpillSlots ncgImpl)
-                                withLiveness
-                                livenessCfg
-
-                let ((alloced', stack_updt_blks), usAlloc')
-                        = initUs usAlloc $
-                                case maybe_more_stack of
-                                Nothing     -> return (alloced, [])
-                                Just amount -> do
-                                    (alloced',stack_updt_blks) <- unzip <$>
-                                                (mapM ((ncgAllocMoreStack ncgImpl) amount) alloced)
-                                    return (alloced', concat stack_updt_blks )
-
-
-                -- dump out what happened during register allocation
-                putDumpFileMaybe logger
-                        Opt_D_dump_asm_regalloc "Registers allocated"
-                        FormatCMM
-                        (vcat $ map (pprNatCmmDeclS ncgImpl) alloced)
-
-                putDumpFileMaybe logger
-                        Opt_D_dump_asm_regalloc_stages "Build/spill stages"
-                        FormatText
-                        (vcat   $ map (\(stage, stats)
-                                        -> text "# --------------------------"
-                                        $$ text "#  cmm " <> int count <> text " Stage " <> int stage
-                                        $$ ppr (fmap (pprInstr platform) stats))
-                                $ zip [0..] regAllocStats)
-
-                let mPprStats =
-                        if logHasDumpFlag logger Opt_D_dump_asm_stats
-                         then Just regAllocStats else Nothing
-
-                -- force evaluation of the Maybe to avoid space leak
-                mPprStats `seq` return ()
-
-                return  ( alloced', usAlloc'
-                        , mPprStats
-                        , Nothing
-                        , [], stack_updt_blks)
-
-          else do
-                -- do linear register allocation
-                let reg_alloc proc = do
-                       (alloced, maybe_more_stack, ra_stats) <-
-                               Linear.regAlloc config proc
-                       case maybe_more_stack of
-                         Nothing -> return ( alloced, ra_stats, [] )
-                         Just amount -> do
-                           (alloced',stack_updt_blks) <-
-                               ncgAllocMoreStack ncgImpl amount alloced
-                           return (alloced', ra_stats, stack_updt_blks )
-
-                let ((alloced, regAllocStats, stack_updt_blks), usAlloc)
-                        = {-# SCC "RegAlloc-linear" #-}
-                          initUs usLive
-                          $ liftM unzip3
-                          $ mapM reg_alloc withLiveness
-
-                putDumpFileMaybe logger
-                        Opt_D_dump_asm_regalloc "Registers allocated"
-                        FormatCMM
-                        (vcat $ map (pprNatCmmDeclS ncgImpl) alloced)
-
-                let mPprStats =
-                        if logHasDumpFlag logger Opt_D_dump_asm_stats
-                         then Just (catMaybes regAllocStats) else Nothing
-
-                -- force evaluation of the Maybe to avoid space leak
-                mPprStats `seq` return ()
-
-                return  ( alloced, usAlloc
-                        , Nothing
-                        , mPprStats, (catMaybes regAllocStats)
-                        , concat stack_updt_blks )
-
-        -- Fixupblocks the register allocator inserted (from, regMoves, to)
-        let cfgRegAllocUpdates :: [(BlockId,BlockId,BlockId)]
-            cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)
-
-        let cfgWithFixupBlks =
-                (\cfg -> addNodesBetween weights cfg cfgRegAllocUpdates) <$> livenessCfg
-
-        -- Insert stack update blocks
-        let postRegCFG =
-                pure (foldl' (\m (from,to) -> addImmediateSuccessor weights from to m ))
-                     <*> cfgWithFixupBlks
-                     <*> pure stack_updt_blks
-
-        ---- generate jump tables
-        let tabled      =
-                {-# SCC "generateJumpTables" #-}
-                generateJumpTables ncgImpl alloced
-
-        when (not $ null nativeCfgWeights) $ putDumpFileMaybe logger
-                Opt_D_dump_cfg_weights "CFG Update information"
-                FormatText
-                ( text "stack:" <+> ppr stack_updt_blks $$
-                  text "linearAlloc:" <+> ppr cfgRegAllocUpdates )
-
-        ---- shortcut branches
-        let (shorted, postShortCFG)     =
-                {-# SCC "shortcutBranches" #-}
-                shortcutBranches config ncgImpl tabled postRegCFG
-
-        let optimizedCFG :: Maybe CFG
-            optimizedCFG =
-                optimizeCFG (ncgCmmStaticPred config) weights cmm <$!> postShortCFG
-
-        maybeDumpCfg logger optimizedCFG "CFG Weights - Final" proc_name
-
-        --TODO: Partially check validity of the cfg.
-        let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks
-            getBlks _ = []
-
-        when ( ncgEnableDeadCodeElimination config &&
-                (ncgAsmLinting config || debugIsOn )) $ do
-                let blocks = concatMap getBlks shorted
-                let labels = setFromList $ fmap blockId blocks :: LabelSet
-                let cfg = fromJust optimizedCFG
-                return $! seq (sanityCheckCfg cfg labels $
-                                text "cfg not in lockstep") ()
-
-        ---- sequence blocks
-        let sequenced :: [NatCmmDecl statics instr]
-            sequenced =
-                checkLayout shorted $
-                {-# SCC "sequenceBlocks" #-}
-                map (BlockLayout.sequenceTop
-                        ncgImpl optimizedCFG)
-                    shorted
-
-        let branchOpt :: [NatCmmDecl statics instr]
-            branchOpt =
-                {-# SCC "invertCondBranches" #-}
-                map invert sequenced
-              where
-                invertConds :: LabelMap RawCmmStatics -> [NatBasicBlock instr]
-                            -> [NatBasicBlock instr]
-                invertConds = invertCondBranches ncgImpl optimizedCFG
-                invert top@CmmData {} = top
-                invert (CmmProc info lbl live (ListGraph blocks)) =
-                    CmmProc info lbl live (ListGraph $ invertConds info blocks)
-
-        -- generate unwinding information from cmm
-        let unwinds :: BlockMap [UnwindPoint]
-            unwinds =
-                {-# SCC "unwindingInfo" #-}
-                foldl' addUnwind mapEmpty branchOpt
-              where
-                addUnwind acc proc =
-                    acc `mapUnion` computeUnwinding config ncgImpl proc
-
-        return  ( usAlloc
-                , fileIds'
-                , branchOpt
-                , lastMinuteImports ++ imports
-                , ppr_raStatsColor
-                , ppr_raStatsLinear
-                , unwinds )
-
-maybeDumpCfg :: Logger -> Maybe CFG -> String -> SDoc -> IO ()
-maybeDumpCfg _logger Nothing _ _ = return ()
-maybeDumpCfg logger (Just cfg) msg proc_name
-        | null cfg = return ()
-        | otherwise
-        = putDumpFileMaybe logger
-                Opt_D_dump_cfg_weights msg
-                FormatText
-                (proc_name <> char ':' $$ pprEdgeWeights cfg)
-
--- | Make sure all blocks we want the layout algorithm to place have been placed.
-checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
-            -> [NatCmmDecl statics instr]
-checkLayout procsUnsequenced procsSequenced =
-        assertPpr (setNull diff) (text "Block sequencing dropped blocks:" <> ppr diff)
-        procsSequenced
-  where
-        blocks1 = foldl' (setUnion) setEmpty $
-                        map getBlockIds procsUnsequenced :: LabelSet
-        blocks2 = foldl' (setUnion) setEmpty $
-                        map getBlockIds procsSequenced
-        diff = setDifference blocks1 blocks2
-
-        getBlockIds (CmmData _ _) = setEmpty
-        getBlockIds (CmmProc _ _ _ (ListGraph blocks)) =
-                setFromList $ map blockId blocks
-
--- | Compute unwinding tables for the blocks of a procedure
-computeUnwinding :: Instruction instr
-                 => NCGConfig
-                 -> NcgImpl statics instr jumpDest
-                 -> NatCmmDecl statics instr
-                    -- ^ the native code generated for the procedure
-                 -> LabelMap [UnwindPoint]
-                    -- ^ unwinding tables for all points of all blocks of the
-                    -- procedure
-computeUnwinding config _ _
-  | not (ncgComputeUnwinding config) = mapEmpty
-computeUnwinding _ _ (CmmData _ _)   = mapEmpty
-computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) =
-    -- In general we would need to push unwinding information down the
-    -- block-level call-graph to ensure that we fully account for all
-    -- relevant register writes within a procedure.
-    --
-    -- However, the only unwinding information that we care about in GHC is for
-    -- Sp. The fact that GHC.Cmm.LayoutStack already ensures that we have unwind
-    -- information at the beginning of every block means that there is no need
-    -- to perform this sort of push-down.
-    mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs)
-                | BasicBlock blk_lbl instrs <- blks ]
-
--- | Build a doc for all the imports.
---
-makeImportsDoc :: NCGConfig -> [CLabel] -> HDoc
-makeImportsDoc config imports
- = dyld_stubs imports
-            $$
-            -- On recent versions of Darwin, the linker supports
-            -- dead-stripping of code and data on a per-symbol basis.
-            -- There's a hack to make this work in PprMach.pprNatCmmDecl.
-            (if platformHasSubsectionsViaSymbols platform
-             then line $ text ".subsections_via_symbols"
-             else Outputable.empty)
-            $$
-                -- On recent GNU ELF systems one can mark an object file
-                -- as not requiring an executable stack. If all objects
-                -- linked into a program have this note then the program
-                -- will not use an executable stack, which is good for
-                -- security. GHC generated code does not need an executable
-                -- stack so add the note in:
-            (if platformHasGnuNonexecStack platform
-             then line $ text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits"
-             else Outputable.empty)
-            $$
-                -- And just because every other compiler does, let's stick in
-                -- an identifier directive: .ident "GHC x.y.z"
-            (if platformHasIdentDirective platform
-             then let compilerIdent = text "GHC" <+> text cProjectVersion
-                   in line $ text ".ident" <+> doubleQuotes compilerIdent
-             else Outputable.empty)
-
- where
-        platform = ncgPlatform config
-
-        -- Generate "symbol stubs" for all external symbols that might
-        -- come from a dynamic library.
-        dyld_stubs :: [CLabel] -> HDoc
-        -- (Hack) sometimes two Labels pretty-print the same, but have
-        -- different uniques; so we compare their text versions...
-        dyld_stubs imps
-                | needImportedSymbols config
-                = vcat $
-                        (pprGotDeclaration config :) $
-                        fmap (pprImportedSymbol config . fst . head) $
-                        groupAllWith snd $
-                        map doPpr $
-                        imps
-                | otherwise
-                = Outputable.empty
-
-        doPpr lbl = (lbl, showSDocOneLine
-                              (ncgAsmContext config)
-                              (pprAsmLabel platform lbl))
-
--- -----------------------------------------------------------------------------
--- Generate jump tables
-
--- Analyzes all native code and generates data sections for all jump
--- table instructions.
-generateJumpTables
-        :: NcgImpl statics instr jumpDest
-        -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
-generateJumpTables ncgImpl xs = concatMap f xs
-    where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs
-          f p = [p]
-          g (BasicBlock _ xs) = mapMaybe (generateJumpTableForInstr ncgImpl) xs
-
--- -----------------------------------------------------------------------------
--- Shortcut branches
-
-shortcutBranches
-        :: forall statics instr jumpDest. (Outputable jumpDest)
-        => NCGConfig
-        -> NcgImpl statics instr jumpDest
-        -> [NatCmmDecl statics instr]
-        -> Maybe CFG
-        -> ([NatCmmDecl statics instr],Maybe CFG)
-
-shortcutBranches config ncgImpl tops weights
-  | ncgEnableShortcutting config
-  = ( map (apply_mapping ncgImpl mapping) tops'
-    , shortcutWeightMap mappingBid <$!> weights )
-  | otherwise
-  = (tops, weights)
-  where
-    (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
-    mapping = mapUnions mappings :: LabelMap jumpDest
-    mappingBid = fmap (getJumpDestBlockId ncgImpl) mapping
-
-build_mapping :: forall instr t d statics jumpDest.
-                 NcgImpl statics instr jumpDest
-              -> GenCmmDecl d (LabelMap t) (ListGraph instr)
-              -> (GenCmmDecl d (LabelMap t) (ListGraph instr)
-                 ,LabelMap jumpDest)
-build_mapping _ top@(CmmData _ _) = (top, mapEmpty)
-build_mapping _ (CmmProc info lbl live (ListGraph []))
-  = (CmmProc info lbl live (ListGraph []), mapEmpty)
-build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks)))
-  = (CmmProc info lbl live (ListGraph (head:others)), mapping)
-        -- drop the shorted blocks, but don't ever drop the first one,
-        -- because it is pointed to by a global label.
-  where
-    -- find all the blocks that just consist of a jump that can be
-    -- shorted.
-    -- Don't completely eliminate loops here -- that can leave a dangling jump!
-    shortcut_blocks :: [(BlockId, jumpDest)]
-    (_, shortcut_blocks, others) =
-        foldl' split (setEmpty :: LabelSet, [], []) blocks
-    split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
-        | Just jd <- canShortcut ncgImpl insn
-        , Just dest <- getJumpDestBlockId ncgImpl jd
-        , not (has_info id)
-        , (setMember dest s) || dest == id -- loop checks
-        = (s, shortcut_blocks, b : others)
-    split (s, shortcut_blocks, others) (BasicBlock id [insn])
-        | Just dest <- canShortcut ncgImpl insn
-        , not (has_info id)
-        = (setInsert id s, (id,dest) : shortcut_blocks, others)
-    split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
-
-    -- do not eliminate blocks that have an info table
-    has_info l = mapMember l info
-
-    -- build a mapping from BlockId to JumpDest for shorting branches
-    mapping = mapFromList shortcut_blocks
-
-apply_mapping :: NcgImpl statics instr jumpDest
-              -> LabelMap jumpDest
-              -> GenCmmDecl statics h (ListGraph instr)
-              -> GenCmmDecl statics h (ListGraph instr)
-apply_mapping ncgImpl ufm (CmmData sec statics)
-  = CmmData sec (shortcutStatics ncgImpl (\bid -> mapLookup bid ufm) statics)
-apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks))
-  = CmmProc info lbl live (ListGraph $ map short_bb blocks)
-  where
-    short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
-    short_insn i = shortcutJump ncgImpl (\bid -> mapLookup bid ufm) i
-                 -- shortcutJump should apply the mapping repeatedly,
-                 -- just in case we can short multiple branches.
-
--- -----------------------------------------------------------------------------
--- Instruction selection
-
--- Native code instruction selection for a chunk of stix code.  For
--- this part of the computation, we switch from the UniqSM monad to
--- the NatM monad.  The latter carries not only a Unique, but also an
--- Int denoting the current C stack pointer offset in the generated
--- code; this is needed for creating correct spill offsets on
--- architectures which don't offer, or for which it would be
--- prohibitively expensive to employ, a frame pointer register.  Viz,
--- x86.
-
--- The offset is measured in bytes, and indicates the difference
--- between the current (simulated) C stack-ptr and the value it was at
--- the beginning of the block.  For stacks which grow down, this value
--- should be either zero or negative.
-
--- Along with the stack pointer offset, we also carry along a LabelMap of
--- DebugBlocks, which we read to generate .location directives.
---
--- Switching between the two monads whilst carrying along the same
--- Unique supply breaks abstraction.  Is that bad?
-
-genMachCode
-        :: NCGConfig
-        -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
-        -> DwarfFiles
-        -> LabelMap DebugBlock
-        -> RawCmmDecl
-        -> CFG
-        -> UniqSM
-                ( [NatCmmDecl statics instr]
-                , [CLabel]
-                , DwarfFiles
-                , CFG
-                )
-
-genMachCode config cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg
-  = do  { initial_us <- getUniqueSupplyM
-        ; let initial_st           = mkNatM_State initial_us 0 config
-                                                  fileIds dbgMap cmm_cfg
-              (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
-              final_delta          = natm_delta final_st
-              final_imports        = natm_imports final_st
-              final_cfg            = natm_cfg final_st
-        ; if   final_delta == 0
-          then return (new_tops, final_imports
-                      , natm_fileid final_st, final_cfg)
-          else pprPanic "genMachCode: nonzero final delta" (int final_delta)
-    }
-
--- -----------------------------------------------------------------------------
--- Generic Cmm optimiser
-
-{-
-Here we do:
-
-  (a) Constant folding
-  (c) Position independent code and dynamic linking
-        (i)  introduce the appropriate indirections
-             and position independent refs
-        (ii) compile a list of imported symbols
-  (d) Some arch-specific optimizations
-
-(a) will be moving to the new Hoopl pipeline, however, (c) and
-(d) are only needed by the native backend and will continue to live
-here.
-
-Ideas for other things we could do (put these in Hoopl please!):
-
-  - shortcut jumps-to-jumps
-  - simple CSE: if an expr is assigned to a temp, then replace later occs of
-    that expr with the temp, until the expr is no longer valid (can push through
-    temp assignments, and certain assigns to mem...)
--}
-
-cmmToCmm :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel])
-cmmToCmm _ top@(CmmData _ _) = (top, [])
-cmmToCmm config (CmmProc info lbl live graph)
-    = runCmmOpt config $
-      do blocks' <- mapM cmmBlockConFold (toBlockList graph)
-         return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')
-
-type OptMResult a = (# a, [CLabel] #)
-
-pattern OptMResult :: a -> b -> (# a, b #)
-pattern OptMResult x y = (# x, y #)
-{-# COMPLETE OptMResult #-}
-
-newtype CmmOptM a = CmmOptM (NCGConfig -> [CLabel] -> OptMResult a)
-    deriving (Functor)
-
-instance Applicative CmmOptM where
-    pure x = CmmOptM $ \_ imports -> OptMResult x imports
-    (<*>) = ap
-
-instance Monad CmmOptM where
-  (CmmOptM f) >>= g =
-    CmmOptM $ \config imports0 ->
-                case f config imports0 of
-                  OptMResult x imports1 ->
-                    case g x of
-                      CmmOptM g' -> g' config imports1
-
-instance CmmMakeDynamicReferenceM CmmOptM where
-    addImport = addImportCmmOpt
-
-addImportCmmOpt :: CLabel -> CmmOptM ()
-addImportCmmOpt lbl = CmmOptM $ \_ imports -> OptMResult () (lbl:imports)
-
-getCmmOptConfig :: CmmOptM NCGConfig
-getCmmOptConfig = CmmOptM $ \config imports -> OptMResult config imports
-
-runCmmOpt :: NCGConfig -> CmmOptM a -> (a, [CLabel])
-runCmmOpt config (CmmOptM f) =
-  case f config [] of
-    OptMResult result imports -> (result, imports)
-
-cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
-cmmBlockConFold block = do
-  let (entry, middle, last) = blockSplit block
-      stmts = blockToList middle
-  stmts' <- mapM cmmStmtConFold stmts
-  last' <- cmmStmtConFold last
-  return $ blockJoin entry (blockFromList stmts') last'
-
--- This does three optimizations, but they're very quick to check, so we don't
--- bother turning them off even when the Hoopl code is active.  Since
--- this is on the old Cmm representation, we can't reuse the code either:
---  * reg = reg      --> nop
---  * if 0 then jump --> nop
---  * if 1 then jump --> jump
--- We might be tempted to skip this step entirely of not Opt_PIC, but
--- there is some PowerPC code for the non-PIC case, which would also
--- have to be separated.
-cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x)
-cmmStmtConFold stmt
-   = case stmt of
-        CmmAssign reg src
-           -> do src' <- cmmExprConFold DataReference src
-                 return $ case src' of
-                   CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop")
-                   new_src -> CmmAssign reg new_src
-
-        CmmStore addr src align
-           -> do addr' <- cmmExprConFold DataReference addr
-                 src'  <- cmmExprConFold DataReference src
-                 return $ CmmStore addr' src' align
-
-        CmmCall { cml_target = addr }
-           -> do addr' <- cmmExprConFold JumpReference addr
-                 return $ stmt { cml_target = addr' }
-
-        CmmUnsafeForeignCall target regs args
-           -> do target' <- case target of
-                              ForeignTarget e conv -> do
-                                e' <- cmmExprConFold CallReference e
-                                return $ ForeignTarget e' conv
-                              PrimTarget _ ->
-                                return target
-                 args' <- mapM (cmmExprConFold DataReference) args
-                 return $ CmmUnsafeForeignCall target' regs args'
-
-        CmmCondBranch test true false likely
-           -> do test' <- cmmExprConFold DataReference test
-                 return $ case test' of
-                   CmmLit (CmmInt 0 _) -> CmmBranch false
-                   CmmLit (CmmInt _ _) -> CmmBranch true
-                   _other -> CmmCondBranch test' true false likely
-
-        CmmSwitch expr ids
-           -> do expr' <- cmmExprConFold DataReference expr
-                 return $ CmmSwitch expr' ids
-
-        other
-           -> return other
-
-cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
-cmmExprConFold referenceKind expr = do
-    config <- getCmmOptConfig
-
-    let expr' = if not (ncgDoConstantFolding config)
-                    then expr
-                    else cmmExprCon config expr
-
-    cmmExprNative referenceKind expr'
-
-cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr
-cmmExprCon config (CmmLoad addr rep align) = CmmLoad (cmmExprCon config addr) rep align
-cmmExprCon config (CmmMachOp mop args)
-    = cmmMachOpFold (ncgPlatform config) mop (map (cmmExprCon config) args)
-cmmExprCon _ other = other
-
--- handles both PIC and non-PIC cases... a very strange mixture
--- of things to do.
-cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
-cmmExprNative referenceKind expr = do
-     config <- getCmmOptConfig
-     let platform = ncgPlatform config
-         arch = platformArch platform
-     case expr of
-        CmmLoad addr rep align
-          -> do addr' <- cmmExprNative DataReference addr
-                return $ CmmLoad addr' rep align
-
-        CmmMachOp mop args
-          -> do args' <- mapM (cmmExprNative DataReference) args
-                return $ CmmMachOp mop args'
-
-        CmmLit (CmmBlock id)
-          -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))
-          -- we must convert block Ids to CLabels here, because we
-          -- might have to do the PIC transformation.  Hence we must
-          -- not modify BlockIds beyond this point.
-
-        CmmLit (CmmLabel lbl)
-          -> cmmMakeDynamicReference config referenceKind lbl
-        CmmLit (CmmLabelOff lbl off)
-          -> do dynRef <- cmmMakeDynamicReference config referenceKind lbl
-                -- need to optimize here, since it's late
-                return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [
-                    dynRef,
-                    (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform))
-                  ]
-
-        -- On powerpc (non-PIC), it's easier to jump directly to a label than
-        -- to use the register table, so we replace these registers
-        -- with the corresponding labels:
-        CmmReg (CmmGlobal EagerBlackholeInfo)
-          | arch == ArchPPC && not (ncgPIC config)
-          -> cmmExprNative referenceKind $
-             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))
-        CmmReg (CmmGlobal GCEnter1)
-          | arch == ArchPPC && not (ncgPIC config)
-          -> cmmExprNative referenceKind $
-             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))
-        CmmReg (CmmGlobal GCFun)
-          | arch == ArchPPC && not (ncgPIC config)
-          -> cmmExprNative referenceKind $
-             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))
-
-        other
-           -> return other
diff --git a/compiler/GHC/CmmToAsm/AArch64.hs b/compiler/GHC/CmmToAsm/AArch64.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/AArch64.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
--- | Native code generator for AArch64 architectures
-module GHC.CmmToAsm.AArch64
-   ( ncgAArch64 )
-where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.Instr
-import GHC.CmmToAsm.Monad
-import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Types
-import GHC.Utils.Outputable (ftext)
-
-import qualified GHC.CmmToAsm.AArch64.Instr   as AArch64
-import qualified GHC.CmmToAsm.AArch64.Ppr     as AArch64
-import qualified GHC.CmmToAsm.AArch64.CodeGen as AArch64
-import qualified GHC.CmmToAsm.AArch64.Regs    as AArch64
-import qualified GHC.CmmToAsm.AArch64.RegInfo as AArch64
-
-ncgAArch64 :: NCGConfig -> NcgImpl RawCmmStatics AArch64.Instr AArch64.JumpDest
-ncgAArch64 config
- = NcgImpl {
-        ncgConfig                 = config
-       ,cmmTopCodeGen             = AArch64.cmmTopCodeGen
-       ,generateJumpTableForInstr = AArch64.generateJumpTableForInstr config
-       ,getJumpDestBlockId        = AArch64.getJumpDestBlockId
-       ,canShortcut               = AArch64.canShortcut
-       ,shortcutStatics           = AArch64.shortcutStatics
-       ,shortcutJump              = AArch64.shortcutJump
-       ,pprNatCmmDeclS            = AArch64.pprNatCmmDecl config
-       ,pprNatCmmDeclH            = AArch64.pprNatCmmDecl config
-       ,maxSpillSlots             = AArch64.maxSpillSlots config
-       ,allocatableRegs           = AArch64.allocatableRegs platform
-       ,ncgAllocMoreStack         = AArch64.allocMoreStack platform
-       ,ncgMakeFarBranches        = const id
-       ,extractUnwindPoints       = const []
-       ,invertCondBranches        = \_ _ -> id
-  }
-    where
-      platform = ncgPlatform config
-
--- | Instruction instance for aarch64
-instance Instruction AArch64.Instr where
-        regUsageOfInstr         = AArch64.regUsageOfInstr
-        patchRegsOfInstr        = AArch64.patchRegsOfInstr
-        isJumpishInstr          = AArch64.isJumpishInstr
-        jumpDestsOfInstr        = AArch64.jumpDestsOfInstr
-        patchJumpInstr          = AArch64.patchJumpInstr
-        mkSpillInstr            = AArch64.mkSpillInstr
-        mkLoadInstr             = AArch64.mkLoadInstr
-        takeDeltaInstr          = AArch64.takeDeltaInstr
-        isMetaInstr             = AArch64.isMetaInstr
-        mkRegRegMoveInstr _     = AArch64.mkRegRegMoveInstr
-        takeRegRegMoveInstr     = AArch64.takeRegRegMoveInstr
-        mkJumpInstr             = AArch64.mkJumpInstr
-        mkStackAllocInstr       = AArch64.mkStackAllocInstr
-        mkStackDeallocInstr     = AArch64.mkStackDeallocInstr
-        mkComment               = pure . AArch64.COMMENT . ftext
-        pprInstr                = AArch64.pprInstr
diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
+++ /dev/null
@@ -1,1720 +0,0 @@
-{-# language GADTs #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE BinaryLiterals #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NumericUnderscores #-}
-module GHC.CmmToAsm.AArch64.CodeGen (
-      cmmTopCodeGen
-    , generateJumpTableForInstr
-)
-
-where
-
--- NCG stuff:
-import GHC.Prelude hiding (EQ)
-
-import Data.Word
-
-import GHC.Platform.Regs
-import GHC.CmmToAsm.AArch64.Instr
-import GHC.CmmToAsm.AArch64.Regs
-import GHC.CmmToAsm.AArch64.Cond
-
-import GHC.CmmToAsm.CPrim
-import GHC.Cmm.DebugBlock
-import GHC.CmmToAsm.Monad
-   ( NatM, getNewRegNat
-   , getPicBaseMaybeNat, getPlatform, getConfig
-   , getDebugBlock, getFileId
-   )
--- import GHC.CmmToAsm.Instr
-import GHC.CmmToAsm.PIC
-import GHC.CmmToAsm.Format
-import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Types
-import GHC.Platform.Reg
-import GHC.Platform
-
--- Our intermediate code:
-import GHC.Cmm.BlockId
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Cmm.Switch
-import GHC.Cmm.CLabel
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Graph
-import GHC.Types.Tickish ( GenTickish(..) )
-import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
-
--- The rest:
-import GHC.Data.OrdList
-import GHC.Utils.Outputable
-
-import Control.Monad    ( mapAndUnzipM, foldM )
-import Data.Maybe
-import GHC.Float
-
-import GHC.Types.Basic
-import GHC.Types.ForeignCall
-import GHC.Data.FastString
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Constants (debugIsOn)
-
--- Note [General layout of an NCG]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- @cmmTopCodeGen@ will be our main entry point to code gen.  Here we'll get
--- @RawCmmDecl@; see GHC.Cmm
---
---   RawCmmDecl = GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
---
---   GenCmmDecl d h g = CmmProc h CLabel [GlobalReg] g
---                    | CmmData Section d
---
--- As a result we want to transform this to a list of @NatCmmDecl@, which is
--- defined @GHC.CmmToAsm.Instr@ as
---
---   type NatCmmDecl statics instr
---        = GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr)
---
--- Thus well' turn
---   GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
--- into
---   [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) (ListGraph Instr)]
---
--- where @CmmGraph@ is
---
---   type CmmGraph = GenCmmGraph CmmNode
---   data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
---   type CmmBlock = Block CmmNode C C
---
--- and @ListGraph Instr@ is
---
---   newtype ListGraph i = ListGraph [GenBasicBlock i]
---   data GenBasicBlock i = BasicBlock BlockId [i]
-
-cmmTopCodeGen
-    :: RawCmmDecl
-    -> NatM [NatCmmDecl RawCmmStatics Instr]
-
--- Thus we'll have to deal with either CmmProc ...
-cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do
-  -- do
-  --   traceM $ "-- -------------------------- cmmTopGen (CmmProc) -------------------------- --\n"
-  --         ++ showSDocUnsafe (ppr cmm)
-
-  let blocks = toBlockListEntryFirst graph
-  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
-  picBaseMb <- getPicBaseMaybeNat
-
-  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
-      tops = proc : concat statics
-
-  case picBaseMb of
-      Just _picBase -> panic "AArch64.cmmTopCodeGen: picBase not implemented"
-      Nothing -> return tops
-
--- ... or CmmData.
-cmmTopCodeGen _cmm@(CmmData sec dat) = do
-  -- do
-  --   traceM $ "-- -------------------------- cmmTopGen (CmmData) -------------------------- --\n"
-  --         ++ showSDocUnsafe (ppr cmm)
-  return [CmmData sec dat] -- no translation, we just use CmmStatic
-
-basicBlockCodeGen
-        :: Block CmmNode C C
-        -> NatM ( [NatBasicBlock Instr]
-                , [NatCmmDecl RawCmmStatics Instr])
-
-basicBlockCodeGen block = do
-  config <- getConfig
-  -- do
-  --   traceM $ "-- --------------------------- basicBlockCodeGen --------------------------- --\n"
-  --         ++ showSDocUnsafe (ppr block)
-  let (_, nodes, tail)  = blockSplit block
-      id = entryLabel block
-      stmts = blockToList nodes
-
-      header_comment_instr | debugIsOn = unitOL $ MULTILINE_COMMENT (
-          text "-- --------------------------- basicBlockCodeGen --------------------------- --\n"
-          $+$ withPprStyle defaultDumpStyle (pdoc (ncgPlatform config) block)
-          )
-                           | otherwise = nilOL
-  -- Generate location directive
-  dbg <- getDebugBlock (entryLabel block)
-  loc_instrs <- case dblSourceTick =<< dbg of
-    Just (SourceNote span name)
-      -> do fileId <- getFileId (srcSpanFile span)
-            let line = srcSpanStartLine span; col = srcSpanStartCol span
-            return $ unitOL $ LOCATION fileId line col name
-    _ -> return nilOL
-  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts
-  (!tail_instrs,_) <- stmtToInstrs mid_bid tail
-  let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs
-  -- TODO: Then x86 backend run @verifyBasicBlock@ here and inserts
-  --      unwinding info. See Ticket 19913
-  -- code generation may introduce new basic block boundaries, which
-  -- are indicated by the NEWBLOCK instruction.  We must split up the
-  -- instruction stream into basic blocks again.  Also, we extract
-  -- LDATAs here too.
-  let
-        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
-
-        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
-          = ([], BasicBlock id instrs : blocks, statics)
-        mkBlocks (LDATA sec dat) (instrs,blocks,statics)
-          = (instrs, blocks, CmmData sec dat:statics)
-        mkBlocks instr (instrs,blocks,statics)
-          = (instr:instrs, blocks, statics)
-  return (BasicBlock id top : other_blocks, statics)
-
-
--- -----------------------------------------------------------------------------
--- | Utilities
-ann :: SDoc -> Instr -> Instr
-ann doc instr {- debugIsOn -} = ANN doc instr
--- ann _ instr = instr
-{-# INLINE ann #-}
-
--- Using pprExpr will hide the AST, @ANN@ will end up in the assembly with
--- -dppr-debug.  The idea is that we can trivially see how a cmm expression
--- ended up producing the assembly we see.  By having the verbatim AST printed
--- we can simply check the patterns that were matched to arrive at the assembly
--- we generated.
---
--- pprExpr will hide a lot of noise of the underlying data structure and print
--- the expression into something that can be easily read by a human. However
--- going back to the exact CmmExpr representation can be laborious and adds
--- indirections to find the matches that lead to the assembly.
---
--- An improvement oculd be to have
---
---    (pprExpr genericPlatform e) <> parens (text. show e)
---
--- to have the best of both worlds.
---
--- Note: debugIsOn is too restrictive, it only works for debug compilers.
--- However, we do not only want to inspect this for debug compilers. Ideally
--- we'd have a check for -dppr-debug here already, such that we don't even
--- generate the ANN expressions. However, as they are lazy, they shouldn't be
--- forced until we actually force them, and without -dppr-debug they should
--- never end up being forced.
-annExpr :: CmmExpr -> Instr -> Instr
-annExpr e instr {- debugIsOn -} = ANN (text . show $ e) instr
--- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr
--- annExpr _ instr = instr
-{-# INLINE annExpr #-}
-
--- -----------------------------------------------------------------------------
--- Generating a table-branch
-
--- TODO jump tables would be a lot faster, but we'll use bare bones for now.
--- this is usually done by sticking the jump table ids into an instruction
--- and then have the @generateJumpTableForInstr@ callback produce the jump
--- table as a static.
---
--- See Ticket 19912
---
--- data SwitchTargets =
---    SwitchTargets
---        Bool                       -- Signed values
---        (Integer, Integer)         -- Range
---        (Maybe Label)              -- Default value
---        (M.Map Integer Label)      -- The branches
---
--- Non Jumptable plan:
--- xE <- expr
---
-genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock
-genSwitch expr targets = do -- pprPanic "genSwitch" (ppr expr)
-  (reg, format, code) <- getSomeReg expr
-  let w = formatToWidth format
-  let mkbranch acc (key, bid) = do
-        (keyReg, _format, code) <- getSomeReg (CmmLit (CmmInt key w))
-        return $ code `appOL`
-                 toOL [ CMP (OpReg w reg) (OpReg w keyReg)
-                      , BCOND EQ (TBlock bid)
-                      ] `appOL` acc
-      def_code = case switchTargetsDefault targets of
-        Just bid -> unitOL (B (TBlock bid))
-        Nothing  -> nilOL
-
-  switch_code <- foldM mkbranch nilOL (switchTargetsCases targets)
-  return $ code `appOL` switch_code `appOL` def_code
-
--- We don't do jump tables for now, see Ticket 19912
-generateJumpTableForInstr :: NCGConfig -> Instr
-  -> Maybe (NatCmmDecl RawCmmStatics Instr)
-generateJumpTableForInstr _ _ = Nothing
-
--- -----------------------------------------------------------------------------
--- Top-level of the instruction selector
-
--- See Note [Keeping track of the current block] for why
--- we pass the BlockId.
-stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.
-              -> [CmmNode O O] -- ^ Cmm Statement
-              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction
-stmtsToInstrs bid stmts =
-    go bid stmts nilOL
-  where
-    go bid  []        instrs = return (instrs,bid)
-    go bid (s:stmts)  instrs = do
-      (instrs',bid') <- stmtToInstrs bid s
-      -- If the statement introduced a new block, we use that one
-      let !newBid = fromMaybe bid bid'
-      go newBid stmts (instrs `appOL` instrs')
-
--- | `bid` refers to the current block and is used to update the CFG
---   if new blocks are inserted in the control flow.
--- See Note [Keeping track of the current block] for more details.
-stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.
-             -> CmmNode e x
-             -> NatM (InstrBlock, Maybe BlockId)
-             -- ^ Instructions, and bid of new block if successive
-             -- statements are placed in a different basic block.
-stmtToInstrs bid stmt = do
-  -- traceM $ "-- -------------------------- stmtToInstrs -------------------------- --\n"
-  --     ++ showSDocUnsafe (ppr stmt)
-  platform <- getPlatform
-  case stmt of
-    CmmUnsafeForeignCall target result_regs args
-       -> genCCall target result_regs args bid
-
-    _ -> (,Nothing) <$> case stmt of
-      CmmComment s   -> return (unitOL (COMMENT (ftext s)))
-      CmmTick {}     -> return nilOL
-
-      CmmAssign reg src
-        | isFloatType ty         -> assignReg_FltCode format reg src
-        | otherwise              -> assignReg_IntCode format reg src
-          where ty = cmmRegType platform reg
-                format = cmmTypeFormat ty
-
-      CmmStore addr src _alignment
-        | isFloatType ty         -> assignMem_FltCode format addr src
-        | otherwise              -> assignMem_IntCode format addr src
-          where ty = cmmExprType platform src
-                format = cmmTypeFormat ty
-
-      CmmBranch id          -> genBranch id
-
-      --We try to arrange blocks such that the likely branch is the fallthrough
-      --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.
-      CmmCondBranch arg true false _prediction ->
-          genCondBranch bid true false arg
-
-      CmmSwitch arg ids -> genSwitch arg ids
-
-      CmmCall { cml_target = arg } -> genJump arg
-
-      CmmUnwind _regs -> return nilOL
-
-      _ -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt)
-
---------------------------------------------------------------------------------
--- | 'InstrBlock's are the insn sequences generated by the insn selectors.
---      They are really trees of insns to facilitate fast appending, where a
---      left-to-right traversal yields the insns in the correct order.
---
-type InstrBlock
-        = OrdList Instr
-
--- | Register's passed up the tree.  If the stix code forces the register
---      to live in a pre-decided machine register, it comes out as @Fixed@;
---      otherwise, it comes out as @Any@, and the parent can decide which
---      register to put it in.
---
-data Register
-        = Fixed Format Reg InstrBlock
-        | Any   Format (Reg -> InstrBlock)
-
--- | Sometimes we need to change the Format of a register. Primarily during
--- conversion.
-swizzleRegisterRep :: Format -> Register -> Register
-swizzleRegisterRep format (Fixed _ reg code) = Fixed format reg code
-swizzleRegisterRep format (Any _ codefn)     = Any   format codefn
-
--- | Grab the Reg for a CmmReg
-getRegisterReg :: Platform -> CmmReg -> Reg
-
-getRegisterReg _ (CmmLocal (LocalReg u pk))
-  = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)
-
-getRegisterReg platform (CmmGlobal mid)
-  = case globalRegMaybe platform mid of
-        Just reg -> RegReal reg
-        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
-        -- By this stage, the only MagicIds remaining should be the
-        -- ones which map to a real machine register on this
-        -- platform.  Hence if it's not mapped to a registers something
-        -- went wrong earlier in the pipeline.
--- | Convert a BlockId to some CmmStatic data
--- TODO: Add JumpTable Logic, see Ticket 19912
--- jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic
--- jumpTableEntry config Nothing   = CmmStaticLit (CmmInt 0 (ncgWordWidth config))
--- jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
---     where blockLabel = blockLbl blockid
-
--- -----------------------------------------------------------------------------
--- General things for putting together code sequences
-
--- | The dual to getAnyReg: compute an expression into a register, but
---      we don't mind which one it is.
-getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock)
-getSomeReg expr = do
-  r <- getRegister expr
-  case r of
-    Any rep code -> do
-        tmp <- getNewRegNat rep
-        return (tmp, rep, code tmp)
-    Fixed rep reg code ->
-        return (reg, rep, code)
-
--- TODO OPT: we might be able give getRegister
---          a hint, what kind of register we want.
-getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock)
-getFloatReg expr = do
-  r <- getRegister expr
-  case r of
-    Any rep code | isFloatFormat rep -> do
-      tmp <- getNewRegNat rep
-      return (tmp, rep, code tmp)
-    Any II32 code -> do
-      tmp <- getNewRegNat FF32
-      return (tmp, FF32, code tmp)
-    Any II64 code -> do
-      tmp <- getNewRegNat FF64
-      return (tmp, FF64, code tmp)
-    Any _w _code -> do
-      config <- getConfig
-      pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr)
-    -- can't do much for fixed.
-    Fixed rep reg code ->
-      return (reg, rep, code)
-
--- TODO: TODO, bounds. We can't put any immediate
--- value in. They are constrained.
--- See Ticket 19911
-litToImm' :: CmmLit -> NatM (Operand, InstrBlock)
-litToImm' lit = return (OpImm (litToImm lit), nilOL)
-
-getRegister :: CmmExpr -> NatM Register
-getRegister e = do
-  config <- getConfig
-  getRegister' config (ncgPlatform config) e
-
--- | The register width to be used for an operation on the given width
--- operand.
-opRegWidth :: Width -> Width
-opRegWidth W64 = W64  -- x
-opRegWidth W32 = W32  -- w
-opRegWidth W16 = W32  -- w
-opRegWidth W8  = W32  -- w
-opRegWidth w   = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)
-
--- Note [Signed arithmetic on AArch64]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Handling signed arithmetic on sub-word-size values on AArch64 is a bit
--- tricky as Cmm's type system does not capture signedness. While 32-bit values
--- are fairly easy to handle due to AArch64's 32-bit instruction variants
--- (denoted by use of %wN registers), 16- and 8-bit values require quite some
--- care.
---
--- We handle 16-and 8-bit values by using the 32-bit operations and
--- sign-/zero-extending operands and truncate results as necessary. For
--- simplicity we maintain the invariant that a register containing a
--- sub-word-size value always contains the zero-extended form of that value
--- in between operations.
---
--- For instance, consider the program,
---
---    test(bits64 buffer)
---      bits8 a = bits8[buffer];
---      bits8 b = %mul(a, 42);
---      bits8 c = %not(b);
---      bits8 d = %shrl(c, 4::bits8);
---      return (d);
---    }
---
--- This program begins by loading `a` from memory, for which we use a
--- zero-extended byte-size load.  We next sign-extend `a` to 32-bits, and use a
--- 32-bit multiplication to compute `b`, and truncate the result back down to
--- 8-bits.
---
--- Next we compute `c`: The `%not` requires no extension of its operands, but
--- we must still truncate the result back down to 8-bits. Finally the `%shrl`
--- requires no extension and no truncate since we can assume that
--- `c` is zero-extended.
---
--- TODO:
---   Don't use Width in Operands
---   Instructions should rather carry a RegWidth
---
--- Note [Handling PIC on AArch64]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- AArch64 does not have a special PIC register, the general approach is to
--- simply go through the GOT, and there is assembly support for this:
---
---   // Load the address of 'sym' from the GOT using ADRP and LDR (used for
---   // position-independent code on AArch64):
---   adrp x0, #:got:sym
---   ldr x0, [x0, #:got_lo12:sym]
---
--- See also: https://developer.arm.com/documentation/dui0774/i/armclang-integrated-assembler-directives/assembly-expressions
---
--- CmmGlobal @PicBaseReg@'s are generated in @GHC.CmmToAsm.PIC@ in the
--- @cmmMakePicReference@.  This is in turn called from @cmmMakeDynamicReference@
--- also in @Cmm.CmmToAsm.PIC@ from where it is also exported.  There are two
--- callsites for this. One is in this module to produce the @target@ in @genCCall@
--- the other is in @GHC.CmmToAsm@ in @cmmExprNative@.
---
--- Conceptually we do not want any special PicBaseReg to be used on AArch64. If
--- we want to distinguish between symbol loading, we need to address this through
--- the way we load it, not through a register.
---
-
-getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
--- OPTIMIZATION WARNING: CmmExpr rewrites
--- 1. Rewrite: Reg + (-n) => Reg - n
---    TODO: this expression shouldn't even be generated to begin with.
-getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt i w1)]) | i < 0
-  = getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt (-i) w1)])
-
-getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt i w1)]) | i < 0
-  = getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt (-i) w1)])
-
-
--- Generic case.
-getRegister' config plat expr
-  = case expr of
-    CmmReg (CmmGlobal PicBaseReg)
-      -> pprPanic "getRegisterReg-memory" (ppr $ PicBaseReg)
-    CmmLit lit
-      -> case lit of
-
-        -- TODO handle CmmInt 0 specially, use wzr or xzr.
-
-        CmmInt i W8 | i >= 0 -> do
-          return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i))))))
-        CmmInt i W16 | i >= 0 -> do
-          return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i))))))
-
-        CmmInt i W8  -> do
-          return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i))))))
-        CmmInt i W16 -> do
-          return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i))))))
-
-        -- We need to be careful to not shorten this for negative literals.
-        -- Those need the upper bits set. We'd either have to explicitly sign
-        -- or figure out something smarter. Lowered to
-        -- `MOV dst XZR`
-        CmmInt i w | isNbitEncodeable 16 i, i >= 0 -> do
-          return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger i)))))
-        CmmInt i w | isNbitEncodeable 32 i, i >= 0 -> do
-          let  half0 = fromIntegral (fromIntegral i :: Word16)
-               half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)
-          return (Any (intFormat w) (\dst -> toOL [ annExpr expr
-                                                  $ MOV (OpReg W32 dst) (OpImm (ImmInt half0))
-                                                  , MOVK (OpReg W32 dst) (OpImmShift (ImmInt half1) SLSL 16)
-                                                  ]))
-        -- fallback for W32
-        CmmInt i W32 -> do
-          let  half0 = fromIntegral (fromIntegral i :: Word16)
-               half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)
-          return (Any (intFormat W32) (\dst -> toOL [ annExpr expr
-                                                    $ MOV (OpReg W32 dst) (OpImm (ImmInt half0))
-                                                    , MOVK (OpReg W32 dst) (OpImmShift (ImmInt half1) SLSL 16)
-                                                    ]))
-        -- anything else
-        CmmInt i W64 -> do
-          let  half0 = fromIntegral (fromIntegral i :: Word16)
-               half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)
-               half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16)
-               half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16)
-          return (Any (intFormat W64) (\dst -> toOL [ annExpr expr
-                                                    $ MOV (OpReg W64 dst) (OpImm (ImmInt half0))
-                                                    , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half1) SLSL 16)
-                                                    , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half2) SLSL 32)
-                                                    , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half3) SLSL 48)
-                                                    ]))
-        CmmInt _i rep -> do
-          (op, imm_code) <- litToImm' lit
-          return (Any (intFormat rep) (\dst -> imm_code `snocOL` annExpr expr (MOV (OpReg rep dst) op)))
-
-        -- floatToBytes (fromRational f)
-        CmmFloat 0 w   -> do
-          (op, imm_code) <- litToImm' lit
-          return (Any (floatFormat w) (\dst -> imm_code `snocOL` annExpr expr (MOV (OpReg w dst) op)))
-
-        CmmFloat _f W8  -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for bytes" (pdoc plat expr)
-        CmmFloat _f W16 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for halfs" (pdoc plat expr)
-        CmmFloat f W32 -> do
-          let word = castFloatToWord32 (fromRational f) :: Word32
-              half0 = fromIntegral (fromIntegral word :: Word16)
-              half1 = fromIntegral (fromIntegral (word `shiftR` 16) :: Word16)
-          tmp <- getNewRegNat (intFormat W32)
-          return (Any (floatFormat W32) (\dst -> toOL [ annExpr expr
-                                                      $ MOV (OpReg W32 tmp) (OpImm (ImmInt half0))
-                                                      , MOVK (OpReg W32 tmp) (OpImmShift (ImmInt half1) SLSL 16)
-                                                      , MOV (OpReg W32 dst) (OpReg W32 tmp)
-                                                      ]))
-        CmmFloat f W64 -> do
-          let word = castDoubleToWord64 (fromRational f) :: Word64
-              half0 = fromIntegral (fromIntegral word :: Word16)
-              half1 = fromIntegral (fromIntegral (word `shiftR` 16) :: Word16)
-              half2 = fromIntegral (fromIntegral (word `shiftR` 32) :: Word16)
-              half3 = fromIntegral (fromIntegral (word `shiftR` 48) :: Word16)
-          tmp <- getNewRegNat (intFormat W64)
-          return (Any (floatFormat W64) (\dst -> toOL [ annExpr expr
-                                                      $ MOV (OpReg W64 tmp) (OpImm (ImmInt half0))
-                                                      , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half1) SLSL 16)
-                                                      , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half2) SLSL 32)
-                                                      , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half3) SLSL 48)
-                                                      , MOV (OpReg W64 dst) (OpReg W64 tmp)
-                                                      ]))
-        CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr)
-        CmmVec _ -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr)
-        CmmLabel _lbl -> do
-          (op, imm_code) <- litToImm' lit
-          let rep = cmmLitType plat lit
-              format = cmmTypeFormat rep
-          return (Any format (\dst -> imm_code `snocOL` (annExpr expr $ LDR format (OpReg (formatToWidth format) dst) op)))
-
-        CmmLabelOff _lbl off | isNbitEncodeable 12 (fromIntegral off) -> do
-          (op, imm_code) <- litToImm' lit
-          let rep = cmmLitType plat lit
-              format = cmmTypeFormat rep
-              -- width = typeWidth rep
-          return (Any format (\dst -> imm_code `snocOL` LDR format (OpReg (formatToWidth format) dst) op))
-
-        CmmLabelOff lbl off -> do
-          (op, imm_code) <- litToImm' (CmmLabel lbl)
-          let rep = cmmLitType plat lit
-              format = cmmTypeFormat rep
-              width = typeWidth rep
-          (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width)
-          return (Any format (\dst -> imm_code `appOL` off_code `snocOL` LDR format (OpReg (formatToWidth format) dst) op `snocOL` ADD (OpReg width dst) (OpReg width dst) (OpReg width off_r)))
-
-        CmmLabelDiffOff _ _ _ _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)
-        CmmBlock _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)
-        CmmHighStackMark -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)
-    CmmLoad mem rep _ -> do
-      Amode addr addr_code <- getAmode plat (typeWidth rep) mem
-      let format = cmmTypeFormat rep
-      return (Any format (\dst -> addr_code `snocOL` LDR format (OpReg (formatToWidth format) dst) (OpAddr addr)))
-    CmmStackSlot _ _
-      -> pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr)
-    CmmReg reg
-      -> return (Fixed (cmmTypeFormat (cmmRegType plat reg))
-                       (getRegisterReg plat reg)
-                       nilOL)
-    CmmRegOff reg off | isNbitEncodeable 12 (fromIntegral off) -> do
-      getRegister' config plat $
-            CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
-          where width = typeWidth (cmmRegType plat reg)
-
-    CmmRegOff reg off -> do
-      (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width)
-      (reg, _format, code) <- getSomeReg $ CmmReg reg
-      return $ Any (intFormat width) (\dst -> off_code `appOL` code `snocOL` ADD (OpReg width dst) (OpReg width reg) (OpReg width off_r))
-          where width = typeWidth (cmmRegType plat reg)
-
-
-
-    -- for MachOps, see GHC.Cmm.MachOp
-    -- For CmmMachOp, see GHC.Cmm.Expr
-    CmmMachOp op [e] -> do
-      (reg, _format, code) <- getSomeReg e
-      case op of
-        MO_Not w -> return $ Any (intFormat w) $ \dst ->
-            let w' = opRegWidth w
-             in code `snocOL`
-                MVN (OpReg w' dst) (OpReg w' reg) `appOL`
-                truncateReg w' w dst -- See Note [Signed arithmetic on AArch64]
-
-        MO_S_Neg w -> negate code w reg
-        MO_F_Neg w -> return $ Any (floatFormat w) (\dst -> code `snocOL` NEG (OpReg w dst) (OpReg w reg))
-
-        MO_SF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg))  -- (Signed ConVerT Float)
-        MO_FS_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from reg)) -- (float convert (-> zero) signed)
-
-        -- TODO this is very hacky
-        -- Note, UBFM and SBFM expect source and target register to be of the same size, so we'll use @max from to@
-        -- UBFM will set the high bits to 0. SBFM will copy the sign (sign extend).
-        MO_UU_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` UBFM (OpReg (max from to) dst) (OpReg (max from to) reg) (OpImm (ImmInt 0)) (toImm (min from to)))
-        MO_SS_Conv from to -> ss_conv from to reg code
-        MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` FCVT (OpReg to dst) (OpReg from reg))
-
-        -- Conversions
-        MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e
-
-        _ -> pprPanic "getRegister' (monadic CmmMachOp):" (pdoc plat expr)
-      where
-        toImm W8 =  (OpImm (ImmInt 7))
-        toImm W16 = (OpImm (ImmInt 15))
-        toImm W32 = (OpImm (ImmInt 31))
-        toImm W64 = (OpImm (ImmInt 63))
-        toImm W128 = (OpImm (ImmInt 127))
-        toImm W256 = (OpImm (ImmInt 255))
-        toImm W512 = (OpImm (ImmInt 511))
-
-        -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits
-        -- See Note [Signed arithmetic on AArch64].
-        negate code w reg = do
-            let w' = opRegWidth w
-            (reg', code_sx) <- signExtendReg w w' reg
-            return $ Any (intFormat w) $ \dst ->
-                code `appOL`
-                code_sx `snocOL`
-                NEG (OpReg w' dst) (OpReg w' reg') `appOL`
-                truncateReg w' w dst
-
-        ss_conv from to reg code =
-            let w' = opRegWidth (max from to)
-            in return $ Any (intFormat to) $ \dst ->
-                code `snocOL`
-                SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) `appOL`
-                -- At this point an 8- or 16-bit value would be sign-extended
-                -- to 32-bits. Truncate back down the final width.
-                truncateReg w' to dst
-
-    -- Dyadic machops:
-    --
-    -- The general idea is:
-    -- compute x<i> <- x
-    -- compute x<j> <- y
-    -- OP x<r>, x<i>, x<j>
-    --
-    -- TODO: for now we'll only implement the 64bit versions. And rely on the
-    --      fallthrough to alert us if things go wrong!
-    -- OPTIMIZATION WARNING: Dyadic CmmMachOp destructuring
-    -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg
-    CmmMachOp (MO_Add _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'
-    CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'
-    -- 1. Compute Reg +/- n directly.
-    --    For Add/Sub we can directly encode 12bits, or 12bits lsl #12.
-    CmmMachOp (MO_Add w) [(CmmReg reg), CmmLit (CmmInt n _)]
-      | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))
-      -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.
-      where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))
-            r' = getRegisterReg plat reg
-    CmmMachOp (MO_Sub w) [(CmmReg reg), CmmLit (CmmInt n _)]
-      | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))
-      -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.
-      where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))
-            r' = getRegisterReg plat reg
-
-    CmmMachOp (MO_U_Quot w) [x, y] | w == W8 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      (reg_y, _format_y, code_y) <- getSomeReg y
-      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (UXTB (OpReg w reg_y) (OpReg w reg_y)) `snocOL` (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
-    CmmMachOp (MO_U_Quot w) [x, y] | w == W16 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      (reg_y, _format_y, code_y) <- getSomeReg y
-      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (UXTH (OpReg w reg_y) (OpReg w reg_y)) `snocOL` (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
-
-    -- 2. Shifts. x << n, x >> n.
-    CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W32, 0 <= n, n < 32 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
-    CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W64, 0 <= n, n < 64 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
-
-    CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n)))))
-    CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      (reg_y, _format_y, code_y) <- getSomeReg y
-      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
-
-    CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n)))))
-    CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      (reg_y, _format_y, code_y) <- getSomeReg y
-      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
-
-    CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W32, 0 <= n, n < 32 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ASR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
-
-    CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W64, 0 <= n, n < 64 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ASR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
-
-
-    CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n)))))
-    CmmMachOp (MO_U_Shr w) [x, y] | w == W8 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      (reg_y, _format_y, code_y) <- getSomeReg y
-      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
-
-    CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n)))))
-    CmmMachOp (MO_U_Shr w) [x, y] | w == W16 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      (reg_y, _format_y, code_y) <- getSomeReg y
-      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))
-
-    CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W32, 0 <= n, n < 32 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
-
-    CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W64, 0 <= n, n < 64 -> do
-      (reg_x, _format_x, code_x) <- getSomeReg x
-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
-
-    -- 3. Logic &&, ||
-    CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (fromIntegral n) ->
-      return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))
-      where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))
-            r' = getRegisterReg plat reg
-
-    CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (fromIntegral n) ->
-      return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORR (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))
-      where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))
-            r' = getRegisterReg plat reg
-
-    -- Generic case.
-    CmmMachOp op [x, y] -> do
-      -- alright, so we have an operation, and two expressions. And we want to essentially do
-      -- ensure we get float regs (TODO(Ben): What?)
-      let withTempIntReg w op = OpReg w <$> getNewRegNat (intFormat w) >>= op
-          -- withTempFloatReg w op = OpReg w <$> getNewRegNat (floatFormat w) >>= op
-
-          -- A "plain" operation.
-          bitOp w op = do
-            -- compute x<m> <- x
-            -- compute x<o> <- y
-            -- <OP> x<n>, x<m>, x<o>
-            (reg_x, format_x, code_x) <- getSomeReg x
-            (reg_y, format_y, code_y) <- getSomeReg y
-            massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOp: incompatible"
-            return $ Any (intFormat w) (\dst ->
-                code_x `appOL`
-                code_y `appOL`
-                op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))
-
-          -- A (potentially signed) integer operation.
-          -- In the case of 8- and 16-bit signed arithmetic we must first
-          -- sign-extend both arguments to 32-bits.
-          -- See Note [Signed arithmetic on AArch64].
-          intOp is_signed w op = do
-              -- compute x<m> <- x
-              -- compute x<o> <- y
-              -- <OP> x<n>, x<m>, x<o>
-              (reg_x, format_x, code_x) <- getSomeReg x
-              (reg_y, format_y, code_y) <- getSomeReg y
-              massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"
-              -- This is the width of the registers on which the operation
-              -- should be performed.
-              let w' = opRegWidth w
-                  signExt r
-                    | not is_signed  = return (r, nilOL)
-                    | otherwise      = signExtendReg w w' r
-              (reg_x_sx, code_x_sx) <- signExt reg_x
-              (reg_y_sx, code_y_sx) <- signExt reg_y
-              return $ Any (intFormat w) $ \dst ->
-                  code_x `appOL`
-                  code_y `appOL`
-                  -- sign-extend both operands
-                  code_x_sx `appOL`
-                  code_y_sx `appOL`
-                  op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx) `appOL`
-                  truncateReg w' w dst -- truncate back to the operand's original width
-
-          floatOp w op = do
-            (reg_fx, format_x, code_fx) <- getFloatReg x
-            (reg_fy, format_y, code_fy) <- getFloatReg y
-            massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatOp: non-float"
-            return $ Any (floatFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy))
-
-          -- need a special one for conditionals, as they return ints
-          floatCond w op = do
-            (reg_fx, format_x, code_fx) <- getFloatReg x
-            (reg_fy, format_y, code_fy) <- getFloatReg y
-            massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatCond: non-float"
-            return $ Any (intFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy))
-
-      case op of
-        -- Integer operations
-        -- Add/Sub should only be Integer Options.
-        MO_Add w -> intOp False w (\d x y -> unitOL $ annExpr expr (ADD d x y))
-        -- TODO: Handle sub-word case
-        MO_Sub w -> intOp False w (\d x y -> unitOL $ annExpr expr (SUB d x y))
-
-        -- Note [CSET]
-        -- ~~~~~~~~~~~
-        -- Setting conditional flags: the architecture internally knows the
-        -- following flag bits.  And based on thsoe comparisons as in the
-        -- table below.
-        --
-        --    31  30  29  28
-        --  .---+---+---+---+-- - -
-        --  | N | Z | C | V |
-        --  '---+---+---+---+-- - -
-        --  Negative
-        --  Zero
-        --  Carry
-        --  oVerflow
-        --
-        --  .------+-------------------------------------+-----------------+----------.
-        --  | Code | Meaning                             | Flags           | Encoding |
-        --  |------+-------------------------------------+-----------------+----------|
-        --  |  EQ  | Equal                               | Z = 1           | 0000     |
-        --  |  NE  | Not Equal                           | Z = 0           | 0001     |
-        --  |  HI  | Unsigned Higher                     | C = 1 && Z = 0  | 1000     |
-        --  |  HS  | Unsigned Higher or Same             | C = 1           | 0010     |
-        --  |  LS  | Unsigned Lower or Same              | C = 0 || Z = 1  | 1001     |
-        --  |  LO  | Unsigned Lower                      | C = 0           | 0011     |
-        --  |  GT  | Signed Greater Than                 | Z = 0 && N = V  | 1100     |
-        --  |  GE  | Signed Greater Than or Equal        | N = V           | 1010     |
-        --  |  LE  | Signed Less Than or Equal           | Z = 1 || N /= V | 1101     |
-        --  |  LT  | Signed Less Than                    | N /= V          | 1011     |
-        --  |  CS  | Carry Set (Unsigned Overflow)       | C = 1           | 0010     |
-        --  |  CC  | Carry Clear (No Unsigned Overflow)  | C = 0           | 0011     |
-        --  |  VS  | Signed Overflow                     | V = 1           | 0110     |
-        --  |  VC  | No Signed Overflow                  | V = 0           | 0111     |
-        --  |  MI  | Minus, Negative                     | N = 1           | 0100     |
-        --  |  PL  | Plus, Positive or Zero (!)          | N = 0           | 0101     |
-        --  |  AL  | Always                              | Any             | 1110     |
-        --  |  NV  | Never                               | Any             | 1111     |
-        --- '-------------------------------------------------------------------------'
-
-        -- N.B. We needn't sign-extend sub-word size (in)equality comparisons
-        -- since we don't care about ordering.
-        MO_Eq w     -> bitOp w (\d x y -> toOL [ CMP x y, CSET d EQ ])
-        MO_Ne w     -> bitOp w (\d x y -> toOL [ CMP x y, CSET d NE ])
-
-        -- Signed multiply/divide
-        MO_Mul w          -> intOp True w (\d x y -> unitOL $ MUL d x y)
-        MO_S_MulMayOflo w -> do_mul_may_oflo w x y
-        MO_S_Quot w       -> intOp True w (\d x y -> unitOL $ SDIV d x y)
-
-        -- No native rem instruction. So we'll compute the following
-        -- Rd  <- Rx / Ry             | 2 <- 7 / 3      -- SDIV Rd Rx Ry
-        -- Rd' <- Rx - Rd * Ry        | 1 <- 7 - 2 * 3  -- MSUB Rd' Rd Ry Rx
-        --        |     '---|----------------|---'   |
-        --        |         '----------------|-------'
-        --        '--------------------------'
-        -- Note the swap in Rx and Ry.
-        MO_S_Rem w -> withTempIntReg w $ \t ->
-                      intOp True w (\d x y -> toOL [ SDIV t x y, MSUB d t y x ])
-
-        -- Unsigned multiply/divide
-        MO_U_Quot w -> intOp False w (\d x y -> unitOL $ UDIV d x y)
-        MO_U_Rem w  -> withTempIntReg w $ \t ->
-                       intOp False w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ])
-
-        -- Signed comparisons -- see Note [CSET]
-        MO_S_Ge w     -> intOp True  w (\d x y -> toOL [ CMP x y, CSET d SGE ])
-        MO_S_Le w     -> intOp True  w (\d x y -> toOL [ CMP x y, CSET d SLE ])
-        MO_S_Gt w     -> intOp True  w (\d x y -> toOL [ CMP x y, CSET d SGT ])
-        MO_S_Lt w     -> intOp True  w (\d x y -> toOL [ CMP x y, CSET d SLT ])
-
-        -- Unsigned comparisons
-        MO_U_Ge w     -> intOp False w (\d x y -> toOL [ CMP x y, CSET d UGE ])
-        MO_U_Le w     -> intOp False w (\d x y -> toOL [ CMP x y, CSET d ULE ])
-        MO_U_Gt w     -> intOp False w (\d x y -> toOL [ CMP x y, CSET d UGT ])
-        MO_U_Lt w     -> intOp False w (\d x y -> toOL [ CMP x y, CSET d ULT ])
-
-        -- Floating point arithmetic
-        MO_F_Add w   -> floatOp w (\d x y -> unitOL $ ADD d x y)
-        MO_F_Sub w   -> floatOp w (\d x y -> unitOL $ SUB d x y)
-        MO_F_Mul w   -> floatOp w (\d x y -> unitOL $ MUL d x y)
-        MO_F_Quot w  -> floatOp w (\d x y -> unitOL $ SDIV d x y)
-
-        -- Floating point comparison
-        MO_F_Eq w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d EQ ])
-        MO_F_Ne w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d NE ])
-
-        -- careful with the floating point operations.
-        -- SLE is effectively LE or unordered (NaN)
-        -- SLT is the same. ULE, and ULT will not return true for NaN.
-        -- This is a bit counter-intuitive. Don't let yourself be fooled by
-        -- the S/U prefix for floats, it's only meaningful for integers.
-        MO_F_Ge w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OGE ])
-        MO_F_Le w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLE ]) -- x <= y <=> y > x
-        MO_F_Gt w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OGT ])
-        MO_F_Lt w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLT ]) -- x < y <=> y >= x
-
-        -- Bitwise operations
-        MO_And   w -> bitOp w (\d x y -> unitOL $ AND d x y)
-        MO_Or    w -> bitOp w (\d x y -> unitOL $ ORR d x y)
-        MO_Xor   w -> bitOp w (\d x y -> unitOL $ EOR d x y)
-        MO_Shl   w -> intOp False w (\d x y -> unitOL $ LSL d x y)
-        MO_U_Shr w -> intOp False w (\d x y -> unitOL $ LSR d x y)
-        MO_S_Shr w -> intOp True  w (\d x y -> unitOL $ ASR d x y)
-
-        -- TODO
-
-        op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ (pprMachOp op) <+> text "in" <+> (pdoc plat expr)
-    CmmMachOp _op _xs
-      -> pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr)
-
-  where
-    isNbitEncodeable :: Int -> Integer -> Bool
-    isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)
-    -- This needs to check if n can be encoded as a bitmask immediate:
-    --
-    -- See https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly
-    --
-    isBitMaskImmediate :: Integer -> Bool
-    isBitMaskImmediate i = i `elem` [0b0000_0001, 0b0000_0010, 0b0000_0100, 0b0000_1000, 0b0001_0000, 0b0010_0000, 0b0100_0000, 0b1000_0000
-                                    ,0b0000_0011, 0b0000_0110, 0b0000_1100, 0b0001_1000, 0b0011_0000, 0b0110_0000, 0b1100_0000
-                                    ,0b0000_0111, 0b0000_1110, 0b0001_1100, 0b0011_1000, 0b0111_0000, 0b1110_0000
-                                    ,0b0000_1111, 0b0001_1110, 0b0011_1100, 0b0111_1000, 0b1111_0000
-                                    ,0b0001_1111, 0b0011_1110, 0b0111_1100, 0b1111_1000
-                                    ,0b0011_1111, 0b0111_1110, 0b1111_1100
-                                    ,0b0111_1111, 0b1111_1110
-                                    ,0b1111_1111]
-
-    -- N.B. MUL does not set the overflow flag.
-    do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
-    do_mul_may_oflo w@W64 x y = do
-        (reg_x, _format_x, code_x) <- getSomeReg x
-        (reg_y, _format_y, code_y) <- getSomeReg y
-        lo <- getNewRegNat II64
-        hi <- getNewRegNat II64
-        return $ Any (intFormat w) (\dst ->
-            code_x `appOL`
-            code_y `snocOL`
-            MUL (OpReg w lo) (OpReg w reg_x) (OpReg w reg_y) `snocOL`
-            SMULH (OpReg w hi) (OpReg w reg_x) (OpReg w reg_y) `snocOL`
-            CMP (OpReg w hi) (OpRegShift w lo SASR 63) `snocOL`
-            CSET (OpReg w dst) NE)
-    do_mul_may_oflo w x y = do
-        (reg_x, _format_x, code_x) <- getSomeReg x
-        (reg_y, _format_y, code_y) <- getSomeReg y
-        let tmp_w = case w of
-                      W32 -> W64
-                      W16 -> W32
-                      W8  -> W32
-                      _   -> panic "do_mul_may_oflo: impossible"
-        -- This will hold the product
-        tmp <- getNewRegNat (intFormat tmp_w)
-        let ext_mode = case w of
-                         W32 -> ESXTW
-                         W16 -> ESXTH
-                         W8  -> ESXTB
-                         _   -> panic "do_mul_may_oflo: impossible"
-            mul = case w of
-                    W32 -> SMULL
-                    W16 -> MUL
-                    W8  -> MUL
-                    _   -> panic "do_mul_may_oflo: impossible"
-        return $ Any (intFormat w) (\dst ->
-            code_x `appOL`
-            code_y `snocOL`
-            mul (OpReg tmp_w tmp) (OpReg w reg_x) (OpReg w reg_y) `snocOL`
-            CMP (OpReg tmp_w tmp) (OpRegExt tmp_w tmp ext_mode 0) `snocOL`
-            CSET (OpReg w dst) NE)
-
--- | Instructions to sign-extend the value in the given register from width @w@
--- up to width @w'@.
-signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
-signExtendReg w w' r =
-    case w of
-      W64 -> noop
-      W32
-        | w' == W32 -> noop
-        | otherwise -> extend SXTH
-      W16           -> extend SXTH
-      W8            -> extend SXTB
-      _             -> panic "intOp"
-  where
-    noop = return (r, nilOL)
-    extend instr = do
-        r' <- getNewRegNat II64
-        return (r', unitOL $ instr (OpReg w' r') (OpReg w' r))
-
--- | Instructions to truncate the value in the given register from width @w@
--- down to width @w'@.
-truncateReg :: Width -> Width -> Reg -> OrdList Instr
-truncateReg w w' r =
-    case w of
-      W64 -> nilOL
-      W32
-        | w' == W32 -> nilOL
-      _   -> unitOL $ UBFM (OpReg w r)
-                           (OpReg w r)
-                           (OpImm (ImmInt 0))
-                           (OpImm $ ImmInt $ widthInBits w' - 1)
-
--- -----------------------------------------------------------------------------
---  The 'Amode' type: Memory addressing modes passed up the tree.
-data Amode = Amode AddrMode InstrBlock
-
-getAmode :: Platform
-         -> Width     -- ^ width of loaded value
-         -> CmmExpr
-         -> NatM Amode
--- TODO: Specialize stuff we can destructure here.
-
--- OPTIMIZATION WARNING: Addressing modes.
--- Addressing options:
--- LDUR/STUR: imm9: -256 - 255
-getAmode platform _ (CmmRegOff reg off) | -256 <= off, off <= 255
-  = return $ Amode (AddrRegImm reg' off') nilOL
-    where reg' = getRegisterReg platform reg
-          off' = ImmInt off
--- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4
-getAmode platform W32 (CmmRegOff reg off)
-  | 0 <= off, off <= 16380, off `mod` 4 == 0
-  = return $ Amode (AddrRegImm reg' off') nilOL
-    where reg' = getRegisterReg platform reg
-          off' = ImmInt off
--- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8
-getAmode platform W64 (CmmRegOff reg off)
-  | 0 <= off, off <= 32760, off `mod` 8 == 0
-  = return $ Amode (AddrRegImm reg' off') nilOL
-    where reg' = getRegisterReg platform reg
-          off' = ImmInt off
-
--- For Stores we often see something like this:
--- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2)
--- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ]
--- for `n` in range.
-getAmode _platform _ (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')])
-  | -256 <= off, off <= 255
-  = do (reg, _format, code) <- getSomeReg expr
-       return $ Amode (AddrRegImm reg (ImmInteger off)) code
-
-getAmode _platform _ (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')])
-  | -256 <= -off, -off <= 255
-  = do (reg, _format, code) <- getSomeReg expr
-       return $ Amode (AddrRegImm reg (ImmInteger (-off))) code
-
--- Generic case
-getAmode _platform _ expr
-  = do (reg, _format, code) <- getSomeReg expr
-       return $ Amode (AddrReg reg) code
-
--- -----------------------------------------------------------------------------
--- Generating assignments
-
--- Assignments are really at the heart of the whole code generation
--- business.  Almost all top-level nodes of any real importance are
--- assignments, which correspond to loads, stores, or register
--- transfers.  If we're really lucky, some of the register transfers
--- will go away, because we can use the destination register to
--- complete the code generation for the right hand side.  This only
--- fails when the right hand side is forced into a fixed register
--- (e.g. the result of a call).
-
-assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
-assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
-
-assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
-assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
-
-assignMem_IntCode rep addrE srcE
-  = do
-    (src_reg, _format, code) <- getSomeReg srcE
-    platform <- getPlatform
-    let w = formatToWidth rep
-    Amode addr addr_code <- getAmode platform w addrE
-    return $ COMMENT (text "CmmStore" <+> parens (text (show addrE)) <+> parens (text (show srcE)))
-            `consOL` (code
-            `appOL` addr_code
-            `snocOL` STR rep (OpReg w src_reg) (OpAddr addr))
-
-assignReg_IntCode _ reg src
-  = do
-    platform <- getPlatform
-    let dst = getRegisterReg platform reg
-    r <- getRegister src
-    return $ case r of
-      Any _ code              -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` code dst
-      Fixed format freg fcode -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` (fcode `snocOL` MOV (OpReg (formatToWidth format) dst) (OpReg (formatToWidth format) freg))
-
--- Let's treat Floating point stuff
--- as integer code for now. Opaque.
-assignMem_FltCode = assignMem_IntCode
-assignReg_FltCode = assignReg_IntCode
-
--- -----------------------------------------------------------------------------
--- Jumps
-genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
-genJump expr@(CmmLit (CmmLabel lbl))
-  = return $ unitOL (annExpr expr (J (TLabel lbl)))
-
-genJump expr = do
-    (target, _format, code) <- getSomeReg expr
-    return (code `appOL` unitOL (annExpr expr (J (TReg target))))
-
--- -----------------------------------------------------------------------------
---  Unconditional branches
-genBranch :: BlockId -> NatM InstrBlock
-genBranch = return . toOL . mkJumpInstr
-
--- -----------------------------------------------------------------------------
--- Conditional branches
-genCondJump
-    :: BlockId
-    -> CmmExpr
-    -> NatM InstrBlock
-genCondJump bid expr = do
-    case expr of
-      -- Optimized == 0 case.
-      CmmMachOp (MO_Eq w) [x, CmmLit (CmmInt 0 _)] -> do
-        (reg_x, _format_x, code_x) <- getSomeReg x
-        return $ code_x `snocOL` (annExpr expr (CBZ (OpReg w reg_x) (TBlock bid)))
-
-      -- Optimized /= 0 case.
-      CmmMachOp (MO_Ne w) [x, CmmLit (CmmInt 0 _)] -> do
-        (reg_x, _format_x, code_x) <- getSomeReg x
-        return $ code_x `snocOL`  (annExpr expr (CBNZ (OpReg w reg_x) (TBlock bid)))
-
-      -- Generic case.
-      CmmMachOp mop [x, y] -> do
-
-        let ubcond w cmp = do
-                -- compute both sides.
-                (reg_x, _format_x, code_x) <- getSomeReg x
-                (reg_y, _format_y, code_y) <- getSomeReg y
-                let x' = OpReg w reg_x
-                    y' = OpReg w reg_y
-                return $ case w of
-                  W8  -> code_x `appOL` code_y `appOL` toOL [ UXTB x' x', UXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
-                  W16 -> code_x `appOL` code_y `appOL` toOL [ UXTH x' x', UXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
-                  _   -> code_x `appOL` code_y `appOL` toOL [                         CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
-
-            sbcond w cmp = do
-                -- compute both sides.
-                (reg_x, _format_x, code_x) <- getSomeReg x
-                (reg_y, _format_y, code_y) <- getSomeReg y
-                let x' = OpReg w reg_x
-                    y' = OpReg w reg_y
-                return $ case w of
-                  W8  -> code_x `appOL` code_y `appOL` toOL [ SXTB x' x', SXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
-                  W16 -> code_x `appOL` code_y `appOL` toOL [ SXTH x' x', SXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
-                  _   -> code_x `appOL` code_y `appOL` toOL [                         CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]
-
-            fbcond w cmp = do
-              -- ensure we get float regs
-              (reg_fx, _format_fx, code_fx) <- getFloatReg x
-              (reg_fy, _format_fy, code_fy) <- getFloatReg y
-              return $ code_fx `appOL` code_fy `snocOL` CMP (OpReg w reg_fx) (OpReg w reg_fy) `snocOL` (annExpr expr (BCOND cmp (TBlock bid)))
-
-        case mop of
-          MO_F_Eq w -> fbcond w EQ
-          MO_F_Ne w -> fbcond w NE
-
-          MO_F_Gt w -> fbcond w OGT
-          MO_F_Ge w -> fbcond w OGE
-          MO_F_Lt w -> fbcond w OLT
-          MO_F_Le w -> fbcond w OLE
-
-          MO_Eq w   -> sbcond w EQ
-          MO_Ne w   -> sbcond w NE
-
-          MO_S_Gt w -> sbcond w SGT
-          MO_S_Ge w -> sbcond w SGE
-          MO_S_Lt w -> sbcond w SLT
-          MO_S_Le w -> sbcond w SLE
-          MO_U_Gt w -> ubcond w UGT
-          MO_U_Ge w -> ubcond w UGE
-          MO_U_Lt w -> ubcond w ULT
-          MO_U_Le w -> ubcond w ULE
-          _ -> pprPanic "AArch64.genCondJump:case mop: " (text $ show expr)
-      _ -> pprPanic "AArch64.genCondJump: " (text $ show expr)
-
-
-genCondBranch
-    :: BlockId      -- the source of the jump
-    -> BlockId      -- the true branch target
-    -> BlockId      -- the false branch target
-    -> CmmExpr      -- the condition on which to branch
-    -> NatM InstrBlock -- Instructions
-
-genCondBranch _ true false expr = do
-  b1 <- genCondJump true expr
-  b2 <- genBranch false
-  return (b1 `appOL` b2)
-
--- -----------------------------------------------------------------------------
---  Generating C calls
-
--- Now the biggest nightmare---calls.  Most of the nastiness is buried in
--- @get_arg@, which moves the arguments to the correct registers/stack
--- locations.  Apart from that, the code is easy.
---
--- As per *convention*:
--- x0-x7:   (volatile) argument registers
--- x8:      (volatile) indirect result register / Linux syscall no
--- x9-x15:  (volatile) caller saved regs
--- x16,x17: (volatile) intra-procedure-call registers
--- x18:     (volatile) platform register. don't use for portability
--- x19-x28: (non-volatile) callee save regs
--- x29:     (non-volatile) frame pointer
--- x30:                    link register
--- x31:                    stack pointer / zero reg
---
--- Thus, this is what a c function will expect. Find the arguments in x0-x7,
--- anything above that on the stack.  We'll ignore c functions with more than
--- 8 arguments for now.  Sorry.
---
--- We need to make sure we preserve x9-x15, don't want to touch x16, x17.
-
--- Note [PLT vs GOT relocations]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- When linking objects together, we may need to lookup foreign references. That
--- is symbolic references to functions or values in other objects. When
--- compiling the object, we can not know where those elements will end up in
--- memory (relative to the current location). Thus the use of symbols. There
--- are two types of items we are interested, code segments we want to jump to
--- and continue execution there (functions, ...), and data items we want to look
--- up (strings, numbers, ...). For functions we can use the fact that we can use
--- an intermediate jump without visibility to the programs execution.  If we
--- want to jump to a function that is simply too far away to reach for the B/BL
--- instruction, we can create a small piece of code that loads the full target
--- address and jumps to that on demand. Say f wants to call g, however g is out
--- of range for a direct jump, we can create a function h in range for f, that
--- will load the address of g, and jump there. The area where we construct h
--- is called the Procedure Linking Table (PLT), we have essentially replaced
--- f -> g with f -> h -> g.  This is fine for function calls.  However if we
--- want to lookup values, this trick doesn't work, so we need something else.
--- We will instead reserve a slot in memory, and have a symbol pointing to that
--- slot. Now what we essentially do is, we reference that slot, and expect that
--- slot to hold the final resting address of the data we are interested in.
--- Thus what that symbol really points to is the location of the final data.
--- The block of memory where we hold all those slots is the Global Offset Table
--- (GOT).  Instead of x <- $foo, we now do y <- $fooPtr, and x <- [$y].
---
--- For JUMP/CALLs we have 26bits (+/- 128MB), for conditional branches we only
--- have 19bits (+/- 1MB).  Symbol lookups are also within +/- 1MB, thus for most
--- of the LOAD/STOREs we'd want to use adrp, and add to compute a value within
--- 4GB of the PC, and load that.  For anything outside of that range, we'd have
--- to go through the GOT.
---
---  adrp x0, <symbol>
---  add x0, :lo:<symbol>
---
--- will compute the address of <symbol> int x0 if <symbol> is within 4GB of the
--- PC.
---
--- If we want to get the slot in the global offset table (GOT), we can do this:
---
---   adrp x0, #:got:<symbol>
---   ldr x0, [x0, #:got_lo12:<symbol>]
---
--- this will compute the address anywhere in the addressable 64bit space into
--- x0, by loading the address from the GOT slot.
---
--- To actually get the value of <symbol>, we'd need to ldr x0, x0 still, which
--- for the first case can be optimized to use ldr x0, [x0, #:lo12:<symbol>]
--- instead of the add instruction.
---
--- As the memory model for AArch64 for PIC is considered to be +/- 4GB, we do
--- not need to go through the GOT, unless we want to address the full address
--- range within 64bit.
-
-genCCall
-    :: ForeignTarget      -- function to call
-    -> [CmmFormal]        -- where to put the result
-    -> [CmmActual]        -- arguments (of mixed type)
-    -> BlockId            -- The block we are in
-    -> NatM (InstrBlock, Maybe BlockId)
--- TODO: Specialize where we can.
--- Generic impl
-genCCall target dest_regs arg_regs bid = do
-  -- we want to pass arg_regs into allArgRegs
-  -- pprTraceM "genCCall target" (ppr target)
-  -- pprTraceM "genCCall formal" (ppr dest_regs)
-  -- pprTraceM "genCCall actual" (ppr arg_regs)
-
-  case target of
-    -- The target :: ForeignTarget call can either
-    -- be a foreign procedure with an address expr
-    -- and a calling convention.
-    ForeignTarget expr _cconv -> do
-      (call_target, call_target_code) <- case expr of
-        -- if this is a label, let's just directly to it.  This will produce the
-        -- correct CALL relocation for BL...
-        (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL)
-        -- ... if it's not a label--well--let's compute the expression into a
-        -- register and jump to that. See Note [PLT vs GOT relocations]
-        _ -> do (reg, _format, reg_code) <- getSomeReg expr
-                pure (TReg reg, reg_code)
-      -- compute the code and register logic for all arg_regs.
-      -- this will give us the format information to match on.
-      arg_regs' <- mapM getSomeReg arg_regs
-
-      -- Now this is stupid.  Our Cmm expressions doesn't carry the proper sizes
-      -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in
-      -- STG; this thenn breaks packing of stack arguments, if we need to pack
-      -- for the pcs, e.g. darwinpcs.  Option one would be to fix the Int type
-      -- in Cmm proper. Option two, which we choose here is to use extended Hint
-      -- information to contain the size information and use that when packing
-      -- arguments, spilled onto the stack.
-      let (_res_hints, arg_hints) = foreignTargetHints target
-          arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints
-
-      platform <- getPlatform
-      let packStack = platformOS platform == OSDarwin
-
-      (stackSpace', passRegs, passArgumentsCode) <- passArguments packStack allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL
-
-      -- if we pack the stack, we may need to adjust to multiple of 8byte.
-      -- if we don't pack the stack, it will always be multiple of 8.
-      let stackSpace = if stackSpace' `mod` 8 /= 0
-                       then 8 * (stackSpace' `div` 8 + 1)
-                       else stackSpace'
-
-      (returnRegs, readResultsCode)   <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL
-
-      let moveStackDown 0 = toOL [ PUSH_STACK_FRAME
-                                 , DELTA (-16) ]
-          moveStackDown i | odd i = moveStackDown (i + 1)
-          moveStackDown i = toOL [ PUSH_STACK_FRAME
-                                 , SUB (OpReg W64 (regSingle 31)) (OpReg W64 (regSingle 31)) (OpImm (ImmInt (8 * i)))
-                                 , DELTA (-8 * i - 16) ]
-          moveStackUp 0 = toOL [ POP_STACK_FRAME
-                               , DELTA 0 ]
-          moveStackUp i | odd i = moveStackUp (i + 1)
-          moveStackUp i = toOL [ ADD (OpReg W64 (regSingle 31)) (OpReg W64 (regSingle 31)) (OpImm (ImmInt (8 * i)))
-                               , POP_STACK_FRAME
-                               , DELTA 0 ]
-
-      let code =    call_target_code          -- compute the label (possibly into a register)
-            `appOL` moveStackDown (stackSpace `div` 8)
-            `appOL` passArgumentsCode         -- put the arguments into x0, ...
-            `appOL` (unitOL $ BL call_target passRegs returnRegs) -- branch and link.
-            `appOL` readResultsCode           -- parse the results into registers
-            `appOL` moveStackUp (stackSpace `div` 8)
-      return (code, Nothing)
-
-    PrimTarget MO_F32_Fabs
-      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
-        unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg
-    PrimTarget MO_F64_Fabs
-      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
-        unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg
-
-    -- or a possibly side-effecting machine operation
-    -- mop :: CallishMachOp (see GHC.Cmm.MachOp)
-    PrimTarget mop -> do
-      -- We'll need config to construct forien targets
-      case mop of
-        -- 64 bit float ops
-        MO_F64_Pwr   -> mkCCall "pow"
-
-        MO_F64_Sin   -> mkCCall "sin"
-        MO_F64_Cos   -> mkCCall "cos"
-        MO_F64_Tan   -> mkCCall "tan"
-
-        MO_F64_Sinh  -> mkCCall "sinh"
-        MO_F64_Cosh  -> mkCCall "cosh"
-        MO_F64_Tanh  -> mkCCall "tanh"
-
-        MO_F64_Asin  -> mkCCall "asin"
-        MO_F64_Acos  -> mkCCall "acos"
-        MO_F64_Atan  -> mkCCall "atan"
-
-        MO_F64_Asinh -> mkCCall "asinh"
-        MO_F64_Acosh -> mkCCall "acosh"
-        MO_F64_Atanh -> mkCCall "atanh"
-
-        MO_F64_Log   -> mkCCall "log"
-        MO_F64_Log1P -> mkCCall "log1p"
-        MO_F64_Exp   -> mkCCall "exp"
-        MO_F64_ExpM1 -> mkCCall "expm1"
-        MO_F64_Fabs  -> mkCCall "fabs"
-        MO_F64_Sqrt  -> mkCCall "sqrt"
-
-        -- 32 bit float ops
-        MO_F32_Pwr   -> mkCCall "powf"
-
-        MO_F32_Sin   -> mkCCall "sinf"
-        MO_F32_Cos   -> mkCCall "cosf"
-        MO_F32_Tan   -> mkCCall "tanf"
-        MO_F32_Sinh  -> mkCCall "sinhf"
-        MO_F32_Cosh  -> mkCCall "coshf"
-        MO_F32_Tanh  -> mkCCall "tanhf"
-        MO_F32_Asin  -> mkCCall "asinf"
-        MO_F32_Acos  -> mkCCall "acosf"
-        MO_F32_Atan  -> mkCCall "atanf"
-        MO_F32_Asinh -> mkCCall "asinhf"
-        MO_F32_Acosh -> mkCCall "acoshf"
-        MO_F32_Atanh -> mkCCall "atanhf"
-        MO_F32_Log   -> mkCCall "logf"
-        MO_F32_Log1P -> mkCCall "log1pf"
-        MO_F32_Exp   -> mkCCall "expf"
-        MO_F32_ExpM1 -> mkCCall "expm1f"
-        MO_F32_Fabs  -> mkCCall "fabsf"
-        MO_F32_Sqrt  -> mkCCall "sqrtf"
-
-        -- 64-bit primops
-        MO_I64_ToI   -> mkCCall "hs_int64ToInt"
-        MO_I64_FromI -> mkCCall "hs_intToInt64"
-        MO_W64_ToW   -> mkCCall "hs_word64ToWord"
-        MO_W64_FromW -> mkCCall "hs_wordToWord64"
-        MO_x64_Neg   -> mkCCall "hs_neg64"
-        MO_x64_Add   -> mkCCall "hs_add64"
-        MO_x64_Sub   -> mkCCall "hs_sub64"
-        MO_x64_Mul   -> mkCCall "hs_mul64"
-        MO_I64_Quot  -> mkCCall "hs_quotInt64"
-        MO_I64_Rem   -> mkCCall "hs_remInt64"
-        MO_W64_Quot  -> mkCCall "hs_quotWord64"
-        MO_W64_Rem   -> mkCCall "hs_remWord64"
-        MO_x64_And   -> mkCCall "hs_and64"
-        MO_x64_Or    -> mkCCall "hs_or64"
-        MO_x64_Xor   -> mkCCall "hs_xor64"
-        MO_x64_Not   -> mkCCall "hs_not64"
-        MO_x64_Shl   -> mkCCall "hs_uncheckedShiftL64"
-        MO_I64_Shr   -> mkCCall "hs_uncheckedIShiftRA64"
-        MO_W64_Shr   -> mkCCall "hs_uncheckedShiftRL64"
-        MO_x64_Eq    -> mkCCall "hs_eq64"
-        MO_x64_Ne    -> mkCCall "hs_ne64"
-        MO_I64_Ge    -> mkCCall "hs_geInt64"
-        MO_I64_Gt    -> mkCCall "hs_gtInt64"
-        MO_I64_Le    -> mkCCall "hs_leInt64"
-        MO_I64_Lt    -> mkCCall "hs_ltInt64"
-        MO_W64_Ge    -> mkCCall "hs_geWord64"
-        MO_W64_Gt    -> mkCCall "hs_gtWord64"
-        MO_W64_Le    -> mkCCall "hs_leWord64"
-        MO_W64_Lt    -> mkCCall "hs_ltWord64"
-
-        -- Conversion
-        MO_UF_Conv w        -> mkCCall (word2FloatLabel w)
-
-        -- Arithmatic
-        -- These are not supported on X86, so I doubt they are used much.
-        MO_S_Mul2     _w -> unsupported mop
-        MO_S_QuotRem  _w -> unsupported mop
-        MO_U_QuotRem  _w -> unsupported mop
-        MO_U_QuotRem2 _w -> unsupported mop
-        MO_Add2       _w -> unsupported mop
-        MO_AddWordC   _w -> unsupported mop
-        MO_SubWordC   _w -> unsupported mop
-        MO_AddIntC    _w -> unsupported mop
-        MO_SubIntC    _w -> unsupported mop
-        MO_U_Mul2     _w -> unsupported mop
-
-        -- Memory Ordering
-        -- TODO DMBSY is probably *way* too much!
-        MO_ReadBarrier      ->  return (unitOL DMBSY, Nothing)
-        MO_WriteBarrier     ->  return (unitOL DMBSY, Nothing)
-        MO_Touch            ->  return (nilOL, Nothing) -- Keep variables live (when using interior pointers)
-        -- Prefetch
-        MO_Prefetch_Data _n -> return (nilOL, Nothing) -- Prefetch hint.
-
-        -- Memory copy/set/move/cmp, with alignment for optimization
-
-        -- TODO Optimize and use e.g. quad registers to move memory around instead
-        -- of offloading this to memcpy. For small memcpys we can utilize
-        -- the 128bit quad registers in NEON to move block of bytes around.
-        -- Might also make sense of small memsets? Use xzr? What's the function
-        -- call overhead?
-        MO_Memcpy  _align   -> mkCCall "memcpy"
-        MO_Memset  _align   -> mkCCall "memset"
-        MO_Memmove _align   -> mkCCall "memmove"
-        MO_Memcmp  _align   -> mkCCall "memcmp"
-
-        MO_SuspendThread    -> mkCCall "suspendThread"
-        MO_ResumeThread     -> mkCCall "resumeThread"
-
-        MO_PopCnt w         -> mkCCall (popCntLabel w)
-        MO_Pdep w           -> mkCCall (pdepLabel w)
-        MO_Pext w           -> mkCCall (pextLabel w)
-        MO_Clz w            -> mkCCall (clzLabel w)
-        MO_Ctz w            -> mkCCall (ctzLabel w)
-        MO_BSwap w          -> mkCCall (bSwapLabel w)
-        MO_BRev w           -> mkCCall (bRevLabel w)
-
-        -- -- Atomic read-modify-write.
-        MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)
-        MO_AtomicRead w     -> mkCCall (atomicReadLabel w)
-        MO_AtomicWrite w    -> mkCCall (atomicWriteLabel w)
-        MO_Cmpxchg w        -> mkCCall (cmpxchgLabel w)
-        -- -- Should be an AtomicRMW variant eventually.
-        -- -- Sequential consistent.
-        -- TODO: this should be implemented properly!
-        MO_Xchg w           -> mkCCall (xchgLabel w)
-
-  where
-    unsupported :: Show a => a -> b
-    unsupported mop = panic ("outOfLineCmmOp: " ++ show mop
-                          ++ " not supported here")
-    mkCCall :: FastString -> NatM (InstrBlock, Maybe BlockId)
-    mkCCall name = do
-      config <- getConfig
-      target <- cmmMakeDynamicReference config CallReference $
-          mkForeignLabel name Nothing ForeignLabelInThisPackage IsFunction
-      let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn
-      genCCall (ForeignTarget target cconv) dest_regs arg_regs bid
-
-    -- TODO: Optimize using paired stores and loads (STP, LDP). It is
-    -- automatically done by the allocator for us. However it's not optimal,
-    -- as we'd rather want to have control over
-    --     all spill/load registers, so we can optimize with instructions like
-    --       STP xA, xB, [sp, #-16]!
-    --     and
-    --       LDP xA, xB, sp, #16
-    --
-    passArguments :: Bool -> [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)
-    passArguments _packStack _ _ [] stackSpace accumRegs accumCode = return (stackSpace, accumRegs, accumCode)
-    -- passArguments _ _ [] accumCode stackSpace | isEven stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * stackSpace))
-    -- passArguments _ _ [] accumCode stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * (stackSpace + 1)))
-    -- passArguments [] fpRegs (arg0:arg1:args) stack accumCode = do
-    --   -- allocate this on the stack
-    --   (r0, format0, code_r0) <- getSomeReg arg0
-    --   (r1, format1, code_r1) <- getSomeReg arg1
-    --   let w0 = formatToWidth format0
-    --       w1 = formatToWidth format1
-    --       stackCode = unitOL $ STP (OpReg w0 r0) (OpReg w1 R1), (OpAddr (AddrRegImm x31 (ImmInt (stackSpace * 8)))
-    --   passArguments gpRegs (fpReg:fpRegs) args (stackCode `appOL` accumCode)
-
-      -- float promotion.
-      -- According to
-      --  ISO/IEC 9899:2018
-      --  Information technology — Programming languages — C
-      --
-      -- e.g.
-      -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1124.pdf
-      -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1256.pdf
-      --
-      -- GHC would need to know the prototype.
-      --
-      -- > If the expression that denotes the called function has a type that does not include a
-      -- > prototype, the integer promotions are performed on each argument, and arguments that
-      -- > have type float are promoted to double.
-      --
-      -- As we have no way to get prototypes for C yet, we'll *not* promote this
-      -- which is in line with the x86_64 backend :(
-      --
-      -- See the encode_values.cmm test.
-      --
-      -- We would essentially need to insert an FCVT (OpReg W64 fpReg) (OpReg W32 fpReg)
-      -- if w == W32.  But *only* if we don't have a prototype m(
-      --
-      -- For AArch64 specificies see: https://developer.arm.com/docs/ihi0055/latest/procedure-call-standard-for-the-arm-64-bit-architecture
-      --
-    -- Still have GP regs, and we want to pass an GP argument.
-
-    -- AArch64-Darwin: stack packing and alignment
-    --
-    -- According to the "Writing ARM64 Code for Apple Platforms" document form
-    -- Apple, specifically the section "Handle Data Types and Data Alignment Properly"
-    -- we need to not only pack, but also align arguments on the stack.
-    --
-    -- Data type   Size (in bytes)   Natural alignment (in bytes)
-    -- BOOL, bool  1                 1
-    -- char        1                 1
-    -- short       2                 2
-    -- int         4                 4
-    -- long        8                 8
-    -- long long   8                 8
-    -- pointer     8                 8
-    -- size_t      8                 8
-    -- NSInteger   8                 8
-    -- CFIndex     8                 8
-    -- fpos_t      8                 8
-    -- off_t       8                 8
-    --
-    -- We can see that types are aligned by their sizes so the easiest way to
-    -- guarantee alignment during packing seems to be to pad to a multiple of the
-    -- size we want to pack. Failure to get this right can result in pretty
-    -- subtle bugs, e.g. #20137.
-
-    passArguments pack (gpReg:gpRegs) fpRegs ((r, format, hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do
-      platform <- getPlatform
-      let w = formatToWidth format
-          mov
-            -- Specifically, Darwin/AArch64's ABI requires that the caller
-            -- sign-extend arguments which are smaller than 32-bits.
-            | w < W32
-            , platformCConvNeedsExtension platform
-            , SignedHint <- hint
-            = case w of
-                W8  -> SXTB (OpReg W64 gpReg) (OpReg w r)
-                W16 -> SXTH (OpReg W64 gpReg) (OpReg w r)
-                _   -> panic "impossible"
-            | otherwise
-            = MOV (OpReg w gpReg) (OpReg w r)
-          accumCode' = accumCode `appOL`
-                       code_r `snocOL`
-                       ann (text "Pass gp argument: " <> ppr r) mov
-      passArguments pack gpRegs fpRegs args stackSpace (gpReg:accumRegs) accumCode'
-
-    -- Still have FP regs, and we want to pass an FP argument.
-    passArguments pack gpRegs (fpReg:fpRegs) ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do
-      let w = formatToWidth format
-          mov = MOV (OpReg w fpReg) (OpReg w r)
-          accumCode' = accumCode `appOL`
-                       code_r `snocOL`
-                       ann (text "Pass fp argument: " <> ppr r) mov
-      passArguments pack gpRegs fpRegs args stackSpace (fpReg:accumRegs) accumCode'
-
-    -- No mor regs left to pass. Must pass on stack.
-    passArguments pack [] [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode = do
-      let w = formatToWidth format
-          bytes = widthInBits w `div` 8
-          space = if pack then bytes else 8
-          stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space)
-                      | otherwise                           = stackSpace
-          str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace')))
-          stackCode = code_r `snocOL`
-                      ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str
-      passArguments pack [] [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode)
-
-    -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.
-    passArguments pack [] fpRegs ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do
-      let w = formatToWidth format
-          bytes = widthInBits w `div` 8
-          space = if pack then bytes else 8
-          stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space)
-                      | otherwise                           = stackSpace
-          str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace')))
-          stackCode = code_r `snocOL`
-                      ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str
-      passArguments pack [] fpRegs args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode)
-
-    -- Still have gpRegs left, but want to pass a FP argument. Must be passed on the stack then.
-    passArguments pack gpRegs [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do
-      let w = formatToWidth format
-          bytes = widthInBits w `div` 8
-          space = if pack then bytes else 8
-          stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space)
-                      | otherwise                           = stackSpace
-          str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace')))
-          stackCode = code_r `snocOL`
-                      ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str
-      passArguments pack gpRegs [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode)
-
-    passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")
-
-    readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM ([Reg], InstrBlock)
-    readResults _ _ [] accumRegs accumCode = return (accumRegs, accumCode)
-    readResults [] _ _ _ _ = do
-      platform <- getPlatform
-      pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target)
-    readResults _ [] _ _ _ = do
-      platform <- getPlatform
-      pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target)
-    readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do
-      -- gp/fp reg -> dst
-      platform <- getPlatform
-      let rep = cmmRegType platform (CmmLocal dst)
-          format = cmmTypeFormat rep
-          w   = cmmRegWidth platform (CmmLocal dst)
-          r_dst = getRegisterReg platform (CmmLocal dst)
-      if isFloatFormat format
-        then readResults (gpReg:gpRegs) fpRegs dsts (fpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg))
-        else readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg))
-
-    unaryFloatOp w op arg_reg dest_reg = do
-      platform <- getPlatform
-      (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg
-      let dst = getRegisterReg platform (CmmLocal dest_reg)
-      let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx)
-      return (code, Nothing)
diff --git a/compiler/GHC/CmmToAsm/AArch64/Cond.hs b/compiler/GHC/CmmToAsm/AArch64/Cond.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/AArch64/Cond.hs
+++ /dev/null
@@ -1,66 +0,0 @@
-module GHC.CmmToAsm.AArch64.Cond  where
-
-import GHC.Prelude
-
--- https://developer.arm.com/documentation/den0024/a/the-a64-instruction-set/data-processing-instructions/conditional-instructions
-
--- TODO: This appears to go a bit overboard? Maybe we should stick with what LLVM
--- settled on for fcmp?
--- false: always yields false, regardless of operands.
--- oeq: yields true if both operands are not a QNAN and op1 is equal to op2.
--- ogt: yields true if both operands are not a QNAN and op1 is greater than op2.
--- oge: yields true if both operands are not a QNAN and op1 is greater than or equal to op2.
--- olt: yields true if both operands are not a QNAN and op1 is less than op2.
--- ole: yields true if both operands are not a QNAN and op1 is less than or equal to op2.
--- one: yields true if both operands are not a QNAN and op1 is not equal to op2.
--- ord: yields true if both operands are not a QNAN.
--- ueq: yields true if either operand is a QNAN or op1 is equal to op2.
--- ugt: yields true if either operand is a QNAN or op1 is greater than op2.
--- uge: yields true if either operand is a QNAN or op1 is greater than or equal to op2.
--- ult: yields true if either operand is a QNAN or op1 is less than op2.
--- ule: yields true if either operand is a QNAN or op1 is less than or equal to op2.
--- une: yields true if either operand is a QNAN or op1 is not equal to op2.
--- uno: yields true if either operand is a QNAN.
--- true: always yields true, regardless of operands.
---
--- LLVMs icmp knows about:
--- eq: yields true if the operands are equal, false otherwise. No sign interpretation is necessary or performed.
--- ne: yields true if the operands are unequal, false otherwise. No sign interpretation is necessary or performed.
--- ugt: interprets the operands as unsigned values and yields true if op1 is greater than op2.
--- uge: interprets the operands as unsigned values and yields true if op1 is greater than or equal to op2.
--- ult: interprets the operands as unsigned values and yields true if op1 is less than op2.
--- ule: interprets the operands as unsigned values and yields true if op1 is less than or equal to op2.
--- sgt: interprets the operands as signed values and yields true if op1 is greater than op2.
--- sge: interprets the operands as signed values and yields true if op1 is greater than or equal to op2.
--- slt: interprets the operands as signed values and yields true if op1 is less than op2.
--- sle: interprets the operands as signed values and yields true if op1 is less than or equal to op2.
-
-data Cond
-    = ALWAYS -- b.al
-    | EQ     -- b.eq
-    | NE     -- b.ne
-    -- signed
-    | SLT    -- b.lt
-    | SLE    -- b.le
-    | SGE    -- b.ge
-    | SGT    -- b.gt
-    -- unsigned
-    | ULT    -- b.lo
-    | ULE    -- b.ls
-    | UGE    -- b.hs
-    | UGT    -- b.hi
-    -- ordered
-    | OLT    -- b.mi
-    | OLE    -- b.ls
-    | OGE    -- b.ge
-    | OGT    -- b.gt
-    -- unordered
-    | UOLT   -- b.lt
-    | UOLE   -- b.le
-    | UOGE   -- b.pl
-    | UOGT   -- b.hi
-    -- others
-    | NEVER  -- b.nv
-    | VS     -- oVerflow set
-    | VC     -- oVerflow clear
-    deriving Eq
diff --git a/compiler/GHC/CmmToAsm/AArch64/Instr.hs b/compiler/GHC/CmmToAsm/AArch64/Instr.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/AArch64/Instr.hs
+++ /dev/null
@@ -1,776 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module GHC.CmmToAsm.AArch64.Instr
-
-where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.AArch64.Cond
-import GHC.CmmToAsm.AArch64.Regs
-
-import GHC.CmmToAsm.Instr (RegUsage(..))
-import GHC.CmmToAsm.Format
-import GHC.CmmToAsm.Types
-import GHC.CmmToAsm.Utils
-import GHC.CmmToAsm.Config
-import GHC.Platform.Reg
-
-import GHC.Platform.Regs
-import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm
-import GHC.Cmm.CLabel
-import GHC.Utils.Outputable
-import GHC.Platform
-import GHC.Types.Unique.Supply
-
-import GHC.Utils.Panic
-
-import Data.Maybe (fromMaybe)
-
-import GHC.Stack
-
--- | TODO: verify this!
-stackFrameHeaderSize :: Platform -> Int
-stackFrameHeaderSize _ = 64
-
--- | All registers are 8 byte wide.
-spillSlotSize :: Int
-spillSlotSize = 8
-
--- | The number of bytes that the stack pointer should be aligned
--- to.
-stackAlign :: Int
-stackAlign = 16
-
--- | The number of spill slots available without allocating more.
-maxSpillSlots :: NCGConfig -> Int
-maxSpillSlots config
---  = 0 -- set to zero, to see when allocMoreStack has to fire.
-    = let platform = ncgPlatform config
-      in ((ncgSpillPreallocSize config - stackFrameHeaderSize platform)
-         `div` spillSlotSize) - 1
-
--- | Convert a spill slot number to a *byte* offset, with no sign.
-spillSlotToOffset :: NCGConfig -> Int -> Int
-spillSlotToOffset config slot
-   = stackFrameHeaderSize (ncgPlatform config) + spillSlotSize * slot
-
--- | Get the registers that are being used by this instruction.
--- regUsage doesn't need to do any trickery for jumps and such.
--- Just state precisely the regs read and written by that insn.
--- The consequences of control flow transfers, as far as register
--- allocation goes, are taken care of by the register allocator.
---
--- RegUsage = RU [<read regs>] [<write regs>]
-
-instance Outputable RegUsage where
-    ppr (RU reads writes) = text "RegUsage(reads:" <+> ppr reads <> comma <+> text "writes:" <+> ppr writes <> char ')'
-
-regUsageOfInstr :: Platform -> Instr -> RegUsage
-regUsageOfInstr platform instr = case instr of
-  ANN _ i                  -> regUsageOfInstr platform i
-  -- 1. Arithmetic Instructions ------------------------------------------------
-  ADD dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)
-  CMN l r                  -> usage (regOp l ++ regOp r, [])
-  CMP l r                  -> usage (regOp l ++ regOp r, [])
-  MSUB dst src1 src2 src3  -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)
-  MUL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)
-  NEG dst src              -> usage (regOp src, regOp dst)
-  SMULH dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)
-  SMULL dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)
-  SDIV dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)
-  SUB dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)
-  UDIV dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)
-
-  -- 2. Bit Manipulation Instructions ------------------------------------------
-  SBFM dst src _ _         -> usage (regOp src, regOp dst)
-  UBFM dst src _ _         -> usage (regOp src, regOp dst)
-  SBFX dst src _ _         -> usage (regOp src, regOp dst)
-  UBFX dst src _ _         -> usage (regOp src, regOp dst)
-  SXTB dst src             -> usage (regOp src, regOp dst)
-  UXTB dst src             -> usage (regOp src, regOp dst)
-  SXTH dst src             -> usage (regOp src, regOp dst)
-  UXTH dst src             -> usage (regOp src, regOp dst)
-  -- 3. Logical and Move Instructions ------------------------------------------
-  AND dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)
-  ASR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)
-  BIC dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)
-  BICS dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)
-  EON dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)
-  EOR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)
-  LSL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)
-  LSR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)
-  MOV dst src              -> usage (regOp src, regOp dst)
-  MOVK dst src             -> usage (regOp src, regOp dst)
-  MVN dst src              -> usage (regOp src, regOp dst)
-  ORR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)
-  ROR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)
-  TST src1 src2            -> usage (regOp src1 ++ regOp src2, [])
-  -- 4. Branch Instructions ----------------------------------------------------
-  J t                      -> usage (regTarget t, [])
-  B t                      -> usage (regTarget t, [])
-  BCOND _ t                -> usage (regTarget t, [])
-  BL t ps _rs              -> usage (regTarget t ++ ps, callerSavedRegisters)
-
-  -- 5. Atomic Instructions ----------------------------------------------------
-  -- 6. Conditional Instructions -----------------------------------------------
-  CSET dst _               -> usage ([], regOp dst)
-  CBZ src _                -> usage (regOp src, [])
-  CBNZ src _               -> usage (regOp src, [])
-  -- 7. Load and Store Instructions --------------------------------------------
-  STR _ src dst            -> usage (regOp src ++ regOp dst, [])
-  LDR _ dst src            -> usage (regOp src, regOp dst)
-  -- TODO is this right? see STR, which I'm only partial about being right?
-  STP _ src1 src2 dst      -> usage (regOp src1 ++ regOp src2 ++ regOp dst, [])
-  LDP _ dst1 dst2 src      -> usage (regOp src, regOp dst1 ++ regOp dst2)
-
-  -- 8. Synchronization Instructions -------------------------------------------
-  DMBSY                    -> usage ([], [])
-
-  -- 9. Floating Point Instructions --------------------------------------------
-  FCVT dst src             -> usage (regOp src, regOp dst)
-  SCVTF dst src            -> usage (regOp src, regOp dst)
-  FCVTZS dst src           -> usage (regOp src, regOp dst)
-  FABS dst src             -> usage (regOp src, regOp dst)
-
-  _ -> panic "regUsageOfInstr"
-
-  where
-        -- filtering the usage is necessary, otherwise the register
-        -- allocator will try to allocate pre-defined fixed stg
-        -- registers as well, as they show up.
-        usage (src, dst) = RU (filter (interesting platform) src)
-                              (filter (interesting platform) dst)
-
-        regAddr :: AddrMode -> [Reg]
-        regAddr (AddrRegReg r1 r2) = [r1, r2]
-        regAddr (AddrRegImm r1 _)  = [r1]
-        regAddr (AddrReg r1)       = [r1]
-        regOp :: Operand -> [Reg]
-        regOp (OpReg _ r1) = [r1]
-        regOp (OpRegExt _ r1 _ _) = [r1]
-        regOp (OpRegShift _ r1 _ _) = [r1]
-        regOp (OpAddr a) = regAddr a
-        regOp (OpImm _) = []
-        regOp (OpImmShift _ _ _) = []
-        regTarget :: Target -> [Reg]
-        regTarget (TBlock _) = []
-        regTarget (TLabel _) = []
-        regTarget (TReg r1)  = [r1]
-
-        -- Is this register interesting for the register allocator?
-        interesting :: Platform -> Reg -> Bool
-        interesting _        (RegVirtual _)                 = True
-        interesting _        (RegReal (RealRegSingle (-1))) = False
-        interesting platform (RegReal (RealRegSingle i))    = freeReg platform i
-
--- Save caller save registers
--- This is x0-x18
---
--- For SIMD/FP Registers:
--- Registers v8-v15 must be preserved by a callee across subroutine calls;
--- the remaining registers (v0-v7, v16-v31) do not need to be preserved (or
--- should be preserved by the caller). Additionally, only the bottom 64 bits
--- of each value stored in v8-v15 need to be preserved [7]; it is the
--- responsibility of the caller to preserve larger values.
---
--- .---------------------------------------------------------------------------------------------------------------------------------------------------------------.
--- |  0 |  1 |  2 |  3 |  4 |  5 |  6 |  7 |  8 |  9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 |
--- | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 42 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 |
--- |== General Purpose registers ==================================================================================================================================|
--- | <---- argument passing -------------> | IR | <------- tmp registers --------> | IP0| IP1| PL | <------------------- callee saved ------------> | FP | LR | SP |
--- | <------ free registers --------------------------------------------------------------------> | BR | Sp | Hp | R1 | R2 | R3 | R4 | R5 | R6 | SL | -- | -- | -- |
--- |== SIMD/FP Registers ==========================================================================================================================================|
--- | <---- argument passing -------------> | <-- callee saved (lower 64 bits) ---> | <--------------------------------------- caller saved ----------------------> |
--- | <------ free registers -------------> | F1 | F2 | F3 | F4 | D1 | D2 | D3 | D4 | <------ free registers -----------------------------------------------------> |
--- '---------------------------------------------------------------------------------------------------------------------------------------------------------------'
--- IR: Indirect result location register, IP: Intra-procedure register, PL: Platform register, FP: Frame pointer, LR: Link register, SP: Stack pointer
--- BR: Base, SL: SpLim
-callerSavedRegisters :: [Reg]
-callerSavedRegisters
-    = map regSingle [0..18]
-    ++ map regSingle [32..39]
-    ++ map regSingle [48..63]
-
--- | Apply a given mapping to all the register references in this
--- instruction.
-patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
-patchRegsOfInstr instr env = case instr of
-    -- 0. Meta Instructions
-    ANN d i        -> ANN d (patchRegsOfInstr i env)
-    -- 1. Arithmetic Instructions ----------------------------------------------
-    ADD o1 o2 o3   -> ADD (patchOp o1) (patchOp o2) (patchOp o3)
-    CMN o1 o2      -> CMN (patchOp o1) (patchOp o2)
-    CMP o1 o2      -> CMP (patchOp o1) (patchOp o2)
-    MSUB o1 o2 o3 o4 -> MSUB (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)
-    MUL o1 o2 o3   -> MUL (patchOp o1) (patchOp o2) (patchOp o3)
-    NEG o1 o2      -> NEG (patchOp o1) (patchOp o2)
-    SMULH o1 o2 o3 -> SMULH (patchOp o1) (patchOp o2)  (patchOp o3)
-    SMULL o1 o2 o3 -> SMULL (patchOp o1) (patchOp o2)  (patchOp o3)
-    SDIV o1 o2 o3  -> SDIV (patchOp o1) (patchOp o2) (patchOp o3)
-    SUB o1 o2 o3   -> SUB  (patchOp o1) (patchOp o2) (patchOp o3)
-    UDIV o1 o2 o3  -> UDIV (patchOp o1) (patchOp o2) (patchOp o3)
-
-    -- 2. Bit Manipulation Instructions ----------------------------------------
-    SBFM o1 o2 o3 o4 -> SBFM (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)
-    UBFM o1 o2 o3 o4 -> UBFM (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)
-    SBFX o1 o2 o3 o4 -> SBFX (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)
-    UBFX o1 o2 o3 o4 -> UBFX (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)
-    SXTB o1 o2       -> SXTB (patchOp o1) (patchOp o2)
-    UXTB o1 o2       -> UXTB (patchOp o1) (patchOp o2)
-    SXTH o1 o2       -> SXTH (patchOp o1) (patchOp o2)
-    UXTH o1 o2       -> UXTH (patchOp o1) (patchOp o2)
-
-    -- 3. Logical and Move Instructions ----------------------------------------
-    AND o1 o2 o3   -> AND  (patchOp o1) (patchOp o2) (patchOp o3)
-    ANDS o1 o2 o3  -> ANDS (patchOp o1) (patchOp o2) (patchOp o3)
-    ASR o1 o2 o3   -> ASR  (patchOp o1) (patchOp o2) (patchOp o3)
-    BIC o1 o2 o3   -> BIC  (patchOp o1) (patchOp o2) (patchOp o3)
-    BICS o1 o2 o3  -> BICS (patchOp o1) (patchOp o2) (patchOp o3)
-    EON o1 o2 o3   -> EON  (patchOp o1) (patchOp o2) (patchOp o3)
-    EOR o1 o2 o3   -> EOR  (patchOp o1) (patchOp o2) (patchOp o3)
-    LSL o1 o2 o3   -> LSL  (patchOp o1) (patchOp o2) (patchOp o3)
-    LSR o1 o2 o3   -> LSR  (patchOp o1) (patchOp o2) (patchOp o3)
-    MOV o1 o2      -> MOV  (patchOp o1) (patchOp o2)
-    MOVK o1 o2     -> MOVK (patchOp o1) (patchOp o2)
-    MVN o1 o2      -> MVN  (patchOp o1) (patchOp o2)
-    ORR o1 o2 o3   -> ORR  (patchOp o1) (patchOp o2) (patchOp o3)
-    ROR o1 o2 o3   -> ROR  (patchOp o1) (patchOp o2) (patchOp o3)
-    TST o1 o2      -> TST  (patchOp o1) (patchOp o2)
-
-    -- 4. Branch Instructions --------------------------------------------------
-    J t            -> J (patchTarget t)
-    B t            -> B (patchTarget t)
-    BL t rs ts     -> BL (patchTarget t) rs ts
-    BCOND c t      -> BCOND c (patchTarget t)
-
-    -- 5. Atomic Instructions --------------------------------------------------
-    -- 6. Conditional Instructions ---------------------------------------------
-    CSET o c       -> CSET (patchOp o) c
-    CBZ o l        -> CBZ (patchOp o) l
-    CBNZ o l       -> CBNZ (patchOp o) l
-    -- 7. Load and Store Instructions ------------------------------------------
-    STR f o1 o2    -> STR f (patchOp o1) (patchOp o2)
-    LDR f o1 o2    -> LDR f (patchOp o1) (patchOp o2)
-    STP f o1 o2 o3 -> STP f (patchOp o1) (patchOp o2) (patchOp o3)
-    LDP f o1 o2 o3 -> LDP f (patchOp o1) (patchOp o2) (patchOp o3)
-
-    -- 8. Synchronization Instructions -----------------------------------------
-    DMBSY          -> DMBSY
-
-    -- 9. Floating Point Instructions ------------------------------------------
-    FCVT o1 o2     -> FCVT (patchOp o1) (patchOp o2)
-    SCVTF o1 o2    -> SCVTF (patchOp o1) (patchOp o2)
-    FCVTZS o1 o2   -> FCVTZS (patchOp o1) (patchOp o2)
-    FABS o1 o2     -> FABS (patchOp o1) (patchOp o2)
-
-    _ -> pprPanic "patchRegsOfInstr" (text $ show instr)
-    where
-        patchOp :: Operand -> Operand
-        patchOp (OpReg w r) = OpReg w (env r)
-        patchOp (OpRegExt w r x s) = OpRegExt w (env r) x s
-        patchOp (OpRegShift w r m s) = OpRegShift w (env r) m s
-        patchOp (OpAddr a) = OpAddr (patchAddr a)
-        patchOp op = op
-        patchTarget :: Target -> Target
-        patchTarget (TReg r) = TReg (env r)
-        patchTarget t = t
-        patchAddr :: AddrMode -> AddrMode
-        patchAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
-        patchAddr (AddrRegImm r1 i)  = AddrRegImm (env r1) i
-        patchAddr (AddrReg r) = AddrReg (env r)
---------------------------------------------------------------------------------
--- | Checks whether this instruction is a jump/branch instruction.
--- One that can change the flow of control in a way that the
--- register allocator needs to worry about.
-isJumpishInstr :: Instr -> Bool
-isJumpishInstr instr = case instr of
-    ANN _ i -> isJumpishInstr i
-    CBZ{} -> True
-    CBNZ{} -> True
-    J{} -> True
-    B{} -> True
-    BL{} -> True
-    BCOND{} -> True
-    _ -> False
-
--- | Checks whether this instruction is a jump/branch instruction.
--- One that can change the flow of control in a way that the
--- register allocator needs to worry about.
-jumpDestsOfInstr :: Instr -> [BlockId]
-jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i
-jumpDestsOfInstr (CBZ _ t) = [ id | TBlock id <- [t]]
-jumpDestsOfInstr (CBNZ _ t) = [ id | TBlock id <- [t]]
-jumpDestsOfInstr (J t) = [id | TBlock id <- [t]]
-jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]
-jumpDestsOfInstr (BL t _ _) = [ id | TBlock id <- [t]]
-jumpDestsOfInstr (BCOND _ t) = [ id | TBlock id <- [t]]
-jumpDestsOfInstr _ = []
-
--- | Change the destination of this jump instruction.
--- Used in the linear allocator when adding fixup blocks for join
--- points.
-patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
-patchJumpInstr instr patchF
-    = case instr of
-        ANN d i -> ANN d (patchJumpInstr i patchF)
-        CBZ r (TBlock bid) -> CBZ r (TBlock (patchF bid))
-        CBNZ r (TBlock bid) -> CBNZ r (TBlock (patchF bid))
-        J (TBlock bid) -> J (TBlock (patchF bid))
-        B (TBlock bid) -> B (TBlock (patchF bid))
-        BL (TBlock bid) ps rs -> BL (TBlock (patchF bid)) ps rs
-        BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid))
-        _ -> pprPanic "patchJumpInstr" (text $ show instr)
-
--- -----------------------------------------------------------------------------
--- Note [Spills and Reloads]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~
--- We reserve @RESERVED_C_STACK_BYTES@ on the C stack for spilling and reloading
--- registers.  AArch64s maximum displacement for SP relative spills and reloads
--- is essentially [-256,255], or [0, 0xFFF]*8 = [0, 32760] for 64bits.
---
--- The @RESERVED_C_STACK_BYTES@ is 16k, so we can't address any location in a
--- single instruction.  The idea is to use the Inter Procedure 0 (ip0) register
--- to perform the computations for larger offsets.
---
--- Using sp to compute the offset will violate assumptions about the stack pointer
--- pointing to the top of the stack during signal handling.  As we can't force
--- every signal to use its own stack, we have to ensure that the stack pointer
--- always points to the top of the stack, and we can't use it for computation.
---
--- | An instruction to spill a register into a spill slot.
-mkSpillInstr
-   :: HasCallStack
-   => NCGConfig
-   -> Reg       -- register to spill
-   -> Int       -- current stack delta
-   -> Int       -- spill slot to use
-   -> [Instr]
-
-mkSpillInstr config reg delta slot =
-  case (spillSlotToOffset config slot) - delta of
-    imm | -256 <= imm && imm <= 255                               -> [ mkStrSp imm ]
-    imm | imm > 0 && imm .&. 0x7 == 0x0 && imm <= 0xfff           -> [ mkStrSp imm ]
-    imm | imm > 0xfff && imm <= 0xffffff && imm .&. 0x7 == 0x0    -> [ mkIp0SpillAddr (imm .&~. 0xfff)
-                                                                     , mkStrIp0 (imm .&.  0xfff)
-                                                                     ]
-    imm -> pprPanic "mkSpillInstr" (text "Unable to spill into" <+> int imm)
-    where
-        a .&~. b = a .&. (complement b)
-
-        fmt = case reg of
-            RegReal (RealRegSingle n) | n < 32 -> II64
-            _                                  -> FF64
-        mkIp0SpillAddr imm = ANN (text "Spill: IP0 <- SP + " <> int imm) $ ADD ip0 sp (OpImm (ImmInt imm))
-        mkStrSp imm = ANN (text "Spill@" <> int (off - delta)) $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 31) (ImmInt imm)))
-        mkStrIp0 imm = ANN (text "Spill@" <> int (off - delta)) $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 16) (ImmInt imm)))
-
-        off = spillSlotToOffset config slot
-
-mkLoadInstr
-   :: NCGConfig
-   -> Reg       -- register to load
-   -> Int       -- current stack delta
-   -> Int       -- spill slot to use
-   -> [Instr]
-
-mkLoadInstr config reg delta slot =
-  case (spillSlotToOffset config slot) - delta of
-    imm | -256 <= imm && imm <= 255                               -> [ mkLdrSp imm ]
-    imm | imm > 0 && imm .&. 0x7 == 0x0 && imm <= 0xfff           -> [ mkLdrSp imm ]
-    imm | imm > 0xfff && imm <= 0xffffff && imm .&. 0x7 == 0x0    -> [ mkIp0SpillAddr (imm .&~. 0xfff)
-                                                                     , mkLdrIp0 (imm .&.  0xfff)
-                                                                     ]
-    imm -> pprPanic "mkSpillInstr" (text "Unable to spill into" <+> int imm)
-    where
-        a .&~. b = a .&. (complement b)
-
-        fmt = case reg of
-            RegReal (RealRegSingle n) | n < 32 -> II64
-            _                                  -> FF64
-
-        mkIp0SpillAddr imm = ANN (text "Reload: IP0 <- SP + " <> int imm) $ ADD ip0 sp (OpImm (ImmInt imm))
-        mkLdrSp imm = ANN (text "Reload@" <> int (off - delta)) $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 31) (ImmInt imm)))
-        mkLdrIp0 imm = ANN (text "Reload@" <> int (off - delta)) $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 16) (ImmInt imm)))
-
-        off = spillSlotToOffset config slot
-
---------------------------------------------------------------------------------
--- | See if this instruction is telling us the current C stack delta
-takeDeltaInstr :: Instr -> Maybe Int
-takeDeltaInstr (ANN _ i) = takeDeltaInstr i
-takeDeltaInstr (DELTA i) = Just i
-takeDeltaInstr _         = Nothing
-
--- Not real instructions.  Just meta data
-isMetaInstr :: Instr -> Bool
-isMetaInstr instr
- = case instr of
-    ANN _ i     -> isMetaInstr i
-    COMMENT{}   -> True
-    MULTILINE_COMMENT{} -> True
-    LOCATION{}  -> True
-    LDATA{}     -> True
-    NEWBLOCK{}  -> True
-    DELTA{}     -> True
-    PUSH_STACK_FRAME -> True
-    POP_STACK_FRAME -> True
-    _           -> False
-
--- | Copy the value in a register to another one.
--- Must work for all register classes.
-mkRegRegMoveInstr :: Reg -> Reg -> Instr
-mkRegRegMoveInstr src dst = ANN (text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst) $ MOV (OpReg W64 dst) (OpReg W64 src)
-
--- | Take the source and destination from this reg -> reg move instruction
--- or Nothing if it's not one
-takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)
---takeRegRegMoveInstr (MOV (OpReg fmt dst) (OpReg fmt' src)) | fmt == fmt' = Just (src, dst)
-takeRegRegMoveInstr _ = Nothing
-
--- | Make an unconditional jump instruction.
-mkJumpInstr :: BlockId -> [Instr]
-mkJumpInstr id = [B (TBlock id)]
-
-mkStackAllocInstr :: Platform -> Int -> [Instr]
-mkStackAllocInstr platform n
-    | n == 0 = []
-    | n > 0 && n < 4096 = [ ANN (text "Alloc More Stack") $ SUB sp sp (OpImm (ImmInt n)) ]
-    | n > 0 =  ANN (text "Alloc More Stack") (SUB sp sp (OpImm (ImmInt 4095))) : mkStackAllocInstr platform (n - 4095)
-mkStackAllocInstr _platform n = pprPanic "mkStackAllocInstr" (int n)
-
-mkStackDeallocInstr :: Platform -> Int -> [Instr]
-mkStackDeallocInstr platform n
-    | n == 0 = []
-    | n > 0 && n < 4096 = [ ANN (text "Dealloc More Stack") $ ADD sp sp (OpImm (ImmInt n)) ]
-    | n > 0 =  ANN (text "Dealloc More Stack") (ADD sp sp (OpImm (ImmInt 4095))) : mkStackDeallocInstr platform (n - 4095)
-mkStackDeallocInstr _platform n = pprPanic "mkStackDeallocInstr" (int n)
-
---
--- See Note [extra spill slots] in X86/Instr.hs
---
-allocMoreStack
-  :: Platform
-  -> Int
-  -> NatCmmDecl statics GHC.CmmToAsm.AArch64.Instr.Instr
-  -> UniqSM (NatCmmDecl statics GHC.CmmToAsm.AArch64.Instr.Instr, [(BlockId,BlockId)])
-
-allocMoreStack _ _ top@(CmmData _ _) = return (top,[])
-allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do
-    let entries = entryBlocks proc
-
-    uniqs <- getUniquesM
-
-    let
-      delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
-        where x = slots * spillSlotSize -- sp delta
-
-      alloc   = mkStackAllocInstr   platform delta
-      dealloc = mkStackDeallocInstr platform delta
-
-      retargetList = (zip entries (map mkBlockId uniqs))
-
-      new_blockmap :: LabelMap BlockId
-      new_blockmap = mapFromList retargetList
-
-      insert_stack_insn (BasicBlock id insns)
-        | Just new_blockid <- mapLookup id new_blockmap
-        = [ BasicBlock id $ alloc ++ [ B (TBlock new_blockid) ]
-          , BasicBlock new_blockid block' ]
-        | otherwise
-        = [ BasicBlock id block' ]
-        where
-          block' = foldr insert_dealloc [] insns
-
-      insert_dealloc insn r = case insn of
-        J _ -> dealloc ++ (insn : r)
-        ANN _ (J _) -> dealloc ++ (insn : r)
-        _other | jumpDestsOfInstr insn /= []
-            -> patchJumpInstr insn retarget : r
-        _other -> insn : r
-
-        where retarget b = fromMaybe b (mapLookup b new_blockmap)
-
-      new_code = concatMap insert_stack_insn code
-    -- in
-    return (CmmProc info lbl live (ListGraph new_code), retargetList)
--- -----------------------------------------------------------------------------
--- Machine's assembly language
-
--- We have a few common "instructions" (nearly all the pseudo-ops) but
--- mostly all of 'Instr' is machine-specific.
-
--- Some additional (potential future) instructions are commented out. They are
--- not needed yet for the backend but could be used in the future.
-data Instr
-    -- comment pseudo-op
-    = COMMENT SDoc
-    | MULTILINE_COMMENT SDoc
-
-    -- Annotated instruction. Should print <instr> # <doc>
-    | ANN SDoc Instr
-
-    -- location pseudo-op (file, line, col, name)
-    | LOCATION Int Int Int String
-
-    -- some static data spat out during code
-    -- generation.  Will be extracted before
-    -- pretty-printing.
-    | LDATA   Section RawCmmStatics
-
-    -- start a new basic block.  Useful during
-    -- codegen, removed later.  Preceding
-    -- instruction should be a jump, as per the
-    -- invariants for a BasicBlock (see Cmm).
-    | NEWBLOCK BlockId
-
-    -- specify current stack offset for
-    -- benefit of subsequent passes
-    | DELTA   Int
-
-    -- 0. Pseudo Instructions --------------------------------------------------
-    | SXTB Operand Operand
-    | UXTB Operand Operand
-    | SXTH Operand Operand
-    | UXTH Operand Operand
-    -- | SXTW Operand Operand
-    -- | SXTX Operand Operand
-    | PUSH_STACK_FRAME
-    | POP_STACK_FRAME
-    -- 1. Arithmetic Instructions ----------------------------------------------
-    -- | ADC Operand Operand Operand -- rd = rn + rm + C
-    -- | ADCS ...
-    | ADD Operand Operand Operand -- rd = rn + rm
-    -- | ADDS Operand Operand Operand -- rd = rn + rm
-    -- | ADR ...
-    -- | ADRP ...
-    | CMN Operand Operand -- rd + op2
-    | CMP Operand Operand -- rd - op2
-    -- | MADD ...
-    -- | MNEG ...
-    | MSUB Operand Operand Operand Operand -- rd = ra - rn × rm
-    | MUL Operand Operand Operand -- rd = rn × rm
-    | NEG Operand Operand -- rd = -op2
-    -- | NEGS ...
-    -- | NGC ...
-    -- | NGCS ...
-    -- | SBC ...
-    -- | SBCS ...
-    | SDIV Operand Operand Operand -- rd = rn ÷ rm
-    -- | SMADDL ...
-    -- | SMNEGL ...
-    -- | SMSUBL ...
-    | SMULH Operand Operand Operand
-    | SMULL Operand Operand Operand
-    | SUB Operand Operand Operand -- rd = rn - op2
-    -- | SUBS ...
-    | UDIV Operand Operand Operand -- rd = rn ÷ rm
-    -- | UMADDL ...  -- Xd = Xa + Wn × Wm
-    -- | UMNEGL ... -- Xd = - Wn × Wm
-    -- | UMSUBL ... -- Xd = Xa - Wn × Wm
-    -- | UMULH ... -- Xd = (Xn × Xm)_127:64
-    -- | UMULL ... -- Xd = Wn × Wm
-
-    -- 2. Bit Manipulation Instructions ----------------------------------------
-    | SBFM Operand Operand Operand Operand -- rd = rn[i,j]
-    -- SXTB = SBFM <Wd>, <Wn>, #0, #7
-    -- SXTH = SBFM <Wd>, <Wn>, #0, #15
-    -- SXTW = SBFM <Wd>, <Wn>, #0, #31
-    | UBFM Operand Operand Operand Operand -- rd = rn[i,j]
-    -- UXTB = UBFM <Wd>, <Wn>, #0, #7
-    -- UXTH = UBFM <Wd>, <Wn>, #0, #15
-    -- Signed/Unsigned bitfield extract
-    | SBFX Operand Operand Operand Operand -- rd = rn[i,j]
-    | UBFX Operand Operand Operand Operand -- rd = rn[i,j]
-
-    -- 3. Logical and Move Instructions ----------------------------------------
-    | AND Operand Operand Operand -- rd = rn & op2
-    | ANDS Operand Operand Operand -- rd = rn & op2
-    | ASR Operand Operand Operand -- rd = rn ≫ rm  or  rd = rn ≫ #i, i is 6 bits
-    | BIC Operand Operand Operand -- rd = rn & ~op2
-    | BICS Operand Operand Operand -- rd = rn & ~op2
-    | EON Operand Operand Operand -- rd = rn ⊕ ~op2
-    | EOR Operand Operand Operand -- rd = rn ⊕ op2
-    | LSL Operand Operand Operand -- rd = rn ≪ rm  or rd = rn ≪ #i, i is 6 bits
-    | LSR Operand Operand Operand -- rd = rn ≫ rm  or rd = rn ≫ #i, i is 6 bits
-    | MOV Operand Operand -- rd = rn  or  rd = #i
-    | MOVK Operand Operand
-    -- | MOVN Operand Operand
-    -- | MOVZ Operand Operand
-    | MVN Operand Operand -- rd = ~rn
-    | ORN Operand Operand Operand -- rd = rn | ~op2
-    | ORR Operand Operand Operand -- rd = rn | op2
-    | ROR Operand Operand Operand -- rd = rn ≫ rm  or  rd = rn ≫ #i, i is 6 bits
-    | TST Operand Operand -- rn & op2
-    -- Load and stores.
-    -- TODO STR/LDR might want to change to STP/LDP with XZR for the second register.
-    | STR Format Operand Operand -- str Xn, address-mode // Xn -> *addr
-    | LDR Format Operand Operand -- ldr Xn, address-mode // Xn <- *addr
-    | STP Format Operand Operand Operand -- stp Xn, Xm, address-mode // Xn -> *addr, Xm -> *(addr + 8)
-    | LDP Format Operand Operand Operand -- stp Xn, Xm, address-mode // Xn <- *addr, Xm <- *(addr + 8)
-
-    -- Conditional instructions
-    | CSET Operand Cond   -- if(cond) op <- 1 else op <- 0
-
-    | CBZ Operand Target  -- if op == 0, then branch.
-    | CBNZ Operand Target -- if op /= 0, then branch.
-    -- Branching.
-    | J Target            -- like B, but only generated from genJump. Used to distinguish genJumps from others.
-    | B Target            -- unconditional branching b/br. (To a blockid, label or register)
-    | BL Target [Reg] [Reg] -- branch and link (e.g. set x30 to next pc, and branch)
-    | BCOND Cond Target   -- branch with condition. b.<cond>
-
-    -- 8. Synchronization Instructions -----------------------------------------
-    | DMBSY
-    -- 9. Floating Point Instructions
-    -- Float ConVerT
-    | FCVT Operand Operand
-    -- Signed ConVerT Float
-    | SCVTF Operand Operand
-    -- Float ConVerT to Zero Signed
-    | FCVTZS Operand Operand
-    -- Float ABSolute value
-    | FABS Operand Operand
-
-instance Show Instr where
-    show (LDR _f o1 o2) = "LDR " ++ show o1 ++ ", " ++ show o2
-    show (MOV o1 o2) = "MOV " ++ show o1 ++ ", " ++ show o2
-    show _ = "missing"
-
-data Target
-    = TBlock BlockId
-    | TLabel CLabel
-    | TReg   Reg
-
-
--- Extension
--- {Unsigned|Signed}XT{Byte|Half|Word|Doube}
-data ExtMode
-    = EUXTB | EUXTH | EUXTW | EUXTX
-    | ESXTB | ESXTH | ESXTW | ESXTX
-    deriving (Eq, Show)
-
-data ShiftMode
-    = SLSL | SLSR | SASR | SROR
-    deriving (Eq, Show)
-
-
--- We can also add ExtShift to Extension.
--- However at most 3bits.
-type ExtShift = Int
--- at most 6bits
-type RegShift = Int
-
-data Operand
-        = OpReg Width Reg            -- register
-        | OpRegExt Width Reg ExtMode ExtShift -- rm, <ext>[, <shift left>]
-        | OpRegShift Width Reg ShiftMode RegShift     -- rm, <shift>, <0-64>
-        | OpImm Imm            -- immediate value
-        | OpImmShift Imm ShiftMode RegShift
-        | OpAddr AddrMode       -- memory reference
-        deriving (Eq, Show)
-
--- Smart constructors
-opReg :: Width -> Reg -> Operand
-opReg = OpReg
-
-xzr, wzr, sp, ip0 :: Operand
-xzr = OpReg W64 (RegReal (RealRegSingle (-1)))
-wzr = OpReg W32 (RegReal (RealRegSingle (-1)))
-sp  = OpReg W64 (RegReal (RealRegSingle 31))
-ip0 = OpReg W64 (RegReal (RealRegSingle 16))
-
-_x :: Int -> Operand
-_x i = OpReg W64 (RegReal (RealRegSingle i))
-x0,  x1,  x2,  x3,  x4,  x5,  x6,  x7  :: Operand
-x8,  x9,  x10, x11, x12, x13, x14, x15 :: Operand
-x16, x17, x18, x19, x20, x21, x22, x23 :: Operand
-x24, x25, x26, x27, x28, x29, x30, x31 :: Operand
-x0  = OpReg W64 (RegReal (RealRegSingle  0))
-x1  = OpReg W64 (RegReal (RealRegSingle  1))
-x2  = OpReg W64 (RegReal (RealRegSingle  2))
-x3  = OpReg W64 (RegReal (RealRegSingle  3))
-x4  = OpReg W64 (RegReal (RealRegSingle  4))
-x5  = OpReg W64 (RegReal (RealRegSingle  5))
-x6  = OpReg W64 (RegReal (RealRegSingle  6))
-x7  = OpReg W64 (RegReal (RealRegSingle  7))
-x8  = OpReg W64 (RegReal (RealRegSingle  8))
-x9  = OpReg W64 (RegReal (RealRegSingle  9))
-x10 = OpReg W64 (RegReal (RealRegSingle 10))
-x11 = OpReg W64 (RegReal (RealRegSingle 11))
-x12 = OpReg W64 (RegReal (RealRegSingle 12))
-x13 = OpReg W64 (RegReal (RealRegSingle 13))
-x14 = OpReg W64 (RegReal (RealRegSingle 14))
-x15 = OpReg W64 (RegReal (RealRegSingle 15))
-x16 = OpReg W64 (RegReal (RealRegSingle 16))
-x17 = OpReg W64 (RegReal (RealRegSingle 17))
-x18 = OpReg W64 (RegReal (RealRegSingle 18))
-x19 = OpReg W64 (RegReal (RealRegSingle 19))
-x20 = OpReg W64 (RegReal (RealRegSingle 20))
-x21 = OpReg W64 (RegReal (RealRegSingle 21))
-x22 = OpReg W64 (RegReal (RealRegSingle 22))
-x23 = OpReg W64 (RegReal (RealRegSingle 23))
-x24 = OpReg W64 (RegReal (RealRegSingle 24))
-x25 = OpReg W64 (RegReal (RealRegSingle 25))
-x26 = OpReg W64 (RegReal (RealRegSingle 26))
-x27 = OpReg W64 (RegReal (RealRegSingle 27))
-x28 = OpReg W64 (RegReal (RealRegSingle 28))
-x29 = OpReg W64 (RegReal (RealRegSingle 29))
-x30 = OpReg W64 (RegReal (RealRegSingle 30))
-x31 = OpReg W64 (RegReal (RealRegSingle 31))
-
-_d :: Int -> Operand
-_d = OpReg W64 . RegReal . RealRegSingle
-d0,  d1,  d2,  d3,  d4,  d5,  d6,  d7  :: Operand
-d8,  d9,  d10, d11, d12, d13, d14, d15 :: Operand
-d16, d17, d18, d19, d20, d21, d22, d23 :: Operand
-d24, d25, d26, d27, d28, d29, d30, d31 :: Operand
-d0  = OpReg W64 (RegReal (RealRegSingle 32))
-d1  = OpReg W64 (RegReal (RealRegSingle 33))
-d2  = OpReg W64 (RegReal (RealRegSingle 34))
-d3  = OpReg W64 (RegReal (RealRegSingle 35))
-d4  = OpReg W64 (RegReal (RealRegSingle 36))
-d5  = OpReg W64 (RegReal (RealRegSingle 37))
-d6  = OpReg W64 (RegReal (RealRegSingle 38))
-d7  = OpReg W64 (RegReal (RealRegSingle 39))
-d8  = OpReg W64 (RegReal (RealRegSingle 40))
-d9  = OpReg W64 (RegReal (RealRegSingle 41))
-d10 = OpReg W64 (RegReal (RealRegSingle 42))
-d11 = OpReg W64 (RegReal (RealRegSingle 43))
-d12 = OpReg W64 (RegReal (RealRegSingle 44))
-d13 = OpReg W64 (RegReal (RealRegSingle 45))
-d14 = OpReg W64 (RegReal (RealRegSingle 46))
-d15 = OpReg W64 (RegReal (RealRegSingle 47))
-d16 = OpReg W64 (RegReal (RealRegSingle 48))
-d17 = OpReg W64 (RegReal (RealRegSingle 49))
-d18 = OpReg W64 (RegReal (RealRegSingle 50))
-d19 = OpReg W64 (RegReal (RealRegSingle 51))
-d20 = OpReg W64 (RegReal (RealRegSingle 52))
-d21 = OpReg W64 (RegReal (RealRegSingle 53))
-d22 = OpReg W64 (RegReal (RealRegSingle 54))
-d23 = OpReg W64 (RegReal (RealRegSingle 55))
-d24 = OpReg W64 (RegReal (RealRegSingle 56))
-d25 = OpReg W64 (RegReal (RealRegSingle 57))
-d26 = OpReg W64 (RegReal (RealRegSingle 58))
-d27 = OpReg W64 (RegReal (RealRegSingle 59))
-d28 = OpReg W64 (RegReal (RealRegSingle 60))
-d29 = OpReg W64 (RegReal (RealRegSingle 61))
-d30 = OpReg W64 (RegReal (RealRegSingle 62))
-d31 = OpReg W64 (RegReal (RealRegSingle 63))
-
-opRegUExt :: Width -> Reg -> Operand
-opRegUExt W64 r = OpRegExt W64 r EUXTX 0
-opRegUExt W32 r = OpRegExt W32 r EUXTW 0
-opRegUExt W16 r = OpRegExt W16 r EUXTH 0
-opRegUExt W8  r = OpRegExt W8  r EUXTB 0
-opRegUExt w  _r = pprPanic "opRegUExt" (text $ show w)
-
-opRegSExt :: Width -> Reg -> Operand
-opRegSExt W64 r = OpRegExt W64 r ESXTX 0
-opRegSExt W32 r = OpRegExt W32 r ESXTW 0
-opRegSExt W16 r = OpRegExt W16 r ESXTH 0
-opRegSExt W8  r = OpRegExt W8  r ESXTB 0
-opRegSExt w  _r = pprPanic "opRegSExt" (text $ show w)
diff --git a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs
+++ /dev/null
@@ -1,587 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE CPP #-}
-
-module GHC.CmmToAsm.AArch64.Ppr (pprNatCmmDecl, pprInstr) where
-
-import GHC.Prelude hiding (EQ)
-
-import GHC.CmmToAsm.AArch64.Instr
-import GHC.CmmToAsm.AArch64.Regs
-import GHC.CmmToAsm.AArch64.Cond
-import GHC.CmmToAsm.Ppr
-import GHC.CmmToAsm.Format
-import GHC.Platform.Reg
-import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Types
-import GHC.CmmToAsm.Utils
-
-import GHC.Cmm hiding (topInfoTable)
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Label
-import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes)
-
-import GHC.Cmm.BlockId
-import GHC.Cmm.CLabel
-
-import GHC.Types.Unique ( pprUniqueAlways, getUnique )
-import GHC.Platform
-import GHC.Utils.Outputable
-
-import GHC.Utils.Panic
-
-pprProcAlignment :: IsDoc doc => NCGConfig -> doc
-pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config)
-   where
-      platform = ncgPlatform config
-
-pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc
-pprNatCmmDecl config (CmmData section dats) =
-  pprSectionAlign config section $$ pprDatas config dats
-
-pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
-  let platform = ncgPlatform config in
-  pprProcAlignment config $$
-  case topInfoTable proc of
-    Nothing ->
-        -- special case for code without info table:
-        pprSectionAlign config (Section Text lbl) $$
-        -- do not
-        -- pprProcAlignment config $$
-        pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed
-        vcat (map (pprBasicBlock config top_info) blocks) $$
-        (if ncgDwarfEnabled config
-         then line (pprAsmLabel platform (mkAsmTempEndLabel lbl) <> char ':') else empty) $$
-        pprSizeDecl platform lbl
-
-    Just (CmmStaticsRaw info_lbl _) ->
-      pprSectionAlign config (Section Text info_lbl) $$
-      -- pprProcAlignment config $$
-      (if platformHasSubsectionsViaSymbols platform
-          then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':')
-          else empty) $$
-      vcat (map (pprBasicBlock config top_info) blocks) $$
-      -- above: Even the first block gets a label, because with branch-chain
-      -- elimination, it might be the target of a goto.
-      (if platformHasSubsectionsViaSymbols platform
-       then -- See Note [Subsections Via Symbols]
-                line
-              $ text "\t.long "
-            <+> pprAsmLabel platform info_lbl
-            <+> char '-'
-            <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)
-       else empty) $$
-      pprSizeDecl platform info_lbl
-{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-}
-{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
-pprLabel :: IsDoc doc => Platform -> CLabel -> doc
-pprLabel platform lbl =
-   pprGloblDecl platform lbl
-   $$ pprTypeDecl platform lbl
-   $$ line (pprAsmLabel platform lbl <> char ':')
-
-pprAlign :: IsDoc doc => Platform -> Alignment -> doc
-pprAlign _platform alignment
-        = line $ text "\t.balign " <> int (alignmentBytes alignment)
-
--- | Print appropriate alignment for the given section type.
-pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc
-pprAlignForSection _platform _seg
-    -- .balign is stable, whereas .align is platform dependent.
-    = line (text "\t.balign 8") --  always 8
-
--- | Print section header and appropriate alignment for that section.
---
--- This one will emit the header:
---
---     .section .text
---     .balign 8
---
-pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc
-pprSectionAlign _config (Section (OtherSection _) _) =
-     panic "AArch64.Ppr.pprSectionAlign: unknown section"
-pprSectionAlign config sec@(Section seg _) =
-    line (pprSectionHeader config sec)
-    $$ pprAlignForSection (ncgPlatform config) seg
-
--- | Output the ELF .size directive.
-pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc
-pprSizeDecl platform lbl
- = if osElfTarget (platformOS platform)
-   then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl)
-   else empty
-
-pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr
-              -> doc
-pprBasicBlock config info_env (BasicBlock blockid instrs)
-  = maybe_infotable $
-    pprLabel platform asmLbl $$
-    vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$
-    (if  ncgDwarfEnabled config
-      then line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':')
-      else empty
-    )
-  where
-    -- Filter out identity moves. E.g. mov x18, x18 will be dropped.
-    optInstrs = filter f instrs
-      where f (MOV o1 o2) | o1 == o2 = False
-            f _ = True
-
-    asmLbl = blockLbl blockid
-    platform = ncgPlatform config
-    maybe_infotable c = case mapLookup blockid info_env of
-       Nothing   -> c
-       Just (CmmStaticsRaw info_lbl info) ->
-          --  pprAlignForSection platform Text $$
-           infoTableLoc $$
-           vcat (map (pprData config) info) $$
-           pprLabel platform info_lbl $$
-           c $$
-           (if ncgDwarfEnabled config
-             then line (pprAsmLabel platform (mkAsmTempEndLabel info_lbl) <> char ':')
-             else empty)
-    -- Make sure the info table has the right .loc for the block
-    -- coming right after it. See Note [Info Offset]
-    infoTableLoc = case instrs of
-      (l@LOCATION{} : _) -> pprInstr platform l
-      _other             -> empty
-
-pprDatas :: IsDoc doc => NCGConfig -> RawCmmStatics -> doc
--- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
-pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
-  | lbl == mkIndStaticInfoLabel
-  , let labelInd (CmmLabelOff l _) = Just l
-        labelInd (CmmLabel l) = Just l
-        labelInd _ = Nothing
-  , Just ind' <- labelInd ind
-  , alias `mayRedirectTo` ind'
-  = pprGloblDecl (ncgPlatform config) alias
-    $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind')
-
-pprDatas config (CmmStaticsRaw lbl dats)
-  = vcat (pprLabel platform lbl : map (pprData config) dats)
-   where
-      platform = ncgPlatform config
-
-pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc
-pprData _config (CmmString str) = line (pprString str)
-pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path)
-
-pprData config (CmmUninitialised bytes)
- = line $ let platform = ncgPlatform config
-          in if platformOS platform == OSDarwin
-                then text ".space " <> int bytes
-                else text ".skip "  <> int bytes
-
-pprData config (CmmStaticLit lit) = pprDataItem config lit
-
-pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc
-pprGloblDecl platform lbl
-  | not (externallyVisibleCLabel lbl) = empty
-  | otherwise = line (text "\t.globl " <> pprAsmLabel platform lbl)
-
--- Note [Always use objects for info tables]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- See discussion in X86.Ppr for why this is necessary.  Essentially we need to
--- ensure that we never pass function symbols when we might want to lookup the
--- info table.  If we did, we could end up with procedure linking tables
--- (PLT)s, and thus the lookup wouldn't point to the function, but into the
--- jump table.
---
--- Fun fact: The LLVMMangler exists to patch this issue su on the LLVM side as
--- well.
-pprLabelType' :: IsLine doc => Platform -> CLabel -> doc
-pprLabelType' platform lbl =
-  if isCFunctionLabel lbl || functionOkInfoTable then
-    text "@function"
-  else
-    text "@object"
-  where
-    functionOkInfoTable = platformTablesNextToCode platform &&
-      isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl)
-
--- this is called pprTypeAndSizeDecl in PPC.Ppr
-pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc
-pprTypeDecl platform lbl
-    = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl
-      then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl)
-      else empty
-
-pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc
-pprDataItem config lit
-  = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)
-    where
-        platform = ncgPlatform config
-
-        imm = litToImm lit
-
-        ppr_item II8  _ = [text "\t.byte\t"  <> pprImm platform imm]
-        ppr_item II16 _ = [text "\t.short\t" <> pprImm platform imm]
-        ppr_item II32 _ = [text "\t.long\t"  <> pprImm platform imm]
-        ppr_item II64 _ = [text "\t.quad\t"  <> pprImm platform imm]
-
-        ppr_item FF32  (CmmFloat r _)
-           = let bs = floatToBytes (fromRational r)
-             in  map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs
-
-        ppr_item FF64 (CmmFloat r _)
-           = let bs = doubleToBytes (fromRational r)
-             in  map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs
-
-        ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit)
-
-pprImm :: IsLine doc => Platform -> Imm -> doc
-pprImm _ (ImmInt i)     = int i
-pprImm _ (ImmInteger i) = integer i
-pprImm p (ImmCLbl l)    = pprAsmLabel p l
-pprImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i
-pprImm _ (ImmLit s)     = ftext s
-
--- TODO: See pprIm below for why this is a bad idea!
-pprImm _ (ImmFloat f)
-  | f == 0 = text "wzr"
-  | otherwise = float (fromRational f)
-pprImm _ (ImmDouble d)
-  | d == 0 = text "xzr"
-  | otherwise = double (fromRational d)
-
-pprImm p (ImmConstantSum a b) = pprImm p a <> char '+' <> pprImm p b
-pprImm p (ImmConstantDiff a b) = pprImm p a <> char '-'
-                   <> lparen <> pprImm p b <> rparen
-
-
--- aarch64 GNU as uses // for comments.
-asmComment :: SDoc -> SDoc
-asmComment c = whenPprDebug $ text "#" <+> c
-
-asmDoubleslashComment :: SDoc -> SDoc
-asmDoubleslashComment c = whenPprDebug $ text "//" <+> c
-
-asmMultilineComment :: SDoc -> SDoc
-asmMultilineComment c = whenPprDebug $ text "/*" $+$ c $+$ text "*/"
-
-pprIm :: IsLine doc => Platform -> Imm -> doc
-pprIm platform im = case im of
-  ImmInt i     -> char '#' <> int i
-  ImmInteger i -> char '#' <> integer i
-
-  -- TODO: This will only work for
-  -- The floating point value must be expressible as ±n ÷ 16 × 2^r,
-  -- where n and r are integers such that 16 ≤ n ≤ 31 and -3 ≤ r ≤ 4.
-  -- and 0 needs to be encoded as wzr/xzr.
-  --
-  -- Except for 0, we might want to either split it up into enough
-  -- ADD operations into an Integer register and then just bit copy it into
-  -- the double register? See the toBytes + fromRational above for data items.
-  -- This is something the x86 backend does.
-  --
-  -- We could also just turn them into statics :-/ Which is what the
-  -- PowerPC backend does.
-  ImmFloat f | f == 0 -> text "wzr"
-  ImmFloat f -> char '#' <> float (fromRational f)
-  ImmDouble d | d == 0 -> text "xzr"
-  ImmDouble d -> char '#' <> double (fromRational d)
-  -- =<lbl> pseudo instruction!
-  ImmCLbl l    -> char '=' <> pprAsmLabel platform l
-  ImmIndex l o -> text "[=" <> pprAsmLabel platform l <> comma <+> char '#' <> int o <> char ']'
-  _            -> panic "AArch64.pprIm"
-
-pprExt :: IsLine doc => ExtMode -> doc
-pprExt EUXTB = text "uxtb"
-pprExt EUXTH = text "uxth"
-pprExt EUXTW = text "uxtw"
-pprExt EUXTX = text "uxtx"
-pprExt ESXTB = text "sxtb"
-pprExt ESXTH = text "sxth"
-pprExt ESXTW = text "sxtw"
-pprExt ESXTX = text "sxtx"
-
-pprShift :: IsLine doc => ShiftMode -> doc
-pprShift SLSL = text "lsl"
-pprShift SLSR = text "lsr"
-pprShift SASR = text "asr"
-pprShift SROR = text "ror"
-
-pprOp :: IsLine doc => Platform -> Operand -> doc
-pprOp plat op = case op of
-  OpReg w r           -> pprReg w r
-  OpRegExt w r x 0 -> pprReg w r <> comma <+> pprExt x
-  OpRegExt w r x i -> pprReg w r <> comma <+> pprExt x <> comma <+> char '#' <> int i
-  OpRegShift w r s i -> pprReg w r <> comma <+> pprShift s <+> char '#' <> int i
-  OpImm im          -> pprIm plat im
-  OpImmShift im s i -> pprIm plat im <> comma <+> pprShift s <+> char '#' <> int i
-  -- TODO: Address computation always use registers as 64bit -- is this correct?
-  OpAddr (AddrRegReg r1 r2) -> char '[' <+> pprReg W64 r1 <> comma <+> pprReg W64 r2 <+> char ']'
-  OpAddr (AddrRegImm r1 im) -> char '[' <+> pprReg W64 r1 <> comma <+> pprImm plat im <+> char ']'
-  OpAddr (AddrReg r1)       -> char '[' <+> pprReg W64 r1 <+> char ']'
-
-pprReg :: forall doc. IsLine doc => Width -> Reg -> doc
-pprReg w r = case r of
-  RegReal    (RealRegSingle i) -> ppr_reg_no w i
-  -- virtual regs should not show up, but this is helpful for debugging.
-  RegVirtual (VirtualRegI u)   -> text "%vI_" <> pprUniqueAlways u
-  RegVirtual (VirtualRegF u)   -> text "%vF_" <> pprUniqueAlways u
-  RegVirtual (VirtualRegD u)   -> text "%vD_" <> pprUniqueAlways u
-  _                            -> pprPanic "AArch64.pprReg" (text $ show r)
-
-  where
-    ppr_reg_no :: Width -> Int -> doc
-    ppr_reg_no w 31
-         | w == W64 = text "sp"
-         | w == W32 = text "wsp"
-
-    ppr_reg_no w i
-         | i < 0, w == W32 = text "wzr"
-         | i < 0, w == W64 = text "xzr"
-         | i < 0 = pprPanic "Invalid Zero Reg" (ppr w <+> int i)
-         -- General Purpose Registers
-         | i <= 31, w == W8  = text "w" <> int i      -- there are no byte or half
-         | i <= 31, w == W16 = text "w" <> int i      -- words... word will do.
-         | i <= 31, w == W32 = text "w" <> int i
-         | i <= 31, w == W64 = text "x" <> int i
-         | i <= 31 = pprPanic "Invalid Reg" (ppr w <+> int i)
-         -- Floating Point Registers
-         | i <= 63, w == W8  = text "b" <> int (i-32)
-         | i <= 63, w == W16 = text "h" <> int (i-32)
-         | i <= 63, w == W32 = text "s" <> int (i-32)
-         | i <= 63, w == W64 = text "d" <> int (i-32)
-         -- no support for 'q'uad in GHC's NCG yet.
-         | otherwise = text "very naughty powerpc register"
-
-isFloatOp :: Operand -> Bool
-isFloatOp (OpReg _ (RegReal (RealRegSingle i))) | i > 31 = True
-isFloatOp (OpReg _ (RegVirtual (VirtualRegF _))) = True
-isFloatOp (OpReg _ (RegVirtual (VirtualRegD _))) = True
-isFloatOp _ = False
-
-pprInstr :: IsDoc doc => Platform -> Instr -> doc
-pprInstr platform instr = case instr of
-  -- Meta Instructions ---------------------------------------------------------
-  -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable
-  COMMENT s  -> dualDoc (asmComment s) empty
-  MULTILINE_COMMENT s -> dualDoc (asmMultilineComment s) empty
-  ANN d i -> dualDoc (pprInstr platform i <+> asmDoubleslashComment d) (pprInstr platform i)
-
-  LOCATION file line' col _name
-    -> line (text "\t.loc" <+> int file <+> int line' <+> int col)
-  DELTA d   -> dualDoc (asmComment $ text "\tdelta = " <> int d) empty
-               -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable
-  NEWBLOCK _ -> panic "PprInstr: NEWBLOCK"
-  LDATA _ _  -> panic "pprInstr: LDATA"
-
-  -- Pseudo Instructions -------------------------------------------------------
-
-  PUSH_STACK_FRAME -> lines_ [text "\tstp x29, x30, [sp, #-16]!",
-                              text "\tmov x29, sp"]
-
-  POP_STACK_FRAME -> line $ text "\tldp x29, x30, [sp], #16"
-  -- ===========================================================================
-  -- AArch64 Instruction Set
-  -- 1. Arithmetic Instructions ------------------------------------------------
-  ADD  o1 o2 o3
-    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfadd") o1 o2 o3
-    | otherwise -> op3 (text "\tadd") o1 o2 o3
-  CMN  o1 o2    -> op2 (text "\tcmn") o1 o2
-  CMP  o1 o2
-    | isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfcmp") o1 o2
-    | otherwise -> op2 (text "\tcmp") o1 o2
-  MSUB o1 o2 o3 o4 -> op4 (text "\tmsub") o1 o2 o3 o4
-  MUL  o1 o2 o3
-    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfmul") o1 o2 o3
-    | otherwise -> op3 (text "\tmul") o1 o2 o3
-  SMULH o1 o2 o3 -> op3 (text "\tsmulh") o1 o2 o3
-  SMULL o1 o2 o3 -> op3 (text "\tsmull") o1 o2 o3
-  NEG  o1 o2
-    | isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfneg") o1 o2
-    | otherwise -> op2 (text "\tneg") o1 o2
-  SDIV o1 o2 o3 | isFloatOp o1 && isFloatOp o2 && isFloatOp o3
-    -> op3 (text "\tfdiv") o1 o2 o3
-  SDIV o1 o2 o3 -> op3 (text "\tsdiv") o1 o2 o3
-
-  SUB  o1 o2 o3
-    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfsub") o1 o2 o3
-    | otherwise -> op3 (text "\tsub")  o1 o2 o3
-  UDIV o1 o2 o3 -> op3 (text "\tudiv") o1 o2 o3
-
-  -- 2. Bit Manipulation Instructions ------------------------------------------
-  SBFM o1 o2 o3 o4 -> op4 (text "\tsbfm") o1 o2 o3 o4
-  UBFM o1 o2 o3 o4 -> op4 (text "\tubfm") o1 o2 o3 o4
-  -- signed and unsigned bitfield extract
-  SBFX o1 o2 o3 o4 -> op4 (text "\tsbfx") o1 o2 o3 o4
-  UBFX o1 o2 o3 o4 -> op4 (text "\tubfx") o1 o2 o3 o4
-  SXTB o1 o2       -> op2 (text "\tsxtb") o1 o2
-  UXTB o1 o2       -> op2 (text "\tuxtb") o1 o2
-  SXTH o1 o2       -> op2 (text "\tsxth") o1 o2
-  UXTH o1 o2       -> op2 (text "\tuxth") o1 o2
-
-  -- 3. Logical and Move Instructions ------------------------------------------
-  AND o1 o2 o3  -> op3 (text "\tand") o1 o2 o3
-  ANDS o1 o2 o3 -> op3 (text "\tands") o1 o2 o3
-  ASR o1 o2 o3  -> op3 (text "\tasr") o1 o2 o3
-  BIC o1 o2 o3  -> op3 (text "\tbic") o1 o2 o3
-  BICS o1 o2 o3 -> op3 (text "\tbics") o1 o2 o3
-  EON o1 o2 o3  -> op3 (text "\teon") o1 o2 o3
-  EOR o1 o2 o3  -> op3 (text "\teor") o1 o2 o3
-  LSL o1 o2 o3  -> op3 (text "\tlsl") o1 o2 o3
-  LSR o1 o2 o3  -> op3 (text "\tlsr") o1 o2 o3
-  MOV o1 o2
-    | isFloatOp o1 || isFloatOp o2 -> op2 (text "\tfmov") o1 o2
-    | otherwise                    -> op2 (text "\tmov") o1 o2
-  MOVK o1 o2    -> op2 (text "\tmovk") o1 o2
-  MVN o1 o2     -> op2 (text "\tmvn") o1 o2
-  ORN o1 o2 o3  -> op3 (text "\torn") o1 o2 o3
-  ORR o1 o2 o3  -> op3 (text "\torr") o1 o2 o3
-  ROR o1 o2 o3  -> op3 (text "\tror") o1 o2 o3
-  TST o1 o2     -> op2 (text "\ttst") o1 o2
-
-  -- 4. Branch Instructions ----------------------------------------------------
-  J t            -> pprInstr platform (B t)
-  B (TBlock bid) -> line $ text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
-  B (TLabel lbl) -> line $ text "\tb" <+> pprAsmLabel platform lbl
-  B (TReg r)     -> line $ text "\tbr" <+> pprReg W64 r
-
-  BL (TBlock bid) _ _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
-  BL (TLabel lbl) _ _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl
-  BL (TReg r)     _ _ -> line $ text "\tblr" <+> pprReg W64 r
-
-  BCOND c (TBlock bid) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
-  BCOND c (TLabel lbl) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform lbl
-  BCOND _ (TReg _)     -> panic "AArch64.ppr: No conditional branching to registers!"
-
-  -- 5. Atomic Instructions ----------------------------------------------------
-  -- 6. Conditional Instructions -----------------------------------------------
-  CSET o c  -> line $ text "\tcset" <+> pprOp platform o <> comma <+> pprCond c
-
-  CBZ o (TBlock bid) -> line $ text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
-  CBZ o (TLabel lbl) -> line $ text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl
-  CBZ _ (TReg _)     -> panic "AArch64.ppr: No conditional (cbz) branching to registers!"
-
-  CBNZ o (TBlock bid) -> line $ text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))
-  CBNZ o (TLabel lbl) -> line $ text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl
-  CBNZ _ (TReg _)     -> panic "AArch64.ppr: No conditional (cbnz) branching to registers!"
-
-  -- 7. Load and Store Instructions --------------------------------------------
-  -- NOTE: GHC may do whacky things where it only load the lower part of an
-  --       address. Not observing the correct size when loading will lead
-  --       inevitably to crashes.
-  STR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->
-    op2 (text "\tstrb") o1 o2
-  STR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->
-    op2 (text "\tstrh") o1 o2
-  STR _f o1 o2 -> op2 (text "\tstr") o1 o2
-
-#if defined(darwin_HOST_OS)
-  LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->
-    op_adrp o1 (pprAsmLabel platform lbl <> text "@gotpage") $$
-    op_ldr o1 (pprAsmLabel platform lbl <> text "@gotpageoff") $$
-    op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits.
-
-  LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl ->
-    op_adrp o1 (pprAsmLabel platform lbl <> text "@gotpage") $$
-    op_ldr o1 (pprAsmLabel platform lbl <> text "@gotpageoff") $$
-    op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits.
-
-  LDR _f o1 (OpImm (ImmIndex lbl off)) ->
-    op_adrp o1 (pprAsmLabel platform lbl <> text "@page") $$
-    op_add o1 (pprAsmLabel platform lbl <> text "@pageoff") $$
-    op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits.
-
-  LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->
-    op_adrp o1 (pprAsmLabel platform lbl <> text "@gotpage") $$
-    op_ldr o1 (pprAsmLabel platform lbl <> text "@gotpageoff")
-
-  LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl ->
-    op_adrp o1 (pprAsmLabel platform lbl <> text "@gotpage") $$
-    op_ldr o1 (pprAsmLabel platform lbl <> text "@gotpageoff")
-
-  LDR _f o1 (OpImm (ImmCLbl lbl)) ->
-    op_adrp o1 (pprAsmLabel platform lbl <> text "@page") $$
-    op_add o1 (pprAsmLabel platform lbl <> text "@pageoff")
-
-#else
-  LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->
-    op_adrp o1 (text ":got:" <> pprAsmLabel platform lbl) $$
-    op_ldr o1 (text ":got_lo12:" <> pprAsmLabel platform lbl) $$
-    op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits.
-
-  LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl ->
-    op_adrp o1 (text ":got:" <> pprAsmLabel platform lbl) $$
-    op_ldr o1 (text ":got_lo12:" <> pprAsmLabel platform lbl) $$
-    op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits.
-
-  LDR _f o1 (OpImm (ImmIndex lbl off)) ->
-    op_adrp o1 (pprAsmLabel platform lbl) $$
-    op_add o1 (text ":lo12:" <> pprAsmLabel platform lbl) $$
-    op_add o1 (char '#' <> int off) -- TODO: check that off is in 12bits.
-
-  LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->
-    op_adrp o1 (text ":got:" <> pprAsmLabel platform lbl) $$
-    op_ldr o1 (text ":got_lo12:" <> pprAsmLabel platform lbl)
-
-  LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl ->
-    op_adrp o1 (text ":got:" <> pprAsmLabel platform lbl) $$
-    op_ldr o1 (text ":got_lo12:" <> pprAsmLabel platform lbl)
-
-  LDR _f o1 (OpImm (ImmCLbl lbl)) ->
-    op_adrp o1 (pprAsmLabel platform lbl) $$
-    op_add o1 (text ":lo12:" <> pprAsmLabel platform lbl)
-
-#endif
-
-  LDR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->
-    op2 (text "\tldrb") o1 o2
-  LDR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->
-    op2 (text "\tldrh") o1 o2
-  LDR _f o1 o2 -> op2 (text "\tldr") o1 o2
-
-  STP _f o1 o2 o3 -> op3 (text "\tstp") o1 o2 o3
-  LDP _f o1 o2 o3 -> op3 (text "\tldp") o1 o2 o3
-
-  -- 8. Synchronization Instructions -------------------------------------------
-  DMBSY -> line $ text "\tdmb sy"
-  -- 9. Floating Point Instructions --------------------------------------------
-  FCVT o1 o2 -> op2 (text "\tfcvt") o1 o2
-  SCVTF o1 o2 -> op2 (text "\tscvtf") o1 o2
-  FCVTZS o1 o2 -> op2 (text "\tfcvtzs") o1 o2
-  FABS o1 o2 -> op2 (text "\tfabs") o1 o2
- where op2 op o1 o2        = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2
-       op3 op o1 o2 o3     = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3
-       op4 op o1 o2 o3 o4  = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4
-       op_ldr o1 rest      = line $ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> rest <> text "]"
-       op_adrp o1 rest     = line $ text "\tadrp" <+> pprOp platform o1 <> comma <+> rest
-       op_add o1 rest      = line $ text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> rest
-
-pprBcond :: IsLine doc => Cond -> doc
-pprBcond c = text "b." <> pprCond c
-
-pprCond :: IsLine doc => Cond -> doc
-pprCond c = case c of
-  ALWAYS -> text "al" -- Always
-  EQ     -> text "eq" -- Equal
-  NE     -> text "ne" -- Not Equal
-
-  SLT    -> text "lt" -- Signed less than                  ; Less than, or unordered
-  SLE    -> text "le" -- Signed less than or equal         ; Less than or equal, or unordered
-  SGE    -> text "ge" -- Signed greater than or equal      ; Greater than or equal
-  SGT    -> text "gt" -- Signed greater than               ; Greater than
-
-  ULT    -> text "lo" -- Carry clear/ unsigned lower       ; less than
-  ULE    -> text "ls" -- Unsigned lower or same            ; Less than or equal
-  UGE    -> text "hs" -- Carry set/unsigned higher or same ; Greater than or equal, or unordered
-  UGT    -> text "hi" -- Unsigned higher                   ; Greater than, or unordered
-
-  NEVER  -> text "nv" -- Never
-  VS     -> text "vs" -- Overflow                          ; Unordered (at least one NaN operand)
-  VC     -> text "vc" -- No overflow                       ; Not unordered
-
-  -- Ordered variants.  Respecting NaN.
-  OLT    -> text "mi"
-  OLE    -> text "ls"
-  OGE    -> text "ge"
-  OGT    -> text "gt"
-
-  -- Unordered
-  UOLT   -> text "lt"
-  UOLE   -> text "le"
-  UOGE   -> text "pl"
-  UOGT   -> text "hi"
diff --git a/compiler/GHC/CmmToAsm/AArch64/RegInfo.hs b/compiler/GHC/CmmToAsm/AArch64/RegInfo.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/AArch64/RegInfo.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-module GHC.CmmToAsm.AArch64.RegInfo where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.AArch64.Instr
-import GHC.Cmm.BlockId
-import GHC.Cmm
-
-import GHC.Utils.Outputable
-
-data JumpDest = DestBlockId BlockId
-
--- Debug Instance
-instance Outputable JumpDest where
-  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid
-
--- TODO: documen what this does. See Ticket 19914
-getJumpDestBlockId :: JumpDest -> Maybe BlockId
-getJumpDestBlockId (DestBlockId bid) = Just bid
-
--- TODO: document what this does. See Ticket 19914
-canShortcut :: Instr -> Maybe JumpDest
-canShortcut _ = Nothing
-
--- TODO: document what this does. See Ticket 19914
-shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics
-shortcutStatics _ other_static = other_static
-
--- TODO: document what this does. See Ticket 19914
-shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
-shortcutJump _ other = other
diff --git a/compiler/GHC/CmmToAsm/AArch64/Regs.hs b/compiler/GHC/CmmToAsm/AArch64/Regs.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/AArch64/Regs.hs
+++ /dev/null
@@ -1,155 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module GHC.CmmToAsm.AArch64.Regs where
-
-import GHC.Prelude
-import GHC.Data.FastString
-
-import GHC.Platform.Reg
-import GHC.Platform.Reg.Class
-import GHC.CmmToAsm.Format
-
-import GHC.Cmm
-import GHC.Cmm.CLabel           ( CLabel )
-import GHC.Types.Unique
-
-import GHC.Platform.Regs
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Platform
-
-allMachRegNos   :: [RegNo]
-allMachRegNos   = [0..31] ++ [32..63]
--- allocatableRegs is allMachRegNos with the fixed-use regs removed.
--- i.e., these are the regs for which we are prepared to allow the
--- register allocator to attempt to map VRegs to.
-allocatableRegs :: Platform -> [RealReg]
-allocatableRegs platform
-   = let isFree i = freeReg platform i
-     in  map RealRegSingle $ filter isFree allMachRegNos
-
-
--- argRegs is the set of regs which are read for an n-argument call to C.
-allGpArgRegs :: [Reg]
-allGpArgRegs = map regSingle [0..7]
-allFpArgRegs :: [Reg]
-allFpArgRegs = map regSingle [32..39]
-
--- STG:
--- 19: Base
--- 20: Sp
--- 21: Hp
--- 22-27: R1-R6
--- 28: SpLim
-
--- This is the STG Sp reg.
--- sp :: Reg
--- sp = regSingle 20
-
--- addressing modes ------------------------------------------------------------
-
-data AddrMode
-        = AddrRegReg    Reg Reg
-        | AddrRegImm    Reg Imm
-        | AddrReg       Reg
-        deriving (Eq, Show)
-
--- -----------------------------------------------------------------------------
--- Immediates
-
-data Imm
-  = ImmInt      Int
-  | ImmInteger  Integer     -- Sigh.
-  | ImmCLbl     CLabel      -- AbstractC Label (with baggage)
-  | ImmLit      FastString
-  | ImmIndex    CLabel Int
-  | ImmFloat    Rational
-  | ImmDouble   Rational
-  | ImmConstantSum Imm Imm
-  | ImmConstantDiff Imm Imm
-  deriving (Eq, Show)
-
-strImmLit :: FastString -> Imm
-strImmLit s = ImmLit s
-
-
-litToImm :: CmmLit -> Imm
-litToImm (CmmInt i w)        = ImmInteger (narrowS w i)
-                -- narrow to the width: a CmmInt might be out of
-                -- range, but we assume that ImmInteger only contains
-                -- in-range values.  A signed value should be fine here.
-litToImm (CmmFloat f W32)    = ImmFloat f
-litToImm (CmmFloat f W64)    = ImmDouble f
-litToImm (CmmLabel l)        = ImmCLbl l
-litToImm (CmmLabelOff l off) = ImmIndex l off
-litToImm (CmmLabelDiffOff l1 l2 off _)
-                             = ImmConstantSum
-                               (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
-                               (ImmInt off)
-litToImm _                   = panic "AArch64.Regs.litToImm: no match"
-
-
--- == To satisfy GHC.CmmToAsm.Reg.Target =======================================
-
--- squeese functions for the graph allocator -----------------------------------
--- | regSqueeze_class reg
---      Calculate the maximum number of register colors that could be
---      denied to a node of this class due to having this reg
---      as a neighbour.
---
-{-# INLINE virtualRegSqueeze #-}
-virtualRegSqueeze :: RegClass -> VirtualReg -> Int
-virtualRegSqueeze cls vr
- = case cls of
-        RcInteger
-         -> case vr of
-                VirtualRegI{}           -> 1
-                VirtualRegHi{}          -> 1
-                _other                  -> 0
-
-        RcDouble
-         -> case vr of
-                VirtualRegD{}           -> 1
-                VirtualRegF{}           -> 0
-                _other                  -> 0
-
-        _other -> 0
-
-{-# INLINE realRegSqueeze #-}
-realRegSqueeze :: RegClass -> RealReg -> Int
-realRegSqueeze cls rr
- = case cls of
-        RcInteger
-         -> case rr of
-                RealRegSingle regNo
-                        | regNo < 32    -> 1     -- first fp reg is 32
-                        | otherwise     -> 0
-
-        RcDouble
-         -> case rr of
-                RealRegSingle regNo
-                        | regNo < 32    -> 0
-                        | otherwise     -> 1
-
-        _other -> 0
-
-mkVirtualReg :: Unique -> Format -> VirtualReg
-mkVirtualReg u format
-   | not (isFloatFormat format) = VirtualRegI u
-   | otherwise
-   = case format of
-        FF32    -> VirtualRegD u
-        FF64    -> VirtualRegD u
-        _       -> panic "AArch64.mkVirtualReg"
-
-{-# INLINE classOfRealReg      #-}
-classOfRealReg :: RealReg -> RegClass
-classOfRealReg (RealRegSingle i)
-        | i < 32        = RcInteger
-        | otherwise     = RcDouble
-
-regDotColor :: RealReg -> SDoc
-regDotColor reg
- = case classOfRealReg reg of
-        RcInteger       -> text "blue"
-        RcFloat         -> text "red"
-        RcDouble        -> text "green"
diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/BlockLayout.hs
+++ /dev/null
@@ -1,924 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-
---
--- Copyright (c) 2018 Andreas Klebinger
---
-
-module GHC.CmmToAsm.BlockLayout
-    ( sequenceTop, backendMaintainsCfg)
-where
-
-import GHC.Prelude hiding (head, init, last, tail)
-
-import GHC.Platform
-
-import GHC.CmmToAsm.Instr
-import GHC.CmmToAsm.Monad
-import GHC.CmmToAsm.CFG
-import GHC.CmmToAsm.Types
-import GHC.CmmToAsm.Config
-
-import GHC.Cmm
-import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Label
-
-import GHC.Types.Unique.FM
-
-import GHC.Data.Graph.Directed
-import GHC.Data.Maybe
-import GHC.Data.List.SetOps (removeDups)
-import GHC.Data.OrdList
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Misc
-
-import Data.List (sortOn, sortBy, nub)
-import qualified Data.List as Partial (head, tail)
-import Data.List.NonEmpty (nonEmpty)
-import qualified Data.List.NonEmpty as NE
-import Data.Foldable (toList)
-import qualified Data.Set as Set
-import Data.STRef
-import Control.Monad.ST.Strict
-import Control.Monad (foldM, unless)
-import GHC.Data.UnionFind
-
-{-
-  Note [CFG based code layout]
-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-  The major steps in placing blocks are as follow:
-  * Compute a CFG based on the Cmm AST, see getCfgProc.
-    This CFG will have edge weights representing a guess
-    on how important they are.
-  * After we convert Cmm to Asm we run `optimizeCFG` which
-    adds a few more "educated guesses" to the equation.
-  * Then we run loop analysis on the CFG (`loopInfo`) which tells us
-    about loop headers, loop nesting levels and the sort.
-  * Based on the CFG and loop information refine the edge weights
-    in the CFG and normalize them relative to the most often visited
-    node. (See `mkGlobalWeights`)
-  * Feed this CFG into the block layout code (`sequenceTop`) in this
-    module. Which will then produce a code layout based on the input weights.
-
-
-  Note [Chain based CFG serialization]
-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  For additional information also look at
-  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/code-layout
-
-  We have a CFG with edge weights based on which we try to place blocks next to
-  each other.
-
-  Edge weights not only represent likelihood of control transfer between blocks
-  but also how much a block would benefit from being placed sequentially after
-  it's predecessor.
-  For example blocks which are preceded by an info table are more likely to end
-  up in a different cache line than their predecessor and we can't eliminate the jump
-  so there is less benefit to placing them sequentially.
-
-  For example consider this example:
-
-  A:  ...
-      jmp cond D (weak successor)
-      jmp B
-  B:  ...
-      jmp C
-  C:  ...
-      jmp X
-  D:  ...
-      jmp B (weak successor)
-
-  We determine a block layout by building up chunks (calling them chains) of
-  possible control flows for which blocks will be placed sequentially.
-
-  Eg for our example we might end up with two chains like:
-  [A->B->C->X],[D]. Blocks inside chains will always be placed sequentially.
-  However there is no particular order in which chains are placed since
-  (hopefully) the blocks for which sequentiality is important have already
-  been placed in the same chain.
-
-  -----------------------------------------------------------------------------
-     1) First try to create a list of good chains.
-  -----------------------------------------------------------------------------
-
-  Good chains are these which allow us to eliminate jump instructions.
-  Which further eliminate often executed jumps first.
-
-  We do so by:
-
-  *)  Ignore edges which represent instructions which can not be replaced
-      by fall through control flow. Primarily calls and edges to blocks which
-      are prefixed by a info table we have to jump across.
-
-  *)  Then process remaining edges in order of frequency taken and:
-
-    +)  If source and target have not been placed build a new chain from them.
-
-    +)  If source and target have been placed, and are ends of differing chains
-        try to merge the two chains.
-
-    +)  If one side of the edge is a end/front of a chain, add the other block of
-        to edge to the same chain
-
-        Eg if we look at edge (B -> C) and already have the chain (A -> B)
-        then we extend the chain to (A -> B -> C).
-
-    +)  If the edge was used to modify or build a new chain remove the edge from
-        our working list.
-
-  *) If there any blocks not being placed into a chain after these steps we place
-     them into a chain consisting of only this block.
-
-  Ranking edges by their taken frequency, if
-  two edges compete for fall through on the same target block, the one taken
-  more often will automatically win out. Resulting in fewer instructions being
-  executed.
-
-  Creating singleton chains is required for situations where we have code of the
-  form:
-
-    A: goto B:
-    <infoTable>
-    B: goto C:
-    <infoTable>
-    C: ...
-
-  As the code in block B is only connected to the rest of the program via edges
-  which will be ignored in this step we make sure that B still ends up in a chain
-  this way.
-
-  -----------------------------------------------------------------------------
-     2) We also try to fuse chains.
-  -----------------------------------------------------------------------------
-
-  As a result from the above step we still end up with multiple chains which
-  represent sequential control flow chunks. But they are not yet suitable for
-  code layout as we need to place *all* blocks into a single sequence.
-
-  In this step we combine chains result from the above step via these steps:
-
-  *)  Look at the ranked list of *all* edges, including calls/jumps across info tables
-      and the like.
-
-  *)  Look at each edge and
-
-    +) Given an edge (A -> B) try to find two chains for which
-      * Block A is at the end of one chain
-      * Block B is at the front of the other chain.
-    +) If we find such a chain we "fuse" them into a single chain, remove the
-       edge from working set and continue.
-    +) If we can't find such chains we skip the edge and continue.
-
-  -----------------------------------------------------------------------------
-     3) Place indirect successors (neighbours) after each other
-  -----------------------------------------------------------------------------
-
-  We might have chains [A,B,C,X],[E] in a CFG of the sort:
-
-    A ---> B ---> C --------> X(exit)
-                   \- ->E- -/
-
-  While E does not follow X it's still beneficial to place them near each other.
-  This can be advantageous if eg C,X,E will end up in the same cache line.
-
-
-  Note [Triangle Control Flow]
-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  Checking if an argument is already evaluated leads to a somewhat
-  special case  which looks like this:
-
-    A:
-        if (R1 & 7 != 0) goto Leval; else goto Lwork;
-    Leval: // global
-        call (I64[R1])(R1) returns to Lwork, args: 8, res: 8, upd: 8;
-    Lwork: // global
-        ...
-
-        A
-        |\
-        | Leval
-        |/ - (This edge can be missing because of optimizations)
-        Lwork
-
-  Once we hit the metal the call instruction is just 2-3 bytes large
-  depending on the register used. So we lay out the assembly like this:
-
-        movq %rbx,%rax
-        andl $7,%eax
-        cmpq $1,%rax
-        jne Lwork
-    Leval:
-        jmp *(%rbx) # encoded in 2-3 bytes.
-    <info table>
-    Lwork:
-        ...
-
-  We could explicitly check for this control flow pattern.
-
-  This is advantageous because:
-  * It's optimal if the argument isn't evaluated.
-  * If it's evaluated we only have the extra cost of jumping over
-    the 2-3 bytes for the call.
-  * Guarantees the smaller encoding for the conditional jump.
-
-  However given that Lwork usually has an info table we
-  penalize this edge. So Leval should get placed first
-  either way and things work out for the best.
-
-  Optimizing for the evaluated case instead would penalize
-  the other code path. It adds an jump as we can't fall through
-  to Lwork because of the info table.
-  Assuming that Lwork is large the chance that the "call" ends up
-  in the same cache line is also fairly small.
-
-
-  Note [Layout relevant edge weights]
-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  The input to the chain based code layout algorithm is a CFG
-  with edges annotated with their frequency. The frequency
-  of traversal corresponds quite well to the cost of not placing
-  the connected blocks next to each other.
-
-  However even if having the same frequency certain edges are
-  inherently more or less relevant to code layout.
-
-  In particular:
-
-  * Edges which cross an info table are less relevant than others.
-
-    If we place the blocks across this edge next to each other
-    they are still separated by the info table which negates
-    much of the benefit. It makes it less likely both blocks
-    will share a cache line reducing the benefits from locality.
-    But it also prevents us from eliminating jump instructions.
-
-  * Conditional branches and switches are slightly less relevant.
-
-    We can completely remove unconditional jumps by placing them
-    next to each other. This is not true for conditional branch edges.
-    We apply a small modifier to them to ensure edges for which we can
-    eliminate the overhead completely are considered first. See also #18053.
-
-  * Edges constituted by a call are ignored.
-
-    Considering these hardly helped with performance and ignoring
-    them helps quite a bit to improve compiler performance.
-
-  So we perform a preprocessing step where we apply a multiplicator
-  to these kinds of edges.
-
-  -}
-
-
--- | Look at X number of blocks in two chains to determine
---   if they are "neighbours".
-neighbourOverlapp :: Int
-neighbourOverlapp = 2
-
--- | Maps blocks near the end of a chain to it's chain AND
--- the other blocks near the end.
--- [A,B,C,D,E] Gives entries like (B -> ([A,B], [A,B,C,D,E]))
--- where [A,B] are blocks in the end region of a chain.
--- This is cheaper then recomputing the ends multiple times.
-type FrontierMap = LabelMap ([BlockId],BlockChain)
-
--- | A non empty ordered sequence of basic blocks.
---   It is suitable for serialization in this order.
---
---   We use OrdList instead of [] to allow fast append on both sides
---   when combining chains.
-newtype BlockChain
-    = BlockChain { chainBlocks :: (OrdList BlockId) }
-
--- All chains are constructed the same way so comparison
--- including structure is faster.
-instance Eq BlockChain where
-    BlockChain b1 == BlockChain b2 = strictlyEqOL b1 b2
-
--- Useful for things like sets and debugging purposes, sorts by blocks
--- in the chain.
-instance Ord (BlockChain) where
-   (BlockChain lbls1) `compare` (BlockChain lbls2)
-       = assert (toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2) $
-         strictlyOrdOL lbls1 lbls2
-
-instance Outputable (BlockChain) where
-    ppr (BlockChain blks) =
-        parens (text "Chain:" <+> ppr (fromOL $ blks) )
-
-chainFoldl :: (b -> BlockId -> b) -> b -> BlockChain -> b
-chainFoldl f z (BlockChain blocks) = foldl' f z blocks
-
-noDups :: [BlockChain] -> Bool
-noDups chains =
-    let chainBlocks = concatMap chainToBlocks chains :: [BlockId]
-        (_blocks, dups) = removeDups compare chainBlocks
-    in if null dups then True
-        else pprTrace "Duplicates:" (ppr (map toList dups) $$ text "chains" <+> ppr chains ) False
-
-inFront :: BlockId -> BlockChain -> Bool
-inFront bid (BlockChain seq)
-  = headOL seq == bid
-
-chainSingleton :: BlockId -> BlockChain
-chainSingleton lbl
-    = BlockChain (unitOL lbl)
-
-chainFromList :: [BlockId] -> BlockChain
-chainFromList = BlockChain . toOL
-
-chainSnoc :: BlockChain -> BlockId -> BlockChain
-chainSnoc (BlockChain blks) lbl
-  = BlockChain (blks `snocOL` lbl)
-
-chainCons :: BlockId -> BlockChain -> BlockChain
-chainCons lbl (BlockChain blks)
-  = BlockChain (lbl `consOL` blks)
-
-chainConcat :: BlockChain -> BlockChain -> BlockChain
-chainConcat (BlockChain blks1) (BlockChain blks2)
-  = BlockChain (blks1 `appOL` blks2)
-
-chainToBlocks :: BlockChain -> [BlockId]
-chainToBlocks (BlockChain blks) = fromOL blks
-
--- | Given the Chain A -> B -> C -> D and we break at C
---   we get the two Chains (A -> B, C -> D) as result.
-breakChainAt :: BlockId -> BlockChain
-             -> (BlockChain,BlockChain)
-breakChainAt bid (BlockChain blks)
-    | not (bid == Partial.head rblks)
-    = panic "Block not in chain"
-    | otherwise
-    = (BlockChain (toOL lblks),
-       BlockChain (toOL rblks))
-  where
-    (lblks, rblks) = break (\lbl -> lbl == bid) (fromOL blks)
-
-takeR :: Int -> BlockChain -> [BlockId]
-takeR n (BlockChain blks) =
-    take n . fromOLReverse $ blks
-
-takeL :: Int -> BlockChain -> [BlockId]
-takeL n (BlockChain blks) =
-    take n . fromOL $ blks
-
-
--- Note [Combining neighborhood chains]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- See also Note [Chain based CFG serialization]
--- We have the chains (A-B-C-D) and (E-F) and an Edge C->E.
---
--- While placing the latter after the former doesn't result in sequential
--- control flow it is still beneficial. As block C and E might end
--- up in the same cache line.
---
--- So we place these chains next to each other even if we can't fuse them.
---
---   A -> B -> C -> D
---             v
---             - -> E -> F ...
---
--- A simple heuristic to chose which chains we want to combine:
---   * Process edges in descending priority.
---   * Check if there is a edge near the end of one chain which goes
---     to a block near the start of another edge.
---
--- While we could take into account the space between the two blocks which
--- share an edge this blows up compile times quite a bit. It requires
--- us to find all edges between two chains, check the distance for all edges,
--- rank them based on the distance and only then we can select two chains
--- to combine. Which would add a lot of complexity for little gain.
---
--- So instead we just rank by the strength of the edge and use the first pair we
--- find.
-
--- | For a given list of chains and edges try to combine chains with strong
---   edges between them.
-combineNeighbourhood  :: [CfgEdge] -- ^ Edges to consider
-                      -> [BlockChain] -- ^ Current chains of blocks
-                      -> ([BlockChain], Set.Set (BlockId,BlockId))
-                      -- ^ Resulting list of block chains, and a set of edges which
-                      -- were used to fuse chains and as such no longer need to be
-                      -- considered.
-combineNeighbourhood edges chains
-    = -- pprTraceIt "Neighbours" $
-    --   pprTrace "combineNeighbours" (ppr edges) $
-      applyEdges edges endFrontier startFrontier (Set.empty)
-    where
-        --Build maps from chain ends to chains
-        endFrontier, startFrontier :: FrontierMap
-        endFrontier =
-            mapFromList $ concatMap (\chain ->
-                                let ends = getEnds chain :: [BlockId]
-                                    entry = (ends,chain)
-                                in map (\x -> (x,entry)) ends ) chains
-        startFrontier =
-            mapFromList $ concatMap (\chain ->
-                                let front = getFronts chain
-                                    entry = (front,chain)
-                                in map (\x -> (x,entry)) front) chains
-        applyEdges :: [CfgEdge] -> FrontierMap -> FrontierMap -> Set.Set (BlockId, BlockId)
-                   -> ([BlockChain], Set.Set (BlockId,BlockId))
-        applyEdges [] chainEnds _chainFronts combined =
-            (ordNub $ map snd $ mapElems chainEnds, combined)
-        applyEdges ((CfgEdge from to _w):edges) chainEnds chainFronts combined
-            | Just (c1_e,c1) <- mapLookup from chainEnds
-            , Just (c2_f,c2) <- mapLookup to chainFronts
-            , c1 /= c2 -- Avoid trying to concat a chain with itself.
-            = let newChain = chainConcat c1 c2
-                  newChainFrontier = getFronts newChain
-                  newChainEnds = getEnds newChain
-                  newFronts :: FrontierMap
-                  newFronts =
-                    let withoutOld =
-                            foldl' (\m b -> mapDelete b m :: FrontierMap) chainFronts (c2_f ++ getFronts c1)
-                        entry =
-                            (newChainFrontier,newChain) --let bound to ensure sharing
-                    in foldl' (\m x -> mapInsert x entry m)
-                              withoutOld newChainFrontier
-
-                  newEnds =
-                    let withoutOld = foldl' (\m b -> mapDelete b m) chainEnds (c1_e ++ getEnds c2)
-                        entry = (newChainEnds,newChain) --let bound to ensure sharing
-                    in foldl' (\m x -> mapInsert x entry m)
-                              withoutOld newChainEnds
-              in
-                -- pprTrace "ApplyEdges"
-                --  (text "before" $$
-                --   text "fronts" <+> ppr chainFronts $$
-                --   text "ends" <+> ppr chainEnds $$
-
-                --   text "various" $$
-                --   text "newChain" <+> ppr newChain $$
-                --   text "newChainFrontier" <+> ppr newChainFrontier $$
-                --   text "newChainEnds" <+> ppr newChainEnds $$
-                --   text "drop" <+> ppr ((c2_f ++ getFronts c1) ++ (c1_e ++ getEnds c2)) $$
-
-                --   text "after" $$
-                --   text "fronts" <+> ppr newFronts $$
-                --   text "ends" <+> ppr newEnds
-                --   )
-                 applyEdges edges newEnds newFronts (Set.insert (from,to) combined)
-            | otherwise
-            = applyEdges edges chainEnds chainFronts combined
-
-        getFronts chain = takeL neighbourOverlapp chain
-        getEnds chain = takeR neighbourOverlapp chain
-
--- In the last stop we combine all chains into a single one.
--- Trying to place chains with strong edges next to each other.
-mergeChains :: [CfgEdge] -> [BlockChain]
-            -> (BlockChain)
-mergeChains edges chains
-    = runST $ do
-        let addChain m0 chain = do
-                ref <- fresh chain
-                return $ chainFoldl (\m' b -> mapInsert b ref m') m0 chain
-        chainMap' <- foldM (\m0 c -> addChain m0 c) mapEmpty chains
-        merge edges chainMap'
-    where
-        -- We keep a map from ALL blocks to their respective chain (sigh)
-        -- This is required since when looking at an edge we need to find
-        -- the associated chains quickly.
-        -- We use a union-find data structure to do this efficiently.
-
-        merge :: forall s. [CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain
-        merge [] chains = do
-            chains' <- mapM find =<< (nub <$> (mapM repr $ mapElems chains)) :: ST s [BlockChain]
-            return $ foldl' chainConcat (Partial.head chains') (Partial.tail chains')
-        merge ((CfgEdge from to _):edges) chains
-        --   | pprTrace "merge" (ppr (from,to) <> ppr chains) False
-        --   = undefined
-          = do
-            same <- equivalent cFrom cTo
-            unless same $ do
-              cRight <- find cTo
-              cLeft <- find cFrom
-              new_point <- fresh (chainConcat cLeft cRight)
-              union cTo new_point
-              union cFrom new_point
-            merge edges chains
-          where
-            cFrom = expectJust "mergeChains:chainMap:from" $ mapLookup from chains
-            cTo = expectJust "mergeChains:chainMap:to"   $ mapLookup to   chains
-
-
--- See Note [Chain based CFG serialization] for the general idea.
--- This creates and fuses chains at the same time for performance reasons.
-
--- Try to build chains from a list of edges.
--- Edges must be sorted **descending** by their priority.
--- Returns the constructed chains, along with all edges which
--- are irrelevant past this point, this information doesn't need
--- to be complete - it's only used to speed up the process.
--- An Edge is irrelevant if the ends are part of the same chain.
--- We say these edges are already linked
-buildChains :: [CfgEdge] -> [BlockId]
-            -> ( LabelMap BlockChain  -- Resulting chains, indexed by end if chain.
-               , Set.Set (BlockId, BlockId)) --List of fused edges.
-buildChains edges blocks
-  = runST $ buildNext setEmpty mapEmpty mapEmpty edges Set.empty
-  where
-    -- buildNext builds up chains from edges one at a time.
-
-    -- We keep a map from the ends of chains to the chains.
-    -- This way we can easily check if an block should be appended to an
-    -- existing chain!
-    -- We store them using STRefs so we don't have to rebuild the spine of both
-    -- maps every time we update a chain.
-    buildNext :: forall s. LabelSet
-              -> LabelMap (STRef s BlockChain) -- Map from end of chain to chain.
-              -> LabelMap (STRef s BlockChain) -- Map from start of chain to chain.
-              -> [CfgEdge] -- Edges to check - ordered by decreasing weight
-              -> Set.Set (BlockId, BlockId) -- Used edges
-              -> ST s   ( LabelMap BlockChain -- Chains by end
-                        , Set.Set (BlockId, BlockId) --List of fused edges
-                        )
-    buildNext placed _chainStarts chainEnds  [] linked = do
-        ends' <- sequence $ mapMap readSTRef chainEnds :: ST s (LabelMap BlockChain)
-        -- Any remaining blocks have to be made to singleton chains.
-        -- They might be combined with other chains later on outside this function.
-        let unplaced = filter (\x -> not (setMember x placed)) blocks
-            singletons = map (\x -> (x,chainSingleton x)) unplaced :: [(BlockId,BlockChain)]
-        return (foldl' (\m (k,v) -> mapInsert k v m) ends' singletons , linked)
-    buildNext placed chainStarts chainEnds (edge:todo) linked
-        | from == to
-        -- We skip self edges
-        = buildNext placed chainStarts chainEnds todo (Set.insert (from,to) linked)
-        | not (alreadyPlaced from) &&
-          not (alreadyPlaced to)
-        = do
-            --pprTraceM "Edge-Chain:" (ppr edge)
-            chain' <- newSTRef $ chainFromList [from,to]
-            buildNext
-                (setInsert to (setInsert from placed))
-                (mapInsert from chain' chainStarts)
-                (mapInsert to chain' chainEnds)
-                todo
-                (Set.insert (from,to) linked)
-
-        | (alreadyPlaced from) &&
-          (alreadyPlaced to)
-        , Just predChain <- mapLookup from chainEnds
-        , Just succChain <- mapLookup to chainStarts
-        , predChain /= succChain -- Otherwise we try to create a cycle.
-          = fuseChain predChain succChain
-
-        | (alreadyPlaced from) &&
-          (alreadyPlaced to)
-          = buildNext placed chainStarts chainEnds todo linked
-
-        | otherwise
-          = findChain
-      where
-        from = edgeFrom edge
-        to   = edgeTo   edge
-        alreadyPlaced blkId = (setMember blkId placed)
-
-        -- Combine two chains into a single one.
-        fuseChain :: STRef s BlockChain -> STRef s BlockChain
-                  -> ST s   ( LabelMap BlockChain -- Chains by end
-                            , Set.Set (BlockId, BlockId) --List of fused edges
-                            )
-        fuseChain fromRef toRef = do
-            fromChain <- readSTRef fromRef
-            toChain <- readSTRef toRef
-            let newChain = chainConcat fromChain toChain
-            ref <- newSTRef newChain
-            let start = Partial.head $ takeL 1 newChain
-            let end = Partial.head $ takeR 1 newChain
-            -- chains <- sequence $ mapMap readSTRef chainStarts
-            -- pprTraceM "pre-fuse chains:" $ ppr chains
-            buildNext
-                placed
-                (mapInsert start ref $ mapDelete to $ chainStarts)
-                (mapInsert end ref $ mapDelete from $ chainEnds)
-                todo
-                (Set.insert (from,to) linked)
-
-
-        --Add the block to a existing chain or creates a new chain
-        findChain :: ST s   ( LabelMap BlockChain -- Chains by end
-                            , Set.Set (BlockId, BlockId) --List of fused edges
-                            )
-        findChain
-          -- We can attach the block to the end of a chain
-          | alreadyPlaced from
-          , Just predChain <- mapLookup from chainEnds
-          = do
-            chain <- readSTRef predChain
-            let newChain = chainSnoc chain to
-            writeSTRef predChain newChain
-            let chainEnds' = mapInsert to predChain $ mapDelete from chainEnds
-            -- chains <- sequence $ mapMap readSTRef chainStarts
-            -- pprTraceM "from chains:" $ ppr chains
-            buildNext (setInsert to placed) chainStarts chainEnds' todo (Set.insert (from,to) linked)
-          -- We can attack it to the front of a chain
-          | alreadyPlaced to
-          , Just succChain <- mapLookup to chainStarts
-          = do
-            chain <- readSTRef succChain
-            let newChain = from `chainCons` chain
-            writeSTRef succChain newChain
-            let chainStarts' = mapInsert from succChain $ mapDelete to chainStarts
-            -- chains <- sequence $ mapMap readSTRef chainStarts'
-            -- pprTraceM "to chains:" $ ppr chains
-            buildNext (setInsert from placed) chainStarts' chainEnds todo (Set.insert (from,to) linked)
-          -- The placed end of the edge is part of a chain already and not an end.
-          | otherwise
-          = do
-            let block    = if alreadyPlaced to then from else to
-            --pprTraceM "Singleton" $ ppr block
-            let newChain = chainSingleton block
-            ref <- newSTRef newChain
-            buildNext (setInsert block placed) (mapInsert block ref chainStarts)
-                      (mapInsert block ref chainEnds) todo (linked)
-            where
-              alreadyPlaced blkId = (setMember blkId placed)
-
--- | Place basic blocks based on the given CFG.
--- See Note [Chain based CFG serialization]
-sequenceChain :: forall a i. Instruction i
-              => LabelMap a -- ^ Keys indicate an info table on the block.
-              -> CFG -- ^ Control flow graph and some meta data.
-              -> [GenBasicBlock i] -- ^ List of basic blocks to be placed.
-              -> [GenBasicBlock i] -- ^ Blocks placed in sequence.
-sequenceChain _info _weights    [] = []
-sequenceChain _info _weights    [x] = [x]
-sequenceChain  info weights     blocks@((BasicBlock entry _):_) =
-    let directEdges :: [CfgEdge]
-        directEdges = sortBy (flip compare) $ mapMaybe relevantWeight (infoEdgeList weights)
-          where
-            -- Apply modifiers to turn edge frequencies into useable weights
-            -- for computing code layout.
-            -- See also Note [Layout relevant edge weights]
-            relevantWeight :: CfgEdge -> Maybe CfgEdge
-            relevantWeight edge@(CfgEdge from to edgeInfo)
-                | (EdgeInfo CmmSource { trans_cmmNode = CmmCall {} } _) <- edgeInfo
-                -- Ignore edges across calls.
-                = Nothing
-                | mapMember to info
-                , w <- edgeWeight edgeInfo
-                -- The payoff is quite small if we jump over an info table
-                = Just (CfgEdge from to edgeInfo { edgeWeight = w/8 })
-                | (EdgeInfo CmmSource { trans_cmmNode = exitNode } _) <- edgeInfo
-                , cantEliminate exitNode
-                , w <- edgeWeight edgeInfo
-                -- A small penalty to edge types which
-                -- we can't optimize away by layout.
-                -- w * 0.96875 == w - w/32
-                = Just (CfgEdge from to edgeInfo { edgeWeight = w * 0.96875 })
-                | otherwise
-                = Just edge
-                where
-                  cantEliminate CmmCondBranch {} = True
-                  cantEliminate CmmSwitch {} = True
-                  cantEliminate _ = False
-
-        blockMap :: LabelMap (GenBasicBlock i)
-        blockMap
-            = foldl' (\m blk@(BasicBlock lbl _ins) ->
-                        mapInsert lbl blk m)
-                     mapEmpty blocks
-
-        (builtChains, builtEdges)
-            = {-# SCC "buildChains" #-}
-              --pprTraceIt "generatedChains" $
-              --pprTrace "blocks" (ppr (mapKeys blockMap)) $
-              buildChains directEdges (mapKeys blockMap)
-
-        rankedEdges :: [CfgEdge]
-        -- Sort descending by weight, remove fused edges
-        rankedEdges =
-            filter (\edge -> not (Set.member (edgeFrom edge,edgeTo edge) builtEdges)) $
-            directEdges
-
-        (neighbourChains, combined)
-            = assert (noDups $ mapElems builtChains) $
-              {-# SCC "groupNeighbourChains" #-}
-            --   pprTraceIt "NeighbourChains" $
-              combineNeighbourhood rankedEdges (mapElems builtChains)
-
-
-        allEdges :: [CfgEdge]
-        allEdges = {-# SCC allEdges #-}
-                   sortOn (relevantWeight) $ filter (not . deadEdge) $ (infoEdgeList weights)
-          where
-            deadEdge :: CfgEdge -> Bool
-            deadEdge (CfgEdge from to _) = let e = (from,to) in Set.member e combined || Set.member e builtEdges
-            relevantWeight :: CfgEdge -> EdgeWeight
-            relevantWeight (CfgEdge _ _ edgeInfo)
-                | EdgeInfo (CmmSource { trans_cmmNode = CmmCall {}}) _ <- edgeInfo
-                -- Penalize edges across calls
-                = weight/(64.0)
-                | otherwise
-                = weight
-              where
-                -- negate to sort descending
-                weight = negate (edgeWeight edgeInfo)
-
-        masterChain =
-            {-# SCC "mergeChains" #-}
-            -- pprTraceIt "MergedChains" $
-            mergeChains allEdges neighbourChains
-
-        --Make sure the first block stays first
-        prepedChains
-            | inFront entry masterChain
-            = [masterChain]
-            | (rest,entry) <- breakChainAt entry masterChain
-            = [entry,rest]
-#if __GLASGOW_HASKELL__ <= 810
-            | otherwise = pprPanic "Entry point eliminated" $
-                            ppr masterChain
-#endif
-
-        blockList
-            = assert (noDups [masterChain])
-              (concatMap fromOL $ map chainBlocks prepedChains)
-
-        --chainPlaced = setFromList $ map blockId blockList :: LabelSet
-        chainPlaced = setFromList $ blockList :: LabelSet
-        unplaced =
-            let blocks = mapKeys blockMap
-                isPlaced b = setMember (b) chainPlaced
-            in filter (\block -> not (isPlaced block)) blocks
-
-        placedBlocks =
-            -- We want debug builds to catch this as it's a good indicator for
-            -- issues with CFG invariants. But we don't want to blow up production
-            -- builds if something slips through.
-            assert (null unplaced) $
-            --pprTraceIt "placedBlocks" $
-            -- ++ [] is still kinda expensive
-            if null unplaced then blockList else blockList ++ unplaced
-        getBlock bid = expectJust "Block placement" $ mapLookup bid blockMap
-    in
-        --Assert we placed all blocks given as input
-        assert (all (\bid -> mapMember bid blockMap) placedBlocks) $
-        dropJumps info $ map getBlock placedBlocks
-
-{-# SCC dropJumps #-}
--- | Remove redundant jumps between blocks when we can rely on
--- fall through.
-dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i]
-          -> [GenBasicBlock i]
-dropJumps _    [] = []
-dropJumps info (BasicBlock lbl ins:todo)
-    | Just ins <- nonEmpty ins --This can happen because of shortcutting
-    , [dest] <- jumpDestsOfInstr (NE.last ins)
-    , BasicBlock nextLbl _ : _ <- todo
-    , not (mapMember dest info)
-    , nextLbl == dest
-    = BasicBlock lbl (NE.init ins) : dropJumps info todo
-    | otherwise
-    = BasicBlock lbl ins : dropJumps info todo
-
-
--- -----------------------------------------------------------------------------
--- Sequencing the basic blocks
-
--- Cmm BasicBlocks are self-contained entities: they always end in a
--- jump, either non-local or to another basic block in the same proc.
--- In this phase, we attempt to place the basic blocks in a sequence
--- such that as many of the local jumps as possible turn into
--- fallthroughs.
-
-sequenceTop
-    :: Instruction instr
-    => NcgImpl statics instr jumpDest
-    -> Maybe CFG -- ^ CFG if we have one.
-    -> NatCmmDecl statics instr -- ^ Function to serialize
-    -> NatCmmDecl statics instr
-
-sequenceTop _       _           top@(CmmData _ _) = top
-sequenceTop ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks))
-  = let
-      config     = ncgConfig ncgImpl
-      platform   = ncgPlatform config
-
-    in CmmProc info lbl live $ ListGraph $ ncgMakeFarBranches ncgImpl info $
-         if -- Chain based algorithm
-            | ncgCfgBlockLayout config
-            , backendMaintainsCfg platform
-            , Just cfg <- edgeWeights
-            -> {-# SCC layoutBlocks #-} sequenceChain info cfg blocks
-
-            -- Old algorithm without edge weights
-            | ncgCfgWeightlessLayout config
-               || not (backendMaintainsCfg platform)
-            -> {-# SCC layoutBlocks #-} sequenceBlocks Nothing info blocks
-
-            -- Old algorithm with edge weights (if any)
-            | otherwise
-            -> {-# SCC layoutBlocks #-} sequenceBlocks edgeWeights info blocks
-
--- The old algorithm:
--- It is very simple (and stupid): We make a graph out of
--- the blocks where there is an edge from one block to another iff the
--- first block ends by jumping to the second.  Then we topologically
--- sort this graph.  Then traverse the list: for each block, we first
--- output the block, then if it has an out edge, we move the
--- destination of the out edge to the front of the list, and continue.
-
--- FYI, the classic layout for basic blocks uses postorder DFS; this
--- algorithm is implemented in Hoopl.
-
-sequenceBlocks :: Instruction inst => Maybe CFG -> LabelMap a
-               -> [GenBasicBlock inst] -> [GenBasicBlock inst]
-sequenceBlocks _edgeWeight _ [] = []
-sequenceBlocks edgeWeights infos (entry:blocks) =
-    let entryNode = mkNode edgeWeights entry
-        bodyNodes = reverse
-                    (flattenSCCs (sccBlocks edgeWeights blocks))
-    in dropJumps infos . seqBlocks infos $ ( entryNode : bodyNodes)
-  -- the first block is the entry point ==> it must remain at the start.
-
-sccBlocks
-        :: Instruction instr
-        => Maybe CFG -> [NatBasicBlock instr]
-        -> [SCC (Node BlockId (NatBasicBlock instr))]
-sccBlocks edgeWeights blocks =
-    stronglyConnCompFromEdgedVerticesUniqR
-        (map (mkNode edgeWeights) blocks)
-
-mkNode :: (Instruction t)
-       => Maybe CFG -> GenBasicBlock t
-       -> Node BlockId (GenBasicBlock t)
-mkNode edgeWeights block@(BasicBlock id instrs) =
-    DigraphNode block id outEdges
-  where
-    outEdges :: [BlockId]
-    outEdges
-      --Select the heaviest successor, ignore weights <= zero
-      = successor
-      where
-        successor
-          | Just successors <- fmap (`getSuccEdgesSorted` id)
-                                    edgeWeights -- :: Maybe [(Label, EdgeInfo)]
-          = case successors of
-            [] -> []
-            ((target,info):_)
-              | length successors > 2 || edgeWeight info <= 0 -> []
-              | otherwise -> [target]
-          | Just instr <- lastMaybe instrs
-          , [one] <- jumpDestsOfInstr instr
-          = [one]
-          | otherwise = []
-
-
-seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)]
-                        -> [GenBasicBlock t1]
-seqBlocks infos blocks = placeNext pullable0 todo0
-  where
-    -- pullable: Blocks that are not yet placed
-    -- todo:     Original order of blocks, to be followed if we have no good
-    --           reason not to;
-    --           may include blocks that have already been placed, but then
-    --           these are not in pullable
-    pullable0 = listToUFM [ (i,(b,n)) | DigraphNode b i n <- blocks ]
-    todo0     = map node_key blocks
-
-    placeNext _ [] = []
-    placeNext pullable (i:rest)
-        | Just (block, pullable') <- lookupDeleteUFM pullable i
-        = place pullable' rest block
-        | otherwise
-        -- We already placed this block, so ignore
-        = placeNext pullable rest
-
-    place pullable todo (block,[])
-                          = block : placeNext pullable todo
-    place pullable todo (block@(BasicBlock id instrs),[next])
-        | mapMember next infos
-        = block : placeNext pullable todo
-        | Just (nextBlock, pullable') <- lookupDeleteUFM pullable next
-        = BasicBlock id instrs : place pullable' todo nextBlock
-        | otherwise
-        = block : placeNext pullable todo
-    place _ _ (_,tooManyNextNodes)
-        = pprPanic "seqBlocks" (ppr tooManyNextNodes)
-
-
-lookupDeleteUFM :: UniqFM BlockId elt -> BlockId
-                -> Maybe (elt, UniqFM BlockId elt)
-lookupDeleteUFM m k = do -- Maybe monad
-    v <- lookupUFM m k
-    return (v, delFromUFM m k)
-
-backendMaintainsCfg :: Platform -> Bool
-backendMaintainsCfg platform = case platformArch platform of
-    -- ArchX86 -- Should work but not tested so disabled currently.
-    ArchX86_64 -> True
-    _otherwise -> False
-
diff --git a/compiler/GHC/CmmToAsm/CFG.hs b/compiler/GHC/CmmToAsm/CFG.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/CFG.hs
+++ /dev/null
@@ -1,1360 +0,0 @@
-{-# LANGUAGE DataKinds                  #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE Rank2Types                 #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE TupleSections              #-}
---
--- Copyright (c) 2018 Andreas Klebinger
---
-
-module GHC.CmmToAsm.CFG
-    ( CFG, CfgEdge(..), EdgeInfo(..), EdgeWeight(..)
-    , TransitionSource(..)
-
-    --Modify the CFG
-    , addWeightEdge, addEdge
-    , delEdge
-    , addNodesBetween, shortcutWeightMap
-    , reverseEdges, filterEdges
-    , addImmediateSuccessor
-    , mkWeightInfo, adjustEdgeWeight, setEdgeWeight
-
-    --Query the CFG
-    , infoEdgeList, edgeList
-    , getSuccessorEdges, getSuccessors
-    , getSuccEdgesSorted
-    , getEdgeInfo
-    , getCfgNodes, hasNode
-
-    -- Loop Information
-    , loopMembers, loopLevels, loopInfo
-
-    --Construction/Misc
-    , getCfg, getCfgProc, pprEdgeWeights, sanityCheckCfg
-
-    --Find backedges and update their weight
-    , optimizeCFG
-    , mkGlobalWeights
-
-     )
-where
-
-import GHC.Prelude
-import GHC.Platform
-
-import GHC.Cmm.BlockId
-import GHC.Cmm as Cmm
-
-import GHC.Cmm.Switch
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.Dataflow.Block
-import qualified GHC.Cmm.Dataflow.Graph as G
-
-import GHC.Utils.Misc
-import GHC.Data.Graph.Directed
-import GHC.Data.Maybe
-
-import GHC.Types.Unique
-import qualified GHC.CmmToAsm.CFG.Dominators as Dom
-import GHC.CmmToAsm.CFG.Weight
-import Data.IntMap.Strict (IntMap)
-import Data.IntSet (IntSet)
-
-import qualified Data.IntMap.Strict as IM
-import qualified Data.Map as M
-import qualified Data.IntSet as IS
-import qualified Data.Set as S
-import Data.Tree
-import Data.Bifunctor
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
--- DEBUGGING ONLY
---import GHC.Cmm.DebugBlock
---import GHC.Data.OrdList
---import GHC.Cmm.DebugBlock.Trace
-
-import Data.List (sort, nub, partition)
-import Data.STRef.Strict
-import Control.Monad.ST
-
-import Data.Array.MArray
-import Data.Array.ST
-import Data.Array.IArray
-import Data.Array.Unsafe (unsafeFreeze)
-import Data.Array.Base (unsafeRead, unsafeWrite)
-
-import Control.Monad
-import GHC.Data.UnionFind
-
-type Prob = Double
-
-type Edge = (BlockId, BlockId)
-type Edges = [Edge]
-
-newtype EdgeWeight
-  = EdgeWeight { weightToDouble :: Double }
-  deriving (Eq,Ord,Enum,Num,Real,Fractional)
-
-instance Outputable EdgeWeight where
-  ppr (EdgeWeight w) = doublePrec 5 w
-
-type EdgeInfoMap edgeInfo = LabelMap (LabelMap edgeInfo)
-
--- | A control flow graph where edges have been annotated with a weight.
--- Implemented as IntMap (IntMap \<edgeData>)
--- We must uphold the invariant that for each edge A -> B we must have:
--- A entry B in the outer map.
--- A entry B in the map we get when looking up A.
--- Maintaining this invariant is useful as any failed lookup now indicates
--- an actual error in code which might go unnoticed for a while
--- otherwise.
-type CFG = EdgeInfoMap EdgeInfo
-
-data CfgEdge
-  = CfgEdge
-  { edgeFrom :: !BlockId
-  , edgeTo :: !BlockId
-  , edgeInfo :: !EdgeInfo
-  }
-
--- | Careful! Since we assume there is at most one edge from A to B
---   the Eq instance does not consider weight.
-instance Eq CfgEdge where
-  (==) (CfgEdge from1 to1 _) (CfgEdge from2 to2 _)
-    = from1 == from2 && to1 == to2
-
--- | Edges are sorted ascending pointwise by weight, source and destination
-instance Ord CfgEdge where
-  compare (CfgEdge from1 to1 (EdgeInfo {edgeWeight = weight1}))
-          (CfgEdge from2 to2 (EdgeInfo {edgeWeight = weight2}))
-    | weight1 < weight2 || weight1 == weight2 && from1 < from2 ||
-      weight1 == weight2 && from1 == from2 && to1 < to2
-    = LT
-    | from1 == from2 && to1 == to2 && weight1 == weight2
-    = EQ
-    | otherwise
-    = GT
-
-instance Outputable CfgEdge where
-  ppr (CfgEdge from1 to1 edgeInfo)
-    = parens (ppr from1 <+> text "-(" <> ppr edgeInfo <> text ")->" <+> ppr to1)
-
--- | Can we trace back a edge to a specific Cmm Node
--- or has it been introduced during assembly codegen. We use this to maintain
--- some information which would otherwise be lost during the
--- Cmm \<-> asm transition.
--- See also Note [Inverting conditions]
-data TransitionSource
-  = CmmSource { trans_cmmNode :: (CmmNode O C)
-              , trans_info :: BranchInfo }
-  | AsmCodeGen
-  deriving (Eq)
-
-data BranchInfo = NoInfo         -- ^ Unknown, but not heap or stack check.
-                | HeapStackCheck -- ^ Heap or stack check
-    deriving Eq
-
-instance Outputable BranchInfo where
-    ppr NoInfo = text "regular"
-    ppr HeapStackCheck = text "heap/stack"
-
-isHeapOrStackCheck :: TransitionSource -> Bool
-isHeapOrStackCheck (CmmSource { trans_info = HeapStackCheck}) = True
-isHeapOrStackCheck _ = False
-
--- | Information about edges
-data EdgeInfo
-  = EdgeInfo
-  { transitionSource :: !TransitionSource
-  , edgeWeight :: !EdgeWeight
-  } deriving (Eq)
-
-instance Outputable EdgeInfo where
-  ppr edgeInfo = text "weight:" <+> ppr (edgeWeight edgeInfo)
-
--- | Convenience function, generate edge info based
---   on weight not originating from cmm.
-mkWeightInfo :: EdgeWeight -> EdgeInfo
-mkWeightInfo = EdgeInfo AsmCodeGen
-
--- | Adjust the weight between the blocks using the given function.
---   If there is no such edge returns the original map.
-adjustEdgeWeight :: CFG -> (EdgeWeight -> EdgeWeight)
-                 -> BlockId -> BlockId -> CFG
-adjustEdgeWeight cfg f from to
-  | Just info <- getEdgeInfo from to cfg
-  , !weight <- edgeWeight info
-  , !newWeight <- f weight
-  = addEdge from to (info { edgeWeight = newWeight}) cfg
-  | otherwise = cfg
-
--- | Set the weight between the blocks to the given weight.
---   If there is no such edge returns the original map.
-setEdgeWeight :: CFG -> EdgeWeight
-              -> BlockId -> BlockId -> CFG
-setEdgeWeight cfg !weight from to
-  | Just info <- getEdgeInfo from to cfg
-  = addEdge from to (info { edgeWeight = weight}) cfg
-  | otherwise = cfg
-
-
-getCfgNodes :: CFG -> [BlockId]
-getCfgNodes m =
-    mapKeys m
-
--- | Is this block part of this graph?
-hasNode :: CFG -> BlockId -> Bool
-hasNode m node =
-  -- Check the invariant that each node must exist in the first map or not at all.
-  assert (found || not (any (mapMember node) m))
-  found
-    where
-      found = mapMember node m
-
-
-
--- | Check if the nodes in the cfg and the set of blocks are the same.
---   In a case of a mismatch we panic and show the difference.
-sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool
-sanityCheckCfg m blockSet msg
-    | blockSet == cfgNodes
-    = True
-    | otherwise =
-        pprPanic "Block list and cfg nodes don't match" (
-            text "difference:" <+> ppr diff $$
-            text "blocks:" <+> ppr blockSet $$
-            text "cfg:" <+> pprEdgeWeights m $$
-            msg )
-            False
-    where
-      cfgNodes = setFromList $ getCfgNodes m :: LabelSet
-      diff = (setUnion cfgNodes blockSet) `setDifference` (setIntersection cfgNodes blockSet) :: LabelSet
-
--- | Filter the CFG with a custom function f.
---   Parameters are `f from to edgeInfo`
-filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG
-filterEdges f cfg =
-    mapMapWithKey filterSources cfg
-    where
-      filterSources from m =
-        mapFilterWithKey (\to w -> f from to w) m
-
-
-{- Note [Updating the CFG during shortcutting]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See Note [What is shortcutting] in the control flow optimization
-code (GHC.Cmm.ContFlowOpt) for a slightly more in depth explanation on shortcutting.
-
-In the native backend we shortcut jumps at the assembly level. ("GHC.CmmToAsm")
-This means we remove blocks containing only one jump from the code
-and instead redirecting all jumps targeting this block to the deleted
-blocks jump target.
-
-However we want to have an accurate representation of control
-flow in the CFG. So we add/remove edges accordingly to account
-for the eliminated blocks and new edges.
-
-If we shortcut A -> B -> C to A -> C:
-* We delete edges A -> B and B -> C
-* Replacing them with the edge A -> C
-
-We also try to preserve jump weights while doing so.
-
-Note that:
-* The edge B -> C can't have interesting weights since
-  the block B consists of a single unconditional jump without branching.
-* We delete the edge A -> B and add the edge A -> C.
-* The edge A -> B can be one of many edges originating from A so likely
-  has edge weights we want to preserve.
-
-For this reason we simply store the edge info from the original A -> B
-edge and apply this information to the new edge A -> C.
-
-Sometimes we have a scenario where jump target C is not represented by an
-BlockId but an immediate value. I'm only aware of this happening without
-tables next to code currently.
-
-Then we go from A ---> B - -> IMM   to   A - -> IMM where the dashed arrows
-are not stored in the CFG.
-
-In that case we simply delete the edge A -> B.
-
-In terms of implementation the native backend first builds a mapping
-from blocks suitable for shortcutting to their jump targets.
-Then it redirects all jump instructions to these blocks using the
-built up mapping.
-This function (shortcutWeightMap) takes the same mapping and
-applies the mapping to the CFG in the way laid out above.
-
--}
-shortcutWeightMap :: LabelMap (Maybe BlockId) -> CFG -> CFG
-shortcutWeightMap cuts cfg
-  | mapNull cuts = cfg
-  | otherwise = normalised_cfg
-    where
-      -- First take the cuts map and collapse any shortcuts, for example
-      -- if the cuts map has A -> B and B -> C then we want to rewrite
-      -- A -> C and B -> C directly.
-      normalised_cuts_st :: forall s . ST s (LabelMap (Maybe BlockId))
-      normalised_cuts_st = do
-        (null :: Point s (Maybe BlockId)) <- fresh Nothing
-        let cuts_list = mapToList cuts
-        -- Create a unification variable for each of the nodes in a rewrite
-        cuts_vars <- traverse (\p -> (p,) <$> fresh (Just p)) (concatMap (\(a, b) -> [a] ++ maybe [] (:[]) b) cuts_list)
-        let cuts_map = mapFromList cuts_vars :: LabelMap (Point s (Maybe BlockId))
-        -- Then unify according to the rewrites in the cuts map
-        mapM_ (\(from, to) -> expectJust "shortcutWeightMap" (mapLookup from cuts_map)
-                              `union` expectJust "shortcutWeightMap" (maybe (Just null) (flip mapLookup cuts_map) to) ) cuts_list
-        -- Then recover the unique representative, which is the result of following
-        -- the chain to the end.
-        mapM find cuts_map
-
-      normalised_cuts = runST normalised_cuts_st
-
-      cuts_domain :: LabelSet
-      cuts_domain = setFromList $ mapKeys cuts
-
-      -- The CFG is shortcutted using the normalised cuts map
-      normalised_cfg :: CFG
-      normalised_cfg = mapFoldlWithKey update_edge mapEmpty cfg
-
-      update_edge :: CFG -> Label -> LabelMap EdgeInfo -> CFG
-      update_edge new_map from edge_map
-        -- If the from edge is in the cuts map then delete the edge
-        | setMember from cuts_domain = new_map
-        -- Otherwise we are keeping the edge, but might have shortcutted some of
-        -- the target nodes.
-        | otherwise = mapInsert from (mapFoldlWithKey update_from_edge mapEmpty edge_map) new_map
-
-      update_from_edge :: LabelMap a -> Label -> a -> LabelMap a
-      update_from_edge new_map to_edge edge_info
-        -- Edge is in the normalised cuts
-        | Just new_edge <- mapLookup to_edge normalised_cuts =
-            case new_edge of
-              -- The result was Nothing, so edge is deleted
-              Nothing -> new_map
-              -- The new target for the edge, write it with the old edge_info.
-              Just new_to -> mapInsert new_to edge_info new_map
-        -- Node wasn't in the cuts map, so just add it back
-        | otherwise = mapInsert to_edge edge_info new_map
-
-
--- | Sometimes we insert a block which should unconditionally be executed
---   after a given block. This function updates the CFG for these cases.
---  So we get A -> B    => A -> A' -> B
---             \                  \
---              -> C    =>         -> C
---
-addImmediateSuccessor :: Weights -> BlockId -> BlockId -> CFG -> CFG
-addImmediateSuccessor weights node follower cfg
-    = updateEdges . addWeightEdge node follower weight $ cfg
-    where
-        weight = fromIntegral (uncondWeight weights)
-        targets = getSuccessorEdges cfg node
-        successors = map fst targets :: [BlockId]
-        updateEdges = addNewSuccs . remOldSuccs
-        remOldSuccs m = foldl' (flip (delEdge node)) m successors
-        addNewSuccs m =
-          foldl' (\m' (t,info) -> addEdge follower t info m') m targets
-
--- | Adds a new edge, overwrites existing edges if present
-addEdge :: BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
-addEdge from to info cfg =
-    mapAlter addFromToEdge from $
-    mapAlter addDestNode to cfg
-    where
-        -- Simply insert the edge into the edge list.
-        addFromToEdge Nothing = Just $ mapSingleton to info
-        addFromToEdge (Just wm) = Just $ mapInsert to info wm
-        -- We must add the destination node explicitly
-        addDestNode Nothing = Just $ mapEmpty
-        addDestNode n@(Just _) = n
-
-
--- | Adds a edge with the given weight to the cfg
---   If there already existed an edge it is overwritten.
---   `addWeightEdge from to weight cfg`
-addWeightEdge :: BlockId -> BlockId -> EdgeWeight -> CFG -> CFG
-addWeightEdge from to weight cfg =
-    addEdge from to (mkWeightInfo weight) cfg
-
-delEdge :: BlockId -> BlockId -> CFG -> CFG
-delEdge from to m =
-    mapAdjust (mapDelete to) from m
-
-
--- | Destinations from bid ordered by weight (descending)
-getSuccEdgesSorted :: CFG -> BlockId -> [(BlockId,EdgeInfo)]
-getSuccEdgesSorted m bid =
-    let destMap = mapFindWithDefault mapEmpty bid m
-        cfgEdges = mapToList destMap
-        sortedEdges = sortWith (negate . edgeWeight . snd) cfgEdges
-    in  --pprTrace "getSuccEdgesSorted" (ppr bid <+> text "map:" <+> ppr m)
-        sortedEdges
-
--- | Get successors of a given node with edge weights.
-getSuccessorEdges :: HasDebugCallStack => CFG -> BlockId -> [(BlockId,EdgeInfo)]
-getSuccessorEdges m bid = maybe lookupError mapToList (mapLookup bid m)
-  where
-    lookupError = pprPanic "getSuccessorEdges: Block does not exist" $
-                    ppr bid <+> pprEdgeWeights m
-
-getEdgeInfo :: BlockId -> BlockId -> CFG -> Maybe EdgeInfo
-getEdgeInfo from to m
-    | Just wm <- mapLookup from m
-    , Just info <- mapLookup to wm
-    = Just $! info
-    | otherwise
-    = Nothing
-
-getEdgeWeight :: CFG -> BlockId -> BlockId -> EdgeWeight
-getEdgeWeight cfg from to =
-    edgeWeight $ expectJust "Edgeweight for nonexisting block" $
-                 getEdgeInfo from to cfg
-
-getTransitionSource :: BlockId -> BlockId -> CFG -> TransitionSource
-getTransitionSource from to cfg = transitionSource $ expectJust "Source info for nonexisting block" $
-                        getEdgeInfo from to cfg
-
-reverseEdges :: CFG -> CFG
-reverseEdges cfg = mapFoldlWithKey (\cfg from toMap -> go (addNode cfg from) from toMap) mapEmpty cfg
-  where
-    -- We must preserve nodes without outgoing edges!
-    addNode :: CFG -> BlockId -> CFG
-    addNode cfg b = mapInsertWith mapUnion b mapEmpty cfg
-    go :: CFG -> BlockId -> (LabelMap EdgeInfo) -> CFG
-    go cfg from toMap = mapFoldlWithKey (\cfg to info -> addEdge to from info cfg) cfg toMap  :: CFG
-
-
--- | Returns a unordered list of all edges with info
-infoEdgeList :: CFG -> [CfgEdge]
-infoEdgeList m =
-    go (mapToList m) []
-  where
-    -- We avoid foldMap to avoid thunk buildup
-    go :: [(BlockId,LabelMap EdgeInfo)] -> [CfgEdge] -> [CfgEdge]
-    go [] acc = acc
-    go ((from,toMap):xs) acc
-      = go' xs from (mapToList toMap) acc
-    go' :: [(BlockId,LabelMap EdgeInfo)] -> BlockId -> [(BlockId,EdgeInfo)] -> [CfgEdge] -> [CfgEdge]
-    go' froms _    []              acc = go froms acc
-    go' froms from ((to,info):tos) acc
-      = go' froms from tos (CfgEdge from to info : acc)
-
--- | Returns a unordered list of all edges without weights
-edgeList :: CFG -> [Edge]
-edgeList m =
-    go (mapToList m) []
-  where
-    -- We avoid foldMap to avoid thunk buildup
-    go :: [(BlockId,LabelMap EdgeInfo)] -> [Edge] -> [Edge]
-    go [] acc = acc
-    go ((from,toMap):xs) acc
-      = go' xs from (mapKeys toMap) acc
-    go' :: [(BlockId,LabelMap EdgeInfo)] -> BlockId -> [BlockId] -> [Edge] -> [Edge]
-    go' froms _    []              acc = go froms acc
-    go' froms from (to:tos) acc
-      = go' froms from tos ((from,to) : acc)
-
--- | Get successors of a given node without edge weights.
-getSuccessors :: HasDebugCallStack => CFG -> BlockId -> [BlockId]
-getSuccessors m bid
-    | Just wm <- mapLookup bid m
-    = mapKeys wm
-    | otherwise = lookupError
-    where
-      lookupError = pprPanic "getSuccessors: Block does not exist" $
-                    ppr bid <+> pprEdgeWeights m
-
-pprEdgeWeights :: CFG -> SDoc
-pprEdgeWeights m =
-    let edges = sort $ infoEdgeList m :: [CfgEdge]
-        printEdge (CfgEdge from to (EdgeInfo { edgeWeight = weight }))
-            = text "\t" <> ppr from <+> text "->" <+> ppr to <>
-              text "[label=\"" <> ppr weight <> text "\",weight=\"" <>
-              ppr weight <> text "\"];\n"
-        --for the case that there are no edges from/to this node.
-        --This should rarely happen but it can save a lot of time
-        --to immediately see it when it does.
-        printNode node
-            = text "\t" <> ppr node <> text ";\n"
-        getEdgeNodes (CfgEdge from to _) = [from,to]
-        edgeNodes = setFromList $ concatMap getEdgeNodes edges :: LabelSet
-        nodes = filter (\n -> (not . setMember n) edgeNodes) . mapKeys $ mapFilter null m
-    in
-    text "digraph {\n" <>
-        (foldl' (<>) empty (map printEdge edges)) <>
-        (foldl' (<>) empty (map printNode nodes)) <>
-    text "}\n"
-
-{-# INLINE updateEdgeWeight #-} --Allows eliminating the tuple when possible
--- | Invariant: The edge **must** exist already in the graph.
-updateEdgeWeight :: (EdgeWeight -> EdgeWeight) -> Edge -> CFG -> CFG
-updateEdgeWeight f (from, to) cfg
-    | Just oldInfo <- getEdgeInfo from to cfg
-    = let !oldWeight = edgeWeight oldInfo
-          !newWeight = f oldWeight
-      in addEdge from to (oldInfo {edgeWeight = newWeight}) cfg
-    | otherwise
-    = panic "Trying to update invalid edge"
-
--- from to oldWeight => newWeight
-mapWeights :: (BlockId -> BlockId -> EdgeWeight -> EdgeWeight) -> CFG -> CFG
-mapWeights f cfg =
-  foldl' (\cfg (CfgEdge from to info) ->
-            let oldWeight = edgeWeight info
-                newWeight = f from to oldWeight
-            in addEdge from to (info {edgeWeight = newWeight}) cfg)
-          cfg (infoEdgeList cfg)
-
-
--- | Insert a block in the control flow between two other blocks.
--- We pass a list of tuples (A,B,C) where
--- * A -> C: Old edge
--- * A -> B -> C : New Arc, where B is the new block.
--- It's possible that a block has two jumps to the same block
--- in the assembly code. However we still only store a single edge for
--- these cases.
--- We assign the old edge info to the edge A -> B and assign B -> C the
--- weight of an unconditional jump.
-addNodesBetween :: Weights -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG
-addNodesBetween weights m updates =
-  foldl'  updateWeight m .
-          weightUpdates $ updates
-    where
-      weight = fromIntegral (uncondWeight weights)
-      -- We might add two blocks for different jumps along a single
-      -- edge. So we end up with edges:   A -> B -> C   ,   A -> D -> C
-      -- in this case after applying the first update the weight for A -> C
-      -- is no longer available. So we calculate future weights before updates.
-      weightUpdates = map getWeight
-      getWeight :: (BlockId,BlockId,BlockId) -> (BlockId,BlockId,BlockId,EdgeInfo)
-      getWeight (from,between,old)
-        | Just edgeInfo <- getEdgeInfo from old m
-        = (from,between,old,edgeInfo)
-        | otherwise
-        = pprPanic "Can't find weight for edge that should have one" (
-            text "triple" <+> ppr (from,between,old) $$
-            text "updates" <+> ppr updates $$
-            text "cfg:" <+> pprEdgeWeights m )
-      updateWeight :: CFG -> (BlockId,BlockId,BlockId,EdgeInfo) -> CFG
-      updateWeight m (from,between,old,edgeInfo)
-        = addEdge from between edgeInfo .
-          addWeightEdge between old weight .
-          delEdge from old $ m
-
-{-
-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  ~~~       Note [CFG Edge Weights]    ~~~
-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-  Edge weights assigned do not currently represent a specific
-  cost model and rather just a ranking of which blocks should
-  be placed next to each other given their connection type in
-  the CFG.
-  This is especially relevant if we whenever two blocks will
-  jump to the same target.
-
-                     A   B
-                      \ /
-                       C
-
-  Should A or B be placed in front of C? The block layout algorithm
-  decides this based on which edge (A,C)/(B,C) is heavier. So we
-  make a educated guess on which branch should be preferred.
-
-  We rank edges in this order:
-  * Unconditional Control Transfer - They will always
-    transfer control to their target. Unless there is a info table
-    we can turn the jump into a fallthrough as well.
-    We use 20k as default, so it's easy to spot if values have been
-    modified but unlikely that we run into issues with overflow.
-  * If branches (likely) - We assume branches marked as likely
-    are taken more than 80% of the time.
-    By ranking them below unconditional jumps we make sure we
-    prefer the unconditional if there is a conditional and
-    unconditional edge towards a block.
-  * If branches (regular) - The false branch can potentially be turned
-    into a fallthrough so we prefer it slightly over the true branch.
-  * Unlikely branches - These can be assumed to be taken less than 20%
-    of the time. So we given them one of the lowest priorities.
-  * Switches - Switches at this level are implemented as jump tables
-    so have a larger number of successors. So without more information
-    we can only say that each individual successor is unlikely to be
-    jumped to and we rank them accordingly.
-  * Calls - We currently ignore calls completely:
-        * By the time we return from a call there is a good chance
-          that the address we return to has already been evicted from
-          cache eliminating a main advantage sequential placement brings.
-        * Calls always require a info table in front of their return
-          address. This reduces the chance that we return to the same
-          cache line further.
-
--}
--- | Generate weights for a Cmm proc based on some simple heuristics.
-getCfgProc :: Platform -> Weights -> RawCmmDecl -> CFG
-getCfgProc _        _       (CmmData {}) = mapEmpty
-getCfgProc platform weights (CmmProc _info _lab _live graph) = getCfg platform weights graph
-
-getCfg :: Platform -> Weights -> CmmGraph -> CFG
-getCfg platform weights graph =
-  foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks
-  where
-    Weights
-            { uncondWeight = uncondWeight
-            , condBranchWeight = condBranchWeight
-            , switchWeight = switchWeight
-            , callWeight = callWeight
-            , likelyCondWeight = likelyCondWeight
-            , unlikelyCondWeight = unlikelyCondWeight
-            --  Last two are used in other places
-            --, infoTablePenalty = infoTablePenalty
-            --, backEdgeBonus = backEdgeBonus
-            } = weights
-    -- Explicitly add all nodes to the cfg to ensure they are part of the
-    -- CFG.
-    edgelessCfg = mapFromList $ zip (map G.entryLabel blocks) (repeat mapEmpty)
-    insertEdge :: CFG -> ((BlockId,BlockId),EdgeInfo) -> CFG
-    insertEdge m ((from,to),weight) =
-      mapAlter f from m
-        where
-          f :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
-          f Nothing = Just $ mapSingleton to weight
-          f (Just destMap) = Just $ mapInsert to weight destMap
-    getBlockEdges :: CmmBlock -> [((BlockId,BlockId),EdgeInfo)]
-    getBlockEdges block =
-      case branch of
-        CmmBranch dest -> [mkEdge dest uncondWeight]
-        CmmCondBranch cond t f l
-          | l == Nothing ->
-              [mkEdge f condBranchWeight,   mkEdge t condBranchWeight]
-          | l == Just True ->
-              [mkEdge f unlikelyCondWeight, mkEdge t likelyCondWeight]
-          | l == Just False ->
-              [mkEdge f likelyCondWeight,   mkEdge t unlikelyCondWeight]
-          where
-            mkEdgeInfo = -- pprTrace "Info" (ppr branchInfo <+> ppr cond)
-                         EdgeInfo (CmmSource branch branchInfo) . fromIntegral
-            mkEdge target weight = ((bid,target), mkEdgeInfo weight)
-            branchInfo =
-              foldRegsUsed
-                (panic "GHC.CmmToAsm.CFG.getCfg: foldRegsUsed")
-                (\info r -> if r == SpLim || r == HpLim || r == BaseReg
-                    then HeapStackCheck else info)
-                NoInfo cond
-
-        (CmmSwitch _e ids) ->
-          let switchTargets = switchTargetsToList ids
-              --Compiler performance hack - for very wide switches don't
-              --consider targets for layout.
-              adjustedWeight =
-                if (length switchTargets > 10) then -1 else switchWeight
-          in map (\x -> mkEdge x adjustedWeight) switchTargets
-        (CmmCall { cml_cont = Just cont})  -> [mkEdge cont callWeight]
-        (CmmForeignCall {Cmm.succ = cont}) -> [mkEdge cont callWeight]
-        (CmmCall { cml_cont = Nothing })   -> []
-        other ->
-            panic "Foo" $
-            assertPpr False (text "Unknown successor cause:" <>
-              (pdoc platform branch <+> text "=>" <> pdoc platform (G.successors other))) $
-            map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other
-      where
-        bid = G.entryLabel block
-        mkEdgeInfo = EdgeInfo (CmmSource branch NoInfo) . fromIntegral
-        mkEdge target weight = ((bid,target), mkEdgeInfo weight)
-        branch = lastNode block :: CmmNode O C
-
-    blocks = revPostorder graph :: [CmmBlock]
-
---Find back edges by BFS
-findBackEdges :: HasDebugCallStack => BlockId -> CFG -> Edges
-findBackEdges root cfg =
-    --pprTraceIt "Backedges:" $
-    map fst .
-    filter (\x -> snd x == Backward) $ typedEdges
-  where
-    edges = edgeList cfg :: [(BlockId,BlockId)]
-    getSuccs = getSuccessors cfg :: BlockId -> [BlockId]
-    typedEdges =
-      classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)]
-
-optimizeCFG :: Bool -> Weights -> RawCmmDecl -> CFG -> CFG
-optimizeCFG _ _ (CmmData {}) cfg = cfg
-optimizeCFG doStaticPred weights proc@(CmmProc _info _lab _live graph) cfg =
-  (if doStaticPred then staticPredCfg (g_entry graph) else id) $
-    optHsPatterns weights proc $ cfg
-
--- | Modify branch weights based on educated guess on
--- patterns GHC tends to produce and how they affect
--- performance.
---
--- Most importantly we penalize jumps across info tables.
-optHsPatterns :: Weights -> RawCmmDecl -> CFG -> CFG
-optHsPatterns _ (CmmData {}) cfg = cfg
-optHsPatterns weights (CmmProc info _lab _live graph) cfg =
-    {-# SCC optHsPatterns #-}
-    -- pprTrace "Initial:" (pprEdgeWeights cfg) $
-    -- pprTrace "Initial:" (ppr $ mkGlobalWeights (g_entry graph) cfg) $
-
-    -- pprTrace "LoopInfo:" (ppr $ loopInfo cfg (g_entry graph)) $
-    favourFewerPreds  .
-    penalizeInfoTables info .
-    increaseBackEdgeWeight (g_entry graph) $ cfg
-  where
-
-    -- Increase the weight of all backedges in the CFG
-    -- this helps to make loop jumpbacks the heaviest edges
-    increaseBackEdgeWeight :: BlockId -> CFG -> CFG
-    increaseBackEdgeWeight root cfg =
-        let backedges = findBackEdges root cfg
-            update weight
-              --Keep irrelevant edges irrelevant
-              | weight <= 0 = 0
-              | otherwise
-              = weight + fromIntegral (backEdgeBonus weights)
-        in  foldl'  (\cfg edge -> updateEdgeWeight update edge cfg)
-                    cfg backedges
-
-    -- Since we cant fall through info tables we penalize these.
-    penalizeInfoTables :: LabelMap a -> CFG -> CFG
-    penalizeInfoTables info cfg =
-        mapWeights fupdate cfg
-      where
-        fupdate :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight
-        fupdate _ to weight
-          | mapMember to info
-          = weight - (fromIntegral $ infoTablePenalty weights)
-          | otherwise = weight
-
-    -- If a block has two successors, favour the one with fewer
-    -- predecessors and/or the one allowing fall through.
-    favourFewerPreds :: CFG -> CFG
-    favourFewerPreds cfg =
-        let
-            revCfg =
-              reverseEdges $ filterEdges
-                              (\_from -> fallthroughTarget)  cfg
-
-            predCount n = length $ getSuccessorEdges revCfg n
-            nodes = getCfgNodes cfg
-
-            modifiers :: Int -> Int -> (EdgeWeight, EdgeWeight)
-            modifiers preds1 preds2
-              | preds1 <  preds2 = ( 1,-1)
-              | preds1 == preds2 = ( 0, 0)
-              | otherwise        = (-1, 1)
-
-            update :: CFG -> BlockId -> CFG
-            update cfg node
-              | [(s1,e1),(s2,e2)] <- getSuccessorEdges cfg node
-              , !w1 <- edgeWeight e1
-              , !w2 <- edgeWeight e2
-              --Only change the weights if there isn't already a ordering.
-              , w1 == w2
-              , (mod1,mod2) <- modifiers (predCount s1) (predCount s2)
-              = (\cfg' ->
-                  (adjustEdgeWeight cfg' (+mod2) node s2))
-                    (adjustEdgeWeight cfg  (+mod1) node s1)
-              | otherwise
-              = cfg
-        in foldl' update cfg nodes
-      where
-        fallthroughTarget :: BlockId -> EdgeInfo -> Bool
-        fallthroughTarget to (EdgeInfo source _weight)
-          | mapMember to info = False
-          | AsmCodeGen <- source = True
-          | CmmSource { trans_cmmNode = CmmBranch {} } <- source = True
-          | CmmSource { trans_cmmNode = CmmCondBranch {} } <- source = True
-          | otherwise = False
-
--- | Convert block-local branch weights to global weights.
-staticPredCfg :: BlockId -> CFG -> CFG
-staticPredCfg entry cfg = cfg'
-  where
-    (_, globalEdgeWeights) = {-# SCC mkGlobalWeights #-}
-                             mkGlobalWeights entry cfg
-    cfg' = {-# SCC rewriteEdges #-}
-            mapFoldlWithKey
-                (\cfg from m ->
-                    mapFoldlWithKey
-                        (\cfg to w -> setEdgeWeight cfg (EdgeWeight w) from to )
-                        cfg m )
-                cfg
-                globalEdgeWeights
-
--- | Determine loop membership of blocks based on SCC analysis
---   This is faster but only gives yes/no answers.
-loopMembers :: HasDebugCallStack => CFG -> LabelMap Bool
-loopMembers cfg =
-    foldl' (flip setLevel) mapEmpty sccs
-  where
-    mkNode :: BlockId -> Node BlockId BlockId
-    mkNode bid = DigraphNode bid bid (getSuccessors cfg bid)
-    nodes = map mkNode (getCfgNodes cfg)
-
-    sccs = stronglyConnCompFromEdgedVerticesOrd nodes
-
-    setLevel :: SCC BlockId -> LabelMap Bool -> LabelMap Bool
-    setLevel (AcyclicSCC bid) m = mapInsert bid False m
-    setLevel (CyclicSCC bids) m = foldl' (\m k -> mapInsert k True m) m bids
-
-loopLevels :: CFG -> BlockId -> LabelMap Int
-loopLevels cfg root = liLevels loopInfos
-    where
-      loopInfos = loopInfo cfg root
-
-data LoopInfo = LoopInfo
-  { liBackEdges :: [(Edge)] -- ^ List of back edges
-  , liLevels :: LabelMap Int -- ^ BlockId -> LoopLevel mapping
-  , liLoops :: [(Edge, LabelSet)] -- ^ (backEdge, loopBody), body includes header
-  }
-
-instance Outputable LoopInfo where
-    ppr (LoopInfo _ _lvls loops) =
-        text "Loops:(backEdge, bodyNodes)" $$
-            (vcat $ map ppr loops)
-
-{-  Note [Determining the loop body]
-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-    Starting with the knowledge that:
-    * head dominates the loop
-    * `tail` -> `head` is a backedge
-
-    We can determine all nodes by:
-    * Deleting the loop head from the graph.
-    * Collect all blocks which are reachable from the `tail`.
-
-    We do so by performing bfs from the tail node towards the head.
- -}
-
--- | Determine loop membership of blocks based on Dominator analysis.
---   This is slower but gives loop levels instead of just loop membership.
---   However it only detects natural loops. Irreducible control flow is not
---   recognized even if it loops. But that is rare enough that we don't have
---   to care about that special case.
-loopInfo :: HasDebugCallStack => CFG -> BlockId -> LoopInfo
-loopInfo cfg root = LoopInfo  { liBackEdges = backEdges
-                              , liLevels = mapFromList loopCounts
-                              , liLoops = loopBodies }
-  where
-    revCfg = reverseEdges cfg
-
-    graph = -- pprTrace "CFG - loopInfo" (pprEdgeWeights cfg) $
-            fmap (setFromList . mapKeys ) cfg :: LabelMap LabelSet
-
-
-    --TODO - This should be a no op: Export constructors? Use unsafeCoerce? ...
-    rooted = ( fromBlockId root
-              , toIntMap $ fmap toIntSet graph) :: (Int, IntMap IntSet)
-    tree = fmap toBlockId $ Dom.domTree rooted :: Tree BlockId
-
-    -- Map from Nodes to their dominators
-    domMap :: LabelMap LabelSet
-    domMap = mkDomMap tree
-
-    edges = edgeList cfg :: [(BlockId, BlockId)]
-    -- We can't recompute nodes from edges, there might be blocks not connected via edges.
-    nodes = getCfgNodes cfg :: [BlockId]
-
-    -- identify back edges
-    isBackEdge (from,to)
-      | Just doms <- mapLookup from domMap
-      , setMember to doms
-      = True
-      | otherwise = False
-
-    -- See Note [Determining the loop body]
-    -- Get the loop body associated with a back edge.
-    findBody edge@(tail, head)
-      = ( edge, setInsert head $ go (setSingleton tail) (setSingleton tail) )
-      where
-        -- See Note [Determining the loop body]
-
-
-        go :: LabelSet -> LabelSet -> LabelSet
-        go found current
-          | setNull current = found
-          | otherwise = go  (setUnion newSuccessors found)
-                            newSuccessors
-          where
-            -- Really predecessors, since we use the reversed cfg.
-            newSuccessors = setFilter (\n -> not $ setMember n found) successors :: LabelSet
-            successors = setDelete head $ setUnions $ map
-                                      (\x -> if x == head then setEmpty else setFromList (getSuccessors revCfg x))
-                                      (setElems current) :: LabelSet
-
-    backEdges = filter isBackEdge edges
-    loopBodies = map findBody backEdges :: [(Edge, LabelSet)]
-
-    -- Block b is part of n loop bodies => loop nest level of n
-    loopCounts =
-      let bodies = map (first snd) loopBodies -- [(Header, Body)]
-          loopCount n = length $ nub . map fst . filter (setMember n . snd) $ bodies
-      in  map (\n -> (n, loopCount n)) $ nodes :: [(BlockId, Int)]
-
-    toIntSet :: LabelSet -> IntSet
-    toIntSet s = IS.fromList . map fromBlockId . setElems $ s
-    toIntMap :: LabelMap a -> IntMap a
-    toIntMap m = IM.fromList $ map (\(x,y) -> (fromBlockId x,y)) $ mapToList m
-
-    mkDomMap :: Tree BlockId -> LabelMap LabelSet
-    mkDomMap root = mapFromList $ go setEmpty root
-      where
-        go :: LabelSet -> Tree BlockId -> [(Label,LabelSet)]
-        go parents (Node lbl [])
-          =  [(lbl, parents)]
-        go parents (Node _ leaves)
-          = let nodes = map rootLabel leaves
-                entries = map (\x -> (x,parents)) nodes
-            in  entries ++ concatMap
-                            (\n -> go (setInsert (rootLabel n) parents) n)
-                            leaves
-
-    fromBlockId :: BlockId -> Int
-    fromBlockId = getKey . getUnique
-
-    toBlockId :: Int -> BlockId
-    toBlockId = mkBlockId . mkUniqueGrimily
-
--- We make the CFG a Hoopl Graph, so we can reuse revPostOrder.
-newtype BlockNode (e :: Extensibility) (x :: Extensibility) = BN (BlockId,[BlockId])
-
-instance G.NonLocal (BlockNode) where
-  entryLabel (BN (lbl,_))   = lbl
-  successors (BN (_,succs)) = succs
-
-revPostorderFrom :: HasDebugCallStack => CFG -> BlockId -> [BlockId]
-revPostorderFrom cfg root =
-    map fromNode $ G.revPostorderFrom hooplGraph root
-  where
-    nodes = getCfgNodes cfg
-    hooplGraph = foldl' (\m n -> mapInsert n (toNode n) m) mapEmpty nodes
-
-    fromNode :: BlockNode C C -> BlockId
-    fromNode (BN x) = fst x
-
-    toNode :: BlockId -> BlockNode C C
-    toNode bid =
-        BN (bid,getSuccessors cfg $ bid)
-
-
--- | We take in a CFG which has on its edges weights which are
---   relative only to other edges originating from the same node.
---
---   We return a CFG for which each edge represents a GLOBAL weight.
---   This means edge weights are comparable across the whole graph.
---
---   For irreducible control flow results might be imprecise, otherwise they
---   are reliable.
---
---   The algorithm is based on the Paper
---   "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus
---   The only big change is that we go over the nodes in the body of loops in
---   reverse post order. Which is required for diamond control flow to work probably.
---
---   We also apply a few prediction heuristics (based on the same paper)
---
---   The returned result represents frequences.
---   For blocks it's the expected number of executions and
---   for edges is the number of traversals.
-
-{-# NOINLINE mkGlobalWeights #-}
-{-# SCC mkGlobalWeights #-}
-mkGlobalWeights :: HasDebugCallStack => BlockId -> CFG -> (LabelMap Double, LabelMap (LabelMap Double))
-mkGlobalWeights root localCfg
-  | null localCfg = panic "Error - Empty CFG"
-  | otherwise
-  = (blockFreqs', edgeFreqs')
-  where
-    -- Calculate fixpoints
-    (blockFreqs, edgeFreqs) = calcFreqs nodeProbs backEdges' bodies' revOrder'
-    blockFreqs' = mapFromList $ map (first fromVertex) (assocs blockFreqs) :: LabelMap Double
-    edgeFreqs' = fmap fromVertexMap $ fromVertexMap edgeFreqs
-
-    fromVertexMap :: IM.IntMap x -> LabelMap x
-    fromVertexMap m = mapFromList . map (first fromVertex) $ IM.toList m
-
-    revOrder = revPostorderFrom localCfg root :: [BlockId]
-    loopResults@(LoopInfo backedges _levels bodies) = loopInfo localCfg root
-
-    revOrder' = map toVertex revOrder
-    backEdges' = map (bimap toVertex toVertex) backedges
-    bodies' = map calcBody bodies
-
-    estimatedCfg = staticBranchPrediction root loopResults localCfg
-    -- Normalize the weights to probabilities and apply heuristics
-    nodeProbs = cfgEdgeProbabilities estimatedCfg toVertex
-
-    -- By mapping vertices to numbers in reverse post order we can bring any subset into reverse post
-    -- order simply by sorting.
-    -- TODO: The sort is redundant if we can guarantee that setElems returns elements ascending
-    calcBody (backedge, blocks) =
-        (toVertex $ snd backedge, sort . map toVertex $ (setElems blocks))
-
-    vertexMapping = mapFromList $ zip revOrder [0..] :: LabelMap Int
-    blockMapping = listArray (0,mapSize vertexMapping - 1) revOrder :: Array Int BlockId
-    -- Map from blockId to indices starting at zero
-    toVertex :: BlockId -> Int
-    toVertex   blockId  = expectJust "mkGlobalWeights" $ mapLookup blockId vertexMapping
-    -- Map from indices starting at zero to blockIds
-    fromVertex :: Int -> BlockId
-    fromVertex vertex   = blockMapping ! vertex
-
-{- Note [Static Branch Prediction]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The work here has been based on the paper
-"Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus.
-
-The primary differences are that if we branch on the result of a heap
-check we do not apply any of the heuristics.
-The reason is simple: They look like loops in the control flow graph
-but are usually never entered, and if at most once.
-
-Currently implemented is a heuristic to predict that we do not exit
-loops (lehPredicts) and one to predict that backedges are more likely
-than any other edge.
-
-The back edge case is special as it supersedes any other heuristic if it
-applies.
-
-Do NOT rely solely on nofib results for benchmarking this. I recommend at least
-comparing megaparsec and container benchmarks. Nofib does not seem to have
-many instances of "loopy" Cmm where these make a difference.
-
-TODO:
-* The paper containers more benchmarks which should be implemented.
-* If we turn the likelihood on if/else branches into a probability
-  instead of true/false we could implement this as a Cmm pass.
-  + The complete Cmm code still exists and can be accessed by the heuristics
-  + There is no chance of register allocation/codegen inserting branches/blocks
-  + making the TransitionSource info wrong.
-  + potential to use this information in CmmPasses.
-  - Requires refactoring of all the code relying on the binary nature of likelihood.
-  - Requires refactoring `loopInfo` to work on both, Cmm Graphs and the backend CFG.
--}
-
--- | Combination of target node id and information about the branch
---   we are looking at.
-type TargetNodeInfo = (BlockId, EdgeInfo)
-
-
--- | Update branch weights based on certain heuristics.
--- See Note [Static Branch Prediction]
--- TODO: This should be combined with optimizeCFG
-{-# SCC staticBranchPrediction #-}
-staticBranchPrediction :: BlockId -> LoopInfo -> CFG -> CFG
-staticBranchPrediction _root (LoopInfo l_backEdges loopLevels l_loops) cfg =
-    -- pprTrace "staticEstimatesOn" (ppr (cfg)) $
-    foldl' update cfg nodes
-  where
-    nodes = getCfgNodes cfg
-    backedges = S.fromList $ l_backEdges
-    -- Loops keyed by their back edge
-    loops = M.fromList $ l_loops :: M.Map Edge LabelSet
-    loopHeads = S.fromList $ map snd $ M.keys loops
-
-    update :: CFG -> BlockId -> CFG
-    update cfg node
-        -- No successors, nothing to do.
-        | null successors = cfg
-
-        -- Mix of backedges and others:
-        -- Always predict the backedges.
-        | not (null m) && length m < length successors
-        -- Heap/Stack checks "loop", but only once.
-        -- So we simply exclude any case involving them.
-        , not $ any (isHeapOrStackCheck  . transitionSource . snd) successors
-        = let   loopChance = repeat $! pred_LBH / (fromIntegral $ length m)
-                exitChance = repeat $! (1 - pred_LBH) / fromIntegral (length not_m)
-                updates = zip (map fst m) loopChance ++ zip (map fst not_m) exitChance
-        in  -- pprTrace "mix" (ppr (node,successors)) $
-            foldl' (\cfg (to,weight) -> setEdgeWeight cfg weight node to) cfg updates
-
-        -- For (regular) non-binary branches we keep the weights from the STG -> Cmm translation.
-        | length successors /= 2
-        = cfg
-
-        -- Only backedges - no need to adjust
-        | length m > 0
-        = cfg
-
-        -- A regular binary branch, we can plug addition predictors in here.
-        | [(s1,s1_info),(s2,s2_info)] <- successors
-        , not $ any (isHeapOrStackCheck  . transitionSource . snd) successors
-        = -- Normalize weights to total of 1
-            let !w1 = max (edgeWeight s1_info) (0)
-                !w2 = max (edgeWeight s2_info) (0)
-                -- Of both weights are <= 0 we set both to 0.5
-                normalizeWeight w = if w1 + w2 == 0 then 0.5 else w/(w1+w2)
-                !cfg'  = setEdgeWeight cfg  (normalizeWeight w1) node s1
-                !cfg'' = setEdgeWeight cfg' (normalizeWeight w2) node s2
-
-                -- Figure out which heuristics apply to these successors
-                heuristics = map ($ ((s1,s1_info),(s2,s2_info)))
-                            [lehPredicts, phPredicts, ohPredicts, ghPredicts, lhhPredicts, chPredicts
-                            , shPredicts, rhPredicts]
-                -- Apply result of a heuristic. Argument is the likelihood
-                -- predicted for s1.
-                applyHeuristic :: CFG -> Maybe Prob -> CFG
-                applyHeuristic cfg Nothing = cfg
-                applyHeuristic cfg (Just (s1_pred :: Double))
-                  | s1_old == 0 || s2_old == 0 ||
-                    isHeapOrStackCheck (transitionSource s1_info) ||
-                    isHeapOrStackCheck (transitionSource s2_info)
-                  = cfg
-                  | otherwise =
-                    let -- Predictions from heuristic
-                        s1_prob = EdgeWeight s1_pred :: EdgeWeight
-                        s2_prob = 1.0 - s1_prob
-                        -- Update
-                        d = (s1_old * s1_prob) + (s2_old * s2_prob) :: EdgeWeight
-                        s1_prob' = s1_old * s1_prob / d
-                        !s2_prob' = s2_old * s2_prob / d
-                        !cfg_s1 = setEdgeWeight cfg    s1_prob' node s1
-                    in  -- pprTrace "Applying heuristic!" (ppr (node,s1,s2) $$ ppr (s1_prob', s2_prob')) $
-                        setEdgeWeight cfg_s1 s2_prob' node s2
-                  where
-                    -- Old weights
-                    s1_old = getEdgeWeight cfg node s1
-                    s2_old = getEdgeWeight cfg node s2
-
-            in
-            -- pprTraceIt "RegularCfgResult" $
-            foldl' applyHeuristic cfg'' heuristics
-
-        -- Branch on heap/stack check
-        | otherwise = cfg
-
-      where
-        -- Chance that loops are taken.
-        pred_LBH = 0.875
-        -- successors
-        successors = getSuccessorEdges cfg node
-        -- backedges
-        (m,not_m) = partition (\succ -> S.member (node, fst succ) backedges) successors
-
-        -- Heuristics return nothing if they don't say anything about this branch
-        -- or Just (prob_s1) where prob_s1 is the likelihood for s1 to be the
-        -- taken branch. s1 is the branch in the true case.
-
-        -- Loop exit heuristic.
-        -- We are unlikely to leave a loop unless it's to enter another one.
-        pred_LEH = 0.75
-        -- If and only if no successor is a loopheader,
-        -- then we will likely not exit the current loop body.
-        lehPredicts :: (TargetNodeInfo,TargetNodeInfo) -> Maybe Prob
-        lehPredicts ((s1,_s1_info),(s2,_s2_info))
-          | S.member s1 loopHeads || S.member s2 loopHeads
-          = Nothing
-
-          | otherwise
-          = --pprTrace "lehPredict:" (ppr $ compare s1Level s2Level) $
-            case compare s1Level s2Level of
-                EQ -> Nothing
-                LT -> Just (1-pred_LEH) --s1 exits to a shallower loop level (exits loop)
-                GT -> Just (pred_LEH)   --s1 exits to a deeper loop level
-            where
-                s1Level = mapLookup s1 loopLevels
-                s2Level = mapLookup s2 loopLevels
-
-        -- Comparing to a constant is unlikely to be equal.
-        ohPredicts (s1,_s2)
-            | CmmSource { trans_cmmNode = src1 } <- getTransitionSource node (fst s1) cfg
-            , CmmCondBranch cond ltrue _lfalse likely <- src1
-            , likely == Nothing
-            , CmmMachOp mop args <- cond
-            , MO_Eq {} <- mop
-            , not (null [x | x@CmmLit{} <- args])
-            = if fst s1 == ltrue then Just 0.3 else Just 0.7
-
-            | otherwise
-            = Nothing
-
-        -- TODO: These are all the other heuristics from the paper.
-        -- Not all will apply, for now we just stub them out as Nothing.
-        phPredicts = const Nothing
-        ghPredicts = const Nothing
-        lhhPredicts = const Nothing
-        chPredicts = const Nothing
-        shPredicts = const Nothing
-        rhPredicts = const Nothing
-
--- We normalize all edge weights as probabilities between 0 and 1.
--- Ignoring rounding errors all outgoing edges sum up to 1.
-cfgEdgeProbabilities :: CFG -> (BlockId -> Int) -> IM.IntMap (IM.IntMap Prob)
-cfgEdgeProbabilities cfg toVertex
-    = mapFoldlWithKey foldEdges IM.empty cfg
-  where
-    foldEdges = (\m from toMap -> IM.insert (toVertex from) (normalize toMap) m)
-
-    normalize :: (LabelMap EdgeInfo) -> (IM.IntMap Prob)
-    normalize weightMap
-        | edgeCount <= 1 = mapFoldlWithKey (\m k _ -> IM.insert (toVertex k) 1.0 m) IM.empty weightMap
-        | otherwise = mapFoldlWithKey (\m k _ -> IM.insert (toVertex k) (normalWeight k) m) IM.empty weightMap
-      where
-        edgeCount = mapSize weightMap
-        -- Negative weights are generally allowed but are mapped to zero.
-        -- We then check if there is at least one non-zero edge and if not
-        -- assign uniform weights to all branches.
-        minWeight = 0 :: Prob
-        weightMap' = fmap (\w -> max (weightToDouble . edgeWeight $ w) minWeight) weightMap
-        totalWeight = sum weightMap'
-
-        normalWeight :: BlockId -> Prob
-        normalWeight bid
-         | totalWeight == 0
-         = 1.0 / fromIntegral edgeCount
-         | Just w <- mapLookup bid weightMap'
-         = w/totalWeight
-         | otherwise = panic "impossible"
-
--- This is the fixpoint algorithm from
---   "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus
--- The adaption to Haskell is my own.
-calcFreqs :: IM.IntMap (IM.IntMap Prob) -> [(Int,Int)] -> [(Int, [Int])] -> [Int]
-          -> (Array Int Double, IM.IntMap (IM.IntMap Prob))
-calcFreqs graph backEdges loops revPostOrder = runST $ do
-    visitedNodes <- newArray (0,nodeCount-1) False :: ST s (STUArray s Int Bool)
-    blockFreqs <- newArray (0,nodeCount-1) 0.0 :: ST s (STUArray s Int Double)
-    edgeProbs <- newSTRef graph
-    edgeBackProbs <- newSTRef graph
-
-    -- let traceArray a = do
-    --       vs <- forM [0..nodeCount-1] $ \i -> readArray a i >>= (\v -> return (i,v))
-          -- trace ("array: " ++ show vs) $ return ()
-
-    let  -- See #1600, we need to inline or unboxing makes perf worse.
-        -- {-# INLINE getFreq #-}
-        {-# INLINE visited #-}
-        visited b = unsafeRead visitedNodes b
-        getFreq b = unsafeRead blockFreqs b
-        -- setFreq :: forall s. Int -> Double -> ST s ()
-        setFreq b f = unsafeWrite blockFreqs b f
-        -- setVisited :: forall s. Node -> ST s ()
-        setVisited b = unsafeWrite visitedNodes b True
-        -- Frequency/probability that edge is taken.
-        getProb' arr b1 b2 = readSTRef arr >>=
-            (\graph ->
-                return .
-                        fromMaybe (error "getFreq 1") .
-                        IM.lookup b2 .
-                        fromMaybe (error "getFreq 2") $
-                        (IM.lookup b1 graph)
-            )
-        setProb' arr b1 b2 prob = do
-          g <- readSTRef arr
-          let !m = fromMaybe (error "Foo") $ IM.lookup b1 g
-              !m' = IM.insert b2 prob m
-          writeSTRef arr $! (IM.insert b1 m' g)
-
-        getEdgeFreq b1 b2 = getProb' edgeProbs b1 b2
-        setEdgeFreq b1 b2 = setProb' edgeProbs b1 b2
-        getProb b1 b2 = fromMaybe (error "getProb") $ do
-            m' <- IM.lookup b1 graph
-            IM.lookup b2 m'
-
-        getBackProb b1 b2 = getProb' edgeBackProbs b1 b2
-        setBackProb b1 b2 = setProb' edgeBackProbs b1 b2
-
-
-    let -- calcOutFreqs :: Node -> ST s ()
-        calcOutFreqs bhead block = do
-          !f <- getFreq block
-          forM (successors block) $ \bi -> do
-            let !prob = getProb block bi
-            let !succFreq = f * prob
-            setEdgeFreq block bi succFreq
-            -- traceM $ "SetOut: " ++ show (block, bi, f, prob, succFreq)
-            when (bi == bhead) $ setBackProb block bi succFreq
-
-
-    let propFreq block head = do
-            -- traceM ("prop:" ++ show (block,head))
-            -- traceShowM block
-
-            !v <- visited block
-            if v then
-                return () --Dont look at nodes twice
-            else if block == head then
-                setFreq block 1.0 -- Loop header frequency is always 1
-            else do
-                let preds = IS.elems $ predecessors block
-                irreducible <- (fmap or) $ forM preds $ \bp -> do
-                    !bp_visited <- visited bp
-                    let bp_backedge = isBackEdge bp block
-                    return (not bp_visited && not bp_backedge)
-
-                if irreducible
-                then return () -- Rare we don't care
-                else do
-                    setFreq block 0
-                    !cycleProb <- sum <$> (forM preds $ \pred -> do
-                        if isBackEdge pred block
-                            then
-                                getBackProb pred block
-                            else do
-                                !f <- getFreq block
-                                !prob <- getEdgeFreq pred block
-                                setFreq block $! f + prob
-                                return 0)
-                    -- traceM $ "cycleProb:" ++ show cycleProb
-                    let limit = 1 - 1/512 -- Paper uses 1 - epsilon, but this works.
-                                          -- determines how large likelyhoods in loops can grow.
-                    !cycleProb <- return $ min cycleProb limit -- <- return $ if cycleProb > limit then limit else cycleProb
-                    -- traceM $ "cycleProb:" ++ show cycleProb
-
-                    !f <- getFreq block
-                    setFreq block (f / (1.0 - cycleProb))
-
-            setVisited block
-            calcOutFreqs head block
-
-    -- Loops, by nesting, inner to outer
-    forM_ loops $ \(head, body) -> do
-        forM_ [0 .. nodeCount - 1] (\i -> unsafeWrite visitedNodes i True) -- Mark all nodes as visited.
-        forM_ body (\i -> unsafeWrite visitedNodes i False) -- Mark all blocks reachable from head as not visited
-        forM_ body $ \block -> propFreq block head
-
-    -- After dealing with all loops, deal with non-looping parts of the CFG
-    forM_ [0 .. nodeCount - 1] (\i -> unsafeWrite visitedNodes i False) -- Everything in revPostOrder is reachable
-    forM_ revPostOrder $ \block -> propFreq block (head revPostOrder)
-
-    -- trace ("Final freqs:") $ return ()
-    -- let freqString = pprFreqs freqs
-    -- trace (unlines freqString) $ return ()
-    -- trace (pprFre) $ return ()
-    graph' <- readSTRef edgeProbs
-    freqs' <- unsafeFreeze  blockFreqs
-
-    return (freqs', graph')
-  where
-    -- How can these lookups fail? Consider the CFG [A -> B]
-    predecessors :: Int -> IS.IntSet
-    predecessors b = fromMaybe IS.empty $ IM.lookup b revGraph
-    successors :: Int -> [Int]
-    successors b = fromMaybe (lookupError "succ" b graph)$ IM.keys <$> IM.lookup b graph
-    lookupError s b g = pprPanic ("Lookup error " ++ s) $
-                            ( text "node" <+> ppr b $$
-                                text "graph" <+>
-                                vcat (map (\(k,m) -> ppr (k,m :: IM.IntMap Double)) $ IM.toList g)
-                            )
-
-    nodeCount = IM.foldl' (\count toMap -> IM.foldlWithKey' countTargets (count + 1) toMap) 0 graph
-      where
-        countTargets = (\count k _ -> countNode k + count )
-        countNode n = if IM.member n graph then 0 else 1
-
-    isBackEdge from to = S.member (from,to) backEdgeSet
-    backEdgeSet = S.fromList backEdges
-
-    revGraph :: IntMap IntSet
-    revGraph = IM.foldlWithKey' (\m from toMap -> addEdges m from toMap) IM.empty graph
-        where
-            addEdges m0 from toMap = IM.foldlWithKey' (\m k _ -> addEdge m from k) m0 toMap
-            addEdge m0 from to = IM.insertWith IS.union to (IS.singleton from) m0
diff --git a/compiler/GHC/CmmToAsm/CFG/Dominators.hs b/compiler/GHC/CmmToAsm/CFG/Dominators.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/CFG/Dominators.hs
+++ /dev/null
@@ -1,566 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE Strict #-}
-
-{- |
-  Module      :  GHC.CmmToAsm.CFG.Dominators
-  Copyright   :  (c) Matt Morrow 2009
-  License     :  BSD3
-  Maintainer  :  <klebinger.andreas@gmx.at>
-  Stability   :  stable
-  Portability :  portable
-
-  The Lengauer-Tarjan graph dominators algorithm.
-
-    \[1\] Lengauer, Tarjan,
-      /A Fast Algorithm for Finding Dominators in a Flowgraph/, 1979.
-
-    \[2\] Muchnick,
-      /Advanced Compiler Design and Implementation/, 1997.
-
-    \[3\] Brisk, Sarrafzadeh,
-      /Interference Graphs for Procedures in Static Single/
-      /Information Form are Interval Graphs/, 2007.
-
- * Strictness
-
- Unless stated otherwise all exposed functions might fully evaluate their input
- but are not guaranteed to do so.
-
--}
-
-module GHC.CmmToAsm.CFG.Dominators (
-   Node,Path,Edge
-  ,Graph,Rooted
-  ,idom,ipdom
-  ,domTree,pdomTree
-  ,dom,pdom
-  ,pddfs,rpddfs
-  ,fromAdj,fromEdges
-  ,toAdj,toEdges
-  ,asTree,asGraph
-  ,parents,ancestors
-) where
-
-import GHC.Prelude
-import Data.Bifunctor
-import Data.Tuple (swap)
-
-import Data.Tree
-import Data.IntMap(IntMap)
-import Data.IntSet(IntSet)
-import qualified Data.IntMap.Strict as IM
-import qualified Data.IntSet as IS
-
-import Control.Monad
-import Control.Monad.ST.Strict
-
-import Data.Array.ST
-import Data.Array.Base
-  (unsafeNewArray_
-  ,unsafeWrite,unsafeRead)
-
------------------------------------------------------------------------------
-
-type Node       = Int
-type Path       = [Node]
-type Edge       = (Node,Node)
-type Graph      = IntMap IntSet
-type Rooted     = (Node, Graph)
-
------------------------------------------------------------------------------
-
--- | /Dominators/.
--- Complexity as for @idom@
-dom :: Rooted -> [(Node, Path)]
-dom = ancestors . domTree
-
--- | /Post-dominators/.
--- Complexity as for @idom@.
-pdom :: Rooted -> [(Node, Path)]
-pdom = ancestors . pdomTree
-
--- | /Dominator tree/.
--- Complexity as for @idom@.
-domTree :: Rooted -> Tree Node
-domTree a@(r,_) =
-  let is = filter ((/=r).fst) (idom a)
-      tg = fromEdges (fmap swap is)
-  in asTree (r,tg)
-
--- | /Post-dominator tree/.
--- Complexity as for @idom@.
-pdomTree :: Rooted -> Tree Node
-pdomTree a@(r,_) =
-  let is = filter ((/=r).fst) (ipdom a)
-      tg = fromEdges (fmap swap is)
-  in asTree (r,tg)
-
--- | /Immediate dominators/.
--- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is
--- \"a functional inverse of Ackermann's function\".
---
--- This Complexity bound assumes /O(1)/ indexing. Since we're
--- using @IntMap@, it has an additional /lg |V|/ factor
--- somewhere in there. I'm not sure where.
-idom :: Rooted -> [(Node,Node)]
-idom rg = runST (evalS idomM =<< initEnv (pruneReach rg))
-
--- | /Immediate post-dominators/.
--- Complexity as for @idom@.
-ipdom :: Rooted -> [(Node,Node)]
-ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg)))
-
------------------------------------------------------------------------------
-
--- | /Post-dominated depth-first search/.
-pddfs :: Rooted -> [Node]
-pddfs = reverse . rpddfs
-
--- | /Reverse post-dominated depth-first search/.
-rpddfs :: Rooted -> [Node]
-rpddfs = concat . levels . pdomTree
-
------------------------------------------------------------------------------
-
-type Dom s a = S s (Env s) a
-type NodeSet    = IntSet
-type NodeMap a  = IntMap a
-data Env s = Env
-  {succE      :: !Graph
-  ,predE      :: !Graph
-  ,bucketE    :: !Graph
-  ,dfsE       :: {-# UNPACK #-}!Int
-  ,zeroE      :: {-# UNPACK #-}!Node
-  ,rootE      :: {-# UNPACK #-}!Node
-  ,labelE     :: {-# UNPACK #-}!(Arr s Node)
-  ,parentE    :: {-# UNPACK #-}!(Arr s Node)
-  ,ancestorE  :: {-# UNPACK #-}!(Arr s Node)
-  ,childE     :: {-# UNPACK #-}!(Arr s Node)
-  ,ndfsE      :: {-# UNPACK #-}!(Arr s Node)
-  ,dfnE       :: {-# UNPACK #-}!(Arr s Int)
-  ,sdnoE      :: {-# UNPACK #-}!(Arr s Int)
-  ,sizeE      :: {-# UNPACK #-}!(Arr s Int)
-  ,domE       :: {-# UNPACK #-}!(Arr s Node)
-  ,rnE        :: {-# UNPACK #-}!(Arr s Node)}
-
------------------------------------------------------------------------------
-
-idomM :: Dom s [(Node,Node)]
-idomM = do
-  dfsDom =<< rootM
-  n <- gets dfsE
-  forM_ [n,n-1..1] (\i-> do
-    w <- ndfsM i
-    ps <- predsM w
-    forM_ ps (\v-> do
-      sw <- sdnoM w
-      u <- eval v
-      su <- sdnoM u
-      when (su < sw)
-        (store sdnoE w su))
-    z <- ndfsM =<< sdnoM w
-    modify(\e->e{bucketE=IM.adjust
-                      (w`IS.insert`)
-                      z (bucketE e)})
-    pw <- parentM w
-    link pw w
-    bps <- bucketM pw
-    forM_ bps (\v-> do
-      u <- eval v
-      su <- sdnoM u
-      sv <- sdnoM v
-      let dv = case su < sv of
-                True-> u
-                False-> pw
-      store domE v dv))
-  forM_ [1..n] (\i-> do
-    w <- ndfsM i
-    j <- sdnoM w
-    z <- ndfsM j
-    dw <- domM w
-    when (dw /= z)
-      (do ddw <- domM dw
-          store domE w ddw))
-  fromEnv
-
------------------------------------------------------------------------------
-
-eval :: Node -> Dom s Node
-eval v = do
-  n0 <- zeroM
-  a  <- ancestorM v
-  case a==n0 of
-    True-> labelM v
-    False-> do
-      compress v
-      a   <- ancestorM v
-      l   <- labelM v
-      la  <- labelM a
-      sl  <- sdnoM l
-      sla <- sdnoM la
-      case sl <= sla of
-        True-> return l
-        False-> return la
-
-compress :: Node -> Dom s ()
-compress v = do
-  n0  <- zeroM
-  a   <- ancestorM v
-  aa  <- ancestorM a
-  when (aa /= n0) (do
-    compress a
-    a   <- ancestorM v
-    aa  <- ancestorM a
-    l   <- labelM v
-    la  <- labelM a
-    sl  <- sdnoM l
-    sla <- sdnoM la
-    when (sla < sl)
-      (store labelE v la)
-    store ancestorE v aa)
-
------------------------------------------------------------------------------
-
-link :: Node -> Node -> Dom s ()
-link v w = do
-  n0  <- zeroM
-  lw  <- labelM w
-  slw <- sdnoM lw
-  let balance s = do
-        c   <- childM s
-        lc  <- labelM c
-        slc <- sdnoM lc
-        case slw < slc of
-          False-> return s
-          True-> do
-            zs  <- sizeM s
-            zc  <- sizeM c
-            cc  <- childM c
-            zcc <- sizeM cc
-            case 2*zc <= zs+zcc of
-              True-> do
-                store ancestorE c s
-                store childE s cc
-                balance s
-              False-> do
-                store sizeE c zs
-                store ancestorE s c
-                balance c
-  s   <- balance w
-  lw  <- labelM w
-  zw  <- sizeM w
-  store labelE s lw
-  store sizeE v . (+zw) =<< sizeM v
-  let follow s =
-        when (s /= n0) (do
-          store ancestorE s v
-          follow =<< childM s)
-  zv  <- sizeM v
-  follow =<< case zv < 2*zw of
-              False-> return s
-              True-> do
-                cv <- childM v
-                store childE v s
-                return cv
-
------------------------------------------------------------------------------
-
-dfsDom :: Node -> Dom s ()
-dfsDom i = do
-  _   <- go i
-  n0  <- zeroM
-  r   <- rootM
-  store parentE r n0
-  where go i = do
-          n <- nextM
-          store dfnE   i n
-          store sdnoE  i n
-          store ndfsE  n i
-          store labelE i i
-          ss <- succsM i
-          forM_ ss (\j-> do
-            s <- sdnoM j
-            case s==0 of
-              False-> return()
-              True-> do
-                store parentE j i
-                go j)
-
------------------------------------------------------------------------------
-
-initEnv :: Rooted -> ST s (Env s)
-initEnv (r0,g0) = do
-  -- Graph renumbered to indices from 1 to |V|
-  let (g,rnmap) = renum 1 g0
-      pred      = predG g -- reverse graph
-      root      = rnmap IM.! r0 -- renamed root
-      n         = IM.size g
-      ns        = [0..n]
-      m         = n+1
-
-  let bucket = IM.fromList
-        (zip ns (repeat mempty))
-
-  rna <- newI m
-  writes rna (fmap swap
-        (IM.toList rnmap))
-
-  doms      <- newI m
-  sdno      <- newI m
-  size      <- newI m
-  parent    <- newI m
-  ancestor  <- newI m
-  child     <- newI m
-  label     <- newI m
-  ndfs      <- newI m
-  dfn       <- newI m
-
-  -- Initialize all arrays
-  forM_ [0..n] (doms.=0)
-  forM_ [0..n] (sdno.=0)
-  forM_ [1..n] (size.=1)
-  forM_ [0..n] (ancestor.=0)
-  forM_ [0..n] (child.=0)
-
-  (doms.=root) root
-  (size.=0) 0
-  (label.=0) 0
-
-  return (Env
-    {rnE        = rna
-    ,dfsE       = 0
-    ,zeroE      = 0
-    ,rootE      = root
-    ,labelE     = label
-    ,parentE    = parent
-    ,ancestorE  = ancestor
-    ,childE     = child
-    ,ndfsE      = ndfs
-    ,dfnE       = dfn
-    ,sdnoE      = sdno
-    ,sizeE      = size
-    ,succE      = g
-    ,predE      = pred
-    ,bucketE    = bucket
-    ,domE       = doms})
-
-fromEnv :: Dom s [(Node,Node)]
-fromEnv = do
-  dom   <- gets domE
-  rn    <- gets rnE
-  -- r     <- gets rootE
-  (_,n) <- st (getBounds dom)
-  forM [1..n] (\i-> do
-    j <- st(rn!:i)
-    d <- st(dom!:i)
-    k <- st(rn!:d)
-    return (j,k))
-
------------------------------------------------------------------------------
-
-zeroM :: Dom s Node
-zeroM = gets zeroE
-domM :: Node -> Dom s Node
-domM = fetch domE
-rootM :: Dom s Node
-rootM = gets rootE
-succsM :: Node -> Dom s [Node]
-succsM i = gets (IS.toList . (! i) . succE)
-predsM :: Node -> Dom s [Node]
-predsM i = gets (IS.toList . (! i) . predE)
-bucketM :: Node -> Dom s [Node]
-bucketM i = gets (IS.toList . (! i) . bucketE)
-sizeM :: Node -> Dom s Int
-sizeM = fetch sizeE
-sdnoM :: Node -> Dom s Int
-sdnoM = fetch sdnoE
--- dfnM :: Node -> Dom s Int
--- dfnM = fetch dfnE
-ndfsM :: Int -> Dom s Node
-ndfsM = fetch ndfsE
-childM :: Node -> Dom s Node
-childM = fetch childE
-ancestorM :: Node -> Dom s Node
-ancestorM = fetch ancestorE
-parentM :: Node -> Dom s Node
-parentM = fetch parentE
-labelM :: Node -> Dom s Node
-labelM = fetch labelE
-nextM :: Dom s Int
-nextM = do
-  n <- gets dfsE
-  let n' = n+1
-  modify(\e->e{dfsE=n'})
-  return n'
-
------------------------------------------------------------------------------
-
-type A = STUArray
-type Arr s a = A s Int a
-
-infixl 9 !:
-infixr 2 .=
-
--- | arr .= x idx => write x to index
-(.=) :: (MArray (A s) a (ST s))
-     => Arr s a -> a -> Int -> ST s ()
-(v .= x) i = unsafeWrite v i x
-
-(!:) :: (MArray (A s) a (ST s))
-     => A s Int a -> Int -> ST s a
-a !: i = do
-  o <- unsafeRead a i
-  return $! o
-
-new :: (MArray (A s) a (ST s))
-    => Int -> ST s (Arr s a)
-new n = unsafeNewArray_ (0,n-1)
-
-newI :: Int -> ST s (Arr s Int)
-newI = new
-
-writes :: (MArray (A s) a (ST s))
-     => Arr s a -> [(Int,a)] -> ST s ()
-writes a xs = forM_ xs (\(i,x) -> (a.=x) i)
-
-
-(!) :: Monoid a => IntMap a -> Int -> a
-(!) g n = maybe mempty id (IM.lookup n g)
-
-fromAdj :: [(Node, [Node])] -> Graph
-fromAdj = IM.fromList . fmap (second IS.fromList)
-
-fromEdges :: [Edge] -> Graph
-fromEdges = collectI IS.union fst (IS.singleton . snd)
-
-toAdj :: Graph -> [(Node, [Node])]
-toAdj = fmap (second IS.toList) . IM.toList
-
-toEdges :: Graph -> [Edge]
-toEdges = concatMap (uncurry (fmap . (,))) . toAdj
-
-predG :: Graph -> Graph
-predG g = IM.unionWith IS.union (go g) g0
-  where g0 = fmap (const mempty) g
-        go = flip IM.foldrWithKey mempty (\i a m ->
-                foldl' (\m p -> IM.insertWith mappend p
-                                      (IS.singleton i) m)
-                        m
-                       (IS.toList a))
-
-pruneReach :: Rooted -> Rooted
-pruneReach (r,g) = (r,g2)
-  where is = reachable
-              (maybe mempty id
-                . flip IM.lookup g) $ r
-        g2 = IM.fromList
-            . fmap (second (IS.filter (`IS.member`is)))
-            . filter ((`IS.member`is) . fst)
-            . IM.toList $ g
-
-tip :: Tree a -> (a, [Tree a])
-tip (Node a ts) = (a, ts)
-
-parents :: Tree a -> [(a, a)]
-parents (Node i xs) = p i xs
-        ++ concatMap parents xs
-  where p i = fmap (flip (,) i . rootLabel)
-
-ancestors :: Tree a -> [(a, [a])]
-ancestors = go []
-  where go acc (Node i xs)
-          = let acc' = i:acc
-            in p acc' xs ++ concatMap (go acc') xs
-        p is = fmap (flip (,) is . rootLabel)
-
-asGraph :: Tree Node -> Rooted
-asGraph t@(Node a _) = let g = go t in (a, fromAdj g)
-  where go (Node a ts) = let as = (fst . unzip . fmap tip) ts
-                          in (a, as) : concatMap go ts
-
-asTree :: Rooted -> Tree Node
-asTree (r,g) = let go a = Node a (fmap go ((IS.toList . f) a))
-                   f = (g !)
-            in go r
-
-reachable :: (Node -> NodeSet) -> (Node -> NodeSet)
-reachable f a = go (IS.singleton a) a
-  where go seen a = let s = f a
-                        as = IS.toList (s `IS.difference` seen)
-                    in foldl' go (s `IS.union` seen) as
-
-collectI :: (c -> c -> c)
-        -> (a -> Int) -> (a -> c) -> [a] -> IntMap c
-collectI (<>) f g
-  = foldl' (\m a -> IM.insertWith (<>)
-                                  (f a)
-                                  (g a) m) mempty
-
--- | renum n g: Rename all nodes
---
--- Gives nodes sequential names starting at n.
--- Returns the new graph and a mapping.
--- (renamed, old -> new)
-renum :: Int -> Graph -> (Graph, NodeMap Node)
-renum from = (\(_,m,g)->(g,m))
-  . IM.foldrWithKey
-      (\i ss (!n,!env,!new)->
-          let (j,n2,env2) = go n env i
-              (n3,env3,ss2) = IS.fold
-                (\k (!n,!env,!new)->
-                    case go n env k of
-                      (l,n2,env2)-> (n2,env2,l `IS.insert` new))
-                (n2,env2,mempty) ss
-              new2 = IM.insertWith IS.union j ss2 new
-          in (n3,env3,new2)) (from,mempty,mempty)
-  where go :: Int
-           -> NodeMap Node
-           -> Node
-           -> (Node,Int,NodeMap Node)
-        go !n !env i =
-          case IM.lookup i env of
-            Just j -> (j,n,env)
-            Nothing -> (n,n+1,IM.insert i n env)
-
------------------------------------------------------------------------------
-
--- Nothing better than reinventing the state monad.
-newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o}
-  deriving (Functor)
-instance Monad (S z s) where
-  return = pure
-  S g >>= f = S (\k -> g (\a -> unS (f a) k))
-instance Applicative (S z s) where
-  pure a = S (\k -> k a)
-  (<*>) = ap
--- get :: S z s s
--- get = S (\k s -> k s s)
-gets :: (s -> a) -> S z s a
-gets f = S (\k s -> k (f s) s)
--- set :: s -> S z s ()
--- set s = S (\k _ -> k () s)
-modify :: (s -> s) -> S z s ()
-modify f = S (\k -> k () . f)
--- runS :: S z s a -> s -> ST z (a, s)
--- runS (S g) = g (\a s -> return (a,s))
-evalS :: S z s a -> s -> ST z a
-evalS (S g) = g ((return .) . const)
--- execS :: S z s a -> s -> ST z s
--- execS (S g) = g ((return .) . flip const)
-st :: ST z a -> S z s a
-st m = S (\k s-> do
-  a <- m
-  k a s)
-store :: (MArray (A z) a (ST z))
-      => (s -> Arr z a) -> Int -> a -> S z s ()
-store f i x = do
-  a <- gets f
-  st ((a.=x) i)
-fetch :: (MArray (A z) a (ST z))
-      => (s -> Arr z a) -> Int -> S z s a
-fetch f i = do
-  a <- gets f
-  st (a!:i)
diff --git a/compiler/GHC/CmmToAsm/CPrim.hs b/compiler/GHC/CmmToAsm/CPrim.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/CPrim.hs
+++ /dev/null
@@ -1,160 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
--- | Generating C symbol names emitted by the compiler.
-module GHC.CmmToAsm.CPrim
-    ( atomicReadLabel
-    , atomicWriteLabel
-    , atomicRMWLabel
-    , cmpxchgLabel
-    , xchgLabel
-    , popCntLabel
-    , pdepLabel
-    , pextLabel
-    , bSwapLabel
-    , bRevLabel
-    , clzLabel
-    , ctzLabel
-    , word2FloatLabel
-    ) where
-
-import GHC.Cmm.Type
-import GHC.Cmm.MachOp
-import GHC.Data.FastString
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-popCntLabel :: Width -> FastString
-popCntLabel = \case
-  W8  -> fsLit "hs_popcnt8"
-  W16 -> fsLit "hs_popcnt16"
-  W32 -> fsLit "hs_popcnt32"
-  W64 -> fsLit "hs_popcnt64"
-  w   -> pprPanic "popCntLabel: Unsupported word width " (ppr w)
-
-pdepLabel :: Width -> FastString
-pdepLabel = \case
-  W8  -> fsLit "hs_pdep8"
-  W16 -> fsLit "hs_pdep16"
-  W32 -> fsLit "hs_pdep32"
-  W64 -> fsLit "hs_pdep64"
-  w   -> pprPanic "pdepLabel: Unsupported word width " (ppr w)
-
-pextLabel :: Width -> FastString
-pextLabel = \case
-  W8  -> fsLit "hs_pext8"
-  W16 -> fsLit "hs_pext16"
-  W32 -> fsLit "hs_pext32"
-  W64 -> fsLit "hs_pext64"
-  w   -> pprPanic "pextLabel: Unsupported word width " (ppr w)
-
-bSwapLabel :: Width -> FastString
-bSwapLabel = \case
-  W16 -> fsLit "hs_bswap16"
-  W32 -> fsLit "hs_bswap32"
-  W64 -> fsLit "hs_bswap64"
-  w   -> pprPanic "bSwapLabel: Unsupported word width " (ppr w)
-
-bRevLabel :: Width -> FastString
-bRevLabel = \case
-  W8  -> fsLit "hs_bitrev8"
-  W16 -> fsLit "hs_bitrev16"
-  W32 -> fsLit "hs_bitrev32"
-  W64 -> fsLit "hs_bitrev64"
-  w   -> pprPanic "bRevLabel: Unsupported word width " (ppr w)
-
-clzLabel :: Width -> FastString
-clzLabel = \case
-  W8  -> fsLit "hs_clz8"
-  W16 -> fsLit "hs_clz16"
-  W32 -> fsLit "hs_clz32"
-  W64 -> fsLit "hs_clz64"
-  w   -> pprPanic "clzLabel: Unsupported word width " (ppr w)
-
-ctzLabel :: Width -> FastString
-ctzLabel = \case
-  W8  -> fsLit "hs_ctz8"
-  W16 -> fsLit "hs_ctz16"
-  W32 -> fsLit "hs_ctz32"
-  W64 -> fsLit "hs_ctz64"
-  w   -> pprPanic "ctzLabel: Unsupported word width " (ppr w)
-
-word2FloatLabel :: Width -> FastString
-word2FloatLabel = \case
-  W32 -> fsLit "hs_word2float32"
-  W64 -> fsLit "hs_word2float64"
-  w   -> pprPanic "word2FloatLabel: Unsupported word width " (ppr w)
-
-atomicRMWLabel :: Width -> AtomicMachOp -> FastString
-atomicRMWLabel w amop = case amop of
-  -- lots of boring cases, but we do it this way to get shared FastString
-  -- literals (compared to concatenating strings and allocating FastStrings at
-  -- runtime)
-  AMO_Add  -> case w of
-    W8  -> fsLit "hs_atomic_add8"
-    W16 -> fsLit "hs_atomic_add16"
-    W32 -> fsLit "hs_atomic_add32"
-    W64 -> fsLit "hs_atomic_add64"
-    _   -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)
-  AMO_Sub  -> case w of
-    W8  -> fsLit "hs_atomic_sub8"
-    W16 -> fsLit "hs_atomic_sub16"
-    W32 -> fsLit "hs_atomic_sub32"
-    W64 -> fsLit "hs_atomic_sub64"
-    _   -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)
-  AMO_And  -> case w of
-    W8  -> fsLit "hs_atomic_and8"
-    W16 -> fsLit "hs_atomic_and16"
-    W32 -> fsLit "hs_atomic_and32"
-    W64 -> fsLit "hs_atomic_and64"
-    _   -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)
-  AMO_Nand  -> case w of
-    W8  -> fsLit "hs_atomic_nand8"
-    W16 -> fsLit "hs_atomic_nand16"
-    W32 -> fsLit "hs_atomic_nand32"
-    W64 -> fsLit "hs_atomic_nand64"
-    _   -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)
-  AMO_Or  -> case w of
-    W8  -> fsLit "hs_atomic_or8"
-    W16 -> fsLit "hs_atomic_or16"
-    W32 -> fsLit "hs_atomic_or32"
-    W64 -> fsLit "hs_atomic_or64"
-    _   -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)
-  AMO_Xor  -> case w of
-    W8  -> fsLit "hs_atomic_xor8"
-    W16 -> fsLit "hs_atomic_xor16"
-    W32 -> fsLit "hs_atomic_xor32"
-    W64 -> fsLit "hs_atomic_xor64"
-    _   -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)
-
-
-xchgLabel :: Width -> FastString
-xchgLabel = \case
-  W8  -> fsLit "hs_xchg8"
-  W16 -> fsLit "hs_xchg16"
-  W32 -> fsLit "hs_xchg32"
-  W64 -> fsLit "hs_xchg64"
-  w   -> pprPanic "xchgLabel: Unsupported word width " (ppr w)
-
-cmpxchgLabel :: Width -> FastString
-cmpxchgLabel = \case
-  W8  -> fsLit "hs_cmpxchg8"
-  W16 -> fsLit "hs_cmpxchg16"
-  W32 -> fsLit "hs_cmpxchg32"
-  W64 -> fsLit "hs_cmpxchg64"
-  w   -> pprPanic "cmpxchgLabel: Unsupported word width " (ppr w)
-
-atomicReadLabel :: Width -> FastString
-atomicReadLabel = \case
-  W8  -> fsLit "hs_atomicread8"
-  W16 -> fsLit "hs_atomicread16"
-  W32 -> fsLit "hs_atomicread32"
-  W64 -> fsLit "hs_atomicread64"
-  w   -> pprPanic "atomicReadLabel: Unsupported word width " (ppr w)
-
-atomicWriteLabel :: Width -> FastString
-atomicWriteLabel = \case
-  W8  -> fsLit "hs_atomicwrite8"
-  W16 -> fsLit "hs_atomicwrite16"
-  W32 -> fsLit "hs_atomicwrite32"
-  W64 -> fsLit "hs_atomicwrite64"
-  w   -> pprPanic "atomicWriteLabel: Unsupported word width " (ppr w)
diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Config.hs
+++ /dev/null
@@ -1,63 +0,0 @@
--- | Native code generator configuration
-module GHC.CmmToAsm.Config
-   ( NCGConfig(..)
-   , ncgWordWidth
-   , ncgSpillPreallocSize
-   , platformWordWidth
-   )
-where
-
-import GHC.Prelude
-import GHC.Platform
-import GHC.Cmm.Type (Width(..))
-import GHC.CmmToAsm.CFG.Weight
-import GHC.Unit.Module (Module)
-import GHC.Utils.Outputable
-
--- | Native code generator configuration
-data NCGConfig = NCGConfig
-   { ncgPlatform              :: !Platform        -- ^ Target platform
-   , ncgAsmContext            :: !SDocContext     -- ^ Context for ASM code generation
-   , ncgThisModule            :: !Module          -- ^ The name of the module we are currently compiling
-   , ncgProcAlignment         :: !(Maybe Int)     -- ^ Mandatory proc alignment
-   , ncgExternalDynamicRefs   :: !Bool            -- ^ Generate code to link against dynamic libraries
-   , ncgPIC                   :: !Bool            -- ^ Enable Position-Independent Code
-   , ncgInlineThresholdMemcpy :: !Word            -- ^ If inlining `memcpy` produces less than this threshold (in pseudo-instruction unit), do it
-   , ncgInlineThresholdMemset :: !Word            -- ^ Ditto for `memset`
-   , ncgSplitSections         :: !Bool            -- ^ Split sections
-   , ncgRegsIterative         :: !Bool
-   , ncgRegsGraph             :: !Bool
-   , ncgAsmLinting            :: !Bool            -- ^ Perform ASM linting pass
-   , ncgDoConstantFolding     :: !Bool            -- ^ Perform CMM constant folding
-   , ncgSseVersion            :: Maybe SseVersion -- ^ (x86) SSE instructions
-   , ncgBmiVersion            :: Maybe BmiVersion -- ^ (x86) BMI instructions
-   , ncgDumpRegAllocStages    :: !Bool
-   , ncgDumpAsmStats          :: !Bool
-   , ncgDumpAsmConflicts      :: !Bool
-   , ncgCfgWeights            :: !Weights         -- ^ CFG edge weights
-   , ncgCfgBlockLayout        :: !Bool            -- ^ Use CFG based block layout algorithm
-   , ncgCfgWeightlessLayout   :: !Bool            -- ^ Layout based on last instruction per block.
-   , ncgDwarfEnabled          :: !Bool            -- ^ Enable Dwarf generation
-   , ncgDwarfUnwindings       :: !Bool            -- ^ Enable unwindings
-   , ncgDwarfStripBlockInfo   :: !Bool            -- ^ Strip out block information from generated Dwarf
-   , ncgExposeInternalSymbols :: !Bool            -- ^ Expose symbol table entries for internal symbols
-   , ncgDwarfSourceNotes      :: !Bool            -- ^ Enable GHC-specific source note DIEs
-   , ncgCmmStaticPred         :: !Bool            -- ^ Enable static control-flow prediction
-   , ncgEnableShortcutting    :: !Bool            -- ^ Enable shortcutting (don't jump to blocks only containing a jump)
-   , ncgComputeUnwinding      :: !Bool            -- ^ Compute block unwinding tables
-   , ncgEnableDeadCodeElimination :: !Bool        -- ^ Whether to enable the dead-code elimination
-   }
-
--- | Return Word size
-ncgWordWidth :: NCGConfig -> Width
-ncgWordWidth config = platformWordWidth (ncgPlatform config)
-
--- | Size in bytes of the pre-allocated spill space on the C stack
-ncgSpillPreallocSize :: NCGConfig -> Int
-ncgSpillPreallocSize config = pc_RESERVED_C_STACK_BYTES (platformConstants (ncgPlatform config))
-
--- | Return Word size
-platformWordWidth :: Platform -> Width
-platformWordWidth platform = case platformWordSize platform of
-   PW4 -> W32
-   PW8 -> W64
diff --git a/compiler/GHC/CmmToAsm/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Dwarf.hs
+++ /dev/null
@@ -1,271 +0,0 @@
-module GHC.CmmToAsm.Dwarf (
-  dwarfGen
-  ) where
-
-import GHC.Prelude
-
-import GHC.Cmm.CLabel
-import GHC.Cmm.Expr        ( GlobalReg(..) )
-import GHC.Settings.Config ( cProjectName, cProjectVersion )
-import GHC.Types.Tickish   ( CmmTickish, GenTickish(..) )
-import GHC.Cmm.DebugBlock
-import GHC.Unit.Module
-import GHC.Utils.Outputable
-import GHC.Platform
-import GHC.Types.Unique
-import GHC.Types.Unique.Supply
-
-import GHC.CmmToAsm.Dwarf.Constants
-import GHC.CmmToAsm.Dwarf.Types
-import GHC.CmmToAsm.Config
-
-import Control.Arrow    ( first )
-import Control.Monad    ( mfilter )
-import Data.Maybe
-import Data.List        ( sortBy )
-import Data.Ord         ( comparing )
-import qualified Data.Map as Map
-import System.FilePath
-
-import qualified GHC.Cmm.Dataflow.Label as H
-import qualified GHC.Cmm.Dataflow.Collections as H
-
--- | Generate DWARF/debug information
-dwarfGen :: IsDoc doc => String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock]
-            -> (doc, UniqSupply)
-dwarfGen _        _      _      us []     = (empty, us)
-dwarfGen compPath config modLoc us blocks =
-  let platform = ncgPlatform config
-
-      -- Convert debug data structures to DWARF info records
-      procs = debugSplitProcs blocks
-      stripBlocks dbg
-        | ncgDwarfStripBlockInfo config = dbg { dblBlocks = [] }
-        | otherwise                     = dbg
-      lowLabel = dblCLabel $ head procs
-      highLabel = mkAsmTempProcEndLabel $ dblCLabel $ last procs
-      dwarfUnit = DwarfCompileUnit
-        { dwChildren = map (procToDwarf config) (map stripBlocks procs)
-        , dwName = fromMaybe "" (ml_hs_file modLoc)
-        , dwCompDir = addTrailingPathSeparator compPath
-        , dwProducer = cProjectName ++ " " ++ cProjectVersion
-        , dwLowLabel = lowLabel
-        , dwHighLabel = highLabel
-        }
-
-      -- Check whether we have any source code information, so we do not
-      -- end up writing a pointer to an empty .debug_line section
-      -- (dsymutil on Mac Os gets confused by this).
-      haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)
-                      || any haveSrcIn (dblBlocks blk)
-      haveSrc = any haveSrcIn procs
-
-  -- .debug_abbrev section: Declare the format we're using
-      abbrevSct = pprAbbrevDecls platform haveSrc
-
-  -- .debug_info section: Information records on procedures and blocks
-      -- unique to identify start and end compilation unit .debug_inf
-      (unitU, us') = takeUniqFromSupply us
-      infoSct = vcat [ line (dwarfInfoLabel <> colon)
-                     , dwarfInfoSection platform
-                     , compileUnitHeader platform unitU
-                     , pprDwarfInfo platform haveSrc dwarfUnit
-                     , compileUnitFooter platform unitU
-                     ]
-
-  -- .debug_line section: Generated mainly by the assembler, but we
-  -- need to label it
-      lineSct = dwarfLineSection platform $$
-                line (dwarfLineLabel <> colon)
-
-  -- .debug_frame section: Information about the layout of the GHC stack
-      (framesU, us'') = takeUniqFromSupply us'
-      frameSct = dwarfFrameSection platform $$
-                 line (dwarfFrameLabel <> colon) $$
-                 pprDwarfFrame platform (debugFrame framesU procs)
-
-  -- .aranges section: Information about the bounds of compilation units
-      aranges' | ncgSplitSections config = map mkDwarfARange procs
-               | otherwise               = [DwarfARange lowLabel highLabel]
-      aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU
-
-  in (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
-{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] -> (SDoc, UniqSupply) #-}
-{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] -> (HDoc, UniqSupply) #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Build an address range entry for one proc.
--- With split sections, each proc needs its own entry, since they may get
--- scattered in the final binary. Without split sections, we could make a
--- single arange based on the first/last proc.
-mkDwarfARange :: DebugBlock -> DwarfARange
-mkDwarfARange proc = DwarfARange lbl end
-  where
-    lbl = dblCLabel proc
-    end = mkAsmTempProcEndLabel lbl
-
--- | Header for a compilation unit, establishing global format
--- parameters
-compileUnitHeader :: IsDoc doc => Platform -> Unique -> doc
-compileUnitHeader platform unitU =
-  let cuLabel = mkAsmTempLabel unitU  -- sits right before initialLength field
-      length = pprAsmLabel platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pprAsmLabel platform cuLabel
-               <> text "-4"       -- length of initialLength field
-  in vcat [ line (pprAsmLabel platform cuLabel <> colon)
-          , line (text "\t.long " <> length)  -- compilation unit size
-          , pprHalf 3                          -- DWARF version
-          , sectionOffset platform dwarfAbbrevLabel dwarfAbbrevLabel
-                                               -- abbrevs offset
-          , line (text "\t.byte " <> int (platformWordSizeInBytes platform)) -- word size
-          ]
-
--- | Compilation unit footer, mainly establishing size of debug sections
-compileUnitFooter :: IsDoc doc => Platform -> Unique -> doc
-compileUnitFooter platform unitU =
-  let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU
-  in line (pprAsmLabel platform cuEndLabel <> colon)
-
--- | Splits the blocks by procedures. In the result all nested blocks
--- will come from the same procedure as the top-level block. See
--- Note [Splitting DebugBlocks] for details.
-debugSplitProcs :: [DebugBlock] -> [DebugBlock]
-debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map (split Nothing) b
-  where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty
-        split :: Maybe DebugBlock -> DebugBlock -> H.LabelMap [DebugBlock]
-        split parent blk = H.mapInsert prc [blk'] nested
-          where prc = dblProcedure blk
-                blk' = blk { dblBlocks = own_blks
-                           , dblParent = parent
-                           }
-                own_blks = fromMaybe [] $ H.mapLookup prc nested
-                nested = mergeMaps $ map (split parent') $ dblBlocks blk
-                -- Figure out who should be the parent of nested blocks.
-                -- If @blk@ is optimized out then it isn't a good choice
-                -- and we just use its parent.
-                parent'
-                  | Nothing <- dblPosition blk = parent
-                  | otherwise                  = Just blk
-
-{-
-Note [Splitting DebugBlocks]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-DWARF requires that we break up the nested DebugBlocks produced from
-the C-- AST. For instance, we begin with tick trees containing nested procs.
-For example,
-
-    proc A [tick1, tick2]
-      block B [tick3]
-        proc C [tick4]
-
-when producing DWARF we need to procs (which are represented in DWARF as
-TAG_subprogram DIEs) to be top-level DIEs. debugSplitProcs is responsible for
-this transform, pulling out the nested procs into top-level procs.
-
-However, in doing this we need to be careful to preserve the parentage of the
-nested procs. This is the reason DebugBlocks carry the dblParent field, allowing
-us to reorganize the above tree as,
-
-    proc A [tick1, tick2]
-      block B [tick3]
-    proc C [tick4] parent=B
-
-Here we have annotated the new proc C with an attribute giving its original
-parent, B.
--}
-
--- | Generate DWARF info for a procedure debug block
-procToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo
-procToDwarf config prc
-  = DwarfSubprogram { dwChildren = map (blockToDwarf config) (dblBlocks prc)
-                    , dwName     = case dblSourceTick prc of
-                         Just s@SourceNote{} -> sourceName s
-                         _otherwise -> show (dblLabel prc)
-                    , dwLabel    = dblCLabel prc
-                    , dwParent   = fmap mkAsmTempDieLabel
-                                   $ mfilter goodParent
-                                   $ fmap dblCLabel (dblParent prc)
-                    }
-  where
-  goodParent a | a == dblCLabel prc = False
-               -- Omit parent if it would be self-referential
-  goodParent a | not (externallyVisibleCLabel a)
-               , ncgDwarfStripBlockInfo config = False
-               -- If we strip block information, don't refer to blocks.
-               -- Fixes #14894.
-  goodParent _ = True
-
--- | Generate DWARF info for a block
-blockToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo
-blockToDwarf config blk
-  = DwarfBlock { dwChildren = map (blockToDwarf config) (dblBlocks blk) ++ srcNotes
-               , dwLabel    = dblCLabel blk
-               , dwMarker   = marker
-               }
-  where
-    srcNotes
-      | ncgDwarfSourceNotes config = concatMap tickToDwarf (dblTicks blk)
-      | otherwise                  = []
-
-    marker
-      | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk
-      | otherwise                 = Nothing   -- block was optimized out
-
-tickToDwarf :: CmmTickish -> [DwarfInfo]
-tickToDwarf  (SourceNote ss _) = [DwarfSrcNote ss]
-tickToDwarf _ = []
-
--- | Generates the data for the debug frame section, which encodes the
--- desired stack unwind behaviour for the debugger
-debugFrame :: Unique -> [DebugBlock] -> DwarfFrame
-debugFrame u procs
-  = DwarfFrame { dwCieLabel = mkAsmTempLabel u
-               , dwCieInit  = initUws
-               , dwCieProcs = map (procToFrame initUws) procs
-               }
-  where
-    initUws :: UnwindTable
-    initUws = Map.fromList [(Sp, Just (UwReg Sp 0))]
-
--- | Generates unwind information for a procedure debug block
-procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
-procToFrame initUws blk
-  = DwarfFrameProc { dwFdeProc    = dblCLabel blk
-                   , dwFdeHasInfo = dblHasInfoTbl blk
-                   , dwFdeBlocks  = map (uncurry blockToFrame)
-                                        (setHasInfo blockUws)
-                   }
-  where blockUws :: [(DebugBlock, [UnwindPoint])]
-        blockUws = map snd $ sortBy (comparing fst) $ flatten blk
-
-        flatten :: DebugBlock
-                -> [(Int, (DebugBlock, [UnwindPoint]))]
-        flatten b@DebugBlock{ dblPosition=pos, dblUnwind=uws, dblBlocks=blocks }
-          | Just p <- pos  = (p, (b, uws')):nested
-          | otherwise      = nested -- block was optimized out
-          where uws'   = addDefaultUnwindings initUws uws
-                nested = concatMap flatten blocks
-
-        -- If the current procedure has an info table, then we also say that
-        -- its first block has one to ensure that it gets the necessary -1
-        -- offset applied to its start address.
-        -- See Note [Info Offset] in "GHC.CmmToAsm.Dwarf.Types".
-        setHasInfo :: [(DebugBlock, [UnwindPoint])]
-                   -> [(DebugBlock, [UnwindPoint])]
-        setHasInfo [] = []
-        setHasInfo (c0:cs) = first setIt c0 : cs
-          where
-            setIt child =
-              child { dblHasInfoTbl = dblHasInfoTbl child
-                                      || dblHasInfoTbl blk }
-
-blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock
-blockToFrame blk uws
-  = DwarfFrameBlock { dwFdeBlkHasInfo = dblHasInfoTbl blk
-                    , dwFdeUnwind     = uws
-                    }
-
-addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint]
-addDefaultUnwindings tbl pts =
-    [ UnwindPoint lbl (tbl' `mappend` tbl)
-      -- mappend is left-biased
-    | UnwindPoint lbl tbl' <- pts
-    ]
diff --git a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Dwarf/Constants.hs
+++ /dev/null
@@ -1,256 +0,0 @@
--- | Constants describing the DWARF format. Most of this simply
--- mirrors \/usr\/include\/dwarf.h.
-
-module GHC.CmmToAsm.Dwarf.Constants where
-
-import GHC.Prelude
-
-import GHC.Utils.Asm
-import GHC.Platform
-import GHC.Utils.Outputable
-
-import GHC.Platform.Reg
-import GHC.CmmToAsm.X86.Regs
-import GHC.CmmToAsm.PPC.Regs (toRegNo)
-
-import Data.Word
-
--- | Language ID used for Haskell.
-dW_LANG_Haskell :: Word
-dW_LANG_Haskell = 0x18
-  -- Thanks to Nathan Howell for getting us our very own language ID!
-
--- * Dwarf tags
-dW_TAG_compile_unit, dW_TAG_subroutine_type,
-  dW_TAG_file_type, dW_TAG_subprogram, dW_TAG_lexical_block,
-  dW_TAG_base_type, dW_TAG_structure_type, dW_TAG_pointer_type,
-  dW_TAG_array_type, dW_TAG_subrange_type, dW_TAG_typedef,
-  dW_TAG_variable, dW_TAG_arg_variable, dW_TAG_auto_variable,
-  dW_TAG_ghc_src_note :: Word
-dW_TAG_array_type      = 1
-dW_TAG_lexical_block   = 11
-dW_TAG_pointer_type    = 15
-dW_TAG_compile_unit    = 17
-dW_TAG_structure_type  = 19
-dW_TAG_typedef         = 22
-dW_TAG_subroutine_type = 32
-dW_TAG_subrange_type   = 33
-dW_TAG_base_type       = 36
-dW_TAG_file_type       = 41
-dW_TAG_subprogram      = 46
-dW_TAG_variable        = 52
-dW_TAG_auto_variable   = 256
-dW_TAG_arg_variable    = 257
-
-dW_TAG_ghc_src_note    = 0x5b00
-
--- * Dwarf attributes
-dW_AT_name, dW_AT_stmt_list, dW_AT_low_pc, dW_AT_high_pc, dW_AT_language,
-  dW_AT_comp_dir, dW_AT_producer, dW_AT_external, dW_AT_frame_base,
-  dW_AT_use_UTF8, dW_AT_linkage_name :: Word
-dW_AT_name              = 0x03
-dW_AT_stmt_list         = 0x10
-dW_AT_low_pc            = 0x11
-dW_AT_high_pc           = 0x12
-dW_AT_language          = 0x13
-dW_AT_comp_dir          = 0x1b
-dW_AT_producer          = 0x25
-dW_AT_external          = 0x3f
-dW_AT_frame_base        = 0x40
-dW_AT_use_UTF8          = 0x53
-dW_AT_linkage_name      = 0x6e
-
--- * Custom DWARF attributes
--- Chosen a more or less random section of the vendor-extensible region
-
--- ** Describing C-- blocks
--- These appear in DW_TAG_lexical_scope DIEs corresponding to C-- blocks
-dW_AT_ghc_tick_parent :: Word
-dW_AT_ghc_tick_parent     = 0x2b20
-
--- ** Describing source notes
--- These appear in DW_TAG_ghc_src_note DIEs
-dW_AT_ghc_span_file, dW_AT_ghc_span_start_line,
-  dW_AT_ghc_span_start_col, dW_AT_ghc_span_end_line,
-  dW_AT_ghc_span_end_col :: Word
-dW_AT_ghc_span_file       = 0x2b00
-dW_AT_ghc_span_start_line = 0x2b01
-dW_AT_ghc_span_start_col  = 0x2b02
-dW_AT_ghc_span_end_line   = 0x2b03
-dW_AT_ghc_span_end_col    = 0x2b04
-
-
--- * Abbrev declarations
-dW_CHILDREN_no, dW_CHILDREN_yes :: Word8
-dW_CHILDREN_no  = 0
-dW_CHILDREN_yes = 1
-
-dW_FORM_addr, dW_FORM_data2, dW_FORM_data4, dW_FORM_string, dW_FORM_flag,
-  dW_FORM_block1, dW_FORM_ref4, dW_FORM_ref_addr, dW_FORM_flag_present :: Word
-dW_FORM_addr   = 0x01
-dW_FORM_data2  = 0x05
-dW_FORM_data4  = 0x06
-dW_FORM_string = 0x08
-dW_FORM_flag   = 0x0c
-dW_FORM_block1 = 0x0a
-dW_FORM_ref_addr     = 0x10
-dW_FORM_ref4         = 0x13
-dW_FORM_flag_present = 0x19
-
--- * Dwarf native types
-dW_ATE_address, dW_ATE_boolean, dW_ATE_float, dW_ATE_signed,
-  dW_ATE_signed_char, dW_ATE_unsigned, dW_ATE_unsigned_char :: Word
-dW_ATE_address       = 1
-dW_ATE_boolean       = 2
-dW_ATE_float         = 4
-dW_ATE_signed        = 5
-dW_ATE_signed_char   = 6
-dW_ATE_unsigned      = 7
-dW_ATE_unsigned_char = 8
-
--- * Call frame information
-dW_CFA_set_loc, dW_CFA_undefined, dW_CFA_same_value,
-  dW_CFA_def_cfa, dW_CFA_def_cfa_offset, dW_CFA_def_cfa_expression,
-  dW_CFA_expression, dW_CFA_offset_extended_sf, dW_CFA_def_cfa_offset_sf,
-  dW_CFA_def_cfa_sf, dW_CFA_val_offset, dW_CFA_val_expression,
-  dW_CFA_offset :: Word8
-dW_CFA_set_loc            = 0x01
-dW_CFA_undefined          = 0x07
-dW_CFA_same_value         = 0x08
-dW_CFA_def_cfa            = 0x0c
-dW_CFA_def_cfa_offset     = 0x0e
-dW_CFA_def_cfa_expression = 0x0f
-dW_CFA_expression         = 0x10
-dW_CFA_offset_extended_sf = 0x11
-dW_CFA_def_cfa_sf         = 0x12
-dW_CFA_def_cfa_offset_sf  = 0x13
-dW_CFA_val_offset         = 0x14
-dW_CFA_val_expression     = 0x16
-dW_CFA_offset             = 0x80
-
--- * Operations
-dW_OP_addr, dW_OP_deref, dW_OP_consts,
-  dW_OP_minus, dW_OP_mul, dW_OP_plus,
-  dW_OP_lit0, dW_OP_breg0, dW_OP_call_frame_cfa :: Word8
-dW_OP_addr           = 0x03
-dW_OP_deref          = 0x06
-dW_OP_consts         = 0x11
-dW_OP_minus          = 0x1c
-dW_OP_mul            = 0x1e
-dW_OP_plus           = 0x22
-dW_OP_lit0           = 0x30
-dW_OP_breg0          = 0x70
-dW_OP_call_frame_cfa = 0x9c
-
--- * Dwarf section declarations
-dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection,
-  dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: IsDoc doc => Platform -> doc
-dwarfInfoSection    platform = dwarfSection platform "info"
-dwarfAbbrevSection  platform = dwarfSection platform "abbrev"
-dwarfLineSection    platform = dwarfSection platform "line"
-dwarfFrameSection   platform = dwarfSection platform "frame"
-dwarfGhcSection     platform = dwarfSection platform "ghc"
-dwarfARangesSection platform = dwarfSection platform "aranges"
-{-# SPECIALIZE dwarfInfoSection :: Platform -> SDoc #-}
-{-# SPECIALIZE dwarfInfoSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-{-# SPECIALIZE dwarfAbbrevSection :: Platform -> SDoc #-}
-{-# SPECIALIZE dwarfAbbrevSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-{-# SPECIALIZE dwarfLineSection :: Platform -> SDoc #-}
-{-# SPECIALIZE dwarfLineSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-{-# SPECIALIZE dwarfFrameSection :: Platform -> SDoc #-}
-{-# SPECIALIZE dwarfFrameSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-{-# SPECIALIZE dwarfGhcSection :: Platform -> SDoc #-}
-{-# SPECIALIZE dwarfGhcSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-{-# SPECIALIZE dwarfARangesSection :: Platform -> SDoc #-}
-{-# SPECIALIZE dwarfARangesSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
-dwarfSection :: IsDoc doc => Platform -> String -> doc
-dwarfSection platform name =
-  line $ case platformOS platform of
-    os | osElfTarget os
-       -> text "\t.section .debug_" <> text name <> text ",\"\","
-          <> sectionType platform "progbits"
-       | osMachOTarget os
-       -> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug"
-       | otherwise
-       -> text "\t.section .debug_" <> text name <> text ",\"dr\""
-{-# SPECIALIZE dwarfSection :: Platform -> String -> SDoc #-}
-{-# SPECIALIZE dwarfSection :: Platform -> String -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
-
--- * Dwarf section labels
-dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: IsLine doc => doc
-dwarfInfoLabel   = text ".Lsection_info"
-dwarfAbbrevLabel = text ".Lsection_abbrev"
-dwarfLineLabel   = text ".Lsection_line"
-dwarfFrameLabel  = text ".Lsection_frame"
-{-# SPECIALIZE dwarfInfoLabel :: SDoc #-}
-{-# SPECIALIZE dwarfInfoLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-{-# SPECIALIZE dwarfAbbrevLabel :: SDoc #-}
-{-# SPECIALIZE dwarfAbbrevLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-{-# SPECIALIZE dwarfLineLabel :: SDoc #-}
-{-# SPECIALIZE dwarfLineLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-{-# SPECIALIZE dwarfFrameLabel :: SDoc #-}
-{-# SPECIALIZE dwarfFrameLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Mapping of registers to DWARF register numbers
-dwarfRegNo :: Platform -> Reg -> Word8
-dwarfRegNo p r = case platformArch p of
-  ArchX86
-    | r == eax  -> 0
-    | r == ecx  -> 1  -- yes, no typo
-    | r == edx  -> 2
-    | r == ebx  -> 3
-    | r == esp  -> 4
-    | r == ebp  -> 5
-    | r == esi  -> 6
-    | r == edi  -> 7
-  ArchX86_64
-    | r == rax  -> 0
-    | r == rdx  -> 1 -- this neither. The order GCC allocates registers in?
-    | r == rcx  -> 2
-    | r == rbx  -> 3
-    | r == rsi  -> 4
-    | r == rdi  -> 5
-    | r == rbp  -> 6
-    | r == rsp  -> 7
-    | r == r8   -> 8
-    | r == r9   -> 9
-    | r == r10  -> 10
-    | r == r11  -> 11
-    | r == r12  -> 12
-    | r == r13  -> 13
-    | r == r14  -> 14
-    | r == r15  -> 15
-    | r == xmm0 -> 17
-    | r == xmm1 -> 18
-    | r == xmm2 -> 19
-    | r == xmm3 -> 20
-    | r == xmm4 -> 21
-    | r == xmm5 -> 22
-    | r == xmm6 -> 23
-    | r == xmm7 -> 24
-    | r == xmm8 -> 25
-    | r == xmm9 -> 26
-    | r == xmm10 -> 27
-    | r == xmm11 -> 28
-    | r == xmm12 -> 29
-    | r == xmm13 -> 30
-    | r == xmm14 -> 31
-    | r == xmm15 -> 32
-  ArchPPC_64 _ -> fromIntegral $ toRegNo r
-  ArchAArch64  -> fromIntegral $ toRegNo r
-  _other -> error "dwarfRegNo: Unsupported platform or unknown register!"
-
--- | Virtual register number to use for return address.
-dwarfReturnRegNo :: Platform -> Word8
-dwarfReturnRegNo p
-  -- We "overwrite" IP with our pseudo register - that makes sense, as
-  -- when using this mechanism gdb already knows the IP anyway. Clang
-  -- does this too, so it must be safe.
-  = case platformArch p of
-    ArchX86    -> 8  -- eip
-    ArchX86_64 -> 16 -- rip
-    ArchPPC_64 ELF_V2 -> 65 -- lr (link register)
-    ArchAArch64-> 30
-    _other     -> error "dwarfReturnRegNo: Unsupported platform!"
diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs
+++ /dev/null
@@ -1,654 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module GHC.CmmToAsm.Dwarf.Types
-  ( -- * Dwarf information
-    DwarfInfo(..)
-  , pprDwarfInfo
-  , pprAbbrevDecls
-    -- * Dwarf address range table
-  , DwarfARange(..)
-  , pprDwarfARanges
-    -- * Dwarf frame
-  , DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..)
-  , pprDwarfFrame
-    -- * Utilities
-  , pprByte
-  , pprHalf
-  , pprData4'
-  , pprDwWord
-  , pprWord
-  , pprLEBWord
-  , pprLEBInt
-  , wordAlign
-  , sectionOffset
-  )
-  where
-
-import GHC.Prelude
-
-import GHC.Cmm.DebugBlock
-import GHC.Cmm.CLabel
-import GHC.Cmm.Expr         ( GlobalReg(..) )
-import GHC.Utils.Encoding
-import GHC.Data.FastString
-import GHC.Utils.Outputable
-import GHC.Platform
-import GHC.Types.Unique
-import GHC.Platform.Reg
-import GHC.Types.SrcLoc
-import GHC.Utils.Misc
-
-import GHC.CmmToAsm.Dwarf.Constants
-
-import qualified Data.ByteString as BS
-import qualified GHC.Utils.Monad.State.Strict as S
-import Control.Monad (zipWithM, join)
-import qualified Data.Map as Map
-import Data.Word
-import Data.Char
-
-import GHC.Platform.Regs
-
--- | Individual dwarf records. Each one will be encoded as an entry in
--- the @.debug_info@ section.
-data DwarfInfo
-  = DwarfCompileUnit { dwChildren :: [DwarfInfo]
-                     , dwName :: String
-                     , dwProducer :: String
-                     , dwCompDir :: String
-                     , dwLowLabel :: CLabel
-                     , dwHighLabel :: CLabel }
-  | DwarfSubprogram { dwChildren :: [DwarfInfo]
-                    , dwName :: String
-                    , dwLabel :: CLabel
-                    , dwParent :: Maybe CLabel
-                      -- ^ label of DIE belonging to the parent tick
-                    }
-  | DwarfBlock { dwChildren :: [DwarfInfo]
-               , dwLabel :: CLabel
-               , dwMarker :: Maybe CLabel
-               }
-  | DwarfSrcNote { dwSrcSpan :: RealSrcSpan
-                 }
-
--- | Abbreviation codes used for encoding above records in the
--- @.debug_info@ section.
-data DwarfAbbrev
-  = DwAbbrNull          -- ^ Pseudo, used for marking the end of lists
-  | DwAbbrCompileUnit
-  | DwAbbrSubprogram
-  | DwAbbrSubprogramWithParent
-  | DwAbbrBlockWithoutCode
-  | DwAbbrBlock
-  | DwAbbrGhcSrcNote
-  deriving (Eq, Enum)
-
--- | Generate assembly for the given abbreviation code
-pprAbbrev :: IsDoc doc => DwarfAbbrev -> doc
-pprAbbrev = pprLEBWord . fromIntegral . fromEnum
-
--- | Abbreviation declaration. This explains the binary encoding we
--- use for representing 'DwarfInfo'. Be aware that this must be updated
--- along with 'pprDwarfInfo'.
-pprAbbrevDecls :: IsDoc doc => Platform -> Bool -> doc
-pprAbbrevDecls platform haveDebugLine =
-  let mkAbbrev abbr tag chld flds =
-        let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form
-        in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$
-           vcat (map fld flds) $$ pprByte 0 $$ pprByte 0
-      -- These are shared between DwAbbrSubprogram and
-      -- DwAbbrSubprogramWithParent
-      subprogramAttrs =
-           [ (dW_AT_name, dW_FORM_string)
-           , (dW_AT_linkage_name, dW_FORM_string)
-           , (dW_AT_external, dW_FORM_flag)
-           , (dW_AT_low_pc, dW_FORM_addr)
-           , (dW_AT_high_pc, dW_FORM_addr)
-           , (dW_AT_frame_base, dW_FORM_block1)
-           ]
-  in dwarfAbbrevSection platform $$
-     line (dwarfAbbrevLabel <> colon) $$
-     mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes
-       ([(dW_AT_name,     dW_FORM_string)
-       , (dW_AT_producer, dW_FORM_string)
-       , (dW_AT_language, dW_FORM_data4)
-       , (dW_AT_comp_dir, dW_FORM_string)
-       , (dW_AT_use_UTF8, dW_FORM_flag_present)  -- not represented in body
-       , (dW_AT_low_pc,   dW_FORM_addr)
-       , (dW_AT_high_pc,  dW_FORM_addr)
-       ] ++
-       (if haveDebugLine
-        then [ (dW_AT_stmt_list, dW_FORM_data4) ]
-        else [])) $$
-     mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes
-       subprogramAttrs $$
-     mkAbbrev DwAbbrSubprogramWithParent dW_TAG_subprogram dW_CHILDREN_yes
-       (subprogramAttrs ++ [(dW_AT_ghc_tick_parent, dW_FORM_ref_addr)]) $$
-     mkAbbrev DwAbbrBlockWithoutCode dW_TAG_lexical_block dW_CHILDREN_yes
-       [ (dW_AT_name, dW_FORM_string)
-       ] $$
-     mkAbbrev DwAbbrBlock dW_TAG_lexical_block dW_CHILDREN_yes
-       [ (dW_AT_name, dW_FORM_string)
-       , (dW_AT_low_pc, dW_FORM_addr)
-       , (dW_AT_high_pc, dW_FORM_addr)
-       ] $$
-     mkAbbrev DwAbbrGhcSrcNote dW_TAG_ghc_src_note dW_CHILDREN_no
-       [ (dW_AT_ghc_span_file, dW_FORM_string)
-       , (dW_AT_ghc_span_start_line, dW_FORM_data4)
-       , (dW_AT_ghc_span_start_col, dW_FORM_data2)
-       , (dW_AT_ghc_span_end_line, dW_FORM_data4)
-       , (dW_AT_ghc_span_end_col, dW_FORM_data2)
-       ] $$
-     pprByte 0
-{-# SPECIALIZE pprAbbrevDecls :: Platform -> Bool -> SDoc #-}
-{-# SPECIALIZE pprAbbrevDecls :: Platform -> Bool -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Generate assembly for DWARF data
-pprDwarfInfo :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc
-pprDwarfInfo platform haveSrc d
-  = case d of
-      DwarfCompileUnit {}  -> hasChildren
-      DwarfSubprogram {}   -> hasChildren
-      DwarfBlock {}        -> hasChildren
-      DwarfSrcNote {}      -> noChildren
-  where
-    hasChildren =
-        pprDwarfInfoOpen platform haveSrc d $$
-        vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$
-        pprDwarfInfoClose
-    noChildren = pprDwarfInfoOpen platform haveSrc d
-{-# SPECIALIZE pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc #-}
-{-# SPECIALIZE pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Print a CLabel name in a ".stringz \"LABEL\""
-pprLabelString :: IsDoc doc => Platform -> CLabel -> doc
-pprLabelString platform label =
-   pprString'                  -- we don't need to escape the string as labels don't contain exotic characters
-    $ pprCLabel platform label -- pretty-print as C label (foreign labels may be printed differently in Asm)
-
--- | Prints assembler data corresponding to DWARF info records. Note
--- that the binary format of this is parameterized in @abbrevDecls@ and
--- has to be kept in synch.
-pprDwarfInfoOpen :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc
-pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
-                                           highLabel) =
-  pprAbbrev DwAbbrCompileUnit
-  $$ pprString name
-  $$ pprString producer
-  $$ pprData4 dW_LANG_Haskell
-  $$ pprString compDir
-     -- Offset due to Note [Info Offset]
-  $$ pprWord platform (pprAsmLabel platform lowLabel <> text "-1")
-  $$ pprWord platform (pprAsmLabel platform highLabel)
-  $$ if haveSrc
-     then sectionOffset platform dwarfLineLabel dwarfLineLabel
-     else empty
-pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) =
-  line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon)
-  $$ pprAbbrev abbrev
-  $$ pprString name
-  $$ pprLabelString platform label
-  $$ pprFlag (externallyVisibleCLabel label)
-     -- Offset due to Note [Info Offset]
-  $$ pprWord platform (pprAsmLabel platform label <> text "-1")
-  $$ pprWord platform (pprAsmLabel platform $ mkAsmTempProcEndLabel label)
-  $$ pprByte 1
-  $$ pprByte dW_OP_call_frame_cfa
-  $$ parentValue
-  where
-    abbrev = case parent of Nothing -> DwAbbrSubprogram
-                            Just _  -> DwAbbrSubprogramWithParent
-    parentValue = maybe empty pprParentDie parent
-    pprParentDie sym = sectionOffset platform (pprAsmLabel platform sym) dwarfInfoLabel
-pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) =
-  line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon)
-  $$ pprAbbrev DwAbbrBlockWithoutCode
-  $$ pprLabelString platform label
-pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) =
-  line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon)
-  $$ pprAbbrev DwAbbrBlock
-  $$ pprLabelString platform label
-  $$ pprWord platform (pprAsmLabel platform marker)
-  $$ pprWord platform (pprAsmLabel platform $ mkAsmTempEndLabel marker)
-pprDwarfInfoOpen _ _ (DwarfSrcNote ss) =
-  pprAbbrev DwAbbrGhcSrcNote
-  $$ pprString' (ftext $ srcSpanFile ss)
-  $$ pprData4 (fromIntegral $ srcSpanStartLine ss)
-  $$ pprHalf (fromIntegral $ srcSpanStartCol ss)
-  $$ pprData4 (fromIntegral $ srcSpanEndLine ss)
-  $$ pprHalf (fromIntegral $ srcSpanEndCol ss)
-
--- | Close a DWARF info record with children
-pprDwarfInfoClose :: IsDoc doc => doc
-pprDwarfInfoClose = pprAbbrev DwAbbrNull
-
--- | A DWARF address range. This is used by the debugger to quickly locate
--- which compilation unit a given address belongs to. This type assumes
--- a non-segmented address-space.
-data DwarfARange
-  = DwarfARange
-    { dwArngStartLabel :: CLabel
-    , dwArngEndLabel   :: CLabel
-    }
-
--- | Print assembler directives corresponding to a DWARF @.debug_aranges@
--- address table entry.
-pprDwarfARanges :: IsDoc doc => Platform -> [DwarfARange] -> Unique -> doc
-pprDwarfARanges platform arngs unitU =
-  let wordSize = platformWordSizeInBytes platform
-      paddingSize = 4 :: Int
-      -- header is 12 bytes long.
-      -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).
-      -- pad such that first entry begins at multiple of entry size.
-      pad n = vcat $ replicate n $ pprByte 0
-      -- Fix for #17428
-      initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize
-  in pprDwWord (int initialLength)
-     $$ pprHalf 2
-     $$ sectionOffset platform (pprAsmLabel platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel
-     $$ pprByte (fromIntegral wordSize)
-     $$ pprByte 0
-     $$ pad paddingSize
-     -- body
-     $$ vcat (map (pprDwarfARange platform) arngs)
-     -- terminus
-     $$ pprWord platform (char '0')
-     $$ pprWord platform (char '0')
-{-# SPECIALIZE pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc #-}
-{-# SPECIALIZE pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
-pprDwarfARange :: IsDoc doc => Platform -> DwarfARange -> doc
-pprDwarfARange platform arng =
-    -- Offset due to Note [Info Offset].
-    pprWord platform (pprAsmLabel platform (dwArngStartLabel arng) <> text "-1")
-    $$ pprWord platform length
-  where
-    length = pprAsmLabel platform (dwArngEndLabel arng)
-             <> char '-' <> pprAsmLabel platform (dwArngStartLabel arng)
-
--- | Information about unwind instructions for a procedure. This
--- corresponds to a "Common Information Entry" (CIE) in DWARF.
-data DwarfFrame
-  = DwarfFrame
-    { dwCieLabel :: CLabel
-    , dwCieInit  :: UnwindTable
-    , dwCieProcs :: [DwarfFrameProc]
-    }
-
--- | Unwind instructions for an individual procedure. Corresponds to a
--- "Frame Description Entry" (FDE) in DWARF.
-data DwarfFrameProc
-  = DwarfFrameProc
-    { dwFdeProc    :: CLabel
-    , dwFdeHasInfo :: Bool
-    , dwFdeBlocks  :: [DwarfFrameBlock]
-      -- ^ List of blocks. Order must match asm!
-    }
-
--- | Unwind instructions for a block. Will become part of the
--- containing FDE.
-data DwarfFrameBlock
-  = DwarfFrameBlock
-    { dwFdeBlkHasInfo :: Bool
-    , dwFdeUnwind     :: [UnwindPoint]
-      -- ^ these unwind points must occur in the same order as they occur
-      -- in the block
-    }
-
-instance OutputableP Platform DwarfFrameBlock where
-  pdoc env (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> pdoc env unwinds
-
--- | Header for the @.debug_frame@ section. Here we emit the "Common
--- Information Entry" record that establishes general call frame
--- parameters and the default stack layout.
-pprDwarfFrame :: forall doc. IsDoc doc => Platform -> DwarfFrame -> doc
-pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
-  = let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")
-        cieEndLabel = mkAsmTempEndLabel cieLabel
-        length      = pprAsmLabel platform cieEndLabel <> char '-' <> pprAsmLabel platform cieStartLabel
-        spReg       = dwarfGlobalRegNo platform Sp
-        retReg      = dwarfReturnRegNo platform
-        wordSize    = platformWordSizeInBytes platform
-        pprInit :: (GlobalReg, Maybe UnwindExpr) -> doc
-        pprInit (g, uw) = pprSetUnwind platform g (Nothing, uw)
-
-        -- Preserve C stack pointer: This necessary to override that default
-        -- unwinding behavior of setting $sp = CFA.
-        preserveSp = case platformArch platform of
-          ArchX86    -> pprByte dW_CFA_same_value $$ pprLEBWord 4
-          ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7
-          _          -> empty
-    in vcat [ line (pprAsmLabel platform cieLabel <> colon)
-            , pprData4' length -- Length of CIE
-            , line (pprAsmLabel platform cieStartLabel <> colon)
-            , pprData4' (text "-1")
-                               -- Common Information Entry marker (-1 = 0xf..f)
-            , pprByte 3        -- CIE version (we require DWARF 3)
-            , pprByte 0        -- Augmentation (none)
-            , pprByte 1        -- Code offset multiplicator
-            , pprByte (128-fromIntegral wordSize)
-                               -- Data offset multiplicator
-                               -- (stacks grow down => "-w" in signed LEB128)
-            , pprByte retReg   -- virtual register holding return address
-            ] $$
-       -- Initial unwind table
-       vcat (map pprInit $ Map.toList cieInit) $$
-       vcat [ -- RET = *CFA
-              pprByte (dW_CFA_offset+retReg)
-            , pprByte 0
-
-              -- Preserve C stack pointer
-            , preserveSp
-
-              -- Sp' = CFA
-              -- (we need to set this manually as our (STG) Sp register is
-              -- often not the architecture's default stack register)
-            , pprByte dW_CFA_val_offset
-            , pprLEBWord (fromIntegral spReg)
-            , pprLEBWord 0
-            ] $$
-       wordAlign platform $$
-       line (pprAsmLabel platform cieEndLabel <> colon) $$
-       -- Procedure unwind tables
-       vcat (map (pprFrameProc platform cieLabel cieInit) procs)
-{-# SPECIALIZE pprDwarfFrame :: Platform -> DwarfFrame -> SDoc #-}
-{-# SPECIALIZE pprDwarfFrame :: Platform -> DwarfFrame -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Writes a "Frame Description Entry" for a procedure. This consists
--- mainly of referencing the CIE and writing state machine
--- instructions to describe how the frame base (CFA) changes.
-pprFrameProc :: IsDoc doc => Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> doc
-pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
-  = let fdeLabel    = mkAsmTempDerivedLabel procLbl (fsLit "_fde")
-        fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end")
-        procEnd     = mkAsmTempProcEndLabel procLbl
-        ifInfo str  = if hasInfo then text str else empty
-                      -- see Note [Info Offset]
-    in vcat [ whenPprDebug $ line $ text "# Unwinding for" <+> pprAsmLabel platform procLbl <> colon
-            , pprData4' (pprAsmLabel platform fdeEndLabel <> char '-' <> pprAsmLabel platform fdeLabel)
-            , line (pprAsmLabel platform fdeLabel <> colon)
-            , pprData4' (pprAsmLabel platform frameLbl <> char '-' <> dwarfFrameLabel)    -- Reference to CIE
-            , pprWord platform (pprAsmLabel platform procLbl <> ifInfo "-1") -- Code pointer
-            , pprWord platform (pprAsmLabel platform procEnd <> char '-' <>
-                                 pprAsmLabel platform procLbl <> ifInfo "+1") -- Block byte length
-            ] $$
-       vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$
-       wordAlign platform $$
-       line (pprAsmLabel platform fdeEndLabel <> colon)
-
--- | Generates unwind information for a block. We only generate
--- instructions where unwind information actually changes. This small
--- optimisations saves a lot of space, as subsequent blocks often have
--- the same unwind information.
-pprFrameBlock :: forall doc. IsDoc doc => Platform -> DwarfFrameBlock -> S.State UnwindTable doc
-pprFrameBlock platform (DwarfFrameBlock hasInfo uws0) =
-    vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0
-  where
-    pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable doc
-    pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws ->
-        let -- Did a register's unwind expression change?
-            isChanged :: GlobalReg -> Maybe UnwindExpr
-                      -> Maybe (Maybe UnwindExpr, Maybe UnwindExpr)
-            isChanged g new
-                -- the value didn't change
-              | Just new == old = Nothing
-                -- the value was and still is undefined
-              | Nothing <- old
-              , Nothing <- new  = Nothing
-                -- the value changed
-              | otherwise       = Just (join old, new)
-              where
-                old = Map.lookup g oldUws
-
-            changed = Map.toList $ Map.mapMaybeWithKey isChanged uws
-
-        in if oldUws == uws
-             then (empty, oldUws)
-             else let -- see Note [Info Offset]
-                      needsOffset = firstDecl && hasInfo
-                      lblDoc = pprAsmLabel platform lbl <>
-                               if needsOffset then text "-1" else empty
-                      doc = pprByte dW_CFA_set_loc $$ pprWord platform lblDoc $$
-                            vcat (map (uncurry $ pprSetUnwind platform) changed)
-                  in (doc, uws)
-
--- Note [Info Offset]
--- ~~~~~~~~~~~~~~~~~~
--- GDB was pretty much written with C-like programs in mind, and as a
--- result they assume that once you have a return address, it is a
--- good idea to look at (PC-1) to unwind further - as that's where the
--- "call" instruction is supposed to be.
---
--- Now on one hand, code generated by GHC looks nothing like what GDB
--- expects, and in fact going up from a return pointer is guaranteed
--- to land us inside an info table! On the other hand, that actually
--- gives us some wiggle room, as we expect IP to never *actually* end
--- up inside the info table, so we can "cheat" by putting whatever GDB
--- expects to see there. This is probably pretty safe, as GDB cannot
--- assume (PC-1) to be a valid code pointer in the first place - and I
--- have seen no code trying to correct this.
---
--- Note that this will not prevent GDB from failing to look-up the
--- correct function name for the frame, as that uses the symbol table,
--- which we can not manipulate as easily.
---
--- We apply this offset in several places:
---
---  * unwind information in .debug_frames
---  * the subprogram and lexical_block DIEs in .debug_info
---  * the ranges in .debug_aranges
---
--- In the latter two cases we apply the offset unconditionally.
---
--- There's a GDB patch to address this at [1]. At the moment of writing
--- it's not merged, so I recommend building GDB with the patch if you
--- care about unwinding. The hack above doesn't cover every case.
---
--- [1] https://sourceware.org/ml/gdb-patches/2018-02/msg00055.html
-
--- | Get DWARF register ID for a given GlobalReg
-dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8
-dwarfGlobalRegNo p UnwindReturnReg = dwarfReturnRegNo p
-dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg
-
--- | Generate code for setting the unwind information for a register,
--- optimized using its known old value in the table. Note that "Sp" is
--- special: We see it as synonym for the CFA.
-pprSetUnwind :: IsDoc doc => Platform
-             -> GlobalReg
-                -- ^ the register to produce an unwinding table entry for
-             -> (Maybe UnwindExpr, Maybe UnwindExpr)
-                -- ^ the old and new values of the register
-             -> doc
-pprSetUnwind plat g  (_, Nothing)
-  = pprUndefUnwind plat g
-pprSetUnwind _    Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s'
-  = if o' >= 0
-    then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o')
-    else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o'
-pprSetUnwind plat Sp (_, Just (UwReg s' o'))
-  = if o' >= 0
-    then pprByte dW_CFA_def_cfa $$
-         pprLEBRegNo plat s' $$
-         pprLEBWord (fromIntegral o')
-    else pprByte dW_CFA_def_cfa_sf $$
-         pprLEBRegNo plat s' $$
-         pprLEBInt o'
-pprSetUnwind plat Sp (_, Just uw)
-  = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr plat False uw
-pprSetUnwind plat g  (_, Just (UwDeref (UwReg Sp o)))
-  | o < 0 && ((-o) `mod` platformWordSizeInBytes plat) == 0 -- expected case
-  = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$
-    pprLEBWord (fromIntegral ((-o) `div` platformWordSizeInBytes plat))
-  | otherwise
-  = pprByte dW_CFA_offset_extended_sf $$
-    pprLEBRegNo plat g $$
-    pprLEBInt o
-pprSetUnwind plat g  (_, Just (UwDeref uw))
-  = pprByte dW_CFA_expression $$
-    pprLEBRegNo plat g $$
-    pprUnwindExpr plat True uw
-pprSetUnwind plat g  (_, Just (UwReg g' 0))
-  | g == g'
-  = pprByte dW_CFA_same_value $$
-    pprLEBRegNo plat g
-pprSetUnwind plat g  (_, Just uw)
-  = pprByte dW_CFA_val_expression $$
-    pprLEBRegNo plat g $$
-    pprUnwindExpr plat True uw
-
--- | Print the register number of the given 'GlobalReg' as an unsigned LEB128
--- encoded number.
-pprLEBRegNo :: IsDoc doc => Platform -> GlobalReg -> doc
-pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat
-
--- | Generates a DWARF expression for the given unwind expression. If
--- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets
--- mentioned.
-pprUnwindExpr :: IsDoc doc => Platform -> Bool -> UnwindExpr -> doc
-pprUnwindExpr platform spIsCFA expr
-  = let pprE (UwConst i)
-          | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i)
-          | otherwise        = pprByte dW_OP_consts $$ pprLEBInt i -- lazy...
-        pprE (UwReg Sp i) | spIsCFA
-                             = if i == 0
-                               then pprByte dW_OP_call_frame_cfa
-                               else pprE (UwPlus (UwReg Sp 0) (UwConst i))
-        pprE (UwReg g i)      = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$
-                               pprLEBInt i
-        pprE (UwDeref u)      = pprE u $$ pprByte dW_OP_deref
-        pprE (UwLabel l)      = pprByte dW_OP_addr $$ pprWord platform (pprAsmLabel platform l)
-        pprE (UwPlus u1 u2)   = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus
-        pprE (UwMinus u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus
-        pprE (UwTimes u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul
-    in line (text "\t.uleb128 2f-1f") $$ -- DW_FORM_block length
-       -- computed as the difference of the following local labels 2: and 1:
-       line (text "1:") $$
-       pprE expr $$
-       line (text "2:")
-
--- | Generate code for re-setting the unwind information for a
--- register to @undefined@
-pprUndefUnwind :: IsDoc doc => Platform -> GlobalReg -> doc
-pprUndefUnwind plat g  = pprByte dW_CFA_undefined $$
-                         pprLEBRegNo plat g
-
-
--- | Align assembly at (machine) word boundary
-wordAlign :: IsDoc doc => Platform -> doc
-wordAlign plat =
-  line $ text "\t.align " <> case platformOS plat of
-    OSDarwin -> case platformWordSize plat of
-      PW8 -> char '3'
-      PW4 -> char '2'
-    _other   -> int (platformWordSizeInBytes plat)
-{-# SPECIALIZE wordAlign :: Platform -> SDoc #-}
-{-# SPECIALIZE wordAlign :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Assembly for a single byte of constant DWARF data
-pprByte :: IsDoc doc => Word8 -> doc
-pprByte x = line $ text "\t.byte " <> integer (fromIntegral x)
-{-# SPECIALIZE pprByte :: Word8 -> SDoc #-}
-{-# SPECIALIZE pprByte :: Word8 -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Assembly for a two-byte constant integer
-pprHalf :: IsDoc doc => Word16 -> doc
-pprHalf x = line $ text "\t.short" <+> integer (fromIntegral x)
-{-# SPECIALIZE pprHalf :: Word16 -> SDoc #-}
-{-# SPECIALIZE pprHalf :: Word16 -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Assembly for a constant DWARF flag
-pprFlag :: IsDoc doc => Bool -> doc
-pprFlag f = pprByte (if f then 0xff else 0x00)
-
--- | Assembly for 4 bytes of dynamic DWARF data
-pprData4' :: IsDoc doc => Line doc -> doc
-pprData4' x = line (text "\t.long " <> x)
-{-# SPECIALIZE pprData4' :: SDoc -> SDoc #-}
-{-# SPECIALIZE pprData4' :: HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Assembly for 4 bytes of constant DWARF data
-pprData4 :: IsDoc doc => Word -> doc
-pprData4 = pprData4' . integer . fromIntegral
-
--- | Assembly for a DWARF word of dynamic data. This means 32 bit, as
--- we are generating 32 bit DWARF.
-pprDwWord :: IsDoc doc => Line doc -> doc
-pprDwWord = pprData4'
-{-# SPECIALIZE pprDwWord :: SDoc -> SDoc #-}
-{-# SPECIALIZE pprDwWord :: HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Assembly for a machine word of dynamic data. Depends on the
--- architecture we are currently generating code for.
-pprWord :: IsDoc doc => Platform -> Line doc -> doc
-pprWord plat s =
-  line $ case platformWordSize plat of
-    PW4 -> text "\t.long " <> s
-    PW8 -> text "\t.quad " <> s
-{-# SPECIALIZE pprWord :: Platform -> SDoc -> SDoc #-}
-{-# SPECIALIZE pprWord :: Platform -> HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Prints a number in "little endian base 128" format. The idea is
--- to optimize for small numbers by stopping once all further bytes
--- would be 0. The highest bit in every byte signals whether there
--- are further bytes to read.
-pprLEBWord :: IsDoc doc => Word -> doc
-pprLEBWord x | x < 128   = pprByte (fromIntegral x)
-             | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
-                           pprLEBWord (x `shiftR` 7)
-{-# SPECIALIZE pprLEBWord :: Word -> SDoc #-}
-{-# SPECIALIZE pprLEBWord :: Word -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Same as @pprLEBWord@, but for a signed number
-pprLEBInt :: IsDoc doc => Int -> doc
-pprLEBInt x | x >= -64 && x < 64
-                        = pprByte (fromIntegral (x .&. 127))
-            | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
-                          pprLEBInt (x `shiftR` 7)
-{-# SPECIALIZE pprLEBInt :: Int -> SDoc #-}
-{-# SPECIALIZE pprLEBInt :: Int -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Generates a dynamic null-terminated string. If required the
--- caller needs to make sure that the string is escaped properly.
-pprString' :: IsDoc doc => Line doc -> doc
-pprString' str = line (text "\t.asciz \"" <> str <> char '"')
-
--- | Generate a string constant. We take care to escape the string.
-pprString :: IsDoc doc => String -> doc
-pprString str
-  = pprString' $ hcat $ map escapeChar $
-    if str `lengthIs` utf8EncodedLength str
-    then str
-    else map (chr . fromIntegral) $ BS.unpack $ utf8EncodeByteString str
-
--- | Escape a single non-unicode character
-escapeChar :: IsLine doc => Char -> doc
-escapeChar '\\' = text "\\\\"
-escapeChar '\"' = text "\\\""
-escapeChar '\n' = text "\\n"
-escapeChar c
-  | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings
-  = char c
-  | otherwise
-  = char '\\' <> char (intToDigit (ch `div` 64)) <>
-                 char (intToDigit ((ch `div` 8) `mod` 8)) <>
-                 char (intToDigit (ch `mod` 8))
-  where ch = ord c
-
--- | Generate an offset into another section. This is tricky because
--- this is handled differently depending on platform: Mac Os expects
--- us to calculate the offset using assembler arithmetic. Linux expects
--- us to just reference the target directly, and will figure out on
--- their own that we actually need an offset. Finally, Windows has
--- a special directive to refer to relative offsets. Fun.
-sectionOffset :: IsDoc doc => Platform -> Line doc -> Line doc -> doc
-sectionOffset plat target section =
-  case platformOS plat of
-    OSDarwin  -> pprDwWord (target <> char '-' <> section)
-    OSMinGW32 -> line (text "\t.secrel32 " <> target)
-    _other    -> pprDwWord target
-{-# SPECIALIZE sectionOffset :: Platform -> SDoc -> SDoc -> SDoc #-}
-{-# SPECIALIZE sectionOffset :: Platform -> HLine -> HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
diff --git a/compiler/GHC/CmmToAsm/Format.hs b/compiler/GHC/CmmToAsm/Format.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Format.hs
+++ /dev/null
@@ -1,110 +0,0 @@
--- | Formats on this architecture
---      A Format is a combination of width and class
---
---      TODO:   Signed vs unsigned?
---
---      TODO:   This module is currently shared by all architectures because
---              NCGMonad need to know about it to make a VReg. It would be better
---              to have architecture specific formats, and do the overloading
---              properly. eg SPARC doesn't care about FF80.
---
-module GHC.CmmToAsm.Format (
-    Format(..),
-    intFormat,
-    floatFormat,
-    isIntFormat,
-    isFloatFormat,
-    cmmTypeFormat,
-    formatToWidth,
-    formatInBytes
-)
-
-where
-
-import GHC.Prelude
-
-import GHC.Cmm
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
--- It looks very like the old MachRep, but it's now of purely local
--- significance, here in the native code generator.  You can change it
--- without global consequences.
---
--- A major use is as an opcode qualifier; thus the opcode
---      mov.l a b
--- might be encoded
---      MOV II32 a b
--- where the Format field encodes the ".l" part.
-
--- ToDo: it's not clear to me that we need separate signed-vs-unsigned formats
---        here.  I've removed them from the x86 version, we'll see what happens --SDM
-
--- ToDo: quite a few occurrences of Format could usefully be replaced by Width
-
-data Format
-        = II8
-        | II16
-        | II32
-        | II64
-        | FF32
-        | FF64
-        deriving (Show, Eq)
-
-
--- | Get the integer format of this width.
-intFormat :: Width -> Format
-intFormat width
- = case width of
-        W8      -> II8
-        W16     -> II16
-        W32     -> II32
-        W64     -> II64
-        other   -> sorry $ "The native code generator cannot " ++
-            "produce code for Format.intFormat " ++ show other
-            ++ "\n\tConsider using the llvm backend with -fllvm"
-
-
--- | Get the float format of this width.
-floatFormat :: Width -> Format
-floatFormat width
- = case width of
-        W32     -> FF32
-        W64     -> FF64
-
-        other   -> pprPanic "Format.floatFormat" (ppr other)
-
--- | Check if a format represent an integer value.
-isIntFormat :: Format -> Bool
-isIntFormat = not . isFloatFormat
-
--- | Check if a format represents a floating point value.
-isFloatFormat :: Format -> Bool
-isFloatFormat format
- = case format of
-        FF32    -> True
-        FF64    -> True
-        _       -> False
-
-
--- | Convert a Cmm type to a Format.
-cmmTypeFormat :: CmmType -> Format
-cmmTypeFormat ty
-        | isFloatType ty        = floatFormat (typeWidth ty)
-        | otherwise             = intFormat (typeWidth ty)
-
-
--- | Get the Width of a Format.
-formatToWidth :: Format -> Width
-formatToWidth format
- = case format of
-        II8             -> W8
-        II16            -> W16
-        II32            -> W32
-        II64            -> W64
-        FF32            -> W32
-        FF64            -> W64
-
-
-formatInBytes :: Format -> Int
-formatInBytes = widthInBytes . formatToWidth
diff --git a/compiler/GHC/CmmToAsm/Instr.hs b/compiler/GHC/CmmToAsm/Instr.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Instr.hs
+++ /dev/null
@@ -1,164 +0,0 @@
-
-module GHC.CmmToAsm.Instr
-   ( Instruction(..)
-   , RegUsage(..)
-   , noUsage
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Platform.Reg
-import GHC.Utils.Outputable (SDoc)
-
-import GHC.Cmm.BlockId
-
-import GHC.CmmToAsm.Config
-import GHC.Data.FastString
-
--- | Holds a list of source and destination registers used by a
---      particular instruction.
---
---   Machine registers that are pre-allocated to stgRegs are filtered
---      out, because they are uninteresting from a register allocation
---      standpoint.  (We wouldn't want them to end up on the free list!)
---
---   As far as we are concerned, the fixed registers simply don't exist
---      (for allocation purposes, anyway).
---
-data RegUsage
-        = RU    {
-                reads :: [Reg],
-                writes :: [Reg]
-                }
-        deriving Show
-
--- | No regs read or written to.
-noUsage :: RegUsage
-noUsage  = RU [] []
-
--- | Common things that we can do with instructions, on all architectures.
---      These are used by the shared parts of the native code generator,
---      specifically the register allocators.
---
-class Instruction instr where
-
-        -- | Get the registers that are being used by this instruction.
-        --      regUsage doesn't need to do any trickery for jumps and such.
-        --      Just state precisely the regs read and written by that insn.
-        --      The consequences of control flow transfers, as far as register
-        --      allocation goes, are taken care of by the register allocator.
-        --
-        regUsageOfInstr
-                :: Platform
-                -> instr
-                -> RegUsage
-
-
-        -- | Apply a given mapping to all the register references in this
-        --      instruction.
-        patchRegsOfInstr
-                :: instr
-                -> (Reg -> Reg)
-                -> instr
-
-
-        -- | Checks whether this instruction is a jump/branch instruction.
-        --      One that can change the flow of control in a way that the
-        --      register allocator needs to worry about.
-        isJumpishInstr
-                :: instr -> Bool
-
-
-        -- | Give the possible destinations of this jump instruction.
-        --      Must be defined for all jumpish instructions.
-        jumpDestsOfInstr
-                :: instr -> [BlockId]
-
-
-        -- | Change the destination of this jump instruction.
-        --      Used in the linear allocator when adding fixup blocks for join
-        --      points.
-        patchJumpInstr
-                :: instr
-                -> (BlockId -> BlockId)
-                -> instr
-
-
-        -- | An instruction to spill a register into a spill slot.
-        mkSpillInstr
-                :: NCGConfig
-                -> Reg          -- ^ the reg to spill
-                -> Int          -- ^ the current stack delta
-                -> Int          -- ^ spill slot to use
-                -> [instr]        -- ^ instructions
-
-
-        -- | An instruction to reload a register from a spill slot.
-        mkLoadInstr
-                :: NCGConfig
-                -> Reg          -- ^ the reg to reload.
-                -> Int          -- ^ the current stack delta
-                -> Int          -- ^ the spill slot to use
-                -> [instr]        -- ^ instructions
-
-        -- | See if this instruction is telling us the current C stack delta
-        takeDeltaInstr
-                :: instr
-                -> Maybe Int
-
-        -- | Check whether this instruction is some meta thing inserted into
-        --      the instruction stream for other purposes.
-        --
-        --      Not something that has to be treated as a real machine instruction
-        --      and have its registers allocated.
-        --
-        --      eg, comments, delta, ldata, etc.
-        isMetaInstr
-                :: instr
-                -> Bool
-
-
-
-        -- | Copy the value in a register to another one.
-        --      Must work for all register classes.
-        mkRegRegMoveInstr
-                :: Platform
-                -> Reg          -- ^ source register
-                -> Reg          -- ^ destination register
-                -> instr
-
-        -- | Take the source and destination from this reg -> reg move instruction
-        --      or Nothing if it's not one
-        takeRegRegMoveInstr
-                :: instr
-                -> Maybe (Reg, Reg)
-
-        -- | Make an unconditional jump instruction.
-        --      For architectures with branch delay slots, its ok to put
-        --      a NOP after the jump. Don't fill the delay slot with an
-        --      instruction that references regs or you'll confuse the
-        --      linear allocator.
-        mkJumpInstr
-                :: BlockId
-                -> [instr]
-
-
-        -- Subtract an amount from the C stack pointer
-        mkStackAllocInstr
-                :: Platform
-                -> Int
-                -> [instr]
-
-        -- Add an amount to the C stack pointer
-        mkStackDeallocInstr
-                :: Platform
-                -> Int
-                -> [instr]
-
-        -- | Pretty-print an instruction
-        pprInstr :: Platform -> instr -> SDoc
-
-        -- Create a comment instruction
-        mkComment :: FastString -> [instr]
diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Monad.hs
+++ /dev/null
@@ -1,335 +0,0 @@
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ViewPatterns #-}
-
--- -----------------------------------------------------------------------------
---
--- (c) The University of Glasgow 1993-2004
---
--- The native code generator's monad.
---
--- -----------------------------------------------------------------------------
-
-module GHC.CmmToAsm.Monad (
-        NcgImpl(..),
-        NatM_State(..), mkNatM_State,
-
-        NatM, -- instance Monad
-        initNat,
-        addImportNat,
-        addNodeBetweenNat,
-        addImmediateSuccessorNat,
-        updateCfgNat,
-        getUniqueNat,
-        setDeltaNat,
-        getConfig,
-        getPlatform,
-        getDeltaNat,
-        getThisModuleNat,
-        getBlockIdNat,
-        getNewLabelNat,
-        getNewRegNat,
-        getPicBaseMaybeNat,
-        getPicBaseNat,
-        getCfgWeights,
-        getFileId,
-        getDebugBlock,
-
-        DwarfFiles,
-
-        -- * 64-bit registers on 32-bit architectures
-        Reg64(..), RegCode64(..),
-        getNewReg64, localReg64
-)
-
-where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Platform.Reg
-import GHC.CmmToAsm.Format
-import GHC.CmmToAsm.Reg.Target
-import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Types
-
-import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.CLabel           ( CLabel )
-import GHC.Cmm.DebugBlock
-import GHC.Cmm.Expr             (LocalReg (..), isWord64)
-
-import GHC.Data.FastString      ( FastString )
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Supply
-import GHC.Types.Unique         ( Unique )
-import GHC.Unit.Module
-
-import GHC.Utils.Outputable (SDoc, HDoc, ppr)
-import GHC.Utils.Panic      (pprPanic)
-import GHC.Utils.Monad.State.Strict (State (..), runState, state)
-import GHC.Utils.Misc
-import GHC.CmmToAsm.CFG
-import GHC.CmmToAsm.CFG.Weight
-
-data NcgImpl statics instr jumpDest = NcgImpl {
-    ncgConfig                 :: !NCGConfig,
-    cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
-    generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
-    getJumpDestBlockId        :: jumpDest -> Maybe BlockId,
-    canShortcut               :: instr -> Maybe jumpDest,
-    shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,
-    shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,
-    -- | 'Module' is only for printing internal labels. See Note [Internal proc
-    -- labels] in CLabel.
-    pprNatCmmDeclS            :: NatCmmDecl statics instr -> SDoc,
-    pprNatCmmDeclH            :: NatCmmDecl statics instr -> HDoc,
-        -- see Note [pprNatCmmDeclS and pprNatCmmDeclH]
-    maxSpillSlots             :: Int,
-    allocatableRegs           :: [RealReg],
-    ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr
-                              -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),
-    -- ^ The list of block ids records the redirected jumps to allow us to update
-    -- the CFG.
-    ncgMakeFarBranches        :: LabelMap RawCmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr],
-    extractUnwindPoints       :: [instr] -> [UnwindPoint],
-    -- ^ given the instruction sequence of a block, produce a list of
-    -- the block's 'UnwindPoint's
-    -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"
-    -- and Note [Unwinding information in the NCG] in this module.
-    invertCondBranches        :: Maybe CFG -> LabelMap RawCmmStatics -> [NatBasicBlock instr]
-                              -> [NatBasicBlock instr]
-    -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \<block_l1>@
-    -- when possible.
-    }
-
-{- Note [pprNatCmmDeclS and pprNatCmmDeclH]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Each NcgImpl provides two implementations of its CmmDecl printer, pprNatCmmDeclS
-and pprNatCmmDeclH, which are specialized to SDoc and HDoc, respectively
-(see Note [SDoc versus HDoc] in GHC.Utils.Outputable). These are both internally
-implemented as a single, polymorphic function, but they need to be stored using
-monomorphic types to ensure the specialized versions are used, which is
-essential for performance (see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable).
-
-One might wonder why we bother with pprNatCmmDeclS and SDoc at all, since we
-have a perfectly serviceable HDoc-based implementation that is more efficient.
-However, it turns out we benefit from keeping both, for two (related) reasons:
-
-  1. Although we absolutely want to take care to use pprNatCmmDeclH for actual
-     code generation (the improved performance there is why we have HDoc at
-     all!), we also sometimes print assembly for debug dumps, when requested via
-     -ddump-asm. In this case, it’s more convenient to produce an SDoc, which
-     can be concatenated with other SDocs for consistency with the general-
-     purpose dump file infrastructure.
-
-  2. Some debug information is sometimes useful to include in -ddump-asm that is
-     neither necessary nor useful in normal code generation, and it turns out to
-     be tricky to format neatly using the one-line-at-a-time model of HLine/HDoc.
-
-Therefore, we provide both pprNatCmmDeclS and pprNatCmmDeclH, and we sometimes
-include additional information in the SDoc variant using dualDoc
-(see Note [dualLine and dualDoc] in GHC.Utils.Outputable). However, it is
-absolutely *critical* that pprNatCmmDeclS is not actually used unless -ddump-asm
-is provided, as that would rather defeat the whole point. (Fortunately, the
-difference in allocations between the two implementations is so vast that such a
-mistake would readily show up in performance tests). -}
-
-data NatM_State
-        = NatM_State {
-                natm_us          :: UniqSupply,
-                natm_delta       :: Int,
-                natm_imports     :: [(CLabel)],
-                natm_pic         :: Maybe Reg,
-                natm_config      :: NCGConfig,
-                natm_fileid      :: DwarfFiles,
-                natm_debug_map   :: LabelMap DebugBlock,
-                natm_cfg         :: CFG
-        -- ^ Having a CFG with additional information is essential for some
-        -- operations. However we can't reconstruct all information once we
-        -- generated instructions. So instead we update the CFG as we go.
-        }
-
-type DwarfFiles = UniqFM FastString (FastString, Int)
-
-newtype NatM a = NatM' (State NatM_State a)
-  deriving stock (Functor)
-  deriving (Applicative, Monad) via State NatM_State
-
-pattern NatM :: (NatM_State -> (a, NatM_State)) -> NatM a
-pattern NatM f <- NatM' (runState -> f)
-  where NatM f  = NatM' (state f)
-{-# COMPLETE NatM #-}
-
-unNat :: NatM a -> NatM_State -> (a, NatM_State)
-unNat (NatM a) = a
-
-mkNatM_State :: UniqSupply -> Int -> NCGConfig ->
-                DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State
-mkNatM_State us delta config
-        = \dwf dbg cfg ->
-                NatM_State
-                        { natm_us = us
-                        , natm_delta = delta
-                        , natm_imports = []
-                        , natm_pic = Nothing
-                        , natm_config = config
-                        , natm_fileid = dwf
-                        , natm_debug_map = dbg
-                        , natm_cfg = cfg
-                        }
-
-initNat :: NatM_State -> NatM a -> (a, NatM_State)
-initNat = flip unNat
-
-instance MonadUnique NatM where
-  getUniqueSupplyM = NatM $ \st ->
-      case splitUniqSupply (natm_us st) of
-          (us1, us2) -> (us1, st {natm_us = us2})
-
-  getUniqueM = NatM $ \st ->
-      case takeUniqFromSupply (natm_us st) of
-          (uniq, us') -> (uniq, st {natm_us = us'})
-
-getUniqueNat :: NatM Unique
-getUniqueNat = NatM $ \ st ->
-    case takeUniqFromSupply $ natm_us st of
-    (uniq, us') -> (uniq, st {natm_us = us'})
-
-getDeltaNat :: NatM Int
-getDeltaNat = NatM $ \ st -> (natm_delta st, st)
-
--- | Get CFG edge weights
-getCfgWeights :: NatM Weights
-getCfgWeights = NatM $ \ st -> (ncgCfgWeights (natm_config st), st)
-
-setDeltaNat :: Int -> NatM ()
-setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta})
-
-getThisModuleNat :: NatM Module
-getThisModuleNat = NatM $ \ st -> (ncgThisModule $ natm_config st, st)
-
-instance HasModule NatM where
-  getModule = getThisModuleNat
-
-addImportNat :: CLabel -> NatM ()
-addImportNat imp
-        = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st})
-
-updateCfgNat :: (CFG -> CFG) -> NatM ()
-updateCfgNat f
-        = NatM $ \ st -> let !cfg' = f (natm_cfg st)
-                         in ((), st { natm_cfg = cfg'})
-
--- | Record that we added a block between `from` and `old`.
-addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
-addNodeBetweenNat from between to
- = do   weights <- getCfgWeights
-        let jmpWeight = fromIntegral (uncondWeight weights)
-        updateCfgNat (updateCfg jmpWeight from between to)
-  where
-    -- When transforming A -> B to A -> A' -> B
-    -- A -> A' keeps the old edge info while
-    -- A' -> B gets the info for an unconditional
-    -- jump.
-    updateCfg weight from between old m
-        | Just info <- getEdgeInfo from old m
-        = addEdge from between info .
-          addWeightEdge between old weight .
-          delEdge from old $ m
-        | otherwise
-        = pprPanic "Failed to update cfg: Untracked edge" (ppr (from,to))
-
-
--- | Place `succ` after `block` and change any edges
---   block -> X to `succ` -> X
-addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()
-addImmediateSuccessorNat block succ = do
-   weights <- getCfgWeights
-   updateCfgNat (addImmediateSuccessor weights block succ)
-
-getBlockIdNat :: NatM BlockId
-getBlockIdNat
- = mkBlockId <$> getUniqueNat
-
-getNewLabelNat :: NatM CLabel
-getNewLabelNat
- = blockLbl <$> getBlockIdNat
-
-
-getNewRegNat :: Format -> NatM Reg
-getNewRegNat rep
- = do u <- getUniqueNat
-      platform <- getPlatform
-      return (RegVirtual $ targetMkVirtualReg platform u rep)
-
-
--- | Two 32-bit regs used as a single virtual 64-bit register
-data Reg64 = Reg64
-  !Reg -- ^ Higher part
-  !Reg -- ^ Lower part
-
--- | Two 32-bit regs used as a single virtual 64-bit register
--- and the code to set them appropriately
-data RegCode64 code = RegCode64
-  code -- ^ Code to initialize the registers
-  !Reg -- ^ Higher part
-  !Reg -- ^ Lower part
-
--- | Return a virtual 64-bit register
-getNewReg64 :: NatM Reg64
-getNewReg64 = do
-  let rep = II32
-  u <- getUniqueNat
-  platform <- getPlatform
-  let vLo = targetMkVirtualReg platform u rep
-  let lo  = RegVirtual $ targetMkVirtualReg platform u rep
-  let hi  = RegVirtual $ getHiVirtualRegFromLo vLo
-  return $ Reg64 hi lo
-
--- | Convert a 64-bit LocalReg into two virtual 32-bit regs.
---
--- Used to handle 64-bit "registers" on 32-bit architectures
-localReg64 :: HasDebugCallStack => LocalReg -> Reg64
-localReg64 (LocalReg vu ty)
-  | isWord64 ty = let lo = RegVirtual (VirtualRegI vu)
-                      hi = getHiVRegFromLo lo
-                  in Reg64 hi lo
-  | otherwise   = pprPanic "localReg64" (ppr ty)
-
-
-getPicBaseMaybeNat :: NatM (Maybe Reg)
-getPicBaseMaybeNat
-        = NatM (\state -> (natm_pic state, state))
-
-
-getPicBaseNat :: Format -> NatM Reg
-getPicBaseNat rep
- = do   mbPicBase <- getPicBaseMaybeNat
-        case mbPicBase of
-                Just picBase -> return picBase
-                Nothing
-                 -> do
-                        reg <- getNewRegNat rep
-                        NatM (\state -> (reg, state { natm_pic = Just reg }))
-
--- | Get native code generator configuration
-getConfig :: NatM NCGConfig
-getConfig = NatM $ \st -> (natm_config st, st)
-
--- | Get target platform from native code generator configuration
-getPlatform :: NatM Platform
-getPlatform = ncgPlatform <$> getConfig
-
-getFileId :: FastString -> NatM Int
-getFileId f = NatM $ \st ->
-  case lookupUFM (natm_fileid st) f of
-    Just (_,n) -> (n, st)
-    Nothing    -> let n = 1 + sizeUFM (natm_fileid st)
-                      fids = addToUFM (natm_fileid st) f (f,n)
-                  in n `seq` fids `seq` (n, st { natm_fileid = fids  })
-
-getDebugBlock :: Label -> NatM (Maybe DebugBlock)
-getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st)
diff --git a/compiler/GHC/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/PIC.hs
+++ /dev/null
@@ -1,873 +0,0 @@
-{-
-  This module handles generation of position independent code and
-  dynamic-linking related issues for the native code generator.
-
-  This depends on both the architecture and OS, so we define it here
-  instead of in one of the architecture specific modules.
-
-  Things outside this module which are related to this:
-
-  + module CLabel
-    - PIC base label (pretty printed as local label 1)
-    - DynamicLinkerLabels - several kinds:
-        CodeStub, SymbolPtr, GotSymbolPtr, GotSymbolOffset
-    - labelDynamic predicate
-  + module Cmm
-    - The GlobalReg datatype has a PicBaseReg constructor
-    - The CmmLit datatype has a CmmLabelDiffOff constructor
-  + codeGen & RTS
-    - When tablesNextToCode, no absolute addresses are stored in info tables
-      any more. Instead, offsets from the info label are used.
-    - For Win32 only, SRTs might contain addresses of __imp_ symbol pointers
-      because Win32 doesn't support external references in data sections.
-      TODO: make sure this still works, it might be bitrotted
-  + NCG
-    - The cmmToCmm pass in AsmCodeGen calls cmmMakeDynamicReference for all
-      labels.
-    - nativeCodeGen calls pprImportedSymbol and pprGotDeclaration to output
-      all the necessary stuff for imported symbols.
-    - The NCG monad keeps track of a list of imported symbols.
-    - MachCodeGen invokes initializePicBase to generate code to initialize
-      the PIC base register when needed.
-    - MachCodeGen calls cmmMakeDynamicReference whenever it uses a CLabel
-      that wasn't in the original Cmm code (e.g. floating point literals).
--}
-
-module GHC.CmmToAsm.PIC (
-        cmmMakeDynamicReference,
-        CmmMakeDynamicReferenceM(..),
-        ReferenceKind(..),
-        needImportedSymbols,
-        pprImportedSymbol,
-        pprGotDeclaration,
-
-        initializePicBase_ppc,
-        initializePicBase_x86
-)
-
-where
-
-import GHC.Prelude
-
-import qualified GHC.CmmToAsm.PPC.Instr as PPC
-import qualified GHC.CmmToAsm.PPC.Regs  as PPC
-import qualified GHC.CmmToAsm.X86.Instr as X86
-
-import GHC.Platform
-import GHC.Platform.Reg
-import GHC.CmmToAsm.Monad
-import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Types
-
-
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm
-import GHC.Cmm.CLabel
-import GHC.Cmm.Utils (cmmLoadBWord)
-
-import GHC.Types.Basic
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import GHC.Data.FastString
-
-
-
---------------------------------------------------------------------------------
--- It gets called by the cmmToCmm pass for every CmmLabel in the Cmm
--- code. It does The Right Thing(tm) to convert the CmmLabel into a
--- position-independent, dynamic-linking-aware reference to the thing
--- in question.
--- Note that this also has to be called from MachCodeGen in order to
--- access static data like floating point literals (labels that were
--- created after the cmmToCmm pass).
--- The function must run in a monad that can keep track of imported symbols
--- A function for recording an imported symbol must be passed in:
--- - addImportCmmOpt for the CmmOptM monad
--- - addImportNat for the NatM monad.
-
-data ReferenceKind
-        = DataReference
-        | CallReference
-        | JumpReference
-        deriving(Eq)
-
-class Monad m => CmmMakeDynamicReferenceM m where
-    addImport :: CLabel -> m ()
-
-instance CmmMakeDynamicReferenceM NatM where
-    addImport = addImportNat
-
-cmmMakeDynamicReference
-  :: CmmMakeDynamicReferenceM m
-  => NCGConfig
-  -> ReferenceKind     -- whether this is the target of a jump
-  -> CLabel            -- the label
-  -> m CmmExpr
-
-cmmMakeDynamicReference config referenceKind lbl
-  | Just _ <- dynamicLinkerLabelInfo lbl
-  = return $ CmmLit $ CmmLabel lbl   -- already processed it, pass through
-
-  | otherwise
-  = do let platform = ncgPlatform config
-       case howToAccessLabel
-                config
-                (platformArch platform)
-                (platformOS   platform)
-                referenceKind lbl of
-
-        AccessViaStub -> do
-              let stub = mkDynamicLinkerLabel CodeStub lbl
-              addImport stub
-              return $ CmmLit $ CmmLabel stub
-
-        -- GOT relative loads work differently on AArch64.  We don't do two
-        -- step loads. The got symbol is loaded directly, and not through an
-        -- additional load. Thus we do not need the CmmLoad decoration we have
-        -- on other platforms.
-        AccessViaSymbolPtr | ArchAArch64 <- platformArch platform -> do
-              let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl
-              addImport symbolPtr
-              return $ cmmMakePicReference config symbolPtr
-
-        AccessViaSymbolPtr -> do
-              let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl
-              addImport symbolPtr
-              return $ cmmLoadBWord platform (cmmMakePicReference config symbolPtr)
-
-        AccessDirectly -> case referenceKind of
-                -- for data, we might have to make some calculations:
-              DataReference -> return $ cmmMakePicReference config lbl
-                -- all currently supported processors support
-                -- PC-relative branch and call instructions,
-                -- so just jump there if it's a call or a jump
-              _ -> return $ CmmLit $ CmmLabel lbl
-
--- -----------------------------------------------------------------------------
--- Create a position independent reference to a label.
--- (but do not bother with dynamic linking).
--- We calculate the label's address by adding some (platform-dependent)
--- offset to our base register; this offset is calculated by
--- the function picRelative in the platform-dependent part below.
-
-cmmMakePicReference :: NCGConfig -> CLabel -> CmmExpr
-cmmMakePicReference config lbl
-  -- Windows doesn't need PIC,
-  -- everything gets relocated at runtime
-  | OSMinGW32 <- platformOS platform
-  = CmmLit $ CmmLabel lbl
-
-  -- no pic base reg on AArch64, however indicate this symbol should go through
-  -- the global offset table (GOT).
-  | ArchAArch64 <- platformArch platform
-  = CmmLit $ CmmLabel lbl
-
-  | OSAIX <- platformOS platform
-  = CmmMachOp (MO_Add W32)
-          [ CmmReg (CmmGlobal PicBaseReg)
-          , CmmLit $ picRelative (wordWidth platform)
-                          (platformArch platform)
-                          (platformOS   platform)
-                          lbl ]
-
-  -- both ABI versions default to medium code model
-  | ArchPPC_64 _ <- platformArch platform
-  = CmmMachOp (MO_Add W32) -- code model medium
-          [ CmmReg (CmmGlobal PicBaseReg)
-          , CmmLit $ picRelative (wordWidth platform)
-                          (platformArch platform)
-                          (platformOS   platform)
-                          lbl ]
-
-  | (ncgPIC config || ncgExternalDynamicRefs config)
-      && absoluteLabel lbl
-  = CmmMachOp (MO_Add (wordWidth platform))
-          [ CmmReg (CmmGlobal PicBaseReg)
-          , CmmLit $ picRelative (wordWidth platform)
-                          (platformArch platform)
-                          (platformOS   platform)
-                          lbl ]
-
-  | otherwise
-  = CmmLit $ CmmLabel lbl
-  where
-    platform = ncgPlatform config
-
-
-
-absoluteLabel :: CLabel -> Bool
-absoluteLabel lbl
- = case dynamicLinkerLabelInfo lbl of
-        Just (GotSymbolPtr, _)    -> False
-        Just (GotSymbolOffset, _) -> False
-        _                         -> True
-
-
---------------------------------------------------------------------------------
--- Knowledge about how special dynamic linker labels like symbol
--- pointers, code stubs and GOT offsets look like is located in the
--- module CLabel.
-
--- | Helper to check whether the data resides in a DLL or not, see @labelDynamic@
-ncgLabelDynamic :: NCGConfig -> CLabel -> Bool
-ncgLabelDynamic config = labelDynamic (ncgThisModule config)
-                                      (ncgPlatform config)
-                                      (ncgExternalDynamicRefs config)
-
-
--- We have to decide which labels need to be accessed
--- indirectly or via a piece of stub code.
-data LabelAccessStyle
-        = AccessViaStub
-        | AccessViaSymbolPtr
-        | AccessDirectly
-
-howToAccessLabel :: NCGConfig -> Arch -> OS -> ReferenceKind -> CLabel -> LabelAccessStyle
-
--- Windows
--- In Windows speak, a "module" is a set of objects linked into the
--- same Portable Executable (PE) file. (both .exe and .dll files are PEs).
---
--- If we're compiling a multi-module program then symbols from other modules
--- are accessed by a symbol pointer named __imp_SYMBOL. At runtime we have the
--- following.
---
---   (in the local module)
---     __imp_SYMBOL: addr of SYMBOL
---
---   (in the other module)
---     SYMBOL: the real function / data.
---
--- To access the function at SYMBOL from our local module, we just need to
--- dereference the local __imp_SYMBOL.
---
--- If not compiling with -dynamic we assume that all our code will be linked
--- into the same .exe file. In this case we always access symbols directly,
--- and never use __imp_SYMBOL.
---
-howToAccessLabel config _arch OSMinGW32 _kind lbl
-
-        -- Assume all symbols will be in the same PE, so just access them directly.
-        | not (ncgExternalDynamicRefs config)
-        = AccessDirectly
-
-        -- If the target symbol is in another PE we need to access it via the
-        --      appropriate __imp_SYMBOL pointer.
-        | ncgLabelDynamic config lbl
-        = AccessViaSymbolPtr
-
-        -- Target symbol is in the same PE as the caller, so just access it directly.
-        | otherwise
-        = AccessDirectly
-
--- On AArch64, relocations for JUMP and CALL will be emitted with 26bits, this
--- is enough for ~64MB of range. Anything else will need to go through a veneer,
--- which is the job of the linker to build.  We might only want to lookup
--- Data References through the GOT.
-howToAccessLabel config ArchAArch64 _os _kind lbl
-        | not (ncgExternalDynamicRefs config)
-        = AccessDirectly
-
-        | ncgLabelDynamic config lbl
-        = AccessViaSymbolPtr
-
-        | otherwise
-        = AccessDirectly
-
-
--- Mach-O (Darwin, Mac OS X)
---
--- Indirect access is required in the following cases:
---  * things imported from a dynamic library
---  * (not on x86_64) data from a different module, if we're generating PIC code
--- It is always possible to access something indirectly,
--- even when it's not necessary.
---
-howToAccessLabel config arch OSDarwin DataReference lbl
-        -- data access to a dynamic library goes via a symbol pointer
-        | ncgLabelDynamic config lbl
-        = AccessViaSymbolPtr
-
-        -- when generating PIC code, all cross-module data references must
-        -- must go via a symbol pointer, too, because the assembler
-        -- cannot generate code for a label difference where one
-        -- label is undefined. Doesn't apply to x86_64 (why?).
-        | arch /= ArchX86_64
-        , not (isLocalCLabel (ncgThisModule config) lbl)
-        , ncgPIC config
-        , externallyVisibleCLabel lbl
-        = AccessViaSymbolPtr
-
-        | otherwise
-        = AccessDirectly
-
-howToAccessLabel config arch OSDarwin JumpReference lbl
-        -- dyld code stubs don't work for tailcalls because the
-        -- stack alignment is only right for regular calls.
-        -- Therefore, we have to go via a symbol pointer:
-        | arch == ArchX86 || arch == ArchX86_64 || arch == ArchAArch64
-        , ncgLabelDynamic config lbl
-        = AccessViaSymbolPtr
-
-
-howToAccessLabel config arch OSDarwin _kind lbl
-        -- Code stubs are the usual method of choice for imported code;
-        -- not needed on x86_64 because Apple's new linker, ld64, generates
-        -- them automatically, neither on Aarch64 (arm64).
-        | arch /= ArchX86_64
-        , arch /= ArchAArch64
-        , ncgLabelDynamic config lbl
-        = AccessViaStub
-
-        | otherwise
-        = AccessDirectly
-
-----------------------------------------------------------------------------
--- AIX
-
--- quite simple (for now)
-howToAccessLabel _config _arch OSAIX kind _lbl
-        = case kind of
-            DataReference -> AccessViaSymbolPtr
-            CallReference -> AccessDirectly
-            JumpReference -> AccessDirectly
-
--- ELF (Linux)
---
--- ELF tries to pretend to the main application code that dynamic linking does
--- not exist. While this may sound convenient, it tends to mess things up in
--- very bad ways, so we have to be careful when we generate code for a non-PIE
--- main program (-dynamic but no -fPIC).
---
--- Indirect access is required for references to imported symbols
--- from position independent code. It is also required from the main program
--- when dynamic libraries containing Haskell code are used.
-
-howToAccessLabel _config (ArchPPC_64 _) os kind _lbl
-        | osElfTarget os
-        = case kind of
-          -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC
-          DataReference -> AccessViaSymbolPtr
-          -- RTLD does not generate stubs for function descriptors
-          -- in tail calls. Create a symbol pointer and generate
-          -- the code to load the function descriptor at the call site.
-          JumpReference -> AccessViaSymbolPtr
-          -- regular calls are handled by the runtime linker
-          _             -> AccessDirectly
-
-howToAccessLabel config _arch os _kind _lbl
-        -- no PIC -> the dynamic linker does everything for us;
-        --           if we don't dynamically link to Haskell code,
-        --           it actually manages to do so without messing things up.
-        | osElfTarget os
-        , not (ncgPIC config) &&
-          not (ncgExternalDynamicRefs config)
-        = AccessDirectly
-
-howToAccessLabel config arch os DataReference lbl
-        | osElfTarget os
-        = case () of
-            -- A dynamic label needs to be accessed via a symbol pointer.
-          _ | ncgLabelDynamic config lbl
-            -> AccessViaSymbolPtr
-
-            -- For PowerPC32 -fPIC, we have to access even static data
-            -- via a symbol pointer (see below for an explanation why
-            -- PowerPC32 Linux is especially broken).
-            | arch == ArchPPC
-            , ncgPIC config
-            -> AccessViaSymbolPtr
-
-            | otherwise
-            -> AccessDirectly
-
-
-        -- In most cases, we have to avoid symbol stubs on ELF, for the following reasons:
-        --   on i386, the position-independent symbol stubs in the Procedure Linkage Table
-        --   require the address of the GOT to be loaded into register %ebx on entry.
-        --   The linker will take any reference to the symbol stub as a hint that
-        --   the label in question is a code label. When linking executables, this
-        --   will cause the linker to replace even data references to the label with
-        --   references to the symbol stub.
-
-        -- This leaves calling a (foreign) function from non-PIC code
-        -- (AccessDirectly, because we get an implicit symbol stub)
-        -- and calling functions from PIC code on non-i386 platforms (via a symbol stub)
-
-howToAccessLabel config arch os CallReference lbl
-        | osElfTarget os
-        , ncgLabelDynamic config lbl
-        , not (ncgPIC config)
-        = AccessDirectly
-
-        | osElfTarget os
-        , arch /= ArchX86
-        , ncgLabelDynamic config lbl
-        , ncgPIC config
-        = AccessViaStub
-
-howToAccessLabel config _arch os _kind lbl
-        | osElfTarget os
-        = if ncgLabelDynamic config lbl
-            then AccessViaSymbolPtr
-            else AccessDirectly
-
--- all other platforms
-howToAccessLabel config _arch _os _kind _lbl
-        | not (ncgPIC config)
-        = AccessDirectly
-
-        | otherwise
-        = panic "howToAccessLabel: PIC not defined for this platform"
-
-
-
--- -------------------------------------------------------------------
--- | Says what we have to add to our 'PIC base register' in order to
---      get the address of a label.
-
-picRelative :: Width -> Arch -> OS -> CLabel -> CmmLit
-
--- Darwin, but not x86_64:
--- The PIC base register points to the PIC base label at the beginning
--- of the current CmmDecl. We just have to use a label difference to
--- get the offset.
--- We have already made sure that all labels that are not from the current
--- module are accessed indirectly ('as' can't calculate differences between
--- undefined labels).
-picRelative width arch OSDarwin lbl
-        | arch /= ArchX86_64
-        = CmmLabelDiffOff lbl mkPicBaseLabel 0 width
-
--- On AIX we use an indirect local TOC anchored by 'gotLabel'.
--- This way we use up only one global TOC entry per compilation-unit
--- (this is quite similar to GCC's @-mminimal-toc@ compilation mode)
-picRelative width _ OSAIX lbl
-        = CmmLabelDiffOff lbl gotLabel 0 width
-
--- PowerPC Linux:
--- The PIC base register points to our fake GOT. Use a label difference
--- to get the offset.
--- We have made sure that *everything* is accessed indirectly, so this
--- is only used for offsets from the GOT to symbol pointers inside the
--- GOT.
-picRelative width ArchPPC os lbl
-        | osElfTarget os
-        = CmmLabelDiffOff lbl gotLabel 0 width
-
-
--- Most Linux versions:
--- The PIC base register points to the GOT. Use foo@got for symbol
--- pointers, and foo@gotoff for everything else.
--- Linux and Darwin on x86_64:
--- The PIC base register is %rip, we use foo@gotpcrel for symbol pointers,
--- and a GotSymbolOffset label for other things.
--- For reasons of tradition, the symbol offset label is written as a plain label.
-picRelative _ arch os lbl
-        | osElfTarget os || (os == OSDarwin && arch == ArchX86_64)
-        = let   result
-                        | Just (SymbolPtr, lbl') <- dynamicLinkerLabelInfo lbl
-                        = CmmLabel $ mkDynamicLinkerLabel GotSymbolPtr lbl'
-
-                        | otherwise
-                        = CmmLabel $ mkDynamicLinkerLabel GotSymbolOffset lbl
-
-          in    result
-
-picRelative _ _ _ _
-        = panic "GHC.CmmToAsm.PIC.picRelative undefined for this platform"
-
-
-
---------------------------------------------------------------------------------
-
-needImportedSymbols :: NCGConfig -> Bool
-needImportedSymbols config
-        | os    == OSDarwin
-        , arch  /= ArchX86_64
-        = True
-
-        | os    == OSAIX
-        = True
-
-        -- PowerPC Linux: -fPIC or -dynamic
-        | osElfTarget os
-        , arch  == ArchPPC
-        = ncgPIC config || ncgExternalDynamicRefs config
-
-        -- PowerPC 64 Linux: always
-        | osElfTarget os
-        , arch == ArchPPC_64 ELF_V1 || arch == ArchPPC_64 ELF_V2
-        = True
-
-        -- i386 (and others?): -dynamic but not -fPIC
-        | osElfTarget os
-        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
-        = ncgExternalDynamicRefs config &&
-          not (ncgPIC config)
-
-        | otherwise
-        = False
-   where
-      platform = ncgPlatform config
-      arch     = platformArch platform
-      os       = platformOS   platform
-
--- gotLabel
--- The label used to refer to our "fake GOT" from
--- position-independent code.
-gotLabel :: CLabel
-gotLabel
-        -- HACK: this label isn't really foreign
-        = mkForeignLabel
-                (fsLit ".LCTOC1")
-                Nothing ForeignLabelInThisPackage IsData
-
-
-
--- Emit GOT declaration
--- Output whatever needs to be output once per .s file.
---
--- We don't need to declare any offset tables.
--- However, for PIC on x86, we need a small helper function.
-pprGotDeclaration :: NCGConfig -> HDoc
-pprGotDeclaration config = case (arch,os) of
-   (ArchX86, OSDarwin)
-        | ncgPIC config
-        -> lines_ [
-                text ".section __TEXT,__textcoal_nt,coalesced,no_toc",
-                text ".weak_definition ___i686.get_pc_thunk.ax",
-                text ".private_extern ___i686.get_pc_thunk.ax",
-                text "___i686.get_pc_thunk.ax:",
-                text "\tmovl (%esp), %eax",
-                text "\tret" ]
-
-   (_, OSDarwin) -> empty
-
-   -- Emit XCOFF TOC section
-   (_, OSAIX)
-        -> lines_ [ text ".toc"
-                  , text ".tc ghc_toc_table[TC],.LCTOC1"
-                  , text ".csect ghc_toc_table[RW]"
-                    -- See Note [.LCTOC1 in PPC PIC code]
-                  , text ".set .LCTOC1,$+0x8000"
-                  ]
-
-
-   -- PPC 64 ELF v1 needs a Table Of Contents (TOC)
-   (ArchPPC_64 ELF_V1, _)
-        -> line $ text ".section \".toc\",\"aw\""
-
-   -- In ELF v2 we also need to tell the assembler that we want ABI
-   -- version 2. This would normally be done at the top of the file
-   -- right after a file directive, but I could not figure out how
-   -- to do that.
-   (ArchPPC_64 ELF_V2, _)
-        -> lines_ [ text ".abiversion 2",
-                    text ".section \".toc\",\"aw\""
-                  ]
-
-   (arch, os)
-        | osElfTarget os
-        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
-        , not (ncgPIC config)
-        -> empty
-
-        | osElfTarget os
-        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
-        -> lines_ [
-                -- See Note [.LCTOC1 in PPC PIC code]
-                text ".section \".got2\",\"aw\"",
-                text ".LCTOC1 = .+32768" ]
-
-   _ -> panic "pprGotDeclaration: no match"
- where
-   platform = ncgPlatform config
-   arch     = platformArch platform
-   os       = platformOS   platform
-
-
---------------------------------------------------------------------------------
--- On Darwin, we have to generate our own stub code for lazy binding..
--- For each processor architecture, there are two versions, one for PIC
--- and one for non-PIC.
---
-
-pprImportedSymbol :: NCGConfig -> CLabel -> HDoc
-pprImportedSymbol config importedLbl = case (arch,os) of
-   (ArchX86, OSDarwin)
-        | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
-        -> if not pic
-             then
-              lines_ [
-                  text ".symbol_stub",
-                  text "L" <> ppr_lbl lbl <> text "$stub:",
-                      text "\t.indirect_symbol" <+> ppr_lbl lbl,
-                      text "\tjmp *L" <> ppr_lbl lbl
-                          <> text "$lazy_ptr",
-                  text "L" <> ppr_lbl lbl
-                      <> text "$stub_binder:",
-                      text "\tpushl $L" <> ppr_lbl lbl
-                          <> text "$lazy_ptr",
-                      text "\tjmp dyld_stub_binding_helper"
-              ]
-             else
-              lines_ [
-                  text ".section __TEXT,__picsymbolstub2,"
-                      <> text "symbol_stubs,pure_instructions,25",
-                  text "L" <> ppr_lbl lbl <> text "$stub:",
-                      text "\t.indirect_symbol" <+> ppr_lbl lbl,
-                      text "\tcall ___i686.get_pc_thunk.ax",
-                  text "1:",
-                      text "\tmovl L" <> ppr_lbl lbl
-                          <> text "$lazy_ptr-1b(%eax),%edx",
-                      text "\tjmp *%edx",
-                  text "L" <> ppr_lbl lbl
-                      <> text "$stub_binder:",
-                      text "\tlea L" <> ppr_lbl lbl
-                          <> text "$lazy_ptr-1b(%eax),%eax",
-                      text "\tpushl %eax",
-                      text "\tjmp dyld_stub_binding_helper"
-              ]
-           $$ lines_ [
-                text ".section __DATA, __la_sym_ptr"
-                    <> (if pic then int 2 else int 3)
-                    <> text ",lazy_symbol_pointers",
-                text "L" <> ppr_lbl lbl <> text "$lazy_ptr:",
-                    text "\t.indirect_symbol" <+> ppr_lbl lbl,
-                    text "\t.long L" <> ppr_lbl lbl
-                    <> text "$stub_binder"]
-
-        | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl
-        -> lines_ [
-                text ".non_lazy_symbol_pointer",
-                char 'L' <> ppr_lbl lbl <> text "$non_lazy_ptr:",
-                text "\t.indirect_symbol" <+> ppr_lbl lbl,
-                text "\t.long\t0"]
-
-        | otherwise
-        -> empty
-
-   (ArchAArch64, OSDarwin)
-        -> empty
-
-
-
-   -- XCOFF / AIX
-   --
-   -- Similar to PPC64 ELF v1, there's dedicated TOC register (r2). To
-   -- workaround the limitation of a global TOC we use an indirect TOC
-   -- with the label `ghc_toc_table`.
-   --
-   -- See also GCC's `-mminimal-toc` compilation mode or
-   -- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/
-   --
-   -- NB: No DSO-support yet
-
-   (_, OSAIX) -> case dynamicLinkerLabelInfo importedLbl of
-            Just (SymbolPtr, lbl)
-              -> lines_ [
-                   text "LC.." <> ppr_lbl lbl <> char ':',
-                   text "\t.long" <+> ppr_lbl lbl ]
-            _ -> empty
-
-   -- ELF / Linux
-   --
-   -- In theory, we don't need to generate any stubs or symbol pointers
-   -- by hand for Linux.
-   --
-   -- Reality differs from this in two areas.
-   --
-   -- 1) If we just use a dynamically imported symbol directly in a read-only
-   --    section of the main executable (as GCC does), ld generates R_*_COPY
-   --    relocations, which are fundamentally incompatible with reversed info
-   --    tables. Therefore, we need a table of imported addresses in a writable
-   --    section.
-   --    The "official" GOT mechanism (label@got) isn't intended to be used
-   --    in position dependent code, so we have to create our own "fake GOT"
-   --    when not Opt_PIC && WayDyn `elem` ways dflags.
-   --
-   -- 2) PowerPC Linux is just plain broken.
-   --    While it's theoretically possible to use GOT offsets larger
-   --    than 16 bit, the standard crt*.o files don't, which leads to
-   --    linker errors as soon as the GOT size exceeds 16 bit.
-   --    Also, the assembler doesn't support @gotoff labels.
-   --    In order to be able to use a larger GOT, we have to circumvent the
-   --    entire GOT mechanism and do it ourselves (this is also what GCC does).
-
-
-   -- When needImportedSymbols is defined,
-   -- the NCG will keep track of all DynamicLinkerLabels it uses
-   -- and output each of them using pprImportedSymbol.
-
-   (ArchPPC_64 _, _)
-        | osElfTarget os
-        -> case dynamicLinkerLabelInfo importedLbl of
-            Just (SymbolPtr, lbl)
-              -> lines_ [
-                   text ".LC_" <> ppr_lbl lbl <> char ':',
-                   text "\t.quad" <+> ppr_lbl lbl ]
-            _ -> empty
-
-   _ | osElfTarget os
-     -> case dynamicLinkerLabelInfo importedLbl of
-            Just (SymbolPtr, lbl)
-              -> let symbolSize = case ncgWordWidth config of
-                         W32 -> text "\t.long"
-                         W64 -> text "\t.quad"
-                         _ -> panic "Unknown wordRep in pprImportedSymbol"
-
-                 in lines_ [
-                      text ".section \".got2\", \"aw\"",
-                      text ".LC_" <> ppr_lbl lbl <> char ':',
-                      symbolSize <+> ppr_lbl lbl ]
-
-            -- PLT code stubs are generated automatically by the dynamic linker.
-            _ -> empty
-
-   _ -> panic "PIC.pprImportedSymbol: no match"
- where
-   platform = ncgPlatform config
-   ppr_lbl :: CLabel -> HLine
-   ppr_lbl  = pprAsmLabel   platform
-   arch     = platformArch  platform
-   os       = platformOS    platform
-   pic      = ncgPIC config
-
---------------------------------------------------------------------------------
--- Generate code to calculate the address that should be put in the
--- PIC base register.
--- This is called by MachCodeGen for every CmmProc that accessed the
--- PIC base register. It adds the appropriate instructions to the
--- top of the CmmProc.
-
--- It is assumed that the first NatCmmDecl in the input list is a Proc
--- and the rest are CmmDatas.
-
--- Darwin is simple: just fetch the address of a local label.
--- The FETCHPC pseudo-instruction is expanded to multiple instructions
--- during pretty-printing so that we don't have to deal with the
--- local label:
-
--- PowerPC version:
---          bcl 20,31,1f.
---      1:  mflr picReg
-
--- i386 version:
---          call 1f
---      1:  popl %picReg
-
-
-
--- Get a pointer to our own fake GOT, which is defined on a per-module basis.
--- This is exactly how GCC does it in linux.
-
-initializePicBase_ppc
-        :: Arch -> OS -> Reg
-        -> [NatCmmDecl RawCmmStatics PPC.Instr]
-        -> NatM [NatCmmDecl RawCmmStatics PPC.Instr]
-
-initializePicBase_ppc ArchPPC os picReg
-    (CmmProc info lab live (ListGraph blocks) : statics)
-    | osElfTarget os
-    = do
-        let
-            gotOffset = PPC.ImmConstantDiff
-                                (PPC.ImmCLbl gotLabel)
-                                (PPC.ImmCLbl mkPicBaseLabel)
-
-            blocks' = case blocks of
-                       [] -> []
-                       (b:bs) -> fetchPC b : map maybeFetchPC bs
-
-            maybeFetchPC b@(BasicBlock bID _)
-              | bID `mapMember` info = fetchPC b
-              | otherwise            = b
-
-            -- GCC does PIC prologs thusly:
-            --     bcl 20,31,.L1
-            -- .L1:
-            --     mflr 30
-            --     addis 30,30,.LCTOC1-.L1@ha
-            --     addi 30,30,.LCTOC1-.L1@l
-            -- TODO: below we use it over temporary register,
-            -- it can and should be optimised by picking
-            -- correct PIC reg.
-            fetchPC (BasicBlock bID insns) =
-              BasicBlock bID (PPC.FETCHPC picReg
-                              : PPC.ADDIS picReg picReg (PPC.HA gotOffset)
-                              : PPC.ADD picReg picReg
-                                        (PPC.RIImm (PPC.LO gotOffset))
-                              : PPC.MR PPC.r30 picReg
-                              : insns)
-
-        return (CmmProc info lab live (ListGraph blocks') : statics)
-
--------------------------------------------------------------------------
--- Load TOC into register 2
--- PowerPC 64-bit ELF ABI 2.0 requires the address of the callee
--- in register 12.
--- We pass the label to FETCHTOC and create a .localentry too.
--- TODO: Explain this better and refer to ABI spec!
-{-
-We would like to do approximately this, but spill slot allocation
-might be added before the first BasicBlock. That violates the ABI.
-
-For now we will emit the prologue code in the pretty printer,
-which is also what we do for ELF v1.
-initializePicBase_ppc (ArchPPC_64 ELF_V2) OSLinux picReg
-        (CmmProc info lab live (ListGraph (entry:blocks)) : statics)
-        = do
-           bID <-getUniqueM
-           return (CmmProc info lab live (ListGraph (b':entry:blocks))
-                                         : statics)
-        where   BasicBlock entryID _ = entry
-                b' = BasicBlock bID [PPC.FETCHTOC picReg lab,
-                                     PPC.BCC PPC.ALWAYS entryID]
--}
-
-initializePicBase_ppc _ _ _ _
-        = panic "initializePicBase_ppc: not needed"
-
-
--- We cheat a bit here by defining a pseudo-instruction named FETCHGOT
--- which pretty-prints as:
---              call 1f
--- 1:           popl %picReg
---              addl __GLOBAL_OFFSET_TABLE__+.-1b, %picReg
--- (See PprMach.hs)
-
-initializePicBase_x86
-        :: Arch -> OS -> Reg
-        -> [NatCmmDecl (Alignment, RawCmmStatics) X86.Instr]
-        -> NatM [NatCmmDecl (Alignment, RawCmmStatics) X86.Instr]
-
-initializePicBase_x86 ArchX86 os picReg
-        (CmmProc info lab live (ListGraph blocks) : statics)
-    | osElfTarget os
-    = return (CmmProc info lab live (ListGraph blocks') : statics)
-    where blocks' = case blocks of
-                     [] -> []
-                     (b:bs) -> fetchGOT b : map maybeFetchGOT bs
-
-          -- we want to add a FETCHGOT instruction to the beginning of
-          -- every block that is an entry point, which corresponds to
-          -- the blocks that have entries in the info-table mapping.
-          maybeFetchGOT b@(BasicBlock bID _)
-            | bID `mapMember` info = fetchGOT b
-            | otherwise            = b
-
-          fetchGOT (BasicBlock bID insns) =
-             BasicBlock bID (X86.FETCHGOT picReg : insns)
-
-initializePicBase_x86 ArchX86 OSDarwin picReg
-        (CmmProc info lab live (ListGraph (entry:blocks)) : statics)
-        = return (CmmProc info lab live (ListGraph (block':blocks)) : statics)
-
-    where BasicBlock bID insns = entry
-          block' = BasicBlock bID (X86.FETCHPC picReg : insns)
-
-initializePicBase_x86 _ _ _ _
-        = panic "initializePicBase_x86: not needed"
diff --git a/compiler/GHC/CmmToAsm/PPC.hs b/compiler/GHC/CmmToAsm/PPC.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/PPC.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
--- | Native code generator for PPC architectures
-module GHC.CmmToAsm.PPC
-   ( ncgPPC
-   )
-where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.Instr
-import GHC.CmmToAsm.Monad
-import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Types
-
-import qualified GHC.CmmToAsm.PPC.Instr   as PPC
-import qualified GHC.CmmToAsm.PPC.Ppr     as PPC
-import qualified GHC.CmmToAsm.PPC.CodeGen as PPC
-import qualified GHC.CmmToAsm.PPC.Regs    as PPC
-import qualified GHC.CmmToAsm.PPC.RegInfo as PPC
-
-ncgPPC :: NCGConfig -> NcgImpl RawCmmStatics PPC.Instr PPC.JumpDest
-ncgPPC config = NcgImpl
-   { ncgConfig                 = config
-   , cmmTopCodeGen             = PPC.cmmTopCodeGen
-   , generateJumpTableForInstr = PPC.generateJumpTableForInstr config
-   , getJumpDestBlockId        = PPC.getJumpDestBlockId
-   , canShortcut               = PPC.canShortcut
-   , shortcutStatics           = PPC.shortcutStatics
-   , shortcutJump              = PPC.shortcutJump
-   , pprNatCmmDeclH            = PPC.pprNatCmmDecl config
-   , pprNatCmmDeclS            = PPC.pprNatCmmDecl config
-   , maxSpillSlots             = PPC.maxSpillSlots config
-   , allocatableRegs           = PPC.allocatableRegs platform
-   , ncgAllocMoreStack         = PPC.allocMoreStack platform
-   , ncgMakeFarBranches        = PPC.makeFarBranches
-   , extractUnwindPoints       = const []
-   , invertCondBranches        = \_ _ -> id
-   }
-    where
-      platform = ncgPlatform config
-
--- | Instruction instance for powerpc
-instance Instruction PPC.Instr where
-   regUsageOfInstr     = PPC.regUsageOfInstr
-   patchRegsOfInstr    = PPC.patchRegsOfInstr
-   isJumpishInstr      = PPC.isJumpishInstr
-   jumpDestsOfInstr    = PPC.jumpDestsOfInstr
-   patchJumpInstr      = PPC.patchJumpInstr
-   mkSpillInstr        = PPC.mkSpillInstr
-   mkLoadInstr         = PPC.mkLoadInstr
-   takeDeltaInstr      = PPC.takeDeltaInstr
-   isMetaInstr         = PPC.isMetaInstr
-   mkRegRegMoveInstr _ = PPC.mkRegRegMoveInstr
-   takeRegRegMoveInstr = PPC.takeRegRegMoveInstr
-   mkJumpInstr         = PPC.mkJumpInstr
-   mkStackAllocInstr   = PPC.mkStackAllocInstr
-   mkStackDeallocInstr = PPC.mkStackDeallocInstr
-   pprInstr            = PPC.pprInstr
-   mkComment           = pure . PPC.COMMENT
diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
+++ /dev/null
@@ -1,2534 +0,0 @@
-{-# LANGUAGE GADTs #-}
-
------------------------------------------------------------------------------
---
--- Generating machine code (instruction selection)
---
--- (c) The University of Glasgow 1996-2004
---
------------------------------------------------------------------------------
-
--- This is a big module, but, if you pay attention to
--- (a) the sectioning, and (b) the type signatures,
--- the structure should not be too overwhelming.
-
-module GHC.CmmToAsm.PPC.CodeGen (
-        cmmTopCodeGen,
-        generateJumpTableForInstr,
-        InstrBlock
-)
-
-where
-
--- NCG stuff:
-import GHC.Prelude
-
-import GHC.Platform.Regs
-import GHC.CmmToAsm.PPC.Instr
-import GHC.CmmToAsm.PPC.Cond
-import GHC.CmmToAsm.PPC.Regs
-import GHC.CmmToAsm.CPrim
-import GHC.CmmToAsm.Types
-import GHC.Cmm.DebugBlock
-   ( DebugBlock(..) )
-import GHC.CmmToAsm.Monad
-   ( NatM, getNewRegNat, getNewLabelNat
-   , getBlockIdNat, getPicBaseNat
-   , Reg64(..), RegCode64(..), getNewReg64, localReg64
-   , getPicBaseMaybeNat, getPlatform, getConfig
-   , getDebugBlock, getFileId
-   )
-import GHC.CmmToAsm.PIC
-import GHC.CmmToAsm.Format
-import GHC.CmmToAsm.Config
-import GHC.Platform.Reg.Class
-import GHC.Platform.Reg
-import GHC.CmmToAsm.Reg.Target
-import GHC.Platform
-
--- Our intermediate code:
-import GHC.Cmm.BlockId
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Cmm.Switch
-import GHC.Cmm.CLabel
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Graph
-import GHC.Types.Tickish     ( GenTickish(..) )
-import GHC.Types.SrcLoc      ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
-
--- The rest:
-import GHC.Data.OrdList
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-import Control.Monad    ( mapAndUnzipM, when )
-import Data.Word
-
-import GHC.Types.Basic
-import GHC.Data.FastString
-
--- -----------------------------------------------------------------------------
--- Top-level of the instruction selector
-
--- | 'InstrBlock's are the insn sequences generated by the insn selectors.
--- They are really trees of insns to facilitate fast appending, where a
--- left-to-right traversal (pre-order?) yields the insns in the correct
--- order.
-
-cmmTopCodeGen
-        :: RawCmmDecl
-        -> NatM [NatCmmDecl RawCmmStatics Instr]
-
-cmmTopCodeGen (CmmProc info lab live graph) = do
-  let blocks = toBlockListEntryFirst graph
-  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
-  platform <- getPlatform
-  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
-      tops = proc : concat statics
-      os   = platformOS platform
-      arch = platformArch platform
-  case arch of
-    ArchPPC | os == OSAIX -> return tops
-            | otherwise -> do
-      picBaseMb <- getPicBaseMaybeNat
-      case picBaseMb of
-           Just picBase -> initializePicBase_ppc arch os picBase tops
-           Nothing -> return tops
-    ArchPPC_64 ELF_V1 -> fixup_entry tops
-                      -- generating function descriptor is handled in
-                      -- pretty printer
-    ArchPPC_64 ELF_V2 -> fixup_entry tops
-                      -- generating function prologue is handled in
-                      -- pretty printer
-    _          -> panic "PPC.cmmTopCodeGen: unknown arch"
-    where
-      fixup_entry (CmmProc info lab live (ListGraph (entry:blocks)) : statics)
-        = do
-        let BasicBlock bID insns = entry
-        bID' <- if lab == (blockLbl bID)
-                then newBlockId
-                else return bID
-        let b' = BasicBlock bID' insns
-        return (CmmProc info lab live (ListGraph (b':blocks)) : statics)
-      fixup_entry _ = panic "cmmTopCodegen: Broken CmmProc"
-
-cmmTopCodeGen (CmmData sec dat) =
-  return [CmmData sec dat]  -- no translation, we just use CmmStatic
-
-basicBlockCodeGen
-        :: Block CmmNode C C
-        -> NatM ( [NatBasicBlock Instr]
-                , [NatCmmDecl RawCmmStatics Instr])
-
-basicBlockCodeGen block = do
-  let (_, nodes, tail)  = blockSplit block
-      id = entryLabel block
-      stmts = blockToList nodes
-  -- Generate location directive
-  dbg <- getDebugBlock (entryLabel block)
-  loc_instrs <- case dblSourceTick =<< dbg of
-    Just (SourceNote span name)
-      -> do fileid <- getFileId (srcSpanFile span)
-            let line = srcSpanStartLine span; col =srcSpanStartCol span
-            return $ unitOL $ LOCATION fileid line col name
-    _ -> return nilOL
-  mid_instrs <- stmtsToInstrs stmts
-  tail_instrs <- stmtToInstrs tail
-  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs
-  -- code generation may introduce new basic block boundaries, which
-  -- are indicated by the NEWBLOCK instruction.  We must split up the
-  -- instruction stream into basic blocks again.  Also, we extract
-  -- LDATAs here too.
-  let
-        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
-
-        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
-          = ([], BasicBlock id instrs : blocks, statics)
-        mkBlocks (LDATA sec dat) (instrs,blocks,statics)
-          = (instrs, blocks, CmmData sec dat:statics)
-        mkBlocks instr (instrs,blocks,statics)
-          = (instr:instrs, blocks, statics)
-  return (BasicBlock id top : other_blocks, statics)
-
-stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
-stmtsToInstrs stmts
-   = do instrss <- mapM stmtToInstrs stmts
-        return (concatOL instrss)
-
-stmtToInstrs :: CmmNode e x -> NatM InstrBlock
-stmtToInstrs stmt = do
-  config <- getConfig
-  platform <- getPlatform
-  case stmt of
-    CmmComment s   -> return (unitOL (COMMENT s))
-    CmmTick {}     -> return nilOL
-    CmmUnwind {}   -> return nilOL
-
-    CmmAssign reg src
-      | isFloatType ty -> assignReg_FltCode format reg src
-      | target32Bit platform &&
-        isWord64 ty    -> assignReg_I64Code      reg src
-      | otherwise      -> assignReg_IntCode format reg src
-        where ty = cmmRegType platform reg
-              format = cmmTypeFormat ty
-
-    CmmStore addr src _alignment
-      | isFloatType ty -> assignMem_FltCode format addr src
-      | target32Bit platform &&
-        isWord64 ty    -> assignMem_I64Code      addr src
-      | otherwise      -> assignMem_IntCode format addr src
-        where ty = cmmExprType platform src
-              format = cmmTypeFormat ty
-
-    CmmUnsafeForeignCall target result_regs args
-       -> genCCall target result_regs args
-
-    CmmBranch id          -> genBranch id
-    CmmCondBranch arg true false prediction -> do
-      b1 <- genCondJump true arg prediction
-      b2 <- genBranch false
-      return (b1 `appOL` b2)
-    CmmSwitch arg ids -> genSwitch config arg ids
-    CmmCall { cml_target = arg
-            , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)
-    _ ->
-      panic "stmtToInstrs: statement should have been cps'd away"
-
-jumpRegs :: Platform -> [GlobalReg] -> [Reg]
-jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]
-
---------------------------------------------------------------------------------
--- | 'InstrBlock's are the insn sequences generated by the insn selectors.
---      They are really trees of insns to facilitate fast appending, where a
---      left-to-right traversal yields the insns in the correct order.
---
-type InstrBlock
-        = OrdList Instr
-
-
--- | Register's passed up the tree.  If the stix code forces the register
---      to live in a pre-decided machine register, it comes out as @Fixed@;
---      otherwise, it comes out as @Any@, and the parent can decide which
---      register to put it in.
---
-data Register
-        = Fixed Format Reg InstrBlock
-        | Any   Format (Reg -> InstrBlock)
-
-
-swizzleRegisterRep :: Register -> Format -> Register
-swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code
-swizzleRegisterRep (Any _ codefn)     format = Any   format codefn
-
-getLocalRegReg :: LocalReg -> Reg
-getLocalRegReg (LocalReg u pk)
-  = RegVirtual (mkVirtualReg u (cmmTypeFormat pk))
-
--- | Grab the Reg for a CmmReg
-getRegisterReg :: Platform -> CmmReg -> Reg
-
-getRegisterReg _ (CmmLocal local_reg)
-  = getLocalRegReg local_reg
-
-getRegisterReg platform (CmmGlobal mid)
-  = case globalRegMaybe platform mid of
-        Just reg -> RegReal reg
-        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
-        -- By this stage, the only MagicIds remaining should be the
-        -- ones which map to a real machine register on this
-        -- platform.  Hence ...
-
--- | Convert a BlockId to some CmmStatic data
-jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic
-jumpTableEntry config Nothing   = CmmStaticLit (CmmInt 0 (ncgWordWidth config))
-jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
-    where blockLabel = blockLbl blockid
-
-
-
--- -----------------------------------------------------------------------------
--- General things for putting together code sequences
-
--- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
--- CmmExprs into CmmRegOff?
-mangleIndexTree :: Platform -> CmmExpr -> CmmExpr
-mangleIndexTree platform (CmmRegOff reg off)
-  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
-  where width = typeWidth (cmmRegType platform reg)
-
-mangleIndexTree _ _
-        = panic "PPC.CodeGen.mangleIndexTree: no match"
-
--- -----------------------------------------------------------------------------
---  Code gen for 64-bit arithmetic on 32-bit platforms
-
-{-
-Simple support for generating 64-bit code (ie, 64 bit values and 64
-bit assignments) on 32-bit platforms.  Unlike the main code generator
-we merely shoot for generating working code as simply as possible, and
-pay little attention to code quality.  Specifically, there is no
-attempt to deal cleverly with the fixed-vs-floating register
-distinction; all values are generated into (pairs of) floating
-registers, even if this would mean some redundant reg-reg moves as a
-result.  Only one of the VRegUniques is returned, since it will be
-of the VRegUniqueLo form, and the upper-half VReg can be determined
-by applying getHiVRegFromLo to it.
--}
-
--- | Compute an expression into a register, but
---      we don't mind which one it is.
-getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
-getSomeReg expr = do
-  r <- getRegister expr
-  case r of
-    Any rep code -> do
-        tmp <- getNewRegNat rep
-        return (tmp, code tmp)
-    Fixed _ reg code ->
-        return (reg, code)
-
-getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)
-getI64Amodes addrTree = do
-    Amode hi_addr addr_code <- getAmode D addrTree
-    case addrOffset hi_addr 4 of
-        Just lo_addr -> return (hi_addr, lo_addr, addr_code)
-        Nothing      -> do (hi_ptr, code) <- getSomeReg addrTree
-                           return (AddrRegImm hi_ptr (ImmInt 0),
-                                   AddrRegImm hi_ptr (ImmInt 4),
-                                   code)
-
-
-assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
-assignMem_I64Code addrTree valueTree = do
-        (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
-        RegCode64 vcode rhi rlo <- iselExpr64 valueTree
-        let
-                -- Big-endian store
-                mov_hi = ST II32 rhi hi_addr
-                mov_lo = ST II32 rlo lo_addr
-        return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
-
-
-assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
-assignReg_I64Code (CmmLocal lreg) valueTree = do
-   RegCode64 vcode r_src_hi r_src_lo <- iselExpr64 valueTree
-   let Reg64 r_dst_hi r_dst_lo = localReg64 lreg
-       mov_lo = MR r_dst_lo r_src_lo
-       mov_hi = MR r_dst_hi r_src_hi
-   return (
-        vcode `snocOL` mov_lo `snocOL` mov_hi
-     )
-
-assignReg_I64Code _ _
-   = panic "assignReg_I64Code(powerpc): invalid lvalue"
-
-
-iselExpr64        :: CmmExpr -> NatM (RegCode64 InstrBlock)
-iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do
-    (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
-    Reg64 rhi rlo <- getNewReg64
-    let mov_hi = LD II32 rhi hi_addr
-        mov_lo = LD II32 rlo lo_addr
-    return $ RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
-                         rhi rlo
-
-iselExpr64 (CmmReg (CmmLocal local_reg)) = do
-  let Reg64 hi lo = localReg64 local_reg
-  return (RegCode64 nilOL hi lo)
-
-iselExpr64 (CmmLit (CmmInt i _)) = do
-  Reg64 rhi rlo <- getNewReg64
-  let
-        half0 = fromIntegral (fromIntegral i :: Word16)
-        half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)
-        half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16)
-        half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16)
-
-        code = toOL [
-                LIS rlo (ImmInt half1),
-                OR rlo rlo (RIImm $ ImmInt half0),
-                LIS rhi (ImmInt half3),
-                OR rhi rhi (RIImm $ ImmInt half2)
-                ]
-  return (RegCode64 code rhi rlo)
-
-iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1
-   RegCode64 code2 r2hi r2lo <- iselExpr64 e2
-   Reg64 rhi rlo <- getNewReg64
-   let
-        code =  code1 `appOL`
-                code2 `appOL`
-                toOL [ ADDC rlo r1lo r2lo,
-                       ADDE rhi r1hi r2hi ]
-   return (RegCode64 code rhi rlo)
-
-iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do
-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1
-   RegCode64 code2 r2hi r2lo <- iselExpr64 e2
-   Reg64 rhi rlo <- getNewReg64
-   let
-        code =  code1 `appOL`
-                code2 `appOL`
-                toOL [ SUBFC rlo r2lo (RIReg r1lo),
-                       SUBFE rhi r2hi r1hi ]
-   return (RegCode64 code rhi rlo)
-
-iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do
-    (expr_reg,expr_code) <- getSomeReg expr
-    Reg64 rhi rlo <- getNewReg64
-    let mov_hi = LI rhi (ImmInt 0)
-        mov_lo = MR rlo expr_reg
-    return $ RegCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
-                       rhi rlo
-
-iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do
-    (expr_reg,expr_code) <- getSomeReg expr
-    Reg64 rhi rlo <- getNewReg64
-    let mov_hi = SRA II32 rhi expr_reg (RIImm (ImmInt 31))
-        mov_lo = MR rlo expr_reg
-    return $ RegCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
-                       rhi rlo
-iselExpr64 expr
-   = do
-     platform <- getPlatform
-     pprPanic "iselExpr64(powerpc)" (pdoc platform expr)
-
-
-
-getRegister :: CmmExpr -> NatM Register
-getRegister e = do config <- getConfig
-                   getRegister' config (ncgPlatform config) e
-
-getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
-
-getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg))
-  | OSAIX <- platformOS platform = do
-        let code dst = toOL [ LD II32 dst tocAddr ]
-            tocAddr = AddrRegImm toc (ImmLit (fsLit "ghc_toc_table[TC]"))
-        return (Any II32 code)
-  | target32Bit platform = do
-      reg <- getPicBaseNat $ archWordFormat (target32Bit platform)
-      return (Fixed (archWordFormat (target32Bit platform))
-                    reg nilOL)
-  | otherwise = return (Fixed II64 toc nilOL)
-
-getRegister' _ platform (CmmReg reg)
-  = return (Fixed (cmmTypeFormat (cmmRegType platform reg))
-                  (getRegisterReg platform reg) nilOL)
-
-getRegister' config platform tree@(CmmRegOff _ _)
-  = getRegister' config platform (mangleIndexTree platform tree)
-
-    -- for 32-bit architectures, support some 64 -> 32 bit conversions:
-    -- TO_W_(x), TO_W_(x >> 32)
-
-getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32)
-                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
- | target32Bit platform = do
-  RegCode64 code _rhi rlo <- iselExpr64 x
-  return $ Fixed II32 (getHiVRegFromLo rlo) code
-
-getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32)
-                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
- | target32Bit platform = do
-  RegCode64 code _rhi rlo <- iselExpr64 x
-  return $ Fixed II32 (getHiVRegFromLo rlo) code
-
-getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32) [x])
- | target32Bit platform = do
-  RegCode64 code _rhi rlo <- iselExpr64 x
-  return $ Fixed II32 rlo code
-
-getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32) [x])
- | target32Bit platform = do
-  RegCode64 code _rhi rlo <- iselExpr64 x
-  return $ Fixed II32 rlo code
-
-getRegister' _ platform (CmmLoad mem pk _)
- | not (isWord64 pk) = do
-        Amode addr addr_code <- getAmode D mem
-        let code dst = assert ((targetClassOfReg platform dst == RcDouble) == isFloatType pk) $
-                       addr_code `snocOL` LD format dst addr
-        return (Any format code)
- | not (target32Bit platform) = do
-        Amode addr addr_code <- getAmode DS mem
-        let code dst = addr_code `snocOL` LD II64 dst addr
-        return (Any II64 code)
-
-          where format = cmmTypeFormat pk
-
--- catch simple cases of zero- or sign-extended load
-getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _ _]) = do
-    Amode addr addr_code <- getAmode D mem
-    return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _ _]) = do
-    Amode addr addr_code <- getAmode D mem
-    return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _ _]) = do
-    Amode addr addr_code <- getAmode D mem
-    return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _ _]) = do
-    Amode addr addr_code <- getAmode D mem
-    return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))
-
--- Note: there is no Load Byte Arithmetic instruction, so no signed case here
-
-getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _ _]) = do
-    Amode addr addr_code <- getAmode D mem
-    return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _ _]) = do
-    Amode addr addr_code <- getAmode D mem
-    return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _ _]) = do
-    Amode addr addr_code <- getAmode D mem
-    return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _ _]) = do
-    Amode addr addr_code <- getAmode D mem
-    return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _ _]) = do
-    Amode addr addr_code <- getAmode D mem
-    return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr))
-
-getRegister' _ _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _ _]) = do
-    -- lwa is DS-form. See Note [Power instruction format]
-    Amode addr addr_code <- getAmode DS mem
-    return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr))
-
-getRegister' config platform (CmmMachOp mop [x]) -- unary MachOps
-  = case mop of
-      MO_Not rep   -> triv_ucode_int rep NOT
-
-      MO_F_Neg w   -> triv_ucode_float w FNEG
-      MO_S_Neg w   -> triv_ucode_int   w NEG
-
-      MO_FF_Conv W64 W32 -> trivialUCode  FF32 FRSP x
-      MO_FF_Conv W32 W64 -> conversionNop FF64 x
-
-      MO_FS_Conv from to -> coerceFP2Int from to x
-      MO_SF_Conv from to -> coerceInt2FP from to x
-
-      MO_SS_Conv from to
-        | from >= to -> conversionNop (intFormat to) x
-        | otherwise  -> triv_ucode_int to (EXTS (intFormat from))
-
-      MO_UU_Conv from to
-        | from >= to -> conversionNop (intFormat to) x
-        | otherwise  -> clearLeft from to
-
-      MO_XX_Conv _ to -> conversionNop (intFormat to) x
-
-      _ -> panic "PPC.CodeGen.getRegister: no match"
-
-    where
-        triv_ucode_int   width instr = trivialUCode (intFormat    width) instr x
-        triv_ucode_float width instr = trivialUCode (floatFormat  width) instr x
-
-        conversionNop new_format expr
-            = do e_code <- getRegister' config platform expr
-                 return (swizzleRegisterRep e_code new_format)
-
-        clearLeft from to
-            = do (src1, code1) <- getSomeReg x
-                 let arch_fmt  = intFormat (wordWidth platform)
-                     arch_bits = widthInBits (wordWidth platform)
-                     size      = widthInBits from
-                     code dst  = code1 `snocOL`
-                                 CLRLI arch_fmt dst src1 (arch_bits - size)
-                 return (Any (intFormat to) code)
-
-getRegister' _ _ (CmmMachOp mop [x, y]) -- dyadic PrimOps
-  = case mop of
-      MO_F_Eq _ -> condFltReg EQQ x y
-      MO_F_Ne _ -> condFltReg NE  x y
-      MO_F_Gt _ -> condFltReg GTT x y
-      MO_F_Ge _ -> condFltReg GE  x y
-      MO_F_Lt _ -> condFltReg LTT x y
-      MO_F_Le _ -> condFltReg LE  x y
-
-      MO_Eq rep -> condIntReg EQQ rep x y
-      MO_Ne rep -> condIntReg NE  rep x y
-
-      MO_S_Gt rep -> condIntReg GTT rep x y
-      MO_S_Ge rep -> condIntReg GE  rep x y
-      MO_S_Lt rep -> condIntReg LTT rep x y
-      MO_S_Le rep -> condIntReg LE  rep x y
-
-      MO_U_Gt rep -> condIntReg GU  rep x y
-      MO_U_Ge rep -> condIntReg GEU rep x y
-      MO_U_Lt rep -> condIntReg LU  rep x y
-      MO_U_Le rep -> condIntReg LEU rep x y
-
-      MO_F_Add w  -> triv_float w FADD
-      MO_F_Sub w  -> triv_float w FSUB
-      MO_F_Mul w  -> triv_float w FMUL
-      MO_F_Quot w -> triv_float w FDIV
-
-         -- optimize addition with 32-bit immediate
-         -- (needed for PIC)
-      MO_Add W32 ->
-        case y of
-          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate W32 True imm
-            -> trivialCode W32 True ADD x (CmmLit $ CmmInt imm immrep)
-          CmmLit lit
-            -> do
-                (src, srcCode) <- getSomeReg x
-                let imm = litToImm lit
-                    code dst = srcCode `appOL` toOL [
-                                    ADDIS dst src (HA imm),
-                                    ADD dst dst (RIImm (LO imm))
-                                ]
-                return (Any II32 code)
-          _ -> trivialCode W32 True ADD x y
-
-      MO_Add rep -> trivialCode rep True ADD x y
-      MO_Sub rep ->
-        case y of
-          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm)
-            -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep)
-          _ -> case x of
-                 CmmLit (CmmInt imm _)
-                   | Just _ <- makeImmediate rep True imm
-                   -- subfi ('subtract from' with immediate) doesn't exist
-                   -> trivialCode rep True SUBFC y x
-                 _ -> trivialCodeNoImm' (intFormat rep) SUBF y x
-
-      MO_Mul rep -> shiftMulCode rep True MULL x y
-      MO_S_MulMayOflo rep -> do
-        (src1, code1) <- getSomeReg x
-        (src2, code2) <- getSomeReg y
-        let
-          format = intFormat rep
-          code dst = code1 `appOL` code2
-                       `appOL` toOL [ MULLO format dst src1 src2
-                                    , MFOV  format dst
-                                    ]
-        return (Any format code)
-
-      MO_S_Quot rep -> divCode rep True x y
-      MO_U_Quot rep -> divCode rep False x y
-
-      MO_S_Rem rep -> remainder rep True x y
-      MO_U_Rem rep -> remainder rep False x y
-
-      MO_And rep   -> case y of
-        (CmmLit (CmmInt imm _)) | imm == -8 || imm == -4
-            -> do
-                (src, srcCode) <- getSomeReg x
-                let clear_mask = if imm == -4 then 2 else 3
-                    fmt = intFormat rep
-                    code dst = srcCode
-                               `appOL` unitOL (CLRRI fmt dst src clear_mask)
-                return (Any fmt code)
-        _ -> trivialCode rep False AND x y
-      MO_Or rep    -> trivialCode rep False OR x y
-      MO_Xor rep   -> trivialCode rep False XOR x y
-
-      MO_Shl rep   -> shiftMulCode rep False SL x y
-      MO_S_Shr rep -> srCode rep True SRA x y
-      MO_U_Shr rep -> srCode rep False SR x y
-      _         -> panic "PPC.CodeGen.getRegister: no match"
-
-  where
-    triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
-    triv_float width instr = trivialCodeNoImm (floatFormat width) instr x y
-
-    remainder :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
-    remainder rep sgn x y = do
-      let fmt = intFormat rep
-      tmp <- getNewRegNat fmt
-      code <- remainderCode rep sgn tmp x y
-      return (Any fmt code)
-
-
-getRegister' _ _ (CmmLit (CmmInt i rep))
-  | Just imm <- makeImmediate rep True i
-  = let
-        code dst = unitOL (LI dst imm)
-    in
-        return (Any (intFormat rep) code)
-
-getRegister' config _ (CmmLit (CmmFloat f frep)) = do
-    lbl <- getNewLabelNat
-    dynRef <- cmmMakeDynamicReference config DataReference lbl
-    Amode addr addr_code <- getAmode D dynRef
-    let format = floatFormat frep
-        code dst =
-            LDATA (Section ReadOnlyData lbl)
-                  (CmmStaticsRaw lbl [CmmStaticLit (CmmFloat f frep)])
-            `consOL` (addr_code `snocOL` LD format dst addr)
-    return (Any format code)
-
-getRegister' config platform (CmmLit lit)
-  | target32Bit platform
-  = let rep = cmmLitType platform lit
-        imm = litToImm lit
-        code dst = toOL [
-              LIS dst (HA imm),
-              ADD dst dst (RIImm (LO imm))
-          ]
-    in return (Any (cmmTypeFormat rep) code)
-  | otherwise
-  = do lbl <- getNewLabelNat
-       dynRef <- cmmMakeDynamicReference config DataReference lbl
-       Amode addr addr_code <- getAmode D dynRef
-       let rep = cmmLitType platform lit
-           format = cmmTypeFormat rep
-           code dst =
-            LDATA (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmStaticLit lit])
-            `consOL` (addr_code `snocOL` LD format dst addr)
-       return (Any format code)
-
-getRegister' _ platform other = pprPanic "getRegister(ppc)" (pdoc platform other)
-
-    -- extend?Rep: wrap integer expression of type `from`
-    -- in a conversion to `to`
-extendSExpr :: Width -> Width -> CmmExpr -> CmmExpr
-extendSExpr from to x = CmmMachOp (MO_SS_Conv from to) [x]
-
-extendUExpr :: Width -> Width -> CmmExpr -> CmmExpr
-extendUExpr from to x = CmmMachOp (MO_UU_Conv from to) [x]
-
--- -----------------------------------------------------------------------------
---  The 'Amode' type: Memory addressing modes passed up the tree.
-
-data Amode
-        = Amode AddrMode InstrBlock
-
-{-
-Now, given a tree (the argument to a CmmLoad) that references memory,
-produce a suitable addressing mode.
-
-A Rule of the Game (tm) for Amodes: use of the addr bit must
-immediately follow use of the code part, since the code part puts
-values in registers which the addr then refers to.  So you can't put
-anything in between, lest it overwrite some of those registers.  If
-you need to do some other computation between the code part and use of
-the addr bit, first store the effective address from the amode in a
-temporary, then do the other computation, and then use the temporary:
-
-    code
-    LEA amode, tmp
-    ... other computation ...
-    ... (tmp) ...
--}
-
-{- Note [Power instruction format]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In some instructions the 16 bit offset must be a multiple of 4, i.e.
-the two least significant bits must be zero. The "Power ISA" specification
-calls these instruction formats "DS-FORM" and the instructions with
-arbitrary 16 bit offsets are "D-FORM".
-
-The Power ISA specification document can be obtained from www.power.org.
--}
-data InstrForm = D | DS
-
-getAmode :: InstrForm -> CmmExpr -> NatM Amode
-getAmode inf tree@(CmmRegOff _ _)
-  = do platform <- getPlatform
-       getAmode inf (mangleIndexTree platform tree)
-
-getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)])
-  | Just off <- makeImmediate W32 True (-i)
-  = do
-        (reg, code) <- getSomeReg x
-        return (Amode (AddrRegImm reg off) code)
-
-
-getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)])
-  | Just off <- makeImmediate W32 True i
-  = do
-        (reg, code) <- getSomeReg x
-        return (Amode (AddrRegImm reg off) code)
-
-getAmode D (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])
-  | Just off <- makeImmediate W64 True (-i)
-  = do
-        (reg, code) <- getSomeReg x
-        return (Amode (AddrRegImm reg off) code)
-
-
-getAmode D (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])
-  | Just off <- makeImmediate W64 True i
-  = do
-        (reg, code) <- getSomeReg x
-        return (Amode (AddrRegImm reg off) code)
-
-getAmode DS (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])
-  | Just off <- makeImmediate W64 True (-i)
-  = do
-        (reg, code) <- getSomeReg x
-        (reg', off', code')  <-
-                     if i `mod` 4 == 0
-                      then return (reg, off, code)
-                      else do
-                           tmp <- getNewRegNat II64
-                           return (tmp, ImmInt 0,
-                                  code `snocOL` ADD tmp reg (RIImm off))
-        return (Amode (AddrRegImm reg' off') code')
-
-getAmode DS (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])
-  | Just off <- makeImmediate W64 True i
-  = do
-        (reg, code) <- getSomeReg x
-        (reg', off', code')  <-
-                     if i `mod` 4 == 0
-                      then return (reg, off, code)
-                      else do
-                           tmp <- getNewRegNat II64
-                           return (tmp, ImmInt 0,
-                                  code `snocOL` ADD tmp reg (RIImm off))
-        return (Amode (AddrRegImm reg' off') code')
-
-   -- optimize addition with 32-bit immediate
-   -- (needed for PIC)
-getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit])
-  = do
-        platform <- getPlatform
-        (src, srcCode) <- getSomeReg x
-        let imm = litToImm lit
-        case () of
-            _ | OSAIX <- platformOS platform
-              , isCmmLabelType lit ->
-                    -- HA16/LO16 relocations on labels not supported on AIX
-                    return (Amode (AddrRegImm src imm) srcCode)
-              | otherwise -> do
-                    tmp <- getNewRegNat II32
-                    let code = srcCode `snocOL` ADDIS tmp src (HA imm)
-                    return (Amode (AddrRegImm tmp (LO imm)) code)
-  where
-      isCmmLabelType (CmmLabel {})        = True
-      isCmmLabelType (CmmLabelOff {})     = True
-      isCmmLabelType (CmmLabelDiffOff {}) = True
-      isCmmLabelType _                    = False
-
-getAmode _ (CmmLit lit)
-  = do
-        platform <- getPlatform
-        case platformArch platform of
-             ArchPPC -> do
-                 tmp <- getNewRegNat II32
-                 let imm = litToImm lit
-                     code = unitOL (LIS tmp (HA imm))
-                 return (Amode (AddrRegImm tmp (LO imm)) code)
-             _        -> do -- TODO: Load from TOC,
-                            -- see getRegister' _ (CmmLit lit)
-                 tmp <- getNewRegNat II64
-                 let imm = litToImm lit
-                     code =  toOL [
-                          LIS tmp (HIGHESTA imm),
-                          OR tmp tmp (RIImm (HIGHERA imm)),
-                          SL  II64 tmp tmp (RIImm (ImmInt 32)),
-                          ORIS tmp tmp (HA imm)
-                          ]
-                 return (Amode (AddrRegImm tmp (LO imm)) code)
-
-getAmode _ (CmmMachOp (MO_Add W32) [x, y])
-  = do
-        (regX, codeX) <- getSomeReg x
-        (regY, codeY) <- getSomeReg y
-        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
-
-getAmode _ (CmmMachOp (MO_Add W64) [x, y])
-  = do
-        (regX, codeX) <- getSomeReg x
-        (regY, codeY) <- getSomeReg y
-        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
-
-getAmode _ other
-  = do
-        (reg, code) <- getSomeReg other
-        let
-            off  = ImmInt 0
-        return (Amode (AddrRegImm reg off) code)
-
-
---  The 'CondCode' type:  Condition codes passed up the tree.
-data CondCode
-        = CondCode Bool Cond InstrBlock
-
--- Set up a condition code for a conditional branch.
-
-getCondCode :: CmmExpr -> NatM CondCode
-
--- almost the same as everywhere else - but we need to
--- extend small integers to 32 bit or 64 bit first
-
-getCondCode (CmmMachOp mop [x, y])
-  = case mop of
-      MO_F_Eq W32 -> condFltCode EQQ x y
-      MO_F_Ne W32 -> condFltCode NE  x y
-      MO_F_Gt W32 -> condFltCode GTT x y
-      MO_F_Ge W32 -> condFltCode GE  x y
-      MO_F_Lt W32 -> condFltCode LTT x y
-      MO_F_Le W32 -> condFltCode LE  x y
-
-      MO_F_Eq W64 -> condFltCode EQQ x y
-      MO_F_Ne W64 -> condFltCode NE  x y
-      MO_F_Gt W64 -> condFltCode GTT x y
-      MO_F_Ge W64 -> condFltCode GE  x y
-      MO_F_Lt W64 -> condFltCode LTT x y
-      MO_F_Le W64 -> condFltCode LE  x y
-
-      MO_Eq rep -> condIntCode EQQ rep x y
-      MO_Ne rep -> condIntCode NE  rep x y
-
-      MO_S_Gt rep -> condIntCode GTT rep x y
-      MO_S_Ge rep -> condIntCode GE  rep x y
-      MO_S_Lt rep -> condIntCode LTT rep x y
-      MO_S_Le rep -> condIntCode LE  rep x y
-
-      MO_U_Gt rep -> condIntCode GU  rep x y
-      MO_U_Ge rep -> condIntCode GEU rep x y
-      MO_U_Lt rep -> condIntCode LU  rep x y
-      MO_U_Le rep -> condIntCode LEU rep x y
-
-      _ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop)
-
-getCondCode _ = panic "getCondCode(2)(powerpc)"
-
-
--- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
--- passed back up the tree.
-
-condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
-condIntCode cond width x y = do
-  platform <- getPlatform
-  condIntCode' (target32Bit platform) cond width x y
-
-condIntCode' :: Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
-
--- simple code for 64-bit on 32-bit platforms
-condIntCode' True cond W64 x y
-  | condUnsigned cond
-  = do
-      RegCode64 code_x x_hi x_lo <- iselExpr64 x
-      RegCode64 code_y y_hi y_lo <- iselExpr64 y
-      end_lbl <- getBlockIdNat
-      let code = code_x `appOL` code_y `appOL` toOL
-                 [ CMPL II32 x_hi (RIReg y_hi)
-                 , BCC NE end_lbl Nothing
-                 , CMPL II32 x_lo (RIReg y_lo)
-                 , BCC ALWAYS end_lbl Nothing
-
-                 , NEWBLOCK end_lbl
-                 ]
-      return (CondCode False cond code)
-  | otherwise
-  = do
-      RegCode64 code_x x_hi x_lo <- iselExpr64 x
-      RegCode64 code_y y_hi y_lo <- iselExpr64 y
-      end_lbl <- getBlockIdNat
-      cmp_lo  <- getBlockIdNat
-      let code = code_x `appOL` code_y `appOL` toOL
-                 [ CMP II32 x_hi (RIReg y_hi)
-                 , BCC NE end_lbl Nothing
-                 , CMP II32 x_hi (RIImm (ImmInt 0))
-                 , BCC LE cmp_lo Nothing
-                 , CMPL II32 x_lo (RIReg y_lo)
-                 , BCC ALWAYS end_lbl Nothing
-                 , NEWBLOCK cmp_lo
-                 , CMPL II32 y_lo (RIReg x_lo)
-                 , BCC ALWAYS end_lbl Nothing
-
-                 , NEWBLOCK end_lbl
-                 ]
-      return (CondCode False cond code)
-
--- optimize pointer tag checks. Operation andi. sets condition register
--- so cmpi ..., 0 is redundant.
-condIntCode' _ cond _ (CmmMachOp (MO_And _) [x, CmmLit (CmmInt imm rep)])
-                 (CmmLit (CmmInt 0 _))
-  | not $ condUnsigned cond,
-    Just src2 <- makeImmediate rep False imm
-  = do
-      (src1, code) <- getSomeReg x
-      let code' = code `snocOL` AND r0 src1 (RIImm src2)
-      return (CondCode False cond code')
-
-condIntCode' _ cond width x (CmmLit (CmmInt y rep))
-  | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y
-  = do
-      let op_len = max W32 width
-      let extend = if condUnsigned cond then extendUExpr width op_len
-                   else extendSExpr width op_len
-      (src1, code) <- getSomeReg (extend x)
-      let format = intFormat op_len
-          code' = code `snocOL`
-            (if condUnsigned cond then CMPL else CMP) format src1 (RIImm src2)
-      return (CondCode False cond code')
-
-condIntCode' _ cond width x y = do
-  let op_len = max W32 width
-  let extend = if condUnsigned cond then extendUExpr width op_len
-               else extendSExpr width op_len
-  (src1, code1) <- getSomeReg (extend x)
-  (src2, code2) <- getSomeReg (extend y)
-  let format = intFormat op_len
-      code' = code1 `appOL` code2 `snocOL`
-        (if condUnsigned cond then CMPL else CMP) format src1 (RIReg src2)
-  return (CondCode False cond code')
-
-condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
-condFltCode cond x y = do
-    (src1, code1) <- getSomeReg x
-    (src2, code2) <- getSomeReg y
-    let
-        code'  = code1 `appOL` code2 `snocOL` FCMP src1 src2
-        code'' = case cond of -- twiddle CR to handle unordered case
-                    GE -> code' `snocOL` CRNOR ltbit eqbit gtbit
-                    LE -> code' `snocOL` CRNOR gtbit eqbit ltbit
-                    _ -> code'
-                 where
-                    ltbit = 0 ; eqbit = 2 ; gtbit = 1
-    return (CondCode True cond code'')
-
-
-
--- -----------------------------------------------------------------------------
--- Generating assignments
-
--- Assignments are really at the heart of the whole code generation
--- business.  Almost all top-level nodes of any real importance are
--- assignments, which correspond to loads, stores, or register
--- transfers.  If we're really lucky, some of the register transfers
--- will go away, because we can use the destination register to
--- complete the code generation for the right hand side.  This only
--- fails when the right hand side is forced into a fixed register
--- (e.g. the result of a call).
-
-assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
-assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
-
-assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
-assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
-
-assignMem_IntCode pk addr src = do
-    (srcReg, code) <- getSomeReg src
-    Amode dstAddr addr_code <- case pk of
-                                II64 -> getAmode DS addr
-                                _    -> getAmode D  addr
-    return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
-
--- dst is a reg, but src could be anything
-assignReg_IntCode _ reg src
-    = do
-        platform <- getPlatform
-        let dst = getRegisterReg platform reg
-        r <- getRegister src
-        return $ case r of
-            Any _ code         -> code dst
-            Fixed _ freg fcode -> fcode `snocOL` MR dst freg
-
-
-
--- Easy, isn't it?
-assignMem_FltCode = assignMem_IntCode
-assignReg_FltCode = assignReg_IntCode
-
-
-
-genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock
-
-genJump (CmmLit (CmmLabel lbl)) regs
-  = return (unitOL $ JMP lbl regs)
-
-genJump tree gregs
-  = do
-        platform <- getPlatform
-        genJump' tree (platformToGCP platform) gregs
-
-genJump' :: CmmExpr -> GenCCallPlatform -> [Reg] -> NatM InstrBlock
-
-genJump' tree (GCP64ELF 1) regs
-  = do
-        (target,code) <- getSomeReg tree
-        return (code
-               `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 0))
-               `snocOL` LD II64 toc (AddrRegImm target (ImmInt 8))
-               `snocOL` MTCTR r11
-               `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 16))
-               `snocOL` BCTR [] Nothing regs)
-
-genJump' tree (GCP64ELF 2) regs
-  = do
-        (target,code) <- getSomeReg tree
-        return (code
-               `snocOL` MR r12 target
-               `snocOL` MTCTR r12
-               `snocOL` BCTR [] Nothing regs)
-
-genJump' tree _ regs
-  = do
-        (target,code) <- getSomeReg tree
-        return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing regs)
-
--- -----------------------------------------------------------------------------
---  Unconditional branches
-genBranch :: BlockId -> NatM InstrBlock
-genBranch = return . toOL . mkJumpInstr
-
-
--- -----------------------------------------------------------------------------
---  Conditional jumps
-
-{-
-Conditional jumps are always to local labels, so we can use branch
-instructions.  We peek at the arguments to decide what kind of
-comparison to do.
--}
-
-
-genCondJump
-    :: BlockId      -- the branch target
-    -> CmmExpr      -- the condition on which to branch
-    -> Maybe Bool
-    -> NatM InstrBlock
-
-genCondJump id bool prediction = do
-  CondCode _ cond code <- getCondCode bool
-  return (code `snocOL` BCC cond id prediction)
-
-
-
--- -----------------------------------------------------------------------------
---  Generating C calls
-
--- Now the biggest nightmare---calls.  Most of the nastiness is buried in
--- @get_arg@, which moves the arguments to the correct registers/stack
--- locations.  Apart from that, the code is easy.
-
-genCCall :: ForeignTarget      -- function to call
-         -> [CmmFormal]        -- where to put the result
-         -> [CmmActual]        -- arguments (of mixed type)
-         -> NatM InstrBlock
-genCCall (PrimTarget MO_ReadBarrier) _ _
- = return $ unitOL LWSYNC
-genCCall (PrimTarget MO_WriteBarrier) _ _
- = return $ unitOL LWSYNC
-
-genCCall (PrimTarget MO_Touch) _ _
- = return $ nilOL
-
-genCCall (PrimTarget (MO_Prefetch_Data _)) _ _
- = return $ nilOL
-
-genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n]
- = do let fmt      = intFormat width
-          reg_dst  = getLocalRegReg dst
-      (instr, n_code) <- case amop of
-            AMO_Add  -> getSomeRegOrImm ADD True reg_dst
-            AMO_Sub  -> case n of
-                CmmLit (CmmInt i _)
-                  | Just imm <- makeImmediate width True (-i)
-                   -> return (ADD reg_dst reg_dst (RIImm imm), nilOL)
-                _
-                   -> do
-                         (n_reg, n_code) <- getSomeReg n
-                         return  (SUBF reg_dst n_reg reg_dst, n_code)
-            AMO_And  -> getSomeRegOrImm AND False reg_dst
-            AMO_Nand -> do (n_reg, n_code) <- getSomeReg n
-                           return (NAND reg_dst reg_dst n_reg, n_code)
-            AMO_Or   -> getSomeRegOrImm OR False reg_dst
-            AMO_Xor  -> getSomeRegOrImm XOR False reg_dst
-      Amode addr_reg addr_code <- getAmodeIndex addr
-      lbl_retry <- getBlockIdNat
-      return $ n_code `appOL` addr_code
-        `appOL` toOL [ HWSYNC
-                     , BCC ALWAYS lbl_retry Nothing
-
-                     , NEWBLOCK lbl_retry
-                     , LDR fmt reg_dst addr_reg
-                     , instr
-                     , STC fmt reg_dst addr_reg
-                     , BCC NE lbl_retry (Just False)
-                     , ISYNC
-                     ]
-         where
-           getAmodeIndex (CmmMachOp (MO_Add _) [x, y])
-             = do
-                 (regX, codeX) <- getSomeReg x
-                 (regY, codeY) <- getSomeReg y
-                 return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
-           getAmodeIndex other
-             = do
-                 (reg, code) <- getSomeReg other
-                 return (Amode (AddrRegReg r0 reg) code) -- NB: r0 is 0 here!
-           getSomeRegOrImm op sign dst
-             = case n of
-                 CmmLit (CmmInt i _) | Just imm <- makeImmediate width sign i
-                    -> return (op dst dst (RIImm imm), nilOL)
-                 _
-                    -> do
-                          (n_reg, n_code) <- getSomeReg n
-                          return  (op dst dst (RIReg n_reg), n_code)
-
-genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr]
- = do let fmt      = intFormat width
-          reg_dst  = getLocalRegReg dst
-          form     = if widthInBits width == 64 then DS else D
-      Amode addr_reg addr_code <- getAmode form addr
-      lbl_end <- getBlockIdNat
-      return $ addr_code `appOL` toOL [ HWSYNC
-                                      , LD fmt reg_dst addr_reg
-                                      , CMP fmt reg_dst (RIReg reg_dst)
-                                      , BCC NE lbl_end (Just False)
-                                      , BCC ALWAYS lbl_end Nothing
-                            -- See Note [Seemingly useless cmp and bne]
-                                      , NEWBLOCK lbl_end
-                                      , ISYNC
-                                      ]
-
--- Note [Seemingly useless cmp and bne]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- In Power ISA, Book II, Section 4.4.1, Instruction Synchronize Instruction
--- the second paragraph says that isync may complete before storage accesses
--- "associated" with a preceding instruction have been performed. The cmp
--- operation and the following bne introduce a data and control dependency
--- on the load instruction (See also Power ISA, Book II, Appendix B.2.3, Safe
--- Fetch).
--- This is also what gcc does.
-
-
-genCCall (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do
-    code <- assignMem_IntCode (intFormat width) addr val
-    return $ unitOL HWSYNC `appOL` code
-
-genCCall (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new]
-  | width == W32 || width == W64
-  = do
-      (old_reg, old_code) <- getSomeReg old
-      (new_reg, new_code) <- getSomeReg new
-      (addr_reg, addr_code) <- getSomeReg addr
-      lbl_retry <- getBlockIdNat
-      lbl_eq    <- getBlockIdNat
-      lbl_end   <- getBlockIdNat
-      let reg_dst   = getLocalRegReg dst
-          code      = toOL
-                      [ HWSYNC
-                      , BCC ALWAYS lbl_retry Nothing
-                      , NEWBLOCK lbl_retry
-                      , LDR format reg_dst (AddrRegReg r0 addr_reg)
-                      , CMP format reg_dst (RIReg old_reg)
-                      , BCC NE lbl_end Nothing
-                      , BCC ALWAYS lbl_eq Nothing
-                      , NEWBLOCK lbl_eq
-                      , STC format new_reg (AddrRegReg r0 addr_reg)
-                      , BCC NE lbl_retry Nothing
-                      , BCC ALWAYS lbl_end Nothing
-                      , NEWBLOCK lbl_end
-                      , ISYNC
-                      ]
-      return $ addr_code `appOL` new_code `appOL` old_code `appOL` code
-  where
-    format = intFormat width
-
-
-genCCall (PrimTarget (MO_Clz width)) [dst] [src]
- = do platform <- getPlatform
-      let reg_dst = getLocalRegReg dst
-      if target32Bit platform && width == W64
-        then do
-          RegCode64 code vr_hi vr_lo <- iselExpr64 src
-          lbl1 <- getBlockIdNat
-          lbl2 <- getBlockIdNat
-          lbl3 <- getBlockIdNat
-          let cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0))
-                           , BCC NE lbl2 Nothing
-                           , BCC ALWAYS lbl1 Nothing
-
-                           , NEWBLOCK lbl1
-                           , CNTLZ II32 reg_dst vr_lo
-                           , ADD reg_dst reg_dst (RIImm (ImmInt 32))
-                           , BCC ALWAYS lbl3 Nothing
-
-                           , NEWBLOCK lbl2
-                           , CNTLZ II32 reg_dst vr_hi
-                           , BCC ALWAYS lbl3 Nothing
-
-                           , NEWBLOCK lbl3
-                           ]
-          return $ code `appOL` cntlz
-        else do
-          let format = if width == W64 then II64 else II32
-          (s_reg, s_code) <- getSomeReg src
-          (pre, reg , post) <-
-            case width of
-              W64 -> return (nilOL, s_reg, nilOL)
-              W32 -> return (nilOL, s_reg, nilOL)
-              W16 -> do
-                reg_tmp <- getNewRegNat format
-                return
-                  ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 65535))
-                  , reg_tmp
-                  , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-16)))
-                  )
-              W8  -> do
-                reg_tmp <- getNewRegNat format
-                return
-                  ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 255))
-                  , reg_tmp
-                  , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-24)))
-                  )
-              _   -> panic "genCall: Clz wrong format"
-          let cntlz = unitOL (CNTLZ format reg_dst reg)
-          return $ s_code `appOL` pre `appOL` cntlz `appOL` post
-
-genCCall (PrimTarget (MO_Ctz width)) [dst] [src]
- = do platform <- getPlatform
-      let reg_dst = getLocalRegReg dst
-      if target32Bit platform && width == W64
-        then do
-          let format = II32
-          RegCode64 code vr_hi vr_lo <- iselExpr64 src
-          lbl1 <- getBlockIdNat
-          lbl2 <- getBlockIdNat
-          lbl3 <- getBlockIdNat
-          x' <- getNewRegNat format
-          x'' <- getNewRegNat format
-          r' <- getNewRegNat format
-          cnttzlo <- cnttz format reg_dst vr_lo
-          let cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0))
-                             , BCC NE lbl2 Nothing
-                             , BCC ALWAYS lbl1 Nothing
-
-                             , NEWBLOCK lbl1
-                             , ADD x' vr_hi (RIImm (ImmInt (-1)))
-                             , ANDC x'' x' vr_hi
-                             , CNTLZ format r' x''
-                               -- 32 + (32 - clz(x''))
-                             , SUBFC reg_dst r' (RIImm (ImmInt 64))
-                             , BCC ALWAYS lbl3 Nothing
-
-                             , NEWBLOCK lbl2
-                             ]
-                        `appOL` cnttzlo `appOL`
-                        toOL [ BCC ALWAYS lbl3 Nothing
-
-                             , NEWBLOCK lbl3
-                             ]
-          return $ code `appOL` cnttz64
-        else do
-          let format = if width == W64 then II64 else II32
-          (s_reg, s_code) <- getSomeReg src
-          (reg_ctz, pre_code) <-
-            case width of
-              W64 -> return (s_reg, nilOL)
-              W32 -> return (s_reg, nilOL)
-              W16 -> do
-                reg_tmp <- getNewRegNat format
-                return (reg_tmp, unitOL $ ORIS reg_tmp s_reg (ImmInt 1))
-              W8  -> do
-                reg_tmp <- getNewRegNat format
-                return (reg_tmp, unitOL $ OR reg_tmp s_reg (RIImm (ImmInt 256)))
-              _   -> panic "genCall: Ctz wrong format"
-          ctz_code <- cnttz format reg_dst reg_ctz
-          return $ s_code `appOL` pre_code `appOL` ctz_code
-        where
-          -- cnttz(x) = sizeof(x) - cntlz(~x & (x - 1))
-          -- see Henry S. Warren, Hacker's Delight, p 107
-          cnttz format dst src = do
-            let format_bits = 8 * formatInBytes format
-            x' <- getNewRegNat format
-            x'' <- getNewRegNat format
-            r' <- getNewRegNat format
-            return $ toOL [ ADD x' src (RIImm (ImmInt (-1)))
-                          , ANDC x'' x' src
-                          , CNTLZ format r' x''
-                          , SUBFC dst r' (RIImm (ImmInt (format_bits)))
-                          ]
-
-genCCall target dest_regs argsAndHints
- = do platform <- getPlatform
-      case target of
-        PrimTarget (MO_S_QuotRem  width) -> divOp1 True  width
-                                                   dest_regs argsAndHints
-        PrimTarget (MO_U_QuotRem  width) -> divOp1 False width
-                                                   dest_regs argsAndHints
-        PrimTarget (MO_U_QuotRem2 width) -> divOp2 width dest_regs
-                                                   argsAndHints
-        PrimTarget (MO_U_Mul2 width) -> multOp2 width dest_regs
-                                                argsAndHints
-        PrimTarget (MO_Add2 _) -> add2Op dest_regs argsAndHints
-        PrimTarget (MO_AddWordC _) -> addcOp dest_regs argsAndHints
-        PrimTarget (MO_SubWordC _) -> subcOp dest_regs argsAndHints
-        PrimTarget (MO_AddIntC width) -> addSubCOp ADDO width
-                                                   dest_regs argsAndHints
-        PrimTarget (MO_SubIntC width) -> addSubCOp SUBFO width
-                                                   dest_regs argsAndHints
-        PrimTarget MO_F64_Fabs -> fabs dest_regs argsAndHints
-        PrimTarget MO_F32_Fabs -> fabs dest_regs argsAndHints
-        _ -> do config <- getConfig
-                genCCall' config (platformToGCP platform)
-                       target dest_regs argsAndHints
-        where divOp1 signed width [res_q, res_r] [arg_x, arg_y]
-                = do let reg_q = getLocalRegReg res_q
-                         reg_r = getLocalRegReg res_r
-                     remainderCode width signed reg_q arg_x arg_y
-                       <*> pure reg_r
-
-              divOp1 _ _ _ _
-                = panic "genCCall: Wrong number of arguments for divOp1"
-              divOp2 width [res_q, res_r]
-                                    [arg_x_high, arg_x_low, arg_y]
-                = do let reg_q = getLocalRegReg res_q
-                         reg_r = getLocalRegReg res_r
-                         fmt   = intFormat width
-                         half  = 4 * (formatInBytes fmt)
-                     (xh_reg, xh_code) <- getSomeReg arg_x_high
-                     (xl_reg, xl_code) <- getSomeReg arg_x_low
-                     (y_reg, y_code) <- getSomeReg arg_y
-                     s <- getNewRegNat fmt
-                     b <- getNewRegNat fmt
-                     v <- getNewRegNat fmt
-                     vn1 <- getNewRegNat fmt
-                     vn0 <- getNewRegNat fmt
-                     un32 <- getNewRegNat fmt
-                     tmp  <- getNewRegNat fmt
-                     un10 <- getNewRegNat fmt
-                     un1 <- getNewRegNat fmt
-                     un0 <- getNewRegNat fmt
-                     q1 <- getNewRegNat fmt
-                     rhat <- getNewRegNat fmt
-                     tmp1 <- getNewRegNat fmt
-                     q0 <- getNewRegNat fmt
-                     un21 <- getNewRegNat fmt
-                     again1 <- getBlockIdNat
-                     no1 <- getBlockIdNat
-                     then1 <- getBlockIdNat
-                     endif1 <- getBlockIdNat
-                     again2 <- getBlockIdNat
-                     no2 <- getBlockIdNat
-                     then2 <- getBlockIdNat
-                     endif2 <- getBlockIdNat
-                     return $ y_code `appOL` xl_code `appOL` xh_code `appOL`
-                              -- see Hacker's Delight p 196 Figure 9-3
-                              toOL [ -- b = 2 ^ (bits_in_word / 2)
-                                     LI b (ImmInt 1)
-                                   , SL fmt b b (RIImm (ImmInt half))
-                                     -- s = clz(y)
-                                   , CNTLZ fmt s y_reg
-                                     -- v = y << s
-                                   , SL fmt v y_reg (RIReg s)
-                                     -- vn1 = upper half of v
-                                   , SR fmt vn1 v (RIImm (ImmInt half))
-                                     -- vn0 = lower half of v
-                                   , CLRLI fmt vn0 v half
-                                     -- un32 = (u1 << s)
-                                     --      | (u0 >> (bits_in_word - s))
-                                   , SL fmt un32 xh_reg (RIReg s)
-                                   , SUBFC tmp s
-                                        (RIImm (ImmInt (8 * formatInBytes fmt)))
-                                   , SR fmt tmp xl_reg (RIReg tmp)
-                                   , OR un32 un32 (RIReg tmp)
-                                     -- un10 = u0 << s
-                                   , SL fmt un10 xl_reg (RIReg s)
-                                     -- un1 = upper half of un10
-                                   , SR fmt un1 un10 (RIImm (ImmInt half))
-                                     -- un0 = lower half of un10
-                                   , CLRLI fmt un0 un10 half
-                                     -- q1 = un32/vn1
-                                   , DIV fmt False q1 un32 vn1
-                                     -- rhat = un32 - q1*vn1
-                                   , MULL fmt tmp q1 (RIReg vn1)
-                                   , SUBF rhat tmp un32
-                                   , BCC ALWAYS again1 Nothing
-
-                                   , NEWBLOCK again1
-                                     -- if (q1 >= b || q1*vn0 > b*rhat + un1)
-                                   , CMPL fmt q1 (RIReg b)
-                                   , BCC GEU then1 Nothing
-                                   , BCC ALWAYS no1 Nothing
-
-                                   , NEWBLOCK no1
-                                   , MULL fmt tmp q1 (RIReg vn0)
-                                   , SL fmt tmp1 rhat (RIImm (ImmInt half))
-                                   , ADD tmp1 tmp1 (RIReg un1)
-                                   , CMPL fmt tmp (RIReg tmp1)
-                                   , BCC LEU endif1 Nothing
-                                   , BCC ALWAYS then1 Nothing
-
-                                   , NEWBLOCK then1
-                                     -- q1 = q1 - 1
-                                   , ADD q1 q1 (RIImm (ImmInt (-1)))
-                                     -- rhat = rhat + vn1
-                                   , ADD rhat rhat (RIReg vn1)
-                                     -- if (rhat < b) goto again1
-                                   , CMPL fmt rhat (RIReg b)
-                                   , BCC LTT again1 Nothing
-                                   , BCC ALWAYS endif1 Nothing
-
-                                   , NEWBLOCK endif1
-                                     -- un21 = un32*b + un1 - q1*v
-                                   , SL fmt un21 un32 (RIImm (ImmInt half))
-                                   , ADD un21 un21 (RIReg un1)
-                                   , MULL fmt tmp q1 (RIReg v)
-                                   , SUBF un21 tmp un21
-                                     -- compute second quotient digit
-                                     -- q0 = un21/vn1
-                                   , DIV fmt False q0 un21 vn1
-                                     -- rhat = un21- q0*vn1
-                                   , MULL fmt tmp q0 (RIReg vn1)
-                                   , SUBF rhat tmp un21
-                                   , BCC ALWAYS again2 Nothing
-
-                                   , NEWBLOCK again2
-                                     -- if (q0>b || q0*vn0 > b*rhat + un0)
-                                   , CMPL fmt q0 (RIReg b)
-                                   , BCC GEU then2 Nothing
-                                   , BCC ALWAYS no2 Nothing
-
-                                   , NEWBLOCK no2
-                                   , MULL fmt tmp q0 (RIReg vn0)
-                                   , SL fmt tmp1 rhat (RIImm (ImmInt half))
-                                   , ADD tmp1 tmp1 (RIReg un0)
-                                   , CMPL fmt tmp (RIReg tmp1)
-                                   , BCC LEU endif2 Nothing
-                                   , BCC ALWAYS then2 Nothing
-
-                                   , NEWBLOCK then2
-                                     -- q0 = q0 - 1
-                                   , ADD q0 q0 (RIImm (ImmInt (-1)))
-                                     -- rhat = rhat + vn1
-                                   , ADD rhat rhat (RIReg vn1)
-                                     -- if (rhat<b) goto again2
-                                   , CMPL fmt rhat (RIReg b)
-                                   , BCC LTT again2 Nothing
-                                   , BCC ALWAYS endif2 Nothing
-
-                                   , NEWBLOCK endif2
-                                     -- compute remainder
-                                     -- r = (un21*b + un0 - q0*v) >> s
-                                   , SL fmt reg_r un21 (RIImm (ImmInt half))
-                                   , ADD reg_r reg_r (RIReg un0)
-                                   , MULL fmt tmp q0 (RIReg v)
-                                   , SUBF reg_r tmp reg_r
-                                   , SR fmt reg_r reg_r (RIReg s)
-                                     -- compute quotient
-                                     -- q = q1*b + q0
-                                   , SL fmt reg_q q1 (RIImm (ImmInt half))
-                                   , ADD reg_q reg_q (RIReg q0)
-                                   ]
-              divOp2 _ _ _
-                = panic "genCCall: Wrong number of arguments for divOp2"
-              multOp2 width [res_h, res_l] [arg_x, arg_y]
-                = do let reg_h = getLocalRegReg res_h
-                         reg_l = getLocalRegReg res_l
-                         fmt = intFormat width
-                     (x_reg, x_code) <- getSomeReg arg_x
-                     (y_reg, y_code) <- getSomeReg arg_y
-                     return $ y_code `appOL` x_code
-                            `appOL` toOL [ MULL fmt reg_l x_reg (RIReg y_reg)
-                                         , MULHU fmt reg_h x_reg y_reg
-                                         ]
-              multOp2 _ _ _
-                = panic "genCall: Wrong number of arguments for multOp2"
-              add2Op [res_h, res_l] [arg_x, arg_y]
-                = do let reg_h = getLocalRegReg res_h
-                         reg_l = getLocalRegReg res_l
-                     (x_reg, x_code) <- getSomeReg arg_x
-                     (y_reg, y_code) <- getSomeReg arg_y
-                     return $ y_code `appOL` x_code
-                            `appOL` toOL [ LI reg_h (ImmInt 0)
-                                         , ADDC reg_l x_reg y_reg
-                                         , ADDZE reg_h reg_h
-                                         ]
-              add2Op _ _
-                = panic "genCCall: Wrong number of arguments/results for add2"
-
-              addcOp [res_r, res_c] [arg_x, arg_y]
-                = add2Op [res_c {-hi-}, res_r {-lo-}] [arg_x, arg_y]
-              addcOp _ _
-                = panic "genCCall: Wrong number of arguments/results for addc"
-
-              -- PowerPC subfc sets the carry for rT = ~(rA) + rB + 1,
-              -- which is 0 for borrow and 1 otherwise. We need 1 and 0
-              -- so xor with 1.
-              subcOp [res_r, res_c] [arg_x, arg_y]
-                = do let reg_r = getLocalRegReg res_r
-                         reg_c = getLocalRegReg res_c
-                     (x_reg, x_code) <- getSomeReg arg_x
-                     (y_reg, y_code) <- getSomeReg arg_y
-                     return $ y_code `appOL` x_code
-                            `appOL` toOL [ LI reg_c (ImmInt 0)
-                                         , SUBFC reg_r y_reg (RIReg x_reg)
-                                         , ADDZE reg_c reg_c
-                                         , XOR reg_c reg_c (RIImm (ImmInt 1))
-                                         ]
-              subcOp _ _
-                = panic "genCCall: Wrong number of arguments/results for subc"
-              addSubCOp instr width [res_r, res_c] [arg_x, arg_y]
-                = do let reg_r = getLocalRegReg res_r
-                         reg_c = getLocalRegReg res_c
-                     (x_reg, x_code) <- getSomeReg arg_x
-                     (y_reg, y_code) <- getSomeReg arg_y
-                     return $ y_code `appOL` x_code
-                            `appOL` toOL [ instr reg_r y_reg x_reg,
-                                           -- SUBFO argument order reversed!
-                                           MFOV (intFormat width) reg_c
-                                         ]
-              addSubCOp _ _ _ _
-                = panic "genCall: Wrong number of arguments/results for addC"
-              fabs [res] [arg]
-                = do let res_r = getLocalRegReg res
-                     (arg_reg, arg_code) <- getSomeReg arg
-                     return $ arg_code `snocOL` FABS res_r arg_reg
-              fabs _ _
-                = panic "genCall: Wrong number of arguments/results for fabs"
-
--- TODO: replace 'Int' by an enum such as 'PPC_64ABI'
-data GenCCallPlatform = GCP32ELF | GCP64ELF !Int | GCPAIX
-
-platformToGCP :: Platform -> GenCCallPlatform
-platformToGCP platform
-  = case platformOS platform of
-      OSAIX    -> GCPAIX
-      _ -> case platformArch platform of
-             ArchPPC           -> GCP32ELF
-             ArchPPC_64 ELF_V1 -> GCP64ELF 1
-             ArchPPC_64 ELF_V2 -> GCP64ELF 2
-             _ -> panic "platformToGCP: Not PowerPC"
-
-
-genCCall'
-    :: NCGConfig
-    -> GenCCallPlatform
-    -> ForeignTarget            -- function to call
-    -> [CmmFormal]        -- where to put the result
-    -> [CmmActual]        -- arguments (of mixed type)
-    -> NatM InstrBlock
-
-{-
-    PowerPC Linux uses the System V Release 4 Calling Convention
-    for PowerPC. It is described in the
-    "System V Application Binary Interface PowerPC Processor Supplement".
-
-    PowerPC 64 Linux uses the System V Release 4 Calling Convention for
-    64-bit PowerPC. It is specified in
-    "64-bit PowerPC ELF Application Binary Interface Supplement 1.9"
-    (PPC64 ELF v1.9).
-
-    PowerPC 64 Linux in little endian mode uses the "Power Architecture 64-Bit
-    ELF V2 ABI Specification -- OpenPOWER ABI for Linux Supplement"
-    (PPC64 ELF v2).
-
-    AIX follows the "PowerOpen ABI: Application Binary Interface Big-Endian
-    32-Bit Hardware Implementation"
-
-    All four conventions are similar:
-    Parameters may be passed in general-purpose registers starting at r3, in
-    floating point registers starting at f1, or on the stack.
-
-    But there are substantial differences:
-    * The number of registers used for parameter passing and the exact set of
-      nonvolatile registers differs (see MachRegs.hs).
-    * On AIX and 64-bit ELF, stack space is always reserved for parameters,
-      even if they are passed in registers. The called routine may choose to
-      save parameters from registers to the corresponding space on the stack.
-    * On AIX and 64-bit ELF, a corresponding amount of GPRs is skipped when
-      a floating point parameter is passed in an FPR.
-    * SysV insists on either passing I64 arguments on the stack, or in two GPRs,
-      starting with an odd-numbered GPR. It may skip a GPR to achieve this.
-      AIX just treats an I64 likt two separate I32s (high word first).
-    * I64 and FF64 arguments are 8-byte aligned on the stack for SysV, but only
-      4-byte aligned like everything else on AIX.
-    * The SysV spec claims that FF32 is represented as FF64 on the stack. GCC on
-      PowerPC Linux does not agree, so neither do we.
-
-    According to all conventions, the parameter area should be part of the
-    caller's stack frame, allocated in the caller's prologue code (large enough
-    to hold the parameter lists for all called routines). The NCG already
-    uses the stack for register spilling, leaving 64 bytes free at the top.
-    If we need a larger parameter area than that, we increase the size
-    of the stack frame just before ccalling.
--}
-
-
-genCCall' config gcp target dest_regs args
-  = do
-        (finalStack,passArgumentsCode,usedRegs) <- passArguments
-                                                   (zip3 args argReps argHints)
-                                                   allArgRegs
-                                                   (allFPArgRegs platform)
-                                                   initialStackOffset
-                                                   nilOL []
-
-        (labelOrExpr, reduceToFF32) <- case target of
-            ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do
-                uses_pic_base_implicitly
-                return (Left lbl, False)
-            ForeignTarget expr _ -> do
-                uses_pic_base_implicitly
-                return (Right expr, False)
-            PrimTarget mop -> outOfLineMachOp mop
-
-        let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
-            codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32
-
-        case labelOrExpr of
-            Left lbl -> -- the linker does all the work for us
-                return (         codeBefore
-                        `snocOL` BL lbl usedRegs
-                        `appOL`  maybeNOP -- some ABI require a NOP after BL
-                        `appOL`  codeAfter)
-            Right dyn -> do -- implement call through function pointer
-                (dynReg, dynCode) <- getSomeReg dyn
-                case gcp of
-                     GCP64ELF 1      -> return ( dynCode
-                       `appOL`  codeBefore
-                       `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 40))
-                       `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 0))
-                       `snocOL` LD II64 toc (AddrRegImm dynReg (ImmInt 8))
-                       `snocOL` MTCTR r11
-                       `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 16))
-                       `snocOL` BCTRL usedRegs
-                       `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 40))
-                       `appOL`  codeAfter)
-                     GCP64ELF 2      -> return ( dynCode
-                       `appOL`  codeBefore
-                       `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 24))
-                       `snocOL` MR r12 dynReg
-                       `snocOL` MTCTR r12
-                       `snocOL` BCTRL usedRegs
-                       `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 24))
-                       `appOL`  codeAfter)
-                     GCPAIX          -> return ( dynCode
-                       -- AIX/XCOFF follows the PowerOPEN ABI
-                       -- which is quite similar to LinuxPPC64/ELFv1
-                       `appOL`  codeBefore
-                       `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 20))
-                       `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 0))
-                       `snocOL` LD II32 toc (AddrRegImm dynReg (ImmInt 4))
-                       `snocOL` MTCTR r11
-                       `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 8))
-                       `snocOL` BCTRL usedRegs
-                       `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 20))
-                       `appOL`  codeAfter)
-                     _               -> return ( dynCode
-                       `snocOL` MTCTR dynReg
-                       `appOL`  codeBefore
-                       `snocOL` BCTRL usedRegs
-                       `appOL`  codeAfter)
-    where
-        platform = ncgPlatform config
-
-        uses_pic_base_implicitly =
-            -- See Note [implicit register in PPC PIC code]
-            -- on why we claim to use PIC register here
-            when (ncgPIC config && target32Bit platform) $ do
-                _ <- getPicBaseNat $ archWordFormat True
-                return ()
-
-        initialStackOffset = case gcp of
-                             GCPAIX     -> 24
-                             GCP32ELF   -> 8
-                             GCP64ELF 1 -> 48
-                             GCP64ELF 2 -> 32
-                             _ -> panic "genCall': unknown calling convention"
-            -- size of linkage area + size of arguments, in bytes
-        stackDelta finalStack = case gcp of
-                                GCPAIX ->
-                                    roundTo 16 $ (24 +) $ max 32 $ sum $
-                                    map (widthInBytes . typeWidth) argReps
-                                GCP32ELF -> roundTo 16 finalStack
-                                GCP64ELF 1 ->
-                                    roundTo 16 $ (48 +) $ max 64 $ sum $
-                                    map (roundTo 8 . widthInBytes . typeWidth)
-                                        argReps
-                                GCP64ELF 2 ->
-                                    roundTo 16 $ (32 +) $ max 64 $ sum $
-                                    map (roundTo 8 . widthInBytes . typeWidth)
-                                        argReps
-                                _ -> panic "genCall': unknown calling conv."
-
-        argReps = map (cmmExprType platform) args
-        (argHints, _) = foreignTargetHints target
-
-        roundTo a x | x `mod` a == 0 = x
-                    | otherwise = x + a - (x `mod` a)
-
-        spFormat = if target32Bit platform then II32 else II64
-
-        -- TODO: Do not create a new stack frame if delta is too large.
-        move_sp_down finalStack
-               | delta > stackFrameHeaderSize platform =
-                        toOL [STU spFormat sp (AddrRegImm sp (ImmInt (-delta))),
-                              DELTA (-delta)]
-               | otherwise = nilOL
-               where delta = stackDelta finalStack
-        move_sp_up finalStack
-               | delta > stackFrameHeaderSize platform =
-                        toOL [ADD sp sp (RIImm (ImmInt delta)),
-                              DELTA 0]
-               | otherwise = nilOL
-               where delta = stackDelta finalStack
-
-        -- A NOP instruction is required after a call (bl instruction)
-        -- on AIX and 64-Bit Linux.
-        -- If the call is to a function with a different TOC (r2) the
-        -- link editor replaces the NOP instruction with a load of the TOC
-        -- from the stack to restore the TOC.
-        maybeNOP = case gcp of
-           GCP32ELF        -> nilOL
-           -- See Section 3.9.4 of OpenPower ABI
-           GCPAIX          -> unitOL NOP
-           -- See Section 3.5.11 of PPC64 ELF v1.9
-           GCP64ELF 1      -> unitOL NOP
-           -- See Section 2.3.6 of PPC64 ELF v2
-           GCP64ELF 2      -> unitOL NOP
-           _               -> panic "maybeNOP: Unknown PowerPC 64-bit ABI"
-
-        passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed)
-        passArguments ((arg,arg_ty,_):args) gprs fprs stackOffset
-               accumCode accumUsed | isWord64 arg_ty
-                                     && target32Bit (ncgPlatform config) =
-            do
-                RegCode64 code vr_hi vr_lo <- iselExpr64 arg
-
-                case gcp of
-                    GCPAIX ->
-                        do let storeWord vr (gpr:_) _ = MR gpr vr
-                               storeWord vr [] offset
-                                   = ST II32 vr (AddrRegImm sp (ImmInt offset))
-                           passArguments args
-                                         (drop 2 gprs)
-                                         fprs
-                                         (stackOffset+8)
-                                         (accumCode `appOL` code
-                                               `snocOL` storeWord vr_hi gprs stackOffset
-                                               `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
-                                         ((take 2 gprs) ++ accumUsed)
-                    GCP32ELF ->
-                        do let stackOffset' = roundTo 8 stackOffset
-                               stackCode = accumCode `appOL` code
-                                   `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset'))
-                                   `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4)))
-                               regCode hireg loreg =
-                                   accumCode `appOL` code
-                                       `snocOL` MR hireg vr_hi
-                                       `snocOL` MR loreg vr_lo
-
-                           case gprs of
-                               hireg : loreg : regs | even (length gprs) ->
-                                   passArguments args regs fprs stackOffset
-                                                 (regCode hireg loreg) (hireg : loreg : accumUsed)
-                               _skipped : hireg : loreg : regs ->
-                                   passArguments args regs fprs stackOffset
-                                                 (regCode hireg loreg) (hireg : loreg : accumUsed)
-                               _ -> -- only one or no regs left
-                                   passArguments args [] fprs (stackOffset'+8)
-                                                 stackCode accumUsed
-                    GCP64ELF _ -> panic "passArguments: 32 bit code"
-
-        passArguments ((arg,rep,hint):args) gprs fprs stackOffset accumCode accumUsed
-            | reg : _ <- regs = do
-                register <- getRegister arg_pro
-                let code = case register of
-                            Fixed _ freg fcode -> fcode `snocOL` MR reg freg
-                            Any _ acode -> acode reg
-                    stackOffsetRes = case gcp of
-                                     -- The PowerOpen ABI requires that we
-                                     -- reserve stack slots for register
-                                     -- parameters
-                                     GCPAIX    -> stackOffset + stackBytes
-                                     -- ... the SysV ABI 32-bit doesn't.
-                                     GCP32ELF -> stackOffset
-                                     -- ... but SysV ABI 64-bit does.
-                                     GCP64ELF _ -> stackOffset + stackBytes
-                passArguments args
-                              (drop nGprs gprs)
-                              (drop nFprs fprs)
-                              stackOffsetRes
-                              (accumCode `appOL` code)
-                              (reg : accumUsed)
-            | otherwise = do
-                (vr, code) <- getSomeReg arg_pro
-                passArguments args
-                              (drop nGprs gprs)
-                              (drop nFprs fprs)
-                              (stackOffset' + stackBytes)
-                              (accumCode `appOL` code
-                                         `snocOL` ST format_pro vr stackSlot)
-                              accumUsed
-            where
-                arg_pro
-                   | isBitsType rep = CmmMachOp (conv_op (typeWidth rep) (wordWidth platform)) [arg]
-                   | otherwise      = arg
-                format_pro
-                   | isBitsType rep = intFormat (wordWidth platform)
-                   | otherwise      = cmmTypeFormat rep
-                conv_op = case hint of
-                            SignedHint -> MO_SS_Conv
-                            _          -> MO_UU_Conv
-
-                stackOffset' = case gcp of
-                               GCPAIX ->
-                                   -- The 32bit PowerOPEN ABI is happy with
-                                   -- 32bit-alignment ...
-                                   stackOffset
-                               GCP32ELF
-                                   -- ... the SysV ABI requires 8-byte
-                                   -- alignment for doubles.
-                                | isFloatType rep && typeWidth rep == W64 ->
-                                   roundTo 8 stackOffset
-                                | otherwise ->
-                                   stackOffset
-                               GCP64ELF _ ->
-                                   -- Everything on the stack is mapped to
-                                   -- 8-byte aligned doublewords
-                                   stackOffset
-                stackOffset''
-                     | isFloatType rep && typeWidth rep == W32 =
-                         case gcp of
-                         -- The ELF v1 ABI Section 3.2.3 requires:
-                         -- "Single precision floating point values
-                         -- are mapped to the second word in a single
-                         -- doubleword"
-                         GCP64ELF 1      -> stackOffset' + 4
-                         _               -> stackOffset'
-                     | otherwise = stackOffset'
-
-                stackSlot = AddrRegImm sp (ImmInt stackOffset'')
-                (nGprs, nFprs, stackBytes, regs)
-                    = case gcp of
-                      GCPAIX ->
-                          case cmmTypeFormat rep of
-                          II8  -> (1, 0, 4, gprs)
-                          II16 -> (1, 0, 4, gprs)
-                          II32 -> (1, 0, 4, gprs)
-                          -- The PowerOpen ABI requires that we skip a
-                          -- corresponding number of GPRs when we use
-                          -- the FPRs.
-                          --
-                          -- E.g. for a `double` two GPRs are skipped,
-                          -- whereas for a `float` one GPR is skipped
-                          -- when parameters are assigned to
-                          -- registers.
-                          --
-                          -- The PowerOpen ABI specification can be found at
-                          -- ftp://www.sourceware.org/pub/binutils/ppc-docs/ppc-poweropen/
-                          FF32 -> (1, 1, 4, fprs)
-                          FF64 -> (2, 1, 8, fprs)
-                          II64 -> panic "genCCall' passArguments II64"
-
-                      GCP32ELF ->
-                          case cmmTypeFormat rep of
-                          II8  -> (1, 0, 4, gprs)
-                          II16 -> (1, 0, 4, gprs)
-                          II32 -> (1, 0, 4, gprs)
-                          -- ... the SysV ABI doesn't.
-                          FF32 -> (0, 1, 4, fprs)
-                          FF64 -> (0, 1, 8, fprs)
-                          II64 -> panic "genCCall' passArguments II64"
-                      GCP64ELF _ ->
-                          case cmmTypeFormat rep of
-                          II8  -> (1, 0, 8, gprs)
-                          II16 -> (1, 0, 8, gprs)
-                          II32 -> (1, 0, 8, gprs)
-                          II64 -> (1, 0, 8, gprs)
-                          -- The ELFv1 ABI requires that we skip a
-                          -- corresponding number of GPRs when we use
-                          -- the FPRs.
-                          FF32 -> (1, 1, 8, fprs)
-                          FF64 -> (1, 1, 8, fprs)
-
-        moveResult reduceToFF32 =
-            case dest_regs of
-                [] -> nilOL
-                [dest]
-                    | reduceToFF32 && isFloat32 rep   -> unitOL (FRSP r_dest f1)
-                    | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1)
-                    | isWord64 rep && target32Bit platform
-                       -> toOL [MR (getHiVRegFromLo r_dest) r3,
-                                MR r_dest r4]
-                    | otherwise -> unitOL (MR r_dest r3)
-                    where rep = cmmRegType platform (CmmLocal dest)
-                          r_dest = getLocalRegReg dest
-                _ -> panic "genCCall' moveResult: Bad dest_regs"
-
-        outOfLineMachOp mop =
-            do
-                mopExpr <- cmmMakeDynamicReference config CallReference $
-                              mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction
-                let mopLabelOrExpr = case mopExpr of
-                        CmmLit (CmmLabel lbl) -> Left lbl
-                        _ -> Right mopExpr
-                return (mopLabelOrExpr, reduce)
-            where
-                (functionName, reduce) = case mop of
-                    MO_F32_Exp   -> (fsLit "exp", True)
-                    MO_F32_ExpM1 -> (fsLit "expm1", True)
-                    MO_F32_Log   -> (fsLit "log", True)
-                    MO_F32_Log1P -> (fsLit "log1p", True)
-                    MO_F32_Sqrt  -> (fsLit "sqrt", True)
-                    MO_F32_Fabs  -> unsupported
-
-                    MO_F32_Sin   -> (fsLit "sin", True)
-                    MO_F32_Cos   -> (fsLit "cos", True)
-                    MO_F32_Tan   -> (fsLit "tan", True)
-
-                    MO_F32_Asin  -> (fsLit "asin", True)
-                    MO_F32_Acos  -> (fsLit "acos", True)
-                    MO_F32_Atan  -> (fsLit "atan", True)
-
-                    MO_F32_Sinh  -> (fsLit "sinh", True)
-                    MO_F32_Cosh  -> (fsLit "cosh", True)
-                    MO_F32_Tanh  -> (fsLit "tanh", True)
-                    MO_F32_Pwr   -> (fsLit "pow", True)
-
-                    MO_F32_Asinh -> (fsLit "asinh", True)
-                    MO_F32_Acosh -> (fsLit "acosh", True)
-                    MO_F32_Atanh -> (fsLit "atanh", True)
-
-                    MO_F64_Exp   -> (fsLit "exp", False)
-                    MO_F64_ExpM1 -> (fsLit "expm1", False)
-                    MO_F64_Log   -> (fsLit "log", False)
-                    MO_F64_Log1P -> (fsLit "log1p", False)
-                    MO_F64_Sqrt  -> (fsLit "sqrt", False)
-                    MO_F64_Fabs  -> unsupported
-
-                    MO_F64_Sin   -> (fsLit "sin", False)
-                    MO_F64_Cos   -> (fsLit "cos", False)
-                    MO_F64_Tan   -> (fsLit "tan", False)
-
-                    MO_F64_Asin  -> (fsLit "asin", False)
-                    MO_F64_Acos  -> (fsLit "acos", False)
-                    MO_F64_Atan  -> (fsLit "atan", False)
-
-                    MO_F64_Sinh  -> (fsLit "sinh", False)
-                    MO_F64_Cosh  -> (fsLit "cosh", False)
-                    MO_F64_Tanh  -> (fsLit "tanh", False)
-                    MO_F64_Pwr   -> (fsLit "pow", False)
-
-                    MO_F64_Asinh -> (fsLit "asinh", False)
-                    MO_F64_Acosh -> (fsLit "acosh", False)
-                    MO_F64_Atanh -> (fsLit "atanh", False)
-
-                    MO_I64_ToI   -> (fsLit "hs_int64ToInt", False)
-                    MO_I64_FromI -> (fsLit "hs_intToInt64", False)
-                    MO_W64_ToW   -> (fsLit "hs_word64ToWord", False)
-                    MO_W64_FromW -> (fsLit "hs_wordToWord64", False)
-
-                    MO_x64_Neg   -> (fsLit "hs_neg64", False)
-                    MO_x64_Add   -> (fsLit "hs_add64", False)
-                    MO_x64_Sub   -> (fsLit "hs_sub64", False)
-                    MO_x64_Mul   -> (fsLit "hs_mul64", False)
-                    MO_I64_Quot  -> (fsLit "hs_quotInt64", False)
-                    MO_I64_Rem   -> (fsLit "hs_remInt64", False)
-                    MO_W64_Quot  -> (fsLit "hs_quotWord64", False)
-                    MO_W64_Rem   -> (fsLit "hs_remWord64", False)
-
-                    MO_x64_And   -> (fsLit "hs_and64", False)
-                    MO_x64_Or    -> (fsLit "hs_or64", False)
-                    MO_x64_Xor   -> (fsLit "hs_xor64", False)
-                    MO_x64_Not   -> (fsLit "hs_not64", False)
-                    MO_x64_Shl   -> (fsLit "hs_uncheckedShiftL64", False)
-                    MO_I64_Shr   -> (fsLit "hs_uncheckedIShiftRA64", False)
-                    MO_W64_Shr   -> (fsLit "hs_uncheckedShiftRL64", False)
-
-                    MO_x64_Eq    -> (fsLit "hs_eq64", False)
-                    MO_x64_Ne    -> (fsLit "hs_ne64", False)
-                    MO_I64_Ge    -> (fsLit "hs_geInt64", False)
-                    MO_I64_Gt    -> (fsLit "hs_gtInt64", False)
-                    MO_I64_Le    -> (fsLit "hs_leInt64", False)
-                    MO_I64_Lt    -> (fsLit "hs_ltInt64", False)
-                    MO_W64_Ge    -> (fsLit "hs_geWord64", False)
-                    MO_W64_Gt    -> (fsLit "hs_gtWord64", False)
-                    MO_W64_Le    -> (fsLit "hs_leWord64", False)
-                    MO_W64_Lt    -> (fsLit "hs_ltWord64", False)
-
-                    MO_UF_Conv w -> (word2FloatLabel w, False)
-
-                    MO_Memcpy _  -> (fsLit "memcpy", False)
-                    MO_Memset _  -> (fsLit "memset", False)
-                    MO_Memmove _ -> (fsLit "memmove", False)
-                    MO_Memcmp _  -> (fsLit "memcmp", False)
-
-                    MO_SuspendThread -> (fsLit "suspendThread", False)
-                    MO_ResumeThread  -> (fsLit "resumeThread", False)
-
-                    MO_BSwap w   -> (bSwapLabel w, False)
-                    MO_BRev w    -> (bRevLabel w, False)
-                    MO_PopCnt w  -> (popCntLabel w, False)
-                    MO_Pdep w    -> (pdepLabel w, False)
-                    MO_Pext w    -> (pextLabel w, False)
-                    MO_Clz _     -> unsupported
-                    MO_Ctz _     -> unsupported
-                    MO_AtomicRMW {} -> unsupported
-                    MO_Cmpxchg w -> (cmpxchgLabel w, False)
-                    MO_Xchg w    -> (xchgLabel w, False)
-                    MO_AtomicRead _  -> unsupported
-                    MO_AtomicWrite _ -> unsupported
-
-                    MO_S_Mul2    {}  -> unsupported
-                    MO_S_QuotRem {}  -> unsupported
-                    MO_U_QuotRem {}  -> unsupported
-                    MO_U_QuotRem2 {} -> unsupported
-                    MO_Add2 {}       -> unsupported
-                    MO_AddWordC {}   -> unsupported
-                    MO_SubWordC {}   -> unsupported
-                    MO_AddIntC {}    -> unsupported
-                    MO_SubIntC {}    -> unsupported
-                    MO_U_Mul2 {}     -> unsupported
-                    MO_ReadBarrier   -> unsupported
-                    MO_WriteBarrier  -> unsupported
-                    MO_Touch         -> unsupported
-                    MO_Prefetch_Data _ -> unsupported
-                unsupported = panic ("outOfLineCmmOp: " ++ show mop
-                                  ++ " not supported")
-
--- -----------------------------------------------------------------------------
--- Generating a table-branch
-
-genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock
-genSwitch config expr targets
-  | OSAIX <- platformOS platform
-  = do
-        (reg,e_code) <- getSomeReg indexExpr
-        let fmt = archWordFormat $ target32Bit platform
-            sha = if target32Bit platform then 2 else 3
-        tmp <- getNewRegNat fmt
-        lbl <- getNewLabelNat
-        dynRef <- cmmMakeDynamicReference config DataReference lbl
-        (tableReg,t_code) <- getSomeReg $ dynRef
-        let code = e_code `appOL` t_code `appOL` toOL [
-                            SL fmt tmp reg (RIImm (ImmInt sha)),
-                            LD fmt tmp (AddrRegReg tableReg tmp),
-                            MTCTR tmp,
-                            BCTR ids (Just lbl) []
-                    ]
-        return code
-
-  | (ncgPIC config) || (not $ target32Bit platform)
-  = do
-        (reg,e_code) <- getSomeReg indexExpr
-        let fmt = archWordFormat $ target32Bit platform
-            sha = if target32Bit platform then 2 else 3
-        tmp <- getNewRegNat fmt
-        lbl <- getNewLabelNat
-        dynRef <- cmmMakeDynamicReference config DataReference lbl
-        (tableReg,t_code) <- getSomeReg $ dynRef
-        let code = e_code `appOL` t_code `appOL` toOL [
-                            SL fmt tmp reg (RIImm (ImmInt sha)),
-                            LD fmt tmp (AddrRegReg tableReg tmp),
-                            ADD tmp tmp (RIReg tableReg),
-                            MTCTR tmp,
-                            BCTR ids (Just lbl) []
-                    ]
-        return code
-  | otherwise
-  = do
-        (reg,e_code) <- getSomeReg indexExpr
-        let fmt = archWordFormat $ target32Bit platform
-            sha = if target32Bit platform then 2 else 3
-        tmp <- getNewRegNat fmt
-        lbl <- getNewLabelNat
-        let code = e_code `appOL` toOL [
-                            SL fmt tmp reg (RIImm (ImmInt sha)),
-                            ADDIS tmp tmp (HA (ImmCLbl lbl)),
-                            LD fmt tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
-                            MTCTR tmp,
-                            BCTR ids (Just lbl) []
-                    ]
-        return code
-  where
-    -- See Note [Sub-word subtlety during jump-table indexing] in
-    -- GHC.CmmToAsm.X86.CodeGen for why we must first offset, then widen.
-    indexExpr0 = cmmOffset platform expr offset
-    -- We widen to a native-width register to sanitize the high bits
-    indexExpr = CmmMachOp
-      (MO_UU_Conv expr_w (platformWordWidth platform))
-      [indexExpr0]
-    expr_w = cmmExprWidth platform expr
-    (offset, ids) = switchTargetsToTable targets
-    platform      = ncgPlatform config
-
-generateJumpTableForInstr :: NCGConfig -> Instr
-                          -> Maybe (NatCmmDecl RawCmmStatics Instr)
-generateJumpTableForInstr config (BCTR ids (Just lbl) _) =
-    let jumpTable
-            | (ncgPIC config) || (not $ target32Bit $ ncgPlatform config)
-            = map jumpTableEntryRel ids
-            | otherwise = map (jumpTableEntry config) ids
-                where jumpTableEntryRel Nothing
-                        = CmmStaticLit (CmmInt 0 (ncgWordWidth config))
-                      jumpTableEntryRel (Just blockid)
-                        = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0
-                                         (ncgWordWidth config))
-                            where blockLabel = blockLbl blockid
-    in Just (CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl jumpTable))
-generateJumpTableForInstr _ _ = Nothing
-
--- -----------------------------------------------------------------------------
--- 'condIntReg' and 'condFltReg': condition codes into registers
-
--- Turn those condition codes into integers now (when they appear on
--- the right hand side of an assignment).
-
-
-
-condReg :: NatM CondCode -> NatM Register
-condReg getCond = do
-    CondCode _ cond cond_code <- getCond
-    platform <- getPlatform
-    let
-        code dst = cond_code
-            `appOL` negate_code
-            `appOL` toOL [
-                MFCR dst,
-                RLWINM dst dst (bit + 1) 31 31
-            ]
-
-        negate_code | do_negate = unitOL (CRNOR bit bit bit)
-                    | otherwise = nilOL
-
-        (bit, do_negate) = case cond of
-            LTT -> (0, False)
-            LE  -> (1, True)
-            EQQ -> (2, False)
-            GE  -> (0, True)
-            GTT -> (1, False)
-
-            NE  -> (2, True)
-
-            LU  -> (0, False)
-            LEU -> (1, True)
-            GEU -> (0, True)
-            GU  -> (1, False)
-            _   -> panic "PPC.CodeGen.codeReg: no match"
-
-        format = archWordFormat $ target32Bit platform
-    return (Any format code)
-
-condIntReg :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
-condIntReg cond width x y = condReg (condIntCode cond width x y)
-condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
-condFltReg cond x y = condReg (condFltCode cond x y)
-
-
-
--- -----------------------------------------------------------------------------
--- 'trivial*Code': deal with trivial instructions
-
--- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
--- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
--- Only look for constants on the right hand side, because that's
--- where the generic optimizer will have put them.
-
--- Similarly, for unary instructions, we don't have to worry about
--- matching an StInt as the argument, because genericOpt will already
--- have handled the constant-folding.
-
-
-
-{-
-Wolfgang's PowerPC version of The Rules:
-
-A slightly modified version of The Rules to take advantage of the fact
-that PowerPC instructions work on all registers and don't implicitly
-clobber any fixed registers.
-
-* The only expression for which getRegister returns Fixed is (CmmReg reg).
-
-* If getRegister returns Any, then the code it generates may modify only:
-        (a) fresh temporaries
-        (b) the destination register
-  It may *not* modify global registers, unless the global
-  register happens to be the destination register.
-  It may not clobber any other registers. In fact, only ccalls clobber any
-  fixed registers.
-  Also, it may not modify the counter register (used by genCCall).
-
-  Corollary: If a getRegister for a subexpression returns Fixed, you need
-  not move it to a fresh temporary before evaluating the next subexpression.
-  The Fixed register won't be modified.
-  Therefore, we don't need a counterpart for the x86's getStableReg on PPC.
-
-* SDM's First Rule is valid for PowerPC, too: subexpressions can depend on
-  the value of the destination register.
--}
-
-trivialCode
-        :: Width
-        -> Bool
-        -> (Reg -> Reg -> RI -> Instr)
-        -> CmmExpr
-        -> CmmExpr
-        -> NatM Register
-
-trivialCode rep signed instr x (CmmLit (CmmInt y _))
-    | Just imm <- makeImmediate rep signed y
-    = do
-        (src1, code1) <- getSomeReg x
-        let code dst = code1 `snocOL` instr dst src1 (RIImm imm)
-        return (Any (intFormat rep) code)
-
-trivialCode rep _ instr x y = do
-    (src1, code1) <- getSomeReg x
-    (src2, code2) <- getSomeReg y
-    let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2)
-    return (Any (intFormat rep) code)
-
-shiftMulCode
-        :: Width
-        -> Bool
-        -> (Format-> Reg -> Reg -> RI -> Instr)
-        -> CmmExpr
-        -> CmmExpr
-        -> NatM Register
-shiftMulCode width sign instr x (CmmLit (CmmInt y _))
-    | Just imm <- makeImmediate width sign y
-    = do
-        (src1, code1) <- getSomeReg x
-        let format = intFormat width
-        let ins_fmt = intFormat (max W32 width)
-        let code dst = code1 `snocOL` instr ins_fmt dst src1 (RIImm imm)
-        return (Any format code)
-
-shiftMulCode width _ instr x y = do
-    (src1, code1) <- getSomeReg x
-    (src2, code2) <- getSomeReg y
-    let format = intFormat width
-    let ins_fmt = intFormat (max W32 width)
-    let code dst = code1 `appOL` code2
-                   `snocOL` instr ins_fmt dst src1 (RIReg src2)
-    return (Any format code)
-
-trivialCodeNoImm' :: Format -> (Reg -> Reg -> Reg -> Instr)
-                 -> CmmExpr -> CmmExpr -> NatM Register
-trivialCodeNoImm' format instr x y = do
-    (src1, code1) <- getSomeReg x
-    (src2, code2) <- getSomeReg y
-    let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2
-    return (Any format code)
-
-trivialCodeNoImm :: Format -> (Format -> Reg -> Reg -> Reg -> Instr)
-                 -> CmmExpr -> CmmExpr -> NatM Register
-trivialCodeNoImm format instr x y
-  = trivialCodeNoImm' format (instr format) x y
-
-srCode :: Width -> Bool -> (Format-> Reg -> Reg -> RI -> Instr)
-       -> CmmExpr -> CmmExpr -> NatM Register
-srCode width sgn instr x (CmmLit (CmmInt y _))
-    | Just imm <- makeImmediate width sgn y
-    = do
-        let op_len = max W32 width
-            extend = if sgn then extendSExpr else extendUExpr
-        (src1, code1) <- getSomeReg (extend width op_len x)
-        let code dst = code1 `snocOL`
-                       instr (intFormat op_len) dst src1 (RIImm imm)
-        return (Any (intFormat width) code)
-
-srCode width sgn instr x y = do
-  let op_len = max W32 width
-      extend = if sgn then extendSExpr else extendUExpr
-  (src1, code1) <- getSomeReg (extend width op_len x)
-  (src2, code2) <- getSomeReg (extendUExpr width op_len y)
-  -- Note: Shift amount `y` is unsigned
-  let code dst = code1 `appOL` code2 `snocOL`
-                 instr (intFormat op_len) dst src1 (RIReg src2)
-  return (Any (intFormat width) code)
-
-divCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
-divCode width sgn x y = do
-  let op_len = max W32 width
-      extend = if sgn then extendSExpr else extendUExpr
-  (src1, code1) <- getSomeReg (extend width op_len x)
-  (src2, code2) <- getSomeReg (extend width op_len y)
-  let code dst = code1 `appOL` code2 `snocOL`
-                 DIV (intFormat op_len) sgn dst src1 src2
-  return (Any (intFormat width) code)
-
-
-trivialUCode :: Format
-             -> (Reg -> Reg -> Instr)
-             -> CmmExpr
-             -> NatM Register
-trivialUCode rep instr x = do
-    (src, code) <- getSomeReg x
-    let code' dst = code `snocOL` instr dst src
-    return (Any rep code')
-
--- There is no "remainder" instruction on the PPC, so we have to do
--- it the hard way.
--- The "sgn" parameter is the signedness for the division instruction
-
-remainderCode :: Width -> Bool -> Reg -> CmmExpr -> CmmExpr
-               -> NatM (Reg -> InstrBlock)
-remainderCode rep sgn reg_q arg_x arg_y = do
-  let op_len = max W32 rep
-      fmt    = intFormat op_len
-      extend = if sgn then extendSExpr else extendUExpr
-  (x_reg, x_code) <- getSomeReg (extend rep op_len arg_x)
-  (y_reg, y_code) <- getSomeReg (extend rep op_len arg_y)
-  return $ \reg_r -> y_code `appOL` x_code
-                     `appOL` toOL [ DIV fmt sgn reg_q x_reg y_reg
-                                  , MULL fmt reg_r reg_q (RIReg y_reg)
-                                  , SUBF reg_r reg_r x_reg
-                                  ]
-
-
-coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
-coerceInt2FP fromRep toRep x = do
-    platform <- getPlatform
-    let arch = platformArch platform
-    coerceInt2FP' arch fromRep toRep x
-
-coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
-coerceInt2FP' ArchPPC fromRep toRep x = do
-    (src, code) <- getSomeReg x
-    lbl <- getNewLabelNat
-    itmp <- getNewRegNat II32
-    ftmp <- getNewRegNat FF64
-    config <- getConfig
-    platform <- getPlatform
-    dynRef <- cmmMakeDynamicReference config DataReference lbl
-    Amode addr addr_code <- getAmode D dynRef
-    let
-        code' dst = code `appOL` maybe_exts `appOL` toOL [
-                LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl
-                                 [CmmStaticLit (CmmInt 0x43300000 W32),
-                                  CmmStaticLit (CmmInt 0x80000000 W32)],
-                XORIS itmp src (ImmInt 0x8000),
-                ST II32 itmp (spRel platform 3),
-                LIS itmp (ImmInt 0x4330),
-                ST II32 itmp (spRel platform 2),
-                LD FF64 ftmp (spRel platform 2)
-            ] `appOL` addr_code `appOL` toOL [
-                LD FF64 dst addr,
-                FSUB FF64 dst ftmp dst
-            ] `appOL` maybe_frsp dst
-
-        maybe_exts = case fromRep of
-                        W8 ->  unitOL $ EXTS II8 src src
-                        W16 -> unitOL $ EXTS II16 src src
-                        W32 -> nilOL
-                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"
-
-        maybe_frsp dst
-                = case toRep of
-                        W32 -> unitOL $ FRSP dst dst
-                        W64 -> nilOL
-                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"
-
-    return (Any (floatFormat toRep) code')
-
--- On an ELF v1 Linux we use the compiler doubleword in the stack frame
--- this is the TOC pointer doubleword on ELF v2 Linux. The latter is only
--- set right before a call and restored right after return from the call.
--- So it is fine.
-coerceInt2FP' (ArchPPC_64 _) fromRep toRep x = do
-    (src, code) <- getSomeReg x
-    platform <- getPlatform
-    upper <- getNewRegNat II64
-    lower <- getNewRegNat II64
-    l1 <- getBlockIdNat
-    l2 <- getBlockIdNat
-    let
-        code' dst = code `appOL` maybe_exts `appOL` toOL [
-                ST II64 src (spRel platform 3),
-                LD FF64 dst (spRel platform 3),
-                FCFID dst dst
-            ] `appOL` maybe_frsp dst
-
-        maybe_exts
-          = case fromRep of
-              W8 ->  unitOL $ EXTS II8 src src
-              W16 -> unitOL $ EXTS II16 src src
-              W32 -> unitOL $ EXTS II32 src src
-              W64 -> case toRep of
-                        W32 -> toOL [ SRA II64 upper src (RIImm (ImmInt 53))
-                                    , CLRLI II64 lower src 53
-                                    , ADD upper upper (RIImm (ImmInt 1))
-                                    , ADD lower lower (RIImm (ImmInt 2047))
-                                    , CMPL II64 upper (RIImm (ImmInt 2))
-                                    , OR lower lower (RIReg src)
-                                    , CLRRI II64 lower lower 11
-                                    , BCC LTT l2 Nothing
-                                    , BCC ALWAYS l1 Nothing
-                                    , NEWBLOCK l1
-                                    , MR src lower
-                                    , BCC ALWAYS l2 Nothing
-                                    , NEWBLOCK l2
-                                    ]
-                        _   -> nilOL
-              _       -> panic "PPC.CodeGen.coerceInt2FP: no match"
-
-        maybe_frsp dst
-                = case toRep of
-                        W32 -> unitOL $ FRSP dst dst
-                        W64 -> nilOL
-                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"
-
-    return (Any (floatFormat toRep) code')
-
-coerceInt2FP' _ _ _ _ = panic "PPC.CodeGen.coerceInt2FP: unknown arch"
-
-
-coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
-coerceFP2Int fromRep toRep x = do
-    platform <- getPlatform
-    let arch =  platformArch platform
-    coerceFP2Int' arch fromRep toRep x
-
-coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
-coerceFP2Int' ArchPPC _ toRep x = do
-    platform <- getPlatform
-    -- the reps don't really matter: F*->FF64 and II32->I* are no-ops
-    (src, code) <- getSomeReg x
-    tmp <- getNewRegNat FF64
-    let
-        code' dst = code `appOL` toOL [
-                -- convert to int in FP reg
-            FCTIWZ tmp src,
-                -- store value (64bit) from FP to stack
-            ST FF64 tmp (spRel platform 2),
-                -- read low word of value (high word is undefined)
-            LD II32 dst (spRel platform 3)]
-    return (Any (intFormat toRep) code')
-
-coerceFP2Int' (ArchPPC_64 _) _ toRep x = do
-    platform <- getPlatform
-    -- the reps don't really matter: F*->FF64 and II64->I* are no-ops
-    (src, code) <- getSomeReg x
-    tmp <- getNewRegNat FF64
-    let
-        code' dst = code `appOL` toOL [
-                -- convert to int in FP reg
-            FCTIDZ tmp src,
-                -- store value (64bit) from FP to compiler word on stack
-            ST FF64 tmp (spRel platform 3),
-            LD II64 dst (spRel platform 3)]
-    return (Any (intFormat toRep) code')
-
-coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch"
-
--- Note [.LCTOC1 in PPC PIC code]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- The .LCTOC1 label is defined to point 32768 bytes into the GOT table
--- to make the most of the PPC's 16-bit displacements.
--- As 16-bit signed offset is used (usually via addi/lwz instructions)
--- first element will have '-32768' offset against .LCTOC1.
-
--- Note [implicit register in PPC PIC code]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- PPC generates calls by labels in assembly
--- in form of:
---     bl puts+32768@plt
--- in this form it's not seen directly (by GHC NCG)
--- that r30 (PicBaseReg) is used,
--- but r30 is a required part of PLT code setup:
---   puts+32768@plt:
---       lwz     r11,-30484(r30) ; offset in .LCTOC1
---       mtctr   r11
---       bctr
diff --git a/compiler/GHC/CmmToAsm/PPC/Cond.hs b/compiler/GHC/CmmToAsm/PPC/Cond.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/PPC/Cond.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-module GHC.CmmToAsm.PPC.Cond (
-        Cond(..),
-        condNegate,
-        condUnsigned,
-)
-
-where
-
-import GHC.Prelude
-
-import GHC.Utils.Panic
-
-data Cond
-        = ALWAYS
-        | EQQ
-        | GE
-        | GEU
-        | GTT
-        | GU
-        | LE
-        | LEU
-        | LTT
-        | LU
-        | NE
-        deriving Eq
-
-
-condNegate :: Cond -> Cond
-condNegate ALWAYS  = panic "condNegate: ALWAYS"
-condNegate EQQ     = NE
-condNegate GE      = LTT
-condNegate GEU     = LU
-condNegate GTT     = LE
-condNegate GU      = LEU
-condNegate LE      = GTT
-condNegate LEU     = GU
-condNegate LTT     = GE
-condNegate LU      = GEU
-condNegate NE      = EQQ
-
--- Condition utils
-condUnsigned :: Cond -> Bool
-condUnsigned GU  = True
-condUnsigned LU  = True
-condUnsigned GEU = True
-condUnsigned LEU = True
-condUnsigned _   = False
diff --git a/compiler/GHC/CmmToAsm/PPC/Instr.hs b/compiler/GHC/CmmToAsm/PPC/Instr.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/PPC/Instr.hs
+++ /dev/null
@@ -1,709 +0,0 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
------------------------------------------------------------------------------
---
--- Machine-dependent assembly language
---
--- (c) The University of Glasgow 1993-2004
---
------------------------------------------------------------------------------
-
-module GHC.CmmToAsm.PPC.Instr
-   ( Instr(..)
-   , RI(..)
-   , archWordFormat
-   , stackFrameHeaderSize
-   , maxSpillSlots
-   , allocMoreStack
-   , makeFarBranches
-   , mkJumpInstr
-   , mkLoadInstr
-   , mkSpillInstr
-   , patchJumpInstr
-   , patchRegsOfInstr
-   , jumpDestsOfInstr
-   , takeRegRegMoveInstr
-   , takeDeltaInstr
-   , mkRegRegMoveInstr
-   , mkStackAllocInstr
-   , mkStackDeallocInstr
-   , regUsageOfInstr
-   , isJumpishInstr
-   , isMetaInstr
-   )
-where
-
-import GHC.Prelude hiding (head, init, last, tail)
-
-import GHC.CmmToAsm.PPC.Regs
-import GHC.CmmToAsm.PPC.Cond
-import GHC.CmmToAsm.Types
-import GHC.CmmToAsm.Instr (RegUsage(..), noUsage)
-import GHC.CmmToAsm.Format
-import GHC.CmmToAsm.Reg.Target
-import GHC.CmmToAsm.Config
-import GHC.Platform.Reg.Class
-import GHC.Platform.Reg
-
-import GHC.Platform.Regs
-import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm
-import GHC.Cmm.Info
-import GHC.Cmm.CLabel
-import GHC.Utils.Panic
-import GHC.Platform
-import GHC.Types.Unique.FM (listToUFM, lookupUFM)
-import GHC.Types.Unique.Supply
-
-import Data.Foldable (toList)
-import qualified Data.List.NonEmpty as NE
-import GHC.Data.FastString (FastString)
-import Data.Maybe (fromMaybe)
-
-
---------------------------------------------------------------------------------
--- Format of a PPC memory address.
---
-archWordFormat :: Bool -> Format
-archWordFormat is32Bit
- | is32Bit   = II32
- | otherwise = II64
-
-
-mkStackAllocInstr :: Platform -> Int -> [Instr]
-mkStackAllocInstr platform amount
-  = mkStackAllocInstr' platform (-amount)
-
-mkStackDeallocInstr :: Platform -> Int -> [Instr]
-mkStackDeallocInstr platform amount
-  = mkStackAllocInstr' platform amount
-
-mkStackAllocInstr' :: Platform -> Int -> [Instr]
-mkStackAllocInstr' platform amount
-  | fits16Bits amount
-  = [ LD fmt r0 (AddrRegImm sp zero)
-    , STU fmt r0 (AddrRegImm sp immAmount)
-    ]
-  | otherwise
-  = [ LD fmt r0 (AddrRegImm sp zero)
-    , ADDIS tmp sp (HA immAmount)
-    , ADD tmp tmp (RIImm (LO immAmount))
-    , STU fmt r0 (AddrRegReg sp tmp)
-    ]
-  where
-    fmt = intFormat $ widthFromBytes (platformWordSizeInBytes platform)
-    zero = ImmInt 0
-    tmp = tmpReg platform
-    immAmount = ImmInt amount
-
---
--- See Note [extra spill slots] in X86/Instr.hs
---
-allocMoreStack
-  :: Platform
-  -> Int
-  -> NatCmmDecl statics GHC.CmmToAsm.PPC.Instr.Instr
-  -> UniqSM (NatCmmDecl statics GHC.CmmToAsm.PPC.Instr.Instr, [(BlockId,BlockId)])
-
-allocMoreStack _ _ top@(CmmData _ _) = return (top,[])
-allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do
-    let
-        infos   = mapKeys info
-        entries = case code of
-                    [] -> infos
-                    BasicBlock entry _ : _ -- first block is the entry point
-                        | entry `elem` infos -> infos
-                        | otherwise          -> entry : infos
-
-    uniqs <- getUniquesM
-
-    let
-        delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
-            where x = slots * spillSlotSize -- sp delta
-
-        alloc   = mkStackAllocInstr   platform delta
-        dealloc = mkStackDeallocInstr platform delta
-
-        retargetList = (zip entries (map mkBlockId uniqs))
-
-        new_blockmap :: LabelMap BlockId
-        new_blockmap = mapFromList retargetList
-
-        insert_stack_insns (BasicBlock id insns)
-            | Just new_blockid <- mapLookup id new_blockmap
-                = [ BasicBlock id $ alloc ++ [BCC ALWAYS new_blockid Nothing]
-                  , BasicBlock new_blockid block'
-                  ]
-            | otherwise
-                = [ BasicBlock id block' ]
-            where
-              block' = foldr insert_dealloc [] insns
-
-        insert_dealloc insn r
-            -- BCTR might or might not be a non-local jump. For
-            -- "labeled-goto" we use JMP, and for "computed-goto" we
-            -- use MTCTR followed by BCTR. See 'PPC.CodeGen.genJump'.
-            = case insn of
-                JMP _ _           -> dealloc ++ (insn : r)
-                BCTR [] Nothing _ -> dealloc ++ (insn : r)
-                BCTR ids label rs -> BCTR (map (fmap retarget) ids) label rs : r
-                BCCFAR cond b p   -> BCCFAR cond (retarget b) p : r
-                BCC    cond b p   -> BCC    cond (retarget b) p : r
-                _                 -> insn : r
-            -- BL and BCTRL are call-like instructions rather than
-            -- jumps, and are used only for C calls.
-
-        retarget :: BlockId -> BlockId
-        retarget b
-            = fromMaybe b (mapLookup b new_blockmap)
-
-        new_code
-            = concatMap insert_stack_insns code
-
-    -- in
-    return (CmmProc info lbl live (ListGraph new_code),retargetList)
-
-
--- -----------------------------------------------------------------------------
--- Machine's assembly language
-
--- We have a few common "instructions" (nearly all the pseudo-ops) but
--- mostly all of 'Instr' is machine-specific.
-
--- Register or immediate
-data RI
-    = RIReg Reg
-    | RIImm Imm
-
-data Instr
-    -- comment pseudo-op
-    = COMMENT FastString
-
-    -- location pseudo-op (file, line, col, name)
-    | LOCATION Int Int Int String
-
-    -- some static data spat out during code
-    -- generation.  Will be extracted before
-    -- pretty-printing.
-    | LDATA   Section RawCmmStatics
-
-    -- start a new basic block.  Useful during
-    -- codegen, removed later.  Preceding
-    -- instruction should be a jump, as per the
-    -- invariants for a BasicBlock (see Cmm).
-    | NEWBLOCK BlockId
-
-    -- specify current stack offset for
-    -- benefit of subsequent passes
-    | DELTA   Int
-
-    -- Loads and stores.
-    | LD      Format Reg AddrMode   -- Load format, dst, src
-    | LDFAR   Format Reg AddrMode   -- Load format, dst, src 32 bit offset
-    | LDR     Format Reg AddrMode   -- Load and reserve format, dst, src
-    | LA      Format Reg AddrMode   -- Load arithmetic format, dst, src
-    | ST      Format Reg AddrMode   -- Store format, src, dst
-    | STFAR   Format Reg AddrMode   -- Store format, src, dst 32 bit offset
-    | STU     Format Reg AddrMode   -- Store with Update format, src, dst
-    | STC     Format Reg AddrMode   -- Store conditional format, src, dst
-    | LIS     Reg Imm               -- Load Immediate Shifted dst, src
-    | LI      Reg Imm               -- Load Immediate dst, src
-    | MR      Reg Reg               -- Move Register dst, src -- also for fmr
-
-    | CMP     Format Reg RI         -- format, src1, src2
-    | CMPL    Format Reg RI         -- format, src1, src2
-
-    | BCC     Cond BlockId (Maybe Bool) -- cond, block, hint
-    | BCCFAR  Cond BlockId (Maybe Bool) -- cond, block, hint
-                                    --   hint:
-                                    --    Just True:  branch likely taken
-                                    --    Just False: branch likely not taken
-                                    --    Nothing:    no hint
-    | JMP     CLabel [Reg]          -- same as branch,
-                                    -- but with CLabel instead of block ID
-                                    -- and live global registers
-    | MTCTR   Reg
-    | BCTR    [Maybe BlockId] (Maybe CLabel) [Reg]
-                                    -- with list of local destinations, and
-                                    -- jump table location if necessary
-    | BL      CLabel [Reg]          -- with list of argument regs
-    | BCTRL   [Reg]
-
-    | ADD     Reg Reg RI            -- dst, src1, src2
-    | ADDO    Reg Reg Reg           -- add and set overflow
-    | ADDC    Reg Reg Reg           -- (carrying) dst, src1, src2
-    | ADDE    Reg Reg Reg           -- (extended) dst, src1, src2
-    | ADDZE   Reg Reg               -- (to zero extended) dst, src
-    | ADDIS   Reg Reg Imm           -- Add Immediate Shifted dst, src1, src2
-    | SUBF    Reg Reg Reg           -- dst, src1, src2 ; dst = src2 - src1
-    | SUBFO   Reg Reg Reg           -- subtract from and set overflow
-    | SUBFC   Reg Reg RI            -- (carrying) dst, src1, src2 ;
-                                    -- dst = src2 - src1
-    | SUBFE   Reg Reg Reg           -- (extended) dst, src1, src2 ;
-                                    -- dst = src2 - src1
-    | MULL    Format Reg Reg RI
-    | MULLO   Format Reg Reg Reg    -- multiply and set overflow
-    | MFOV    Format Reg            -- move overflow bit (1|33) to register
-                                    -- pseudo-instruction; pretty printed as
-                                    -- mfxer dst
-                                    -- extr[w|d]i dst, dst, 1, [1|33]
-    | MULHU   Format Reg Reg Reg
-    | DIV     Format Bool Reg Reg Reg
-    | AND     Reg Reg RI            -- dst, src1, src2
-    | ANDC    Reg Reg Reg           -- AND with complement, dst = src1 & ~ src2
-    | NAND    Reg Reg Reg           -- dst, src1, src2
-    | OR      Reg Reg RI            -- dst, src1, src2
-    | ORIS    Reg Reg Imm           -- OR Immediate Shifted dst, src1, src2
-    | XOR     Reg Reg RI            -- dst, src1, src2
-    | XORIS   Reg Reg Imm           -- XOR Immediate Shifted dst, src1, src2
-
-    | EXTS    Format Reg Reg
-    | CNTLZ   Format Reg Reg
-
-    | NEG     Reg Reg
-    | NOT     Reg Reg
-
-    | SL      Format Reg Reg RI            -- shift left
-    | SR      Format Reg Reg RI            -- shift right
-    | SRA     Format Reg Reg RI            -- shift right arithmetic
-
-    | RLWINM  Reg Reg Int Int Int   -- Rotate Left Word Immediate then AND with Mask
-    | CLRLI   Format Reg Reg Int    -- clear left immediate (extended mnemonic)
-    | CLRRI   Format Reg Reg Int    -- clear right immediate (extended mnemonic)
-
-    | FADD    Format Reg Reg Reg
-    | FSUB    Format Reg Reg Reg
-    | FMUL    Format Reg Reg Reg
-    | FDIV    Format Reg Reg Reg
-    | FABS    Reg Reg               -- abs is the same for single and double
-    | FNEG    Reg Reg               -- negate is the same for single and double prec.
-
-    | FCMP    Reg Reg
-
-    | FCTIWZ  Reg Reg           -- convert to integer word
-    | FCTIDZ  Reg Reg           -- convert to integer double word
-    | FCFID   Reg Reg           -- convert from integer double word
-    | FRSP    Reg Reg           -- reduce to single precision
-                                -- (but destination is a FP register)
-
-    | CRNOR   Int Int Int       -- condition register nor
-    | MFCR    Reg               -- move from condition register
-
-    | MFLR    Reg               -- move from link register
-    | FETCHPC Reg               -- pseudo-instruction:
-                                -- bcl to next insn, mflr reg
-    | HWSYNC                    -- heavy weight sync
-    | ISYNC                     -- instruction synchronize
-    | LWSYNC                    -- memory barrier
-    | NOP                       -- no operation, PowerPC 64 bit
-                                -- needs this as place holder to
-                                -- reload TOC pointer
-
--- | Get the registers that are being used by this instruction.
--- regUsage doesn't need to do any trickery for jumps and such.
--- Just state precisely the regs read and written by that insn.
--- The consequences of control flow transfers, as far as register
--- allocation goes, are taken care of by the register allocator.
---
-regUsageOfInstr :: Platform -> Instr -> RegUsage
-regUsageOfInstr platform instr
- = case instr of
-    LD      _ reg addr       -> usage (regAddr addr, [reg])
-    LDFAR   _ reg addr       -> usage (regAddr addr, [reg])
-    LDR     _ reg addr       -> usage (regAddr addr, [reg])
-    LA      _ reg addr       -> usage (regAddr addr, [reg])
-    ST      _ reg addr       -> usage (reg : regAddr addr, [])
-    STFAR   _ reg addr       -> usage (reg : regAddr addr, [])
-    STU     _ reg addr       -> usage (reg : regAddr addr, [])
-    STC     _ reg addr       -> usage (reg : regAddr addr, [])
-    LIS     reg _            -> usage ([], [reg])
-    LI      reg _            -> usage ([], [reg])
-    MR      reg1 reg2        -> usage ([reg2], [reg1])
-    CMP     _ reg ri         -> usage (reg : regRI ri,[])
-    CMPL    _ reg ri         -> usage (reg : regRI ri,[])
-    BCC     _ _ _            -> noUsage
-    BCCFAR  _ _ _            -> noUsage
-    JMP     _ regs           -> usage (regs, [])
-    MTCTR   reg              -> usage ([reg],[])
-    BCTR    _ _ regs         -> usage (regs, [])
-    BL      _ params         -> usage (params, callClobberedRegs platform)
-    BCTRL   params           -> usage (params, callClobberedRegs platform)
-
-    ADD     reg1 reg2 ri     -> usage (reg2 : regRI ri, [reg1])
-    ADDO    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
-    ADDC    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
-    ADDE    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
-    ADDZE   reg1 reg2        -> usage ([reg2], [reg1])
-    ADDIS   reg1 reg2 _      -> usage ([reg2], [reg1])
-    SUBF    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
-    SUBFO   reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
-    SUBFC   reg1 reg2 ri     -> usage (reg2 : regRI ri, [reg1])
-    SUBFE   reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
-    MULL    _ reg1 reg2 ri   -> usage (reg2 : regRI ri, [reg1])
-    MULLO   _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
-    MFOV    _ reg            -> usage ([], [reg])
-    MULHU   _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
-    DIV     _ _ reg1 reg2 reg3
-                             -> usage ([reg2,reg3], [reg1])
-
-    AND     reg1 reg2 ri    -> usage (reg2 : regRI ri, [reg1])
-    ANDC    reg1 reg2 reg3  -> usage ([reg2,reg3], [reg1])
-    NAND    reg1 reg2 reg3  -> usage ([reg2,reg3], [reg1])
-    OR      reg1 reg2 ri    -> usage (reg2 : regRI ri, [reg1])
-    ORIS    reg1 reg2 _     -> usage ([reg2], [reg1])
-    XOR     reg1 reg2 ri    -> usage (reg2 : regRI ri, [reg1])
-    XORIS   reg1 reg2 _     -> usage ([reg2], [reg1])
-    EXTS    _  reg1 reg2    -> usage ([reg2], [reg1])
-    CNTLZ   _  reg1 reg2    -> usage ([reg2], [reg1])
-    NEG     reg1 reg2       -> usage ([reg2], [reg1])
-    NOT     reg1 reg2       -> usage ([reg2], [reg1])
-    SL      _ reg1 reg2 ri  -> usage (reg2 : regRI ri, [reg1])
-    SR      _ reg1 reg2 ri  -> usage (reg2 : regRI ri, [reg1])
-    SRA     _ reg1 reg2 ri  -> usage (reg2 : regRI ri, [reg1])
-    RLWINM  reg1 reg2 _ _ _ -> usage ([reg2], [reg1])
-    CLRLI   _ reg1 reg2 _   -> usage ([reg2], [reg1])
-    CLRRI   _ reg1 reg2 _   -> usage ([reg2], [reg1])
-
-    FADD    _ r1 r2 r3      -> usage ([r2,r3], [r1])
-    FSUB    _ r1 r2 r3      -> usage ([r2,r3], [r1])
-    FMUL    _ r1 r2 r3      -> usage ([r2,r3], [r1])
-    FDIV    _ r1 r2 r3      -> usage ([r2,r3], [r1])
-    FABS    r1 r2           -> usage ([r2], [r1])
-    FNEG    r1 r2           -> usage ([r2], [r1])
-    FCMP    r1 r2           -> usage ([r1,r2], [])
-    FCTIWZ  r1 r2           -> usage ([r2], [r1])
-    FCTIDZ  r1 r2           -> usage ([r2], [r1])
-    FCFID   r1 r2           -> usage ([r2], [r1])
-    FRSP    r1 r2           -> usage ([r2], [r1])
-    MFCR    reg             -> usage ([], [reg])
-    MFLR    reg             -> usage ([], [reg])
-    FETCHPC reg             -> usage ([], [reg])
-    _                       -> noUsage
-  where
-    usage (src, dst) = RU (filter (interesting platform) src)
-                          (filter (interesting platform) dst)
-    regAddr (AddrRegReg r1 r2) = [r1, r2]
-    regAddr (AddrRegImm r1 _)  = [r1]
-
-    regRI (RIReg r) = [r]
-    regRI  _        = []
-
-interesting :: Platform -> Reg -> Bool
-interesting _        (RegVirtual _)              = True
-interesting platform (RegReal (RealRegSingle i)) = freeReg platform i
-
-
--- | Apply a given mapping to all the register references in this
--- instruction.
-patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
-patchRegsOfInstr instr env
- = case instr of
-    LD      fmt reg addr    -> LD fmt (env reg) (fixAddr addr)
-    LDFAR   fmt reg addr    -> LDFAR fmt (env reg) (fixAddr addr)
-    LDR     fmt reg addr    -> LDR fmt (env reg) (fixAddr addr)
-    LA      fmt reg addr    -> LA fmt (env reg) (fixAddr addr)
-    ST      fmt reg addr    -> ST fmt (env reg) (fixAddr addr)
-    STFAR   fmt reg addr    -> STFAR fmt (env reg) (fixAddr addr)
-    STU     fmt reg addr    -> STU fmt (env reg) (fixAddr addr)
-    STC     fmt reg addr    -> STC fmt (env reg) (fixAddr addr)
-    LIS     reg imm         -> LIS (env reg) imm
-    LI      reg imm         -> LI (env reg) imm
-    MR      reg1 reg2       -> MR (env reg1) (env reg2)
-    CMP     fmt reg ri      -> CMP fmt (env reg) (fixRI ri)
-    CMPL    fmt reg ri      -> CMPL fmt (env reg) (fixRI ri)
-    BCC     cond lbl p      -> BCC cond lbl p
-    BCCFAR  cond lbl p      -> BCCFAR cond lbl p
-    JMP     l regs          -> JMP l regs -- global regs will not be remapped
-    MTCTR   reg             -> MTCTR (env reg)
-    BCTR    targets lbl rs  -> BCTR targets lbl rs
-    BL      imm argRegs     -> BL imm argRegs    -- argument regs
-    BCTRL   argRegs         -> BCTRL argRegs     -- cannot be remapped
-    ADD     reg1 reg2 ri    -> ADD (env reg1) (env reg2) (fixRI ri)
-    ADDO    reg1 reg2 reg3  -> ADDO (env reg1) (env reg2) (env reg3)
-    ADDC    reg1 reg2 reg3  -> ADDC (env reg1) (env reg2) (env reg3)
-    ADDE    reg1 reg2 reg3  -> ADDE (env reg1) (env reg2) (env reg3)
-    ADDZE   reg1 reg2       -> ADDZE (env reg1) (env reg2)
-    ADDIS   reg1 reg2 imm   -> ADDIS (env reg1) (env reg2) imm
-    SUBF    reg1 reg2 reg3  -> SUBF (env reg1) (env reg2) (env reg3)
-    SUBFO   reg1 reg2 reg3  -> SUBFO (env reg1) (env reg2) (env reg3)
-    SUBFC   reg1 reg2 ri    -> SUBFC (env reg1) (env reg2) (fixRI ri)
-    SUBFE   reg1 reg2 reg3  -> SUBFE (env reg1) (env reg2) (env reg3)
-    MULL    fmt reg1 reg2 ri
-                            -> MULL fmt (env reg1) (env reg2) (fixRI ri)
-    MULLO   fmt reg1 reg2 reg3
-                            -> MULLO fmt (env reg1) (env reg2) (env reg3)
-    MFOV    fmt reg         -> MFOV fmt (env reg)
-    MULHU   fmt reg1 reg2 reg3
-                            -> MULHU fmt (env reg1) (env reg2) (env reg3)
-    DIV     fmt sgn reg1 reg2 reg3
-                            -> DIV fmt sgn (env reg1) (env reg2) (env reg3)
-
-    AND     reg1 reg2 ri    -> AND (env reg1) (env reg2) (fixRI ri)
-    ANDC    reg1 reg2 reg3  -> ANDC (env reg1) (env reg2) (env reg3)
-    NAND    reg1 reg2 reg3  -> NAND (env reg1) (env reg2) (env reg3)
-    OR      reg1 reg2 ri    -> OR  (env reg1) (env reg2) (fixRI ri)
-    ORIS    reg1 reg2 imm   -> ORIS (env reg1) (env reg2) imm
-    XOR     reg1 reg2 ri    -> XOR (env reg1) (env reg2) (fixRI ri)
-    XORIS   reg1 reg2 imm   -> XORIS (env reg1) (env reg2) imm
-    EXTS    fmt reg1 reg2   -> EXTS fmt (env reg1) (env reg2)
-    CNTLZ   fmt reg1 reg2   -> CNTLZ fmt (env reg1) (env reg2)
-    NEG     reg1 reg2       -> NEG (env reg1) (env reg2)
-    NOT     reg1 reg2       -> NOT (env reg1) (env reg2)
-    SL      fmt reg1 reg2 ri
-                            -> SL fmt (env reg1) (env reg2) (fixRI ri)
-    SR      fmt reg1 reg2 ri
-                            -> SR fmt (env reg1) (env reg2) (fixRI ri)
-    SRA     fmt reg1 reg2 ri
-                            -> SRA fmt (env reg1) (env reg2) (fixRI ri)
-    RLWINM  reg1 reg2 sh mb me
-                            -> RLWINM (env reg1) (env reg2) sh mb me
-    CLRLI   fmt reg1 reg2 n -> CLRLI fmt (env reg1) (env reg2) n
-    CLRRI   fmt reg1 reg2 n -> CLRRI fmt (env reg1) (env reg2) n
-    FADD    fmt r1 r2 r3    -> FADD fmt (env r1) (env r2) (env r3)
-    FSUB    fmt r1 r2 r3    -> FSUB fmt (env r1) (env r2) (env r3)
-    FMUL    fmt r1 r2 r3    -> FMUL fmt (env r1) (env r2) (env r3)
-    FDIV    fmt r1 r2 r3    -> FDIV fmt (env r1) (env r2) (env r3)
-    FABS    r1 r2           -> FABS (env r1) (env r2)
-    FNEG    r1 r2           -> FNEG (env r1) (env r2)
-    FCMP    r1 r2           -> FCMP (env r1) (env r2)
-    FCTIWZ  r1 r2           -> FCTIWZ (env r1) (env r2)
-    FCTIDZ  r1 r2           -> FCTIDZ (env r1) (env r2)
-    FCFID   r1 r2           -> FCFID (env r1) (env r2)
-    FRSP    r1 r2           -> FRSP (env r1) (env r2)
-    MFCR    reg             -> MFCR (env reg)
-    MFLR    reg             -> MFLR (env reg)
-    FETCHPC reg             -> FETCHPC (env reg)
-    _                       -> instr
-  where
-    fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
-    fixAddr (AddrRegImm r1 i)  = AddrRegImm (env r1) i
-
-    fixRI (RIReg r) = RIReg (env r)
-    fixRI other     = other
-
-
---------------------------------------------------------------------------------
--- | Checks whether this instruction is a jump/branch instruction.
--- One that can change the flow of control in a way that the
--- register allocator needs to worry about.
-isJumpishInstr :: Instr -> Bool
-isJumpishInstr instr
- = case instr of
-    BCC{}       -> True
-    BCCFAR{}    -> True
-    BCTR{}      -> True
-    BCTRL{}     -> True
-    BL{}        -> True
-    JMP{}       -> True
-    _           -> False
-
-
--- | Checks whether this instruction is a jump/branch instruction.
--- One that can change the flow of control in a way that the
--- register allocator needs to worry about.
-jumpDestsOfInstr :: Instr -> [BlockId]
-jumpDestsOfInstr insn
-  = case insn of
-        BCC _ id _       -> [id]
-        BCCFAR _ id _    -> [id]
-        BCTR targets _ _ -> [id | Just id <- targets]
-        _                -> []
-
-
--- | Change the destination of this jump instruction.
--- Used in the linear allocator when adding fixup blocks for join
--- points.
-patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
-patchJumpInstr insn patchF
-  = case insn of
-        BCC cc id p     -> BCC cc (patchF id) p
-        BCCFAR cc id p  -> BCCFAR cc (patchF id) p
-        BCTR ids lbl rs -> BCTR (map (fmap patchF) ids) lbl rs
-        _               -> insn
-
-
--- -----------------------------------------------------------------------------
-
--- | An instruction to spill a register into a spill slot.
-mkSpillInstr
-   :: NCGConfig
-   -> Reg       -- register to spill
-   -> Int       -- current stack delta
-   -> Int       -- spill slot to use
-   -> [Instr]
-
-mkSpillInstr config reg delta slot
-  = let platform = ncgPlatform config
-        off      = spillSlotToOffset platform slot
-        arch     = platformArch platform
-    in
-    let fmt = case targetClassOfReg platform reg of
-                RcInteger -> case arch of
-                                ArchPPC -> II32
-                                _       -> II64
-                RcDouble  -> FF64
-                _         -> panic "PPC.Instr.mkSpillInstr: no match"
-        instr = case makeImmediate W32 True (off-delta) of
-                Just _  -> ST
-                Nothing -> STFAR -- pseudo instruction: 32 bit offsets
-
-    in [instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))]
-
-
-mkLoadInstr
-   :: NCGConfig
-   -> Reg       -- register to load
-   -> Int       -- current stack delta
-   -> Int       -- spill slot to use
-   -> [Instr]
-
-mkLoadInstr config reg delta slot
-  = let platform = ncgPlatform config
-        off      = spillSlotToOffset platform slot
-        arch     = platformArch platform
-    in
-    let fmt = case targetClassOfReg platform reg of
-                RcInteger ->  case arch of
-                                 ArchPPC -> II32
-                                 _       -> II64
-                RcDouble  -> FF64
-                _         -> panic "PPC.Instr.mkLoadInstr: no match"
-        instr = case makeImmediate W32 True (off-delta) of
-                Just _  -> LD
-                Nothing -> LDFAR -- pseudo instruction: 32 bit offsets
-
-    in [instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))]
-
-
--- | The size of a minimal stackframe header including minimal
--- parameter save area.
-stackFrameHeaderSize :: Platform -> Int
-stackFrameHeaderSize platform
-  = case platformOS platform of
-      OSAIX    -> 24 + 8 * 4
-      _ -> case platformArch platform of
-                             -- header + parameter save area
-             ArchPPC           -> 64 -- TODO: check ABI spec
-             ArchPPC_64 ELF_V1 -> 48 + 8 * 8
-             ArchPPC_64 ELF_V2 -> 32 + 8 * 8
-             _ -> panic "PPC.stackFrameHeaderSize: not defined for this OS"
-
--- | The maximum number of bytes required to spill a register. PPC32
--- has 32-bit GPRs and 64-bit FPRs, while PPC64 has 64-bit GPRs and
--- 64-bit FPRs. So the maximum is 8 regardless of platforms unlike
--- x86. Note that AltiVec's vector registers are 128-bit wide so we
--- must not use this to spill them.
-spillSlotSize :: Int
-spillSlotSize = 8
-
--- | The number of spill slots available without allocating more.
-maxSpillSlots :: NCGConfig -> Int
-maxSpillSlots config
---  = 0 -- useful for testing allocMoreStack
-    = let platform = ncgPlatform config
-      in ((ncgSpillPreallocSize config - stackFrameHeaderSize platform)
-         `div` spillSlotSize) - 1
-
--- | The number of bytes that the stack pointer should be aligned
--- to. This is 16 both on PPC32 and PPC64 ELF (see ELF processor
--- specific supplements).
-stackAlign :: Int
-stackAlign = 16
-
--- | Convert a spill slot number to a *byte* offset, with no sign.
-spillSlotToOffset :: Platform -> Int -> Int
-spillSlotToOffset platform slot
-   = stackFrameHeaderSize platform + spillSlotSize * slot
-
-
---------------------------------------------------------------------------------
--- | See if this instruction is telling us the current C stack delta
-takeDeltaInstr
-    :: Instr
-    -> Maybe Int
-
-takeDeltaInstr instr
- = case instr of
-     DELTA i  -> Just i
-     _        -> Nothing
-
-
-isMetaInstr
-    :: Instr
-    -> Bool
-
-isMetaInstr instr
- = case instr of
-    COMMENT{}   -> True
-    LOCATION{}  -> True
-    LDATA{}     -> True
-    NEWBLOCK{}  -> True
-    DELTA{}     -> True
-    _           -> False
-
-
--- | Copy the value in a register to another one.
--- Must work for all register classes.
-mkRegRegMoveInstr
-    :: Reg
-    -> Reg
-    -> Instr
-
-mkRegRegMoveInstr src dst
-    = MR dst src
-
-
--- | Make an unconditional jump instruction.
-mkJumpInstr
-    :: BlockId
-    -> [Instr]
-
-mkJumpInstr id
-    = [BCC ALWAYS id Nothing]
-
-
--- | Take the source and destination from this reg -> reg move instruction
--- or Nothing if it's not one
-takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)
-takeRegRegMoveInstr (MR dst src) = Just (src,dst)
-takeRegRegMoveInstr _  = Nothing
-
--- -----------------------------------------------------------------------------
--- Making far branches
-
--- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
--- big, we have to work around this limitation.
-
-makeFarBranches
-        :: LabelMap RawCmmStatics
-        -> [NatBasicBlock Instr]
-        -> [NatBasicBlock Instr]
-makeFarBranches info_env blocks
-    | NE.last blockAddresses < nearLimit = blocks
-    | otherwise = zipWith handleBlock blockAddressList blocks
-    where
-        blockAddresses = NE.scanl (+) 0 $ map blockLen blocks
-        blockAddressList = toList blockAddresses
-        blockLen (BasicBlock _ instrs) = length instrs
-
-        handleBlock addr (BasicBlock id instrs)
-                = BasicBlock id (zipWith makeFar [addr..] instrs)
-
-        makeFar _ (BCC ALWAYS tgt _) = BCC ALWAYS tgt Nothing
-        makeFar addr (BCC cond tgt p)
-            | abs (addr - targetAddr) >= nearLimit
-            = BCCFAR cond tgt p
-            | otherwise
-            = BCC cond tgt p
-            where Just targetAddr = lookupUFM blockAddressMap tgt
-        makeFar _ other            = other
-
-        -- 8192 instructions are allowed; let's keep some distance, as
-        -- we have a few pseudo-insns that are pretty-printed as
-        -- multiple instructions, and it's just not worth the effort
-        -- to calculate things exactly
-        nearLimit = 7000 - mapSize info_env * maxRetInfoTableSizeW
-
-        blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddressList
diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs
+++ /dev/null
@@ -1,1103 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
------------------------------------------------------------------------------
---
--- Pretty-printing assembly language
---
--- (c) The University of Glasgow 1993-2005
---
------------------------------------------------------------------------------
-
-module GHC.CmmToAsm.PPC.Ppr
-   ( pprNatCmmDecl
-   , pprInstr
-   )
-where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.PPC.Regs
-import GHC.CmmToAsm.PPC.Instr
-import GHC.CmmToAsm.PPC.Cond
-import GHC.CmmToAsm.Ppr
-import GHC.CmmToAsm.Format
-import GHC.Platform.Reg
-import GHC.Platform.Reg.Class
-import GHC.CmmToAsm.Reg.Target
-import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Types
-import GHC.CmmToAsm.Utils
-
-import GHC.Cmm hiding (topInfoTable)
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Label
-
-import GHC.Cmm.BlockId
-import GHC.Cmm.CLabel
-
-import GHC.Types.Unique ( pprUniqueAlways, getUnique )
-import GHC.Platform
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import Data.Word
-import Data.Int
-
--- -----------------------------------------------------------------------------
--- Printing this stuff out
-
-pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc
-pprNatCmmDecl config (CmmData section dats) =
-  pprSectionAlign config section
-  $$ pprDatas (ncgPlatform config) dats
-
-pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
-  let platform = ncgPlatform config in
-  case topInfoTable proc of
-    Nothing ->
-         -- special case for code without info table:
-         pprSectionAlign config (Section Text lbl) $$
-         (case platformArch platform of
-            ArchPPC_64 ELF_V1 -> pprFunctionDescriptor platform lbl
-            ArchPPC_64 ELF_V2 -> pprFunctionPrologue platform lbl
-            _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null,
-                                           -- so label needed
-         vcat (map (pprBasicBlock config top_info) blocks) $$
-         ppWhen (ncgDwarfEnabled config) (line (pprAsmLabel platform (mkAsmTempEndLabel lbl)
-                                                <> char ':') $$
-                                          line (pprProcEndLabel platform lbl)) $$
-         pprSizeDecl platform lbl
-
-    Just (CmmStaticsRaw info_lbl _) ->
-      pprSectionAlign config (Section Text info_lbl) $$
-      (if platformHasSubsectionsViaSymbols platform
-          then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':')
-          else empty) $$
-      vcat (map (pprBasicBlock config top_info) blocks) $$
-      -- above: Even the first block gets a label, because with branch-chain
-      -- elimination, it might be the target of a goto.
-      (if platformHasSubsectionsViaSymbols platform
-       then
-       -- See Note [Subsections Via Symbols] in X86/Ppr.hs
-                line (text "\t.long "
-                      <+> pprAsmLabel platform info_lbl
-                      <+> char '-'
-                      <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl))
-       else empty) $$
-      pprSizeDecl platform info_lbl
-{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-}
-{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Output the ELF .size directive.
-pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc
-pprSizeDecl platform lbl
- = if osElfTarget (platformOS platform)
-   then line (text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl)
-   else empty
-  where
-    prettyLbl = pprAsmLabel platform lbl
-    codeLbl
-      | platformArch platform == ArchPPC_64 ELF_V1 = char '.' <> prettyLbl
-      | otherwise                                  = prettyLbl
-
-pprFunctionDescriptor :: IsDoc doc => Platform -> CLabel -> doc
-pprFunctionDescriptor platform lab =
-  vcat [pprGloblDecl platform lab,
-        line (text "\t.section \".opd\", \"aw\""),
-        line (text "\t.align 3"),
-        line (pprAsmLabel platform lab <> char ':'),
-        line (text "\t.quad ."
-              <>  pprAsmLabel platform lab
-              <>  text ",.TOC.@tocbase,0"),
-        line (text "\t.previous"),
-        line (text "\t.type"
-              <+> pprAsmLabel platform lab
-              <>  text ", @function"),
-        line (char '.' <> pprAsmLabel platform lab <> char ':')]
-
-pprFunctionPrologue :: IsDoc doc => Platform -> CLabel -> doc
-pprFunctionPrologue platform lab =
-  vcat [pprGloblDecl platform lab,
-        line (text ".type " <> pprAsmLabel platform lab <> text ", @function"),
-        line (pprAsmLabel platform lab <> char ':'),
-        line (text "0:\taddis\t" <> pprReg toc <> text ",12,.TOC.-0b@ha"),
-        line (text "\taddi\t" <> pprReg toc <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"),
-        line (text "\t.localentry\t" <> pprAsmLabel platform lab <>
-              text ",.-" <> pprAsmLabel platform lab)]
-
-pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name
-                -> doc
-pprProcEndLabel platform lbl =
-    pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> char ':'
-
-pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr
-              -> doc
-pprBasicBlock config info_env (BasicBlock blockid instrs)
-  = maybe_infotable $$
-    pprLabel platform asmLbl $$
-    vcat (map (pprInstr platform) instrs) $$
-    ppWhen (ncgDwarfEnabled config) (
-      line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':'
-            <> pprProcEndLabel platform asmLbl)
-    )
-  where
-    asmLbl = blockLbl blockid
-    platform = ncgPlatform config
-    maybe_infotable = case mapLookup blockid info_env of
-       Nothing   -> empty
-       Just (CmmStaticsRaw info_lbl info) ->
-           pprAlignForSection platform Text $$
-           vcat (map (pprData platform) info) $$
-           pprLabel platform info_lbl
-
-
-
-pprDatas :: IsDoc doc => Platform -> RawCmmStatics -> doc
--- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
-pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
-  | lbl == mkIndStaticInfoLabel
-  , let labelInd (CmmLabelOff l _) = Just l
-        labelInd (CmmLabel l) = Just l
-        labelInd _ = Nothing
-  , Just ind' <- labelInd ind
-  , alias `mayRedirectTo` ind'
-  = pprGloblDecl platform alias
-    $$ line (text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind')
-pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats)
-
-pprData :: IsDoc doc => Platform -> CmmStatic -> doc
-pprData platform d = case d of
-   CmmString str          -> line (pprString str)
-   CmmFileEmbed path _    -> line (pprFileEmbed path)
-   CmmUninitialised bytes -> line (text ".space " <> int bytes)
-   CmmStaticLit lit       -> pprDataItem platform lit
-
-pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc
-pprGloblDecl platform lbl
-  | not (externallyVisibleCLabel lbl) = empty
-  | otherwise = line (text ".globl " <> pprAsmLabel platform lbl)
-
-pprTypeAndSizeDecl :: IsLine doc => Platform -> CLabel -> doc
-pprTypeAndSizeDecl platform lbl
-  = if platformOS platform == OSLinux && externallyVisibleCLabel lbl
-    then text ".type " <>
-         pprAsmLabel platform lbl <> text ", @object"
-    else empty
-
-pprLabel :: IsDoc doc => Platform -> CLabel -> doc
-pprLabel platform lbl =
-   pprGloblDecl platform lbl
-   $$ line (pprTypeAndSizeDecl platform lbl)
-   $$ line (pprAsmLabel platform lbl <> char ':')
-
--- -----------------------------------------------------------------------------
--- pprInstr: print an 'Instr'
-
-pprReg :: forall doc. IsLine doc => Reg -> doc
-
-pprReg r
-  = case r of
-      RegReal    (RealRegSingle i) -> ppr_reg_no i
-      RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u
-      RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u
-      RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u
-      RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u
-
-  where
-    ppr_reg_no :: Int -> doc
-    ppr_reg_no i
-         | i <= 31   = int i      -- GPRs
-         | i <= 63   = int (i-32) -- FPRs
-         | otherwise = text "very naughty powerpc register"
-
-
-
-pprFormat :: IsLine doc => Format -> doc
-pprFormat x
- = case x of
-                II8  -> text "b"
-                II16 -> text "h"
-                II32 -> text "w"
-                II64 -> text "d"
-                FF32 -> text "fs"
-                FF64 -> text "fd"
-
-
-pprCond :: IsLine doc => Cond -> doc
-pprCond c
- = case c of {
-                ALWAYS  -> text "";
-                EQQ     -> text "eq";  NE    -> text "ne";
-                LTT     -> text "lt";  GE    -> text "ge";
-                GTT     -> text "gt";  LE    -> text "le";
-                LU      -> text "lt";  GEU   -> text "ge";
-                GU      -> text "gt";  LEU   -> text "le"; }
-
-
-pprImm :: IsLine doc => Platform -> Imm -> doc
-pprImm platform = \case
-   ImmInt i       -> int i
-   ImmInteger i   -> integer i
-   ImmCLbl l      -> pprAsmLabel platform l
-   ImmIndex l i   -> pprAsmLabel platform l <> char '+' <> int i
-   ImmLit s       -> ftext s
-   ImmFloat f     -> float $ fromRational f
-   ImmDouble d    -> double $ fromRational d
-   ImmConstantSum a b   -> pprImm platform a <> char '+' <> pprImm platform b
-   ImmConstantDiff a b  -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen
-   LO (ImmInt i)        -> pprImm platform (LO (ImmInteger (toInteger i)))
-   LO (ImmInteger i)    -> pprImm platform (ImmInteger (toInteger lo16))
-        where
-          lo16 = fromInteger (i .&. 0xffff) :: Int16
-
-   LO i              -> pprImm platform i <> text "@l"
-   HI i              -> pprImm platform i <> text "@h"
-   HA (ImmInt i)     -> pprImm platform (HA (ImmInteger (toInteger i)))
-   HA (ImmInteger i) -> pprImm platform (ImmInteger ha16)
-        where
-          ha16 = if lo16 >= 0x8000 then hi16+1 else hi16
-          hi16 = (i `shiftR` 16)
-          lo16 = i .&. 0xffff
-
-   HA i        -> pprImm platform i <> text "@ha"
-   HIGHERA i   -> pprImm platform i <> text "@highera"
-   HIGHESTA i  -> pprImm platform i <> text "@highesta"
-
-
-pprAddr :: IsLine doc => Platform -> AddrMode -> doc
-pprAddr platform = \case
-   AddrRegReg r1 r2             -> pprReg r1 <> char ',' <+> pprReg r2
-   AddrRegImm r1 (ImmInt i)     -> hcat [ int i, char '(', pprReg r1, char ')' ]
-   AddrRegImm r1 (ImmInteger i) -> hcat [ integer i, char '(', pprReg r1, char ')' ]
-   AddrRegImm r1 imm            -> hcat [ pprImm platform imm, char '(', pprReg r1, char ')' ]
-
-
-pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc
-pprSectionAlign config sec@(Section seg _) =
-   line (pprSectionHeader config sec) $$
-   pprAlignForSection (ncgPlatform config) seg
-
--- | Print appropriate alignment for the given section type.
-pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc
-pprAlignForSection platform seg = line $
- let ppc64    = not $ target32Bit platform
- in case seg of
-       Text              -> text ".align 2"
-       Data
-        | ppc64          -> text ".align 3"
-        | otherwise      -> text ".align 2"
-       ReadOnlyData
-        | ppc64          -> text ".align 3"
-        | otherwise      -> text ".align 2"
-       RelocatableReadOnlyData
-        | ppc64          -> text ".align 3"
-        | otherwise      -> text ".align 2"
-       UninitialisedData
-        | ppc64          -> text ".align 3"
-        | otherwise      -> text ".align 2"
-       -- TODO: This is copied from the ReadOnlyData case, but it can likely be
-       -- made more efficient.
-       InitArray         -> text ".align 3"
-       FiniArray         -> text ".align 3"
-       CString
-        | ppc64          -> text ".align 3"
-        | otherwise      -> text ".align 2"
-       OtherSection _    -> panic "PprMach.pprSectionAlign: unknown section"
-
-pprDataItem :: IsDoc doc => Platform -> CmmLit -> doc
-pprDataItem platform lit
-  = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)
-    where
-        imm = litToImm lit
-        archPPC_64 = not $ target32Bit platform
-
-        ppr_item II8  _ = [text "\t.byte\t"  <> pprImm platform imm]
-        ppr_item II16 _ = [text "\t.short\t" <> pprImm platform imm]
-        ppr_item II32 _ = [text "\t.long\t"  <> pprImm platform imm]
-        ppr_item II64 _
-           | archPPC_64 = [text "\t.quad\t"  <> pprImm platform imm]
-
-        ppr_item II64 (CmmInt x _)
-           | not archPPC_64 =
-                [text "\t.long\t"
-                    <> int (fromIntegral
-                        (fromIntegral (x `shiftR` 32) :: Word32)),
-                 text "\t.long\t"
-                    <> int (fromIntegral (fromIntegral x :: Word32))]
-
-
-        ppr_item FF32 _ = [text "\t.float\t" <> pprImm platform imm]
-        ppr_item FF64 _ = [text "\t.double\t" <> pprImm platform imm]
-
-        ppr_item _ _
-                = panic "PPC.Ppr.pprDataItem: no match"
-
-
-asmComment :: IsLine doc => doc -> doc
-asmComment c = whenPprDebug $ text "#" <+> c
-
-
-pprInstr :: IsDoc doc => Platform -> Instr -> doc
-pprInstr platform instr = case instr of
-
-   COMMENT s
-      -> line (asmComment (ftext s))
-
-   LOCATION file line' col _name
-      -> line (text "\t.loc" <+> int file <+> int line' <+> int col)
-
-   DELTA d
-      -> line (asmComment $ text ("\tdelta = " ++ show d))
-
-   NEWBLOCK _
-      -> panic "PprMach.pprInstr: NEWBLOCK"
-
-   LDATA _ _
-      -> panic "PprMach.pprInstr: LDATA"
-
-{-
-   SPILL reg slot
-      -> hcat [
-              text "\tSPILL",
-           char '\t',
-           pprReg reg,
-           comma,
-           text "SLOT" <> parens (int slot)]
-
-   RELOAD slot reg
-      -> hcat [
-              text "\tRELOAD",
-           char '\t',
-           text "SLOT" <> parens (int slot),
-           comma,
-           pprReg reg]
--}
-
-   LD fmt reg addr
-      -> line $ hcat [
-           char '\t',
-           text "l",
-           (case fmt of
-               II8  -> text "bz"
-               II16 -> text "hz"
-               II32 -> text "wz"
-               II64 -> text "d"
-               FF32 -> text "fs"
-               FF64 -> text "fd"
-               ),
-           case addr of AddrRegImm _ _ -> empty
-                        AddrRegReg _ _ -> char 'x',
-           char '\t',
-           pprReg reg,
-           text ", ",
-           pprAddr platform addr
-       ]
-
-   LDFAR fmt reg (AddrRegImm source off)
-      -> vcat
-            [ pprInstr platform (ADDIS (tmpReg platform) source (HA off))
-            , pprInstr platform (LD fmt reg (AddrRegImm (tmpReg platform) (LO off)))
-            ]
-
-   LDFAR _ _ _
-      -> panic "PPC.Ppr.pprInstr LDFAR: no match"
-
-   LDR fmt reg1 addr
-      -> line $ hcat [
-           text "\tl",
-           case fmt of
-             II32 -> char 'w'
-             II64 -> char 'd'
-             _    -> panic "PPC.Ppr.Instr LDR: no match",
-           text "arx\t",
-           pprReg reg1,
-           text ", ",
-           pprAddr platform addr
-           ]
-
-   LA fmt reg addr
-      -> line $ hcat [
-           char '\t',
-           text "l",
-           (case fmt of
-               II8  -> text "ba"
-               II16 -> text "ha"
-               II32 -> text "wa"
-               II64 -> text "d"
-               FF32 -> text "fs"
-               FF64 -> text "fd"
-               ),
-           case addr of AddrRegImm _ _ -> empty
-                        AddrRegReg _ _ -> char 'x',
-           char '\t',
-           pprReg reg,
-           text ", ",
-           pprAddr platform addr
-           ]
-
-   ST fmt reg addr
-      -> line $ hcat [
-           char '\t',
-           text "st",
-           pprFormat fmt,
-           case addr of AddrRegImm _ _ -> empty
-                        AddrRegReg _ _ -> char 'x',
-           char '\t',
-           pprReg reg,
-           text ", ",
-           pprAddr platform addr
-           ]
-
-   STFAR fmt reg (AddrRegImm source off)
-      -> vcat [ pprInstr platform (ADDIS (tmpReg platform) source (HA off))
-              , pprInstr platform (ST fmt reg (AddrRegImm (tmpReg platform) (LO off)))
-              ]
-
-   STFAR _ _ _
-      -> panic "PPC.Ppr.pprInstr STFAR: no match"
-
-   STU fmt reg addr
-      -> line $ hcat [
-           char '\t',
-           text "st",
-           pprFormat fmt,
-           char 'u',
-           case addr of AddrRegImm _ _ -> empty
-                        AddrRegReg _ _ -> char 'x',
-           char '\t',
-           pprReg reg,
-           text ", ",
-           pprAddr platform addr
-           ]
-
-   STC fmt reg1 addr
-      -> line $ hcat [
-           text "\tst",
-           case fmt of
-             II32 -> char 'w'
-             II64 -> char 'd'
-             _    -> panic "PPC.Ppr.Instr STC: no match",
-           text "cx.\t",
-           pprReg reg1,
-           text ", ",
-           pprAddr platform addr
-           ]
-
-   LIS reg imm
-      -> line $ hcat [
-           char '\t',
-           text "lis",
-           char '\t',
-           pprReg reg,
-           text ", ",
-           pprImm platform imm
-           ]
-
-   LI reg imm
-      -> line $ hcat [
-           char '\t',
-           text "li",
-           char '\t',
-           pprReg reg,
-           text ", ",
-           pprImm platform imm
-           ]
-
-   MR reg1 reg2
-    | reg1 == reg2 -> empty
-    | otherwise    -> line $ hcat [
-        char '\t',
-        case targetClassOfReg platform reg1 of
-            RcInteger -> text "mr"
-            _ -> text "fmr",
-        char '\t',
-        pprReg reg1,
-        text ", ",
-        pprReg reg2
-        ]
-
-   CMP fmt reg ri
-      -> line $ hcat [
-           char '\t',
-           op,
-           char '\t',
-           pprReg reg,
-           text ", ",
-           pprRI platform ri
-           ]
-         where
-           op = hcat [
-                   text "cmp",
-                   pprFormat fmt,
-                   case ri of
-                       RIReg _ -> empty
-                       RIImm _ -> char 'i'
-               ]
-
-   CMPL fmt reg ri
-      -> line $ hcat [
-           char '\t',
-           op,
-           char '\t',
-           pprReg reg,
-           text ", ",
-           pprRI platform ri
-           ]
-          where
-              op = hcat [
-                      text "cmpl",
-                      pprFormat fmt,
-                      case ri of
-                          RIReg _ -> empty
-                          RIImm _ -> char 'i'
-                  ]
-
-   BCC cond blockid prediction
-      -> line $ hcat [
-           char '\t',
-           text "b",
-           pprCond cond,
-           pprPrediction prediction,
-           char '\t',
-           pprAsmLabel platform lbl
-           ]
-         where lbl = mkLocalBlockLabel (getUnique blockid)
-               pprPrediction p = case p of
-                 Nothing    -> empty
-                 Just True  -> char '+'
-                 Just False -> char '-'
-
-   BCCFAR cond blockid prediction
-      -> lines_ [
-           hcat [
-               text "\tb",
-               pprCond (condNegate cond),
-               neg_prediction,
-               text "\t$+8"
-           ],
-           hcat [
-               text "\tb\t",
-               pprAsmLabel platform lbl
-           ]
-          ]
-          where lbl = mkLocalBlockLabel (getUnique blockid)
-                neg_prediction = case prediction of
-                  Nothing    -> empty
-                  Just True  -> char '-'
-                  Just False -> char '+'
-
-   JMP lbl _
-     -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL"
-     | isForeignLabel lbl -> panic "PPC.Ppr.pprInstr: JMP to ForeignLabel"
-     | otherwise ->
-       line $ hcat [ -- an alias for b that takes a CLabel
-           text "\tb\t",
-           pprAsmLabel platform lbl
-       ]
-
-   MTCTR reg
-      -> line $ hcat [
-           char '\t',
-           text "mtctr",
-           char '\t',
-           pprReg reg
-        ]
-
-   BCTR _ _ _
-      -> line $ hcat [
-           char '\t',
-           text "bctr"
-         ]
-
-   BL lbl _
-      -> case platformOS platform of
-           OSAIX ->
-             -- On AIX, "printf" denotes a function-descriptor (for use
-             -- by function pointers), whereas the actual entry-code
-             -- address is denoted by the dot-prefixed ".printf" label.
-             -- Moreover, the PPC NCG only ever emits a BL instruction
-             -- for calling C ABI functions. Most of the time these calls
-             -- originate from FFI imports and have a 'ForeignLabel',
-             -- but when profiling the codegen inserts calls via
-             -- 'emitRtsCallGen' which are 'CmmLabel's even though
-             -- they'd technically be more like 'ForeignLabel's.
-             line $ hcat [
-               text "\tbl\t.",
-               pprAsmLabel platform lbl
-             ]
-           _ ->
-             line $ hcat [
-               text "\tbl\t",
-               pprAsmLabel platform lbl
-             ]
-
-   BCTRL _
-      -> line $ hcat [
-             char '\t',
-             text "bctrl"
-         ]
-
-   ADD reg1 reg2 ri
-      -> pprLogic platform (text "add") reg1 reg2 ri
-
-   ADDIS reg1 reg2 imm
-      -> line $ hcat [
-           char '\t',
-           text "addis",
-           char '\t',
-           pprReg reg1,
-           text ", ",
-           pprReg reg2,
-           text ", ",
-           pprImm platform imm
-           ]
-
-   ADDO reg1 reg2 reg3
-      -> pprLogic platform (text "addo") reg1 reg2 (RIReg reg3)
-
-   ADDC reg1 reg2 reg3
-      -> pprLogic platform (text "addc") reg1 reg2 (RIReg reg3)
-
-   ADDE reg1 reg2 reg3
-      -> pprLogic platform (text "adde") reg1 reg2 (RIReg reg3)
-
-   ADDZE reg1 reg2
-      -> pprUnary (text "addze") reg1 reg2
-
-   SUBF reg1 reg2 reg3
-      -> pprLogic platform (text "subf") reg1 reg2 (RIReg reg3)
-
-   SUBFO reg1 reg2 reg3
-      -> pprLogic platform (text "subfo") reg1 reg2 (RIReg reg3)
-
-   SUBFC reg1 reg2 ri
-      -> line $ hcat [
-           char '\t',
-           text "subf",
-           case ri of
-               RIReg _ -> empty
-               RIImm _ -> char 'i',
-           text "c\t",
-           pprReg reg1,
-           text ", ",
-           pprReg reg2,
-           text ", ",
-           pprRI platform ri
-           ]
-
-   SUBFE reg1 reg2 reg3
-      -> pprLogic platform (text "subfe") reg1 reg2 (RIReg reg3)
-
-   MULL fmt reg1 reg2 ri
-      -> pprMul platform fmt reg1 reg2 ri
-
-   MULLO fmt reg1 reg2 reg3
-      -> line $ hcat [
-             char '\t',
-             text "mull",
-             case fmt of
-               II32 -> char 'w'
-               II64 -> char 'd'
-               _    -> panic "PPC: illegal format",
-             text "o\t",
-             pprReg reg1,
-             text ", ",
-             pprReg reg2,
-             text ", ",
-             pprReg reg3
-         ]
-
-   MFOV fmt reg
-      -> vcat [
-           line $ hcat [
-               char '\t',
-               text "mfxer",
-               char '\t',
-               pprReg reg
-               ],
-           line $ hcat [
-               char '\t',
-               text "extr",
-               case fmt of
-                 II32 -> char 'w'
-                 II64 -> char 'd'
-                 _    -> panic "PPC: illegal format",
-               text "i\t",
-               pprReg reg,
-               text ", ",
-               pprReg reg,
-               text ", 1, ",
-               case fmt of
-                 II32 -> text "1"
-                 II64 -> text "33"
-                 _    -> panic "PPC: illegal format"
-               ]
-           ]
-
-   MULHU fmt reg1 reg2 reg3
-      -> line $ hcat [
-            char '\t',
-            text "mulh",
-            case fmt of
-              II32 -> char 'w'
-              II64 -> char 'd'
-              _    -> panic "PPC: illegal format",
-            text "u\t",
-            pprReg reg1,
-            text ", ",
-            pprReg reg2,
-            text ", ",
-            pprReg reg3
-        ]
-
-   DIV fmt sgn reg1 reg2 reg3
-      -> pprDiv fmt sgn reg1 reg2 reg3
-
-        -- for some reason, "andi" doesn't exist.
-        -- we'll use "andi." instead.
-   AND reg1 reg2 (RIImm imm)
-      -> line $ hcat [
-            char '\t',
-            text "andi.",
-            char '\t',
-            pprReg reg1,
-            text ", ",
-            pprReg reg2,
-            text ", ",
-            pprImm platform imm
-        ]
-
-   AND reg1 reg2 ri
-      -> pprLogic platform (text "and") reg1 reg2 ri
-
-   ANDC reg1 reg2 reg3
-      -> pprLogic platform (text "andc") reg1 reg2 (RIReg reg3)
-
-   NAND reg1 reg2 reg3
-      -> pprLogic platform (text "nand") reg1 reg2 (RIReg reg3)
-
-   OR reg1 reg2 ri
-      -> pprLogic platform (text "or") reg1 reg2 ri
-
-   XOR reg1 reg2 ri
-      -> pprLogic platform (text "xor") reg1 reg2 ri
-
-   ORIS reg1 reg2 imm
-      -> line $ hcat [
-            char '\t',
-            text "oris",
-            char '\t',
-            pprReg reg1,
-            text ", ",
-            pprReg reg2,
-            text ", ",
-            pprImm platform imm
-        ]
-
-   XORIS reg1 reg2 imm
-      -> line $ hcat [
-            char '\t',
-            text "xoris",
-            char '\t',
-            pprReg reg1,
-            text ", ",
-            pprReg reg2,
-            text ", ",
-            pprImm platform imm
-        ]
-
-   EXTS fmt reg1 reg2
-      -> line $ hcat [
-           char '\t',
-           text "exts",
-           pprFormat fmt,
-           char '\t',
-           pprReg reg1,
-           text ", ",
-           pprReg reg2
-         ]
-
-   CNTLZ fmt reg1 reg2
-      -> line $ hcat [
-           char '\t',
-           text "cntlz",
-           case fmt of
-             II32 -> char 'w'
-             II64 -> char 'd'
-             _    -> panic "PPC: illegal format",
-           char '\t',
-           pprReg reg1,
-           text ", ",
-           pprReg reg2
-         ]
-
-   NEG reg1 reg2
-      -> pprUnary (text "neg") reg1 reg2
-
-   NOT reg1 reg2
-      -> pprUnary (text "not") reg1 reg2
-
-   SR II32 reg1 reg2 (RIImm (ImmInt i))
-    -- Handle the case where we are asked to shift a 32 bit register by
-    -- less than zero or more than 31 bits. We convert this into a clear
-    -- of the destination register.
-    -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/5900
-      | i < 0  || i > 31 -> pprInstr platform (XOR reg1 reg2 (RIReg reg2))
-
-   SL II32 reg1 reg2 (RIImm (ImmInt i))
-    -- As above for SR, but for left shifts.
-    -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/10870
-      | i < 0  || i > 31 -> pprInstr platform (XOR reg1 reg2 (RIReg reg2))
-
-   SRA II32 reg1 reg2 (RIImm (ImmInt i))
-    -- PT: I don't know what to do for negative shift amounts:
-    -- For now just panic.
-    --
-    -- For shift amounts greater than 31 set all bit to the
-    -- value of the sign bit, this also what sraw does.
-      | i > 31 -> pprInstr platform (SRA II32 reg1 reg2 (RIImm (ImmInt 31)))
-
-   SL fmt reg1 reg2 ri
-      -> let op = case fmt of
-                       II32 -> text "slw"
-                       II64 -> text "sld"
-                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"
-         in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri)
-
-   SR fmt reg1 reg2 ri
-      -> let op = case fmt of
-                       II32 -> text "srw"
-                       II64 -> text "srd"
-                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"
-         in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri)
-
-   SRA fmt reg1 reg2 ri
-      -> let op = case fmt of
-                       II32 -> text "sraw"
-                       II64 -> text "srad"
-                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"
-         in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri)
-
-   RLWINM reg1 reg2 sh mb me
-      -> line $ hcat [
-             text "\trlwinm\t",
-             pprReg reg1,
-             text ", ",
-             pprReg reg2,
-             text ", ",
-             int sh,
-             text ", ",
-             int mb,
-             text ", ",
-             int me
-         ]
-
-   CLRLI fmt reg1 reg2 n
-      -> line $ hcat [
-            text "\tclrl",
-            pprFormat fmt,
-            text "i ",
-            pprReg reg1,
-            text ", ",
-            pprReg reg2,
-            text ", ",
-            int n
-        ]
-
-   CLRRI fmt reg1 reg2 n
-      -> line $ hcat [
-            text "\tclrr",
-            pprFormat fmt,
-            text "i ",
-            pprReg reg1,
-            text ", ",
-            pprReg reg2,
-            text ", ",
-            int n
-        ]
-
-   FADD fmt reg1 reg2 reg3
-      -> pprBinaryF (text "fadd") fmt reg1 reg2 reg3
-
-   FSUB fmt reg1 reg2 reg3
-      -> pprBinaryF (text "fsub") fmt reg1 reg2 reg3
-
-   FMUL fmt reg1 reg2 reg3
-      -> pprBinaryF (text "fmul") fmt reg1 reg2 reg3
-
-   FDIV fmt reg1 reg2 reg3
-      -> pprBinaryF (text "fdiv") fmt reg1 reg2 reg3
-
-   FABS reg1 reg2
-      -> pprUnary (text "fabs") reg1 reg2
-
-   FNEG reg1 reg2
-      -> pprUnary (text "fneg") reg1 reg2
-
-   FCMP reg1 reg2
-      -> line $ hcat [
-           char '\t',
-           text "fcmpu\t0, ",
-               -- Note: we're using fcmpu, not fcmpo
-               -- The difference is with fcmpo, compare with NaN is an invalid operation.
-               -- We don't handle invalid fp ops, so we don't care.
-               -- Moreover, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for
-               -- better portability since some non-GNU assembler (such as
-               -- IBM's `as`) tend not to support the symbolic register name cr0.
-               -- This matches the syntax that GCC seems to emit for PPC targets.
-           pprReg reg1,
-           text ", ",
-           pprReg reg2
-         ]
-
-   FCTIWZ reg1 reg2
-      -> pprUnary (text "fctiwz") reg1 reg2
-
-   FCTIDZ reg1 reg2
-      -> pprUnary (text "fctidz") reg1 reg2
-
-   FCFID reg1 reg2
-      -> pprUnary (text "fcfid") reg1 reg2
-
-   FRSP reg1 reg2
-      -> pprUnary (text "frsp") reg1 reg2
-
-   CRNOR dst src1 src2
-      -> line $ hcat [
-           text "\tcrnor\t",
-           int dst,
-           text ", ",
-           int src1,
-           text ", ",
-           int src2
-         ]
-
-   MFCR reg
-      -> line $ hcat [
-             char '\t',
-             text "mfcr",
-             char '\t',
-             pprReg reg
-         ]
-
-   MFLR reg
-      -> line $ hcat [
-           char '\t',
-           text "mflr",
-           char '\t',
-           pprReg reg
-         ]
-
-   FETCHPC reg
-      -> lines_ [
-             text "\tbcl\t20,31,1f",
-             hcat [ text "1:\tmflr\t", pprReg reg ]
-         ]
-
-   HWSYNC
-      -> line $ text "\tsync"
-
-   ISYNC
-      -> line $ text "\tisync"
-
-   LWSYNC
-      -> line $ text "\tlwsync"
-
-   NOP
-      -> line $ text "\tnop"
-
-pprLogic :: IsDoc doc => Platform -> Line doc -> Reg -> Reg -> RI -> doc
-pprLogic platform op reg1 reg2 ri = line $ hcat [
-        char '\t',
-        op,
-        case ri of
-            RIReg _ -> empty
-            RIImm _ -> char 'i',
-        char '\t',
-        pprReg reg1,
-        text ", ",
-        pprReg reg2,
-        text ", ",
-        pprRI platform ri
-    ]
-
-
-pprMul :: IsDoc doc => Platform -> Format -> Reg -> Reg -> RI -> doc
-pprMul platform fmt reg1 reg2 ri = line $ hcat [
-        char '\t',
-        text "mull",
-        case ri of
-            RIReg _ -> case fmt of
-              II32 -> char 'w'
-              II64 -> char 'd'
-              _    -> panic "PPC: illegal format"
-            RIImm _ -> char 'i',
-        char '\t',
-        pprReg reg1,
-        text ", ",
-        pprReg reg2,
-        text ", ",
-        pprRI platform ri
-    ]
-
-
-pprDiv :: IsDoc doc => Format -> Bool -> Reg -> Reg -> Reg -> doc
-pprDiv fmt sgn reg1 reg2 reg3 = line $ hcat [
-        char '\t',
-        text "div",
-        case fmt of
-          II32 -> char 'w'
-          II64 -> char 'd'
-          _    -> panic "PPC: illegal format",
-        if sgn then empty else char 'u',
-        char '\t',
-        pprReg reg1,
-        text ", ",
-        pprReg reg2,
-        text ", ",
-        pprReg reg3
-    ]
-
-
-pprUnary :: IsDoc doc => Line doc -> Reg -> Reg -> doc
-pprUnary op reg1 reg2 = line $ hcat [
-        char '\t',
-        op,
-        char '\t',
-        pprReg reg1,
-        text ", ",
-        pprReg reg2
-    ]
-
-
-pprBinaryF :: IsDoc doc => Line doc -> Format -> Reg -> Reg -> Reg -> doc
-pprBinaryF op fmt reg1 reg2 reg3 = line $ hcat [
-        char '\t',
-        op,
-        pprFFormat fmt,
-        char '\t',
-        pprReg reg1,
-        text ", ",
-        pprReg reg2,
-        text ", ",
-        pprReg reg3
-    ]
-
-pprRI :: IsLine doc => Platform -> RI -> doc
-pprRI _        (RIReg r) = pprReg r
-pprRI platform (RIImm r) = pprImm platform r
-
-
-pprFFormat :: IsLine doc => Format -> doc
-pprFFormat FF64     = empty
-pprFFormat FF32     = char 's'
-pprFFormat _        = panic "PPC.Ppr.pprFFormat: no match"
-
-    -- limit immediate argument for shift instruction to range 0..63
-    -- for 64 bit size and 0..32 otherwise
-limitShiftRI :: Format -> RI -> RI
-limitShiftRI II64 (RIImm (ImmInt i)) | i > 63 || i < 0 =
-  panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed."
-limitShiftRI II32 (RIImm (ImmInt i)) | i > 31 || i < 0 =
-  panic $ "PPC.Ppr: 32 bit: Shift by " ++ show i ++ " bits is not allowed."
-limitShiftRI _ x = x
diff --git a/compiler/GHC/CmmToAsm/PPC/RegInfo.hs b/compiler/GHC/CmmToAsm/PPC/RegInfo.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/PPC/RegInfo.hs
+++ /dev/null
@@ -1,77 +0,0 @@
-
------------------------------------------------------------------------------
---
--- Machine-specific parts of the register allocator
---
--- (c) The University of Glasgow 1996-2004
---
------------------------------------------------------------------------------
-module GHC.CmmToAsm.PPC.RegInfo (
-        JumpDest( DestBlockId ), getJumpDestBlockId,
-        canShortcut,
-        shortcutJump,
-
-        shortcutStatics
-)
-
-where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.PPC.Instr
-
-import GHC.Cmm.BlockId
-import GHC.Cmm
-import GHC.Cmm.CLabel
-
-import GHC.Types.Unique
-import GHC.Utils.Outputable (ppr, text, Outputable, (<>))
-
-data JumpDest = DestBlockId BlockId
-
--- Debug Instance
-instance Outputable JumpDest where
-  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid
-
-getJumpDestBlockId :: JumpDest -> Maybe BlockId
-getJumpDestBlockId (DestBlockId bid) = Just bid
-
-canShortcut :: Instr -> Maybe JumpDest
-canShortcut _ = Nothing
-
-shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
-shortcutJump _ other = other
-
-
--- Here because it knows about JumpDest
-shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics
-shortcutStatics fn (CmmStaticsRaw lbl statics)
-  = CmmStaticsRaw lbl $ map (shortcutStatic fn) statics
-  -- we need to get the jump tables, so apply the mapping to the entries
-  -- of a CmmData too.
-
-shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
-shortcutLabel fn lab
-  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId
-  | otherwise                              = lab
-
-shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
-shortcutStatic fn (CmmStaticLit (CmmLabel lab))
-  = CmmStaticLit (CmmLabel (shortcutLabel fn lab))
-shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w))
-  = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w)
-        -- slightly dodgy, we're ignoring the second label, but this
-        -- works with the way we use CmmLabelDiffOff for jump tables now.
-shortcutStatic _ other_static
-        = other_static
-
-shortBlockId
-        :: (BlockId -> Maybe JumpDest)
-        -> BlockId
-        -> CLabel
-
-shortBlockId fn blockid =
-   case fn blockid of
-      Nothing -> mkLocalBlockLabel uq
-      Just (DestBlockId blockid')  -> shortBlockId fn blockid'
-   where uq = getUnique blockid
diff --git a/compiler/GHC/CmmToAsm/PPC/Regs.hs b/compiler/GHC/CmmToAsm/PPC/Regs.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/PPC/Regs.hs
+++ /dev/null
@@ -1,328 +0,0 @@
--- -----------------------------------------------------------------------------
---
--- (c) The University of Glasgow 1994-2004
---
--- -----------------------------------------------------------------------------
-
-module GHC.CmmToAsm.PPC.Regs (
-        -- squeeze functions
-        virtualRegSqueeze,
-        realRegSqueeze,
-
-        mkVirtualReg,
-        regDotColor,
-
-        -- immediates
-        Imm(..),
-        strImmLit,
-        litToImm,
-
-        -- addressing modes
-        AddrMode(..),
-        addrOffset,
-
-        -- registers
-        spRel,
-        argRegs,
-        allArgRegs,
-        callClobberedRegs,
-        allMachRegNos,
-        classOfRealReg,
-        showReg,
-        toRegNo,
-
-        -- machine specific
-        allFPArgRegs,
-        fits16Bits,
-        makeImmediate,
-        fReg,
-        r0, sp, toc, r3, r4, r11, r12, r30,
-        tmpReg,
-        f1,
-
-        allocatableRegs
-
-)
-
-where
-
-import GHC.Prelude
-import GHC.Data.FastString
-
-import GHC.Platform.Reg
-import GHC.Platform.Reg.Class
-import GHC.CmmToAsm.Format
-
-import GHC.Cmm
-import GHC.Cmm.CLabel           ( CLabel )
-import GHC.Types.Unique
-
-import GHC.Platform.Regs
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Platform
-
-import Data.Word        ( Word8, Word16, Word32, Word64 )
-import Data.Int         ( Int8, Int16, Int32, Int64 )
-
-
--- squeese functions for the graph allocator -----------------------------------
-
--- | regSqueeze_class reg
---      Calculate the maximum number of register colors that could be
---      denied to a node of this class due to having this reg
---      as a neighbour.
---
-{-# INLINE virtualRegSqueeze #-}
-virtualRegSqueeze :: RegClass -> VirtualReg -> Int
-virtualRegSqueeze cls vr
- = case cls of
-        RcInteger
-         -> case vr of
-                VirtualRegI{}           -> 1
-                VirtualRegHi{}          -> 1
-                _other                  -> 0
-
-        RcDouble
-         -> case vr of
-                VirtualRegD{}           -> 1
-                VirtualRegF{}           -> 0
-                _other                  -> 0
-
-        _other -> 0
-
-{-# INLINE realRegSqueeze #-}
-realRegSqueeze :: RegClass -> RealReg -> Int
-realRegSqueeze cls rr
- = case cls of
-        RcInteger
-         -> case rr of
-                RealRegSingle regNo
-                        | regNo < 32    -> 1     -- first fp reg is 32
-                        | otherwise     -> 0
-
-
-        RcDouble
-         -> case rr of
-                RealRegSingle regNo
-                        | regNo < 32    -> 0
-                        | otherwise     -> 1
-
-
-        _other -> 0
-
-mkVirtualReg :: Unique -> Format -> VirtualReg
-mkVirtualReg u format
-   | not (isFloatFormat format) = VirtualRegI u
-   | otherwise
-   = case format of
-        FF32    -> VirtualRegD u
-        FF64    -> VirtualRegD u
-        _       -> panic "mkVirtualReg"
-
-regDotColor :: RealReg -> SDoc
-regDotColor reg
- = case classOfRealReg reg of
-        RcInteger       -> text "blue"
-        RcFloat         -> text "red"
-        RcDouble        -> text "green"
-
-
-
--- immediates ------------------------------------------------------------------
-data Imm
-        = ImmInt        Int
-        | ImmInteger    Integer     -- Sigh.
-        | ImmCLbl       CLabel      -- AbstractC Label (with baggage)
-        | ImmLit        FastString
-        | ImmIndex    CLabel Int
-        | ImmFloat      Rational
-        | ImmDouble     Rational
-        | ImmConstantSum Imm Imm
-        | ImmConstantDiff Imm Imm
-        | LO Imm
-        | HI Imm
-        | HA Imm        {- high halfword adjusted -}
-        | HIGHERA Imm
-        | HIGHESTA Imm
-
-
-strImmLit :: FastString -> Imm
-strImmLit s = ImmLit s
-
-
-litToImm :: CmmLit -> Imm
-litToImm (CmmInt i w)        = ImmInteger (narrowS w i)
-                -- narrow to the width: a CmmInt might be out of
-                -- range, but we assume that ImmInteger only contains
-                -- in-range values.  A signed value should be fine here.
-litToImm (CmmFloat f W32)    = ImmFloat f
-litToImm (CmmFloat f W64)    = ImmDouble f
-litToImm (CmmLabel l)        = ImmCLbl l
-litToImm (CmmLabelOff l off) = ImmIndex l off
-litToImm (CmmLabelDiffOff l1 l2 off _)
-                             = ImmConstantSum
-                               (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
-                               (ImmInt off)
-litToImm _                   = panic "PPC.Regs.litToImm: no match"
-
-
--- addressing modes ------------------------------------------------------------
-
-data AddrMode
-        = AddrRegReg    Reg Reg
-        | AddrRegImm    Reg Imm
-
-
-addrOffset :: AddrMode -> Int -> Maybe AddrMode
-addrOffset addr off
-  = case addr of
-      AddrRegImm r (ImmInt n)
-       | fits16Bits n2 -> Just (AddrRegImm r (ImmInt n2))
-       | otherwise     -> Nothing
-       where n2 = n + off
-
-      AddrRegImm r (ImmInteger n)
-       | fits16Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2)))
-       | otherwise     -> Nothing
-       where n2 = n + toInteger off
-
-      _ -> Nothing
-
-
--- registers -------------------------------------------------------------------
--- @spRel@ gives us a stack relative addressing mode for volatile
--- temporaries and for excess call arguments.  @fpRel@, where
--- applicable, is the same but for the frame pointer.
-
-spRel :: Platform
-      -> Int    -- desired stack offset in words, positive or negative
-      -> AddrMode
-
-spRel platform n = AddrRegImm sp (ImmInt (n * platformWordSizeInBytes platform))
-
-
--- argRegs is the set of regs which are read for an n-argument call to C.
--- For archs which pass all args on the stack (x86), is empty.
--- Sparc passes up to the first 6 args in regs.
-argRegs :: RegNo -> [Reg]
-argRegs 0 = []
-argRegs 1 = map regSingle [3]
-argRegs 2 = map regSingle [3,4]
-argRegs 3 = map regSingle [3..5]
-argRegs 4 = map regSingle [3..6]
-argRegs 5 = map regSingle [3..7]
-argRegs 6 = map regSingle [3..8]
-argRegs 7 = map regSingle [3..9]
-argRegs 8 = map regSingle [3..10]
-argRegs _ = panic "MachRegs.argRegs(powerpc): don't know about >8 arguments!"
-
-
-allArgRegs :: [Reg]
-allArgRegs = map regSingle [3..10]
-
-
--- these are the regs which we cannot assume stay alive over a C call.
-callClobberedRegs :: Platform -> [Reg]
-callClobberedRegs _platform
-  = map regSingle (0:[2..12] ++ map fReg [0..13])
-
-
-allMachRegNos   :: [RegNo]
-allMachRegNos   = [0..63]
-
-
-{-# INLINE classOfRealReg      #-}
-classOfRealReg :: RealReg -> RegClass
-classOfRealReg (RealRegSingle i)
-        | i < 32        = RcInteger
-        | otherwise     = RcDouble
-
-showReg :: RegNo -> String
-showReg n
-    | n >= 0 && n <= 31   = "%r" ++ show n
-    | n >= 32 && n <= 63  = "%f" ++ show (n - 32)
-    | otherwise           = "%unknown_powerpc_real_reg_" ++ show n
-
-toRegNo :: Reg -> RegNo
-toRegNo (RegReal (RealRegSingle n)) = n
-toRegNo _                           = panic "PPC.toRegNo: unsupported register"
-
--- machine specific ------------------------------------------------------------
-
-allFPArgRegs :: Platform -> [Reg]
-allFPArgRegs platform
-    = case platformOS platform of
-      OSAIX    -> map (regSingle . fReg) [1..13]
-      _        -> case platformArch platform of
-        ArchPPC      -> map (regSingle . fReg) [1..8]
-        ArchPPC_64 _ -> map (regSingle . fReg) [1..13]
-        _            -> panic "PPC.Regs.allFPArgRegs: unknown PPC Linux"
-
-fits16Bits :: Integral a => a -> Bool
-fits16Bits x = x >= -32768 && x < 32768
-
-makeImmediate :: Integral a => Width -> Bool -> a -> Maybe Imm
-makeImmediate rep signed x = fmap ImmInt (toI16 rep signed)
-    where
-        narrow W64 False = fromIntegral (fromIntegral x :: Word64)
-        narrow W32 False = fromIntegral (fromIntegral x :: Word32)
-        narrow W16 False = fromIntegral (fromIntegral x :: Word16)
-        narrow W8  False = fromIntegral (fromIntegral x :: Word8)
-        narrow W64 True  = fromIntegral (fromIntegral x :: Int64)
-        narrow W32 True  = fromIntegral (fromIntegral x :: Int32)
-        narrow W16 True  = fromIntegral (fromIntegral x :: Int16)
-        narrow W8  True  = fromIntegral (fromIntegral x :: Int8)
-        narrow _   _     = panic "PPC.Regs.narrow: no match"
-
-        narrowed = narrow rep signed
-
-        toI16 W32 True
-            | narrowed >= -32768 && narrowed < 32768 = Just narrowed
-            | otherwise = Nothing
-        toI16 W32 False
-            | narrowed >= 0 && narrowed < 65536 = Just narrowed
-            | otherwise = Nothing
-        toI16 W64 True
-            | narrowed >= -32768 && narrowed < 32768 = Just narrowed
-            | otherwise = Nothing
-        toI16 W64 False
-            | narrowed >= 0 && narrowed < 65536 = Just narrowed
-            | otherwise = Nothing
-        toI16 _ _  = Just narrowed
-
-
-{-
-The PowerPC has 64 registers of interest; 32 integer registers and 32 floating
-point registers.
--}
-
-fReg :: Int -> RegNo
-fReg x = (32 + x)
-
-r0, sp, toc, r3, r4, r11, r12, r30, f1 :: Reg
-r0      = regSingle 0
-sp      = regSingle 1
-toc     = regSingle 2
-r3      = regSingle 3
-r4      = regSingle 4
-r11     = regSingle 11
-r12     = regSingle 12
-r30     = regSingle 30
-f1      = regSingle $ fReg 1
-
--- allocatableRegs is allMachRegNos with the fixed-use regs removed.
--- i.e., these are the regs for which we are prepared to allow the
--- register allocator to attempt to map VRegs to.
-allocatableRegs :: Platform -> [RealReg]
-allocatableRegs platform
-   = let isFree i = freeReg platform i
-     in  map RealRegSingle $ filter isFree allMachRegNos
-
--- temporary register for compiler use
-tmpReg :: Platform -> Reg
-tmpReg platform =
-       case platformArch platform of
-       ArchPPC      -> regSingle 13
-       ArchPPC_64 _ -> regSingle 30
-       _            -> panic "PPC.Regs.tmpReg: unknown arch"
diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Ppr.hs
+++ /dev/null
@@ -1,282 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE MagicHash #-}
-
------------------------------------------------------------------------------
---
--- Pretty-printing assembly language
---
--- (c) The University of Glasgow 1993-2005
---
------------------------------------------------------------------------------
-
-module GHC.CmmToAsm.Ppr (
-        doubleToBytes,
-        floatToBytes,
-        pprASCII,
-        pprString,
-        pprFileEmbed,
-        pprSectionHeader
-)
-
-where
-
-import GHC.Prelude
-
-import GHC.Utils.Asm
-import GHC.Cmm.CLabel
-import GHC.Cmm
-import GHC.CmmToAsm.Config
-import GHC.Utils.Outputable as SDoc
-import GHC.Utils.Panic
-import GHC.Platform
-
-import qualified Data.Array.Unsafe as U ( castSTUArray )
-import Data.Array.ST
-
-import Control.Monad.ST
-import Data.Word
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
-import GHC.Exts
-import GHC.Word
-
-#if !MIN_VERSION_base(4,16,0)
-word8ToWord# :: Word# -> Word#
-word8ToWord# w = w
-{-# INLINE word8ToWord# #-}
-#endif
-
--- -----------------------------------------------------------------------------
--- Converting floating-point literals to integrals for printing
-
--- | Get bytes of a Float representation
-floatToBytes :: Float -> [Word8]
-floatToBytes f = runST $ do
-  arr <- newArray_ ((0::Int),3)
-  writeArray arr 0 f
-  let cast :: STUArray s Int Float -> ST s (STUArray s Int Word8)
-      cast = U.castSTUArray
-  arr <- cast arr
-  i0 <- readArray arr 0
-  i1 <- readArray arr 1
-  i2 <- readArray arr 2
-  i3 <- readArray arr 3
-  return [i0,i1,i2,i3]
-
--- | Get bytes of a Double representation
-doubleToBytes :: Double -> [Word8]
-doubleToBytes d = runST $ do
-  arr <- newArray_ ((0::Int),7)
-  writeArray arr 0 d
-  let cast :: STUArray s Int Double -> ST s (STUArray s Int Word8)
-      cast = U.castSTUArray
-  arr <- cast arr
-  i0 <- readArray arr 0
-  i1 <- readArray arr 1
-  i2 <- readArray arr 2
-  i3 <- readArray arr 3
-  i4 <- readArray arr 4
-  i5 <- readArray arr 5
-  i6 <- readArray arr 6
-  i7 <- readArray arr 7
-  return [i0,i1,i2,i3,i4,i5,i6,i7]
-
-
--- ---------------------------------------------------------------------------
--- Printing ASCII strings.
---
--- Print as a string and escape non-printable characters.
--- This is similar to charToC in GHC.Utils.Misc
-
-pprASCII :: forall doc. IsLine doc => ByteString -> doc
-pprASCII str
-  -- Transform this given literal bytestring to escaped string and construct
-  -- the literal SDoc directly.
-  -- See #14741
-  -- and Note [Pretty print ASCII when AsmCodeGen]
-  --
-  -- We work with a `Doc` instead of an `SDoc` because there is no need to carry
-  -- an `SDocContext` that we don't use. It leads to nicer (STG) code.
-  = BS.foldr f empty str
-    where
-       f :: Word8 -> doc -> doc
-       f w s = do1 w <> s
-
-       do1 :: Word8 -> doc
-       do1 w | 0x09 == w = text "\\t"
-             | 0x0A == w = text "\\n"
-             | 0x22 == w = text "\\\""
-             | 0x5C == w = text "\\\\"
-               -- ASCII printable characters range
-             | w >= 0x20 && w <= 0x7E = char (chr' w)
-             | otherwise = text xs
-                where
-                 !xs = [ '\\', x0, x1, x2] -- octal
-                 !x0 = chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)
-                 !x1 = chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07)
-                 !x2 = chr' (ord0 + w .&. 0x07)
-                 !ord0 = 0x30 -- = ord '0'
-
-       -- we know that the Chars we create are in the ASCII range
-       -- so we bypass the check in "chr"
-       chr' :: Word8 -> Char
-       chr' (W8# w#) = C# (chr# (word2Int# (word8ToWord# w#)))
-{-# SPECIALIZE pprASCII :: ByteString -> SDoc #-}
-{-# SPECIALIZE pprASCII :: ByteString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Emit a ".string" directive
-pprString :: IsLine doc => ByteString -> doc
-pprString bs = text "\t.string " <> doubleQuotes (pprASCII bs)
-{-# SPECIALIZE pprString :: ByteString -> SDoc #-}
-{-# SPECIALIZE pprString :: ByteString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Emit a ".incbin" directive
---
--- A NULL byte is added after the binary data.
-pprFileEmbed :: IsLine doc => FilePath -> doc
-pprFileEmbed path
-   = text "\t.incbin "
-     <> pprFilePathString path -- proper escape (see #16389)
-     <> text "\n\t.byte 0"
-{-# SPECIALIZE pprFileEmbed :: FilePath -> SDoc #-}
-{-# SPECIALIZE pprFileEmbed :: FilePath -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
-{-
-Note [Embedding large binary blobs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-To embed a blob of binary data (e.g. an UTF-8 encoded string) into the generated
-code object, we have several options:
-
-   1. Generate a ".byte" directive for each byte. This is what was done in the past
-      (see Note [Pretty print ASCII when AsmCodeGen]).
-
-   2. Generate a single ".string"/".asciz" directive for the whole sequence of
-      bytes. Bytes in the ASCII printable range are rendered as characters and
-      other values are escaped (e.g., "\t", "\077", etc.).
-
-   3. Create a temporary file into which we dump the binary data and generate a
-      single ".incbin" directive. The assembler will include the binary file for
-      us in the generated output object.
-
-Now the code generator uses either (2) or (3), depending on the binary blob
-size.  Using (3) for small blobs adds too much overhead (see benchmark results
-in #16190), so we only do it when the size is above a threshold (500K at the
-time of writing).
-
-The threshold is configurable via the `-fbinary-blob-threshold` flag.
-
--}
-
-
-{-
-Note [Pretty print ASCII when AsmCodeGen]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Previously, when generating assembly code, we created SDoc with
-`(ptext . sLit)` for every bytes in literal bytestring, then
-combine them using `hcat`.
-
-When handling literal bytestrings with millions of bytes,
-millions of SDoc would be created and to combine, leading to
-high memory usage.
-
-Now we escape the given bytestring to string directly and construct
-SDoc only once. This improvement could dramatically decrease the
-memory allocation from 4.7GB to 1.3GB when embedding a 3MB literal
-string in source code. See #14741 for profiling results.
--}
-
--- ----------------------------------------------------------------------------
--- Printing section headers.
---
--- If -split-section was specified, include the suffix label, otherwise just
--- print the section type. For Darwin, where subsections-for-symbols are
--- used instead, only print section type.
---
--- For string literals, additional flags are specified to enable merging of
--- identical strings in the linker. With -split-sections each string also gets
--- a unique section to allow strings from unused code to be GC'd.
-
-pprSectionHeader :: IsLine doc => NCGConfig -> Section -> doc
-pprSectionHeader config (Section t suffix) =
- case platformOS (ncgPlatform config) of
-   OSAIX     -> pprXcoffSectionHeader t
-   OSDarwin  -> pprDarwinSectionHeader t
-   _         -> pprGNUSectionHeader config t suffix
-{-# SPECIALIZE pprSectionHeader :: NCGConfig -> Section -> SDoc #-}
-{-# SPECIALIZE pprSectionHeader :: NCGConfig -> Section -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
-pprGNUSectionHeader :: IsLine doc => NCGConfig -> SectionType -> CLabel -> doc
-pprGNUSectionHeader config t suffix =
-  hcat [text ".section ", header, subsection, flags]
-  where
-    sep
-      | OSMinGW32 <- platformOS platform = char '$'
-      | otherwise                        = char '.'
-    platform      = ncgPlatform config
-    splitSections = ncgSplitSections config
-    subsection
-      | splitSections = sep <> pprAsmLabel platform suffix
-      | otherwise     = empty
-    header = case t of
-      Text -> text ".text"
-      Data -> text ".data"
-      ReadOnlyData  | OSMinGW32 <- platformOS platform
-                                -> text ".rdata"
-                    | otherwise -> text ".rodata"
-      RelocatableReadOnlyData | OSMinGW32 <- platformOS platform
-                                -- Concept does not exist on Windows,
-                                -- So map these to R/O data.
-                                          -> text ".rdata$rel.ro"
-                              | otherwise -> text ".data.rel.ro"
-      UninitialisedData -> text ".bss"
-      InitArray
-        | OSMinGW32 <- platformOS platform
-                    -> text ".ctors"
-        | otherwise -> text ".init_array"
-      FiniArray
-        | OSMinGW32 <- platformOS platform
-                    -> text ".dtors"
-        | otherwise -> text ".fini_array"
-      CString
-        | OSMinGW32 <- platformOS platform
-                    -> text ".rdata"
-        | otherwise -> text ".rodata.str"
-      OtherSection _ ->
-        panic "PprBase.pprGNUSectionHeader: unknown section type"
-    flags = case t of
-      CString
-        | OSMinGW32 <- platformOS platform
-                    -> empty
-        | otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1"
-      _ -> empty
-{-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc #-}
-{-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- XCOFF doesn't support relocating label-differences, so we place all
--- RO sections into .text[PR] sections
-pprXcoffSectionHeader :: IsLine doc => SectionType -> doc
-pprXcoffSectionHeader t = case t of
-  Text                    -> text ".csect .text[PR]"
-  Data                    -> text ".csect .data[RW]"
-  ReadOnlyData            -> text ".csect .text[PR] # ReadOnlyData"
-  RelocatableReadOnlyData -> text ".csect .text[PR] # RelocatableReadOnlyData"
-  CString                 -> text ".csect .text[PR] # CString"
-  UninitialisedData       -> text ".csect .data[BS]"
-  _                       -> panic "pprXcoffSectionHeader: unknown section type"
-{-# SPECIALIZE pprXcoffSectionHeader :: SectionType -> SDoc #-}
-{-# SPECIALIZE pprXcoffSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
-pprDarwinSectionHeader :: IsLine doc => SectionType -> doc
-pprDarwinSectionHeader t = case t of
-  Text                    -> text ".text"
-  Data                    -> text ".data"
-  ReadOnlyData            -> text ".const"
-  RelocatableReadOnlyData -> text ".const_data"
-  UninitialisedData       -> text ".data"
-  InitArray               -> text ".section\t__DATA,__mod_init_func,mod_init_funcs"
-  FiniArray               -> panic "pprDarwinSectionHeader: fini not supported"
-  CString                 -> text ".section\t__TEXT,__cstring,cstring_literals"
-  OtherSection _          -> panic "pprDarwinSectionHeader: unknown section type"
-{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> SDoc #-}
-{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph.hs b/compiler/GHC/CmmToAsm/Reg/Graph.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph.hs
+++ /dev/null
@@ -1,480 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-
--- | Graph coloring register allocator.
-module GHC.CmmToAsm.Reg.Graph (
-        regAlloc
-) where
-import GHC.Prelude
-
-import qualified GHC.Data.Graph.Color as Color
-import GHC.CmmToAsm.Reg.Liveness
-import GHC.CmmToAsm.Reg.Graph.Spill
-import GHC.CmmToAsm.Reg.Graph.SpillClean
-import GHC.CmmToAsm.Reg.Graph.SpillCost
-import GHC.CmmToAsm.Reg.Graph.Stats
-import GHC.CmmToAsm.Reg.Graph.TrivColorable
-import GHC.CmmToAsm.Instr
-import GHC.CmmToAsm.Reg.Target
-import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Types
-import GHC.Platform.Reg.Class
-import GHC.Platform.Reg
-
-import GHC.Data.Bag
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Platform
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.Supply
-import GHC.Utils.Misc (seqList)
-import GHC.CmmToAsm.CFG
-
-import Data.Maybe
-import Control.Monad
-
-
--- | The maximum number of build\/spill cycles we'll allow.
---
---   It should only take 3 or 4 cycles for the allocator to converge.
---   If it takes any longer than this it's probably in an infinite loop,
---   so it's better just to bail out and report a bug.
-maxSpinCount    :: Int
-maxSpinCount    = 10
-
-
--- | The top level of the graph coloring register allocator.
-regAlloc
-        :: (OutputableP Platform statics, Instruction instr)
-        => NCGConfig
-        -> UniqFM RegClass (UniqSet RealReg)     -- ^ registers we can use for allocation
-        -> UniqSet Int                  -- ^ set of available spill slots.
-        -> Int                          -- ^ current number of spill slots
-        -> [LiveCmmDecl statics instr]  -- ^ code annotated with liveness information.
-        -> Maybe CFG                    -- ^ CFG of basic blocks if available
-        -> UniqSM ( [NatCmmDecl statics instr]
-                  , Maybe Int, [RegAllocStats statics instr] )
-           -- ^ code with registers allocated, additional stacks required
-           -- and stats for each stage of allocation
-
-regAlloc config regsFree slotsFree slotsCount code cfg
- = do
-        let platform = ncgPlatform config
-            triv = trivColorable platform
-                        (targetVirtualRegSqueeze platform)
-                        (targetRealRegSqueeze platform)
-
-        (code_final, debug_codeGraphs, slotsCount', _)
-                <- regAlloc_spin config 0
-                        triv
-                        regsFree slotsFree slotsCount [] code cfg
-
-        let needStack
-                | slotsCount == slotsCount'
-                = Nothing
-                | otherwise
-                = Just slotsCount'
-
-        return  ( code_final
-                , needStack
-                , reverse debug_codeGraphs )
-
-
--- | Perform solver iterations for the graph coloring allocator.
---
---   We extract a register conflict graph from the provided cmm code,
---   and try to colour it. If that works then we use the solution rewrite
---   the code with real hregs. If coloring doesn't work we add spill code
---   and try to colour it again. After `maxSpinCount` iterations we give up.
---
-regAlloc_spin
-        :: forall instr statics.
-           (Instruction instr,
-            OutputableP Platform statics)
-        => NCGConfig
-        -> Int  -- ^ Number of solver iterations we've already performed.
-        -> Color.Triv VirtualReg RegClass RealReg
-                -- ^ Function for calculating whether a register is trivially
-                --   colourable.
-        -> UniqFM RegClass (UniqSet RealReg)      -- ^ Free registers that we can allocate.
-        -> UniqSet Int                   -- ^ Free stack slots that we can use.
-        -> Int                           -- ^ Number of spill slots in use
-        -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to.
-        -> [LiveCmmDecl statics instr]   -- ^ Liveness annotated code to allocate.
-        -> Maybe CFG
-        -> UniqSM ( [NatCmmDecl statics instr]
-                  , [RegAllocStats statics instr]
-                  , Int                  -- Slots in use
-                  , Color.Graph VirtualReg RegClass RealReg)
-
-regAlloc_spin config spinCount triv regsFree slotsFree slotsCount debug_codeGraphs code cfg
- = do
-        let platform = ncgPlatform config
-
-        -- If any of these dump flags are turned on we want to hang on to
-        -- intermediate structures in the allocator - otherwise tell the
-        -- allocator to ditch them early so we don't end up creating space leaks.
-        let dump = or
-                [ ncgDumpRegAllocStages config
-                , ncgDumpAsmStats       config
-                , ncgDumpAsmConflicts   config
-                ]
-
-        -- Check that we're not running off down the garden path.
-        when (spinCount > maxSpinCount)
-         $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
-           (  text "It looks like the register allocator is stuck in an infinite loop."
-           $$ text "max cycles  = " <> int maxSpinCount
-           $$ text "regsFree    = " <> (hcat $ punctuate space $ map ppr
-                                             $ nonDetEltsUniqSet $ unionManyUniqSets
-                                             $ nonDetEltsUFM regsFree)
-              -- This is non-deterministic but we do not
-              -- currently support deterministic code-generation.
-              -- See Note [Unique Determinism and code generation]
-           $$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))
-
-        -- Build the register conflict graph from the cmm code.
-        (graph  :: Color.Graph VirtualReg RegClass RealReg)
-                <- {-# SCC "BuildGraph" #-} buildGraph code
-
-        -- VERY IMPORTANT:
-        --   We really do want the graph to be fully evaluated _before_ we
-        --   start coloring. If we don't do this now then when the call to
-        --   Color.colorGraph forces bits of it, the heap will be filled with
-        --   half evaluated pieces of graph and zillions of apply thunks.
-        seqGraph graph `seq` return ()
-
-        -- Build a map of the cost of spilling each instruction.
-        -- This is a lazy binding, so the map will only be computed if we
-        -- actually have to spill to the stack.
-        let spillCosts  = foldl' plusSpillCostInfo zeroSpillCostInfo
-                        $ map (slurpSpillCostInfo platform cfg) code
-
-        -- The function to choose regs to leave uncolored.
-        let spill       = chooseSpill spillCosts
-
-        -- Record startup state in our log.
-        let stat1
-             = if spinCount == 0
-                 then   Just $ RegAllocStatsStart
-                        { raLiveCmm     = code
-                        , raGraph       = graph
-                        , raSpillCosts  = spillCosts
-                        , raPlatform    = platform
-                        }
-                 else   Nothing
-
-        -- Try and color the graph.
-        let (graph_colored, rsSpill, rmCoalesce)
-                = {-# SCC "ColorGraph" #-}
-                  Color.colorGraph
-                       (ncgRegsIterative config)
-                       spinCount
-                       regsFree triv spill graph
-
-        -- Rewrite registers in the code that have been coalesced.
-        let patchF reg
-                | RegVirtual vr <- reg
-                = case lookupUFM rmCoalesce vr of
-                        Just vr'        -> patchF (RegVirtual vr')
-                        Nothing         -> reg
-
-                | otherwise
-                = reg
-
-        let (code_coalesced :: [LiveCmmDecl statics instr])
-                = map (patchEraseLive patchF) code
-
-        -- Check whether we've found a coloring.
-        if isEmptyUniqSet rsSpill
-
-         -- Coloring was successful because no registers needed to be spilled.
-         then do
-                -- if -fasm-lint is turned on then validate the graph.
-                -- This checks for bugs in the graph allocator itself.
-                let graph_colored_lint  =
-                        if ncgAsmLinting config
-                                then Color.validateGraph (text "")
-                                        True    -- Require all nodes to be colored.
-                                        graph_colored
-                                else graph_colored
-
-                -- Rewrite the code to use real hregs, using the colored graph.
-                let code_patched
-                        = map (patchRegsFromGraph platform graph_colored_lint)
-                              code_coalesced
-
-                -- Clean out unneeded SPILL/RELOAD meta instructions.
-                --   The spill code generator just spills the entire live range
-                --   of a vreg, but it might not need to be on the stack for
-                --   its entire lifetime.
-                let code_spillclean
-                        = map (cleanSpills platform) code_patched
-
-                -- Strip off liveness information from the allocated code.
-                -- Also rewrite SPILL/RELOAD meta instructions into real machine
-                -- instructions along the way
-                let code_final
-                        = map (stripLive config) code_spillclean
-
-                -- Record what happened in this stage for debugging
-                let stat
-                     =  RegAllocStatsColored
-                        { raCode                = code
-                        , raGraph               = graph
-                        , raGraphColored        = graph_colored_lint
-                        , raCoalesced           = rmCoalesce
-                        , raCodeCoalesced       = code_coalesced
-                        , raPatched             = code_patched
-                        , raSpillClean          = code_spillclean
-                        , raFinal               = code_final
-                        , raSRMs                = foldl' addSRM (0, 0, 0)
-                                                $ map countSRMs code_spillclean
-                        , raPlatform    = platform
-                     }
-
-                -- Bundle up all the register allocator statistics.
-                --   .. but make sure to drop them on the floor if they're not
-                --      needed, otherwise we'll get a space leak.
-                let statList =
-                        if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
-                                else []
-
-                -- Ensure all the statistics are evaluated, to avoid space leaks.
-                seqList statList (return ())
-
-                return  ( code_final
-                        , statList
-                        , slotsCount
-                        , graph_colored_lint)
-
-         -- Coloring was unsuccessful. We need to spill some register to the
-         -- stack, make a new graph, and try to color it again.
-         else do
-                -- if -fasm-lint is turned on then validate the graph
-                let graph_colored_lint  =
-                        if ncgAsmLinting config
-                                then Color.validateGraph (text "")
-                                        False   -- don't require nodes to be colored
-                                        graph_colored
-                                else graph_colored
-
-                -- Spill uncolored regs to the stack.
-                (code_spilled, slotsFree', slotsCount', spillStats)
-                        <- regSpill platform code_coalesced slotsFree slotsCount rsSpill
-
-                -- Recalculate liveness information.
-                -- NOTE: we have to reverse the SCCs here to get them back into
-                --       the reverse-dependency order required by computeLiveness.
-                --       If they're not in the correct order that function will panic.
-                code_relive     <- mapM (regLiveness platform . reverseBlocksInTops)
-                                        code_spilled
-
-                -- Record what happened in this stage for debugging.
-                let stat        =
-                        RegAllocStatsSpill
-                        { raCode        = code
-                        , raGraph       = graph_colored_lint
-                        , raCoalesced   = rmCoalesce
-                        , raSpillStats  = spillStats
-                        , raSpillCosts  = spillCosts
-                        , raSpilled     = code_spilled
-                        , raPlatform    = platform }
-
-                -- Bundle up all the register allocator statistics.
-                --   .. but make sure to drop them on the floor if they're not
-                --      needed, otherwise we'll get a space leak.
-                let statList =
-                        if dump
-                                then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
-                                else []
-
-                -- Ensure all the statistics are evaluated, to avoid space leaks.
-                seqList statList (return ())
-
-                regAlloc_spin config (spinCount + 1) triv regsFree slotsFree'
-                              slotsCount' statList code_relive cfg
-
-
--- | Build a graph from the liveness and coalesce information in this code.
-buildGraph
-        :: Instruction instr
-        => [LiveCmmDecl statics instr]
-        -> UniqSM (Color.Graph VirtualReg RegClass RealReg)
-
-buildGraph code
- = do
-        -- Slurp out the conflicts and reg->reg moves from this code.
-        let (conflictList, moveList) =
-                unzip $ map slurpConflicts code
-
-        -- Slurp out the spill/reload coalesces.
-        let moveList2           = map slurpReloadCoalesce code
-
-        -- Add the reg-reg conflicts to the graph.
-        let conflictBag         = unionManyBags conflictList
-        let graph_conflict
-                = foldr graphAddConflictSet Color.initGraph conflictBag
-
-        -- Add the coalescences edges to the graph.
-        let moveBag
-                = unionBags (unionManyBags moveList2)
-                            (unionManyBags moveList)
-
-        let graph_coalesce
-                = foldr graphAddCoalesce graph_conflict moveBag
-
-        return  graph_coalesce
-
-
--- | Add some conflict edges to the graph.
---   Conflicts between virtual and real regs are recorded as exclusions.
-graphAddConflictSet
-        :: UniqSet Reg
-        -> Color.Graph VirtualReg RegClass RealReg
-        -> Color.Graph VirtualReg RegClass RealReg
-
-graphAddConflictSet set graph
- = let  virtuals        = mkUniqSet
-                        [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]
-
-        graph1  = Color.addConflicts virtuals classOfVirtualReg graph
-
-        graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2)
-                        graph1
-                        [ (vr, rr)
-                                | RegVirtual vr <- nonDetEltsUniqSet set
-                                , RegReal    rr <- nonDetEltsUniqSet set]
-                          -- See Note [Unique Determinism and code generation]
-
-   in   graph2
-
-
--- | Add some coalescence edges to the graph
---   Coalescences between virtual and real regs are recorded as preferences.
-graphAddCoalesce
-        :: (Reg, Reg)
-        -> Color.Graph VirtualReg RegClass RealReg
-        -> Color.Graph VirtualReg RegClass RealReg
-
-graphAddCoalesce (r1, r2) graph
-        | RegReal rr            <- r1
-        , RegVirtual vr         <- r2
-        = Color.addPreference (vr, classOfVirtualReg vr) rr graph
-
-        | RegReal rr            <- r2
-        , RegVirtual vr         <- r1
-        = Color.addPreference (vr, classOfVirtualReg vr) rr graph
-
-        | RegVirtual vr1        <- r1
-        , RegVirtual vr2        <- r2
-        = Color.addCoalesce
-                (vr1, classOfVirtualReg vr1)
-                (vr2, classOfVirtualReg vr2)
-                graph
-
-        -- We can't coalesce two real regs, but there could well be existing
-        --      hreg,hreg moves in the input code. We'll just ignore these
-        --      for coalescing purposes.
-        | RegReal _             <- r1
-        , RegReal _             <- r2
-        = graph
-
-#if __GLASGOW_HASKELL__ <= 810
-        | otherwise
-        = panic "graphAddCoalesce"
-#endif
-
-
--- | Patch registers in code using the reg -> reg mapping in this graph.
-patchRegsFromGraph
-        :: (OutputableP Platform statics, Instruction instr)
-        => Platform -> Color.Graph VirtualReg RegClass RealReg
-        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
-
-patchRegsFromGraph platform graph code
- = patchEraseLive patchF code
- where
-        -- Function to lookup the hardreg for a virtual reg from the graph.
-        patchF reg
-                -- leave real regs alone.
-                | RegReal{}     <- reg
-                = reg
-
-                -- this virtual has a regular node in the graph.
-                | RegVirtual vr <- reg
-                , Just node     <- Color.lookupNode graph vr
-                = case Color.nodeColor node of
-                        Just color      -> RegReal    color
-                        Nothing         -> RegVirtual vr
-
-                -- no node in the graph for this virtual, bad news.
-                | otherwise
-                = pprPanic "patchRegsFromGraph: register mapping failed."
-                        (  text "There is no node in the graph for register "
-                                <> ppr reg
-                        $$ pprLiveCmmDecl platform code
-                        $$ Color.dotGraph
-                                (\_ -> text "white")
-                                (trivColorable platform
-                                        (targetVirtualRegSqueeze platform)
-                                        (targetRealRegSqueeze platform))
-                                graph)
-
-
------
--- for when laziness just isn't what you wanted...
---  We need to deepSeq the whole graph before trying to colour it to avoid
---  space leaks.
-seqGraph :: Color.Graph VirtualReg RegClass RealReg -> ()
-seqGraph graph          = seqNodes (nonDetEltsUFM (Color.graphMap graph))
-   -- See Note [Unique Determinism and code generation]
-
-seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> ()
-seqNodes ns
- = case ns of
-        []              -> ()
-        (n : ns)        -> seqNode n `seq` seqNodes ns
-
-seqNode :: Color.Node VirtualReg RegClass RealReg -> ()
-seqNode node
-        =     seqVirtualReg     (Color.nodeId node)
-        `seq` seqRegClass       (Color.nodeClass node)
-        `seq` seqMaybeRealReg   (Color.nodeColor node)
-        `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeConflicts node)))
-        `seq` (seqRealRegList    (nonDetEltsUniqSet (Color.nodeExclusions node)))
-        `seq` (seqRealRegList (Color.nodePreference node))
-        `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeCoalesce node)))
-              -- It's OK to use nonDetEltsUniqSet for seq
-
-seqVirtualReg :: VirtualReg -> ()
-seqVirtualReg reg = reg `seq` ()
-
-seqRealReg :: RealReg -> ()
-seqRealReg reg = reg `seq` ()
-
-seqRegClass :: RegClass -> ()
-seqRegClass c = c `seq` ()
-
-seqMaybeRealReg :: Maybe RealReg -> ()
-seqMaybeRealReg mr
- = case mr of
-        Nothing         -> ()
-        Just r          -> seqRealReg r
-
-seqVirtualRegList :: [VirtualReg] -> ()
-seqVirtualRegList rs
- = case rs of
-        []              -> ()
-        (r : rs)        -> seqVirtualReg r `seq` seqVirtualRegList rs
-
-seqRealRegList :: [RealReg] -> ()
-seqRealRegList rs
- = case rs of
-        []              -> ()
-        (r : rs)        -> seqRealReg r `seq` seqRealRegList rs
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs
+++ /dev/null
@@ -1,164 +0,0 @@
-
--- | Utils for calculating general worst, bound, squeese and free, functions.
---
---   as per: "A Generalized Algorithm for Graph-Coloring Register Allocation"
---           Michael Smith, Normal Ramsey, Glenn Holloway.
---           PLDI 2004
---
---   These general versions are not used in GHC proper because they are too slow.
---   Instead, hand written optimised versions are provided for each architecture
---   in MachRegs*.hs
---
---   This code is here because we can test the architecture specific code against
---   it.
---
-module GHC.CmmToAsm.Reg.Graph.Base (
-        RegClass(..),
-        Reg(..),
-        RegSub(..),
-
-        worst,
-        bound,
-        squeese
-) where
-
-import GHC.Prelude
-
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.FM
-import GHC.Types.Unique
-import GHC.Builtin.Uniques
-import GHC.Utils.Monad (concatMapM)
-
-
--- Some basic register classes.
---      These aren't necessarily in 1-to-1 correspondence with the allocatable
---      RegClasses in MachRegs.hs
-data RegClass
-        -- general purpose regs
-        = ClassG32      -- 32 bit GPRs
-        | ClassG16      -- 16 bit GPRs
-        | ClassG8       -- 8  bit GPRs
-
-        -- floating point regs
-        | ClassF64      -- 64 bit FPRs
-        deriving (Show, Eq, Enum)
-
-
--- | A register of some class
-data Reg
-        -- a register of some class
-        = Reg RegClass Int
-
-        -- a sub-component of one of the other regs
-        | RegSub RegSub Reg
-        deriving (Show, Eq)
-
-
--- | so we can put regs in UniqSets
-instance Uniquable Reg where
-        getUnique (Reg c i)
-         = mkRegSingleUnique
-         $ fromEnum c * 1000 + i
-
-        getUnique (RegSub s (Reg c i))
-         = mkRegSubUnique
-         $ fromEnum s * 10000 + fromEnum c * 1000 + i
-
-        getUnique (RegSub _ (RegSub _ _))
-          = error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg."
-
-
--- | A subcomponent of another register
-data RegSub
-        = SubL16        -- lowest 16 bits
-        | SubL8         -- lowest  8 bits
-        | SubL8H        -- second lowest 8 bits
-        deriving (Show, Enum, Ord, Eq)
-
-
--- | Worst case displacement
---
---      a node N of classN has some number of neighbors,
---      all of which are from classC.
---
---      (worst neighbors classN classC) is the maximum number of potential
---      colors for N that can be lost by coloring its neighbors.
---
--- This should be hand coded/cached for each particular architecture,
---      because the compute time is very long..
-worst   :: (RegClass    -> UniqSet Reg)
-        -> (Reg         -> UniqSet Reg)
-        -> Int -> RegClass -> RegClass -> Int
-
-worst regsOfClass regAlias neighbors classN classC
- = let  regAliasS regs  = unionManyUniqSets
-                        $ map regAlias
-                        $ nonDetEltsUniqSet regs
-                        -- This is non-deterministic but we do not
-                        -- currently support deterministic code-generation.
-                        -- See Note [Unique Determinism and code generation]
-
-        -- all the regs in classes N, C
-        regsN           = regsOfClass classN
-        regsC           = regsOfClass classC
-
-        -- all the possible subsets of c which have size < m
-        regsS           = filter (\s -> not (isEmptyUniqSet s)
-                                     && sizeUniqSet s <= neighbors)
-                        $ powersetLS regsC
-
-        -- for each of the subsets of C, the regs which conflict
-        -- with possibilities for N
-        regsS_conflict
-                = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS
-
-  in    maximum $ map sizeUniqSet $ regsS_conflict
-
-
--- | For a node N of classN and neighbors of classesC
---      (bound classN classesC) is the maximum number of potential
---      colors for N that can be lost by coloring its neighbors.
-bound   :: (RegClass    -> UniqSet Reg)
-        -> (Reg         -> UniqSet Reg)
-        -> RegClass -> [RegClass] -> Int
-
-bound regsOfClass regAlias classN classesC
- = let  regAliasS regs  = unionManyUniqSets
-                        $ map regAlias
-                        $ nonDetEltsUFM regs
-                        -- See Note [Unique Determinism and code generation]
-
-        regsC_aliases
-                = unionManyUniqSets
-                $ map (regAliasS . getUniqSet . regsOfClass) classesC
-
-        overlap = intersectUniqSets (regsOfClass classN) regsC_aliases
-
-   in   sizeUniqSet overlap
-
-
--- | The total squeese on a particular node with a list of neighbors.
---
---   A version of this should be constructed for each particular architecture,
---   possibly including uses of bound, so that aliased registers don't get
---   counted twice, as per the paper.
-squeese :: (RegClass    -> UniqSet Reg)
-        -> (Reg         -> UniqSet Reg)
-        -> RegClass -> [(Int, RegClass)] -> Int
-
-squeese regsOfClass regAlias classN countCs
-        = sum
-        $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC)
-        $ countCs
-
-
--- | powerset (for lists)
-powersetL :: [a] -> [[a]]
-powersetL       = concatMapM (\x -> [[],[x]])
-
-
--- | powersetLS (list of sets)
-powersetLS :: Uniquable a => UniqSet a -> [UniqSet a]
-powersetLS s    = map mkUniqSet $ powersetL $ nonDetEltsUniqSet s
-  -- See Note [Unique Determinism and code generation]
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs
+++ /dev/null
@@ -1,99 +0,0 @@
--- | Register coalescing.
-module GHC.CmmToAsm.Reg.Graph.Coalesce (
-        regCoalesce,
-        slurpJoinMovs
-) where
-import GHC.Prelude
-
-import GHC.CmmToAsm.Reg.Liveness
-import GHC.CmmToAsm.Instr
-import GHC.Platform.Reg
-
-import GHC.Cmm
-import GHC.Data.Bag
-import GHC.Data.Graph.Directed
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.Supply
-
-
--- | Do register coalescing on this top level thing
---
---   For Reg -> Reg moves, if the first reg dies at the same time the
---   second reg is born then the mov only serves to join live ranges.
---   The two regs can be renamed to be the same and the move instruction
---   safely erased.
-regCoalesce
-        :: Instruction instr
-        => [LiveCmmDecl statics instr]
-        -> UniqSM [LiveCmmDecl statics instr]
-
-regCoalesce code
- = do
-        let joins       = foldl' unionBags emptyBag
-                        $ map slurpJoinMovs code
-
-        let alloc       = foldl' buildAlloc emptyUFM
-                        $ bagToList joins
-
-        let patched     = map (patchEraseLive (sinkReg alloc)) code
-
-        return patched
-
-
--- | Add a v1 = v2 register renaming to the map.
---   The register with the lowest lexical name is set as the
---   canonical version.
-buildAlloc :: UniqFM Reg Reg -> (Reg, Reg) -> UniqFM Reg Reg
-buildAlloc fm (r1, r2)
- = let  rmin    = min r1 r2
-        rmax    = max r1 r2
-   in   addToUFM fm rmax rmin
-
-
--- | Determine the canonical name for a register by following
---   v1 = v2 renamings in this map.
-sinkReg :: UniqFM Reg Reg -> Reg -> Reg
-sinkReg fm r
- = case lookupUFM fm r of
-        Nothing -> r
-        Just r' -> sinkReg fm r'
-
-
--- | Slurp out mov instructions that only serve to join live ranges.
---
---   During a mov, if the source reg dies and the destination reg is
---   born then we can rename the two regs to the same thing and
---   eliminate the move.
-slurpJoinMovs
-        :: Instruction instr
-        => LiveCmmDecl statics instr
-        -> Bag (Reg, Reg)
-
-slurpJoinMovs live
-        = slurpCmm emptyBag live
- where
-        slurpCmm   rs  CmmData{}
-         = rs
-
-        slurpCmm   rs (CmmProc _ _ _ sccs)
-         = foldl' slurpBlock rs (flattenSCCs sccs)
-
-        slurpBlock rs (BasicBlock _ instrs)
-         = foldl' slurpLI    rs instrs
-
-        slurpLI    rs (LiveInstr _      Nothing)    = rs
-        slurpLI    rs (LiveInstr instr (Just live))
-                | Just (r1, r2) <- takeRegRegMoveInstr instr
-                , elementOfUniqSet r1 $ liveDieRead live
-                , elementOfUniqSet r2 $ liveBorn live
-
-                -- only coalesce movs between two virtuals for now,
-                -- else we end up with allocatable regs in the live
-                -- regs list..
-                , isVirtualReg r1 && isVirtualReg r2
-                = consBag (r1, r2) rs
-
-                | otherwise
-                = rs
-
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs
+++ /dev/null
@@ -1,381 +0,0 @@
--- | When there aren't enough registers to hold all the vregs we have to spill
---   some of those vregs to slots on the stack. This module is used modify the
---   code to use those slots.
-module GHC.CmmToAsm.Reg.Graph.Spill (
-        regSpill,
-        SpillStats(..),
-        accSpillSL
-) where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.Reg.Liveness
-import GHC.CmmToAsm.Reg.Utils
-import GHC.CmmToAsm.Instr
-import GHC.Platform.Reg
-import GHC.Cmm hiding (RegSet)
-import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Collections
-
-import GHC.Utils.Monad
-import GHC.Utils.Monad.State.Strict
-import GHC.Types.Unique
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.Supply
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Platform
-
-import Data.List (nub, (\\), intersect)
-import Data.Maybe
-import Data.IntSet              (IntSet)
-import qualified Data.IntSet    as IntSet
-
-
--- | Spill all these virtual regs to stack slots.
---
---   Bumps the number of required stack slots if required.
---
---
---   TODO: See if we can split some of the live ranges instead of just globally
---         spilling the virtual reg. This might make the spill cleaner's job easier.
---
---   TODO: On CISCy x86 and x86_64 we don't necessarily have to add a mov instruction
---         when making spills. If an instr is using a spilled virtual we may be able to
---         address the spill slot directly.
---
-regSpill
-        :: Instruction instr
-        => Platform
-        -> [LiveCmmDecl statics instr]  -- ^ the code
-        -> UniqSet Int                  -- ^ available stack slots
-        -> Int                          -- ^ current number of spill slots.
-        -> UniqSet VirtualReg           -- ^ the regs to spill
-        -> UniqSM
-            ([LiveCmmDecl statics instr]
-                 -- code with SPILL and RELOAD meta instructions added.
-            , UniqSet Int               -- left over slots
-            , Int                       -- slot count in use now.
-            , SpillStats )              -- stats about what happened during spilling
-
-regSpill platform code slotsFree slotCount regs
-
-        -- Not enough slots to spill these regs.
-        | sizeUniqSet slotsFree < sizeUniqSet regs
-        = -- pprTrace "Bumping slot count:" (ppr slotCount <> text " -> " <> ppr (slotCount+512)) $
-          let slotsFree' = (addListToUniqSet slotsFree [slotCount+1 .. slotCount+512])
-          in regSpill platform code slotsFree' (slotCount+512) regs
-
-        | otherwise
-        = do
-                -- Allocate a slot for each of the spilled regs.
-                let slots       = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree
-                let
-                    regSlotMap  = toRegMap -- Cast keys from VirtualReg to Reg
-                                           -- See Note [UniqFM and the register allocator]
-                                $ listToUFM
-                                $ zip (nonDetEltsUniqSet regs) slots :: UniqFM Reg Int
-                    -- This is non-deterministic but we do not
-                    -- currently support deterministic code-generation.
-                    -- See Note [Unique Determinism and code generation]
-
-                -- Grab the unique supply from the monad.
-                us      <- getUniqueSupplyM
-
-                -- Run the spiller on all the blocks.
-                let (code', state')     =
-                        runState (mapM (regSpill_top platform regSlotMap) code)
-                                 (initSpillS us)
-
-                return  ( code'
-                        , minusUniqSet slotsFree (mkUniqSet slots)
-                        , slotCount
-                        , makeSpillStats state')
-
-
--- | Spill some registers to stack slots in a top-level thing.
-regSpill_top
-        :: Instruction instr
-        => Platform
-        -> RegMap Int
-                -- ^ map of vregs to slots they're being spilled to.
-        -> LiveCmmDecl statics instr
-                -- ^ the top level thing.
-        -> SpillM (LiveCmmDecl statics instr)
-
-regSpill_top platform regSlotMap cmm
- = case cmm of
-        CmmData{}
-         -> return cmm
-
-        CmmProc info label live sccs
-         |  LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry <- info
-         -> do
-                -- The liveVRegsOnEntry contains the set of vregs that are live
-                -- on entry to each basic block. If we spill one of those vregs
-                -- we remove it from that set and add the corresponding slot
-                -- number to the liveSlotsOnEntry set. The spill cleaner needs
-                -- this information to erase unneeded spill and reload instructions
-                -- after we've done a successful allocation.
-                let liveSlotsOnEntry' :: BlockMap IntSet
-                    liveSlotsOnEntry'
-                        = mapFoldlWithKey patchLiveSlot
-                                          liveSlotsOnEntry liveVRegsOnEntry
-
-                let info'
-                        = LiveInfo static firstId
-                                liveVRegsOnEntry
-                                liveSlotsOnEntry'
-
-                -- Apply the spiller to all the basic blocks in the CmmProc.
-                sccs'   <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs
-
-                return  $ CmmProc info' label live sccs'
-
- where  -- Given a BlockId and the set of registers live in it,
-        -- if registers in this block are being spilled to stack slots,
-        -- then record the fact that these slots are now live in those blocks
-        -- in the given slotmap.
-        patchLiveSlot
-                :: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet
-
-        patchLiveSlot slotMap blockId regsLive
-         = let
-                -- Slots that are already recorded as being live.
-                curSlotsLive    = fromMaybe IntSet.empty
-                                $ mapLookup blockId slotMap
-
-                moreSlotsLive   = IntSet.fromList
-                                $ mapMaybe (lookupUFM regSlotMap)
-                                $ nonDetEltsUniqSet regsLive
-                    -- See Note [Unique Determinism and code generation]
-
-                slotMap'
-                 = mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive)
-                             slotMap
-
-           in   slotMap'
-
-
--- | Spill some registers to stack slots in a basic block.
-regSpill_block
-        :: Instruction instr
-        => Platform
-        -> UniqFM Reg Int   -- ^ map of vregs to slots they're being spilled to.
-        -> LiveBasicBlock instr
-        -> SpillM (LiveBasicBlock instr)
-
-regSpill_block platform regSlotMap (BasicBlock i instrs)
- = do   instrss'        <- mapM (regSpill_instr platform regSlotMap) instrs
-        return  $ BasicBlock i (concat instrss')
-
-
--- | Spill some registers to stack slots in a single instruction.
---   If the instruction uses registers that need to be spilled, then it is
---   prefixed (or postfixed) with the appropriate RELOAD or SPILL meta
---   instructions.
-regSpill_instr
-        :: Instruction instr
-        => Platform
-        -> UniqFM Reg Int -- ^ map of vregs to slots they're being spilled to.
-        -> LiveInstr instr
-        -> SpillM [LiveInstr instr]
-regSpill_instr _ _ li@(LiveInstr _ Nothing) = return [li]
-regSpill_instr platform regSlotMap (LiveInstr instr (Just _)) = do
-  -- work out which regs are read and written in this instr
-  let RU rlRead rlWritten = regUsageOfInstr platform instr
-
-  -- sometimes a register is listed as being read more than once,
-  --      nub this so we don't end up inserting two lots of spill code.
-  let rsRead_             = nub rlRead
-  let rsWritten_          = nub rlWritten
-
-  -- if a reg is modified, it appears in both lists, want to undo this..
-  let rsRead              = rsRead_    \\ rsWritten_
-  let rsWritten           = rsWritten_ \\ rsRead_
-  let rsModify            = intersect rsRead_ rsWritten_
-
-  -- work out if any of the regs being used are currently being spilled.
-  let rsSpillRead         = filter (\r -> elemUFM r regSlotMap) rsRead
-  let rsSpillWritten      = filter (\r -> elemUFM r regSlotMap) rsWritten
-  let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify
-
-  -- rewrite the instr and work out spill code.
-  (instr1, prepost1)      <- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead
-  (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten
-  (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify
-
-  let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3)
-  let prefixes                = concat mPrefixes
-  let postfixes               = concat mPostfixes
-
-  -- final code
-  let instrs' =  prefixes
-              ++ [LiveInstr instr3 Nothing]
-              ++ postfixes
-
-  return instrs'
-
-
--- | Add a RELOAD met a instruction to load a value for an instruction that
---   writes to a vreg that is being spilled.
-spillRead
-        :: Instruction instr
-        => UniqFM Reg Int
-        -> instr
-        -> Reg
-        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
-
-spillRead regSlotMap instr reg
- | Just slot     <- lookupUFM regSlotMap reg
- = do    (instr', nReg)  <- patchInstr reg instr
-
-         modify $ \s -> s
-                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
-
-         return  ( instr'
-                 , ( [LiveInstr (RELOAD slot nReg) Nothing]
-                 , []) )
-
- | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"
-
-
--- | Add a SPILL meta instruction to store a value for an instruction that
---   writes to a vreg that is being spilled.
-spillWrite
-        :: Instruction instr
-        => UniqFM Reg Int
-        -> instr
-        -> Reg
-        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
-
-spillWrite regSlotMap instr reg
- | Just slot     <- lookupUFM regSlotMap reg
- = do    (instr', nReg)  <- patchInstr reg instr
-
-         modify $ \s -> s
-                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
-
-         return  ( instr'
-                 , ( []
-                   , [LiveInstr (SPILL nReg slot) Nothing]))
-
- | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg"
-
-
--- | Add both RELOAD and SPILL meta instructions for an instruction that
---   both reads and writes to a vreg that is being spilled.
-spillModify
-        :: Instruction instr
-        => UniqFM Reg Int
-        -> instr
-        -> Reg
-        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
-
-spillModify regSlotMap instr reg
- | Just slot     <- lookupUFM regSlotMap reg
- = do    (instr', nReg)  <- patchInstr reg instr
-
-         modify $ \s -> s
-                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
-
-         return  ( instr'
-                 , ( [LiveInstr (RELOAD slot nReg) Nothing]
-                   , [LiveInstr (SPILL nReg slot) Nothing]))
-
- | otherwise     = panic "RegSpill.spillModify: no slot defined for spilled reg"
-
-
--- | Rewrite uses of this virtual reg in an instr to use a different
---   virtual reg.
-patchInstr
-        :: Instruction instr
-        => Reg -> instr -> SpillM (instr, Reg)
-
-patchInstr reg instr
- = do   nUnique         <- newUnique
-
-        -- The register we're rewriting is supposed to be virtual.
-        -- If it's not then something has gone horribly wrong.
-        let nReg
-             = case reg of
-                RegVirtual vr
-                 -> RegVirtual (renameVirtualReg nUnique vr)
-
-                RegReal{}
-                 -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg"
-
-        let instr'      = patchReg1 reg nReg instr
-        return          (instr', nReg)
-
-
-patchReg1
-        :: Instruction instr
-        => Reg -> Reg -> instr -> instr
-
-patchReg1 old new instr
- = let  patchF r
-                | r == old      = new
-                | otherwise     = r
-   in   patchRegsOfInstr instr patchF
-
-
--- Spiller monad --------------------------------------------------------------
--- | State monad for the spill code generator.
-type SpillM a
-        = State SpillS a
-
--- | Spill code generator state.
-data SpillS
-        = SpillS
-        { -- | Unique supply for generating fresh vregs.
-          stateUS       :: UniqSupply
-
-          -- | Spilled vreg vs the number of times it was loaded, stored.
-        , stateSpillSL  :: UniqFM Reg (Reg, Int, Int) }
-
-
--- | Create a new spiller state.
-initSpillS :: UniqSupply -> SpillS
-initSpillS uniqueSupply
-        = SpillS
-        { stateUS       = uniqueSupply
-        , stateSpillSL  = emptyUFM }
-
-
--- | Allocate a new unique in the spiller monad.
-newUnique :: SpillM Unique
-newUnique
- = do   us      <- gets stateUS
-        case takeUniqFromSupply us of
-         (uniq, us')
-          -> do modify $ \s -> s { stateUS = us' }
-                return uniq
-
-
--- | Add a spill/reload count to a stats record for a register.
-accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)
-accSpillSL (r1, s1, l1) (_, s2, l2)
-        = (r1, s1 + s2, l1 + l2)
-
-
--- Spiller stats --------------------------------------------------------------
--- | Spiller statistics.
---   Tells us what registers were spilled.
-data SpillStats
-        = SpillStats
-        { spillStoreLoad        :: UniqFM Reg (Reg, Int, Int) }
-
-
--- | Extract spiller statistics from the spiller state.
-makeSpillStats :: SpillS -> SpillStats
-makeSpillStats s
-        = SpillStats
-        { spillStoreLoad        = stateSpillSL s }
-
-
-instance Outputable SpillStats where
- ppr stats
-        = pprUFM (spillStoreLoad stats)
-                 (vcat . map (\(r, s, l) -> ppr r <+> int s <+> int l))
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs
+++ /dev/null
@@ -1,614 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
--- | Clean out unneeded spill\/reload instructions.
---
---   Handling of join points
---   ~~~~~~~~~~~~~~~~~~~~~~~
---
---   @
---   B1:                          B2:
---    ...                          ...
---       RELOAD SLOT(0), %r1          RELOAD SLOT(0), %r1
---       ... A ...                    ... B ...
---       jump B3                      jump B3
---
---                B3: ... C ...
---                    RELOAD SLOT(0), %r1
---                    ...
---   @
---
---   The Plan
---   ~~~~~~~~
---
---   As long as %r1 hasn't been written to in A, B or C then we don't need
---   the reload in B3.
---
---   What we really care about here is that on the entry to B3, %r1 will
---   always have the same value that is in SLOT(0) (ie, %r1 is _valid_)
---
---   This also works if the reloads in B1\/B2 were spills instead, because
---   spilling %r1 to a slot makes that slot have the same value as %r1.
---
-module GHC.CmmToAsm.Reg.Graph.SpillClean (
-        cleanSpills
-) where
-import GHC.Prelude
-
-import GHC.CmmToAsm.Reg.Liveness
-import GHC.CmmToAsm.Instr
-import GHC.Platform.Reg
-
-import GHC.Cmm.BlockId
-import GHC.Cmm
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.FM
-import GHC.Types.Unique
-import GHC.Builtin.Uniques
-import GHC.Utils.Monad.State.Strict
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Platform
-import GHC.Cmm.Dataflow.Collections
-
-import Data.List (nub, foldl1', find)
-import Data.Maybe
-import Data.IntSet              (IntSet)
-import qualified Data.IntSet    as IntSet
-
-
--- | The identification number of a spill slot.
---   A value is stored in a spill slot when we don't have a free
---   register to hold it.
-type Slot = Int
-
-
--- | Clean out unneeded spill\/reloads from this top level thing.
-cleanSpills
-        :: Instruction instr
-        => Platform
-        -> LiveCmmDecl statics instr
-        -> LiveCmmDecl statics instr
-
-cleanSpills platform cmm
-        = evalState (cleanSpin platform 0 cmm) initCleanS
-
-
--- | Do one pass of cleaning.
-cleanSpin
-        :: Instruction instr
-        => Platform
-        -> Int                              -- ^ Iteration number for the cleaner.
-        -> LiveCmmDecl statics instr        -- ^ Liveness annotated code to clean.
-        -> CleanM (LiveCmmDecl statics instr)
-
-cleanSpin platform spinCount code
- = do
-        -- Initialise count of cleaned spill and reload instructions.
-        modify $ \s -> s
-                { sCleanedSpillsAcc     = 0
-                , sCleanedReloadsAcc    = 0
-                , sReloadedBy           = emptyUFM }
-
-        code_forward    <- mapBlockTopM (cleanBlockForward platform) code
-        code_backward   <- cleanTopBackward code_forward
-
-        -- During the cleaning of each block we collected information about
-        -- what regs were valid across each jump. Based on this, work out
-        -- whether it will be safe to erase reloads after join points for
-        -- the next pass.
-        collateJoinPoints
-
-        -- Remember how many spill and reload instructions we cleaned in this pass.
-        spills          <- gets sCleanedSpillsAcc
-        reloads         <- gets sCleanedReloadsAcc
-        modify $ \s -> s
-                { sCleanedCount = (spills, reloads) : sCleanedCount s }
-
-        -- If nothing was cleaned in this pass or the last one
-        --      then we're done and it's time to bail out.
-        cleanedCount    <- gets sCleanedCount
-        if take 2 cleanedCount == [(0, 0), (0, 0)]
-           then return code
-
-        -- otherwise go around again
-           else cleanSpin platform (spinCount + 1) code_backward
-
-
--------------------------------------------------------------------------------
--- | Clean out unneeded reload instructions,
---   while walking forward over the code.
-cleanBlockForward
-        :: Instruction instr
-        => Platform
-        -> LiveBasicBlock instr
-        -> CleanM (LiveBasicBlock instr)
-
-cleanBlockForward platform (BasicBlock blockId instrs)
- = do
-        -- See if we have a valid association for the entry to this block.
-        jumpValid       <- gets sJumpValid
-        let assoc       = case lookupUFM jumpValid blockId of
-                                Just assoc      -> assoc
-                                Nothing         -> emptyAssoc
-
-        instrs_reload   <- cleanForward platform blockId assoc [] instrs
-        return  $ BasicBlock blockId instrs_reload
-
-
-
--- | Clean out unneeded reload instructions.
---
---   Walking forwards across the code
---     On a reload, if we know a reg already has the same value as a slot
---     then we don't need to do the reload.
---
-cleanForward
-        :: Instruction instr
-        => Platform
-        -> BlockId                  -- ^ the block that we're currently in
-        -> Assoc Store              -- ^ two store locations are associated if
-                                    --     they have the same value
-        -> [LiveInstr instr]        -- ^ acc
-        -> [LiveInstr instr]        -- ^ instrs to clean (in backwards order)
-        -> CleanM [LiveInstr instr] -- ^ cleaned instrs  (in forward   order)
-
-cleanForward _ _ _ acc []
-        = return acc
-
--- Rewrite live range joins via spill slots to just a spill and a reg-reg move
--- hopefully the spill will be also be cleaned in the next pass
-cleanForward platform blockId assoc acc (li1 : li2 : instrs)
-
-        | LiveInstr (SPILL  reg1  slot1) _      <- li1
-        , LiveInstr (RELOAD slot2 reg2)  _      <- li2
-        , slot1 == slot2
-        = do
-                modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
-                cleanForward platform blockId assoc acc
-                 $ li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing
-                       : instrs
-
-cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs)
-        | Just (r1, r2) <- takeRegRegMoveInstr i1
-        = if r1 == r2
-                -- Erase any left over nop reg reg moves while we're here
-                -- this will also catch any nop moves that the previous case
-                -- happens to add.
-                then cleanForward platform blockId assoc acc instrs
-
-                -- If r1 has the same value as some slots and we copy r1 to r2,
-                --      then r2 is now associated with those slots instead
-                else do let assoc'      = addAssoc (SReg r1) (SReg r2)
-                                        $ delAssoc (SReg r2)
-                                        $ assoc
-
-                        cleanForward platform blockId assoc' (li : acc) instrs
-
-
-cleanForward platform blockId assoc acc (li : instrs)
-
-        -- Update association due to the spill.
-        | LiveInstr (SPILL reg slot) _  <- li
-        = let   assoc'  = addAssoc (SReg reg)  (SSlot slot)
-                        $ delAssoc (SSlot slot)
-                        $ assoc
-          in    cleanForward platform blockId assoc' (li : acc) instrs
-
-        -- Clean a reload instr.
-        | LiveInstr (RELOAD{}) _        <- li
-        = do    (assoc', mli)   <- cleanReload platform blockId assoc li
-                case mli of
-                 Nothing        -> cleanForward platform blockId assoc' acc
-                                                instrs
-
-                 Just li'       -> cleanForward platform blockId assoc' (li' : acc)
-                                                instrs
-
-        -- Remember the association over a jump.
-        | LiveInstr instr _     <- li
-        , targets               <- jumpDestsOfInstr instr
-        , not $ null targets
-        = do    mapM_ (accJumpValid assoc) targets
-                cleanForward platform blockId assoc (li : acc) instrs
-
-        -- Writing to a reg changes its value.
-        | LiveInstr instr _     <- li
-        , RU _ written          <- regUsageOfInstr platform instr
-        = let assoc'    = foldr delAssoc assoc (map SReg $ nub written)
-          in  cleanForward platform blockId assoc' (li : acc) instrs
-
-
-
--- | Try and rewrite a reload instruction to something more pleasing
-cleanReload
-        :: Instruction instr
-        => Platform
-        -> BlockId
-        -> Assoc Store
-        -> LiveInstr instr
-        -> CleanM (Assoc Store, Maybe (LiveInstr instr))
-
-cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _)
-
-        -- If the reg we're reloading already has the same value as the slot
-        --      then we can erase the instruction outright.
-        | elemAssoc (SSlot slot) (SReg reg) assoc
-        = do    modify  $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
-                return  (assoc, Nothing)
-
-        -- If we can find another reg with the same value as this slot then
-        --      do a move instead of a reload.
-        | Just reg2     <- findRegOfSlot assoc slot
-        = do    modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
-
-                let assoc'      = addAssoc (SReg reg) (SReg reg2)
-                                $ delAssoc (SReg reg)
-                                $ assoc
-
-                return  ( assoc'
-                        , Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing)
-
-        -- Gotta keep this instr.
-        | otherwise
-        = do    -- Update the association.
-                let assoc'
-                        = addAssoc (SReg reg)  (SSlot slot)
-                                -- doing the reload makes reg and slot the same value
-                        $ delAssoc (SReg reg)
-                                -- reg value changes on reload
-                        $ assoc
-
-                -- Remember that this block reloads from this slot.
-                accBlockReloadsSlot blockId slot
-
-                return  (assoc', Just li)
-
-cleanReload _ _ _ _
-        = panic "RegSpillClean.cleanReload: unhandled instr"
-
-
--------------------------------------------------------------------------------
--- | Clean out unneeded spill instructions,
---   while walking backwards over the code.
---
---      If there were no reloads from a slot between a spill and the last one
---      then the slot was never read and we don't need the spill.
---
---      SPILL   r0 -> s1
---      RELOAD  s1 -> r2
---      SPILL   r3 -> s1        <--- don't need this spill
---      SPILL   r4 -> s1
---      RELOAD  s1 -> r5
---
---      Maintain a set of
---              "slots which were spilled to but not reloaded from yet"
---
---      Walking backwards across the code:
---       a) On a reload from a slot, remove it from the set.
---
---       a) On a spill from a slot
---              If the slot is in set then we can erase the spill,
---               because it won't be reloaded from until after the next spill.
---
---              otherwise
---               keep the spill and add the slot to the set
---
--- TODO: This is mostly inter-block
---       we should really be updating the noReloads set as we cross jumps also.
---
--- TODO: generate noReloads from liveSlotsOnEntry
---
-cleanTopBackward
-        :: Instruction instr
-        => LiveCmmDecl statics instr
-        -> CleanM (LiveCmmDecl statics instr)
-
-cleanTopBackward cmm
- = case cmm of
-        CmmData{}
-         -> return cmm
-
-        CmmProc info label live sccs
-         | LiveInfo _ _ _ liveSlotsOnEntry <- info
-         -> do  sccs'   <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs
-                return  $ CmmProc info label live sccs'
-
-
-cleanBlockBackward
-        :: Instruction instr
-        => BlockMap IntSet
-        -> LiveBasicBlock instr
-        -> CleanM (LiveBasicBlock instr)
-
-cleanBlockBackward liveSlotsOnEntry (BasicBlock blockId instrs)
- = do   instrs_spill    <- cleanBackward liveSlotsOnEntry  emptyUniqSet  [] instrs
-        return  $ BasicBlock blockId instrs_spill
-
-
-
-cleanBackward
-        :: Instruction instr
-        => BlockMap IntSet          -- ^ Slots live on entry to each block
-        -> UniqSet Int              -- ^ Slots that have been spilled, but not reloaded from
-        -> [LiveInstr instr]        -- ^ acc
-        -> [LiveInstr instr]        -- ^ Instrs to clean (in forwards order)
-        -> CleanM [LiveInstr instr] -- ^ Cleaned instrs  (in backwards order)
-
-cleanBackward liveSlotsOnEntry noReloads acc lis
- = do   reloadedBy      <- gets sReloadedBy
-        cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc lis
-
-
-cleanBackward'
-        :: Instruction instr
-        => BlockMap IntSet
-        -> UniqFM Store [BlockId]
-        -> UniqSet Int
-        -> [LiveInstr instr]
-        -> [LiveInstr instr]
-        -> State CleanS [LiveInstr instr]
-
-cleanBackward' _ _ _      acc []
-        = return  acc
-
-cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs)
-
-        -- If nothing ever reloads from this slot then we don't need the spill.
-        | LiveInstr (SPILL _ slot) _    <- li
-        , Nothing       <- lookupUFM reloadedBy (SSlot slot)
-        = do    modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
-                cleanBackward liveSlotsOnEntry noReloads acc instrs
-
-        | LiveInstr (SPILL _ slot) _    <- li
-        = if elementOfUniqSet slot noReloads
-
-           -- We can erase this spill because the slot won't be read until
-           -- after the next one
-           then do
-                modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
-                cleanBackward liveSlotsOnEntry noReloads acc instrs
-
-           else do
-                -- This slot is being spilled to, but we haven't seen any reloads yet.
-                let noReloads'  = addOneToUniqSet noReloads slot
-                cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
-
-        -- if we reload from a slot then it's no longer unused
-        | LiveInstr (RELOAD slot _) _   <- li
-        , noReloads'            <- delOneFromUniqSet noReloads slot
-        = cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
-
-        -- If a slot is live in a jump target then assume it's reloaded there.
-        --
-        -- TODO: A real dataflow analysis would do a better job here.
-        --       If the target block _ever_ used the slot then we assume
-        --       it always does, but if those reloads are cleaned the slot
-        --       liveness map doesn't get updated.
-        | LiveInstr instr _     <- li
-        , targets               <- jumpDestsOfInstr instr
-        = do
-                let slotsReloadedByTargets
-                        = IntSet.unions
-                        $ mapMaybe (flip mapLookup liveSlotsOnEntry)
-                        $ targets
-
-                let noReloads'
-                        = foldl' delOneFromUniqSet noReloads
-                        $ IntSet.toList slotsReloadedByTargets
-
-                cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
-
-#if __GLASGOW_HASKELL__ <= 810
-        -- some other instruction
-        | otherwise
-        = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs
-#endif
-
-
--- | Combine the associations from all the inward control flow edges.
---
-collateJoinPoints :: CleanM ()
-collateJoinPoints
- = modify $ \s -> s
-        { sJumpValid    = mapUFM intersects (sJumpValidAcc s)
-        , sJumpValidAcc = emptyUFM }
-
-intersects :: [Assoc Store]     -> Assoc Store
-intersects []           = emptyAssoc
-intersects assocs       = foldl1' intersectAssoc assocs
-
-
--- | See if we have a reg with the same value as this slot in the association table.
-findRegOfSlot :: Assoc Store -> Int -> Maybe Reg
-findRegOfSlot assoc slot
-        | close                 <- closeAssoc (SSlot slot) assoc
-        , Just (SReg reg)       <- find isStoreReg $ nonDetEltsUniqSet close
-           -- See Note [Unique Determinism and code generation]
-        = Just reg
-
-        | otherwise
-        = Nothing
-
-
--------------------------------------------------------------------------------
--- | Cleaner monad.
-type CleanM
-        = State CleanS
-
--- | Cleaner state.
-data CleanS
-        = CleanS
-        { -- | Regs which are valid at the start of each block.
-          sJumpValid            :: UniqFM BlockId (Assoc Store)
-
-          -- | Collecting up what regs were valid across each jump.
-          --    in the next pass we can collate these and write the results
-          --    to sJumpValid.
-        , sJumpValidAcc         :: UniqFM BlockId [Assoc Store]
-
-          -- | Map of (slot -> blocks which reload from this slot)
-          --    used to decide if whether slot spilled to will ever be
-          --    reloaded from on this path.
-        , sReloadedBy           :: UniqFM Store [BlockId]
-
-          -- | Spills and reloads cleaned each pass (latest at front)
-        , sCleanedCount         :: [(Int, Int)]
-
-          -- | Spills and reloads that have been cleaned in this pass so far.
-        , sCleanedSpillsAcc     :: Int
-        , sCleanedReloadsAcc    :: Int }
-
-
--- | Construct the initial cleaner state.
-initCleanS :: CleanS
-initCleanS
-        = CleanS
-        { sJumpValid            = emptyUFM
-        , sJumpValidAcc         = emptyUFM
-
-        , sReloadedBy           = emptyUFM
-
-        , sCleanedCount         = []
-
-        , sCleanedSpillsAcc     = 0
-        , sCleanedReloadsAcc    = 0 }
-
-
--- | Remember the associations before a jump.
-accJumpValid :: Assoc Store -> BlockId -> CleanM ()
-accJumpValid assocs target
- = modify $ \s -> s {
-        sJumpValidAcc = addToUFM_C (++)
-                                (sJumpValidAcc s)
-                                target
-                                [assocs] }
-
-
-accBlockReloadsSlot :: BlockId -> Slot -> CleanM ()
-accBlockReloadsSlot blockId slot
- = modify $ \s -> s {
-        sReloadedBy = addToUFM_C (++)
-                                (sReloadedBy s)
-                                (SSlot slot)
-                                [blockId] }
-
-
--------------------------------------------------------------------------------
--- A store location can be a stack slot or a register
-data Store
-        = SSlot Int
-        | SReg  Reg
-
-
--- | Check if this is a reg store.
-isStoreReg :: Store -> Bool
-isStoreReg ss
- = case ss of
-        SSlot _ -> False
-        SReg  _ -> True
-
-
--- Spill cleaning is only done once all virtuals have been allocated to realRegs
-instance Uniquable Store where
-    getUnique (SReg  r)
-        | RegReal (RealRegSingle i)     <- r
-        = mkRegSingleUnique i
-
-        | otherwise
-        = error $ "RegSpillClean.getUnique: found virtual reg during spill clean,"
-                ++ "only real regs expected."
-
-    getUnique (SSlot i) = mkRegSubUnique i    -- [SLPJ] I hope "SubUnique" is ok
-
-
-instance Outputable Store where
-        ppr (SSlot i)   = text "slot" <> int i
-        ppr (SReg  r)   = ppr r
-
-
--------------------------------------------------------------------------------
--- Association graphs.
--- In the spill cleaner, two store locations are associated if they are known
--- to hold the same value.
---
--- TODO: Monomorphize: I think we only ever use this with a ~ Store
-type Assoc a    = UniqFM a (UniqSet a)
-
--- | An empty association
-emptyAssoc :: Assoc a
-emptyAssoc      = emptyUFM
-
-
--- | Add an association between these two things.
--- addAssoc :: Uniquable a
---          => a -> a -> Assoc a -> Assoc a
-addAssoc :: Store -> Store -> Assoc Store -> Assoc Store
-
-addAssoc a b m
- = let  m1      = addToUFM_C unionUniqSets m  a (unitUniqSet b)
-        m2      = addToUFM_C unionUniqSets m1 b (unitUniqSet a)
-   in   m2
-
-
--- | Delete all associations to a node.
-delAssoc :: Store -> Assoc Store -> Assoc Store
-delAssoc a m
-        | Just aSet     <- lookupUFM  m a
-        , m1            <- delFromUFM m a
-        = nonDetStrictFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
-          -- It's OK to use a non-deterministic fold here because deletion is
-          -- commutative
-
-        | otherwise     = m
-
-
--- | Delete a single association edge (a -> b).
-delAssoc1 :: Store -> Store -> Assoc Store -> Assoc Store
-delAssoc1 a b m
-        | Just aSet     <- lookupUFM m a
-        = addToUFM m a (delOneFromUniqSet aSet b)
-
-        | otherwise     = m
-
-
--- | Check if these two things are associated.
-elemAssoc :: Store -> Store -> Assoc Store -> Bool
-
-elemAssoc a b m
-        = elementOfUniqSet b (closeAssoc a m)
-
-
--- | Find the refl. trans. closure of the association from this point.
-closeAssoc :: Store -> Assoc Store -> UniqSet Store
-closeAssoc a assoc
- =      closeAssoc' assoc emptyUniqSet (unitUniqSet a)
- where
-        closeAssoc' assoc visited toVisit
-         = case nonDetEltsUniqSet toVisit of
-             -- See Note [Unique Determinism and code generation]
-
-                -- nothing else to visit, we're done
-                []      -> visited
-
-                (x:_)
-                 -- we've already seen this node
-                 |  elementOfUniqSet x visited
-                 -> closeAssoc' assoc visited (delOneFromUniqSet toVisit x)
-
-                 -- haven't seen this node before,
-                 --     remember to visit all its neighbors
-                 |  otherwise
-                 -> let neighbors
-                         = case lookupUFM assoc x of
-                                Nothing         -> emptyUniqSet
-                                Just set        -> set
-
-                   in closeAssoc' assoc
-                        (addOneToUniqSet visited x)
-                        (unionUniqSets   toVisit neighbors)
-
--- | Intersect two associations.
-intersectAssoc :: Assoc Store -> Assoc Store -> Assoc Store
-intersectAssoc a b
-        = intersectUFM_C (intersectUniqSets) a b
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs
+++ /dev/null
@@ -1,320 +0,0 @@
-{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module GHC.CmmToAsm.Reg.Graph.SpillCost (
-        SpillCostRecord,
-        plusSpillCostRecord,
-        pprSpillCostRecord,
-
-        SpillCostInfo,
-        zeroSpillCostInfo,
-        plusSpillCostInfo,
-
-        slurpSpillCostInfo,
-        chooseSpill,
-
-        lifeMapFromSpillCostInfo
-) where
-import GHC.Prelude
-
-import GHC.CmmToAsm.Reg.Liveness
-import GHC.CmmToAsm.Instr
-import GHC.Platform.Reg.Class
-import GHC.Platform.Reg
-
-import GHC.Data.Graph.Base
-
-import GHC.Cmm.Dataflow.Collections (mapLookup)
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Set
-import GHC.Data.Graph.Directed          (flattenSCCs)
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Platform
-import GHC.Utils.Monad.State.Strict
-import GHC.CmmToAsm.CFG
-
-import Data.List        (nub, minimumBy)
-import Data.Maybe
-import Control.Monad (join)
-
-
--- | Records the expected cost to spill some register.
-type SpillCostRecord
- =      ( VirtualReg    -- register name
-        , Int           -- number of writes to this reg
-        , Int           -- number of reads from this reg
-        , Int)          -- number of instrs this reg was live on entry to
-
-
--- | Map of `SpillCostRecord`
-type SpillCostInfo
-        = UniqFM VirtualReg SpillCostRecord
-
-type SpillCostState = State SpillCostInfo ()
-
--- | An empty map of spill costs.
-zeroSpillCostInfo :: SpillCostInfo
-zeroSpillCostInfo       = emptyUFM
-
-
--- | Add two spill cost infos.
-plusSpillCostInfo :: SpillCostInfo -> SpillCostInfo -> SpillCostInfo
-plusSpillCostInfo sc1 sc2
-        = plusUFM_C plusSpillCostRecord sc1 sc2
-
-
--- | Add two spill cost records.
-plusSpillCostRecord :: SpillCostRecord -> SpillCostRecord -> SpillCostRecord
-plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2)
-        | r1 == r2      = (r1, a1 + a2, b1 + b2, c1 + c2)
-        | otherwise     = error "RegSpillCost.plusRegInt: regs don't match"
-
-
--- | Slurp out information used for determining spill costs.
---
---   For each vreg, the number of times it was written to, read from,
---   and the number of instructions it was live on entry to (lifetime)
---
-slurpSpillCostInfo :: forall instr statics. Instruction instr
-                   => Platform
-                   -> Maybe CFG
-                   -> LiveCmmDecl statics instr
-                   -> SpillCostInfo
-
-slurpSpillCostInfo platform cfg cmm
-        = execState (countCmm cmm) zeroSpillCostInfo
- where
-        countCmm CmmData{}              = return ()
-        countCmm (CmmProc info _ _ sccs)
-                = mapM_ (countBlock info freqMap)
-                $ flattenSCCs sccs
-            where
-                LiveInfo _ entries _ _ = info
-                freqMap = (fst . mkGlobalWeights (head entries)) <$> cfg
-
-        -- Lookup the regs that are live on entry to this block in
-        --      the info table from the CmmProc.
-        countBlock info freqMap (BasicBlock blockId instrs)
-                | LiveInfo _ _ blockLive _ <- info
-                , Just rsLiveEntry  <- mapLookup blockId blockLive
-                , rsLiveEntry_virt  <- takeVirtuals rsLiveEntry
-                = countLIs (ceiling $ blockFreq freqMap blockId) rsLiveEntry_virt instrs
-
-                | otherwise
-                = error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block"
-
-
-        countLIs :: Int -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState
-        countLIs _      _      []
-                = return ()
-
-        -- Skip over comment and delta pseudo instrs.
-        countLIs scale rsLive (LiveInstr instr Nothing : lis)
-                | isMetaInstr instr
-                = countLIs scale rsLive lis
-
-                | otherwise
-                = pprPanic "RegSpillCost.slurpSpillCostInfo"
-                $ text "no liveness information on instruction " <> pprInstr platform instr
-
-        countLIs scale rsLiveEntry (LiveInstr instr (Just live) : lis)
-         = do
-                -- Increment the lifetime counts for regs live on entry to this instr.
-                mapM_ incLifetime $ nonDetEltsUniqSet rsLiveEntry
-                    -- This is non-deterministic but we do not
-                    -- currently support deterministic code-generation.
-                    -- See Note [Unique Determinism and code generation]
-
-                -- Increment counts for what regs were read/written from.
-                let (RU read written)   = regUsageOfInstr platform instr
-                mapM_ (incUses scale) $ mapMaybe takeVirtualReg $ nub read
-                mapM_ (incDefs scale) $ mapMaybe takeVirtualReg $ nub written
-
-                -- Compute liveness for entry to next instruction.
-                let liveDieRead_virt    = takeVirtuals (liveDieRead  live)
-                let liveDieWrite_virt   = takeVirtuals (liveDieWrite live)
-                let liveBorn_virt       = takeVirtuals (liveBorn     live)
-
-                let rsLiveAcross
-                        = rsLiveEntry `minusUniqSet` liveDieRead_virt
-
-                let rsLiveNext
-                        = (rsLiveAcross `unionUniqSets` liveBorn_virt)
-                                        `minusUniqSet`  liveDieWrite_virt
-
-                countLIs scale rsLiveNext lis
-
-        incDefs     count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, count, 0, 0)
-        incUses     count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, count, 0)
-        incLifetime       reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, 1)
-
-        blockFreq :: Maybe (LabelMap Double) -> Label -> Double
-        blockFreq freqs bid
-          | Just freq <- join (mapLookup bid <$> freqs)
-          = max 1.0 (10000 * freq)
-          | otherwise
-          = 1.0 -- Only if no cfg given
-
--- | Take all the virtual registers from this set.
-takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg
-takeVirtuals set = mkUniqSet
-  [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]
-  -- See Note [Unique Determinism and code generation]
-
-
--- | Choose a node to spill from this graph
-chooseSpill
-        :: SpillCostInfo
-        -> Graph VirtualReg RegClass RealReg
-        -> VirtualReg
-
-chooseSpill info graph
- = let  cost    = spillCost_length info graph
-        node    = minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2))
-                $ nonDetEltsUFM $ graphMap graph
-                -- See Note [Unique Determinism and code generation]
-
-   in   nodeId node
-
-
--------------------------------------------------------------------------------
--- | Chaitins spill cost function is:
---
---   cost =     sum         loadCost * freq (u)  +    sum        storeCost * freq (d)
---          u <- uses (v)                         d <- defs (v)
---
---   There are no loops in our code at the moment, so we can set the freq's to 1.
---
---  If we don't have live range splitting then Chaitins function performs badly
---  if we have lots of nested live ranges and very few registers.
---
---               v1 v2 v3
---      def v1   .
---      use v1   .
---      def v2   .  .
---      def v3   .  .  .
---      use v1   .  .  .
---      use v3   .  .  .
---      use v2   .  .
---      use v1   .
---
---           defs uses degree   cost
---      v1:  1     3     3      1.5
---      v2:  1     2     3      1.0
---      v3:  1     1     3      0.666
---
---   v3 has the lowest cost, but if we only have 2 hardregs and we insert
---   spill code for v3 then this isn't going to improve the colorability of
---   the graph.
---
---  When compiling SHA1, which as very long basic blocks and some vregs
---  with very long live ranges the allocator seems to try and spill from
---  the inside out and eventually run out of stack slots.
---
---  Without live range splitting, its's better to spill from the outside
---  in so set the cost of very long live ranges to zero
---
-
--- spillCost_chaitin
---         :: SpillCostInfo
---         -> Graph VirtualReg RegClass RealReg
---         -> VirtualReg
---         -> Float
-
--- spillCost_chaitin info graph reg
---         -- Spilling a live range that only lives for 1 instruction
---         -- isn't going to help us at all - and we definitely want to avoid
---         -- trying to re-spill previously inserted spill code.
---         | lifetime <= 1         = 1/0
-
---         -- It's unlikely that we'll find a reg for a live range this long
---         -- better to spill it straight up and not risk trying to keep it around
---         -- and have to go through the build/color cycle again.
-
---         -- To facility this we scale down the spill cost of long ranges.
---         -- This makes sure long ranges are still spilled first.
---         -- But this way spill cost remains relevant for long live
---         -- ranges.
---         | lifetime >= 128
---         = (spillCost / conflicts) / 10.0
-
-
---         -- Otherwise revert to chaitin's regular cost function.
---         | otherwise = (spillCost / conflicts)
---         where
---             !spillCost = fromIntegral (uses + defs) :: Float
---             conflicts = fromIntegral (nodeDegree classOfVirtualReg graph reg)
---             (_, defs, uses, lifetime)
---                 = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg
-
-
--- Just spill the longest live range.
-spillCost_length
-        :: SpillCostInfo
-        -> Graph VirtualReg RegClass RealReg
-        -> VirtualReg
-        -> Float
-
-spillCost_length info _ reg
-        | lifetime <= 1         = 1/0
-        | otherwise             = 1 / fromIntegral lifetime
-        where (_, _, _, lifetime)
-                = fromMaybe (reg, 0, 0, 0)
-                $ lookupUFM info reg
-
-
--- | Extract a map of register lifetimes from a `SpillCostInfo`.
-lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM VirtualReg (VirtualReg, Int)
-lifeMapFromSpillCostInfo info
-        = listToUFM
-        $ map (\(r, _, _, life) -> (r, (r, life)))
-        $ nonDetEltsUFM info
-        -- See Note [Unique Determinism and code generation]
-
-
--- | Determine the degree (number of neighbors) of this node which
---   have the same class.
-nodeDegree
-        :: (VirtualReg -> RegClass)
-        -> Graph VirtualReg RegClass RealReg
-        -> VirtualReg
-        -> Int
-
-nodeDegree classOfVirtualReg graph reg
-        | Just node     <- lookupUFM (graphMap graph) reg
-
-        , virtConflicts
-           <- length
-           $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg)
-           $ nonDetEltsUniqSet
-           -- See Note [Unique Determinism and code generation]
-           $ nodeConflicts node
-
-        = virtConflicts + sizeUniqSet (nodeExclusions node)
-
-        | otherwise
-        = 0
-
-
--- | Show a spill cost record, including the degree from the graph
---   and final calculated spill cost.
-pprSpillCostRecord
-        :: (VirtualReg -> RegClass)
-        -> (Reg -> SDoc)
-        -> Graph VirtualReg RegClass RealReg
-        -> SpillCostRecord
-        -> SDoc
-
-pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life)
-        =  hsep
-        [ pprReg (RegVirtual reg)
-        , ppr uses
-        , ppr defs
-        , ppr life
-        , ppr $ nodeDegree regClass graph reg
-        , text $ show $ (fromIntegral (uses + defs)
-                       / fromIntegral (nodeDegree regClass graph reg) :: Float) ]
-
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs
+++ /dev/null
@@ -1,365 +0,0 @@
-{-# LANGUAGE BangPatterns, DeriveFunctor #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
--- | Carries interesting info for debugging / profiling of the
---   graph coloring register allocator.
-module GHC.CmmToAsm.Reg.Graph.Stats (
-        RegAllocStats (..),
-
-        pprStats,
-        pprStatsSpills,
-        pprStatsLifetimes,
-        pprStatsConflict,
-        pprStatsLifeConflict,
-
-        countSRMs, addSRM
-) where
-
-import GHC.Prelude
-
-import qualified GHC.Data.Graph.Color as Color
-import GHC.CmmToAsm.Reg.Liveness
-import GHC.CmmToAsm.Reg.Graph.Spill
-import GHC.CmmToAsm.Reg.Graph.SpillCost
-import GHC.CmmToAsm.Reg.Graph.TrivColorable
-import GHC.CmmToAsm.Reg.Target
-import GHC.CmmToAsm.Instr
-import GHC.CmmToAsm.Types
-
-import GHC.Platform
-import GHC.Platform.Reg
-import GHC.Platform.Reg.Class
-
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Set
-import GHC.Utils.Outputable
-import GHC.Utils.Monad.State.Strict
-
--- | Holds interesting statistics from the register allocator.
-data RegAllocStats statics instr
-
-        -- Information about the initial conflict graph.
-        = RegAllocStatsStart
-        { -- | Initial code, with liveness.
-          raLiveCmm     :: [LiveCmmDecl statics instr]
-
-          -- | The initial, uncolored graph.
-        , raGraph       :: Color.Graph VirtualReg RegClass RealReg
-
-          -- | Information to help choose which regs to spill.
-        , raSpillCosts  :: SpillCostInfo
-
-          -- | Target platform
-        , raPlatform    :: !Platform
-        }
-
-
-        -- Information about an intermediate graph.
-        -- This is one that we couldn't color, so had to insert spill code
-        -- instruction stream.
-        | RegAllocStatsSpill
-        { -- | Code we tried to allocate registers for.
-          raCode        :: [LiveCmmDecl statics instr]
-
-          -- | Partially colored graph.
-        , raGraph       :: Color.Graph VirtualReg RegClass RealReg
-
-          -- | The regs that were coalesced.
-        , raCoalesced   :: UniqFM VirtualReg VirtualReg
-
-          -- | Spiller stats.
-        , raSpillStats  :: SpillStats
-
-          -- | Number of instructions each reg lives for.
-        , raSpillCosts  :: SpillCostInfo
-
-          -- | Code with spill instructions added.
-        , raSpilled     :: [LiveCmmDecl statics instr]
-
-          -- | Target platform
-        , raPlatform    :: !Platform
-        }
-
-
-        -- a successful coloring
-        | RegAllocStatsColored
-        { -- | Code we tried to allocate registers for.
-          raCode          :: [LiveCmmDecl statics instr]
-
-          -- | Uncolored graph.
-        , raGraph         :: Color.Graph VirtualReg RegClass RealReg
-
-          -- | Coalesced and colored graph.
-        , raGraphColored  :: Color.Graph VirtualReg RegClass RealReg
-
-          -- | Regs that were coalesced.
-        , raCoalesced     :: UniqFM VirtualReg VirtualReg
-
-          -- | Code with coalescings applied.
-        , raCodeCoalesced :: [LiveCmmDecl statics instr]
-
-          -- | Code with vregs replaced by hregs.
-        , raPatched       :: [LiveCmmDecl statics instr]
-
-          -- | Code with unneeded spill\/reloads cleaned out.
-        , raSpillClean    :: [LiveCmmDecl statics instr]
-
-          -- | Final code.
-        , raFinal         :: [NatCmmDecl statics instr]
-
-          -- | Spill\/reload\/reg-reg moves present in this code.
-        , raSRMs          :: (Int, Int, Int)
-
-          -- | Target platform
-        , raPlatform    :: !Platform
-        }
-        deriving (Functor)
-
-
-instance (OutputableP Platform statics, OutputableP Platform instr)
-       => Outputable (RegAllocStats statics instr) where
-
- ppr (s@RegAllocStatsStart{})
-    =      text "#  Start"
-        $$ text "#  Native code with liveness information."
-        $$ pdoc (raPlatform s) (raLiveCmm s)
-        $$ text ""
-        $$ text "#  Initial register conflict graph."
-        $$ Color.dotGraph
-                (targetRegDotColor (raPlatform s))
-                (trivColorable (raPlatform s)
-                        (targetVirtualRegSqueeze (raPlatform s))
-                        (targetRealRegSqueeze (raPlatform s)))
-                (raGraph s)
-
-
- ppr (s@RegAllocStatsSpill{}) =
-           text "#  Spill"
-
-        $$ text "#  Code with liveness information."
-        $$ pdoc (raPlatform s) (raCode s)
-        $$ text ""
-
-        $$ (if (not $ isNullUFM $ raCoalesced s)
-                then    text "#  Registers coalesced."
-                        $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr)
-                        $$ text ""
-                else empty)
-
-        $$ text "#  Spills inserted."
-        $$ ppr (raSpillStats s)
-        $$ text ""
-
-        $$ text "#  Code with spills inserted."
-        $$ pdoc (raPlatform s) (raSpilled s)
-
-
- ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) })
-    =      text "#  Colored"
-
-        $$ text "#  Code with liveness information."
-        $$ pdoc (raPlatform s) (raCode s)
-        $$ text ""
-
-        $$ text "#  Register conflict graph (colored)."
-        $$ Color.dotGraph
-                (targetRegDotColor (raPlatform s))
-                (trivColorable (raPlatform s)
-                        (targetVirtualRegSqueeze (raPlatform s))
-                        (targetRealRegSqueeze (raPlatform s)))
-                (raGraphColored s)
-        $$ text ""
-
-        $$ (if (not $ isNullUFM $ raCoalesced s)
-                then    text "#  Registers coalesced."
-                        $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr)
-                        $$ text ""
-                else empty)
-
-        $$ text "#  Native code after coalescings applied."
-        $$ pdoc (raPlatform s) (raCodeCoalesced s)
-        $$ text ""
-
-        $$ text "#  Native code after register allocation."
-        $$ pdoc (raPlatform s) (raPatched s)
-        $$ text ""
-
-        $$ text "#  Clean out unneeded spill/reloads."
-        $$ pdoc (raPlatform s) (raSpillClean s)
-        $$ text ""
-
-        $$ text "#  Final code, after rewriting spill/rewrite pseudo instrs."
-        $$ pdoc (raPlatform s) (raFinal s)
-        $$ text ""
-        $$  text "#  Score:"
-        $$ (text "#          spills  inserted: " <> int spills)
-        $$ (text "#          reloads inserted: " <> int reloads)
-        $$ (text "#   reg-reg moves remaining: " <> int moves)
-        $$ text ""
-
-
--- | Do all the different analysis on this list of RegAllocStats
-pprStats
-        :: [RegAllocStats statics instr]
-        -> Color.Graph VirtualReg RegClass RealReg
-        -> SDoc
-
-pprStats stats graph
- = let  outSpills       = pprStatsSpills    stats
-        outLife         = pprStatsLifetimes stats
-        outConflict     = pprStatsConflict  stats
-        outScatter      = pprStatsLifeConflict stats graph
-
-  in    vcat [outSpills, outLife, outConflict, outScatter]
-
-
--- | Dump a table of how many spill loads \/ stores were inserted for each vreg.
-pprStatsSpills
-        :: [RegAllocStats statics instr] -> SDoc
-
-pprStatsSpills stats
- = let
-        finals  = [ s   | s@RegAllocStatsColored{} <- stats]
-
-        -- sum up how many stores\/loads\/reg-reg-moves were left in the code
-        total   = foldl' addSRM (0, 0, 0)
-                $ map raSRMs finals
-
-    in  (  text "-- spills-added-total"
-        $$ text "--    (stores, loads, reg_reg_moves_remaining)"
-        $$ ppr total
-        $$ text "")
-
-
--- | Dump a table of how long vregs tend to live for in the initial code.
-pprStatsLifetimes
-        :: [RegAllocStats statics instr] -> SDoc
-
-pprStatsLifetimes stats
- = let  info            = foldl' plusSpillCostInfo zeroSpillCostInfo
-                                [ raSpillCosts s
-                                        | s@RegAllocStatsStart{} <- stats ]
-
-        lifeBins        = binLifetimeCount $ lifeMapFromSpillCostInfo info
-
-   in   (  text "-- vreg-population-lifetimes"
-        $$ text "--   (instruction_count, number_of_vregs_that_lived_that_long)"
-        $$ pprUFM lifeBins (vcat . map ppr)
-        $$ text "\n")
-
-
-binLifetimeCount :: UniqFM VirtualReg (VirtualReg, Int) -> UniqFM Int (Int, Int)
-binLifetimeCount fm
- = let  lifes   = map (\l -> (l, (l, 1)))
-                $ map snd
-                $ nonDetEltsUFM fm
-                -- See Note [Unique Determinism and code generation]
-
-   in   addListToUFM_C
-                (\(l1, c1) (_, c2) -> (l1, c1 + c2))
-                emptyUFM
-                lifes
-
-
--- | Dump a table of how many conflicts vregs tend to have in the initial code.
-pprStatsConflict
-        :: [RegAllocStats statics instr] -> SDoc
-
-pprStatsConflict stats
- = let  confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2)))
-                        emptyUFM
-                $ map Color.slurpNodeConflictCount
-                        [ raGraph s | s@RegAllocStatsStart{} <- stats ]
-
-   in   (  text "-- vreg-conflicts"
-        $$ text "--   (conflict_count, number_of_vregs_that_had_that_many_conflicts)"
-        $$ pprUFM confMap (vcat . map ppr)
-        $$ text "\n")
-
-
--- | For every vreg, dump how many conflicts it has, and its lifetime.
---      Good for making a scatter plot.
-pprStatsLifeConflict
-        :: [RegAllocStats statics instr]
-        -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph
-        -> SDoc
-
-pprStatsLifeConflict stats graph
- = let  lifeMap = lifeMapFromSpillCostInfo
-                $ foldl' plusSpillCostInfo zeroSpillCostInfo
-                $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]
-
-        scatter = map   (\r ->  let lifetime  = case lookupUFM lifeMap r of
-                                                      Just (_, l) -> l
-                                                      Nothing     -> 0
-                                    Just node = Color.lookupNode graph r
-                                in parens $ hcat $ punctuate (text ", ")
-                                        [ doubleQuotes $ ppr $ Color.nodeId node
-                                        , ppr $ sizeUniqSet (Color.nodeConflicts node)
-                                        , ppr $ lifetime ])
-                $ map Color.nodeId
-                $ nonDetEltsUFM
-                -- See Note [Unique Determinism and code generation]
-                $ Color.graphMap graph
-
-   in   (  text "-- vreg-conflict-lifetime"
-        $$ text "--   (vreg, vreg_conflicts, vreg_lifetime)"
-        $$ (vcat scatter)
-        $$ text "\n")
-
-
--- | Count spill/reload/reg-reg moves.
---      Lets us see how well the register allocator has done.
-countSRMs
-        :: Instruction instr
-        => LiveCmmDecl statics instr -> (Int, Int, Int)
-
-countSRMs cmm
-        = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)
-
-
-countSRM_block
-        :: Instruction instr
-        => GenBasicBlock (LiveInstr instr)
-        -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr))
-
-countSRM_block (BasicBlock i instrs)
- = do   instrs' <- mapM countSRM_instr instrs
-        return  $ BasicBlock i instrs'
-
-
-countSRM_instr
-        :: Instruction instr
-        => LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)
-
-countSRM_instr li
-        | LiveInstr SPILL{} _    <- li
-        = do    modify  $ \(s, r, m)    -> (s + 1, r, m)
-                return li
-
-        | LiveInstr RELOAD{} _  <- li
-        = do    modify  $ \(s, r, m)    -> (s, r + 1, m)
-                return li
-
-        | LiveInstr instr _     <- li
-        , Just _        <- takeRegRegMoveInstr instr
-        = do    modify  $ \(s, r, m)    -> (s, r, m + 1)
-                return li
-
-        | otherwise
-        =       return li
-
-
--- sigh..
-addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
-addSRM (s1, r1, m1) (s2, r2, m2)
- = let  !s = s1 + s2
-        !r = r1 + r2
-        !m = m1 + m2
-   in   (s, r, m)
-
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs b/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs
+++ /dev/null
@@ -1,276 +0,0 @@
-module GHC.CmmToAsm.Reg.Graph.TrivColorable (
-        trivColorable,
-)
-
-where
-
-import GHC.Prelude
-
-import GHC.Platform.Reg.Class
-import GHC.Platform.Reg
-
-import GHC.Data.Graph.Base
-
-import GHC.Types.Unique.Set
-import GHC.Platform
-import GHC.Utils.Panic
-
--- trivColorable ---------------------------------------------------------------
-
--- trivColorable function for the graph coloring allocator
---
---      This gets hammered by scanGraph during register allocation,
---      so needs to be fairly efficient.
---
---      NOTE:   This only works for architectures with just RcInteger and RcDouble
---              (which are disjoint) ie. x86, x86_64 and ppc
---
---      The number of allocatable regs is hard coded in here so we can do
---              a fast comparison in trivColorable.
---
---      It's ok if these numbers are _less_ than the actual number of free
---              regs, but they can't be more or the register conflict
---              graph won't color.
---
---      If the graph doesn't color then the allocator will panic, but it won't
---              generate bad object code or anything nasty like that.
---
---      There is an allocatableRegsInClass :: RegClass -> Int, but doing
---      the unboxing is too slow for us here.
---      TODO: Is that still true? Could we use allocatableRegsInClass
---      without losing performance now?
---
---      Look at rts/include/stg/MachRegs.h to get the numbers.
---
-
-
--- Disjoint registers ----------------------------------------------------------
---
---      The definition has been unfolded into individual cases for speed.
---      Each architecture has a different register setup, so we use a
---      different regSqueeze function for each.
---
-accSqueeze
-        :: Int
-        -> Int
-        -> (reg -> Int)
-        -> UniqSet reg
-        -> Int
-
-accSqueeze count maxCount squeeze us = acc count (nonDetEltsUniqSet us)
-  -- See Note [Unique Determinism and code generation]
-  where acc count [] = count
-        acc count _ | count >= maxCount = count
-        acc count (r:rs) = acc (count + squeeze r) rs
-
-{- Note [accSqueeze]
-~~~~~~~~~~~~~~~~~~~~
-BL 2007/09
-Doing a nice fold over the UniqSet makes trivColorable use
-32% of total compile time and 42% of total alloc when compiling SHA1.hs from darcs.
-Therefore the UniqFM is made non-abstract and we use custom fold.
-
-MS 2010/04
-When converting UniqFM to use Data.IntMap, the fold cannot use UniqFM internal
-representation any more. But it is imperative that the accSqueeze stops
-the folding if the count gets greater or equal to maxCount. We thus convert
-UniqFM to a (lazy) list, do the fold and stops if necessary, which was
-the most efficient variant tried. Benchmark compiling 10-times SHA1.hs follows.
-(original = previous implementation, folding = fold of the whole UFM,
- lazyFold = the current implementation,
- hackFold = using internal representation of Data.IntMap)
-
-                                 original  folding   hackFold  lazyFold
- -O -fasm (used everywhere)      31.509s   30.387s   30.791s   30.603s
-                                 100.00%   96.44%    97.72%    97.12%
- -fregs-graph                    67.938s   74.875s   62.673s   64.679s
-                                 100.00%   110.21%   92.25%    95.20%
- -fregs-iterative                89.761s   143.913s  81.075s   86.912s
-                                 100.00%   160.33%   90.32%    96.83%
- -fnew-codegen                   38.225s   37.142s   37.551s   37.119s
-                                 100.00%   97.17%    98.24%    97.11%
- -fnew-codegen -fregs-graph      91.786s   91.51s    87.368s   86.88s
-                                 100.00%   99.70%    95.19%    94.65%
- -fnew-codegen -fregs-iterative  206.72s   343.632s  194.694s  208.677s
-                                 100.00%   166.23%   94.18%    100.95%
--}
-
-trivColorable
-        :: Platform
-        -> (RegClass -> VirtualReg -> Int)
-        -> (RegClass -> RealReg    -> Int)
-        -> Triv VirtualReg RegClass RealReg
-
-trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions
-        | let cALLOCATABLE_REGS_INTEGER
-                  =        (case platformArch platform of
-                            ArchX86       -> 3
-                            ArchX86_64    -> 5
-                            ArchPPC       -> 16
-                            ArchPPC_64 _  -> 15
-                            ArchARM _ _ _ -> panic "trivColorable ArchARM"
-                            -- We should be able to allocate *a lot* more in principle.
-                            -- essentially all 32 - SP, so 31, we'd trash the link reg
-                            -- as well as the platform and all others though.
-                            ArchAArch64   -> 18
-                            ArchAlpha     -> panic "trivColorable ArchAlpha"
-                            ArchMipseb    -> panic "trivColorable ArchMipseb"
-                            ArchMipsel    -> panic "trivColorable ArchMipsel"
-                            ArchS390X     -> panic "trivColorable ArchS390X"
-                            ArchRISCV64   -> panic "trivColorable ArchRISCV64"
-                            ArchJavaScript-> panic "trivColorable ArchJavaScript"
-                            ArchWasm32    -> panic "trivColorable ArchWasm32"
-                            ArchUnknown   -> panic "trivColorable ArchUnknown")
-        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_INTEGER
-                                (virtualRegSqueeze RcInteger)
-                                conflicts
-
-        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_INTEGER
-                                (realRegSqueeze   RcInteger)
-                                exclusions
-
-        = count3 < cALLOCATABLE_REGS_INTEGER
-
-trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions
-        | let cALLOCATABLE_REGS_FLOAT
-                  =        (case platformArch platform of
-                    -- On x86_64 and x86, Float and RcDouble
-                    -- use the same registers,
-                    -- so we only use RcDouble to represent the
-                    -- register allocation problem on those types.
-                            ArchX86       -> 0
-                            ArchX86_64    -> 0
-                            ArchPPC       -> 0
-                            ArchPPC_64 _  -> 0
-                            ArchARM _ _ _ -> panic "trivColorable ArchARM"
-                            -- we can in principle address all the float regs as
-                            -- segments. So we could have 64 Float regs. Or
-                            -- 128 Half regs, or even 256 Byte regs.
-                            ArchAArch64   -> 0
-                            ArchAlpha     -> panic "trivColorable ArchAlpha"
-                            ArchMipseb    -> panic "trivColorable ArchMipseb"
-                            ArchMipsel    -> panic "trivColorable ArchMipsel"
-                            ArchS390X     -> panic "trivColorable ArchS390X"
-                            ArchRISCV64   -> panic "trivColorable ArchRISCV64"
-                            ArchJavaScript-> panic "trivColorable ArchJavaScript"
-                            ArchWasm32    -> panic "trivColorable ArchWasm32"
-                            ArchUnknown   -> panic "trivColorable ArchUnknown")
-        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_FLOAT
-                                (virtualRegSqueeze RcFloat)
-                                conflicts
-
-        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_FLOAT
-                                (realRegSqueeze   RcFloat)
-                                exclusions
-
-        = count3 < cALLOCATABLE_REGS_FLOAT
-
-trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions
-        | let cALLOCATABLE_REGS_DOUBLE
-                  =        (case platformArch platform of
-                            ArchX86       -> 8
-                            -- in x86 32bit mode sse2 there are only
-                            -- 8 XMM registers xmm0 ... xmm7
-                            ArchX86_64    -> 10
-                            -- in x86_64 there are 16 XMM registers
-                            -- xmm0 .. xmm15, here 10 is a
-                            -- "dont need to solve conflicts" count that
-                            -- was chosen at some point in the past.
-                            ArchPPC       -> 26
-                            ArchPPC_64 _  -> 20
-                            ArchARM _ _ _ -> panic "trivColorable ArchARM"
-                            ArchAArch64   -> 32
-                            ArchAlpha     -> panic "trivColorable ArchAlpha"
-                            ArchMipseb    -> panic "trivColorable ArchMipseb"
-                            ArchMipsel    -> panic "trivColorable ArchMipsel"
-                            ArchS390X     -> panic "trivColorable ArchS390X"
-                            ArchRISCV64   -> panic "trivColorable ArchRISCV64"
-                            ArchJavaScript-> panic "trivColorable ArchJavaScript"
-                            ArchWasm32    -> panic "trivColorable ArchWasm32"
-                            ArchUnknown   -> panic "trivColorable ArchUnknown")
-        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_DOUBLE
-                                (virtualRegSqueeze RcDouble)
-                                conflicts
-
-        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_DOUBLE
-                                (realRegSqueeze   RcDouble)
-                                exclusions
-
-        = count3 < cALLOCATABLE_REGS_DOUBLE
-
-
-
-
--- Specification Code ----------------------------------------------------------
---
---      The trivColorable function for each particular architecture should
---      implement the following function, but faster.
---
-
-{-
-trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool
-trivColorable classN conflicts exclusions
- = let
-
-        acc :: Reg -> (Int, Int) -> (Int, Int)
-        acc r (cd, cf)
-         = case regClass r of
-                RcInteger       -> (cd+1, cf)
-                RcFloat         -> (cd,   cf+1)
-                _               -> panic "Regs.trivColorable: reg class not handled"
-
-        tmp                     = nonDetFoldUFM acc (0, 0) conflicts
-        (countInt,  countFloat) = nonDetFoldUFM acc tmp    exclusions
-
-        squeese         = worst countInt   classN RcInteger
-                        + worst countFloat classN RcFloat
-
-   in   squeese < allocatableRegsInClass classN
-
--- | Worst case displacement
---      node N of classN has n neighbors of class C.
---
---      We currently only have RcInteger and RcDouble, which don't conflict at all.
---      This is a bit boring compared to what's in RegArchX86.
---
-worst :: Int -> RegClass -> RegClass -> Int
-worst n classN classC
- = case classN of
-        RcInteger
-         -> case classC of
-                RcInteger       -> min n (allocatableRegsInClass RcInteger)
-                RcFloat         -> 0
-
-        RcDouble
-         -> case classC of
-                RcFloat         -> min n (allocatableRegsInClass RcFloat)
-                RcInteger       -> 0
-
--- allocatableRegs is allMachRegNos with the fixed-use regs removed.
--- i.e., these are the regs for which we are prepared to allow the
--- register allocator to attempt to map VRegs to.
-allocatableRegs :: [RegNo]
-allocatableRegs
-   = let isFree i = freeReg i
-     in  filter isFree allMachRegNos
-
-
--- | The number of regs in each class.
---      We go via top level CAFs to ensure that we're not recomputing
---      the length of these lists each time the fn is called.
-allocatableRegsInClass :: RegClass -> Int
-allocatableRegsInClass cls
- = case cls of
-        RcInteger       -> allocatableRegsInteger
-        RcFloat         -> allocatableRegsDouble
-
-allocatableRegsInteger :: Int
-allocatableRegsInteger
-        = length $ filter (\r -> regClass r == RcInteger)
-                 $ map RealReg allocatableRegs
-
-allocatableRegsFloat :: Int
-allocatableRegsFloat
-        = length $ filter (\r -> regClass r == RcFloat
-                 $ map RealReg allocatableRegs
--}
diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs b/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Graph/X86.hs
+++ /dev/null
@@ -1,161 +0,0 @@
-
--- | A description of the register set of the X86.
---
---   This isn't used directly in GHC proper.
---
---   See RegArchBase.hs for the reference.
---   See MachRegs.hs for the actual trivColorable function used in GHC.
---
-module GHC.CmmToAsm.Reg.Graph.X86 (
-        classOfReg,
-        regsOfClass,
-        regName,
-        regAlias,
-        worst,
-        squeese,
-) where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.Reg.Graph.Base  (Reg(..), RegSub(..), RegClass(..))
-import GHC.Types.Unique.Set
-
-import qualified Data.Array as A
-
-
--- | Determine the class of a register
-classOfReg :: Reg -> RegClass
-classOfReg reg
- = case reg of
-        Reg c _         -> c
-
-        RegSub SubL16 _ -> ClassG16
-        RegSub SubL8  _ -> ClassG8
-        RegSub SubL8H _ -> ClassG8
-
-
--- | Determine all the regs that make up a certain class.
-regsOfClass :: RegClass -> UniqSet Reg
-regsOfClass c
- = case c of
-        ClassG32
-         -> mkUniqSet   [ Reg ClassG32  i
-                        | i <- [0..7] ]
-
-        ClassG16
-         -> mkUniqSet   [ RegSub SubL16 (Reg ClassG32 i)
-                        | i <- [0..7] ]
-
-        ClassG8
-         -> unionUniqSets
-                (mkUniqSet [ RegSub SubL8  (Reg ClassG32 i) | i <- [0..3] ])
-                (mkUniqSet [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ])
-
-        ClassF64
-         -> mkUniqSet   [ Reg ClassF64  i
-                        | i <- [0..5] ]
-
-
--- | Determine the common name of a reg
---      returns Nothing if this reg is not part of the machine.
-regName :: Reg -> Maybe String
-regName reg
- = case reg of
-        Reg ClassG32 i
-         | i <= 7 ->
-           let names = A.listArray (0,8)
-                       [ "eax", "ebx", "ecx", "edx"
-                       , "ebp", "esi", "edi", "esp" ]
-           in Just $ names A.! i
-
-        RegSub SubL16 (Reg ClassG32 i)
-         | i <= 7 ->
-           let names = A.listArray (0,8)
-                       [ "ax", "bx", "cx", "dx"
-                       , "bp", "si", "di", "sp"]
-           in Just $ names A.! i
-
-        RegSub SubL8  (Reg ClassG32 i)
-         | i <= 3 ->
-           let names = A.listArray (0,4) [ "al", "bl", "cl", "dl"]
-           in Just $ names A.! i
-
-        RegSub SubL8H (Reg ClassG32 i)
-         | i <= 3 ->
-           let names = A.listArray (0,4) [ "ah", "bh", "ch", "dh"]
-           in Just $ names A.! i
-
-        _         -> Nothing
-
-
--- | Which regs alias what other regs.
-regAlias :: Reg -> UniqSet Reg
-regAlias reg
- = case reg of
-
-        -- 32 bit regs alias all of the subregs
-        Reg ClassG32 i
-
-         -- for eax, ebx, ecx, eds
-         |  i <= 3
-         -> mkUniqSet
-         $ [ Reg ClassG32 i,   RegSub SubL16 reg
-           , RegSub SubL8 reg, RegSub SubL8H reg ]
-
-         -- for esi, edi, esp, ebp
-         | 4 <= i && i <= 7
-         -> mkUniqSet
-         $ [ Reg ClassG32 i,   RegSub SubL16 reg ]
-
-        -- 16 bit subregs alias the whole reg
-        RegSub SubL16 r@(Reg ClassG32 _)
-         ->     regAlias r
-
-        -- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg
-        RegSub SubL8  r@(Reg ClassG32 _)
-         -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ]
-
-        RegSub SubL8H r@(Reg ClassG32 _)
-         -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ]
-
-        -- fp
-        Reg ClassF64 _
-         -> unitUniqSet reg
-
-        _ -> error "regAlias: invalid register"
-
-
--- | Optimised versions of RegColorBase.{worst, squeese} specific to x86
-worst :: Int -> RegClass -> RegClass -> Int
-worst n classN classC
- = case classN of
-        ClassG32
-         -> case classC of
-                ClassG32        -> min n 8
-                ClassG16        -> min n 8
-                ClassG8         -> min n 4
-                ClassF64        -> 0
-
-        ClassG16
-         -> case classC of
-                ClassG32        -> min n 8
-                ClassG16        -> min n 8
-                ClassG8         -> min n 4
-                ClassF64        -> 0
-
-        ClassG8
-         -> case classC of
-                ClassG32        -> min (n*2) 8
-                ClassG16        -> min (n*2) 8
-                ClassG8         -> min n 8
-                ClassF64        -> 0
-
-        ClassF64
-         -> case classC of
-                ClassF64        -> min n 6
-                _               -> 0
-
-squeese :: RegClass -> [(Int, RegClass)] -> Int
-squeese classN countCs
-        = sum (map (\(i, classC) -> worst i classN classC) countCs)
-
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear.hs
+++ /dev/null
@@ -1,995 +0,0 @@
-{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
-{-# LANGUAGE ConstraintKinds #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
------------------------------------------------------------------------------
---
--- The register allocator
---
--- (c) The University of Glasgow 2004
---
------------------------------------------------------------------------------
-
-{-
-The algorithm is roughly:
-
-  1) Compute strongly connected components of the basic block list.
-
-  2) Compute liveness (mapping from pseudo register to
-     point(s) of death?).
-
-  3) Walk instructions in each basic block.  We keep track of
-        (a) Free real registers (a bitmap?)
-        (b) Current assignment of temporaries to machine registers and/or
-            spill slots (call this the "assignment").
-        (c) Partial mapping from basic block ids to a virt-to-loc mapping.
-            When we first encounter a branch to a basic block,
-            we fill in its entry in this table with the current mapping.
-
-     For each instruction:
-        (a) For each temporary *read* by the instruction:
-            If the temporary does not have a real register allocation:
-                - Allocate a real register from the free list.  If
-                  the list is empty:
-                  - Find a temporary to spill.  Pick one that is
-                    not used in this instruction (ToDo: not
-                    used for a while...)
-                  - generate a spill instruction
-                - If the temporary was previously spilled,
-                  generate an instruction to read the temp from its spill loc.
-            (optimisation: if we can see that a real register is going to
-            be used soon, then don't use it for allocation).
-
-        (b) For each real register clobbered by this instruction:
-            If a temporary resides in it,
-                If the temporary is live after this instruction,
-                    Move the temporary to another (non-clobbered & free) reg,
-                    or spill it to memory.  Mark the temporary as residing
-                    in both memory and a register if it was spilled (it might
-                    need to be read by this instruction).
-
-            (ToDo: this is wrong for jump instructions?)
-
-            We do this after step (a), because if we start with
-               movq v1, %rsi
-            which is an instruction that clobbers %rsi, if v1 currently resides
-            in %rsi we want to get
-               movq %rsi, %freereg
-               movq %rsi, %rsi     -- will disappear
-            instead of
-               movq %rsi, %freereg
-               movq %freereg, %rsi
-
-        (c) Update the current assignment
-
-        (d) If the instruction is a branch:
-              if the destination block already has a register assignment,
-                Generate a new block with fixup code and redirect the
-                jump to the new block.
-              else,
-                Update the block id->assignment mapping with the current
-                assignment.
-
-        (e) Delete all register assignments for temps which are read
-            (only) and die here.  Update the free register list.
-
-        (f) Mark all registers clobbered by this instruction as not free,
-            and mark temporaries which have been spilled due to clobbering
-            as in memory (step (a) marks then as in both mem & reg).
-
-        (g) For each temporary *written* by this instruction:
-            Allocate a real register as for (b), spilling something
-            else if necessary.
-                - except when updating the assignment, drop any memory
-                  locations that the temporary was previously in, since
-                  they will be no longer valid after this instruction.
-
-        (h) Delete all register assignments for temps which are
-            written and die here (there should rarely be any).  Update
-            the free register list.
-
-        (i) Rewrite the instruction with the new mapping.
-
-        (j) For each spilled reg known to be now dead, re-add its stack slot
-            to the free list.
-
--}
-
-module GHC.CmmToAsm.Reg.Linear (
-        regAlloc,
-        module  GHC.CmmToAsm.Reg.Linear.Base,
-        module  GHC.CmmToAsm.Reg.Linear.Stats
-  ) where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.Reg.Linear.State
-import GHC.CmmToAsm.Reg.Linear.Base
-import GHC.CmmToAsm.Reg.Linear.StackMap
-import GHC.CmmToAsm.Reg.Linear.FreeRegs
-import GHC.CmmToAsm.Reg.Linear.Stats
-import GHC.CmmToAsm.Reg.Linear.JoinToTargets
-import qualified GHC.CmmToAsm.Reg.Linear.PPC     as PPC
-import qualified GHC.CmmToAsm.Reg.Linear.X86     as X86
-import qualified GHC.CmmToAsm.Reg.Linear.X86_64  as X86_64
-import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64
-import GHC.CmmToAsm.Reg.Target
-import GHC.CmmToAsm.Reg.Liveness
-import GHC.CmmToAsm.Reg.Utils
-import GHC.CmmToAsm.Instr
-import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Types
-import GHC.Platform.Reg
-import GHC.Platform.Reg.Class (RegClass(..))
-
-import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm hiding (RegSet)
-
-import GHC.Data.Graph.Directed
-import GHC.Types.Unique
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Supply
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Platform
-
-import Data.Maybe
-import Data.List (partition, nub)
-import Control.Monad
-
--- -----------------------------------------------------------------------------
--- Top level of the register allocator
-
--- Allocate registers
-regAlloc
-        :: Instruction instr
-        => NCGConfig
-        -> LiveCmmDecl statics instr
-        -> UniqSM ( NatCmmDecl statics instr
-                  , Maybe Int  -- number of extra stack slots required,
-                               -- beyond maxSpillSlots
-                  , Maybe RegAllocStats
-                  )
-
-regAlloc _ (CmmData sec d)
-        = return
-                ( CmmData sec d
-                , Nothing
-                , Nothing )
-
-regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live [])
-        = return ( CmmProc info lbl live (ListGraph [])
-                 , Nothing
-                 , Nothing )
-
-regAlloc config (CmmProc static lbl live sccs)
-        | LiveInfo info entry_ids@(first_id:_) block_live _ <- static
-        = do
-                -- do register allocation on each component.
-                !(!final_blocks, !stats, !stack_use)
-                        <- linearRegAlloc config entry_ids block_live sccs
-
-                -- make sure the block that was first in the input list
-                --      stays at the front of the output
-                let !(!(!first':_), !rest')
-                                = partition ((== first_id) . blockId) final_blocks
-
-                let max_spill_slots = maxSpillSlots config
-                    extra_stack
-                      | stack_use > max_spill_slots
-                      = Just $! stack_use - max_spill_slots
-                      | otherwise
-                      = Nothing
-
-                return  ( CmmProc info lbl live (ListGraph (first' : rest'))
-                        , extra_stack
-                        , Just stats)
-
--- bogus. to make non-exhaustive match warning go away.
-regAlloc _ (CmmProc _ _ _ _)
-        = panic "RegAllocLinear.regAlloc: no match"
-
-
--- -----------------------------------------------------------------------------
--- Linear sweep to allocate registers
-
-
--- | Do register allocation on some basic blocks.
---   But be careful to allocate a block in an SCC only if it has
---   an entry in the block map or it is the first block.
---
-linearRegAlloc
-        :: forall instr. (Instruction instr)
-        => NCGConfig
-        -> [BlockId] -- ^ entry points
-        -> BlockMap RegSet
-              -- ^ live regs on entry to each basic block
-        -> [SCC (LiveBasicBlock instr)]
-              -- ^ instructions annotated with "deaths"
-        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
-
-linearRegAlloc config entry_ids block_live sccs
- = case platformArch platform of
-      ArchX86        -> go $ (frInitFreeRegs platform :: X86.FreeRegs)
-      ArchX86_64     -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs)
-      ArchS390X      -> panic "linearRegAlloc ArchS390X"
-      ArchPPC        -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)
-      ArchARM _ _ _  -> panic "linearRegAlloc ArchARM"
-      ArchAArch64    -> go $ (frInitFreeRegs platform :: AArch64.FreeRegs)
-      ArchPPC_64 _   -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)
-      ArchAlpha      -> panic "linearRegAlloc ArchAlpha"
-      ArchMipseb     -> panic "linearRegAlloc ArchMipseb"
-      ArchMipsel     -> panic "linearRegAlloc ArchMipsel"
-      ArchRISCV64    -> panic "linearRegAlloc ArchRISCV64"
-      ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"
-      ArchWasm32     -> panic "linearRegAlloc ArchWasm32"
-      ArchUnknown    -> panic "linearRegAlloc ArchUnknown"
- where
-  go :: (FR regs, Outputable regs)
-     => regs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
-  go f = linearRegAlloc' config f entry_ids block_live sccs
-  platform = ncgPlatform config
-
--- | Constraints on the instruction instances used by the
--- linear allocator.
-type OutputableRegConstraint freeRegs instr =
-        (FR freeRegs, Outputable freeRegs, Instruction instr)
-
-linearRegAlloc'
-        :: OutputableRegConstraint freeRegs instr
-        => NCGConfig
-        -> freeRegs
-        -> [BlockId]                    -- ^ entry points
-        -> BlockMap RegSet              -- ^ live regs on entry to each basic block
-        -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
-        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
-
-linearRegAlloc' config initFreeRegs entry_ids block_live sccs
- = do   us      <- getUniqueSupplyM
-        let !(_, !stack, !stats, !blocks) =
-                runR config emptyBlockAssignment initFreeRegs emptyRegMap emptyStackMap us
-                    $ linearRA_SCCs entry_ids block_live [] sccs
-        return  (blocks, stats, getStackUse stack)
-
-
-linearRA_SCCs :: OutputableRegConstraint freeRegs instr
-              => [BlockId]
-              -> BlockMap RegSet
-              -> [NatBasicBlock instr]
-              -> [SCC (LiveBasicBlock instr)]
-              -> RegM freeRegs [NatBasicBlock instr]
-
-linearRA_SCCs _ _ blocksAcc []
-        = return $ reverse blocksAcc
-
-linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs)
- = do   blocks' <- processBlock block_live block
-        linearRA_SCCs entry_ids block_live
-                ((reverse blocks') ++ blocksAcc)
-                sccs
-
-linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs)
- = do
-        blockss' <- process entry_ids block_live blocks
-        linearRA_SCCs entry_ids block_live
-                (reverse (concat blockss') ++ blocksAcc)
-                sccs
-
-{- from John Dias's patch 2008/10/16:
-   The linear-scan allocator sometimes allocates a block
-   before allocating one of its predecessors, which could lead to
-   inconsistent allocations. Make it so a block is only allocated
-   if a predecessor has set the "incoming" assignments for the block, or
-   if it's the procedure's entry block.
-
-   BL 2009/02: Careful. If the assignment for a block doesn't get set for
-   some reason then this function will loop. We should probably do some
-   more sanity checking to guard against this eventuality.
--}
-
-process :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)
-        => [BlockId]
-        -> BlockMap RegSet
-        -> [GenBasicBlock (LiveInstr instr)]
-        -> RegM freeRegs [[NatBasicBlock instr]]
-process entry_ids block_live =
-    \blocks -> go blocks [] (return []) False
-  where
-    go :: [GenBasicBlock (LiveInstr instr)]
-       -> [GenBasicBlock (LiveInstr instr)]
-       -> [[NatBasicBlock instr]]
-       -> Bool
-       -> RegM freeRegs [[NatBasicBlock instr]]
-    go [] []         accum _madeProgress
-      = return $ reverse accum
-
-    go [] next_round accum madeProgress
-      | not madeProgress
-          {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.
-             pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."
-                (  text "Unreachable blocks:"
-                $$ vcat (map ppr next_round)) -}
-      = return $ reverse accum
-
-      | otherwise
-      = go next_round [] accum False
-
-    go (b@(BasicBlock id _) : blocks) next_round accum madeProgress
-      = do
-          block_assig <- getBlockAssigR
-          if isJust (lookupBlockAssignment id block_assig) || id `elem` entry_ids
-            then do b' <- processBlock block_live b
-                    go blocks next_round (b' : accum) True
-
-            else do go blocks (b : next_round) accum madeProgress
-
-
--- | Do register allocation on this basic block
---
-processBlock
-        :: OutputableRegConstraint freeRegs instr
-        => BlockMap RegSet              -- ^ live regs on entry to each basic block
-        -> LiveBasicBlock instr         -- ^ block to do register allocation on
-        -> RegM freeRegs [NatBasicBlock instr]   -- ^ block with registers allocated
-
-processBlock block_live (BasicBlock id instrs)
- = do   -- pprTraceM "processBlock" $ text "" $$ ppr (BasicBlock id instrs)
-        initBlock id block_live
-
-        (instrs', fixups)
-                <- linearRA block_live id instrs
-        -- pprTraceM "blockResult" $ ppr (instrs', fixups)
-        return  $ BasicBlock id instrs' : fixups
-
-
--- | Load the freeregs and current reg assignment into the RegM state
---      for the basic block with this BlockId.
-initBlock :: FR freeRegs
-          => BlockId -> BlockMap RegSet -> RegM freeRegs ()
-initBlock id block_live
- = do   platform    <- getPlatform
-        block_assig <- getBlockAssigR
-        case lookupBlockAssignment id block_assig of
-                -- no prior info about this block: we must consider
-                -- any fixed regs to be allocated, but we can ignore
-                -- virtual regs (presumably this is part of a loop,
-                -- and we'll iterate again).  The assignment begins
-                -- empty.
-                Nothing
-                 -> do  -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
-                        case mapLookup id block_live of
-                          Nothing ->
-                            setFreeRegsR    (frInitFreeRegs platform)
-                          Just live ->
-                            setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform)
-                                                  [ r | RegReal r <- nonDetEltsUniqSet live ]
-                            -- See Note [Unique Determinism and code generation]
-                        setAssigR       emptyRegMap
-
-                -- load info about register assignments leading into this block.
-                Just (freeregs, assig)
-                 -> do  setFreeRegsR    freeregs
-                        setAssigR       assig
-
-
--- | Do allocation for a sequence of instructions.
-linearRA
-        :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)
-        => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.
-        -> BlockId                              -- ^ id of the current block, for debugging.
-        -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.
-        -> RegM freeRegs
-                ( [instr]                       --   instructions after register allocation
-                , [NatBasicBlock instr])        --   fresh blocks of fixup code.
-linearRA block_live block_id = go [] []
-  where
-    go :: [instr]                              -- accumulator for instructions already processed.
-       -> [NatBasicBlock instr]                -- accumulator for blocks of fixup code.
-       -> [LiveInstr instr]                    -- liveness annotated instructions in this block.
-       -> RegM freeRegs
-               ( [instr]                       --   instructions after register allocation
-               , [NatBasicBlock instr] )       --   fresh blocks of fixup code.
-    go !accInstr !accFixups [] = do
-        return ( reverse accInstr               -- instrs need to be returned in the correct order.
-               , accFixups )                    -- it doesn't matter what order the fixup blocks are returned in.
-
-    go accInstr accFixups (instr:instrs) = do
-        (accInstr', new_fixups) <- raInsn block_live accInstr block_id instr
-        go accInstr' (new_fixups ++ accFixups) instrs
-
--- | Do allocation for a single instruction.
-raInsn
-        :: OutputableRegConstraint freeRegs instr
-        => BlockMap RegSet                      -- ^ map of what vregs are love on entry to each block.
-        -> [instr]                              -- ^ accumulator for instructions already processed.
-        -> BlockId                              -- ^ the id of the current block, for debugging
-        -> LiveInstr instr                      -- ^ the instr to have its regs allocated, with liveness info.
-        -> RegM freeRegs
-                ( [instr]                       -- new instructions
-                , [NatBasicBlock instr])        -- extra fixup blocks
-
-raInsn _     new_instrs _ (LiveInstr ii Nothing)
-        | Just n        <- takeDeltaInstr ii
-        = do    setDeltaR n
-                return (new_instrs, [])
-
-raInsn _     new_instrs _ (LiveInstr ii@(Instr i) Nothing)
-        | isMetaInstr ii
-        = return (i : new_instrs, [])
-
-
-raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
- = do
-    assig    <- getAssigR :: RegM freeRegs (UniqFM Reg Loc)
-
-    -- If we have a reg->reg move between virtual registers, where the
-    -- src register is not live after this instruction, and the dst
-    -- register does not already have an assignment,
-    -- and the source register is assigned to a register, not to a spill slot,
-    -- then we can eliminate the instruction.
-    -- (we can't eliminate it if the source register is on the stack, because
-    --  we do not want to use one spill slot for different virtual registers)
-    case takeRegRegMoveInstr instr of
-        Just (src,dst)  | src `elementOfUniqSet` (liveDieRead live),
-                          isVirtualReg dst,
-                          not (dst `elemUFM` assig),
-                          isRealReg src || isInReg src assig -> do
-           case src of
-              (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))
-                -- if src is a fixed reg, then we just map dest to this
-                -- reg in the assignment.  src must be an allocatable reg,
-                -- otherwise it wouldn't be in r_dying.
-              _virt -> case lookupUFM assig src of
-                         Nothing -> panic "raInsn"
-                         Just loc ->
-                           setAssigR (addToUFM (delFromUFM assig src) dst loc)
-
-           -- we have eliminated this instruction
-          {-
-          freeregs <- getFreeRegsR
-          assig <- getAssigR
-          pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
-                        $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
-          -}
-           return (new_instrs, [])
-
-        _ -> genRaInsn block_live new_instrs id instr
-                        (nonDetEltsUniqSet $ liveDieRead live)
-                        (nonDetEltsUniqSet $ liveDieWrite live)
-                        -- See Note [Unique Determinism and code generation]
-
-raInsn _ _ _ instr
-        = do
-            platform <- getPlatform
-            let instr' = fmap (pprInstr platform) instr
-            pprPanic "raInsn" (text "no match for:" <> ppr instr')
-
--- ToDo: what can we do about
---
---     R1 = x
---     jump I64[x] // [R1]
---
--- where x is mapped to the same reg as R1.  We want to coalesce x and
--- R1, but the register allocator doesn't know whether x will be
--- assigned to again later, in which case x and R1 should be in
--- different registers.  Right now we assume the worst, and the
--- assignment to R1 will clobber x, so we'll spill x into another reg,
--- generating another reg->reg move.
-
-
-isInReg :: Reg -> RegMap Loc -> Bool
-isInReg src assig | Just (InReg _) <- lookupUFM assig src = True
-                  | otherwise = False
-
-
-genRaInsn :: forall freeRegs instr.
-             (OutputableRegConstraint freeRegs instr)
-          => BlockMap RegSet
-          -> [instr]
-          -> BlockId
-          -> instr
-          -> [Reg]
-          -> [Reg]
-          -> RegM freeRegs ([instr], [NatBasicBlock instr])
-
-genRaInsn block_live new_instrs block_id instr r_dying w_dying = do
--- pprTraceM "genRaInsn" $ ppr (block_id, instr)
-  platform <- getPlatform
-  case regUsageOfInstr platform instr of { RU read written ->
-    do
-    let real_written    = [ rr  | (RegReal     rr) <- written ] :: [RealReg]
-    let virt_written    = [ vr  | (RegVirtual  vr) <- written ]
-
-    -- we don't need to do anything with real registers that are
-    -- only read by this instr.  (the list is typically ~2 elements,
-    -- so using nub isn't a problem).
-    let virt_read       = nub [ vr      | (RegVirtual vr) <- read ] :: [VirtualReg]
-
---     do
---         let real_read       = nub [ rr      | (RegReal rr) <- read]
---         freeregs <- getFreeRegsR
---         assig    <- getAssigR
-
---         pprTraceM "genRaInsn"
---                 (          text "block        = " <+> ppr block_id
---                         $$ text "instruction  = " <+> ppr instr
---                         $$ text "r_dying      = " <+> ppr r_dying
---                         $$ text "w_dying      = " <+> ppr w_dying
---                         $$ text "read         = " <+> ppr real_read    <+> ppr virt_read
---                         $$ text "written      = " <+> ppr real_written <+> ppr virt_written
---                         $$ text "freeregs     = " <+> ppr freeregs
---                         $$ text "assign       = " <+> ppr assig)
-
-    -- (a), (b) allocate real regs for all regs read by this instruction.
-    (r_spills, r_allocd) <-
-        allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
-
-    -- (c) save any temporaries which will be clobbered by this instruction
-    clobber_saves <- saveClobberedTemps real_written r_dying
-
-    -- (d) Update block map for new destinations
-    -- NB. do this before removing dead regs from the assignment, because
-    -- these dead regs might in fact be live in the jump targets (they're
-    -- only dead in the code that follows in the current basic block).
-    (fixup_blocks, adjusted_instr)
-        <- joinToTargets block_live block_id instr
-
---     when (not $ null fixup_blocks) $ pprTraceM "genRA:FixBlocks" $ ppr fixup_blocks
-
-    -- Debugging - show places where the reg alloc inserted
-    -- assignment fixup blocks.
-    -- when (not $ null fixup_blocks) $
-    --    pprTrace "fixup_blocks" (ppr fixup_blocks) (return ())
-
-    -- (e) Delete all register assignments for temps which are read
-    --     (only) and die here.  Update the free register list.
-    releaseRegs r_dying
-
-    -- (f) Mark regs which are clobbered as unallocatable
-    clobberRegs real_written
-
-    -- (g) Allocate registers for temporaries *written* (only)
-    (w_spills, w_allocd) <-
-        allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
-
-    -- (h) Release registers for temps which are written here and not
-    -- used again.
-    releaseRegs w_dying
-
-    let
-        -- (i) Patch the instruction
-        patch_map :: UniqFM Reg Reg
-        patch_map
-                = toRegMap $ -- Cast key from VirtualReg to Reg
-                             -- See Note [UniqFM and the register allocator]
-                  listToUFM
-                        [ (t, RegReal r)
-                                | (t, r) <- zip virt_read    r_allocd
-                                         ++ zip virt_written w_allocd ]
-
-        patched_instr :: instr
-        patched_instr
-                = patchRegsOfInstr adjusted_instr patchLookup
-
-        patchLookup :: Reg -> Reg
-        patchLookup x
-                = case lookupUFM patch_map x of
-                        Nothing -> x
-                        Just y  -> y
-
-    -- (j) free up stack slots for dead spilled regs
-    -- TODO (can't be bothered right now)
-
-    -- erase reg->reg moves where the source and destination are the same.
-    --  If the src temp didn't die in this instr but happened to be allocated
-    --  to the same real reg as the destination, then we can erase the move anyway.
-    let squashed_instr  = case takeRegRegMoveInstr patched_instr of
-                                Just (src, dst)
-                                 | src == dst   -> []
-                                _               -> [patched_instr]
-
-    -- On the use of @reverse@ below.
-    -- Since we can have spills and reloads produce multiple instructions
-    -- we need to ensure they are emitted in the correct order.  We used to only
-    -- emit single instructions in mkSpill/mkReload/mkRegRegMove.
-    -- As such order of spills and reloads didn't matter.  However,  with
-    -- multiple instructions potentially issued by those functions we need to be
-    -- careful to not break execution order. Reversing the spills (clobber will
-    -- also spill), will ensure they are emitted in the right order.
-    --
-    -- See also Ticket 19910 for changing the return type from [] to OrdList.
-
-    -- For debugging, uncomment the follow line and the mkComment lines.
-    -- u <- getUniqueR
-    let code = concat [ --  mkComment (text "<genRaInsn(" <> ppr u <> text ")>")
-                        -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):squashed>")]
-                        squashed_instr
-                        -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):w_spills>")
-                      , reverse w_spills
-                        -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):r_spills>")
-                      , reverse r_spills
-                        -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):clobber_saves>")
-                      , reverse clobber_saves
-                        -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):new_instrs>")
-                      , new_instrs
-                        -- ,mkComment (text "</genRaInsn(" <> ppr u <> text ")>")
-                      ]
-
---    pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do
---    pprTrace "patched-fixup" ((ppr fixup_blocks)) $ do
-
-    return (code, fixup_blocks)
-
-  }
-
--- -----------------------------------------------------------------------------
--- releaseRegs
-
-releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()
-releaseRegs regs = do
-  platform <- getPlatform
-  assig <- getAssigR
-  free <- getFreeRegsR
-
-  let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return ()
-      loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs
-      loop assig !free (r:rs) =
-         case lookupUFM assig r of
-         Just (InBoth real _) -> loop (delFromUFM assig r)
-                                      (frReleaseReg platform real free) rs
-         Just (InReg real)    -> loop (delFromUFM assig r)
-                                      (frReleaseReg platform real free) rs
-         _                    -> loop (delFromUFM assig r) free rs
-  loop assig free regs
-
-
--- -----------------------------------------------------------------------------
--- Clobber real registers
-
--- For each temp in a register that is going to be clobbered:
---      - if the temp dies after this instruction, do nothing
---      - otherwise, put it somewhere safe (another reg if possible,
---              otherwise spill and record InBoth in the assignment).
---      - for allocateRegs on the temps *read*,
---      - clobbered regs are allocatable.
---
---      for allocateRegs on the temps *written*,
---        - clobbered regs are not allocatable.
---
-
-saveClobberedTemps
-        :: forall instr freeRegs.
-           (Instruction instr, FR freeRegs)
-        => [RealReg]            -- real registers clobbered by this instruction
-        -> [Reg]                -- registers which are no longer live after this insn
-        -> RegM freeRegs [instr]         -- return: instructions to spill any temps that will
-                                -- be clobbered.
-
-saveClobberedTemps [] _
-        = return []
-
-saveClobberedTemps clobbered dying
- = do
-        assig   <- getAssigR :: RegM freeRegs (UniqFM Reg Loc)
-        (assig',instrs) <- nonDetStrictFoldUFM_DirectlyM maybe_spill (assig,[]) assig
-        setAssigR assig'
-        return $ -- mkComment (text "<saveClobberedTemps>") ++
-                 instrs
---              ++ mkComment (text "</saveClobberedTemps>")
-   where
-     -- Unique represents the VirtualReg
-     -- Here we separate the cases which we do want to spill from these we don't.
-     maybe_spill :: Unique -> (RegMap Loc,[instr]) -> (Loc) -> RegM freeRegs (RegMap Loc,[instr])
-     maybe_spill !temp !(assig,instrs) !loc =
-        case loc of
-                -- This is non-deterministic but we do not
-                -- currently support deterministic code-generation.
-                -- See Note [Unique Determinism and code generation]
-                InReg reg
-                    | any (realRegsAlias reg) clobbered
-                    , temp `notElem` map getUnique dying
-                    -> clobber temp (assig,instrs) (reg)
-                _ -> return (assig,instrs)
-
-
-     -- See Note [UniqFM and the register allocator]
-     clobber :: Unique -> (RegMap Loc,[instr]) -> (RealReg) -> RegM freeRegs (RegMap Loc,[instr])
-     clobber temp (assig,instrs) (reg)
-       = do platform <- getPlatform
-
-            freeRegs <- getFreeRegsR
-            let regclass = targetClassOfRealReg platform reg
-                freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs
-
-            case filter (`notElem` clobbered) freeRegs_thisClass of
-
-              -- (1) we have a free reg of the right class that isn't
-              -- clobbered by this instruction; use it to save the
-              -- clobbered value.
-              (my_reg : _) -> do
-                  setFreeRegsR (frAllocateReg platform my_reg freeRegs)
-
-                  let new_assign = addToUFM_Directly assig temp (InReg my_reg)
-                  let instr = mkRegRegMoveInstr platform
-                                  (RegReal reg) (RegReal my_reg)
-
-                  return (new_assign,(instr : instrs))
-
-              -- (2) no free registers: spill the value
-              [] -> do
-                  (spill, slot)   <- spillR (RegReal reg) temp
-
-                  -- record why this reg was spilled for profiling
-                  recordSpill (SpillClobber temp)
-
-                  let new_assign  = addToUFM_Directly assig temp (InBoth reg slot)
-
-                  return (new_assign, (spill ++ instrs))
-
-
-
-
--- | Mark all these real regs as allocated,
---      and kick out their vreg assignments.
---
-clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()
-clobberRegs []
-        = return ()
-
-clobberRegs clobbered
- = do   platform <- getPlatform
-        freeregs <- getFreeRegsR
-
-        let gpRegs  = frGetFreeRegs platform RcInteger freeregs :: [RealReg]
-            fltRegs = frGetFreeRegs platform RcFloat   freeregs :: [RealReg]
-            dblRegs = frGetFreeRegs platform RcDouble  freeregs :: [RealReg]
-
-        let extra_clobbered = [ r | r <- clobbered
-                                  , r `elem` (gpRegs ++ fltRegs ++ dblRegs) ]
-
-        setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs extra_clobbered
-
-        -- setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered
-
-        assig           <- getAssigR
-        setAssigR $! clobber assig (nonDetUFMToList assig)
-          -- This is non-deterministic but we do not
-          -- currently support deterministic code-generation.
-          -- See Note [Unique Determinism and code generation]
-
-   where
-        -- if the temp was InReg and clobbered, then we will have
-        -- saved it in saveClobberedTemps above.  So the only case
-        -- we have to worry about here is InBoth.  Note that this
-        -- also catches temps which were loaded up during allocation
-        -- of read registers, not just those saved in saveClobberedTemps.
-
-        clobber :: RegMap Loc -> [(Unique,Loc)] -> RegMap Loc
-        clobber assig []
-                = assig
-
-        clobber assig ((temp, InBoth reg slot) : rest)
-                | any (realRegsAlias reg) clobbered
-                = clobber (addToUFM_Directly assig temp (InMem slot)) rest
-
-        clobber assig (_:rest)
-                = clobber assig rest
-
--- -----------------------------------------------------------------------------
--- allocateRegsAndSpill
-
--- Why are we performing a spill?
-data SpillLoc = ReadMem StackSlot  -- reading from register only in memory
-              | WriteNew           -- writing to a new variable
-              | WriteMem           -- writing to register only in memory
--- Note that ReadNew is not valid, since you don't want to be reading
--- from an uninitialized register.  We also don't need the location of
--- the register in memory, since that will be invalidated by the write.
--- Technically, we could coalesce WriteNew and WriteMem into a single
--- entry as well. -- EZY
-
--- This function does several things:
---   For each temporary referred to by this instruction,
---   we allocate a real register (spilling another temporary if necessary).
---   We load the temporary up from memory if necessary.
---   We also update the register assignment in the process, and
---   the list of free registers and free stack slots.
-
-allocateRegsAndSpill
-        :: forall freeRegs instr. (FR freeRegs, Instruction instr)
-        => Bool                 -- True <=> reading (load up spilled regs)
-        -> [VirtualReg]         -- don't push these out
-        -> [instr]              -- spill insns
-        -> [RealReg]            -- real registers allocated (accum.)
-        -> [VirtualReg]         -- temps to allocate
-        -> RegM freeRegs ( [instr] , [RealReg])
-
-allocateRegsAndSpill _       _    spills alloc []
-        = return (spills, reverse alloc)
-
-allocateRegsAndSpill reading keep spills alloc (r:rs)
- = do   assig <- toVRegMap <$> getAssigR
-        -- pprTraceM "allocateRegsAndSpill:assig" (ppr (r:rs) $$ ppr assig)
-        -- See Note [UniqFM and the register allocator]
-        let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig
-        case lookupUFM assig r of
-                -- case (1a): already in a register
-                Just (InReg my_reg) ->
-                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
-
-                -- case (1b): already in a register (and memory)
-                -- NB1. if we're writing this register, update its assignment to be
-                -- InReg, because the memory value is no longer valid.
-                -- NB2. This is why we must process written registers here, even if they
-                -- are also read by the same instruction.
-                Just (InBoth my_reg _)
-                 -> do  when (not reading) (setAssigR $ toRegMap (addToUFM assig r (InReg my_reg)))
-                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
-
-                -- Not already in a register, so we need to find a free one...
-                Just (InMem slot) | reading   -> doSpill (ReadMem slot)
-                                  | otherwise -> doSpill WriteMem
-                Nothing | reading   ->
-                   pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)
-                   -- NOTE: if the input to the NCG contains some
-                   -- unreachable blocks with junk code, this panic
-                   -- might be triggered.  Make sure you only feed
-                   -- sensible code into the NCG.  In GHC.Cmm.Pipeline we
-                   -- call removeUnreachableBlocks at the end for this
-                   -- reason.
-
-                        | otherwise -> doSpill WriteNew
-
--- | Given a virtual reg find a preferred real register.
--- The preferred register is simply the first one the variable
--- was assigned to (if any). This way when we allocate for a loop
--- variables are likely to end up in the same registers at the
--- end and start of the loop, avoiding redundant reg-reg moves.
--- Note: I tried returning a list of past assignments, but that
--- turned out to barely matter.
-findPrefRealReg :: VirtualReg -> RegM freeRegs (Maybe RealReg)
-findPrefRealReg vreg = do
-  bassig <- getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
-  return $ lookupFirstUsed vreg bassig
-
--- reading is redundant with reason, but we keep it around because it's
--- convenient and it maintains the recursive structure of the allocator. -- EZY
-allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr)
-                        => Bool
-                        -> [VirtualReg]
-                        -> [instr]
-                        -> [RealReg]
-                        -> VirtualReg
-                        -> [VirtualReg]
-                        -> UniqFM VirtualReg Loc
-                        -> SpillLoc
-                        -> RegM freeRegs ([instr], [RealReg])
-allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
- = do   platform <- getPlatform
-        freeRegs <- getFreeRegsR
-        let freeRegs_thisClass  = frGetFreeRegs platform (classOfVirtualReg r) freeRegs :: [RealReg]
-
-        -- Can we put the variable into a register it already was?
-        pref_reg <- findPrefRealReg r
-
-        case freeRegs_thisClass of
-         -- case (2): we have a free register
-         (first_free : _) ->
-           do   let !final_reg
-                        | Just reg <- pref_reg
-                        , reg `elem` freeRegs_thisClass
-                        = reg
-                        | otherwise
-                        = first_free
-                spills'   <- loadTemp r spill_loc final_reg spills
-
-                setAssigR $ toRegMap
-                          $ (addToUFM assig r $! newLocation spill_loc final_reg)
-                setFreeRegsR $  frAllocateReg platform final_reg freeRegs
-
-                allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs
-
-
-          -- case (3): we need to push something out to free up a register
-         [] ->
-           do   let inRegOrBoth (InReg _) = True
-                    inRegOrBoth (InBoth _ _) = True
-                    inRegOrBoth _ = False
-                let candidates' :: UniqFM VirtualReg Loc
-                    candidates' =
-                      flip delListFromUFM keep $
-                      filterUFM inRegOrBoth $
-                      assig
-                      -- This is non-deterministic but we do not
-                      -- currently support deterministic code-generation.
-                      -- See Note [Unique Determinism and code generation]
-                let candidates = nonDetUFMToList candidates'
-
-                -- the vregs we could kick out that are already in a slot
-                let candidates_inBoth :: [(Unique, RealReg, StackSlot)]
-                    candidates_inBoth
-                        = [ (temp, reg, mem)
-                          | (temp, InBoth reg mem) <- candidates
-                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]
-
-                -- the vregs we could kick out that are only in a reg
-                --      this would require writing the reg to a new slot before using it.
-                let candidates_inReg
-                        = [ (temp, reg)
-                          | (temp, InReg reg) <- candidates
-                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]
-
-                let result
-
-                        -- we have a temporary that is in both register and mem,
-                        -- just free up its register for use.
-                        | (temp, my_reg, slot) : _      <- candidates_inBoth
-                        = do    spills' <- loadTemp r spill_loc my_reg spills
-                                let assig1  = addToUFM_Directly assig temp (InMem slot)
-                                let assig2  = addToUFM assig1 r $! newLocation spill_loc my_reg
-
-                                setAssigR $ toRegMap assig2
-                                allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
-
-                        -- otherwise, we need to spill a temporary that currently
-                        -- resides in a register.
-                        | (temp_to_push_out, (my_reg :: RealReg)) : _
-                                        <- candidates_inReg
-                        = do
-                                (spill_store, slot) <- spillR (RegReal my_reg) temp_to_push_out
-
-                                -- record that this temp was spilled
-                                recordSpill (SpillAlloc temp_to_push_out)
-
-                                -- update the register assignment
-                                let assig1  = addToUFM_Directly assig temp_to_push_out   (InMem slot)
-                                let assig2  = addToUFM assig1 r                 $! newLocation spill_loc my_reg
-                                setAssigR $ toRegMap assig2
-
-                                -- if need be, load up a spilled temp into the reg we've just freed up.
-                                spills' <- loadTemp r spill_loc my_reg spills
-
-                                allocateRegsAndSpill reading keep
-                                        (spill_store ++ spills')
-                                        (my_reg:alloc) rs
-
-
-                        -- there wasn't anything to spill, so we're screwed.
-                        | otherwise
-                        = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
-                        $ vcat
-                                [ text "allocating vreg:  " <> text (show r)
-                                , text "assignment:       " <> ppr assig
-                                , text "freeRegs:         " <> text (show freeRegs)
-                                , text "initFreeRegs:     " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ]
-
-                result
-
-
--- | Calculate a new location after a register has been loaded.
-newLocation :: SpillLoc -> RealReg -> Loc
--- if the tmp was read from a slot, then now its in a reg as well
-newLocation (ReadMem slot) my_reg = InBoth my_reg slot
--- writes will always result in only the register being available
-newLocation _ my_reg = InReg my_reg
-
--- | Load up a spilled temporary if we need to (read from memory).
-loadTemp
-        :: (Instruction instr)
-        => VirtualReg   -- the temp being loaded
-        -> SpillLoc     -- the current location of this temp
-        -> RealReg      -- the hreg to load the temp into
-        -> [instr]
-        -> RegM freeRegs [instr]
-
-loadTemp vreg (ReadMem slot) hreg spills
- = do
-        insn <- loadR (RegReal hreg) slot
-        recordSpill (SpillLoad $ getUnique vreg)
-        return  $  {- mkComment (text "spill load") : -} insn ++ spills
-
-loadTemp _ _ _ spills =
-   return spills
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs b/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs
+++ /dev/null
@@ -1,135 +0,0 @@
-module GHC.CmmToAsm.Reg.Linear.AArch64 where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.AArch64.Regs
-import GHC.Platform.Reg.Class
-import GHC.Platform.Reg
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Platform
-
-import Data.Word
-
-import GHC.Stack
--- AArch64 has 32 64bit general purpose register r0..r30, and zr/sp
--- AArch64 has 32 128bit floating point registers v0..v31 as part of the NEON
--- extension in Armv8-A.
---
--- Armv8-A is a fundamental change to the Arm architecture. It supports the
--- 64-bit Execution state called “AArch64”, and a new 64-bit instruction set
--- “A64”. To provide compatibility with the Armv7-A (32-bit architecture)
--- instruction set, a 32-bit variant of Armv8-A “AArch32” is provided. Most of
--- existing Armv7-A code can be run in the AArch32 execution state of Armv8-A.
---
--- these can be addresses as q/d/s/h/b 0..31, or v.f<size>[idx]
--- where size is 64, 32, 16, 8, ... and the index i allows us
--- to access the given part.
---
--- History of Arm Adv SIMD
--- .---------------------------------------------------------------------------.
--- | Armv6                  | Armv7-A                | Armv8-A AArch64         |
--- | SIMD extension         | NEON                   | NEON                    |
--- |===========================================================================|
--- | - Operates on 32-bit   | - Separate reg. bank,  | - Separate reg. bank,   |
--- |   GP ARM registers     |    32x64-bit NEON regs |   32x128-bit NEON regs  |
--- | - 8-bit/16-bit integer | - 8/16/32/64-bit int   | - 8/16/32/64-bit int    |
--- |                        | - Single precision fp  | - Single precision fp   |
--- |                        |                        | - Double precision fp   |
--- |                        |                        | - Single/Double fp are  |
--- |                        |                        |   IEEE compliant        |
--- | - 2x16-bit/4x8-bit ops | - Up to 16x8-bit ops   | - Up to 16x8-bit ops    |
--- |   per instruction      |   per instruction      |   per instruction       |
--- '---------------------------------------------------------------------------'
-
-data FreeRegs = FreeRegs !Word32 !Word32
-
-instance Show FreeRegs where
-  show (FreeRegs g f) = "FreeRegs: " ++ showBits g ++ "; " ++ showBits f
-
-instance Outputable FreeRegs where
-    ppr (FreeRegs g f) = text "   " <+> foldr (\i x -> pad_int i    <+> x) (text "") [0..31]
-                      $$ text "GPR" <+> foldr (\i x -> show_bit g i <+> x) (text "") [0..31]
-                      $$ text "FPR" <+> foldr (\i x -> show_bit f i <+> x) (text "") [0..31]
-      where pad_int i | i < 10 = char ' ' <> int i
-            pad_int i = int i
-            -- remember bit = 1 means it's available.
-            show_bit bits bit | testBit bits bit = text "  "
-            show_bit _    _ = text " x"
-
-noFreeRegs :: FreeRegs
-noFreeRegs = FreeRegs 0 0
-
-showBits :: Word32 -> String
-showBits w = map (\i -> if testBit w i then '1' else '0') [0..31]
-
--- FR instance implementation (See Linear.FreeRegs)
-allocateReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs
-allocateReg (RealRegSingle r) (FreeRegs g f)
-    | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32))
-    | r < 32 && testBit g r = FreeRegs (clearBit g r) f
-    | r > 31 = panic $ "Linear.AArch64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f
-    | otherwise = pprPanic "Linear.AArch64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g)
-
--- we start from 28 downwards... the logic is similar to the ppc logic.
--- 31 is Stack Pointer
--- 30 is Link Register
--- 29 is Stack Frame (by convention)
--- 19-28 are callee save
--- the lower ones are all caller save
-
--- For this reason someone decided to give aarch64 only 6 regs for
--- STG:
--- 19: Base
--- 20: Sp
--- 21: Hp
--- 22-27: R1-R6
--- 28: SpLim
-
--- For LLVM code gen interop:
--- See https://lists.llvm.org/pipermail/llvm-commits/Week-of-Mon-20150119/253722.html
--- and the current ghccc implementation here:
--- https://github.com/llvm/llvm-project/blob/161ae1f39816edf667aaa190bce702a86879c7bd/llvm/lib/Target/AArch64/AArch64CallingConvention.td#L324-L363
--- and https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/generated-code
--- for the STG discussion.
-{- For reference the ghcc from the link above:
-let Entry = 1 in
-def CC_AArch64_GHC : CallingConv<[
-  CCIfType<[iPTR], CCBitConvertToType<i64>>,
-
-  // Handle all vector types as either f64 or v2f64.
-  CCIfType<[v1i64, v2i32, v4i16, v8i8, v2f32], CCBitConvertToType<f64>>,
-  CCIfType<[v2i64, v4i32, v8i16, v16i8, v4f32, f128], CCBitConvertToType<v2f64>>,
-
-  CCIfType<[v2f64], CCAssignToReg<[Q4, Q5]>>,
-  CCIfType<[f32], CCAssignToReg<[S8, S9, S10, S11]>>,
-  CCIfType<[f64], CCAssignToReg<[D12, D13, D14, D15]>>,
-
-  // Promote i8/i16/i32 arguments to i64.
-  CCIfType<[i8, i16, i32], CCPromoteToType<i64>>,
-
-  // Pass in STG registers: Base, Sp, Hp, R1, R2, R3, R4, R5, R6, SpLim
-  CCIfType<[i64], CCAssignToReg<[X19, X20, X21, X22, X23, X24, X25, X26, X27, X28]>>
-]>;
--}
-
-getFreeRegs :: RegClass -> FreeRegs -> [RealReg]
-getFreeRegs cls (FreeRegs g f)
-  | RcFloat   <- cls = [] -- For now we only support double and integer registers, floats will need to be promoted.
-  | RcDouble  <- cls = go 32 f 31
-  | RcInteger <- cls = go  0 g 18
-    where
-        go _   _ i | i < 0 = []
-        go off x i | testBit x i = RealRegSingle (off + i) : (go off x $! i - 1)
-                   | otherwise   = go off x $! i - 1
-
-initFreeRegs :: Platform -> FreeRegs
-initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)
-
-releaseReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs
-releaseReg (RealRegSingle r) (FreeRegs g f)
-  | r > 31 && testBit f (r - 32) = pprPanic "Linear.AArch64.releaseReg" (text  "can't release non-allocated reg v" <> int (r - 32))
-  | r < 32 && testBit g r = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg x" <> int r)
-  | r > 31 = FreeRegs g (setBit f (r - 32))
-  | otherwise = FreeRegs (setBit g r) f
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/Base.hs
+++ /dev/null
@@ -1,188 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-
--- | Put common type definitions here to break recursive module dependencies.
-
-module GHC.CmmToAsm.Reg.Linear.Base (
-        BlockAssignment,
-        lookupBlockAssignment,
-        lookupFirstUsed,
-        emptyBlockAssignment,
-        updateBlockAssignment,
-
-        Loc(..),
-        regsOfLoc,
-
-        -- for stats
-        SpillReason(..),
-        RegAllocStats(..),
-
-        -- the allocator monad
-        RA_State(..),
-)
-
-where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.Reg.Linear.StackMap
-import GHC.CmmToAsm.Reg.Liveness
-import GHC.CmmToAsm.Config
-import GHC.Platform.Reg
-
-import GHC.Utils.Outputable
-import GHC.Types.Unique
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Supply
-import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Collections
-import GHC.CmmToAsm.Reg.Utils
-
-data ReadingOrWriting = Reading | Writing deriving (Eq,Ord)
-
--- | Used to store the register assignment on entry to a basic block.
---      We use this to handle join points, where multiple branch instructions
---      target a particular label. We have to insert fixup code to make
---      the register assignments from the different sources match up.
---
-data BlockAssignment freeRegs
-        = BlockAssignment { blockMap :: !(BlockMap (freeRegs, RegMap Loc))
-                          , firstUsed :: !(UniqFM VirtualReg RealReg) }
-
--- | Find the register mapping for a specific BlockId.
-lookupBlockAssignment :: BlockId -> BlockAssignment freeRegs -> Maybe (freeRegs, RegMap Loc)
-lookupBlockAssignment bid ba = mapLookup bid (blockMap ba)
-
--- | Lookup which register a virtual register was first assigned to.
-lookupFirstUsed :: VirtualReg -> BlockAssignment freeRegs -> Maybe RealReg
-lookupFirstUsed vr ba = lookupUFM (firstUsed ba) vr
-
--- | An initial empty 'BlockAssignment'
-emptyBlockAssignment :: BlockAssignment freeRegs
-emptyBlockAssignment = BlockAssignment mapEmpty mempty
-
--- | Add new register mappings for a specific block.
-updateBlockAssignment :: BlockId
-  -> (freeRegs, RegMap Loc)
-  -> BlockAssignment freeRegs
-  -> BlockAssignment freeRegs
-updateBlockAssignment dest (freeRegs, regMap) (BlockAssignment {..}) =
-  BlockAssignment (mapInsert dest (freeRegs, regMap) blockMap)
-                  (mergeUFM combWithExisting id (mapMaybeUFM fromLoc) (firstUsed) (toVRegMap regMap))
-  where
-    -- The blocks are processed in dependency order, so if there's already an
-    -- entry in the map then keep that assignment rather than writing the new
-    -- assignment.
-    combWithExisting :: RealReg -> Loc -> Maybe RealReg
-    combWithExisting old_reg _ = Just $ old_reg
-
-    fromLoc :: Loc -> Maybe RealReg
-    fromLoc (InReg rr) = Just rr
-    fromLoc (InBoth rr _) = Just rr
-    fromLoc _ = Nothing
-
-
--- | Where a vreg is currently stored
---      A temporary can be marked as living in both a register and memory
---      (InBoth), for example if it was recently loaded from a spill location.
---      This makes it cheap to spill (no save instruction required), but we
---      have to be careful to turn this into InReg if the value in the
---      register is changed.
-
---      This is also useful when a temporary is about to be clobbered.  We
---      save it in a spill location, but mark it as InBoth because the current
---      instruction might still want to read it.
---
-data Loc
-        -- | vreg is in a register
-        = InReg   !RealReg
-
-        -- | vreg is held in a stack slot
-        | InMem   {-# UNPACK #-}  !StackSlot
-
-
-        -- | vreg is held in both a register and a stack slot
-        | InBoth   !RealReg
-                   {-# UNPACK #-} !StackSlot
-        deriving (Eq, Show, Ord)
-
-instance Outputable Loc where
-        ppr l = text (show l)
-
-
--- | Get the reg numbers stored in this Loc.
-regsOfLoc :: Loc -> [RealReg]
-regsOfLoc (InReg r)    = [r]
-regsOfLoc (InBoth r _) = [r]
-regsOfLoc (InMem _)    = []
-
-
--- | Reasons why instructions might be inserted by the spiller.
---      Used when generating stats for -ddrop-asm-stats.
---
-data SpillReason
-        -- | vreg was spilled to a slot so we could use its
-        --      current hreg for another vreg
-        = SpillAlloc    !Unique
-
-        -- | vreg was moved because its hreg was clobbered
-        | SpillClobber  !Unique
-
-        -- | vreg was loaded from a spill slot
-        | SpillLoad     !Unique
-
-        -- | reg-reg move inserted during join to targets
-        | SpillJoinRR   !Unique
-
-        -- | reg-mem move inserted during join to targets
-        | SpillJoinRM   !Unique
-
-
--- | Used to carry interesting stats out of the register allocator.
-data RegAllocStats
-        = RegAllocStats
-        { ra_spillInstrs        :: UniqFM Unique [Int] -- Keys are the uniques of regs
-                                                       -- and taken from SpillReason
-                                                       -- See Note [UniqFM and the register allocator]
-        , ra_fixupList     :: [(BlockId,BlockId,BlockId)]
-        -- ^ (from,fixup,to) : We inserted fixup code between from and to
-        }
-
-
--- | The register allocator state
-data RA_State freeRegs
-        = RA_State
-
-        {
-        -- | the current mapping from basic blocks to
-        --      the register assignments at the beginning of that block.
-          ra_blockassig :: BlockAssignment freeRegs
-
-        -- | free machine registers
-        , ra_freeregs   :: !freeRegs
-
-        -- | assignment of temps to locations
-        , ra_assig      :: RegMap Loc
-
-        -- | current stack delta
-        , ra_delta      :: Int
-
-        -- | free stack slots for spilling
-        , ra_stack      :: StackMap
-
-        -- | unique supply for generating names for join point fixup blocks.
-        , ra_us         :: UniqSupply
-
-        -- | Record why things were spilled, for -ddrop-asm-stats.
-        --      Just keep a list here instead of a map of regs -> reasons.
-        --      We don't want to slow down the allocator if we're not going to emit the stats.
-        , ra_spills     :: [SpillReason]
-
-        -- | Native code generator configuration
-        , ra_config     :: !NCGConfig
-
-        -- | (from,fixup,to) : We inserted fixup code between from and to
-        , ra_fixups     :: [(BlockId,BlockId,BlockId)]
-
-        }
-
-
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs b/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs
+++ /dev/null
@@ -1,82 +0,0 @@
-module GHC.CmmToAsm.Reg.Linear.FreeRegs (
-    FR(..),
-    maxSpillSlots
-)
-where
-
-import GHC.Prelude
-
-import GHC.Platform.Reg
-import GHC.Platform.Reg.Class
-
-import GHC.CmmToAsm.Config
-import GHC.Utils.Panic
-import GHC.Platform
-
--- -----------------------------------------------------------------------------
--- The free register set
--- This needs to be *efficient*
--- Here's an inefficient 'executable specification' of the FreeRegs data type:
---
---      type FreeRegs = [RegNo]
---      noFreeRegs = 0
---      releaseReg n f = if n `elem` f then f else (n : f)
---      initFreeRegs = allocatableRegs
---      getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
---      allocateReg f r = filter (/= r) f
-
-import qualified GHC.CmmToAsm.Reg.Linear.PPC     as PPC
-import qualified GHC.CmmToAsm.Reg.Linear.X86     as X86
-import qualified GHC.CmmToAsm.Reg.Linear.X86_64  as X86_64
-import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64
-
-import qualified GHC.CmmToAsm.PPC.Instr     as PPC.Instr
-import qualified GHC.CmmToAsm.X86.Instr     as X86.Instr
-import qualified GHC.CmmToAsm.AArch64.Instr as AArch64.Instr
-
-class Show freeRegs => FR freeRegs where
-    frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs
-    frGetFreeRegs :: Platform -> RegClass -> freeRegs -> [RealReg]
-    frInitFreeRegs :: Platform -> freeRegs
-    frReleaseReg :: Platform -> RealReg -> freeRegs -> freeRegs
-
-instance FR X86.FreeRegs where
-    frAllocateReg  = \_ -> X86.allocateReg
-    frGetFreeRegs  = X86.getFreeRegs
-    frInitFreeRegs = X86.initFreeRegs
-    frReleaseReg   = \_ -> X86.releaseReg
-
-instance FR X86_64.FreeRegs where
-    frAllocateReg  = \_ -> X86_64.allocateReg
-    frGetFreeRegs  = X86_64.getFreeRegs
-    frInitFreeRegs = X86_64.initFreeRegs
-    frReleaseReg   = \_ -> X86_64.releaseReg
-
-instance FR PPC.FreeRegs where
-    frAllocateReg  = \_ -> PPC.allocateReg
-    frGetFreeRegs  = \_ -> PPC.getFreeRegs
-    frInitFreeRegs = PPC.initFreeRegs
-    frReleaseReg   = \_ -> PPC.releaseReg
-
-instance FR AArch64.FreeRegs where
-    frAllocateReg = \_ -> AArch64.allocateReg
-    frGetFreeRegs = \_ -> AArch64.getFreeRegs
-    frInitFreeRegs = AArch64.initFreeRegs
-    frReleaseReg = \_ -> AArch64.releaseReg
-
-maxSpillSlots :: NCGConfig -> Int
-maxSpillSlots config = case platformArch (ncgPlatform config) of
-   ArchX86       -> X86.Instr.maxSpillSlots config
-   ArchX86_64    -> X86.Instr.maxSpillSlots config
-   ArchPPC       -> PPC.Instr.maxSpillSlots config
-   ArchS390X     -> panic "maxSpillSlots ArchS390X"
-   ArchARM _ _ _ -> panic "maxSpillSlots ArchARM"
-   ArchAArch64   -> AArch64.Instr.maxSpillSlots config
-   ArchPPC_64 _  -> PPC.Instr.maxSpillSlots config
-   ArchAlpha     -> panic "maxSpillSlots ArchAlpha"
-   ArchMipseb    -> panic "maxSpillSlots ArchMipseb"
-   ArchMipsel    -> panic "maxSpillSlots ArchMipsel"
-   ArchRISCV64   -> panic "maxSpillSlots ArchRISCV64"
-   ArchJavaScript-> panic "maxSpillSlots ArchJavaScript"
-   ArchWasm32    -> panic "maxSpillSlots ArchWasm32"
-   ArchUnknown   -> panic "maxSpillSlots ArchUnknown"
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs b/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs
+++ /dev/null
@@ -1,381 +0,0 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
--- | Handles joining of a jump instruction to its targets.
-
---      The first time we encounter a jump to a particular basic block, we
---      record the assignment of temporaries.  The next time we encounter a
---      jump to the same block, we compare our current assignment to the
---      stored one.  They might be different if spilling has occurred in one
---      branch; so some fixup code will be required to match up the assignments.
---
-module GHC.CmmToAsm.Reg.Linear.JoinToTargets (joinToTargets) where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.Reg.Linear.State
-import GHC.CmmToAsm.Reg.Linear.Base
-import GHC.CmmToAsm.Reg.Linear.FreeRegs
-import GHC.CmmToAsm.Reg.Liveness
-import GHC.CmmToAsm.Instr
-import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Types
-
-import GHC.Platform.Reg
-
-import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Collections
-import GHC.Data.Graph.Directed
-import GHC.Utils.Panic
-import GHC.Utils.Monad (concatMapM)
-import GHC.Types.Unique
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Set
-
-import GHC.Utils.Outputable
-
--- | For a jump instruction at the end of a block, generate fixup code so its
---      vregs are in the correct regs for its destination.
---
-joinToTargets
-        :: (FR freeRegs, Instruction instr)
-        => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs
-                                        --      that are known to be live on the entry to each block.
-
-        -> BlockId                      -- ^ id of the current block
-        -> instr                        -- ^ branch instr on the end of the source block.
-
-        -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code.
-                         , instr)               -- the original branch
-                                                -- instruction, but maybe
-                                                -- patched to jump
-                                                -- to a fixup block first.
-
-joinToTargets block_live id instr
-
-        -- we only need to worry about jump instructions.
-        | not $ isJumpishInstr instr
-        = return ([], instr)
-
-        | otherwise
-        = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr)
-
------
-joinToTargets'
-        :: (FR freeRegs, Instruction instr)
-        => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs
-                                        --      that are known to be live on the entry to each block.
-
-        -> [NatBasicBlock instr]        -- ^ acc blocks of fixup code.
-
-        -> BlockId                      -- ^ id of the current block
-        -> instr                        -- ^ branch instr on the end of the source block.
-
-        -> [BlockId]                    -- ^ branch destinations still to consider.
-
-        -> RegM freeRegs ([NatBasicBlock instr], instr)
-
--- no more targets to consider. all done.
-joinToTargets' _          new_blocks _ instr []
-        = return (new_blocks, instr)
-
--- handle a branch target.
-joinToTargets' block_live new_blocks block_id instr (dest:dests)
- = do
-        -- get the map of where the vregs are stored on entry to each basic block.
-        block_assig     <- getBlockAssigR
-
-        -- get the assignment on entry to the branch instruction.
-        assig           <- getAssigR
-
-        -- adjust the current assignment to remove any vregs that are not live
-        -- on entry to the destination block.
-        let Just live_set       = mapLookup dest block_live
-        let still_live uniq _   = uniq `elemUniqSet_Directly` live_set
-        let adjusted_assig      = filterUFM_Directly still_live assig
-
-        -- and free up those registers which are now free.
-        let to_free =
-                [ r     | (reg, loc) <- nonDetUFMToList assig
-                        -- This is non-deterministic but we do not
-                        -- currently support deterministic code-generation.
-                        -- See Note [Unique Determinism and code generation]
-                        , not (elemUniqSet_Directly reg live_set)
-                        , r          <- regsOfLoc loc ]
-
-        case lookupBlockAssignment  dest block_assig of
-         Nothing
-          -> joinToTargets_first
-                        block_live new_blocks block_id instr dest dests
-                        block_assig adjusted_assig to_free
-
-         Just (_, dest_assig)
-          -> joinToTargets_again
-                        block_live new_blocks block_id instr dest dests
-                        adjusted_assig dest_assig
-
-
--- this is the first time we jumped to this block.
-joinToTargets_first :: (FR freeRegs, Instruction instr)
-                    => BlockMap RegSet
-                    -> [NatBasicBlock instr]
-                    -> BlockId
-                    -> instr
-                    -> BlockId
-                    -> [BlockId]
-                    -> BlockAssignment freeRegs
-                    -> RegMap Loc
-                    -> [RealReg]
-                    -> RegM freeRegs ([NatBasicBlock instr], instr)
-joinToTargets_first block_live new_blocks block_id instr dest dests
-        block_assig src_assig
-        to_free
-
- = do   config <- getConfig
-        let platform = ncgPlatform config
-
-        -- free up the regs that are not live on entry to this block.
-        freeregs        <- getFreeRegsR
-        let freeregs' = foldl' (flip $ frReleaseReg platform) freeregs to_free
-
-        -- remember the current assignment on entry to this block.
-        setBlockAssigR (updateBlockAssignment dest (freeregs', src_assig) block_assig)
-
-        joinToTargets' block_live new_blocks block_id instr dests
-
-
--- we've jumped to this block before
-joinToTargets_again :: (Instruction instr, FR freeRegs)
-                    => BlockMap RegSet
-                    -> [NatBasicBlock instr]
-                    -> BlockId
-                    -> instr
-                    -> BlockId
-                    -> [BlockId]
-                    -> UniqFM Reg Loc
-                    -> UniqFM Reg Loc
-                    -> RegM freeRegs ([NatBasicBlock instr], instr)
-joinToTargets_again
-    block_live new_blocks block_id instr dest dests
-    src_assig dest_assig
-
-        -- the assignments already match, no problem.
-        | nonDetUFMToList dest_assig == nonDetUFMToList src_assig
-        -- This is non-deterministic but we do not
-        -- currently support deterministic code-generation.
-        -- See Note [Unique Determinism and code generation]
-        = joinToTargets' block_live new_blocks block_id instr dests
-
-        -- assignments don't match, need fixup code
-        | otherwise
-        = do
-
-                -- make a graph of what things need to be moved where.
-                let graph = makeRegMovementGraph src_assig dest_assig
-
-                -- look for cycles in the graph. This can happen if regs need to be swapped.
-                -- Note that we depend on the fact that this function does a
-                --      bottom up traversal of the tree-like portions of the graph.
-                --
-                --  eg, if we have
-                --      R1 -> R2 -> R3
-                --
-                --  ie move value in R1 to R2 and value in R2 to R3.
-                --
-                -- We need to do the R2 -> R3 move before R1 -> R2.
-                --
-                let sccs  = stronglyConnCompFromEdgedVerticesOrdR graph
-
-              -- debugging
-                {-
-                pprTrace
-                        ("joinToTargets: making fixup code")
-                        (vcat   [ text "        in block: "     <> ppr block_id
-                                , text " jmp instruction: "     <> ppr instr
-                                , text "  src assignment: "     <> ppr src_assig
-                                , text " dest assignment: "     <> ppr dest_assig
-                                , text "  movement graph: "     <> ppr graph
-                                , text "   sccs of graph: "     <> ppr sccs
-                                , text ""])
-                        (return ())
-                -}
-                delta           <- getDeltaR
-                fixUpInstrs_    <- mapM (handleComponent delta instr) sccs
-                let fixUpInstrs = concat fixUpInstrs_
-
-                -- make a new basic block containing the fixup code.
-                --      A the end of the current block we will jump to the fixup one,
-                --      then that will jump to our original destination.
-                fixup_block_id <- mkBlockId <$> getUniqueR
-                let block = BasicBlock fixup_block_id
-                                $ fixUpInstrs ++ mkJumpInstr dest
-
-                -- if we didn't need any fixups, then don't include the block
-                case fixUpInstrs of
-                 []     -> joinToTargets' block_live new_blocks block_id instr dests
-
-                 -- patch the original branch instruction so it goes to our
-                 --     fixup block instead.
-                 _      -> let  instr'  =  patchJumpInstr instr
-                                            (\bid -> if bid == dest
-                                                        then fixup_block_id
-                                                        else bid) -- no change!
-
-                           in do
-                                {- --debugging
-                                pprTrace "FixUpEdge info:"
-                                    (
-                                    text "inBlock:" <> ppr block_id $$
-                                    text "instr:" <> ppr instr $$
-                                    text "instr':" <> ppr instr' $$
-                                    text "fixup_block_id':" <>
-                                        ppr fixup_block_id $$
-                                    text "dest:" <> ppr dest
-                                    ) (return ())
-                                -}
-                                recordFixupBlock block_id fixup_block_id dest
-                                joinToTargets' block_live (block : new_blocks)
-                                               block_id instr' dests
-
-
--- | Construct a graph of register\/spill movements.
---
---      Cyclic components seem to occur only very rarely.
---
---      We cut some corners by not handling memory-to-memory moves.
---      This shouldn't happen because every temporary gets its own stack slot.
---
-makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [Node Loc Unique]
-makeRegMovementGraph adjusted_assig dest_assig
- = [ node       | (vreg, src) <- nonDetUFMToList adjusted_assig
-                    -- This is non-deterministic but we do not
-                    -- currently support deterministic code-generation.
-                    -- See Note [Unique Determinism and code generation]
-                    -- source reg might not be needed at the dest:
-                , Just loc <- [lookupUFM_Directly dest_assig vreg]
-                , node <- expandNode vreg src loc ]
-
-
--- | Expand out the destination, so InBoth destinations turn into
---      a combination of InReg and InMem.
-
---      The InBoth handling is a little tricky here.  If the destination is
---      InBoth, then we must ensure that the value ends up in both locations.
---      An InBoth  destination must conflict with an InReg or InMem source, so
---      we expand an InBoth destination as necessary.
---
---      An InBoth source is slightly different: we only care about the register
---      that the source value is in, so that we can move it to the destinations.
---
-expandNode
-        :: a
-        -> Loc                  -- ^ source of move
-        -> Loc                  -- ^ destination of move
-        -> [Node Loc a ]
-
-expandNode vreg loc@(InReg src) (InBoth dst mem)
-        | src == dst = [DigraphNode vreg loc [InMem mem]]
-        | otherwise  = [DigraphNode vreg loc [InReg dst, InMem mem]]
-
-expandNode vreg loc@(InMem src) (InBoth dst mem)
-        | src == mem = [DigraphNode vreg loc [InReg dst]]
-        | otherwise  = [DigraphNode vreg loc [InReg dst, InMem mem]]
-
-expandNode _        (InBoth _ src) (InMem dst)
-        | src == dst = [] -- guaranteed to be true
-
-expandNode _        (InBoth src _) (InReg dst)
-        | src == dst = []
-
-expandNode vreg     (InBoth src _) dst
-        = expandNode vreg (InReg src) dst
-
-expandNode vreg src dst
-        | src == dst = []
-        | otherwise  = [DigraphNode vreg src [dst]]
-
-
--- | Generate fixup code for a particular component in the move graph
---      This component tells us what values need to be moved to what
---      destinations. We have eliminated any possibility of single-node
---      cycles in expandNode above.
---
-handleComponent
-        :: Instruction instr
-        => Int -> instr -> SCC (Node Loc Unique)
-        -> RegM freeRegs [instr]
-
--- If the graph is acyclic then we won't get the swapping problem below.
---      In this case we can just do the moves directly, and avoid having to
---      go via a spill slot.
---
-handleComponent delta _  (AcyclicSCC (DigraphNode vreg src dsts))
-        = concatMapM (makeMove delta vreg src) dsts
-
-
--- Handle some cyclic moves.
---      This can happen if we have two regs that need to be swapped.
---      eg:
---           vreg   source loc   dest loc
---          (vreg1, InReg r1,    [InReg r2])
---          (vreg2, InReg r2,    [InReg r1])
---
---      To avoid needing temp register, we just spill all the source regs, then
---      reaload them into their destination regs.
---
---      Note that we can not have cycles that involve memory locations as
---      sources as single destination because memory locations (stack slots)
---      are allocated exclusively for a virtual register and therefore can not
---      require a fixup.
---
-handleComponent delta instr
-        (CyclicSCC ((DigraphNode vreg (InReg sreg) ((InReg dreg: _))) : rest))
-        -- dest list may have more than one element, if the reg is also InMem.
- = do
-        -- spill the source into its slot
-        (instrSpill, slot)
-                        <- spillR (RegReal sreg) vreg
-
-        -- reload into destination reg
-        instrLoad       <- loadR (RegReal dreg) slot
-
-        remainingFixUps <- mapM (handleComponent delta instr)
-                                (stronglyConnCompFromEdgedVerticesOrdR rest)
-
-        -- make sure to do all the reloads after all the spills,
-        --      so we don't end up clobbering the source values.
-        return (instrSpill ++ concat remainingFixUps ++ instrLoad)
-
-handleComponent _ _ (CyclicSCC _)
- = panic "Register Allocator: handleComponent cyclic"
-
-
--- | Move a vreg between these two locations.
---
-makeMove
-    :: Instruction instr
-    => Int      -- ^ current C stack delta.
-    -> Unique   -- ^ unique of the vreg that we're moving.
-    -> Loc      -- ^ source location.
-    -> Loc      -- ^ destination location.
-    -> RegM freeRegs [instr]  -- ^ move instruction.
-
-makeMove delta vreg src dst
- = do config <- getConfig
-      let platform = ncgPlatform config
-
-      case (src, dst) of
-          (InReg s, InReg d) ->
-              do recordSpill (SpillJoinRR vreg)
-                 return $ [mkRegRegMoveInstr platform (RegReal s) (RegReal d)]
-          (InMem s, InReg d) ->
-              do recordSpill (SpillJoinRM vreg)
-                 return $ mkLoadInstr config (RegReal d) delta s
-          (InReg s, InMem d) ->
-              do recordSpill (SpillJoinRM vreg)
-                 return $ mkSpillInstr config (RegReal s) delta d
-          _ ->
-              -- we don't handle memory to memory moves.
-              -- they shouldn't happen because we don't share
-              -- stack slots between vregs.
-              pprPanic "makeMove: we don't handle mem->mem moves"
-                 (ppr vreg <+> parens (ppr src) <+> parens (ppr dst))
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs b/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs
+++ /dev/null
@@ -1,57 +0,0 @@
--- | Free regs map for PowerPC
-module GHC.CmmToAsm.Reg.Linear.PPC where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.PPC.Regs
-import GHC.Platform.Reg.Class
-import GHC.Platform.Reg
-
-import GHC.Utils.Outputable
-import GHC.Platform
-
-import Data.Word
-
--- The PowerPC has 32 integer and 32 floating point registers.
--- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much
--- better.
--- Note that when getFreeRegs scans for free registers, it starts at register
--- 31 and counts down. This is a hack for the PowerPC - the higher-numbered
--- registers are callee-saves, while the lower regs are caller-saves, so it
--- makes sense to start at the high end.
--- Apart from that, the code does nothing PowerPC-specific, so feel free to
--- add your favourite platform to the #if (if you have 64 registers but only
--- 32-bit words).
-
-data FreeRegs = FreeRegs !Word32 !Word32
-              deriving( Show )  -- The Show is used in an ASSERT
-
-instance Outputable FreeRegs where
-    ppr = text . show
-
-noFreeRegs :: FreeRegs
-noFreeRegs = FreeRegs 0 0
-
-releaseReg :: RealReg -> FreeRegs -> FreeRegs
-releaseReg (RealRegSingle r) (FreeRegs g f)
-    | r > 31    = FreeRegs g (f .|. (1 `shiftL` (r - 32)))
-    | otherwise = FreeRegs (g .|. (1 `shiftL` r)) f
-
-initFreeRegs :: Platform -> FreeRegs
-initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)
-
-getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily
-getFreeRegs cls (FreeRegs g f)
-    | RcFloat <- cls = [] -- no float regs on PowerPC, use double
-    | RcDouble <- cls = go f (0x80000000) 63
-    | RcInteger <- cls = go g (0x80000000) 31
-    where
-        go _ 0 _ = []
-        go x m i | x .&. m /= 0 = RealRegSingle i : (go x (m `shiftR` 1) $! i-1)
-                 | otherwise    = go x (m `shiftR` 1) $! i-1
-
-allocateReg :: RealReg -> FreeRegs -> FreeRegs
-allocateReg (RealRegSingle r) (FreeRegs g f)
-    | r > 31    = FreeRegs g (f .&. complement (1 `shiftL` (r - 32)))
-    | otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f
-
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs b/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-
--- | The assignment of virtual registers to stack slots
-
---      We have lots of stack slots. Memory-to-memory moves are a pain on most
---      architectures. Therefore, we avoid having to generate memory-to-memory moves
---      by simply giving every virtual register its own stack slot.
-
---      The StackMap stack map keeps track of virtual register - stack slot
---      associations and of which stack slots are still free. Once it has been
---      associated, a stack slot is never "freed" or removed from the StackMap again,
---      it remains associated until we are done with the current CmmProc.
---
-module GHC.CmmToAsm.Reg.Linear.StackMap (
-        StackSlot,
-        StackMap(..),
-        emptyStackMap,
-        getStackSlotFor,
-        getStackUse
-)
-
-where
-
-import GHC.Prelude
-
-import GHC.Types.Unique.FM
-import GHC.Types.Unique
-
-
--- | Identifier for a stack slot.
-type StackSlot = Int
-
-data StackMap
-        = StackMap
-        { -- | The slots that are still available to be allocated.
-          stackMapNextFreeSlot  :: !Int
-
-          -- See Note [UniqFM and the register allocator]
-          -- | Assignment of vregs to stack slots.
-        , stackMapAssignment    :: UniqFM Unique StackSlot }
-
-
--- | An empty stack map, with all slots available.
-emptyStackMap :: StackMap
-emptyStackMap = StackMap 0 emptyUFM
-
-
--- | If this vreg unique already has a stack assignment then return the slot number,
---      otherwise allocate a new slot, and update the map.
---
-getStackSlotFor :: StackMap -> Unique -> (StackMap, Int)
-
-getStackSlotFor fs@(StackMap _ reserved) reg
-  | Just slot <- lookupUFM reserved reg  =  (fs, slot)
-
-getStackSlotFor (StackMap freeSlot reserved) reg =
-    (StackMap (freeSlot+1) (addToUFM reserved reg freeSlot), freeSlot)
-
--- | Return the number of stack slots that were allocated
-getStackUse :: StackMap -> Int
-getStackUse (StackMap freeSlot _) = freeSlot
-
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs
+++ /dev/null
@@ -1,184 +0,0 @@
-{-# LANGUAGE PatternSynonyms, DeriveFunctor #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE UnboxedTuples #-}
-
--- | State monad for the linear register allocator.
-
---      Here we keep all the state that the register allocator keeps track
---      of as it walks the instructions in a basic block.
-
-module GHC.CmmToAsm.Reg.Linear.State (
-        RA_State(..),
-        RegM,
-        runR,
-
-        spillR,
-        loadR,
-
-        getFreeRegsR,
-        setFreeRegsR,
-
-        getAssigR,
-        setAssigR,
-
-        getBlockAssigR,
-        setBlockAssigR,
-
-        setDeltaR,
-        getDeltaR,
-
-        getUniqueR,
-        getConfig,
-        getPlatform,
-
-        recordSpill,
-        recordFixupBlock
-)
-where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.Reg.Linear.Stats
-import GHC.CmmToAsm.Reg.Linear.StackMap
-import GHC.CmmToAsm.Reg.Linear.Base
-import GHC.CmmToAsm.Reg.Liveness
-import GHC.CmmToAsm.Instr
-import GHC.CmmToAsm.Config
-import GHC.Platform.Reg
-import GHC.Cmm.BlockId
-
-import GHC.Platform
-import GHC.Types.Unique
-import GHC.Types.Unique.Supply
-import GHC.Exts (oneShot)
-
-import Control.Monad (ap)
-
-type RA_Result freeRegs a = (# RA_State freeRegs, a #)
-
-pattern RA_Result :: a -> b -> (# a, b #)
-pattern RA_Result a b = (# a, b #)
-{-# COMPLETE RA_Result #-}
-
--- | The register allocator monad type.
-newtype RegM freeRegs a
-        = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }
-        deriving (Functor)
-
--- | Smart constructor for 'RegM', as described in Note [The one-shot state
--- monad trick] in GHC.Utils.Monad.
-mkRegM :: (RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
-mkRegM f = RegM (oneShot f)
-
-instance Applicative (RegM freeRegs) where
-      pure a  =  mkRegM $ \s -> RA_Result s a
-      (<*>) = ap
-
-instance Monad (RegM freeRegs) where
-  m >>= k   =  mkRegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }
-
--- | Get native code generator configuration
-getConfig :: RegM a NCGConfig
-getConfig = mkRegM $ \s -> RA_Result s (ra_config s)
-
--- | Get target platform from native code generator configuration
-getPlatform :: RegM a Platform
-getPlatform = ncgPlatform <$> getConfig
-
--- | Run a computation in the RegM register allocator monad.
-runR    :: NCGConfig
-        -> BlockAssignment freeRegs
-        -> freeRegs
-        -> RegMap Loc
-        -> StackMap
-        -> UniqSupply
-        -> RegM freeRegs a
-        -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)
-
-runR config block_assig freeregs assig stack us thing =
-  case unReg thing
-        (RA_State
-                { ra_blockassig = block_assig
-                , ra_freeregs   = freeregs
-                , ra_assig      = assig
-                , ra_delta      = 0{-???-}
-                , ra_stack      = stack
-                , ra_us         = us
-                , ra_spills     = []
-                , ra_config     = config
-                , ra_fixups     = [] })
-   of
-        RA_Result state returned_thing
-         ->     (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing)
-
-
--- | Make register allocator stats from its final state.
-makeRAStats :: RA_State freeRegs -> RegAllocStats
-makeRAStats state
-        = RegAllocStats
-        { ra_spillInstrs        = binSpillReasons (ra_spills state)
-        , ra_fixupList          = ra_fixups state }
-
-
-spillR :: Instruction instr
-       => Reg -> Unique -> RegM freeRegs ([instr], Int)
-
-spillR reg temp = mkRegM $ \s ->
-  let (stack1,slot) = getStackSlotFor (ra_stack s) temp
-      instr  = mkSpillInstr (ra_config s) reg (ra_delta s) slot
-  in
-  RA_Result s{ra_stack=stack1} (instr,slot)
-
-
-loadR :: Instruction instr
-      => Reg -> Int -> RegM freeRegs [instr]
-
-loadR reg slot = mkRegM $ \s ->
-  RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot)
-
-getFreeRegsR :: RegM freeRegs freeRegs
-getFreeRegsR = mkRegM $ \ s@RA_State{ra_freeregs = freeregs} ->
-  RA_Result s freeregs
-
-setFreeRegsR :: freeRegs -> RegM freeRegs ()
-setFreeRegsR regs = mkRegM $ \ s ->
-  RA_Result s{ra_freeregs = regs} ()
-
-getAssigR :: RegM freeRegs (RegMap Loc)
-getAssigR = mkRegM $ \ s@RA_State{ra_assig = assig} ->
-  RA_Result s assig
-
-setAssigR :: RegMap Loc -> RegM freeRegs ()
-setAssigR assig = mkRegM $ \ s ->
-  RA_Result s{ra_assig=assig} ()
-
-getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
-getBlockAssigR = mkRegM $ \ s@RA_State{ra_blockassig = assig} ->
-  RA_Result s assig
-
-setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()
-setBlockAssigR assig = mkRegM $ \ s ->
-  RA_Result s{ra_blockassig = assig} ()
-
-setDeltaR :: Int -> RegM freeRegs ()
-setDeltaR n = mkRegM $ \ s ->
-  RA_Result s{ra_delta = n} ()
-
-getDeltaR :: RegM freeRegs Int
-getDeltaR = mkRegM $ \s -> RA_Result s (ra_delta s)
-
-getUniqueR :: RegM freeRegs Unique
-getUniqueR = mkRegM $ \s ->
-  case takeUniqFromSupply (ra_us s) of
-    (uniq, us) -> RA_Result s{ra_us = us} uniq
-
-
--- | Record that a spill instruction was inserted, for profiling.
-recordSpill :: SpillReason -> RegM freeRegs ()
-recordSpill spill
-    = mkRegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) ()
-
--- | Record a created fixup block
-recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs ()
-recordFixupBlock from between to
-    = mkRegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs b/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs
+++ /dev/null
@@ -1,91 +0,0 @@
-module GHC.CmmToAsm.Reg.Linear.Stats (
-        binSpillReasons,
-        countRegRegMovesNat,
-        pprStats
-)
-
-where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.Reg.Linear.Base
-import GHC.CmmToAsm.Reg.Liveness
-import GHC.CmmToAsm.Instr
-import GHC.Types.Unique (Unique)
-import GHC.CmmToAsm.Types
-
-import GHC.Types.Unique.FM
-
-import GHC.Utils.Outputable
-import GHC.Utils.Monad.State.Strict
-
--- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
-binSpillReasons
-        :: [SpillReason] -> UniqFM Unique [Int]
-        -- See Note [UniqFM and the register allocator]
-binSpillReasons reasons
-        = addListToUFM_C
-                (zipWith (+))
-                emptyUFM
-                (map (\reason -> case reason of
-                        SpillAlloc r    -> (r, [1, 0, 0, 0, 0])
-                        SpillClobber r  -> (r, [0, 1, 0, 0, 0])
-                        SpillLoad r     -> (r, [0, 0, 1, 0, 0])
-                        SpillJoinRR r   -> (r, [0, 0, 0, 1, 0])
-                        SpillJoinRM r   -> (r, [0, 0, 0, 0, 1])) reasons)
-
-
--- | Count reg-reg moves remaining in this code.
-countRegRegMovesNat
-        :: Instruction instr
-        => NatCmmDecl statics instr -> Int
-
-countRegRegMovesNat cmm
-        = execState (mapGenBlockTopM countBlock cmm) 0
- where
-        countBlock b@(BasicBlock _ instrs)
-         = do   mapM_ countInstr instrs
-                return  b
-
-        countInstr instr
-                | Just _        <- takeRegRegMoveInstr instr
-                = do    modify (+ 1)
-                        return instr
-
-                | otherwise
-                =       return instr
-
-
--- | Pretty print some RegAllocStats
-pprStats
-        :: Instruction instr
-        => [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc
-
-pprStats code statss
- = let  -- sum up all the instrs inserted by the spiller
-        -- See Note [UniqFM and the register allocator]
-        spills :: UniqFM Unique [Int]
-        spills          = foldl' (plusUFM_C (zipWith (+)))
-                                emptyUFM
-                        $ map ra_spillInstrs statss
-
-        spillTotals     = foldl' (zipWith (+))
-                                [0, 0, 0, 0, 0]
-                        $ nonDetEltsUFM spills
-                        -- See Note [Unique Determinism and code generation]
-
-        -- count how many reg-reg-moves remain in the code
-        moves           = sum $ map countRegRegMovesNat code
-
-        pprSpill (reg, spills)
-                = parens $ (hcat $ punctuate (text ", ")  (doubleQuotes (ppr reg) : map ppr spills))
-
-   in   (  text "-- spills-added-total"
-        $$ text "--    (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)"
-        $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves])))
-        $$ text ""
-        $$ text "-- spills-added"
-        $$ text "--    (reg_name, allocs, clobbers, loads, joinRR, joinRM)"
-        $$ (pprUFMWithKeys spills (vcat . map pprSpill))
-        $$ text "")
-
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs b/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/X86.hs
+++ /dev/null
@@ -1,46 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
--- | Free regs map for i386
-module GHC.CmmToAsm.Reg.Linear.X86 where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.X86.Regs
-import GHC.Platform.Reg.Class
-import GHC.Platform.Reg
-import GHC.Platform
-import GHC.Utils.Outputable
-
-import Data.Word
-
-newtype FreeRegs = FreeRegs Word32
-    deriving (Show,Outputable)
-
-noFreeRegs :: FreeRegs
-noFreeRegs = FreeRegs 0
-
-releaseReg :: RealReg -> FreeRegs -> FreeRegs
-releaseReg (RealRegSingle n) (FreeRegs f)
-        = FreeRegs (f .|. (1 `shiftL` n))
-
-initFreeRegs :: Platform -> FreeRegs
-initFreeRegs platform
-        = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)
-
-getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily
-getFreeRegs platform cls (FreeRegs f) = go f 0
-
-  where go 0 _ = []
-        go n m
-          | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls
-          = RealRegSingle m : (go (n `shiftR` 1) $! (m+1))
-
-          | otherwise
-          = go (n `shiftR` 1) $! (m+1)
-        -- ToDo: there's no point looking through all the integer registers
-        -- in order to find a floating-point one.
-
-allocateReg :: RealReg -> FreeRegs -> FreeRegs
-allocateReg (RealRegSingle r) (FreeRegs f)
-        = FreeRegs (f .&. complement (1 `shiftL` r))
-
diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs b/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs
+++ /dev/null
@@ -1,46 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
--- | Free regs map for x86_64
-module GHC.CmmToAsm.Reg.Linear.X86_64 where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.X86.Regs
-import GHC.Platform.Reg.Class
-import GHC.Platform.Reg
-import GHC.Platform
-import GHC.Utils.Outputable
-
-import Data.Word
-
-newtype FreeRegs = FreeRegs Word64
-    deriving (Show,Outputable)
-
-noFreeRegs :: FreeRegs
-noFreeRegs = FreeRegs 0
-
-releaseReg :: RealReg -> FreeRegs -> FreeRegs
-releaseReg (RealRegSingle n) (FreeRegs f)
-        = FreeRegs (f .|. (1 `shiftL` n))
-
-initFreeRegs :: Platform -> FreeRegs
-initFreeRegs platform
-        = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)
-
-getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily
-getFreeRegs platform cls (FreeRegs f) = go f 0
-
-  where go 0 _ = []
-        go n m
-          | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls
-          = RealRegSingle m : (go (n `shiftR` 1) $! (m+1))
-
-          | otherwise
-          = go (n `shiftR` 1) $! (m+1)
-        -- ToDo: there's no point looking through all the integer registers
-        -- in order to find a floating-point one.
-
-allocateReg :: RealReg -> FreeRegs -> FreeRegs
-allocateReg (RealRegSingle r) (FreeRegs f)
-        = FreeRegs (f .&. complement (1 `shiftL` r))
-
diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs
+++ /dev/null
@@ -1,1072 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
------------------------------------------------------------------------------
---
--- The register liveness determinator
---
--- (c) The University of Glasgow 2004-2013
---
------------------------------------------------------------------------------
-
-module GHC.CmmToAsm.Reg.Liveness (
-        RegSet,
-        RegMap, emptyRegMap,
-        BlockMap, mapEmpty,
-        LiveCmmDecl,
-        InstrSR   (..),
-        LiveInstr (..),
-        Liveness (..),
-        LiveInfo (..),
-        LiveBasicBlock,
-
-        mapBlockTop,    mapBlockTopM,   mapSCCM,
-        mapGenBlockTop, mapGenBlockTopM,
-        mapLiveCmmDecl, pprLiveCmmDecl,
-        stripLive,
-        stripLiveBlock,
-        slurpConflicts,
-        slurpReloadCoalesce,
-        eraseDeltasLive,
-        patchEraseLive,
-        patchRegsLiveInstr,
-        reverseBlocksInTops,
-        regLiveness,
-        cmmTopLiveness
-  ) where
-import GHC.Prelude
-
-import GHC.Platform.Reg
-import GHC.CmmToAsm.Instr
-import GHC.CmmToAsm.CFG
-import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Types
-import GHC.CmmToAsm.Utils
-
-import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm hiding (RegSet, emptyRegSet)
-
-import GHC.Data.Graph.Directed
-import GHC.Utils.Monad
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Platform
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Supply
-import GHC.Data.Bag
-import GHC.Utils.Monad.State.Strict
-
-import Data.List (mapAccumL, partition)
-import Data.Maybe
-import Data.IntSet              (IntSet)
-
------------------------------------------------------------------------------
-type RegSet = UniqSet Reg
-
--- | Map from some kind of register to a.
---
--- While we give the type for keys as Reg which is the common case
--- sometimes we end up using VirtualReq or naked Uniques.
--- See Note [UniqFM and the register allocator]
-type RegMap a = UniqFM Reg a
-
-emptyRegMap :: RegMap a
-emptyRegMap = emptyUFM
-
-emptyRegSet :: RegSet
-emptyRegSet = emptyUniqSet
-
-type BlockMap a = LabelMap a
-
-type SlotMap a = UniqFM Slot a
-
-type Slot = Int
-
--- | A top level thing which carries liveness information.
-type LiveCmmDecl statics instr
-        = GenCmmDecl
-                statics
-                LiveInfo
-                [SCC (LiveBasicBlock instr)]
-
-
--- | The register allocator also wants to use SPILL/RELOAD meta instructions,
---   so we'll keep those here.
-data InstrSR instr
-        -- | A real machine instruction
-        = Instr  instr
-
-        -- | spill this reg to a stack slot
-        | SPILL  Reg Int
-
-        -- | reload this reg from a stack slot
-        | RELOAD Int Reg
-
-        deriving (Functor)
-
-instance Instruction instr => Instruction (InstrSR instr) where
-        regUsageOfInstr platform i
-         = case i of
-                Instr  instr    -> regUsageOfInstr platform instr
-                SPILL  reg _    -> RU [reg] []
-                RELOAD _ reg    -> RU [] [reg]
-
-        patchRegsOfInstr i f
-         = case i of
-                Instr instr     -> Instr (patchRegsOfInstr instr f)
-                SPILL  reg slot -> SPILL (f reg) slot
-                RELOAD slot reg -> RELOAD slot (f reg)
-
-        isJumpishInstr i
-         = case i of
-                Instr instr     -> isJumpishInstr instr
-                _               -> False
-
-        jumpDestsOfInstr i
-         = case i of
-                Instr instr     -> jumpDestsOfInstr instr
-                _               -> []
-
-        patchJumpInstr i f
-         = case i of
-                Instr instr     -> Instr (patchJumpInstr instr f)
-                _               -> i
-
-        mkSpillInstr            = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr"
-        mkLoadInstr             = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr"
-
-        takeDeltaInstr i
-         = case i of
-                Instr instr     -> takeDeltaInstr instr
-                _               -> Nothing
-
-        isMetaInstr i
-         = case i of
-                Instr instr     -> isMetaInstr instr
-                _               -> False
-
-        mkRegRegMoveInstr platform r1 r2
-            = Instr (mkRegRegMoveInstr platform r1 r2)
-
-        takeRegRegMoveInstr i
-         = case i of
-                Instr instr     -> takeRegRegMoveInstr instr
-                _               -> Nothing
-
-        mkJumpInstr target      = map Instr (mkJumpInstr target)
-
-        mkStackAllocInstr platform amount =
-             Instr <$> mkStackAllocInstr platform amount
-
-        mkStackDeallocInstr platform amount =
-             Instr <$> mkStackDeallocInstr platform amount
-
-        pprInstr platform i = ppr (fmap (pprInstr platform) i)
-
-        mkComment               = fmap Instr . mkComment
-
-
--- | An instruction with liveness information.
-data LiveInstr instr
-        = LiveInstr (InstrSR instr) (Maybe Liveness)
-        deriving (Functor)
-
--- | Liveness information.
---   The regs which die are ones which are no longer live in the *next* instruction
---   in this sequence.
---   (NB. if the instruction is a jump, these registers might still be live
---   at the jump target(s) - you have to check the liveness at the destination
---   block to find out).
-
-data Liveness
-        = Liveness
-        { liveBorn      :: RegSet       -- ^ registers born in this instruction (written to for first time).
-        , liveDieRead   :: RegSet       -- ^ registers that died because they were read for the last time.
-        , liveDieWrite  :: RegSet }     -- ^ registers that died because they were clobbered by something.
-
-
--- | Stash regs live on entry to each basic block in the info part of the cmm code.
-data LiveInfo
-        = LiveInfo
-                (LabelMap RawCmmStatics)  -- cmm info table static stuff
-                [BlockId]                 -- entry points (first one is the
-                                          -- entry point for the proc).
-                (BlockMap RegSet)         -- argument locals live on entry to this block
-                (BlockMap IntSet)         -- stack slots live on entry to this block
-
-
--- | A basic block with liveness information.
-type LiveBasicBlock instr
-        = GenBasicBlock (LiveInstr instr)
-
-
-instance Outputable instr
-      => Outputable (InstrSR instr) where
-
-        ppr (Instr realInstr)
-           = ppr realInstr
-
-        ppr (SPILL reg slot)
-           = hcat [
-                text "\tSPILL",
-                char ' ',
-                ppr reg,
-                comma,
-                text "SLOT" <> parens (int slot)]
-
-        ppr (RELOAD slot reg)
-           = hcat [
-                text "\tRELOAD",
-                char ' ',
-                text "SLOT" <> parens (int slot),
-                comma,
-                ppr reg]
-
-instance Outputable instr
-      => Outputable (LiveInstr instr) where
-
-        ppr (LiveInstr instr Nothing)
-         = ppr instr
-
-        ppr (LiveInstr instr (Just live))
-         =  ppr instr
-                $$ (nest 8
-                        $ vcat
-                        [ pprRegs (text "# born:    ") (liveBorn live)
-                        , pprRegs (text "# r_dying: ") (liveDieRead live)
-                        , pprRegs (text "# w_dying: ") (liveDieWrite live) ]
-                    $+$ space)
-
-         where  pprRegs :: SDoc -> RegSet -> SDoc
-                pprRegs name regs
-                 | isEmptyUniqSet regs  = empty
-                 | otherwise            = name <>
-                     (pprUFM (getUniqSet regs) (hcat . punctuate space . map ppr))
-
-instance OutputableP env instr => OutputableP env (LiveInstr instr) where
-   pdoc env i = ppr (fmap (pdoc env) i)
-
-instance OutputableP Platform LiveInfo where
-    pdoc env (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry)
-        =  (pdoc env mb_static)
-        $$ text "# entryIds         = " <> ppr entryIds
-        $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry
-        $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)
-
-
-
-
--- | map a function across all the basic blocks in this code
---
-mapBlockTop
-        :: (LiveBasicBlock instr -> LiveBasicBlock instr)
-        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
-
-mapBlockTop f cmm
-        = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
-
-
--- | map a function across all the basic blocks in this code (monadic version)
---
-mapBlockTopM
-        :: Monad m
-        => (LiveBasicBlock instr -> m (LiveBasicBlock instr))
-        -> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
-
-mapBlockTopM _ cmm@(CmmData{})
-        = return cmm
-
-mapBlockTopM f (CmmProc header label live sccs)
- = do   sccs'   <- mapM (mapSCCM f) sccs
-        return  $ CmmProc header label live sccs'
-
-mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
-mapSCCM f (AcyclicSCC x)
- = do   x'      <- f x
-        return  $ AcyclicSCC x'
-
-mapSCCM f (CyclicSCC xs)
- = do   xs'     <- mapM f xs
-        return  $ CyclicSCC xs'
-
-
--- map a function across all the basic blocks in this code
-mapGenBlockTop
-        :: (GenBasicBlock             i -> GenBasicBlock            i)
-        -> (GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i))
-
-mapGenBlockTop f cmm
-        = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
-
-
--- | map a function across all the basic blocks in this code (monadic version)
-mapGenBlockTopM
-        :: Monad m
-        => (GenBasicBlock            i  -> m (GenBasicBlock            i))
-        -> (GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i)))
-
-mapGenBlockTopM _ cmm@(CmmData{})
-        = return cmm
-
-mapGenBlockTopM f (CmmProc header label live (ListGraph blocks))
- = do   blocks' <- mapM f blocks
-        return  $ CmmProc header label live (ListGraph blocks')
-
-
--- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
---   Slurping of conflicts and moves is wrapped up together so we don't have
---   to make two passes over the same code when we want to build the graph.
---
-slurpConflicts
-        :: Instruction instr
-        => LiveCmmDecl statics instr
-        -> (Bag (UniqSet Reg), Bag (Reg, Reg))
-
-slurpConflicts live
-        = slurpCmm (emptyBag, emptyBag) live
-
- where  slurpCmm   rs  CmmData{}                = rs
-        slurpCmm   rs (CmmProc info _ _ sccs)
-                = foldl' (slurpSCC info) rs sccs
-
-        slurpSCC  info rs (AcyclicSCC b)
-                = slurpBlock info rs b
-
-        slurpSCC  info rs (CyclicSCC bs)
-                = foldl'  (slurpBlock info) rs bs
-
-        slurpBlock info rs (BasicBlock blockId instrs)
-                | LiveInfo _ _ blockLive _        <- info
-                , Just rsLiveEntry                <- mapLookup blockId blockLive
-                , (conflicts, moves)              <- slurpLIs rsLiveEntry rs instrs
-                = (consBag rsLiveEntry conflicts, moves)
-
-                | otherwise
-                = panic "Liveness.slurpConflicts: bad block"
-
-        slurpLIs rsLive (conflicts, moves) []
-                = (consBag rsLive conflicts, moves)
-
-        slurpLIs rsLive rs (LiveInstr _ Nothing     : lis)
-                = slurpLIs rsLive rs lis
-
-        slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis)
-         = let
-                -- regs that die because they are read for the last time at the start of an instruction
-                --      are not live across it.
-                rsLiveAcross    = rsLiveEntry `minusUniqSet` (liveDieRead live)
-
-                -- regs live on entry to the next instruction.
-                --      be careful of orphans, make sure to delete dying regs _after_ unioning
-                --      in the ones that are born here.
-                rsLiveNext      = (rsLiveAcross `unionUniqSets` (liveBorn     live))
-                                                `minusUniqSet`  (liveDieWrite live)
-
-                -- orphan vregs are the ones that die in the same instruction they are born in.
-                --      these are likely to be results that are never used, but we still
-                --      need to assign a hreg to them..
-                rsOrphans       = intersectUniqSets
-                                        (liveBorn live)
-                                        (unionUniqSets (liveDieWrite live) (liveDieRead live))
-
-                --
-                rsConflicts     = unionUniqSets rsLiveNext rsOrphans
-
-          in    case takeRegRegMoveInstr instr of
-                 Just rr        -> slurpLIs rsLiveNext
-                                        ( consBag rsConflicts conflicts
-                                        , consBag rr moves) lis
-
-                 Nothing        -> slurpLIs rsLiveNext
-                                        ( consBag rsConflicts conflicts
-                                        , moves) lis
-
-
--- | For spill\/reloads
---
---   SPILL  v1, slot1
---   ...
---   RELOAD slot1, v2
---
---   If we can arrange that v1 and v2 are allocated to the same hreg it's more likely
---   the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move.
---
---
-slurpReloadCoalesce
-        :: forall statics instr. Instruction instr
-        => LiveCmmDecl statics instr
-        -> Bag (Reg, Reg)
-
-slurpReloadCoalesce live
-        = slurpCmm emptyBag live
-
- where
-        slurpCmm :: Bag (Reg, Reg)
-                 -> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)]
-                 -> Bag (Reg, Reg)
-        slurpCmm cs CmmData{}   = cs
-        slurpCmm cs (CmmProc _ _ _ sccs)
-                = slurpComp cs (flattenSCCs sccs)
-
-        slurpComp :: Bag (Reg, Reg)
-                     -> [LiveBasicBlock instr]
-                     -> Bag (Reg, Reg)
-        slurpComp  cs blocks
-         = let  (moveBags, _)   = runState (slurpCompM blocks) emptyUFM
-           in   unionManyBags (cs : moveBags)
-
-        slurpCompM :: [LiveBasicBlock instr]
-                   -> State (UniqFM BlockId [UniqFM Slot Reg]) [Bag (Reg, Reg)]
-        slurpCompM blocks
-         = do   -- run the analysis once to record the mapping across jumps.
-                mapM_   (slurpBlock False) blocks
-
-                -- run it a second time while using the information from the last pass.
-                --      We /could/ run this many more times to deal with graphical control
-                --      flow and propagating info across multiple jumps, but it's probably
-                --      not worth the trouble.
-                mapM    (slurpBlock True) blocks
-
-        slurpBlock :: Bool -> LiveBasicBlock instr
-                   -> State (UniqFM BlockId [UniqFM Slot Reg]) (Bag (Reg, Reg))
-        slurpBlock propagate (BasicBlock blockId instrs)
-         = do   -- grab the slot map for entry to this block
-                slotMap         <- if propagate
-                                        then getSlotMap blockId
-                                        else return emptyUFM
-
-                (_, mMoves)     <- mapAccumLM slurpLI slotMap instrs
-                return $ listToBag $ catMaybes mMoves
-
-        slurpLI :: SlotMap Reg                           -- current slotMap
-                -> LiveInstr instr
-                -> State (UniqFM BlockId [SlotMap Reg])  -- blockId -> [slot -> reg]
-                                                        --      for tracking slotMaps across jumps
-
-                         ( SlotMap Reg           -- new slotMap
-                         , Maybe (Reg, Reg))            -- maybe a new coalesce edge
-
-        slurpLI slotMap li
-
-                -- remember what reg was stored into the slot
-                | LiveInstr (SPILL reg slot) _  <- li
-                , slotMap'                      <- addToUFM slotMap slot reg
-                = return (slotMap', Nothing)
-
-                -- add an edge between the this reg and the last one stored into the slot
-                | LiveInstr (RELOAD slot reg) _ <- li
-                = case lookupUFM slotMap slot of
-                        Just reg2
-                         | reg /= reg2  -> return (slotMap, Just (reg, reg2))
-                         | otherwise    -> return (slotMap, Nothing)
-
-                        Nothing         -> return (slotMap, Nothing)
-
-                -- if we hit a jump, remember the current slotMap
-                | LiveInstr (Instr instr) _     <- li
-                , targets                       <- jumpDestsOfInstr instr
-                , not $ null targets
-                = do    mapM_   (accSlotMap slotMap) targets
-                        return  (slotMap, Nothing)
-
-                | otherwise
-                = return (slotMap, Nothing)
-
-        -- record a slotmap for an in edge to this block
-        accSlotMap slotMap blockId
-                = modify (\s -> addToUFM_C (++) s blockId [slotMap])
-
-        -- work out the slot map on entry to this block
-        --      if we have slot maps for multiple in-edges then we need to merge them.
-        getSlotMap blockId
-         = do   map             <- get
-                let slotMaps    = fromMaybe [] (lookupUFM map blockId)
-                return          $ foldr mergeSlotMaps emptyUFM slotMaps
-
-        mergeSlotMaps :: SlotMap Reg -> SlotMap Reg -> SlotMap Reg
-        mergeSlotMaps map1 map2
-                -- toList sadly means we have to use the _Directly style
-                -- functions.
-                -- TODO: We shouldn't need to go through a list here.
-                = listToUFM_Directly
-                $ [ (k, r1)
-                  | (k, r1) <- nonDetUFMToList map1
-                  -- This is non-deterministic but we do not
-                  -- currently support deterministic code-generation.
-                  -- See Note [Unique Determinism and code generation]
-                  , case lookupUFM_Directly map2 k of
-                          Nothing -> False
-                          Just r2 -> r1 == r2 ]
-
-
--- | Strip away liveness information, yielding NatCmmDecl
-stripLive
-        :: (OutputableP Platform statics, Instruction instr)
-        => NCGConfig
-        -> LiveCmmDecl statics instr
-        -> NatCmmDecl statics instr
-
-stripLive config live
-        = stripCmm live
-
- where  stripCmm :: (OutputableP Platform statics, Instruction instr)
-                 => LiveCmmDecl statics instr -> NatCmmDecl statics instr
-        stripCmm (CmmData sec ds)       = CmmData sec ds
-        stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs)
-         = let  final_blocks    = flattenSCCs sccs
-
-                -- make sure the block that was first in the input list
-                --      stays at the front of the output. This is the entry point
-                --      of the proc, and it needs to come first.
-                ((first':_), rest')
-                                = partition ((== first_id) . blockId) final_blocks
-
-           in   CmmProc info label live
-                          (ListGraph $ map (stripLiveBlock config) $ first' : rest')
-
-        -- If the proc has blocks but we don't know what the first one was, then we're dead.
-        stripCmm proc
-                 = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (pprLiveCmmDecl (ncgPlatform config) proc)
-
-
--- | Pretty-print a `LiveCmmDecl`
-pprLiveCmmDecl :: (OutputableP Platform statics, Instruction instr) => Platform -> LiveCmmDecl statics instr -> SDoc
-pprLiveCmmDecl platform d = pdoc platform (mapLiveCmmDecl (pprInstr platform) d)
-
-
--- | Map over instruction type in `LiveCmmDecl`
-mapLiveCmmDecl
-   :: (instr -> b)
-   -> LiveCmmDecl statics instr
-   -> LiveCmmDecl statics b
-mapLiveCmmDecl f proc = fmap (fmap (fmap (fmap (fmap f)))) proc
-
--- | Strip away liveness information from a basic block,
---   and make real spill instructions out of SPILL, RELOAD pseudos along the way.
-
-stripLiveBlock
-        :: Instruction instr
-        => NCGConfig
-        -> LiveBasicBlock instr
-        -> NatBasicBlock instr
-
-stripLiveBlock config (BasicBlock i lis)
- =      BasicBlock i instrs'
-
- where  (instrs', _)
-                = runState (spillNat [] lis) 0
-
-        -- spillNat :: [instr] -> [LiveInstr instr] -> State Int [instr]
-        spillNat :: Instruction instr => [instr] -> [LiveInstr instr] -> State Int [instr]
-        spillNat acc []
-         =      return (reverse acc)
-
-        -- The SPILL/RELOAD cases do not appear to be exercised by our codegens
-        --
-        spillNat acc (LiveInstr (SPILL reg slot) _ : instrs)
-         = do   delta   <- get
-                spillNat (mkSpillInstr config reg delta slot ++ acc) instrs
-
-        spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs)
-         = do   delta   <- get
-                spillNat (mkLoadInstr config reg delta slot ++ acc) instrs
-
-        spillNat acc (LiveInstr (Instr instr) _ : instrs)
-         | Just i <- takeDeltaInstr instr
-         = do   put i
-                spillNat acc instrs
-
-        spillNat acc (LiveInstr (Instr instr) _ : instrs)
-         =      spillNat (instr : acc) instrs
-
-
--- | Erase Delta instructions.
-
-eraseDeltasLive
-        :: Instruction instr
-        => LiveCmmDecl statics instr
-        -> LiveCmmDecl statics instr
-
-eraseDeltasLive cmm
-        = mapBlockTop eraseBlock cmm
- where
-        eraseBlock (BasicBlock id lis)
-                = BasicBlock id
-                $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i)
-                $ lis
-
-
--- | Patch the registers in this code according to this register mapping.
---   also erase reg -> reg moves when the reg is the same.
---   also erase reg -> reg moves when the destination dies in this instr.
-patchEraseLive
-        :: Instruction instr
-        => (Reg -> Reg)
-        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
-
-patchEraseLive patchF cmm
-        = patchCmm cmm
- where
-        patchCmm cmm@CmmData{}  = cmm
-
-        patchCmm (CmmProc info label live sccs)
-         | LiveInfo static id blockMap mLiveSlots <- info
-         = let
-                patchRegSet set = mkUniqSet $ map patchF $ nonDetEltsUFM set
-                  -- See Note [Unique Determinism and code generation]
-                blockMap'       = mapMap (patchRegSet . getUniqSet) blockMap
-
-                info'           = LiveInfo static id blockMap' mLiveSlots
-           in   CmmProc info' label live $ map patchSCC sccs
-
-        patchSCC (AcyclicSCC b)  = AcyclicSCC (patchBlock b)
-        patchSCC (CyclicSCC  bs) = CyclicSCC  (map patchBlock bs)
-
-        patchBlock (BasicBlock id lis)
-                = BasicBlock id $ patchInstrs lis
-
-        patchInstrs []          = []
-        patchInstrs (li : lis)
-
-                | LiveInstr i (Just live)       <- li'
-                , Just (r1, r2) <- takeRegRegMoveInstr i
-                , eatMe r1 r2 live
-                = patchInstrs lis
-
-                | otherwise
-                = li' : patchInstrs lis
-
-                where   li'     = patchRegsLiveInstr patchF li
-
-        eatMe   r1 r2 live
-                -- source and destination regs are the same
-                | r1 == r2      = True
-
-                -- destination reg is never used
-                | elementOfUniqSet r2 (liveBorn live)
-                , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
-                = True
-
-                | otherwise     = False
-
-
--- | Patch registers in this LiveInstr, including the liveness information.
---
-patchRegsLiveInstr
-        :: Instruction instr
-        => (Reg -> Reg)
-        -> LiveInstr instr -> LiveInstr instr
-
-patchRegsLiveInstr patchF li
- = case li of
-        LiveInstr instr Nothing
-         -> LiveInstr (patchRegsOfInstr instr patchF) Nothing
-
-        LiveInstr instr (Just live)
-         -> LiveInstr
-                (patchRegsOfInstr instr patchF)
-                (Just live
-                        { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
-                          liveBorn      = mapUniqSet patchF $ liveBorn live
-                        , liveDieRead   = mapUniqSet patchF $ liveDieRead live
-                        , liveDieWrite  = mapUniqSet patchF $ liveDieWrite live })
-                          -- See Note [Unique Determinism and code generation]
-
-
---------------------------------------------------------------------------------
--- | Convert a NatCmmDecl to a LiveCmmDecl, with liveness information
-
-cmmTopLiveness
-        :: Instruction instr
-        => Maybe CFG
-        -> Platform
-        -> NatCmmDecl statics instr
-        -> UniqSM (LiveCmmDecl statics instr)
-cmmTopLiveness cfg platform cmm
-        = regLiveness platform $ natCmmTopToLive cfg cmm
-
-natCmmTopToLive
-        :: Instruction instr
-        => Maybe CFG -> NatCmmDecl statics instr
-        -> LiveCmmDecl statics instr
-
-natCmmTopToLive _ (CmmData i d)
-        = CmmData i d
-
-natCmmTopToLive _ (CmmProc info lbl live (ListGraph []))
-        = CmmProc (LiveInfo info [] mapEmpty mapEmpty) lbl live []
-
-natCmmTopToLive mCfg proc@(CmmProc info lbl live (ListGraph blocks@(first : _)))
-        = CmmProc (LiveInfo info' (first_id : entry_ids) mapEmpty mapEmpty)
-                lbl live sccsLive
-   where
-        first_id        = blockId first
-        all_entry_ids   = entryBlocks proc
-        sccs            = sccBlocks blocks all_entry_ids mCfg
-        sccsLive        = map (fmap (\(BasicBlock l instrs) ->
-                                       BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
-                        $ sccs
-
-        entry_ids       = filter (reachable_node) .
-                          filter (/= first_id) $ all_entry_ids
-        info'           = mapFilterWithKey (\node _ -> reachable_node node) info
-        reachable_node
-          | Just cfg <- mCfg
-          = hasNode cfg
-          | otherwise
-          = const True
-
---
--- Compute the liveness graph of the set of basic blocks.  Important:
--- we also discard any unreachable code here, starting from the entry
--- points (the first block in the list, and any blocks with info
--- tables).  Unreachable code arises when code blocks are orphaned in
--- earlier optimisation passes, and may confuse the register allocator
--- by referring to registers that are not initialised.  It's easy to
--- discard the unreachable code as part of the SCC pass, so that's
--- exactly what we do. (#7574)
---
-sccBlocks
-        :: forall instr . Instruction instr
-        => [NatBasicBlock instr]
-        -> [BlockId]
-        -> Maybe CFG
-        -> [SCC (NatBasicBlock instr)]
-
-sccBlocks blocks entries mcfg = map (fmap node_payload) sccs
-  where
-        nodes :: [ Node BlockId (NatBasicBlock instr) ]
-        nodes = [ DigraphNode block id (getOutEdges instrs)
-                | block@(BasicBlock id instrs) <- blocks ]
-
-        g1 = graphFromEdgedVerticesUniq nodes
-
-        reachable :: LabelSet
-        reachable
-            | Just cfg <- mcfg
-            -- Our CFG only contains reachable nodes by construction at this point.
-            = setFromList $ getCfgNodes cfg
-            | otherwise
-            = setFromList $ [ node_key node | node <- reachablesG g1 roots ]
-
-        g2 = graphFromEdgedVerticesUniq [ node | node <- nodes
-                                               , node_key node
-                                                  `setMember` reachable ]
-
-        sccs = stronglyConnCompG g2
-
-        getOutEdges :: Instruction instr => [instr] -> [BlockId]
-        getOutEdges instrs = concatMap jumpDestsOfInstr instrs
-
-        -- This is truly ugly, but I don't see a good alternative.
-        -- Digraph just has the wrong API.  We want to identify nodes
-        -- by their keys (BlockId), but Digraph requires the whole
-        -- node: (NatBasicBlock, BlockId, [BlockId]).  This takes
-        -- advantage of the fact that Digraph only looks at the key,
-        -- even though it asks for the whole triple.
-        roots = [DigraphNode (panic "sccBlocks") b (panic "sccBlocks")
-                | b <- entries ]
-
---------------------------------------------------------------------------------
--- Annotate code with register liveness information
---
-
-regLiveness
-        :: Instruction instr
-        => Platform
-        -> LiveCmmDecl statics instr
-        -> UniqSM (LiveCmmDecl statics instr)
-
-regLiveness _ (CmmData i d)
-        = return $ CmmData i d
-
-regLiveness _ (CmmProc info lbl live [])
-        | LiveInfo static mFirst _ _    <- info
-        = return $ CmmProc
-                        (LiveInfo static mFirst mapEmpty mapEmpty)
-                        lbl live []
-
-regLiveness platform (CmmProc info lbl live sccs)
-        | LiveInfo static mFirst _ liveSlotsOnEntry     <- info
-        = let   (ann_sccs, block_live)  = computeLiveness platform sccs
-
-          in    return $ CmmProc (LiveInfo static mFirst block_live liveSlotsOnEntry)
-                           lbl live ann_sccs
-
-
--- -----------------------------------------------------------------------------
--- | Check ordering of Blocks
---   The computeLiveness function requires SCCs to be in reverse
---   dependent order.  If they're not the liveness information will be
---   wrong, and we'll get a bad allocation.  Better to check for this
---   precondition explicitly or some other poor sucker will waste a
---   day staring at bad assembly code..
---
-checkIsReverseDependent
-        :: Instruction instr
-        => [SCC (LiveBasicBlock instr)]         -- ^ SCCs of blocks that we're about to run the liveness determinator on.
-        -> Maybe BlockId                        -- ^ BlockIds that fail the test (if any)
-
-checkIsReverseDependent sccs'
- = go emptyUniqSet sccs'
-
- where  go _ []
-         = Nothing
-
-        go blocksSeen (AcyclicSCC block : sccs)
-         = let  dests           = slurpJumpDestsOfBlock block
-                blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet [blockId block]
-                badDests        = dests `minusUniqSet` blocksSeen'
-           in   case nonDetEltsUniqSet badDests of
-                 -- See Note [Unique Determinism and code generation]
-                 []             -> go blocksSeen' sccs
-                 bad : _        -> Just bad
-
-        go blocksSeen (CyclicSCC blocks : sccs)
-         = let  dests           = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks
-                blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks
-                badDests        = dests `minusUniqSet` blocksSeen'
-           in   case nonDetEltsUniqSet badDests of
-                 -- See Note [Unique Determinism and code generation]
-                 []             -> go blocksSeen' sccs
-                 bad : _        -> Just bad
-
-        slurpJumpDestsOfBlock (BasicBlock _ instrs)
-                = unionManyUniqSets
-                $ map (mkUniqSet . jumpDestsOfInstr)
-                        [ i | LiveInstr i _ <- instrs]
-
-
--- | If we've compute liveness info for this code already we have to reverse
---   the SCCs in each top to get them back to the right order so we can do it again.
-reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr
-reverseBlocksInTops top
- = case top of
-        CmmData{}                       -> top
-        CmmProc info lbl live sccs      -> CmmProc info lbl live (reverse sccs)
-
-
--- | Computing liveness
---
---  On entry, the SCCs must be in "reverse" order: later blocks may transfer
---  control to earlier ones only, else `panic`.
---
---  The SCCs returned are in the *opposite* order, which is exactly what we
---  want for the next pass.
---
-computeLiveness
-        :: Instruction instr
-        => Platform
-        -> [SCC (LiveBasicBlock instr)]
-        -> ([SCC (LiveBasicBlock instr)],       -- instructions annotated with list of registers
-                                                -- which are "dead after this instruction".
-               BlockMap RegSet)                 -- blocks annotated with set of live registers
-                                                -- on entry to the block.
-
-computeLiveness platform sccs
- = case checkIsReverseDependent sccs of
-        Nothing         -> livenessSCCs platform mapEmpty [] sccs
-        Just bad        -> let sccs' = fmap (fmap (fmap (fmap (pprInstr platform)))) sccs
-                           in pprPanic "RegAlloc.Liveness.computeLiveness"
-                                (vcat   [ text "SCCs aren't in reverse dependent order"
-                                        , text "bad blockId" <+> ppr bad
-                                        , ppr sccs'])
-
-livenessSCCs
-       :: Instruction instr
-       => Platform
-       -> BlockMap RegSet
-       -> [SCC (LiveBasicBlock instr)]          -- accum
-       -> [SCC (LiveBasicBlock instr)]
-       -> ( [SCC (LiveBasicBlock instr)]
-          , BlockMap RegSet)
-
-livenessSCCs _ blockmap done []
-        = (done, blockmap)
-
-livenessSCCs platform blockmap done (AcyclicSCC block : sccs)
- = let  (blockmap', block')     = livenessBlock platform blockmap block
-   in   livenessSCCs platform blockmap' (AcyclicSCC block' : done) sccs
-
-livenessSCCs platform blockmap done
-        (CyclicSCC blocks : sccs) =
-        livenessSCCs platform blockmap' (CyclicSCC blocks':done) sccs
- where      (blockmap', blocks')
-                = iterateUntilUnchanged linearLiveness equalBlockMaps
-                                      blockmap blocks
-
-            iterateUntilUnchanged
-                :: (a -> b -> (a,c)) -> (a -> a -> Bool)
-                -> a -> b
-                -> (a,c)
-
-            iterateUntilUnchanged f eq aa b = go aa
-              where
-                go a = if eq a a' then ac else go a'
-                  where
-                    ac@(a', _) = f a b
-
-            linearLiveness
-                :: Instruction instr
-                => BlockMap RegSet -> [LiveBasicBlock instr]
-                -> (BlockMap RegSet, [LiveBasicBlock instr])
-
-            linearLiveness = mapAccumL (livenessBlock platform)
-
-                -- probably the least efficient way to compare two
-                -- BlockMaps for equality.
-            equalBlockMaps a b
-                = a' == b'
-              where a' = map f $ mapToList a
-                    b' = map f $ mapToList b
-                    f (key,elt) = (key, nonDetEltsUniqSet elt)
-                    -- See Note [Unique Determinism and code generation]
-
-
-
--- | Annotate a basic block with register liveness information.
---
-livenessBlock
-        :: Instruction instr
-        => Platform
-        -> BlockMap RegSet
-        -> LiveBasicBlock instr
-        -> (BlockMap RegSet, LiveBasicBlock instr)
-
-livenessBlock platform blockmap (BasicBlock block_id instrs)
- = let
-        (regsLiveOnEntry, instrs1)
-            = livenessBack platform emptyUniqSet blockmap [] (reverse instrs)
-        blockmap'       = mapInsert block_id regsLiveOnEntry blockmap
-
-        instrs2         = livenessForward platform regsLiveOnEntry instrs1
-
-        output          = BasicBlock block_id instrs2
-
-   in   ( blockmap', output)
-
--- | Calculate liveness going forwards,
---   filling in when regs are born
-
-livenessForward
-        :: Instruction instr
-        => Platform
-        -> RegSet                       -- regs live on this instr
-        -> [LiveInstr instr] -> [LiveInstr instr]
-
-livenessForward _        _           []  = []
-livenessForward platform rsLiveEntry (li@(LiveInstr instr mLive) : lis)
-        | Just live <- mLive
-        = let
-                RU _ written  = regUsageOfInstr platform instr
-                -- Regs that are written to but weren't live on entry to this instruction
-                --      are recorded as being born here.
-                rsBorn          = mkUniqSet
-                                $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
-
-                rsLiveNext      = (rsLiveEntry `unionUniqSets` rsBorn)
-                                        `minusUniqSet` (liveDieRead live)
-                                        `minusUniqSet` (liveDieWrite live)
-
-        in LiveInstr instr (Just live { liveBorn = rsBorn })
-                : livenessForward platform rsLiveNext lis
-
-        | otherwise
-        = li : livenessForward platform rsLiveEntry lis
-
-
--- | Calculate liveness going backwards,
---   filling in when regs die, and what regs are live across each instruction
-
-livenessBack
-        :: Instruction instr
-        => Platform
-        -> RegSet                       -- regs live on this instr
-        -> BlockMap RegSet              -- regs live on entry to other BBs
-        -> [LiveInstr instr]            -- instructions (accum)
-        -> [LiveInstr instr]            -- instructions
-        -> (RegSet, [LiveInstr instr])
-
-livenessBack _        liveregs _        done []  = (liveregs, done)
-
-livenessBack platform liveregs blockmap acc (instr : instrs)
- = let  (liveregs', instr')     = liveness1 platform liveregs blockmap instr
-   in   livenessBack platform liveregs' blockmap (instr' : acc) instrs
-
-
--- don't bother tagging comments or deltas with liveness
-liveness1
-        :: Instruction instr
-        => Platform
-        -> RegSet
-        -> BlockMap RegSet
-        -> LiveInstr instr
-        -> (RegSet, LiveInstr instr)
-
-liveness1 _ liveregs _ (LiveInstr instr _)
-        | isMetaInstr instr
-        = (liveregs, LiveInstr instr Nothing)
-
-liveness1 platform liveregs blockmap (LiveInstr instr _)
-
-        | not_a_branch
-        = (liveregs1, LiveInstr instr
-                        (Just $ Liveness
-                        { liveBorn      = emptyUniqSet
-                        , liveDieRead   = mkUniqSet r_dying
-                        , liveDieWrite  = mkUniqSet w_dying }))
-
-        | otherwise
-        = (liveregs_br, LiveInstr instr
-                        (Just $ Liveness
-                        { liveBorn      = emptyUniqSet
-                        , liveDieRead   = mkUniqSet r_dying_br
-                        , liveDieWrite  = mkUniqSet w_dying }))
-
-        where
-            !(RU read written) = regUsageOfInstr platform instr
-
-            -- registers that were written here are dead going backwards.
-            -- registers that were read here are live going backwards.
-            liveregs1   = (liveregs `delListFromUniqSet` written)
-                                    `addListToUniqSet` read
-
-            -- registers that are not live beyond this point, are recorded
-            --  as dying here.
-            r_dying     = [ reg | reg <- read, reg `notElem` written,
-                              not (elementOfUniqSet reg liveregs) ]
-
-            w_dying     = [ reg | reg <- written,
-                             not (elementOfUniqSet reg liveregs) ]
-
-            -- union in the live regs from all the jump destinations of this
-            -- instruction.
-            targets      = jumpDestsOfInstr instr -- where we go from here
-            not_a_branch = null targets
-
-            targetLiveRegs target
-                  = case mapLookup target blockmap of
-                                Just ra -> ra
-                                Nothing -> emptyRegSet
-
-            live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
-
-            liveregs_br = liveregs1 `unionUniqSets` live_from_branch
-
-            -- registers that are live only in the branch targets should
-            -- be listed as dying here.
-            live_branch_only = live_from_branch `minusUniqSet` liveregs
-            r_dying_br  = nonDetEltsUniqSet (mkUniqSet r_dying `unionUniqSets`
-                                             live_branch_only)
-                          -- See Note [Unique Determinism and code generation]
diff --git a/compiler/GHC/CmmToAsm/Reg/Target.hs b/compiler/GHC/CmmToAsm/Reg/Target.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Target.hs
+++ /dev/null
@@ -1,135 +0,0 @@
-
--- | Hard wired things related to registers.
---      This is module is preventing the native code generator being able to
---      emit code for non-host architectures.
---
---      TODO: Do a better job of the overloading, and eliminate this module.
---      We'd probably do better with a Register type class, and hook this to
---      Instruction somehow.
---
---      TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable
-module GHC.CmmToAsm.Reg.Target (
-        targetVirtualRegSqueeze,
-        targetRealRegSqueeze,
-        targetClassOfRealReg,
-        targetMkVirtualReg,
-        targetRegDotColor,
-        targetClassOfReg
-)
-
-where
-
-import GHC.Prelude
-
-import GHC.Platform.Reg
-import GHC.Platform.Reg.Class
-import GHC.CmmToAsm.Format
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Types.Unique
-import GHC.Platform
-
-import qualified GHC.CmmToAsm.X86.Regs       as X86
-import qualified GHC.CmmToAsm.X86.RegInfo    as X86
-import qualified GHC.CmmToAsm.PPC.Regs       as PPC
-import qualified GHC.CmmToAsm.AArch64.Regs   as AArch64
-
-
-targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int
-targetVirtualRegSqueeze platform
-    = case platformArch platform of
-      ArchX86       -> X86.virtualRegSqueeze
-      ArchX86_64    -> X86.virtualRegSqueeze
-      ArchPPC       -> PPC.virtualRegSqueeze
-      ArchS390X     -> panic "targetVirtualRegSqueeze ArchS390X"
-      ArchPPC_64 _  -> PPC.virtualRegSqueeze
-      ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM"
-      ArchAArch64   -> AArch64.virtualRegSqueeze
-      ArchAlpha     -> panic "targetVirtualRegSqueeze ArchAlpha"
-      ArchMipseb    -> panic "targetVirtualRegSqueeze ArchMipseb"
-      ArchMipsel    -> panic "targetVirtualRegSqueeze ArchMipsel"
-      ArchRISCV64   -> panic "targetVirtualRegSqueeze ArchRISCV64"
-      ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript"
-      ArchWasm32    -> panic "targetVirtualRegSqueeze ArchWasm32"
-      ArchUnknown   -> panic "targetVirtualRegSqueeze ArchUnknown"
-
-
-targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> Int
-targetRealRegSqueeze platform
-    = case platformArch platform of
-      ArchX86       -> X86.realRegSqueeze
-      ArchX86_64    -> X86.realRegSqueeze
-      ArchPPC       -> PPC.realRegSqueeze
-      ArchS390X     -> panic "targetRealRegSqueeze ArchS390X"
-      ArchPPC_64 _  -> PPC.realRegSqueeze
-      ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM"
-      ArchAArch64   -> AArch64.realRegSqueeze
-      ArchAlpha     -> panic "targetRealRegSqueeze ArchAlpha"
-      ArchMipseb    -> panic "targetRealRegSqueeze ArchMipseb"
-      ArchMipsel    -> panic "targetRealRegSqueeze ArchMipsel"
-      ArchRISCV64   -> panic "targetRealRegSqueeze ArchRISCV64"
-      ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript"
-      ArchWasm32    -> panic "targetRealRegSqueeze ArchWasm32"
-      ArchUnknown   -> panic "targetRealRegSqueeze ArchUnknown"
-
-targetClassOfRealReg :: Platform -> RealReg -> RegClass
-targetClassOfRealReg platform
-    = case platformArch platform of
-      ArchX86       -> X86.classOfRealReg platform
-      ArchX86_64    -> X86.classOfRealReg platform
-      ArchPPC       -> PPC.classOfRealReg
-      ArchS390X     -> panic "targetClassOfRealReg ArchS390X"
-      ArchPPC_64 _  -> PPC.classOfRealReg
-      ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM"
-      ArchAArch64   -> AArch64.classOfRealReg
-      ArchAlpha     -> panic "targetClassOfRealReg ArchAlpha"
-      ArchMipseb    -> panic "targetClassOfRealReg ArchMipseb"
-      ArchMipsel    -> panic "targetClassOfRealReg ArchMipsel"
-      ArchRISCV64   -> panic "targetClassOfRealReg ArchRISCV64"
-      ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript"
-      ArchWasm32    -> panic "targetClassOfRealReg ArchWasm32"
-      ArchUnknown   -> panic "targetClassOfRealReg ArchUnknown"
-
-targetMkVirtualReg :: Platform -> Unique -> Format -> VirtualReg
-targetMkVirtualReg platform
-    = case platformArch platform of
-      ArchX86       -> X86.mkVirtualReg
-      ArchX86_64    -> X86.mkVirtualReg
-      ArchPPC       -> PPC.mkVirtualReg
-      ArchS390X     -> panic "targetMkVirtualReg ArchS390X"
-      ArchPPC_64 _  -> PPC.mkVirtualReg
-      ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM"
-      ArchAArch64   -> AArch64.mkVirtualReg
-      ArchAlpha     -> panic "targetMkVirtualReg ArchAlpha"
-      ArchMipseb    -> panic "targetMkVirtualReg ArchMipseb"
-      ArchMipsel    -> panic "targetMkVirtualReg ArchMipsel"
-      ArchRISCV64   -> panic "targetMkVirtualReg ArchRISCV64"
-      ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript"
-      ArchWasm32    -> panic "targetMkVirtualReg ArchWasm32"
-      ArchUnknown   -> panic "targetMkVirtualReg ArchUnknown"
-
-targetRegDotColor :: Platform -> RealReg -> SDoc
-targetRegDotColor platform
-    = case platformArch platform of
-      ArchX86       -> X86.regDotColor platform
-      ArchX86_64    -> X86.regDotColor platform
-      ArchPPC       -> PPC.regDotColor
-      ArchS390X     -> panic "targetRegDotColor ArchS390X"
-      ArchPPC_64 _  -> PPC.regDotColor
-      ArchARM _ _ _ -> panic "targetRegDotColor ArchARM"
-      ArchAArch64   -> AArch64.regDotColor
-      ArchAlpha     -> panic "targetRegDotColor ArchAlpha"
-      ArchMipseb    -> panic "targetRegDotColor ArchMipseb"
-      ArchMipsel    -> panic "targetRegDotColor ArchMipsel"
-      ArchRISCV64   -> panic "targetRegDotColor ArchRISCV64"
-      ArchJavaScript-> panic "targetRegDotColor ArchJavaScript"
-      ArchWasm32    -> panic "targetRegDotColor ArchWasm32"
-      ArchUnknown   -> panic "targetRegDotColor ArchUnknown"
-
-
-targetClassOfReg :: Platform -> Reg -> RegClass
-targetClassOfReg platform reg
- = case reg of
-   RegVirtual vr -> classOfVirtualReg vr
-   RegReal rr -> targetClassOfRealReg platform rr
diff --git a/compiler/GHC/CmmToAsm/Reg/Utils.hs b/compiler/GHC/CmmToAsm/Reg/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Reg/Utils.hs
+++ /dev/null
@@ -1,58 +0,0 @@
-module GHC.CmmToAsm.Reg.Utils
-    ( toRegMap, toVRegMap )
-where
-
-{- Note [UniqFM and the register allocator]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-   Before UniqFM had a key type the register allocator
-   wasn't picky about key types, using VirtualReg, Reg
-   and Unique at various use sites for the same map.
-
-   This is safe.
-   * The Unique values come from registers at various
-     points where we lose a reference to the original
-     register value, but the unique is still valid.
-
-   * VirtualReg is a subset of the registers in Reg's type.
-     Making a value of VirtualReg into a Reg in fact doesn't
-     change its unique. This is because Reg consists of virtual
-     regs and real regs, whose unique values do not overlap.
-
-   * Since the code was written in the assumption that keys are
-     not typed it's hard to reverse this assumption now. So we get
-     some gnarly but correct code where we often pass around Uniques
-     and switch between using Uniques, VirtualReg and RealReg as keys
-     of the same map. These issues were always there. But with the
-     now-typed keys they become visible. It's a classic case of not all
-     correct programs type checking.
-
-   We reduce some of the burden by providing a way to cast
-
-        UniqFM VirtualReg a
-
-   to
-
-        UniqFM Reg a
-
-    in this module. This is safe as Reg is the sum of VirtualReg and
-    RealReg. With each kind of register keeping the same unique when
-    treated as Reg.
-
-   TODO: If you take offense to this I encourage you to refactor this
-   code. I'm sure we can do with less casting of keys and direct use
-   of uniques. It might also be reasonable to just use a IntMap directly
-   instead of dealing with UniqFM at all.
-
-
--}
-import GHC.Types.Unique.FM
-import GHC.Platform.Reg
-
--- These should hopefully be zero cost.
-
-toRegMap :: UniqFM VirtualReg elt -> UniqFM Reg elt
-toRegMap = unsafeCastUFMKey
-
-toVRegMap :: UniqFM Reg elt -> UniqFM VirtualReg elt
-toVRegMap = unsafeCastUFMKey
-
diff --git a/compiler/GHC/CmmToAsm/Types.hs b/compiler/GHC/CmmToAsm/Types.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Types.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-module GHC.CmmToAsm.Types
-   ( NatCmm
-   , NatCmmDecl
-   , NatBasicBlock
-   , GenBasicBlock(..)
-   , blockId
-   , ListGraph(..)
-   , RawCmmStatics
-   , RawCmmDecl
-   )
-where
-
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm
-
-
--- Our flavours of the Cmm types
--- Type synonyms for Cmm populated with native code
-type NatCmm instr
-        = GenCmmGroup
-                RawCmmStatics
-                (LabelMap RawCmmStatics)
-                (ListGraph instr)
-
-type NatCmmDecl statics instr
-        = GenCmmDecl
-                statics
-                (LabelMap RawCmmStatics)
-                (ListGraph instr)
-
-type NatBasicBlock instr
-        = GenBasicBlock instr
diff --git a/compiler/GHC/CmmToAsm/Utils.hs b/compiler/GHC/CmmToAsm/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Utils.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-module GHC.CmmToAsm.Utils
-   ( topInfoTable
-   , entryBlocks
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm hiding (topInfoTable)
-
--- | Returns the info table associated with the CmmDecl's entry point,
--- if any.
-topInfoTable :: GenCmmDecl a (LabelMap i) (ListGraph b) -> Maybe i
-topInfoTable (CmmProc infos _ _ (ListGraph (b:_)))
-  = mapLookup (blockId b) infos
-topInfoTable _
-  = Nothing
-
--- | Return the list of BlockIds in a CmmDecl that are entry points
--- for this proc (i.e. they may be jumped to from outside this proc).
-entryBlocks :: GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId]
-entryBlocks (CmmProc info _ _ (ListGraph code)) = entries
-  where
-        infos = mapKeys info
-        entries = case code of
-                    [] -> infos
-                    BasicBlock entry _ : _ -- first block is the entry point
-                       | entry `elem` infos -> infos
-                       | otherwise          -> entry : infos
-entryBlocks _ = []
diff --git a/compiler/GHC/CmmToAsm/Wasm.hs b/compiler/GHC/CmmToAsm/Wasm.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Wasm.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Strict #-}
-
-module GHC.CmmToAsm.Wasm (ncgWasm) where
-
-import Data.ByteString.Builder
-import Data.Maybe
-import Data.Semigroup
-import GHC.Cmm
-import GHC.CmmToAsm.Wasm.Asm
-import GHC.CmmToAsm.Wasm.FromCmm
-import GHC.CmmToAsm.Wasm.Types
-import GHC.Data.Stream (Stream, StreamS (..), runStream)
-import GHC.Platform
-import GHC.Prelude
-import GHC.Types.Unique.Supply
-import GHC.Unit
-import System.IO
-
-ncgWasm ::
-  Platform ->
-  UniqSupply ->
-  ModLocation ->
-  Handle ->
-  Stream IO RawCmmGroup a ->
-  IO a
-ncgWasm platform us loc h cmms = do
-  (r, s) <- streamCmmGroups platform us cmms
-  hPutBuilder h $ "# " <> string7 (fromJust $ ml_hs_file loc) <> "\n\n"
-  hPutBuilder h $ execWasmAsmM $ asmTellEverything TagI32 s
-  pure r
-
-streamCmmGroups ::
-  Platform ->
-  UniqSupply ->
-  Stream IO RawCmmGroup a ->
-  IO (a, WasmCodeGenState 'I32)
-streamCmmGroups platform us cmms =
-  go (initialWasmCodeGenState platform us) $
-    runStream cmms
-  where
-    go s (Done r) = pure (r, s)
-    go s (Effect m) = m >>= go s
-    go s (Yield cmm k) = go (wasmExecM (onCmmGroup cmm) s) k
diff --git a/compiler/GHC/CmmToAsm/Wasm/Asm.hs b/compiler/GHC/CmmToAsm/Wasm/Asm.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Wasm/Asm.hs
+++ /dev/null
@@ -1,511 +0,0 @@
-{-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE Strict #-}
-
-module GHC.CmmToAsm.Wasm.Asm (asmTellEverything, execWasmAsmM) where
-
-import Control.Monad
-import Control.Monad.Trans.Reader
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
-import Data.ByteString.Builder
-import Data.Coerce
-import Data.Foldable
-import qualified Data.IntSet as IS
-import Data.Maybe
-import Data.Semigroup
-import GHC.Cmm
-import GHC.CmmToAsm.Ppr
-import GHC.CmmToAsm.Wasm.FromCmm
-import GHC.CmmToAsm.Wasm.Types
-import GHC.CmmToAsm.Wasm.Utils
-import GHC.Data.FastString
-import GHC.Float
-import GHC.Prelude
-import GHC.Types.Basic
-import GHC.Types.Unique
-import GHC.Types.Unique.Map
-import GHC.Utils.Monad.State.Strict
-import GHC.Utils.Outputable hiding ((<>))
-import GHC.Utils.Panic (panic)
-
--- | Reads current indentation, appends result to state
-newtype WasmAsmM a = WasmAsmM (Builder -> State Builder a)
-  deriving
-    ( Functor,
-      Applicative,
-      Monad
-    )
-    via (ReaderT Builder (State Builder))
-
-instance Semigroup a => Semigroup (WasmAsmM a) where
-  (<>) = liftA2 (<>)
-
-instance Monoid a => Monoid (WasmAsmM a) where
-  mempty = pure mempty
-
--- | Default indent level is none
-execWasmAsmM :: WasmAsmM a -> Builder
-execWasmAsmM (WasmAsmM m) = execState (m mempty) mempty
-
--- | Increase indent level by a tab
-asmWithTab :: WasmAsmM a -> WasmAsmM a
-asmWithTab (WasmAsmM m) = WasmAsmM $ \t -> m $! char7 '\t' <> t
-
--- | Writes a single line starting with the current indent
-asmTellLine :: Builder -> WasmAsmM ()
-asmTellLine b = WasmAsmM $ \t -> modify $ \acc -> acc <> t <> b <> char7 '\n'
-
--- | Writes a single line break
-asmTellLF :: WasmAsmM ()
-asmTellLF = WasmAsmM $ \_ -> modify $ \acc -> acc <> char7 '\n'
-
--- | Writes a line starting with a single tab, ignoring current indent
--- level
-asmTellTabLine :: Builder -> WasmAsmM ()
-asmTellTabLine b =
-  WasmAsmM $ \_ -> modify $ \acc -> acc <> char7 '\t' <> b <> char7 '\n'
-
-asmFromWasmType :: WasmTypeTag t -> Builder
-asmFromWasmType ty = case ty of
-  TagI32 -> "i32"
-  TagI64 -> "i64"
-  TagF32 -> "f32"
-  TagF64 -> "f64"
-
-asmFromSomeWasmType :: SomeWasmType -> Builder
-asmFromSomeWasmType (SomeWasmType t) = asmFromWasmType t
-
-asmFromSomeWasmTypes :: [SomeWasmType] -> Builder
-asmFromSomeWasmTypes ts = "(" <> builderCommas asmFromSomeWasmType ts <> ")"
-
-asmFromFuncType :: [SomeWasmType] -> [SomeWasmType] -> Builder
-asmFromFuncType arg_tys ret_tys =
-  asmFromSomeWasmTypes arg_tys <> " -> " <> asmFromSomeWasmTypes ret_tys
-
-asmTellFuncType ::
-  SymName -> ([SomeWasmType], [SomeWasmType]) -> WasmAsmM ()
-asmTellFuncType sym (arg_tys, ret_tys) =
-  asmTellTabLine $
-    ".functype "
-      <> asmFromSymName sym
-      <> " "
-      <> asmFromFuncType arg_tys ret_tys
-
-asmTellLocals :: [SomeWasmType] -> WasmAsmM ()
-asmTellLocals [] = mempty
-asmTellLocals local_tys =
-  asmTellTabLine $ ".local " <> builderCommas asmFromSomeWasmType local_tys
-
-asmFromSymName :: SymName -> Builder
-asmFromSymName = shortByteString . coerce fastStringToShortByteString
-
-asmTellDefSym :: SymName -> WasmAsmM ()
-asmTellDefSym sym = do
-  asmTellTabLine $ ".hidden " <> asm_sym
-  asmTellTabLine $ ".globl " <> asm_sym
-  where
-    asm_sym = asmFromSymName sym
-
-asmTellDataSectionContent :: WasmTypeTag w -> DataSectionContent -> WasmAsmM ()
-asmTellDataSectionContent ty_word c = asmTellTabLine $ case c of
-  DataI8 i -> ".int8 " <> integerDec i
-  DataI16 i -> ".int16 " <> integerDec i
-  DataI32 i -> ".int32 " <> integerDec i
-  DataI64 i -> ".int64 " <> integerDec i
-  DataF32 f -> ".int32 0x" <> word32Hex (castFloatToWord32 f)
-  DataF64 d -> ".int64 0x" <> word64Hex (castDoubleToWord64 d)
-  DataSym sym o ->
-    ( case ty_word of
-        TagI32 -> ".int32 "
-        TagI64 -> ".int64 "
-        _ -> panic "asmTellDataSectionContent: unreachable"
-    )
-      <> asmFromSymName sym
-      <> ( case compare o 0 of
-             EQ -> mempty
-             GT -> "+" <> intDec o
-             LT -> intDec o
-         )
-  DataSkip i -> ".skip " <> intDec i
-  DataASCII s
-    | not (BS.null s) && BS.last s == 0 ->
-        ".asciz \""
-          <> string7
-            (showSDocOneLine defaultSDocContext $ pprASCII $ BS.init s)
-          <> "\""
-    | otherwise ->
-        ".ascii \""
-          <> string7
-            (showSDocOneLine defaultSDocContext $ pprASCII s)
-          <> "\""
-  DataIncBin f _ ->
-    ".incbin "
-      <> string7
-        (showSDocOneLine defaultSDocContext $ pprFilePathString f)
-
-dataSectionContentSize :: WasmTypeTag w -> DataSectionContent -> Int
-dataSectionContentSize ty_word c = case c of
-  DataI8 {} -> 1
-  DataI16 {} -> 2
-  DataI32 {} -> 4
-  DataI64 {} -> 8
-  DataF32 {} -> 4
-  DataF64 {} -> 8
-  DataSym {} -> alignmentBytes $ alignmentFromWordType ty_word
-  DataSkip i -> i
-  DataASCII s -> BS.length s
-  DataIncBin _ l -> l
-
-dataSectionSize :: WasmTypeTag w -> [DataSectionContent] -> Int
-dataSectionSize ty_word =
-  coerce
-    . foldMap'
-      (Sum . dataSectionContentSize ty_word)
-
-asmTellAlign :: Alignment -> WasmAsmM ()
-asmTellAlign a = case alignmentBytes a of
-  1 -> mempty
-  i -> asmTellTabLine $ ".p2align " <> intDec (countTrailingZeros i)
-
-asmTellSectionHeader :: Builder -> WasmAsmM ()
-asmTellSectionHeader k = asmTellTabLine $ ".section " <> k <> ",\"\",@"
-
-asmTellDataSection ::
-  WasmTypeTag w -> IS.IntSet -> SymName -> DataSection -> WasmAsmM ()
-asmTellDataSection ty_word def_syms sym DataSection {..} = do
-  when (getKey (getUnique sym) `IS.member` def_syms) $ asmTellDefSym sym
-  asmTellSectionHeader sec_name
-  asmTellAlign dataSectionAlignment
-  asmTellTabLine asm_size
-  asmTellLine $ asm_sym <> ":"
-  for_ dataSectionContents $ asmTellDataSectionContent ty_word
-  asmTellLF
-  where
-    asm_sym = asmFromSymName sym
-
-    sec_name =
-      ( case dataSectionKind of
-          SectionData -> ".data."
-          SectionROData -> ".rodata."
-      )
-        <> asm_sym
-
-    asm_size =
-      ".size "
-        <> asm_sym
-        <> ", "
-        <> intDec
-          (dataSectionSize ty_word dataSectionContents)
-
-asmFromWasmBlockType :: WasmTypeTag w -> WasmFunctionType pre post -> Builder
-asmFromWasmBlockType
-  _
-  (WasmFunctionType {ft_pops = TypeListNil, ft_pushes = TypeListNil}) =
-    mempty
-asmFromWasmBlockType
-  TagI32
-  ( WasmFunctionType
-      { ft_pops = TypeListNil,
-        ft_pushes = TypeListCons TagI32 TypeListNil
-      }
-    ) =
-    " i32"
-asmFromWasmBlockType
-  TagI64
-  ( WasmFunctionType
-      { ft_pops = TypeListNil,
-        ft_pushes = TypeListCons TagI64 TypeListNil
-      }
-    ) =
-    " i64"
-asmFromWasmBlockType _ _ = panic "asmFromWasmBlockType: invalid block type"
-
-asmFromAlignmentSpec :: AlignmentSpec -> Builder
-asmFromAlignmentSpec NaturallyAligned = mempty
-asmFromAlignmentSpec Unaligned = ":p2align=0"
-
-asmTellWasmInstr :: WasmTypeTag w -> WasmInstr w pre post -> WasmAsmM ()
-asmTellWasmInstr ty_word instr = case instr of
-  WasmComment c -> asmTellLine $ stringUtf8 $ "# " <> c
-  WasmNop -> mempty
-  WasmDrop -> asmTellLine "drop"
-  WasmUnreachable -> asmTellLine "unreachable"
-  WasmConst TagI32 i -> asmTellLine $ "i32.const " <> integerDec i
-  WasmConst TagI64 i -> asmTellLine $ "i64.const " <> integerDec i
-  WasmConst {} -> panic "asmTellWasmInstr: unreachable"
-  WasmSymConst sym ->
-    asmTellLine $
-      ( case ty_word of
-          TagI32 -> "i32.const "
-          TagI64 -> "i64.const "
-          _ -> panic "asmTellWasmInstr: unreachable"
-      )
-        <> asmFromSymName sym
-  WasmLoad ty (Just w) s o align ->
-    asmTellLine $
-      asmFromWasmType ty
-        <> ".load"
-        <> intDec w
-        <> ( case s of
-               Signed -> "_s"
-               Unsigned -> "_u"
-           )
-        <> " "
-        <> intDec o
-        <> asmFromAlignmentSpec align
-  WasmLoad ty Nothing _ o align ->
-    asmTellLine $
-      asmFromWasmType ty
-        <> ".load"
-        <> " "
-        <> intDec o
-        <> asmFromAlignmentSpec align
-  WasmStore ty (Just w) o align ->
-    asmTellLine $
-      asmFromWasmType ty
-        <> ".store"
-        <> intDec w
-        <> " "
-        <> intDec o
-        <> asmFromAlignmentSpec align
-  WasmStore ty Nothing o align ->
-    asmTellLine $
-      asmFromWasmType ty
-        <> ".store"
-        <> " "
-        <> intDec o
-        <> asmFromAlignmentSpec align
-  WasmGlobalGet _ sym -> asmTellLine $ "global.get " <> asmFromSymName sym
-  WasmGlobalSet _ sym -> asmTellLine $ "global.set " <> asmFromSymName sym
-  WasmLocalGet _ i -> asmTellLine $ "local.get " <> intDec i
-  WasmLocalSet _ i -> asmTellLine $ "local.set " <> intDec i
-  WasmLocalTee _ i -> asmTellLine $ "local.tee " <> intDec i
-  WasmCCall sym -> asmTellLine $ "call " <> asmFromSymName sym
-  WasmCCallIndirect arg_tys ret_tys ->
-    asmTellLine $
-      "call_indirect "
-        <> asmFromFuncType
-          (someWasmTypesFromTypeList arg_tys)
-          (someWasmTypesFromTypeList ret_tys)
-  WasmConcat instr0 instr1 -> do
-    asmTellWasmInstr ty_word instr0
-    asmTellWasmInstr ty_word instr1
-  WasmReinterpret t0 t1 ->
-    asmTellLine $
-      asmFromWasmType t1 <> ".reinterpret_" <> asmFromWasmType t0
-  WasmTruncSat Signed t0 t1 ->
-    asmTellLine $
-      asmFromWasmType t1 <> ".trunc_sat_" <> asmFromWasmType t0 <> "_s"
-  WasmTruncSat Unsigned t0 t1 ->
-    asmTellLine $
-      asmFromWasmType t1 <> ".trunc_sat_" <> asmFromWasmType t0 <> "_u"
-  WasmConvert Signed t0 t1 ->
-    asmTellLine $
-      asmFromWasmType t1 <> ".convert_" <> asmFromWasmType t0 <> "_s"
-  WasmConvert Unsigned t0 t1 ->
-    asmTellLine $
-      asmFromWasmType t1 <> ".convert_" <> asmFromWasmType t0 <> "_u"
-  WasmAdd ty -> asmTellLine $ asmFromWasmType ty <> ".add"
-  WasmSub ty -> asmTellLine $ asmFromWasmType ty <> ".sub"
-  WasmMul ty -> asmTellLine $ asmFromWasmType ty <> ".mul"
-  WasmDiv _ TagF32 -> asmTellLine "f32.div"
-  WasmDiv _ TagF64 -> asmTellLine "f64.div"
-  WasmDiv Signed ty -> asmTellLine $ asmFromWasmType ty <> ".div_s"
-  WasmDiv Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".div_u"
-  WasmRem Signed ty -> asmTellLine $ asmFromWasmType ty <> ".rem_s"
-  WasmRem Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".rem_u"
-  WasmAnd ty -> asmTellLine $ asmFromWasmType ty <> ".and"
-  WasmOr ty -> asmTellLine $ asmFromWasmType ty <> ".or"
-  WasmXor ty -> asmTellLine $ asmFromWasmType ty <> ".xor"
-  WasmEq ty -> asmTellLine $ asmFromWasmType ty <> ".eq"
-  WasmNe ty -> asmTellLine $ asmFromWasmType ty <> ".ne"
-  WasmLt _ TagF32 -> asmTellLine "f32.lt"
-  WasmLt _ TagF64 -> asmTellLine "f64.lt"
-  WasmLt Signed ty -> asmTellLine $ asmFromWasmType ty <> ".lt_s"
-  WasmLt Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".lt_u"
-  WasmGt _ TagF32 -> asmTellLine "f32.gt"
-  WasmGt _ TagF64 -> asmTellLine "f64.gt"
-  WasmGt Signed ty -> asmTellLine $ asmFromWasmType ty <> ".gt_s"
-  WasmGt Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".gt_u"
-  WasmLe _ TagF32 -> asmTellLine "f32.le"
-  WasmLe _ TagF64 -> asmTellLine "f64.le"
-  WasmLe Signed ty -> asmTellLine $ asmFromWasmType ty <> ".le_s"
-  WasmLe Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".le_u"
-  WasmGe _ TagF32 -> asmTellLine "f32.ge"
-  WasmGe _ TagF64 -> asmTellLine "f64.ge"
-  WasmGe Signed ty -> asmTellLine $ asmFromWasmType ty <> ".ge_s"
-  WasmGe Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".ge_u"
-  WasmShl ty -> asmTellLine $ asmFromWasmType ty <> ".shl"
-  WasmShr Signed ty -> asmTellLine $ asmFromWasmType ty <> ".shr_s"
-  WasmShr Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".shr_u"
-  WasmI32Extend8S -> asmTellLine "i32.extend8_s"
-  WasmI32Extend16S -> asmTellLine "i32.extend16_s"
-  WasmI64Extend8S -> asmTellLine "i64.extend8_s"
-  WasmI64Extend16S -> asmTellLine "i64.extend16_s"
-  WasmI64Extend32S -> asmTellLine "i64.extend32_s"
-  WasmI64ExtendI32 Signed -> asmTellLine "i64.extend_i32_s"
-  WasmI64ExtendI32 Unsigned -> asmTellLine "i64.extend_i32_u"
-  WasmI32WrapI64 -> asmTellLine "i32.wrap_i64"
-  WasmF32DemoteF64 -> asmTellLine "f32.demote_f64"
-  WasmF64PromoteF32 -> asmTellLine "f64.promote_f32"
-  WasmAbs ty -> asmTellLine $ asmFromWasmType ty <> ".abs"
-  WasmCond t -> do
-    asmTellLine "if"
-    asmWithTab $ asmTellWasmInstr ty_word t
-    asmTellLine "end_if"
-
-asmTellWasmControl ::
-  WasmTypeTag w ->
-  WasmControl
-    (WasmStatements w)
-    (WasmExpr w a)
-    pre
-    post ->
-  WasmAsmM ()
-asmTellWasmControl ty_word c = case c of
-  WasmPush _ (WasmExpr e) -> asmTellWasmInstr ty_word e
-  WasmBlock bt c -> do
-    asmTellLine $ "block" <> asmFromWasmBlockType ty_word bt
-    asmWithTab $ asmTellWasmControl ty_word c
-    asmTellLine "end_block"
-  WasmLoop bt c -> do
-    asmTellLine $ "loop" <> asmFromWasmBlockType ty_word bt
-    asmWithTab $ asmTellWasmControl ty_word c
-    -- asmTellLine "br 0"
-    asmTellLine "end_loop"
-  WasmIfTop bt t f -> do
-    asmTellLine $ "if" <> asmFromWasmBlockType ty_word bt
-    asmWithTab $ asmTellWasmControl ty_word t
-    asmTellLine "else"
-    asmWithTab $ asmTellWasmControl ty_word f
-    asmTellLine "end_if"
-  WasmBr i -> asmTellLine $ "br " <> intDec i
-  WasmFallthrough -> mempty
-  WasmBrTable (WasmExpr e) _ ts t -> do
-    asmTellWasmInstr ty_word e
-    asmTellLine $ "br_table {" <> builderCommas intDec (ts <> [t]) <> "}"
-  WasmReturnTop _ -> asmTellLine "return"
-  WasmActions (WasmStatements a) -> asmTellWasmInstr ty_word a
-  WasmSeq c0 c1 -> do
-    asmTellWasmControl ty_word c0
-    asmTellWasmControl ty_word c1
-
-asmTellFunc ::
-  WasmTypeTag w ->
-  IS.IntSet ->
-  SymName ->
-  (([SomeWasmType], [SomeWasmType]), FuncBody w) ->
-  WasmAsmM ()
-asmTellFunc ty_word def_syms sym (func_ty, FuncBody {..}) = do
-  when (getKey (getUnique sym) `IS.member` def_syms) $ asmTellDefSym sym
-  asmTellSectionHeader $ ".text." <> asm_sym
-  asmTellLine $ asm_sym <> ":"
-  asmTellFuncType sym func_ty
-  asmTellLocals funcLocals
-  asmWithTab $ asmTellWasmControl ty_word funcBody
-  asmTellTabLine "end_function"
-  asmTellLF
-  where
-    asm_sym = asmFromSymName sym
-
-asmTellGlobals :: WasmTypeTag w -> WasmAsmM ()
-asmTellGlobals ty_word = do
-  for_ supportedCmmGlobalRegs $ \reg ->
-    let (sym, ty) = fromJust $ globalInfoFromCmmGlobalReg ty_word reg
-     in asmTellTabLine $
-          ".globaltype "
-            <> asmFromSymName sym
-            <> ", "
-            <> asmFromSomeWasmType ty
-  asmTellLF
-
-asmTellCtors :: WasmTypeTag w -> [SymName] -> WasmAsmM ()
-asmTellCtors _ [] = mempty
-asmTellCtors ty_word syms = do
-  asmTellSectionHeader ".init_array"
-  asmTellAlign $ alignmentFromWordType ty_word
-  for_ syms $ \sym ->
-    asmTellTabLine $
-      ( case ty_word of
-          TagI32 -> ".int32 "
-          TagI64 -> ".int64 "
-          _ -> panic "asmTellCtors: unreachable"
-      )
-        <> asmFromSymName sym
-  asmTellLF
-
-asmTellBS :: ByteString -> WasmAsmM ()
-asmTellBS s = do
-  asmTellTabLine $ ".int8 " <> intDec (BS.length s)
-  asmTellTabLine $
-    ".ascii \""
-      <> string7
-        (showSDocOneLine defaultSDocContext $ pprASCII s)
-      <> "\""
-
-asmTellVec :: [WasmAsmM ()] -> WasmAsmM ()
-asmTellVec xs = do
-  asmTellTabLine $ ".int8 " <> intDec (length xs)
-  sequence_ xs
-
-asmTellProducers :: WasmAsmM ()
-asmTellProducers = do
-  asmTellSectionHeader ".custom_section.producers"
-  asmTellVec
-    [ do
-        asmTellBS "processed-by"
-        asmTellVec
-          [ do
-              asmTellBS "ghc"
-              asmTellBS "9.6"
-          ]
-    ]
-
-asmTellTargetFeatures :: WasmAsmM ()
-asmTellTargetFeatures = do
-  asmTellSectionHeader ".custom_section.target_features"
-  asmTellVec
-    [ do
-        asmTellTabLine ".int8 0x2b"
-        asmTellBS feature
-      | feature <-
-          [ "bulk-memory",
-            "mutable-globals",
-            "nontrapping-fptoint",
-            "reference-types",
-            "sign-ext"
-          ]
-    ]
-
-asmTellEverything :: WasmTypeTag w -> WasmCodeGenState w -> WasmAsmM ()
-asmTellEverything ty_word WasmCodeGenState {..} = do
-  asmTellGlobals ty_word
-  asm_functypes
-  asm_funcs
-  asm_data_secs
-  asm_ctors
-  asmTellProducers
-  asmTellTargetFeatures
-  where
-    asm_functypes = do
-      for_
-        (detEltsUniqMap $ funcTypes `minusUniqMap` funcBodies)
-        (uncurry asmTellFuncType)
-      asmTellLF
-
-    asm_funcs = do
-      for_
-        (detEltsUniqMap $ intersectUniqMap_C (,) funcTypes funcBodies)
-        (uncurry $ asmTellFunc ty_word defaultSyms)
-      asmTellLF
-
-    asm_data_secs = do
-      for_
-        (detEltsUniqMap dataSections)
-        (uncurry (asmTellDataSection ty_word defaultSyms))
-      asmTellLF
-
-    asm_ctors = asmTellCtors ty_word ctors
diff --git a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs
+++ /dev/null
@@ -1,1677 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE Strict #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UnboxedTuples #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
-
-{-# HLINT ignore "Use camelCase" #-}
-module GHC.CmmToAsm.Wasm.FromCmm where
-
-import Control.Monad
-import qualified Data.ByteString as BS
-import Data.Foldable
-import Data.Functor
-import qualified Data.IntSet as IS
-import Data.Semigroup
-import Data.String
-import Data.Traversable
-import Data.Type.Equality
-import GHC.Cmm
-import GHC.Cmm.CLabel
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.InitFini
-import GHC.CmmToAsm.Wasm.Types
-import GHC.CmmToAsm.Wasm.Utils
-import GHC.Float
-import GHC.Platform
-import GHC.Prelude
-import GHC.StgToCmm.CgUtils
-import GHC.Types.Basic
-import GHC.Types.ForeignCall
-import GHC.Types.Unique
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Map
-import GHC.Utils.Outputable hiding ((<>))
-import GHC.Utils.Panic
-import GHC.Wasm.ControlFlow.FromCmm
-
--- | Calculate the wasm representation type from a 'CmmType'. This is
--- a lossy conversion, and sometimes we need to pass the original
--- 'CmmType' or at least its 'Width' around, so to properly add
--- subword truncation or extension logic.
-someWasmTypeFromCmmType :: CmmType -> SomeWasmType
-someWasmTypeFromCmmType t
-  | isWord32 t = SomeWasmType TagI32
-  | isWord64 t = SomeWasmType TagI64
-  | t `cmmEqType` b16 = SomeWasmType TagI32
-  | t `cmmEqType` b8 = SomeWasmType TagI32
-  | isFloat64 t = SomeWasmType TagF64
-  | isFloat32 t = SomeWasmType TagF32
-  | otherwise =
-      panic $
-        "someWasmTypeFromCmmType: unsupported CmmType "
-          <> showSDocOneLine defaultSDocContext (ppr t)
-
--- | Calculate the optional memory narrowing of a 'CmmLoad' or
--- 'CmmStore'.
-wasmMemoryNarrowing :: WasmTypeTag t -> CmmType -> Maybe Int
-wasmMemoryNarrowing ty ty_cmm = case (# ty, typeWidth ty_cmm #) of
-  (# TagI32, W8 #) -> Just 8
-  (# TagI32, W16 #) -> Just 16
-  (# TagI32, W32 #) -> Nothing
-  (# TagI64, W8 #) -> Just 8
-  (# TagI64, W16 #) -> Just 16
-  (# TagI64, W32 #) -> Just 32
-  (# TagI64, W64 #) -> Nothing
-  (# TagF32, W32 #) -> Nothing
-  (# TagF64, W64 #) -> Nothing
-  _ -> panic "wasmMemoryNarrowing: unreachable"
-
--- | Despite this is used by the WebAssembly native codegen, we use
--- 'pprCLabel' instead of 'pprAsmLabel' when emitting the textual
--- symbol name. Either one would work, but 'pprCLabel' makes the
--- output assembly code looks closer to the unregisterised codegen
--- output, which can be handy when using the unregisterised codegen as
--- a source of truth when debugging the native codegen.
-symNameFromCLabel :: CLabel -> SymName
-symNameFromCLabel lbl =
-  fromString $
-    showSDocOneLine defaultSDocContext {sdocStyle = PprCode} $
-      pprCLabel genericPlatform lbl
-
--- | Calculate a symbol's visibility.
-symVisibilityFromCLabel :: CLabel -> SymVisibility
-symVisibilityFromCLabel lbl
-  | externallyVisibleCLabel lbl = SymDefault
-  | otherwise = SymStatic
-
--- | Calculate a symbol's kind, see haddock docs of 'SymKind' for more
--- explanation.
-symKindFromCLabel :: CLabel -> SymKind
-symKindFromCLabel lbl
-  | isCFunctionLabel lbl = SymFunc
-  | otherwise = SymData
-
--- | Calculate a data section's kind, see haddock docs of
--- 'DataSectionKind' for more explanation.
-dataSectionKindFromCmmSection :: Section -> DataSectionKind
-dataSectionKindFromCmmSection s = case sectionProtection s of
-  ReadWriteSection -> SectionData
-  _ -> SectionROData
-
--- | Calculate the natural alignment size given the platform word
--- type.
-alignmentFromWordType :: WasmTypeTag w -> Alignment
-alignmentFromWordType TagI32 = mkAlignment 4
-alignmentFromWordType TagI64 = mkAlignment 8
-alignmentFromWordType _ = panic "alignmentFromWordType: unreachable"
-
--- | Calculate a data section's alignment. Closures needs to be
--- naturally aligned; info tables need to align to 2, so to get 1 tag
--- bit as forwarding pointer marker. The rest have no alignment
--- requirements.
-alignmentFromCmmSection :: WasmTypeTag w -> CLabel -> Alignment
-alignmentFromCmmSection t lbl
-  | isStaticClosureLabel lbl = alignmentFromWordType t
-  | isInfoTableLabel lbl = mkAlignment 2
-  | otherwise = mkAlignment 1
-
--- | Lower a 'CmmStatic'.
-lower_CmmStatic :: CmmStatic -> WasmCodeGenM w DataSectionContent
-lower_CmmStatic s = case s of
-  CmmStaticLit (CmmInt i W8) -> pure $ DataI8 $ naturalNarrowing W8 i
-  CmmStaticLit (CmmInt i W16) -> pure $ DataI16 $ naturalNarrowing W16 i
-  CmmStaticLit (CmmInt i W32) -> pure $ DataI32 $ naturalNarrowing W32 i
-  CmmStaticLit (CmmInt i W64) -> pure $ DataI64 $ naturalNarrowing W64 i
-  CmmStaticLit (CmmFloat f W32) -> pure $ DataF32 $ fromRational f
-  CmmStaticLit (CmmFloat d W64) -> pure $ DataF64 $ fromRational d
-  CmmStaticLit (CmmLabel lbl) ->
-    onAnySym lbl
-      $> DataSym
-        (symNameFromCLabel lbl)
-        0
-  CmmStaticLit (CmmLabelOff lbl o) ->
-    onAnySym lbl
-      $> DataSym
-        (symNameFromCLabel lbl)
-        o
-  CmmUninitialised i -> pure $ DataSkip i
-  CmmString b -> pure $ DataASCII b
-  CmmFileEmbed f l -> pure $ DataIncBin f l
-  _ -> panic "lower_CmmStatic: unreachable"
-
-{-
-Note [Register mapping on WebAssembly]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Unlike typical ISAs, WebAssembly doesn't expose a fixed set of
-registers. For now, we map each Cmm LocalReg to a wasm local, and each
-Cmm GlobalReg to a wasm global. The wasm globals are defined in
-rts/wasm/Wasm.S, and must be kept in sync with
-'globalInfoFromCmmGlobalReg' and 'supportedCmmGlobalRegs' here.
-
-There are some other Cmm GlobalRegs which are still represented by
-StgRegTable fields instead of wasm globals (e.g. HpAlloc). It's cheap
-to add wasm globals, but other parts of rts logic only work with the
-StgRegTable fields, so we also need to instrument StgRun/StgReturn to
-sync the wasm globals with the StgRegTable. It's not really worth the
-trouble.
-
--}
-globalInfoFromCmmGlobalReg :: WasmTypeTag w -> GlobalReg -> Maybe GlobalInfo
-globalInfoFromCmmGlobalReg t reg = case reg of
-  VanillaReg i _
-    | i >= 1 && i <= 10 -> Just (fromString $ "__R" <> show i, ty_word)
-  FloatReg i
-    | i >= 1 && i <= 6 ->
-        Just (fromString $ "__F" <> show i, SomeWasmType TagF32)
-  DoubleReg i
-    | i >= 1 && i <= 6 ->
-        Just (fromString $ "__D" <> show i, SomeWasmType TagF64)
-  LongReg i
-    | i == 1 -> Just (fromString $ "__L" <> show i, SomeWasmType TagI64)
-  Sp -> Just ("__Sp", ty_word)
-  SpLim -> Just ("__SpLim", ty_word)
-  Hp -> Just ("__Hp", ty_word)
-  HpLim -> Just ("__HpLim", ty_word)
-  CCCS -> Just ("__CCCS", ty_word)
-  _ -> Nothing
-  where
-    ty_word = SomeWasmType t
-
-supportedCmmGlobalRegs :: [GlobalReg]
-supportedCmmGlobalRegs =
-  [VanillaReg i VGcPtr | i <- [1 .. 10]]
-    <> [FloatReg i | i <- [1 .. 6]]
-    <> [DoubleReg i | i <- [1 .. 6]]
-    <> [LongReg i | i <- [1 .. 1]]
-    <> [Sp, SpLim, Hp, HpLim, CCCS]
-
--- | Allocate a fresh symbol for an internal data section.
-allocDataSection :: DataSection -> WasmCodeGenM w SymName
-allocDataSection sec = do
-  u <- wasmUniq
-  let sym = fromString $ ".L" <> show u
-  wasmModifyM $ \s ->
-    s
-      { dataSections =
-          addToUniqMap (dataSections s) sym sec
-      }
-  pure sym
-
--- | Print a debug message to stderr by calling @fputs()@. We don't
--- bother to check @fputs()@ return value.
-wasmDebugMsg :: String -> WasmCodeGenM w (WasmStatements w)
-wasmDebugMsg msg = do
-  ty_word_cmm <- wasmWordCmmTypeM
-  sym_buf <-
-    allocDataSection
-      DataSection
-        { dataSectionKind =
-            SectionROData,
-          dataSectionAlignment =
-            mkAlignment 1,
-          dataSectionContents =
-            [DataASCII $ fromString $ msg <> "\NUL"]
-        }
-  onFuncSym "fputs" [ty_word_cmm, ty_word_cmm] [b32]
-  pure $
-    WasmStatements $
-      WasmSymConst sym_buf
-        `WasmConcat` WasmSymConst "__stderr_FILE"
-        `WasmConcat` WasmCCall "fputs"
-        `WasmConcat` WasmDrop
-
--- | Truncate a subword.
-truncSubword :: Width -> WasmTypeTag t -> WasmExpr w t -> WasmExpr w t
-truncSubword W8 ty (WasmExpr instr) =
-  WasmExpr $ instr `WasmConcat` WasmConst ty 0xFF `WasmConcat` WasmAnd ty
-truncSubword W16 ty (WasmExpr instr) =
-  WasmExpr $ instr `WasmConcat` WasmConst ty 0xFFFF `WasmConcat` WasmAnd ty
-truncSubword _ _ expr = expr
-
--- | Sign-extend a subword.
-extendSubword :: Width -> WasmTypeTag t -> WasmExpr w t -> WasmExpr w t
-extendSubword W8 TagI32 (WasmExpr instr) =
-  WasmExpr $ instr `WasmConcat` WasmI32Extend8S
-extendSubword W16 TagI32 (WasmExpr instr) =
-  WasmExpr $ instr `WasmConcat` WasmI32Extend16S
-extendSubword W8 TagI64 (WasmExpr instr) =
-  WasmExpr $ instr `WasmConcat` WasmI64Extend8S
-extendSubword W16 TagI64 (WasmExpr instr) =
-  WasmExpr $ instr `WasmConcat` WasmI64Extend16S
-extendSubword W32 TagI64 (WasmExpr instr) =
-  WasmExpr $ instr `WasmConcat` WasmI64Extend32S
-extendSubword _ _ expr = expr
-
--- | Lower a binary homogeneous operation. Homogeneous: result type is
--- the same with operand types.
-lower_MO_Bin_Homo ::
-  ( forall pre t.
-    WasmTypeTag t ->
-    WasmInstr
-      w
-      (t : t : pre)
-      (t : pre)
-  ) ->
-  CLabel ->
-  CmmType ->
-  [CmmExpr] ->
-  WasmCodeGenM w (SomeWasmExpr w)
-lower_MO_Bin_Homo op lbl t0 [x, y] = case someWasmTypeFromCmmType t0 of
-  SomeWasmType ty -> do
-    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x
-    WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y
-    pure $
-      SomeWasmExpr ty $
-        WasmExpr $
-          x_instr `WasmConcat` y_instr `WasmConcat` op ty
-lower_MO_Bin_Homo _ _ _ _ = panic "lower_MO_Bin_Homo: unreachable"
-
--- | Lower a binary homogeneous operation, and truncate the result if
--- it's a subword.
-lower_MO_Bin_Homo_Trunc ::
-  (forall pre t. WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)) ->
-  CLabel ->
-  Width ->
-  [CmmExpr] ->
-  WasmCodeGenM w (SomeWasmExpr w)
-lower_MO_Bin_Homo_Trunc op lbl w0 [x, y] =
-  case someWasmTypeFromCmmType (cmmBits w0) of
-    SomeWasmType ty -> do
-      WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x
-      WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y
-      pure $
-        SomeWasmExpr ty $
-          truncSubword w0 ty $
-            WasmExpr $
-              x_instr `WasmConcat` y_instr `WasmConcat` op ty
-lower_MO_Bin_Homo_Trunc _ _ _ _ = panic "lower_MO_Bin_Homo_Trunc: unreachable"
-
--- | Lower a binary homogeneous operation, first sign extending the
--- operands, then truncating the result.
-lower_MO_Bin_Homo_Ext_Trunc ::
-  (forall pre t. WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)) ->
-  CLabel ->
-  Width ->
-  [CmmExpr] ->
-  WasmCodeGenM w (SomeWasmExpr w)
-lower_MO_Bin_Homo_Ext_Trunc op lbl w0 [x, y] =
-  case someWasmTypeFromCmmType (cmmBits w0) of
-    SomeWasmType ty -> do
-      WasmExpr x_instr <-
-        extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty x
-      WasmExpr y_instr <-
-        extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty y
-      pure $
-        SomeWasmExpr ty $
-          truncSubword w0 ty $
-            WasmExpr $
-              x_instr `WasmConcat` y_instr `WasmConcat` op ty
-lower_MO_Bin_Homo_Ext_Trunc _ _ _ _ =
-  panic "lower_MO_Bin_Homo_Ext_Trunc: unreachable"
-
--- | Lower a relational binary operation, first sign extending the
--- operands. Relational: result type is a boolean (word type).
-lower_MO_Bin_Rel_Ext ::
-  (forall pre t. WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)) ->
-  CLabel ->
-  Width ->
-  [CmmExpr] ->
-  WasmCodeGenM w (SomeWasmExpr w)
-lower_MO_Bin_Rel_Ext op lbl w0 [x, y] =
-  case someWasmTypeFromCmmType (cmmBits w0) of
-    SomeWasmType ty -> do
-      WasmExpr x_instr <-
-        extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty x
-      WasmExpr y_instr <-
-        extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty y
-      ty_word <- wasmWordTypeM
-      pure $
-        SomeWasmExpr ty_word $
-          WasmExpr $
-            x_instr `WasmConcat` y_instr `WasmConcat` op ty
-lower_MO_Bin_Rel_Ext _ _ _ _ = panic "lower_MO_Bin_Rel_Ext: unreachable"
-
--- | Lower a relational binary operation.
-lower_MO_Bin_Rel ::
-  ( forall pre t.
-    WasmTypeTag t ->
-    WasmInstr
-      w
-      (t : t : pre)
-      (w : pre)
-  ) ->
-  CLabel ->
-  CmmType ->
-  [CmmExpr] ->
-  WasmCodeGenM w (SomeWasmExpr w)
-lower_MO_Bin_Rel op lbl t0 [x, y] = case someWasmTypeFromCmmType t0 of
-  SomeWasmType ty -> do
-    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x
-    WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y
-    ty_word <- wasmWordTypeM
-    pure $
-      SomeWasmExpr ty_word $
-        WasmExpr $
-          x_instr `WasmConcat` y_instr `WasmConcat` op ty
-lower_MO_Bin_Rel _ _ _ _ = panic "lower_MO_Bin_Rel: unreachable"
-
--- | Cast a shiftL/shiftR RHS to the same type as LHS. Because we may
--- have a 64-bit LHS and 32-bit RHS, but wasm shift operators are
--- homogeneous.
-shiftRHSCast ::
-  CLabel ->
-  WasmTypeTag t ->
-  CmmExpr ->
-  WasmCodeGenM
-    w
-    (WasmExpr w t)
-shiftRHSCast lbl t1 x = do
-  SomeWasmExpr t0 (WasmExpr x_instr) <- lower_CmmExpr lbl x
-  if
-      | Just Refl <- t0 `testEquality` t1 -> pure $ WasmExpr x_instr
-      | TagI32 <- t0,
-        TagI64 <- t1 ->
-          pure $ WasmExpr $ x_instr `WasmConcat` WasmI64ExtendI32 Unsigned
-      | otherwise -> panic "shiftRHSCast: unreachable"
-
--- | Lower a 'MO_Shl' operation, truncating the result.
-lower_MO_Shl ::
-  CLabel ->
-  Width ->
-  [CmmExpr] ->
-  WasmCodeGenM
-    w
-    (SomeWasmExpr w)
-lower_MO_Shl lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of
-  SomeWasmType ty -> do
-    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x
-    WasmExpr y_instr <- shiftRHSCast lbl ty y
-    pure $
-      SomeWasmExpr ty $
-        truncSubword w0 ty $
-          WasmExpr $
-            x_instr `WasmConcat` y_instr `WasmConcat` WasmShl ty
-lower_MO_Shl _ _ _ = panic "lower_MO_Shl: unreachable"
-
--- | Lower a 'MO_U_Shr' operation.
-lower_MO_U_Shr ::
-  CLabel ->
-  Width ->
-  [CmmExpr] ->
-  WasmCodeGenM
-    w
-    (SomeWasmExpr w)
-lower_MO_U_Shr lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of
-  SomeWasmType ty -> do
-    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x
-    WasmExpr y_instr <- shiftRHSCast lbl ty y
-    pure $
-      SomeWasmExpr ty $
-        WasmExpr $
-          x_instr `WasmConcat` y_instr `WasmConcat` WasmShr Unsigned ty
-lower_MO_U_Shr _ _ _ = panic "lower_MO_U_Shr: unreachable"
-
--- | Lower a 'MO_S_Shr' operation, first sign-extending the LHS, then
--- truncating the result.
-lower_MO_S_Shr ::
-  CLabel ->
-  Width ->
-  [CmmExpr] ->
-  WasmCodeGenM
-    w
-    (SomeWasmExpr w)
-lower_MO_S_Shr lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of
-  SomeWasmType ty -> do
-    WasmExpr x_instr <- extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty x
-    WasmExpr y_instr <- shiftRHSCast lbl ty y
-    pure $
-      SomeWasmExpr ty $
-        truncSubword w0 ty $
-          WasmExpr $
-            x_instr `WasmConcat` y_instr `WasmConcat` WasmShr Signed ty
-lower_MO_S_Shr _ _ _ = panic "lower_MO_S_Shr: unreachable"
-
--- | Lower a 'MO_MulMayOflo' operation. It's translated to a ccall to
--- @hs_mulIntMayOflo@ function in @ghc-prim/cbits/mulIntMayOflo@,
--- otherwise it's quite non-trivial to implement as inline assembly.
-lower_MO_MulMayOflo ::
-  CLabel -> Width -> [CmmExpr] -> WasmCodeGenM w (SomeWasmExpr w)
-lower_MO_MulMayOflo lbl w0 [x, y] = case someWasmTypeFromCmmType ty_cmm of
-  SomeWasmType ty -> do
-    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x
-    WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y
-    onFuncSym "hs_mulIntMayOflo" [ty_cmm, ty_cmm] [ty_cmm]
-    pure $
-      SomeWasmExpr ty $
-        WasmExpr $
-          x_instr
-            `WasmConcat` y_instr
-            `WasmConcat` WasmCCall "hs_mulIntMayOflo"
-  where
-    ty_cmm = cmmBits w0
-lower_MO_MulMayOflo _ _ _ = panic "lower_MO_MulMayOflo: unreachable"
-
--- | Lower an unary conversion operation.
-lower_MO_Un_Conv ::
-  ( forall pre t0 t1.
-    WasmTypeTag t0 ->
-    WasmTypeTag t1 ->
-    WasmInstr w (t0 : pre) (t1 : pre)
-  ) ->
-  CLabel ->
-  CmmType ->
-  CmmType ->
-  [CmmExpr] ->
-  WasmCodeGenM w (SomeWasmExpr w)
-lower_MO_Un_Conv op lbl t0 t1 [x] =
-  case (# someWasmTypeFromCmmType t0, someWasmTypeFromCmmType t1 #) of
-    (# SomeWasmType ty0, SomeWasmType ty1 #) -> do
-      WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty0 x
-      pure $ SomeWasmExpr ty1 $ WasmExpr $ x_instr `WasmConcat` op ty0 ty1
-lower_MO_Un_Conv _ _ _ _ _ = panic "lower_MO_Un_Conv: unreachable"
-
--- | Lower a 'MO_SS_Conv' operation.
-lower_MO_SS_Conv ::
-  CLabel ->
-  Width ->
-  Width ->
-  [CmmExpr] ->
-  WasmCodeGenM
-    w
-    (SomeWasmExpr w)
-lower_MO_SS_Conv lbl w0 w1 [x]
-  | w0 == w1 = lower_CmmExpr lbl x
-lower_MO_SS_Conv lbl w0 w1 [CmmLoad ptr _ align]
-  | w0 < w1,
-    w1 <= W32 = do
-      (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr
-      pure $
-        SomeWasmExpr TagI32 $
-          truncSubword w1 TagI32 $
-            WasmExpr $
-              ptr_instr
-                `WasmConcat` WasmLoad
-                  TagI32
-                  (wasmMemoryNarrowing TagI32 (cmmBits w0))
-                  Signed
-                  o
-                  align
-  | w0 > w1 =
-      SomeWasmExpr TagI32
-        <$> lower_CmmLoad_Typed
-          lbl
-          ptr
-          TagI32
-          (cmmBits w1)
-          align
-lower_MO_SS_Conv lbl w0 W64 [CmmLoad ptr _ align] = do
-  (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr
-  pure $
-    SomeWasmExpr TagI64 $
-      WasmExpr $
-        ptr_instr
-          `WasmConcat` WasmLoad
-            TagI64
-            (wasmMemoryNarrowing TagI64 (cmmBits w0))
-            Signed
-            o
-            align
-lower_MO_SS_Conv lbl w0 w1 [x]
-  | w0 < w1,
-    w1 <= W32 = do
-      x_expr <- lower_CmmExpr_Typed lbl TagI32 x
-      pure $
-        SomeWasmExpr TagI32 $
-          truncSubword w1 TagI32 $
-            extendSubword w0 TagI32 x_expr
-  | W32 >= w0,
-    w0 > w1 = do
-      x_expr <- lower_CmmExpr_Typed lbl TagI32 x
-      pure $ SomeWasmExpr TagI32 $ truncSubword w1 TagI32 x_expr
-lower_MO_SS_Conv lbl W32 W64 [x] = do
-  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x
-  pure $
-    SomeWasmExpr TagI64 $
-      WasmExpr $
-        x_instr `WasmConcat` WasmI64ExtendI32 Signed
-lower_MO_SS_Conv lbl w0 W64 [x] = do
-  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x
-  pure $
-    SomeWasmExpr TagI64 $
-      extendSubword w0 TagI64 $
-        WasmExpr $
-          x_instr `WasmConcat` WasmI64ExtendI32 Unsigned
-lower_MO_SS_Conv lbl W64 w1 [x] = do
-  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI64 x
-  pure $
-    SomeWasmExpr TagI32 $
-      truncSubword w1 TagI32 $
-        WasmExpr $
-          x_instr `WasmConcat` WasmI32WrapI64
-lower_MO_SS_Conv _ _ _ _ = panic "lower_MO_SS_Conv: unreachable"
-
--- | Lower a 'MO_UU_Conv' operation.
-lower_MO_UU_Conv ::
-  CLabel ->
-  Width ->
-  Width ->
-  [CmmExpr] ->
-  WasmCodeGenM
-    w
-    (SomeWasmExpr w)
-lower_MO_UU_Conv lbl w0 w1 [CmmLoad ptr _ align] =
-  case someWasmTypeFromCmmType (cmmBits w1) of
-    SomeWasmType ty ->
-      SomeWasmExpr ty
-        <$> lower_CmmLoad_Typed
-          lbl
-          ptr
-          ty
-          (cmmBits (min w0 w1))
-          align
-lower_MO_UU_Conv lbl w0 w1 [x]
-  | w0 == w1 = lower_CmmExpr lbl x
-  | w0 < w1, w1 <= W32 = lower_CmmExpr lbl x
-  | W32 >= w0,
-    w0 > w1 = do
-      x_expr <- lower_CmmExpr_Typed lbl TagI32 x
-      pure $ SomeWasmExpr TagI32 $ truncSubword w1 TagI32 x_expr
-lower_MO_UU_Conv lbl _ W64 [x] = do
-  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x
-  pure $
-    SomeWasmExpr TagI64 $
-      WasmExpr $
-        x_instr `WasmConcat` WasmI64ExtendI32 Unsigned
-lower_MO_UU_Conv lbl W64 w1 [x] = do
-  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI64 x
-  pure $
-    SomeWasmExpr TagI32 $
-      truncSubword w1 TagI32 $
-        WasmExpr $
-          x_instr `WasmConcat` WasmI32WrapI64
-lower_MO_UU_Conv _ _ _ _ = panic "lower_MO_UU_Conv: unreachable"
-
--- | Lower a 'MO_FF_Conv' operation.
-lower_MO_FF_Conv ::
-  CLabel ->
-  Width ->
-  Width ->
-  [CmmExpr] ->
-  WasmCodeGenM
-    w
-    (SomeWasmExpr w)
-lower_MO_FF_Conv lbl W32 W64 [x] = do
-  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF32 x
-  pure $
-    SomeWasmExpr TagF64 $
-      WasmExpr $
-        x_instr `WasmConcat` WasmF64PromoteF32
-lower_MO_FF_Conv lbl W64 W32 [x] = do
-  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF64 x
-  pure $
-    SomeWasmExpr TagF32 $
-      WasmExpr $
-        x_instr `WasmConcat` WasmF32DemoteF64
-lower_MO_FF_Conv _ _ _ _ = panic "lower_MO_FF_Conv: unreachable"
-
--- | Lower a 'CmmMachOp'.
-lower_CmmMachOp ::
-  CLabel ->
-  MachOp ->
-  [CmmExpr] ->
-  WasmCodeGenM
-    w
-    (SomeWasmExpr w)
-lower_CmmMachOp lbl (MO_Add w0) xs = lower_MO_Bin_Homo_Trunc WasmAdd lbl w0 xs
-lower_CmmMachOp lbl (MO_Sub w0) xs = lower_MO_Bin_Homo_Trunc WasmSub lbl w0 xs
-lower_CmmMachOp lbl (MO_Eq w0) xs = lower_MO_Bin_Rel WasmEq lbl (cmmBits w0) xs
-lower_CmmMachOp lbl (MO_Ne w0) xs = lower_MO_Bin_Rel WasmNe lbl (cmmBits w0) xs
-lower_CmmMachOp lbl (MO_Mul w0) xs = lower_MO_Bin_Homo_Trunc WasmMul lbl w0 xs
-lower_CmmMachOp lbl (MO_S_MulMayOflo w0) xs = lower_MO_MulMayOflo lbl w0 xs
-lower_CmmMachOp lbl (MO_S_Quot w0) xs =
-  lower_MO_Bin_Homo_Ext_Trunc
-    (WasmDiv Signed)
-    lbl
-    w0
-    xs
-lower_CmmMachOp lbl (MO_S_Rem w0) xs =
-  lower_MO_Bin_Homo_Ext_Trunc
-    (WasmRem Signed)
-    lbl
-    w0
-    xs
-lower_CmmMachOp lbl (MO_S_Neg w0) [x] =
-  lower_CmmMachOp
-    lbl
-    (MO_Sub w0)
-    [CmmLit $ CmmInt 0 w0, x]
-lower_CmmMachOp lbl (MO_U_Quot w0) xs =
-  lower_MO_Bin_Homo
-    (WasmDiv Unsigned)
-    lbl
-    (cmmBits w0)
-    xs
-lower_CmmMachOp lbl (MO_U_Rem w0) xs =
-  lower_MO_Bin_Homo
-    (WasmRem Unsigned)
-    lbl
-    (cmmBits w0)
-    xs
-lower_CmmMachOp lbl (MO_S_Ge w0) xs =
-  lower_MO_Bin_Rel_Ext
-    (WasmGe Signed)
-    lbl
-    w0
-    xs
-lower_CmmMachOp lbl (MO_S_Le w0) xs =
-  lower_MO_Bin_Rel_Ext
-    (WasmLe Signed)
-    lbl
-    w0
-    xs
-lower_CmmMachOp lbl (MO_S_Gt w0) xs =
-  lower_MO_Bin_Rel_Ext
-    (WasmGt Signed)
-    lbl
-    w0
-    xs
-lower_CmmMachOp lbl (MO_S_Lt w0) xs =
-  lower_MO_Bin_Rel_Ext
-    (WasmLt Signed)
-    lbl
-    w0
-    xs
-lower_CmmMachOp lbl (MO_U_Ge w0) xs =
-  lower_MO_Bin_Rel
-    (WasmGe Unsigned)
-    lbl
-    (cmmBits w0)
-    xs
-lower_CmmMachOp lbl (MO_U_Le w0) xs =
-  lower_MO_Bin_Rel
-    (WasmLe Unsigned)
-    lbl
-    (cmmBits w0)
-    xs
-lower_CmmMachOp lbl (MO_U_Gt w0) xs =
-  lower_MO_Bin_Rel
-    (WasmGt Unsigned)
-    lbl
-    (cmmBits w0)
-    xs
-lower_CmmMachOp lbl (MO_U_Lt w0) xs =
-  lower_MO_Bin_Rel
-    (WasmLt Unsigned)
-    lbl
-    (cmmBits w0)
-    xs
-lower_CmmMachOp lbl (MO_F_Add w0) xs =
-  lower_MO_Bin_Homo
-    WasmAdd
-    lbl
-    (cmmFloat w0)
-    xs
-lower_CmmMachOp lbl (MO_F_Sub w0) xs =
-  lower_MO_Bin_Homo
-    WasmSub
-    lbl
-    (cmmFloat w0)
-    xs
-lower_CmmMachOp lbl (MO_F_Neg w0) [x] =
-  lower_CmmMachOp
-    lbl
-    (MO_F_Sub w0)
-    [CmmLit $ CmmFloat 0 w0, x]
-lower_CmmMachOp lbl (MO_F_Mul w0) xs =
-  lower_MO_Bin_Homo
-    WasmMul
-    lbl
-    (cmmFloat w0)
-    xs
-lower_CmmMachOp lbl (MO_F_Quot w0) xs =
-  lower_MO_Bin_Homo
-    (WasmDiv Signed)
-    lbl
-    (cmmFloat w0)
-    xs
-lower_CmmMachOp lbl (MO_F_Eq w0) xs =
-  lower_MO_Bin_Rel
-    WasmEq
-    lbl
-    (cmmFloat w0)
-    xs
-lower_CmmMachOp lbl (MO_F_Ne w0) xs =
-  lower_MO_Bin_Rel
-    WasmNe
-    lbl
-    (cmmFloat w0)
-    xs
-lower_CmmMachOp lbl (MO_F_Ge w0) xs =
-  lower_MO_Bin_Rel
-    (WasmGe Signed)
-    lbl
-    (cmmFloat w0)
-    xs
-lower_CmmMachOp lbl (MO_F_Le w0) xs =
-  lower_MO_Bin_Rel
-    (WasmLe Signed)
-    lbl
-    (cmmFloat w0)
-    xs
-lower_CmmMachOp lbl (MO_F_Gt w0) xs =
-  lower_MO_Bin_Rel
-    (WasmGt Signed)
-    lbl
-    (cmmFloat w0)
-    xs
-lower_CmmMachOp lbl (MO_F_Lt w0) xs =
-  lower_MO_Bin_Rel
-    (WasmLt Signed)
-    lbl
-    (cmmFloat w0)
-    xs
-lower_CmmMachOp lbl (MO_And w0) xs =
-  lower_MO_Bin_Homo
-    WasmAnd
-    lbl
-    (cmmBits w0)
-    xs
-lower_CmmMachOp lbl (MO_Or w0) xs = lower_MO_Bin_Homo WasmOr lbl (cmmBits w0) xs
-lower_CmmMachOp lbl (MO_Xor w0) xs =
-  lower_MO_Bin_Homo
-    WasmXor
-    lbl
-    (cmmBits w0)
-    xs
-lower_CmmMachOp lbl (MO_Not w0) [x] =
-  lower_CmmMachOp
-    lbl
-    (MO_Xor w0)
-    [x, CmmLit $ CmmInt (widthMax w0) w0]
-lower_CmmMachOp lbl (MO_Shl w0) xs = lower_MO_Shl lbl w0 xs
-lower_CmmMachOp lbl (MO_U_Shr w0) xs = lower_MO_U_Shr lbl w0 xs
-lower_CmmMachOp lbl (MO_S_Shr w0) xs = lower_MO_S_Shr lbl w0 xs
-lower_CmmMachOp lbl (MO_SF_Conv w0 w1) xs =
-  lower_MO_Un_Conv
-    (WasmConvert Signed)
-    lbl
-    (cmmBits w0)
-    (cmmFloat w1)
-    xs
-lower_CmmMachOp lbl (MO_FS_Conv w0 w1) xs =
-  lower_MO_Un_Conv
-    (WasmTruncSat Signed)
-    lbl
-    (cmmFloat w0)
-    (cmmBits w1)
-    xs
-lower_CmmMachOp lbl (MO_SS_Conv w0 w1) xs = lower_MO_SS_Conv lbl w0 w1 xs
-lower_CmmMachOp lbl (MO_UU_Conv w0 w1) xs = lower_MO_UU_Conv lbl w0 w1 xs
-lower_CmmMachOp lbl (MO_XX_Conv w0 w1) xs = lower_MO_UU_Conv lbl w0 w1 xs
-lower_CmmMachOp lbl (MO_FF_Conv w0 w1) xs = lower_MO_FF_Conv lbl w0 w1 xs
-lower_CmmMachOp _ _ _ = panic "lower_CmmMachOp: unreachable"
-
--- | Lower a 'CmmLit'. Note that we don't emit 'f32.const' or
--- 'f64.const' for the time being, and instead emit their relative bit
--- pattern as int literals, then use an reinterpret cast. This is
--- simpler than dealing with textual representation of floating point
--- values.
-lower_CmmLit :: CmmLit -> WasmCodeGenM w (SomeWasmExpr w)
-lower_CmmLit lit = do
-  ty_word <- wasmWordTypeM
-  case lit of
-    CmmInt i w -> case someWasmTypeFromCmmType (cmmBits w) of
-      SomeWasmType ty ->
-        pure $
-          SomeWasmExpr ty $
-            WasmExpr $
-              WasmConst ty $
-                naturalNarrowing w i
-    CmmFloat f W32 ->
-      pure $
-        SomeWasmExpr TagF32 $
-          WasmExpr $
-            WasmConst
-              TagI32
-              (toInteger $ castFloatToWord32 $ fromRational f)
-              `WasmConcat` WasmReinterpret TagI32 TagF32
-    CmmFloat f W64 ->
-      pure $
-        SomeWasmExpr TagF64 $
-          WasmExpr $
-            WasmConst
-              TagI64
-              (toInteger $ castDoubleToWord64 $ fromRational f)
-              `WasmConcat` WasmReinterpret TagI64 TagF64
-    CmmLabel lbl' -> do
-      onAnySym lbl'
-      let sym = symNameFromCLabel lbl'
-      pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst sym
-    CmmLabelOff lbl' o -> do
-      onAnySym lbl'
-      let sym = symNameFromCLabel lbl'
-      pure $
-        SomeWasmExpr ty_word $
-          WasmExpr $
-            WasmSymConst sym
-              `WasmConcat` WasmConst ty_word (toInteger o)
-              `WasmConcat` WasmAdd ty_word
-    _ -> panic "lower_CmmLit: unreachable"
-
---  | Lower a 'CmmReg'. Some of the logic here wouldn't be needed if
---  we have run 'fixStgRegisters' on the wasm NCG's input Cmm, but we
---  haven't run it yet for certain reasons.
-lower_CmmReg :: CLabel -> CmmReg -> WasmCodeGenM w (SomeWasmExpr w)
-lower_CmmReg _ (CmmLocal reg) = do
-  (reg_i, SomeWasmType ty) <- onCmmLocalReg reg
-  pure $ SomeWasmExpr ty $ WasmExpr $ WasmLocalGet ty reg_i
-lower_CmmReg _ (CmmGlobal EagerBlackholeInfo) = do
-  ty_word <- wasmWordTypeM
-  pure $
-    SomeWasmExpr ty_word $
-      WasmExpr $
-        WasmSymConst "stg_EAGER_BLACKHOLE_info"
-lower_CmmReg _ (CmmGlobal GCEnter1) = do
-  ty_word <- wasmWordTypeM
-  ty_word_cmm <- wasmWordCmmTypeM
-  onFuncSym "__stg_gc_enter_1" [] [ty_word_cmm]
-  pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_enter_1"
-lower_CmmReg _ (CmmGlobal GCFun) = do
-  ty_word <- wasmWordTypeM
-  ty_word_cmm <- wasmWordCmmTypeM
-  onFuncSym "__stg_gc_fun" [] [ty_word_cmm]
-  pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_fun"
-lower_CmmReg lbl (CmmGlobal BaseReg) = do
-  platform <- wasmPlatformM
-  lower_CmmExpr lbl $ regTableOffset platform 0
-lower_CmmReg lbl (CmmGlobal reg) = do
-  ty_word <- wasmWordTypeM
-  if
-      | Just (sym_global, SomeWasmType ty) <-
-          globalInfoFromCmmGlobalReg ty_word reg ->
-          pure $ SomeWasmExpr ty $ WasmExpr $ WasmGlobalGet ty sym_global
-      | otherwise -> do
-          platform <- wasmPlatformM
-          case someWasmTypeFromCmmType $ globalRegType platform reg of
-            SomeWasmType ty -> do
-              (WasmExpr ptr_instr, o) <-
-                lower_CmmExpr_Ptr lbl $
-                  get_GlobalReg_addr platform reg
-              pure $
-                SomeWasmExpr ty $
-                  WasmExpr $
-                    ptr_instr
-                      `WasmConcat` WasmLoad
-                        ty
-                        Nothing
-                        Unsigned
-                        o
-                        NaturallyAligned
-
--- | Lower a 'CmmRegOff'.
-lower_CmmRegOff :: CLabel -> CmmReg -> Int -> WasmCodeGenM w (SomeWasmExpr w)
-lower_CmmRegOff lbl reg 0 = lower_CmmReg lbl reg
-lower_CmmRegOff lbl reg o = do
-  SomeWasmExpr ty (WasmExpr reg_instr) <- lower_CmmReg lbl reg
-  pure $
-    SomeWasmExpr ty $
-      WasmExpr $
-        reg_instr
-          `WasmConcat` WasmConst
-            ty
-            (toInteger o)
-          `WasmConcat` WasmAdd ty
-
--- | Lower a 'CmmLoad', passing in the expected wasm representation
--- type, and also the Cmm type (which contains width info needed for
--- memory narrowing).
---
--- The Cmm type system doesn't track signedness, so all 'CmmLoad's are
--- unsigned loads. However, as an optimization, we do emit signed
--- loads when a 'CmmLoad' result is immediately used as a 'MO_SS_Conv'
--- operand.
-lower_CmmLoad_Typed ::
-  CLabel ->
-  CmmExpr ->
-  WasmTypeTag t ->
-  CmmType ->
-  AlignmentSpec ->
-  WasmCodeGenM w (WasmExpr w t)
-lower_CmmLoad_Typed lbl ptr_expr ty ty_cmm align = do
-  (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr_expr
-  pure $
-    WasmExpr $
-      ptr_instr
-        `WasmConcat` WasmLoad
-          ty
-          (wasmMemoryNarrowing ty ty_cmm)
-          Unsigned
-          o
-          align
-
--- | Lower a 'CmmLoad'.
-lower_CmmLoad ::
-  CLabel ->
-  CmmExpr ->
-  CmmType ->
-  AlignmentSpec ->
-  WasmCodeGenM
-    w
-    (SomeWasmExpr w)
-lower_CmmLoad lbl ptr_expr ty_cmm align = case someWasmTypeFromCmmType ty_cmm of
-  SomeWasmType ty ->
-    SomeWasmExpr ty <$> lower_CmmLoad_Typed lbl ptr_expr ty ty_cmm align
-
--- | Lower a 'CmmExpr'.
-lower_CmmExpr :: CLabel -> CmmExpr -> WasmCodeGenM w (SomeWasmExpr w)
-lower_CmmExpr lbl expr = case expr of
-  CmmLit lit -> lower_CmmLit lit
-  CmmLoad ptr_expr ty_cmm align -> lower_CmmLoad lbl ptr_expr ty_cmm align
-  CmmReg reg -> lower_CmmReg lbl reg
-  CmmRegOff reg o -> lower_CmmRegOff lbl reg o
-  CmmMachOp op xs -> lower_CmmMachOp lbl op xs
-  _ -> panic "lower_CmmExpr: unreachable"
-
--- | Lower a 'CmmExpr', passing in the expected wasm representation
--- type.
-lower_CmmExpr_Typed ::
-  CLabel ->
-  WasmTypeTag t ->
-  CmmExpr ->
-  WasmCodeGenM
-    w
-    (WasmExpr w t)
-lower_CmmExpr_Typed lbl ty expr = do
-  SomeWasmExpr ty' r <- lower_CmmExpr lbl expr
-  if
-      | Just Refl <- ty' `testEquality` ty -> pure r
-      | otherwise -> panic "lower_CmmExpr_Typed: unreachable"
-
--- | Lower a 'CmmExpr' as a pointer, returning the pair of base
--- pointer and non-negative offset.
-lower_CmmExpr_Ptr :: CLabel -> CmmExpr -> WasmCodeGenM w (WasmExpr w w, Int)
-lower_CmmExpr_Ptr lbl ptr = do
-  ty_word <- wasmWordTypeM
-  case ptr of
-    CmmLit (CmmLabelOff lbl o)
-      | o >= 0 -> do
-          instrs <-
-            lower_CmmExpr_Typed
-              lbl
-              ty_word
-              (CmmLit $ CmmLabel lbl)
-          pure (instrs, o)
-    CmmMachOp (MO_Add _) [base, CmmLit (CmmInt o _)]
-      | o >= 0 -> do
-          instrs <- lower_CmmExpr_Typed lbl ty_word base
-          pure (instrs, fromInteger o)
-    _ -> do
-      instrs <- lower_CmmExpr_Typed lbl ty_word ptr
-      pure (instrs, 0)
-
--- | Push a series of values onto the wasm value stack, returning the
--- result stack type.
-type family
-  WasmPushes (ts :: [WasmType]) (pre :: [WasmType]) ::
-    [WasmType]
-  where
-  WasmPushes '[] pre = pre
-  WasmPushes (t : ts) pre = WasmPushes ts (t : pre)
-
--- | Push the arguments onto the wasm value stack before a ccall.
-data SomeWasmPreCCall w where
-  SomeWasmPreCCall ::
-    TypeList ts ->
-    (forall pre. WasmInstr w pre (WasmPushes ts pre)) ->
-    SomeWasmPreCCall w
-
--- | Pop the results into locals after a ccall.
-data SomeWasmPostCCall w where
-  SomeWasmPostCCall ::
-    TypeList ts ->
-    (forall post. WasmInstr w (WasmPushes ts post) post) ->
-    SomeWasmPostCCall w
-
--- | Lower an unary homogeneous 'CallishMachOp' to a ccall.
-lower_CMO_Un_Homo ::
-  CLabel ->
-  SymName ->
-  [CmmFormal] ->
-  [CmmActual] ->
-  WasmCodeGenM w (WasmStatements w)
-lower_CMO_Un_Homo lbl op [reg] [x] = do
-  (ri, SomeWasmType ty) <- onCmmLocalReg reg
-  WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x
-  let ty_cmm = localRegType reg
-  onFuncSym op [ty_cmm] [ty_cmm]
-  pure $
-    WasmStatements $
-      x_instr `WasmConcat` WasmCCall op `WasmConcat` WasmLocalSet ty ri
-lower_CMO_Un_Homo _ _ _ _ = panic "lower_CMO_Un_Homo: unreachable"
-
--- | Lower an unary homogeneous 'CallishMachOp' to inline assembly.
-lower_CMO_Un_Prim ::
-  CLabel ->
-  (forall pre t. WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)) ->
-  [CmmFormal] ->
-  [CmmActual] ->
-  WasmCodeGenM w (WasmStatements w)
-lower_CMO_Un_Prim lbl op [reg] [x] = do
-  (ri, SomeWasmType ty) <- onCmmLocalReg reg
-  SomeWasmExpr ty_x (WasmExpr x_instr) <- lower_CmmExpr lbl x
-  if
-      | Just Refl <- ty `testEquality` ty_x ->
-          pure $
-            WasmStatements $
-              x_instr `WasmConcat` op ty_x `WasmConcat` WasmLocalSet ty ri
-      | TagI32 <- ty,
-        TagI64 <-
-          ty_x ->
-          pure $
-            WasmStatements $
-              x_instr
-                `WasmConcat` op ty_x
-                `WasmConcat` WasmI32WrapI64
-                `WasmConcat` WasmLocalSet ty ri
-      | otherwise -> panic "lower_CMO_Un_Prim: unreachable"
-lower_CMO_Un_Prim _ _ _ _ = panic "lower_CMO_Un_Prim: unreachable"
-
--- | Lower a binary homogeneous 'CallishMachOp' to a ccall.
-lower_CMO_Bin_Homo ::
-  CLabel ->
-  SymName ->
-  [CmmFormal] ->
-  [CmmActual] ->
-  WasmCodeGenM w (WasmStatements w)
-lower_CMO_Bin_Homo lbl op [reg] [x, y] = do
-  (ri, SomeWasmType ty) <- onCmmLocalReg reg
-  WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x
-  WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y
-  let ty_cmm = localRegType reg
-  onFuncSym op [ty_cmm, ty_cmm] [ty_cmm]
-  pure $
-    WasmStatements $
-      x_instr
-        `WasmConcat` y_instr
-        `WasmConcat` WasmCCall op
-        `WasmConcat` WasmLocalSet ty ri
-lower_CMO_Bin_Homo _ _ _ _ = panic "lower_CMO_Bin_Homo: unreachable"
-
--- | Lower a 'MO_UF_Conv' operation.
-lower_MO_UF_Conv ::
-  CLabel ->
-  Width ->
-  [CmmFormal] ->
-  [CmmActual] ->
-  WasmCodeGenM w (WasmStatements w)
-lower_MO_UF_Conv lbl W32 [reg] [x] = do
-  ri <- onCmmLocalReg_Typed TagF32 reg
-  SomeWasmExpr ty0 (WasmExpr x_instr) <- lower_CmmExpr lbl x
-  pure $
-    WasmStatements $
-      x_instr
-        `WasmConcat` WasmConvert Unsigned ty0 TagF32
-        `WasmConcat` WasmLocalSet TagF32 ri
-lower_MO_UF_Conv lbl W64 [reg] [x] = do
-  ri <- onCmmLocalReg_Typed TagF64 reg
-  SomeWasmExpr ty0 (WasmExpr x_instr) <- lower_CmmExpr lbl x
-  pure $
-    WasmStatements $
-      x_instr
-        `WasmConcat` WasmConvert Unsigned ty0 TagF64
-        `WasmConcat` WasmLocalSet TagF64 ri
-lower_MO_UF_Conv _ _ _ _ = panic "lower_MO_UF_Conv: unreachable"
-
--- | Lower a 'MO_Cmpxchg' operation to inline assembly. Currently we
--- target wasm without atomics and threads, so it's just lowered to
--- regular memory loads and stores.
-lower_MO_Cmpxchg ::
-  CLabel ->
-  Width ->
-  [CmmFormal] ->
-  [CmmActual] ->
-  WasmCodeGenM w (WasmStatements w)
-lower_MO_Cmpxchg lbl w0 [reg] [ptr, expected, new] =
-  case someWasmTypeFromCmmType ty_cmm of
-    SomeWasmType ty -> do
-      reg_i <- onCmmLocalReg_Typed ty reg
-      let narrowing = wasmMemoryNarrowing ty ty_cmm
-      (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr
-      WasmExpr expected_instr <- lower_CmmExpr_Typed lbl ty expected
-      WasmExpr new_instr <- lower_CmmExpr_Typed lbl ty new
-      pure $
-        WasmStatements $
-          ptr_instr
-            `WasmConcat` WasmLoad ty narrowing Unsigned o NaturallyAligned
-            `WasmConcat` WasmLocalTee ty reg_i
-            `WasmConcat` expected_instr
-            `WasmConcat` WasmEq ty
-            `WasmConcat` WasmCond
-              ( ptr_instr
-                  `WasmConcat` new_instr
-                  `WasmConcat` WasmStore ty narrowing o NaturallyAligned
-              )
-  where
-    ty_cmm = cmmBits w0
-lower_MO_Cmpxchg _ _ _ _ = panic "lower_MO_Cmpxchg: unreachable"
-
--- | Lower a 'CallishMachOp'.
-lower_CallishMachOp ::
-  CLabel ->
-  CallishMachOp ->
-  [CmmFormal] ->
-  [CmmActual] ->
-  WasmCodeGenM w (WasmStatements w)
-lower_CallishMachOp lbl MO_F64_Pwr rs xs = lower_CMO_Bin_Homo lbl "pow" rs xs
-lower_CallishMachOp lbl MO_F64_Sin rs xs = lower_CMO_Un_Homo lbl "sin" rs xs
-lower_CallishMachOp lbl MO_F64_Cos rs xs = lower_CMO_Un_Homo lbl "cos" rs xs
-lower_CallishMachOp lbl MO_F64_Tan rs xs = lower_CMO_Un_Homo lbl "tan" rs xs
-lower_CallishMachOp lbl MO_F64_Sinh rs xs = lower_CMO_Un_Homo lbl "sinh" rs xs
-lower_CallishMachOp lbl MO_F64_Cosh rs xs = lower_CMO_Un_Homo lbl "cosh" rs xs
-lower_CallishMachOp lbl MO_F64_Tanh rs xs = lower_CMO_Un_Homo lbl "tanh" rs xs
-lower_CallishMachOp lbl MO_F64_Asin rs xs = lower_CMO_Un_Homo lbl "asin" rs xs
-lower_CallishMachOp lbl MO_F64_Acos rs xs = lower_CMO_Un_Homo lbl "acos" rs xs
-lower_CallishMachOp lbl MO_F64_Atan rs xs = lower_CMO_Un_Homo lbl "atan" rs xs
-lower_CallishMachOp lbl MO_F64_Asinh rs xs = lower_CMO_Un_Homo lbl "asinh" rs xs
-lower_CallishMachOp lbl MO_F64_Acosh rs xs = lower_CMO_Un_Homo lbl "acosh" rs xs
-lower_CallishMachOp lbl MO_F64_Atanh rs xs = lower_CMO_Un_Homo lbl "atanh" rs xs
-lower_CallishMachOp lbl MO_F64_Log rs xs = lower_CMO_Un_Homo lbl "log" rs xs
-lower_CallishMachOp lbl MO_F64_Log1P rs xs = lower_CMO_Un_Homo lbl "log1p" rs xs
-lower_CallishMachOp lbl MO_F64_Exp rs xs = lower_CMO_Un_Homo lbl "exp" rs xs
-lower_CallishMachOp lbl MO_F64_ExpM1 rs xs = lower_CMO_Un_Homo lbl "expm1" rs xs
-lower_CallishMachOp lbl MO_F64_Fabs rs xs = lower_CMO_Un_Homo lbl "fabs" rs xs
-lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrt" rs xs
-lower_CallishMachOp lbl MO_F32_Pwr rs xs = lower_CMO_Bin_Homo lbl "powf" rs xs
-lower_CallishMachOp lbl MO_F32_Sin rs xs = lower_CMO_Un_Homo lbl "sinf" rs xs
-lower_CallishMachOp lbl MO_F32_Cos rs xs = lower_CMO_Un_Homo lbl "cosf" rs xs
-lower_CallishMachOp lbl MO_F32_Tan rs xs = lower_CMO_Un_Homo lbl "tanf" rs xs
-lower_CallishMachOp lbl MO_F32_Sinh rs xs = lower_CMO_Un_Homo lbl "sinhf" rs xs
-lower_CallishMachOp lbl MO_F32_Cosh rs xs = lower_CMO_Un_Homo lbl "coshf" rs xs
-lower_CallishMachOp lbl MO_F32_Tanh rs xs = lower_CMO_Un_Homo lbl "tanhf" rs xs
-lower_CallishMachOp lbl MO_F32_Asin rs xs = lower_CMO_Un_Homo lbl "asinf" rs xs
-lower_CallishMachOp lbl MO_F32_Acos rs xs = lower_CMO_Un_Homo lbl "acosf" rs xs
-lower_CallishMachOp lbl MO_F32_Atan rs xs = lower_CMO_Un_Homo lbl "atanf" rs xs
-lower_CallishMachOp lbl MO_F32_Asinh rs xs =
-  lower_CMO_Un_Homo lbl "asinhf" rs xs
-lower_CallishMachOp lbl MO_F32_Acosh rs xs =
-  lower_CMO_Un_Homo lbl "acoshf" rs xs
-lower_CallishMachOp lbl MO_F32_Atanh rs xs =
-  lower_CMO_Un_Homo lbl "atanhf" rs xs
-lower_CallishMachOp lbl MO_F32_Log rs xs = lower_CMO_Un_Homo lbl "logf" rs xs
-lower_CallishMachOp lbl MO_F32_Log1P rs xs =
-  lower_CMO_Un_Homo lbl "log1pf" rs xs
-lower_CallishMachOp lbl MO_F32_Exp rs xs = lower_CMO_Un_Homo lbl "expf" rs xs
-lower_CallishMachOp lbl MO_F32_ExpM1 rs xs =
-  lower_CMO_Un_Homo lbl "expm1f" rs xs
-lower_CallishMachOp lbl MO_F32_Fabs rs xs = lower_CMO_Un_Homo lbl "fabsf" rs xs
-lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrtf" rs xs
-lower_CallishMachOp lbl (MO_UF_Conv w0) rs xs = lower_MO_UF_Conv lbl w0 rs xs
-lower_CallishMachOp _ MO_ReadBarrier _ _ = pure $ WasmStatements WasmNop
-lower_CallishMachOp _ MO_WriteBarrier _ _ = pure $ WasmStatements WasmNop
-lower_CallishMachOp _ MO_Touch _ _ = pure $ WasmStatements WasmNop
-lower_CallishMachOp _ (MO_Prefetch_Data {}) _ _ = pure $ WasmStatements WasmNop
-lower_CallishMachOp lbl (MO_Memcpy {}) [] xs = do
-  ty_word_cmm <- wasmWordCmmTypeM
-  lower_CmmUnsafeForeignCall_Drop lbl "memcpy" ty_word_cmm xs
-lower_CallishMachOp lbl (MO_Memset {}) [] xs = do
-  ty_word_cmm <- wasmWordCmmTypeM
-  lower_CmmUnsafeForeignCall_Drop lbl "memset" ty_word_cmm xs
-lower_CallishMachOp lbl (MO_Memmove {}) [] xs = do
-  ty_word_cmm <- wasmWordCmmTypeM
-  lower_CmmUnsafeForeignCall_Drop lbl "memmove" ty_word_cmm xs
-lower_CallishMachOp lbl (MO_Memcmp {}) rs xs =
-  lower_CmmUnsafeForeignCall
-    lbl
-    (Left "memcmp")
-    CmmMayReturn
-    rs
-    xs
-lower_CallishMachOp lbl (MO_PopCnt w0) rs xs =
-  lower_CmmUnsafeForeignCall
-    lbl
-    (Left $ fromString $ "hs_popcnt" <> show (widthInBits w0))
-    CmmMayReturn
-    rs
-    xs
-lower_CallishMachOp lbl (MO_Pdep w0) rs xs =
-  lower_CmmUnsafeForeignCall
-    lbl
-    (Left $ fromString $ "hs_pdep" <> show (widthInBits w0))
-    CmmMayReturn
-    rs
-    xs
-lower_CallishMachOp lbl (MO_Pext w0) rs xs =
-  lower_CmmUnsafeForeignCall
-    lbl
-    (Left $ fromString $ "hs_pext" <> show (widthInBits w0))
-    CmmMayReturn
-    rs
-    xs
-lower_CallishMachOp lbl (MO_Clz w0) rs xs =
-  lower_CmmUnsafeForeignCall
-    lbl
-    (Left $ fromString $ "hs_clz" <> show (widthInBits w0))
-    CmmMayReturn
-    rs
-    xs
-lower_CallishMachOp lbl (MO_Ctz w0) rs xs =
-  lower_CmmUnsafeForeignCall
-    lbl
-    (Left $ fromString $ "hs_ctz" <> show (widthInBits w0))
-    CmmMayReturn
-    rs
-    xs
-lower_CallishMachOp lbl (MO_BSwap w0) rs xs =
-  lower_CmmUnsafeForeignCall
-    lbl
-    (Left $ fromString $ "hs_bswap" <> show (widthInBits w0))
-    CmmMayReturn
-    rs
-    xs
-lower_CallishMachOp lbl (MO_BRev w0) rs xs =
-  lower_CmmUnsafeForeignCall
-    lbl
-    (Left $ fromString $ "hs_bitrev" <> show (widthInBits w0))
-    CmmMayReturn
-    rs
-    xs
-lower_CallishMachOp lbl (MO_AtomicRMW w0 op) rs xs =
-  lower_CmmUnsafeForeignCall
-    lbl
-    ( Left $
-        fromString $
-          ( case op of
-              AMO_Add -> "hs_atomic_add"
-              AMO_Sub -> "hs_atomic_sub"
-              AMO_And -> "hs_atomic_and"
-              AMO_Nand -> "hs_atomic_nand"
-              AMO_Or -> "hs_atomic_or"
-              AMO_Xor -> "hs_atomic_xor"
-          )
-            <> show (widthInBits w0)
-    )
-    CmmMayReturn
-    rs
-    xs
-lower_CallishMachOp lbl (MO_AtomicRead w0) [reg] [ptr] = do
-  SomeWasmExpr ty (WasmExpr ret_instr) <-
-    lower_CmmLoad
-      lbl
-      ptr
-      (cmmBits w0)
-      NaturallyAligned
-  ri <- onCmmLocalReg_Typed ty reg
-  pure $ WasmStatements $ ret_instr `WasmConcat` WasmLocalSet ty ri
-lower_CallishMachOp lbl (MO_AtomicWrite _) [] [ptr, val] =
-  lower_CmmStore lbl ptr val NaturallyAligned
-lower_CallishMachOp lbl (MO_Cmpxchg w0) rs xs = lower_MO_Cmpxchg lbl w0 rs xs
-lower_CallishMachOp lbl (MO_Xchg w0) rs xs =
-  lower_CmmUnsafeForeignCall
-    lbl
-    (Left $ fromString $ "hs_xchg" <> show (widthInBits w0))
-    CmmMayReturn
-    rs
-    xs
-lower_CallishMachOp lbl MO_SuspendThread rs xs =
-  lower_CmmUnsafeForeignCall
-    lbl
-    (Left "suspendThread")
-    CmmMayReturn
-    rs
-    xs
-lower_CallishMachOp lbl MO_ResumeThread rs xs =
-  lower_CmmUnsafeForeignCall
-    lbl
-    (Left "resumeThread")
-    CmmMayReturn
-    rs
-    xs
-lower_CallishMachOp _ _ _ _ = panic "lower_CallishMachOp: unreachable"
-
--- | Lower a ccall, but drop the result by assigning it to an unused
--- local. This is only used for lowering 'MO_Memcpy' and such, where
--- the libc functions do have a return value, but the corresponding
--- 'CallishMachOp' does not expect one.
-lower_CmmUnsafeForeignCall_Drop ::
-  CLabel ->
-  SymName ->
-  CmmType ->
-  [CmmActual] ->
-  WasmCodeGenM w (WasmStatements w)
-lower_CmmUnsafeForeignCall_Drop lbl sym_callee ret_cmm_ty arg_exprs = do
-  ret_uniq <- wasmUniq
-  let ret_local = LocalReg ret_uniq ret_cmm_ty
-  lower_CmmUnsafeForeignCall
-    lbl
-    (Left sym_callee)
-    CmmMayReturn
-    [ret_local]
-    arg_exprs
-
--- | Lower a 'CmmUnsafeForeignCall'. The target is 'Either' a symbol,
--- which translates to a direct @call@, or an expression, which
--- translates to a @call_indirect@. The callee function signature is
--- inferred from the passed in arguments here.
-lower_CmmUnsafeForeignCall ::
-  CLabel ->
-  (Either SymName CmmExpr) ->
-  CmmReturnInfo ->
-  [CmmFormal] ->
-  [CmmActual] ->
-  WasmCodeGenM
-    w
-    (WasmStatements w)
-lower_CmmUnsafeForeignCall lbl target ret_info ret_locals arg_exprs = do
-  SomeWasmPreCCall arg_tys args_instr <-
-    foldrM
-      ( \arg_expr (SomeWasmPreCCall acc_tys acc_instr) -> do
-          SomeWasmExpr arg_ty (WasmExpr arg_instr) <-
-            lower_CmmExpr lbl arg_expr
-          pure $
-            SomeWasmPreCCall (arg_ty `TypeListCons` acc_tys) $
-              arg_instr `WasmConcat` acc_instr
-      )
-      (SomeWasmPreCCall TypeListNil WasmNop)
-      arg_exprs
-  SomeWasmPostCCall ret_tys ret_instr <-
-    foldrM
-      ( \reg (SomeWasmPostCCall acc_tys acc_instr) -> do
-          (reg_i, SomeWasmType reg_ty) <- onCmmLocalReg reg
-          pure $
-            SomeWasmPostCCall (reg_ty `TypeListCons` acc_tys) $
-              acc_instr `WasmConcat` WasmLocalSet reg_ty reg_i
-      )
-      (SomeWasmPostCCall TypeListNil WasmNop)
-      ret_locals
-  case target of
-    Left sym_callee -> do
-      platform <- wasmPlatformM
-      let arg_cmm_tys = map (cmmExprType platform) arg_exprs
-          ret_cmm_tys = map localRegType ret_locals
-      onFuncSym sym_callee arg_cmm_tys ret_cmm_tys
-      pure $
-        WasmStatements $
-          args_instr
-            `WasmConcat` WasmCCall sym_callee
-            `WasmConcat` ( case ret_info of
-                             CmmMayReturn -> ret_instr
-                             CmmNeverReturns -> WasmUnreachable
-                         )
-    Right fptr_callee -> do
-      (WasmExpr instr_callee, _) <- lower_CmmExpr_Ptr lbl fptr_callee
-      pure $
-        WasmStatements $
-          args_instr
-            `WasmConcat` instr_callee
-            `WasmConcat` WasmCCallIndirect arg_tys ret_tys
-            `WasmConcat` ( case ret_info of
-                             CmmMayReturn -> ret_instr
-                             CmmNeverReturns -> WasmUnreachable
-                         )
-
--- | Lower a 'CmmStore'.
-lower_CmmStore ::
-  CLabel ->
-  CmmExpr ->
-  CmmExpr ->
-  AlignmentSpec ->
-  WasmCodeGenM
-    w
-    (WasmStatements w)
-lower_CmmStore lbl ptr val align = do
-  platform <- wasmPlatformM
-  (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr
-  let ty_cmm = cmmExprType platform val
-  SomeWasmExpr ty (WasmExpr val_instr) <- lower_CmmExpr lbl val
-  pure $
-    WasmStatements $
-      ptr_instr
-        `WasmConcat` val_instr
-        `WasmConcat` WasmStore ty (wasmMemoryNarrowing ty ty_cmm) o align
-
--- | Lower a single Cmm action.
-lower_CmmAction :: CLabel -> CmmNode O O -> WasmCodeGenM w (WasmStatements w)
-lower_CmmAction lbl act = do
-  ty_word <- wasmWordTypeM
-  platform <- wasmPlatformM
-  case act of
-    CmmComment {} -> pure $ WasmStatements WasmNop
-    CmmTick {} -> pure $ WasmStatements WasmNop
-    CmmUnwind {} -> pure $ WasmStatements WasmNop
-    CmmAssign (CmmLocal reg) e -> do
-      (i, SomeWasmType ty_reg) <- onCmmLocalReg reg
-      WasmExpr instrs <- lower_CmmExpr_Typed lbl ty_reg e
-      pure $ WasmStatements $ instrs `WasmConcat` WasmLocalSet ty_reg i
-    CmmAssign (CmmGlobal reg) e
-      | BaseReg <- reg -> pure $ WasmStatements WasmNop
-      | Just (sym_global, SomeWasmType ty_reg) <-
-          globalInfoFromCmmGlobalReg ty_word reg -> do
-          WasmExpr instrs <- lower_CmmExpr_Typed lbl ty_reg e
-          pure $
-            WasmStatements $
-              instrs `WasmConcat` WasmGlobalSet ty_reg sym_global
-      | otherwise -> do
-          (WasmExpr ptr_instr, o) <-
-            lower_CmmExpr_Ptr lbl $ get_GlobalReg_addr platform reg
-          SomeWasmExpr ty_e (WasmExpr instrs) <- lower_CmmExpr lbl e
-          pure $
-            WasmStatements $
-              ptr_instr
-                `WasmConcat` instrs
-                `WasmConcat` WasmStore ty_e Nothing o NaturallyAligned
-    CmmStore ptr val align -> lower_CmmStore lbl ptr val align
-    CmmUnsafeForeignCall
-      ( ForeignTarget
-          (CmmLit (CmmLabel lbl_callee))
-          (ForeignConvention conv _ _ ret_info)
-        )
-      ret_locals
-      arg_exprs
-        | conv `elem` [CCallConv, CApiConv] ->
-            lower_CmmUnsafeForeignCall
-              lbl
-              (Left $ symNameFromCLabel lbl_callee)
-              ret_info
-              ret_locals
-              arg_exprs
-    CmmUnsafeForeignCall
-      (ForeignTarget target_expr (ForeignConvention conv _ _ ret_info))
-      ret_locals
-      arg_exprs
-        | conv `elem` [CCallConv, CApiConv] ->
-            lower_CmmUnsafeForeignCall
-              lbl
-              (Right target_expr)
-              ret_info
-              ret_locals
-              arg_exprs
-    CmmUnsafeForeignCall (PrimTarget op) ret_locals arg_exprs ->
-      lower_CallishMachOp lbl op ret_locals arg_exprs
-    _ -> panic "lower_CmmAction: unreachable"
-
--- | Lower a block of Cmm actions.
-lower_CmmActions ::
-  CLabel ->
-  Label ->
-  Block CmmNode O O ->
-  WasmCodeGenM
-    w
-    (WasmStatements w)
-lower_CmmActions lbl _ blk =
-  foldlM
-    ( \(WasmStatements acc) act ->
-        (\(WasmStatements stmts) -> WasmStatements $ acc `WasmConcat` stmts)
-          <$> lower_CmmAction lbl act
-    )
-    (WasmStatements WasmNop)
-    acts
-  where
-    acts = blockToList blk
-
--- | Lower a 'CmmGraph'.
-lower_CmmGraph :: CLabel -> CmmGraph -> WasmCodeGenM w (FuncBody w)
-lower_CmmGraph lbl g = do
-  ty_word <- wasmWordTypeM
-  platform <- wasmPlatformM
-  body <-
-    structuredControl
-      platform
-      (\_ -> lower_CmmExpr_Typed lbl ty_word)
-      (lower_CmmActions lbl)
-      g
-  locals <- wasmStateM $ \s ->
-    (#
-      map snd $ detEltsUFM $ localRegs s,
-      s {localRegs = emptyUFM, localRegsCount = 0}
-    #)
-  pure FuncBody {funcLocals = locals, funcBody = wasmControlCast $ body}
-
--- | Invoked once for each 'CLabel' which indexes a 'CmmData' or
--- 'CmmProc'.
-onTopSym :: CLabel -> WasmCodeGenM w ()
-onTopSym lbl = case sym_vis of
-  SymDefault -> wasmModifyM $ \s ->
-    s
-      { defaultSyms =
-          IS.insert
-            (getKey $ getUnique sym)
-            $ defaultSyms s
-      }
-  _ -> pure ()
-  where
-    sym = symNameFromCLabel lbl
-
-    sym_vis = symVisibilityFromCLabel lbl
-
--- | Invoked for each function 'CLabel' with known type (e.g. a
--- 'CmmProc', or callee of 'CmmUnsafeForeignCall').
-onFuncSym :: SymName -> [CmmType] -> [CmmType] -> WasmCodeGenM w ()
-onFuncSym sym arg_tys ret_tys = wasmModifyM $
-  \s@WasmCodeGenState {..} ->
-    s
-      { funcTypes =
-          addToUniqMap
-            funcTypes
-            sym
-            ( map someWasmTypeFromCmmType arg_tys,
-              map someWasmTypeFromCmmType ret_tys
-            )
-      }
-
--- | Invoked for all other 'CLabel's along the way, e.g. in
--- 'CmmStatic's or 'CmmExpr's.
-onAnySym :: CLabel -> WasmCodeGenM w ()
-onAnySym lbl = case sym_kind of
-  SymFunc -> wasmModifyM $ \s@WasmCodeGenState {..} ->
-    s {funcTypes = addToUniqMap_C const funcTypes sym ([], [])}
-  _ -> pure ()
-  where
-    sym = symNameFromCLabel lbl
-
-    sym_kind = symKindFromCLabel lbl
-
--- | Invoked for each 'LocalReg', returning its wasm local id and
--- representation type.
-onCmmLocalReg :: LocalReg -> WasmCodeGenM w LocalInfo
-onCmmLocalReg reg = wasmStateM $ \s@WasmCodeGenState {..} ->
-  let reg_info =
-        (localRegsCount, someWasmTypeFromCmmType $ localRegType reg)
-   in case addToUFM_L (\_ i _ -> i) reg reg_info localRegs of
-        (Just i, _) -> (# i, s #)
-        (_, localRegs') ->
-          (#
-            reg_info,
-            s
-              { localRegs = localRegs',
-                localRegsCount =
-                  localRegsCount + 1
-              }
-          #)
-
--- | Invoked for each 'LocalReg' with expected representation type,
--- only returning its wasm local id.
-onCmmLocalReg_Typed :: WasmTypeTag t -> LocalReg -> WasmCodeGenM w Int
-onCmmLocalReg_Typed ty reg = do
-  (i, SomeWasmType ty') <- onCmmLocalReg reg
-  if
-      | Just Refl <- ty' `testEquality` ty -> pure i
-      | otherwise -> panic "onCmmLocalReg_Typed: unreachable"
-
--- | Invoked for dtors. We don't bother to implement dtors yet;
--- there's no native @.fini_array@ support for wasm, and the way
--- @clang@ handles dtors is generating a ctor that calls @atexit()@
--- for dtors. Which makes some sense, but we don't need to do the same
--- thing yet.
-onFini :: [SymName] -> WasmCodeGenM w ()
-onFini syms = do
-  let n_finis = length syms
-  when (n_finis /= 0) $ panic "dtors unsupported by wasm32 NCG"
-
--- | Invoked for ctors and dtors.
-onCmmInitFini :: InitOrFini -> [CLabel] -> WasmCodeGenM w ()
-onCmmInitFini iof lbls = do
-  for_ lbls $ \lbl -> onFuncSym (symNameFromCLabel lbl) [] []
-  case iof of
-    IsInitArray -> wasmModifyM $ \s -> s {ctors = syms <> ctors s}
-    IsFiniArray -> onFini syms
-  where
-    syms = map symNameFromCLabel lbls
-
--- | Invoked for each data section.
-onCmmData :: CLabel -> Section -> [CmmStatic] -> WasmCodeGenM w ()
-onCmmData lbl s statics = do
-  ty_word <- wasmWordTypeM
-  onTopSym lbl
-  cs <- for statics lower_CmmStatic
-  let sym = symNameFromCLabel lbl
-      sec =
-        DataSection
-          { dataSectionKind =
-              dataSectionKindFromCmmSection s,
-            dataSectionAlignment =
-              alignmentFromCmmSection ty_word lbl,
-            dataSectionContents =
-              case cs of
-                [DataASCII buf] -> [DataASCII $ buf `BS.snoc` 0]
-                [DataIncBin p l] -> [DataIncBin p l, DataI8 0]
-                _ -> cs
-          }
-  wasmModifyM $ \s ->
-    s
-      { dataSections =
-          addToUniqMap (dataSections s) sym sec
-      }
-
--- | Invoked for each 'CmmProc'.
-onCmmProc :: CLabel -> CmmGraph -> WasmCodeGenM w ()
-onCmmProc lbl g = do
-  ty_word <- wasmWordCmmTypeM
-  onTopSym lbl
-  onFuncSym sym [] [ty_word]
-  body <- lower_CmmGraph lbl g
-  wasmModifyM $ \s -> s {funcBodies = addToUniqMap (funcBodies s) sym body}
-  where
-    sym = symNameFromCLabel lbl
-
--- | Invoked for each 'RawCmmDecl'.
-onCmmDecl :: RawCmmDecl -> WasmCodeGenM w ()
-onCmmDecl decl
-  | Just (iof, lbls) <- isInitOrFiniArray decl = onCmmInitFini iof lbls
-onCmmDecl (CmmData s (CmmStaticsRaw lbl statics)) = onCmmData lbl s statics
-onCmmDecl (CmmProc _ lbl _ g) = onCmmProc lbl g
-
--- | Invoked for each 'RawCmmGroup'.
-onCmmGroup :: RawCmmGroup -> WasmCodeGenM w ()
-onCmmGroup cmms = wasmStateM $ \s0 ->
-  (# (), foldl' (\s cmm -> wasmExecM (onCmmDecl cmm) s) s0 cmms #)
diff --git a/compiler/GHC/CmmToAsm/Wasm/Types.hs b/compiler/GHC/CmmToAsm/Wasm/Types.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Wasm/Types.hs
+++ /dev/null
@@ -1,452 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE Strict #-}
-{-# LANGUAGE TypeFamilyDependencies #-}
-{-# LANGUAGE UnboxedTuples #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module GHC.CmmToAsm.Wasm.Types
-  ( WasmType (..),
-    WasmTypeTag (..),
-    SomeWasmType (..),
-    TypeList (..),
-    someWasmTypesFromTypeList,
-    WasmFunctionType (..),
-    SymName (..),
-    SymVisibility (..),
-    SymKind (..),
-    DataSectionKind (..),
-    DataSectionContent (..),
-    DataSection (..),
-    GlobalInfo,
-    LocalInfo,
-    FuncBody (..),
-    Signage (..),
-    WasmInstr (..),
-    WasmExpr (..),
-    SomeWasmExpr (..),
-    WasmStatements (..),
-    WasmControl (..),
-    BrTableInterval (..),
-    wasmControlCast,
-    WasmCodeGenState (..),
-    initialWasmCodeGenState,
-    WasmCodeGenM (..),
-    wasmGetsM,
-    wasmPlatformM,
-    wasmWordTypeM,
-    wasmWordCmmTypeM,
-    wasmStateM,
-    wasmModifyM,
-    wasmExecM,
-    wasmUniq,
-  )
-where
-
-import Control.Applicative
-import Data.ByteString (ByteString)
-import Data.Coerce
-import Data.Functor
-import qualified Data.IntSet as IS
-import Data.Kind
-import Data.String
-import Data.Type.Equality
-import GHC.Cmm
-import GHC.Data.FastString
-import GHC.Float
-import GHC.Platform
-import GHC.Prelude
-import GHC.Types.Basic
-import GHC.Types.Unique
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Map
-import GHC.Types.Unique.Supply
-import GHC.Utils.Monad.State.Strict
-import GHC.Utils.Outputable hiding ((<>))
-import Unsafe.Coerce
-
--- | WebAssembly type of a WebAssembly value that WebAssembly code
--- could either expect on the evaluation stack or leave on the
--- evaluation stack.
-data WasmType = I32 | I64 | F32 | F64
-
--- | Singleton type useful for programming with `WasmType` at the type
--- level.
-data WasmTypeTag :: WasmType -> Type where
-  TagI32 :: WasmTypeTag 'I32
-  TagI64 :: WasmTypeTag 'I64
-  TagF32 :: WasmTypeTag 'F32
-  TagF64 :: WasmTypeTag 'F64
-
-deriving instance Show (WasmTypeTag t)
-
-instance TestEquality WasmTypeTag where
-  TagI32 `testEquality` TagI32 = Just Refl
-  TagI64 `testEquality` TagI64 = Just Refl
-  TagF32 `testEquality` TagF32 = Just Refl
-  TagF64 `testEquality` TagF64 = Just Refl
-  _ `testEquality` _ = Nothing
-
-data SomeWasmType where
-  SomeWasmType :: WasmTypeTag t -> SomeWasmType
-
-instance Eq SomeWasmType where
-  SomeWasmType ty0 == SomeWasmType ty1
-    | Just Refl <- ty0 `testEquality` ty1 = True
-    | otherwise = False
-
--- | List of WebAssembly types used to describe the sequence of
--- WebAssembly values that a block of code may expect on the stack or
--- leave on the stack.
-data TypeList :: [WasmType] -> Type where
-  TypeListNil :: TypeList '[]
-  TypeListCons :: WasmTypeTag t -> TypeList ts -> TypeList (t : ts)
-
-someWasmTypesFromTypeList :: TypeList ts -> [SomeWasmType]
-someWasmTypesFromTypeList TypeListNil = []
-someWasmTypesFromTypeList (ty `TypeListCons` tys) =
-  SomeWasmType ty : someWasmTypesFromTypeList tys
-
--- | The type of a WebAssembly function, loop, block, or conditional.
--- This type says what values the code expects to pop off the stack
--- and what values it promises to push.  The WebAssembly standard
--- requires that this type appear explicitly in the code.
-data WasmFunctionType pre post = WasmFunctionType {ft_pops :: TypeList pre, ft_pushes :: TypeList post}
-
--- | For simplicity, we record other metadata in 'WasmCodeGenState' by
--- need, instead of carrying them along with 'SymName'.
-newtype SymName = SymName FastString
-  deriving (Eq, IsString, Show, Uniquable) via FastString
-  deriving (Ord) via LexicalFastString
-
-data SymVisibility
-  = -- | Not defined in the current compilation unit.
-    --
-    -- @[ undefined binding=global vis=default ]@
-    SymUndefined
-  | -- | Defined, not visible to other compilation units.
-    --
-    -- @[ binding=local vis=default ]@
-    SymStatic
-  | -- | Defined, visible to other compilation units.
-    --
-    -- Adds @.hidden@ & @.globl@ directives in the output assembly.
-    --
-    -- @[ binding=global vis=hidden ]@
-    SymDefault
-
--- | Represents whether a symbol is a data symbol or a function
--- symbol. Unlike linkers for other targets, @wasm-ld@ does panic at
--- link-time if it finds symbol kind inconsistency between the
--- definition site and other use sites.
---
--- Currently we solely rely on 'isCFunctionLabel' to determine a
--- symbol's kind, but it does take extra effort to make it work. The
--- main source of inconsistency arises from hand-written Cmm sources,
--- where it's possible to refer to external entities like @xxx_info@
--- and @xxx_closure@ without explicit @import CLOSURE@ declarations.
--- The Cmm parser will implicitly assume those are foreign function
--- labels, and then this will break the WebAssembly backend. #22368
--- provides more context on this issue.
---
--- tl;dr for any GHC contributor that accidentally triggers @wasm-ld@
--- errors when hacking Cmm: whatever data symbols are used in new
--- code, just add the corresponding @import CLOSURE@ declarations at
--- the top of that Cmm file.
-data SymKind = SymData | SymFunc
-  deriving (Eq)
-
--- | WebAssembly doesn't really have proper read-only memory regions
--- yet. Neverthless we add the .rodata logic here, wasm-ld will
--- aggregate all .rodata sections into a single one, which adds
--- possibility for runtime checks later, either via a customized
--- runtime, or via code instrumentation. See
--- <https://github.com/llvm/llvm-project/blob/b296aed8ae239c20ebdd7969e978f8d2a3b9c178/lld/wasm/Writer.cpp#L856>
-data DataSectionKind = SectionData | SectionROData
-
--- | Neither Cmm or Wasm type system takes integer signedness into
--- account, therefore we always round up a 'CmmLit' to the right width
--- and handle it as an untyped integer.
-data DataSectionContent
-  = DataI8 Integer
-  | DataI16 Integer
-  | DataI32 Integer
-  | DataI64 Integer
-  | DataF32 Float
-  | DataF64 Double
-  | DataSym SymName Int
-  | DataSkip Int
-  | DataASCII ByteString
-  | DataIncBin FilePath Int
-
-data DataSection = DataSection
-  { dataSectionKind :: DataSectionKind,
-    dataSectionAlignment ::
-      Alignment,
-    dataSectionContents :: [DataSectionContent]
-  }
-
--- | We need to remember the symbols. Determinism is achieved by
--- sorting symbols before writing the assembly.
-type SymMap = UniqMap SymName
-
--- | No need to remember the symbols.
-type SymSet = IS.IntSet
-
-type GlobalInfo = (SymName, SomeWasmType)
-
-type LocalInfo = (Int, SomeWasmType)
-
-data FuncBody w = FuncBody
-  { funcLocals :: [SomeWasmType],
-    -- | Most are Cmm functions, but may also contain synthesized
-    -- function of other types, sigh.
-    funcBody :: WasmControl (WasmStatements w) (WasmExpr w w) '[] '[w]
-  }
-
-data Signage = Signed | Unsigned
-
--- | The @w@ type variable in the Wasm IR stands for "platform word
--- type", so 'TagI32' on wasm32, and 'TagI64' on wasm64. This way, we
--- can make the codegen logic work on both wasm32/wasm64 in a
--- type-safe manner.
-data WasmInstr :: WasmType -> [WasmType] -> [WasmType] -> Type where
-  WasmComment :: String -> WasmInstr w pre pre
-  WasmNop :: WasmInstr w pre pre
-  WasmDrop :: WasmInstr w (t : pre) pre
-  WasmUnreachable :: WasmInstr w pre post
-  WasmConst :: WasmTypeTag t -> Integer -> WasmInstr w pre (t : pre)
-  WasmSymConst :: SymName -> WasmInstr w pre (w : pre)
-  WasmLoad ::
-    WasmTypeTag t ->
-    Maybe Int ->
-    Signage ->
-    Int ->
-    AlignmentSpec ->
-    WasmInstr w (w : pre) (t : pre)
-  WasmStore ::
-    WasmTypeTag t ->
-    Maybe Int ->
-    Int ->
-    AlignmentSpec ->
-    WasmInstr
-      w
-      (t : w : pre)
-      pre
-  WasmGlobalGet :: WasmTypeTag t -> SymName -> WasmInstr w pre (t : pre)
-  WasmGlobalSet :: WasmTypeTag t -> SymName -> WasmInstr w (t : pre) pre
-  WasmLocalGet :: WasmTypeTag t -> Int -> WasmInstr w pre (t : pre)
-  WasmLocalSet :: WasmTypeTag t -> Int -> WasmInstr w (t : pre) pre
-  WasmLocalTee :: WasmTypeTag t -> Int -> WasmInstr w (t : pre) (t : pre)
-  WasmCCall :: SymName -> WasmInstr w pre post
-  WasmCCallIndirect ::
-    TypeList arg_tys ->
-    TypeList ret_tys ->
-    WasmInstr
-      w
-      (w : pre)
-      post
-  WasmConcat ::
-    WasmInstr w pre mid ->
-    WasmInstr w mid post ->
-    WasmInstr w pre post
-  WasmReinterpret ::
-    WasmTypeTag t0 ->
-    WasmTypeTag t1 ->
-    WasmInstr
-      w
-      (t0 : pre)
-      (t1 : pre)
-  WasmTruncSat ::
-    Signage ->
-    WasmTypeTag t0 ->
-    WasmTypeTag t1 ->
-    WasmInstr
-      w
-      (t0 : pre)
-      (t1 : pre)
-  WasmConvert ::
-    Signage ->
-    WasmTypeTag t0 ->
-    WasmTypeTag t1 ->
-    WasmInstr
-      w
-      (t0 : pre)
-      (t1 : pre)
-  WasmAdd :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
-  WasmSub :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
-  WasmMul :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
-  WasmDiv :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
-  WasmRem :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
-  WasmAnd :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
-  WasmOr :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
-  WasmXor :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
-  WasmEq :: WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)
-  WasmNe :: WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)
-  WasmLt :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)
-  WasmGt :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)
-  WasmLe :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)
-  WasmGe :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)
-  WasmShl :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
-  WasmShr :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)
-  WasmI32Extend8S :: WasmInstr w ('I32 : pre) ('I32 : pre)
-  WasmI32Extend16S :: WasmInstr w ('I32 : pre) ('I32 : pre)
-  WasmI64Extend8S :: WasmInstr w ('I64 : pre) ('I64 : pre)
-  WasmI64Extend16S :: WasmInstr w ('I64 : pre) ('I64 : pre)
-  WasmI64Extend32S :: WasmInstr w ('I64 : pre) ('I64 : pre)
-  WasmI64ExtendI32 :: Signage -> WasmInstr w ('I32 : pre) ('I64 : pre)
-  WasmI32WrapI64 :: WasmInstr w ('I64 : pre) ('I32 : pre)
-  WasmF32DemoteF64 :: WasmInstr w ('F64 : pre) ('F32 : pre)
-  WasmF64PromoteF32 :: WasmInstr w ('F32 : pre) ('F64 : pre)
-  WasmAbs :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)
-  WasmCond :: WasmInstr w pre pre -> WasmInstr w (w : pre) pre
-
-newtype WasmExpr w t = WasmExpr (forall pre. WasmInstr w pre (t : pre))
-
-data SomeWasmExpr w where
-  SomeWasmExpr :: WasmTypeTag t -> WasmExpr w t -> SomeWasmExpr w
-
-newtype WasmStatements w = WasmStatements (forall pre. WasmInstr w pre pre)
-
--- | Representation of WebAssembly control flow.
--- Normally written as
--- @
---   WasmControl s e pre post
--- @
--- Type parameter `s` is the type of (unspecified) statements.
--- It might be instantiated with an open Cmm block or with a sequence
--- of Wasm instructions.
--- Parameter `e` is the type of expressions.
--- Parameter `pre` represents the values that are expected on the
--- WebAssembly stack when the code runs, and `post` represents
--- the state of the stack on completion.
-data WasmControl :: Type -> Type -> [WasmType] -> [WasmType] -> Type where
-  WasmPush :: WasmTypeTag t -> e -> WasmControl s e stack (t : stack)
-  WasmBlock ::
-    WasmFunctionType pre post ->
-    WasmControl s e pre post ->
-    WasmControl s e pre post
-  WasmLoop ::
-    WasmFunctionType pre post ->
-    WasmControl s e pre post ->
-    WasmControl s e pre post
-  WasmIfTop ::
-    WasmFunctionType pre post ->
-    WasmControl s e pre post ->
-    WasmControl s e pre post ->
-    WasmControl s e ('I32 : pre) post
-  WasmBr :: Int -> WasmControl s e dropped destination -- not typechecked
-  WasmFallthrough :: WasmControl s e dropped destination
-  -- generates no code, but has the same type as a branch
-  WasmBrTable ::
-    e ->
-    BrTableInterval -> -- for testing
-    [Int] -> -- targets
-    Int -> -- default target
-    WasmControl s e dropped destination
-  -- invariant: the table interval is contained
-  -- within [0 .. pred (length targets)]
-  WasmReturnTop ::
-    WasmTypeTag t ->
-    WasmControl s e (t : t1star) t2star -- as per type system
-  WasmActions ::
-    s ->
-    WasmControl s e stack stack -- basic block: one entry, one exit
-  WasmSeq ::
-    WasmControl s e pre mid ->
-    WasmControl s e mid post ->
-    WasmControl s e pre post
-
-data BrTableInterval = BrTableInterval {bti_lo :: Integer, bti_count :: Integer}
-  deriving (Show)
-
-instance Outputable BrTableInterval where
-  ppr range =
-    brackets $
-      hcat
-        [integer (bti_lo range), text "..", integer hi]
-    where
-      hi = bti_lo range + bti_count range - 1
-
-wasmControlCast :: WasmControl s e pre post -> WasmControl s e pre' post'
-wasmControlCast = unsafeCoerce
-
-data WasmCodeGenState w = WasmCodeGenState
-  { -- | Target platform
-    wasmPlatform :: Platform,
-    -- | Defined symbols with 'SymDefault' visibility.
-    defaultSyms :: SymSet,
-    -- | Function types, defined or not. There may exist a function
-    -- whose type is unknown (e.g. as a function pointer), in that
-    -- case we fall back to () -> (), it's imperfect but works with
-    -- wasm-ld.
-    funcTypes :: SymMap ([SomeWasmType], [SomeWasmType]),
-    -- | Defined function bodies.
-    funcBodies :: SymMap (FuncBody w),
-    -- | Defined data sections.
-    dataSections :: SymMap DataSection,
-    -- | ctors in the current compilation unit.
-    ctors :: [SymName],
-    localRegs ::
-      UniqFM LocalReg LocalInfo,
-    localRegsCount ::
-      Int,
-    wasmUniqSupply :: UniqSupply
-  }
-
-initialWasmCodeGenState :: Platform -> UniqSupply -> WasmCodeGenState w
-initialWasmCodeGenState platform us =
-  WasmCodeGenState
-    { wasmPlatform =
-        platform,
-      defaultSyms = IS.empty,
-      funcTypes = emptyUniqMap,
-      funcBodies =
-        emptyUniqMap,
-      dataSections = emptyUniqMap,
-      ctors =
-        [],
-      localRegs = emptyUFM,
-      localRegsCount = 0,
-      wasmUniqSupply = us
-    }
-
-newtype WasmCodeGenM w a = WasmCodeGenM (State (WasmCodeGenState w) a)
-  deriving newtype (Functor, Applicative, Monad)
-
-wasmGetsM :: (WasmCodeGenState w -> a) -> WasmCodeGenM w a
-wasmGetsM = coerce . gets
-
-wasmPlatformM :: WasmCodeGenM w Platform
-wasmPlatformM = wasmGetsM wasmPlatform
-
-wasmWordTypeM :: WasmCodeGenM w (WasmTypeTag w)
-wasmWordTypeM = wasmGetsM $ \s ->
-  if target32Bit $ wasmPlatform s
-    then unsafeCoerce TagI32
-    else unsafeCoerce TagI64
-
-wasmWordCmmTypeM :: WasmCodeGenM w CmmType
-wasmWordCmmTypeM = wasmGetsM (bWord . wasmPlatform)
-
-wasmStateM ::
-  (WasmCodeGenState w -> (# a, WasmCodeGenState w #)) ->
-  WasmCodeGenM w a
-wasmStateM = coerce . State
-
-wasmModifyM :: (WasmCodeGenState w -> WasmCodeGenState w) -> WasmCodeGenM w ()
-wasmModifyM = coerce . modify
-
-wasmExecM :: WasmCodeGenM w a -> WasmCodeGenState w -> WasmCodeGenState w
-wasmExecM (WasmCodeGenM s) = execState s
-
-wasmUniq :: WasmCodeGenM w Unique
-wasmUniq = wasmStateM $
-  \s@WasmCodeGenState {..} -> case takeUniqFromSupply wasmUniqSupply of
-    (u, us) -> (# u, s {wasmUniqSupply = us} #)
diff --git a/compiler/GHC/CmmToAsm/Wasm/Utils.hs b/compiler/GHC/CmmToAsm/Wasm/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/Wasm/Utils.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Strict #-}
-
-module GHC.CmmToAsm.Wasm.Utils
-  ( naturalNarrowing,
-    widthMax,
-    detEltsUFM,
-    detEltsUniqMap,
-    builderCommas,
-  )
-where
-
-import Data.ByteString.Builder
-import Data.List (intersperse, sortOn)
-import GHC.Cmm
-import GHC.Prelude
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Map
-
-naturalNarrowing :: Width -> Integer -> Integer
-naturalNarrowing w i
-  | i < 0 = narrowS w i
-  | otherwise = narrowU w i
-
-widthMax :: Width -> Integer
-widthMax w = (1 `shiftL` widthInBits w) - 1
-
-detEltsUFM :: Ord k => UniqFM k0 (k, a) -> [(k, a)]
-detEltsUFM = sortOn fst . nonDetEltsUFM
-
-detEltsUniqMap :: Ord k => UniqMap k a -> [(k, a)]
-detEltsUniqMap = sortOn fst . nonDetEltsUniqMap
-
-builderCommas :: (a -> Builder) -> [a] -> Builder
-builderCommas f xs = mconcat (intersperse ", " (map f xs))
diff --git a/compiler/GHC/CmmToAsm/X86.hs b/compiler/GHC/CmmToAsm/X86.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/X86.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
--- | Native code generator for x86 and x86-64 architectures
-module GHC.CmmToAsm.X86
-   ( ncgX86_64
-   , ncgX86
-   )
-where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.Instr
-import GHC.CmmToAsm.Monad
-import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Types
-import GHC.Types.Basic (Alignment)
-
-import qualified GHC.CmmToAsm.X86.Instr   as X86
-import qualified GHC.CmmToAsm.X86.Ppr     as X86
-import qualified GHC.CmmToAsm.X86.CodeGen as X86
-import qualified GHC.CmmToAsm.X86.Regs    as X86
-
-ncgX86 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest
-ncgX86 = ncgX86_64
-
-
-ncgX86_64 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest
-ncgX86_64 config = NcgImpl
-   { ncgConfig                 = config
-   , cmmTopCodeGen             = X86.cmmTopCodeGen
-   , generateJumpTableForInstr = X86.generateJumpTableForInstr config
-   , getJumpDestBlockId        = X86.getJumpDestBlockId
-   , canShortcut               = X86.canShortcut
-   , shortcutStatics           = X86.shortcutStatics
-   , shortcutJump              = X86.shortcutJump
-   , pprNatCmmDeclS            = X86.pprNatCmmDecl config
-   , pprNatCmmDeclH            = X86.pprNatCmmDecl config
-   , maxSpillSlots             = X86.maxSpillSlots config
-   , allocatableRegs           = X86.allocatableRegs platform
-   , ncgAllocMoreStack         = X86.allocMoreStack platform
-   , ncgMakeFarBranches        = const id
-   , extractUnwindPoints       = X86.extractUnwindPoints
-   , invertCondBranches        = X86.invertCondBranches
-   }
-    where
-      platform = ncgPlatform config
-
--- | Instruction instance for x86 instruction set.
-instance Instruction X86.Instr where
-   regUsageOfInstr         = X86.regUsageOfInstr
-   patchRegsOfInstr        = X86.patchRegsOfInstr
-   isJumpishInstr          = X86.isJumpishInstr
-   jumpDestsOfInstr        = X86.jumpDestsOfInstr
-   patchJumpInstr          = X86.patchJumpInstr
-   mkSpillInstr            = X86.mkSpillInstr
-   mkLoadInstr             = X86.mkLoadInstr
-   takeDeltaInstr          = X86.takeDeltaInstr
-   isMetaInstr             = X86.isMetaInstr
-   mkRegRegMoveInstr       = X86.mkRegRegMoveInstr
-   takeRegRegMoveInstr     = X86.takeRegRegMoveInstr
-   mkJumpInstr             = X86.mkJumpInstr
-   mkStackAllocInstr       = X86.mkStackAllocInstr
-   mkStackDeallocInstr     = X86.mkStackDeallocInstr
-   pprInstr                = X86.pprInstr
-   mkComment               = pure . X86.COMMENT
diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs
+++ /dev/null
@@ -1,4416 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NondecreasingIndentation #-}
-{-# LANGUAGE TupleSections #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
------------------------------------------------------------------------------
---
--- Generating machine code (instruction selection)
---
--- (c) The University of Glasgow 1996-2004
---
------------------------------------------------------------------------------
-
--- This is a big module, but, if you pay attention to
--- (a) the sectioning, and (b) the type signatures, the
--- structure should not be too overwhelming.
-
-module GHC.CmmToAsm.X86.CodeGen (
-        cmmTopCodeGen,
-        generateJumpTableForInstr,
-        extractUnwindPoints,
-        invertCondBranches,
-        InstrBlock
-)
-
-where
-
--- NCG stuff:
-import GHC.Prelude
-
-import GHC.CmmToAsm.X86.Instr
-import GHC.CmmToAsm.X86.Cond
-import GHC.CmmToAsm.X86.Regs
-import GHC.CmmToAsm.X86.Ppr
-import GHC.CmmToAsm.X86.RegInfo
-
-import GHC.Platform.Regs
-import GHC.CmmToAsm.CPrim
-import GHC.CmmToAsm.Types
-import GHC.Cmm.DebugBlock
-   ( DebugBlock(..), UnwindPoint(..), UnwindTable
-   , UnwindExpr(UwReg), toUnwindExpr
-   )
-import GHC.CmmToAsm.PIC
-import GHC.CmmToAsm.Monad
-   ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat
-   , getDeltaNat, getBlockIdNat, getPicBaseNat
-   , Reg64(..), RegCode64(..), getNewReg64, localReg64
-   , getPicBaseMaybeNat, getDebugBlock, getFileId
-   , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform
-   , getCfgWeights
-   )
-import GHC.CmmToAsm.CFG
-import GHC.CmmToAsm.Format
-import GHC.CmmToAsm.Config
-import GHC.Platform.Reg
-import GHC.Platform
-
--- Our intermediate code:
-import GHC.Types.Basic
-import GHC.Cmm.BlockId
-import GHC.Unit.Types ( primUnitId )
-import GHC.Cmm.Utils
-import GHC.Cmm.Switch
-import GHC.Cmm
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.CLabel
-import GHC.Types.Tickish ( GenTickish(..) )
-import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
-
--- The rest:
-import GHC.Types.ForeignCall ( CCallConv(..) )
-import GHC.Data.OrdList
-import GHC.Utils.Outputable
-import GHC.Utils.Constants (debugIsOn)
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Data.FastString
-import GHC.Utils.Misc
-import GHC.Types.Unique.Supply ( getUniqueM )
-
-import Control.Monad
-import Data.Foldable (fold)
-import Data.Int
-import Data.Maybe
-import Data.Word
-
-import qualified Data.Map as M
-
-is32BitPlatform :: NatM Bool
-is32BitPlatform = do
-    platform <- getPlatform
-    return $ target32Bit platform
-
-expect32BitPlatform :: SDoc -> NatM ()
-expect32BitPlatform doc = do
-  is32Bit <- is32BitPlatform
-  when (not is32Bit) $
-    pprPanic "Expecting 32-bit platform" doc
-
-sse2Enabled :: NatM Bool
-sse2Enabled = do
-  config <- getConfig
-  return (ncgSseVersion config >= Just SSE2)
-
-sse4_2Enabled :: NatM Bool
-sse4_2Enabled = do
-  config <- getConfig
-  return (ncgSseVersion config >= Just SSE42)
-
-cmmTopCodeGen
-        :: RawCmmDecl
-        -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]
-
-cmmTopCodeGen (CmmProc info lab live graph) = do
-  let blocks = toBlockListEntryFirst graph
-  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
-  picBaseMb <- getPicBaseMaybeNat
-  platform <- getPlatform
-  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
-      tops = proc : concat statics
-      os   = platformOS platform
-
-  case picBaseMb of
-      Just picBase -> initializePicBase_x86 ArchX86 os picBase tops
-      Nothing -> return tops
-
-cmmTopCodeGen (CmmData sec dat) =
-  return [CmmData sec (mkAlignment 1, dat)]  -- no translation, we just use CmmStatic
-
-{- Note [Verifying basic blocks]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-   We want to guarantee a few things about the results
-   of instruction selection.
-
-   Namely that each basic blocks consists of:
-    * A (potentially empty) sequence of straight line instructions
-  followed by
-    * A (potentially empty) sequence of jump like instructions.
-
-    We can verify this by going through the instructions and
-    making sure that any non-jumpish instruction can't appear
-    after a jumpish instruction.
-
-    There are gotchas however:
-    * CALLs are strictly speaking control flow but here we care
-      not about them. Hence we treat them as regular instructions.
-
-      It's safe for them to appear inside a basic block
-      as (ignoring side effects inside the call) they will result in
-      straight line code.
-
-    * NEWBLOCK marks the start of a new basic block so can
-      be followed by any instructions.
--}
-
--- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally.
-verifyBasicBlock :: Platform -> [Instr] -> ()
-verifyBasicBlock platform instrs
-  | debugIsOn     = go False instrs
-  | otherwise     = ()
-  where
-    go _     [] = ()
-    go atEnd (i:instr)
-        = case i of
-            -- Start a new basic block
-            NEWBLOCK {} -> go False instr
-            -- Calls are not viable block terminators
-            CALL {}     | atEnd -> faultyBlockWith i
-                        | not atEnd -> go atEnd instr
-            -- All instructions ok, check if we reached the end and continue.
-            _ | not atEnd -> go (isJumpishInstr i) instr
-              -- Only jumps allowed at the end of basic blocks.
-              | otherwise -> if isJumpishInstr i
-                                then go True instr
-                                else faultyBlockWith i
-    faultyBlockWith i
-        = pprPanic "Non control flow instructions after end of basic block."
-                   (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs))
-
-basicBlockCodeGen
-        :: CmmBlock
-        -> NatM ( [NatBasicBlock Instr]
-                , [NatCmmDecl (Alignment, RawCmmStatics) Instr])
-
-basicBlockCodeGen block = do
-  let (_, nodes, tail)  = blockSplit block
-      id = entryLabel block
-      stmts = blockToList nodes
-  -- Generate location directive
-  dbg <- getDebugBlock (entryLabel block)
-  loc_instrs <- case dblSourceTick =<< dbg of
-    Just (SourceNote span name)
-      -> do fileId <- getFileId (srcSpanFile span)
-            let line = srcSpanStartLine span; col = srcSpanStartCol span
-            return $ unitOL $ LOCATION fileId line col name
-    _ -> return nilOL
-  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts
-  (!tail_instrs,_) <- stmtToInstrs mid_bid tail
-  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs
-  platform <- getPlatform
-  return $! verifyBasicBlock platform (fromOL instrs)
-  instrs' <- fold <$> traverse addSpUnwindings instrs
-  -- code generation may introduce new basic block boundaries, which
-  -- are indicated by the NEWBLOCK instruction.  We must split up the
-  -- instruction stream into basic blocks again.  Also, we extract
-  -- LDATAs here too.
-  let
-        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'
-
-        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
-          = ([], BasicBlock id instrs : blocks, statics)
-        mkBlocks (LDATA sec dat) (instrs,blocks,statics)
-          = (instrs, blocks, CmmData sec dat:statics)
-        mkBlocks instr (instrs,blocks,statics)
-          = (instr:instrs, blocks, statics)
-  return (BasicBlock id top : other_blocks, statics)
-
--- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes
--- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"
--- for details.
-addSpUnwindings :: Instr -> NatM (OrdList Instr)
-addSpUnwindings instr@(DELTA d) = do
-    config <- getConfig
-    if ncgDwarfUnwindings config
-        then do lbl <- mkAsmTempLabel <$> getUniqueM
-                let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)
-                return $ toOL [ instr, UNWIND lbl unwind ]
-        else return (unitOL instr)
-addSpUnwindings instr = return $ unitOL instr
-
-{- Note [Keeping track of the current block]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When generating instructions for Cmm we sometimes require
-the current block for things like retry loops.
-
-We also sometimes change the current block, if a MachOP
-results in branching control flow.
-
-Issues arise if we have two statements in the same block,
-which both depend on the current block id *and* change the
-basic block after them. This happens for atomic primops
-in the X86 backend where we want to update the CFG data structure
-when introducing new basic blocks.
-
-For example in #17334 we got this Cmm code:
-
-        c3Bf: // global
-            (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18);
-            (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0);
-            _s3sT::I64 = _s3sV::I64;
-            goto c3B1;
-
-This resulted in two new basic blocks being inserted:
-
-        c3Bf:
-                movl $18,%vI_n3Bo
-                movq 88(%vI_s3sQ),%rax
-                jmp _n3Bp
-        n3Bp:
-                ...
-                cmpxchgq %vI_n3Bq,88(%vI_s3sQ)
-                jne _n3Bp
-                ...
-                jmp _n3Bs
-        n3Bs:
-                ...
-                cmpxchgq %vI_n3Bt,88(%vI_s3sQ)
-                jne _n3Bs
-                ...
-                jmp _c3B1
-        ...
-
-Based on the Cmm we called stmtToInstrs we translated both atomic operations under
-the assumption they would be placed into their Cmm basic block `c3Bf`.
-However for the retry loop we introduce new labels, so this is not the case
-for the second statement.
-This resulted in a desync between the explicit control flow graph
-we construct as a separate data type and the actual control flow graph in the code.
-
-Instead we now return the new basic block if a statement causes a change
-in the current block and use the block for all following statements.
-
-For this reason genForeignCall is also split into two parts.  One for calls which
-*won't* change the basic blocks in which successive instructions will be
-placed (since they only evaluate CmmExpr, which can only contain MachOps, which
-cannot introduce basic blocks in their lowerings).  A different one for calls
-which *are* known to change the basic block.
-
--}
-
--- See Note [Keeping track of the current block] for why
--- we pass the BlockId.
-stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.
-              -> [CmmNode O O] -- ^ Cmm Statement
-              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction
-stmtsToInstrs bid stmts =
-    go bid stmts nilOL
-  where
-    go bid  []        instrs = return (instrs,bid)
-    go bid (s:stmts)  instrs = do
-      (instrs',bid') <- stmtToInstrs bid s
-      -- If the statement introduced a new block, we use that one
-      let !newBid = fromMaybe bid bid'
-      go newBid stmts (instrs `appOL` instrs')
-
--- | `bid` refers to the current block and is used to update the CFG
---   if new blocks are inserted in the control flow.
--- See Note [Keeping track of the current block] for more details.
-stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.
-             -> CmmNode e x
-             -> NatM (InstrBlock, Maybe BlockId)
-             -- ^ Instructions, and bid of new block if successive
-             -- statements are placed in a different basic block.
-stmtToInstrs bid stmt = do
-  is32Bit <- is32BitPlatform
-  platform <- getPlatform
-  case stmt of
-    CmmUnsafeForeignCall target result_regs args
-       -> genForeignCall target result_regs args bid
-
-    _ -> (,Nothing) <$> case stmt of
-      CmmComment s   -> return (unitOL (COMMENT s))
-      CmmTick {}     -> return nilOL
-
-      CmmUnwind regs -> do
-        let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable
-            to_unwind_entry (reg, expr) = M.singleton reg (fmap (toUnwindExpr platform) expr)
-        case foldMap to_unwind_entry regs of
-          tbl | M.null tbl -> return nilOL
-              | otherwise  -> do
-                  lbl <- mkAsmTempLabel <$> getUniqueM
-                  return $ unitOL $ UNWIND lbl tbl
-
-      CmmAssign reg src
-        | isFloatType ty         -> assignReg_FltCode format reg src
-        | is32Bit && isWord64 ty -> assignReg_I64Code      reg src
-        | otherwise              -> assignReg_IntCode format reg src
-          where ty = cmmRegType platform reg
-                format = cmmTypeFormat ty
-
-      CmmStore addr src _alignment
-        | isFloatType ty         -> assignMem_FltCode format addr src
-        | is32Bit && isWord64 ty -> assignMem_I64Code      addr src
-        | otherwise              -> assignMem_IntCode format addr src
-          where ty = cmmExprType platform src
-                format = cmmTypeFormat ty
-
-      CmmBranch id          -> return $ genBranch id
-
-      --We try to arrange blocks such that the likely branch is the fallthrough
-      --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.
-      CmmCondBranch arg true false _ -> genCondBranch bid true false arg
-      CmmSwitch arg ids -> genSwitch arg ids
-      CmmCall { cml_target = arg
-              , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)
-      _ ->
-        panic "stmtToInstrs: statement should have been cps'd away"
-
-
-jumpRegs :: Platform -> [GlobalReg] -> [Reg]
-jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]
-
---------------------------------------------------------------------------------
--- | 'InstrBlock's are the insn sequences generated by the insn selectors.
---      They are really trees of insns to facilitate fast appending, where a
---      left-to-right traversal yields the insns in the correct order.
---
-type InstrBlock
-        = OrdList Instr
-
-
--- | Condition codes passed up the tree.
---
-data CondCode
-        = CondCode Bool Cond InstrBlock
-
-
--- | Register's passed up the tree.  If the stix code forces the register
---      to live in a pre-decided machine register, it comes out as @Fixed@;
---      otherwise, it comes out as @Any@, and the parent can decide which
---      register to put it in.
---
-data Register
-        = Fixed Format Reg InstrBlock
-        | Any   Format (Reg -> InstrBlock)
-
-
-swizzleRegisterRep :: Register -> Format -> Register
-swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code
-swizzleRegisterRep (Any _ codefn)     format = Any   format codefn
-
-getLocalRegReg :: LocalReg -> Reg
-getLocalRegReg (LocalReg u pk)
-  = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated
-    RegVirtual (mkVirtualReg u (cmmTypeFormat pk))
-
--- | Grab the Reg for a CmmReg
-getRegisterReg :: Platform  -> CmmReg -> Reg
-
-getRegisterReg _   (CmmLocal lreg) = getLocalRegReg lreg
-
-getRegisterReg platform  (CmmGlobal mid)
-  = case globalRegMaybe platform mid of
-        Just reg -> RegReal $ reg
-        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
-        -- By this stage, the only MagicIds remaining should be the
-        -- ones which map to a real machine register on this
-        -- platform.  Hence ...
-
-
--- | Memory addressing modes passed up the tree.
-data Amode
-        = Amode AddrMode InstrBlock
-
-{-
-Now, given a tree (the argument to a CmmLoad) that references memory,
-produce a suitable addressing mode.
-
-A Rule of the Game (tm) for Amodes: use of the addr bit must
-immediately follow use of the code part, since the code part puts
-values in registers which the addr then refers to.  So you can't put
-anything in between, lest it overwrite some of those registers.  If
-you need to do some other computation between the code part and use of
-the addr bit, first store the effective address from the amode in a
-temporary, then do the other computation, and then use the temporary:
-
-    code
-    LEA amode, tmp
-    ... other computation ...
-    ... (tmp) ...
--}
-
-{-
-Note [%rip-relative addressing on x86-64]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-On x86-64 GHC produces code for use in the "small" or, when `-fPIC` is set,
-"small PIC" code models defined by the x86-64 System V ABI (section 3.5.1 of
-specification version 0.99).
-
-In general the small code model would allow us to assume that code is located
-between 0 and 2^31 - 1. However, this is not true on Windows which, due to
-high-entropy ASLR, may place the executable image anywhere in 64-bit address
-space. This is problematic since immediate operands in x86-64 are generally
-32-bit sign-extended values (with the exception of the 64-bit MOVABS encoding).
-Consequently, to avoid overflowing we use %rip-relative addressing universally.
-Since %rip-relative addressing comes essentially for free and makes linking far
-easier, we use it even on non-Windows platforms.
-
-See also: the documentation for GCC's `-mcmodel=small` flag.
--}
-
-
--- | Check whether an integer will fit in 32 bits.
---      A CmmInt is intended to be truncated to the appropriate
---      number of bits, so here we truncate it to Int64.  This is
---      important because e.g. -1 as a CmmInt might be either
---      -1 or 18446744073709551615.
---
-is32BitInteger :: Integer -> Bool
-is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000
-  where i64 = fromIntegral i :: Int64
-
-
--- | Convert a BlockId to some CmmStatic data
-jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic
-jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config))
-jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
-    where blockLabel = blockLbl blockid
-
-
--- -----------------------------------------------------------------------------
--- General things for putting together code sequences
-
--- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
--- CmmExprs into CmmRegOff?
-mangleIndexTree :: Platform -> CmmReg -> Int -> CmmExpr
-mangleIndexTree platform reg off
-  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
-  where width = typeWidth (cmmRegType platform reg)
-
--- | The dual to getAnyReg: compute an expression into a register, but
---      we don't mind which one it is.
-getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
-getSomeReg expr = do
-  r <- getRegister expr
-  case r of
-    Any rep code -> do
-        tmp <- getNewRegNat rep
-        return (tmp, code tmp)
-    Fixed _ reg code ->
-        return (reg, code)
-
-
-assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
-assignMem_I64Code addrTree valueTree = do
-  Amode addr addr_code <- getAmode addrTree
-  RegCode64 vcode rhi rlo <- iselExpr64 valueTree
-  let
-        -- Little-endian store
-        mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)
-        mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))
-  return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
-
-
-assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
-assignReg_I64Code (CmmLocal dst) valueTree = do
-   RegCode64 vcode r_src_hi r_src_lo <- iselExpr64 valueTree
-   let
-         Reg64 r_dst_hi r_dst_lo = localReg64 dst
-         mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)
-         mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)
-   return (
-        vcode `snocOL` mov_lo `snocOL` mov_hi
-     )
-
-assignReg_I64Code _ _
-   = panic "assignReg_I64Code(i386): invalid lvalue"
-
-
-iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)
-iselExpr64 (CmmLit (CmmInt i _)) = do
-  Reg64 rhi rlo <- getNewReg64
-  let
-        r = fromIntegral (fromIntegral i :: Word32)
-        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)
-        code = toOL [
-                MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),
-                MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)
-                ]
-  return (RegCode64 code rhi rlo)
-
-iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do
-   Amode addr addr_code <- getAmode addrTree
-   Reg64 rhi rlo <- getNewReg64
-   let
-        mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)
-        mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)
-   return (
-            RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rhi rlo
-     )
-
-iselExpr64 (CmmReg (CmmLocal local_reg)) = do
-  let Reg64 hi lo = localReg64 local_reg
-  return (RegCode64 nilOL hi lo)
-
--- we handle addition, but rather badly
-iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do
-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1
-   Reg64 rhi rlo <- getNewReg64
-   let
-        r = fromIntegral (fromIntegral i :: Word32)
-        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)
-        code =  code1 `appOL`
-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
-                       ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),
-                       MOV II32 (OpReg r1hi) (OpReg rhi),
-                       ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]
-   return (RegCode64 code rhi rlo)
-
-iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1
-   RegCode64 code2 r2hi r2lo <- iselExpr64 e2
-   Reg64 rhi rlo <- getNewReg64
-   let
-        code =  code1 `appOL`
-                code2 `appOL`
-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
-                       ADD II32 (OpReg r2lo) (OpReg rlo),
-                       MOV II32 (OpReg r1hi) (OpReg rhi),
-                       ADC II32 (OpReg r2hi) (OpReg rhi) ]
-   return (RegCode64 code rhi rlo)
-
-iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do
-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1
-   RegCode64 code2 r2hi r2lo <- iselExpr64 e2
-   Reg64 rhi rlo <- getNewReg64
-   let
-        code =  code1 `appOL`
-                code2 `appOL`
-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
-                       SUB II32 (OpReg r2lo) (OpReg rlo),
-                       MOV II32 (OpReg r1hi) (OpReg rhi),
-                       SBB II32 (OpReg r2hi) (OpReg rhi) ]
-   return (RegCode64 code rhi rlo)
-
-iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do
-     code <- getAnyReg expr
-     Reg64 r_dst_hi r_dst_lo <- getNewReg64
-     return $ RegCode64 (code r_dst_lo `snocOL`
-                          MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))
-                          r_dst_hi
-                          r_dst_lo
-
-iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do
-     code <- getAnyReg expr
-     Reg64 r_dst_hi r_dst_lo <- getNewReg64
-     return $ RegCode64 (code r_dst_lo `snocOL`
-                          MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL`
-                          CLTD II32 `snocOL`
-                          MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL`
-                          MOV II32 (OpReg edx) (OpReg r_dst_hi))
-                          r_dst_hi
-                          r_dst_lo
-
-iselExpr64 expr
-   = do
-      platform <- getPlatform
-      pprPanic "iselExpr64(i386)" (pdoc platform expr)
-
-
---------------------------------------------------------------------------------
-getRegister :: CmmExpr -> NatM Register
-getRegister e = do platform <- getPlatform
-                   is32Bit <- is32BitPlatform
-                   getRegister' platform is32Bit e
-
-getRegister' :: Platform -> Bool -> CmmExpr -> NatM Register
-
-getRegister' platform is32Bit (CmmReg reg)
-  = case reg of
-        CmmGlobal PicBaseReg
-         | is32Bit ->
-            -- on x86_64, we have %rip for PicBaseReg, but it's not
-            -- a full-featured register, it can only be used for
-            -- rip-relative addressing.
-            do reg' <- getPicBaseNat (archWordFormat is32Bit)
-               return (Fixed (archWordFormat is32Bit) reg' nilOL)
-        _ ->
-            do
-               let
-                 fmt = cmmTypeFormat (cmmRegType platform reg)
-                 format  = fmt
-               --
-               platform <- ncgPlatform <$> getConfig
-               return (Fixed format
-                             (getRegisterReg platform reg)
-                             nilOL)
-
-
-getRegister' platform is32Bit (CmmRegOff r n)
-  = getRegister' platform is32Bit $ mangleIndexTree platform r n
-
-getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])
-  = addAlignmentCheck align <$> getRegister' platform is32Bit e
-
--- for 32-bit architectures, support some 64 -> 32 bit conversions:
--- TO_W_(x), TO_W_(x >> 32)
-
-getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)
-                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
- | is32Bit = do
-  RegCode64 code rhi _rlo <- iselExpr64 x
-  return $ Fixed II32 rhi code
-
-getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32)
-                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
- | is32Bit = do
-  RegCode64 code rhi _rlo <- iselExpr64 x
-  return $ Fixed II32 rhi code
-
-getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])
- | is32Bit = do
-  RegCode64 code _rhi rlo <- iselExpr64 x
-  return $ Fixed II32 rlo code
-
-getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])
- | is32Bit = do
-  RegCode64 code _rhi rlo <- iselExpr64 x
-  return $ Fixed II32 rlo code
-
-getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =
-  float_const_sse2  where
-  float_const_sse2
-    | f == 0.0 = do
-      let
-          format = floatFormat w
-          code dst = unitOL  (XOR format (OpReg dst) (OpReg dst))
-        -- I don't know why there are xorpd, xorps, and pxor instructions.
-        -- They all appear to do the same thing --SDM
-      return (Any format code)
-
-   | otherwise = do
-      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit
-      loadFloatAmode w addr code
-
--- catch simple cases of zero- or sign-extended load
-getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _ _]) = do
-  code <- intLoadCode (MOVZxL II8) addr
-  return (Any II32 code)
-
-getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _ _]) = do
-  code <- intLoadCode (MOVSxL II8) addr
-  return (Any II32 code)
-
-getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _ _]) = do
-  code <- intLoadCode (MOVZxL II16) addr
-  return (Any II32 code)
-
-getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _ _]) = do
-  code <- intLoadCode (MOVSxL II16) addr
-  return (Any II32 code)
-
--- catch simple cases of zero- or sign-extended load
-getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _ _])
- | not is32Bit = do
-  code <- intLoadCode (MOVZxL II8) addr
-  return (Any II64 code)
-
-getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _ _])
- | not is32Bit = do
-  code <- intLoadCode (MOVSxL II8) addr
-  return (Any II64 code)
-
-getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _ _])
- | not is32Bit = do
-  code <- intLoadCode (MOVZxL II16) addr
-  return (Any II64 code)
-
-getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _ _])
- | not is32Bit = do
-  code <- intLoadCode (MOVSxL II16) addr
-  return (Any II64 code)
-
-getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _ _])
- | not is32Bit = do
-  code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend
-  return (Any II64 code)
-
-getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _ _])
- | not is32Bit = do
-  code <- intLoadCode (MOVSxL II32) addr
-  return (Any II64 code)
-
-getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),
-                                     CmmLit displacement])
- | not is32Bit =
-      return $ Any II64 (\dst -> unitOL $
-        LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))
-
-getRegister' platform is32Bit (CmmMachOp mop [x]) = -- unary MachOps
-    case mop of
-      MO_F_Neg w  -> sse2NegCode w x
-
-
-      MO_S_Neg w -> triv_ucode NEGI (intFormat w)
-      MO_Not w   -> triv_ucode NOT  (intFormat w)
-
-      -- Nop conversions
-      MO_UU_Conv W32 W8  -> toI8Reg  W32 x
-      MO_SS_Conv W32 W8  -> toI8Reg  W32 x
-      MO_XX_Conv W32 W8  -> toI8Reg  W32 x
-      MO_UU_Conv W16 W8  -> toI8Reg  W16 x
-      MO_SS_Conv W16 W8  -> toI8Reg  W16 x
-      MO_XX_Conv W16 W8  -> toI8Reg  W16 x
-      MO_UU_Conv W32 W16 -> toI16Reg W32 x
-      MO_SS_Conv W32 W16 -> toI16Reg W32 x
-      MO_XX_Conv W32 W16 -> toI16Reg W32 x
-
-      MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x
-      MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x
-      MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x
-      MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x
-      MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x
-      MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x
-      MO_UU_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x
-      MO_SS_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x
-      MO_XX_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x
-
-      MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x
-      MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x
-      MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x
-
-      -- widenings
-      MO_UU_Conv W8  W32 -> integerExtend W8  W32 MOVZxL x
-      MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x
-      MO_UU_Conv W8  W16 -> integerExtend W8  W16 MOVZxL x
-
-      MO_SS_Conv W8  W32 -> integerExtend W8  W32 MOVSxL x
-      MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x
-      MO_SS_Conv W8  W16 -> integerExtend W8  W16 MOVSxL x
-
-      -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we
-      -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register
-      -- has 8-bit version). So for 32-bit code, we'll just zero-extend.
-      MO_XX_Conv W8  W32
-          | is32Bit   -> integerExtend W8 W32 MOVZxL x
-          | otherwise -> integerExtend W8 W32 MOV x
-      MO_XX_Conv W8  W16
-          | is32Bit   -> integerExtend W8 W16 MOVZxL x
-          | otherwise -> integerExtend W8 W16 MOV x
-      MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x
-
-      MO_UU_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVZxL x
-      MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x
-      MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x
-      MO_SS_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVSxL x
-      MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x
-      MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x
-      -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.
-      -- However, we don't want the register allocator to throw it
-      -- away as an unnecessary reg-to-reg move, so we keep it in
-      -- the form of a movzl and print it as a movl later.
-      -- This doesn't apply to MO_XX_Conv since in this case we don't care about
-      -- the upper bits. So we can just use MOV.
-      MO_XX_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOV x
-      MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x
-      MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x
-
-      MO_FF_Conv W32 W64 -> coerceFP2FP W64 x
-
-
-      MO_FF_Conv W64 W32 -> coerceFP2FP W32 x
-
-      MO_FS_Conv from to -> coerceFP2Int from to x
-      MO_SF_Conv from to -> coerceInt2FP from to x
-
-      MO_V_Insert {}   -> needLlvm
-      MO_V_Extract {}  -> needLlvm
-      MO_V_Add {}      -> needLlvm
-      MO_V_Sub {}      -> needLlvm
-      MO_V_Mul {}      -> needLlvm
-      MO_VS_Quot {}    -> needLlvm
-      MO_VS_Rem {}     -> needLlvm
-      MO_VS_Neg {}     -> needLlvm
-      MO_VU_Quot {}    -> needLlvm
-      MO_VU_Rem {}     -> needLlvm
-      MO_VF_Insert {}  -> needLlvm
-      MO_VF_Extract {} -> needLlvm
-      MO_VF_Add {}     -> needLlvm
-      MO_VF_Sub {}     -> needLlvm
-      MO_VF_Mul {}     -> needLlvm
-      MO_VF_Quot {}    -> needLlvm
-      MO_VF_Neg {}     -> needLlvm
-
-      _other -> pprPanic "getRegister" (pprMachOp mop)
-   where
-        triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register
-        triv_ucode instr format = trivialUCode format (instr format) x
-
-        -- signed or unsigned extension.
-        integerExtend :: Width -> Width
-                      -> (Format -> Operand -> Operand -> Instr)
-                      -> CmmExpr -> NatM Register
-        integerExtend from to instr expr = do
-            (reg,e_code) <- if from == W8 then getByteReg expr
-                                          else getSomeReg expr
-            let
-                code dst =
-                  e_code `snocOL`
-                  instr (intFormat from) (OpReg reg) (OpReg dst)
-            return (Any (intFormat to) code)
-
-        toI8Reg :: Width -> CmmExpr -> NatM Register
-        toI8Reg new_rep expr
-            = do codefn <- getAnyReg expr
-                 return (Any (intFormat new_rep) codefn)
-                -- HACK: use getAnyReg to get a byte-addressable register.
-                -- If the source was a Fixed register, this will add the
-                -- mov instruction to put it into the desired destination.
-                -- We're assuming that the destination won't be a fixed
-                -- non-byte-addressable register; it won't be, because all
-                -- fixed registers are word-sized.
-
-        toI16Reg = toI8Reg -- for now
-
-        conversionNop :: Format -> CmmExpr -> NatM Register
-        conversionNop new_format expr
-            = do e_code <- getRegister' platform is32Bit expr
-                 return (swizzleRegisterRep e_code new_format)
-
-
-getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps
-  case mop of
-      MO_F_Eq _ -> condFltReg is32Bit EQQ x y
-      MO_F_Ne _ -> condFltReg is32Bit NE  x y
-      MO_F_Gt _ -> condFltReg is32Bit GTT x y
-      MO_F_Ge _ -> condFltReg is32Bit GE  x y
-      -- Invert comparison condition and swap operands
-      -- See Note [SSE Parity Checks]
-      MO_F_Lt _ -> condFltReg is32Bit GTT  y x
-      MO_F_Le _ -> condFltReg is32Bit GE   y x
-
-      MO_Eq _   -> condIntReg EQQ x y
-      MO_Ne _   -> condIntReg NE  x y
-
-      MO_S_Gt _ -> condIntReg GTT x y
-      MO_S_Ge _ -> condIntReg GE  x y
-      MO_S_Lt _ -> condIntReg LTT x y
-      MO_S_Le _ -> condIntReg LE  x y
-
-      MO_U_Gt _ -> condIntReg GU  x y
-      MO_U_Ge _ -> condIntReg GEU x y
-      MO_U_Lt _ -> condIntReg LU  x y
-      MO_U_Le _ -> condIntReg LEU x y
-
-      MO_F_Add w   -> trivialFCode_sse2 w ADD  x y
-
-      MO_F_Sub w   -> trivialFCode_sse2 w SUB  x y
-
-      MO_F_Quot w  -> trivialFCode_sse2 w FDIV x y
-
-      MO_F_Mul w   -> trivialFCode_sse2 w MUL x y
-
-
-      MO_Add rep -> add_code rep x y
-      MO_Sub rep -> sub_code rep x y
-
-      MO_S_Quot rep -> div_code rep True  True  x y
-      MO_S_Rem  rep -> div_code rep True  False x y
-      MO_U_Quot rep -> div_code rep False True  x y
-      MO_U_Rem  rep -> div_code rep False False x y
-
-      MO_S_MulMayOflo rep -> imulMayOflo rep x y
-
-      MO_Mul W8  -> imulW8 x y
-      MO_Mul rep -> triv_op rep IMUL
-      MO_And rep -> triv_op rep AND
-      MO_Or  rep -> triv_op rep OR
-      MO_Xor rep -> triv_op rep XOR
-
-        {- Shift ops on x86s have constraints on their source, it
-           either has to be Imm, CL or 1
-            => trivialCode is not restrictive enough (sigh.)
-        -}
-      MO_Shl rep   -> shift_code rep SHL x y {-False-}
-      MO_U_Shr rep -> shift_code rep SHR x y {-False-}
-      MO_S_Shr rep -> shift_code rep SAR x y {-False-}
-
-      MO_V_Insert {}   -> needLlvm
-      MO_V_Extract {}  -> needLlvm
-      MO_V_Add {}      -> needLlvm
-      MO_V_Sub {}      -> needLlvm
-      MO_V_Mul {}      -> needLlvm
-      MO_VS_Quot {}    -> needLlvm
-      MO_VS_Rem {}     -> needLlvm
-      MO_VS_Neg {}     -> needLlvm
-      MO_VF_Insert {}  -> needLlvm
-      MO_VF_Extract {} -> needLlvm
-      MO_VF_Add {}     -> needLlvm
-      MO_VF_Sub {}     -> needLlvm
-      MO_VF_Mul {}     -> needLlvm
-      MO_VF_Quot {}    -> needLlvm
-      MO_VF_Neg {}     -> needLlvm
-
-      _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)
-  where
-    --------------------
-    triv_op width instr = trivialCode width op (Just op) x y
-                        where op   = instr (intFormat width)
-
-    -- Special case for IMUL for bytes, since the result of IMULB will be in
-    -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider
-    -- values.
-    imulW8 :: CmmExpr -> CmmExpr -> NatM Register
-    imulW8 arg_a arg_b = do
-        (a_reg, a_code) <- getNonClobberedReg arg_a
-        b_code <- getAnyReg arg_b
-
-        let code = a_code `appOL` b_code eax `appOL`
-                   toOL [ IMUL2 format (OpReg a_reg) ]
-            format = intFormat W8
-
-        return (Fixed format eax code)
-
-
-    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
-    imulMayOflo rep a b = do
-         (a_reg, a_code) <- getNonClobberedReg a
-         b_code <- getAnyReg b
-         let
-             shift_amt  = case rep of
-                           W32 -> 31
-                           W64 -> 63
-                           _ -> panic "shift_amt"
-
-             format = intFormat rep
-             code = a_code `appOL` b_code eax `appOL`
-                        toOL [
-                           IMUL2 format (OpReg a_reg),   -- result in %edx:%eax
-                           SAR format (OpImm (ImmInt shift_amt)) (OpReg eax),
-                                -- sign extend lower part
-                           SUB format (OpReg edx) (OpReg eax)
-                                -- compare against upper
-                           -- eax==0 if high part == sign extended low part
-                        ]
-         return (Fixed format eax code)
-
-    --------------------
-    shift_code :: Width
-               -> (Format -> Operand -> Operand -> Instr)
-               -> CmmExpr
-               -> CmmExpr
-               -> NatM Register
-
-    {- Case1: shift length as immediate -}
-    shift_code width instr x (CmmLit lit)
-      -- Handle the case of a shift larger than the width of the shifted value.
-      -- This is necessary since x86 applies a mask of 0x1f to the shift
-      -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by
-      -- `47 & 0x1f == 15`. See #20626.
-      | CmmInt n _ <- lit
-      , n >= fromIntegral (widthInBits width)
-      = getRegister $ CmmLit $ CmmInt 0 width
-
-      | otherwise = do
-          x_code <- getAnyReg x
-          let
-               format = intFormat width
-               code dst
-                  = x_code dst `snocOL`
-                    instr format (OpImm (litToImm lit)) (OpReg dst)
-          return (Any format code)
-
-    {- Case2: shift length is complex (non-immediate)
-      * y must go in %ecx.
-      * we cannot do y first *and* put its result in %ecx, because
-        %ecx might be clobbered by x.
-      * if we do y second, then x cannot be
-        in a clobbered reg.  Also, we cannot clobber x's reg
-        with the instruction itself.
-      * so we can either:
-        - do y first, put its result in a fresh tmp, then copy it to %ecx later
-        - do y second and put its result into %ecx.  x gets placed in a fresh
-          tmp.  This is likely to be better, because the reg alloc can
-          eliminate this reg->reg move here (it won't eliminate the other one,
-          because the move is into the fixed %ecx).
-      * in the case of C calls the use of ecx here can interfere with arguments.
-        We avoid this with the hack described in Note [Evaluate C-call
-        arguments before placing in destination registers]
-    -}
-    shift_code width instr x y{-amount-} = do
-        x_code <- getAnyReg x
-        let format = intFormat width
-        tmp <- getNewRegNat format
-        y_code <- getAnyReg y
-        let
-           code = x_code tmp `appOL`
-                  y_code ecx `snocOL`
-                  instr format (OpReg ecx) (OpReg tmp)
-        return (Fixed format tmp code)
-
-    --------------------
-    add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
-    -- x + imm
-    add_code rep x (CmmLit (CmmInt y _))
-        | is32BitInteger y
-        , rep /= W8 -- LEA doesn't support byte size (#18614)
-        = add_int rep x y
-    -- x + (y << imm)
-    add_code rep x y
-        -- Byte size is not supported and 16bit size is slow when computed via LEA
-        | rep /= W8 && rep /= W16
-        -- 2^3 = 8 is the highest multiplicator supported by LEA.
-        , Just (x,y,shift_bits) <- get_shift x y
-        = add_shiftL rep x y (fromIntegral shift_bits)
-        where
-          -- x + (y << imm)
-          get_shift x (CmmMachOp (MO_Shl _w) [y, CmmLit (CmmInt shift_bits _)])
-            | shift_bits <= 3
-            = Just (x, y, shift_bits)
-          -- (y << imm) + x
-          get_shift (CmmMachOp (MO_Shl _w) [y, CmmLit (CmmInt shift_bits _)]) x
-            | shift_bits <= 3
-            = Just (x, y, shift_bits)
-          get_shift _ _
-            = Nothing
-    add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y
-      where format = intFormat rep
-    -- TODO: There are other interesting patterns we want to replace
-    --     with a LEA, e.g. `(x + offset) + (y << shift)`.
-
-    --------------------
-    sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
-    sub_code rep x (CmmLit (CmmInt y _))
-        | is32BitInteger (-y)
-        , rep /= W8 -- LEA doesn't support byte size (#18614)
-        = add_int rep x (-y)
-    sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y
-
-    -- our three-operand add instruction:
-    add_int :: (Width -> CmmExpr -> Integer -> NatM Register)
-    add_int width x y = do
-        (x_reg, x_code) <- getSomeReg x
-        let
-            format = intFormat width
-            imm = ImmInt (fromInteger y)
-            code dst
-               = x_code `snocOL`
-                 LEA format
-                        (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))
-                        (OpReg dst)
-        --
-        return (Any format code)
-
-    -- x + (y << shift_bits) using LEA
-    add_shiftL :: (Width -> CmmExpr -> CmmExpr -> Int -> NatM Register)
-    add_shiftL width x y shift_bits = do
-        (x_reg, x_code) <- getSomeReg x
-        (y_reg, y_code) <- getSomeReg y
-        let
-            format = intFormat width
-            imm = ImmInt 0
-            code dst
-               = (x_code `appOL` y_code) `snocOL`
-                 LEA format
-                        (OpAddr (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg (2 ^ shift_bits)) imm))
-                        (OpReg dst)
-        --
-        return (Any format code)
-
-    ----------------------
-
-    -- See Note [DIV/IDIV for bytes]
-    div_code W8 signed quotient x y = do
-        let widen | signed    = MO_SS_Conv W8 W16
-                  | otherwise = MO_UU_Conv W8 W16
-        div_code
-            W16
-            signed
-            quotient
-            (CmmMachOp widen [x])
-            (CmmMachOp widen [y])
-
-    div_code width signed quotient x y = do
-           (y_op, y_code) <- getRegOrMem y -- cannot be clobbered
-           x_code <- getAnyReg x
-           let
-             format = intFormat width
-             widen | signed    = CLTD format
-                   | otherwise = XOR format (OpReg edx) (OpReg edx)
-
-             instr | signed    = IDIV
-                   | otherwise = DIV
-
-             code = y_code `appOL`
-                    x_code eax `appOL`
-                    toOL [widen, instr format y_op]
-
-             result | quotient  = eax
-                    | otherwise = edx
-
-           return (Fixed format result code)
-
-
-getRegister' _ _ (CmmLoad mem pk _)
-  | isFloatType pk
-  = do
-    Amode addr mem_code <- getAmode mem
-    loadFloatAmode  (typeWidth pk) addr mem_code
-
-getRegister' _ is32Bit (CmmLoad mem pk _)
-  | is32Bit && not (isWord64 pk)
-  = do
-    code <- intLoadCode instr mem
-    return (Any format code)
-  where
-    width = typeWidth pk
-    format = intFormat width
-    instr = case width of
-                W8     -> MOVZxL II8
-                _other -> MOV format
-        -- We always zero-extend 8-bit loads, if we
-        -- can't think of anything better.  This is because
-        -- we can't guarantee access to an 8-bit variant of every register
-        -- (esi and edi don't have 8-bit variants), so to make things
-        -- simpler we do our 8-bit arithmetic with full 32-bit registers.
-
--- Simpler memory load code on x86_64
-getRegister' _ is32Bit (CmmLoad mem pk _)
- | not is32Bit
-  = do
-    code <- intLoadCode (MOV format) mem
-    return (Any format code)
-  where format = intFormat $ typeWidth pk
-
-getRegister' _ is32Bit (CmmLit (CmmInt 0 width))
-  = let
-        format = intFormat width
-
-        -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits
-        format1 = if is32Bit then format
-                           else case format of
-                                II64 -> II32
-                                _ -> format
-        code dst
-           = unitOL (XOR format1 (OpReg dst) (OpReg dst))
-    in
-        return (Any format code)
-
--- Handle symbol references with LEA and %rip-relative addressing.
--- See Note [%rip-relative addressing on x86-64].
-getRegister' platform is32Bit (CmmLit lit)
-  | is_label lit
-  , not is32Bit
-  = do let format = cmmTypeFormat (cmmLitType platform lit)
-           imm = litToImm lit
-           op = OpAddr (AddrBaseIndex EABaseRip EAIndexNone imm)
-           code dst = unitOL (LEA format op (OpReg dst))
-       return (Any format code)
-  where
-    is_label (CmmLabel {})        = True
-    is_label (CmmLabelOff {})     = True
-    is_label (CmmLabelDiffOff {}) = True
-    is_label _                    = False
-
-  -- optimisation for loading small literals on x86_64: take advantage
-  -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit
-  -- instruction forms are shorter.
-getRegister' platform is32Bit (CmmLit lit)
-  | not is32Bit, isWord64 (cmmLitType platform lit), not (isBigLit lit)
-  = let
-        imm = litToImm lit
-        code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))
-    in
-        return (Any II64 code)
-  where
-   isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff
-   isBigLit _ = False
-        -- note1: not the same as (not.is32BitLit), because that checks for
-        -- signed literals that fit in 32 bits, but we want unsigned
-        -- literals here.
-        -- note2: all labels are small, because we're assuming the
-        -- small memory model. See Note [%rip-relative addressing on x86-64].
-
-getRegister' platform _ (CmmLit lit)
-  = do let format = cmmTypeFormat (cmmLitType platform lit)
-           imm = litToImm lit
-           code dst = unitOL (MOV format (OpImm imm) (OpReg dst))
-       return (Any format code)
-
-getRegister' platform _ other
-    | isVecExpr other  = needLlvm
-    | otherwise        = pprPanic "getRegister(x86)" (pdoc platform other)
-
-
-intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr
-   -> NatM (Reg -> InstrBlock)
-intLoadCode instr mem = do
-  Amode src mem_code <- getAmode mem
-  return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))
-
--- Compute an expression into *any* register, adding the appropriate
--- move instruction if necessary.
-getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)
-getAnyReg expr = do
-  r <- getRegister expr
-  anyReg r
-
-anyReg :: Register -> NatM (Reg -> InstrBlock)
-anyReg (Any _ code)          = return code
-anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)
-
--- A bit like getSomeReg, but we want a reg that can be byte-addressed.
--- Fixed registers might not be byte-addressable, so we make sure we've
--- got a temporary, inserting an extra reg copy if necessary.
-getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)
-getByteReg expr = do
-  is32Bit <- is32BitPlatform
-  if is32Bit
-      then do r <- getRegister expr
-              case r of
-                Any rep code -> do
-                    tmp <- getNewRegNat rep
-                    return (tmp, code tmp)
-                Fixed rep reg code
-                    | isVirtualReg reg -> return (reg,code)
-                    | otherwise -> do
-                        tmp <- getNewRegNat rep
-                        return (tmp, code `snocOL` reg2reg rep reg tmp)
-                    -- ToDo: could optimise slightly by checking for
-                    -- byte-addressable real registers, but that will
-                    -- happen very rarely if at all.
-      else getSomeReg expr -- all regs are byte-addressable on x86_64
-
--- Another variant: this time we want the result in a register that cannot
--- be modified by code to evaluate an arbitrary expression.
-getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)
-getNonClobberedReg expr = do
-  r <- getRegister expr
-  platform <- ncgPlatform <$> getConfig
-  case r of
-    Any rep code -> do
-        tmp <- getNewRegNat rep
-        return (tmp, code tmp)
-    Fixed rep reg code
-        -- only certain regs can be clobbered
-        | reg `elem` instrClobberedRegs platform
-        -> do
-                tmp <- getNewRegNat rep
-                return (tmp, code `snocOL` reg2reg rep reg tmp)
-        | otherwise ->
-                return (reg, code)
-
-reg2reg :: Format -> Reg -> Reg -> Instr
-reg2reg format src dst = MOV format (OpReg src) (OpReg dst)
-
-
---------------------------------------------------------------------------------
-
--- | Convert a 'CmmExpr' representing a memory address into an 'Amode'.
---
--- An 'Amode' is a datatype representing a valid address form for the target
--- (e.g. "Base + Index + disp" or immediate) and the code to compute it.
-getAmode :: CmmExpr -> NatM Amode
-getAmode e = do
-   platform <- getPlatform
-   let is32Bit = target32Bit platform
-
-   case e of
-      CmmRegOff r n
-         -> getAmode $ mangleIndexTree platform r n
-
-      CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]
-         | not is32Bit
-         -> return $ Amode (ripRel (litToImm displacement)) nilOL
-
-      -- This is all just ridiculous, since it carefully undoes
-      -- what mangleIndexTree has just done.
-      CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]
-         | is32BitLit platform lit
-         -- assert (rep == II32)???
-         -> do
-            (x_reg, x_code) <- getSomeReg x
-            let off = ImmInt (-(fromInteger i))
-            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)
-
-      CmmMachOp (MO_Add _rep) [x, CmmLit lit]
-         | is32BitLit platform lit
-         -- assert (rep == II32)???
-         -> do
-            (x_reg, x_code) <- getSomeReg x
-            let off = litToImm lit
-            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)
-
-      -- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be
-      -- recognised by the next rule.
-      CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)]
-         -> getAmode (CmmMachOp (MO_Add rep) [b,a])
-
-      -- Matches: (x + offset) + (y << shift)
-      CmmMachOp (MO_Add _) [CmmRegOff x offset, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]
-         | shift == 0 || shift == 1 || shift == 2 || shift == 3
-         -> x86_complex_amode (CmmReg x) y shift (fromIntegral offset)
-
-      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]
-         | shift == 0 || shift == 1 || shift == 2 || shift == 3
-         -> x86_complex_amode x y shift 0
-
-      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _)
-                                                    [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]]
-         | shift == 0 || shift == 1 || shift == 2 || shift == 3
-         && is32BitInteger offset
-         -> x86_complex_amode x y shift offset
-
-      CmmMachOp (MO_Add _) [x,y]
-         | not (isLit y) -- we already handle valid literals above.
-         -> x86_complex_amode x y 0 0
-
-      -- Handle labels with %rip-relative addressing since in general the image
-      -- may be loaded anywhere in the 64-bit address space (e.g. on Windows
-      -- with high-entropy ASLR). See Note [%rip-relative addressing on x86-64].
-      CmmLit lit
-         | not is32Bit
-         , is_label lit
-         -> return (Amode (AddrBaseIndex EABaseRip EAIndexNone (litToImm lit)) nilOL)
-
-      CmmLit lit
-         | is32BitLit platform lit
-         -> return (Amode (ImmAddr (litToImm lit) 0) nilOL)
-
-      -- Literal with offsets too big (> 32 bits) fails during the linking phase
-      -- (#15570). We already handled valid literals above so we don't have to
-      -- test anything here.
-      CmmLit (CmmLabelOff l off)
-         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabel l)
-                                             , CmmLit (CmmInt (fromIntegral off) W64)
-                                             ])
-      CmmLit (CmmLabelDiffOff l1 l2 off w)
-         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabelDiffOff l1 l2 0 w)
-                                             , CmmLit (CmmInt (fromIntegral off) W64)
-                                             ])
-
-      -- in case we can't do something better, we just compute the expression
-      -- and put the result in a register
-      _ -> do
-        (reg,code) <- getSomeReg e
-        return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)
-  where
-    is_label (CmmLabel{}) = True
-    is_label (CmmLabelOff{}) = True
-    is_label (CmmLabelDiffOff{}) = True
-    is_label _ = False
-
-
--- | Like 'getAmode', but on 32-bit use simple register addressing
--- (i.e. no index register). This stops us from running out of
--- registers on x86 when using instructions such as cmpxchg, which can
--- use up to three virtual registers and one fixed register.
-getSimpleAmode :: CmmExpr -> NatM Amode
-getSimpleAmode addr = is32BitPlatform >>= \case
-  False -> getAmode addr
-  True  -> do
-    addr_code <- getAnyReg addr
-    config <- getConfig
-    addr_r <- getNewRegNat (intFormat (ncgWordWidth config))
-    let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0)
-    return $! Amode amode (addr_code addr_r)
-
-x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode
-x86_complex_amode base index shift offset
-  = do (x_reg, x_code) <- getNonClobberedReg base
-        -- x must be in a temp, because it has to stay live over y_code
-        -- we could compare x_reg and y_reg and do something better here...
-       (y_reg, y_code) <- getSomeReg index
-       let
-           code = x_code `appOL` y_code
-           base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;
-                                n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"
-       return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))
-               code)
-
-
-
-
--- -----------------------------------------------------------------------------
--- getOperand: sometimes any operand will do.
-
--- getNonClobberedOperand: the value of the operand will remain valid across
--- the computation of an arbitrary expression, unless the expression
--- is computed directly into a register which the operand refers to
--- (see trivialCode where this function is used for an example).
-
-getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)
-getNonClobberedOperand (CmmLit lit) =
-  if isSuitableFloatingPointLit lit
-  then do
-    let CmmFloat _ w = lit
-    Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit
-    return (OpAddr addr, code)
-  else do
-    platform <- getPlatform
-    if is32BitLit platform lit && not (isFloatType (cmmLitType platform lit))
-    then return (OpImm (litToImm lit), nilOL)
-    else getNonClobberedOperand_generic (CmmLit lit)
-
-getNonClobberedOperand (CmmLoad mem pk _) = do
-  is32Bit <- is32BitPlatform
-  -- this logic could be simplified
-  -- TODO FIXME
-  if   (if is32Bit then not (isWord64 pk) else True)
-      -- if 32bit and pk is at float/double/simd value
-      -- or if 64bit
-      --  this could use some eyeballs or i'll need to stare at it more later
-    then do
-      platform <- ncgPlatform <$> getConfig
-      Amode src mem_code <- getAmode mem
-      (src',save_code) <-
-        if (amodeCouldBeClobbered platform src)
-                then do
-                   tmp <- getNewRegNat (archWordFormat is32Bit)
-                   return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),
-                           unitOL (LEA (archWordFormat is32Bit)
-                                       (OpAddr src)
-                                       (OpReg tmp)))
-                else
-                   return (src, nilOL)
-      return (OpAddr src', mem_code `appOL` save_code)
-    else
-      -- if its a word or gcptr on 32bit?
-      getNonClobberedOperand_generic (CmmLoad mem pk NaturallyAligned)
-
-getNonClobberedOperand e = getNonClobberedOperand_generic e
-
-getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)
-getNonClobberedOperand_generic e = do
-  (reg, code) <- getNonClobberedReg e
-  return (OpReg reg, code)
-
-amodeCouldBeClobbered :: Platform -> AddrMode -> Bool
-amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)
-
-regClobbered :: Platform -> Reg -> Bool
-regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr
-regClobbered _ _ = False
-
--- getOperand: the operand is not required to remain valid across the
--- computation of an arbitrary expression.
-getOperand :: CmmExpr -> NatM (Operand, InstrBlock)
-
-getOperand (CmmLit lit) = do
-  use_sse2 <- sse2Enabled
-  if (use_sse2 && isSuitableFloatingPointLit lit)
-    then do
-      let CmmFloat _ w = lit
-      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit
-      return (OpAddr addr, code)
-    else do
-
-  platform <- getPlatform
-  if is32BitLit platform lit && not (isFloatType (cmmLitType platform lit))
-    then return (OpImm (litToImm lit), nilOL)
-    else getOperand_generic (CmmLit lit)
-
-getOperand (CmmLoad mem pk _) = do
-  is32Bit <- is32BitPlatform
-  use_sse2 <- sse2Enabled
-  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)
-     then do
-       Amode src mem_code <- getAmode mem
-       return (OpAddr src, mem_code)
-     else
-       getOperand_generic (CmmLoad mem pk NaturallyAligned)
-
-getOperand e = getOperand_generic e
-
-getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)
-getOperand_generic e = do
-    (reg, code) <- getSomeReg e
-    return (OpReg reg, code)
-
-isOperand :: Platform -> CmmExpr -> Bool
-isOperand _ (CmmLoad _ _ _) = True
-isOperand platform (CmmLit lit)
-                          = is32BitLit platform lit
-                          || isSuitableFloatingPointLit lit
-isOperand _ _            = False
-
--- | Given a 'Register', produce a new 'Register' with an instruction block
--- which will check the value for alignment. Used for @-falignment-sanitisation@.
-addAlignmentCheck :: Int -> Register -> Register
-addAlignmentCheck align reg =
-    case reg of
-      Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)
-      Any fmt f          -> Any fmt (\reg -> f reg `appOL` check fmt reg)
-  where
-    check :: Format -> Reg -> InstrBlock
-    check fmt reg =
-        assert (not $ isFloatFormat fmt) $
-        toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)
-             , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel
-             ]
-
-memConstant :: Alignment -> CmmLit -> NatM Amode
-memConstant align lit = do
-  lbl <- getNewLabelNat
-  let rosection = Section ReadOnlyData lbl
-  config <- getConfig
-  platform <- getPlatform
-  (addr, addr_code) <- if target32Bit platform
-                       then do dynRef <- cmmMakeDynamicReference
-                                             config
-                                             DataReference
-                                             lbl
-                               Amode addr addr_code <- getAmode dynRef
-                               return (addr, addr_code)
-                       else return (ripRel (ImmCLbl lbl), nilOL)
-  let code =
-        LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit])
-        `consOL` addr_code
-  return (Amode addr code)
-
-
-loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register
-loadFloatAmode w addr addr_code = do
-  let format = floatFormat w
-      code dst = addr_code `snocOL`
-                    MOV format (OpAddr addr) (OpReg dst)
-
-  return (Any format code)
-
-
--- if we want a floating-point literal as an operand, we can
--- use it directly from memory.  However, if the literal is
--- zero, we're better off generating it into a register using
--- xor.
-isSuitableFloatingPointLit :: CmmLit -> Bool
-isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0
-isSuitableFloatingPointLit _ = False
-
-getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)
-getRegOrMem e@(CmmLoad mem pk _) = do
-  is32Bit <- is32BitPlatform
-  use_sse2 <- sse2Enabled
-  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)
-     then do
-       Amode src mem_code <- getAmode mem
-       return (OpAddr src, mem_code)
-     else do
-       (reg, code) <- getNonClobberedReg e
-       return (OpReg reg, code)
-getRegOrMem e = do
-    (reg, code) <- getNonClobberedReg e
-    return (OpReg reg, code)
-
-is32BitLit :: Platform -> CmmLit -> Bool
-is32BitLit platform _lit
-   | target32Bit platform = True
-is32BitLit platform lit =
-   case lit of
-      CmmInt i W64              -> is32BitInteger i
-      -- Except on Windows, assume that labels are in the range 0-2^31-1: this
-      -- assumes the small memory model. Note [%rip-relative addressing on
-      -- x86-64].
-      CmmLabel _                -> low_image
-      -- however we can't assume that label offsets are in this range
-      -- (see #15570)
-      CmmLabelOff _ off         -> low_image && is32BitInteger (fromIntegral off)
-      CmmLabelDiffOff _ _ off _ -> low_image && is32BitInteger (fromIntegral off)
-      _                         -> True
-  where
-    -- Is the executable image certain to be located below 4GB? As noted in
-    -- Note [%rip-relative addressing on x86-64], this is not true on Windows.
-    low_image =
-      case platformOS platform of
-        OSMinGW32 -> False   -- See Note [%rip-relative addressing on x86-64]
-        _         -> True
-
-
--- Set up a condition code for a conditional branch.
-
-getCondCode :: CmmExpr -> NatM CondCode
-
--- yes, they really do seem to want exactly the same!
-
-getCondCode (CmmMachOp mop [x, y])
-  =
-    case mop of
-      MO_F_Eq W32 -> condFltCode EQQ x y
-      MO_F_Ne W32 -> condFltCode NE  x y
-      MO_F_Gt W32 -> condFltCode GTT x y
-      MO_F_Ge W32 -> condFltCode GE  x y
-      -- Invert comparison condition and swap operands
-      -- See Note [SSE Parity Checks]
-      MO_F_Lt W32 -> condFltCode GTT  y x
-      MO_F_Le W32 -> condFltCode GE   y x
-
-      MO_F_Eq W64 -> condFltCode EQQ x y
-      MO_F_Ne W64 -> condFltCode NE  x y
-      MO_F_Gt W64 -> condFltCode GTT x y
-      MO_F_Ge W64 -> condFltCode GE  x y
-      MO_F_Lt W64 -> condFltCode GTT y x
-      MO_F_Le W64 -> condFltCode GE  y x
-
-      _ -> condIntCode (machOpToCond mop) x y
-
-getCondCode other = do
-   platform <- getPlatform
-   pprPanic "getCondCode(2)(x86,x86_64)" (pdoc platform other)
-
-machOpToCond :: MachOp -> Cond
-machOpToCond mo = case mo of
-  MO_Eq _   -> EQQ
-  MO_Ne _   -> NE
-  MO_S_Gt _ -> GTT
-  MO_S_Ge _ -> GE
-  MO_S_Lt _ -> LTT
-  MO_S_Le _ -> LE
-  MO_U_Gt _ -> GU
-  MO_U_Ge _ -> GEU
-  MO_U_Lt _ -> LU
-  MO_U_Le _ -> LEU
-  _other -> pprPanic "machOpToCond" (pprMachOp mo)
-
-
--- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
--- passed back up the tree.
-
-condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
-condIntCode cond x y = do platform <- getPlatform
-                          condIntCode' platform cond x y
-
-condIntCode' :: Platform -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
-
--- memory vs immediate
-condIntCode' platform cond (CmmLoad x pk _) (CmmLit lit)
- | is32BitLit platform lit = do
-    Amode x_addr x_code <- getAmode x
-    let
-        imm  = litToImm lit
-        code = x_code `snocOL`
-                  CMP (cmmTypeFormat pk) (OpImm imm) (OpAddr x_addr)
-    --
-    return (CondCode False cond code)
-
--- anything vs zero, using a mask
--- TODO: Add some sanity checking!!!!
-condIntCode' platform cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))
-    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit platform lit
-    = do
-      (x_reg, x_code) <- getSomeReg x
-      let
-         code = x_code `snocOL`
-                TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg)
-      --
-      return (CondCode False cond code)
-
--- anything vs zero
-condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do
-    (x_reg, x_code) <- getSomeReg x
-    let
-        code = x_code `snocOL`
-                  TEST (intFormat pk) (OpReg x_reg) (OpReg x_reg)
-    --
-    return (CondCode False cond code)
-
--- anything vs operand
-condIntCode' platform cond x y
- | isOperand platform y = do
-    (x_reg, x_code) <- getNonClobberedReg x
-    (y_op,  y_code) <- getOperand y
-    let
-        code = x_code `appOL` y_code `snocOL`
-                  CMP (cmmTypeFormat (cmmExprType platform x)) y_op (OpReg x_reg)
-    return (CondCode False cond code)
--- operand vs. anything: invert the comparison so that we can use a
--- single comparison instruction.
- | isOperand platform x
- , Just revcond <- maybeFlipCond cond = do
-    (y_reg, y_code) <- getNonClobberedReg y
-    (x_op,  x_code) <- getOperand x
-    let
-        code = y_code `appOL` x_code `snocOL`
-                  CMP (cmmTypeFormat (cmmExprType platform x)) x_op (OpReg y_reg)
-    return (CondCode False revcond code)
-
--- anything vs anything
-condIntCode' platform cond x y = do
-  (y_reg, y_code) <- getNonClobberedReg y
-  (x_op, x_code) <- getRegOrMem x
-  let
-        code = y_code `appOL`
-               x_code `snocOL`
-                  CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op
-  return (CondCode False cond code)
-
-
-
---------------------------------------------------------------------------------
-condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
-
-condFltCode cond x y
-  =  condFltCode_sse2
-  where
-
-
-  -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be
-  -- an operand, but the right must be a reg.  We can probably do better
-  -- than this general case...
-  condFltCode_sse2 = do
-    platform <- getPlatform
-    (x_reg, x_code) <- getNonClobberedReg x
-    (y_op, y_code) <- getOperand y
-    let
-        code = x_code `appOL`
-               y_code `snocOL`
-                  CMP (floatFormat $ cmmExprWidth platform x) y_op (OpReg x_reg)
-        -- NB(1): we need to use the unsigned comparison operators on the
-        -- result of this comparison.
-    return (CondCode True (condToUnsigned cond) code)
-
--- -----------------------------------------------------------------------------
--- Generating assignments
-
--- Assignments are really at the heart of the whole code generation
--- business.  Almost all top-level nodes of any real importance are
--- assignments, which correspond to loads, stores, or register
--- transfers.  If we're really lucky, some of the register transfers
--- will go away, because we can use the destination register to
--- complete the code generation for the right hand side.  This only
--- fails when the right hand side is forced into a fixed register
--- (e.g. the result of a call).
-
-assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
-assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
-
-assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
-assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
-
-
--- integer assignment to memory
-
--- specific case of adding/subtracting an integer to a particular address.
--- ToDo: catch other cases where we can use an operation directly on a memory
--- address.
-assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _ _,
-                                                 CmmLit (CmmInt i _)])
-   | addr == addr2, pk /= II64 || is32BitInteger i,
-     Just instr <- check op
-   = do Amode amode code_addr <- getAmode addr
-        let code = code_addr `snocOL`
-                   instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)
-        return code
-   where
-        check (MO_Add _) = Just ADD
-        check (MO_Sub _) = Just SUB
-        check _ = Nothing
-        -- ToDo: more?
-
--- general case
-assignMem_IntCode pk addr src = do
-    platform <- getPlatform
-    Amode addr code_addr <- getAmode addr
-    (code_src, op_src)   <- get_op_RI platform src
-    let
-        code = code_src `appOL`
-               code_addr `snocOL`
-                  MOV pk op_src (OpAddr addr)
-        -- NOTE: op_src is stable, so it will still be valid
-        -- after code_addr.  This may involve the introduction
-        -- of an extra MOV to a temporary register, but we hope
-        -- the register allocator will get rid of it.
-    --
-    return code
-  where
-    get_op_RI :: Platform -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator
-    get_op_RI platform (CmmLit lit) | is32BitLit platform lit
-      = return (nilOL, OpImm (litToImm lit))
-    get_op_RI _ op
-      = do (reg,code) <- getNonClobberedReg op
-           return (code, OpReg reg)
-
-
--- Assign; dst is a reg, rhs is mem
-assignReg_IntCode pk reg (CmmLoad src _ _) = do
-  load_code <- intLoadCode (MOV pk) src
-  platform <- ncgPlatform <$> getConfig
-  return (load_code (getRegisterReg platform reg))
-
--- dst is a reg, but src could be anything
-assignReg_IntCode _ reg src = do
-  platform <- ncgPlatform <$> getConfig
-  code <- getAnyReg src
-  return (code (getRegisterReg platform reg))
-
-
--- Floating point assignment to memory
-assignMem_FltCode pk addr src = do
-  (src_reg, src_code) <- getNonClobberedReg src
-  Amode addr addr_code <- getAmode addr
-  let
-        code = src_code `appOL`
-               addr_code `snocOL`
-               MOV pk (OpReg src_reg) (OpAddr addr)
-
-  return code
-
--- Floating point assignment to a register/temporary
-assignReg_FltCode _ reg src = do
-  src_code <- getAnyReg src
-  platform <- ncgPlatform <$> getConfig
-  return (src_code (getRegisterReg platform reg))
-
-
-genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock
-
-genJump (CmmLoad mem _ _) regs = do
-  Amode target code <- getAmode mem
-  return (code `snocOL` JMP (OpAddr target) regs)
-
-genJump (CmmLit lit) regs =
-  return (unitOL (JMP (OpImm (litToImm lit)) regs))
-
-genJump expr regs = do
-  (reg,code) <- getSomeReg expr
-  return (code `snocOL` JMP (OpReg reg) regs)
-
-
--- -----------------------------------------------------------------------------
---  Unconditional branches
-
-genBranch :: BlockId -> InstrBlock
-genBranch = toOL . mkJumpInstr
-
-
-
--- -----------------------------------------------------------------------------
---  Conditional jumps/branches
-
-{-
-Conditional jumps are always to local labels, so we can use branch
-instructions.  We peek at the arguments to decide what kind of
-comparison to do.
-
-I386: First, we have to ensure that the condition
-codes are set according to the supplied comparison operation.
--}
-
-{-  Note [64-bit integer comparisons on 32-bit]
-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-    When doing these comparisons there are 2 kinds of
-    comparisons.
-
-    * Comparison for equality (or lack thereof)
-
-    We use xor to check if high/low bits are
-    equal. Then combine the results using or and
-    perform a single conditional jump based on the
-    result.
-
-    * Other comparisons:
-
-    We map all other comparisons to the >= operation.
-    Why? Because it's easy to encode it with a single
-    conditional jump.
-
-    We do this by first computing [r1_lo - r2_lo]
-    and use the carry flag to compute
-    [r1_high - r2_high - CF].
-
-    At which point if r1 >= r2 then the result will be
-    positive. Otherwise negative so we can branch on this
-    condition.
-
--}
-
-
-genCondBranch
-    :: BlockId      -- the source of the jump
-    -> BlockId      -- the true branch target
-    -> BlockId      -- the false branch target
-    -> CmmExpr      -- the condition on which to branch
-    -> NatM InstrBlock -- Instructions
-
-genCondBranch bid id false expr = do
-  is32Bit <- is32BitPlatform
-  genCondBranch' is32Bit bid id false expr
-
--- | We return the instructions generated.
-genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr
-               -> NatM InstrBlock
-
--- 64-bit integer comparisons on 32-bit
--- See Note [64-bit integer comparisons on 32-bit]
-genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])
-  | is32Bit, Just W64 <- maybeIntComparison mop = do
-
-  RegCode64 code1 r1hi r1lo <- iselExpr64 e1
-  RegCode64 code2 r2hi r2lo <- iselExpr64 e2
-  let cond = machOpToCond mop :: Cond
-
-  -- we mustn't clobber r1/r2 so we use temporaries
-  tmp1 <- getNewRegNat II32
-  tmp2 <- getNewRegNat II32
-
-  let cmpCode = intComparison cond true false r1hi r1lo r2hi r2lo tmp1 tmp2
-  return $ code1 `appOL` code2 `appOL` cmpCode
-
-  where
-    intComparison cond true false r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 =
-      case cond of
-        -- Impossible results of machOpToCond
-        ALWAYS  -> panic "impossible"
-        NEG     -> panic "impossible"
-        POS     -> panic "impossible"
-        CARRY   -> panic "impossible"
-        OFLO    -> panic "impossible"
-        PARITY  -> panic "impossible"
-        NOTPARITY -> panic "impossible"
-        -- Special case #1 x == y and x != y
-        EQQ -> cmpExact
-        NE  -> cmpExact
-        -- [x >= y]
-        GE  -> cmpGE
-        GEU -> cmpGE
-        -- [x >  y] <==> ![y >= x]
-        GTT -> intComparison GE  false true r2_hi r2_lo r1_hi r1_lo tmp1 tmp2
-        GU  -> intComparison GEU false true r2_hi r2_lo r1_hi r1_lo tmp1 tmp2
-        -- [x <= y] <==> [y >= x]
-        LE  -> intComparison GE  true false r2_hi r2_lo r1_hi r1_lo tmp1 tmp2
-        LEU -> intComparison GEU true false r2_hi r2_lo r1_hi r1_lo tmp1 tmp2
-        -- [x <  y] <==> ![x >= x]
-        LTT -> intComparison GE  false true r1_hi r1_lo r2_hi r2_lo tmp1 tmp2
-        LU  -> intComparison GEU false true r1_hi r1_lo r2_hi r2_lo tmp1 tmp2
-      where
-        cmpExact :: OrdList Instr
-        cmpExact =
-          toOL
-            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)
-            , MOV II32 (OpReg r1_lo) (OpReg tmp2)
-            , XOR II32 (OpReg r2_hi) (OpReg tmp1)
-            , XOR II32 (OpReg r2_lo) (OpReg tmp2)
-            , OR  II32 (OpReg tmp1)  (OpReg tmp2)
-            , JXX cond true
-            , JXX ALWAYS false
-            ]
-        cmpGE = toOL
-            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)
-            , CMP II32 (OpReg r2_lo) (OpReg r1_lo)
-            , SBB II32 (OpReg r2_hi) (OpReg tmp1)
-            , JXX cond true
-            , JXX ALWAYS false ]
-
-genCondBranch' _ bid id false bool = do
-  CondCode is_float cond cond_code <- getCondCode bool
-  use_sse2 <- sse2Enabled
-  if not is_float || not use_sse2
-    then
-        return (cond_code `snocOL` JXX cond id `appOL` genBranch false)
-    else do
-        -- See Note [SSE Parity Checks]
-        let jmpFalse = genBranch false
-            code
-                = case cond of
-                  NE  -> or_unordered
-                  GU  -> plain_test
-                  GEU -> plain_test
-                  -- Use ASSERT so we don't break releases if
-                  -- LTT/LE creep in somehow.
-                  LTT ->
-                    assertPpr False (text "Should have been turned into >")
-                    and_ordered
-                  LE  ->
-                    assertPpr False (text "Should have been turned into >=")
-                    and_ordered
-                  _   -> and_ordered
-
-            plain_test = unitOL (
-                  JXX cond id
-                ) `appOL` jmpFalse
-            or_unordered = toOL [
-                  JXX cond id,
-                  JXX PARITY id
-                ] `appOL` jmpFalse
-            and_ordered = toOL [
-                  JXX PARITY false,
-                  JXX cond id,
-                  JXX ALWAYS false
-                ]
-        updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)
-        return (cond_code `appOL` code)
-
-{-  Note [Introducing cfg edges inside basic blocks]
-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-    During instruction selection a statement `s`
-    in a block B with control of the sort: B -> C
-    will sometimes result in control
-    flow of the sort:
-
-            ┌ < ┐
-            v   ^
-      B ->  B1  ┴ -> C
-
-    as is the case for some atomic operations.
-
-    Now to keep the CFG in sync when introducing B1 we clearly
-    want to insert it between B and C. However there is
-    a catch when we have to deal with self loops.
-
-    We might start with code and a CFG of these forms:
-
-    loop:
-        stmt1               ┌ < ┐
-        ....                v   ^
-        stmtX              loop ┘
-        stmtY
-        ....
-        goto loop:
-
-    Now we introduce B1:
-                            ┌ ─ ─ ─ ─ ─┐
-        loop:               │   ┌ <  ┐ │
-        instrs              v   │    │ ^
-        ....               loop ┴ B1 ┴ ┘
-        instrsFromX
-        stmtY
-        goto loop:
-
-    This is simple, all outgoing edges from loop now simply
-    start from B1 instead and the code generator knows which
-    new edges it introduced for the self loop of B1.
-
-    Disaster strikes if the statement Y follows the same pattern.
-    If we apply the same rule that all outgoing edges change then
-    we end up with:
-
-        loop ─> B1 ─> B2 ┬─┐
-          │      │    └─<┤ │
-          │      └───<───┘ │
-          └───────<────────┘
-
-    This is problematic. The edge B1->B1 is modified as expected.
-    However the modification is wrong!
-
-    The assembly in this case looked like this:
-
-    _loop:
-        <instrs>
-    _B1:
-        ...
-        cmpxchgq ...
-        jne _B1
-        <instrs>
-        <end _B1>
-    _B2:
-        ...
-        cmpxchgq ...
-        jne _B2
-        <instrs>
-        jmp loop
-
-    There is no edge _B2 -> _B1 here. It's still a self loop onto _B1.
-
-    The problem here is that really B1 should be two basic blocks.
-    Otherwise we have control flow in the *middle* of a basic block.
-    A contradiction!
-
-    So to account for this we add yet another basic block marker:
-
-    _B:
-        <instrs>
-    _B1:
-        ...
-        cmpxchgq ...
-        jne _B1
-        jmp _B1'
-    _B1':
-        <instrs>
-        <end _B1>
-    _B2:
-        ...
-
-    Now when inserting B2 we will only look at the outgoing edges of B1' and
-    everything will work out nicely.
-
-    You might also wonder why we don't insert jumps at the end of _B1'. There is
-    no way another block ends up jumping to the labels _B1 or _B2 since they are
-    essentially invisible to other blocks. View them as control flow labels local
-    to the basic block if you'd like.
-
-    Not doing this ultimately caused (part 2 of) #17334.
--}
-
-
--- -----------------------------------------------------------------------------
---  Generating C calls
-
--- Now the biggest nightmare---calls.  Most of the nastiness is buried in
--- @get_arg@, which moves the arguments to the correct registers/stack
--- locations.  Apart from that, the code is easy.
---
--- (If applicable) Do not fill the delay slots here; you will confuse the
--- register allocator.
---
--- See Note [Keeping track of the current block] for information why we need
--- to take/return a block id.
-
-genForeignCall
-    :: ForeignTarget -- ^ function to call
-    -> [CmmFormal]   -- ^ where to put the result
-    -> [CmmActual]   -- ^ arguments (of mixed type)
-    -> BlockId       -- ^ The block we are in
-    -> NatM (InstrBlock, Maybe BlockId)
-
-genForeignCall target dst args bid = do
-  case target of
-    PrimTarget prim         -> genPrim bid prim dst args
-    ForeignTarget addr conv -> (,Nothing) <$> genCCall bid addr conv dst args
-
-genPrim
-    :: BlockId       -- ^ The block we are in
-    -> CallishMachOp -- ^ MachOp
-    -> [CmmFormal]   -- ^ where to put the result
-    -> [CmmActual]   -- ^ arguments (of mixed type)
-    -> NatM (InstrBlock, Maybe BlockId)
-
--- First we deal with cases which might introduce new blocks in the stream.
-genPrim bid (MO_AtomicRMW width amop) [dst] [addr, n]
-  = genAtomicRMW bid width amop dst addr n
-genPrim bid (MO_Ctz width) [dst] [src]
-  = genCtz bid width dst src
-
--- Then we deal with cases which not introducing new blocks in the stream.
-genPrim bid prim dst args
-  = (,Nothing) <$> genSimplePrim bid prim dst args
-
-genSimplePrim
-    :: BlockId       -- ^ the block we are in
-    -> CallishMachOp -- ^ MachOp
-    -> [CmmFormal]   -- ^ where to put the result
-    -> [CmmActual]   -- ^ arguments (of mixed type)
-    -> NatM InstrBlock
-genSimplePrim bid (MO_Memcpy align)    []      [dst,src,n]    = genMemCpy  bid align dst src n
-genSimplePrim bid (MO_Memmove align)   []      [dst,src,n]    = genMemMove bid align dst src n
-genSimplePrim bid (MO_Memcmp align)    [res]   [dst,src,n]    = genMemCmp  bid align res dst src n
-genSimplePrim bid (MO_Memset align)    []      [dst,c,n]      = genMemSet  bid align dst c n
-genSimplePrim _   MO_ReadBarrier       []      []             = return nilOL -- barriers compile to no code on x86/x86-64;
-genSimplePrim _   MO_WriteBarrier      []      []             = return nilOL -- we keep it this long in order to prevent earlier optimisations.
-genSimplePrim _   MO_Touch             []      [_]            = return nilOL
-genSimplePrim _   (MO_Prefetch_Data n) []      [src]          = genPrefetchData n src
-genSimplePrim _   (MO_BSwap width)     [dst]   [src]          = genByteSwap width dst src
-genSimplePrim bid (MO_BRev width)      [dst]   [src]          = genBitRev bid width dst src
-genSimplePrim bid (MO_PopCnt width)    [dst]   [src]          = genPopCnt bid width dst src
-genSimplePrim bid (MO_Pdep width)      [dst]   [src,mask]     = genPdep bid width dst src mask
-genSimplePrim bid (MO_Pext width)      [dst]   [src,mask]     = genPext bid width dst src mask
-genSimplePrim bid (MO_Clz width)       [dst]   [src]          = genClz bid width dst src
-genSimplePrim bid (MO_UF_Conv width)   [dst]   [src]          = genWordToFloat bid width dst src
-genSimplePrim _   (MO_AtomicRead w)    [dst]   [addr]         = genAtomicRead w dst addr
-genSimplePrim _   (MO_AtomicWrite w)   []      [addr,val]     = genAtomicWrite w addr val
-genSimplePrim bid (MO_Cmpxchg width)   [dst]   [addr,old,new] = genCmpXchg bid width dst addr old new
-genSimplePrim _   (MO_Xchg width)      [dst]   [addr, value]  = genXchg width dst addr value
-genSimplePrim _   (MO_AddWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y
-genSimplePrim _   (MO_SubWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) CARRY r c x y
-genSimplePrim _   (MO_AddIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (Just . ADD_CC) OFLO  r c x y
-genSimplePrim _   (MO_SubIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) OFLO  r c x y
-genSimplePrim _   (MO_Add2 w)          [h,l]   [x,y]          = genAddWithCarry w h l x y
-genSimplePrim _   (MO_U_Mul2 w)        [h,l]   [x,y]          = genUnsignedLargeMul w h l x y
-genSimplePrim _   (MO_S_Mul2 w)        [c,h,l] [x,y]          = genSignedLargeMul w c h l x y
-genSimplePrim _   (MO_S_QuotRem w)     [q,r]   [x,y]          = genQuotRem w True  q r Nothing   x  y
-genSimplePrim _   (MO_U_QuotRem w)     [q,r]   [x,y]          = genQuotRem w False q r Nothing   x  y
-genSimplePrim _   (MO_U_QuotRem2 w)    [q,r]   [hx,lx,y]      = genQuotRem w False q r (Just hx) lx y
-genSimplePrim _   MO_F32_Fabs          [dst]   [src]          = genFloatAbs W32 dst src
-genSimplePrim _   MO_F64_Fabs          [dst]   [src]          = genFloatAbs W64 dst src
-genSimplePrim _   MO_F32_Sqrt          [dst]   [src]          = genFloatSqrt FF32 dst src
-genSimplePrim _   MO_F64_Sqrt          [dst]   [src]          = genFloatSqrt FF64 dst src
-genSimplePrim bid MO_F32_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sinf") [dst] [src]
-genSimplePrim bid MO_F32_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cosf") [dst] [src]
-genSimplePrim bid MO_F32_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tanf") [dst] [src]
-genSimplePrim bid MO_F32_Exp           [dst]   [src]          = genLibCCall bid (fsLit "expf") [dst] [src]
-genSimplePrim bid MO_F32_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1f") [dst] [src]
-genSimplePrim bid MO_F32_Log           [dst]   [src]          = genLibCCall bid (fsLit "logf") [dst] [src]
-genSimplePrim bid MO_F32_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1pf") [dst] [src]
-genSimplePrim bid MO_F32_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asinf") [dst] [src]
-genSimplePrim bid MO_F32_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acosf") [dst] [src]
-genSimplePrim bid MO_F32_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atanf") [dst] [src]
-genSimplePrim bid MO_F32_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinhf") [dst] [src]
-genSimplePrim bid MO_F32_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "coshf") [dst] [src]
-genSimplePrim bid MO_F32_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanhf") [dst] [src]
-genSimplePrim bid MO_F32_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "powf")  [dst] [x,y]
-genSimplePrim bid MO_F32_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinhf") [dst] [src]
-genSimplePrim bid MO_F32_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acoshf") [dst] [src]
-genSimplePrim bid MO_F32_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanhf") [dst] [src]
-genSimplePrim bid MO_F64_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sin") [dst] [src]
-genSimplePrim bid MO_F64_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cos") [dst] [src]
-genSimplePrim bid MO_F64_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tan") [dst] [src]
-genSimplePrim bid MO_F64_Exp           [dst]   [src]          = genLibCCall bid (fsLit "exp") [dst] [src]
-genSimplePrim bid MO_F64_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1") [dst] [src]
-genSimplePrim bid MO_F64_Log           [dst]   [src]          = genLibCCall bid (fsLit "log") [dst] [src]
-genSimplePrim bid MO_F64_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1p") [dst] [src]
-genSimplePrim bid MO_F64_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asin") [dst] [src]
-genSimplePrim bid MO_F64_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acos") [dst] [src]
-genSimplePrim bid MO_F64_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atan") [dst] [src]
-genSimplePrim bid MO_F64_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinh") [dst] [src]
-genSimplePrim bid MO_F64_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "cosh") [dst] [src]
-genSimplePrim bid MO_F64_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanh") [dst] [src]
-genSimplePrim bid MO_F64_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "pow")  [dst] [x,y]
-genSimplePrim bid MO_F64_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinh") [dst] [src]
-genSimplePrim bid MO_F64_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acosh") [dst] [src]
-genSimplePrim bid MO_F64_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanh") [dst] [src]
-genSimplePrim bid MO_SuspendThread     [tok]   [rs,i]         = genRTSCCall bid (fsLit "suspendThread") [tok] [rs,i]
-genSimplePrim bid MO_ResumeThread      [rs]    [tok]          = genRTSCCall bid (fsLit "resumeThread") [rs] [tok]
-genSimplePrim _   MO_I64_ToI           [dst]   [src]          = genInt64ToInt dst src
-genSimplePrim _   MO_I64_FromI         [dst]   [src]          = genIntToInt64 dst src
-genSimplePrim _   MO_W64_ToW           [dst]   [src]          = genWord64ToWord dst src
-genSimplePrim _   MO_W64_FromW         [dst]   [src]          = genWordToWord64 dst src
-genSimplePrim _   MO_x64_Neg           [dst]   [src]          = genNeg64 dst src
-genSimplePrim _   MO_x64_Add           [dst]   [x,y]          = genAdd64 dst x y
-genSimplePrim _   MO_x64_Sub           [dst]   [x,y]          = genSub64 dst x y
-genSimplePrim bid MO_x64_Mul           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_mul64") [dst] [x,y]
-genSimplePrim bid MO_I64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt64") [dst] [x,y]
-genSimplePrim bid MO_I64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt64") [dst] [x,y]
-genSimplePrim bid MO_W64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord64") [dst] [x,y]
-genSimplePrim bid MO_W64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord64") [dst] [x,y]
-genSimplePrim _   MO_x64_And           [dst]   [x,y]          = genAnd64 dst x y
-genSimplePrim _   MO_x64_Or            [dst]   [x,y]          = genOr64  dst x y
-genSimplePrim _   MO_x64_Xor           [dst]   [x,y]          = genXor64 dst x y
-genSimplePrim _   MO_x64_Not           [dst]   [src]          = genNot64 dst src
-genSimplePrim bid MO_x64_Shl           [dst]   [x,n]          = genPrimCCall bid (fsLit "hs_uncheckedShiftL64") [dst] [x,n]
-genSimplePrim bid MO_I64_Shr           [dst]   [x,n]          = genPrimCCall bid (fsLit "hs_uncheckedIShiftRA64") [dst] [x,n]
-genSimplePrim bid MO_W64_Shr           [dst]   [x,n]          = genPrimCCall bid (fsLit "hs_uncheckedShiftRL64") [dst] [x,n]
-genSimplePrim _   MO_x64_Eq            [dst]   [x,y]          = genEq64 dst x y
-genSimplePrim _   MO_x64_Ne            [dst]   [x,y]          = genNe64 dst x y
-genSimplePrim _   MO_I64_Ge            [dst]   [x,y]          = genGeInt64 dst x y
-genSimplePrim _   MO_I64_Gt            [dst]   [x,y]          = genGtInt64 dst x y
-genSimplePrim _   MO_I64_Le            [dst]   [x,y]          = genLeInt64 dst x y
-genSimplePrim _   MO_I64_Lt            [dst]   [x,y]          = genLtInt64 dst x y
-genSimplePrim _   MO_W64_Ge            [dst]   [x,y]          = genGeWord64 dst x y
-genSimplePrim _   MO_W64_Gt            [dst]   [x,y]          = genGtWord64 dst x y
-genSimplePrim _   MO_W64_Le            [dst]   [x,y]          = genLeWord64 dst x y
-genSimplePrim _   MO_W64_Lt            [dst]   [x,y]          = genLtWord64 dst x y
-genSimplePrim _   op                   dst     args           = do
-  platform <- ncgPlatform <$> getConfig
-  pprPanic "genSimplePrim: unhandled primop" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args))
-
-{-
-Note [Evaluate C-call arguments before placing in destination registers]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-When producing code for C calls we must take care when placing arguments
-in their final registers. Specifically, we must ensure that temporary register
-usage due to evaluation of one argument does not clobber a register in which we
-already placed a previous argument (e.g. as the code generation logic for
-MO_Shl can clobber %rcx due to x86 instruction limitations).
-
-This is precisely what happened in #18527. Consider this C--:
-
-    (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));
-
-Here we are calling the C function `doSomething` with three arguments, the last
-involving a non-trivial expression involving MO_Shl. In this case the NCG could
-naively generate the following assembly (where $tmp denotes some temporary
-register and $argN denotes the register for argument N, as dictated by the
-platform's calling convention):
-
-    mov _s2hp, $arg1   # place first argument
-    mov _s2hq, $arg2   # place second argument
-
-    # Compute 1 << _s2hz
-    mov _s2hz, %rcx
-    shl %cl, $tmp
-
-    # Compute (_s2hw | (1 << _s2hz))
-    mov _s2hw, $arg3
-    or $tmp, $arg3
-
-    # Perform the call
-    call func
-
-This code is outright broken on Windows which assigns $arg1 to %rcx. This means
-that the evaluation of the last argument clobbers the first argument.
-
-To avoid this we use a rather awful hack: when producing code for a C call with
-at least one non-trivial argument, we first evaluate all of the arguments into
-local registers before moving them into their final calling-convention-defined
-homes.  This is performed by 'evalArgs'. Here we define "non-trivial" to be an
-expression which might contain a MachOp since these are the only cases which
-might clobber registers. Furthermore, we use a conservative approximation of
-this condition (only looking at the top-level of CmmExprs) to avoid spending
-too much effort trying to decide whether we want to take the fast path.
-
-Note that this hack *also* applies to calls to out-of-line PrimTargets (which
-are lowered via a C call), which will ultimately end up in
-genForeignCall{32,64}.
--}
-
--- | See Note [Evaluate C-call arguments before placing in destination registers]
-evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])
-evalArgs bid actuals
-  | any mightContainMachOp actuals = do
-      regs_blks <- mapM evalArg actuals
-      return (concatOL $ map fst regs_blks, map snd regs_blks)
-  | otherwise = return (nilOL, actuals)
-  where
-    mightContainMachOp (CmmReg _)      = False
-    mightContainMachOp (CmmRegOff _ _) = False
-    mightContainMachOp (CmmLit _)      = False
-    mightContainMachOp _               = True
-
-    evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)
-    evalArg actual = do
-        platform <- getPlatform
-        lreg <- newLocalReg $ cmmExprType platform actual
-        (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual
-        -- The above assignment shouldn't change the current block
-        massert (isNothing bid1)
-        return (instrs, CmmReg $ CmmLocal lreg)
-
-    newLocalReg :: CmmType -> NatM LocalReg
-    newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty
-
--- Note [DIV/IDIV for bytes]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~
--- IDIV reminder:
---   Size    Dividend   Divisor   Quotient    Remainder
---   byte    %ax         r/m8      %al          %ah
---   word    %dx:%ax     r/m16     %ax          %dx
---   dword   %edx:%eax   r/m32     %eax         %edx
---   qword   %rdx:%rax   r/m64     %rax         %rdx
---
--- We do a special case for the byte division because the current
--- codegen doesn't deal well with accessing %ah register (also,
--- accessing %ah in 64-bit mode is complicated because it cannot be an
--- operand of many instructions). So we just widen operands to 16 bits
--- and get the results from %al, %dl. This is not optimal, but a few
--- register moves are probably not a huge deal when doing division.
-
-
--- | Generate C call to the given function in ghc-prim
-genPrimCCall
-  :: BlockId
-  -> FastString
-  -> [CmmFormal]
-  -> [CmmActual]
-  -> NatM InstrBlock
-genPrimCCall bid lbl_txt dsts args = do
-  config <- getConfig
-  -- FIXME: we should use mkForeignLabel instead of mkCmmCodeLabel
-  let lbl = mkCmmCodeLabel primUnitId lbl_txt
-  addr <- cmmMakeDynamicReference config CallReference lbl
-  let conv = ForeignConvention CCallConv [] [] CmmMayReturn
-  genCCall bid addr conv dsts args
-
--- | Generate C call to the given function in libc
-genLibCCall
-  :: BlockId
-  -> FastString
-  -> [CmmFormal]
-  -> [CmmActual]
-  -> NatM InstrBlock
-genLibCCall bid lbl_txt dsts args = do
-  config <- getConfig
-  -- Assume we can call these functions directly, and that they're not in a dynamic library.
-  -- TODO: Why is this ok? Under linux this code will be in libm.so
-  --       Is it because they're really implemented as a primitive instruction by the assembler??  -- BL 2009/12/31
-  let lbl = mkForeignLabel lbl_txt Nothing ForeignLabelInThisPackage IsFunction
-  addr <- cmmMakeDynamicReference config CallReference lbl
-  let conv = ForeignConvention CCallConv [] [] CmmMayReturn
-  genCCall bid addr conv dsts args
-
--- | Generate C call to the given function in the RTS
-genRTSCCall
-  :: BlockId
-  -> FastString
-  -> [CmmFormal]
-  -> [CmmActual]
-  -> NatM InstrBlock
-genRTSCCall bid lbl_txt dsts args = do
-  config <- getConfig
-  -- Assume we can call these functions directly, and that they're not in a dynamic library.
-  let lbl = mkForeignLabel lbl_txt Nothing ForeignLabelInThisPackage IsFunction
-  addr <- cmmMakeDynamicReference config CallReference lbl
-  let conv = ForeignConvention CCallConv [] [] CmmMayReturn
-  genCCall bid addr conv dsts args
-
--- | Generate a real C call to the given address with the given convention
-genCCall
-  :: BlockId
-  -> CmmExpr
-  -> ForeignConvention
-  -> [CmmFormal]
-  -> [CmmActual]
-  -> NatM InstrBlock
-genCCall bid addr conv dest_regs args = do
-  is32Bit <- is32BitPlatform
-  (instrs0, args') <- evalArgs bid args
-  instrs1 <- if is32Bit
-    then genCCall32 addr conv dest_regs args'
-    else genCCall64 addr conv dest_regs args'
-  return (instrs0 `appOL` instrs1)
-
-genCCall32 :: CmmExpr           -- ^ address of the function to call
-           -> ForeignConvention -- ^ calling convention
-           -> [CmmFormal]       -- ^ where to put the result
-           -> [CmmActual]       -- ^ arguments (of mixed type)
-           -> NatM InstrBlock
-genCCall32 addr conv dest_regs args = do
-        config <- getConfig
-        let platform = ncgPlatform config
-            prom_args = map (maybePromoteCArg platform W32) args
-
-            -- If the size is smaller than the word, we widen things (see maybePromoteCArg)
-            arg_size_bytes :: CmmType -> Int
-            arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth platform))
-
-            roundTo a x | x `mod` a == 0 = x
-                        | otherwise = x + a - (x `mod` a)
-
-            push_arg :: CmmActual {-current argument-}
-                            -> NatM InstrBlock  -- code
-
-            push_arg  arg -- we don't need the hints on x86
-              | isWord64 arg_ty = do
-                RegCode64 code r_hi r_lo <- iselExpr64 arg
-                delta <- getDeltaNat
-                setDeltaNat (delta - 8)
-                return (       code `appOL`
-                               toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),
-                                     PUSH II32 (OpReg r_lo), DELTA (delta - 8),
-                                     DELTA (delta-8)]
-                    )
-
-              | isFloatType arg_ty = do
-                (reg, code) <- getSomeReg arg
-                delta <- getDeltaNat
-                setDeltaNat (delta-size)
-                return (code `appOL`
-                                toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),
-                                      DELTA (delta-size),
-                                      let addr = AddrBaseIndex (EABaseReg esp)
-                                                                EAIndexNone
-                                                                (ImmInt 0)
-                                          format = floatFormat (typeWidth arg_ty)
-                                      in
-
-                                      -- assume SSE2
-                                       MOV format (OpReg reg) (OpAddr addr)
-
-                                     ]
-                               )
-
-              | otherwise = do
-                -- Arguments can be smaller than 32-bit, but we still use @PUSH
-                -- II32@ - the usual calling conventions expect integers to be
-                -- 4-byte aligned.
-                massert ((typeWidth arg_ty) <= W32)
-                (operand, code) <- getOperand arg
-                delta <- getDeltaNat
-                setDeltaNat (delta-size)
-                return (code `snocOL`
-                        PUSH II32 operand `snocOL`
-                        DELTA (delta-size))
-
-              where
-                 arg_ty = cmmExprType platform arg
-                 size = arg_size_bytes arg_ty -- Byte size
-
-        let
-            -- Align stack to 16n for calls, assuming a starting stack
-            -- alignment of 16n - word_size on procedure entry. Which we
-            -- maintiain. See Note [Stack Alignment on X86] in rts/StgCRun.c.
-            sizes               = map (arg_size_bytes . cmmExprType platform) (reverse args)
-            raw_arg_size        = sum sizes + platformWordSizeInBytes platform
-            arg_pad_size        = (roundTo 16 $ raw_arg_size) - raw_arg_size
-            tot_arg_size        = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform
-
-
-        delta0 <- getDeltaNat
-        setDeltaNat (delta0 - arg_pad_size)
-
-        push_codes <- mapM push_arg (reverse prom_args)
-        delta <- getDeltaNat
-        massert (delta == delta0 - tot_arg_size)
-
-        -- deal with static vs dynamic call targets
-        (callinsns,cconv) <-
-          case addr of
-            CmmLit (CmmLabel lbl)
-               -> -- ToDo: stdcall arg sizes
-                  return (unitOL (CALL (Left fn_imm) []), conv)
-               where fn_imm = ImmCLbl lbl
-            _
-               -> do { (dyn_r, dyn_c) <- getSomeReg addr
-                     ; massert (isWord32 (cmmExprType platform addr))
-                     ; return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }
-        let push_code
-                | arg_pad_size /= 0
-                = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),
-                        DELTA (delta0 - arg_pad_size)]
-                  `appOL` concatOL push_codes
-                | otherwise
-                = concatOL push_codes
-
-              -- Deallocate parameters after call for ccall;
-              -- but not for stdcall (callee does it)
-              --
-              -- We have to pop any stack padding we added
-              -- even if we are doing stdcall, though (#5052)
-            pop_size
-               | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size
-               | otherwise = tot_arg_size
-
-            call = callinsns `appOL`
-                   toOL (
-                      (if pop_size==0 then [] else
-                       [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)])
-                      ++
-                      [DELTA delta0]
-                   )
-        setDeltaNat delta0
-
-        let
-            -- assign the results, if necessary
-            assign_code []     = nilOL
-            assign_code [dest]
-              | isFloatType ty =
-                  -- we assume SSE2
-                  let tmp_amode = AddrBaseIndex (EABaseReg esp)
-                                                       EAIndexNone
-                                                       (ImmInt 0)
-                      fmt = floatFormat w
-                         in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),
-                                   DELTA (delta0 - b),
-                                   X87Store fmt  tmp_amode,
-                                   -- X87Store only supported for the CDECL ABI
-                                   -- NB: This code will need to be
-                                   -- revisited once GHC does more work around
-                                   -- SIGFPE f
-                                   MOV fmt (OpAddr tmp_amode) (OpReg r_dest),
-                                   ADD II32 (OpImm (ImmInt b)) (OpReg esp),
-                                   DELTA delta0]
-              | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),
-                                        MOV II32 (OpReg edx) (OpReg r_dest_hi)]
-              | otherwise      = unitOL (MOV (intFormat w)
-                                             (OpReg eax)
-                                             (OpReg r_dest))
-              where
-                    ty = localRegType dest
-                    w  = typeWidth ty
-                    b  = widthInBytes w
-                    r_dest_hi = getHiVRegFromLo r_dest
-                    r_dest    = getLocalRegReg dest
-            assign_code many = pprPanic "genForeignCall.assign_code - too many return values:" (ppr many)
-
-        return (push_code `appOL`
-                call `appOL`
-                assign_code dest_regs)
-
-genCCall64 :: CmmExpr           -- ^ address of function to call
-           -> ForeignConvention -- ^ calling convention
-           -> [CmmFormal]       -- ^ where to put the result
-           -> [CmmActual]       -- ^ arguments (of mixed type)
-           -> NatM InstrBlock
-genCCall64 addr conv dest_regs args = do
-    platform <- getPlatform
-    -- load up the register arguments
-    let prom_args = map (maybePromoteCArg platform W32) args
-
-    let load_args :: [CmmExpr]
-                  -> [Reg]         -- int regs avail for args
-                  -> [Reg]         -- FP regs avail for args
-                  -> InstrBlock    -- code computing args
-                  -> InstrBlock    -- code assigning args to ABI regs
-                  -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)
-        -- no more regs to use
-        load_args args [] [] code acode     =
-            return (args, [], [], code, acode)
-
-        -- no more args to push
-        load_args [] aregs fregs code acode =
-            return ([], aregs, fregs, code, acode)
-
-        load_args (arg : rest) aregs fregs code acode
-            | isFloatType arg_rep = case fregs of
-                 []     -> push_this_arg
-                 (r:rs) -> do
-                    (code',acode') <- reg_this_arg r
-                    load_args rest aregs rs code' acode'
-            | otherwise           = case aregs of
-                 []     -> push_this_arg
-                 (r:rs) -> do
-                    (code',acode') <- reg_this_arg r
-                    load_args rest rs fregs code' acode'
-            where
-
-              -- put arg into the list of stack pushed args
-              push_this_arg = do
-                 (args',ars,frs,code',acode')
-                     <- load_args rest aregs fregs code acode
-                 return (arg:args', ars, frs, code', acode')
-
-              -- pass the arg into the given register
-              reg_this_arg r
-                -- "operand" args can be directly assigned into r
-                | isOperand platform arg = do
-                    arg_code <- getAnyReg arg
-                    return (code, (acode `appOL` arg_code r))
-                -- The last non-operand arg can be directly assigned after its
-                -- computation without going into a temporary register
-                | all (isOperand platform) rest = do
-                    arg_code   <- getAnyReg arg
-                    return (code `appOL` arg_code r,acode)
-
-                -- other args need to be computed beforehand to avoid clobbering
-                -- previously assigned registers used to pass parameters (see
-                -- #11792, #12614). They are assigned into temporary registers
-                -- and get assigned to proper call ABI registers after they all
-                -- have been computed.
-                | otherwise     = do
-                    arg_code <- getAnyReg arg
-                    tmp      <- getNewRegNat arg_fmt
-                    let
-                      code'  = code `appOL` arg_code tmp
-                      acode' = acode `snocOL` reg2reg arg_fmt tmp r
-                    return (code',acode')
-
-              arg_rep = cmmExprType platform arg
-              arg_fmt = cmmTypeFormat arg_rep
-
-        load_args_win :: [CmmExpr]
-                      -> [Reg]        -- used int regs
-                      -> [Reg]        -- used FP regs
-                      -> [(Reg, Reg)] -- (int, FP) regs avail for args
-                      -> InstrBlock
-                      -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)
-        load_args_win args usedInt usedFP [] code
-            = return (args, usedInt, usedFP, code, nilOL)
-            -- no more regs to use
-        load_args_win [] usedInt usedFP _ code
-            = return ([], usedInt, usedFP, code, nilOL)
-            -- no more args to push
-        load_args_win (arg : rest) usedInt usedFP
-                      ((ireg, freg) : regs) code
-            | isFloatType arg_rep = do
-                 arg_code <- getAnyReg arg
-                 load_args_win rest (ireg : usedInt) (freg : usedFP) regs
-                               (code `appOL`
-                                arg_code freg `snocOL`
-                                -- If we are calling a varargs function
-                                -- then we need to define ireg as well
-                                -- as freg
-                                MOV II64 (OpReg freg) (OpReg ireg))
-            | otherwise = do
-                 arg_code <- getAnyReg arg
-                 load_args_win rest (ireg : usedInt) usedFP regs
-                               (code `appOL` arg_code ireg)
-            where
-              arg_rep = cmmExprType platform arg
-
-        arg_size = 8 -- always, at the mo
-
-        push_args [] code = return code
-        push_args (arg:rest) code
-           | isFloatType arg_rep = do
-             (arg_reg, arg_code) <- getSomeReg arg
-             delta <- getDeltaNat
-             setDeltaNat (delta-arg_size)
-             let code' = code `appOL` arg_code `appOL` toOL [
-                            SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp),
-                            DELTA (delta-arg_size),
-                            MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel platform 0))]
-             push_args rest code'
-
-           | otherwise = do
-             -- Arguments can be smaller than 64-bit, but we still use @PUSH
-             -- II64@ - the usual calling conventions expect integers to be
-             -- 8-byte aligned.
-             massert (width <= W64)
-             (arg_op, arg_code) <- getOperand arg
-             delta <- getDeltaNat
-             setDeltaNat (delta-arg_size)
-             let code' = code `appOL` arg_code `appOL` toOL [
-                                    PUSH II64 arg_op,
-                                    DELTA (delta-arg_size)]
-             push_args rest code'
-            where
-              arg_rep = cmmExprType platform arg
-              width = typeWidth arg_rep
-
-        leaveStackSpace n = do
-             delta <- getDeltaNat
-             setDeltaNat (delta - n * arg_size)
-             return $ toOL [
-                         SUB II64 (OpImm (ImmInt (n * platformWordSizeInBytes platform))) (OpReg rsp),
-                         DELTA (delta - n * arg_size)]
-
-    (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code)
-         <-
-        if platformOS platform == OSMinGW32
-        then load_args_win prom_args [] [] (allArgRegs platform) nilOL
-        else do
-           (stack_args, aregs, fregs, load_args_code, assign_args_code)
-               <- load_args prom_args (allIntArgRegs platform)
-                                      (allFPArgRegs platform)
-                                      nilOL nilOL
-           let used_regs rs as = reverse (drop (length rs) (reverse as))
-               fregs_used      = used_regs fregs (allFPArgRegs platform)
-               aregs_used      = used_regs aregs (allIntArgRegs platform)
-           return (stack_args, aregs_used, fregs_used, load_args_code
-                                                      , assign_args_code)
-
-    let
-        arg_regs_used = int_regs_used ++ fp_regs_used
-        arg_regs = [eax] ++ arg_regs_used
-                -- for annotating the call instruction with
-        sse_regs = length fp_regs_used
-        arg_stack_slots = if platformOS platform == OSMinGW32
-                          then length stack_args + length (allArgRegs platform)
-                          else length stack_args
-        tot_arg_size = arg_size * arg_stack_slots
-
-
-    -- Align stack to 16n for calls, assuming a starting stack
-    -- alignment of 16n - word_size on procedure entry. Which we
-    -- maintain. See Note [Stack Alignment on X86] in rts/StgCRun.c
-    let word_size = platformWordSizeInBytes platform
-    (real_size, adjust_rsp) <-
-        if (tot_arg_size + word_size) `rem` 16 == 0
-            then return (tot_arg_size, nilOL)
-            else do -- we need to adjust...
-                delta <- getDeltaNat
-                setDeltaNat (delta - word_size)
-                return (tot_arg_size + word_size, toOL [
-                                SUB II64 (OpImm (ImmInt word_size)) (OpReg rsp),
-                                DELTA (delta - word_size) ])
-
-    -- push the stack args, right to left
-    push_code <- push_args (reverse stack_args) nilOL
-    -- On Win64, we also have to leave stack space for the arguments
-    -- that we are passing in registers
-    lss_code <- if platformOS platform == OSMinGW32
-                then leaveStackSpace (length (allArgRegs platform))
-                else return nilOL
-    delta <- getDeltaNat
-
-    -- deal with static vs dynamic call targets
-    (callinsns,_cconv) <- case addr of
-      CmmLit (CmmLabel lbl) ->
-        -- ToDo: stdcall arg sizes
-        return (unitOL (CALL (Left (ImmCLbl lbl)) arg_regs), conv)
-      _ -> do
-        (dyn_r, dyn_c) <- getSomeReg addr
-        return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)
-
-    let
-        -- The x86_64 ABI requires us to set %al to the number of SSE2
-        -- registers that contain arguments, if the called routine
-        -- is a varargs function.  We don't know whether it's a
-        -- varargs function or not, so we have to assume it is.
-        --
-        -- It's not safe to omit this assignment, even if the number
-        -- of SSE2 regs in use is zero.  If %al is larger than 8
-        -- on entry to a varargs function, seg faults ensue.
-        assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))
-
-    let call = callinsns `appOL`
-               toOL (
-                    -- Deallocate parameters after call for ccall;
-                    -- stdcall has callee do it, but is not supported on
-                    -- x86_64 target (see #3336)
-                  (if real_size==0 then [] else
-                   [ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)])
-                  ++
-                  [DELTA (delta + real_size)]
-               )
-    setDeltaNat (delta + real_size)
-
-    let
-        -- assign the results, if necessary
-        assign_code []     = nilOL
-        assign_code [dest] =
-          case typeWidth rep of
-                W32 | isFloatType rep -> unitOL (MOV (floatFormat W32)
-                                                     (OpReg xmm0)
-                                                     (OpReg r_dest))
-                W64 | isFloatType rep -> unitOL (MOV (floatFormat W64)
-                                                     (OpReg xmm0)
-                                                     (OpReg r_dest))
-                _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))
-          where
-                rep = localRegType dest
-                r_dest = getRegisterReg platform  (CmmLocal dest)
-        assign_code _many = panic "genForeignCall.assign_code many"
-
-    return (adjust_rsp          `appOL`
-            push_code           `appOL`
-            load_args_code      `appOL`
-            assign_args_code    `appOL`
-            lss_code            `appOL`
-            assign_eax sse_regs `appOL`
-            call                `appOL`
-            assign_code dest_regs)
-
-
-maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr
-maybePromoteCArg platform wto arg
- | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]
- | otherwise   = arg
- where
-   wfrom = cmmExprWidth platform arg
-
--- -----------------------------------------------------------------------------
--- Generating a table-branch
-
-{-
-Note [Sub-word subtlety during jump-table indexing]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Offset the index by the start index of the jump table.
-It's important that we do this *before* the widening below. To see
-why, consider a switch with a sub-word, signed discriminant such as:
-
-    switch [-5...+2] x::I16 {
-        case -5: ...
-        ...
-        case +2: ...
-    }
-
-Consider what happens if we offset *after* widening in the case that
-x=-4:
-
-                                         // x == -4 == 0xfffc::I16
-    indexWidened = UU_Conv(x);           // == 0xfffc::I64
-    indexExpr    = indexWidened - (-5);  // == 0x10000::I64
-
-This index is clearly nonsense given that the jump table only has
-eight entries.
-
-By contrast, if we widen *after* we offset then we get the correct
-index (1),
-
-                                         // x == -4 == 0xfffc::I16
-    indexOffset  = x - (-5);             // == 1::I16
-    indexExpr    = UU_Conv(indexOffset); // == 1::I64
-
-See #21186.
--}
-
-genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock
-
-genSwitch expr targets = do
-  config <- getConfig
-  let platform = ncgPlatform config
-      expr_w = cmmExprWidth platform expr
-      indexExpr0 = cmmOffset platform expr offset
-      -- We widen to a native-width register because we cannot use arbitrary sizes
-      -- in x86 addressing modes.
-      -- See Note [Sub-word subtlety during jump-table indexing].
-      indexExpr = CmmMachOp
-        (MO_UU_Conv expr_w (platformWordWidth platform))
-        [indexExpr0]
-  if ncgPIC config
-  then do
-        (reg,e_code) <- getNonClobberedReg indexExpr
-           -- getNonClobberedReg because it needs to survive across t_code
-        lbl <- getNewLabelNat
-        let is32bit = target32Bit platform
-            os = platformOS platform
-            -- Might want to use .rodata.<function we're in> instead, but as
-            -- long as it's something unique it'll work out since the
-            -- references to the jump table are in the appropriate section.
-            rosection = case os of
-              -- on Mac OS X/x86_64, put the jump table in the text section to
-              -- work around a limitation of the linker.
-              -- ld64 is unable to handle the relocations for
-              --     .quad L1 - L0
-              -- if L0 is not preceded by a non-anonymous label in its section.
-              OSDarwin | not is32bit -> Section Text lbl
-              _ -> Section ReadOnlyData lbl
-        dynRef <- cmmMakeDynamicReference config DataReference lbl
-        (tableReg,t_code) <- getSomeReg $ dynRef
-        let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
-                                       (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))
-
-        return $ e_code `appOL` t_code `appOL` toOL [
-                                ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg),
-                                JMP_TBL (OpReg tableReg) ids rosection lbl
-                       ]
-  else do
-        (reg,e_code) <- getSomeReg indexExpr
-        lbl <- getNewLabelNat
-        let is32bit = target32Bit platform
-        if is32bit
-          then let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))
-                   jmp_code = JMP_TBL op ids (Section ReadOnlyData lbl) lbl
-               in return $ e_code `appOL` unitOL jmp_code
-          else do
-            -- See Note [%rip-relative addressing on x86-64].
-            tableReg <- getNewRegNat (intFormat (platformWordWidth platform))
-            targetReg <- getNewRegNat (intFormat (platformWordWidth platform))
-            let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))
-                code = e_code `appOL` toOL
-                    [ LEA (archWordFormat is32bit) (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl lbl))) (OpReg tableReg)
-                    , MOV (archWordFormat is32bit) op (OpReg targetReg)
-                    , JMP_TBL (OpReg targetReg) ids (Section ReadOnlyData lbl) lbl
-                    ]
-            return code
-  where
-    (offset, blockIds) = switchTargetsToTable targets
-    ids = map (fmap DestBlockId) blockIds
-
-generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)
-generateJumpTableForInstr config (JMP_TBL _ ids section lbl)
-    = let getBlockId (DestBlockId id) = id
-          getBlockId _ = panic "Non-Label target in Jump Table"
-          blockIds = map (fmap getBlockId) ids
-      in Just (createJumpTable config blockIds section lbl)
-generateJumpTableForInstr _ _ = Nothing
-
-createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel
-                -> GenCmmDecl (Alignment, RawCmmStatics) h g
-createJumpTable config ids section lbl
-    = let jumpTable
-            | ncgPIC config =
-                  let ww = ncgWordWidth config
-                      jumpTableEntryRel Nothing
-                          = CmmStaticLit (CmmInt 0 ww)
-                      jumpTableEntryRel (Just blockid)
-                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww)
-                          where blockLabel = blockLbl blockid
-                  in map jumpTableEntryRel ids
-            | otherwise = map (jumpTableEntry config) ids
-      in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable)
-
-extractUnwindPoints :: [Instr] -> [UnwindPoint]
-extractUnwindPoints instrs =
-    [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs]
-
--- -----------------------------------------------------------------------------
--- 'condIntReg' and 'condFltReg': condition codes into registers
-
--- Turn those condition codes into integers now (when they appear on
--- the right hand side of an assignment).
---
--- (If applicable) Do not fill the delay slots here; you will confuse the
--- register allocator.
-
-condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
-
-condIntReg cond x y = do
-  CondCode _ cond cond_code <- condIntCode cond x y
-  tmp <- getNewRegNat II8
-  let
-        code dst = cond_code `appOL` toOL [
-                    SETCC cond (OpReg tmp),
-                    MOVZxL II8 (OpReg tmp) (OpReg dst)
-                  ]
-  return (Any II32 code)
-
-
--- Note [SSE Parity Checks]
--- ~~~~~~~~~~~~~~~~~~~~~~~~
--- We have to worry about unordered operands (eg. comparisons
--- against NaN).  If the operands are unordered, the comparison
--- sets the parity flag, carry flag and zero flag.
--- All comparisons are supposed to return false for unordered
--- operands except for !=, which returns true.
---
--- Optimisation: we don't have to test the parity flag if we
--- know the test has already excluded the unordered case: eg >
--- and >= test for a zero carry flag, which can only occur for
--- ordered operands.
---
--- By reversing comparisons we can avoid testing the parity
--- for < and <= as well. If any of the arguments is an NaN we
--- return false either way. If both arguments are valid then
--- x <= y  <->  y >= x  holds. So it's safe to swap these.
---
--- We invert the condition inside getRegister'and  getCondCode
--- which should cover all invertable cases.
--- All other functions translating FP comparisons to assembly
--- use these to two generate the comparison code.
---
--- As an example consider a simple check:
---
--- func :: Float -> Float -> Int
--- func x y = if x < y then 1 else 0
---
--- Which in Cmm gives the floating point comparison.
---
---  if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf;
---
--- We used to compile this to an assembly code block like this:
--- _c2gh:
---  ucomiss %xmm2,%xmm1
---  jp _c2gf
---  jb _c2gg
---  jmp _c2gf
---
--- Where we have to introduce an explicit
--- check for unordered results (using jmp parity):
---
--- We can avoid this by exchanging the arguments and inverting the direction
--- of the comparison. This results in the sequence of:
---
---  ucomiss %xmm1,%xmm2
---  ja _c2g2
---  jmp _c2g1
---
--- Removing the jump reduces the pressure on the branch prediction system
--- and plays better with the uOP cache.
-
-condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register
-condFltReg is32Bit cond x y = condFltReg_sse2
- where
-
-
-  condFltReg_sse2 = do
-    CondCode _ cond cond_code <- condFltCode cond x y
-    tmp1 <- getNewRegNat (archWordFormat is32Bit)
-    tmp2 <- getNewRegNat (archWordFormat is32Bit)
-    let -- See Note [SSE Parity Checks]
-        code dst =
-           cond_code `appOL`
-             (case cond of
-                NE  -> or_unordered dst
-                GU  -> plain_test   dst
-                GEU -> plain_test   dst
-                -- Use ASSERT so we don't break releases if these creep in.
-                LTT -> assertPpr False (text "Should have been turned into >") $
-                       and_ordered  dst
-                LE  -> assertPpr False (text "Should have been turned into >=") $
-                       and_ordered  dst
-                _   -> and_ordered  dst)
-
-        plain_test dst = toOL [
-                    SETCC cond (OpReg tmp1),
-                    MOVZxL II8 (OpReg tmp1) (OpReg dst)
-                 ]
-        or_unordered dst = toOL [
-                    SETCC cond (OpReg tmp1),
-                    SETCC PARITY (OpReg tmp2),
-                    OR II8 (OpReg tmp1) (OpReg tmp2),
-                    MOVZxL II8 (OpReg tmp2) (OpReg dst)
-                  ]
-        and_ordered dst = toOL [
-                    SETCC cond (OpReg tmp1),
-                    SETCC NOTPARITY (OpReg tmp2),
-                    AND II8 (OpReg tmp1) (OpReg tmp2),
-                    MOVZxL II8 (OpReg tmp2) (OpReg dst)
-                  ]
-    return (Any II32 code)
-
-
--- -----------------------------------------------------------------------------
--- 'trivial*Code': deal with trivial instructions
-
--- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
--- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
--- Only look for constants on the right hand side, because that's
--- where the generic optimizer will have put them.
-
--- Similarly, for unary instructions, we don't have to worry about
--- matching an StInt as the argument, because genericOpt will already
--- have handled the constant-folding.
-
-
-{-
-The Rules of the Game are:
-
-* You cannot assume anything about the destination register dst;
-  it may be anything, including a fixed reg.
-
-* You may compute an operand into a fixed reg, but you may not
-  subsequently change the contents of that fixed reg.  If you
-  want to do so, first copy the value either to a temporary
-  or into dst.  You are free to modify dst even if it happens
-  to be a fixed reg -- that's not your problem.
-
-* You cannot assume that a fixed reg will stay live over an
-  arbitrary computation.  The same applies to the dst reg.
-
-* Temporary regs obtained from getNewRegNat are distinct from
-  each other and from all other regs, and stay live over
-  arbitrary computations.
-
---------------------
-
-SDM's version of The Rules:
-
-* If getRegister returns Any, that means it can generate correct
-  code which places the result in any register, period.  Even if that
-  register happens to be read during the computation.
-
-  Corollary #1: this means that if you are generating code for an
-  operation with two arbitrary operands, you cannot assign the result
-  of the first operand into the destination register before computing
-  the second operand.  The second operand might require the old value
-  of the destination register.
-
-  Corollary #2: A function might be able to generate more efficient
-  code if it knows the destination register is a new temporary (and
-  therefore not read by any of the sub-computations).
-
-* If getRegister returns Any, then the code it generates may modify only:
-        (a) fresh temporaries
-        (b) the destination register
-        (c) known registers (eg. %ecx is used by shifts)
-  In particular, it may *not* modify global registers, unless the global
-  register happens to be the destination register.
--}
-
-trivialCode :: Width -> (Operand -> Operand -> Instr)
-            -> Maybe (Operand -> Operand -> Instr)
-            -> CmmExpr -> CmmExpr -> NatM Register
-trivialCode width instr m a b
-    = do platform <- getPlatform
-         trivialCode' platform width instr m a b
-
-trivialCode' :: Platform -> Width -> (Operand -> Operand -> Instr)
-             -> Maybe (Operand -> Operand -> Instr)
-             -> CmmExpr -> CmmExpr -> NatM Register
-trivialCode' platform width _ (Just revinstr) (CmmLit lit_a) b
-  | is32BitLit platform lit_a = do
-  b_code <- getAnyReg b
-  let
-       code dst
-         = b_code dst `snocOL`
-           revinstr (OpImm (litToImm lit_a)) (OpReg dst)
-  return (Any (intFormat width) code)
-
-trivialCode' _ width instr _ a b
-  = genTrivialCode (intFormat width) instr a b
-
--- This is re-used for floating pt instructions too.
-genTrivialCode :: Format -> (Operand -> Operand -> Instr)
-               -> CmmExpr -> CmmExpr -> NatM Register
-genTrivialCode rep instr a b = do
-  (b_op, b_code) <- getNonClobberedOperand b
-  a_code <- getAnyReg a
-  tmp <- getNewRegNat rep
-  let
-     -- We want the value of b to stay alive across the computation of a.
-     -- But, we want to calculate a straight into the destination register,
-     -- because the instruction only has two operands (dst := dst `op` src).
-     -- The troublesome case is when the result of b is in the same register
-     -- as the destination reg.  In this case, we have to save b in a
-     -- new temporary across the computation of a.
-     code dst
-        | dst `regClashesWithOp` b_op =
-                b_code `appOL`
-                unitOL (MOV rep b_op (OpReg tmp)) `appOL`
-                a_code dst `snocOL`
-                instr (OpReg tmp) (OpReg dst)
-        | otherwise =
-                b_code `appOL`
-                a_code dst `snocOL`
-                instr b_op (OpReg dst)
-  return (Any rep code)
-
-regClashesWithOp :: Reg -> Operand -> Bool
-reg `regClashesWithOp` OpReg reg2   = reg == reg2
-reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)
-_   `regClashesWithOp` _            = False
-
------------
-
-trivialUCode :: Format -> (Operand -> Instr)
-             -> CmmExpr -> NatM Register
-trivialUCode rep instr x = do
-  x_code <- getAnyReg x
-  let
-     code dst =
-        x_code dst `snocOL`
-        instr (OpReg dst)
-  return (Any rep code)
-
------------
-
-
-trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr)
-                  -> CmmExpr -> CmmExpr -> NatM Register
-trivialFCode_sse2 pk instr x y
-    = genTrivialCode format (instr format) x y
-    where format = floatFormat pk
-
-
---------------------------------------------------------------------------------
-coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
-coerceInt2FP from to x =  coerce_sse2
- where
-
-   coerce_sse2 = do
-     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand
-     let
-           opc  = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD
-                             n -> panic $ "coerceInt2FP.sse: unhandled width ("
-                                         ++ show n ++ ")"
-           code dst = x_code `snocOL` opc (intFormat from) x_op dst
-     return (Any (floatFormat to) code)
-        -- works even if the destination rep is <II32
-
---------------------------------------------------------------------------------
-coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
-coerceFP2Int from to x =  coerceFP2Int_sse2
- where
-   coerceFP2Int_sse2 = do
-     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand
-     let
-           opc  = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;
-                               n -> panic $ "coerceFP2Init.sse: unhandled width ("
-                                           ++ show n ++ ")"
-           code dst = x_code `snocOL` opc (intFormat to) x_op dst
-     return (Any (intFormat to) code)
-         -- works even if the destination rep is <II32
-
-
---------------------------------------------------------------------------------
-coerceFP2FP :: Width -> CmmExpr -> NatM Register
-coerceFP2FP to x = do
-  (x_reg, x_code) <- getSomeReg x
-  let
-        opc  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;
-                                     n -> panic $ "coerceFP2FP: unhandled width ("
-                                                 ++ show n ++ ")"
-        code dst = x_code `snocOL` opc x_reg dst
-  return (Any ( floatFormat to) code)
-
---------------------------------------------------------------------------------
-
-sse2NegCode :: Width -> CmmExpr -> NatM Register
-sse2NegCode w x = do
-  let fmt = floatFormat w
-  x_code <- getAnyReg x
-  -- This is how gcc does it, so it can't be that bad:
-  let
-    const = case fmt of
-      FF32 -> CmmInt 0x80000000 W32
-      FF64 -> CmmInt 0x8000000000000000 W64
-      x@II8  -> wrongFmt x
-      x@II16 -> wrongFmt x
-      x@II32 -> wrongFmt x
-      x@II64 -> wrongFmt x
-
-      where
-        wrongFmt x = panic $ "sse2NegCode: " ++ show x
-  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const
-  tmp <- getNewRegNat fmt
-  let
-    code dst = x_code dst `appOL` amode_code `appOL` toOL [
-        MOV fmt (OpAddr amode) (OpReg tmp),
-        XOR fmt (OpReg tmp) (OpReg dst)
-        ]
-  --
-  return (Any fmt code)
-
-isVecExpr :: CmmExpr -> Bool
-isVecExpr (CmmMachOp (MO_V_Insert {}) _)   = True
-isVecExpr (CmmMachOp (MO_V_Extract {}) _)  = True
-isVecExpr (CmmMachOp (MO_V_Add {}) _)      = True
-isVecExpr (CmmMachOp (MO_V_Sub {}) _)      = True
-isVecExpr (CmmMachOp (MO_V_Mul {}) _)      = True
-isVecExpr (CmmMachOp (MO_VS_Quot {}) _)    = True
-isVecExpr (CmmMachOp (MO_VS_Rem {}) _)     = True
-isVecExpr (CmmMachOp (MO_VS_Neg {}) _)     = True
-isVecExpr (CmmMachOp (MO_VF_Insert {}) _)  = True
-isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True
-isVecExpr (CmmMachOp (MO_VF_Add {}) _)     = True
-isVecExpr (CmmMachOp (MO_VF_Sub {}) _)     = True
-isVecExpr (CmmMachOp (MO_VF_Mul {}) _)     = True
-isVecExpr (CmmMachOp (MO_VF_Quot {}) _)    = True
-isVecExpr (CmmMachOp (MO_VF_Neg {}) _)     = True
-isVecExpr (CmmMachOp _ [e])                = isVecExpr e
-isVecExpr _                                = False
-
-needLlvm :: NatM a
-needLlvm =
-    sorry $ unlines ["The native code generator does not support vector"
-                    ,"instructions. Please use -fllvm."]
-
--- | This works on the invariant that all jumps in the given blocks are required.
---   Starting from there we try to make a few more jumps redundant by reordering
---   them.
---   We depend on the information in the CFG to do so so without a given CFG
---   we do nothing.
-invertCondBranches :: Maybe CFG  -- ^ CFG if present
-                   -> LabelMap a -- ^ Blocks with info tables
-                   -> [NatBasicBlock Instr] -- ^ List of basic blocks
-                   -> [NatBasicBlock Instr]
-invertCondBranches Nothing _       bs = bs
-invertCondBranches (Just cfg) keep bs =
-    invert bs
-  where
-    invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]
-    invert (BasicBlock lbl1 ins:b2@(BasicBlock lbl2 _):bs)
-      | --pprTrace "Block" (ppr lbl1) True,
-        Just (jmp1,jmp2) <- last2 ins
-      , JXX cond1 target1 <- jmp1
-      , target1 == lbl2
-      --, pprTrace "CutChance" (ppr b1) True
-      , JXX ALWAYS target2 <- jmp2
-      -- We have enough information to check if we can perform the inversion
-      -- TODO: We could also check for the last asm instruction which sets
-      -- status flags instead. Which I suspect is worse in terms of compiler
-      -- performance, but might be applicable to more cases
-      , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg
-      , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg
-      -- Both jumps come from the same cmm statement
-      , transitionSource edgeInfo1 == transitionSource edgeInfo2
-      , CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1
-
-      --Int comparisons are invertable
-      , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch
-      , Just _ <- maybeIntComparison op
-      , Just invCond <- maybeInvertCond cond1
-
-      --Swap the last two jumps, invert the conditional jumps condition.
-      = let jumps =
-              case () of
-                -- We are free the eliminate the jmp. So we do so.
-                _ | not (mapMember target1 keep)
-                    -> [JXX invCond target2]
-                -- If the conditional target is unlikely we put the other
-                -- target at the front.
-                  | edgeWeight edgeInfo2 > edgeWeight edgeInfo1
-                    -> [JXX invCond target2, JXX ALWAYS target1]
-                -- Keep things as-is otherwise
-                  | otherwise
-                    -> [jmp1, jmp2]
-        in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $
-           (BasicBlock lbl1
-            (dropTail 2 ins ++ jumps))
-            : invert (b2:bs)
-    invert (b:bs) = b : invert bs
-    invert [] = []
-
-genAtomicRMW
-  :: BlockId
-  -> Width
-  -> AtomicMachOp
-  -> LocalReg
-  -> CmmExpr
-  -> CmmExpr
-  -> NatM (InstrBlock, Maybe BlockId)
-genAtomicRMW bid width amop dst addr n = do
-    Amode amode addr_code <-
-        if amop `elem` [AMO_Add, AMO_Sub]
-        then getAmode addr
-        else getSimpleAmode addr  -- See genForeignCall for MO_Cmpxchg
-    arg <- getNewRegNat format
-    arg_code <- getAnyReg n
-    platform <- ncgPlatform <$> getConfig
-
-    let dst_r    = getRegisterReg platform  (CmmLocal dst)
-    (code, lbl) <- op_code dst_r arg amode
-    return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)
-  where
-    -- Code for the operation
-    op_code :: Reg       -- Destination reg
-            -> Reg       -- Register containing argument
-            -> AddrMode  -- Address of location to mutate
-            -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId
-    op_code dst_r arg amode = case amop of
-        -- In the common case where dst_r is a virtual register the
-        -- final move should go away, because it's the last use of arg
-        -- and the first use of dst_r.
-        AMO_Add  -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))
-                                   , MOV format (OpReg arg) (OpReg dst_r)
-                                   ], bid)
-        AMO_Sub  -> return $ (toOL [ NEGI format (OpReg arg)
-                                   , LOCK (XADD format (OpReg arg) (OpAddr amode))
-                                   , MOV format (OpReg arg) (OpReg dst_r)
-                                   ], bid)
-        -- In these cases we need a new block id, and have to return it so
-        -- that later instruction selection can reference it.
-        AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)
-        AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst
-                                                    , NOT format dst
-                                                    ])
-        AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)
-        AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)
-      where
-        -- Simulate operation that lacks a dedicated instruction using
-        -- cmpxchg.
-        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)
-                     -> NatM (OrdList Instr, BlockId)
-        cmpxchg_code instrs = do
-            lbl1 <- getBlockIdNat
-            lbl2 <- getBlockIdNat
-            tmp <- getNewRegNat format
-
-            --Record inserted blocks
-            --  We turn A -> B into A -> A' -> A'' -> B
-            --  with a self loop on A'.
-            addImmediateSuccessorNat bid lbl1
-            addImmediateSuccessorNat lbl1 lbl2
-            updateCfgNat (addWeightEdge lbl1 lbl1 0)
-
-            return $ (toOL
-                [ MOV format (OpAddr amode) (OpReg eax)
-                , JXX ALWAYS lbl1
-                , NEWBLOCK lbl1
-                  -- Keep old value so we can return it:
-                , MOV format (OpReg eax) (OpReg dst_r)
-                , MOV format (OpReg eax) (OpReg tmp)
-                ]
-                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL
-                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))
-                , JXX NE lbl1
-                -- See Note [Introducing cfg edges inside basic blocks]
-                -- why this basic block is required.
-                , JXX ALWAYS lbl2
-                , NEWBLOCK lbl2
-                ],
-                lbl2)
-    format = intFormat width
-
--- | Count trailing zeroes
-genCtz :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM (InstrBlock, Maybe BlockId)
-genCtz bid width dst src = do
-  is32Bit <- is32BitPlatform
-  if is32Bit && width == W64
-    then genCtz64_32 bid dst src
-    else (,Nothing) <$> genCtzGeneric width dst src
-
--- | Count trailing zeroes
---
--- 64-bit width on 32-bit architecture
-genCtz64_32
-  :: BlockId
-  -> LocalReg
-  -> CmmExpr
-  -> NatM (InstrBlock, Maybe BlockId)
-genCtz64_32 bid dst src = do
-  RegCode64 vcode rhi rlo <- iselExpr64 src
-  let dst_r = getLocalRegReg dst
-  lbl1 <- getBlockIdNat
-  lbl2 <- getBlockIdNat
-  tmp_r <- getNewRegNat II64
-
-  -- New CFG Edges:
-  --  bid -> lbl2
-  --  bid -> lbl1 -> lbl2
-  --  We also changes edges originating at bid to start at lbl2 instead.
-  weights <- getCfgWeights
-  updateCfgNat (addWeightEdge bid lbl1 110 .
-                addWeightEdge lbl1 lbl2 110 .
-                addImmediateSuccessor weights bid lbl2)
-
-  -- The following instruction sequence corresponds to the pseudo-code
-  --
-  --  if (src) {
-  --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);
-  --  } else {
-  --    dst = 64;
-  --  }
-  let instrs = vcode `appOL` toOL
-           ([ MOV      II32 (OpReg rhi)         (OpReg tmp_r)
-            , OR       II32 (OpReg rlo)         (OpReg tmp_r)
-            , MOV      II32 (OpImm (ImmInt 64)) (OpReg dst_r)
-            , JXX EQQ    lbl2
-            , JXX ALWAYS lbl1
-
-            , NEWBLOCK   lbl1
-            , BSF     II32 (OpReg rhi)         dst_r
-            , ADD     II32 (OpImm (ImmInt 32)) (OpReg dst_r)
-            , BSF     II32 (OpReg rlo)         tmp_r
-            , CMOV NE II32 (OpReg tmp_r)       dst_r
-            , JXX ALWAYS lbl2
-
-            , NEWBLOCK   lbl2
-            ])
-  return (instrs, Just lbl2)
-
--- | Count trailing zeroes
---
--- Generic case (width <= word size)
-genCtzGeneric :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
-genCtzGeneric width dst src = do
-  code_src <- getAnyReg src
-  config <- getConfig
-  let bw = widthInBits width
-  let dst_r = getLocalRegReg dst
-  if ncgBmiVersion config >= Just BMI2
-  then do
-      src_r <- getNewRegNat (intFormat width)
-      let instrs = appOL (code_src src_r) $ case width of
-              W8 -> toOL
-                  [ OR    II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r)
-                  , TZCNT II32 (OpReg src_r) dst_r
-                  ]
-              W16 -> toOL
-                  [ TZCNT  II16 (OpReg src_r) dst_r
-                  , MOVZxL II16 (OpReg dst_r) (OpReg dst_r)
-                  ]
-              _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r
-      return instrs
-  else do
-      -- The following insn sequence makes sure 'ctz 0' has a defined value.
-      -- starting with Haswell, one could use the TZCNT insn instead.
-      let format = if width == W8 then II16 else intFormat width
-      src_r <- getNewRegNat format
-      tmp_r <- getNewRegNat format
-      let instrs = code_src src_r `appOL` toOL
-               ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] ++
-                [ BSF     format (OpReg src_r) tmp_r
-                , MOV     II32   (OpImm (ImmInt bw)) (OpReg dst_r)
-                , CMOV NE format (OpReg tmp_r) dst_r
-                ]) -- NB: We don't need to zero-extend the result for the
-                   -- W8/W16 cases because the 'MOV' insn already
-                   -- took care of implicitly clearing the upper bits
-      return instrs
-
-
-
--- | Copy memory
---
--- Unroll memcpy calls if the number of bytes to copy isn't too large (cf
--- ncgInlineThresholdMemcpy).  Otherwise, call C's memcpy.
-genMemCpy
-  :: BlockId
-  -> Int
-  -> CmmExpr
-  -> CmmExpr
-  -> CmmExpr
-  -> NatM InstrBlock
-genMemCpy bid align dst src arg_n = do
-
-  let libc_memcpy = genLibCCall bid (fsLit "memcpy") [] [dst,src,arg_n]
-
-  case arg_n of
-    CmmLit (CmmInt n _) -> do
-      -- try to inline it
-      mcode <- genMemCpyInlineMaybe align dst src n
-      -- if it didn't inline, call the C function
-      case mcode of
-        Nothing -> libc_memcpy
-        Just c  -> pure c
-
-    -- not a literal size argument: call the C function
-    _ -> libc_memcpy
-
-
-
-genMemCpyInlineMaybe
-  :: Int
-  -> CmmExpr
-  -> CmmExpr
-  -> Integer
-  -> NatM (Maybe InstrBlock)
-genMemCpyInlineMaybe align dst src n = do
-  config <- getConfig
-  let
-    platform     = ncgPlatform config
-    maxAlignment = wordAlignment platform
-                   -- only machine word wide MOVs are supported
-    effectiveAlignment = min (alignmentOf align) maxAlignment
-    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment
-
-
-  -- The size of each move, in bytes.
-  let sizeBytes :: Integer
-      sizeBytes = fromIntegral (formatInBytes format)
-
-  -- The number of instructions we will generate (approx). We need 2
-  -- instructions per move.
-  let insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)
-
-      go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr
-      go dst src tmp i
-          | i >= sizeBytes =
-              unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL`
-              unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL`
-              go dst src tmp (i - sizeBytes)
-          -- Deal with remaining bytes.
-          | i >= 4 =  -- Will never happen on 32-bit
-              unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL`
-              unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL`
-              go dst src tmp (i - 4)
-          | i >= 2 =
-              unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL`
-              unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL`
-              go dst src tmp (i - 2)
-          | i >= 1 =
-              unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL`
-              unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL`
-              go dst src tmp (i - 1)
-          | otherwise = nilOL
-        where
-          src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone
-                       (ImmInteger (n - i))
-
-          dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone
-                       (ImmInteger (n - i))
-
-  if insns > fromIntegral (ncgInlineThresholdMemcpy config)
-    then pure Nothing
-    else do
-      code_dst <- getAnyReg dst
-      dst_r <- getNewRegNat format
-      code_src <- getAnyReg src
-      src_r <- getNewRegNat format
-      tmp_r <- getNewRegNat format
-      pure $ Just $ code_dst dst_r `appOL` code_src src_r `appOL`
-                      go dst_r src_r tmp_r (fromInteger n)
-
--- | Set memory to the given byte
---
--- Unroll memset calls if the number of bytes to copy isn't too large (cf
--- ncgInlineThresholdMemset).  Otherwise, call C's memset.
-genMemSet
-  :: BlockId
-  -> Int
-  -> CmmExpr
-  -> CmmExpr
-  -> CmmExpr
-  -> NatM InstrBlock
-genMemSet bid align dst arg_c arg_n = do
-
-  let libc_memset = genLibCCall bid (fsLit "memset") [] [dst,arg_c,arg_n]
-
-  case (arg_c,arg_n) of
-    (CmmLit (CmmInt c _), CmmLit (CmmInt n _)) -> do
-      -- try to inline it
-      mcode <- genMemSetInlineMaybe align dst c n
-      -- if it didn't inline, call the C function
-      case mcode of
-        Nothing -> libc_memset
-        Just c  -> pure c
-
-    -- not literal size arguments: call the C function
-    _ -> libc_memset
-
-genMemSetInlineMaybe
-  :: Int
-  -> CmmExpr
-  -> Integer
-  -> Integer
-  -> NatM (Maybe InstrBlock)
-genMemSetInlineMaybe align dst c n = do
-  config <- getConfig
-  let
-    platform = ncgPlatform config
-    maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported
-    effectiveAlignment = min (alignmentOf align) maxAlignment
-    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment
-    c2 = c `shiftL` 8 .|. c
-    c4 = c2 `shiftL` 16 .|. c2
-    c8 = c4 `shiftL` 32 .|. c4
-
-    -- The number of instructions we will generate (approx). We need 1
-    -- instructions per move.
-    insns = (n + sizeBytes - 1) `div` sizeBytes
-
-    -- The size of each move, in bytes.
-    sizeBytes :: Integer
-    sizeBytes = fromIntegral (formatInBytes format)
-
-    -- Depending on size returns the widest MOV instruction and its
-    -- width.
-    gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)
-    gen4 addr size
-        | size >= 4 =
-            (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4)
-        | size >= 2 =
-            (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2)
-        | size >= 1 =
-            (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1)
-        | otherwise = (nilOL, 0)
-
-    -- Generates a 64-bit wide MOV instruction from REG to MEM.
-    gen8 :: AddrMode -> Reg -> InstrBlock
-    gen8 addr reg8byte =
-      unitOL (MOV format (OpReg reg8byte) (OpAddr addr))
-
-    -- Unrolls memset when the widest MOV is <= 4 bytes.
-    go4 :: Reg -> Integer -> InstrBlock
-    go4 dst left =
-      if left <= 0 then nilOL
-      else curMov `appOL` go4 dst (left - curWidth)
-      where
-        possibleWidth = minimum [left, sizeBytes]
-        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))
-        (curMov, curWidth) = gen4 dst_addr possibleWidth
-
-    -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg
-    -- argument). Falls back to go4 when all 8 byte moves are
-    -- exhausted.
-    go8 :: Reg -> Reg -> Integer -> InstrBlock
-    go8 dst reg8byte left =
-      if possibleWidth >= 8 then
-        let curMov = gen8 dst_addr reg8byte
-        in  curMov `appOL` go8 dst reg8byte (left - 8)
-      else go4 dst left
-      where
-        possibleWidth = minimum [left, sizeBytes]
-        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))
-
-  if fromInteger insns > ncgInlineThresholdMemset config
-    then pure Nothing
-    else do
-        code_dst <- getAnyReg dst
-        dst_r <- getNewRegNat format
-        if format == II64 && n >= 8
-          then do
-            code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64))
-            imm8byte_r <- getNewRegNat II64
-            return $ Just $ code_dst dst_r `appOL`
-                              code_imm8byte imm8byte_r `appOL`
-                              go8 dst_r imm8byte_r (fromInteger n)
-          else
-            return $ Just $ code_dst dst_r `appOL`
-                              go4 dst_r (fromInteger n)
-
-
-genMemMove :: BlockId -> p -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock
-genMemMove bid _align dst src n = do
-  -- TODO: generate inline assembly when under a given treshold (similarly to
-  -- memcpy and memset)
-  genLibCCall bid (fsLit "memmove") [] [dst,src,n]
-
-genMemCmp :: BlockId -> p -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock
-genMemCmp bid _align res dst src n = do
-  -- TODO: generate inline assembly when under a given treshold (similarly to
-  -- memcpy and memset)
-  genLibCCall bid (fsLit "memcmp") [res] [dst,src,n]
-
-genPrefetchData :: Int -> CmmExpr -> NatM (OrdList Instr)
-genPrefetchData n src = do
-  is32Bit <- is32BitPlatform
-  let
-    format = archWordFormat is32Bit
-    -- need to know what register width for pointers!
-    genPrefetch inRegSrc prefetchCTor = do
-      code_src <- getAnyReg inRegSrc
-      src_r <- getNewRegNat format
-      return $ code_src src_r `appOL`
-        (unitOL (prefetchCTor  (OpAddr
-                    ((AddrBaseIndex (EABaseReg src_r )   EAIndexNone (ImmInt 0))))  ))
-        -- prefetch always takes an address
-
-  -- the c / llvm prefetch convention is 0, 1, 2, and 3
-  -- the x86 corresponding names are : NTA, 2 , 1, and 0
-  case n of
-      0 -> genPrefetch src $ PREFETCH NTA  format
-      1 -> genPrefetch src $ PREFETCH Lvl2 format
-      2 -> genPrefetch src $ PREFETCH Lvl1 format
-      3 -> genPrefetch src $ PREFETCH Lvl0 format
-      l -> pprPanic "genPrefetchData: unexpected prefetch level" (ppr l)
-
-genByteSwap :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
-genByteSwap width dst src = do
-  is32Bit <- is32BitPlatform
-  let format = intFormat width
-  case width of
-      W64 | is32Bit -> do
-        let Reg64 dst_hi dst_lo = localReg64 dst
-        RegCode64 vcode rhi rlo <- iselExpr64 src
-        return $ vcode `appOL`
-                 toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi),
-                        MOV II32 (OpReg rhi) (OpReg dst_lo),
-                        BSWAP II32 dst_hi,
-                        BSWAP II32 dst_lo ]
-      W16 -> do
-        let dst_r = getLocalRegReg dst
-        code_src <- getAnyReg src
-        return $ code_src dst_r `appOL`
-                 unitOL (BSWAP II32 dst_r) `appOL`
-                 unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r))
-      _   -> do
-        let dst_r = getLocalRegReg dst
-        code_src <- getAnyReg src
-        return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r)
-
-genBitRev :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock
-genBitRev bid width dst src = do
-  -- Here the C implementation (hs_bitrevN) is used as there is no x86
-  -- instruction to reverse a word's bit order.
-  genPrimCCall bid (bRevLabel width) [dst] [src]
-
-genPopCnt :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM InstrBlock
-genPopCnt bid width dst src = do
-  config <- getConfig
-  let
-    platform = ncgPlatform config
-    format = intFormat width
-
-  sse4_2Enabled >>= \case
-
-    True -> do
-      code_src <- getAnyReg src
-      src_r <- getNewRegNat format
-      let dst_r = getRegisterReg platform  (CmmLocal dst)
-      return $ code_src src_r `appOL`
-          (if width == W8 then
-               -- The POPCNT instruction doesn't take a r/m8
-               unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`
-               unitOL (POPCNT II16 (OpReg src_r) dst_r)
-           else
-               unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`
-          (if width == W8 || width == W16 then
-               -- We used a 16-bit destination register above,
-               -- so zero-extend
-               unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
-           else nilOL)
-
-    False ->
-      -- generate C call to hs_popcntN in ghc-prim
-      -- TODO: we could directly generate the assembly to index popcount_tab
-      -- here instead of doing it by calling a C function
-      genPrimCCall bid (popCntLabel width) [dst] [src]
-
-
-genPdep :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genPdep bid width dst src mask = do
-  config <- getConfig
-  let
-    platform = ncgPlatform config
-    format = intFormat width
-
-  if ncgBmiVersion config >= Just BMI2
-    then do
-      code_src  <- getAnyReg src
-      code_mask <- getAnyReg mask
-      src_r     <- getNewRegNat format
-      mask_r    <- getNewRegNat format
-      let dst_r = getRegisterReg platform  (CmmLocal dst)
-      return $ code_src src_r `appOL` code_mask mask_r `appOL`
-          -- PDEP only supports > 32 bit args
-          ( if width == W8 || width == W16 then
-              toOL
-                [ MOVZxL format (OpReg src_r ) (OpReg src_r )
-                , MOVZxL format (OpReg mask_r) (OpReg mask_r)
-                , PDEP   II32 (OpReg mask_r) (OpReg src_r ) dst_r
-                , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width
-                ]
-            else
-              unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)
-          )
-    else
-      -- generate C call to hs_pdepN in ghc-prim
-      genPrimCCall bid (pdepLabel width) [dst] [src,mask]
-
-
-genPext :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genPext bid width dst src mask = do
-  config <- getConfig
-  if ncgBmiVersion config >= Just BMI2
-    then do
-      let format   = intFormat width
-      let dst_r    = getLocalRegReg dst
-      code_src  <- getAnyReg src
-      code_mask <- getAnyReg mask
-      src_r     <- getNewRegNat format
-      mask_r    <- getNewRegNat format
-      return $ code_src src_r `appOL` code_mask mask_r `appOL`
-          (if width == W8 || width == W16 then
-               -- The PEXT instruction doesn't take a r/m8 or 16
-              toOL
-                [ MOVZxL format (OpReg src_r ) (OpReg src_r )
-                , MOVZxL format (OpReg mask_r) (OpReg mask_r)
-                , PEXT   II32 (OpReg mask_r) (OpReg src_r ) dst_r
-                , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width
-                ]
-            else
-              unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)
-          )
-    else
-      -- generate C call to hs_pextN in ghc-prim
-      genPrimCCall bid (pextLabel width) [dst] [src,mask]
-
-genClz :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock
-genClz bid width dst src = do
-  is32Bit <- is32BitPlatform
-  config <- getConfig
-  if is32Bit && width == W64
-
-    then
-      -- Fallback to `hs_clz64` on i386
-      genPrimCCall bid (clzLabel width) [dst] [src]
-
-    else do
-      code_src <- getAnyReg src
-      let dst_r = getLocalRegReg dst
-      if ncgBmiVersion config >= Just BMI2
-        then do
-          src_r <- getNewRegNat (intFormat width)
-          return $ appOL (code_src src_r) $ case width of
-            W8 -> toOL
-                [ MOVZxL II8  (OpReg src_r)       (OpReg src_r) -- zero-extend to 32 bit
-                , LZCNT  II32 (OpReg src_r)       dst_r         -- lzcnt with extra 24 zeros
-                , SUB    II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros
-                ]
-            W16 -> toOL
-                [ LZCNT  II16 (OpReg src_r) dst_r
-                , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit
-                ]
-            _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r)
-        else do
-          let format = if width == W8 then II16 else intFormat width
-          let bw = widthInBits width
-          src_r <- getNewRegNat format
-          tmp_r <- getNewRegNat format
-          return $ code_src src_r `appOL` toOL
-                   ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] ++
-                    [ BSR     format (OpReg src_r) tmp_r
-                    , MOV     II32   (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)
-                    , CMOV NE format (OpReg tmp_r) dst_r
-                    , XOR     format (OpImm (ImmInt (bw-1))) (OpReg dst_r)
-                    ]) -- NB: We don't need to zero-extend the result for the
-                       -- W8/W16 cases because the 'MOV' insn already
-                       -- took care of implicitly clearing the upper bits
-
-genWordToFloat :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock
-genWordToFloat bid width dst src =
-  -- TODO: generate assembly instead
-  genPrimCCall bid (word2FloatLabel width) [dst] [src]
-
-genAtomicRead :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
-genAtomicRead width dst addr = do
-  load_code <- intLoadCode (MOV (intFormat width)) addr
-  return (load_code (getLocalRegReg dst))
-
-genAtomicWrite :: Width -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genAtomicWrite width addr val = do
-  code <- assignMem_IntCode (intFormat width) addr val
-  return $ code `snocOL` MFENCE
-
-genCmpXchg
-  :: BlockId
-  -> Width
-  -> LocalReg
-  -> CmmExpr
-  -> CmmExpr
-  -> CmmExpr
-  -> NatM InstrBlock
-genCmpXchg bid width dst addr old new = do
-  is32Bit <- is32BitPlatform
-  -- On x86 we don't have enough registers to use cmpxchg with a
-  -- complicated addressing mode, so on that architecture we
-  -- pre-compute the address first.
-  if not (is32Bit && width == W64)
-    then do
-      let format = intFormat width
-      Amode amode addr_code <- getSimpleAmode addr
-      newval <- getNewRegNat format
-      newval_code <- getAnyReg new
-      oldval <- getNewRegNat format
-      oldval_code <- getAnyReg old
-      platform <- getPlatform
-      let dst_r    = getRegisterReg platform  (CmmLocal dst)
-          code     = toOL
-                     [ MOV format (OpReg oldval) (OpReg eax)
-                     , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))
-                     , MOV format (OpReg eax) (OpReg dst_r)
-                     ]
-      return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval
-          `appOL` code
-    else
-      -- generate C call to hs_cmpxchgN in ghc-prim
-      genPrimCCall bid (cmpxchgLabel width) [dst] [addr,old,new]
-      -- TODO: implement cmpxchg8b instruction
-
-genXchg :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genXchg width dst addr value = do
-  is32Bit <- is32BitPlatform
-
-  when (is32Bit && width == W64) $
-    panic "genXchg: 64bit atomic exchange not supported on 32bit platforms"
-
-  Amode amode addr_code <- getSimpleAmode addr
-  (newval, newval_code) <- getSomeReg value
-  let format   = intFormat width
-  let dst_r    = getLocalRegReg dst
-  -- Copy the value into the target register, perform the exchange.
-  let code     = toOL
-                 [ MOV format (OpReg newval) (OpReg dst_r)
-                  -- On X86 xchg implies a lock prefix if we use a memory argument.
-                  -- so this is atomic.
-                 , XCHG format (OpAddr amode) dst_r
-                 ]
-  return $ addr_code `appOL` newval_code `appOL` code
-
-
-genFloatAbs :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock
-genFloatAbs width dst src = do
-  let
-    format = floatFormat width
-    const = case width of
-      W32 -> CmmInt 0x7fffffff W32
-      W64 -> CmmInt 0x7fffffffffffffff W64
-      _   -> pprPanic "genFloatAbs: invalid width" (ppr width)
-  src_code <- getAnyReg src
-  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes width) const
-  tmp <- getNewRegNat format
-  let dst_r = getLocalRegReg dst
-  pure $ src_code dst_r `appOL` amode_code `appOL` toOL
-           [ MOV format (OpAddr amode) (OpReg tmp)
-           , AND format (OpReg tmp) (OpReg dst_r)
-           ]
-
-
-genFloatSqrt :: Format -> LocalReg -> CmmExpr -> NatM InstrBlock
-genFloatSqrt format dst src = do
-  let dst_r = getLocalRegReg dst
-  src_code <- getAnyReg src
-  pure $ src_code dst_r `snocOL` SQRT format (OpReg dst_r) dst_r
-
-
-genAddSubRetCarry
-  :: Width
-  -> (Format -> Operand -> Operand -> Instr)
-  -> (Format -> Maybe (Operand -> Operand -> Instr))
-  -> Cond
-  -> LocalReg
-  -> LocalReg
-  -> CmmExpr
-  -> CmmExpr
-  -> NatM InstrBlock
-genAddSubRetCarry width instr mrevinstr cond res_r res_c arg_x arg_y = do
-  platform <- ncgPlatform <$> getConfig
-  let format = intFormat width
-  rCode <- anyReg =<< trivialCode width (instr format)
-                        (mrevinstr format) arg_x arg_y
-  reg_tmp <- getNewRegNat II8
-  let reg_c = getRegisterReg platform  (CmmLocal res_c)
-      reg_r = getRegisterReg platform  (CmmLocal res_r)
-      code = rCode reg_r `snocOL`
-             SETCC cond (OpReg reg_tmp) `snocOL`
-             MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)
-  return code
-
-
-genAddWithCarry
-  :: Width
-  -> LocalReg
-  -> LocalReg
-  -> CmmExpr
-  -> CmmExpr
-  -> NatM InstrBlock
-genAddWithCarry width res_h res_l arg_x arg_y = do
-  hCode <- getAnyReg (CmmLit (CmmInt 0 width))
-  let format = intFormat width
-  lCode <- anyReg =<< trivialCode width (ADD_CC format)
-                        (Just (ADD_CC format)) arg_x arg_y
-  let reg_l = getLocalRegReg res_l
-      reg_h = getLocalRegReg res_h
-      code = hCode reg_h `appOL`
-             lCode reg_l `snocOL`
-             ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)
-  return code
-
-
-genSignedLargeMul
-  :: Width
-  -> LocalReg
-  -> LocalReg
-  -> LocalReg
-  -> CmmExpr
-  -> CmmExpr
-  -> NatM (OrdList Instr)
-genSignedLargeMul width res_c res_h res_l arg_x arg_y = do
-  (y_reg, y_code) <- getRegOrMem arg_y
-  x_code <- getAnyReg arg_x
-  reg_tmp <- getNewRegNat II8
-  let format = intFormat width
-      reg_h = getLocalRegReg res_h
-      reg_l = getLocalRegReg res_l
-      reg_c = getLocalRegReg res_c
-      code = y_code `appOL`
-             x_code rax `appOL`
-             toOL [ IMUL2 format y_reg
-                  , MOV format (OpReg rdx) (OpReg reg_h)
-                  , MOV format (OpReg rax) (OpReg reg_l)
-                  , SETCC CARRY (OpReg reg_tmp)
-                  , MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)
-                  ]
-  return code
-
-genUnsignedLargeMul
-  :: Width
-  -> LocalReg
-  -> LocalReg
-  -> CmmExpr
-  -> CmmExpr
-  -> NatM (OrdList Instr)
-genUnsignedLargeMul width res_h res_l arg_x arg_y = do
-  (y_reg, y_code) <- getRegOrMem arg_y
-  x_code <- getAnyReg arg_x
-  let format = intFormat width
-      reg_h = getLocalRegReg res_h
-      reg_l = getLocalRegReg res_l
-      code = y_code `appOL`
-             x_code rax `appOL`
-             toOL [MUL2 format y_reg,
-                   MOV format (OpReg rdx) (OpReg reg_h),
-                   MOV format (OpReg rax) (OpReg reg_l)]
-  return code
-
-
-genQuotRem
-  :: Width
-  -> Bool
-  -> LocalReg
-  -> LocalReg
-  -> Maybe CmmExpr
-  -> CmmExpr
-  -> CmmExpr
-  -> NatM InstrBlock
-genQuotRem width signed res_q res_r m_arg_x_high arg_x_low arg_y = do
-  case width of
-    W8 -> do
-      -- See Note [DIV/IDIV for bytes]
-      let widen | signed = MO_SS_Conv W8 W16
-                | otherwise = MO_UU_Conv W8 W16
-          arg_x_low_16 = CmmMachOp widen [arg_x_low]
-          arg_y_16 = CmmMachOp widen [arg_y]
-          m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high
-      genQuotRem W16 signed res_q res_r m_arg_x_high_16 arg_x_low_16 arg_y_16
-
-    _ -> do
-      let format = intFormat width
-          reg_q = getLocalRegReg res_q
-          reg_r = getLocalRegReg res_r
-          widen | signed    = CLTD format
-                | otherwise = XOR format (OpReg rdx) (OpReg rdx)
-          instr | signed    = IDIV
-                | otherwise = DIV
-      (y_reg, y_code) <- getRegOrMem arg_y
-      x_low_code <- getAnyReg arg_x_low
-      x_high_code <- case m_arg_x_high of
-                     Just arg_x_high ->
-                         getAnyReg arg_x_high
-                     Nothing ->
-                         return $ const $ unitOL widen
-      return $ y_code `appOL`
-               x_low_code rax `appOL`
-               x_high_code rdx `appOL`
-               toOL [instr format y_reg,
-                     MOV format (OpReg rax) (OpReg reg_q),
-                     MOV format (OpReg rdx) (OpReg reg_r)]
-
-
-----------------------------------------------------------------------------
--- The following functions implement certain 64-bit MachOps inline for 32-bit
--- architectures. On 64-bit architectures, those MachOps aren't supported and
--- calling these functions for a 64-bit target platform is considered an error
--- (hence the use of `expect32BitPlatform`).
---
--- On 64-bit platforms, generic MachOps should be used instead of these 64-bit
--- specific ones (e.g. use MO_Add instead of MO_x64_Add). This MachOp selection
--- is done by StgToCmm.
-
-genInt64ToInt :: LocalReg -> CmmExpr -> NatM InstrBlock
-genInt64ToInt dst src = do
-  expect32BitPlatform (text "genInt64ToInt")
-  RegCode64 code _src_hi src_lo <- iselExpr64 src
-  let dst_r = getLocalRegReg dst
-  pure $ code `snocOL` MOV II32 (OpReg src_lo) (OpReg dst_r)
-
-genWord64ToWord :: LocalReg -> CmmExpr -> NatM InstrBlock
-genWord64ToWord dst src = do
-  expect32BitPlatform (text "genWord64ToWord")
-  RegCode64 code _src_hi src_lo <- iselExpr64 src
-  let dst_r = getLocalRegReg dst
-  pure $ code `snocOL` MOV II32 (OpReg src_lo) (OpReg dst_r)
-
-genIntToInt64 :: LocalReg -> CmmExpr -> NatM InstrBlock
-genIntToInt64 dst src = do
-  expect32BitPlatform (text "genIntToInt64")
-  let Reg64 dst_hi dst_lo = localReg64 dst
-  src_code <- getAnyReg src
-  pure $ src_code rax `appOL` toOL
-          [ CLTD II32 -- sign extend EAX in EDX:EAX
-          , MOV II32 (OpReg rax) (OpReg dst_lo)
-          , MOV II32 (OpReg rdx) (OpReg dst_hi)
-          ]
-
-genWordToWord64 :: LocalReg -> CmmExpr -> NatM InstrBlock
-genWordToWord64 dst src = do
-  expect32BitPlatform (text "genWordToWord64")
-  let Reg64 dst_hi dst_lo = localReg64 dst
-  src_code <- getAnyReg src
-  pure $ src_code dst_lo
-          `snocOL` XOR II32 (OpReg dst_hi) (OpReg dst_hi)
-
-genNeg64 :: LocalReg -> CmmExpr -> NatM InstrBlock
-genNeg64 dst src = do
-  expect32BitPlatform (text "genNeg64")
-  let Reg64 dst_hi dst_lo = localReg64 dst
-  RegCode64 code src_hi src_lo <- iselExpr64 src
-  pure $ code `appOL` toOL
-          [ MOV  II32 (OpReg src_lo) (OpReg dst_lo)
-          , MOV  II32 (OpReg src_hi) (OpReg dst_hi)
-          , NEGI II32 (OpReg dst_lo)
-          , ADC  II32 (OpImm (ImmInt 0)) (OpReg dst_hi)
-          , NEGI II32 (OpReg dst_hi)
-          ]
-
-genAdd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genAdd64 dst x y = do
-  expect32BitPlatform (text "genAdd64")
-  let Reg64 dst_hi dst_lo = localReg64 dst
-  RegCode64 x_code x_hi x_lo <- iselExpr64 x
-  RegCode64 y_code y_hi y_lo <- iselExpr64 y
-  pure $ x_code `appOL` y_code `appOL` toOL
-          [ MOV  II32 (OpReg x_lo) (OpReg dst_lo)
-          , MOV  II32 (OpReg x_hi) (OpReg dst_hi)
-          , ADD  II32 (OpReg y_lo) (OpReg dst_lo)
-          , ADC  II32 (OpReg y_hi) (OpReg dst_hi)
-          ]
-
-genSub64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genSub64 dst x y = do
-  expect32BitPlatform (text "genSub64")
-  let Reg64 dst_hi dst_lo = localReg64 dst
-  RegCode64 x_code x_hi x_lo <- iselExpr64 x
-  RegCode64 y_code y_hi y_lo <- iselExpr64 y
-  pure $ x_code `appOL` y_code `appOL` toOL
-          [ MOV  II32 (OpReg x_lo) (OpReg dst_lo)
-          , MOV  II32 (OpReg x_hi) (OpReg dst_hi)
-          , SUB  II32 (OpReg y_lo) (OpReg dst_lo)
-          , SBB  II32 (OpReg y_hi) (OpReg dst_hi)
-          ]
-
-genAnd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genAnd64 dst x y = do
-  expect32BitPlatform (text "genAnd64")
-  let Reg64 dst_hi dst_lo = localReg64 dst
-  RegCode64 x_code x_hi x_lo <- iselExpr64 x
-  RegCode64 y_code y_hi y_lo <- iselExpr64 y
-  pure $ x_code `appOL` y_code `appOL` toOL
-          [ MOV II32 (OpReg x_lo) (OpReg dst_lo)
-          , MOV II32 (OpReg x_hi) (OpReg dst_hi)
-          , AND II32 (OpReg y_lo) (OpReg dst_lo)
-          , AND II32 (OpReg y_hi) (OpReg dst_hi)
-          ]
-
-genOr64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genOr64 dst x y = do
-  expect32BitPlatform (text "genOr64")
-  let Reg64 dst_hi dst_lo = localReg64 dst
-  RegCode64 x_code x_hi x_lo <- iselExpr64 x
-  RegCode64 y_code y_hi y_lo <- iselExpr64 y
-  pure $ x_code `appOL` y_code `appOL` toOL
-          [ MOV II32 (OpReg x_lo) (OpReg dst_lo)
-          , MOV II32 (OpReg x_hi) (OpReg dst_hi)
-          , OR  II32 (OpReg y_lo) (OpReg dst_lo)
-          , OR  II32 (OpReg y_hi) (OpReg dst_hi)
-          ]
-
-genXor64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genXor64 dst x y = do
-  expect32BitPlatform (text "genXor64")
-  let Reg64 dst_hi dst_lo = localReg64 dst
-  RegCode64 x_code x_hi x_lo <- iselExpr64 x
-  RegCode64 y_code y_hi y_lo <- iselExpr64 y
-  pure $ x_code `appOL` y_code `appOL` toOL
-          [ MOV II32 (OpReg x_lo) (OpReg dst_lo)
-          , MOV II32 (OpReg x_hi) (OpReg dst_hi)
-          , XOR II32 (OpReg y_lo) (OpReg dst_lo)
-          , XOR II32 (OpReg y_hi) (OpReg dst_hi)
-          ]
-
-genNot64 :: LocalReg -> CmmExpr -> NatM InstrBlock
-genNot64 dst src = do
-  expect32BitPlatform (text "genNot64")
-  let Reg64 dst_hi dst_lo = localReg64 dst
-  RegCode64 src_code src_hi src_lo <- iselExpr64 src
-  pure $ src_code `appOL` toOL
-          [ MOV II32 (OpReg src_lo) (OpReg dst_lo)
-          , MOV II32 (OpReg src_hi) (OpReg dst_hi)
-          , NOT II32 (OpReg dst_lo)
-          , NOT II32 (OpReg dst_hi)
-          ]
-
-genEq64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genEq64 dst x y = do
-  expect32BitPlatform (text "genEq64")
-  let dst_r = getLocalRegReg dst
-  RegCode64 x_code x_hi x_lo <- iselExpr64 x
-  RegCode64 y_code y_hi y_lo <- iselExpr64 y
-  Reg64 tmp_hi tmp_lo <- getNewReg64
-  pure $ x_code `appOL` y_code `appOL` toOL
-          [ MOV II32 (OpReg x_lo)   (OpReg tmp_lo)
-          , MOV II32 (OpReg x_hi)   (OpReg tmp_hi)
-          , XOR II32 (OpReg y_lo)   (OpReg tmp_lo)
-          , XOR II32 (OpReg y_hi)   (OpReg tmp_hi)
-          , OR  II32 (OpReg tmp_lo) (OpReg tmp_hi)
-          , SETCC EQQ (OpReg dst_r)
-          , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)
-          ]
-
-genNe64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genNe64 dst x y = do
-  expect32BitPlatform (text "genNe64")
-  let dst_r = getLocalRegReg dst
-  RegCode64 x_code x_hi x_lo <- iselExpr64 x
-  RegCode64 y_code y_hi y_lo <- iselExpr64 y
-  Reg64 tmp_hi tmp_lo <- getNewReg64
-  pure $ x_code `appOL` y_code `appOL` toOL
-          [ MOV II32 (OpReg x_lo)   (OpReg tmp_lo)
-          , MOV II32 (OpReg x_hi)   (OpReg tmp_hi)
-          , XOR II32 (OpReg y_lo)   (OpReg tmp_lo)
-          , XOR II32 (OpReg y_hi)   (OpReg tmp_hi)
-          , OR  II32 (OpReg tmp_lo) (OpReg tmp_hi)
-          , SETCC NE (OpReg dst_r)
-          , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)
-          ]
-
-genGtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genGtWord64 dst x y = do
-  expect32BitPlatform (text "genGtWord64")
-  genPred64 LU dst y x
-
-genLtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genLtWord64 dst x y = do
-  expect32BitPlatform (text "genLtWord64")
-  genPred64 LU dst x y
-
-genGeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genGeWord64 dst x y = do
-  expect32BitPlatform (text "genGeWord64")
-  genPred64 GEU dst x y
-
-genLeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genLeWord64 dst x y = do
-  expect32BitPlatform (text "genLeWord64")
-  genPred64 GEU dst y x
-
-genGtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genGtInt64 dst x y = do
-  expect32BitPlatform (text "genGtInt64")
-  genPred64 LTT dst y x
-
-genLtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genLtInt64 dst x y = do
-  expect32BitPlatform (text "genLtInt64")
-  genPred64 LTT dst x y
-
-genGeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genGeInt64 dst x y = do
-  expect32BitPlatform (text "genGeInt64")
-  genPred64 GE dst x y
-
-genLeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genLeInt64 dst x y = do
-  expect32BitPlatform (text "genLeInt64")
-  genPred64 GE dst y x
-
-genPred64 :: Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock
-genPred64 cond dst x y = do
-  -- we can only rely on CF/SF/OF flags!
-  -- Not on ZF, which doesn't take into account the lower parts.
-  massert (cond `elem` [LU,GEU,LTT,GE])
-
-  let dst_r = getLocalRegReg dst
-  RegCode64 x_code x_hi x_lo <- iselExpr64 x
-  RegCode64 y_code y_hi y_lo <- iselExpr64 y
-  -- Basically we perform a subtraction with borrow.
-  -- As we don't need to result, we can use CMP instead of SUB for the low part
-  -- (it sets the borrow flag just like SUB does)
-  pure $ x_code `appOL` y_code `appOL` toOL
-          [ MOV II32 (OpReg x_hi) (OpReg dst_r)
-          , CMP II32 (OpReg y_lo) (OpReg x_lo)
-          , SBB II32 (OpReg y_hi) (OpReg dst_r)
-          , SETCC cond (OpReg dst_r)
-          , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)
-          ]
-
diff --git a/compiler/GHC/CmmToAsm/X86/Cond.hs b/compiler/GHC/CmmToAsm/X86/Cond.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/X86/Cond.hs
+++ /dev/null
@@ -1,91 +0,0 @@
-module GHC.CmmToAsm.X86.Cond (
-        Cond(..),
-        condToUnsigned,
-        maybeFlipCond,
-        maybeInvertCond
-)
-
-where
-
-import GHC.Prelude
-
-data Cond
-        = ALWAYS        -- What's really used? ToDo
-        | EQQ           -- je/jz -> zf=1
-        | GE            -- jge   -> sf=of
-        | GEU           -- ae    -> cf=0
-        | GTT           -- jg    -> zf=0 && sf=of
-        | GU            -- ja    -> cf=0 && zf=0
-        | LE            -- jle   -> zf=1 || sf/=of
-        | LEU           -- jbe   -> cf=1 || zf=1
-        | LTT           -- jl    -> sf/=of
-        | LU            -- jb    -> cf=1
-        | NE            -- jne   -> zf=0
-        | NEG           -- js    -> sf=1
-        | POS           -- jns   -> sf=0
-        | CARRY         -- jc    -> cf=1
-        | OFLO          -- jo    -> of=1
-        | PARITY        -- jp    -> pf=1
-        | NOTPARITY     -- jnp   -> pf=0
-        deriving Eq
-
-condToUnsigned :: Cond -> Cond
-condToUnsigned GTT = GU
-condToUnsigned LTT = LU
-condToUnsigned GE  = GEU
-condToUnsigned LE  = LEU
-condToUnsigned x   = x
-
--- | @maybeFlipCond c@ returns @Just c'@ if it is possible to flip the
--- arguments to the conditional @c@, and the new condition should be @c'@.
-maybeFlipCond :: Cond -> Maybe Cond
-maybeFlipCond cond  = case cond of
-        EQQ   -> Just EQQ
-        NE    -> Just NE
-        LU    -> Just GU
-        GU    -> Just LU
-        LEU   -> Just GEU
-        GEU   -> Just LEU
-        LTT   -> Just GTT
-        GTT   -> Just LTT
-        LE    -> Just GE
-        GE    -> Just LE
-        _other -> Nothing
-
--- | If we apply @maybeInvertCond@ to the condition of a jump we turn
--- jumps taken into jumps not taken and vice versa.
---
--- Careful! If the used comparison and the conditional jump
--- don't match the above behaviour will NOT hold.
--- When used for FP comparisons this does not consider unordered
--- numbers.
--- Also inverting twice might return a synonym for the original condition.
-maybeInvertCond :: Cond -> Maybe Cond
-maybeInvertCond cond  = case cond of
-        ALWAYS  -> Nothing
-        EQQ     -> Just NE
-        NE      -> Just EQQ
-
-        NEG     -> Just POS
-        POS     -> Just NEG
-
-        GEU     -> Just LU
-        LU      -> Just GEU
-
-        GE      -> Just LTT
-        LTT     -> Just GE
-
-        GTT     -> Just LE
-        LE      -> Just GTT
-
-        GU      -> Just LEU
-        LEU     -> Just GU
-
-        --GEU "==" NOTCARRY, they are synonyms
-        --at the assembly level
-        CARRY   -> Just GEU
-
-        OFLO    -> Nothing
-
-        PARITY  -> Just NOTPARITY
-        NOTPARITY -> Just PARITY
diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/X86/Instr.hs
+++ /dev/null
@@ -1,1066 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-
------------------------------------------------------------------------------
---
--- Machine-dependent assembly language
---
--- (c) The University of Glasgow 1993-2004
---
------------------------------------------------------------------------------
-
-module GHC.CmmToAsm.X86.Instr
-   ( Instr(..)
-   , Operand(..)
-   , PrefetchVariant(..)
-   , JumpDest(..)
-   , getJumpDestBlockId
-   , canShortcut
-   , shortcutStatics
-   , shortcutJump
-   , allocMoreStack
-   , maxSpillSlots
-   , archWordFormat
-   , takeRegRegMoveInstr
-   , regUsageOfInstr
-   , takeDeltaInstr
-   , mkLoadInstr
-   , mkJumpInstr
-   , mkStackAllocInstr
-   , mkStackDeallocInstr
-   , mkSpillInstr
-   , mkRegRegMoveInstr
-   , jumpDestsOfInstr
-   , patchRegsOfInstr
-   , patchJumpInstr
-   , isMetaInstr
-   , isJumpishInstr
-   )
-where
-
-import GHC.Prelude
-import GHC.Data.FastString
-
-import GHC.CmmToAsm.X86.Cond
-import GHC.CmmToAsm.X86.Regs
-import GHC.CmmToAsm.Format
-import GHC.CmmToAsm.Types
-import GHC.CmmToAsm.Utils
-import GHC.CmmToAsm.Instr (RegUsage(..), noUsage)
-import GHC.Platform.Reg.Class
-import GHC.Platform.Reg
-import GHC.CmmToAsm.Reg.Target
-import GHC.CmmToAsm.Config
-
-import GHC.Cmm.BlockId
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Label
-import GHC.Platform.Regs
-import GHC.Cmm
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Platform
-
-import GHC.Cmm.CLabel
-import GHC.Types.Unique.Set
-import GHC.Types.Unique
-import GHC.Types.Unique.Supply
-import GHC.Types.Basic (Alignment)
-import GHC.Cmm.DebugBlock (UnwindTable)
-
-import Data.Maybe       (fromMaybe)
-
--- Format of an x86/x86_64 memory address, in bytes.
---
-archWordFormat :: Bool -> Format
-archWordFormat is32Bit
- | is32Bit   = II32
- | otherwise = II64
-
--- -----------------------------------------------------------------------------
--- Intel x86 instructions
-
-{-
-Intel, in their infinite wisdom, selected a stack model for floating
-point registers on x86.  That might have made sense back in 1979 --
-nowadays we can see it for the nonsense it really is.  A stack model
-fits poorly with the existing nativeGen infrastructure, which assumes
-flat integer and FP register sets.  Prior to this commit, nativeGen
-could not generate correct x86 FP code -- to do so would have meant
-somehow working the register-stack paradigm into the register
-allocator and spiller, which sounds very difficult.
-
-We have decided to cheat, and go for a simple fix which requires no
-infrastructure modifications, at the expense of generating ropey but
-correct FP code.  All notions of the x86 FP stack and its insns have
-been removed.  Instead, we pretend (to the instruction selector and
-register allocator) that x86 has six floating point registers, %fake0
-.. %fake5, which can be used in the usual flat manner.  We further
-claim that x86 has floating point instructions very similar to SPARC
-and Alpha, that is, a simple 3-operand register-register arrangement.
-Code generation and register allocation proceed on this basis.
-
-When we come to print out the final assembly, our convenient fiction
-is converted to dismal reality.  Each fake instruction is
-independently converted to a series of real x86 instructions.
-%fake0 .. %fake5 are mapped to %st(0) .. %st(5).  To do reg-reg
-arithmetic operations, the two operands are pushed onto the top of the
-FP stack, the operation done, and the result copied back into the
-relevant register.  There are only six %fake registers because 2 are
-needed for the translation, and x86 has 8 in total.
-
-The translation is inefficient but is simple and it works.  A cleverer
-translation would handle a sequence of insns, simulating the FP stack
-contents, would not impose a fixed mapping from %fake to %st regs, and
-hopefully could avoid most of the redundant reg-reg moves of the
-current translation.
-
-We might as well make use of whatever unique FP facilities Intel have
-chosen to bless us with (let's not be churlish, after all).
-Hence GLDZ and GLD1.  Bwahahahahahahaha!
--}
-
-{-
-Note [x86 Floating point precision]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Intel's internal floating point registers are by default 80 bit
-extended precision.  This means that all operations done on values in
-registers are done at 80 bits, and unless the intermediate values are
-truncated to the appropriate size (32 or 64 bits) by storing in
-memory, calculations in registers will give different results from
-calculations which pass intermediate values in memory (eg. via
-function calls).
-
-One solution is to set the FPU into 64 bit precision mode.  Some OSs
-do this (eg. FreeBSD) and some don't (eg. Linux).  The problem here is
-that this will only affect 64-bit precision arithmetic; 32-bit
-calculations will still be done at 64-bit precision in registers.  So
-it doesn't solve the whole problem.
-
-There's also the issue of what the C library is expecting in terms of
-precision.  It seems to be the case that glibc on Linux expects the
-FPU to be set to 80 bit precision, so setting it to 64 bit could have
-unexpected effects.  Changing the default could have undesirable
-effects on other 3rd-party library code too, so the right thing would
-be to save/restore the FPU control word across Haskell code if we were
-to do this.
-
-gcc's -ffloat-store gives consistent results by always storing the
-results of floating-point calculations in memory, which works for both
-32 and 64-bit precision.  However, it only affects the values of
-user-declared floating point variables in C, not intermediate results.
-GHC in -fvia-C mode uses -ffloat-store (see the -fexcess-precision
-flag).
-
-Another problem is how to spill floating point registers in the
-register allocator.  Should we spill the whole 80 bits, or just 64?
-On an OS which is set to 64 bit precision, spilling 64 is fine.  On
-Linux, spilling 64 bits will round the results of some operations.
-This is what gcc does.  Spilling at 80 bits requires taking up a full
-128 bit slot (so we get alignment).  We spill at 80-bits and ignore
-the alignment problems.
-
-In the future [edit: now available in GHC 7.0.1, with the -msse2
-flag], we'll use the SSE registers for floating point.  This requires
-a CPU that supports SSE2 (ordinary SSE only supports 32 bit precision
-float ops), which means P4 or Xeon and above.  Using SSE will solve
-all these problems, because the SSE registers use fixed 32 bit or 64
-bit precision.
-
---SDM 1/2003
--}
-
-data Instr
-        -- comment pseudo-op
-        = COMMENT FastString
-
-        -- location pseudo-op (file, line, col, name)
-        | LOCATION Int Int Int String
-
-        -- some static data spat out during code
-        -- generation.  Will be extracted before
-        -- pretty-printing.
-        | LDATA   Section (Alignment, RawCmmStatics)
-
-        -- start a new basic block.  Useful during
-        -- codegen, removed later.  Preceding
-        -- instruction should be a jump, as per the
-        -- invariants for a BasicBlock (see Cmm).
-        | NEWBLOCK BlockId
-
-        -- unwinding information
-        -- See Note [Unwinding information in the NCG].
-        | UNWIND CLabel UnwindTable
-
-        -- specify current stack offset for benefit of subsequent passes.
-        -- This carries a BlockId so it can be used in unwinding information.
-        | DELTA  Int
-
-        -- Moves.
-        | MOV         Format Operand Operand
-             -- ^ N.B. when used with the 'II64' 'Format', the source
-             -- operand is interpreted to be a 32-bit sign-extended value.
-             -- True 64-bit operands need to be moved with @MOVABS@, which we
-             -- currently don't use.
-        | CMOV   Cond Format Operand Reg
-        | MOVZxL      Format Operand Operand
-              -- ^ The format argument is the size of operand 1 (the number of bits we keep)
-              -- We always zero *all* high bits, even though this isn't how the actual instruction
-              -- works. The code generator also seems to rely on this behaviour and it's faster
-              -- to execute on many cpus as well so for now I'm just documenting the fact.
-        | MOVSxL      Format Operand Operand -- format is the size of operand 1
-        -- x86_64 note: plain mov into a 32-bit register always zero-extends
-        -- into the 64-bit reg, in contrast to the 8 and 16-bit movs which
-        -- don't affect the high bits of the register.
-
-        -- Load effective address (also a very useful three-operand add instruction :-)
-        | LEA         Format Operand Operand
-
-        -- Int Arithmetic.
-        | ADD         Format Operand Operand
-        | ADC         Format Operand Operand
-        | SUB         Format Operand Operand
-        | SBB         Format Operand Operand
-
-        | MUL         Format Operand Operand
-        | MUL2        Format Operand         -- %edx:%eax = operand * %rax
-        | IMUL        Format Operand Operand -- signed int mul
-        | IMUL2       Format Operand         -- %edx:%eax = operand * %eax
-
-        | DIV         Format Operand         -- eax := eax:edx/op, edx := eax:edx%op
-        | IDIV        Format Operand         -- ditto, but signed
-
-        -- Int Arithmetic, where the effects on the condition register
-        -- are important. Used in specialized sequences such as MO_Add2.
-        -- Do not rewrite these instructions to "equivalent" ones that
-        -- have different effect on the condition register! (See #9013.)
-        | ADD_CC      Format Operand Operand
-        | SUB_CC      Format Operand Operand
-
-        -- Simple bit-twiddling.
-        | AND         Format Operand Operand
-        | OR          Format Operand Operand
-        | XOR         Format Operand Operand
-        | NOT         Format Operand
-        | NEGI        Format Operand         -- NEG instruction (name clash with Cond)
-        | BSWAP       Format Reg
-
-        -- Shifts (amount may be immediate or %cl only)
-        | SHL         Format Operand{-amount-} Operand
-        | SAR         Format Operand{-amount-} Operand
-        | SHR         Format Operand{-amount-} Operand
-
-        | BT          Format Imm Operand
-        | NOP
-
-
-        -- We need to support the FSTP (x87 store and pop) instruction
-        -- so that we can correctly read off the return value of an
-        -- x86 CDECL C function call when its floating point.
-        -- so we dont include a register argument, and just use st(0)
-        -- this instruction is used ONLY for return values of C ffi calls
-        -- in x86_32 abi
-        | X87Store         Format  AddrMode -- st(0), dst
-
-
-        -- SSE2 floating point: we use a restricted set of the available SSE2
-        -- instructions for floating-point.
-        -- use MOV for moving (either movss or movsd (movlpd better?))
-        | CVTSS2SD      Reg Reg            -- F32 to F64
-        | CVTSD2SS      Reg Reg            -- F64 to F32
-        | CVTTSS2SIQ    Format Operand Reg -- F32 to I32/I64 (with truncation)
-        | CVTTSD2SIQ    Format Operand Reg -- F64 to I32/I64 (with truncation)
-        | CVTSI2SS      Format Operand Reg -- I32/I64 to F32
-        | CVTSI2SD      Format Operand Reg -- I32/I64 to F64
-
-        -- use ADD, SUB, and SQRT for arithmetic.  In both cases, operands
-        -- are  Operand Reg.
-
-        -- SSE2 floating-point division:
-        | FDIV          Format Operand Operand   -- divisor, dividend(dst)
-
-        -- use CMP for comparisons.  ucomiss and ucomisd instructions
-        -- compare single/double prec floating point respectively.
-
-        | SQRT          Format Operand Reg      -- src, dst
-
-
-        -- Comparison
-        | TEST          Format Operand Operand
-        | CMP           Format Operand Operand
-        | SETCC         Cond Operand
-
-        -- Stack Operations.
-        | PUSH          Format Operand
-        | POP           Format Operand
-        -- both unused (SDM):
-        --  | PUSHA
-        --  | POPA
-
-        -- Jumping around.
-        | JMP         Operand [Reg] -- including live Regs at the call
-        | JXX         Cond BlockId  -- includes unconditional branches
-        | JXX_GBL     Cond Imm      -- non-local version of JXX
-        -- Table jump
-        | JMP_TBL     Operand   -- Address to jump to
-                      [Maybe JumpDest] -- Targets of the jump table
-                      Section   -- Data section jump table should be put in
-                      CLabel    -- Label of jump table
-        -- | X86 call instruction
-        | CALL        (Either Imm Reg) -- ^ Jump target
-                      [Reg]            -- ^ Arguments (required for register allocation)
-
-        -- Other things.
-        | CLTD Format            -- sign extend %eax into %edx:%eax
-
-        | FETCHGOT    Reg        -- pseudo-insn for ELF position-independent code
-                                 -- pretty-prints as
-                                 --       call 1f
-                                 -- 1:    popl %reg
-                                 --       addl __GLOBAL_OFFSET_TABLE__+.-1b, %reg
-        | FETCHPC     Reg        -- pseudo-insn for Darwin position-independent code
-                                 -- pretty-prints as
-                                 --       call 1f
-                                 -- 1:    popl %reg
-
-    -- bit counting instructions
-        | POPCNT      Format Operand Reg -- [SSE4.2] count number of bits set to 1
-        | LZCNT       Format Operand Reg -- [BMI2] count number of leading zeros
-        | TZCNT       Format Operand Reg -- [BMI2] count number of trailing zeros
-        | BSF         Format Operand Reg -- bit scan forward
-        | BSR         Format Operand Reg -- bit scan reverse
-
-    -- bit manipulation instructions
-        | PDEP        Format Operand Operand Reg -- [BMI2] deposit bits to   the specified mask
-        | PEXT        Format Operand Operand Reg -- [BMI2] extract bits from the specified mask
-
-    -- prefetch
-        | PREFETCH  PrefetchVariant Format Operand -- prefetch Variant, addr size, address to prefetch
-                                        -- variant can be NTA, Lvl0, Lvl1, or Lvl2
-
-        | LOCK        Instr -- lock prefix
-        | XADD        Format Operand Operand -- src (r), dst (r/m)
-        | CMPXCHG     Format Operand Operand -- src (r), dst (r/m), eax implicit
-        | XCHG        Format Operand Reg     -- src (r/m), dst (r/m)
-        | MFENCE
-
-data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2
-
-
-data Operand
-        = OpReg  Reg            -- register
-        | OpImm  Imm            -- immediate value
-        | OpAddr AddrMode       -- memory reference
-
-
-
--- | Returns which registers are read and written as a (read, written)
--- pair.
-regUsageOfInstr :: Platform -> Instr -> RegUsage
-regUsageOfInstr platform instr
- = case instr of
-    MOV    _ src dst    -> usageRW src dst
-    CMOV _ _ src dst    -> mkRU (use_R src [dst]) [dst]
-    MOVZxL _ src dst    -> usageRW src dst
-    MOVSxL _ src dst    -> usageRW src dst
-    LEA    _ src dst    -> usageRW src dst
-    ADD    _ src dst    -> usageRM src dst
-    ADC    _ src dst    -> usageRM src dst
-    SUB    _ src dst    -> usageRM src dst
-    SBB    _ src dst    -> usageRM src dst
-    IMUL   _ src dst    -> usageRM src dst
-
-    -- Result of IMULB will be in just in %ax
-    IMUL2  II8 src       -> mkRU (eax:use_R src []) [eax]
-    -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and
-    -- %ax/%eax/%rax.
-    IMUL2  _ src        -> mkRU (eax:use_R src []) [eax,edx]
-
-    MUL    _ src dst    -> usageRM src dst
-    MUL2   _ src        -> mkRU (eax:use_R src []) [eax,edx]
-    DIV    _ op -> mkRU (eax:edx:use_R op []) [eax,edx]
-    IDIV   _ op -> mkRU (eax:edx:use_R op []) [eax,edx]
-    ADD_CC _ src dst    -> usageRM src dst
-    SUB_CC _ src dst    -> usageRM src dst
-    AND    _ src dst    -> usageRM src dst
-    OR     _ src dst    -> usageRM src dst
-
-    XOR    _ (OpReg src) (OpReg dst)
-        | src == dst    -> mkRU [] [dst]
-
-    XOR    _ src dst    -> usageRM src dst
-    NOT    _ op         -> usageM op
-    BSWAP  _ reg        -> mkRU [reg] [reg]
-    NEGI   _ op         -> usageM op
-    SHL    _ imm dst    -> usageRM imm dst
-    SAR    _ imm dst    -> usageRM imm dst
-    SHR    _ imm dst    -> usageRM imm dst
-    BT     _ _   src    -> mkRUR (use_R src [])
-
-    PUSH   _ op         -> mkRUR (use_R op [])
-    POP    _ op         -> mkRU [] (def_W op)
-    TEST   _ src dst    -> mkRUR (use_R src $! use_R dst [])
-    CMP    _ src dst    -> mkRUR (use_R src $! use_R dst [])
-    SETCC  _ op         -> mkRU [] (def_W op)
-    JXX    _ _          -> mkRU [] []
-    JXX_GBL _ _         -> mkRU [] []
-    JMP     op regs     -> mkRUR (use_R op regs)
-    JMP_TBL op _ _ _    -> mkRUR (use_R op [])
-    CALL (Left _)  params   -> mkRU params (callClobberedRegs platform)
-    CALL (Right reg) params -> mkRU (reg:params) (callClobberedRegs platform)
-    CLTD   _            -> mkRU [eax] [edx]
-    NOP                 -> mkRU [] []
-
-    X87Store    _  dst    -> mkRUR ( use_EA dst [])
-
-    CVTSS2SD   src dst  -> mkRU [src] [dst]
-    CVTSD2SS   src dst  -> mkRU [src] [dst]
-    CVTTSS2SIQ _ src dst -> mkRU (use_R src []) [dst]
-    CVTTSD2SIQ _ src dst -> mkRU (use_R src []) [dst]
-    CVTSI2SS   _ src dst -> mkRU (use_R src []) [dst]
-    CVTSI2SD   _ src dst -> mkRU (use_R src []) [dst]
-    FDIV _     src dst  -> usageRM src dst
-    SQRT _ src dst      -> mkRU (use_R src []) [dst]
-
-    FETCHGOT reg        -> mkRU [] [reg]
-    FETCHPC  reg        -> mkRU [] [reg]
-
-    COMMENT _           -> noUsage
-    LOCATION{}          -> noUsage
-    UNWIND{}            -> noUsage
-    DELTA   _           -> noUsage
-
-    POPCNT _ src dst -> mkRU (use_R src []) [dst]
-    LZCNT  _ src dst -> mkRU (use_R src []) [dst]
-    TZCNT  _ src dst -> mkRU (use_R src []) [dst]
-    BSF    _ src dst -> mkRU (use_R src []) [dst]
-    BSR    _ src dst -> mkRU (use_R src []) [dst]
-
-    PDEP   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]
-    PEXT   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]
-
-    -- note: might be a better way to do this
-    PREFETCH _  _ src -> mkRU (use_R src []) []
-    LOCK i              -> regUsageOfInstr platform i
-    XADD _ src dst      -> usageMM src dst
-    CMPXCHG _ src dst   -> usageRMM src dst (OpReg eax)
-    XCHG _ src dst      -> usageMM src (OpReg dst)
-    MFENCE -> noUsage
-
-    _other              -> panic "regUsage: unrecognised instr"
- where
-    -- # Definitions
-    --
-    -- Written: If the operand is a register, it's written. If it's an
-    -- address, registers mentioned in the address are read.
-    --
-    -- Modified: If the operand is a register, it's both read and
-    -- written. If it's an address, registers mentioned in the address
-    -- are read.
-
-    -- 2 operand form; first operand Read; second Written
-    usageRW :: Operand -> Operand -> RegUsage
-    usageRW op (OpReg reg)      = mkRU (use_R op []) [reg]
-    usageRW op (OpAddr ea)      = mkRUR (use_R op $! use_EA ea [])
-    usageRW _ _                 = panic "X86.RegInfo.usageRW: no match"
-
-    -- 2 operand form; first operand Read; second Modified
-    usageRM :: Operand -> Operand -> RegUsage
-    usageRM op (OpReg reg)      = mkRU (use_R op [reg]) [reg]
-    usageRM op (OpAddr ea)      = mkRUR (use_R op $! use_EA ea [])
-    usageRM _ _                 = panic "X86.RegInfo.usageRM: no match"
-
-    -- 2 operand form; first operand Modified; second Modified
-    usageMM :: Operand -> Operand -> RegUsage
-    usageMM (OpReg src) (OpReg dst) = mkRU [src, dst] [src, dst]
-    usageMM (OpReg src) (OpAddr ea) = mkRU (use_EA ea [src]) [src]
-    usageMM (OpAddr ea) (OpReg dst) = mkRU (use_EA ea [dst]) [dst]
-    usageMM _ _                     = panic "X86.RegInfo.usageMM: no match"
-
-    -- 3 operand form; first operand Read; second Modified; third Modified
-    usageRMM :: Operand -> Operand -> Operand -> RegUsage
-    usageRMM (OpReg src) (OpReg dst) (OpReg reg) = mkRU [src, dst, reg] [dst, reg]
-    usageRMM (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [src, reg]) [reg]
-    usageRMM _ _ _                               = panic "X86.RegInfo.usageRMM: no match"
-
-    -- 1 operand form; operand Modified
-    usageM :: Operand -> RegUsage
-    usageM (OpReg reg)          = mkRU [reg] [reg]
-    usageM (OpAddr ea)          = mkRUR (use_EA ea [])
-    usageM _                    = panic "X86.RegInfo.usageM: no match"
-
-    -- Registers defd when an operand is written.
-    def_W (OpReg reg)           = [reg]
-    def_W (OpAddr _ )           = []
-    def_W _                     = panic "X86.RegInfo.def_W: no match"
-
-    -- Registers used when an operand is read.
-    use_R (OpReg reg)  tl = reg : tl
-    use_R (OpImm _)    tl = tl
-    use_R (OpAddr ea)  tl = use_EA ea tl
-
-    -- Registers used to compute an effective address.
-    use_EA (ImmAddr _ _) tl = tl
-    use_EA (AddrBaseIndex base index _) tl =
-        use_base base $! use_index index tl
-        where use_base (EABaseReg r)  tl = r : tl
-              use_base _              tl = tl
-              use_index EAIndexNone   tl = tl
-              use_index (EAIndex i _) tl = i : tl
-
-    mkRUR src = src' `seq` RU src' []
-        where src' = filter (interesting platform) src
-
-    mkRU src dst = src' `seq` dst' `seq` RU src' dst'
-        where src' = filter (interesting platform) src
-              dst' = filter (interesting platform) dst
-
--- | Is this register interesting for the register allocator?
-interesting :: Platform -> Reg -> Bool
-interesting _        (RegVirtual _)              = True
-interesting platform (RegReal (RealRegSingle i)) = freeReg platform i
-
-
-
--- | Applies the supplied function to all registers in instructions.
--- Typically used to change virtual registers to real registers.
-patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
-patchRegsOfInstr instr env
- = case instr of
-    MOV  fmt src dst     -> patch2 (MOV  fmt) src dst
-    CMOV cc fmt src dst  -> CMOV cc fmt (patchOp src) (env dst)
-    MOVZxL fmt src dst   -> patch2 (MOVZxL fmt) src dst
-    MOVSxL fmt src dst   -> patch2 (MOVSxL fmt) src dst
-    LEA  fmt src dst     -> patch2 (LEA  fmt) src dst
-    ADD  fmt src dst     -> patch2 (ADD  fmt) src dst
-    ADC  fmt src dst     -> patch2 (ADC  fmt) src dst
-    SUB  fmt src dst     -> patch2 (SUB  fmt) src dst
-    SBB  fmt src dst     -> patch2 (SBB  fmt) src dst
-    IMUL fmt src dst     -> patch2 (IMUL fmt) src dst
-    IMUL2 fmt src        -> patch1 (IMUL2 fmt) src
-    MUL fmt src dst      -> patch2 (MUL fmt) src dst
-    MUL2 fmt src         -> patch1 (MUL2 fmt) src
-    IDIV fmt op          -> patch1 (IDIV fmt) op
-    DIV fmt op           -> patch1 (DIV fmt) op
-    ADD_CC fmt src dst   -> patch2 (ADD_CC fmt) src dst
-    SUB_CC fmt src dst   -> patch2 (SUB_CC fmt) src dst
-    AND  fmt src dst     -> patch2 (AND  fmt) src dst
-    OR   fmt src dst     -> patch2 (OR   fmt) src dst
-    XOR  fmt src dst     -> patch2 (XOR  fmt) src dst
-    NOT  fmt op          -> patch1 (NOT  fmt) op
-    BSWAP fmt reg        -> BSWAP fmt (env reg)
-    NEGI fmt op          -> patch1 (NEGI fmt) op
-    SHL  fmt imm dst     -> patch1 (SHL fmt imm) dst
-    SAR  fmt imm dst     -> patch1 (SAR fmt imm) dst
-    SHR  fmt imm dst     -> patch1 (SHR fmt imm) dst
-    BT   fmt imm src     -> patch1 (BT  fmt imm) src
-    TEST fmt src dst     -> patch2 (TEST fmt) src dst
-    CMP  fmt src dst     -> patch2 (CMP  fmt) src dst
-    PUSH fmt op          -> patch1 (PUSH fmt) op
-    POP  fmt op          -> patch1 (POP  fmt) op
-    SETCC cond op        -> patch1 (SETCC cond) op
-    JMP op regs          -> JMP (patchOp op) regs
-    JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl
-
-    -- literally only support storing the top x87 stack value st(0)
-    X87Store  fmt  dst     -> X87Store fmt  (lookupAddr dst)
-
-    CVTSS2SD src dst    -> CVTSS2SD (env src) (env dst)
-    CVTSD2SS src dst    -> CVTSD2SS (env src) (env dst)
-    CVTTSS2SIQ fmt src dst -> CVTTSS2SIQ fmt (patchOp src) (env dst)
-    CVTTSD2SIQ fmt src dst -> CVTTSD2SIQ fmt (patchOp src) (env dst)
-    CVTSI2SS fmt src dst -> CVTSI2SS fmt (patchOp src) (env dst)
-    CVTSI2SD fmt src dst -> CVTSI2SD fmt (patchOp src) (env dst)
-    FDIV fmt src dst     -> FDIV fmt (patchOp src) (patchOp dst)
-    SQRT fmt src dst    -> SQRT fmt (patchOp src) (env dst)
-
-    CALL (Left _)  _    -> instr
-    CALL (Right reg) p  -> CALL (Right (env reg)) p
-
-    FETCHGOT reg        -> FETCHGOT (env reg)
-    FETCHPC  reg        -> FETCHPC  (env reg)
-
-    NOP                 -> instr
-    COMMENT _           -> instr
-    LOCATION {}         -> instr
-    UNWIND {}           -> instr
-    DELTA _             -> instr
-
-    JXX _ _             -> instr
-    JXX_GBL _ _         -> instr
-    CLTD _              -> instr
-
-    POPCNT fmt src dst -> POPCNT fmt (patchOp src) (env dst)
-    LZCNT  fmt src dst -> LZCNT  fmt (patchOp src) (env dst)
-    TZCNT  fmt src dst -> TZCNT  fmt (patchOp src) (env dst)
-    PDEP   fmt src mask dst -> PDEP   fmt (patchOp src) (patchOp mask) (env dst)
-    PEXT   fmt src mask dst -> PEXT   fmt (patchOp src) (patchOp mask) (env dst)
-    BSF    fmt src dst -> BSF    fmt (patchOp src) (env dst)
-    BSR    fmt src dst -> BSR    fmt (patchOp src) (env dst)
-
-    PREFETCH lvl format src -> PREFETCH lvl format (patchOp src)
-
-    LOCK i               -> LOCK (patchRegsOfInstr i env)
-    XADD fmt src dst     -> patch2 (XADD fmt) src dst
-    CMPXCHG fmt src dst  -> patch2 (CMPXCHG fmt) src dst
-    XCHG fmt src dst     -> XCHG fmt (patchOp src) (env dst)
-    MFENCE               -> instr
-
-    _other              -> panic "patchRegs: unrecognised instr"
-
-  where
-    patch1 :: (Operand -> a) -> Operand -> a
-    patch1 insn op      = insn $! patchOp op
-    patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a
-    patch2 insn src dst = (insn $! patchOp src) $! patchOp dst
-
-    patchOp (OpReg  reg) = OpReg $! env reg
-    patchOp (OpImm  imm) = OpImm imm
-    patchOp (OpAddr ea)  = OpAddr $! lookupAddr ea
-
-    lookupAddr (ImmAddr imm off) = ImmAddr imm off
-    lookupAddr (AddrBaseIndex base index disp)
-      = ((AddrBaseIndex $! lookupBase base) $! lookupIndex index) disp
-      where
-        lookupBase EABaseNone       = EABaseNone
-        lookupBase EABaseRip        = EABaseRip
-        lookupBase (EABaseReg r)    = EABaseReg $! env r
-
-        lookupIndex EAIndexNone     = EAIndexNone
-        lookupIndex (EAIndex r i)   = (EAIndex $! env r) i
-
-
---------------------------------------------------------------------------------
-isJumpishInstr
-        :: Instr -> Bool
-
-isJumpishInstr instr
- = case instr of
-        JMP{}           -> True
-        JXX{}           -> True
-        JXX_GBL{}       -> True
-        JMP_TBL{}       -> True
-        CALL{}          -> True
-        _               -> False
-
-
-jumpDestsOfInstr
-        :: Instr
-        -> [BlockId]
-
-jumpDestsOfInstr insn
-  = case insn of
-        JXX _ id        -> [id]
-        JMP_TBL _ ids _ _ -> [id | Just (DestBlockId id) <- ids]
-        _               -> []
-
-
-patchJumpInstr
-        :: Instr -> (BlockId -> BlockId) -> Instr
-
-patchJumpInstr insn patchF
-  = case insn of
-        JXX cc id       -> JXX cc (patchF id)
-        JMP_TBL op ids section lbl
-          -> JMP_TBL op (map (fmap (patchJumpDest patchF)) ids) section lbl
-        _               -> insn
-    where
-        patchJumpDest f (DestBlockId id) = DestBlockId (f id)
-        patchJumpDest _ dest             = dest
-
-
-
-
-
--- -----------------------------------------------------------------------------
--- | Make a spill instruction.
-mkSpillInstr
-    :: NCGConfig
-    -> Reg      -- register to spill
-    -> Int      -- current stack delta
-    -> Int      -- spill slot to use
-    -> [Instr]
-
-mkSpillInstr config reg delta slot
-  = let off     = spillSlotToOffset platform slot - delta
-    in
-    case targetClassOfReg platform reg of
-           RcInteger   -> [MOV (archWordFormat is32Bit)
-                                   (OpReg reg) (OpAddr (spRel platform off))]
-           RcDouble    -> [MOV FF64 (OpReg reg) (OpAddr (spRel platform off))]
-           _         -> panic "X86.mkSpillInstr: no match"
-    where platform = ncgPlatform config
-          is32Bit = target32Bit platform
-
--- | Make a spill reload instruction.
-mkLoadInstr
-    :: NCGConfig
-    -> Reg      -- register to load
-    -> Int      -- current stack delta
-    -> Int      -- spill slot to use
-    -> [Instr]
-
-mkLoadInstr config reg delta slot
-  = let off     = spillSlotToOffset platform slot - delta
-    in
-        case targetClassOfReg platform reg of
-              RcInteger -> ([MOV (archWordFormat is32Bit)
-                                 (OpAddr (spRel platform off)) (OpReg reg)])
-              RcDouble  -> ([MOV FF64 (OpAddr (spRel platform off)) (OpReg reg)])
-              _         -> panic "X86.mkLoadInstr"
-    where platform = ncgPlatform config
-          is32Bit = target32Bit platform
-
-spillSlotSize :: Platform -> Int
-spillSlotSize platform
-   | target32Bit platform = 12
-   | otherwise            = 8
-
-maxSpillSlots :: NCGConfig -> Int
-maxSpillSlots config
-    = ((ncgSpillPreallocSize config - 64) `div` spillSlotSize (ncgPlatform config)) - 1
---  = 0 -- useful for testing allocMoreStack
-
--- number of bytes that the stack pointer should be aligned to
-stackAlign :: Int
-stackAlign = 16
-
--- convert a spill slot number to a *byte* offset, with no sign:
--- decide on a per arch basis whether you are spilling above or below
--- the C stack pointer.
-spillSlotToOffset :: Platform -> Int -> Int
-spillSlotToOffset platform slot
-   = 64 + spillSlotSize platform * slot
-
---------------------------------------------------------------------------------
-
--- | See if this instruction is telling us the current C stack delta
-takeDeltaInstr
-        :: Instr
-        -> Maybe Int
-
-takeDeltaInstr instr
- = case instr of
-        DELTA i         -> Just i
-        _               -> Nothing
-
-
-isMetaInstr
-        :: Instr
-        -> Bool
-
-isMetaInstr instr
- = case instr of
-        COMMENT{}       -> True
-        LOCATION{}      -> True
-        LDATA{}         -> True
-        NEWBLOCK{}      -> True
-        UNWIND{}        -> True
-        DELTA{}         -> True
-        _               -> False
-
--- | Make a reg-reg move instruction.
-mkRegRegMoveInstr
-    :: Platform
-    -> Reg
-    -> Reg
-    -> Instr
-
-mkRegRegMoveInstr platform src dst
- = case targetClassOfReg platform src of
-        RcInteger -> case platformArch platform of
-                     ArchX86    -> MOV II32 (OpReg src) (OpReg dst)
-                     ArchX86_64 -> MOV II64 (OpReg src) (OpReg dst)
-                     _          -> panic "X86.mkRegRegMoveInstr: Bad arch"
-        RcDouble    ->  MOV FF64 (OpReg src) (OpReg dst)
-        -- this code is the lie we tell ourselves because both float and double
-        -- use the same register class.on x86_64 and x86 32bit with SSE2,
-        -- more plainly, both use the XMM registers
-        _     -> panic "X86.RegInfo.mkRegRegMoveInstr: no match"
-
--- | Check whether an instruction represents a reg-reg move.
---      The register allocator attempts to eliminate reg->reg moves whenever it can,
---      by assigning the src and dest temporaries to the same real register.
---
-takeRegRegMoveInstr
-        :: Instr
-        -> Maybe (Reg,Reg)
-
-takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2))
-        = Just (r1,r2)
-
-takeRegRegMoveInstr _  = Nothing
-
-
--- | Make an unconditional branch instruction.
-mkJumpInstr
-        :: BlockId
-        -> [Instr]
-
-mkJumpInstr id
-        = [JXX ALWAYS id]
-
--- Note [Windows stack layout]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
--- | On most OSes the kernel will place a guard page after the current stack
---   page.  If you allocate larger than a page worth you may jump over this
---   guard page.  Not only is this a security issue, but on certain OSes such
---   as Windows a new page won't be allocated if you don't hit the guard.  This
---   will cause a segfault or access fault.
---
---   This function defines if the current allocation amount requires a probe.
---   On Windows (for now) we emit a call to _chkstk for this.  For other OSes
---   this is not yet implemented.
---   See https://docs.microsoft.com/en-us/windows/desktop/DevNotes/-win32-chkstk
---   The Windows stack looks like this:
---
---                         +-------------------+
---                         |        SP         |
---                         +-------------------+
---                         |                   |
---                         |    GUARD PAGE     |
---                         |                   |
---                         +-------------------+
---                         |                   |
---                         |                   |
---                         |     UNMAPPED      |
---                         |                   |
---                         |                   |
---                         +-------------------+
---
---   In essence each allocation larger than a page size needs to be chunked and
---   a probe emitted after each page allocation.  You have to hit the guard
---   page so the kernel can map in the next page, otherwise you'll segfault.
---   See Note [Windows stack allocations].
---
-needs_probe_call :: Platform -> Int -> Bool
-needs_probe_call platform amount
-  = case platformOS platform of
-     OSMinGW32 -> case platformArch platform of
-                    ArchX86    -> amount > (4 * 1024)
-                    ArchX86_64 -> amount > (4 * 1024)
-                    _          -> False
-     _         -> False
-
-mkStackAllocInstr
-        :: Platform
-        -> Int
-        -> [Instr]
-mkStackAllocInstr platform amount
-  = case platformOS platform of
-      OSMinGW32 ->
-        -- These will clobber AX but this should be ok because
-        --
-        -- 1. It is the first thing we do when entering the closure and AX is
-        --    a caller saved registers on Windows both on x86_64 and x86.
-        --
-        -- 2. The closures are only entered via a call or longjmp in which case
-        --    there are no expectations for volatile registers.
-        --
-        -- 3. When the target is a local branch point it is re-targeted
-        --    after the dealloc, preserving #2.  See Note [extra spill slots].
-        --
-        -- We emit a call because the stack probes are quite involved and
-        -- would bloat code size a lot.  GHC doesn't really have an -Os.
-        -- ___chkstk is guaranteed to leave all nonvolatile registers and AX
-        -- untouched.  It's part of the standard prologue code for any Windows
-        -- function dropping the stack more than a page.
-        -- See Note [Windows stack layout]
-        case platformArch platform of
-            ArchX86    | needs_probe_call platform amount ->
-                           [ MOV II32 (OpImm (ImmInt amount)) (OpReg eax)
-                           , CALL (Left $ strImmLit (fsLit "___chkstk_ms")) [eax]
-                           , SUB II32 (OpReg eax) (OpReg esp)
-                           ]
-                       | otherwise ->
-                           [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp)
-                           , TEST II32 (OpReg esp) (OpReg esp)
-                           ]
-            ArchX86_64 | needs_probe_call platform amount ->
-                           [ MOV II64 (OpImm (ImmInt amount)) (OpReg rax)
-                           , CALL (Left $ strImmLit (fsLit "___chkstk_ms")) [rax]
-                           , SUB II64 (OpReg rax) (OpReg rsp)
-                           ]
-                       | otherwise ->
-                           [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp)
-                           , TEST II64 (OpReg rsp) (OpReg rsp)
-                           ]
-            _ -> panic "X86.mkStackAllocInstr"
-      _       ->
-        case platformArch platform of
-          ArchX86    -> [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp) ]
-          ArchX86_64 -> [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) ]
-          _ -> panic "X86.mkStackAllocInstr"
-
-mkStackDeallocInstr
-        :: Platform
-        -> Int
-        -> [Instr]
-mkStackDeallocInstr platform amount
-  = case platformArch platform of
-      ArchX86    -> [ADD II32 (OpImm (ImmInt amount)) (OpReg esp)]
-      ArchX86_64 -> [ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)]
-      _ -> panic "X86.mkStackDeallocInstr"
-
-
--- Note [extra spill slots]
--- ~~~~~~~~~~~~~~~~~~~~~~~~
--- If the register allocator used more spill slots than we have
--- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more
--- C stack space on entry and exit from this proc.  Therefore we
--- insert a "sub $N, %rsp" at every entry point, and an "add $N, %rsp"
--- before every non-local jump.
---
--- This became necessary when the new codegen started bundling entire
--- functions together into one proc, because the register allocator
--- assigns a different stack slot to each virtual reg within a proc.
--- To avoid using so many slots we could also:
---
---   - split up the proc into connected components before code generator
---
---   - rename the virtual regs, so that we re-use vreg names and hence
---     stack slots for non-overlapping vregs.
---
--- Note that when a block is both a non-local entry point (with an
--- info table) and a local branch target, we have to split it into
--- two, like so:
---
---    <info table>
---    L:
---       <code>
---
--- becomes
---
---    <info table>
---    L:
---       subl $rsp, N
---       jmp Lnew
---    Lnew:
---       <code>
---
--- and all branches pointing to L are retargetted to point to Lnew.
--- Otherwise, we would repeat the $rsp adjustment for each branch to
--- L.
---
--- Returns a list of (L,Lnew) pairs.
---
-allocMoreStack
-  :: Platform
-  -> Int
-  -> NatCmmDecl statics GHC.CmmToAsm.X86.Instr.Instr
-  -> UniqSM (NatCmmDecl statics GHC.CmmToAsm.X86.Instr.Instr, [(BlockId,BlockId)])
-
-allocMoreStack _ _ top@(CmmData _ _) = return (top,[])
-allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do
-    let entries = entryBlocks proc
-
-    uniqs <- getUniquesM
-
-    let
-      delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
-        where x = slots * spillSlotSize platform -- sp delta
-
-      alloc   = mkStackAllocInstr   platform delta
-      dealloc = mkStackDeallocInstr platform delta
-
-      retargetList = (zip entries (map mkBlockId uniqs))
-
-      new_blockmap :: LabelMap BlockId
-      new_blockmap = mapFromList retargetList
-
-      insert_stack_insns (BasicBlock id insns)
-         | Just new_blockid <- mapLookup id new_blockmap
-         = [ BasicBlock id $ alloc ++ [JXX ALWAYS new_blockid]
-           , BasicBlock new_blockid block' ]
-         | otherwise
-         = [ BasicBlock id block' ]
-         where
-           block' = foldr insert_dealloc [] insns
-
-      insert_dealloc insn r = case insn of
-         JMP _ _     -> dealloc ++ (insn : r)
-         JXX_GBL _ _ -> panic "insert_dealloc: cannot handle JXX_GBL"
-         _other      -> patchJumpInstr insn retarget : r
-           where retarget b = fromMaybe b (mapLookup b new_blockmap)
-
-      new_code = concatMap insert_stack_insns code
-    -- in
-    return (CmmProc info lbl live (ListGraph new_code), retargetList)
-
-data JumpDest = DestBlockId BlockId | DestImm Imm
-
--- Debug Instance
-instance Outputable JumpDest where
-  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid
-  ppr (DestImm _imm)    = text "jd<imm>:noShow"
-
-
-getJumpDestBlockId :: JumpDest -> Maybe BlockId
-getJumpDestBlockId (DestBlockId bid) = Just bid
-getJumpDestBlockId _                 = Nothing
-
-canShortcut :: Instr -> Maybe JumpDest
-canShortcut (JXX ALWAYS id)      = Just (DestBlockId id)
-canShortcut (JMP (OpImm imm) _)  = Just (DestImm imm)
-canShortcut _                    = Nothing
-
-
--- This helper shortcuts a sequence of branches.
--- The blockset helps avoid following cycles.
-shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
-shortcutJump fn insn = shortcutJump' fn (setEmpty :: LabelSet) insn
-  where
-    shortcutJump' :: (BlockId -> Maybe JumpDest) -> LabelSet -> Instr -> Instr
-    shortcutJump' fn seen insn@(JXX cc id) =
-        if setMember id seen then insn
-        else case fn id of
-            Nothing                -> insn
-            Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id')
-            Just (DestImm imm)     -> shortcutJump' fn seen' (JXX_GBL cc imm)
-        where seen' = setInsert id seen
-    shortcutJump' fn _ (JMP_TBL addr blocks section tblId) =
-        let updateBlock (Just (DestBlockId bid))  =
-                case fn bid of
-                    Nothing   -> Just (DestBlockId bid )
-                    Just dest -> Just dest
-            updateBlock dest = dest
-            blocks' = map updateBlock blocks
-        in  JMP_TBL addr blocks' section tblId
-    shortcutJump' _ _ other = other
-
--- Here because it knows about JumpDest
-shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, RawCmmStatics) -> (Alignment, RawCmmStatics)
-shortcutStatics fn (align, CmmStaticsRaw lbl statics)
-  = (align, CmmStaticsRaw lbl $ map (shortcutStatic fn) statics)
-  -- we need to get the jump tables, so apply the mapping to the entries
-  -- of a CmmData too.
-
-shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
-shortcutLabel fn lab
-  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn emptyUniqSet blkId
-  | otherwise                              = lab
-
-shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
-shortcutStatic fn (CmmStaticLit (CmmLabel lab))
-  = CmmStaticLit (CmmLabel (shortcutLabel fn lab))
-shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w))
-  = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w)
-        -- slightly dodgy, we're ignoring the second label, but this
-        -- works with the way we use CmmLabelDiffOff for jump tables now.
-shortcutStatic _ other_static
-        = other_static
-
-shortBlockId
-        :: (BlockId -> Maybe JumpDest)
-        -> UniqSet Unique
-        -> BlockId
-        -> CLabel
-
-shortBlockId fn seen blockid =
-  case (elementOfUniqSet uq seen, fn blockid) of
-    (True, _)    -> blockLbl blockid
-    (_, Nothing) -> blockLbl blockid
-    (_, Just (DestBlockId blockid'))  -> shortBlockId fn (addOneToUniqSet seen uq) blockid'
-    (_, Just (DestImm (ImmCLbl lbl))) -> lbl
-    (_, _other) -> panic "shortBlockId"
-  where uq = getUnique blockid
diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/X86/Ppr.hs
+++ /dev/null
@@ -1,1063 +0,0 @@
-
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
------------------------------------------------------------------------------
---
--- Pretty-printing assembly language
---
--- (c) The University of Glasgow 1993-2005
---
------------------------------------------------------------------------------
-
-module GHC.CmmToAsm.X86.Ppr (
-        pprNatCmmDecl,
-        pprInstr,
-)
-
-where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Platform.Reg
-
-import GHC.CmmToAsm.X86.Regs
-import GHC.CmmToAsm.X86.Instr
-import GHC.CmmToAsm.X86.Cond
-import GHC.CmmToAsm.Config
-import GHC.CmmToAsm.Format
-import GHC.CmmToAsm.Types
-import GHC.CmmToAsm.Utils
-import GHC.CmmToAsm.Ppr
-
-import GHC.Cmm              hiding (topInfoTable)
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.BlockId
-import GHC.Cmm.CLabel
-import GHC.Cmm.DebugBlock (pprUnwindTable)
-
-import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes)
-import GHC.Types.Unique ( pprUniqueAlways )
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import Data.Word
-
--- Note [Subsections Via Symbols]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- If we are using the .subsections_via_symbols directive
--- (available on recent versions of Darwin),
--- we have to make sure that there is some kind of reference
--- from the entry code to a label on the _top_ of the info table,
--- so that the linker will not think it is unreferenced and dead-strip
--- it. That's why the label is called a DeadStripPreventer (_dsp).
---
--- The LLVM code gen already creates `iTableSuf` symbols, where
--- the X86 would generate the DeadStripPreventer (_dsp) symbol.
--- Therefore all that is left for llvm code gen, is to ensure
--- that all the `iTableSuf` symbols are marked as used.
--- As of this writing the documentation regarding the
--- .subsections_via_symbols and -dead_strip can be found at
--- <https://developer.apple.com/library/mac/documentation/DeveloperTools/Reference/Assembler/040-Assembler_Directives/asm_directives.html#//apple_ref/doc/uid/TP30000823-TPXREF101>
-
-pprProcAlignment :: IsDoc doc => NCGConfig -> doc
-pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config)
-   where
-      platform = ncgPlatform config
-
-pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> doc
-pprNatCmmDecl config (CmmData section dats) =
-  pprSectionAlign config section $$ pprDatas config dats
-
-pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
-  let platform = ncgPlatform config in
-  pprProcAlignment config $$
-  case topInfoTable proc of
-    Nothing ->
-        -- special case for code without info table:
-        pprSectionAlign config (Section Text lbl) $$
-        pprProcAlignment config $$
-        pprProcLabel config lbl $$
-        pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed
-        vcat (map (pprBasicBlock config top_info) blocks) $$
-        ppWhen (ncgDwarfEnabled config) (line (pprBlockEndLabel platform lbl) $$ line (pprProcEndLabel platform lbl)) $$
-        pprSizeDecl platform lbl
-
-    Just (CmmStaticsRaw info_lbl _) ->
-      pprSectionAlign config (Section Text info_lbl) $$
-      pprProcAlignment config $$
-      pprProcLabel config lbl $$
-      (if platformHasSubsectionsViaSymbols platform
-          then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> colon)
-          else empty) $$
-      vcat (map (pprBasicBlock config top_info) blocks) $$
-      ppWhen (ncgDwarfEnabled config) (line (pprProcEndLabel platform info_lbl)) $$
-      -- above: Even the first block gets a label, because with branch-chain
-      -- elimination, it might be the target of a goto.
-      (if platformHasSubsectionsViaSymbols platform
-       then -- See Note [Subsections Via Symbols]
-                line
-              $ text "\t.long "
-            <+> pprAsmLabel platform info_lbl
-            <+> char '-'
-            <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)
-       else empty) $$
-      pprSizeDecl platform info_lbl
-{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc #-}
-{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
-
--- | Output an internal proc label. See Note [Internal proc labels] in CLabel.
-pprProcLabel :: IsDoc doc => NCGConfig -> CLabel -> doc
-pprProcLabel config lbl
-  | ncgExposeInternalSymbols config
-  , Just lbl' <- ppInternalProcLabel (ncgThisModule config) lbl
-  = line (lbl' <> colon)
-  | otherwise
-  = empty
-
-pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name
-                -> doc
-pprProcEndLabel platform lbl =
-    pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon
-
-pprBlockEndLabel :: IsLine doc => Platform -> CLabel -- ^ Block name
-                 -> doc
-pprBlockEndLabel platform lbl =
-    pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon
-
--- | Output the ELF .size directive.
-pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc
-pprSizeDecl platform lbl
- = if osElfTarget (platformOS platform)
-   then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl)
-   else empty
-
-pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> doc
-pprBasicBlock config info_env (BasicBlock blockid instrs)
-  = maybe_infotable $
-    pprLabel platform asmLbl $$
-    vcat (map (pprInstr platform) instrs) $$
-    ppWhen (ncgDwarfEnabled config) (
-      -- Emit both end labels since this may end up being a standalone
-      -- top-level block
-      line (pprBlockEndLabel platform asmLbl
-         <> pprProcEndLabel platform asmLbl)
-    )
-  where
-    asmLbl = blockLbl blockid
-    platform = ncgPlatform config
-    maybe_infotable c = case mapLookup blockid info_env of
-       Nothing -> c
-       Just (CmmStaticsRaw infoLbl info) ->
-           pprAlignForSection platform Text $$
-           infoTableLoc $$
-           vcat (map (pprData config) info) $$
-           pprLabel platform infoLbl $$
-           c $$
-           ppWhen (ncgDwarfEnabled config) (line (pprAsmLabel platform (mkAsmTempEndLabel infoLbl) <> colon))
-
-    -- Make sure the info table has the right .loc for the block
-    -- coming right after it. See Note [Info Offset]
-    infoTableLoc = case instrs of
-      (l@LOCATION{} : _) -> pprInstr platform l
-      _other             -> empty
-
-
-pprDatas :: IsDoc doc => NCGConfig -> (Alignment, RawCmmStatics) -> doc
--- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
-pprDatas config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
-  | lbl == mkIndStaticInfoLabel
-  , let labelInd (CmmLabelOff l _) = Just l
-        labelInd (CmmLabel l) = Just l
-        labelInd _ = Nothing
-  , Just ind' <- labelInd ind
-  , alias `mayRedirectTo` ind'
-  = pprGloblDecl (ncgPlatform config) alias
-    $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind')
-
-pprDatas config (align, (CmmStaticsRaw lbl dats))
- = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats)
-   where
-      platform = ncgPlatform config
-
-pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc
-pprData _config (CmmString str) = line (pprString str)
-pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path)
-
-pprData config (CmmUninitialised bytes)
- = line
- $ let platform = ncgPlatform config
-   in if platformOS platform == OSDarwin
-         then text ".space " <> int bytes
-         else text ".skip "  <> int bytes
-
-pprData config (CmmStaticLit lit) = pprDataItem config lit
-
-pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc
-pprGloblDecl platform lbl
-  | not (externallyVisibleCLabel lbl) = empty
-  | otherwise = line (text ".globl " <> pprAsmLabel platform lbl)
-
-pprLabelType' :: IsLine doc => Platform -> CLabel -> doc
-pprLabelType' platform lbl =
-  if isCFunctionLabel lbl || functionOkInfoTable then
-    text "@function"
-  else
-    text "@object"
-  where
-    {-
-    NOTE: This is a bit hacky.
-
-    With the `tablesNextToCode` info tables look like this:
-    ```
-      <info table data>
-    label_info:
-      <info table code>
-    ```
-    So actually info table label points exactly to the code and we can mark
-    the label as @function. (This is required to make perf and potentially other
-    tools to work on Haskell binaries).
-    This usually works well but it can cause issues with a linker.
-    A linker uses different algorithms for the relocation depending on
-    the symbol type.For some reason, a linker will generate JUMP_SLOT relocation
-    when constructor info table is referenced from a data section.
-    This only happens with static constructor call so
-    we mark _con_info symbols as `@object` to avoid the issue with relocations.
-
-    @SimonMarlow hack explanation:
-    "The reasoning goes like this:
-
-    * The danger when we mark a symbol as `@function` is that the linker will
-      redirect it to point to the PLT and use a `JUMP_SLOT` relocation when
-      the symbol refers to something outside the current shared object.
-      A PLT / JUMP_SLOT reference only works for symbols that we jump to, not
-      for symbols representing data,, nor for info table symbol references which
-      we expect to point directly to the info table.
-    * GHC generates code that might refer to any info table symbol from the text
-      segment, but that's OK, because those will be explicit GOT references
-      generated by the code generator.
-    * When we refer to info tables from the data segment, it's either
-      * a FUN_STATIC/THUNK_STATIC local to this module
-      * a `con_info` that could be from anywhere
-
-    So, the only info table symbols that we might refer to from the data segment
-    of another shared object are `con_info` symbols, so those are the ones we
-    need to exclude from getting the @function treatment.
-    "
-
-    A good place to check for more
-    https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code
-
-    Another possible hack is to create an extra local function symbol for
-    every code-like thing to give the needed information for to the tools
-    but mess up with the relocation. https://phabricator.haskell.org/D4730
-    -}
-    functionOkInfoTable = platformTablesNextToCode platform &&
-      isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl)
-
-
-pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc
-pprTypeDecl platform lbl
-    = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl
-      then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl)
-      else empty
-
-pprLabel :: IsDoc doc => Platform -> CLabel -> doc
-pprLabel platform lbl =
-   pprGloblDecl platform lbl
-   $$ pprTypeDecl platform lbl
-   $$ line (pprAsmLabel platform lbl <> colon)
-
-pprAlign :: IsDoc doc => Platform -> Alignment -> doc
-pprAlign platform alignment
-        = line $ text ".align " <> int (alignmentOn platform)
-  where
-        bytes = alignmentBytes alignment
-        alignmentOn platform = if platformOS platform == OSDarwin
-                               then log2 bytes
-                               else      bytes
-
-        log2 :: Int -> Int  -- cache the common ones
-        log2 1 = 0
-        log2 2 = 1
-        log2 4 = 2
-        log2 8 = 3
-        log2 n = 1 + log2 (n `quot` 2)
-
-pprReg :: forall doc. IsLine doc => Platform -> Format -> Reg -> doc
-pprReg platform f r
-  = case r of
-      RegReal    (RealRegSingle i) ->
-          if target32Bit platform then ppr32_reg_no f i
-                                  else ppr64_reg_no f i
-      RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u
-      RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u
-      RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u
-      RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u
-
-  where
-    ppr32_reg_no :: Format -> Int -> doc
-    ppr32_reg_no II8   = ppr32_reg_byte
-    ppr32_reg_no II16  = ppr32_reg_word
-    ppr32_reg_no _     = ppr32_reg_long
-
-    ppr32_reg_byte i =
-      case i of {
-         0 -> text "%al";     1 -> text "%bl";
-         2 -> text "%cl";     3 -> text "%dl";
-        _  -> text "very naughty I386 byte register: " <> int i
-      }
-
-    ppr32_reg_word i =
-      case i of {
-         0 -> text "%ax";     1 -> text "%bx";
-         2 -> text "%cx";     3 -> text "%dx";
-         4 -> text "%si";     5 -> text "%di";
-         6 -> text "%bp";     7 -> text "%sp";
-        _  -> text "very naughty I386 word register"
-      }
-
-    ppr32_reg_long i =
-      case i of {
-         0 -> text "%eax";    1 -> text "%ebx";
-         2 -> text "%ecx";    3 -> text "%edx";
-         4 -> text "%esi";    5 -> text "%edi";
-         6 -> text "%ebp";    7 -> text "%esp";
-         _  -> ppr_reg_float i
-      }
-
-    ppr64_reg_no :: Format -> Int -> doc
-    ppr64_reg_no II8   = ppr64_reg_byte
-    ppr64_reg_no II16  = ppr64_reg_word
-    ppr64_reg_no II32  = ppr64_reg_long
-    ppr64_reg_no _     = ppr64_reg_quad
-
-    ppr64_reg_byte i =
-      case i of {
-         0 -> text "%al";      1 -> text "%bl";
-         2 -> text "%cl";      3 -> text "%dl";
-         4 -> text "%sil";     5 -> text "%dil"; -- new 8-bit regs!
-         6 -> text "%bpl";     7 -> text "%spl";
-         8 -> text "%r8b";     9 -> text "%r9b";
-        10 -> text "%r10b";   11 -> text "%r11b";
-        12 -> text "%r12b";   13 -> text "%r13b";
-        14 -> text "%r14b";   15 -> text "%r15b";
-        _  -> text "very naughty x86_64 byte register: " <> int i
-      }
-
-    ppr64_reg_word i =
-      case i of {
-         0 -> text "%ax";      1 -> text "%bx";
-         2 -> text "%cx";      3 -> text "%dx";
-         4 -> text "%si";      5 -> text "%di";
-         6 -> text "%bp";      7 -> text "%sp";
-         8 -> text "%r8w";     9 -> text "%r9w";
-        10 -> text "%r10w";   11 -> text "%r11w";
-        12 -> text "%r12w";   13 -> text "%r13w";
-        14 -> text "%r14w";   15 -> text "%r15w";
-        _  -> text "very naughty x86_64 word register"
-      }
-
-    ppr64_reg_long i =
-      case i of {
-         0 -> text "%eax";    1  -> text "%ebx";
-         2 -> text "%ecx";    3  -> text "%edx";
-         4 -> text "%esi";    5  -> text "%edi";
-         6 -> text "%ebp";    7  -> text "%esp";
-         8 -> text "%r8d";    9  -> text "%r9d";
-        10 -> text "%r10d";   11 -> text "%r11d";
-        12 -> text "%r12d";   13 -> text "%r13d";
-        14 -> text "%r14d";   15 -> text "%r15d";
-        _  -> text "very naughty x86_64 register"
-      }
-
-    ppr64_reg_quad i =
-      case i of {
-         0 -> text "%rax";     1 -> text "%rbx";
-         2 -> text "%rcx";     3 -> text "%rdx";
-         4 -> text "%rsi";     5 -> text "%rdi";
-         6 -> text "%rbp";     7 -> text "%rsp";
-         8 -> text "%r8";      9 -> text "%r9";
-        10 -> text "%r10";    11 -> text "%r11";
-        12 -> text "%r12";    13 -> text "%r13";
-        14 -> text "%r14";    15 -> text "%r15";
-        _  -> ppr_reg_float i
-      }
-
-ppr_reg_float :: IsLine doc => Int -> doc
-ppr_reg_float i = case i of
-        16 -> text "%xmm0" ;   17 -> text "%xmm1"
-        18 -> text "%xmm2" ;   19 -> text "%xmm3"
-        20 -> text "%xmm4" ;   21 -> text "%xmm5"
-        22 -> text "%xmm6" ;   23 -> text "%xmm7"
-        24 -> text "%xmm8" ;   25 -> text "%xmm9"
-        26 -> text "%xmm10";   27 -> text "%xmm11"
-        28 -> text "%xmm12";   29 -> text "%xmm13"
-        30 -> text "%xmm14";   31 -> text "%xmm15"
-        _  -> text "very naughty x86 register"
-
-pprFormat :: IsLine doc => Format -> doc
-pprFormat x = case x of
-  II8   -> text "b"
-  II16  -> text "w"
-  II32  -> text "l"
-  II64  -> text "q"
-  FF32  -> text "ss"      -- "scalar single-precision float" (SSE2)
-  FF64  -> text "sd"      -- "scalar double-precision float" (SSE2)
-
-pprFormat_x87 :: IsLine doc => Format -> doc
-pprFormat_x87 x = case x of
-  FF32  -> text "s"
-  FF64  -> text "l"
-  _     -> panic "X86.Ppr.pprFormat_x87"
-
-
-pprCond :: IsLine doc => Cond -> doc
-pprCond c = case c of {
-  GEU     -> text "ae";   LU   -> text "b";
-  EQQ     -> text "e";    GTT  -> text "g";
-  GE      -> text "ge";   GU   -> text "a";
-  LTT     -> text "l";    LE   -> text "le";
-  LEU     -> text "be";   NE   -> text "ne";
-  NEG     -> text "s";    POS  -> text "ns";
-  CARRY   -> text "c";   OFLO  -> text "o";
-  PARITY  -> text "p";   NOTPARITY -> text "np";
-  ALWAYS  -> text "mp"}
-
-
-pprImm :: IsLine doc => Platform -> Imm -> doc
-pprImm platform = \case
-   ImmInt i            -> int i
-   ImmInteger i        -> integer i
-   ImmCLbl l           -> pprAsmLabel platform l
-   ImmIndex l i        -> pprAsmLabel platform l <> char '+' <> int i
-   ImmLit s            -> ftext s
-   ImmFloat f          -> float $ fromRational f
-   ImmDouble d         -> double $ fromRational d
-   ImmConstantSum a b  -> pprImm platform a <> char '+' <> pprImm platform b
-   ImmConstantDiff a b -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen
-
-
-
-pprAddr :: IsLine doc => Platform -> AddrMode -> doc
-pprAddr platform (ImmAddr imm off)
-  = let pp_imm = pprImm platform imm
-    in
-    if (off == 0) then
-        pp_imm
-    else if (off < 0) then
-        pp_imm <> int off
-    else
-        pp_imm <> char '+' <> int off
-
-pprAddr platform (AddrBaseIndex base index displacement)
-  = let
-        pp_disp  = ppr_disp displacement
-        pp_off p = pp_disp <> char '(' <> p <> char ')'
-        pp_reg r = pprReg platform (archWordFormat (target32Bit platform)) r
-    in
-    case (base, index) of
-      (EABaseNone,  EAIndexNone) -> pp_disp
-      (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
-      (EABaseRip,   EAIndexNone) -> pp_off (text "%rip")
-      (EABaseNone,  EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
-      (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
-                                       <> comma <> int i)
-      _                         -> panic "X86.Ppr.pprAddr: no match"
-
-  where
-    ppr_disp (ImmInt 0) = empty
-    ppr_disp imm        = pprImm platform imm
-
--- | Print section header and appropriate alignment for that section.
-pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc
-pprSectionAlign _config (Section (OtherSection _) _) =
-     panic "X86.Ppr.pprSectionAlign: unknown section"
-pprSectionAlign config sec@(Section seg _) =
-    line (pprSectionHeader config sec) $$
-    pprAlignForSection (ncgPlatform config) seg
-
--- | Print appropriate alignment for the given section type.
-pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc
-pprAlignForSection platform seg = line $
-    text ".align " <>
-    case platformOS platform of
-      -- Darwin: alignments are given as shifts.
-      OSDarwin
-       | target32Bit platform ->
-          case seg of
-           CString           -> int 1
-           _                 -> int 2
-       | otherwise ->
-          case seg of
-           CString           -> int 1
-           _                 -> int 3
-      -- Other: alignments are given as bytes.
-      _
-       | target32Bit platform ->
-          case seg of
-           Text              -> text "4,0x90"
-           CString           -> int 1
-           _                 -> int 4
-       | otherwise ->
-          case seg of
-           CString           -> int 1
-           _                 -> int 8
-
-pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc
-pprDataItem config lit
-  = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)
-    where
-        platform = ncgPlatform config
-        imm = litToImm lit
-
-        -- These seem to be common:
-        ppr_item II8   _ = [text "\t.byte\t" <> pprImm platform imm]
-        ppr_item II16  _ = [text "\t.word\t" <> pprImm platform imm]
-        ppr_item II32  _ = [text "\t.long\t" <> pprImm platform imm]
-
-        ppr_item FF32 _ = [text "\t.float\t" <> pprImm platform imm]
-        ppr_item FF64 _ = [text "\t.double\t" <> pprImm platform imm]
-
-        ppr_item II64 _
-            = case platformOS platform of
-              OSDarwin
-               | target32Bit platform ->
-                  case lit of
-                  CmmInt x _ ->
-                      [text "\t.long\t"
-                          <> int (fromIntegral (fromIntegral x :: Word32)),
-                       text "\t.long\t"
-                          <> int (fromIntegral
-                              (fromIntegral (x `shiftR` 32) :: Word32))]
-                  _ -> panic "X86.Ppr.ppr_item: no match for II64"
-              _ -> [text "\t.quad\t" <> pprImm platform imm]
-
-
-asmComment :: IsLine doc => doc -> doc
-asmComment c = whenPprDebug $ text "# " <> c
-
-pprInstr :: forall doc. IsDoc doc => Platform -> Instr -> doc
-pprInstr platform i = case i of
-   COMMENT s
-      -> line (asmComment (ftext s))
-
-   LOCATION file line' col _name
-      -> line (text "\t.loc " <> int file <+> int line' <+> int col)
-
-   DELTA d
-      -> line (asmComment $ text ("\tdelta = " ++ show d))
-
-   NEWBLOCK _
-      -> panic "pprInstr: NEWBLOCK"
-
-   UNWIND lbl d
-      -> line (asmComment (text "\tunwind = " <> pprUnwindTable platform d))
-         $$ line (pprAsmLabel platform lbl <> colon)
-
-   LDATA _ _
-      -> panic "pprInstr: LDATA"
-
-{-
-   SPILL reg slot
-      -> hcat [
-           text "\tSPILL",
-           char ' ',
-           pprUserReg reg,
-           comma,
-           text "SLOT" <> parens (int slot)]
-
-   RELOAD slot reg
-      -> hcat [
-        text "\tRELOAD",
-        char ' ',
-        text "SLOT" <> parens (int slot),
-        comma,
-        pprUserReg reg]
--}
-
-   -- Replace 'mov $0x0,%reg' by 'xor %reg,%reg', which is smaller and cheaper.
-   -- The code generator catches most of these already, but not all.
-   MOV format (OpImm (ImmInt 0)) dst@(OpReg _)
-     -> pprInstr platform (XOR format' dst dst)
-        where format' = case format of
-                II64 -> II32          -- 32-bit version is equivalent, and smaller
-                _    -> format
-
-   MOV format src dst
-     -> pprFormatOpOp (text "mov") format src dst
-
-   CMOV cc format src dst
-     -> pprCondOpReg (text "cmov") format cc src dst
-
-   MOVZxL II32 src dst
-      -> pprFormatOpOp (text "mov") II32 src dst
-        -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
-        -- movl.  But we represent it as a MOVZxL instruction, because
-        -- the reg alloc would tend to throw away a plain reg-to-reg
-        -- move, and we still want it to do that.
-
-   MOVZxL formats src dst
-      -> pprFormatOpOpCoerce (text "movz") formats II32 src dst
-        -- zero-extension only needs to extend to 32 bits: on x86_64,
-        -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
-        -- instruction is shorter.
-
-   MOVSxL formats src dst
-      -> pprFormatOpOpCoerce (text "movs") formats (archWordFormat (target32Bit platform)) src dst
-
-   -- here we do some patching, since the physical registers are only set late
-   -- in the code generation.
-   LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)
-      | reg1 == reg3
-      -> pprFormatOpOp (text "add") format (OpReg reg2) dst
-
-   LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)
-      | reg2 == reg3
-      -> pprFormatOpOp (text "add") format (OpReg reg1) dst
-
-   LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3)
-      | reg1 == reg3
-      -> pprInstr platform (ADD format (OpImm displ) dst)
-
-   LEA format src dst
-      -> pprFormatOpOp (text "lea") format src dst
-
-   ADD format (OpImm (ImmInt (-1))) dst
-      -> pprFormatOp (text "dec") format dst
-
-   ADD format (OpImm (ImmInt 1)) dst
-      -> pprFormatOp (text "inc") format dst
-
-   ADD format src dst
-      -> pprFormatOpOp (text "add") format src dst
-
-   ADC format src dst
-      -> pprFormatOpOp (text "adc") format src dst
-
-   SUB format src dst
-      -> pprFormatOpOp (text "sub") format src dst
-
-   SBB format src dst
-      -> pprFormatOpOp (text "sbb") format src dst
-
-   IMUL format op1 op2
-      -> pprFormatOpOp (text "imul") format op1 op2
-
-   ADD_CC format src dst
-      -> pprFormatOpOp (text "add") format src dst
-
-   SUB_CC format src dst
-      -> pprFormatOpOp (text "sub") format src dst
-
-   -- Use a 32-bit instruction when possible as it saves a byte.
-   -- Notably, extracting the tag bits of a pointer has this form.
-   -- TODO: we could save a byte in a subsequent CMP instruction too,
-   -- but need something like a peephole pass for this
-   AND II64 src@(OpImm (ImmInteger mask)) dst
-      | 0 <= mask && mask < 0xffffffff
-      -> pprInstr platform (AND II32 src dst)
-
-   AND FF32 src dst
-      -> pprOpOp (text "andps") FF32 src dst
-
-   AND FF64 src dst
-      -> pprOpOp (text "andpd") FF64 src dst
-
-   AND format src dst
-      -> pprFormatOpOp (text "and") format src dst
-
-   OR  format src dst
-      -> pprFormatOpOp (text "or")  format src dst
-
-   XOR FF32 src dst
-      -> pprOpOp (text "xorps") FF32 src dst
-
-   XOR FF64 src dst
-      ->  pprOpOp (text "xorpd") FF64 src dst
-
-   XOR format src dst
-      -> pprFormatOpOp (text "xor") format src dst
-
-   POPCNT format src dst
-      -> pprOpOp (text "popcnt") format src (OpReg dst)
-
-   LZCNT format src dst
-      ->  pprOpOp (text "lzcnt") format src (OpReg dst)
-
-   TZCNT format src dst
-      -> pprOpOp (text "tzcnt") format src (OpReg dst)
-
-   BSF format src dst
-      -> pprOpOp (text "bsf") format src (OpReg dst)
-
-   BSR format src dst
-      -> pprOpOp (text "bsr") format src (OpReg dst)
-
-   PDEP format src mask dst
-      -> pprFormatOpOpReg (text "pdep") format src mask dst
-
-   PEXT format src mask dst
-      -> pprFormatOpOpReg (text "pext") format src mask dst
-
-   PREFETCH NTA format src
-      -> pprFormatOp_ (text "prefetchnta") format src
-
-   PREFETCH Lvl0 format src
-      -> pprFormatOp_ (text "prefetcht0") format src
-
-   PREFETCH Lvl1 format src
-      -> pprFormatOp_ (text "prefetcht1") format src
-
-   PREFETCH Lvl2 format src
-      -> pprFormatOp_ (text "prefetcht2") format src
-
-   NOT format op
-      -> pprFormatOp (text "not") format op
-
-   BSWAP format op
-      -> pprFormatOp (text "bswap") format (OpReg op)
-
-   NEGI format op
-      -> pprFormatOp (text "neg") format op
-
-   SHL format src dst
-      -> pprShift (text "shl") format src dst
-
-   SAR format src dst
-      -> pprShift (text "sar") format src dst
-
-   SHR format src dst
-      -> pprShift (text "shr") format src dst
-
-   BT format imm src
-      -> pprFormatImmOp (text "bt") format imm src
-
-   CMP format src dst
-     | isFloatFormat format -> pprFormatOpOp (text "ucomi") format src dst -- SSE2
-     | otherwise            -> pprFormatOpOp (text "cmp")   format src dst
-
-   TEST format src dst
-      -> pprFormatOpOp (text "test") format' src dst
-         where
-        -- Match instructions like 'test $0x3,%esi' or 'test $0x7,%rbx'.
-        -- We can replace them by equivalent, but smaller instructions
-        -- by reducing the size of the immediate operand as far as possible.
-        -- (We could handle masks larger than a single byte too,
-        -- but it would complicate the code considerably
-        -- and tag checks are by far the most common case.)
-        -- The mask must have the high bit clear for this smaller encoding
-        -- to be completely equivalent to the original; in particular so
-        -- that the signed comparison condition bits are the same as they
-        -- would be if doing a full word comparison. See #13425.
-          format' = case (src,dst) of
-           (OpImm (ImmInteger mask), OpReg dstReg)
-             | 0 <= mask && mask < 128 -> minSizeOfReg platform dstReg
-           _ -> format
-          minSizeOfReg platform (RegReal (RealRegSingle i))
-            | target32Bit platform && i <= 3        = II8  -- al, bl, cl, dl
-            | target32Bit platform && i <= 7        = II16 -- si, di, bp, sp
-            | not (target32Bit platform) && i <= 15 = II8  -- al .. r15b
-          minSizeOfReg _ _ = format                 -- other
-
-   PUSH format op
-      -> pprFormatOp (text "push") format op
-
-   POP format op
-      -> pprFormatOp (text "pop") format op
-
--- both unused (SDM):
--- PUSHA -> text "\tpushal"
--- POPA  -> text "\tpopal"
-
-   NOP
-      -> line $ text "\tnop"
-
-   CLTD II8
-      -> line $ text "\tcbtw"
-
-   CLTD II16
-      -> line $ text "\tcwtd"
-
-   CLTD II32
-      -> line $ text "\tcltd"
-
-   CLTD II64
-      -> line $ text "\tcqto"
-
-   CLTD x
-      -> panic $ "pprInstr: CLTD " ++ show x
-
-   SETCC cond op
-      -> pprCondInstr (text "set") cond (pprOperand platform II8 op)
-
-   XCHG format src val
-      -> pprFormatOpReg (text "xchg") format src val
-
-   JXX cond blockid
-      -> pprCondInstr (text "j") cond (pprAsmLabel platform lab)
-         where lab = blockLbl blockid
-
-   JXX_GBL cond imm
-      -> pprCondInstr (text "j") cond (pprImm platform imm)
-
-   JMP (OpImm imm) _
-      -> line $ text "\tjmp " <> pprImm platform imm
-
-   JMP op _
-      -> line $ text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op
-
-   JMP_TBL op _ _ _
-      -> pprInstr platform (JMP op [])
-
-   CALL (Left imm) _
-      -> line $ text "\tcall " <> pprImm platform imm
-
-   CALL (Right reg) _
-      -> line $ text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg
-
-   IDIV fmt op
-      -> pprFormatOp (text "idiv") fmt op
-
-   DIV fmt op
-      -> pprFormatOp (text "div")  fmt op
-
-   IMUL2 fmt op
-      -> pprFormatOp (text "imul") fmt op
-
-   -- x86_64 only
-   MUL format op1 op2
-      -> pprFormatOpOp (text "mul") format op1 op2
-
-   MUL2 format op
-      -> pprFormatOp (text "mul") format op
-
-   FDIV format op1 op2
-      -> pprFormatOpOp (text "div") format op1 op2
-
-   SQRT format op1 op2
-      -> pprFormatOpReg (text "sqrt") format op1 op2
-
-   CVTSS2SD from to
-      -> pprRegReg (text "cvtss2sd") from to
-
-   CVTSD2SS from to
-      -> pprRegReg (text "cvtsd2ss") from to
-
-   CVTTSS2SIQ fmt from to
-      -> pprFormatFormatOpReg (text "cvttss2si") FF32 fmt from to
-
-   CVTTSD2SIQ fmt from to
-      -> pprFormatFormatOpReg (text "cvttsd2si") FF64 fmt from to
-
-   CVTSI2SS fmt from to
-      -> pprFormatOpReg (text "cvtsi2ss") fmt from to
-
-   CVTSI2SD fmt from to
-      -> pprFormatOpReg (text "cvtsi2sd") fmt from to
-
-       -- FETCHGOT for PIC on ELF platforms
-   FETCHGOT reg
-      -> lines_ [ text "\tcall 1f",
-                  hcat [ text "1:\tpopl\t", pprReg platform II32 reg ],
-                  hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ",
-                         pprReg platform II32 reg ]
-                ]
-
-    -- FETCHPC for PIC on Darwin/x86
-    -- get the instruction pointer into a register
-    -- (Terminology note: the IP is called Program Counter on PPC,
-    --  and it's a good thing to use the same name on both platforms)
-   FETCHPC reg
-      -> lines_ [ text "\tcall 1f",
-                  hcat [ text "1:\tpopl\t", pprReg platform II32 reg ]
-                ]
-
-   -- the
-   -- GST fmt src addr ==> FLD dst ; FSTPsz addr
-   g@(X87Store fmt  addr)
-      -> pprX87 g (hcat [gtab, text "fstp", pprFormat_x87 fmt, gsp, pprAddr platform addr])
-
-   -- Atomics
-   LOCK i
-      -> line (text "\tlock") $$ pprInstr platform i
-
-   MFENCE
-      -> line $ text "\tmfence"
-
-   XADD format src dst
-      -> pprFormatOpOp (text "xadd") format src dst
-
-   CMPXCHG format src dst
-      -> pprFormatOpOp (text "cmpxchg") format src dst
-
-
-  where
-   gtab :: Line doc
-   gtab  = char '\t'
-
-   gsp :: Line doc
-   gsp   = char ' '
-
-
-
-   pprX87 :: Instr -> Line doc -> doc
-   pprX87 fake actual
-      = line (char '#' <> pprX87Instr fake) $$ line actual
-
-   pprX87Instr :: Instr -> Line doc
-   pprX87Instr (X87Store fmt dst) = pprFormatAddr (text "gst") fmt dst
-   pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match"
-
-   pprDollImm :: Imm -> Line doc
-   pprDollImm i = text "$" <> pprImm platform i
-
-
-   pprOperand :: Platform -> Format -> Operand -> Line doc
-   pprOperand platform f op = case op of
-      OpReg r   -> pprReg platform f r
-      OpImm i   -> pprDollImm i
-      OpAddr ea -> pprAddr platform ea
-
-
-   pprMnemonic_  :: Line doc -> Line doc
-   pprMnemonic_ name =
-      char '\t' <> name <> space
-
-
-   pprMnemonic  :: Line doc -> Format -> Line doc
-   pprMnemonic name format =
-      char '\t' <> name <> pprFormat format <> space
-
-
-   pprFormatImmOp :: Line doc -> Format -> Imm -> Operand -> doc
-   pprFormatImmOp name format imm op1
-     = line $ hcat [
-           pprMnemonic name format,
-           char '$',
-           pprImm platform imm,
-           comma,
-           pprOperand platform format op1
-       ]
-
-
-   pprFormatOp_ :: Line doc -> Format -> Operand -> doc
-   pprFormatOp_ name format op1
-     = line $ hcat [
-           pprMnemonic_ name ,
-           pprOperand platform format op1
-       ]
-
-   pprFormatOp :: Line doc -> Format -> Operand -> doc
-   pprFormatOp name format op1
-     = line $ hcat [
-           pprMnemonic name format,
-           pprOperand platform format op1
-       ]
-
-
-   pprFormatOpOp :: Line doc -> Format -> Operand -> Operand -> doc
-   pprFormatOpOp name format op1 op2
-     = line $ hcat [
-           pprMnemonic name format,
-           pprOperand platform format op1,
-           comma,
-           pprOperand platform format op2
-       ]
-
-
-   pprOpOp :: Line doc -> Format -> Operand -> Operand -> doc
-   pprOpOp name format op1 op2
-     = line $ hcat [
-           pprMnemonic_ name,
-           pprOperand platform format op1,
-           comma,
-           pprOperand platform format op2
-       ]
-
-   pprRegReg :: Line doc -> Reg -> Reg -> doc
-   pprRegReg name reg1 reg2
-     = line $ hcat [
-           pprMnemonic_ name,
-           pprReg platform (archWordFormat (target32Bit platform)) reg1,
-           comma,
-           pprReg platform (archWordFormat (target32Bit platform)) reg2
-       ]
-
-
-   pprFormatOpReg :: Line doc -> Format -> Operand -> Reg -> doc
-   pprFormatOpReg name format op1 reg2
-     = line $ hcat [
-           pprMnemonic name format,
-           pprOperand platform format op1,
-           comma,
-           pprReg platform (archWordFormat (target32Bit platform)) reg2
-       ]
-
-   pprCondOpReg :: Line doc -> Format -> Cond -> Operand -> Reg -> doc
-   pprCondOpReg name format cond op1 reg2
-     = line $ hcat [
-           char '\t',
-           name,
-           pprCond cond,
-           space,
-           pprOperand platform format op1,
-           comma,
-           pprReg platform format reg2
-       ]
-
-   pprFormatFormatOpReg :: Line doc -> Format -> Format -> Operand -> Reg -> doc
-   pprFormatFormatOpReg name format1 format2 op1 reg2
-     = line $ hcat [
-           pprMnemonic name format2,
-           pprOperand platform format1 op1,
-           comma,
-           pprReg platform format2 reg2
-       ]
-
-   pprFormatOpOpReg :: Line doc -> Format -> Operand -> Operand -> Reg -> doc
-   pprFormatOpOpReg name format op1 op2 reg3
-     = line $ hcat [
-           pprMnemonic name format,
-           pprOperand platform format op1,
-           comma,
-           pprOperand platform format op2,
-           comma,
-           pprReg platform format reg3
-       ]
-
-
-
-   pprFormatAddr :: Line doc -> Format -> AddrMode -> Line doc
-   pprFormatAddr name format  op
-     = hcat [
-           pprMnemonic name format,
-           comma,
-           pprAddr platform op
-       ]
-
-   pprShift :: Line doc -> Format -> Operand -> Operand -> doc
-   pprShift name format src dest
-     = line $ hcat [
-           pprMnemonic name format,
-           pprOperand platform II8 src,  -- src is 8-bit sized
-           comma,
-           pprOperand platform format dest
-       ]
-
-
-   pprFormatOpOpCoerce :: Line doc -> Format -> Format -> Operand -> Operand -> doc
-   pprFormatOpOpCoerce name format1 format2 op1 op2
-     = line $ hcat [ char '\t', name, pprFormat format1, pprFormat format2, space,
-           pprOperand platform format1 op1,
-           comma,
-           pprOperand platform format2 op2
-       ]
-
-
-   pprCondInstr :: Line doc -> Cond -> Line doc -> doc
-   pprCondInstr name cond arg
-     = line $ hcat [ char '\t', name, pprCond cond, space, arg]
diff --git a/compiler/GHC/CmmToAsm/X86/RegInfo.hs b/compiler/GHC/CmmToAsm/X86/RegInfo.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/X86/RegInfo.hs
+++ /dev/null
@@ -1,72 +0,0 @@
-
-module GHC.CmmToAsm.X86.RegInfo (
-        mkVirtualReg,
-        regDotColor
-)
-
-where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.Format
-import GHC.Platform.Reg
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Platform
-import GHC.Types.Unique
-
-import GHC.Types.Unique.FM
-import GHC.CmmToAsm.X86.Regs
-
-
-mkVirtualReg :: Unique -> Format -> VirtualReg
-mkVirtualReg u format
-   = case format of
-        FF32    -> VirtualRegD u
-        -- for scalar F32, we use the same xmm as F64!
-        -- this is a hack that needs some improvement.
-        -- For now we map both to being allocated as "Double" Registers
-        -- on X86/X86_64
-        FF64    -> VirtualRegD u
-        _other  -> VirtualRegI u
-
-regDotColor :: Platform -> RealReg -> SDoc
-regDotColor platform reg
- = case (lookupUFM (regColors platform) reg) of
-        Just str -> text str
-        _        -> panic "Register not assigned a color"
-
-regColors :: Platform -> UniqFM RealReg [Char]
-regColors platform = listToUFM (normalRegColors platform)
-
-normalRegColors :: Platform -> [(RealReg,String)]
-normalRegColors platform =
-    zip (map realRegSingle [0..lastint platform]) colors
-        ++ zip (map realRegSingle [firstxmm..lastxmm platform]) greys
-  where
-    -- 16 colors - enough for amd64 gp regs
-    colors = ["#800000","#ff0000","#808000","#ffff00","#008000"
-             ,"#00ff00","#008080","#00ffff","#000080","#0000ff"
-             ,"#800080","#ff00ff","#87005f","#875f00","#87af00"
-             ,"#ff00af"]
-
-    -- 16 shades of grey, enough for the currently supported
-    -- SSE extensions.
-    greys = ["#0e0e0e","#1c1c1c","#2a2a2a","#383838","#464646"
-            ,"#545454","#626262","#707070","#7e7e7e","#8c8c8c"
-            ,"#9a9a9a","#a8a8a8","#b6b6b6","#c4c4c4","#d2d2d2"
-            ,"#e0e0e0"]
-
-
-
---     32 shades of grey - use for avx 512 if we ever need it
---     greys = ["#070707","#0e0e0e","#151515","#1c1c1c"
---             ,"#232323","#2a2a2a","#313131","#383838","#3f3f3f"
---             ,"#464646","#4d4d4d","#545454","#5b5b5b","#626262"
---             ,"#696969","#707070","#777777","#7e7e7e","#858585"
---             ,"#8c8c8c","#939393","#9a9a9a","#a1a1a1","#a8a8a8"
---             ,"#afafaf","#b6b6b6","#bdbdbd","#c4c4c4","#cbcbcb"
---             ,"#d2d2d2","#d9d9d9","#e0e0e0"]
-
-
diff --git a/compiler/GHC/CmmToAsm/X86/Regs.hs b/compiler/GHC/CmmToAsm/X86/Regs.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToAsm/X86/Regs.hs
+++ /dev/null
@@ -1,434 +0,0 @@
-
-
-module GHC.CmmToAsm.X86.Regs (
-        -- squeese functions for the graph allocator
-        virtualRegSqueeze,
-        realRegSqueeze,
-
-        -- immediates
-        Imm(..),
-        strImmLit,
-        litToImm,
-
-        -- addressing modes
-        AddrMode(..),
-        addrOffset,
-
-        -- registers
-        spRel,
-        argRegs,
-        allArgRegs,
-        allIntArgRegs,
-        callClobberedRegs,
-        instrClobberedRegs,
-        allMachRegNos,
-        classOfRealReg,
-        showReg,
-
-        -- machine specific
-        EABase(..), EAIndex(..), addrModeRegs,
-
-        eax, ebx, ecx, edx, esi, edi, ebp, esp,
-
-
-        rax, rbx, rcx, rdx, rsi, rdi, rbp, rsp,
-        r8,  r9,  r10, r11, r12, r13, r14, r15,
-        lastint,
-        xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7,
-        xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15,
-        xmm,
-        firstxmm, lastxmm,
-
-        ripRel,
-        allFPArgRegs,
-
-        allocatableRegs
-)
-
-where
-
-import GHC.Prelude
-import GHC.Data.FastString
-
-import GHC.Platform.Regs
-import GHC.Platform.Reg
-import GHC.Platform.Reg.Class
-
-import GHC.Cmm
-import GHC.Cmm.CLabel           ( CLabel )
-import GHC.Utils.Panic
-import GHC.Platform
-
-import qualified Data.Array as A
-
--- | regSqueeze_class reg
---      Calculate the maximum number of register colors that could be
---      denied to a node of this class due to having this reg
---      as a neighbour.
---
-{-# INLINE virtualRegSqueeze #-}
-virtualRegSqueeze :: RegClass -> VirtualReg -> Int
-
-virtualRegSqueeze cls vr
- = case cls of
-        RcInteger
-         -> case vr of
-                VirtualRegI{}           -> 1
-                VirtualRegHi{}          -> 1
-                _other                  -> 0
-
-        RcDouble
-         -> case vr of
-                VirtualRegD{}           -> 1
-                VirtualRegF{}           -> 0
-                _other                  -> 0
-
-
-        _other -> 0
-
-{-# INLINE realRegSqueeze #-}
-realRegSqueeze :: RegClass -> RealReg -> Int
-realRegSqueeze cls rr
- = case cls of
-        RcInteger
-         -> case rr of
-                RealRegSingle regNo
-                        | regNo < firstxmm -> 1
-                        | otherwise     -> 0
-
-        RcDouble
-         -> case rr of
-                RealRegSingle regNo
-                        | regNo >= firstxmm  -> 1
-                        | otherwise     -> 0
-
-        _other -> 0
-
--- -----------------------------------------------------------------------------
--- Immediates
-
-data Imm
-  = ImmInt      Int
-  | ImmInteger  Integer     -- Sigh.
-  | ImmCLbl     CLabel      -- AbstractC Label (with baggage)
-  | ImmLit      FastString
-  | ImmIndex    CLabel Int
-  | ImmFloat    Rational
-  | ImmDouble   Rational
-  | ImmConstantSum Imm Imm
-  | ImmConstantDiff Imm Imm
-
-strImmLit :: FastString -> Imm
-strImmLit s = ImmLit s
-
-
-litToImm :: CmmLit -> Imm
-litToImm (CmmInt i w)        = ImmInteger (narrowS w i)
-                -- narrow to the width: a CmmInt might be out of
-                -- range, but we assume that ImmInteger only contains
-                -- in-range values.  A signed value should be fine here.
-litToImm (CmmFloat f W32)    = ImmFloat f
-litToImm (CmmFloat f W64)    = ImmDouble f
-litToImm (CmmLabel l)        = ImmCLbl l
-litToImm (CmmLabelOff l off) = ImmIndex l off
-litToImm (CmmLabelDiffOff l1 l2 off _)
-                             = ImmConstantSum
-                               (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
-                               (ImmInt off)
-litToImm _                   = panic "X86.Regs.litToImm: no match"
-
--- addressing modes ------------------------------------------------------------
-
-data AddrMode
-        = AddrBaseIndex EABase EAIndex Displacement
-        | ImmAddr Imm Int
-
-data EABase       = EABaseNone  | EABaseReg Reg | EABaseRip
-data EAIndex      = EAIndexNone | EAIndex Reg Int
-type Displacement = Imm
-
-
-addrOffset :: AddrMode -> Int -> Maybe AddrMode
-addrOffset addr off
-  = case addr of
-      ImmAddr i off0      -> Just (ImmAddr i (off0 + off))
-
-      AddrBaseIndex r i (ImmInt n) -> Just (AddrBaseIndex r i (ImmInt (n + off)))
-      AddrBaseIndex r i (ImmInteger n)
-        -> Just (AddrBaseIndex r i (ImmInt (fromInteger (n + toInteger off))))
-
-      AddrBaseIndex r i (ImmCLbl lbl)
-        -> Just (AddrBaseIndex r i (ImmIndex lbl off))
-
-      AddrBaseIndex r i (ImmIndex lbl ix)
-        -> Just (AddrBaseIndex r i (ImmIndex lbl (ix+off)))
-
-      _ -> Nothing  -- in theory, shouldn't happen
-
-
-addrModeRegs :: AddrMode -> [Reg]
-addrModeRegs (AddrBaseIndex b i _) =  b_regs ++ i_regs
-  where
-   b_regs = case b of { EABaseReg r -> [r]; _ -> [] }
-   i_regs = case i of { EAIndex r _ -> [r]; _ -> [] }
-addrModeRegs _ = []
-
-
--- registers -------------------------------------------------------------------
-
--- @spRel@ gives us a stack relative addressing mode for volatile
--- temporaries and for excess call arguments.  @fpRel@, where
--- applicable, is the same but for the frame pointer.
-
-
-spRel :: Platform
-      -> Int -- ^ desired stack offset in bytes, positive or negative
-      -> AddrMode
-spRel platform n
- | target32Bit platform
-    = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt n)
- | otherwise
-    = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt n)
-
--- The register numbers must fit into 32 bits on x86, so that we can
--- use a Word32 to represent the set of free registers in the register
--- allocator.
-
-
-
-firstxmm :: RegNo
-firstxmm  = 16
-
---  on 32bit platformOSs, only the first 8 XMM/YMM/ZMM registers are available
-lastxmm :: Platform -> RegNo
-lastxmm platform
- | target32Bit platform = firstxmm + 7  -- xmm0 - xmmm7
- | otherwise            = firstxmm + 15 -- xmm0 -xmm15
-
-lastint :: Platform -> RegNo
-lastint platform
- | target32Bit platform = 7 -- not %r8..%r15
- | otherwise            = 15
-
-intregnos :: Platform -> [RegNo]
-intregnos platform = [0 .. lastint platform]
-
-
-
-xmmregnos :: Platform -> [RegNo]
-xmmregnos platform = [firstxmm  .. lastxmm platform]
-
-floatregnos :: Platform -> [RegNo]
-floatregnos platform = xmmregnos platform
-
--- argRegs is the set of regs which are read for an n-argument call to C.
--- For archs which pass all args on the stack (x86), is empty.
--- Sparc passes up to the first 6 args in regs.
-argRegs :: RegNo -> [Reg]
-argRegs _       = panic "MachRegs.argRegs(x86): should not be used!"
-
--- | The complete set of machine registers.
-allMachRegNos :: Platform -> [RegNo]
-allMachRegNos platform = intregnos platform ++ floatregnos platform
-
--- | Take the class of a register.
-{-# INLINE classOfRealReg #-}
-classOfRealReg :: Platform -> RealReg -> RegClass
--- On x86, we might want to have an 8-bit RegClass, which would
--- contain just regs 1-4 (the others don't have 8-bit versions).
--- However, we can get away without this at the moment because the
--- only allocatable integer regs are also 8-bit compatible (1, 3, 4).
-classOfRealReg platform reg
-    = case reg of
-        RealRegSingle i
-            | i <= lastint platform -> RcInteger
-            | i <= lastxmm platform -> RcDouble
-            | otherwise             -> panic "X86.Reg.classOfRealReg registerSingle too high"
-
--- | Get the name of the register with this number.
--- NOTE: fixme, we dont track which "way" the XMM registers are used
-showReg :: Platform -> RegNo -> String
-showReg platform n
-        | n >= firstxmm && n <= lastxmm  platform = "%xmm" ++ show (n-firstxmm)
-        | n >= 8   && n < firstxmm      = "%r" ++ show n
-        | otherwise      = regNames platform A.! n
-
-regNames :: Platform -> A.Array Int String
-regNames platform
-    = if target32Bit platform
-      then A.listArray (0,8) ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp"]
-      else A.listArray (0,8) ["%rax", "%rbx", "%rcx", "%rdx", "%rsi", "%rdi", "%rbp", "%rsp"]
-
-
-
--- machine specific ------------------------------------------------------------
-
-
-{-
-Intel x86 architecture:
-- All registers except 7 (esp) are available for use.
-- Only ebx, esi, edi and esp are available across a C call (they are callee-saves).
-- Registers 0-7 have 16-bit counterparts (ax, bx etc.)
-- Registers 0-3 have 8 bit counterparts (ah, bh etc.)
-
-The fp registers are all Double registers; we don't have any RcFloat class
-regs.  @regClass@ barfs if you give it a VirtualRegF, and mkVReg above should
-never generate them.
-
-TODO: cleanup modelling float vs double registers and how they are the same class.
--}
-
-
-eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg
-
-eax   = regSingle 0
-ebx   = regSingle 1
-ecx   = regSingle 2
-edx   = regSingle 3
-esi   = regSingle 4
-edi   = regSingle 5
-ebp   = regSingle 6
-esp   = regSingle 7
-
-
-
-
-{-
-AMD x86_64 architecture:
-- All 16 integer registers are addressable as 8, 16, 32 and 64-bit values:
-
-  8     16    32    64
-  ---------------------
-  al    ax    eax   rax
-  bl    bx    ebx   rbx
-  cl    cx    ecx   rcx
-  dl    dx    edx   rdx
-  sil   si    esi   rsi
-  dil   si    edi   rdi
-  bpl   bp    ebp   rbp
-  spl   sp    esp   rsp
-  r10b  r10w  r10d  r10
-  r11b  r11w  r11d  r11
-  r12b  r12w  r12d  r12
-  r13b  r13w  r13d  r13
-  r14b  r14w  r14d  r14
-  r15b  r15w  r15d  r15
--}
-
-rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi,
-  r8, r9, r10, r11, r12, r13, r14, r15,
-  xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7,
-  xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15 :: Reg
-
-rax   = regSingle 0
-rbx   = regSingle 1
-rcx   = regSingle 2
-rdx   = regSingle 3
-rsi   = regSingle 4
-rdi   = regSingle 5
-rbp   = regSingle 6
-rsp   = regSingle 7
-r8    = regSingle 8
-r9    = regSingle 9
-r10   = regSingle 10
-r11   = regSingle 11
-r12   = regSingle 12
-r13   = regSingle 13
-r14   = regSingle 14
-r15   = regSingle 15
-xmm0  = regSingle 16
-xmm1  = regSingle 17
-xmm2  = regSingle 18
-xmm3  = regSingle 19
-xmm4  = regSingle 20
-xmm5  = regSingle 21
-xmm6  = regSingle 22
-xmm7  = regSingle 23
-xmm8  = regSingle 24
-xmm9  = regSingle 25
-xmm10 = regSingle 26
-xmm11 = regSingle 27
-xmm12 = regSingle 28
-xmm13 = regSingle 29
-xmm14 = regSingle 30
-xmm15 = regSingle 31
-
-ripRel :: Displacement -> AddrMode
-ripRel imm      = AddrBaseIndex EABaseRip EAIndexNone imm
-
-
- -- so we can re-use some x86 code:
-{-
-eax = rax
-ebx = rbx
-ecx = rcx
-edx = rdx
-esi = rsi
-edi = rdi
-ebp = rbp
-esp = rsp
--}
-
-xmm :: RegNo -> Reg
-xmm n = regSingle (firstxmm+n)
-
-
-
-
--- | these are the regs which we cannot assume stay alive over a C call.
-callClobberedRegs       :: Platform -> [Reg]
--- caller-saves registers
-callClobberedRegs platform
- | target32Bit platform = [eax,ecx,edx] ++ map regSingle (floatregnos platform)
- | platformOS platform == OSMinGW32
-   = [rax,rcx,rdx,r8,r9,r10,r11]
-   -- Only xmm0-5 are caller-saves registers on 64-bit windows.
-   -- For details check the Win64 ABI:
-   -- https://docs.microsoft.com/en-us/cpp/build/x64-software-conventions
-   ++ map xmm [0  .. 5]
- | otherwise
-    -- all xmm regs are caller-saves
-    -- caller-saves registers
-    = [rax,rcx,rdx,rsi,rdi,r8,r9,r10,r11]
-   ++ map regSingle (floatregnos platform)
-
-allArgRegs :: Platform -> [(Reg, Reg)]
-allArgRegs platform
- | platformOS platform == OSMinGW32 = zip [rcx,rdx,r8,r9]
-                                          (map regSingle [firstxmm ..])
- | otherwise = panic "X86.Regs.allArgRegs: not defined for this arch"
-
-allIntArgRegs :: Platform -> [Reg]
-allIntArgRegs platform
- | (platformOS platform == OSMinGW32) || target32Bit platform
-    = panic "X86.Regs.allIntArgRegs: not defined for this platform"
- | otherwise = [rdi,rsi,rdx,rcx,r8,r9]
-
-
--- | on 64bit platforms we pass the first 8 float/double arguments
--- in the xmm registers.
-allFPArgRegs :: Platform -> [Reg]
-allFPArgRegs platform
- | platformOS platform == OSMinGW32
-    = panic "X86.Regs.allFPArgRegs: not defined for this platform"
- | otherwise = map regSingle [firstxmm .. firstxmm + 7 ]
-
-
--- Machine registers which might be clobbered by instructions that
--- generate results into fixed registers, or need arguments in a fixed
--- register.
-instrClobberedRegs :: Platform -> [Reg]
-instrClobberedRegs platform
- | target32Bit platform = [ eax, ecx, edx ]
- | otherwise            = [ rax, rcx, rdx ]
-
---
-
--- allocatableRegs is allMachRegNos with the fixed-use regs removed.
--- i.e., these are the regs for which we are prepared to allow the
--- register allocator to attempt to map VRegs to.
-allocatableRegs :: Platform -> [RealReg]
-allocatableRegs platform
-   = let isFree i = freeReg platform i
-     in  map RealRegSingle $ filter isFree (allMachRegNos platform)
-
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToC.hs
+++ /dev/null
@@ -1,1502 +0,0 @@
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DerivingVia   #-}
-{-# LANGUAGE GADTs         #-}
-{-# LANGUAGE LambdaCase    #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE ViewPatterns #-}
-
------------------------------------------------------------------------------
---
--- Pretty-printing of Cmm as C, suitable for feeding gcc
---
--- (c) The University of Glasgow 2004-2006
---
--- Print Cmm as real C, for -fvia-C
---
--- See wiki:commentary/compiler/backends/ppr-c
---
--- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"
--- relative to the old AbstractC, and many oddities/decorations have
--- disappeared from the data type.
---
--- This code generator is only supported in unregisterised mode.
---
------------------------------------------------------------------------------
-
-module GHC.CmmToC
-   ( cmmToC
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Platform
-
-import GHC.CmmToAsm.CPrim
-
-import GHC.Cmm.BlockId
-import GHC.Cmm.CLabel
-import GHC.Cmm hiding (pprBBlock, pprStatic)
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Utils
-import GHC.Cmm.Switch
-import GHC.Cmm.InitFini
-
-import GHC.Types.ForeignCall
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.FM
-import GHC.Types.Unique
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Monad.State.Strict (State (..), runState, state)
-import GHC.Utils.Misc
-
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
-import Data.Char
-import Data.List (intersperse)
-import Data.List.NonEmpty (NonEmpty (..))
-import Data.Map (Map)
-import qualified Data.Map as Map
-import GHC.Float
-
--- --------------------------------------------------------------------------
--- Now do some real work
---
--- for fun, we could call cmmToCmm over the tops...
---
-
-cmmToC :: Platform -> RawCmmGroup -> SDoc
-cmmToC platform tops = (vcat $ intersperse blankLine $ map (pprTop platform) tops) $$ blankLine
-
---
--- top level procs
---
-pprTop :: Platform -> RawCmmDecl -> SDoc
-pprTop platform = \case
-  (CmmProc infos clbl _in_live_regs graph) ->
-    (case mapLookup (g_entry graph) infos of
-       Nothing -> empty
-       Just (CmmStaticsRaw info_clbl info_dat) ->
-           pprDataExterns platform info_dat $$
-           pprWordArray platform info_is_in_rodata info_clbl info_dat) $$
-    (vcat [
-           blankLine,
-           extern_decls,
-           (if (externallyVisibleCLabel clbl)
-                    then mkFN_ else mkIF_) (pprCLabel platform clbl) <+> lbrace,
-           nest 8 temp_decls,
-           vcat (map (pprBBlock platform) blocks),
-           rbrace ]
-    )
-    where
-        -- info tables are always in .rodata
-        info_is_in_rodata = True
-        blocks = toBlockListEntryFirst graph
-        (temp_decls, extern_decls) = pprTempAndExternDecls platform blocks
-
-
-  -- Chunks of static data.
-
-  -- We only handle (a) arrays of word-sized things and (b) strings.
-
-  cmm_data | Just (initOrFini, clbls) <- isInitOrFiniArray cmm_data ->
-    pprCtorArray platform initOrFini clbls
-
-  (CmmData section (CmmStaticsRaw lbl [CmmString str])) ->
-    pprExternDecl platform lbl $$
-    hcat [
-      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform lbl,
-      text "[] = ", pprStringInCStyle str, semi
-    ]
-
-  (CmmData section (CmmStaticsRaw lbl [CmmUninitialised size])) ->
-    pprExternDecl platform lbl $$
-    hcat [
-      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform lbl,
-      brackets (int size), semi
-    ]
-
-  (CmmData section (CmmStaticsRaw lbl lits)) ->
-    pprDataExterns platform lits $$
-    pprWordArray platform (isSecConstant section) lbl lits
-  where
-    isSecConstant section = case sectionProtection section of
-      ReadOnlySection -> True
-      WriteProtectedSection -> True
-      _ -> False
-
--- --------------------------------------------------------------------------
--- BasicBlocks are self-contained entities: they always end in a jump.
---
--- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn
--- as many jumps as possible into fallthroughs.
---
-
-pprBBlock :: Platform -> CmmBlock -> SDoc
-pprBBlock platform block =
-  nest 4 (pprBlockId (entryLabel block) <> colon) $$
-  nest 8 (vcat (map (pprStmt platform) (blockToList nodes)) $$ pprStmt platform last)
- where
-  (_, nodes, last)  = blockSplit block
-
--- --------------------------------------------------------------------------
--- Info tables. Just arrays of words.
--- See codeGen/ClosureInfo, and nativeGen/PprMach
-
-pprWordArray :: Platform -> Bool -> CLabel -> [CmmStatic] -> SDoc
-pprWordArray platform is_ro lbl ds
-  = -- TODO: align closures only
-    pprExternDecl platform lbl $$
-    hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"
-         , space, pprCLabel platform lbl, text "[]"
-         -- See Note [StgWord alignment]
-         , pprAlignment (wordWidth platform)
-         , text "= {" ]
-    $$ nest 8 (commafy (staticLitsToWords platform $ toLits ds))
-    $$ text "};"
-  where
-    toLits :: [CmmStatic] -> [CmmLit]
-    toLits = map f
-      where
-        f (CmmStaticLit lit) = lit
-        f static             = pprPanic "pprWordArray: Unexpected literal"  (pprStatic platform static)
-
-pprAlignment :: Width -> SDoc
-pprAlignment words =
-     text "__attribute__((aligned(" <> int (widthInBytes words) <> text ")))"
-
--- Note [StgWord alignment]
--- ~~~~~~~~~~~~~~~~~~~~~~~~
--- C codegen builds static closures as StgWord C arrays (pprWordArray).
--- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume
--- pointers to 'StgClosure' are aligned at pointer size boundary:
---  4 byte boundary on 32 systems
---  and 8 bytes on 64-bit systems
--- see TAG_MASK and TAG_BITS definition and usage.
---
--- It's a reasonable assumption also known as natural alignment.
--- Although some architectures have different alignment rules.
--- One of known exceptions is m68k (#11395, comment:16) where:
---   __alignof__(StgWord) == 2, sizeof(StgWord) == 4
---
--- Thus we explicitly increase alignment by using
---    __attribute__((aligned(4)))
--- declaration.
-
---
--- has to be static, if it isn't globally visible
---
-pprLocalness :: CLabel -> SDoc
-pprLocalness lbl | not $ externallyVisibleCLabel lbl = text "static "
-                 | otherwise = empty
-
-pprConstness :: Bool -> SDoc
-pprConstness is_ro | is_ro = text "const "
-                   | otherwise = empty
-
--- --------------------------------------------------------------------------
--- Statements.
---
-
-pprStmt :: Platform -> CmmNode e x -> SDoc
-pprStmt platform stmt =
-    case stmt of
-    CmmEntry{}   -> empty
-    CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ text "*/"
-                          -- XXX if the string contains "*/", we need to fix it
-                          -- XXX we probably want to emit these comments when
-                          -- some debugging option is on.  They can get quite
-                          -- large.
-
-    CmmTick _ -> empty
-    CmmUnwind{} -> empty
-
-    CmmAssign dest src -> pprAssign platform dest src
-
-    CmmStore  dest src align
-        | typeWidth rep == W64 && wordWidth platform /= W64
-        -> (if isFloatType rep then text "ASSIGN_DBL"
-                               else text "ASSIGN_Word64") <>
-           parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi
-
-        | otherwise
-        -> hsep [ pprExpr platform (CmmLoad dest rep align), equals, pprExpr platform src <> semi ]
-        where
-          rep = cmmExprType platform src
-
-    CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->
-        fnCall
-        where
-        (res_hints, arg_hints) = foreignTargetHints target
-        hresults = zip results res_hints
-        hargs    = zip args arg_hints
-
-        ForeignConvention cconv _ _ ret = conv
-
-        cast_fn = parens (cCast platform (pprCFunType platform (char '*') cconv hresults hargs) fn)
-
-        -- See wiki:commentary/compiler/backends/ppr-c#prototypes
-        fnCall =
-            case fn of
-              CmmLit (CmmLabel lbl)
-                | StdCallConv <- cconv ->
-                    pprCall platform (pprCLabel platform lbl) cconv hresults hargs
-                        -- stdcall functions must be declared with
-                        -- a function type, otherwise the C compiler
-                        -- doesn't add the @n suffix to the label.  We
-                        -- can't add the @n suffix ourselves, because
-                        -- it isn't valid C.
-                | CmmNeverReturns <- ret ->
-                    pprCall platform cast_fn cconv hresults hargs <> semi <> text "__builtin_unreachable();"
-                | not (isMathFun lbl) ->
-                    pprForeignCall platform (pprCLabel platform lbl) cconv hresults hargs
-              _ ->
-                    pprCall platform cast_fn cconv hresults hargs <> semi
-                        -- for a dynamic call, no declaration is necessary.
-
-    CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty
-    CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _)) _results _args -> empty
-
-    CmmUnsafeForeignCall target@(PrimTarget op) results args ->
-        fn_call
-      where
-        cconv = CCallConv
-        fn = pprCallishMachOp_for_C op
-
-        (res_hints, arg_hints) = foreignTargetHints target
-        hresults = zip results res_hints
-        hargs    = zip args arg_hints
-
-        need_cdecl
-          | MO_ResumeThread  <- op                 = True
-          | MO_SuspendThread <- op                 = True
-          | otherwise                              = False
-
-        fn_call
-          -- The mem primops carry an extra alignment arg.
-          -- We could maybe emit an alignment directive using this info.
-          -- We also need to cast mem primops to prevent conflicts with GCC
-          -- builtins (see bug #5967).
-          | need_cdecl
-          = (text ";EFF_(" <> fn <> char ')' <> semi) $$
-            pprForeignCall platform fn cconv hresults hargs
-          | otherwise
-          = pprCall platform fn cconv hresults hargs
-
-    CmmBranch ident               -> pprBranch ident
-    CmmCondBranch expr yes no _   -> pprCondBranch platform expr yes no
-    CmmCall { cml_target = expr } -> mkJMP_ (pprExpr platform expr) <> semi
-    CmmSwitch arg ids             -> pprSwitch platform arg ids
-
-    _other -> pprPanic "PprC.pprStmt" (pdoc platform stmt)
-
-type Hinted a = (a, ForeignHint)
-
-pprForeignCall :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]
-               -> SDoc
-pprForeignCall platform fn cconv results args = fn_call
-  where
-    fn_call = braces (
-                 pprCFunType platform (char '*' <> text "ghcFunPtr") cconv results args <> semi
-              $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
-              $$ pprCall platform (text "ghcFunPtr") cconv results args <> semi
-             )
-    cast_fn = parens (parens (pprCFunType platform (char '*') cconv results args) <> fn)
-
-pprCFunType :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
-pprCFunType platform ppr_fn cconv ress args
-  = let res_type [] = text "void"
-        res_type [(one, hint)] = machRepHintCType platform (localRegType one) hint
-        res_type _ = panic "pprCFunType: only void or 1 return value supported"
-
-        arg_type (expr, hint) = machRepHintCType platform (cmmExprType platform expr) hint
-    in res_type ress <+>
-       parens (ccallConvAttribute cconv <> ppr_fn) <>
-       parens (commafy (map arg_type args))
-
--- ---------------------------------------------------------------------
--- unconditional branches
-pprBranch :: BlockId -> SDoc
-pprBranch ident = text "goto" <+> pprBlockId ident <> semi
-
-
--- ---------------------------------------------------------------------
--- conditional branches to local labels
-pprCondBranch :: Platform -> CmmExpr -> BlockId -> BlockId -> SDoc
-pprCondBranch platform expr yes no
-        = hsep [ text "if" , parens (pprExpr platform expr) ,
-                        text "goto", pprBlockId yes <> semi,
-                        text "else goto", pprBlockId no <> semi ]
-
--- ---------------------------------------------------------------------
--- a local table branch
---
--- we find the fall-through cases
---
-pprSwitch :: Platform -> CmmExpr -> SwitchTargets -> SDoc
-pprSwitch platform e ids
-  = (hang (text "switch" <+> parens ( pprExpr platform e ) <+> lbrace)
-                4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace
-  where
-    (pairs, mbdef) = switchTargetsFallThrough ids
-
-    rep = typeWidth (cmmExprType platform e)
-
-    -- fall through case
-    caseify (ix:|ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
-        where
-        do_fallthrough ix =
-                 hsep [ text "case" , pprHexVal platform ix rep <> colon ,
-                        text "/* fall through */" ]
-
-        final_branch ix =
-                hsep [ text "case" , pprHexVal platform ix rep <> colon ,
-                       text "goto" , (pprBlockId ident) <> semi ]
-
-    def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi
-        | otherwise       = text "default: __builtin_unreachable();"
-
--- ---------------------------------------------------------------------
--- Expressions.
---
-
--- C Types: the invariant is that the C expression generated by
---
---      pprExpr e
---
--- has a type in C which is also given by
---
---      machRepCType (cmmExprType e)
---
--- (similar invariants apply to the rest of the pretty printer).
-
-pprExpr :: Platform -> CmmExpr -> SDoc
-pprExpr platform e = case e of
-    CmmLit lit         -> pprLit platform lit
-    CmmLoad e ty align -> pprLoad platform e ty align
-    CmmReg reg         -> pprCastReg reg
-    CmmRegOff reg 0    -> pprCastReg reg
-
-    -- CmmRegOff is an alias of MO_Add
-    CmmRegOff reg i -> pprCastReg reg <> char '+' <>
-                       pprHexVal platform (fromIntegral i) (wordWidth platform)
-
-    CmmMachOp mop args -> pprMachOpApp platform mop args
-
-    CmmStackSlot _ _   -> panic "pprExpr: CmmStackSlot not supported!"
-
-
-pprLoad :: Platform -> CmmExpr -> CmmType -> AlignmentSpec -> SDoc
-pprLoad platform e ty _align
-  | width == W64, wordWidth platform /= W64
-  = (if isFloatType ty then text "PK_DBL"
-                       else text "PK_Word64")
-    <> parens (mkP_ <> pprExpr1 platform e)
-
-  -- TODO: exploit natural-alignment where possible
-  | otherwise
-  = case e of
-        CmmReg r | isPtrReg r && width == wordWidth platform && not (isFloatType ty)
-                 -> char '*' <> pprAsPtrReg r
-
-        CmmRegOff r 0 | isPtrReg r && width == wordWidth platform && not (isFloatType ty)
-                      -> char '*' <> pprAsPtrReg r
-
-        CmmRegOff r off | isPtrReg r && width == wordWidth platform
-                        , off `rem` platformWordSizeInBytes platform == 0 && not (isFloatType ty)
-        -- ToDo: check that the offset is a word multiple?
-        --       (For tagging to work, I had to avoid unaligned loads. --ARY)
-                        -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift platform))
-
-        _other -> cLoad platform e ty
-  where
-    width = typeWidth ty
-
-pprExpr1 :: Platform -> CmmExpr -> SDoc
-pprExpr1 platform e = case e of
-   CmmLit lit  -> pprLit1 platform lit
-   CmmReg _reg -> pprExpr platform e
-   _           -> parens (pprExpr platform e)
-
--- --------------------------------------------------------------------------
--- MachOp applications
-
-pprMachOpApp :: Platform -> MachOp -> [CmmExpr] -> SDoc
-
-pprMachOpApp platform op args
-  | isMulMayOfloOp op
-  = text "mulIntMayOflo" <> parens (commafy (map (pprExpr platform) args))
-  where isMulMayOfloOp (MO_S_MulMayOflo _) = True
-        isMulMayOfloOp _ = False
-
-pprMachOpApp platform mop args
-  | Just ty <- machOpNeedsCast platform mop (map (cmmExprType platform) args)
-  = ty <> parens (pprMachOpApp' platform mop args)
-  | otherwise
-  = pprMachOpApp' platform mop args
-
-{-
-Note [Zero-extending sub-word signed results]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider a program like (from #20634):
-
-    test() {
-        bits64 ret;
-        bits8 a,b;
-        a = 0xe1 :: bits8;       // == -31 signed
-        b = %quot(a, 3::bits8);  // == -10 signed
-        ret = %zx64(a);          // == 0xf6 unsigned
-        return (ret);
-    }
-
-This program should return 0xf6 == 246. However, we need to be very careful
-with when dealing with the result of the %quot. For instance, one might be
-tempted produce code like:
-
-    StgWord8 a = 0xe1U;
-    StgInt8  b = (StgInt8) a / (StgInt8) 0x3U;
-    StgWord ret = (W_) b;
-
-However, this would be wrong; by widening `b` directly from `StgInt8` to
-`StgWord` we will get sign-extension semantics: rather than 0xf6 we will get
-0xfffffffffffffff6. To avoid this we must first cast `b` back to `StgWord8`,
-ensuring that we get zero-extension semantics when we widen up to `StgWord`.
-
-Note [When in doubt, cast arguments as unsigned]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In general C's signed-ness behavior can lead to surprising results and
-consequently we are very explicit about ensuring that arguments have the
-correct signedness. For instance, consider a program like
-
-    test() {
-        bits64 ret, a, b;
-        a = %neg(43 :: bits64);
-        b = %neg(0x443c70fa3e465120 :: bits64);
-        ret = %modu(a, b);
-        return (ret);
-    }
-
-In this case both `a` and `b` will be StgInts in the generated C (since
-`MO_Neg` is a signed operation). However, we want to ensure that we perform an
-*unsigned* modulus operation, therefore we must be careful to cast both arguments
-to StgWord. We do this for any operation where the signedness of the argument
-may affect the operation's semantics.
--}
-
--- | The result type of most operations is determined by the operands. However,
--- there are a few exceptions: particularly operations which might get promoted
--- to a signed result. For these we explicitly cast the result.
-machOpNeedsCast :: Platform -> MachOp -> [CmmType] -> Maybe SDoc
-machOpNeedsCast platform mop args
-    -- Comparisons in C have type 'int', but we want type W_ (this is what
-    -- resultRepOfMachOp says).
-  | isComparisonMachOp mop = Just mkW_
-
-    -- See Note [Zero-extending sub-word signed results]
-  | signedOp mop
-  , res_ty <- machOpResultType platform mop args
-  , not $ isFloatType res_ty -- only integer operations, not MO_SF_Conv
-  , let w = typeWidth res_ty
-  , w < wordWidth platform
-  = cast_it w
-
-    -- A shift operation like (a >> b) where a::Word8 and b::Word has type Word
-    -- in C yet we want a Word8
-  | Just w <- shiftOp mop  = cast_it w
-
-    -- The results of these operations may be promoted to signed values
-    -- due to C11 section 6.3.1.1.
-  | MO_Add w <- mop        = cast_it w
-  | MO_Sub w <- mop        = cast_it w
-  | MO_Mul w <- mop        = cast_it w
-  | MO_U_Quot w <- mop     = cast_it w
-  | MO_U_Rem  w <- mop     = cast_it w
-  | MO_And w <- mop        = cast_it w
-  | MO_Or  w <- mop        = cast_it w
-  | MO_Xor w <- mop        = cast_it w
-  | MO_Not w <- mop        = cast_it w
-
-  | otherwise              = Nothing
-  where
-    cast_it w =
-      let ty = machRep_U_CType platform w
-      in Just $ parens ty
-
-pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc
-pprMachOpApp' platform mop args
- = case args of
-    -- dyadic
-    [x,y] -> pprArg x <+> pprMachOp_for_C platform mop <+> pprArg y
-
-    -- unary
-    [x]   -> pprMachOp_for_C platform mop <> parens (pprArg x)
-
-    _     -> panic "PprC.pprMachOp : machop with wrong number of args"
-
-  where
-    pprArg e
-      | needsFCasts mop = cCast platform (machRep_F_CType width) e
-        -- Cast needed for signed integer ops
-      | signedOp    mop = cCast platform (machRep_S_CType platform width) e
-        -- See Note [When in doubt, cast arguments as unsigned]
-      | needsUnsignedCast mop
-                        = cCast platform (machRep_U_CType platform width) e
-      | otherwise       = pprExpr1 platform e
-      where
-        width = typeWidth (cmmExprType platform e)
-
-    needsFCasts (MO_F_Neg _)  = True
-    needsFCasts (MO_F_Quot _) = True
-    needsFCasts mop  = floatComparison mop
-
-    -- See Note [When in doubt, cast arguments as unsigned]
-    needsUnsignedCast (MO_Mul    _) = True
-    needsUnsignedCast (MO_U_Shr  _) = True
-    needsUnsignedCast (MO_U_Quot _) = True
-    needsUnsignedCast (MO_U_Rem  _) = True
-    needsUnsignedCast (MO_U_Ge   _) = True
-    needsUnsignedCast (MO_U_Le   _) = True
-    needsUnsignedCast (MO_U_Gt   _) = True
-    needsUnsignedCast (MO_U_Lt   _) = True
-    needsUnsignedCast _             = False
-
--- --------------------------------------------------------------------------
--- Literals
-
-pprLit :: Platform -> CmmLit -> SDoc
-pprLit platform lit = case lit of
-    CmmInt i rep      -> pprHexVal platform i rep
-
-    CmmFloat f w       -> parens (machRep_F_CType w) <> str
-        where d = fromRational f :: Double
-              str | isInfinite d && d < 0 = text "-INFINITY"
-                  | isInfinite d          = text "INFINITY"
-                  | isNaN d               = text "NAN"
-                  | otherwise             = text (show d)
-                -- these constants come from <math.h>
-                -- see #1861
-
-    CmmVec {} -> panic "PprC printing vector literal"
-
-    CmmBlock bid       -> mkW_ <> pprCLabelAddr (infoTblLbl bid)
-    CmmHighStackMark   -> panic "PprC printing high stack mark"
-    CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl
-    CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
-    CmmLabelDiffOff clbl1 _ i _   -- non-word widths not supported via C
-        -- WARNING:
-        --  * the lit must occur in the info table clbl2
-        --  * clbl1 must be an SRT, a slow entry point or a large bitmap
-        -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
-
-    where
-        pprCLabelAddr lbl = char '&' <> pprCLabel platform lbl
-
-pprLit1 :: Platform -> CmmLit -> SDoc
-pprLit1 platform lit = case lit of
-   (CmmLabelOff _ _)         -> parens (pprLit platform lit)
-   (CmmLabelDiffOff _ _ _ _) -> parens (pprLit platform lit)
-   (CmmFloat _ _)            -> parens (pprLit platform lit)
-   _                         -> pprLit platform lit
-
--- ---------------------------------------------------------------------------
--- Static data
-
--- | Produce a list of word sized literals encoding the given list of 'CmmLit's.
-staticLitsToWords :: Platform -> [CmmLit] -> [SDoc]
-staticLitsToWords platform = go . foldMap decomposeMultiWord
-  where
-    -- rem_bytes is how many bytes remain in the word we are currently filling.
-    -- accum is the word we are filling.
-    go :: [CmmLit] -> [SDoc]
-    go [] = []
-    go lits@(lit : _)
-      | Just _ <- isSubWordLit lit
-      = goSubWord wordWidthBytes 0 lits
-    go (lit : rest)
-      = pprLit1 platform lit : go rest
-
-    goSubWord :: Int -> Integer -> [CmmLit] -> [SDoc]
-    goSubWord rem_bytes accum (lit : rest)
-      | Just (bytes, w) <- isSubWordLit lit
-      , rem_bytes >= widthInBytes w
-      = let accum' = (accum `shiftL` widthInBits w) .|. fixEndian w bytes
-        in goSubWord (rem_bytes - widthInBytes w) accum' rest
-    goSubWord rem_bytes accum rest
-      = pprWord (fixEndian (wordWidth platform) $ accum `shiftL` (8*rem_bytes)) : go rest
-
-    fixEndian :: Width -> Integer -> Integer
-    fixEndian w = case platformByteOrder platform of
-      BigEndian    -> id
-      LittleEndian -> byteSwap w
-
-    -- Decompose multi-word or floating-point literals into multiple
-    -- single-word (or smaller) literals.
-    decomposeMultiWord :: CmmLit -> [CmmLit]
-    decomposeMultiWord (CmmFloat n W64)
-      | W32 <- wordWidth platform = decomposeMultiWord (doubleToWord64 n)
-      | otherwise = [doubleToWord64 n]
-    decomposeMultiWord (CmmFloat n W32)
-      = [floatToWord32 n]
-    decomposeMultiWord (CmmInt n W64)
-      | W32 <- wordWidth platform
-      = case platformByteOrder platform of
-          BigEndian -> [CmmInt hi W32, CmmInt lo W32]
-          LittleEndian -> [CmmInt lo W32, CmmInt hi W32]
-      where
-        hi = n `shiftR` 32
-        lo = n .&. 0xffffffff
-    decomposeMultiWord lit = [lit]
-
-    -- Decompose a sub-word-sized literal into the integer value and its
-    -- (sub-word-sized) width.
-    isSubWordLit :: CmmLit -> Maybe (Integer, Width)
-    isSubWordLit lit =
-      case lit of
-        CmmInt n w
-          | w < wordWidth platform   -> Just (n, w)
-        _                            -> Nothing
-
-    wordWidthBytes = widthInBytes $ wordWidth platform
-
-    pprWord :: Integer -> SDoc
-    pprWord n = pprHexVal platform n (wordWidth platform)
-
-byteSwap :: Width -> Integer -> Integer
-byteSwap width n = foldl' f 0 bytes
-  where
-    f acc m = (acc `shiftL` 8) .|. m
-    bytes = [ byte i | i <- [0..widthInBytes width - 1] ]
-    byte i = (n `shiftR` (i*8)) .&. 0xff
-
-pprStatic :: Platform -> CmmStatic -> SDoc
-pprStatic platform s = case s of
-
-    CmmStaticLit lit   -> nest 4 (pprLit platform lit)
-    CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))
-
-    -- these should be inlined, like the old .hc
-    CmmString s'       -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))
-    CmmFileEmbed {}    -> panic "Unexpected CmmFileEmbed literal"
-
-
--- ---------------------------------------------------------------------------
--- Block Ids
-
-pprBlockId :: BlockId -> SDoc
-pprBlockId b = char '_' <> ppr (getUnique b)
-
--- --------------------------------------------------------------------------
--- Print a MachOp in a way suitable for emitting via C.
---
-
-pprMachOp_for_C :: Platform -> MachOp -> SDoc
-
-pprMachOp_for_C platform mop = case mop of
-
-        -- Integer operations
-        MO_Add          _ -> char '+'
-        MO_Sub          _ -> char '-'
-        MO_Eq           _ -> text "=="
-        MO_Ne           _ -> text "!="
-        MO_Mul          _ -> char '*'
-
-        MO_S_Quot       _ -> char '/'
-        MO_S_Rem        _ -> char '%'
-        MO_S_Neg        _ -> char '-'
-
-        MO_U_Quot       _ -> char '/'
-        MO_U_Rem        _ -> char '%'
-
-        -- & Floating-point operations
-        MO_F_Add        _ -> char '+'
-        MO_F_Sub        _ -> char '-'
-        MO_F_Neg        _ -> char '-'
-        MO_F_Mul        _ -> char '*'
-        MO_F_Quot       _ -> char '/'
-
-        -- Signed comparisons
-        MO_S_Ge         _ -> text ">="
-        MO_S_Le         _ -> text "<="
-        MO_S_Gt         _ -> char '>'
-        MO_S_Lt         _ -> char '<'
-
-        -- & Unsigned comparisons
-        MO_U_Ge         _ -> text ">="
-        MO_U_Le         _ -> text "<="
-        MO_U_Gt         _ -> char '>'
-        MO_U_Lt         _ -> char '<'
-
-        -- & Floating-point comparisons
-        MO_F_Eq         _ -> text "=="
-        MO_F_Ne         _ -> text "!="
-        MO_F_Ge         _ -> text ">="
-        MO_F_Le         _ -> text "<="
-        MO_F_Gt         _ -> char '>'
-        MO_F_Lt         _ -> char '<'
-
-        -- Bitwise operations.  Not all of these may be supported at all
-        -- sizes, and only integral MachReps are valid.
-        MO_And          _ -> char '&'
-        MO_Or           _ -> char '|'
-        MO_Xor          _ -> char '^'
-        MO_Not          _ -> char '~'
-        MO_Shl          _ -> text "<<"
-        MO_U_Shr        _ -> text ">>" -- unsigned shift right
-        MO_S_Shr        _ -> text ">>" -- signed shift right
-
--- Conversions.  Some of these will be NOPs, but never those that convert
--- between ints and floats.
--- Floating-point conversions use the signed variant.
--- We won't know to generate (void*) casts here, but maybe from
--- context elsewhere
-
--- noop casts
-        MO_UU_Conv from to | from == to -> empty
-        MO_UU_Conv _from to -> parens (machRep_U_CType platform to)
-
-        MO_SS_Conv from to | from == to -> empty
-        MO_SS_Conv _from to -> parens (machRep_S_CType platform to)
-
-        MO_XX_Conv from to | from == to -> empty
-        MO_XX_Conv _from to -> parens (machRep_U_CType platform to)
-
-        MO_FF_Conv from to | from == to -> empty
-        MO_FF_Conv _from to -> parens (machRep_F_CType to)
-
-        MO_SF_Conv _from to -> parens (machRep_F_CType to)
-        MO_FS_Conv _from to -> parens (machRep_S_CType platform to)
-
-        MO_S_MulMayOflo _ -> pprTrace "offending mop:"
-                                (text "MO_S_MulMayOflo")
-                                (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"
-                                      ++ " should have been handled earlier!")
-
-        MO_V_Insert {}    -> pprTrace "offending mop:"
-                                (text "MO_V_Insert")
-                                (panic $ "PprC.pprMachOp_for_C: MO_V_Insert"
-                                      ++ " should have been handled earlier!")
-        MO_V_Extract {}   -> pprTrace "offending mop:"
-                                (text "MO_V_Extract")
-                                (panic $ "PprC.pprMachOp_for_C: MO_V_Extract"
-                                      ++ " should have been handled earlier!")
-
-        MO_V_Add {}       -> pprTrace "offending mop:"
-                                (text "MO_V_Add")
-                                (panic $ "PprC.pprMachOp_for_C: MO_V_Add"
-                                      ++ " should have been handled earlier!")
-        MO_V_Sub {}       -> pprTrace "offending mop:"
-                                (text "MO_V_Sub")
-                                (panic $ "PprC.pprMachOp_for_C: MO_V_Sub"
-                                      ++ " should have been handled earlier!")
-        MO_V_Mul {}       -> pprTrace "offending mop:"
-                                (text "MO_V_Mul")
-                                (panic $ "PprC.pprMachOp_for_C: MO_V_Mul"
-                                      ++ " should have been handled earlier!")
-
-        MO_VS_Quot {}     -> pprTrace "offending mop:"
-                                (text "MO_VS_Quot")
-                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot"
-                                      ++ " should have been handled earlier!")
-        MO_VS_Rem {}      -> pprTrace "offending mop:"
-                                (text "MO_VS_Rem")
-                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem"
-                                      ++ " should have been handled earlier!")
-        MO_VS_Neg {}      -> pprTrace "offending mop:"
-                                (text "MO_VS_Neg")
-                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg"
-                                      ++ " should have been handled earlier!")
-
-        MO_VU_Quot {}     -> pprTrace "offending mop:"
-                                (text "MO_VU_Quot")
-                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot"
-                                      ++ " should have been handled earlier!")
-        MO_VU_Rem {}      -> pprTrace "offending mop:"
-                                (text "MO_VU_Rem")
-                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem"
-                                      ++ " should have been handled earlier!")
-
-        MO_VF_Insert {}   -> pprTrace "offending mop:"
-                                (text "MO_VF_Insert")
-                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert"
-                                      ++ " should have been handled earlier!")
-        MO_VF_Extract {}  -> pprTrace "offending mop:"
-                                (text "MO_VF_Extract")
-                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract"
-                                      ++ " should have been handled earlier!")
-
-        MO_VF_Add {}      -> pprTrace "offending mop:"
-                                (text "MO_VF_Add")
-                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Add"
-                                      ++ " should have been handled earlier!")
-        MO_VF_Sub {}      -> pprTrace "offending mop:"
-                                (text "MO_VF_Sub")
-                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub"
-                                      ++ " should have been handled earlier!")
-        MO_VF_Neg {}      -> pprTrace "offending mop:"
-                                (text "MO_VF_Neg")
-                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg"
-                                      ++ " should have been handled earlier!")
-        MO_VF_Mul {}      -> pprTrace "offending mop:"
-                                (text "MO_VF_Mul")
-                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul"
-                                      ++ " should have been handled earlier!")
-        MO_VF_Quot {}     -> pprTrace "offending mop:"
-                                (text "MO_VF_Quot")
-                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"
-                                      ++ " should have been handled earlier!")
-
-        MO_AlignmentCheck {} -> panic "-falignment-sanitisation not supported by unregisterised backend"
-
-signedOp :: MachOp -> Bool      -- Argument type(s) are signed ints
-signedOp (MO_S_Quot _)    = True
-signedOp (MO_S_Rem  _)    = True
-signedOp (MO_S_Neg  _)    = True
-signedOp (MO_S_Ge   _)    = True
-signedOp (MO_S_Le   _)    = True
-signedOp (MO_S_Gt   _)    = True
-signedOp (MO_S_Lt   _)    = True
-signedOp (MO_S_Shr  _)    = True
-signedOp (MO_SS_Conv _ _) = True
-signedOp (MO_SF_Conv _ _) = True
-signedOp _                = False
-
-shiftOp :: MachOp -> Maybe Width
-shiftOp (MO_Shl w)        = Just w
-shiftOp (MO_U_Shr w)      = Just w
-shiftOp (MO_S_Shr w)      = Just w
-shiftOp _                 = Nothing
-
-floatComparison :: MachOp -> Bool  -- comparison between float args
-floatComparison (MO_F_Eq   _) = True
-floatComparison (MO_F_Ne   _) = True
-floatComparison (MO_F_Ge   _) = True
-floatComparison (MO_F_Le   _) = True
-floatComparison (MO_F_Gt   _) = True
-floatComparison (MO_F_Lt   _) = True
-floatComparison _             = False
-
--- ---------------------------------------------------------------------
--- tend to be implemented by foreign calls
-
-pprCallishMachOp_for_C :: CallishMachOp -> SDoc
-
-pprCallishMachOp_for_C mop
-    = case mop of
-        MO_F64_Pwr      -> text "pow"
-        MO_F64_Sin      -> text "sin"
-        MO_F64_Cos      -> text "cos"
-        MO_F64_Tan      -> text "tan"
-        MO_F64_Sinh     -> text "sinh"
-        MO_F64_Cosh     -> text "cosh"
-        MO_F64_Tanh     -> text "tanh"
-        MO_F64_Asin     -> text "asin"
-        MO_F64_Acos     -> text "acos"
-        MO_F64_Atanh    -> text "atanh"
-        MO_F64_Asinh    -> text "asinh"
-        MO_F64_Acosh    -> text "acosh"
-        MO_F64_Atan     -> text "atan"
-        MO_F64_Log      -> text "log"
-        MO_F64_Log1P    -> text "log1p"
-        MO_F64_Exp      -> text "exp"
-        MO_F64_ExpM1    -> text "expm1"
-        MO_F64_Sqrt     -> text "sqrt"
-        MO_F64_Fabs     -> text "fabs"
-        MO_F32_Pwr      -> text "powf"
-        MO_F32_Sin      -> text "sinf"
-        MO_F32_Cos      -> text "cosf"
-        MO_F32_Tan      -> text "tanf"
-        MO_F32_Sinh     -> text "sinhf"
-        MO_F32_Cosh     -> text "coshf"
-        MO_F32_Tanh     -> text "tanhf"
-        MO_F32_Asin     -> text "asinf"
-        MO_F32_Acos     -> text "acosf"
-        MO_F32_Atan     -> text "atanf"
-        MO_F32_Asinh    -> text "asinhf"
-        MO_F32_Acosh    -> text "acoshf"
-        MO_F32_Atanh    -> text "atanhf"
-        MO_F32_Log      -> text "logf"
-        MO_F32_Log1P    -> text "log1pf"
-        MO_F32_Exp      -> text "expf"
-        MO_F32_ExpM1    -> text "expm1f"
-        MO_F32_Sqrt     -> text "sqrtf"
-        MO_F32_Fabs     -> text "fabsf"
-        MO_ReadBarrier  -> text "load_load_barrier"
-        MO_WriteBarrier -> text "write_barrier"
-        MO_Memcpy _     -> text "__builtin_memcpy"
-        MO_Memset _     -> text "__builtin_memset"
-        MO_Memmove _    -> text "__builtin_memmove"
-        MO_Memcmp _     -> text "__builtin_memcmp"
-
-        MO_SuspendThread -> text "suspendThread"
-        MO_ResumeThread  -> text "resumeThread"
-
-        MO_BSwap w          -> ftext (bSwapLabel w)
-        MO_BRev w           -> ftext (bRevLabel w)
-        MO_PopCnt w         -> ftext (popCntLabel w)
-        MO_Pext w           -> ftext (pextLabel w)
-        MO_Pdep w           -> ftext (pdepLabel w)
-        MO_Clz w            -> ftext (clzLabel w)
-        MO_Ctz w            -> ftext (ctzLabel w)
-        MO_AtomicRMW w amop -> ftext (atomicRMWLabel w amop)
-        MO_Cmpxchg w        -> ftext (cmpxchgLabel w)
-        MO_Xchg w           -> ftext (xchgLabel w)
-        MO_AtomicRead w     -> ftext (atomicReadLabel w)
-        MO_AtomicWrite w    -> ftext (atomicWriteLabel w)
-        MO_UF_Conv w        -> ftext (word2FloatLabel w)
-
-        MO_S_Mul2     {} -> unsupported
-        MO_S_QuotRem  {} -> unsupported
-        MO_U_QuotRem  {} -> unsupported
-        MO_U_QuotRem2 {} -> unsupported
-        MO_Add2       {} -> unsupported
-        MO_AddWordC   {} -> unsupported
-        MO_SubWordC   {} -> unsupported
-        MO_AddIntC    {} -> unsupported
-        MO_SubIntC    {} -> unsupported
-        MO_U_Mul2     {} -> unsupported
-        MO_Touch         -> unsupported
-        -- we could support prefetch via "__builtin_prefetch"
-        -- Not adding it for now
-        (MO_Prefetch_Data _ ) -> unsupported
-
-        MO_I64_ToI   -> text "hs_int64ToInt"
-        MO_I64_FromI -> text "hs_intToInt64"
-        MO_W64_ToW   -> text "hs_word64ToWord"
-        MO_W64_FromW -> text "hs_wordToWord64"
-        MO_x64_Neg   -> text "hs_neg64"
-        MO_x64_Add   -> text "hs_add64"
-        MO_x64_Sub   -> text "hs_sub64"
-        MO_x64_Mul   -> text "hs_mul64"
-        MO_I64_Quot  -> text "hs_quotInt64"
-        MO_I64_Rem   -> text "hs_remInt64"
-        MO_W64_Quot  -> text "hs_quotWord64"
-        MO_W64_Rem   -> text "hs_remWord64"
-        MO_x64_And   -> text "hs_and64"
-        MO_x64_Or    -> text "hs_or64"
-        MO_x64_Xor   -> text "hs_xor64"
-        MO_x64_Not   -> text "hs_not64"
-        MO_x64_Shl   -> text "hs_uncheckedShiftL64"
-        MO_I64_Shr   -> text "hs_uncheckedIShiftRA64"
-        MO_W64_Shr   -> text "hs_uncheckedShiftRL64"
-        MO_x64_Eq    -> text "hs_eq64"
-        MO_x64_Ne    -> text "hs_ne64"
-        MO_I64_Ge    -> text "hs_geInt64"
-        MO_I64_Gt    -> text "hs_gtInt64"
-        MO_I64_Le    -> text "hs_leInt64"
-        MO_I64_Lt    -> text "hs_ltInt64"
-        MO_W64_Ge    -> text "hs_geWord64"
-        MO_W64_Gt    -> text "hs_gtWord64"
-        MO_W64_Le    -> text "hs_leWord64"
-        MO_W64_Lt    -> text "hs_ltWord64"
-    where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop
-                            ++ " not supported!")
-
--- ---------------------------------------------------------------------
--- Useful #defines
---
-
-mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc
-
-mkJMP_ i = text "JMP_" <> parens i
-mkFN_  i = text "FN_"  <> parens i -- externally visible function
-mkIF_  i = text "IF_"  <> parens i -- locally visible
-
--- from rts/include/Stg.h
---
-mkC_,mkW_,mkP_ :: SDoc
-
-mkC_  = text "(C_)"        -- StgChar
-mkW_  = text "(W_)"        -- StgWord
-mkP_  = text "(P_)"        -- StgWord*
-
--- ---------------------------------------------------------------------
---
--- Assignments
---
--- Generating assignments is what we're all about, here
---
-pprAssign :: Platform -> CmmReg -> CmmExpr -> SDoc
-
--- dest is a reg, rhs is a reg
-pprAssign _ r1 (CmmReg r2)
-   | isPtrReg r1 && isPtrReg r2
-   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]
-
--- dest is a reg, rhs is a CmmRegOff
-pprAssign platform r1 (CmmRegOff r2 off)
-   | isPtrReg r1 && isPtrReg r2 && (off `rem` platformWordSizeInBytes platform == 0)
-   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
-  where
-        off1 = off `shiftR` wordShift platform
-
-        (op,off') | off >= 0  = (char '+', off1)
-                  | otherwise = (char '-', -off1)
-
--- dest is a reg, rhs is anything.
--- We can't cast the lvalue, so we have to cast the rhs if necessary.  Casting
--- the lvalue elicits a warning from new GCC versions (3.4+).
-pprAssign platform r1 r2
-  | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 platform r2)
-  | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 platform r2)
-  | otherwise                    = mkAssign (pprExpr platform r2)
-    where mkAssign x = if r1 == CmmGlobal BaseReg
-                       then text "ASSIGN_BaseReg" <> parens x <> semi
-                       else pprReg r1 <> text " = " <> x <> semi
-
--- ---------------------------------------------------------------------
--- Registers
-
-pprCastReg :: CmmReg -> SDoc
-pprCastReg reg
-   | isStrangeTypeReg reg = mkW_ <> pprReg reg
-   | otherwise            = pprReg reg
-
--- True if (pprReg reg) will give an expression with type StgPtr.  We
--- need to take care with pointer arithmetic on registers with type
--- StgPtr.
-isFixedPtrReg :: CmmReg -> Bool
-isFixedPtrReg (CmmLocal _) = False
-isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r
-
--- True if (pprAsPtrReg reg) will give an expression with type StgPtr
--- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST.
--- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT;
--- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY.
-isPtrReg :: CmmReg -> Bool
-isPtrReg (CmmLocal _)                         = False
-isPtrReg (CmmGlobal (VanillaReg _ VGcPtr))    = True  -- if we print via pprAsPtrReg
-isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg
-isPtrReg (CmmGlobal reg)                      = isFixedPtrGlobalReg reg
-
--- True if this global reg has type StgPtr
-isFixedPtrGlobalReg :: GlobalReg -> Bool
-isFixedPtrGlobalReg Sp    = True
-isFixedPtrGlobalReg Hp    = True
-isFixedPtrGlobalReg HpLim = True
-isFixedPtrGlobalReg SpLim = True
-isFixedPtrGlobalReg _     = False
-
--- True if in C this register doesn't have the type given by
--- (machRepCType (cmmRegType reg)), so it has to be cast.
-isStrangeTypeReg :: CmmReg -> Bool
-isStrangeTypeReg (CmmLocal _)   = False
-isStrangeTypeReg (CmmGlobal g)  = isStrangeTypeGlobal g
-
-isStrangeTypeGlobal :: GlobalReg -> Bool
-isStrangeTypeGlobal CCCS                = True
-isStrangeTypeGlobal CurrentTSO          = True
-isStrangeTypeGlobal CurrentNursery      = True
-isStrangeTypeGlobal BaseReg             = True
-isStrangeTypeGlobal r                   = isFixedPtrGlobalReg r
-
-strangeRegType :: CmmReg -> Maybe SDoc
-strangeRegType (CmmGlobal CCCS) = Just (text "struct CostCentreStack_ *")
-strangeRegType (CmmGlobal CurrentTSO) = Just (text "struct StgTSO_ *")
-strangeRegType (CmmGlobal CurrentNursery) = Just (text "struct bdescr_ *")
-strangeRegType (CmmGlobal BaseReg) = Just (text "struct StgRegTable_ *")
-strangeRegType _ = Nothing
-
--- pprReg just prints the register name.
---
-pprReg :: CmmReg -> SDoc
-pprReg r = case r of
-        CmmLocal  local  -> pprLocalReg local
-        CmmGlobal global -> pprGlobalReg global
-
-pprAsPtrReg :: CmmReg -> SDoc
-pprAsPtrReg (CmmGlobal (VanillaReg n gcp))
-  = warnPprTrace (gcp /= VGcPtr) "pprAsPtrReg" (ppr n) $ char 'R' <> int n <> text ".p"
-pprAsPtrReg other_reg = pprReg other_reg
-
-pprGlobalReg :: GlobalReg -> SDoc
-pprGlobalReg gr = case gr of
-    VanillaReg n _ -> char 'R' <> int n  <> text ".w"
-        -- pprGlobalReg prints a VanillaReg as a .w regardless
-        -- Example:     R1.w = R1.w & (-0x8UL);
-        --              JMP_(*R1.p);
-    FloatReg   n   -> char 'F' <> int n
-    DoubleReg  n   -> char 'D' <> int n
-    LongReg    n   -> char 'L' <> int n
-    Sp             -> text "Sp"
-    SpLim          -> text "SpLim"
-    Hp             -> text "Hp"
-    HpLim          -> text "HpLim"
-    CCCS           -> text "CCCS"
-    CurrentTSO     -> text "CurrentTSO"
-    CurrentNursery -> text "CurrentNursery"
-    HpAlloc        -> text "HpAlloc"
-    BaseReg        -> text "BaseReg"
-    EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"
-    GCEnter1       -> text "stg_gc_enter_1"
-    GCFun          -> text "stg_gc_fun"
-    other          -> panic $ "pprGlobalReg: Unsupported register: " ++ show other
-
-pprLocalReg :: LocalReg -> SDoc
-pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
-
--- -----------------------------------------------------------------------------
--- Foreign Calls
-
-pprCall :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
-pprCall platform ppr_fn cconv results args
-  | not (is_cishCC cconv)
-  = panic $ "pprCall: unknown calling convention"
-
-  | otherwise
-  =
-    ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
-  where
-     ppr_assign []           rhs = rhs
-     ppr_assign [(one,hint)] rhs
-         = pprLocalReg one <> text " = "
-                 <> pprUnHint hint (localRegType one) <> rhs
-     ppr_assign _other _rhs = panic "pprCall: multiple results"
-
-     pprArg (expr, AddrHint)
-        = cCast platform (text "void *") expr
-        -- see comment by machRepHintCType below
-     pprArg (expr, SignedHint)
-        = cCast platform (machRep_S_CType platform $ typeWidth $ cmmExprType platform expr) expr
-     pprArg (expr, _other)
-        = pprExpr platform expr
-
-     pprUnHint AddrHint   rep = parens (machRepCType platform rep)
-     pprUnHint SignedHint rep = parens (machRepCType platform rep)
-     pprUnHint _          _   = empty
-
--- Currently we only have these two calling conventions, but this might
--- change in the future...
-is_cishCC :: CCallConv -> Bool
-is_cishCC CCallConv    = True
-is_cishCC CApiConv     = True
-is_cishCC StdCallConv  = True
-is_cishCC PrimCallConv = False
-is_cishCC JavaScriptCallConv = False
-
--- ---------------------------------------------------------------------
--- Find and print local and external declarations for a list of
--- Cmm statements.
---
-pprTempAndExternDecls :: Platform -> [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})
-pprTempAndExternDecls platform stmts
-  = (pprUFM (getUniqSet temps) (vcat . map (pprTempDecl platform)),
-     vcat (map (pprExternDecl platform) (Map.keys lbls)))
-  where (temps, lbls) = runTE (mapM_ te_BB stmts)
-
-pprDataExterns :: Platform -> [CmmStatic] -> SDoc
-pprDataExterns platform statics
-  = vcat (map (pprExternDecl platform) (Map.keys lbls))
-  where (_, lbls) = runTE (mapM_ te_Static statics)
-
-pprTempDecl :: Platform -> LocalReg -> SDoc
-pprTempDecl platform l@(LocalReg _ rep)
-  = hcat [ machRepCType platform rep, space, pprLocalReg l, semi ]
-
-pprExternDecl :: Platform -> CLabel -> SDoc
-pprExternDecl platform lbl
-  -- do not print anything for "known external" things
-  | not (needsCDecl lbl) = empty
-  | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
-  | otherwise =
-        hcat [ visibility, label_type lbl , lparen, pprCLabel platform lbl, text ");"
-             -- occasionally useful to see label type
-             -- , text "/* ", pprDebugCLabel lbl, text " */"
-             ]
- where
-  label_type lbl | isBytesLabel lbl         = text "B_"
-                 | isForeignLabel lbl && isCFunctionLabel lbl
-                                            = text "FF_"
-                 | isCFunctionLabel lbl     = text "F_"
-                 | isStaticClosureLabel lbl = text "C_"
-                 -- generic .rodata labels
-                 | isSomeRODataLabel lbl    = text "RO_"
-                 -- generic .data labels (common case)
-                 | otherwise                = text "RW_"
-
-  visibility
-     | externallyVisibleCLabel lbl = char 'E'
-     | otherwise                   = char 'I'
-
-  -- If the label we want to refer to is a stdcall function (on Windows) then
-  -- we must generate an appropriate prototype for it, so that the C compiler will
-  -- add the @n suffix to the label (#2276)
-  stdcall_decl sz =
-        text "extern __attribute__((stdcall)) void " <> pprCLabel platform lbl
-        <> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform))))
-        <> semi
-
-type TEState = (UniqSet LocalReg, Map CLabel ())
-newtype TE a = TE' (State TEState a)
-  deriving stock (Functor)
-  deriving (Applicative, Monad) via State TEState
-
-pattern TE :: (TEState -> (a, TEState)) -> TE a
-pattern TE f <- TE' (runState -> f)
-  where TE f  = TE' (state f)
-{-# COMPLETE TE #-}
-
-te_lbl :: CLabel -> TE ()
-te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls))
-
-te_temp :: LocalReg -> TE ()
-te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))
-
-runTE :: TE () -> TEState
-runTE (TE m) = snd (m (emptyUniqSet, Map.empty))
-
-te_Static :: CmmStatic -> TE ()
-te_Static (CmmStaticLit lit) = te_Lit lit
-te_Static _ = return ()
-
-te_BB :: CmmBlock -> TE ()
-te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last
-  where (_, mid, last) = blockSplit block
-
-te_Lit :: CmmLit -> TE ()
-te_Lit (CmmLabel l) = te_lbl l
-te_Lit (CmmLabelOff l _) = te_lbl l
-te_Lit (CmmLabelDiffOff l1 _ _ _) = te_lbl l1
-te_Lit _ = return ()
-
-te_Stmt :: CmmNode e x -> TE ()
-te_Stmt (CmmAssign r e)         = te_Reg r >> te_Expr e
-te_Stmt (CmmStore l r _)        = te_Expr l >> te_Expr r
-te_Stmt (CmmUnsafeForeignCall target rs es)
-  = do  te_Target target
-        mapM_ te_temp rs
-        mapM_ te_Expr es
-te_Stmt (CmmCondBranch e _ _ _) = te_Expr e
-te_Stmt (CmmSwitch e _)         = te_Expr e
-te_Stmt (CmmCall { cml_target = e }) = te_Expr e
-te_Stmt _                       = return ()
-
-te_Target :: ForeignTarget -> TE ()
-te_Target (ForeignTarget e _)      = te_Expr e
-te_Target (PrimTarget{})           = return ()
-
-te_Expr :: CmmExpr -> TE ()
-te_Expr (CmmLit lit)            = te_Lit lit
-te_Expr (CmmLoad e _ _)         = te_Expr e
-te_Expr (CmmReg r)              = te_Reg r
-te_Expr (CmmMachOp _ es)        = mapM_ te_Expr es
-te_Expr (CmmRegOff r _)         = te_Reg r
-te_Expr (CmmStackSlot _ _)      = panic "te_Expr: CmmStackSlot not supported!"
-
-te_Reg :: CmmReg -> TE ()
-te_Reg (CmmLocal l) = te_temp l
-te_Reg _            = return ()
-
-
--- ---------------------------------------------------------------------
--- C types for MachReps
-
-cCast :: Platform -> SDoc -> CmmExpr -> SDoc
-cCast platform ty expr = parens ty <> pprExpr1 platform expr
-
-cLoad :: Platform -> CmmExpr -> CmmType -> SDoc
-cLoad platform expr rep
-    = if bewareLoadStoreAlignment (platformArch platform)
-      then let decl = machRepCType platform rep <+> text "x" <> semi
-               struct = text "struct" <+> braces (decl)
-               packed_attr = text "__attribute__((packed))"
-               cast = parens (struct <+> packed_attr <> char '*')
-           in parens (cast <+> pprExpr1 platform expr) <> text "->x"
-      else char '*' <> parens (cCast platform (machRepPtrCType platform rep) expr)
-    where -- On these platforms, unaligned loads are known to cause problems
-          bewareLoadStoreAlignment ArchAlpha    = True
-          bewareLoadStoreAlignment ArchMipseb   = True
-          bewareLoadStoreAlignment ArchMipsel   = True
-          bewareLoadStoreAlignment (ArchARM {}) = True
-          bewareLoadStoreAlignment ArchAArch64  = True
-          -- Pessimistically assume that they will also cause problems
-          -- on unknown arches
-          bewareLoadStoreAlignment ArchUnknown  = True
-          bewareLoadStoreAlignment _            = False
-
-isCmmWordType :: Platform -> CmmType -> Bool
--- True of GcPtrReg/NonGcReg of native word size
-isCmmWordType platform ty = not (isFloatType ty)
-                            && typeWidth ty == wordWidth platform
-
--- This is for finding the types of foreign call arguments.  For a pointer
--- argument, we always cast the argument to (void *), to avoid warnings from
--- the C compiler.
-machRepHintCType :: Platform -> CmmType -> ForeignHint -> SDoc
-machRepHintCType platform rep = \case
-   AddrHint   -> text "void *"
-   SignedHint -> machRep_S_CType platform (typeWidth rep)
-   _other     -> machRepCType platform rep
-
-machRepPtrCType :: Platform -> CmmType -> SDoc
-machRepPtrCType platform r
- = if isCmmWordType platform r
-      then text "P_"
-      else machRepCType platform r <> char '*'
-
-machRepCType :: Platform -> CmmType -> SDoc
-machRepCType platform ty
-   | isFloatType ty = machRep_F_CType w
-   | otherwise      = machRep_U_CType platform w
-   where
-      w = typeWidth ty
-
-machRep_F_CType :: Width -> SDoc
-machRep_F_CType W32 = text "StgFloat" -- ToDo: correct?
-machRep_F_CType W64 = text "StgDouble"
-machRep_F_CType _   = panic "machRep_F_CType"
-
-machRep_U_CType :: Platform -> Width -> SDoc
-machRep_U_CType platform w
- = case w of
-   _ | w == wordWidth platform -> text "W_"
-   W8  -> text "StgWord8"
-   W16 -> text "StgWord16"
-   W32 -> text "StgWord32"
-   W64 -> text "StgWord64"
-   _   -> panic "machRep_U_CType"
-
-machRep_S_CType :: Platform -> Width -> SDoc
-machRep_S_CType platform w
- = case w of
-   _ | w == wordWidth platform -> text "I_"
-   W8  -> text "StgInt8"
-   W16 -> text "StgInt16"
-   W32 -> text "StgInt32"
-   W64 -> text "StgInt64"
-   _   -> panic "machRep_S_CType"
-
-
--- ---------------------------------------------------------------------
--- print strings as valid C strings
-
-pprStringInCStyle :: ByteString -> SDoc
-pprStringInCStyle s = doubleQuotes (text (concatMap charToC (BS.unpack s)))
-
--- ---------------------------------------------------------------------------
--- Initialising static objects with floating-point numbers.  We can't
--- just emit the floating point number, because C will cast it to an int
--- by rounding it.  We want the actual bit-representation of the float.
---
--- Consider a concrete C example:
---    double d = 2.5e-10;
---    float f  = 2.5e-10f;
---
---    int * i2 = &d;      printf ("i2: %08X %08X\n", i2[0], i2[1]);
---    long long * l = &d; printf (" l: %016llX\n",   l[0]);
---    int * i = &f;       printf (" i: %08X\n",      i[0]);
--- Result on 64-bit LE (x86_64):
---     i2: E826D695 3DF12E0B
---      l: 3DF12E0BE826D695
---      i: 2F89705F
--- Result on 32-bit BE (m68k):
---     i2: 3DF12E0B E826D695
---      l: 3DF12E0BE826D695
---      i: 2F89705F
---
--- The trick here is to notice that binary representation does not
--- change much: only Word32 values get swapped on LE hosts / targets.
-
--- This is a hack to turn the floating point numbers into ints that we
--- can safely initialise to static locations.
-
-floatToWord32 :: Rational -> CmmLit
-floatToWord32 r = CmmInt (toInteger (castFloatToWord32 (fromRational r))) W32
-
-doubleToWord64 :: Rational -> CmmLit
-doubleToWord64 r = CmmInt (toInteger (castDoubleToWord64 (fromRational r))) W64
-
-
--- ---------------------------------------------------------------------------
--- Utils
-
-wordShift :: Platform -> Int
-wordShift platform = widthInLog (wordWidth platform)
-
-commafy :: [SDoc] -> SDoc
-commafy xs = hsep $ punctuate comma xs
-
--- | Print in C hex format
---
--- Examples:
---
---   5114    :: W32  ===>  ((StgWord32)0x13faU)
---   (-5114) :: W32  ===>  ((StgWord32)(-0x13faU))
---
--- We use casts to support types smaller than `unsigned int`; C literal
--- suffixes support longer but not shorter types.
-pprHexVal :: Platform -> Integer -> Width -> SDoc
-pprHexVal platform w rep = parens ctype <> rawlit
-  where
-      rawlit
-        | w < 0     = parens (char '-' <>
-                          text "0x" <> intToDoc (-w) <> repsuffix rep)
-        | otherwise =     text "0x" <> intToDoc   w  <> repsuffix rep
-      ctype = machRep_U_CType platform rep
-
-        -- type suffix for literals:
-        -- Integer literals are unsigned in Cmm/C.  We explicitly cast to
-        -- signed values for doing signed operations, but at all other
-        -- times values are unsigned.  This also helps eliminate occasional
-        -- warnings about integer overflow from gcc.
-
-      constants = platformConstants platform
-
-      repsuffix W64 =
-               if pc_CINT_SIZE       constants == 8 then char 'U'
-          else if pc_CLONG_SIZE      constants == 8 then text "UL"
-          else if pc_CLONG_LONG_SIZE constants == 8 then text "ULL"
-          else panic "pprHexVal: Can't find a 64-bit type"
-      repsuffix _ = char 'U'
-
-      intToDoc :: Integer -> SDoc
-      intToDoc i = case truncInt i of
-                       0 -> char '0'
-                       v -> go v
-
-      -- We need to truncate value as Cmm backend does not drop
-      -- redundant bits to ease handling of negative values.
-      -- Thus the following Cmm code on 64-bit arch, like amd64:
-      --     CInt v;
-      --     v = {something};
-      --     if (v == %lobits32(-1)) { ...
-      -- leads to the following C code:
-      --     StgWord64 v = (StgWord32)({something});
-      --     if (v == 0xFFFFffffFFFFffffU) { ...
-      -- Such code is incorrect as it promotes both operands to StgWord64
-      -- and the whole condition is always false.
-      truncInt :: Integer -> Integer
-      truncInt i =
-          case rep of
-              W8  -> i `rem` (2^(8 :: Int))
-              W16 -> i `rem` (2^(16 :: Int))
-              W32 -> i `rem` (2^(32 :: Int))
-              W64 -> i `rem` (2^(64 :: Int))
-              _   -> panic ("pprHexVal/truncInt: C backend can't encode "
-                            ++ show rep ++ " literals")
-
-      go 0 = empty
-      go w' = go q <> dig
-           where
-             (q,r) = w' `quotRem` 16
-             dig | r < 10    = char (chr (fromInteger r + ord '0'))
-                 | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
-
--- | Construct a constructor/finalizer function. Instead of emitting a
--- initializer/finalizer array we rather just emit a single function, annotated
--- with the appropriate C attribute, which then calls each of the initializers.
-pprCtorArray :: Platform -> InitOrFini -> [CLabel] -> SDoc
-pprCtorArray platform initOrFini lbls =
-       decls
-    <> text "static __attribute__((" <> attribute <> text "))"
-    <> text "void _hs_" <> attribute <> text "()"
-    <> braces body
-  where
-    body = vcat [ pprCLabel platform lbl <> text " ();" | lbl <- lbls ]
-    decls = vcat [ text "void" <+> pprCLabel platform lbl <> text " (void);" | lbl <- lbls ]
-    attribute = case initOrFini of
-                  IsInitArray -> text "constructor"
-                  IsFiniArray -> text "destructor"
diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToLlvm.hs
+++ /dev/null
@@ -1,232 +0,0 @@
-{-# LANGUAGE TypeFamilies, ViewPatterns, OverloadedStrings #-}
-
--- -----------------------------------------------------------------------------
--- | This is the top-level module in the LLVM code generator.
---
-module GHC.CmmToLlvm
-   ( LlvmVersion
-   , llvmVersionList
-   , llvmCodeGen
-   , llvmFixupAsm
-   )
-where
-
-import GHC.Prelude hiding ( head )
-
-import GHC.Llvm
-import GHC.CmmToLlvm.Base
-import GHC.CmmToLlvm.CodeGen
-import GHC.CmmToLlvm.Config
-import GHC.CmmToLlvm.Data
-import GHC.CmmToLlvm.Ppr
-import GHC.CmmToLlvm.Regs
-import GHC.CmmToLlvm.Mangler
-
-import GHC.StgToCmm.CgUtils ( fixStgRegisters )
-import GHC.Cmm
-import GHC.Cmm.Dataflow.Collections
-
-import GHC.Utils.BufHandle
-import GHC.Driver.Session
-import GHC.Platform ( platformArch, Arch(..) )
-import GHC.Utils.Error
-import GHC.Data.FastString
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Logger
-import qualified GHC.Data.Stream as Stream
-
-import Control.Monad ( when, forM_ )
-import Data.List.NonEmpty ( head )
-import Data.Maybe ( fromMaybe, catMaybes )
-import System.IO
-
--- -----------------------------------------------------------------------------
--- | Top-level of the LLVM Code generator
---
-llvmCodeGen :: Logger -> LlvmCgConfig -> Handle
-               -> Stream.Stream IO RawCmmGroup a
-               -> IO a
-llvmCodeGen logger cfg h cmm_stream
-  = withTiming logger (text "LLVM CodeGen") (const ()) $ do
-       bufh <- newBufHandle h
-
-       -- Pass header
-       showPass logger "LLVM CodeGen"
-
-       -- get llvm version, cache for later use
-       let mb_ver = llvmCgLlvmVersion cfg
-
-       -- warn if unsupported
-       forM_ mb_ver $ \ver -> do
-         debugTraceMsg logger 2
-              (text "Using LLVM version:" <+> text (llvmVersionStr ver))
-         let doWarn = llvmCgDoWarn cfg
-         when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger $
-           "You are using an unsupported version of LLVM!" $$
-           "Currently only" <+> text (llvmVersionStr supportedLlvmVersionLowerBound) <+>
-           "up to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "(non inclusive) is supported." <+>
-           "System LLVM version: " <> text (llvmVersionStr ver) $$
-           "We will try though..."
-         let isS390X = platformArch (llvmCgPlatform cfg)  == ArchS390X
-         let major_ver = head . llvmVersionNE $ ver
-         when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $
-           "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>
-           "You are using LLVM version: " <> text (llvmVersionStr ver)
-
-       -- HACK: the Nothing case here is potentially wrong here but we
-       -- currently don't use the LLVM version to guide code generation
-       -- so this is okay.
-       let llvm_ver :: LlvmVersion
-           llvm_ver = fromMaybe supportedLlvmVersionLowerBound mb_ver
-
-       -- run code generation
-       a <- runLlvm logger cfg llvm_ver bufh $
-         llvmCodeGen' cfg cmm_stream
-
-       bFlush bufh
-
-       return a
-
-llvmCodeGen' :: LlvmCgConfig -> Stream.Stream IO RawCmmGroup a -> LlvmM a
-llvmCodeGen' cfg cmm_stream
-  = do  -- Preamble
-        renderLlvm header
-        ghcInternalFunctions
-        cmmMetaLlvmPrelude
-
-        -- Procedures
-        a <- Stream.consume cmm_stream liftIO llvmGroupLlvmGens
-
-        -- Declare aliases for forward references
-        renderLlvm . pprLlvmData cfg =<< generateExternDecls
-
-        -- Postamble
-        cmmUsedLlvmGens
-
-        return a
-  where
-    header :: SDoc
-    header =
-      let target  = llvmCgLlvmTarget cfg
-          llvmCfg = llvmCgLlvmConfig cfg
-      in     (text "target datalayout = \"" <> text (getDataLayout llvmCfg target) <> text "\"")
-         $+$ (text "target triple = \"" <> text target <> text "\"")
-
-    getDataLayout :: LlvmConfig -> String -> String
-    getDataLayout config target =
-      case lookup target (llvmTargets config) of
-        Just (LlvmTarget {lDataLayout=dl}) -> dl
-        Nothing -> pprPanic "Failed to lookup LLVM data layout" $
-                   text "Target:" <+> text target $$
-                   hang (text "Available targets:") 4
-                        (vcat $ map (text . fst) $ llvmTargets config)
-
-llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
-llvmGroupLlvmGens cmm = do
-
-        -- Insert functions into map, collect data
-        let split (CmmData s d' )     = return $ Just (s, d')
-            split (CmmProc h l live g) = do
-              -- Set function type
-              let l' = case mapLookup (g_entry g) h :: Maybe RawCmmStatics of
-                         Nothing                   -> l
-                         Just (CmmStaticsRaw info_lbl _) -> info_lbl
-              lml <- strCLabel_llvm l'
-              funInsert lml =<< llvmFunTy live
-              return Nothing
-        cdata <- fmap catMaybes $ mapM split cmm
-
-        {-# SCC "llvm_datas_gen" #-}
-          cmmDataLlvmGens cdata
-        {-# SCC "llvm_procs_gen" #-}
-          mapM_ cmmLlvmGen cmm
-
--- -----------------------------------------------------------------------------
--- | Do LLVM code generation on all these Cmms data sections.
---
-cmmDataLlvmGens :: [(Section,RawCmmStatics)] -> LlvmM ()
-
-cmmDataLlvmGens statics
-  = do lmdatas <- mapM genLlvmData statics
-
-       let (concat -> gs, tss) = unzip lmdatas
-
-       let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)
-                        = funInsert l ty
-           regGlobal _  = pure ()
-       mapM_ regGlobal gs
-       gss' <- mapM aliasify $ gs
-
-       cfg <- getConfig
-       renderLlvm $ pprLlvmData cfg (concat gss', concat tss)
-
--- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
-cmmLlvmGen ::RawCmmDecl -> LlvmM ()
-cmmLlvmGen cmm@CmmProc{} = do
-
-    -- rewrite assignments to global regs
-    platform <- getPlatform
-    let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters platform cmm
-
-    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm"
-      FormatCMM (pprCmmGroup platform [fixed_cmm])
-
-    -- generate llvm code from cmm
-    llvmBC <- withClearVars $ genLlvmProc fixed_cmm
-
-    -- pretty print
-    (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC
-
-    -- Output, note down used variables
-    renderLlvm (vcat docs)
-    mapM_ markUsedVar $ concat ivars
-
-cmmLlvmGen _ = return ()
-
--- -----------------------------------------------------------------------------
--- | Generate meta data nodes
---
-
-cmmMetaLlvmPrelude :: LlvmM ()
-cmmMetaLlvmPrelude = do
-  metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do
-    -- Generate / lookup meta data IDs
-    tbaaId <- getMetaUniqueId
-    setUniqMeta uniq tbaaId
-    parentId <- maybe (return Nothing) getUniqMeta parent
-    -- Build definition
-    return $ MetaUnnamed tbaaId $ MetaStruct $
-          case parentId of
-              Just p  -> [ MetaStr name, MetaNode p ]
-              -- As of LLVM 4.0, a node without parents should be rendered as
-              -- just a name on its own. Previously `null` was accepted as the
-              -- name.
-              Nothing -> [ MetaStr name ]
-  cfg <- getConfig
-  renderLlvm $ ppLlvmMetas cfg metas
-
--- -----------------------------------------------------------------------------
--- | Marks variables as used where necessary
---
-
-cmmUsedLlvmGens :: LlvmM ()
-cmmUsedLlvmGens = do
-
-  -- LLVM would discard variables that are internal and not obviously
-  -- used if we didn't provide these hints. This will generate a
-  -- definition of the form
-  --
-  --   @llvm.used = appending global [42 x i8*] [i8* bitcast <var> to i8*, ...]
-  --
-  -- Which is the LLVM way of protecting them against getting removed.
-  ivars <- getUsedVars
-  let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
-      ty     = LMArray (length ivars) i8Ptr
-      usedArray = LMStaticArray (map cast ivars) ty
-      sectName  = Just $ fsLit "llvm.metadata"
-      lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant
-      lmUsed    = LMGlobal lmUsedVar (Just usedArray)
-  if null ivars
-     then return ()
-     else getConfig >>= renderLlvm . flip pprLlvmData ([lmUsed], [])
diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ /dev/null
@@ -1,609 +0,0 @@
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DerivingVia #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
--- ----------------------------------------------------------------------------
--- | Base LLVM Code Generation module
---
--- Contains functions useful through out the code generator.
---
-
-module GHC.CmmToLlvm.Base (
-
-        LlvmCmmDecl, LlvmBasicBlock,
-        LiveGlobalRegs,
-        LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
-
-        LlvmM,
-        runLlvm, withClearVars, varLookup, varInsert,
-        markStackReg, checkStackReg,
-        funLookup, funInsert, getLlvmVer,
-        dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
-        ghcInternalFunctions, getPlatform, getConfig,
-
-        getMetaUniqueId,
-        setUniqMeta, getUniqMeta, liftIO,
-
-        cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
-        llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
-        llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR,
-
-        strCLabel_llvm,
-        getGlobalPtr, generateExternDecls,
-
-        aliasify, llvmDefLabel
-    ) where
-
-import GHC.Prelude
-import GHC.Utils.Panic
-
-import GHC.Llvm
-import GHC.CmmToLlvm.Regs
-import GHC.CmmToLlvm.Config
-
-import GHC.Cmm.CLabel
-import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe )
-import GHC.Driver.Session
-import GHC.Data.FastString
-import GHC.Cmm              hiding ( succ )
-import GHC.Cmm.Utils (regsOverlap)
-import GHC.Utils.Outputable as Outp
-import GHC.Platform
-import GHC.Types.Unique.FM
-import GHC.Types.Unique
-import GHC.Utils.BufHandle   ( BufHandle )
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.Supply
-import GHC.Utils.Logger
-
-import Data.Maybe (fromJust)
-import Control.Monad.Trans.State (StateT (..))
-import Data.List (isPrefixOf)
-import qualified Data.List.NonEmpty as NE
-import Data.Ord (comparing)
-
--- ----------------------------------------------------------------------------
--- * Some Data Types
---
-
-type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe RawCmmStatics) (ListGraph LlvmStatement)
-type LlvmBasicBlock = GenBasicBlock LlvmStatement
-
--- | Global registers live on proc entry
-type LiveGlobalRegs = [GlobalReg]
-
--- | Unresolved code.
--- Of the form: (data label, data type, unresolved data)
-type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
-
--- | Top level LLVM Data (globals and type aliases)
-type LlvmData = ([LMGlobal], [LlvmType])
-
--- | An unresolved Label.
---
--- Labels are unresolved when we haven't yet determined if they are defined in
--- the module we are currently compiling, or an external one.
-type UnresLabel  = CmmLit
-type UnresStatic = Either UnresLabel LlvmStatic
-
--- ----------------------------------------------------------------------------
--- * Type translations
---
-
--- | Translate a basic CmmType to an LlvmType.
-cmmToLlvmType :: CmmType -> LlvmType
-cmmToLlvmType ty | isVecType ty   = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty))
-                 | isFloatType ty = widthToLlvmFloat $ typeWidth ty
-                 | otherwise      = widthToLlvmInt   $ typeWidth ty
-
--- | Translate a Cmm Float Width to a LlvmType.
-widthToLlvmFloat :: Width -> LlvmType
-widthToLlvmFloat W32  = LMFloat
-widthToLlvmFloat W64  = LMDouble
-widthToLlvmFloat W128 = LMFloat128
-widthToLlvmFloat w    = panic $ "widthToLlvmFloat: Bad float size: " ++ show w
-
--- | Translate a Cmm Bit Width to a LlvmType.
-widthToLlvmInt :: Width -> LlvmType
-widthToLlvmInt w = LMInt $ widthInBits w
-
--- | GHC Call Convention for LLVM
-llvmGhcCC :: Platform -> LlvmCallConvention
-llvmGhcCC platform
- | platformUnregisterised platform = CC_Ccc
- | otherwise                       = CC_Ghc
-
--- | Llvm Function type for Cmm function
-llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
-llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible
-
--- | Llvm Function signature
-llvmFunSig :: LiveGlobalRegs ->  CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
-llvmFunSig live lbl link = do
-  lbl' <- strCLabel_llvm lbl
-  llvmFunSig' live lbl' link
-
-llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
-llvmFunSig' live lbl link
-  = do let toParams x | isPointer x = (x, [NoAlias, NoCapture])
-                      | otherwise   = (x, [])
-       platform <- getPlatform
-       return $ LlvmFunctionDecl lbl link (llvmGhcCC platform) LMVoid FixedArgs
-                                 (map (toParams . getVarType) (llvmFunArgs platform live))
-                                 (llvmFunAlign platform)
-
--- | Alignment to use for functions
-llvmFunAlign :: Platform -> LMAlign
-llvmFunAlign platform = Just (platformWordSizeInBytes platform)
-
--- | Alignment to use for into tables
-llvmInfAlign :: Platform -> LMAlign
-llvmInfAlign platform = Just (platformWordSizeInBytes platform)
-
--- | Section to use for a function
-llvmFunSection :: LlvmCgConfig -> LMString -> LMSection
-llvmFunSection opts lbl
-    | llvmCgSplitSection opts = Just (concatFS [fsLit ".text.", lbl])
-    | otherwise               = Nothing
-
--- | A Function's arguments
-llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
-llvmFunArgs platform live =
-    map (lmGlobalRegArg platform) (filter isPassed allRegs)
-    where allRegs = activeStgRegs platform
-          paddingRegs = padLiveArgs platform live
-          isLive r = r `elem` alwaysLive
-                     || r `elem` live
-                     || r `elem` paddingRegs
-          isPassed r = not (isFPR r) || isLive r
-
-
-isFPR :: GlobalReg -> Bool
-isFPR (FloatReg _)  = True
-isFPR (DoubleReg _) = True
-isFPR (XmmReg _)    = True
-isFPR (YmmReg _)    = True
-isFPR (ZmmReg _)    = True
-isFPR _             = False
-
--- | Return a list of "padding" registers for LLVM function calls.
---
--- When we generate LLVM function signatures, we can't just make any register
--- alive on function entry. Instead, we need to insert fake arguments of the
--- same register class until we are sure that one of them is mapped to the
--- register we want alive. E.g. to ensure that F5 is alive, we may need to
--- insert fake arguments mapped to F1, F2, F3 and F4.
---
--- Invariant: Cmm FPR regs with number "n" maps to real registers with number
--- "n" If the calling convention uses registers in a different order or if the
--- invariant doesn't hold, this code probably won't be correct.
-padLiveArgs :: Platform -> LiveGlobalRegs -> LiveGlobalRegs
-padLiveArgs platform live =
-      if platformUnregisterised platform
-        then [] -- not using GHC's register convention for platform.
-        else padded
-  where
-    ----------------------------------
-    -- handle floating-point registers (FPR)
-
-    fprLive = filter isFPR live  -- real live FPR registers
-
-    -- we group live registers sharing the same classes, i.e. that use the same
-    -- set of real registers to be passed. E.g. FloatReg, DoubleReg and XmmReg
-    -- all use the same real regs on X86-64 (XMM registers).
-    --
-    classes         = NE.groupBy sharesClass fprLive
-    sharesClass a b = regsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers
-    norm x          = CmmGlobal ((fpr_ctor x) 1)             -- get the first register of the family
-
-    -- For each class, we just have to fill missing registers numbers. We use
-    -- the constructor of the greatest register to build padding registers.
-    --
-    -- E.g. sortedRs = [   F2,   XMM4, D5]
-    --      output   = [D1,   D3]
-    padded      = concatMap padClass classes
-    padClass rs = go (NE.toList sortedRs) 1
-      where
-         sortedRs = NE.sortBy (comparing fpr_num) rs
-         maxr     = NE.last sortedRs
-         ctor     = fpr_ctor maxr
-
-         go [] _ = []
-         go (c1:c2:_) _   -- detect bogus case (see #17920)
-            | fpr_num c1 == fpr_num c2
-            , Just real <- globalRegMaybe platform c1
-            = sorryDoc "LLVM code generator" $
-               text "Found two different Cmm registers (" <> ppr c1 <> text "," <> ppr c2 <>
-               text ") both alive AND mapped to the same real register: " <> ppr real <>
-               text ". This isn't currently supported by the LLVM backend."
-         go (c:cs) f
-            | fpr_num c == f = go cs f                    -- already covered by a real register
-            | otherwise      = ctor f : go (c:cs) (f + 1) -- add padding register
-
-    fpr_ctor :: GlobalReg -> Int -> GlobalReg
-    fpr_ctor (FloatReg _)  = FloatReg
-    fpr_ctor (DoubleReg _) = DoubleReg
-    fpr_ctor (XmmReg _)    = XmmReg
-    fpr_ctor (YmmReg _)    = YmmReg
-    fpr_ctor (ZmmReg _)    = ZmmReg
-    fpr_ctor _ = error "fpr_ctor expected only FPR regs"
-
-    fpr_num :: GlobalReg -> Int
-    fpr_num (FloatReg i)  = i
-    fpr_num (DoubleReg i) = i
-    fpr_num (XmmReg i)    = i
-    fpr_num (YmmReg i)    = i
-    fpr_num (ZmmReg i)    = i
-    fpr_num _ = error "fpr_num expected only FPR regs"
-
-
--- | Llvm standard fun attributes
-llvmStdFunAttrs :: [LlvmFuncAttr]
-llvmStdFunAttrs = [NoUnwind]
-
--- | Convert a list of types to a list of function parameters
--- (each with no parameter attributes)
-tysToParams :: [LlvmType] -> [LlvmParameter]
-tysToParams = map (\ty -> (ty, []))
-
--- | Pointer width
-llvmPtrBits :: Platform -> Int
-llvmPtrBits platform = widthInBits $ typeWidth $ gcWord platform
-
--- ----------------------------------------------------------------------------
--- * Environment Handling
---
-
-data LlvmEnv = LlvmEnv
-  { envVersion   :: LlvmVersion      -- ^ LLVM version
-  , envConfig    :: !LlvmCgConfig    -- ^ Configuration for LLVM code gen
-  , envLogger    :: !Logger          -- ^ Logger
-  , envOutput    :: BufHandle        -- ^ Output buffer
-  , envMask      :: !Char            -- ^ Mask for creating unique values
-  , envFreshMeta :: MetaId           -- ^ Supply of fresh metadata IDs
-  , envUniqMeta  :: UniqFM Unique MetaId   -- ^ Global metadata nodes
-  , envFunMap    :: LlvmEnvMap       -- ^ Global functions so far, with type
-  , envAliases   :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
-  , envUsedVars  :: [LlvmVar]        -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)
-
-    -- the following get cleared for every function (see @withClearVars@)
-  , envVarMap    :: LlvmEnvMap       -- ^ Local variables so far, with type
-  , envStackRegs :: [GlobalReg]      -- ^ Non-constant registers (alloca'd in the function prelude)
-  }
-
-type LlvmEnvMap = UniqFM Unique LlvmType
-
--- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
-newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
-    deriving stock (Functor)
-    deriving (Applicative, Monad) via StateT LlvmEnv IO
-
-instance HasLogger LlvmM where
-    getLogger = LlvmM $ \env -> return (envLogger env, env)
-
-
--- | Get target platform
-getPlatform :: LlvmM Platform
-getPlatform = llvmCgPlatform <$> getConfig
-
-getConfig :: LlvmM LlvmCgConfig
-getConfig = LlvmM $ \env -> return (envConfig env, env)
-
-instance MonadUnique LlvmM where
-    getUniqueSupplyM = do
-        mask <- getEnv envMask
-        liftIO $! mkSplitUniqSupply mask
-
-    getUniqueM = do
-        mask <- getEnv envMask
-        liftIO $! uniqFromMask mask
-
--- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
-liftIO :: IO a -> LlvmM a
-liftIO m = LlvmM $ \env -> do x <- m
-                              return (x, env)
-
--- | Get initial Llvm environment.
-runLlvm :: Logger -> LlvmCgConfig -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
-runLlvm logger cfg ver out m = do
-    (a, _) <- runLlvmM m env
-    return a
-  where env = LlvmEnv { envFunMap    = emptyUFM
-                      , envVarMap    = emptyUFM
-                      , envStackRegs = []
-                      , envUsedVars  = []
-                      , envAliases   = emptyUniqSet
-                      , envVersion   = ver
-                      , envConfig    = cfg
-                      , envLogger    = logger
-                      , envOutput    = out
-                      , envMask      = 'n'
-                      , envFreshMeta = MetaId 0
-                      , envUniqMeta  = emptyUFM
-                      }
-
--- | Get environment (internal)
-getEnv :: (LlvmEnv -> a) -> LlvmM a
-getEnv f = LlvmM (\env -> return (f env, env))
-
--- | Modify environment (internal)
-modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()
-modifyEnv f = LlvmM (\env -> return ((), f env))
-
--- | Clear variables from the environment for a subcomputation
-withClearVars :: LlvmM a -> LlvmM a
-withClearVars m = LlvmM $ \env -> do
-    (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] }
-    return (x, env' { envVarMap = emptyUFM, envStackRegs = [] })
-
--- | Insert variables or functions into the environment.
-varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM ()
-varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) (getUnique s) t }
-funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) (getUnique s) t }
-
--- | Lookup variables or functions in the environment.
-varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)
-varLookup s = getEnv (flip lookupUFM (getUnique s) . envVarMap)
-funLookup s = getEnv (flip lookupUFM (getUnique s) . envFunMap)
-
--- | Set a register as allocated on the stack
-markStackReg :: GlobalReg -> LlvmM ()
-markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env }
-
--- | Check whether a register is allocated on the stack
-checkStackReg :: GlobalReg -> LlvmM Bool
-checkStackReg r = getEnv ((elem r) . envStackRegs)
-
--- | Allocate a new global unnamed metadata identifier
-getMetaUniqueId :: LlvmM MetaId
-getMetaUniqueId = LlvmM $ \env ->
-    return (envFreshMeta env, env { envFreshMeta = succ $ envFreshMeta env })
-
--- | Get the LLVM version we are generating code for
-getLlvmVer :: LlvmM LlvmVersion
-getLlvmVer = getEnv envVersion
-
--- | Dumps the document if the corresponding flag has been set by the user
-dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM ()
-dumpIfSetLlvm flag hdr fmt doc = do
-  logger <- getLogger
-  liftIO $ putDumpFileMaybe logger flag hdr fmt doc
-
--- | Prints the given contents to the output handle
-renderLlvm :: Outp.SDoc -> LlvmM ()
-renderLlvm sdoc = do
-
-    -- Write to output
-    ctx <- llvmCgContext <$> getConfig
-    out <- getEnv envOutput
-    liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc
-
-    -- Dump, if requested
-    dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc
-    return ()
-
--- | Marks a variable as "used"
-markUsedVar :: LlvmVar -> LlvmM ()
-markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env }
-
--- | Return all variables marked as "used" so far
-getUsedVars :: LlvmM [LlvmVar]
-getUsedVars = getEnv envUsedVars
-
--- | Saves that at some point we didn't know the type of the label and
--- generated a reference to a type variable instead
-saveAlias :: LMString -> LlvmM ()
-saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl }
-
--- | Sets metadata node for a given unique
-setUniqMeta :: Unique -> MetaId -> LlvmM ()
-setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m }
-
--- | Gets metadata node for given unique
-getUniqMeta :: Unique -> LlvmM (Maybe MetaId)
-getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)
-
--- ----------------------------------------------------------------------------
--- * Internal functions
---
-
--- | Here we pre-initialise some functions that are used internally by GHC
--- so as to make sure they have the most general type in the case that
--- user code also uses these functions but with a different type than GHC
--- internally. (Main offender is treating return type as 'void' instead of
--- 'void *'). Fixes trac #5486.
-ghcInternalFunctions :: LlvmM ()
-ghcInternalFunctions = do
-    platform <- getPlatform
-    let w = llvmWord platform
-        cint = LMInt $ widthInBits $ cIntWidth platform
-    mk "memcmp" cint [i8Ptr, i8Ptr, w]
-    mk "memcpy" i8Ptr [i8Ptr, i8Ptr, w]
-    mk "memmove" i8Ptr [i8Ptr, i8Ptr, w]
-    mk "memset" i8Ptr [i8Ptr, w, w]
-    mk "newSpark" w [i8Ptr, i8Ptr]
-  where
-    mk n ret args = do
-      let n' = fsLit n
-          decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
-                                 FixedArgs (tysToParams args) Nothing
-      renderLlvm $ ppLlvmFunctionDecl decl
-      funInsert n' (LMFunction decl)
-
--- ----------------------------------------------------------------------------
--- * Label handling
---
-
--- | Pretty print a 'CLabel'.
-strCLabel_llvm :: CLabel -> LlvmM LMString
-strCLabel_llvm lbl = do
-    ctx <- llvmCgContext <$> getConfig
-    platform <- getPlatform
-    let sdoc = pprCLabel platform lbl
-        str = Outp.showSDocOneLine ctx sdoc
-    return (fsLit str)
-
--- ----------------------------------------------------------------------------
--- * Global variables / forward references
---
-
--- | Create/get a pointer to a global value. Might return an alias if
--- the value in question hasn't been defined yet. We especially make
--- no guarantees on the type of the returned pointer.
-getGlobalPtr :: LMString -> LlvmM LlvmVar
-getGlobalPtr llvmLbl = do
-  m_ty <- funLookup llvmLbl
-  let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing
-  case m_ty of
-    -- Directly reference if we have seen it already
-    Just ty -> do
-      if llvmLbl `elem` (map fsLit ["newSpark", "memmove", "memcpy", "memcmp", "memset"])
-        then return $ mkGlbVar (llvmLbl) ty Global
-        else return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global
-    -- Otherwise use a forward alias of it
-    Nothing -> do
-      saveAlias llvmLbl
-      return $ mkGlbVar llvmLbl i8 Alias
-
--- | Derive the definition label. It has an identified
--- structure type.
-llvmDefLabel :: LMString -> LMString
-llvmDefLabel = (`appendFS` fsLit "$def")
-
--- | Generate definitions for aliases forward-referenced by @getGlobalPtr@.
---
--- Must be called at a point where we are sure that no new global definitions
--- will be generated anymore!
-generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
-generateExternDecls = do
-  delayed <- fmap nonDetEltsUniqSet $ getEnv envAliases
-  -- This is non-deterministic but we do not
-  -- currently support deterministic code-generation.
-  -- See Note [Unique Determinism and code generation]
-  defss <- flip mapM delayed $ \lbl -> do
-    m_ty <- funLookup lbl
-    case m_ty of
-      -- If we have a definition we've already emitted the proper aliases
-      -- when the symbol itself was emitted by @aliasify@
-      Just _ -> return []
-
-      -- If we don't have a definition this is an external symbol and we
-      -- need to emit a declaration
-      Nothing ->
-        let var = LMGlobalVar lbl i8Ptr External Nothing Nothing Global
-        in return [LMGlobal var Nothing]
-
-  -- Reset forward list
-  modifyEnv $ \env -> env { envAliases = emptyUniqSet }
-  return (concat defss, [])
-
--- | Is a variable one of the special @$llvm@ globals?
-isBuiltinLlvmVar :: LlvmVar -> Bool
-isBuiltinLlvmVar (LMGlobalVar lbl _ _ _ _ _) =
-    "$llvm" `isPrefixOf` unpackFS lbl
-isBuiltinLlvmVar _ = False
-
--- | Here we take a global variable definition, rename it with a
--- @$def@ suffix, and generate the appropriate alias.
-aliasify :: LMGlobal -> LlvmM [LMGlobal]
--- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
--- Here we obtain the indirectee's precise type and introduce
--- fresh aliases to both the precise typed label (lbl$def) and the i8*
--- typed (regular) label of it with the matching new names.
-aliasify (LMGlobal var@(LMGlobalVar lbl ty@LMAlias{} link sect align Alias)
-                   (Just orig))
-  | not $ isBuiltinLlvmVar var = do
-    let defLbl = llvmDefLabel lbl
-        LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig
-        defOrigLbl = llvmDefLabel origLbl
-        orig' = LMStaticPointer (LMGlobalVar origLbl i8Ptr oLnk Nothing Nothing Alias)
-    origType <- funLookup origLbl
-    let defOrig = LMBitc (LMStaticPointer (LMGlobalVar defOrigLbl
-                                           (pLift $ fromJust origType) oLnk
-                                           Nothing Nothing Alias))
-                         (pLift ty)
-    pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig)
-         , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig')
-         ]
-aliasify (LMGlobal var val)
-  | not $ isBuiltinLlvmVar var = do
-    let LMGlobalVar lbl ty link sect align const = var
-
-        defLbl = llvmDefLabel lbl
-        defVar = LMGlobalVar defLbl ty Internal sect align const
-
-        defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const
-        aliasVar = LMGlobalVar lbl i8Ptr link Nothing Nothing Alias
-        aliasVal = LMBitc (LMStaticPointer defPtrVar) i8Ptr
-
-    -- we need to mark the $def symbols as used so LLVM doesn't forget which
-    -- section they need to go in. This will vanish once we switch away from
-    -- mangling sections for TNTC.
-    markUsedVar defVar
-
-    return [ LMGlobal defVar val
-           , LMGlobal aliasVar (Just aliasVal)
-           ]
-aliasify global = pure [global]
-
--- Note [Llvm Forward References]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- The issue here is that LLVM insists on being strongly typed at
--- every corner, so the first time we mention something, we have to
--- settle what type we assign to it. That makes things awkward, as Cmm
--- will often reference things before their definition, and we have no
--- idea what (LLVM) type it is going to be before that point.
---
--- Our work-around is to define "aliases" of a standard type (i8 *) in
--- these kind of situations, which we later tell LLVM to be either
--- references to their actual local definitions (involving a cast) or
--- an external reference. This obviously only works for pointers.
---
--- In particular when we encounter a reference to a symbol in a chunk of
--- C-- there are three possible scenarios,
---
---   1. We have already seen a definition for the referenced symbol. This
---      means we already know its type.
---
---   2. We have not yet seen a definition but we will find one later in this
---      compilation unit. Since we want to be a good consumer of the
---      C-- streamed to us from upstream, we don't know the type of the
---      symbol at the time when we must emit the reference.
---
---   3. We have not yet seen a definition nor will we find one in this
---      compilation unit. In this case the reference refers to an
---      external symbol for which we do not know the type.
---
--- Let's consider case (2) for a moment: say we see a reference to
--- the symbol @fooBar@ for which we have not seen a definition. As we
--- do not know the symbol's type, we assume it is of type @i8*@ and emit
--- the appropriate casts in @getSymbolPtr@. Later on, when we
--- encounter the definition of @fooBar@ we emit it but with a modified
--- name, @fooBar$def@ (which we'll call the definition symbol), to
--- since we have already had to assume that the symbol @fooBar@
--- is of type @i8*@. We then emit @fooBar@ itself as an alias
--- of @fooBar$def@ with appropriate casts. This all happens in
--- @aliasify@.
---
--- Case (3) is quite similar to (2): References are emitted assuming
--- the referenced symbol is of type @i8*@. When we arrive at the end of
--- the compilation unit and realize that the symbol is external, we emit
--- an LLVM @external global@ declaration for the symbol @fooBar@
--- (handled in @generateExternDecls@). This takes advantage of the
--- fact that the aliases produced by @aliasify@ for exported symbols
--- have external linkage and can therefore be used as normal symbols.
---
--- Historical note: As of release 3.5 LLVM does not allow aliases to
--- refer to declarations. This the reason why aliases are produced at the
--- point of definition instead of the point of usage, as was previously
--- done. See #9142 for details.
---
--- Finally, case (1) is trivial. As we already have a definition for
--- and therefore know the type of the referenced symbol, we can do
--- away with casting the alias to the desired type in @getSymbolPtr@
--- and instead just emit a reference to the definition symbol directly.
--- This is the @Just@ case in @getSymbolPtr@.
---
--- Note that we must take care not to turn LLVM's builtin variables into
--- aliases (e.g. $llvm.global_ctors) since this confuses LLVM.
diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ /dev/null
@@ -1,2237 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE GADTs, MultiWayIf #-}
-{-# OPTIONS_GHC -fno-warn-type-defaults #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
--- | Handle conversion of CmmProc to LLVM code.
-module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Platform.Regs ( activeStgRegs )
-
-import GHC.Llvm
-import GHC.CmmToLlvm.Base
-import GHC.CmmToLlvm.Config
-import GHC.CmmToLlvm.Regs
-
-import GHC.Cmm.BlockId
-import GHC.Cmm.CLabel
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Cmm.Switch
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Collections
-
-import GHC.Data.FastString
-import GHC.Data.OrdList
-
-import GHC.Types.ForeignCall
-import GHC.Types.Unique.Supply
-import GHC.Types.Unique
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic.Plain (massert)
-import qualified GHC.Utils.Panic as Panic
-import GHC.Utils.Misc
-
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Writer
-import Control.Monad
-
-import qualified Data.Semigroup as Semigroup
-import Data.List ( nub )
-import Data.Maybe ( catMaybes )
-
-type Atomic = Bool
-type LlvmStatements = OrdList LlvmStatement
-
-data Signage = Signed | Unsigned deriving (Eq, Show)
-
--- -----------------------------------------------------------------------------
--- | Top-level of the LLVM proc Code generator
---
-genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]
-genLlvmProc (CmmProc infos lbl live graph) = do
-    let blocks = toBlockListEntryFirstFalseFallthrough graph
-    (lmblocks, lmdata) <- basicBlocksCodeGen live blocks
-    let info = mapLookup (g_entry graph) infos
-        proc = CmmProc info lbl live (ListGraph lmblocks)
-    return (proc:lmdata)
-
-genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!"
-
--- -----------------------------------------------------------------------------
--- * Block code generation
---
-
--- | Generate code for a list of blocks that make up a complete
--- procedure. The first block in the list is expected to be the entry
--- point.
-basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock]
-                      -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
-basicBlocksCodeGen _    []                     = panic "no entry block!"
-basicBlocksCodeGen live cmmBlocks
-  = do -- Emit the prologue
-       -- N.B. this must be its own block to ensure that the entry block of the
-       -- procedure has no predecessors, as required by the LLVM IR. See #17589
-       -- and #11649.
-       bid <- newBlockId
-       (prologue, prologueTops) <- funPrologue live cmmBlocks
-       let entryBlock = BasicBlock bid (fromOL prologue)
-
-       -- Generate code
-       (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks
-
-       -- Compose
-       return (entryBlock : blocks, prologueTops ++ concat topss)
-
-
--- | Generate code for one block
-basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )
-basicBlockCodeGen block
-  = do let (_, nodes, tail)  = blockSplit block
-           id = entryLabel block
-       (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes
-       (tail_instrs, top')  <- stmtToInstrs tail
-       let instrs = fromOL (mid_instrs `appOL` tail_instrs)
-       return (BasicBlock id instrs, top' ++ top)
-
--- -----------------------------------------------------------------------------
--- * CmmNode code generation
---
-
--- A statement conversion return data.
---   * LlvmStatements: The compiled LLVM statements.
---   * LlvmCmmDecl: Any global data needed.
-type StmtData = (LlvmStatements, [LlvmCmmDecl])
-
-
--- | Convert a list of CmmNode's to LlvmStatement's
-stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData
-stmtsToInstrs stmts
-   = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts
-        return (concatOL instrss, concat topss)
-
-
--- | Convert a CmmStmt to a list of LlvmStatement's
-stmtToInstrs :: CmmNode e x -> LlvmM StmtData
-stmtToInstrs stmt = case stmt of
-
-    CmmComment _         -> return (nilOL, []) -- nuke comments
-    CmmTick    _         -> return (nilOL, [])
-    CmmUnwind  {}        -> return (nilOL, [])
-
-    CmmAssign reg src    -> genAssign reg src
-    CmmStore addr src align
-                         -> genStore addr src align
-
-    CmmBranch id         -> genBranch id
-    CmmCondBranch arg true false likely
-                         -> genCondBranch arg true false likely
-    CmmSwitch arg ids    -> genSwitch arg ids
-
-    -- Foreign Call
-    CmmUnsafeForeignCall target res args
-        -> genCall target res args
-
-    -- Tail call
-    CmmCall { cml_target = arg,
-              cml_args_regs = live } -> genJump arg live
-
-    _ -> panic "Llvm.CodeGen.stmtToInstrs"
-
--- | Wrapper function to declare an instrinct function by function type
-getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData
-getInstrinct2 fname fty@(LMFunction funSig) = do
-
-    let fv   = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant
-
-    fn <- funLookup fname
-    tops <- case fn of
-      Just _  ->
-        return []
-      Nothing -> do
-        funInsert fname fty
-        un <- getUniqueM
-        let lbl = mkAsmTempLabel un
-        return [CmmData (Section Data lbl) [([],[fty])]]
-
-    return (fv, nilOL, tops)
-
-getInstrinct2 _ _ = error "getInstrinct2: Non-function type!"
-
--- | Declares an instrinct function by return and parameter types
-getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData
-getInstrinct fname retTy parTys =
-    let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy
-                    FixedArgs (tysToParams parTys) Nothing
-        fty = LMFunction funSig
-    in getInstrinct2 fname fty
-
--- | Memory barrier instruction for LLVM >= 3.0
-barrier :: LlvmM StmtData
-barrier = do
-    let s = Fence False SyncSeqCst
-    return (unitOL s, [])
-
--- | Insert a 'barrier', unless the target platform is in the provided list of
---   exceptions (where no code will be emitted instead).
-barrierUnless :: [Arch] -> LlvmM StmtData
-barrierUnless exs = do
-    platform <- getPlatform
-    if platformArch platform `elem` exs
-        then return (nilOL, [])
-        else barrier
-
--- | Foreign Calls
-genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData
-
--- Barriers need to be handled specially as they are implemented as LLVM
--- intrinsic functions.
-genCall (PrimTarget MO_ReadBarrier) _ _ =
-    barrierUnless [ArchX86, ArchX86_64]
-
-genCall (PrimTarget MO_WriteBarrier) _ _ =
-    barrierUnless [ArchX86, ArchX86_64]
-
-genCall (PrimTarget MO_Touch) _ _ =
-    return (nilOL, [])
-
-genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do
-    dstV <- getCmmRegW (CmmLocal dst)
-    let ty = cmmToLlvmType $ localRegType dst
-        width = widthToLlvmFloat w
-    castV <- lift $ mkLocalVar ty
-    ve <- exprToVarW e
-    statement $ Assignment castV $ Cast LM_Uitofp ve width
-    statement $ Store castV dstV Nothing
-
-genCall (PrimTarget (MO_UF_Conv _)) [_] args =
-    panic $ "genCall: Too many arguments to MO_UF_Conv. " ++
-    "Can only handle 1, given" ++ show (length args) ++ "."
-
--- Handle prefetching data
-genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args
-  | 0 <= localityInt && localityInt <= 3 = runStmtsDecls $ do
-    let argTy = [i8Ptr, i32, i32, i32]
-        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
-                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
-
-    let (_, arg_hints) = foreignTargetHints t
-    let args_hints' = zip args arg_hints
-    argVars <- arg_varsW args_hints' ([], nilOL, [])
-    fptr    <- liftExprData $ getFunPtr funTy t
-    argVars' <- castVarsW Signed $ zip argVars argTy
-
-    let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1]
-    statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) []
-  | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt)
-
--- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg
--- and return types
-genCall t@(PrimTarget (MO_PopCnt w)) dsts args =
-    genCallSimpleCast w t dsts args
-
-genCall t@(PrimTarget (MO_Pdep w)) dsts args =
-    genCallSimpleCast2 w t dsts args
-genCall t@(PrimTarget (MO_Pext w)) dsts args =
-    genCallSimpleCast2 w t dsts args
-genCall t@(PrimTarget (MO_Clz w)) dsts args =
-    genCallSimpleCast w t dsts args
-genCall t@(PrimTarget (MO_Ctz w)) dsts args =
-    genCallSimpleCast w t dsts args
-genCall t@(PrimTarget (MO_BSwap w)) dsts args =
-    genCallSimpleCast w t dsts args
-genCall t@(PrimTarget (MO_BRev w)) dsts args =
-    genCallSimpleCast w t dsts args
-
-genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do
-    addrVar <- exprToVarW addr
-    nVar <- exprToVarW n
-    let targetTy = widthToLlvmInt width
-        ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)
-    ptrVar <- doExprW (pLift targetTy) ptrExpr
-    dstVar <- getCmmRegW (CmmLocal dst)
-    let op = case amop of
-               AMO_Add  -> LAO_Add
-               AMO_Sub  -> LAO_Sub
-               AMO_And  -> LAO_And
-               AMO_Nand -> LAO_Nand
-               AMO_Or   -> LAO_Or
-               AMO_Xor  -> LAO_Xor
-    retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst
-    statement $ Store retVar dstVar Nothing
-
-genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do
-    dstV <- getCmmRegW (CmmLocal dst)
-    v1 <- genLoadW True addr (localRegType dst) NaturallyAligned
-    statement $ Store v1 dstV Nothing
-
-genCall (PrimTarget (MO_Cmpxchg _width))
-        [dst] [addr, old, new] = runStmtsDecls $ do
-    addrVar <- exprToVarW addr
-    oldVar <- exprToVarW old
-    newVar <- exprToVarW new
-    let targetTy = getVarType oldVar
-        ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)
-    ptrVar <- doExprW (pLift targetTy) ptrExpr
-    dstVar <- getCmmRegW (CmmLocal dst)
-    retVar <- doExprW (LMStructU [targetTy,i1])
-              $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst
-    retVar' <- doExprW targetTy $ ExtractV retVar 0
-    statement $ Store retVar' dstVar Nothing
-
-genCall (PrimTarget (MO_Xchg _width)) [dst] [addr, val] = runStmtsDecls $ do
-    dstV <- getCmmRegW (CmmLocal dst) :: WriterT LlvmAccum LlvmM LlvmVar
-    addrVar <- exprToVarW addr
-    valVar <- exprToVarW val
-    let ptrTy = pLift $ getVarType valVar
-        ptrExpr = Cast LM_Inttoptr addrVar ptrTy
-    ptrVar <- doExprW ptrTy ptrExpr
-    resVar <- doExprW (getVarType valVar) (AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst)
-    statement $ Store resVar dstV Nothing
-
-genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do
-    addrVar <- exprToVarW addr
-    valVar <- exprToVarW val
-    let ptrTy = pLift $ getVarType valVar
-        ptrExpr = Cast LM_Inttoptr addrVar ptrTy
-    ptrVar <- doExprW ptrTy ptrExpr
-    statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst
-
--- Handle memcpy function specifically since llvm's intrinsic version takes
--- some extra parameters.
-genCall t@(PrimTarget op) [] args
- | Just align <- machOpMemcpyishAlign op
- = do
-   platform <- getPlatform
-   runStmtsDecls $ do
-    let isVolTy = [i1]
-        isVolVal = [mkIntLit i1 0]
-        argTy | MO_Memset _ <- op = [i8Ptr, i8,    llvmWord platform, i32] ++ isVolTy
-              | otherwise         = [i8Ptr, i8Ptr, llvmWord platform, i32] ++ isVolTy
-        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
-                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
-
-    let (_, arg_hints) = foreignTargetHints t
-    let args_hints = zip args arg_hints
-    argVars       <- arg_varsW args_hints ([], nilOL, [])
-    fptr          <- getFunPtrW funTy t
-    argVars' <- castVarsW Signed $ zip argVars argTy
-
-    let alignVal = mkIntLit i32 align
-        arguments = argVars' ++ (alignVal:isVolVal)
-    statement $ Expr $ Call StdCall fptr arguments []
-
--- We handle MO_U_Mul2 by simply using a 'mul' instruction, but with operands
--- twice the width (we first zero-extend them), e.g., on 64-bit arch we will
--- generate 'mul' on 128-bit operands. Then we only need some plumbing to
--- extract the two 64-bit values out of 128-bit result.
-genCall (PrimTarget (MO_U_Mul2 w)) [dstH, dstL] [lhs, rhs] = runStmtsDecls $ do
-    let width = widthToLlvmInt w
-        bitWidth = widthInBits w
-        width2x = LMInt (bitWidth * 2)
-    -- First zero-extend the operands ('mul' instruction requires the operands
-    -- and the result to be of the same type). Note that we don't use 'castVars'
-    -- because it tries to do LM_Sext.
-    lhsVar <- exprToVarW lhs
-    rhsVar <- exprToVarW rhs
-    lhsExt <- doExprW width2x $ Cast LM_Zext lhsVar width2x
-    rhsExt <- doExprW width2x $ Cast LM_Zext rhsVar width2x
-    -- Do the actual multiplication (note that the result is also 2x width).
-    retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt
-    -- Extract the lower bits of the result into retL.
-    retL <- doExprW width $ Cast LM_Trunc retV width
-    -- Now we unsigned right-shift the higher bits by width.
-    let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width
-    retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit
-    -- And extract them into retH.
-    retH <- doExprW width $ Cast LM_Trunc retShifted width
-    dstRegL <- getCmmRegW (CmmLocal dstL)
-    dstRegH <- getCmmRegW (CmmLocal dstH)
-    statement $ Store retL dstRegL Nothing
-    statement $ Store retH dstRegH Nothing
-
-genCall (PrimTarget (MO_S_Mul2 w)) [dstC, dstH, dstL] [lhs, rhs] = runStmtsDecls $ do
-    let width = widthToLlvmInt w
-        bitWidth = widthInBits w
-        width2x = LMInt (bitWidth * 2)
-    -- First sign-extend the operands ('mul' instruction requires the operands
-    -- and the result to be of the same type). Note that we don't use 'castVars'
-    -- because it tries to do LM_Sext.
-    lhsVar <- exprToVarW lhs
-    rhsVar <- exprToVarW rhs
-    lhsExt <- doExprW width2x $ Cast LM_Sext lhsVar width2x
-    rhsExt <- doExprW width2x $ Cast LM_Sext rhsVar width2x
-    -- Do the actual multiplication (note that the result is also 2x width).
-    retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt
-    -- Extract the lower bits of the result into retL.
-    retL <- doExprW width $ Cast LM_Trunc retV width
-    -- Now we signed right-shift the higher bits by width.
-    let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width
-    retShifted <- doExprW width2x $ LlvmOp LM_MO_AShr retV widthLlvmLit
-    -- And extract them into retH.
-    retH <- doExprW width $ Cast LM_Trunc retShifted width
-    -- Check if the carry is useful by doing a full arithmetic right shift on
-    -- retL and comparing the result with retH
-    let widthLlvmLitm1 = LMLitVar $ LMIntLit (fromIntegral bitWidth - 1) width
-    retH' <- doExprW width $ LlvmOp LM_MO_AShr retL widthLlvmLitm1
-    retC1  <- doExprW i1 $ Compare LM_CMP_Ne retH retH' -- Compare op returns a 1-bit value (i1)
-    retC   <- doExprW width $ Cast LM_Zext retC1 width  -- so we zero-extend it
-    dstRegL <- getCmmRegW (CmmLocal dstL)
-    dstRegH <- getCmmRegW (CmmLocal dstH)
-    dstRegC <- getCmmRegW (CmmLocal dstC)
-    statement $ Store retL dstRegL Nothing
-    statement $ Store retH dstRegH Nothing
-    statement $ Store retC dstRegC Nothing
-
--- MO_U_QuotRem2 is another case we handle by widening the registers to double
--- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The
--- main difference here is that we need to combine two words into one register
--- and then use both 'udiv' and 'urem' instructions to compute the result.
-genCall (PrimTarget (MO_U_QuotRem2 w))
-        [dstQ, dstR] [lhsH, lhsL, rhs] = runStmtsDecls $ do
-    let width = widthToLlvmInt w
-        bitWidth = widthInBits w
-        width2x = LMInt (bitWidth * 2)
-    -- First zero-extend all parameters to double width.
-    let zeroExtend expr = do
-            var <- exprToVarW expr
-            doExprW width2x $ Cast LM_Zext var width2x
-    lhsExtH <- zeroExtend lhsH
-    lhsExtL <- zeroExtend lhsL
-    rhsExt <- zeroExtend rhs
-    -- Now we combine the first two parameters (that represent the high and low
-    -- bits of the value). So first left-shift the high bits to their position
-    -- and then bit-or them with the low bits.
-    let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width
-    lhsExtHShifted <- doExprW width2x $ LlvmOp LM_MO_Shl lhsExtH widthLlvmLit
-    lhsExt <- doExprW width2x $ LlvmOp LM_MO_Or lhsExtHShifted lhsExtL
-    -- Finally, we can call 'udiv' and 'urem' to compute the results.
-    retExtDiv <- doExprW width2x $ LlvmOp LM_MO_UDiv lhsExt rhsExt
-    retExtRem <- doExprW width2x $ LlvmOp LM_MO_URem lhsExt rhsExt
-    -- And since everything is in 2x width, we need to truncate the results and
-    -- then return them.
-    let narrow var = doExprW width $ Cast LM_Trunc var width
-    retDiv <- narrow retExtDiv
-    retRem <- narrow retExtRem
-    dstRegQ <- lift $ getCmmReg (CmmLocal dstQ)
-    dstRegR <- lift $ getCmmReg (CmmLocal dstR)
-    statement $ Store retDiv dstRegQ Nothing
-    statement $ Store retRem dstRegR Nothing
-
--- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from
--- which we need to extract the actual values.
-genCall t@(PrimTarget (MO_AddIntC w)) [dstV, dstO] [lhs, rhs] =
-    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
-genCall t@(PrimTarget (MO_SubIntC w)) [dstV, dstO] [lhs, rhs] =
-    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
-
--- Similar to MO_{Add,Sub}IntC, but MO_Add2 expects the first element of the
--- return tuple to be the overflow bit and the second element to contain the
--- actual result of the addition. So we still use genCallWithOverflow but swap
--- the return registers.
-genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] =
-    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
-
-genCall t@(PrimTarget (MO_AddWordC w)) [dstV, dstO] [lhs, rhs] =
-    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
-
-genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] =
-    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
-
--- Handle all other foreign calls and prim ops.
-genCall target res args = do
-  platform <- getPlatform
-  runStmtsDecls $ do
-
-    -- extract Cmm call convention, and translate to LLVM call convention
-    let lmconv = case target of
-            ForeignTarget _ (ForeignConvention conv _ _ _) ->
-              case conv of
-                 StdCallConv  -> case platformArch platform of
-                                 ArchX86    -> CC_X86_Stdcc
-                                 ArchX86_64 -> CC_X86_Stdcc
-                                 _          -> CC_Ccc
-                 CCallConv    -> CC_Ccc
-                 CApiConv     -> CC_Ccc
-                 PrimCallConv       -> panic "GHC.CmmToLlvm.CodeGen.genCall: PrimCallConv"
-                 JavaScriptCallConv -> panic "GHC.CmmToLlvm.CodeGen.genCall: JavaScriptCallConv"
-
-            PrimTarget   _ -> CC_Ccc
-
-    {-
-        CC_Ccc of the possibilities here are a worry with the use of a custom
-        calling convention for passing STG args. In practice the more
-        dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
-
-        The native code generator only handles StdCall and CCallConv.
-    -}
-
-    -- parameter types
-    let arg_type (_, AddrHint) = (i8Ptr, [])
-        -- cast pointers to i8*. Llvm equivalent of void*
-        arg_type (expr, hint) =
-            case cmmToLlvmType $ cmmExprType platform expr of
-              ty@(LMInt n) | n < 64 && lmconv == CC_Ccc && platformCConvNeedsExtension platform
-                 -> (ty, if hint == SignedHint then [SignExt] else [ZeroExt])
-              ty -> (ty, [])
-
-    -- ret type
-    let ret_type [] = LMVoid
-        ret_type [(_, AddrHint)] = i8Ptr
-        ret_type [(reg, _)]      = cmmToLlvmType $ localRegType reg
-        ret_type t = panic $ "genCall: Too many return values! Can only handle"
-                        ++ " 0 or 1, given " ++ show (length t) ++ "."
-
-    -- call attributes
-    let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs
-                | otherwise     = llvmStdFunAttrs
-
-        never_returns = case target of
-             ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True
-             _ -> False
-
-    -- fun type
-    let (res_hints, arg_hints) = foreignTargetHints target
-    let args_hints = zip args arg_hints
-    let ress_hints = zip res  res_hints
-    let ccTy  = StdCall -- tail calls should be done through CmmJump
-    let retTy = ret_type ress_hints
-    let argTy = map arg_type args_hints
-    let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
-                             lmconv retTy FixedArgs argTy (llvmFunAlign platform)
-
-
-    argVars <- arg_varsW args_hints ([], nilOL, [])
-    fptr    <- getFunPtrW funTy target
-
-    let doReturn | ccTy == TailCall  = statement $ Return Nothing
-                 | never_returns     = statement $ Unreachable
-                 | otherwise         = return ()
-
-
-    -- make the actual call
-    case retTy of
-        LMVoid ->
-            statement $ Expr $ Call ccTy fptr argVars fnAttrs
-        _ -> do
-            v1 <- doExprW retTy $ Call ccTy fptr argVars fnAttrs
-            -- get the return register
-            let ret_reg [reg] = reg
-                ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
-                                ++ " 1, given " ++ show (length t) ++ "."
-            let creg = ret_reg res
-            vreg <- getCmmRegW (CmmLocal creg)
-            if retTy == pLower (getVarType vreg)
-                then do
-                    statement $ Store v1 vreg Nothing
-                    doReturn
-                else do
-                    let ty = pLower $ getVarType vreg
-                    let op = case ty of
-                            vt | isPointer vt -> LM_Bitcast
-                               | isInt     vt -> LM_Ptrtoint
-                               | otherwise    ->
-                                   panic $ "genCall: CmmReg bad match for"
-                                        ++ " returned type!"
-
-                    v2 <- doExprW ty $ Cast op v1 ty
-                    statement $ Store v2 vreg Nothing
-                    doReturn
-
--- | Generate a call to an LLVM intrinsic that performs arithmetic operation
--- with overflow bit (i.e., returns a struct containing the actual result of the
--- operation and an overflow bit). This function will also extract the overflow
--- bit and zero-extend it (all the corresponding Cmm PrimOps represent the
--- overflow "bit" as a usual Int# or Word#).
-genCallWithOverflow
-  :: ForeignTarget -> Width -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData
-genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do
-    -- So far this was only tested for the following four CallishMachOps.
-    let valid = op `elem`   [ MO_Add2 w
-                            , MO_AddIntC w
-                            , MO_SubIntC w
-                            , MO_AddWordC w
-                            , MO_SubWordC w
-                            ]
-    massert valid
-    let width = widthToLlvmInt w
-    -- This will do most of the work of generating the call to the intrinsic and
-    -- extracting the values from the struct.
-    (value, overflowBit, (stmts, top)) <-
-      genCallExtract t w (lhs, rhs) (width, i1)
-    -- value is i<width>, but overflowBit is i1, so we need to cast (Cmm expects
-    -- both to be i<width>)
-    (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width
-    dstRegV <- getCmmReg (CmmLocal dstV)
-    dstRegO <- getCmmReg (CmmLocal dstO)
-    let storeV = Store value dstRegV Nothing
-        storeO = Store overflow dstRegO Nothing
-    return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top)
-genCallWithOverflow _ _ _ _ =
-    panic "genCallExtract: wrong ForeignTarget or number of arguments"
-
--- | A helper function for genCallWithOverflow that handles generating the call
--- to the LLVM intrinsic and extracting the result from the struct to LlvmVars.
-genCallExtract
-    :: ForeignTarget           -- ^ PrimOp
-    -> Width                   -- ^ Width of the operands.
-    -> (CmmActual, CmmActual)  -- ^ Actual arguments.
-    -> (LlvmType, LlvmType)    -- ^ LLVM types of the returned struct.
-    -> LlvmM (LlvmVar, LlvmVar, StmtData)
-genCallExtract target@(PrimTarget op) w (argA, argB) (llvmTypeA, llvmTypeB) = do
-    let width = widthToLlvmInt w
-        argTy = [width, width]
-        retTy = LMStructU [llvmTypeA, llvmTypeB]
-
-    -- Process the arguments.
-    let args_hints = zip [argA, argB] (snd $ foreignTargetHints target)
-    (argsV1, args1, top1) <- arg_vars args_hints ([], nilOL, [])
-    (argsV2, args2) <- castVars Signed $ zip argsV1 argTy
-
-    -- Get the function and make the call.
-    fname <- cmmPrimOpFunctions op
-    (fptr, _, top2) <- getInstrinct fname retTy argTy
-    -- We use StdCall for primops. See also the last case of genCall.
-    (retV, call) <- doExpr retTy $ Call StdCall fptr argsV2 []
-
-    -- This will result in a two element struct, we need to use "extractvalue"
-    -- to get them out of it.
-    (res1, ext1) <- doExpr llvmTypeA (ExtractV retV 0)
-    (res2, ext2) <- doExpr llvmTypeB (ExtractV retV 1)
-
-    let stmts = args1 `appOL` args2 `snocOL` call `snocOL` ext1 `snocOL` ext2
-        tops = top1 ++ top2
-    return (res1, res2, (stmts, tops))
-
-genCallExtract _ _ _ _ =
-    panic "genCallExtract: unsupported ForeignTarget"
-
--- Handle simple function call that only need simple type casting, of the form:
---   truncate arg >>= \a -> call(a) >>= zext
---
--- since GHC only really has i32 and i64 types and things like Word8 are backed
--- by an i32 and just present a logical i8 range. So we must handle conversions
--- from i32 to i8 explicitly as LLVM is strict about types.
-genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
-              -> LlvmM StmtData
-genCallSimpleCast w t@(PrimTarget op) [dst] args = do
-    let width = widthToLlvmInt w
-        dstTy = cmmToLlvmType $ localRegType dst
-
-    fname                       <- cmmPrimOpFunctions op
-    (fptr, _, top3)             <- getInstrinct fname width [width]
-
-    dstV                        <- getCmmReg (CmmLocal dst)
-
-    let (_, arg_hints) = foreignTargetHints t
-    let args_hints = zip args arg_hints
-    (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])
-    (argsV', stmts4)            <- castVars Signed $ zip argsV [width]
-    (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []
-    (retVs', stmts5)            <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
-    let retV'                    = singletonPanic "genCallSimpleCast" retVs'
-    let s2                       = Store retV' dstV Nothing
-
-    let stmts = stmts2 `appOL` stmts4 `snocOL`
-                s1 `appOL` stmts5 `snocOL` s2
-    return (stmts, top2 ++ top3)
-genCallSimpleCast _ _ dsts _ =
-    panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts")
-
--- Handle simple function call that only need simple type casting, of the form:
---   truncate arg >>= \a -> call(a) >>= zext
---
--- since GHC only really has i32 and i64 types and things like Word8 are backed
--- by an i32 and just present a logical i8 range. So we must handle conversions
--- from i32 to i8 explicitly as LLVM is strict about types.
-genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
-              -> LlvmM StmtData
-genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do
-    let width = widthToLlvmInt w
-        dstTy = cmmToLlvmType $ localRegType dst
-
-    fname                       <- cmmPrimOpFunctions op
-    (fptr, _, top3)             <- getInstrinct fname width (const width <$> args)
-
-    dstV                        <- getCmmReg (CmmLocal dst)
-
-    let (_, arg_hints) = foreignTargetHints t
-    let args_hints = zip args arg_hints
-    (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])
-    (argsV', stmts4)            <- castVars Signed $ zip argsV (const width <$> argsV)
-    (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []
-    (retVs', stmts5)             <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
-    let retV'                    = singletonPanic "genCallSimpleCast2" retVs'
-    let s2                       = Store retV' dstV Nothing
-
-    let stmts = stmts2 `appOL` stmts4 `snocOL`
-                s1 `appOL` stmts5 `snocOL` s2
-    return (stmts, top2 ++ top3)
-genCallSimpleCast2 _ _ dsts _ =
-    panic ("genCallSimpleCast2: " ++ show (length dsts) ++ " dsts")
-
--- | Create a function pointer from a target.
-getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget
-           -> WriterT LlvmAccum LlvmM LlvmVar
-getFunPtrW funTy targ = liftExprData $ getFunPtr funTy targ
-
--- | Create a function pointer from a target.
-getFunPtr :: (LMString -> LlvmType) -> ForeignTarget
-          -> LlvmM ExprData
-getFunPtr funTy targ = case targ of
-    ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do
-        name <- strCLabel_llvm lbl
-        getHsFunc' name (funTy name)
-
-    ForeignTarget expr _ -> do
-        (v1, stmts, top) <- exprToVar expr
-        let fty = funTy $ fsLit "dynamic"
-            cast = case getVarType v1 of
-                ty | isPointer ty -> LM_Bitcast
-                ty | isInt ty     -> LM_Inttoptr
-
-                ty -> pprPanic "genCall: Expr is of bad type for function" $
-                  text " call! " <> lparen <> ppr ty <> rparen
-
-        (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
-        return (v2, stmts `snocOL` s1, top)
-
-    PrimTarget mop -> do
-        name <- cmmPrimOpFunctions mop
-        let fty = funTy name
-        getInstrinct2 name fty
-
--- | Conversion of call arguments.
-arg_varsW :: [(CmmActual, ForeignHint)]
-          -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-          -> WriterT LlvmAccum LlvmM [LlvmVar]
-arg_varsW xs ys = do
-    (vars, stmts, decls) <- lift $ arg_vars xs ys
-    tell $ LlvmAccum stmts decls
-    return vars
-
--- | Conversion of call arguments.
-arg_vars :: [(CmmActual, ForeignHint)]
-         -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-         -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-
-arg_vars [] (vars, stmts, tops)
-  = return (vars, stmts, tops)
-
-arg_vars ((e, AddrHint):rest) (vars, stmts, tops)
-  = do (v1, stmts', top') <- exprToVar e
-       let op = case getVarType v1 of
-               ty | isPointer ty -> LM_Bitcast
-               ty | isInt ty     -> LM_Inttoptr
-
-               a  -> pprPanic "genCall: Can't cast llvmType to i8*! " $
-                lparen <>  ppr a <> rparen
-
-       (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
-       arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
-                               tops ++ top')
-
-arg_vars ((e, _):rest) (vars, stmts, tops)
-  = do (v1, stmts', top') <- exprToVar e
-       arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
-
-
--- | Cast a collection of LLVM variables to specific types.
-castVarsW :: Signage
-          -> [(LlvmVar, LlvmType)]
-          -> WriterT LlvmAccum LlvmM [LlvmVar]
-castVarsW signage vars = do
-    (vars, stmts) <- lift $ castVars signage vars
-    tell $ LlvmAccum stmts mempty
-    return vars
-
--- | Cast a collection of LLVM variables to specific types.
-castVars :: Signage -> [(LlvmVar, LlvmType)]
-         -> LlvmM ([LlvmVar], LlvmStatements)
-castVars signage vars = do
-                done <- mapM (uncurry (castVar signage)) vars
-                let (vars', stmts) = unzip done
-                return (vars', toOL stmts)
-
--- | Cast an LLVM variable to a specific type, panicking if it can't be done.
-castVar :: Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
-castVar signage v t | getVarType v == t
-            = return (v, Nop)
-
-            | otherwise
-            = do platform <- getPlatform
-                 let op = case (getVarType v, t) of
-                      (LMInt n, LMInt m)
-                          -> if n < m then extend else LM_Trunc
-                      (vt, _) | isFloat vt && isFloat t
-                          -> if llvmWidthInBits platform vt < llvmWidthInBits platform t
-                                then LM_Fpext else LM_Fptrunc
-                      (vt, _) | isInt vt && isFloat t       -> LM_Sitofp
-                      (vt, _) | isFloat vt && isInt t       -> LM_Fptosi
-                      (vt, _) | isInt vt && isPointer t     -> LM_Inttoptr
-                      (vt, _) | isPointer vt && isInt t     -> LM_Ptrtoint
-                      (vt, _) | isPointer vt && isPointer t -> LM_Bitcast
-                      (vt, _) | isVector vt && isVector t   -> LM_Bitcast
-
-                      (vt, _) -> pprPanic "castVars: Can't cast this type " $
-                                lparen <> ppr vt <> rparen
-                                <> text " to " <>
-                                lparen <> ppr t <> rparen
-
-                 doExpr t $ Cast op v t
-    where extend = case signage of
-            Signed      -> LM_Sext
-            Unsigned    -> LM_Zext
-
-
-cmmPrimOpRetValSignage :: CallishMachOp -> Signage
-cmmPrimOpRetValSignage mop = case mop of
-    MO_Pdep _   -> Unsigned
-    MO_Pext _   -> Unsigned
-    _           -> Signed
-
--- | Decide what C function to use to implement a CallishMachOp
-cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
-cmmPrimOpFunctions mop = do
-  cfg      <- getConfig
-  platform <- getPlatform
-  let !isBmi2Enabled = llvmCgBmiVersion cfg >= Just BMI2
-      !is32bit       = platformWordSize platform == PW4
-      unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
-                        ++ " not supported here")
-      dontReach64 = panic ("cmmPrimOpFunctions: " ++ show mop
-                        ++ " should be not be encountered because the regular primop for this 64-bit operation is used instead.")
-
-  return $ case mop of
-    MO_F32_Exp    -> fsLit "expf"
-    MO_F32_ExpM1  -> fsLit "expm1f"
-    MO_F32_Log    -> fsLit "logf"
-    MO_F32_Log1P  -> fsLit "log1pf"
-    MO_F32_Sqrt   -> fsLit "llvm.sqrt.f32"
-    MO_F32_Fabs   -> fsLit "llvm.fabs.f32"
-    MO_F32_Pwr    -> fsLit "llvm.pow.f32"
-
-    MO_F32_Sin    -> fsLit "llvm.sin.f32"
-    MO_F32_Cos    -> fsLit "llvm.cos.f32"
-    MO_F32_Tan    -> fsLit "tanf"
-
-    MO_F32_Asin   -> fsLit "asinf"
-    MO_F32_Acos   -> fsLit "acosf"
-    MO_F32_Atan   -> fsLit "atanf"
-
-    MO_F32_Sinh   -> fsLit "sinhf"
-    MO_F32_Cosh   -> fsLit "coshf"
-    MO_F32_Tanh   -> fsLit "tanhf"
-
-    MO_F32_Asinh  -> fsLit "asinhf"
-    MO_F32_Acosh  -> fsLit "acoshf"
-    MO_F32_Atanh  -> fsLit "atanhf"
-
-    MO_F64_Exp    -> fsLit "exp"
-    MO_F64_ExpM1  -> fsLit "expm1"
-    MO_F64_Log    -> fsLit "log"
-    MO_F64_Log1P  -> fsLit "log1p"
-    MO_F64_Sqrt   -> fsLit "llvm.sqrt.f64"
-    MO_F64_Fabs   -> fsLit "llvm.fabs.f64"
-    MO_F64_Pwr    -> fsLit "llvm.pow.f64"
-
-    MO_F64_Sin    -> fsLit "llvm.sin.f64"
-    MO_F64_Cos    -> fsLit "llvm.cos.f64"
-    MO_F64_Tan    -> fsLit "tan"
-
-    MO_F64_Asin   -> fsLit "asin"
-    MO_F64_Acos   -> fsLit "acos"
-    MO_F64_Atan   -> fsLit "atan"
-
-    MO_F64_Sinh   -> fsLit "sinh"
-    MO_F64_Cosh   -> fsLit "cosh"
-    MO_F64_Tanh   -> fsLit "tanh"
-
-    MO_F64_Asinh  -> fsLit "asinh"
-    MO_F64_Acosh  -> fsLit "acosh"
-    MO_F64_Atanh  -> fsLit "atanh"
-
-    -- In the following ops, it looks like we could factorize the concatenation
-    -- of the bit size, and indeed it was like this before, e.g.
-    --
-    --     MO_PopCnt w -> fsLit $ "llvm.ctpop.i" ++ wbits w
-    -- or
-    --     MO_Memcpy _ -> fsLit $ "llvm.memcpy."  ++ intrinTy1
-    --
-    -- however it meant that FastStrings were not built from constant string
-    -- literals, hence they weren't matching the "fslit" rewrite rule in
-    -- GHC.Data.FastString that computes the string size at compilation time.
-
-    MO_Memcpy _
-      | is32bit   -> fsLit "llvm.memcpy.p0i8.p0i8.i32"
-      | otherwise -> fsLit "llvm.memcpy.p0i8.p0i8.i64"
-    MO_Memmove _
-      | is32bit   -> fsLit "llvm.memmove.p0i8.p0i8.i32"
-      | otherwise -> fsLit "llvm.memmove.p0i8.p0i8.i64"
-    MO_Memset _
-       | is32bit   -> fsLit "llvm.memset.p0i8.i32"
-       | otherwise -> fsLit "llvm.memset.p0i8.i64"
-    MO_Memcmp _   -> fsLit "memcmp"
-
-    MO_SuspendThread -> fsLit "suspendThread"
-    MO_ResumeThread  -> fsLit "resumeThread"
-
-    MO_PopCnt w -> case w of
-      W8   -> fsLit "llvm.ctpop.i8"
-      W16  -> fsLit "llvm.ctpop.i16"
-      W32  -> fsLit "llvm.ctpop.i32"
-      W64  -> fsLit "llvm.ctpop.i64"
-      W128 -> fsLit "llvm.ctpop.i128"
-      W256 -> fsLit "llvm.ctpop.i256"
-      W512 -> fsLit "llvm.ctpop.i512"
-    MO_BSwap w  -> case w of
-      W8   -> fsLit "llvm.bswap.i8"
-      W16  -> fsLit "llvm.bswap.i16"
-      W32  -> fsLit "llvm.bswap.i32"
-      W64  -> fsLit "llvm.bswap.i64"
-      W128 -> fsLit "llvm.bswap.i128"
-      W256 -> fsLit "llvm.bswap.i256"
-      W512 -> fsLit "llvm.bswap.i512"
-    MO_BRev w   -> case w of
-      W8   -> fsLit "llvm.bitreverse.i8"
-      W16  -> fsLit "llvm.bitreverse.i16"
-      W32  -> fsLit "llvm.bitreverse.i32"
-      W64  -> fsLit "llvm.bitreverse.i64"
-      W128 -> fsLit "llvm.bitreverse.i128"
-      W256 -> fsLit "llvm.bitreverse.i256"
-      W512 -> fsLit "llvm.bitreverse.i512"
-    MO_Clz w    -> case w of
-      W8   -> fsLit "llvm.ctlz.i8"
-      W16  -> fsLit "llvm.ctlz.i16"
-      W32  -> fsLit "llvm.ctlz.i32"
-      W64  -> fsLit "llvm.ctlz.i64"
-      W128 -> fsLit "llvm.ctlz.i128"
-      W256 -> fsLit "llvm.ctlz.i256"
-      W512 -> fsLit "llvm.ctlz.i512"
-    MO_Ctz w    -> case w of
-      W8   -> fsLit "llvm.cttz.i8"
-      W16  -> fsLit "llvm.cttz.i16"
-      W32  -> fsLit "llvm.cttz.i32"
-      W64  -> fsLit "llvm.cttz.i64"
-      W128 -> fsLit "llvm.cttz.i128"
-      W256 -> fsLit "llvm.cttz.i256"
-      W512 -> fsLit "llvm.cttz.i512"
-    MO_Pdep w
-      | isBmi2Enabled -> case w of
-          W8   -> fsLit "llvm.x86.bmi.pdep.8"
-          W16  -> fsLit "llvm.x86.bmi.pdep.16"
-          W32  -> fsLit "llvm.x86.bmi.pdep.32"
-          W64  -> fsLit "llvm.x86.bmi.pdep.64"
-          W128 -> fsLit "llvm.x86.bmi.pdep.128"
-          W256 -> fsLit "llvm.x86.bmi.pdep.256"
-          W512 -> fsLit "llvm.x86.bmi.pdep.512"
-      | otherwise -> case w of
-          W8   -> fsLit "hs_pdep8"
-          W16  -> fsLit "hs_pdep16"
-          W32  -> fsLit "hs_pdep32"
-          W64  -> fsLit "hs_pdep64"
-          W128 -> fsLit "hs_pdep128"
-          W256 -> fsLit "hs_pdep256"
-          W512 -> fsLit "hs_pdep512"
-    MO_Pext w
-      | isBmi2Enabled -> case w of
-          W8   -> fsLit "llvm.x86.bmi.pext.8"
-          W16  -> fsLit "llvm.x86.bmi.pext.16"
-          W32  -> fsLit "llvm.x86.bmi.pext.32"
-          W64  -> fsLit "llvm.x86.bmi.pext.64"
-          W128 -> fsLit "llvm.x86.bmi.pext.128"
-          W256 -> fsLit "llvm.x86.bmi.pext.256"
-          W512 -> fsLit "llvm.x86.bmi.pext.512"
-      | otherwise -> case w of
-          W8   -> fsLit "hs_pext8"
-          W16  -> fsLit "hs_pext16"
-          W32  -> fsLit "hs_pext32"
-          W64  -> fsLit "hs_pext64"
-          W128 -> fsLit "hs_pext128"
-          W256 -> fsLit "hs_pext256"
-          W512 -> fsLit "hs_pext512"
-
-    MO_AddIntC w    -> case w of
-      W8   -> fsLit "llvm.sadd.with.overflow.i8"
-      W16  -> fsLit "llvm.sadd.with.overflow.i16"
-      W32  -> fsLit "llvm.sadd.with.overflow.i32"
-      W64  -> fsLit "llvm.sadd.with.overflow.i64"
-      W128 -> fsLit "llvm.sadd.with.overflow.i128"
-      W256 -> fsLit "llvm.sadd.with.overflow.i256"
-      W512 -> fsLit "llvm.sadd.with.overflow.i512"
-    MO_SubIntC w    -> case w of
-      W8   -> fsLit "llvm.ssub.with.overflow.i8"
-      W16  -> fsLit "llvm.ssub.with.overflow.i16"
-      W32  -> fsLit "llvm.ssub.with.overflow.i32"
-      W64  -> fsLit "llvm.ssub.with.overflow.i64"
-      W128 -> fsLit "llvm.ssub.with.overflow.i128"
-      W256 -> fsLit "llvm.ssub.with.overflow.i256"
-      W512 -> fsLit "llvm.ssub.with.overflow.i512"
-    MO_Add2 w       -> case w of
-      W8   -> fsLit "llvm.uadd.with.overflow.i8"
-      W16  -> fsLit "llvm.uadd.with.overflow.i16"
-      W32  -> fsLit "llvm.uadd.with.overflow.i32"
-      W64  -> fsLit "llvm.uadd.with.overflow.i64"
-      W128 -> fsLit "llvm.uadd.with.overflow.i128"
-      W256 -> fsLit "llvm.uadd.with.overflow.i256"
-      W512 -> fsLit "llvm.uadd.with.overflow.i512"
-    MO_AddWordC w   -> case w of
-      W8   -> fsLit "llvm.uadd.with.overflow.i8"
-      W16  -> fsLit "llvm.uadd.with.overflow.i16"
-      W32  -> fsLit "llvm.uadd.with.overflow.i32"
-      W64  -> fsLit "llvm.uadd.with.overflow.i64"
-      W128 -> fsLit "llvm.uadd.with.overflow.i128"
-      W256 -> fsLit "llvm.uadd.with.overflow.i256"
-      W512 -> fsLit "llvm.uadd.with.overflow.i512"
-    MO_SubWordC w   -> case w of
-      W8   -> fsLit "llvm.usub.with.overflow.i8"
-      W16  -> fsLit "llvm.usub.with.overflow.i16"
-      W32  -> fsLit "llvm.usub.with.overflow.i32"
-      W64  -> fsLit "llvm.usub.with.overflow.i64"
-      W128 -> fsLit "llvm.usub.with.overflow.i128"
-      W256 -> fsLit "llvm.usub.with.overflow.i256"
-      W512 -> fsLit "llvm.usub.with.overflow.i512"
-
-
-    MO_Prefetch_Data _ -> fsLit "llvm.prefetch"
-
-    MO_S_Mul2    {}  -> unsupported
-    MO_S_QuotRem {}  -> unsupported
-    MO_U_QuotRem {}  -> unsupported
-    MO_U_QuotRem2 {} -> unsupported
-    -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the
-    -- appropriate case of genCall.
-    MO_U_Mul2 {}     -> unsupported
-    MO_ReadBarrier   -> unsupported
-    MO_WriteBarrier  -> unsupported
-    MO_Touch         -> unsupported
-    MO_UF_Conv _     -> unsupported
-
-    MO_AtomicRead _  -> unsupported
-    MO_AtomicRMW _ _ -> unsupported
-    MO_AtomicWrite _ -> unsupported
-    MO_Cmpxchg _     -> unsupported
-    MO_Xchg _        -> unsupported
-
-    MO_I64_ToI       -> dontReach64
-    MO_I64_FromI     -> dontReach64
-    MO_W64_ToW       -> dontReach64
-    MO_W64_FromW     -> dontReach64
-    MO_x64_Neg       -> dontReach64
-    MO_x64_Add       -> dontReach64
-    MO_x64_Sub       -> dontReach64
-    MO_x64_Mul       -> dontReach64
-    MO_I64_Quot      -> dontReach64
-    MO_I64_Rem       -> dontReach64
-    MO_W64_Quot      -> dontReach64
-    MO_W64_Rem       -> dontReach64
-    MO_x64_And       -> dontReach64
-    MO_x64_Or        -> dontReach64
-    MO_x64_Xor       -> dontReach64
-    MO_x64_Not       -> dontReach64
-    MO_x64_Shl       -> dontReach64
-    MO_I64_Shr       -> dontReach64
-    MO_W64_Shr       -> dontReach64
-    MO_x64_Eq        -> dontReach64
-    MO_x64_Ne        -> dontReach64
-    MO_I64_Ge        -> dontReach64
-    MO_I64_Gt        -> dontReach64
-    MO_I64_Le        -> dontReach64
-    MO_I64_Lt        -> dontReach64
-    MO_W64_Ge        -> dontReach64
-    MO_W64_Gt        -> dontReach64
-    MO_W64_Le        -> dontReach64
-    MO_W64_Lt        -> dontReach64
-
-
--- | Tail function calls
-genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData
-
--- Call to known function
-genJump (CmmLit (CmmLabel lbl)) live = do
-    (vf, stmts, top) <- getHsFunc live lbl
-    (stgRegs, stgStmts) <- funEpilogue live
-    let s1  = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
-    let s2  = Return Nothing
-    return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
-
-
--- Call to unknown function / address
-genJump expr live = do
-    fty <- llvmFunTy live
-    (vf, stmts, top) <- exprToVar expr
-
-    let cast = case getVarType vf of
-         ty | isPointer ty -> LM_Bitcast
-         ty | isInt ty     -> LM_Inttoptr
-
-         ty -> pprPanic "genJump: Expr is of bad type for function call! "
-                $ lparen <> ppr ty <> rparen
-
-    (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
-    (stgRegs, stgStmts) <- funEpilogue live
-    let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
-    let s3 = Return Nothing
-    return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
-            top)
-
-
--- | CmmAssign operation
---
--- We use stack allocated variables for CmmReg. The optimiser will replace
--- these with registers when possible.
-genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData
-genAssign reg val = do
-    vreg <- getCmmReg reg
-    (vval, stmts2, top2) <- exprToVar val
-    let stmts = stmts2
-
-    let ty = (pLower . getVarType) vreg
-    platform <- getPlatform
-    case ty of
-      -- Some registers are pointer types, so need to cast value to pointer
-      LMPointer _ | getVarType vval == llvmWord platform -> do
-          (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
-          let s2 = Store v vreg Nothing
-          return (stmts `snocOL` s1 `snocOL` s2, top2)
-
-      LMVector _ _ -> do
-          (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty
-          let s2 = mkStore v vreg NaturallyAligned
-          return (stmts `snocOL` s1 `snocOL` s2, top2)
-
-      _ -> do
-          let s1 = Store vval vreg Nothing
-          return (stmts `snocOL` s1, top2)
-
-
--- | CmmStore operation
-genStore :: CmmExpr -> CmmExpr -> AlignmentSpec -> LlvmM StmtData
-
--- First we try to detect a few common cases and produce better code for
--- these then the default case. We are mostly trying to detect Cmm code
--- like I32[Sp + n] and use 'getelementptr' operations instead of the
--- generic case that uses casts and pointer arithmetic
-genStore addr@(CmmReg (CmmGlobal r)) val alignment
-    = genStore_fast addr r 0 val alignment
-
-genStore addr@(CmmRegOff (CmmGlobal r) n) val alignment
-    = genStore_fast addr r n val alignment
-
-genStore addr@(CmmMachOp (MO_Add _) [
-                            (CmmReg (CmmGlobal r)),
-                            (CmmLit (CmmInt n _))])
-                val alignment
-    = genStore_fast addr r (fromInteger n) val alignment
-
-genStore addr@(CmmMachOp (MO_Sub _) [
-                            (CmmReg (CmmGlobal r)),
-                            (CmmLit (CmmInt n _))])
-                val alignment
-    = genStore_fast addr r (negate $ fromInteger n) val alignment
-
--- generic case
-genStore addr val alignment
-    = getTBAAMeta topN >>= genStore_slow addr val alignment
-
--- | CmmStore operation
--- This is a special case for storing to a global register pointer
--- offset such as I32[Sp+8].
-genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr -> AlignmentSpec
-              -> LlvmM StmtData
-genStore_fast addr r n val alignment
-  = do platform <- getPlatform
-       (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
-       meta          <- getTBAARegMeta r
-       let (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt  `div` 8)
-       case isPointer grt && rem == 0 of
-            True -> do
-                (vval,  stmts, top) <- exprToVar val
-                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
-                -- We might need a different pointer type, so check
-                case pLower grt == getVarType vval of
-                     -- were fine
-                     True  -> do
-                         let s3 = MetaStmt meta $ mkStore vval ptr alignment
-                         return (stmts `appOL` s1 `snocOL` s2
-                                 `snocOL` s3, top)
-
-                     -- cast to pointer type needed
-                     False -> do
-                         let ty = (pLift . getVarType) vval
-                         (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
-                         let s4 = MetaStmt meta $ mkStore vval ptr' alignment
-                         return (stmts `appOL` s1 `snocOL` s2
-                                 `snocOL` s3 `snocOL` s4, top)
-
-            -- If its a bit type then we use the slow method since
-            -- we can't avoid casting anyway.
-            False -> genStore_slow addr val alignment meta
-
-
--- | CmmStore operation
--- Generic case. Uses casts and pointer arithmetic if needed.
-genStore_slow :: CmmExpr -> CmmExpr -> AlignmentSpec -> [MetaAnnot] -> LlvmM StmtData
-genStore_slow addr val alignment meta = do
-    (vaddr, stmts1, top1) <- exprToVar addr
-    (vval,  stmts2, top2) <- exprToVar val
-
-    let stmts = stmts1 `appOL` stmts2
-    platform <- getPlatform
-    cfg      <- getConfig
-    case getVarType vaddr of
-        -- sometimes we need to cast an int to a pointer before storing
-        LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do
-            (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
-            let s2 = MetaStmt meta $ mkStore v vaddr alignment
-            return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
-
-        LMPointer _ -> do
-            let s1 = MetaStmt meta $ mkStore vval vaddr alignment
-            return (stmts `snocOL` s1, top1 ++ top2)
-
-        i@(LMInt _) | i == llvmWord platform -> do
-            let vty = pLift $ getVarType vval
-            (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
-            let s2 = MetaStmt meta $ mkStore vval vptr alignment
-            return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
-
-        other ->
-            pprPanic "genStore: ptr not right type!"
-                    (pdoc platform addr $$
-                     text "Size of Ptr:" <+> ppr (llvmPtrBits platform) $$
-                     text "Size of var:" <+> ppr (llvmWidthInBits platform other) $$
-                     text "Var:"         <+> ppVar cfg vaddr)
-
-mkStore :: LlvmVar -> LlvmVar -> AlignmentSpec -> LlvmStatement
-mkStore vval vptr alignment =
-    Store vval vptr align
-  where
-    ty = pLower (getVarType vptr)
-    align = case alignment of
-              -- See Note [Alignment of vector-typed values]
-              _ | isVector ty  -> Just 1
-              Unaligned        -> Just 1
-              NaturallyAligned -> Nothing
-
--- | Unconditional branch
-genBranch :: BlockId -> LlvmM StmtData
-genBranch id =
-    let label = blockIdToLlvm id
-    in return (unitOL $ Branch label, [])
-
-
--- | Conditional branch
-genCondBranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> LlvmM StmtData
-genCondBranch cond idT idF likely = do
-    let labelT = blockIdToLlvm idT
-    let labelF = blockIdToLlvm idF
-    -- See Note [Literals and branch conditions].
-    (vc, stmts1, top1) <- exprToVarOpt i1Option cond
-    if getVarType vc == i1
-        then do
-            (vc', (stmts2, top2)) <- case likely of
-              Just b -> genExpectLit (if b then 1 else 0) i1  vc
-              _      -> pure (vc, (nilOL, []))
-            let s1 = BranchIf vc' labelT labelF
-            return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)
-        else do
-            cfg <- getConfig
-            pprPanic "genCondBranch: Cond expr not bool! " $
-              lparen <> ppVar cfg vc <> rparen
-
-
--- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var.
-genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData)
-genExpectLit expLit expTy var = do
-  cfg <- getConfig
-
-  let
-    lit = LMLitVar $ LMIntLit expLit expTy
-
-    llvmExpectName
-      | isInt expTy = fsLit $ "llvm.expect." ++ showSDocOneLine (llvmCgContext cfg) (ppr expTy)
-      | otherwise   = panic "genExpectedLit: Type not an int!"
-
-  (llvmExpect, stmts, top) <-
-    getInstrinct llvmExpectName expTy [expTy, expTy]
-  (var', call) <- doExpr expTy $ Call StdCall llvmExpect [var, lit] []
-  return (var', (stmts `snocOL` call, top))
-
-{- Note [Literals and branch conditions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It is important that whenever we generate branch conditions for
-literals like '1', they are properly narrowed to an LLVM expression of
-type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert
-a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt
-must be certain to return a properly narrowed type. genLit is
-responsible for this, in the case of literal integers.
-
-Often, we won't see direct statements like:
-
-    if(1) {
-      ...
-    } else {
-      ...
-    }
-
-at this point in the pipeline, because the Glorious Code Generator
-will do trivial branch elimination in the sinking pass (among others,)
-which will eliminate the expression entirely.
-
-However, it's certainly possible and reasonable for this to occur in
-hand-written C-- code. Consider something like:
-
-    #if !defined(SOME_CONDITIONAL)
-    #define CHECK_THING(x) 1
-    #else
-    #define CHECK_THING(x) some_operation((x))
-    #endif
-
-    f() {
-
-      if (CHECK_THING(xyz)) {
-        ...
-      } else {
-        ...
-      }
-
-    }
-
-In such an instance, CHECK_THING might result in an *expression* in
-one case, and a *literal* in the other, depending on what in
-particular was #define'd. So we must be sure to properly narrow the
-literal in this case to i1 as it won't be eliminated beforehand.
-
-For a real example of this, see ./rts/StgStdThunks.cmm
-
--}
-
-
-
--- | Switch branch
-genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData
-genSwitch cond ids = do
-    (vc, stmts, top) <- exprToVar cond
-    let ty = getVarType vc
-
-    let labels = [ (mkIntLit ty ix, blockIdToLlvm b)
-                 | (ix, b) <- switchTargetsCases ids ]
-    -- out of range is undefined, so let's just branch to first label
-    let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l
-               | otherwise                          = snd (head labels)
-
-    let s1 = Switch vc defLbl labels
-    return $ (stmts `snocOL` s1, top)
-
-
--- -----------------------------------------------------------------------------
--- * CmmExpr code generation
---
-
--- | An expression conversion return data:
---   * LlvmVar: The var holding the result of the expression
---   * LlvmStatements: Any statements needed to evaluate the expression
---   * LlvmCmmDecl: Any global data needed for this expression
-type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl])
-
--- | Values which can be passed to 'exprToVar' to configure its
--- behaviour in certain circumstances.
---
--- Currently just used for determining if a comparison should return
--- a boolean (i1) or a word. See Note [Literals and branch conditions].
-newtype EOption = EOption { i1Expected :: Bool }
--- XXX: EOption is an ugly and inefficient solution to this problem.
-
--- | i1 type expected (condition scrutinee).
-i1Option :: EOption
-i1Option = EOption True
-
--- | Word type expected (usual).
-wordOption :: EOption
-wordOption = EOption False
-
--- | Convert a CmmExpr to a list of LlvmStatements with the result of the
--- expression being stored in the returned LlvmVar.
-exprToVar :: CmmExpr -> LlvmM ExprData
-exprToVar = exprToVarOpt wordOption
-
-exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData
-exprToVarOpt opt e = case e of
-
-    CmmLit lit
-        -> genLit opt lit
-
-    CmmLoad e' ty align
-        -> genLoad False e' ty align
-
-    -- Cmmreg in expression is the value, so must load. If you want actual
-    -- reg pointer, call getCmmReg directly.
-    CmmReg r -> do
-        (v1, ty, s1) <- getCmmRegVal r
-        case isPointer ty of
-             True  -> do
-                 -- Cmm wants the value, so pointer types must be cast to ints
-                 platform <- getPlatform
-                 (v2, s2) <- doExpr (llvmWord platform) $ Cast LM_Ptrtoint v1 (llvmWord platform)
-                 return (v2, s1 `snocOL` s2, [])
-
-             False -> return (v1, s1, [])
-
-    CmmMachOp op exprs
-        -> genMachOp opt op exprs
-
-    CmmRegOff r i
-        -> do platform <- getPlatform
-              exprToVar $ expandCmmReg platform (r, i)
-
-    CmmStackSlot _ _
-        -> panic "exprToVar: CmmStackSlot not supported!"
-
-
--- | Handle CmmMachOp expressions
-genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
-
--- Unary Machop
-genMachOp _ op [x] = case op of
-
-    MO_Not w ->
-        let all1 = mkIntLit (widthToLlvmInt w) (-1)
-        in negate (widthToLlvmInt w) all1 LM_MO_Xor
-
-    MO_S_Neg w ->
-        let all0 = mkIntLit (widthToLlvmInt w) 0
-        in negate (widthToLlvmInt w) all0 LM_MO_Sub
-
-    MO_F_Neg w ->
-        let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
-        in negate (widthToLlvmFloat w) all0 LM_MO_FSub
-
-    MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
-    MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
-
-    MO_SS_Conv from to
-        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
-
-    MO_UU_Conv from to
-        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
-
-    MO_XX_Conv from to
-        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
-
-    MO_FF_Conv from to
-        -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
-
-    MO_VS_Neg len w ->
-        let ty    = widthToLlvmInt w
-            vecty = LMVector len ty
-            all0  = LMIntLit (-0) ty
-            all0s = LMLitVar $ LMVectorLit (replicate len all0)
-        in negateVec vecty all0s LM_MO_Sub
-
-    MO_VF_Neg len w ->
-        let ty    = widthToLlvmFloat w
-            vecty = LMVector len ty
-            all0  = LMFloatLit (-0) ty
-            all0s = LMLitVar $ LMVectorLit (replicate len all0)
-        in negateVec vecty all0s LM_MO_FSub
-
-    MO_AlignmentCheck _ _ -> panic "-falignment-sanitisation is not supported by -fllvm"
-
-    -- Handle unsupported cases explicitly so we get a warning
-    -- of missing case when new MachOps added
-    MO_Add _          -> panicOp
-    MO_Mul _          -> panicOp
-    MO_Sub _          -> panicOp
-    MO_S_MulMayOflo _ -> panicOp
-    MO_S_Quot _       -> panicOp
-    MO_S_Rem _        -> panicOp
-    MO_U_Quot _       -> panicOp
-    MO_U_Rem _        -> panicOp
-
-    MO_Eq  _          -> panicOp
-    MO_Ne  _          -> panicOp
-    MO_S_Ge _         -> panicOp
-    MO_S_Gt _         -> panicOp
-    MO_S_Le _         -> panicOp
-    MO_S_Lt _         -> panicOp
-    MO_U_Ge _         -> panicOp
-    MO_U_Gt _         -> panicOp
-    MO_U_Le _         -> panicOp
-    MO_U_Lt _         -> panicOp
-
-    MO_F_Add        _ -> panicOp
-    MO_F_Sub        _ -> panicOp
-    MO_F_Mul        _ -> panicOp
-    MO_F_Quot       _ -> panicOp
-    MO_F_Eq         _ -> panicOp
-    MO_F_Ne         _ -> panicOp
-    MO_F_Ge         _ -> panicOp
-    MO_F_Gt         _ -> panicOp
-    MO_F_Le         _ -> panicOp
-    MO_F_Lt         _ -> panicOp
-
-    MO_And          _ -> panicOp
-    MO_Or           _ -> panicOp
-    MO_Xor          _ -> panicOp
-    MO_Shl          _ -> panicOp
-    MO_U_Shr        _ -> panicOp
-    MO_S_Shr        _ -> panicOp
-
-    MO_V_Insert   _ _ -> panicOp
-    MO_V_Extract  _ _ -> panicOp
-
-    MO_V_Add      _ _ -> panicOp
-    MO_V_Sub      _ _ -> panicOp
-    MO_V_Mul      _ _ -> panicOp
-
-    MO_VS_Quot    _ _ -> panicOp
-    MO_VS_Rem     _ _ -> panicOp
-
-    MO_VU_Quot    _ _ -> panicOp
-    MO_VU_Rem     _ _ -> panicOp
-
-    MO_VF_Insert  _ _ -> panicOp
-    MO_VF_Extract _ _ -> panicOp
-
-    MO_VF_Add     _ _ -> panicOp
-    MO_VF_Sub     _ _ -> panicOp
-    MO_VF_Mul     _ _ -> panicOp
-    MO_VF_Quot    _ _ -> panicOp
-
-    where
-        negate ty v2 negOp = do
-            (vx, stmts, top) <- exprToVar x
-            (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
-            return (v1, stmts `snocOL` s1, top)
-
-        negateVec ty v2 negOp = do
-            (vx, stmts1, top) <- exprToVar x
-            (vxs', stmts2) <- castVars Signed [(vx, ty)]
-            let vx' = singletonPanic "genMachOp: negateVec" vxs'
-            (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'
-            return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
-
-        fiConv ty convOp = do
-            (vx, stmts, top) <- exprToVar x
-            (v1, s1) <- doExpr ty $ Cast convOp vx ty
-            return (v1, stmts `snocOL` s1, top)
-
-        sameConv from ty reduce expand = do
-            x'@(vx, stmts, top) <- exprToVar x
-            let sameConv' op = do
-                    (v1, s1) <- doExpr ty $ Cast op vx ty
-                    return (v1, stmts `snocOL` s1, top)
-            platform <- getPlatform
-            let toWidth = llvmWidthInBits platform ty
-            -- LLVM doesn't like trying to convert to same width, so
-            -- need to check for that as we do get Cmm code doing it.
-            case widthInBits from  of
-                 w | w < toWidth -> sameConv' expand
-                 w | w > toWidth -> sameConv' reduce
-                 _w              -> return x'
-
-        panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encountered"
-                       ++ "with one argument! (" ++ show op ++ ")"
-
--- Handle GlobalRegs pointers
-genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
-    = genMachOp_fast opt o r (fromInteger n) e
-
-genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
-    = genMachOp_fast opt o r (negate . fromInteger $ n) e
-
--- Generic case
-genMachOp opt op e = genMachOp_slow opt op e
-
-
--- | Handle CmmMachOp expressions
--- This is a specialised method that handles Global register manipulations like
--- 'Sp - 16', using the getelementptr instruction.
-genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
-               -> LlvmM ExprData
-genMachOp_fast opt op r n e
-  = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
-       platform <- getPlatform
-       let (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt  `div` 8)
-       case isPointer grt && rem == 0 of
-            True -> do
-                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
-                (var, s3) <- doExpr (llvmWord platform) $ Cast LM_Ptrtoint ptr (llvmWord platform)
-                return (var, s1 `snocOL` s2 `snocOL` s3, [])
-
-            False -> genMachOp_slow opt op e
-
-
--- | Handle CmmMachOp expressions
--- This handles all the cases not handle by the specialised genMachOp_fast.
-genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
-
--- Element extraction
-genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do
-    vval <- exprToVarW val
-    vidx <- exprToVarW idx
-    vval' <- singletonPanic "genMachOp_slow" <$>
-             castVarsW Signed [(vval, LMVector l ty)]
-    doExprW ty $ Extract vval' vidx
-  where
-    ty = widthToLlvmInt w
-
-genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do
-    vval <- exprToVarW val
-    vidx <- exprToVarW idx
-    vval' <- singletonPanic "genMachOp_slow" <$>
-             castVarsW Signed [(vval, LMVector l ty)]
-    doExprW ty $ Extract vval' vidx
-  where
-    ty = widthToLlvmFloat w
-
--- Element insertion
-genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do
-    vval <- exprToVarW val
-    velt <- exprToVarW elt
-    vidx <- exprToVarW idx
-    vval' <- singletonPanic "genMachOp_slow" <$>
-             castVarsW Signed [(vval, ty)]
-    doExprW ty $ Insert vval' velt vidx
-  where
-    ty = LMVector l (widthToLlvmInt w)
-
-genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do
-    vval <- exprToVarW val
-    velt <- exprToVarW elt
-    vidx <- exprToVarW idx
-    vval' <- singletonPanic "genMachOp_slow" <$>
-             castVarsW Signed [(vval, ty)]
-    doExprW ty $ Insert vval' velt vidx
-  where
-    ty = LMVector l (widthToLlvmFloat w)
-
--- Binary MachOp
-genMachOp_slow opt op [x, y] = case op of
-
-    MO_Eq _   -> genBinComp opt LM_CMP_Eq
-    MO_Ne _   -> genBinComp opt LM_CMP_Ne
-
-    MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
-    MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
-    MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
-    MO_S_Le _ -> genBinComp opt LM_CMP_Sle
-
-    MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
-    MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
-    MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
-    MO_U_Le _ -> genBinComp opt LM_CMP_Ule
-
-    MO_Add _ -> genBinMach LM_MO_Add
-    MO_Sub _ -> genBinMach LM_MO_Sub
-    MO_Mul _ -> genBinMach LM_MO_Mul
-
-    MO_S_MulMayOflo w -> isSMulOK w x y
-
-    MO_S_Quot _ -> genBinMach LM_MO_SDiv
-    MO_S_Rem  _ -> genBinMach LM_MO_SRem
-
-    MO_U_Quot _ -> genBinMach LM_MO_UDiv
-    MO_U_Rem  _ -> genBinMach LM_MO_URem
-
-    MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
-    MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
-    MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
-    MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
-    MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
-    MO_F_Le _ -> genBinComp opt LM_CMP_Fle
-
-    MO_F_Add  _ -> genBinMach LM_MO_FAdd
-    MO_F_Sub  _ -> genBinMach LM_MO_FSub
-    MO_F_Mul  _ -> genBinMach LM_MO_FMul
-    MO_F_Quot _ -> genBinMach LM_MO_FDiv
-
-    MO_And _   -> genBinMach LM_MO_And
-    MO_Or  _   -> genBinMach LM_MO_Or
-    MO_Xor _   -> genBinMach LM_MO_Xor
-    MO_Shl _   -> genBinCastYMach LM_MO_Shl
-    MO_U_Shr _ -> genBinCastYMach LM_MO_LShr
-    MO_S_Shr _ -> genBinCastYMach LM_MO_AShr
-
-    MO_V_Add l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add
-    MO_V_Sub l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub
-    MO_V_Mul l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul
-
-    MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv
-    MO_VS_Rem  l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem
-
-    MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv
-    MO_VU_Rem  l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem
-
-    MO_VF_Add  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd
-    MO_VF_Sub  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub
-    MO_VF_Mul  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul
-    MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv
-
-    MO_Not _       -> panicOp
-    MO_S_Neg _     -> panicOp
-    MO_F_Neg _     -> panicOp
-
-    MO_SF_Conv _ _ -> panicOp
-    MO_FS_Conv _ _ -> panicOp
-    MO_SS_Conv _ _ -> panicOp
-    MO_UU_Conv _ _ -> panicOp
-    MO_XX_Conv _ _ -> panicOp
-    MO_FF_Conv _ _ -> panicOp
-
-    MO_V_Insert  {} -> panicOp
-
-    MO_VS_Neg {} -> panicOp
-
-    MO_VF_Insert  {} -> panicOp
-
-    MO_VF_Neg {} -> panicOp
-
-    MO_AlignmentCheck {} -> panicOp
-
-#if __GLASGOW_HASKELL__ < 811
-    MO_VF_Extract {} -> panicOp
-    MO_V_Extract {} -> panicOp
-#endif
-
-    where
-        binLlvmOp ty binOp allow_y_cast = do
-          platform <- getPlatform
-          runExprData $ do
-            vx <- exprToVarW x
-            vy <- exprToVarW y
-
-            if | getVarType vx == getVarType vy
-               -> doExprW (ty vx) $ binOp vx vy
-
-               | allow_y_cast
-               -> do
-                    vy' <- singletonPanic "binLlvmOp cast"<$>
-                            castVarsW Signed [(vy, (ty vx))]
-                    doExprW (ty vx) $ binOp vx vy'
-
-               | otherwise
-               -> pprPanic "binLlvmOp types" (pdoc platform x $$ pdoc platform y)
-
-        binCastLlvmOp ty binOp = runExprData $ do
-            vx <- exprToVarW x
-            vy <- exprToVarW y
-            vxy' <- castVarsW Signed [(vx, ty), (vy, ty)]
-            case vxy' of
-              [vx',vy'] -> doExprW ty $ binOp vx' vy'
-              _         -> panic "genMachOp_slow: binCastLlvmOp"
-
-        -- Need to use EOption here as Cmm expects word size results from
-        -- comparisons while LLVM return i1. Need to extend to llvmWord type
-        -- if expected. See Note [Literals and branch conditions].
-        genBinComp opt cmp = do
-            ed@(v1, stmts, top) <- binLlvmOp (const i1) (Compare cmp) False
-            platform <- getPlatform
-            if getVarType v1 == i1
-                then case i1Expected opt of
-                    True  -> return ed
-                    False -> do
-                        let w_ = llvmWord platform
-                        (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_
-                        return (v2, stmts `snocOL` s1, top)
-                else
-                    pprPanic "genBinComp: Compare returned type other then i1! "
-                               (ppr $ getVarType v1)
-
-        genBinMach op = binLlvmOp getVarType (LlvmOp op) False
-
-        genBinCastYMach op = binLlvmOp getVarType (LlvmOp op) True
-
-        genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op)
-
-        -- Detect if overflow will occur in signed multiply of the two
-        -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
-        -- implementation. Its much longer due to type information/safety.
-        -- This should actually compile to only about 3 asm instructions.
-        isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData
-        isSMulOK _ x y = do
-          platform <- getPlatform
-          runExprData $ do
-            vx <- exprToVarW x
-            vy <- exprToVarW y
-
-            let word  = getVarType vx
-            let word2 = LMInt $ 2 * llvmWidthInBits platform (getVarType vx)
-            let shift = llvmWidthInBits platform word
-            let shift1 = toIWord platform (shift - 1)
-            let shift2 = toIWord platform shift
-
-            if isInt word
-                then do
-                    x1     <- doExprW word2 $ Cast LM_Sext vx word2
-                    y1     <- doExprW word2 $ Cast LM_Sext vy word2
-                    r1     <- doExprW word2 $ LlvmOp LM_MO_Mul x1 y1
-                    rlow1  <- doExprW word $ Cast LM_Trunc r1 word
-                    rlow2  <- doExprW word $ LlvmOp LM_MO_AShr rlow1 shift1
-                    rhigh1 <- doExprW word2 $ LlvmOp LM_MO_AShr r1 shift2
-                    rhigh2 <- doExprW word $ Cast LM_Trunc rhigh1 word
-                    doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2
-
-                else
-                    pprPanic "isSMulOK: Not bit type! " $
-                        lparen <> ppr word <> rparen
-
-        panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"
-                       ++ "with two arguments! (" ++ show op ++ ")"
-
--- More than two expression, invalid!
-genMachOp_slow _ _ _ = panic "genMachOp: More than 2 expressions in MachOp!"
-
-
--- | Handle CmmLoad expression.
-genLoad :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> LlvmM ExprData
-
--- First we try to detect a few common cases and produce better code for
--- these then the default case. We are mostly trying to detect Cmm code
--- like I32[Sp + n] and use 'getelementptr' operations instead of the
--- generic case that uses casts and pointer arithmetic
-genLoad atomic e@(CmmReg (CmmGlobal r)) ty align
-    = genLoad_fast atomic e r 0 ty align
-
-genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty align
-    = genLoad_fast atomic e r n ty align
-
-genLoad atomic e@(CmmMachOp (MO_Add _) [
-                            (CmmReg (CmmGlobal r)),
-                            (CmmLit (CmmInt n _))])
-                ty align
-    = genLoad_fast atomic e r (fromInteger n) ty align
-
-genLoad atomic e@(CmmMachOp (MO_Sub _) [
-                            (CmmReg (CmmGlobal r)),
-                            (CmmLit (CmmInt n _))])
-                ty align
-    = genLoad_fast atomic e r (negate $ fromInteger n) ty align
-
--- generic case
-genLoad atomic e ty align
-    = getTBAAMeta topN >>= genLoad_slow atomic e ty align
-
--- | Handle CmmLoad expression.
--- This is a special case for loading from a global register pointer
--- offset such as I32[Sp+8].
-genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType
-             -> AlignmentSpec -> LlvmM ExprData
-genLoad_fast atomic e r n ty align = do
-    platform <- getPlatform
-    (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
-    meta          <- getTBAARegMeta r
-    let ty'      = cmmToLlvmType ty
-        (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt  `div` 8)
-    case isPointer grt && rem == 0 of
-            True  -> do
-                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
-                -- We might need a different pointer type, so check
-                case grt == ty' of
-                     -- were fine
-                     True -> do
-                         (var, s3) <- doExpr ty' (MExpr meta $ mkLoad atomic ptr align)
-                         return (var, s1 `snocOL` s2 `snocOL` s3,
-                                     [])
-
-                     -- cast to pointer type needed
-                     False -> do
-                         let pty = pLift ty'
-                         (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
-                         (var, s4) <- doExpr ty' (MExpr meta $ mkLoad atomic ptr' align)
-                         return (var, s1 `snocOL` s2 `snocOL` s3
-                                    `snocOL` s4, [])
-
-            -- If its a bit type then we use the slow method since
-            -- we can't avoid casting anyway.
-            False -> genLoad_slow atomic  e ty align meta
-
--- | Handle Cmm load expression.
--- Generic case. Uses casts and pointer arithmetic if needed.
-genLoad_slow :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> [MetaAnnot]
-             -> LlvmM ExprData
-genLoad_slow atomic e ty align meta = do
-  platform <- getPlatform
-  cfg      <- getConfig
-  runExprData $ do
-    iptr <- exprToVarW e
-    case getVarType iptr of
-        LMPointer _ ->
-                    doExprW (cmmToLlvmType ty) (MExpr meta $ mkLoad atomic iptr align)
-
-        i@(LMInt _) | i == llvmWord platform -> do
-                    let pty = LMPointer $ cmmToLlvmType ty
-                    ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty
-                    doExprW (cmmToLlvmType ty) (MExpr meta $ mkLoad atomic ptr align)
-
-        other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
-                     (pdoc platform e $$
-                      text "Size of Ptr:" <+> ppr (llvmPtrBits platform) $$
-                      text "Size of var:" <+> ppr (llvmWidthInBits platform other) $$
-                      text "Var:" <+> (ppVar cfg iptr))
-
-{-
-Note [Alignment of vector-typed values]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-On x86, vector types need to be 16-byte aligned for aligned
-access, but we have no way of guaranteeing that this is true with GHC
-(we would need to modify the layout of the stack and closures, change
-the storage manager, etc.). So, we blindly tell LLVM that *any* vector
-store or load could be unaligned. In the future we may be able to
-guarantee that certain vector access patterns are aligned, in which
-case we will need a more granular way of specifying alignment.
--}
-
-mkLoad :: Atomic -> LlvmVar -> AlignmentSpec -> LlvmExpression
-mkLoad atomic vptr alignment
-  | atomic      = ALoad SyncSeqCst False vptr
-  | otherwise   = Load vptr align
-  where
-    ty = pLower (getVarType vptr)
-    align = case alignment of
-              -- See Note [Alignment of vector-typed values]
-              _ | isVector ty  -> Just 1
-              Unaligned        -> Just 1
-              NaturallyAligned -> Nothing
-
--- | Handle CmmReg expression. This will return a pointer to the stack
--- location of the register. Throws an error if it isn't allocated on
--- the stack.
-getCmmReg :: CmmReg -> LlvmM LlvmVar
-getCmmReg (CmmLocal (LocalReg un _))
-  = do exists <- varLookup un
-       case exists of
-         Just ety -> return (LMLocalVar un $ pLift ety)
-         Nothing  -> pprPanic "getCmmReg: Cmm register " $
-                        ppr un <> text " was not allocated!"
-           -- This should never happen, as every local variable should
-           -- have been assigned a value at some point, triggering
-           -- "funPrologue" to allocate it on the stack.
-
-getCmmReg (CmmGlobal g)
-  = do onStack  <- checkStackReg g
-       platform <- getPlatform
-       if onStack
-         then return (lmGlobalRegVar platform g)
-         else pprPanic "getCmmReg: Cmm register " $
-                ppr g <> text " not stack-allocated!"
-
--- | Return the value of a given register, as well as its type. Might
--- need to be load from stack.
-getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
-getCmmRegVal reg =
-  case reg of
-    CmmGlobal g -> do
-      onStack <- checkStackReg g
-      platform <- getPlatform
-      if onStack then loadFromStack else do
-        let r = lmGlobalRegArg platform g
-        return (r, getVarType r, nilOL)
-    _ -> loadFromStack
- where loadFromStack = do
-         ptr <- getCmmReg reg
-         let ty = pLower $ getVarType ptr
-         (v, s) <- doExpr ty (Load ptr Nothing)
-         return (v, ty, unitOL s)
-
--- | Allocate a local CmmReg on the stack
-allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
-allocReg (CmmLocal (LocalReg un ty))
-  = let ty' = cmmToLlvmType ty
-        var = LMLocalVar un (LMPointer ty')
-        alc = Alloca ty' 1
-    in (var, unitOL $ Assignment var alc)
-
-allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
-                    ++ " have been handled elsewhere!"
-
-
--- | Generate code for a literal
-genLit :: EOption -> CmmLit -> LlvmM ExprData
-genLit opt (CmmInt i w)
-  -- See Note [Literals and branch conditions].
-  = let width | i1Expected opt = i1
-              | otherwise      = LMInt (widthInBits w)
-        -- comm  = Comment [ fsLit $ "EOption: " ++ show opt
-        --                 , fsLit $ "Width  : " ++ show w
-        --                 , fsLit $ "Width' : " ++ show (widthInBits w)
-        --                 ]
-    in return (mkIntLit width i, nilOL, [])
-
-genLit _ (CmmFloat r w)
-  = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
-              nilOL, [])
-
-genLit opt (CmmVec ls)
-  = do llvmLits <- mapM toLlvmLit ls
-       return (LMLitVar $ LMVectorLit llvmLits, nilOL, [])
-  where
-    toLlvmLit :: CmmLit -> LlvmM LlvmLit
-    toLlvmLit lit = do
-        (llvmLitVar, _, _) <- genLit opt lit
-        case llvmLitVar of
-          LMLitVar llvmLit -> return llvmLit
-          _ -> panic "genLit"
-
-genLit _ cmm@(CmmLabel l)
-  = do var <- getGlobalPtr =<< strCLabel_llvm l
-       platform <- getPlatform
-       let lmty = cmmToLlvmType $ cmmLitType platform cmm
-       (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord platform)
-       return (v1, unitOL s1, [])
-
-genLit opt (CmmLabelOff label off) = do
-    platform <- getPlatform
-    (vlbl, stmts, stat) <- genLit opt (CmmLabel label)
-    let voff = toIWord platform off
-    (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
-    return (v1, stmts `snocOL` s1, stat)
-
-genLit opt (CmmLabelDiffOff l1 l2 off w) = do
-    platform <- getPlatform
-    (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1)
-    (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2)
-    let voff = toIWord platform off
-    let ty1 = getVarType vl1
-    let ty2 = getVarType vl2
-    if (isInt ty1) && (isInt ty2)
-       && (llvmWidthInBits platform ty1 == llvmWidthInBits platform ty2)
-       then do
-            (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
-            (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
-            let ty = widthToLlvmInt w
-            let stmts = stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2
-            if w /= wordWidth platform
-              then do
-                (v3, s3) <- doExpr ty $ Cast LM_Trunc v2 ty
-                return (v3, stmts `snocOL` s3, stat1 ++ stat2)
-              else
-                return (v2, stmts, stat1 ++ stat2)
-        else
-            panic "genLit: CmmLabelDiffOff encountered with different label ty!"
-
-genLit opt (CmmBlock b)
-  = genLit opt (CmmLabel $ infoTblLbl b)
-
-genLit _ CmmHighStackMark
-  = panic "genStaticLit - CmmHighStackMark unsupported!"
-
-
--- -----------------------------------------------------------------------------
--- * Misc
---
-
--- | Find CmmRegs that get assigned and allocate them on the stack
---
--- Any register that gets written needs to be allocated on the
--- stack. This avoids having to map a CmmReg to an equivalent SSA form
--- and avoids having to deal with Phi node insertion.  This is also
--- the approach recommended by LLVM developers.
---
--- On the other hand, this is unnecessarily verbose if the register in
--- question is never written. Therefore we skip it where we can to
--- save a few lines in the output and hopefully speed compilation up a
--- bit.
-funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData
-funPrologue live cmmBlocks = do
-
-  let getAssignedRegs :: CmmNode O O -> [CmmReg]
-      getAssignedRegs (CmmAssign reg _)  = [reg]
-      getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmLocal rs
-      getAssignedRegs _                  = []
-      getRegsBlock (_, body, _)          = concatMap getAssignedRegs $ blockToList body
-      assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks
-      isLive r     = r `elem` alwaysLive || r `elem` live
-
-  platform <- getPlatform
-  stmtss <- forM assignedRegs $ \reg ->
-    case reg of
-      CmmLocal (LocalReg un _) -> do
-        let (newv, stmts) = allocReg reg
-        varInsert un (pLower $ getVarType newv)
-        return stmts
-      CmmGlobal r -> do
-        let reg   = lmGlobalRegVar platform r
-            arg   = lmGlobalRegArg platform r
-            ty    = (pLower . getVarType) reg
-            trash = LMLitVar $ LMUndefLit ty
-            rval  = if isLive r then arg else trash
-            alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
-        markStackReg r
-        return $ toOL [alloc, Store rval reg Nothing]
-
-  return (concatOL stmtss `snocOL` jumpToEntry, [])
-  where
-    entryBlk : _ = cmmBlocks
-    jumpToEntry = Branch $ blockIdToLlvm (entryLabel entryBlk)
-
--- | Function epilogue. Load STG variables to use as argument for call.
--- STG Liveness optimisation done here.
-funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)
-funEpilogue live = do
-    platform <- getPlatform
-
-    let paddingRegs = padLiveArgs platform live
-
-    -- Set to value or "undef" depending on whether the register is
-    -- actually live
-    let loadExpr r = do
-          (v, _, s) <- getCmmRegVal (CmmGlobal r)
-          return (Just $ v, s)
-        loadUndef r = do
-          let ty = (pLower . getVarType $ lmGlobalRegVar platform r)
-          return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
-
-    -- Note that floating-point registers in `activeStgRegs` must be sorted
-    -- according to the calling convention.
-    --  E.g. for X86:
-    --     GOOD: F1,D1,XMM1,F2,D2,XMM2,...
-    --     BAD : F1,F2,F3,D1,D2,D3,XMM1,XMM2,XMM3,...
-    --  As Fn, Dn and XMMn use the same register (XMMn) to be passed, we don't
-    --  want to pass F2 before D1 for example, otherwise we could get F2 -> XMM1
-    --  and D1 -> XMM2.
-    let allRegs = activeStgRegs platform
-    loads <- forM allRegs $ \r -> if
-      -- load live registers
-      | r `elem` alwaysLive  -> loadExpr r
-      | r `elem` live        -> loadExpr r
-      -- load all non Floating-Point Registers
-      | not (isFPR r)        -> loadUndef r
-      -- load padding Floating-Point Registers
-      | r `elem` paddingRegs -> loadUndef r
-      | otherwise            -> return (Nothing, nilOL)
-
-    let (vars, stmts) = unzip loads
-    return (catMaybes vars, concatOL stmts)
-
--- | Get a function pointer to the CLabel specified.
---
--- This is for Haskell functions, function type is assumed, so doesn't work
--- with foreign functions.
-getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData
-getHsFunc live lbl
-  = do fty <- llvmFunTy live
-       name <- strCLabel_llvm lbl
-       getHsFunc' name fty
-
-getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData
-getHsFunc' name fty
-  = do fun <- getGlobalPtr name
-       if getVarType fun == fty
-         then return (fun, nilOL, [])
-         else do (v1, s1) <- doExpr (pLift fty)
-                               $ Cast LM_Bitcast fun (pLift fty)
-                 return  (v1, unitOL s1, [])
-
--- | Create a new local var
-mkLocalVar :: LlvmType -> LlvmM LlvmVar
-mkLocalVar ty = do
-    un <- getUniqueM
-    return $ LMLocalVar un ty
-
-
--- | Execute an expression, assigning result to a var
-doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
-doExpr ty expr = do
-    v <- mkLocalVar ty
-    return (v, Assignment v expr)
-
-
--- | Expand CmmRegOff
-expandCmmReg :: Platform -> (CmmReg, Int) -> CmmExpr
-expandCmmReg platform (reg, off)
-  = let width = typeWidth (cmmRegType platform reg)
-        voff  = CmmLit $ CmmInt (fromIntegral off) width
-    in CmmMachOp (MO_Add width) [CmmReg reg, voff]
-
-
--- | Convert a block id into a appropriate Llvm label
-blockIdToLlvm :: BlockId -> LlvmVar
-blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
-
--- | Create Llvm int Literal
-mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
-mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
-
--- | Convert int type to a LLvmVar of word or i32 size
-toI32 :: Integral a => a -> LlvmVar
-toI32 = mkIntLit i32
-
-toIWord :: Integral a => Platform -> a -> LlvmVar
-toIWord platform = mkIntLit (llvmWord platform)
-
-
--- | Error functions
-panic :: HasCallStack => String -> a
-panic s = Panic.panic $ "GHC.CmmToLlvm.CodeGen." ++ s
-
-pprPanic :: HasCallStack => String -> SDoc -> a
-pprPanic s d = Panic.pprPanic ("GHC.CmmToLlvm.CodeGen." ++ s) d
-
-
--- | Returns TBAA meta data by unique
-getTBAAMeta :: Unique -> LlvmM [MetaAnnot]
-getTBAAMeta u = do
-    mi <- getUniqMeta u
-    return [MetaAnnot tbaa (MetaNode i) | let Just i = mi]
-
--- | Returns TBAA meta data for given register
-getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot]
-getTBAARegMeta = getTBAAMeta . getTBAA
-
-
--- | A more convenient way of accumulating LLVM statements and declarations.
-data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl]
-
-instance Semigroup LlvmAccum where
-  LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB =
-        LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB)
-
-instance Monoid LlvmAccum where
-    mempty = LlvmAccum nilOL []
-    mappend = (Semigroup.<>)
-
-liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar
-liftExprData action = do
-    (var, stmts, decls) <- lift action
-    tell $ LlvmAccum stmts decls
-    return var
-
-statement :: LlvmStatement -> WriterT LlvmAccum LlvmM ()
-statement stmt = tell $ LlvmAccum (unitOL stmt) []
-
-doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
-doExprW a b = do
-    (var, stmt) <- lift $ doExpr a b
-    statement stmt
-    return var
-
-exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
-exprToVarW = liftExprData . exprToVar
-
-runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
-runExprData action = do
-    (var, LlvmAccum stmts decls) <- runWriterT action
-    return (var, stmts, decls)
-
-runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
-runStmtsDecls action = do
-    LlvmAccum stmts decls <- execWriterT action
-    return (stmts, decls)
-
-getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
-getCmmRegW = lift . getCmmReg
-
-genLoadW :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> WriterT LlvmAccum LlvmM LlvmVar
-genLoadW atomic e ty alignment = liftExprData $ genLoad atomic e ty alignment
-
--- | Return element of single-element list; 'panic' if list is not a single-element list
-singletonPanic :: String -> [a] -> a
-singletonPanic _ [x] = x
-singletonPanic s _ = panic s
diff --git a/compiler/GHC/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToLlvm/Data.hs
+++ /dev/null
@@ -1,236 +0,0 @@
-
--- ----------------------------------------------------------------------------
--- | Handle conversion of CmmData to LLVM code.
---
-
-module GHC.CmmToLlvm.Data (
-        genLlvmData, genData
-    ) where
-
-import GHC.Prelude
-
-import GHC.Llvm
-import GHC.CmmToLlvm.Base
-import GHC.CmmToLlvm.Config
-
-import GHC.Cmm.BlockId
-import GHC.Cmm.CLabel
-import GHC.Cmm.InitFini
-import GHC.Cmm
-import GHC.Platform
-
-import GHC.Data.FastString
-import GHC.Utils.Panic
-import qualified Data.ByteString as BS
-
--- ----------------------------------------------------------------------------
--- * Constants
---
-
--- | The string appended to a variable name to create its structure type alias
-structStr :: LMString
-structStr = fsLit "_struct"
-
--- | The LLVM visibility of the label
-linkage :: CLabel -> LlvmLinkageType
-linkage lbl = if externallyVisibleCLabel lbl
-              then ExternallyVisible else Internal
-
--- ----------------------------------------------------------------------------
--- * Top level
---
-
--- | Pass a CmmStatic section to an equivalent Llvm code.
-genLlvmData :: (Section, RawCmmStatics) -> LlvmM LlvmData
--- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
-genLlvmData (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])
-  | lbl == mkIndStaticInfoLabel
-  , let labelInd (CmmLabelOff l _) = Just l
-        labelInd (CmmLabel l) = Just l
-        labelInd _ = Nothing
-  , Just ind' <- labelInd ind
-  , alias `mayRedirectTo` ind' = do
-    label <- strCLabel_llvm alias
-    label' <- strCLabel_llvm ind'
-    let link     = linkage alias
-        link'    = linkage ind'
-        -- the LLVM type we give the alias is an empty struct type
-        -- but it doesn't really matter, as the pointer is only
-        -- used for (bit/int)casting.
-        tyAlias  = LMAlias (label `appendFS` structStr, LMStructU [])
-
-        aliasDef = LMGlobalVar label tyAlias link Nothing Nothing Alias
-        -- we don't know the type of the indirectee here
-        indType  = panic "will be filled by 'aliasify', later"
-        orig     = LMStaticPointer $ LMGlobalVar label' indType link' Nothing Nothing Alias
-
-    pure ([LMGlobal aliasDef $ Just orig], [tyAlias])
-
--- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini.
-genLlvmData (sect, statics)
-  | Just (initOrFini, clbls) <- isInitOrFiniArray (CmmData sect statics)
-  = let var = case initOrFini of
-                IsInitArray -> fsLit "llvm.global_ctors"
-                IsFiniArray -> fsLit "llvm.global_dtors"
-    in genGlobalLabelArray var clbls
-
-genLlvmData (sec, CmmStaticsRaw lbl xs) = do
-    label <- strCLabel_llvm lbl
-    static <- mapM genData xs
-    lmsec <- llvmSection sec
-    platform <- getPlatform
-    let types   = map getStatType static
-
-        strucTy = LMStruct types
-        tyAlias = LMAlias (label `appendFS` structStr, strucTy)
-
-        struct         = Just $ LMStaticStruc static tyAlias
-        link           = linkage lbl
-        align          = case sec of
-                            Section CString _ -> if (platformArch platform == ArchS390X)
-                                                    then Just 2 else Just 1
-                            _                 -> Nothing
-        const          = if sectionProtection sec == ReadOnlySection
-                            then Constant else Global
-        varDef         = LMGlobalVar label tyAlias link lmsec align const
-        globDef        = LMGlobal varDef struct
-
-    return ([globDef], [tyAlias])
-
--- | Produce an initializer or finalizer array declaration.
--- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for
--- details.
-genGlobalLabelArray :: FastString -> [CLabel] -> LlvmM LlvmData
-genGlobalLabelArray var_nm clbls = do
-    lbls <- mapM strCLabel_llvm clbls
-    decls <- mapM mkFunDecl lbls
-    let entries = map toArrayEntry lbls
-        static = LMStaticArray entries arr_ty
-        arr = LMGlobal arr_var (Just static)
-    return ([arr], decls)
-  where
-    mkFunDecl :: LMString -> LlvmM LlvmType
-    mkFunDecl fn_lbl = do
-        let fn_ty = mkFunTy fn_lbl
-        funInsert fn_lbl fn_ty
-        return (fn_ty)
-
-    toArrayEntry :: LMString -> LlvmStatic
-    toArrayEntry fn_lbl =
-        let fn_var = LMGlobalVar fn_lbl (LMPointer $ mkFunTy fn_lbl) Internal Nothing Nothing Global
-            fn = LMStaticPointer fn_var
-            null = LMStaticLit (LMNullLit i8Ptr)
-            prio = LMStaticLit $ LMIntLit 0xffff i32
-        in LMStaticStrucU [prio, fn, null] entry_ty
-
-    arr_var = LMGlobalVar var_nm arr_ty Internal Nothing Nothing Global
-    mkFunTy lbl = LMFunction $ LlvmFunctionDecl lbl ExternallyVisible CC_Ccc LMVoid FixedArgs [] Nothing
-    entry_ty = LMStructU [i32, LMPointer $ mkFunTy $ fsLit "placeholder", LMPointer i8]
-    arr_ty = LMArray (length clbls) entry_ty
-
--- | Format the section type part of a Cmm Section
-llvmSectionType :: Platform -> SectionType -> FastString
-llvmSectionType p t = case t of
-    Text                    -> fsLit ".text"
-    ReadOnlyData            -> case platformOS p of
-                                 OSMinGW32 -> fsLit ".rdata"
-                                 _         -> fsLit ".rodata"
-    RelocatableReadOnlyData -> case platformOS p of
-                                 OSMinGW32 -> fsLit ".rdata$rel.ro"
-                                 _         -> fsLit ".data.rel.ro"
-    Data                    -> fsLit ".data"
-    UninitialisedData       -> fsLit ".bss"
-    CString                 -> case platformOS p of
-                                 OSMinGW32 -> fsLit ".rdata$str"
-                                 _         -> fsLit ".rodata.str"
-
-    InitArray               -> panic "llvmSectionType: InitArray"
-    FiniArray               -> panic "llvmSectionType: FiniArray"
-    OtherSection _          -> panic "llvmSectionType: unknown section type"
-
--- | Format a Cmm Section into a LLVM section name
-llvmSection :: Section -> LlvmM LMSection
-llvmSection (Section t suffix) = do
-  opts <- getConfig
-  let splitSect = llvmCgSplitSection opts
-      platform  = llvmCgPlatform     opts
-  if not splitSect
-  then return Nothing
-  else do
-    lmsuffix <- strCLabel_llvm suffix
-    let result sep = Just (concatFS [llvmSectionType platform t
-                                    , fsLit sep, lmsuffix])
-    case platformOS platform of
-      OSMinGW32 -> return (result "$")
-      _         -> return (result ".")
-
--- ----------------------------------------------------------------------------
--- * Generate static data
---
-
--- | Handle static data
-genData :: CmmStatic -> LlvmM LlvmStatic
-
-genData (CmmFileEmbed {}) = panic "Unexpected CmmFileEmbed literal"
-genData (CmmString str) = do
-    let v  = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8)
-                 (BS.unpack str)
-        ve = v ++ [LMStaticLit $ LMIntLit 0 i8]
-    return $ LMStaticArray ve (LMArray (length ve) i8)
-
-genData (CmmUninitialised bytes)
-    = return $ LMUninitType (LMArray bytes i8)
-
-genData (CmmStaticLit lit)
-    = genStaticLit lit
-
--- | Generate Llvm code for a static literal.
---
--- Will either generate the code or leave it unresolved if it is a 'CLabel'
--- which isn't yet known.
-genStaticLit :: CmmLit -> LlvmM LlvmStatic
-genStaticLit (CmmInt i w)
-    = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w))
-
-genStaticLit (CmmFloat r w)
-    = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w))
-
-genStaticLit (CmmVec ls)
-    = do sls <- mapM toLlvmLit ls
-         return $ LMStaticLit (LMVectorLit sls)
-  where
-    toLlvmLit :: CmmLit -> LlvmM LlvmLit
-    toLlvmLit lit = do
-      slit <- genStaticLit lit
-      case slit of
-        LMStaticLit llvmLit -> return llvmLit
-        _ -> panic "genStaticLit"
-
--- Leave unresolved, will fix later
-genStaticLit cmm@(CmmLabel l) = do
-    var <- getGlobalPtr =<< strCLabel_llvm l
-    platform <- getPlatform
-    let ptr = LMStaticPointer var
-        lmty = cmmToLlvmType $ cmmLitType platform cmm
-    return $ LMPtoI ptr lmty
-
-genStaticLit (CmmLabelOff label off) = do
-    platform <- getPlatform
-    var <- genStaticLit (CmmLabel label)
-    let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord platform)
-    return $ LMAdd var offset
-
-genStaticLit (CmmLabelDiffOff l1 l2 off w) = do
-    platform <- getPlatform
-    var1 <- genStaticLit (CmmLabel l1)
-    var2 <- genStaticLit (CmmLabel l2)
-    let var
-          | w == wordWidth platform = LMSub var1 var2
-          | otherwise = LMTrunc (LMSub var1 var2) (widthToLlvmInt w)
-        offset = LMStaticLit $ LMIntLit (toInteger off) (LMInt $ widthInBits w)
-    return $ LMAdd var offset
-
-genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b
-
-genStaticLit (CmmHighStackMark)
-    = panic "genStaticLit: CmmHighStackMark unsupported!"
diff --git a/compiler/GHC/CmmToLlvm/Mangler.hs b/compiler/GHC/CmmToLlvm/Mangler.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToLlvm/Mangler.hs
+++ /dev/null
@@ -1,146 +0,0 @@
--- -----------------------------------------------------------------------------
--- | GHC LLVM Mangler
---
--- This script processes the assembly produced by LLVM, rewriting all symbols
--- of type @function to @object. This keeps them from going through the PLT,
--- which would be bad due to tables-next-to-code. On x86_64,
--- it also rewrites AVX instructions that require alignment to their
--- unaligned counterparts, since the stack is only 16-byte aligned but these
--- instructions require 32-byte alignment.
---
-
-module GHC.CmmToLlvm.Mangler ( llvmFixupAsm ) where
-
-import GHC.Prelude
-
-import GHC.Platform ( Platform, platformArch, Arch(..) )
-import GHC.Utils.Exception (try)
-
-import qualified Data.ByteString.Char8 as B
-import System.IO
-
--- | Read in assembly file and process
-llvmFixupAsm :: Platform -> FilePath -> FilePath -> IO ()
-llvmFixupAsm platform f1 f2 = {-# SCC "llvm_mangler" #-}
-  withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do
-      go r w
-      hClose r
-      hClose w
-      return ()
-  where
-    go :: Handle -> Handle -> IO ()
-    go r w = do
-      e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString)
-      let writeline a = B.hPutStrLn w (rewriteLine platform rewrites a) >> go r w
-      case e_l of
-        Right l -> writeline l
-        Left _  -> return ()
-
--- | These are the rewrites that the mangler will perform
-rewrites :: [Rewrite]
-rewrites = [rewriteSymType, rewriteAVX, rewriteCall]
-
-type Rewrite = Platform -> B.ByteString -> Maybe B.ByteString
-
--- | Rewrite a line of assembly source with the given rewrites,
--- taking the first rewrite that applies.
-rewriteLine :: Platform -> [Rewrite] -> B.ByteString -> B.ByteString
-rewriteLine platform rewrites l
-  -- We disable .subsections_via_symbols on darwin and ios, as the llvm code
-  -- gen uses prefix data for the info table.  This however does not prevent
-  -- llvm from generating .subsections_via_symbols, which in turn with
-  -- -dead_strip, strips the info tables, and therefore breaks ghc.
-  | isSubsectionsViaSymbols l =
-    (B.pack "## no .subsection_via_symbols for ghc. We need our info tables!")
-  | otherwise =
-    case firstJust $ map (\rewrite -> rewrite platform rest) rewrites of
-      Nothing        -> l
-      Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten]
-  where
-    isSubsectionsViaSymbols = B.isPrefixOf (B.pack ".subsections_via_symbols")
-
-    (symbol, rest) = splitLine l
-
-    firstJust :: [Maybe a] -> Maybe a
-    firstJust (Just x:_) = Just x
-    firstJust []         = Nothing
-    firstJust (_:rest)   = firstJust rest
-
--- | This rewrites @.type@ annotations of function symbols to @%object@.
--- This is done as the linker can relocate @%functions@ through the
--- Procedure Linking Table (PLT). This is bad since we expect that the
--- info table will appear directly before the symbol's location. In the
--- case that the PLT is used, this will be not an info table but instead
--- some random PLT garbage.
-rewriteSymType :: Rewrite
-rewriteSymType _ l
-  | isType l  = Just $ rewrite '@' $ rewrite '%' l
-  | otherwise = Nothing
-  where
-    isType = B.isPrefixOf (B.pack ".type")
-
-    rewrite :: Char -> B.ByteString -> B.ByteString
-    rewrite prefix = replaceOnce funcType objType
-      where
-        funcType = prefix `B.cons` B.pack "function"
-        objType  = prefix `B.cons` B.pack "object"
-
--- | This rewrites aligned AVX instructions to their unaligned counterparts on
--- x86-64. This is necessary because the stack is not adequately aligned for
--- aligned AVX spills, so LLVM would emit code that adjusts the stack pointer
--- and disable tail call optimization. Both would be catastrophic here so GHC
--- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then
--- rewrites the instructions in the mangler.
-rewriteAVX :: Rewrite
-rewriteAVX platform s
-  | not isX86_64 = Nothing
-  | isVmovdqa s  = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s
-  | isVmovap s   = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s
-  | otherwise    = Nothing
-  where
-    isX86_64 = platformArch platform == ArchX86_64
-    isVmovdqa = B.isPrefixOf (B.pack "vmovdqa")
-    isVmovap = B.isPrefixOf (B.pack "vmovap")
-
--- | This rewrites (tail) calls to avoid creating PLT entries for
--- functions on riscv64. The replacement will load the address from the
--- GOT, which is resolved to point to the real address of the function.
-rewriteCall :: Rewrite
-rewriteCall platform l
-  | not isRISCV64 = Nothing
-  | isCall l      = Just $ replaceCall "call" "jalr" "ra" l
-  | isTail l      = Just $ replaceCall "tail" "jr" "t1" l
-  | otherwise     = Nothing
-  where
-    isRISCV64 = platformArch platform == ArchRISCV64
-    isCall = B.isPrefixOf (B.pack "call\t")
-    isTail = B.isPrefixOf (B.pack "tail\t")
-
-    replaceCall call jump reg l =
-        appendInsn (jump ++ "\t" ++ reg) $ removePlt $
-        replaceOnce (B.pack call) (B.pack ("la\t" ++ reg ++ ",")) l
-      where
-        removePlt = replaceOnce (B.pack "@plt") (B.pack "")
-        appendInsn i = (`B.append` B.pack ("\n\t" ++ i))
-
--- | @replaceOnce match replace bs@ replaces the first occurrence of the
--- substring @match@ in @bs@ with @replace@.
-replaceOnce :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
-replaceOnce matchBS replaceOnceBS = loop
-  where
-    loop :: B.ByteString -> B.ByteString
-    loop cts =
-        case B.breakSubstring matchBS cts of
-          (hd,tl) | B.null tl -> hd
-                  | otherwise -> hd `B.append` replaceOnceBS `B.append`
-                                 B.drop (B.length matchBS) tl
-
--- | This function splits a line of assembly code into the label and the
--- rest of the code.
-splitLine :: B.ByteString -> (B.ByteString, B.ByteString)
-splitLine l = (symbol, B.dropWhile isSpace rest)
-  where
-    isSpace ' ' = True
-    isSpace '\t' = True
-    isSpace _ = False
-    (symbol, rest) = B.span (not . isSpace) l
diff --git a/compiler/GHC/CmmToLlvm/Ppr.hs b/compiler/GHC/CmmToLlvm/Ppr.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToLlvm/Ppr.hs
+++ /dev/null
@@ -1,101 +0,0 @@
-
-
--- ----------------------------------------------------------------------------
--- | Pretty print helpers for the LLVM Code generator.
---
-module GHC.CmmToLlvm.Ppr (
-        pprLlvmCmmDecl, pprLlvmData, infoSection
-    ) where
-
-import GHC.Prelude
-
-import GHC.Llvm
-import GHC.CmmToLlvm.Base
-import GHC.CmmToLlvm.Data
-import GHC.CmmToLlvm.Config
-
-import GHC.Cmm.CLabel
-import GHC.Cmm
-
-import GHC.Data.FastString
-import GHC.Utils.Outputable
-import GHC.Types.Unique
-
--- ----------------------------------------------------------------------------
--- * Top level
---
-
--- | Pretty print LLVM data code
-pprLlvmData :: LlvmCgConfig -> LlvmData -> SDoc
-pprLlvmData cfg (globals, types) =
-    let ppLlvmTys (LMAlias    a) = ppLlvmAlias a
-        ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f
-        ppLlvmTys _other         = empty
-
-        types'   = vcat $ map ppLlvmTys types
-        globals' = ppLlvmGlobals cfg globals
-    in types' $+$ globals'
-
-
--- | Pretty print LLVM code
-pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
-pprLlvmCmmDecl (CmmData _ lmdata) = do
-  opts <- getConfig
-  return (vcat $ map (pprLlvmData opts) lmdata, [])
-
-pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
-  = do let lbl = case mb_info of
-                     Nothing -> entry_lbl
-                     Just (CmmStaticsRaw info_lbl _) -> info_lbl
-           link = if externallyVisibleCLabel lbl
-                      then ExternallyVisible
-                      else Internal
-           lmblocks = map (\(BasicBlock id stmts) ->
-                                LlvmBlock (getUnique id) stmts) blks
-
-       funDec   <- llvmFunSig live lbl link
-       cfg      <- getConfig
-       platform <- getPlatform
-       let buildArg = fsLit . showSDocOneLine (llvmCgContext cfg). ppPlainName cfg
-           funArgs = map buildArg (llvmFunArgs platform live)
-           funSect = llvmFunSection cfg (decName funDec)
-
-       -- generate the info table
-       prefix <- case mb_info of
-                     Nothing -> return Nothing
-                     Just (CmmStaticsRaw _ statics) -> do
-                       infoStatics <- mapM genData statics
-                       let infoTy = LMStruct $ map getStatType infoStatics
-                       return $ Just $ LMStaticStruc infoStatics infoTy
-
-
-       let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect
-                              prefix lmblocks
-           name = decName $ funcDecl fun
-           defName = llvmDefLabel name
-           funcDecl' = (funcDecl fun) { decName = defName }
-           fun' = fun { funcDecl = funcDecl' }
-           funTy = LMFunction funcDecl'
-           funVar = LMGlobalVar name
-                                (LMPointer funTy)
-                                link
-                                Nothing
-                                Nothing
-                                Alias
-           defVar = LMGlobalVar defName
-                                (LMPointer funTy)
-                                (funcLinkage funcDecl')
-                                (funcSect fun)
-                                (funcAlign funcDecl')
-                                Alias
-           alias = LMGlobal funVar
-                            (Just $ LMBitc (LMStaticPointer defVar)
-                                           i8Ptr)
-
-       return (ppLlvmGlobal cfg alias $+$ ppLlvmFunction cfg fun', [])
-
-
--- | The section we are putting info tables and their entry code into, should
--- be unique since we process the assembly pattern matching this.
-infoSection :: String
-infoSection = "X98A__STRIP,__me"
diff --git a/compiler/GHC/CmmToLlvm/Regs.hs b/compiler/GHC/CmmToLlvm/Regs.hs
deleted file mode 100644
--- a/compiler/GHC/CmmToLlvm/Regs.hs
+++ /dev/null
@@ -1,136 +0,0 @@
-
-
---------------------------------------------------------------------------------
--- | Deal with Cmm registers
---
-
-module GHC.CmmToLlvm.Regs (
-        lmGlobalRegArg, lmGlobalRegVar, alwaysLive,
-        stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA
-    ) where
-
-import GHC.Prelude
-
-import GHC.Llvm
-
-import GHC.Cmm.Expr
-import GHC.Platform
-import GHC.Data.FastString
-import GHC.Utils.Panic ( panic )
-import GHC.Types.Unique
-
--- | Get the LlvmVar function variable storing the real register
-lmGlobalRegVar :: Platform -> GlobalReg -> LlvmVar
-lmGlobalRegVar platform = pVarLift . lmGlobalReg platform "_Var"
-
--- | Get the LlvmVar function argument storing the real register
-lmGlobalRegArg :: Platform -> GlobalReg -> LlvmVar
-lmGlobalRegArg platform = lmGlobalReg platform "_Arg"
-
-{- Need to make sure the names here can't conflict with the unique generated
-   names. Uniques generated names containing only base62 chars. So using say
-   the '_' char guarantees this.
--}
-lmGlobalReg :: Platform -> String -> GlobalReg -> LlvmVar
-lmGlobalReg platform suf reg
-  = case reg of
-        BaseReg        -> ptrGlobal $ "Base" ++ suf
-        Sp             -> ptrGlobal $ "Sp" ++ suf
-        Hp             -> ptrGlobal $ "Hp" ++ suf
-        VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf
-        VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf
-        VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf
-        VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf
-        VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf
-        VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf
-        VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf
-        VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf
-        VanillaReg 9 _ -> wordGlobal $ "R9" ++ suf
-        VanillaReg 10 _ -> wordGlobal $ "R10" ++ suf
-        SpLim          -> wordGlobal $ "SpLim" ++ suf
-        FloatReg 1     -> floatGlobal $ "F1" ++ suf
-        FloatReg 2     -> floatGlobal $ "F2" ++ suf
-        FloatReg 3     -> floatGlobal $ "F3" ++ suf
-        FloatReg 4     -> floatGlobal $ "F4" ++ suf
-        FloatReg 5     -> floatGlobal $ "F5" ++ suf
-        FloatReg 6     -> floatGlobal $ "F6" ++ suf
-        DoubleReg 1    -> doubleGlobal $ "D1" ++ suf
-        DoubleReg 2    -> doubleGlobal $ "D2" ++ suf
-        DoubleReg 3    -> doubleGlobal $ "D3" ++ suf
-        DoubleReg 4    -> doubleGlobal $ "D4" ++ suf
-        DoubleReg 5    -> doubleGlobal $ "D5" ++ suf
-        DoubleReg 6    -> doubleGlobal $ "D6" ++ suf
-        XmmReg 1       -> xmmGlobal $ "XMM1" ++ suf
-        XmmReg 2       -> xmmGlobal $ "XMM2" ++ suf
-        XmmReg 3       -> xmmGlobal $ "XMM3" ++ suf
-        XmmReg 4       -> xmmGlobal $ "XMM4" ++ suf
-        XmmReg 5       -> xmmGlobal $ "XMM5" ++ suf
-        XmmReg 6       -> xmmGlobal $ "XMM6" ++ suf
-        YmmReg 1       -> ymmGlobal $ "YMM1" ++ suf
-        YmmReg 2       -> ymmGlobal $ "YMM2" ++ suf
-        YmmReg 3       -> ymmGlobal $ "YMM3" ++ suf
-        YmmReg 4       -> ymmGlobal $ "YMM4" ++ suf
-        YmmReg 5       -> ymmGlobal $ "YMM5" ++ suf
-        YmmReg 6       -> ymmGlobal $ "YMM6" ++ suf
-        ZmmReg 1       -> zmmGlobal $ "ZMM1" ++ suf
-        ZmmReg 2       -> zmmGlobal $ "ZMM2" ++ suf
-        ZmmReg 3       -> zmmGlobal $ "ZMM3" ++ suf
-        ZmmReg 4       -> zmmGlobal $ "ZMM4" ++ suf
-        ZmmReg 5       -> zmmGlobal $ "ZMM5" ++ suf
-        ZmmReg 6       -> zmmGlobal $ "ZMM6" ++ suf
-        MachSp         -> wordGlobal $ "MachSp" ++ suf
-        _other         -> panic $ "GHC.CmmToLlvm.Reg: GlobalReg (" ++ (show reg)
-                                ++ ") not supported!"
-        -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc
-        -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg
-    where
-        wordGlobal   name = LMNLocalVar (fsLit name) (llvmWord platform)
-        ptrGlobal    name = LMNLocalVar (fsLit name) (llvmWordPtr platform)
-        floatGlobal  name = LMNLocalVar (fsLit name) LMFloat
-        doubleGlobal name = LMNLocalVar (fsLit name) LMDouble
-        xmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 4 (LMInt 32))
-        ymmGlobal    name = LMNLocalVar (fsLit name) (LMVector 8 (LMInt 32))
-        zmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 16 (LMInt 32))
-
--- | A list of STG Registers that should always be considered alive
-alwaysLive :: [GlobalReg]
-alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node]
-
--- | STG Type Based Alias Analysis hierarchy
-stgTBAA :: [(Unique, LMString, Maybe Unique)]
-stgTBAA
-  = [ (rootN,  fsLit "root",   Nothing)
-    , (topN,   fsLit "top",   Just rootN)
-    , (stackN, fsLit "stack", Just topN)
-    , (heapN,  fsLit "heap",  Just topN)
-    , (rxN,    fsLit "rx",    Just heapN)
-    , (baseN,  fsLit "base",  Just topN)
-    -- FIX: Not 100% sure if this hierarchy is complete.  I think the big thing
-    -- is Sp is never aliased, so might want to change the hierarchy to have Sp
-    -- on its own branch that is never aliased (e.g never use top as a TBAA
-    -- node).
-    ]
-
--- | Id values
--- The `rootN` node is the root (there can be more than one) of the TBAA
--- hierarchy and as of LLVM 4.0 should *only* be referenced by other nodes. It
--- should never occur in any LLVM instruction statement.
-rootN, topN, stackN, heapN, rxN, baseN :: Unique
-rootN  = getUnique (fsLit "GHC.CmmToLlvm.Regs.rootN")
-topN   = getUnique (fsLit "GHC.CmmToLlvm.Regs.topN")
-stackN = getUnique (fsLit "GHC.CmmToLlvm.Regs.stackN")
-heapN  = getUnique (fsLit "GHC.CmmToLlvm.Regs.heapN")
-rxN    = getUnique (fsLit "GHC.CmmToLlvm.Regs.rxN")
-baseN  = getUnique (fsLit "GHC.CmmToLlvm.Regs.baseN")
-
--- | The TBAA metadata identifier
-tbaa :: LMString
-tbaa = fsLit "tbaa"
-
--- | Get the correct TBAA metadata information for this register type
-getTBAA :: GlobalReg -> Unique
-getTBAA BaseReg          = baseN
-getTBAA Sp               = stackN
-getTBAA Hp               = heapN
-getTBAA (VanillaReg _ _) = rxN
-getTBAA _                = topN
diff --git a/compiler/GHC/Core/LateCC.hs b/compiler/GHC/Core/LateCC.hs
deleted file mode 100644
--- a/compiler/GHC/Core/LateCC.hs
+++ /dev/null
@@ -1,167 +0,0 @@
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE TupleSections #-}
-
--- | Adds cost-centers after the core piple has run.
-module GHC.Core.LateCC
-    ( addLateCostCentresMG
-    , addLateCostCentresPgm
-    , addLateCostCentres -- Might be useful for API users
-    , Env(..)
-    ) where
-
-import Control.Applicative
-import Control.Monad
-import qualified Data.Set as S
-
-import GHC.Prelude
-import GHC.Types.CostCentre
-import GHC.Types.CostCentre.State
-import GHC.Types.Name hiding (varName)
-import GHC.Types.Tickish
-import GHC.Unit.Module.ModGuts
-import GHC.Types.Var
-import GHC.Unit.Types
-import GHC.Data.FastString
-import GHC.Core
-import GHC.Core.Opt.Monad
-import GHC.Core.Utils (mkTick)
-import GHC.Types.Id
-import GHC.Driver.Session
-
-import GHC.Utils.Logger
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Error (withTiming)
-import GHC.Utils.Monad.State.Strict
-
-
-{- Note [Collecting late cost centres]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Usually cost centres defined by a module are collected
-during tidy by collectCostCentres. However with `-fprof-late`
-we insert cost centres after inlining. So we keep a list of
-all the cost centres we inserted and combine that with the list
-of cost centres found during tidy.
-
-To avoid overhead when using -fprof-inline there is a flag to stop
-us from collecting them here when we run this pass before tidy.
-
-Note [Adding late cost centres]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The basic idea is very simple. For every top level binder
-`f = rhs` we compile it as if the user had written
-`f = {-# SCC f #-} rhs`.
-
-If we do this after unfoldings for `f` have been created this
-doesn't impact core-level optimizations at all. If we do it
-before the cost centre will be included in the unfolding and
-might inhibit optimizations at the call site. For this reason
-we provide flags for both approaches as they have different
-tradeoffs.
-
-We also don't add a cost centre for any binder that is a constructor
-worker or wrapper. These will never meaningfully enrich the resulting
-profile so we improve efficiency by omitting those.
-
--}
-
-addLateCostCentresMG :: ModGuts -> CoreM ModGuts
-addLateCostCentresMG guts = do
-  dflags <- getDynFlags
-  let env :: Env
-      env = Env
-        { thisModule = mg_module guts
-        , ccState = newCostCentreState
-        , countEntries = gopt Opt_ProfCountEntries dflags
-        , collectCCs = False -- See Note [Collecting late cost centres]
-        }
-  let guts' = guts { mg_binds = fst (addLateCostCentres env (mg_binds guts))
-                   }
-  return guts'
-
-addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre)
-addLateCostCentresPgm dflags logger mod binds =
-  withTiming logger
-               (text "LateCC"<+>brackets (ppr mod))
-               (\(a,b) -> a `seqList` (b `seq` ())) $ do
-  let env = Env
-        { thisModule = mod
-        , ccState = newCostCentreState
-        , countEntries = gopt Opt_ProfCountEntries dflags
-        , collectCCs = True -- See Note [Collecting late cost centres]
-        }
-      (binds', ccs) = addLateCostCentres env binds
-  when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $
-    putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr binds'))
-  return (binds', ccs)
-
-addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre)
-addLateCostCentres env binds =
-  let (binds', state) = runState (mapM (doBind env) binds) initLateCCState
-  in (binds',lcs_ccs state)
-
-
-doBind :: Env -> CoreBind -> M CoreBind
-doBind env (NonRec b rhs) = NonRec b <$> doBndr env b rhs
-doBind env (Rec bs) = Rec <$> mapM doPair bs
-  where
-    doPair :: ((Id, CoreExpr) -> M (Id, CoreExpr))
-    doPair (b,rhs) = (b,) <$> doBndr env b rhs
-
-doBndr :: Env -> Id -> CoreExpr -> M CoreExpr
-doBndr env bndr rhs
-  -- Cost centres on constructor workers are pretty much useless
-  -- so we don't emit them if we are looking at the rhs of a constructor
-  -- binding.
-  | Just _ <- isDataConId_maybe bndr = pure rhs
-  | otherwise = doBndr' env bndr rhs
-
-
--- We want to put the cost centra below the lambda as we only care about executions of the RHS.
-doBndr' :: Env -> Id -> CoreExpr -> State LateCCState CoreExpr
-doBndr' env bndr (Lam b rhs) = Lam b <$> doBndr' env bndr rhs
-doBndr' env bndr rhs = do
-    let name = idName bndr
-        name_loc = nameSrcSpan name
-        cc_name = getOccFS name
-        count = countEntries env
-    cc_flavour <- getCCFlavour cc_name
-    let cc_mod = thisModule env
-        bndrCC = NormalCC cc_flavour cc_name cc_mod name_loc
-        note = ProfNote bndrCC count True
-    addCC env bndrCC
-    return $ mkTick note rhs
-
-data LateCCState = LateCCState
-    { lcs_state :: !CostCentreState
-    , lcs_ccs   :: S.Set CostCentre
-    }
-type M = State LateCCState
-
-initLateCCState :: LateCCState
-initLateCCState = LateCCState newCostCentreState mempty
-
-getCCFlavour :: FastString -> M CCFlavour
-getCCFlavour name = LateCC <$> getCCIndex' name
-
-getCCIndex' :: FastString -> M CostCentreIndex
-getCCIndex' name = do
-  state <- get
-  let (index,cc_state') = getCCIndex name (lcs_state state)
-  put (state { lcs_state = cc_state'})
-  return index
-
-addCC :: Env -> CostCentre -> M ()
-addCC !env cc = do
-    state <- get
-    when (collectCCs env) $ do
-        let ccs' = S.insert cc (lcs_ccs state)
-        put (state { lcs_ccs = ccs'})
-
-data Env = Env
-  { thisModule  :: !Module
-  , countEntries:: !Bool
-  , ccState     :: !CostCentreState
-  , collectCCs  :: !Bool
-  }
-
diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs
deleted file mode 100644
--- a/compiler/GHC/Core/Opt/CSE.hs
+++ /dev/null
@@ -1,919 +0,0 @@
-{-
-(c) The AQUA Project, Glasgow University, 1993-1998
-
-\section{Common subexpression}
--}
-
-module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where
-
-import GHC.Prelude
-
-import GHC.Core.Subst
-import GHC.Types.Var    ( Var )
-import GHC.Types.Var.Env ( mkInScopeSet )
-import GHC.Types.Id     ( Id, idType, idHasRules, zapStableUnfolding
-                        , idInlineActivation, setInlineActivation
-                        , zapIdOccInfo, zapIdUsageInfo, idInlinePragma
-                        , isJoinId, isJoinId_maybe, idUnfolding )
-import GHC.Core.Utils   ( mkAltExpr
-                        , exprIsTickedString
-                        , stripTicksE, stripTicksT, mkTicks )
-import GHC.Core.FVs     ( exprFreeVars )
-import GHC.Core.Type    ( tyConAppArgs )
-import GHC.Core
-import GHC.Utils.Outputable
-import GHC.Types.Basic
-import GHC.Types.Tickish
-import GHC.Core.Map.Expr
-import GHC.Utils.Misc   ( filterOut, equalLength )
-import GHC.Utils.Panic
-import Data.Functor.Identity ( Identity (..) )
-import Data.List        ( mapAccumL )
-
-{-
-                        Simple common sub-expression
-                        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we see
-        x1 = C a b
-        x2 = C x1 b
-we build up a reverse mapping:   C a b  -> x1
-                                 C x1 b -> x2
-and apply that to the rest of the program.
-
-When we then see
-        y1 = C a b
-        y2 = C y1 b
-we replace the C a b with x1.  But then we *dont* want to
-add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1
-so that a subsequent binding
-        y2 = C y1 b
-will get transformed to C x1 b, and then to x2.
-
-So we carry an extra var->var substitution which we apply *before* looking up in the
-reverse mapping.
-
-
-Note [Shadowing]
-~~~~~~~~~~~~~~~~
-We have to be careful about shadowing.
-For example, consider
-        f = \x -> let y = x+x in
-                      h = \x -> x+x
-                  in ...
-
-Here we must *not* do CSE on the inner x+x!  The simplifier used to guarantee no
-shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
-We can simply add clones to the substitution already described.
-
-A similar tricky situation is this, with x_123 and y_123 sharing the same unique:
-
-    let x_123 = e1 in
-    let y_123 = e2 in
-    let foo = e1
-
-Naively applying e1 = x_123 during CSE we would get:
-
-    let x_123 = e1 in
-    let y_123 = e2 in
-    let foo = x_123
-
-But x_123 is shadowed by y_123 and things would go terribly wrong! One more reason
-why we have to substitute binders as we go so we will properly get:
-
-    let x1 = e1 in
-    let x2 = e2 in
-    let foo = x1
-
-Note [CSE for bindings]
-~~~~~~~~~~~~~~~~~~~~~~~
-Let-bindings have two cases, implemented by extendCSEnvWithBinding.
-
-* SUBSTITUTE: applies when the RHS is a variable
-
-     let x = y in ...(h x)....
-
-  Here we want to extend the /substitution/ with x -> y, so that the
-  (h x) in the body might CSE with an enclosing (let v = h y in ...).
-  NB: the substitution maps InIds, so we extend the substitution with
-      a binding for the original InId 'x'
-
-  How can we have a variable on the RHS? Doesn't the simplifier inline them?
-
-    - First, the original RHS might have been (g z) which has CSE'd
-      with an enclosing (let y = g z in ...).  This is super-important.
-      See #5996:
-         x1 = C a b
-         x2 = C x1 b
-         y1 = C a b
-         y2 = C y1 b
-      Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to
-      the substitution so that we can CSE the binding for y2.
-
-    - Second, we use extendCSEnvWithBinding for case expression scrutinees too;
-      see Note [CSE for case expressions]
-
-* EXTEND THE REVERSE MAPPING: applies in all other cases
-
-     let x = h y in ...(h y)...
-
-  Here we want to extend the /reverse mapping (cs_map)/ so that
-  we CSE the (h y) call to x.
-
-  Note that we use EXTEND even for a trivial expression, provided it
-  is not a variable or literal. In particular this /includes/ type
-  applications. This can be important (#13156); e.g.
-     case f @ Int of { r1 ->
-     case f @ Int of { r2 -> ...
-  Here we want to common-up the two uses of (f @ Int) so we can
-  remove one of the case expressions.
-
-  See also Note [Corner case for case expressions] for another
-  reason not to use SUBSTITUTE for all trivial expressions.
-
-Notice that
-  - The SUBSTITUTE situation extends the substitution (cs_subst)
-  - The EXTEND situation extends the reverse mapping (cs_map)
-
-Notice also that in the SUBSTITUTE case we leave behind a binding
-  x = y
-even though we /also/ carry a substitution x -> y.  Can we just drop
-the binding instead?  Well, not at top level! See Note [Top level and
-postInlineUnconditionally] in GHC.Core.Opt.Simplify.Utils; and in any
-case CSE applies only to the /bindings/ of the program, and we leave
-it to the simplifier to propagate effects to the RULES. Finally, it
-doesn't seem worth the effort to discard the nested bindings because
-the simplifier will do it next.
-
-Note [CSE for case expressions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  case scrut_expr of x { ...alts... }
-This is very like a strict let-binding
-  let !x = scrut_expr in ...
-So we use (extendCSEnvWithBinding x scrut_expr) to process scrut_expr and x, and as a
-result all the stuff under Note [CSE for bindings] applies directly.
-
-For example:
-
-* Trivial scrutinee
-     f = \x -> case x of wild {
-                 (a:as) -> case a of wild1 {
-                             (p,q) -> ...(wild1:as)...
-
-  Here, (wild1:as) is morally the same as (a:as) and hence equal to
-  wild. But that's not quite obvious.  In the rest of the compiler we
-  want to keep it as (wild1:as), but for CSE purpose that's a bad
-  idea.
-
-  By using extendCSEnvWithBinding we add the binding (wild1 -> a) to the substitution,
-  which does exactly the right thing.
-
-  (Notice this is exactly backwards to what the simplifier does, which
-  is to try to replaces uses of 'a' with uses of 'wild1'.)
-
-  This is the main reason that extendCSEnvWithBinding is called with a trivial rhs.
-
-* Non-trivial scrutinee
-     case (f x) of y { pat -> ...let z = f x in ... }
-
-  By using extendCSEnvWithBinding we'll add (f x :-> y) to the cs_map, and
-  thereby CSE the inner (f x) to y.
-
-Note [CSE for INLINE and NOINLINE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are some subtle interactions of CSE with functions that the user
-has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)
-Consider
-
-        yes :: Int  {-# NOINLINE yes #-}
-        yes = undefined
-
-        no :: Int   {-# NOINLINE no #-}
-        no = undefined
-
-        foo :: Int -> Int -> Int  {-# NOINLINE foo #-}
-        foo m n = n
-
-        {-# RULES "foo/no" foo no = id #-}
-
-        bar :: Int -> Int
-        bar = foo yes
-
-We do not expect the rule to fire.  But if we do CSE, then we risk
-getting yes=no, and the rule does fire.  Actually, it won't because
-NOINLINE means that 'yes' will never be inlined, not even if we have
-yes=no.  So that's fine (now; perhaps in the olden days, yes=no would
-have substituted even if 'yes' was NOINLINE).
-
-But we do need to take care.  Consider
-
-        {-# NOINLINE bar #-}
-        bar = <rhs>     -- Same rhs as foo
-
-        foo = <rhs>
-
-If CSE produces
-        foo = bar
-then foo will never be inlined to <rhs> (when it should be, if <rhs>
-is small).  The conclusion here is this:
-
-   We should not add
-       <rhs> :-> bar
-  to the CSEnv if 'bar' has any constraints on when it can inline;
-  that is, if its 'activation' not always active.  Otherwise we
-  might replace <rhs> by 'bar', and then later be unable to see that it
-  really was <rhs>.
-
-An exception to the rule is when the INLINE pragma is not from the user, e.g. from
-WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec
-is then true.
-
-Note that we do not (currently) do CSE on the unfolding stored inside
-an Id, even if it is a 'stable' unfolding.  That means that when an
-unfolding happens, it is always faithful to what the stable unfolding
-originally was.
-
-Note [CSE for stable unfoldings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   {-# Unf = Stable (\pq. build blah) #-}
-   foo = x
-
-Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial.
-(Turns out that this actually happens for the enumFromTo method of
-the Integer instance of Enum in GHC.Enum.)  Suppose moreover that foo's
-stable unfolding originates from an INLINE or INLINEABLE pragma on foo.
-Then we obviously do NOT want to extend the substitution with (foo->x),
-because we promised to inline foo as what the user wrote.  See similar Note
-[Stable unfoldings and postInlineUnconditionally] in GHC.Core.Opt.Simplify.Utils.
-
-Nor do we want to change the reverse mapping. Suppose we have
-
-   foo {-# Unf = Stable (\pq. build blah) #-}
-       = <expr>
-   bar = <expr>
-
-There could conceivably be merit in rewriting the RHS of bar:
-   bar = foo
-but now bar's inlining behaviour will change, and importing
-modules might see that.  So it seems dodgy and we don't do it.
-
-Wrinkles
-
-* Stable unfoldings are also created during worker/wrapper when we
-  decide that a function's definition is so small that it should
-  always inline, or indeed for the wrapper function itself.  In this
-  case we still want to do CSE (#13340). Hence the use of
-  isStableUserUnfolding/isStableSystemUnfolding rather than
-  isStableUnfolding.
-
-* Consider
-     foo = <expr>
-     bar {-# Unf = Stable ... #-}
-        = <expr>
-  where the unfolding was added by strictness analysis, say.  Then
-  CSE goes ahead, so we get
-     bar = foo
-  and probably use SUBSTITUTE that will make 'bar' dead.  But just
-  possibly not -- see Note [Dealing with ticks].  In that case we might
-  be left with
-     bar = tick t1 (tick t2 foo)
-  in which case we would really like to get rid of the stable unfolding
-  (generated by the strictness analyser, say).
-
-  Hence the zapStableUnfolding in cse_bind.  Not a big deal, and only
-  makes a difference when ticks get into the picture.
-
-Note [Corner case for case expressions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here is another reason that we do not use SUBSTITUTE for
-all trivial expressions. Consider
-   case x |> co of (y::Array# Int) { ... }
-
-We do not want to extend the substitution with (y -> x |> co); since y
-is of unlifted type, this would destroy the let-can-float invariant if
-(x |> co) was not ok-for-speculation.
-
-But surely (x |> co) is ok-for-speculation, because it's a trivial
-expression, and x's type is also unlifted, presumably.  Well, maybe
-not if you are using unsafe casts.  I actually found a case where we
-had
-   (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int)
-
-Note [CSE for join points?]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must not be naive about join points in CSE:
-   join j = e in
-   if b then jump j else 1 + e
-The expression (1 + jump j) is not good (see Note [Invariants on join points] in
-GHC.Core). This seems to come up quite seldom, but it happens (first seen
-compiling ppHtml in Haddock.Backends.Xhtml).
-
-We could try and be careful by tracking which join points are still valid at
-each subexpression, but since join points aren't allocated or shared, there's
-less to gain by trying to CSE them. (#13219)
-
-Note [Look inside join-point binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Another way how CSE for join points is tricky is
-
-  let join foo x = (x, 42)
-      join bar x = (x, 42)
-  in … jump foo 1 … jump bar 2 …
-
-naively, CSE would turn this into
-
-  let join foo x = (x, 42)
-      join bar = foo
-  in … jump foo 1 … jump bar 2 …
-
-but now bar is a join point that claims arity one, but its right-hand side
-is not a lambda, breaking the join-point invariant (this was #15002).
-
-So `cse_bind` must zoom past the lambdas of a join point (using
-`collectNBinders`) and resume searching for CSE opportunities only in
-the body of the join point.
-
-Note [CSE for recursive bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  f = \x ... f....
-  g = \y ... g ...
-where the "..." are identical.  Could we CSE them?  In full generality
-with mutual recursion it's quite hard; but for self-recursive bindings
-(which are very common) it's rather easy:
-
-* Maintain a separate cs_rec_map, that maps
-      (\f. (\x. ...f...) ) -> f
-  Note the \f in the domain of the mapping!
-
-* When we come across the binding for 'g', look up (\g. (\y. ...g...))
-  Bingo we get a hit.  So we can replace the 'g' binding with
-     g = f
-
-We can't use cs_map for this, because the key isn't an expression of
-the program; it's a kind of synthetic key for recursive bindings.
-
-Note [Separate envs for let rhs and body]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Substituting occurrences of the binder in the rhs with the
- renamed binder is wrong for non-recursive bindings. Why?
-Consider this core.
-
-    let {x_123 = e} in
-    let {y_123 = \eta0 -> x_123} in ...
-
-In the second line the y_123 on the lhs and x_123 on the rhs refer to different binders
-even if they share the same unique.
-
-If we apply the substitution `123 => x2_124}` to both the lhs and rhs we  will transform
-`let y_123 = \eta0 -> x_123` into `let x2_124 = \eta0 -> x2_124`.
-However x2_124 on the rhs is not in scope and really shouldn't have been renamed at all.
-Because really this should still be x_123! In fact this exact thing happened in #21685.
-
-To fix this we pass two different cse envs to cse_bind. One we use the cse the rhs of the binding.
-And one we update with the result of cseing the rhs which we then use going forward for the
-body/rest of the module.
-
-************************************************************************
-*                                                                      *
-\section{Common subexpression}
-*                                                                      *
-************************************************************************
--}
-
-cseProgram :: CoreProgram -> CoreProgram
-cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds)
-
-cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind)
-cseBind toplevel env (NonRec b e)
-  = (env2, NonRec b2 e2)
-  where
-    -- See Note [Separate envs for let rhs and body]
-    (env1, b1)       = addBinder env b
-    (env2, (b2, e2)) = cse_bind toplevel env env1 (b,e) b1
-
-cseBind toplevel env (Rec [(in_id, rhs)])
-  | noCSE in_id
-  = (env1, Rec [(out_id, rhs')])
-
-  -- See Note [CSE for recursive bindings]
-  | Just previous <- lookupCSRecEnv env out_id rhs''
-  , let previous' = mkTicks ticks previous
-        out_id'   = delayInlining toplevel out_id
-  = -- We have a hit in the recursive-binding cache
-    (extendCSSubst env1 in_id previous', NonRec out_id' previous')
-
-  | otherwise
-  = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')])
-
-  where
-    (env1, Identity out_id) = addRecBinders env (Identity in_id)
-    rhs'  = cseExpr env1 rhs
-    rhs'' = stripTicksE tickishFloatable rhs'
-    ticks = stripTicksT tickishFloatable rhs'
-    id_expr'  = varToCoreExpr out_id
-    zapped_id = zapIdUsageInfo out_id
-
-cseBind toplevel env (Rec pairs)
-  = (env2, Rec pairs')
-  where
-    (env1, bndrs1) = addRecBinders env (map fst pairs)
-    (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1)
-
-    do_one env (pr, b1) = cse_bind toplevel env env pr b1
-
--- | Given a binding of @in_id@ to @in_rhs@, and a fresh name to refer
--- to @in_id@ (@out_id@, created from addBinder or addRecBinders),
--- first try to CSE @in_rhs@, and then add the resulting (possibly CSE'd)
--- binding to the 'CSEnv', so that we attempt to CSE any expressions
--- which are equal to @out_rhs@.
--- We use a different env for cse on the rhs and for extendCSEnvWithBinding
--- for reasons explain in See Note [Separate envs for let rhs and body]
-cse_bind :: TopLevelFlag -> CSEnv -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))
-cse_bind toplevel env_rhs env_body (in_id, in_rhs) out_id
-  | isTopLevel toplevel, exprIsTickedString in_rhs
-      -- See Note [Take care with literal strings]
-  = (env_body', (out_id', in_rhs))
-
-  | Just arity <- isJoinId_maybe out_id
-      -- See Note [Look inside join-point binders]
-  = let (params, in_body) = collectNBinders arity in_rhs
-        (env', params') = addBinders env_rhs params
-        out_body = tryForCSE env' in_body
-    in (env_body , (out_id, mkLams params' out_body))
-
-  | otherwise
-  = (env_body', (out_id'', out_rhs))
-  where
-    (env_body', out_id') = extendCSEnvWithBinding env_body  in_id out_id out_rhs cse_done
-    (cse_done, out_rhs)  = try_for_cse env_rhs in_rhs
-    out_id'' | cse_done  = zapStableUnfolding $
-                           delayInlining toplevel out_id'
-             | otherwise = out_id'
-
-delayInlining :: TopLevelFlag -> Id -> Id
--- Add a NOINLINE[2] if the Id doesn't have an INLNE pragma already
--- See Note [Delay inlining after CSE]
-delayInlining top_lvl bndr
-  | isTopLevel top_lvl
-  , isAlwaysActive (idInlineActivation bndr)
-  , idHasRules bndr  -- Only if the Id has some RULES,
-                     -- which might otherwise get lost
-       -- These rules are probably auto-generated specialisations,
-       -- since Ids with manual rules usually have manually-inserted
-       -- delayed inlining anyway
-  = bndr `setInlineActivation` activateAfterInitial
-  | otherwise
-  = bndr
-
-extendCSEnvWithBinding
-           :: CSEnv            -- Includes InId->OutId cloning
-           -> InVar            -- Could be a let-bound type
-           -> OutId -> OutExpr -- Processed binding
-           -> Bool             -- True <=> RHS was CSE'd and is a variable
-                               --          or maybe (Tick t variable)
-           -> (CSEnv, OutId)   -- Final env, final bndr
--- Extend the CSE env with a mapping [rhs -> out-id]
--- unless we can instead just substitute [in-id -> rhs]
---
--- It's possible for the binder to be a type variable,
--- in which case we can just substitute.
--- See Note [CSE for bindings]
-extendCSEnvWithBinding env in_id out_id rhs' cse_done
-  | not (isId out_id) = (extendCSSubst env in_id rhs',     out_id)
-  | noCSE out_id      = (env,                              out_id)
-  | use_subst         = (extendCSSubst env in_id rhs',     out_id)
-  | cse_done          = (env,                              out_id)
-                       -- See Note [Dealing with ticks]
-  | otherwise         = (extendCSEnv env rhs' id_expr', zapped_id)
-  where
-    id_expr'  = varToCoreExpr out_id
-    zapped_id = zapIdUsageInfo out_id
-       -- Putting the Id into the cs_map makes it possible that
-       -- it'll become shared more than it is now, which would
-       -- invalidate (the usage part of) its demand info.
-       --    This caused #100218.
-       -- Easiest thing is to zap the usage info; subsequently
-       -- performing late demand-analysis will restore it.  Don't zap
-       -- the strictness info; it's not necessary to do so, and losing
-       -- it is bad for performance if you don't do late demand
-       -- analysis
-
-    -- Should we use SUBSTITUTE or EXTEND?
-    -- See Note [CSE for bindings]
-    use_subst | Var {} <- rhs' = True
-              | otherwise      = False
-
--- | Given a binder `let x = e`, this function
--- determines whether we should add `e -> x` to the cs_map
-noCSE :: InId -> Bool
-noCSE id
-  | isJoinId id                = no_cse  -- See Note [CSE for join points?]
-  | isStableUserUnfolding  unf = no_cse  -- See Note [CSE for stable unfoldings]
-  | user_activation_control    = no_cse  -- See Note [CSE for INLINE and NOINLINE]
-  | otherwise = yes_cse
-   where
-     unf = idUnfolding id
-     user_activation_control = not (isAlwaysActive (idInlineActivation id))
-                            && not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id)))
-     yes_cse = False
-     no_cse  = True
-
-{- Note [Take care with literal strings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this example:
-
-  x = "foo"#
-  y = "foo"#
-  ...x...y...x...y....
-
-We would normally turn this into:
-
-  x = "foo"#
-  y = x
-  ...x...x...x...x....
-
-But this breaks an invariant of Core, namely that the RHS of a top-level binding
-of type Addr# must be a string literal, not another variable. See Note
-[Core top-level string literals] in GHC.Core.
-
-For this reason, we special case top-level bindings to literal strings and leave
-the original RHS unmodified. This produces:
-
-  x = "foo"#
-  y = "foo"#
-  ...x...x...x...x....
-
-Now 'y' will be discarded as dead code, and we are done.
-
-The net effect is that for the y-binding we want to
-  - Use SUBSTITUTE, by extending the substitution with  y :-> x
-  - but leave the original binding for y undisturbed
-
-This is done by cse_bind.  I got it wrong the first time (#13367).
-
-Note [Dealing with ticks]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Ticks complicate CSE a bit, as I discovered in the fallout from
-fixing #19360.
-
-* To get more CSE-ing, we strip all the tickishFloatable ticks from
-  an expression
-  - when inserting into the cs_map (see extendCSEnv)
-  - when looking up in the cs_map (see call to lookupCSEnv in try_for_cse)
-  Quite why only the tickishFloatable ticks, I'm not quite sure.
-
-  AK: I think we only do this for floatable ticks since generally we don't mind them
-  being less accurate as much. E.g. consider
-    case e of
-      C1 -> f (<tick1> e1)
-      C2 -> f (<tick2> e1)
-  If the ticks are (floatable) source notes nothing too bad happens if the debug info for
-  both branches says the code comes from the same source location. Even if it will be inaccurate
-  for one of the branches. We should probably still consider this worthwhile.
-  However if the ticks are cost centres we really don't want the cost of both branches to be
-  attributed to the same cost centre. Because a user might explicitly have inserted different
-  cost centres in order to distinguish between evaluations resulting from the two different branches.
-  e.g. something like this:
-    case e of
-      C1 -> f ({ SCC "evalAlt1"} e1)
-      C1 -> f ({ SCC "evalAlt2"} e1)
-  But it's still a bit suspicious.
-
-* If we get a hit in cs_map, we wrap the result in the ticks from the
-  thing we are looking up (see try_for_cse)
-
-Net result: if we get a hit, we might replace
-  let x = tick t1 (tick t2 e)
-with
-  let x = tick t1 (tick t2 y)
-where 'y' is the variable that 'e' maps to.  Now consider extendCSEnvWithBinding for
-the binding for 'x':
-
-* We can't use SUBSTITUTE because those ticks might not be trivial (we
-  use tickishIsCode in exprIsTrivial)
-
-* We should not use EXTEND, because we definitely don't want to
-  add  (tick t1 (tick t2 y)) :-> x
-  to the cs_map. Remember we strip off the ticks, so that would amount
-  to adding y :-> x, very silly.
-
-TL;DR: we do neither; hence the cse_done case in extendCSEnvWithBinding.
-
-
-Note [Delay inlining after CSE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose (#15445) we have
-   f,g :: Num a => a -> a
-   f x = ...f (x-1).....
-   g y = ...g (y-1) ....
-
-and we make some specialisations of 'g', either automatically, or via
-a SPECIALISE pragma.  Then CSE kicks in and notices that the RHSs of
-'f' and 'g' are identical, so we get
-   f x = ...f (x-1)...
-   g = f
-   {-# RULES g @Int _ = $sg #-}
-
-Now there is terrible danger that, in an importing module, we'll inline
-'g' before we have a chance to run its specialisation!
-
-Solution: during CSE, after a "hit" in the CSE cache
-  * when adding a binding
-        g = f
-  * for a top-level function g
-  * and g has specialisation RULES
-add a NOINLINE[2] activation to it, to ensure it's not inlined
-right away.
-
-Notes:
-* Why top level only?  Because for nested bindings we are already past
-  phase 2 and will never return there.
-
-* Why "only if g has RULES"?  Because there is no point in
-  doing this if there are no RULES; and other things being
-  equal it delays optimisation to delay inlining (#17409)
-
-
----- Historical note ---
-
-This patch is simpler and more direct than an earlier
-version:
-
-  commit 2110738b280543698407924a16ac92b6d804dc36
-  Author: Simon Peyton Jones <simonpj@microsoft.com>
-  Date:   Mon Jul 30 13:43:56 2018 +0100
-
-  Don't inline functions with RULES too early
-
-We had to revert this patch because it made GHC itself slower.
-
-Why? It delayed inlining of /all/ functions with RULES, and that was
-very bad in GHC.Tc.Solver.Flatten.flatten_ty_con_app
-
-* It delayed inlining of liftM
-* That delayed the unravelling of the recursion in some dictionary
-  bindings.
-* That delayed some eta expansion, leaving
-     flatten_ty_con_app = \x y. let <stuff> in \z. blah
-* That allowed the float-out pass to put sguff between
-  the \y and \z.
-* And that permanently stopped eta expansion of the function,
-  even once <stuff> was simplified.
-
--}
-
-tryForCSE :: CSEnv -> InExpr -> OutExpr
-tryForCSE env expr = snd (try_for_cse env expr)
-
-try_for_cse :: CSEnv -> InExpr -> (Bool, OutExpr)
--- (False, e') => We did not CSE the entire expression,
---                but we might have CSE'd some sub-expressions,
---                yielding e'
---
--- (True, te') => We CSE'd the entire expression,
---                yielding the trivial expression te'
-try_for_cse env expr
-  | Just e <- lookupCSEnv env expr'' = (True,  mkTicks ticks e)
-  | otherwise                        = (False, expr')
-    -- The varToCoreExpr is needed if we have
-    --   case e of xco { ...case e of yco { ... } ... }
-    -- Then CSE will substitute yco -> xco;
-    -- but these are /coercion/ variables
-  where
-    expr'  = cseExpr env expr
-    expr'' = stripTicksE tickishFloatable expr'
-    ticks  = stripTicksT tickishFloatable expr'
-    -- We don't want to lose the source notes when a common sub
-    -- expression gets eliminated. Hence we push all (!) of them on
-    -- top of the replaced sub-expression. This is probably not too
-    -- useful in practice, but upholds our semantics.
-
--- | Runs CSE on a single expression.
---
--- This entry point is not used in the compiler itself, but is provided
--- as a convenient entry point for users of the GHC API.
-cseOneExpr :: InExpr -> OutExpr
-cseOneExpr e = cseExpr env e
-  where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) }
-
-cseExpr :: CSEnv -> InExpr -> OutExpr
-cseExpr env (Type t)              = Type (substTyUnchecked (csEnvSubst env) t)
-cseExpr env (Coercion c)          = Coercion (substCo (csEnvSubst env) c)
-cseExpr _   (Lit lit)             = Lit lit
-cseExpr env (Var v)               = lookupSubst env v
-cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)
-cseExpr env (Tick t e)            = Tick t (cseExpr env e)
-cseExpr env (Cast e co)           = Cast (tryForCSE env e) (substCo (csEnvSubst env) co)
-cseExpr env (Lam b e)             = let (env', b') = addBinder env b
-                                    in Lam b' (cseExpr env' e)
-cseExpr env (Let bind e)          = let (env', bind') = cseBind NotTopLevel env bind
-                                    in Let bind' (cseExpr env' e)
-cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts
-
-cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr
-cseCase env scrut bndr ty alts
-  = Case scrut1 bndr3 ty' $
-    combineAlts (map cse_alt alts)
-  where
-    ty' = substTyUnchecked (csEnvSubst env) ty
-    (cse_done, scrut1) = try_for_cse env scrut
-
-    bndr1 = zapIdOccInfo bndr
-      -- Zapping the OccInfo is needed because the extendCSEnv
-      -- in cse_alt may mean that a dead case binder
-      -- becomes alive, and Lint rejects that
-    (env1, bndr2)    = addBinder env bndr1
-    (alt_env, bndr3) = extendCSEnvWithBinding env1 bndr bndr2 scrut1 cse_done
-         -- extendCSEnvWithBinding: see Note [CSE for case expressions]
-
-    con_target :: OutExpr
-    con_target = lookupSubst alt_env bndr
-
-    arg_tys :: [OutType]
-    arg_tys = tyConAppArgs (idType bndr3)
-
-    -- See Note [CSE for case alternatives]
-    cse_alt (Alt (DataAlt con) args rhs)
-        = Alt (DataAlt con) args' (tryForCSE new_env rhs)
-        where
-          (env', args') = addBinders alt_env args
-          new_env       = extendCSEnv env' con_expr con_target
-          con_expr      = mkAltExpr (DataAlt con) args' arg_tys
-
-    cse_alt (Alt con args rhs)
-        = Alt con args' (tryForCSE env' rhs)
-        where
-          (env', args') = addBinders alt_env args
-
-combineAlts :: [OutAlt] -> [OutAlt]
--- See Note [Combine case alternatives]
-combineAlts alts
-  | (Just alt1, rest_alts) <- find_bndr_free_alt alts
-  , Alt _ bndrs1 rhs1 <- alt1
-  , let filtered_alts = filterOut (identical_alt rhs1) rest_alts
-  , not (equalLength rest_alts filtered_alts)
-  = assertPpr (null bndrs1) (ppr alts) $
-    Alt DEFAULT [] rhs1 : filtered_alts
-
-  | otherwise
-  = alts
-  where
-
-    find_bndr_free_alt :: [CoreAlt] -> (Maybe CoreAlt, [CoreAlt])
-       -- The (Just alt) is a binder-free alt
-       -- See Note [Combine case alts: awkward corner]
-    find_bndr_free_alt []
-      = (Nothing, [])
-    find_bndr_free_alt (alt@(Alt _ bndrs _) : alts)
-      | null bndrs = (Just alt, alts)
-      | otherwise  = case find_bndr_free_alt alts of
-                       (mb_bf, alts) -> (mb_bf, alt:alts)
-
-    identical_alt rhs1 (Alt _ _ rhs) = eqCoreExpr rhs1 rhs
-       -- Even if this alt has binders, they will have been cloned
-       -- If any of these binders are mentioned in 'rhs', then
-       -- 'rhs' won't compare equal to 'rhs1' (which is from an
-       -- alt with no binders).
-
-{- Note [CSE for case alternatives]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider   case e of x
-            K1 y -> ....(K1 y)...
-            K2   -> ....K2....
-
-We definitely want to CSE that (K1 y) into just x.
-
-But what about the lone K2?  At first you would think "no" because
-turning K2 into 'x' increases the number of live variables.  But
-
-* Turning K2 into x increases the chance of combining identical alts.
-  Example      case xs of
-                  (_:_) -> f xs
-                  []    -> f []
-  See #17901 and simplCore/should_compile/T17901 for more examples
-  of this kind.
-
-* The next run of the simplifier will turn 'x' back into K2, so we won't
-  permanently bloat the free-var count.
-
-
-Note [Combine case alternatives]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-combineAlts is just a more heavyweight version of the use of
-combineIdenticalAlts in GHC.Core.Opt.Simplify.Utils.prepareAlts.  The basic idea is
-to transform
-
-    DEFAULT -> e1
-    K x     -> e1
-    W y z   -> e2
-===>
-   DEFAULT -> e1
-   W y z   -> e2
-
-In the simplifier we use cheapEqExpr, because it is called a lot.
-But here in CSE we use the full eqCoreExpr.  After all, two alternatives usually
-differ near the root, so it probably isn't expensive to compare the full
-alternative.  It seems like the same kind of thing that CSE is supposed
-to be doing, which is why I put it here.
-
-I actually saw some examples in the wild, where some inlining made e1 too
-big for cheapEqExpr to catch it.
-
-Note [Combine case alts: awkward corner]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We would really like to check isDeadBinder on the binders in the
-alternative.  But alas, the simplifer zaps occ-info on binders in case
-alternatives; see Note [Case alternative occ info] in GHC.Core.Opt.Simplify.
-
-* One alternative (perhaps a good one) would be to do OccAnal
-  just before CSE.  Then perhaps we could get rid of combineIdenticalAlts
-  in the Simplifier, which might save work.
-
-* Another would be for CSE to return free vars as it goes.
-
-* But the current solution is to find a nullary alternative (including
-  the DEFAULT alt, if any). This will not catch
-      case x of
-        A y   -> blah
-        B z p -> blah
-  where no alternative is nullary or DEFAULT.  But the current
-  solution is at least cheap.
-
-
-************************************************************************
-*                                                                      *
-\section{The CSE envt}
-*                                                                      *
-************************************************************************
--}
-
-data CSEnv
-  = CS { cs_subst :: Subst  -- Maps InBndrs to OutExprs
-            -- The substitution variables to
-            -- /trivial/ OutExprs, not arbitrary expressions
-
-       , cs_map   :: CoreMap OutExpr
-            -- The "reverse" mapping.
-            -- Maps a OutExpr to a /trivial/ OutExpr
-            -- The key of cs_map is stripped of all Ticks
-            -- It maps arbitrary expressions to trivial expressions
-            -- representing the same value. E.g @C a b@ to @x1@.
-
-       , cs_rec_map :: CoreMap OutExpr
-            -- See Note [CSE for recursive bindings]
-       }
-
-emptyCSEnv :: CSEnv
-emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap
-                , cs_subst = emptySubst }
-
-lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
-lookupCSEnv (CS { cs_map = csmap }) expr
-  = lookupCoreMap csmap expr
-
--- | @extendCSEnv env e triv_expr@ will replace any occurrence of @e@ with @triv_expr@ going forward.
-extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
-extendCSEnv cse expr triv_expr
-  = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }
-  where
-    sexpr = stripTicksE tickishFloatable expr
-
-extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv
--- See Note [CSE for recursive bindings]
-extendCSRecEnv cse bndr expr triv_expr
-  = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr }
-
-lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr
--- See Note [CSE for recursive bindings]
-lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr
-  = lookupCoreMap csmap (Lam bndr expr)
-
-csEnvSubst :: CSEnv -> Subst
-csEnvSubst = cs_subst
-
-lookupSubst :: CSEnv -> Id -> OutExpr
-lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst sub x
-
-extendCSSubst :: CSEnv -> Id  -> CoreExpr -> CSEnv
-extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
-
--- | Add clones to the substitution to deal with shadowing.  See
--- Note [Shadowing] for more details.  You should call this whenever
--- you go under a binder.
-addBinder :: CSEnv -> Var -> (CSEnv, Var)
-addBinder cse v = (cse { cs_subst = sub' }, v')
-                where
-                  (sub', v') = substBndr (cs_subst cse) v
-
-addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
-addBinders cse vs = (cse { cs_subst = sub' }, vs')
-                where
-                  (sub', vs') = substBndrs (cs_subst cse) vs
-
-addRecBinders :: Traversable f => CSEnv -> f Id -> (CSEnv, f Id)
-addRecBinders = \ cse vs ->
-    let (sub', vs') = substRecBndrs (cs_subst cse) vs
-    in (cse { cs_subst = sub' }, vs')
-{-# INLINE addRecBinders #-}
diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs
deleted file mode 100644
--- a/compiler/GHC/Core/Opt/CallArity.hs
+++ /dev/null
@@ -1,763 +0,0 @@
---
--- Copyright (c) 2014 Joachim Breitner
---
-
-{-# LANGUAGE BangPatterns #-}
-
-module GHC.Core.Opt.CallArity
-    ( callArityAnalProgram
-    , callArityRHS -- for testing
-    ) where
-
-import GHC.Prelude
-
-import GHC.Types.Var.Set
-import GHC.Types.Var.Env
-
-import GHC.Types.Basic
-import GHC.Core
-import GHC.Types.Id
-import GHC.Core.Opt.Arity ( typeArity )
-import GHC.Core.Utils ( exprIsCheap, exprIsTrivial )
-import GHC.Data.Graph.UnVar
-import GHC.Types.Demand
-import GHC.Utils.Misc
-
-import Control.Arrow ( first, second )
-
-
-{-
-%************************************************************************
-%*                                                                      *
-              Call Arity Analysis
-%*                                                                      *
-%************************************************************************
-
-Note [Call Arity: The goal]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The goal of this analysis is to find out if we can eta-expand a local function
-based on how it is being called. The motivating example is this code,
-which comes up when we implement foldl using foldr, and do list fusion:
-
-    let go = \x -> let d = case ... of
-                              False -> go (x+1)
-                              True  -> id
-                   in \z -> d (x + z)
-    in go 1 0
-
-If we do not eta-expand `go` to have arity 2, we are going to allocate a lot of
-partial function applications, which would be bad.
-
-The function `go` has a type of arity two, but only one lambda is manifest.
-Furthermore, an analysis that only looks at the RHS of go cannot be sufficient
-to eta-expand go: If `go` is ever called with one argument (and the result used
-multiple times), we would be doing the work in `...` multiple times.
-
-So `callArityAnalProgram` looks at the whole let expression to figure out if
-all calls are nice, i.e. have a high enough arity. It then stores the result in
-the `calledArity` field of the `IdInfo` of `go`, which the next simplifier
-phase will eta-expand.
-
-The specification of the `calledArity` field is:
-
-    No work will be lost if you eta-expand me to the arity in `calledArity`.
-
-What we want to know for a variable
------------------------------------
-
-For every let-bound variable we'd like to know:
-  1. A lower bound on the arity of all calls to the variable, and
-  2. whether the variable is being called at most once or possibly multiple
-     times.
-
-It is always okay to lower the arity, or pretend that there are multiple calls.
-In particular, "Minimum arity 0 and possibly called multiple times" is always
-correct.
-
-
-What we want to know from an expression
----------------------------------------
-
-In order to obtain that information for variables, we analyze expression and
-obtain bits of information:
-
- I.  The arity analysis:
-     For every variable, whether it is absent, or called,
-     and if called, with what arity.
-
- II. The Co-Called analysis:
-     For every two variables, whether there is a possibility that both are being
-     called.
-     We obtain as a special case: For every variable, whether there is a
-     possibility that it is being called twice.
-
-For efficiency reasons, we gather this information only for a set of
-*interesting variables*, to avoid spending time on, e.g., variables from pattern matches.
-
-The two analysis are not completely independent, as a higher arity can improve
-the information about what variables are being called once or multiple times.
-
-Note [Analysis I: The arity analysis]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The arity analysis is quite straightforward: The information about an
-expression is an
-    VarEnv Arity
-where absent variables are bound to Nothing and otherwise to a lower bound to
-their arity.
-
-When we analyze an expression, we analyze it with a given context arity.
-Lambdas decrease and applications increase the incoming arity. Analysing a
-variable will put that arity in the environment. In `let`s or `case`s all the
-results from the various subexpressions are lub'd, which takes the point-wise
-minimum (considering Nothing an infinity).
-
-
-Note [Analysis II: The Co-Called analysis]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The second part is more sophisticated. For reasons explained below, it is not
-sufficient to simply know how often an expression evaluates a variable. Instead
-we need to know which variables are possibly called together.
-
-The data structure here is an undirected graph of variables, which is provided
-by the abstract
-    UnVarGraph
-
-It is safe to return a larger graph, i.e. one with more edges. The worst case
-(i.e. the least useful and always correct result) is the complete graph on all
-free variables, which means that anything can be called together with anything
-(including itself).
-
-Notation for the following:
-C(e)  is the co-called result for e.
-G₁∪G₂ is the union of two graphs
-fv    is the set of free variables (conveniently the domain of the arity analysis result)
-S₁×S₂ is the complete bipartite graph { {a,b} | a ∈ S₁, b ∈ S₂ }
-S²    is the complete graph on the set of variables S, S² = S×S
-C'(e) is a variant for bound expression:
-      If e is called at most once, or it is and stays a thunk (after the analysis),
-      it is simply C(e). Otherwise, the expression can be called multiple times
-      and we return (fv e)²
-
-The interesting cases of the analysis:
- * Var v:
-   No other variables are being called.
-   Return {} (the empty graph)
- * Lambda v e, under arity 0:
-   This means that e can be evaluated many times and we cannot get
-   any useful co-call information.
-   Return (fv e)²
- * Case alternatives alt₁,alt₂,...:
-   Only one can be executed, so
-   Return (alt₁ ∪ alt₂ ∪...)
- * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂:
-   We get the results from both sides, with the argument evaluated at most once.
-   Additionally, anything called by e₁ can possibly be called with anything
-   from e₂.
-   Return: C(e₁) ∪ C(e₂) ∪ (fv e₁) × (fv e₂)
- * App e₁ x:
-   As this is already in A-normal form, CorePrep will not separately lambda
-   bind (and hence share) x. So we conservatively assume multiple calls to x here
-   Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)}
- * Let v = rhs in body:
-   In addition to the results from the subexpressions, add all co-calls from
-   everything that the body calls together with v to everything that is called
-   by v.
-   Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)}
- * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body
-   Tricky.
-   We assume that it is really mutually recursive, i.e. that every variable
-   calls one of the others, and that this is strongly connected (otherwise we
-   return an over-approximation, so that's ok), see Note [Recursion and fixpointing].
-
-   Let V = {v₁,...vₙ}.
-   Assume that the vs have been analysed with an incoming demand and
-   cardinality consistent with the final result (this is the fixed-pointing).
-   Again we can use the results from all subexpressions.
-   In addition, for every variable vᵢ, we need to find out what it is called
-   with (call this set Sᵢ). There are two cases:
-    * If vᵢ is a function, we need to go through all right-hand-sides and bodies,
-      and collect every variable that is called together with any variable from V:
-      Sᵢ = {v' | j ∈ {1,...,n},      {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }
-    * If vᵢ is a thunk, then its rhs is evaluated only once, so we need to
-      exclude it from this set:
-      Sᵢ = {v' | j ∈ {1,...,n}, j≠i, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }
-   Finally, combine all this:
-   Return: C(body) ∪
-           C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪
-           (fv rhs₁) × S₁) ∪ ... ∪ (fv rhsₙ) × Sₙ)
-
-Using the result: Eta-Expansion
--------------------------------
-
-We use the result of these two analyses to decide whether we can eta-expand the
-rhs of a let-bound variable.
-
-If the variable is already a function (exprIsCheap), and all calls to the
-variables have a higher arity than the current manifest arity (i.e. the number
-of lambdas), expand.
-
-If the variable is a thunk we must be careful: Eta-Expansion will prevent
-sharing of work, so this is only safe if there is at most one call to the
-function. Therefore, we check whether {v,v} ∈ G.
-
-    Example:
-
-        let n = case .. of .. -- A thunk!
-        in n 0 + n 1
-
-    vs.
-
-        let n = case .. of ..
-        in case .. of T -> n 0
-                      F -> n 1
-
-    We are only allowed to eta-expand `n` if it is going to be called at most
-    once in the body of the outer let. So we need to know, for each variable
-    individually, that it is going to be called at most once.
-
-
-Why the co-call graph?
-----------------------
-
-Why is it not sufficient to simply remember which variables are called once and
-which are called multiple times? It would be in the previous example, but consider
-
-        let n = case .. of ..
-        in case .. of
-            True -> let go = \y -> case .. of
-                                     True -> go (y + n 1)
-                                     False > n
-                    in go 1
-            False -> n
-
-vs.
-
-        let n = case .. of ..
-        in case .. of
-            True -> let go = \y -> case .. of
-                                     True -> go (y+1)
-                                     False > n
-                    in go 1
-            False -> n
-
-In both cases, the body and the rhs of the inner let call n at most once.
-But only in the second case that holds for the whole expression! The
-crucial difference is that in the first case, the rhs of `go` can call
-*both* `go` and `n`, and hence can call `n` multiple times as it recurses,
-while in the second case find out that `go` and `n` are not called together.
-
-
-Why co-call information for functions?
---------------------------------------
-
-Although for eta-expansion we need the information only for thunks, we still
-need to know whether functions are being called once or multiple times, and
-together with what other functions.
-
-    Example:
-
-        let n = case .. of ..
-            f x = n (x+1)
-        in f 1 + f 2
-
-    vs.
-
-        let n = case .. of ..
-            f x = n (x+1)
-        in case .. of T -> f 0
-                      F -> f 1
-
-    Here, the body of f calls n exactly once, but f itself is being called
-    multiple times, so eta-expansion is not allowed.
-
-
-Note [Analysis type signature]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The workhorse of the analysis is the function `callArityAnal`, with the
-following type:
-
-    type CallArityRes = (UnVarGraph, VarEnv Arity)
-    callArityAnal ::
-        Arity ->  -- The arity this expression is called with
-        VarSet -> -- The set of interesting variables
-        CoreExpr ->  -- The expression to analyse
-        (CallArityRes, CoreExpr)
-
-and the following specification:
-
-  ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr
-
-                            <=>
-
-  Assume the expression `expr` is being passed `arity` arguments. Then it holds that
-    * The domain of `callArityEnv` is a subset of `interestingIds`.
-    * Any variable from `interestingIds` that is not mentioned in the `callArityEnv`
-      is absent, i.e. not called at all.
-    * Every call from `expr` to a variable bound to n in `callArityEnv` has at
-      least n value arguments.
-    * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`,
-      then in no execution of `expr` both are being called.
-  Furthermore, expr' is expr with the callArity field of the `IdInfo` updated.
-
-
-Note [Which variables are interesting]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The analysis would quickly become prohibitive expensive if we would analyse all
-variables; for most variables we simply do not care about how often they are
-called, i.e. variables bound in a pattern match. So interesting are variables that are
- * top-level or let bound
- * and possibly functions (typeArity > 0)
-
-Note [Taking boring variables into account]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-If we decide that the variable bound in `let x = e1 in e2` is not interesting,
-the analysis of `e2` will not report anything about `x`. To ensure that
-`callArityBind` does still do the right thing we have to take that into account
-every time we would be lookup up `x` in the analysis result of `e2`.
-  * Instead of calling lookupCallArityRes, we return (0, True), indicating
-    that this variable might be called many times with no arguments.
-  * Instead of checking `calledWith x`, we assume that everything can be called
-    with it.
-  * In the recursive case, when calclulating the `cross_calls`, if there is
-    any boring variable in the recursive group, we ignore all co-call-results
-    and directly go to a very conservative assumption.
-
-The last point has the nice side effect that the relatively expensive
-integration of co-call results in a recursive groups is often skipped. This
-helped to avoid the compile time blowup in some real-world code with large
-recursive groups (#10293).
-
-Note [Recursion and fixpointing]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-For a mutually recursive let, we begin by
- 1. analysing the body, using the same incoming arity as for the whole expression.
- 2. Then we iterate, memoizing for each of the bound variables the last
-    analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes.
- 3. We combine the analysis result from the body and the memoized results for
-    the arguments (if already present).
- 4. For each variable, we find out the incoming arity and whether it is called
-    once, based on the current analysis result. If this differs from the
-    memoized results, we re-analyse the rhs and update the memoized table.
- 5. If nothing had to be reanalyzed, we are done.
-    Otherwise, repeat from step 3.
-
-
-Note [Thunks in recursive groups]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-We never eta-expand a thunk in a recursive group, on the grounds that if it is
-part of a recursive group, then it will be called multiple times.
-
-This is not necessarily true, e.g.  it would be safe to eta-expand t2 (but not
-t1) in the following code:
-
-  let go x = t1
-      t1 = if ... then t2 else ...
-      t2 = if ... then go 1 else ...
-  in go 0
-
-Detecting this would require finding out what variables are only ever called
-from thunks. While this is certainly possible, we yet have to see this to be
-relevant in the wild.
-
-
-Note [Analysing top-level binds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-We can eta-expand top-level-binds if they are not exported, as we see all calls
-to them. The plan is as follows: Treat the top-level binds as nested lets around
-a body representing “all external calls”, which returns a pessimistic
-CallArityRes (the co-call graph is the complete graph, all arityies 0).
-
-Note [Trimming arity]
-~~~~~~~~~~~~~~~~~~~~~
-In the Call Arity papers, we are working on an untyped lambda calculus with no
-other id annotations, where eta-expansion is always possible. But this is not
-the case for Core!
- 1. We need to ensure the invariant
-      callArity e <= typeArity (exprType e)
-    for the same reasons that exprArity needs this invariant (see Note
-    [typeArity invariants] in GHC.Core.Opt.Arity).
-
-    If we are not doing that, a too-high arity annotation will be stored with
-    the id, confusing the simplifier later on.
-
- 2. Eta-expanding a right hand side might invalidate existing annotations. In
-    particular, if an id has a strictness annotation of <...><...>b, then
-    passing two arguments to it will definitely bottom out, so the simplifier
-    will throw away additional parameters. This conflicts with Call Arity! So
-    we ensure that we never eta-expand such a value beyond the number of
-    arguments mentioned in the strictness signature.
-    See #10176 for a real-world-example.
-
-Note [What is a thunk]
-~~~~~~~~~~~~~~~~~~~~~~
-
-Originally, everything that is not in WHNF (`exprIsWHNF`) is considered a
-thunk, not eta-expanded, to avoid losing any sharing. This is also how the
-published papers on Call Arity describe it.
-
-In practice, there are thunks that do a just little work, such as
-pattern-matching on a variable, and the benefits of eta-expansion likely
-outweigh the cost of doing that repeatedly. Therefore, this implementation of
-Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk.
-
-Note [Call Arity and Join Points]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The Call Arity analysis does not care about join points, and treats them just
-like normal functions. This is ok.
-
-The analysis *could* make use of the fact that join points are always evaluated
-in the same context as the join-binding they are defined in and are always
-one-shot, and handle join points separately, as suggested in
-https://gitlab.haskell.org/ghc/ghc/issues/13479#note_134870.
-This *might* be more efficient (for example, join points would not have to be
-considered interesting variables), but it would also add redundant code. So for
-now we do not do that.
-
-The simplifier never eta-expands join points (it instead pushes extra arguments from
-an eta-expanded context into the join point’s RHS), so the call arity
-annotation on join points is not actually used. As it would be equally valid
-(though less efficient) to eta-expand join points, this is the simplifier's
-choice, and hence Call Arity sets the call arity for join points as well.
--}
-
--- Main entry point
-
-callArityAnalProgram :: CoreProgram -> CoreProgram
-callArityAnalProgram binds = binds'
-  where
-    (_, binds') = callArityTopLvl [] emptyVarSet binds
-
--- See Note [Analysing top-level binds]
-callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind])
-callArityTopLvl exported _ []
-    = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported])
-      , [] )
-callArityTopLvl exported int1 (b:bs)
-    = (ae2, b':bs')
-  where
-    int2 = bindersOf b
-    exported' = filter isExportedId int2 ++ exported
-    int' = int1 `addInterestingBinds` b
-    (ae1, bs') = callArityTopLvl exported' int' bs
-    (ae2, b')  = callArityBind (boringBinds b) ae1 int1 b
-
-
-callArityRHS :: CoreExpr -> CoreExpr
-callArityRHS = snd . callArityAnal 0 emptyVarSet
-
--- The main analysis function. See Note [Analysis type signature]
-callArityAnal ::
-    Arity ->  -- The arity this expression is called with
-    VarSet -> -- The set of interesting variables
-    CoreExpr ->  -- The expression to analyse
-    (CallArityRes, CoreExpr)
-        -- How this expression uses its interesting variables
-        -- and the expression with IdInfo updated
-
--- The trivial base cases
-callArityAnal _     _   e@(Lit _)
-    = (emptyArityRes, e)
-callArityAnal _     _   e@(Type _)
-    = (emptyArityRes, e)
-callArityAnal _     _   e@(Coercion _)
-    = (emptyArityRes, e)
--- The transparent cases
-callArityAnal arity int (Tick t e)
-    = second (Tick t) $ callArityAnal arity int e
-callArityAnal arity int (Cast e co)
-    = second (\e -> Cast e co) $ callArityAnal arity int e
-
--- The interesting case: Variables, Lambdas, Lets, Applications, Cases
-callArityAnal arity int e@(Var v)
-    | v `elemVarSet` int
-    = (unitArityRes v arity, e)
-    | otherwise
-    = (emptyArityRes, e)
-
--- Non-value lambdas are ignored
-callArityAnal arity int (Lam v e) | not (isId v)
-    = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e
-
--- We have a lambda that may be called multiple times, so its free variables
--- can all be co-called.
-callArityAnal 0     int (Lam v e)
-    = (ae', Lam v e')
-  where
-    (ae, e') = callArityAnal 0 (int `delVarSet` v) e
-    ae' = calledMultipleTimes ae
--- We have a lambda that we are calling. decrease arity.
-callArityAnal arity int (Lam v e)
-    = (ae, Lam v e')
-  where
-    (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e
-
--- Application. Increase arity for the called expression, nothing to know about
--- the second
-callArityAnal arity int (App e (Type t))
-    = second (\e -> App e (Type t)) $ callArityAnal arity int e
-callArityAnal arity int (App e1 e2)
-    = (final_ae, App e1' e2')
-  where
-    (ae1, e1') = callArityAnal (arity + 1) int e1
-    (ae2, e2') = callArityAnal 0           int e2
-    -- If the argument is trivial (e.g. a variable), then it will _not_ be
-    -- let-bound in the Core to STG transformation (CorePrep actually),
-    -- so no sharing will happen here, and we have to assume many calls.
-    ae2' | exprIsTrivial e2 = calledMultipleTimes ae2
-         | otherwise        = ae2
-    final_ae = ae1 `both` ae2'
-
--- Case expression.
-callArityAnal arity int (Case scrut bndr ty alts)
-    = -- pprTrace "callArityAnal:Case"
-      --          (vcat [ppr scrut, ppr final_ae])
-      (final_ae, Case scrut' bndr ty alts')
-  where
-    (alt_aes, alts') = unzip $ map go alts
-    go (Alt dc bndrs e) = let (ae, e') = callArityAnal arity (int `delVarSetList` (bndr:bndrs)) e
-                          in  (ae, Alt dc bndrs e')
-    alt_ae = lubRess alt_aes
-    (scrut_ae, scrut') = callArityAnal 0 int scrut
-    final_ae = scrut_ae `both` alt_ae
-
--- For lets, use callArityBind
-callArityAnal arity int (Let bind e)
-  = -- pprTrace "callArityAnal:Let"
-    --          (vcat [ppr v, ppr arity, ppr n, ppr final_ae ])
-    (final_ae, Let bind' e')
-  where
-    int_body = int `addInterestingBinds` bind
-    (ae_body, e') = callArityAnal arity int_body e
-    (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind
-
--- Which bindings should we look at?
--- See Note [Which variables are interesting]
-isInteresting :: Var -> Bool
-isInteresting v = typeArity (idType v) > 0
-
-interestingBinds :: CoreBind -> [Var]
-interestingBinds = filter isInteresting . bindersOf
-
-boringBinds :: CoreBind -> VarSet
-boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf
-
-addInterestingBinds :: VarSet -> CoreBind -> VarSet
-addInterestingBinds int bind
-    = int `delVarSetList`    bindersOf bind -- Possible shadowing
-          `extendVarSetList` interestingBinds bind
-
--- Used for both local and top-level binds
--- Second argument is the demand from the body
-callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)
--- Non-recursive let
-callArityBind boring_vars ae_body int (NonRec v rhs)
-  | otherwise
-  = -- pprTrace "callArityBind:NonRec"
-    --          (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity])
-    (final_ae, NonRec v' rhs')
-  where
-    is_thunk = not (exprIsCheap rhs) -- see Note [What is a thunk]
-    -- If v is boring, we will not find it in ae_body, but always assume (0, False)
-    boring = v `elemVarSet` boring_vars
-
-    (arity, called_once)
-        | boring    = (0, False) -- See Note [Taking boring variables into account]
-        | otherwise = lookupCallArityRes ae_body v
-    safe_arity | called_once = arity
-               | is_thunk    = 0      -- A thunk! Do not eta-expand
-               | otherwise   = arity
-
-    -- See Note [Trimming arity]
-    trimmed_arity = trimArity v safe_arity
-
-    (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs
-
-
-    ae_rhs'| called_once     = ae_rhs
-           | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once
-           | otherwise       = calledMultipleTimes ae_rhs
-
-    called_by_v = domRes ae_rhs'
-    called_with_v
-        | boring    = domRes ae_body
-        | otherwise = calledWith ae_body v `delUnVarSet` v
-    final_ae = addCrossCoCalls called_by_v called_with_v $ ae_rhs' `lubRes` resDel v ae_body
-
-    v' = v `setIdCallArity` trimmed_arity
-
-
--- Recursive let. See Note [Recursion and fixpointing]
-callArityBind boring_vars ae_body int b@(Rec binds)
-  = -- (if length binds > 300 then
-    -- pprTrace "callArityBind:Rec"
-    --           (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $
-    (final_ae, Rec binds')
-  where
-    -- See Note [Taking boring variables into account]
-    any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds]
-
-    int_body = int `addInterestingBinds` b
-    (ae_rhs, binds') = fix initial_binds
-    final_ae = bindersOf b `resDelList` ae_rhs
-
-    initial_binds = [(i,Nothing,e) | (i,e) <- binds]
-
-    fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)])
-    fix ann_binds
-        | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $
-          any_change
-        = fix ann_binds'
-        | otherwise
-        = (ae, map (\(i, _, e) -> (i, e)) ann_binds')
-      where
-        aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ]
-        ae = callArityRecEnv any_boring aes_old ae_body
-
-        rerun (i, mbLastRun, rhs)
-            | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae)
-            -- No call to this yet, so do nothing
-            = (False, (i, Nothing, rhs))
-
-            | Just (old_called_once, old_arity, _) <- mbLastRun
-            , called_once == old_called_once
-            , new_arity == old_arity
-            -- No change, no need to re-analyze
-            = (False, (i, mbLastRun, rhs))
-
-            | otherwise
-            -- We previously analyzed this with a different arity (or not at all)
-            = let is_thunk = not (exprIsCheap rhs) -- see Note [What is a thunk]
-
-                  safe_arity | is_thunk    = 0  -- See Note [Thunks in recursive groups]
-                             | otherwise   = new_arity
-
-                  -- See Note [Trimming arity]
-                  trimmed_arity = trimArity i safe_arity
-
-                  (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs
-
-                  ae_rhs' | called_once     = ae_rhs
-                          | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once
-                          | otherwise       = calledMultipleTimes ae_rhs
-
-                  i' = i `setIdCallArity` trimmed_arity
-
-              in (True, (i', Just (called_once, new_arity, ae_rhs'), rhs'))
-          where
-            -- See Note [Taking boring variables into account]
-            (new_arity, called_once) | i `elemVarSet` boring_vars = (0, False)
-                                     | otherwise                  = lookupCallArityRes ae i
-
-        (changes, ann_binds') = unzip $ map rerun ann_binds
-        any_change = or changes
-
--- Combining the results from body and rhs, (mutually) recursive case
--- See Note [Analysis II: The Co-Called analysis]
-callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes
-callArityRecEnv any_boring ae_rhss ae_body
-    = -- (if length ae_rhss > 300 then pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new]) else id) $
-      ae_new
-  where
-    vars = map fst ae_rhss
-
-    ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body
-
-    cross_calls
-        -- See Note [Taking boring variables into account]
-        | any_boring               = completeGraph (domRes ae_combined)
-        -- Also, calculating cross_calls is expensive. Simply be conservative
-        -- if the mutually recursive group becomes too large.
-        | lengthExceeds ae_rhss 25 = completeGraph (domRes ae_combined)
-        | otherwise                = unionUnVarGraphs $ map cross_call ae_rhss
-    cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v
-      where
-        is_thunk = idCallArity v == 0
-        -- What rhs are relevant as happening before (or after) calling v?
-        --    If v is a thunk, everything from all the _other_ variables
-        --    If v is not a thunk, everything can happen.
-        ae_before_v | is_thunk  = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body
-                    | otherwise = ae_combined
-        -- What do we want to know from these?
-        -- Which calls can happen next to any recursive call.
-        called_with_v
-            = unionUnVarSets $ map (calledWith ae_before_v) vars
-        called_by_v = domRes ae_rhs
-
-    ae_new = first (cross_calls `unionUnVarGraph`) ae_combined
-
--- See Note [Trimming arity]
-trimArity :: Id -> Arity -> Arity
-trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig]
-  where
-    max_arity_by_type = typeArity (idType v)
-    max_arity_by_strsig
-        | isDeadEndDiv result_info = length demands
-        | otherwise = a
-
-    (demands, result_info) = splitDmdSig (idDmdSig v)
-
----------------------------------------
--- Functions related to CallArityRes --
----------------------------------------
-
--- Result type for the two analyses.
--- See Note [Analysis I: The arity analysis]
--- and Note [Analysis II: The Co-Called analysis]
-type CallArityRes = (UnVarGraph, VarEnv Arity)
-
-emptyArityRes :: CallArityRes
-emptyArityRes = (emptyUnVarGraph, emptyVarEnv)
-
-unitArityRes :: Var -> Arity -> CallArityRes
-unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity)
-
-resDelList :: [Var] -> CallArityRes -> CallArityRes
-resDelList vs ae = foldl' (flip resDel) ae vs
-
-resDel :: Var -> CallArityRes -> CallArityRes
-resDel v (!g, !ae) = (g `delNode` v, ae `delVarEnv` v)
-
-domRes :: CallArityRes -> UnVarSet
-domRes (_, ae) = varEnvDomain ae
-
--- In the result, find out the minimum arity and whether the variable is called
--- at most once.
-lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool)
-lookupCallArityRes (g, ae) v
-    = case lookupVarEnv ae v of
-        Just a -> (a, not (g `hasLoopAt` v))
-        Nothing -> (0, False)
-
-calledWith :: CallArityRes -> Var -> UnVarSet
-calledWith (g, _) v = neighbors g v
-
-addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes
-addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`)
-
--- Replaces the co-call graph by a complete graph (i.e. no information)
-calledMultipleTimes :: CallArityRes -> CallArityRes
-calledMultipleTimes res = first (const (completeGraph (domRes res))) res
-
--- Used for application and cases
-both :: CallArityRes -> CallArityRes -> CallArityRes
-both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2
-
--- Used when combining results from alternative cases; take the minimum
-lubRes :: CallArityRes -> CallArityRes -> CallArityRes
-lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2)
-
-lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity
-lubArityEnv = plusVarEnv_C min
-
-lubRess :: [CallArityRes] -> CallArityRes
-lubRess = foldl' lubRes emptyArityRes
diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs
deleted file mode 100644
--- a/compiler/GHC/Core/Opt/CprAnal.hs
+++ /dev/null
@@ -1,1216 +0,0 @@
-
--- | Constructed Product Result analysis. Identifies functions that surely
--- return heap-allocated records on every code path, so that we can eliminate
--- said heap allocation by performing a worker/wrapper split.
---
--- See https://www.microsoft.com/en-us/research/publication/constructed-product-result-analysis-haskell/.
--- CPR analysis should happen after strictness analysis.
--- See Note [Phase ordering].
-module GHC.Core.Opt.CprAnal ( cprAnalProgram ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Flags ( DumpFlag (..) )
-
-import GHC.Builtin.Names ( runRWKey )
-
-import GHC.Types.Var.Env
-import GHC.Types.Basic
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.Demand
-import GHC.Types.Cpr
-import GHC.Types.Unique.MemoFun
-
-import GHC.Core.FamInstEnv
-import GHC.Core.DataCon
-import GHC.Core.Type
-import GHC.Core.Utils
-import GHC.Core
-import GHC.Core.Seq
-import GHC.Core.Opt.WorkWrap.Utils
-
-import GHC.Data.Graph.UnVar -- for UnVarSet
-
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Logger  ( Logger, putDumpFileMaybe, DumpFormat (..) )
-
-import Data.List ( mapAccumL )
-
-{- Note [Constructed Product Result]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The goal of Constructed Product Result analysis is to identify functions that
-surely return heap-allocated records on every code path, so that we can
-eliminate said heap allocation by performing a worker/wrapper split
-(via 'GHC.Core.Opt.WorkWrap.Utils.mkWWcpr_entry').
-
-`swap` below is such a function:
-```
-  swap (a, b) = (b, a)
-```
-A `case` on an application of `swap`, like
-`case swap (10, 42) of (a, b) -> a + b` could cancel away
-(by case-of-known-constructor) if we \"inlined\" `swap` and simplified. We then
-say that `swap` has the CPR property.
-
-We can't inline recursive functions, but similar reasoning applies there:
-```
-  f x n = case n of
-    0 -> (x, 0)
-    _ -> f (x+1) (n-1)
-```
-Inductively, `case f 1 2 of (a, b) -> a + b` could cancel away the constructed
-product with the case. So `f`, too, has the CPR property. But we can't really
-"inline" `f`, because it's recursive. Also, non-recursive functions like `swap`
-might be too big to inline (or even marked NOINLINE). We still want to exploit
-the CPR property, and that is exactly what the worker/wrapper transformation
-can do for us:
-```
-  $wf x n = case n of
-    0 -> case (x, 0) of -> (a, b) -> (# a, b #)
-    _ -> case f (x+1) (n-1) of (a, b) -> (# a, b #)
-  f x n = case $wf x n of (# a, b #) -> (a, b)
-```
-where $wf readily simplifies (by case-of-known-constructor and inlining `f`) to:
-```
-  $wf x n = case n of
-    0 -> (# x, 0 #)
-    _ -> $wf (x+1) (n-1)
-```
-Now, a call site like `case f 1 2 of (a, b) -> a + b` can inline `f` and
-eliminate the heap-allocated pair constructor.
-
-Note [Nested CPR]
-~~~~~~~~~~~~~~~~~
-We can apply Note [Constructed Product Result] deeper than just the top-level
-result constructor of a function, e.g.,
-```
-  g x
-    | even x = (x+1,x+2) :: (Int, Int)
-    | odd  x = (x+2,x+3)
-```
-Not only does `g` return a constructed pair, the pair components /also/ have the
-CPR property. We can split `g` for its /nested/ CPR property, as follows:
-```
-  $wg (x :: Int#)
-    | .. x .. = (# x +# 1#, x +# 2# #) :: (# Int#, Int# #)
-    | .. x .. = (# x +# 2#, x +# 3# #)
-  g (I# x) = case $wf x of (# y, z #) -> (I# y, I# z)
-```
-Note however that in the following we will only unbox the second component,
-even if `foo` has the CPR property:
-```
-  h x
-    | even x = (foo x, x+2) :: (Int, Int)
-    | odd  x = (x+2,   x+3)
-    -- where `foo` has the CPR property
-```
-Why can't we also unbox `foo x`? Because in order to do so, we have to evaluate
-it and that might diverge, so we cannot give `h` the nested CPR property in the
-first component of the result.
-
-The Right Thing is to do a termination analysis, to see if we can guarantee that
-`foo` terminates quickly, in which case we can speculatively evaluate `foo x` and
-hence give `h` a nested CPR property.  That is done in !1866.  But for now we
-have an incredibly simple termination analysis; an expression terminates fast
-iff it is in HNF: see `exprTerminates`. We call `exprTerminates` in
-`cprTransformDataConWork`, which is the main function figuring out whether it's
-OK to propagate nested CPR info (in `extract_nested_cpr`).
-
-In addition to `exprTerminates`, `extract_nested_cpr` also looks at the
-`StrictnessMark` of the corresponding constructor field. Example:
-```
-  data T a = MkT !a
-  h2 x
-    | even x = MkT (foo x) :: T Int
-    | odd  x = MkT (x+2)
-    -- where `foo` has the CPR property
-```
-Regardless of whether or not `foo` terminates, we may unbox the strict field,
-because it has to be evaluated (the Core for `MkT (foo x)` will look more like
-`case foo x of y { __DEFAULT -> MkT y }`).
-
-Surprisingly, there are local binders with a strict demand that *do not*
-terminate quickly in a sense that is useful to us! The following function
-demonstrates that:
-```
-  j x = (let t = x+1 in t+t, 42)
-```
-Here, `t` is used strictly, *but only within its scope in the first pair
-component*. `t` satisfies Note [CPR for binders that will be unboxed], so it has
-the CPR property, nevertheless we may not unbox `j` deeply lest evaluation of
-`x` diverges. The termination analysis must say "Might diverge" for `t` and we
-won't unbox the first pair component.
-There are a couple of tests in T18174 that show case Nested CPR. Some of them
-only work with the termination analysis from !1866.
-
-Giving the (Nested) CPR property to deep data structures can lead to loss of
-sharing; see Note [CPR for data structures can destroy sharing].
-
-Note [Phase ordering]
-~~~~~~~~~~~~~~~~~~~~~
-We need to perform strictness analysis before CPR analysis, because that might
-unbox some arguments, in turn leading to more constructed products.
-Ideally, we would want the following pipeline:
-
-1. Strictness
-2. worker/wrapper (for strictness)
-3. CPR
-4. worker/wrapper (for CPR)
-
-Currently, we omit 2. and anticipate the results of worker/wrapper.
-See Note [CPR for binders that will be unboxed].
-An additional w/w pass would simplify things, but probably add slight overhead.
-So currently we have
-
-1. Strictness
-2. CPR
-3. worker/wrapper (for strictness and CPR)
--}
-
---
--- * Analysing programs
---
-
-cprAnalProgram :: Logger -> FamInstEnvs -> CoreProgram -> IO CoreProgram
-cprAnalProgram logger fam_envs binds = do
-  let env            = emptyAnalEnv fam_envs
-  let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds
-  putDumpFileMaybe logger Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $
-    dumpIdInfoOfProgram False (ppr . cprSigInfo) binds_plus_cpr
-  -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal
-  seqBinds binds_plus_cpr `seq` return binds_plus_cpr
-
--- Analyse a (group of) top-level binding(s)
-cprAnalTopBind :: AnalEnv
-               -> CoreBind
-               -> (AnalEnv, CoreBind)
-cprAnalTopBind env (NonRec id rhs)
-  = (env', NonRec id' rhs')
-  where
-    (id', rhs', env') = cprAnalBind env id rhs
-
-cprAnalTopBind env (Rec pairs)
-  = (env', Rec pairs')
-  where
-    (env', pairs') = cprFix env pairs
-
---
--- * Analysing expressions
---
-
--- | The abstract semantic function ⟦_⟧ : Expr -> Env -> A from
--- "Constructed Product Result Analysis for Haskell"
-cprAnal, cprAnal'
-  :: AnalEnv
-  -> CoreExpr            -- ^ expression to be denoted by a 'CprType'
-  -> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType'
-
-cprAnal env e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $
-                  cprAnal' env e
-
-cprAnal' _ (Lit lit)     = (topCprType, Lit lit)
-cprAnal' _ (Type ty)     = (topCprType, Type ty)      -- Doesn't happen, in fact
-cprAnal' _ (Coercion co) = (topCprType, Coercion co)
-
-cprAnal' env (Cast e co)
-  = (cpr_ty, Cast e' co)
-  where
-    (cpr_ty, e') = cprAnal env e
-
-cprAnal' env (Tick t e)
-  = (cpr_ty, Tick t e')
-  where
-    (cpr_ty, e') = cprAnal env e
-
-cprAnal' env e@(Var{})
-  = cprAnalApp env e []
-cprAnal' env e@(App{})
-  = cprAnalApp env e []
-
-cprAnal' env (Lam var body)
-  | isTyVar var
-  , (body_ty, body') <- cprAnal env body
-  = (body_ty, Lam var body')
-  | otherwise
-  = (lam_ty, Lam var body')
-  where
-    -- See Note [CPR for binders that will be unboxed]
-    env'             = extendSigEnvForArg env var
-    (body_ty, body') = cprAnal env' body
-    lam_ty           = abstractCprTy body_ty
-
-cprAnal' env (Case scrut case_bndr ty alts)
-  = (res_ty, Case scrut' case_bndr ty alts')
-  where
-    (scrut_ty, scrut') = cprAnal env scrut
-    env'               = extendSigEnv env case_bndr (CprSig scrut_ty)
-    (alt_tys, alts')   = mapAndUnzip (cprAnalAlt env' scrut_ty) alts
-    res_ty             = foldl' lubCprType botCprType alt_tys
-
-cprAnal' env (Let (NonRec id rhs) body)
-  = (body_ty, Let (NonRec id' rhs') body')
-  where
-    (id', rhs', env') = cprAnalBind env id rhs
-    (body_ty, body')  = cprAnal env' body
-
-cprAnal' env (Let (Rec pairs) body)
-  = body_ty `seq` (body_ty, Let (Rec pairs') body')
-  where
-    (env', pairs')   = cprFix env pairs
-    (body_ty, body') = cprAnal env' body
-
-cprAnalAlt
-  :: AnalEnv
-  -> CprType -- ^ CPR type of the scrutinee
-  -> Alt Var -- ^ current alternative
-  -> (CprType, Alt Var)
-cprAnalAlt env scrut_ty (Alt con bndrs rhs)
-  = (rhs_ty, Alt con bndrs rhs')
-  where
-    env_alt
-      | DataAlt dc <- con
-      , let ids = filter isId bndrs
-      , CprType arity cpr <- scrut_ty
-      , assert (arity == 0 ) True
-      = case unpackConFieldsCpr dc cpr of
-          AllFieldsSame field_cpr
-            | let sig = mkCprSig 0 field_cpr
-            -> extendSigEnvAllSame env ids sig
-          ForeachField field_cprs
-            | let sigs = zipWith (mkCprSig . idArity) ids field_cprs
-            -> extendSigEnvList env (zipEqual "cprAnalAlt" ids sigs)
-      | otherwise
-      = env
-    (rhs_ty, rhs') = cprAnal env_alt rhs
-
---
--- * CPR transformer
---
-
-data TermFlag -- Better than using a Bool
-  = Terminates
-  | MightDiverge
-
--- See Note [Nested CPR]
-exprTerminates :: CoreExpr -> TermFlag
-exprTerminates e
-  | exprIsHNF e = Terminates -- A /very/ simple termination analysis.
-  | otherwise   = MightDiverge
-
-cprAnalApp :: AnalEnv -> CoreExpr -> [(CprType, CoreArg)] -> (CprType, CoreExpr)
--- Main function that takes care of /nested/ CPR. See Note [Nested CPR]
-cprAnalApp env e arg_infos = go e arg_infos []
-  where
-    go e arg_infos args'
-      -- Collect CprTypes for (value) args (inlined collectArgs):
-      | App fn arg <- e, isTypeArg arg -- Don't analyse Type args
-      = go fn arg_infos (arg:args')
-      | App fn arg <- e
-      , arg_info@(_arg_ty, arg') <- cprAnal env arg
-      -- See Note [Nested CPR] on the need for termination analysis
-      = go fn (arg_info:arg_infos) (arg':args')
-
-      | Var fn <- e
-      = (cprTransform env fn arg_infos, mkApps e args')
-
-      | (e_ty, e') <- cprAnal env e -- e is not an App and not a Var
-      = (applyCprTy e_ty (length arg_infos), mkApps e' args')
-
-cprTransform :: AnalEnv               -- ^ The analysis environment
-             -> Id                    -- ^ The function
-             -> [(CprType, CoreArg)]  -- ^ info about incoming /value/ arguments
-             -> CprType               -- ^ The demand type of the application
-cprTransform env id args
-  -- Any local binding, except for data structure bindings
-  -- See Note [Efficient Top sigs in SigEnv]
-  | Just sig <- lookupSigEnv env id
-  = applyCprTy (getCprSig sig) (length args)
-  -- See Note [CPR for data structures]
-  | Just rhs <- cprDataStructureUnfolding_maybe id
-  = fst $ cprAnal env rhs
-  -- Some (mostly global, known-key) Ids have bespoke CPR transformers
-  | Just cpr_ty <- cprTransformBespoke id args
-  = cpr_ty
-  -- Other local Ids that respond True to 'isDataStructure' but don't have an
-  -- expandable unfolding, such as NOINLINE bindings. They all get a top sig
-  | isLocalId id
-  = assertPpr (isDataStructure id) (ppr id) topCprType
-  -- See Note [CPR for DataCon wrappers]
-  | isDataConWrapId id, let rhs = uf_tmpl (realIdUnfolding id)
-  = fst $ cprAnalApp env rhs args
-  -- DataCon worker
-  | Just con <- isDataConWorkId_maybe id
-  = cprTransformDataConWork env con args
-  -- Imported function
-  | otherwise
-  = applyCprTy (getCprSig (idCprSig id)) (length args)
-
--- | Precise, hand-written CPR transformers for select Ids
-cprTransformBespoke :: Id -> [(CprType, CoreArg)] -> Maybe CprType
-cprTransformBespoke id args
-  -- See Note [Simplification of runRW#] in GHC.CoreToStg.Prep
-  | idUnique id == runRWKey    -- `runRW (\s -> e)`
-  , [(arg_ty, _arg)] <- args   -- `\s -> e` has CPR type `arg` (e.g. `. -> 2`)
-  = Just $ applyCprTy arg_ty 1 -- `e` has CPR type `2`
-  | otherwise
-  = Nothing
-
--- | Get a (possibly nested) 'CprType' for an application of a 'DataCon' worker,
--- given a saturated number of 'CprType's for its field expressions.
--- Implements the Nested part of Note [Nested CPR].
-cprTransformDataConWork :: AnalEnv -> DataCon -> [(CprType, CoreArg)] -> CprType
-cprTransformDataConWork env con args
-  | null (dataConExTyCoVars con)  -- No existentials
-  , wkr_arity <= mAX_CPR_SIZE -- See Note [Trimming to mAX_CPR_SIZE]
-  , args `lengthIs` wkr_arity
-  , ae_rec_dc env con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors]
-  -- , pprTrace "cprTransformDataConWork" (ppr con <+> ppr wkr_arity <+> ppr args) True
-  = CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks))
-  | otherwise
-  = topCprType
-  where
-    wkr_arity = dataConRepArity con
-    wkr_str_marks = dataConRepStrictness con
-    -- See Note [Nested CPR]
-    extract_nested_cpr (CprType 0 cpr, arg) str
-      | MarkedStrict <- str              = cpr
-      | Terminates <- exprTerminates arg = cpr
-    extract_nested_cpr _ _               = topCpr -- intervening lambda or doesn't terminate
-
--- | See Note [Trimming to mAX_CPR_SIZE].
-mAX_CPR_SIZE :: Arity
-mAX_CPR_SIZE = 10
-
---
--- * Bindings
---
-
--- Recursive bindings
-cprFix :: AnalEnv                    -- Does not include bindings for this binding
-       -> [(Id,CoreExpr)]
-       -> (AnalEnv, [(Id,CoreExpr)]) -- Binders annotated with CPR info
-cprFix orig_env orig_pairs
-  = loop 1 init_env init_pairs
-  where
-    init_sig id
-      -- See Note [CPR for data structures]
-      -- Don't set the sig to bottom in this case, because cprAnalBind won't
-      -- update it to something reasonable. Result: Assertion error in WW
-      | isDataStructure id || isDFunId id = topCprSig
-      | otherwise                         = mkCprSig 0 botCpr
-    -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal
-    orig_virgin = ae_virgin orig_env
-    init_pairs | orig_virgin  = [(setIdCprSig id (init_sig id), rhs) | (id, rhs) <- orig_pairs ]
-               | otherwise    = orig_pairs
-    init_env = extendSigEnvFromIds orig_env (map fst init_pairs)
-
-    -- The fixed-point varies the idCprSig field of the binders and and their
-    -- entries in the AnalEnv, and terminates if that annotation does not change
-    -- any more.
-    loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)])
-    loop n env pairs
-      | found_fixpoint = (reset_env', pairs')
-      | otherwise      = loop (n+1) env' pairs'
-      where
-        -- In all but the first iteration, delete the virgin flag
-        -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal
-        (env', pairs') = step (applyWhen (n/=1) nonVirgin env) pairs
-        -- Make sure we reset the virgin flag to what it was when we are stable
-        reset_env'     = env'{ ae_virgin = orig_virgin }
-        found_fixpoint = map (idCprSig . fst) pairs' == map (idCprSig . fst) pairs
-
-    step :: AnalEnv -> [(Id, CoreExpr)] -> (AnalEnv, [(Id, CoreExpr)])
-    step env pairs = mapAccumL go env pairs
-      where
-        go env (id, rhs) = (env', (id', rhs'))
-          where
-            (id', rhs', env') = cprAnalBind env id rhs
-
-{-
-Note [The OPAQUE pragma and avoiding the reboxing of results]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider:
-
-  {-# OPAQUE f #-}
-  f x = (x,y)
-
-  g True  = f 2 x
-  g False = (0,0)
-
-Where if we didn't strip the CPR info from 'f' we would end up with the
-following W/W pair for 'g':
-
-  $wg True  = case f 2 of (x, y) -> (# x, y #)
-  $wg False = (# 0, 0 #)
-
-  g b = case wg$ b of (# x, y #) -> (x, y)
-
-Where the worker unboxes the result of 'f', only for wrapper to box it again.
-That's because the non-stripped CPR signature of 'f' is saying to W/W-transform
-'f'. However, OPAQUE-annotated binders aren't W/W transformed (see
-Note [OPAQUE pragma]), so we should strip 'f's CPR signature.
--}
-
--- | Process the RHS of the binding for a sensible arity, add the CPR signature
--- to the Id, and augment the environment with the signature as well.
-cprAnalBind
-  :: AnalEnv
-  -> Id
-  -> CoreExpr
-  -> (Id, CoreExpr, AnalEnv)
-cprAnalBind env id rhs
-  | isDFunId id -- Never give DFuns the CPR property; we'll never save allocs.
-  = (id,  rhs,  extendSigEnv env id topCprSig)
-  -- See Note [CPR for data structures]
-  | isDataStructure id -- Data structure => no code => no need to analyse rhs
-  = (id,  rhs,  env)
-  | otherwise
-  = (id `setIdCprSig` sig',       rhs', env')
-  where
-    (rhs_ty, rhs')  = cprAnal env rhs
-    -- possibly trim thunk CPR info
-    rhs_ty'
-      -- See Note [CPR for thunks]
-      | stays_thunk = trimCprTy rhs_ty
-      | otherwise   = rhs_ty
-    -- See Note [Arity trimming for CPR signatures]
-    sig  = mkCprSigForArity (idArity id) rhs_ty'
-    -- See Note [OPAQUE pragma]
-    -- See Note [The OPAQUE pragma and avoiding the reboxing of results]
-    sig' | isOpaquePragma (idInlinePragma id) = topCprSig
-         | otherwise                          = sig
-    env' = extendSigEnv env id sig'
-
-    -- See Note [CPR for thunks]
-    stays_thunk = is_thunk && not_strict
-    is_thunk    = not (exprIsHNF rhs) && not (isJoinId id)
-    not_strict  = not (isStrUsedDmd (idDemandInfo id))
-
-isDataStructure :: Id -> Bool
--- See Note [CPR for data structures]
-isDataStructure id =
-  not (isJoinId id) && idArity id == 0 && isEvaldUnfolding (idUnfolding id)
-
--- | Returns an expandable unfolding
--- (See Note [exprIsExpandable] in "GHC.Core.Utils") that has
--- So effectively is a constructor application.
-cprDataStructureUnfolding_maybe :: Id -> Maybe CoreExpr
-cprDataStructureUnfolding_maybe id
-  -- There are only FinalPhase Simplifier runs after CPR analysis
-  | activeInFinalPhase (idInlineActivation id)
-  , isDataStructure id
-  = expandUnfolding_maybe (idUnfolding id)
-  | otherwise
-  = Nothing
-
-{- Note [Arity trimming for CPR signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Although it doesn't affect correctness of the analysis per se, we have to trim
-CPR signatures to idArity. Here's what might happen if we don't:
-
-  f x = if expensive
-          then \y. Box y
-          else \z. Box z
-  g a b = f a b
-
-The two lambdas will have a CPR type of @1m@ (so construct a product after
-applied to one argument). Thus, @f@ will have a CPR signature of @2m@
-(constructs a product after applied to two arguments).
-But WW will never eta-expand @f@! In this case that would amount to possibly
-duplicating @expensive@ work.
-
-(Side note: Even if @f@'s 'idArity' happened to be 2, it would not do so, see
-Note [Don't eta expand in w/w].)
-
-So @f@ will not be worker/wrappered. But @g@ also inherited its CPR signature
-from @f@'s, so it *will* be WW'd:
-
-  f x = if expensive
-          then \y. Box y
-          else \z. Box z
-  $wg a b = case f a b of Box x -> x
-  g a b = Box ($wg a b)
-
-And the case in @g@ can never cancel away, thus we introduced extra reboxing.
-Hence we always trim the CPR signature of a binding to idArity.
-
-Note [CPR for DataCon wrappers]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We used to give DataCon wrappers a (necessarily flat) CPR signature in
-'GHC.Types.Id.Make.mkDataConRep'. Now we transform DataCon wrappers simply by
-analysing their unfolding. A few reasons for the change:
-
-  1. DataCon wrappers are generally inlined in the Final phase (so before CPR),
-     all leftover occurrences are in a boring context like `f x y = $WMkT y x`.
-     It's simpler to analyse the unfolding anew at every such call site, and the
-     unfolding will be pretty cheap to analyse. Also they occur seldom enough
-     that performance-wise it doesn't matter.
-  2. 'GHC.Types.Id.Make' no longer precomputes CPR signatures for DataCon
-     *workers*, because their transformers need to adapt to CPR for their
-     arguments in 'cprTransformDataConWork' to enable Note [Nested CPR].
-     Better keep it all in this module! The alternative would be that
-     'GHC.Types.Id.Make' depends on CprAnal.
-  3. In the future, Nested CPR could take a better account of incoming args
-     in cprAnalApp and do some beta-reduction on the fly, like !1866 did. If
-     any of those args had the CPR property, then we'd even get Nested CPR for
-     DataCon wrapper calls, for free. Not so if we simply give the wrapper a
-     single CPR sig in 'GHC.Types.Id.Make.mkDataConRep'!
-
-DmdAnal also looks through the wrapper's unfolding:
-See Note [DmdAnal for DataCon wrappers].
-
-Note [Trimming to mAX_CPR_SIZE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not treat very big tuples as CPR-ish:
-
-  a) For a start, we get into trouble because there aren't
-     "enough" unboxed tuple types (a tiresome restriction,
-     but hard to fix),
-  b) More importantly, big unboxed tuples get returned mainly
-     on the stack, and are often then allocated in the heap
-     by the caller. So doing CPR for them may in fact make
-     things worse, especially if the wrapper doesn't cancel away
-     and we move to the stack in the worker and then to the heap
-     in the wrapper.
-
-So we (nested) CPR for functions that would otherwise pass more than than
-'mAX_CPR_SIZE' fields.
-That effect is exacerbated for the unregisterised backend, where we
-don't have any hardware registers to return the fields in. Returning
-everything on the stack results in much churn and increases compiler
-allocation by 15% for T15164 in a validate build.
--}
-
-data AnalEnv
-  = AE
-  { ae_sigs   :: SigEnv
-  -- ^ Current approximation of signatures for local ids
-  , ae_virgin :: Bool
-  -- ^ True only on every first iteration in a fixed-point
-  -- iteration. See Note [Initialising strictness] in "GHC.Core.Opt.DmdAnal"
-  , ae_fam_envs :: FamInstEnvs
-  -- ^ Needed when expanding type families and synonyms of product types.
-  , ae_rec_dc :: DataCon -> IsRecDataConResult
-  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'
-  }
-
-instance Outputable AnalEnv where
-  ppr (AE { ae_sigs = env, ae_virgin = virgin })
-    = text "AE" <+> braces (vcat
-         [ text "ae_virgin =" <+> ppr virgin
-         , text "ae_sigs =" <+> ppr env ])
-
--- | An environment storing 'CprSig's for local Ids.
--- Puts binders with 'topCprSig' in a space-saving 'IntSet'.
--- See Note [Efficient Top sigs in SigEnv].
-data SigEnv
-  = SE
-  { se_tops :: !UnVarSet
-  -- ^ All these Ids have 'topCprSig'. Like a 'VarSet', but more efficient.
-  , se_sigs :: !(VarEnv CprSig)
-  -- ^ Ids that have something other than 'topCprSig'.
-  }
-
-instance Outputable SigEnv where
-  ppr (SE { se_tops = tops, se_sigs = sigs })
-    = text "SE" <+> braces (vcat
-         [ text "se_tops =" <+> ppr tops
-         , text "se_sigs =" <+> ppr sigs ])
-
-emptyAnalEnv :: FamInstEnvs -> AnalEnv
-emptyAnalEnv fam_envs
-  = AE
-  { ae_sigs = SE emptyUnVarSet emptyVarEnv
-  , ae_virgin = True
-  , ae_fam_envs = fam_envs
-  , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs fuel)
-  } where
-    fuel = 3 -- If we can unbox more than 3 constructors to find a
-             -- recursive occurrence, then we can just as well unbox it
-             -- See Note [CPR for recursive data constructors], point (4)
-
-modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv
-modifySigEnv f env = env { ae_sigs = f (ae_sigs env) }
-
-lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig
--- See Note [Efficient Top sigs in SigEnv]
-lookupSigEnv AE{ae_sigs = SE tops sigs} id
-  | id `elemUnVarSet` tops = Just topCprSig
-  | otherwise              = lookupVarEnv sigs id
-
-extendSigEnv :: AnalEnv -> Id -> CprSig -> AnalEnv
--- See Note [Efficient Top sigs in SigEnv]
-extendSigEnv env id sig
-  | isTopCprSig sig
-  = modifySigEnv (\se -> se{se_tops = extendUnVarSet id (se_tops se)}) env
-  | otherwise
-  = modifySigEnv (\se -> se{se_sigs = extendVarEnv (se_sigs se) id sig}) env
-
--- | Extend an environment with the (Id, CPR sig) pairs
-extendSigEnvList :: AnalEnv -> [(Id, CprSig)] -> AnalEnv
-extendSigEnvList env ids_cprs
-  = foldl' (\env (id, sig) -> extendSigEnv env id sig) env ids_cprs
-
--- | Extend an environment with the CPR sigs attached to the ids
-extendSigEnvFromIds :: AnalEnv -> [Id] -> AnalEnv
-extendSigEnvFromIds env ids
-  = foldl' (\env id -> extendSigEnv env id (idCprSig id)) env ids
-
--- | Extend an environment with the same CPR sig for all ids
-extendSigEnvAllSame :: AnalEnv -> [Id] -> CprSig -> AnalEnv
-extendSigEnvAllSame env ids sig
-  = foldl' (\env id -> extendSigEnv env id sig) env ids
-
-nonVirgin :: AnalEnv -> AnalEnv
-nonVirgin env = env { ae_virgin = False }
-
--- | A version of 'extendSigEnv' for a binder of which we don't see the RHS
--- needed to compute a 'CprSig' (e.g. lambdas and DataAlt field binders).
--- In this case, we can still look at their demand to attach CPR signatures
--- anticipating the unboxing done by worker/wrapper.
--- See Note [CPR for binders that will be unboxed].
-extendSigEnvForArg :: AnalEnv -> Id -> AnalEnv
-extendSigEnvForArg env id
-  = extendSigEnv env id (CprSig (argCprType (idDemandInfo id)))
-
--- | Produces a 'CprType' according to how a strict argument will be unboxed.
--- Examples:
---
---   * A head-strict demand @1!L@ would translate to @1@
---   * A product demand @1!P(1!L,L)@ would translate to @1(1,)@
---   * A product demand @1!P(1L,L)@ would translate to @1(,)@,
---     because the first field will not be unboxed.
-argCprType :: Demand -> CprType
-argCprType dmd = CprType 0 (go dmd)
-  where
-    go (n :* sd)
-      | isAbs n               = topCpr
-      | Prod Unboxed ds <- sd = ConCpr fIRST_TAG (strictMap go ds)
-      | Poly Unboxed _  <- sd = ConCpr fIRST_TAG []
-      | otherwise             = topCpr
-
-{- Note [Safe abortion in the fixed-point iteration]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Fixed-point iteration may fail to terminate. But we cannot simply give up and
-return the environment and code unchanged! We still need to do one additional
-round, to ensure that all expressions have been traversed at least once, and any
-unsound CPR annotations have been updated.
-
-Note [Efficient Top sigs in SigEnv]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's pretty common for binders in the SigEnv to have a 'topCprSig'.
-Wide records with 100 fields like in T9675 even will generate code where the
-majority of binders has Top signature. To save some allocations, we store
-those binders with a Top signature in a separate UnVarSet (which is an IntSet
-with a convenient Var-tailored API).
-
-Why store top signatures at all in the SigEnv? After all, when 'cprTransform'
-encounters a locally-bound Id without an entry in the SigEnv, it should behave
-as if that binder has a Top signature!
-Well, the problem is when case binders should have a Top signatures. They always
-have an unfolding and thus look to 'cprTransform' as if they bind a data
-structure, Note [CPR for data structures], and thus would always have the CPR
-property. So we need some mechanism to separate data structures from case
-binders with a Top signature, and the UnVarSet provides that in the least
-convoluted way I can think of.
-
-Note [CPR for binders that will be unboxed]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If a lambda-bound variable will be unboxed by worker/wrapper (so it must be
-demanded strictly), then give it a CPR signature. Here's a concrete example
-('f1' in test T10482a), assuming h is strict:
-
-  f1 :: Int -> Int
-  f1 x = case h x of
-          A -> x
-          B -> f1 (x-1)
-          C -> x+1
-
-If we notice that 'x' is used strictly, we can give it the CPR
-property; and hence f1 gets the CPR property too.  It's sound (doesn't
-change strictness) to give it the CPR property because by the time 'x'
-is returned (case A above), it'll have been evaluated (by the wrapper
-of 'h' in the example).
-
-Moreover, if f itself is strict in x, then we'll pass x unboxed to
-f1, and so the boxed version *won't* be available; in that case it's
-very helpful to give 'x' the CPR property.
-
-This is all done in 'extendSigEnvForArg'.
-
-Note that
-
-  * Whether or not something unboxes is decided by 'canUnboxArg', else we may
-    get over-optimistic CPR results (e.g., from \(x :: a) -> x!).
-
-  * If the demand unboxes deeply, we can give the binder a /nested/ CPR
-    property, e.g.
-
-      g :: (Int, Int) -> Int
-      g p = case p of
-        (x, y) | x < 0     -> 0
-               | otherwise -> x
-
-    `x` should have the CPR property because it will be unboxed. We do so
-    by giving `p` the Nested CPR property `1(1,)`, indicating that we not only
-    have `p` available unboxed, but also its field `x`. Analysis of the Case
-    will then transfer the CPR property to `x`.
-
-    Before we were able to express Nested CPR, we used to guess which field
-    binders should get the CPR property.
-    See Historic Note [Optimistic field binder CPR].
-
-  * See Note [CPR examples]
-
-Note [CPR for thunks]
-~~~~~~~~~~~~~~~~~~~~~
-If the rhs is a thunk, we usually forget the CPR info, because
-it is presumably shared (else it would have been inlined, and
-so we'd lose sharing if w/w'd it into a function).  E.g.
-
-        let r = case expensive of
-                  (a,b) -> (b,a)
-        in ...
-
-If we marked r as having the CPR property, then we'd w/w into
-
-        let $wr = \() -> case expensive of
-                            (a,b) -> (# b, a #)
-            r = case $wr () of
-                  (# b,a #) -> (b,a)
-        in ...
-
-But now r is a thunk, which won't be inlined, so we are no further ahead.
-But consider
-
-        f x = let r = case expensive of (a,b) -> (b,a)
-              in if foo r then r else (x,x)
-
-Does f have the CPR property?  Well, no.
-
-However, if the strictness analyser has figured out (in a previous
-iteration) that it's strict, then we DON'T need to forget the CPR info.
-Instead we can retain the CPR info and do the thunk-splitting transform
-(see WorkWrap.splitThunk).
-
-This made a big difference to PrelBase.modInt, which had something like
-        modInt = \ x -> let r = ... -> I# v in
-                        ...body strict in r...
-r's RHS isn't a value yet; but modInt returns r in various branches, so
-if r doesn't have the CPR property then neither does modInt
-Another case I found in practice (in Complex.magnitude), looks like this:
-                let k = if ... then I# a else I# b
-                in ... body strict in k ....
-(For this example, it doesn't matter whether k is returned as part of
-the overall result; but it does matter that k's RHS has the CPR property.)
-Left to itself, the simplifier will make a join point thus:
-                let $j k = ...body strict in k...
-                if ... then $j (I# a) else $j (I# b)
-With thunk-splitting, we get instead
-                let $j x = let k = I#x in ...body strict in k...
-                in if ... then $j a else $j b
-This is much better; there's a good chance the I# won't get allocated.
-
-But what about botCpr? Consider
-    lvl = error "boom"
-    fac -1 = lvl
-    fac 0 = 1
-    fac n = n * fac (n-1)
-fac won't have the CPR property here when we trim every thunk! But the
-assumption is that error cases are rarely entered and we are diverging anyway,
-so WW doesn't hurt.
-
-Should we also trim CPR on DataCon application bindings?
-See Note [CPR for data structures]!
-
-Note [CPR for data structures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Long static data structures (whether top-level or not) like
-
-  xs = x1 : xs1
-  xs1 = x2 : xs2
-  xs2 = x3 : xs3
-
-should not get (nested) CPR signatures (#18154), because they
-
-  * Never get WW'd, so their CPR signature should be irrelevant after analysis
-    (in fact the signature might even be harmful for that reason)
-  * Would need to be inlined/expanded to see their constructed product
-  * BUT MOST IMPORTANTLY, Problem P1:
-    Recording CPR on them blows up interface file sizes and is redundant with
-    their unfolding. In case of Nested CPR, this blow-up can be quadratic!
-    Reason: the CPR info for xs1 contains the CPR info for xs; the CPR info
-    for xs2 contains that for xs1. And so on.
-    By contrast, the size of unfoldings and types stays linear. That's why
-    quadratic blowup is problematic; it makes an asymptotic difference.
-
-Hence (Solution S1) we don't give data structure bindings a CPR *signature* and
-hence don't to analyse them in 'cprAnalBind'.
-What do we mean by "data structure binding"? Answer:
-
-  (1) idArity id == 0    (otherwise it's a function)
-  (2) is eval'd          (otherwise it's a thunk, Note [CPR for thunks] applies)
-  (3) not (isJoinId id)  (otherwise it's a function and its more efficient to
-                          analyse it just once rather than at each call site)
-
-But (S1) leads to a new Problem P2: We can't just stop giving DataCon application
-bindings the CPR *property*, for example the factorial function after FloatOut
-
-  lvl = I# 1#
-  fac 0 = lvl
-  fac n = n * fac (n-1)
-
-lvl is a data structure, and hence (see above) will not have a CPR *signature*.
-But if lvl doesn't have the CPR *property*, fac won't either and we allocate a
-box for the result on every iteration of the loop.
-
-So (Solution S2) when 'cprAnal' meets a variable lacking a CPR signature to
-extrapolate into a CPR transformer, 'cprTransform' tries to get its unfolding
-(via 'cprDataStructureUnfolding_maybe'), and analyses that instead.
-
-The Result R1: Everything behaves as if there was a CPR signature, but without
-the blowup in interface files.
-
-There is one exception to (R1):
-
-  x   = (y, z); {-# NOINLINE x #-}
-  f p = (y, z); {-# NOINLINE f #-}
-
-While we still give the NOINLINE *function* 'f' the CPR property (and WW
-accordingly, see Note [Worker/wrapper for NOINLINE functions]), we won't
-give the NOINLINE *data structure* 'x' the CPR property, because it lacks an
-unfolding. In particular, KindRep bindings are NOINLINE data structures (see
-the noinline wrinkle in Note [Grand plan for Typeable]). We'll behave as if the
-bindings had 'topCprSig', and that is fine, as a case on the binding would never
-cancel away after WW!
-
-It's also worth pointing out how ad-hoc (S1) is: If we instead had
-
-    f1 x = x:[]
-    f2 x = x : f1 x
-    f3 x = x : f2 x
-    ...
-
-we still give every function an ever deepening CPR signature. But it's very
-uncommon to find code like this, whereas the long static data structures from
-the beginning of this Note are very common because of GHC's strategy of ANF'ing
-data structure RHSs.
-
-Note [CPR for data structures can destroy sharing]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In Note [CPR for data structures], we argued that giving data structure bindings
-the CPR property is useful to give functions like fac the CPR property:
-
-  lvl = I# 1#
-  fac 0 = lvl
-  fac n = n * fac (n-1)
-
-Worker/wrappering fac for its CPR property means we get a very fast worker
-function with type Int# -> Int#, without any heap allocation at all.
-
-But consider what happens if we call `map fac (replicate n 0)`, where the
-wrapper doesn't cancel away: Then we rebox the result of $wfac *on each call*,
-n times, instead of reusing the static thunk for 1, e.g. an asymptotic increase
-in allocations. If you twist it just right, you can actually write programs that
-that take O(n) space if you do CPR and O(1) if you don't:
-
-  fac :: Int -> Int
-  fac 0 = 1 -- this clause will trigger CPR and destroy sharing for O(n) space
-  -- fac 0 = lazy 1 -- this clause will prevent CPR and run in O(1) space
-  fac n = n * fac (n-1)
-
-  const0 :: Int -> Int
-  const0 n = signum n - 1 -- will return 0 for [1..n]
-  {-# NOINLINE const0 #-}
-
-  main = print $ foldl' (\acc n -> acc + lazy n) 0 $ map (fac . const0) [1..100000000]
-
-Generally, this kind of asymptotic increase in allocation can happen whenever we
-give a data structure the CPR property that is bound outside of a recursive
-function. So far we don't have a convincing remedy; giving fac the CPR property
-is just too attractive. #19309 documents a futile idea. #13331 tracks the
-general issue of WW destroying sharing and also contains above reproducer.
-#19326 is about CPR destroying sharing in particular.
-
-With Nested CPR, sharing can also be lost within the same "lambda level", for
-example:
-
-  f (I# x) = let y = I# (x*#x) in (y, y)
-
-Nestedly unboxing would destroy the box shared through 'y'. (Perhaps we can call
-this "internal sharing", in contrast to "external sharing" beyond lambda or even
-loop levels above.) But duplicate occurrences like that are pretty rare and may
-never lead to an asymptotic difference in allocations of 'f'.
-
-Note [CPR for recursive data constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Note [CPR for data structures can destroy sharing] gives good reasons not to
-give shared data structure bindings the CPR property. But we shouldn't even
-give *functions* that return *recursive* data constructor applications the CPR
-property. Here's an example for why:
-
-  c = C# 'a'
-  replicateC :: Int -> [Int]
-  replicateC 1 = [c]
-  replicateC n = c : replicateC (n-1)
-
-What happens if we give `replicateC` the (nested) CPR property? We get a WW
-split for 'replicateC', the wrapper of which is certain to inline, like this:
-
-  replicateC (I# n) = case $wreplicateC n of (# x, xs #) -> C# x : xs
-  $wreplicateC 1# = (# 'a', [] #)
-  $wreplicateC n  = (# 'a', replicateC (I# (n -# 1#)) #)
-
-Eliminating the shared 'c' binding in the process. And then
-
-  * We *might* save allocation of the topmost (of most likely several) (:)
-    constructor if it cancels away at the call site. Similarly for the 'C#'
-    constructor.
-  * But we will now re-allocate the C# box on every iteration of the loop,
-    because we separated the character literal from the C# application.
-    That means n times as many C# allocations as before. Yikes!!
-  * We make all other call sites where the wrapper inlines a bit larger, most of
-    them for no gain. But this shouldn't matter much.
-  * The inlined wrapper may inhibit eta-expansion in some cases. Here's how:
-    If the wrapper is inlined in a strict arg position, the Simplifier will
-    transform as follows
-
-      f (replicateC n)
-      ==> { inline }
-      f (case $wreplicateC n of (# x, xs #) -> (C# x, xs))
-      ==> { strict arg }
-      case $wreplicateC n of (# x, xs #) -> f (C# x, xs)
-
-    Now we can't float out the case anymore. In fact, we can't even float out
-    `$wreplicateC n`, because it returns an unboxed tuple.
-    This can inhibit eta-expansion if we later find out that `f` has arity > 1
-    (such as when we define `foldl` in terms of `foldr`). #19970 shows how
-    abstaining from worker/wrappering made a difference of -20% in reptile. So
-    while WW'ing for CPR didn't make the program slower directly, the resulting
-    program got much harder to optimise because of the returned unboxed tuple
-    (which can't easily float because unlifted).
-
-`replicateC` comes up in T5536, which regresses significantly if CPR'd nestedly.
-
-What can we do about it?
-
- A. Don't CPR functions that return a *recursive data type* (the list in this
-    case). This is the solution we adopt. Rationale: the benefit of CPR on
-    recursive data structures is slight, because it only affects the outer layer
-    of a potentially massive data structure.
- B. Don't CPR any *recursive function*. That would be quite conservative, as it
-    would also affect e.g. the factorial function.
- C. Flat CPR only for recursive functions. This prevents the asymptotic
-    worsening part arising through unsharing the C# box, but it's still quite
-    conservative.
- D. No CPR at occurrences of shared data structure in hot paths (e.g. the use of
-    `c` in the second eqn of `replicateC`). But we'd need to know which paths
-    were hot. We want such static branch frequency estimates in #20378.
-
-We adopt solution (A) It is ad-hoc, but appears to work reasonably well.
-Deciding what a "recursive data constructor" is is quite tricky and ad-hoc, too:
-See Note [Detecting recursive data constructors]. We don't have to be perfect
-and can simply keep on unboxing if unsure.
-
-Note [Detecting recursive data constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What qualifies as a "recursive data constructor" as per
-Note [CPR for recursive data constructors]? That is up to
-'GHC.Core.Opt.WorkWrapW.Utils.isRecDataCon' to decide. It does a DFS search over
-the field types of the DataCon and looks for term-level recursion into the data
-constructor's type constructor. Assuming infinite fuel (point (4) below), it
-looks inside the following class of types, represented by `ty` (and responds
-`NonRecursiveOrUnsure` in all other cases):
-
- A. If `ty = forall v. ty'`, then look into `ty'`
- B. If `ty = Tc tc_args` and `Tc` is an `AlgTyCon`, look into the arg
-    types of its data constructors and check `tc_args` for recursion.
- C. If `ty = F tc_args`, `F` is a `FamTyCon` and we can reduce `F tc_args` to
-    `rhs`, look into the `rhs` type.
-
-A few perhaps surprising points:
-
-  1. It deems any function type as non-recursive, because it's unlikely that
-     a recursion through a function type builds up a recursive data structure.
-  2. It doesn't look into kinds or coercion types because there's nothing to unbox.
-     Same for promoted data constructors.
-  3. We don't care whether an AlgTyCon app `T tc_args` is fully saturated or not;
-     we simply look at its definition/DataCons and its field tys and look for
-     recursive occs in the `tc_args` we are given. This is so that we expand
-     the `ST` in `StateT Int (ST s) a`.
-  4. We don't recurse deeper than 3 (at the moment of this writing) TyCons and
-     assume the DataCon is non-recursive after that. One reason for this "fuel"
-     approach is guaranteed constant-time efficiency; the other is that it's
-     fair to say that a recursion over 3 or more TyCons doesn't really count as
-     a list-like data structure anymore and a bit of unboxing doesn't hurt much.
-  5. It checks AlgTyCon apps like `T tc_args` by eagerly checking the `tc_args`
-     *before* it looks into the expanded DataCons/NewTyCon, so that it
-     terminates before doing a deep nest of expansions only to discover that the
-     first level already contained a recursion.
-  6. As a result of keeping the implementation simple, it says "recursive"
-     for `data T = MkT [T]`, even though we could argue that the inner recursion
-     (through the `[]` TyCon) by way of which `T` is recursive will already be
-     "broken" and thus never unboxed. Consequently, it might be OK to CPR a
-     function returning `T`. Lacking arguments for or against the current simple
-     behavior, we stick to it.
-  7. When the search hits an abstract TyCon (algebraic, but without visible
-     DataCons, e.g., from an .hs-boot file), it returns 'NonRecursiveOrUnsure',
-     the same as when we run out of fuel. If there is ever a recursion through
-     an abstract TyCon, then it's not part of the same function we are looking
-     at in CPR, so we can treat it as if it wasn't recursive.
-     We handle stuck type and data families much the same.
-
-Here are a few examples of data constructors or data types with a single data
-con and the answers of our function:
-
-  data T = T (Int, (Bool, Char))               NonRec
-  (:)                                          Rec
-  []                                           NonRec
-  data U = U [Int]                             NonRec
-  data U2 = U2 [U2]                            Rec     (see point (6))
-  data T1 = T1 T2; data T2 = T2 T1             Rec
-  newtype Fix f = Fix (f (Fix f))              Rec
-  data N = N (Fix (Either Int))                NonRec
-  data M = M (Fix (Either M))                  Rec
-  data F = F (F -> Int)                        NonRec  (see point (1))
-  data G = G (Int -> G)                        NonRec  (see point (1))
-  newtype MyM s a = MyM (StateT Int (ST s) a   NonRec
-  type S = (Int, Bool)                         NonRec
-
-  { type family E a where
-      E Int = Char
-      E (a,b) = (E a, E b)
-      E Char = Blub
-    data Blah = Blah (E (Int, (Int, Int)))     NonRec
-    data Blub = Blub (E (Char, Int))           Rec
-    data Blub2 = Blub2 (E (Bool, Int))     }   Unsure, because stuck (see point (7))
-
-  { data T1 = T1 T2; data T2 = T2 T3;
-    ... data T5 = T5 T1                    }   Unsure (out of fuel)  (see point (4))
-
-  { module A where -- A.hs-boot
-      data T
-    module B where
-      import {-# SOURCE #-} A
-      data U = MkU T
-      f :: T -> U
-      f t = MkU t                              Unsure (T is abstract)  (see point (7))
-    module A where -- A.hs
-      import B
-      data T = MkT U }
-
-These examples are tested by the testcase RecDataConCPR.
-
-I've played with the idea to make points (1) through (3) of 'isRecDataCon'
-configurable like (4) to enable more re-use throughout the compiler, but haven't
-found a killer app for that yet, so ultimately didn't do that.
-
-Note [CPR examples]
-~~~~~~~~~~~~~~~~~~~
-Here are some examples (stranal/should_compile/T10482a) of the
-usefulness of Note [Optimistic field binder CPR].  The main
-point: all of these functions can have the CPR property.
-
-    ------- f1 -----------
-    -- x is used strictly by h, so it'll be available
-    -- unboxed before it is returned in the True branch
-
-    f1 :: Int -> Int
-    f1 x = case h x x of
-            True  -> x
-            False -> f1 (x-1)
-
-    ------- f3 -----------
-    -- h is strict in x, so x will be unboxed before it
-    -- is rerturned in the otherwise case.
-
-    data T3 = MkT3 Int Int
-
-    f1 :: T3 -> Int
-    f1 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))
-                  | otherwise = x
-
-Historic Note [Optimistic field binder CPR]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This Note describes how we used to guess whether fields have the CPR property
-before we were able to express Nested CPR for arguments.
-
-Consider
-
-  data T a = MkT a
-  f :: T Int -> Int
-  f x = ... (case x of
-    MkT y -> y) ...
-
-And assume we know from strictness analysis that `f` is strict in `x` and its
-field `y` and we unbox both. Then we give `x` the CPR property according
-to Note [CPR for binders that will be unboxed]. But `x`'s sole field `y`
-likewise will be unboxed and it should also get the CPR property. We'd
-need a *nested* CPR property here for `x` to express that and unwrap one level
-when we analyse the Case to give the CPR property to `y`.
-
-Lacking Nested CPR (hence this Note is historic now that we have Nested CPR), we
-have to guess a bit, by looking for
-
-  (A) Flat CPR on the scrutinee
-  (B) A variable scrutinee. Otherwise surely it can't be a parameter.
-  (C) Strict demand on the field binder `y` (or it binds a strict field)
-
-While (A) is a necessary condition to give a field the CPR property, there are
-ways in which (B) and (C) are too lax, leading to unsound analysis results and
-thus reboxing in the wrapper:
-
-  (b) We could scrutinise some other variable than a parameter, like in
-
-        g :: T Int -> Int
-        g x = let z = foo x in -- assume `z` has CPR property
-              case z of MkT y -> y
-
-      Lacking Nested CPR and multiple levels of unboxing, only the outer box
-      of `z` will be available and a case on `y` won't actually cancel away.
-      But it's simple, and nothing terrible happens if we get it wrong. e.g.
-      #10694.
-
-  (c) A strictly used field binder doesn't mean the function is strict in it.
-
-        h :: T Int -> Int -> Int
-        h !x 0 = 0
-        h  x 0 = case x of MkT y -> y
-
-      Here, `y` is used strictly, but the field of `x` certainly is not and
-      consequently will not be available unboxed.
-      Why not look at the demand of `x` instead to determine whether `y` is
-      unboxed? Because the 'idDemandInfo' on `x` will not have been propagated
-      to its occurrence in the scrutinee when CprAnal runs directly after
-      DmdAnal.
-
-We used to give the case binder the CPR property unconditionally instead of
-deriving it from the case scrutinee.
-See Historic Note [Optimistic case binder CPR].
-
-Historic Note [Optimistic case binder CPR]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We used to give the case binder the CPR property unconditionally, which is too
-optimistic (#19232). Here are the details:
-
-Inside the alternative, the case binder always has the CPR property, meaning
-that a case on it will successfully cancel.
-Example:
-  f True  x = case x of y { I# x' -> if x' ==# 3
-                                     then y
-                                     else I# 8 }
-  f False x = I# 3
-By giving 'y' the CPR property, we ensure that 'f' does too, so we get
-  f b x = case fw b x of { r -> I# r }
-  fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
-  fw False x = 3
-Of course there is the usual risk of re-boxing: we have 'x' available boxed
-and unboxed, but we return the unboxed version for the wrapper to box. If the
-wrapper doesn't cancel with its caller, we'll end up re-boxing something that
-we did have available in boxed form.
-
--}
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
deleted file mode 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ /dev/null
@@ -1,2594 +0,0 @@
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-
-
-                        -----------------
-                        A demand analysis
-                        -----------------
--}
-
-
-module GHC.Core.Opt.DmdAnal
-   ( DmdAnalOpts(..)
-   , dmdAnalProgram
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Core.Opt.WorkWrap.Utils
-import GHC.Types.Demand   -- All of it
-import GHC.Core
-import GHC.Core.Multiplicity ( scaledThing )
-import GHC.Utils.Outputable
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
-import GHC.Types.Basic
-import Data.List        ( mapAccumL )
-import GHC.Core.DataCon
-import GHC.Types.ForeignCall ( isSafeForeignCall )
-import GHC.Types.Id
-import GHC.Core.Utils
-import GHC.Core.TyCon
-import GHC.Core.Type
-import GHC.Core.Predicate( isClassPred )
-import GHC.Core.FVs      ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds )
-import GHC.Core.Coercion ( Coercion )
-import GHC.Core.TyCo.FVs     ( coVarsOfCos )
-import GHC.Core.TyCo.Compare ( eqType )
-import GHC.Core.FamInstEnv
-import GHC.Core.Opt.Arity ( typeArity )
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Data.Maybe
-import GHC.Builtin.PrimOps
-import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.MemoFun
-import GHC.Types.RepType
-
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Top level stuff}
-*                                                                      *
-************************************************************************
--}
-
--- | Options for the demand analysis
-data DmdAnalOpts = DmdAnalOpts
-   { dmd_strict_dicts    :: !Bool
-   -- ^ Value of `-fdicts-strict` (on by default).
-   -- When set, all functons are implicitly strict in dictionary args.
-   , dmd_do_boxity       :: !Bool
-   -- ^ Governs whether the analysis should update boxity signatures.
-   -- See Note [Don't change boxity without worker/wrapper].
-   , dmd_unbox_width     :: !Int
-   -- ^ Value of `-fdmd-unbox-width`.
-   -- See Note [Unboxed demand on function bodies returning small products]
-   , dmd_max_worker_args :: !Int
-   -- ^ Value of `-fmax-worker-args`.
-   -- Don't unbox anything if we end up with more than this many args.
-   }
-
--- This is a strict alternative to (,)
--- See Note [Space Leaks in Demand Analysis]
-data WithDmdType a = WithDmdType !DmdType !a
-
-getAnnotated :: WithDmdType a -> a
-getAnnotated (WithDmdType _ a) = a
-
-data DmdResult a b = R !a !b
-
--- | Outputs a new copy of the Core program in which binders have been annotated
--- with demand and strictness information.
---
--- Note: use `seqBinds` on the result to avoid leaks due to lazyness (cf Note
--- [Stamp out space leaks in demand analysis])
-dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram
-dmdAnalProgram opts fam_envs rules binds
-  = getAnnotated $ go (emptyAnalEnv opts fam_envs) binds
-  where
-    -- See Note [Analysing top-level bindings]
-    -- and Note [Why care for top-level demand annotations?]
-    go _   []     = WithDmdType nopDmdType []
-    go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body
-      where
-        anal_body env'
-          | WithDmdType body_ty bs' <- go env' bs
-          = WithDmdType (add_exported_uses env' body_ty (bindersOf b)) bs'
-
-    cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b]
-    cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs')
-
-    add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType
-    add_exported_uses env = foldl' (add_exported_use env)
-
-    -- If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@
-    -- corresponds to the demand type of @(id, e)@, but is a lot more direct.
-    -- See Note [Analysing top-level bindings].
-    add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType
-    add_exported_use env dmd_ty id
-      | isExportedId id || elemVarSet id rule_fvs
-      -- See Note [Absence analysis for stable unfoldings and RULES]
-      = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id))
-      | otherwise
-      = dmd_ty
-
-    rule_fvs :: IdSet
-    rule_fvs = rulesRhsFreeIds rules
-
--- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings
--- that satisfy this function.
---
--- Basically, we want to know how top-level *functions* are *used*
--- (e.g. called). The information will always be lazy.
--- Any other top-level bindings are boring.
---
--- See also Note [Why care for top-level demand annotations?].
-isInterestingTopLevelFn :: Id -> Bool
--- SG tried to set this to True and got a +2% ghc/alloc regression in T5642
--- (which is dominated by the Simplifier) at no gain in analysis precision.
--- If there was a gain, that regression might be acceptable.
--- Plus, we could use LetUp for thunks and share some code with local let
--- bindings.
-isInterestingTopLevelFn id = typeArity (idType id) > 0
-
-{- Note [Stamp out space leaks in demand analysis]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The demand analysis pass outputs a new copy of the Core program in
-which binders have been annotated with demand and strictness
-information. It's tiresome to ensure that this information is fully
-evaluated everywhere that we produce it, so we just run a single
-seqBinds over the output before returning it, to ensure that there are
-no references holding on to the input Core program.
-
-This makes a ~30% reduction in peak memory usage when compiling
-DynFlags (cf #9675 and #13426).
-
-This is particularly important when we are doing late demand analysis,
-since we don't do a seqBinds at any point thereafter. Hence code
-generation would hold on to an extra copy of the Core program, via
-unforced thunks in demand or strictness information; and it is the
-most memory-intensive part of the compilation process, so this added
-seqBinds makes a big difference in peak memory usage.
-
-Note [Don't change boxity without worker/wrapper]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (T21754)
-  f n = n+1
-  {-# NOINLINE f #-}
-With `-fno-worker-wrapper`, we should not give `f` a boxity signature that says
-that it unboxes its argument! Client modules would never be able to cancel away
-the box for n. Likewise we shouldn't give `f` the CPR property.
-
-Similarly, in the last run of DmdAnal before codegen (which does not have a
-worker/wrapper phase) we should not change boxity in any way. Remember: an
-earlier result of the demand analyser, complete with worker/wrapper, has aleady
-given a demand signature (with boxity info) to the function.
-(The "last run" is mainly there to attach demanded-once info to let-bindings.)
-
-In general, we should not run Note [Boxity analysis] unless worker/wrapper
-follows to exploit the boxity and make sure that calling modules can observe the
-reported boxity.
-
-Hence DmdAnal is configured by a flag `dmd_do_boxity` that is True only
-if worker/wrapper follows after DmdAnal. If it is not set, and the signature
-is not subject to Note [Boxity for bottoming functions], DmdAnal tries
-to transfer over the previous boxity to the new demand signature, in
-`setIdDmdAndBoxSig`.
-
-Why isn't CprAnal configured with a similar flag? Because if we aren't going to
-do worker/wrapper we don't run CPR analysis at all. (see GHC.Core.Opt.Pipeline)
-
-It might be surprising that we only try to preserve *arg* boxity, not boxity on
-FVs. But FV demands won't make it into interface files anyway, so it's a waste
-of energy.
-Besides, W/W zaps the `DmdEnv` portion of a signature, so we don't know the old
-boxity to begin with; see Note [Zapping DmdEnv after Demand Analyzer].
-
-Note [Analysing top-level bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider a CoreProgram like
-  e1 = ...
-  n1 = ...
-  e2 = \a b -> ... fst (n1 a b) ...
-  n2 = \c d -> ... snd (e2 c d) ...
-  ...
-where e* are exported, but n* are not.
-Intuitively, we can see that @n1@ is only ever called with two arguments
-and in every call site, the first component of the result of the call
-is evaluated. Thus, we'd like it to have idDemandInfo @LC(L,C(M,P(1L,A))@.
-NB: We may *not* give e2 a similar annotation, because it is exported and
-external callers might use it in arbitrary ways, expressed by 'topDmd'.
-This can then be exploited by Nested CPR and eta-expansion,
-see Note [Why care for top-level demand annotations?].
-
-How do we get this result? Answer: By analysing the program as if it was a let
-expression of this form:
-  let e1 = ... in
-  let n1 = ... in
-  let e2 = ... in
-  let n2 = ... in
-  (e1,e2, ...)
-E.g. putting all bindings in nested lets and returning all exported binders in a tuple.
-Of course, we will not actually build that CoreExpr! Instead we faithfully
-simulate analysis of said expression by adding the free variable 'DmdEnv'
-of @e*@'s strictness signatures to the 'DmdType' we get from analysing the
-nested bindings.
-
-And even then the above form blows up analysis performance in T10370:
-If @e1@ uses many free variables, we'll unnecessarily carry their demands around
-with us from the moment we analyse the pair to the moment we bubble back up to
-the binding for @e1@. So instead we analyse as if we had
-  let e1 = ... in
-  (e1, let n1 = ... in
-  (    let e2 = ... in
-  (e2, let n2 = ... in
-  (    ...))))
-That is, a series of right-nested pairs, where the @fst@ are the exported
-binders of the last enclosing let binding and @snd@ continues the nested
-lets.
-
-Variables occurring free in RULE RHSs are to be handled the same as exported Ids.
-See also Note [Absence analysis for stable unfoldings and RULES].
-
-Note [Why care for top-level demand annotations?]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Reading Note [Analysing top-level bindings], you might think that we go through
-quite some trouble to get useful demands for top-level bindings. They can never
-be strict, for example, so why bother?
-
-First, we get to eta-expand top-level bindings that we weren't able to
-eta-expand before without Call Arity. From T18894b:
-  module T18894b (f) where
-  eta :: Int -> Int -> Int
-  eta x = if fst (expensive x) == 13 then \y -> ... else \y -> ...
-  f m = ... eta m 2 ... eta 2 m ...
-Since only @f@ is exported, we see all call sites of @eta@ and can eta-expand to
-arity 2.
-
-The call demands we get for some top-level bindings will also allow Nested CPR
-to unbox deeper. From T18894:
-  module T18894 (h) where
-  g m n = (2 * m, 2 `div` n)
-  {-# NOINLINE g #-}
-  h :: Int -> Int
-  h m = ... snd (g m 2) ... uncurry (+) (g 2 m) ...
-Only @h@ is exported, hence we see that @g@ is always called in contexts were we
-also force the division in the second component of the pair returned by @g@.
-This allows Nested CPR to evaluate the division eagerly and return an I# in its
-position.
--}
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{The analyser itself}
-*                                                                      *
-************************************************************************
--}
-
--- | Analyse a binding group and its \"body\", e.g. where it is in scope.
---
--- It calls a function that knows how to analyse this \"body\" given
--- an 'AnalEnv' with updated demand signatures for the binding group
--- (reflecting their 'idDmdSigInfo') and expects to receive a
--- 'DmdType' in return, which it uses to annotate the binding group with their
--- 'idDemandInfo'.
-dmdAnalBind
-  :: TopLevelFlag
-  -> AnalEnv
-  -> SubDemand                 -- ^ Demand put on the "body"
-                               --   (important for join points)
-  -> CoreBind
-  -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g.
-                               --   where the binding is in scope
-  -> WithDmdType (DmdResult CoreBind a)
-dmdAnalBind top_lvl env dmd bind anal_body = case bind of
-  NonRec id rhs
-    | useLetUp top_lvl id
-    -> dmdAnalBindLetUp   top_lvl env     id rhs anal_body
-  _ -> dmdAnalBindLetDown top_lvl env dmd bind   anal_body
-
--- | Annotates uninteresting top level functions ('isInterestingTopLevelFn')
--- with 'topDmd', the rest with the given demand.
-setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id
-setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of
-  TopLevel | not (isInterestingTopLevelFn id) -> topDmd
-  _                                           -> dmd
-
--- | Update the demand signature, but be careful not to change boxity info if
--- `dmd_do_boxity` is True or if the signature is bottom.
--- See Note [Don't change boxity without worker/wrapper]
--- and Note [Boxity for bottoming functions].
-setIdDmdAndBoxSig :: DmdAnalOpts -> Id -> DmdSig -> Id
-setIdDmdAndBoxSig opts id sig = setIdDmdSig id $
-  if dmd_do_boxity opts || isBottomingSig sig
-    then sig
-    else transferArgBoxityDmdSig (idDmdSig id) sig
-
--- | Let bindings can be processed in two ways:
--- Down (RHS before body) or Up (body before RHS).
--- This function handles the up variant.
---
--- It is very simple. For  let x = rhs in body
---   * Demand-analyse 'body' in the current environment
---   * Find the demand, 'rhs_dmd' placed on 'x' by 'body'
---   * Demand-analyse 'rhs' in 'rhs_dmd'
---
--- This is used for a non-recursive local let without manifest lambdas (see
--- 'useLetUp').
---
--- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.
-dmdAnalBindLetUp :: TopLevelFlag
-                 -> AnalEnv
-                 -> Id
-                 -> CoreExpr
-                 -> (AnalEnv -> WithDmdType a)
-                 -> WithDmdType (DmdResult CoreBind a)
-dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body'))
-  where
-    WithDmdType body_ty body'   = anal_body env
-    WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id
-    -- See Note [Finalising boxity for demand signatures]
-
-    id_dmd'            = finaliseLetBoxity env (idType id) id_dmd
-    !id'               = setBindIdDemandInfo top_lvl id id_dmd'
-    (rhs_ty, rhs')     = dmdAnalStar env id_dmd' rhs
-
-    -- See Note [Absence analysis for stable unfoldings and RULES]
-    rule_fvs           = bndrRuleAndUnfoldingIds id
-    final_ty           = body_ty' `plusDmdType` rhs_ty `keepAliveDmdType` rule_fvs
-
--- | Let bindings can be processed in two ways:
--- Down (RHS before body) or Up (body before RHS).
--- This function handles the down variant.
---
--- It computes a demand signature (by means of 'dmdAnalRhsSig') and uses
--- that at call sites in the body.
---
--- It is used for toplevel definitions, recursive definitions and local
--- non-recursive definitions that have manifest lambdas (cf. 'useLetUp').
--- Local non-recursive definitions without a lambda are handled with LetUp.
---
--- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.
-dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a)
-dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of
-  NonRec id rhs
-    | (env', lazy_fv, id1, rhs1) <-
-        dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs
-    -> do_rest env' lazy_fv [(id1, rhs1)] (uncurry NonRec . only)
-  Rec pairs
-    | (env', lazy_fv, pairs') <- dmdFix top_lvl env dmd pairs
-    -> do_rest env' lazy_fv pairs' Rec
-  where
-    do_rest env' lazy_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body')
-      where
-        WithDmdType body_ty body'        = anal_body env'
-        -- see Note [Lazy and unleashable free variables]
-        dmd_ty                          = addLazyFVs body_ty lazy_fv
-        WithDmdType final_ty id_dmds    = findBndrsDmds env' dmd_ty (strictMap fst pairs1)
-        -- Important to force this as build_bind might not force it.
-        !pairs2                         = strictZipWith do_one pairs1 id_dmds
-        do_one (id', rhs') dmd          = ((,) $! setBindIdDemandInfo top_lvl id' dmd) $! rhs'
-        -- If the actual demand is better than the vanilla call
-        -- demand, you might think that we might do better to re-analyse
-        -- the RHS with the stronger demand.
-        -- But (a) That seldom happens, because it means that *every* path in
-        --         the body of the let has to use that stronger demand
-        -- (b) It often happens temporarily in when fixpointing, because
-        --     the recursive function at first seems to place a massive demand.
-        --     But we don't want to go to extra work when the function will
-        --     probably iterate to something less demanding.
-        -- In practice, all the times the actual demand on id2 is more than
-        -- the vanilla call demand seem to be due to (b).  So we don't
-        -- bother to re-analyse the RHS.
-
--- | Mimic the effect of 'GHC.Core.Prep.mkFloat', turning non-trivial argument
--- expressions/RHSs into a proper let-bound thunk (lifted) or a case (with
--- unlifted scrutinee).
-anticipateANF :: CoreExpr -> Card -> Card
-anticipateANF e n
-  | exprIsTrivial e                               = n -- trivial expr won't have a binding
-  | Just Unlifted <- typeLevity_maybe (exprType e)
-  , not (isAbs n && exprOkForSpeculation e)       = case_bind n
-  | otherwise                                     = let_bind  n
-  where
-    case_bind _ = C_11       -- evaluated exactly once
-    let_bind    = oneifyCard -- evaluated at most once
-
--- Do not process absent demands
--- Otherwise act like in a normal demand analysis
--- See ↦* relation in the Cardinality Analysis paper
-dmdAnalStar :: AnalEnv
-            -> Demand   -- This one takes a *Demand*
-            -> CoreExpr
-            -> (PlusDmdArg, CoreExpr)
-dmdAnalStar env (n :* sd) e
-  -- NB: (:*) expands AbsDmd and BotDmd as needed
-  | WithDmdType dmd_ty e' <- dmdAnal env sd e
-  , n' <- anticipateANF e n
-      -- See Note [Anticipating ANF in demand analysis]
-      -- and Note [Analysing with absent demand]
-  = (toPlusDmdArg $ multDmdType n' dmd_ty, e')
-
--- Main Demand Analysis machinery
-dmdAnal, dmdAnal' :: AnalEnv
-        -> SubDemand         -- The main one takes a *SubDemand*
-        -> CoreExpr -> WithDmdType CoreExpr
-
-dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
-                  dmdAnal' env d e
-
-dmdAnal' _ _ (Lit lit)     = WithDmdType nopDmdType (Lit lit)
-dmdAnal' _ _ (Type ty)     = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact
-dmdAnal' _ _ (Coercion co)
-  = WithDmdType (unitDmdType (coercionDmdEnv co)) (Coercion co)
-
-dmdAnal' env dmd (Var var)
-  = WithDmdType (dmdTransform env var dmd) (Var var)
-
-dmdAnal' env dmd (Cast e co)
-  = WithDmdType (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co)) (Cast e' co)
-  where
-    WithDmdType dmd_ty e' = dmdAnal env dmd e
-
-dmdAnal' env dmd (Tick t e)
-  = WithDmdType dmd_ty (Tick t e')
-  where
-    WithDmdType dmd_ty e' = dmdAnal env dmd e
-
-dmdAnal' env dmd (App fun (Type ty))
-  = WithDmdType fun_ty (App fun' (Type ty))
-  where
-    WithDmdType fun_ty fun' = dmdAnal env dmd fun
-
--- Lots of the other code is there to make this
--- beautiful, compositional, application rule :-)
-dmdAnal' env dmd (App fun arg)
-  = -- This case handles value arguments (type args handled above)
-    -- Crucially, coercions /are/ handled here, because they are
-    -- value arguments (#10288)
-    let
-        call_dmd          = mkCalledOnceDmd dmd
-        WithDmdType fun_ty fun' = dmdAnal env call_dmd fun
-        (arg_dmd, res_ty) = splitDmdTy fun_ty
-        (arg_ty, arg')    = dmdAnalStar env arg_dmd arg
-    in
---    pprTrace "dmdAnal:app" (vcat
---         [ text "dmd =" <+> ppr dmd
---         , text "expr =" <+> ppr (App fun arg)
---         , text "fun dmd_ty =" <+> ppr fun_ty
---         , text "arg dmd =" <+> ppr arg_dmd
---         , text "arg dmd_ty =" <+> ppr arg_ty
---         , text "res dmd_ty =" <+> ppr res_ty
---         , text "overall res dmd_ty =" <+> ppr (res_ty `plusDmdType` arg_ty) ])
-    WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg')
-
-dmdAnal' env dmd (Lam var body)
-  | isTyVar var
-  = let
-        WithDmdType body_ty body' = dmdAnal env dmd body
-    in
-    WithDmdType body_ty (Lam var body')
-
-  | otherwise
-  = let (n, body_dmd)    = peelCallDmd dmd
-          -- body_dmd: a demand to analyze the body
-
-        WithDmdType body_ty body' = dmdAnal env body_dmd body
-        WithDmdType lam_ty var'   = annotateLamIdBndr env body_ty var
-        new_dmd_type = multDmdType n lam_ty
-    in
-    WithDmdType new_dmd_type (Lam var' body')
-
-dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs])
-  -- Only one alternative.
-  -- If it's a DataAlt, it should be the only constructor of the type and we
-  -- can consider its field demands when analysing the scrutinee.
-  | want_precise_field_dmds alt_con
-  = let
-        WithDmdType rhs_ty rhs'           = dmdAnal env dmd rhs
-        WithDmdType alt_ty1 fld_dmds      = findBndrsDmds env rhs_ty bndrs
-        WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr
-        !case_bndr'                       = setIdDemandInfo case_bndr case_bndr_dmd
-
-        -- Evaluation cardinality on the case binder is irrelevant and a no-op.
-        -- What matters is its nested sub-demand!
-        -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is
-        -- what we want, because then `seq` will put a `seqDmd` on its scrut.
-        (_ :* case_bndr_sd) = strictifyDmd case_bndr_dmd
-
-        -- Compute demand on the scrutinee
-        -- FORCE the result, otherwise thunks will end up retaining the
-        -- whole DmdEnv
-        !(!bndrs', !scrut_sd)
-          | DataAlt _ <- alt_con
-          -- See Note [Demand on the scrutinee of a product case]
-          , let !scrut_sd = scrutSubDmd case_bndr_sd fld_dmds
-          -- See Note [Demand on case-alternative binders]
-          , let !fld_dmds' = fieldBndrDmds scrut_sd (length fld_dmds)
-          , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds'
-          = (bndrs', scrut_sd)
-          | otherwise
-          -- DEFAULT alts. Simply add demands and discard the evaluation
-          -- cardinality, as we evaluate the scrutinee exactly once.
-          = assert (null bndrs) (bndrs, case_bndr_sd)
-
-        alt_ty3
-          -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"
-          | exprMayThrowPreciseException (ae_fam_envs env) scrut
-          = deferAfterPreciseException alt_ty2
-          | otherwise
-          = alt_ty2
-
-        WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut
-        res_ty             = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty
-    in
---    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
---                                   , text "dmd" <+> ppr dmd
---                                   , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')
---                                   , text "scrut_sd" <+> ppr scrut_sd
---                                   , text "scrut_ty" <+> ppr scrut_ty
---                                   , text "alt_ty" <+> ppr alt_ty2
---                                   , text "res_ty" <+> ppr res_ty ]) $
-    WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt_con bndrs' rhs'])
-    where
-      want_precise_field_dmds (DataAlt dc)
-        | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc
-        = False    -- Not a product type, even though this is the
-                   -- only remaining possible data constructor
-        | DefinitelyRecursive <- ae_rec_dc env dc
-        = False     -- See Note [Demand analysis for recursive data constructors]
-        | otherwise
-        = True
-      want_precise_field_dmds (LitAlt {}) = False  -- Like the non-product datacon above
-      want_precise_field_dmds DEFAULT     = True
-
-dmdAnal' env dmd (Case scrut case_bndr ty alts)
-  = let      -- Case expression with multiple alternatives
-        WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut
-
-        WithDmdType alt_ty1 case_bndr_dmd = findBndrDmd env alt_ty case_bndr
-        !case_bndr'                       = setIdDemandInfo case_bndr case_bndr_dmd
-        WithDmdType alt_ty alts'          = dmdAnalSumAlts env dmd case_bndr alts
-
-        fam_envs             = ae_fam_envs env
-        alt_ty2
-          -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"
-          | exprMayThrowPreciseException fam_envs scrut
-          = deferAfterPreciseException alt_ty1
-          | otherwise
-          = alt_ty1
-        res_ty               = alt_ty2 `plusDmdType` toPlusDmdArg scrut_ty
-
-    in
---    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
---                                   , text "scrut_ty" <+> ppr scrut_ty
---                                   , text "alt_ty1" <+> ppr alt_ty1
---                                   , text "alt_ty2" <+> ppr alt_ty2
---                                   , text "res_ty" <+> ppr res_ty ]) $
-    WithDmdType res_ty (Case scrut' case_bndr' ty alts')
-
-dmdAnal' env dmd (Let bind body)
-  = WithDmdType final_ty (Let bind' body')
-  where
-    !(WithDmdType final_ty (R bind' body')) = dmdAnalBind NotTopLevel env dmd bind go'
-    go' !env'                 = dmdAnal env' dmd body
-
--- | A simple, syntactic analysis of whether an expression MAY throw a precise
--- exception when evaluated. It's always sound to return 'True'.
--- See Note [Which scrutinees may throw precise exceptions].
-exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool
-exprMayThrowPreciseException envs e
-  | not (forcesRealWorld envs (exprType e))
-  = False -- 1. in the Note
-  | (Var f, _) <- collectArgs e
-  , Just op    <- isPrimOpId_maybe f
-  , op /= RaiseIOOp
-  = False -- 2. in the Note
-  | (Var f, _) <- collectArgs e
-  , Just fcall <- isFCallId_maybe f
-  , not (isSafeForeignCall fcall)
-  = False -- 3. in the Note
-  | otherwise
-  = True  -- _. in the Note
-
--- | Recognises types that are
---    * @State# RealWorld@
---    * Unboxed tuples with a @State# RealWorld@ field
--- modulo coercions. This will detect 'IO' actions (even post Nested CPR! See
--- T13380e) and user-written variants thereof by their type.
-forcesRealWorld :: FamInstEnvs -> Type -> Bool
-forcesRealWorld fam_envs ty
-  | ty `eqType` realWorldStatePrimTy
-  = True
-  | Just (tc, tc_args, _co)  <- normSplitTyConApp_maybe fam_envs ty
-  , isUnboxedTupleTyCon tc
-  , let field_tys = dataConInstArgTys (tyConSingleDataCon tc) tc_args
-  = any (eqType realWorldStatePrimTy . scaledThing) field_tys
-  | otherwise
-  = False
-
-dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [CoreAlt] -> WithDmdType [CoreAlt]
-dmdAnalSumAlts _ _ _ [] = WithDmdType botDmdType []
-  -- Base case is botDmdType, for empty case alternatives
-  -- This is a unit for lubDmdType, and the right result
-  -- when there really are no alternatives
-dmdAnalSumAlts env dmd case_bndr (alt:alts)
-  = let
-      WithDmdType cur_ty  alt'  = dmdAnalSumAlt env dmd case_bndr alt
-      WithDmdType rest_ty alts' = dmdAnalSumAlts env dmd case_bndr alts
-    in WithDmdType (lubDmdType cur_ty rest_ty) (alt':alts')
-
-
-dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt
-dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)
-  | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs
-  , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs
-  , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr
-        -- See Note [Demand on case-alternative binders]
-        -- we can't use the scrut_sd, because it says 'Prod' and we'll use
-        -- topSubDmd anyway for scrutinees of sum types.
-        scrut_sd = scrutSubDmd case_bndr_sd dmds
-        dmds' = fieldBndrDmds scrut_sd (length dmds)
-        -- Do not put a thunk into the Alt
-        !new_ids            = setBndrsDemandInfo bndrs dmds'
-  = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $
-    WithDmdType alt_ty (Alt con new_ids rhs')
-
--- See Note [Demand on the scrutinee of a product case]
-scrutSubDmd :: SubDemand -> [Demand] -> SubDemand
-scrutSubDmd case_sd fld_dmds =
-  -- pprTraceWith "scrutSubDmd" (\scrut_sd -> ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) $
-  case_sd `plusSubDmd` mkProd Unboxed fld_dmds
-
--- See Note [Demand on case-alternative binders]
-fieldBndrDmds :: SubDemand -- on the scrutinee
-              -> Arity
-              -> [Demand]  -- Final demands for the components of the DataCon
-fieldBndrDmds scrut_sd n_flds =
-  case viewProd n_flds scrut_sd of
-    Just (_, ds) -> ds
-    Nothing      -> replicate n_flds topDmd
-                      -- Either an arity mismatch or scrut_sd was a call demand.
-                      -- See Note [Untyped demand on case-alternative binders]
-
-{-
-Note [Anticipating ANF in demand analysis]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When analysing non-complex (e.g., trivial) thunks and complex function
-arguments, we have to pretend that the expression is really in administrative
-normal form (ANF), the conversion to which is done by CorePrep.
-
-Consider
-```
-f x = let y = x |> co in y `seq` y `seq` ()
-```
-E.g., 'y' is a let-binding with a trivial RHS. That may occur if 'y' can't be
-inlined, for example. Now, is 'x' used once? It may appear as if that is the
-case, since its only occurrence is in 'y's memoised RHS. But actually, CorePrep
-will *not* allocate a thunk for 'y', because it is trivial and could just
-re-use the memoisation mechanism of 'x'! By saying that 'x' is used once it
-becomes a single-entry thunk and a call to 'f' will evaluate it twice.
-The same applies to trivial arguments, e.g., `f z` really evaluates `z` twice.
-
-So, somewhat counter-intuitively, trivial arguments and let RHSs will *not* be
-memoised. On the other hand, evaluation of non-trivial arguments and let RHSs
-*will* be memoised. In fact, consider the effect of conversion to ANF on complex
-function arguments (as done by 'GHC.Core.Prep.mkFloat'):
-```
-f2 (g2 x) ===> let y = g2 x in f2 y                   (if `y` is lifted)
-f3 (g3 x) ===> case g3 x of y { __DEFAULT -> f3 y }   (if `y` is not lifted)
-```
-So if a lifted argument like `g2 x` is complex enough, it will be memoised.
-Regardless how many times 'f2' evaluates its parameter, the argument will be
-evaluated at most once to WHNF.
-Similarly, when an unlifted argument like `g3 x` is complex enough, we will
-evaluate it *exactly* once to WHNF, no matter how 'f3' evaluates its parameter.
-
-Note that any evaluation beyond WHNF is not affected by memoisation. So this
-Note affects the outer 'Card' of a 'Demand', but not its nested 'SubDemand'.
-'anticipateANF' predicts the effect of case-binding and let-binding complex
-arguments, as well as the lack of memoisation for trivial let RHSs.
-In particular, this takes care of the gripes in
-Note [Analysing with absent demand] relating to unlifted types.
-
-Note [Analysing with absent demand]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we analyse an expression with demand A.  The "A" means
-"absent", so this expression will never be needed. What should happen?
-There are several wrinkles:
-
-* We *do* want to analyse the expression regardless.
-  Reason: Note [Always analyse in virgin pass]
-
-  But we can post-process the results to ignore all the usage
-  demands coming back. This is done by 'multDmdType' with the appropriate
-  (absent) evaluation cardinality A or B.
-
-* Nevertheless, which sub-demand should we pick for analysis?
-  Since the demand was absent, any would do. Worker/wrapper will replace
-  absent bindings with an absent filler anyway, so annotations in the RHS
-  of an absent binding don't matter much.
-  Picking 'botSubDmd' would be the most useful, but would also look a bit
-  misleading in the Core output of DmdAnal, because all nested annotations would
-  be bottoming. Better pick 'seqSubDmd', so that we annotate many of those
-  nested bindings with A themselves.
-
-* Since we allow unlifted arguments that are not ok-for-speculation,
-  we need to be extra careful in the following situation, because unlifted
-  values are evaluated even if they are not used. Example from #9254:
-     f :: (() -> (# Int#, () #)) -> ()
-          -- Strictness signature is
-          --    <1C(1,P(A,1L))>
-          -- I.e. calls k, but discards first component of result
-     f k = case k () of (# _, r #) -> r
-
-     g :: Int -> ()
-     g y = f (\n -> (# case y of I# y2 -> y2, n #))
-
-  Here, f's strictness signature says (correctly) that it calls its argument
-  function and ignores the first component of its result.
-
-  But in function g, we *will* evaluate the 'case y of ...', because it has type
-  Int#. So in the program as written, 'y' will be evaluated. Hence we must
-  record this usage of 'y', else 'g' will say 'y' is absent, and will w/w so
-  that 'y' is bound to an absent filler (see Note [Absent fillers]), leading
-  to a crash when 'y' is evaluated.
-
-  Now, worker/wrapper could be smarter and replace `case y of I# y2 -> y2`
-  with a suitable absent filler such as `RUBBISH[IntRep] @Int#`.
-  But as long as worker/wrapper isn't equipped to do so, we must be cautious,
-  and follow Note [Anticipating ANF in demand analysis]. That is, in
-  'dmdAnalStar', we will set the evaluation cardinality to C_11, anticipating
-  the case binding of the complex argument `case y of I# y2 -> y2`. This
-  cardinlities' only effect is in the call to 'multDmdType', where it makes sure
-  that the demand on the arg's free variable 'y' is not absent and strict, so
-  that it is ultimately passed unboxed to 'g'.
-
-Note [Always analyse in virgin pass]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Tricky point: make sure that we analyse in the 'virgin' pass. Consider
-   rec { f acc x True  = f (...rec { g y = ...g... }...)
-         f acc x False = acc }
-In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type.
-That might mean that we analyse the sub-expression containing the
-E = "...rec g..." stuff in a bottom demand.  Suppose we *didn't analyse*
-E, but just returned botType.
-
-Then in the *next* (non-virgin) iteration for 'f', we might analyse E
-in a weaker demand, and that will trigger doing a fixpoint iteration
-for g.  But *because it's not the virgin pass* we won't start g's
-iteration at bottom.  Disaster.  (This happened in $sfibToList' of
-nofib/spectral/fibheaps.)
-
-So in the virgin pass we make sure that we do analyse the expression
-at least once, to initialise its signatures.
-
-Note [Which scrutinees may throw precise exceptions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This is the specification of 'exprMayThrowPreciseExceptions',
-which is important for Scenario 2 of
-Note [Precise exceptions and strictness analysis] in GHC.Types.Demand.
-
-For an expression @f a1 ... an :: ty@ we determine that
-  1. False  If ty is *not* @State# RealWorld@ or an unboxed tuple thereof.
-            This check is done by 'forcesRealWorld'.
-            (Why not simply unboxed pairs as above? This is motivated by
-            T13380{d,e}.)
-  2. False  If f is a PrimOp, and it is *not* raiseIO#
-  3. False  If f is an unsafe FFI call ('PlayRisky')
-  _. True   Otherwise "give up".
-
-It is sound to return False in those cases, because
-  1. We don't give any guarantees for unsafePerformIO, so no precise exceptions
-     from pure code.
-  2. raiseIO# is the only primop that may throw a precise exception.
-  3. Unsafe FFI calls may not interact with the RTS (to throw, for example).
-     See haddock on GHC.Types.ForeignCall.PlayRisky.
-
-We *need* to return False in those cases, because
-  1. We would lose too much strictness in pure code, all over the place.
-  2. We would lose strictness for primops like getMaskingState#, which
-     introduces a substantial regression in
-     GHC.IO.Handle.Internals.wantReadableHandle.
-  3. We would lose strictness for code like GHC.Fingerprint.fingerprintData,
-     where an intermittent FFI call to c_MD5Init would otherwise lose
-     strictness on the arguments len and buf, leading to regressions in T9203
-     (2%) and i386's haddock.base (5%). Tested by T13380f.
-
-In !3014 we tried a more sophisticated analysis by introducing ConOrDiv (nic)
-to the Divergence lattice, but in practice it turned out to be hard to untaint
-from 'topDiv' to 'conDiv', leading to bugs, performance regressions and
-complexity that didn't justify the single fixed testcase T13380c.
-
-Note [Demand analysis for recursive data constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-T11545 features a single-product, recursive data type
-  data A = A A A ... A
-    deriving Eq
-Naturally, `(==)` is deeply strict in `A` and in fact will never terminate. That
-leads to very large (exponential in the depth) demand signatures and fruitless
-churn in boxity analysis, demand analysis and worker/wrapper.
-
-So we detect `A` as a recursive data constructor (see
-Note [Detecting recursive data constructors]) analysing `case x of A ...`
-and simply assume L for the demand on field binders, which is the same code
-path as we take for sum types. This code happens in want_precise_field_dmds
-in the Case equation for dmdAnal.
-
-Combined with the B demand on the case binder, we get the very small demand
-signature <1S><1S>b on `(==)`. This improves ghc/alloc performance on T11545
-tenfold! See also Note [CPR for recursive data constructors] which describes the
-sibling mechanism in CPR analysis.
-
-Note [Demand on the scrutinee of a product case]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When figuring out the demand on the scrutinee of a product case,
-we use the demands of the case alternative, i.e. id_dmds.
-But note that these include the demand on the case binder;
-see Note [Demand on case-alternative binders].
-This is crucial. Example:
-   f x = case x of y { (a,b) -> k y a }
-If we just take scrut_demand = 1P(L,A), then we won't pass x to the
-worker, so the worker will rebuild
-     x = (a, absent-error)
-and that'll crash.
-
-Note [Demand on case-alternative binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The demand on a binder in a case alternative comes
-  (a) From the demand on the binder itself
-  (b) From the demand on the case binder
-Forgetting (b) led directly to #10148.
-
-Example. Source code:
-  f x@(p,_) = if p then foo x else True
-
-  foo (p,True) = True
-  foo (p,q)    = foo (q,p)
-
-After strictness analysis, forgetting (b):
-  f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) ->
-      case x_an1
-      of wild_X7 [Dmd=MP(ML,ML)]
-      { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) ->
-      case p_an2 of _ {
-        False -> GHC.Types.True;
-        True -> foo wild_X7 }
-
-Note that ds_dnz is syntactically dead, but the expression bound to it is
-reachable through the case binder wild_X7. Now watch what happens if we inline
-foo's wrapper:
-  f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) ->
-      case x_an1
-      of _ [Dmd=MP(ML,ML)]
-      { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) ->
-      case p_an2 of _ {
-        False -> GHC.Types.True;
-        True -> $wfoo_soq GHC.Types.True ds_dnz }
-
-Look at that! ds_dnz has come back to life in the call to $wfoo_soq! A second
-run of demand analysis would no longer infer ds_dnz to be absent.
-But unlike occurrence analysis, which infers properties of the *syntactic*
-shape of the program, the results of demand analysis describe expressions
-*semantically* and are supposed to be mostly stable across Simplification.
-That's why we should better account for (b).
-In #10148, we ended up emitting a single-entry thunk instead of an updateable
-thunk for a let binder that was an an absent case-alt binder during DmdAnal.
-
-This is needed even for non-product types, in case the case-binder
-is used but the components of the case alternative are not.
-
-Note [Untyped demand on case-alternative binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-With unsafeCoerce, #8037 and #22039 taught us that the demand on the case binder
-may be a call demand or have a different number of fields than the constructor
-of the case alternative it is used in. From T22039:
-
-  blarg :: (Int, Int) -> Int
-  blarg (x,y) = x+y
-  -- blarg :: <1!P(1L,1L)>
-
-  f :: Either Int Int -> Int
-  f Left{} = 0
-  f e = blarg (unsafeCoerce e)
-  ==> { desugars to }
-  f = \ (ds_d1nV :: Either Int Int) ->
-      case ds_d1nV of wild_X1 {
-        Left ds_d1oV -> lvl_s1Q6;
-        Right ipv_s1Pl ->
-          blarg
-            (case unsafeEqualityProof @(*) @(Either Int Int) @(Int, Int) of
-             { UnsafeRefl co_a1oT ->
-             wild_X1 `cast` (Sub (Sym co_a1oT) :: Either Int Int ~R# (Int, Int))
-             })
-      }
-
-The case binder `e`/`wild_X1` has demand 1!P(1L,1L), with two fields, from the call
-to `blarg`, but `Right` only has one field. Although the code will crash when
-executed, we must be able to analyse it in 'fieldBndrDmds' and conservatively
-approximate with Top instead of panicking because of the mismatch.
-In #22039, this kind of code was guarded behind a safe `cast` and thus dead
-code, but nevertheless led to a panic of the compiler.
-
-You might wonder why the same problem doesn't come up when scrutinising a
-product type instead of a sum type. It appears that for products, `wild_X1`
-will be inlined before DmdAnal.
-
-See also Note [mkWWstr and unsafeCoerce] for a related issue.
-
-Note [Aggregated demand for cardinality]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-FIXME: This Note should be named [LetUp vs. LetDown] and probably predates
-said separation. SG
-
-We use different strategies for strictness and usage/cardinality to
-"unleash" demands captured on free variables by bindings. Let us
-consider the example:
-
-f1 y = let {-# NOINLINE h #-}
-           h = y
-       in  (h, h)
-
-We are interested in obtaining cardinality demand U1 on |y|, as it is
-used only in a thunk, and, therefore, is not going to be updated any
-more. Therefore, the demand on |y|, captured and unleashed by usage of
-|h| is U1. However, if we unleash this demand every time |h| is used,
-and then sum up the effects, the ultimate demand on |y| will be U1 +
-U1 = U. In order to avoid it, we *first* collect the aggregate demand
-on |h| in the body of let-expression, and only then apply the demand
-transformer:
-
-transf[x](U) = {y |-> U1}
-
-so the resulting demand on |y| is U1.
-
-The situation is, however, different for strictness, where this
-aggregating approach exhibits worse results because of the nature of
-|both| operation for strictness. Consider the example:
-
-f y c =
-  let h x = y |seq| x
-   in case of
-        True  -> h True
-        False -> y
-
-It is clear that |f| is strict in |y|, however, the suggested analysis
-will infer from the body of |let| that |h| is used lazily (as it is
-used in one branch only), therefore lazy demand will be put on its
-free variable |y|. Conversely, if the demand on |h| is unleashed right
-on the spot, we will get the desired result, namely, that |f| is
-strict in |y|.
-
-
-************************************************************************
-*                                                                      *
-                    Demand transformer
-*                                                                      *
-************************************************************************
--}
-
-dmdTransform :: AnalEnv   -- ^ The analysis environment
-             -> Id        -- ^ The variable
-             -> SubDemand -- ^ The evaluation context of the var
-             -> DmdType   -- ^ The demand type unleashed by the variable in this
-                          -- context. The returned DmdEnv includes the demand on
-                          -- this function plus demand on its free variables
--- See Note [What are demand signatures?] in "GHC.Types.Demand"
-dmdTransform env var sd
-  -- Data constructors
-  | Just con <- isDataConWorkId_maybe var
-  = -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr con $$ ppr sd $$ ppr ty) $
-    dmdTransformDataConSig (dataConRepStrictness con) sd
-  -- See Note [DmdAnal for DataCon wrappers]
-  | isDataConWrapId var, let rhs = uf_tmpl (realIdUnfolding var)
-  , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs
-  = dmd_ty
-  -- Dictionary component selectors
-  -- Used to be controlled by a flag.
-  -- See #18429 for some perf measurements.
-  | Just _ <- isClassOpId_maybe var
-  = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr (idDmdSig var) $$ ppr sd) $
-    dmdTransformDictSelSig (idDmdSig var) sd
-  -- Imported functions
-  | isGlobalId var
-  , let res = dmdTransformSig (idDmdSig var) sd
-  = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idDmdSig var), ppr sd, ppr res])
-    res
-  -- Top-level or local let-bound thing for which we use LetDown ('useLetUp').
-  -- In that case, we have a strictness signature to unleash in our AnalEnv.
-  | Just (sig, top_lvl) <- lookupSigEnv env var
-  , let fn_ty = dmdTransformSig sig sd
-  = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr sd, ppr fn_ty]) $
-    case top_lvl of
-      NotTopLevel -> addVarDmd fn_ty var (C_11 :* sd)
-      TopLevel
-        | isInterestingTopLevelFn var
-        -- Top-level things will be used multiple times or not at
-        -- all anyway, hence the multDmd below: It means we don't
-        -- have to track whether @var@ is used strictly or at most
-        -- once, because ultimately it never will.
-        -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* sd)) -- discard strictness
-        | otherwise
-        -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later
-  -- Everything else:
-  --   * Local let binders for which we use LetUp (cf. 'useLetUp')
-  --   * Lambda binders
-  --   * Case and constructor field binders
-  | otherwise
-  = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $
-    unitDmdType (unitVarEnv var (C_11 :* sd))
-
-{- *********************************************************************
-*                                                                      *
-                      Binding right-hand sides
-*                                                                      *
-********************************************************************* -}
-
--- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature
--- for the LetDown rule. It works as follows:
---
---  * assuming the weakest possible body sub-demand, L
---  * looking at the definition
---  * determining a strictness signature
---
--- Since it assumed a body sub-demand of L, the resulting signature is
--- applicable at any call site.
-dmdAnalRhsSig
-  :: TopLevelFlag
-  -> RecFlag
-  -> AnalEnv -> SubDemand
-  -> Id -> CoreExpr
-  -> (AnalEnv, DmdEnv, Id, CoreExpr)
--- Process the RHS of the binding, add the strictness signature
--- to the Id, and augment the environment with the signature as well.
--- See Note [NOINLINE and strictness]
-dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
-  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr lazy_fv) $
-    (final_env, lazy_fv, final_id, final_rhs)
-  where
-    threshold_arity = thresholdArity id rhs
-
-    rhs_dmd = mkCalledOnceDmds threshold_arity body_dmd
-
-    body_dmd
-      | isJoinId id
-      -- See Note [Demand analysis for join points]
-      -- See Note [Invariants on join points] invariant 2b, in GHC.Core
-      --     threshold_arity matches the join arity of the join point
-      -- See Note [Unboxed demand on function bodies returning small products]
-      = unboxedWhenSmall env rec_flag (resultType_maybe id) let_dmd
-      | otherwise
-      -- See Note [Unboxed demand on function bodies returning small products]
-      = unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd
-
-    WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs
-    DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty
-    -- See Note [Boxity for bottoming functions]
-    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity rhs' rhs_div
-                                  `orElse` (rhs_dmds, rhs')
-
-    sig = mkDmdSigForArity threshold_arity (DmdType sig_fv final_rhs_dmds rhs_div)
-
-    opts       = ae_opts env
-    final_id   = setIdDmdAndBoxSig opts id sig
-    !final_env = extendAnalEnv top_lvl env final_id sig
-
-    -- See Note [Aggregated demand for cardinality]
-    -- FIXME: That Note doesn't explain the following lines at all. The reason
-    --        is really much different: When we have a recursive function, we'd
-    --        have to also consider the free vars of the strictness signature
-    --        when checking whether we found a fixed-point. That is expensive;
-    --        we only want to check whether argument demands of the sig changed.
-    --        reuseEnv makes it so that the FV results are stable as long as the
-    --        last argument demands were. Strictness won't change. But used-once
-    --        might turn into used-many even if the signature was stable and
-    --        we'd have to do an additional iteration. reuseEnv makes sure that
-    --        we never get used-once info for FVs of recursive functions.
-    --        See #14816 where we try to get rid of reuseEnv.
-    rhs_fv1 = case rec_flag of
-                Recursive    -> reuseEnv rhs_fv
-                NonRecursive -> rhs_fv
-
-    -- See Note [Absence analysis for stable unfoldings and RULES]
-    rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id
-
-    -- See Note [Lazy and unleashable free variables]
-    !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2
-
-thresholdArity :: Id -> CoreExpr -> Arity
--- See Note [Demand signatures are computed for a threshold arity based on idArity]
-thresholdArity fn rhs
-  = case isJoinId_maybe fn of
-      Just join_arity -> count isId $ fst $ collectNBinders join_arity rhs
-      Nothing         -> idArity fn
-
--- | The result type after applying 'idArity' many arguments. Returns 'Nothing'
--- when the type doesn't have exactly 'idArity' many arrows.
-resultType_maybe :: Id -> Maybe Type
-resultType_maybe id
-  | (pis,ret_ty) <- splitPiTys (idType id)
-  , count isAnonPiTyBinder pis == idArity id
-  = Just $! ret_ty
-  | otherwise
-  = Nothing
-
-unboxedWhenSmall :: AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand
--- See Note [Unboxed demand on function bodies returning small products]
-unboxedWhenSmall _   _        Nothing       sd = sd
-unboxedWhenSmall env rec_flag (Just ret_ty) sd = go 1 ret_ty sd
-  where
-    -- Magic constant, bounding the depth of optimistic 'Unboxed' flags. We
-    -- might want to minmax in the future.
-    max_depth | isRec rec_flag = 3 -- So we get at most something as deep as !P(L!P(L!L))
-              | otherwise      = 1 -- Otherwise be unbox too deep in T18109, T18174 and others and get a bunch of stack overflows
-    go :: Int -> Type -> SubDemand -> SubDemand
-    go depth ty sd
-      | depth <= max_depth
-      , Just (tc, tc_args, _co) <- normSplitTyConApp_maybe (ae_fam_envs env) ty
-      , Just dc <- tyConSingleAlgDataCon_maybe tc
-      , null (dataConExTyCoVars dc) -- Can't unbox results with existentials
-      , dataConRepArity dc <= dmd_unbox_width (ae_opts env)
-      , Just (_, ds) <- viewProd (dataConRepArity dc) sd
-      , arg_tys <- map scaledThing $ dataConInstArgTys dc tc_args
-      , equalLength ds arg_tys
-      = mkProd Unboxed $! strictZipWith (go_dmd (depth+1)) arg_tys ds
-      | otherwise
-      = sd
-
-    go_dmd :: Int -> Type -> Demand -> Demand
-    go_dmd depth ty dmd = case dmd of
-      AbsDmd  -> AbsDmd
-      BotDmd  -> BotDmd
-      n :* sd -> n :* go depth ty sd
-
--- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines
--- whether we should process the binding up (body before rhs) or down (rhs
--- before body).
---
--- We use LetDown if there is a chance to get a useful strictness signature to
--- unleash at call sites. LetDown is generally more precise than LetUp if we can
--- correctly guess how it will be used in the body, that is, for which incoming
--- demand the strictness signature should be computed, which allows us to
--- unleash higher-order demands on arguments at call sites. This is mostly the
--- case when
---
---   * The binding takes any arguments before performing meaningful work (cf.
---     'idArity'), in which case we are interested to see how it uses them.
---   * The binding is a join point, hence acting like a function, not a value.
---     As a big plus, we know *precisely* how it will be used in the body; since
---     it's always tail-called, we can directly unleash the incoming demand of
---     the let binding on its RHS when computing a strictness signature. See
---     [Demand analysis for join points].
---
--- Thus, if the binding is not a join point and its arity is 0, we have a thunk
--- and use LetUp, implying that we have no usable demand signature available
--- when we analyse the let body.
---
--- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free
--- vars at most once, regardless of how many times it was forced in the body.
--- This makes a real difference wrt. usage demands. The other reason is being
--- able to unleash a more precise product demand on its RHS once we know how the
--- thunk was used in the let body.
---
--- Characteristic examples, always assuming a single evaluation:
---
---   * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that
---     the expression uses @y@ at most once.
---   * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that
---     @b@ is absent.
---   * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that
---     the expression uses @y@ strictly, because we have @f@'s demand signature
---     available at the call site.
---   * @join exit = 2*y in if a then exit else if b then exit else 3*y@ =>
---     LetDown. Compared to LetUp, we find out that the expression uses @y@
---     strictly, because we can unleash @exit@'s signature at each call site.
---   * For a more convincing example with join points, see Note [Demand analysis
---     for join points].
---
-useLetUp :: TopLevelFlag -> Var -> Bool
-useLetUp top_lvl f = isNotTopLevel top_lvl && idArity f == 0 && not (isJoinId f)
-
-{- Note [Demand analysis for join points]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   g :: (Int,Int) -> Int
-   g (p,q) = p+q
-
-   f :: T -> Int -> Int
-   f x p = g (join j y = (p,y)
-              in case x of
-                   A -> j 3
-                   B -> j 4
-                   C -> (p,7))
-
-If j was a vanilla function definition, we'd analyse its body with
-evalDmd, and think that it was lazy in p.  But for join points we can
-do better!  We know that j's body will (if called at all) be evaluated
-with the demand that consumes the entire join-binding, in this case
-the argument demand from g.  Whizzo!  g evaluates both components of
-its argument pair, so p will certainly be evaluated if j is called.
-
-For f to be strict in p, we need /all/ paths to evaluate p; in this
-case the C branch does so too, so we are fine.  So, as usual, we need
-to transport demands on free variables to the call site(s).  Compare
-Note [Lazy and unleashable free variables].
-
-The implementation is easy.  When analysing a join point, we can
-analyse its body with the demand from the entire join-binding (written
-let_dmd here).
-
-Another win for join points!  #13543.
-
-However, note that the strictness signature for a join point can
-look a little puzzling.  E.g.
-
-    (join j x = \y. error "urk")
-    (in case v of              )
-    (     A -> j 3             )  x
-    (     B -> j 4             )
-    (     C -> \y. blah        )
-
-The entire thing is in a C(1,L) context, so j's strictness signature
-will be    [A]b
-meaning one absent argument, returns bottom.  That seems odd because
-there's a \y inside.  But it's right because when consumed in a C(1,L)
-context the RHS of the join point is indeed bottom.
-
-Note [Demand signatures are computed for a threshold arity based on idArity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given a binding { f = rhs }, we compute a "theshold arity", and do demand
-analysis based on a call with that many value arguments.
-
-The threshold we use is
-
-* Ordinary bindings: idArity f.
-  Why idArity arguments? Because that's a conservative estimate of how many
-  arguments we must feed a function before it does anything interesting with
-  them.  Also it elegantly subsumes the trivial RHS and PAP case.
-
-  idArity is /at least/ the number of manifest lambdas, but might be higher for
-  PAPs and trivial RHS (see Note [Demand analysis for trivial right-hand sides]).
-
-* Join points: the value-binder subset of the JoinArity.  This can
-  be less than the number of visible lambdas; e.g.
-     join j x = \y. blah
-     in ...(jump j 2)....(jump j 3)....
-  We know that j will never be applied to more than 1 arg (its join
-  arity, and we don't eta-expand join points, so here a threshold
-  of 1 is the best we can do.
-
-Note that the idArity of a function varies independently of its cardinality
-properties (cf. Note [idArity varies independently of dmdTypeDepth]), so we
-implicitly encode the arity for when a demand signature is sound to unleash
-in its 'dmdTypeDepth', not in its idArity (cf. Note [Understanding DmdType
-and DmdSig] in GHC.Types.Demand). It is unsound to unleash a demand
-signature when the incoming number of arguments is less than that. See
-GHC.Types.Demand Note [What are demand signatures?]  for more details on
-soundness.
-
-Note that there might, in principle, be functions for which we might want to
-analyse for more incoming arguments than idArity. Example:
-
-  f x =
-    if expensive
-      then \y -> ... y ...
-      else \y -> ... y ...
-
-We'd analyse `f` under a unary call demand C(1,L), corresponding to idArity
-being 1. That's enough to look under the manifest lambda and find out how a
-unary call would use `x`, but not enough to look into the lambdas in the if
-branches.
-
-On the other hand, if we analysed for call demand C(1,C(1,L)), we'd get useful
-strictness info for `y` (and more precise info on `x`) and possibly CPR
-information, but
-
-  * We would no longer be able to unleash the signature at unary call sites
-
-  * Performing the worker/wrapper split based on this information would be
-    implicitly eta-expanding `f`, playing fast and loose with divergence and
-    even being unsound in the presence of newtypes, so we refrain from doing so.
-    Also see Note [Don't eta expand in w/w] in GHC.Core.Opt.WorkWrap.
-
-Since we only compute one signature, we do so for arity 1. Computing multiple
-signatures for different arities (i.e., polyvariance) would be entirely
-possible, if it weren't for the additional runtime and implementation
-complexity.
-
-Note [idArity varies independently of dmdTypeDepth]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In general, an Id `f` has two independently varying attributes:
-
-* f's idArity, and
-* the dmdTypeDepth of f's demand signature
-
-For example, if f's demand signature is <L><L>, f's arity could be
-greater than, or less than 2. Why?  Because both are conservative
-approximations:
-
-* Arity n means "does no expensive work until applied to at least n args"
-  (e.g. (f x1..xm) is cheap to bring to HNF for m<n)
-
-* Dmd sig with n args means "here is how to transform the incoming demand
-  when applied to n args".  This is /semantic/ property, unrelated to
-  arity. See GHC.Types.Demand Note [Understanding DmdType and DmdSig]
-
-We used to check in GHC.Core.Lint that dmdTypeDepth <= idArity for a let-bound
-identifier. But that means we would have to zap demand signatures every time we
-reset or decrease arity.
-
-For example, consider the following expression:
-
-    (let go x y = `x` seq ... in go) |> co
-
-`go` might have a strictness signature of `<1L><L>`. The simplifier will identify
-`go` as a nullary join point through `joinPointBinding_maybe` and float the
-coercion into the binding, leading to an arity decrease:
-
-    join go = (\x y -> `x` seq ...) |> co in go
-
-With the CoreLint check, we would have to zap `go`'s perfectly viable strictness
-signature.
-
-However, in the case of a /bottoming/ signature, f : <L><L>b, we /can/
-say that f's arity is no greater than 2, because it'd be false to say
-that f does no work when applied to 3 args.  Lint checks this constraint,
-in `GHC.Core.Lint.lintLetBind`.
-
-Note [Demand analysis for trivial right-hand sides]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-    foo = plusInt |> co
-where plusInt is an arity-2 function with known strictness.  Clearly
-we want plusInt's strictness to propagate to foo!  But because it has
-no manifest lambdas, it won't do so automatically, and indeed 'co' might
-have type (Int->Int->Int) ~ T.
-
-Fortunately, GHC.Core.Opt.Arity gives 'foo' arity 2, which is enough for LetDown to
-forward plusInt's demand signature, and all is well (see Note [Newtype arity] in
-GHC.Core.Opt.Arity)! A small example is the test case NewtypeArity.
-
-Note [Absence analysis for stable unfoldings and RULES]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Ticket #18638 shows that it's really important to do absence analysis
-for stable unfoldings. Consider
-
-   g = blah
-
-   f = \x.  ...no use of g....
-   {- f's stable unfolding is f = \x. ...g... -}
-
-If f is ever inlined we use 'g'. But f's current RHS makes no use
-of 'g', so if we don't look at the unfolding we'll mark g as Absent,
-and transform to
-
-   g = error "Entered absent value"
-   f = \x. ...
-   {- f's stable unfolding is f = \x. ...g... -}
-
-Now if f is subsequently inlined, we'll use 'g' and ... disaster.
-
-SOLUTION: if f has a stable unfolding, adjust its DmdEnv (the demands
-on its free variables) so that no variable mentioned in its unfolding
-is Absent.  This is done by the function Demand.keepAliveDmdEnv.
-
-ALSO: do the same for Ids free in the RHS of any RULES for f.
-
-PS: You may wonder how it can be that f's optimised RHS has somehow
-discarded 'g', but when f is inlined we /don't/ discard g in the same
-way. I think a simple example is
-   g = (a,b)
-   f = \x.  fst g
-   {-# INLINE f #-}
-
-Now f's optimised RHS will be \x.a, but if we change g to (error "..")
-(since it is apparently Absent) and then inline (\x. fst g) we get
-disaster.  But regardless, #18638 was a more complicated version of
-this, that actually happened in practice.
-
-Note [DmdAnal for DataCon wrappers]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We give DataCon wrappers a (necessarily flat) demand signature in
-`GHC.Types.Id.Make.mkDataConRep`, so that passes such as the Simplifier can
-exploit it via the call to `GHC.Core.Opt.Simplify.Utils.isStrictArgInfo` in
-`GHC.Core.Opt.Simplify.Iteration.rebuildCall`. But during DmdAnal, we *ignore*
-the demand signature of a DataCon wrapper, and instead analyse its unfolding at
-every call site.
-
-The reason is that DataCon *worker*s have very precise demand transformers,
-computed by `dmdTransformDataConSig`. It would be awkward if DataCon *wrappers*
-would behave much less precisely during DmdAnal. Example:
-
-   data T1 = MkT1 { get_x1 :: Int,  get_y1 :: Int }
-   data T2 = MkT2 { get_x2 :: !Int, get_y2 :: Int }
-   f1 x y = get_x1 (MkT1 x y)
-   f2 x y = get_x2 (MkT2 x y)
-
-Here `MkT1` has no wrapper. `get_x1` puts a demand `!P(1!L,A)` on its argument,
-and `dmdTransformDataConSig` will transform that demand to an absent demand on
-`y` in `f1` and an unboxing demand on `x`.
-But `MkT2` has a wrapper (to evaluate the first field). If demand analysis deals
-with `MkT2` only through its demand signature, demand signatures can't transform
-an incoming demand `P(1!L,A)` in a useful way, so we won't get an absent demand
-on `y` in `f2` or see that `x` can be unboxed. That's a serious loss.
-
-The example above will not actually occur, because $WMkT2 would be inlined.
-Nevertheless, we can get interesting sub-demands on DataCon wrapper
-applications in boring contexts; see T22241.
-
-You might worry about the efficiency cost of demand-analysing datacon wrappers
-at every call site. But in fact they are inlined /anyway/ in the Final phase,
-which happens before DmdAnal, so few wrappers remain. And analysing the
-unfoldings for the remaining calls (which are those in a boring context) will be
-exactly as (in)efficent as if we'd inlined those calls. It turns out to be not
-measurable in practice.
-
-See also Note [CPR for DataCon wrappers] in `GHC.Core.Opt.CprAnal`.
-
-Note [Boxity for bottoming functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (A)
-    indexError :: Show a => (a, a) -> a -> String -> b
-    -- Str=<..><1!P(S,S)><1S><S>b
-    indexError rng i s = error (show rng ++ show i ++ show s)
-
-    get :: (Int, Int) -> Int -> [a] -> a
-    get p@(l,u) i xs
-      | l <= i, i < u = xs !! (i-u)
-      | otherwise     = indexError p i "get"
-
-The hot path of `get` certainly wants to unbox `p` as well as `l` and
-`u`, but the unimportant, diverging error path needs `l::a` and `u::a`
-boxed, since `indexError` can't unbox them because they are polymorphic.
-This pattern often occurs in performance sensitive code that does
-bounds-checking.
-
-So we want to give `indexError` a signature like `<1!P(!S,!S)><1!S><S!S>b`
-where the !S (meaning Poly Unboxed C1N) says that the polymorphic arguments
-are unboxed (recursively).  The wrapper for `indexError` won't /acutally/
-unbox them (because their polymorphic type doesn't allow that) but when
-demand-analysing /callers/, we'll behave as if that call needs the args
-unboxed.
-
-Then at call sites of `indexError`, we will end up doing some
-reboxing, because `$windexError` still takes boxed arguments. This
-reboxing should usually float into the slow, diverging code path; but
-sometimes (sadly) it doesn't: see Note [Reboxed crud for bottoming calls].
-
-Here is another important case (B):
-    f x = Just x  -- Suppose f is not inlined for some reason
-                  -- Main point: f takes its argument boxed
-
-    wombat x = error (show (f x))
-
-    g :: Bool -> Int -> a
-    g True  x = x+1
-    g False x = wombat x
-
-Again we want `wombat` to pretend to take its Int-typed argument unboxed,
-even though it has to pass it boxed to `f`, so that `g` can take its
-argument unboxed (and rebox it before calling `wombat`).
-
-So here's what we do: while summarising `indexError`'s boxity signature in
-`finaliseArgBoxities`:
-
-* To address (B), for bottoming functions, we start by using `unboxDeeplyDmd`
-  to make all its argument demands unboxed, right to the leaves; regardless
-  of what the analysis said.
-
-* To address (A), for bottoming functions, in the DontUnbox case when the
-  argument is a type variable, we /refrain/ from using trimBoxity.
-  (Remember the previous bullet: we have already doen `unboxDeeplyDmd`.)
-
-Wrinkle:
-
-* Remember Note [No lazy, Unboxed demands in demand signature]. So
-  unboxDeeplyDmd doesn't recurse into lazy demands.  It's extremely unusual
-  to have lazy demands in the arguments of a bottoming function anyway.
-  But it can happen, when the demand analyser gives up because it
-  encounters a recursive data type; see Note [Demand analysis for recursive
-  data constructors].
-
-Note [Reboxed crud for bottoming calls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For functions like `get` in Note [Boxity for bottoming functions], it's clear
-that the reboxed crud will be floated inside to the call site of `$windexError`.
-But here's an example where that is not the case:
-```hs
-import GHC.Ix
-
-theresCrud :: Int -> Int -> Int
-theresCrud x y = go x
-  where
-    go 0 = index (0,y) 0
-    go 1 = index (x,y) 1
-    go n = go (n-1)
-    {-# NOINLINE theresCrud #-}
-```
-If you look at the Core, you'll see that `y` will be reboxed and used in the
-two exit join points for the `$windexError` calls, while `x` is only reboxed in the
-exit join point for `index (x,y) 1` (happens in lvl below):
-```
-$wtheresCrud = \ ww ww1 ->
-      let { y = I# ww1 } in
-      join { lvl2 = ... case lvl1 ww y of wild { }; ... } in
-      join { lvl3 = ... case lvl y of wild { }; ... } in
-      ...
-```
-This is currently a bug that we willingly accept and it's documented in #21128.
-
-See also Note [indexError] in base:GHC.Ix, which describes how we use
-SPECIALISE to mitigate this problem for indexError.
--}
-
-{- *********************************************************************
-*                                                                      *
-             Finalising boxity
-*                                                                      *
-********************************************************************* -}
-
-{- Note [Finalising boxity for demand signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The worker/wrapper pass must strictly adhere to the boxity decisions
-encoded in the demand signature, because that is the information that
-demand analysis propagates throughout the program. Failing to
-implement the strategy laid out in the signature can result in
-reboxing in unexpected places. Hence, we must completely anticipate
-unboxing decisions during demand analysis and reflect these decisions
-in demand annotations. That is the job of 'finaliseArgBoxities',
-which is defined here and called from demand analysis.
-
-Here is a list of different Notes it has to take care of:
-
-  * Note [No lazy, Unboxed demands in demand signature] such as `L!P(L)` in
-    general, but still allow Note [Unboxing evaluated arguments]
-  * Note [No nested Unboxed inside Boxed in demand signature] such as `1P(1!L)`
-  * Note [mkWWstr and unsafeCoerce]
-
-NB: Then, the worker/wrapper blindly trusts the boxity info in the
-demand signature; that is why 'canUnboxArg' does not look at
-strictness -- it is redundant to do so.
-
-Note [Finalising boxity for let-bound Ids]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  let x = e in body
-where the demand on 'x' is 1!P(blah).  We want to unbox x according to
-Note [Thunk splitting] in GHC.Core.Opt.WorkWrap.  We must do this because
-worker/wrapper ignores strictness and looks only at boxity flags; so if
-x's demand is L!P(blah) we might still split it (wrongly).  We want to
-switch to Boxed on any lazy demand.
-
-That is what finaliseLetBoxity does.  It has no worker-arg budget, so it
-is much simpler than finaliseArgBoxities.
-
-Note [No nested Unboxed inside Boxed in demand signature]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-```
-f p@(x,y)
-  | even (x+y) = []
-  | otherwise  = [p]
-```
-Demand analysis will infer that the function body puts a demand of `1P(1!L,1!L)`
-on 'p', e.g., Boxed on the outside but Unboxed on the inside. But worker/wrapper
-can't unbox the pair components without unboxing the pair! So we better say
-`1P(1L,1L)` in the demand signature in order not to spread wrong Boxity info.
-That happens via the call to trimBoxity in 'finaliseArgBoxities'/'finaliseLetBoxity'.
-
-Note [No lazy, Unboxed demands in demand signature]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider T19407:
-
-  data Huge = Huge Bool () ... () -- think: DynFlags
-  data T = T { h :: Huge, n :: Int }
-  f t@(T h _) = g h t
-  g (H b _ ... _) t = if b then 1 else n t
-
-The body of `g` puts (approx.) demand `L!P(A,1)` on `t`. But we better
-not put that demand in `g`'s demand signature, because worker/wrapper will not
-in general unbox a lazy-and-unboxed demand like `L!P(..)`.
-(The exception are known-to-be-evaluated arguments like strict fields,
-see Note [Unboxing evaluated arguments].)
-
-The program above is an example where spreading misinformed boxity through the
-signature is particularly egregious. If we give `g` that signature, then `f`
-puts demand `S!P(1!P(1L,A,..),ML)` on `t`. Now we will unbox `t` in `f` it and
-we get
-
-  f (T (H b _ ... _) n) = $wf b n
-  $wf b n = $wg b (T (H b x ... x) n)
-  $wg = ...
-
-Massive reboxing in `$wf`! Solution: Trim boxity on lazy demands in
-'trimBoxity', modulo Note [Unboxing evaluated arguments].
-
-Note [Unboxing evaluated arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this program (due to Roman):
-
-    data X a = X !a
-
-    foo :: X Int -> Int -> Int
-    foo x@(X a) n = go 0
-     where
-       go i | i < n     = a + go (i+1)
-            | otherwise = 0
-
-We want the worker for 'foo' to look like this:
-
-    $wfoo :: Int# -> Int# -> Int#
-
-with the first argument unboxed, so that it is not eval'd each time around the
-'go' loop (which would otherwise happen, since 'foo' is not strict in 'a'). It
-is sound for the wrapper to pass an unboxed arg because X is strict
-(see Note [Strictness and Unboxing] in "GHC.Core.Opt.DmdAnal"), so its argument
-must be evaluated. And if we *don't* pass an unboxed argument, we can't even
-repair it by adding a `seq` thus:
-
-    foo (X a) n = a `seq` go 0
-
-because the seq is discarded (very early) since X is strict!
-
-So here's what we do
-
-* Since this has nothing to do with how 'foo' uses 'a', we leave demand
-  analysis alone, but account for the additional evaluatedness when
-  annotating the binder 'finaliseArgBoxities', which will retain the Unboxed
-  boxity on 'a' in the definition of 'foo' in the demand 'L!P(L)'; meaning
-  it's used lazily but unboxed nonetheless. This seems to contradict Note
-  [No lazy, Unboxed demands in demand signature], but we know that 'a' is
-  evaluated and thus can be unboxed.
-
-* When 'finaliseArgBoxities' decides to unbox a record, it will zip the field demands
-  together with the respective 'StrictnessMark'. In case of 'x', it will pair
-  up the lazy field demand 'L!P(L)' on 'a' with 'MarkedStrict' to account for
-  the strict field.
-
-* Said 'StrictnessMark' is passed to the recursive invocation of 'go_args' in
-  'finaliseArgBoxities' when deciding whether to unbox 'a'. 'a' was used lazily, but
-  since it also says 'MarkedStrict', we'll retain the 'Unboxed' boxity on 'a'.
-
-* Worker/wrapper will consult 'canUnboxArg' for its unboxing decision. It will
-  /not/ look at the strictness bits of the demand, only at Boxity flags. As such,
-  it will happily unbox 'a' despite the lazy demand on it.
-
-The net effect is that boxity analysis and the w/w transformation are more
-aggressive about unboxing the strict arguments of a data constructor than when
-looking at strictness info exclusively. It is very much like (Nested) CPR, which
-needs its nested fields to be evaluated in order for it to unbox nestedly.
-
-There is the usual danger of reboxing, which as usual we ignore. But
-if X is monomorphic, and has an UNPACK pragma, then this optimisation
-is even more important.  We don't want the wrapper to rebox an unboxed
-argument, and pass an Int to $wfoo!
-
-This works in nested situations like T10482
-
-    data family Bar a
-    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
-    newtype instance Bar Int = Bar Int
-
-    foo :: Bar ((Int, Int), Int) -> Int -> Int
-    foo f k = case f of BarPair x y ->
-              case burble of
-                 True -> case x of
-                           BarPair p q -> ...
-                 False -> ...
-
-The extra eagerness lets us produce a worker of type:
-     $wfoo :: Int# -> Int# -> Int# -> Int -> Int
-     $wfoo p# q# y# = ...
-
-even though the `case x` is only lazily evaluated.
-
---------- Historical note ------------
-We used to add data-con strictness demands when demand analysing case
-expression. However, it was noticed in #15696 that this misses some cases. For
-instance, consider the program (from T10482)
-
-    data family Bar a
-    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
-    newtype instance Bar Int = Bar Int
-
-    foo :: Bar ((Int, Int), Int) -> Int -> Int
-    foo f k =
-      case f of
-        BarPair x y -> case burble of
-                          True -> case x of
-                                    BarPair p q -> ...
-                          False -> ...
-
-We really should be able to assume that `p` is already evaluated since it came
-from a strict field of BarPair. This strictness would allow us to produce a
-worker of type:
-
-    $wfoo :: Int# -> Int# -> Int# -> Int -> Int
-    $wfoo p# q# y# = ...
-
-even though the `case x` is only lazily evaluated
-
-Indeed before we fixed #15696 this would happen since we would float the inner
-`case x` through the `case burble` to get:
-
-    foo f k =
-      case f of
-        BarPair x y -> case x of
-                          BarPair p q -> case burble of
-                                          True -> ...
-                                          False -> ...
-
-However, after fixing #15696 this could no longer happen (for the reasons
-discussed in ticket:15696#comment:76). This means that the demand placed on `f`
-would then be significantly weaker (since the False branch of the case on
-`burble` is not strict in `p` or `q`).
-
-Consequently, we now instead account for data-con strictness in mkWWstr_one,
-applying the strictness demands to the final result of DmdAnal. The result is
-that we get the strict demand signature we wanted even if we can't float
-the case on `x` up through the case on `burble`.
-
-Note [Do not unbox class dictionaries]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We never unbox class dictionaries in worker/wrapper.
-
-1. INLINABLE functions
-   If we have
-      f :: Ord a => [a] -> Int -> a
-      {-# INLINABLE f #-}
-   and we worker/wrapper f, we'll get a worker with an INLINABLE pragma
-   (see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),
-   which can still be specialised by the type-class specialiser, something like
-      fw :: Ord a => [a] -> Int# -> a
-
-   BUT if f is strict in the Ord dictionary, we might unpack it, to get
-      fw :: (a->a->Bool) -> [a] -> Int# -> a
-   and the type-class specialiser can't specialise that. An example is #6056.
-
-   Historical note: #14955 describes how I got this fix wrong the first time.
-   I got aware of the issue in T5075 by the change in boxity of loop between
-   demand analysis runs.
-
-2. -fspecialise-aggressively.  As #21286 shows, the same phenomenon can occur
-   occur without INLINABLE, when we use -fexpose-all-unfoldings and
-   -fspecialise-aggressively to do vigorous cross-module specialisation.
-
-TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing
-a raft of higher-order functions isn't a huge win anyway -- you really want to
-specialise the function.
-
-Note [Worker argument budget]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In 'finaliseArgBoxities' we don't want to generate workers with zillions of
-argument when, say given a strict record with zillions of fields.  So we
-limit the maximum number of worker args ('max_wkr_args') to the maximum of
-  - -fmax-worker-args=N
-  - The number of args in the original function; if it already has has
-    zillions of arguments we don't want to seek /fewer/ args in the worker.
-(Maybe we should /add/ them instead of maxing?)
-
-We pursue a "layered" strategy for unboxing: we unbox the top level of the
-argument(s), subject to budget; if there are any arguments left we unbox the
-next layer, using that depleted budget.
-Unboxing an argument *increases* the budget for the inner layer roughly
-according to how many registers that argument takes (unboxed tuples take
-multiple registers, see below), as determined by 'unariseArity'.
-Budget is spent when we have to pass a non-absent field as a parameter.
-
-To achieve this, we use the classic almost-circular programming technique in
-which we we write one pass that takes a lazy list of the Budgets for every
-layer. The effect is that of a breadth-first search (over argument type and
-demand structure) to compute Budgets followed by a depth-first search to
-construct the product demands, but laziness allows us to do it all in one
-pass and without intermediate data structures.
-
-Suppose we have -fmax-worker-args=4 for the remainder of this Note.
-Then consider this example function:
-
-  boxed :: (Int, Int) -> (Int, (Int, Int, Int)) -> Int
-  boxed (a,b) (c, (d,e,f)) = a + b + c + d + e + f
-
-With a budget of 4 args to spend (number of args is only 2), we'd be served well
-to unbox both pairs, but not the triple. Indeed, that is what the algorithm
-computes, and the following pictogram shows how the budget layers are computed.
-Each layer is started with `n ~>`, where `n` is the budget at the start of the
-layer. We write -n~> when we spend budget (and n is the remaining budget) and
-+n~> when we earn budget. We separate unboxed args with ][ and indicate
-inner budget threads becoming negative in braces {{}}, so that we see which
-unboxing decision we do *not* commit to. Without further ado:
-
-  4 ~> ][     (a,b) -3~>               ][     (c, ...) -2~>
-       ][      | |                     ][      |   |
-       ][      | +-------------+       ][      |   +-----------------+
-       ][      |               |       ][      |                     |
-       ][      v               v       ][      v                     v
-  2 ~> ][ +3~> a  -2~> ][      b  -1~> ][ +2~> c  -1~> ][        (d, e, f) -0~>
-       ][      |       ][      |       ][      |       ][ {{      |  |  |                          }}
-       ][      |       ][      |       ][      |       ][ {{      |  |  +----------------+         }}
-       ][      v       ][      v       ][      v       ][ {{      v  +------v            v         }}
-  0 ~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ {{ +1~> d -0~> ][ e -(-1)~> ][ f -(-2)~> }}
-
-Unboxing increments the budget we have on the next layer (because we don't need
-to retain the boxed arg), but in turn the inner layer must afford to retain all
-non-absent fields, each decrementing the budget. Note how the budget becomes
-negative when trying to unbox the triple and the unboxing decision is "rolled
-back". This is done by the 'positiveTopBudget' guard.
-
-There's a bit of complication as a result of handling unboxed tuples correctly;
-specifically, handling nested unboxed tuples. Consider (#21737)
-
-  unboxed :: (Int, Int) -> (# Int, (# Int, Int, Int #) #) -> Int
-  unboxed (a,b) (# c, (# d, e, f #) #) = a + b + c + d + e + f
-
-Recall that unboxed tuples will be flattened to individual arguments during
-unarisation. Here, `unboxed` will have 5 arguments at runtime because of the
-nested unboxed tuple, which will be flattened to 4 args. So it's best to leave
-`(a,b)` boxed (because we already are above our arg threshold), but unbox `c`
-through `f` because that doesn't increase the number of args post unarisation.
-
-Note that the challenge is that syntactically, `(# d, e, f #)` occurs in a
-deeper layer than `(a, b)`. Treating unboxed tuples as a regular data type, we'd
-make the same unboxing decisions as for `boxed` above; although our starting
-budget is 5 (Here, the number of args is greater than -fmax-worker-args), it's
-not enough to unbox the triple (we'd finish with budget -1). So we'd unbox `a`
-through `c`, but not `d` through `f`, which is silly, because then we'd end up
-having 6 arguments at runtime, of which `d` through `f` weren't unboxed.
-
-Hence we pretend that the fields of unboxed tuples appear in the same budget
-layer as the tuple itself. For example at the top-level, `(# x,y #)` is to be
-treated just like two arguments `x` and `y`.
-Of course, for that to work, our budget calculations must initialise
-'max_wkr_args' to 5, based on the 'unariseArity' of each Core arg: That would be
-1 for the pair and 4 for the unboxed pair. Then when we decide whether to unbox
-the unboxed pair, we *directly* recurse into the fields, spending our budget
-on retaining `c` and (after recursing once more) `d` through `f` as arguments,
-depleting our budget completely in the first layer. Pictorially:
-
-  5 ~> ][         (a,b) -4~>             ][         (# c, ... #)
-       ][ {{      | |                 }} ][      c  -3~> ][ (# d, e, f #)
-       ][ {{      | +-------+         }} ][      |       ][      d  -2~> ][      e  -1~> ][      f  -0~>
-       ][ {{      |         |         }} ][      |       ][      |       ][      |       ][      |
-       ][ {{      v         v         }} ][      v       ][      v       ][      v       ][      v
-  0 ~> ][ {{ +1~> a -0~> ][ b -(-1)~> }} ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~>
-
-As you can see, we have no budget left to justify unboxing `(a,b)` on the second
-layer, which is good, because it would increase the number of args. Also note
-that we can still unbox `c` through `f` in this layer, because doing so has a
-net zero effect on budget.
-
-Note [The OPAQUE pragma and avoiding the reboxing of arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In https://gitlab.haskell.org/ghc/ghc/-/issues/13143 it was identified that when
-a function 'f' with a NOINLINE pragma is W/W transformed, then the worker for
-'f' should get the NOINLINE annotation, while the wrapper /should/ be inlined.
-
-That's because if the wrapper for 'f' had stayed NOINLINE, then any worker of a
-W/W-transformed /caller of/ 'f' would immediately rebox any unboxed arguments
-that is applied to the wrapper of 'f'. When the wrapper is inlined, that kind of
-reboxing does not happen.
-
-But now we have functions with OPAQUE pragmas, which by definition (See Note
-[OPAQUE pragma]) do not get W/W-transformed. So in order to avoid reboxing
-workers of any W/W-transformed /callers of/ 'f' we need to strip all boxity
-information from 'f' in the demand analysis. This will inform the
-W/W-transformation code that boxed arguments of 'f' must definitely be passed
-along in boxed form and as such dissuade the creation of reboxing workers.
--}
-
--- | How many registers does this type take after unarisation?
-unariseArity :: Type -> Arity
-unariseArity ty = length (typePrimRep ty)
-
-data Budgets = MkB !Arity Budgets   -- An infinite list of arity budgets
-
-earnTopBudget :: Budgets -> Budgets
-earnTopBudget (MkB n bg) = MkB (n+1) bg
-
-spendTopBudget :: Arity -> Budgets -> Budgets
-spendTopBudget m (MkB n bg) = MkB (n-m) bg
-
-positiveTopBudget :: Budgets -> Bool
-positiveTopBudget (MkB n _) = n >= 0
-
-finaliseArgBoxities :: AnalEnv -> Id -> Arity -> CoreExpr -> Divergence
-                    -> Maybe ([Demand], CoreExpr)
-finaliseArgBoxities env fn arity rhs div
-  | arity > count isId bndrs  -- Can't find enough binders
-  = Nothing  -- This happens if we have   f = g
-             -- Then there are no binders; we don't worker/wrapper; and we
-             -- simply want to give f the same demand signature as g
-
-  | otherwise -- NB: arity is the threshold_arity, which might be less than
-              -- manifest arity for join points
-  = -- pprTrace "finaliseArgBoxities" (
-    --   vcat [text "function:" <+> ppr fn
-    --        , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs))
-    --        , text "dmds after: " <+>  ppr arg_dmds' ]) $
-    Just (arg_dmds', add_demands arg_dmds' rhs)
-    -- add_demands: we must attach the final boxities to the lambda-binders
-    -- of the function, both because that's kosher, and because CPR analysis
-    -- uses the info on the binders directly.
-  where
-    opts            = ae_opts env
-    (bndrs, _body)  = collectBinders rhs
-    unarise_arity   = sum [ unariseArity (idType b) | b <- bndrs, isId b ]
-    max_wkr_args    = dmd_max_worker_args opts `max` unarise_arity
-                      -- This is the budget initialisation step of
-                      -- Note [Worker argument budget]
-
-    -- This is the key line, which uses almost-circular programming
-    -- The remaining budget from one layer becomes the initial
-    -- budget for the next layer down.  See Note [Worker argument budget]
-    (remaining_budget, arg_dmds') = go_args (MkB max_wkr_args remaining_budget) arg_triples
-
-    arg_triples :: [(Type, StrictnessMark, Demand)]
-    arg_triples = take arity $
-                  [ (bndr_ty, NotMarkedStrict, get_dmd bndr bndr_ty)
-                  | bndr <- bndrs
-                  , isRuntimeVar bndr, let bndr_ty = idType bndr ]
-
-    get_dmd :: Id -> Type -> Demand
-    get_dmd bndr bndr_ty
-      | isClassPred bndr_ty = trimBoxity dmd
-        -- See Note [Do not unbox class dictionaries]
-        -- NB: 'ty' has not been normalised, so this will (rightly)
-        --     catch newtype dictionaries too.
-        -- NB: even for bottoming functions, don't unbox dictionaries
-
-      | is_bot_fn = unboxDeeplyDmd dmd
-        -- See Note [Boxity for bottoming functions], case (B)
-
-      | is_opaque = trimBoxity dmd
-        -- See Note [OPAQUE pragma]
-        -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]
-
-      | otherwise = dmd
-      where
-        dmd       = idDemandInfo bndr
-        is_opaque = isOpaquePragma (idInlinePragma fn)
-
-    -- is_bot_fn:  see Note [Boxity for bottoming functions]
-    is_bot_fn = div == botDiv
-
-    go_args :: Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand])
-    go_args bg triples = mapAccumL go_arg bg triples
-
-    go_arg :: Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand)
-    go_arg bg@(MkB bg_top bg_inner) (ty, str_mark, dmd@(n :* _))
-      = case wantToUnboxArg env ty str_mark dmd of
-          DropAbsent -> (bg, dmd)
-
-          DontUnbox | is_bot_fn, isTyVarTy ty -> (retain_budget, dmd)
-                    | otherwise               -> (retain_budget, trimBoxity dmd)
-            -- If bot: Keep deep boxity even though WW won't unbox
-            -- See Note [Boxity for bottoming functions] case (A)
-            -- trimBoxity: see Note [No lazy, Unboxed demands in demand signature]
-            where
-              retain_budget = spendTopBudget (unariseArity ty) bg
-                -- spendTopBudget: spend from our budget the cost of the
-                -- retaining the arg
-                -- The unboxed case does happen here, for example
-                --   app g x = g x :: (# Int, Int #)
-                -- here, `x` is used `L`azy and thus Boxed
-
-          DoUnbox triples
-            | isUnboxedTupleType ty
-            , (bg', dmds') <- go_args bg triples
-            -> (bg', n :* (mkProd Unboxed $! dmds'))
-                     -- See Note [Worker argument budget]
-                     -- unboxed tuples are always unboxed, deeply
-                     -- NB: Recurse with bg, *not* bg_inner! The unboxed fields
-                     -- are at the same budget layer.
-
-            | isUnboxedSumType ty
-            -> pprPanic "Unboxing through unboxed sum" (ppr fn <+> ppr ty)
-                     -- We currently don't return DoUnbox for unboxed sums.
-                     -- But hopefully we will at some point. When that happens,
-                     -- it would still be impossible to predict the effect
-                     -- of dropping absent fields and unboxing others on the
-                     -- unariseArity of the sum without losing sanity.
-                     -- We could overwrite bg_top with the one from
-                     -- retain_budget while still unboxing inside the alts as in
-                     -- the tuple case for a conservative solution, though.
-
-            | otherwise
-            -> (spendTopBudget 1 (MkB bg_top final_bg_inner), final_dmd)
-            where
-              (bg_inner', dmds') = go_args (earnTopBudget bg_inner) triples
-                     -- earnTopBudget: give back the cost of retaining the
-                     -- arg we are insted unboxing.
-              dmd' = n :* (mkProd Unboxed $! dmds')
-              ~(final_bg_inner, final_dmd) -- "~": This match *must* be lazy!
-                 | positiveTopBudget bg_inner' = (bg_inner', dmd')
-                 | otherwise                   = (bg_inner,  trimBoxity dmd)
-
-    add_demands :: [Demand] -> CoreExpr -> CoreExpr
-    -- Attach the demands to the outer lambdas of this expression
-    add_demands [] e = e
-    add_demands (dmd:dmds) (Lam v e)
-      | isTyVar v = Lam v (add_demands (dmd:dmds) e)
-      | otherwise = Lam (v `setIdDemandInfo` dmd) (add_demands dmds e)
-    add_demands dmds e = pprPanic "add_demands" (ppr dmds $$ ppr e)
-
-finaliseLetBoxity
-  :: AnalEnv
-  -> Type                   -- ^ Type of the let-bound Id
-  -> Demand                 -- ^ How the Id is used
-  -> Demand
--- See Note [Finalising boxity for let-bound Ids]
--- This function is like finaliseArgBoxities, but much simpler because
--- it has no "budget".  It simply unboxes strict demands, and stops
--- when it reaches a lazy one.
-finaliseLetBoxity env ty dmd
-  = go (ty, NotMarkedStrict, dmd)
-  where
-    go :: (Type,StrictnessMark,Demand) -> Demand
-    go (ty, str, dmd@(n :* _)) =
-      case wantToUnboxArg env ty str dmd of
-        DropAbsent      -> dmd
-        DontUnbox       -> trimBoxity dmd
-        DoUnbox triples -> n :* (mkProd Unboxed $! map go triples)
-
-wantToUnboxArg :: AnalEnv -> Type -> StrictnessMark -> Demand
-               -> UnboxingDecision [(Type, StrictnessMark, Demand)]
-wantToUnboxArg env ty str_mark dmd@(n :* _)
-  = case canUnboxArg (ae_fam_envs env) ty dmd of
-      DropAbsent -> DropAbsent
-      DontUnbox  -> DontUnbox
-
-      DoUnbox (DataConPatContext{ dcpc_dc      = dc
-                                , dcpc_tc_args = tc_args
-                                , dcpc_args    = dmds })
-       -- OK, so we /can/ unbox it; but do we /want/ to?
-       | not (isStrict n || isMarkedStrict str_mark)   -- Don't unbox a lazy field
-         -- isMarkedStrict: see Note [Unboxing evaluated arguments] in DmdAnal
-       -> DontUnbox
-
-       | DefinitelyRecursive <- ae_rec_dc env dc
-         -- See Note [Which types are unboxed?]
-         -- and Note [Demand analysis for recursive data constructors]
-       -> DontUnbox
-
-       | otherwise  -- Bad cases dealt with: we want to unbox!
-       -> DoUnbox (zip3 (dubiousDataConInstArgTys dc tc_args)
-                        (dataConRepStrictness dc)
-                        dmds)
-
-{- *********************************************************************
-*                                                                      *
-                      Fixpoints
-*                                                                      *
-********************************************************************* -}
-
--- Recursive bindings
-dmdFix :: TopLevelFlag
-       -> AnalEnv                            -- Does not include bindings for this binding
-       -> SubDemand
-       -> [(Id,CoreExpr)]
-       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info
-
-dmdFix top_lvl env let_dmd orig_pairs
-  = loop 1 initial_pairs
-  where
-    opts = ae_opts env
-    -- See Note [Initialising strictness]
-    initial_pairs | ae_virgin env = [(setIdDmdAndBoxSig opts id botSig, rhs) | (id, rhs) <- orig_pairs ]
-                  | otherwise     = orig_pairs
-
-    -- If fixed-point iteration does not yield a result we use this instead
-    -- See Note [Safe abortion in the fixed-point iteration]
-    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])
-    abort = (env, lazy_fv', zapped_pairs)
-      where (lazy_fv, pairs') = step True (zapIdDmdSig orig_pairs)
-            -- Note [Lazy and unleashable free variables]
-            non_lazy_fvs = plusVarEnvList $ map (dmdSigDmdEnv . idDmdSig . fst) pairs'
-            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs
-            zapped_pairs = zapIdDmdSig pairs'
-
-    -- The fixed-point varies the idDmdSig field of the binders, and terminates if that
-    -- annotation does not change any more.
-    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
-    loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id)
-                   --                                   | (id,_) <- pairs]) $
-                   loop' n pairs
-
-    loop' n pairs
-      | found_fixpoint = (final_anal_env, lazy_fv, pairs')
-      | n == 10        = abort
-      | otherwise      = loop (n+1) pairs'
-      where
-        found_fixpoint    = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs
-        first_round       = n == 1
-        (lazy_fv, pairs') = step first_round pairs
-        final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')
-
-    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])
-    step first_round pairs = (lazy_fv, pairs')
-      where
-        -- In all but the first iteration, delete the virgin flag
-        start_env | first_round = env
-                  | otherwise   = nonVirgin env
-
-        start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv)
-
-        !((_,!lazy_fv), !pairs') = mapAccumL my_downRhs start pairs
-                -- mapAccumL: Use the new signature to do the next pair
-                -- The occurrence analyser has arranged them in a good order
-                -- so this can significantly reduce the number of iterations needed
-
-        my_downRhs (env, lazy_fv) (id,rhs)
-          = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $
-            ((env', lazy_fv'), (id', rhs'))
-          where
-            !(!env', !lazy_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs
-            !lazy_fv'                    = plusVarEnv_C plusDmd lazy_fv lazy_fv1
-
-    zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
-    zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ]
-
-{- Note [Safe abortion in the fixed-point iteration]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Fixed-point iteration may fail to terminate. But we cannot simply give up and
-return the environment and code unchanged! We still need to do one additional
-round, for two reasons:
-
- * To get information on used free variables (both lazy and strict!)
-   (see Note [Lazy and unleashable free variables])
- * To ensure that all expressions have been traversed at least once, and any left-over
-   strictness annotations have been updated.
-
-This final iteration does not add the variables to the strictness signature
-environment, which effectively assigns them 'nopSig' (see "getStrictness")
-
-Note [Trimming a demand to a type]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are two reasons we sometimes trim a demand to match a type.
-  1. GADTs
-  2. Recursive products and widening
-
-More on both below.  But the bottom line is: we really don't want to
-have a binder whose demand is more deeply-nested than its type
-"allows". So in findBndrDmd we call trimToType and findTypeShape to
-trim the demand on the binder to a form that matches the type
-
-Now to the reasons. For (1) consider
-  f :: a -> Bool
-  f x = case ... of
-          A g1 -> case (x |> g1) of (p,q) -> ...
-          B    -> error "urk"
-
-where A,B are the constructors of a GADT.  We'll get a 1P(L,L) demand
-on x from the A branch, but that's a stupid demand for x itself, which
-has type 'a'. Indeed we get ASSERTs going off (notably in
-splitUseProdDmd, #8569).
-
-For (2) consider
-  data T = MkT Int T    -- A recursive product
-  f :: Int -> T -> Int
-  f 0 _         = 0
-  f _ (MkT n t) = f n t
-
-Here f is lazy in T, but its *usage* is infinite: P(L,P(L,P(L, ...))).
-Notice that this happens because T is a product type, and is recursive.
-If we are not careful, we'll fail to iterate to a fixpoint in dmdFix,
-and bale out entirely, which is inefficient and over-conservative.
-
-Worse, as we discovered in #18304, the size of the usages we compute
-can grow /exponentially/, so even 10 iterations costs far too much.
-Especially since we then discard the result.
-
-To avoid this we use the same findTypeShape function as for (1), but
-arrange that it trims the demand if it encounters the same type constructor
-twice (or three times, etc).  We use our standard RecTcChecker mechanism
-for this -- see GHC.Core.Opt.WorkWrap.Utils.findTypeShape.
-
-This is usually call "widening".  We could do it just in dmdFix, but
-since are doing this findTypeShape business /anyway/ because of (1),
-and it has all the right information to hand, it's extremely
-convenient to do it there.
-
--}
-
-{- *********************************************************************
-*                                                                      *
-                 Strictness signatures and types
-*                                                                      *
-********************************************************************* -}
-
-unitDmdType :: DmdEnv -> DmdType
-unitDmdType dmd_env = DmdType dmd_env [] topDiv
-
-coercionDmdEnv :: Coercion -> DmdEnv
-coercionDmdEnv co = coercionsDmdEnv [co]
-
-coercionsDmdEnv :: [Coercion] -> DmdEnv
-coercionsDmdEnv cos = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCos cos)
-                      -- The VarSet from coVarsOfCos is really a VarEnv Var
-
-addVarDmd :: DmdType -> Var -> Demand -> DmdType
-addVarDmd (DmdType fv ds res) var dmd
-  = DmdType (extendVarEnv_C plusDmd fv var dmd) ds res
-
-addLazyFVs :: DmdType -> DmdEnv -> DmdType
-addLazyFVs dmd_ty lazy_fvs
-  = dmd_ty `plusDmdType` mkPlusDmdArg lazy_fvs
-        -- Using plusDmdType (rather than just plus'ing the envs)
-        -- is vital.  Consider
-        --      let f = \x -> (x,y)
-        --      in  error (f 3)
-        -- Here, y is treated as a lazy-fv of f, but we must `plusDmd` that L
-        -- demand with the bottom coming up from 'error'
-        --
-        -- I got a loop in the fixpointer without this, due to an interaction
-        -- with the lazy_fv filtering in dmdAnalRhsSig.  Roughly, it was
-        --      letrec f n x
-        --          = letrec g y = x `fatbar`
-        --                         letrec h z = z + ...g...
-        --                         in h (f (n-1) x)
-        --      in ...
-        -- In the initial iteration for f, f=Bot
-        -- Suppose h is found to be strict in z, but the occurrence of g in its RHS
-        -- is lazy.  Now consider the fixpoint iteration for g, esp the demands it
-        -- places on its free variables.  Suppose it places none.  Then the
-        --      x `fatbar` ...call to h...
-        -- will give a x->V demand for x.  That turns into a L demand for x,
-        -- which floats out of the defn for h.  Without the modifyEnv, that
-        -- L demand doesn't get both'd with the Bot coming up from the inner
-        -- call to f.  So we just get an L demand for x for g.
-
-{-
-Note [Do not strictify the argument dictionaries of a dfun]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The typechecker can tie recursive knots involving dfuns, so we do the
-conservative thing and refrain from strictifying a dfun's argument
-dictionaries.
--}
-
-setBndrsDemandInfo :: HasCallStack => [Var] -> [Demand] -> [Var]
-setBndrsDemandInfo (b:bs) ds
-  | isTyVar b = b : setBndrsDemandInfo bs ds
-setBndrsDemandInfo (b:bs) (d:ds) =
-    let !new_info = setIdDemandInfo b d
-        !vars = setBndrsDemandInfo bs ds
-    in new_info : vars
-setBndrsDemandInfo [] ds = assert (null ds) []
-setBndrsDemandInfo bs _  = pprPanic "setBndrsDemandInfo" (ppr bs)
-
-annotateLamIdBndr :: AnalEnv
-                  -> DmdType    -- Demand type of body
-                  -> Id         -- Lambda binder
-                  -> WithDmdType Id  -- Demand type of lambda
-                                     -- and binder annotated with demand
-
-annotateLamIdBndr env dmd_ty id
--- For lambdas we add the demand to the argument demands
--- Only called for Ids
-  = assert (isId id) $
-    -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $
-    WithDmdType main_ty new_id
-  where
-    new_id  = setIdDemandInfo id dmd
-    main_ty = addDemand dmd dmd_ty'
-    WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id
-
-{- Note [NOINLINE and strictness]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-At one point we disabled strictness for NOINLINE functions, on the
-grounds that they should be entirely opaque.  But that lost lots of
-useful semantic strictness information, so now we analyse them like
-any other function, and pin strictness information on them.
-
-That in turn forces us to worker/wrapper them; see
-Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.
-
-
-Note [Lazy and unleashable free variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We put the strict and once-used FVs in the DmdType of the Id, so
-that at its call sites we unleash demands on its strict fvs.
-An example is 'roll' in imaginary/wheel-sieve2
-Something like this:
-        roll x = letrec
-                     go y = if ... then roll (x-1) else x+1
-                 in
-                 go ms
-We want to see that roll is strict in x, which is because
-go is called.   So we put the DmdEnv for x in go's DmdType.
-
-Another example:
-
-        f :: Int -> Int -> Int
-        f x y = let t = x+1
-            h z = if z==0 then t else
-                  if z==1 then x+1 else
-                  x + h (z-1)
-        in h y
-
-Calling h does indeed evaluate x, but we can only see
-that if we unleash a demand on x at the call site for t.
-
-Incidentally, here's a place where lambda-lifting h would
-lose the cigar --- we couldn't see the joint strictness in t/x
-
-        ON THE OTHER HAND
-
-We don't want to put *all* the fv's from the RHS into the
-DmdType. Because
-
- * it makes the strictness signatures larger, and hence slows down fixpointing
-
-and
-
- * it is useless information at the call site anyways:
-   For lazy, used-many times fv's we will never get any better result than
-   that, no matter how good the actual demand on the function at the call site
-   is (unless it is always absent, but then the whole binder is useless).
-
-Therefore we exclude lazy multiple-used fv's from the environment in the
-DmdType.
-
-But now the signature lies! (Missing variables are assumed to be absent.) To
-make up for this, the code that analyses the binding keeps the demand on those
-variable separate (usually called "lazy_fv") and adds it to the demand of the
-whole binding later.
-
-What if we decide _not_ to store a strictness signature for a binding at all, as
-we do when aborting a fixed-point iteration? The we risk losing the information
-that the strict variables are being used. In that case, we take all free variables
-mentioned in the (unsound) strictness signature, conservatively approximate the
-demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".
-
-
-************************************************************************
-*                                                                      *
-\subsection{Strictness signatures}
-*                                                                      *
-************************************************************************
--}
-
-
-data AnalEnv = AE
-  { ae_opts      :: !DmdAnalOpts
-  -- ^ Analysis options
-  , ae_sigs      :: !SigEnv
-  , ae_virgin    :: !Bool
-  -- ^ True on first iteration only. See Note [Initialising strictness]
-  , ae_fam_envs  :: !FamInstEnvs
-  , ae_rec_dc    :: DataCon -> IsRecDataConResult
-  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'
-  }
-
-        -- We use the se_env to tell us whether to
-        -- record info about a variable in the DmdEnv
-        -- We do so if it's a LocalId, but not top-level
-        --
-        -- The DmdEnv gives the demand on the free vars of the function
-        -- when it is given enough args to satisfy the strictness signature
-
-type SigEnv = VarEnv (DmdSig, TopLevelFlag)
-
-instance Outputable AnalEnv where
-  ppr env = text "AE" <+> braces (vcat
-         [ text "ae_virgin =" <+> ppr (ae_virgin env)
-         , text "ae_sigs =" <+> ppr (ae_sigs env)
-         ])
-
-emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv
-emptyAnalEnv opts fam_envs
-    = AE { ae_opts         = opts
-         , ae_sigs         = emptySigEnv
-         , ae_virgin       = True
-         , ae_fam_envs     = fam_envs
-         , ae_rec_dc       = memoiseUniqueFun (isRecDataCon fam_envs 3)
-         }
-
-emptySigEnv :: SigEnv
-emptySigEnv = emptyVarEnv
-
--- | Extend an environment with the strictness IDs attached to the id
-extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
-extendAnalEnvs top_lvl env vars
-  = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }
-
-extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv
-extendSigEnvs top_lvl sigs vars
-  = extendVarEnvList sigs [ (var, (idDmdSig var, top_lvl)) | var <- vars]
-
-extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv
-extendAnalEnv top_lvl env var sig
-  = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig }
-
-extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> DmdSig -> SigEnv
-extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)
-
-lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag)
-lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
-
-nonVirgin :: AnalEnv -> AnalEnv
-nonVirgin env = env { ae_virgin = False }
-
-findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand]
--- Return the demands on the Ids in the [Var]
-findBndrsDmds env dmd_ty bndrs
-  = go dmd_ty bndrs
-  where
-    go dmd_ty []  = WithDmdType dmd_ty []
-    go dmd_ty (b:bs)
-      | isId b    = let WithDmdType dmd_ty1 dmds = go dmd_ty bs
-                        WithDmdType dmd_ty2 dmd  = findBndrDmd env dmd_ty1 b
-                    in WithDmdType dmd_ty2  (dmd : dmds)
-      | otherwise = go dmd_ty bs
-
-findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand
--- See Note [Trimming a demand to a type]
-findBndrDmd env dmd_ty id
-  = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $
-    WithDmdType dmd_ty' dmd'
-  where
-    dmd' = strictify $
-           trimToType starting_dmd (findTypeShape fam_envs id_ty)
-
-    (dmd_ty', starting_dmd) = peelFV dmd_ty id
-
-    id_ty = idType id
-
-    strictify dmd
-      -- See Note [Making dictionaries strict]
-      | dmd_strict_dicts (ae_opts env)
-             -- We never want to strictify a recursive let. At the moment
-             -- findBndrDmd is never called for recursive lets; if that
-             -- changes, we need a RecFlag parameter and another guard here.
-      = strictifyDictDmd id_ty dmd
-      | otherwise
-      = dmd
-
-    fam_envs = ae_fam_envs env
-
-{- Note [Making dictionaries strict]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries.  Why?
-
-* Generally CBV is more efficient.
-
-* Dictionaries are always non-bottom; and never take much work to
-  compute.  E.g. a dfun from an instance decl always returns a dictionary
-  record immediately.  See DFunUnfolding in CoreSyn.
-  See also Note [Recursive superclasses] in TcInstDcls.
-
-* The strictness analyser will then unbox dictionaries and pass the
-  methods individually, rather than in a bundle.  If there are a lot of
-  methods that might be bad; but worker/wrapper already does throttling.
-
-* A newtype dictionary is *not* always non-bottom.  E.g.
-      class C a where op :: a -> a
-      instance C Int where op = error "urk"
-  Now a value of type (C Int) is just a newtype wrapper (a cast) around
-  the error thunk.  Don't strictify these!
-
-See #17758 for more background and perf numbers.
-
-The implementation is extremely simple: just make the strictness
-analyser strictify the demand on a dictionary binder in
-'findBndrDmd'.
-
-However there is one case where this can make performance worse.
-For the principle consider some function at the core level:
-    myEq :: Eq a => a -> a -> Bool
-    myEq eqDict x y = ((==) eqDict) x y
-If we make the dictionary strict then WW can fire turning this into:
-    $wmyEq :: (a -> a -> Bool) -> a -> a -> Bool
-    $wmyEq eq x y = eq x y
-Which *usually* performs better. However if the dictionary is known we
-are far more likely to inline a function applied to the dictionary than
-to inline one applied to a function. Sometimes this makes just enough
-of a difference to stop a function from inlining. This is documented in #18421.
-
-It's somewhat similar to Note [Do not unbox class dictionaries] although
-here our problem is with the inliner, not the specializer.
-
-Note [Initialising strictness]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See section 9.2 (Finding fixpoints) of the paper.
-
-Our basic plan is to initialise the strictness of each Id in a
-recursive group to "bottom", and find a fixpoint from there.  However,
-this group B might be inside an *enclosing* recursive group A, in
-which case we'll do the entire fixpoint shebang on for each iteration
-of A. This can be illustrated by the following example:
-
-Example:
-
-  f [] = []
-  f (x:xs) = let g []     = f xs
-                 g (y:ys) = y+1 : g ys
-              in g (h x)
-
-At each iteration of the fixpoint for f, the analyser has to find a
-fixpoint for the enclosed function g. In the meantime, the demand
-values for g at each iteration for f are *greater* than those we
-encountered in the previous iteration for f. Therefore, we can begin
-the fixpoint for g not with the bottom value but rather with the
-result of the previous analysis. I.e., when beginning the fixpoint
-process for g, we can start from the demand signature computed for g
-previously and attached to the binding occurrence of g.
-
-To speed things up, we initialise each iteration of A (the enclosing
-one) from the result of the last one, which is neatly recorded in each
-binder.  That way we make use of earlier iterations of the fixpoint
-algorithm. (Cunning plan.)
-
-But on the *first* iteration we want to *ignore* the current strictness
-of the Id, and start from "bottom".  Nowadays the Id can have a current
-strictness, because interface files record strictness for nested bindings.
-To know when we are in the first iteration, we look at the ae_virgin
-field of the AnalEnv.
-
-
-Note [Final Demand Analyser run]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Some of the information that the demand analyser determines is not always
-preserved by the simplifier.  For example, the simplifier will happily rewrite
-  \y [Demand=MU] let x = y in x + x
-to
-  \y [Demand=MU] y + y
-which is quite a lie: Now y occurs more than just once.
-
-The once-used information is (currently) only used by the code
-generator, though.  So:
-
- * We zap the used-once info in the worker-wrapper;
-   see Note [Zapping Used Once info in WorkWrap] in
-   GHC.Core.Opt.WorkWrap.
-   If it's not reliable, it's better not to have it at all.
-
- * Just before TidyCore, we add a pass of the demand analyser,
-      but WITHOUT subsequent worker/wrapper and simplifier,
-   right before TidyCore.  See SimplCore.getCoreToDo.
-
-   This way, correct information finds its way into the module interface
-   (strictness signatures!) and the code generator (single-entry thunks!)
-
-Note that, in contrast, the single-call information (C(M,..)) /can/ be
-relied upon, as the simplifier tends to be very careful about not
-duplicating actual function calls.
-
-Also see #11731.
-
-Note [Space Leaks in Demand Analysis]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Ticket: #15455
-MR: !5399
-
-In the past the result of demand analysis was not forced until the whole module
-had finished being analysed. In big programs, this led to a big build up of thunks
-which were all ultimately forced at the end of the analysis.
-
-This was because the return type of the analysis was a lazy pair:
-  dmdAnal :: AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr)
-To avoid space leaks we added extra bangs to evaluate the DmdType component eagerly; but
-we were never sure we had added enough.
-The easiest way to systematically fix this was to use a strict pair type for the
-return value of the analysis so that we can be more confident that the result
-is incrementally computed rather than all at the end.
-
-A second, only loosely related point is that
-the updating of Ids was not forced because the result of updating
-an Id was placed into a lazy field in CoreExpr. This meant that until the end of
-demand analysis, the unforced Ids would retain the DmdEnv which the demand information
-was fetch from. Now we are quite careful to force Ids before putting them
-back into core expressions so that we can garbage-collect the environments more eagerly.
-For example see the `Case` branch of `dmdAnal'` where `case_bndr'` is forced
-or `dmdAnalSumAlt`.
-
-The net result of all these improvements is the peak live memory usage of compiling
-jsaddle-dom decreases about 4GB (from 6.5G to 2.5G). A bunch of bytes allocated benchmarks also
-decrease because we allocate a lot fewer thunks which we immediately overwrite and
-also runtime for the pass is faster! Overall, good wins.
-
--}
diff --git a/compiler/GHC/Core/Opt/Exitify.hs b/compiler/GHC/Core/Opt/Exitify.hs
deleted file mode 100644
--- a/compiler/GHC/Core/Opt/Exitify.hs
+++ /dev/null
@@ -1,523 +0,0 @@
-module GHC.Core.Opt.Exitify ( exitifyProgram ) where
-
-{-
-Note [Exitification]
-~~~~~~~~~~~~~~~~~~~~
-
-This module implements Exitification. The goal is to pull as much code out of
-recursive functions as possible, as the simplifier is better at inlining into
-call-sites that are not in recursive functions.
-
-Example:
-
-  let t = foo bar
-  joinrec go 0     x y = t (x*x)
-          go (n-1) x y = jump go (n-1) (x+y)
-  in …
-
-We’d like to inline `t`, but that does not happen: Because t is a thunk and is
-used in a recursive function, doing so might lose sharing in general. In
-this case, however, `t` is on the _exit path_ of `go`, so called at most once.
-How do we make this clearly visible to the simplifier?
-
-A code path (i.e., an expression in a tail-recursive position) in a recursive
-function is an exit path if it does not contain a recursive call. We can bind
-this expression outside the recursive function, as a join-point.
-
-Example result:
-
-  let t = foo bar
-  join exit x = t (x*x)
-  joinrec go 0     x y = jump exit x
-          go (n-1) x y = jump go (n-1) (x+y)
-  in …
-
-Now `t` is no longer in a recursive function, and good things happen!
--}
-
-import GHC.Prelude
-import GHC.Types.Var
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Core
-import GHC.Core.Utils
-import GHC.Utils.Monad.State.Strict
-import GHC.Builtin.Uniques
-import GHC.Types.Var.Set
-import GHC.Types.Var.Env
-import GHC.Core.FVs
-import GHC.Data.FastString
-import GHC.Core.Type
-import GHC.Utils.Misc( mapSnd )
-
-import Data.Bifunctor
-import Control.Monad
-
--- | Traverses the AST, simply to find all joinrecs and call 'exitify' on them.
--- The really interesting function is exitifyRec
-exitifyProgram :: CoreProgram -> CoreProgram
-exitifyProgram binds = map goTopLvl binds
-  where
-    goTopLvl (NonRec v e) = NonRec v (go in_scope_toplvl e)
-    goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs)
-      -- Top-level bindings are never join points
-
-    in_scope_toplvl = emptyInScopeSet `extendInScopeSetBndrs` binds
-
-    go :: InScopeSet -> CoreExpr -> CoreExpr
-    go _    e@(Var{})       = e
-    go _    e@(Lit {})      = e
-    go _    e@(Type {})     = e
-    go _    e@(Coercion {}) = e
-    go in_scope (Cast e' c) = Cast (go in_scope e') c
-    go in_scope (Tick t e') = Tick t (go in_scope e')
-    go in_scope (App e1 e2) = App (go in_scope e1) (go in_scope e2)
-
-    go in_scope (Lam v e')
-      = Lam v (go in_scope' e')
-      where in_scope' = in_scope `extendInScopeSet` v
-
-    go in_scope (Case scrut bndr ty alts)
-      = Case (go in_scope scrut) bndr ty (map go_alt alts)
-      where
-        in_scope1 = in_scope `extendInScopeSet` bndr
-        go_alt (Alt dc pats rhs) = Alt dc pats (go in_scope' rhs)
-           where in_scope' = in_scope1 `extendInScopeSetList` pats
-
-    go in_scope (Let (NonRec bndr rhs) body)
-      = Let (NonRec bndr (go in_scope rhs)) (go in_scope' body)
-      where
-        in_scope' = in_scope `extendInScopeSet` bndr
-
-    go in_scope (Let (Rec pairs) body)
-      | is_join_rec = mkLets (exitifyRec in_scope' pairs') body'
-      | otherwise   = Let (Rec pairs') body'
-      where
-        is_join_rec = any (isJoinId . fst) pairs
-        in_scope'   = in_scope `extendInScopeSetBind` (Rec pairs)
-        pairs'      = mapSnd (go in_scope') pairs
-        body'       = go in_scope' body
-
-
--- | State Monad used inside `exitify`
-type ExitifyM =  State [(JoinId, CoreExpr)]
-
--- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as
---   join-points outside the joinrec.
-exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind]
-exitifyRec in_scope pairs
-  = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs']
-  where
-    -- We need the set of free variables of many subexpressions here, so
-    -- annotate the AST with them
-    -- see Note [Calculating free variables]
-    ann_pairs = map (second freeVars) pairs
-
-    -- Which are the recursive calls?
-    recursive_calls = mkVarSet $ map fst pairs
-
-    (pairs',exits) = (`runState` []) $
-        forM ann_pairs $ \(x,rhs) -> do
-            -- go past the lambdas of the join point
-            let (args, body) = collectNAnnBndrs (idJoinArity x) rhs
-            body' <- go args body
-            let rhs' = mkLams args body'
-            return (x, rhs')
-
-    ---------------------
-    -- 'go' is the main working function.
-    -- It goes through the RHS (tail-call positions only),
-    -- checks if there are no more recursive calls, if so, abstracts over
-    -- variables bound on the way and lifts it out as a join point.
-    --
-    -- ExitifyM is a state monad to keep track of floated binds
-    go :: [Var]           -- Variables that are in-scope here, but
-                          -- not in scope at the joinrec; that is,
-                          -- we must potentially abstract over them.
-                          -- Invariant: they are kept in dependency order
-       -> CoreExprWithFVs -- Current expression in tail position
-       -> ExitifyM CoreExpr
-
-    -- We first look at the expression (no matter what it shape is)
-    -- and determine if we can turn it into a exit join point
-    go captured ann_e
-        | -- An exit expression has no recursive calls
-          let fvs = dVarSetToVarSet (freeVarsOf ann_e)
-        , disjointVarSet fvs recursive_calls
-        = go_exit captured (deAnnotate ann_e) fvs
-
-    -- We could not turn it into a exit join point. So now recurse
-    -- into all expression where eligible exit join points might sit,
-    -- i.e. into all tail-call positions:
-
-    -- Case right hand sides are in tail-call position
-    go captured (_, AnnCase scrut bndr ty alts) = do
-        alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do
-            rhs' <- go (captured ++ [bndr] ++ pats) rhs
-            return (Alt dc pats rhs')
-        return $ Case (deAnnotate scrut) bndr ty alts'
-
-    go captured (_, AnnLet ann_bind body)
-        -- join point, RHS and body are in tail-call position
-        | AnnNonRec j rhs <- ann_bind
-        , Just join_arity <- isJoinId_maybe j
-        = do let (params, join_body) = collectNAnnBndrs join_arity rhs
-             join_body' <- go (captured ++ params) join_body
-             let rhs' = mkLams params join_body'
-             body' <- go (captured ++ [j]) body
-             return $ Let (NonRec j rhs') body'
-
-        -- rec join point, RHSs and body are in tail-call position
-        | AnnRec pairs <- ann_bind
-        , isJoinId (fst (head pairs))
-        = do let js = map fst pairs
-             pairs' <- forM pairs $ \(j,rhs) -> do
-                 let join_arity = idJoinArity j
-                     (params, join_body) = collectNAnnBndrs join_arity rhs
-                 join_body' <- go (captured ++ js ++ params) join_body
-                 let rhs' = mkLams params join_body'
-                 return (j, rhs')
-             body' <- go (captured ++ js) body
-             return $ Let (Rec pairs') body'
-
-        -- normal Let, only the body is in tail-call position
-        | otherwise
-        = do body' <- go (captured ++ bindersOf bind ) body
-             return $ Let bind body'
-      where bind = deAnnBind ann_bind
-
-    -- Cannot be turned into an exit join point, but also has no
-    -- tail-call subexpression. Nothing to do here.
-    go _ ann_e = return (deAnnotate ann_e)
-
-    ---------------------
-    go_exit :: [Var]      -- Variables captured locally
-            -> CoreExpr   -- An exit expression
-            -> VarSet     -- Free vars of the expression
-            -> ExitifyM CoreExpr
-    -- go_exit deals with a tail expression that is floatable
-    -- out as an exit point; that is, it mentions no recursive calls
-    go_exit captured e fvs
-      -- Do not touch an expression that is already a join jump where all arguments
-      -- are captured variables. See Note [Idempotency]
-      -- But _do_ float join jumps with interesting arguments.
-      -- See Note [Jumps can be interesting]
-      | (Var f, args) <- collectArgs e
-      , isJoinId f
-      , all isCapturedVarArg args
-      = return e
-
-      -- Do not touch a boring expression (see Note [Interesting expression])
-      | not is_interesting
-      = return e
-
-      -- Cannot float out if local join points are used, as
-      -- we cannot abstract over them
-      | captures_join_points
-      = return e
-
-      -- We have something to float out!
-      | otherwise
-      = do { -- Assemble the RHS of the exit join point
-             let rhs   = mkLams abs_vars e
-                 avoid = in_scope `extendInScopeSetList` captured
-             -- Remember this binding under a suitable name
-           ; v <- addExit avoid (length abs_vars) rhs
-             -- And jump to it from here
-           ; return $ mkVarApps (Var v) abs_vars }
-
-      where
-        -- Used to detect exit expressions that are already proper exit jumps
-        isCapturedVarArg (Var v) = v `elem` captured
-        isCapturedVarArg _ = False
-
-        -- An interesting exit expression has free, non-imported
-        -- variables from outside the recursive group
-        -- See Note [Interesting expression]
-        is_interesting = anyVarSet isLocalId $
-                         fvs `minusVarSet` mkVarSet captured
-
-        -- The arguments of this exit join point
-        -- See Note [Picking arguments to abstract over]
-        abs_vars = snd $ foldr pick (fvs, []) captured
-          where
-            pick v (fvs', acc) | v `elemVarSet` fvs' = (fvs' `delVarSet` v, zap v : acc)
-                               | otherwise           = (fvs',               acc)
-
-        -- We are going to abstract over these variables, so we must
-        -- zap any IdInfo they have; see #15005
-        -- cf. GHC.Core.Opt.SetLevels.abstractVars
-        zap v | isId v = setIdInfo v vanillaIdInfo
-              | otherwise = v
-
-        -- We cannot abstract over join points
-        captures_join_points = any isJoinId abs_vars
-
-
--- Picks a new unique, which is disjoint from
---  * the free variables of the whole joinrec
---  * any bound variables (captured)
---  * any exit join points created so far.
-mkExitJoinId :: InScopeSet -> Type -> JoinArity -> ExitifyM JoinId
-mkExitJoinId in_scope ty join_arity = do
-    fs <- get
-    let avoid = in_scope `extendInScopeSetList` (map fst fs)
-                         `extendInScopeSet` exit_id_tmpl -- just cosmetics
-    return (uniqAway avoid exit_id_tmpl)
-  where
-    exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty
-                    `asJoinId` join_arity
-
-addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId
-addExit in_scope join_arity rhs = do
-    -- Pick a suitable name
-    let ty = exprType rhs
-    v <- mkExitJoinId in_scope ty join_arity
-    fs <- get
-    put ((v,rhs):fs)
-    return v
-
-{-
-Note [Interesting expression]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not want this to happen:
-
-  joinrec go 0     x y = x
-          go (n-1) x y = jump go (n-1) (x+y)
-  in …
-==>
-  join exit x = x
-  joinrec go 0     x y = jump exit x
-          go (n-1) x y = jump go (n-1) (x+y)
-  in …
-
-because the floated exit path (`x`) is simply a parameter of `go`; there are
-not useful interactions exposed this way.
-
-Neither do we want this to happen
-
-  joinrec go 0     x y = x+x
-          go (n-1) x y = jump go (n-1) (x+y)
-  in …
-==>
-  join exit x = x+x
-  joinrec go 0     x y = jump exit x
-          go (n-1) x y = jump go (n-1) (x+y)
-  in …
-
-where the floated expression `x+x` is a bit more complicated, but still not
-interesting.
-
-Expressions are interesting when they move an occurrence of a variable outside
-the recursive `go` that can benefit from being obviously called once, for example:
- * a local thunk that can then be inlined (see example in Note [Exitification])
- * the parameter of a function, where the demand analyzer then can then
-   see that it is called at most once, and hence improve the function’s
-   strictness signature
-
-So we only hoist an exit expression out if it mentions at least one free,
-non-imported variable.
-
-Note [Jumps can be interesting]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A jump to a join point can be interesting, if its arguments contain free
-non-exported variables (z in the following example):
-
-  joinrec go 0     x y = jump j (x+z)
-          go (n-1) x y = jump go (n-1) (x+y)
-  in …
-==>
-  join exit x y = jump j (x+z)
-  joinrec go 0     x y = jump exit x
-          go (n-1) x y = jump go (n-1) (x+y)
-
-
-The join point itself can be interesting, even if none if its
-arguments have free variables free in the joinrec.  For example
-
-  join j p = case p of (x,y) -> x+y
-  joinrec go 0     x y = jump j (x,y)
-          go (n-1) x y = jump go (n-1) (x+y) y
-  in …
-
-Here, `j` would not be inlined because we do not inline something that looks
-like an exit join point (see Note [Do not inline exit join points]). But
-if we exitify the 'jump j (x,y)' we get
-
-  join j p = case p of (x,y) -> x+y
-  join exit x y = jump j (x,y)
-  joinrec go 0     x y = jump exit x y
-          go (n-1) x y = jump go (n-1) (x+y) y
-  in …
-
-and now 'j' can inline, and we get rid of the pair. Here's another
-example (assume `g` to be an imported function that, on its own,
-does not make this interesting):
-
-  join j y = map f y
-  joinrec go 0     x y = jump j (map g x)
-          go (n-1) x y = jump go (n-1) (x+y)
-  in …
-
-Again, `j` would not be inlined because we do not inline something that looks
-like an exit join point (see Note [Do not inline exit join points]).
-
-But after exitification we have
-
-  join j y = map f y
-  join exit x = jump j (map g x)
-  joinrec go 0     x y = jump j (map g x)
-              go (n-1) x y = jump go (n-1) (x+y)
-  in …
-
-and now we can inline `j` and this will allow `map/map` to fire.
-
-
-Note [Idempotency]
-~~~~~~~~~~~~~~~~~~
-
-We do not want this to happen, where we replace the floated expression with
-essentially the same expression:
-
-  join exit x = t (x*x)
-  joinrec go 0     x y = jump exit x
-          go (n-1) x y = jump go (n-1) (x+y)
-  in …
-==>
-  join exit x = t (x*x)
-  join exit' x = jump exit x
-  joinrec go 0     x y = jump exit' x
-          go (n-1) x y = jump go (n-1) (x+y)
-  in …
-
-So when the RHS is a join jump, and all of its arguments are captured variables,
-then we leave it in place.
-
-Note that `jump exit x` in this example looks interesting, as `exit` is a free
-variable. Therefore, idempotency does not simply follow from floating only
-interesting expressions.
-
-Note [Calculating free variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We have two options where to annotate the tree with free variables:
-
- A) The whole tree.
- B) Each individual joinrec as we come across it.
-
-Downside of A: We pay the price on the whole module, even outside any joinrecs.
-Downside of B: We pay the price per joinrec, possibly multiple times when
-joinrecs are nested.
-
-Further downside of A: If the exitify function returns annotated expressions,
-it would have to ensure that the annotations are correct.
-
-We therefore choose B, and calculate the free variables in `exitify`.
-
-
-Note [Do not inline exit join points]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we have
-
-  let t = foo bar
-  join exit x = t (x*x)
-  joinrec go 0     x y = jump exit x
-          go (n-1) x y = jump go (n-1) (x+y)
-  in …
-
-we do not want the simplifier to simply inline `exit` back in (which it happily
-would).
-
-To prevent this, we need to recognize exit join points, and then disable
-inlining.
-
-Exit join points, recognizable using `isExitJoinId` are join points with an
-occurrence in a recursive group, and can be recognized (after the occurrence
-analyzer ran!) using `isExitJoinId`.
-
-This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`,
-because the lambdas of a non-recursive join point are not considered for
-`occ_in_lam`.  For example, in the following code, `j1` is /not/ marked
-occ_in_lam, because `j2` is called only once.
-
-  join j1 x = x+1
-  join j2 y = join j1 (y+2)
-
-To prevent inlining, we check for isExitJoinId
-* In `preInlineUnconditionally` directly.
-* In `simplLetUnfolding` we simply give exit join points no unfolding, which
-  prevents inlining in `postInlineUnconditionally` and call sites.
-
-But see Note [Be selective about not-inlining exit join points]
-
-Note [Be selective about not-inlining exit join points]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we follow "do not inline exit join points" mantra throughout,
-some bad things happen.
-
-* We can lose CPR information: see #21148
-
-* We get useless clutter (#22084) that
-  - makes the program bigger (including duplicated code #20739), and
-  - adds extra jumps (and maybe stack saves) at runtime
-
-So instead we follow "do not inline exit join points" for a /single run/
-of the simplifier, right after Exitification.  That should give a
-sufficient chance for used-once things to inline, but subsequent runs
-will inline them back in.  (Annoyingly, as things stand, only with -O2
-is there a subsequent run, but that might change, and it's not a huge
-deal anyway.)
-
-This is controlled by the Simplifier's sm_keep_exits flag; see
-GHC.Core.Opt.Pipeline.
-
-Note [Placement of the exitification pass]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-I (Joachim) experimented with multiple positions for the Exitification pass in
-the Core2Core pipeline:
-
- A) Before the `simpl_phases`
- B) Between the `simpl_phases` and the "main" simplifier pass
- C) After demand_analyser
- D) Before the final simplification phase
-
-Here is the table (this is without inlining join exit points in the final
-simplifier run):
-
-        Program |                       Allocs                      |                      Instrs
-                | ABCD.log     A.log     B.log     C.log     D.log  | ABCD.log     A.log     B.log     C.log     D.log
-----------------|---------------------------------------------------|-------------------------------------------------
- fannkuch-redux |   -99.9%     +0.0%    -99.9%    -99.9%    -99.9%  |    -3.9%     +0.5%     -3.0%     -3.9%     -3.9%
-          fasta |    -0.0%     +0.0%     +0.0%     -0.0%     -0.0%  |    -8.5%     +0.0%     +0.0%     -0.0%     -8.5%
-            fem |     0.0%      0.0%      0.0%      0.0%     +0.0%  |    -2.2%     -0.1%     -0.1%     -2.1%     -2.1%
-           fish |     0.0%      0.0%      0.0%      0.0%     +0.0%  |    -3.1%     +0.0%     -1.1%     -1.1%     -0.0%
-   k-nucleotide |   -91.3%    -91.0%    -91.0%    -91.3%    -91.3%  |    -6.3%    +11.4%    +11.4%     -6.3%     -6.2%
-            scs |    -0.0%     -0.0%     -0.0%     -0.0%     -0.0%  |    -3.4%     -3.0%     -3.1%     -3.3%     -3.3%
-         simple |    -6.0%      0.0%     -6.0%     -6.0%     +0.0%  |    -3.4%     +0.0%     -5.2%     -3.4%     -0.1%
-  spectral-norm |    -0.0%      0.0%      0.0%     -0.0%     +0.0%  |    -2.7%     +0.0%     -2.7%     -5.4%     -5.4%
-----------------|---------------------------------------------------|-------------------------------------------------
-            Min |   -95.0%    -91.0%    -95.0%    -95.0%    -95.0%  |    -8.5%     -3.0%     -5.2%     -6.3%     -8.5%
-            Max |    +0.2%     +0.2%     +0.2%     +0.2%     +1.5%  |    +0.4%    +11.4%    +11.4%     +0.4%     +1.5%
- Geometric Mean |    -4.7%     -2.1%     -4.7%     -4.7%     -4.6%  |    -0.4%     +0.1%     -0.1%     -0.3%     -0.2%
-
-Position A is disqualified, as it does not get rid of the allocations in
-fannkuch-redux.
-Position A and B are disqualified because it increases instructions in k-nucleotide.
-Positions C and D have their advantages: C decreases allocations in simpl, but D instructions in fasta.
-
-Assuming we have a budget of _one_ run of Exitification, then C wins (but we
-could get more from running it multiple times, as seen in fish).
-
-Note [Picking arguments to abstract over]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-When we create an exit join point, so we need to abstract over those of its
-free variables that are be out-of-scope at the destination of the exit join
-point. So we go through the list `captured` and pick those that are actually
-free variables of the join point.
-
-We do not just `filter (`elemVarSet` fvs) captured`, as there might be
-shadowing, and `captured` may contain multiple variables with the same Unique. I
-these cases we want to abstract only over the last occurrence, hence the `foldr`
-(with emphasis on the `r`). This is #15110.
-
--}
diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs
deleted file mode 100644
--- a/compiler/GHC/Core/Opt/FloatIn.hs
+++ /dev/null
@@ -1,766 +0,0 @@
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-************************************************************************
-*                                                                      *
-\section[FloatIn]{Floating Inwards pass}
-*                                                                      *
-************************************************************************
-
-The main purpose of @floatInwards@ is floating into branches of a
-case, so that we don't allocate things, save them on the stack, and
-then discover that they aren't needed in the chosen branch.
--}
-
-
-{-# OPTIONS_GHC -fprof-auto #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module GHC.Core.Opt.FloatIn ( floatInwards ) where
-
-import GHC.Prelude
-import GHC.Platform
-
-import GHC.Core
-import GHC.Core.Opt.Arity( isOneShotBndr )
-import GHC.Core.Make hiding ( wrapFloats )
-import GHC.Core.Utils
-import GHC.Core.FVs
-import GHC.Core.Type
-
-import GHC.Types.Basic      ( RecFlag(..), isRec, Levity(Unlifted) )
-import GHC.Types.Id         ( idType, isJoinId, isJoinId_maybe )
-import GHC.Types.Tickish
-import GHC.Types.Var
-import GHC.Types.Var.Set
-
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-{-
-Top-level interface function, @floatInwards@.  Note that we do not
-actually float any bindings downwards from the top-level.
--}
-
-floatInwards :: Platform -> CoreProgram -> CoreProgram
-floatInwards platform binds = map (fi_top_bind platform) binds
-  where
-    fi_top_bind platform (NonRec binder rhs)
-      = NonRec binder (fiExpr platform [] (freeVars rhs))
-    fi_top_bind platform (Rec pairs)
-      = Rec [ (b, fiExpr platform [] (freeVars rhs)) | (b, rhs) <- pairs ]
-
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Mail from Andr\'e [edited]}
-*                                                                      *
-************************************************************************
-
-{\em Will wrote: What??? I thought the idea was to float as far
-inwards as possible, no matter what.  This is dropping all bindings
-every time it sees a lambda of any kind.  Help! }
-
-You are assuming we DO DO full laziness AFTER floating inwards!  We
-have to [not float inside lambdas] if we don't.
-
-If we indeed do full laziness after the floating inwards (we could
-check the compilation flags for that) then I agree we could be more
-aggressive and do float inwards past lambdas.
-
-Actually we are not doing a proper full laziness (see below), which
-was another reason for not floating inwards past a lambda.
-
-This can easily be fixed.  The problem is that we float lets outwards,
-but there are a few expressions which are not let bound, like case
-scrutinees and case alternatives.  After floating inwards the
-simplifier could decide to inline the let and the laziness would be
-lost, e.g.
-
-\begin{verbatim}
-let a = expensive             ==> \b -> case expensive of ...
-in \ b -> case a of ...
-\end{verbatim}
-The fix is
-\begin{enumerate}
-\item
-to let bind the algebraic case scrutinees (done, I think) and
-the case alternatives (except the ones with an
-unboxed type)(not done, I think). This is best done in the
-GHC.Core.Opt.SetLevels module, which tags things with their level numbers.
-\item
-do the full laziness pass (floating lets outwards).
-\item
-simplify. The simplifier inlines the (trivial) lets that were
- created but were not floated outwards.
-\end{enumerate}
-
-With the fix I think Will's suggestion that we can gain even more from
-strictness by floating inwards past lambdas makes sense.
-
-We still gain even without going past lambdas, as things may be
-strict in the (new) context of a branch (where it was floated to) or
-of a let rhs, e.g.
-\begin{verbatim}
-let a = something            case x of
-in case x of                   alt1 -> case something of a -> a + a
-     alt1 -> a + a      ==>    alt2 -> b
-     alt2 -> b
-
-let a = something           let b = case something of a -> a + a
-in let b = a + a        ==> in (b,b)
-in (b,b)
-\end{verbatim}
-Also, even if a is not found to be strict in the new context and is
-still left as a let, if the branch is not taken (or b is not entered)
-the closure for a is not built.
-
-************************************************************************
-*                                                                      *
-\subsection{Main floating-inwards code}
-*                                                                      *
-************************************************************************
--}
-
-type FreeVarSet  = DIdSet
-type BoundVarSet = DIdSet
-
-data FloatInBind = FB BoundVarSet FreeVarSet FloatBind
-        -- The FreeVarSet is the free variables of the binding.  In the case
-        -- of recursive bindings, the set doesn't include the bound
-        -- variables.
-
-type FloatInBinds = [FloatInBind]
-        -- In reverse dependency order (innermost binder first)
-
-fiExpr :: Platform
-       -> FloatInBinds      -- Binds we're trying to drop
-                            -- as far "inwards" as possible
-       -> CoreExprWithFVs   -- Input expr
-       -> CoreExpr          -- Result
-
-fiExpr _ to_drop (_, AnnLit lit)     = wrapFloats to_drop (Lit lit)
-                                       -- See Note [Dead bindings]
-fiExpr _ to_drop (_, AnnType ty)     = assert (null to_drop) $ Type ty
-fiExpr _ to_drop (_, AnnVar v)       = wrapFloats to_drop (Var v)
-fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)
-fiExpr platform to_drop (_, AnnCast expr (co_ann, co))
-  = wrapFloats (drop_here ++ co_drop) $
-    Cast (fiExpr platform e_drop expr) co
-  where
-    [drop_here, e_drop, co_drop]
-      = sepBindsByDropPoint platform False
-          [freeVarsOf expr, freeVarsOfAnn co_ann]
-          to_drop
-
-{-
-Applications: we do float inside applications, mainly because we
-need to get at all the arguments.  The next simplifier run will
-pull out any silly ones.
--}
-
-fiExpr platform to_drop ann_expr@(_,AnnApp {})
-  = wrapFloats drop_here $ wrapFloats extra_drop $
-    mkTicks ticks $
-    mkApps (fiExpr platform fun_drop ann_fun)
-           (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args)
-           -- use zipWithEqual, we should have
-           -- length ann_args = length arg_fvs = length arg_drops
-  where
-    (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr
-    fun_ty  = exprType (deAnnotate ann_fun)
-    fun_fvs = freeVarsOf ann_fun
-    arg_fvs = map freeVarsOf ann_args
-
-    (drop_here : extra_drop : fun_drop : arg_drops)
-       = sepBindsByDropPoint platform False
-                             (extra_fvs : fun_fvs : arg_fvs)
-                             to_drop
-         -- Shortcut behaviour: if to_drop is empty,
-         -- sepBindsByDropPoint returns a suitable bunch of empty
-         -- lists without evaluating extra_fvs, and hence without
-         -- peering into each argument
-
-    (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args
-    extra_fvs0 = case ann_fun of
-                   (_, AnnVar _) -> fun_fvs
-                   _             -> emptyDVarSet
-          -- Don't float the binding for f into f x y z; see Note [Join points]
-          -- for why we *can't* do it when f is a join point. (If f isn't a
-          -- join point, floating it in isn't especially harmful but it's
-          -- useless since the simplifier will immediately float it back out.)
-
-    add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)
-    add_arg (fun_ty, extra_fvs) (_, AnnType ty)
-      = (piResultTy fun_ty ty, extra_fvs)
-    add_arg (fun_ty, extra_fvs) (arg_fvs, arg)
-      | noFloatIntoArg arg
-      = (funResultTy fun_ty, extra_fvs `unionDVarSet` arg_fvs)
-      | otherwise
-      = (funResultTy fun_ty, extra_fvs)
-
-{- Note [Dead bindings]
-~~~~~~~~~~~~~~~~~~~~~~~
-At a literal we won't usually have any floated bindings; the
-only way that can happen is if the binding wrapped the literal
-/in the original input program/.  e.g.
-   case x of { DEFAULT -> 1# }
-But, while this may be unusual it is not actually wrong, and it did
-once happen (#15696).
-
-Note [Join points]
-~~~~~~~~~~~~~~~~~~
-Generally, we don't need to worry about join points - there are places we're
-not allowed to float them, but since they can't have occurrences in those
-places, we're not tempted.
-
-We do need to be careful about jumps, however:
-
-  joinrec j x y z = ... in
-  jump j a b c
-
-Previous versions often floated the definition of a recursive function into its
-only non-recursive occurrence. But for a join point, this is a disaster:
-
-  (joinrec j x y z = ... in
-  jump j) a b c -- wrong!
-
-Every jump must be exact, so the jump to j must have three arguments. Hence
-we're careful not to float into the target of a jump (though we can float into
-the arguments just fine).
-
-Note [Floating in past a lambda group]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* We must be careful about floating inside a value lambda.
-  That risks losing laziness.
-  The float-out pass might rescue us, but then again it might not.
-
-* We must be careful about type lambdas too.  At one time we did, and
-  there is no risk of duplicating work thereby, but we do need to be
-  careful.  In particular, here is a bad case (it happened in the
-  cichelli benchmark:
-        let v = ...
-        in let f = /\t -> \a -> ...
-           ==>
-        let f = /\t -> let v = ... in \a -> ...
-  This is bad as now f is an updatable closure (update PAP)
-  and has arity 0.
-
-* Hack alert!  We only float in through one-shot lambdas,
-  not (as you might guess) through lone big lambdas.
-  Reason: we float *out* past big lambdas (see the test in the Lam
-  case of FloatOut.floatExpr) and we don't want to float straight
-  back in again.
-
-  It *is* important to float into one-shot lambdas, however;
-  see the remarks with noFloatIntoRhs.
-
-So we treat lambda in groups, using the following rule:
-
- Float in if (a) there is at least one Id,
-         and (b) there are no non-one-shot Ids
-
- Otherwise drop all the bindings outside the group.
-
-This is what the 'go' function in the AnnLam case is doing.
-
-(Join points are handled similarly: a join point is considered one-shot iff
-it's non-recursive, so we float only into non-recursive join points.)
-
-Urk! if all are tyvars, and we don't float in, we may miss an
-      opportunity to float inside a nested case branch
-
-
-Note [Floating coercions]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-We could, in principle, have a coercion binding like
-   case f x of co { DEFAULT -> e1 e2 }
-It's not common to have a function that returns a coercion, but nothing
-in Core prohibits it.  If so, 'co' might be mentioned in e1 or e2
-/only in a type/.  E.g. suppose e1 was
-  let (x :: Int |> co) = blah in blah2
-
-
-But, with coercions appearing in types, there is a complication: we
-might be floating in a "strict let" -- that is, a case. Case expressions
-mention their return type. We absolutely can't float a coercion binding
-inward to the point that the type of the expression it's about to wrap
-mentions the coercion. So we include the union of the sets of free variables
-of the types of all the drop points involved. If any of the floaters
-bind a coercion variable mentioned in any of the types, that binder must
-be dropped right away.
-
--}
-
-fiExpr platform to_drop lam@(_, AnnLam _ _)
-  | noFloatIntoLam bndrs       -- Dump it all here
-     -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088
-  = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body))
-
-  | otherwise           -- Float inside
-  = mkLams bndrs (fiExpr platform to_drop body)
-
-  where
-    (bndrs, body) = collectAnnBndrs lam
-
-{-
-We don't float lets inwards past an SCC.
-        ToDo: keep info on current cc, and when passing
-        one, if it is not the same, annotate all lets in binds with current
-        cc, change current cc to the new one and float binds into expr.
--}
-
-fiExpr platform to_drop (_, AnnTick tickish expr)
-  | tickish `tickishScopesLike` SoftScope
-  = Tick tickish (fiExpr platform to_drop expr)
-
-  | otherwise -- Wimp out for now - we could push values in
-  = wrapFloats to_drop (Tick tickish (fiExpr platform [] expr))
-
-{-
-For @Lets@, the possible ``drop points'' for the \tr{to_drop}
-bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
-or~(b2), in each of the RHSs of the pairs of a @Rec@.
-
-Note that we do {\em weird things} with this let's binding.  Consider:
-\begin{verbatim}
-let
-    w = ...
-in {
-    let v = ... w ...
-    in ... v .. w ...
-}
-\end{verbatim}
-Look at the inner \tr{let}.  As \tr{w} is used in both the bind and
-body of the inner let, we could panic and leave \tr{w}'s binding where
-it is.  But \tr{v} is floatable further into the body of the inner let, and
-{\em then} \tr{w} will also be only in the body of that inner let.
-
-So: rather than drop \tr{w}'s binding here, we add it onto the list of
-things to drop in the outer let's body, and let nature take its
-course.
-
-Note [extra_fvs (1)]: avoid floating into RHS
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider let x=\y....t... in body.  We do not necessarily want to float
-a binding for t into the RHS, because it'll immediately be floated out
-again.  (It won't go inside the lambda else we risk losing work.)
-In letrec, we need to be more careful still. We don't want to transform
-        let x# = y# +# 1#
-        in
-        letrec f = \z. ...x#...f...
-        in ...
-into
-        letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
-because now we can't float the let out again, because a letrec
-can't have unboxed bindings.
-
-So we make "extra_fvs" which is the rhs_fvs of such bindings, and
-arrange to dump bindings that bind extra_fvs before the entire let.
-
-Note [extra_fvs (2)]: free variables of rules
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  let x{rule mentioning y} = rhs in body
-Here y is not free in rhs or body; but we still want to dump bindings
-that bind y outside the let.  So we augment extra_fvs with the
-idRuleAndUnfoldingVars of x.  No need for type variables, hence not using
-idFreeVars.
--}
-
-fiExpr platform to_drop (_,AnnLet bind body)
-  = fiExpr platform (after ++ new_float : before) body
-           -- to_drop is in reverse dependency order
-  where
-    (before, new_float, after) = fiBind platform to_drop bind body_fvs
-    body_fvs    = freeVarsOf body
-
-{- Note [Floating primops]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-We try to float-in a case expression over an unlifted type.  The
-motivating example was #5658: in particular, this change allows
-array indexing operations, which have a single DEFAULT alternative
-without any binders, to be floated inward.
-
-SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed
-scalars also need to be floated inward, but unpacks have a single non-DEFAULT
-alternative that binds the elements of the tuple. We now therefore also support
-floating in cases with a single alternative that may bind values.
-
-But there are wrinkles
-
-* Which unlifted cases do we float?
-  See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps which
-  explains:
-   - We can float in can_fail primops (which concerns imprecise exceptions),
-     but we can't float them out.
-   - But we can float a has_side_effects primop, but NOT inside a lambda,
-     so for now we don't float them at all. Hence exprOkForSideEffects.
-   - Throwing precise exceptions is a special case of the previous point: We
-     may /never/ float in a call to (something that ultimately calls)
-     'raiseIO#'.
-     See Note [Precise exceptions and strictness analysis] in GHC.Types.Demand.
-
-* Because we can float can-fail primops (array indexing, division) inwards
-  but not outwards, we must be careful not to transform
-     case a /# b of r -> f (F# r)
-  ===>
-    f (case a /# b of r -> F# r)
-  because that creates a new thunk that wasn't there before.  And
-  because it can't be floated out (can_fail), the thunk will stay
-  there.  Disaster!  (This happened in nofib 'simple' and 'scs'.)
-
-  Solution: only float cases into the branches of other cases, and
-  not into the arguments of an application, or the RHS of a let. This
-  is somewhat conservative, but it's simple.  And it still hits the
-  cases like #5658.   This is implemented in sepBindsByJoinPoint;
-  if is_case is False we dump all floating cases right here.
-
-* #14511 is another example of why we want to restrict float-in
-  of case-expressions.  Consider
-     case indexArray# a n of (# r #) -> writeArray# ma i (f r)
-  Now, floating that indexing operation into the (f r) thunk will
-  not create any new thunks, but it will keep the array 'a' alive
-  for much longer than the programmer expected.
-
-  So again, not floating a case into a let or argument seems like
-  the Right Thing
-
-For @Case@, the possible drop points for the 'to_drop'
-bindings are:
-  (a) inside the scrutinee
-  (b) inside one of the alternatives/default (default FVs always /first/!).
-
--}
-
-fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs])
-  | isUnliftedType (idType case_bndr)
-     -- binders have a fixed RuntimeRep so it's OK to call isUnliftedType
-  , exprOkForSideEffects (deAnnotate scrut)
-      -- See Note [Floating primops]
-  = wrapFloats shared_binds $
-    fiExpr platform (case_float : rhs_binds) rhs
-  where
-    case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs
-                    (FloatCase scrut' case_bndr con alt_bndrs)
-    scrut'     = fiExpr platform scrut_binds scrut
-    rhs_fvs    = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)
-    scrut_fvs  = freeVarsOf scrut
-
-    [shared_binds, scrut_binds, rhs_binds]
-       = sepBindsByDropPoint platform False
-           [scrut_fvs, rhs_fvs]
-           to_drop
-
-fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts)
-  = wrapFloats drop_here1 $
-    wrapFloats drop_here2 $
-    Case (fiExpr platform scrut_drops scrut) case_bndr ty
-         (zipWithEqual "fiExpr" fi_alt alts_drops_s alts)
-         -- use zipWithEqual, we should have length alts_drops_s = length alts
-  where
-        -- Float into the scrut and alts-considered-together just like App
-    [drop_here1, scrut_drops, alts_drops]
-       = sepBindsByDropPoint platform False
-           [scrut_fvs, all_alts_fvs]
-           to_drop
-
-        -- Float into the alts with the is_case flag set
-    (drop_here2 : alts_drops_s)
-      | [ _ ] <- alts = [] : [alts_drops]
-      | otherwise     = sepBindsByDropPoint platform True alts_fvs alts_drops
-
-    scrut_fvs    = freeVarsOf scrut
-    alts_fvs     = map alt_fvs alts
-    all_alts_fvs = unionDVarSets alts_fvs
-    alt_fvs (AnnAlt _con args rhs)
-      = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)
-           -- Delete case_bndr and args from free vars of rhs
-           -- to get free vars of alt
-
-    fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs)
-
-------------------
-fiBind :: Platform
-       -> FloatInBinds      -- Binds we're trying to drop
-                            -- as far "inwards" as possible
-       -> CoreBindWithFVs   -- Input binding
-       -> DVarSet           -- Free in scope of binding
-       -> ( FloatInBinds    -- Land these before
-          , FloatInBind     -- The binding itself
-          , FloatInBinds)   -- Land these after
-
-fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs
-  = ( extra_binds ++ shared_binds          -- Land these before
-                                           -- See Note [extra_fvs (1)] and Note [extra_fvs (2)]
-    , FB (unitDVarSet id) rhs_fvs'         -- The new binding itself
-          (FloatLet (NonRec id rhs'))
-    , body_binds )                         -- Land these after
-
-  where
-    body_fvs2 = body_fvs `delDVarSet` id
-
-    rule_fvs = bndrRuleAndUnfoldingVarsDSet id        -- See Note [extra_fvs (2)]
-    extra_fvs | noFloatIntoRhs NonRecursive id rhs
-              = rule_fvs `unionDVarSet` rhs_fvs
-              | otherwise
-              = rule_fvs
-        -- See Note [extra_fvs (1)]
-        -- No point in floating in only to float straight out again
-        -- We *can't* float into ok-for-speculation unlifted RHSs
-        -- But do float into join points
-
-    [shared_binds, extra_binds, rhs_binds, body_binds]
-        = sepBindsByDropPoint platform False
-            [extra_fvs, rhs_fvs, body_fvs2]
-            to_drop
-
-        -- Push rhs_binds into the right hand side of the binding
-    rhs'     = fiRhs platform rhs_binds id ann_rhs
-    rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs
-                        -- Don't forget the rule_fvs; the binding mentions them!
-
-fiBind platform to_drop (AnnRec bindings) body_fvs
-  = ( extra_binds ++ shared_binds
-    , FB (mkDVarSet ids) rhs_fvs'
-         (FloatLet (Rec (fi_bind rhss_binds bindings)))
-    , body_binds )
-  where
-    (ids, rhss) = unzip bindings
-    rhss_fvs = map freeVarsOf rhss
-
-        -- See Note [extra_fvs (1)] and Note [extra_fvs (2)]
-    rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids
-    extra_fvs = rule_fvs `unionDVarSet`
-                unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings
-                              , noFloatIntoRhs Recursive bndr rhs ]
-
-    (shared_binds:extra_binds:body_binds:rhss_binds)
-        = sepBindsByDropPoint platform False
-            (extra_fvs:body_fvs:rhss_fvs)
-            to_drop
-
-    rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet`
-               unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet`
-               rule_fvs         -- Don't forget the rule variables!
-
-    -- Push rhs_binds into the right hand side of the binding
-    fi_bind :: [FloatInBinds]       -- one per "drop pt" conjured w/ fvs_of_rhss
-            -> [(Id, CoreExprWithFVs)]
-            -> [(Id, CoreExpr)]
-
-    fi_bind to_drops pairs
-      = [ (binder, fiRhs platform to_drop binder rhs)
-        | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
-
-------------------
-fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr
-fiRhs platform to_drop bndr rhs
-  | Just join_arity <- isJoinId_maybe bndr
-  , let (bndrs, body) = collectNAnnBndrs join_arity rhs
-  = mkLams bndrs (fiExpr platform to_drop body)
-  | otherwise
-  = fiExpr platform to_drop rhs
-
-------------------
-noFloatIntoLam :: [Var] -> Bool
-noFloatIntoLam bndrs = any bad bndrs
-  where
-    bad b = isId b && not (isOneShotBndr b)
-    -- Don't float inside a non-one-shot lambda
-
-noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool
--- ^ True if it's a bad idea to float bindings into this RHS
-noFloatIntoRhs is_rec bndr rhs
-  | isJoinId bndr
-  = isRec is_rec -- Joins are one-shot iff non-recursive
-
-  | Just Unlifted <- typeLevity_maybe (idType bndr)
-  = True  -- Preserve let-can-float invariant, see Note [noFloatInto considerations]
-
-  | otherwise
-  = noFloatIntoArg rhs
-
-noFloatIntoArg :: CoreExprWithFVs' -> Bool
-noFloatIntoArg expr
-   | AnnLam bndr e <- expr
-   , (bndrs, _) <- collectAnnBndrs e
-   =  noFloatIntoLam (bndr:bndrs)  -- Wrinkle 1 (a)
-   || all isTyVar (bndr:bndrs)     -- Wrinkle 1 (b)
-      -- See Note [noFloatInto considerations] wrinkle 2
-
-  | otherwise  -- See Note [noFloatInto considerations] wrinkle 2
-  = exprIsTrivial deann_expr || exprIsHNF deann_expr
-  where
-    deann_expr = deAnnotate' expr
-
-{- Note [noFloatInto considerations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When do we want to float bindings into
-   - noFloatIntoRhs: the RHS of a let-binding
-   - noFloatIntoArg: the argument of a function application
-
-Definitely don't float into RHS if it has unlifted type;
-that would destroy the let-can-float invariant.
-
-* Wrinkle 1: do not float in if
-     (a) any non-one-shot value lambdas
-  or (b) all type lambdas
-  In both cases we'll float straight back out again
-  NB: Must line up with fiExpr (AnnLam...); see #7088
-
-  (a) is important: we /must/ float into a one-shot lambda group
-  (which includes join points). This makes a big difference
-  for things like
-     f x# = let x = I# x#
-            in let j = \() -> ...x...
-               in if <condition> then normal-path else j ()
-  If x is used only in the error case join point, j, we must float the
-  boxing constructor into it, else we box it every time which is very
-  bad news indeed.
-
-* Wrinkle 2: for RHSs, do not float into a HNF; we'll just float right
-  back out again... not tragic, but a waste of time.
-
-  For function arguments we will still end up with this
-  in-then-out stuff; consider
-    letrec x = e in f x
-  Here x is not a HNF, so we'll produce
-    f (letrec x = e in x)
-  which is OK... it's not that common, and we'll end up
-  floating out again, in CorePrep if not earlier.
-  Still, we use exprIsTrivial to catch this case (sigh)
-
-
-************************************************************************
-*                                                                      *
-\subsection{@sepBindsByDropPoint@}
-*                                                                      *
-************************************************************************
-
-This is the crucial function.  The idea is: We have a wad of bindings
-that we'd like to distribute inside a collection of {\em drop points};
-insides the alternatives of a \tr{case} would be one example of some
-drop points; the RHS and body of a non-recursive \tr{let} binding
-would be another (2-element) collection.
-
-So: We're given a list of sets-of-free-variables, one per drop point,
-and a list of floating-inwards bindings.  If a binding can go into
-only one drop point (without suddenly making something out-of-scope),
-in it goes.  If a binding is used inside {\em multiple} drop points,
-then it has to go in a you-must-drop-it-above-all-these-drop-points
-point.
-
-We have to maintain the order on these drop-point-related lists.
--}
-
--- pprFIB :: FloatInBinds -> SDoc
--- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs]
-
-sepBindsByDropPoint
-    :: Platform
-    -> Bool                -- True <=> is case expression
-    -> [FreeVarSet]        -- One set of FVs per drop point
-                           -- Always at least two long!
-    -> FloatInBinds        -- Candidate floaters
-    -> [FloatInBinds]      -- FIRST one is bindings which must not be floated
-                           -- inside any drop point; the rest correspond
-                           -- one-to-one with the input list of FV sets
-
--- Every input floater is returned somewhere in the result;
--- none are dropped, not even ones which don't seem to be
--- free in *any* of the drop-point fvs.  Why?  Because, for example,
--- a binding (let x = E in B) might have a specialised version of
--- x (say x') stored inside x, but x' isn't free in E or B.
-
-type DropBox = (FreeVarSet, FloatInBinds)
-
-sepBindsByDropPoint platform is_case drop_pts floaters
-  | null floaters  -- Shortcut common case
-  = [] : [[] | _ <- drop_pts]
-
-  | otherwise
-  = assert (drop_pts `lengthAtLeast` 2) $
-    go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))
-  where
-    n_alts = length drop_pts
-
-    go :: FloatInBinds -> [DropBox] -> [FloatInBinds]
-        -- The *first* one in the argument list is the drop_here set
-        -- The FloatInBinds in the lists are in the reverse of
-        -- the normal FloatInBinds order; that is, they are the right way round!
-
-    go [] drop_boxes = map (reverse . snd) drop_boxes
-
-    go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)
-        = go binds new_boxes
-        where
-          -- "here" means the group of bindings dropped at the top of the fork
-
-          (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs
-                                        | (fvs, _) <- drop_boxes]
-
-          drop_here = used_here || cant_push
-
-          n_used_alts = count id used_in_flags -- returns number of Trues in list.
-
-          cant_push
-            | is_case   = n_used_alts == n_alts   -- Used in all, don't push
-                                                  -- Remember n_alts > 1
-                          || (n_used_alts > 1 && not (floatIsDupable platform bind))
-                             -- floatIsDupable: see Note [Duplicating floats]
-
-            | otherwise = floatIsCase bind || n_used_alts > 1
-                             -- floatIsCase: see Note [Floating primops]
-
-          new_boxes | drop_here = (insert here_box : fork_boxes)
-                    | otherwise = (here_box : new_fork_boxes)
-
-          new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe
-                                        fork_boxes used_in_flags
-
-          insert :: DropBox -> DropBox
-          insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops)
-
-          insert_maybe box True  = insert box
-          insert_maybe box False = box
-
-    go _ _ = panic "sepBindsByDropPoint/go"
-
-
-{- Note [Duplicating floats]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For case expressions we duplicate the binding if it is reasonably
-small, and if it is not used in all the RHSs This is good for
-situations like
-     let x = I# y in
-     case e of
-       C -> error x
-       D -> error x
-       E -> ...not mentioning x...
-
-If the thing is used in all RHSs there is nothing gained,
-so we don't duplicate then.
--}
-
-floatedBindsFVs :: FloatInBinds -> FreeVarSet
-floatedBindsFVs binds = mapUnionDVarSet fbFVs binds
-
-fbFVs :: FloatInBind -> DVarSet
-fbFVs (FB _ fvs _) = fvs
-
-wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr
--- Remember FloatInBinds is in *reverse* dependency order
-wrapFloats []               e = e
-wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)
-
-floatIsDupable :: Platform -> FloatBind -> Bool
-floatIsDupable platform (FloatCase scrut _ _ _) = exprIsDupable platform scrut
-floatIsDupable platform (FloatLet (Rec prs))    = all (exprIsDupable platform . snd) prs
-floatIsDupable platform (FloatLet (NonRec _ r)) = exprIsDupable platform r
-
-floatIsCase :: FloatBind -> Bool
-floatIsCase (FloatCase {}) = True
-floatIsCase (FloatLet {})  = False
diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs
deleted file mode 100644
--- a/compiler/GHC/Core/Opt/FloatOut.hs
+++ /dev/null
@@ -1,753 +0,0 @@
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-\section[FloatOut]{Float bindings outwards (towards the top level)}
-
-``Long-distance'' floating of bindings towards the top level.
--}
-
-
-
-module GHC.Core.Opt.FloatOut ( floatOutwards ) where
-
-import GHC.Prelude
-
-import GHC.Core
-import GHC.Core.Utils
-import GHC.Core.Make
--- import GHC.Core.Opt.Arity ( exprArity, etaExpand )
-import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )
-
-import GHC.Driver.Flags  ( DumpFlag (..) )
-import GHC.Utils.Logger
-import GHC.Types.Id      ( Id, idType,
---                           idArity, isDeadEndId,
-                           isJoinId, isJoinId_maybe )
-import GHC.Types.Tickish
-import GHC.Core.Opt.SetLevels
-import GHC.Types.Unique.Supply ( UniqSupply )
-import GHC.Data.Bag
-import GHC.Utils.Misc
-import GHC.Data.Maybe
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Core.Type
-import qualified Data.IntMap as M
-
-import Data.List        ( partition )
-
-{-
-        -----------------
-        Overall game plan
-        -----------------
-
-The Big Main Idea is:
-
-        To float out sub-expressions that can thereby get outside
-        a non-one-shot value lambda, and hence may be shared.
-
-
-To achieve this we may need to do two things:
-
-   a) Let-bind the sub-expression:
-
-        f (g x)  ==>  let lvl = f (g x) in lvl
-
-      Now we can float the binding for 'lvl'.
-
-   b) More than that, we may need to abstract wrt a type variable
-
-        \x -> ... /\a -> let v = ...a... in ....
-
-      Here the binding for v mentions 'a' but not 'x'.  So we
-      abstract wrt 'a', to give this binding for 'v':
-
-            vp = /\a -> ...a...
-            v  = vp a
-
-      Now the binding for vp can float out unimpeded.
-      I can't remember why this case seemed important enough to
-      deal with, but I certainly found cases where important floats
-      didn't happen if we did not abstract wrt tyvars.
-
-With this in mind we can also achieve another goal: lambda lifting.
-We can make an arbitrary (function) binding float to top level by
-abstracting wrt *all* local variables, not just type variables, leaving
-a binding that can be floated right to top level.  Whether or not this
-happens is controlled by a flag.
-
-
-Random comments
-~~~~~~~~~~~~~~~
-
-At the moment we never float a binding out to between two adjacent
-lambdas.  For example:
-
-@
-        \x y -> let t = x+x in ...
-===>
-        \x -> let t = x+x in \y -> ...
-@
-Reason: this is less efficient in the case where the original lambda
-is never partially applied.
-
-But there's a case I've seen where this might not be true.  Consider:
-@
-elEm2 x ys
-  = elem' x ys
-  where
-    elem' _ []  = False
-    elem' x (y:ys)      = x==y || elem' x ys
-@
-It turns out that this generates a subexpression of the form
-@
-        \deq x ys -> let eq = eqFromEqDict deq in ...
-@
-which might usefully be separated to
-@
-        \deq -> let eq = eqFromEqDict deq in \xy -> ...
-@
-Well, maybe.  We don't do this at the moment.
-
-Note [Join points]
-~~~~~~~~~~~~~~~~~~
-Every occurrence of a join point must be a tail call (see Note [Invariants on
-join points] in GHC.Core), so we must be careful with how far we float them. The
-mechanism for doing so is the *join ceiling*, detailed in Note [Join ceiling]
-in GHC.Core.Opt.SetLevels. For us, the significance is that a binder might be marked to be
-dropped at the nearest boundary between tail calls and non-tail calls. For
-example:
-
-  (< join j = ... in
-     let x = < ... > in
-     case < ... > of
-       A -> ...
-       B -> ...
-   >) < ... > < ... >
-
-Here the join ceilings are marked with angle brackets. Either side of an
-application is a join ceiling, as is the scrutinee position of a case
-expression or the RHS of a let binding (but not a join point).
-
-Why do we *want* do float join points at all? After all, they're never
-allocated, so there's no sharing to be gained by floating them. However, the
-other benefit of floating is making RHSes small, and this can have a significant
-impact. In particular, stream fusion has been known to produce nested loops like
-this:
-
-  joinrec j1 x1 =
-    joinrec j2 x2 =
-      joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...
-      in jump j3 x2
-    in jump j2 x1
-  in jump j1 x
-
-(Assume x1 and x2 do *not* occur free in j3.)
-
-Here j1 and j2 are wholly superfluous---each of them merely forwards its
-argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make
-everything one big mutual recursion:
-
-  joinrec j1 x1 = jump j2 x1
-          j2 x2 = jump j3 x2
-          j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...
-  in jump j1 x
-
-Now the simplifier will happily inline the trivial j1 and j2, leaving only j3.
-Without floating, we're stuck with three loops instead of one.
-
-************************************************************************
-*                                                                      *
-\subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
-*                                                                      *
-************************************************************************
--}
-
-floatOutwards :: Logger
-              -> FloatOutSwitches
-              -> UniqSupply
-              -> CoreProgram -> IO CoreProgram
-
-floatOutwards logger float_sws us pgm
-  = do {
-        let { annotated_w_levels = setLevels float_sws pgm us ;
-              (fss, binds_s')    = unzip (map floatTopBind annotated_w_levels)
-            } ;
-
-        putDumpFileMaybe logger Opt_D_verbose_core2core "Levels added:"
-                  FormatCore
-                  (vcat (map ppr annotated_w_levels));
-
-        let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
-
-        putDumpFileMaybe logger Opt_D_dump_simpl_stats "FloatOut stats:"
-                FormatText
-                (hcat [ int tlets,  text " Lets floated to top level; ",
-                        int ntlets, text " Lets floated elsewhere; from ",
-                        int lams,   text " Lambda groups"]);
-
-        return (bagToList (unionManyBags binds_s'))
-    }
-
-floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind)
-floatTopBind bind
-  = case (floatBind bind) of { (fs, floats, bind') ->
-    let float_bag = flattenTopFloats floats
-    in case bind' of
-      -- bind' can't have unlifted values or join points, so can only be one
-      -- value bind, rec or non-rec (see comment on floatBind)
-      [Rec prs]    -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs)))
-      [NonRec b e] -> (fs, float_bag `snocBag` NonRec b e)
-      _            -> pprPanic "floatTopBind" (ppr bind') }
-
-{-
-************************************************************************
-*                                                                      *
-\subsection[FloatOut-Bind]{Floating in a binding (the business end)}
-*                                                                      *
-************************************************************************
--}
-
-floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind])
-  -- Returns a list with either
-  --   * A single non-recursive binding (value or join point), or
-  --   * The following, in order:
-  --     * Zero or more non-rec unlifted bindings
-  --     * One or both of:
-  --       * A recursive group of join binds
-  --       * A recursive group of value binds
-  -- See Note [Floating out of Rec rhss] for why things get arranged this way.
-floatBind (NonRec (TB var _) rhs)
-  = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') ->
-      (fs, rhs_floats, [NonRec var rhs']) }
-
-floatBind (Rec pairs)
-  = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) ->
-    let (new_ul_pairss, new_other_pairss) = unzip new_pairs
-        (new_join_pairs, new_l_pairs)     = partition (isJoinId . fst)
-                                                      (concat new_other_pairss)
-        -- Can't put the join points and the values in the same rec group
-        new_rec_binds | null new_join_pairs = [ Rec new_l_pairs    ]
-                      | null new_l_pairs    = [ Rec new_join_pairs ]
-                      | otherwise           = [ Rec new_l_pairs
-                                              , Rec new_join_pairs ]
-        new_non_rec_binds = [ NonRec b e | (b, e) <- concat new_ul_pairss ]
-    in
-    (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) }
-  where
-    do_pair :: (LevelledBndr, LevelledExpr)
-            -> (FloatStats, FloatBinds,
-                ([(Id,CoreExpr)],  -- Non-recursive unlifted value bindings
-                 [(Id,CoreExpr)])) -- Join points and lifted value bindings
-    do_pair (TB name spec, rhs)
-      | isTopLvl dest_lvl  -- See Note [floatBind for top level]
-      = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->
-        (fs, emptyFloats, ([], addTopFloatPairs (flattenTopFloats rhs_floats)
-                                                [(name, rhs')]))}
-      | otherwise         -- Note [Floating out of Rec rhss]
-      = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->
-        case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) ->
-        case (splitRecFloats heres) of { (ul_pairs, pairs, case_heres) ->
-        let pairs' = (name, installUnderLambdas case_heres rhs') : pairs in
-        (fs, rhs_floats', (ul_pairs, pairs')) }}}
-      where
-        dest_lvl = floatSpecLevel spec
-
-splitRecFloats :: Bag FloatBind
-               -> ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings
-                   [(Id,CoreExpr)], -- Join points and lifted value bindings
-                   Bag FloatBind)   -- A tail of further bindings
--- The "tail" begins with a case
--- See Note [Floating out of Rec rhss]
-splitRecFloats fs
-  = go [] [] (bagToList fs)
-  where
-    go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b)
-                                               -- NB: isUnliftedType is OK here as binders always
-                                               -- have a fixed RuntimeRep.
-                                               , not (isJoinId b)
-                                               = go ((b,r):ul_prs) prs fs
-                                               | otherwise
-                                               = go ul_prs ((b,r):prs) fs
-    go ul_prs prs (FloatLet (Rec prs')   : fs) = go ul_prs (prs' ++ prs) fs
-    go ul_prs prs fs                           = (reverse ul_prs, prs,
-                                                  listToBag fs)
-                                                   -- Order only matters for
-                                                   -- non-rec
-
-installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr
--- See Note [Floating out of Rec rhss]
-installUnderLambdas floats e
-  | isEmptyBag floats = e
-  | otherwise         = go e
-  where
-    go (Lam b e)                 = Lam b (go e)
-    go e                         = install floats e
-
----------------
-floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
-floatList _ [] = (zeroStats, emptyFloats, [])
-floatList f (a:as) = case f a            of { (fs_a,  binds_a,  b)  ->
-                     case floatList f as of { (fs_as, binds_as, bs) ->
-                     (fs_a `add_stats` fs_as, binds_a `plusFloats`  binds_as, b:bs) }}
-
-{-
-Note [Floating out of Rec rhss]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider   Rec { f<1,0> = \xy. body }
-From the body we may get some floats. The ones with level <1,0> must
-stay here, since they may mention f.  Ideally we'd like to make them
-part of the Rec block pairs -- but we can't if there are any
-FloatCases involved.
-
-Nor is it a good idea to dump them in the rhs, but outside the lambda
-    f = case x of I# y -> \xy. body
-because now f's arity might get worse, which is Not Good. (And if
-there's an SCC around the RHS it might not get better again.
-See #5342.)
-
-So, gruesomely, we split the floats into
- * the outer FloatLets, which can join the Rec, and
- * an inner batch starting in a FloatCase, which are then
-   pushed *inside* the lambdas.
-This loses full-laziness the rare situation where there is a
-FloatCase and a Rec interacting.
-
-If there are unlifted FloatLets (that *aren't* join points) among the floats,
-we can't add them to the recursive group without angering Core Lint, but since
-they must be ok-for-speculation, they can't actually be making any recursive
-calls, so we can safely pull them out and keep them non-recursive.
-
-(Why is something getting floated to <1,0> that doesn't make a recursive call?
-The case that came up in testing was that f *and* the unlifted binding were
-getting floated *to the same place*:
-
-  \x<2,0> ->
-    ... <3,0>
-    letrec { f<F<2,0>> =
-      ... let x'<F<2,0>> = x +# 1# in ...
-    } in ...
-
-Everything gets labeled "float to <2,0>" because it all depends on x, but this
-makes f and x' look mutually recursive when they're not.
-
-The test was shootout/k-nucleotide, as compiled using commit 47d5dd68 on the
-wip/join-points branch.
-
-TODO: This can probably be solved somehow in GHC.Core.Opt.SetLevels. The difference between
-"this *is at* level <2,0>" and "this *depends on* level <2,0>" is very
-important.)
-
-Note [floatBind for top level]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus
-         letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... }
-The binding for bar will be in the "tops" part of the floating binds,
-and thus not partitioned by floatBody.
-
-We could perhaps get rid of the 'tops' component of the floating binds,
-but this case works just as well.
-
-
-************************************************************************
-
-\subsection[FloatOut-Expr]{Floating in expressions}
-*                                                                      *
-************************************************************************
--}
-
-floatBody :: Level
-          -> LevelledExpr
-          -> (FloatStats, FloatBinds, CoreExpr)
-
-floatBody lvl arg       -- Used rec rhss, and case-alternative rhss
-  = case (floatExpr arg) of { (fsa, floats, arg') ->
-    case (partitionByLevel lvl floats) of { (floats', heres) ->
-        -- Dump bindings are bound here
-    (fsa, floats', install heres arg') }}
-
------------------
-
-{- Note [Floating past breakpoints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We used to disallow floating out of breakpoint ticks (see #10052). However, I
-think this is too restrictive.
-
-Consider the case of an expression scoped over by a breakpoint tick,
-
-  tick<...> (let x = ... in f x)
-
-In this case it is completely legal to float out x, despite the fact that
-breakpoint ticks are scoped,
-
-  let x = ... in (tick<...>  f x)
-
-The reason here is that we know that the breakpoint will still be hit when the
-expression is entered since the tick still scopes over the RHS.
-
--}
-
-floatExpr :: LevelledExpr
-          -> (FloatStats, FloatBinds, CoreExpr)
-floatExpr (Var v)   = (zeroStats, emptyFloats, Var v)
-floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty)
-floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co)
-floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit)
-
-floatExpr (App e a)
-  = case (atJoinCeiling $ floatExpr  e) of { (fse, floats_e, e') ->
-    case (atJoinCeiling $ floatExpr  a) of { (fsa, floats_a, a') ->
-    (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}
-
-floatExpr lam@(Lam (TB _ lam_spec) _)
-  = let (bndrs_w_lvls, body) = collectBinders lam
-        bndrs                = [b | TB b _ <- bndrs_w_lvls]
-        bndr_lvl             = asJoinCeilLvl (floatSpecLevel lam_spec)
-        -- All the binders have the same level
-        -- See GHC.Core.Opt.SetLevels.lvlLamBndrs
-        -- Use asJoinCeilLvl to make this the join ceiling
-    in
-    case (floatBody bndr_lvl body) of { (fs, floats, body') ->
-    (add_to_stats fs floats, floats, mkLams bndrs body') }
-
-floatExpr (Tick tickish expr)
-  | tickish `tickishScopesLike` SoftScope -- not scoped, can just float
-  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->
-    (fs, floating_defns, Tick tickish expr') }
-
-  | not (tickishCounts tickish) || tickishCanSplit tickish
-  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->
-    let -- Annotate bindings floated outwards past an scc expression
-        -- with the cc.  We mark that cc as "duplicated", though.
-        annotated_defns = wrapTick (mkNoCount tickish) floating_defns
-    in
-    (fs, annotated_defns, Tick tickish expr') }
-
-  -- See Note [Floating past breakpoints]
-  | Breakpoint{} <- tickish
-  = case (floatExpr expr)    of { (fs, floating_defns, expr') ->
-    (fs, floating_defns, Tick tickish expr') }
-
-  | otherwise
-  = pprPanic "floatExpr tick" (ppr tickish)
-
-floatExpr (Cast expr co)
-  = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') ->
-    (fs, floating_defns, Cast expr' co) }
-
-floatExpr (Let bind body)
-  = case bind_spec of
-      FloatMe dest_lvl
-        -> case (floatBind bind) of { (fsb, bind_floats, binds') ->
-           case (floatExpr body) of { (fse, body_floats, body') ->
-           let new_bind_floats = foldr plusFloats emptyFloats
-                                   (map (unitLetFloat dest_lvl) binds') in
-           ( add_stats fsb fse
-           , bind_floats `plusFloats` new_bind_floats
-                         `plusFloats` body_floats
-           , body') }}
-
-      StayPut bind_lvl  -- See Note [Avoiding unnecessary floating]
-        -> case (floatBind bind)          of { (fsb, bind_floats, binds') ->
-           case (floatBody bind_lvl body) of { (fse, body_floats, body') ->
-           ( add_stats fsb fse
-           , bind_floats `plusFloats` body_floats
-           , foldr Let body' binds' ) }}
-  where
-    bind_spec = case bind of
-                 NonRec (TB _ s) _     -> s
-                 Rec ((TB _ s, _) : _) -> s
-                 Rec []                -> panic "floatExpr:rec"
-
-floatExpr (Case scrut (TB case_bndr case_spec) ty alts)
-  = case case_spec of
-      FloatMe dest_lvl  -- Case expression moves
-        | [Alt con@(DataAlt {}) bndrs rhs] <- alts
-        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->
-           case                 floatExpr rhs   of { (fsb, fdb, rhs') ->
-           let
-             float = unitCaseFloat dest_lvl scrut'
-                          case_bndr con [b | TB b _ <- bndrs]
-           in
-           (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }}
-        | otherwise
-        -> pprPanic "Floating multi-case" (ppr alts)
-
-      StayPut bind_lvl  -- Case expression stays put
-        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->
-           case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts')  ->
-           (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')
-           }}
-  where
-    float_alt bind_lvl (Alt con bs rhs)
-        = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') ->
-          (fs, rhs_floats, Alt con [b | TB b _ <- bs] rhs') }
-
-floatRhs :: CoreBndr
-         -> LevelledExpr
-         -> (FloatStats, FloatBinds, CoreExpr)
-floatRhs bndr rhs
-  | Just join_arity <- isJoinId_maybe bndr
-  , Just (bndrs, body) <- try_collect join_arity rhs []
-  = case bndrs of
-      []                -> floatExpr rhs
-      (TB _ lam_spec):_ ->
-        let lvl = floatSpecLevel lam_spec in
-        case floatBody lvl body of { (fs, floats, body') ->
-        (fs, floats, mkLams [b | TB b _ <- bndrs] body') }
-  | otherwise
-  = atJoinCeiling $ floatExpr rhs
-  where
-    try_collect 0 expr      acc = Just (reverse acc, expr)
-    try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc)
-    try_collect _ _         _   = Nothing
-
-{-
-Note [Avoiding unnecessary floating]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In general we want to avoid floating a let unnecessarily, because
-it might worsen strictness:
-    let
-       x = ...(let y = e in y+y)....
-Here y is demanded.  If we float it outside the lazy 'x=..' then
-we'd have to zap its demand info, and it may never be restored.
-
-So at a 'let' we leave the binding right where the are unless
-the binding will escape a value lambda, e.g.
-
-(\x -> let y = fac 100 in y)
-
-That's what the partitionByMajorLevel does in the floatExpr (Let ...)
-case.
-
-Notice, though, that we must take care to drop any bindings
-from the body of the let that depend on the staying-put bindings.
-
-We used instead to do the partitionByMajorLevel on the RHS of an '=',
-in floatRhs.  But that was quite tiresome.  We needed to test for
-values or trivial rhss, because (in particular) we don't want to insert
-new bindings between the "=" and the "\".  E.g.
-        f = \x -> let <bind> in <body>
-We do not want
-        f = let <bind> in \x -> <body>
-(a) The simplifier will immediately float it further out, so we may
-        as well do so right now; in general, keeping rhss as manifest
-        values is good
-(b) If a float-in pass follows immediately, it might add yet more
-        bindings just after the '='.  And some of them might (correctly)
-        be strict even though the 'let f' is lazy, because f, being a value,
-        gets its demand-info zapped by the simplifier.
-And even all that turned out to be very fragile, and broke
-altogether when profiling got in the way.
-
-So now we do the partition right at the (Let..) itself.
-
-************************************************************************
-*                                                                      *
-\subsection{Utility bits for floating stats}
-*                                                                      *
-************************************************************************
-
-I didn't implement this with unboxed numbers.  I don't want to be too
-strict in this stuff, as it is rarely turned on.  (WDP 95/09)
--}
-
-data FloatStats
-  = FlS Int  -- Number of top-floats * lambda groups they've been past
-        Int  -- Number of non-top-floats * lambda groups they've been past
-        Int  -- Number of lambda (groups) seen
-
-get_stats :: FloatStats -> (Int, Int, Int)
-get_stats (FlS a b c) = (a, b, c)
-
-zeroStats :: FloatStats
-zeroStats = FlS 0 0 0
-
-sum_stats :: [FloatStats] -> FloatStats
-sum_stats xs = foldr add_stats zeroStats xs
-
-add_stats :: FloatStats -> FloatStats -> FloatStats
-add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
-  = FlS (a1 + a2) (b1 + b2) (c1 + c2)
-
-add_to_stats :: FloatStats -> FloatBinds -> FloatStats
-add_to_stats (FlS a b c) (FB tops ceils others)
-  = FlS (a + lengthBag tops)
-        (b + lengthBag ceils + lengthBag (flattenMajor others))
-        (c + 1)
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Utility bits for floating}
-*                                                                      *
-************************************************************************
-
-Note [Representation of FloatBinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The FloatBinds types is somewhat important.  We can get very large numbers
-of floating bindings, often all destined for the top level.  A typical example
-is     x = [4,2,5,2,5, .... ]
-Then we get lots of small expressions like (fromInteger 4), which all get
-lifted to top level.
-
-The trouble is that
-  (a) we partition these floating bindings *at every binding site*
-  (b) GHC.Core.Opt.SetLevels introduces a new bindings site for every float
-So we had better not look at each binding at each binding site!
-
-That is why MajorEnv is represented as a finite map.
-
-We keep the bindings destined for the *top* level separate, because
-we float them out even if they don't escape a *value* lambda; see
-partitionByMajorLevel.
--}
-
-type FloatLet = CoreBind        -- INVARIANT: a FloatLet is always lifted
-type MajorEnv = M.IntMap MinorEnv         -- Keyed by major level
-type MinorEnv = M.IntMap (Bag FloatBind)  -- Keyed by minor level
-
-data FloatBinds  = FB !(Bag FloatLet)           -- Destined for top level
-                      !(Bag FloatBind)          -- Destined for join ceiling
-                      !MajorEnv                 -- Other levels
-     -- See Note [Representation of FloatBinds]
-
-instance Outputable FloatBinds where
-  ppr (FB fbs ceils defs)
-      = text "FB" <+> (braces $ vcat
-           [ text "tops ="     <+> ppr fbs
-           , text "ceils ="    <+> ppr ceils
-           , text "non-tops =" <+> ppr defs ])
-
-flattenTopFloats :: FloatBinds -> Bag CoreBind
-flattenTopFloats (FB tops ceils defs)
-  = assertPpr (isEmptyBag (flattenMajor defs)) (ppr defs) $
-    assertPpr (isEmptyBag ceils) (ppr ceils)
-    tops
-
-addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
-addTopFloatPairs float_bag prs
-  = foldr add prs float_bag
-  where
-    add (NonRec b r) prs  = (b,r):prs
-    add (Rec prs1)   prs2 = prs1 ++ prs2
-
-flattenMajor :: MajorEnv -> Bag FloatBind
-flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag
-
-flattenMinor :: MinorEnv -> Bag FloatBind
-flattenMinor = M.foldr unionBags emptyBag
-
-emptyFloats :: FloatBinds
-emptyFloats = FB emptyBag emptyBag M.empty
-
-unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds
-unitCaseFloat (Level major minor t) e b con bs
-  | t == JoinCeilLvl
-  = FB emptyBag floats M.empty
-  | otherwise
-  = FB emptyBag emptyBag (M.singleton major (M.singleton minor floats))
-  where
-    floats = unitBag (FloatCase e b con bs)
-
-unitLetFloat :: Level -> FloatLet -> FloatBinds
-unitLetFloat lvl@(Level major minor t) b
-  | isTopLvl lvl     = FB (unitBag b) emptyBag M.empty
-  | t == JoinCeilLvl = FB emptyBag floats M.empty
-  | otherwise        = FB emptyBag emptyBag (M.singleton major
-                                              (M.singleton minor floats))
-  where
-    floats = unitBag (FloatLet b)
-
-plusFloats :: FloatBinds -> FloatBinds -> FloatBinds
-plusFloats (FB t1 c1 l1) (FB t2 c2 l2)
-  = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2)
-
-plusMajor :: MajorEnv -> MajorEnv -> MajorEnv
-plusMajor = M.unionWith plusMinor
-
-plusMinor :: MinorEnv -> MinorEnv -> MinorEnv
-plusMinor = M.unionWith unionBags
-
-install :: Bag FloatBind -> CoreExpr -> CoreExpr
-install defn_groups expr
-  = foldr wrapFloat expr defn_groups
-
-partitionByLevel
-        :: Level                -- Partitioning level
-        -> FloatBinds           -- Defns to be divided into 2 piles...
-        -> (FloatBinds,         -- Defns  with level strictly < partition level,
-            Bag FloatBind)      -- The rest
-
-{-
---       ---- partitionByMajorLevel ----
--- Float it if we escape a value lambda,
---     *or* if we get to the top level
---     *or* if it's a case-float and its minor level is < current
---
--- If we can get to the top level, say "yes" anyway. This means that
---      x = f e
--- transforms to
---    lvl = e
---    x = f lvl
--- which is as it should be
-
-partitionByMajorLevel (Level major _) (FB tops defns)
-  = (FB tops outer, heres `unionBags` flattenMajor inner)
-  where
-    (outer, mb_heres, inner) = M.splitLookup major defns
-    heres = case mb_heres of
-               Nothing -> emptyBag
-               Just h  -> flattenMinor h
--}
-
-partitionByLevel (Level major minor typ) (FB tops ceils defns)
-  = (FB tops ceils' (outer_maj `plusMajor` M.singleton major outer_min),
-     here_min `unionBags` here_ceil
-              `unionBags` flattenMinor inner_min
-              `unionBags` flattenMajor inner_maj)
-
-  where
-    (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns
-    (outer_min, mb_here_min, inner_min) = case mb_here_maj of
-                                            Nothing -> (M.empty, Nothing, M.empty)
-                                            Just min_defns -> M.splitLookup minor min_defns
-    here_min = mb_here_min `orElse` emptyBag
-    (here_ceil, ceils') | typ == JoinCeilLvl = (ceils, emptyBag)
-                        | otherwise          = (emptyBag, ceils)
-
--- Like partitionByLevel, but instead split out the bindings that are marked
--- to float to the nearest join ceiling (see Note [Join points])
-partitionAtJoinCeiling :: FloatBinds -> (FloatBinds, Bag FloatBind)
-partitionAtJoinCeiling (FB tops ceils defs)
-  = (FB tops emptyBag defs, ceils)
-
--- Perform some action at a join ceiling, i.e., don't let join points float out
--- (see Note [Join points])
-atJoinCeiling :: (FloatStats, FloatBinds, CoreExpr)
-              -> (FloatStats, FloatBinds, CoreExpr)
-atJoinCeiling (fs, floats, expr')
-  = (fs, floats', install ceils expr')
-  where
-    (floats', ceils) = partitionAtJoinCeiling floats
-
-wrapTick :: CoreTickish -> FloatBinds -> FloatBinds
-wrapTick t (FB tops ceils defns)
-  = FB (mapBag wrap_bind tops) (wrap_defns ceils)
-       (M.map (M.map wrap_defns) defns)
-  where
-    wrap_defns = mapBag wrap_one
-
-    wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs)
-    wrap_bind (Rec pairs)         = Rec (mapSnd maybe_tick pairs)
-
-    wrap_one (FloatLet bind)      = FloatLet (wrap_bind bind)
-    wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs
-
-    maybe_tick e | exprIsHNF e = tickHNFArgs t e
-                 | otherwise   = mkTick t e
-      -- we don't need to wrap a tick around an HNF when we float it
-      -- outside a tick: that is an invariant of the tick semantics
-      -- Conversely, inlining of HNFs inside an SCC is allowed, and
-      -- indeed the HNF we're floating here might well be inlined back
-      -- again, and we don't want to end up with duplicate ticks.
diff --git a/compiler/GHC/Core/Opt/LiberateCase.hs b/compiler/GHC/Core/Opt/LiberateCase.hs
deleted file mode 100644
--- a/compiler/GHC/Core/Opt/LiberateCase.hs
+++ /dev/null
@@ -1,459 +0,0 @@
-{-
-(c) The AQUA Project, Glasgow University, 1994-1998
-
-\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
--}
-
-
-module GHC.Core.Opt.LiberateCase
-  ( LibCaseOpts(..)
-  , liberateCase
-  ) where
-
-import GHC.Prelude
-
-import GHC.Core
-import GHC.Core.Unfold
-import GHC.Builtin.Types ( unitDataConId )
-import GHC.Types.Id
-import GHC.Types.Var.Env
-import GHC.Utils.Misc    ( notNull )
-
-{-
-The liberate-case transformation
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This module walks over @Core@, and looks for @case@ on free variables.
-The criterion is:
-        if there is case on a free on the route to the recursive call,
-        then the recursive call is replaced with an unfolding.
-
-Example
-
-   f = \ t -> case v of
-                 V a b -> a : f t
-
-=> the inner f is replaced.
-
-   f = \ t -> case v of
-                 V a b -> a : (letrec
-                                f =  \ t -> case v of
-                                               V a b -> a : f t
-                               in f) t
-(note the NEED for shadowing)
-
-=> Simplify
-
-  f = \ t -> case v of
-                 V a b -> a : (letrec
-                                f = \ t -> a : f t
-                               in f t)
-
-Better code, because 'a' is  free inside the inner letrec, rather
-than needing projection from v.
-
-Note that this deals with *free variables*.  SpecConstr deals with
-*arguments* that are of known form.  E.g.
-
-        last []     = error
-        last (x:[]) = x
-        last (x:xs) = last xs
-
-
-Note [Scrutinee with cast]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this:
-    f = \ t -> case (v `cast` co) of
-                 V a b -> a : f t
-
-Exactly the same optimisation (unrolling one call to f) will work here,
-despite the cast.  See mk_alt_env in the Case branch of libCase.
-
-
-To think about (Apr 94)
-~~~~~~~~~~~~~~
-Main worry: duplicating code excessively.  At the moment we duplicate
-the entire binding group once at each recursive call.  But there may
-be a group of recursive calls which share a common set of evaluated
-free variables, in which case the duplication is a plain waste.
-
-Another thing we could consider adding is some unfold-threshold thing,
-so that we'll only duplicate if the size of the group rhss isn't too
-big.
-
-Data types
-~~~~~~~~~~
-The ``level'' of a binder tells how many
-recursive defns lexically enclose the binding
-A recursive defn "encloses" its RHS, not its
-scope.  For example:
-\begin{verbatim}
-        letrec f = let g = ... in ...
-        in
-        let h = ...
-        in ...
-\end{verbatim}
-Here, the level of @f@ is zero, the level of @g@ is one,
-and the level of @h@ is zero (NB not one).
-
-
-************************************************************************
-*                                                                      *
-         Top-level code
-*                                                                      *
-************************************************************************
--}
-
-liberateCase :: LibCaseOpts -> CoreProgram -> CoreProgram
-liberateCase opts binds = do_prog (initLiberateCaseEnv opts) binds
-  where
-    do_prog _   [] = []
-    do_prog env (bind:binds) = bind' : do_prog env' binds
-                             where
-                               (env', bind') = libCaseBind env bind
-
-initLiberateCaseEnv :: LibCaseOpts -> LibCaseEnv
-initLiberateCaseEnv opts = LibCaseEnv
-   { lc_opts      = opts
-   , lc_lvl       = 0
-   , lc_lvl_env   = emptyVarEnv
-   , lc_rec_env   = emptyVarEnv
-   , lc_scruts    = []
-   }
-
-{-
-************************************************************************
-*                                                                      *
-         Main payload
-*                                                                      *
-************************************************************************
-
-Bindings
-~~~~~~~~
--}
-
-libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)
-
-libCaseBind env (NonRec binder rhs)
-  = (addBinders env [binder], NonRec binder (libCase env rhs))
-
-libCaseBind env (Rec pairs)
-  = (env_body, Rec pairs')
-  where
-    binders = map fst pairs
-
-    env_body = addBinders env binders
-
-    pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs]
-
-        -- We extend the rec-env by binding each Id to its rhs, first
-        -- processing the rhs with an *un-extended* environment, so
-        -- that the same process doesn't occur for ever!
-    env_rhs | is_dupable_bind = addRecBinds env dup_pairs
-            | otherwise       = env
-
-    dup_pairs = [ (localiseId binder, libCase env_body rhs)
-                | (binder, rhs) <- pairs ]
-        -- localiseID : see Note [Need to localiseId in libCaseBind]
-
-    is_dupable_bind = small_enough && all ok_pair pairs
-
-    -- Size: we are going to duplicate dup_pairs; to find their
-    --       size, build a fake binding (let { dup_pairs } in (),
-    --       and find the size of that
-    -- See Note [Small enough]
-    small_enough = case lc_threshold env of
-                      Nothing   -> True   -- Infinity
-                      Just size -> couldBeSmallEnoughToInline (lc_uf_opts env) size $
-                                   Let (Rec dup_pairs) (Var unitDataConId)
-
-    ok_pair (id,_)
-        =  idArity id > 0       -- Note [Only functions!]
-        && not (isDeadEndId id) -- Note [Not bottoming Ids]
-
-{- Note [Not bottoming Ids]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Do not specialise error-functions (this is unusual, but I once saw it,
-(actually in Data.Typeable.Internal)
-
-Note [Only functions!]
-~~~~~~~~~~~~~~~~~~~~~~
-Consider the following code
-
-       f = g (case v of V a b -> a : t f)
-
-where g is expensive. If we aren't careful, liberate case will turn this into
-
-       f = g (case v of
-               V a b -> a : t (letrec f = g (case v of V a b -> a : f t)
-                                in f)
-             )
-
-Yikes! We evaluate g twice. This leads to a O(2^n) explosion
-if g calls back to the same code recursively.
-
-Solution: make sure that we only do the liberate-case thing on *functions*
-
-Note [Small enough]
-~~~~~~~~~~~~~~~~~~~
-Consider
-  \fv. letrec
-         f = \x. BIG...(case fv of { (a,b) -> ...g.. })...
-         g = \y. SMALL...f...
-
-Then we *can* in principle do liberate-case on 'g' (small RHS) but not
-for 'f' (too big).  But doing so is not profitable, because duplicating
-'g' at its call site in 'f' doesn't get rid of any cases.  So we just
-ask for the whole group to be small enough.
-
-Note [Need to localiseId in libCaseBind]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The call to localiseId is needed for two subtle reasons
-(a)  Reset the export flags on the binders so
-        that we don't get name clashes on exported things if the
-        local binding floats out to top level.  This is most unlikely
-        to happen, since the whole point concerns free variables.
-        But resetting the export flag is right regardless.
-
-(b)  Make the name an Internal one.  External Names should never be
-        nested; if it were floated to the top level, we'd get a name
-        clash at code generation time.
-
-Expressions
-~~~~~~~~~~~
--}
-
-libCase :: LibCaseEnv
-        -> CoreExpr
-        -> CoreExpr
-
-libCase env (Var v)             = libCaseApp env v []
-libCase _   (Lit lit)           = Lit lit
-libCase _   (Type ty)           = Type ty
-libCase _   (Coercion co)       = Coercion co
-libCase env e@(App {})          | let (fun, args) = collectArgs e
-                                , Var v <- fun
-                                = libCaseApp env v args
-libCase env (App fun arg)       = App (libCase env fun) (libCase env arg)
-libCase env (Tick tickish body) = Tick tickish (libCase env body)
-libCase env (Cast e co)         = Cast (libCase env e) co
-
-libCase env (Lam binder body)
-  = Lam binder (libCase (addBinders env [binder]) body)
-
-libCase env (Let bind body)
-  = Let bind' (libCase env_body body)
-  where
-    (env_body, bind') = libCaseBind env bind
-
-libCase env (Case scrut bndr ty alts)
-  = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)
-  where
-    env_alts = addBinders (mk_alt_env scrut) [bndr]
-    mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var
-    mk_alt_env (Cast scrut _)  = mk_alt_env scrut       -- Note [Scrutinee with cast]
-    mk_alt_env _               = env
-
-libCaseAlt :: LibCaseEnv -> Alt CoreBndr -> Alt CoreBndr
-libCaseAlt env (Alt con args rhs) = Alt con args (libCase (addBinders env args) rhs)
-
-{-
-Ids
-~~~
-
-To unfold, we can't just wrap the id itself in its binding if it's a join point:
-
-  jump j a b c  =>  (joinrec j x y z = ... in jump j) a b c -- wrong!!!
-
-Every jump must provide all arguments, so we have to be careful to wrap the
-whole jump instead:
-
-  jump j a b c  =>  joinrec j x y z = ... in jump j a b c -- right
-
--}
-
-libCaseApp :: LibCaseEnv -> Id -> [CoreExpr] -> CoreExpr
-libCaseApp env v args
-  | Just the_bind <- lookupRecId env v  -- It's a use of a recursive thing
-  , notNull free_scruts                 -- with free vars scrutinised in RHS
-  = Let the_bind expr'
-
-  | otherwise
-  = expr'
-
-  where
-    rec_id_level = lookupLevel env v
-    free_scruts  = freeScruts env rec_id_level
-    expr'        = mkApps (Var v) (map (libCase env) args)
-
-freeScruts :: LibCaseEnv
-           -> LibCaseLevel      -- Level of the recursive Id
-           -> [Id]              -- Ids that are scrutinised between the binding
-                                -- of the recursive Id and here
-freeScruts env rec_bind_lvl
-  = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env
-       , scrut_bind_lvl <= rec_bind_lvl
-       , scrut_at_lvl > rec_bind_lvl]
-        -- Note [When to specialise]
-        -- Note [Avoiding fruitless liberate-case]
-
-{-
-Note [When to specialise]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  f = \x. letrec g = \y. case x of
-                           True  -> ... (f a) ...
-                           False -> ... (g b) ...
-
-We get the following levels
-          f  0
-          x  1
-          g  1
-          y  2
-
-Then 'x' is being scrutinised at a deeper level than its binding, so
-it's added to lc_sruts:  [(x,1)]
-
-We do *not* want to specialise the call to 'f', because 'x' is not free
-in 'f'.  So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0).
-
-We *do* want to specialise the call to 'g', because 'x' is free in g.
-Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1).
-
-Note [Avoiding fruitless liberate-case]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider also:
-  f = \x. case top_lvl_thing of
-                I# _ -> let g = \y. ... g ...
-                        in ...
-
-Here, top_lvl_thing is scrutinised at a level (1) deeper than its
-binding site (0).  Nevertheless, we do NOT want to specialise the call
-to 'g' because all the structure in its free variables is already
-visible at the definition site for g.  Hence, when considering specialising
-an occurrence of 'g', we want to check that there's a scruted-var v st
-
-   a) v's binding site is *outside* g
-   b) v's scrutinisation site is *inside* g
-
-
-************************************************************************
-*                                                                      *
-        Utility functions
-*                                                                      *
-************************************************************************
--}
-
-addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv
-addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders
-  = env { lc_lvl_env = lvl_env' }
-  where
-    lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl)
-
-addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
-addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env,
-                             lc_rec_env = rec_env}) pairs
-  = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' }
-  where
-    lvl'     = lvl + 1
-    lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
-    rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]
-
-addScrutedVar :: LibCaseEnv
-              -> Id             -- This Id is being scrutinised by a case expression
-              -> LibCaseEnv
-
-addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env,
-                                lc_scruts = scruts }) scrut_var
-  | bind_lvl < lvl
-  = env { lc_scruts = scruts' }
-        -- Add to scruts iff the scrut_var is being scrutinised at
-        -- a deeper level than its defn
-
-  | otherwise = env
-  where
-    scruts'  = (scrut_var, bind_lvl, lvl) : scruts
-    bind_lvl = case lookupVarEnv lvl_env scrut_var of
-                 Just lvl -> lvl
-                 Nothing  -> topLevel
-
-lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
-lookupRecId env id = lookupVarEnv (lc_rec_env env) id
-
-lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
-lookupLevel env id
-  = case lookupVarEnv (lc_lvl_env env) id of
-      Just lvl -> lvl
-      Nothing  -> topLevel
-
-{-
-************************************************************************
-*                                                                      *
-         Options
-*                                                                      *
-************************************************************************
--}
-
--- | Options for the liberate case pass.
-data LibCaseOpts = LibCaseOpts
-  { -- | Bomb-out size for deciding if potential liberatees are too big.
-    lco_threshold :: !(Maybe Int)
-  -- | Unfolding options
-  , lco_unfolding_opts :: !UnfoldingOpts
-  }
-
-{-
-************************************************************************
-*                                                                      *
-         The environment
-*                                                                      *
-************************************************************************
--}
-
-type LibCaseLevel = Int
-
-topLevel :: LibCaseLevel
-topLevel = 0
-
-lc_threshold :: LibCaseEnv -> Maybe Int
-lc_threshold = lco_threshold . lc_opts
-
-lc_uf_opts :: LibCaseEnv -> UnfoldingOpts
-lc_uf_opts = lco_unfolding_opts . lc_opts
-
-data LibCaseEnv
-  = LibCaseEnv {
-        lc_opts :: !LibCaseOpts,
-                -- ^ liberate case options
-
-        lc_lvl :: LibCaseLevel, -- ^ Current level
-                -- The level is incremented when (and only when) going
-                -- inside the RHS of a (sufficiently small) recursive
-                -- function.
-
-        lc_lvl_env :: IdEnv LibCaseLevel,
-                -- ^ Binds all non-top-level in-scope Ids (top-level and
-                -- imported things have a level of zero)
-
-        lc_rec_env :: IdEnv CoreBind,
-                -- ^ Binds *only* recursively defined ids, to their own
-                -- binding group, and *only* in their own RHSs
-
-        lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)]
-                -- ^ Each of these Ids was scrutinised by an enclosing
-                -- case expression, at a level deeper than its binding
-                -- level.
-                --
-                -- The first LibCaseLevel is the *binding level* of
-                --   the scrutinised Id,
-                -- The second is the level *at which it was scrutinised*.
-                --   (see Note [Avoiding fruitless liberate-case])
-                -- The former is a bit redundant, since you could always
-                -- look it up in lc_lvl_env, but it's just cached here
-                --
-                -- The order is insignificant; it's a bag really
-                --
-                -- There's one element per scrutinisation;
-                --    in principle the same Id may appear multiple times,
-                --    although that'd be unusual:
-                --       case x of { (a,b) -> ....(case x of ...) .. }
-        }
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
deleted file mode 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ /dev/null
@@ -1,599 +0,0 @@
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-\section[SimplCore]{Driver for simplifying @Core@ programs}
--}
-
-{-# LANGUAGE CPP #-}
-
-module GHC.Core.Opt.Pipeline ( core2core, simplifyExpr ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-import GHC.Driver.Plugins ( withPlugins, installCoreToDos )
-import GHC.Driver.Env
-import GHC.Driver.Config.Core.Lint ( endPass )
-import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts )
-import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode )
-import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts )
-import GHC.Driver.Config.Core.Rules ( initRuleOpts )
-import GHC.Platform.Ways  ( hasWay, Way(WayProf) )
-
-import GHC.Core
-import GHC.Core.Opt.CSE  ( cseProgram )
-import GHC.Core.Rules   ( RuleBase, mkRuleBase, ruleCheckProgram, getRules )
-import GHC.Core.Ppr     ( pprCoreBindings )
-import GHC.Core.Utils   ( dumpIdInfoOfProgram )
-import GHC.Core.Lint    ( lintAnnots )
-import GHC.Core.Lint.Interactive ( interactiveInScope )
-import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm )
-import GHC.Core.Opt.Simplify.Env( SimplMode(..) )
-import GHC.Core.Opt.Simplify.Monad
-import GHC.Core.Opt.Monad
-import GHC.Core.Opt.Pipeline.Types
-import GHC.Core.Opt.FloatIn      ( floatInwards )
-import GHC.Core.Opt.FloatOut     ( floatOutwards )
-import GHC.Core.Opt.LiberateCase ( liberateCase )
-import GHC.Core.Opt.StaticArgs   ( doStaticArgs )
-import GHC.Core.Opt.Specialise   ( specProgram)
-import GHC.Core.Opt.SpecConstr   ( specConstrProgram)
-import GHC.Core.Opt.DmdAnal
-import GHC.Core.Opt.CprAnal      ( cprAnalProgram )
-import GHC.Core.Opt.CallArity    ( callArityAnalProgram )
-import GHC.Core.Opt.Exitify      ( exitifyProgram )
-import GHC.Core.Opt.WorkWrap     ( wwTopBinds )
-import GHC.Core.Opt.CallerCC     ( addCallerCostCentres )
-import GHC.Core.LateCC           (addLateCostCentresMG)
-import GHC.Core.Seq (seqBinds)
-import GHC.Core.FamInstEnv
-
-import GHC.Utils.Error  ( withTiming )
-import GHC.Utils.Logger as Logger
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import GHC.Unit.Module.ModGuts
-
-import GHC.Types.Id.Info
-import GHC.Types.Basic
-import GHC.Types.Demand ( zapDmdEnvSig )
-import GHC.Types.Name.Ppr
-import GHC.Types.Var ( Var )
-
-import Control.Monad
-import qualified GHC.LanguageExtensions as LangExt
-import GHC.Unit.Module
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{The driver for the simplifier}
-*                                                                      *
-************************************************************************
--}
-
-core2core :: HscEnv -> ModGuts -> IO ModGuts
-core2core hsc_env guts@(ModGuts { mg_module  = mod
-                                , mg_loc     = loc
-                                , mg_rdr_env = rdr_env })
-  = do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars
-             uniq_mask = 's'
-
-       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod
-                                    name_ppr_ctx loc $
-                           do { hsc_env' <- getHscEnv
-                              ; all_passes <- withPlugins (hsc_plugins hsc_env')
-                                                installCoreToDos
-                                                builtin_passes
-                              ; runCorePasses all_passes guts }
-
-       ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats
-             "Grand total simplifier statistics"
-             FormatText
-             (pprSimplCount stats)
-
-       ; return guts2 }
-  where
-    dflags         = hsc_dflags hsc_env
-    logger         = hsc_logger hsc_env
-    extra_vars     = interactiveInScope (hsc_IC hsc_env)
-    home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod
-                                                               , gwib_isBoot = NotBoot })
-    hpt_rule_base  = mkRuleBase home_pkg_rules
-    name_ppr_ctx   = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
-    ptc            = initPromotionTickContext dflags
-    -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
-    -- This is very convienent for the users of the monad (e.g. plugins do not have to
-    -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
-    -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
-    -- would mean our cached value would go out of date.
-
-{-
-************************************************************************
-*                                                                      *
-           Generating the main optimisation pipeline
-*                                                                      *
-************************************************************************
--}
-
-getCoreToDo :: DynFlags -> RuleBase -> [Var] -> [CoreToDo]
--- This function builds the pipeline of optimisations
-getCoreToDo dflags hpt_rule_base extra_vars
-  = flatten_todos core_todo
-  where
-    phases        = simplPhases        dflags
-    max_iter      = maxSimplIterations dflags
-    rule_check    = ruleCheck          dflags
-    const_fold    = gopt Opt_CoreConstantFolding          dflags
-    call_arity    = gopt Opt_CallArity                    dflags
-    exitification = gopt Opt_Exitification                dflags
-    strictness    = gopt Opt_Strictness                   dflags
-    full_laziness = gopt Opt_FullLaziness                 dflags
-    do_specialise = gopt Opt_Specialise                   dflags
-    do_float_in   = gopt Opt_FloatIn                      dflags
-    cse           = gopt Opt_CSE                          dflags
-    spec_constr   = gopt Opt_SpecConstr                   dflags
-    liberate_case = gopt Opt_LiberateCase                 dflags
-    late_dmd_anal = gopt Opt_LateDmdAnal                  dflags
-    late_specialise = gopt Opt_LateSpecialise             dflags
-    static_args   = gopt Opt_StaticArgumentTransformation dflags
-    rules_on      = gopt Opt_EnableRewriteRules           dflags
-    ww_on         = gopt Opt_WorkerWrapper                dflags
-    static_ptrs   = xopt LangExt.StaticPointers           dflags
-    profiling     = ways dflags `hasWay` WayProf
-
-    do_presimplify = do_specialise -- TODO: any other optimizations benefit from pre-simplification?
-    do_simpl3      = const_fold || rules_on -- TODO: any other optimizations benefit from three-phase simplification?
-
-    maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
-
-    maybe_strictness_before (Phase phase)
-      | phase `elem` strictnessBefore dflags = CoreDoDemand False
-    maybe_strictness_before _
-      = CoreDoNothing
-
-    ----------------------------
-    base_simpl_mode :: SimplMode
-    base_simpl_mode = initSimplMode dflags
-
-    -- gentle_mode: make specialiser happy: minimum effort please
-    -- See Note [Inline in InitialPhase]
-    -- See Note [RULEs enabled in InitialPhase]
-    gentle_mode = base_simpl_mode { sm_names     = ["Gentle"]
-                                  , sm_phase     = InitialPhase
-                                  , sm_case_case = False }
-
-    simpl_mode phase name
-      = base_simpl_mode { sm_names = [name], sm_phase = phase }
-
-    keep_exits :: SimplMode -> SimplMode
-    -- See Note [Be selective about not-inlining exit join points]
-    -- in GHC.Core.Opt.Exitify
-    keep_exits mode = mode { sm_keep_exits = True }
-
-    ----------------------------
-    run_simplifier mode iter
-      = CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter mode hpt_rule_base
-
-    simpl_phase phase name iter = CoreDoPasses $
-                                  [ maybe_strictness_before phase
-                                  , run_simplifier (simpl_mode phase name) iter
-                                  , maybe_rule_check phase ]
-
-    -- Run GHC's internal simplification phase, after all rules have run.
-    -- See Note [Compiler phases] in GHC.Types.Basic
-    simpl_gently          = run_simplifier gentle_mode  max_iter
-    simplify_final   name = run_simplifier (             simpl_mode FinalPhase name) max_iter
-    simpl_keep_exits name = run_simplifier (keep_exits $ simpl_mode FinalPhase name) max_iter
-
-    ----------------------------
-    dmd_cpr_ww = if ww_on then [CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper]
-                          else [CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper]
-
-
-    -- Static forms are moved to the top level with the FloatOut pass.
-    -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
-    static_ptrs_float_outwards =
-      runWhen static_ptrs $ CoreDoPasses
-        [ simpl_gently -- Float Out can't handle type lets (sometimes created
-                       -- by simpleOptPgm via mkParallelBindings)
-        , CoreDoFloatOutwards FloatOutSwitches
-          { floatOutLambdas   = Just 0
-          , floatOutConstants = True
-          , floatOutOverSatApps = False
-          , floatToTopLevelOnly = True
-          }
-        ]
-
-    add_caller_ccs =
-        runWhen (profiling && not (null $ callerCcFilters dflags)) CoreAddCallerCcs
-
-    add_late_ccs =
-        runWhen (profiling && gopt Opt_ProfLateInlineCcs dflags) $ CoreAddLateCcs
-
-    core_todo =
-     [
-    -- We want to do the static argument transform before full laziness as it
-    -- may expose extra opportunities to float things outwards. However, to fix
-    -- up the output of the transformation we need at do at least one simplify
-    -- after this before anything else
-        runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
-
-        -- initial simplify: mk specialiser happy: minimum effort please
-        runWhen do_presimplify simpl_gently,
-
-        -- Specialisation is best done before full laziness
-        -- so that overloaded functions have all their dictionary lambdas manifest
-        runWhen do_specialise CoreDoSpecialising,
-
-        if full_laziness then
-           CoreDoFloatOutwards FloatOutSwitches {
-                                 floatOutLambdas   = Just 0,
-                                 floatOutConstants = True,
-                                 floatOutOverSatApps = False,
-                                 floatToTopLevelOnly = False }
-                -- Was: gentleFloatOutSwitches
-                --
-                -- I have no idea why, but not floating constants to
-                -- top level is very bad in some cases.
-                --
-                -- Notably: p_ident in spectral/rewrite
-                --          Changing from "gentle" to "constantsOnly"
-                --          improved rewrite's allocation by 19%, and
-                --          made 0.0% difference to any other nofib
-                --          benchmark
-                --
-                -- Not doing floatOutOverSatApps yet, we'll do
-                -- that later on when we've had a chance to get more
-                -- accurate arity information.  In fact it makes no
-                -- difference at all to performance if we do it here,
-                -- but maybe we save some unnecessary to-and-fro in
-                -- the simplifier.
-        else
-           -- Even with full laziness turned off, we still need to float static
-           -- forms to the top level. See Note [Grand plan for static forms] in
-           -- GHC.Iface.Tidy.StaticPtrTable.
-           static_ptrs_float_outwards,
-
-        -- Run the simplifier phases 2,1,0 to allow rewrite rules to fire
-        runWhen do_simpl3
-            (CoreDoPasses $ [ simpl_phase (Phase phase) "main" max_iter
-                            | phase <- [phases, phases-1 .. 1] ] ++
-                            [ simpl_phase (Phase 0) "main" (max max_iter 3) ]),
-                -- Phase 0: allow all Ids to be inlined now
-                -- This gets foldr inlined before strictness analysis
-
-                -- At least 3 iterations because otherwise we land up with
-                -- huge dead expressions because of an infelicity in the
-                -- simplifier.
-                --      let k = BIG in foldr k z xs
-                -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
-                -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
-                -- Don't stop now!
-
-        runWhen do_float_in CoreDoFloatInwards,
-            -- Run float-inwards immediately before the strictness analyser
-            -- Doing so pushes bindings nearer their use site and hence makes
-            -- them more likely to be strict. These bindings might only show
-            -- up after the inlining from simplification.  Example in fulsom,
-            -- Csg.calc, where an arg of timesDouble thereby becomes strict.
-
-        runWhen call_arity $ CoreDoPasses
-            [ CoreDoCallArity
-            , simplify_final "post-call-arity"
-            ],
-
-        -- Strictness analysis
-        runWhen strictness $ CoreDoPasses
-            (dmd_cpr_ww ++ [simplify_final "post-worker-wrapper"]),
-
-        runWhen exitification CoreDoExitify,
-            -- See Note [Placement of the exitification pass]
-            -- in GHC.Core.Opt.Exitify
-
-        runWhen full_laziness $
-           CoreDoFloatOutwards FloatOutSwitches {
-                                 floatOutLambdas     = floatLamArgs dflags,
-                                 floatOutConstants   = True,
-                                 floatOutOverSatApps = True,
-                                 floatToTopLevelOnly = False },
-                -- nofib/spectral/hartel/wang doubles in speed if you
-                -- do full laziness late in the day.  It only happens
-                -- after fusion and other stuff, so the early pass doesn't
-                -- catch it.  For the record, the redex is
-                --        f_el22 (f_el21 r_midblock)
-
-
-        runWhen cse CoreCSE,
-                -- We want CSE to follow the final full-laziness pass, because it may
-                -- succeed in commoning up things floated out by full laziness.
-                -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
-
-        runWhen do_float_in CoreDoFloatInwards,
-
-        -- Final tidy-up run of the simplifier
-        simpl_keep_exits "final tidy up",
-            -- Keep exit join point because this is the first
-            -- Simplifier run after Exitify. Subsequent runs will
-            -- re-inline those exit join points; their work is done.
-            -- See Note [Be selective about not-inlining exit join points]
-            -- in GHC.Core.Opt.Exitify
-            --
-            -- Annoyingly, we only /have/ a subsequent run with -O2.  With
-            -- plain -O we'll still have those exit join points hanging around.
-            -- Oh well.
-
-        maybe_rule_check FinalPhase,
-
-        --------  After this we have -O2 passes -----------------
-        -- None of them run with -O
-
-                -- Case-liberation for -O2.  This should be after
-                -- strictness analysis and the simplification which follows it.
-        runWhen liberate_case $ CoreDoPasses
-           [ CoreLiberateCase, simplify_final "post-liberate-case" ],
-           -- Run the simplifier after LiberateCase to vastly
-           -- reduce the possibility of shadowing
-           -- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr
-
-        runWhen spec_constr $ CoreDoPasses
-           [ CoreDoSpecConstr, simplify_final "post-spec-constr"],
-           -- See Note [Simplify after SpecConstr]
-
-        maybe_rule_check FinalPhase,
-
-        runWhen late_specialise $ CoreDoPasses
-           [ CoreDoSpecialising, simplify_final "post-late-spec"],
-
-        -- LiberateCase can yield new CSE opportunities because it peels
-        -- off one layer of a recursive function (concretely, I saw this
-        -- in wheel-sieve1), and I'm guessing that SpecConstr can too
-        -- And CSE is a very cheap pass. So it seems worth doing here.
-        runWhen ((liberate_case || spec_constr) && cse) $ CoreDoPasses
-           [ CoreCSE, simplify_final "post-final-cse" ],
-
-        ---------  End of -O2 passes --------------
-
-        runWhen late_dmd_anal $ CoreDoPasses (
-            dmd_cpr_ww ++ [simplify_final "post-late-ww"]
-          ),
-
-        -- Final run of the demand_analyser, ensures that one-shot thunks are
-        -- really really one-shot thunks. Only needed if the demand analyser
-        -- has run at all. See Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal
-        -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution
-        -- can become /exponentially/ more expensive. See #11731, #12996.
-        runWhen (strictness || late_dmd_anal) (CoreDoDemand False),
-
-        maybe_rule_check FinalPhase,
-
-        add_caller_ccs,
-        add_late_ccs
-     ]
-
-    -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.
-    flatten_todos [] = []
-    flatten_todos (CoreDoNothing : rest) = flatten_todos rest
-    flatten_todos (CoreDoPasses passes : rest) =
-      flatten_todos passes ++ flatten_todos rest
-    flatten_todos (todo : rest) = todo : flatten_todos rest
-
--- The core-to-core pass ordering is derived from the DynFlags:
-runWhen :: Bool -> CoreToDo -> CoreToDo
-runWhen True  do_this = do_this
-runWhen False _       = CoreDoNothing
-
-runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo
-runMaybe (Just x) f = f x
-runMaybe Nothing  _ = CoreDoNothing
-
-{- Note [Inline in InitialPhase]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is
-confusing for users because when they say INLINE they expect the function to inline
-right away.
-
-So now we do inlining immediately, even in the InitialPhase, assuming that the
-Id's Activation allows it.
-
-This is a surprisingly big deal. Compiler performance improved a lot
-when I made this change:
-
-   perf/compiler/T5837.run            T5837 [stat too good] (normal)
-   perf/compiler/parsing001.run       parsing001 [stat too good] (normal)
-   perf/compiler/T12234.run           T12234 [stat too good] (optasm)
-   perf/compiler/T9020.run            T9020 [stat too good] (optasm)
-   perf/compiler/T3064.run            T3064 [stat too good] (normal)
-   perf/compiler/T9961.run            T9961 [stat too good] (normal)
-   perf/compiler/T13056.run           T13056 [stat too good] (optasm)
-   perf/compiler/T9872d.run           T9872d [stat too good] (normal)
-   perf/compiler/T783.run             T783 [stat too good] (normal)
-   perf/compiler/T12227.run           T12227 [stat too good] (normal)
-   perf/should_run/lazy-bs-alloc.run  lazy-bs-alloc [stat too good] (normal)
-   perf/compiler/T1969.run            T1969 [stat too good] (normal)
-   perf/compiler/T9872a.run           T9872a [stat too good] (normal)
-   perf/compiler/T9872c.run           T9872c [stat too good] (normal)
-   perf/compiler/T9872b.run           T9872b [stat too good] (normal)
-   perf/compiler/T9872d.run           T9872d [stat too good] (normal)
-
-Note [RULEs enabled in InitialPhase]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-RULES are enabled when doing "gentle" simplification in InitialPhase,
-or with -O0.  Two reasons:
-
-  * We really want the class-op cancellation to happen:
-        op (df d1 d2) --> $cop3 d1 d2
-    because this breaks the mutual recursion between 'op' and 'df'
-
-  * I wanted the RULE
-        lift String ===> ...
-    to work in Template Haskell when simplifying
-    splices, so we get simpler code for literal strings
-
-But watch out: list fusion can prevent floating.  So use phase control
-to switch off those rules until after floating.
-
-Note [Simplify after SpecConstr]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We want to run the simplifier after SpecConstr, and before late-Specialise,
-for two reasons, both shown up in test perf/compiler/T16473,
-with -O2 -flate-specialise
-
-1.  I found that running late-Specialise after SpecConstr, with no
-    simplification in between meant that the carefully constructed
-    SpecConstr rule never got to fire.  (It was something like
-          lvl = f a   -- Arity 1
-          ....g lvl....
-    SpecConstr specialised g for argument lvl; but Specialise then
-    specialised lvl = f a to lvl = $sf, and inlined. Or something like
-    that.)
-
-2.  Specialise relies on unfoldings being available for top-level dictionary
-    bindings; but SpecConstr kills them all!  The Simplifer restores them.
-
-This extra run of the simplifier has a cost, but this is only with -O2.
-
-
-************************************************************************
-*                                                                      *
-                  The CoreToDo interpreter
-*                                                                      *
-************************************************************************
--}
-
-runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
-runCorePasses passes guts
-  = foldM do_pass guts passes
-  where
-    do_pass guts CoreDoNothing = return guts
-    do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
-    do_pass guts pass = do
-      logger <- getLogger
-      withTiming logger (ppr pass <+> brackets (ppr mod))
-                   (const ()) $ do
-            guts' <- lintAnnots (ppr pass) (doCorePass pass) guts
-            endPass pass (mg_binds guts') (mg_rules guts')
-            return guts'
-
-    mod = mg_module guts
-
-doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
-doCorePass pass guts = do
-  logger    <- getLogger
-  hsc_env   <- getHscEnv
-  dflags    <- getDynFlags
-  us        <- getUniqueSupplyM
-  p_fam_env <- getPackageFamInstEnv
-  let platform = targetPlatform dflags
-  let fam_envs = (p_fam_env, mg_fam_inst_env guts)
-  let updateBinds  f = return $ guts { mg_binds = f (mg_binds guts) }
-  let updateBindsM f = f (mg_binds guts) >>= \b' -> return $ guts { mg_binds = b' }
-  let name_ppr_ctx =
-        mkNamePprCtx
-          (initPromotionTickContext dflags)
-          (hsc_unit_env hsc_env)
-          (mg_rdr_env guts)
-
-  case pass of
-    CoreDoSimplify opts       -> {-# SCC "Simplify" #-}
-                                 liftIOWithCount $ simplifyPgm logger (hsc_unit_env hsc_env) name_ppr_ctx opts guts
-
-    CoreCSE                   -> {-# SCC "CommonSubExpr" #-}
-                                 updateBinds cseProgram
-
-    CoreLiberateCase          -> {-# SCC "LiberateCase" #-}
-                                 updateBinds (liberateCase (initLiberateCaseOpts dflags))
-
-    CoreDoFloatInwards        -> {-# SCC "FloatInwards" #-}
-                                 updateBinds (floatInwards platform)
-
-    CoreDoFloatOutwards f     -> {-# SCC "FloatOutwards" #-}
-                                 updateBindsM (liftIO . floatOutwards logger f us)
-
-    CoreDoStaticArgs          -> {-# SCC "StaticArgs" #-}
-                                 updateBinds (doStaticArgs us)
-
-    CoreDoCallArity           -> {-# SCC "CallArity" #-}
-                                 updateBinds callArityAnalProgram
-
-    CoreDoExitify             -> {-# SCC "Exitify" #-}
-                                 updateBinds exitifyProgram
-
-    CoreDoDemand before_ww    -> {-# SCC "DmdAnal" #-}
-                                 updateBindsM (liftIO . dmdAnal logger before_ww dflags fam_envs (mg_rules guts))
-
-    CoreDoCpr                 -> {-# SCC "CprAnal" #-}
-                                 updateBindsM (liftIO . cprAnalProgram logger fam_envs)
-
-    CoreDoWorkerWrapper       -> {-# SCC "WorkWrap" #-}
-                                 updateBinds (wwTopBinds
-                                               (initWorkWrapOpts (mg_module guts) dflags fam_envs)
-                                               us)
-
-    CoreDoSpecialising        -> {-# SCC "Specialise" #-}
-                                 specProgram guts
-
-    CoreDoSpecConstr          -> {-# SCC "SpecConstr" #-}
-                                 specConstrProgram guts
-
-    CoreAddCallerCcs          -> {-# SCC "AddCallerCcs" #-}
-                                 addCallerCostCentres guts
-
-    CoreAddLateCcs            -> {-# SCC "AddLateCcs" #-}
-                                 addLateCostCentresMG guts
-
-    CoreDoPrintCore           -> {-# SCC "PrintCore" #-}
-                                 liftIO $ printCore logger (mg_binds guts) >> return guts
-
-    CoreDoRuleCheck phase pat -> {-# SCC "RuleCheck" #-}
-                                 ruleCheckPass phase pat guts
-    CoreDoNothing             -> return guts
-    CoreDoPasses passes       -> runCorePasses passes guts
-
-    CoreDoPluginPass _ p      -> {-# SCC "Plugin" #-} p guts
-
-    CoreDesugar               -> pprPanic "doCorePass" (ppr pass)
-    CoreDesugarOpt            -> pprPanic "doCorePass" (ppr pass)
-    CoreTidy                  -> pprPanic "doCorePass" (ppr pass)
-    CorePrep                  -> pprPanic "doCorePass" (ppr pass)
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Core pass combinators}
-*                                                                      *
-************************************************************************
--}
-
-printCore :: Logger -> CoreProgram -> IO ()
-printCore logger binds
-    = Logger.logDumpMsg logger "Print Core" (pprCoreBindings binds)
-
-ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
-ruleCheckPass current_phase pat guts = do
-    dflags <- getDynFlags
-    logger <- getLogger
-    withTiming logger (text "RuleCheck"<+>brackets (ppr $ mg_module guts))
-                (const ()) $ do
-        rule_env <- initRuleEnv guts
-        let rule_fn fn = getRules rule_env fn
-            ropts = initRuleOpts dflags
-        liftIO $ logDumpMsg logger "Rule check"
-                     (ruleCheckProgram ropts current_phase pat
-                        rule_fn (mg_binds guts))
-        return guts
-
-dmdAnal :: Logger -> Bool -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram
-dmdAnal logger before_ww dflags fam_envs rules binds = do
-  let !opts = DmdAnalOpts
-               { dmd_strict_dicts    = gopt Opt_DictsStrict dflags
-               , dmd_do_boxity       = before_ww -- only run Boxity Analysis immediately preceding WW
-               , dmd_unbox_width     = dmdUnboxWidth dflags
-               , dmd_max_worker_args = maxWorkerArgs dflags
-               }
-      binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds
-  Logger.putDumpFileMaybe logger Opt_D_dump_str_signatures "Strictness signatures" FormatText $
-    dumpIdInfoOfProgram (hasPprDebug dflags) (ppr . zapDmdEnvSig . dmdSigInfo) binds_plus_dmds
-  -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal
-  seqBinds binds_plus_dmds `seq` return binds_plus_dmds
diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs
deleted file mode 100644
--- a/compiler/GHC/Core/Opt/SetLevels.hs
+++ /dev/null
@@ -1,1813 +0,0 @@
-{-# LANGUAGE PatternSynonyms #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-\section{GHC.Core.Opt.SetLevels}
-
-                ***************************
-                        Overview
-                ***************************
-
-1. We attach binding levels to Core bindings, in preparation for floating
-   outwards (@FloatOut@).
-
-2. We also let-ify many expressions (notably case scrutinees), so they
-   will have a fighting chance of being floated sensible.
-
-3. Note [Need for cloning during float-out]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-   We clone the binders of any floatable let-binding, so that when it is
-   floated out it will be unique. Example
-      (let x=2 in x) + (let x=3 in x)
-   we must clone before floating so we get
-      let x1=2 in
-      let x2=3 in
-      x1+x2
-
-   NOTE: this can't be done using the uniqAway idea, because the variable
-         must be unique in the whole program, not just its current scope,
-         because two variables in different scopes may float out to the
-         same top level place
-
-   NOTE: Very tiresomely, we must apply this substitution to
-         the rules stored inside a variable too.
-
-   We do *not* clone top-level bindings, because some of them must not change,
-   but we *do* clone bindings that are heading for the top level
-
-4. Note [Binder-swap during float-out]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-   In the expression
-        case x of wild { p -> ...wild... }
-   we substitute x for wild in the RHS of the case alternatives:
-        case x of wild { p -> ...x... }
-   This means that a sub-expression involving x is not "trapped" inside the RHS.
-   And it's not inconvenient because we already have a substitution.
-
-  Note that this is EXACTLY BACKWARDS from the what the simplifier does.
-  The simplifier tries to get rid of occurrences of x, in favour of wild,
-  in the hope that there will only be one remaining occurrence of x, namely
-  the scrutinee of the case, and we can inline it.
--}
-
-module GHC.Core.Opt.SetLevels (
-        setLevels,
-
-        Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl,
-        LevelledBind, LevelledExpr, LevelledBndr,
-        FloatSpec(..), floatSpecLevel,
-
-        incMinorLvl, ltMajLvl, ltLvl, isTopLvl
-    ) where
-
-import GHC.Prelude
-
-import GHC.Core
-import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )
-import GHC.Core.Utils   ( exprType, exprIsHNF
-                        , exprOkForSpeculation
-                        , exprIsTopLevelBindable
-                        , collectMakeStaticArgs
-                        , mkLamTypes, extendInScopeSetBndrs
-                        )
-import GHC.Core.Opt.Arity   ( exprBotStrictness_maybe, isOneShotBndr )
-import GHC.Core.FVs     -- all of it
-import GHC.Core.Subst
-import GHC.Core.Make    ( sortQuantVars )
-import GHC.Core.Type    ( Type, tyCoVarsOfType
-                        , mightBeUnliftedType, closeOverKindsDSet
-                        , typeHasFixedRuntimeRep
-                        )
-import GHC.Core.Multiplicity     ( pattern ManyTy )
-
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.Var
-import GHC.Types.Var.Set
-import GHC.Types.Unique.Set   ( nonDetStrictFoldUniqSet )
-import GHC.Types.Unique.DSet  ( getUniqDSet )
-import GHC.Types.Var.Env
-import GHC.Types.Literal      ( litIsTrivial )
-import GHC.Types.Demand       ( DmdSig, prependArgsDmdSig )
-import GHC.Types.Cpr          ( CprSig, prependArgsCprSig )
-import GHC.Types.Name         ( getOccName, mkSystemVarName )
-import GHC.Types.Name.Occurrence ( occNameFS )
-import GHC.Types.Unique       ( hasKey )
-import GHC.Types.Tickish      ( tickishIsCode )
-import GHC.Types.Unique.Supply
-import GHC.Types.Unique.DFM
-import GHC.Types.Basic  ( Arity, RecFlag(..), isRec )
-
-import GHC.Builtin.Types
-import GHC.Builtin.Names      ( runRWKey )
-
-import GHC.Data.FastString
-
-import GHC.Utils.FV
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-import Data.Maybe
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Level numbers}
-*                                                                      *
-************************************************************************
--}
-
-type LevelledExpr = TaggedExpr FloatSpec
-type LevelledBind = TaggedBind FloatSpec
-type LevelledBndr = TaggedBndr FloatSpec
-
-data Level = Level Int  -- Level number of enclosing lambdas
-                   Int  -- Number of big-lambda and/or case expressions and/or
-                        -- context boundaries between
-                        -- here and the nearest enclosing lambda
-                   LevelType -- Binder or join ceiling?
-data LevelType = BndrLvl | JoinCeilLvl deriving (Eq)
-
-data FloatSpec
-  = FloatMe Level       -- Float to just inside the binding
-                        --    tagged with this level
-  | StayPut Level       -- Stay where it is; binding is
-                        --     tagged with this level
-
-floatSpecLevel :: FloatSpec -> Level
-floatSpecLevel (FloatMe l) = l
-floatSpecLevel (StayPut l) = l
-
-{-
-The {\em level number} on a (type-)lambda-bound variable is the
-nesting depth of the (type-)lambda which binds it.  The outermost lambda
-has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
-
-On an expression, it's the maximum level number of its free
-(type-)variables.  On a let(rec)-bound variable, it's the level of its
-RHS.  On a case-bound variable, it's the number of enclosing lambdas.
-
-Top-level variables: level~0.  Those bound on the RHS of a top-level
-definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
-as ``subscripts'')...
-\begin{verbatim}
-a_0 = let  b_? = ...  in
-           x_1 = ... b ... in ...
-\end{verbatim}
-
-The main function @lvlExpr@ carries a ``context level'' (@le_ctxt_lvl@).
-That's meant to be the level number of the enclosing binder in the
-final (floated) program.  If the level number of a sub-expression is
-less than that of the context, then it might be worth let-binding the
-sub-expression so that it will indeed float.
-
-If you can float to level @Level 0 0@ worth doing so because then your
-allocation becomes static instead of dynamic.  We always start with
-context @Level 0 0@.
-
-
-Note [FloatOut inside INLINE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose:
-to say "don't float anything out of here".  That's exactly what we
-want for the body of an INLINE, where we don't want to float anything
-out at all.  See notes with lvlMFE below.
-
-But, check this out:
-
--- At one time I tried the effect of not floating anything out of an InlineMe,
--- but it sometimes works badly.  For example, consider PrelArr.done.  It
--- has the form         __inline (\d. e)
--- where e doesn't mention d.  If we float this to
---      __inline (let x = e in \d. x)
--- things are bad.  The inliner doesn't even inline it because it doesn't look
--- like a head-normal form.  So it seems a lesser evil to let things float.
--- In GHC.Core.Opt.SetLevels we do set the context to (Level 0 0) when we get to an InlineMe
--- which discourages floating out.
-
-So the conclusion is: don't do any floating at all inside an InlineMe.
-(In the above example, don't float the {x=e} out of the \d.)
-
-One particular case is that of workers: we don't want to float the
-call to the worker outside the wrapper, otherwise the worker might get
-inlined into the floated expression, and an importing module won't see
-the worker at all.
-
-Note [Join ceiling]
-~~~~~~~~~~~~~~~~~~~
-Join points can't float very far; too far, and they can't remain join points
-So, suppose we have:
-
-  f x = (joinrec j y = ... x ... in jump j x) + 1
-
-One may be tempted to float j out to the top of f's RHS, but then the jump
-would not be a tail call. Thus we keep track of a level called the *join
-ceiling* past which join points are not allowed to float.
-
-The troublesome thing is that, unlike most levels to which something might
-float, there is not necessarily an identifier to which the join ceiling is
-attached. Fortunately, if something is to be floated to a join ceiling, it must
-be dropped at the *nearest* join ceiling. Thus each level is marked as to
-whether it is a join ceiling, so that FloatOut can tell which binders are being
-floated to the nearest join ceiling and which to a particular binder (or set of
-binders).
--}
-
-instance Outputable FloatSpec where
-  ppr (FloatMe l) = char 'F' <> ppr l
-  ppr (StayPut l) = ppr l
-
-tOP_LEVEL :: Level
-tOP_LEVEL   = Level 0 0 BndrLvl
-
-incMajorLvl :: Level -> Level
-incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl
-
-incMinorLvl :: Level -> Level
-incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl
-
-asJoinCeilLvl :: Level -> Level
-asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl
-
-maxLvl :: Level -> Level -> Level
-maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _)
-  | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
-  | otherwise                                      = l2
-
-ltLvl :: Level -> Level -> Bool
-ltLvl (Level maj1 min1 _) (Level maj2 min2 _)
-  = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
-
-ltMajLvl :: Level -> Level -> Bool
-    -- Tells if one level belongs to a difft *lambda* level to another
-ltMajLvl (Level maj1 _ _) (Level maj2 _ _) = maj1 < maj2
-
-isTopLvl :: Level -> Bool
-isTopLvl (Level 0 0 _) = True
-isTopLvl _             = False
-
-isJoinCeilLvl :: Level -> Bool
-isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl
-
-instance Outputable Level where
-  ppr (Level maj min typ)
-    = hcat [ char '<', int maj, char ',', int min, char '>'
-           , ppWhen (typ == JoinCeilLvl) (char 'C') ]
-
-instance Eq Level where
-  (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Main level-setting code}
-*                                                                      *
-************************************************************************
--}
-
-setLevels :: FloatOutSwitches
-          -> CoreProgram
-          -> UniqSupply
-          -> [LevelledBind]
-
-setLevels float_lams binds us
-  = initLvl us (do_them binds)
-  where
-    env = initialEnv float_lams binds
-
-    do_them :: [CoreBind] -> LvlM [LevelledBind]
-    do_them [] = return []
-    do_them (b:bs)
-      = do { lvld_bind <- lvlTopBind env b
-           ; lvld_binds <- do_them bs
-           ; return (lvld_bind : lvld_binds) }
-
-lvlTopBind :: LevelEnv -> Bind Id -> LvlM LevelledBind
-lvlTopBind env (NonRec bndr rhs)
-  = do { (bndr', rhs') <- lvl_top env NonRecursive bndr rhs
-       ; return (NonRec bndr' rhs') }
-
-lvlTopBind env (Rec pairs)
-  = do { prs' <- mapM (\(b,r) -> lvl_top env Recursive b r) pairs
-       ; return (Rec prs') }
-
-lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr
-        -> LvlM (LevelledBndr, LevelledExpr)
--- NB: 'env' has all the top-level binders in scope, so
---     there is no need call substAndLvlBndrs here
-lvl_top env is_rec bndr rhs
-  = do { rhs' <- lvlRhs env is_rec (isDeadEndId bndr)
-                                   Nothing  -- Not a join point
-                                   (freeVars rhs)
-       ; return (stayPut tOP_LEVEL bndr, rhs') }
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Setting expression levels}
-*                                                                      *
-************************************************************************
-
-Note [Floating over-saturated applications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we see (f x y), and (f x) is a redex (ie f's arity is 1),
-we call (f x) an "over-saturated application"
-
-Should we float out an over-sat app, if can escape a value lambda?
-It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2).
-But we don't want to do it for class selectors, because the work saved
-is minimal, and the extra local thunks allocated cost money.
-
-Arguably we could float even class-op applications if they were going to
-top level -- but then they must be applied to a constant dictionary and
-will almost certainly be optimised away anyway.
--}
-
-lvlExpr :: LevelEnv             -- Context
-        -> CoreExprWithFVs      -- Input expression
-        -> LvlM LevelledExpr    -- Result expression
-
-{-
-The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing
-binder.  Here's an example
-
-        v = \x -> ...\y -> let r = case (..x..) of
-                                        ..x..
-                           in ..
-
-When looking at the rhs of @r@, @le_ctxt_lvl@ will be 1 because that's
-the level of @r@, even though it's inside a level-2 @\y@.  It's
-important that @le_ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
-don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
---- because it isn't a *maximal* free expression.
-
-If there were another lambda in @r@'s rhs, it would get level-2 as well.
--}
-
-lvlExpr env (_, AnnType ty)     = return (Type (substTyUnchecked (le_subst env) ty))
-lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co))
-lvlExpr env (_, AnnVar v)       = return (lookupVar env v)
-lvlExpr _   (_, AnnLit lit)     = return (Lit lit)
-
-lvlExpr env (_, AnnCast expr (_, co)) = do
-    expr' <- lvlNonTailExpr env expr
-    return (Cast expr' (substCo (le_subst env) co))
-
-lvlExpr env (_, AnnTick tickish expr) = do
-    expr' <- lvlNonTailExpr env expr
-    let tickish' = substTickish (le_subst env) tickish
-    return (Tick tickish' expr')
-
-lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr)
-
--- We don't split adjacent lambdas.  That is, given
---      \x y -> (x+1,y)
--- we don't float to give
---      \x -> let v = x+1 in \y -> (v,y)
--- Why not?  Because partial applications are fairly rare, and splitting
--- lambdas makes them more expensive.
-
-lvlExpr env expr@(_, AnnLam {})
-  = do { new_body <- lvlNonTailMFE new_env True body
-       ; return (mkLams new_bndrs new_body) }
-  where
-    (bndrs, body)        = collectAnnBndrs expr
-    (env1, bndrs1)       = substBndrsSL NonRecursive env bndrs
-    (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1
-        -- At one time we called a special version of collectBinders,
-        -- which ignored coercions, because we don't want to split
-        -- a lambda like this (\x -> coerce t (\s -> ...))
-        -- This used to happen quite a bit in state-transformer programs,
-        -- but not nearly so much now non-recursive newtypes are transparent.
-        -- [See GHC.Core.Opt.SetLevels rev 1.50 for a version with this approach.]
-
-lvlExpr env (_, AnnLet bind body)
-  = do { (bind', new_env) <- lvlBind env bind
-       ; body' <- lvlExpr new_env body
-           -- No point in going via lvlMFE here.  If the binding is alive
-           -- (mentioned in body), and the whole let-expression doesn't
-           -- float, then neither will the body
-       ; return (Let bind' body') }
-
-lvlExpr env (_, AnnCase scrut case_bndr ty alts)
-  = do { scrut' <- lvlNonTailMFE env True scrut
-       ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts }
-
-lvlNonTailExpr :: LevelEnv             -- Context
-               -> CoreExprWithFVs      -- Input expression
-               -> LvlM LevelledExpr    -- Result expression
-lvlNonTailExpr env expr
-  = lvlExpr (placeJoinCeiling env) expr
-
--------------------------------------------
-lvlApp :: LevelEnv
-       -> CoreExprWithFVs
-       -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application
-       -> LvlM LevelledExpr                    -- Result expression
-lvlApp env orig_expr ((_,AnnVar fn), args)
-  -- Try to ensure that runRW#'s continuation isn't floated out.
-  -- See Note [Simplification of runRW#].
-  | fn `hasKey` runRWKey
-  = do { args' <- mapM (lvlExpr env) args
-       ; return (foldl' App (lookupVar env fn) args') }
-
-  | floatOverSat env   -- See Note [Floating over-saturated applications]
-  , arity > 0
-  , arity < n_val_args
-  , Nothing <- isClassOpId_maybe fn
-  =  do { rargs' <- mapM (lvlNonTailMFE env False) rargs
-        ; lapp'  <- lvlNonTailMFE env False lapp
-        ; return (foldl' App lapp' rargs') }
-
-  | otherwise
-  = do { args' <- mapM (lvlMFE env False) args
-                  -- False: see "Arguments" in Note [Floating to the top]
-       ; return (foldl' App (lookupVar env fn) args') }
-  where
-    n_val_args = count (isValArg . deAnnotate) args
-    arity      = idArity fn
-
-    -- Separate out the PAP that we are floating from the extra
-    -- arguments, by traversing the spine until we have collected
-    -- (n_val_args - arity) value arguments.
-    (lapp, rargs) = left (n_val_args - arity) orig_expr []
-
-    left 0 e               rargs = (e, rargs)
-    left n (_, AnnApp f a) rargs
-       | isValArg (deAnnotate a) = left (n-1) f (a:rargs)
-       | otherwise               = left n     f (a:rargs)
-    left _ _ _                   = panic "GHC.Core.Opt.SetLevels.lvlExpr.left"
-
-lvlApp env _ (fun, args)
-  =  -- No PAPs that we can float: just carry on with the
-     -- arguments and the function.
-     do { args' <- mapM (lvlNonTailMFE env False) args
-        ; fun'  <- lvlNonTailExpr env fun
-        ; return (foldl' App fun' args') }
-
--------------------------------------------
-lvlCase :: LevelEnv             -- Level of in-scope names/tyvars
-        -> DVarSet              -- Free vars of input scrutinee
-        -> LevelledExpr         -- Processed scrutinee
-        -> Id -> Type           -- Case binder and result type
-        -> [CoreAltWithFVs]     -- Input alternatives
-        -> LvlM LevelledExpr    -- Result expression
-lvlCase env scrut_fvs scrut' case_bndr ty alts
-  -- See Note [Floating single-alternative cases]
-  | [AnnAlt con@(DataAlt {}) bs body] <- alts
-  , exprIsHNF (deTagExpr scrut')  -- See Note [Check the output scrutinee for exprIsHNF]
-  , not (isTopLvl dest_lvl)       -- Can't have top-level cases
-  , not (floatTopLvlOnly env)     -- Can float anywhere
-  , ManyTy <- idMult case_bndr     -- See Note [Floating linear case]
-  =     -- Always float the case if possible
-        -- Unlike lets we don't insist that it escapes a value lambda
-    do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs)
-       ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut'
-       ; body' <- lvlMFE rhs_env True body
-       ; let alt' = Alt con (map (stayPut dest_lvl) bs') body'
-       ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) }
-
-  | otherwise     -- Stays put
-  = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr]
-             alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut'
-       ; alts' <- mapM (lvl_alt alts_env) alts
-       ; return (Case scrut' case_bndr' ty' alts') }
-  where
-    ty' = substTyUnchecked (le_subst env) ty
-
-    incd_lvl = incMinorLvl (le_ctxt_lvl env)
-    dest_lvl = maxFvLevel (const True) env scrut_fvs
-            -- Don't abstract over type variables, hence const True
-
-    lvl_alt alts_env (AnnAlt con bs rhs)
-      = do { rhs' <- lvlMFE new_env True rhs
-           ; return (Alt con bs' rhs') }
-      where
-        (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs
-
-{- Note [Floating single-alternative cases]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this:
-  data T a = MkT !a
-  f :: T Int -> blah
-  f x vs = case x of { MkT y ->
-             let f vs = ...(case y of I# w -> e)...f..
-             in f vs
-
-Here we can float the (case y ...) out, because y is sure
-to be evaluated, to give
-  f x vs = case x of { MkT y ->
-           case y of I# w ->
-             let f vs = ...(e)...f..
-             in f vs
-
-That saves unboxing it every time round the loop.  It's important in
-some DPH stuff where we really want to avoid that repeated unboxing in
-the inner loop.
-
-Things to note:
-
- * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation.
-
-     - exrpIsHNF catches the key case of an evaluated variable
-
-     - exprOkForSpeculation is /false/ of an evaluated variable;
-       See Note [exprOkForSpeculation and evaluated variables] in GHC.Core.Utils
-       So we'd actually miss the key case!
-
-     - Nothing is gained from the extra generality of exprOkForSpeculation
-       since we only consider floating a case whose single alternative
-       is a DataAlt   K a b -> rhs
-
- * We can't float a case to top level
-
- * It's worth doing this float even if we don't float
-   the case outside a value lambda.  Example
-     case x of {
-       MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...)
-   If we floated the cases out we could eliminate one of them.
-
- * We only do this with a single-alternative case
-
-
-Note [Floating linear case]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Linear case can't be floated past case branches:
-    case u of { p1 -> case[1] v of { C x -> ...x...}; p2 -> ... }
-Is well typed, but
-    case[1] v of { C x -> case u of { p1 -> ...x...; p2 -> ... }}
-Will not be, because of how `x` is used in one alternative but not the other.
-
-It is not easy to float this linear cases precisely, so, instead, we elect, for
-the moment, to simply not float linear case.
-
-
-Note [Setting levels when floating single-alternative cases]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Handling level-setting when floating a single-alternative case binding
-is a bit subtle, as evidenced by #16978.  In particular, we must keep
-in mind that we are merely moving the case and its binders, not the
-body. For example, suppose 'a' is known to be evaluated and we have
-
-  \z -> case a of
-          (x,_) -> <body involving x and z>
-
-After floating we may have:
-
-  case a of
-    (x,_) -> \z -> <body involving x and z>
-      {- some expression involving x and z -}
-
-When analysing <body involving...> we want to use the /ambient/ level,
-and /not/ the destination level of the 'case a of (x,-) ->' binding.
-
-#16978 was caused by us setting the context level to the destination
-level of `x` when analysing <body>. This led us to conclude that we
-needed to quantify over some of its free variables (e.g. z), resulting
-in shadowing and very confusing Core Lint failures.
-
-
-Note [Check the output scrutinee for exprIsHNF]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this:
-  case x of y {
-    A -> ....(case y of alts)....
-  }
-
-Because of the binder-swap, the inner case will get substituted to
-(case x of ..).  So when testing whether the scrutinee is in HNF we
-must be careful to test the *result* scrutinee ('x' in this case), not
-the *input* one 'y'.  The latter *is* in HNF here (because y is
-evaluated), but the former is not -- and indeed we can't float the
-inner case out, at least not unless x is also evaluated at its binding
-site.  See #5453.
-
-That's why we apply exprIsHNF to scrut' and not to scrut.
-
-See Note [Floating single-alternative cases] for why
-we use exprIsHNF in the first place.
--}
-
-lvlNonTailMFE :: LevelEnv             -- Level of in-scope names/tyvars
-              -> Bool                 -- True <=> strict context [body of case
-                                      --   or let]
-              -> CoreExprWithFVs      -- input expression
-              -> LvlM LevelledExpr    -- Result expression
-lvlNonTailMFE env strict_ctxt ann_expr
-  = lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr
-
-lvlMFE ::  LevelEnv             -- Level of in-scope names/tyvars
-        -> Bool                 -- True <=> strict context [body of case or let]
-        -> CoreExprWithFVs      -- input expression
-        -> LvlM LevelledExpr    -- Result expression
--- lvlMFE is just like lvlExpr, except that it might let-bind
--- the expression, so that it can itself be floated.
-
-lvlMFE env _ (_, AnnType ty)
-  = return (Type (substTyUnchecked (le_subst env) ty))
-
--- No point in floating out an expression wrapped in a coercion or note
--- If we do we'll transform  lvl = e |> co
---                       to  lvl' = e; lvl = lvl' |> co
--- and then inline lvl.  Better just to float out the payload.
-lvlMFE env strict_ctxt (_, AnnTick t e)
-  = do { e' <- lvlMFE env strict_ctxt e
-       ; let t' = substTickish (le_subst env) t
-       ; return (Tick t' e') }
-
-lvlMFE env strict_ctxt (_, AnnCast e (_, co))
-  = do  { e' <- lvlMFE env strict_ctxt e
-        ; return (Cast e' (substCo (le_subst env) co)) }
-
-lvlMFE env strict_ctxt e@(_, AnnCase {})
-  | strict_ctxt       -- Don't share cases in a strict context
-  = lvlExpr env e     -- See Note [Case MFEs]
-
-lvlMFE env strict_ctxt ann_expr
-  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)
-         -- Only floating to the top level is allowed.
-  || hasFreeJoin env fvs   -- If there is a free join, don't float
-                           -- See Note [Free join points]
-  || not (typeHasFixedRuntimeRep (exprType expr))
-         -- We can't let-bind an expression if we don't know
-         -- how it will be represented at runtime.
-         -- See Note [Representation polymorphism invariants] in GHC.Core
-  || notWorthFloating expr abs_vars
-  || not float_me
-  =     -- Don't float it out
-    lvlExpr env ann_expr
-
-  |  float_is_new_lam || exprIsTopLevelBindable expr expr_ty
-         -- No wrapping needed if the type is lifted, or is a literal string
-         -- or if we are wrapping it in one or more value lambdas
-  = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive
-                              is_bot_lam join_arity_maybe ann_expr
-                  -- Treat the expr just like a right-hand side
-       ; var <- newLvlVar expr1 join_arity_maybe is_mk_static
-       ; let var2 = annotateBotStr var float_n_lams mb_bot_str
-       ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)
-                     (mkVarApps (Var var2) abs_vars)) }
-
-  -- OK, so the float has an unlifted type (not top-level bindable)
-  --     and no new value lambdas (float_is_new_lam is False)
-  -- Try for the boxing strategy
-  -- See Note [Floating MFEs of unlifted type]
-  | escapes_value_lam
-  , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions
-                         -- See Note [Test cheapness with exprOkForSpeculation]
-  , BI_Box { bi_data_con = box_dc, bi_inst_con = boxing_expr
-           , bi_boxed_type = box_ty } <- boxingDataCon expr_ty
-  , let [bx_bndr, ubx_bndr] = mkTemplateLocals [box_ty, expr_ty]
-  = do { expr1 <- lvlExpr rhs_env ann_expr
-       ; let l1r       = incMinorLvlFrom rhs_env
-             float_rhs = mkLams abs_vars_w_lvls $
-                         Case expr1 (stayPut l1r ubx_bndr) box_ty
-                             [Alt DEFAULT [] (App boxing_expr (Var ubx_bndr))]
-
-       ; var <- newLvlVar float_rhs Nothing is_mk_static
-       ; let l1u      = incMinorLvlFrom env
-             use_expr = Case (mkVarApps (Var var) abs_vars)
-                             (stayPut l1u bx_bndr) expr_ty
-                             [Alt (DataAlt box_dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)]
-       ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs)
-                     use_expr) }
-
-  | otherwise          -- e.g. do not float unboxed tuples
-  = lvlExpr env ann_expr
-
-  where
-    expr         = deAnnotate ann_expr
-    expr_ty      = exprType expr
-    fvs          = freeVarsOf ann_expr
-    fvs_ty       = tyCoVarsOfType expr_ty
-    is_bot_lam   = isJust mb_bot_str   -- True of bottoming thunks too!
-    is_function  = isFunction ann_expr
-    mb_bot_str   = exprBotStrictness_maybe expr
-                           -- See Note [Bottoming floats]
-                           -- esp Bottoming floats (2)
-    expr_ok_for_spec = exprOkForSpeculation expr
-    abs_vars = abstractVars dest_lvl env fvs
-    dest_lvl = destLevel env fvs fvs_ty is_function is_bot_lam False
-               -- NB: is_bot_lam not is_bot; see (3) in
-               --     Note [Bottoming floats]
-
-    -- float_is_new_lam: the floated thing will be a new value lambda
-    -- replacing, say (g (x+4)) by (lvl x).  No work is saved, nor is
-    -- allocation saved.  The benefit is to get it to the top level
-    -- and hence out of the body of this function altogether, making
-    -- it smaller and more inlinable
-    float_is_new_lam = float_n_lams > 0
-    float_n_lams     = count isId abs_vars
-
-    (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
-
-    join_arity_maybe = Nothing
-
-    is_mk_static = isJust (collectMakeStaticArgs expr)
-        -- Yuk: See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable
-
-        -- A decision to float entails let-binding this thing, and we only do
-        -- that if we'll escape a value lambda, or will go to the top level.
-    float_me = saves_work || saves_alloc || is_mk_static
-
-    -- We can save work if we can move a redex outside a value lambda
-    -- But if float_is_new_lam is True, then the redex is wrapped in a
-    -- a new lambda, so no work is saved
-    saves_work = escapes_value_lam && not float_is_new_lam
-
-    escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env)
-                  -- See Note [Escaping a value lambda]
-
-    -- See Note [Floating to the top]
-    saves_alloc =  isTopLvl dest_lvl
-                && floatConsts env
-                && (   not strict_ctxt                     -- (a)
-                    || exprIsHNF expr                      -- (b)
-                    || (is_bot_lam && escapes_value_lam))  -- (c)
-
-hasFreeJoin :: LevelEnv -> DVarSet -> Bool
--- Has a free join point which is not being floated to top level.
--- (In the latter case it won't be a join point any more.)
--- Not treating top-level ones specially had a massive effect
--- on nofib/minimax/Prog.prog
-hasFreeJoin env fvs
-  = not (maxFvLevel isJoinId env fvs == tOP_LEVEL)
-
-{- Note [Floating to the top]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose saves_work is False, i.e.
- - 'e' does not escape a value lambda (escapes_value_lam), or
- - 'e' would have added value lambdas if floated (float_is_new_lam)
-Then we may still be keen to float a sub-expression 'e' to the top level,
-for two reasons:
-
- (i) Doing so makes the function smaller, by floating out
-     bottoming expressions, or integer or string literals.  That in
-     turn makes it easier to inline, with less duplication.
-     This only matters if the floated sub-expression is inside a
-     value-lambda, which in turn may be easier to inline.
-
- (ii) (Minor) Doing so may turn a dynamic allocation (done by machine
-      instructions) into a static one. Minor because we are assuming
-      we are not escaping a value lambda.
-
-But only do so if (saves_alloc):
-     (a) the context is lazy (so we get allocation), or
-     (b) the expression is a HNF (so we get allocation), or
-     (c) the expression is bottoming and (i) applies
-         (NB: if the expression is a lambda, (b) will apply;
-              so this case only catches bottoming thunks)
-
-Examples:
-
-* (a) Strict.  Case scrutinee
-      f = case g True of ....
-  Don't float (g True) to top level; then we have the admin of a
-  top-level thunk to worry about, with zero gain.
-
-* (a) Strict.  Case alternative
-      h = case y of
-             True  -> g True
-             False -> False
-  Don't float (g True) to the top level
-
-* (b) HNF
-      f = case y of
-            True  -> p:q
-            False -> blah
-  We may as well float the (p:q) so it becomes a static data structure.
-
-* (c) Bottoming expressions; see also Note [Bottoming floats]
-      f x = case x of
-              0 -> error <big thing>
-              _ -> x+1
-  Here we want to float (error <big thing>) to top level, abstracting
-  over 'x', so as to make f's RHS smaller.
-
-  But (#22494) if it's more like
-       foo = case error <thing> of { ... }
-  then there is no point in floating; we are never going to inline
-  'foo' anyway.  So float bottoming things only if they escape
-  a lambda.
-
-* Arguments
-     t = f (g True)
-  Prior to Apr 22 we didn't float (g True) to the top if f was strict.
-  But (a) this only affected CAFs, because if it escapes a value lambda
-          we'll definitely float it; so the complication of working out
-          argument strictness doesn't seem worth it.
-      (b) floating to the top helps SpecContr; see GHC.Core.Opt.SpecConstr
-          Note [Specialising on dictionaries].
-  So now we don't use strictness to affect argument floating.
-
-It's controlled by a flag (floatConsts), because doing this too
-early loses opportunities for RULES which (needless to say) are
-important in some nofib programs (gcd is an example).  [SPJ note:
-I think this is obsolete; the flag seems always on.]
-
-Note [Floating join point bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Mostly we only float a join point if it can /stay/ a join point.  But
-there is one exception: if it can go to the top level (#13286).
-Consider
-  f x = joinrec j y n = <...j y' n'...>
-        in jump j x 0
-
-Here we may just as well produce
-  j y n = <....j y' n'...>
-  f x = j x 0
-
-and now there is a chance that 'f' will be inlined at its call sites.
-It shouldn't make a lot of difference, but these tests
-  perf/should_run/MethSharing
-  simplCore/should_compile/spec-inline
-and one nofib program, all improve if you do float to top, because
-of the resulting inlining of f.  So ok, let's do it.
-
-Note [Free join points]
-~~~~~~~~~~~~~~~~~~~~~~~
-We never float a MFE that has a free join-point variable.  You might think
-this can never occur.  After all, consider
-     join j x = ...
-     in ....(jump j x)....
-How might we ever want to float that (jump j x)?
-  * If it would escape a value lambda, thus
-        join j x = ... in (\y. ...(jump j x)... )
-    then 'j' isn't a valid join point in the first place.
-
-But consider
-     join j x = .... in
-     joinrec j2 y =  ...(jump j x)...(a+b)....
-
-Since j2 is recursive, it /is/ worth floating (a+b) out of the joinrec.
-But it is emphatically /not/ good to float the (jump j x) out:
- (a) 'j' will stop being a join point
- (b) In any case, jumping to 'j' must be an exit of the j2 loop, so no
-     work would be saved by floating it out of the \y.
-
-Even if we floated 'j' to top level, (b) would still hold.
-
-Bottom line: never float a MFE that has a free JoinId.
-
-Note [Floating MFEs of unlifted type]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-   case f x of (r::Int#) -> blah
-we'd like to float (f x). But it's not trivial because it has type
-Int#, and we don't want to evaluate it too early.  But we can instead
-float a boxed version
-   y = case f x of r -> I# r
-and replace the original (f x) with
-   case (case y of I# r -> r) of r -> blah
-
-Being able to float unboxed expressions is sometimes important; see #12603.
-I'm not sure how /often/ it is important, but it's not hard to achieve.
-
-We only do it for a fixed collection of types for which we have a
-convenient boxing constructor (see boxingDataCon_maybe).  In
-particular we /don't/ do it for unboxed tuples; it's better to float
-the components of the tuple individually.
-
-I did experiment with a form of boxing that works for any type, namely
-wrapping in a function.  In our example
-
-   let y = case f x of r -> \v. f x
-   in case y void of r -> blah
-
-It works fine, but it's 50% slower (based on some crude benchmarking).
-I suppose we could do it for types not covered by boxingDataCon_maybe,
-but it's more code and I'll wait to see if anyone wants it.
-
-Note [Test cheapness with exprOkForSpeculation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We don't want to float very cheap expressions by boxing and unboxing.
-But we use exprOkForSpeculation for the test, not exprIsCheap.
-Why?  Because it's important /not/ to transform
-     let x = a /# 3
-to
-     let x = case bx of I# a -> a /# 3
-because the let binding no
-longer obeys the let-can-float invariant.  But (a /# 3) is ok-for-spec
-due to a special hack that says division operators can't fail
-when the denominator is definitely non-zero.  And yet that
-same expression says False to exprIsCheap.  Simplest way to
-guarantee the let-can-float invariant is to use the same function!
-
-If an expression is okay for speculation, we could also float it out
-*without* boxing and unboxing, since evaluating it early is okay.
-However, it turned out to usually be better not to float such expressions,
-since they tend to be extremely cheap things like (x +# 1#). Even the
-cost of spilling the let-bound variable to the stack across a call may
-exceed the cost of recomputing such an expression. (And we can't float
-unlifted bindings to top-level.)
-
-We could try to do something smarter here, and float out expensive yet
-okay-for-speculation things, such as division by non-zero constants.
-But I suspect it's a narrow target.
-
-Note [Bottoming floats]
-~~~~~~~~~~~~~~~~~~~~~~~
-If we see
-        f = \x. g (error "urk")
-we'd like to float the call to error, to get
-        lvl = error "urk"
-        f = \x. g lvl
-
-But, as ever, we need to be careful:
-
-(1) We want to float a bottoming
-    expression even if it has free variables:
-        f = \x. g (let v = h x in error ("urk" ++ v))
-    Then we'd like to abstract over 'x', and float the whole arg of g:
-        lvl = \x. let v = h x in error ("urk" ++ v)
-        f = \x. g (lvl x)
-    To achieve this we pass is_bot to destLevel
-
-(2) We do not do this for lambdas that return
-    bottom.  Instead we treat the /body/ of such a function specially,
-    via point (1).  For example:
-        f = \x. ....(\y z. if x then error y else error z)....
-    If we float the whole lambda thus
-        lvl = \x. \y z. if x then error y else error z
-        f = \x. ...(lvl x)...
-    we may well end up eta-expanding that PAP to
-        f = \x. ...(\y z. lvl x y z)...
-
-    ===>
-        lvl = \x z y. if b then error y else error z
-        f = \x. ...(\y z. lvl x z y)...
-    (There is no guarantee that we'll choose the perfect argument order.)
-
-(3) If we have a /binding/ that returns bottom, we want to float it to top
-    level, even if it has free vars (point (1)), and even it has lambdas.
-    Example:
-       ... let { v = \y. error (show x ++ show y) } in ...
-    We want to abstract over x and float the whole thing to top:
-       lvl = \xy. error (show x ++ show y)
-       ...let {v = lvl x} in ...
-
-    Then of course we don't want to separately float the body (error ...)
-    as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot
-    argument.
-
-See Maessen's paper 1999 "Bottom extraction: factoring error handling out
-of functional programs" (unpublished I think).
-
-When we do this, we set the strictness and arity of the new bottoming
-Id, *immediately*, for three reasons:
-
-  * To prevent the abstracted thing being immediately inlined back in again
-    via preInlineUnconditionally.  The latter has a test for bottoming Ids
-    to stop inlining them, so we'd better make sure it *is* a bottoming Id!
-
-  * So that it's properly exposed as such in the interface file, even if
-    this is all happening after strictness analysis.
-
-  * In case we do CSE with the same expression that *is* marked bottom
-        lvl          = error "urk"
-          x{str=bot) = error "urk"
-    Here we don't want to replace 'x' with 'lvl', else we may get Lint
-    errors, e.g. via a case with empty alternatives:  (case x of {})
-    Lint complains unless the scrutinee of such a case is clearly bottom.
-
-    This was reported in #11290.   But since the whole bottoming-float
-    thing is based on the cheap-and-cheerful exprIsDeadEnd, I'm not sure
-    that it'll nail all such cases.
-
-Note [Case MFEs]
-~~~~~~~~~~~~~~~~
-We don't float a case expression as an MFE from a strict context.  Why not?
-Because in doing so we share a tiny bit of computation (the switch) but
-in exchange we build a thunk, which is bad.  This case reduces allocation
-by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.
-Doesn't change any other allocation at all.
-
-We will make a separate decision for the scrutinee and alternatives.
-
-However this can have a knock-on effect for fusion: consider
-    \v -> foldr k z (case x of I# y -> build ..y..)
-Perhaps we can float the entire (case x of ...) out of the \v.  Then
-fusion will not happen, but we will get more sharing.  But if we don't
-float the case (as advocated here) we won't float the (build ...y..)
-either, so fusion will happen.  It can be a big effect, esp in some
-artificial benchmarks (e.g. integer, queens), but there is no perfect
-answer.
-
--}
-
-annotateBotStr :: Id -> Arity -> Maybe (Arity, DmdSig, CprSig) -> Id
--- See Note [Bottoming floats] for why we want to add
--- bottoming information right now
---
--- n_extra are the number of extra value arguments added during floating
-annotateBotStr id n_extra mb_bot_str
-  | Just (arity, str_sig, cpr_sig) <- mb_bot_str
-  = id `setIdArity`  (arity + n_extra)
-       `setIdDmdSig` prependArgsDmdSig n_extra str_sig
-       `setIdCprSig` prependArgsCprSig n_extra cpr_sig
-  | otherwise
-  = id
-
-notWorthFloating :: CoreExpr -> [Var] -> Bool
--- Returns True if the expression would be replaced by
--- something bigger than it is now.  For example:
---   abs_vars = tvars only:  return True if e is trivial,
---                           but False for anything bigger
---   abs_vars = [x] (an Id): return True for trivial, or an application (f x)
---                           but False for (f x x)
---
--- One big goal is that floating should be idempotent.  Eg if
--- we replace e with (lvl79 x y) and then run FloatOut again, don't want
--- to replace (lvl79 x y) with (lvl83 x y)!
-
-notWorthFloating e abs_vars
-  = go e (count isId abs_vars)
-  where
-    go (Var {}) n    = n >= 0
-    go (Lit lit) n   = assert (n==0) $
-                       litIsTrivial lit   -- Note [Floating literals]
-    go (Tick t e) n  = not (tickishIsCode t) && go e n
-    go (Cast e _)  n = go e n
-    go (App e arg) n
-       -- See Note [Floating applications to coercions]
-       | Type {} <- arg = go e n
-       | n==0           = False
-       | is_triv arg    = go e (n-1)
-       | otherwise      = False
-    go _ _              = False
-
-    is_triv (Lit {})              = True        -- Treat all literals as trivial
-    is_triv (Var {})              = True        -- (ie not worth floating)
-    is_triv (Cast e _)            = is_triv e
-    is_triv (App e (Type {}))     = is_triv e   -- See Note [Floating applications to coercions]
-    is_triv (Tick t e)            = not (tickishIsCode t) && is_triv e
-    is_triv _                     = False
-
-{-
-Note [Floating literals]
-~~~~~~~~~~~~~~~~~~~~~~~~
-It's important to float Integer literals, so that they get shared,
-rather than being allocated every time round the loop.
-Hence the litIsTrivial.
-
-Ditto literal strings (LitString), which we'd like to float to top
-level, which is now possible.
-
-Note [Floating applications to coercions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We don’t float out variables applied only to type arguments, since the
-extra binding would be pointless: type arguments are completely erased.
-But *coercion* arguments aren’t (see Note [Coercion tokens] in
-"GHC.CoreToStg" and Note [Count coercion arguments in boring contexts] in
-"GHC.Core.Unfold"), so we still want to float out variables applied only to
-coercion arguments.
-
-Note [Escaping a value lambda]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We want to float even cheap expressions out of value lambdas,
-because that saves allocation.  Consider
-        f = \x.  .. (\y.e) ...
-Then we'd like to avoid allocating the (\y.e) every time we call f,
-(assuming e does not mention x). An example where this really makes a
-difference is simplrun009.
-
-Another reason it's good is because it makes SpecContr fire on functions.
-Consider
-        f = \x. ....(f (\y.e))....
-After floating we get
-        lvl = \y.e
-        f = \x. ....(f lvl)...
-and that is much easier for SpecConstr to generate a robust
-specialisation for.
-
-However, if we are wrapping the thing in extra value lambdas (in
-abs_vars), then nothing is saved.  E.g.
-        f = \xyz. ...(e1[y],e2)....
-If we float
-        lvl = \y. (e1[y],e2)
-        f = \xyz. ...(lvl y)...
-we have saved nothing: one pair will still be allocated for each
-call of 'f'.  Hence the (not float_is_lam) in float_me.
-
-
-************************************************************************
-*                                                                      *
-\subsection{Bindings}
-*                                                                      *
-************************************************************************
-
-The binding stuff works for top level too.
--}
-
-lvlBind :: LevelEnv
-        -> CoreBindWithFVs
-        -> LvlM (LevelledBind, LevelEnv)
-
-lvlBind env (AnnNonRec bndr rhs)
-  | isTyVar bndr    -- Don't do anything for TyVar binders
-                    --   (simplifier gets rid of them pronto)
-  || isCoVar bndr   -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)
-                    -- so we will ignore this case for now
-  || not (profitableFloat env dest_lvl)
-  || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty))
-          -- We can't float an unlifted binding to top level (except
-          -- literal strings), so we don't float it at all.  It's a
-          -- bit brutal, but unlifted bindings aren't expensive either
-
-  = -- No float
-    do { rhs' <- lvlRhs env NonRecursive is_bot_lam mb_join_arity rhs
-       ; let  bind_lvl        = incMinorLvl (le_ctxt_lvl env)
-              (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]
-       ; return (NonRec bndr' rhs', env') }
-
-  -- Otherwise we are going to float
-  | null abs_vars
-  = do {  -- No type abstraction; clone existing binder
-         rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive
-                             is_bot_lam mb_join_arity rhs
-       ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]
-       ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str
-       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
-
-  | otherwise
-  = do {  -- Yes, type abstraction; create a new binder, extend substitution, etc
-         rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive
-                             is_bot_lam mb_join_arity rhs
-       ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]
-       ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str
-       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
-
-  where
-    bndr_ty    = idType bndr
-    ty_fvs     = tyCoVarsOfType bndr_ty
-    rhs_fvs    = freeVarsOf rhs
-    bind_fvs   = rhs_fvs `unionDVarSet` dIdFreeVars bndr
-    abs_vars   = abstractVars dest_lvl env bind_fvs
-    dest_lvl   = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot_lam is_join
-
-    deann_rhs  = deAnnotate rhs
-    mb_bot_str = exprBotStrictness_maybe deann_rhs
-    is_bot_lam = isJust mb_bot_str
-        -- is_bot_lam: looks like (\xy. bot), maybe zero lams
-        -- NB: not isBottomThunk!  See Note [Bottoming floats] point (3)
-
-    n_extra    = count isId abs_vars
-    mb_join_arity = isJoinId_maybe bndr
-    is_join       = isJust mb_join_arity
-
-lvlBind env (AnnRec pairs)
-  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)
-         -- Only floating to the top level is allowed.
-  || not (profitableFloat env dest_lvl)
-  || (isTopLvl dest_lvl && any (mightBeUnliftedType . idType) bndrs)
-       -- This mightBeUnliftedType stuff is the same test as in the non-rec case
-       -- You might wonder whether we can have a recursive binding for
-       -- an unlifted value -- but we can if it's a /join binding/ (#16978)
-       -- (Ultimately I think we should not use GHC.Core.Opt.SetLevels to
-       -- float join bindings at all, but that's another story.)
-  =    -- No float
-    do { let bind_lvl       = incMinorLvl (le_ctxt_lvl env)
-             (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs
-             lvl_rhs (b,r)  = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r
-       ; rhss' <- mapM lvl_rhs pairs
-       ; return (Rec (bndrs' `zip` rhss'), env') }
-
-  -- Otherwise we are going to float
-  | null abs_vars
-  = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs
-       ; new_rhss <- mapM (do_rhs new_env) pairs
-       ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)
-                , new_env) }
-
--- ToDo: when enabling the floatLambda stuff,
---       I think we want to stop doing this
-  | [(bndr,rhs)] <- pairs
-  , count isId abs_vars > 1
-  = do  -- Special case for self recursion where there are
-        -- several variables carried around: build a local loop:
-        --      poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars
-        -- This just makes the closures a bit smaller.  If we don't do
-        -- this, allocation rises significantly on some programs
-        --
-        -- We could elaborate it for the case where there are several
-        -- mutually recursive functions, but it's quite a bit more complicated
-        --
-        -- This all seems a bit ad hoc -- sigh
-    let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
-        rhs_lvl = le_ctxt_lvl rhs_env
-
-    (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr]
-    let
-        (lam_bndrs, rhs_body)   = collectAnnBndrs rhs
-        (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs
-        (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1
-    new_rhs_body <- lvlRhs body_env2 Recursive is_bot (get_join bndr) rhs_body
-    (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]
-    return (Rec [(TB poly_bndr (FloatMe dest_lvl)
-                 , mkLams abs_vars_w_lvls $
-                   mkLams lam_bndrs2 $
-                   Let (Rec [( TB new_bndr (StayPut rhs_lvl)
-                             , mkLams lam_bndrs2 new_rhs_body)])
-                       (mkVarApps (Var new_bndr) lam_bndrs1))]
-           , poly_env)
-
-  | otherwise  -- Non-null abs_vars
-  = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs
-       ; new_rhss <- mapM (do_rhs new_env) pairs
-       ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)
-                , new_env) }
-
-  where
-    (bndrs,rhss) = unzip pairs
-    is_join  = isJoinId (head bndrs)
-                -- bndrs is always non-empty and if one is a join they all are
-                -- Both are checked by Lint
-    is_fun   = all isFunction rhss
-    is_bot   = False  -- It's odd to have an unconditionally divergent
-                      -- function in a Rec, and we don't much care what
-                      -- happens to it.  False is simple!
-
-    do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive
-                                        is_bot (get_join bndr)
-                                        rhs
-
-    get_join bndr | need_zap  = Nothing
-                  | otherwise = isJoinId_maybe bndr
-    need_zap = dest_lvl `ltLvl` joinCeilingLevel env
-
-        -- Finding the free vars of the binding group is annoying
-    bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs])
-                `unionDVarSet`
-                (fvDVarSet $ unionsFV [ idFVs bndr
-                                      | (bndr, (_,_)) <- pairs]))
-               `delDVarSetList`
-                bndrs
-
-    ty_fvs   = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs
-    dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join
-    abs_vars = abstractVars dest_lvl env bind_fvs
-
-profitableFloat :: LevelEnv -> Level -> Bool
-profitableFloat env dest_lvl
-  =  (dest_lvl `ltMajLvl` le_ctxt_lvl env)  -- Escapes a value lambda
-  || (isTopLvl dest_lvl && floatConsts env) -- Going all the way to top level
-
-
-----------------------------------------------------
--- Three help functions for the type-abstraction case
-
-lvlRhs :: LevelEnv
-       -> RecFlag
-       -> Bool               -- Is this a bottoming function
-       -> Maybe JoinArity
-       -> CoreExprWithFVs
-       -> LvlM LevelledExpr
-lvlRhs env rec_flag is_bot mb_join_arity expr
-  = lvlFloatRhs [] (le_ctxt_lvl env) env
-                rec_flag is_bot mb_join_arity expr
-
-lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag
-            -> Bool   -- Binding is for a bottoming function
-            -> Maybe JoinArity
-            -> CoreExprWithFVs
-            -> LvlM (Expr LevelledBndr)
--- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline
-lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs
-  = do { body' <- if not is_bot  -- See Note [Floating from a RHS]
-                     && any isId bndrs
-                  then lvlMFE  body_env True body
-                  else lvlExpr body_env      body
-       ; return (mkLams bndrs' body') }
-  where
-    (bndrs, body)     | Just join_arity <- mb_join_arity
-                      = collectNAnnBndrs join_arity rhs
-                      | otherwise
-                      = collectAnnBndrs rhs
-    (env1, bndrs1)    = substBndrsSL NonRecursive env bndrs
-    all_bndrs         = abs_vars ++ bndrs1
-    (body_env, bndrs') | Just _ <- mb_join_arity
-                      = lvlJoinBndrs env1 dest_lvl rec all_bndrs
-                      | otherwise
-                      = case lvlLamBndrs env1 dest_lvl all_bndrs of
-                          (env2, bndrs') -> (placeJoinCeiling env2, bndrs')
-        -- The important thing here is that we call lvlLamBndrs on
-        -- all these binders at once (abs_vars and bndrs), so they
-        -- all get the same major level.  Otherwise we create stupid
-        -- let-bindings inside, joyfully thinking they can float; but
-        -- in the end they don't because we never float bindings in
-        -- between lambdas
-
-{- Note [Floating from a RHS]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When floating the RHS of a let-binding, we don't always want to apply
-lvlMFE to the body of a lambda, as we usually do, because the entire
-binding body is already going to the right place (dest_lvl).
-
-A particular example is the top level.  Consider
-   concat = /\ a -> foldr ..a.. (++) []
-We don't want to float the body of the lambda to get
-   lvl    = /\ a -> foldr ..a.. (++) []
-   concat = /\ a -> lvl a
-That would be stupid.
-
-Previously this was avoided in a much nastier way, by testing strict_ctxt
-in float_me in lvlMFE.  But that wasn't even right because it would fail
-to float out the error sub-expression in
-    f = \x. case x of
-              True  -> error ("blah" ++ show x)
-              False -> ...
-
-But we must be careful:
-
-* If we had
-    f = \x -> factorial 20
-  we /would/ want to float that (factorial 20) out!  Functions are treated
-  differently: see the use of isFunction in the calls to destLevel. If
-  there are only type lambdas, then destLevel will say "go to top, and
-  abstract over the free tyvars" and we don't want that here.
-
-* But if we had
-    f = \x -> error (...x....)
-  we would NOT want to float the bottoming expression out to give
-    lvl = \x -> error (...x...)
-    f = \x -> lvl x
-
-Conclusion: use lvlMFE if there are
-  * any value lambdas in the original function, and
-  * this is not a bottoming function (the is_bot argument)
-Use lvlExpr otherwise.  A little subtle, and I got it wrong at least twice
-(e.g. #13369).
--}
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Deciding floatability}
-*                                                                      *
-************************************************************************
--}
-
-substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr])
-substAndLvlBndrs is_rec env lvl bndrs
-  = lvlBndrs subst_env lvl subst_bndrs
-  where
-    (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs
-
-substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar])
--- So named only to avoid the name clash with GHC.Core.Subst.substBndrs
-substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs
-  = ( env { le_subst    = subst'
-          , le_env      = foldl' add_id  id_env (bndrs `zip` bndrs') }
-    , bndrs')
-  where
-    (subst', bndrs') = case is_rec of
-                         NonRecursive -> substBndrs    subst bndrs
-                         Recursive    -> substRecBndrs subst bndrs
-
-lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr])
--- Compute the levels for the binders of a lambda group
-lvlLamBndrs env lvl bndrs
-  = lvlBndrs env new_lvl bndrs
-  where
-    new_lvl | any is_major bndrs = incMajorLvl lvl
-            | otherwise          = incMinorLvl lvl
-
-    is_major bndr = not (isOneShotBndr bndr)
-       -- Only non-one-shot lambdas bump a major level, which in
-       -- turn triggers floating.  NB: isOneShotBndr is always
-       -- true of a type variable -- there is no point in floating
-       -- out of a big lambda.
-       -- See Note [Computing one-shot info] in GHC.Types.Demand
-
-lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar]
-             -> (LevelEnv, [LevelledBndr])
-lvlJoinBndrs env lvl rec bndrs
-  = lvlBndrs env new_lvl bndrs
-  where
-    new_lvl | isRec rec = incMajorLvl lvl
-            | otherwise = incMinorLvl lvl
-      -- Non-recursive join points are one-shot; recursive ones are not
-
-lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])
--- The binders returned are exactly the same as the ones passed,
--- apart from applying the substitution, but they are now paired
--- with a (StayPut level)
---
--- The returned envt has le_ctxt_lvl updated to the new_lvl
---
--- All the new binders get the same level, because
--- any floating binding is either going to float past
--- all or none.  We never separate binders.
-lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs
-  = ( env { le_ctxt_lvl = new_lvl
-          , le_join_ceil = new_lvl
-          , le_lvl_env  = addLvls new_lvl lvl_env bndrs }
-    , map (stayPut new_lvl) bndrs)
-
-stayPut :: Level -> OutVar -> LevelledBndr
-stayPut new_lvl bndr = TB bndr (StayPut new_lvl)
-
-  -- Destination level is the max Id level of the expression
-  -- (We'll abstract the type variables, if any.)
-destLevel :: LevelEnv
-          -> DVarSet    -- Free vars of the term
-          -> TyCoVarSet -- Free in the /type/ of the term
-                        -- (a subset of the previous argument)
-          -> Bool   -- True <=> is function
-          -> Bool   -- True <=> looks like \x1..xn.bottom (n>=0)
-          -> Bool   -- True <=> is a join point
-          -> Level
--- INVARIANT: if is_join=True then result >= join_ceiling
-destLevel env fvs fvs_ty is_function is_bot is_join
-  | isTopLvl max_fv_id_level  -- Float even joins if they get to top level
-                              -- See Note [Floating join point bindings]
-  = tOP_LEVEL
-
-  | is_join  -- Never float a join point past the join ceiling
-             -- See Note [Join points] in GHC.Core.Opt.FloatOut
-  = if max_fv_id_level `ltLvl` join_ceiling
-    then join_ceiling
-    else max_fv_id_level
-
-  | is_bot              -- Send bottoming bindings to the top
-  = as_far_as_poss      -- regardless; see Note [Bottoming floats]
-                        -- Esp Bottoming floats (1) and (3)
-
-  | Just n_args <- floatLams env
-  , n_args > 0  -- n=0 case handled uniformly by the 'otherwise' case
-  , is_function
-  , countFreeIds fvs <= n_args
-  = as_far_as_poss  -- Send functions to top level; see
-                    -- the comments with isFunction
-
-  | otherwise = max_fv_id_level
-  where
-    join_ceiling    = joinCeilingLevel env
-    max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the
-                                              -- tyvars will be abstracted
-
-    as_far_as_poss = maxFvLevel' isId env fvs_ty
-                     -- See Note [Floating and kind casts]
-
-{- Note [Floating and kind casts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this
-   case x of
-     K (co :: * ~# k) -> let v :: Int |> co
-                             v = e
-                         in blah
-
-Then, even if we are abstracting over Ids, or if e is bottom, we can't
-float v outside the 'co' binding.  Reason: if we did we'd get
-    v' :: forall k. (Int ~# Age) => Int |> co
-and now 'co' isn't in scope in that type. The underlying reason is
-that 'co' is a value-level thing and we can't abstract over that in a
-type (else we'd get a dependent type).  So if v's /type/ mentions 'co'
-we can't float it out beyond the binding site of 'co'.
-
-That's why we have this as_far_as_poss stuff.  Usually as_far_as_poss
-is just tOP_LEVEL; but occasionally a coercion variable (which is an
-Id) mentioned in type prevents this.
-
-Example #14270 comment:15.
--}
-
-
-isFunction :: CoreExprWithFVs -> Bool
--- The idea here is that we want to float *functions* to
--- the top level.  This saves no work, but
---      (a) it can make the host function body a lot smaller,
---              and hence inlinable.
---      (b) it can also save allocation when the function is recursive:
---          h = \x -> letrec f = \y -> ...f...y...x...
---                    in f x
---     becomes
---          f = \x y -> ...(f x)...y...x...
---          h = \x -> f x x
---     No allocation for f now.
--- We may only want to do this if there are sufficiently few free
--- variables.  We certainly only want to do it for values, and not for
--- constructors.  So the simple thing is just to look for lambdas
-isFunction (_, AnnLam b e) | isId b    = True
-                           | otherwise = isFunction e
--- isFunction (_, AnnTick _ e)         = isFunction e  -- dubious
-isFunction _                           = False
-
-countFreeIds :: DVarSet -> Int
-countFreeIds = nonDetStrictFoldUDFM add 0 . getUniqDSet
-  -- It's OK to use nonDetStrictFoldUDFM here because we're just counting things.
-  where
-    add :: Var -> Int -> Int
-    add v n | isId v    = n+1
-            | otherwise = n
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Free-To-Level Monad}
-*                                                                      *
-************************************************************************
--}
-
-data LevelEnv
-  = LE { le_switches :: FloatOutSwitches
-       , le_ctxt_lvl :: Level           -- The current level
-       , le_lvl_env  :: VarEnv Level    -- Domain is *post-cloned* TyVars and Ids
-       , le_join_ceil:: Level           -- Highest level to which joins float
-                                        -- Invariant: always >= le_ctxt_lvl
-
-       -- See Note [le_subst and le_env]
-       , le_subst    :: Subst           -- Domain is pre-cloned TyVars and Ids
-                                        -- The Id -> CoreExpr in the Subst is ignored
-                                        -- (since we want to substitute a LevelledExpr for
-                                        -- an Id via le_env) but we do use the Co/TyVar substs
-       , le_env      :: IdEnv ([OutVar], LevelledExpr)  -- Domain is pre-cloned Ids
-    }
-
-{- Note [le_subst and le_env]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We clone nested let- and case-bound variables so that they are still
-distinct when floated out; hence the le_subst/le_env.  (see point 3 of
-the module overview comment).  We also use these envs when making a
-variable polymorphic because we want to float it out past a big
-lambda.
-
-The le_subst and le_env always implement the same mapping,
-     in_x :->  out_x a b
-where out_x is an OutVar, and a,b are its arguments (when
-we perform abstraction at the same time as floating).
-
-  le_subst maps to CoreExpr
-  le_env   maps to LevelledExpr
-
-Since the range is always a variable or application, there is never
-any difference between the two, but sadly the types differ.  The
-le_subst is used when substituting in a variable's IdInfo; the le_env
-when we find a Var.
-
-In addition the le_env records a [OutVar] of variables free in the
-OutExpr/LevelledExpr, just so we don't have to call freeVars
-repeatedly.  This list is always non-empty, and the first element is
-out_x
-
-The domain of the both envs is *pre-cloned* Ids, though
-
-The domain of the le_lvl_env is the *post-cloned* Ids
--}
-
-initialEnv :: FloatOutSwitches -> CoreProgram -> LevelEnv
-initialEnv float_lams binds
-  = LE { le_switches  = float_lams
-       , le_ctxt_lvl  = tOP_LEVEL
-       , le_join_ceil = panic "initialEnv"
-       , le_lvl_env   = emptyVarEnv
-       , le_subst     = mkEmptySubst in_scope_toplvl
-       , le_env       = emptyVarEnv }
-  where
-    in_scope_toplvl = emptyInScopeSet `extendInScopeSetBndrs` binds
-      -- The Simplifier (see Note [Glomming] in GHC.Core.Opt.OccurAnal) and
-      -- the specialiser (see Note [Top level scope] in GHC.Core.Opt.Specialise)
-      -- may both produce top-level bindings where an early binding refers
-      -- to a later one.  So here we put all the top-level binders in scope before
-      -- we start, to satisfy the lookupIdSubst invariants (#20200 and #20294)
-
-addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
-addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl
-
-addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level
-addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs
-
-floatLams :: LevelEnv -> Maybe Int
-floatLams le = floatOutLambdas (le_switches le)
-
-floatConsts :: LevelEnv -> Bool
-floatConsts le = floatOutConstants (le_switches le)
-
-floatOverSat :: LevelEnv -> Bool
-floatOverSat le = floatOutOverSatApps (le_switches le)
-
-floatTopLvlOnly :: LevelEnv -> Bool
-floatTopLvlOnly le = floatToTopLevelOnly (le_switches le)
-
-incMinorLvlFrom :: LevelEnv -> Level
-incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env)
-
--- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can
--- See Note [Binder-swap during float-out]
-extendCaseBndrEnv :: LevelEnv
-                  -> Id                 -- Pre-cloned case binder
-                  -> Expr LevelledBndr  -- Post-cloned scrutinee
-                  -> LevelEnv
-extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })
-                  case_bndr (Var scrut_var)
-  -- We could use OccurAnal. scrutBinderSwap_maybe here, and perhaps
-  -- get a bit more floating.  But we didn't in the past and it's
-  -- an unforced change, so I'm leaving it.
-  = le { le_subst   = extendSubstWithVar subst case_bndr scrut_var
-       , le_env     = add_id id_env (case_bndr, scrut_var) }
-extendCaseBndrEnv env _ _ = env
-
--- See Note [Join ceiling]
-placeJoinCeiling :: LevelEnv -> LevelEnv
-placeJoinCeiling le@(LE { le_ctxt_lvl = lvl })
-  = le { le_ctxt_lvl = lvl', le_join_ceil = lvl' }
-  where
-    lvl' = asJoinCeilLvl (incMinorLvl lvl)
-
-maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level
-maxFvLevel max_me env var_set
-  = nonDetStrictFoldDVarSet (maxIn max_me env) tOP_LEVEL var_set
-    -- It's OK to use a non-deterministic fold here because maxIn commutes.
-
-maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level
--- Same but for TyCoVarSet
-maxFvLevel' max_me env var_set
-  = nonDetStrictFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set
-    -- It's OK to use a non-deterministic fold here because maxIn commutes.
-
-maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level
-maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl
-  = case lookupVarEnv id_env in_var of
-      Just (abs_vars, _) -> foldr max_out lvl abs_vars
-      Nothing            -> max_out in_var lvl
-  where
-    max_out out_var lvl
-        | max_me out_var = case lookupVarEnv lvl_env out_var of
-                                Just lvl' -> maxLvl lvl' lvl
-                                Nothing   -> lvl
-        | otherwise = lvl       -- Ignore some vars depending on max_me
-
-lookupVar :: LevelEnv -> Id -> LevelledExpr
-lookupVar le v = case lookupVarEnv (le_env le) v of
-                    Just (_, expr) -> expr
-                    _              -> Var v
-
--- Level to which join points are allowed to float (boundary of current tail
--- context). See Note [Join ceiling]
-joinCeilingLevel :: LevelEnv -> Level
-joinCeilingLevel = le_join_ceil
-
-abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]
-        -- Find the variables in fvs, free vars of the target expression,
-        -- whose level is greater than the destination level
-        -- These are the ones we are going to abstract out
-        --
-        -- Note that to get reproducible builds, the variables need to be
-        -- abstracted in deterministic order, not dependent on the values of
-        -- Uniques. This is achieved by using DVarSets, deterministic free
-        -- variable computation and deterministic sort.
-        -- See Note [Unique Determinism] in GHC.Types.Unique for explanation of why
-        -- Uniques are not deterministic.
-abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
-  =  -- NB: sortQuantVars might not put duplicates next to each other
-    map zap $ sortQuantVars $
-    filter abstract_me      $
-    dVarSetElems            $
-    closeOverKindsDSet      $
-    substDVarSet subst in_fvs
-        -- NB: it's important to call abstract_me only on the OutIds the
-        -- come from substDVarSet (not on fv, which is an InId)
-  where
-    abstract_me v = case lookupVarEnv lvl_env v of
-                        Just lvl -> dest_lvl `ltLvl` lvl
-                        Nothing  -> False
-
-        -- We are going to lambda-abstract, so nuke any IdInfo,
-        -- and add the tyvars of the Id (if necessary)
-    zap v | isId v = warnPprTrace (isStableUnfolding (idUnfolding v) ||
-                           not (isEmptyRuleInfo (idSpecialisation v)))
-                           "absVarsOf: discarding info on" (ppr v) $
-                     setIdInfo v vanillaIdInfo
-          | otherwise = v
-
-type LvlM result = UniqSM result
-
-initLvl :: UniqSupply -> UniqSM a -> a
-initLvl = initUs_
-
-newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId]
-             -> LvlM (LevelEnv, [OutId])
--- The envt is extended to bind the new bndrs to dest_lvl, but
--- the le_ctxt_lvl is unaffected
-newPolyBndrs dest_lvl
-             env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env })
-             abs_vars bndrs
- = assert (all (not . isCoVar) bndrs) $   -- What would we add to the CoSubst in this case. No easy answer.
-   do { uniqs <- getUniquesM
-      ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
-            bndr_prs  = bndrs `zip` new_bndrs
-            env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs
-                       , le_subst   = foldl' add_subst subst   bndr_prs
-                       , le_env     = foldl' add_id    id_env  bndr_prs }
-      ; return (env', new_bndrs) }
-  where
-    add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)
-    add_id    env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)
-
-    mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id
-                             transfer_join_info bndr $
-                             mkSysLocal str uniq (idMult bndr) poly_ty
-                           where
-                             str     = fsLit "poly_" `appendFS` occNameFS (getOccName bndr)
-                             poly_ty = mkLamTypes abs_vars (substTyUnchecked subst (idType bndr))
-
-    -- If we are floating a join point to top level, it stops being
-    -- a join point.  Otherwise it continues to be a join point,
-    -- but we may need to adjust its arity
-    dest_is_top = isTopLvl dest_lvl
-    transfer_join_info bndr new_bndr
-      | Just join_arity <- isJoinId_maybe bndr
-      , not dest_is_top
-      = new_bndr `asJoinId` join_arity + length abs_vars
-      | otherwise
-      = new_bndr
-
-newLvlVar :: LevelledExpr        -- The RHS of the new binding
-          -> Maybe JoinArity     -- Its join arity, if it is a join point
-          -> Bool                -- True <=> the RHS looks like (makeStatic ...)
-          -> LvlM Id
-newLvlVar lvld_rhs join_arity_maybe is_mk_static
-  = do { uniq <- getUniqueM
-       ; return (add_join_info (mk_id uniq rhs_ty))
-       }
-  where
-    add_join_info var = var `asJoinId_maybe` join_arity_maybe
-    de_tagged_rhs = deTagExpr lvld_rhs
-    rhs_ty        = exprType de_tagged_rhs
-
-    mk_id uniq rhs_ty
-      -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
-      | is_mk_static
-      = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
-                            rhs_ty
-      | otherwise
-      = mkSysLocal (mkFastString "lvl") uniq ManyTy rhs_ty
-
--- | Clone the binders bound by a single-alternative case.
-cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
-cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
-               new_lvl vs
-  = do { us <- getUniqueSupplyM
-       ; let (subst', vs') = cloneBndrs subst us vs
-             -- N.B. We are not moving the body of the case, merely its case
-             -- binders.  Consequently we should *not* set le_ctxt_lvl and
-             -- le_join_ceil.  See Note [Setting levels when floating
-             -- single-alternative cases].
-             env' = env { le_lvl_env   = addLvls new_lvl lvl_env vs'
-                        , le_subst     = subst'
-                        , le_env       = foldl' add_id id_env (vs `zip` vs') }
-
-       ; return (env', vs') }
-
-cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]
-             -> LvlM (LevelEnv, [OutVar])
--- See Note [Need for cloning during float-out]
--- Works for Ids bound by let(rec)
--- The dest_lvl is attributed to the binders in the new env,
--- but cloneVars doesn't affect the le_ctxt_lvl of the incoming env
-cloneLetVars is_rec
-          env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
-          dest_lvl vs
-  = do { us <- getUniqueSupplyM
-       ; let vs1  = map zap vs
-                      -- See Note [Zapping the demand info]
-             (subst', vs2) = case is_rec of
-                               NonRecursive -> cloneBndrs      subst us vs1
-                               Recursive    -> cloneRecIdBndrs subst us vs1
-             prs  = vs `zip` vs2
-             env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2
-                        , le_subst   = subst'
-                        , le_env     = foldl' add_id id_env prs }
-
-       ; return (env', vs2) }
-  where
-    zap :: Var -> Var
-    zap v | isId v    = zap_join (zapIdDemandInfo v)
-          | otherwise = v
-
-    zap_join | isTopLvl dest_lvl = zapJoinId
-             | otherwise         = id
-
-add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)
-add_id id_env (v, v1)
-  | isTyVar v = delVarEnv    id_env v
-  | otherwise = extendVarEnv id_env v ([v1], assert (not (isCoVar v1)) $ Var v1)
-
-{-
-Note [Zapping the demand info]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-VERY IMPORTANT: we must zap the demand info if the thing is going to
-float out, because it may be less demanded than at its original
-binding site.  Eg
-   f :: Int -> Int
-   f x = let v = 3*4 in v+x
-Here v is strict; but if we float v to top level, it isn't any more.
-
-Similarly, if we're floating a join point, it won't be one anymore, so we zap
-join point information as well.
--}
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
deleted file mode 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ /dev/null
@@ -1,2803 +0,0 @@
-{-# LANGUAGE CPP #-}
-#if __GLASGOW_HASKELL__ < 905
-{-# LANGUAGE PatternSynonyms #-}
-#endif
-{-
-ToDo [Oct 2013]
-~~~~~~~~~~~~~~~
-1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim)
-2. Nuke NoSpecConstr
-
-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-\section[SpecConstr]{Specialise over constructors}
--}
-
-
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module GHC.Core.Opt.SpecConstr(
-        specConstrProgram,
-        SpecConstrAnnotation(..)
-    ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )
-                          , gopt, hasPprDebug )
-
-import GHC.Core
-import GHC.Core.Subst
-import GHC.Core.Utils
-import GHC.Core.Unfold
-import GHC.Core.FVs     ( exprsFreeVarsList, exprFreeVars )
-import GHC.Core.Opt.Monad
-import GHC.Core.Opt.WorkWrap.Utils
-import GHC.Core.Opt.OccurAnal( scrutBinderSwap_maybe )
-import GHC.Core.DataCon
-import GHC.Core.Class( classTyVars )
-import GHC.Core.Coercion hiding( substCo )
-import GHC.Core.Rules
-import GHC.Core.Predicate ( typeDeterminesValue )
-import GHC.Core.Type     hiding ( substTy )
-import GHC.Core.TyCon   (TyCon, tyConName )
-import GHC.Core.Multiplicity
-import GHC.Core.Ppr     ( pprParendExpr )
-import GHC.Core.Make    ( mkImpossibleExpr )
-
-import GHC.Unit.Module
-import GHC.Unit.Module.ModGuts
-
-import GHC.Types.Literal ( litIsLifted )
-import GHC.Types.Id
-import GHC.Types.Id.Info ( IdDetails(..) )
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
-import GHC.Types.Name
-import GHC.Types.Tickish
-import GHC.Types.Basic
-import GHC.Types.Demand
-import GHC.Types.Cpr
-import GHC.Types.Unique.Supply
-import GHC.Types.Unique.FM
-import GHC.Types.Unique( hasKey )
-
-import GHC.Data.Maybe     ( orElse, catMaybes, isJust, isNothing )
-import GHC.Data.Pair
-import GHC.Data.FastString
-
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Panic
-import GHC.Utils.Constants (debugIsOn)
-import GHC.Utils.Monad
-
-import GHC.Builtin.Names ( specTyConKey )
-
-import GHC.Exts( SpecConstrAnnotation(..) )
-import GHC.Serialized   ( deserializeWithData )
-
-import Control.Monad    ( zipWithM )
-import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL )
-import Data.Maybe( mapMaybe )
-import Data.Ord( comparing )
-import Data.Tuple
-
-{-
------------------------------------------------------
-                        Game plan
------------------------------------------------------
-
-Consider
-        drop n []     = []
-        drop 0 xs     = []
-        drop n (x:xs) = drop (n-1) xs
-
-After the first time round, we could pass n unboxed.  This happens in
-numerical code too.  Here's what it looks like in Core:
-
-        drop n xs = case xs of
-                      []     -> []
-                      (y:ys) -> case n of
-                                  I# n# -> case n# of
-                                             0 -> []
-                                             _ -> drop (I# (n# -# 1#)) xs
-
-Notice that the recursive call has an explicit constructor as argument.
-Noticing this, we can make a specialised version of drop
-
-        RULE: drop (I# n#) xs ==> drop' n# xs
-
-        drop' n# xs = let n = I# n# in ...orig RHS...
-
-Now the simplifier will apply the specialisation in the rhs of drop', giving
-
-        drop' n# xs = case xs of
-                      []     -> []
-                      (y:ys) -> case n# of
-                                  0 -> []
-                                  _ -> drop' (n# -# 1#) xs
-
-Much better!
-
-We'd also like to catch cases where a parameter is carried along unchanged,
-but evaluated each time round the loop:
-
-        f i n = if i>0 || i>n then i else f (i*2) n
-
-Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
-In Core, by the time we've w/wd (f is strict in i) we get
-
-        f i# n = case i# ># 0 of
-                   False -> I# i#
-                   True  -> case n of { I# n# ->
-                            case i# ># n# of
-                                False -> I# i#
-                                True  -> f (i# *# 2#) n
-
-At the call to f, we see that the argument, n is known to be (I# n#),
-and n is evaluated elsewhere in the body of f, so we can play the same
-trick as above.
-
-
-Note [Reboxing]
-~~~~~~~~~~~~~~~
-We must be careful not to allocate the same constructor twice.  Consider
-        f p = (...(case p of (a,b) -> e)...p...,
-               ...let t = (r,s) in ...t...(f t)...)
-At the recursive call to f, we can see that t is a pair.  But we do NOT want
-to make a specialised copy:
-        f' a b = let p = (a,b) in (..., ...)
-because now t is allocated by the caller, then r and s are passed to the
-recursive call, which allocates the (r,s) pair again.
-
-This happens if
-  (a) the argument p is used in other than a case-scrutinisation way.
-  (b) the argument to the call is not a 'fresh' tuple; you have to
-        look into its unfolding to see that it's a tuple
-
-Hence the "OR" part of Note [Good arguments] below.
-
-ALTERNATIVE 2: pass both boxed and unboxed versions.  This no longer saves
-allocation, but does perhaps save evals. In the RULE we'd have
-something like
-
-  f (I# x#) = f' (I# x#) x#
-
-If at the call site the (I# x) was an unfolding, then we'd have to
-rely on CSE to eliminate the duplicate allocation.... This alternative
-doesn't look attractive enough to pursue.
-
-ALTERNATIVE 3: ignore the reboxing problem.  The trouble is that
-the conservative reboxing story prevents many useful functions from being
-specialised.  Example:
-        foo :: Maybe Int -> Int -> Int
-        foo   (Just m) 0 = 0
-        foo x@(Just m) n = foo x (n-m)
-Here the use of 'x' will clearly not require boxing in the specialised function.
-
-The strictness analyser has the same problem, in fact.  Example:
-        f p@(a,b) = ...
-If we pass just 'a' and 'b' to the worker, it might need to rebox the
-pair to create (a,b).  A more sophisticated analysis might figure out
-precisely the cases in which this could happen, but the strictness
-analyser does no such analysis; it just passes 'a' and 'b', and hopes
-for the best.
-
-So my current choice is to make SpecConstr similarly aggressive, and
-ignore the bad potential of reboxing.
-
-
-Note [Good arguments]
-~~~~~~~~~~~~~~~~~~~~~
-So we look for
-
-* A self-recursive function.  Ignore mutual recursion for now,
-  because it's less common, and the code is simpler for self-recursion.
-
-* EITHER
-
-   a) At a recursive call, one or more parameters is an explicit
-      constructor application
-        AND
-      That same parameter is scrutinised by a case somewhere in
-      the RHS of the function
-
-  OR
-
-    b) At a recursive call, one or more parameters has an unfolding
-       that is an explicit constructor application
-        AND
-      That same parameter is scrutinised by a case somewhere in
-      the RHS of the function
-        AND
-      Those are the only uses of the parameter (see Note [Reboxing])
-
-
-What to abstract over
-~~~~~~~~~~~~~~~~~~~~~
-There's a bit of a complication with type arguments.  If the call
-site looks like
-
-        f p = ...f ((:) [a] x xs)...
-
-then our specialised function look like
-
-        f_spec x xs = let p = (:) [a] x xs in ....as before....
-
-This only makes sense if either
-  a) the type variable 'a' is in scope at the top of f, or
-  b) the type variable 'a' is an argument to f (and hence fs)
-
-Actually, (a) may hold for value arguments too, in which case
-we may not want to pass them.  Suppose 'x' is in scope at f's
-defn, but xs is not.  Then we'd like
-
-        f_spec xs = let p = (:) [a] x xs in ....as before....
-
-Similarly (b) may hold too.  If x is already an argument at the
-call, no need to pass it again.
-
-Finally, if 'a' is not in scope at the call site, we could abstract
-it as we do the term variables:
-
-        f_spec a x xs = let p = (:) [a] x xs in ...as before...
-
-So the grand plan is:
-
-        * abstract the call site to a constructor-only pattern
-          e.g.  C x (D (f p) (g q))  ==>  C s1 (D s2 s3)
-
-        * Find the free variables of the abstracted pattern
-
-        * Pass these variables, less any that are in scope at
-          the fn defn.  But see Note [Shadowing] below.
-
-
-NOTICE that we only abstract over variables that are not in scope,
-so we're in no danger of shadowing variables used in "higher up"
-in f_spec's RHS.
-
-
-Note [Shadowing]
-~~~~~~~~~~~~~~~~
-In this pass we gather up usage information that may mention variables
-that are bound between the usage site and the definition site; or (more
-seriously) may be bound to something different at the definition site.
-For example:
-
-        f x = letrec g y v = let x = ...
-                             in ...(g (a,b) x)...
-
-Since 'x' is in scope at the call site, we may make a rewrite rule that
-looks like
-        RULE forall a,b. g (a,b) x = ...
-But this rule will never match, because it's really a different 'x' at
-the call site -- and that difference will be manifest by the time the
-simplifier gets to it.  [A worry: the simplifier doesn't *guarantee*
-no-shadowing, so perhaps it may not be distinct?]
-
-Anyway, the rule isn't actually wrong, it's just not useful.  One possibility
-is to run deShadowBinds before running SpecConstr, but instead we run the
-simplifier.  That gives the simplest possible program for SpecConstr to
-chew on; and it virtually guarantees no shadowing.
-
-Note [Specialising for constant parameters]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This one is about specialising on a *constant* (but not necessarily
-constructor) argument
-
-    foo :: Int -> (Int -> Int) -> Int
-    foo 0 f = 0
-    foo m f = foo (f m) (+1)
-
-It produces
-
-    lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
-    lvl_rmV =
-      \ (ds_dlk :: GHC.Base.Int) ->
-        case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
-        GHC.Base.I# (GHC.Prim.+# x_alG 1)
-
-    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
-    GHC.Prim.Int#
-    T.$wfoo =
-      \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
-        case ww_sme of ds_Xlw {
-          __DEFAULT ->
-        case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
-        T.$wfoo ww1_Xmz lvl_rmV
-        };
-          0 -> 0
-        }
-
-The recursive call has lvl_rmV as its argument, so we could create a specialised copy
-with that argument baked in; that is, not passed at all.   Now it can perhaps be inlined.
-
-When is this worth it?  Call the constant 'lvl'
-- If 'lvl' has an unfolding that is a constructor, see if the corresponding
-  parameter is scrutinised anywhere in the body.
-
-- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
-  parameter is applied (...to enough arguments...?)
-
-  Also do this is if the function has RULES?
-
-Also
-
-Note [Specialising for lambda parameters]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-    foo :: Int -> (Int -> Int) -> Int
-    foo 0 f = 0
-    foo m f = foo (f m) (\n -> n-m)
-
-This is subtly different from the previous one in that we get an
-explicit lambda as the argument:
-
-    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
-    GHC.Prim.Int#
-    T.$wfoo =
-      \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
-        case ww_sm8 of ds_Xlr {
-          __DEFAULT ->
-        case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
-        T.$wfoo
-          ww1_Xmq
-          (\ (n_ad3 :: GHC.Base.Int) ->
-             case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
-             GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
-             })
-        };
-          0 -> 0
-        }
-
-I wonder if SpecConstr couldn't be extended to handle this? After all,
-lambda is a sort of constructor for functions and perhaps it already
-has most of the necessary machinery?
-
-Furthermore, there's an immediate win, because you don't need to allocate the lambda
-at the call site; and if perchance it's called in the recursive call, then you
-may avoid allocating it altogether.  Just like for constructors.
-
-Looks cool, but probably rare...but it might be easy to implement.
-
-
-Note [SpecConstr for casts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-    data family T a :: *
-    data instance T Int = T Int
-
-    foo n = ...
-       where
-         go (T 0) = 0
-         go (T n) = go (T (n-1))
-
-The recursive call ends up looking like
-        go (T (I# ...) `cast` g)
-So we want to spot the constructor application inside the cast.
-That's why we have the Cast case in argToPat
-
-Note [Seeding recursive groups]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For a recursive group that is either
-  * nested, or
-  * top-level, but with no exported Ids
-we can see all the calls to the function, so we seed the specialisation
-loop from the calls in the body, and /not/ from the calls in the RHS.
-Consider:
-
-  bar m n = foo n (n,n) (n,n) (n,n) (n,n)
-   where
-     foo n p q r s
-       | n == 0    = m
-       | n > 3000  = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
-       | n > 2000  = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
-       | n > 1000  = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
-       | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
-
-If we start with the RHSs of 'foo', we get lots and lots of specialisations,
-most of which are not needed.  But if we start with the (single) call
-in the rhs of 'bar' we get exactly one fully-specialised copy, and all
-the recursive calls go to this fully-specialised copy. Indeed, the original
-function is later collected as dead code.  This is very important in
-specialising the loops arising from stream fusion, for example in NDP where
-we were getting literally hundreds of (mostly unused) specialisations of
-a local function.
-
-In a case like the above we end up never calling the original un-specialised
-function.  (Although we still leave its code around just in case.)
-
-Wrinkles
-
-* Boring calls. If we find any boring calls in the body, including
-  *unsaturated* ones, such as
-      letrec foo x y = ....foo...
-      in map foo xs
-  then we will end up calling the un-specialised function, so then we
-  *should* use the calls in the un-specialised RHS as seeds.  We call
-  these "boring call patterns", and callsToNewPats reports if it finds
-  any of these.  Then 'specialise' unleashes the usage info from the
-  un-specialised RHS.
-
-* Exported Ids. `specialise` /also/ unleashes `si_mb_unspec`
-  for exported Ids.  That way we are sure to generate usage info from
-  the /un-specialised/ RHS of an exported function.
-
-More precisely:
-
-* Always start from the calls in the body of the let or (for top level)
-  calls in the rest of the module.  See the body_calls in the call to
-  `specialise` in `specNonRec`, and to `go` in `specRec`.
-
-* si_mb_unspec holds the usage from the unspecialised RHS.
-  See `initSpecInfo`.
-
-* `specialise` will unleash si_mb_unspec, if
-  - `callsToNewPats` reports "boring calls found", or
-  - this is a top-level exported Id.
-
-Historical note.  At an earlier point, if a top-level Id was exported,
-we used only seeds from the RHS, and /not/from the body. But Dimitrios
-had an example where using call patterns from the body (the other defns
-in the module) was crucial.  And doing so improved nofib allocation results:
-    multiplier: 4%   better
-    minimax:    2.8% better
-In any case, it is easier to do!
-
-Note [Do not specialise diverging functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Specialising a function that just diverges is a waste of code.
-Furthermore, it broke GHC (simpl014) thus:
-   {-# STR Sb #-}
-   f = \x. case x of (a,b) -> f x
-If we specialise f we get
-   f = \x. case x of (a,b) -> fspec a b
-But fspec doesn't have decent strictness info.  As it happened,
-(f x) :: IO t, so the state hack applied and we eta expanded fspec,
-and hence f.  But now f's strictness is less than its arity, which
-breaks an invariant.
-
-
-Note [Forcing specialisation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-With stream fusion and in other similar cases, we want to fully
-specialise some (but not necessarily all!) loops regardless of their
-size and the number of specialisations.
-
-We allow a library to do this, in one of two ways (one which is
-deprecated):
-
-  1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body.
-
-  2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts,
-     and then add *that* type as a parameter to the loop body
-
-The reason #2 is deprecated is because it requires GHCi, which isn't
-available for things like a cross compiler using stage1.
-
-Here's a (simplified) example from the `vector` package. You may bring
-the special 'force specialization' type into scope by saying:
-
-  import GHC.Types (SPEC(..))
-
-or by defining your own type (again, deprecated):
-
-  data SPEC = SPEC | SPEC2
-  {-# ANN type SPEC ForceSpecConstr #-}
-
-(Note this is the exact same definition of GHC.Types.SPEC, just
-without the annotation.)
-
-After that, you say:
-
-  foldl :: (a -> b -> a) -> a -> Stream b -> a
-  {-# INLINE foldl #-}
-  foldl f z (Stream step s _) = foldl_loop SPEC z s
-    where
-      foldl_loop !sPEC z s = case step s of
-                              Yield x s' -> foldl_loop sPEC (f z x) s'
-                              Skip       -> foldl_loop sPEC z s'
-                              Done       -> z
-
-SpecConstr will spot the SPEC parameter and always fully specialise
-foldl_loop. Note that
-
-  * We have to prevent the SPEC argument from being removed by
-    w/w which is why (a) SPEC is a sum type, and (b) we have to seq on
-    the SPEC argument.
-
-  * And lastly, the SPEC argument is ultimately eliminated by
-    SpecConstr itself so there is no runtime overhead.
-
-This is all quite ugly; we ought to come up with a better design.
-
-ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
-sc_force to True when calling specLoop. This flag does four things:
-
-  * Ignore specConstrThreshold, to specialise functions of arbitrary size
-        (see scTopBind)
-  * Ignore specConstrCount, to make arbitrary numbers of specialisations
-        (see specialise)
-  * Specialise even for arguments that are not scrutinised in the loop
-        (see argToPat; #4448)
-  * Only specialise on recursive types a finite number of times
-        (see is_too_recursive; #5550; Note [Limit recursive specialisation])
-
-The flag holds only for specialising a single binding group, and NOT
-for nested bindings.  (So really it should be passed around explicitly
-and not stored in ScEnv.)  #14379 turned out to be caused by
-   f SPEC x = let g1 x = ...
-              in ...
-We force-specialise f (because of the SPEC), but that generates a specialised
-copy of g1 (as well as the original).  Alas g1 has a nested binding g2; and
-in each copy of g1 we get an unspecialised and specialised copy of g2; and so
-on. Result, exponential.  So the force-spec flag now only applies to one
-level of bindings at a time.
-
-Mechanism for this one-level-only thing:
-
- - Switch it on at the call to specRec, in scExpr and scTopBinds
- - Switch it off when doing the RHSs;
-   this can be done very conveniently in decreaseSpecCount
-
-What alternatives did I consider?
-
-* Annotating the loop itself doesn't work because (a) it is local and
-  (b) it will be w/w'ed and having w/w propagating annotations somehow
-  doesn't seem like a good idea. The types of the loop arguments
-  really seem to be the most persistent thing.
-
-* Annotating the types that make up the loop state doesn't work,
-  either, because (a) it would prevent us from using types like Either
-  or tuples here, (b) we don't want to restrict the set of types that
-  can be used in Stream states and (c) some types are fixed by the
-  user (e.g., the accumulator here) but we still want to specialise as
-  much as possible.
-
-Alternatives to ForceSpecConstr
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Instead of giving the loop an extra argument of type SPEC, we
-also considered *wrapping* arguments in SPEC, thus
-  data SPEC a = SPEC a | SPEC2
-
-  loop = \arg -> case arg of
-                     SPEC state ->
-                        case state of (x,y) -> ... loop (SPEC (x',y')) ...
-                        S2 -> error ...
-The idea is that a SPEC argument says "specialise this argument
-regardless of whether the function case-analyses it".  But this
-doesn't work well:
-  * SPEC must still be a sum type, else the strictness analyser
-    eliminates it
-  * But that means that 'loop' won't be strict in its real payload
-This loss of strictness in turn screws up specialisation, because
-we may end up with calls like
-   loop (SPEC (case z of (p,q) -> (q,p)))
-Without the SPEC, if 'loop' were strict, the case would move out
-and we'd see loop applied to a pair. But if 'loop' isn't strict
-this doesn't look like a specialisable call.
-
-Note [Limit recursive specialisation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It is possible for ForceSpecConstr to cause an infinite loop of specialisation.
-Because there is no limit on the number of specialisations, a recursive call with
-a recursive constructor as an argument (for example, list cons) will generate
-a specialisation for that constructor. If the resulting specialisation also
-contains a recursive call with the constructor, this could proceed indefinitely.
-
-For example, if ForceSpecConstr is on:
-  loop :: [Int] -> [Int] -> [Int]
-  loop z []         = z
-  loop z (x:xs)     = loop (x:z) xs
-this example will create a specialisation for the pattern
-  loop (a:b) c      = loop' a b c
-
-  loop' a b []      = (a:b)
-  loop' a b (x:xs)  = loop (x:(a:b)) xs
-and a new pattern is found:
-  loop (a:(b:c)) d  = loop'' a b c d
-which can continue indefinitely.
-
-Roman's suggestion to fix this was to stop after a couple of times on recursive types,
-but still specialising on non-recursive types as much as possible.
-
-To implement this, we count the number of times we have gone round the
-"specialise recursively" loop ('go' in 'specRec').  Once have gone round
-more than N times (controlled by -fspec-constr-recursive=N) we check
-
-  - If sc_force is off, and sc_count is (Just max) then we don't
-    need to do anything: trim_pats will limit the number of specs
-
-  - Otherwise check if any function has now got more than (sc_count env)
-    specialisations.  If sc_count is "no limit" then we arbitrarily
-    choose 10 as the limit (ugh).
-
-See #5550.   Also #13623, where this test had become over-aggressive,
-and we lost a wonderful specialisation that we really wanted!
-
-Note [NoSpecConstr]
-~~~~~~~~~~~~~~~~~~~
-The ignoreDataCon stuff allows you to say
-    {-# ANN type T NoSpecConstr #-}
-to mean "don't specialise on arguments of this type".  It was added
-before we had ForceSpecConstr.  Lacking ForceSpecConstr we specialised
-regardless of size; and then we needed a way to turn that *off*.  Now
-that we have ForceSpecConstr, this NoSpecConstr is probably redundant.
-(Used only for PArray, TODO: remove?)
-
-Note [SpecConstr and strict fields]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We treat strict fields in SpecConstr the same way we do in W/W.
-That is we make the specialized function strict in arguments
-representing strict fields. See Note [Call-by-value for worker args]
-for why we do this.
-
-Note [Specialising on dictionaries]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In #21386, SpecConstr saw this call:
-
-   $wgo 100# @.. ($fMonadStateT @.. @.. $fMonadIdentity)
-
-where $wgo :: Int# -> forall m. Monad m => blah
-
-You might think that the type-class Specialiser would have specialised
-this, but there are good reasons why not: the Specialiser ran too early.
-But regardless, SpecConstr can and should!  It's easy:
-
-* isValue: treat ($fblah d1 .. dn)
-  like a constructor application.
-
-* scApp: treat (op_sel d), a class method selection,
-  like a case expression
-
-* Float that dictionary application to top level, thus
-    lvl = $fMonadStateT @.. @.. $fMonadIdentity
-  so the call looks like
-    ($wgo 100# @.. lvl)
-
-  Why? This way dictionaries will appear as top level binders which we
-  can trivially match in rules.  (CSE runs before SpecConstr, so we
-  may hope to common-up duplicate top-level dictionaries.)
-  For the floating part, see the "Arguments" case of Note
-  [Floating to the top] in GHC.Core.Opt.SetLevels.
-
-  We could be more clever, perhaps, and generate a RULE like
-     $wgo _  @.. ($fMonadStateT @.. @.. $fMonadIdentity) = $s$wgo ...
-  but that would mean making argToPat able to spot dfun applications as
-  well as constructor applications.
-
-Wrinkles:
-
-* This should all work perfectly fine for newtype classes.  Mind you,
-  currently newtype classes are inlined fairly agressively, but we
-  may change that. And it would take extra code to exclude them, as
-  well as being unnecessary.
-
-* In isValue, we (mis-) use LambdaVal for this ($fblah d1 .. dn)
-  because ConVal requires us to list the data constructor and
-  fields, and that is (a) inconvenient and (b) unnecessary for
-  class methods.
-
------------------------------------------------------
-                Stuff not yet handled
------------------------------------------------------
-
-Here are notes arising from Roman's work that I don't want to lose.
-
-Example 1
-~~~~~~~~~
-    data T a = T !a
-
-    foo :: Int -> T Int -> Int
-    foo 0 t = 0
-    foo x t | even x    = case t of { T n -> foo (x-n) t }
-            | otherwise = foo (x-1) t
-
-SpecConstr does no specialisation, because the second recursive call
-looks like a boxed use of the argument.  A pity.
-
-    $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
-    $wfoo_sFw =
-      \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
-         case ww_sFo of ds_Xw6 [Just L] {
-           __DEFAULT ->
-                case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
-                  __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
-                  0 ->
-                    case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
-                    case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
-                    $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
-                    } } };
-           0 -> 0
-
-Example 2
-~~~~~~~~~
-    data a :*: b = !a :*: !b
-    data T a = T !a
-
-    foo :: (Int :*: T Int) -> Int
-    foo (0 :*: t) = 0
-    foo (x :*: t) | even x    = case t of { T n -> foo ((x-n) :*: t) }
-                  | otherwise = foo ((x-1) :*: t)
-
-Very similar to the previous one, except that the parameters are now in
-a strict tuple. Before SpecConstr, we have
-
-    $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
-    $wfoo_sG3 =
-      \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
-    GHC.Base.Int) ->
-        case ww_sFU of ds_Xws [Just L] {
-          __DEFAULT ->
-        case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
-          __DEFAULT ->
-            case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
-            $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2             -- $wfoo1
-            };
-          0 ->
-            case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
-            case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
-            $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB        -- $wfoo2
-            } } };
-          0 -> 0 }
-
-We get two specialisations:
-"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
-                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
-                  = Foo.$s$wfoo1 a_sFB sc_sGC ;
-"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
-                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
-                  = Foo.$s$wfoo y_aFp sc_sGC ;
-
-But perhaps the first one isn't good.  After all, we know that tpl_B2 is
-a T (I# x) really, because T is strict and Int has one constructor.  (We can't
-unbox the strict fields, because T is polymorphic!)
-
-************************************************************************
-*                                                                      *
-\subsection{Top level wrapper stuff}
-*                                                                      *
-************************************************************************
--}
-
-specConstrProgram :: ModGuts -> CoreM ModGuts
-specConstrProgram guts
-  = do { env0 <- initScEnv guts
-       ; us   <- getUniqueSupplyM
-       ; let (_usg, binds') = initUs_ us $
-                              scTopBinds env0 (mg_binds guts)
-
-       ; return (guts { mg_binds = binds' }) }
-
-scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind])
-scTopBinds _env []     = return (nullUsage, [])
-scTopBinds env  (b:bs) = do { (usg, b', bs') <- scBind TopLevel env b $
-                                                (\env -> scTopBinds env bs)
-                            ; return (usg, b' ++ bs') }
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Environment: goes downwards}
-*                                                                      *
-************************************************************************
-
-Note [Work-free values only in environment]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The sc_vals field keeps track of in-scope value bindings, so
-that if we come across (case x of Just y ->...) we can reduce the
-case from knowing that x is bound to a pair.
-
-But only *work-free* values are ok here. For example if the envt had
-    x -> Just (expensive v)
-then we do NOT want to expand to
-     let y = expensive v in ...
-because the x-binding still exists and we've now duplicated (expensive v).
-
-This seldom happens because let-bound constructor applications are
-ANF-ised, but it can happen as a result of on-the-fly transformations in
-SpecConstr itself.  Here is #7865:
-
-        let {
-          a'_shr =
-            case xs_af8 of _ {
-              [] -> acc_af6;
-              : ds_dgt [Dmd=<L,A>] ds_dgu [Dmd=<L,A>] ->
-                (expensive x_af7, x_af7
-            } } in
-        let {
-          ds_sht =
-            case a'_shr of _ { (p'_afd, q'_afe) ->
-            TSpecConstr_DoubleInline.recursive
-              (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd)
-            } } in
-
-When processed knowing that xs_af8 was bound to a cons, we simplify to
-   a'_shr = (expensive x_af7, x_af7)
-and we do NOT want to inline that at the occurrence of a'_shr in ds_sht.
-(There are other occurrences of a'_shr.)  No no no.
-
-It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned
-into a work-free value again, thus
-   a1 = expensive x_af7
-   a'_shr = (a1, x_af7)
-but that's more work, so until its shown to be important I'm going to
-leave it for now.
-
-Note [Making SpecConstr keener]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this, in (perf/should_run/T9339)
-   last (filter odd [1..1000])
-
-After optimisation, including SpecConstr, we get:
-   f :: Int# -> Int -> Int
-   f x y = case remInt# x 2# of
-             __DEFAULT -> case x of
-                            __DEFAULT -> f (+# wild_Xp 1#) (I# x)
-                            1000000# -> ...
-             0# -> case x of
-                     __DEFAULT -> f (+# wild_Xp 1#) y
-                    1000000#   -> y
-
-Not good!  We build an (I# x) box every time around the loop.
-SpecConstr (as described in the paper) does not specialise f, despite
-the call (f ... (I# x)) because 'y' is not scrutinised in the body.
-But it is much better to specialise f for the case where the argument
-is of form (I# x); then we build the box only when returning y, which
-is on the cold path.
-
-Another example:
-
-   f x = ...(g x)....
-
-Here 'x' is not scrutinised in f's body; but if we did specialise 'f'
-then the call (g x) might allow 'g' to be specialised in turn.
-
-So sc_keen controls whether or not we take account of whether argument is
-scrutinised in the body.  True <=> ignore that, and specialise whenever
-the function is applied to a data constructor.
--}
-
--- | Options for Specializing over constructors in Core.
-data SpecConstrOpts = SpecConstrOpts
-  { sc_max_args  :: !Int
-  -- ^ The threshold at which a worker-wrapper transformation used as part of
-  -- this pass will no longer happen, measured in the number of arguments.
-
-  , sc_debug     :: !Bool
-  -- ^ Whether to print debug information
-
-  , sc_uf_opts   :: !UnfoldingOpts
-  -- ^ Unfolding options
-
-  , sc_module    :: !Module
-  -- ^ The name of the module being processed
-
-  , sc_size      :: !(Maybe Int)
-  -- ^ Size threshold: Nothing => no limit
-
-  , sc_count     :: !(Maybe Int)
-  -- ^ Max # of specialisations for any one function. Nothing => no limit.
-  -- See Note [Avoiding exponential blowup] and decreaseSpecCount
-
-  , sc_recursive :: !Int
-  -- ^ Max # of specialisations over recursive type. Stops
-  -- ForceSpecConstr from diverging.
-
-  , sc_keen      :: !Bool
-  -- ^ Specialise on arguments that are known constructors, even if they are
-  -- not scrutinised in the body. See Note [Making SpecConstr keener].
-  }
-
-data ScEnv = SCE { sc_opts      :: !SpecConstrOpts,
-                   sc_force     :: Bool,        -- Force specialisation?
-                                                -- See Note [Forcing specialisation]
-
-                   sc_subst     :: Subst,       -- Current substitution
-                                                -- Maps InIds to OutExprs
-
-                   sc_how_bound :: HowBoundEnv,
-                        -- Binds interesting non-top-level variables
-                        -- Domain is OutVars (*after* applying the substitution)
-
-                   sc_vals      :: ValueEnv,
-                        -- Domain is OutIds (*after* applying the substitution)
-                        -- Used even for top-level bindings (but not imported ones)
-                        -- The range of the ValueEnv is *work-free* values
-                        -- such as (\x. blah), or (Just v)
-                        -- but NOT (Just (expensive v))
-                        -- See Note [Work-free values only in environment]
-
-                   sc_annotations :: UniqFM Name SpecConstrAnnotation
-             }
-
----------------------
-type HowBoundEnv = VarEnv HowBound      -- Domain is OutVars
-
----------------------
-type ValueEnv = IdEnv Value             -- Domain is OutIds
-data Value    = ConVal AltCon [CoreArg] -- _Saturated_ constructors
-                                        --   The AltCon is never DEFAULT
-              | LambdaVal               -- Inlinable lambdas or PAPs
-
-instance Outputable Value where
-   ppr (ConVal con args) = ppr con <+> interpp'SP args
-   ppr LambdaVal         = text "<Lambda>"
-
----------------------
-initScOpts :: DynFlags -> Module -> SpecConstrOpts
-initScOpts dflags this_mod = SpecConstrOpts
-        { sc_max_args    = maxWorkerArgs dflags,
-          sc_debug       = hasPprDebug dflags,
-          sc_uf_opts     = unfoldingOpts dflags,
-          sc_module      = this_mod,
-          sc_size        = specConstrThreshold dflags,
-          sc_count       = specConstrCount     dflags,
-          sc_recursive   = specConstrRecursive dflags,
-          sc_keen        = gopt Opt_SpecConstrKeen dflags
-        }
-
-initScEnv :: ModGuts -> CoreM ScEnv
-initScEnv guts
-  = do { dflags    <- getDynFlags
-       ; (_, anns) <- getFirstAnnotations deserializeWithData guts
-       ; this_mod  <- getModule
-       ; return (SCE { sc_opts        = initScOpts dflags this_mod,
-                       sc_force       = False,
-                       sc_subst       = init_subst,
-                       sc_how_bound   = emptyVarEnv,
-                       sc_vals        = emptyVarEnv,
-                       sc_annotations = anns }) }
-  where
-    init_subst = mkEmptySubst $ mkInScopeSetBndrs (mg_binds guts)
-        -- Acccount for top-level bindings that are not in dependency order;
-        -- see Note [Glomming] in GHC.Core.Opt.OccurAnal
-        -- Easiest thing is to bring all the top level binders into scope at once,
-        -- as if  at once, as if all the top-level decls were mutually recursive.
-
-data HowBound = RecFun  -- These are the recursive functions for which
-                        -- we seek interesting call patterns
-
-              | RecArg  -- These are those functions' arguments, or their sub-components;
-                        -- we gather occurrence information for these
-
-instance Outputable HowBound where
-  ppr RecFun = text "RecFun"
-  ppr RecArg = text "RecArg"
-
-scForce :: ScEnv -> Bool -> ScEnv
-scForce env b = env { sc_force = b }
-
-lookupHowBound :: ScEnv -> OutId -> Maybe HowBound
-lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
-
-scSubstId :: ScEnv -> InId -> OutExpr
-scSubstId env v = lookupIdSubst (sc_subst env) v
-
-
--- Solo is only defined in base starting from ghc-9.2
-#if !(MIN_VERSION_base(4, 16, 0))
-data Solo a = Solo a
-#endif
-
--- The Solo constructor was renamed to MkSolo in ghc 9.5
-#if __GLASGOW_HASKELL__ < 905
-pattern MkSolo :: a -> Solo a
-pattern MkSolo a = Solo a
-#endif
-
--- The !subst ensures that we force the selection `(sc_subst env)`, which avoids
--- retaining all of `env` when we only need `subst`.  The `Solo` means that the
--- substitution itself is lazy, because that type is often discarded.
--- The callers of `scSubstTy` always force the result (to unpack the `Solo`)
--- so we get the desired effect: we leave a thunk, but retain only the subst,
--- not the whole env.
---
--- Fully forcing the result of `scSubstTy` regresses performance (#22102)
-scSubstTy :: ScEnv -> InType -> Solo OutType
-scSubstTy env ty =
-  let !subst = sc_subst env
-  in MkSolo (substTyUnchecked subst ty)
-
-scSubstCo :: ScEnv -> Coercion -> Coercion
-scSubstCo env co = substCo (sc_subst env) co
-
-zapScSubst :: ScEnv -> ScEnv
-zapScSubst env = env { sc_subst = zapSubst (sc_subst env) }
-
-extendScInScope :: ScEnv -> [Var] -> ScEnv
-        -- Bring the quantified variables into scope
-extendScInScope env qvars
-  = env { sc_subst = extendSubstInScopeList (sc_subst env) qvars }
-
-        -- Extend the substitution
-extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
-extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
-
-extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
-extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
-
-extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
-extendHowBound env bndrs how_bound
-  = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
-                            [(bndr,how_bound) | bndr <- bndrs] }
-
-extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
-extendBndrsWith how_bound env bndrs
-  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
-  where
-    (subst', bndrs') = substBndrs (sc_subst env) bndrs
-    hb_env' = sc_how_bound env `extendVarEnvList`
-                    [(bndr,how_bound) | bndr <- bndrs']
-
-extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
-extendBndrWith how_bound env bndr
-  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
-  where
-    (subst', bndr') = substBndr (sc_subst env) bndr
-    hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
-
-extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
-extendRecBndrs env bndrs  = (env { sc_subst = subst' }, bndrs')
-                      where
-                        (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
-
-extendBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
-extendBndrs env bndrs = mapAccumL extendBndr env bndrs
-
-extendBndr :: ScEnv -> Var -> (ScEnv, Var)
-extendBndr env bndr  = (env { sc_subst = subst' }, bndr')
-                     where
-                       (subst', bndr') = substBndr (sc_subst env) bndr
-
-extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
-extendValEnv env _  Nothing   = env
-extendValEnv env id (Just cv)
- | valueIsWorkFree cv      -- Don't duplicate work!!  #7865
- = env { sc_vals = extendVarEnv (sc_vals env) id cv }
-extendValEnv env _ _ = env
-
-extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var])
--- When we encounter
---      case scrut of b
---          C x y -> ...
--- we want to bind b, to (C x y)
--- NB1: Extends only the sc_vals part of the envt
--- NB2: Kill the dead-ness info on the pattern binders x,y, since
---      they are potentially made alive by the [b -> C x y] binding
-extendCaseBndrs env scrut case_bndr con alt_bndrs
-   = (env2, alt_bndrs')
- where
-   live_case_bndr = not (isDeadBinder case_bndr)
-   env1 | Just (v, mco) <- scrutBinderSwap_maybe scrut
-        , isReflMCo mco  = extendValEnv env v cval
-        | otherwise      = env  -- See Note [Add scrutinee to ValueEnv too]
-   env2 | live_case_bndr = extendValEnv env1 case_bndr cval
-        | otherwise      = env1
-
-   alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr }
-              = map zap alt_bndrs
-              | otherwise
-              = alt_bndrs
-
-   cval = case con of
-                DEFAULT    -> Nothing
-                LitAlt {}  -> Just (ConVal con [])
-                DataAlt {} -> Just (ConVal con vanilla_args)
-                      where
-                        vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
-                                       varsToCoreExprs alt_bndrs
-
-   zap v | isTyVar v = v                -- See NB2 above
-         | otherwise = zapIdOccInfo v
-
-
-decreaseSpecCount :: ScEnv -> Int -> ScEnv
--- See Note [Avoiding exponential blowup]
-decreaseSpecCount env _n_specs
-  = env { sc_force = False   -- See Note [Forcing specialisation]
-        , sc_opts = opts { sc_count = case sc_count opts of
-                             Nothing -> Nothing
-                             Just n  -> Just $! dec n
-            }
-        }
-  where
-    opts  = sc_opts env
-    dec n = n `div` 2  -- See Note [Avoiding exponential blowup]
-
-    -- Or:   n `div` (n_specs + 1)
-    -- See the historical note part of Note [Avoiding exponential blowup]
-    -- The "+1" takes account of the original function;
-
----------------------------------------------------
--- See Note [Forcing specialisation]
-ignoreType    :: ScEnv -> Type   -> Bool
-ignoreDataCon  :: ScEnv -> DataCon -> Bool
-forceSpecBndr :: ScEnv -> Var    -> Bool
-
-ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc)
-
-ignoreType env ty
-  = case tyConAppTyCon_maybe ty of
-      Just tycon -> ignoreTyCon env tycon
-      _          -> False
-
-ignoreTyCon :: ScEnv -> TyCon -> Bool
-ignoreTyCon env tycon
-  = lookupUFM (sc_annotations env) (tyConName tycon) == Just NoSpecConstr
-
-forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTyCoVars . varType $ var
-
-forceSpecFunTy :: ScEnv -> Type -> Bool
-forceSpecFunTy env = any (forceSpecArgTy env) . map scaledThing . fst . splitFunTys
-
-forceSpecArgTy :: ScEnv -> Type -> Bool
-forceSpecArgTy env ty
-  | isFunTy ty
-  = False
-
-  | Just (tycon, tys) <- splitTyConApp_maybe ty
-  = tycon `hasKey` specTyConKey
-    || lookupUFM (sc_annotations env) (tyConName tycon) == Just ForceSpecConstr
-    || any (forceSpecArgTy env) tys
-
-forceSpecArgTy _ _ = False
-
-{-
-Note [Add scrutinee to ValueEnv too]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this:
-   case x of y
-     (a,b) -> case b of c
-                I# v -> ...(f y)...
-By the time we get to the call (f y), the ValueEnv
-will have a binding for y, and for c
-    y -> (a,b)
-    c -> I# v
-BUT that's not enough!  Looking at the call (f y) we
-see that y is pair (a,b), but we also need to know what 'b' is.
-So in extendCaseBndrs we must *also* add the binding
-   b -> I# v
-else we lose a useful specialisation for f.  This is necessary even
-though the simplifier has systematically replaced uses of 'x' with 'y'
-and 'b' with 'c' in the code.  The use of 'b' in the ValueEnv came
-from outside the case.  See #4908 for the live example.
-
-It's very like the binder-swap story, so we use scrutBinderSwap_maybe
-to identify suitable scrutinees -- but only if there is no cast
-(isReflMCo) because that's all that the ValueEnv allows.
-
-Note [Avoiding exponential blowup]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The sc_count field of the ScEnv says how many times we are prepared to
-duplicate a single function.  But we must take care with recursive
-specialisations.  Consider
-
-        let $j1 = let $j2 = let $j3 = ...
-                            in
-                            ...$j3...
-                  in
-                  ...$j2...
-        in
-        ...$j1...
-
-If we specialise $j1 then in each specialisation (as well as the original)
-we can specialise $j2, and similarly $j3.  Even if we make just *one*
-specialisation of each, because we also have the original we'll get 2^n
-copies of $j3, which is not good.
-
-So when recursively specialising we divide the sc_count (the maximum
-number of specialisations, in the ScEnv) by two.  You might think that
-gives us n*(n/2)*(n/4)... copies of the innnermost thing, which is
-still exponential the depth.  But we use integer division, rounding
-down, so if the starting sc_count is 3, we'll get 3 -> 1 -> 0, and
-stop.  In fact, simply subtracting 1 would be good enough, for the same
-reason.
-
-Historical note: in the past we divided by (n_specs+1), where n_specs
-is the number of specialisations at this level; but that gets us down
-to zero jolly quickly, which I found led to some regressions.  (An
-example is nofib/spectral/fibheaps, the getMin' function inside the
-outer function $sfibToList, which has several interesting call
-patterns.)
-
-************************************************************************
-*                                                                      *
-\subsection{Usage information: flows upwards}
-*                                                                      *
-************************************************************************
--}
-
-data ScUsage
-   = SCU {
-        scu_calls :: CallEnv,           -- Calls
-                                        -- The functions are a subset of the
-                                        --      RecFuns in the ScEnv
-
-        scu_occs :: !(IdEnv ArgOcc)     -- Information on argument occurrences
-     }                                  -- The domain is OutIds
-
-type CallEnv = IdEnv [Call]  -- Domain is OutIds
-data Call    = Call OutId [CoreArg] ValueEnv
-        -- The arguments of the call, together with the
-        -- env giving the constructor bindings at the call site
-        -- We keep the function mainly for debug output
-        --
-        -- The call is not necessarily saturated; we just put
-        -- in however many args are visible at the call site
-
-instance Outputable ScUsage where
-  ppr (SCU { scu_calls = calls, scu_occs = occs })
-    = text "SCU" <+> braces (sep [ text "calls =" <+> ppr calls
-                                 , text "occs =" <+> ppr occs ])
-
-instance Outputable Call where
-  ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args)
-
-nullUsage :: ScUsage
-nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
-
-combineCalls :: CallEnv -> CallEnv -> CallEnv
-combineCalls = plusVarEnv_C (++)
-
-delCallsFor :: ScUsage -> [Var] -> ScUsage
-delCallsFor env bndrs = env { scu_calls = scu_calls env `delVarEnvList` bndrs }
-
-combineUsage :: ScUsage -> ScUsage -> ScUsage
-combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
-                           scu_occs  = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
-
-combineUsages :: [ScUsage] -> ScUsage
-combineUsages [] = nullUsage
-combineUsages us = foldr1 combineUsage us
-
-lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
-lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
-  = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
-     [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
-
-data ArgOcc = NoOcc     -- Doesn't occur at all; or a type argument
-            | UnkOcc    -- Used in some unknown way
-
-            | ScrutOcc  -- See Note [ScrutOcc]
-                 (DataConEnv [ArgOcc])
-                     -- [ArgOcc]: how the sub-components are used
-
-deadArgOcc :: ArgOcc -> Bool
-deadArgOcc (ScrutOcc {}) = False
-deadArgOcc UnkOcc        = False
-deadArgOcc NoOcc         = True
-
-specialisableArgOcc :: ArgOcc -> Bool
--- | Does this occurence represent one worth specializing for.
-specialisableArgOcc UnkOcc        = False
-specialisableArgOcc NoOcc         = False
-specialisableArgOcc (ScrutOcc {}) = True
-
-
-{- Note [ScrutOcc]
-~~~~~~~~~~~~~~~~~~
-An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
-is *only* taken apart or applied.
-
-  Functions, literal: ScrutOcc emptyUFM
-  Data constructors:  ScrutOcc subs,
-
-where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
-The domain of the UniqFM is the Unique of the data constructor
-
-The [ArgOcc] is the occurrences of the *pattern-bound* components
-of the data structure.  E.g.
-        data T a = forall b. MkT a b (b->a)
-A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
-
--}
-
-instance Outputable ArgOcc where
-  ppr (ScrutOcc xs) = text "scrut-occ" <> ppr xs
-  ppr UnkOcc        = text "unk-occ"
-  ppr NoOcc         = text "no-occ"
-
-evalScrutOcc :: ArgOcc
--- We use evalScrutOcc for
---   - mkVarUsage: applied functions
---   - scApp: dicts that are the argument of a classop
-evalScrutOcc = ScrutOcc emptyUFM
-
--- Experimentally, this version of combineOcc makes ScrutOcc "win", so
--- that if the thing is scrutinised anywhere then we get to see that
--- in the overall result, even if it's also used in a boxed way
--- This might be too aggressive; see Note [Reboxing] Alternative 3
-combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
-combineOcc NoOcc         occ           = occ
-combineOcc occ           NoOcc         = occ
-combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
-combineOcc UnkOcc        (ScrutOcc ys) = ScrutOcc ys
-combineOcc (ScrutOcc xs) UnkOcc        = ScrutOcc xs
-combineOcc UnkOcc        UnkOcc        = UnkOcc
-
-combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
-combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
-
-setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
--- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
--- is a variable, and an interesting variable
-setScrutOcc env usg (Cast e _) occ      = setScrutOcc env usg e occ
-setScrutOcc env usg (Tick _ e) occ      = setScrutOcc env usg e occ
-setScrutOcc env usg (Var v)    occ
-  | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
-  | otherwise                           = usg
-setScrutOcc _env usg _other _occ        -- Catch-all
-  = usg
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{The main recursive function}
-*                                                                      *
-************************************************************************
-
-The main recursive function gathers up usage information, and
-creates specialised versions of functions.
--}
-
-scBind :: TopLevelFlag -> ScEnv -> InBind
-       -> (ScEnv -> UniqSM (ScUsage, a))   -- Specialise the scope of the binding
-       -> UniqSM (ScUsage, [OutBind], a)
-scBind top_lvl env (NonRec bndr rhs) do_body
-  | isTyVar bndr         -- Type-lets may be created by doBeta
-  = do { (final_usage, body') <- do_body (extendScSubst env bndr rhs)
-       ; return (final_usage, [], body') }
-
-  | not (isTopLevel top_lvl)  -- Nested non-recursive value binding
-    -- See Note [Specialising local let bindings]
-  = do  { let (body_env, bndr') = extendBndr env bndr
-              -- Not necessary at top level; but here we are nested
-
-        ; rhs_info  <- scRecRhs env (bndr',rhs)
-
-        ; let body_env2 = extendHowBound body_env [bndr'] RecFun
-              rhs'      = ri_new_rhs rhs_info
-              body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
-
-        ; (body_usg, body') <- do_body body_env3
-
-          -- Now make specialised copies of the binding,
-          -- based on calls in body_usg
-        ; (spec_usg, specs) <- specNonRec env (scu_calls body_usg) rhs_info
-          -- NB: For non-recursive bindings we inherit sc_force flag from
-          -- the parent function (see Note [Forcing specialisation])
-
-        -- Specialized + original binding
-        ; let spec_bnds  = [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs]
-              bind_usage = (body_usg `delCallsFor` [bndr'])
-                           `combineUsage` spec_usg -- Note [spec_usg includes rhs_usg]
-
-        ; return (bind_usage, spec_bnds, body')
-        }
-
-  | otherwise  -- Top-level, non-recursive value binding
-    -- At top level we do not specialise non-recursive bindings; that
-    -- is, we do not call specNonRec, passing the calls from the body.
-    -- The original paper only specialised /recursive/ bindings, but
-    -- we later started specialising nested non-recursive bindings:
-    -- see Note [Specialising local let bindings]
-    --
-    -- I tried always specialising non-recursive top-level bindings too,
-    -- but found some regressions (see !8135).  So I backed off.
-  = do { (rhs_usage, rhs')   <- scExpr env rhs
-
-       -- At top level, we've already put all binders into scope; see initScEnv
-       -- Hence no need to call `extendBndr`. But we still want to
-       -- extend the `ValueEnv` to record the value of this binder.
-       ; let body_env = extendValEnv env bndr (isValue (sc_vals env) rhs')
-       ; (body_usage, body') <- do_body body_env
-
-       ; return (rhs_usage `combineUsage` body_usage, [NonRec bndr rhs'], body') }
-
-scBind top_lvl env (Rec prs) do_body
-  | isTopLevel top_lvl
-  , Just threshold <- sc_size (sc_opts env)
-  , not force_spec
-  , not (all (couldBeSmallEnoughToInline (sc_uf_opts (sc_opts env)) threshold) rhss)
-  = -- Do no specialisation if the RHSs are too big
-    -- ToDo: I'm honestly not sure of the rationale of this size-testing, nor
-    --       why it only applies at top level. But that's the way it has been
-    --       for a while. See #21456.
-    do  { (body_usg, body') <- do_body rhs_env2
-        ; (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss
-        ; let all_usg = (combineUsages rhs_usgs `combineUsage` body_usg)
-                        `delCallsFor` bndrs'
-              bind'   = Rec (bndrs' `zip` rhss')
-        ; return (all_usg, [bind'], body') }
-
-  | otherwise
-  = do  { rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
-        ; (body_usg, body') <- do_body rhs_env2
-
-        ; (spec_usg, specs) <- specRec (scForce rhs_env2 force_spec)
-                                       (scu_calls body_usg) rhs_infos
-                -- Do not unconditionally generate specialisations from rhs_usgs
-                -- Instead use them only if we find an unspecialised call
-                -- See Note [Seeding recursive groups]
-
-        ; let all_usg = (spec_usg `combineUsage` body_usg)  -- Note [spec_usg includes rhs_usg]
-                        `delCallsFor` bndrs'
-              bind'   = Rec (concat (zipWithEqual "scExpr'" ruleInfoBinds rhs_infos specs))
-                        -- zipWithEqual: length of returned [SpecInfo]
-                        -- should be the same as incoming [RhsInfo]
-
-        ; return (all_usg, [bind'], body') }
-  where
-    (bndrs,rhss) = unzip prs
-    force_spec   = any (forceSpecBndr env) bndrs    -- Note [Forcing specialisation]
-
-    (rhs_env1,bndrs') | isTopLevel top_lvl = (env, bndrs)
-                      | otherwise          = extendRecBndrs env bndrs
-       -- At top level, we've already put all binders into scope; see initScEnv
-
-    rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun
-
-{- Note [Specialising local let bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It is not uncommon to find this
-
-   let $j = \x. <blah> in ...$j True...$j True...
-
-Here $j is an arbitrary let-bound function, but it often comes up for
-join points.  We might like to specialise $j for its call patterns.
-Notice the difference from a letrec, where we look for call patterns
-in the *RHS* of the function.  Here we look for call patterns in the
-*body* of the let.
-
-At one point I predicated this on the RHS mentioning the outer
-recursive function, but that's not essential and might even be
-harmful.  I'm not sure.
--}
-
-------------------------
-scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
-        -- The unique supply is needed when we invent
-        -- a new name for the specialised function and its args
-
-scExpr env e = scExpr' env e
-
-scExpr' env (Var v)      = case scSubstId env v of
-                            Var v' -> return (mkVarUsage env v' [], Var v')
-                            e'     -> scExpr (zapScSubst env) e'
-
-scExpr' env (Type t)     =
-  let !(MkSolo ty') = scSubstTy env t
-  in return (nullUsage, Type ty')
-scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))
-scExpr' _   e@(Lit {})   = return (nullUsage, e)
-scExpr' env (Tick t e)   = do (usg, e') <- scExpr env e
-                              return (usg, Tick t e')
-scExpr' env (Cast e co)  = do (usg, e') <- scExpr env e
-                              return (usg, mkCast e' (scSubstCo env co))
-                              -- Important to use mkCast here
-                              -- See Note [SpecConstr call patterns]
-scExpr' env e@(App _ _)  = scApp env (collectArgs e)
-scExpr' env (Lam b e)    = do let (env', b') = extendBndr env b
-                              (usg, e') <- scExpr env' e
-                              return (usg, Lam b' e')
-
-scExpr' env (Let bind body)
-  = do { (final_usage, binds', body') <- scBind NotTopLevel env bind $
-                                         (\env -> scExpr env body)
-       ; return (final_usage, mkLets binds' body') }
-
-scExpr' env (Case scrut b ty alts)
-  = do  { (scrut_usg, scrut') <- scExpr env scrut
-        ; case isValue (sc_vals env) scrut' of
-                Just (ConVal con args) -> sc_con_app con args scrut'
-                _other                 -> sc_vanilla scrut_usg scrut'
-        }
-  where
-    sc_con_app con args scrut'  -- Known constructor; simplify
-     = do { let Alt _ bs rhs = findAlt con alts
-                                  `orElse` Alt DEFAULT [] (mkImpossibleExpr ty)
-                alt_env'     = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
-          ; scExpr alt_env' rhs }
-
-    sc_vanilla scrut_usg scrut' -- Normal case
-     = do { let (alt_env,b') = extendBndrWith RecArg env b
-                        -- Record RecArg for the components
-
-          ; (alt_usgs, alt_occs, alts') <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
-
-          ; let scrut_occ  = foldr combineOcc NoOcc alt_occs
-                scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
-                -- The combined usage of the scrutinee is given
-                -- by scrut_occ, which is passed to setScrutOcc, which
-                -- in turn treats a bare-variable scrutinee specially
-          ; let !(MkSolo ty') = scSubstTy env ty
-
-          ; return (foldr combineUsage scrut_usg' alt_usgs,
-                    Case scrut' b' ty'  alts') }
-
-    single_alt = isSingleton alts
-
-    sc_alt env scrut' b' (Alt con bs rhs)
-     = do { let (env1, bs1) = extendBndrsWith RecArg env bs
-                (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1
-          ; (usg, rhs') <- scExpr env2 rhs
-          ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)
-                scrut_occ = case con of
-                               DataAlt dc -- See Note [Do not specialise evals]
-                                  | not (single_alt && all deadArgOcc arg_occs)
-                                  -> -- pprTrace "sc_alt1" (ppr b' $$ ppr con $$ ppr bs $$ ppr arg_occs) $
-                                     ScrutOcc (unitUFM dc arg_occs)
-                               _  -> -- pprTrace "sc_alt1" (ppr b' $$ ppr con $$ ppr bs $$ ppr arg_occs) $
-                                     UnkOcc
-          ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') }
-
-
-
-{- Note [Do not specialise evals]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   f x y = case x of I# _ ->
-           if y>1 then f x (y-1) else x
-
-Here `x` is scrutinised by a case, but only in an eval-like way; the
-/component/ of the I# is unused.  We don't want to specialise this
-function, even if we find a call (f (I# z)), because nothing is gained
-  * No case branches are discarded
-  * No allocation in removed
-The specialised version would take an unboxed Int#, pass it along,
-and rebox it at the end.
-
-In fact this can cause significant regression.  In #21763 we had:
-like
-  f = ... case x of x' { I# n ->
-          join j y = rhs
-          in ...jump j x'...
-
-Now if we specialise `j` for the argument `I# n`, we'll end up reboxing
-it in `j`, without even removing an allocation from the call site.
-
-Reboxing is always a worry.  But here we can ameliorate the problem as
-follows.
-
-* In scExpr (Case ...), for a /single-alternative/ case expression, in
-  which the pattern binders are all unused, we build a UnkOcc for
-  the scrutinee, not one that maps the data constructor; we don't treat
-  this occurrence as a reason for specialisation.
-
-* Conveniently, SpecConstr is doing its own occurrence analysis, so
-  the "unused" bit is just looking for NoOcc
-
-* Note that if we have
-    f x = case x of { True -> e1; False -> e2 }
-  then even though the pattern binders are unused (there are none), it is
-  still worth specialising on x. Hence the /single-alternative/ guard.
--}
-
-scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
-
-scApp env (Var fn, args)        -- Function is a variable
-  = assert (not (null args)) $
-    do  { args_w_usgs <- mapM (scExpr env) args
-        ; let (arg_usgs, args') = unzip args_w_usgs
-              arg_usg = combineUsages arg_usgs
-        ; case scSubstId env fn of
-            fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
-                        -- Do beta-reduction and try again
-
-            Var fn' -> return (arg_usg' `combineUsage` mkVarUsage env fn' args',
-                               mkApps (Var fn') args')
-               where
-                 -- arg_usg': see Note [Specialising on dictionaries]
-                 arg_usg' | Just cls <- isClassOpId_maybe fn'
-                          , dict_arg : _ <- dropList (classTyVars cls) args'
-                          = setScrutOcc env arg_usg dict_arg evalScrutOcc
-                          | otherwise
-                          = arg_usg
-
-            other_fn' -> return (arg_usg, mkApps other_fn' args') }
-                -- NB: doing this ignores any usage info from the substituted
-                --     function, but I don't think that matters.  If it does
-                --     we can fix it.
-  where
-    doBeta :: OutExpr -> [OutExpr] -> OutExpr
-    doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
-    doBeta fn              args         = mkApps fn args
-
--- The function is almost always a variable, but not always.
--- In particular, if this pass follows float-in,
--- which it may, we can get
---      (let f = ...f... in f) arg1 arg2
-scApp env (other_fn, args)
-  = do  { (fn_usg,   fn')   <- scExpr env other_fn
-        ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
-        ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
-
-----------------------
-mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage
-mkVarUsage env fn args
-  = case lookupHowBound env fn of
-        Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)]
-                           , scu_occs  = emptyVarEnv }
-        Just RecArg -> SCU { scu_calls = emptyVarEnv
-                           , scu_occs  = unitVarEnv fn arg_occ }
-        Nothing     -> nullUsage
-  where
-    arg_occ | null args = UnkOcc
-            | otherwise = evalScrutOcc
-
-----------------------
-scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo
-scRecRhs env (bndr,rhs)
-  = do  { let (arg_bndrs,body)       = collectBinders rhs
-              (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
-        ; (body_usg, body')         <- scExpr body_env body
-        ; let (rhs_usg, arg_occs)    = lookupOccs body_usg arg_bndrs'
-        ; return (RI { ri_rhs_usg = rhs_usg
-                     , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body'
-                     , ri_lam_bndrs = arg_bndrs, ri_lam_body = body
-                     , ri_arg_occs = arg_occs }) }
-                -- The arg_occs says how the visible,
-                -- lambda-bound binders of the RHS are used
-                -- (including the TyVar binders)
-                -- Two pats are the same if they match both ways
-
-----------------------
-ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
-ruleInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs })
-              (SI { si_specs = specs })
-  = [(id,rhs) | OS { os_id = id, os_rhs = rhs } <- specs] ++
-              -- First the specialised bindings
-
-    [(fn `addIdSpecialisations` rules, new_rhs)]
-              -- And now the original binding
-  where
-    rules = [r | OS { os_rule = r } <- specs]
-
-{-
-************************************************************************
-*                                                                      *
-                The specialiser itself
-*                                                                      *
-************************************************************************
--}
-
-data RhsInfo
-  = RI { ri_fn :: OutId                 -- The binder
-       , ri_new_rhs :: OutExpr          -- The specialised RHS (in current envt)
-       , ri_rhs_usg :: ScUsage          -- Usage info from specialising RHS
-
-       , ri_lam_bndrs :: [InVar]       -- The *original* RHS (\xs.body)
-       , ri_lam_body  :: InExpr        --   Note [Specialise original body]
-       , ri_arg_occs  :: [ArgOcc]      -- Info on how the xs occur in body
-    }
-
-data SpecInfo       -- Info about specialisations for a particular Id
-  = SI { si_specs :: [OneSpec]          -- The specialisations we have
-                                        -- generated for this function
-
-       , si_n_specs :: Int              -- Length of si_specs; used for numbering them
-
-       , si_mb_unspec :: Maybe ScUsage  -- Just cs  => we have not yet used calls in the
-       }                                --             from calls in the *original* RHS as
-                                        --             seeds for new specialisations;
-                                        --             if you decide to do so, here is the
-                                        --             RHS usage (which has not yet been
-                                        --             unleashed)
-                                        -- Nothing => we have
-                                        -- See Note [Seeding recursive groups]
-                                        -- See Note [spec_usg includes rhs_usg]
-
-        -- One specialisation: Rule plus definition
-data OneSpec =
-  OS { os_pat  :: CallPat    -- Call pattern that generated this specialisation
-     , os_rule :: CoreRule   -- Rule connecting original id with the specialisation
-     , os_id   :: OutId      -- Spec id
-     , os_rhs  :: OutExpr }  -- Spec rhs
-
-initSpecInfo :: RhsInfo -> SpecInfo
-initSpecInfo (RI { ri_rhs_usg = rhs_usg })
-  = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Just rhs_usg }
-    -- si_mb_unspec: add in rhs_usg if there are any boring calls,
-    --               or if the bndr is exported
-
-----------------------
-specNonRec :: ScEnv
-           -> CallEnv         -- Calls in body
-           -> RhsInfo         -- Structure info usage info for un-specialised RHS
-           -> UniqSM (ScUsage, SpecInfo)       -- Usage from RHSs (specialised and not)
-                                               --     plus details of specialisations
-
-specNonRec env body_calls rhs_info
-  = specialise env body_calls rhs_info (initSpecInfo rhs_info)
-
-----------------------
-specRec :: ScEnv
-        -> CallEnv                         -- Calls in body
-        -> [RhsInfo]                       -- Structure info and usage info for un-specialised RHSs
-        -> UniqSM (ScUsage, [SpecInfo])    -- Usage from all RHSs (specialised and not)
-                                           --     plus details of specialisations
-
-specRec env body_calls rhs_infos
-  = go 1 body_calls nullUsage (map initSpecInfo rhs_infos)
-    -- body_calls: see Note [Seeding recursive groups]
-    -- NB: 'go' always calls 'specialise' once, which in turn unleashes
-    --     si_mb_unspec if there are any boring calls in body_calls,
-    --     or if any of the Id(s) are exported
-  where
-    opts = sc_opts env
-
-    -- Loop, specialising, until you get no new specialisations
-    go, go_again :: Int   -- Which iteration of the "until no new specialisations"
-                          -- loop we are on; first iteration is 1
-                 -> CallEnv   -- Seed calls
-                              -- Two accumulating parameters:
-                 -> ScUsage      -- Usage from earlier specialisations
-                 -> [SpecInfo]   -- Details of specialisations so far
-                 -> UniqSM (ScUsage, [SpecInfo])
-    go n_iter seed_calls usg_so_far spec_infos
-      = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)
-        --                           , text "iteration" <+> int n_iter
-        --                          , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)
-        --                    ]) $
-        do  { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos
-            ; let (extra_usg_s, all_spec_infos) = unzip specs_w_usg
-                  extra_usg = combineUsages extra_usg_s
-                  all_usg   = usg_so_far `combineUsage` extra_usg
-                  new_calls = scu_calls extra_usg
-            ; go_again n_iter new_calls all_usg all_spec_infos }
-
-    -- go_again deals with termination
-    go_again n_iter seed_calls usg_so_far spec_infos
-      | isEmptyVarEnv seed_calls
-      = return (usg_so_far, spec_infos)
-
-      -- Limit recursive specialisation
-      -- See Note [Limit recursive specialisation]
-      | n_iter > sc_recursive opts  -- Too many iterations of the 'go' loop
-      , sc_force env || isNothing (sc_count opts)
-           -- If both of these are false, the sc_count
-           -- threshold will prevent non-termination
-      , any ((> the_limit) . si_n_specs) spec_infos
-      = -- Give up on specialisation, but don't forget to include the rhs_usg
-        -- for the unspecialised function, since it may now be called
-        -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $
-        let rhs_usgs = combineUsages (mapMaybe si_mb_unspec spec_infos)
-        in return (usg_so_far `combineUsage` rhs_usgs, spec_infos)
-
-      | otherwise
-      = go (n_iter + 1) seed_calls usg_so_far spec_infos
-
-    -- See Note [Limit recursive specialisation]
-    the_limit = case sc_count opts of
-                  Nothing  -> 10    -- Ugh!
-                  Just max -> max
-
-----------------------
-specialise
-   :: ScEnv
-   -> CallEnv                     -- Info on newly-discovered calls to this function
-   -> RhsInfo
-   -> SpecInfo                    -- Original RHS plus patterns dealt with
-   -> UniqSM (ScUsage, SpecInfo)  -- New specialised versions and their usage
-
--- See Note [spec_usg includes rhs_usg]
-
--- Note: this only generates *specialised* bindings
--- The original binding is added by ruleInfoBinds
---
--- Note: the rhs here is the optimised version of the original rhs
--- So when we make a specialised copy of the RHS, we're starting
--- from an RHS whose nested functions have been optimised already.
-
-specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
-                              , ri_lam_body = body, ri_arg_occs = arg_occs })
-               spec_info@(SI { si_specs = specs, si_n_specs = spec_count
-                             , si_mb_unspec = mb_unspec })
-  | isDeadEndId fn  -- Note [Do not specialise diverging functions]
-                    -- /and/ do not generate specialisation seeds from its RHS
-  = -- pprTrace "specialise bot" (ppr fn) $
-    return (nullUsage, spec_info)
-
-  | not (isNeverActive (idInlineActivation fn))
-      -- See Note [Transfer activation]
-      -- Don't specialise OPAQUE things, see Note [OPAQUE pragma].
-      -- Since OPAQUE things are always never-active (see
-      -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for
-      -- OPAQUE things.
-  , not (null arg_bndrs)                         -- Only specialise functions
-  , Just all_calls <- lookupVarEnv bind_calls fn -- Some calls to it
-  = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $
-    do  { (boring_call, pats_discarded, new_pats)
-             <- callsToNewPats env fn spec_info arg_occs all_calls
-
-        ; let n_pats = length new_pats
---        ; when (not (null new_pats) || isJust mb_unspec) $
---          pprTraceM "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns"
---                                       , text "boring_call:" <+> ppr boring_call
---                                       , text "pats_discarded:" <+> ppr pats_discarded
---                                       , text "old spec_count" <+> ppr spec_count
---                                       , text "spec count limit" <+> ppr (sc_count (sc_opts env))
---                                       , text "mb_unspec" <+> ppr (isJust mb_unspec)
---                                       , text "arg_occs" <+> ppr arg_occs
---                                       , text "new_pats" <+> ppr new_pats])
-
-        ; let spec_env = decreaseSpecCount env n_pats
-        ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
-                                                 (new_pats `zip` [spec_count..])
-                -- See Note [Specialise original body]
-
-        ; let spec_usg = combineUsages spec_usgs
-
-              unspec_rhs_needed = pats_discarded || boring_call || isExportedId fn
-
-              -- If there were any boring calls among the seeds (= all_calls), then those
-              -- calls will call the un-specialised function.  So we should use the seeds
-              -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning
-              -- then in new_usg.
-              (new_usg, mb_unspec') = case mb_unspec of
-                  Just rhs_usg | unspec_rhs_needed
-                               -> (spec_usg `combineUsage` rhs_usg, Nothing)
-                  _            -> (spec_usg,                      mb_unspec)
-
---        ; pprTraceM "specialise return }" $
---          vcat [ ppr fn
---               , text "unspec_rhs_needed:" <+> ppr unspec_rhs_needed
---               , text "new calls:" <+> ppr (scu_calls new_usg)]
-
-        ; return (new_usg, SI { si_specs     = new_specs ++ specs
-                              , si_n_specs   = spec_count + n_pats
-                              , si_mb_unspec = mb_unspec' }) }
-
-  | otherwise  -- No calls, inactive, or not a function
-               -- Behave as if there was a single, boring call
-  = -- pprTrace "specialise inactive" (ppr fn $$ ppr mb_unspec) $
-    case mb_unspec of    -- Behave as if there was a single, boring call
-      Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing })
-                         -- See Note [spec_usg includes rhs_usg]
-      Nothing      -> return (nullUsage, spec_info)
-
-
----------------------
-spec_one :: ScEnv
-         -> OutId       -- Function
-         -> [InVar]     -- Lambda-binders of RHS; should match patterns
-         -> InExpr      -- Body of the original function
-         -> (CallPat, Int)
-         -> UniqSM (ScUsage, OneSpec)   -- Rule and binding
-
--- spec_one creates a specialised copy of the function, together
--- with a rule for using it.  I'm very proud of how short this
--- function is, considering what it does :-).
-
-{-
-  Example
-
-     In-scope: a, x::a
-     f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
-          [c::*, v::(b,c) are presumably bound by the (...) part]
-  ==>
-     f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
-                  (...entire body of f...) [b -> (b,c),
-                                            y -> ((:) (a,(b,c)) (x,v) hw)]
-
-     RULE:  forall b::* c::*,           -- Note, *not* forall a, x
-                   v::(b,c),
-                   hw::[(a,(b,c))] .
-
-            f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
--}
-
-spec_one env fn arg_bndrs body (call_pat, rule_number)
-  | CP { cp_qvars = qvars, cp_args = pats, cp_strict_args = cbv_args } <- call_pat
-  = do  { -- pprTraceM "spec_one {" (ppr fn <+> ppr pats)
-
-        ; spec_uniq <- getUniqueM
-        ; let env1 = extendScSubstList (extendScInScope env qvars)
-                                       (arg_bndrs `zip` pats)
-              (body_env, extra_bndrs) = extendBndrs env1 (dropList pats arg_bndrs)
-              -- Remember, there may be fewer pats than arg_bndrs
-              -- See Note [SpecConstr call patterns]
-              -- extra_bndrs will then be arguments in the specialized version
-              -- which are *not* applied to arguments immediately at the call sites.
-              -- e.g. let f x y = ... in map (f True) xs
-              -- will result in y becoming an extra_bndr
-
-              fn_name  = idName fn
-              fn_loc   = nameSrcSpan fn_name
-              fn_occ   = nameOccName fn_name
-              spec_occ = mkSpecOcc fn_occ
-              -- We use fn_occ rather than fn in the rule_name string
-              -- as we don't want the uniq to end up in the rule, and
-              -- hence in the ABI, as that can cause spurious ABI
-              -- changes (#4012).
-              rule_name  = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number)
-              spec_name  = mkInternalName spec_uniq spec_occ fn_loc
-
-        -- Specialise the body
-        -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env)
-        ; (spec_usg, spec_body) <- scExpr body_env body
-
-                -- And build the results
-        ; (qvars', pats') <- generaliseDictPats qvars pats
-        ; let spec_body_ty   = exprType spec_body
-              (spec_lam_args1, spec_sig, spec_arity1, spec_join_arity1)
-                  = calcSpecInfo fn call_pat extra_bndrs
-                  -- Annotate the variables with the strictness information from
-                  -- the function (see Note [Strictness information in worker binders])
-              add_void_arg = needsVoidWorkerArg fn arg_bndrs spec_lam_args1
-              (spec_lam_args, spec_call_args, spec_arity, spec_join_arity)
-                  | add_void_arg
-                  -- See Note [SpecConstr needs to add void args first]
-                  , (spec_lam_args, spec_call_args, _) <- addVoidWorkerArg spec_lam_args1 []
-                      -- needsVoidWorkerArg: usual w/w hack to avoid generating
-                      -- a spec_rhs of unlifted type and no args.
-                  , !spec_arity      <- spec_arity1 + 1
-                  , !spec_join_arity <- fmap (+ 1) spec_join_arity1
-                  = (spec_lam_args,  spec_call_args, spec_arity,  spec_join_arity)
-                  | otherwise
-                  = (spec_lam_args1, spec_lam_args1, spec_arity1, spec_join_arity1)
-
-              spec_id    = asWorkerLikeId $
-                           mkLocalId spec_name ManyTy
-                                     (mkLamTypes spec_lam_args spec_body_ty)
-                             -- See Note [Transfer strictness]
-                             `setIdDmdSig`    spec_sig
-                             `setIdCprSig`    topCprSig
-                             `setIdArity`     spec_arity
-                             `asJoinId_maybe` spec_join_arity
-
-        -- Conditionally use result of new worker-wrapper transform
-              spec_rhs = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body)
-              rule_rhs = mkVarApps (Var spec_id) $
-                              -- This will give us all the arguments we quantify over
-                              -- in the rule plus the void argument if present
-                              -- since `length(qvars) + void + length(extra_bndrs) = length spec_call_args`
-                              dropTail (length extra_bndrs) spec_call_args
-              inline_act = idInlineActivation fn
-              this_mod   = sc_module $ sc_opts env
-              rule       = mkRule this_mod True {- Auto -} True {- Local -}
-                                  rule_name inline_act
-                                  fn_name qvars' pats' rule_rhs
-                           -- See Note [Transfer activation]
-
---        ; pprTraceM "spec_one end }" $
---          vcat [ text "function:" <+> ppr fn <+> braces (ppr (idUnique fn))
---               , text "pats:" <+> ppr pats
---               , text "call_pat:" <+> ppr call_pat
---               , text "-->" <+> ppr spec_name
---               , text "bndrs" <+> ppr arg_bndrs
---               , text "extra_bndrs" <+> ppr extra_bndrs
---               , text "cbv_args" <+> ppr cbv_args
---               , text "spec_lam_args" <+> ppr spec_lam_args
---               , text "spec_call_args" <+> ppr spec_call_args
---               , text "rule_rhs" <+> ppr rule_rhs
---               , text "adds_void_worker_arg" <+> ppr add_void_arg
-----               , text "body" <+> ppr body
-----               , text "spec_rhs" <+> ppr spec_rhs
-----               , text "how_bound" <+> ppr (sc_how_bound env) ]
---               ]
-        ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule
-                               , os_id = spec_id
-                               , os_rhs = spec_rhs }) }
-
-generaliseDictPats :: [Var] -> [CoreExpr]  -- Quantified vars and pats
-                   -> UniqSM ([Var], [CoreExpr]) -- New quantified vars and pats
--- See Note [generaliseDictPats]
-generaliseDictPats qvars pats
-  = do { (extra_qvars, pats') <- mapAccumLM go [] pats
-       ; case extra_qvars of
-             [] -> return (qvars,                pats)
-             _  -> return (qvars ++ extra_qvars, pats') }
-  where
-    qvar_set = mkVarSet qvars
-    go :: [Id] -> CoreExpr -> UniqSM ([Id], CoreExpr)
-    go extra_qvs pat
-       | not (isTyCoArg pat)
-       , let pat_ty = exprType pat
-       , typeDeterminesValue pat_ty
-       , exprFreeVars pat `disjointVarSet` qvar_set
-       = do { id <- mkSysLocalOrCoVarM (fsLit "dict") ManyTy pat_ty
-            ; return (id:extra_qvs, Var id) }
-       | otherwise
-       = return (extra_qvs, pat)
-
--- See Note [SpecConstr and strict fields]
-mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr
-mkSeqs seqees res_ty rhs =
-  foldr addEval rhs seqees
-    where
-      addEval :: Var -> CoreExpr -> CoreExpr
-      addEval arg_id rhs
-        -- Argument representing strict field and it's worth passing via cbv
-        | shouldStrictifyIdForCbv arg_id
-        = Case (Var arg_id) arg_id res_ty ([Alt DEFAULT [] rhs])
-        | otherwise
-        = rhs
-
-
-{- Note [SpecConstr needs to add void args first]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider a function
-    f start @t = e
-We want to specialize for a partially applied call `f True`.
-See also Note [SpecConstr call patterns], second Wrinkle.
-Naively we would expect to get
-    $sf @t = $se
-    RULE: f True = $sf
-The specialized function only takes a single type argument
-so we add a void argument to prevent it from turning into
-a thunk. See Note [Protecting the last value argument] for details
-why. Normally we would add the void argument after the
-type argument giving us:
-    $sf :: forall t. Void# -> bla
-    $sf @t void = $se
-    RULE: f True = $sf void# (wrong)
-But if you look closely this wouldn't typecheck!
-If we substitute `f True` with `$sf void#` we expect the type argument to be applied first
-but we apply void# first.
-The easiest fix seems to be just to add the void argument to the front of the arguments.
-Now we get:
-    $sf :: Void# -> forall t. bla
-    $sf void @t = $se
-    RULE: f True = $sf void#
-And now we can substitute `f True` with `$sf void#` with everything working out nicely!
-
-Note [generaliseDictPats]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider these two rules (#21831, item 2):
-  RULE "SPEC:foo"  forall d1 d2. foo @Int @Integer d1 d2 = $sfoo1
-  RULE "SC:foo"    forall a. foo @Int @a $fNumInteger = $sfoo2 @a
-The former comes from the type class specialiser, the latter from SpecConstr.
-Note that $fNumInteger is a top-level binding for Num Integer.
-
-The trouble is that neither is more general than the other.  In a call
-   (foo @Int @Integer $fNumInteger d)
-it isn't clear which rule to fire.
-
-The trouble is that the SpecConstr rule fires on a /specific/ dict, $fNumInteger,
-but actually /could/ fire regardless.  That is, it could be
-  RULE "SC:foo"    forall a d. foo @Int @a d = $sfoo2 @a
-
-Now, it is clear that SPEC:foo is more specific.  But GHC can't tell
-that, because SpecConstr doesn't know that dictionary arguments are
-singleton types!  So generaliseDictPats teaches it this fact.  It
-spots such patterns (using typeDeterminesValue), and quantifies over
-the dictionary.  Now we get
-
-  RULE "SC:foo"    forall a d. foo @Int @a d = $sfoo2 @a
-
-And /now/ "SPEC:foo" is clearly more specific: we can instantiate the new
-"SC:foo" to match the (prefix of) "SPEC:foo".
--}
-
-calcSpecInfo :: Id                     -- The original function
-             -> CallPat                -- Call pattern
-             -> [Var]                  -- Extra bndrs
-             -> ( [Var]                     -- Demand-decorated binders
-                , DmdSig                    -- Strictness of specialised thing
-                , Arity, Maybe JoinArity )  -- Arities of specialised thing
--- Calculate bits of IdInfo for the specialised function
--- See Note [Transfer strictness]
--- See Note [Strictness information in worker binders]
-calcSpecInfo fn (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs
-  | isJoinId fn    -- Join points have strictness and arity for LHS only
-  = ( bndrs_w_dmds
-    , mkClosedDmdSig qvar_dmds div
-    , count isId qvars
-    , Just (length qvars) )
-  | otherwise
-  = ( bndrs_w_dmds
-    , mkClosedDmdSig (qvar_dmds ++ extra_dmds) div
-    , count isId qvars + count isId extra_bndrs
-    , Nothing )
-  where
-    DmdSig (DmdType _ fn_dmds div) = idDmdSig fn
-
-    val_pats   = filterOut isTypeArg pats -- value args at call sites, used to determine how many demands to drop
-                                          -- from the original functions demand and for setting up dmd_env.
-    qvar_dmds  = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]
-    extra_dmds = dropList val_pats fn_dmds
-
-    bndrs_w_dmds =  set_dmds qvars       qvar_dmds
-                 ++ set_dmds extra_bndrs extra_dmds
-
-    set_dmds :: [Var] -> [Demand] -> [Var]
-    set_dmds [] _   = []
-    set_dmds vs  [] = vs  -- Run out of demands
-    set_dmds (v:vs) ds@(d:ds') | isTyVar v = v                   : set_dmds vs ds
-                               | otherwise = setIdDemandInfo v d : set_dmds vs ds'
-
-    dmd_env = go emptyVarEnv fn_dmds val_pats
-
-    go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv
-    -- We've filtered out all the type patterns already
-    go env (d:ds) (pat : pats)     = go (go_one env d pat) ds pats
-    go env _      _                = env
-
-    go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv
-    go_one env d          (Var v) = extendVarEnv_C plusDmd env v d
-    go_one env (_n :* cd) e -- NB: _n does not have to be strict
-      | (Var _, args) <- collectArgs e
-      , Just (_b, ds) <- viewProd (length args) cd -- TODO: We may want to look at boxity _b, though...
-      = go env ds args
-    go_one env _  _ = env
-
-
-{-
-Note [spec_usg includes rhs_usg]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In calls to 'specialise', the returned ScUsage must include the rhs_usg in
-the passed-in SpecInfo in si_mb_unspec, unless there are no calls at all to
-the function.
-
-The caller can, indeed must, assume this.  They should not combine in rhs_usg
-themselves, or they'll get rhs_usg twice -- and that can lead to an exponential
-blowup of duplicates in the CallEnv.  This is what gave rise to the massive
-performance loss in #8852.
-
-Note [Specialise original body]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The RhsInfo for a binding keeps the *original* body of the binding.  We
-must specialise that, *not* the result of applying specExpr to the RHS
-(which is also kept in RhsInfo). Otherwise we end up specialising a
-specialised RHS, and that can lead directly to exponential behaviour.
-
-Note [Transfer activation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-  This note is for SpecConstr, but exactly the same thing
-  happens in the overloading specialiser; see
-  Note [Auto-specialisation and RULES] in GHC.Core.Opt.Specialise.
-
-In which phase should the specialise-constructor rules be active?
-Originally I made them always-active, but Manuel found that this
-defeated some clever user-written rules.  Then I made them active only
-in FinalPhase; after all, currently, the specConstr transformation is
-only run after the simplifier has reached FinalPhase, but that meant
-that specialisations didn't fire inside wrappers; see test
-simplCore/should_compile/spec-inline.
-
-So now I just use the inline-activation of the parent Id, as the
-activation for the specialisation RULE, just like the main specialiser;
-
-This in turn means there is no point in specialising NOINLINE things,
-so we test for that.
-
-Note [Transfer strictness]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must transfer strictness information from the original function to
-the specialised one.  Suppose, for example
-
-  f has strictness     SSx
-        and a RULE     f (a:as) b = f_spec a as b
-
-Now we want f_spec to have strictness  LLSx, otherwise we'll use call-by-need
-when calling f_spec instead of call-by-value.  And that can result in
-unbounded worsening in space (cf the classic foldl vs foldl')
-
-See #3437 for a good example.
-
-The function calcSpecStrictness performs the calculation.
-
-Note [Strictness information in worker binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-After having calculated the strictness annotation for the worker (see Note
-[Transfer strictness] above), we also want to have this information attached to
-the worker’s arguments, for the benefit of later passes. The function
-handOutStrictnessInformation decomposes the strictness annotation calculated by
-calcSpecStrictness and attaches them to the variables.
-
-
-************************************************************************
-*                                                                      *
-\subsection{Argument analysis}
-*                                                                      *
-************************************************************************
-
-This code deals with analysing call-site arguments to see whether
-they are constructor applications.
-
-Note [Free type variables of the qvar types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In a call (f @a x True), that we want to specialise, what variables should
-we quantify over.  Clearly over 'a' and 'x', but what about any type variables
-free in x's type?  In fact we don't need to worry about them because (f @a)
-can only be a well-typed application if its type is compatible with x, so any
-variables free in x's type must be free in (f @a), and hence either be gathered
-via 'a' itself, or be in scope at f's defn.  Hence we just take
-  (exprsFreeVars pats).
-
-BUT phantom type synonyms can mess this reasoning up,
-  eg   x::T b   with  type T b = Int
-So we apply expandTypeSynonyms to the bound Ids.
-See # 5458.  Yuk.
-
-Note [SpecConstr call patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A "call patterns" that we collect is going to become the LHS of a RULE.
-
-Wrinkles:
-
-* The list of argument patterns, cp_args, is no longer than the
-  visible lambdas of the binding, ri_arg_occs.  This is done via
-  the zipWithM in callToPats.
-
-* The list of argument patterns can certainly be shorter than the
-  lambdas in the function definition (under-saturated).  For example
-      f x y = case x of { True -> e1; False -> e2 }
-      ....map (f True) e...
-  We want to specialise `f` for `f True`.
-
-* In fact we deliberately shrink the list of argument patterns,
-  cp_args, by trimming off all the boring ones at the end (see
-  `dropWhileEnd is_boring` in callToPats).  Since the RULE only
-  applies when it is saturated, this shrinking makes the RULE more
-  applicable.  But it does mean that the argument patterns do not
-  necessarily saturate the lambdas of the function.
-
-* It's important that the pattern arguments do not look like
-     e |> Refl
-  or
-    e |> g1 |> g2
-  because both of these will be optimised by Simplify.simplRule. In the
-  former case such optimisation benign, because the rule will match more
-  terms; but in the latter we may lose a binding of 'g1' or 'g2', and
-  end up with a rule LHS that doesn't bind the template variables
-  (#10602).
-
-  The simplifier eliminates such things, but SpecConstr itself constructs
-  new terms by substituting.  So the 'mkCast' in the Cast case of scExpr
-  is very important!
-
-Note [Choosing patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~
-If we get lots of patterns we may not want to make a specialisation
-for each of them (code bloat), so we choose as follows, implemented
-by trim_pats.
-
-* The flag -fspec-constr-count-N sets the sc_count field
-  of the ScEnv to (Just n).  This limits the total number
-  of specialisations for a given function to N.
-
-* -fno-spec-constr-count sets the sc_count field to Nothing,
-  which switches of the limit.
-
-* The ghastly ForceSpecConstr trick also switches of the limit
-  for a particular function
-
-* Otherwise we sort the patterns to choose the most general
-  ones first; more general => more widely applicable.
-
-Note [SpecConstr and casts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#14270) a call like
-
-    let f = e
-    in ... f (K @(a |> co)) ...
-
-where 'co' is a coercion variable not in scope at f's definition site.
-If we aren't careful we'll get
-
-    let $sf a co = e (K @(a |> co))
-        RULE "SC:f" forall a co.  f (K @(a |> co)) = $sf a co
-        f = e
-    in ...
-
-But alas, when we match the call we won't bind 'co', because type-matching
-(for good reasons) discards casts).
-
-I don't know how to solve this, so for now I'm just discarding any
-call patterns that
-  * Mentions a coercion variable in a type argument
-  * That is not in scope at the binding of the function
-
-I think this is very rare.
-
-It is important (e.g. #14936) that this /only/ applies to
-coercions mentioned in casts.  We don't want to be discombobulated
-by casts in terms!  For example, consider
-   f ((e1,e2) |> sym co)
-where, say,
-   f  :: Foo -> blah
-   co :: Foo ~R (Int,Int)
-
-Here we definitely do want to specialise for that pair!  We do not
-match on the structure of the coercion; instead we just match on a
-coercion variable, so the RULE looks like
-
-   forall (x::Int, y::Int, co :: (Int,Int) ~R Foo)
-     f ((x,y) |> co) = $sf x y co
-
-Often the body of f looks like
-   f arg = ...(case arg |> co' of
-                (x,y) -> blah)...
-
-so that the specialised f will turn into
-   $sf x y co = let arg = (x,y) |> co
-                in ...(case arg>| co' of
-                         (x,y) -> blah)....
-
-which will simplify to not use 'co' at all.  But we can't guarantee
-that co will end up unused, so we still pass it.  Absence analysis
-may remove it later.
-
-Note that this /also/ discards the call pattern if we have a cast in a
-/term/, although in fact Rules.match does make a very flaky and
-fragile attempt to match coercions.  e.g. a call like
-    f (Maybe Age) (Nothing |> co) blah
-    where co :: Maybe Int ~ Maybe Age
-will be discarded.  It's extremely fragile to match on the form of a
-coercion, so I think it's better just not to try.  A more complicated
-alternative would be to discard calls that mention coercion variables
-only in kind-casts, but I'm doing the simple thing for now.
--}
-
-data CallPat = CP { cp_qvars :: [Var]           -- Quantified variables
-                  , cp_args  :: [CoreExpr]      -- Arguments
-                  , cp_strict_args :: [Var] }   -- Arguments we want to pass unlifted even if they are boxed
-     -- See Note [SpecConstr call patterns]
-
-instance Outputable CallPat where
-  ppr (CP { cp_qvars = qvars, cp_args = args, cp_strict_args =  strict })
-    = text "CP" <> braces (sep [ text "cp_qvars =" <+> ppr qvars <> comma
-                               , text "cp_args =" <+> ppr args
-                               , text "cp_strict_args = " <> ppr strict ])
-
-callsToNewPats :: ScEnv -> Id
-               -> SpecInfo
-               -> [ArgOcc] -> [Call]
-               -> UniqSM ( Bool        -- At least one boring call
-                         , Bool        -- Patterns were discarded
-                         , [CallPat] ) -- Patterns to specialise
--- Result has no duplicate patterns,
--- nor ones mentioned in si_specs (hence "new" patterns)
--- Bool indicates that there was at least one boring pattern
--- The "New" in the name means "patterns that are not already covered
--- by an existing specialisation"
-callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
-  = do  { mb_pats <- mapM (callToPats env bndr_occs) calls
-
-        ; let have_boring_call = any isNothing mb_pats
-
-              good_pats :: [CallPat]
-              good_pats = catMaybes mb_pats
-
-              -- Remove patterns we have already done
-              new_pats = filterOut is_done good_pats
-              is_done p = any (samePat p . os_pat) done_specs
-
-              -- Remove duplicates
-              non_dups = nubBy samePat new_pats
-
-              -- Remove ones that have too many worker variables
-              small_pats = filterOut too_big non_dups
-              too_big (CP { cp_qvars = vars, cp_args = args })
-                = not (isWorkerSmallEnough (sc_max_args $ sc_opts env) (valArgCount args) vars)
-                  -- We are about to construct w/w pair in 'spec_one'.
-                  -- Omit specialisation leading to high arity workers.
-                  -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils
-
-                -- Discard specialisations if there are too many of them
-              (pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats
-
---        ; pprTraceM "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls
---                                        , text "done_specs:" <+> ppr (map os_pat done_specs)
---                                        , text "trimmed_pats:" <+> ppr trimmed_pats ])
-
-        ; return (have_boring_call, pats_were_discarded, trimmed_pats) }
-          -- If any of the calls does not give rise to a specialisation, either
-          -- because it is boring, or because there are too many specialisations,
-          -- return a flag to say so, so that we know to keep the original function.
-
-
-trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat])
--- True <=> some patterns were discarded
--- See Note [Choosing patterns]
-trim_pats env fn (SI { si_n_specs = done_spec_count }) pats
-  | sc_force env
-    || isNothing mb_scc
-    || n_remaining >= n_pats
-  = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)
-    (False, pats)          -- No need to trim
-
-  | otherwise
-  = emit_trace $  -- Need to trim, so keep the best ones
-    (True, take n_remaining sorted_pats)
-
-  where
-    n_pats         = length pats
-    spec_count'    = n_pats + done_spec_count
-    n_remaining    = max_specs - done_spec_count
-    mb_scc         = sc_count $ sc_opts env
-    Just max_specs = mb_scc
-
-    sorted_pats = map fst $
-                  sortBy (comparing snd) $
-                  [(pat, pat_cons pat) | pat <- pats]
-     -- Sort in order of increasing number of constructors
-     -- (i.e. decreasing generality) and pick the initial
-     -- segment of this list
-
-    pat_cons :: CallPat -> Int
-    -- How many data constructors of literals are in
-    -- the pattern.  More data-cons => less general
-    pat_cons (CP { cp_qvars = qs, cp_args = ps })
-       = foldr ((+) . n_cons) 0 ps
-       where
-          q_set = mkVarSet qs
-          n_cons (Var v) | v `elemVarSet` q_set = 0
-                         | otherwise            = 1
-          n_cons (Cast e _)  = n_cons e
-          n_cons (App e1 e2) = n_cons e1 + n_cons e2
-          n_cons (Lit {})    = 1
-          n_cons _           = 0
-
-    emit_trace result
-       | debugIsOn || sc_debug (sc_opts env)
-         -- Suppress this scary message for ordinary users!  #5125
-       = pprTrace "SpecConstr" msg result
-       | otherwise
-       = result
-    msg = vcat [ sep [ text "Function" <+> quotes (ppr fn)
-                     , nest 2 (text "has" <+>
-                               speakNOf spec_count' (text "call pattern") <> comma <+>
-                               text "but the limit is" <+> int max_specs) ]
-               , text "Use -fspec-constr-count=n to set the bound"
-               , text "done_spec_count =" <+> int done_spec_count
-               , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats
-               , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ]
-
-
-callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
-        -- The [Var] is the variables to quantify over in the rule
-        --      Type variables come first, since they may scope
-        --      over the following term variables
-        -- The [CoreExpr] are the argument patterns for the rule
-callToPats env bndr_occs call@(Call fn args con_env)
-  = do  { let in_scope = getSubstInScope (sc_subst env)
-
-        ; arg_tripples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args)
-                   -- This zip trims the args to be no longer than
-                   -- the lambdas in the function definition (bndr_occs)
-
-          -- Drop boring patterns from the end
-          -- See Note [SpecConstr call patterns]
-        ; let arg_tripples' | isJoinId fn = arg_tripples
-                            | otherwise   = dropWhileEnd is_boring arg_tripples
-              is_boring (interesting, _,_) = not interesting
-              (interesting_s, pats, cbv_ids) = unzip3 arg_tripples'
-              interesting           = or interesting_s
-
-        ; let pat_fvs = exprsFreeVarsList pats
-                -- To get determinism we need the list of free variables in
-                -- deterministic order. Otherwise we end up creating
-                -- lambdas with different argument orders. See
-                -- determinism/simplCore/should_compile/spec-inline-determ.hs
-                -- for an example. For explanation of determinism
-                -- considerations See Note [Unique Determinism] in GHC.Types.Unique.
-
-              in_scope_vars = getInScopeVars in_scope
-              is_in_scope v = v `elemVarSet` in_scope_vars
-              qvars         = filterOut is_in_scope pat_fvs
-                -- Quantify over variables that are not in scope
-                -- at the call site
-                -- See Note [Free type variables of the qvar types]
-                -- See Note [Shadowing] at the top
-
-              (ktvs, ids)   = partition isTyVar qvars
-              qvars'        = scopedSort ktvs ++ map sanitise ids
-                -- Order into kind variables, type variables, term variables
-                -- The kind of a type variable may mention a kind variable
-                -- and the type of a term variable may mention a type variable
-
-              sanitise id   = updateIdTypeAndMult expandTypeSynonyms id
-                -- See Note [Free type variables of the qvar types]
-
-
-        -- Check for bad coercion variables: see Note [SpecConstr and casts]
-        ; let bad_covars :: CoVarSet
-              bad_covars = mapUnionVarSet get_bad_covars pats
-              get_bad_covars :: CoreArg -> CoVarSet
-              get_bad_covars (Type ty) = filterVarSet bad_covar (tyCoVarsOfType ty)
-              get_bad_covars _         = emptyVarSet
-              bad_covar v = isId v && not (is_in_scope v)
-
-        ; warnPprTrace (not (isEmptyVarSet bad_covars))
-              "SpecConstr: bad covars"
-              (ppr bad_covars $$ ppr call) $
-
-          if interesting && isEmptyVarSet bad_covars
-          then do { let cp_res = CP { cp_qvars = qvars', cp_args = pats
-                                    , cp_strict_args = concat cbv_ids }
---                  ; pprTraceM "callToPatsOut" $
---                    vcat [ text "fn:" <+> ppr fn
---                         , text "args:" <+> ppr args
---                         , text "bndr_occs:" <+> ppr bndr_occs
---                         , text "pat_fvs:" <+> ppr pat_fvs
---                         , text "cp_res:" <+> ppr cp_res ]
-                  ; return (Just cp_res) }
-          else return Nothing }
-
-    -- argToPat takes an actual argument, and returns an abstracted
-    -- version, consisting of just the "constructor skeleton" of the
-    -- argument, with non-constructor sub-expression replaced by new
-    -- placeholder variables.  For example:
-    --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)
-
-argToPat :: ScEnv
-         -> InScopeSet                  -- What's in scope at the fn defn site
-         -> ValueEnv                    -- ValueEnv at the call site
-         -> CoreArg                     -- A call arg (or component thereof)
-         -> ArgOcc
-         -> StrictnessMark              -- Tells us if this argument is a strict field of a data constructor
-                                        -- See Note [SpecConstr and strict fields]
-         -> UniqSM (Bool, CoreArg, [Id])
-
--- Returns (interesting, pat),
--- where pat is the pattern derived from the argument
---            interesting=True if the pattern is non-trivial (not a variable or type)
--- E.g.         x:xs         --> (True, x:xs)
---              f xs         --> (False, w)        where w is a fresh wildcard
---              (f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard
---              \x. x+y      --> (True, \x. x+y)
---              lvl7         --> (True, lvl7)      if lvl7 is bound
---                                                 somewhere further out
-
-argToPat env in_scope val_env arg arg_occ arg_str
-  = do
-    -- pprTraceM "argToPatIn" (ppr arg)
-    !res <- argToPat1 env in_scope val_env arg arg_occ arg_str
-    -- pprTraceM "argToPatOut" (ppr res)
-    return res
-
-argToPat1 :: ScEnv
-  -> InScopeSet
-  -> ValueEnv
-  -> Expr CoreBndr
-  -> ArgOcc
-  -> StrictnessMark
-  -> UniqSM (Bool, Expr CoreBndr, [Id])
-argToPat1 _env _in_scope _val_env arg@(Type {}) _arg_occ _arg_str
-  = return (False, arg, [])
-
-argToPat1 env in_scope val_env (Tick _ arg) arg_occ arg_str
-  = argToPat env in_scope val_env arg arg_occ arg_str
-        -- Note [Tick annotations in call patterns]
-        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-        -- Ignore Notes.  In particular, we want to ignore any InlineMe notes
-        -- Perhaps we should not ignore profiling notes, but I'm going to
-        -- ride roughshod over them all for now.
-        --- See Note [Tick annotations in RULE matching] in GHC.Core.Rules
-
-argToPat1 env in_scope val_env (Let _ arg) arg_occ arg_str
-  = argToPat env in_scope val_env arg arg_occ arg_str
-        -- See Note [Matching lets] in "GHC.Core.Rules"
-        -- Look through let expressions
-        -- e.g.         f (let v = rhs in (v,w))
-        -- Here we can specialise for f (v,w)
-        -- because the rule-matcher will look through the let.
-
-{- Disabled; see Note [Matching cases] in "GHC.Core.Rules"
-argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
-  | exprOkForSpeculation scrut  -- See Note [Matching cases] in "GHC.Core.Rules"
-  = argToPat env in_scope val_env rhs arg_occ
--}
-
-argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str
-  | not (ignoreType env ty2)
-  = do  { (interesting, arg', strict_args) <- argToPat env in_scope val_env arg arg_occ arg_str
-        ; if not interesting then
-                wildCardPat ty2 arg_str
-          else do
-        { -- Make a wild-card pattern for the coercion
-          uniq <- getUniqueM
-        ; let co_name = mkSysTvName uniq (fsLit "sg")
-              co_var  = mkCoVar co_name (mkCoercionType Representational ty1 ty2)
-        ; return (interesting, Cast arg' (mkCoVarCo co_var), strict_args) } }
-  where
-    Pair ty1 ty2 = coercionKind co
-
-
-
-{-      Disabling lambda specialisation for now
-        It's fragile, and the spec_loop can be infinite
-argToPat in_scope val_env arg arg_occ
-  | is_value_lam arg
-  = return (True, arg)
-  where
-    is_value_lam (Lam v e)         -- Spot a value lambda, even if
-        | isId v       = True      -- it is inside a type lambda
-        | otherwise    = is_value_lam e
-    is_value_lam other = False
--}
-
-  -- Check for a constructor application
-  -- NB: this *precedes* the Var case, so that we catch nullary constrs
-argToPat1 env in_scope val_env arg arg_occ _arg_str
-  | Just (ConVal (DataAlt dc) args) <- isValue val_env arg
-  , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]
-  , Just arg_occs <- mb_scrut dc
-  = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args
-             con_str, matched_str :: [StrictnessMark]
-             -- con_str corresponds 1-1 with the /value/ arguments
-             -- matched_str corresponds 1-1 with /all/ arguments
-             con_str = dataConRepStrictness dc
-             matched_str = match_vals con_str rest_args
-      --  ; pprTraceM "bangs" (ppr (length rest_args == length con_str) $$
-      --       ppr dc $$
-      --       ppr con_str $$
-      --       ppr rest_args $$
-      --       ppr (map isTypeArg rest_args))
-       ; prs <- zipWith3M (argToPat env in_scope val_env) rest_args arg_occs matched_str
-       ; let args' = map sndOf3 prs :: [CoreArg]
-       ; assertPpr (length con_str == length (filter isRuntimeArg rest_args))
-            ( ppr con_str $$ ppr rest_args $$
-              ppr (length con_str) $$ ppr (length rest_args)
-            ) $ return ()
-       ; return (True, mkConApp dc (ty_args ++ args'), concat (map thdOf3 prs)) }
-  where
-    mb_scrut dc = case arg_occ of
-                ScrutOcc bs | Just occs <- lookupUFM bs dc
-                            -> Just (occs)  -- See Note [Reboxing]
-                _other      | sc_force env || sc_keen (sc_opts env)
-                            -> Just (repeat UnkOcc)
-                            | otherwise
-                            -> Nothing
-    match_vals bangs (arg:args)
-      | isTypeArg arg
-      = NotMarkedStrict : match_vals bangs args
-      | (b:bs) <- bangs
-      = b : match_vals bs args
-    match_vals [] [] = []
-    match_vals as bs =
-        pprPanic "spec-constr:argToPat - Bangs don't match value arguments"
-            (text "arg:" <> ppr arg $$
-             text "remaining args:" <> ppr as $$
-             text "remaining bangs:" <> ppr bs)
-
-  -- Check if the argument is a variable that
-  --    (a) is used in an interesting way in the function body
-  ---       i.e. ScrutOcc. UnkOcc and NoOcc are not interesting
-  --        (NoOcc means we could drop the argument, but that's the
-  --         business of absence analysis, not SpecConstr.)
-  --    (b) we know what its value is
-  -- In that case it counts as "interesting"
-argToPat1 env in_scope val_env (Var v) arg_occ arg_str
-  | sc_force env || specialisableArgOcc arg_occ  -- (a)
-  , is_value                                     -- (b)
-       -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]
-       -- So sc_keen focused just on f (I# x), where we have freshly-allocated
-       -- box that we can eliminate in the caller
-  , not (ignoreType env (varType v))
-  -- See Note [SpecConstr and strict fields]
-  = return (True, Var v, if isMarkedStrict arg_str then [v] else mempty)
-  where
-    is_value
-        | isLocalId v = v `elemInScopeSet` in_scope
-                        && isJust (lookupVarEnv val_env v)
-                -- Local variables have values in val_env
-        | otherwise   = isValueUnfolding (idUnfolding v)
-                -- Imports have unfoldings
-
---      I'm really not sure what this comment means
---      And by not wild-carding we tend to get forall'd
---      variables that are in scope, which in turn can
---      expose the weakness in let-matching
---      See Note [Matching lets] in GHC.Core.Rules
-
-  -- Check for a variable bound inside the function.
-  -- Don't make a wild-card, because we may usefully share
-  --    e.g.  f a = let x = ... in f (x,x)
-  -- NB: this case follows the lambda and con-app cases!!
--- argToPat _in_scope _val_env (Var v) _arg_occ
---   = return (False, Var v)
-        -- SLPJ : disabling this to avoid proliferation of versions
-        -- also works badly when thinking about seeding the loop
-        -- from the body of the let
-        --       f x y = letrec g z = ... in g (x,y)
-        -- We don't want to specialise for that *particular* x,y
-
-  -- The default case: make a wild-card
-  -- We use this for coercions too
-argToPat1 _env _in_scope _val_env arg _arg_occ arg_str
-  = wildCardPat (exprType arg) arg_str
-
--- | wildCardPats are always boring
-wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id])
-wildCardPat ty str
-  = do { id <- mkSysLocalOrCoVarM (fsLit "sc") ManyTy ty
-       -- ; pprTraceM "wildCardPat" (ppr id' <+> ppr (idUnfolding id'))
-       ; return (False, varToCoreExpr id, if isMarkedStrict str then [id] else []) }
-
-isValue :: ValueEnv -> CoreExpr -> Maybe Value
-isValue _env (Lit lit)
-  | litIsLifted lit = Nothing
-  | otherwise       = Just (ConVal (LitAlt lit) [])
-
-isValue env (Var v)
-  | Just cval <- lookupVarEnv env v
-  = Just cval  -- You might think we could look in the idUnfolding here
-               -- but that doesn't take account of which branch of a
-               -- case we are in, which is the whole point
-
-  | not (isLocalId v) && isCheapUnfolding unf
-  = isValue env (unfoldingTemplate unf)
-  where
-    unf = idUnfolding v
-        -- However we do want to consult the unfolding
-        -- as well, for let-bound constructors!
-
-isValue env (Lam b e)
-  | isTyVar b = case isValue env e of
-                  Just _  -> Just LambdaVal
-                  Nothing -> Nothing
-  | otherwise = Just LambdaVal
-
-isValue env (Tick t e)
-  | not (tickishIsCode t)
-  = isValue env e
-
-isValue _env expr       -- Maybe it's a constructor application
-  | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr
-  = case idDetails fun of
-        DataConWorkId con | args `lengthAtLeast` dataConRepArity con
-                -- Check saturated; might be > because the
-                --                  arity excludes type args
-                -> Just (ConVal (DataAlt con) args)
-
-        DFunId {} -> Just LambdaVal
-        -- DFunId: see Note [Specialising on dictionaries]
-
-        _other | valArgCount args < idArity fun
-                -- Under-applied function
-               -> Just LambdaVal        -- Partial application
-
-        _other -> Nothing
-
-isValue _env _expr = Nothing
-
-valueIsWorkFree :: Value -> Bool
-valueIsWorkFree LambdaVal       = True
-valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args
-
-samePat :: CallPat -> CallPat -> Bool
-samePat (CP { cp_qvars = vs1, cp_args = as1 })
-        (CP { cp_qvars = vs2, cp_args = as2 })
-  = all2 same as1 as2
-  where
-    -- If the args are the same, their strictness marks will be too so we don't compare those.
-    same (Var v1) (Var v2)
-        | v1 `elem` vs1 = v2 `elem` vs2
-        | v2 `elem` vs2 = False
-        | otherwise     = v1 == v2
-
-    same (Lit l1)    (Lit l2)    = l1==l2
-    same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
-
-    same (Type {}) (Type {}) = True     -- Note [Ignore type differences]
-    same (Coercion {}) (Coercion {}) = True
-    same (Tick _ e1) e2 = same e1 e2  -- Ignore casts and notes
-    same (Cast e1 _) e2 = same e1 e2
-    same e1 (Tick _ e2) = same e1 e2
-    same e1 (Cast e2 _) = same e1 e2
-
-    same e1 e2 = warnPprTrace (bad e1 || bad e2) "samePat" (ppr e1 $$ ppr e2) $
-                 False  -- Let, lambda, case should not occur
-    bad (Case {}) = True
-    bad (Let {})  = True
-    bad (Lam {})  = True
-    bad _other    = False
-
-{-
-Note [Ignore type differences]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not want to generate specialisations where the call patterns
-differ only in their type arguments!  Not only is it utterly useless,
-but it also means that (with polymorphic recursion) we can generate
-an infinite number of specialisations. Example is Data.Sequence.adjustTree,
-I think.
--}
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
deleted file mode 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ /dev/null
@@ -1,3429 +0,0 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-
-\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
--}
-
-module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-import GHC.Driver.Config
-import GHC.Driver.Config.Diagnostic
-import GHC.Driver.Config.Core.Rules ( initRuleOpts )
-
-import GHC.Core.Type  hiding( substTy, substCo, extendTvSubst, zapSubst )
-import GHC.Core.Multiplicity
-import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith )
-import GHC.Core.Predicate
-import GHC.Core.Coercion( Coercion )
-import GHC.Core.Opt.Monad
-import qualified GHC.Core.Subst as Core
-import GHC.Core.Unfold.Make
-import GHC.Core
-import GHC.Core.Make      ( mkLitRubbish )
-import GHC.Core.Unify     ( tcMatchTy )
-import GHC.Core.Rules
-import GHC.Core.Utils     ( exprIsTrivial
-                          , mkCast, exprType
-                          , stripTicksTop, mkInScopeSetBndrs )
-import GHC.Core.FVs
-import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
-import GHC.Core.Opt.Arity( collectBindersPushingCo )
-
-import GHC.Builtin.Types  ( unboxedUnitTy )
-
-import GHC.Data.Maybe     ( maybeToList, isJust )
-import GHC.Data.Bag
-import GHC.Data.OrdList
-import GHC.Data.List.SetOps
-
-import GHC.Types.Basic
-import GHC.Types.Unique.Supply
-import GHC.Types.Unique.DFM
-import GHC.Types.Name
-import GHC.Types.Tickish
-import GHC.Types.Id.Make  ( voidArgId, voidPrimId )
-import GHC.Types.Var      ( PiTyBinder(..), isLocalVar, isInvisibleFunArg )
-import GHC.Types.Var.Set
-import GHC.Types.Var.Env
-import GHC.Types.Id
-import GHC.Types.Error
-
-import GHC.Utils.Error ( mkMCDiagnostic )
-import GHC.Utils.Monad    ( foldlM )
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import GHC.Unit.Module( Module )
-import GHC.Unit.Module.ModGuts
-import GHC.Core.Unfold
-
-import Data.List.NonEmpty ( NonEmpty (..) )
-
-{-
-************************************************************************
-*                                                                      *
-\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}
-*                                                                      *
-************************************************************************
-
-These notes describe how we implement specialisation to eliminate
-overloading.
-
-The specialisation pass works on Core
-syntax, complete with all the explicit dictionary application,
-abstraction and construction as added by the type checker.  The
-existing type checker remains largely as it is.
-
-One important thought: the {\em types} passed to an overloaded
-function, and the {\em dictionaries} passed are mutually redundant.
-If the same function is applied to the same type(s) then it is sure to
-be applied to the same dictionary(s)---or rather to the same {\em
-values}.  (The arguments might look different but they will evaluate
-to the same value.)
-
-Second important thought: we know that we can make progress by
-treating dictionary arguments as static and worth specialising on.  So
-we can do without binding-time analysis, and instead specialise on
-dictionary arguments and no others.
-
-The basic idea
-~~~~~~~~~~~~~~
-Suppose we have
-
-        let f = <f_rhs>
-        in <body>
-
-and suppose f is overloaded.
-
-STEP 1: CALL-INSTANCE COLLECTION
-
-We traverse <body>, accumulating all applications of f to types and
-dictionaries.
-
-(Might there be partial applications, to just some of its types and
-dictionaries?  In principle yes, but in practice the type checker only
-builds applications of f to all its types and dictionaries, so partial
-applications could only arise as a result of transformation, and even
-then I think it's unlikely.  In any case, we simply don't accumulate such
-partial applications.)
-
-
-STEP 2: EQUIVALENCES
-
-So now we have a collection of calls to f:
-        f t1 t2 d1 d2
-        f t3 t4 d3 d4
-        ...
-Notice that f may take several type arguments.  To avoid ambiguity, we
-say that f is called at type t1/t2 and t3/t4.
-
-We take equivalence classes using equality of the *types* (ignoring
-the dictionary args, which as mentioned previously are redundant).
-
-STEP 3: SPECIALISATION
-
-For each equivalence class, choose a representative (f t1 t2 d1 d2),
-and create a local instance of f, defined thus:
-
-        f@t1/t2 = <f_rhs> t1 t2 d1 d2
-
-f_rhs presumably has some big lambdas and dictionary lambdas, so lots
-of simplification will now result.  However we don't actually *do* that
-simplification.  Rather, we leave it for the simplifier to do.  If we
-*did* do it, though, we'd get more call instances from the specialised
-RHS.  We can work out what they are by instantiating the call-instance
-set from f's RHS with the types t1, t2.
-
-Add this new id to f's IdInfo, to record that f has a specialised version.
-
-Before doing any of this, check that f's IdInfo doesn't already
-tell us about an existing instance of f at the required type/s.
-(This might happen if specialisation was applied more than once, or
-it might arise from user SPECIALIZE pragmas.)
-
-Recursion
-~~~~~~~~~
-Wait a minute!  What if f is recursive?  Then we can't just plug in
-its right-hand side, can we?
-
-But it's ok.  The type checker *always* creates non-recursive definitions
-for overloaded recursive functions.  For example:
-
-        f x = f (x+x)           -- Yes I know its silly
-
-becomes
-
-        f a (d::Num a) = let p = +.sel a d
-                         in
-                         letrec fl (y::a) = fl (p y y)
-                         in
-                         fl
-
-We still have recursion for non-overloaded functions which we
-specialise, but the recursive call should get specialised to the
-same recursive version.
-
-
-Polymorphism 1
-~~~~~~~~~~~~~~
-
-All this is crystal clear when the function is applied to *constant
-types*; that is, types which have no type variables inside.  But what if
-it is applied to non-constant types?  Suppose we find a call of f at type
-t1/t2.  There are two possibilities:
-
-(a) The free type variables of t1, t2 are in scope at the definition point
-of f.  In this case there's no problem, we proceed just as before.  A common
-example is as follows.  Here's the Haskell:
-
-        g y = let f x = x+x
-              in f y + f y
-
-After typechecking we have
-
-        g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
-                                in +.sel a d (f a d y) (f a d y)
-
-Notice that the call to f is at type type "a"; a non-constant type.
-Both calls to f are at the same type, so we can specialise to give:
-
-        g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
-                                in +.sel a d (f@a y) (f@a y)
-
-
-(b) The other case is when the type variables in the instance types
-are *not* in scope at the definition point of f.  The example we are
-working with above is a good case.  There are two instances of (+.sel a d),
-but "a" is not in scope at the definition of +.sel.  Can we do anything?
-Yes, we can "common them up", a sort of limited common sub-expression deal.
-This would give:
-
-        g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
-                                    f@a (x::a) = +.sel@a x x
-                                in +.sel@a (f@a y) (f@a y)
-
-This can save work, and can't be spotted by the type checker, because
-the two instances of +.sel weren't originally at the same type.
-
-Further notes on (b)
-
-* There are quite a few variations here.  For example, the defn of
-  +.sel could be floated outside the \y, to attempt to gain laziness.
-  It certainly mustn't be floated outside the \d because the d has to
-  be in scope too.
-
-* We don't want to inline f_rhs in this case, because
-that will duplicate code.  Just commoning up the call is the point.
-
-* Nothing gets added to +.sel's IdInfo.
-
-* Don't bother unless the equivalence class has more than one item!
-
-Not clear whether this is all worth it.  It is of course OK to
-simply discard call-instances when passing a big lambda.
-
-Polymorphism 2 -- Overloading
-~~~~~~~~~~~~~~
-Consider a function whose most general type is
-
-        f :: forall a b. Ord a => [a] -> b -> b
-
-There is really no point in making a version of g at Int/Int and another
-at Int/Bool, because it's only instantiating the type variable "a" which
-buys us any efficiency. Since g is completely polymorphic in b there
-ain't much point in making separate versions of g for the different
-b types.
-
-That suggests that we should identify which of g's type variables
-are constrained (like "a") and which are unconstrained (like "b").
-Then when taking equivalence classes in STEP 2, we ignore the type args
-corresponding to unconstrained type variable.  In STEP 3 we make
-polymorphic versions.  Thus:
-
-        f@t1/ = /\b -> <f_rhs> t1 b d1 d2
-
-We do this.
-
-
-Dictionary floating
-~~~~~~~~~~~~~~~~~~~
-Consider this
-
-        f a (d::Num a) = let g = ...
-                         in
-                         ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
-
-Here, g is only called at one type, but the dictionary isn't in scope at the
-definition point for g.  Usually the type checker would build a
-definition for d1 which enclosed g, but the transformation system
-might have moved d1's defn inward.  Solution: float dictionary bindings
-outwards along with call instances.
-
-Consider
-
-        f x = let g p q = p==q
-                  h r s = (r+s, g r s)
-              in
-              h x x
-
-
-Before specialisation, leaving out type abstractions we have
-
-        f df x = let g :: Eq a => a -> a -> Bool
-                     g dg p q = == dg p q
-                     h :: Num a => a -> a -> (a, Bool)
-                     h dh r s = let deq = eqFromNum dh
-                                in (+ dh r s, g deq r s)
-              in
-              h df x x
-
-After specialising h we get a specialised version of h, like this:
-
-                    h' r s = let deq = eqFromNum df
-                             in (+ df r s, g deq r s)
-
-But we can't naively make an instance for g from this, because deq is not in scope
-at the defn of g.  Instead, we have to float out the (new) defn of deq
-to widen its scope.  Notice that this floating can't be done in advance -- it only
-shows up when specialisation is done.
-
-User SPECIALIZE pragmas
-~~~~~~~~~~~~~~~~~~~~~~~
-Specialisation pragmas can be digested by the type checker, and implemented
-by adding extra definitions along with that of f, in the same way as before
-
-        f@t1/t2 = <f_rhs> t1 t2 d1 d2
-
-Indeed the pragmas *have* to be dealt with by the type checker, because
-only it knows how to build the dictionaries d1 and d2!  For example
-
-        g :: Ord a => [a] -> [a]
-        {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
-
-Here, the specialised version of g is an application of g's rhs to the
-Ord dictionary for (Tree Int), which only the type checker can conjure
-up.  There might not even *be* one, if (Tree Int) is not an instance of
-Ord!  (All the other specialisation has suitable dictionaries to hand
-from actual calls.)
-
-Problem.  The type checker doesn't have to hand a convenient <f_rhs>, because
-it is buried in a complex (as-yet-un-desugared) binding group.
-Maybe we should say
-
-        f@t1/t2 = f* t1 t2 d1 d2
-
-where f* is the Id f with an IdInfo which says "inline me regardless!".
-Indeed all the specialisation could be done in this way.
-That in turn means that the simplifier has to be prepared to inline absolutely
-any in-scope let-bound thing.
-
-
-Again, the pragma should permit polymorphism in unconstrained variables:
-
-        h :: Ord a => [a] -> b -> b
-        {-# SPECIALIZE h :: [Int] -> b -> b #-}
-
-We *insist* that all overloaded type variables are specialised to ground types,
-(and hence there can be no context inside a SPECIALIZE pragma).
-We *permit* unconstrained type variables to be specialised to
-        - a ground type
-        - or left as a polymorphic type variable
-but nothing in between.  So
-
-        {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
-
-is *illegal*.  (It can be handled, but it adds complication, and gains the
-programmer nothing.)
-
-
-SPECIALISING INSTANCE DECLARATIONS
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-        instance Foo a => Foo [a] where
-                ...
-        {-# SPECIALIZE instance Foo [Int] #-}
-
-The original instance decl creates a dictionary-function
-definition:
-
-        dfun.Foo.List :: forall a. Foo a -> Foo [a]
-
-The SPECIALIZE pragma just makes a specialised copy, just as for
-ordinary function definitions:
-
-        dfun.Foo.List@Int :: Foo [Int]
-        dfun.Foo.List@Int = dfun.Foo.List Int dFooInt
-
-The information about what instance of the dfun exist gets added to
-the dfun's IdInfo in the same way as a user-defined function too.
-
-
-Automatic instance decl specialisation?
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Can instance decls be specialised automatically?  It's tricky.
-We could collect call-instance information for each dfun, but
-then when we specialised their bodies we'd get new call-instances
-for ordinary functions; and when we specialised their bodies, we might get
-new call-instances of the dfuns, and so on.  This all arises because of
-the unrestricted mutual recursion between instance decls and value decls.
-
-Still, there's no actual problem; it just means that we may not do all
-the specialisation we could theoretically do.
-
-Furthermore, instance decls are usually exported and used non-locally,
-so we'll want to compile enough to get those specialisations done.
-
-Lastly, there's no such thing as a local instance decl, so we can
-survive solely by spitting out *usage* information, and then reading that
-back in as a pragma when next compiling the file.  So for now,
-we only specialise instance decls in response to pragmas.
-
-
-SPITTING OUT USAGE INFORMATION
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-To spit out usage information we need to traverse the code collecting
-call-instance information for all imported (non-prelude?) functions
-and data types. Then we equivalence-class it and spit it out.
-
-This is done at the top-level when all the call instances which escape
-must be for imported functions and data types.
-
-*** Not currently done ***
-
-
-Partial specialisation by pragmas
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What about partial specialisation:
-
-        k :: (Ord a, Eq b) => [a] -> b -> b -> [a]
-        {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}
-
-or even
-
-        {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}
-
-Seems quite reasonable.  Similar things could be done with instance decls:
-
-        instance (Foo a, Foo b) => Foo (a,b) where
-                ...
-        {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}
-        {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}
-
-Ho hum.  Things are complex enough without this.  I pass.
-
-
-Requirements for the simplifier
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The simplifier has to be able to take advantage of the specialisation.
-
-* When the simplifier finds an application of a polymorphic f, it looks in
-f's IdInfo in case there is a suitable instance to call instead.  This converts
-
-        f t1 t2 d1 d2   ===>   f_t1_t2
-
-Note that the dictionaries get eaten up too!
-
-* Dictionary selection operations on constant dictionaries must be
-  short-circuited:
-
-        +.sel Int d     ===>  +Int
-
-The obvious way to do this is in the same way as other specialised
-calls: +.sel has inside it some IdInfo which tells that if it's applied
-to the type Int then it should eat a dictionary and transform to +Int.
-
-In short, dictionary selectors need IdInfo inside them for constant
-methods.
-
-* Exactly the same applies if a superclass dictionary is being
-  extracted:
-
-        Eq.sel Int d   ===>   dEqInt
-
-* Something similar applies to dictionary construction too.  Suppose
-dfun.Eq.List is the function taking a dictionary for (Eq a) to
-one for (Eq [a]).  Then we want
-
-        dfun.Eq.List Int d      ===> dEq.List_Int
-
-Where does the Eq [Int] dictionary come from?  It is built in
-response to a SPECIALIZE pragma on the Eq [a] instance decl.
-
-In short, dfun Ids need IdInfo with a specialisation for each
-constant instance of their instance declaration.
-
-All this uses a single mechanism: the SpecEnv inside an Id
-
-
-What does the specialisation IdInfo look like?
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The SpecEnv of an Id maps a list of types (the template) to an expression
-
-        [Type]  |->  Expr
-
-For example, if f has this RuleInfo:
-
-        [Int, a]  ->  \d:Ord Int. f' a
-
-it means that we can replace the call
-
-        f Int t  ===>  (\d. f' t)
-
-This chucks one dictionary away and proceeds with the
-specialised version of f, namely f'.
-
-
-What can't be done this way?
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There is no way, post-typechecker, to get a dictionary for (say)
-Eq a from a dictionary for Eq [a].  So if we find
-
-        ==.sel [t] d
-
-we can't transform to
-
-        eqList (==.sel t d')
-
-where
-        eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
-
-Of course, we currently have no way to automatically derive
-eqList, nor to connect it to the Eq [a] instance decl, but you
-can imagine that it might somehow be possible.  Taking advantage
-of this is permanently ruled out.
-
-Still, this is no great hardship, because we intend to eliminate
-overloading altogether anyway!
-
-A note about non-tyvar dictionaries
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Some Ids have types like
-
-        forall a,b,c. Eq a -> Ord [a] -> tau
-
-This seems curious at first, because we usually only have dictionary
-args whose types are of the form (C a) where a is a type variable.
-But this doesn't hold for the functions arising from instance decls,
-which sometimes get arguments with types of form (C (T a)) for some
-type constructor T.
-
-Should we specialise wrt this compound-type dictionary?  We used to say
-"no", saying:
-        "This is a heuristic judgement, as indeed is the fact that we
-        specialise wrt only dictionaries.  We choose *not* to specialise
-        wrt compound dictionaries because at the moment the only place
-        they show up is in instance decls, where they are simply plugged
-        into a returned dictionary.  So nothing is gained by specialising
-        wrt them."
-
-But it is simpler and more uniform to specialise wrt these dicts too;
-and in future GHC is likely to support full fledged type signatures
-like
-        f :: Eq [(a,b)] => ...
-
-
-Note [Specialisation and overlapping instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here is at tricky case (see a comment in MR !8916):
-
-    module A where
-      class C a where
-        meth :: a -> String
-      instance {-# OVERLAPPABLE #-} C (Maybe a) where
-        meth _ = "Maybe"
-
-      {-# SPECIALISE f :: Maybe a -> Bool -> String #-}
-      f :: C a => a -> Bool -> String
-      f a True = f a False
-      f a _    = meth a
-
-    module B where
-      import A
-
-      instance C (Maybe Int) where
-        meth _ = "Int"
-
-      main = putStrLn $ f (Just 42 :: Maybe Int) True
-
-Running main without optimisations yields "Int", the correct answer.
-Activating optimisations yields "Maybe" due to a rewrite rule in module
-A generated by the SPECIALISE pragma:
-
-    RULE "USPEC f" forall a (d :: C a). f @a d = $sf
-
-In B we get the call (f @(Maybe Int) (d :: C (Maybe Int))), and
-that rewrites to $sf, but that isn't really right.
-
-Overlapping instances mean that `C (Maybe Int)` is not a singleton
-type: there two distinct dictionaries that have this type.  And that
-spells trouble for specialistion, which really asssumes singleton
-types.
-
-For now, we just accept this problem, but it may bite us one day.
-One solution would be to decline to expose any specialisation rules
-to an importing module -- but that seems a bit drastic.
-
-
-************************************************************************
-*                                                                      *
-\subsubsection{The new specialiser}
-*                                                                      *
-************************************************************************
-
-Our basic game plan is this.  For let(rec) bound function
-        f :: (C a, D c) => (a,b,c,d) -> Bool
-
-* Find any specialised calls of f, (f ts ds), where
-  ts are the type arguments t1 .. t4, and
-  ds are the dictionary arguments d1 .. d2.
-
-* Add a new definition for f1 (say):
-
-        f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2
-
-  Note that we abstract over the unconstrained type arguments.
-
-* Add the mapping
-
-        [t1,b,t3,d]  |->  \d1 d2 -> f1 b d
-
-  to the specialisations of f.  This will be used by the
-  simplifier to replace calls
-                (f t1 t2 t3 t4) da db
-  by
-                (\d1 d1 -> f1 t2 t4) da db
-
-  All the stuff about how many dictionaries to discard, and what types
-  to apply the specialised function to, are handled by the fact that the
-  SpecEnv contains a template for the result of the specialisation.
-
-We don't build *partial* specialisations for f.  For example:
-
-  f :: Eq a => a -> a -> Bool
-  {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-}
-
-Here, little is gained by making a specialised copy of f.
-There's a distinct danger that the specialised version would
-first build a dictionary for (Eq b, Eq c), and then select the (==)
-method from it!  Even if it didn't, not a great deal is saved.
-
-We do, however, generate polymorphic, but not overloaded, specialisations:
-
-  f :: Eq a => [a] -> b -> b -> b
-  ... SPECIALISE f :: [Int] -> b -> b -> b ...
-
-Hence, the invariant is this:
-
-        *** no specialised version is overloaded ***
-
-
-************************************************************************
-*                                                                      *
-\subsubsection{The exported function}
-*                                                                      *
-************************************************************************
--}
-
--- | Specialise calls to type-class overloaded functions occurring in a program.
-specProgram :: ModGuts -> CoreM ModGuts
-specProgram guts@(ModGuts { mg_module = this_mod
-                          , mg_rules  = local_rules
-                          , mg_binds  = binds })
-  = do { dflags   <- getDynFlags
-       ; rule_env <- initRuleEnv guts
-                     -- See Note [Fire rules in the specialiser]
-
-              -- We need to start with a Subst that knows all the things
-              -- that are in scope, so that the substitution engine doesn't
-              -- accidentally re-use a unique that's already in use
-              -- Easiest thing is to do it all at once, as if all the top-level
-              -- decls were mutually recursive
-       ; let top_env = SE { se_subst = Core.mkEmptySubst $
-                                        mkInScopeSetBndrs binds
-                                      --    mkInScopeSetList $
-                                      --  bindersOfBinds binds
-                          , se_module = this_mod
-                          , se_rules  = rule_env
-                          , se_dflags = dflags }
-
-             go []           = return ([], emptyUDs)
-             go (bind:binds) = do (bind', binds', uds') <- specBind TopLevel top_env bind $ \_ ->
-                                                           go binds
-                                  return (bind' ++ binds', uds')
-
-             -- Specialise the bindings of this module
-       ; (binds', uds) <- runSpecM (go binds)
-
-       ; (spec_rules, spec_binds) <- specImports top_env uds
-
-       ; return (guts { mg_binds = spec_binds ++ binds'
-                      , mg_rules = spec_rules ++ local_rules }) }
-
-{-
-Note [Wrap bindings returned by specImports]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-'specImports' returns a set of specialized bindings. However, these are lacking
-necessary floated dictionary bindings, which are returned by
-UsageDetails(ud_binds). These dictionaries need to be brought into scope with
-'wrapDictBinds' before the bindings returned by 'specImports' can be used. See,
-for instance, the 'specImports' call in 'specProgram'.
-
-
-Note [Disabling cross-module specialisation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Since GHC 7.10 we have performed specialisation of INLINABLE bindings living
-in modules outside of the current module. This can sometimes uncover user code
-which explodes in size when aggressively optimized. The
--fno-cross-module-specialise option was introduced to allow users to being
-bitten by such instances to revert to the pre-7.10 behavior.
-
-See #10491
--}
-
-
-{- *********************************************************************
-*                                                                      *
-                   Specialising imported functions
-*                                                                      *
-********************************************************************* -}
-
-{- Note [Specialising imported functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-specImports specialises imported functions, based on calls in this module.
-
-When -fspecialise-aggressively is on, we specialise any imported
-function for which we have an unfolding.  The
--fspecialise-aggressively flag is usually off, because we risk lots of
-orphan modules from over-vigorous specialisation.  (See Note [Orphans]
-in GHC.Core.) However it's not a big deal: anything non-recursive with
-an unfolding-template will probably have been inlined already.
-
-When -fspecialise-aggressively is off, we are more selective about
-specialisation (see canSpecImport):
-
-(1) Without -fspecialise-aggressively, do not specialise
-    DFunUnfoldings. Note [Do not specialise imported DFuns].
-
-(2) Without -fspecialise-aggressively, specialise only imported things
-    that have a /user-supplied/ INLINE or INLINABLE pragma (hence
-    isAnyInlinePragma rather than isStableSource).
-
-    In particular, we don't want to specialise workers created by
-    worker/wrapper (for functions with no pragma) because they won't
-    specialise usefully, and they generate quite a bit of useless code
-    bloat.
-
-    Specialise even INLINE things; it hasn't inlined yet, so perhaps
-    it never will.  Moreover it may have calls inside it that we want
-    to specialise
--}
-
-specImports :: SpecEnv
-            -> UsageDetails
-            -> CoreM ([CoreRule], [CoreBind])
-specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls })
-  | not $ gopt Opt_CrossModuleSpecialise (se_dflags top_env)
-    -- See Note [Disabling cross-module specialisation]
-  = return ([], wrapDictBinds dict_binds [])
-
-  | otherwise
-  = do { (_env, spec_rules, spec_binds) <- spec_imports top_env [] dict_binds calls
-
-             -- Don't forget to wrap the specialized bindings with
-             -- bindings for the needed dictionaries.
-             -- See Note [Wrap bindings returned by specImports]
-             -- and Note [Glom the bindings if imported functions are specialised]
-       ; let final_binds
-               | null spec_binds = wrapDictBinds dict_binds []
-               | otherwise       = [Rec $ flattenBinds $
-                                    wrapDictBinds dict_binds spec_binds]
-
-       ; return (spec_rules, final_binds)
-    }
-
--- | Specialise a set of calls to imported bindings
-spec_imports :: SpecEnv          -- Passed in so that all top-level Ids are in scope
-             -> [Id]             -- Stack of imported functions being specialised
-                                 -- See Note [specImport call stack]
-             -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls
-                                 -- See Note [Avoiding loops in specImports]
-             -> CallDetails      -- Calls for imported things
-             -> CoreM ( SpecEnv      -- Env contains the new rules
-                      , [CoreRule]   -- New rules
-                      , [CoreBind] ) -- Specialised bindings
-spec_imports env callers dict_binds calls
-  = do { let import_calls = dVarEnvElts calls
---       ; debugTraceMsg (text "specImports {" <+>
---                         vcat [ text "calls:" <+> ppr import_calls
---                              , text "dict_binds:" <+> ppr dict_binds ])
-       ; (env, rules, spec_binds) <- go env import_calls
---       ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)
-
-       ; return (env, rules, spec_binds) }
-  where
-    go :: SpecEnv -> [CallInfoSet] -> CoreM (SpecEnv, [CoreRule], [CoreBind])
-    go env [] = return (env, [], [])
-    go env (cis : other_calls)
-      = do { -- debugTraceMsg (text "specImport {" <+> ppr cis)
-           ; (env, rules1, spec_binds1) <- spec_import env callers dict_binds cis
-           ; -- debugTraceMsg (text "specImport }" <+> ppr cis)
-
-           ; (env, rules2, spec_binds2) <- go env other_calls
-           ; return (env, rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
-
-spec_import :: SpecEnv               -- Passed in so that all top-level Ids are in scope
-            -> [Id]                  -- Stack of imported functions being specialised
-                                     -- See Note [specImport call stack]
-            -> FloatedDictBinds      -- Dict bindings, used /only/ for filterCalls
-                                     -- See Note [Avoiding loops in specImports]
-            -> CallInfoSet           -- Imported function and calls for it
-            -> CoreM ( SpecEnv
-                     , [CoreRule]    -- New rules
-                     , [CoreBind] )  -- Specialised bindings
-spec_import env callers dict_binds cis@(CIS fn _)
-  | isIn "specImport" fn callers
-  = return (env, [], [])  -- No warning.  This actually happens all the time
-                          -- when specialising a recursive function, because
-                          -- the RHS of the specialised function contains a recursive
-                          -- call to the original function
-
-  | null good_calls
-  = return (env, [], [])
-
-  | Just rhs <- canSpecImport dflags fn
-  = do {     -- Get rules from the external package state
-             -- We keep doing this in case we "page-fault in"
-             -- more rules as we go along
-       ; eps_rules <- getExternalRuleBase
-       ; let rule_env = se_rules env `updExternalPackageRules` eps_rules
-
---       ; debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls
---                                                    , ppr (getRules rule_env fn), ppr rhs])
-       ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })
-            <- runSpecM $ specCalls True env dict_binds
-                                    (getRules rule_env fn) good_calls fn rhs
-
-       ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
-             -- After the rules kick in we may get recursion, but
-             -- we rely on a global GlomBinds to sort that out later
-             -- See Note [Glom the bindings if imported functions are specialised]
-
-             new_subst = se_subst env `Core.extendSubstInScopeList` map fst spec_pairs
-             new_env   = env { se_rules = rule_env `addLocalRules` rules1
-                             , se_subst = new_subst }
-
-              -- Now specialise any cascaded calls
---       ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))
-       ; (env, rules2, spec_binds2)
-            <- spec_imports new_env (fn:callers)
-                                    (dict_binds `thenFDBs` dict_binds1)
-                                    new_calls
-
-       ; let final_binds = wrapDictBinds dict_binds1 $
-                           spec_binds2 ++ spec_binds1
-
-       ; return (env, rules2 ++ rules1, final_binds) }
-
-  | otherwise
-  = do { tryWarnMissingSpecs dflags callers fn good_calls
-       ; return (env, [], [])}
-
-  where
-    dflags = se_dflags env
-    good_calls = filterCalls cis dict_binds
-       -- SUPER IMPORTANT!  Drop calls that (directly or indirectly) refer to fn
-       -- See Note [Avoiding loops in specImports]
-
-canSpecImport :: DynFlags -> Id -> Maybe CoreExpr
-canSpecImport dflags fn
-  | isDataConWrapId fn
-  = Nothing   -- Don't specialise data-con wrappers, even if they
-              -- have dict args; there is no benefit.
-
-  | CoreUnfolding { uf_tmpl = rhs } <- unf
-    -- CoreUnfolding: see Note [Specialising imported functions] point (1).
-  , isAnyInlinePragma (idInlinePragma fn)
-    -- See Note [Specialising imported functions] point (2).
-  = Just rhs
-
-  | gopt Opt_SpecialiseAggressively dflags
-  = maybeUnfoldingTemplate unf
-    -- With -fspecialise-aggressively, specialise anything
-    -- with an unfolding, stable or not, DFun or not
-
-  | otherwise = Nothing
-  where
-    unf = realIdUnfolding fn   -- We want to see the unfolding even for loop breakers
-
--- | Returns whether or not to show a missed-spec warning.
--- If -Wall-missed-specializations is on, show the warning.
--- Otherwise, if -Wmissed-specializations is on, only show a warning
--- if there is at least one imported function being specialized,
--- and if all imported functions are marked with an inline pragma
--- Use the most specific warning as the reason.
-tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()
--- See Note [Warning about missed specialisations]
-tryWarnMissingSpecs dflags callers fn calls_for_fn
-  | isClassOpId fn = return () -- See Note [Missed specialisation for ClassOps]
-  | wopt Opt_WarnMissedSpecs dflags
-    && not (null callers)
-    && allCallersInlined                  = doWarn $ WarningWithFlag Opt_WarnMissedSpecs
-  | wopt Opt_WarnAllMissedSpecs dflags    = doWarn $ WarningWithFlag Opt_WarnAllMissedSpecs
-  | otherwise                             = return ()
-  where
-    allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers
-    diag_opts = initDiagOpts dflags
-    doWarn reason =
-      msg (mkMCDiagnostic diag_opts reason Nothing)
-        (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))
-                2 (vcat [ text "when specialising" <+> quotes (ppr caller)
-                        | caller <- callers])
-          , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))
-          , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])
-
-{- Note [Missed specialisation for ClassOps]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In #19592 I saw a number of missed specialisation warnings
-which were the result of things like:
-
-    case isJumpishInstr @X86.Instr $dInstruction_s7f8 eta3_a78C of { ...
-
-where isJumpishInstr is part of the Instruction class and defined like
-this:
-
-    class Instruction instr where
-        ...
-        isJumpishInstr :: instr -> Bool
-        ...
-
-isJumpishInstr is a ClassOp which will select the right method
-from within the dictionary via our built in rules. See also
-Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance.
-
-We don't give these unfoldings, and as a result the specialiser
-complains. But usually this doesn't matter. The simplifier will
-apply the rule and we end up with
-
-    case isJumpishInstrImplX86 eta3_a78C of { ...
-
-Since isJumpishInstrImplX86 is defined for a concrete instance (given
-by the dictionary) it is usually already well specialised!
-Theoretically the implementation of a method could still be overloaded
-over a different type class than what it's a method of. But I wasn't able
-to make this go wrong, and SPJ thinks this should be fine as well.
-
-So I decided to remove the warnings for failed specialisations on ClassOps
-alltogether as they do more harm than good.
--}
-
-{- Note [Do not specialise imported DFuns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Ticket #18223 shows that specialising calls of DFuns is can cause a huge
-and entirely unnecessary blowup in program size.  Consider a call to
-    f @[[[[[[[[T]]]]]]]] d1 x
-where df :: C a => C [a]
-      d1 :: C [[[[[[[[T]]]]]]]] = dfC[] @[[[[[[[T]]]]]]] d1
-      d2 :: C [[[[[[[T]]]]]]]   = dfC[] @[[[[[[T]]]]]] d3
-      ...
-Now we'll specialise f's RHS, which may give rise to calls to 'g',
-also overloaded, which we will specialise, and so on.  However, if
-we specialise the calls to dfC[], we'll generate specialised copies of
-all methods of C, at all types; and the same for C's superclasses.
-
-And many of these specialised functions will never be called.  We are
-going to call the specialised 'f', and the specialised 'g', but DFuns
-group functions into a tuple, many of whose elements may never be used.
-
-With deeply-nested types this can lead to a simply overwhelming number
-of specialisations: see #18223 for a simple example (from the wild).
-I measured the number of specialisations for various numbers of calls
-of `flip evalStateT ()`, and got this
-
-                       Size after one simplification
-  #calls    #SPEC rules    Terms     Types
-      5         56          3100     10600
-      9        108         13660     77206
-
-The real tests case has 60+ calls, which blew GHC out of the water.
-
-Solution: don't specialise DFuns.  The downside is that if we end
-up with (h (dfun d)), /and/ we don't specialise 'h', then we won't
-pass to 'h' a tuple of specialised functions.
-
-However, the flag -fspecialise-aggressively (experimental, off by default)
-allows DFuns to specialise as well.
-
-Note [Avoiding loops in specImports]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must take great care when specialising instance declarations
-(DFuns like $fOrdList) lest we accidentally build a recursive
-dictionary. See Note [Avoiding loops (DFuns)].
-
-The basic strategy of Note [Avoiding loops (DFuns)] is to use filterCalls
-to discard loopy specialisations.  But to do that we must ensure
-that the in-scope dict-binds (passed to filterCalls) contains
-all the needed dictionary bindings.  In particular, in the recursive
-call to spec_imports in spec_import, we must include the dict-binds
-from the parent.  Lacking this caused #17151, a really nasty bug.
-
-Here is what happened.
-* Class structure:
-    Source is a superclass of Mut
-    Index is a superclass of Source
-
-* We started with these dict binds
-    dSource = $fSourcePix @Int $fIndexInt
-    dIndex  = sc_sel dSource
-    dMut    = $fMutPix @Int dIndex
-  and these calls to specialise
-    $fMutPix @Int dIndex
-    $fSourcePix @Int $fIndexInt
-
-* We specialised the call ($fMutPix @Int dIndex)
-  ==> new call ($fSourcePix @Int dIndex)
-      (because Source is a superclass of Mut)
-
-* We specialised ($fSourcePix @Int dIndex)
-  ==> produces specialised dict $s$fSourcePix,
-      a record with dIndex as a field
-      plus RULE forall d. ($fSourcePix @Int d) = $s$fSourcePix
-  *** This is the bogus step ***
-
-* Now we decide not to specialise the call
-    $fSourcePix @Int $fIndexInt
-  because we alredy have a RULE that matches it
-
-* Finally the simplifer rewrites
-    dSource = $fSourcePix @Int $fIndexInt
-    ==>  dSource = $s$fSourcePix
-
-Disaster. Now we have
-
-Rewrite dSource's RHS to $s$fSourcePix   Disaster
-    dSource = $s$fSourcePix
-    dIndex  = sc_sel dSource
-    $s$fSourcePix = MkSource dIndex ...
-
-Solution: filterCalls should have stopped the bogus step,
-by seeing that dIndex transitively uses $fSourcePix. But
-it can only do that if it sees all the dict_binds.  Wow.
-
---------------
-Here's another example (#13429).  Suppose we have
-  class Monoid v => C v a where ...
-
-We start with a call
-   f @ [Integer] @ Integer $fC[]Integer
-
-Specialising call to 'f' gives dict bindings
-   $dMonoid_1 :: Monoid [Integer]
-   $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer
-
-   $dC_1 :: C [Integer] (Node [Integer] Integer)
-   $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1
-
-...plus a recursive call to
-   f @ [Integer] @ (Node [Integer] Integer) $dC_1
-
-Specialising that call gives
-   $dMonoid_2  :: Monoid [Integer]
-   $dMonoid_2  = M.$p1C @ [Integer] $dC_1
-
-   $dC_2 :: C [Integer] (Node [Integer] Integer)
-   $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2
-
-Now we have two calls to the imported function
-  M.$fCvNode :: Monoid v => C v a
-  M.$fCvNode @v @a m = C m some_fun
-
-But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2)
-for specialisation, else we get:
-
-  $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1
-  $dMonoid_2 = M.$p1C @ [Integer] $dC_1
-  $s$fCvNode = C $dMonoid_2 ...
-    RULE M.$fCvNode [Integer] _ _ = $s$fCvNode
-
-Now use the rule to rewrite the call in the RHS of $dC_1
-and we get a loop!
-
-
-Note [specImport call stack]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When specialising an imports function 'f', we may get new calls
-of an imported function 'g', which we want to specialise in turn,
-and similarly specialising 'g' might expose a new call to 'h'.
-
-We track the stack of enclosing functions. So when specialising 'h' we
-have a specImport call stack of [g,f]. We do this for two reasons:
-* Note [Warning about missed specialisations]
-* Note [Avoiding recursive specialisation]
-
-Note [Warning about missed specialisations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose
- * In module Lib, you carefully mark a function 'foo' INLINABLE
- * Import Lib(foo) into another module M
- * Call 'foo' at some specialised type in M
-Then you jolly well expect it to be specialised in M.  But what if
-'foo' calls another function 'Lib.bar'.  Then you'd like 'bar' to be
-specialised too.  But if 'bar' is not marked INLINABLE it may well
-not be specialised.  The warning Opt_WarnMissedSpecs warns about this.
-
-It's more noisy to warning about a missed specialisation opportunity
-for /every/ overloaded imported function, but sometimes useful. That
-is what Opt_WarnAllMissedSpecs does.
-
-ToDo: warn about missed opportunities for local functions.
-
-Note [Avoiding recursive specialisation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we specialise 'f' we may find new overloaded calls to 'g', 'h' in
-'f's RHS.  So we want to specialise g,h.  But we don't want to
-specialise f any more!  It's possible that f's RHS might have a
-recursive yet-more-specialised call, so we'd diverge in that case.
-And if the call is to the same type, one specialisation is enough.
-Avoiding this recursive specialisation loop is one reason for the
-'callers' stack passed to specImports and specImport.
-
-Note [Glom the bindings if imported functions are specialised]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have an imported, *recursive*, INLINABLE function
-   f :: Eq a => a -> a
-   f = /\a \d x. ...(f a d)...
-In the module being compiled we have
-   g x = f (x::Int)
-Now we'll make a specialised function
-   f_spec :: Int -> Int
-   f_spec = \x -> ...(f Int dInt)...
-   {-# RULE  f Int _ = f_spec #-}
-   g = \x. f Int dInt x
-Note that f_spec doesn't look recursive
-After rewriting with the RULE, we get
-   f_spec = \x -> ...(f_spec)...
-BUT since f_spec was non-recursive before it'll *stay* non-recursive.
-The occurrence analyser never turns a NonRec into a Rec.  So we must
-make sure that f_spec is recursive.  Easiest thing is to make all
-the specialisations for imported bindings recursive.
-
-
-
-************************************************************************
-*                                                                      *
-\subsubsection{@specExpr@: the main function}
-*                                                                      *
-************************************************************************
--}
-
-data SpecEnv
-  = SE { se_subst :: Core.Subst
-             -- We carry a substitution down:
-             -- a) we must clone any binding that might float outwards,
-             --    to avoid name clashes
-             -- b) we carry a type substitution to use when analysing
-             --    the RHS of specialised bindings (no type-let!)
-
-       , se_module :: Module
-       , se_rules  :: RuleEnv  -- From the home package and this module
-       , se_dflags :: DynFlags
-     }
-
-instance Outputable SpecEnv where
-  ppr (SE { se_subst = subst })
-    = text "SE" <+> braces (text "subst =" <+> ppr subst)
-
-specVar :: SpecEnv -> InId -> SpecM (OutExpr, UsageDetails)
-specVar env@(SE { se_subst = Core.Subst in_scope ids _ _ }) v
-  | not (isLocalId v)                   = return (Var v, emptyUDs)
-  | Just e  <- lookupVarEnv ids       v = specExpr (zapSubst env) e  -- Note (1)
-  | Just v' <- lookupInScope in_scope v = return (Var v', emptyUDs)
-  | otherwise = pprPanic "specVar" (ppr v $$ ppr in_scope)
-  -- c.f. GHC.Core.Subst.lookupIdSubst
-  -- Note (1): we recurse so we do the lookupInScope thing on any Vars in e
-  --           probably has little effect, but it's the right thing.
-  --           We need zapSubst because `e` is an OutExpr
-
-specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
-
----------------- First the easy cases --------------------
-specExpr env (Var v)       = specVar env v
-specExpr env (Type ty)     = return (Type     (substTy env ty), emptyUDs)
-specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs)
-specExpr _   (Lit lit)     = return (Lit lit,                   emptyUDs)
-specExpr env (Cast e co)
-  = do { (e', uds) <- specExpr env e
-       ; return ((mkCast e' (substCo env co)), uds) }
-specExpr env (Tick tickish body)
-  = do { (body', uds) <- specExpr env body
-       ; return (Tick (specTickish env tickish) body', uds) }
-
----------------- Applications might generate a call instance --------------------
-specExpr env expr@(App {})
-  = do { let (fun_in, args_in) = collectArgs expr
-       ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in
-       ; let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_args
-                -- Some dicts may have floated out of args_in;
-                -- they should be in scope for fireRewriteRules (#21689)
-             (fun_in', args_out') = fireRewriteRules env_args fun_in args_out
-       ; (fun_out', uds_fun) <- specExpr env fun_in'
-       ; let uds_call = mkCallUDs env fun_out' args_out'
-       ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) }
-
----------------- Lambda/case require dumping of usage details --------------------
-specExpr env e@(Lam {})
-  = specLam env' bndrs' body
-  where
-    (bndrs, body)  = collectBinders e
-    (env', bndrs') = substBndrs env bndrs
-        -- More efficient to collect a group of binders together all at once
-        -- and we don't want to split a lambda group with dumped bindings
-
-specExpr env (Case scrut case_bndr ty alts)
-  = do { (scrut', scrut_uds) <- specExpr env scrut
-       ; (scrut'', case_bndr', alts', alts_uds)
-             <- specCase env scrut' case_bndr alts
---       ; pprTrace "specExpr:case" (vcat
---            [ text "scrut" <+> ppr scrut, text "scrut'" <+> ppr scrut'
---            , text "case_bndr'" <+> ppr case_bndr'
---            , text "alts_uds" <+> ppr alts_uds
---            ])
-       ; return (Case scrut'' case_bndr' (substTy env ty) alts'
-                , scrut_uds `thenUDs` alts_uds) }
-
----------------- Finally, let is the interesting case --------------------
-specExpr env (Let bind body)
-  = do { (binds', body', uds) <- specBind NotTopLevel env bind $ \body_env ->
-                                 -- pprTrace "specExpr:let" (ppr (se_subst body_env) $$ ppr body) $
-                                 specExpr body_env body
-         -- All done
-       ; return (foldr Let body' binds', uds) }
-
--- See Note [Specialisation modulo dictionary selectors]
---     Note [ClassOp/DFun selection]
---     Note [Fire rules in the specialiser]
-fireRewriteRules :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr])
-fireRewriteRules env (Var f) args
-  | Just (rule, expr) <- specLookupRule env f args InitialPhase (getRules (se_rules env) f)
-  , let rest_args    = drop (ruleArity rule) args -- See Note [Extra args in the target]
-        zapped_subst = Core.zapSubst (se_subst env)
-        expr'        = simpleOptExprWith defaultSimpleOpts zapped_subst expr
-                       -- simplOptExpr needed because lookupRule returns
-                       --   (\x y. rhs) arg1 arg2
-  , (fun, args) <- collectArgs expr'
-  = fireRewriteRules env fun (args++rest_args)
-fireRewriteRules _ fun args = (fun, args)
-
---------------
-specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails)
--- The binders have been substituted, but the body has not
-specLam env bndrs body
-  | null bndrs
-  = specExpr env body
-  | otherwise
-  = do { (body', uds) <- specExpr env body
-       ; let (free_uds, dumped_dbs) = dumpUDs bndrs uds
-       ; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) }
-
---------------
-specTickish :: SpecEnv -> CoreTickish -> CoreTickish
-specTickish (SE { se_subst = subst }) (Breakpoint ext ix ids)
-  = Breakpoint ext ix [ id' | id <- ids, Var id' <- [Core.lookupIdSubst subst id]]
-  -- drop vars from the list if they have a non-variable substitution.
-  -- should never happen, but it's harmless to drop them anyway.
-specTickish _ other_tickish = other_tickish
-
---------------
-specCase :: SpecEnv
-         -> OutExpr             -- Scrutinee, already done
-         -> InId -> [InAlt]
-         -> SpecM ( OutExpr     -- New scrutinee
-                  , OutId
-                  , [OutAlt]
-                  , UsageDetails)
-specCase env scrut' case_bndr [Alt con args rhs]
-  | -- See Note [Floating dictionaries out of cases]
-    interestingDict scrut' (idType case_bndr)
-  , not (isDeadBinder case_bndr && null sc_args')
-  = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args')
-
-       ; let case_bndr_flt' = case_bndr_flt `addDictUnfolding` scrut'
-             scrut_bind     = mkDB (NonRec case_bndr_flt scrut')
-
-             sc_args_flt' = zipWith addDictUnfolding sc_args_flt sc_rhss
-             sc_rhss      = [ Case (Var case_bndr_flt') case_bndr' (idType sc_arg')
-                                   [Alt con args' (Var sc_arg')]
-                            | sc_arg' <- sc_args' ]
-             cb_set       = unitVarSet case_bndr_flt'
-             sc_binds     = [ DB { db_bind = NonRec sc_arg_flt sc_rhs, db_fvs  = cb_set }
-                            | (sc_arg_flt, sc_rhs) <- sc_args_flt' `zip` sc_rhss ]
-
-             flt_binds    = scrut_bind : sc_binds
-
-             -- Extend the substitution for RHS to map the *original* binders
-             -- to their floated versions.
-             mb_sc_flts :: [Maybe DictId]
-             mb_sc_flts = map (lookupVarEnv clone_env) args'
-             clone_env  = zipVarEnv sc_args' sc_args_flt'
-
-             subst_prs  = (case_bndr, Var case_bndr_flt)
-                        : [ (arg, Var sc_flt)
-                          | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]
-             subst'   = se_subst env_rhs
-                        `Core.extendSubstInScopeList` (case_bndr_flt' : sc_args_flt')
-                        `Core.extendIdSubstList`      subst_prs
-             env_rhs' = env_rhs { se_subst = subst' }
-
-       ; (rhs', rhs_uds)   <- specExpr env_rhs' rhs
-       ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds
-             all_uds = flt_binds `consDictBinds` free_uds
-             alt'    = Alt con args' (wrapDictBindsE dumped_dbs rhs')
---       ; pprTrace "specCase" (ppr case_bndr $$ ppr scrut_bind) $
-       ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
-  where
-    (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args)
-    sc_args' = filter is_flt_sc_arg args'
-
-    clone_me bndr = do { uniq <- getUniqueM
-                       ; return (mkUserLocalOrCoVar occ uniq wght ty loc) }
-       where
-         name = idName bndr
-         wght = idMult bndr
-         ty   = idType bndr
-         occ  = nameOccName name
-         loc  = getSrcSpan name
-
-    arg_set = mkVarSet args'
-    is_flt_sc_arg var =  isId var
-                      && not (isDeadBinder var)
-                      && isDictTy var_ty
-                      && tyCoVarsOfType var_ty `disjointVarSet` arg_set
-       where
-         var_ty = idType var
-
-
-specCase env scrut case_bndr alts
-  = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts
-       ; return (scrut, case_bndr', alts', uds_alts) }
-  where
-    (env_alt, case_bndr') = substBndr env case_bndr
-    spec_alt (Alt con args rhs)
-      = do { (rhs', uds) <- specExpr env_rhs rhs
-           ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds
---           ; unless (isNilOL dumped_dbs) $
---             pprTrace "specAlt" (vcat
---                 [text "case_bndr', args" <+> (ppr case_bndr' $$ ppr args)
---                 ,text "dumped" <+> ppr dumped_dbs ]) return ()
-           ; return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds) }
-        where
-          (env_rhs, args') = substBndrs env_alt args
-
-{- Note [Fire rules in the specialiser]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this (#21851)
-
-    module A where
-      f :: Num b => b -> (b, b)
-      f x = (x + 1, snd (f x))
-      {-# SPECIALIZE f :: Int -> (Int, Int) #-}
-
-    module B (g') where
-      import A
-
-      g :: Num a => a -> a
-      g x = fst (f x)
-      {-# NOINLINE[99] g #-}
-
-      h :: Int -> Int
-      h = g
-
-Note that `f` has the CPR property, and so will worker/wrapper.
-
-The call to `g` in `h` will make us specialise `g @Int`. And the specialised
-version of `g` will contain the call `f @Int`; but in the subsequent run of
-the Simplifier, there will be a competition between:
-* The user-supplied SPECIALISE rule for `f`
-* The inlining of the wrapper for `f`
-In fact, the latter wins -- see Note [Rewrite rules and inlining] in
-GHC.Core.Opt.Simplify.Iteration.  However, it a bit fragile.
-
-Moreover consider (test T21851_2):
-
-    module A
-      f :: (Ord a, Show b) => a -> b -> blah
-      {-# RULE forall b. f @Int @b = wombat #-}
-
-      wombat :: Show b => Int -> b -> blah
-      wombat = blah
-
-    module B
-      import A
-      g :: forall a. Ord a => blah
-      g @a = ...g...f @a @Char....
-
-      h = ....g @Int....
-
-Now, in module B, GHC will specialise `g @Int`, which will lead to a
-call `f @Int @Char`.  If we immediately (in the specialiser) rewrite
-that to `womabat @Char`, we have a chance to specialise `wombat`.
-
-Conclusion: it's treat if the Specialiser fires RULEs itself.
-It's not hard to achieve: see `fireRewriteRules`. The only tricky bit is
-making sure that we have a reasonably up to date EPS rule base. Currently
-we load it up just once, in `initRuleEnv`, called at the beginning of
-`specProgram`.
-
-NB: you might wonder if running rules in the specialiser (this Note)
-renders Note [Rewrite rules and inlining] in the Simplifier redundant.
-That is, if we run rules in the specialiser, does it matter if we make
-rules "win" over inlining in the Simplifier?  Yes, it does!  See the
-discussion in #21851.
-
-Note [Floating dictionaries out of cases]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   g = \d. case d of { MkD sc ... -> ...(f sc)... }
-Naively we can't float d2's binding out of the case expression,
-because 'sc' is bound by the case, and that in turn means we can't
-specialise f, which seems a pity.
-
-So we invert the case, by floating out a binding
-for 'sc_flt' thus:
-    sc_flt = case d of { MkD sc ... -> sc }
-Now we can float the call instance for 'f'.  Indeed this is just
-what'll happen if 'sc' was originally bound with a let binding,
-but case is more efficient, and necessary with equalities. So it's
-good to work with both.
-
-You might think that this won't make any difference, because the
-call instance will only get nuked by the \d.  BUT if 'g' itself is
-specialised, then transitively we should be able to specialise f.
-
-In general, given
-   case e of cb { MkD sc ... -> ...(f sc)... }
-we transform to
-   let cb_flt = e
-       sc_flt = case cb_flt of { MkD sc ... -> sc }
-   in
-   case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... }
-
-The "_flt" things are the floated binds; we use the current substitution
-to substitute sc -> sc_flt in the RHS
-
-************************************************************************
-*                                                                      *
-                     Dealing with a binding
-*                                                                      *
-************************************************************************
--}
-
-bringFloatedDictsIntoScope :: SpecEnv -> FloatedDictBinds -> SpecEnv
-bringFloatedDictsIntoScope env (FDB { fdb_bndrs = dx_bndrs })
-  = -- pprTrace "brought into scope" (ppr dx_bndrs) $
-    env {se_subst=subst'}
-  where
-   subst' = se_subst env `Core.extendSubstInScopeSet` dx_bndrs
-
-specBind :: TopLevelFlag
-         -> SpecEnv    -- At top-level only, this env already has the
-                       -- top level binders in scope
-         -> InBind
-         -> (SpecEnv -> SpecM (body, UsageDetails))    -- Process the body
-         -> SpecM ( [OutBind]           -- New bindings
-                  , body                -- Body
-                  , UsageDetails)       -- And info to pass upstream
-
--- Returned UsageDetails:
---    No calls for binders of this bind
-specBind top_lvl env (NonRec fn rhs) do_body
-  = do { (rhs', rhs_uds) <- specExpr env rhs
-
-       ; (body_env1, fn1) <- case top_lvl of
-                               TopLevel    -> return (env, fn)
-                               NotTopLevel -> cloneBndrSM env fn
-
-       ; let fn2 | isStableUnfolding (idUnfolding fn1) = fn1
-                 | otherwise = fn1 `setIdUnfolding` mkSimpleUnfolding defaultUnfoldingOpts rhs'
-             -- Update the unfolding with the perhaps-simpler or more specialised rhs'
-             -- This is important: see Note [Update unfolding after specialisation]
-             -- And in any case cloneBndrSM discards non-Stable unfoldings
-
-             fn3 = zapIdDemandInfo fn2
-             -- We zap the demand info because the binding may float,
-             -- which would invalidate the demand info (see #17810 for example).
-             -- Destroying demand info is not terrible; specialisation is
-             -- always followed soon by demand analysis.
-
-             body_env2 = body_env1 `extendInScope` fn3
-
-       ; (body', body_uds) <- do_body body_env2
-
-       ; (fn4, spec_defns, body_uds1) <- specDefn env body_uds fn3 rhs
-
-       ; let (free_uds, dump_dbs, float_all) = dumpBindUDs [fn4] body_uds1
-             all_free_uds                    = free_uds `thenUDs` rhs_uds
-
-             pairs = spec_defns ++ [(fn4, rhs')]
-                        -- fn4 mentions the spec_defns in its rules,
-                        -- so put the latter first
-
-             final_binds :: [DictBind]
-             -- See Note [From non-recursive to recursive]
-             final_binds | not (isNilOL dump_dbs)
-                         , not (null spec_defns)
-                         = [recWithDumpedDicts pairs dump_dbs]
-                         | otherwise
-                         = [mkDB $ NonRec b r | (b,r) <- pairs]
-                           ++ fromOL dump_dbs
-
-       ; if float_all then
-             -- Rather than discard the calls mentioning the bound variables
-             -- we float this (dictionary) binding along with the others
-              return ([], body', all_free_uds `snocDictBinds` final_binds)
-         else
-             -- No call in final_uds mentions bound variables,
-             -- so we can just leave the binding here
-              return (map db_bind final_binds, body', all_free_uds) }
-
-
-specBind top_lvl env (Rec pairs) do_body
-       -- Note [Specialising a recursive group]
-  = do { let (bndrs,rhss) = unzip pairs
-
-       ; (rec_env, bndrs1) <- case top_lvl of
-                                 TopLevel    -> return (env, bndrs)
-                                 NotTopLevel -> cloneRecBndrsSM env bndrs
-
-       ; (rhss', rhs_uds)  <- mapAndCombineSM (specExpr rec_env) rhss
-       ; (body', body_uds) <- do_body rec_env
-
-       ; let scope_uds = body_uds `thenUDs` rhs_uds
-                       -- Includes binds and calls arising from rhss
-
-       ; (bndrs2, spec_defns2, uds2) <- specDefns rec_env scope_uds (bndrs1 `zip` rhss)
-         -- bndrs2 is like bndrs1, but with RULES added
-
-       ; (bndrs3, spec_defns3, uds3)
-             <- if null spec_defns2  -- Common case: no specialisation
-                then return (bndrs2, [], uds2)
-                else do {            -- Specialisation occurred; do it again
-                          (bndrs3, spec_defns3, uds3)
-                              <- specDefns rec_env uds2 (bndrs2 `zip` rhss)
-                        ; return (bndrs3, spec_defns3 ++ spec_defns2, uds3) }
-
-       ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs1 uds3
-             final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss')
-                                             dumped_dbs
-
-       ; if float_all then
-              return ([], body', final_uds `snocDictBind` final_bind)
-         else
-              return ([db_bind final_bind], body', final_uds) }
-
-
----------------------------
-specDefns :: SpecEnv
-          -> UsageDetails               -- Info on how it is used in its scope
-          -> [(OutId,InExpr)]           -- The things being bound and their un-processed RHS
-          -> SpecM ([OutId],            -- Original Ids with RULES added
-                    [(OutId,OutExpr)],  -- Extra, specialised bindings
-                    UsageDetails)       -- Stuff to fling upwards from the specialised versions
-
--- Specialise a list of bindings (the contents of a Rec), but flowing usages
--- upwards binding by binding.  Example: { f = ...g ...; g = ...f .... }
--- Then if the input CallDetails has a specialised call for 'g', whose specialisation
--- in turn generates a specialised call for 'f', we catch that in this one sweep.
--- But not vice versa (it's a fixpoint problem).
-
-specDefns _env uds []
-  = return ([], [], uds)
-specDefns env uds ((bndr,rhs):pairs)
-  = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds  pairs
-       ; (bndr1, spec_defns2, uds2)  <- specDefn  env uds1 bndr rhs
-       ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }
-
----------------------------
-specDefn :: SpecEnv
-         -> UsageDetails                -- Info on how it is used in its scope
-         -> OutId -> InExpr             -- The thing being bound and its un-processed RHS
-         -> SpecM (Id,                  -- Original Id with added RULES
-                   [(Id,CoreExpr)],     -- Extra, specialised bindings
-                   UsageDetails)        -- Stuff to fling upwards from the specialised versions
-
-specDefn env body_uds fn rhs
-  = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds
-             rules_for_me = idCoreRules fn
-             dict_binds   = ud_binds body_uds
-
-       ; (rules, spec_defns, spec_uds) <- specCalls False env dict_binds
-                                               rules_for_me calls_for_me fn rhs
-
-       ; return ( fn `addIdSpecialisations` rules
-                , spec_defns
-                , body_uds_without_me `thenUDs` spec_uds) }
-                -- It's important that the `thenUDs` is this way
-                -- round, because body_uds_without_me may bind
-                -- dictionaries that are used in calls_for_me passed
-                -- to specDefn.  So the dictionary bindings in
-                -- spec_uds may mention dictionaries bound in
-                -- body_uds_without_me
-
----------------------------
-specCalls :: Bool              -- True  =>  specialising imported fn
-                               -- False =>  specialising local fn
-          -> SpecEnv
-          -> FloatedDictBinds  -- Just so that we can extend the in-scope set
-          -> [CoreRule]        -- Existing RULES for the fn
-          -> [CallInfo]
-          -> OutId -> InExpr
-          -> SpecM SpecInfo    -- New rules, specialised bindings, and usage details
-
--- This function checks existing rules, and does not create
--- duplicate ones. So the caller does not need to do this filtering.
--- See 'already_covered'
-
-type SpecInfo = ( [CoreRule]       -- Specialisation rules
-                , [(Id,CoreExpr)]  -- Specialised definition
-                , UsageDetails )   -- Usage details from specialised RHSs
-
-specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
-        -- The first case is the interesting one
-  |  notNull calls_for_me               -- And there are some calls to specialise
-  && not (isNeverActive (idInlineActivation fn))
-        -- Don't specialise NOINLINE things
-        -- See Note [Auto-specialisation and RULES]
-        --
-        -- Don't specialise OPAQUE things, see Note [OPAQUE pragma].
-        -- Since OPAQUE things are always never-active (see
-        -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for
-        -- OPAQUE things.
-
---   && not (certainlyWillInline (idUnfolding fn))      -- And it's not small
---      See Note [Inline specialisations] for why we do not
---      switch off specialisation for inline functions
-
-  = -- pprTrace "specCalls: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $
-    foldlM spec_call ([], [], emptyUDs) calls_for_me
-
-  | otherwise   -- No calls or RHS doesn't fit our preconceptions
-  = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me && not (isClassOpId fn))
-          "Missed specialisation opportunity for" (ppr fn $$ trace_doc) $
-          -- isClassOpId: class-op Ids never inline; we specialise them
-          -- through fireRewriteRules. So don't complain about missed opportunities
-          -- Note [Specialisation shape]
-    -- pprTrace "specCalls: none" (ppr fn <+> ppr calls_for_me) $
-    return ([], [], emptyUDs)
-  where
-    trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ]
-
-    fn_type   = idType fn
-    fn_arity  = idArity fn
-    fn_unf    = realIdUnfolding fn  -- Ignore loop-breaker-ness here
-    inl_prag  = idInlinePragma fn
-    inl_act   = inlinePragmaActivation inl_prag
-    is_local  = isLocalId fn
-    is_dfun   = isDFunId fn
-    dflags    = se_dflags env
-    this_mod  = se_module env
-        -- Figure out whether the function has an INLINE pragma
-        -- See Note [Inline specialisations]
-
-    (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs
-                            -- See Note [Account for casts in binding]
-
-    -- Bring into scope the binders from the floated dicts
-    env_with_dict_bndrs = bringFloatedDictsIntoScope env dict_binds
-
-    already_covered :: SpecEnv -> [CoreRule] -> [CoreExpr] -> Bool
-    already_covered env new_rules args      -- Note [Specialisations already covered]
-       = isJust (specLookupRule env fn args (beginPhase inl_act)
-                                (new_rules ++ existing_rules))
-         -- Rules: we look both in the new_rules (generated by this invocation
-         --   of specCalls), and in existing_rules (passed in to specCalls)
-         -- inl_act: is the activation we are going to put in the new SPEC
-         --   rule; so we want to see if it is covered by another rule with
-         --   that same activation.
-
-    ----------------------------------------------------------
-        -- Specialise to one particular call pattern
-    spec_call :: SpecInfo                         -- Accumulating parameter
-              -> CallInfo                         -- Call instance
-              -> SpecM SpecInfo
-    spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) _ci@(CI { ci_key = call_args })
-      = -- See Note [Specialising Calls]
-        do { let all_call_args | is_dfun   = saturating_call_args -- See Note [Specialising DFuns]
-                               | otherwise = call_args
-                 saturating_call_args = call_args ++ map mk_extra_dfun_arg (dropList call_args rhs_bndrs)
-                 mk_extra_dfun_arg bndr | isTyVar bndr = UnspecType
-                                        | otherwise = UnspecArg
-
-           ; ( useful, rhs_env2, leftover_bndrs
-             , rule_bndrs, rule_lhs_args
-             , spec_bndrs1, dx_binds, spec_args) <- specHeader env_with_dict_bndrs
-                                                               rhs_bndrs all_call_args
-
---           ; pprTrace "spec_call" (vcat [ text "fun:       "  <+> ppr fn
---                                        , text "call info: "  <+> ppr _ci
---                                        , text "useful:    "  <+> ppr useful
---                                        , text "rule_bndrs:"  <+> ppr rule_bndrs
---                                        , text "lhs_args:  "  <+> ppr rule_lhs_args
---                                        , text "spec_bndrs1:" <+> ppr spec_bndrs1
---                                        , text "leftover_bndrs:" <+> pprIds leftover_bndrs
---                                        , text "spec_args: "  <+> ppr spec_args
---                                        , text "dx_binds:  "  <+> ppr dx_binds
---                                        , text "rhs_body"     <+> ppr rhs_body
---                                        , text "rhs_env2:  "  <+> ppr (se_subst rhs_env2)
---                                        , ppr dx_binds ]) $
---             return ()
-
-           ; if not useful  -- No useful specialisation
-                || already_covered rhs_env2 rules_acc rule_lhs_args
-             then return spec_acc
-             else
-        do { -- Run the specialiser on the specialised RHS
-             -- The "1" suffix is before we maybe add the void arg
-           ; (rhs_body', rhs_uds) <- specExpr rhs_env2 rhs_body
-                -- Add the { d1' = dx1; d2' = dx2 } usage stuff
-                -- to the rhs_uds; see Note [Specialising Calls]
-           ; let rhs_uds_w_dx   = dx_binds `consDictBinds` rhs_uds
-                 spec_rhs_bndrs = spec_bndrs1 ++ leftover_bndrs
-                 (spec_uds, dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds_w_dx
-                 spec_rhs1 = mkLams spec_rhs_bndrs $
-                             wrapDictBindsE dumped_dbs rhs_body'
-
-                 spec_fn_ty1 = exprType spec_rhs1
-
-                 -- Maybe add a void arg to the specialised function,
-                 -- to avoid unlifted bindings
-                 -- See Note [Specialisations Must Be Lifted]
-                 -- C.f. GHC.Core.Opt.WorkWrap.Utils.needsVoidWorkerArg
-                 add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn)
-                 (spec_bndrs, spec_rhs, spec_fn_ty)
-                   | add_void_arg = ( voidPrimId : spec_bndrs1
-                                    , Lam voidArgId spec_rhs1
-                                    , mkVisFunTyMany unboxedUnitTy spec_fn_ty1)
-                   | otherwise   = (spec_bndrs1, spec_rhs1, spec_fn_ty1)
-
-                 join_arity_decr = length rule_lhs_args - length spec_bndrs
-                 spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn
-                                 = Just (orig_join_arity - join_arity_decr)
-                                 | otherwise
-                                 = Nothing
-
-           ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity
-           ; let
-                -- The rule to put in the function's specialisation is:
-                --      forall x @b d1' d2'.
-                --          f x @T1 @b @T2 d1' d2' = f1 x @b
-                -- See Note [Specialising Calls]
-                herald | spec_imp  = -- Specialising imported fn
-                                     text "SPEC/" <> ppr this_mod
-                       | otherwise = -- Specialising local fn
-                                     text "SPEC"
-
-                spec_rule = mkSpecRule dflags this_mod True inl_act
-                                    herald fn rule_bndrs rule_lhs_args
-                                    (mkVarApps (Var spec_fn) spec_bndrs)
-
-                simpl_opts = initSimpleOpts dflags
-
-                --------------------------------------
-                -- Add a suitable unfolding; see Note [Inline specialisations]
-                -- The wrap_unf_body applies the original unfolding to the specialised
-                -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)
-                wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds
-                spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body
-                                         rule_lhs_args fn_unf
-
-                spec_inl_prag
-                  | not is_local     -- See Note [Specialising imported functions]
-                  , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal
-                  = neverInlinePragma
-                  | otherwise
-                  = inl_prag
-
-                --------------------------------------
-                -- Adding arity information just propagates it a bit faster
-                --      See Note [Arity decrease] in GHC.Core.Opt.Simplify
-                -- Copy InlinePragma information from the parent Id.
-                -- So if f has INLINE[1] so does spec_fn
-                arity_decr     = count isValArg rule_lhs_args - count isId spec_bndrs
-                spec_f_w_arity = spec_fn `setIdArity`      max 0 (fn_arity - arity_decr)
-                                         `setInlinePragma` spec_inl_prag
-                                         `setIdUnfolding`  spec_unf
-                                         `asJoinId_maybe`  spec_join_arity
-
-                _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type
-                                       , ppr spec_fn  <+> dcolon <+> ppr spec_fn_ty
-                                       , ppr rhs_bndrs, ppr call_args
-                                       , ppr spec_rule
-                                       ]
-
-           ; -- pprTrace "spec_call: rule" _rule_trace_doc
-             return ( spec_rule                  : rules_acc
-                    , (spec_f_w_arity, spec_rhs) : pairs_acc
-                    , spec_uds           `thenUDs` uds_acc
-                    ) } }
-
--- Convenience function for invoking lookupRule from Specialise
--- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr]
-specLookupRule :: SpecEnv -> Id -> [CoreExpr]
-               -> CompilerPhase  -- Look up rules as if we were in this phase
-               -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
-specLookupRule env fn args phase rules
-  = lookupRule ropts (in_scope, realIdUnfolding) is_active fn args rules
-  where
-    dflags    = se_dflags env
-    in_scope  = getSubstInScope (se_subst env)
-    ropts     = initRuleOpts dflags
-    is_active = isActive phase
-
-{- Note [Specialising DFuns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-DFuns have a special sort of unfolding (DFunUnfolding), and these are
-hard to specialise a DFunUnfolding to give another DFunUnfolding
-unless the DFun is fully applied (#18120).  So, in the case of DFunIds
-we simply extend the CallKey with trailing UnspecTypes/UnspecArgs,
-so that we'll generate a rule that completely saturates the DFun.
-
-There is an ASSERT that checks this, in the DFunUnfolding case of
-GHC.Core.Unfold.Make.specUnfolding.
-
-Note [Specialisation Must Preserve Sharing]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider a function:
-
-    f :: forall a. Eq a => a -> blah
-    f =
-      if expensive
-         then f1
-         else f2
-
-As written, all calls to 'f' will share 'expensive'. But if we specialise 'f'
-at 'Int', eg:
-
-    $sfInt = SUBST[a->Int,dict->dEqInt] (if expensive then f1 else f2)
-
-    RULE "SPEC f"
-      forall (d :: Eq Int).
-        f Int _ = $sfIntf
-
-We've now lost sharing between 'f' and '$sfInt' for 'expensive'. Yikes!
-
-To avoid this, we only generate specialisations for functions whose arity is
-enough to bind all of the arguments we need to specialise.  This ensures our
-specialised functions don't do any work before receiving all of their dicts,
-and thus avoids the 'f' case above.
-
-Note [Specialisations Must Be Lifted]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider a function 'f':
-
-    f = forall a. Eq a => Array# a
-
-used like
-
-    case x of
-      True -> ...f @Int dEqInt...
-      False -> 0
-
-Naively, we might generate an (expensive) specialisation
-
-    $sfInt :: Array# Int
-
-even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to
-the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to
-preserve laziness.
-
-Note [Specialising Calls]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have a function with a complicated type:
-
-    f :: forall a b c. Int -> Eq a => Show b => c -> Blah
-    f @a @b @c i dEqA dShowA x = blah
-
-and suppose it is called at:
-
-    f 7 @T1 @T2 @T3 dEqT1 ($dfShow dShowT2) t3
-
-This call is described as a 'CallInfo' whose 'ci_key' is:
-
-    [ SpecType T1, SpecType T2, UnspecType, UnspecArg, SpecDict dEqT1
-    , SpecDict ($dfShow dShowT2), UnspecArg ]
-
-Why are 'a' and 'b' identified as 'SpecType', while 'c' is 'UnspecType'?
-Because we must specialise the function on type variables that appear
-free in its *dictionary* arguments; but not on type variables that do not
-appear in any dictionaries, i.e. are fully polymorphic.
-
-Because this call has dictionaries applied, we'd like to specialise
-the call on any type argument that appears free in those dictionaries.
-In this case, those are [a :-> T1, b :-> T2].
-
-We also need to substitute the dictionary binders with their
-specialised dictionaries. The simplest substitution would be
-[dEqA :-> dEqT1, dShowA :-> $dfShow dShowT2], but this duplicates
-work, since `$dfShow dShowT2` is a function application. Therefore, we
-also want to *float the dictionary out* (via bindAuxiliaryDict),
-creating a new dict binding
-
-    dShow1 = $dfShow dShowT2
-
-and the substitution [dEqA :-> dEqT1, dShowA :-> dShow1].
-
-With the substitutions in hand, we can generate a specialised function:
-
-    $sf :: forall c. Int -> c -> Blah
-    $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah)
-
-Note that the substitution is applied to the whole thing.  This is
-convenient, but just slightly fragile.  Notably:
-  * There had better be no name clashes in a/b/c
-
-We must construct a rewrite rule:
-
-    RULE "SPEC f @T1 @T2 _"
-      forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2).
-        f @T1 @T2 @c i d1 d2 = $sf @c i
-
-In the rule, d1 and d2 are just wildcards, not used in the RHS.  Note
-additionally that 'x' isn't captured by this rule --- we bind only
-enough etas in order to capture all of the *specialised* arguments.
-
-Note [Drop dead args from specialisations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When specialising a function, it’s possible some of the arguments may
-actually be dead. For example, consider:
-
-    f :: forall a. () -> Show a => a -> String
-    f x y = show y ++ "!"
-
-We might generate the following CallInfo for `f @Int`:
-
-    [SpecType Int, UnspecArg, SpecDict $dShowInt, UnspecArg]
-
-Normally we’d include both the x and y arguments in the
-specialisation, since we’re not specialising on either of them. But
-that’s silly, since x is actually unused! So we might as well drop it
-in the specialisation:
-
-    $sf :: Int -> String
-    $sf y = show y ++ "!"
-
-    {-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-}
-
-This doesn’t save us much, since the arg would be removed later by
-worker/wrapper, anyway, but it’s easy to do.
-
-Wrinkles
-
-* Note that we only drop dead arguments if:
-    1. We don’t specialise on them.
-    2. They come before an argument we do specialise on.
-  Doing the latter would require eta-expanding the RULE, which could
-  make it match less often, so it’s not worth it. Doing the former could
-  be more useful --- it would stop us from generating pointless
-  specialisations --- but it’s more involved to implement and unclear if
-  it actually provides much benefit in practice.
-
-* If the function has a stable unfolding, specHeader has to come up with
-  arguments to pass to that stable unfolding, when building the stable
-  unfolding of the specialised function: this is the last field in specHeader's
-  big result tuple.
-
-  The right thing to do is to produce a LitRubbish; it should rapidly
-  disappear.  Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let.
-
-Note [Specialisation modulo dictionary selectors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In #19644, we discovered that the ClassOp/DFun rules from
-Note [ClassOp/DFun selection] inhibit transitive specialisation.
-Example, inspired by T17966:
-
-  class C a where
-    m :: Show b => a -> b -> String
-    dummy :: a -> () -- Force a datatype dictionary representation
-
-  instance C Int where
-    m a b = show a ++ show b
-    dummy _ = ()
-
-  f :: (C a, Show b) => a -> b -> String
-  f a b = m a b ++ "!"
-  {-# INLINABLE[0] f #-}
-
-  main = putStrLn (f (42::Int) (True::Bool))
-
-Here, we specialise `f` at `Int` and `Bool`, giving
-
-  $dC = $fCInt
-  $dShow = GHC.Show.$fShowBool
-  $sf (a::Int) (b::Bool) =
-        ... (m @Int $dC @Bool $dShow a b) ...
-
-Here `m` is just a DictSel, so there is (apparently) nothing to specialise!
-However, the next Simplifier run will expose the rewritten instance method:
-
-  ... $fCInt_$cm @Bool $fShowBool a b ...
-
-where $fCInt_$cm is the instance method for `m` in `instance C Int`:
-
-   $fCInt_$cm :: forall b. Show b => Int -> b -> String
-   $fCInt_$cm b d x y = show @Int $dShowInt x ++ show @b d y
-
-We want to specialise this! How? By doing the method-selection rewrite in
-the Specialiser. Hence
-
-1. In the App case of 'specExpr', try to apply the ClassOp/DFun rule on the
-   head of the application, repeatedly, via 'fireRewriteRules'.
-2. Attach an unfolding to freshly-bound dictionary ids such as `$dC` and
-   `$dShow` in `bindAuxiliaryDict`, so that we can exploit the unfolding
-   in 'fireRewriteRules' to do the ClassOp/DFun rewrite.
-
-NB: Without (2), (1) would be pointless, because 'lookupRule' wouldn't be able
-to look into the RHS of `$dC` to see the DFun.
-
-Note [Zap occ info in rule binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we generate a specialisation RULE, we need to drop occurrence
-info on the binders. If we don’t, things go wrong when we specialise a
-function like
-
-    f :: forall a. () -> Show a => a -> String
-    f x y = show y ++ "!"
-
-since we’ll generate a RULE like
-
-    RULE "SPEC f @Int" forall x [Occ=Dead].
-      f @Int x $dShow = $sf
-
-and Core Lint complains, even though x only appears on the LHS (due to
-Note [Drop dead args from specialisations]).
-
-Why is that a Lint error? Because the arguments on the LHS of a rule
-are syntactically expressions, not patterns, so Lint treats the
-appearance of x as a use rather than a binding. Fortunately, the
-solution is simple: we just make sure to zap the occ info before
-using ids as wildcard binders in a rule.
-
-Note [Account for casts in binding]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   f :: Eq a => a -> IO ()
-   {-# INLINABLE f
-       StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g
-     #-}
-   f = ...
-
-In f's stable unfolding we have done some modest simplification which
-has pushed the cast to the outside.  (I wonder if this is the Right
-Thing, but it's what happens now; see GHC.Core.Opt.Simplify.Utils Note [Casts and
-lambdas].)  Now that stable unfolding must be specialised, so we want
-to push the cast back inside. It would be terrible if the cast
-defeated specialisation!  Hence the use of collectBindersPushingCo.
-
-Note [Evidence foralls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose (#12212) that we are specialising
-   f :: forall a b. (Num a, F a ~ F b) => blah
-with a=b=Int. Then the RULE will be something like
-   RULE forall (d:Num Int) (g :: F Int ~ F Int).
-        f Int Int d g = f_spec
-But both varToCoreExpr (when constructing the LHS args), and the
-simplifier (when simplifying the LHS args), will transform to
-   RULE forall (d:Num Int) (g :: F Int ~ F Int).
-        f Int Int d <F Int> = f_spec
-by replacing g with Refl.  So now 'g' is unbound, which results in a later
-crash. So we use Refl right off the bat, and do not forall-quantify 'g':
- * varToCoreExpr generates a Refl
- * exprsFreeIdsList returns the Ids bound by the args,
-   which won't include g
-
-You might wonder if this will match as often, but the simplifier replaces
-complicated Refl coercions with Refl pretty aggressively.
-
-Note [Orphans and auto-generated rules]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we specialise an INLINABLE function, or when we have
--fspecialise-aggressively, we auto-generate RULES that are orphans.
-We don't want to warn about these, or we'd generate a lot of warnings.
-Thus, we only warn about user-specified orphan rules.
-
-Indeed, we don't even treat the module as an orphan module if it has
-auto-generated *rule* orphans.  Orphan modules are read every time we
-compile, so they are pretty obtrusive and slow down every compilation,
-even non-optimised ones.  (Reason: for type class instances it's a
-type correctness issue.)  But specialisation rules are strictly for
-*optimisation* only so it's fine not to read the interface.
-
-What this means is that a SPEC rules from auto-specialisation in
-module M will be used in other modules only if M.hi has been read for
-some other reason, which is actually pretty likely.
-
-Note [From non-recursive to recursive]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Even in the non-recursive case, if any dict-binds depend on 'fn' we might
-have built a recursive knot
-
-      f a d x = <blah>
-      MkUD { ud_binds = NonRec d7  (MkD ..f..)
-           , ud_calls = ...(f T d7)... }
-
-The we generate
-
-     Rec { fs x = <blah>[T/a, d7/d]
-           f a d x = <blah>
-               RULE f T _ = fs
-           d7 = ...f... }
-
-Here the recursion is only through the RULE.
-
-However we definitely should /not/ make the Rec in this wildly common
-case:
-      d = ...
-      MkUD { ud_binds = NonRec d7 (...d...)
-           , ud_calls = ...(f T d7)... }
-
-Here we want simply to add d to the floats, giving
-      MkUD { ud_binds = NonRec d (...)
-                        NonRec d7 (...d...)
-           , ud_calls = ...(f T d7)... }
-
-In general, we need only make this Rec if
-  - there are some specialisations (spec_binds non-empty)
-  - there are some dict_binds that depend on f (dump_dbs non-empty)
-
-Note [Avoiding loops (DFuns)]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When specialising /dictionary functions/ we must be very careful to
-avoid building loops. Here is an example that bit us badly, on
-several distinct occasions.
-
-Here is one: #3591
-     class Eq a => C a
-     instance Eq [a] => C [a]
-
-This translates to
-     dfun :: Eq [a] -> C [a]
-     dfun a d = MkD a d (meth d)
-
-     d4 :: Eq [T] = <blah>
-     d2 ::  C [T] = dfun T d4
-     d1 :: Eq [T] = $p1 d2
-     d3 ::  C [T] = dfun T d1
-
-None of these definitions is recursive. What happened was that we
-generated a specialisation:
-     RULE forall d. dfun T d = dT  :: C [T]
-     dT = (MkD a d (meth d)) [T/a, d1/d]
-        = MkD T d1 (meth d1)
-
-But now we use the RULE on the RHS of d2, to get
-    d2 = dT = MkD d1 (meth d1)
-    d1 = $p1 d2
-
-and now d1 is bottom!  The problem is that when specialising 'dfun' we
-should first dump "below" the binding all floated dictionary bindings
-that mention 'dfun' itself.  So d2 and d3 (and hence d1) must be
-placed below 'dfun', and thus unavailable to it when specialising
-'dfun'.  That in turn means that the call (dfun T d1) must be
-discarded.  On the other hand, the call (dfun T d4) is fine, assuming
-d4 doesn't mention dfun.
-
-Solution:
-  Discard all calls that mention dictionaries that depend
-  (directly or indirectly) on the dfun we are specialising.
-  This is done by 'filterCalls'
-
-Note [Avoiding loops (non-DFuns)]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The whole Note [Avoiding loops (DFuns)] things applies only to DFuns.
-It's important /not/ to apply filterCalls to non-DFuns. For example:
-
-  class C a where { foo,bar :: [a] -> [a] }
-
-  instance C Int where
-     foo x = r_bar x
-     bar xs = reverse xs
-
-  r_bar :: C a => [a] -> [a]
-  r_bar xs = bar (xs ++ xs)
-
-That translates to:
-
-    r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)
-
-    Rec { $fCInt :: C Int = MkC foo_help reverse
-          foo_help (xs::[Int]) = r_bar Int $fCInt xs }
-
-The call (r_bar $fCInt) mentions $fCInt,
-                        which mentions foo_help,
-                        which mentions r_bar
-
-But we DO want to specialise r_bar at Int:
-    Rec { $fCInt :: C Int = MkC foo_help reverse
-          foo_help (xs::[Int]) = r_bar Int $fCInt xs
-
-          r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)
-            RULE r_bar Int _ = r_bar_Int
-
-          r_bar_Int xs = bar Int $fCInt (xs ++ xs)
-           }
-
-Note that, because of its RULE, r_bar joins the recursive
-group.  (In this case it'll unravel a short moment later.)
-See test simplCore/should_compile/T19599a.
-
-Another example is #19599, which looked like this:
-
-   class (Show a, Enum a) => MyShow a where
-      myShow :: a -> String
-
-   myShow_impl :: MyShow a => a -> String
-
-   foo :: Int -> String
-   foo = myShow_impl @Int $fMyShowInt
-
-   Rec { $fMyShowInt = MkMyShowD $fEnumInt $fShowInt $cmyShow
-       ; $cmyShow = myShow_impl @Int $fMyShowInt }
-
-Here, we really do want to specialise `myShow_impl @Int $fMyShowInt`.
-
-
-Note [Specialising a recursive group]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-    let rec { f x = ...g x'...
-            ; g y = ...f y'.... }
-    in f 'a'
-Here we specialise 'f' at Char; but that is very likely to lead to
-a specialisation of 'g' at Char.  We must do the latter, else the
-whole point of specialisation is lost.
-
-But we do not want to keep iterating to a fixpoint, because in the
-presence of polymorphic recursion we might generate an infinite number
-of specialisations.
-
-So we use the following heuristic:
-  * Arrange the rec block in dependency order, so far as possible
-    (the occurrence analyser already does this)
-
-  * Specialise it much like a sequence of lets
-
-  * Then go through the block a second time, feeding call-info from
-    the RHSs back in the bottom, as it were
-
-In effect, the ordering maxmimises the effectiveness of each sweep,
-and we do just two sweeps.   This should catch almost every case of
-monomorphic recursion -- the exception could be a very knotted-up
-recursion with multiple cycles tied up together.
-
-This plan is implemented in the Rec case of specBindItself.
-
-Note [Specialisations already covered]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We obviously don't want to generate two specialisations for the same
-argument pattern.  There are two wrinkles
-
-1. We do the already-covered test in specDefn, not when we generate
-the CallInfo in mkCallUDs.  We used to test in the latter place, but
-we now iterate the specialiser somewhat, and the Id at the call site
-might therefore not have all the RULES that we can see in specDefn
-
-2. What about two specialisations where the second is an *instance*
-of the first?  If the more specific one shows up first, we'll generate
-specialisations for both.  If the *less* specific one shows up first,
-we *don't* currently generate a specialisation for the more specific
-one.  (See the call to lookupRule in already_covered.)  Reasons:
-  (a) lookupRule doesn't say which matches are exact (bad reason)
-  (b) if the earlier specialisation is user-provided, it's
-      far from clear that we should auto-specialise further
-
-Note [Auto-specialisation and RULES]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider:
-   g :: Num a => a -> a
-   g = ...
-
-   f :: (Int -> Int) -> Int
-   f w = ...
-   {-# RULE f g = 0 #-}
-
-Suppose that auto-specialisation makes a specialised version of
-g::Int->Int. That version won't appear in the LHS of the RULE for f.
-So if the specialisation rule fires too early, the rule for f may
-never fire.
-
-It might be possible to add new rules, to "complete" the rewrite system.
-Thus when adding
-        RULE forall d. g Int d = g_spec
-also add
-        RULE f g_spec = 0
-
-But that's a bit complicated.  For now we ask the programmer's help,
-by *copying the INLINE activation pragma* to the auto-specialised
-rule.  So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule
-will also not be active until phase 2.  And that's what programmers
-should jolly well do anyway, even aside from specialisation, to ensure
-that g doesn't inline too early.
-
-This in turn means that the RULE would never fire for a NOINLINE
-thing so not much point in generating a specialisation at all.
-
-Note [Specialisation shape]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We only specialise a function if it has visible top-level lambdas
-corresponding to its overloading.  E.g. if
-        f :: forall a. Eq a => ....
-then its body must look like
-        f = /\a. \d. ...
-
-Reason: when specialising the body for a call (f ty dexp), we want to
-substitute dexp for d, and pick up specialised calls in the body of f.
-
-We do allow casts, however; see Note [Account for casts in binding].
-
-This doesn't always work.  One example I came across was this:
-        newtype Gen a = MkGen{ unGen :: Int -> a }
-
-        choose :: Eq a => a -> Gen a
-        choose n = MkGen (\r -> n)
-
-        oneof = choose (1::Int)
-
-It's a silly example, but we get
-        choose = /\a. g `cast` co
-where choose doesn't have any dict arguments.  Thus far I have not
-tried to fix this (wait till there's a real example).
-
-Mind you, then 'choose' will be inlined (since RHS is trivial) so
-it doesn't matter.  This comes up with single-method classes
-
-   class C a where { op :: a -> a }
-   instance C a => C [a] where ....
-==>
-   $fCList :: C a => C [a]
-   $fCList = $copList |> (...coercion>...)
-   ....(uses of $fCList at particular types)...
-
-So we suppress the WARN if the rhs is trivial.
-
-Note [Inline specialisations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here is what we do with the InlinePragma of the original function
-
-  * Activation/RuleMatchInfo: both inherited from the original function
-
-  * InlineSpec: inherit from original function
-
-  * Unfolding: transfer a StableUnfolding iff it is UnfWhen
-               See GHC.Core.Unfold.Make.specUnfolding
-               and its Note [Specialising unfoldings]
-
-InlineSpec: you might wonder why we specialise INLINE functions at all.
-After all they should be inlined, right?  Two reasons:
-
- * Even INLINE functions are sometimes not inlined, when they aren't
-   applied to interesting arguments.  But perhaps the type arguments
-   alone are enough to specialise (even though the args are too boring
-   to trigger inlining), and it's certainly better to call the
-   specialised version.
-
- * The RHS of an INLINE function might call another overloaded function,
-   and we'd like to generate a specialised version of that function too.
-   This actually happens a lot. Consider
-      replicateM_ :: (Monad m) => Int -> m a -> m ()
-      {-# INLINABLE replicateM_ #-}
-      replicateM_ d x ma = ...
-   The strictness analyser may transform to
-      replicateM_ :: (Monad m) => Int -> m a -> m ()
-      {-# INLINE replicateM_ #-}
-      replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma
-
-      $wreplicateM_ :: (Monad m) => Int# -> m a -> m ()
-      {-# INLINABLE $wreplicateM_ #-}
-      $wreplicateM_ = ...
-   Now an importing module has a specialised call to replicateM_, say
-   (replicateM_ dMonadIO).  We certainly want to specialise $wreplicateM_!
-   This particular example had a huge effect on the call to replicateM_
-   in nofib/shootout/n-body.
--}
-
-{- *********************************************************************
-*                                                                      *
-                   SpecArg, and specHeader
-*                                                                      *
-********************************************************************* -}
-
--- | An argument that we might want to specialise.
--- See Note [Specialising Calls] for the nitty gritty details.
-data SpecArg
-  =
-    -- | Type arguments that should be specialised, due to appearing
-    -- free in the type of a 'SpecDict'.
-    SpecType Type
-
-    -- | Type arguments that should remain polymorphic.
-  | UnspecType
-
-    -- | Dictionaries that should be specialised. mkCallUDs ensures
-    -- that only "interesting" dictionary arguments get a SpecDict;
-    -- see Note [Interesting dictionary arguments]
-  | SpecDict DictExpr
-
-    -- | Value arguments that should not be specialised.
-  | UnspecArg
-
-instance Outputable SpecArg where
-  ppr (SpecType t) = text "SpecType" <+> ppr t
-  ppr UnspecType   = text "UnspecType"
-  ppr (SpecDict d) = text "SpecDict" <+> ppr d
-  ppr UnspecArg    = text "UnspecArg"
-
-specArgFreeIds :: SpecArg -> IdSet
-specArgFreeIds (SpecType {}) = emptyVarSet
-specArgFreeIds (SpecDict dx) = exprFreeIds dx
-specArgFreeIds UnspecType    = emptyVarSet
-specArgFreeIds UnspecArg     = emptyVarSet
-
-isSpecDict :: SpecArg -> Bool
-isSpecDict (SpecDict {}) = True
-isSpecDict _             = False
-
--- | Given binders from an original function 'f', and the 'SpecArg's
--- corresponding to its usage, compute everything necessary to build
--- a specialisation.
---
--- We will use the running example from Note [Specialising Calls]:
---
---     f :: forall a b c. Int -> Eq a => Show b => c -> Blah
---     f @a @b @c i dEqA dShowB x = blah
---
--- Suppose we decide to specialise it at the following pattern:
---
---     [ SpecType T1, SpecType T2, UnspecType, UnspecArg
---     , SpecDict dEqT1, SpecDict ($dfShow dShowT2), UnspecArg ]
---
--- We'd eventually like to build the RULE
---
---     RULE "SPEC f @T1 @T2 _"
---       forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2).
---         f @T1 @T2 @c i d1 d2 = $sf @c i
---
--- and the specialisation '$sf'
---
---     $sf :: forall c. Int -> c -> Blah
---     $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowB :-> dShow1] (\@c i x -> blah)
---
--- where dShow1 is a floated binding created by bindAuxiliaryDict.
---
--- The cases for 'specHeader' below are presented in the same order as this
--- running example. The result of 'specHeader' for this example is as follows:
---
---    ( -- Returned arguments
---      env + [a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowB :-> dShow1]
---    , [x]
---
---      -- RULE helpers
---    , [c, i, d1, d2]
---    , [T1, T2, c, i, d1, d2]
---
---      -- Specialised function helpers
---    , [c, i, x]
---    , [dShow1 = $dfShow dShowT2]
---    , [T1, T2, c, i, dEqT1, dShow1]
---    )
-specHeader
-     :: SpecEnv
-     -> [InBndr]    -- The binders from the original function 'f'
-     -> [SpecArg]   -- From the CallInfo
-     -> SpecM ( Bool     -- True <=> some useful specialisation happened
-                         -- Not the same as any (isSpecDict args) because
-                         -- the args might be longer than bndrs
-
-                -- Returned arguments
-              , SpecEnv      -- Substitution to apply to the body of 'f'
-              , [OutBndr]    -- Leftover binders from the original function 'f'
-                             --   that don’t have a corresponding SpecArg
-
-                -- RULE helpers
-              , [OutBndr]    -- Binders for the RULE
-              , [OutExpr]    -- Args for the LHS of the rule
-
-                -- Specialised function helpers
-              , [OutBndr]    -- Binders for $sf
-              , [DictBind]   -- Auxiliary dictionary bindings
-              , [OutExpr]    -- Specialised arguments for unfolding
-                             -- Same length as "Args for LHS of rule"
-              )
-
--- We want to specialise on type 'T1', and so we must construct a substitution
--- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding
--- details.
-specHeader env (bndr : bndrs) (SpecType ty : args)
-  = do { -- Find qvars, the type variables to add to the binders for the rule
-         -- Namely those free in `ty` that aren't in scope
-         -- See (MP2) in Note [Specialising polymorphic dictionaries]
-         let in_scope = Core.getSubstInScope (se_subst env)
-             qvars    = scopedSort $
-                        filterOut (`elemInScopeSet` in_scope) $
-                        tyCoVarsOfTypeList ty
-             (env1, qvars') = substBndrs env qvars
-             ty'            = substTy env1 ty
-             env2           = extendTvSubst env1 bndr ty'
-       ; (useful, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
-            <- specHeader env2 bndrs args
-       ; pure ( useful
-              , env3
-              , leftover_bndrs
-              , qvars' ++ rule_bs
-              , Type ty' : rule_es
-              , qvars' ++ bs'
-              , dx
-              , Type ty' : spec_args
-              )
-       }
-
--- Next we have a type that we don't want to specialise. We need to perform
--- a substitution on it (in case the type refers to 'a'). Additionally, we need
--- to produce a binder, LHS argument and RHS argument for the resulting rule,
--- /and/ a binder for the specialised body.
-specHeader env (bndr : bndrs) (UnspecType : args)
-  = do { let (env', bndr') = substBndr env bndr
-       ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
-            <- specHeader env' bndrs args
-       ; pure ( useful
-              , env''
-              , leftover_bndrs
-              , bndr' : rule_bs
-              , varToCoreExpr bndr' : rule_es
-              , bndr' : bs'
-              , dx
-              , varToCoreExpr bndr' : spec_args
-              )
-       }
-
--- Next we want to specialise the 'Eq a' dict away. We need to construct
--- a wildcard binder to match the dictionary (See Note [Specialising Calls] for
--- the nitty-gritty), as a LHS rule and unfolding details.
-specHeader env (bndr : bndrs) (SpecDict d : args)
-  | not (isDeadBinder bndr)
-  = do { (env1, bndr') <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]
-       ; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d
-       ; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
-             <- specHeader env2 bndrs args
-       ; pure ( True      -- Ha!  A useful specialisation!
-              , env3
-              , leftover_bndrs
-              -- See Note [Evidence foralls]
-              , exprFreeIdsList (varToCoreExpr bndr') ++ rule_bs
-              , varToCoreExpr bndr' : rule_es
-              , bs'
-              , maybeToList dx_bind ++ dx
-              , spec_dict : spec_args
-              )
-       }
-
--- Finally, we don't want to specialise on this argument 'i':
---   - It's an UnSpecArg, or
---   - It's a dead dictionary
--- We need to produce a binder, LHS and RHS argument for the RULE, and
--- a binder for the specialised body.
---
--- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is
--- why 'i' doesn't appear in our RULE above. But we have no guarantee that
--- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so
--- this case must be here.
-specHeader env (bndr : bndrs) (_ : args)
-    -- The "_" can be UnSpecArg, or SpecDict where the bndr is dead
-  = do { -- see Note [Zap occ info in rule binders]
-         let (env', bndr') = substBndr env (zapIdOccInfo bndr)
-       ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
-             <- specHeader env' bndrs args
-
-       ; let bndr_ty = idType bndr'
-
-             -- See Note [Drop dead args from specialisations]
-             -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let
-             (mb_spec_bndr, spec_arg)
-                | isDeadBinder bndr
-                , Just lit_expr <- mkLitRubbish bndr_ty
-                = (Nothing, lit_expr)
-                | otherwise
-                = (Just bndr', varToCoreExpr bndr')
-
-       ; pure ( useful
-              , env''
-              , leftover_bndrs
-              , bndr' : rule_bs
-              , varToCoreExpr bndr' : rule_es
-              , case mb_spec_bndr of
-                  Just b' -> b' : bs'
-                  Nothing -> bs'
-              , dx
-              , spec_arg : spec_args
-              )
-       }
-
--- If we run out of binders, stop immediately
--- See Note [Specialisation Must Preserve Sharing]
-specHeader env [] _ = pure (False, env, [], [], [], [], [], [])
-
--- Return all remaining binders from the original function. These have the
--- invariant that they should all correspond to unspecialised arguments, so
--- it's safe to stop processing at this point.
-specHeader env bndrs []
-  = pure (False, env', bndrs', [], [], [], [], [])
-  where
-    (env', bndrs') = substBndrs env bndrs
-
-
--- | Binds a dictionary argument to a fresh name, to preserve sharing
-bindAuxiliaryDict
-  :: SpecEnv
-  -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression
-  -> ( SpecEnv        -- Substitutes for orig_dict_id
-     , Maybe DictBind -- Auxiliary dict binding, if any
-     , OutExpr)       -- Witnessing expression (always trivial)
-bindAuxiliaryDict env@(SE { se_subst = subst })
-                  orig_dict_id fresh_dict_id dict_expr
-
-  -- If the dictionary argument is trivial,
-  -- don’t bother creating a new dict binding; just substitute
-  | exprIsTrivial dict_expr
-  = let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr }
-    in -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_id) $
-       (env', Nothing, dict_expr)
-
-  | otherwise  -- Non-trivial dictionary arg; make an auxiliary binding
-  = let fresh_dict_id' = fresh_dict_id `addDictUnfolding` dict_expr
-
-        dict_bind = mkDB (NonRec fresh_dict_id' dict_expr)
-        env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id')
-                                `Core.extendSubstInScope` fresh_dict_id' }
-                                -- Ensure the new unfolding is in the in-scope set
-    in -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id') $
-       (env', Just dict_bind, Var fresh_dict_id')
-
-addDictUnfolding :: Id -> CoreExpr -> Id
--- Add unfolding for freshly-bound Ids: see Note [Make the new dictionaries interesting]
--- and Note [Specialisation modulo dictionary selectors]
-addDictUnfolding id rhs
-  = id `setIdUnfolding` mkSimpleUnfolding defaultUnfoldingOpts rhs
-
-{-
-Note [Make the new dictionaries interesting]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Important!  We're going to substitute dx_id1 for d
-and we want it to look "interesting", else we won't gather *any*
-consequential calls. E.g.
-    f d = ...g d....
-If we specialise f for a call (f (dfun dNumInt)), we'll get
-a consequent call (g d') with an auxiliary definition
-    d' = df dNumInt
-We want that consequent call to look interesting; so we add an unfolding
-in the dictionary Id.
--}
-
-
-{- *********************************************************************
-*                                                                      *
-            UsageDetails and suchlike
-*                                                                      *
-********************************************************************* -}
-
-data UsageDetails
-  = MkUD { ud_binds :: !FloatedDictBinds
-         , ud_calls :: !CallDetails }
-    -- INVARIANT: suppose bs = fdb_bndrs ud_binds
-    -- Then 'calls' may *mention* 'bs',
-    -- but there should be no calls *for* bs
-
-data FloatedDictBinds  -- See Note [Floated dictionary bindings]
-  = FDB { fdb_binds :: !(OrdList DictBind)
-               -- The order is important;
-               -- in ds1 `appOL` ds2, bindings in ds2 can depend on those in ds1
-
-        , fdb_bndrs :: !IdSet
-    }          -- ^ The binders of 'fdb_binds'.
-               -- Caches a superset of the expression
-               --   `mkVarSet (bindersOfDictBinds fdb_binds))`
-               -- for later addition to an InScopeSet
-
--- | A 'DictBind' is a binding along with a cached set containing its free
--- variables (both type variables and dictionaries). We need this set
--- in splitDictBinds, when filtering bindings to decide which are
--- captured by a binder
-data DictBind = DB { db_bind :: CoreBind, db_fvs :: VarSet }
-
-bindersOfDictBind :: DictBind -> [Id]
-bindersOfDictBind = bindersOf . db_bind
-
-bindersOfDictBinds :: Foldable f => f DictBind -> [Id]
-bindersOfDictBinds = bindersOfBinds . foldr ((:) . db_bind) []
-
-{- Note [Floated dictionary bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We float out dictionary bindings for the reasons described under
-"Dictionary floating" above.  But not /just/ dictionary bindings.
-Consider
-
-   f :: Eq a => blah
-   f a d = rhs
-
-   $c== :: T -> T -> Bool
-   $c== x y = ...
-
-   $df :: Eq T
-   $df = Eq $c== ...
-
-   gurgle = ...(f @T $df)...
-
-We gather the call info for (f @T $df), and we don't want to drop it
-when we come across the binding for $df.  So we add $df to the floats
-and continue.  But then we have to add $c== to the floats, and so on.
-These all float above the binding for 'f', and now we can
-successfully specialise 'f'.
-
-So the DictBinds in (ud_binds :: OrdList DictBind) may contain
-non-dictionary bindings too.
-
-Note [Specialising polymorphic dictionaries]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-    class M a where { foo :: a -> Int }
-
-    instance M (ST s) where ...
-    -- dMST :: forall s. M (ST s)
-
-    wimwam :: forall a. M a => a -> Int
-    wimwam = /\a \(d::M a). body
-
-    f :: ST s -> Int
-    f = /\s \(x::ST s). wimwam @(ST s) (dMST @s) dx + 1
-
-We'd like to specialise wimwam at (ST s), thus
-    $swimwam :: forall s. ST s -> Int
-    $swimwam = /\s. body[ST s/a, (dMST @s)/d]
-
-    RULE forall s (d :: M (ST s)).
-         wimwam @(ST s) d = $swimwam @s
-
-Here are the moving parts:
-
-(MP1) We must /not/ dump the CallInfo
-        CIS wimwam (CI { ci_key = [@(ST s), dMST @s]
-                       , ci_fvs = {dMST} })
-      when we come to the /\s.  Instead, we simply let it continue to float
-      upwards. Hence ci_fvs is an IdSet, listing the /Ids/ that
-      are free in the call, but not the /TyVars/.  Hence using specArgFreeIds
-      in singleCall.
-
-  NB to be fully kosher we should explicitly quantifying the CallInfo
-  over 's', but we don't bother.  This would matter if there was an
-  enclosing binding of the same 's', which I don't expect to happen.
-
-(MP2) When we come to specialise the call, we must remember to quantify
-      over 's'.  That is done in the SpecType case of specHeader, where
-      we add 's' (called qvars) to the binders of the RULE and the specialised
-      function.
-
-(MP3) If we have f :: forall m. Monoid m => blah, and two calls
-        (f @(Endo b)      (d :: Monoid (Endo b))
-        (f @(Endo (c->c)) (d :: Monoid (Endo (c->c)))
-      we want to generate a specialisation only for the first.  The second
-      is just a substitution instance of the first, with no greater specialisation.
-      Hence the call to `remove_dups` in `filterCalls`.
-
-All this arose in #13873, in the unexpected form that a SPECIALISE
-pragma made the program slower!  The reason was that the specialised
-function $sinsertWith arising from the pragma looked rather like `f`
-above, and failed to specialise a call in its body like wimwam.
-Without the pragma, the original call to `insertWith` was completely
-monomorpic, and specialised in one go.
-
-Wrinkles.
-
-* With -XOverlappingInstances you might worry about this:
-    class C a where ...
-    instance C (Maybe Int) where ...   -- $df1 :: C (Maybe Int)
-    instance C (Maybe a)   where ...   -- $df2 :: forall a. C (Maybe a)
-
-    f :: C a => blah
-    f = rhs
-
-    g = /\a.  ...(f @(Maybe a) ($df2 a))...
-    h = ...f @(Maybe Int) $df1
-
-  There are two calls to f, but with different evidence.  This patch will
-  combine them into one.  But it's OK: this code will never arise unless you
-  use -XIncoherentInstances.  Even with -XOverlappingInstances, GHC tries hard
-  to keep dictionaries as singleton types.  But that goes out of the window
-  with -XIncoherentInstances -- and that is true even with ordianry type-class
-  specialisation (at least if any inlining has taken place).
-
-  GHC makes very few guarantees when you use -XIncoherentInstances, and its
-  not worth crippling the normal case for the incoherent corner.  (The best
-  thing might be to switch off specialisation altogether if incoherence is
-  involved... but incoherence is a property of an instance, not a class, so
-  it's a hard test to make.)
-
-  But see Note [Specialisation and overlapping instances].
--}
-
-instance Outputable DictBind where
-  ppr (DB { db_bind = bind, db_fvs = fvs })
-    = text "DB" <+> braces (sep [ text "fvs: " <+> ppr fvs
-                                , text "bind:" <+> ppr bind ])
-
-instance Outputable UsageDetails where
-  ppr (MkUD { ud_binds = dbs, ud_calls = calls })
-        = text "MkUD" <+> braces (sep (punctuate comma
-                [text "binds" <+> equals <+> ppr dbs,
-                 text "calls" <+> equals <+> ppr calls]))
-
-instance Outputable FloatedDictBinds where
-  ppr (FDB { fdb_binds = binds }) = ppr binds
-
-emptyUDs :: UsageDetails
-emptyUDs = MkUD { ud_binds = emptyFDBs, ud_calls = emptyDVarEnv }
-
-
-emptyFDBs :: FloatedDictBinds
-emptyFDBs = FDB { fdb_binds = nilOL, fdb_bndrs = emptyVarSet }
-
-------------------------------------------------------------
-type CallDetails  = DIdEnv CallInfoSet
-  -- The order of specialized binds and rules depends on how we linearize
-  -- CallDetails, so to get determinism we must use a deterministic set here.
-  -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM
-
-data CallInfoSet = CIS Id (Bag CallInfo)
-  -- The list of types and dictionaries is guaranteed to
-  -- match the type of f
-  -- The Bag may contain duplicate calls (i.e. f @T and another f @T)
-  -- These dups are eliminated by already_covered in specCalls
-
-data CallInfo
-  = CI { ci_key  :: [SpecArg]   -- All arguments
-       , ci_fvs  :: IdSet       -- Free Ids of the ci_key call
-                                -- /not/ including the main id itself, of course
-                                -- NB: excluding tyvars:
-                                --     See Note [Specialising polymorphic dictionaries]
-    }
-
-type DictExpr = CoreExpr
-
-ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet
-ciSetFilter p (CIS id a) = CIS id (filterBag p a)
-
-instance Outputable CallInfoSet where
-  ppr (CIS fn map) = hang (text "CIS" <+> ppr fn)
-                        2 (ppr map)
-
-pprCallInfo :: Id -> CallInfo -> SDoc
-pprCallInfo fn (CI { ci_key = key })
-  = ppr fn <+> ppr key
-
-instance Outputable CallInfo where
-  ppr (CI { ci_key = key, ci_fvs = _fvs })
-    = text "CI" <> braces (sep (map ppr key))
-
-unionCalls :: CallDetails -> CallDetails -> CallDetails
-unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2
-
-unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet
-unionCallInfoSet (CIS f calls1) (CIS _ calls2) =
-  CIS f (calls1 `unionBags` calls2)
-
-callDetailsFVs :: CallDetails -> VarSet
-callDetailsFVs calls =
-  nonDetStrictFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls
-  -- It's OK to use nonDetStrictFoldUDFM here because we forget the ordering
-  -- immediately by converting to a nondeterministic set.
-
-callInfoFVs :: CallInfoSet -> VarSet
-callInfoFVs (CIS _ call_info) =
-  foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info
-
-getTheta :: [PiTyBinder] -> [PredType]
-getTheta = fmap piTyBinderType . filter isInvisiblePiTyBinder . filter isAnonPiTyBinder
-
-
-------------------------------------------------------------
-singleCall :: Id -> [SpecArg] -> UsageDetails
-singleCall id args
-  = MkUD {ud_binds = emptyFDBs,
-          ud_calls = unitDVarEnv id $ CIS id $
-                     unitBag (CI { ci_key  = args
-                                 , ci_fvs  = call_fvs }) }
-  where
-    call_fvs = foldr (unionVarSet . specArgFreeIds) emptyVarSet args
-        -- specArgFreeIds: we specifically look for free Ids, not TyVars
-        --    see (MP1) in Note [Specialising polymorphic dictionaries]
-        --
-        -- We don't include the 'id' itself.
-
-mkCallUDs :: SpecEnv -> OutExpr -> [OutExpr] -> UsageDetails
-mkCallUDs env fun args
-  | (_, Var f) <- stripTicksTop tickishFloatable fun -- See Note [Ticks on applications]
-  = -- pprTraceWith "mkCallUDs" (\res -> vcat [ ppr f, ppr args, ppr res ]) $
-    mkCallUDs' env f args
-  | otherwise
-  = emptyUDs
-
-mkCallUDs' :: SpecEnv -> Id -> [OutExpr] -> UsageDetails
-mkCallUDs' env f args
-  | wantCallsFor env f    -- We want it, and...
-  , not (null ci_key)     -- this call site has a useful specialisation
-  = -- pprTrace "mkCallUDs: keeping" _trace_doc
-    singleCall f ci_key
-
-  | otherwise  -- See also Note [Specialisations already covered]
-  = -- pprTrace "mkCallUDs: discarding" _trace_doc
-    emptyUDs
-
-  where
-    _trace_doc = vcat [ppr f, ppr args, ppr ci_key]
-    pis                = fst $ splitPiTys $ idType f
-    constrained_tyvars = tyCoVarsOfTypes $ getTheta pis
-
-    ci_key :: [SpecArg]
-    ci_key = dropWhileEndLE (not . isSpecDict) $
-             zipWith mk_spec_arg args pis
-             -- Drop trailing args until we get to a SpecDict
-             -- In this way the RULE has as few args as possible,
-             -- which broadens its applicability, since rules only
-             -- fire when saturated
-
-    mk_spec_arg :: OutExpr -> PiTyBinder -> SpecArg
-    mk_spec_arg arg (Named bndr)
-      |  binderVar bndr `elemVarSet` constrained_tyvars
-      = case arg of
-          Type ty -> SpecType ty
-          _       -> pprPanic "ci_key" $ ppr arg
-      |  otherwise = UnspecType
-
-    -- For "invisibleFunArg", which are the type-class dictionaries,
-    -- we decide on a case by case basis if we want to specialise
-    -- on this argument; if so, SpecDict, if not UnspecArg
-    mk_spec_arg arg (Anon pred af)
-      | isInvisibleFunArg af
-      , interestingDict arg (scaledThing pred)
-              -- See Note [Interesting dictionary arguments]
-      = SpecDict arg
-
-      | otherwise = UnspecArg
-
-{-
-Note [Ticks on applications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Ticks such as source location annotations can sometimes make their way
-onto applications (see e.g. #21697). So if we see something like
-
-    App (Tick _ f) e
-
-we need to descend below the tick to find what the real function being
-applied is.
-
-The resulting RULE also has to be able to match this annotated use
-site, so we only look through ticks that RULE matching looks through
-(see Note [Tick annotations in RULE matching] in GHC.Core.Rules).
--}
-
-wantCallsFor :: SpecEnv -> Id -> Bool
-wantCallsFor _env _f = True
- -- We could reduce the size of the UsageDetails by being less eager
- -- about collecting calls for LocalIds: there is no point for
- -- ones that are lambda-bound.  We can't decide this by looking at
- -- the (absence of an) unfolding, because unfoldings for local
- -- functions are discarded by cloneBindSM, so no local binder will
- -- have an unfolding at this stage.  We'd have to keep a candidate
- -- set of let-binders.
- --
- -- Not many lambda-bound variables have dictionary arguments, so
- -- this would make little difference anyway.
- --
- -- For imported Ids we could check for an unfolding, but we have to
- -- do so anyway in canSpecImport, and it seems better to have it
- -- all in one place.  So we simply collect usage info for imported
- -- overloaded functions.
-
-{- Note [Interesting dictionary arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this
-         \a.\d:Eq a.  let f = ... in ...(f d)...
-There really is not much point in specialising f wrt the dictionary d,
-because the code for the specialised f is not improved at all, because
-d is lambda-bound.  We simply get junk specialisations.
-
-What is "interesting"?  Just that it has *some* structure.  But what about
-variables?  We look in the variable's /unfolding/.  And that means
-that we must be careful to ensure that dictionaries have unfoldings,
-
-* cloneBndrSM discards non-Stable unfoldings
-* specBind updates the unfolding after specialisation
-  See Note [Update unfolding after specialisation]
-* bindAuxiliaryDict adds an unfolding for an aux dict
-  see Note [Specialisation modulo dictionary selectors]
-* specCase adds unfoldings for the new bindings it creates
-
-We accidentally lost accurate tracking of local variables for a long
-time, because cloned variables didn't have unfoldings. But makes a
-massive difference in a few cases, eg #5113. For nofib as a
-whole it's only a small win: 2.2% improvement in allocation for ansi,
-1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size.
-
-Note [Update unfolding after specialisation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#21848)
-
-  wombat :: Show b => Int -> b -> String
-  wombat a b | a>0       = wombat (a-1) b
-             | otherwise = show a ++ wombat a b
-
-  class C a where
-    meth :: Show b => a -> b -> String
-    dummy :: a -> () -- Force a datatype dictionary representation
-
-  instance C Int where
-    meth = wombat
-    dummy _ = ()
-
-  class C a => D a   -- D has C as a superclass
-  instance D Int
-
-  f :: (D a, Show b) => a -> b -> String
-  {-# INLINABLE[0] f #-}
-  f a b = meth a b ++ "!" ++ meth a b
-
-Now `f` turns into:
-
-  f @a @b (dd :: D a) (ds :: Show b) a b
-     = let dc :: D a = %p1 dd  -- Superclass selection
-       in meth @a dc ....
-          meth @a dc ....
-
-When we specialise `f`, at a=Int say, that superclass selection can
-nfire (via rewiteClassOps), but that info (that 'dc' is now a
-particular dictionary `C`, of type `C Int`) must be available to
-the call `meth @a dc`, so that we can fire the `meth` class-op, and
-thence specialise `wombat`.
-
-We deliver on this idea by updating the unfolding for the binder
-in the NonRec case of specBind.  (This is too exotic to trouble with
-the Rec case.)
--}
-
-interestingDict :: CoreExpr -> Type -> Bool
--- A dictionary argument is interesting if it has *some* structure,
--- see Note [Interesting dictionary arguments]
--- NB: "dictionary" arguments include constraints of all sorts,
---     including equality constraints; hence the Coercion case
--- To make this work, we need to ensure that dictionaries have
--- unfoldings in them.
-interestingDict arg arg_ty
-  | not (typeDeterminesValue arg_ty) = False   -- See Note [Type determines value]
-  | otherwise                        = go arg
-  where
-    go (Var v)               =  hasSomeUnfolding (idUnfolding v)
-                             || isDataConWorkId v
-    go (Type _)              = False
-    go (Coercion _)          = False
-    go (App fn (Type _))     = go fn
-    go (App fn (Coercion _)) = go fn
-    go (Tick _ a)            = go a
-    go (Cast e _)            = go e
-    go _                     = True
-
-thenUDs :: UsageDetails -> UsageDetails -> UsageDetails
-thenUDs (MkUD {ud_binds = db1, ud_calls = calls1})
-        (MkUD {ud_binds = db2, ud_calls = calls2})
-  = MkUD { ud_binds       = db1    `thenFDBs`   db2
-         , ud_calls       = calls1 `unionCalls`  calls2 }
-
-thenFDBs :: FloatedDictBinds -> FloatedDictBinds -> FloatedDictBinds
--- Combine FloatedDictBinds
--- In (dbs1 `thenFDBs` dbs2), dbs2 may mention dbs1 but not vice versa
-thenFDBs (FDB { fdb_binds = dbs1, fdb_bndrs = bs1 })
-         (FDB { fdb_binds = dbs2, fdb_bndrs = bs2 })
-  = FDB { fdb_binds = dbs1 `appOL` dbs2
-        , fdb_bndrs = bs1  `unionVarSet` bs2 }
-
------------------------------
-_dictBindBndrs :: OrdList DictBind -> [Id]
-_dictBindBndrs dbs = foldr ((++) . bindersOf . db_bind) [] dbs
-
--- | Construct a 'DictBind' from a 'CoreBind'
-mkDB :: CoreBind -> DictBind
-mkDB bind = DB { db_bind = bind, db_fvs = bind_fvs bind }
-
--- | Identify the free variables of a 'CoreBind'
-bind_fvs :: CoreBind -> VarSet
-bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
-bind_fvs (Rec prs)         = rhs_fvs `delVarSetList` (map fst prs)
-                           where
-                             rhs_fvs = unionVarSets (map pair_fvs prs)
-
-pair_fvs :: (Id, CoreExpr) -> VarSet
-pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs
-                       `unionVarSet` idFreeVars bndr
-        -- idFreeVars: don't forget variables mentioned in
-        -- the rules of the bndr.  C.f. OccAnal.addRuleUsage
-        -- Also tyvars mentioned in its type; they may not appear
-        -- in the RHS
-        --      type T a = Int
-        --      x :: T a = 3
-  where
-    interesting :: InterestingVarFun
-    interesting v = isLocalVar v || (isId v && isDFunId v)
-        -- Very important: include DFunIds /even/ if it is imported
-        -- Reason: See Note [Avoiding loops in specImports], the #13429
-        --         example involving an imported dfun.  We must know
-        --         whether a dictionary binding depends on an imported
-        --         DFun in case we try to specialise that imported DFun
-
--- | Flatten a set of "dumped" 'DictBind's, and some other binding
--- pairs, into a single recursive binding.
-recWithDumpedDicts :: [(Id,CoreExpr)] -> OrdList DictBind -> DictBind
-recWithDumpedDicts pairs dbs
-  = DB { db_bind = Rec bindings
-       , db_fvs = fvs `delVarSetList` map fst bindings }
-  where
-    (bindings, fvs) = foldr add ([], emptyVarSet)
-                                (dbs `snocOL` mkDB (Rec pairs))
-    add (DB { db_bind = bind, db_fvs = fvs }) (prs_acc, fvs_acc)
-      = case bind of
-          NonRec b r -> ((b,r) : prs_acc, fvs')
-          Rec prs1   -> (prs1 ++ prs_acc, fvs')
-      where
-        fvs' = fvs_acc `unionVarSet` fvs
-
-snocDictBind :: UsageDetails -> DictBind -> UsageDetails
-snocDictBind uds@MkUD{ud_binds= FDB { fdb_binds = dbs, fdb_bndrs = bs }} db
-  = uds { ud_binds = FDB { fdb_binds = dbs `snocOL` db
-                         , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }
-
-snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails
--- Add ud_binds to the tail end of the bindings in uds
-snocDictBinds uds@MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs
-  = uds { ud_binds = FDB { fdb_binds = binds `appOL`        (toOL dbs)
-                         , fdb_bndrs = bs    `extendVarSetList` bindersOfDictBinds dbs } }
-
-consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
-consDictBinds dbs uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}}
-  = uds { ud_binds = FDB{ fdb_binds = toOL dbs `appOL` binds
-                        , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } }
-
-wrapDictBinds :: FloatedDictBinds -> [CoreBind] -> [CoreBind]
-wrapDictBinds (FDB { fdb_binds = dbs }) binds
-  = foldr add binds dbs
-  where
-    add (DB { db_bind = bind }) binds = bind : binds
-
-wrapDictBindsE :: OrdList DictBind -> CoreExpr -> CoreExpr
-wrapDictBindsE dbs expr
-  = foldr add expr dbs
-  where
-    add (DB { db_bind = bind }) expr = Let bind expr
-
-----------------------
-dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind)
--- Used at a lambda or case binder; just dump anything mentioning the binder
-dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
-  | null bndrs = (uds, nilOL)  -- Common in case alternatives
-  | otherwise  = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $
-                 (free_uds, dump_dbs)
-  where
-    free_uds = uds { ud_binds = free_dbs, ud_calls = free_calls }
-    bndr_set = mkVarSet bndrs
-    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
-    free_calls = deleteCallsMentioning dump_set $   -- Drop calls mentioning bndr_set on the floor
-                 deleteCallsFor bndrs orig_calls    -- Discard calls for bndr_set; there should be
-                                                    -- no calls for any of the dicts in dump_dbs
-
-dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind, Bool)
--- Used at a let(rec) binding.
--- We return a boolean indicating whether the binding itself is mentioned,
--- directly or indirectly, by any of the ud_calls; in that case we want to
--- float the binding itself;
--- See Note [Floated dictionary bindings]
-dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
-  = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs $$ ppr float_all) $
-    (free_uds, dump_dbs, float_all)
-  where
-    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }
-    bndr_set = mkVarSet bndrs
-    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
-    free_calls = deleteCallsFor bndrs orig_calls
-    float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls
-
-callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])
-callsForMe fn uds@MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }
-  = -- pprTrace ("callsForMe")
-    --          (vcat [ppr fn,
-    --                 text "Orig dbs ="     <+> ppr (_dictBindBndrs orig_dbs),
-    --                 text "Orig calls ="   <+> ppr orig_calls,
-    --                 text "Calls for me =" <+> ppr calls_for_me]) $
-    (uds_without_me, calls_for_me)
-  where
-    uds_without_me = uds { ud_calls = delDVarEnv orig_calls fn }
-    calls_for_me = case lookupDVarEnv orig_calls fn of
-                        Nothing -> []
-                        Just cis -> filterCalls cis orig_dbs
-         -- filterCalls: drop calls that (directly or indirectly)
-         -- refer to fn.  See Note [Avoiding loops (DFuns)]
-
-----------------------
-filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo]
--- Remove dominated calls (Note [Specialising polymorphic dictionaries])
--- and loopy DFuns (Note [Avoiding loops (DFuns)])
-filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })
-  | isDFunId fn  -- Note [Avoiding loops (DFuns)] applies only to DFuns
-  = filter ok_call de_dupd_calls
-  | otherwise         -- Do not apply it to non-DFuns
-  = de_dupd_calls  -- See Note [Avoiding loops (non-DFuns)]
-  where
-    de_dupd_calls = remove_dups call_bag
-
-    dump_set = foldl' go (unitVarSet fn) dbs
-      -- This dump-set could also be computed by splitDictBinds
-      --   (_,_,dump_set) = splitDictBinds dbs {fn}
-      -- But this variant is shorter
-
-    go so_far (DB { db_bind = bind, db_fvs = fvs })
-       | fvs `intersectsVarSet` so_far
-       = extendVarSetList so_far (bindersOf bind)
-       | otherwise = so_far
-
-    ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set
-
-remove_dups :: Bag CallInfo -> [CallInfo]
--- Calls involving more generic instances beat more specific ones.
--- See (MP3) in Note [Specialising polymorphic dictionaries]
-remove_dups calls = foldr add [] calls
-  where
-    add :: CallInfo -> [CallInfo] -> [CallInfo]
-    add ci [] = [ci]
-    add ci1 (ci2:cis) | ci2 `beats_or_same` ci1 = ci2:cis
-                      | ci1 `beats_or_same` ci2 = ci1:cis
-                      | otherwise               = ci2 : add ci1 cis
-
-beats_or_same :: CallInfo -> CallInfo -> Bool
-beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 })
-  = go args1 args2
-  where
-    go [] _ = True
-    go (arg1:args1) (arg2:args2) = go_arg arg1 arg2 && go args1 args2
-    go (_:_)        []           = False
-
-    go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2)
-    go_arg UnspecType     UnspecType     = True
-    go_arg (SpecDict {})  (SpecDict {})  = True
-    go_arg UnspecArg      UnspecArg      = True
-    go_arg _              _              = False
-
-----------------------
-splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, OrdList DictBind, IdSet)
--- splitDictBinds dbs bndrs returns
---   (free_dbs, dump_dbs, dump_set)
--- where
---   * dump_dbs depends, transitively on bndrs
---   * free_dbs does not depend on bndrs
---   * dump_set = bndrs `union` bndrs(dump_dbs)
-splitDictBinds (FDB { fdb_binds = dbs, fdb_bndrs = bs }) bndr_set
-   = (FDB { fdb_binds = free_dbs
-          , fdb_bndrs = bs `minusVarSet` dump_set }
-     , dump_dbs, dump_set)
-   where
-    (free_dbs, dump_dbs, dump_set)
-      = foldl' split_db (nilOL, nilOL, bndr_set) dbs
-                -- Important that it's foldl' not foldr;
-                -- we're accumulating the set of dumped ids in dump_set
-
-    split_db (free_dbs, dump_dbs, dump_idset) db
-        | DB { db_bind = bind, db_fvs = fvs } <- db
-        , dump_idset `intersectsVarSet` fvs     -- Dump it
-        = (free_dbs, dump_dbs `snocOL` db,
-           extendVarSetList dump_idset (bindersOf bind))
-
-        | otherwise     -- Don't dump it
-        = (free_dbs `snocOL` db, dump_dbs, dump_idset)
-
-
-----------------------
-deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
--- Remove calls mentioning any Id in bndrs
--- NB: The call is allowed to mention TyVars in bndrs
---     Note [Specialising polymorphic dictionaries]
---     ci_fvs are just the free /Ids/
-deleteCallsMentioning bndrs calls
-  = mapDVarEnv (ciSetFilter keep_call) calls
-  where
-    keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bndrs
-
-deleteCallsFor :: [Id] -> CallDetails -> CallDetails
--- Remove calls *for* bndrs
-deleteCallsFor bndrs calls = delDVarEnvList calls bndrs
-
-{-
-************************************************************************
-*                                                                      *
-\subsubsection{Boring helper functions}
-*                                                                      *
-************************************************************************
--}
-
-type SpecM a = UniqSM a
-
-runSpecM :: SpecM a -> CoreM a
-runSpecM thing_inside
-  = do { us <- getUniqueSupplyM
-       ; return (initUs_ us thing_inside) }
-
-mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
-mapAndCombineSM _ []     = return ([], emptyUDs)
-mapAndCombineSM f (x:xs) = do (y, uds1) <- f x
-                              (ys, uds2) <- mapAndCombineSM f xs
-                              return (y:ys, uds1 `thenUDs` uds2)
-
-extendTvSubst :: SpecEnv -> TyVar -> Type -> SpecEnv
-extendTvSubst env tv ty
-  = env { se_subst = Core.extendTvSubst (se_subst env) tv ty }
-
-extendInScope :: SpecEnv -> OutId -> SpecEnv
-extendInScope env@(SE { se_subst = subst }) bndr
-  = env { se_subst = subst `Core.extendSubstInScope` bndr }
-
-zapSubst :: SpecEnv -> SpecEnv
-zapSubst env@(SE { se_subst = subst })
-  = env { se_subst = Core.zapSubst subst }
-
-substTy :: SpecEnv -> Type -> Type
-substTy env ty = substTyUnchecked (se_subst env) ty
-
-substCo :: SpecEnv -> Coercion -> Coercion
-substCo env co = Core.substCo (se_subst env) co
-
-substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr)
-substBndr env bs = case Core.substBndr (se_subst env) bs of
-                      (subst', bs') -> (env { se_subst = subst' }, bs')
-
-substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])
-substBndrs env bs = case Core.substBndrs (se_subst env) bs of
-                      (subst', bs') -> (env { se_subst = subst' }, bs')
-
-cloneBndrSM :: SpecEnv -> Id -> SpecM (SpecEnv, Id)
--- Clone the binders of the bind; return new bind with the cloned binders
--- Return the substitution to use for RHSs, and the one to use for the body
--- Discards non-Stable unfoldings
-cloneBndrSM env@(SE { se_subst = subst }) bndr
-  = do { us <- getUniqueSupplyM
-       ; let (subst', bndr') = Core.cloneIdBndr subst us bndr
-       ; return (env { se_subst = subst' }, bndr') }
-
-cloneRecBndrsSM :: SpecEnv -> [Id] -> SpecM (SpecEnv, [Id])
-cloneRecBndrsSM env@(SE { se_subst = subst }) bndrs
-  = do { us <- getUniqueSupplyM
-       ; let (subst', bndrs') = Core.cloneRecIdBndrs subst us bndrs
-             env' = env { se_subst = subst' }
-       ; return (env', bndrs') }
-
-newDictBndr :: SpecEnv -> CoreBndr -> SpecM (SpecEnv, CoreBndr)
--- Make up completely fresh binders for the dictionaries
--- Their bindings are going to float outwards
-newDictBndr env@(SE { se_subst = subst }) b
-  = do { uniq <- getUniqueM
-       ; let n    = idName b
-             ty'  = substTyUnchecked subst (idType b)
-             b'   = mkUserLocal (nameOccName n) uniq ManyTy ty' (getSrcSpan n)
-             env' = env { se_subst = subst `Core.extendSubstInScope` b' }
-       ; pure (env', b') }
-
-newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id
-    -- Give the new Id a similar occurrence name to the old one
-newSpecIdSM old_id new_ty join_arity_maybe
-  = do  { uniq <- getUniqueM
-        ; let name    = idName old_id
-              new_occ = mkSpecOcc (nameOccName name)
-              new_id  = mkUserLocal new_occ uniq ManyTy new_ty (getSrcSpan name)
-                          `asJoinId_maybe` join_arity_maybe
-        ; return new_id }
-
-{-
-                Old (but interesting) stuff about unboxed bindings
-                ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-What should we do when a value is specialised to a *strict* unboxed value?
-
-        map_*_* f (x:xs) = let h = f x
-                               t = map f xs
-                           in h:t
-
-Could convert let to case:
-
-        map_*_Int# f (x:xs) = case f x of h# ->
-                              let t = map f xs
-                              in h#:t
-
-This may be undesirable since it forces evaluation here, but the value
-may not be used in all branches of the body. In the general case this
-transformation is impossible since the mutual recursion in a letrec
-cannot be expressed as a case.
-
-There is also a problem with top-level unboxed values, since our
-implementation cannot handle unboxed values at the top level.
-
-Solution: Lift the binding of the unboxed value and extract it when it
-is used:
-
-        map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
-                                  t = map f xs
-                              in case h of
-                                 _Lift h# -> h#:t
-
-Now give it to the simplifier and the _Lifting will be optimised away.
-
-The benefit is that we have given the specialised "unboxed" values a
-very simple lifted semantics and then leave it up to the simplifier to
-optimise it --- knowing that the overheads will be removed in nearly
-all cases.
-
-In particular, the value will only be evaluated in the branches of the
-program which use it, rather than being forced at the point where the
-value is bound. For example:
-
-        filtermap_*_* p f (x:xs)
-          = let h = f x
-                t = ...
-            in case p x of
-                True  -> h:t
-                False -> t
-   ==>
-        filtermap_*_Int# p f (x:xs)
-          = let h = case (f x) of h# -> _Lift h#
-                t = ...
-            in case p x of
-                True  -> case h of _Lift h#
-                           -> h#:t
-                False -> t
-
-The binding for h can still be inlined in the one branch and the
-_Lifting eliminated.
-
-
-Question: When won't the _Lifting be eliminated?
-
-Answer: When they at the top-level (where it is necessary) or when
-inlining would duplicate work (or possibly code depending on
-options). However, the _Lifting will still be eliminated if the
-strictness analyser deems the lifted binding strict.
--}
diff --git a/compiler/GHC/Core/Opt/StaticArgs.hs b/compiler/GHC/Core/Opt/StaticArgs.hs
deleted file mode 100644
--- a/compiler/GHC/Core/Opt/StaticArgs.hs
+++ /dev/null
@@ -1,437 +0,0 @@
-
-
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-************************************************************************
-
-               Static Argument Transformation pass
-
-************************************************************************
-
-May be seen as removing invariants from loops:
-Arguments of recursive functions that do not change in recursive
-calls are removed from the recursion, which is done locally
-and only passes the arguments which effectively change.
-
-Example:
-map = /\ ab -> \f -> \xs -> case xs of
-                 []       -> []
-                 (a:b) -> f a : map f b
-
-as map is recursively called with the same argument f (unmodified)
-we transform it to
-
-map = /\ ab -> \f -> \xs -> let map' ys = case ys of
-                       []     -> []
-                       (a:b) -> f a : map' b
-                in map' xs
-
-Notice that for a compiler that uses lambda lifting this is
-useless as map' will be transformed back to what map was.
-
-We could possibly do the same for big lambdas, but we don't as
-they will eventually be removed in later stages of the compiler,
-therefore there is no penalty in keeping them.
-
-We only apply the SAT when the number of static args is > 2. This
-produces few bad cases.  See
-                should_transform
-in saTransform.
-
-Here are the headline nofib results:
-                  Size    Allocs   Runtime
-Min             +0.0%    -13.7%    -21.4%
-Max             +0.1%     +0.0%     +5.4%
-Geometric Mean  +0.0%     -0.2%     -6.9%
-
-The previous patch, to fix polymorphic floatout demand signatures, is
-essential to make this work well!
--}
-
-module GHC.Core.Opt.StaticArgs ( doStaticArgs ) where
-
-import GHC.Prelude
-
-import GHC.Core
-import GHC.Core.Utils
-import GHC.Core.Type
-import GHC.Core.Coercion
-import GHC.Core.TyCo.Compare( eqType )
-
-import GHC.Types.Var
-import GHC.Types.Id
-import GHC.Types.Name
-import GHC.Types.Var.Env
-import GHC.Types.Unique.Supply
-import GHC.Types.Unique.FM
-import GHC.Types.Var.Set
-import GHC.Types.Unique
-import GHC.Types.Unique.Set
-
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import Data.List (mapAccumL)
-import GHC.Data.FastString
-
-doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram
-doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds
-  where
-    sat_bind_threaded_us us bind =
-        let (us1, us2) = splitUniqSupply us
-        in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet))
-
--- We don't bother to SAT recursive groups since it can lead
--- to massive code expansion: see Andre Santos' thesis for details.
--- This means we only apply the actual SAT to Rec groups of one element,
--- but we want to recurse into the others anyway to discover other binds
-satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo)
-satBind (NonRec binder expr) interesting_ids = do
-    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
-    return (NonRec binder expr', finalizeApp expr_app sat_info_expr)
-satBind (Rec [(binder, rhs)]) interesting_ids = do
-    let interesting_ids' = interesting_ids `addOneToUniqSet` binder
-        (rhs_binders, rhs_body) = collectBinders rhs
-    (rhs_body', sat_info_rhs_body) <- satTopLevelExpr rhs_body interesting_ids'
-    let sat_info_rhs_from_args = unitVarEnv binder (bindersToSATInfo rhs_binders)
-        sat_info_rhs' = mergeIdSATInfo sat_info_rhs_from_args sat_info_rhs_body
-
-        shadowing = binder `elementOfUniqSet` interesting_ids
-        sat_info_rhs'' = if shadowing
-                        then sat_info_rhs' `delFromUFM` binder -- For safety
-                        else sat_info_rhs'
-
-    bind' <- saTransformMaybe binder (lookupUFM sat_info_rhs' binder)
-                              rhs_binders rhs_body'
-    return (bind', sat_info_rhs'')
-satBind (Rec pairs) interesting_ids = do
-    let (binders, rhss) = unzip pairs
-    rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss
-    let (rhss', sat_info_rhss') = unzip rhss_SATed
-    return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss')
-
-data App = VarApp Id | TypeApp Type | CoApp Coercion
-data Staticness a = Static a | NotStatic
-
-type IdAppInfo = (Id, SATInfo)
-
-type SATInfo = [Staticness App]
-type IdSATInfo = IdEnv SATInfo
-emptyIdSATInfo :: IdSATInfo
-emptyIdSATInfo = emptyUFM
-
-{-
-pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info))
-  where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info)
--}
-
-pprSATInfo :: SATInfo -> SDoc
-pprSATInfo staticness = hcat $ map pprStaticness staticness
-
-pprStaticness :: Staticness App -> SDoc
-pprStaticness (Static (VarApp _))  = text "SV"
-pprStaticness (Static (TypeApp _)) = text "ST"
-pprStaticness (Static (CoApp _))   = text "SC"
-pprStaticness NotStatic            = text "NS"
-
-
-mergeSATInfo :: SATInfo -> SATInfo -> SATInfo
-mergeSATInfo l r = zipWith mergeSA l r
-  where
-    mergeSA NotStatic _ = NotStatic
-    mergeSA _ NotStatic = NotStatic
-    mergeSA (Static (VarApp v)) (Static (VarApp v'))
-      | v == v'   = Static (VarApp v)
-      | otherwise = NotStatic
-    mergeSA (Static (TypeApp t)) (Static (TypeApp t'))
-      | t `eqType` t' = Static (TypeApp t)
-      | otherwise     = NotStatic
-    mergeSA (Static (CoApp c)) (Static (CoApp c'))
-      | c `eqCoercion` c' = Static (CoApp c)
-      | otherwise             = NotStatic
-    mergeSA _ _  = pprPanic "mergeSATInfo" $
-                          text "Left:"
-                       <> pprSATInfo l <> text ", "
-                       <> text "Right:"
-                       <> pprSATInfo r
-
-mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo
-mergeIdSATInfo = plusUFM_C mergeSATInfo
-
-mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo
-mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo
-
-bindersToSATInfo :: [Id] -> SATInfo
-bindersToSATInfo vs = map (Static . binderToApp) vs
-    where binderToApp v | isId v    = VarApp v
-                        | isTyVar v = TypeApp $ mkTyVarTy v
-                        | otherwise = CoApp $ mkCoVarCo v
-
-finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo
-finalizeApp Nothing id_sat_info = id_sat_info
-finalizeApp (Just (v, sat_info')) id_sat_info =
-    let sat_info'' = case lookupUFM id_sat_info v of
-                        Nothing -> sat_info'
-                        Just sat_info -> mergeSATInfo sat_info sat_info'
-    in extendVarEnv id_sat_info v sat_info''
-
-satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo)
-satTopLevelExpr expr interesting_ids = do
-    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
-    return (expr', finalizeApp expr_app sat_info_expr)
-
-satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)
-satExpr var@(Var v) interesting_ids = do
-    let app_info = if v `elementOfUniqSet` interesting_ids
-                   then Just (v, [])
-                   else Nothing
-    return (var, emptyIdSATInfo, app_info)
-
-satExpr lit@(Lit _) _ =
-    return (lit, emptyIdSATInfo, Nothing)
-
-satExpr (Lam binders body) interesting_ids = do
-    (body', sat_info, this_app) <- satExpr body interesting_ids
-    return (Lam binders body', finalizeApp this_app sat_info, Nothing)
-
-satExpr (App fn arg) interesting_ids = do
-    (fn', sat_info_fn, fn_app) <- satExpr fn interesting_ids
-    let satRemainder = boring fn' sat_info_fn
-    case fn_app of
-        Nothing -> satRemainder Nothing
-        Just (fn_id, fn_app_info) ->
-            -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface)
-            let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness])
-            in case arg of
-                Type t     -> satRemainderWithStaticness $ Static (TypeApp t)
-                Coercion c -> satRemainderWithStaticness $ Static (CoApp c)
-                Var v      -> satRemainderWithStaticness $ Static (VarApp v)
-                _          -> satRemainderWithStaticness $ NotStatic
-  where
-    boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)
-    boring fn' sat_info_fn app_info =
-        do (arg', sat_info_arg, arg_app) <- satExpr arg interesting_ids
-           let sat_info_arg' = finalizeApp arg_app sat_info_arg
-               sat_info = mergeIdSATInfo sat_info_fn sat_info_arg'
-           return (App fn' arg', sat_info, app_info)
-
-satExpr (Case expr bndr ty alts) interesting_ids = do
-    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
-    let sat_info_expr' = finalizeApp expr_app sat_info_expr
-
-    zipped_alts' <- mapM satAlt alts
-    let (alts', sat_infos_alts) = unzip zipped_alts'
-    return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing)
-  where
-    satAlt (Alt con bndrs expr) = do
-        (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids
-        return (Alt con bndrs expr', sat_info_expr)
-
-satExpr (Let bind body) interesting_ids = do
-    (body', sat_info_body, body_app) <- satExpr body interesting_ids
-    (bind', sat_info_bind) <- satBind bind interesting_ids
-    return (Let bind' body', mergeIdSATInfo sat_info_body sat_info_bind, body_app)
-
-satExpr (Tick tickish expr) interesting_ids = do
-    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
-    return (Tick tickish expr', sat_info_expr, expr_app)
-
-satExpr ty@(Type _) _ =
-    return (ty, emptyIdSATInfo, Nothing)
-
-satExpr co@(Coercion _) _ =
-    return (co, emptyIdSATInfo, Nothing)
-
-satExpr (Cast expr coercion) interesting_ids = do
-    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
-    return (Cast expr' coercion, sat_info_expr, expr_app)
-
-{-
-************************************************************************
-
-                Static Argument Transformation Monad
-
-************************************************************************
--}
-
-type SatM result = UniqSM result
-
-runSAT :: UniqSupply -> SatM a -> a
-runSAT = initUs_
-
-newUnique :: SatM Unique
-newUnique = getUniqueM
-
-{-
-************************************************************************
-
-                Static Argument Transformation Monad
-
-************************************************************************
-
-To do the transformation, the game plan is to:
-
-1. Create a small nonrecursive RHS that takes the
-   original arguments to the function but discards
-   the ones that are static and makes a call to the
-   SATed version with the remainder. We intend that
-   this will be inlined later, removing the overhead
-
-2. Bind this nonrecursive RHS over the original body
-   WITH THE SAME UNIQUE as the original body so that
-   any recursive calls to the original now go via
-   the small wrapper
-
-3. Rebind the original function to a new one which contains
-   our SATed function and just makes a call to it:
-   we call the thing making this call the local body
-
-Example: transform this
-
-    map :: forall a b. (a->b) -> [a] -> [b]
-    map = /\ab. \(f:a->b) (as:[a]) -> body[map]
-to
-    map :: forall a b. (a->b) -> [a] -> [b]
-    map = /\ab. \(f:a->b) (as:[a]) ->
-         letrec map' :: [a] -> [b]
-                    -- The "worker function
-                map' = \(as:[a]) ->
-                         let map :: forall a' b'. (a -> b) -> [a] -> [b]
-                                -- The "shadow function
-                             map = /\a'b'. \(f':(a->b) (as:[a]).
-                                   map' as
-                         in body[map]
-         in map' as
-
-Note [Shadow binding]
-~~~~~~~~~~~~~~~~~~~~~
-The calls to the inner map inside body[map] should get inlined
-by the local re-binding of 'map'.  We call this the "shadow binding".
-
-But we can't use the original binder 'map' unchanged, because
-it might be exported, in which case the shadow binding won't be
-discarded as dead code after it is inlined.
-
-So we use a hack: we make a new SysLocal binder with the *same* unique
-as binder.  (Another alternative would be to reset the export flag.)
-
-Note [Binder type capture]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Notice that in the inner map (the "shadow function"), the static arguments
-are discarded -- it's as if they were underscores.  Instead, mentions
-of these arguments (notably in the types of dynamic arguments) are bound
-by the *outer* lambdas of the main function.  So we must make up fresh
-names for the static arguments so that they do not capture variables
-mentioned in the types of dynamic args.
-
-In the map example, the shadow function must clone the static type
-argument a,b, giving a',b', to ensure that in the \(as:[a]), the 'a'
-is bound by the outer forall.  We clone f' too for consistency, but
-that doesn't matter either way because static Id arguments aren't
-mentioned in the shadow binding at all.
-
-If we don't we get something like this:
-
-[Exported]
-[Arity 3]
-GHC.Base.until =
-  \ (@ a_aiK)
-    (p_a6T :: a_aiK -> GHC.Types.Bool)
-    (f_a6V :: a_aiK -> a_aiK)
-    (x_a6X :: a_aiK) ->
-    letrec {
-      sat_worker_s1aU :: a_aiK -> a_aiK
-      []
-      sat_worker_s1aU =
-        \ (x_a6X :: a_aiK) ->
-          let {
-            sat_shadow_r17 :: forall a_a3O.
-                              (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O
-            []
-            sat_shadow_r17 =
-              \ (@ a_aiK)
-                (p_a6T :: a_aiK -> GHC.Types.Bool)
-                (f_a6V :: a_aiK -> a_aiK)
-                (x_a6X :: a_aiK) ->
-                sat_worker_s1aU x_a6X } in
-          case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] {
-            GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X);
-            GHC.Types.True -> x_a6X
-          }; } in
-    sat_worker_s1aU x_a6X
-
-Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK
-type argument. This is bad because it means the application sat_worker_s1aU x_a6X
-is not well typed.
--}
-
-saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind
-saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body
-  | Just arg_staticness <- maybe_arg_staticness
-  , should_transform arg_staticness
-  = saTransform binder arg_staticness rhs_binders rhs_body
-  | otherwise
-  = return (Rec [(binder, mkLams rhs_binders rhs_body)])
-  where
-    should_transform staticness = n_static_args > 1 -- THIS IS THE DECISION POINT
-      where
-        n_static_args = count isStaticValue staticness
-
-saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind
-saTransform binder arg_staticness rhs_binders rhs_body
-  = do  { shadow_lam_bndrs <- mapM clone binders_w_staticness
-        ; uniq             <- newUnique
-        ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) }
-  where
-    -- Running example: foldr
-    -- foldr \alpha \beta c n xs = e, for some e
-    -- arg_staticness = [Static TypeApp, Static TypeApp, Static VarApp, Static VarApp, NonStatic]
-    -- rhs_binders = [\alpha, \beta, c, n, xs]
-    -- rhs_body = e
-
-    binders_w_staticness = rhs_binders `zip` (arg_staticness ++ repeat NotStatic)
-                                        -- Any extra args are assumed NotStatic
-
-    non_static_args :: [Var]
-            -- non_static_args = [xs]
-            -- rhs_binders_without_type_capture = [\alpha', \beta', c, n, xs]
-    non_static_args = [v | (v, NotStatic) <- binders_w_staticness]
-
-    clone (bndr, NotStatic) = return bndr
-    clone (bndr, _        ) = do { uniq <- newUnique
-                                 ; return (setVarUnique bndr uniq) }
-
-    -- new_rhs = \alpha beta c n xs ->
-    --           let sat_worker = \xs -> let sat_shadow = \alpha' beta' c n xs ->
-    --                                       sat_worker xs
-    --                                   in e
-    --           in sat_worker xs
-    mk_new_rhs uniq shadow_lam_bndrs
-        = mkLams rhs_binders $
-          Let (Rec [(rec_body_bndr, rec_body)])
-          local_body
-        where
-          local_body = mkVarApps (Var rec_body_bndr) non_static_args
-
-          rec_body = mkLams non_static_args $
-                     Let (NonRec shadow_bndr shadow_rhs) rhs_body
-
-            -- See Note [Binder type capture]
-          shadow_rhs = mkLams shadow_lam_bndrs local_body
-            -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs
-
-          rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq ManyTy (exprType rec_body)
-            -- rec_body_bndr = sat_worker
-
-            -- See Note [Shadow binding]; make a SysLocal
-          shadow_bndr = mkSysLocal (occNameFS (getOccName binder))
-                                   (idUnique binder)
-                                   ManyTy
-                                   (exprType shadow_rhs)
-
-isStaticValue :: Staticness App -> Bool
-isStaticValue (Static (VarApp _)) = True
-isStaticValue _                   = False
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
deleted file mode 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ /dev/null
@@ -1,1058 +0,0 @@
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-
-\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
--}
-
-
-module GHC.Core.Opt.WorkWrap
- ( WwOpts (..)
- , wwTopBinds
- )
-where
-
-import GHC.Prelude
-
-import GHC.Core
-import GHC.Core.Unfold.Make
-import GHC.Core.Utils  ( exprType, exprIsHNF )
-import GHC.Core.Type
-import GHC.Core.Opt.WorkWrap.Utils
-import GHC.Core.SimpleOpt
-
-import GHC.Types.Var
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.Unique.Supply
-import GHC.Types.Basic
-import GHC.Types.Demand
-import GHC.Types.Cpr
-import GHC.Types.SourceText
-import GHC.Types.Unique
-
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Monad
-import GHC.Core.DataCon
-
-{-
-We take Core bindings whose binders have:
-
-\begin{enumerate}
-
-\item Strictness attached (by the front-end of the strictness
-analyser), and / or
-
-\item Constructed Product Result information attached by the CPR
-analysis pass.
-
-\end{enumerate}
-
-and we return some ``plain'' bindings which have been
-worker/wrapper-ified, meaning:
-
-\begin{enumerate}
-
-\item Functions have been split into workers and wrappers where
-appropriate.  If a function has both strictness and CPR properties
-then only one worker/wrapper doing both transformations is produced;
-
-\item Binders' @IdInfos@ have been updated to reflect the existence of
-these workers/wrappers (this is where we get STRICTNESS and CPR pragma
-info for exported values).
-\end{enumerate}
--}
-
-wwTopBinds :: WwOpts -> UniqSupply -> CoreProgram -> CoreProgram
-
-wwTopBinds ww_opts us top_binds
-  = initUs_ us $ do
-    top_binds' <- mapM (wwBind ww_opts) top_binds
-    return (concat top_binds')
-
-{-
-************************************************************************
-*                                                                      *
-\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@}
-*                                                                      *
-************************************************************************
-
-@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in
-turn.  Non-recursive case first, then recursive...
--}
-
-wwBind  :: WwOpts
-        -> CoreBind
-        -> UniqSM [CoreBind]    -- returns a WwBinding intermediate form;
-                                -- the caller will convert to Expr/Binding,
-                                -- as appropriate.
-
-wwBind ww_opts (NonRec binder rhs) = do
-    new_rhs   <- wwExpr ww_opts rhs
-    new_pairs <- tryWW ww_opts NonRecursive binder new_rhs
-    return [NonRec b e | (b,e) <- new_pairs]
-      -- Generated bindings must be non-recursive
-      -- because the original binding was.
-
-wwBind ww_opts (Rec pairs)
-  = return . Rec <$> concatMapM do_one pairs
-  where
-    do_one (binder, rhs) = do new_rhs <- wwExpr ww_opts rhs
-                              tryWW ww_opts Recursive binder new_rhs
-
-{-
-@wwExpr@ basically just walks the tree, looking for appropriate
-annotations that can be used. Remember it is @wwBind@ that does the
-matching by looking for strict arguments of the correct type.
-@wwExpr@ is a version that just returns the ``Plain'' Tree.
--}
-
-wwExpr :: WwOpts -> CoreExpr -> UniqSM CoreExpr
-
-wwExpr _ e@(Type {}) = return e
-wwExpr _ e@(Coercion {}) = return e
-wwExpr _ e@(Lit  {}) = return e
-wwExpr _ e@(Var  {}) = return e
-
-wwExpr ww_opts (Lam binder expr)
-  = Lam new_binder <$> wwExpr ww_opts expr
-  where new_binder | isId binder = zapIdUsedOnceInfo binder
-                   | otherwise   = binder
-  -- See Note [Zapping Used Once info in WorkWrap]
-
-wwExpr ww_opts (App f a)
-  = App <$> wwExpr ww_opts f <*> wwExpr ww_opts a
-
-wwExpr ww_opts (Tick note expr)
-  = Tick note <$> wwExpr ww_opts expr
-
-wwExpr ww_opts (Cast expr co) = do
-    new_expr <- wwExpr ww_opts expr
-    return (Cast new_expr co)
-
-wwExpr ww_opts (Let bind expr)
-  = mkLets <$> wwBind ww_opts bind <*> wwExpr ww_opts expr
-
-wwExpr ww_opts (Case expr binder ty alts) = do
-    new_expr <- wwExpr ww_opts expr
-    new_alts <- mapM ww_alt alts
-    let new_binder = zapIdUsedOnceInfo binder
-      -- See Note [Zapping Used Once info in WorkWrap]
-    return (Case new_expr new_binder ty new_alts)
-  where
-    ww_alt (Alt con binders rhs) = do
-        new_rhs <- wwExpr ww_opts rhs
-        let new_binders = [ if isId b then zapIdUsedOnceInfo b else b
-                          | b <- binders ]
-           -- See Note [Zapping Used Once info in WorkWrap]
-        return (Alt con new_binders new_rhs)
-
-{-
-************************************************************************
-*                                                                      *
-\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair}
-*                                                                      *
-************************************************************************
-
-@tryWW@ just accumulates arguments, converts strictness info from the
-front-end into the proper form, then calls @mkWwBodies@ to do
-the business.
-
-The only reason this is monadised is for the unique supply.
-
-Note [Don't w/w INLINE things]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's very important to refrain from w/w-ing an INLINE function (ie one
-with a stable unfolding) because the wrapper will then overwrite the
-old stable unfolding with the wrapper code.
-
-Furthermore, if the programmer has marked something as INLINE,
-we may lose by w/w'ing it.
-
-If the strictness analyser is run twice, this test also prevents
-wrappers (which are INLINEd) from being re-done.  (You can end up with
-several liked-named Ids bouncing around at the same time---absolute
-mischief.)
-
-Notice that we refrain from w/w'ing an INLINE function even if it is
-in a recursive group.  It might not be the loop breaker.  (We could
-test for loop-breaker-hood, but I'm not sure that ever matters.)
-
-Note [Worker/wrapper for INLINABLE functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we have
-  {-# INLINABLE f #-}
-  f :: Ord a => [a] -> Int -> a
-  f x y = ....f....
-
-where f is strict in y, we might get a more efficient loop by w/w'ing
-f.  But that would make a new unfolding which would overwrite the old
-one! So the function would no longer be INLINABLE, and in particular
-will not be specialised at call sites in other modules.
-
-This comes up in practice (#6056).
-
-Solution:
-
-* Do the w/w for strictness analysis, even for INLINABLE functions
-
-* Transfer the Stable unfolding to the *worker*.  How do we "transfer
-  the unfolding"? Easy: by using the old one, wrapped in work_fn! See
-  GHC.Core.Unfold.Make.mkWorkerUnfolding.
-
-* We use the /original, user-specified/ function's InlineSpec pragma
-  for both the wrapper and the worker (see `mkStrWrapperInlinePrag`).
-  So if f is INLINEABLE, both worker and wrapper will get an InlineSpec
-  of (Inlinable "blah").
-
-  It's important that both get this, because the specialiser uses
-  the existence of a /user-specified/ INLINE/INLINABLE pragma to
-  drive specialisation of imported functions.  See  GHC.Core.Opt.Specialise
-  Note [Specialising imported functions]
-
-* Remember, the subsequent inlining behaviour of the wrapper is expressed by
-  (a) the stable unfolding
-  (b) the unfolding guidance of UnfWhen
-  (c) the inl_act activation (see Note [Wrapper activation]
-
-For our {-# INLINEABLE f #-} example above, we will get something a
-bit like like this:
-
-  {-# Has stable unfolding, active in phase 2;
-      plus InlineSpec = INLINEABLE #-}
-  f :: Ord a => [a] -> Int -> a
-  f d x y = case y of I# y' -> fw d x y'
-
-  {-# Has stable unfolding, plus InlineSpec = INLINEABLE #-}
-  fw :: Ord a => [a] -> Int# -> a
-  fw d x y' = let y = I# y' in ...f...
-
-
-(Historical note: we used to always give the wrapper an INLINE pragma,
-but CSE will not happen if there is a user-specified pragma, but
-should happen for w/w’ed things (#14186).  But now we simply propagate
-any user-defined pragma info, so we'll defeat CSE (rightly) only when
-there is a user-supplied INLINE/INLINEABLE pragma.)
-
-Note [No worker/wrapper for record selectors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We sometimes generate a lot of record selectors, and generally the
-don't benefit from worker/wrapper.  Yes, mkWwBodies would find a w/w split,
-but it is then suppressed by the certainlyWillInline test in splitFun.
-
-The wasted effort in mkWwBodies makes a measurable difference in
-compile time (see MR !2873), so although it's a terribly ad-hoc test,
-we just check here for record selectors, and do a no-op in that case.
-
-I did look for a generalisation, so that it's not just record
-selectors that benefit.  But you'd need a cheap test for "this
-function will definitely get a w/w split" and that's hard to predict
-in advance...the logic in mkWwBodies is complex. So I've left the
-super-simple test, with this Note to explain.
-
-NB: record selectors are ordinary functions, inlined iff GHC wants to,
-so won't be caught by the preceding isInlineUnfolding test in tryWW.
-
-Note [Worker/wrapper for NOINLINE functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We used to disable worker/wrapper for NOINLINE things, but it turns out
-this can cause unnecessary reboxing of values. Consider
-
-  {-# NOINLINE f #-}
-  f :: Int -> a
-  f x = error (show x)
-
-  g :: Bool -> Bool -> Int -> Int
-  g True  True  p = f p
-  g False True  p = p + 1
-  g b     False p = g b True p
-
-the strictness analysis will discover f and g are strict, but because f
-has no wrapper, the worker for g will rebox p. So we get
-
-  $wg x y p# =
-    let p = I# p# in  -- Yikes! Reboxing!
-    case x of
-      False ->
-        case y of
-          False -> $wg False True p#
-          True -> +# p# 1#
-      True ->
-        case y of
-          False -> $wg True True p#
-          True -> case f p of { }
-
-  g x y p = case p of (I# p#) -> $wg x y p#
-
-Now, in this case the reboxing will float into the True branch, and so
-the allocation will only happen on the error path. But it won't float
-inwards if there are multiple branches that call (f p), so the reboxing
-will happen on every call of g. Disaster.
-
-Solution: do worker/wrapper even on NOINLINE things; but move the
-NOINLINE pragma to the worker.
-
-(See #13143 for a real-world example.)
-
-It is crucial that we do this for *all* NOINLINE functions. #10069
-demonstrates what happens when we promise to w/w a (NOINLINE) leaf
-function, but fail to deliver:
-
-  data C = C Int# Int#
-
-  {-# NOINLINE c1 #-}
-  c1 :: C -> Int#
-  c1 (C _ n) = n
-
-  {-# NOINLINE fc #-}
-  fc :: C -> Int#
-  fc c = 2 *# c1 c
-
-Failing to w/w `c1`, but still w/wing `fc` leads to the following code:
-
-  c1 :: C -> Int#
-  c1 (C _ n) = n
-
-  $wfc :: Int# -> Int#
-  $wfc n = let c = C 0# n in 2 #* c1 c
-
-  fc :: C -> Int#
-  fc (C _ n) = $wfc n
-
-Yikes! The reboxed `C` in `$wfc` can't cancel out, so we are in a bad place.
-This generalises to any function that derives its strictness signature from
-its callees, so we have to make sure that when a function announces particular
-strictness properties, we have to w/w them accordingly, even if it means
-splitting a NOINLINE function.
-
-Note [Worker activation]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Follows on from Note [Worker/wrapper for INLINABLE functions]
-
-It is *vital* that if the worker gets an INLINABLE pragma (from the
-original function), then the worker has the same phase activation as
-the wrapper (or later).  That is necessary to allow the wrapper to
-inline into the worker's unfolding: see GHC.Core.Opt.Simplify.Utils
-Note [Simplifying inside stable unfoldings].
-
-If the original is NOINLINE, it's important that the worker inherits the
-original activation. Consider
-
-  {-# NOINLINE expensive #-}
-  expensive x = x + 1
-
-  f y = let z = expensive y in ...
-
-If expensive's worker inherits the wrapper's activation,
-we'll get this (because of the compromise in point (2) of
-Note [Wrapper activation])
-
-  {-# NOINLINE[Final] $wexpensive #-}
-  $wexpensive x = x + 1
-  {-# INLINE[Final] expensive #-}
-  expensive x = $wexpensive x
-
-  f y = let z = expensive y in ...
-
-and $wexpensive will be immediately inlined into expensive, followed by
-expensive into f. This effectively removes the original NOINLINE!
-
-Otherwise, nothing is lost by giving the worker the same activation as the
-wrapper, because the worker won't have any chance of inlining until the
-wrapper does; there's no point in giving it an earlier activation.
-
-Note [Don't w/w inline small non-loop-breaker things]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In general, we refrain from w/w-ing *small* functions, which are not
-loop breakers, because they'll inline anyway.  But we must take care:
-it may look small now, but get to be big later after other inlining
-has happened.  So we take the precaution of adding a StableUnfolding
-for any such functions.
-
-I made this change when I observed a big function at the end of
-compilation with a useful strictness signature but no w-w.  (It was
-small during demand analysis, we refrained from w/w, and then got big
-when something was inlined in its rhs.) When I measured it on nofib,
-it didn't make much difference; just a few percent improved allocation
-on one benchmark (bspt/Euclid.space).  But nothing got worse.
-
-There is an infelicity though.  We may get something like
-      f = g val
-==>
-      g x = case gw x of r -> I# r
-
-      f {- InlineStable, Template = g val -}
-      f = case gw x of r -> I# r
-
-The code for f duplicates that for g, without any real benefit. It
-won't really be executed, because calls to f will go via the inlining.
-
-Note [Don't w/w join points for CPR]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There's no point in exploiting CPR info on a join point. If the whole function
-is getting CPR'd, then the case expression around the worker function will get
-pushed into the join point by the simplifier, which will have the same effect
-that w/w'ing for CPR would have - the result will be returned in an unboxed
-tuple.
-
-  f z = let join j x y = (x+1, y+1)
-        in case z of A -> j 1 2
-                     B -> j 2 3
-
-  =>
-
-  f z = case $wf z of (# a, b #) -> (a, b)
-  $wf z = case (let join j x y = (x+1, y+1)
-                in case z of A -> j 1 2
-                             B -> j 2 3) of (a, b) -> (# a, b #)
-
-  =>
-
-  f z = case $wf z of (# a, b #) -> (a, b)
-  $wf z = let join j x y = (# x+1, y+1 #)
-          in case z of A -> j 1 2
-                       B -> j 2 3
-
-Note that we still want to give `j` the CPR property, so that `f` has it. So
-CPR *analyse* join points as regular functions, but don't *transform* them.
-
-We could retain the CPR /signature/ on the worker after W/W, but it would
-become outright wrong if the Simplifier pushes a non-trivial continuation
-into it. For example:
-    case (let $j x = (x,x) in ...) of alts
-    ==>
-    let $j x = case (x,x) of alts in case ... of alts
-Before pushing the case in, `$j` has the CPR property, but not afterwards.
-
-So we simply zap the CPR signature for join pints as part of the W/W pass.
-The signature served its purpose during CPR analysis in propagating the
-CPR property of `$j`.
-
-Doing W/W for returned products on a join point would be tricky anyway, as the
-worker could not be a join point because it would not be tail-called. However,
-doing the *argument* part of W/W still works for join points, since the wrapper
-body will make a tail call:
-
-  f z = let join j x y = x + y
-        in ...
-
-  =>
-
-  f z = let join $wj x# y# = x# +# y#
-                 j x y = case x of I# x# ->
-                         case y of I# y# ->
-                         $wj x# y#
-        in ...
-
-Note [Wrapper activation]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-When should the wrapper inlining be active?
-
-1. It must not be active earlier than the current Activation of the Id,
-   because we must give rewrite rules mentioning the wrapper and
-   specialisation a chance to fire.
-   See Note [Worker/wrapper for INLINABLE functions]
-   and Note [Worker activation]
-
-2. It should be active at some point, despite (1) because of
-   Note [Worker/wrapper for NOINLINE functions]
-
-3. For ordinary functions with no pragmas we want to inline the
-   wrapper as early as possible (#15056).  Suppose another module
-   defines    f !x xs = ... foldr k z xs ...
-   and suppose we have the usual foldr/build RULE.  Then if we have
-   a call `f x [1..x]`, we'd expect to inline f and the RULE will fire.
-   But if f is w/w'd (which it might be), we want the inlining to
-   occur just as if it hadn't been.
-
-   (This only matters if f's RHS is big enough to w/w, but small
-   enough to inline given the call site, but that can happen.)
-
-4. We do not want to inline the wrapper before specialisation.
-         module Foo where
-           f :: Num a => a -> Int -> a
-           f n 0 = n              -- Strict in the Int, hence wrapper
-           f n x = f (n+n) (x-1)
-
-           g :: Int -> Int
-           g x = f x x            -- Provokes a specialisation for f
-
-         module Bar where
-           import Foo
-
-           h :: Int -> Int
-           h x = f 3 x
-
-   In module Bar we want to give specialisations a chance to fire
-   before inlining f's wrapper.
-
-   (Historical note: At one stage I tried making the wrapper inlining
-   always-active, and that had a very bad effect on nofib/imaginary/x2n1;
-   a wrapper was inlined before the specialisation fired.)
-
-4a. If we have
-      {-# SPECIALISE foo :: (Int,Int) -> Bool -> Int #-}
-      {-# NOINLINE [n] foo #-}
-    then specialisation will generate a SPEC rule active from Phase n.
-    See Note [Auto-specialisation and RULES] in GHC.Core.Opt.Specialise
-    This SPEC specialisation rule will compete with inlining, but we don't
-    mind that, because if inlining succeeds, it should be better.
-
-    Now, if we w/w foo, we must ensure that the wrapper (which is very
-    keen to inline) has a phase /after/ 'n', else it'll always "win" over
-    the SPEC rule -- disaster (#20709).
-
-Conclusion: the activation for the wrapper should be the /later/ of
-  (a) the current activation of the function, or FinalPhase if it is NOINLINE
-  (b) one phase /after/ the activation of any rules
-This is implemented by mkStrWrapperInlinePrag.
-
-Reminder: Note [Don't w/w INLINE things], so we don't need to worry
-          about INLINE things here.
-
-
-What if `foo` has no specialisations, is worker/wrappered (with the
-wrapper inlining very early), and exported; and then in an importing
-module we have {-# SPECIALISE foo : ... #-}?
-
-Well then, we'll specialise foo's wrapper, which will expose a
-specialisation for foo's worker, which we will do too.  That seems
-fine.  (To work reliably, `foo` would need an INLINABLE pragma,
-in which case we don't unpack dictionaries for the worker; see
-see Note [Do not unbox class dictionaries].)
-
-Note [Drop absent bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#19824):
-   let t = ...big...
-   in ...(f t x)...
-
-were `f` ignores its first argument.  With luck f's wrapper will inline
-thereby dropping `t`, but maybe not: the arguments to f all look boring.
-
-So we pre-empt the problem by replacing t's RHS with an absent filler.
-Simple and effective.
--}
-
-tryWW   :: WwOpts
-        -> RecFlag
-        -> Id                           -- The fn binder
-        -> CoreExpr                     -- The bound rhs; its innards
-                                        --   are already ww'd
-        -> UniqSM [(Id, CoreExpr)]      -- either *one* or *two* pairs;
-                                        -- if one, then no worker (only
-                                        -- the orig "wrapper" lives on);
-                                        -- if two, then a worker and a
-                                        -- wrapper.
-tryWW ww_opts is_rec fn_id rhs
-  -- See Note [Drop absent bindings]
-  | isAbsDmd (demandInfo fn_info)
-  , not (isJoinId fn_id)
-  , Just filler <- mkAbsentFiller ww_opts fn_id NotMarkedStrict
-  = return [(new_fn_id, filler)]
-
-  -- See Note [Don't w/w INLINE things]
-  | hasInlineUnfolding fn_info
-  = return [(new_fn_id, rhs)]
-
-  -- See Note [No worker/wrapper for record selectors]
-  | isRecordSelector fn_id
-  = return [ (new_fn_id, rhs ) ]
-
-  -- Don't w/w OPAQUE things
-  -- See Note [OPAQUE pragma]
-  --
-  -- Whilst this check might seem superfluous, since we strip boxity
-  -- information in GHC.Core.Opt.DmdAnal.finaliseArgBoxities and
-  -- CPR information in GHC.Core.Opt.CprAnal.cprAnalBind, it actually
-  -- isn't. That is because we would still perform w/w when:
-  --
-  -- - An argument is used strictly, and -fworker-wrapper-cbv is
-  --   enabled, or,
-  -- - When demand analysis marks an argument as absent.
-  --
-  -- In a debug build we do assert that boxity and CPR information
-  -- are actually stripped, since we want to prevent callers of OPAQUE
-  -- things to do reboxing. See:
-  -- - Note [The OPAQUE pragma and avoiding the reboxing of arguments]
-  -- - Note [The OPAQUE pragma and avoiding the reboxing of results]
-  | isOpaquePragma (inlinePragInfo fn_info)
-  = assertPpr (onlyBoxedArguments (dmdSigInfo fn_info) &&
-               isTopCprSig (cprSigInfo fn_info))
-              (text "OPAQUE fun with boxity" $$
-               ppr new_fn_id $$
-               ppr (dmdSigInfo fn_info) $$
-               ppr (cprSigInfo fn_info) $$
-               ppr rhs) $
-    return [ (new_fn_id, rhs) ]
-
-  -- Do this even if there is a NOINLINE pragma
-  -- See Note [Worker/wrapper for NOINLINE functions]
-  | is_fun
-  = splitFun ww_opts new_fn_id rhs
-
-  -- See Note [Thunk splitting]
-  | isNonRec is_rec, is_thunk
-  = splitThunk ww_opts is_rec new_fn_id rhs
-
-  | otherwise
-  = return [ (new_fn_id, rhs) ]
-
-  where
-    fn_info        = idInfo fn_id
-    (wrap_dmds, _) = splitDmdSig (dmdSigInfo fn_info)
-    new_fn_id      = zap_join_cpr $ zap_usage fn_id
-
-    zap_usage = zapIdUsedOnceInfo . zapIdUsageEnvInfo
-        -- See Note [Zapping DmdEnv after Demand Analyzer] and
-        -- See Note [Zapping Used Once info in WorkWrap]
-
-    zap_join_cpr id
-      | isJoinId id = id `setIdCprSig` topCprSig
-      | otherwise   = id
-        -- See Note [Don't w/w join points for CPR]
-
-    is_fun     = notNull wrap_dmds || isJoinId fn_id
-    is_thunk   = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id)
-                            && not (isUnliftedType (idType fn_id))
-
-{-
-Note [Zapping DmdEnv after Demand Analyzer]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In the worker-wrapper pass we zap the DmdEnv.  Why?
- (a) it is never used again
- (b) it wastes space
- (c) it becomes incorrect as things are cloned, because
-     we don't push the substitution into it
-
-Why here?
- * Because we don’t want to do it in the Demand Analyzer, as we never know
-   there when we are doing the last pass.
- * We want them to be still there at the end of DmdAnal, so that
-   -ddump-str-anal contains them.
- * We don’t want a second pass just for that.
- * WorkWrap looks at all bindings anyway.
-
-We also need to do it in TidyCore.tidyLetBndr to clean up after the
-final, worker/wrapper-less run of the demand analyser (see
-Note [Final Demand Analyser run] in GHC.Core.Opt.DmdAnal).
-
-Note [Zapping Used Once info in WorkWrap]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-During the work/wrap pass, using zapIdUsedOnceInfo, we zap the "used once" info
-* on every binder (let binders, case binders, lambda binders)
-* in both demands and in strictness signatures
-* recursively
-
-Why?
- * The simplifier may happen to transform code in a way that invalidates the
-   data (see #11731 for an example).
- * It is not used in later passes, up to code generation.
-
-At first it's hard to see how the simplifier might invalidate it (and
-indeed for a while I thought it couldn't: #19482), but it's not quite
-as simple as I thought.  Consider this:
-  {-# STRICTNESS SIG <SP(M,A)> #-}
-  f p = let v = case p of (a,b) -> a
-        in p `seq` (v,v)
-
-I think we'll give `f` the strictness signature `<SP(M,A)>`, where the
-`M` says that we'll evaluate the first component of the pair at most
-once.  Why?  Because the RHS of the thunk `v` is evaluated at most
-once.
-
-But now let's worker/wrapper f:
-  {-# STRICTNESS SIG <M> #-}
-  $wf p1 = let p2 = absentError "urk" in
-           let p = (p1,p2) in
-           let v = case p of (a,b) -> a
-           in p `seq` (v,v)
-
-where I've gotten the demand on `p1` by decomposing the P(M,A) argument demand.
-This rapidly simplifies to
-  {-# STRICTNESS SIG <M> #-}
-  $wf p1 = let v = p1 in
-           (v,v)
-
-and thence to `(p1,p1)` by inlining the trivial let. Now the demand on `p1` should
-not be at most once!!
-
-Conclusion: used-once info is fragile to simplification, because of
-the non-monotonic behaviour of let's, which turn used-many into
-used-once.  So indeed we should zap this info in worker/wrapper.
-
-Conclusion: kill it during worker/wrapper, using `zapUsedOnceInfo`.
-Both the *demand signature* of the binder, and the *demand-info* of
-the binder.  Moreover, do so recursively.
-
-You might wonder: why do we generate used-once info if we then throw
-it away.  The main reason is that we do a final run of the demand analyser,
-immediately before CoreTidy, which is /not/ followed by worker/wrapper; it
-is there only to generate used-once info for single-entry thunks.
-
-Note [Don't eta expand in w/w]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A binding where the manifestArity of the RHS is less than idArity of
-the binder means GHC.Core.Opt.Arity didn't eta expand that binding
-When this happens, it does so for a reason (see Note [Arity invariants for bindings]
-in GHC.Core.Opt.Arity) and we probably have a PAP, cast or trivial expression
-as RHS.
-
-Below is a historical account of what happened when w/w still did eta expansion.
-Nowadays, it doesn't do that, but will simply w/w for the wrong arity, unleashing
-a demand signature meant for e.g. 2 args to be unleashed for e.g. 1 arg
-(manifest arity). That's at least as terrible as doing eta expansion, so don't
-do it.
----
-When worker/wrapper did eta expansion, it implictly eta expanded the binding to
-idArity, overriding GHC.Core.Opt.Arity's decision. Other than playing fast and loose with
-divergence, it's also broken for newtypes:
-
-  f = (\xy.blah) |> co
-    where
-      co :: (Int -> Int -> Char) ~ T
-
-Then idArity is 2 (despite the type T), and it can have a DmdSig based on a
-threshold of 2. But we can't w/w it without a type error.
-
-The situation is less grave for PAPs, but the implicit eta expansion caused a
-compiler allocation regression in T15164, where huge recursive instance method
-groups, mostly consisting of PAPs, got w/w'd. This caused great churn in the
-simplifier, when simply waiting for the PAPs to inline arrived at the same
-output program.
-
-Note there is the worry here that such PAPs and trivial RHSs might not *always*
-be inlined. That would lead to reboxing, because the analysis tacitly assumes
-that we W/W'd for idArity and will propagate analysis information under that
-assumption. So far, this doesn't seem to matter in practice.
-See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064.
-
-Note [Inline pragma for certainlyWillInline]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this (#19824 comment on 15 May 21):
-  f _ (x,y) = ...big...
-  v = ...big...
-  g x = f v x + 1
-
-So `f` will generate a worker/wrapper split; and `g` (since it is small)
-will trigger the certainlyWillInline case of splitFun.  The danger is that
-we end up with
-  g {- StableUnfolding = \x -> f v x + 1 -}
-    = ...blah...
-
-Since (a) that unfolding for g is AlwaysActive
-      (b) the unfolding for f's wrapper is ActiveAfterInitial
-the call of f will never inline in g's stable unfolding, thereby
-keeping `v` alive.
-
-I thought of changing g's unfolding to be ActiveAfterInitial, but that
-too is bad: it delays g's inlining into other modules, which makes fewer
-specialisations happen. Example in perf/should_run/DeriveNull.
-
-So I decided to live with the problem.  In fact v's RHS will be replaced
-by LitRubbish (see Note [Drop absent bindings]) so there is no great harm.
--}
-
-
----------------------
-splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)]
-splitFun ww_opts fn_id rhs
-  | Just (arg_vars, body) <- collectNValBinders_maybe (length wrap_dmds) rhs
-  = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info)))
-                 "splitFun"
-                 (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $
-    do { mb_stuff <- mkWwBodies ww_opts fn_id arg_vars (exprType body) wrap_dmds cpr
-       ; case mb_stuff of
-            Nothing -> -- No useful wrapper; leave the binding alone
-                       return [(fn_id, rhs)]
-
-            Just stuff
-              | let opt_wwd_rhs = simpleOptExpr (wo_simple_opts ww_opts) rhs
-                  -- We need to stabilise the WW'd (and optimised) RHS below
-              , Just stable_unf <- certainlyWillInline uf_opts fn_info opt_wwd_rhs
-                -- We could make a w/w split, but in fact the RHS is small
-                -- See Note [Don't w/w inline small non-loop-breaker things]
-              , let id_w_unf = fn_id `setIdUnfolding` stable_unf
-                -- See Note [Inline pragma for certainlyWillInline]
-              ->  return [ (id_w_unf, rhs) ]
-
-              | otherwise
-              -> do { work_uniq <- getUniqueM
-                    ; return (mkWWBindPair ww_opts fn_id fn_info arg_vars body
-                                           work_uniq div stuff) } }
-
-  | otherwise    -- See Note [Don't eta expand in w/w]
-  = return [(fn_id, rhs)]
-
-  where
-    uf_opts = so_uf_opts (wo_simple_opts ww_opts)
-    fn_info = idInfo fn_id
-
-    (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info)
-
-    cpr_ty = getCprSig (cprSigInfo fn_info)
-    -- Arity of the CPR sig should match idArity when it's not a join point.
-    -- See Note [Arity trimming for CPR signatures] in GHC.Core.Opt.CprAnal
-    cpr = assertPpr (isJoinId fn_id || cpr_ty == topCprType || ct_arty cpr_ty == arityInfo fn_info)
-                    (ppr fn_id <> colon <+> text "ct_arty:" <+> int (ct_arty cpr_ty)
-                      <+> text "arityInfo:" <+> ppr (arityInfo fn_info)) $
-          ct_cpr cpr_ty
-
-mkWWBindPair :: WwOpts -> Id -> IdInfo
-             -> [Var] -> CoreExpr -> Unique -> Divergence
-             -> ([Demand],JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr)
-             -> [(Id, CoreExpr)]
-mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div
-             (work_demands, join_arity, wrap_fn, work_fn)
-  = -- pprTrace "mkWWBindPair" (ppr fn_id <+> ppr wrap_id <+> ppr work_id $$ ppr wrap_rhs) $
-    [(work_id, work_rhs), (wrap_id, wrap_rhs)]
-     -- Worker first, because wrapper mentions it
-  where
-    arity = arityInfo fn_info
-            -- The arity is set by the simplifier using exprEtaExpandArity
-            -- So it may be more than the number of top-level-visible lambdas
-
-    simpl_opts = wo_simple_opts ww_opts
-
-    work_rhs = work_fn (mkLams fn_args fn_body)
-    work_act = case fn_inline_spec of  -- See Note [Worker activation]
-                   NoInline _  -> inl_act fn_inl_prag
-                   _           -> inl_act wrap_prag
-
-    work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"
-                             , inl_inline = fn_inline_spec
-                             , inl_sat    = Nothing
-                             , inl_act    = work_act
-                             , inl_rule   = FunLike }
-      -- inl_inline: copy from fn_id; see Note [Worker/wrapper for INLINABLE functions]
-      -- inl_act:    see Note [Worker activation]
-      -- inl_rule:   it does not make sense for workers to be constructorlike.
-
-    work_join_arity | isJoinId fn_id = Just join_arity
-                    | otherwise      = Nothing
-      -- worker is join point iff wrapper is join point
-      -- (see Note [Don't w/w join points for CPR])
-
-    work_id  = asWorkerLikeId $
-               mkWorkerId work_uniq fn_id (exprType work_rhs)
-                `setIdOccInfo` occInfo fn_info
-                        -- Copy over occurrence info from parent
-                        -- Notably whether it's a loop breaker
-                        -- Doesn't matter much, since we will simplify next, but
-                        -- seems right-er to do so
-
-                `setInlinePragma` work_prag
-
-                `setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding
-                        -- See Note [Worker/wrapper for INLINABLE functions]
-
-                `setIdDmdSig` mkClosedDmdSig work_demands div
-                        -- Even though we may not be at top level,
-                        -- it's ok to give it an empty DmdEnv
-
-                `setIdCprSig` topCprSig
-
-                `setIdDemandInfo` worker_demand
-
-                `setIdArity` work_arity
-                        -- Set the arity so that the Core Lint check that the
-                        -- arity is consistent with the demand type goes
-                        -- through
-
-                `asJoinId_maybe` work_join_arity
-
-    work_arity = length work_demands :: Int
-
-    -- See Note [Demand on the worker]
-    single_call = saturatedByOneShots arity (demandInfo fn_info)
-    worker_demand | single_call = mkWorkerDemand work_arity
-                  | otherwise   = topDmd
-
-    wrap_rhs  = wrap_fn work_id
-    wrap_prag = mkStrWrapperInlinePrag fn_inl_prag fn_rules
-    wrap_unf  = mkWrapperUnfolding simpl_opts wrap_rhs arity
-
-    wrap_id   = fn_id `setIdUnfolding`  wrap_unf
-                      `setInlinePragma` wrap_prag
-                      `setIdOccInfo`    noOccInfo
-                        -- Zap any loop-breaker-ness, to avoid bleating from Lint
-                        -- about a loop breaker with an INLINE rule
-
-    fn_inl_prag     = inlinePragInfo fn_info
-    fn_inline_spec  = inl_inline fn_inl_prag
-    fn_unfolding    = realUnfoldingInfo fn_info
-    fn_rules        = ruleInfoRules (ruleInfo fn_info)
-
-mkStrWrapperInlinePrag :: InlinePragma -> [CoreRule] -> InlinePragma
-mkStrWrapperInlinePrag (InlinePragma { inl_inline = fn_inl
-                                     , inl_act    = fn_act
-                                     , inl_rule   = rule_info }) rules
-  = InlinePragma { inl_src    = SourceText "{-# INLINE"
-                 , inl_sat    = Nothing
-
-                 , inl_inline = fn_inl
-                      -- See Note [Worker/wrapper for INLINABLE functions]
-
-                 , inl_act    = activeAfter wrapper_phase
-                      -- See Note [Wrapper activation]
-
-                 , inl_rule   = rule_info }  -- RuleMatchInfo is (and must be) unaffected
-  where
-    -- See Note [Wrapper activation]
-    wrapper_phase = foldr (laterPhase . get_rule_phase) earliest_inline_phase rules
-    earliest_inline_phase = beginPhase fn_act `laterPhase` nextPhase InitialPhase
-          -- laterPhase (nextPhase InitialPhase) is a temporary hack
-          -- to inline no earlier than phase 2.  I got regressions in
-          -- 'mate', due to changes in full laziness due to Note [Case
-          -- MFEs], when I did earlier inlining.
-
-    get_rule_phase :: CoreRule -> CompilerPhase
-    -- The phase /after/ the rule is first active
-    get_rule_phase rule = nextPhase (beginPhase (ruleActivation rule))
-
-{-
-Note [Demand on the worker]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-If the original function is called once, according to its demand info, then
-so is the worker. This is important so that the occurrence analyser can
-attach OneShot annotations to the worker’s lambda binders.
-
-
-Example:
-
-  -- Original function
-  f [Demand=<L,1*C(1,U)>] :: (a,a) -> a
-  f = \p -> ...
-
-  -- Wrapper
-  f [Demand=<L,1*C(1,U)>] :: a -> a -> a
-  f = \p -> case p of (a,b) -> $wf a b
-
-  -- Worker
-  $wf [Demand=<L,1*C(1,C(1,U))>] :: Int -> Int
-  $wf = \a b -> ...
-
-We need to check whether the original function is called once, with
-sufficiently many arguments. This is done using saturatedByOneShots, which
-takes the arity of the original function (resp. the wrapper) and the demand on
-the original function.
-
-The demand on the worker is then calculated using mkWorkerDemand, and always of
-the form [Demand=<L,1*(C(1,...(C(1,U))))>]
-
-Note [Thunk splitting]
-~~~~~~~~~~~~~~~~~~~~~~
-Suppose x is used strictly; never mind whether it has the CPR
-property.  I'll use a '*' to mean "x* is demanded strictly".
-
-      let
-        x* = x-rhs
-      in body
-
-splitThunk transforms like this:
-      let
-        x* = let x = x-rhs in
-             case x of { I# a -> I# a }
-      in body
-
-This is a little strange: we are re-using the same `x` in the RHS; and
-the RHS takes `x` apart and reboxes it. But because the outer 'let' is
-strict, and the inner let mentions `x` only once, the simplifier
-transform it to
-      case x-rhs of
-        I# a -> let x* = I# a
-                in body
-
-That is good: in `body` we know the form of `x`, which
-  * gives the CPR property, and
-  * allows case-of-case to happen on x
-
-Notes
-* I tried transforming like this:
-      let
-        x* = let x = x-rhs in
-             case x of { I# a -> x }
-      in body
-  where I return `x` itself, rather than reboxing it.  But this
-  turned out to cause some regressions, which I never fully
-  investigated.
-
-* Suppose x-rhs is itself a case:
-        x-rhs = case e of { T -> I# e1; F -> I# e2 }
-  Then we'll get
-      join j a = let x* = I# a in body
-      in case e of { T -> j e1; F -> j e2 }
-  which is good (no boxing).  But in the original, unsplit program
-  we would transform
-      let x* = case e of ... in body
-  ==> join j2 x = body
-      in case e of { T -> j2 (I# e1); F -> j (I# e2) }
-  which is not good (boxing).
-
-* In fact, splitThunk uses the function argument w/w splitting
-  function, mkWWstr_one, so that if x's demand is deeper (say U(U(L,L),L))
-  then the splitting will go deeper too.
-
-* For recursive thunks, the Simplifier is unable to float `x-rhs` out of
-  `x*`'s RHS, because `x*` occurs freely in `x-rhs`, and will just change it
-  back to the original definition, so we just split non-recursive thunks.
-
-Note [Thunk splitting for top-level binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Top-level bindings are never strict. Yet they can be absent, as T14270 shows:
-
-  module T14270 (mkTrApp) where
-  mkTrApp x y
-    | Just ... <- ... typeRepKind x ...
-    = undefined
-    | otherwise
-    = undefined
-  typeRepKind = Tick scc undefined
-
-(T19180 is a profiling-free test case for this)
-Note that `typeRepKind` is not exported and its only use site in
-`mkTrApp` guards a bottoming expression. Thus, demand analysis
-figures out that `typeRepKind` is absent and splits the thunk to
-
-  typeRepKind =
-    let typeRepKind = Tick scc undefined in
-    let typeRepKind = absentError in
-    typeRepKind
-
-But now we have a local binding with an External Name
-(See Note [About the NameSorts]). That will trigger a CoreLint error, which we
-get around by localising the Id for the auxiliary bindings in 'splitThunk'.
--}
-
--- | See Note [Thunk splitting].
---
--- splitThunk converts the *non-recursive* binding
---      x = e
--- into
---      x = let x' = e in
---          case x' of I# y -> let x' = I# y in x'
--- See comments above. Is it not beautifully short?
--- Moreover, it works just as well when there are
--- several binders, and if the binders are lifted
--- E.g.     x = e
---     -->  x = let x' = e in
---              case x' of (a,b) -> let x' = (a,b)  in x'
--- Here, x' is a localised version of x, in case x is a
--- top-level Id with an External Name, because Lint rejects local binders with
--- External Names; see Note [About the NameSorts] in GHC.Types.Name.
---
--- How can we do thunk-splitting on a top-level binder?  See
--- Note [Thunk splitting for top-level binders].
-splitThunk :: WwOpts -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]
-splitThunk ww_opts is_rec x rhs
-  = assert (not (isJoinId x)) $
-    do { let x' = localiseId x -- See comment above
-       ; (useful,_args, wrap_fn, fn_arg)
-           <- mkWWstr_one ww_opts x' NotMarkedStrict
-       ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn fn_arg)) ]
-       ; if useful then assertPpr (isNonRec is_rec) (ppr x) -- The thunk must be non-recursive
-                   return res
-                   else return [(x, rhs)] }
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ /dev/null
@@ -1,1680 +0,0 @@
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-
-A library for the ``worker\/wrapper'' back-end to the strictness analyser
--}
-
-
-{-# LANGUAGE ViewPatterns #-}
-
-module GHC.Core.Opt.WorkWrap.Utils
-   ( WwOpts(..), mkWwBodies, mkWWstr, mkWWstr_one
-   , needsVoidWorkerArg, addVoidWorkerArg
-   , DataConPatContext(..)
-   , UnboxingDecision(..), canUnboxArg
-   , findTypeShape, IsRecDataConResult(..), isRecDataCon
-   , mkAbsentFiller
-   , isWorkerSmallEnough, dubiousDataConInstArgTys
-   , boringSplit , usefulSplit
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Core
-import GHC.Core.Utils
-import GHC.Core.DataCon
-import GHC.Core.Make
-import GHC.Core.Subst
-import GHC.Core.Type
-import GHC.Core.Multiplicity
-import GHC.Core.Coercion
-import GHC.Core.Reduction
-import GHC.Core.FamInstEnv
-import GHC.Core.TyCon
-import GHC.Core.TyCon.Set
-import GHC.Core.TyCon.RecWalk
-import GHC.Core.SimpleOpt( SimpleOpts )
-
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.Demand
-import GHC.Types.Cpr
-import GHC.Types.Id.Make ( voidArgId, voidPrimId )
-import GHC.Types.Var.Env
-import GHC.Types.Basic
-import GHC.Types.Unique.Supply
-import GHC.Types.Name ( getOccFS )
-
-import GHC.Data.FastString
-import GHC.Data.OrdList
-import GHC.Data.List.SetOps
-
-import GHC.Builtin.Types ( tupleDataCon )
-
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-import Control.Applicative ( (<|>) )
-import Control.Monad ( zipWithM )
-import Data.List ( unzip4 )
-
-import GHC.Types.RepType
-import GHC.Unit.Types
-
-{-
-************************************************************************
-*                                                                      *
-\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
-*                                                                      *
-************************************************************************
-
-Here's an example.  The original function is:
-
-\begin{verbatim}
-g :: forall a . Int -> [a] -> a
-
-g = \/\ a -> \ x ys ->
-        case x of
-          0 -> head ys
-          _ -> head (tail ys)
-\end{verbatim}
-
-From this, we want to produce:
-\begin{verbatim}
--- wrapper (an unfolding)
-g :: forall a . Int -> [a] -> a
-
-g = \/\ a -> \ x ys ->
-        case x of
-          I# x# -> $wg a x# ys
-            -- call the worker; don't forget the type args!
-
--- worker
-$wg :: forall a . Int# -> [a] -> a
-
-$wg = \/\ a -> \ x# ys ->
-        let
-            x = I# x#
-        in
-            case x of               -- note: body of g moved intact
-              0 -> head ys
-              _ -> head (tail ys)
-\end{verbatim}
-
-Something we have to be careful about:  Here's an example:
-
-\begin{verbatim}
--- "f" strictness: U(P)U(P)
-f (I# a) (I# b) = a +# b
-
-g = f   -- "g" strictness same as "f"
-\end{verbatim}
-
-\tr{f} will get a worker all nice and friendly-like; that's good.
-{\em But we don't want a worker for \tr{g}}, even though it has the
-same strictness as \tr{f}.  Doing so could break laziness, at best.
-
-Consequently, we insist that the number of strictness-info items is
-exactly the same as the number of lambda-bound arguments.  (This is
-probably slightly paranoid, but OK in practice.)  If it isn't the
-same, we ``revise'' the strictness info, so that we won't propagate
-the unusable strictness-info into the interfaces.
-
-
-************************************************************************
-*                                                                      *
-\subsection{The worker wrapper core}
-*                                                                      *
-************************************************************************
-
-@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.
--}
-
-data WwOpts
-  = MkWwOpts
-  { -- | Environment of type/data family instances
-    wo_fam_envs          :: !FamInstEnvs
-  , -- | Options for the "Simple optimiser"
-    wo_simple_opts       :: !SimpleOpts
-  , -- | Whether to enable "Constructed Product Result" analysis.
-    -- (Originally from DOI: 10.1017/S0956796803004751)
-    wo_cpr_anal          :: !Bool
-  , -- | Used for absent argument error message
-    wo_module            :: !Module
-  , -- | Generate workers even if the only effect is some args get passed
-    -- unlifted. See Note [WW for calling convention]
-    wo_unlift_strict     :: !Bool }
-
-type WwResult
-  = ([Demand],              -- Demands for worker (value) args
-     JoinArity,             -- Number of worker (type OR value) args
-     Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id
-     CoreExpr -> CoreExpr)  -- Worker body, lacking the original function rhs
-
-nop_fn :: CoreExpr -> CoreExpr
-nop_fn body = body
-
-
-mkWwBodies :: WwOpts
-           -> Id             -- ^ The original function
-           -> [Var]          -- ^ Manifest args of original function
-           -> Type           -- ^ Result type of the original function,
-                             --   after being stripped of args
-           -> [Demand]       -- ^ Strictness of original function
-           -> Cpr            -- ^ Info about function result
-           -> UniqSM (Maybe WwResult)
--- ^ Given a function definition
---
--- > data T = MkT Int Bool Char
--- > f :: (a, b) -> Int -> T
--- > f = \x y -> E
---
--- @mkWwBodies _ 'f' ['x::(a,b)','y::Int'] '(a,b)' ['1P(L,L)', '1P(L)'] '1'@
--- returns
---
---   * The wrapper body context for the call to the worker function, lacking
---     only the 'Id' for the worker function:
---
---     > W[_] :: Id -> CoreExpr
---     > W[work_fn] = \x y ->          -- args of the wrapper    (cloned_arg_vars)
---     >   case x of (a, b) ->         -- unbox wrapper args     (wrap_fn_str)
---     >   case y of I# n ->           --
---     >   case <work_fn> a b n of     -- call to the worker fun (call_work)
---     >   (# i, b, c #) -> MkT i b c  -- rebox result           (wrap_fn_cpr)
---
---   * The worker body context that wraps around its hole reboxing defns for x
---     and y, as well as returning CPR transit variables of the unboxed MkT
---     result in an unboxed tuple:
---
---     > w[_] :: CoreExpr -> CoreExpr
---     > w[fn_rhs] = \a b n ->              -- args of the worker       (work_lam_args)
---     >   let { y = I# n; x = (a, b) } in  -- reboxing wrapper args    (work_fn_str)
---     >   case <fn_rhs> x y of             -- call to the original RHS (call_rhs)
---     >   MkT i b c -> (# i, b, c #)       -- return CPR transit vars  (work_fn_cpr)
---
---     NB: The wrap_rhs hole is to be filled with the original wrapper RHS
---     @\x y -> E@. This is so that we can also use @w@ to transform stable
---     unfoldings, the lambda args of which may be different than x and y.
---
---   * Id details for the worker function like demands on arguments and its join
---     arity.
---
--- All without looking at E (except for beta reduction, see Note [Join points
--- and beta-redexes]), which allows us to apply the same split to function body
--- and its unfolding(s) alike.
---
-mkWwBodies opts fun_id arg_vars res_ty demands res_cpr
-  = do  { massertPpr (filter isId arg_vars `equalLength` demands)
-                     (text "wrong wrapper arity" $$ ppr fun_id $$ ppr arg_vars $$ ppr res_ty $$ ppr demands)
-
-        -- Clone and prepare arg_vars of the original fun RHS
-        -- See Note [Freshen WW arguments]
-        -- and Note [Zap IdInfo on worker args]
-        ; uniq_supply <- getUniqueSupplyM
-        ; let args_free_tcvs = tyCoVarsOfTypes (res_ty : map varType arg_vars)
-              empty_subst = mkEmptySubst (mkInScopeSet args_free_tcvs)
-              zapped_arg_vars = map zap_var arg_vars
-              (subst, cloned_arg_vars) = cloneBndrs empty_subst uniq_supply zapped_arg_vars
-              res_ty' = substTyUnchecked subst res_ty
-              init_str_marks = map (const NotMarkedStrict) cloned_arg_vars
-
-        ; (useful1, work_args_str, wrap_fn_str, fn_args)
-             <- -- pprTrace "mkWWbodies" (ppr fun_id $$ ppr (arg_vars `zip` cloned_arg_vars) $$ ppr demands) $
-                mkWWstr opts cloned_arg_vars init_str_marks
-
-        ; let (work_args, work_marks) = unzip work_args_str
-
-        -- Do CPR w/w.  See Note [Always do CPR w/w]
-        ; (useful2, wrap_fn_cpr, work_fn_cpr)
-              <- mkWWcpr_entry opts res_ty' res_cpr
-
-        ; let (work_lam_args, work_call_args, work_call_str)
-                | needsVoidWorkerArg fun_id arg_vars work_args
-                = addVoidWorkerArg work_args work_marks
-                | otherwise
-                = (work_args, work_args, work_marks)
-
-              call_work work_fn  = mkVarApps (Var work_fn) work_call_args
-              call_rhs fn_rhs = mkAppsBeta fn_rhs fn_args
-                                  -- See Note [Join points and beta-redexes]
-              wrapper_body = mkLams cloned_arg_vars . wrap_fn_cpr . wrap_fn_str . call_work
-                                  -- See Note [Call-by-value for worker args]
-              work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_str)
-              worker_body = mkLams work_lam_args . work_seq_str_flds . work_fn_cpr . call_rhs
-              worker_args_dmds= [ idDemandInfo v | v <- work_call_args, isId v]
-
-        ; if ((useful1 && not only_one_void_argument) || useful2)
-          then return (Just (worker_args_dmds, length work_call_args,
-                       wrapper_body, worker_body))
-          else return Nothing
-        }
-        -- We use an INLINE unconditionally, even if the wrapper turns out to be
-        -- something trivial like
-        --      fw = ...
-        --      f = __inline__ (coerce T fw)
-        -- The point is to propagate the coerce to f's call sites, so even though
-        -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
-        -- fw from being inlined into f's RHS
-  where
-    zap_var v | isTyVar v = v
-              | otherwise = modifyIdInfo zap_info v
-    zap_info info -- See Note [Zap IdInfo on worker args]
-      = info `setOccInfo`       noOccInfo
-
-    -- Note [Do not split void functions]
-    only_one_void_argument
-      | [d] <- demands
-      , [v] <- filter isId arg_vars
-      , isAbsDmd d && isZeroBitTy (idType v)
-      = True
-      | otherwise
-      = False
-
--- | Version of 'GHC.Core.mkApps' that does beta reduction on-the-fly.
--- PRECONDITION: The arg expressions are not free in any of the lambdas binders.
-mkAppsBeta :: CoreExpr -> [CoreArg] -> CoreExpr
--- The precondition holds for our call site in mkWwBodies, because all the FVs
--- of as are either cloned_arg_vars (and thus fresh) or fresh worker args.
-mkAppsBeta (Lam b body) (a:as) = bindNonRec b a $! mkAppsBeta body as
-mkAppsBeta f            as     = mkApps f as
-
--- See Note [Limit w/w arity]
-isWorkerSmallEnough :: Int -> Int -> [Var] -> Bool
-isWorkerSmallEnough max_worker_args old_n_args vars
-  = count isId vars <= max old_n_args max_worker_args
-    -- We count only Free variables (isId) to skip Type, Kind
-    -- variables which have no runtime representation.
-    -- Also if the function took 82 arguments before (old_n_args), it's fine if
-    -- it takes <= 82 arguments afterwards.
-
-{-
-Note [Always do CPR w/w]
-~~~~~~~~~~~~~~~~~~~~~~~~
-At one time we refrained from doing CPR w/w for thunks, on the grounds that
-we might duplicate work.  But that is already handled by the demand analyser,
-which doesn't give the CPR property if w/w might waste work: see
-Note [CPR for thunks] in GHC.Core.Opt.DmdAnal.
-
-And if something *has* been given the CPR property and we don't w/w, it's
-a disaster, because then the enclosing function might say it has the CPR
-property, but now doesn't and there a cascade of disaster.  A good example
-is #5920.
-
-Note [Limit w/w arity]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Guard against high worker arity as it generates a lot of stack traffic.
-A simplified example is #11565#comment:6
-
-Current strategy is very simple: don't perform w/w transformation at all
-if the result produces a wrapper with arity higher than -fmax-worker-args
-and the number arguments before w/w (see #18122).
-
-It is a bit all or nothing, consider
-
-        f (x,y) (a,b,c,d,e ... , z) = rhs
-
-Currently we will remove all w/w ness entirely. But actually we could
-w/w on the (x,y) pair... it's the huge product that is the problem.
-
-Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd
-solve f. But we can get a lot of args from deeply-nested products:
-
-        g (a, (b, (c, (d, ...)))) = rhs
-
-This is harder to spot on an arg-by-arg basis. Previously mkWwStr was
-given some "fuel" saying how many arguments it could add; when we ran
-out of fuel it would stop w/wing.
-
-Still not very clever because it had a left-right bias.
-
-Note [Zap IdInfo on worker args]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We have to zap the following IdInfo when re-using arg variables of the original
-function for the worker:
-
-  * OccInfo: Dead wrapper args now occur in Apps of the worker's call to the
-    original fun body. Those occurrences will quickly cancel away with the lambdas
-    of the fun body in the next run of the Simplifier, but CoreLint will complain
-    in the meantime, so zap it.
-
-We zap in mkWwBodies because we need the zapped variables when binding them in
-mkWWstr (mkAbsentFiller, specifically).
-
-Note [Do not split void functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this rather common form of binding:
-        $j = \x:Void# -> ...no use of x...
-
-Since x is not used it'll be marked as absent.  But there is no point
-in w/w-ing because we'll simply add (\y:Void#), see addVoidWorkerArg.
-
-If x has a more interesting type (eg Int, or Int#), there *is* a point
-in w/w so that we don't pass the argument at all.
-
-************************************************************************
-*                                                                      *
-\subsection{Making wrapper args}
-*                                                                      *
-************************************************************************
-
-During worker-wrapper stuff we may end up with an unlifted thing
-which we want to let-bind without losing laziness.  So we
-add a void argument.  E.g.
-
-        f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z
-==>
-        fw = /\ a -> \void -> E
-        f  = /\ a -> \x y z -> fw realworld
-
-We use the state-token type which generates no code.
--}
-
--- | Whether the worker needs an additional `Void#` arg as per
--- Note [Protecting the last value argument] or
--- Note [Preserving float barriers].
-needsVoidWorkerArg :: Id -> [Var] -> [Var] -> Bool
-needsVoidWorkerArg fn_id wrap_args work_args
-  =  not (isJoinId fn_id) && no_value_arg -- See Note [Protecting the last value argument]
-  || needs_float_barrier                  -- See Note [Preserving float barriers]
-  where
-    no_value_arg        = all (not . isId) work_args
-    is_float_barrier v  = isId v && hasNoOneShotInfo (idOneShotInfo v)
-    wrap_had_barrier    = any is_float_barrier wrap_args
-    work_has_barrier    = any is_float_barrier work_args
-    needs_float_barrier = wrap_had_barrier && not work_has_barrier
-
--- | Inserts a `Void#` arg before the first argument.
---
--- Why as the first argument? See Note [SpecConstr needs to add void args first]
--- in SpecConstr.
-addVoidWorkerArg :: [Var] -> [StrictnessMark]
-                 -> ([Var],     -- Lambda bound args
-                     [Var],     -- Args at call site
-                     [StrictnessMark]) -- str semantics for the worker args.
-addVoidWorkerArg work_args str_marks
-  = (voidArgId : work_args, voidPrimId:work_args, NotMarkedStrict:str_marks)
-
-{-
-Note [Protecting the last value argument]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If the user writes (\_ -> E), they might be intentionally disallowing
-the sharing of E. Since absence analysis and worker-wrapper are keen
-to remove such unused arguments, we add in a void argument to prevent
-the function from becoming a thunk.  Three reasons why turning a function
-into a thunk might be bad:
-
-1) It can create a space leak. e.g.
-      f x = let y () = [1..x]
-            in (sum (y ()) + length (y ()))
-   As written it'll calculate [1..x] twice, and avoid keeping a big
-   list around.  (Of course let-floating may introduce the leak; but
-   at least w/w doesn't.)
-
-2) It can prevent inlining *under a lambda*. e.g.
-       g = \y. [1..100]
-       f = \t. g ()
-   Here we can inline g under the \t.  But we won't if we remove the \y.
-
-3) It can create an unlifted binding.  E.g.
-       g :: Int -> Int#
-       g = \x. 30#
-   Removing the \x would leave an unlifted binding.
-
-NB: none of these apply to a join point.
-
-Note [Preserving float barriers]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-```
-let
-  t = sum [0..x]
-  f a{os} b[Dmd=A] c{os} = ... t ...
-in f 1 2 3 + f 4 5 6
-```
-Here, we would like to drop the argument `b` because it's absent. But doing so
-leaves behind only one-shot lambdas, `$wf a{os} c{os} = ...`, and then the
-Simplifier will inline `t` into `$wf`, because `$wf` says "I'm only called
-once". That's bad, because we lost sharing of `t`! Similarly, FloatIn would
-happily float `t` into `$wf`, see Note [Floating in past a lambda group].
-
-Why does floating happen after dropping `b` but not before? Because `b` was the
-only non-one-shot value lambda left, acting as our "float barrier".
-
-Definition:  A float barrier is a non-one-shot value lambda.
-Key insight: If `f` had a float barrier, `$wf` has to have one, too.
-
-To this end, in `needsVoidWorkerArg`, we check whether the wrapper had a float
-barrier and if the worker has none so far. If that is the case, we add a `Void#`
-argument at the end as an artificial float barrier.
-
-The issue is tracked in #21150. It came up when compiling GHC itself, in
-GHC.Tc.Gen.Bind.mkEdges. There the key_map thunk was inlined after WW dropped a
-leading absent non-one-shot arg. Here are some example wrapper arguments of
-which some are absent or one-shot and the resulting worker arguments:
-
-  * \a{Abs}.\b{os}.\c{os}... ==> \b{os}.\c{os}.\(_::Void#)...
-    Wrapper arg `a` was the only float barrier and had been dropped. Hence Void#
-  * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c...
-    Worker arg `c` is a float barrier.
-  * \a.\b{Abs}.\c{os}... ==> \a.\c{os}...
-    Worker arg `a` is a float barrier.
-  * \a{os}.\b{Abs,os}.\c{os}... ==> \a{os}.\c{os}...
-    Wrapper didn't have a float barrier, no need for Void#.
-  * \a{Abs,os}.... ==> ... (no value lambda left)
-    This examples simply demonstrates that preserving float barriers is not
-    enough to subsume Note [Protecting the last value argument].
-
-Executable examples in T21150.
-
-Note [Join points and beta-redexes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Originally, the worker would invoke the original function by calling it with
-arguments, thus producing a beta-redex for the simplifier to munch away:
-
-  \x y z -> e => (\x y z -> e) wx wy wz
-
-Now that we have special rules about join points, however, this is Not Good if
-the original function is itself a join point, as then it may contain invocations
-of other join points:
-
-  join j1 x = ...
-  join j2 y = if y == 0 then 0 else j1 y
-
-  =>
-
-  join j1 x = ...
-  join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy
-  join j2 y = case y of I# y# -> jump $wj2 y#
-
-There can't be an intervening lambda between a join point's declaration and its
-occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:
-
-  ...
-  let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y
-  ...
-
-Hence we simply do the beta-reduction here. (This would be harder if we had to
-worry about hygiene, but luckily wy is freshly generated.)
-
-Note [Freshen WW arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we do a worker/wrapper split, we must freshen the arg vars of the original
-fun RHS because they might shadow each other. E.g.
-
-  f :: forall a. Maybe a -> forall a. Maybe a -> Int -> Int
-  f @a x @a y z = case x <|> y of
-    Nothing -> z
-    Just _  -> z + 1
-
-  ==> {WW split unboxing the Int}
-
-  $wf :: forall a. Maybe a -> forall a. Maybe a -> Int# -> Int
-  $wf @a x @a y wz = (\@a x @a y z -> case x <|> y of ...) ??? x @a y (I# wz)
-
-(Notice that the code we actually emit will sort-of ANF-ise the lambda args,
-leading to even more shadowing issues. The above demonstrates that even if we
-try harder we'll still get shadowing issues.)
-
-What should we put in place for ??? ? Certainly not @a, because that would
-reference the wrong, inner a. A similar situation occurred in #12562, we even
-saw a type variable in the worker shadowing an outer term-variable binding.
-
-We avoid the issue by freshening the argument variables from the original fun
-RHS through 'cloneBndrs', which will also take care of substitution in binder
-types. Fortunately, it's sufficient to pick the FVs of the arg vars as in-scope
-set, so that we don't need to do a FV traversal over the whole body of the
-original function.
-
-At the moment, #12562 has no regression test. As such, this Note is not covered
-by any test logic or when bootstrapping the compiler. Yet we clearly want to
-freshen the binders, as the example above demonstrates.
-Adding a Core pass that maximises shadowing for testing purposes might help,
-see #17478.
--}
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Unboxing Decision for Strictness and CPR}
-*                                                                      *
-************************************************************************
--}
-
--- | The information needed to build a pattern for a DataCon to be unboxed.
--- The pattern can be generated from 'dcpc_dc' and 'dcpc_tc_args' via
--- 'GHC.Core.Utils.dataConRepInstPat'. The coercion 'dcpc_co' is for newtype
--- wrappers.
---
--- If we get @DataConPatContext dc tys co@ for some type @ty@
--- and @dataConRepInstPat ... dc tys = (exs, flds)@, then
---
---   * @dc @exs flds :: T tys@
---   * @co :: T tys ~ ty@
---
--- 's' will be 'Demand' or 'Cpr'.
-data DataConPatContext s
-  = DataConPatContext
-  { dcpc_dc      :: !DataCon
-  , dcpc_tc_args :: ![Type]
-  , dcpc_co      :: !Coercion
-  , dcpc_args    :: ![s]
-  }
-
--- | Describes the outer shape of an argument to be unboxed or left as-is
--- Depending on how @s@ is instantiated (e.g., 'Demand' or 'Cpr').
-data UnboxingDecision unboxing_info
-  = DontUnbox               -- ^ We ran out of strictness info. Leave untouched.
-  | DoUnbox !unboxing_info  -- ^ The argument is used strictly or the
-                            -- returned product was constructed, so unbox it.
-  | DropAbsent              -- ^ The argument/field was absent. Drop it.
-
--- | Do we want to create workers just for unlifting?
-wwUseForUnlifting :: WwOpts -> WwUse
-wwUseForUnlifting !opts
-    -- Always unlift if possible
-    | wo_unlift_strict opts = usefulSplit
-    -- Don't unlift  it would cause additional W/W splits.
-    | otherwise             = boringSplit
-
--- | Is the worker/wrapper split profitable?
-type WwUse = Bool
-
--- | WW split not profitable
-boringSplit :: WwUse
-boringSplit = False
-
--- | WW split profitable
-usefulSplit :: WwUse
-usefulSplit = True
-
--- | Unwraps the 'Boxity' decision encoded in the given 'SubDemand' and returns
--- a 'DataConPatContext' as well the nested demands on fields of the 'DataCon'
--- to unbox.
-canUnboxArg
-  :: FamInstEnvs
-  -> Type        -- ^ Type of the argument
-  -> Demand      -- ^ How the arg was used
-  -> UnboxingDecision (DataConPatContext Demand)
--- See Note [Which types are unboxed?]
-canUnboxArg fam_envs ty (n :* sd)
-  | isAbs n
-  = DropAbsent
-
-  -- From here we are strict and not absent
-  | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty
-  , Just dc <- tyConSingleAlgDataCon_maybe tc
-  , let arity = dataConRepArity dc
-  , Just (Unboxed, dmds) <- viewProd arity sd -- See Note [Boxity analysis]
-  , dmds `lengthIs` dataConRepArity dc
-  = DoUnbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
-                               , dcpc_co = co, dcpc_args = dmds })
-
-  | otherwise
-  = DontUnbox
-
-
--- | Unboxing strategy for constructed results.
-canUnboxResult :: FamInstEnvs -> Type -> Cpr
-               -> UnboxingDecision (DataConPatContext Cpr)
--- See Note [Which types are unboxed?]
-canUnboxResult fam_envs ty cpr
-  | Just (con_tag, arg_cprs) <- asConCpr cpr
-  , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty
-  , Just dcs <- tyConAlgDataCons_maybe tc <|> open_body_ty_warning
-  , dcs `lengthAtLeast` con_tag -- This might not be true if we import the
-                                -- type constructor via a .hs-boot file (#8743)
-  , let dc = dcs `getNth` (con_tag - fIRST_TAG)
-  , null (dataConExTyCoVars dc) -- no existentials;
-                                -- See Note [Which types are unboxed?]
-                                -- and GHC.Core.Opt.CprAnal.argCprType
-                                -- where we also check this.
-  , all isLinear (dataConInstArgTys dc tc_args)
-  -- Deactivates CPR worker/wrapper splits on constructors with non-linear
-  -- arguments, for the moment, because they require unboxed tuple with variable
-  -- multiplicity fields.
-  = DoUnbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
-                               , dcpc_co = co, dcpc_args = arg_cprs })
-
-  | otherwise
-  = DontUnbox
-
-  where
-    -- See Note [non-algebraic or open body type warning]
-    open_body_ty_warning = warnPprTrace True "canUnboxResult: non-algebraic or open body type" (ppr ty) Nothing
-
-isLinear :: Scaled a -> Bool
-isLinear (Scaled w _ ) =
-  case w of
-    OneTy -> True
-    _     -> False
-
-
-{- Note [Which types are unboxed?]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Worker/wrapper will unbox
-
-  1. A strict data type argument, that
-       * is an algebraic data type (not a newtype)
-       * is not recursive (as per 'isRecDataCon')
-       * has a single constructor (thus is a "product")
-       * that may bind existentials
-     We can transform
-     > data D a = forall b. D a b
-     > f (D @ex a b) = e
-     to
-     > $wf @ex a b = e
-     via 'mkWWstr'.
-
-  2. The constructed result of a function, if
-       * its type is an algebraic data type (not a newtype)
-       * is not recursive (as per 'isRecDataCon')
-       * (might have multiple constructors, in contrast to (1))
-       * the applied data constructor *does not* bind existentials
-     We can transform
-     > f x y = let ... in D a b
-     to
-     > $wf x y = let ... in (# a, b #)
-     via 'mkWWcpr'.
-
-     NB: We don't allow existentials for CPR W/W, because we don't have unboxed
-     dependent tuples (yet?). Otherwise, we could transform
-     > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)
-     to
-     > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)
-
-The respective tests are in 'canUnboxArg' and
-'canUnboxResult', respectively.
-
-Note that the data constructor /can/ have evidence arguments: equality
-constraints, type classes etc.  So it can be GADT.  These evidence
-arguments are simply value arguments, and should not get in the way.
-
-Note [mkWWstr and unsafeCoerce]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-By using unsafeCoerce, it is possible to make the number of demands fail to
-match the number of constructor arguments; this happened in #8037.
-If so, the worker/wrapper split doesn't work right and we get a Core Lint
-bug.  The fix here is simply to decline to do w/w if that happens.
-
-Note [non-algebraic or open body type warning]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are a few cases where the W/W transformation is told that something
-returns a constructor, but the type at hand doesn't really match this. One
-real-world example involves unsafeCoerce:
-  foo = IO a
-  foo = unsafeCoerce c_exit
-  foreign import ccall "c_exit" c_exit :: IO ()
-Here CPR will tell you that `foo` returns a () constructor for sure, but trying
-to create a worker/wrapper for type `a` obviously fails.
-(This was a real example until ee8e792  in libraries/base.)
-
-It does not seem feasible to avoid all such cases already in the analyser (and
-after all, the analysis is not really wrong), so we simply do nothing here in
-mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch
-other cases where something went avoidably wrong.
-
-This warning also triggers for the stream fusion library within `text`.
-We can't easily W/W constructed results like `Stream` because we have no simple
-way to express existential types in the worker's type signature.
-
-Note [WW for calling convention]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we know a function f will always evaluate a particular argument
-we might decide that it should rather get evaluated by the caller.
-We call this "unlifting" the argument.
-Sometimes the caller knows that the argument is already evaluated,
-so we won't generate any code to enter/evaluate the argument.
-This evaluation avoidance can be quite beneficial.
-Especially for recursive functions who pass the same lifted argument
-along on each iteration or walk over strict data structures.
-
-One way to achieve this is to do a W/W split, where the wrapper does
-the evaluation, and the worker can treat its arguments as unlifted.
-The wrapper is small and will be inlined at almost all call sites and
-the evaluation code in the wrapper can then cancel out with evaluation
-done by the calling context if the argument is evaluated there.
-Same idea as W/W to avoid allocation really, just for a different kind
-of work.
-
-Performing W/W might not always be a win. In particular it's easy to break
-(badly written, but common) rule frameworks by doing additional W/W splits.
-See #20364 for a more detailed explanation.
-
-Hence we have the following strategies with different trade-offs:
-
-A) Never do W/W *just* for unlifting of arguments.
-  + Very conservative - doesn't break any rules
-  - Lot's of performance left on the table
-
-B) Do W/W on just about anything where it might be
-  beneficial.
-  + Exploits pretty much every opportunity for unlifting.
-  - A bit of compile time/code size cost for all the wrappers.
-  - Can break rules which would otherwise fire. See #20364.
-
-C) Unlift *any* (non-boot exported) functions arguments if they are strict.
-  That is instead of creating a Worker with the new calling convention we
-  change the calling convention of the binding itself.
-  + Exploits every opportunity for unlifting.
-  + Maybe less bad interactions with rules.
-  - Requires tracking of boot-exported definitions.
-  - Requires either:
-    ~ Eta-expansion at *all* call sites in order to generate
-      an impedance matcher function. Leading to massive code bloat.
-      Essentially we end up creating a impromptu wrapper function
-      wherever we wouldn't inline the wrapper with a W/W approach.
-    ~ There is the option of achieving this without eta-expansion if we instead expand
-      the partial application code to check for demands on the calling convention and
-      for it to evaluate the arguments. The main downsides there would be the complexity
-      of the implementation and that it carries a certain overhead even for functions who
-      don't take advantage of this functionality. I haven't tried this approach because it's
-      not trivial to implement and doing W/W splits seems to work well enough.
-
-Currently we use the first approach A) by default, with a flag that allows users to fall back to the
-more aggressive approach B).
-
-I also tried the third approach C) using eta-expansion at call sites to avoid modifying the PAP-handling
-code which wasn't fruitful. See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5614#note_389903.
-We could still try to do C) in the future by having PAP calls which will evaluate the required arguments
-before calling the partially applied function. But this would be neither a small nor simple change so we
-stick with A) and a flag for B) for now.
-
-See also Note [Tag Inference] and Note [CBV Function Ids]
-
-Note [Worker/wrapper for strict arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-    f x = case x of
-             []     -> blah
-             (y:ys) -> f ys
-
-Clearly `f` is strict, but its argument is not a product type, so by default
-we don't worker/wrapper it.  But it is arguably valuable to do so.  We could
-do this:
-
-   f x = case x of xx { DEFAULT -> $wf xx }
-   $wf xx = case xx of
-              []     -> blah
-              (y:ys) -> f ys
-
-Now the worker `$wf` knows that its argument `xx` will be evaluated
-and properly tagged, so the code for the `case xx` does not need to do
-an "eval" (see `GHC.StgToCmm.Expr.cgCase`).  A call (f (a:as)) will
-have the wrapper inlined, and will drop the `case x`, so no eval
-happens at all.
-
-The worker `$wf` is a CBV function (see `Note [CBV Function Ids]`
-in GHC.Types.Id.Info) and the code generator guarantees that every
-call to `$wf` has a properly tagged argument (see `GHC.Stg.InferTags.Rewrite`).
-
-Is this a win?  Not always:
-* It can cause slight codesize increases. This is since we push evals to every
-  call sites which there might be many. And the evals will only disappear at
-  call sites where we already known that the argument is evaluated.
-
-* It will also cause many more functions to get a worker/wrapper split
-  which can play badly with rules (see Ticket #20364).  In particular
-  if you depend on rules firing on functions marked as NOINLINE
-  without marking use sites of these functions as INLINE or INLINEABLE
-  then things will break.
-  But if you want a function to match in a RULE, it is /in any case/ good practice to
-  have a `INLINE[1]` or `NOINLNE[1]` pragma, to ensure that it doesn't inline until
-  the rule has had a chance to fire.
-
-So there is a flag, `-fworker-wrapper-cbv`, to control whether we do
-w/w on strict arguments (internally `Opt_WorkerWrapperUnlift`).  The
-flag is off by default.  The choice is made in
-GHC.Core.Opt.WorkWrape.Utils.wwUseForUnlifting
-
-See also `Note [WW for calling convention]` in GHC.Core.Opt.WorkWrap.Utils
--}
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Worker/wrapper for Strictness and Absence}
-*                                                                      *
-************************************************************************
--}
-
-mkWWstr :: WwOpts
-        -> [Var]                         -- Wrapper args; have their demand info on them
-                                         --  *Includes type variables*
-        -> [StrictnessMark]              -- Strictness-mark info for arguments
-        -> UniqSM (WwUse,                -- Will this result in a useful worker
-                   [(Var,StrictnessMark)],      -- Worker args/their call-by-value semantics.
-                   CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
-                                         -- and without its lambdas
-                                         -- This fn adds the unboxing
-                   [CoreExpr])           -- Reboxed args for the call to the
-                                         -- original RHS. Corresponds one-to-one
-                                         -- with the wrapper arg vars
-mkWWstr opts args str_marks
-  = -- pprTrace "mkWWstr" (ppr args) $
-    go args str_marks
-  where
-    go [] _ = return (boringSplit, [], nop_fn, [])
-    go (arg : args) (str:strs)
-      = do { (useful1, args1, wrap_fn1, wrap_arg)  <- mkWWstr_one opts arg str
-           ; (useful2, args2, wrap_fn2, wrap_args) <- go args strs
-           ; return ( useful1 || useful2
-                    , args1 ++ args2
-                    , wrap_fn1 . wrap_fn2
-                    , wrap_arg:wrap_args ) }
-    go _ _ = panic "mkWWstr: Impossible - str/arg length mismatch"
-
-----------------------
--- mkWWstr_one wrap_var = (useful, work_args, wrap_fn, wrap_arg)
---   *  wrap_fn assumes wrap_var is in scope,
---        brings into scope work_args (via cases)
---   * wrap_arg assumes work_args are in scope, and builds a ConApp that
---        reconstructs the RHS of wrap_var that we pass to the original RHS
--- See Note [Worker/wrapper for Strictness and Absence]
-mkWWstr_one :: WwOpts
-            -> Var
-            -> StrictnessMark
-            -> UniqSM (WwUse, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
-mkWWstr_one opts arg str_mark =
-  -- pprTrace "mkWWstr_one" (ppr arg <+> (if isId arg then ppr arg_ty  $$ ppr arg_dmd else text "type arg")) $
-  case canUnboxArg fam_envs arg_ty arg_dmd of
-    _ | isTyVar arg -> do_nothing
-
-    DropAbsent
-      | Just absent_filler <- mkAbsentFiller opts arg str_mark
-         -- Absent case.  Drop the argument from the worker.
-         -- We can't always handle absence for arbitrary
-         -- unlifted types, so we need to choose just the cases we can
-         -- (that's what mkAbsentFiller does)
-      -> return (usefulSplit, [], nop_fn, absent_filler)
-      | otherwise -> do_nothing
-
-    DoUnbox dcpc -> -- pprTrace "mkWWstr_one:1" (ppr (dcpc_dc dcpc) <+> ppr (dcpc_tc_args dcpc) $$ ppr (dcpc_args dcpc)) $
-                    unbox_one_arg opts arg dcpc
-
-    DontUnbox
-      | isStrictDmd arg_dmd || isMarkedStrict str_mark
-      , wwUseForUnlifting opts  -- See Note [CBV Function Ids]
-      , not (isFunTy arg_ty)
-      , not (isUnliftedType arg_ty) -- Already unlifted!
-        -- NB: function arguments have a fixed RuntimeRep,
-        -- so it's OK to call isUnliftedType here
-      -> return  (usefulSplit, [(arg, MarkedStrict)], nop_fn, varToCoreExpr arg )
-
-      | otherwise -> do_nothing
-
-  where
-    fam_envs   = wo_fam_envs opts
-    arg_ty     = idType arg
-    arg_dmd    = idDemandInfo arg
-    arg_str    | isTyVar arg = NotMarkedStrict -- Type args don't get strictness marks
-               | otherwise   = str_mark
-    do_nothing = return (boringSplit, [(arg,arg_str)], nop_fn, varToCoreExpr arg)
-
-unbox_one_arg :: WwOpts
-              -> Var -> DataConPatContext Demand
-              -> UniqSM (WwUse, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)
-unbox_one_arg opts arg_var
-              DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
-                                , dcpc_co = co, dcpc_args = ds }
-  = do { pat_bndrs_uniqs <- getUniquesM
-       ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc
-
-             -- Create new arguments we get when unboxing dc
-             (ex_tvs', arg_ids) = dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix)
-                                            pat_bndrs_uniqs (idMult arg_var) dc tc_args
-             con_str_marks = dataConRepStrictness dc
-
-             -- Apply str info to new args. Also remove OtherCon unfoldings so they
-             -- don't end up in lambda binders of the worker.
-             -- See Note [Never put `OtherCon` unfoldings on lambda binders]
-             arg_ids' = map zapIdUnfolding $
-                        zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds
-
-             unbox_fn = mkUnpackCase (Var arg_var) co (idMult arg_var)
-                                     dc (ex_tvs' ++ arg_ids')
-
-             -- Mark arguments coming out of strict fields so we can seq them in the worker
-             -- See Note [Call-by-value for worker args]
-             all_str_marks = (map (const NotMarkedStrict) ex_tvs') ++ con_str_marks
-
-       ; (nested_useful, worker_args, wrap_fn, wrap_args)
-             <- mkWWstr opts (ex_tvs' ++ arg_ids') all_str_marks
-
-       ; let wrap_arg = mkConApp dc (map Type tc_args ++ wrap_args) `mkCast` mkSymCo co
-       -- See Note [Unboxing through unboxed tuples]
-       ; return $ if isUnboxedTupleDataCon dc && not nested_useful
-                     then (boringSplit, [(arg_var,NotMarkedStrict)], nop_fn, varToCoreExpr arg_var)
-                     else (usefulSplit, worker_args, unbox_fn . wrap_fn, wrap_arg) }
-
--- | Tries to find a suitable absent filler to bind the given absent identifier
--- to. See Note [Absent fillers].
---
--- If @mkAbsentFiller _ id == Just e@, then @e@ is an absent filler with the
--- same type as @id@. Otherwise, no suitable filler could be found.
-mkAbsentFiller :: WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr
-mkAbsentFiller opts arg str
-  -- The lifted case: Bind 'absentError' for a nice panic message if we are
-  -- wrong (like we were in #11126). See (1) in Note [Absent fillers]
-  | mightBeLiftedType arg_ty
-  , not is_strict
-  , not (isMarkedStrict str) -- See (2) in Note [Absent fillers]
-  = Just (mkAbsentErrorApp arg_ty msg)
-
-  -- The default case for mono rep: Bind `RUBBISH[rr] arg_ty`
-  -- See Note [Absent fillers], the main part
-  | otherwise
-  = mkLitRubbish arg_ty
-
-  where
-    arg_ty    = idType arg
-    is_strict = isStrictDmd (idDemandInfo arg)
-
-    msg = renderWithContext
-            (defaultSDocContext { sdocSuppressUniques = True })
-            (vcat
-              [ text "Arg:" <+> ppr arg
-              , text "Type:" <+> ppr arg_ty
-              , file_msg ])
-              -- We need to suppress uniques here because otherwise they'd
-              -- end up in the generated code as strings. This is bad for
-              -- determinism, because with different uniques the strings
-              -- will have different lengths and hence different costs for
-              -- the inliner leading to different inlining.
-              -- See also Note [Unique Determinism] in GHC.Types.Unique
-    file_msg = text "In module" <+> quotes (ppr $ wo_module opts)
-
-{- Note [Worker/wrapper for Strictness and Absence]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The worker/wrapper transformation, mkWWstr_one, takes concrete action
-based on the 'UnboxingDecision' returned by 'canUnboxArg'.
-The latter takes into account several possibilities to decide if the
-function is worthy for splitting:
-
-1. If an argument is absent, it would be silly to pass it to
-   the worker.  Hence the DropAbsent case.  This case must come
-   first because the bottom demand B is also strict.
-   E.g. B comes from a function like
-       f x = error "urk"
-   and the absent demand A can come from Note [Unboxing evaluated arguments]
-   in GHC.Core.Opt.DmdAnal.
-
-2. If the argument is evaluated strictly (or known to be eval'd),
-   we can take a view into the product demand ('viewProd'). In accordance
-   with Note [Boxity analysis], 'canUnboxArg' will say 'DoUnbox'.
-   'mkWWstr_one' then follows suit it and recurses into the fields of the
-   product demand. For example
-
-     f :: (Int, Int) -> Int
-     f p = (case p of (a,b) -> a) + 1
-   is split to
-     f :: (Int, Int) -> Int
-     f p = case p of (a,b) -> $wf a
-
-     $wf :: Int -> Int
-     $wf a = a + 1
-
-   and
-     g :: Bool -> (Int, Int) -> Int
-     g c p = case p of (a,b) ->
-                if c then a else b
-   is split to
-     g c p = case p of (a,b) -> $gw c a b
-     $gw c a b = if c then a else b
-
-2a But do /not/ unbox if Boxity Analysis said "Boxed".
-   In this case, 'canUnboxArg' returns 'DontUnbox'.
-   Otherwise we risk decomposing and reboxing a massive
-   tuple which is barely used. Example:
-
-        f :: ((Int,Int) -> String) -> (Int,Int) -> a
-        f g pr = error (g pr)
-
-        main = print (f fst (1, error "no"))
-
-   Here, f does not take 'pr' apart, and it's stupid to do so.
-   Imagine that it had millions of fields. This actually happened
-   in GHC itself where the tuple was DynFlags
-
-2b But if e.g. a large tuple or product type is always demanded we might
-   decide to "unlift" it. That is tighten the calling convention for that
-   argument to require it to be passed as a pointer to the value itself.
-   See Note [WW for calling convention].
-
-3. In all other cases (e.g., lazy, used demand and not eval'd),
-   'finaliseArgBoxities' will have cleared the Boxity flag to 'Boxed'
-   (see Note [Finalising boxity for demand signatures] in GHC.Core.Opt.DmdAnal)
-   and 'canUnboxArg' returns 'DontUnbox' so that 'mkWWstr_one'
-   stops unboxing.
-
-Note [Worker/wrapper for bottoming functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We used not to split if the result is bottom.
-[Justification:  there's no efficiency to be gained.]
-
-But it's sometimes bad not to make a wrapper.  Consider
-        fw = \x# -> let x = I# x# in case e of
-                                        p1 -> error_fn x
-                                        p2 -> error_fn x
-                                        p3 -> the real stuff
-The re-boxing code won't go away unless error_fn gets a wrapper too.
-[We don't do reboxing now, but in general it's better to pass an
-unboxed thing to f, and have it reboxed in the error cases....]
-
-Note [Record evaluated-ness in worker/wrapper]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-
-   data T = MkT !Int Int
-
-   f :: T -> T
-   f x = e
-
-and f's is strict, and has the CPR property.  The we are going to generate
-this w/w split
-
-   f x = case x of
-           MkT x1 x2 -> case $wf x1 x2 of
-                           (# r1, r2 #) -> MkT r1 r2
-
-   $wfw x1 x2 = let x = MkT x1 x2 in
-                case e of
-                  MkT r1 r2 -> (# r1, r2 #)
-
-Note that
-
-* In the worker $wf, inside 'e' we can be sure that x1 will be
-  evaluated (it came from unpacking the argument MkT.  But that's no
-  immediately apparent in $wf
-
-* In the wrapper 'f', which we'll inline at call sites, we can be sure
-  that 'r1' has been evaluated (because it came from unpacking the result
-  MkT.  But that is not immediately apparent from the wrapper code.
-
-Missing these facts isn't unsound, but it loses possible future
-opportunities for optimisation.
-
-Solution: use setCaseBndrEvald when creating
- (A) The arg binders x1,x2 in mkWstr_one via mkUnpackCase
-         See #13077, test T13077
- (B) The result binders r1,r2 in mkWWcpr_entry
-         See Trace #13077, test T13077a
-         And #13027 comment:20, item (4)
-to record that the relevant binder is evaluated.
-
-Note [Absent fillers]
-~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-  data T = MkT [Int] [Int] ![Int]  -- NB: last field is strict
-  f :: T -> Int# -> blah
-  f ps w = case ps of MkT xs ys zs -> <body mentioning xs>
-
-Then f gets a strictness sig of <S(L,A,A)><A>. We make a worker $wf thus:
-
-  $wf :: [Int] -> blah
-  $wf xs = case ps of MkT xs _ _ -> <body mentioning xs>
-    where
-      ys = absentError "ys :: [Int]"
-      zs = RUBBISH[LiftedRep] @[Int]
-      ps = MkT xs ys zs
-      w  = RUBBISH[IntRep] @Int#
-
-The absent arguments 'ys', 'zs' and 'w' aren't even passed to the worker.
-And neither should they! They are never used, their value is irrelevant (hence
-they are *dead code*) and they are probably discarded after the next run of the
-Simplifier (when they are in fact *unreachable code*). Yet, we have to come up
-with "filler" values that we bind the absent arg Ids to.
-
-That is exactly what Note [Rubbish literals] are for: A convenient way to
-conjure filler values at any type (and any representation or levity!).
-
-Needless to say, there are some wrinkles:
-
-  1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk
-     instead. If absence analysis was wrong (e.g., #11126) and the binding
-     in fact is used, then we get a nice panic message instead of undefined
-     runtime behavior (See Modes of failure from Note [Rubbish literals]).
-
-     Obviously, we can't use an error-thunk if the value is of unlifted rep
-     (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic.
-
-  2. We also mustn't put an error-thunk (that fills in for an absent value of
-     lifted rep) in a strict field, because #16970 establishes the invariant
-     that strict fields are always evaluated, by possibly (re-)evaluating what is put in
-     a strict field. That's the reason why 'zs' binds a rubbish literal instead
-     of an error-thunk, see #19133.
-
-     How do we detect when we are about to put an error-thunk in a strict field?
-     Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field. So that's
-     what we do!
-
-     There are other necessary conditions for strict fields:
-     Note [Unboxing evaluated arguments] in DmdAnal makes it so that the demand on
-     'zs' is absent and /strict/: It will get cardinality 'C_10', the empty
-     interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It further
-     guarantees e never fill in an error-thunk for an absent strict field.
-     But that also means we emit a rubbish lit for other args that have
-     cardinality 'C_10' (say, the arg to a bottoming function) where we could've
-     used an error-thunk.
-     NB from Andreas: But I think using an error thunk there would be dodgy no matter what
-     for example if we decide to pass the argument to the bottoming function cbv.
-     As we might do if the function in question is a worker.
-     See Note [CBV Function Ids] in GHC.Types.Id.Info. So I just left the strictness check
-     in place on top of threading through the marks from the constructor. It's a *really* cheap
-     and easy check to make anyway.
-
-  3. We can only emit a LitRubbish if the arg's type @arg_ty@ is mono-rep, e.g.
-     of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable.
-     Why? Because if we don't know its representation (e.g. size in memory,
-     register class), we don't know what or how much rubbish to emit in codegen.
-     'mkLitRubbish' returns 'Nothing' in this case and we simply fall
-     back to passing the original parameter to the worker.
-
-     Note that currently this case should not occur, because binders always
-     have to be representation monomorphic. But in the future, we might allow
-     levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'.
-
-While (1) and (2) are simply an optimisation in terms of compiler debugging
-experience, (3) should be irrelevant in most programs, if not all.
-
-Historical note: I did try the experiment of using an error thunk for unlifted
-things too, relying on the simplifier to drop it as dead code.  But this is
-fragile
-
- - It fails when profiling is on, which disables various optimisations
-
- - It fails when reboxing happens. E.g.
-      data T = MkT Int Int#
-      f p@(MkT a _) = ...g p....
-   where g is /lazy/ in 'p', but only uses the first component.  Then
-   'f' is /strict/ in 'p', and only uses the first component.  So we only
-   pass that component to the worker for 'f', which reconstructs 'p' to
-   pass it to 'g'.  Alas we can't say
-       ...f (MkT a (absentError Int# "blah"))...
-   because `MkT` is strict in its Int# argument, so we get an absentError
-   exception when we shouldn't.  Very annoying!
-
-Note [Unboxing through unboxed tuples]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We should not to a worker/wrapper split just for unboxing the components of
-an unboxed tuple (in the result *or* argument, #22388). Consider
-  boring_res x y = (# y, x #)
-It's entirely pointless to split for the constructed unboxed pair to
-  $wboring_res x y = (# y, x #)
-  boring_res = case $wboring_res x y of (# a, b #) -> (# a, b #)
-`boring_res` will immediately simplify to an alias for `$wboring_res`!
-
-Similarly, the unboxed tuple might occur in argument position
-  boring_arg (# x, y, z #) = (# z, x, y #)
-It's entirely pointless to "unbox" the triple
-  $wboring_arg x y z = (# z, x, y #)
-  boring_arg (# x, y, z #) = $wboring_arg x y z
-because after unarisation, `boring_arg` is just an alias for `$wboring_arg`.
-
-Conclusion: Only consider unboxing an unboxed tuple useful when we will
-also unbox its components. That is governed by the `usefulSplit` mechanism.
-
-************************************************************************
-*                                                                      *
-         Type scrutiny that is specific to demand analysis
-*                                                                      *
-************************************************************************
--}
-
--- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that
--- the 'DataCon' may not have existentials. The lack of cloning the existentials
--- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";
--- only use it where type variables aren't substituted for!
-dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]
-dubiousDataConInstArgTys dc tc_args = arg_tys
-  where
-    univ_tvs = dataConUnivTyVars dc
-    ex_tvs   = dataConExTyCoVars dc
-    subst    = extendSubstInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs
-    arg_tys  = map (GHC.Core.Type.substTy subst . scaledThing) (dataConRepArgTys dc)
-
-findTypeShape :: FamInstEnvs -> Type -> TypeShape
--- Uncover the arrow and product shape of a type
--- The data type TypeShape is defined in GHC.Types.Demand
--- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal
-findTypeShape fam_envs ty
-  = go (setRecTcMaxBound 2 initRecTc) ty
-       -- You might think this bound of 2 is low, but actually
-       -- I think even 1 would be fine.  This only bites for recursive
-       -- product types, which are rare, and we really don't want
-       -- to look deep into such products -- see #18034
-  where
-    go rec_tc ty
-       | Just (_, _, _, res) <- splitFunTy_maybe ty
-       = TsFun (go rec_tc res)
-
-       | Just (tc, tc_args)  <- splitTyConApp_maybe ty
-       = go_tc rec_tc tc tc_args
-
-       | Just (_, ty') <- splitForAllTyCoVar_maybe ty
-       = go rec_tc ty'
-
-       | otherwise
-       = TsUnk
-
-    go_tc rec_tc tc tc_args
-       | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args
-       = go rec_tc rhs
-
-       | Just con <- tyConSingleAlgDataCon_maybe tc
-       , Just rec_tc <- if isTupleTyCon tc
-                        then Just rec_tc
-                        else checkRecTc rec_tc tc
-         -- We treat tuples specially because they can't cause loops.
-         -- Maybe we should do so in checkRecTc.
-         -- The use of 'dubiousDataConInstArgTys' is OK, since this
-         -- function performs no substitution at all, hence the uniques
-         -- don't matter.
-         -- We really do encounter existentials here, see
-         -- Note [Which types are unboxed?] for an example.
-       = TsProd (map (go rec_tc) (dubiousDataConInstArgTys con tc_args))
-
-       | Just (ty', _) <- instNewTyCon_maybe tc tc_args
-       , Just rec_tc <- checkRecTc rec_tc tc
-       = go rec_tc ty'
-
-       | otherwise
-       = TsUnk
-
--- | Returned by 'isRecDataCon'.
--- See also Note [Detecting recursive data constructors].
-data IsRecDataConResult
-  = DefinitelyRecursive  -- ^ The algorithm detected a loop
-  | NonRecursiveOrUnsure -- ^ The algorithm detected no loop, went out of fuel
-                         -- or hit an .hs-boot file
-  deriving (Eq, Show)
-
-instance Outputable IsRecDataConResult where
-  ppr = text . show
-
-combineIRDCR :: IsRecDataConResult -> IsRecDataConResult -> IsRecDataConResult
-combineIRDCR DefinitelyRecursive _                   = DefinitelyRecursive
-combineIRDCR _                   DefinitelyRecursive = DefinitelyRecursive
-combineIRDCR _                   _                   = NonRecursiveOrUnsure
-
-combineIRDCRs :: [IsRecDataConResult] -> IsRecDataConResult
-combineIRDCRs = foldl' combineIRDCR NonRecursiveOrUnsure
-{-# INLINE combineIRDCRs #-}
-
--- | @isRecDataCon _ fuel dc@, where @tc = dataConTyCon dc@ returns
---
---   * @DefinitelyRecursive@ if the analysis found that @tc@ is reachable
---     through one of @dc@'s @arg_tys@.
---   * @NonRecursiveOrUnsure@ if the analysis found that @tc@ is not reachable
---     through one of @dc@'s fields (so surely non-recursive).
---   * @NonRecursiveOrUnsure@ when @fuel /= Infinity@
---     and @fuel@ expansions of nested data TyCons were not enough to prove
---     non-recursiveness, nor arrive at an occurrence of @tc@ thus proving
---     recursiveness. (So not sure if non-recursive.)
---   * @NonRecursiveOrUnsure@ when we hit an abstract TyCon (one without
---     visible DataCons), such as those imported from .hs-boot files.
---     Similarly for stuck type and data families.
---
--- If @fuel = 'Infinity'@ and there are no boot files involved, then the result
--- is never @Nothing@ and the analysis is a depth-first search. If @fuel = 'Int'
--- f@, then the analysis behaves like a depth-limited DFS and returns @Nothing@
--- if the search was inconclusive.
---
--- See Note [Detecting recursive data constructors] for which recursive DataCons
--- we want to flag.
-isRecDataCon :: FamInstEnvs -> IntWithInf -> DataCon -> IsRecDataConResult
-isRecDataCon fam_envs fuel orig_dc
-  | isTupleDataCon orig_dc || isUnboxedSumDataCon orig_dc
-  = NonRecursiveOrUnsure
-  | otherwise
-  = -- pprTraceWith "isRecDataCon" (\answer -> ppr dc <+> dcolon <+> ppr (dataConRepType dc) $$ ppr fuel $$ ppr answer) $
-    go_dc fuel emptyTyConSet orig_dc
-  where
-    go_dc :: IntWithInf -> TyConSet -> DataCon -> IsRecDataConResult
-    go_dc fuel visited_tcs dc =
-      combineIRDCRs [ go_arg_ty fuel visited_tcs arg_ty
-                    | arg_ty <- map scaledThing (dataConRepArgTys dc) ]
-
-    go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult
-    go_arg_ty fuel visited_tcs ty
-      --- | pprTrace "arg_ty" (ppr ty) False = undefined
-
-      | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty
-      = go_arg_ty fuel visited_tcs ty'
-          -- See Note [Detecting recursive data constructors], point (A)
-
-      | Just (tc, tc_args) <- splitTyConApp_maybe ty
-      = go_tc_app fuel visited_tcs tc tc_args
-
-      | otherwise
-      = NonRecursiveOrUnsure
-
-    go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Type] -> IsRecDataConResult
-    go_tc_app fuel visited_tcs tc tc_args =
-      case tyConDataCons_maybe tc of
-      --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined
-        _ | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args
-          -- This is the only place where we look at tc_args, which might have
-          -- See Note [Detecting recursive data constructors], point (C) and (5)
-          -> go_arg_ty fuel visited_tcs rhs
-
-        _ | tc == dataConTyCon orig_dc
-          -> DefinitelyRecursive -- loop found!
-
-        Just dcs
-          | DefinitelyRecursive <- combineIRDCRs [ go_arg_ty fuel visited_tcs' ty | ty <- tc_args ]
-              -- Check tc_args, See Note [Detecting recursive data constructors], point (5)
-              -- The new visited_tcs', so that we don't recursively check tc,
-              -- promising that we will check it below.
-              -- Do the tc_args check *before* the dcs check below, otherwise
-              -- we might miss an obvious rec occ in tc_args when we run out of
-              -- fuel and respond NonRecursiveOrUnsure instead
-          -> DefinitelyRecursive
-
-          | fuel >= 0
-              -- See Note [Detecting recursive data constructors], point (4)
-          , not (tc `elemTyConSet` visited_tcs)
-              -- only need to check tc if we haven't visited it already. NB: original visited_tcs
-          -> combineIRDCRs [ go_dc (subWithInf fuel 1) visited_tcs' dc | dc <- dcs ]
-              -- Finally: check ds
-
-        _ -> NonRecursiveOrUnsure
-        where
-          visited_tcs' = extendTyConSet visited_tcs tc
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Worker/wrapper for CPR}
-*                                                                      *
-************************************************************************
-See Note [Worker/wrapper for CPR] for an overview.
--}
-
-mkWWcpr_entry
-  :: WwOpts
-  -> Type                              -- function body
-  -> Cpr                               -- CPR analysis results
-  -> UniqSM (WwUse,                    -- Is w/w'ing useful?
-             CoreExpr -> CoreExpr,     -- New wrapper. 'nop_fn' if not useful
-             CoreExpr -> CoreExpr)     -- New worker.  'nop_fn' if not useful
--- ^ Entrypoint to CPR W/W. See Note [Worker/wrapper for CPR] for an overview.
-mkWWcpr_entry opts body_ty body_cpr
-  | not (wo_cpr_anal opts) = return (boringSplit, nop_fn, nop_fn)
-  | otherwise = do
-    -- Part (1)
-    res_bndr <- mk_res_bndr body_ty
-    let bind_res_bndr body scope = mkDefaultCase body res_bndr scope
-
-    -- Part (2)
-    (useful, fromOL -> transit_vars, rebuilt_result, work_unpack_res) <-
-      mkWWcpr_one opts res_bndr body_cpr
-
-    -- Part (3)
-    let (unbox_transit_tup, transit_tup) = move_transit_vars transit_vars
-
-    -- Stacking unboxer (work_fn) and builder (wrap_fn) together
-    let wrap_fn      = unbox_transit_tup rebuilt_result                 -- 3 2
-        work_fn body = bind_res_bndr body (work_unpack_res transit_tup) -- 1 2 3
-    return $ if not useful
-                then (boringSplit, nop_fn, nop_fn)
-                else (usefulSplit, wrap_fn, work_fn)
-
--- | Part (1) of Note [Worker/wrapper for CPR].
-mk_res_bndr :: Type -> UniqSM Id
-mk_res_bndr body_ty = do
-  -- See Note [Linear types and CPR]
-  bndr <- mkSysLocalOrCoVarM ww_prefix cprCaseBndrMult body_ty
-  -- See Note [Record evaluated-ness in worker/wrapper]
-  pure (setCaseBndrEvald MarkedStrict bndr)
-
--- | What part (2) of Note [Worker/wrapper for CPR] collects.
---
---   1. A 'WwUse' capturing whether the split does anything useful.
---   2. The list of transit variables (see the Note).
---   3. The result builder expression for the wrapper.  The original case binder if not useful.
---   4. The result unpacking expression for the worker. 'nop_fn' if not useful.
-type CprWwResultOne  = (WwUse, OrdList Var,  CoreExpr , CoreExpr -> CoreExpr)
-type CprWwResultMany = (WwUse, OrdList Var, [CoreExpr], CoreExpr -> CoreExpr)
-
-mkWWcpr :: WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResultMany
-mkWWcpr _opts vars []   =
-  -- special case: No CPRs means all top (for example from FlatConCpr),
-  -- hence stop WW.
-  return (boringSplit, toOL vars, map varToCoreExpr vars, nop_fn)
-mkWWcpr opts  vars cprs = do
-  -- No existentials in 'vars'. 'canUnboxResult' should have checked that.
-  massertPpr (not (any isTyVar vars)) (ppr vars $$ ppr cprs)
-  massertPpr (equalLength vars cprs) (ppr vars $$ ppr cprs)
-  (usefuls, varss, rebuilt_results, work_unpack_ress) <-
-    unzip4 <$> zipWithM (mkWWcpr_one opts) vars cprs
-  return ( or usefuls
-         , concatOL varss
-         , rebuilt_results
-         , foldl' (.) nop_fn work_unpack_ress )
-
-mkWWcpr_one :: WwOpts -> Id -> Cpr -> UniqSM CprWwResultOne
--- ^ See if we want to unbox the result and hand off to 'unbox_one_result'.
-mkWWcpr_one opts res_bndr cpr
-  | assert (not (isTyVar res_bndr) ) True
-  , DoUnbox dcpc <- canUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr
-  = unbox_one_result opts res_bndr dcpc
-  | otherwise
-  = return (boringSplit, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn)
-
-unbox_one_result
-  :: WwOpts -> Id -> DataConPatContext Cpr -> UniqSM CprWwResultOne
--- ^ Implements the main bits of part (2) of Note [Worker/wrapper for CPR]
-unbox_one_result opts res_bndr
-                 DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args
-                                   , dcpc_co = co, dcpc_args = arg_cprs } = do
-  -- unboxer (free in `res_bndr`):       |   builder (where <i> builds what was
-  --   ( case res_bndr of (i, j) -> )    |            bound to i)
-  --   ( case i of I# a ->          )    |
-  --   ( case j of I# b ->          )    |     (      (<i>, <j>)      )
-  --   ( <hole>                     )    |
-  pat_bndrs_uniqs <- getUniquesM
-  let (_exs, arg_ids) =
-        dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs cprCaseBndrMult dc tc_args
-  massert (null _exs) -- Should have been caught by canUnboxResult
-
-  (nested_useful, transit_vars, con_args, work_unbox_res) <-
-    mkWWcpr opts arg_ids arg_cprs
-
-  let -- rebuilt_result = (C a b |> sym co)
-      rebuilt_result = mkConApp dc (map Type tc_args ++ con_args) `mkCast` mkSymCo co
-      -- this_work_unbox_res alt = (case res_bndr |> co of C a b -> <alt>[a,b])
-      this_work_unbox_res = mkUnpackCase (Var res_bndr) co cprCaseBndrMult dc arg_ids
-
-  -- See Note [Unboxing through unboxed tuples]
-  return $ if isUnboxedTupleDataCon dc && not nested_useful
-              then ( boringSplit, unitOL res_bndr, Var res_bndr, nop_fn )
-              else ( usefulSplit
-                   , transit_vars
-                   , rebuilt_result
-                   , this_work_unbox_res . work_unbox_res
-                   )
-
--- | Implements part (3) of Note [Worker/wrapper for CPR].
---
--- If `move_transit_vars [a,b] = (unbox, tup)` then
---     * `a` and `b` are the *transit vars* to be returned from the worker
---       to the wrapper
---     * `unbox scrut alt = (case <scrut> of (# a, b #) -> <alt>)`
---     * `tup = (# a, b #)`
--- There is a special case for when there's 1 transit var,
--- see Note [No unboxed tuple for single, unlifted transit var].
-move_transit_vars :: [Id] -> (CoreExpr -> CoreExpr -> CoreExpr, CoreExpr)
-move_transit_vars vars
-  | [var] <- vars
-  , let var_ty = idType var
-  , isUnliftedType var_ty || exprIsHNF (Var var)
-  -- See Note [No unboxed tuple for single, unlifted transit var]
-  --   * Wrapper: `unbox scrut alt = (case <scrut> of a -> <alt>)`
-  --   * Worker:  `tup = a`
-  = ( \build_res wkr_call -> mkDefaultCase wkr_call var build_res
-    , varToCoreExpr var ) -- varToCoreExpr important here: var can be a coercion
-                          -- Lacking this caused #10658
-  | otherwise
-  -- The general case: Just return an unboxed tuple from the worker
-  --   * Wrapper: `unbox scrut alt = (case <scrut> of (# a, b #) -> <alt>)`
-  --   * Worker:  `tup = (# a, b #)`
-  = ( \build_res wkr_call -> mkSingleAltCase wkr_call case_bndr
-                                    (DataAlt tup_con) vars build_res
-    , ubx_tup_app )
-   where
-    ubx_tup_app = mkCoreUnboxedTuple (map varToCoreExpr vars)
-    tup_con     = tupleDataCon Unboxed (length vars)
-    -- See also Note [Linear types and CPR]
-    case_bndr   = mkWildValBinder cprCaseBndrMult (exprType ubx_tup_app)
-
-
-{- Note [Worker/wrapper for CPR]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-'mkWWcpr_entry' is the entry-point to the worker/wrapper transformation that
-exploits CPR info. Here's an example:
-```
-  f :: ... -> (Int, Int)
-  f ... = <body>
-```
-Let's assume the CPR info `body_cpr` for the body of `f` says
-"unbox the pair and its components" and `body_ty` is the type of the function
-body `body` (i.e., `(Int, Int)`). Then `mkWWcpr_entry body_ty body_cpr` returns
-
-  * A result-unpacking expression for the worker, with a hole for the fun body:
-    ```
-      unpack body = ( case <body> of r __DEFAULT -> )    -- (1)
-                    ( case r of (i, j) ->           )    -- (2)
-                    ( case i of I# a ->             )    -- (2)
-                    ( case j of I# b ->             )    -- (2)
-                    ( (# a, b #)                    )    -- (3)
-    ```
-  * A result-building expression for the wrapper, with a hole for the worker call:
-    ```
-      build wkr_call = ( case <wkr_call> of (# a, b #) -> )    -- (3)
-                       ( (I# a, I# b)                     )    -- (2)
-    ```
-  * The result type of the worker, e.g., `(# Int#, Int# #)` above.
-
-To achieve said transformation, 'mkWWcpr_entry'
-
-  1. First allocates a fresh result binder `r`, giving a name to the `body`
-     expression and contributing part (1) of the unpacker and builder.
-  2. Then it delegates to 'mkWWcpr_one', which recurses into all result fields
-     to unbox, contributing the parts marked with (2). Crucially, it knows
-     what belongs in the case scrutinee of the unpacker through the communicated
-     Id `r`: The unpacking expression will be free in that variable.
-     (This is a similar contract as that of 'mkWWstr_one' for strict args.)
-  3. 'mkWWstr_one' produces a bunch of *transit vars*: Those result variables
-     that have to be transferred from the worker to the wrapper, where the
-     constructed result can be rebuilt, `a` and `b` above. Part (3) is
-     responsible for tupling them up in the worker and taking the tuple apart
-     in the wrapper. This is implemented in 'move_transit_vars'.
-
-Note [No unboxed tuple for single, unlifted transit var]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When there's only a single, unlifted transit var (Note [Worker/wrapper for CPR]),
-we don't wrap an unboxed singleton tuple around it (which otherwise would be
-needed to suspend evaluation) and return the unlifted thing directly. E.g.
-```
-  f :: Int -> Int
-  f x = x+1
-```
-We certainly want `$wf :: Int# -> Int#`, not `$wf :: Int# -> (# Int# #)`.
-This is OK as long as we know that evaluation of the returned thing terminates
-quickly, as is the case for fields of unlifted type like `Int#`.
-
-But more generally, this should also be true for *lifted* types that terminate
-quickly! Consider from `T18109`:
-```
-  data F = F (Int -> Int)
-  f :: Int -> F
-  f n = F (+n)
-
-  data T = T (Int, Int)
-  g :: T -> T
-  g t@(T p) = p `seq` t
-
-  data U = U ![Int]
-  h :: Int -> U
-  h n = U [0..n]
-```
-All of the nested fields are actually ok-for-speculation and thus OK to
-return unboxed instead of in an unboxed singleton tuple:
-
- 1. The field of `F` is a HNF.
-    We want `$wf :: Int -> Int -> Int`.
-    We get  `$wf :: Int -> (# Int -> Int #)`.
- 2. The field of `T` is `seq`'d in `g`.
-    We want `$wg :: (Int, Int) -> (Int, Int)`.
-    We get  `$wg :: (Int, Int) -> (# (Int, Int) #)`.
- 3. The field of `U` is strict and thus always evaluated.
-    We want  `$wh :: Int# -> [Int]`.
-    We'd get `$wh :: Int# -> (# [Int] #)`.
-
-By considering vars as unlifted that satisfy 'exprIsHNF', we catch (3).
-Why not check for 'exprOkForSpeculation'? Quite perplexingly, evaluated vars
-are not ok-for-spec, see Note [exprOkForSpeculation and evaluated variables].
-For (1) and (2) we would have to look at the term. WW only looks at the
-type and the CPR signature, so the only way to fix (1) and (2) would be to
-have a nested termination signature, like in MR !1866.
-
-Note [Linear types and CPR]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Remark on linearity: in both the case of the wrapper and the worker,
-we build a linear case to unpack constructed products. All the
-multiplicity information is kept in the constructors (both C and (#, #)).
-In particular (#,#) is parameterised by the multiplicity of its fields.
-Specifically, in this instance, the multiplicity of the fields of (#,#)
-is chosen to be the same as those of C.
-
-
-************************************************************************
-*                                                                      *
-\subsection{Utilities}
-*                                                                      *
-************************************************************************
--}
-
-mkUnpackCase ::  CoreExpr -> Coercion -> Mult -> DataCon -> [Id] -> CoreExpr -> CoreExpr
--- (mkUnpackCase e co Con args body)
---      returns
--- case e |> co of _dead { Con args -> body }
-mkUnpackCase (Tick tickish e) co mult con args body   -- See Note [Profiling and unpacking]
-  = Tick tickish (mkUnpackCase e co mult con args body)
-mkUnpackCase scrut co mult boxing_con unpk_args body
-  = mkSingleAltCase casted_scrut bndr
-                    (DataAlt boxing_con) unpk_args body
-  where
-    casted_scrut = scrut `mkCast` co
-    bndr = mkWildValBinder mult (exprType casted_scrut)
-
--- | The multiplicity of a case binder unboxing a constructed result.
--- See Note [Linear types and CPR]
-cprCaseBndrMult :: Mult
-cprCaseBndrMult = OneTy
-
-ww_prefix :: FastString
-ww_prefix = fsLit "ww"
-
-{- Note [Profiling and unpacking]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If the original function looked like
-        f = \ x -> {-# SCC "foo" #-} E
-
-then we want the CPR'd worker to look like
-        \ x -> {-# SCC "foo" #-} (case E of I# x -> x)
-and definitely not
-        \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)
-
-This transform doesn't move work or allocation
-from one cost centre to another.
-
-Later [SDM]: presumably this is because we want the simplifier to
-eliminate the case, and the scc would get in the way?  I'm ok with
-including the case itself in the cost centre, since it is morally
-part of the function (post transformation) anyway.
--}
diff --git a/compiler/GHC/Core/TyCon/Set.hs b/compiler/GHC/Core/TyCon/Set.hs
deleted file mode 100644
--- a/compiler/GHC/Core/TyCon/Set.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
-
-
-module GHC.Core.TyCon.Set (
-        -- * TyCons set type
-        TyConSet,
-
-        -- ** Manipulating these sets
-        emptyTyConSet, unitTyConSet, mkTyConSet, unionTyConSet, unionTyConSets,
-        minusTyConSet, elemTyConSet, extendTyConSet, extendTyConSetList,
-        delFromTyConSet, delListFromTyConSet, isEmptyTyConSet, filterTyConSet,
-        intersectsTyConSet, disjointTyConSet, intersectTyConSet,
-        nameSetAny, nameSetAll
-    ) where
-
-import GHC.Prelude
-
-import GHC.Types.Unique.Set
-import GHC.Core.TyCon (TyCon)
-
-type TyConSet = UniqSet TyCon
-
-emptyTyConSet       :: TyConSet
-unitTyConSet        :: TyCon -> TyConSet
-extendTyConSetList   :: TyConSet -> [TyCon] -> TyConSet
-extendTyConSet    :: TyConSet -> TyCon -> TyConSet
-mkTyConSet          :: [TyCon] -> TyConSet
-unionTyConSet      :: TyConSet -> TyConSet -> TyConSet
-unionTyConSets  :: [TyConSet] -> TyConSet
-minusTyConSet       :: TyConSet -> TyConSet -> TyConSet
-elemTyConSet        :: TyCon -> TyConSet -> Bool
-isEmptyTyConSet     :: TyConSet -> Bool
-delFromTyConSet     :: TyConSet -> TyCon -> TyConSet
-delListFromTyConSet :: TyConSet -> [TyCon] -> TyConSet
-filterTyConSet      :: (TyCon -> Bool) -> TyConSet -> TyConSet
-intersectTyConSet   :: TyConSet -> TyConSet -> TyConSet
-intersectsTyConSet  :: TyConSet -> TyConSet -> Bool
--- ^ True if there is a non-empty intersection.
--- @s1 `intersectsTyConSet` s2@ doesn't compute @s2@ if @s1@ is empty
-disjointTyConSet    :: TyConSet -> TyConSet -> Bool
-
-isEmptyTyConSet    = isEmptyUniqSet
-emptyTyConSet      = emptyUniqSet
-unitTyConSet       = unitUniqSet
-mkTyConSet         = mkUniqSet
-extendTyConSetList = addListToUniqSet
-extendTyConSet     = addOneToUniqSet
-unionTyConSet      = unionUniqSets
-unionTyConSets     = unionManyUniqSets
-minusTyConSet      = minusUniqSet
-elemTyConSet       = elementOfUniqSet
-delFromTyConSet    = delOneFromUniqSet
-filterTyConSet     = filterUniqSet
-intersectTyConSet  = intersectUniqSets
-disjointTyConSet   = disjointUniqSets
-
-
-delListFromTyConSet set ns = foldl' delFromTyConSet set ns
-
-intersectsTyConSet s1 s2 = not (isEmptyTyConSet (s1 `intersectTyConSet` s2))
-
-nameSetAny :: (TyCon -> Bool) -> TyConSet -> Bool
-nameSetAny = uniqSetAny
-
-nameSetAll :: (TyCon -> Bool) -> TyConSet -> Bool
-nameSetAll = uniqSetAll
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
deleted file mode 100644
--- a/compiler/GHC/CoreToStg.hs
+++ /dev/null
@@ -1,1008 +0,0 @@
-{-# LANGUAGE DataKinds #-}
-
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE TypeFamilies #-}
-
---
--- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
---
-
---------------------------------------------------------------
--- Converting Core to STG Syntax
---------------------------------------------------------------
-
--- And, as we have the info in hand, we may convert some lets to
--- let-no-escapes.
-
-module GHC.CoreToStg ( CoreToStgOpts (..), coreToStg ) where
-
-import GHC.Prelude
-
-import GHC.Core
-import GHC.Core.Utils   ( exprType, findDefault, isJoinBind
-                        , exprIsTickedString_maybe )
-import GHC.Core.Opt.Arity   ( manifestArity )
-import GHC.Core.Type
-import GHC.Core.TyCon
-import GHC.Core.DataCon
-
-import GHC.Stg.Syntax
-import GHC.Stg.Debug
-import GHC.Stg.Utils
-
-import GHC.Types.RepType
-import GHC.Types.Id.Make ( coercionTokenId )
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.CostCentre
-import GHC.Types.Tickish
-import GHC.Types.Var.Env
-import GHC.Types.Name   ( isExternalName, nameModule_maybe )
-import GHC.Types.Basic  ( Arity, TypeOrConstraint(..) )
-import GHC.Types.Literal
-import GHC.Types.ForeignCall
-import GHC.Types.IPE
-import GHC.Types.Demand    ( isUsedOnceDmd )
-import GHC.Types.SrcLoc    ( mkGeneralSrcSpan )
-
-import GHC.Unit.Module
-import GHC.Data.FastString
-import GHC.Platform        ( Platform )
-import GHC.Platform.Ways
-import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId )
-
-import GHC.Utils.Outputable
-import GHC.Utils.Monad
-import GHC.Utils.Misc (HasDebugCallStack)
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-import Control.Monad (ap)
-import Data.Maybe (fromMaybe)
-
--- Note [Live vs free]
--- ~~~~~~~~~~~~~~~~~~~
---
--- The two are not the same. Liveness is an operational property rather
--- than a semantic one. A variable is live at a particular execution
--- point if it can be referred to directly again. In particular, a dead
--- variable's stack slot (if it has one):
---
---           - should be stubbed to avoid space leaks, and
---           - may be reused for something else.
---
--- There ought to be a better way to say this. Here are some examples:
---
---         let v = [q] \[x] -> e
---         in
---         ...v...  (but no q's)
---
--- Just after the `in', v is live, but q is dead. If the whole of that
--- let expression was enclosed in a case expression, thus:
---
---         case (let v = [q] \[x] -> e in ...v...) of
---                 alts[...q...]
---
--- (ie `alts' mention `q'), then `q' is live even after the `in'; because
--- we'll return later to the `alts' and need it.
---
--- Let-no-escapes make this a bit more interesting:
---
---         let-no-escape v = [q] \ [x] -> e
---         in
---         ...v...
---
--- Here, `q' is still live at the `in', because `v' is represented not by
--- a closure but by the current stack state.  In other words, if `v' is
--- live then so is `q'. Furthermore, if `e' mentions an enclosing
--- let-no-escaped variable, then its free variables are also live if `v' is.
-
--- Note [What are these SRTs all about?]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- Consider the Core program,
---
---     fibs = go 1 1
---       where go a b = let c = a + c
---                      in c : go b c
---     add x = map (\y -> x*y) fibs
---
--- In this case we have a CAF, 'fibs', which is quite large after evaluation and
--- has only one possible user, 'add'. Consequently, we want to ensure that when
--- all references to 'add' die we can garbage collect any bit of 'fibs' that we
--- have evaluated.
---
--- However, how do we know whether there are any references to 'fibs' still
--- around? Afterall, the only reference to it is buried in the code generated
--- for 'add'. The answer is that we record the CAFs referred to by a definition
--- in its info table, namely a part of it known as the Static Reference Table
--- (SRT).
---
--- Since SRTs are so common, we use a special compact encoding for them in: we
--- produce one table containing a list of CAFs in a module and then include a
--- bitmap in each info table describing which entries of this table the closure
--- references.
---
--- See also: commentary/rts/storage/gc/CAFs on the GHC Wiki.
-
--- Note [What is a non-escaping let]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- NB: Nowadays this is recognized by the occurrence analyser by turning a
--- "non-escaping let" into a join point. The following is then an operational
--- account of join points.
---
--- Consider:
---
---     let x = fvs \ args -> e
---     in
---         if ... then x else
---            if ... then x else ...
---
--- `x' is used twice (so we probably can't unfold it), but when it is
--- entered, the stack is deeper than it was when the definition of `x'
--- happened.  Specifically, if instead of allocating a closure for `x',
--- we saved all `x's fvs on the stack, and remembered the stack depth at
--- that moment, then whenever we enter `x' we can simply set the stack
--- pointer(s) to these remembered (compile-time-fixed) values, and jump
--- to the code for `x'.
---
--- All of this is provided x is:
---   1. non-updatable;
---   2. guaranteed to be entered before the stack retreats -- ie x is not
---      buried in a heap-allocated closure, or passed as an argument to
---      something;
---   3. all the enters have exactly the right number of arguments,
---      no more no less;
---   4. all the enters are tail calls; that is, they return to the
---      caller enclosing the definition of `x'.
---
--- Under these circumstances we say that `x' is non-escaping.
---
--- An example of when (4) does not hold:
---
---     let x = ...
---     in case x of ...alts...
---
--- Here, `x' is certainly entered only when the stack is deeper than when
--- `x' is defined, but here it must return to ...alts... So we can't just
--- adjust the stack down to `x''s recalled points, because that would lost
--- alts' context.
---
--- Things can get a little more complicated.  Consider:
---
---     let y = ...
---     in let x = fvs \ args -> ...y...
---     in ...x...
---
--- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a
--- non-escaping way in ...y..., then `y' is non-escaping.
---
--- `x' can even be recursive!  Eg:
---
---     letrec x = [y] \ [v] -> if v then x True else ...
---     in
---         ...(x b)...
-
--- Note [Cost-centre initialization plan]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`,
--- and the fields were then fixed by a separate pass `stgMassageForProfiling`.
--- We now initialize these correctly. The initialization works like this:
---
---   - For non-top level bindings always use `currentCCS`.
---
---   - For top-level bindings, check if the binding is a CAF
---
---     - CAF:      If -fcaf-all is enabled, create a new CAF just for this CAF
---                 and use it. Note that these new cost centres need to be
---                 collected to be able to generate cost centre initialization
---                 code, so `coreToTopStgRhs` now returns `CollectedCCs`.
---
---                 If -fcaf-all is not enabled, use "all CAFs" cost centre.
---
---     - Non-CAF:  Top-level (static) data is not counted in heap profiles; nor
---                 do we set CCCS from it; so we just slam in
---                 dontCareCostCentre.
-
--- Note [Coercion tokens]
--- ~~~~~~~~~~~~~~~~~~~~~~
--- In coreToStgArgs, we drop type arguments completely, but we replace
--- coercions with a special coercionToken# placeholder. Why? Consider:
---
---   f :: forall a. Int ~# Bool -> a
---   f = /\a. \(co :: Int ~# Bool) -> error "impossible"
---
--- If we erased the coercion argument completely, we’d end up with just
--- f = error "impossible", but then f `seq` () would be ⊥!
---
--- This is an artificial example, but back in the day we *did* treat
--- coercion lambdas like type lambdas, and we had bug reports as a
--- result. So now we treat coercion lambdas like value lambdas, but we
--- treat coercions themselves as zero-width arguments — coercionToken#
--- has representation VoidRep — which gets the best of both worlds.
---
--- (For the gory details, see also the (unpublished) paper, “Practical
--- aspects of evidence-based compilation in System FC.”)
-
--- --------------------------------------------------------------
--- Setting variable info: top-level, binds, RHSs
--- --------------------------------------------------------------
-
-
-coreToStg :: CoreToStgOpts -> Module -> ModLocation -> CoreProgram
-          -> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
-coreToStg opts@CoreToStgOpts
-  { coreToStg_ways = ways
-  , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs
-  , coreToStg_InfoTableMap = opt_InfoTableMap
-  , coreToStg_stgDebugOpts = stgDebugOpts
-  } this_mod ml pgm
-  = (pgm'', denv, final_ccs)
-  where
-    (_, (local_ccs, local_cc_stacks), pgm')
-      = coreTopBindsToStg opts this_mod emptyVarEnv emptyCollectedCCs pgm
-
-    -- See Note [Mapping Info Tables to Source Positions]
-    (!pgm'', !denv)
-      | opt_InfoTableMap
-      = collectDebugInformation stgDebugOpts ml pgm'
-      | otherwise = (pgm', emptyInfoTableProvMap)
-
-    prof = hasWay ways WayProf
-
-    final_ccs
-      | prof && opt_AutoSccsOnIndividualCafs
-      = (local_ccs,local_cc_stacks)  -- don't need "all CAFs" CC
-      | prof
-      = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks)
-      | otherwise
-      = emptyCollectedCCs
-
-    (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod
-
-coreTopBindsToStg
-    :: CoreToStgOpts
-    -> Module
-    -> IdEnv HowBound           -- environment for the bindings
-    -> CollectedCCs
-    -> CoreProgram
-    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
-
-coreTopBindsToStg _      _        env ccs []
-  = (env, ccs, [])
-coreTopBindsToStg opts this_mod env ccs (b:bs)
-  | NonRec _ rhs <- b, isTyCoArg rhs
-  = coreTopBindsToStg opts this_mod env1 ccs1 bs
-  | otherwise
-  = (env2, ccs2, b':bs')
-  where
-    (env1, ccs1, b' ) = coreTopBindToStg opts this_mod env ccs b
-    (env2, ccs2, bs') = coreTopBindsToStg opts this_mod env1 ccs1 bs
-
-coreTopBindToStg
-        :: CoreToStgOpts
-        -> Module
-        -> IdEnv HowBound
-        -> CollectedCCs
-        -> CoreBind
-        -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
-
-coreTopBindToStg _ _ env ccs (NonRec id e)
-  | Just str <- exprIsTickedString_maybe e
-  -- top-level string literal
-  -- See Note [Core top-level string literals] in GHC.Core
-  = let
-        env' = extendVarEnv env id how_bound
-        how_bound = LetBound TopLet 0
-    in (env', ccs, StgTopStringLit id str)
-
-coreTopBindToStg opts@CoreToStgOpts
-  { coreToStg_platform = platform
-  } this_mod env ccs (NonRec id rhs)
-  = let
-        env'      = extendVarEnv env id how_bound
-        how_bound = LetBound TopLet $! manifestArity rhs
-
-        (ccs', (id', stg_rhs)) =
-            initCts platform env $
-              coreToTopStgRhs opts this_mod ccs (id,rhs)
-
-        bind = StgTopLifted $ StgNonRec id' stg_rhs
-    in
-      -- NB: previously the assertion printed 'rhs' and 'bind'
-      --     as well as 'id', but that led to a black hole
-      --     where printing the assertion error tripped the
-      --     assertion again!
-    (env', ccs', bind)
-
-coreTopBindToStg opts@CoreToStgOpts
-  { coreToStg_platform = platform
-  } this_mod env ccs (Rec pairs)
-  = assert (not (null pairs)) $
-    let
-        extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
-                     | (b, rhs) <- pairs ]
-        env' = extendVarEnvList env extra_env'
-
-        -- generate StgTopBindings and CAF cost centres created for CAFs
-        (ccs', stg_rhss)
-          = initCts platform env' $ mapAccumLM (coreToTopStgRhs opts this_mod) ccs pairs
-        bind = StgTopLifted $ StgRec stg_rhss
-    in
-    (env', ccs', bind)
-
-coreToTopStgRhs
-        :: CoreToStgOpts
-        -> Module
-        -> CollectedCCs
-        -> (Id,CoreExpr)
-        -> CtsM (CollectedCCs, (Id, StgRhs))
-
-coreToTopStgRhs opts this_mod ccs (bndr, rhs)
-  = do { new_rhs <- coreToPreStgRhs rhs
-
-       ; let (stg_rhs, ccs') =
-               mkTopStgRhs opts this_mod ccs bndr new_rhs
-             stg_arity =
-               stgRhsArity stg_rhs
-
-       ; pure (ccs', (bndr, assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs)) }
-  where
-        -- It's vital that the arity on a top-level Id matches
-        -- the arity of the generated STG binding, else an importing
-        -- module will use the wrong calling convention
-        --      (#2844 was an example where this happened)
-        -- NB1: we can't move the assertion further out without
-        --      blocking the "knot" tied in coreTopBindsToStg
-        -- NB2: the arity check is only needed for Ids with External
-        --      Names, because they are externally visible.  The CorePrep
-        --      pass introduces "sat" things with Local Names and does
-        --      not bother to set their Arity info, so don't fail for those
-    arity_ok stg_arity
-       | isExternalName (idName bndr) = id_arity == stg_arity
-       | otherwise                    = True
-    id_arity  = idArity bndr
-    mk_arity_msg stg_arity
-        = vcat [ppr bndr,
-                text "Id arity:" <+> ppr id_arity,
-                text "STG arity:" <+> ppr stg_arity]
-
--- ---------------------------------------------------------------------------
--- Expressions
--- ---------------------------------------------------------------------------
-
--- coreToStgExpr panics if the input expression is a value lambda. CorePrep
--- ensures that value lambdas only exist as the RHS of bindings, which we
--- handle with the function coreToPreStgRhs.
-
-coreToStgExpr
-        :: HasDebugCallStack => CoreExpr
-        -> CtsM StgExpr
-
--- The second and third components can be derived in a simple bottom up pass, not
--- dependent on any decisions about which variables will be let-no-escaped or
--- not.  The first component, that is, the decorated expression, may then depend
--- on these components, but it in turn is not scrutinised as the basis for any
--- decisions.  Hence no black holes.
-
--- No bignum literal should be left by the time this is called.
--- CorePrep should have converted them all to a real core representation.
-coreToStgExpr (Lit (LitNumber LitNumBigNat _))  = panic "coreToStgExpr: LitNumBigNat"
-coreToStgExpr (Lit l)                           = return (StgLit l)
-coreToStgExpr (Var v) = coreToStgApp v [] []
-coreToStgExpr (Coercion _)
-  -- See Note [Coercion tokens]
-  = coreToStgApp coercionTokenId [] []
-
-coreToStgExpr expr@(App _ _)
-  = case app_head of
-      Var f -> coreToStgApp f args ticks -- Regular application
-      Lit l | isLitRubbish l             -- If there is LitRubbish at the head,
-                                         --    discard the arguments
-                                         --    Recompute representation, because in
-                                         --    '(RUBBISH[rep] x) :: (T :: TYPE rep2)'
-                                         --    rep might not be equal to rep2
-            -> return (StgLit $ LitRubbish TypeLike $ getRuntimeRep (exprType expr))
-
-      _     -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr)
-    where
-      (app_head, args, ticks) = myCollectArgs expr
-coreToStgExpr expr@(Lam _ _)
-  = let
-        (args, body) = myCollectBinders expr
-    in
-    case filterStgBinders args of
-
-      [] -> coreToStgExpr body
-
-      _ -> pprPanic "coretoStgExpr" $
-        text "Unexpected value lambda:" $$ ppr expr
-
-coreToStgExpr (Tick tick expr)
-  = do
-       let !stg_tick = coreToStgTick (exprType expr) tick
-       !expr2 <- coreToStgExpr expr
-       return (StgTick stg_tick expr2)
-
-coreToStgExpr (Cast expr _)
-  = coreToStgExpr expr
-
--- Cases require a little more real work.
-
-{-
-coreToStgExpr (Case scrut _ _ [])
-  = coreToStgExpr scrut
-    -- See Note [Empty case alternatives] in GHC.Core If the case
-    -- alternatives are empty, the scrutinee must diverge or raise an
-    -- exception, so we can just dive into it.
-    --
-    -- Of course this may seg-fault if the scrutinee *does* return.  A
-    -- belt-and-braces approach would be to move this case into the
-    -- code generator, and put a return point anyway that calls a
-    -- runtime system error function.
-
-coreToStgExpr e0@(Case scrut bndr _ [alt]) = do
-  | isUnsafeEqualityProof scrut
-  , isDeadBinder bndr -- We can only discard the case if the case-binder is dead
-                      -- It usually is, but see #18227
-  , (_,_,rhs) <- alt
-  = coreToStgExpr rhs
-    -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
--}
-
--- The normal case for case-expressions
-coreToStgExpr (Case scrut bndr _ alts)
-  = do { scrut2 <- coreToStgExpr scrut
-       ; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
-       ; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) }
-  where
-    vars_alt :: CoreAlt -> CtsM StgAlt
-    vars_alt (Alt con binders rhs)
-      = let     -- Remove type variables
-            binders' = filterStgBinders binders
-        in
-        extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do
-        rhs2 <- coreToStgExpr rhs
-        return $! GenStgAlt{ alt_con   = con
-                           , alt_bndrs = binders'
-                           , alt_rhs   = rhs2
-                           }
-
-coreToStgExpr (Let bind body) = coreToStgLet bind body
-coreToStgExpr e               = pprPanic "coreToStgExpr" (ppr e)
-
-mkStgAltType :: Id -> [CoreAlt] -> AltType
-mkStgAltType bndr alts
-  | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty
-  = MultiValAlt (length prim_reps)  -- always use MultiValAlt for unboxed tuples
-
-  | otherwise
-  = case prim_reps of
-      [rep] | isGcPtrRep rep ->
-        case tyConAppTyCon_maybe (unwrapType bndr_ty) of
-          Just tc
-            | isAbstractTyCon tc -> look_for_better_tycon
-            | isAlgTyCon tc      -> AlgAlt tc
-            | otherwise          -> assertPpr (_is_poly_alt_tycon tc) (ppr tc) PolyAlt
-          Nothing                -> PolyAlt
-      [non_gcd] -> PrimAlt non_gcd
-      not_unary -> MultiValAlt (length not_unary)
-  where
-   bndr_ty   = idType bndr
-   prim_reps = typePrimRep bndr_ty
-
-   _is_poly_alt_tycon tc
-        =  isPrimTyCon tc   -- "Any" is lifted but primitive
-        || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict
-                            -- function application where argument has a
-                            -- type-family type
-
-   -- Sometimes, the TyCon is a AbstractTyCon which may not have any
-   -- constructors inside it.  Then we may get a better TyCon by
-   -- grabbing the one from a constructor alternative
-   -- if one exists.
-   look_for_better_tycon
-        | ((Alt (DataAlt con) _ _) : _) <- data_alts =
-                AlgAlt (dataConTyCon con)
-        | otherwise =
-                assert (null data_alts)
-                PolyAlt
-        where
-                (data_alts, _deflt) = findDefault alts
-
--- ---------------------------------------------------------------------------
--- Applications
--- ---------------------------------------------------------------------------
-
-coreToStgApp :: Id            -- Function
-             -> [CoreArg]     -- Arguments
-             -> [CoreTickish] -- Debug ticks
-             -> CtsM StgExpr
-coreToStgApp f args ticks = do
-    (args', ticks') <- coreToStgArgs args
-    how_bound <- lookupVarCts f
-
-    let
-        n_val_args       = valArgCount args
-
-        -- Mostly, the arity info of a function is in the fn's IdInfo
-        -- But new bindings introduced by CoreSat may not have no
-        -- arity info; it would do us no good anyway.  For example:
-        --      let f = \ab -> e in f
-        -- No point in having correct arity info for f!
-        -- Hence the hasArity stuff below.
-        -- NB: f_arity is only consulted for LetBound things
-        f_arity   = stgArity f how_bound
-        saturated = f_arity <= n_val_args
-
-        res_ty = exprType (mkApps (Var f) args)
-        app = case idDetails f of
-                DataConWorkId dc
-                  | saturated    -> StgConApp dc NoNumber args'
-                                      (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))
-
-                -- Some primitive operator that might be implemented as a library call.
-                -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps
-                -- we require that primop applications be saturated.
-                PrimOpId op _    -> -- assertPpr saturated (ppr f <+> ppr args) $
-                                    StgOpApp (StgPrimOp op) args' res_ty
-
-                -- A call to some primitive Cmm function.
-                FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)
-                                          PrimCallConv _))
-                                 -> assert saturated $
-                                    StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
-
-                -- A regular foreign call.
-                FCallId call     -> assert saturated $
-                                    StgOpApp (StgFCallOp call (idType f)) args' res_ty
-
-                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
-                _other           -> StgApp f args'
-
-        add_tick !t !e = StgTick t e
-        tapp = foldr add_tick app (map (coreToStgTick res_ty) ticks ++ ticks')
-
-    -- Forcing these fixes a leak in the code generator, noticed while
-    -- profiling for trac #4367
-    app `seq` return tapp
-
--- ---------------------------------------------------------------------------
--- Argument lists
--- This is the guy that turns applications into A-normal form
--- ---------------------------------------------------------------------------
-
-coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish])
-coreToStgArgs []
-  = return ([], [])
-
-coreToStgArgs (Type _ : args) = do     -- Type argument
-    (args', ts) <- coreToStgArgs args
-    return (args', ts)
-
-coreToStgArgs (Coercion _ : args) -- Coercion argument; See Note [Coercion tokens]
-  = do { (args', ts) <- coreToStgArgs args
-       ; return (StgVarArg coercionTokenId : args', ts) }
-
-coreToStgArgs (Tick t e : args)
-  = assert (not (tickishIsCode t)) $
-    do { (args', ts) <- coreToStgArgs (e : args)
-       ; let !t' = coreToStgTick (exprType e) t
-       ; return (args', t':ts) }
-
-coreToStgArgs (arg : args) = do         -- Non-type argument
-    (stg_args, ticks) <- coreToStgArgs args
-    arg' <- coreToStgExpr arg
-    let
-        (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
-        stg_arg = case arg'' of
-           StgApp v []                  -> StgVarArg v
-           StgConApp con _ [] _         -> StgVarArg (dataConWorkId con)
-           StgOpApp (StgPrimOp op) [] _ -> StgVarArg (primOpWrapperId op)
-           StgLit lit                   -> StgLitArg lit
-           _ -> pprPanic "coreToStgArgs" (ppr arg $$ pprStgExpr panicStgPprOpts arg' $$ pprStgExpr panicStgPprOpts arg'')
-
-        -- WARNING: what if we have an argument like (v `cast` co)
-        --          where 'co' changes the representation type?
-        --          (This really only happens if co is unsafe.)
-        -- Then all the getArgAmode stuff in CgBindery will set the
-        -- cg_rep of the CgIdInfo based on the type of v, rather
-        -- than the type of 'co'.
-        -- This matters particularly when the function is a primop
-        -- or foreign call.
-        -- Wanted: a better solution than this hacky warning
-
-    platform <- getPlatform
-    let
-        arg_rep = typePrimRep (exprType arg)
-        stg_arg_rep = typePrimRep (stgArgType stg_arg)
-        bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep)
-
-    warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) $
-     return (stg_arg : stg_args, ticks ++ aticks)
-
-coreToStgTick :: Type -- type of the ticked expression
-              -> CoreTickish
-              -> StgTickish
-coreToStgTick _ty (HpcTick m i)           = HpcTick m i
-coreToStgTick _ty (SourceNote span nm)    = SourceNote span nm
-coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope
-coreToStgTick !ty (Breakpoint _ bid fvs)  = Breakpoint ty bid fvs
-
--- ---------------------------------------------------------------------------
--- The magic for lets:
--- ---------------------------------------------------------------------------
-
-coreToStgLet
-         :: CoreBind     -- bindings
-         -> CoreExpr     -- body
-         -> CtsM StgExpr -- new let
-
-coreToStgLet bind body
-  | NonRec _ rhs <- bind, isTyCoArg rhs
-  = coreToStgExpr body
-
-  | otherwise
-  = do { (bind2, env_ext) <- vars_bind bind
-
-          -- Do the body
-         ; body2 <- extendVarEnvCts env_ext $
-                    coreToStgExpr body
-
-        -- Compute the new let-expression
-        ; let new_let | isJoinBind bind
-                      = StgLetNoEscape noExtFieldSilent bind2 body2
-                      | otherwise
-                      = StgLet noExtFieldSilent bind2 body2
-
-        ; return new_let }
-  where
-    mk_binding binder rhs
-        = (binder, LetBound NestedLet (manifestArity rhs))
-
-    vars_bind :: CoreBind
-              -> CtsM (StgBinding,
-                       [(Id, HowBound)])  -- extension to environment
-
-    vars_bind (NonRec binder rhs) = do
-        rhs2 <- coreToStgRhs (binder,rhs)
-        let
-            env_ext_item = mk_binding binder rhs
-
-        return (StgNonRec binder rhs2, [env_ext_item])
-
-    vars_bind (Rec pairs)
-      =    let
-                binders = map fst pairs
-                env_ext = [ mk_binding b rhs
-                          | (b,rhs) <- pairs ]
-           in
-           extendVarEnvCts env_ext $ do
-              rhss2 <- mapM coreToStgRhs pairs
-              return (StgRec (binders `zip` rhss2), env_ext)
-
-coreToStgRhs :: (Id,CoreExpr)
-             -> CtsM StgRhs
-
-coreToStgRhs (bndr, rhs) = do
-    new_rhs <- coreToPreStgRhs rhs
-    return (mkStgRhs bndr new_rhs)
-
--- Represents the RHS of a binding for use with mk(Top)StgRhs.
-data PreStgRhs = PreStgRhs [Id] StgExpr -- The [Id] is empty for thunks
-
--- Convert the RHS of a binding from Core to STG. This is a wrapper around
--- coreToStgExpr that can handle value lambdas.
-coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs
-coreToPreStgRhs expr
-  = extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $
-    do { body' <- coreToStgExpr body
-       ; return (PreStgRhs args' body') }
-  where
-   (args, body) = myCollectBinders expr
-   args'        = filterStgBinders args
-
--- Generate a top-level RHS. Any new cost centres generated for CAFs will be
--- appended to `CollectedCCs` argument.
-mkTopStgRhs :: CoreToStgOpts -> Module -> CollectedCCs
-            -> Id -> PreStgRhs -> (StgRhs, CollectedCCs)
-
-mkTopStgRhs CoreToStgOpts
-  { coreToStg_platform = platform
-  , coreToStg_ExternalDynamicRefs = opt_ExternalDynamicRefs
-  , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs
-  } this_mod ccs bndr (PreStgRhs bndrs rhs)
-  | not (null bndrs)
-  = -- The list of arguments is non-empty, so not CAF
-    ( StgRhsClosure noExtFieldSilent
-                    dontCareCCS
-                    ReEntrant
-                    bndrs rhs
-    , ccs )
-
-  -- After this point we know that `bndrs` is empty,
-  -- so this is not a function binding
-  | StgConApp con mn args _ <- unticked_rhs
-  , -- Dynamic StgConApps are updatable
-    not (isDllConApp platform opt_ExternalDynamicRefs this_mod con args)
-  = -- CorePrep does this right, but just to make sure
-    assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
-              (ppr bndr $$ ppr con $$ ppr args)
-    ( StgRhsCon dontCareCCS con mn ticks args, ccs )
-
-  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
-  | opt_AutoSccsOnIndividualCafs
-  = ( StgRhsClosure noExtFieldSilent
-                    caf_ccs
-                    upd_flag [] rhs
-    , collectCC caf_cc caf_ccs ccs )
-
-  | otherwise
-  = ( StgRhsClosure noExtFieldSilent
-                    all_cafs_ccs
-                    upd_flag [] rhs
-    , ccs )
-
-  where
-    (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
-
-    upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry
-             | otherwise                         = Updatable
-
-    -- CAF cost centres generated for -fcaf-all
-    caf_cc = mkAutoCC bndr modl
-    caf_ccs = mkSingletonCCS caf_cc
-           -- careful: the binder might be :Main.main,
-           -- which doesn't belong to module mod_name.
-           -- bug #249, tests prof001, prof002
-    modl | Just m <- nameModule_maybe (idName bndr) = m
-         | otherwise = this_mod
-
-    -- default CAF cost centre
-    (_, all_cafs_ccs) = getAllCAFsCC this_mod
-
--- Generate a non-top-level RHS. Cost-centre is always currentCCS,
--- see Note [Cost-centre initialization plan].
-mkStgRhs :: Id -> PreStgRhs -> StgRhs
-mkStgRhs bndr (PreStgRhs bndrs rhs)
-  | not (null bndrs)
-  = StgRhsClosure noExtFieldSilent
-                  currentCCS
-                  ReEntrant
-                  bndrs rhs
-
-  -- After this point we know that `bndrs` is empty,
-  -- so this is not a function binding
-
-  | isJoinId bndr -- Must be a nullary join point
-  = -- It might have /type/ arguments (T18328),
-    -- so its JoinArity might be >0
-    StgRhsClosure noExtFieldSilent
-                  currentCCS
-                  ReEntrant -- ignored for LNE
-                  [] rhs
-
-  | StgConApp con mn args _ <- unticked_rhs
-  = StgRhsCon currentCCS con mn ticks args
-
-  | otherwise
-  = StgRhsClosure noExtFieldSilent
-                  currentCCS
-                  upd_flag [] rhs
-  where
-    (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
-
-    upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry
-             | otherwise                         = Updatable
-
-  {-
-    SDM: disabled.  Eval/Apply can't handle functions with arity zero very
-    well; and making these into simple non-updatable thunks breaks other
-    assumptions (namely that they will be entered only once).
-
-    upd_flag | isPAP env rhs  = ReEntrant
-             | otherwise      = Updatable
-
--- Detect thunks which will reduce immediately to PAPs, and make them
--- non-updatable.  This has several advantages:
---
---         - the non-updatable thunk behaves exactly like the PAP,
---
---         - the thunk is more efficient to enter, because it is
---           specialised to the task.
---
---         - we save one update frame, one stg_update_PAP, one update
---           and lots of PAP_enters.
---
---         - in the case where the thunk is top-level, we save building
---           a black hole and furthermore the thunk isn't considered to
---           be a CAF any more, so it doesn't appear in any SRTs.
---
--- We do it here, because the arity information is accurate, and we need
--- to do it before the SRT pass to save the SRT entries associated with
--- any top-level PAPs.
-
-isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
-                              where
-                                 arity = stgArity f (lookupBinding env f)
-isPAP env _               = False
-
--}
-
-{- ToDo:
-          upd = if isOnceDem dem
-                    then (if isNotTop toplev
-                            then SingleEntry    -- HA!  Paydirt for "dem"
-                            else
-                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
-                     Updatable)
-                else Updatable
-        -- For now we forbid SingleEntry CAFs; they tickle the
-        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
-        -- and I don't understand why.  There's only one SE_CAF (well,
-        -- only one that tickled a great gaping bug in an earlier attempt
-        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
-        -- specifically Main.lvl6 in spectral/cryptarithm2.
-        -- So no great loss.  KSW 2000-07.
--}
-
--- ---------------------------------------------------------------------------
--- A monad for the core-to-STG pass
--- ---------------------------------------------------------------------------
-
--- There's a lot of stuff to pass around, so we use this CtsM
--- ("core-to-STG monad") monad to help.  All the stuff here is only passed
--- *down*.
-
-newtype CtsM a = CtsM
-    { unCtsM :: Platform -- Needed for checking for bad coercions in coreToStgArgs
-             -> IdEnv HowBound
-             -> a
-    }
-    deriving (Functor)
-
-data HowBound
-  = ImportBound         -- Used only as a response to lookupBinding; never
-                        -- exists in the range of the (IdEnv HowBound)
-
-  | LetBound            -- A let(rec) in this module
-        LetInfo         -- Whether top level or nested
-        Arity           -- Its arity (local Ids don't have arity info at this point)
-
-  | LambdaBound         -- Used for both lambda and case
-  deriving (Eq)
-
-data LetInfo
-  = TopLet              -- top level things
-  | NestedLet
-  deriving (Eq)
-
--- For a let(rec)-bound variable, x, we record LiveInfo, the set of
--- variables that are live if x is live.  This LiveInfo comprises
---         (a) dynamic live variables (ones with a non-top-level binding)
---         (b) static live variables (CAFs or things that refer to CAFs)
---
--- For "normal" variables (a) is just x alone.  If x is a let-no-escaped
--- variable then x is represented by a code pointer and a stack pointer
--- (well, one for each stack).  So all of the variables needed in the
--- execution of x are live if x is, and are therefore recorded in the
--- LetBound constructor; x itself *is* included.
---
--- The set of dynamic live variables is guaranteed ot have no further
--- let-no-escaped variables in it.
-
--- The std monad functions:
-
-initCts :: Platform -> IdEnv HowBound -> CtsM a -> a
-initCts platform env m = unCtsM m platform env
-
-
-
-{-# INLINE thenCts #-}
-{-# INLINE returnCts #-}
-
-returnCts :: a -> CtsM a
-returnCts e = CtsM $ \_ _ -> e
-
-thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
-thenCts m k = CtsM $ \platform env
-  -> unCtsM (k (unCtsM m platform env)) platform env
-
-instance Applicative CtsM where
-    pure = returnCts
-    (<*>) = ap
-
-instance Monad CtsM where
-    (>>=)  = thenCts
-
-getPlatform :: CtsM Platform
-getPlatform = CtsM const
-
--- Functions specific to this monad:
-
-extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
-extendVarEnvCts ids_w_howbound expr
-   =    CtsM $   \platform env
-   -> unCtsM expr platform (extendVarEnvList env ids_w_howbound)
-
-lookupVarCts :: Id -> CtsM HowBound
-lookupVarCts v = CtsM $ \_ env -> lookupBinding env v
-
-lookupBinding :: IdEnv HowBound -> Id -> HowBound
-lookupBinding env v = case lookupVarEnv env v of
-                        Just xx -> xx
-                        Nothing -> assertPpr (isGlobalId v) (ppr v) ImportBound
-
-getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
-getAllCAFsCC this_mod =
-    let
-      span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
-      all_cafs_cc  = mkAllCafsCC this_mod span
-      all_cafs_ccs = mkSingletonCCS all_cafs_cc
-    in
-      (all_cafs_cc, all_cafs_ccs)
-
--- Misc.
-
-filterStgBinders :: [Var] -> [Var]
-filterStgBinders bndrs = filter isId bndrs
-
-myCollectBinders :: Expr Var -> ([Var], Expr Var)
-myCollectBinders expr
-  = go [] expr
-  where
-    go bs (Lam b e)          = go (b:bs) e
-    go bs (Cast e _)         = go bs e
-    go bs e                  = (reverse bs, e)
-
--- | If the argument expression is (potential chain of) 'App', return the head
--- of the app chain, and collect ticks/args along the chain.
-myCollectArgs :: HasDebugCallStack => CoreExpr -> (CoreExpr, [CoreArg], [CoreTickish])
-myCollectArgs expr
-  = go expr [] []
-  where
-    go h@(Var _v)       as ts = (h, as, ts)
-    go (App f a)        as ts = go f (a:as) ts
-    go (Tick t e)       as ts = assertPpr (not (tickishIsCode t) || all isTypeArg as)
-                                          (ppr e $$ ppr as $$ ppr ts) $
-                                -- See Note [Ticks in applications]
-                                go e as (t:ts) -- ticks can appear in type apps
-    go (Cast e _)       as ts = go e as ts
-    go (Lam b e)        as ts
-       | isTyVar b            = go e as ts -- Note [Collect args]
-    go e                as ts = (e, as, ts)
-
-{- Note [Collect args]
-~~~~~~~~~~~~~~~~~~~~~~
-This big-lambda case occurred following a rather obscure eta expansion.
-It all seems a bit yukky to me.
-
-Note [Ticks in applications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We can get an application like
-   (tick t f) True False
-via inlining in the CorePrep pass; see Note [Inlining in CorePrep]
-in GHC.CoreToStg.Prep.  The tick does not satisfy tickishIsCode;
-the inlining-in-CorePrep happens for cpExprIsTrivial which tests
-tickishIsCode.
-
-So we test the same thing here, pushing any non-code ticks to
-the top (they don't generate any code, after all).  This showed
-up in the fallout from fixing #19360.
--}
-
-stgArity :: Id -> HowBound -> Arity
-stgArity _ (LetBound _ arity) = arity
-stgArity f ImportBound        = idArity f
-stgArity _ LambdaBound        = 0
-
-data CoreToStgOpts = CoreToStgOpts
-  { coreToStg_platform :: Platform
-  , coreToStg_ways :: Ways
-  , coreToStg_AutoSccsOnIndividualCafs :: Bool
-  , coreToStg_InfoTableMap :: Bool
-  , coreToStg_ExternalDynamicRefs :: Bool
-  , coreToStg_stgDebugOpts :: StgDebugOpts
-  }
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
deleted file mode 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ /dev/null
@@ -1,2334 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-{-
-(c) The University of Glasgow, 1994-2006
-
-
-Core pass to saturate constructors and PrimOps
--}
-
-module GHC.CoreToStg.Prep
-   ( CorePrepConfig (..)
-   , CorePrepPgmConfig (..)
-   , corePrepPgm
-   , corePrepExpr
-   , mkConvertNumLiteral
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Platform
-
-import GHC.Driver.Flags
-
-import GHC.Tc.Utils.Env
-import GHC.Unit
-
-import GHC.Builtin.Names
-import GHC.Builtin.Types
-
-import GHC.Core.Utils
-import GHC.Core.Opt.Arity
-import GHC.Core.Lint    ( EndPassConfig(..), endPassIO )
-import GHC.Core
-import GHC.Core.Make hiding( FloatBind(..) )   -- We use our own FloatBind here
-import GHC.Core.Type
-import GHC.Core.Coercion
-import GHC.Core.TyCon
-import GHC.Core.DataCon
-import GHC.Core.Opt.OccurAnal
-import GHC.Core.TyCo.Rep( UnivCoProvenance(..) )
-
-import GHC.Data.Maybe
-import GHC.Data.OrdList
-import GHC.Data.FastString
-import GHC.Data.Pair
-import GHC.Data.Graph.UnVar
-
-import GHC.Utils.Error
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Outputable
-import GHC.Utils.Monad  ( mapAccumLM )
-import GHC.Utils.Logger
-
-import GHC.Types.Demand
-import GHC.Types.Var
-import GHC.Types.Var.Env
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.Id.Make ( realWorldPrimId )
-import GHC.Types.Basic
-import GHC.Types.Name   ( Name, NamedThing(..), nameSrcSpan, isInternalName )
-import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
-import GHC.Types.Literal
-import GHC.Types.Tickish
-import GHC.Types.TyThing
-import GHC.Types.Unique.Supply
-
-import Data.List        ( unfoldr )
-import Data.Functor.Identity
-import Control.Monad
-
-{-
-Note [CorePrep Overview]
-~~~~~~~~~~~~~~~~~~~~~~~~
-
-The goal of this pass is to prepare for code generation.
-
-1.  Saturate constructor and primop applications.
-
-2.  Convert to A-normal form; that is, function arguments
-    are always variables.
-
-    * Use case for strict arguments:
-        f E ==> case E of x -> f x
-        (where f is strict)
-
-    * Use let for non-trivial lazy arguments
-        f E ==> let x = E in f x
-        (were f is lazy and x is non-trivial)
-
-3.  Similarly, convert any unboxed lets into cases.
-    [I'm experimenting with leaving 'ok-for-speculation'
-     rhss in let-form right up to this point.]
-
-4.  Ensure that *value* lambdas only occur as the RHS of a binding
-    (The code generator can't deal with anything else.)
-    Type lambdas are ok, however, because the code gen discards them.
-
-5.  [Not any more; nuked Jun 2002] Do the seq/par munging.
-
-6.  Clone all local Ids.
-    This means that all such Ids are unique, rather than the
-    weaker guarantee of no clashes which the simplifier provides.
-    And that is what the code generator needs.
-
-    We don't clone TyVars or CoVars. The code gen doesn't need that,
-    and doing so would be tiresome because then we'd need
-    to substitute in types and coercions.
-
-    We need to clone ids for two reasons:
-    + Things associated with labels in the final code must be truly unique in
-      order to avoid labels being shadowed in the final output.
-    + Even binders without info tables like function arguments or alternative
-      bound binders must be unique at least in their type/unique combination.
-      We only emit a single declaration for each binder when compiling to C
-      so if binders are not unique we would either get duplicate declarations
-      or misstyped variables. The later happend in #22402.
-    + We heavily use unique-keyed maps in the backend which can go wrong when
-      ids with the same unique are meant to represent the same variable.
-
-7.  Give each dynamic CCall occurrence a fresh unique; this is
-    rather like the cloning step above.
-
-8.  Inject bindings for the "implicit" Ids:
-        * Constructor wrappers
-        * Constructor workers
-    We want curried definitions for all of these in case they
-    aren't inlined by some caller.
-
- 9. Convert bignum literals into their core representation.
-
-10. Uphold tick consistency while doing this: We move ticks out of
-    (non-type) applications where we can, and make sure that we
-    annotate according to scoping rules when floating.
-
-11. Collect cost centres (including cost centres in unfoldings) if we're in
-    profiling mode. We have to do this here because we won't have unfoldings
-    after this pass (see `trimUnfolding` and Note [Drop unfoldings and rules].
-
-12. Eliminate case clutter in favour of unsafe coercions.
-    See Note [Unsafe coercions]
-
-13. Eliminate some magic Ids, specifically
-     runRW# (\s. e)  ==>  e[readWorldId/s]
-             lazy e  ==>  e (see Note [lazyId magic] in GHC.Types.Id.Make)
-         noinline e  ==>  e
-           nospec e  ==>  e
-     ToDo:  keepAlive# ...
-    This is done in cpeApp
-
-This is all done modulo type applications and abstractions, so that
-when type erasure is done for conversion to STG, we don't end up with
-any trivial or useless bindings.
-
-Note [Unsafe coercions]
-~~~~~~~~~~~~~~~~~~~~~~~
-CorePrep does these two transformations:
-
-1. Convert empty case to cast with an unsafe coercion
-          (case e of {}) ===>  e |> unsafe-co
-   See Note [Empty case alternatives] in GHC.Core: if the case
-   alternatives are empty, the scrutinee must diverge or raise an
-   exception, so we can just dive into it.
-
-   Of course, if the scrutinee *does* return, we may get a seg-fault.
-   A belt-and-braces approach would be to persist empty-alternative
-   cases to code generator, and put a return point anyway that calls a
-   runtime system error function.
-
-   Notice that eliminating empty case can lead to an ill-kinded coercion
-       case error @Int "foo" of {}  :: Int#
-       ===> error @Int "foo" |> unsafe-co
-       where unsafe-co :: Int ~ Int#
-   But that's fine because the expression diverges anyway. And it's
-   no different to what happened before.
-
-2. Eliminate unsafeEqualityProof in favour of an unsafe coercion
-           case unsafeEqualityProof of UnsafeRefl g -> e
-           ===>  e[unsafe-co/g]
-   See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
-
-   Note that this requires us to substitute 'unsafe-co' for 'g', and
-   that is the main (current) reason for cpe_tyco_env in CorePrepEnv.
-   Tiresome, but not difficult.
-
-These transformations get rid of "case clutter", leaving only casts.
-We are doing no further significant transformations, so the reasons
-for the case forms have disappeared. And it is extremely helpful for
-the ANF-ery, CoreToStg, and backends, if trivial expressions really do
-look trivial. #19700 was an example.
-
-In both cases, the "unsafe-co" is just (UnivCo ty1 ty2 (CorePrepProv b)),
-The boolean 'b' says whether the unsafe coercion is supposed to be
-kind-homogeneous (yes for (2), no for (1).  This information is used
-/only/ by Lint.
-
-Note [CorePrep invariants]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here is the syntax of the Core produced by CorePrep:
-
-    Trivial expressions
-       arg ::= lit |  var
-              | arg ty  |  /\a. arg
-              | truv co  |  /\c. arg  |  arg |> co
-
-    Applications
-       app ::= lit  |  var  |  app arg  |  app ty  | app co | app |> co
-
-    Expressions
-       body ::= app
-              | let(rec) x = rhs in body     -- Boxed only
-              | case body of pat -> body
-              | /\a. body | /\c. body
-              | body |> co
-
-    Right hand sides (only place where value lambdas can occur)
-       rhs ::= /\a.rhs  |  \x.rhs  |  body
-
-We define a synonym for each of these non-terminals.  Functions
-with the corresponding name produce a result in that syntax.
--}
-
-type CpeArg  = CoreExpr    -- Non-terminal 'arg'
-type CpeApp  = CoreExpr    -- Non-terminal 'app'
-type CpeBody = CoreExpr    -- Non-terminal 'body'
-type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'
-
-{-
-************************************************************************
-*                                                                      *
-                Top level stuff
-*                                                                      *
-************************************************************************
--}
-
-data CorePrepPgmConfig = CorePrepPgmConfig
-  { cpPgm_endPassConfig     :: !EndPassConfig
-  , cpPgm_generateDebugInfo :: !Bool
-  }
-
-corePrepPgm :: Logger
-            -> CorePrepConfig
-            -> CorePrepPgmConfig
-            -> Module -> ModLocation -> CoreProgram -> [TyCon]
-            -> IO CoreProgram
-corePrepPgm logger cp_cfg pgm_cfg
-            this_mod mod_loc binds data_tycons =
-    withTiming logger
-               (text "CorePrep"<+>brackets (ppr this_mod))
-               (\a -> a `seqList` ()) $ do
-    us <- mkSplitUniqSupply 's'
-    let initialCorePrepEnv = mkInitialCorePrepEnv cp_cfg
-
-    let
-        implicit_binds = mkDataConWorkers
-          (cpPgm_generateDebugInfo pgm_cfg)
-          mod_loc data_tycons
-            -- NB: we must feed mkImplicitBinds through corePrep too
-            -- so that they are suitably cloned and eta-expanded
-
-        binds_out = initUs_ us $ do
-                      floats1 <- corePrepTopBinds initialCorePrepEnv binds
-                      floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
-                      return (deFloatTop (floats1 `appendFloats` floats2))
-
-    endPassIO logger (cpPgm_endPassConfig pgm_cfg)
-              binds_out []
-    return binds_out
-
-corePrepExpr :: Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr
-corePrepExpr logger config expr = do
-    withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do
-      us <- mkSplitUniqSupply 's'
-      let initialCorePrepEnv = mkInitialCorePrepEnv config
-      let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)
-      putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)
-      return new_expr
-
-corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats
--- Note [Floating out of top level bindings]
-corePrepTopBinds initialCorePrepEnv binds
-  = go initialCorePrepEnv binds
-  where
-    go _   []             = return emptyFloats
-    go env (bind : binds) = do (env', floats, maybe_new_bind)
-                                 <- cpeBind TopLevel env bind
-                               massert (isNothing maybe_new_bind)
-                                 -- Only join points get returned this way by
-                                 -- cpeBind, and no join point may float to top
-                               floatss <- go env' binds
-                               return (floats `appendFloats` floatss)
-
-mkDataConWorkers :: Bool -> ModLocation -> [TyCon] -> [CoreBind]
--- See Note [Data constructor workers]
--- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy
-mkDataConWorkers generate_debug_info mod_loc data_tycons
-  = [ NonRec id (tick_it (getName data_con) (Var id))
-                                -- The ice is thin here, but it works
-    | tycon <- data_tycons,     -- CorePrep will eta-expand it
-      data_con <- tyConDataCons tycon,
-      let id = dataConWorkId data_con
-    ]
- where
-   -- If we want to generate debug info, we put a source note on the
-   -- worker. This is useful, especially for heap profiling.
-   tick_it name
-     | not generate_debug_info               = id
-     | RealSrcSpan span _ <- nameSrcSpan name = tick span
-     | Just file <- ml_hs_file mod_loc       = tick (span1 file)
-     | otherwise                             = tick (span1 "???")
-     where tick span  = Tick $ SourceNote span $
-             renderWithContext defaultSDocContext $ ppr name
-           span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1
-
-{-
-Note [Floating out of top level bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-NB: we do need to float out of top-level bindings
-Consider        x = length [True,False]
-We want to get
-                s1 = False : []
-                s2 = True  : s1
-                x  = length s2
-
-We return a *list* of bindings, because we may start with
-        x* = f (g y)
-where x is demanded, in which case we want to finish with
-        a = g y
-        x* = f a
-And then x will actually end up case-bound
-
-Note [Join points and floating]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Join points can float out of other join points but not out of value bindings:
-
-  let z =
-    let  w = ... in -- can float
-    join k = ... in -- can't float
-    ... jump k ...
-  join j x1 ... xn =
-    let  y = ... in -- can float (but don't want to)
-    join h = ... in -- can float (but not much point)
-    ... jump h ...
-  in ...
-
-Here, the jump to h remains valid if h is floated outward, but the jump to k
-does not.
-
-We don't float *out* of join points. It would only be safe to float out of
-nullary join points (or ones where the arguments are all either type arguments
-or dead binders). Nullary join points aren't ever recursive, so they're always
-effectively one-shot functions, which we don't float out of. We *could* float
-join points from nullary join points, but there's no clear benefit at this
-stage.
-
-Note [Data constructor workers]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Create any necessary "implicit" bindings for data con workers.  We
-create the rather strange (non-recursive!) binding
-
-        $wC = \x y -> $wC x y
-
-i.e. a curried constructor that allocates.  This means that we can
-treat the worker for a constructor like any other function in the rest
-of the compiler.  The point here is that CoreToStg will generate a
-StgConApp for the RHS, rather than a call to the worker (which would
-give a loop).  As Lennart says: the ice is thin here, but it works.
-
-Hmm.  Should we create bindings for dictionary constructors?  They are
-always fully applied, and the bindings are just there to support
-partial applications. But it's easier to let them through.
-
-
-Note [Dead code in CorePrep]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Imagine that we got an input program like this (see #4962):
-
-  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
-  f x = (g True (Just x) + g () (Just x), g)
-    where
-      g :: Show a => a -> Maybe Int -> Int
-      g _ Nothing = x
-      g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown
-
-After specialisation and SpecConstr, we would get something like this:
-
-  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
-  f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)
-    where
-      {-# RULES g $dBool = g$Bool
-                g $dUnit = g$Unit #-}
-      g = ...
-      {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}
-      g$Bool = ...
-      {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}
-      g$Unit = ...
-      g$Bool_True_Just = ...
-      g$Unit_Unit_Just = ...
-
-Note that the g$Bool and g$Unit functions are actually dead code: they
-are only kept alive by the occurrence analyser because they are
-referred to by the rules of g, which is being kept alive by the fact
-that it is used (unspecialised) in the returned pair.
-
-However, at the CorePrep stage there is no way that the rules for g
-will ever fire, and it really seems like a shame to produce an output
-program that goes to the trouble of allocating a closure for the
-unreachable g$Bool and g$Unit functions.
-
-The way we fix this is to:
- * In cloneBndr, drop all unfoldings/rules
-
- * In deFloatTop, run a simple dead code analyser on each top-level
-   RHS to drop the dead local bindings.
-
-The reason we don't just OccAnal the whole output of CorePrep is that
-the tidier ensures that all top-level binders are GlobalIds, so they
-don't show up in the free variables any longer. So if you run the
-occurrence analyser on the output of CoreTidy (or later) you e.g. turn
-this program:
-
-  Rec {
-  f = ... f ...
-  }
-
-Into this one:
-
-  f = ... f ...
-
-(Since f is not considered to be free in its own RHS.)
-
-
-Note [keepAlive# magic]
-~~~~~~~~~~~~~~~~~~~~~~~
-When interacting with foreign code, it is often necessary for the user to
-extend the lifetime of a heap object beyond the lifetime that would be apparent
-from the on-heap references alone. For instance, a program like:
-
-  foreign import safe "hello" hello :: ByteArray# -> IO ()
-
-  callForeign :: IO ()
-  callForeign = IO $ \s0 ->
-    case newByteArray# n# s0 of (# s1, barr #) ->
-      unIO hello barr s1
-
-As-written this program is susceptible to memory-unsafety since there are
-no references to `barr` visible to the garbage collector. Consequently, if a
-garbage collection happens during the execution of the C function `hello`, it
-may be that the array is freed while in use by the foreign function.
-
-To address this, we introduced a new primop, keepAlive#, which "scopes over"
-the computation needing the kept-alive value:
-
-  keepAlive# :: forall (ra :: RuntimeRep) (rb :: RuntimeRep) (a :: TYPE a) (b :: TYPE b).
-                a -> State# RealWorld -> (State# RealWorld -> b) -> b
-
-When entered, an application (keepAlive# x s k) will apply `k` to the state
-token, evaluating it to WHNF. However, during the course of this evaluation
-will *guarantee* that `x` is considered to be alive.
-
-There are a few things to note here:
-
- - we are RuntimeRep-polymorphic in the value to be kept-alive. This is
-   necessary since we will often (but not always) be keeping alive something
-   unlifted (like a ByteArray#)
-
- - we are RuntimeRep-polymorphic in the result value since the result may take
-   many forms (e.g. a boxed value, a raw state token, or a (# State s, result #).
-
-We implement this operation by desugaring to touch# during CorePrep (see
-GHC.CoreToStg.Prep.cpeApp). Specifically,
-
-  keepAlive# x s0 k
-
-is transformed to:
-
-  case k s0 of r ->
-  case touch# x realWorld# of s1 ->
-    r
-
-Operationally, `keepAlive# x s k` is equivalent to pushing a stack frame with a
-pointer to `x` and entering `k s0`. This compilation strategy is safe
-because we do no optimization on STG that would drop or re-order the
-continuation containing the `touch#`. However, if we were to become more
-aggressive in our STG pipeline then we would need to revisit this.
-
-Beyond this CorePrep transformation, there is very little special about
-keepAlive#. However, we did explore (and eventually gave up on)
-an optimisation which would allow unboxing of constructed product results,
-which we describe below.
-
-
-Lost optimisation: CPR unboxing
---------------------------------
-One unfortunate property of this approach is that the simplifier is unable to
-unbox the result of a keepAlive# expression. For instance, consider the program:
-
-  case keepAlive# arr s0 (
-         \s1 -> case peekInt arr s1 of
-                  (# s2, r #) -> I# r
-  ) of
-    I# x -> ...
-
-This is a surprisingly common pattern, previously used, e.g., in
-GHC.IO.Buffer.readWord8Buf. While exploring ideas, we briefly played around
-with optimising this away by pushing strict contexts (like the
-`case [] of I# x -> ...` above) into keepAlive#'s continuation. While this can
-recover unboxing, it can also unfortunately in general change the asymptotic
-memory (namely stack) behavior of the program. For instance, consider
-
-  writeN =
-    ...
-      case keepAlive# x s0 (\s1 -> something s1) of
-        (# s2, x #) ->
-          writeN ...
-
-As it is tail-recursive, this program will run in constant space. However, if
-we push outer case into the continuation we get:
-
-  writeN =
-
-      case keepAlive# x s0 (\s1 ->
-        case something s1 of
-          (# s2, x #) ->
-            writeN ...
-      ) of
-        ...
-
-Which ends up building a stack which is linear in the recursion depth. For this
-reason, we ended up giving up on this optimisation.
-
-
-Historical note: touch# and its inadequacy
-------------------------------------------
-Prior to the introduction of `keepAlive#` we instead addressed the need for
-lifetime extension with the `touch#` primop:
-
-    touch# :: a -> State# s -> State# s
-
-This operation would ensure that the `a` value passed as the first argument was
-considered "alive" at the time the primop application is entered.
-
-For instance, the user might modify `callForeign` as:
-
-  callForeign :: IO ()
-  callForeign s0 = IO $ \s0 ->
-    case newByteArray# n# s0 of (# s1, barr #) ->
-    case unIO hello barr s1 of (# s2, () #) ->
-    case touch# barr s2 of s3 ->
-      (# s3, () #)
-
-However, in #14346 we discovered that this primop is insufficient in the
-presence of simplification. For instance, consider a program like:
-
-  callForeign :: IO ()
-  callForeign s0 = IO $ \s0 ->
-    case newByteArray# n# s0 of (# s1, barr #) ->
-    case unIO (forever $ hello barr) s1 of (# s2, () #) ->
-    case touch# barr s2 of s3 ->
-      (# s3, () #)
-
-In this case the Simplifier may realize that (forever $ hello barr)
-will never return and consequently that the `touch#` that follows is dead code.
-As such, it will be dropped, resulting in memory unsoundness.
-This unsoundness lead to the introduction of keepAlive#.
-
-
-
-Other related tickets:
-
- - #15544
- - #17760
- - #14375
- - #15260
- - #18061
-
-************************************************************************
-*                                                                      *
-                The main code
-*                                                                      *
-************************************************************************
--}
-
-cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
-        -> UniqSM (CorePrepEnv,
-                   Floats,         -- Floating value bindings
-                   Maybe CoreBind) -- Just bind' <=> returned new bind; no float
-                                   -- Nothing <=> added bind' to floats instead
-cpeBind top_lvl env (NonRec bndr rhs)
-  | not (isJoinId bndr)
-  = do { (env1, bndr1) <- cpCloneBndr env bndr
-       ; let dmd         = idDemandInfo bndr
-             is_unlifted = isUnliftedType (idType bndr)
-       ; (floats, rhs1) <- cpePair top_lvl NonRecursive
-                                   dmd is_unlifted
-                                   env bndr1 rhs
-       -- See Note [Inlining in CorePrep]
-       ; let triv_rhs = exprIsTrivial rhs1
-             env2    | triv_rhs  = extendCorePrepEnvExpr env1 bndr rhs1
-                     | otherwise = env1
-             floats1 | triv_rhs, isInternalName (idName bndr)
-                     = floats
-                     | otherwise
-                     = addFloat floats new_float
-
-             new_float = mkFloat env dmd is_unlifted bndr1 rhs1
-
-       ; return (env2, floats1, Nothing) }
-
-  | otherwise -- A join point; see Note [Join points and floating]
-  = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point
-    do { (_, bndr1) <- cpCloneBndr env bndr
-       ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
-       ; return (extendCorePrepEnv env bndr bndr2,
-                 emptyFloats,
-                 Just (NonRec bndr2 rhs1)) }
-
-cpeBind top_lvl env (Rec pairs)
-  | not (isJoinId (head bndrs))
-  = do { (env, bndrs1) <- cpCloneBndrs env bndrs
-       ; let env' = enterRecGroupRHSs env bndrs1
-       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')
-                           bndrs1 rhss
-
-       ; let (floats_s, rhss1) = unzip stuff
-             all_pairs = foldrOL add_float (bndrs1 `zip` rhss1)
-                                           (concatFloats floats_s)
-       -- use env below, so that we reset cpe_rec_ids
-       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),
-                 unitFloat (FloatLet (Rec all_pairs)),
-                 Nothing) }
-
-  | otherwise -- See Note [Join points and floating]
-  = do { (env, bndrs1) <- cpCloneBndrs env bndrs
-       ; let env' = enterRecGroupRHSs env bndrs1
-       ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss
-
-       ; let bndrs2 = map fst pairs1
-       -- use env below, so that we reset cpe_rec_ids
-       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),
-                 emptyFloats,
-                 Just (Rec pairs1)) }
-  where
-    (bndrs, rhss) = unzip pairs
-
-        -- Flatten all the floats, and the current
-        -- group into a single giant Rec
-    add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
-    add_float (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2
-    add_float b                       _    = pprPanic "cpeBind" (ppr b)
-
----------------
-cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
-        -> CorePrepEnv -> OutId -> CoreExpr
-        -> UniqSM (Floats, CpeRhs)
--- Used for all bindings
--- The binder is already cloned, hence an OutId
-cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
-  = assert (not (isJoinId bndr)) $ -- those should use cpeJoinPair
-    do { (floats1, rhs1) <- cpeRhsE env rhs
-
-       -- See if we are allowed to float this stuff out of the RHS
-       ; (floats2, rhs2) <- float_from_rhs floats1 rhs1
-
-       -- Make the arity match up
-       ; (floats3, rhs3)
-            <- if manifestArity rhs1 <= arity
-               then return (floats2, cpeEtaExpand arity rhs2)
-               else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $
-                               -- Note [Silly extra arguments]
-                    (do { v <- newVar (idType bndr)
-                        ; let float = mkFloat env topDmd False v rhs2
-                        ; return ( addFloat floats2 float
-                                 , cpeEtaExpand arity (Var v)) })
-
-        -- Wrap floating ticks
-       ; let (floats4, rhs4) = wrapTicks floats3 rhs3
-
-       ; return (floats4, rhs4) }
-  where
-    arity = idArity bndr        -- We must match this arity
-
-    ---------------------
-    float_from_rhs floats rhs
-      | isEmptyFloats floats = return (emptyFloats, rhs)
-      | isTopLevel top_lvl   = float_top    floats rhs
-      | otherwise            = float_nested floats rhs
-
-    ---------------------
-    float_nested floats rhs
-      | wantFloatNested is_rec dmd is_unlifted floats rhs
-                  = return (floats, rhs)
-      | otherwise = dontFloat floats rhs
-
-    ---------------------
-    float_top floats rhs
-      | allLazyTop floats
-      = return (floats, rhs)
-
-      | Just floats <- canFloat floats rhs
-      = return floats
-
-      | otherwise
-      = dontFloat floats rhs
-
-dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)
--- Non-empty floats, but do not want to float from rhs
--- So wrap the rhs in the floats
--- But: rhs1 might have lambdas, and we can't
---      put them inside a wrapBinds
-dontFloat floats1 rhs
-  = do { (floats2, body) <- rhsToBody rhs
-        ; return (emptyFloats, wrapBinds floats1 $
-                               wrapBinds floats2 body) }
-
-{- Note [Silly extra arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we had this
-        f{arity=1} = \x\y. e
-We *must* match the arity on the Id, so we have to generate
-        f' = \x\y. e
-        f  = \x. f' x
-
-It's a bizarre case: why is the arity on the Id wrong?  Reason
-(in the days of __inline_me__):
-        f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
-When InlineMe notes go away this won't happen any more.  But
-it seems good for CorePrep to be robust.
--}
-
----------------
-cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr
-            -> UniqSM (JoinId, CpeRhs)
--- Used for all join bindings
--- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils
-cpeJoinPair env bndr rhs
-  = assert (isJoinId bndr) $
-    do { let Just join_arity = isJoinId_maybe bndr
-             (bndrs, body)   = collectNBinders join_arity rhs
-
-       ; (env', bndrs') <- cpCloneBndrs env bndrs
-
-       ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts
-                                      -- with a lambda
-
-       ; let rhs'  = mkCoreLams bndrs' body'
-             bndr' = bndr `setIdUnfolding` evaldUnfolding
-                          `setIdArity` count isId bndrs
-                            -- See Note [Arity and join points]
-
-       ; return (bndr', rhs') }
-
-{-
-Note [Arity and join points]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Up to now, we've allowed a join point to have an arity greater than its join
-arity (minus type arguments), since this is what's useful for eta expansion.
-However, for code gen purposes, its arity must be exactly the number of value
-arguments it will be called with, and it must have exactly that many value
-lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS:
-
-  join j x y z = \w -> ... in ...
-    =>
-  join j x y z = (let f = \w -> ... in f) in ...
-
-This is also what happens with Note [Silly extra arguments]. Note that it's okay
-for us to mess with the arity because a join point is never exported.
--}
-
--- ---------------------------------------------------------------------------
---              CpeRhs: produces a result satisfying CpeRhs
--- ---------------------------------------------------------------------------
-
-cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
--- If
---      e  ===>  (bs, e')
--- then
---      e = let bs in e'        (semantically, that is!)
---
--- For example
---      f (g x)   ===>   ([v = g x], f v)
-
-cpeRhsE env (Type ty)
-  = return (emptyFloats, Type (cpSubstTy env ty))
-cpeRhsE env (Coercion co)
-  = return (emptyFloats, Coercion (cpSubstCo env co))
-cpeRhsE env expr@(Lit (LitNumber nt i))
-   = case cp_convertNumLit (cpe_config env) nt i of
-      Nothing -> return (emptyFloats, expr)
-      Just e  -> cpeRhsE env e
-cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
-cpeRhsE env expr@(Var {})  = cpeApp env expr
-cpeRhsE env expr@(App {})  = cpeApp env expr
-
-cpeRhsE env (Let bind body)
-  = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind
-       ; (body_floats, body') <- cpeRhsE env' body
-       ; let expr' = case maybe_bind' of Just bind' -> Let bind' body'
-                                         Nothing    -> body'
-       ; return (bind_floats `appendFloats` body_floats, expr') }
-
-cpeRhsE env (Tick tickish expr)
-  -- Pull out ticks if they are allowed to be floated.
-  | tickishFloatable tickish
-  = do { (floats, body) <- cpeRhsE env expr
-         -- See [Floating Ticks in CorePrep]
-       ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }
-  | otherwise
-  = do { body <- cpeBodyNF env expr
-       ; return (emptyFloats, mkTick tickish' body) }
-  where
-    tickish' | Breakpoint ext n fvs <- tickish
-             -- See also 'substTickish'
-             = Breakpoint ext n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)
-             | otherwise
-             = tickish
-
-cpeRhsE env (Cast expr co)
-   = do { (floats, expr') <- cpeRhsE env expr
-        ; return (floats, Cast expr' (cpSubstCo env co)) }
-
-cpeRhsE env expr@(Lam {})
-   = do { let (bndrs,body) = collectBinders expr
-        ; (env', bndrs') <- cpCloneBndrs env bndrs
-        ; body' <- cpeBodyNF env' body
-        ; return (emptyFloats, mkLams bndrs' body') }
-
--- Eliminate empty case
--- See Note [Unsafe coercions]
-cpeRhsE env (Case scrut _ ty [])
-  = do { (floats, scrut') <- cpeRhsE env scrut
-       ; let ty'       = cpSubstTy env ty
-             scrut_ty' = exprType scrut'
-             co'       = mkUnivCo prov Representational scrut_ty' ty'
-             prov      = CorePrepProv False
-               -- False says that the kinds of two types may differ
-               -- E.g. we might cast Int to Int#.  This is fine
-               -- because the scrutinee is guaranteed to diverge
-
-       ; return (floats, Cast scrut' co') }
-   -- This can give rise to
-   --   Warning: Unsafe coercion: between unboxed and boxed value
-   -- but it's fine because 'scrut' diverges
-
--- Eliminate unsafeEqualityProof
--- See Note [Unsafe coercions]
-cpeRhsE env (Case scrut bndr _ alts)
-  | isUnsafeEqualityProof scrut
-  , isDeadBinder bndr -- We can only discard the case if the case-binder
-                      -- is dead.  It usually is, but see #18227
-  , [Alt _ [co_var] rhs] <- alts
-  , let Pair ty1 ty2 = coVarTypes co_var
-        the_co = mkUnivCo prov Nominal (cpSubstTy env ty1) (cpSubstTy env ty2)
-        prov   = CorePrepProv True  -- True <=> kind homogeneous
-        env'   = extendCoVarEnv env co_var the_co
-  = cpeRhsE env' rhs
-
-cpeRhsE env (Case scrut bndr ty alts)
-  = do { (floats, scrut') <- cpeBody env scrut
-       ; (env', bndr2) <- cpCloneBndr env bndr
-       ; let alts'
-               | cp_catchNonexhaustiveCases $ cpe_config env
-               , not (altsAreExhaustive alts)
-               = addDefault alts (Just err)
-               | otherwise = alts
-               where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty
-                                             "Bottoming expression returned"
-       ; alts'' <- mapM (sat_alt env') alts'
-
-       ; return (floats, Case scrut' bndr2 ty alts'') }
-  where
-    sat_alt env (Alt con bs rhs)
-       = do { (env2, bs') <- cpCloneBndrs env bs
-            ; rhs' <- cpeBodyNF env2 rhs
-            ; return (Alt con bs' rhs') }
-
--- ---------------------------------------------------------------------------
---              CpeBody: produces a result satisfying CpeBody
--- ---------------------------------------------------------------------------
-
--- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without
--- producing any floats (any generated floats are immediately
--- let-bound using 'wrapBinds').  Generally you want this, esp.
--- when you've reached a binding form (e.g., a lambda) and
--- floating any further would be incorrect.
-cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
-cpeBodyNF env expr
-  = do { (floats, body) <- cpeBody env expr
-       ; return (wrapBinds floats body) }
-
--- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce
--- a list of 'Floats' which are being propagated upwards.  In
--- fact, this function is used in only two cases: to
--- implement 'cpeBodyNF' (which is what you usually want),
--- and in the case when a let-binding is in a case scrutinee--here,
--- we can always float out:
---
---      case (let x = y in z) of ...
---      ==> let x = y in case z of ...
---
-cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
-cpeBody env expr
-  = do { (floats1, rhs) <- cpeRhsE env expr
-       ; (floats2, body) <- rhsToBody rhs
-       ; return (floats1 `appendFloats` floats2, body) }
-
---------
-rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
--- Remove top level lambdas by let-binding
-
-rhsToBody (Tick t expr)
-  | tickishScoped t == NoScope  -- only float out of non-scoped annotations
-  = do { (floats, expr') <- rhsToBody expr
-       ; return (floats, mkTick t expr') }
-
-rhsToBody (Cast e co)
-        -- You can get things like
-        --      case e of { p -> coerce t (\s -> ...) }
-  = do { (floats, e') <- rhsToBody e
-       ; return (floats, Cast e' co) }
-
-rhsToBody expr@(Lam {})   -- See Note [No eta reduction needed in rhsToBody]
-  | all isTyVar bndrs           -- Type lambdas are ok
-  = return (emptyFloats, expr)
-  | otherwise                   -- Some value lambdas
-  = do { let rhs = cpeEtaExpand (exprArity expr) expr
-       ; fn <- newVar (exprType rhs)
-       ; let float = FloatLet (NonRec fn rhs)
-       ; return (unitFloat float, Var fn) }
-  where
-    (bndrs,_) = collectBinders expr
-
-rhsToBody expr = return (emptyFloats, expr)
-
-
-{- Note [No eta reduction needed in rhsToBody]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Historical note.  In the olden days we used to have a Prep-specific
-eta-reduction step in rhsToBody:
-  rhsToBody expr@(Lam {})
-    | Just no_lam_result <- tryEtaReducePrep bndrs body
-    = return (emptyFloats, no_lam_result)
-
-The goal was to reduce
-        case x of { p -> \xs. map f xs }
-    ==> case x of { p -> map f }
-
-to avoid allocating a lambda.  Of course, we'd allocate a PAP
-instead, which is hardly better, but that's the way it was.
-
-Now we simply don't bother with this. It doesn't seem to be a win,
-and it's extra work.
--}
-
--- ---------------------------------------------------------------------------
---              CpeApp: produces a result satisfying CpeApp
--- ---------------------------------------------------------------------------
-
-data ArgInfo = CpeApp  CoreArg
-             | CpeCast Coercion
-             | CpeTick CoreTickish
-
-instance Outputable ArgInfo where
-  ppr (CpeApp arg) = text "app" <+> ppr arg
-  ppr (CpeCast co) = text "cast" <+> ppr co
-  ppr (CpeTick tick) = text "tick" <+> ppr tick
-
-{- Note [Ticks and mandatory eta expansion]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Something like
-    `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool`
-caused a compiler panic in #20938. Why did this happen?
-The simplifier will eta-reduce the rhs giving us a partial
-application of tagToEnum#. The tick is then pushed inside the
-type argument. That is we get
-    `(Tick<foo> tagToEnum#) @Bool`
-CorePrep would go on to see a undersaturated tagToEnum# application
-and eta expand the expression under the tick. Giving us:
-    (Tick<scc> (\forall a. x -> tagToEnum# @a x) @Bool
-Suddenly tagToEnum# is applied to a polymorphic type and the code generator
-panics as it needs a concrete type to determine the representation.
-
-The problem in my eyes was that the tick covers a partial application
-of a primop. There is no clear semantic for such a construct as we can't
-partially apply a primop since they do not have bindings.
-We fix this by expanding the scope of such ticks slightly to cover the body
-of the eta-expanded expression.
-
-We do this by:
-* Checking if an application is headed by a primOpish thing.
-* If so we collect floatable ticks and usually but also profiling ticks
-  along with regular arguments.
-* When rebuilding the application we check if any profiling ticks appear
-  before the primop is fully saturated.
-* If the primop isn't fully satured we eta expand the primop application
-  and scope the tick to scope over the body of the saturated expression.
-
-Going back to #20938 this means starting with
-    `(Tick<foo> tagToEnum#) @Bool`
-we check if the function head is a primop (yes). This means we collect the
-profiling tick like if it was floatable. Giving us
-    (tagToEnum#, [CpeTick foo, CpeApp @Bool]).
-cpe_app filters out the tick as a underscoped tick on the expression
-`tagToEnum# @Bool`. During eta expansion we then put that tick back onto the
-body of the eta-expansion lambdas. Giving us `\x -> Tick<foo> (tagToEnum# @Bool x)`.
--}
-cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
--- May return a CpeRhs because of saturating primops
-cpeApp top_env expr
-  = do { let (terminal, args) = collect_args expr
-      --  ; pprTraceM "cpeApp" $ (ppr expr)
-       ; cpe_app top_env terminal args
-       }
-
-  where
-    -- We have a nested data structure of the form
-    -- e `App` a1 `App` a2 ... `App` an, convert it into
-    -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth)
-    -- We use 'ArgInfo' because we may also need to
-    -- record casts and ticks.  Depth counts the number
-    -- of arguments that would consume strictness information
-    -- (so, no type or coercion arguments.)
-    collect_args :: CoreExpr -> (CoreExpr, [ArgInfo])
-    collect_args e = go e []
-      where
-        go (App fun arg)      as
-            = go fun (CpeApp arg : as)
-        go (Cast fun co)      as
-            = go fun (CpeCast co : as)
-        go (Tick tickish fun) as
-            -- Profiling ticks are slightly less strict so we expand their scope
-            -- if they cover partial applications of things like primOps.
-            -- See Note [Ticks and mandatory eta expansion]
-            -- Here we look inside `fun` before we make the final decision about
-            -- floating the tick which isn't optimal for perf. But this only makes
-            -- a difference if we have a non-floatable tick which is somewhat rare.
-            | Var vh <- head
-            , Var head' <- lookupCorePrepEnv top_env vh
-            , etaExpansionTick head' tickish
-            = (head,as')
-            where
-              (head,as') = go fun (CpeTick tickish : as)
-
-        -- Terminal could still be an app if it's wrapped by a tick.
-        -- E.g. Tick<foo> (f x) can give us (f x) as terminal.
-        go terminal as = (terminal, as)
-
-    cpe_app :: CorePrepEnv
-            -> CoreExpr -- The thing we are calling
-            -> [ArgInfo]
-            -> UniqSM (Floats, CpeRhs)
-    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args)
-        | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and
-            -- See Note [lazyId magic] in GHC.Types.Id.Make
-       || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey
-            -- Replace (noinline a) with a
-            -- See Note [noinlineId magic] in GHC.Types.Id.Make
-       || f `hasKey` nospecIdKey        -- Replace (nospec a) with a
-            -- See Note [nospecId magic] in GHC.Types.Id.Make
-
-        -- Consider the code:
-        --
-        --      lazy (f x) y
-        --
-        -- We need to make sure that we need to recursively collect arguments on
-        -- "f x", otherwise we'll float "f x" out (it's not a variable) and
-        -- end up with this awful -ddump-prep:
-        --
-        --      case f x of f_x {
-        --        __DEFAULT -> f_x y
-        --      }
-        --
-        -- rather than the far superior "f x y".  Test case is par01.
-        = let (terminal, args') = collect_args arg
-          in cpe_app env terminal (args' ++ args)
-
-    -- runRW# magic
-    cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest)
-        | f `hasKey` runRWKey
-        -- N.B. While it may appear that n == 1 in the case of runRW#
-        -- applications, keep in mind that we may have applications that return
-        , has_value_arg (CpeApp arg : rest)
-        -- See Note [runRW magic]
-        -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this
-        -- is why we return a CorePrepEnv as well)
-        = case arg of
-            Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest
-            _          -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest)
-             -- TODO: What about casts?
-        where
-          has_value_arg [] = False
-          has_value_arg (CpeApp arg:_rest)
-            | not (isTyCoArg arg) = True
-          has_value_arg (_:rest) = has_value_arg rest
-
-    cpe_app env (Var v) args
-      = do { v1 <- fiddleCCall v
-           ; let e2 = lookupCorePrepEnv env v1
-                 hd = getIdFromTrivialExpr_maybe e2
-                 -- Determine number of required arguments. See Note [Ticks and mandatory eta expansion]
-                 min_arity = case hd of
-                   Just v_hd -> if hasNoBinding v_hd then Just $! (idArity v_hd) else Nothing
-                   Nothing -> Nothing
-          --  ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v))
-           ; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity
-           ; mb_saturate hd app floats unsat_ticks depth }
-        where
-          depth = val_args args
-          stricts = case idDmdSig v of
-                            DmdSig (DmdType _ demands _)
-                              | listLengthCmp demands depth /= GT -> demands
-                                    -- length demands <= depth
-                              | otherwise                         -> []
-                -- If depth < length demands, then we have too few args to
-                -- satisfy strictness  info so we have to  ignore all the
-                -- strictness info, e.g. + (error "urk")
-                -- Here, we can't evaluate the arg strictly, because this
-                -- partial application might be seq'd
-
-        -- We inlined into something that's not a var and has no args.
-        -- Bounce it back up to cpeRhsE.
-    cpe_app env fun [] = cpeRhsE env fun
-
-    -- Here we get:
-    -- N-variable fun, better let-bind it
-    -- This case covers literals, apps, lams or let expressions applied to arguments.
-    -- Basically things we want to ANF before applying to arguments.
-    cpe_app env fun args
-      = do { (fun_floats, fun') <- cpeArg env evalDmd fun
-                          -- If evalDmd says that it's sure to be evaluated,
-                          -- we'll end up case-binding it
-           ; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing
-           ; mb_saturate Nothing app floats unsat_ticks (val_args args) }
-
-    -- Count the number of value arguments *and* coercions (since we don't eliminate the later in STG)
-    val_args :: [ArgInfo] -> Int
-    val_args args = go args 0
-      where
-        go [] !n = n
-        go (info:infos) n =
-          case info of
-            CpeCast {} -> go infos n
-            CpeTick tickish
-              | tickishFloatable tickish                 -> go infos n
-              -- If we can't guarantee a tick will be floated out of the application
-              -- we can't guarantee the value args following it will be applied.
-              | otherwise                             -> n
-            CpeApp e                                  -> go infos n'
-              where
-                !n'
-                  | isTypeArg e = n
-                  | otherwise   = n+1
-
-    -- Saturate if necessary
-    mb_saturate head app floats unsat_ticks depth =
-       case head of
-         Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth unsat_ticks
-                          ; return (floats, sat_app) }
-         _other     -> do { massert (null unsat_ticks)
-                          ; return (floats, app) }
-
-    -- Deconstruct and rebuild the application, floating any non-atomic
-    -- arguments to the outside.  We collect the type of the expression,
-    -- the head of the application, and the number of actual value arguments,
-    -- all of which are used to possibly saturate this application if it
-    -- has a constructor or primop at the head.
-    rebuild_app
-        :: CorePrepEnv
-        -> [ArgInfo]                  -- The arguments (inner to outer)
-        -> CpeApp                     -- The function
-        -> Floats
-        -> [Demand]
-        -> Maybe Arity
-        -> UniqSM (CpeApp
-                  ,Floats
-                  ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion]
-                  )
-    rebuild_app env args app floats ss req_depth =
-      rebuild_app' env args app floats ss [] (fromMaybe 0 req_depth)
-
-    rebuild_app'
-        :: CorePrepEnv
-        -> [ArgInfo] -- The arguments (inner to outer)
-        -> CpeApp
-        -> Floats
-        -> [Demand]
-        -> [CoreTickish]
-        -> Int -- Number of arguments required to satisfy minimal tick scopes.
-        -> UniqSM (CpeApp, Floats, [CoreTickish])
-    rebuild_app' _ [] app floats ss rt_ticks !_req_depth
-      = assertPpr (null ss) (ppr ss)-- make sure we used all the strictness info
-        return (app, floats, rt_ticks)
-
-    rebuild_app' env (a : as) fun' floats ss rt_ticks req_depth = case a of
-      -- See Note [Ticks and mandatory eta expansion]
-      _
-        | not (null rt_ticks)
-        , req_depth <= 0
-        ->
-            let tick_fun = foldr mkTick fun' rt_ticks
-            in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth
-
-      CpeApp (Type arg_ty)
-        -> rebuild_app' env as (App fun' (Type arg_ty')) floats ss rt_ticks req_depth
-        where
-          arg_ty' = cpSubstTy env arg_ty
-
-      CpeApp (Coercion co)
-        -> rebuild_app' env as (App fun' (Coercion co')) floats (drop 1 ss) rt_ticks req_depth
-        where
-            co' = cpSubstCo env co
-
-      CpeApp arg -> do
-        let (ss1, ss_rest)  -- See Note [lazyId magic] in GHC.Types.Id.Make
-               = case (ss, isLazyExpr arg) of
-                   (_   : ss_rest, True)  -> (topDmd, ss_rest)
-                   (ss1 : ss_rest, False) -> (ss1,    ss_rest)
-                   ([],            _)     -> (topDmd, [])
-        (fs, arg') <- cpeArg top_env ss1 arg
-        rebuild_app' env as (App fun' arg') (fs `appendFloats` floats) ss_rest rt_ticks (req_depth-1)
-
-      CpeCast co
-        -> rebuild_app' env as (Cast fun' co') floats ss rt_ticks req_depth
-        where
-           co' = cpSubstCo env co
-      -- See Note [Ticks and mandatory eta expansion]
-      CpeTick tickish
-        | tickishPlace tickish == PlaceRuntime
-        , req_depth > 0
-        -> assert (isProfTick tickish) $
-           rebuild_app' env as fun' floats ss (tickish:rt_ticks) req_depth
-        | otherwise
-        -- See [Floating Ticks in CorePrep]
-        -> rebuild_app' env as fun' (addFloat floats (FloatTick tickish)) ss rt_ticks req_depth
-
-isLazyExpr :: CoreExpr -> Bool
--- See Note [lazyId magic] in GHC.Types.Id.Make
-isLazyExpr (Cast e _)              = isLazyExpr e
-isLazyExpr (Tick _ e)              = isLazyExpr e
-isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey
-isLazyExpr _                       = False
-
-{- Note [runRW magic]
-~~~~~~~~~~~~~~~~~~~~~
-Some definitions, for instance @runST@, must have careful control over float out
-of the bindings in their body. Consider this use of @runST@,
-
-    f x = runST ( \ s -> let (a, s')  = newArray# 100 [] s
-                             (_, s'') = fill_in_array_or_something a x s'
-                         in freezeArray# a s'' )
-
-If we inline @runST@, we'll get:
-
-    f x = let (a, s')  = newArray# 100 [] realWorld#{-NB-}
-              (_, s'') = fill_in_array_or_something a x s'
-          in freezeArray# a s''
-
-And now if we allow the @newArray#@ binding to float out to become a CAF,
-we end up with a result that is totally and utterly wrong:
-
-    f = let (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
-        in \ x ->
-            let (_, s'') = fill_in_array_or_something a x s'
-            in freezeArray# a s''
-
-All calls to @f@ will share a {\em single} array! Clearly this is nonsense and
-must be prevented.
-
-This is what @runRW#@ gives us: by being inlined extremely late in the
-optimization (right before lowering to STG, in CorePrep), we can ensure that
-no further floating will occur. This allows us to safely inline things like
-@runST@, which are otherwise needlessly expensive (see #10678 and #5916).
-
-'runRW' has a variety of quirks:
-
- * 'runRW' is known-key with a NOINLINE definition in
-   GHC.Magic. This definition is used in cases where runRW is curried.
-
- * In addition to its normal Haskell definition in GHC.Magic, we give it
-   a special late inlining here in CorePrep and GHC.StgToByteCode, avoiding
-   the incorrect sharing due to float-out noted above.
-
- * It is levity-polymorphic:
-
-    runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)
-           => (State# RealWorld -> (# State# RealWorld, o #))
-           -> (# State# RealWorld, o #)
-
- * It has some special simplification logic to allow unboxing of results when
-   runRW# appears in a strict context. See Note [Simplification of runRW#]
-   below.
-
- * Since its body is inlined, we allow runRW#'s argument to contain jumps to
-   join points. That is, the following is allowed:
-
-    join j x = ...
-    in runRW# @_ @_ (\s -> ... jump j 42 ...)
-
-   The Core Linter knows about this. See Note [Linting of runRW#] in
-   GHC.Core.Lint for details.
-
-   The occurrence analyser and SetLevels also know about this, as described in
-   Note [Simplification of runRW#].
-
-Other relevant Notes:
-
- * Note [Simplification of runRW#] below, describing a transformation of runRW
-   applications in strict contexts performed by the simplifier.
- * Note [Linting of runRW#] in GHC.Core.Lint
- * Note [runRW arg] below, describing a non-obvious case where the
-   late-inlining could go wrong.
-
-
- Note [runRW arg]
-~~~~~~~~~~~~~~~~~~~
-Consider the Core program (from #11291),
-
-   runRW# (case bot of {})
-
-The late inlining logic in cpe_app would transform this into:
-
-   (case bot of {}) realWorld#
-
-Which would rise to a panic in CoreToStg.myCollectArgs, which expects only
-variables in function position.
-
-However, as runRW#'s strictness signature captures the fact that it will call
-its argument this can't happen: the simplifier will transform the bottoming
-application into simply (case bot of {}).
-
-Note that this reasoning does *not* apply to non-bottoming continuations like:
-
-    hello :: Bool -> Int
-    hello n =
-      runRW# (
-          case n of
-            True -> \s -> 23
-            _    -> \s -> 10)
-
-Why? The difference is that (case bot of {}) is considered by okCpeArg to be
-trivial, consequently cpeArg (which the catch-all case of cpe_app calls on both
-the function and the arguments) will forgo binding it to a variable. By
-contrast, in the non-bottoming case of `hello` above  the function will be
-deemed non-trivial and consequently will be case-bound.
-
-
-Note [Simplification of runRW#]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider the program,
-
-    case runRW# (\s -> I# 42#) of
-      I# n# -> f n#
-
-There is no reason why we should allocate an I# constructor given that we
-immediately destructure it.
-
-To avoid this the simplifier has a special transformation rule, specific to
-runRW#, that pushes a strict context into runRW#'s continuation.  See the
-`runRW#` guard in `GHC.Core.Opt.Simplify.rebuildCall`.  That is, it transforms
-
-    K[ runRW# @r @ty cont ]
-              ~>
-    runRW# @r @ty (\s -> K[cont s])
-
-This has a few interesting implications. Consider, for instance, this program:
-
-    join j = ...
-    in case runRW# @r @ty cont of
-         result -> jump j result
-
-Performing the transform described above would result in:
-
-    join j x = ...
-    in runRW# @r @ty (\s ->
-         case cont of in
-           result -> jump j result
-       )
-
-If runRW# were a "normal" function this call to join point j would not be
-allowed in its continuation argument. However, since runRW# is inlined (as
-described in Note [runRW magic] above), such join point occurrences are
-completely fine. Both occurrence analysis (see the runRW guard in occAnalApp)
-and Core Lint (see the App case of lintCoreExpr) have special treatment for
-runRW# applications. See Note [Linting of runRW#] for details on the latter.
-
-Moreover, it's helpful to ensure that runRW's continuation isn't floated out
-For instance, if we have
-
-    runRW# (\s -> do_something)
-
-where do_something contains only top-level free variables, we may be tempted to
-float the argument to the top-level. However, we must resist this urge as since
-doing so would then require that runRW# produce an allocation and call, e.g.:
-
-    let lvl = \s -> do_somethign
-    in
-    ....(runRW# lvl)....
-
-whereas without floating the inlining of the definition of runRW would result
-in straight-line code. Consequently, GHC.Core.Opt.SetLevels.lvlApp has special
-treatment for runRW# applications, ensure the arguments are not floated as
-MFEs.
-
-Now that we float evaluation context into runRW#, we also have to give runRW# a
-special higher-order CPR transformer lest we risk #19822. E.g.,
-
-  case runRW# (\s -> doThings) of x -> Data.Text.Text x something something'
-      ~>
-  runRW# (\s -> case doThings s of x -> Data.Text.Text x something something')
-
-The former had the CPR property, and so should the latter.
-
-Other considered designs
-------------------------
-
-One design that was rejected was to *require* that runRW#'s continuation be
-headed by a lambda. However, this proved to be quite fragile. For instance,
-SetLevels is very eager to float bottoming expressions. For instance given
-something of the form,
-
-    runRW# @r @ty (\s -> case expr of x -> undefined)
-
-SetLevels will see that the body the lambda is bottoming and will consequently
-float it to the top-level (assuming expr has no free coercion variables which
-prevent this). We therefore end up with
-
-    runRW# @r @ty (\s -> lvl s)
-
-Which the simplifier will beta reduce, leaving us with
-
-    runRW# @r @ty lvl
-
-Breaking our desired invariant. Ultimately we decided to simply accept that
-the continuation may not be a manifest lambda.
-
-
--- ---------------------------------------------------------------------------
---      CpeArg: produces a result satisfying CpeArg
--- ---------------------------------------------------------------------------
-
-Note [ANF-ising literal string arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Consider a program like,
-
-    data Foo = Foo Addr#
-
-    foo = Foo "turtle"#
-
-When we go to ANFise this we might think that we want to float the string
-literal like we do any other non-trivial argument. This would look like,
-
-    foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s }
-
-However, this 1) isn't necessary since strings are in a sense "trivial"; and 2)
-wreaks havoc on the CAF annotations that we produce here since we the result
-above is caffy since it is updateable. Ideally at some point in the future we
-would like to just float the literal to the top level as suggested in #11312,
-
-    s = "turtle"#
-    foo = Foo s
-
-However, until then we simply add a special case excluding literals from the
-floating done by cpeArg.
--}
-
--- | Is an argument okay to CPE?
-okCpeArg :: CoreExpr -> Bool
--- Don't float literals. See Note [ANF-ising literal string arguments].
-okCpeArg (Lit _) = False
--- Do not eta expand a trivial argument
-okCpeArg expr    = not (exprIsTrivial expr)
-
--- This is where we arrange that a non-trivial argument is let-bound
-cpeArg :: CorePrepEnv -> Demand
-       -> CoreArg -> UniqSM (Floats, CpeArg)
-cpeArg env dmd arg
-  = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda
-       ; let arg_ty      = exprType arg1
-             is_unlifted = isUnliftedType arg_ty
-             want_float  = wantFloatNested NonRecursive dmd is_unlifted
-       ; (floats2, arg2) <- if want_float floats1 arg1
-                            then return (floats1, arg1)
-                            else dontFloat floats1 arg1
-                -- Else case: arg1 might have lambdas, and we can't
-                --            put them inside a wrapBinds
-
-       ; if okCpeArg arg2
-         then do { v <- newVar arg_ty
-                 ; let arg3      = cpeEtaExpand (exprArity arg2) arg2
-                       arg_float = mkFloat env dmd is_unlifted v arg3
-                 ; return (addFloat floats2 arg_float, varToCoreExpr v) }
-         else return (floats2, arg2)
-       }
-
-{-
-Note [Floating unlifted arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider    C (let v* = expensive in v)
-
-where the "*" indicates "will be demanded".  Usually v will have been
-inlined by now, but let's suppose it hasn't (see #2756).  Then we
-do *not* want to get
-
-     let v* = expensive in C v
-
-because that has different strictness.  Hence the use of 'allLazy'.
-(NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
-
-
-------------------------------------------------------------------------------
--- Building the saturated syntax
--- ---------------------------------------------------------------------------
-
-Note [Eta expansion of hasNoBinding things in CorePrep]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-maybeSaturate deals with eta expanding to saturate things that can't deal with
-unsaturated applications (identified by 'hasNoBinding', currently
-foreign calls, unboxed tuple/sum constructors, and representation-polymorphic
-primitives such as 'coerce' and 'unsafeCoerce#').
-
-Historical Note: Note that eta expansion in CorePrep used to be very fragile
-due to the "prediction" of CAFfyness that we used to make during tidying.
-We previously saturated primop
-applications here as well but due to this fragility (see #16846) we now deal
-with this another way, as described in Note [Primop wrappers] in GHC.Builtin.PrimOps.
--}
-
-maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs
-maybeSaturate fn expr n_args unsat_ticks
-  | hasNoBinding fn        -- There's no binding
-  = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr
-
-  | mark_arity > 0 -- A call-by-value function. See Note [CBV Function Ids]
-  , not applied_marks
-  = assertPpr
-      ( not (isJoinId fn)) -- See Note [Do not eta-expand join points]
-      ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$
-          text "marks:" <+> ppr (idCbvMarks_maybe fn) $$
-          text "join_arity" <+> ppr (isJoinId_maybe fn) $$
-          text "fn_arity" <+> ppr fn_arity
-       ) $
-    -- pprTrace "maybeSat"
-    --   ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$
-    --       text "marks:" <+> ppr (idCbvMarks_maybe fn) $$
-    --       text "join_arity" <+> ppr (isJoinId_maybe fn) $$
-    --       text "fn_arity" <+> ppr fn_arity $$
-    --       text "excess_arity" <+> ppr excess_arity $$
-    --       text "mark_arity" <+> ppr mark_arity
-    --    ) $
-    return sat_expr
-
-  | otherwise
-  = assert (null unsat_ticks) $
-    return expr
-  where
-    mark_arity    = idCbvMarkArity fn
-    fn_arity      = idArity fn
-    excess_arity  = (max fn_arity mark_arity) - n_args
-    sat_expr      = cpeEtaExpand excess_arity expr
-    applied_marks = n_args >= (length . dropWhile (not . isMarkedCbv) . reverse . expectJust "maybeSaturate" $ (idCbvMarks_maybe fn))
-    -- For join points we never eta-expand (See Note [Do not eta-expand join points])
-    -- so we assert all arguments that need to be passed cbv are visible so that the backend can evalaute them if required..
-{-
-************************************************************************
-*                                                                      *
-                Simple GHC.Core operations
-*                                                                      *
-************************************************************************
--}
-
-{-
--- -----------------------------------------------------------------------------
---      Eta reduction
--- -----------------------------------------------------------------------------
-
-Note [Eta expansion]
-~~~~~~~~~~~~~~~~~~~~~
-Eta expand to match the arity claimed by the binder Remember,
-CorePrep must not change arity
-
-Eta expansion might not have happened already, because it is done by
-the simplifier only when there at least one lambda already.
-
-NB1:we could refrain when the RHS is trivial (which can happen
-    for exported things).  This would reduce the amount of code
-    generated (a little) and make things a little worse for
-    code compiled without -O.  The case in point is data constructor
-    wrappers.
-
-NB2: we have to be careful that the result of etaExpand doesn't
-   invalidate any of the assumptions that CorePrep is attempting
-   to establish.  One possible cause is eta expanding inside of
-   an SCC note - we're now careful in etaExpand to make sure the
-   SCC is pushed inside any new lambdas that are generated.
-
-Note [Eta expansion and the CorePrep invariants]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It turns out to be much much easier to do eta expansion
-*after* the main CorePrep stuff.  But that places constraints
-on the eta expander: given a CpeRhs, it must return a CpeRhs.
-
-For example here is what we do not want:
-                f = /\a -> g (h 3)      -- h has arity 2
-After ANFing we get
-                f = /\a -> let s = h 3 in g s
-and now we do NOT want eta expansion to give
-                f = /\a -> \ y -> (let s = h 3 in g s) y
-
-Instead GHC.Core.Opt.Arity.etaExpand gives
-                f = /\a -> \y -> let s = h 3 in g s y
-
--}
-
-cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
-cpeEtaExpand arity expr
-  | arity == 0 = expr
-  | otherwise  = etaExpand arity expr
-
-{-
-************************************************************************
-*                                                                      *
-                Floats
-*                                                                      *
-************************************************************************
-
-Note [Pin demand info on floats]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We pin demand info on floated lets, so that we can see the one-shot thunks.
-
-Note [Speculative evaluation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Since call-by-value is much cheaper than call-by-need, we case-bind arguments
-that are either
-
-  1. Strictly evaluated anyway, according to the DmdSig of the callee, or
-  2. ok-for-spec, according to 'exprOkForSpeculation'
-
-While (1) is a no-brainer and always beneficial, (2) is a bit
-more subtle, as the careful haddock for 'exprOkForSpeculation'
-points out. Still, by case-binding the argument we don't need
-to allocate a thunk for it, whose closure must be retained as
-long as the callee might evaluate it. And if it is evaluated on
-most code paths anyway, we get to turn the unknown eval in the
-callee into a known call at the call site.
-
-However, we must be very careful not to speculate recursive calls!
-Doing so might well change termination behavior.
-
-That comes up in practice for DFuns, which are considered ok-for-spec,
-because they always immediately return a constructor.
-Not so if you speculate the recursive call, as #20836 shows:
-
-  class Foo m => Foo m where
-    runFoo :: m a -> m a
-  newtype Trans m a = Trans { runTrans :: m a }
-  instance Monad m => Foo (Trans m) where
-    runFoo = id
-
-(NB: class Foo m => Foo m` looks weird and needs -XUndecidableSuperClasses. The
-example in #20836 is more compelling, but boils down to the same thing.)
-This program compiles to the following DFun for the `Trans` instance:
-
-  Rec {
-  $fFooTrans
-    = \ @m $dMonad -> C:Foo ($fFooTrans $dMonad) (\ @a -> id)
-  end Rec }
-
-Note that the DFun immediately terminates and produces a dictionary, just
-like DFuns ought to, but it calls itself recursively to produce the `Foo m`
-dictionary. But alas, if we treat `$fFooTrans` as always-terminating, so
-that we can speculate its calls, and hence use call-by-value, we get:
-
-  $fFooTrans
-    = \ @m $dMonad -> case ($fFooTrans $dMonad) of sc ->
-                      C:Foo sc (\ @a -> id)
-
-and that's an infinite loop!
-Note that this bad-ness only happens in `$fFooTrans`'s own RHS. In the
-*body* of the letrec, it's absolutely fine to use call-by-value on
-`foo ($fFooTrans d)`.
-
-Our solution is this: we track in cpe_rec_ids the set of enclosing
-recursively-bound Ids, the RHSs of which we are currently transforming and then
-in 'exprOkForSpecEval' (a special entry point to 'exprOkForSpeculation',
-basically) we'll say that any binder in this set is not ok-for-spec.
-
-Note if we have a letrec group `Rec { f1 = rhs1; ...; fn = rhsn }`, and we
-prep up `rhs1`, we have to include not only `f1`, but all binders of the group
-`f1..fn` in this set, otherwise our fix is not robust wrt. mutual recursive
-DFuns.
-
-NB: If at some point we decide to have a termination analysis for general
-functions (#8655, !1866), we need to take similar precautions for (guarded)
-recursive functions:
-
-  repeat x = x : repeat x
-
-Same problem here: As written, repeat evaluates rapidly to WHNF. So `repeat x`
-is a cheap call that we are willing to speculate, but *not* in repeat's RHS.
-Fortunately, pce_rec_ids already has all the information we need in that case.
-
-The problem is very similar to Note [Eta reduction in recursive RHSs].
-Here as well as there it is *unsound* to change the termination properties
-of the very function whose termination properties we are exploiting.
--}
-
-data FloatingBind
-  = FloatLet CoreBind    -- Rhs of bindings are CpeRhss
-                         -- They are always of lifted type;
-                         -- unlifted ones are done with FloatCase
-
- | FloatCase
-      CpeBody         -- Always ok-for-speculation
-      Id              -- Case binder
-      AltCon [Var]    -- Single alternative
-      Bool            -- Ok-for-speculation; False of a strict,
-                      -- but lifted binding
-
- -- | See Note [Floating Ticks in CorePrep]
- | FloatTick CoreTickish
-
-data Floats = Floats OkToSpec (OrdList FloatingBind)
-
-instance Outputable FloatingBind where
-  ppr (FloatLet b) = ppr b
-  ppr (FloatCase r b k bs ok) = text "case" <> braces (ppr ok) <+> ppr r
-                                <+> text "of"<+> ppr b <> text "@"
-                                <> case bs of
-                                   [] -> ppr k
-                                   _  -> parens (ppr k <+> ppr bs)
-  ppr (FloatTick t) = ppr t
-
-instance Outputable Floats where
-  ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+>
-                         braces (vcat (map ppr (fromOL fs)))
-
-instance Outputable OkToSpec where
-  ppr OkToSpec    = text "OkToSpec"
-  ppr IfUnboxedOk = text "IfUnboxedOk"
-  ppr NotOkToSpec = text "NotOkToSpec"
-
--- Can we float these binds out of the rhs of a let?  We cache this decision
--- to avoid having to recompute it in a non-linear way when there are
--- deeply nested lets.
-data OkToSpec
-   = OkToSpec           -- Lazy bindings of lifted type
-   | IfUnboxedOk        -- A mixture of lazy lifted bindings and n
-                        -- ok-to-speculate unlifted bindings
-   | NotOkToSpec        -- Some not-ok-to-speculate unlifted bindings
-
-mkFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind
-mkFloat env dmd is_unlifted bndr rhs
-  | is_strict || ok_for_spec -- See Note [Speculative evaluation]
-  , not is_hnf  = FloatCase rhs bndr DEFAULT [] ok_for_spec
-    -- Don't make a case for a HNF binding, even if it's strict
-    -- Otherwise we get  case (\x -> e) of ...!
-
-  | is_unlifted = FloatCase rhs bndr DEFAULT [] True
-      -- we used to assertPpr ok_for_spec (ppr rhs) here, but it is now disabled
-      -- because exprOkForSpeculation isn't stable under ANF-ing. See for
-      -- example #19489 where the following unlifted expression:
-      --
-      --    GHC.Prim.(#|_#) @LiftedRep @LiftedRep @[a_ax0] @[a_ax0]
-      --                    (GHC.Types.: @a_ax0 a2_agq a3_agl)
-      --
-      -- is ok-for-spec but is ANF-ised into:
-      --
-      --    let sat = GHC.Types.: @a_ax0 a2_agq a3_agl
-      --    in GHC.Prim.(#|_#) @LiftedRep @LiftedRep @[a_ax0] @[a_ax0] sat
-      --
-      -- which isn't ok-for-spec because of the let-expression.
-
-  | is_hnf      = FloatLet (NonRec bndr                       rhs)
-  | otherwise   = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)
-                   -- See Note [Pin demand info on floats]
-  where
-    is_hnf      = exprIsHNF rhs
-    is_strict   = isStrUsedDmd dmd
-    ok_for_spec = exprOkForSpecEval (not . is_rec_call) rhs
-    is_rec_call = (`elemUnVarSet` cpe_rec_ids env)
-
-emptyFloats :: Floats
-emptyFloats = Floats OkToSpec nilOL
-
-isEmptyFloats :: Floats -> Bool
-isEmptyFloats (Floats _ bs) = isNilOL bs
-
-wrapBinds :: Floats -> CpeBody -> CpeBody
-wrapBinds (Floats _ binds) body
-  = foldrOL mk_bind body binds
-  where
-    mk_bind (FloatCase rhs bndr con bs _) body = Case rhs bndr (exprType body) [Alt con bs body]
-    mk_bind (FloatLet bind)               body = Let bind body
-    mk_bind (FloatTick tickish)           body = mkTick tickish body
-
-addFloat :: Floats -> FloatingBind -> Floats
-addFloat (Floats ok_to_spec floats) new_float
-  = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
-  where
-    check (FloatLet {})  = OkToSpec
-    check (FloatCase _ _ _ _ ok_for_spec)
-      | ok_for_spec = IfUnboxedOk
-      | otherwise   = NotOkToSpec
-    check FloatTick{}    = OkToSpec
-        -- The ok-for-speculation flag says that it's safe to
-        -- float this Case out of a let, and thereby do it more eagerly
-        -- We need the top-level flag because it's never ok to float
-        -- an unboxed binding to the top level
-
-unitFloat :: FloatingBind -> Floats
-unitFloat = addFloat emptyFloats
-
-appendFloats :: Floats -> Floats -> Floats
-appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
-  = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
-
-concatFloats :: [Floats] -> OrdList FloatingBind
-concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
-
-combine :: OkToSpec -> OkToSpec -> OkToSpec
-combine NotOkToSpec _ = NotOkToSpec
-combine _ NotOkToSpec = NotOkToSpec
-combine IfUnboxedOk _ = IfUnboxedOk
-combine _ IfUnboxedOk = IfUnboxedOk
-combine _ _           = OkToSpec
-
-deFloatTop :: Floats -> [CoreBind]
--- For top level only; we don't expect any FloatCases
-deFloatTop (Floats _ floats)
-  = foldrOL get [] floats
-  where
-    get (FloatLet b)               bs = get_bind b                 : bs
-    get (FloatCase body var _ _ _) bs = get_bind (NonRec var body) : bs
-    get b _ = pprPanic "corePrepPgm" (ppr b)
-
-    -- See Note [Dead code in CorePrep]
-    get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e)
-    get_bind (Rec xes)    = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes]
-
----------------------------------------------------------------------------
-
-canFloat :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
-canFloat (Floats ok_to_spec fs) rhs
-  | OkToSpec <- ok_to_spec           -- Worth trying
-  , Just fs' <- go nilOL (fromOL fs)
-  = Just (Floats OkToSpec fs', rhs)
-  | otherwise
-  = Nothing
-  where
-    go :: OrdList FloatingBind -> [FloatingBind]
-       -> Maybe (OrdList FloatingBind)
-
-    go (fbs_out) [] = Just fbs_out
-
-    go fbs_out (fb@(FloatLet _) : fbs_in)
-      = go (fbs_out `snocOL` fb) fbs_in
-
-    go fbs_out (ft@FloatTick{} : fbs_in)
-      = go (fbs_out `snocOL` ft) fbs_in
-
-    go _ (FloatCase{} : _) = Nothing
-
-
-wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
-wantFloatNested is_rec dmd is_unlifted floats rhs
-  =  isEmptyFloats floats
-  || isStrUsedDmd dmd
-  || is_unlifted
-  || (allLazyNested is_rec floats && exprIsHNF rhs)
-        -- Why the test for allLazyNested?
-        --      v = f (x `divInt#` y)
-        -- we don't want to float the case, even if f has arity 2,
-        -- because floating the case would make it evaluated too early
-
-allLazyTop :: Floats -> Bool
-allLazyTop (Floats OkToSpec _) = True
-allLazyTop _                   = False
-
-allLazyNested :: RecFlag -> Floats -> Bool
-allLazyNested _      (Floats OkToSpec    _) = True
-allLazyNested _      (Floats NotOkToSpec _) = False
-allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
-
-{-
-************************************************************************
-*                                                                      *
-                Cloning
-*                                                                      *
-************************************************************************
--}
-
--- ---------------------------------------------------------------------------
---                      The environment
--- ---------------------------------------------------------------------------
-
-{- Note [Inlining in CorePrep]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There is a subtle but important invariant that must be upheld in the output
-of CorePrep: there are no "trivial" updatable thunks.  Thus, this Core
-is impermissible:
-
-     let x :: ()
-         x = y
-
-(where y is a reference to a GLOBAL variable).  Thunks like this are silly:
-they can always be profitably replaced by inlining x with y. Consequently,
-the code generator/runtime does not bother implementing this properly
-(specifically, there is no implementation of stg_ap_0_upd_info, which is the
-stack frame that would be used to update this thunk.  The "0" means it has
-zero free variables.)
-
-In general, the inliner is good at eliminating these let-bindings.  However,
-there is one case where these trivial updatable thunks can arise: when
-we are optimizing away 'lazy' (see Note [lazyId magic], and also
-'cpeRhsE'.)  Then, we could have started with:
-
-     let x :: ()
-         x = lazy @ () y
-
-which is a perfectly fine, non-trivial thunk, but then CorePrep will
-drop 'lazy', giving us 'x = y' which is trivial and impermissible.
-The solution is CorePrep to have a miniature inlining pass which deals
-with cases like this.  We can then drop the let-binding altogether.
-
-Why does the removal of 'lazy' have to occur in CorePrep?
-The gory details are in Note [lazyId magic] in GHC.Types.Id.Make, but the
-main reason is that lazy must appear in unfoldings (optimizer
-output) and it must prevent call-by-value for catch# (which
-is implemented by CorePrep.)
-
-An alternate strategy for solving this problem is to have the
-inliner treat 'lazy e' as a trivial expression if 'e' is trivial.
-We decided not to adopt this solution to keep the definition
-of 'exprIsTrivial' simple.
-
-There is ONE caveat however: for top-level bindings we have
-to preserve the binding so that we float the (hacky) non-recursive
-binding for data constructors; see Note [Data constructor workers].
-
-Note [CorePrep inlines trivial CoreExpr not Id]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an
-IdEnv Id?  Naively, we might conjecture that trivial updatable thunks
-as per Note [Inlining in CorePrep] always have the form
-'lazy @ SomeType gbl_id'.  But this is not true: the following is
-perfectly reasonable Core:
-
-     let x :: ()
-         x = lazy @ (forall a. a) y @ Bool
-
-When we inline 'x' after eliminating 'lazy', we need to replace
-occurrences of 'x' with 'y @ bool', not just 'y'.  Situations like
-this can easily arise with higher-rank types; thus, cpe_env must
-map to CoreExprs, not Ids.
-
--}
-
-data CorePrepConfig = CorePrepConfig
-  { cp_catchNonexhaustiveCases :: !Bool
-  -- ^ Whether to generate a default alternative with ``error`` in these
-  -- cases. This is helpful when debugging demand analysis or type
-  -- checker bugs which can sometimes manifest as segmentation faults.
-
-  , cp_convertNumLit           :: !(LitNumType -> Integer -> Maybe CoreExpr)
-  -- ^ Convert some numeric literals (Integer, Natural) into their final
-  -- Core form.
-  }
-
-data CorePrepEnv
-  = CPE { cpe_config          :: !CorePrepConfig
-        -- ^ This flag is intended to aid in debugging strictness
-        -- analysis bugs. These are particularly nasty to chase down as
-        -- they may manifest as segmentation faults. When this flag is
-        -- enabled we instead produce an 'error' expression to catch
-        -- the case where a function we think should bottom
-        -- unexpectedly returns.
-        , cpe_env             :: IdEnv CoreExpr   -- Clone local Ids
-        -- ^ This environment is used for three operations:
-        --
-        --      1. To support cloning of local Ids so that they are
-        --      all unique (see item (6) of CorePrep overview).
-        --
-        --      2. To support beta-reduction of runRW, see
-        --      Note [runRW magic] and Note [runRW arg].
-        --
-        --      3. To let us inline trivial RHSs of non top-level let-bindings,
-        --      see Note [lazyId magic], Note [Inlining in CorePrep]
-        --      and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
-
-        , cpe_tyco_env :: Maybe CpeTyCoEnv -- See Note [CpeTyCoEnv]
-
-        , cpe_rec_ids         :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]
-    }
-
-mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv
-mkInitialCorePrepEnv cfg = CPE
-      { cpe_config        = cfg
-      , cpe_env           = emptyVarEnv
-      , cpe_tyco_env      = Nothing
-      , cpe_rec_ids       = emptyUnVarSet
-      }
-
-extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
-extendCorePrepEnv cpe id id'
-    = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }
-
-extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
-extendCorePrepEnvExpr cpe id expr
-    = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr }
-
-extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
-extendCorePrepEnvList cpe prs
-    = cpe { cpe_env = extendVarEnvList (cpe_env cpe)
-                        (map (\(id, id') -> (id, Var id')) prs) }
-
-lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
-lookupCorePrepEnv cpe id
-  = case lookupVarEnv (cpe_env cpe) id of
-        Nothing  -> Var id
-        Just exp -> exp
-
-enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv
-enterRecGroupRHSs env grp
-  = env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) }
-
-------------------------------------------------------------------------------
---           CpeTyCoEnv
--- ---------------------------------------------------------------------------
-
-{- Note [CpeTyCoEnv]
-~~~~~~~~~~~~~~~~~~~~
-The cpe_tyco_env :: Maybe CpeTyCoEnv field carries a substitution
-for type and coercion variables
-
-* We need the coercion substitution to support the elimination of
-  unsafeEqualityProof (see Note [Unsafe coercions])
-
-* We need the type substitution in case one of those unsafe
-  coercions occurs in the kind of tyvar binder (sigh)
-
-We don't need an in-scope set because we don't clone any of these
-binders at all, so no new capture can take place.
-
-The cpe_tyco_env is almost always empty -- it only gets populated
-when we get under an usafeEqualityProof.  Hence the Maybe CpeTyCoEnv,
-which makes everything into a no-op in the common case.
--}
-
-data CpeTyCoEnv = TCE TvSubstEnv CvSubstEnv
-
-emptyTCE :: CpeTyCoEnv
-emptyTCE = TCE emptyTvSubstEnv emptyCvSubstEnv
-
-extend_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion -> CpeTyCoEnv
-extend_tce_cv (TCE tv_env cv_env) cv co
-  = TCE tv_env (extendVarEnv cv_env cv co)
-
-extend_tce_tv :: CpeTyCoEnv -> TyVar -> Type -> CpeTyCoEnv
-extend_tce_tv (TCE tv_env cv_env) tv ty
-  = TCE (extendVarEnv tv_env tv ty) cv_env
-
-lookup_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion
-lookup_tce_cv (TCE _ cv_env) cv
-  = case lookupVarEnv cv_env cv of
-        Just co -> co
-        Nothing -> mkCoVarCo cv
-
-lookup_tce_tv :: CpeTyCoEnv -> TyVar -> Type
-lookup_tce_tv (TCE tv_env _) tv
-  = case lookupVarEnv tv_env tv of
-        Just ty -> ty
-        Nothing -> mkTyVarTy tv
-
-extendCoVarEnv :: CorePrepEnv -> CoVar -> Coercion -> CorePrepEnv
-extendCoVarEnv cpe@(CPE { cpe_tyco_env = mb_tce }) cv co
-  = cpe { cpe_tyco_env = Just (extend_tce_cv tce cv co) }
-  where
-    tce = mb_tce `orElse` emptyTCE
-
-
-cpSubstTy :: CorePrepEnv -> Type -> Type
-cpSubstTy (CPE { cpe_tyco_env = mb_env }) ty
-  = case mb_env of
-      Just env -> runIdentity (subst_ty env ty)
-      Nothing  -> ty
-
-cpSubstCo :: CorePrepEnv -> Coercion -> Coercion
-cpSubstCo (CPE { cpe_tyco_env = mb_env }) co
-  = case mb_env of
-      Just tce -> runIdentity (subst_co tce co)
-      Nothing  -> co
-
-subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity
-subst_tyco_mapper = TyCoMapper
-  { tcm_tyvar      = \env tv -> return (lookup_tce_tv env tv)
-  , tcm_covar      = \env cv -> return (lookup_tce_cv env cv)
-  , tcm_hole       = \_ hole -> pprPanic "subst_co_mapper:hole" (ppr hole)
-  , tcm_tycobinder = \env tcv _vis -> if isTyVar tcv
-                                      then return (subst_tv_bndr env tcv)
-                                      else return (subst_cv_bndr env tcv)
-  , tcm_tycon      = \tc -> return tc }
-
-subst_ty :: CpeTyCoEnv -> Type     -> Identity Type
-subst_co :: CpeTyCoEnv -> Coercion -> Identity Coercion
-(subst_ty, _, subst_co, _) = mapTyCoX subst_tyco_mapper
-
-cpSubstTyVarBndr :: CorePrepEnv -> TyVar -> (CorePrepEnv, TyVar)
-cpSubstTyVarBndr env@(CPE { cpe_tyco_env = mb_env }) tv
-  = case mb_env of
-      Nothing  -> (env, tv)
-      Just tce -> (env { cpe_tyco_env = Just tce' }, tv')
-               where
-                  (tce', tv') = subst_tv_bndr tce tv
-
-subst_tv_bndr :: CpeTyCoEnv -> TyVar -> (CpeTyCoEnv, TyVar)
-subst_tv_bndr tce tv
-  = (extend_tce_tv tce tv (mkTyVarTy tv'), tv')
-  where
-    tv'   = mkTyVar (tyVarName tv) kind'
-    kind' = runIdentity $ subst_ty tce $ tyVarKind tv
-
-cpSubstCoVarBndr :: CorePrepEnv -> CoVar -> (CorePrepEnv, CoVar)
-cpSubstCoVarBndr env@(CPE { cpe_tyco_env = mb_env }) cv
-  = case mb_env of
-      Nothing  -> (env, cv)
-      Just tce -> (env { cpe_tyco_env = Just tce' }, cv')
-               where
-                  (tce', cv') = subst_cv_bndr tce cv
-
-subst_cv_bndr :: CpeTyCoEnv -> CoVar -> (CpeTyCoEnv, CoVar)
-subst_cv_bndr tce cv
-  = (extend_tce_cv tce cv (mkCoVarCo cv'), cv')
-  where
-    cv' = mkCoVar (varName cv) ty'
-    ty' = runIdentity (subst_ty tce $ varType cv)
-
-------------------------------------------------------------------------------
--- Cloning binders
--- ---------------------------------------------------------------------------
-
-cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])
-cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs
-
-cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
-cpCloneBndr env bndr
-  | isTyVar bndr
-  = return (cpSubstTyVarBndr env bndr)
-
-  | isCoVar bndr
-  = return (cpSubstCoVarBndr env bndr)
-
-  | otherwise
-  = do { bndr' <- clone_it bndr
-
-       -- Drop (now-useless) rules/unfoldings
-       -- See Note [Drop unfoldings and rules]
-       -- and Note [Preserve evaluatedness] in GHC.Core.Tidy
-       -- And force it.. otherwise the old unfolding is just retained.
-       -- See #22071
-       ; let !unfolding' = trimUnfolding (realIdUnfolding bndr)
-                          -- Simplifier will set the Id's unfolding
-
-             bndr'' = bndr' `setIdUnfolding`      unfolding'
-                            `setIdSpecialisation` emptyRuleInfo
-
-       ; return (extendCorePrepEnv env bndr bndr'', bndr'') }
-  where
-    clone_it bndr
-      | isLocalId bndr
-      = do { uniq <- getUniqueM
-           ; let ty' = cpSubstTy env (idType bndr)
-           ; return (setVarUnique (setIdType bndr ty') uniq) }
-
-      | otherwise   -- Top level things, which we don't want
-                    -- to clone, have become GlobalIds by now
-      = return bndr
-
-{- Note [Drop unfoldings and rules]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We want to drop the unfolding/rules on every Id:
-
-  - We are now past interface-file generation, and in the
-    codegen pipeline, so we really don't need full unfoldings/rules
-
-  - The unfolding/rule may be keeping stuff alive that we'd like
-    to discard.  See  Note [Dead code in CorePrep]
-
-  - Getting rid of unnecessary unfoldings reduces heap usage
-
-  - We are changing uniques, so if we didn't discard unfoldings/rules
-    we'd have to substitute in them
-
-HOWEVER, we want to preserve evaluated-ness;
-see Note [Preserve evaluatedness] in GHC.Core.Tidy.
--}
-
-------------------------------------------------------------------------------
--- Cloning ccall Ids; each must have a unique name,
--- to give the code generator a handle to hang it on
--- ---------------------------------------------------------------------------
-
-fiddleCCall :: Id -> UniqSM Id
-fiddleCCall id
-  | isFCallId id = (id `setVarUnique`) <$> getUniqueM
-  | otherwise    = return id
-
-------------------------------------------------------------------------------
--- Generating new binders
--- ---------------------------------------------------------------------------
-
-newVar :: Type -> UniqSM Id
-newVar ty
- = seqType ty `seq` mkSysLocalOrCoVarM (fsLit "sat") ManyTy ty
-
-
-------------------------------------------------------------------------------
--- Floating ticks
--- ---------------------------------------------------------------------------
---
--- Note [Floating Ticks in CorePrep]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- It might seem counter-intuitive to float ticks by default, given
--- that we don't actually want to move them if we can help it. On the
--- other hand, nothing gets very far in CorePrep anyway, and we want
--- to preserve the order of let bindings and tick annotations in
--- relation to each other. For example, if we just wrapped let floats
--- when they pass through ticks, we might end up performing the
--- following transformation:
---
---   src<...> let foo = bar in baz
---   ==>  let foo = src<...> bar in src<...> baz
---
--- Because the let-binding would float through the tick, and then
--- immediately materialize, achieving nothing but decreasing tick
--- accuracy. The only special case is the following scenario:
---
---   let foo = src<...> (let a = b in bar) in baz
---   ==>  let foo = src<...> bar; a = src<...> b in baz
---
--- Here we would not want the source tick to end up covering "baz" and
--- therefore refrain from pushing ticks outside. Instead, we copy them
--- into the floating binds (here "a") in cpePair. Note that where "b"
--- or "bar" are (value) lambdas we have to push the annotations
--- further inside in order to uphold our rules.
---
--- All of this is implemented below in @wrapTicks@.
-
--- | Like wrapFloats, but only wraps tick floats
-wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
-wrapTicks (Floats flag floats0) expr =
-    (Floats flag (toOL $ reverse floats1), foldr mkTick expr (reverse ticks1))
-  where (floats1, ticks1) = foldlOL go ([], []) $ floats0
-        -- Deeply nested constructors will produce long lists of
-        -- redundant source note floats here. We need to eliminate
-        -- those early, as relying on mkTick to spot it after the fact
-        -- can yield O(n^3) complexity [#11095]
-        go (floats, ticks) (FloatTick t)
-          = assert (tickishPlace t == PlaceNonLam)
-            (floats, if any (flip tickishContains t) ticks
-                     then ticks else t:ticks)
-        go (floats, ticks) f
-          = (foldr wrap f (reverse ticks):floats, ticks)
-
-        wrap t (FloatLet bind)           = FloatLet (wrapBind t bind)
-        wrap t (FloatCase r b con bs ok) = FloatCase (mkTick t r) b con bs ok
-        wrap _ other                     = pprPanic "wrapTicks: unexpected float!"
-                                             (ppr other)
-        wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
-        wrapBind t (Rec pairs)         = Rec (mapSnd (mkTick t) pairs)
-
-------------------------------------------------------------------------------
--- Numeric literals
--- ---------------------------------------------------------------------------
-
--- | Create a function that converts Bignum literals into their final CoreExpr
-mkConvertNumLiteral
-   :: Platform
-   -> HomeUnit
-   -> (Name -> IO TyThing)
-   -> IO (LitNumType -> Integer -> Maybe CoreExpr)
-mkConvertNumLiteral platform home_unit lookup_global = do
-   let
-      guardBignum act
-         | isHomeUnitInstanceOf home_unit primUnitId
-         = return $ panic "Bignum literals are not supported in ghc-prim"
-         | isHomeUnitInstanceOf home_unit bignumUnitId
-         = return $ panic "Bignum literals are not supported in ghc-bignum"
-         | otherwise = act
-
-      lookupBignumId n      = guardBignum (tyThingId <$> lookup_global n)
-
-   -- The lookup is done here but the failure (panic) is reported lazily when we
-   -- try to access the `bigNatFromWordList` function.
-   --
-   -- If we ever get built-in ByteArray# literals, we could avoid the lookup by
-   -- directly using the Integer/Natural wired-in constructors for big numbers.
-
-   bignatFromWordListId <- lookupBignumId bignatFromWordListName
-
-   let
-      convertNumLit nt i = case nt of
-         LitNumBigNat  -> Just (convertBignatPrim i)
-         _             -> Nothing
-
-      convertBignatPrim i =
-         let
-            -- ByteArray# literals aren't supported (yet). Were they supported,
-            -- we would use them directly. We would need to handle
-            -- wordSize/endianness conversion between host and target
-            -- wordSize  = platformWordSize platform
-            -- byteOrder = platformByteOrder platform
-
-            -- For now we build a list of Words and we produce
-            -- `bigNatFromWordList# list_of_words`
-
-            words = mkListExpr wordTy (reverse (unfoldr f i))
-               where
-                  f 0 = Nothing
-                  f x = let low  = x .&. mask
-                            high = x `shiftR` bits
-                        in Just (mkConApp wordDataCon [Lit (mkLitWord platform low)], high)
-                  bits = platformWordSizeInBits platform
-                  mask = 2 ^ bits - 1
-
-         in mkApps (Var bignatFromWordListId) [words]
-
-
-   return convertNumLit
diff --git a/compiler/GHC/Data/Bitmap.hs b/compiler/GHC/Data/Bitmap.hs
deleted file mode 100644
--- a/compiler/GHC/Data/Bitmap.hs
+++ /dev/null
@@ -1,103 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-
---
--- (c) The University of Glasgow 2003-2006
---
-
--- Functions for constructing bitmaps, which are used in various
--- places in generated code (stack frame liveness masks, function
--- argument liveness masks, SRT bitmaps).
-
-module GHC.Data.Bitmap (
-        Bitmap, mkBitmap,
-        intsToReverseBitmap,
-        mAX_SMALL_BITMAP_SIZE,
-  ) where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Runtime.Heap.Layout
-
-
-{-|
-A bitmap represented by a sequence of 'StgWord's on the /target/
-architecture.  These are used for bitmaps in info tables and other
-generated code which need to be emitted as sequences of StgWords.
--}
-type Bitmap = [StgWord]
-
--- | Make a bitmap from a sequence of bits
-mkBitmap :: Platform -> [Bool] -> Bitmap
-mkBitmap _ [] = []
-mkBitmap platform stuff = chunkToBitmap platform chunk : mkBitmap platform rest
-  where (chunk, rest) = splitAt (platformWordSizeInBits platform) stuff
-
-chunkToBitmap :: Platform -> [Bool] -> StgWord
-chunkToBitmap platform chunk =
-  foldl' (.|.) (toStgWord platform 0) [ oneAt n | (True,n) <- zip chunk [0..] ]
-  where
-    oneAt :: Int -> StgWord
-    oneAt i = toStgWord platform 1 `shiftL` i
-
--- | Make a bitmap where the slots specified are the /zeros/ in the bitmap.
--- eg. @[0,1,3], size 4 ==> 0x4@  (we leave any bits outside the size as zero,
--- just to make the bitmap easier to read).
---
--- The list of @Int@s /must/ be already sorted and duplicate-free.
-intsToReverseBitmap :: Platform
-                    -> Int      -- ^ size in bits
-                    -> [Int]    -- ^ sorted indices of zeros free of duplicates
-                    -> Bitmap
-intsToReverseBitmap platform size = go 0
-  where
-    word_sz = platformWordSizeInBits platform
-    oneAt :: Int -> StgWord
-    oneAt i = toStgWord platform 1 `shiftL` i
-
-    -- It is important that we maintain strictness here.
-    -- See Note [Strictness when building Bitmaps].
-    go :: Int -> [Int] -> Bitmap
-    go !pos slots
-      | size <= pos = []
-      | otherwise =
-        (foldl' xor (toStgWord platform init) (map (\i->oneAt (i - pos)) these)) :
-          go (pos + word_sz) rest
-      where
-        (these,rest) = span (< (pos + word_sz)) slots
-        remain = size - pos
-        init
-          | remain >= word_sz = -1
-          | otherwise         = (1 `shiftL` remain) - 1
-
-{-
-
-Note [Strictness when building Bitmaps]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-One of the places where @Bitmap@ is used is in building Static Reference
-Tables (SRTs) (in @GHC.Cmm.Info.Build.procpointSRT@). In #7450 it was noticed
-that some test cases (particularly those whose C-- have large numbers of CAFs)
-produced large quantities of allocations from this function.
-
-The source traced back to 'intsToBitmap', which was lazily subtracting the word
-size from the elements of the tail of the @slots@ list and recursively invoking
-itself with the result. This resulted in large numbers of subtraction thunks
-being built up. Here we take care to avoid passing new thunks to the recursive
-call. Instead we pass the unmodified tail along with an explicit position
-accumulator, which get subtracted in the fold when we compute the Word.
-
--}
-
-{- |
-Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h.
-Some kinds of bitmap pack a size\/bitmap into a single word if
-possible, or fall back to an external pointer when the bitmap is too
-large.  This value represents the largest size of bitmap that can be
-packed into a single word.
--}
-mAX_SMALL_BITMAP_SIZE :: Platform -> Int
-mAX_SMALL_BITMAP_SIZE platform =
-    case platformWordSize platform of
-      PW4 -> 27 -- On 32-bit: 5 bits for size, 27 bits for bitmap
-      PW8 -> 58 -- On 64-bit: 6 bits for size, 58 bits for bitmap
diff --git a/compiler/GHC/Data/Graph/Base.hs b/compiler/GHC/Data/Graph/Base.hs
deleted file mode 100644
--- a/compiler/GHC/Data/Graph/Base.hs
+++ /dev/null
@@ -1,107 +0,0 @@
-
--- | Types for the general graph colorer.
-module GHC.Data.Graph.Base (
-        Triv,
-        Graph (..),
-        initGraph,
-        graphMapModify,
-
-        Node  (..),     newNode,
-)
-
-
-where
-
-import GHC.Prelude
-
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.FM
-
-
--- | A fn to check if a node is trivially colorable
---      For graphs who's color classes are disjoint then a node is 'trivially colorable'
---      when it has less neighbors and exclusions than available colors for that node.
---
---      For graph's who's color classes overlap, ie some colors alias other colors, then
---      this can be a bit more tricky. There is a general way to calculate this, but
---      it's likely be too slow for use in the code. The coloring algorithm takes
---      a canned function which can be optimised by the user to be specific to the
---      specific graph being colored.
---
---      for details, see  "A Generalised Algorithm for Graph-Coloring Register Allocation"
---                              Smith, Ramsey, Holloway - PLDI 2004.
---
-type Triv k cls color
-        =  cls                  -- the class of the node we're trying to color.
-        -> UniqSet k            -- the node's neighbors.
-        -> UniqSet color        -- the node's exclusions.
-        -> Bool
-
-
--- | The Interference graph.
---      There used to be more fields, but they were turfed out in a previous revision.
---      maybe we'll want more later..
---
-newtype Graph k cls color
-        = Graph {
-        -- | All active nodes in the graph.
-          graphMap              :: UniqFM k (Node k cls color)  }
-
-
--- | An empty graph.
-initGraph :: Graph k cls color
-initGraph
-        = Graph
-        { graphMap              = emptyUFM }
-
-
--- | Modify the finite map holding the nodes in the graph.
-graphMapModify
-        :: (UniqFM k (Node k cls color) -> UniqFM k (Node k cls color))
-        -> Graph k cls color -> Graph k cls color
-
-graphMapModify f graph
-        = graph { graphMap      = f (graphMap graph) }
-
-
-
--- | Graph nodes.
---      Represents a thing that can conflict with another thing.
---      For the register allocater the nodes represent registers.
---
-data Node k cls color
-        = Node {
-        -- | A unique identifier for this node.
-          nodeId                :: k
-
-        -- | The class of this node,
-        --      determines the set of colors that can be used.
-        , nodeClass             :: cls
-
-        -- | The color of this node, if any.
-        , nodeColor             :: Maybe color
-
-        -- | Neighbors which must be colored differently to this node.
-        , nodeConflicts         :: UniqSet k
-
-        -- | Colors that cannot be used by this node.
-        , nodeExclusions        :: UniqSet color
-
-        -- | Colors that this node would prefer to be, in descending order.
-        , nodePreference        :: [color]
-
-        -- | Neighbors that this node would like to be colored the same as.
-        , nodeCoalesce          :: UniqSet k }
-
-
--- | An empty node.
-newNode :: k -> cls -> Node k cls color
-newNode k cls
-        = Node
-        { nodeId                = k
-        , nodeClass             = cls
-        , nodeColor             = Nothing
-        , nodeConflicts         = emptyUniqSet
-        , nodeExclusions        = emptyUniqSet
-        , nodePreference        = []
-        , nodeCoalesce          = emptyUniqSet }
diff --git a/compiler/GHC/Data/Graph/Collapse.hs b/compiler/GHC/Data/Graph/Collapse.hs
deleted file mode 100644
--- a/compiler/GHC/Data/Graph/Collapse.hs
+++ /dev/null
@@ -1,264 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
-module GHC.Data.Graph.Collapse
-  ( PureSupernode(..)
-  , Supernode(..)
-  , collapseInductiveGraph
-  , VizCollapseMonad(..)
-  , NullCollapseViz(..)
-  , runNullCollapse
-  , MonadUniqSM(..)
-  )
-where
-
-import GHC.Prelude
-
-import Control.Exception
-import Control.Monad
-import Data.List (delete, union, insert, intersect)
-import Data.Semigroup
-
-import GHC.Cmm.Dataflow.Label
-import GHC.Data.Graph.Inductive.Graph
-import GHC.Types.Unique.Supply
-import GHC.Utils.Panic
-
-
-{-|
-Module      : GHC.Data.Graph.Collapse
-Description : Implement the "collapsing" algorithm Hecht and Ullman
-
-A control-flow graph is reducible if and only if it is collapsible
-according to the definition of Hecht and Ullman (1972).   This module
-implements the collapsing algorithm of Hecht and Ullman, and if it
-encounters a graph that is not collapsible, it splits nodes until the
-graph is fully collapsed.  It then reports what nodes (if any) had to
-be split in order to collapse the graph.  The information is used
-upstream to node-split Cmm graphs.
-
-The module uses the inductive graph representation cloned from the
-Functional Graph Library (Hackage package `fgl`, modules
-`GHC.Data.Graph.Inductive.*`.)
-
--}
-
--- Full reference to paper: Matthew S. Hecht and Jeffrey D. Ullman
--- (1972).  Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202.
--- https://doi.org/10.1137/0201014
-
-
------------------- Graph-splitting monad -----------------------
-
--- | If you want to visualize the graph-collapsing algorithm, create
--- an instance of monad `VizCollapseMonad`.  Each step in the
--- algorithm is announced to the monad as a side effect.  If you don't
--- care about visualization, you would use the `NullCollapseViz`
--- monad, in which these operations are no-ops.
-
-class (Monad m) => MonadUniqSM m where
-  liftUniqSM :: UniqSM a -> m a
-
-class (MonadUniqSM m, Graph gr, Supernode s m) => VizCollapseMonad m gr s where
-  consumeByInGraph :: Node -> Node -> gr s () -> m ()
-  splitGraphAt :: gr s () -> LNode s -> m ()
-  finalGraph :: gr s () -> m ()
-
-
-
--- | The identity monad as a `VizCollapseMonad`.  Use this monad when
--- you want efficiency in graph collapse.
-newtype NullCollapseViz a = NullCollapseViz { unNCV :: UniqSM a }
-  deriving (Functor, Applicative, Monad, MonadUnique)
-
-instance MonadUniqSM NullCollapseViz where
-  liftUniqSM = NullCollapseViz
-
-instance (Graph gr, Supernode s NullCollapseViz) =>
-    VizCollapseMonad NullCollapseViz gr s where
-  consumeByInGraph _ _ _ = return ()
-  splitGraphAt _ _ = return ()
-  finalGraph _ = return ()
-
-runNullCollapse :: NullCollapseViz a -> UniqSM a
-runNullCollapse = unNCV
-
-
------------------- Utility functions on graphs -----------------------
-
-
--- | Tell if a `Node` has a single predecessor.
-singlePred :: Graph gr => gr a b -> Node -> Bool
-singlePred gr n
-    | ([_], _, _, _) <- context gr n = True
-    | otherwise = False
-
--- | Use this function to extract information about a `Node` that you
--- know is in a `Graph`.  It's like `match` from `Graph`, but it must
--- succeed.
-forceMatch :: (Graph gr)
-           => Node -> gr s b -> (Context s b, gr s b)
-forceMatch node g = case match node g of (Just c, g') -> (c, g')
-                                         _ -> panicDump node g
- where panicDump :: Graph gr => Node -> gr s b -> any
-       panicDump k _g =
-         panic $ "GHC.Data.Graph.Collapse failed to match node " ++ show k
-
--- | Rewrite the label of a given node.
-updateNode :: DynGraph gr => (s -> s) -> Node -> gr s b -> gr s b
-updateNode relabel node g = (preds, n, relabel this, succs) & g'
-    where ((preds, n, this, succs), g') = forceMatch node g
-
-
--- | Test if a graph has but a single node.
-singletonGraph :: Graph gr => gr a b -> Bool
-singletonGraph g = case labNodes g of [_] -> True
-                                      _ -> False
-
-
-----------------  Supernodes ------------------------------------
-
--- | A "supernode" stands for a collection of one or more nodes (basic
--- blocks) that have been coalesced by the Hecht-Ullman algorithm.
--- A collection in a supernode constitutes a /reducible/ subgraph of a
--- control-flow graph.  (When an entire control-flow graph is collapsed
--- to a single supernode, the flow graph is reducible.)
---
--- The idea of node splitting is to collapse a control-flow graph down
--- to a single supernode, then materialize (``inflate'') the reducible
--- equivalent graph from that supernode.  The `Supernode` class
--- defines only the methods needed to collapse; rematerialization is
--- the responsiblity of the client.
---
--- During the Hecht-Ullman algorithm, every supernode has a unique
--- entry point, which is given by `superLabel`.  But this invariant is
--- not guaranteed by the class methods and is not a law of the class.
--- The `mapLabels` function rewrites all labels that appear in a
--- supernode (both definitions and uses).  The `freshen` function
--- replaces every appearance of a /defined/ label with a fresh label.
--- (Appearances include both definitions and uses.)
---
--- Laws:
--- @
---    superLabel (n <> n') == superLabel n
---    blocks (n <> n') == blocks n `union` blocks n'
---    mapLabels f (n <> n') = mapLabels f n <> mapLabels f n'
---    mapLabels id == id
---    mapLabels (f . g) == mapLabels f . mapLabels g
--- @
---
--- (We expect `freshen` to distribute over `<>`, but because of
--- the fresh names involved, formulating a precise law is a bit
--- challenging.)
-
-class (Semigroup node) => PureSupernode node where
-  superLabel :: node -> Label
-  mapLabels :: (Label -> Label) -> (node -> node)
-
-class (MonadUnique m, PureSupernode node) => Supernode node m where
-  freshen :: node -> m node
-
-  -- ghost method
-  -- blocks :: node -> Set Block
-
------------------- Functions specific to the algorithm -----------------------
-
--- | Merge two nodes, return new graph plus list of nodes that newly have a single
--- predecessor.  This function implements transformation $T_2$ from
--- the Hecht and Ullman paper (merge the node into its unique
--- predecessor).  It then also removes self-edges (transformation $T_1$ from
--- the Hecht and Ullman paper).  There is no need for a separate
--- implementation of $T_1$.
---
--- `consumeBy v u g` returns the graph that results when node v is
--- consumed by node u in graph g.  Both v and u are replaced with a new node u'
--- with these properties:
---
---    LABELS(u') = LABELS(u) `union` LABELS(v)
---    SUCC(u') = SUCC(u) `union` SUCC(v) - { u }
---    every node that previously points to u now points to u'
---
--- It also returns a list of nodes in the result graph that
--- are *newly* single-predecessor nodes.
-
-consumeBy :: (DynGraph gr, PureSupernode s)
-          => Node -> Node -> gr s () -> (gr s (), [Node])
-consumeBy toNode fromNode g =
-    assert (toPreds == [((), fromNode)]) $
-    (newGraph, newCandidates)
-  where ((toPreds,   _, to,   toSuccs),   g')  = forceMatch toNode   g
-        ((fromPreds, _, from, fromSuccs), g'') = forceMatch fromNode g'
-        context = ( fromPreds -- by construction, can't have `toNode`
-                  , fromNode
-                  , from <> to
-                  , delete ((), fromNode) toSuccs `union` fromSuccs
-                  )
-        newGraph = context & g''
-        newCandidates = filter (singlePred newGraph) changedNodes
-        changedNodes = fromNode `insert` map snd (toSuccs `intersect` fromSuccs)
-
--- | Split a given node.  The node is replaced with a collection of replicas,
--- one for each predecessor.  After the split, every predecessor
--- points to a unique replica.
-split :: forall gr s b m . (DynGraph gr, Supernode s m)
-      => Node -> gr s b -> m (gr s b)
-split node g = assert (isMultiple preds) $ foldM addReplica g' newNodes
-  where ((preds, _, this, succs), g') = forceMatch node g
-        newNodes :: [((b, Node), Node)]
-        newNodes = zip preds [maxNode+1..]
-        (_, maxNode) = nodeRange g
-        thisLabel = superLabel this
-        addReplica :: gr s b -> ((b, Node), Node) -> m (gr s b)
-        addReplica g ((b, pred), newNode) = do
-            newSuper <- freshen this
-            return $ add newSuper
-          where add newSuper =
-                  updateNode (thisLabel `replacedWith` superLabel newSuper) pred $
-                  ([(b, pred)], newNode, newSuper, succs) & g
-
-replacedWith :: PureSupernode s => Label -> Label -> s -> s
-replacedWith old new = mapLabels (\l -> if l == old then new else l)
-
-
--- | Does a list have more than one element? (in constant time).
-isMultiple :: [a] -> Bool
-isMultiple [] = False
-isMultiple [_] = False
-isMultiple (_:_:_) = True
-
--- | Find a candidate for splitting by finding a node that has multiple predecessors.
-
-anySplittable :: forall gr a b . Graph gr => gr a b -> LNode a
-anySplittable g = case splittable of
-                    n : _ -> n
-                    [] -> panic "anySplittable found no splittable nodes"
-  where splittable = filter (isMultiple . pre g . fst) $ labNodes g
-        splittable :: [LNode a]
-
-
------------------- The collapsing algorithm -----------------------
-
--- | Using the algorithm of Hecht and Ullman (1972), collapse a graph
--- into a single node, splitting nodes as needed.  Record
--- visualization events in monad `m`.
-collapseInductiveGraph :: (DynGraph gr, Supernode s m, VizCollapseMonad m gr s)
-                       => gr s () -> m (gr s ())
-collapseInductiveGraph g = drain g worklist
-  where worklist :: [[Node]] -- nodes with exactly one predecessor
-        worklist = [filter (singlePred g) $ nodes g]
-
-        drain g [] = if singletonGraph g then finalGraph g >> return g
-                     else let (n, super) = anySplittable g
-                          in  do splitGraphAt g (n, super)
-                                 collapseInductiveGraph =<< split n g
-        drain g ([]:nss) = drain g nss
-        drain g ((n:ns):nss) = let (g', ns') = consumeBy n (theUniquePred n) g
-                               in  do consumeByInGraph n (theUniquePred n) g
-                                      drain g' (ns':ns:nss)
-         where theUniquePred n
-                 | ([(_, p)], _, _, _) <- context g n = p
-                 | otherwise =
-                     panic "node claimed to have a unique predecessor; it doesn't"
diff --git a/compiler/GHC/Data/Graph/Color.hs b/compiler/GHC/Data/Graph/Color.hs
deleted file mode 100644
--- a/compiler/GHC/Data/Graph/Color.hs
+++ /dev/null
@@ -1,384 +0,0 @@
--- | Graph Coloring.
---      This is a generic graph coloring library, abstracted over the type of
---      the node keys, nodes and colors.
---
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module GHC.Data.Graph.Color (
-        module GHC.Data.Graph.Base,
-        module GHC.Data.Graph.Ops,
-        module GHC.Data.Graph.Ppr,
-        colorGraph
-)
-
-where
-
-import GHC.Prelude
-
-import GHC.Data.Graph.Base
-import GHC.Data.Graph.Ops
-import GHC.Data.Graph.Ppr
-
-import GHC.Types.Unique
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Set
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import Data.Maybe
-import Data.List (mapAccumL)
-
-
--- | Try to color a graph with this set of colors.
---      Uses Chaitin's algorithm to color the graph.
---      The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes
---      are pushed onto a stack and removed from the graph.
---      Once this process is complete the graph can be colored by removing nodes from
---      the stack (ie in reverse order) and assigning them colors different to their neighbors.
---
-colorGraph
-        :: forall k cls color.
-           ( Uniquable  k, Uniquable cls,  Uniquable  color
-           , Eq cls, Ord k
-           , Outputable k, Outputable cls, Outputable color)
-        => Bool                         -- ^ whether to do iterative coalescing
-        -> Int                          -- ^ how many times we've tried to color this graph so far.
-        -> UniqFM cls (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
-        -> Triv   k cls color           -- ^ fn to decide whether a node is trivially colorable.
-        -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
-        -> Graph  k cls color           -- ^ the graph to color.
-
-        -> ( Graph k cls color          -- the colored graph.
-           , UniqSet k                  -- the set of nodes that we couldn't find a color for.
-           , UniqFM k k )                -- map of regs (r1 -> r2) that were coalesced
-                                        --       r1 should be replaced by r2 in the source
-
-colorGraph iterative spinCount colors triv spill graph0
- = let
-        -- If we're not doing iterative coalescing then do an aggressive coalescing first time
-        --      around and then conservative coalescing for subsequent passes.
-        --
-        --      Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if
-        --      there is a lot of register pressure and we do it on every round then it can make the
-        --      graph less colorable and prevent the algorithm from converging in a sensible number
-        --      of cycles.
-        --
-        (graph_coalesced, kksCoalesce1)
-         = if iterative
-                then (graph0, [])
-                else if spinCount == 0
-                        then coalesceGraph True  triv graph0
-                        else coalesceGraph False triv graph0
-
-        -- run the scanner to slurp out all the trivially colorable nodes
-        --      (and do coalescing if iterative coalescing is enabled)
-        (ksTriv, ksProblems, kksCoalesce2 :: [(k,k)])
-                = colorScan iterative triv spill graph_coalesced
-
-        -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business.
-        --      We need to apply all the coalescences found by the scanner to the original
-        --      graph before doing assignColors.
-        --
-        --      Because we've got the whole, non-pruned graph here we turn on aggressive coalescing
-        --      to force all the (conservative) coalescences found during scanning.
-        --
-        (graph_scan_coalesced, _)
-                = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2
-
-        -- color the trivially colorable nodes
-        --      during scanning, keys of triv nodes were added to the front of the list as they were found
-        --      this colors them in the reverse order, as required by the algorithm.
-        (graph_triv, ksNoTriv)
-                = assignColors colors graph_scan_coalesced ksTriv
-
-        -- try and color the problem nodes
-        --      problem nodes are the ones that were left uncolored because they weren't triv.
-        --      there's a change we can color them here anyway.
-        (graph_prob, ksNoColor)
-                = assignColors colors graph_triv ksProblems
-
-        -- if the trivially colorable nodes didn't color then something is probably wrong
-        --      with the provided triv function.
-        --
-   in   if not $ null ksNoTriv
-         then   pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty
-                        (  empty
-                        $$ text "ksTriv    = " <> ppr ksTriv
-                        $$ text "ksNoTriv  = " <> ppr ksNoTriv
-                        $$ text "colors    = " <> ppr colors
-                        $$ empty
-                        $$ dotGraph (\_ -> text "white") triv graph_triv)
-
-         else   ( graph_prob
-                , mkUniqSet ksNoColor   -- the nodes that didn't color (spills)
-                , if iterative
-                        then (listToUFM kksCoalesce2)
-                        else (listToUFM kksCoalesce1))
-
-
--- | Scan through the conflict graph separating out trivially colorable and
---      potentially uncolorable (problem) nodes.
---
---      Checking whether a node is trivially colorable or not is a reasonably expensive operation,
---      so after a triv node is found and removed from the graph it's no good to return to the 'start'
---      of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable.
---
---      To ward against this, during each pass through the graph we collect up a list of triv nodes
---      that were found, and only remove them once we've finished the pass. The more nodes we can delete
---      at once the more likely it is that nodes we've already checked will become trivially colorable
---      for the next pass.
---
---      TODO:   add work lists to finding triv nodes is easier.
---              If we've just scanned the graph, and removed triv nodes, then the only
---              nodes that we need to rescan are the ones we've removed edges from.
-
-colorScan
-        :: ( Uniquable k, Uniquable cls, Uniquable color
-           , Ord k,       Eq cls
-           , Outputable k, Outputable cls)
-        => Bool                         -- ^ whether to do iterative coalescing
-        -> Triv k cls color             -- ^ fn to decide whether a node is trivially colorable
-        -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
-        -> Graph k cls color            -- ^ the graph to scan
-
-        -> ([k], [k], [(k, k)])         --  triv colorable nodes, problem nodes, pairs of nodes to coalesce
-
-colorScan iterative triv spill graph
-        = colorScan_spin iterative triv spill graph [] [] []
-
-colorScan_spin
-        :: ( Uniquable k, Uniquable cls, Uniquable color
-           , Ord k,       Eq cls
-           , Outputable k, Outputable cls)
-        => Bool
-        -> Triv k cls color
-        -> (Graph k cls color -> k)
-        -> Graph k cls color
-        -> [k]
-        -> [k]
-        -> [(k, k)]
-        -> ([k], [k], [(k, k)])
-
-colorScan_spin iterative triv spill graph
-        ksTriv ksSpill kksCoalesce
-
-        -- if the graph is empty then we're done
-        | isNullUFM $ graphMap graph
-        = (ksTriv, ksSpill, reverse kksCoalesce)
-
-        -- Simplify:
-        --      Look for trivially colorable nodes.
-        --      If we can find some then remove them from the graph and go back for more.
-        --
-        | nsTrivFound@(_:_)
-                <-  scanGraph   (\node -> triv  (nodeClass node) (nodeConflicts node) (nodeExclusions node)
-
-                                  -- for iterative coalescing we only want non-move related
-                                  --    nodes here
-                                  && (not iterative || isEmptyUniqSet (nodeCoalesce node)))
-                        $ graph
-
-        , ksTrivFound   <- map nodeId nsTrivFound
-        , graph2        <- foldr (\k g -> let Just g' = delNode k g
-                                          in  g')
-                                graph ksTrivFound
-
-        = colorScan_spin iterative triv spill graph2
-                (ksTrivFound ++ ksTriv)
-                ksSpill
-                kksCoalesce
-
-        -- Coalesce:
-        --      If we're doing iterative coalescing and no triv nodes are available
-        --      then it's time for a coalescing pass.
-        | iterative
-        = case coalesceGraph False triv graph of
-
-                -- we were able to coalesce something
-                --      go back to Simplify and see if this frees up more nodes to be trivially colorable.
-                (graph2, kksCoalesceFound@(_:_))
-                 -> colorScan_spin iterative triv spill graph2
-                        ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce)
-
-                -- Freeze:
-                -- nothing could be coalesced (or was triv),
-                --      time to choose a node to freeze and give up on ever coalescing it.
-                (graph2, [])
-                 -> case freezeOneInGraph graph2 of
-
-                        -- we were able to freeze something
-                        --      hopefully this will free up something for Simplify
-                        (graph3, True)
-                         -> colorScan_spin iterative triv spill graph3
-                                ksTriv ksSpill kksCoalesce
-
-                        -- we couldn't find something to freeze either
-                        --      time for a spill
-                        (graph3, False)
-                         -> colorScan_spill iterative triv spill graph3
-                                ksTriv ksSpill kksCoalesce
-
-        -- spill time
-        | otherwise
-        = colorScan_spill iterative triv spill graph
-                ksTriv ksSpill kksCoalesce
-
-
--- Select:
--- we couldn't find any triv nodes or things to freeze or coalesce,
---      and the graph isn't empty yet.. We'll have to choose a spill
---      candidate and leave it uncolored.
---
-colorScan_spill
-        :: ( Uniquable k, Uniquable cls, Uniquable color
-           , Ord k,       Eq cls
-           , Outputable k, Outputable cls)
-        => Bool
-        -> Triv k cls color
-        -> (Graph k cls color -> k)
-        -> Graph k cls color
-        -> [k]
-        -> [k]
-        -> [(k, k)]
-        -> ([k], [k], [(k, k)])
-
-colorScan_spill iterative triv spill graph
-        ksTriv ksSpill kksCoalesce
-
- = let  kSpill          = spill graph
-        Just graph'     = delNode kSpill graph
-   in   colorScan_spin iterative triv spill graph'
-                ksTriv (kSpill : ksSpill) kksCoalesce
-
-
--- | Try to assign a color to all these nodes.
-
-assignColors
-        :: forall k cls color.
-           ( Uniquable k, Uniquable cls, Uniquable color
-           , Outputable cls)
-        => UniqFM cls (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
-        -> Graph k cls color            -- ^ the graph
-        -> [k]                          -- ^ nodes to assign a color to.
-        -> ( Graph k cls color          -- the colored graph
-           , [k])                       -- the nodes that didn't color.
-
-assignColors colors graph ks
-        = assignColors' colors graph [] ks
-
- where  assignColors' :: UniqFM cls (UniqSet color)     -- map of (node class -> set of colors available for this class).
-                        -> Graph k cls color            -- the graph
-                        -> [k]                          -- nodes to assign a color to.
-                        -> [k]
-                        -> ( Graph k cls color          -- the colored graph
-                        , [k])
-        assignColors' _ graph prob []
-                = (graph, prob)
-
-        assignColors' colors graph prob (k:ks)
-         = case assignColor colors k graph of
-
-                -- couldn't color this node
-                Nothing         -> assignColors' colors graph (k : prob) ks
-
-                -- this node colored ok, so do the rest
-                Just graph'     -> assignColors' colors graph' prob ks
-
-
-        assignColor colors u graph
-                | Just c        <- selectColor colors graph u
-                = Just (setColor u c graph)
-
-                | otherwise
-                = Nothing
-
-
-
--- | Select a color for a certain node
---      taking into account preferences, neighbors and exclusions.
---      returns Nothing if no color can be assigned to this node.
---
-selectColor
-        :: ( Uniquable k, Uniquable cls, Uniquable color
-           , Outputable cls)
-        => UniqFM cls (UniqSet color)   -- map of (node class -> set of colors available for this class).
-        -> Graph k cls color            -- the graph
-        -> k                            -- key of the node to select a color for.
-        -> Maybe color
-
-selectColor colors graph u
- = let  -- lookup the node
-        Just node       = lookupNode graph u
-
-        -- lookup the available colors for the class of this node.
-        colors_avail
-         = case lookupUFM colors (nodeClass node) of
-                Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node))
-                Just cs -> cs
-
-        -- find colors we can't use because they're already being used
-        --      by a node that conflicts with this one.
-        Just nsConflicts
-                        = sequence
-                        $ map (lookupNode graph)
-                        $ nonDetEltsUniqSet
-                        $ nodeConflicts node
-                        -- See Note [Unique Determinism and code generation]
-
-        colors_conflict = mkUniqSet
-                        $ mapMaybe nodeColor nsConflicts
-
-        -- the prefs of our neighbors
-        colors_neighbor_prefs
-                        = mkUniqSet
-                        $ concatMap nodePreference nsConflicts
-
-        -- colors that are still valid for us
-        colors_ok_ex    = minusUniqSet colors_avail (nodeExclusions node)
-        colors_ok       = minusUniqSet colors_ok_ex colors_conflict
-
-        -- the colors that we prefer, and are still ok
-        colors_ok_pref  = intersectUniqSets
-                                (mkUniqSet $ nodePreference node) colors_ok
-
-        -- the colors that we could choose while being nice to our neighbors
-        colors_ok_nice  = minusUniqSet
-                                colors_ok colors_neighbor_prefs
-
-        -- the best of all possible worlds..
-        colors_ok_pref_nice
-                        = intersectUniqSets
-                                colors_ok_nice colors_ok_pref
-
-        -- make the decision
-        chooseColor
-
-                -- everyone is happy, yay!
-                | not $ isEmptyUniqSet colors_ok_pref_nice
-                , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice)
-                                        (nodePreference node)
-                = Just c
-
-                -- we've got one of our preferences
-                | not $ isEmptyUniqSet colors_ok_pref
-                , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref)
-                                        (nodePreference node)
-                = Just c
-
-                -- it wasn't a preference, but it was still ok
-                | not $ isEmptyUniqSet colors_ok
-                , c : _         <- nonDetEltsUniqSet colors_ok
-                -- See Note [Unique Determinism and code generation]
-                = Just c
-
-                -- no colors were available for us this time.
-                --      looks like we're going around the loop again..
-                | otherwise
-                = Nothing
-
-   in   chooseColor
-
-
-
diff --git a/compiler/GHC/Data/Graph/Inductive/Graph.hs b/compiler/GHC/Data/Graph/Inductive/Graph.hs
deleted file mode 100644
--- a/compiler/GHC/Data/Graph/Inductive/Graph.hs
+++ /dev/null
@@ -1,643 +0,0 @@
--- (c) 1999-2005 by Martin Erwig (see copyright at bottom)
--- | Static and Dynamic Inductive Graphs
---
--- Code is from Hackage `fgl` package version 5.7.0.3
---
-module GHC.Data.Graph.Inductive.Graph (
-    -- * General Type Defintions
-    -- ** Node and Edge Types
-    Node,LNode,UNode,
-    Edge,LEdge,UEdge,
-    -- ** Types Supporting Inductive Graph View
-    Adj,Context,MContext,Decomp,GDecomp,UContext,UDecomp,
-    Path,LPath(..),UPath,
-    -- * Graph Type Classes
-    -- | We define two graph classes:
-    --
-    --   Graph: static, decomposable graphs.
-    --    Static means that a graph itself cannot be changed
-    --
-    --   DynGraph: dynamic, extensible graphs.
-    --             Dynamic graphs inherit all operations from static graphs
-    --             but also offer operations to extend and change graphs.
-    --
-    -- Each class contains in addition to its essential operations those
-    -- derived operations that might be overwritten by a more efficient
-    -- implementation in an instance definition.
-    --
-    -- Note that labNodes is essentially needed because the default definition
-    -- for matchAny is based on it: we need some node from the graph to define
-    -- matchAny in terms of match. Alternatively, we could have made matchAny
-    -- essential and have labNodes defined in terms of ufold and matchAny.
-    -- However, in general, labNodes seems to be (at least) as easy to define
-    -- as matchAny. We have chosen labNodes instead of the function nodes since
-    -- nodes can be easily derived from labNodes, but not vice versa.
-    Graph(..),
-    DynGraph(..),
-    -- * Operations
-    order,
-    size,
-    -- ** Graph Folds and Maps
-    ufold,gmap,nmap,emap,nemap,
-    -- ** Graph Projection
-    nodes,edges,toEdge,edgeLabel,toLEdge,newNodes,gelem,
-    -- ** Graph Construction and Destruction
-    insNode,insEdge,delNode,delEdge,delLEdge,delAllLEdge,
-    insNodes,insEdges,delNodes,delEdges,
-    buildGr,mkUGraph,
-    -- ** Subgraphs
-    gfiltermap,nfilter,labnfilter,labfilter,subgraph,
-    -- ** Graph Inspection
-    context,lab,neighbors,lneighbors,
-    suc,pre,lsuc,lpre,
-    out,inn,outdeg,indeg,deg,
-    hasEdge,hasNeighbor,hasLEdge,hasNeighborAdj,
-    equal,
-    -- ** Context Inspection
-    node',lab',labNode',neighbors',lneighbors',
-    suc',pre',lpre',lsuc',
-    out',inn',outdeg',indeg',deg',
-    -- * Pretty-printing
-    prettify,
-    prettyPrint,
-    -- * Ordering of Graphs
-    OrdGr(..)
-) where
-
-import GHC.Prelude
-
-import           Control.Arrow (first)
-import           Data.Function (on)
-import qualified Data.IntSet   as IntSet
-import           Data.List     (delete, groupBy, sort, sortBy, (\\))
-import           Data.Maybe    (fromMaybe, isJust)
-
-import GHC.Utils.Panic
-
--- | Unlabeled node
-type  Node   = Int
--- | Labeled node
-type LNode a = (Node,a)
--- | Quasi-unlabeled node
-type UNode   = LNode ()
-
--- | Unlabeled edge
-type  Edge   = (Node,Node)
--- | Labeled edge
-type LEdge b = (Node,Node,b)
--- | Quasi-unlabeled edge
-type UEdge   = LEdge ()
-
--- | Unlabeled path
-type Path    = [Node]
--- | Labeled path
-newtype LPath a = LP { unLPath :: [LNode a] }
-
-instance (Show a) => Show (LPath a) where
-  show (LP xs) = show xs
-
-instance (Eq a) => Eq (LPath a) where
-  (LP [])        == (LP [])        = True
-  (LP ((_,x):_)) == (LP ((_,y):_)) = x==y
-  (LP _)         == (LP _)         = False
-
-instance (Ord a) => Ord (LPath a) where
-  compare (LP [])        (LP [])        = EQ
-  compare (LP ((_,x):_)) (LP ((_,y):_)) = compare x y
-  compare _ _ = panic "LPath: cannot compare two empty paths"
-
--- | Quasi-unlabeled path
-type UPath   = [UNode]
-
--- | Labeled links to or from a 'Node'.
-type Adj b        = [(b,Node)]
--- | Links to the 'Node', the 'Node' itself, a label, links from the 'Node'.
---
---   In other words, this captures all information regarding the
---   specified 'Node' within a graph.
-type Context a b  = (Adj b,Node,a,Adj b) -- Context a b "=" Context' a b "+" Node
-type MContext a b = Maybe (Context a b)
--- | 'Graph' decomposition - the context removed from a 'Graph', and the rest
--- of the 'Graph'.
-type Decomp g a b = (MContext a b,g a b)
--- | The same as 'Decomp', only more sure of itself.
-type GDecomp g a b  = (Context a b,g a b)
-
--- | Unlabeled context.
-type UContext     = ([Node],Node,[Node])
--- | Unlabeled decomposition.
-type UDecomp g    = (Maybe UContext,g)
-
--- | Minimum implementation: 'empty', 'isEmpty', 'match', 'mkGraph', 'labNodes'
-class Graph gr where
-  {-# MINIMAL empty, isEmpty, match, mkGraph, labNodes #-}
-
-  -- | An empty 'Graph'.
-  empty     :: gr a b
-
-  -- | True if the given 'Graph' is empty.
-  isEmpty   :: gr a b -> Bool
-
-  -- | Decompose a 'Graph' into the 'MContext' found for the given node and the
-  -- remaining 'Graph'.
-  match     :: Node -> gr a b -> Decomp gr a b
-
-  -- | Create a 'Graph' from the list of 'LNode's and 'LEdge's.
-  --
-  --   For graphs that are also instances of 'DynGraph', @mkGraph ns
-  --   es@ should be equivalent to @('insEdges' es . 'insNodes' ns)
-  --   'empty'@.
-  mkGraph   :: [LNode a] -> [LEdge b] -> gr a b
-
-  -- | A list of all 'LNode's in the 'Graph'.
-  labNodes  :: gr a b -> [LNode a]
-
-  -- | Decompose a graph into the 'Context' for an arbitrarily-chosen 'Node'
-  -- and the remaining 'Graph'.
-  matchAny  :: gr a b -> GDecomp gr a b
-  matchAny g = case labNodes g of
-                 []      -> panic "Match Exception, Empty Graph"
-                 (v,_):_ | (Just c,g') <- match v g -> (c,g')
-                 _       -> panic "This can't happen: failed to match node in graph"
-
-
-  -- | The number of 'Node's in a 'Graph'.
-  noNodes   :: gr a b -> Int
-  noNodes = length . labNodes
-
-  -- | The minimum and maximum 'Node' in a 'Graph'.
-  nodeRange :: gr a b -> (Node,Node)
-  nodeRange g
-    | isEmpty g = panic "nodeRange of empty graph"
-    | otherwise = (minimum vs, maximum vs)
-    where
-      vs = nodes g
-
-  -- | A list of all 'LEdge's in the 'Graph'.
-  labEdges  :: gr a b -> [LEdge b]
-  labEdges = ufold (\(_,v,_,s)->(map (\(l,w)->(v,w,l)) s ++)) []
-
-class (Graph gr) => DynGraph gr where
-  -- | Merge the 'Context' into the 'DynGraph'.
-  --
-  --   Context adjacencies should only refer to either a Node already
-  --   in a graph or the node in the Context itself (for loops).
-  --
-  --   Behaviour is undefined if the specified 'Node' already exists
-  --   in the graph.
-  (&) :: Context a b -> gr a b -> gr a b
-
-
--- | The number of nodes in the graph.  An alias for 'noNodes'.
-order :: (Graph gr) => gr a b -> Int
-order = noNodes
-
--- | The number of edges in the graph.
---
---   Note that this counts every edge found, so if you are
---   representing an unordered graph by having each edge mirrored this
---   will be incorrect.
---
---   If you created an unordered graph by either mirroring every edge
---   (including loops!) or using the @undir@ function in
---   "Data.Graph.Inductive.Basic" then you can safely halve the value
---   returned by this.
-size :: (Graph gr) => gr a b -> Int
-size = length . labEdges
-
--- | Fold a function over the graph by recursively calling 'match'.
-ufold :: (Graph gr) => (Context a b -> c -> c) -> c -> gr a b -> c
-ufold f u g
-  | isEmpty g = u
-  | otherwise = f c (ufold f u g')
-  where
-    (c,g') = matchAny g
-
--- | Map a function over the graph by recursively calling 'match'.
-gmap :: (DynGraph gr) => (Context a b -> Context c d) -> gr a b -> gr c d
-gmap f = ufold (\c->(f c&)) empty
-{-# NOINLINE [0] gmap #-}
-
--- | Map a function over the 'Node' labels in a graph.
-nmap :: (DynGraph gr) => (a -> c) -> gr a b -> gr c b
-nmap f = gmap (\(p,v,l,s)->(p,v,f l,s))
-{-# NOINLINE [0] nmap #-}
-
--- | Map a function over the 'Edge' labels in a graph.
-emap :: (DynGraph gr) => (b -> c) -> gr a b -> gr a c
-emap f = gmap (\(p,v,l,s)->(map1 f p,v,l,map1 f s))
-  where
-    map1 g = map (first g)
-{-# NOINLINE [0] emap #-}
-
--- | Map functions over both the 'Node' and 'Edge' labels in a graph.
-nemap :: (DynGraph gr) => (a -> c) -> (b -> d) -> gr a b -> gr c d
-nemap fn fe = gmap (\(p,v,l,s) -> (fe' p,v,fn l,fe' s))
-  where
-    fe' = map (first fe)
-{-# NOINLINE [0] nemap #-}
-
--- | List all 'Node's in the 'Graph'.
-nodes :: (Graph gr) => gr a b -> [Node]
-nodes = map fst . labNodes
-
--- | List all 'Edge's in the 'Graph'.
-edges :: (Graph gr) => gr a b -> [Edge]
-edges = map toEdge . labEdges
-
--- | Drop the label component of an edge.
-toEdge :: LEdge b -> Edge
-toEdge (v,w,_) = (v,w)
-
--- | Add a label to an edge.
-toLEdge :: Edge -> b -> LEdge b
-toLEdge (v,w) l = (v,w,l)
-
--- | The label in an edge.
-edgeLabel :: LEdge b -> b
-edgeLabel (_,_,l) = l
-
--- | List N available 'Node's, i.e. 'Node's that are not used in the 'Graph'.
-newNodes :: (Graph gr) => Int -> gr a b -> [Node]
-newNodes i g
-  | isEmpty g = [0..i-1]
-  | otherwise = [n+1..n+i]
-  where
-    (_,n) = nodeRange g
-
--- | 'True' if the 'Node' is present in the 'Graph'.
-gelem :: (Graph gr) => Node -> gr a b -> Bool
-gelem v = isJust . fst . match v
-
--- | Insert a 'LNode' into the 'Graph'.
-insNode :: (DynGraph gr) => LNode a -> gr a b -> gr a b
-insNode (v,l) = (([],v,l,[])&)
-{-# NOINLINE [0] insNode #-}
-
--- | Insert a 'LEdge' into the 'Graph'.
-insEdge :: (DynGraph gr) => LEdge b -> gr a b -> gr a b
-insEdge (v,w,l) g = (pr,v,la,(l,w):su) & g'
-  where
-    (mcxt,g') = match v g
-    (pr,_,la,su) = fromMaybe
-                     (panic ("insEdge: cannot add edge from non-existent vertex " ++ show v))
-                     mcxt
-{-# NOINLINE [0] insEdge #-}
-
--- | Remove a 'Node' from the 'Graph'.
-delNode :: (Graph gr) => Node -> gr a b -> gr a b
-delNode v = delNodes [v]
-
--- | Remove an 'Edge' from the 'Graph'.
---
---   NOTE: in the case of multiple edges, this will delete /all/ such
---   edges from the graph as there is no way to distinguish between
---   them.  If you need to delete only a single such edge, please use
---   'delLEdge'.
-delEdge :: (DynGraph gr) => Edge -> gr a b -> gr a b
-delEdge (v,w) g = case match v g of
-                    (Nothing,_)          -> g
-                    (Just (p,v',l,s),g') -> (p,v',l,filter ((/=w).snd) s) & g'
-
--- | Remove an 'LEdge' from the 'Graph'.
---
---   NOTE: in the case of multiple edges with the same label, this
---   will only delete the /first/ such edge.  To delete all such
---   edges, please use 'delAllLedge'.
-delLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b
-delLEdge = delLEdgeBy delete
-
--- | Remove all edges equal to the one specified.
-delAllLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b
-delAllLEdge = delLEdgeBy (filter . (/=))
-
-delLEdgeBy :: (DynGraph gr) => ((b,Node) -> Adj b -> Adj b)
-              -> LEdge b -> gr a b -> gr a b
-delLEdgeBy f (v,w,b) g = case match v g of
-                           (Nothing,_)          -> g
-                           (Just (p,v',l,s),g') -> (p,v',l,f (b,w) s) & g'
-
--- | Insert multiple 'LNode's into the 'Graph'.
-insNodes   :: (DynGraph gr) => [LNode a] -> gr a b -> gr a b
-insNodes vs g = foldl' (flip insNode) g vs
-{-# INLINABLE insNodes #-}
-
--- | Insert multiple 'LEdge's into the 'Graph'.
-insEdges :: (DynGraph gr) => [LEdge b] -> gr a b -> gr a b
-insEdges es g = foldl' (flip insEdge) g es
-{-# INLINABLE insEdges #-}
-
--- | Remove multiple 'Node's from the 'Graph'.
-delNodes :: (Graph gr) => [Node] -> gr a b -> gr a b
-delNodes vs g = foldl' (snd .: flip match) g vs
-
--- | Remove multiple 'Edge's from the 'Graph'.
-delEdges :: (DynGraph gr) => [Edge] -> gr a b -> gr a b
-delEdges es g = foldl' (flip delEdge) g es
-
--- | Build a 'Graph' from a list of 'Context's.
---
---   The list should be in the order such that earlier 'Context's
---   depend upon later ones (i.e. as produced by @'ufold' (:) []@).
-buildGr :: (DynGraph gr) => [Context a b] -> gr a b
-buildGr = foldr (&) empty
-
--- | Build a quasi-unlabeled 'Graph'.
-mkUGraph :: (Graph gr) => [Node] -> [Edge] -> gr () ()
-mkUGraph vs es = mkGraph (labUNodes vs) (labUEdges es)
-   where
-     labUEdges = map (`toLEdge` ())
-     labUNodes = map (flip (,) ())
-
--- | Build a graph out of the contexts for which the predicate is
--- satisfied by recursively calling 'match'.
-gfiltermap :: DynGraph gr => (Context a b -> MContext c d) -> gr a b -> gr c d
-gfiltermap f = ufold (maybe id (&) . f) empty
-
--- | Returns the subgraph only containing the labelled nodes which
--- satisfy the given predicate.
-labnfilter :: Graph gr => (LNode a -> Bool) -> gr a b -> gr a b
-labnfilter p gr = delNodes (map fst . filter (not . p) $ labNodes gr) gr
-
--- | Returns the subgraph only containing the nodes which satisfy the
--- given predicate.
-nfilter :: DynGraph gr => (Node -> Bool) -> gr a b -> gr a b
-nfilter f = labnfilter (f . fst)
-
--- | Returns the subgraph only containing the nodes whose labels
--- satisfy the given predicate.
-labfilter :: DynGraph gr => (a -> Bool) -> gr a b -> gr a b
-labfilter f = labnfilter (f . snd)
-
--- | Returns the subgraph induced by the supplied nodes.
-subgraph :: DynGraph gr => [Node] -> gr a b -> gr a b
-subgraph vs = let vs' = IntSet.fromList vs
-              in nfilter (`IntSet.member` vs')
-
--- | Find the context for the given 'Node'.  Causes an error if the 'Node' is
--- not present in the 'Graph'.
-context :: (Graph gr) => gr a b -> Node -> Context a b
-context g v = fromMaybe (panic ("Match Exception, Node: "++show v))
-                        (fst (match v g))
-
--- | Find the label for a 'Node'.
-lab :: (Graph gr) => gr a b -> Node -> Maybe a
-lab g v = fmap lab' . fst $ match v g
-
--- | Find the neighbors for a 'Node'.
-neighbors :: (Graph gr) => gr a b -> Node -> [Node]
-neighbors = map snd .: lneighbors
-
--- | Find the labelled links coming into or going from a 'Context'.
-lneighbors :: (Graph gr) => gr a b -> Node -> Adj b
-lneighbors = maybe [] lneighbors' .: mcontext
-
--- | Find all 'Node's that have a link from the given 'Node'.
-suc :: (Graph gr) => gr a b -> Node -> [Node]
-suc = map snd .: context4l
-
--- | Find all 'Node's that link to to the given 'Node'.
-pre :: (Graph gr) => gr a b -> Node -> [Node]
-pre = map snd .: context1l
-
--- | Find all 'Node's that are linked from the given 'Node' and the label of
--- each link.
-lsuc :: (Graph gr) => gr a b -> Node -> [(Node,b)]
-lsuc = map flip2 .: context4l
-
--- | Find all 'Node's that link to the given 'Node' and the label of each link.
-lpre :: (Graph gr) => gr a b -> Node -> [(Node,b)]
-lpre = map flip2 .: context1l
-
--- | Find all outward-bound 'LEdge's for the given 'Node'.
-out :: (Graph gr) => gr a b -> Node -> [LEdge b]
-out g v = map (\(l,w)->(v,w,l)) (context4l g v)
-
--- | Find all inward-bound 'LEdge's for the given 'Node'.
-inn :: (Graph gr) => gr a b -> Node -> [LEdge b]
-inn g v = map (\(l,w)->(w,v,l)) (context1l g v)
-
--- | The outward-bound degree of the 'Node'.
-outdeg :: (Graph gr) => gr a b -> Node -> Int
-outdeg = length .: context4l
-
--- | The inward-bound degree of the 'Node'.
-indeg :: (Graph gr) => gr a b -> Node -> Int
-indeg  = length .: context1l
-
--- | The degree of the 'Node'.
-deg :: (Graph gr) => gr a b -> Node -> Int
-deg = deg' .: context
-
--- | The 'Node' in a 'Context'.
-node' :: Context a b -> Node
-node' (_,v,_,_) = v
-
--- | The label in a 'Context'.
-lab' :: Context a b -> a
-lab' (_,_,l,_) = l
-
--- | The 'LNode' from a 'Context'.
-labNode' :: Context a b -> LNode a
-labNode' (_,v,l,_) = (v,l)
-
--- | All 'Node's linked to or from in a 'Context'.
-neighbors' :: Context a b -> [Node]
-neighbors' (p,_,_,s) = map snd p++map snd s
-
--- | All labelled links coming into or going from a 'Context'.
-lneighbors' :: Context a b -> Adj b
-lneighbors' (p,_,_,s) = p ++ s
-
--- | All 'Node's linked to in a 'Context'.
-suc' :: Context a b -> [Node]
-suc' = map snd . context4l'
-
--- | All 'Node's linked from in a 'Context'.
-pre' :: Context a b -> [Node]
-pre' = map snd . context1l'
-
--- | All 'Node's linked from in a 'Context', and the label of the links.
-lsuc' :: Context a b -> [(Node,b)]
-lsuc' = map flip2 . context4l'
-
--- | All 'Node's linked from in a 'Context', and the label of the links.
-lpre' :: Context a b -> [(Node,b)]
-lpre' = map flip2 . context1l'
-
--- | All outward-directed 'LEdge's in a 'Context'.
-out' :: Context a b -> [LEdge b]
-out' c@(_,v,_,_) = map (\(l,w)->(v,w,l)) (context4l' c)
-
--- | All inward-directed 'LEdge's in a 'Context'.
-inn' :: Context a b -> [LEdge b]
-inn' c@(_,v,_,_) = map (\(l,w)->(w,v,l)) (context1l' c)
-
--- | The outward degree of a 'Context'.
-outdeg' :: Context a b -> Int
-outdeg' = length . context4l'
-
--- | The inward degree of a 'Context'.
-indeg' :: Context a b -> Int
-indeg' = length . context1l'
-
--- | The degree of a 'Context'.
-deg' :: Context a b -> Int
-deg' (p,_,_,s) = length p+length s
-
--- | Checks if there is a directed edge between two nodes.
-hasEdge :: Graph gr => gr a b -> Edge -> Bool
-hasEdge gr (v,w) = w `elem` suc gr v
-
--- | Checks if there is an undirected edge between two nodes.
-hasNeighbor :: Graph gr => gr a b -> Node -> Node -> Bool
-hasNeighbor gr v w = w `elem` neighbors gr v
-
--- | Checks if there is a labelled edge between two nodes.
-hasLEdge :: (Graph gr, Eq b) => gr a b -> LEdge b -> Bool
-hasLEdge gr (v,w,l) = (w,l) `elem` lsuc gr v
-
--- | Checks if there is an undirected labelled edge between two nodes.
-hasNeighborAdj :: (Graph gr, Eq b) => gr a b -> Node -> (b,Node) -> Bool
-hasNeighborAdj gr v a = a `elem` lneighbors gr v
-
-----------------------------------------------------------------------
--- GRAPH EQUALITY
-----------------------------------------------------------------------
-
-slabNodes :: (Graph gr) => gr a b -> [LNode a]
-slabNodes = sortBy (compare `on` fst) . labNodes
-
-glabEdges :: (Graph gr) => gr a b -> [GroupEdges b]
-glabEdges = map (GEs . groupLabels)
-            . groupBy ((==) `on` toEdge)
-            . sortBy (compare `on` toEdge)
-            . labEdges
-  where
-    groupLabels les = toLEdge (toEdge (head les)) (map edgeLabel les)
-
-equal :: (Eq a,Eq b,Graph gr) => gr a b -> gr a b -> Bool
-equal g g' = slabNodes g == slabNodes g' && glabEdges g == glabEdges g'
--- This assumes that nodes aren't repeated (which shouldn't happen for
--- sane graph instances).  If node IDs are repeated, then the usage of
--- slabNodes cannot guarantee stable ordering.
-
--- Newtype wrapper just to test for equality of multiple edges.  This
--- is needed because without an Ord constraint on `b' it is not
--- possible to guarantee a stable ordering on edge labels.
-newtype GroupEdges b = GEs (LEdge [b])
-  deriving (Show, Read)
-
-instance (Eq b) => Eq (GroupEdges b) where
-  (GEs (v1,w1,bs1)) == (GEs (v2,w2,bs2)) = v1 == v2
-                                           && w1 == w2
-                                           && eqLists bs1 bs2
-
-eqLists :: (Eq a) => [a] -> [a] -> Bool
-eqLists xs ys = null (xs \\ ys) && null (ys \\ xs)
--- OK to use \\ here as we want each value in xs to cancel a *single*
--- value in ys.
-
-----------------------------------------------------------------------
--- UTILITIES
-----------------------------------------------------------------------
-
--- auxiliary functions used in the implementation of the
--- derived class members
---
-(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
--- f .: g = \x y->f (g x y)
--- f .: g = (f .) . g
--- (.:) f = ((f .) .)
--- (.:) = (.) (.) (.)
-(.:) = (.) . (.)
-
-flip2 :: (a,b) -> (b,a)
-flip2 (x,y) = (y,x)
-
--- projecting on context elements
---
-context1l :: (Graph gr) => gr a b -> Node -> Adj b
-context1l = maybe [] context1l' .: mcontext
-
-context4l :: (Graph gr) => gr a b -> Node -> Adj b
-context4l = maybe [] context4l' .: mcontext
-
-mcontext :: (Graph gr) => gr a b -> Node -> MContext a b
-mcontext = fst .: flip match
-
-context1l' :: Context a b -> Adj b
-context1l' (p,v,_,s) = p++filter ((==v).snd) s
-
-context4l' :: Context a b -> Adj b
-context4l' (p,v,_,s) = s++filter ((==v).snd) p
-
-----------------------------------------------------------------------
--- PRETTY PRINTING
-----------------------------------------------------------------------
-
--- | Pretty-print the graph.  Note that this loses a lot of
---   information, such as edge inverses, etc.
-prettify :: (DynGraph gr, Show a, Show b) => gr a b -> String
-prettify g = foldr (showsContext . context g) id (nodes g) ""
-  where
-    showsContext (_,n,l,s) sg = shows n . (':':) . shows l
-                                . showString "->" . shows s
-                                . ('\n':) . sg
-
--- | Pretty-print the graph to stdout.
-prettyPrint :: (DynGraph gr, Show a, Show b) => gr a b -> IO ()
-prettyPrint = putStr . prettify
-
-----------------------------------------------------------------------
--- Ordered Graph
-----------------------------------------------------------------------
-
--- | OrdGr comes equipped with an Ord instance, so that graphs can be
---   used as e.g. Map keys.
-newtype OrdGr gr a b = OrdGr { unOrdGr :: gr a b }
-  deriving (Read,Show)
-
-instance (Graph gr, Ord a, Ord b) => Eq (OrdGr gr a b) where
-  g1 == g2 = compare g1 g2 == EQ
-
-instance (Graph gr, Ord a, Ord b) => Ord (OrdGr gr a b) where
-  compare (OrdGr g1) (OrdGr g2) =
-    (compare `on` sort . labNodes) g1 g2
-    `mappend` (compare `on` sort . labEdges) g1 g2
-
-
-{-----------------------------------------------------------------
-
-Copyright (c) 1999-2008, Martin Erwig
-              2010, Ivan Lazar Miljenovic
-              2022, Norman Ramsey
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
-1. Redistributions of source code must retain the above copyright notice,
-   this list of conditions and the following disclaimer.
-
-2. Redistributions in binary form must reproduce the above copyright
-   notice, this list of conditions and the following disclaimer in the
-   documentation and/or other materials provided with the distribution.
-
-3. Neither the name of the author nor the names of its contributors may be
-   used to endorse or promote products derived from this software without
-   specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
-LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-POSSIBILITY OF SUCH DAMAGE.
-
-----------------------------------------------------------------}
diff --git a/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs b/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs
deleted file mode 100644
--- a/compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs
+++ /dev/null
@@ -1,343 +0,0 @@
-{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
-{-# LANGUAGE DeriveGeneric #-}
-
--- |An efficient implementation of 'Data.Graph.Inductive.Graph.Graph'
--- using big-endian patricia tree (i.e. "Data.IntMap").
---
--- This module provides the following specialised functions to gain
--- more performance, using GHC's RULES pragma:
---
--- * 'Data.Graph.Inductive.Graph.insNode'
---
--- * 'Data.Graph.Inductive.Graph.insEdge'
---
--- * 'Data.Graph.Inductive.Graph.gmap'
---
--- * 'Data.Graph.Inductive.Graph.nmap'
---
--- * 'Data.Graph.Inductive.Graph.emap'
---
--- Code is from Hackage `fgl` package version 5.7.0.3
-
-
-module GHC.Data.Graph.Inductive.PatriciaTree
-    ( Gr
-    , UGr
-    )
-    where
-
-import GHC.Prelude
-
-import GHC.Data.Graph.Inductive.Graph
-
-import           Data.IntMap         (IntMap)
-import qualified Data.IntMap         as IM
-import           Data.List           (sort)
-import           Data.Maybe          (fromMaybe)
-import           Data.Tuple          (swap)
-
-import qualified Data.IntMap.Strict as IMS
-
-import GHC.Generics (Generic)
-
-import Data.Bifunctor
-
-----------------------------------------------------------------------
--- GRAPH REPRESENTATION
-----------------------------------------------------------------------
-
-newtype Gr a b = Gr (GraphRep a b)
-  deriving (Generic)
-
-type GraphRep a b = IntMap (Context' a b)
-type Context' a b = (IntMap [b], a, IntMap [b])
-
-type UGr = Gr () ()
-
-----------------------------------------------------------------------
--- CLASS INSTANCES
-----------------------------------------------------------------------
-
-instance (Eq a, Ord b) => Eq (Gr a b) where
-  (Gr g1) == (Gr g2) = fmap sortAdj g1 == fmap sortAdj g2
-    where
-      sortAdj (p,n,s) = (fmap sort p,n,fmap sort s)
-
-instance (Show a, Show b) => Show (Gr a b) where
-  showsPrec d g = showParen (d > 10) $
-                    showString "mkGraph "
-                    . shows (labNodes g)
-                    . showString " "
-                    . shows (labEdges g)
-
-instance (Read a, Read b) => Read (Gr a b) where
-  readsPrec p = readParen (p > 10) $ \ r -> do
-    ("mkGraph", s) <- lex r
-    (ns,t) <- reads s
-    (es,u) <- reads t
-    return (mkGraph ns es, u)
-
-instance Graph Gr where
-    empty           = Gr IM.empty
-
-    isEmpty (Gr g)  = IM.null g
-
-    match           = matchGr
-
-    mkGraph vs es   = insEdges es
-                      . Gr
-                      . IM.fromList
-                      . map (second (\l -> (IM.empty,l,IM.empty)))
-                      $ vs
-
-    labNodes (Gr g) = [ (node, label)
-                            | (node, (_, label, _)) <- IM.toList g ]
-
-    noNodes   (Gr g) = IM.size g
-
-    nodeRange (Gr g) = fromMaybe (error "nodeRange of empty graph")
-                       $ liftA2 (,) (ix (IM.minViewWithKey g))
-                                    (ix (IM.maxViewWithKey g))
-      where
-        ix = fmap (fst . fst)
-
-    labEdges (Gr g) = do (node, (_, _, s)) <- IM.toList g
-                         (next, labels)    <- IM.toList s
-                         label             <- labels
-                         return (node, next, label)
-
-instance DynGraph Gr where
-    (p, v, l, s) & (Gr g)
-        = let !g1 = IM.insert v (preds, l, succs) g
-              !(np, preds) = fromAdjCounting p
-              !(ns, succs) = fromAdjCounting s
-              !g2 = addSucc g1 v np preds
-              !g3 = addPred g2 v ns succs
-          in Gr g3
-
-
-instance Bifunctor Gr where
-  bimap = fastNEMap
-
-  first = fastNMap
-
-  second = fastEMap
-
-
-matchGr :: Node -> Gr a b -> Decomp Gr a b
-matchGr node (Gr g)
-    = case IM.lookup node g of
-        Nothing
-            -> (Nothing, Gr g)
-
-        Just (p, label, s)
-            -> let !g1 = IM.delete node g
-                   !p' = IM.delete node p
-                   !s' = IM.delete node s
-                   !g2 = clearPred g1 node s'
-                   !g3 = clearSucc g2 node p'
-               in (Just (toAdj p', node, label, toAdj s), Gr g3)
-
-----------------------------------------------------------------------
--- OVERRIDING FUNCTIONS
-----------------------------------------------------------------------
-
-{-
-
-{- RULES
-      "insNode/Data.Graph.Inductive.PatriciaTree"  insNode = fastInsNode
-  -}
-fastInsNode :: LNode a -> Gr a b -> Gr a b
-fastInsNode (v, l) (Gr g) = g' `seq` Gr g'
-  where
-    g' = IM.insert v (IM.empty, l, IM.empty) g
-
--}
-{-# RULES
-      "insEdge/GHC.Data.Graph.Inductive.PatriciaTree"  insEdge = fastInsEdge
-  #-}
-fastInsEdge :: LEdge b -> Gr a b -> Gr a b
-fastInsEdge (v, w, l) (Gr g) = g2 `seq` Gr g2
-  where
-    g1 = IM.adjust addS' v g
-    g2 = IM.adjust addP' w g1
-
-    addS' (ps, l', ss) = (ps, l', IM.insertWith addLists w [l] ss)
-    addP' (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss)
-
-{-
-
-{- RULES
-      "gmap/Data.Graph.Inductive.PatriciaTree"  gmap = fastGMap
-  -}
-fastGMap :: forall a b c d. (Context a b -> Context c d) -> Gr a b -> Gr c d
-fastGMap f (Gr g) = Gr (IM.mapWithKey f' g)
-  where
-    f' :: Node -> Context' a b -> Context' c d
-    f' = ((fromContext . f) .) . toContext
-
-{- RULES
-      "nmap/Data.Graph.Inductive.PatriciaTree"  nmap = fastNMap
-  -}
--}
-fastNMap :: forall a b c. (a -> c) -> Gr a b -> Gr c b
-fastNMap f (Gr g) = Gr (IM.map f' g)
-  where
-    f' :: Context' a b -> Context' c b
-    f' (ps, a, ss) = (ps, f a, ss)
-{-
-
-{- RULES
-      "emap/GHC.Data.Graph.Inductive.PatriciaTree"  emap = fastEMap
-   -}
--}
-fastEMap :: forall a b c. (b -> c) -> Gr a b -> Gr a c
-fastEMap f (Gr g) = Gr (IM.map f' g)
-  where
-    f' :: Context' a b -> Context' a c
-    f' (ps, a, ss) = (IM.map (map f) ps, a, IM.map (map f) ss)
-
-{-  RULES
-      "nemap/GHC.Data.Graph.Inductive.PatriciaTree"  nemap = fastNEMap
-   -}
-
-fastNEMap :: forall a b c d. (a -> c) -> (b -> d) -> Gr a b -> Gr c d
-fastNEMap fn fe (Gr g) = Gr (IM.map f g)
-  where
-    f :: Context' a b -> Context' c d
-    f (ps, a, ss) = (IM.map (map fe) ps, fn a, IM.map (map fe) ss)
-
-
-
-----------------------------------------------------------------------
--- UTILITIES
-----------------------------------------------------------------------
-
-toAdj :: IntMap [b] -> Adj b
-toAdj = concatMap expand . IM.toList
-  where
-    expand (n,ls) = map (flip (,) n) ls
-
---fromAdj :: Adj b -> IntMap [b]
---fromAdj = IM.fromListWith addLists . map (second (:[]) . swap)
-
-data FromListCounting a = FromListCounting !Int !(IntMap a)
-  deriving (Eq, Show, Read)
-
-getFromListCounting :: FromListCounting a -> (Int, IntMap a)
-getFromListCounting (FromListCounting i m) = (i, m)
-{-# INLINE getFromListCounting #-}
-
-fromListWithKeyCounting :: (Int -> a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)
-fromListWithKeyCounting f = getFromListCounting . foldl' ins (FromListCounting 0 IM.empty)
-  where
-    ins (FromListCounting i t) (k,x) = FromListCounting (i + 1) (IM.insertWithKey f k x t)
-{-# INLINE fromListWithKeyCounting #-}
-
-fromListWithCounting :: (a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)
-fromListWithCounting f = fromListWithKeyCounting (\_ x y -> f x y)
-{-# INLINE fromListWithCounting #-}
-
-fromAdjCounting :: Adj b -> (Int, IntMap [b])
-fromAdjCounting = fromListWithCounting addLists . map (second (:[]) . swap)
-
--- We use differenceWith to modify a graph more than bulkThreshold times,
--- and repeated insertWith otherwise.
-bulkThreshold :: Int
-bulkThreshold = 5
-
---toContext :: Node -> Context' a b -> Context a b
---toContext v (ps, a, ss) = (toAdj ps, v, a, toAdj ss)
-
---fromContext :: Context a b -> Context' a b
---fromContext (ps, _, a, ss) = (fromAdj ps, a, fromAdj ss)
-
--- A version of @++@ where order isn't important, so @xs ++ [x]@
--- becomes @x:xs@.  Used when we have to have a function of type @[a]
--- -> [a] -> [a]@ but one of the lists is just going to be a single
--- element (and it isn't possible to tell which).
-addLists :: [a] -> [a] -> [a]
-addLists [a] as  = a : as
-addLists as  [a] = a : as
-addLists xs  ys  = xs ++ ys
-
-addSucc :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b
-addSucc g0 v numAdd xs
-  | numAdd < bulkThreshold = foldlWithKey' go g0 xs
-  where
-    go :: GraphRep a b -> Node -> [b] -> GraphRep a b
-    go g p l = IMS.adjust f p g
-      where f (ps, l', ss) = let !ss' = IM.insertWith addLists v l ss
-                             in (ps, l', ss')
-addSucc g v _ xs = IMS.differenceWith go g xs
-  where
-    go :: Context' a b -> [b] -> Maybe (Context' a b)
-    go (ps, l', ss) l = let !ss' = IM.insertWith addLists v l ss
-                        in Just (ps, l', ss')
-
-foldlWithKey' :: (a -> IM.Key -> b -> a) -> a -> IntMap b -> a
-foldlWithKey' =
-  IM.foldlWithKey'
-
-addPred :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b
-addPred g0 v numAdd xs
-  | numAdd < bulkThreshold = foldlWithKey' go g0 xs
-  where
-    go :: GraphRep a b -> Node -> [b] -> GraphRep a b
-    go g p l = IMS.adjust f p g
-      where f (ps, l', ss) = let !ps' = IM.insertWith addLists v l ps
-                             in (ps', l', ss)
-addPred g v _ xs = IMS.differenceWith go g xs
-  where
-    go :: Context' a b -> [b] -> Maybe (Context' a b)
-    go (ps, l', ss) l = let !ps' = IM.insertWith addLists v l ps
-                        in Just (ps', l', ss)
-
-clearSucc :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b
-clearSucc g v = IMS.differenceWith go g
-  where
-    go :: Context' a b -> x -> Maybe (Context' a b)
-    go (ps, l, ss) _ = let !ss' = IM.delete v ss
-                       in Just (ps, l, ss')
-
-clearPred :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b
-clearPred g v = IMS.differenceWith go g
-  where
-    go :: Context' a b -> x -> Maybe (Context' a b)
-    go (ps, l, ss) _ = let !ps' = IM.delete v ps
-                       in Just (ps', l, ss)
-
-{-----------------------------------------------------------------
-
-Copyright (c) 1999-2008, Martin Erwig
-              2010, Ivan Lazar Miljenovic
-              2022, Norman Ramsey
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
-1. Redistributions of source code must retain the above copyright notice,
-   this list of conditions and the following disclaimer.
-
-2. Redistributions in binary form must reproduce the above copyright
-   notice, this list of conditions and the following disclaimer in the
-   documentation and/or other materials provided with the distribution.
-
-3. Neither the name of the author nor the names of its contributors may be
-   used to endorse or promote products derived from this software without
-   specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
-LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-POSSIBILITY OF SUCH DAMAGE.
-
-----------------------------------------------------------------}
diff --git a/compiler/GHC/Data/Graph/Ops.hs b/compiler/GHC/Data/Graph/Ops.hs
deleted file mode 100644
--- a/compiler/GHC/Data/Graph/Ops.hs
+++ /dev/null
@@ -1,699 +0,0 @@
--- | Basic operations on graphs.
---
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module GHC.Data.Graph.Ops
-   ( addNode
-   , delNode
-   , getNode
-   , lookupNode
-   , modNode
-
-   , size
-   , union
-
-   , addConflict
-   , delConflict
-   , addConflicts
-
-   , addCoalesce
-   , delCoalesce
-
-   , addExclusion
-   , addExclusions
-
-   , addPreference
-   , coalesceNodes
-   , coalesceGraph
-   , freezeNode
-   , freezeOneInGraph
-   , freezeAllInGraph
-   , scanGraph
-   , setColor
-   , validateGraph
-   , slurpNodeConflictCount
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Data.Graph.Base
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Types.Unique
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.FM
-
-import Data.List (mapAccumL, sortBy)
-import Data.Maybe
-
--- | Lookup a node from the graph.
-lookupNode
-        :: Uniquable k
-        => Graph k cls color
-        -> k -> Maybe (Node  k cls color)
-
-lookupNode graph k
-        = lookupUFM (graphMap graph) k
-
-
--- | Get a node from the graph, throwing an error if it's not there
-getNode
-        :: Uniquable k
-        => Graph k cls color
-        -> k -> Node k cls color
-
-getNode graph k
- = case lookupUFM (graphMap graph) k of
-        Just node       -> node
-        Nothing         -> panic "ColorOps.getNode: not found"
-
-
--- | Add a node to the graph, linking up its edges
-addNode :: Uniquable k
-        => k -> Node k cls color
-        -> Graph k cls color -> Graph k cls color
-
-addNode k node graph
- = let
-        -- add back conflict edges from other nodes to this one
-        map_conflict =
-          nonDetStrictFoldUniqSet
-            -- It's OK to use a non-deterministic fold here because the
-            -- operation is commutative
-            (adjustUFM_C (\n -> n { nodeConflicts =
-                                      addOneToUniqSet (nodeConflicts n) k}))
-            (graphMap graph)
-            (nodeConflicts node)
-
-        -- add back coalesce edges from other nodes to this one
-        map_coalesce =
-          nonDetStrictFoldUniqSet
-            -- It's OK to use a non-deterministic fold here because the
-            -- operation is commutative
-            (adjustUFM_C (\n -> n { nodeCoalesce =
-                                      addOneToUniqSet (nodeCoalesce n) k}))
-            map_conflict
-            (nodeCoalesce node)
-
-  in    graph
-        { graphMap      = addToUFM map_coalesce k node}
-
-
--- | Delete a node and all its edges from the graph.
-delNode :: (Uniquable k)
-        => k -> Graph k cls color -> Maybe (Graph k cls color)
-
-delNode k graph
-        | Just node     <- lookupNode graph k
-        = let   -- delete conflict edges from other nodes to this one.
-                graph1  = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
-                        $ nonDetEltsUniqSet (nodeConflicts node)
-
-                -- delete coalesce edge from other nodes to this one.
-                graph2  = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
-                        $ nonDetEltsUniqSet (nodeCoalesce node)
-                        -- See Note [Unique Determinism and code generation]
-
-                -- delete the node
-                graph3  = graphMapModify (\fm -> delFromUFM fm k) graph2
-
-          in    Just graph3
-
-        | otherwise
-        = Nothing
-
-
--- | Modify a node in the graph.
---      returns Nothing if the node isn't present.
---
-modNode :: Uniquable k
-        => (Node k cls color -> Node k cls color)
-        -> k -> Graph k cls color -> Maybe (Graph k cls color)
-
-modNode f k graph
- = case lookupNode graph k of
-        Just Node{}
-         -> Just
-         $  graphMapModify
-                 (\fm   -> let  Just node       = lookupUFM fm k
-                                node'           = f node
-                           in   addToUFM fm k node')
-                graph
-
-        Nothing -> Nothing
-
-
--- | Get the size of the graph, O(n)
-size    :: Graph k cls color -> Int
-
-size graph
-        = sizeUFM $ graphMap graph
-
-
--- | Union two graphs together.
-union   :: Graph k cls color -> Graph k cls color -> Graph k cls color
-
-union   graph1 graph2
-        = Graph
-        { graphMap              = plusUFM (graphMap graph1) (graphMap graph2) }
-
-
--- | Add a conflict between nodes to the graph, creating the nodes required.
---      Conflicts are virtual regs which need to be colored differently.
-addConflict
-        :: Uniquable k
-        => (k, cls) -> (k, cls)
-        -> Graph k cls color -> Graph k cls color
-
-addConflict (u1, c1) (u2, c2)
- = let  addNeighbor u c u'
-                = adjustWithDefaultUFM
-                        (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
-                        (newNode u c)  { nodeConflicts = unitUniqSet u' }
-                        u
-
-   in   graphMapModify
-        ( addNeighbor u1 c1 u2
-        . addNeighbor u2 c2 u1)
-
-
--- | Delete a conflict edge. k1 -> k2
---      returns Nothing if the node isn't in the graph
-delConflict
-        :: Uniquable k
-        => k -> k
-        -> Graph k cls color -> Maybe (Graph k cls color)
-
-delConflict k1 k2
-        = modNode
-                (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
-                k1
-
-
--- | Add some conflicts to the graph, creating nodes if required.
---      All the nodes in the set are taken to conflict with each other.
-addConflicts
-        :: Uniquable k
-        => UniqSet k -> (k -> cls)
-        -> Graph k cls color -> Graph k cls color
-
-addConflicts conflicts getClass
-
-        -- just a single node, but no conflicts, create the node anyway.
-        | (u : [])      <- nonDetEltsUniqSet conflicts
-        = graphMapModify
-        $ adjustWithDefaultUFM
-                id
-                (newNode u (getClass u))
-                u
-
-        | otherwise
-        = graphMapModify
-        $ \fm -> foldl' (\g u  -> addConflictSet1 u getClass conflicts g) fm
-                $ nonDetEltsUniqSet conflicts
-                -- See Note [Unique Determinism and code generation]
-
-
-addConflictSet1 :: Uniquable k
-                => k -> (k -> cls) -> UniqSet k
-                -> UniqFM k (Node k cls color)
-                -> UniqFM k (Node k cls color)
-addConflictSet1 u getClass set
- = case delOneFromUniqSet set u of
-    set' -> adjustWithDefaultUFM
-                (\node -> node                  { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
-                (newNode u (getClass u))        { nodeConflicts = set' }
-                u
-
-
--- | Add an exclusion to the graph, creating nodes if required.
---      These are extra colors that the node cannot use.
-addExclusion
-        :: (Uniquable k, Uniquable color)
-        => k -> (k -> cls) -> color
-        -> Graph k cls color -> Graph k cls color
-
-addExclusion u getClass color
-        = graphMapModify
-        $ adjustWithDefaultUFM
-                (\node -> node                  { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
-                (newNode u (getClass u))        { nodeExclusions = unitUniqSet color }
-                u
-
-addExclusions
-        :: (Uniquable k, Uniquable color)
-        => k -> (k -> cls) -> [color]
-        -> Graph k cls color -> Graph k cls color
-
-addExclusions u getClass colors graph
-        = foldr (addExclusion u getClass) graph colors
-
-
--- | Add a coalescence edge to the graph, creating nodes if required.
---      It is considered advantageous to assign the same color to nodes in a coalescence.
-addCoalesce
-        :: Uniquable k
-        => (k, cls) -> (k, cls)
-        -> Graph k cls color -> Graph k cls color
-
-addCoalesce (u1, c1) (u2, c2)
- = let  addCoalesce u c u'
-         =      adjustWithDefaultUFM
-                        (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })
-                        (newNode u c)  { nodeCoalesce = unitUniqSet u' }
-                        u
-
-   in   graphMapModify
-        ( addCoalesce u1 c1 u2
-        . addCoalesce u2 c2 u1)
-
-
--- | Delete a coalescence edge (k1 -> k2) from the graph.
-delCoalesce
-        :: Uniquable k
-        => k -> k
-        -> Graph k cls color    -> Maybe (Graph k cls color)
-
-delCoalesce k1 k2
-        = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
-                k1
-
-
--- | Add a color preference to the graph, creating nodes if required.
---      The most recently added preference is the most preferred.
---      The algorithm tries to assign a node it's preferred color if possible.
---
-addPreference
-        :: Uniquable k
-        => (k, cls) -> color
-        -> Graph k cls color -> Graph k cls color
-
-addPreference (u, c) color
-        = graphMapModify
-        $ adjustWithDefaultUFM
-                (\node -> node { nodePreference = color : (nodePreference node) })
-                (newNode u c)  { nodePreference = [color] }
-                u
-
-
--- | Do aggressive coalescing on this graph.
---      returns the new graph and the list of pairs of nodes that got coalesced together.
---      for each pair, the resulting node will have the least key and be second in the pair.
---
-coalesceGraph
-        :: (Uniquable k, Ord k, Eq cls, Outputable k)
-        => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
-                                --      less colorable (aggressive coalescing)
-        -> Triv k cls color
-        -> Graph k cls color
-        -> ( Graph k cls color
-           , [(k, k)])          -- pairs of nodes that were coalesced, in the order that the
-                                --      coalescing was applied.
-
-coalesceGraph aggressive triv graph
-        = coalesceGraph' aggressive triv graph []
-
-coalesceGraph'
-        :: (Uniquable k, Ord k, Eq cls, Outputable k)
-        => Bool
-        -> Triv k cls color
-        -> Graph k cls color
-        -> [(k, k)]
-        -> ( Graph k cls color
-           , [(k, k)])
-coalesceGraph' aggressive triv graph kkPairsAcc
- = let
-        -- find all the nodes that have coalescence edges
-        cNodes  = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
-                $ nonDetEltsUFM $ graphMap graph
-                -- See Note [Unique Determinism and code generation]
-
-        -- build a list of pairs of keys for node's we'll try and coalesce
-        --      every pair of nodes will appear twice in this list
-        --      ie [(k1, k2), (k2, k1) ... ]
-        --      This is ok, GrapOps.coalesceNodes handles this and it's convenient for
-        --      build a list of what nodes get coalesced together for later on.
-        --
-        cList   = [ (nodeId node1, k2)
-                        | node1 <- cNodes
-                        , k2    <- nonDetEltsUniqSet $ nodeCoalesce node1 ]
-                        -- See Note [Unique Determinism and code generation]
-
-        -- do the coalescing, returning the new graph and a list of pairs of keys
-        --      that got coalesced together.
-        (graph', mPairs)
-                = mapAccumL (coalesceNodes aggressive triv) graph cList
-
-        -- keep running until there are no more coalesces can be found
-   in   case catMaybes mPairs of
-         []     -> (graph', reverse kkPairsAcc)
-         pairs  -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc)
-
-
--- | Coalesce this pair of nodes unconditionally \/ aggressively.
---      The resulting node is the one with the least key.
---
---      returns: Just    the pair of keys if the nodes were coalesced
---                       the second element of the pair being the least one
---
---               Nothing if either of the nodes weren't in the graph
-
-coalesceNodes
-        :: (Uniquable k, Ord k, Eq cls)
-        => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
-                                --      less colorable (aggressive coalescing)
-        -> Triv  k cls color
-        -> Graph k cls color
-        -> (k, k)               -- ^ keys of the nodes to be coalesced
-        -> (Graph k cls color, Maybe (k, k))
-
-coalesceNodes aggressive triv graph (k1, k2)
-        | (kMin, kMax)  <- if k1 < k2
-                                then (k1, k2)
-                                else (k2, k1)
-
-        -- the nodes being coalesced must be in the graph
-        , Just nMin     <- lookupNode graph kMin
-        , Just nMax     <- lookupNode graph kMax
-
-        -- can't coalesce conflicting modes
-        , not $ elementOfUniqSet kMin (nodeConflicts nMax)
-        , not $ elementOfUniqSet kMax (nodeConflicts nMin)
-
-        -- can't coalesce the same node
-        , nodeId nMin /= nodeId nMax
-
-        = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
-
-        -- don't do the coalescing after all
-        | otherwise
-        = (graph, Nothing)
-
-coalesceNodes_merge
-        :: (Uniquable k, Eq cls)
-        => Bool
-        -> Triv  k cls color
-        -> Graph k cls color
-        -> k -> k
-        -> Node k cls color
-        -> Node k cls color
-        -> (Graph k cls color, Maybe (k, k))
-
-coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
-
-        -- sanity checks
-        | nodeClass nMin /= nodeClass nMax
-        = error "GHC.Data.Graph.Ops.coalesceNodes: can't coalesce nodes of different classes."
-
-        | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
-        = error "GHC.Data.Graph.Ops.coalesceNodes: can't coalesce colored nodes."
-
-        ---
-        | otherwise
-        = let
-                -- the new node gets all the edges from its two components
-                node    =
-                 Node   { nodeId                = kMin
-                        , nodeClass             = nodeClass nMin
-                        , nodeColor             = Nothing
-
-                        -- nodes don't conflict with themselves..
-                        , nodeConflicts
-                                = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))
-                                        `delOneFromUniqSet` kMin
-                                        `delOneFromUniqSet` kMax
-
-                        , nodeExclusions        = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)
-                        , nodePreference        = nodePreference nMin ++ nodePreference nMax
-
-                        -- nodes don't coalesce with themselves..
-                        , nodeCoalesce
-                                = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))
-                                        `delOneFromUniqSet` kMin
-                                        `delOneFromUniqSet` kMax
-                        }
-
-          in    coalesceNodes_check aggressive triv graph kMin kMax node
-
-coalesceNodes_check
-        :: Uniquable k
-        => Bool
-        -> Triv  k cls color
-        -> Graph k cls color
-        -> k -> k
-        -> Node k cls color
-        -> (Graph k cls color, Maybe (k, k))
-
-coalesceNodes_check aggressive triv graph kMin kMax node
-
-        -- Unless we're coalescing aggressively, if the result node is not trivially
-        --      colorable then don't do the coalescing.
-        | not aggressive
-        , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
-        = (graph, Nothing)
-
-        | otherwise
-        = let -- delete the old nodes from the graph and add the new one
-                Just graph1     = delNode kMax graph
-                Just graph2     = delNode kMin graph1
-                graph3          = addNode kMin node graph2
-
-          in    (graph3, Just (kMax, kMin))
-
-
--- | Freeze a node
---      This is for the iterative coalescer.
---      By freezing a node we give up on ever coalescing it.
---      Move all its coalesce edges into the frozen set - and update
---      back edges from other nodes.
---
-freezeNode
-        :: Uniquable k
-        => k                    -- ^ key of the node to freeze
-        -> Graph k cls color    -- ^ the graph
-        -> Graph k cls color    -- ^ graph with that node frozen
-
-freezeNode k
-  = graphMapModify
-  $ \fm ->
-    let -- freeze all the edges in the node to be frozen
-        Just node = lookupUFM fm k
-        node'   = node
-                { nodeCoalesce          = emptyUniqSet }
-
-        fm1     = addToUFM fm k node'
-
-        -- update back edges pointing to this node
-        freezeEdge k node
-         = if elementOfUniqSet k (nodeCoalesce node)
-                then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k }
-                else node       -- panic "GHC.Data.Graph.Ops.freezeNode: edge to freeze wasn't in the coalesce set"
-                                -- If the edge isn't actually in the coalesce set then just ignore it.
-
-        fm2     = nonDetStrictFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1
-                    -- It's OK to use a non-deterministic fold here because the
-                    -- operation is commutative
-                        $ nodeCoalesce node
-
-    in  fm2
-
-
--- | Freeze one node in the graph
---      This if for the iterative coalescer.
---      Look for a move related node of low degree and freeze it.
---
---      We probably don't need to scan the whole graph looking for the node of absolute
---      lowest degree. Just sample the first few and choose the one with the lowest
---      degree out of those. Also, we don't make any distinction between conflicts of different
---      classes.. this is just a heuristic, after all.
---
---      IDEA:   freezing a node might free it up for Simplify.. would be good to check for triv
---              right here, and add it to a worklist if known triv\/non-move nodes.
---
-freezeOneInGraph
-        :: (Uniquable k)
-        => Graph k cls color
-        -> ( Graph k cls color          -- the new graph
-           , Bool )                     -- whether we found a node to freeze
-
-freezeOneInGraph graph
- = let  compareNodeDegree n1 n2
-                = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2)
-
-        candidates
-                = sortBy compareNodeDegree
-                $ take 5        -- 5 isn't special, it's just a small number.
-                $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph
-
-   in   case candidates of
-
-         -- there wasn't anything available to freeze
-         []     -> (graph, False)
-
-         -- we found something to freeze
-         (n : _)
-          -> ( freezeNode (nodeId n) graph
-             , True)
-
-
--- | Freeze all the nodes in the graph
---      for debugging the iterative allocator.
---
-freezeAllInGraph
-        :: (Uniquable k)
-        => Graph k cls color
-        -> Graph k cls color
-
-freezeAllInGraph graph
-        = foldr freezeNode graph
-                $ map nodeId
-                $ nonDetEltsUFM $ graphMap graph
-                -- See Note [Unique Determinism and code generation]
-
-
--- | Find all the nodes in the graph that meet some criteria
---
-scanGraph
-        :: (Node k cls color -> Bool)
-        -> Graph k cls color
-        -> [Node k cls color]
-
-scanGraph match graph
-        = filter match $ nonDetEltsUFM $ graphMap graph
-          -- See Note [Unique Determinism and code generation]
-
-
--- | validate the internal structure of a graph
---      all its edges should point to valid nodes
---      If they don't then throw an error
---
-validateGraph
-        :: (Uniquable k, Outputable k, Eq color)
-        => SDoc                         -- ^ extra debugging info to display on error
-        -> Bool                         -- ^ whether this graph is supposed to be colored.
-        -> Graph k cls color            -- ^ graph to validate
-        -> Graph k cls color            -- ^ validated graph
-
-validateGraph doc isColored graph
-
-        -- Check that all edges point to valid nodes.
-        | edges         <- unionManyUniqSets
-                                (  (map nodeConflicts       $ nonDetEltsUFM $ graphMap graph)
-                                ++ (map nodeCoalesce        $ nonDetEltsUFM $ graphMap graph))
-
-        , nodes         <- mkUniqSet $ map nodeId $ nonDetEltsUFM $ graphMap graph
-        , badEdges      <- minusUniqSet edges nodes
-        , not $ isEmptyUniqSet badEdges
-        = pprPanic "GHC.Data.Graph.Ops.validateGraph"
-                (  text "Graph has edges that point to non-existent nodes"
-                $$ text "  bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr)
-                $$ doc )
-
-        -- Check that no conflicting nodes have the same color
-        | badNodes      <- filter (not . (checkNode graph))
-                        $ nonDetEltsUFM $ graphMap graph
-                           -- See Note [Unique Determinism and code generation]
-        , not $ null badNodes
-        = pprPanic "GHC.Data.Graph.Ops.validateGraph"
-                (  text "Node has same color as one of it's conflicts"
-                $$ text "  bad nodes: " <> hcat (map (ppr . nodeId) badNodes)
-                $$ doc)
-
-        -- If this is supposed to be a colored graph,
-        --      check that all nodes have a color.
-        | isColored
-        , badNodes      <- filter (\n -> isNothing $ nodeColor n)
-                        $  nonDetEltsUFM $ graphMap graph
-        , not $ null badNodes
-        = pprPanic "GHC.Data.Graph.Ops.validateGraph"
-                (  text "Supposedly colored graph has uncolored nodes."
-                $$ text "  uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes)
-                $$ doc )
-
-
-        -- graph looks ok
-        | otherwise
-        = graph
-
-
--- | If this node is colored, check that all the nodes which
---      conflict with it have different colors.
-checkNode
-        :: (Uniquable k, Eq color)
-        => Graph k cls color
-        -> Node  k cls color
-        -> Bool                 -- ^ True if this node is ok
-
-checkNode graph node
-        | Just color            <- nodeColor node
-        , Just neighbors        <- sequence $ map (lookupNode graph)
-                                $  nonDetEltsUniqSet $ nodeConflicts node
-            -- See Note [Unique Determinism and code generation]
-
-        , neighbourColors       <- mapMaybe nodeColor neighbors
-        , elem color neighbourColors
-        = False
-
-        | otherwise
-        = True
-
-
-
--- | Slurp out a map of how many nodes had a certain number of conflict neighbours
-
-slurpNodeConflictCount
-        :: Graph k cls color
-        -> UniqFM Int (Int, Int)    -- ^ (conflict neighbours, num nodes with that many conflicts)
-
-slurpNodeConflictCount graph
-        = addListToUFM_C
-                (\(c1, n1) (_, n2) -> (c1, n1 + n2))
-                emptyUFM
-        $ map   (\node
-                  -> let count  = sizeUniqSet $ nodeConflicts node
-                     in  (count, (count, 1)))
-        $ nonDetEltsUFM
-        -- See Note [Unique Determinism and code generation]
-        $ graphMap graph
-
-
--- | Set the color of a certain node
-setColor
-        :: Uniquable k
-        => k -> color
-        -> Graph k cls color -> Graph k cls color
-
-setColor u color
-        = graphMapModify
-        $ adjustUFM_C
-                (\n -> n { nodeColor = Just color })
-                u
-
-
-{-# INLINE adjustWithDefaultUFM #-}
-adjustWithDefaultUFM
-        :: Uniquable k
-        => (a -> a) -> a -> k
-        -> UniqFM k a -> UniqFM k a
-
-adjustWithDefaultUFM f def k map
-        = addToUFM_C
-                (\old _ -> f old)
-                map
-                k def
-
--- Argument order different from UniqFM's adjustUFM
-{-# INLINE adjustUFM_C #-}
-adjustUFM_C
-        :: Uniquable k
-        => (a -> a)
-        -> k -> UniqFM k a -> UniqFM k a
-
-adjustUFM_C f k map
- = case lookupUFM map k of
-        Nothing -> map
-        Just a  -> addToUFM map k (f a)
-
diff --git a/compiler/GHC/Data/Graph/Ppr.hs b/compiler/GHC/Data/Graph/Ppr.hs
deleted file mode 100644
--- a/compiler/GHC/Data/Graph/Ppr.hs
+++ /dev/null
@@ -1,173 +0,0 @@
-
--- | Pretty printing of graphs.
-
-module GHC.Data.Graph.Ppr
-   ( dumpGraph
-   , dotGraph
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Data.Graph.Base
-
-import GHC.Utils.Outputable
-import GHC.Types.Unique
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.FM
-
-import Data.List (mapAccumL)
-import Data.Maybe
-
-
--- | Pretty print a graph in a somewhat human readable format.
-dumpGraph
-        :: (Outputable k, Outputable color)
-        => Graph k cls color -> SDoc
-
-dumpGraph graph
-        =  text "Graph"
-        $$ pprUFM (graphMap graph) (vcat . map dumpNode)
-
-dumpNode
-        :: (Outputable k, Outputable color)
-        => Node k cls color -> SDoc
-
-dumpNode node
-        =  text "Node " <> ppr (nodeId node)
-        $$ text "conflicts "
-                <> parens (int (sizeUniqSet $ nodeConflicts node))
-                <> text " = "
-                <> ppr (nodeConflicts node)
-
-        $$ text "exclusions "
-                <> parens (int (sizeUniqSet $ nodeExclusions node))
-                <> text " = "
-                <> ppr (nodeExclusions node)
-
-        $$ text "coalesce "
-                <> parens (int (sizeUniqSet $ nodeCoalesce node))
-                <> text " = "
-                <> ppr (nodeCoalesce node)
-
-        $$ space
-
-
-
--- | Pretty print a graph in graphviz .dot format.
---      Conflicts get solid edges.
---      Coalescences get dashed edges.
-dotGraph
-        :: ( Uniquable k
-           , Outputable k, Outputable cls, Outputable color)
-        => (color -> SDoc)  -- ^ What graphviz color to use for each node color
-                            --  It's usually safe to return X11 style colors here,
-                            --  ie "red", "green" etc or a hex triplet #aaff55 etc
-        -> Triv k cls color
-        -> Graph k cls color -> SDoc
-
-dotGraph colorMap triv graph
- = let  nodes   = nonDetEltsUFM $ graphMap graph
-                  -- See Note [Unique Determinism and code generation]
-   in   vcat
-                (  [ text "graph G {" ]
-                ++ map (dotNode colorMap triv) nodes
-                ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes)
-                ++ [ text "}"
-                   , space ])
-
-
-dotNode :: ( Outputable k, Outputable cls, Outputable color)
-        => (color -> SDoc)
-        -> Triv k cls color
-        -> Node k cls color -> SDoc
-
-dotNode colorMap triv node
- = let  name    = ppr $ nodeId node
-        cls     = ppr $ nodeClass node
-
-        excludes
-                = hcat $ punctuate space
-                $ map (\n -> text "-" <> ppr n)
-                $ nonDetEltsUniqSet $ nodeExclusions node
-                -- See Note [Unique Determinism and code generation]
-
-        preferences
-                = hcat $ punctuate space
-                $ map (\n -> text "+" <> ppr n)
-                $ nodePreference node
-
-        expref  = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)]
-                        then empty
-                        else text "\\n" <> (excludes <+> preferences)
-
-        -- if the node has been colored then show that,
-        --      otherwise indicate whether it looks trivially colorable.
-        color
-                | Just c        <- nodeColor node
-                = text "\\n(" <> ppr c <> text ")"
-
-                | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
-                = text "\\n(" <> text "triv" <> text ")"
-
-                | otherwise
-                = text "\\n(" <> text "spill?" <> text ")"
-
-        label   =  name <> text " :: " <> cls
-                <> expref
-                <> color
-
-        pcolorC = case nodeColor node of
-                        Nothing -> text "style=filled fillcolor=white"
-                        Just c  -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c)
-
-
-        pout    = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]"
-                <> space <> doubleQuotes name
-                <> text ";"
-
- in     pout
-
-
--- | Nodes in the graph are doubly linked, but we only want one edge for each
---      conflict if the graphviz graph. Traverse over the graph, but make sure
---      to only print the edges for each node once.
-
-dotNodeEdges
-        :: ( Uniquable k
-           , Outputable k)
-        => UniqSet k
-        -> Node k cls color
-        -> (UniqSet k, Maybe SDoc)
-
-dotNodeEdges visited node
-        | elementOfUniqSet (nodeId node) visited
-        = ( visited
-          , Nothing)
-
-        | otherwise
-        = let   dconflicts
-                        = map (dotEdgeConflict (nodeId node))
-                        $ nonDetEltsUniqSet
-                        -- See Note [Unique Determinism and code generation]
-                        $ minusUniqSet (nodeConflicts node) visited
-
-                dcoalesces
-                        = map (dotEdgeCoalesce (nodeId node))
-                        $ nonDetEltsUniqSet
-                        -- See Note [Unique Determinism and code generation]
-                        $ minusUniqSet (nodeCoalesce node) visited
-
-                out     =  vcat dconflicts
-                        $$ vcat dcoalesces
-
-          in    ( addOneToUniqSet visited (nodeId node)
-                , Just out)
-
-        where   dotEdgeConflict u1 u2
-                        = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)
-                        <> text ";"
-
-                dotEdgeCoalesce u1 u2
-                        = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)
-                        <> space <> text "[ style = dashed ];"
diff --git a/compiler/GHC/Data/UnionFind.hs b/compiler/GHC/Data/UnionFind.hs
deleted file mode 100644
--- a/compiler/GHC/Data/UnionFind.hs
+++ /dev/null
@@ -1,91 +0,0 @@
-{- Union-find data structure compiled from Distribution.Utils.UnionFind -}
-module GHC.Data.UnionFind where
-
-import GHC.Prelude
-import Data.STRef
-import Control.Monad.ST
-import Control.Monad
-
--- | A variable which can be unified; alternately, this can be thought
--- of as an equivalence class with a distinguished representative.
-newtype Point s a = Point (STRef s (Link s a))
-    deriving (Eq)
-
--- | Mutable write to a 'Point'
-writePoint :: Point s a -> Link s a -> ST s ()
-writePoint (Point v) = writeSTRef v
-
--- | Read the current value of 'Point'.
-readPoint :: Point s a -> ST s (Link s a)
-readPoint (Point v) = readSTRef v
-
--- | The internal data structure for a 'Point', which either records
--- the representative element of an equivalence class, or a link to
--- the 'Point' that actually stores the representative type.
-data Link s a
-    -- NB: it is too bad we can't say STRef Int#; the weights remain boxed
-    = Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a)
-    | Link {-# UNPACK #-} !(Point s a)
-
--- | Create a fresh equivalence class with one element.
-fresh :: a -> ST s (Point s a)
-fresh desc = do
-    weight <- newSTRef 1
-    descriptor <- newSTRef desc
-    Point `fmap` newSTRef (Info weight descriptor)
-
--- | Flatten any chains of links, returning a 'Point'
--- which points directly to the canonical representation.
-repr :: Point s a -> ST s (Point s a)
-repr point = readPoint point >>= \r ->
-  case r of
-    Link point' -> do
-        point'' <- repr point'
-        when (point'' /= point') $ do
-            writePoint point =<< readPoint point'
-        return point''
-    Info _ _ -> return point
-
--- | Return the canonical element of an equivalence
--- class 'Point'.
-find :: Point s a -> ST s a
-find point =
-    -- Optimize length 0 and 1 case at expense of
-    -- general case
-    readPoint point >>= \r ->
-      case r of
-        Info _ d_ref -> readSTRef d_ref
-        Link point' -> readPoint point' >>= \r' ->
-          case r' of
-            Info _ d_ref -> readSTRef d_ref
-            Link _ -> repr point >>= find
-
--- | Unify two equivalence classes, so that they share
--- a canonical element. Keeps the descriptor of point2.
-union :: Point s a -> Point s a -> ST s ()
-union refpoint1 refpoint2 = do
-    point1 <- repr refpoint1
-    point2 <- repr refpoint2
-    when (point1 /= point2) $ do
-      l1 <- readPoint point1
-      l2 <- readPoint point2
-      case (l1, l2) of
-          (Info wref1 dref1, Info wref2 dref2) -> do
-              weight1 <- readSTRef wref1
-              weight2 <- readSTRef wref2
-              -- Should be able to optimize the == case separately
-              if weight1 >= weight2
-                  then do
-                      writePoint point2 (Link point1)
-                      -- The weight calculation here seems a bit dodgy
-                      writeSTRef wref1 (weight1 + weight2)
-                      writeSTRef dref1 =<< readSTRef dref2
-                  else do
-                      writePoint point1 (Link point2)
-                      writeSTRef wref2 (weight1 + weight2)
-          _ -> error "UnionFind.union: repr invariant broken"
-
--- | Test if two points are in the same equivalence class.
-equivalent :: Point s a -> Point s a -> ST s Bool
-equivalent point1 point2 = liftM2 (==) (repr point1) (repr point2)
-
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ /dev/null
@@ -1,944 +0,0 @@
-
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE NondecreasingIndentation #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-
-
--- | This is the driver for the 'ghc --backpack' mode, which
--- is a reimplementation of the "package manager" bits of
--- Backpack directly in GHC.  The basic method of operation
--- is to compile packages and then directly insert them into
--- GHC's in memory database.
---
--- The compilation products of this mode aren't really suitable
--- for Cabal, because GHC makes up component IDs for the things
--- it builds and doesn't serialize out the database contents.
--- But it's still handy for constructing tests.
-
-module GHC.Driver.Backpack (doBackpack) where
-
-import GHC.Prelude
-
-import GHC.Driver.Backend
--- In a separate module because it hooks into the parser.
-import GHC.Driver.Backpack.Syntax
-import GHC.Driver.Config.Finder (initFinderOpts)
-import GHC.Driver.Config.Parser (initParserOpts)
-import GHC.Driver.Config.Diagnostic
-import GHC.Driver.Monad
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Driver.Main
-import GHC.Driver.Make
-import GHC.Driver.Env
-import GHC.Driver.Errors
-import GHC.Driver.Errors.Types
-
-import GHC.Parser
-import GHC.Parser.Header
-import GHC.Parser.Lexer
-import GHC.Parser.Annotation
-
-import GHC.Rename.Names
-
-import GHC hiding (Failed, Succeeded)
-import GHC.Tc.Utils.Monad
-import GHC.Iface.Recomp
-import GHC.Builtin.Names
-
-import GHC.Types.SrcLoc
-import GHC.Types.SourceError
-import GHC.Types.SourceFile
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.DFM
-import GHC.Types.Unique.DSet
-
-import GHC.Utils.Outputable
-import GHC.Utils.Fingerprint
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Error
-import GHC.Utils.Logger
-
-import GHC.Unit
-import GHC.Unit.Env
-import GHC.Unit.External
-import GHC.Unit.Finder
-import GHC.Unit.Module.Graph
-import GHC.Unit.Module.ModSummary
-import GHC.Unit.Home.ModInfo
-
-import GHC.Linker.Types
-
-import qualified GHC.LanguageExtensions as LangExt
-
-import GHC.Data.Maybe
-import GHC.Data.StringBuffer
-import GHC.Data.FastString
-import qualified GHC.Data.EnumSet as EnumSet
-import qualified GHC.Data.ShortText as ST
-
-import Data.List ( partition )
-import System.Exit
-import Control.Monad
-import System.FilePath
-import Data.Version
-
--- for the unification
-import Data.IORef
-import Data.Map (Map)
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-
--- | Entry point to compile a Backpack file.
-doBackpack :: [FilePath] -> Ghc ()
-doBackpack [src_filename] = do
-    -- Apply options from file to dflags
-    dflags0 <- getDynFlags
-    let dflags1 = dflags0
-    let parser_opts1 = initParserOpts dflags1
-    (p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 src_filename
-    (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
-    modifySession (hscSetFlags dflags)
-    logger <- getLogger -- Get the logger after having set the session flags,
-                        -- so that logger options are correctly set.
-                        -- Not doing so caused #20396.
-    -- Cribbed from: preprocessFile / GHC.Driver.Pipeline
-    liftIO $ checkProcessArgsResult unhandled_flags
-    let print_config = initPrintConfig dflags
-    liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dflags) (GhcPsMessage <$> p_warns)
-    liftIO $ handleFlagWarnings logger print_config (initDiagOpts dflags) warns
-    -- TODO: Preprocessing not implemented
-
-    buf <- liftIO $ hGetStringBuffer src_filename
-    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
-    case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of
-        PFailed pst -> throwErrors (GhcPsMessage <$> getPsErrorMessages pst)
-        POk _ pkgname_bkp -> do
-            -- OK, so we have an LHsUnit PackageName, but we want an
-            -- LHsUnit HsComponentId.  So let's rename it.
-            hsc_env <- getSession
-            let bkp = renameHsUnits (hsc_units hsc_env) (bkpPackageNameMap pkgname_bkp) pkgname_bkp
-            initBkpM src_filename bkp $
-                forM_ (zip [1..] bkp) $ \(i, lunit) -> do
-                    let comp_name = unLoc (hsunitName (unLoc lunit))
-                    msgTopPackage (i,length bkp) comp_name
-                    innerBkpM $ do
-                        let (cid, insts) = computeUnitId lunit
-                        if null insts
-                            then if cid == UnitId (fsLit "main")
-                                    then compileExe lunit
-                                    else compileUnit cid []
-                            else typecheckUnit cid insts
-doBackpack _ =
-    throwGhcException (CmdLineError "--backpack can only process a single file")
-
-computeUnitId :: LHsUnit HsComponentId -> (UnitId, [(ModuleName, Module)])
-computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])
-  where
-    cid = hsComponentId (unLoc (hsunitName unit))
-    reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))
-    get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname
-    get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet
-    get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet
-    get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =
-        unitFreeModuleHoles (convertHsComponentId hsuid)
-
--- | Tiny enum for all types of Backpack operations we may do.
-data SessionType
-    -- | A compilation operation which will result in a
-    -- runnable executable being produced.
-    = ExeSession
-    -- | A type-checking operation which produces only
-    -- interface files, no object files.
-    | TcSession
-    -- | A compilation operation which produces both
-    -- interface files and object files.
-    | CompSession
-    deriving (Eq)
-
--- | Create a temporary Session to do some sort of type checking or
--- compilation.
-withBkpSession :: UnitId
-               -> [(ModuleName, Module)]
-               -> [(Unit, ModRenaming)]
-               -> SessionType   -- what kind of session are we doing
-               -> BkpM a        -- actual action to run
-               -> BkpM a
-withBkpSession cid insts deps session_type do_this = do
-    dflags <- getDynFlags
-    let cid_fs = unitFS cid
-        is_primary = False
-        uid_str = unpackFS (mkInstantiatedUnitHash cid insts)
-        cid_str = unpackFS cid_fs
-        -- There are multiple units in a single Backpack file, so we
-        -- need to separate out the results in those cases.  Right now,
-        -- we follow this hierarchy:
-        --      $outputdir/$compid          --> typecheck results
-        --      $outputdir/$compid/$unitid  --> compile results
-        key_base p | Just f <- p dflags = f
-                   | otherwise          = "."
-        sub_comp p | is_primary = p
-                   | otherwise = p </> cid_str
-        outdir p | CompSession <- session_type
-                 -- Special case when package is definite
-                 , not (null insts) = sub_comp (key_base p) </> uid_str
-                 | otherwise = sub_comp (key_base p)
-
-        mk_temp_env hsc_env =
-          hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env
-        mk_temp_dflags unit_state dflags = dflags
-            { backend = case session_type of
-                            TcSession -> noBackend
-                            _         -> backend dflags
-            , ghcLink = case session_type of
-                            TcSession -> NoLink
-                            _         -> ghcLink dflags
-            , homeUnitInstantiations_ = insts
-                                     -- if we don't have any instantiation, don't
-                                     -- fill `homeUnitInstanceOfId` as it makes no
-                                     -- sense (we're not instantiating anything)
-            , homeUnitInstanceOf_   = if null insts then Nothing else Just cid
-            , homeUnitId_ = case session_type of
-                TcSession -> newUnitId cid Nothing
-                -- No hash passed if no instances
-                _ | null insts -> newUnitId cid Nothing
-                  | otherwise  -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts))
-
-
-            -- If we're type-checking an indefinite package, we want to
-            -- turn on interface writing.  However, if the user also
-            -- explicitly passed in `-fno-code`, we DON'T want to write
-            -- interfaces unless the user also asked for `-fwrite-interface`.
-            -- See Note [-fno-code mode]
-            , generalFlags = case session_type of
-                -- Make sure to write interfaces when we are type-checking
-                -- indefinite packages.
-                TcSession
-                  | backendSupportsInterfaceWriting $ backend dflags
-                  -> EnumSet.insert Opt_WriteInterface (generalFlags dflags)
-                _ -> generalFlags dflags
-
-            -- Setup all of the output directories according to our hierarchy
-            , objectDir   = Just (outdir objectDir)
-            , hiDir       = Just (outdir hiDir)
-            , stubDir     = Just (outdir stubDir)
-            -- Unset output-file for non exe builds
-            , outputFile_ = case session_type of
-                ExeSession -> outputFile_ dflags
-                _          -> Nothing
-            , dynOutputFile_ = case session_type of
-                ExeSession -> dynOutputFile_ dflags
-                _          -> Nothing
-            -- Clear the import path so we don't accidentally grab anything
-            , importPaths = []
-            -- Synthesize the flags
-            , packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
-              let uid = unwireUnit unit_state
-                        $ improveUnit unit_state
-                        $ renameHoleUnit unit_state (listToUFM insts) uid0
-              in ExposePackage
-                (showSDoc dflags
-                    (text "-unit-id" <+> ppr uid <+> ppr rn))
-                (UnitIdArg uid) rn) deps
-            }
-    withTempSession mk_temp_env $ do
-      dflags <- getSessionDynFlags
-      -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
-      setSessionDynFlags dflags -- calls initUnits
-      do_this
-
-withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a
-withBkpExeSession deps do_this =
-    withBkpSession (UnitId (fsLit "main")) [] deps ExeSession do_this
-
-getSource :: UnitId -> BkpM (LHsUnit HsComponentId)
-getSource cid = do
-    bkp_env <- getBkpEnv
-    case Map.lookup cid (bkp_table bkp_env) of
-        Nothing -> pprPanic "missing needed dependency" (ppr cid)
-        Just lunit -> return lunit
-
-typecheckUnit :: UnitId -> [(ModuleName, Module)] -> BkpM ()
-typecheckUnit cid insts = do
-    lunit <- getSource cid
-    buildUnit TcSession cid insts lunit
-
-compileUnit :: UnitId -> [(ModuleName, Module)] -> BkpM ()
-compileUnit cid insts = do
-    -- Let everyone know we're building this unit
-    msgUnitId (mkVirtUnit cid insts)
-    lunit <- getSource cid
-    buildUnit CompSession cid insts lunit
-
--- | Compute the dependencies with instantiations of a syntactic
--- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a
--- unit file, return the 'Unit' corresponding to @p[A=<A>]@.
--- The @include_sigs@ parameter controls whether or not we also
--- include @dependency signature@ declarations in this calculation.
---
--- Invariant: this NEVER returns UnitId.
-hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(Unit, ModRenaming)]
-hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit)
-  where
-    get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig)))
-        | include_sigs || not is_sig = [(convertHsComponentId hsuid, go mb_lrn)]
-        | otherwise = []
-      where
-        go Nothing = ModRenaming True []
-        go (Just lrns) = ModRenaming False (map convRn lrns)
-          where
-            convRn (L _ (Renaming (L _ from) Nothing))         = (from, from)
-            convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to)
-    get_dep _ = []
-
-buildUnit :: SessionType -> UnitId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
-buildUnit session cid insts lunit = do
-    -- NB: include signature dependencies ONLY when typechecking.
-    -- If we're compiling, it's not necessary to recursively
-    -- compile a signature since it isn't going to produce
-    -- any object files.
-    let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)
-        raw_deps = map fst deps_w_rns
-    hsc_env <- getSession
-    -- The compilation dependencies are just the appropriately filled
-    -- in unit IDs which must be compiled before we can compile.
-    let hsubst = listToUFM insts
-        deps0 = map (renameHoleUnit (hsc_units hsc_env) hsubst) raw_deps
-
-    -- Build dependencies OR make sure they make sense. BUT NOTE,
-    -- we can only check the ones that are fully filled; the rest
-    -- we have to defer until we've typechecked our local signature.
-    -- TODO: work this into GHC.Driver.Make!!
-    forM_ (zip [1..] deps0) $ \(i, dep) ->
-        case session of
-            TcSession -> return ()
-            _ -> compileInclude (length deps0) (i, dep)
-
-    -- IMPROVE IT
-    let deps = map (improveUnit (hsc_units hsc_env)) deps0
-
-    mb_old_eps <- case session of
-                    TcSession -> fmap Just getEpsGhc
-                    _ -> return Nothing
-
-    conf <- withBkpSession cid insts deps_w_rns session $ do
-
-        dflags <- getDynFlags
-        mod_graph <- hsunitModuleGraph False (unLoc lunit)
-
-        msg <- mkBackpackMsg
-        ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph
-        when (failed ok) (liftIO $ exitWith (ExitFailure 1))
-
-        let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
-            export_mod ms = (ms_mod_name ms, ms_mod ms)
-            -- Export everything!
-            mods = [ export_mod ms | ms <- mgModSummaries mod_graph
-                                   , ms_hsc_src ms == HsSrcFile ]
-
-        -- Compile relevant only
-        hsc_env <- getSession
-        let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)
-            linkables = map (expectJust "bkp link" . homeModInfoObject)
-                      . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
-                      $ home_mod_infos
-            getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us)
-            obj_files = concatMap getOfiles linkables
-            state     = hsc_units hsc_env
-
-        let compat_fs = unitIdFS cid
-            compat_pn = PackageName compat_fs
-            unit_id   = homeUnitId (hsc_home_unit hsc_env)
-
-        return GenericUnitInfo {
-            -- Stub data
-            unitAbiHash = "",
-            unitPackageId = PackageId compat_fs,
-            unitPackageName = compat_pn,
-            unitPackageVersion = makeVersion [],
-            unitId = unit_id,
-            unitComponentName = Nothing,
-            unitInstanceOf = cid,
-            unitInstantiations = insts,
-            -- Slight inefficiency here haha
-            unitExposedModules = map (\(m,n) -> (m,Just n)) mods,
-            unitHiddenModules = [], -- TODO: doc only
-            unitDepends = case session of
-                        -- Technically, we should state that we depend
-                        -- on all the indefinite libraries we used to
-                        -- typecheck this.  However, this field isn't
-                        -- really used for anything, so we leave it
-                        -- blank for now.
-                        TcSession -> []
-                        _ -> map (toUnitId . unwireUnit state)
-                                $ deps ++ [ moduleUnit mod
-                                          | (_, mod) <- insts
-                                          , not (isHoleModule mod) ],
-            unitAbiDepends = [],
-            unitLinkerOptions = case session of
-                                 TcSession -> []
-                                 _ -> map ST.pack $ obj_files,
-            unitImportDirs = [ ST.pack $ hi_dir ],
-            unitIsExposed = False,
-            unitIsIndefinite = case session of
-                                 TcSession -> True
-                                 _ -> False,
-            -- nope
-            unitLibraries = [],
-            unitExtDepLibsSys = [],
-            unitExtDepLibsGhc = [],
-            unitLibraryDynDirs = [],
-            unitLibraryDirs = [],
-            unitExtDepFrameworks = [],
-            unitExtDepFrameworkDirs = [],
-            unitCcOptions = [],
-            unitIncludes = [],
-            unitIncludeDirs = [],
-            unitHaddockInterfaces = [],
-            unitHaddockHTMLs = [],
-            unitIsTrusted = False
-            }
-
-
-    addUnit conf
-    case mb_old_eps of
-        Just old_eps -> updateEpsGhc_ (const old_eps)
-        _ -> return ()
-
-compileExe :: LHsUnit HsComponentId -> BkpM ()
-compileExe lunit = do
-    msgUnitId mainUnit
-    let deps_w_rns = hsunitDeps False (unLoc lunit)
-        deps = map fst deps_w_rns
-        -- no renaming necessary
-    forM_ (zip [1..] deps) $ \(i, dep) ->
-        compileInclude (length deps) (i, dep)
-    withBkpExeSession deps_w_rns $ do
-        mod_graph <- hsunitModuleGraph True (unLoc lunit)
-        msg <- mkBackpackMsg
-        ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph
-        when (failed ok) (liftIO $ exitWith (ExitFailure 1))
-
--- | Register a new virtual unit database containing a single unit
-addUnit :: GhcMonad m => UnitInfo -> m ()
-addUnit u = do
-    hsc_env <- getSession
-    logger <- getLogger
-    let dflags0 = hsc_dflags hsc_env
-    let old_unit_env = hsc_unit_env hsc_env
-    newdbs <- case ue_unit_dbs old_unit_env of
-        Nothing  -> panic "addUnit: called too early"
-        Just dbs ->
-         let newdb = UnitDatabase
-               { unitDatabasePath  = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"
-               , unitDatabaseUnits = [u]
-               }
-         in return (dbs ++ [newdb]) -- added at the end because ordering matters
-    (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
-
-    -- update platform constants
-    dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
-
-    let unit_env = ue_setUnits unit_state $ ue_setUnitDbs (Just dbs) $ UnitEnv
-          { ue_platform  = targetPlatform dflags
-          , ue_namever   = ghcNameVersion dflags
-          , ue_current_unit = homeUnitId home_unit
-
-          , ue_home_unit_graph =
-                unitEnv_singleton
-                    (homeUnitId home_unit)
-                    (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
-          , ue_eps       = ue_eps old_unit_env
-          }
-    setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
-
-compileInclude :: Int -> (Int, Unit) -> BkpM ()
-compileInclude n (i, uid) = do
-    hsc_env <- getSession
-    let pkgs = hsc_units hsc_env
-    msgInclude (i, n) uid
-    -- Check if we've compiled it already
-    case uid of
-      HoleUnit   -> return ()
-      RealUnit _ -> return ()
-      VirtUnit i -> case lookupUnit pkgs uid of
-        Nothing -> innerBkpM $ compileUnit (instUnitInstanceOf i) (instUnitInsts i)
-        Just _  -> return ()
-
--- ----------------------------------------------------------------------------
--- Backpack monad
-
--- | Backpack monad is a 'GhcMonad' which also maintains a little extra state
--- beyond the 'Session', c.f. 'BkpEnv'.
-type BkpM = IOEnv BkpEnv
-
--- | Backpack environment.  NB: this has a 'Session' and not an 'HscEnv',
--- because we are going to update the 'HscEnv' as we go.
-data BkpEnv
-    = BkpEnv {
-        -- | The session
-        bkp_session :: Session,
-        -- | The filename of the bkp file we're compiling
-        bkp_filename :: FilePath,
-        -- | Table of source units which we know how to compile
-        bkp_table :: Map UnitId (LHsUnit HsComponentId),
-        -- | When a package we are compiling includes another package
-        -- which has not been compiled, we bump the level and compile
-        -- that.
-        bkp_level :: Int
-    }
-
--- Blah, to get rid of the default instance for IOEnv
--- TODO: just make a proper new monad for BkpM, rather than use IOEnv
-instance {-# OVERLAPPING #-} HasDynFlags BkpM where
-    getDynFlags = fmap hsc_dflags getSession
-instance {-# OVERLAPPING #-} HasLogger BkpM where
-    getLogger = fmap hsc_logger getSession
-
-
-instance GhcMonad BkpM where
-    getSession = do
-        Session s <- fmap bkp_session getEnv
-        readMutVar s
-    setSession hsc_env = do
-        Session s <- fmap bkp_session getEnv
-        writeMutVar s hsc_env
-
--- | Get the current 'BkpEnv'.
-getBkpEnv :: BkpM BkpEnv
-getBkpEnv = getEnv
-
--- | Get the nesting level, when recursively compiling modules.
-getBkpLevel :: BkpM Int
-getBkpLevel = bkp_level `fmap` getBkpEnv
-
--- | Run a 'BkpM' computation, with the nesting level bumped one.
-innerBkpM :: BkpM a -> BkpM a
-innerBkpM do_this =
-    -- NB: withTempSession mutates, so we don't have to worry
-    -- about bkp_session being stale.
-    updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this
-
--- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.
-updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()
-updateEpsGhc_ f = do
-    hsc_env <- getSession
-    liftIO $ atomicModifyIORef' (euc_eps (ue_eps (hsc_unit_env hsc_env))) (\x -> (f x, ()))
-
--- | Get the EPS from a 'GhcMonad'.
-getEpsGhc :: GhcMonad m => m ExternalPackageState
-getEpsGhc = do
-    hsc_env <- getSession
-    liftIO $ hscEPS hsc_env
-
--- | Run 'BkpM' in 'Ghc'.
-initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
-initBkpM file bkp m =
-  reifyGhc $ \session -> do
-    let env = BkpEnv {
-        bkp_session = session,
-        bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],
-        bkp_filename = file,
-        bkp_level = 0
-      }
-    runIOEnv env m
-
--- ----------------------------------------------------------------------------
--- Messaging
-
--- | Print a compilation progress message, but with indentation according
--- to @level@ (for nested compilation).
-backpackProgressMsg :: Int -> Logger -> SDoc -> IO ()
-backpackProgressMsg level logger msg =
-    compilationProgressMsg logger $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr
-                                    <> msg
-
--- | Creates a 'Messager' for Backpack compilation; this is basically
--- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
--- handles indentation.
-mkBackpackMsg :: BkpM Messager
-mkBackpackMsg = do
-    level <- getBkpLevel
-    return $ \hsc_env mod_index recomp node ->
-      let dflags = hsc_dflags hsc_env
-          logger = hsc_logger hsc_env
-          state = hsc_units hsc_env
-          showMsg msg reason =
-            backpackProgressMsg level logger $ pprWithUnitState state $
-                showModuleIndex mod_index <>
-                msg <> showModMsg dflags (recompileRequired recomp) node
-                    <> reason
-      in case node of
-        InstantiationNode _ _ ->
-          case recomp of
-            UpToDate
-              | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty
-              | otherwise -> return ()
-            NeedsRecompile reason0 -> showMsg (text "Instantiating ") $ case reason0 of
-              MustCompile -> empty
-              RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"
-        ModuleNode _ _ ->
-          case recomp of
-            UpToDate
-              | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty
-              | otherwise -> return ()
-            NeedsRecompile reason0 -> showMsg (text "Compiling ") $ case reason0 of
-              MustCompile -> empty
-              RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"
-        LinkNode _ _ -> showMsg (text "Linking ")  empty
-
--- | 'PprStyle' for Backpack messages; here we usually want the module to
--- be qualified (so we can tell how it was instantiated.) But we try not
--- to qualify packages so we can use simple names for them.
-backpackStyle :: PprStyle
-backpackStyle =
-    mkUserStyle
-        (QueryQualify neverQualifyNames
-                      alwaysQualifyModules
-                      neverQualifyPackages
-                      alwaysPrintPromTick)
-        AllTheWay
-
--- | Message when we initially process a Backpack unit.
-msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
-msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
-    logger <- getLogger
-    level <- getBkpLevel
-    liftIO . backpackProgressMsg level logger
-        $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn
-
--- | Message when we instantiate a Backpack unit.
-msgUnitId :: Unit -> BkpM ()
-msgUnitId pk = do
-    logger <- getLogger
-    hsc_env <- getSession
-    level <- getBkpLevel
-    let state = hsc_units hsc_env
-    liftIO . backpackProgressMsg level logger
-        $ pprWithUnitState state
-        $ text "Instantiating "
-           <> withPprStyle backpackStyle (ppr pk)
-
--- | Message when we include a Backpack unit.
-msgInclude :: (Int,Int) -> Unit -> BkpM ()
-msgInclude (i,n) uid = do
-    logger <- getLogger
-    hsc_env <- getSession
-    level <- getBkpLevel
-    let state = hsc_units hsc_env
-    liftIO . backpackProgressMsg level logger
-        $ pprWithUnitState state
-        $ showModuleIndex (i, n) <> text "Including "
-            <> withPprStyle backpackStyle (ppr uid)
-
--- ----------------------------------------------------------------------------
--- Conversion from PackageName to HsComponentId
-
-type PackageNameMap a = UniqFM PackageName a
-
--- For now, something really simple, since we're not actually going
--- to use this for anything
-unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
-unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
-    = (pn, HsComponentId pn (UnitId fs))
-
-bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
-bkpPackageNameMap units = listToUFM (map unitDefines units)
-
-renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
-renameHsUnits pkgstate m units = map (fmap renameHsUnit) units
-  where
-
-    renamePackageName :: PackageName -> HsComponentId
-    renamePackageName pn =
-        case lookupUFM m pn of
-            Nothing ->
-                case lookupPackageName pkgstate pn of
-                    Nothing -> error "no package name"
-                    Just cid -> HsComponentId pn cid
-            Just hscid -> hscid
-
-    renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId
-    renameHsUnit u =
-        HsUnit {
-            hsunitName = fmap renamePackageName (hsunitName u),
-            hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)
-        }
-
-    renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
-    renameHsUnitDecl (DeclD a b c) = DeclD a b c
-    renameHsUnitDecl (IncludeD idecl) =
-        IncludeD IncludeDecl {
-            idUnitId = fmap renameHsUnitId (idUnitId idecl),
-            idModRenaming = idModRenaming idecl,
-            idSignatureInclude = idSignatureInclude idecl
-        }
-
-    renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
-    renameHsUnitId (HsUnitId ln subst)
-        = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)
-
-    renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId
-    renameHsModuleSubst (lk, lm)
-        = (lk, fmap renameHsModuleId lm)
-
-    renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId
-    renameHsModuleId (HsModuleVar lm) = HsModuleVar lm
-    renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm
-
-convertHsComponentId :: HsUnitId HsComponentId -> Unit
-convertHsComponentId (HsUnitId (L _ hscid) subst)
-    = mkVirtUnit (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)
-
-convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)
-convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)
-
-convertHsModuleId :: HsModuleId HsComponentId -> Module
-convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname
-convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsComponentId hsuid) modname
-
-
-
-{-
-************************************************************************
-*                                                                      *
-                        Module graph construction
-*                                                                      *
-************************************************************************
--}
-
--- | This is our version of GHC.Driver.Make.downsweep, but with a few modifications:
---
---  1. Every module is required to be mentioned, so we don't do any funny
---     business with targets or recursively grabbing dependencies.  (We
---     could support this in principle).
---  2. We support inline modules, whose summary we have to synthesize ourself.
---
--- We don't bother trying to support GHC.Driver.Make for now, it's more trouble
--- than it's worth for inline modules.
-hsunitModuleGraph :: Bool -> HsUnit HsComponentId -> BkpM ModuleGraph
-hsunitModuleGraph do_link unit = do
-    hsc_env <- getSession
-
-    let decls = hsunitBody unit
-        pn = hsPackageName (unLoc (hsunitName unit))
-        home_unit = hsc_home_unit hsc_env
-
-        sig_keys = flip map (homeUnitInstantiations home_unit) $ \(mod_name, _) -> NodeKey_Module (ModNodeKeyWithUid (GWIB mod_name NotBoot) (homeUnitId home_unit))
-        keys = [NodeKey_Module (ModNodeKeyWithUid gwib (homeUnitId home_unit)) | (DeclD hsc_src lmodname _) <- map unLoc decls, let gwib = GWIB (unLoc lmodname) (hscSourceToIsBoot hsc_src) ]
-
-    --  1. Create a HsSrcFile/HsigFile summary for every
-    --  explicitly mentioned module/signature.
-    let get_decl (L _ (DeclD hsc_src lmodname hsmod)) =
-          Just <$> summariseDecl pn hsc_src lmodname hsmod (keys ++ sig_keys)
-        get_decl _ = return Nothing
-    nodes <- mapMaybeM get_decl decls
-
-    --  2. For each hole which does not already have an hsig file,
-    --  create an "empty" hsig file to induce compilation for the
-    --  requirement.
-    let hsig_set = Set.fromList
-          [ ms_mod_name ms
-          | ModuleNode _ ms <- nodes
-          , ms_hsc_src ms == HsigFile
-          ]
-    req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) ->
-        if Set.member mod_name hsig_set
-            then return Nothing
-            else fmap Just $ summariseRequirement pn mod_name
-
-    let graph_nodes = nodes ++ req_nodes ++ (instantiationNodes (homeUnitId $ hsc_home_unit hsc_env) (hsc_units hsc_env))
-        key_nodes = map mkNodeKey graph_nodes
-        all_nodes = graph_nodes ++ [LinkNode key_nodes (homeUnitId $ hsc_home_unit hsc_env) | do_link]
-    -- This error message is not very good but .bkp mode is just for testing so
-    -- better to be direct rather than pretty.
-    when
-      (length key_nodes /= length (ordNub key_nodes))
-      (pprPanic "Duplicate nodes keys in backpack file" (ppr key_nodes))
-
-    -- 3. Return the kaboodle
-    return $ mkModuleGraph $ all_nodes
-
-
-summariseRequirement :: PackageName -> ModuleName -> BkpM ModuleGraphNode
-summariseRequirement pn mod_name = do
-    hsc_env <- getSession
-    let dflags = hsc_dflags hsc_env
-    let home_unit = hsc_home_unit hsc_env
-    let fopts = initFinderOpts dflags
-
-    let PackageName pn_fs = pn
-    let location = mkHomeModLocation2 fopts mod_name
-                    (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"
-
-    env <- getBkpEnv
-    src_hash <- liftIO $ getFileHash (bkp_filename env)
-    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
-    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
-    let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
-
-    let fc = hsc_FC hsc_env
-    mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location
-
-    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
-
-    let ms = ModSummary {
-        ms_mod = mod,
-        ms_hsc_src = HsigFile,
-        ms_location = location,
-        ms_hs_hash = src_hash,
-        ms_obj_date = Nothing,
-        ms_dyn_obj_date = Nothing,
-        ms_iface_date = hi_timestamp,
-        ms_hie_date = hie_timestamp,
-        ms_srcimps = [],
-        ms_textual_imps = ((,) NoPkgQual . noLoc) <$> extra_sig_imports,
-        ms_ghc_prim_import = False,
-        ms_parsed_mod = Just (HsParsedModule {
-                hpm_module = L loc (HsModule {
-                        hsmodExt = XModulePs {
-                            hsmodAnn = noAnn,
-                            hsmodLayout = NoLayoutInfo,
-                            hsmodDeprecMessage = Nothing,
-                            hsmodHaddockModHeader = Nothing
-                                             },
-                        hsmodName = Just (L (noAnnSrcSpan loc) mod_name),
-                        hsmodExports = Nothing,
-                        hsmodImports = [],
-                        hsmodDecls = []
-                    }),
-                hpm_src_files = []
-            }),
-        ms_hspp_file = "", -- none, it came inline
-        ms_hspp_opts = dflags,
-        ms_hspp_buf = Nothing
-        }
-    let nodes = [NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit)) | mn <- extra_sig_imports ]
-    return (ModuleNode nodes ms)
-
-summariseDecl :: PackageName
-              -> HscSource
-              -> Located ModuleName
-              -> Located (HsModule GhcPs)
-              -> [NodeKey]
-              -> BkpM ModuleGraphNode
-summariseDecl pn hsc_src (L _ modname) hsmod home_keys = hsModuleToModSummary home_keys pn hsc_src modname hsmod
-
--- | Up until now, GHC has assumed a single compilation target per source file.
--- Backpack files with inline modules break this model, since a single file
--- may generate multiple output files.  How do we decide to name these files?
--- Should there only be one output file? This function our current heuristic,
--- which is we make a "fake" module and use that.
-hsModuleToModSummary :: [NodeKey]
-                     -> PackageName
-                     -> HscSource
-                     -> ModuleName
-                     -> Located (HsModule GhcPs)
-                     -> BkpM ModuleGraphNode
-hsModuleToModSummary home_keys pn hsc_src modname
-                     hsmod = do
-    let imps = hsmodImports (unLoc hsmod)
-        loc  = getLoc hsmod
-    hsc_env <- getSession
-    -- Sort of the same deal as in GHC.Driver.Pipeline's getLocation
-    -- Use the PACKAGE NAME to find the location
-    let PackageName unit_fs = pn
-        dflags = hsc_dflags hsc_env
-        fopts = initFinderOpts dflags
-    -- Unfortunately, we have to define a "fake" location in
-    -- order to appease the various code which uses the file
-    -- name to figure out where to put, e.g. object files.
-    -- To add insult to injury, we don't even actually use
-    -- these filenames to figure out where the hi files go.
-    -- A travesty!
-    let location0 = mkHomeModLocation2 fopts modname
-                             (unpackFS unit_fs </>
-                              moduleNameSlashes modname)
-                              (case hsc_src of
-                                HsigFile -> "hsig"
-                                HsBootFile -> "hs-boot"
-                                HsSrcFile -> "hs")
-    -- DANGEROUS: bootifying can POISON the module finder cache
-    let location = case hsc_src of
-                        HsBootFile -> addBootSuffixLocnOut location0
-                        _ -> location0
-    -- This duplicates a pile of logic in GHC.Driver.Make
-    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
-    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
-
-    -- Also copied from 'getImports'
-    let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
-
-             -- GHC.Prim doesn't exist physically, so don't go looking for it.
-        (ordinary_imps, ghc_prim_import)
-          = partition ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
-              ord_idecls
-
-        implicit_prelude = xopt LangExt.ImplicitPrelude dflags
-        implicit_imports = mkPrelImports modname loc
-                                         implicit_prelude imps
-
-        rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
-        convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
-
-    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
-
-    let normal_imports = map convImport (implicit_imports ++ ordinary_imps)
-    (implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env normal_imports
-
-    -- So that Finder can find it, even though it doesn't exist...
-    this_mod <- liftIO $ do
-      let home_unit = hsc_home_unit hsc_env
-      let fc        = hsc_FC hsc_env
-      addHomeModuleToFinder fc home_unit modname location
-    let ms = ModSummary {
-            ms_mod = this_mod,
-            ms_hsc_src = hsc_src,
-            ms_location = location,
-            ms_hspp_file = (case hiDir dflags of
-                            Nothing -> ""
-                            Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",
-            ms_hspp_opts = dflags,
-            ms_hspp_buf = Nothing,
-            ms_srcimps = map convImport src_idecls,
-            ms_ghc_prim_import = not (null ghc_prim_import),
-            ms_textual_imps = normal_imports
-                           -- We have to do something special here:
-                           -- due to merging, requirements may end up with
-                           -- extra imports
-                           ++ ((,) NoPkgQual . noLoc <$> extra_sig_imports)
-                           ++ ((,) NoPkgQual . noLoc <$> implicit_sigs),
-            -- This is our hack to get the parse tree to the right spot
-            ms_parsed_mod = Just (HsParsedModule {
-                    hpm_module = hsmod,
-                    hpm_src_files = [] -- TODO if we preprocessed it
-                }),
-            -- Source hash = fingerprint0, so the recompilation tests do not recompile
-            -- too much. In future, if necessary then could get the hash by just hashing the
-            -- relevant part of the .bkp file.
-            ms_hs_hash = fingerprint0,
-            ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
-            ms_dyn_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
-            ms_iface_date = hi_timestamp,
-            ms_hie_date = hie_timestamp
-          }
-
-    -- Now, what are the dependencies.
-    let inst_nodes = map NodeKey_Unit inst_deps
-        mod_nodes  =
-          -- hs-boot edge
-          [k | k <- [NodeKey_Module (ModNodeKeyWithUid (GWIB (ms_mod_name ms) IsBoot)  (moduleUnitId this_mod))], NotBoot == isBootSummary ms,  k `elem` home_keys ] ++
-          -- Normal edges
-          [k | (_, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys]
-
-
-    return (ModuleNode (mod_nodes ++ inst_nodes) ms)
-
--- | Create a new, externally provided hashed unit id from
--- a hash.
-newUnitId :: UnitId -> Maybe FastString -> UnitId
-newUnitId uid mhash = case mhash of
-   Nothing   -> uid
-   Just hash -> UnitId (concatFS [unitIdFS uid, fsLit "+", hash])
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ /dev/null
@@ -1,400 +0,0 @@
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-
-\section{Code output phase}
--}
-
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module GHC.Driver.CodeOutput
-   ( codeOutput
-   , outputForeignStubs
-   , profilingInitCode
-   , ipInitCode
-   )
-where
-
-import GHC.Prelude
-import GHC.Platform
-import GHC.ForeignSrcLang
-import GHC.Data.FastString
-
-import GHC.CmmToAsm     ( nativeCodeGen )
-import GHC.CmmToLlvm    ( llvmCodeGen )
-
-import GHC.CmmToC           ( cmmToC )
-import GHC.Cmm.Lint         ( cmmLint )
-import GHC.Cmm
-import GHC.Cmm.CLabel
-
-import GHC.Driver.Session
-import GHC.Driver.Config.Finder    ( initFinderOpts   )
-import GHC.Driver.Config.CmmToAsm  ( initNCGConfig    )
-import GHC.Driver.Config.CmmToLlvm ( initLlvmCgConfig )
-import GHC.Driver.LlvmConfigCache  (LlvmConfigCache)
-import GHC.Driver.Ppr
-import GHC.Driver.Backend
-
-import qualified GHC.Data.ShortText as ST
-import GHC.Data.Stream           ( Stream )
-import qualified GHC.Data.Stream as Stream
-
-import GHC.Utils.TmpFs
-
-
-import GHC.Utils.Error
-import GHC.Utils.Outputable
-import GHC.Utils.Logger
-import GHC.Utils.Exception ( bracket )
-import GHC.Utils.Ppr (Mode(..))
-import GHC.Utils.Panic.Plain ( pgmError )
-
-import GHC.Unit
-import GHC.Unit.Finder      ( mkStubPaths )
-
-import GHC.Types.SrcLoc
-import GHC.Types.CostCentre
-import GHC.Types.ForeignStubs
-import GHC.Types.Unique.Supply ( mkSplitUniqSupply )
-
-import System.Directory
-import System.FilePath
-import System.IO
-import Data.Set (Set)
-import qualified Data.Set as Set
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Steering}
-*                                                                      *
-************************************************************************
--}
-
-codeOutput
-    :: forall a.
-       Logger
-    -> TmpFs
-    -> LlvmConfigCache
-    -> DynFlags
-    -> UnitState
-    -> Module
-    -> FilePath
-    -> ModLocation
-    -> (a -> ForeignStubs)
-    -> [(ForeignSrcLang, FilePath)]
-    -- ^ additional files to be compiled with the C compiler
-    -> Set UnitId -- ^ Dependencies
-    -> Stream IO RawCmmGroup a                       -- Compiled C--
-    -> IO (FilePath,
-           (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
-           [(ForeignSrcLang, FilePath)]{-foreign_fps-},
-           a)
-codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps
-  cmm_stream
-  =
-    do  {
-        -- Lint each CmmGroup as it goes past
-        ; let linted_cmm_stream =
-                 if gopt Opt_DoCmmLinting dflags
-                    then Stream.mapM do_lint cmm_stream
-                    else cmm_stream
-
-              do_lint cmm = withTimingSilent logger
-                  (text "CmmLint"<+>brackets (ppr this_mod))
-                  (const ()) $ do
-                { case cmmLint (targetPlatform dflags) cmm of
-                        Just err -> do { logMsg logger
-                                                   MCDump
-                                                   noSrcSpan
-                                                   $ withPprStyle defaultDumpStyle err
-                                       ; ghcExit logger 1
-                                       }
-                        Nothing  -> return ()
-                ; return cmm
-                }
-
-        ; let final_stream :: Stream IO RawCmmGroup (ForeignStubs, a)
-              final_stream = do
-                  { a <- linted_cmm_stream
-                  ; let stubs = genForeignStubs a
-                  ; emitInitializerDecls this_mod stubs
-                  ; return (stubs, a) }
-
-        ; (stubs, a) <- case backendCodeOutput (backend dflags) of
-                 NcgCodeOutput  -> outputAsm logger dflags this_mod location filenm
-                                             final_stream
-                 ViaCCodeOutput -> outputC logger dflags filenm final_stream pkg_deps
-                 LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm final_stream
-                 JSCodeOutput   -> outputJS logger llvm_config dflags filenm final_stream
-        ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs
-        ; return (filenm, stubs_exist, foreign_fps, a)
-        }
-
--- | See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details.
-emitInitializerDecls :: Module -> ForeignStubs -> Stream IO RawCmmGroup ()
-emitInitializerDecls this_mod (ForeignStubs _ cstub)
-  | initializers <- getInitializers cstub
-  , not $ null initializers =
-      let init_array = CmmData sect statics
-          lbl = mkInitializerArrayLabel this_mod
-          sect = Section InitArray lbl
-          statics = CmmStaticsRaw lbl
-            [ CmmStaticLit $ CmmLabel fn_name
-            | fn_name <- initializers
-            ]
-    in Stream.yield [init_array]
-emitInitializerDecls _ _ = return ()
-
-doOutput :: String -> (Handle -> IO a) -> IO a
-doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{C}
-*                                                                      *
-************************************************************************
--}
-
-outputC :: Logger
-        -> DynFlags
-        -> FilePath
-        -> Stream IO RawCmmGroup a
-        -> Set UnitId
-        -> IO a
-outputC logger dflags filenm cmm_stream unit_deps =
-  withTiming logger (text "C codegen") (\a -> seq a () {- FIXME -}) $ do
-    let pkg_names = map unitIdString (Set.toAscList unit_deps)
-    doOutput filenm $ \ h -> do
-      hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
-      hPutStr h "#include \"Stg.h\"\n"
-      let platform = targetPlatform dflags
-          writeC cmm = do
-            let doc = cmmToC platform cmm
-            putDumpFileMaybe logger Opt_D_dump_c_backend
-                          "C backend output"
-                          FormatC
-                          doc
-            let ctx = initSDocContext dflags PprCode
-            printSDocLn ctx LeftMode h doc
-      Stream.consume cmm_stream id writeC
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Assembler}
-*                                                                      *
-************************************************************************
--}
-
-outputAsm :: Logger
-          -> DynFlags
-          -> Module
-          -> ModLocation
-          -> FilePath
-          -> Stream IO RawCmmGroup a
-          -> IO a
-outputAsm logger dflags this_mod location filenm cmm_stream = do
-  ncg_uniqs <- mkSplitUniqSupply 'n'
-  debugTraceMsg logger 4 (text "Outputing asm to" <+> text filenm)
-  let ncg_config = initNCGConfig dflags this_mod
-  {-# SCC "OutputAsm" #-} doOutput filenm $
-    \h -> {-# SCC "NativeCodeGen" #-}
-      nativeCodeGen logger ncg_config location h ncg_uniqs cmm_stream
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{LLVM}
-*                                                                      *
-************************************************************************
--}
-
-outputLlvm :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
-outputLlvm logger llvm_config dflags filenm cmm_stream = do
-  lcg_config <- initLlvmCgConfig logger llvm_config dflags
-  {-# SCC "llvm_output" #-} doOutput filenm $
-    \f -> {-# SCC "llvm_CodeGen" #-}
-      llvmCodeGen logger lcg_config f cmm_stream
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{JavaScript}
-*                                                                      *
-************************************************************************
--}
-outputJS :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a
-outputJS _ _ _ _ _ = pgmError $ "codeOutput: Hit JavaScript case. We should never reach here!"
-                              ++ "\nThe JS backend should shortcircuit to StgToJS after Stg."
-                              ++ "\nIf you reached this point then you've somehow made it to Cmm!"
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Foreign import/export}
-*                                                                      *
-************************************************************************
--}
-
-{-
-Note [Packaging libffi headers]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The C code emitted by GHC for libffi adjustors must depend upon the ffi_arg type,
-defined in <ffi.h>. For this reason, we must ensure that <ffi.h> is available
-in binary distributions. To do so, we install these headers as part of the
-`rts` package.
--}
-
-outputForeignStubs
-    :: Logger
-    -> TmpFs
-    -> DynFlags
-    -> UnitState
-    -> Module
-    -> ModLocation
-    -> ForeignStubs
-    -> IO (Bool,         -- Header file created
-           Maybe FilePath) -- C file created
-outputForeignStubs logger tmpfs dflags unit_state mod location stubs
- = do
-   let stub_h = mkStubPaths (initFinderOpts dflags) (moduleName mod) location
-   stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
-
-   case stubs of
-     NoStubs ->
-        return (False, Nothing)
-
-     ForeignStubs (CHeader h_code) (CStub c_code _ _) -> do
-        let
-            stub_c_output_d = pprCode c_code
-            stub_c_output_w = showSDoc dflags stub_c_output_d
-
-            -- Header file protos for "foreign export"ed functions.
-            stub_h_output_d = pprCode h_code
-            stub_h_output_w = showSDoc dflags stub_h_output_d
-
-        createDirectoryIfMissing True (takeDirectory stub_h)
-
-        putDumpFileMaybe logger Opt_D_dump_foreign
-                      "Foreign export header file"
-                      FormatC
-                      stub_h_output_d
-
-        -- we need the #includes from the rts package for the stub files
-        let rts_includes =
-               let mrts_pkg = lookupUnitId unit_state rtsUnitId
-                   mk_include i = "#include \"" ++ ST.unpack i ++ "\"\n"
-               in case mrts_pkg of
-                    Just rts_pkg -> concatMap mk_include (unitIncludes rts_pkg)
-                    -- This case only happens when compiling foreign stub for the rts
-                    -- library itself. The only time we do this at the moment is for
-                    -- IPE information for the RTS info tables
-                    Nothing -> ""
-
-            -- wrapper code mentions the ffi_arg type, which comes from ffi.h
-            ffi_includes
-              | platformMisc_libFFI $ platformMisc dflags = "#include <ffi.h>\n"
-              | otherwise = ""
-
-        stub_h_file_exists
-           <- outputForeignStubs_help stub_h stub_h_output_w
-                ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr
-
-        putDumpFileMaybe logger Opt_D_dump_foreign
-                      "Foreign export stubs" FormatC stub_c_output_d
-
-        stub_c_file_exists
-           <- outputForeignStubs_help stub_c stub_c_output_w
-                ("#define IN_STG_CODE 0\n" ++
-                 "#include <Rts.h>\n" ++
-                 rts_includes ++
-                 ffi_includes ++
-                 cplusplus_hdr)
-                 cplusplus_ftr
-           -- We're adding the default hc_header to the stub file, but this
-           -- isn't really HC code, so we need to define IN_STG_CODE==0 to
-           -- avoid the register variables etc. being enabled.
-
-        return (stub_h_file_exists, if stub_c_file_exists
-                                       then Just stub_c
-                                       else Nothing )
- where
-   cplusplus_hdr = "#if defined(__cplusplus)\nextern \"C\" {\n#endif\n"
-   cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n"
-
-
--- It is more than likely that the stubs file will
--- turn out to be empty, in which case no file should be created.
-outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
-outputForeignStubs_help _fname ""      _header _footer = return False
-outputForeignStubs_help fname doc_str header footer
-   = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
-        return True
-
--- -----------------------------------------------------------------------------
--- Initialising cost centres
-
--- We must produce declarations for the cost-centres defined in this
--- module;
-
--- | Generate code to initialise cost centres
-profilingInitCode :: Platform -> Module -> CollectedCCs -> CStub
-profilingInitCode platform this_mod (local_CCs, singleton_CCSs)
- = {-# SCC profilingInitCode #-}
-   initializerCStub platform fn_name decls body
- where
-   pdocC = pprCLabel platform
-   fn_name = mkInitializerStubLabel this_mod (fsLit "prof_init")
-   decls = vcat
-        $  map emit_cc_decl local_CCs
-        ++ map emit_ccs_decl singleton_CCSs
-        ++ [emit_cc_list local_CCs]
-        ++ [emit_ccs_list singleton_CCSs]
-   body = vcat
-        [ text "registerCcList" <> parens local_cc_list_label <> semi
-        , text "registerCcsList" <> parens singleton_cc_list_label <> semi
-        ]
-   emit_cc_decl cc =
-       text "extern CostCentre" <+> cc_lbl <> text "[];"
-     where cc_lbl = pdocC (mkCCLabel cc)
-   local_cc_list_label = text "local_cc_" <> ppr this_mod
-   emit_cc_list ccs =
-      text "static CostCentre *" <> local_cc_list_label <> text "[] ="
-      <+> braces (vcat $ [ pdocC (mkCCLabel cc) <> comma
-                         | cc <- ccs
-                         ] ++ [text "NULL"])
-      <> semi
-
-   emit_ccs_decl ccs =
-       text "extern CostCentreStack" <+> ccs_lbl <> text "[];"
-     where ccs_lbl = pdocC (mkCCSLabel ccs)
-   singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod
-   emit_ccs_list ccs =
-      text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] ="
-      <+> braces (vcat $ [ pdocC (mkCCSLabel cc) <> comma
-                         | cc <- ccs
-                         ] ++ [text "NULL"])
-      <> semi
-
--- | Generate code to initialise info pointer origin
--- See Note [Mapping Info Tables to Source Positions]
-ipInitCode
-  :: Bool            -- is Opt_InfoTableMap enabled or not
-  -> Platform
-  -> Module
-  -> CStub
-ipInitCode do_info_table platform this_mod
-  | not do_info_table = mempty
-  | otherwise = initializerCStub platform fn_nm ipe_buffer_decl body
- where
-   fn_nm = mkInitializerStubLabel this_mod (fsLit "ip_init")
-
-   body = text "registerInfoProvList" <> parens (text "&" <> ipe_buffer_label) <> semi
-
-   ipe_buffer_label = pprCLabel platform (mkIPELabel this_mod)
-
-   ipe_buffer_decl =
-       text "extern IpeBufferListNode" <+> ipe_buffer_label <> text ";"
-
diff --git a/compiler/GHC/Driver/Config/Cmm.hs b/compiler/GHC/Driver/Config/Cmm.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/Cmm.hs
+++ /dev/null
@@ -1,33 +0,0 @@
-module GHC.Driver.Config.Cmm
-  ( initCmmConfig
-  ) where
-
-import GHC.Cmm.Config
-
-import GHC.Driver.Session
-import GHC.Driver.Backend
-
-import GHC.Platform
-
-import GHC.Prelude
-
-initCmmConfig :: DynFlags -> CmmConfig
-initCmmConfig dflags = CmmConfig
-  { cmmProfile             = targetProfile                dflags
-  , cmmOptControlFlow      = gopt Opt_CmmControlFlow      dflags
-  , cmmDoLinting           = gopt Opt_DoCmmLinting        dflags
-  , cmmOptElimCommonBlks   = gopt Opt_CmmElimCommonBlocks dflags
-  , cmmOptSink             = gopt Opt_CmmSink             dflags
-  , cmmGenStackUnwindInstr = debugLevel dflags > 0
-  , cmmExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
-  , cmmDoCmmSwitchPlans    = not (backendHasNativeSwitch (backend dflags))
-                             || platformArch platform == ArchWasm32
-  , cmmSplitProcPoints     = not (backendSupportsUnsplitProcPoints (backend dflags))
-                             || not (platformTablesNextToCode platform)
-                             || usingInconsistentPicReg
-  }
-  where platform                = targetPlatform dflags
-        usingInconsistentPicReg =
-          case (platformArch platform, platformOS platform, positionIndependent dflags)
-          of   (ArchX86, OSDarwin, pic) -> pic
-               _                        -> False
diff --git a/compiler/GHC/Driver/Config/Cmm/Parser.hs b/compiler/GHC/Driver/Config/Cmm/Parser.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/Cmm/Parser.hs
+++ /dev/null
@@ -1,25 +0,0 @@
-module GHC.Driver.Config.Cmm.Parser
-  ( initCmmParserConfig
-  ) where
-
-import GHC.Cmm.Parser.Config
-
-import GHC.Driver.Config.Parser
-import GHC.Driver.Config.StgToCmm
-import GHC.Driver.Session
-
-import GHC.Utils.Panic
-
-initPDConfig :: DynFlags -> PDConfig
-initPDConfig dflags = PDConfig
-  { pdProfile = targetProfile dflags
-  , pdSanitizeAlignment = gopt Opt_AlignmentSanitisation dflags
-  }
-
-initCmmParserConfig :: DynFlags -> CmmParserConfig
-initCmmParserConfig dflags = CmmParserConfig
-  { cmmpParserOpts = initParserOpts dflags
-  , cmmpPDConfig = initPDConfig dflags
-  , cmmpStgToCmmConfig = initStgToCmmConfig dflags (panic "initCmmParserConfig: no module")
-  }
-
diff --git a/compiler/GHC/Driver/Config/CmmToAsm.hs b/compiler/GHC/Driver/Config/CmmToAsm.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/CmmToAsm.hs
+++ /dev/null
@@ -1,75 +0,0 @@
-module GHC.Driver.Config.CmmToAsm
-  ( initNCGConfig
-  )
-where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-
-import GHC.Platform
-import GHC.Unit.Types (Module)
-import GHC.CmmToAsm.Config
-import GHC.Utils.Outputable
-import GHC.CmmToAsm.BlockLayout
-
--- | Initialize the native code generator configuration from the DynFlags
-initNCGConfig :: DynFlags -> Module -> NCGConfig
-initNCGConfig dflags this_mod = NCGConfig
-   { ncgPlatform              = targetPlatform dflags
-   , ncgThisModule            = this_mod
-   , ncgAsmContext            = initSDocContext dflags PprCode
-   , ncgProcAlignment         = cmmProcAlignment dflags
-   , ncgExternalDynamicRefs   = gopt Opt_ExternalDynamicRefs dflags
-   , ncgPIC                   = positionIndependent dflags
-   , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags
-   , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags
-   , ncgSplitSections         = gopt Opt_SplitSections dflags
-   , ncgRegsIterative         = gopt Opt_RegsIterative dflags
-   , ncgRegsGraph             = gopt Opt_RegsGraph dflags
-   , ncgAsmLinting            = gopt Opt_DoAsmLinting dflags
-   , ncgCfgWeights            = cfgWeights dflags
-   , ncgCfgBlockLayout        = gopt Opt_CfgBlocklayout dflags
-   , ncgCfgWeightlessLayout   = gopt Opt_WeightlessBlocklayout dflags
-
-     -- When constant-folding is enabled, the cmmSink pass does constant-folding, so
-     -- we don't need to do it again in the native code generator.
-   , ncgDoConstantFolding     = not (gopt Opt_CoreConstantFolding dflags || gopt Opt_CmmSink dflags)
-
-   , ncgDumpRegAllocStages    = dopt Opt_D_dump_asm_regalloc_stages dflags
-   , ncgDumpAsmStats          = dopt Opt_D_dump_asm_stats dflags
-   , ncgDumpAsmConflicts      = dopt Opt_D_dump_asm_conflicts dflags
-   , ncgBmiVersion            = case platformArch (targetPlatform dflags) of
-                                 ArchX86_64 -> bmiVersion dflags
-                                 ArchX86    -> bmiVersion dflags
-                                 _          -> Nothing
-
-     -- We assume  SSE1 and SSE2 operations are available on both
-     -- x86 and x86_64. Historically we didn't default to SSE2 and
-     -- SSE1 on x86, which results in defacto nondeterminism for how
-     -- rounding behaves in the associated x87 floating point instructions
-     -- because variations in the spill/fpu stack placement of arguments for
-     -- operations would change the precision and final result of what
-     -- would otherwise be the same expressions with respect to single or
-     -- double precision IEEE floating point computations.
-   , ncgSseVersion =
-      let v | sseVersion dflags < Just SSE2 = Just SSE2
-            | otherwise                     = sseVersion dflags
-      in case platformArch (targetPlatform dflags) of
-            ArchX86_64 -> v
-            ArchX86    -> v
-            _          -> Nothing
-
-   , ncgDwarfEnabled        = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 && platformArch (targetPlatform dflags) /= ArchAArch64
-   , ncgDwarfUnwindings     = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0
-   , ncgDwarfStripBlockInfo = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1.
-   , ncgDwarfSourceNotes    = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 2 -- We produce GHC-specific source-note DIEs only with -g3
-   , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags
-   , ncgCmmStaticPred       = gopt Opt_CmmStaticPred dflags
-   , ncgEnableShortcutting  = gopt Opt_AsmShortcutting dflags
-   , ncgComputeUnwinding    = debugLevel dflags > 0
-   , ncgEnableDeadCodeElimination = not (gopt Opt_InfoTableMap dflags)
-                                     -- Disable when -finfo-table-map is on (#20428)
-                                     && backendMaintainsCfg (targetPlatform dflags)
-                                     -- Enable if the platform maintains the CFG
-   }
diff --git a/compiler/GHC/Driver/Config/CmmToLlvm.hs b/compiler/GHC/Driver/Config/CmmToLlvm.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/CmmToLlvm.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-module GHC.Driver.Config.CmmToLlvm
-  ( initLlvmCgConfig
-  )
-where
-
-import GHC.Prelude
-import GHC.Driver.Session
-import GHC.Driver.LlvmConfigCache
-import GHC.Platform
-import GHC.CmmToLlvm.Config
-import GHC.SysTools.Tasks
-
-import GHC.Utils.Outputable
-import GHC.Utils.Logger
-
--- | Initialize the Llvm code generator configuration from DynFlags
-initLlvmCgConfig :: Logger -> LlvmConfigCache -> DynFlags -> IO LlvmCgConfig
-initLlvmCgConfig logger config_cache dflags = do
-  version <- figureLlvmVersion logger dflags
-  llvm_config <- readLlvmConfigCache config_cache
-  pure $! LlvmCgConfig {
-    llvmCgPlatform               = targetPlatform dflags
-    , llvmCgContext              = initSDocContext dflags PprCode
-    , llvmCgFillUndefWithGarbage = gopt Opt_LlvmFillUndefWithGarbage dflags
-    , llvmCgSplitSection         = gopt Opt_SplitSections dflags
-    , llvmCgBmiVersion           = case platformArch (targetPlatform dflags) of
-                                      ArchX86_64 -> bmiVersion dflags
-                                      ArchX86    -> bmiVersion dflags
-                                      _          -> Nothing
-    , llvmCgLlvmVersion          = version
-    , llvmCgDoWarn               = wopt Opt_WarnUnsupportedLlvmVersion dflags
-    , llvmCgLlvmTarget           = platformMisc_llvmTarget $! platformMisc dflags
-    , llvmCgLlvmConfig           = llvm_config
-    }
diff --git a/compiler/GHC/Driver/Config/Core/Lint/Interactive.hs b/compiler/GHC/Driver/Config/Core/Lint/Interactive.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/Core/Lint/Interactive.hs
+++ /dev/null
@@ -1,35 +0,0 @@
-module GHC.Driver.Config.Core.Lint.Interactive
-  ( lintInteractiveExpr
-  ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Env
-import GHC.Driver.Session
-import GHC.Driver.Config.Core.Lint
-
-import GHC.Core
-import GHC.Core.Ppr
-
-import GHC.Core.Lint
-import GHC.Core.Lint.Interactive
-
---import GHC.Runtime.Context
-
-import GHC.Data.Bag
-
-import GHC.Utils.Outputable as Outputable
-
-lintInteractiveExpr :: SDoc -- ^ The source of the linted expression
-                    -> HscEnv
-                    -> CoreExpr -> IO ()
-lintInteractiveExpr what hsc_env expr
-  | not (gopt Opt_DoCoreLinting dflags)
-  = return ()
-  | Just err <- lintExpr (initLintConfig dflags $ interactiveInScope $ hsc_IC hsc_env) expr
-  = displayLintResults logger False what (pprCoreExpr expr) (emptyBag, err)
-  | otherwise
-  = return ()
-  where
-    dflags = hsc_dflags hsc_env
-    logger = hsc_logger hsc_env
diff --git a/compiler/GHC/Driver/Config/Core/Opt/Arity.hs b/compiler/GHC/Driver/Config/Core/Opt/Arity.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/Core/Opt/Arity.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-module GHC.Driver.Config.Core.Opt.Arity
-  ( initArityOpts
-  ) where
-
-import GHC.Prelude ()
-
-import GHC.Driver.Session
-
-import GHC.Core.Opt.Arity
-
-initArityOpts :: DynFlags -> ArityOpts
-initArityOpts dflags = ArityOpts
-  { ao_ped_bot = gopt Opt_PedanticBottoms dflags
-  , ao_dicts_cheap = gopt Opt_DictsCheap dflags
-  }
diff --git a/compiler/GHC/Driver/Config/Core/Opt/LiberateCase.hs b/compiler/GHC/Driver/Config/Core/Opt/LiberateCase.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/Core/Opt/LiberateCase.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-module GHC.Driver.Config.Core.Opt.LiberateCase
-  ( initLiberateCaseOpts
-  ) where
-
-import GHC.Driver.Session
-
-import GHC.Core.Opt.LiberateCase ( LibCaseOpts(..) )
-
--- | Initialize configuration for the liberate case Core optomization
--- pass.
-initLiberateCaseOpts :: DynFlags -> LibCaseOpts
-initLiberateCaseOpts dflags = LibCaseOpts
-  { lco_threshold = liberateCaseThreshold dflags
-  , lco_unfolding_opts = unfoldingOpts dflags
-  }
diff --git a/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs b/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/Core/Opt/Simplify.hs
+++ /dev/null
@@ -1,85 +0,0 @@
-module GHC.Driver.Config.Core.Opt.Simplify
-  ( initSimplifyExprOpts
-  , initSimplifyOpts
-  , initSimplMode
-  ) where
-
-import GHC.Prelude
-
-import GHC.Core.Rules ( RuleBase )
-import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )
-import GHC.Core.Opt.Simplify ( SimplifyExprOpts(..), SimplifyOpts(..) )
-import GHC.Core.Opt.Simplify.Env ( FloatEnable(..), SimplMode(..) )
-import GHC.Core.Opt.Simplify.Monad ( TopEnvConfig(..) )
-
-import GHC.Driver.Config ( initOptCoercionOpts )
-import GHC.Driver.Config.Core.Lint ( initLintPassResultConfig )
-import GHC.Driver.Config.Core.Rules ( initRuleOpts )
-import GHC.Driver.Config.Core.Opt.Arity ( initArityOpts )
-import GHC.Driver.Session ( DynFlags(..), GeneralFlag(..), gopt )
-
-import GHC.Runtime.Context ( InteractiveContext(..) )
-
-import GHC.Types.Basic ( CompilerPhase(..) )
-import GHC.Types.Var ( Var )
-
-initSimplifyExprOpts :: DynFlags -> InteractiveContext -> SimplifyExprOpts
-initSimplifyExprOpts dflags ic = SimplifyExprOpts
-  { se_fam_inst = snd $ ic_instances ic
-
-  , se_mode = (initSimplMode dflags) { sm_names = ["GHCi"]
-                                     , sm_inline = False }
-      -- sm_inline: do not do any inlining, in case we expose
-      -- some unboxed tuple stuff that confuses the bytecode
-      -- interpreter
-
-  , se_top_env_cfg = TopEnvConfig
-    { te_history_size = historySize dflags
-    , te_tick_factor = simplTickFactor dflags
-    }
-  }
-
-initSimplifyOpts :: DynFlags -> [Var] -> Int -> SimplMode -> RuleBase -> SimplifyOpts
-initSimplifyOpts dflags extra_vars iterations mode hpt_rule_base = let
-  -- This is a particularly ugly construction, but we will get rid of it in !8341.
-  opts = SimplifyOpts
-    { so_dump_core_sizes = not $ gopt Opt_SuppressCoreSizes dflags
-    , so_iterations      = iterations
-    , so_mode            = mode
-    , so_pass_result_cfg = if gopt Opt_DoCoreLinting dflags
-                           then Just $ initLintPassResultConfig dflags extra_vars
-                                                            (CoreDoSimplify opts)
-                           else Nothing
-    , so_hpt_rules       = hpt_rule_base
-    , so_top_env_cfg     = TopEnvConfig { te_history_size = historySize dflags
-                                        , te_tick_factor = simplTickFactor dflags }
-    }
-  in opts
-
-initSimplMode :: DynFlags -> SimplMode
-initSimplMode dflags = SimplMode
-  { sm_names = ["Unknown simplifier run"]  -- Always overriden
-  , sm_phase = InitialPhase
-  , sm_rules            = gopt Opt_EnableRewriteRules dflags
-  , sm_eta_expand       = gopt Opt_DoLambdaEtaExpansion dflags
-  , sm_pre_inline       = gopt Opt_SimplPreInlining dflags
-  , sm_do_eta_reduction = gopt Opt_DoEtaReduction dflags
-  , sm_uf_opts          = unfoldingOpts dflags
-  , sm_float_enable     = floatEnable dflags
-  , sm_arity_opts       = initArityOpts dflags
-  , sm_rule_opts        = initRuleOpts dflags
-  , sm_case_folding     = gopt Opt_CaseFolding dflags
-  , sm_case_merge       = gopt Opt_CaseMerge dflags
-  , sm_co_opt_opts      = initOptCoercionOpts dflags
-  , sm_cast_swizzle = True
-  , sm_inline       = True
-  , sm_case_case    = True
-  , sm_keep_exits   = False
-  }
-
-floatEnable :: DynFlags -> FloatEnable
-floatEnable dflags =
-  case (gopt Opt_LocalFloatOut dflags, gopt Opt_LocalFloatOutTopLevel dflags) of
-    (True, True) -> FloatEnabled
-    (True, False)-> FloatNestedOnly
-    (False, _)   -> FloatDisabled
diff --git a/compiler/GHC/Driver/Config/Core/Opt/WorkWrap.hs b/compiler/GHC/Driver/Config/Core/Opt/WorkWrap.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/Core/Opt/WorkWrap.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module GHC.Driver.Config.Core.Opt.WorkWrap
-  ( initWorkWrapOpts
-  ) where
-
-import GHC.Prelude ()
-
-import GHC.Driver.Config (initSimpleOpts)
-import GHC.Driver.Session
-
-import GHC.Core.FamInstEnv
-import GHC.Core.Opt.WorkWrap
-import GHC.Unit.Types
-
-initWorkWrapOpts :: Module -> DynFlags -> FamInstEnvs -> WwOpts
-initWorkWrapOpts this_mod dflags fam_envs = MkWwOpts
-  { wo_fam_envs          = fam_envs
-  , wo_simple_opts       = initSimpleOpts dflags
-  , wo_cpr_anal          = gopt Opt_CprAnal dflags
-  , wo_module            = this_mod
-  , wo_unlift_strict     = gopt Opt_WorkerWrapperUnlift dflags
-  }
diff --git a/compiler/GHC/Driver/Config/Core/Rules.hs b/compiler/GHC/Driver/Config/Core/Rules.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/Core/Rules.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module GHC.Driver.Config.Core.Rules
-  ( initRuleOpts
-  ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Flags
-import GHC.Driver.Session ( DynFlags, gopt, targetPlatform, homeUnitId_ )
-
-import GHC.Core.Rules.Config
-
-import GHC.Unit.Types     ( primUnitId, bignumUnitId )
-
--- | Initialize RuleOpts from DynFlags
-initRuleOpts :: DynFlags -> RuleOpts
-initRuleOpts dflags = RuleOpts
-  { roPlatform                = targetPlatform dflags
-  , roNumConstantFolding      = gopt Opt_NumConstantFolding dflags
-  , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags
-    -- disable bignum rules in ghc-prim and ghc-bignum itself
-  , roBignumRules             = homeUnitId_ dflags /= primUnitId
-                                && homeUnitId_ dflags /= bignumUnitId
-  }
diff --git a/compiler/GHC/Driver/Config/CoreToStg.hs b/compiler/GHC/Driver/Config/CoreToStg.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/CoreToStg.hs
+++ /dev/null
@@ -1,16 +0,0 @@
-module GHC.Driver.Config.CoreToStg where
-
-import GHC.Driver.Config.Stg.Debug
-import GHC.Driver.Session
-
-import GHC.CoreToStg
-
-initCoreToStgOpts :: DynFlags -> CoreToStgOpts
-initCoreToStgOpts dflags = CoreToStgOpts
-  { coreToStg_platform = targetPlatform dflags
-  , coreToStg_ways = ways dflags
-  , coreToStg_AutoSccsOnIndividualCafs = gopt Opt_AutoSccsOnIndividualCafs dflags
-  , coreToStg_InfoTableMap = gopt Opt_InfoTableMap dflags
-  , coreToStg_ExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
-  , coreToStg_stgDebugOpts = initStgDebugOpts dflags
-  }
diff --git a/compiler/GHC/Driver/Config/CoreToStg/Prep.hs b/compiler/GHC/Driver/Config/CoreToStg/Prep.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/CoreToStg/Prep.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-module GHC.Driver.Config.CoreToStg.Prep
-  ( initCorePrepConfig
-  , initCorePrepPgmConfig
-  ) where
-
-import GHC.Prelude
-
-import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )
-import GHC.Driver.Env
-import GHC.Driver.Session
-import GHC.Driver.Config.Core.Lint
-import GHC.Tc.Utils.Env
-import GHC.Types.Var
-import GHC.Utils.Outputable ( alwaysQualify )
-
-import GHC.CoreToStg.Prep
-
-initCorePrepConfig :: HscEnv -> IO CorePrepConfig
-initCorePrepConfig hsc_env = do
-   convertNumLit <- do
-     let platform = targetPlatform $ hsc_dflags hsc_env
-         home_unit = hsc_home_unit hsc_env
-         lookup_global = lookupGlobal hsc_env
-     mkConvertNumLiteral platform home_unit lookup_global
-   return $ CorePrepConfig
-      { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases $ hsc_dflags hsc_env
-      , cp_convertNumLit = convertNumLit
-      }
-
-initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig
-initCorePrepPgmConfig dflags extra_vars = CorePrepPgmConfig
-  { cpPgm_endPassConfig     = initEndPassConfig dflags extra_vars alwaysQualify CorePrep
-  , cpPgm_generateDebugInfo = needSourceNotes dflags
-  }
diff --git a/compiler/GHC/Driver/Config/Finder.hs b/compiler/GHC/Driver/Config/Finder.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/Finder.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-module GHC.Driver.Config.Finder (
-    FinderOpts(..),
-    initFinderOpts
-  ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-import GHC.Unit.Finder.Types
-import GHC.Data.FastString
-
-
--- | Create a new 'FinderOpts' from DynFlags.
-initFinderOpts :: DynFlags -> FinderOpts
-initFinderOpts flags = FinderOpts
-  { finder_importPaths = importPaths flags
-  , finder_lookupHomeInterfaces = isOneShot (ghcMode flags)
-  , finder_bypassHiFileCheck = MkDepend == (ghcMode flags)
-  , finder_ways = ways flags
-  , finder_enableSuggestions = gopt Opt_HelpfulErrors flags
-  , finder_workingDirectory = workingDirectory flags
-  , finder_thisPackageName  = mkFastString <$> thisPackageName flags
-  , finder_hiddenModules = hiddenModules flags
-  , finder_reexportedModules = reexportedModules flags
-  , finder_hieDir = hieDir flags
-  , finder_hieSuf = hieSuf flags
-  , finder_hiDir = hiDir flags
-  , finder_hiSuf = hiSuf_ flags
-  , finder_dynHiSuf = dynHiSuf_ flags
-  , finder_objectDir = objectDir flags
-  , finder_objectSuf = objectSuf_ flags
-  , finder_dynObjectSuf = dynObjectSuf_ flags
-  , finder_stubDir = stubDir flags
-  }
diff --git a/compiler/GHC/Driver/Config/HsToCore.hs b/compiler/GHC/Driver/Config/HsToCore.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/HsToCore.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module GHC.Driver.Config.HsToCore
-  ( initBangOpts
-  )
-where
-
-import GHC.Types.Id.Make
-import GHC.Driver.Session
-import qualified GHC.LanguageExtensions as LangExt
-
-initBangOpts :: DynFlags -> BangOpts
-initBangOpts dflags = BangOpts
-  { bang_opt_strict_data   = xopt LangExt.StrictData dflags
-  , bang_opt_unbox_disable = gopt Opt_OmitInterfacePragmas dflags
-      -- Don't unbox if we aren't optimising; rather arbitrarily,
-      -- we use -fomit-iface-pragmas as the indication
-  , bang_opt_unbox_strict  = gopt Opt_UnboxStrictFields dflags
-  , bang_opt_unbox_small   = gopt Opt_UnboxSmallStrictFields dflags
-  }
-
diff --git a/compiler/GHC/Driver/Config/HsToCore/Ticks.hs b/compiler/GHC/Driver/Config/HsToCore/Ticks.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/HsToCore/Ticks.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-module GHC.Driver.Config.HsToCore.Ticks
-  ( initTicksConfig
-  )
-where
-
-import GHC.Prelude
-
-import Data.Maybe (catMaybes)
-
-import GHC.Driver.Backend
-import GHC.Driver.Session
-import GHC.HsToCore.Ticks
-
-initTicksConfig :: DynFlags -> TicksConfig
-initTicksConfig dflags = TicksConfig
-  { ticks_passes       = coveragePasses dflags
-  , ticks_profAuto     = profAuto dflags
-  , ticks_countEntries = gopt Opt_ProfCountEntries dflags
-  }
-
-coveragePasses :: DynFlags -> [TickishType]
-coveragePasses dflags = catMaybes
-  [ ifA Breakpoints $ backendWantsBreakpointTicks $ backend dflags
-  , ifA HpcTicks $ gopt Opt_Hpc dflags
-  , ifA ProfNotes $ sccProfilingEnabled dflags && profAuto dflags /= NoProfAuto
-  , ifA SourceNotes $ needSourceNotes dflags
-  ]
-  where ifA x cond = if cond then Just x else Nothing
diff --git a/compiler/GHC/Driver/Config/HsToCore/Usage.hs b/compiler/GHC/Driver/Config/HsToCore/Usage.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/HsToCore/Usage.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module GHC.Driver.Config.HsToCore.Usage
-  ( initUsageConfig
-  )
-where
-
-import GHC.Driver.Env.Types
-import GHC.Driver.Session
-
-import GHC.HsToCore.Usage
-
-initUsageConfig :: HscEnv -> UsageConfig
-initUsageConfig hsc_env = UsageConfig
-  { uc_safe_implicit_imps_req = safeImplicitImpsReq (hsc_dflags hsc_env)
-  }
diff --git a/compiler/GHC/Driver/Config/Stg/Debug.hs b/compiler/GHC/Driver/Config/Stg/Debug.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/Stg/Debug.hs
+++ /dev/null
@@ -1,14 +0,0 @@
-module GHC.Driver.Config.Stg.Debug
-  ( initStgDebugOpts
-  ) where
-
-import GHC.Stg.Debug
-
-import GHC.Driver.Session
-
--- | Initialize STG pretty-printing options from DynFlags
-initStgDebugOpts :: DynFlags -> StgDebugOpts
-initStgDebugOpts dflags = StgDebugOpts
-  { stgDebug_infoTableMap = gopt Opt_InfoTableMap dflags
-  , stgDebug_distinctConstructorTables = gopt Opt_DistinctConstructorTables dflags
-  }
diff --git a/compiler/GHC/Driver/Config/Stg/Lift.hs b/compiler/GHC/Driver/Config/Stg/Lift.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/Stg/Lift.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-module GHC.Driver.Config.Stg.Lift
-  ( initStgLiftConfig
-  ) where
-
-import GHC.Stg.Lift.Config
-
-import GHC.Driver.Session
-
-initStgLiftConfig :: DynFlags -> StgLiftConfig
-initStgLiftConfig dflags = StgLiftConfig
-    { c_targetProfile      = targetProfile dflags
-    , c_liftLamsRecArgs    = liftLamsRecArgs dflags
-    , c_liftLamsNonRecArgs = liftLamsNonRecArgs dflags
-    , c_liftLamsKnown      = liftLamsKnown dflags
-    }
diff --git a/compiler/GHC/Driver/Config/Stg/Pipeline.hs b/compiler/GHC/Driver/Config/Stg/Pipeline.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/Stg/Pipeline.hs
+++ /dev/null
@@ -1,47 +0,0 @@
-module GHC.Driver.Config.Stg.Pipeline
-  ( initStgPipelineOpts
-  ) where
-
-import GHC.Prelude
-
-import Control.Monad (guard)
-
-import GHC.Stg.Pipeline
-
-import GHC.Driver.Config.Diagnostic
-import GHC.Driver.Config.Stg.Lift
-import GHC.Driver.Config.Stg.Ppr
-import GHC.Driver.Session
-
--- | Initialize STG pretty-printing options from DynFlags
-initStgPipelineOpts :: DynFlags -> Bool -> StgPipelineOpts
-initStgPipelineOpts dflags for_bytecode = StgPipelineOpts
-  { stgPipeline_lint = do
-      guard $ gopt Opt_DoStgLinting dflags
-      Just $ initDiagOpts dflags
-  , stgPipeline_pprOpts = initStgPprOpts dflags
-  , stgPipeline_phases = getStgToDo for_bytecode dflags
-  , stgPlatform = targetPlatform dflags
-  }
-
--- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.
-getStgToDo
-  :: Bool -- ^ Are we preparing for bytecode?
-  -> DynFlags
-  -> [StgToDo]
-getStgToDo for_bytecode dflags =
-  filter (/= StgDoNothing)
-    [ mandatory StgUnarise
-    -- Important that unarisation comes first
-    -- See Note [StgCse after unarisation] in GHC.Stg.CSE
-    , optional Opt_StgCSE StgCSE
-    , optional Opt_StgLiftLams $ StgLiftLams $ initStgLiftConfig dflags
-    , runWhen for_bytecode StgBcPrep
-    , optional Opt_StgStats StgStats
-    ] where
-      optional opt = runWhen (gopt opt dflags)
-      mandatory = id
-
-runWhen :: Bool -> StgToDo -> StgToDo
-runWhen True todo = todo
-runWhen _    _    = StgDoNothing
diff --git a/compiler/GHC/Driver/Config/Stg/Ppr.hs b/compiler/GHC/Driver/Config/Stg/Ppr.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/Stg/Ppr.hs
+++ /dev/null
@@ -1,13 +0,0 @@
-module GHC.Driver.Config.Stg.Ppr
-  ( initStgPprOpts
-  ) where
-
-import GHC.Stg.Syntax
-
-import GHC.Driver.Session
-
--- | Initialize STG pretty-printing options from DynFlags
-initStgPprOpts :: DynFlags -> StgPprOpts
-initStgPprOpts dflags = StgPprOpts
-   { stgSccEnabled = sccProfilingEnabled dflags
-   }
diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs b/compiler/GHC/Driver/Config/StgToCmm.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/StgToCmm.hs
+++ /dev/null
@@ -1,79 +0,0 @@
-module GHC.Driver.Config.StgToCmm
-  ( initStgToCmmConfig
-  ) where
-
-import GHC.Prelude.Basic
-
-import GHC.StgToCmm.Config
-
-import GHC.Driver.Backend
-import GHC.Driver.Session
-import GHC.Platform
-import GHC.Platform.Profile
-import GHC.Utils.Error
-import GHC.Unit.Module
-import GHC.Utils.Outputable
-
-initStgToCmmConfig :: DynFlags -> Module -> StgToCmmConfig
-initStgToCmmConfig dflags mod = StgToCmmConfig
-  -- settings
-  { stgToCmmProfile       = profile
-  , stgToCmmThisModule    = mod
-  , stgToCmmTmpDir        = tmpDir          dflags
-  , stgToCmmContext       = initSDocContext dflags defaultDumpStyle
-  , stgToCmmEmitDebugInfo = debugLevel      dflags > 0
-  , stgToCmmBinBlobThresh = b_blob
-  , stgToCmmMaxInlAllocSize = maxInlineAllocSize           dflags
-  -- ticky options
-  , stgToCmmDoTicky       = gopt Opt_Ticky                 dflags
-  , stgToCmmTickyAllocd   = gopt Opt_Ticky_Allocd          dflags
-  , stgToCmmTickyLNE      = gopt Opt_Ticky_LNE             dflags
-  , stgToCmmTickyDynThunk = gopt Opt_Ticky_Dyn_Thunk       dflags
-  , stgToCmmTickyTag      = gopt Opt_Ticky_Tag             dflags
-  -- flags
-  , stgToCmmLoopification = gopt Opt_Loopification         dflags
-  , stgToCmmAlignCheck    = gopt Opt_AlignmentSanitisation dflags
-  , stgToCmmOptHpc        = gopt Opt_Hpc                   dflags
-  , stgToCmmFastPAPCalls  = gopt Opt_FastPAPCalls          dflags
-  , stgToCmmSCCProfiling  = sccProfilingEnabled            dflags
-  , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling     dflags
-  , stgToCmmInfoTableMap  = gopt Opt_InfoTableMap          dflags
-  , stgToCmmOmitYields    = gopt Opt_OmitYields            dflags
-  , stgToCmmOmitIfPragmas = gopt Opt_OmitInterfacePragmas  dflags
-  , stgToCmmPIC           = gopt Opt_PIC                   dflags
-  , stgToCmmPIE           = gopt Opt_PIE                   dflags
-  , stgToCmmExtDynRefs    = gopt Opt_ExternalDynamicRefs   dflags
-  , stgToCmmDoBoundsCheck = gopt Opt_DoBoundsChecking      dflags
-  , stgToCmmDoTagCheck    = gopt Opt_DoTagInferenceChecks  dflags
-  -- backend flags
-  , stgToCmmAllowBigArith             = not ncg || platformArch platform == ArchWasm32
-  , stgToCmmAllowQuotRemInstr         = ncg  && (x86ish || ppc)
-  , stgToCmmAllowQuotRem2             = (ncg && (x86ish || ppc)) || llvm
-  , stgToCmmAllowExtendedAddSubInstrs = (ncg && (x86ish || ppc)) || llvm
-  , stgToCmmAllowIntMul2Instr         = (ncg && x86ish) || llvm
-  -- SIMD flags
-  , stgToCmmVecInstrsErr  = vec_err
-  , stgToCmmAvx           = isAvxEnabled                   dflags
-  , stgToCmmAvx2          = isAvx2Enabled                  dflags
-  , stgToCmmAvx512f       = isAvx512fEnabled               dflags
-  , stgToCmmTickyAP       = gopt Opt_Ticky_AP dflags
-  } where profile  = targetProfile dflags
-          platform = profilePlatform profile
-          bk_end  = backend dflags
-          b_blob  = if not ncg then Nothing else binBlobThreshold dflags
-          (ncg, llvm) = case backendPrimitiveImplementation bk_end of
-                          GenericPrimitives -> (False, False)
-                          JSPrimitives      -> (False, False)
-                          NcgPrimitives     -> (True, False)
-                          LlvmPrimitives    -> (False, True)
-          x86ish  = case platformArch platform of
-                      ArchX86    -> True
-                      ArchX86_64 -> True
-                      _          -> False
-          ppc     = case platformArch platform of
-                      ArchPPC      -> True
-                      ArchPPC_64 _ -> True
-                      _            -> False
-          vec_err = case backendSimdValidity (backend dflags) of
-                      IsValid -> Nothing
-                      NotValid msg -> Just msg
diff --git a/compiler/GHC/Driver/Config/StgToJS.hs b/compiler/GHC/Driver/Config/StgToJS.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/StgToJS.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-module GHC.Driver.Config.StgToJS
-  ( initStgToJSConfig
-  )
-where
-
-import GHC.StgToJS.Types
-
-import GHC.Driver.Session
-import GHC.Platform.Ways
-import GHC.Utils.Outputable
-
-import GHC.Prelude
-
--- | Initialize StgToJS settings from DynFlags
-initStgToJSConfig :: DynFlags -> StgToJSConfig
-initStgToJSConfig dflags = StgToJSConfig
-  -- flags
-  { csInlinePush      = False
-  , csInlineBlackhole = False
-  , csInlineLoadRegs  = False
-  , csInlineEnter     = False
-  , csInlineAlloc     = False
-  , csTraceRts        = False
-  , csAssertRts       = False
-  , csBoundsCheck     = gopt Opt_DoBoundsChecking dflags
-  , csDebugAlloc      = False
-  , csTraceForeign    = False
-  , csProf            = ways dflags `hasWay` WayProf
-  , csRuntimeAssert   = False
-  -- settings
-  , csContext         = initSDocContext dflags defaultDumpStyle
-  }
diff --git a/compiler/GHC/Driver/Config/Tidy.hs b/compiler/GHC/Driver/Config/Tidy.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Config/Tidy.hs
+++ /dev/null
@@ -1,69 +0,0 @@
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE LambdaCase #-}
-
-module GHC.Driver.Config.Tidy
-  ( initTidyOpts
-  , initStaticPtrOpts
-  )
-where
-
-import GHC.Prelude
-
-import GHC.Iface.Tidy
-import GHC.Iface.Tidy.StaticPtrTable
-
-import GHC.Driver.Session
-import GHC.Driver.Env
-import GHC.Driver.Backend
-
-import GHC.Core.Make (getMkStringIds)
-import GHC.Data.Maybe
-import GHC.Utils.Panic
-import GHC.Utils.Outputable
-import GHC.Builtin.Names
-import GHC.Tc.Utils.Env (lookupGlobal_maybe)
-import GHC.Types.TyThing
-import GHC.Platform.Ways
-
-import qualified GHC.LanguageExtensions as LangExt
-
-initTidyOpts :: HscEnv -> IO TidyOpts
-initTidyOpts hsc_env = do
-  let dflags = hsc_dflags hsc_env
-  static_ptr_opts <- if not (xopt LangExt.StaticPointers dflags)
-    then pure Nothing
-    else Just <$> initStaticPtrOpts hsc_env
-  pure $ TidyOpts
-    { opt_name_cache        = hsc_NC hsc_env
-    , opt_collect_ccs       = ways dflags `hasWay` WayProf
-    , opt_unfolding_opts    = unfoldingOpts dflags
-    , opt_expose_unfoldings = if | gopt Opt_OmitInterfacePragmas dflags -> ExposeNone
-                                 | gopt Opt_ExposeAllUnfoldings dflags  -> ExposeAll
-                                 | otherwise                            -> ExposeSome
-    , opt_expose_rules      = not (gopt Opt_OmitInterfacePragmas dflags)
-    , opt_trim_ids          = gopt Opt_OmitInterfacePragmas dflags
-    , opt_static_ptr_opts   = static_ptr_opts
-    }
-
-initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts
-initStaticPtrOpts hsc_env = do
-  let dflags = hsc_dflags hsc_env
-
-  let lookupM n = lookupGlobal_maybe hsc_env n >>= \case
-        Succeeded r -> pure r
-        Failed err  -> pprPanic "initStaticPtrOpts: couldn't find" (ppr (err,n))
-
-  mk_string <- getMkStringIds (fmap tyThingId . lookupM)
-  static_ptr_info_datacon <- tyThingDataCon <$> lookupM staticPtrInfoDataConName
-  static_ptr_datacon      <- tyThingDataCon <$> lookupM staticPtrDataConName
-
-  pure $ StaticPtrOpts
-    { opt_platform = targetPlatform dflags
-
-      -- If we are compiling for the interpreter we will insert any necessary
-      -- SPT entries dynamically, otherwise we add a C stub to do so
-    , opt_gen_cstub = backendWritesFiles (backend dflags)
-    , opt_mk_string = mk_string
-    , opt_static_ptr_info_datacon = static_ptr_info_datacon
-    , opt_static_ptr_datacon      = static_ptr_datacon
-    }
diff --git a/compiler/GHC/Driver/GenerateCgIPEStub.hs b/compiler/GHC/Driver/GenerateCgIPEStub.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/GenerateCgIPEStub.hs
+++ /dev/null
@@ -1,268 +0,0 @@
-{-# LANGUAGE GADTs #-}
-
-module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) where
-
-import qualified Data.Map.Strict as Map
-import Data.Maybe (mapMaybe, listToMaybe)
-import GHC.Cmm
-import GHC.Cmm.CLabel (CLabel)
-import GHC.Cmm.Dataflow (Block, C, O)
-import GHC.Cmm.Dataflow.Block (blockSplit, blockToList)
-import GHC.Cmm.Dataflow.Collections (mapToList)
-import GHC.Cmm.Dataflow.Label (Label)
-import GHC.Cmm.Info.Build (emptySRT)
-import GHC.Cmm.Pipeline (cmmPipeline)
-import GHC.Data.Maybe (firstJusts)
-import GHC.Data.Stream (Stream, liftIO)
-import qualified GHC.Data.Stream as Stream
-import GHC.Driver.Env (hsc_dflags, hsc_logger)
-import GHC.Driver.Env.Types (HscEnv)
-import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap))
-import GHC.Driver.Session (gopt, targetPlatform)
-import GHC.Driver.Config.StgToCmm
-import GHC.Driver.Config.Cmm
-import GHC.Prelude
-import GHC.Runtime.Heap.Layout (isStackRep)
-import GHC.Settings (Platform, platformUnregisterised)
-import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState)
-import GHC.StgToCmm.Prof (initInfoTableProv)
-import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos)
-import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation)
-import GHC.Types.Name.Set (NonCaffySet)
-import GHC.Types.Tickish (GenTickish (SourceNote))
-import GHC.Unit.Types (Module)
-import GHC.Utils.Misc
-
-{-
-Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Stacktraces can be created from return frames as they are pushed to stack for every case scrutinee.
-But to make them readable / meaningful, one needs to know the source location of each return frame.
-
-Every return frame has a distinct info table and thus a distinct code pointer (for tables next to
-code) or at least a distinct address itself. Info Table Provenance Entries (IPEs) are searchable by
-this pointer and contain a source location.
-
-The info table / info table code pointer to source location map is described in:
-Note [Mapping Info Tables to Source Positions]
-
-To be able to lookup IPEs for return frames one needs to emit them during compile time. This is done
-by `generateCgIPEStub`.
-
-This leads to the question: How to figure out the source location of a return frame?
-
-While the lookup algorithms for registerised and unregisterised builds differ in details, they have in
-common that we want to lookup the `CmmNode.CmmTick` (containing a `SourceNote`) that is nearest
-(before) the usage of the return frame's label. (Which label and label type is used differs between
-these two use cases.)
-
-Registerised
-~~~~~~~~~~~~~
-
-Let's consider this example:
-```
- Main.returnFrame_entry() { //  [R2]
-         { info_tbls: [(c18g,
-                        label: block_c18g_info
-                        rep: StackRep []
-                        srt: Just GHC.CString.unpackCString#_closure),
-                       (c18r,
-                        label: Main.returnFrame_info
-                        rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} }
-                        srt: Nothing)]
-           stack_info: arg_space: 8
-         }
-     {offset
-
-      [...]
-
-       c18u: // global
-           //tick src<Main.hs:(7,1)-(16,15)>
-           I64[Hp - 16] = sat_s16B_info;
-           P64[Hp] = _s16r::P64;
-           _c17j::P64 = Hp - 16;
-           //tick src<Main.hs:8:25-39>
-           I64[Sp - 8] = c18g;
-           R3 = _c17j::P64;
-           R2 = GHC.IO.Unsafe.unsafePerformIO_closure;
-           R1 = GHC.Base.$_closure;
-           Sp = Sp - 8;
-           call stg_ap_pp_fast(R3,
-                               R2,
-                               R1) returns to c18g, args: 8, res: 8, upd: 8;
-```
-
-The return frame `block_c18g_info` has the label `c18g` which is used in the call to `stg_ap_pp_fast`
-(`returns to c18g`) as continuation (`cml_cont`). The source location we're after, is the nearest
-`//tick` before the call (`//tick src<Main.hs:8:25-39>`).
-
-In code the Cmm program is represented as a Hoopl graph. Hoopl distinguishes nodes by defining if they
-are open or closed on entry (one can fallthrough to them from the previous instruction) and if they are
-open or closed on exit (one can fallthrough from them to the next node).
-
-Please refer to the paper "Hoopl: A Modular, Reusable Library for Dataflow Analysis and Transformation"
-for a detailed explanation.
-
-Here we use the fact, that calls (represented by `CmmNode.CmmCall`) are always closed on exit
-(`CmmNode O C`, `O` means open, `C` closed). In other words, they are always at the end of a block.
-
-So, given a stack represented info table (likely representing a return frame, but this isn't completely
-sure as there are e.g. update frames, too) with it's label (`c18g` in the example above) and a `CmmGraph`:
-  - Look at the end of every block, if it's a `CmmNode.CmmCall` returning to the continuation with the
-    label of the return frame.
-  - If there's such a call, lookup the nearest `CmmNode.CmmTick` by traversing the middle part of the block
-    backwards (from end to beginning).
-  - Take the first `CmmNode.CmmTick` that contains a `Tickish.SourceNote` and return it's payload as
-    `IpeSourceLocation`. (There are other `Tickish` constructors like `ProfNote` or `HpcTick`, these are
-    ignored.)
-
-Unregisterised
-~~~~~~~~~~~~~
-
-In unregisterised builds there is no return frame / continuation label in calls. The continuation (i.e. return
-frame) is set in an explicit Cmm assignment. Thus the tick lookup algorithm has to be slightly different.
-
-```
- sat_s16G_entry() { //  [R1]
-         { info_tbls: [(c18O,
-                        label: sat_s16G_info
-                        rep: HeapRep { Thunk }
-                        srt: Just _u18Z_srt)]
-           stack_info: arg_space: 0
-         }
-     {offset
-       c18O: // global
-           _s16G::P64 = R1;
-           if ((Sp + 8) - 40 < SpLim) (likely: False) goto c18P; else goto c18Q;
-       c18P: // global
-           R1 = _s16G::P64;
-           call (stg_gc_enter_1)(R1) args: 8, res: 0, upd: 8;
-       c18Q: // global
-           I64[Sp - 16] = stg_upd_frame_info;
-           P64[Sp - 8] = _s16G::P64;
-           //tick src<Main.hs:20:9-13>
-           I64[Sp - 24] = block_c18M_info;
-           R1 = GHC.Show.$fShow[]_closure;
-           P64[Sp - 32] = GHC.Show.$fShowChar_closure;
-           Sp = Sp - 32;
-           call stg_ap_p_fast(R1) args: 16, res: 8, upd: 24;
-     }
- },
- _blk_c18M() { //  [R1]
-         { info_tbls: [(c18M,
-                        label: block_c18M_info
-                        rep: StackRep []
-                        srt: Just System.IO.print_closure)]
-           stack_info: arg_space: 0
-         }
-     {offset
-       c18M: // global
-           _s16F::P64 = R1;
-           R1 = System.IO.print_closure;
-           P64[Sp] = _s16F::P64;
-           call stg_ap_p_fast(R1) args: 32, res: 0, upd: 24;
-     }
- },
-```
-
-In this example we have to lookup `//tick src<Main.hs:20:9-13>` for the return frame `c18M`.
-Notice, that this cannot be done with the `Label` `c18M`, but with the `CLabel` `block_c18M_info`
-(`label: block_c18M_info` is actually a `CLabel`).
-
-The find the tick:
-  - Every `Block` is checked from top (first) to bottom (last) node for an assignment like
-   `I64[Sp - 24] = block_c18M_info;`. The lefthand side is actually ignored.
-  - If such an assignment is found the search is over, because the payload (content of
-    `Tickish.SourceNote`, represented as `IpeSourceLocation`) of last visited tick is always
-    remembered in a `Maybe`.
--}
-
-generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CmmCgInfos
-generateCgIPEStub hsc_env this_mod denv s = do
-  let dflags   = hsc_dflags hsc_env
-      platform = targetPlatform dflags
-      logger   = hsc_logger hsc_env
-      fstate   = initFCodeState platform
-      cmm_cfg  = initCmmConfig dflags
-  cgState <- liftIO initC
-
-  -- Collect info tables, but only if -finfo-table-map is enabled, otherwise labeledInfoTablesWithTickishes is empty.
-  let collectFun = if gopt Opt_InfoTableMap dflags then collect platform else collectNothing
-  (labeledInfoTablesWithTickishes, (nonCaffySet, moduleLFInfos)) <- Stream.mapAccumL_ collectFun [] s
-
-  -- Yield Cmm for Info Table Provenance Entries (IPEs)
-  let denv' = denv {provInfoTables = Map.fromList (map (\(_, i, t) -> (cit_lbl i, t)) labeledInfoTablesWithTickishes)}
-      ((ipeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv (map sndOf3 labeledInfoTablesWithTickishes) denv')
-
-  (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline logger cmm_cfg (emptySRT this_mod) ipeCmmGroup
-  Stream.yield ipeCmmGroupSRTs
-
-  return CmmCgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub}
-  where
-    collect :: Platform -> [(Label, CmmInfoTable, Maybe IpeSourceLocation)] -> CmmGroupSRTs -> IO ([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs)
-    collect platform acc cmmGroupSRTs = do
-      let labelsToInfoTables = collectInfoTables cmmGroupSRTs
-          labelsToInfoTablesToTickishes = map (\(l, i) -> (l, i, lookupEstimatedTick platform cmmGroupSRTs l i)) labelsToInfoTables
-      return (acc ++ labelsToInfoTablesToTickishes, cmmGroupSRTs)
-
-    collectNothing :: [a] -> CmmGroupSRTs -> IO ([a], CmmGroupSRTs)
-    collectNothing _ cmmGroupSRTs = pure ([], cmmGroupSRTs)
-
-    collectInfoTables :: CmmGroupSRTs -> [(Label, CmmInfoTable)]
-    collectInfoTables cmmGroup = concat $ mapMaybe extractInfoTables cmmGroup
-
-    extractInfoTables :: GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph -> Maybe [(Label, CmmInfoTable)]
-    extractInfoTables (CmmProc h _ _ _) = Just $ mapToList (info_tbls h)
-    extractInfoTables _ = Nothing
-
-    lookupEstimatedTick :: Platform -> CmmGroupSRTs -> Label -> CmmInfoTable -> Maybe IpeSourceLocation
-    lookupEstimatedTick platform cmmGroup infoTableLabel infoTable = do
-      -- All return frame info tables are stack represented, though not all stack represented info
-      -- tables have to be return frames.
-      if (isStackRep . cit_rep) infoTable
-        then do
-          let findFun =
-                if platformUnregisterised platform
-                  then findCmmTickishForForUnregistered (cit_lbl infoTable)
-                  else findCmmTickishForRegistered infoTableLabel
-              blocks = concatMap toBlockList (graphs cmmGroup)
-          firstJusts $ map findFun blocks
-        else Nothing
-    graphs :: CmmGroupSRTs -> [CmmGraph]
-    graphs = foldl' go []
-      where
-        go :: [CmmGraph] -> GenCmmDecl d h CmmGraph -> [CmmGraph]
-        go acc (CmmProc _ _ _ g) = g : acc
-        go acc _ = acc
-
-    findCmmTickishForRegistered :: Label -> Block CmmNode C C -> Maybe IpeSourceLocation
-    findCmmTickishForRegistered label block = do
-      let (_, middleBlock, endBlock) = blockSplit block
-
-      isCallWithReturnFrameLabel endBlock label
-      lastTickInBlock middleBlock
-      where
-        isCallWithReturnFrameLabel :: CmmNode O C -> Label -> Maybe ()
-        isCallWithReturnFrameLabel (CmmCall _ (Just l) _ _ _ _) clabel | l == clabel = Just ()
-        isCallWithReturnFrameLabel _ _ = Nothing
-
-        lastTickInBlock block =
-          listToMaybe $
-              mapMaybe maybeTick $ (reverse . blockToList) block
-
-        maybeTick :: CmmNode O O -> Maybe IpeSourceLocation
-        maybeTick (CmmTick (SourceNote span name)) = Just (span, name)
-        maybeTick _ = Nothing
-
-    findCmmTickishForForUnregistered :: CLabel -> Block CmmNode C C -> Maybe IpeSourceLocation
-    findCmmTickishForForUnregistered cLabel block = do
-      let (_, middleBlock, _) = blockSplit block
-      find cLabel (blockToList middleBlock) Nothing
-      where
-        find :: CLabel -> [CmmNode O O] -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation
-        find label (b : blocks) lastTick = case b of
-          (CmmStore _ (CmmLit (CmmLabel l)) _) -> if label == l then lastTick else find label blocks lastTick
-          (CmmTick (SourceNote span name)) -> find label blocks $ Just (span, name)
-          _ -> find label blocks lastTick
-        find _ [] _ = Nothing
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Main.hs
+++ /dev/null
@@ -1,2619 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE LambdaCase #-}
-
-{-# LANGUAGE NondecreasingIndentation #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE TypeApplications #-}
-
-{-# OPTIONS_GHC -fprof-auto-top #-}
-
--------------------------------------------------------------------------------
---
--- | Main API for compiling plain Haskell source code.
---
--- This module implements compilation of a Haskell source. It is
--- /not/ concerned with preprocessing of source files; this is handled
--- in "GHC.Driver.Pipeline"
---
--- There are various entry points depending on what mode we're in:
--- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and
--- "interactive" mode (GHCi). There are also entry points for
--- individual passes: parsing, typechecking/renaming, desugaring, and
--- simplification.
---
--- All the functions here take an 'HscEnv' as a parameter, but none of
--- them return a new one: 'HscEnv' is treated as an immutable value
--- from here on in (although it has mutable components, for the
--- caches).
---
--- We use the Hsc monad to deal with warning messages consistently:
--- specifically, while executing within an Hsc monad, warnings are
--- collected. When a Hsc monad returns to an IO monad, the
--- warnings are printed, or compilation aborts if the @-Werror@
--- flag is enabled.
---
--- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
---
--------------------------------------------------------------------------------
-
-module GHC.Driver.Main
-    (
-    -- * Making an HscEnv
-      newHscEnv
-    , newHscEnvWithHUG
-    , initHscEnv
-
-    -- * Compiling complete source files
-    , Messager, batchMsg, batchMultiMsg
-    , HscBackendAction (..), HscRecompStatus (..)
-    , initModDetails
-    , initWholeCoreBindings
-    , hscMaybeWriteIface
-    , hscCompileCmmFile
-
-    , hscGenHardCode
-    , hscInteractive
-    , mkCgInteractiveGuts
-    , CgInteractiveGuts
-    , generateByteCode
-    , generateFreshByteCode
-
-    -- * Running passes separately
-    , hscRecompStatus
-    , hscParse
-    , hscTypecheckRename
-    , hscTypecheckAndGetWarnings
-    , hscDesugar
-    , makeSimpleDetails
-    , hscSimplify -- ToDo, shouldn't really export this
-    , hscDesugarAndSimplify
-
-    -- * Safe Haskell
-    , hscCheckSafe
-    , hscGetSafe
-
-    -- * Support for interactive evaluation
-    , hscParseIdentifier
-    , hscTcRcLookupName
-    , hscTcRnGetInfo
-    , hscIsGHCiMonad
-    , hscGetModuleInterface
-    , hscRnImportDecls
-    , hscTcRnLookupRdrName
-    , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt
-    , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls
-    , hscParseModuleWithLocation
-    , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
-    , hscParseExpr
-    , hscParseType
-    , hscCompileCoreExpr
-    , hscTidy
-
-
-    -- * Low-level exports for hooks
-    , hscCompileCoreExpr'
-      -- We want to make sure that we export enough to be able to redefine
-      -- hsc_typecheck in client code
-    , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen
-    , getHscEnv
-    , hscSimpleIface'
-    , oneShotMsg
-    , dumpIfaceStats
-    , ioMsgMaybe
-    , showModuleIndex
-    , hscAddSptEntries
-    , writeInterfaceOnlyMode
-    ) where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Platform.Ways
-
-import GHC.Driver.Plugins
-import GHC.Driver.Session
-import GHC.Driver.Backend
-import GHC.Driver.Env
-import GHC.Driver.Env.KnotVars
-import GHC.Driver.Errors
-import GHC.Driver.Errors.Types
-import GHC.Driver.CodeOutput
-import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig)
-import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyExprOpts )
-import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )
-import GHC.Driver.Config.Core.Lint.Interactive ( lintInteractiveExpr )
-import GHC.Driver.Config.CoreToStg
-import GHC.Driver.Config.CoreToStg.Prep
-import GHC.Driver.Config.Logger   (initLogFlags)
-import GHC.Driver.Config.Parser   (initParserOpts)
-import GHC.Driver.Config.Stg.Ppr  (initStgPprOpts)
-import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts)
-import GHC.Driver.Config.StgToCmm  (initStgToCmmConfig)
-import GHC.Driver.Config.Cmm       (initCmmConfig)
-import GHC.Driver.LlvmConfigCache  (initLlvmConfigCache)
-import GHC.Driver.Config.StgToJS  (initStgToJSConfig)
-import GHC.Driver.Config.Diagnostic
-import GHC.Driver.Config.Tidy
-import GHC.Driver.Hooks
-import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub)
-
-import GHC.Runtime.Context
-import GHC.Runtime.Interpreter ( addSptEntry )
-import GHC.Runtime.Loader      ( initializePlugins )
-import GHCi.RemoteTypes        ( ForeignHValue )
-import GHC.ByteCode.Types
-
-import GHC.Linker.Loader
-import GHC.Linker.Types
-
-import GHC.Hs
-import GHC.Hs.Dump
-import GHC.Hs.Stats         ( ppSourceStats )
-
-import GHC.HsToCore
-
-import GHC.StgToByteCode    ( byteCodeGen )
-import GHC.StgToJS          ( stgToJS )
-
-import GHC.IfaceToCore  ( typecheckIface, typecheckWholeCoreBindings )
-
-import GHC.Iface.Load   ( ifaceStats, writeIface )
-import GHC.Iface.Make
-import GHC.Iface.Recomp
-import GHC.Iface.Tidy
-import GHC.Iface.Ext.Ast    ( mkHieFile )
-import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module )
-import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)
-import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )
-
-import GHC.Core
-import GHC.Core.Lint.Interactive ( interactiveInScope )
-import GHC.Core.Tidy           ( tidyExpr )
-import GHC.Core.Type           ( Type, Kind )
-import GHC.Core.Multiplicity
-import GHC.Core.Utils          ( exprType )
-import GHC.Core.ConLike
-import GHC.Core.Opt.Pipeline
-import GHC.Core.Opt.Pipeline.Types      ( CoreToDo (..))
-import GHC.Core.TyCon
-import GHC.Core.InstEnv
-import GHC.Core.FamInstEnv
-import GHC.Core.Rules
-import GHC.Core.Stats
-import GHC.Core.LateCC (addLateCostCentresPgm)
-
-
-import GHC.CoreToStg.Prep
-import GHC.CoreToStg    ( coreToStg )
-
-import GHC.Parser.Errors.Types
-import GHC.Parser
-import GHC.Parser.Lexer as Lexer
-
-import GHC.Tc.Module
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Zonk    ( ZonkFlexi (DefaultFlexi) )
-
-import GHC.Stg.Syntax
-import GHC.Stg.Pipeline ( stg2stg, StgCgInfos )
-
-import GHC.Builtin.Utils
-import GHC.Builtin.Names
-import GHC.Builtin.Uniques ( mkPseudoUniqueE )
-
-import qualified GHC.StgToCmm as StgToCmm ( codeGen )
-import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos)
-
-import GHC.Cmm
-import GHC.Cmm.Info.Build
-import GHC.Cmm.Pipeline
-import GHC.Cmm.Info
-import GHC.Cmm.Parser
-
-import GHC.Unit
-import GHC.Unit.Env
-import GHC.Unit.Finder
-import GHC.Unit.External
-import GHC.Unit.Module.ModDetails
-import GHC.Unit.Module.ModGuts
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.ModSummary
-import GHC.Unit.Module.Graph
-import GHC.Unit.Module.Imported
-import GHC.Unit.Module.Deps
-import GHC.Unit.Module.Status
-import GHC.Unit.Home.ModInfo
-
-import GHC.Types.Id
-import GHC.Types.SourceError
-import GHC.Types.SafeHaskell
-import GHC.Types.ForeignStubs
-import GHC.Types.Var.Env       ( emptyTidyEnv )
-import GHC.Types.Error
-import GHC.Types.Fixity.Env
-import GHC.Types.CostCentre
-import GHC.Types.IPE
-import GHC.Types.SourceFile
-import GHC.Types.SrcLoc
-import GHC.Types.Name
-import GHC.Types.Name.Cache ( initNameCache )
-import GHC.Types.Name.Reader
-import GHC.Types.Name.Ppr
-import GHC.Types.Name.Set (NonCaffySet)
-import GHC.Types.TyThing
-import GHC.Types.HpcInfo
-
-import GHC.Utils.Fingerprint ( Fingerprint )
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Error
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Logger
-import GHC.Utils.TmpFs
-
-import GHC.Data.FastString
-import GHC.Data.Bag
-import GHC.Data.StringBuffer
-import qualified GHC.Data.Stream as Stream
-import GHC.Data.Stream (Stream)
-import GHC.Data.Maybe
-
-import qualified GHC.SysTools
-import GHC.SysTools (initSysTools)
-import GHC.SysTools.BaseDir (findTopDir)
-
-import Data.Data hiding (Fixity, TyCon)
-import Data.List        ( nub, isPrefixOf, partition )
-import Control.Monad
-import Data.IORef
-import System.FilePath as FilePath
-import System.Directory
-import qualified Data.Set as S
-import Data.Set (Set)
-import Data.Functor
-import Control.DeepSeq (force)
-import Data.Bifunctor (first)
-import Data.List.NonEmpty (NonEmpty ((:|)))
-import GHC.Unit.Module.WholeCoreBindings
-import GHC.Types.TypeEnv
-import System.IO
-import {-# SOURCE #-} GHC.Driver.Pipeline
-import Data.Time
-
-import System.IO.Unsafe ( unsafeInterleaveIO )
-import GHC.Iface.Env ( trace_if )
-import GHC.Stg.InferTags.TagSig (seqTagSig)
-import GHC.Types.Unique.FM
-
-
-{- **********************************************************************
-%*                                                                      *
-                Initialisation
-%*                                                                      *
-%********************************************************************* -}
-
-newHscEnv :: FilePath -> DynFlags -> IO HscEnv
-newHscEnv top_dir dflags = newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) home_unit_graph
-  where
-    home_unit_graph = unitEnv_singleton
-                        (homeUnitId_ dflags)
-                        (mkHomeUnitEnv dflags emptyHomePackageTable Nothing)
-
-newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
-newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do
-    nc_var  <- initNameCache 'r' knownKeyNames
-    fc_var  <- initFinderCache
-    logger  <- initLogger
-    tmpfs   <- initTmpFs
-    let dflags = homeUnitEnv_dflags $ unitEnv_lookup cur_unit home_unit_graph
-    unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)
-    llvm_config <- initLlvmConfigCache top_dir
-    return HscEnv { hsc_dflags         = top_dynflags
-                  , hsc_logger         = setLogFlags logger (initLogFlags top_dynflags)
-                  , hsc_targets        = []
-                  , hsc_mod_graph      = emptyMG
-                  , hsc_IC             = emptyInteractiveContext dflags
-                  , hsc_NC             = nc_var
-                  , hsc_FC             = fc_var
-                  , hsc_type_env_vars  = emptyKnotVars
-                  , hsc_interp         = Nothing
-                  , hsc_unit_env       = unit_env
-                  , hsc_plugins        = emptyPlugins
-                  , hsc_hooks          = emptyHooks
-                  , hsc_tmpfs          = tmpfs
-                  , hsc_llvm_config    = llvm_config
-                  }
-
--- | Initialize HscEnv from an optional top_dir path
-initHscEnv :: Maybe FilePath -> IO HscEnv
-initHscEnv mb_top_dir = do
-  top_dir <- findTopDir mb_top_dir
-  mySettings <- initSysTools top_dir
-  dflags <- initDynFlags (defaultDynFlags mySettings)
-  hsc_env <- newHscEnv top_dir dflags
-  checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags
-  setUnsafeGlobalDynFlags dflags
-   -- c.f. DynFlags.parseDynamicFlagsFull, which
-   -- creates DynFlags and sets the UnsafeGlobalDynFlags
-  return hsc_env
-
--- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which
--- breaks tables-next-to-code in dynamically linked modules. This
--- check should be more selective but there is currently no released
--- version where this bug is fixed.
--- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and
--- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333
-checkBrokenTablesNextToCode :: Logger -> DynFlags -> IO ()
-checkBrokenTablesNextToCode logger dflags = do
-  let invalidLdErr = "Tables-next-to-code not supported on ARM \
-                     \when using binutils ld (please see: \
-                     \https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"
-  broken <- checkBrokenTablesNextToCode' logger dflags
-  when broken (panic invalidLdErr)
-
-checkBrokenTablesNextToCode' :: Logger -> DynFlags -> IO Bool
-checkBrokenTablesNextToCode' logger dflags
-  | not (isARM arch)               = return False
-  | ways dflags `hasNotWay` WayDyn = return False
-  | not tablesNextToCode           = return False
-  | otherwise                      = do
-    linkerInfo <- liftIO $ GHC.SysTools.getLinkerInfo logger dflags
-    case linkerInfo of
-      GnuLD _  -> return True
-      _        -> return False
-  where platform = targetPlatform dflags
-        arch = platformArch platform
-        tablesNextToCode = platformTablesNextToCode platform
-
-
--- -----------------------------------------------------------------------------
-
-getDiagnostics :: Hsc (Messages GhcMessage)
-getDiagnostics = Hsc $ \_ w -> return (w, w)
-
-clearDiagnostics :: Hsc ()
-clearDiagnostics = Hsc $ \_ _ -> return ((), emptyMessages)
-
-logDiagnostics :: Messages GhcMessage -> Hsc ()
-logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionMessages` w)
-
-getHscEnv :: Hsc HscEnv
-getHscEnv = Hsc $ \e w -> return (e, w)
-
-handleWarnings :: Hsc ()
-handleWarnings = do
-    diag_opts <- initDiagOpts <$> getDynFlags
-    print_config <- initPrintConfig <$> getDynFlags
-    logger <- getLogger
-    w <- getDiagnostics
-    liftIO $ printOrThrowDiagnostics logger print_config diag_opts w
-    clearDiagnostics
-
--- | log warning in the monad, and if there are errors then
--- throw a SourceError exception.
-logWarningsReportErrors :: (Messages PsWarning, Messages PsError) -> Hsc ()
-logWarningsReportErrors (warnings,errors) = do
-    logDiagnostics (GhcPsMessage <$> warnings)
-    when (not $ isEmptyMessages errors) $ throwErrors (GhcPsMessage <$> errors)
-
--- | Log warnings and throw errors, assuming the messages
--- contain at least one error (e.g. coming from PFailed)
-handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a
-handleWarningsThrowErrors (warnings, errors) = do
-    diag_opts <- initDiagOpts <$> getDynFlags
-    logDiagnostics (GhcPsMessage <$> warnings)
-    logger <- getLogger
-    let (wWarns, wErrs) = partitionMessages warnings
-    liftIO $ printMessages logger NoDiagnosticOpts diag_opts wWarns
-    throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs
-
--- | Deal with errors and warnings returned by a compilation step
---
--- In order to reduce dependencies to other parts of the compiler, functions
--- outside the "main" parts of GHC return warnings and errors as a parameter
--- and signal success via by wrapping the result in a 'Maybe' type. This
--- function logs the returned warnings and propagates errors as exceptions
--- (of type 'SourceError').
---
--- This function assumes the following invariants:
---
---  1. If the second result indicates success (is of the form 'Just x'),
---     there must be no error messages in the first result.
---
---  2. If there are no error messages, but the second result indicates failure
---     there should be warnings in the first result. That is, if the action
---     failed, it must have been due to the warnings (i.e., @-Werror@).
-ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a
-ioMsgMaybe ioA = do
-    (msgs, mb_r) <- liftIO ioA
-    let (warns, errs) = partitionMessages msgs
-    logDiagnostics warns
-    case mb_r of
-        Nothing -> throwErrors errs
-        Just r  -> assert (isEmptyMessages errs ) return r
-
--- | like ioMsgMaybe, except that we ignore error messages and return
--- 'Nothing' instead.
-ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
-ioMsgMaybe' ioA = do
-    (msgs, mb_r) <- liftIO $ ioA
-    logDiagnostics (mkMessages $ getWarningMessages msgs)
-    return mb_r
-
--- -----------------------------------------------------------------------------
--- | Lookup things in the compiler's environment
-
-hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]
-hscTcRnLookupRdrName hsc_env0 rdr_name
-  = runInteractiveHsc hsc_env0 $
-    do { hsc_env <- getHscEnv
-       ; ioMsgMaybe $ hoistTcRnMessage $ tcRnLookupRdrName hsc_env rdr_name }
-
-hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
-hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
-  hsc_env <- getHscEnv
-  ioMsgMaybe' $ hoistTcRnMessage $ tcRnLookupName hsc_env name
-      -- ignore errors: the only error we're likely to get is
-      -- "name not found", and the Maybe in the return type
-      -- is used to indicate that.
-
-hscTcRnGetInfo :: HscEnv -> Name
-               -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-hscTcRnGetInfo hsc_env0 name
-  = runInteractiveHsc hsc_env0 $
-    do { hsc_env <- getHscEnv
-       ; ioMsgMaybe' $ hoistTcRnMessage $ tcRnGetInfo hsc_env name }
-
-hscIsGHCiMonad :: HscEnv -> String -> IO Name
-hscIsGHCiMonad hsc_env name
-  = runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ isGHCiMonad hsc_env name
-
-hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
-hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
-  hsc_env <- getHscEnv
-  ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env mod
-
--- -----------------------------------------------------------------------------
--- | Rename some import declarations
-hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
-hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do
-  hsc_env <- getHscEnv
-  ioMsgMaybe $ hoistTcRnMessage $ tcRnImportDecls hsc_env import_decls
-
--- -----------------------------------------------------------------------------
--- | parse a file, returning the abstract syntax
-
-hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
-hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
-
--- internal version, that doesn't fail due to -Werror
-hscParse' :: ModSummary -> Hsc HsParsedModule
-hscParse' mod_summary
- | Just r <- ms_parsed_mod mod_summary = return r
- | otherwise = do
-    dflags <- getDynFlags
-    logger <- getLogger
-    {-# SCC "Parser" #-} withTiming logger
-                (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
-                (const ()) $ do
-    let src_filename  = ms_hspp_file mod_summary
-        maybe_src_buf = ms_hspp_buf  mod_summary
-
-    --------------------------  Parser  ----------------
-    -- sometimes we already have the buffer in memory, perhaps
-    -- because we needed to parse the imports out of it, or get the
-    -- module name.
-    buf <- case maybe_src_buf of
-               Just b  -> return b
-               Nothing -> liftIO $ hGetStringBuffer src_filename
-
-    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
-
-    let diag_opts = initDiagOpts dflags
-    when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do
-      case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of
-        Nothing -> pure ()
-        Just chars@((eloc,chr,_) :| _) ->
-          let span = mkSrcSpanPs $ mkPsSpan eloc (advancePsLoc eloc chr)
-          in logDiagnostics $ singleMessage $
-               mkPlainMsgEnvelope diag_opts span $
-               GhcPsMessage $ PsWarnBidirectionalFormatChars chars
-
-    let parseMod | HsigFile == ms_hsc_src mod_summary
-                 = parseSignature
-                 | otherwise = parseModule
-
-    case unP parseMod (initParserState (initParserOpts dflags) buf loc) of
-        PFailed pst ->
-            handleWarningsThrowErrors (getPsMessages pst)
-        POk pst rdr_module -> do
-            liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser"
-                        FormatHaskell (ppr rdr_module)
-            liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"
-                        FormatHaskell (showAstData NoBlankSrcSpan
-                                                   NoBlankEpAnnotations
-                                                   rdr_module)
-            liftIO $ putDumpFileMaybe logger Opt_D_source_stats "Source Statistics"
-                        FormatText (ppSourceStats False rdr_module)
-
-            -- To get the list of extra source files, we take the list
-            -- that the parser gave us,
-            --   - eliminate files beginning with '<'.  gcc likes to use
-            --     pseudo-filenames like "<built-in>" and "<command-line>"
-            --   - normalise them (eliminate differences between ./f and f)
-            --   - filter out the preprocessed source file
-            --   - filter out anything beginning with tmpdir
-            --   - remove duplicates
-            --   - filter out the .hs/.lhs source filename if we have one
-            --
-            let n_hspp  = FilePath.normalise src_filename
-                TempDir tmp_dir = tmpDir dflags
-                srcs0 = nub $ filter (not . (tmp_dir `isPrefixOf`))
-                            $ filter (not . (== n_hspp))
-                            $ map FilePath.normalise
-                            $ filter (not . isPrefixOf "<")
-                            $ map unpackFS
-                            $ srcfiles pst
-                srcs1 = case ml_hs_file (ms_location mod_summary) of
-                          Just f  -> filter (/= FilePath.normalise f) srcs0
-                          Nothing -> srcs0
-
-            -- sometimes we see source files from earlier
-            -- preprocessing stages that cannot be found, so just
-            -- filter them out:
-            srcs2 <- liftIO $ filterM doesFileExist srcs1
-
-            let res = HsParsedModule {
-                      hpm_module    = rdr_module,
-                      hpm_src_files = srcs2
-                   }
-
-            -- apply parse transformation of plugins
-            let applyPluginAction p opts
-                  = parsedResultAction p opts mod_summary
-            hsc_env <- getHscEnv
-            (ParsedResult transformed (PsMessages warns errs)) <-
-              withPlugins (hsc_plugins hsc_env) applyPluginAction
-                (ParsedResult res (uncurry PsMessages $ getPsMessages pst))
-
-            logDiagnostics (GhcPsMessage <$> warns)
-            unless (isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs)
-
-            return transformed
-
-checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))
-checkBidirectionFormatChars start_loc sb
-  | containsBidirectionalFormatChar sb = Just $ go start_loc sb
-  | otherwise = Nothing
-  where
-    go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String)
-    go loc sb
-      | atEnd sb = panic "checkBidirectionFormatChars: no char found"
-      | otherwise = case nextChar sb of
-          (chr, sb)
-            | Just desc <- lookup chr bidirectionalFormatChars ->
-                (loc, chr, desc) :| go1 (advancePsLoc loc chr) sb
-            | otherwise -> go (advancePsLoc loc chr) sb
-
-    go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)]
-    go1 loc sb
-      | atEnd sb = []
-      | otherwise = case nextChar sb of
-          (chr, sb)
-            | Just desc <- lookup chr bidirectionalFormatChars ->
-                (loc, chr, desc) : go1 (advancePsLoc loc chr) sb
-            | otherwise -> go1 (advancePsLoc loc chr) sb
-
-
--- -----------------------------------------------------------------------------
--- | If the renamed source has been kept, extract it. Dump it if requested.
-
-
-extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
-extract_renamed_stuff mod_summary tc_result = do
-    let rn_info = getRenamedStuff tc_result
-
-    dflags <- getDynFlags
-    logger <- getLogger
-    liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer"
-                FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info)
-
-    -- Create HIE files
-    when (gopt Opt_WriteHie dflags) $ do
-        -- I assume this fromJust is safe because `-fwrite-hie-file`
-        -- enables the option which keeps the renamed source.
-        hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
-        let out_file = ml_hie_file $ ms_location mod_summary
-        liftIO $ writeHieFile out_file hieFile
-        liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)
-
-        -- Validate HIE files
-        when (gopt Opt_ValidateHie dflags) $ do
-            hs_env <- Hsc $ \e w -> return (e, w)
-            liftIO $ do
-              -- Validate Scopes
-              case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of
-                  [] -> putMsg logger $ text "Got valid scopes"
-                  xs -> do
-                    putMsg logger $ text "Got invalid scopes"
-                    mapM_ (putMsg logger) xs
-              -- Roundtrip testing
-              file' <- readHieFile (hsc_NC hs_env) out_file
-              case diffFile hieFile (hie_file_result file') of
-                [] ->
-                  putMsg logger $ text "Got no roundtrip errors"
-                xs -> do
-                  putMsg logger $ text "Got roundtrip errors"
-                  let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug)
-                  mapM_ (putMsg logger') xs
-    return rn_info
-
-
--- -----------------------------------------------------------------------------
--- | Rename and typecheck a module, additionally returning the renamed syntax
-hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
-                   -> IO (TcGblEnv, RenamedStuff)
-hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $
-    hsc_typecheck True mod_summary (Just rdr_module)
-
--- | Do Typechecking without throwing SourceError exception with -Werror
-hscTypecheckAndGetWarnings :: HscEnv ->  ModSummary -> IO (FrontendResult, WarningMessages)
-hscTypecheckAndGetWarnings hsc_env summary = runHsc' hsc_env $ do
-  case hscFrontendHook (hsc_hooks hsc_env) of
-    Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False summary Nothing
-    Just h  -> h summary
-
--- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack
--- b) concerning dumping rename info and hie files. It would be nice to further
--- separate this stuff out, probably in conjunction better separating renaming
--- and type checking (#17781).
-hsc_typecheck :: Bool -- ^ Keep renamed source?
-              -> ModSummary -> Maybe HsParsedModule
-              -> Hsc (TcGblEnv, RenamedStuff)
-hsc_typecheck keep_rn mod_summary mb_rdr_module = do
-    hsc_env <- getHscEnv
-    let hsc_src = ms_hsc_src mod_summary
-        dflags = hsc_dflags hsc_env
-        home_unit = hsc_home_unit hsc_env
-        outer_mod = ms_mod mod_summary
-        mod_name = moduleName outer_mod
-        outer_mod' = mkHomeModule home_unit mod_name
-        inner_mod = homeModuleNameInstantiation home_unit mod_name
-        src_filename  = ms_hspp_file mod_summary
-        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
-        keep_rn' = gopt Opt_WriteHie dflags || keep_rn
-    massert (isHomeModule home_unit outer_mod)
-    tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)
-        then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
-        else
-         do hpm <- case mb_rdr_module of
-                    Just hpm -> return hpm
-                    Nothing -> hscParse' mod_summary
-            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm
-            if hsc_src == HsigFile
-                then do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary
-                        ioMsgMaybe $ hoistTcRnMessage $
-                            tcRnMergeSignatures hsc_env hpm tc_result0 iface
-                else return tc_result0
-    -- TODO are we extracting anything when we merely instantiate a signature?
-    -- If not, try to move this into the "else" case above.
-    rn_info <- extract_renamed_stuff mod_summary tc_result
-    return (tc_result, rn_info)
-
--- wrapper around tcRnModule to handle safe haskell extras
-tcRnModule' :: ModSummary -> Bool -> HsParsedModule
-            -> Hsc TcGblEnv
-tcRnModule' sum save_rn_syntax mod = do
-    hsc_env <- getHscEnv
-    dflags  <- getDynFlags
-
-    let diag_opts = initDiagOpts dflags
-    -- -Wmissing-safe-haskell-mode
-    when (not (safeHaskellModeEnabled dflags)
-          && wopt Opt_WarnMissingSafeHaskellMode dflags) $
-        logDiagnostics $ singleMessage $
-        mkPlainMsgEnvelope diag_opts (getLoc (hpm_module mod)) $
-        GhcDriverMessage $ DriverMissingSafeHaskellMode (ms_mod sum)
-
-    tcg_res <- {-# SCC "Typecheck-Rename" #-}
-               ioMsgMaybe $ hoistTcRnMessage $
-                   tcRnModule hsc_env sum
-                     save_rn_syntax mod
-
-    -- See Note [Safe Haskell Overlapping Instances Implementation]
-    -- although this is used for more than just that failure case.
-    tcSafeOK <- liftIO $ readIORef (tcg_safe_infer tcg_res)
-    whyUnsafe <- liftIO $ readIORef (tcg_safe_infer_reasons tcg_res)
-    let allSafeOK = safeInferred dflags && tcSafeOK
-
-    -- end of the safe haskell line, how to respond to user?
-    if not (safeHaskellOn dflags)
-         || (safeInferOn dflags && not allSafeOK)
-      -- if safe Haskell off or safe infer failed, mark unsafe
-      then markUnsafeInfer tcg_res whyUnsafe
-
-      -- module (could be) safe, throw warning if needed
-      else do
-          tcg_res' <- hscCheckSafeImports tcg_res
-          safe <- liftIO $ readIORef (tcg_safe_infer tcg_res')
-          when safe $
-            case wopt Opt_WarnSafe dflags of
-              True
-                | safeHaskell dflags == Sf_Safe -> return ()
-                | otherwise -> (logDiagnostics $ singleMessage $
-                       mkPlainMsgEnvelope diag_opts (warnSafeOnLoc dflags) $
-                       GhcDriverMessage $ DriverInferredSafeModule (tcg_mod tcg_res'))
-              False | safeHaskell dflags == Sf_Trustworthy &&
-                      wopt Opt_WarnTrustworthySafe dflags ->
-                      (logDiagnostics $ singleMessage $
-                       mkPlainMsgEnvelope diag_opts (trustworthyOnLoc dflags) $
-                       GhcDriverMessage $ DriverMarkedTrustworthyButInferredSafe (tcg_mod tcg_res'))
-              False -> return ()
-          return tcg_res'
-
--- | Convert a typechecked module to Core
-hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
-hscDesugar hsc_env mod_summary tc_result =
-    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
-
-hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
-hscDesugar' mod_location tc_result = do
-    hsc_env <- getHscEnv
-    ioMsgMaybe $ hoistDsMessage $
-      {-# SCC "deSugar" #-}
-      deSugar hsc_env mod_location tc_result
-
--- | Make a 'ModDetails' from the results of typechecking. Used when
--- typechecking only, as opposed to full compilation.
-makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails
-makeSimpleDetails logger tc_result = mkBootModDetailsTc logger tc_result
-
-
-{- **********************************************************************
-%*                                                                      *
-                The main compiler pipeline
-%*                                                                      *
-%********************************************************************* -}
-
-{-
-                   --------------------------------
-                        The compilation proper
-                   --------------------------------
-
-It's the task of the compilation proper to compile Haskell, hs-boot and core
-files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all
-(the module is still parsed and type-checked. This feature is mostly used by
-IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',
-'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'
-mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
-targets byte-code.
-
-The modes are kept separate because of their different types and meanings:
-
- * In 'one-shot' mode, we're only compiling a single file and can therefore
- discard the new ModIface and ModDetails. This is also the reason it only
- targets hard-code; compiling to byte-code or nothing doesn't make sense when
- we discard the result.
-
- * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
- and ModDetails. 'Batch' mode doesn't target byte-code since that require us to
- return the newly compiled byte-code.
-
- * 'Nothing' mode has exactly the same type as 'batch' mode but they're still
- kept separate. This is because compiling to nothing is fairly special: We
- don't output any interface files, we don't run the simplifier and we don't
- generate any code.
-
- * 'Interactive' mode is similar to 'batch' mode except that we return the
- compiled byte-code together with the ModIface and ModDetails.
-
-Trying to compile a hs-boot file to byte-code will result in a run-time error.
-This is the only thing that isn't caught by the type-system.
--}
-
-
-type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()
-
--- | Do the recompilation avoidance checks for both one-shot and --make modes
--- This function is the *only* place in the compiler where we decide whether to
--- recompile a module or not!
-hscRecompStatus :: Maybe Messager
-                -> HscEnv
-                -> ModSummary
-                -> Maybe ModIface
-                -> HomeModLinkable
-                -> (Int,Int)
-                -> IO HscRecompStatus
-hscRecompStatus
-    mHscMessage hsc_env mod_summary mb_old_iface old_linkable mod_index
-  = do
-    let
-        msg what = case mHscMessage of
-          Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] mod_summary)
-          Nothing -> return ()
-
-    -- First check to see if the interface file agrees with the
-    -- source file.
-    --
-    -- Save the interface that comes back from checkOldIface.
-    -- In one-shot mode we don't have the old iface until this
-    -- point, when checkOldIface reads it from the disk.
-    recomp_if_result
-          <- {-# SCC "checkOldIface" #-}
-             liftIO $ checkOldIface hsc_env mod_summary mb_old_iface
-    case recomp_if_result of
-      OutOfDateItem reason mb_checked_iface -> do
-        msg $ NeedsRecompile reason
-        return $ HscRecompNeeded $ fmap (mi_iface_hash . mi_final_exts) mb_checked_iface
-      UpToDateItem checked_iface -> do
-        let lcl_dflags = ms_hspp_opts mod_summary
-        if not (backendGeneratesCode (backend lcl_dflags)) then
-            -- No need for a linkable, we're good to go
-          do msg $ UpToDate
-             return $ HscUpToDate checked_iface emptyHomeModInfoLinkable
-        else
-          -- Do need linkable
-          do
-            -- 1. Just check whether we have bytecode/object linkables and then
-            -- we will decide if we need them or not.
-            bc_linkable <- checkByteCode checked_iface mod_summary (homeMod_bytecode old_linkable)
-            obj_linkable <- liftIO $ checkObjects lcl_dflags (homeMod_object old_linkable) mod_summary
-            trace_if (hsc_logger hsc_env) (vcat [text "BCO linkable", nest 2 (ppr bc_linkable), text "Object Linkable", ppr obj_linkable])
-
-            let just_bc = justBytecode <$> bc_linkable
-                just_o  = justObjects  <$> obj_linkable
-                _maybe_both_os = case (bc_linkable, obj_linkable) of
-                            (UpToDateItem bc, UpToDateItem o) -> UpToDateItem (bytecodeAndObjects bc o)
-                            -- If missing object code, just say we need to recompile because of object code.
-                            (_, OutOfDateItem reason _) -> OutOfDateItem reason Nothing
-                            -- If just missing byte code, just use the object code
-                            -- so you should use -fprefer-byte-code with -fwrite-if-simplified-core or you'll
-                            -- end up using bytecode on recompilation
-                            (_, UpToDateItem {} ) -> just_o
-
-                definitely_both_os = case (bc_linkable, obj_linkable) of
-                            (UpToDateItem bc, UpToDateItem o) -> UpToDateItem (bytecodeAndObjects bc o)
-                            -- If missing object code, just say we need to recompile because of object code.
-                            (_, OutOfDateItem reason _) -> OutOfDateItem reason Nothing
-                            -- If just missing byte code, just use the object code
-                            -- so you should use -fprefer-byte-code with -fwrite-if-simplified-core or you'll
-                            -- end up using bytecode on recompilation
-                            (OutOfDateItem reason _,  _ ) -> OutOfDateItem reason Nothing
-
---            pprTraceM "recomp" (ppr just_bc <+> ppr just_o)
-            -- 2. Decide which of the products we will need
-            let recomp_linkable_result = case () of
-                  _ | backendCanReuseLoadedCode (backend lcl_dflags) ->
-                        case bc_linkable of
-                          -- If bytecode is available for Interactive then don't load object code
-                          UpToDateItem _ -> just_bc
-                          _ -> case obj_linkable of
-                                  -- If o is availabe, then just use that
-                                  UpToDateItem _ -> just_o
-                                  _ -> outOfDateItemBecause MissingBytecode Nothing
-                     -- Need object files for making object files
-                     | backendWritesFiles (backend lcl_dflags) ->
-                        if gopt Opt_ByteCodeAndObjectCode lcl_dflags
-                          -- We say we are going to write both, so recompile unless we have both
-                          then definitely_both_os
-                          -- Only load the object file unless we are saying we need to produce both.
-                          -- Unless we do this then you can end up using byte-code for a module you specify -fobject-code for.
-                          else just_o
-                     | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags)
-            case recomp_linkable_result of
-              UpToDateItem linkable -> do
-                msg $ UpToDate
-                return $ HscUpToDate checked_iface $ linkable
-              OutOfDateItem reason _ -> do
-                msg $ NeedsRecompile reason
-                return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface
-
--- | Check that the .o files produced by compilation are already up-to-date
--- or not.
-checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable)
-checkObjects dflags mb_old_linkable summary = do
-  let
-    dt_enabled  = gopt Opt_BuildDynamicToo dflags
-    this_mod    = ms_mod summary
-    mb_obj_date = ms_obj_date summary
-    mb_dyn_obj_date = ms_dyn_obj_date summary
-    mb_if_date  = ms_iface_date summary
-    obj_fn      = ml_obj_file (ms_location summary)
-    -- dynamic-too *also* produces the dyn_o_file, so have to check
-    -- that's there, and if it's not, regenerate both .o and
-    -- .dyn_o
-    checkDynamicObj k = if dt_enabled
-      then case (>=) <$> mb_dyn_obj_date <*> mb_if_date of
-        Just True -> k
-        _ -> return $ outOfDateItemBecause MissingDynObjectFile Nothing
-      -- Not in dynamic-too mode
-      else k
-
-  checkDynamicObj $
-    case (,) <$> mb_obj_date <*> mb_if_date of
-      Just (obj_date, if_date)
-        | obj_date >= if_date ->
-            case mb_old_linkable of
-              Just old_linkable
-                | isObjectLinkable old_linkable, linkableTime old_linkable == obj_date
-                -> return $ UpToDateItem old_linkable
-              _ -> UpToDateItem <$> findObjectLinkable this_mod obj_fn obj_date
-      _ -> return $ outOfDateItemBecause MissingObjectFile Nothing
-
--- | Check to see if we can reuse the old linkable, by this point we will
--- have just checked that the old interface matches up with the source hash, so
--- no need to check that again here
-checkByteCode :: ModIface -> ModSummary -> Maybe Linkable -> IO (MaybeValidated Linkable)
-checkByteCode iface mod_sum mb_old_linkable =
-  case mb_old_linkable of
-    Just old_linkable
-      | not (isObjectLinkable old_linkable)
-      -> return $ (UpToDateItem old_linkable)
-    _ -> loadByteCode iface mod_sum
-
-loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable)
-loadByteCode iface mod_sum = do
-    let
-      this_mod   = ms_mod mod_sum
-      if_date    = fromJust $ ms_iface_date mod_sum
-    case mi_extra_decls iface of
-      Just extra_decls -> do
-          let fi = WholeCoreBindings extra_decls this_mod (ms_location mod_sum)
-          return (UpToDateItem (LM if_date this_mod [CoreBindings fi]))
-      _ -> return $ outOfDateItemBecause MissingBytecode Nothing
---------------------------------------------------------------
--- Compilers
---------------------------------------------------------------
-
-
--- Knot tying!  See Note [Knot-tying typecheckIface]
--- See Note [ModDetails and --make mode]
-initModDetails :: HscEnv -> ModIface -> IO ModDetails
-initModDetails hsc_env iface =
-  fixIO $ \details' -> do
-    let act hpt  = addToHpt hpt (moduleName $ mi_module iface)
-                                (HomeModInfo iface details' emptyHomeModInfoLinkable)
-    let !hsc_env' = hscUpdateHPT act hsc_env
-    -- NB: This result is actually not that useful
-    -- in one-shot mode, since we're not going to do
-    -- any further typechecking.  It's much more useful
-    -- in make mode, since this HMI will go into the HPT.
-    genModDetails hsc_env' iface
-
--- Hydrate any WholeCoreBindings linkables into BCOs
-initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
-initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = LM utc_time this_mod <$> mapM go uls
-  where
-    go (CoreBindings fi) = do
-        let act hpt  = addToHpt hpt (moduleName $ mi_module mod_iface)
-                                (HomeModInfo mod_iface details emptyHomeModInfoLinkable)
-        types_var <- newIORef (md_types details)
-        let kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])
-        let hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv }
-        core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi
-        -- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do
-        -- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone
-        -- reports a bug.
-        let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing []
-        -- The bytecode generation itself is lazy because otherwise even when doing
-        -- recompilation checking the bytecode will be generated (which slows things down a lot)
-        -- the laziness is OK because generateByteCode just depends on things already loaded
-        -- in the interface file.
-        LoadedBCOs <$> (unsafeInterleaveIO $ do
-                  trace_if (hsc_logger hsc_env) (text "Generating ByteCode for" <+> (ppr this_mod))
-                  generateByteCode hsc_env cgi_guts (wcb_mod_location fi))
-    go ul = return ul
-
-{-
-Note [ModDetails and --make mode]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-An interface file consists of two parts
-
-* The `ModIface` which ends up getting written to disk.
-  The `ModIface` is a completely acyclic tree, which can be serialised
-  and de-serialised completely straightforwardly.  The `ModIface` is
-  also the structure that is finger-printed for recompilation control.
-
-* The `ModDetails` which provides a more structured view that is suitable
-  for usage during compilation.  The `ModDetails` is heavily cyclic:
-  An `Id` contains a `Type`, which mentions a `TyCon` that contains kind
-  that mentions other `TyCons`; the `Id` also includes an unfolding that
-  in turn mentions more `Id`s;  And so on.
-
-The `ModIface` can be created from the `ModDetails` and the `ModDetails` from
-a `ModIface`.
-
-During tidying, just before interfaces are written to disk,
-the ModDetails is calculated and then converted into a ModIface (see GHC.Iface.Make.mkIface_).
-Then when GHC needs to restart typechecking from a certain point it can read the
-interface file, and regenerate the ModDetails from the ModIface (see GHC.IfaceToCore.typecheckIface).
-The key part about the loading is that the ModDetails is regenerated lazily
-from the ModIface, so that there's only a detailed in-memory representation
-for declarations which are actually used from the interface. This mode is
-also used when reading interface files from external packages.
-
-In the old --make mode implementation, the interface was written after compiling a module
-but the in-memory ModDetails which was used to compute the ModIface was retained.
-The result was that --make mode used much more memory than `-c` mode, because a large amount of
-information about a module would be kept in the ModDetails but never used.
-
-The new idea is that even in `--make` mode, when there is an in-memory `ModDetails`
-at hand, we re-create the `ModDetails` from the `ModIface`. Doing this means that
-we only have to keep the `ModIface` decls in memory and then lazily load
-detailed representations if needed. It turns out this makes a really big difference
-to memory usage, halving maximum memory used in some cases.
-
-See !5492 and #13586
--}
-
--- Runs the post-typechecking frontend (desugar and simplify). We want to
--- generate most of the interface as late as possible. This gets us up-to-date
--- and good unfoldings and other info in the interface file.
---
--- We might create a interface right away, in which case we also return the
--- updated HomeModInfo. But we might also need to run the backend first. In the
--- later case Status will be HscRecomp and we return a function from ModIface ->
--- HomeModInfo.
---
--- HscRecomp in turn will carry the information required to compute a interface
--- when passed the result of the code generator. So all this can and is done at
--- the call site of the backend code gen if it is run.
-hscDesugarAndSimplify :: ModSummary
-       -> FrontendResult
-       -> Messages GhcMessage
-       -> Maybe Fingerprint
-       -> Hsc HscBackendAction
-hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_hash = do
-  hsc_env <- getHscEnv
-  dflags <- getDynFlags
-  logger <- getLogger
-  let bcknd  = backend dflags
-      hsc_src = ms_hsc_src summary
-      diag_opts = initDiagOpts dflags
-      print_config = initPrintConfig dflags
-
-  -- Desugar, if appropriate
-  --
-  -- We usually desugar even when we are not generating code, otherwise we
-  -- would miss errors thrown by the desugaring (see #10600). The only
-  -- exceptions are when the Module is Ghc.Prim or when it is not a
-  -- HsSrcFile Module.
-  mb_desugar <-
-      if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile
-      then Just <$> hscDesugar' (ms_location summary) tc_result
-      else pure Nothing
-
-  -- Report the warnings from both typechecking and desugar together
-  w <- getDiagnostics
-  liftIO $ printOrThrowDiagnostics logger print_config diag_opts (unionMessages tc_warnings w)
-  clearDiagnostics
-
-  -- Simplify, if appropriate, and (whether we simplified or not) generate an
-  -- interface file.
-  case mb_desugar of
-      -- Just cause we desugared doesn't mean we are generating code, see above.
-      Just desugared_guts | backendGeneratesCode bcknd -> do
-          plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
-          simplified_guts <- hscSimplify' plugins desugared_guts
-
-          (cg_guts, details) <-
-              liftIO $ hscTidy hsc_env simplified_guts
-
-          let !partial_iface =
-                {-# SCC "GHC.Driver.Main.mkPartialIface" #-}
-                -- This `force` saves 2M residency in test T10370
-                -- See Note [Avoiding space leaks in toIface*] for details.
-                force (mkPartialIface hsc_env (cg_binds cg_guts) details summary simplified_guts)
-
-          return HscRecomp { hscs_guts = cg_guts,
-                             hscs_mod_location = ms_location summary,
-                             hscs_partial_iface = partial_iface,
-                             hscs_old_iface_hash = mb_old_hash
-                           }
-
-      Just desugared_guts | gopt Opt_WriteIfSimplifiedCore dflags -> do
-          -- If -fno-code is enabled (hence we fall through to this case)
-          -- Running the simplifier once is necessary before doing byte code generation
-          -- in order to inline data con wrappers but we honour whatever level of simplificication the
-          -- user requested. See #22008 for some discussion.
-          plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
-          simplified_guts <- hscSimplify' plugins desugared_guts
-          (cg_guts, _) <-
-              liftIO $ hscTidy hsc_env simplified_guts
-
-          (iface, _details) <- liftIO $
-            hscSimpleIface hsc_env (Just $ cg_binds cg_guts) tc_result summary
-
-          liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary)
-
-          return $ HscUpdate iface
-
-
-      -- We are not generating code or writing an interface with simplified core so we can skip simplification
-      -- and generate a simple interface.
-      _ -> do
-        (iface, _details) <- liftIO $
-          hscSimpleIface hsc_env Nothing tc_result summary
-
-        liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary)
-
-        return $ HscUpdate iface
-
-{-
-Note [Writing interface files]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We write one interface file per module and per compilation, except with
--dynamic-too where we write two interface files (non-dynamic and dynamic).
-
-We can write two kinds of interfaces (see Note [Interface file stages] in
-"GHC.Driver.Types"):
-
-   * simple interface: interface generated after the core pipeline
-
-   * full interface: simple interface completed with information from the
-     backend
-
-Depending on the situation, we write one or the other (using
-`hscMaybeWriteIface`). We must be careful with `-dynamic-too` because only the
-backend is run twice, so if we write a simple interface we need to write both
-the non-dynamic and the dynamic interfaces at the same time (with the same
-contents).
-
-Cases for which we generate simple interfaces:
-
-   * GHC.Driver.Main.hscDesugarAndSimplify: when a compilation does NOT require (re)compilation
-   of the hard code
-
-   * GHC.Driver.Pipeline.compileOne': when we run in One Shot mode and target
-   bytecode (if interface writing is forced).
-
-   * GHC.Driver.Backpack uses simple interfaces for indefinite units
-   (units with module holes). It writes them indirectly by forcing the
-   -fwrite-interface flag while setting backend to NoBackend.
-
-Cases for which we generate full interfaces:
-
-   * GHC.Driver.Pipeline.runPhase: when we must be compiling to regular hard
-   code and/or require recompilation.
-
-By default interface file names are derived from module file names by adding
-suffixes. The interface file name can be overloaded with "-ohi", except when
-`-dynamic-too` is used.
-
--}
-
--- | Write interface files
-hscMaybeWriteIface
-  :: Logger
-  -> DynFlags
-  -> Bool
-  -- ^ Is this a simple interface generated after the core pipeline, or one
-  -- with information from the backend? See: Note [Writing interface files]
-  -> ModIface
-  -> Maybe Fingerprint
-  -- ^ The old interface hash, used to decide if we need to actually write the
-  -- new interface.
-  -> ModLocation
-  -> IO ()
-hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do
-    let force_write_interface = gopt Opt_WriteInterface dflags
-        write_interface = backendWritesFiles (backend dflags)
-
-        write_iface dflags' iface =
-          let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location
-              profile     = targetProfile dflags'
-          in
-          {-# SCC "writeIface" #-}
-          withTiming logger
-              (text "WriteIface"<+>brackets (text iface_name))
-              (const ())
-              (writeIface logger profile iface_name iface)
-
-    if (write_interface || force_write_interface) then do
-
-      -- FIXME: with -dynamic-too, "change" is only meaningful for the
-      -- non-dynamic interface, not for the dynamic one. We should have another
-      -- flag for the dynamic interface. In the meantime:
-      --
-      --    * when we write a single full interface, we check if we are
-      --    currently writing the dynamic interface due to -dynamic-too, in
-      --    which case we ignore "change".
-      --
-      --    * when we write two simple interfaces at once because of
-      --    dynamic-too, we use "change" both for the non-dynamic and the
-      --    dynamic interfaces. Hopefully both the dynamic and the non-dynamic
-      --    interfaces stay in sync...
-      --
-      let change = old_iface /= Just (mi_iface_hash (mi_final_exts iface))
-
-      let dt = dynamicTooState dflags
-
-      when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger $
-        hang (text "Writing interface(s):") 2 $ vcat
-         [ text "Kind:" <+> if is_simple then text "simple" else text "full"
-         , text "Hash change:" <+> ppr change
-         , text "DynamicToo state:" <+> text (show dt)
-         ]
-
-      if is_simple
-         then when change $ do -- FIXME: see 'change' comment above
-            write_iface dflags iface
-            case dt of
-               DT_Dont   -> return ()
-               DT_Dyn    -> panic "Unexpected DT_Dyn state when writing simple interface"
-               DT_OK     -> write_iface (setDynamicNow dflags) iface
-         else case dt of
-               DT_Dont | change                    -> write_iface dflags iface
-               DT_OK   | change                    -> write_iface dflags iface
-               -- FIXME: see change' comment above
-               DT_Dyn                              -> write_iface dflags iface
-               _                                   -> return ()
-
-      when (gopt Opt_WriteHie dflags) $ do
-          -- This is slightly hacky. A hie file is considered to be up to date
-          -- if its modification time on disk is greater than or equal to that
-          -- of the .hi file (since we should always write a .hi file if we are
-          -- writing a .hie file). However, with the way this code is
-          -- structured at the moment, the .hie file is often written before
-          -- the .hi file; by touching the file here, we ensure that it is
-          -- correctly considered up-to-date.
-          --
-          -- The file should exist by the time we get here, but we check for
-          -- existence just in case, so that we don't accidentally create empty
-          -- .hie files.
-          let hie_file = ml_hie_file mod_location
-          whenM (doesFileExist hie_file) $
-            GHC.SysTools.touch logger dflags "Touching hie file" hie_file
-    else
-        -- See Note [Strictness in ModIface]
-        forceModIface iface
-
---------------------------------------------------------------
--- NoRecomp handlers
---------------------------------------------------------------
-
-
--- | genModDetails is used to initialise 'ModDetails' at the end of compilation.
--- This has two main effects:
--- 1. Increases memory usage by unloading a lot of the TypeEnv
--- 2. Globalising certain parts (DFunIds) in the TypeEnv (which used to be achieved using UpdateIdInfos)
--- For the second part to work, it's critical that we use 'initIfaceLoadModule' here rather than
--- 'initIfaceCheck' as 'initIfaceLoadModule' removes the module from the KnotVars, otherwise name lookups
--- succeed by hitting the old TypeEnv, which missing out the critical globalisation step for DFuns.
-
--- After the DFunIds are globalised, it's critical to overwrite the old TypeEnv with the new
--- more compact and more correct version. This reduces memory usage whilst compiling the rest of
--- the module loop.
-genModDetails :: HscEnv -> ModIface -> IO ModDetails
-genModDetails hsc_env old_iface
-  = do
-    -- CRITICAL: To use initIfaceLoadModule as that removes the current module from the KnotVars and
-    -- hence properly globalises DFunIds.
-    new_details <- {-# SCC "tcRnIface" #-}
-                  initIfaceLoadModule hsc_env (mi_module old_iface) (typecheckIface old_iface)
-    case lookupKnotVars (hsc_type_env_vars hsc_env) (mi_module old_iface) of
-      Nothing -> return ()
-      Just te_var -> writeIORef te_var (md_types new_details)
-    dumpIfaceStats hsc_env
-    return new_details
-
---------------------------------------------------------------
--- Progress displayers.
---------------------------------------------------------------
-
-oneShotMsg :: Logger -> RecompileRequired -> IO ()
-oneShotMsg logger recomp =
-    case recomp of
-        UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required"
-        NeedsRecompile _ -> return ()
-
-batchMsg :: Messager
-batchMsg = batchMsgWith (\_ _ _ _ -> empty)
-batchMultiMsg :: Messager
-batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (moduleGraphNodeUnitId node)))
-
-batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager
-batchMsgWith extra hsc_env_start mod_index recomp node =
-      case recomp of
-        UpToDate
-          | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty
-          | otherwise -> return ()
-        NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of
-          MustCompile            -> empty
-          (RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"
-    where
-        herald = case node of
-                    LinkNode {} -> "Linking"
-                    InstantiationNode {} -> "Instantiating"
-                    ModuleNode {} -> "Compiling"
-        hsc_env = hscSetActiveUnitId (moduleGraphNodeUnitId node) hsc_env_start
-        dflags = hsc_dflags hsc_env
-        logger = hsc_logger hsc_env
-        state  = hsc_units hsc_env
-        showMsg msg reason =
-            compilationProgressMsg logger $
-            (showModuleIndex mod_index <>
-            msg <+> showModMsg dflags (recompileRequired recomp) node)
-                <> extra hsc_env mod_index recomp node
-                <> reason
-
---------------------------------------------------------------
--- Safe Haskell
---------------------------------------------------------------
-
--- Note [Safe Haskell Trust Check]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Safe Haskell checks that an import is trusted according to the following
--- rules for an import of module M that resides in Package P:
---
---   * If M is recorded as Safe and all its trust dependencies are OK
---     then M is considered safe.
---   * If M is recorded as Trustworthy and P is considered trusted and
---     all M's trust dependencies are OK then M is considered safe.
---
--- By trust dependencies we mean that the check is transitive. So if
--- a module M that is Safe relies on a module N that is trustworthy,
--- importing module M will first check (according to the second case)
--- that N is trusted before checking M is trusted.
---
--- This is a minimal description, so please refer to the user guide
--- for more details. The user guide is also considered the authoritative
--- source in this matter, not the comments or code.
-
-
--- Note [Safe Haskell Inference]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Safe Haskell does Safe inference on modules that don't have any specific
--- safe haskell mode flag. The basic approach to this is:
---   * When deciding if we need to do a Safe language check, treat
---     an unmarked module as having -XSafe mode specified.
---   * For checks, don't throw errors but return them to the caller.
---   * Caller checks if there are errors:
---     * For modules explicitly marked -XSafe, we throw the errors.
---     * For unmarked modules (inference mode), we drop the errors
---       and mark the module as being Unsafe.
---
--- It used to be that we only did safe inference on modules that had no Safe
--- Haskell flags, but now we perform safe inference on all modules as we want
--- to allow users to set the `-Wsafe`, `-Wunsafe` and
--- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a
--- user can ensure their assumptions are correct and see reasons for why a
--- module is safe or unsafe.
---
--- This is tricky as we must be careful when we should throw an error compared
--- to just warnings. For checking safe imports we manage it as two steps. First
--- we check any imports that are required to be safe, then we check all other
--- imports to see if we can infer them to be safe.
-
-
--- | Check that the safe imports of the module being compiled are valid.
--- If not we either issue a compilation error if the module is explicitly
--- using Safe Haskell, or mark the module as unsafe if we're in safe
--- inference mode.
-hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
-hscCheckSafeImports tcg_env = do
-    dflags   <- getDynFlags
-    tcg_env' <- checkSafeImports tcg_env
-    checkRULES dflags tcg_env'
-
-  where
-    checkRULES dflags tcg_env' =
-      let diag_opts = initDiagOpts dflags
-      in case safeLanguageOn dflags of
-          True -> do
-              -- XSafe: we nuke user written RULES
-              logDiagnostics $ fmap GhcDriverMessage $ warns diag_opts (tcg_rules tcg_env')
-              return tcg_env' { tcg_rules = [] }
-          False
-                -- SafeInferred: user defined RULES, so not safe
-              | safeInferOn dflags && not (null $ tcg_rules tcg_env')
-              -> markUnsafeInfer tcg_env' $ warns diag_opts (tcg_rules tcg_env')
-
-                -- Trustworthy OR SafeInferred: with no RULES
-              | otherwise
-              -> return tcg_env'
-
-    warns diag_opts rules = mkMessages $ listToBag $ map (warnRules diag_opts) rules
-
-    warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage
-    warnRules diag_opts (L loc rule) =
-        mkPlainMsgEnvelope diag_opts (locA loc) $ DriverUserDefinedRuleIgnored rule
-
--- | Validate that safe imported modules are actually safe.  For modules in the
--- HomePackage (the package the module we are compiling in resides) this just
--- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
--- that reside in another package we also must check that the external package
--- is trusted. See the Note [Safe Haskell Trust Check] above for more
--- information.
---
--- The code for this is quite tricky as the whole algorithm is done in a few
--- distinct phases in different parts of the code base. See
--- 'GHC.Rename.Names.rnImportDecl' for where package trust dependencies for a
--- module are collected and unioned.  Specifically see the Note [Tracking Trust
--- Transitively] in "GHC.Rename.Names" and the Note [Trust Own Package] in
--- "GHC.Rename.Names".
-checkSafeImports :: TcGblEnv -> Hsc TcGblEnv
-checkSafeImports tcg_env
-    = do
-        dflags <- getDynFlags
-        imps <- mapM condense imports'
-        let (safeImps, regImps) = partition (\(_,_,s) -> s) imps
-
-        -- We want to use the warning state specifically for detecting if safe
-        -- inference has failed, so store and clear any existing warnings.
-        oldErrs <- getDiagnostics
-        clearDiagnostics
-
-        -- Check safe imports are correct
-        safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps
-        safeErrs <- getDiagnostics
-        clearDiagnostics
-
-        -- Check non-safe imports are correct if inferring safety
-        -- See the Note [Safe Haskell Inference]
-        (infErrs, infPkgs) <- case (safeInferOn dflags) of
-          False -> return (emptyMessages, S.empty)
-          True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps
-                     infErrs <- getDiagnostics
-                     clearDiagnostics
-                     return (infErrs, infPkgs)
-
-        -- restore old errors
-        logDiagnostics oldErrs
-
-        case (isEmptyMessages safeErrs) of
-          -- Failed safe check
-          False -> liftIO . throwErrors $ safeErrs
-
-          -- Passed safe check
-          True -> do
-            let infPassed = isEmptyMessages infErrs
-            tcg_env' <- case (not infPassed) of
-              True  -> markUnsafeInfer tcg_env infErrs
-              False -> return tcg_env
-            when (packageTrustOn dflags) $ checkPkgTrust pkgReqs
-            let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed
-            return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }
-
-  where
-    impInfo  = tcg_imports tcg_env     -- ImportAvails
-    imports  = imp_mods impInfo        -- ImportedMods
-    imports1 = moduleEnvToList imports -- (Module, [ImportedBy])
-    imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])
-    pkgReqs  = imp_trust_pkgs impInfo  -- [Unit]
-
-    condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
-    condense (_, [])   = panic "GHC.Driver.Main.condense: Pattern match failure!"
-    condense (m, x:xs) = do imv <- foldlM cond' x xs
-                            return (m, imv_span imv, imv_is_safe imv)
-
-    -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
-    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
-    cond' v1 v2
-        | imv_is_safe v1 /= imv_is_safe v2
-        = throwOneError $
-            mkPlainErrorMsgEnvelope (imv_span v1) $
-            GhcDriverMessage $ DriverMixedSafetyImport (imv_name v1)
-        | otherwise
-        = return v1
-
-    -- easier interface to work with
-    checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId)
-    checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l
-
-    -- what pkg's to add to our trust requirements
-    pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId ->
-          Bool -> ImportAvails
-    pkgTrustReqs dflags req inf infPassed | safeInferOn dflags
-                                  && not (safeHaskellModeEnabled dflags) && infPassed
-                                   = emptyImportAvails {
-                                       imp_trust_pkgs = req `S.union` inf
-                                   }
-    pkgTrustReqs dflags _   _ _ | safeHaskell dflags == Sf_Unsafe
-                         = emptyImportAvails
-    pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }
-
--- | Check that a module is safe to import.
---
--- We return True to indicate the import is safe and False otherwise
--- although in the False case an exception may be thrown first.
-hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
-hscCheckSafe hsc_env m l = runHsc hsc_env $ do
-    dflags <- getDynFlags
-    pkgs <- snd `fmap` hscCheckSafe' m l
-    when (packageTrustOn dflags) $ checkPkgTrust pkgs
-    errs <- getDiagnostics
-    return $ isEmptyMessages errs
-
--- | Return if a module is trusted and the pkgs it depends on to be trusted.
-hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)
-hscGetSafe hsc_env m l = runHsc hsc_env $ do
-    (self, pkgs) <- hscCheckSafe' m l
-    good         <- isEmptyMessages `fmap` getDiagnostics
-    clearDiagnostics -- don't want them printed...
-    let pkgs' | Just p <- self = S.insert p pkgs
-              | otherwise      = pkgs
-    return (good, pkgs')
-
--- | Is a module trusted? If not, throw or log errors depending on the type.
--- Return (regardless of trusted or not) if the trust type requires the modules
--- own package be trusted and a list of other packages required to be trusted
--- (these later ones haven't been checked) but the own package trust has been.
-hscCheckSafe' :: Module -> SrcSpan
-  -> Hsc (Maybe UnitId, Set UnitId)
-hscCheckSafe' m l = do
-    hsc_env <- getHscEnv
-    let home_unit = hsc_home_unit hsc_env
-    (tw, pkgs) <- isModSafe home_unit m l
-    case tw of
-        False                           -> return (Nothing, pkgs)
-        True | isHomeModule home_unit m -> return (Nothing, pkgs)
-             -- TODO: do we also have to check the trust of the instantiation?
-             -- Not necessary if that is reflected in dependencies
-             | otherwise   -> return (Just $ toUnitId (moduleUnit m), pkgs)
-  where
-    isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)
-    isModSafe home_unit m l = do
-        hsc_env <- getHscEnv
-        dflags <- getDynFlags
-        iface <- lookup' m
-        let diag_opts = initDiagOpts dflags
-        case iface of
-            -- can't load iface to check trust!
-            Nothing -> throwOneError $
-                         mkPlainErrorMsgEnvelope l $
-                         GhcDriverMessage $ DriverCannotLoadInterfaceFile m
-
-            -- got iface, check trust
-            Just iface' ->
-                let trust = getSafeMode $ mi_trust iface'
-                    trust_own_pkg = mi_trust_pkg iface'
-                    -- check module is trusted
-                    safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]
-                    -- check package is trusted
-                    safeP = packageTrusted dflags (hsc_units hsc_env) home_unit trust trust_own_pkg m
-                    -- pkg trust reqs
-                    pkgRs = dep_trusted_pkgs $ mi_deps iface'
-                    -- warn if Safe module imports Safe-Inferred module.
-                    warns = if wopt Opt_WarnInferredSafeImports dflags
-                                && safeLanguageOn dflags
-                                && trust == Sf_SafeInferred
-                                then inferredImportWarn diag_opts
-                                else emptyMessages
-                    -- General errors we throw but Safe errors we log
-                    errs = case (safeM, safeP) of
-                        (True, True ) -> emptyMessages
-                        (True, False) -> pkgTrustErr
-                        (False, _   ) -> modTrustErr
-                in do
-                    logDiagnostics warns
-                    logDiagnostics errs
-                    return (trust == Sf_Trustworthy, pkgRs)
-
-                where
-                    state = hsc_units hsc_env
-                    inferredImportWarn diag_opts = singleMessage
-                        $ mkMsgEnvelope diag_opts l (pkgQual state)
-                        $ GhcDriverMessage $ DriverInferredSafeImport m
-                    pkgTrustErr = singleMessage
-                      $ mkErrorMsgEnvelope l (pkgQual state)
-                      $ GhcDriverMessage $ DriverCannotImportFromUntrustedPackage state m
-                    modTrustErr = singleMessage
-                      $ mkErrorMsgEnvelope l (pkgQual state)
-                      $ GhcDriverMessage $ DriverCannotImportUnsafeModule m
-
-    -- Check the package a module resides in is trusted. Safe compiled
-    -- modules are trusted without requiring that their package is trusted. For
-    -- trustworthy modules, modules in the home package are trusted but
-    -- otherwise we check the package trust flag.
-    packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool
-    packageTrusted dflags unit_state home_unit safe_mode trust_own_pkg mod =
-        case safe_mode of
-            Sf_None      -> False -- shouldn't hit these cases
-            Sf_Ignore    -> False -- shouldn't hit these cases
-            Sf_Unsafe    -> False -- prefer for completeness.
-            _ | not (packageTrustOn dflags)     -> True
-            Sf_Safe | not trust_own_pkg         -> True
-            Sf_SafeInferred | not trust_own_pkg -> True
-            _ | isHomeModule home_unit mod      -> True
-            _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m)
-
-    lookup' :: Module -> Hsc (Maybe ModIface)
-    lookup' m = do
-        hsc_env <- getHscEnv
-        hsc_eps <- liftIO $ hscEPS hsc_env
-        let pkgIfaceT = eps_PIT hsc_eps
-            hug       = hsc_HUG hsc_env
-            iface     = lookupIfaceByModule hug pkgIfaceT m
-        -- the 'lookupIfaceByModule' method will always fail when calling from GHCi
-        -- as the compiler hasn't filled in the various module tables
-        -- so we need to call 'getModuleInterface' to load from disk
-        case iface of
-            Just _  -> return iface
-            Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
-
-
--- | Check the list of packages are trusted.
-checkPkgTrust :: Set UnitId -> Hsc ()
-checkPkgTrust pkgs = do
-    hsc_env <- getHscEnv
-    let errors = S.foldr go emptyBag pkgs
-        state  = hsc_units hsc_env
-        go pkg acc
-            | unitIsTrusted $ unsafeLookupUnitId state pkg
-            = acc
-            | otherwise
-            = (`consBag` acc)
-                     $ mkErrorMsgEnvelope noSrcSpan (pkgQual state)
-                     $ GhcDriverMessage
-                     $ DriverPackageNotTrusted state pkg
-    if isEmptyBag errors
-      then return ()
-      else liftIO $ throwErrors $ mkMessages errors
-
--- | Set module to unsafe and (potentially) wipe trust information.
---
--- Make sure to call this method to set a module to inferred unsafe, it should
--- be a central and single failure method. We only wipe the trust information
--- when we aren't in a specific Safe Haskell mode.
---
--- While we only use this for recording that a module was inferred unsafe, we
--- may call it on modules using Trustworthy or Unsafe flags so as to allow
--- warning flags for safety to function correctly. See Note [Safe Haskell
--- Inference].
-markUnsafeInfer :: forall e . Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
-markUnsafeInfer tcg_env whyUnsafe = do
-    dflags <- getDynFlags
-
-    let reason = WarningWithFlag Opt_WarnUnsafe
-    let diag_opts = initDiagOpts dflags
-    when (diag_wopt Opt_WarnUnsafe diag_opts)
-         (logDiagnostics $ singleMessage $
-             mkPlainMsgEnvelope diag_opts (warnUnsafeOnLoc dflags) $
-             GhcDriverMessage $ DriverUnknownMessage $
-             UnknownDiagnostic $
-             mkPlainDiagnostic reason noHints $
-             whyUnsafe' dflags)
-
-    liftIO $ writeIORef (tcg_safe_infer tcg_env) False
-    liftIO $ writeIORef (tcg_safe_infer_reasons tcg_env) emptyMessages
-    -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other
-    -- times inference may be on but we are in Trustworthy mode -- so we want
-    -- to record safe-inference failed but not wipe the trust dependencies.
-    case not (safeHaskellModeEnabled dflags) of
-      True  -> return $ tcg_env { tcg_imports = wiped_trust }
-      False -> return tcg_env
-
-  where
-    wiped_trust   = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }
-    pprMod        = ppr $ moduleName $ tcg_mod tcg_env
-    whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
-                         , text "Reason:"
-                         , nest 4 $ (vcat $ badFlags df) $+$
-                                    -- MP: Using defaultDiagnosticOpts here is not right but it's also not right to handle these
-                                    -- unsafety error messages in an unstructured manner.
-                                    (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @e) (getMessages whyUnsafe)) $+$
-                                    (vcat $ badInsts $ tcg_insts tcg_env)
-                         ]
-    badFlags df   = concatMap (badFlag df) unsafeFlagsForInfer
-    badFlag df (str,loc,on,_)
-        | on df     = [mkLocMessage MCOutput (loc df) $
-                            text str <+> text "is not allowed in Safe Haskell"]
-        | otherwise = []
-    badInsts insts = concatMap badInst insts
-
-    checkOverlap (NoOverlap _) = False
-    checkOverlap _             = True
-
-    badInst ins | checkOverlap (overlapMode (is_flag ins))
-                = [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $
-                      ppr (overlapMode $ is_flag ins) <+>
-                      text "overlap mode isn't allowed in Safe Haskell"]
-                | otherwise = []
-
--- | Figure out the final correct safe haskell mode
-hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
-hscGetSafeMode tcg_env = do
-    dflags  <- getDynFlags
-    liftIO $ finalSafeMode dflags tcg_env
-
---------------------------------------------------------------
--- Simplifiers
---------------------------------------------------------------
-
--- | Run Core2Core simplifier. The list of String is a list of (Core) plugin
--- module names added via TH (cf 'addCorePlugin').
-hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
-hscSimplify hsc_env plugins modguts =
-    runHsc hsc_env $ hscSimplify' plugins modguts
-
--- | Run Core2Core simplifier. The list of String is a list of (Core) plugin
--- module names added via TH (cf 'addCorePlugin').
-hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
-hscSimplify' plugins ds_result = do
-    hsc_env <- getHscEnv
-    hsc_env_with_plugins <- if null plugins -- fast path
-        then return hsc_env
-        else liftIO $ initializePlugins
-                    $ hscUpdateFlags (\dflags -> foldr addPluginModuleName dflags plugins)
-                      hsc_env
-    {-# SCC "Core2Core" #-}
-      liftIO $ core2core hsc_env_with_plugins ds_result
-
---------------------------------------------------------------
--- Interface generators
---------------------------------------------------------------
-
--- | Generate a stripped down interface file, e.g. for boot files or when ghci
--- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc]
-hscSimpleIface :: HscEnv
-               -> Maybe CoreProgram
-               -> TcGblEnv
-               -> ModSummary
-               -> IO (ModIface, ModDetails)
-hscSimpleIface hsc_env mb_core_program tc_result summary
-    = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary
-
-hscSimpleIface' :: Maybe CoreProgram
-                -> TcGblEnv
-                -> ModSummary
-                -> Hsc (ModIface, ModDetails)
-hscSimpleIface' mb_core_program tc_result summary = do
-    hsc_env   <- getHscEnv
-    logger    <- getLogger
-    details   <- liftIO $ mkBootModDetailsTc logger tc_result
-    safe_mode <- hscGetSafeMode tc_result
-    new_iface
-        <- {-# SCC "MkFinalIface" #-}
-           liftIO $
-               mkIfaceTc hsc_env safe_mode details summary mb_core_program tc_result
-    -- And the answer is ...
-    liftIO $ dumpIfaceStats hsc_env
-    return (new_iface, details)
-
---------------------------------------------------------------
--- BackEnd combinators
---------------------------------------------------------------
-
--- | Compile to hard-code.
-hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
-               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos )
-                -- ^ @Just f@ <=> _stub.c is f
-hscGenHardCode hsc_env cgguts location output_filename = do
-        let CgGuts{ -- This is the last use of the ModGuts in a compilation.
-                    -- From now on, we just use the bits we need.
-                    cg_module   = this_mod,
-                    cg_binds    = core_binds,
-                    cg_ccs      = local_ccs,
-                    cg_tycons   = tycons,
-                    cg_foreign  = foreign_stubs0,
-                    cg_foreign_files = foreign_files,
-                    cg_dep_pkgs = dependencies,
-                    cg_hpc_info = hpc_info,
-                    cg_spt_entries = spt_entries
-                    } = cgguts
-            dflags = hsc_dflags hsc_env
-            logger = hsc_logger hsc_env
-            hooks  = hsc_hooks hsc_env
-            tmpfs  = hsc_tmpfs hsc_env
-            llvm_config = hsc_llvm_config hsc_env
-            profile = targetProfile dflags
-            data_tycons = filter isDataTyCon tycons
-            -- cg_tycons includes newtypes, for the benefit of External Core,
-            -- but we don't generate any code for newtypes
-
-        -------------------
-        -- Insert late cost centres if enabled.
-        -- If `-fprof-late-inline` is enabled we can skip this, as it will have added
-        -- a superset of cost centres we would add here already.
-
-        (late_cc_binds, late_local_ccs) <-
-              if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags)
-                  then  {-# SCC lateCC #-} do
-                    (binds,late_ccs) <- addLateCostCentresPgm dflags logger this_mod core_binds
-                    return ( binds, (S.toList late_ccs `mappend` local_ccs ))
-                  else
-                    return (core_binds, local_ccs)
-
-
-
-        -------------------
-        -- PREPARE FOR CODE GENERATION
-        -- Do saturation and convert to A-normal form
-        (prepd_binds) <- {-# SCC "CorePrep" #-} do
-          cp_cfg <- initCorePrepConfig hsc_env
-          corePrepPgm
-            (hsc_logger hsc_env)
-            cp_cfg
-            (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))
-            this_mod location late_cc_binds data_tycons
-
-        -----------------  Convert to STG ------------------
-        (stg_binds, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos)
-            <- {-# SCC "CoreToStg" #-}
-               withTiming logger
-                   (text "CoreToStg"<+>brackets (ppr this_mod))
-                   (\(a, b, (c,d), tag_env) ->
-                        a `seqList`
-                        b `seq`
-                        c `seqList`
-                        d `seqList`
-                        (seqEltsUFM (seqTagSig) tag_env))
-                   (myCoreToStg logger dflags (hsc_IC hsc_env) False this_mod location prepd_binds)
-
-        let cost_centre_info =
-              (late_local_ccs ++ caf_ccs, caf_cc_stacks)
-            platform = targetPlatform dflags
-            prof_init
-              | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info
-              | otherwise = mempty
-
-        ------------------  Code generation ------------------
-        -- The back-end is streamed: each top-level function goes
-        -- from Stg all the way to asm before dealing with the next
-        -- top-level function, so withTiming isn't very useful here.
-        -- Hence we have one withTiming for the whole backend, the
-        -- next withTiming after this will be "Assembler" (hard code only).
-        withTiming logger (text "CodeGen"<+>brackets (ppr this_mod)) (const ())
-         $ case backendCodeOutput (backend dflags) of
-            JSCodeOutput ->
-              do
-              let js_config = initStgToJSConfig dflags
-                  cmm_cg_infos  = Nothing
-                  stub_c_exists = Nothing
-                  foreign_fps   = []
-
-              putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG
-                  (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds)
-
-              -- do the unfortunately effectual business
-              stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs0 cost_centre_info output_filename
-              return (output_filename, stub_c_exists, foreign_fps, Just stg_cg_infos, cmm_cg_infos)
-
-            _          ->
-              do
-              cmms <- {-# SCC "StgToCmm" #-}
-                doCodeGen hsc_env this_mod denv data_tycons
-                cost_centre_info
-                stg_binds hpc_info
-
-              ------------------  Code output -----------------------
-              rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
-                case cmmToRawCmmHook hooks of
-                  Nothing -> cmmToRawCmm logger profile cmms
-                  Just h  -> h dflags (Just this_mod) cmms
-
-              let dump a = do
-                    unless (null a) $ putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)
-                    return a
-                  rawcmms1 = Stream.mapM dump rawcmms0
-
-              let foreign_stubs st = foreign_stubs0
-                                     `appendStubC` prof_init
-                                     `appendStubC` cgIPEStub st
-
-              (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos)
-                  <- {-# SCC "codeOutput" #-}
-                    codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename location
-                    foreign_stubs foreign_files dependencies rawcmms1
-              return  ( output_filename, stub_c_exists, foreign_fps
-                      , Just stg_cg_infos, Just cmm_cg_infos)
-
-
--- The part of CgGuts that we need for HscInteractive
-data CgInteractiveGuts = CgInteractiveGuts { cgi_module :: Module
-                                           , cgi_binds  :: CoreProgram
-                                           , cgi_tycons :: [TyCon]
-                                           , cgi_foreign :: ForeignStubs
-                                           , cgi_modBreaks ::  Maybe ModBreaks
-                                           , cgi_spt_entries :: [SptEntry]
-                                           }
-
-mkCgInteractiveGuts :: CgGuts -> CgInteractiveGuts
-mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_modBreaks, cg_spt_entries}
-  = CgInteractiveGuts cg_module cg_binds cg_tycons cg_foreign cg_modBreaks cg_spt_entries
-
-hscInteractive :: HscEnv
-               -> CgInteractiveGuts
-               -> ModLocation
-               -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
-hscInteractive hsc_env cgguts location = do
-    let dflags = hsc_dflags hsc_env
-    let logger = hsc_logger hsc_env
-    let tmpfs  = hsc_tmpfs hsc_env
-    let CgInteractiveGuts{ -- This is the last use of the ModGuts in a compilation.
-                -- From now on, we just use the bits we need.
-               cgi_module   = this_mod,
-               cgi_binds    = core_binds,
-               cgi_tycons   = tycons,
-               cgi_foreign  = foreign_stubs,
-               cgi_modBreaks = mod_breaks,
-               cgi_spt_entries = spt_entries } = cgguts
-
-        data_tycons = filter isDataTyCon tycons
-        -- cg_tycons includes newtypes, for the benefit of External Core,
-        -- but we don't generate any code for newtypes
-
-    -------------------
-    -- PREPARE FOR CODE GENERATION
-    -- Do saturation and convert to A-normal form
-    prepd_binds <- {-# SCC "CorePrep" #-} do
-      cp_cfg <- initCorePrepConfig hsc_env
-      corePrepPgm
-        (hsc_logger hsc_env)
-        cp_cfg
-        (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))
-        this_mod location core_binds data_tycons
-
-    -- The stg cg info only provides a runtime benfit, but is not requires so we just
-    -- omit it here
-    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos)
-      <- {-# SCC "CoreToStg" #-}
-          myCoreToStg logger dflags (hsc_IC hsc_env) True this_mod location prepd_binds
-    -----------------  Generate byte code ------------------
-    comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks
-    ------------------ Create f-x-dynamic C-side stuff -----
-    (_istub_h_exists, istub_c_exists)
-        <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs
-    return (istub_c_exists, comp_bc, spt_entries)
-
-generateByteCode :: HscEnv
-  -> CgInteractiveGuts
-  -> ModLocation
-  -> IO [Unlinked]
-generateByteCode hsc_env cgguts mod_location = do
-  (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location
-
-  stub_o <- case hasStub of
-            Nothing -> return []
-            Just stub_c -> do
-                stub_o <- compileForeign hsc_env LangC stub_c
-                return [DotO stub_o]
-
-  let hs_unlinked = [BCOs comp_bc spt_entries]
-  return (hs_unlinked ++ stub_o)
-
-generateFreshByteCode :: HscEnv
-  -> ModuleName
-  -> CgInteractiveGuts
-  -> ModLocation
-  -> IO Linkable
-generateFreshByteCode hsc_env mod_name cgguts mod_location = do
-  ul <- generateByteCode hsc_env cgguts mod_location
-  unlinked_time <- getCurrentTime
-  let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) ul
-  return linkable
-------------------------------
-
-hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
-hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hsc_env $ do
-    let dflags   = hsc_dflags hsc_env
-        logger   = hsc_logger hsc_env
-        hooks    = hsc_hooks hsc_env
-        tmpfs    = hsc_tmpfs hsc_env
-        profile  = targetProfile dflags
-        home_unit = hsc_home_unit hsc_env
-        platform  = targetPlatform dflags
-        llvm_config = hsc_llvm_config hsc_env
-        cmm_config = initCmmConfig dflags
-        do_info_table = gopt Opt_InfoTableMap dflags
-        -- Make up a module name to give the NCG. We can't pass bottom here
-        -- lest we reproduce #11784.
-        mod_name = mkModuleName $ "Cmm$" ++ original_filename
-        cmm_mod = mkHomeModule home_unit mod_name
-        cmmpConfig = initCmmParserConfig dflags
-    (cmm, ipe_ents) <- ioMsgMaybe
-               $ do
-                  (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
-                                       $ parseCmmFile cmmpConfig cmm_mod home_unit filename
-                  let msgs = warns `unionMessages` errs
-                  return (GhcPsMessage <$> msgs, cmm)
-    liftIO $ do
-        putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)
-
-        -- Compile decls in Cmm files one decl at a time, to avoid re-ordering
-        -- them in SRT analysis.
-        --
-        -- Re-ordering here causes breakage when booting with C backend because
-        -- in C we must declare before use, but SRT algorithm is free to
-        -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A]
-        cmmgroup <-
-          concatMapM (\cmm -> snd <$> cmmPipeline logger cmm_config (emptySRT cmm_mod) [cmm]) cmm
-
-        unless (null cmmgroup) $
-          putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm"
-            FormatCMM (pdoc platform cmmgroup)
-
-        rawCmms <- case cmmToRawCmmHook hooks of
-          Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup)
-          Just h  -> h           dflags Nothing (Stream.yield cmmgroup)
-
-        let foreign_stubs _
-              | not $ null ipe_ents =
-                  let ip_init = ipInitCode do_info_table platform cmm_mod
-                  in NoStubs `appendStubC` ip_init
-              | otherwise     = NoStubs
-        (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)
-          <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty
-             rawCmms
-        return stub_c_exists
-  where
-    no_loc = ModLocation{ ml_hs_file  = Just original_filename,
-                          ml_hi_file  = panic "hscCompileCmmFile: no hi file",
-                          ml_obj_file = panic "hscCompileCmmFile: no obj file",
-                          ml_dyn_obj_file = panic "hscCompileCmmFile: no dyn obj file",
-                          ml_dyn_hi_file  = panic "hscCompileCmmFile: no dyn obj file",
-                          ml_hie_file = panic "hscCompileCmmFile: no hie file"}
-
--------------------- Stuff for new code gen ---------------------
-
-{-
-Note [Forcing of stg_binds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The two last steps in the STG pipeline are:
-
-* Sorting the bindings in dependency order.
-* Annotating them with free variables.
-
-We want to make sure we do not keep references to unannotated STG bindings
-alive, nor references to bindings which have already been compiled to Cmm.
-
-We explicitly force the bindings to avoid this.
-
-This reduces residency towards the end of the CodeGen phase significantly
-(5-10%).
--}
-
-doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
-          -> CollectedCCs
-          -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs
-          -> HpcInfo
-          -> IO (Stream IO CmmGroupSRTs CmmCgInfos)
-         -- Note we produce a 'Stream' of CmmGroups, so that the
-         -- backend can be run incrementally.  Otherwise it generates all
-         -- the C-- up front, which has a significant space cost.
-doCodeGen hsc_env this_mod denv data_tycons
-              cost_centre_info stg_binds_w_fvs hpc_info = do
-    let dflags     = hsc_dflags hsc_env
-        logger     = hsc_logger hsc_env
-        hooks      = hsc_hooks  hsc_env
-        tmpfs      = hsc_tmpfs  hsc_env
-        platform   = targetPlatform dflags
-        stg_ppr_opts = (initStgPprOpts dflags)
-
-    putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG
-        (pprGenStgTopBindings stg_ppr_opts stg_binds_w_fvs)
-
-    let stg_to_cmm dflags mod = case stgToCmmHook hooks of
-                        Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod)
-                        Just h  -> h                             (initStgToCmmConfig dflags mod)
-
-    let cmm_stream :: Stream IO CmmGroup ModuleLFInfos
-        -- See Note [Forcing of stg_binds]
-        cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}
-            stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info
-
-        -- codegen consumes a stream of CmmGroup, and produces a new
-        -- stream of CmmGroup (not necessarily synchronised: one
-        -- CmmGroup on input may produce many CmmGroups on output due
-        -- to proc-point splitting).
-
-    let dump1 a = do
-          unless (null a) $
-            putDumpFileMaybe logger Opt_D_dump_cmm_from_stg
-              "Cmm produced by codegen" FormatCMM (pdoc platform a)
-          return a
-
-        ppr_stream1 = Stream.mapM dump1 cmm_stream
-
-        cmm_config = initCmmConfig dflags
-
-        pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)
-        pipeline_stream = do
-          (non_cafs,  lf_infos) <-
-            {-# SCC "cmmPipeline" #-}
-            Stream.mapAccumL_ (cmmPipeline logger cmm_config) (emptySRT this_mod) ppr_stream1
-              <&> first (srtMapNonCAFs . moduleSRTMap)
-
-          return (non_cafs, lf_infos)
-
-        dump2 a = do
-          unless (null a) $
-            putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)
-          return a
-
-    return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv pipeline_stream
-
-myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
-                -> Bool
-                -> Module -> ModLocation -> CoreExpr
-                -> IO ( Id
-                      , [CgStgTopBinding]
-                      , InfoTableProvMap
-                      , CollectedCCs
-                      , StgCgInfos )
-myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do
-    {- Create a temporary binding (just because myCoreToStg needs a
-       binding for the stg2stg step) -}
-    let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")
-                                (mkPseudoUniqueE 0)
-                                ManyTy
-                                (exprType prepd_expr)
-    (stg_binds, prov_map, collected_ccs, stg_cg_infos) <-
-       myCoreToStg logger
-                   dflags
-                   ictxt
-                   for_bytecode
-                   this_mod
-                   ml
-                   [NonRec bco_tmp_id prepd_expr]
-    return (bco_tmp_id, stg_binds, prov_map, collected_ccs, stg_cg_infos)
-
-myCoreToStg :: Logger -> DynFlags -> InteractiveContext
-            -> Bool
-            -> Module -> ModLocation -> CoreProgram
-            -> IO ( [CgStgTopBinding] -- output program
-                  , InfoTableProvMap
-                  , CollectedCCs -- CAF cost centre info (declared and used)
-                  , StgCgInfos )
-myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
-    let (stg_binds, denv, cost_centre_info)
-         = {-# SCC "Core2Stg" #-}
-           coreToStg (initCoreToStgOpts dflags) this_mod ml prepd_binds
-
-    (stg_binds_with_fvs,stg_cg_info)
-        <- {-# SCC "Stg2Stg" #-}
-           stg2stg logger (interactiveInScope ictxt) (initStgPipelineOpts dflags for_bytecode)
-                   this_mod stg_binds
-
-    putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG
-        (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_with_fvs)
-
-    return (stg_binds_with_fvs, denv, cost_centre_info, stg_cg_info)
-
-{- **********************************************************************
-%*                                                                      *
-\subsection{Compiling a do-statement}
-%*                                                                      *
-%********************************************************************* -}
-
-{-
-When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
-you run it you get a list of HValues that should be the same length as the list
-of names; add them to the ClosureEnv.
-
-A naked expression returns a singleton Name [it]. The stmt is lifted into the
-IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context
--}
-
--- | Compile a stmt all the way to an HValue, but don't run it
---
--- We return Nothing to indicate an empty statement (or comment only), not a
--- parse error.
-hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
-hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
-
--- | Compile a stmt all the way to an HValue, but don't run it
---
--- We return Nothing to indicate an empty statement (or comment only), not a
--- parse error.
-hscStmtWithLocation :: HscEnv
-                    -> String -- ^ The statement
-                    -> String -- ^ The source
-                    -> Int    -- ^ Starting line
-                    -> IO ( Maybe ([Id]
-                          , ForeignHValue {- IO [HValue] -}
-                          , FixityEnv))
-hscStmtWithLocation hsc_env0 stmt source linenumber =
-  runInteractiveHsc hsc_env0 $ do
-    maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
-    case maybe_stmt of
-      Nothing -> return Nothing
-
-      Just parsed_stmt -> do
-        hsc_env <- getHscEnv
-        liftIO $ hscParsedStmt hsc_env parsed_stmt
-
-hscParsedStmt :: HscEnv
-              -> GhciLStmt GhcPs  -- ^ The parsed statement
-              -> IO ( Maybe ([Id]
-                    , ForeignHValue {- IO [HValue] -}
-                    , FixityEnv))
-hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
-  -- Rename and typecheck it
-  (ids, tc_expr, fix_env) <- ioMsgMaybe $ hoistTcRnMessage $ tcRnStmt hsc_env stmt
-
-  -- Desugar it
-  ds_expr <- ioMsgMaybe $ hoistDsMessage $ deSugarExpr hsc_env tc_expr
-  liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)
-  handleWarnings
-
-  -- Then code-gen, and link it
-  -- It's important NOT to have package 'interactive' as thisUnitId
-  -- for linking, else we try to link 'main' and can't find it.
-  -- Whereas the linker already knows to ignore 'interactive'
-  let src_span = srcLocSpan interactiveSrcLoc
-  (hval,_,_) <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
-
-  return $ Just (ids, hval, fix_env)
-
--- | Compile a decls
-hscDecls :: HscEnv
-         -> String -- ^ The statement
-         -> IO ([TyThing], InteractiveContext)
-hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
-
-hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO (HsModule GhcPs)
-hscParseModuleWithLocation hsc_env source line_num str = do
-    L _ mod <-
-      runInteractiveHsc hsc_env $
-        hscParseThingWithLocation source line_num parseModule str
-    return mod
-
-hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]
-hscParseDeclsWithLocation hsc_env source line_num str = do
-  HsModule { hsmodDecls = decls } <- hscParseModuleWithLocation hsc_env source line_num str
-  return decls
-
--- | Compile a decls
-hscDeclsWithLocation :: HscEnv
-                     -> String -- ^ The statement
-                     -> String -- ^ The source
-                     -> Int    -- ^ Starting line
-                     -> IO ([TyThing], InteractiveContext)
-hscDeclsWithLocation hsc_env str source linenumber = do
-    L _ (HsModule{ hsmodDecls = decls }) <-
-      runInteractiveHsc hsc_env $
-        hscParseThingWithLocation source linenumber parseModule str
-    hscParsedDecls hsc_env decls
-
-hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
-hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
-    hsc_env <- getHscEnv
-    let interp = hscInterp hsc_env
-
-    {- Rename and typecheck it -}
-    tc_gblenv <- ioMsgMaybe $ hoistTcRnMessage $ tcRnDeclsi hsc_env decls
-
-    {- Grab the new instances -}
-    -- We grab the whole environment because of the overlapping that may have
-    -- been done. See the notes at the definition of InteractiveContext
-    -- (ic_instances) for more details.
-    let defaults = tcg_default tc_gblenv
-
-    {- Desugar it -}
-    -- We use a basically null location for iNTERACTIVE
-    let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,
-                                      ml_hi_file   = panic "hsDeclsWithLocation:ml_hi_file",
-                                      ml_obj_file  = panic "hsDeclsWithLocation:ml_obj_file",
-                                      ml_dyn_obj_file = panic "hsDeclsWithLocation:ml_dyn_obj_file",
-                                      ml_dyn_hi_file = panic "hsDeclsWithLocation:ml_dyn_hi_file",
-                                      ml_hie_file  = panic "hsDeclsWithLocation:ml_hie_file" }
-    ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
-
-    {- Simplify -}
-    simpl_mg <- liftIO $ do
-      plugins <- readIORef (tcg_th_coreplugins tc_gblenv)
-      hscSimplify hsc_env plugins ds_result
-
-    {- Tidy -}
-    (tidy_cg, mod_details) <- liftIO $ hscTidy hsc_env simpl_mg
-
-    let !CgGuts{ cg_module    = this_mod,
-                 cg_binds     = core_binds,
-                 cg_tycons    = tycons,
-                 cg_modBreaks = mod_breaks } = tidy_cg
-
-        !ModDetails { md_insts     = cls_insts
-                    , md_fam_insts = fam_insts } = mod_details
-            -- Get the *tidied* cls_insts and fam_insts
-
-        data_tycons = filter isDataTyCon tycons
-
-    {- Prepare For Code Generation -}
-    -- Do saturation and convert to A-normal form
-    prepd_binds <- {-# SCC "CorePrep" #-} liftIO $ do
-      cp_cfg <- initCorePrepConfig hsc_env
-      corePrepPgm
-        (hsc_logger hsc_env)
-        cp_cfg
-        (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))
-        this_mod iNTERACTIVELoc core_binds data_tycons
-
-    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _stg_cg_info)
-        <- {-# SCC "CoreToStg" #-}
-           liftIO $ myCoreToStg (hsc_logger hsc_env)
-                                (hsc_dflags hsc_env)
-                                (hsc_IC hsc_env)
-                                True
-                                this_mod
-                                iNTERACTIVELoc
-                                prepd_binds
-
-    {- Generate byte code -}
-    cbc <- liftIO $ byteCodeGen hsc_env this_mod
-                                stg_binds data_tycons mod_breaks
-
-    let src_span = srcLocSpan interactiveSrcLoc
-    _ <- liftIO $ loadDecls interp hsc_env src_span cbc
-
-    {- Load static pointer table entries -}
-    liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)
-
-    let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
-        patsyns = mg_patsyns simpl_mg
-
-        ext_ids = [ id | id <- bindersOfBinds core_binds
-                       , isExternalName (idName id)
-                       , not (isDFunId id || isImplicitId id) ]
-            -- We only need to keep around the external bindings
-            -- (as decided by GHC.Iface.Tidy), since those are the only ones
-            -- that might later be looked up by name.  But we can exclude
-            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Runtime.Context
-            --    - Implicit Ids, which are implicit in tcs
-            -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv
-
-        new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
-        ictxt        = hsc_IC hsc_env
-        -- See Note [Fixity declarations in GHCi]
-        fix_env      = tcg_fix_env tc_gblenv
-        new_ictxt    = extendInteractiveContext ictxt new_tythings cls_insts
-                                                fam_insts defaults fix_env
-    return (new_tythings, new_ictxt)
-
--- | Load the given static-pointer table entries into the interpreter.
--- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".
-hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()
-hscAddSptEntries hsc_env entries = do
-    let interp = hscInterp hsc_env
-    let add_spt_entry :: SptEntry -> IO ()
-        add_spt_entry (SptEntry i fpr) = do
-            -- These are only names from the current module
-            (val, _, _) <- loadName interp hsc_env (idName i)
-            addSptEntry interp fpr val
-    mapM_ add_spt_entry entries
-
-{-
-  Note [Fixity declarations in GHCi]
-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  To support fixity declarations on types defined within GHCi (as requested
-  in #10018) we record the fixity environment in InteractiveContext.
-  When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this
-  fixity environment and uses it to initialize the global typechecker environment.
-  After the typechecker has finished its business, an updated fixity environment
-  (reflecting whatever fixity declarations were present in the statements we
-  passed it) will be returned from hscParsedStmt. This is passed to
-  updateFixityEnv, which will stuff it back into InteractiveContext, to be
-  used in evaluating the next statement.
-
--}
-
-hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)
-hscImport hsc_env str = runInteractiveHsc hsc_env $ do
-    -- Use >>= \case instead of MonadFail desugaring to take into
-    -- consideration `instance XXModule p = DataConCantHappen`.
-    -- Tracked in #15681
-    hscParseThing parseModule str >>= \case
-      (L _ (HsModule{hsmodImports=is})) ->
-        case is of
-            [L _ i] -> return i
-            _ -> liftIO $ throwOneError $
-                     mkPlainErrorMsgEnvelope noSrcSpan $
-                     GhcPsMessage $ PsUnknownMessage $
-                     UnknownDiagnostic $ mkPlainError noHints $
-                         text "parse error in import declaration"
-
--- | Typecheck an expression (but don't run it)
-hscTcExpr :: HscEnv
-          -> TcRnExprMode
-          -> String -- ^ The expression
-          -> IO Type
-hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do
-  hsc_env <- getHscEnv
-  parsed_expr <- hscParseExpr expr
-  ioMsgMaybe $ hoistTcRnMessage $ tcRnExpr hsc_env mode parsed_expr
-
--- | Find the kind of a type, after generalisation
-hscKcType
-  :: HscEnv
-  -> Bool            -- ^ Normalise the type
-  -> String          -- ^ The type as a string
-  -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
-hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
-    hsc_env <- getHscEnv
-    ty <- hscParseType str
-    ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env DefaultFlexi normalise ty
-
-hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
-hscParseExpr expr = do
-  maybe_stmt <- hscParseStmt expr
-  case maybe_stmt of
-    Just (L _ (BodyStmt _ expr _ _)) -> return expr
-    _ -> throwOneError $
-           mkPlainErrorMsgEnvelope noSrcSpan $
-           GhcPsMessage $ PsUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $
-             text "not an expression:" <+> quotes (text expr)
-
-hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
-hscParseStmt = hscParseThing parseStmt
-
-hscParseStmtWithLocation :: String -> Int -> String
-                         -> Hsc (Maybe (GhciLStmt GhcPs))
-hscParseStmtWithLocation source linenumber stmt =
-    hscParseThingWithLocation source linenumber parseStmt stmt
-
-hscParseType :: String -> Hsc (LHsType GhcPs)
-hscParseType = hscParseThing parseType
-
-hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName)
-hscParseIdentifier hsc_env str =
-    runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
-
-hscParseThing :: (Outputable thing, Data thing)
-              => Lexer.P thing -> String -> Hsc thing
-hscParseThing = hscParseThingWithLocation "<interactive>" 1
-
-hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
-                          -> Lexer.P thing -> String -> Hsc thing
-hscParseThingWithLocation source linenumber parser str = do
-    dflags <- getDynFlags
-    logger <- getLogger
-    withTiming logger
-               (text "Parser [source]")
-               (const ()) $ {-# SCC "Parser" #-} do
-
-        let buf = stringToStringBuffer str
-            loc = mkRealSrcLoc (fsLit source) linenumber 1
-
-        case unP parser (initParserState (initParserOpts dflags) buf loc) of
-            PFailed pst ->
-                handleWarningsThrowErrors (getPsMessages pst)
-            POk pst thing -> do
-                logWarningsReportErrors (getPsMessages pst)
-                liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser"
-                            FormatHaskell (ppr thing)
-                liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"
-                            FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing)
-                return thing
-
-hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
-hscTidy hsc_env guts = do
-  let logger   = hsc_logger hsc_env
-  let this_mod = mg_module guts
-
-  opts <- initTidyOpts hsc_env
-  (cgguts, details) <- withTiming logger
-    (text "CoreTidy"<+>brackets (ppr this_mod))
-    (const ())
-    $! {-# SCC "CoreTidy" #-} tidyProgram opts guts
-
-  -- post tidy pretty-printing and linting...
-  let tidy_rules     = md_rules details
-  let all_tidy_binds = cg_binds cgguts
-  let name_ppr_ctx   = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
-      ptc            = initPromotionTickContext (hsc_dflags hsc_env)
-
-  endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
-
-  -- If the endPass didn't print the rules, but ddump-rules is
-  -- on, print now
-  unless (logHasDumpFlag logger Opt_D_dump_simpl) $
-    putDumpFileMaybe logger Opt_D_dump_rules
-      "Tidy Core rules"
-      FormatText
-      (pprRulesForUser tidy_rules)
-
-  -- Print one-line size info
-  let cs = coreBindsStats all_tidy_binds
-  putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats"
-    FormatText
-    (text "Tidy size (terms,types,coercions)"
-     <+> ppr (moduleName this_mod) <> colon
-     <+> int (cs_tm cs)
-     <+> int (cs_ty cs)
-     <+> int (cs_co cs))
-
-  pure (cgguts, details)
-
-
-{- **********************************************************************
-%*                                                                      *
-        Desugar, simplify, convert to bytecode, and link an expression
-%*                                                                      *
-%********************************************************************* -}
-
-hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)
-hscCompileCoreExpr hsc_env loc expr =
-  case hscCompileCoreExprHook (hsc_hooks hsc_env) of
-      Nothing -> hscCompileCoreExpr' hsc_env loc expr
-      Just h  -> h                   hsc_env loc expr
-
-hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)
-hscCompileCoreExpr' hsc_env srcspan ds_expr
-    = do { {- Simplify it -}
-           -- Question: should we call SimpleOpt.simpleOptExpr here instead?
-           -- It is, well, simpler, and does less inlining etc.
-           let dflags = hsc_dflags hsc_env
-         ; let logger = hsc_logger hsc_env
-         ; let ic = hsc_IC hsc_env
-         ; let unit_env = hsc_unit_env hsc_env
-         ; let simplify_expr_opts = initSimplifyExprOpts dflags ic
-         ; simpl_expr <- simplifyExpr logger (ue_eps unit_env) simplify_expr_opts ds_expr
-
-           {- Tidy it (temporary, until coreSat does cloning) -}
-         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
-
-           {- Prepare for codegen -}
-         ; cp_cfg <- initCorePrepConfig hsc_env
-         ; prepd_expr <- corePrepExpr
-            logger cp_cfg
-            tidy_expr
-
-           {- Lint if necessary -}
-         ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr
-         ; let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,
-                                      ml_hi_file   = panic "hscCompileCoreExpr':ml_hi_file",
-                                      ml_obj_file  = panic "hscCompileCoreExpr':ml_obj_file",
-                                      ml_dyn_obj_file = panic "hscCompileCoreExpr': ml_obj_file",
-                                      ml_dyn_hi_file  = panic "hscCompileCoreExpr': ml_dyn_hi_file",
-                                      ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file" }
-
-         ; let ictxt = hsc_IC hsc_env
-         ; (binding_id, stg_expr, _, _, _stg_cg_info) <-
-             myCoreToStgExpr logger
-                             dflags
-                             ictxt
-                             True
-                             (icInteractiveModule ictxt)
-                             iNTERACTIVELoc
-                             prepd_expr
-
-           {- Convert to BCOs -}
-         ; bcos <- byteCodeGen hsc_env
-                     (icInteractiveModule ictxt)
-                     stg_expr
-                     [] Nothing
-
-           {- load it -}
-         ; (fv_hvs, mods_needed, units_needed) <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos
-           {- Get the HValue for the root -}
-         ; return (expectJust "hscCompileCoreExpr'"
-              $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed) }
-
-
-{- **********************************************************************
-%*                                                                      *
-        Statistics on reading interfaces
-%*                                                                      *
-%********************************************************************* -}
-
-dumpIfaceStats :: HscEnv -> IO ()
-dumpIfaceStats hsc_env = do
-  eps <- hscEPS hsc_env
-  let
-    logger = hsc_logger hsc_env
-    dump_rn_stats = logHasDumpFlag logger Opt_D_dump_rn_stats
-    dump_if_trace = logHasDumpFlag logger Opt_D_dump_if_trace
-  when (dump_if_trace || dump_rn_stats) $
-    logDumpMsg logger "Interface statistics" (ifaceStats eps)
-
-
-{- **********************************************************************
-%*                                                                      *
-        Progress Messages: Module i of n
-%*                                                                      *
-%********************************************************************* -}
-
-showModuleIndex :: (Int, Int) -> SDoc
-showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] "
-  where
-    -- compute the length of x > 0 in base 10
-    len x = ceiling (logBase 10 (fromIntegral x+1) :: Float)
-    pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr
-
-writeInterfaceOnlyMode :: DynFlags -> Bool
-writeInterfaceOnlyMode dflags =
- gopt Opt_WriteInterface dflags &&
- not (backendGeneratesCode (backend dflags))
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Make.hs
+++ /dev/null
@@ -1,2976 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NondecreasingIndentation #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE GeneralisedNewtypeDeriving #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE RecordWildCards #-}
-
--- -----------------------------------------------------------------------------
---
--- (c) The University of Glasgow, 2011
---
--- This module implements multi-module compilation, and is used
--- by --make and GHCi.
---
--- -----------------------------------------------------------------------------
-module GHC.Driver.Make (
-        depanal, depanalE, depanalPartial, checkHomeUnitsClosed,
-        load, loadWithCache, load', LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache,
-        instantiationNodes,
-
-        downsweep,
-
-        topSortModuleGraph,
-
-        ms_home_srcimps, ms_home_imps,
-
-        summariseModule,
-        SummariseResult(..),
-        summariseFile,
-        hscSourceToIsBoot,
-        findExtraSigImports,
-        implicitRequirementsShallow,
-
-        noModError, cyclicModuleErr,
-        SummaryNode,
-        IsBootInterface(..), mkNodeKey,
-
-        ModNodeKey, ModNodeKeyWithUid(..),
-        ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith
-        ) where
-
-import GHC.Prelude
-import GHC.Platform
-
-import GHC.Tc.Utils.Backpack
-import GHC.Tc.Utils.Monad  ( initIfaceCheck, concatMapM )
-
-import GHC.Runtime.Interpreter
-import qualified GHC.Linker.Loader as Linker
-import GHC.Linker.Types
-
-import GHC.Platform.Ways
-
-import GHC.Driver.Config.Finder (initFinderOpts)
-import GHC.Driver.Config.Parser (initParserOpts)
-import GHC.Driver.Config.Diagnostic
-import GHC.Driver.Phases
-import GHC.Driver.Pipeline
-import GHC.Driver.Session
-import GHC.Driver.Backend
-import GHC.Driver.Monad
-import GHC.Driver.Env
-import GHC.Driver.Errors
-import GHC.Driver.Errors.Types
-import GHC.Driver.Main
-
-import GHC.Parser.Header
-
-import GHC.Iface.Load      ( cannotFindModule )
-import GHC.IfaceToCore     ( typecheckIface )
-import GHC.Iface.Recomp    ( RecompileRequired(..), CompileReason(..) )
-
-import GHC.Data.Bag        ( listToBag )
-import GHC.Data.Graph.Directed
-import GHC.Data.FastString
-import GHC.Data.Maybe      ( expectJust )
-import GHC.Data.StringBuffer
-import qualified GHC.LanguageExtensions as LangExt
-
-import GHC.Utils.Exception ( throwIO, SomeAsyncException )
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Misc
-import GHC.Utils.Error
-import GHC.Utils.Logger
-import GHC.Utils.Fingerprint
-import GHC.Utils.TmpFs
-
-import GHC.Types.Basic
-import GHC.Types.Error
-import GHC.Types.Target
-import GHC.Types.SourceFile
-import GHC.Types.SourceError
-import GHC.Types.SrcLoc
-import GHC.Types.Unique.FM
-import GHC.Types.PkgQual
-
-import GHC.Unit
-import GHC.Unit.Env
-import GHC.Unit.Finder
-import GHC.Unit.Module.ModSummary
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.Graph
-import GHC.Unit.Home.ModInfo
-import GHC.Unit.Module.ModDetails
-
-import Data.Either ( rights, partitionEithers, lefts )
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-
-import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
-import qualified GHC.Conc as CC
-import Control.Concurrent.MVar
-import Control.Monad
-import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
-import qualified Control.Monad.Catch as MC
-import Data.IORef
-import Data.Maybe
-import Data.Time
-import Data.Bifunctor (first)
-import System.Directory
-import System.FilePath
-import System.IO        ( fixIO )
-
-import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Reader
-import GHC.Driver.Pipeline.LogQueue
-import qualified Data.Map.Strict as M
-import GHC.Types.TypeEnv
-import Control.Monad.Trans.State.Lazy
-import Control.Monad.Trans.Class
-import GHC.Driver.Env.KnotVars
-import Control.Concurrent.STM
-import Control.Monad.Trans.Maybe
-import GHC.Runtime.Loader
-import GHC.Rename.Names
-import GHC.Utils.Constants
-import GHC.Types.Unique.DFM (udfmRestrictKeysSet)
-import qualified Data.IntSet as I
-import GHC.Types.Unique
-
-
--- -----------------------------------------------------------------------------
--- Loading the program
-
--- | Perform a dependency analysis starting from the current targets
--- and update the session with the new module graph.
---
--- Dependency analysis entails parsing the @import@ directives and may
--- therefore require running certain preprocessors.
---
--- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
--- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
--- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want
--- changes to the 'DynFlags' to take effect you need to call this function
--- again.
--- In case of errors, just throw them.
---
-depanal :: GhcMonad m =>
-           [ModuleName]  -- ^ excluded modules
-        -> Bool          -- ^ allow duplicate roots
-        -> m ModuleGraph
-depanal excluded_mods allow_dup_roots = do
-    (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots
-    if isEmptyMessages errs
-      then pure mod_graph
-      else throwErrors (fmap GhcDriverMessage errs)
-
--- | Perform dependency analysis like in 'depanal'.
--- In case of errors, the errors and an empty module graph are returned.
-depanalE :: GhcMonad m =>     -- New for #17459
-            [ModuleName]      -- ^ excluded modules
-            -> Bool           -- ^ allow duplicate roots
-            -> m (DriverMessages, ModuleGraph)
-depanalE excluded_mods allow_dup_roots = do
-    hsc_env <- getSession
-    (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots
-    if isEmptyMessages errs
-      then do
-        hsc_env <- getSession
-        let one_unit_messages get_mod_errs k hue = do
-              errs <- get_mod_errs
-              unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph
-
-              let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph
-                  unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph
-
-
-              return $ errs `unionMessages` unused_home_mod_err
-                          `unionMessages` unused_pkg_err
-                          `unionMessages` unknown_module_err
-
-        all_errs <- liftIO $ unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env)
-        logDiagnostics (GhcDriverMessage <$> all_errs)
-        setSession hsc_env { hsc_mod_graph = mod_graph }
-        pure (emptyMessages, mod_graph)
-      else do
-        -- We don't have a complete module dependency graph,
-        -- The graph may be disconnected and is unusable.
-        setSession hsc_env { hsc_mod_graph = emptyMG }
-        pure (errs, emptyMG)
-
-
--- | Perform dependency analysis like 'depanal' but return a partial module
--- graph even in the face of problems with some modules.
---
--- Modules which have parse errors in the module header, failing
--- preprocessors or other issues preventing them from being summarised will
--- simply be absent from the returned module graph.
---
--- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the
--- new module graph.
-depanalPartial
-    :: GhcMonad m
-    => [ModuleName]  -- ^ excluded modules
-    -> Bool          -- ^ allow duplicate roots
-    -> m (DriverMessages, ModuleGraph)
-    -- ^ possibly empty 'Bag' of errors and a module graph.
-depanalPartial excluded_mods allow_dup_roots = do
-  hsc_env <- getSession
-  let
-         targets = hsc_targets hsc_env
-         old_graph = hsc_mod_graph hsc_env
-         logger  = hsc_logger hsc_env
-
-  withTiming logger (text "Chasing dependencies") (const ()) $ do
-    liftIO $ debugTraceMsg logger 2 (hcat [
-              text "Chasing modules from: ",
-              hcat (punctuate comma (map pprTarget targets))])
-
-    -- Home package modules may have been moved or deleted, and new
-    -- source files may have appeared in the home package that shadow
-    -- external package modules, so we have to discard the existing
-    -- cached finder data.
-    liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)
-
-    (errs, graph_nodes) <- liftIO $ downsweep
-      hsc_env (mgModSummaries old_graph)
-      excluded_mods allow_dup_roots
-    let
-      mod_graph = mkModuleGraph graph_nodes
-    return (unionManyMessages errs, mod_graph)
-
--- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.
--- These are used to represent the type checking that is done after
--- all the free holes (sigs in current package) relevant to that instantiation
--- are compiled. This is necessary to catch some instantiation errors.
---
--- In the future, perhaps more of the work of instantiation could be moved here,
--- instead of shoved in with the module compilation nodes. That could simplify
--- backpack, and maybe hs-boot too.
-instantiationNodes :: UnitId -> UnitState -> [ModuleGraphNode]
-instantiationNodes uid unit_state = InstantiationNode uid <$> iuids_to_check
-  where
-    iuids_to_check :: [InstantiatedUnit]
-    iuids_to_check =
-      nubSort $ concatMap (goUnitId . fst) (explicitUnits unit_state)
-     where
-      goUnitId uid =
-        [ recur
-        | VirtUnit indef <- [uid]
-        , inst <- instUnitInsts indef
-        , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst
-        ]
-
--- The linking plan for each module. If we need to do linking for a home unit
--- then this function returns a graph node which depends on all the modules in the home unit.
-
--- At the moment nothing can depend on these LinkNodes.
-linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)
-linkNodes summaries uid hue =
-  let dflags = homeUnitEnv_dflags hue
-      ofile = outputFile_ dflags
-
-      unit_nodes :: [NodeKey]
-      unit_nodes = map mkNodeKey (filter ((== uid) . moduleGraphNodeUnitId) summaries)
-  -- Issue a warning for the confusing case where the user
-  -- said '-o foo' but we're not going to do any linking.
-  -- We attempt linking if either (a) one of the modules is
-  -- called Main, or (b) the user said -no-hs-main, indicating
-  -- that main() is going to come from somewhere else.
-  --
-      no_hs_main = gopt Opt_NoHsMain dflags
-
-      main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes
-
-      do_linking =  main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib
-
-  in if | ghcLink dflags == LinkBinary && isJust ofile && not do_linking ->
-            Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))
-        -- This should be an error, not a warning (#10895).
-        | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid))
-        | otherwise  -> Nothing
-
--- Note [Missing home modules]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Sometimes user doesn't want GHC to pick up modules, not explicitly listed
--- in a command line. For example, cabal may want to enable this warning
--- when building a library, so that GHC warns user about modules, not listed
--- neither in `exposed-modules`, nor in `other-modules`.
---
--- Here "home module" means a module, that doesn't come from an other package.
---
--- For example, if GHC is invoked with modules "A" and "B" as targets,
--- but "A" imports some other module "C", then GHC will issue a warning
--- about module "C" not being listed in a command line.
---
--- The warning in enabled by `-Wmissing-home-modules`. See #13129
-warnMissingHomeModules ::  DynFlags -> [Target] -> ModuleGraph -> DriverMessages
-warnMissingHomeModules dflags targets mod_graph =
-    if null missing
-      then emptyMessages
-      else warn
-  where
-    diag_opts = initDiagOpts dflags
-
-    is_known_module mod = any (is_my_target mod) targets
-
-    -- We need to be careful to handle the case where (possibly
-    -- path-qualified) filenames (aka 'TargetFile') rather than module
-    -- names are being passed on the GHC command-line.
-    --
-    -- For instance, `ghc --make src-exe/Main.hs` and
-    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.
-    -- Note also that we can't always infer the associated module name
-    -- directly from the filename argument.  See #13727.
-    is_my_target mod target =
-      let tuid = targetUnitId target
-      in case targetId target of
-          TargetModule name
-            -> moduleName (ms_mod mod) == name
-                && tuid == ms_unitid mod
-          TargetFile target_file _
-            | Just mod_file <- ml_hs_file (ms_location mod)
-            ->
-             target_file == mod_file ||
-
-             --  Don't warn on B.hs-boot if B.hs is specified (#16551)
-             addBootSuffix target_file == mod_file ||
-
-             --  We can get a file target even if a module name was
-             --  originally specified in a command line because it can
-             --  be converted in guessTarget (by appending .hs/.lhs).
-             --  So let's convert it back and compare with module name
-             mkModuleName (fst $ splitExtension target_file)
-              == moduleName (ms_mod mod)
-          _ -> False
-
-    missing = map (moduleName . ms_mod) $
-      filter (not . is_known_module) $
-        (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)
-                (mgModSummaries mod_graph))
-
-    warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan
-                         $ DriverMissingHomeModules missing (checkBuildingCabalPackage dflags)
-
--- Check that any modules we want to reexport or hide are actually in the package.
-warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages
-warnUnknownModules hsc_env dflags mod_graph = do
-  reexported_warns <- filterM check_reexport (Set.toList reexported_mods)
-  return $ final_msgs hidden_warns reexported_warns
-  where
-    diag_opts = initDiagOpts dflags
-
-    unit_mods = Set.fromList (map ms_mod_name
-                  (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)
-                       (mgModSummaries mod_graph)))
-
-    reexported_mods = reexportedModules dflags
-    hidden_mods     = hiddenModules dflags
-
-    hidden_warns = hidden_mods `Set.difference` unit_mods
-
-    lookupModule mn = findImportedModule hsc_env mn NoPkgQual
-
-    check_reexport mn = do
-      fr <- lookupModule mn
-      case fr of
-        Found _ m -> return (moduleUnitId m == homeUnitId_ dflags)
-        _ -> return True
-
-
-    warn flag mod = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan
-                         $ flag mod
-
-    final_msgs hidden_warns reexported_warns
-          =
-        unionManyMessages $
-          [warn DriverUnknownHiddenModules (Set.toList hidden_warns) | not (Set.null hidden_warns)]
-          ++ [warn DriverUnknownReexportedModules reexported_warns | not (null reexported_warns)]
-
--- | Describes which modules of the module graph need to be loaded.
-data LoadHowMuch
-   = LoadAllTargets
-     -- ^ Load all targets and its dependencies.
-   | LoadUpTo HomeUnitModule
-     -- ^ Load only the given module and its dependencies.
-   | LoadDependenciesOf HomeUnitModule
-     -- ^ Load only the dependencies of the given module, but not the module
-     -- itself.
-
-{-
-Note [Caching HomeModInfo]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-API clients who call `load` like to cache the HomeModInfo in memory between
-calls to this function. In the old days, this cache was a simple MVar which stored
-a HomePackageTable. This was insufficient, as the interface files for boot modules
-were not recorded in the cache. In the less old days, the cache was returned at the
-end of load, and supplied at the start of load, however, this was not sufficient
-because it didn't account for the possibility of exceptions such as SIGINT (#20780).
-
-So now, in the current day, we have this ModIfaceCache abstraction which
-can incrementally be updated during the process of upsweep. This allows us
-to store interface files for boot modules in an exception-safe way.
-
-When the final version of an interface file is completed then it is placed into
-the cache. The contents of the cache is retrieved, and the cache cleared, by iface_clearCache.
-
-Note that because we only store the ModIface and Linkable in the ModIfaceCache,
-hydration and rehydration is totally irrelevant, and we just store the CachedIface as
-soon as it is completed.
-
--}
-
-
--- Abstract interface to a cache of HomeModInfo
--- See Note [Caching HomeModInfo]
-data ModIfaceCache = ModIfaceCache { iface_clearCache :: IO [CachedIface]
-                                   , iface_addToCache :: CachedIface -> IO () }
-
-addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO ()
-addHmiToCache c (HomeModInfo i _ l) = iface_addToCache c (CachedIface i l)
-
-data CachedIface = CachedIface { cached_modiface :: !ModIface
-                               , cached_linkable :: !HomeModLinkable }
-
-noIfaceCache :: Maybe ModIfaceCache
-noIfaceCache = Nothing
-
-newIfaceCache :: IO ModIfaceCache
-newIfaceCache = do
-  ioref <- newIORef []
-  return $
-    ModIfaceCache
-      { iface_clearCache = atomicModifyIORef' ioref (\c -> ([], c))
-      , iface_addToCache = \hmi -> atomicModifyIORef' ioref (\c -> (hmi:c, ()))
-      }
-
-
-
-
--- | Try to load the program.  See 'LoadHowMuch' for the different modes.
---
--- This function implements the core of GHC's @--make@ mode.  It preprocesses,
--- compiles and loads the specified modules, avoiding re-compilation wherever
--- possible.  Depending on the backend (see 'DynFlags.backend' field) compiling
--- and loading may result in files being created on disk.
---
--- Calls the 'defaultWarnErrLogger' after each compiling each module, whether
--- successful or not.
---
--- If errors are encountered during dependency analysis, the module `depanalE`
--- returns together with the errors an empty ModuleGraph.
--- After processing this empty ModuleGraph, the errors of depanalE are thrown.
--- All other errors are reported using the 'defaultWarnErrLogger'.
-
-load :: GhcMonad f => LoadHowMuch -> f SuccessFlag
-load how_much = loadWithCache noIfaceCache how_much
-
-mkBatchMsg :: HscEnv -> Messager
-mkBatchMsg hsc_env =
-  if length (hsc_all_home_unit_ids hsc_env) > 1
-    -- This also displays what unit each module is from.
-    then batchMultiMsg
-    else batchMsg
-
-
-loadWithCache :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag
-loadWithCache cache how_much = do
-    (errs, mod_graph) <- depanalE [] False                        -- #17459
-    msg <- mkBatchMsg <$> getSession
-    success <- load' cache how_much (Just msg) mod_graph
-    if isEmptyMessages errs
-      then pure success
-      else throwErrors (fmap GhcDriverMessage errs)
-
--- Note [Unused packages]
--- ~~~~~~~~~~~~~~~~~~~~~~
--- Cabal passes `--package-id` flag for each direct dependency. But GHC
--- loads them lazily, so when compilation is done, we have a list of all
--- actually loaded packages. All the packages, specified on command line,
--- but never loaded, are probably unused dependencies.
-
-warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
-warnUnusedPackages us dflags mod_graph =
-    let diag_opts = initDiagOpts dflags
-
-    -- Only need non-source imports here because SOURCE imports are always HPT
-        loadedPackages = concat $
-          mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
-            $ concatMap ms_imps (
-              filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph))
-
-        used_args = Set.fromList $ map unitId loadedPackages
-
-        resolve (u,mflag) = do
-                  -- The units which we depend on via the command line explicitly
-                  flag <- mflag
-                  -- Which we can find the UnitInfo for (should be all of them)
-                  ui <- lookupUnit us u
-                  -- Which are not explicitly used
-                  guard (Set.notMember (unitId ui) used_args)
-                  return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag)
-
-        unusedArgs = mapMaybe resolve (explicitUnits us)
-
-        warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs)
-
-    in if null unusedArgs
-        then emptyMessages
-        else warn
-
--- | A ModuleGraphNode which also has a hs-boot file, and the list of nodes on any
--- path from module to its boot file.
-data ModuleGraphNodeWithBootFile
-  = ModuleGraphNodeWithBootFile
-     ModuleGraphNode
-       -- ^ The module itself (not the hs-boot module)
-     [NodeKey]
-       -- ^ The modules in between the module and its hs-boot file,
-       -- not including the hs-boot file itself.
-
-
-instance Outputable ModuleGraphNodeWithBootFile where
-  ppr (ModuleGraphNodeWithBootFile mgn deps) = text "ModeGraphNodeWithBootFile: " <+> ppr mgn $$ ppr deps
-
--- | A 'BuildPlan' is the result of attempting to linearise a single strongly-connected
--- component of the module graph.
-data BuildPlan
-  -- | A simple, single module all alone (which *might* have an hs-boot file, if it isn't part of a cycle)
-  = SingleModule ModuleGraphNode
-  -- | A resolved cycle, linearised by hs-boot files
-  | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]
-  -- | An actual cycle, which wasn't resolved by hs-boot files
-  | UnresolvedCycle [ModuleGraphNode]
-
-instance Outputable BuildPlan where
-  ppr (SingleModule mgn) = text "SingleModule" <> parens (ppr mgn)
-  ppr (ResolvedCycle mgn)   = text "ResolvedCycle:" <+> ppr mgn
-  ppr (UnresolvedCycle mgn) = text "UnresolvedCycle:" <+> ppr mgn
-
-
--- Just used for an assertion
-countMods :: BuildPlan -> Int
-countMods (SingleModule _) = 1
-countMods (ResolvedCycle ns) = length ns
-countMods (UnresolvedCycle ns) = length ns
-
--- See Note [Upsweep] for a high-level description.
-createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]
-createBuildPlan mod_graph maybe_top_mod =
-    let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles
-        cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod
-
-        -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles.
-        build_plan :: [BuildPlan]
-        build_plan
-          -- Fast path, if there are no boot modules just do a normal toposort
-          | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod
-          | otherwise = toBuildPlan cycle_mod_graph []
-
-        toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
-        toBuildPlan [] mgn = collapseAcyclic (topSortWithBoot mgn)
-        toBuildPlan ((AcyclicSCC node):sccs) mgn = toBuildPlan sccs (node:mgn)
-        -- Interesting case
-        toBuildPlan ((CyclicSCC nodes):sccs) mgn =
-          let acyclic = collapseAcyclic (topSortWithBoot mgn)
-              -- Now perform another toposort but just with these nodes and relevant hs-boot files.
-              -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph.
-              mresolved_cycle = collapseSCC (topSortWithBoot nodes)
-          in acyclic ++ [maybe (UnresolvedCycle nodes) ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []
-
-        (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph)
-        trans_deps_map = allReachable mg (mkNodeKey . node_payload)
-        -- Compute the intermediate modules between a file and its hs-boot file.
-        -- See Step 2a in Note [Upsweep]
-        boot_path mn uid =
-          map (summaryNodeSummary . expectJust "toNode" . lookup_node) $ Set.toList $
-          -- Don't include the boot module itself
-          Set.delete (NodeKey_Module (key IsBoot))  $
-          -- Keep intermediate dependencies: as per Step 2a in Note [Upsweep], these are
-          -- the transitive dependencies of the non-boot file which transitively depend
-          -- on the boot file.
-          Set.filter (\nk -> nodeKeyUnitId nk == uid  -- Cheap test
-                              && (NodeKey_Module (key IsBoot)) `Set.member` expectJust "dep_on_boot" (M.lookup nk trans_deps_map)) $
-          expectJust "not_boot_dep" (M.lookup (NodeKey_Module (key NotBoot)) trans_deps_map)
-          where
-            key ib = ModNodeKeyWithUid (GWIB mn ib) uid
-
-
-        -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists
-        boot_modules = mkModuleEnv
-          [ (ms_mod ms, (m, boot_path (ms_mod_name ms) (ms_unitid ms))) | m@(ModuleNode _ ms) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]
-
-        select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
-        select_boot_modules = mapMaybe (fmap fst . get_boot_module)
-
-        get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])
-        get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing
-
-        -- Any cycles should be resolved now
-        collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]
-        -- Must be at least two nodes, as we were in a cycle
-        collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Just [toNodeWithBoot node1, toNodeWithBoot node2]
-        collapseSCC (AcyclicSCC node : nodes) = (toNodeWithBoot node :) <$> collapseSCC nodes
-        -- Cyclic
-        collapseSCC _ = Nothing
-
-        toNodeWithBoot :: ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile
-        toNodeWithBoot mn =
-          case get_boot_module mn of
-            -- The node doesn't have a boot file
-            Nothing -> Left mn
-            -- The node does have a boot file
-            Just path -> Right (ModuleGraphNodeWithBootFile mn (map mkNodeKey (snd path)))
-
-        -- The toposort and accumulation of acyclic modules is solely to pick-up
-        -- hs-boot files which are **not** part of cycles.
-        collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]
-        collapseAcyclic (AcyclicSCC node : nodes) = SingleModule node : collapseAcyclic nodes
-        collapseAcyclic (CyclicSCC cy_nodes : nodes) = (UnresolvedCycle cy_nodes) : collapseAcyclic nodes
-        collapseAcyclic [] = []
-
-        topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing
-
-
-  in
-
-    assertPpr (sum (map countMods build_plan) == length (mgModSummaries' mod_graph))
-              (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (length (mgModSummaries' mod_graph )))])
-              build_plan
-
--- | Generalized version of 'load' which also supports a custom
--- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
--- produced by calling 'depanal'.
-load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
-load' mhmi_cache how_much mHscMessage mod_graph = do
-    modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }
-    guessOutputFile
-    hsc_env <- getSession
-
-    let dflags = hsc_dflags hsc_env
-    let logger = hsc_logger hsc_env
-    let interp = hscInterp hsc_env
-
-    -- The "bad" boot modules are the ones for which we have
-    -- B.hs-boot in the module graph, but no B.hs
-    -- The downsweep should have ensured this does not happen
-    -- (see msDeps)
-    let all_home_mods =
-          Set.fromList [ Module (ms_unitid s) (ms_mod_name s)
-                    | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]
-    -- TODO: Figure out what the correct form of this assert is. It's violated
-    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot
-    -- files without corresponding hs files.
-    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,
-    --                              not (ms_mod_name s `elem` all_home_mods)]
-    -- assert (null bad_boot_mods ) return ()
-
-    -- check that the module given in HowMuch actually exists, otherwise
-    -- topSortModuleGraph will bomb later.
-    let checkHowMuch (LoadUpTo m)           = checkMod m
-        checkHowMuch (LoadDependenciesOf m) = checkMod m
-        checkHowMuch _ = id
-
-        checkMod m and_then
-            | m `Set.member` all_home_mods = and_then
-            | otherwise = do
-                    liftIO $ errorMsg logger
-                        (text "no such module:" <+> quotes (ppr (moduleUnit m) <> colon <> ppr (moduleName m)))
-                    return Failed
-
-    checkHowMuch how_much $ do
-
-    -- mg2_with_srcimps drops the hi-boot nodes, returning a
-    -- graph with cycles. It is just used for warning about unecessary source imports.
-    let mg2_with_srcimps :: [SCC ModuleGraphNode]
-        mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
-
-    -- If we can determine that any of the {-# SOURCE #-} imports
-    -- are definitely unnecessary, then emit a warning.
-    warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps)
-
-    let maybe_top_mod = case how_much of
-                          LoadUpTo m           -> Just m
-                          LoadDependenciesOf m -> Just m
-                          _                    -> Nothing
-
-        build_plan = createBuildPlan mod_graph maybe_top_mod
-
-
-    cache <- liftIO $ maybe (return []) iface_clearCache mhmi_cache
-    let
-        -- prune the HPT so everything is not retained when doing an
-        -- upsweep.
-        !pruned_cache = pruneCache cache
-                            (flattenSCCs (filterToposortToModules  mg2_with_srcimps))
-
-
-    -- before we unload anything, make sure we don't leave an old
-    -- interactive context around pointing to dead bindings.  Also,
-    -- write an empty HPT to allow the old HPT to be GC'd.
-
-    let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable }
-    setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env
-
-    -- Unload everything
-    liftIO $ unload interp hsc_env
-
-    liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep")
-                                    2 (ppr build_plan))
-
-    n_jobs <- case parMakeCount (hsc_dflags hsc_env) of
-                    Nothing -> liftIO getNumProcessors
-                    Just n  -> return n
-
-    setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env
-    (upsweep_ok, hsc_env1) <- withDeferredDiagnostics $ do
-      hsc_env <- getSession
-      liftIO $ upsweep n_jobs hsc_env mhmi_cache mHscMessage (toCache pruned_cache) build_plan
-    setSession hsc_env1
-    case upsweep_ok of
-      Failed -> loadFinish upsweep_ok
-      Succeeded -> do
-          liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")
-          -- Clean up after ourselves
-          liftIO $ cleanCurrentModuleTempFilesMaybe logger (hsc_tmpfs hsc_env1) dflags
-          loadFinish upsweep_ok
-
-
-
--- | Finish up after a load.
-loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag
--- Empty the interactive context and set the module context to the topmost
--- newly loaded module, or the Prelude if none were loaded.
-loadFinish all_ok
-  = do modifySession discardIC
-       return all_ok
-
-
--- | If there is no -o option, guess the name of target executable
--- by using top-level source file name as a base.
-guessOutputFile :: GhcMonad m => m ()
-guessOutputFile = modifySession $ \env ->
-    -- Force mod_graph to avoid leaking env
-    let !mod_graph = hsc_mod_graph env
-        new_home_graph =
-          flip unitEnv_map (hsc_HUG env) $ \hue ->
-            let dflags = homeUnitEnv_dflags hue
-                platform = targetPlatform dflags
-                mainModuleSrcPath :: Maybe String
-                mainModuleSrcPath = do
-                  ms <- mgLookupModule mod_graph (mainModIs hue)
-                  ml_hs_file (ms_location ms)
-                name = fmap dropExtension mainModuleSrcPath
-
-                -- MP: This exception is quite sensitive to being forced, if you
-                -- force it here then the error message is different because it gets
-                -- caught by a different error handler than the test (T9930fail) expects.
-                -- Putting an exception into DynFlags is probably not a great design but
-                -- I'll write this comment rather than more eagerly force the exception.
-                name_exe = do
-                  -- we must add the .exe extension unconditionally here, otherwise
-                  -- when name has an extension of its own, the .exe extension will
-                 -- not be added by GHC.Driver.Pipeline.exeFileName.  See #2248
-                 !name' <- if platformOS platform == OSMinGW32
-                           then fmap (<.> "exe") name
-                           else name
-                 mainModuleSrcPath' <- mainModuleSrcPath
-                 -- #9930: don't clobber input files (unless they ask for it)
-                 if name' == mainModuleSrcPath'
-                   then throwGhcException . UsageError $
-                        "default output name would overwrite the input file; " ++
-                        "must specify -o explicitly"
-                   else Just name'
-            in
-              case outputFile_ dflags of
-                Just _ -> hue
-                Nothing -> hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } }
-    in env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } }
-
--- -----------------------------------------------------------------------------
---
--- | Prune the HomePackageTable
---
--- Before doing an upsweep, we can throw away:
---
---   - all ModDetails, all linked code
---   - all unlinked code that is out of date with respect to
---     the source file
---
--- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
--- space at the end of the upsweep, because the topmost ModDetails of the
--- old HPT holds on to the entire type environment from the previous
--- compilation.
--- Note [GHC Heap Invariants]
-pruneCache :: [CachedIface]
-                      -> [ModSummary]
-                      -> [HomeModInfo]
-pruneCache hpt summ
-  = strictMap prune hpt
-  where prune (CachedIface { cached_modiface = iface
-                           , cached_linkable = linkable
-                           }) = HomeModInfo iface emptyModDetails linkable'
-          where
-           modl = moduleName (mi_module iface)
-           linkable'
-                | Just ms <- lookupUFM ms_map modl
-                , mi_src_hash iface /= ms_hs_hash ms
-                = emptyHomeModInfoLinkable
-                | otherwise
-                = linkable
-
-        ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
-
--- ---------------------------------------------------------------------------
---
--- | Unloading
-unload :: Interp -> HscEnv -> IO ()
-unload interp hsc_env
-  = case ghcLink (hsc_dflags hsc_env) of
-        LinkInMemory -> Linker.unload interp hsc_env []
-        _other -> return ()
-
-
-{- Parallel Upsweep
-
-The parallel upsweep attempts to concurrently compile the modules in the
-compilation graph using multiple Haskell threads.
-
-The Algorithm
-
-* The list of `MakeAction`s are created by `interpretBuildPlan`. A `MakeAction` is
-a pair of an `IO a` action and a `MVar a`, where to place the result.
-  The list is sorted topologically, so can be executed in order without fear of
-  blocking.
-* runPipelines takes this list and eventually passes it to runLoop which executes
-  each action and places the result into the right MVar.
-* The amount of parallelism is controlled by a semaphore. This is just used around the
-  module compilation step, so that only the right number of modules are compiled at
-  the same time which reduces overall memory usage and allocations.
-* Each proper node has a LogQueue, which dictates where to send it's output.
-* The LogQueue is placed into the LogQueueQueue when the action starts and a worker
-  thread processes the LogQueueQueue printing logs for each module in a stable order.
-* The result variable for an action producing `a` is of type `Maybe a`, therefore
-  it is still filled on a failure. If a module fails to compile, the
-  failure is propagated through the whole module graph and any modules which didn't
-  depend on the failure can still be compiled. This behaviour also makes the code
-  quite a bit cleaner.
--}
-
-
-{-
-
-Note [--make mode]
-~~~~~~~~~~~~~~~~~
-There are two main parts to `--make` mode.
-
-1. `downsweep`: Starts from the top of the module graph and computes dependencies.
-2. `upsweep`: Starts from the bottom of the module graph and compiles modules.
-
-The result of the downsweep is a 'ModuleGraph', which is then passed to 'upsweep' which
-computers how to build this ModuleGraph.
-
-Note [Upsweep]
-~~~~~~~~~~~~~~
-Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes
-the plan in order to compile the project.
-
-The first step is computing the build plan from a 'ModuleGraph'.
-
-The output of this step is a `[BuildPlan]`, which is a topologically sorted plan for
-how to build all the modules.
-
-```
-data BuildPlan = SingleModule ModuleGraphNode  -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle
-               | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBoot]   -- A resolved cycle, linearised by hs-boot files
-               | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files
-```
-
-The plan is computed in two steps:
-
-Step 1:  Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains
-         cycles.
-Step 2:  For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should
-         result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle.
-Step 2a: For each module in the cycle, if the module has a boot file then compute the
-         modules on the path between it and the hs-boot file.
-         These are the intermediate modules which:
-            (1) are (transitive) dependencies of the non-boot module, and
-            (2) have the boot module as a (transitive) dependency.
-         In particular, all such intermediate modules must appear in the same unit as
-         the module under consideration, as module cycles cannot cross unit boundaries.
-         This information is stored in ModuleGraphNodeWithBoot.
-
-The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function.
-
-* SingleModule nodes are compiled normally by either the upsweep_inst or upsweep_mod functions.
-* ResolvedCycles need to compiled "together" so that modules outside the cycle are presented
-  with a consistent knot-tied version of modules at the end.
-    - When the ModuleGraphNodeWithBoot nodes are compiled then suitable rehydration
-      is performed both before and after the module in question is compiled.
-      See Note [Hydrating Modules] for more information.
-* UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files
-  and are reported as an error to the user.
-
-The main trickiness of `interpretBuildPlan` is deciding which version of a dependency
-is visible from each module. For modules which are not in a cycle, there is just
-one version of a module, so that is always used. For modules in a cycle, there are two versions of
-'HomeModInfo'.
-
-1. Internal to loop: The version created whilst compiling the loop by upsweep_mod.
-2. External to loop: The knot-tied version created by typecheckLoop.
-
-Whilst compiling a module inside the loop, we need to use the (1). For a module which
-is outside of the loop which depends on something from in the loop, the (2) version
-is used.
-
-As the plan is interpreted, which version of a HomeModInfo is visible is updated
-by updating a map held in a state monad. So after a loop has finished being compiled,
-the visible module is the one created by typecheckLoop and the internal version is not
-used again.
-
-This plan also ensures the most important invariant to do with module loops:
-
-> If you depend on anything within a module loop, before you can use the dependency,
-  the whole loop has to finish compiling.
-
-The end result of `interpretBuildPlan` is a `[MakeAction]`, which are pairs
-of `IO a` actions and a `MVar (Maybe a)`, somewhere to put the result of running
-the action. This list is topologically sorted, so can be run in order to compute
-the whole graph.
-
-As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which
-can be queried at the end to get the result of all modules at the end, with their proper
-visibility. For example, if any module in a loop fails then all modules in that loop will
-report as failed because the visible node at the end will be the result of checking
-these modules together.
-
--}
-
--- | Simple wrapper around MVar which allows a functor instance.
-data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a))
-
-deriving instance Functor ResultVar
-
-mkResultVar :: MVar (Maybe a) -> ResultVar a
-mkResultVar = ResultVar id
-
--- | Block until the result is ready.
-waitResult :: ResultVar a -> MaybeT IO a
-waitResult (ResultVar f var) = MaybeT (fmap f <$> readMVar var)
-
-data BuildResult = BuildResult { _resultOrigin :: ResultOrigin
-                               , resultVar    :: ResultVar (Maybe HomeModInfo, ModuleNameSet)
-                               }
-
--- The origin of this result var, useful for debugging
-data ResultOrigin = NoLoop | Loop ResultLoopOrigin deriving (Show)
-
-data ResultLoopOrigin = Initialise | Rehydrated | Finalised deriving (Show)
-
-mkBuildResult :: ResultOrigin -> ResultVar (Maybe HomeModInfo, ModuleNameSet) -> BuildResult
-mkBuildResult = BuildResult
-
-
-data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey BuildResult
-                                          -- The current way to build a specific TNodeKey, without cycles this just points to
-                                          -- the appropriate result of compiling a module  but with
-                                          -- cycles there can be additional indirection and can point to the result of typechecking a loop
-                                     , nNODE :: Int
-                                     , hug_var :: MVar HomeUnitGraph
-                                     -- A global variable which is incrementally updated with the result
-                                     -- of compiling modules.
-                                     }
-
-nodeId :: BuildM Int
-nodeId = do
-  n <- gets nNODE
-  modify (\m -> m { nNODE = n + 1 })
-  return n
-
-
-setModulePipeline :: NodeKey -> BuildResult -> BuildM ()
-setModulePipeline mgn build_result = do
-  modify (\m -> m { buildDep = M.insert mgn build_result (buildDep m) })
-
-type BuildMap = M.Map NodeKey BuildResult
-
-getBuildMap :: BuildM BuildMap
-getBuildMap = gets buildDep
-
-getDependencies :: [NodeKey] -> BuildMap -> [BuildResult]
-getDependencies direct_deps build_map =
-  strictMap (expectJust "dep_map" . flip M.lookup build_map) direct_deps
-
-type BuildM a = StateT BuildLoopState IO a
-
-
--- | Abstraction over the operations of a semaphore which allows usage with the
---  -j1 case
-data AbstractSem = AbstractSem { acquireSem :: IO ()
-                               , releaseSem :: IO () }
-
-withAbstractSem :: AbstractSem -> IO b -> IO b
-withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)
-
--- | Environment used when compiling a module
-data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module
-                       , compile_sem :: !AbstractSem
-                       -- Modify the environment for module k, with the supplied logger modification function.
-                       -- For -j1, this wrapper doesn't do anything
-                       -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output
-                       --          into the log queue.
-                       , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a
-                       , env_messager :: !(Maybe Messager)
-                       }
-
-type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a
-
--- | Given the build plan, creates a graph which indicates where each NodeKey should
--- get its direct dependencies from. This might not be the corresponding build action
--- if the module participates in a loop. This step also labels each node with a number for the output.
--- See Note [Upsweep] for a high-level description.
-interpretBuildPlan :: HomeUnitGraph
-                   -> Maybe ModIfaceCache
-                   -> M.Map ModNodeKeyWithUid HomeModInfo
-                   -> [BuildPlan]
-                   -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle
-                         , [MakeAction] -- Actions we need to run in order to build everything
-                         , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end.
-interpretBuildPlan hug mhmi_cache old_hpt plan = do
-  hug_var <- newMVar hug
-  ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hug_var)
-  let wait = collect_results (buildDep build_map)
-  return (mcycle, plans, wait)
-
-  where
-    collect_results build_map =
-      sequence (map (\br -> collect_result (fst <$> resultVar br)) (M.elems build_map))
-      where
-        collect_result res_var = runMaybeT (waitResult res_var)
-
-    n_mods = sum (map countMods plan)
-
-    buildLoop :: [BuildPlan]
-              -> BuildM (Maybe [ModuleGraphNode], [MakeAction])
-    -- Build the abstract pipeline which we can execute
-    -- Building finished
-    buildLoop []           = return (Nothing, [])
-    buildLoop (plan:plans) =
-      case plan of
-        -- If there was no cycle, then typecheckLoop is not necessary
-        SingleModule m -> do
-          one_plan <- buildSingleModule Nothing NoLoop m
-          (cycle, all_plans) <- buildLoop plans
-          return (cycle, one_plan : all_plans)
-
-        -- For a resolved cycle, depend on everything in the loop, then update
-        -- the cache to point to this node rather than directly to the module build
-        -- nodes
-        ResolvedCycle ms -> do
-          pipes <- buildModuleLoop ms
-          (cycle, graph) <- buildLoop plans
-          return (cycle, pipes ++ graph)
-
-        -- Can't continue past this point as the cycle is unresolved.
-        UnresolvedCycle ns -> return (Just ns, [])
-
-    buildSingleModule :: Maybe [NodeKey]  -- Modules we need to rehydrate before compiling this module
-                      -> ResultOrigin
-                      -> ModuleGraphNode          -- The node we are compiling
-                      -> BuildM MakeAction
-    buildSingleModule rehydrate_nodes origin mod = do
-      mod_idx <- nodeId
-      !build_map <- getBuildMap
-      hug_var <- gets hug_var
-      -- 1. Get the direct dependencies of this module
-      let direct_deps = nodeDependencies False mod
-          -- It's really important to force build_deps, or the whole buildMap is retained,
-          -- which would retain all the result variables, preventing us from collecting them
-          -- after they are no longer used.
-          !build_deps = getDependencies direct_deps build_map
-      let build_action =
-            withCurrentUnit (moduleGraphNodeUnitId mod) $ do
-            (hug, deps) <- wait_deps_hug hug_var build_deps
-            case mod of
-              InstantiationNode uid iu -> do
-                executeInstantiationNode mod_idx n_mods hug uid iu
-                return (Nothing, deps)
-              ModuleNode _build_deps ms -> do
-                let !old_hmi = M.lookup (msKey ms) old_hpt
-                    rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes
-                hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms
-                -- Write the HMI to an external cache (if one exists)
-                -- See Note [Caching HomeModInfo]
-                liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi
-                -- This global MVar is incrementally modified in order to avoid having to
-                -- recreate the HPT before compiling each module which leads to a quadratic amount of work.
-                liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi)
-                return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps )
-              LinkNode _nks uid -> do
-                  executeLinkNode hug (mod_idx, n_mods) uid direct_deps
-                  return (Nothing, deps)
-
-
-      res_var <- liftIO newEmptyMVar
-      let result_var = mkResultVar res_var
-      setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var)
-      return $ (MakeAction build_action res_var)
-
-
-    buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction]
-    buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) = do
-      ma <- buildSingleModule (Just deps) (Loop Initialise) mn
-      -- Rehydration (1) from Note [Hydrating Modules], "Loops with multiple boot files"
-      rehydrate_action <- rehydrateAction Rehydrated ((GWIB (mkNodeKey mn) IsBoot) : (map (\d -> GWIB d NotBoot) deps))
-      return $ [ma, rehydrate_action]
-
-
-    buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildM [MakeAction]
-    buildModuleLoop ms = do
-      build_modules <- concatMapM (either (fmap (:[]) <$> buildSingleModule Nothing (Loop Initialise)) buildOneLoopyModule) ms
-      let extract (Left mn) = GWIB (mkNodeKey mn) NotBoot
-          extract (Right (ModuleGraphNodeWithBootFile mn _)) = GWIB (mkNodeKey mn) IsBoot
-      let loop_mods = map extract ms
-      -- Rehydration (2) from Note [Hydrating Modules], "Loops with multiple boot files"
-      -- Fixes the space leak described in that note.
-      rehydrate_action <- rehydrateAction Finalised loop_mods
-
-      return $ build_modules ++ [rehydrate_action]
-
-    -- An action which rehydrates the given keys
-    rehydrateAction :: ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction
-    rehydrateAction origin deps = do
-      hug_var <- gets hug_var
-      !build_map <- getBuildMap
-      res_var <- liftIO newEmptyMVar
-      let
-          !build_deps = getDependencies (map gwib_mod deps) build_map
-      let loop_action = do
-            (hug, tdeps) <- wait_deps_hug hug_var build_deps
-            hsc_env <- asks hsc_env
-            let new_hsc = setHUG hug hsc_env
-                mns :: [ModuleName]
-                mns = mapMaybe (nodeKeyModName . gwib_mod) deps
-
-            hmis' <- liftIO $ rehydrateAfter new_hsc mns
-
-            checkRehydrationInvariant hmis' deps
-
-            -- Add hydrated interfaces to global variable
-            liftIO $ modifyMVar_ hug_var (\hug -> return $ foldr addHomeModInfoToHug hug hmis')
-            return (hmis', tdeps)
-
-      let fanout i = first (Just . (!! i)) <$> mkResultVar res_var
-      -- From outside the module loop, anyone must wait for the loop to finish and then
-      -- use the result of the rehydrated iface. This makes sure that things not in the
-      -- module loop will see the updated interfaces for all the identifiers in the loop.
-          boot_key :: NodeKey -> NodeKey
-          boot_key (NodeKey_Module m) = NodeKey_Module (m { mnkModuleName = (mnkModuleName m) { gwib_isBoot = IsBoot } } )
-          boot_key k = pprPanic "boot_key" (ppr k)
-
-          update_module_pipeline (m, i) =
-            case gwib_isBoot m of
-              NotBoot -> setModulePipeline (gwib_mod m) (mkBuildResult (Loop origin) (fanout i))
-              IsBoot -> do
-                setModulePipeline (gwib_mod m) (mkBuildResult (Loop origin) (fanout i))
-                -- SPECIAL: Anything outside the loop needs to see A rather than A.hs-boot
-                setModulePipeline (boot_key (gwib_mod m)) (mkBuildResult (Loop origin) (fanout i))
-
-      let deps_i = zip deps [0..]
-      mapM update_module_pipeline deps_i
-
-      return $ MakeAction loop_action res_var
-
-      -- Checks that the interfaces returned from hydration match-up with the names of the
-      -- modules which were fed into the function.
-    checkRehydrationInvariant hmis deps =
-        let hmi_names = map (moduleName . mi_module . hm_iface) hmis
-            start = mapMaybe (nodeKeyModName . gwib_mod) deps
-        in massertPpr (hmi_names == start) $ (ppr hmi_names $$ ppr start)
-
-
-withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a
-withCurrentUnit uid = do
-  local (\env -> env { hsc_env = hscSetActiveUnitId uid (hsc_env env)})
-
-upsweep
-    :: Int -- ^ The number of workers we wish to run in parallel
-    -> HscEnv -- ^ The base HscEnv, which is augmented for each module
-    -> Maybe ModIfaceCache -- ^ A cache to incrementally write final interface files to
-    -> Maybe Messager
-    -> M.Map ModNodeKeyWithUid HomeModInfo
-    -> [BuildPlan]
-    -> IO (SuccessFlag, HscEnv)
-upsweep n_jobs hsc_env hmi_cache mHscMessage old_hpt build_plan = do
-    (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan
-    runPipelines n_jobs hsc_env mHscMessage pipelines
-    res <- collect_result
-
-    let completed = [m | Just (Just m) <- res]
-    let hsc_env' = addDepsToHscEnv completed hsc_env
-
-    -- Handle any cycle in the original compilation graph and return the result
-    -- of the upsweep.
-    case cycle of
-        Just mss -> do
-          let logger = hsc_logger hsc_env
-          liftIO $ fatalErrorMsg logger (cyclicModuleErr mss)
-          return (Failed, hsc_env)
-        Nothing  -> do
-          let success_flag = successIf (all isJust res)
-          return (success_flag, hsc_env')
-
-toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo
-toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis])
-
-miKey :: ModIface -> ModNodeKeyWithUid
-miKey hmi = ModNodeKeyWithUid (mi_mnwib hmi) ((toUnitId $ moduleUnit (mi_module hmi)))
-
-upsweep_inst :: HscEnv
-             -> Maybe Messager
-             -> Int  -- index of module
-             -> Int  -- total number of modules
-             -> UnitId
-             -> InstantiatedUnit
-             -> IO ()
-upsweep_inst hsc_env mHscMessage mod_index nmods uid iuid = do
-        case mHscMessage of
-            Just hscMessage -> hscMessage hsc_env (mod_index, nmods) (NeedsRecompile MustCompile) (InstantiationNode uid iuid)
-            Nothing -> return ()
-        runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid
-        pure ()
-
--- | Compile a single module.  Always produce a Linkable for it if
--- successful.  If no compilation happened, return the old Linkable.
-upsweep_mod :: HscEnv
-            -> Maybe Messager
-            -> Maybe HomeModInfo
-            -> ModSummary
-            -> Int  -- index of module
-            -> Int  -- total number of modules
-            -> IO HomeModInfo
-upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods =  do
-  hmi <- compileOne' mHscMessage hsc_env summary
-          mod_index nmods (hm_iface <$> old_hmi) (maybe emptyHomeModInfoLinkable hm_linkable old_hmi)
-
-  -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module
-  -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I
-  -- am unsure if this is sound (wrt running TH splices for example).
-  -- This function only does anything if the linkable produced is a BCO, which only happens with the
-  -- bytecode backend, no need to guard against the backend type additionally.
-  addSptEntries (hscUpdateHPT (\hpt -> addToHpt hpt (ms_mod_name summary) hmi) hsc_env)
-                (homeModInfoByteCode hmi)
-
-  return hmi
-
--- | Add the entries from a BCO linkable to the SPT table, see
--- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
-addSptEntries :: HscEnv -> Maybe Linkable -> IO ()
-addSptEntries hsc_env mlinkable =
-  hscAddSptEntries hsc_env
-     [ spt
-     | Just linkable <- [mlinkable]
-     , unlinked <- linkableUnlinked linkable
-     , BCOs _ spts <- pure unlinked
-     , spt <- spts
-     ]
-
-{- Note [-fno-code mode]
-~~~~~~~~~~~~~~~~~~~~~~~~
-GHC offers the flag -fno-code for the purpose of parsing and typechecking a
-program without generating object files. This is intended to be used by tooling
-and IDEs to provide quick feedback on any parser or type errors as cheaply as
-possible.
-
-When GHC is invoked with -fno-code no object files or linked output will be
-generated. As many errors and warnings as possible will be generated, as if
--fno-code had not been passed. The session DynFlags will have
-backend == NoBackend.
-
--fwrite-interface
-~~~~~~~~~~~~~~~~
-Whether interface files are generated in -fno-code mode is controlled by the
--fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
-not also passed. Recompilation avoidance requires interface files, so passing
--fno-code without -fwrite-interface should be avoided. If -fno-code were
-re-implemented today, -fwrite-interface would be discarded and it would be
-considered always on; this behaviour is as it is for backwards compatibility.
-
-================================================================
-IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
-================================================================
-
-Template Haskell
-~~~~~~~~~~~~~~~~
-A module using template haskell may invoke an imported function from inside a
-splice. This will cause the type-checker to attempt to execute that code, which
-would fail if no object files had been generated. See #8025. To rectify this,
-during the downsweep we patch the DynFlags in the ModSummary of any home module
-that is imported by a module that uses template haskell, to generate object
-code.
-
-The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled
-or not in the module which needs the code generation. If the module requires byte-code then
-dependencies will generate byte-code, otherwise they will generate object files.
-In the case where some modules require byte-code and some object files, both are
-generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these
-configurations.
-
-The object files (and interface files if -fwrite-interface is disabled) produced
-for template haskell are written to temporary files.
-
-Note that since template haskell can run arbitrary IO actions, -fno-code mode
-is no more secure than running without it.
-
-Potential TODOS:
-~~~~~
-* Remove -fwrite-interface and have interface files always written in -fno-code
-  mode
-* Both .o and .dyn_o files are generated for template haskell, but we only need
-  .dyn_o. Fix it.
-* In make mode, a message like
-  Compiling A (A.hs, /tmp/ghc_123.o)
-  is shown if downsweep enabled object code generation for A. Perhaps we should
-  show "nothing" or "temporary object file" instead. Note that one
-  can currently use -keep-tmp-files and inspect the generated file with the
-  current behaviour.
-* Offer a -no-codedir command line option, and write what were temporary
-  object files there. This would speed up recompilation.
-* Use existing object files (if they are up to date) instead of always
-  generating temporary ones.
--}
-
--- Note [When source is considered modified]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- A number of functions in GHC.Driver accept a SourceModified argument, which
--- is part of how GHC determines whether recompilation may be avoided (see the
--- definition of the SourceModified data type for details).
---
--- Determining whether or not a source file is considered modified depends not
--- only on the source file itself, but also on the output files which compiling
--- that module would produce. This is done because GHC supports a number of
--- flags which control which output files should be produced, e.g. -fno-code
--- -fwrite-interface and -fwrite-ide-file; we must check not only whether the
--- source file has been modified since the last compile, but also whether the
--- source file has been modified since the last compile which produced all of
--- the output files which have been requested.
---
--- Specifically, a source file is considered unmodified if it is up-to-date
--- relative to all of the output files which have been requested. Whether or
--- not an output file is up-to-date depends on what kind of file it is:
---
--- * iface (.hi) files are considered up-to-date if (and only if) their
---   mi_src_hash field matches the hash of the source file,
---
--- * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date
---   if (and only if) their modification times on the filesystem are greater
---   than or equal to the modification time of the corresponding .hi file.
---
--- Why do we use '>=' rather than '>' for output files other than the .hi file?
--- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a
--- resolution of 2 seconds), we may often find that the .hi and .o files have
--- the same modification time. Using >= is slightly unsafe, but it matches
--- make's behaviour.
---
--- This strategy allows us to do the minimum work necessary in order to ensure
--- that all the files the user cares about are up-to-date; e.g. we should not
--- worry about .o files if the user has indicated that they are not interested
--- in them via -fno-code. See also #9243.
---
--- Note that recompilation avoidance is dependent on .hi files being produced,
--- which does not happen if -fno-write-interface -fno-code is passed. That is,
--- passing -fno-write-interface -fno-code means that you cannot benefit from
--- recompilation avoidance. See also Note [-fno-code mode].
---
--- The correctness of this strategy depends on an assumption that whenever we
--- are producing multiple output files, the .hi file is always written first.
--- If this assumption is violated, we risk recompiling unnecessarily by
--- incorrectly regarding non-.hi files as outdated.
---
-
--- ---------------------------------------------------------------------------
---
--- | Topological sort of the module graph
-topSortModuleGraph
-          :: Bool
-          -- ^ Drop hi-boot nodes? (see below)
-          -> ModuleGraph
-          -> Maybe HomeUnitModule
-             -- ^ Root module name.  If @Nothing@, use the full graph.
-          -> [SCC ModuleGraphNode]
--- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
--- The resulting list of strongly-connected-components is in topologically
--- sorted order, starting with the module(s) at the bottom of the
--- dependency graph (ie compile them first) and ending with the ones at
--- the top.
---
--- Drop hi-boot nodes (first boolean arg)?
---
--- - @False@:   treat the hi-boot summaries as nodes of the graph,
---              so the graph must be acyclic
---
--- - @True@:    eliminate the hi-boot nodes, and instead pretend
---              the a source-import of Foo is an import of Foo
---              The resulting graph has no hi-boot nodes, but can be cyclic
-topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod =
-    -- stronglyConnCompG flips the original order, so if we reverse
-    -- the summaries we get a stable topological sort.
-  topSortModules drop_hs_boot_nodes (reverse $ mgModSummaries' module_graph) mb_root_mod
-
-topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
-topSortModules drop_hs_boot_nodes summaries mb_root_mod
-  = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
-  where
-    (graph, lookup_node) =
-      moduleGraphNodes drop_hs_boot_nodes summaries
-
-    initial_graph = case mb_root_mod of
-        Nothing -> graph
-        Just (Module uid root_mod) ->
-            -- restrict the graph to just those modules reachable from
-            -- the specified module.  We do this by building a graph with
-            -- the full set of nodes, and determining the reachable set from
-            -- the specified node.
-            let root | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid
-                     , graph `hasVertexG` node
-                     = node
-                     | otherwise
-                     = throwGhcException (ProgramError "module does not exist")
-            in graphFromEdgedVerticesUniq (seq root (reachableG graph root))
-
-newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }
-  deriving (Functor, Traversable, Foldable)
-
-emptyModNodeMap :: ModNodeMap a
-emptyModNodeMap = ModNodeMap Map.empty
-
-modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a
-modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m)
-
-modNodeMapElems :: ModNodeMap a -> [a]
-modNodeMapElems (ModNodeMap m) = Map.elems m
-
-modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a
-modNodeMapLookup k (ModNodeMap m) = Map.lookup k m
-
-modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a
-modNodeMapSingleton k v = ModNodeMap (M.singleton k v)
-
-modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a
-modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f m n)
-
--- | If there are {-# SOURCE #-} imports between strongly connected
--- components in the topological sort, then those imports can
--- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
--- were necessary, then the edge would be part of a cycle.
-warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
-warnUnnecessarySourceImports sccs = do
-  diag_opts <- initDiagOpts <$> getDynFlags
-  when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do
-    let check ms =
-           let mods_in_this_cycle = map ms_mod_name ms in
-           [ warn i | m <- ms, i <- ms_home_srcimps m,
-                      unLoc i `notElem`  mods_in_this_cycle ]
-
-        warn :: Located ModuleName -> MsgEnvelope GhcMessage
-        warn (L loc mod) = GhcDriverMessage <$> mkPlainMsgEnvelope diag_opts
-                                                  loc (DriverUnnecessarySourceImports mod)
-    logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs))
-
-
--- This caches the answer to the question, if we are in this unit, what does
--- an import of this module mean.
-type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary]
-
------------------------------------------------------------------------------
---
--- | Downsweep (dependency analysis)
---
--- Chase downwards from the specified root set, returning summaries
--- for all home modules encountered.  Only follow source-import
--- links.
---
--- We pass in the previous collection of summaries, which is used as a
--- cache to avoid recalculating a module summary if the source is
--- unchanged.
---
--- The returned list of [ModSummary] nodes has one node for each home-package
--- module, plus one for any hs-boot files.  The imports of these nodes
--- are all there, including the imports of non-home-package modules.
-downsweep :: HscEnv
-          -> [ModSummary]
-          -- ^ Old summaries
-          -> [ModuleName]       -- Ignore dependencies on these; treat
-                                -- them as if they were package modules
-          -> Bool               -- True <=> allow multiple targets to have
-                                --          the same module name; this is
-                                --          very useful for ghc -M
-          -> IO ([DriverMessages], [ModuleGraphNode])
-                -- The non-error elements of the returned list all have distinct
-                -- (Modules, IsBoot) identifiers, unless the Bool is true in
-                -- which case there can be repeats
-downsweep hsc_env old_summaries excl_mods allow_dup_roots
-   = do
-       rootSummaries <- mapM getRootSummary roots
-       let (root_errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549
-           root_map = mkRootMap rootSummariesOk
-       checkDuplicates root_map
-       (deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map)
-       let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps)
-       let unit_env = hsc_unit_env hsc_env
-       let tmpfs    = hsc_tmpfs    hsc_env
-
-       let downsweep_errs = lefts $ concat $ M.elems map0
-           downsweep_nodes = M.elems deps
-
-           (other_errs, unit_nodes) = partitionEithers $ unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)
-           all_nodes = downsweep_nodes ++ unit_nodes
-           all_errs  = all_root_errs ++  downsweep_errs ++ other_errs
-           all_root_errs =  closure_errs ++ map snd root_errs
-
-       -- if we have been passed -fno-code, we enable code generation
-       -- for dependencies of modules that have -XTemplateHaskell,
-       -- otherwise those modules will fail to compile.
-       -- See Note [-fno-code mode] #8025
-       th_enabled_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes
-       if null all_root_errs
-         then return (all_errs, th_enabled_nodes)
-         else pure $ (all_root_errs, [])
-     where
-        -- Dependencies arising on a unit (backpack and module linking deps)
-        unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]
-        unitModuleNodes summaries uid hue =
-          let instantiation_nodes = instantiationNodes uid (homeUnitEnv_units hue)
-          in map Right instantiation_nodes
-              ++ maybeToList (linkNodes (instantiation_nodes ++ summaries) uid hue)
-
-        calcDeps ms =
-          -- Add a dependency on the HsBoot file if it exists
-          -- This gets passed to the loopImports function which just ignores it if it
-          -- can't be found.
-          [(ms_unitid ms, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++
-          [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ]
-
-        logger = hsc_logger hsc_env
-        roots  = hsc_targets hsc_env
-
-        -- A cache from file paths to the already summarised modules.
-        -- Reuse these if we can because the most expensive part of downsweep is
-        -- reading the headers.
-        old_summary_map :: M.Map FilePath ModSummary
-        old_summary_map = M.fromList [(msHsFilePath ms, ms) | ms <- old_summaries]
-
-        getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)
-        getRootSummary Target { targetId = TargetFile file mb_phase
-                              , targetContents = maybe_buf
-                              , targetUnitId = uid
-                              }
-           = do let offset_file = augmentByWorkingDirectory dflags file
-                exists <- liftIO $ doesFileExist offset_file
-                if exists || isJust maybe_buf
-                    then first (uid,) <$>
-                        summariseFile hsc_env home_unit old_summary_map offset_file mb_phase
-                                       maybe_buf
-                    else return $ Left $ (uid,) $ singleMessage
-                                $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)
-            where
-              dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))
-              home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)
-        getRootSummary Target { targetId = TargetModule modl
-                              , targetContents = maybe_buf
-                              , targetUnitId = uid
-                              }
-           = do maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot
-                                           (L rootLoc modl) (ThisPkg (homeUnitId home_unit))
-                                           maybe_buf excl_mods
-                case maybe_summary of
-                   FoundHome s  -> return (Right s)
-                   FoundHomeWithError err -> return (Left err)
-                   _ -> return $ Left $ (uid, moduleNotFoundErr modl)
-            where
-              home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)
-        rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
-
-        -- In a root module, the filename is allowed to diverge from the module
-        -- name, so we have to check that there aren't multiple root files
-        -- defining the same module (otherwise the duplicates will be silently
-        -- ignored, leading to confusing behaviour).
-        checkDuplicates
-          :: DownsweepCache
-          -> IO ()
-        checkDuplicates root_map
-           | allow_dup_roots = return ()
-           | null dup_roots  = return ()
-           | otherwise       = liftIO $ multiRootsErr (head dup_roots)
-           where
-             dup_roots :: [[ModSummary]]        -- Each at least of length 2
-             dup_roots = filterOut isSingleton $ map rights (M.elems root_map)
-
-        -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit
-        loopSummaries :: [ModSummary]
-              -> (M.Map NodeKey ModuleGraphNode, Set.Set (UnitId, UnitId),
-                    DownsweepCache)
-              -> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache)
-        loopSummaries [] done = return done
-        loopSummaries (ms:next) (done, pkgs, summarised)
-          | Just {} <- M.lookup k done
-          = loopSummaries next (done, pkgs, summarised)
-          -- Didn't work out what the imports mean yet, now do that.
-          | otherwise = do
-             (final_deps, pkgs1, done', summarised') <- loopImports (calcDeps ms) done summarised
-             -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.
-             (_, _, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'
-             loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', pkgs1 `Set.union` pkgs, summarised'')
-          where
-            k = NodeKey_Module (msKey ms)
-
-            hs_file_for_boot
-              | HsBootFile <- ms_hsc_src ms = Just $ ((ms_unitid ms), NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))
-              | otherwise = Nothing
-
-
-        -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover
-        -- a new module by doing this.
-        loopImports :: [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]
-                        -- Work list: process these modules
-             -> M.Map NodeKey ModuleGraphNode
-             -> DownsweepCache
-                        -- Visited set; the range is a list because
-                        -- the roots can have the same module names
-                        -- if allow_dup_roots is True
-             -> IO ([NodeKey], Set.Set (UnitId, UnitId),
-
-                  M.Map NodeKey ModuleGraphNode, DownsweepCache)
-                        -- The result is the completed NodeMap
-        loopImports [] done summarised = return ([], Set.empty, done, summarised)
-        loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised
-          | Just summs <- M.lookup cache_key summarised
-          = case summs of
-              [Right ms] -> do
-                let nk = NodeKey_Module (msKey ms)
-                (rest, pkgs, summarised', done') <- loopImports ss done summarised
-                return (nk: rest, pkgs, summarised', done')
-              [Left _err] ->
-                loopImports ss done summarised
-              _errs ->  do
-                loopImports ss done summarised
-          | otherwise
-          = do
-               mb_s <- summariseModule hsc_env home_unit old_summary_map
-                                       is_boot wanted_mod mb_pkg
-                                       Nothing excl_mods
-               case mb_s of
-                   NotThere -> loopImports ss done summarised
-                   External uid -> do
-                    (other_deps, pkgs, done', summarised') <- loopImports ss done summarised
-                    return (other_deps, Set.insert (homeUnitId home_unit, uid) pkgs, done', summarised')
-                   FoundInstantiation iud -> do
-                    (other_deps, pkgs, done', summarised') <- loopImports ss done summarised
-                    return (NodeKey_Unit iud : other_deps, pkgs, done', summarised')
-                   FoundHomeWithError (_uid, e) ->  loopImports ss done (Map.insert cache_key [(Left e)] summarised)
-                   FoundHome s -> do
-                     (done', pkgs1, summarised') <-
-                       loopSummaries [s] (done, Set.empty, Map.insert cache_key [Right s] summarised)
-                     (other_deps, pkgs2, final_done, final_summarised) <- loopImports ss done' summarised'
-
-                     -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.
-                     return (NodeKey_Module (msKey s) : other_deps, pkgs1 `Set.union` pkgs2, final_done, final_summarised)
-          where
-            cache_key = (home_uid, mb_pkg, unLoc <$> gwib)
-            home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
-            GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
-            wanted_mod = L loc mod
-
--- This function checks then important property that if both p and q are home units
--- then any dependency of p, which transitively depends on q is also a home unit.
-checkHomeUnitsClosed ::  UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]
--- Fast path, trivially closed.
-checkHomeUnitsClosed ue home_id_set home_imp_ids
-  | Set.size home_id_set == 1 = []
-  | otherwise =
-  let res = foldMap loop home_imp_ids
-  -- Now check whether everything which transitively depends on a home_unit is actually a home_unit
-  -- These units are the ones which we need to load as home packages but failed to do for some reason,
-  -- it's a bug in the tool invoking GHC.
-      bad_unit_ids = Set.difference res home_id_set
-  in if Set.null bad_unit_ids
-        then []
-        else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]
-
-  where
-    rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
-    -- TODO: This could repeat quite a bit of work but I struggled to write this function.
-    -- Which units transitively depend on a home unit
-    loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit
-    loop (from_uid, uid) =
-      let us = ue_findHomeUnitEnv from_uid ue in
-      let um = unitInfoMap (homeUnitEnv_units us) in
-      case Map.lookup uid um of
-        Nothing -> pprPanic "uid not found" (ppr uid)
-        Just ui ->
-          let depends = unitDepends ui
-              home_depends = Set.fromList depends `Set.intersection` home_id_set
-              other_depends = Set.fromList depends `Set.difference` home_id_set
-          in
-            -- Case 1: The unit directly depends on a home_id
-            if not (null home_depends)
-              then
-                let res = foldMap (loop . (from_uid,)) other_depends
-                in Set.insert uid res
-             -- Case 2: Check the rest of the dependencies, and then see if any of them depended on
-              else
-                let res = foldMap (loop . (from_uid,)) other_depends
-                in
-                  if not (Set.null res)
-                    then Set.insert uid res
-                    else res
-
--- | Update the every ModSummary that is depended on
--- by a module that needs template haskell. We enable codegen to
--- the specified target, disable optimization and change the .hi
--- and .o file locations to be temporary files.
--- See Note [-fno-code mode]
-enableCodeGenForTH
-  :: Logger
-  -> TmpFs
-  -> UnitEnv
-  -> [ModuleGraphNode]
-  -> IO [ModuleGraphNode]
-enableCodeGenForTH logger tmpfs unit_env =
-  enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env
-
-
-data CodeGenEnable = EnableByteCode | EnableObject | EnableByteCodeAndObject deriving (Eq, Show, Ord)
-
-instance Outputable CodeGenEnable where
-  ppr = text . show
-
--- | Helper used to implement 'enableCodeGenForTH'.
--- In particular, this enables
--- unoptimized code generation for all modules that meet some
--- condition (first parameter), or are dependencies of those
--- modules. The second parameter is a condition to check before
--- marking modules for code generation.
-enableCodeGenWhen
-  :: Logger
-  -> TmpFs
-  -> TempFileLifetime
-  -> TempFileLifetime
-  -> UnitEnv
-  -> [ModuleGraphNode]
-  -> IO [ModuleGraphNode]
-enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
-  mapM enable_code_gen mod_graph
-  where
-    defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)
-    enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode
-    enable_code_gen n@(ModuleNode deps ms)
-      | ModSummary
-        { ms_location = ms_location
-        , ms_hsc_src = HsSrcFile
-        , ms_hspp_opts = dflags
-        } <- ms
-      , Just enable_spec <- mkNodeKey n `Map.lookup` needs_codegen_map =
-      if | nocode_enable ms -> do
-               let new_temp_file suf dynsuf = do
-                     tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf
-                     let dyn_tn = tn -<.> dynsuf
-                     addFilesToClean tmpfs dynLife [dyn_tn]
-                     return (tn, dyn_tn)
-                 -- We don't want to create .o or .hi files unless we have been asked
-                 -- to by the user. But we need them, so we patch their locations in
-                 -- the ModSummary with temporary files.
-                 --
-               ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <-
-                 -- If ``-fwrite-interface` is specified, then the .o and .hi files
-                 -- are written into `-odir` and `-hidir` respectively.  #16670
-                 if gopt Opt_WriteInterface dflags
-                   then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location)
-                               , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))
-                   else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))
-                            <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))
-               let new_dflags = case enable_spec of
-                                  EnableByteCode -> dflags { backend = interpreterBackend }
-                                  EnableObject   -> dflags { backend = defaultBackendOf ms }
-                                  EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}
-               let ms' = ms
-                     { ms_location =
-                         ms_location { ml_hi_file = hi_file
-                                     , ml_obj_file = o_file
-                                     , ml_dyn_hi_file = dyn_hi_file
-                                     , ml_dyn_obj_file = dyn_o_file }
-                     , ms_hspp_opts = updOptLevel 0 $ new_dflags
-                     }
-               -- Recursive call to catch the other cases
-               enable_code_gen (ModuleNode deps ms')
-
-         -- If -fprefer-byte-code then satisfy dependency by enabling bytecode (if normal object not enough)
-         -- we only get to this case if the default backend is already generating object files, but we need dynamic
-         -- objects
-         | bytecode_and_enable enable_spec ms -> do
-               let ms' = ms
-                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode
-                     }
-               -- Recursive call to catch the other cases
-               enable_code_gen (ModuleNode deps ms')
-         | dynamic_too_enable enable_spec ms -> do
-               let ms' = ms
-                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo
-                     }
-               -- Recursive call to catch the other cases
-               enable_code_gen (ModuleNode deps ms')
-         | ext_interp_enable ms -> do
-               let ms' = ms
-                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter
-                     }
-               -- Recursive call to catch the other cases
-               enable_code_gen (ModuleNode deps ms')
-
-         | otherwise -> return n
-
-    enable_code_gen ms = return ms
-
-    nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) =
-      not (backendGeneratesCode (backend dflags)) &&
-      -- Don't enable codegen for TH on indefinite packages; we
-      -- can't compile anything anyway! See #16219.
-      isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env)
-
-    bytecode_and_enable enable_spec ms =
-      -- In the situation where we **would** need to enable dynamic-too
-      -- IF we had decided we needed objects
-      dynamic_too_enable EnableObject ms
-        -- but we prefer to use bytecode rather than objects
-        && prefer_bytecode
-        -- and we haven't already turned it on
-        && not generate_both
-      where
-        lcl_dflags   = ms_hspp_opts ms
-        prefer_bytecode = case enable_spec of
-                            EnableByteCodeAndObject -> True
-                            EnableByteCode -> True
-                            EnableObject -> False
-
-        generate_both   = gopt Opt_ByteCodeAndObjectCode lcl_dflags
-
-    -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
-    -- the linker can correctly load the object files.  This isn't necessary
-    -- when using -fexternal-interpreter.
-    dynamic_too_enable enable_spec ms
-      = hostIsDynamic && internalInterpreter &&
-            not isDynWay && not isProfWay &&  not dyn_too_enabled
-              && enable_object
-      where
-       lcl_dflags   = ms_hspp_opts ms
-       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)
-       dyn_too_enabled = gopt Opt_BuildDynamicToo lcl_dflags
-       isDynWay    = hasWay (ways lcl_dflags) WayDyn
-       isProfWay   = hasWay (ways lcl_dflags) WayProf
-       enable_object = case enable_spec of
-                            EnableByteCode -> False
-                            EnableByteCodeAndObject -> True
-                            EnableObject -> True
-
-    -- #16331 - when no "internal interpreter" is available but we
-    -- need to process some TemplateHaskell or QuasiQuotes, we automatically
-    -- turn on -fexternal-interpreter.
-    ext_interp_enable ms = not ghciSupported && internalInterpreter
-      where
-       lcl_dflags   = ms_hspp_opts ms
-       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)
-
-    (mg, lookup_node) = moduleGraphNodes False mod_graph
-
-    mk_needed_set roots = Set.fromList $ map (mkNodeKey . node_payload) $ reachablesG mg (map (expectJust "needs_th" . lookup_node) roots)
-
-    needs_obj_set, needs_bc_set :: Set.Set NodeKey
-    needs_obj_set = mk_needed_set need_obj_set
-
-    needs_bc_set = mk_needed_set need_bc_set
-
-    -- A map which tells us how to enable code generation for a NodeKey
-    needs_codegen_map :: Map.Map NodeKey CodeGenEnable
-    needs_codegen_map =
-      -- Another option here would be to just produce object code, rather than both object and
-      -- byte code
-      Map.unionWith (\_ _ -> EnableByteCodeAndObject)
-        (Map.fromList $ [(m, EnableObject) | m <- Set.toList needs_obj_set])
-        (Map.fromList $ [(m, EnableByteCode) | m <- Set.toList needs_bc_set])
-
-    -- The direct dependencies of modules which require object code
-    need_obj_set =
-      concat
-        -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only
-        -- it's dependencies.
-        [ deps
-        | (ModuleNode deps ms) <- mod_graph
-        , isTemplateHaskellOrQQNonBoot ms
-        , not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms))
-        ]
-
-    -- The direct dependencies of modules which require byte code
-    need_bc_set =
-      concat
-        [ deps
-        | (ModuleNode deps ms) <- mod_graph
-        , isTemplateHaskellOrQQNonBoot ms
-        , gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)
-        ]
-
--- | Populate the Downsweep cache with the root modules.
-mkRootMap
-  :: [ModSummary]
-  -> DownsweepCache
-mkRootMap summaries = Map.fromListWith (flip (++))
-  [ ((ms_unitid s, NoPkgQual, ms_mnwib s), [Right s]) | s <- summaries ]
-
------------------------------------------------------------------------------
--- Summarising modules
-
--- We have two types of summarisation:
---
---    * Summarise a file.  This is used for the root module(s) passed to
---      cmLoadModules.  The file is read, and used to determine the root
---      module name.  The module name may differ from the filename.
---
---    * Summarise a module.  We are given a module name, and must provide
---      a summary.  The finder is used to locate the file in which the module
---      resides.
-
-summariseFile
-        :: HscEnv
-        -> HomeUnit
-        -> M.Map FilePath ModSummary    -- old summaries
-        -> FilePath                     -- source file name
-        -> Maybe Phase                  -- start phase
-        -> Maybe (StringBuffer,UTCTime)
-        -> IO (Either DriverMessages ModSummary)
-
-summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
-        -- we can use a cached summary if one is available and the
-        -- source file hasn't changed,  But we have to look up the summary
-        -- by source file, rather than module name as we do in summarise.
-   | Just old_summary <- M.lookup src_fn old_summaries
-   = do
-        let location = ms_location $ old_summary
-
-        src_hash <- get_src_hash
-                -- The file exists; we checked in getRootSummary above.
-                -- If it gets removed subsequently, then this
-                -- getFileHash may fail, but that's the right
-                -- behaviour.
-
-                -- return the cached summary if the source didn't change
-        checkSummaryHash
-            hsc_env (new_summary src_fn)
-            old_summary location src_hash
-
-   | otherwise
-   = do src_hash <- get_src_hash
-        new_summary src_fn src_hash
-  where
-    -- change the main active unit so all operations happen relative to the given unit
-    hsc_env = hscSetActiveHomeUnit home_unit hsc_env'
-    -- src_fn does not necessarily exist on the filesystem, so we need to
-    -- check what kind of target we are dealing with
-    get_src_hash = case maybe_buf of
-                      Just (buf,_) -> return $ fingerprintStringBuffer buf
-                      Nothing -> liftIO $ getFileHash src_fn
-
-    new_summary src_fn src_hash = runExceptT $ do
-        preimps@PreprocessedImports {..}
-            <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf
-
-        let fopts = initFinderOpts (hsc_dflags hsc_env)
-
-        -- Make a ModLocation for this file
-        let location = mkHomeModLocation fopts pi_mod_name src_fn
-
-        -- Tell the Finder cache where it is, so that subsequent calls
-        -- to findModule will find it, even if it's not on any search path
-        mod <- liftIO $ do
-          let home_unit = hsc_home_unit hsc_env
-          let fc        = hsc_FC hsc_env
-          addHomeModuleToFinder fc home_unit pi_mod_name location
-
-        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
-            { nms_src_fn = src_fn
-            , nms_src_hash = src_hash
-            , nms_is_boot = NotBoot
-            , nms_hsc_src =
-                if isHaskellSigFilename src_fn
-                   then HsigFile
-                   else HsSrcFile
-            , nms_location = location
-            , nms_mod = mod
-            , nms_preimps = preimps
-            }
-
-checkSummaryHash
-    :: HscEnv
-    -> (Fingerprint -> IO (Either e ModSummary))
-    -> ModSummary -> ModLocation -> Fingerprint
-    -> IO (Either e ModSummary)
-checkSummaryHash
-  hsc_env new_summary
-  old_summary
-  location src_hash
-  | ms_hs_hash old_summary == src_hash &&
-      not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do
-           -- update the object-file timestamp
-           obj_timestamp <- modificationTimeIfExists (ml_obj_file location)
-
-           -- We have to repopulate the Finder's cache for file targets
-           -- because the file might not even be on the regular search path
-           -- and it was likely flushed in depanal. This is not technically
-           -- needed when we're called from sumariseModule but it shouldn't
-           -- hurt.
-           -- Also, only add to finder cache for non-boot modules as the finder cache
-           -- makes sure to add a boot suffix for boot files.
-           _ <- do
-              let fc        = hsc_FC hsc_env
-              case ms_hsc_src old_summary of
-                HsSrcFile -> addModuleToFinder fc (ms_mod old_summary) location
-                _ -> return ()
-
-           hi_timestamp <- modificationTimeIfExists (ml_hi_file location)
-           hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
-
-           return $ Right
-             ( old_summary
-                     { ms_obj_date = obj_timestamp
-                     , ms_iface_date = hi_timestamp
-                     , ms_hie_date = hie_timestamp
-                     }
-             )
-
-   | otherwise =
-           -- source changed: re-summarise.
-           new_summary src_hash
-
-data SummariseResult =
-        FoundInstantiation InstantiatedUnit
-      | FoundHomeWithError (UnitId, DriverMessages)
-      | FoundHome ModSummary
-      | External UnitId
-      | NotThere
-
--- Summarise a module, and pick up source and timestamp.
-summariseModule
-          :: HscEnv
-          -> HomeUnit
-          -> M.Map FilePath ModSummary
-          -- ^ Map of old summaries
-          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
-          -> Located ModuleName -- Imported module to be summarised
-          -> PkgQual
-          -> Maybe (StringBuffer, UTCTime)
-          -> [ModuleName]               -- Modules to exclude
-          -> IO SummariseResult
-
-
-summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_pkg
-                maybe_buf excl_mods
-  | wanted_mod `elem` excl_mods
-  = return NotThere
-  | otherwise  = find_it
-  where
-    -- Temporarily change the currently active home unit so all operations
-    -- happen relative to it
-    hsc_env   = hscSetActiveHomeUnit home_unit hsc_env'
-    dflags    = hsc_dflags hsc_env
-
-    find_it :: IO SummariseResult
-
-    find_it = do
-        found <- findImportedModule hsc_env wanted_mod mb_pkg
-        case found of
-             Found location mod
-                | isJust (ml_hs_file location) ->
-                        -- Home package
-                         just_found location mod
-                | VirtUnit iud <- moduleUnit mod
-                , not (isHomeModule home_unit mod)
-                  -> return $ FoundInstantiation iud
-                | otherwise -> return $ External (moduleUnitId mod)
-             _ -> return NotThere
-                        -- Not found
-                        -- (If it is TRULY not found at all, we'll
-                        -- error when we actually try to compile)
-
-    just_found location mod = do
-                -- Adjust location to point to the hs-boot source file,
-                -- hi file, object file, when is_boot says so
-        let location' = case is_boot of
-              IsBoot -> addBootSuffixLocn location
-              NotBoot -> location
-            src_fn = expectJust "summarise2" (ml_hs_file location')
-
-                -- Check that it exists
-                -- It might have been deleted since the Finder last found it
-        maybe_h <- fileHashIfExists src_fn
-        case maybe_h of
-          -- This situation can also happen if we have found the .hs file but the
-          -- .hs-boot file doesn't exist.
-          Nothing -> return NotThere
-          Just h  -> do
-            fresult <- new_summary_cache_check location' mod src_fn h
-            return $ case fresult of
-              Left err -> FoundHomeWithError (moduleUnitId mod, err)
-              Right ms -> FoundHome ms
-
-    new_summary_cache_check loc mod src_fn h
-      | Just old_summary <- Map.lookup src_fn old_summary_map =
-
-         -- check the hash on the source file, and
-         -- return the cached summary if it hasn't changed.  If the
-         -- file has changed then need to resummarise.
-        case maybe_buf of
-           Just (buf,_) ->
-               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf)
-           Nothing    ->
-               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h
-      | otherwise = new_summary loc mod src_fn h
-
-    new_summary :: ModLocation
-                  -> Module
-                  -> FilePath
-                  -> Fingerprint
-                  -> IO (Either DriverMessages ModSummary)
-    new_summary location mod src_fn src_hash
-      = runExceptT $ do
-        preimps@PreprocessedImports {..}
-            -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP
-            -- See multiHomeUnits_cpp2 test
-            <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf
-
-        -- NB: Despite the fact that is_boot is a top-level parameter, we
-        -- don't actually know coming into this function what the HscSource
-        -- of the module in question is.  This is because we may be processing
-        -- this module because another module in the graph imported it: in this
-        -- case, we know if it's a boot or not because of the {-# SOURCE #-}
-        -- annotation, but we don't know if it's a signature or a regular
-        -- module until we actually look it up on the filesystem.
-        let hsc_src
-              | is_boot == IsBoot = HsBootFile
-              | isHaskellSigFilename src_fn = HsigFile
-              | otherwise = HsSrcFile
-
-        when (pi_mod_name /= wanted_mod) $
-                throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
-                       $ DriverFileModuleNameMismatch pi_mod_name wanted_mod
-
-        let instantiations = homeUnitInstantiations home_unit
-        when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $
-            throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc
-                   $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations
-
-        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
-            { nms_src_fn = src_fn
-            , nms_src_hash = src_hash
-            , nms_is_boot = is_boot
-            , nms_hsc_src = hsc_src
-            , nms_location = location
-            , nms_mod = mod
-            , nms_preimps = preimps
-            }
-
--- | Convenience named arguments for 'makeNewModSummary' only used to make
--- code more readable, not exported.
-data MakeNewModSummary
-  = MakeNewModSummary
-      { nms_src_fn :: FilePath
-      , nms_src_hash :: Fingerprint
-      , nms_is_boot :: IsBootInterface
-      , nms_hsc_src :: HscSource
-      , nms_location :: ModLocation
-      , nms_mod :: Module
-      , nms_preimps :: PreprocessedImports
-      }
-
-makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary
-makeNewModSummary hsc_env MakeNewModSummary{..} = do
-  let PreprocessedImports{..} = nms_preimps
-  obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location)
-  dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location)
-  hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location)
-  hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)
-
-  extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name
-  (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps
-
-  return $
-        ModSummary
-        { ms_mod = nms_mod
-        , ms_hsc_src = nms_hsc_src
-        , ms_location = nms_location
-        , ms_hspp_file = pi_hspp_fn
-        , ms_hspp_opts = pi_local_dflags
-        , ms_hspp_buf  = Just pi_hspp_buf
-        , ms_parsed_mod = Nothing
-        , ms_srcimps = pi_srcimps
-        , ms_ghc_prim_import = pi_ghc_prim_import
-        , ms_textual_imps =
-            ((,) NoPkgQual . noLoc <$> extra_sig_imports) ++
-            ((,) NoPkgQual . noLoc <$> implicit_sigs) ++
-            pi_theimps
-        , ms_hs_hash = nms_src_hash
-        , ms_iface_date = hi_timestamp
-        , ms_hie_date = hie_timestamp
-        , ms_obj_date = obj_timestamp
-        , ms_dyn_obj_date = dyn_obj_timestamp
-        }
-
-data PreprocessedImports
-  = PreprocessedImports
-      { pi_local_dflags :: DynFlags
-      , pi_srcimps  :: [(PkgQual, Located ModuleName)]
-      , pi_theimps  :: [(PkgQual, Located ModuleName)]
-      , pi_ghc_prim_import :: Bool
-      , pi_hspp_fn  :: FilePath
-      , pi_hspp_buf :: StringBuffer
-      , pi_mod_name_loc :: SrcSpan
-      , pi_mod_name :: ModuleName
-      }
-
--- Preprocess the source file and get its imports
--- The pi_local_dflags contains the OPTIONS pragmas
-getPreprocessedImports
-    :: HscEnv
-    -> FilePath
-    -> Maybe Phase
-    -> Maybe (StringBuffer, UTCTime)
-    -- ^ optional source code buffer and modification time
-    -> ExceptT DriverMessages IO PreprocessedImports
-getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
-  (pi_local_dflags, pi_hspp_fn)
-      <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
-  pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn
-  (pi_srcimps', pi_theimps', pi_ghc_prim_import, L pi_mod_name_loc pi_mod_name)
-      <- ExceptT $ do
-          let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags
-              popts = initParserOpts pi_local_dflags
-          mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
-          return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps)
-  let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
-  let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
-  let pi_srcimps = rn_imps pi_srcimps'
-  let pi_theimps = rn_imps pi_theimps'
-  return PreprocessedImports {..}
-
-
------------------------------------------------------------------------------
---                      Error messages
------------------------------------------------------------------------------
-
--- Defer and group warning, error and fatal messages so they will not get lost
--- in the regular output.
-withDeferredDiagnostics :: GhcMonad m => m a -> m a
-withDeferredDiagnostics f = do
-  dflags <- getDynFlags
-  if not $ gopt Opt_DeferDiagnostics dflags
-  then f
-  else do
-    warnings <- liftIO $ newIORef []
-    errors <- liftIO $ newIORef []
-    fatals <- liftIO $ newIORef []
-    logger <- getLogger
-
-    let deferDiagnostics _dflags !msgClass !srcSpan !msg = do
-          let action = logMsg logger msgClass srcSpan msg
-          case msgClass of
-            MCDiagnostic SevWarning _reason _code
-              -> atomicModifyIORef' warnings $ \i -> (action: i, ())
-            MCDiagnostic SevError _reason _code
-              -> atomicModifyIORef' errors   $ \i -> (action: i, ())
-            MCFatal
-              -> atomicModifyIORef' fatals   $ \i -> (action: i, ())
-            _ -> action
-
-        printDeferredDiagnostics = liftIO $
-          forM_ [warnings, errors, fatals] $ \ref -> do
-            -- This IORef can leak when the dflags leaks, so let us always
-            -- reset the content.
-            actions <- atomicModifyIORef' ref $ \i -> ([], i)
-            sequence_ $ reverse actions
-
-    MC.bracket
-      (pushLogHookM (const deferDiagnostics))
-      (\_ -> popLogHookM >> printDeferredDiagnostics)
-      (\_ -> f)
-
-noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage
--- ToDo: we don't have a proper line number for this error
-noModError hsc_env loc wanted_mod err
-  = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $
-    DriverUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $
-    cannotFindModule hsc_env wanted_mod err
-
-{-
-noHsFileErr :: SrcSpan -> String -> DriverMessages
-noHsFileErr loc path
-  = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path)
-  -}
-
-moduleNotFoundErr :: ModuleName -> DriverMessages
-moduleNotFoundErr mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod)
-
-multiRootsErr :: [ModSummary] -> IO ()
-multiRootsErr [] = panic "multiRootsErr"
-multiRootsErr summs@(summ1:_)
-  = throwOneError $ fmap GhcDriverMessage $
-    mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files
-  where
-    mod = ms_mod summ1
-    files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
-
-cyclicModuleErr :: [ModuleGraphNode] -> SDoc
--- From a strongly connected component we find
--- a single cycle to report
-cyclicModuleErr mss
-  = assert (not (null mss)) $
-    case findCycle graph of
-       Nothing   -> text "Unexpected non-cycle" <+> ppr mss
-       Just path0 -> vcat
-        [ text "Module graph contains a cycle:"
-        , nest 2 (show_path path0)]
-  where
-    graph :: [Node NodeKey ModuleGraphNode]
-    graph =
-      [ DigraphNode
-        { node_payload = ms
-        , node_key = mkNodeKey ms
-        , node_dependencies = nodeDependencies False ms
-        }
-      | ms <- mss
-      ]
-
-    show_path :: [ModuleGraphNode] -> SDoc
-    show_path []  = panic "show_path"
-    show_path [m] = ppr_node m <+> text "imports itself"
-    show_path (m1:m2:ms) = vcat ( nest 6 (ppr_node m1)
-                                : nest 6 (text "imports" <+> ppr_node m2)
-                                : go ms )
-       where
-         go []     = [text "which imports" <+> ppr_node m1]
-         go (m:ms) = (text "which imports" <+> ppr_node m) : go ms
-
-    ppr_node :: ModuleGraphNode -> SDoc
-    ppr_node (ModuleNode _deps m) = text "module" <+> ppr_ms m
-    ppr_node (InstantiationNode _uid u) = text "instantiated unit" <+> ppr u
-    ppr_node (LinkNode uid _) = pprPanic "LinkNode should not be in a cycle" (ppr uid)
-
-    ppr_ms :: ModSummary -> SDoc
-    ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
-                (parens (text (msHsFilePath ms)))
-
-
-cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()
-cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =
-  unless (gopt Opt_KeepTmpFiles dflags) $
-    liftIO $ cleanCurrentModuleTempFiles logger tmpfs
-
-
-addDepsToHscEnv ::  [HomeModInfo] -> HscEnv -> HscEnv
-addDepsToHscEnv deps hsc_env =
-  hscUpdateHUG (\hug -> foldr addHomeModInfoToHug hug deps) hsc_env
-
-setHPT ::  HomePackageTable -> HscEnv -> HscEnv
-setHPT deps hsc_env =
-  hscUpdateHPT (const $ deps) hsc_env
-
-setHUG ::  HomeUnitGraph -> HscEnv -> HscEnv
-setHUG deps hsc_env =
-  hscUpdateHUG (const $ deps) hsc_env
-
--- | Wrap an action to catch and handle exceptions.
-wrapAction :: HscEnv -> IO a -> IO (Maybe a)
-wrapAction hsc_env k = do
-  let lcl_logger = hsc_logger hsc_env
-      lcl_dynflags = hsc_dflags hsc_env
-      print_config = initPrintConfig lcl_dynflags
-  let logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (srcErrorMessages err)
-  -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle
-  -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches`
-  -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to
-  -- internally using forkIO.
-  mres <- MC.try $ liftIO $ prettyPrintGhcErrors lcl_logger $ k
-  case mres of
-    Right res -> return $ Just res
-    Left exc -> do
-        case fromException exc of
-          Just (err :: SourceError)
-            -> logg err
-          Nothing -> case fromException exc of
-                        -- ThreadKilled in particular needs to actually kill the thread.
-                        -- So rethrow that and the other async exceptions
-                        Just (err :: SomeAsyncException) -> throwIO err
-                        _ -> errorMsg lcl_logger (text (show exc))
-        return Nothing
-
-withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b
-withParLog lqq_var k cont = do
-  let init_log = do
-        -- Make a new log queue
-        lq <- newLogQueue k
-        -- Add it into the LogQueueQueue
-        atomically $ initLogQueue lqq_var lq
-        return lq
-      finish_log lq = liftIO (finishLogQueue lq)
-  MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq)))
-
-withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a
-withLoggerHsc k MakeEnv{withLogger, hsc_env} cont = do
-  withLogger k $ \modifyLogger -> do
-    let lcl_logger = modifyLogger (hsc_logger hsc_env)
-        hsc_env' = hsc_env { hsc_logger = lcl_logger }
-    -- Run continuation with modified logger
-    cont hsc_env'
-
-
-executeInstantiationNode :: Int
-  -> Int
-  -> HomeUnitGraph
-  -> UnitId
-  -> InstantiatedUnit
-  -> RunMakeM ()
-executeInstantiationNode k n deps uid iu = do
-        env <- ask
-        -- Output of the logger is mediated by a central worker to
-        -- avoid output interleaving
-        msg <- asks env_messager
-        lift $ MaybeT $ withLoggerHsc k env $ \hsc_env ->
-          let lcl_hsc_env = setHUG deps hsc_env
-          in wrapAction lcl_hsc_env $ do
-            res <- upsweep_inst lcl_hsc_env msg k n uid iu
-            cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env)
-            return res
-
-
-executeCompileNode :: Int
-  -> Int
-  -> Maybe HomeModInfo
-  -> HomeUnitGraph
-  -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling
-  -> ModSummary
-  -> RunMakeM HomeModInfo
-executeCompileNode k n !old_hmi hug mrehydrate_mods mod = do
-  me@MakeEnv{..} <- ask
-  -- Rehydrate any dependencies if this module had a boot file or is a signature file.
-  lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do
-     hydrated_hsc_env <- liftIO $ maybeRehydrateBefore (setHUG hug hsc_env) mod fixed_mrehydrate_mods
-     let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas
-         lcl_dynflags = ms_hspp_opts mod
-     let lcl_hsc_env =
-             -- Localise the hsc_env to use the cached flags
-             hscSetFlags lcl_dynflags $
-             hydrated_hsc_env
-     -- Compile the module, locking with a semaphore to avoid too many modules
-     -- being compiled at the same time leading to high memory usage.
-     wrapAction lcl_hsc_env $ do
-      res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n
-      cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags
-      return res)
-
-  where
-    fixed_mrehydrate_mods =
-      case ms_hsc_src mod of
-        -- MP: It is probably a bit of a misimplementation in backpack that
-        -- compiling a signature requires an knot_var for that unit.
-        -- If you remove this then a lot of backpack tests fail.
-        HsigFile -> Just []
-        _ -> mrehydrate_mods
-
-{- Rehydration, see Note [Rehydrating Modules] -}
-
-rehydrate :: HscEnv        -- ^ The HPT in this HscEnv needs rehydrating.
-          -> [HomeModInfo] -- ^ These are the modules we want to rehydrate.
-          -> IO HscEnv
-rehydrate hsc_env hmis = do
-  debugTraceMsg logger 2 $ (
-     text "Re-hydrating loop: " <+> (ppr (map (mi_module . hm_iface) hmis)))
-  new_mods <- fixIO $ \new_mods -> do
-      let new_hpt = addListToHpt old_hpt new_mods
-      let new_hsc_env = hscUpdateHPT_lazy (const new_hpt) hsc_env
-      mds <- initIfaceCheck (text "rehydrate") new_hsc_env $
-                mapM (typecheckIface . hm_iface) hmis
-      let new_mods = [ (mn,hmi{ hm_details = details })
-                     | (hmi,details) <- zip hmis mds
-                     , let mn = moduleName (mi_module (hm_iface hmi)) ]
-      return new_mods
-  return $ setHPT (foldl' (\old (mn, hmi) -> addToHpt old mn hmi) old_hpt new_mods) hsc_env
-
-  where
-    logger  = hsc_logger hsc_env
-    to_delete =  (map (moduleName . mi_module . hm_iface) hmis)
-    -- Filter out old modules before tying the knot, otherwise we can end
-    -- up with a thunk which keeps reference to the old HomeModInfo.
-    !old_hpt = foldl' delFromHpt (hsc_HPT hsc_env) to_delete
-
--- If needed, then rehydrate the necessary modules with a suitable KnotVars for the
--- module currently being compiled.
-maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv
-maybeRehydrateBefore hsc_env _ Nothing = return hsc_env
-maybeRehydrateBefore hsc_env mod (Just mns) = do
-  knot_var <- initialise_knot_var hsc_env
-  let hmis = map (expectJust "mr" . lookupHpt (hsc_HPT hsc_env)) mns
-  rehydrate (hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }) hmis
-
-  where
-   initialise_knot_var hsc_env = liftIO $
-    let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (ms_mod mod)
-    in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv
-
-rehydrateAfter :: HscEnv
-  -> [ModuleName]
-  -> IO [HomeModInfo]
-rehydrateAfter new_hsc mns = do
-  let new_hpt = hsc_HPT new_hsc
-      hmis = map (expectJust "mrAfter" . lookupHpt new_hpt) mns
-  hsc_env <- rehydrate (new_hsc { hsc_type_env_vars = emptyKnotVars }) hmis
-  return $ map (\mn -> expectJust "rehydrate" $ lookupHpt (hsc_HPT hsc_env) mn) mns
-
-{-
-Note [Hydrating Modules]
-~~~~~~~~~~~~~~~~~~~~~~~~
-There are at least 4 different representations of an interface file as described
-by this diagram.
-
-------------------------------
-|       On-disk M.hi         |
-------------------------------
-    |             ^
-    | Read file   | Write file
-    V             |
--------------------------------
-|      ByteString             |
--------------------------------
-    |             ^
-    | Binary.get  | Binary.put
-    V             |
---------------------------------
-|    ModIface (an acyclic AST) |
---------------------------------
-    |           ^
-    | hydrate   | mkIfaceTc
-    V           |
----------------------------------
-|  ModDetails (lots of cycles)  |
----------------------------------
-
-The last step, converting a ModIface into a ModDetails is known as "hydration".
-
-Hydration happens in three different places
-
-* When an interface file is initially loaded from disk, it has to be hydrated.
-* When a module is finished compiling, we hydrate the ModIface in order to generate
-  the version of ModDetails which exists in memory (see Note [ModDetails and --make mode])
-* When dealing with boot files and module loops (see Note [Rehydrating Modules])
-
-Note [Rehydrating Modules]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If a module has a boot file then it is critical to rehydrate the modules on
-the path between the two (see #20561).
-
-Suppose we have ("R" for "recursive"):
-```
-R.hs-boot:   module R where
-               data T
-               g :: T -> T
-
-A.hs:        module A( f, T, g ) where
-                import {-# SOURCE #-} R
-                data S = MkS T
-                f :: T -> S = ...g...
-
-R.hs:        module R where
-                import A
-                data T = T1 | T2 S
-                g = ...f...
-```
-
-== Why we need to rehydrate A's ModIface before compiling R.hs
-
-After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type
-type uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same
-AbstractTyCon. (Abstract because it came from R.hs-boot; we know nothing about
-it.)
-
-When compiling R.hs, we build a TyCon for `T`.  But that TyCon mentions `S`, and
-it currently has an AbstractTyCon for `T` inside it.  But we want to build a
-fully cyclic structure, in which `S` refers to `T` and `T` refers to `S`.
-
-Solution: **rehydration**.  *Before compiling `R.hs`*, rehydrate all the
-ModIfaces below it that depend on R.hs-boot.  To rehydrate a ModIface, call
-`typecheckIface` to convert it to a ModDetails.  It's just a de-serialisation
-step, no type inference, just lookups.
-
-Now `S` will be bound to a thunk that, when forced, will "see" the final binding
-for `T`; see [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot).
-But note that this must be done *before* compiling R.hs.
-
-== Why we need to rehydrate A's ModIface after compiling R.hs
-
-When compiling R.hs, the knot-tying stuff above will ensure that `f`'s unfolding
-mentions the `LocalId` for `g`.  But when we finish R, we carefully ensure that
-all those `LocalIds` are turned into completed `GlobalIds`, replete with
-unfoldings etc.   Alas, that will not apply to the occurrences of `g` in `f`'s
-unfolding. And if we leave matters like that, they will stay that way, and *all*
-subsequent modules that import A will see a crippled unfolding for `f`.
-
-Solution: rehydrate both R and A's ModIface together, right after completing R.hs.
-
-~~ Which modules to rehydrate
-
-We only need rehydrate modules that are
-* Below R.hs
-* Above R.hs-boot
-
-There might be many unrelated modules (in the home package) that don't need to be
-rehydrated.
-
-== Loops with multiple boot files
-
-It is possible for a module graph to have a loop (SCC, when ignoring boot files)
-which requires multiple boot files to break. In this case, we must perform
-several hydration steps:
-  1. The hydration steps described above, which are necessary for correctness.
-  2. An extra hydration step at the end of compiling the entire SCC, in order to
-     remove space leaks, as we explain below.
-
-Consider the following example:
-
-   ┌─────┐     ┌─────┐
-   │  A  │     │  B  │
-   └──┬──┘     └──┬──┘
-      │           │
-  ┌───▼───────────▼───┐
-  │         C         │
-  └───┬───────────┬───┘
-      │           │
- ┌────▼───┐   ┌───▼────┐
- │ A-boot │   │ B-boot │
- └────────┘   └────────┘
-
-A, B and C live together in a SCC. Suppose that we compile the modules in the
-order:
-
-  A-boot, B-boot, C, A, B.
-
-When we come to compile A, we will perform the necessary hydration steps,
-because A has a boot file. This means that C will be hydrated relative to A,
-and the ModDetails for A will reference C/A. Then, when B is compiled,
-C will be rehydrated again, and so B will reference C/A,B. At this point,
-its interface will be hydrated relative to both A and B.
-This causes a space leak: there are now two different copies of C's ModDetails,
-kept alive by modules A and B. This is especially problematic if C is large.
-
-The way to avoid this space leak is to rehydrate an entire SCC together at the
-end of compilation, so that all the ModDetails point to interfaces for .hs files.
-In this example, when we hydrate A, B and C together, then both A and B will refer to
-C/A,B.
-
-See #21900 for some more discussion.
-
-== Modules "above" the loop
-
-This dark corner is the subject of #14092.
-
-Suppose we add to our example
-```
-X.hs     module X where
-           import A
-           data XT = MkX T
-           fx = ...g...
-```
-If in `--make` we compile R.hs-boot, then A.hs, then X.hs, we'll get a `ModDetails` for `X` that has an AbstractTyCon for `T` in the argument type of `MkX`.  So:
-
-* Either we should delay compiling X until after R has been compiled. (This is what we do)
-* Or we should rehydrate X after compiling R -- because it transitively depends on R.hs-boot.
-
-Ticket #20200 has exposed some issues to do with the knot-tying logic in GHC.Make, in `--make` mode.
-#20200 has lots of issues, many of them now fixed;
-this particular issue starts [here](https://gitlab.haskell.org/ghc/ghc/-/issues/20200#note_385758).
-
-The wiki page [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot) is helpful.
-Also closely related are
-    * #14092
-    * #14103
-
--}
-
-executeLinkNode :: HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()
-executeLinkNode hug kn uid deps = do
-  withCurrentUnit uid $ do
-    MakeEnv{..} <- ask
-    let dflags = hsc_dflags hsc_env
-    let hsc_env' = setHUG hug hsc_env
-        msg' = (\messager -> \recomp -> messager hsc_env kn recomp (LinkNode deps uid)) <$> env_messager
-
-    linkresult <- liftIO $ withAbstractSem compile_sem $ do
-                            link (ghcLink dflags)
-                                (hsc_logger hsc_env')
-                                (hsc_tmpfs hsc_env')
-                                (hsc_hooks hsc_env')
-                                dflags
-                                (hsc_unit_env hsc_env')
-                                True -- We already decided to link
-                                msg'
-                                (hsc_HPT hsc_env')
-    case linkresult of
-      Failed -> fail "Link Failed"
-      Succeeded -> return ()
-
-{-
-Note [ModuleNameSet, efficiency and space leaks]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-During upsweep, the results of compiling modules are placed into a MVar. When we need
-to compute the right compilation environment for a module, we consult this MVar and
-set the HomeUnitGraph accordingly. This is done to avoid having to precisely track
-module dependencies and recreating the HUG from scratch each time, which is very expensive.
-
-In serial mode (-j1), this all works out fine: a module can only be compiled
-after its dependencies have finished compiling, and compilation can't be
-interleaved with the compilation of other module loops. This ensures that
-the HUG only ever contains finalised interfaces.
-
-In parallel mode, we have to be more careful: the HUG variable can contain non-finalised
-interfaces, which have been started by another thread. In order to avoid a space leak
-in which a finalised interface is compiled against a HPT which contains a non-finalised
-interface, we have to restrict the HUG to only contain the visible modules.
-
-The collection of visible modules explains which transitive modules are visible
-from a certain point. It is recorded in the ModuleNameSet.
-Before a module is compiled, we use this set to restrict the HUG to the visible
-modules only, avoiding this tricky space leak.
-
-Efficiency of the ModuleNameSet is of utmost importance, because a union occurs for
-each edge in the module graph. To achieve this, the set is represented directly as an IntSet,
-which provides suitable performance – even using a UniqSet (which is backed by an IntMap) is
-too slow. The crucial test of performance here is the time taken to a do a no-op build in --make mode.
-
-See test "jspace" for an example which used to trigger this problem.
-
--}
-
--- See Note [ModuleNameSet, efficiency and space leaks]
-type ModuleNameSet = M.Map UnitId I.IntSet
-
-addToModuleNameSet :: UnitId -> ModuleName -> ModuleNameSet -> ModuleNameSet
-addToModuleNameSet uid mn s =
-  let k = (getKey $ getUnique $ mn)
-  in M.insertWith (I.union) uid (I.singleton k) s
-
--- | Wait for some dependencies to finish and then read from the given MVar.
-wait_deps_hug :: MVar HomeUnitGraph -> [BuildResult] -> ReaderT MakeEnv (MaybeT IO) (HomeUnitGraph, ModuleNameSet)
-wait_deps_hug hug_var deps = do
-  (_, module_deps) <- wait_deps deps
-  hug <- liftIO $ readMVar hug_var
-  let pruneHomeUnitEnv uid hme =
-        let -- Restrict to things which are in the transitive closure to avoid retaining
-            -- reference to loop modules which have already been compiled by other threads.
-            -- See Note [ModuleNameSet, efficiency and space leaks]
-            !new = udfmRestrictKeysSet (homeUnitEnv_hpt hme) (fromMaybe I.empty $ M.lookup  uid module_deps)
-        in hme { homeUnitEnv_hpt = new }
-  return (unitEnv_mapWithKey pruneHomeUnitEnv hug, module_deps)
-
--- | Wait for dependencies to finish, and then return their results.
-wait_deps :: [BuildResult] -> RunMakeM ([HomeModInfo], ModuleNameSet)
-wait_deps [] = return ([], M.empty)
-wait_deps (x:xs) = do
-  (res, deps) <- lift $ waitResult (resultVar x)
-  (hmis, all_deps) <- wait_deps xs
-  let !new_deps = deps `unionModuleNameSet` all_deps
-  case res of
-    Nothing -> return (hmis, new_deps)
-    Just hmi -> return (hmi:hmis, new_deps)
-  where
-    unionModuleNameSet = M.unionWith I.union
-
-
--- Executing the pipelines
-
-
-label_self :: String -> IO ()
-label_self thread_name = do
-    self_tid <- CC.myThreadId
-    CC.labelThread self_tid thread_name
-
-
-runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
--- Don't even initialise plugins if there are no pipelines
-runPipelines _ _ _ [] = return ()
-runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do
-  liftIO $ label_self "main --make thread"
-
-  plugins_hsc_env <- initializePlugins orig_hsc_env
-  case n_job of
-    1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines
-    _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines
-
-runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO ()
-runSeqPipelines plugin_hsc_env mHscMessager all_pipelines =
-  let env = MakeEnv { hsc_env = plugin_hsc_env
-                    , withLogger = \_ k -> k id
-                    , compile_sem = AbstractSem (return ()) (return ())
-                    , env_messager = mHscMessager
-                    }
-  in runAllPipelines 1 env all_pipelines
-
-
--- | Build and run a pipeline
-runParPipelines :: Int              -- ^ How many capabilities to use
-             -> HscEnv           -- ^ The basic HscEnv which is augmented with specific info for each module
-             -> Maybe Messager   -- ^ Optional custom messager to use to report progress
-             -> [MakeAction]  -- ^ The build plan for all the module nodes
-             -> IO ()
-runParPipelines n_jobs plugin_hsc_env mHscMessager all_pipelines = do
-
-
-  -- A variable which we write to when an error has happened and we have to tell the
-  -- logging thread to gracefully shut down.
-  stopped_var <- newTVarIO False
-  -- The queue of LogQueues which actions are able to write to. When an action starts it
-  -- will add it's LogQueue into this queue.
-  log_queue_queue_var <- newTVarIO newLogQueueQueue
-  -- Thread which coordinates the printing of logs
-  wait_log_thread <- logThread n_jobs (length all_pipelines) (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var
-
-
-  -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue.
-  thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)
-  let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }
-
-  let updNumCapabilities = liftIO $ do
-          n_capabilities <- getNumCapabilities
-          n_cpus <- getNumProcessors
-          -- Setting number of capabilities more than
-          -- CPU count usually leads to high userspace
-          -- lock contention. #9221
-          let n_caps = min n_jobs n_cpus
-          unless (n_capabilities /= 1) $ setNumCapabilities n_caps
-          return n_capabilities
-
-  let resetNumCapabilities orig_n = do
-          liftIO $ setNumCapabilities orig_n
-          atomically $ writeTVar stopped_var True
-          wait_log_thread
-
-  compile_sem <- newQSem n_jobs
-  let abstract_sem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem)
-    -- Reset the number of capabilities once the upsweep ends.
-  let env = MakeEnv { hsc_env = thread_safe_hsc_env
-                    , withLogger = withParLog log_queue_queue_var
-                    , compile_sem = abstract_sem
-                    , env_messager = mHscMessager
-                    }
-
-  MC.bracket updNumCapabilities resetNumCapabilities $ \_ ->
-    runAllPipelines n_jobs env all_pipelines
-
-withLocalTmpFS :: RunMakeM a -> RunMakeM a
-withLocalTmpFS act = do
-  let initialiser = do
-        MakeEnv{..} <- ask
-        lcl_tmpfs <- liftIO $ forkTmpFsFrom (hsc_tmpfs hsc_env)
-        return $ hsc_env { hsc_tmpfs  = lcl_tmpfs }
-      finaliser lcl_env = do
-        gbl_env <- ask
-        liftIO $ mergeTmpFsInto (hsc_tmpfs lcl_env) (hsc_tmpfs (hsc_env gbl_env))
-       -- Add remaining files which weren't cleaned up into local tmp fs for
-       -- clean-up later.
-       -- Clear the logQueue if this node had it's own log queue
-  MC.bracket initialiser finaliser $ \lcl_hsc_env -> local (\env -> env { hsc_env = lcl_hsc_env}) act
-
--- | Run the given actions and then wait for them all to finish.
-runAllPipelines :: Int -> MakeEnv -> [MakeAction] -> IO ()
-runAllPipelines n_jobs env acts = do
-  let spawn_actions :: IO [ThreadId]
-      spawn_actions = if n_jobs == 1
-        then (:[]) <$> (forkIOWithUnmask $ \unmask -> void $ runLoop (\io -> io unmask) env acts)
-        else runLoop forkIOWithUnmask env acts
-
-      kill_actions :: [ThreadId] -> IO ()
-      kill_actions tids = mapM_ killThread tids
-
-  MC.bracket spawn_actions kill_actions $ \_ -> do
-    mapM_ waitMakeAction acts
-
--- | Execute each action in order, limiting the amount of parallelism by the given
--- semaphore.
-runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a]
-runLoop _ _env [] = return []
-runLoop fork_thread env (MakeAction act res_var :acts) = do
-  new_thread <-
-    fork_thread $ \unmask -> (do
-            mres <- (unmask $ run_pipeline (withLocalTmpFS act))
-                      `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure.
-            putMVar res_var mres)
-  threads <- runLoop fork_thread env acts
-  return (new_thread : threads)
-  where
-      run_pipeline :: RunMakeM a -> IO (Maybe a)
-      run_pipeline p = runMaybeT (runReaderT p env)
-
-data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a))
-
-waitMakeAction :: MakeAction -> IO ()
-waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar
-
-{- Note [GHC Heap Invariants]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~
-This note is a general place to explain some of the heap invariants which should
-hold for a program compiled with --make mode. These invariants are all things
-which can be checked easily using ghc-debug.
-
-1. No HomeModInfo are reachable via the EPS.
-   Why? Interfaces are lazily loaded into the EPS and the lazy thunk retains
-        a reference to the entire HscEnv, if we are not careful the HscEnv will
-        contain the HomePackageTable at the time the interface was loaded and
-        it will never be released.
-   Where? dontLeakTheHPT in GHC.Iface.Load
-
-2. No KnotVars are live at the end of upsweep (#20491)
-   Why? KnotVars contains an old stale reference to the TypeEnv for modules
-        which participate in a loop. At the end of a loop all the KnotVars references
-        should be removed by the call to typecheckLoop.
-   Where? typecheckLoop in GHC.Driver.Make.
-
-3. Immediately after a reload, no ModDetails are live.
-   Why? During the upsweep all old ModDetails are replaced with a new ModDetails
-        generated from a ModIface. If we don't clear the ModDetails before the
-        reload takes place then memory usage during the reload is twice as much
-        as it should be as we retain a copy of the ModDetails for too long.
-   Where? pruneCache in GHC.Driver.Make
-
-4. No TcGblEnv or TcLclEnv are live after typechecking is completed.
-   Why? By the time we get to simplification all the data structures from typechecking
-        should be eliminated.
-   Where? No one place in the compiler. These leaks can be introduced by not suitable
-          forcing functions which take a TcLclEnv as an argument.
-
-5. At the end of a successful upsweep, the number of live ModDetails equals the
-   number of non-boot Modules.
-   Why? Each module has a HomeModInfo which contains a ModDetails from that module.
-   Where? See Note [ModuleNameSet, efficiency and space leaks], a variety of places
-          in the driver are responsible.
--}
diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/MakeFile.hs
+++ /dev/null
@@ -1,454 +0,0 @@
-
-
------------------------------------------------------------------------------
---
--- Makefile Dependency Generation
---
--- (c) The University of Glasgow 2005
---
------------------------------------------------------------------------------
-
-module GHC.Driver.MakeFile
-   ( doMkDependHS
-   )
-where
-
-import GHC.Prelude
-
-import qualified GHC
-import GHC.Driver.Monad
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Utils.Misc
-import GHC.Driver.Env
-import GHC.Driver.Errors.Types
-import qualified GHC.SysTools as SysTools
-import GHC.Data.Graph.Directed ( SCC(..) )
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Types.Error (UnknownDiagnostic(..))
-import GHC.Types.SourceError
-import GHC.Types.SrcLoc
-import GHC.Types.PkgQual
-import Data.List (partition)
-import GHC.Utils.TmpFs
-
-import GHC.Iface.Load (cannotFindModule)
-
-import GHC.Unit.Module
-import GHC.Unit.Module.ModSummary
-import GHC.Unit.Module.Graph
-import GHC.Unit.Finder
-
-import GHC.Utils.Exception
-import GHC.Utils.Error
-import GHC.Utils.Logger
-
-import System.Directory
-import System.FilePath
-import System.IO
-import System.IO.Error  ( isEOFError )
-import Control.Monad    ( when, forM_ )
-import Data.Maybe       ( isJust )
-import Data.IORef
-import qualified Data.Set as Set
-
------------------------------------------------------------------
---
---              The main function
---
------------------------------------------------------------------
-
-doMkDependHS :: GhcMonad m => [FilePath] -> m ()
-doMkDependHS srcs = do
-    logger <- getLogger
-
-    -- Initialisation
-    dflags0 <- GHC.getSessionDynFlags
-
-    -- We kludge things a bit for dependency generation. Rather than
-    -- generating dependencies for each way separately, we generate
-    -- them once and then duplicate them for each way's osuf/hisuf.
-    -- We therefore do the initial dependency generation with an empty
-    -- way and .o/.hi extensions, regardless of any flags that might
-    -- be specified.
-    let dflags1 = dflags0
-            { targetWays_ = Set.empty
-            , hiSuf_      = "hi"
-            , objectSuf_  = "o"
-            }
-    GHC.setSessionDynFlags dflags1
-
-    -- If no suffix is provided, use the default -- the empty one
-    let dflags = if null (depSuffixes dflags1)
-                 then dflags1 { depSuffixes = [""] }
-                 else dflags1
-
-    tmpfs <- hsc_tmpfs <$> getSession
-    files <- liftIO $ beginMkDependHS logger tmpfs dflags
-
-    -- Do the downsweep to find all the modules
-    targets <- mapM (\s -> GHC.guessTarget s Nothing Nothing) srcs
-    GHC.setTargets targets
-    let excl_mods = depExcludeMods dflags
-    module_graph <- GHC.depanal excl_mods True {- Allow dup roots -}
-
-    -- Sort into dependency order
-    -- There should be no cycles
-    let sorted = GHC.topSortModuleGraph False module_graph Nothing
-
-    -- Print out the dependencies if wanted
-    liftIO $ debugTraceMsg logger 2 (text "Module dependencies" $$ ppr sorted)
-
-    -- Process them one by one, dumping results into makefile
-    -- and complaining about cycles
-    hsc_env <- getSession
-    root <- liftIO getCurrentDirectory
-    mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
-
-    -- If -ddump-mod-cycles, show cycles in the module graph
-    liftIO $ dumpModCycles logger module_graph
-
-    -- Tidy up
-    liftIO $ endMkDependHS logger files
-
-    -- Unconditional exiting is a bad idea.  If an error occurs we'll get an
-    --exception; if that is not caught it's fine, but at least we have a
-    --chance to find out exactly what went wrong.  Uncomment the following
-    --line if you disagree.
-
-    --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)
-
------------------------------------------------------------------
---
---              beginMkDependHs
---      Create a temporary file,
---      find the Makefile,
---      slurp through it, etc
---
------------------------------------------------------------------
-
-data MkDepFiles
-  = MkDep { mkd_make_file :: FilePath,          -- Name of the makefile
-            mkd_make_hdl  :: Maybe Handle,      -- Handle for the open makefile
-            mkd_tmp_file  :: FilePath,          -- Name of the temporary file
-            mkd_tmp_hdl   :: Handle }           -- Handle of the open temporary file
-
-beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles
-beginMkDependHS logger tmpfs dflags = do
-        -- open a new temp file in which to stuff the dependency info
-        -- as we go along.
-  tmp_file <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "dep"
-  tmp_hdl <- openFile tmp_file WriteMode
-
-        -- open the makefile
-  let makefile = depMakefile dflags
-  exists <- doesFileExist makefile
-  mb_make_hdl <-
-        if not exists
-        then return Nothing
-        else do
-           makefile_hdl <- openFile makefile ReadMode
-
-                -- slurp through until we get the magic start string,
-                -- copying the contents into dep_makefile
-           let slurp = do
-                l <- hGetLine makefile_hdl
-                if (l == depStartMarker)
-                        then return ()
-                        else do hPutStrLn tmp_hdl l; slurp
-
-                -- slurp through until we get the magic end marker,
-                -- throwing away the contents
-           let chuck = do
-                l <- hGetLine makefile_hdl
-                if (l == depEndMarker)
-                        then return ()
-                        else chuck
-
-           catchIO slurp
-                (\e -> if isEOFError e then return () else ioError e)
-           catchIO chuck
-                (\e -> if isEOFError e then return () else ioError e)
-
-           return (Just makefile_hdl)
-
-
-        -- write the magic marker into the tmp file
-  hPutStrLn tmp_hdl depStartMarker
-
-  return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
-                  mkd_tmp_file  = tmp_file, mkd_tmp_hdl  = tmp_hdl})
-
-
------------------------------------------------------------------
---
---              processDeps
---
------------------------------------------------------------------
-
-processDeps :: DynFlags
-            -> HscEnv
-            -> [ModuleName]
-            -> FilePath
-            -> Handle           -- Write dependencies to here
-            -> SCC ModuleGraphNode
-            -> IO ()
--- Write suitable dependencies to handle
--- Always:
---                      this.o : this.hs
---
--- If the dependency is on something other than a .hi file:
---                      this.o this.p_o ... : dep
--- otherwise
---                      this.o ...   : dep.hi
---                      this.p_o ... : dep.p_hi
---                      ...
--- (where .o is $osuf, and the other suffixes come from
--- the cmdline -s options).
---
--- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
-
-processDeps dflags _ _ _ _ (CyclicSCC nodes)
-  =     -- There shouldn't be any cycles; report them
-    throwGhcExceptionIO $ ProgramError $
-      showSDoc dflags $ GHC.cyclicModuleErr nodes
-
-processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode _uid node))
-  =     -- There shouldn't be any backpack instantiations; report them as well
-    throwGhcExceptionIO $ ProgramError $
-      showSDoc dflags $
-        vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"
-             , nest 2 $ ppr node ]
-processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return ()
-
-processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ node))
-  = do  { let extra_suffixes = depSuffixes dflags
-              include_pkg_deps = depIncludePkgDeps dflags
-              src_file  = msHsFilePath node
-              obj_file  = msObjFilePath node
-              obj_files = insertSuffixes obj_file extra_suffixes
-
-              do_imp loc is_boot pkg_qual imp_mod
-                = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod
-                                               is_boot include_pkg_deps
-                     ; case mb_hi of {
-                           Nothing      -> return () ;
-                           Just hi_file -> do
-                     { let hi_files = insertSuffixes hi_file extra_suffixes
-                           write_dep (obj,hi) = writeDependency root hdl [obj] hi
-
-                        -- Add one dependency for each suffix;
-                        -- e.g.         A.o   : B.hi
-                        --              A.x_o : B.x_hi
-                     ; mapM_ write_dep (obj_files `zip` hi_files) }}}
-
-
-                -- Emit std dependency of the object(s) on the source file
-                -- Something like       A.o : A.hs
-        ; writeDependency root hdl obj_files src_file
-
-          -- add dependency between objects and their corresponding .hi-boot
-          -- files if the module has a corresponding .hs-boot file (#14482)
-        ; when (isBootSummary node == IsBoot) $ do
-            let hi_boot = msHiFilePath node
-            let obj     = removeBootSuffix (msObjFilePath node)
-            forM_ extra_suffixes $ \suff -> do
-               let way_obj     = insertSuffixes obj     [suff]
-               let way_hi_boot = insertSuffixes hi_boot [suff]
-               mapM_ (writeDependency root hdl way_obj) way_hi_boot
-
-                -- Emit a dependency for each CPP import
-        ; when (depIncludeCppDeps dflags) $ do
-            -- CPP deps are discovered in the module parsing phase by parsing
-            -- comment lines left by the preprocessor.
-            -- Note that GHC.parseModule may throw an exception if the module
-            -- fails to parse, which may not be desirable (see #16616).
-          { session <- Session <$> newIORef hsc_env
-          ; parsedMod <- reflectGhc (GHC.parseModule node) session
-          ; mapM_ (writeDependency root hdl obj_files)
-                  (GHC.pm_extra_src_files parsedMod)
-          }
-
-                -- Emit a dependency for each import
-
-        ; let do_imps is_boot idecls = sequence_
-                    [ do_imp loc is_boot mb_pkg mod
-                    | (mb_pkg, L loc mod) <- idecls,
-                      mod `notElem` excl_mods ]
-
-        ; do_imps IsBoot (ms_srcimps node)
-        ; do_imps NotBoot (ms_imps node)
-        }
-
-
-findDependency  :: HscEnv
-                -> SrcSpan
-                -> PkgQual              -- package qualifier, if any
-                -> ModuleName           -- Imported module
-                -> IsBootInterface      -- Source import
-                -> Bool                 -- Record dependency on package modules
-                -> IO (Maybe FilePath)  -- Interface file
-findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
-  -- Find the module; this will be fast because
-  -- we've done it once during downsweep
-  r <- findImportedModule hsc_env imp pkg
-  case r of
-    Found loc _
-        -- Home package: just depend on the .hi or hi-boot file
-        | isJust (ml_hs_file loc) || include_pkg_deps
-        -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
-
-        -- Not in this package: we don't need a dependency
-        | otherwise
-        -> return Nothing
-
-    fail ->
-        throwOneError $
-          mkPlainErrorMsgEnvelope srcloc $
-          GhcDriverMessage $ DriverUnknownMessage $
-             UnknownDiagnostic $ mkPlainError noHints $
-             cannotFindModule hsc_env imp fail
-
------------------------------
-writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
--- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
---      t1 t2 : dep
-writeDependency root hdl targets dep
-  = do let -- We need to avoid making deps on
-           --     c:/foo/...
-           -- on cygwin as make gets confused by the :
-           -- Making relative deps avoids some instances of this.
-           dep' = makeRelative root dep
-           forOutput = escapeSpaces . reslash Forwards . normalise
-           output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
-       hPutStrLn hdl output
-
------------------------------
-insertSuffixes
-        :: FilePath     -- Original filename;   e.g. "foo.o"
-        -> [String]     -- Suffix prefixes      e.g. ["x_", "y_"]
-        -> [FilePath]   -- Zapped filenames     e.g. ["foo.x_o", "foo.y_o"]
-        -- Note that the extra bit gets inserted *before* the old suffix
-        -- We assume the old suffix contains no dots, so we know where to
-        -- split it
-insertSuffixes file_name extras
-  = [ basename <.> (extra ++ suffix) | extra <- extras ]
-  where
-    (basename, suffix) = case splitExtension file_name of
-                         -- Drop the "." from the extension
-                         (b, s) -> (b, drop 1 s)
-
-
------------------------------------------------------------------
---
---              endMkDependHs
---      Complete the makefile, close the tmp file etc
---
------------------------------------------------------------------
-
-endMkDependHS :: Logger -> MkDepFiles -> IO ()
-
-endMkDependHS logger
-   (MkDep { mkd_make_file = makefile, mkd_make_hdl =  makefile_hdl,
-            mkd_tmp_file  = tmp_file, mkd_tmp_hdl  =  tmp_hdl })
-  = do
-  -- write the magic marker into the tmp file
-  hPutStrLn tmp_hdl depEndMarker
-
-  case makefile_hdl of
-     Nothing  -> return ()
-     Just hdl -> do
-        -- slurp the rest of the original makefile and copy it into the output
-        SysTools.copyHandle hdl tmp_hdl
-        hClose hdl
-
-  hClose tmp_hdl  -- make sure it's flushed
-
-        -- Create a backup of the original makefile
-  when (isJust makefile_hdl) $ do
-    showPass logger ("Backing up " ++ makefile)
-    SysTools.copyFile makefile (makefile++".bak")
-
-        -- Copy the new makefile in place
-  showPass logger "Installing new makefile"
-  SysTools.copyFile tmp_file makefile
-
-
------------------------------------------------------------------
---              Module cycles
------------------------------------------------------------------
-
-dumpModCycles :: Logger -> ModuleGraph -> IO ()
-dumpModCycles logger module_graph
-  | not (logHasDumpFlag logger Opt_D_dump_mod_cycles)
-  = return ()
-
-  | null cycles
-  = putMsg logger (text "No module cycles")
-
-  | otherwise
-  = putMsg logger (hang (text "Module cycles found:") 2 pp_cycles)
-  where
-    topoSort = GHC.topSortModuleGraph True module_graph Nothing
-
-    cycles :: [[ModuleGraphNode]]
-    cycles =
-      [ c | CyclicSCC c <- topoSort ]
-
-    pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> text "----------")
-                        $$ pprCycle c $$ blankLine
-                     | (n,c) <- [1..] `zip` cycles ]
-
-pprCycle :: [ModuleGraphNode] -> SDoc
--- Print a cycle, but show only the imports within the cycle
-pprCycle summaries = pp_group (CyclicSCC summaries)
-  where
-    cycle_mods :: [ModuleName]  -- The modules in this cycle
-    cycle_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- summaries]
-
-    pp_group :: SCC ModuleGraphNode -> SDoc
-    pp_group (AcyclicSCC (ModuleNode _ ms)) = pp_ms ms
-    pp_group (AcyclicSCC _) = empty
-    pp_group (CyclicSCC mss)
-        = assert (not (null boot_only)) $
-                -- The boot-only list must be non-empty, else there would
-                -- be an infinite chain of non-boot imports, and we've
-                -- already checked for that in processModDeps
-          pp_ms loop_breaker $$ vcat (map pp_group groups)
-        where
-          (boot_only, others) = partition is_boot_only mss
-          is_boot_only (ModuleNode _ ms) = not (any in_group (map snd (ms_imps ms)))
-          is_boot_only  _ = False
-          in_group (L _ m) = m `elem` group_mods
-          group_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- mss]
-
-          loop_breaker = head ([ms | ModuleNode _ ms  <- boot_only])
-          all_others   = tail boot_only ++ others
-          groups =
-            GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing
-
-    pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
-                       <+> (pp_imps empty (map snd (ms_imps summary)) $$
-                            pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary)))
-        where
-          mod_str = moduleNameString (moduleName (ms_mod summary))
-
-    pp_imps :: SDoc -> [Located ModuleName] -> SDoc
-    pp_imps _    [] = empty
-    pp_imps what lms
-        = case [m | L _ m <- lms, m `elem` cycle_mods] of
-            [] -> empty
-            ms -> what <+> text "imports" <+>
-                                pprWithCommas ppr ms
-
------------------------------------------------------------------
---
---              Flags
---
------------------------------------------------------------------
-
-depStartMarker, depEndMarker :: String
-depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
-depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ /dev/null
@@ -1,955 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE BangPatterns #-}
-
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NondecreasingIndentation #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TypeApplications #-}
-
------------------------------------------------------------------------------
---
--- GHC Driver
---
--- (c) The University of Glasgow 2005
---
------------------------------------------------------------------------------
-
-module GHC.Driver.Pipeline (
-   -- * Run a series of compilation steps in a pipeline, for a
-   -- collection of source files.
-   oneShot, compileFile,
-
-   -- * Interfaces for the compilation manager (interpreted/batch-mode)
-   preprocess,
-   compileOne, compileOne',
-   compileForeign, compileEmptyStub,
-
-   -- * Linking
-   link, linkingNeeded, checkLinkInfo,
-
-   -- * PipeEnv
-   PipeEnv(..), mkPipeEnv, phaseOutputFilenameNew,
-
-   -- * Running individual phases
-   TPhase(..), runPhase,
-   hscPostBackendPhase,
-
-   -- * Constructing Pipelines
-   TPipelineClass, MonadUse(..),
-
-   preprocessPipeline, fullPipeline, hscPipeline, hscBackendPipeline, hscPostBackendPipeline,
-   hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline, jsPipeline,
-   llvmPipeline, llvmLlcPipeline, llvmManglePipeline, pipelineStart,
-
-   -- * Default method of running a pipeline
-   runPipeline
-) where
-
-
-import GHC.Prelude
-
-import GHC.Platform
-
-import GHC.Utils.Monad ( MonadIO(liftIO), mapMaybeM )
-
-import GHC.Driver.Main
-import GHC.Driver.Env hiding ( Hsc )
-import GHC.Driver.Errors
-import GHC.Driver.Errors.Types
-import GHC.Driver.Pipeline.Monad
-import GHC.Driver.Config.Diagnostic
-import GHC.Driver.Config.StgToJS
-import GHC.Driver.Phases
-import GHC.Driver.Pipeline.Execute
-import GHC.Driver.Pipeline.Phases
-import GHC.Driver.Session
-import GHC.Driver.Backend
-import GHC.Driver.Ppr
-import GHC.Driver.Hooks
-
-import GHC.Platform.Ways
-
-import GHC.SysTools
-import GHC.SysTools.Cpp
-import GHC.Utils.TmpFs
-
-import GHC.Linker.ExtraObj
-import GHC.Linker.Static
-import GHC.Linker.Static.Utils
-import GHC.Linker.Types
-
-import GHC.StgToJS.Linker.Linker
-import GHC.StgToJS.Linker.Types (defaultJSLinkConfig)
-
-import GHC.Utils.Outputable
-import GHC.Utils.Error
-import GHC.Utils.Panic
-import GHC.Utils.Misc
-import GHC.Utils.Exception as Exception
-import GHC.Utils.Logger
-
-import qualified GHC.LanguageExtensions as LangExt
-
-import GHC.Data.FastString     ( mkFastString )
-import GHC.Data.StringBuffer   ( hPutStringBuffer )
-import GHC.Data.Maybe          ( expectJust )
-
-import GHC.Iface.Make          ( mkFullIface )
-import GHC.Runtime.Loader      ( initializePlugins )
-
-
-import GHC.Types.Basic       ( SuccessFlag(..), ForeignSrcLang(..) )
-import GHC.Types.Error       ( singleMessage, getMessages, UnknownDiagnostic (..) )
-import GHC.Types.Target
-import GHC.Types.SrcLoc
-import GHC.Types.SourceFile
-import GHC.Types.SourceError
-
-import GHC.Unit
-import GHC.Unit.Env
---import GHC.Unit.Finder
---import GHC.Unit.State
-import GHC.Unit.Module.ModSummary
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.Deps
-import GHC.Unit.Home.ModInfo
-
-import System.Directory
-import System.FilePath
-import System.IO
-import Control.Monad
-import qualified Control.Monad.Catch as MC (handle)
-import Data.Maybe
-import Data.Either      ( partitionEithers )
-import qualified Data.Set as Set
-
-import Data.Time        ( getCurrentTime )
-import GHC.Iface.Recomp
-
--- Simpler type synonym for actions in the pipeline monad
-type P m = TPipelineClass TPhase m
-
--- ---------------------------------------------------------------------------
--- Pre-process
-
--- | Just preprocess a file, put the result in a temp. file (used by the
--- compilation manager during the summary phase).
---
--- We return the augmented DynFlags, because they contain the result
--- of slurping in the OPTIONS pragmas
-
-preprocess :: HscEnv
-           -> FilePath -- ^ input filename
-           -> Maybe InputFileBuffer
-           -- ^ optional buffer to use instead of reading the input file
-           -> Maybe Phase -- ^ starting phase
-           -> IO (Either DriverMessages (DynFlags, FilePath))
-preprocess hsc_env input_fn mb_input_buf mb_phase =
-  handleSourceError (\err -> return $ Left $ to_driver_messages $ srcErrorMessages err) $
-  MC.handle handler $
-  fmap Right $ do
-  massertPpr (isJust mb_phase || isHaskellSrcFilename input_fn) (text input_fn)
-  input_fn_final <- mkInputFn
-  let preprocess_pipeline = preprocessPipeline pipe_env (setDumpPrefix pipe_env hsc_env) input_fn_final
-  runPipeline (hsc_hooks hsc_env) preprocess_pipeline
-
-  where
-    srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1
-    handler (ProgramError msg) =
-      return $ Left $ singleMessage $
-        mkPlainErrorMsgEnvelope srcspan $
-        DriverUnknownMessage $ UnknownDiagnostic $ mkPlainError noHints $ text msg
-    handler ex = throwGhcExceptionIO ex
-
-    to_driver_messages :: Messages GhcMessage -> Messages DriverMessage
-    to_driver_messages msgs = case traverse to_driver_message msgs of
-      Nothing    -> pprPanic "non-driver message in preprocess"
-                             -- MP: Default config is fine here as it's just in a panic.
-                             (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @GhcMessage) (getMessages msgs))
-      Just msgs' -> msgs'
-
-    to_driver_message = \case
-      GhcDriverMessage msg
-        -> Just msg
-      GhcPsMessage (PsHeaderMessage msg)
-        -> Just (DriverPsHeaderMessage (PsHeaderMessage msg))
-      _ -> Nothing
-
-    pipe_env = mkPipeEnv StopPreprocess input_fn mb_phase (Temporary TFL_GhcSession)
-    mkInputFn  =
-      case mb_input_buf of
-        Just input_buf -> do
-          fn <- newTempName (hsc_logger hsc_env)
-                            (hsc_tmpfs hsc_env)
-                            (tmpDir (hsc_dflags hsc_env))
-                            TFL_CurrentModule
-                            ("buf_" ++ src_suffix pipe_env)
-          hdl <- openBinaryFile fn WriteMode
-          -- Add a LINE pragma so reported source locations will
-          -- mention the real input file, not this temp file.
-          hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}"
-          hPutStringBuffer hdl input_buf
-          hClose hdl
-          return fn
-        Nothing -> return input_fn
-
--- ---------------------------------------------------------------------------
-
--- | Compile
---
--- Compile a single module, under the control of the compilation manager.
---
--- This is the interface between the compilation manager and the
--- compiler proper (hsc), where we deal with tedious details like
--- reading the OPTIONS pragma from the source file, converting the
--- C or assembly that GHC produces into an object file, and compiling
--- FFI stub files.
---
--- NB.  No old interface can also mean that the source has changed.
-
-
-compileOne :: HscEnv
-           -> ModSummary      -- ^ summary for module being compiled
-           -> Int             -- ^ module N ...
-           -> Int             -- ^ ... of M
-           -> Maybe ModIface  -- ^ old interface, if we have one
-           -> HomeModLinkable  -- ^ old linkable, if we have one
-           -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful
-
-compileOne = compileOne' (Just batchMsg)
-
-compileOne' :: Maybe Messager
-            -> HscEnv
-            -> ModSummary      -- ^ summary for module being compiled
-            -> Int             -- ^ module N ...
-            -> Int             -- ^ ... of M
-            -> Maybe ModIface  -- ^ old interface, if we have one
-            -> HomeModLinkable
-            -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful
-
-compileOne' mHscMessage
-            hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable
- = do
-
-   debugTraceMsg logger 2 (text "compile: input file" <+> text input_fnpp)
-
-   unless (gopt Opt_KeepHiFiles lcl_dflags) $
-             addFilesToClean tmpfs TFL_CurrentModule $
-                 [ml_hi_file $ ms_location summary]
-   unless (gopt Opt_KeepOFiles lcl_dflags) $
-             addFilesToClean tmpfs TFL_GhcSession $
-                 [ml_obj_file $ ms_location summary]
-
-   plugin_hsc_env <- initializePlugins hsc_env
-   let pipe_env = mkPipeEnv NoStop input_fn Nothing pipelineOutput
-   status <- hscRecompStatus mHscMessage plugin_hsc_env upd_summary
-                mb_old_iface mb_old_linkable (mod_index, nmods)
-   let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status)
-   (iface, linkable) <- runPipeline (hsc_hooks hsc_env) pipeline
-   -- See Note [ModDetails and --make mode]
-   details <- initModDetails plugin_hsc_env iface
-   linkable' <- traverse (initWholeCoreBindings plugin_hsc_env iface details) (homeMod_bytecode linkable)
-   return $! HomeModInfo iface details (linkable { homeMod_bytecode = linkable' })
-
- where lcl_dflags  = ms_hspp_opts summary
-       location    = ms_location summary
-       input_fn    = expectJust "compile:hs" (ml_hs_file location)
-       input_fnpp  = ms_hspp_file summary
-
-       pipelineOutput = backendPipelineOutput bcknd
-
-       logger = hsc_logger hsc_env0
-       tmpfs  = hsc_tmpfs hsc_env0
-
-       basename = dropExtension input_fn
-
-       -- We add the directory in which the .hs files resides) to the import
-       -- path.  This is needed when we try to compile the .hc file later, if it
-       -- imports a _stub.h file that we created here.
-       current_dir = takeDirectory basename
-       old_paths   = includePaths lcl_dflags
-       loadAsByteCode
-         | Just Target { targetAllowObjCode = obj } <- findTarget summary (hsc_targets hsc_env0)
-         , not obj
-         = True
-         | otherwise = False
-       -- Figure out which backend we're using
-       (bcknd, dflags3)
-         -- #8042: When module was loaded with `*` prefix in ghci, but DynFlags
-         -- suggest to generate object code (which may happen in case -fobject-code
-         -- was set), force it to generate byte-code. This is NOT transitive and
-         -- only applies to direct targets.
-         | loadAsByteCode
-         = ( interpreterBackend
-           , gopt_set (lcl_dflags { backend = interpreterBackend }) Opt_ForceRecomp
-           )
-
-         | otherwise
-         = (backend dflags, lcl_dflags)
-       -- See Note [Filepaths and Multiple Home Units]
-       dflags  = dflags3 { includePaths = offsetIncludePaths dflags3 $ addImplicitQuoteInclude old_paths [current_dir] }
-       upd_summary = summary { ms_hspp_opts = dflags }
-       hsc_env = hscSetFlags dflags hsc_env0
-
-
--- ---------------------------------------------------------------------------
--- Link
---
--- Note [Dynamic linking on macOS]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Since macOS Sierra (10.14), the dynamic system linker enforces
--- a limit on the Load Commands.  Specifically the Load Command Size
--- Limit is at 32K (32768).  The Load Commands contain the install
--- name, dependencies, runpaths, and a few other commands.  We however
--- only have control over the install name, dependencies and runpaths.
---
--- The install name is the name by which this library will be
--- referenced.  This is such that we do not need to bake in the full
--- absolute location of the library, and can move the library around.
---
--- The dependency commands contain the install names from of referenced
--- libraries.  Thus if a libraries install name is @rpath/libHS...dylib,
--- that will end up as the dependency.
---
--- Finally we have the runpaths, which informs the linker about the
--- directories to search for the referenced dependencies.
---
--- The system linker can do recursive linking, however using only the
--- direct dependencies conflicts with ghc's ability to inline across
--- packages, and as such would end up with unresolved symbols.
---
--- Thus we will pass the full dependency closure to the linker, and then
--- ask the linker to remove any unused dynamic libraries (-dead_strip_dylibs).
---
--- We still need to add the relevant runpaths, for the dynamic linker to
--- lookup the referenced libraries though.  The linker (ld64) does not
--- have any option to dead strip runpaths; which makes sense as runpaths
--- can be used for dependencies of dependencies as well.
---
--- The solution we then take in GHC is to not pass any runpaths to the
--- linker at link time, but inject them after the linking.  For this to
--- work we'll need to ask the linker to create enough space in the header
--- to add more runpaths after the linking (-headerpad 8000).
---
--- After the library has been linked by $LD (usually ld64), we will use
--- otool to inspect the libraries left over after dead stripping, compute
--- the relevant runpaths, and inject them into the linked product using
--- the install_name_tool command.
---
--- This strategy should produce the smallest possible set of load commands
--- while still retaining some form of relocatability via runpaths.
---
--- The only way I can see to reduce the load command size further would be
--- by shortening the library names, or start putting libraries into the same
--- folders, such that one runpath would be sufficient for multiple/all
--- libraries.
-link :: GhcLink                 -- ^ interactive or batch
-     -> Logger                  -- ^ Logger
-     -> TmpFs
-     -> Hooks
-     -> DynFlags                -- ^ dynamic flags
-     -> UnitEnv                 -- ^ unit environment
-     -> Bool                    -- ^ attempt linking in batch mode?
-     -> Maybe (RecompileRequired -> IO ())
-     -> HomePackageTable        -- ^ what to link
-     -> IO SuccessFlag
-
--- For the moment, in the batch linker, we don't bother to tell doLink
--- which packages to link -- it just tries all that are available.
--- batch_attempt_linking should only be *looked at* in batch mode.  It
--- should only be True if the upsweep was successful and someone
--- exports main, i.e., we have good reason to believe that linking
--- will succeed.
-
-link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking mHscMessage hpt =
-  case linkHook hooks of
-      Nothing -> case ghcLink of
-        NoLink        -> return Succeeded
-        LinkBinary    -> normal_link
-        LinkStaticLib -> normal_link
-        LinkDynLib    -> normal_link
-        LinkMergedObj -> normal_link
-        LinkInMemory
-          | platformMisc_ghcWithInterpreter $ platformMisc dflags
-           -- Not Linking...(demand linker will do the job)
-            -> return Succeeded
-          | otherwise
-            -> panicBadLink LinkInMemory
-      Just h  -> h ghcLink dflags batch_attempt_linking hpt
-  where
-    normal_link = link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessage hpt
-
-
-panicBadLink :: GhcLink -> a
-panicBadLink other = panic ("link: GHC not built to link this way: " ++
-                            show other)
-
-link' :: Logger
-      -> TmpFs
-      -> DynFlags                -- ^ dynamic flags
-      -> UnitEnv                 -- ^ unit environment
-      -> Bool                    -- ^ attempt linking in batch mode?
-      -> Maybe (RecompileRequired -> IO ())
-      -> HomePackageTable        -- ^ what to link
-      -> IO SuccessFlag
-
-link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt
-   | batch_attempt_linking
-   = do
-        let
-            staticLink = case ghcLink dflags of
-                          LinkStaticLib -> True
-                          _ -> False
-
-            home_mod_infos = eltsHpt hpt
-
-            -- the packages we depend on
-            pkg_deps  = Set.toList
-                          $ Set.unions
-                          $ fmap (dep_direct_pkgs . mi_deps . hm_iface)
-                          $ home_mod_infos
-
-            -- the linkables to link
-            linkables = map (expectJust "link". homeModInfoObject) home_mod_infos
-
-        debugTraceMsg logger 3 (text "link: hmi ..." $$ vcat (map (ppr . mi_module . hm_iface) home_mod_infos))
-        debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
-        debugTraceMsg logger 3 (text "link: pkg deps are ..." $$ vcat (map ppr pkg_deps))
-
-        -- check for the -no-link flag
-        if isNoLink (ghcLink dflags)
-          then do debugTraceMsg logger 3 (text "link(batch): linking omitted (-c flag given).")
-                  return Succeeded
-          else do
-
-        let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked)
-            obj_files = concatMap getOfiles linkables
-            platform  = targetPlatform dflags
-            arch_os   = platformArchOS platform
-            exe_file  = exeFileName arch_os staticLink (outputFile_ dflags)
-
-        linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps
-
-        forM_ mHscMessager $ \hscMessage -> hscMessage linking_needed
-        if not (gopt Opt_ForceRecomp dflags) && (linking_needed == UpToDate)
-           then do debugTraceMsg logger 2 (text exe_file <+> text "is up to date, linking not required.")
-                   return Succeeded
-           else do
-
-
-        -- Don't showPass in Batch mode; doLink will do that for us.
-        case ghcLink dflags of
-          LinkBinary
-            | backendUseJSLinker (backend dflags) -> linkJSBinary logger dflags unit_env obj_files pkg_deps
-            | otherwise -> linkBinary logger tmpfs dflags unit_env obj_files pkg_deps
-          LinkStaticLib -> linkStaticLib logger dflags unit_env obj_files pkg_deps
-          LinkDynLib    -> linkDynLibCheck logger tmpfs dflags unit_env obj_files pkg_deps
-          other         -> panicBadLink other
-
-        debugTraceMsg logger 3 (text "link: done")
-
-        -- linkBinary only returns if it succeeds
-        return Succeeded
-
-   | otherwise
-   = do debugTraceMsg logger 3 (text "link(batch): upsweep (partially) failed OR" $$
-                                text "   Main.main not exported; not linking.")
-        return Succeeded
-
-
-linkJSBinary :: Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
-linkJSBinary logger dflags unit_env obj_files pkg_deps = do
-  -- we use the default configuration for now. In the future we may expose
-  -- settings to the user via DynFlags.
-  let lc_cfg   = defaultJSLinkConfig
-  let cfg      = initStgToJSConfig dflags
-  let extra_js = mempty
-  jsLinkBinary lc_cfg cfg extra_js logger dflags unit_env obj_files pkg_deps
-
-linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO RecompileRequired
-linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do
-        -- if the modification time on the executable is later than the
-        -- modification times on all of the objects and libraries, then omit
-        -- linking (unless the -fforce-recomp flag was given).
-  let platform   = ue_platform unit_env
-      unit_state = ue_units unit_env
-      arch_os    = platformArchOS platform
-      exe_file   = exeFileName arch_os staticLink (outputFile_ dflags)
-  e_exe_time <- tryIO $ getModificationUTCTime exe_file
-  case e_exe_time of
-    Left _  -> return $ NeedsRecompile MustCompile
-    Right t -> do
-        -- first check object files and extra_ld_inputs
-        let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
-        e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs
-        let (errs,extra_times) = partitionEithers e_extra_times
-        let obj_times =  map linkableTime linkables ++ extra_times
-        if not (null errs) || any (t <) obj_times
-            then return $ needsRecompileBecause ObjectsChanged
-            else do
-
-        -- next, check libraries. XXX this only checks Haskell libraries,
-        -- not extra_libraries or -l things from the command line.
-        let pkg_hslibs  = [ (collectLibraryDirs (ways dflags) [c], lib)
-                          | Just c <- map (lookupUnitId unit_state) pkg_deps,
-                            lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ]
-
-        pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs
-        if any isNothing pkg_libfiles then return $ needsRecompileBecause LibraryChanged else do
-        e_lib_times <- mapM (tryIO . getModificationUTCTime)
-                          (catMaybes pkg_libfiles)
-        let (lib_errs,lib_times) = partitionEithers e_lib_times
-        if not (null lib_errs) || any (t <) lib_times
-           then return $ needsRecompileBecause LibraryChanged
-           else do
-            res <- checkLinkInfo logger dflags unit_env pkg_deps exe_file
-            if res
-              then return $ needsRecompileBecause FlagsChanged
-              else return UpToDate
-
-
-findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath)
-findHSLib platform ws dirs lib = do
-  let batch_lib_file = if ws `hasNotWay` WayDyn
-                      then "lib" ++ lib <.> "a"
-                      else platformSOName platform lib
-  found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
-  case found of
-    [] -> return Nothing
-    (x:_) -> return (Just x)
-
--- -----------------------------------------------------------------------------
--- Compile files in one-shot mode.
-
-oneShot :: HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO ()
-oneShot hsc_env stop_phase srcs = do
-  o_files <- mapMaybeM (compileFile hsc_env stop_phase) srcs
-  case stop_phase of
-    StopPreprocess -> return ()
-    StopC  -> return ()
-    StopAs -> return ()
-    NoStop -> doLink hsc_env o_files
-
-compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath)
-compileFile hsc_env stop_phase (src, mb_phase) = do
-   exists <- doesFileExist src
-   when (not exists) $
-        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))
-
-   let
-        dflags    = hsc_dflags hsc_env
-        mb_o_file = outputFile dflags
-        ghc_link  = ghcLink dflags      -- Set by -c or -no-link
-        notStopPreprocess | StopPreprocess <- stop_phase = False
-                          | _              <- stop_phase = True
-        -- When linking, the -o argument refers to the linker's output.
-        -- otherwise, we use it as the name for the pipeline's output.
-        output
-         | not (backendGeneratesCode (backend dflags)), notStopPreprocess = NoOutputFile
-                -- avoid -E -fno-code undesirable interactions. see #20439
-         | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent
-                -- -o foo applies to linker
-         | isJust mb_o_file = SpecificFile
-                -- -o foo applies to the file we are compiling now
-         | otherwise = Persistent
-        pipe_env = mkPipeEnv stop_phase src mb_phase output
-        pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src mb_phase
-   runPipeline (hsc_hooks hsc_env) pipeline
-
-
-doLink :: HscEnv -> [FilePath] -> IO ()
-doLink hsc_env o_files = do
-  let
-    dflags   = hsc_dflags   hsc_env
-    logger   = hsc_logger   hsc_env
-    unit_env = hsc_unit_env hsc_env
-    tmpfs    = hsc_tmpfs    hsc_env
-
-  case ghcLink dflags of
-    NoLink        -> return ()
-    LinkBinary
-      | backendUseJSLinker (backend dflags)
-                  -> linkJSBinary logger dflags unit_env o_files []
-      | otherwise -> linkBinary logger tmpfs dflags unit_env o_files []
-    LinkStaticLib -> linkStaticLib      logger       dflags unit_env o_files []
-    LinkDynLib    -> linkDynLibCheck    logger tmpfs dflags unit_env o_files []
-    LinkMergedObj
-      | Just out <- outputFile dflags
-      , let objs = [ f | FileOption _ f <- ldInputs dflags ]
-                  -> joinObjectFiles hsc_env (o_files ++ objs) out
-      | otherwise -> panic "Output path must be specified for LinkMergedObj"
-    other         -> panicBadLink other
-
------------------------------------------------------------------------------
--- stub .h and .c files (for foreign export support), and cc files.
-
--- The _stub.c file is derived from the haskell source file, possibly taking
--- into account the -stubdir option.
---
--- The object file created by compiling the _stub.c file is put into a
--- temporary file, which will be later combined with the main .o file
--- (see the MergeForeign phase).
---
--- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files
--- from TH, that are then compiled and linked to the module. This is
--- useful to implement facilities such as inline-c.
-
-compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
-compileForeign _ RawObject object_file = return object_file
-compileForeign hsc_env lang stub_c = do
-        let pipeline = case lang of
-              LangC      -> viaCPipeline Cc
-              LangCxx    -> viaCPipeline Ccxx
-              LangObjc   -> viaCPipeline Cobjc
-              LangObjcxx -> viaCPipeline Cobjcxx
-              LangAsm    -> \pe hsc_env ml fp -> asPipeline True pe hsc_env ml fp
-              LangJs     -> \pe hsc_env ml fp -> Just <$> jsPipeline pe hsc_env ml fp
-#if __GLASGOW_HASKELL__ < 811
-              RawObject  -> panic "compileForeign: should be unreachable"
-#endif
-            pipe_env = mkPipeEnv NoStop stub_c Nothing (Temporary TFL_GhcSession)
-        res <- runPipeline (hsc_hooks hsc_env) (pipeline pipe_env hsc_env Nothing stub_c)
-        case res of
-          -- This should never happen as viaCPipeline should only return `Nothing` when the stop phase is `StopC`.
-          -- and the same should never happen for asPipeline
-          -- Future refactoring to not check StopC for this case
-          Nothing -> pprPanic "compileForeign" (text stub_c)
-          Just fp -> return fp
-
-compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
-compileEmptyStub dflags hsc_env basename location mod_name = do
-  -- To maintain the invariant that every Haskell file
-  -- compiles to object code, we make an empty (but
-  -- valid) stub object file for signatures.  However,
-  -- we make sure this object file has a unique symbol,
-  -- so that ranlib on OS X doesn't complain, see
-  -- https://gitlab.haskell.org/ghc/ghc/issues/12673
-  -- and https://github.com/haskell/cabal/issues/2257
-  let logger = hsc_logger hsc_env
-  let tmpfs  = hsc_tmpfs hsc_env
-  let home_unit = hsc_home_unit hsc_env
-
-  case backendCodeOutput (backend dflags) of
-    JSCodeOutput -> do
-      empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js"
-      let src = ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
-      writeFile empty_stub (showSDoc dflags (pprCode src))
-      let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename}
-          pipeline = Just <$> jsPipeline pipe_env hsc_env (Just location) empty_stub
-      _ <- runPipeline (hsc_hooks hsc_env) pipeline
-      pure ()
-
-    _ -> do
-      empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
-      let src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"
-      writeFile empty_stub (showSDoc dflags (pprCode src))
-      let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename}
-          pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub
-      _ <- runPipeline (hsc_hooks hsc_env) pipeline
-      pure ()
-
-
-
-{- Environment Initialisation -}
-
-mkPipeEnv :: StopPhase -- End phase
-          -> FilePath -- input fn
-          -> Maybe Phase
-          -> PipelineOutput -- Output
-          -> PipeEnv
-mkPipeEnv stop_phase  input_fn start_phase output =
-  let (basename, suffix) = splitExtension input_fn
-      suffix' = drop 1 suffix -- strip off the .
-      env = PipeEnv{ stop_phase,
-                     src_filename = input_fn,
-                     src_basename = basename,
-                     src_suffix = suffix',
-                     start_phase = fromMaybe (startPhase suffix') start_phase,
-                     output_spec = output }
-  in env
-
-setDumpPrefix :: PipeEnv -> HscEnv -> HscEnv
-setDumpPrefix pipe_env hsc_env =
-  hscUpdateFlags (\dflags -> dflags { dumpPrefix = src_basename pipe_env ++ "."}) hsc_env
-
-{- The Pipelines -}
-
-phaseIfFlag :: Monad m
-            => HscEnv
-            -> (DynFlags -> Bool)
-            -> a
-            -> m a
-            -> m a
-phaseIfFlag hsc_env flag def action =
-  if flag (hsc_dflags hsc_env)
-    then action
-    else return def
-
--- | Check if the start is *before* the current phase, otherwise skip with a default
-phaseIfAfter :: P m => Platform -> Phase -> Phase -> a -> m a -> m a
-phaseIfAfter platform start_phase cur_phase def action =
-  if start_phase `eqPhase` cur_phase
-         || happensBefore platform start_phase cur_phase
-
-    then action
-    else return def
-
--- | The preprocessor pipeline
-preprocessPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m (DynFlags, FilePath)
-preprocessPipeline pipe_env hsc_env input_fn = do
-  unlit_fn <-
-    runAfter (Unlit HsSrcFile) input_fn $ do
-      use (T_Unlit pipe_env hsc_env input_fn)
-
-
-  (dflags1, p_warns1, warns1) <- use (T_FileArgs hsc_env unlit_fn)
-  let hsc_env1 = hscSetFlags dflags1 hsc_env
-
-  (cpp_fn, hsc_env2)
-    <- runAfterFlag hsc_env1 (Cpp HsSrcFile) (xopt LangExt.Cpp) (unlit_fn, hsc_env1) $ do
-          cpp_fn <- use (T_Cpp pipe_env hsc_env1 unlit_fn)
-          (dflags2, _, _) <- use (T_FileArgs hsc_env1 cpp_fn)
-          let hsc_env2 = hscSetFlags dflags2 hsc_env1
-          return (cpp_fn, hsc_env2)
-
-
-  pp_fn <- runAfterFlag hsc_env2 (HsPp HsSrcFile) (gopt Opt_Pp) cpp_fn $
-            use (T_HsPp pipe_env hsc_env2 input_fn cpp_fn)
-
-  (dflags3, p_warns3, warns3)
-    <- if pp_fn == unlit_fn
-          -- Didn't run any preprocessors so don't need to reparse, would be nicer
-          -- if `T_FileArgs` recognised this.
-          then return (dflags1, p_warns1, warns1)
-          else do
-            -- Reparse with original hsc_env so that we don't get duplicated options
-            use (T_FileArgs hsc_env pp_fn)
-
-  let print_config = initPrintConfig dflags3
-  liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3))
-  liftIO (handleFlagWarnings (hsc_logger hsc_env) print_config (initDiagOpts dflags3) warns3)
-  return (dflags3, pp_fn)
-
-
-  -- This won't change through the compilation pipeline
-  where platform = targetPlatform (hsc_dflags hsc_env)
-        runAfter :: P p => Phase
-                  -> a -> p a -> p a
-        runAfter = phaseIfAfter platform (start_phase pipe_env)
-        runAfterFlag :: P p
-                  => HscEnv
-                  -> Phase
-                  -> (DynFlags -> Bool)
-                  -> a
-                  -> p a
-                  -> p a
-        runAfterFlag hsc_env phase flag def action =
-          runAfter phase def
-           $ phaseIfFlag hsc_env flag def action
-
--- | The complete compilation pipeline, from start to finish
-fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, HomeModLinkable)
-fullPipeline pipe_env hsc_env pp_fn src_flavour = do
-  (dflags, input_fn) <- preprocessPipeline pipe_env hsc_env pp_fn
-  let hsc_env' = hscSetFlags dflags hsc_env
-  (hsc_env_with_plugins, mod_sum, hsc_recomp_status)
-    <- use (T_HscRecomp pipe_env hsc_env' input_fn src_flavour)
-  hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status)
-
--- | Everything after preprocess
-hscPipeline :: P m => PipeEnv ->  ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, HomeModLinkable)
-hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do
-  case hsc_recomp_status of
-    HscUpToDate iface mb_linkable -> return (iface, mb_linkable)
-    HscRecompNeeded mb_old_hash -> do
-      (tc_result, warnings) <- use (T_Hsc hsc_env_with_plugins mod_sum)
-      hscBackendAction <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash )
-      hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum hscBackendAction
-
-hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, HomeModLinkable)
-hscBackendPipeline pipe_env hsc_env mod_sum result =
-  if backendGeneratesCode (backend (hsc_dflags hsc_env)) then
-    do
-      res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result
-      when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env)) $ do
-          let dflags' = setDynamicNow (hsc_dflags hsc_env) -- set "dynamicNow"
-          () <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result
-      return res
-  else
-    case result of
-      HscUpdate iface ->  return (iface, emptyHomeModInfoLinkable)
-      HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing) <*> pure emptyHomeModInfoLinkable
-    -- TODO: Why is there not a linkable?
-    -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing
-
-hscGenBackendPipeline :: P m
-  => PipeEnv
-  -> HscEnv
-  -> ModSummary
-  -> HscBackendAction
-  -> m (ModIface, HomeModLinkable)
-hscGenBackendPipeline pipe_env hsc_env mod_sum result = do
-  let mod_name = moduleName (ms_mod mod_sum)
-      src_flavour = (ms_hsc_src mod_sum)
-  let location = ms_location mod_sum
-  (fos, miface, mlinkable, o_file) <- use (T_HscBackend pipe_env hsc_env mod_name src_flavour location result)
-  final_fp <- hscPostBackendPipeline pipe_env hsc_env (ms_hsc_src mod_sum) (backend (hsc_dflags hsc_env)) (Just location) o_file
-  final_linkable <-
-    case final_fp of
-      -- No object file produced, bytecode or NoBackend
-      Nothing -> return mlinkable
-      Just o_fp -> do
-        unlinked_time <- liftIO (liftIO getCurrentTime)
-        final_unlinked <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)
-        let !linkable = LM unlinked_time (ms_mod mod_sum) [final_unlinked]
-        -- Add the object linkable to the potential bytecode linkable which was generated in HscBackend.
-        return (mlinkable { homeMod_object = Just linkable })
-  return (miface, final_linkable)
-
-asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile)
-asPipeline use_cpp pipe_env hsc_env location input_fn =
-  case stop_phase pipe_env of
-    StopAs -> return Nothing
-    _ -> Just <$> use (T_As use_cpp pipe_env hsc_env location input_fn)
-
-viaCPipeline :: P m => Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
-viaCPipeline c_phase pipe_env hsc_env location input_fn = do
-  out_fn <- use (T_Cc c_phase pipe_env hsc_env location input_fn)
-  case stop_phase pipe_env of
-    StopC -> return Nothing
-    _ -> return $ Just out_fn
-
-llvmPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
-llvmPipeline pipe_env hsc_env location fp = do
-  opt_fn <- use (T_LlvmOpt pipe_env hsc_env fp)
-  llvmLlcPipeline pipe_env hsc_env location opt_fn
-
-llvmLlcPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
-llvmLlcPipeline pipe_env hsc_env location opt_fn = do
-  llc_fn <- use (T_LlvmLlc pipe_env hsc_env opt_fn)
-  llvmManglePipeline pipe_env hsc_env location llc_fn
-
-llvmManglePipeline :: P m  => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
-llvmManglePipeline pipe_env hsc_env location llc_fn = do
-  mangled_fn <-
-    if gopt Opt_NoLlvmMangler (hsc_dflags hsc_env)
-      then return llc_fn
-      else use (T_LlvmMangle pipe_env hsc_env llc_fn)
-  asPipeline False pipe_env hsc_env location mangled_fn
-
-cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath
-cmmCppPipeline pipe_env hsc_env input_fn = do
-  output_fn <- use (T_CmmCpp pipe_env hsc_env input_fn)
-  cmmPipeline pipe_env hsc_env output_fn
-
-cmmPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath
-cmmPipeline pipe_env hsc_env input_fn = do
-  (fos, output_fn) <- use (T_Cmm pipe_env hsc_env input_fn)
-  mo_fn <- hscPostBackendPipeline pipe_env hsc_env HsSrcFile (backend (hsc_dflags hsc_env)) Nothing output_fn
-  case mo_fn of
-    Nothing -> panic "CMM pipeline - produced no .o file"
-    Just mo_fn -> use (T_MergeForeign pipe_env hsc_env mo_fn fos)
-
-jsPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath
-jsPipeline pipe_env hsc_env location input_fn = do
-  use (T_Js pipe_env hsc_env location input_fn)
-
-hscPostBackendPipeline :: P m => PipeEnv -> HscEnv -> HscSource -> Backend -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
-hscPostBackendPipeline _ _ HsBootFile _ _ _   = return Nothing
-hscPostBackendPipeline _ _ HsigFile _ _ _     = return Nothing
-hscPostBackendPipeline pipe_env hsc_env _ bcknd ml input_fn =
-  applyPostHscPipeline (backendPostHscPipeline bcknd) pipe_env hsc_env ml input_fn
-
-applyPostHscPipeline
-    :: TPipelineClass TPhase m
-    => DefunctionalizedPostHscPipeline
-    -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)
-applyPostHscPipeline NcgPostHscPipeline =
-    \pe he ml fp -> asPipeline False pe he ml fp
-applyPostHscPipeline ViaCPostHscPipeline = viaCPipeline HCc
-applyPostHscPipeline LlvmPostHscPipeline =
-    \pe he ml fp -> llvmPipeline pe he ml fp
-applyPostHscPipeline JSPostHscPipeline =
-    \pe he ml fp -> Just <$> jsPipeline pe he ml fp
-applyPostHscPipeline NoPostHscPipeline = \_ _ _ _ -> return Nothing
-
--- Pipeline from a given suffix
-pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> Maybe Phase -> m (Maybe FilePath)
-pipelineStart pipe_env hsc_env input_fn mb_phase =
-  fromPhase (fromMaybe (startPhase $ src_suffix pipe_env)  mb_phase)
-  where
-   stop_after = stop_phase pipe_env
-   frontend :: P m => HscSource -> m (Maybe FilePath)
-   frontend sf = case stop_after of
-                    StopPreprocess -> do
-                      -- The actual output from preprocessing
-                      (_, out_fn) <- preprocessPipeline pipe_env hsc_env input_fn
-                      let logger = hsc_logger hsc_env
-                      -- Sometimes, a compilation phase doesn't actually generate any output
-                      -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
-                      -- stage, but we wanted to keep the output, then we have to explicitly
-                      -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
-                      -- further compilation stages can tell what the original filename was.
-                      -- File name we expected the output to have
-                      final_fn <- liftIO $ phaseOutputFilenameNew (Hsc HsSrcFile) pipe_env hsc_env Nothing
-                      when (final_fn /= out_fn) $ do
-                        let msg = "Copying `" ++ out_fn ++"' to `" ++ final_fn ++ "'"
-                            line_prag = "{-# LINE 1 \"" ++ src_filename pipe_env ++ "\" #-}\n"
-                        liftIO (showPass logger msg)
-                        liftIO (copyWithHeader line_prag out_fn final_fn)
-                      return Nothing
-                    _ -> objFromLinkable <$> fullPipeline pipe_env hsc_env input_fn sf
-   c :: P m => Phase -> m (Maybe FilePath)
-   c phase = viaCPipeline phase pipe_env hsc_env Nothing input_fn
-   as :: P m => Bool -> m (Maybe FilePath)
-   as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn
-
-   objFromLinkable (_, homeMod_object -> Just (LM _ _ [DotO lnk])) = Just lnk
-   objFromLinkable _ = Nothing
-
-   fromPhase :: P m => Phase -> m (Maybe FilePath)
-   fromPhase (Unlit p)  = frontend p
-   fromPhase (Cpp p)    = frontend p
-   fromPhase (HsPp p)   = frontend p
-   fromPhase (Hsc p)    = frontend p
-   fromPhase HCc        = c HCc
-   fromPhase Cc         = c Cc
-   fromPhase Ccxx       = c Ccxx
-   fromPhase Cobjc      = c Cobjc
-   fromPhase Cobjcxx    = c Cobjcxx
-   fromPhase (As p)     = as p
-   fromPhase LlvmOpt    = llvmPipeline pipe_env hsc_env Nothing input_fn
-   fromPhase LlvmLlc    = llvmLlcPipeline pipe_env hsc_env Nothing input_fn
-   fromPhase LlvmMangle = llvmManglePipeline pipe_env hsc_env Nothing input_fn
-   fromPhase StopLn     = return (Just input_fn)
-   fromPhase CmmCpp     = Just <$> cmmCppPipeline pipe_env hsc_env input_fn
-   fromPhase Cmm        = Just <$> cmmPipeline pipe_env hsc_env input_fn
-   fromPhase Js         = Just <$> jsPipeline pipe_env hsc_env Nothing input_fn
-   fromPhase MergeForeign = panic "fromPhase: MergeForeign"
-
-{-
-Note [The Pipeline Monad]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-The pipeline is represented as a free monad by the `TPipelineClass` type synonym,
-which stipulates the general monadic interface for the pipeline and `MonadUse`, instantiated
-to `TPhase`, which indicates the actions available in the pipeline.
-
-The `TPhase` actions correspond to different compiled phases, they are executed by
-the 'runPhase' function which interprets each action into IO.
-
-The idea in the future is that we can now implement different instiations of
-`TPipelineClass` to give different behaviours that the default `HookedPhase` implementation:
-
-* Additional logging of different phases
-* Automatic parallelism (in the style of shake)
-* Easy consumption by external tools such as ghcide
-* Easier to create your own pipeline and extend existing pipelines.
-
-The structure of the code as a free monad also means that the return type of each
-phase is a lot more flexible.
-
--}
diff --git a/compiler/GHC/Driver/Pipeline.hs-boot b/compiler/GHC/Driver/Pipeline.hs-boot
deleted file mode 100644
--- a/compiler/GHC/Driver/Pipeline.hs-boot
+++ /dev/null
@@ -1,14 +0,0 @@
-module GHC.Driver.Pipeline where
-
-
-import GHC.Driver.Env.Types ( HscEnv )
-import GHC.ForeignSrcLang ( ForeignSrcLang )
-import GHC.Prelude (FilePath, IO)
-import GHC.Unit.Module.Location (ModLocation)
-import GHC.Driver.Session (DynFlags)
-
-import Language.Haskell.Syntax.Module.Name
-
--- These are used in GHC.Driver.Pipeline.Execute, but defined in terms of runPipeline
-compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
-compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ /dev/null
@@ -1,1304 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE GADTs #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-#include <ghcplatform.h>
-
-{- Functions for providing the default interpretation of the 'TPhase' actions
--}
-module GHC.Driver.Pipeline.Execute where
-
-import GHC.Prelude
-import Control.Monad
-import Control.Monad.IO.Class
-import Control.Monad.Catch
-import GHC.Driver.Hooks
-import Control.Monad.Trans.Reader
-import GHC.Driver.Pipeline.Monad
-import GHC.Driver.Pipeline.Phases
-import GHC.Driver.Env hiding (Hsc)
-import GHC.Unit.Module.Location
-import GHC.Driver.Phases
-import GHC.Unit.Types
-import GHC.Types.SourceFile
-import GHC.Unit.Module.Status
-import GHC.Unit.Module.ModIface
-import GHC.Driver.Backend
-import GHC.Driver.Session
-import GHC.Driver.CmdLine
-import GHC.Unit.Module.ModSummary
-import qualified GHC.LanguageExtensions as LangExt
-import GHC.Types.SrcLoc
-import GHC.Driver.Main
-import GHC.Tc.Types
-import GHC.Types.Error
-import GHC.Driver.Errors.Types
-import GHC.Fingerprint
-import GHC.Utils.Logger
-import GHC.Utils.TmpFs
-import GHC.Platform
-import Data.List (intercalate, isInfixOf)
-import GHC.Unit.Env
-import GHC.Utils.Error
-import Data.Maybe
-import GHC.CmmToLlvm.Mangler
-import GHC.SysTools
-import GHC.SysTools.Cpp
-import GHC.Utils.Panic.Plain
-import System.Directory
-import System.FilePath
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Unit.Info
-import GHC.Unit.State
-import GHC.Unit.Home
-import GHC.Data.Maybe
-import GHC.Iface.Make
-import GHC.Driver.Config.Parser
-import GHC.Parser.Header
-import GHC.Data.StringBuffer
-import GHC.Types.SourceError
-import GHC.Unit.Finder
-import GHC.Runtime.Loader
-import Data.IORef
-import GHC.Types.Name.Env
-import GHC.Platform.Ways
-import GHC.Driver.LlvmConfigCache (readLlvmConfigCache)
-import GHC.CmmToLlvm.Config (LlvmTarget (..), LlvmConfig (..))
-import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub)
-import GHC.Settings
-import System.IO
-import GHC.Linker.ExtraObj
-import GHC.Linker.Dynamic
-import GHC.Utils.Panic
-import GHC.Unit.Module.Env
-import GHC.Driver.Env.KnotVars
-import GHC.Driver.Config.Finder
-import GHC.Rename.Names
-import GHC.StgToJS.Linker.Linker (embedJsFile)
-
-import Language.Haskell.Syntax.Module.Name
-import GHC.Unit.Home.ModInfo
-
-newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a }
-  deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO)
-
-instance MonadUse TPhase HookedUse where
-  use fa = HookedUse $ \(hooks, (PhaseHook k)) ->
-    case runPhaseHook hooks of
-      Nothing -> k fa
-      Just (PhaseHook h) -> h fa
-
--- | The default mechanism to run a pipeline, see Note [The Pipeline Monad]
-runPipeline :: Hooks -> HookedUse a -> IO a
-runPipeline hooks pipeline = runHookedUse pipeline (hooks, PhaseHook runPhase)
-
--- | Default interpretation of each phase, in terms of IO.
-runPhase :: TPhase out -> IO out
-runPhase (T_Unlit pipe_env hsc_env inp_path) = do
-  out_path <- phaseOutputFilenameNew (Cpp HsSrcFile) pipe_env hsc_env Nothing
-  runUnlitPhase hsc_env inp_path out_path
-runPhase (T_FileArgs hsc_env inp_path) = getFileArgs hsc_env inp_path
-runPhase (T_Cpp pipe_env hsc_env inp_path) = do
-  out_path <- phaseOutputFilenameNew (HsPp HsSrcFile) pipe_env hsc_env Nothing
-  runCppPhase hsc_env inp_path out_path
-runPhase (T_HsPp pipe_env hsc_env origin_path inp_path) = do
-  out_path <- phaseOutputFilenameNew (Hsc HsSrcFile) pipe_env hsc_env Nothing
-  runHsPpPhase hsc_env origin_path inp_path out_path
-runPhase (T_HscRecomp pipe_env hsc_env fp hsc_src) = do
-  runHscPhase pipe_env hsc_env fp hsc_src
-runPhase (T_Hsc hsc_env mod_sum) = runHscTcPhase hsc_env mod_sum
-runPhase (T_HscPostTc hsc_env ms fer m mfi) =
-  runHscPostTcPhase hsc_env ms fer m mfi
-runPhase (T_HscBackend pipe_env hsc_env mod_name hsc_src location x) = do
-  runHscBackendPhase pipe_env hsc_env mod_name hsc_src location x
-runPhase (T_CmmCpp pipe_env hsc_env input_fn) = do
-  output_fn <- phaseOutputFilenameNew Cmm pipe_env hsc_env Nothing
-  doCpp (hsc_logger hsc_env)
-        (hsc_tmpfs hsc_env)
-        (hsc_dflags hsc_env)
-        (hsc_unit_env hsc_env)
-        (CppOpts
-          { cppUseCc       = True
-          , cppLinePragmas = True
-          })
-        input_fn output_fn
-  return output_fn
-runPhase (T_Js pipe_env hsc_env _mb_location js_src) = runJsPhase pipe_env hsc_env js_src
-runPhase (T_Cmm pipe_env hsc_env input_fn) = do
-  let dflags = hsc_dflags hsc_env
-  let next_phase = hscPostBackendPhase HsSrcFile (backend dflags)
-  output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing
-  mstub <- hscCompileCmmFile hsc_env (src_filename pipe_env) input_fn output_fn
-  stub_o <- mapM (compileStub hsc_env) mstub
-  let foreign_os = maybeToList stub_o
-  return (foreign_os, output_fn)
-
-runPhase (T_Cc phase pipe_env hsc_env location input_fn) = runCcPhase phase pipe_env hsc_env location input_fn
-runPhase (T_As cpp pipe_env hsc_env location input_fn) = do
-  runAsPhase cpp pipe_env hsc_env location input_fn
-runPhase (T_LlvmOpt pipe_env hsc_env input_fn) =
-  runLlvmOptPhase pipe_env hsc_env input_fn
-runPhase (T_LlvmLlc pipe_env hsc_env input_fn) =
-  runLlvmLlcPhase pipe_env hsc_env input_fn
-runPhase (T_LlvmMangle pipe_env hsc_env input_fn) =
-  runLlvmManglePhase pipe_env hsc_env input_fn
-runPhase (T_MergeForeign pipe_env hsc_env input_fn fos) =
-  runMergeForeign pipe_env hsc_env input_fn fos
-
-runLlvmManglePhase :: PipeEnv -> HscEnv -> FilePath -> IO [Char]
-runLlvmManglePhase pipe_env hsc_env input_fn = do
-      let next_phase = As False
-      output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing
-      let dflags = hsc_dflags hsc_env
-      llvmFixupAsm (targetPlatform dflags) input_fn output_fn
-      return output_fn
-
-runMergeForeign :: PipeEnv -> HscEnv -> FilePath -> [FilePath] -> IO FilePath
-runMergeForeign _pipe_env hsc_env input_fn foreign_os = do
-     if null foreign_os
-       then return input_fn
-       else do
-         -- Work around a binutil < 2.31 bug where you can't merge objects if the output file
-         -- is one of the inputs
-         new_o <- newTempName (hsc_logger hsc_env)
-                              (hsc_tmpfs hsc_env)
-                              (tmpDir (hsc_dflags hsc_env))
-                              TFL_CurrentModule "o"
-         copyFile input_fn new_o
-         joinObjectFiles hsc_env (new_o : foreign_os) input_fn
-         return input_fn
-
-runLlvmLlcPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath
-runLlvmLlcPhase pipe_env hsc_env input_fn = do
-    -- Note [Clamping of llc optimizations]
-    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-    -- See #13724
-    --
-    -- we clamp the llc optimization between [1,2]. This is because passing -O0
-    -- to llc 3.9 or llc 4.0, the naive register allocator can fail with
-    --
-    --   Error while trying to spill R1 from class GPR: Cannot scavenge register
-    --   without an emergency spill slot!
-    --
-    -- Observed at least with target 'arm-unknown-linux-gnueabihf'.
-    --
-    --
-    -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile
-    --   rts/HeapStackCheck.cmm
-    --
-    -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s
-    -- 0  llc                      0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40
-    -- 1  llc                      0x0000000102ae69a6 SignalHandler(int) + 358
-    -- 2  libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26
-    -- 3  libsystem_c.dylib        0x00007fffc226498b __vfprintf + 17876
-    -- 4  llc                      0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699
-    -- 5  llc                      0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381
-    -- 6  llc                      0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457
-    -- 7  llc                      0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20
-    -- 8  llc                      0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134
-    -- 9  llc                      0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498
-    -- 10 llc                      0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67
-    -- 11 llc                      0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920
-    -- 12 llc                      0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133
-    -- 13 llc                      0x000000010195bf0b main + 491
-    -- 14 libdyld.dylib            0x00007fffc21e5235 start + 1
-    -- Stack dump:
-    -- 0.  Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s
-    -- 1.  Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'.
-    -- 2.  Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"'
-    --
-    -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa
-    --
-    llvm_config <- readLlvmConfigCache (hsc_llvm_config hsc_env)
-    let dflags = hsc_dflags hsc_env
-        logger = hsc_logger hsc_env
-        llvmOpts = case llvmOptLevel dflags of
-          0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.
-          1 -> "-O1"
-          _ -> "-O2"
-
-        defaultOptions = map GHC.SysTools.Option . concatMap words . snd
-                         $ unzip (llvmOptions llvm_config dflags)
-        optFlag = if null (getOpts dflags opt_lc)
-                  then map GHC.SysTools.Option $ words llvmOpts
-                  else []
-
-    next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling
-                     | gopt Opt_NoLlvmMangler dflags -> return (As False)
-                     | otherwise -> return LlvmMangle
-
-    output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing
-
-    GHC.SysTools.runLlvmLlc logger dflags
-                (  optFlag
-                ++ defaultOptions
-                ++ [ GHC.SysTools.FileOption "" input_fn
-                   , GHC.SysTools.Option "-o"
-                   , GHC.SysTools.FileOption "" output_fn
-                   ]
-                )
-
-    return output_fn
-
-runLlvmOptPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath
-runLlvmOptPhase pipe_env hsc_env input_fn = do
-    let dflags = hsc_dflags hsc_env
-        logger = hsc_logger hsc_env
-    llvm_config <- readLlvmConfigCache (hsc_llvm_config hsc_env)
-    let -- we always (unless -optlo specified) run Opt since we rely on it to
-        -- fix up some pretty big deficiencies in the code we generate
-        optIdx = max 0 $ min 2 $ llvmOptLevel dflags  -- ensure we're in [0,2]
-        llvmOpts = case lookup optIdx $ llvmPasses llvm_config of
-                    Just passes -> passes
-                    Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "
-                                      ++ "is missing passes for level "
-                                      ++ show optIdx)
-        defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst
-                         $ unzip (llvmOptions llvm_config dflags)
-
-        -- don't specify anything if user has specified commands. We do this
-        -- for opt but not llc since opt is very specifically for optimisation
-        -- passes only, so if the user is passing us extra options we assume
-        -- they know what they are doing and don't get in the way.
-        optFlag = if null (getOpts dflags opt_lo)
-                  then map GHC.SysTools.Option $ words llvmOpts
-                  else []
-
-    output_fn <- phaseOutputFilenameNew LlvmLlc pipe_env hsc_env Nothing
-
-    GHC.SysTools.runLlvmOpt logger dflags
-               (   optFlag
-                ++ defaultOptions ++
-                [ GHC.SysTools.FileOption "" input_fn
-                , GHC.SysTools.Option "-o"
-                , GHC.SysTools.FileOption "" output_fn]
-                )
-
-    return output_fn
-
-
-runAsPhase :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath
-runAsPhase with_cpp pipe_env hsc_env location input_fn = do
-        let dflags     = hsc_dflags   hsc_env
-        let logger     = hsc_logger   hsc_env
-        let unit_env   = hsc_unit_env hsc_env
-        let platform   = ue_platform unit_env
-
-        -- LLVM from version 3.0 onwards doesn't support the OS X system
-        -- assembler, so we use clang as the assembler instead. (#5636)
-        let (as_prog, get_asm_info) =
-                ( applyAssemblerProg $ backendAssemblerProg (backend dflags)
-                , applyAssemblerInfoGetter $ backendAssemblerInfoGetter (backend dflags)
-                )
-        asmInfo <- get_asm_info logger dflags platform
-
-        let cmdline_include_paths = includePaths dflags
-        let pic_c_flags = picCCOpts dflags
-
-        output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env location
-
-        -- we create directories for the object file, because it
-        -- might be a hierarchical module.
-        createDirectoryIfMissing True (takeDirectory output_fn)
-
-        let global_includes = [ GHC.SysTools.Option ("-I" ++ p)
-                              | p <- includePathsGlobal cmdline_include_paths ]
-        let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)
-                             | p <- includePathsQuote cmdline_include_paths ++
-                                includePathsQuoteImplicit cmdline_include_paths]
-        let runAssembler inputFilename outputFilename
-              = withAtomicRename outputFilename $ \temp_outputFilename ->
-                    as_prog
-                       logger dflags
-                       platform
-                       (local_includes ++ global_includes
-                       -- See Note [-fPIC for assembler]
-                       ++ map GHC.SysTools.Option pic_c_flags
-                       -- See Note [Produce big objects on Windows]
-                       ++ [ GHC.SysTools.Option "-Wa,-mbig-obj"
-                          | platformOS (targetPlatform dflags) == OSMinGW32
-                          , not $ target32Bit (targetPlatform dflags)
-                          ]
-
-                       -- See Note [-Wa,--no-type-check on wasm32]
-                       ++ [ GHC.SysTools.Option "-Wa,--no-type-check"
-                          | platformArch (targetPlatform dflags) == ArchWasm32]
-
-                       ++ (if any (asmInfo ==) [Clang, AppleClang, AppleClang51]
-                            then [GHC.SysTools.Option "-Qunused-arguments"]
-                            else [])
-                       ++ [ GHC.SysTools.Option "-x"
-                          , if with_cpp
-                              then GHC.SysTools.Option "assembler-with-cpp"
-                              else GHC.SysTools.Option "assembler"
-                          , GHC.SysTools.Option "-c"
-                          , GHC.SysTools.FileOption "" inputFilename
-                          , GHC.SysTools.Option "-o"
-                          , GHC.SysTools.FileOption "" temp_outputFilename
-                          ])
-
-        debugTraceMsg logger 4 (text "Running the assembler")
-        runAssembler input_fn output_fn
-
-        return output_fn
-
-
--- Note [JS Backend .o file procedure]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- The JS backend breaks some of the assumptions on file generation order
--- because it directly produces .o files. This violation breaks some of the
--- assumptions on file timestamps, particularly in the postHsc phase. The
--- postHsc phase for the JS backend is performed in 'runJsPhase'. Consider
--- what the NCG does:
---
--- With other NCG backends we have the following order:
--- 1. The backend produces a .s file
--- 2. Then we write the interface file, .hi
--- 3. Then we generate a .o file in a postHsc phase (calling the asm phase etc.)
---
--- For the JS Backend this order is different
--- 1. The JS Backend _directly_ produces .o files
--- 2. Then we write the interface file. Notice that this breaks the ordering
--- of .hi > .o (step 2 and step 3 in the NCG above).
---
--- This violation results in timestamp checks which pass on the NCG but fail
--- in the JS backend. In particular, checks that compare 'ms_obj_date', and
--- 'ms_iface_date' in 'GHC.Unit.Module.ModSummary'.
---
--- Thus to fix this ordering we touch the object files we generated earlier
--- to ensure these timestamps abide by the proper ordering.
-
--- | Run the JS Backend postHsc phase.
-runJsPhase :: PipeEnv -> HscEnv -> FilePath -> IO FilePath
-runJsPhase pipe_env hsc_env input_fn = do
-  let dflags     = hsc_dflags   hsc_env
-  let logger     = hsc_logger   hsc_env
-  let tmpfs      = hsc_tmpfs    hsc_env
-  let unit_env   = hsc_unit_env hsc_env
-
-  output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env Nothing
-
-  -- if the input filename is the same as the output, then we've probably
-  -- generated the object ourselves. In this case, we touch the object file to
-  -- ensure the timestamp is refreshed, see Note [JS Backend .o file procedure]. If
-  -- they are not the same then we embed the .js file into a .o file with the
-  -- addition of a header
-  if (input_fn /= output_fn)
-    then embedJsFile logger dflags tmpfs unit_env input_fn output_fn
-    else touchObjectFile logger dflags output_fn
-
-  return output_fn
-
-
-applyAssemblerInfoGetter
-    :: DefunctionalizedAssemblerInfoGetter
-    -> Logger -> DynFlags -> Platform -> IO CompilerInfo
-applyAssemblerInfoGetter StandardAssemblerInfoGetter logger dflags _platform =
-    getAssemblerInfo logger dflags
-applyAssemblerInfoGetter JSAssemblerInfoGetter _ _ _ =
-    pure Emscripten
-applyAssemblerInfoGetter DarwinClangAssemblerInfoGetter logger dflags platform =
-    if platformOS platform == OSDarwin then
-        pure Clang
-    else
-        getAssemblerInfo logger dflags
-
-applyAssemblerProg
-    :: DefunctionalizedAssemblerProg
-    -> Logger -> DynFlags -> Platform -> [Option] -> IO ()
-applyAssemblerProg StandardAssemblerProg logger dflags _platform =
-    runAs logger dflags
-applyAssemblerProg JSAssemblerProg logger dflags _platform =
-    runEmscripten logger dflags
-applyAssemblerProg DarwinClangAssemblerProg logger dflags platform =
-    if platformOS platform == OSDarwin then
-        runClang logger dflags
-    else
-        runAs logger dflags
-
-
-
-runCcPhase :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath
-runCcPhase cc_phase pipe_env hsc_env location input_fn = do
-  let dflags    = hsc_dflags hsc_env
-  let logger    = hsc_logger hsc_env
-  let unit_env  = hsc_unit_env hsc_env
-  let home_unit = hsc_home_unit hsc_env
-  let tmpfs     = hsc_tmpfs hsc_env
-  let platform  = ue_platform unit_env
-  let hcc       = cc_phase `eqPhase` HCc
-
-  let cmdline_include_paths =  offsetIncludePaths dflags (includePaths dflags)
-
-  -- HC files have the dependent packages stamped into them
-  pkgs <- if hcc then getHCFilePackages input_fn else return []
-
-  -- add package include paths even if we're just compiling .c
-  -- files; this is the Value Add(TM) that using ghc instead of
-  -- gcc gives you :)
-  ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env pkgs)
-  let pkg_include_dirs     = collectIncludeDirs ps
-  let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
-        (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
-  let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
-        (includePathsQuote cmdline_include_paths ++
-         includePathsQuoteImplicit cmdline_include_paths)
-  let include_paths = include_paths_quote ++ include_paths_global
-
-  -- pass -D or -optP to preprocessor when compiling foreign C files
-  -- (#16737). Doing it in this way is simpler and also enable the C
-  -- compiler to perform preprocessing and parsing in a single pass,
-  -- but it may introduce inconsistency if a different pgm_P is specified.
-  let opts = getOpts dflags opt_P
-      aug_imports = augmentImports dflags opts
-
-      more_preprocessor_opts = concat
-        [ ["-Xpreprocessor", i]
-        | not hcc
-        , i <- aug_imports
-        ]
-
-  let gcc_extra_viac_flags = extraGccViaCFlags dflags
-  let pic_c_flags = picCCOpts dflags
-
-  let verbFlags = getVerbFlags dflags
-
-  -- cc-options are not passed when compiling .hc files.  Our
-  -- hc code doesn't not #include any header files anyway, so these
-  -- options aren't necessary.
-  let pkg_extra_cc_opts
-          | hcc       = []
-          | otherwise = collectExtraCcOpts ps
-
-  let framework_paths
-          | platformUsesFrameworks platform
-          = let pkgFrameworkPaths     = collectFrameworksDirs ps
-                cmdlineFrameworkPaths = frameworkPaths dflags
-            in map ("-F"++) (cmdlineFrameworkPaths ++ pkgFrameworkPaths)
-          | otherwise
-          = []
-
-  let cc_opt | llvmOptLevel dflags >= 2 = [ "-O2" ]
-             | llvmOptLevel dflags >= 1 = [ "-O" ]
-             | otherwise            = []
-
-  output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env location
-
-  -- we create directories for the object file, because it
-  -- might be a hierarchical module.
-  createDirectoryIfMissing True (takeDirectory output_fn)
-
-  let
-    more_hcc_opts =
-          -- on x86 the floating point regs have greater precision
-          -- than a double, which leads to unpredictable results.
-          -- By default, we turn this off with -ffloat-store unless
-          -- the user specified -fexcess-precision.
-          (if platformArch platform == ArchX86 &&
-              not (gopt Opt_ExcessPrecision dflags)
-                  then [ "-ffloat-store" ]
-                  else []) ++
-
-          -- gcc's -fstrict-aliasing allows two accesses to memory
-          -- to be considered non-aliasing if they have different types.
-          -- This interacts badly with the C code we generate, which is
-          -- very weakly typed, being derived from C--.
-          ["-fno-strict-aliasing"]
-
-  ghcVersionH <- getGhcVersionPathName dflags unit_env
-
-  withAtomicRename output_fn $ \temp_outputFilename ->
-    GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags (
-                  [ GHC.SysTools.Option "-c"
-                  , GHC.SysTools.FileOption "" input_fn
-                  , GHC.SysTools.Option "-o"
-                  , GHC.SysTools.FileOption "" temp_outputFilename
-                  ]
-                 ++ map GHC.SysTools.Option (
-                    pic_c_flags
-
-                 -- See Note [Produce big objects on Windows]
-                 ++ [ "-Wa,-mbig-obj"
-                    | platformOS (targetPlatform dflags) == OSMinGW32
-                    , not $ target32Bit (targetPlatform dflags)
-                    ]
-
-          -- Stub files generated for foreign exports references the runIO_closure
-          -- and runNonIO_closure symbols, which are defined in the base package.
-          -- These symbols are imported into the stub.c file via RtsAPI.h, and the
-          -- way we do the import depends on whether we're currently compiling
-          -- the base package or not.
-                 ++ (if platformOS platform == OSMinGW32 &&
-                        isHomeUnitId home_unit baseUnitId
-                          then [ "-DCOMPILING_BASE_PACKAGE" ]
-                          else [])
-
-                 -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.
-                 ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)
-                       then ["-Wimplicit"]
-                       else [])
-
-                 ++ (if hcc
-                       then gcc_extra_viac_flags ++ more_hcc_opts
-                       else [])
-                 ++ verbFlags
-                 ++ cc_opt
-                 ++ [ "-include", ghcVersionH ]
-                 ++ framework_paths
-                 ++ include_paths
-                 ++ more_preprocessor_opts
-                 ++ pkg_extra_cc_opts
-                 ))
-
-  return output_fn
-
--- This is where all object files get written from, for hs-boot and hsig files as well.
-runHscBackendPhase :: PipeEnv
-                   -> HscEnv
-                   -> ModuleName
-                   -> HscSource
-                   -> ModLocation
-                   -> HscBackendAction
-                   -> IO ([FilePath], ModIface, HomeModLinkable, FilePath)
-runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
-  let dflags = hsc_dflags hsc_env
-      logger = hsc_logger hsc_env
-      o_file = if dynamicNow dflags then ml_dyn_obj_file location else ml_obj_file location -- The real object file
-      next_phase = hscPostBackendPhase src_flavour (backend dflags)
-  case result of
-      HscUpdate iface ->
-          do
-             case src_flavour of
-               HsigFile -> do
-                 -- We need to create a REAL but empty .o file
-                 -- because we are going to attempt to put it in a library
-                 let input_fn = expectJust "runPhase" (ml_hs_file location)
-                     basename = dropExtension input_fn
-                 compileEmptyStub dflags hsc_env basename location mod_name
-
-               -- In the case of hs-boot files, generate a dummy .o-boot
-               -- stamp file for the benefit of Make
-               HsBootFile -> touchObjectFile logger dflags o_file
-               HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile"
-
-             return ([], iface, emptyHomeModInfoLinkable, o_file)
-      HscRecomp { hscs_guts = cgguts,
-                  hscs_mod_location = mod_location,
-                  hscs_partial_iface = partial_iface,
-                  hscs_old_iface_hash = mb_old_iface_hash
-                }
-        -> if not (backendGeneratesCode (backend dflags)) then
-             panic "HscRecomp not relevant for NoBackend"
-           else if backendWritesFiles (backend dflags) then
-             do
-              output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)
-              (outputFilename, mStub, foreign_files, stg_infos, cg_infos) <-
-
-                hscGenHardCode hsc_env cgguts mod_location output_fn
-              final_iface <- mkFullIface hsc_env partial_iface stg_infos cg_infos
-
-              -- See Note [Writing interface files]
-              hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location
-              mlinkable <-
-                if backendGeneratesCode (backend dflags) && gopt Opt_ByteCodeAndObjectCode dflags
-                  then do
-                    bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location
-                    return $ emptyHomeModInfoLinkable { homeMod_bytecode = Just bc }
-
-                  else return emptyHomeModInfoLinkable
-
-
-              stub_o <- mapM (compileStub hsc_env) mStub
-              foreign_os <-
-                mapM (uncurry (compileForeign hsc_env)) foreign_files
-              let fos = (maybe [] return stub_o ++ foreign_os)
-
-              -- This is awkward, no linkable is produced here because we still
-              -- have some way to do before the object file is produced
-              -- In future we can split up the driver logic more so that this function
-              -- is in TPipeline and in this branch we can invoke the rest of the backend phase.
-              return (fos, final_iface, mlinkable, outputFilename)
-
-           else
-              -- In interpreted mode the regular codeGen backend is not run so we
-              -- generate a interface without codeGen info.
-            do
-              final_iface <- mkFullIface hsc_env partial_iface Nothing Nothing
-              hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location
-              bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location
-              return ([], final_iface, emptyHomeModInfoLinkable { homeMod_bytecode = Just bc } , panic "interpreter")
-
-
-runUnlitPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath
-runUnlitPhase hsc_env input_fn output_fn = do
-    let
-       -- escape the characters \, ", and ', but don't try to escape
-       -- Unicode or anything else (so we don't use Util.charToC
-       -- here).  If we get this wrong, then in
-       -- GHC.HsToCore.Ticks.isGoodTickSrcSpan where we check that the filename in
-       -- a SrcLoc is the same as the source filename, the two will
-       -- look bogusly different. See test:
-       -- libraries/hpc/tests/function/subdir/tough2.hs
-       escape ('\\':cs) = '\\':'\\': escape cs
-       escape ('\"':cs) = '\\':'\"': escape cs
-       escape ('\'':cs) = '\\':'\'': escape cs
-       escape (c:cs)    = c : escape cs
-       escape []        = []
-
-    let flags = [ -- The -h option passes the file name for unlit to
-                  -- put in a #line directive
-                  GHC.SysTools.Option     "-h"
-                  -- See Note [Don't normalise input filenames].
-                , GHC.SysTools.Option $ escape input_fn
-                , GHC.SysTools.FileOption "" input_fn
-                , GHC.SysTools.FileOption "" output_fn
-                ]
-
-    let dflags = hsc_dflags hsc_env
-        logger = hsc_logger hsc_env
-    GHC.SysTools.runUnlit logger dflags flags
-
-    return output_fn
-
-getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, [Warn]))
-getFileArgs hsc_env input_fn = do
-  let dflags0 = hsc_dflags hsc_env
-      parser_opts = initParserOpts dflags0
-  (warns0, src_opts) <- getOptionsFromFile parser_opts input_fn
-  (dflags1, unhandled_flags, warns)
-    <- parseDynamicFilePragma dflags0 src_opts
-  checkProcessArgsResult unhandled_flags
-  return (dflags1, warns0, warns)
-
-runCppPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath
-runCppPhase hsc_env input_fn output_fn = do
-  doCpp (hsc_logger hsc_env)
-           (hsc_tmpfs hsc_env)
-           (hsc_dflags hsc_env)
-           (hsc_unit_env hsc_env)
-           (CppOpts
-              { cppUseCc       = False
-              , cppLinePragmas = True
-              })
-           input_fn output_fn
-  return output_fn
-
-
-runHscPhase :: PipeEnv
-  -> HscEnv
-  -> FilePath
-  -> HscSource
-  -> IO (HscEnv, ModSummary, HscRecompStatus)
-runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
-  let dflags0 = hsc_dflags hsc_env0
-      PipeEnv{ src_basename=basename,
-               src_suffix=suff } = pipe_env
-
-  -- we add the current directory (i.e. the directory in which
-  -- the .hs files resides) to the include path, since this is
-  -- what gcc does, and it's probably what you want.
-  let current_dir = takeDirectory basename
-      new_includes = addImplicitQuoteInclude paths [current_dir]
-      paths = includePaths dflags0
-      dflags = dflags0 { includePaths = new_includes }
-      hsc_env = hscSetFlags dflags hsc_env0
-
-
-
-  -- gather the imports and module name
-  (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
-    buf <- hGetStringBuffer input_fn
-    let imp_prelude = xopt LangExt.ImplicitPrelude dflags
-        popts = initParserOpts dflags
-        rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
-        rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
-    eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
-    case eimps of
-        Left errs -> throwErrors (GhcPsMessage <$> errs)
-        Right (src_imps,imps, ghc_prim_imp, L _ mod_name) -> return
-              (Just buf, mod_name, rn_imps imps, rn_imps src_imps, ghc_prim_imp)
-
-  -- Take -o into account if present
-  -- Very like -ohi, but we must *only* do this if we aren't linking
-  -- (If we're linking then the -o applies to the linked thing, not to
-  -- the object file for one module.)
-  -- Note the nasty duplication with the same computation in compileFile above
-  location <- mkOneShotModLocation pipe_env dflags src_flavour mod_name
-  let o_file = ml_obj_file location -- The real object file
-      hi_file = ml_hi_file location
-      hie_file = ml_hie_file location
-      dyn_o_file = ml_dyn_obj_file location
-
-  src_hash <- getFileHash (basename <.> suff)
-  hi_date <- modificationTimeIfExists hi_file
-  hie_date <- modificationTimeIfExists hie_file
-  o_mod <- modificationTimeIfExists o_file
-  dyn_o_mod <- modificationTimeIfExists dyn_o_file
-
-  -- Tell the finder cache about this module
-  mod <- do
-    let home_unit = hsc_home_unit hsc_env
-    let fc        = hsc_FC hsc_env
-    addHomeModuleToFinder fc home_unit mod_name location
-
-  -- Make the ModSummary to hand to hscMain
-  let
-    mod_summary = ModSummary {  ms_mod       = mod,
-                                ms_hsc_src   = src_flavour,
-                                ms_hspp_file = input_fn,
-                                ms_hspp_opts = dflags,
-                                ms_hspp_buf  = hspp_buf,
-                                ms_location  = location,
-                                ms_hs_hash   = src_hash,
-                                ms_obj_date  = o_mod,
-                                ms_dyn_obj_date = dyn_o_mod,
-                                ms_parsed_mod   = Nothing,
-                                ms_iface_date   = hi_date,
-                                ms_hie_date     = hie_date,
-                                ms_ghc_prim_import = ghc_prim_imp,
-                                ms_textual_imps = imps,
-                                ms_srcimps      = src_imps }
-
-
-  -- run the compiler!
-  let msg :: Messager
-      msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what
-  plugin_hsc_env' <- initializePlugins hsc_env
-
-  -- Need to set the knot-tying mutable variable for interface
-  -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var.
-  -- See also Note [hsc_type_env_var hack]
-  type_env_var <- newIORef emptyNameEnv
-  let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) }
-
-  status <- hscRecompStatus (Just msg) plugin_hsc_env mod_summary
-                        Nothing emptyHomeModInfoLinkable (1, 1)
-
-  return (plugin_hsc_env, mod_summary, status)
-
--- | Calculate the ModLocation from the provided DynFlags. This function is only used
--- in one-shot mode and therefore takes into account the effect of -o/-ohi flags
--- (which do nothing in --make mode)
-mkOneShotModLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO ModLocation
-mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
-    let PipeEnv{ src_basename=basename,
-             src_suffix=suff } = pipe_env
-    let location1 = mkHomeModLocation2 fopts mod_name basename suff
-
-    -- Boot-ify it if necessary
-    let location2
-          | HsBootFile <- src_flavour = addBootSuffixLocnOut location1
-          | otherwise                 = location1
-
-
-    -- Take -ohi into account if present
-    -- This can't be done in mkHomeModuleLocation because
-    -- it only applies to the module being compiles
-    let ohi = outputHi dflags
-        location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
-                  | otherwise      = location2
-
-    let dynohi = dynOutputHi dflags
-        location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file = fn }
-                  | otherwise         = location3
-
-    -- Take -o into account if present
-    -- Very like -ohi, but we must *only* do this if we aren't linking
-    -- (If we're linking then the -o applies to the linked thing, not to
-    -- the object file for one module.)
-    -- Note the nasty duplication with the same computation in compileFile
-    -- above
-    let expl_o_file = outputFile_ dflags
-        expl_dyn_o_file  = dynOutputFile_ dflags
-        location5 | Just ofile <- expl_o_file
-                  , let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file
-                  , isNoLink (ghcLink dflags)
-                  = location4 { ml_obj_file = ofile
-                              , ml_dyn_obj_file = dyn_ofile }
-                  | Just dyn_ofile <- expl_dyn_o_file
-                  = location4 { ml_dyn_obj_file = dyn_ofile }
-                  | otherwise = location4
-    return location5
-    where
-      fopts = initFinderOpts dflags
-
-runHscTcPhase :: HscEnv -> ModSummary -> IO (FrontendResult, Messages GhcMessage)
-runHscTcPhase = hscTypecheckAndGetWarnings
-
-runHscPostTcPhase ::
-    HscEnv
-  -> ModSummary
-  -> FrontendResult
-  -> Messages GhcMessage
-  -> Maybe Fingerprint
-  -> IO HscBackendAction
-runHscPostTcPhase hsc_env mod_summary tc_result tc_warnings mb_old_hash = do
-        runHsc hsc_env $ do
-            hscDesugarAndSimplify mod_summary tc_result tc_warnings mb_old_hash
-
-
-runHsPpPhase :: HscEnv -> FilePath -> FilePath -> FilePath -> IO FilePath
-runHsPpPhase hsc_env orig_fn input_fn output_fn = do
-    let dflags = hsc_dflags hsc_env
-    let logger = hsc_logger hsc_env
-    GHC.SysTools.runPp logger dflags
-      ( [ GHC.SysTools.Option     orig_fn
-      , GHC.SysTools.Option     input_fn
-      , GHC.SysTools.FileOption "" output_fn
-      ] )
-    return output_fn
-
-phaseOutputFilenameNew :: Phase -- ^ The next phase
-                       -> PipeEnv
-                       -> HscEnv
-                       -> Maybe ModLocation -- ^ A ModLocation, if we are compiling a Haskell source file
-                       -> IO FilePath
-phaseOutputFilenameNew next_phase pipe_env hsc_env maybe_loc = do
-  let PipeEnv{stop_phase, src_basename, output_spec} = pipe_env
-  let dflags = hsc_dflags hsc_env
-      logger = hsc_logger hsc_env
-      tmpfs = hsc_tmpfs hsc_env
-  getOutputFilename logger tmpfs (stopPhaseToPhase stop_phase) output_spec
-                    src_basename dflags next_phase maybe_loc
-
-
--- | Computes the next output filename for something in the compilation
--- pipeline.  This is controlled by several variables:
---
---      1. 'Phase': the last phase to be run (e.g. 'stopPhase').  This
---         is used to tell if we're in the last phase or not, because
---         in that case flags like @-o@ may be important.
---      2. 'PipelineOutput': is this intended to be a 'Temporary' or
---         'Persistent' build output?  Temporary files just go in
---         a fresh temporary name.
---      3. 'String': what was the basename of the original input file?
---      4. 'DynFlags': the obvious thing
---      5. 'Phase': the phase we want to determine the output filename of.
---      6. @Maybe ModLocation@: the 'ModLocation' of the module we're
---         compiling; this can be used to override the default output
---         of an object file.  (TODO: do we actually need this?)
-getOutputFilename
-  :: Logger
-  -> TmpFs
-  -> Phase
-  -> PipelineOutput
-  -> String
-  -> DynFlags
-  -> Phase -- next phase
-  -> Maybe ModLocation
-  -> IO FilePath
-getOutputFilename logger tmpfs stop_phase output basename dflags next_phase maybe_location
-  -- 1. If we are generating object files for a .hs file, then return the odir as the ModLocation
-  -- will have been modified to point to the accurate locations
- | StopLn <- next_phase, Just loc <- maybe_location  =
-      return $ if dynamicNow dflags then ml_dyn_obj_file loc
-                                    else ml_obj_file loc
- -- 2. If output style is persistent then
- | is_last_phase, Persistent   <- output = persistent_fn
- -- 3. Specific file is only set when outputFile is set by -o
- -- If we are in dynamic mode but -dyno is not set then write to the same path as
- -- -o with a .dyn_* extension. This case is not triggered for object files which
- -- are always handled by the ModLocation.
- | is_last_phase, SpecificFile <- output =
-    return $
-      if dynamicNow dflags
-        then case dynOutputFile_ dflags of
-                Nothing -> let ofile = getOutputFile_ dflags
-                               new_ext = case takeExtension ofile of
-                                            "" -> "dyn"
-                                            ext -> "dyn_" ++ tail ext
-                           in replaceExtension ofile new_ext
-                Just fn -> fn
-        else getOutputFile_ dflags
- | keep_this_output                      = persistent_fn
- | Temporary lifetime <- output          = newTempName logger tmpfs (tmpDir dflags) lifetime suffix
- | otherwise                             = newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule
-   suffix
-    where
-          getOutputFile_ dflags =
-            case outputFile_ dflags of
-              Nothing -> pprPanic "SpecificFile: No filename" (ppr (dynamicNow dflags) $$
-                                                               text (fromMaybe "-" (dynOutputFile_ dflags)))
-              Just fn -> fn
-
-          hcsuf      = hcSuf dflags
-          odir       = objectDir dflags
-          osuf       = objectSuf dflags
-          keep_hc    = gopt Opt_KeepHcFiles dflags
-          keep_hscpp = gopt Opt_KeepHscppFiles dflags
-          keep_s     = gopt Opt_KeepSFiles dflags
-          keep_bc    = gopt Opt_KeepLlvmFiles dflags
-
-          myPhaseInputExt HCc       = hcsuf
-          myPhaseInputExt MergeForeign = osuf
-          myPhaseInputExt StopLn    = osuf
-          myPhaseInputExt other     = phaseInputExt other
-
-          is_last_phase = next_phase `eqPhase` stop_phase
-
-          -- sometimes, we keep output from intermediate stages
-          keep_this_output =
-               case next_phase of
-                       As _    | keep_s     -> True
-                       LlvmOpt | keep_bc    -> True
-                       HCc     | keep_hc    -> True
-                       HsPp _  | keep_hscpp -> True   -- See #10869
-                       _other               -> False
-
-          suffix = myPhaseInputExt next_phase
-
-          -- persistent object files get put in odir
-          persistent_fn
-             | StopLn <- next_phase = return odir_persistent
-             | otherwise            = return persistent
-
-          persistent = basename <.> suffix
-
-          odir_persistent
-             | Just d <- odir = (d </> persistent)
-             | otherwise      = persistent
-
-
--- | LLVM Options. These are flags to be passed to opt and llc, to ensure
--- consistency we list them in pairs, so that they form groups.
-llvmOptions :: LlvmConfig
-            -> DynFlags
-            -> [(String, String)]  -- ^ pairs of (opt, llc) arguments
-llvmOptions llvm_config dflags =
-       [("-enable-tbaa -tbaa",  "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]
-    ++ [("-relocation-model=" ++ rmodel
-        ,"-relocation-model=" ++ rmodel) | not (null rmodel)]
-    ++ [("-stack-alignment=" ++ (show align)
-        ,"-stack-alignment=" ++ (show align)) | align > 0 ]
-
-    -- Additional llc flags
-    ++ [("", "-mcpu=" ++ mcpu)   | not (null mcpu)
-                                 , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]
-    ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]
-    ++ [("", "-target-abi=" ++ abi) | not (null abi) ]
-
-  where target = platformMisc_llvmTarget $ platformMisc dflags
-        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets llvm_config)
-
-        -- Relocation models
-        rmodel | gopt Opt_PIC dflags         = "pic"
-               | positionIndependent dflags  = "pic"
-               | ways dflags `hasWay` WayDyn = "dynamic-no-pic"
-               | otherwise                   = "static"
-
-        platform = targetPlatform dflags
-
-        align :: Int
-        align = case platformArch platform of
-                  ArchX86_64 | isAvxEnabled dflags -> 32
-                  _                                -> 0
-
-        attrs :: String
-        attrs = intercalate "," $ mattr
-              ++ ["+sse42"   | isSse4_2Enabled dflags   ]
-              ++ ["+sse2"    | isSse2Enabled platform   ]
-              ++ ["+sse"     | isSseEnabled platform    ]
-              ++ ["+avx512f" | isAvx512fEnabled dflags  ]
-              ++ ["+avx2"    | isAvx2Enabled dflags     ]
-              ++ ["+avx"     | isAvxEnabled dflags      ]
-              ++ ["+avx512cd"| isAvx512cdEnabled dflags ]
-              ++ ["+avx512er"| isAvx512erEnabled dflags ]
-              ++ ["+avx512pf"| isAvx512pfEnabled dflags ]
-              ++ ["+bmi"     | isBmiEnabled dflags      ]
-              ++ ["+bmi2"    | isBmi2Enabled dflags     ]
-
-        abi :: String
-        abi = case platformArch (targetPlatform dflags) of
-                ArchRISCV64 -> "lp64d"
-                _           -> ""
-
--- | What phase to run after one of the backend code generators has run
-hscPostBackendPhase :: HscSource -> Backend -> Phase
-hscPostBackendPhase HsBootFile _    =  StopLn
-hscPostBackendPhase HsigFile _      =  StopLn
-hscPostBackendPhase _ bcknd = backendNormalSuccessorPhase bcknd
-
-
-compileStub :: HscEnv -> FilePath -> IO FilePath
-compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c
-
-
--- ---------------------------------------------------------------------------
--- join object files into a single relocatable object file, using ld -r
-
-{-
-Note [Produce big objects on Windows]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The Windows Portable Executable object format has a limit of 32k sections, which
-we tend to blow through pretty easily. Thankfully, there is a "big object"
-extension, which raises this limit to 2^32. However, it must be explicitly
-enabled in the toolchain:
-
- * the assembler accepts the -mbig-obj flag, which causes it to produce a
-   bigobj-enabled COFF object.
-
- * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name
-   suggests, this tells the linker to produce a bigobj-enabled COFF object, no a
-   PE executable.
-
-Previously when we used ld.bfd we had to enable bigobj output in a few places:
-
- * When merging object files (GHC.Driver.Pipeline.Execute.joinObjectFiles)
-
- * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...))
-
-However, this is no longer necessary with ld.lld, which detects that the
-object is large on its own.
-
-Unfortunately the big object format is not supported on 32-bit targets so
-none of this can be used in that case.
-
-
-Note [Object merging]
-~~~~~~~~~~~~~~~~~~~~~
-On most platforms one can "merge" a set of relocatable object files into a new,
-partially-linked-but-still-relocatable object. In a typical UNIX-style linker,
-this is accomplished with the `ld -r` command. We rely on this for two ends:
-
- * We rely on `ld -r` to squash together split sections, making GHCi loading
-   more efficient. See Note [Merging object files for GHCi].
-
- * We use merging to combine a module's object code (e.g. produced by the NCG)
-   with its foreign stubs (typically produced by a C compiler).
-
-The command used for object linking is set using the -pgmlm and -optlm
-command-line options.
-
-Sadly, the LLD linker that we use on Windows does not support the `-r` flag
-needed to support object merging (see #21068). For this reason on Windows we do
-not support GHCi objects.  To deal with foreign stubs we build a static archive
-of all of a module's object files instead merging them. Consequently, we can
-end up producing `.o` files which are in fact static archives. However,
-toolchains generally don't have a problem with this as they use file headers,
-not the filename, to determine the nature of inputs.
-
-Note that this has somewhat non-obvious consequences when producing
-initializers and finalizers. See Note [Initializers and finalizers in Cmm]
-in GHC.Cmm.InitFini for details.
-
-
-Note [Merging object files for GHCi]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-GHCi can usually loads standard linkable object files using GHC's linker
-implementation. However, most users build their projects with -split-sections,
-meaning that such object files can have an extremely high number of sections.
-As the linker must map each of these sections individually, loading such object
-files is very inefficient.
-
-To avoid this inefficiency, we use the linker's `-r` flag and a linker script
-to produce a merged relocatable object file. This file will contain a singe
-text section section and can consequently be mapped far more efficiently. As
-gcc tends to do unpredictable things to our linker command line, we opt to
-invoke ld directly in this case, in contrast to our usual strategy of linking
-via gcc.
--}
-
--- | See Note [Object merging].
-joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO ()
-joinObjectFiles hsc_env o_files output_fn
-  | can_merge_objs && not dashLSupported = do
-  let toolSettings' = toolSettings dflags
-      ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'
-      ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (
-                        [ GHC.SysTools.Option "-o",
-                          GHC.SysTools.FileOption "" output_fn ]
-                     ++ args)
-
-  if ldIsGnuLd
-     then do
-          script <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "ldscript"
-          cwd <- getCurrentDirectory
-          let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files
-          writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"
-          ld_r [GHC.SysTools.FileOption "" script]
-     else if toolSettings_ldSupportsFilelist toolSettings'
-     then do
-          filelist <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "filelist"
-          writeFile filelist $ unlines o_files
-          ld_r [GHC.SysTools.Option "-filelist",
-                GHC.SysTools.FileOption "" filelist]
-     else
-          ld_r (map (GHC.SysTools.FileOption "") o_files)
-
-  | otherwise = do
-  withAtomicRename output_fn $ \tmp_ar ->
-      liftIO $ runAr logger dflags Nothing $ map Option $ ["qc" ++ dashL, tmp_ar] ++ o_files
-  where
-    dashLSupported = sArSupportsDashL (settings dflags)
-    dashL = if dashLSupported then "L" else ""
-    can_merge_objs = isJust (pgm_lm (hsc_dflags hsc_env))
-    dflags = hsc_dflags hsc_env
-    tmpfs = hsc_tmpfs hsc_env
-    logger = hsc_logger hsc_env
-
-
------------------------------------------------------------------------------
--- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
-
-getHCFilePackages :: FilePath -> IO [UnitId]
-getHCFilePackages filename =
-  withFile filename ReadMode $ \h -> do
-    l <- hGetLine h
-    case l of
-      '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
-          return (map stringToUnitId (words rest))
-      _other ->
-          return []
-
-
-linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
-linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do
-  when (haveRtsOptsFlags dflags) $
-    logMsg logger MCInfo noSrcSpan
-      $ withPprStyle defaultUserStyle
-      (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
-      text "    Call hs_init_ghc() from your main() function to set these options.")
-  linkDynLib logger tmpfs dflags unit_env o_files dep_units
-
-
-
--- -----------------------------------------------------------------------------
--- Misc.
-
-
-
-touchObjectFile :: Logger -> DynFlags -> FilePath -> IO ()
-touchObjectFile logger dflags path = do
-  createDirectoryIfMissing True $ takeDirectory path
-  GHC.SysTools.touch logger dflags "Touching object file" path
-
--- Note [-fPIC for assembler]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--- When compiling .c source file GHC's driver pipeline basically
--- does the following two things:
---   1. ${CC}              -S 'PIC_CFLAGS' source.c
---   2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S
---
--- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler?
--- Because on some architectures (at least sparc32) assembler also chooses
--- the relocation type!
--- Consider the following C module:
---
---     /* pic-sample.c */
---     int v;
---     void set_v (int n) { v = n; }
---     int  get_v (void)  { return v; }
---
---     $ gcc -S -fPIC pic-sample.c
---     $ gcc -c       pic-sample.s -o pic-sample.no-pic.o # incorrect binary
---     $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o    # correct binary
---
---     $ objdump -r -d pic-sample.pic.o    > pic-sample.pic.o.od
---     $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od
---     $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od
---
--- Most of architectures won't show any difference in this test, but on sparc32
--- the following assembly snippet:
---
---    sethi   %hi(_GLOBAL_OFFSET_TABLE_-8), %l7
---
--- generates two kinds or relocations, only 'R_SPARC_PC22' is correct:
---
---       3c:  2f 00 00 00     sethi  %hi(0), %l7
---    -                       3c: R_SPARC_PC22        _GLOBAL_OFFSET_TABLE_-0x8
---    +                       3c: R_SPARC_HI22        _GLOBAL_OFFSET_TABLE_-0x8
-
-{- Note [Don't normalise input filenames]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Summary
-  We used to normalise input filenames when starting the unlit phase. This
-  broke hpc in `--make` mode with imported literate modules (#2991).
-
-Introduction
-  1) --main
-  When compiling a module with --main, GHC scans its imports to find out which
-  other modules it needs to compile too. It turns out that there is a small
-  difference between saying `ghc --make A.hs`, when `A` imports `B`, and
-  specifying both modules on the command line with `ghc --make A.hs B.hs`. In
-  the former case, the filename for B is inferred to be './B.hs' instead of
-  'B.hs'.
-
-  2) unlit
-  When GHC compiles a literate haskell file, the source code first needs to go
-  through unlit, which turns it into normal Haskell source code. At the start
-  of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the
-  option `-h` and the name of the original file. We used to normalise this
-  filename using System.FilePath.normalise, which among other things removes
-  an initial './'. unlit then uses that filename in #line directives that it
-  inserts in the transformed source code.
-
-  3) SrcSpan
-  A SrcSpan represents a portion of a source code file. It has fields
-  linenumber, start column, end column, and also a reference to the file it
-  originated from. The SrcSpans for a literate haskell file refer to the
-  filename that was passed to unlit -h.
-
-  4) -fhpc
-  At some point during compilation with -fhpc, in the function
-  `GHC.HsToCore.Ticks.isGoodTickSrcSpan`, we compare the filename that a
-  `SrcSpan` refers to with the name of the file we are currently compiling.
-  For some reason I don't yet understand, they can sometimes legitimately be
-  different, and then hpc ignores that SrcSpan.
-
-Problem
-  When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate
-  module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the
-  start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2).
-  Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are
-  still compiling `./B.lhs`. Hpc thinks these two filenames are different (4),
-  doesn't include ticks for B, and we have unhappy customers (#2991).
-
-Solution
-  Do not normalise `input_fn` when starting the unlit phase.
-
-Alternative solution
-  Another option would be to not compare the two filenames on equality, but to
-  use System.FilePath.equalFilePath. That function first normalises its
-  arguments. The problem is that by the time we need to do the comparison, the
-  filenames have been turned into FastStrings, probably for performance
-  reasons, so System.FilePath.equalFilePath can not be used directly.
-
-Archeology
-  The call to `normalise` was added in a commit called "Fix slash
-  direction on Windows with the new filePath code" (c9b6b5e8). The problem
-  that commit was addressing has since been solved in a different manner, in a
-  commit called "Fix the filename passed to unlit" (1eedbc6b). So the
-  `normalise` is no longer necessary.
--}
-
-{-
-Note [-Wa,--no-type-check on wasm32]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Wasm32 has a type system and corresponding validation rules, so it's
-possible to produce syntactically valid object code that doesn't pass
-validation.
-
-We have no problem with that, but we do have a problem with clang.
-When clang takes an assembly input for wasm32, it uses its internal
-type-checker, which is a huge source of trouble (see llvm ticket
-#56935 #58438): it may reject valid assembly, and even worse, it may
-silently alter the output object code!!! The worsest of all, is the
-person that added the wasm32 asm typechecker logic has moved on from
-Google/LLVM, and while other LLVM devs may be knowledgable enough to
-fix this mess, they likely got tons of other stuff on their table and
-don't care enough.
-
-We do have an escape hatch, just pass -Wa,--no-type-check to clang to
-bypass the entire wasm32 asm typechecking logic. There's little point
-in type-checking object code at compile-time anyway, the wasm engines
-will do type-checking at run-time. And even if we want to add some
-linting flag to do compile-time checks, we should just rely on
-battle-tested external tools instead of a completely broken horror
-story.
--}
diff --git a/compiler/GHC/Driver/Pipeline/LogQueue.hs b/compiler/GHC/Driver/Pipeline/LogQueue.hs
deleted file mode 100644
--- a/compiler/GHC/Driver/Pipeline/LogQueue.hs
+++ /dev/null
@@ -1,123 +0,0 @@
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE DerivingVia #-}
-module GHC.Driver.Pipeline.LogQueue ( LogQueue(..)
-                                  , newLogQueue
-                                  , finishLogQueue
-                                  , writeLogQueue
-                                  , parLogAction
-
-                                  , LogQueueQueue(..)
-                                  , initLogQueue
-                                  , allLogQueues
-                                  , newLogQueueQueue
-
-                                  , logThread
-                                  ) where
-
-import GHC.Prelude
-import Control.Concurrent
-import Data.IORef
-import GHC.Types.Error
-import GHC.Types.SrcLoc
-import GHC.Utils.Logger
-import qualified Data.IntMap as IM
-import Control.Concurrent.STM
-import Control.Monad
-
--- LogQueue Abstraction
-
--- | Each module is given a unique 'LogQueue' to redirect compilation messages
--- to. A 'Nothing' value contains the result of compilation, and denotes the
--- end of the message queue.
-data LogQueue = LogQueue { logQueueId :: !Int
-                         , logQueueMessages :: !(IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)])
-                         , logQueueSemaphore :: !(MVar ())
-                         }
-
-newLogQueue :: Int -> IO LogQueue
-newLogQueue n = do
-  mqueue <- newIORef []
-  sem <- newMVar ()
-  return (LogQueue n mqueue sem)
-
-finishLogQueue :: LogQueue -> IO ()
-finishLogQueue lq = do
-  writeLogQueueInternal lq Nothing
-
-
-writeLogQueue :: LogQueue -> (MessageClass,SrcSpan,SDoc, LogFlags) -> IO ()
-writeLogQueue lq msg = do
-  writeLogQueueInternal lq (Just msg)
-
--- | Internal helper for writing log messages
-writeLogQueueInternal :: LogQueue -> Maybe (MessageClass,SrcSpan,SDoc, LogFlags) -> IO ()
-writeLogQueueInternal (LogQueue _n ref sem) msg = do
-    atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
-    _ <- tryPutMVar sem ()
-    return ()
-
--- The log_action callback that is used to synchronize messages from a
--- worker thread.
-parLogAction :: LogQueue -> LogAction
-parLogAction log_queue log_flags !msgClass !srcSpan !msg =
-    writeLogQueue log_queue (msgClass,srcSpan,msg, log_flags)
-
--- Print each message from the log_queue using the global logger
-printLogs :: Logger -> LogQueue -> IO ()
-printLogs !logger (LogQueue _n ref sem) = read_msgs
-  where read_msgs = do
-            takeMVar sem
-            msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)
-            print_loop msgs
-
-        print_loop [] = read_msgs
-        print_loop (x:xs) = case x of
-            Just (msgClass,srcSpan,msg,flags) -> do
-                logMsg (setLogFlags logger flags) msgClass srcSpan msg
-                print_loop xs
-            -- Exit the loop once we encounter the end marker.
-            Nothing -> return ()
-
--- The LogQueueQueue abstraction
-
-data LogQueueQueue = LogQueueQueue Int (IM.IntMap LogQueue)
-
-newLogQueueQueue :: LogQueueQueue
-newLogQueueQueue = LogQueueQueue 1 IM.empty
-
-addToQueueQueue :: LogQueue -> LogQueueQueue -> LogQueueQueue
-addToQueueQueue lq (LogQueueQueue n im) = LogQueueQueue n (IM.insert (logQueueId lq) lq im)
-
-initLogQueue :: TVar LogQueueQueue -> LogQueue -> STM ()
-initLogQueue lqq lq = modifyTVar lqq (addToQueueQueue lq)
-
--- | Return all items in the queue in ascending order
-allLogQueues :: LogQueueQueue -> [LogQueue]
-allLogQueues (LogQueueQueue _n im) = IM.elems im
-
-dequeueLogQueueQueue :: LogQueueQueue -> Maybe (LogQueue, LogQueueQueue)
-dequeueLogQueueQueue (LogQueueQueue n lqq) = case IM.minViewWithKey lqq of
-                                                Just ((k, v), lqq') | k == n -> Just (v, LogQueueQueue (n + 1) lqq')
-                                                _ -> Nothing
-
-logThread :: Int -> Int -> Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit
-                    -> TVar LogQueueQueue -- Queue for logs
-                    -> IO (IO ())
-logThread _ _ logger stopped lqq_var = do
-  finished_var <- newEmptyMVar
-  _ <- forkIO $ print_logs *> putMVar finished_var ()
-  return (takeMVar finished_var)
-  where
-    finish = mapM (printLogs logger)
-
-    print_logs = join $ atomically $ do
-      lqq <- readTVar lqq_var
-      case dequeueLogQueueQueue lqq of
-        Just (lq, lqq') -> do
-          writeTVar lqq_var lqq'
-          return (printLogs logger lq *> print_logs)
-        Nothing -> do
-          -- No log to print, check if we are finished.
-          stopped <- readTVar stopped
-          if not stopped then retry
-                         else return (finish (allLogQueues lqq))
diff --git a/compiler/GHC/Hs/Stats.hs b/compiler/GHC/Hs/Stats.hs
deleted file mode 100644
--- a/compiler/GHC/Hs/Stats.hs
+++ /dev/null
@@ -1,188 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-
--- |
--- Statistics for per-module compilations
---
--- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
---
-
-module GHC.Hs.Stats ( ppSourceStats ) where
-
-import GHC.Prelude
-
-import GHC.Data.Bag
-import GHC.Hs
-import GHC.Types.SrcLoc
-
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-
-import Data.Char
-
--- | Source Statistics
-ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc
-ppSourceStats short (L _ (HsModule{ hsmodExports = exports, hsmodImports = imports, hsmodDecls = ldecls }))
-  = (if short then hcat else vcat)
-        (map pp_val
-            [("ExportAll        ", export_all), -- 1 if no export list
-             ("ExportDecls      ", export_ds),
-             ("ExportModules    ", export_ms),
-             ("Imports          ", imp_no),
-             ("  ImpSafe        ", imp_safe),
-             ("  ImpQual        ", imp_qual),
-             ("  ImpAs          ", imp_as),
-             ("  ImpAll         ", imp_all),
-             ("  ImpPartial     ", imp_partial),
-             ("  ImpHiding      ", imp_hiding),
-             ("FixityDecls      ", fixity_sigs),
-             ("DefaultDecls     ", default_ds),
-             ("TypeDecls        ", type_ds),
-             ("DataDecls        ", data_ds),
-             ("NewTypeDecls     ", newt_ds),
-             ("TypeFamilyDecls  ", type_fam_ds),
-             ("DataConstrs      ", data_constrs),
-             ("DataDerivings    ", data_derivs),
-             ("ClassDecls       ", class_ds),
-             ("ClassMethods     ", class_method_ds),
-             ("DefaultMethods   ", default_method_ds),
-             ("InstDecls        ", inst_ds),
-             ("InstMethods      ", inst_method_ds),
-             ("InstType         ", inst_type_ds),
-             ("InstData         ", inst_data_ds),
-             ("TypeSigs         ", bind_tys),
-             ("ClassOpSigs      ", generic_sigs),
-             ("ValBinds         ", val_bind_ds),
-             ("FunBinds         ", fn_bind_ds),
-             ("PatSynBinds      ", patsyn_ds),
-             ("InlineMeths      ", method_inlines),
-             ("InlineBinds      ", bind_inlines),
-             ("SpecialisedMeths ", method_specs),
-             ("SpecialisedBinds ", bind_specs)
-            ])
-  where
-    decls = map unLoc ldecls
-
-    pp_val (_, 0) = empty
-    pp_val (str, n)
-      | not short   = hcat [text str, int n]
-      | otherwise   = hcat [text (trim str), equals, int n, semi]
-
-    trim ls    = takeWhile (not.isSpace) (dropWhile isSpace ls)
-
-    (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs)
-        = count_sigs [d | SigD _ d <- decls]
-                -- NB: this omits fixity decls on local bindings and
-                -- in class decls. ToDo
-
-    tycl_decls = [d | TyClD _ d <- decls]
-    (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) =
-      countTyClDecls tycl_decls
-
-    inst_decls = [d | InstD _ d <- decls]
-    inst_ds    = length inst_decls
-    default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls
-    val_decls  = [d | ValD _ d <- decls]
-
-    real_exports = case exports of { Nothing -> []; Just (L _ es) -> es }
-    n_exports    = length real_exports
-    export_ms    = count (\ e -> case unLoc e of { IEModuleContents{} -> True
-                                                 ; _ -> False})
-                         real_exports
-    export_ds    = n_exports - export_ms
-    export_all   = case exports of { Nothing -> 1; _ -> 0 }
-
-    (val_bind_ds, fn_bind_ds, patsyn_ds)
-        = sum3 (map count_bind val_decls)
-
-    (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding)
-        = sum7 (map import_info imports)
-    (data_constrs, data_derivs)
-        = sum2 (map data_info tycl_decls)
-    (class_method_ds, default_method_ds)
-        = sum2 (map class_info tycl_decls)
-    (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds)
-        = sum5 (map inst_info inst_decls)
-
-    count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0)
-    count_bind (PatBind {})                           = (0,1,0)
-    count_bind (FunBind {})                           = (0,1,0)
-    count_bind (PatSynBind {})                        = (0,0,1)
-    count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b)
-
-    count_sigs sigs = sum5 (map sig_info sigs)
-
-    sig_info (FixSig {})     = (1,0,0,0,0)
-    sig_info (TypeSig {})    = (0,1,0,0,0)
-    sig_info (SpecSig {})    = (0,0,1,0,0)
-    sig_info (InlineSig {})  = (0,0,0,1,0)
-    sig_info (ClassOpSig {}) = (0,0,0,0,1)
-    sig_info _               = (0,0,0,0,0)
-
-    import_info :: LImportDecl GhcPs -> (Int, Int, Int, Int, Int, Int, Int)
-    import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
-                                 , ideclAs = as, ideclImportList = spec }))
-        = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)
-
-    safe_info False = 0
-    safe_info True = 1
-    qual_info NotQualified = 0
-    qual_info _  = 1
-    as_info Nothing  = 0
-    as_info (Just _) = 1
-    spec_info Nothing           = (0,0,0,0,1,0,0)
-    spec_info (Just (Exactly, _)) = (0,0,0,0,0,1,0)
-    spec_info (Just (EverythingBut, _))  = (0,0,0,0,0,0,1)
-
-    data_info (DataDecl { tcdDataDefn = HsDataDefn
-                                          { dd_cons = cs
-                                          , dd_derivs = derivs}})
-        = ( length cs
-          , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s)
-                   0 derivs )
-    data_info _ = (0,0)
-
-    class_info decl@(ClassDecl {})
-        = (classops, addpr (sum3 (map count_bind methods)))
-      where
-        methods = map unLoc $ bagToList (tcdMeths decl)
-        (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl))
-    class_info _ = (0,0)
-
-    inst_info :: InstDecl GhcPs -> (Int, Int, Int, Int, Int)
-    inst_info (TyFamInstD {}) = (0,0,0,1,0)
-    inst_info (DataFamInstD {}) = (0,0,0,0,1)
-    inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths
-                                                 , cid_sigs = inst_sigs
-                                                 , cid_tyfam_insts = ats
-                                                 , cid_datafam_insts = adts } })
-        = case count_sigs (map unLoc inst_sigs) of
-            (_,_,ss,is,_) ->
-                  (addpr (sum3 (map count_bind methods)),
-                   ss, is, length ats, length adts)
-      where
-        methods = map unLoc $ bagToList inst_meths
-
-    -- TODO: use Sum monoid
-    addpr :: (Int,Int,Int) -> Int
-    sum2 :: [(Int, Int)] -> (Int, Int)
-    sum3 :: [(Int, Int, Int)] -> (Int, Int, Int)
-    sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int)
-    sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int)
-    add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int)
-         -> (Int, Int, Int, Int, Int, Int, Int)
-
-    addpr (x,y,z) = x+y+z
-    sum2 = foldr add2 (0,0)
-      where
-        add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
-    sum3 = foldr add3 (0,0,0)
-      where
-        add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3)
-    sum5 = foldr add5 (0,0,0,0,0)
-      where
-        add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
-    sum7 = foldr add7 (0,0,0,0,0,0,0)
-
-    add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7)
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
deleted file mode 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ /dev/null
@@ -1,200 +0,0 @@
--- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion.
---
--- Note that this does /not/ currently support the use case of annotating
--- every subexpression in an 'HsExpr' with its 'Type'. For more information on
--- this task, see #12706, #15320, #16804, and #17331.
-module GHC.Hs.Syn.Type (
-    -- * Extracting types from HsExpr
-    lhsExprType, hsExprType, hsWrapperType,
-    -- * Extracting types from HsSyn
-    hsLitType, hsPatType, hsLPatType
-
-  ) where
-
-import GHC.Prelude
-
-import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim
-import GHC.Core.Coercion
-import GHC.Core.ConLike
-import GHC.Core.DataCon
-import GHC.Core.PatSyn
-import GHC.Core.TyCo.Rep
-import GHC.Core.Type
-import GHC.Hs
-import GHC.Tc.Types.Evidence
-import GHC.Types.Id
-import GHC.Types.Var( VarBndr(..) )
-import GHC.Types.SrcLoc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-{-
-************************************************************************
-*                                                                      *
-       Extracting the type from HsSyn
-*                                                                      *
-************************************************************************
-
--}
-
-hsLPatType :: LPat GhcTc -> Type
-hsLPatType (L _ p) = hsPatType p
-
-hsPatType :: Pat GhcTc -> Type
-hsPatType (ParPat _ _ pat _)            = hsLPatType pat
-hsPatType (WildPat ty)                  = ty
-hsPatType (VarPat _ lvar)               = idType (unLoc lvar)
-hsPatType (BangPat _ pat)               = hsLPatType pat
-hsPatType (LazyPat _ pat)               = hsLPatType pat
-hsPatType (LitPat _ lit)                = hsLitType lit
-hsPatType (AsPat _ var _ _)             = idType (unLoc var)
-hsPatType (ViewPat ty _ _)              = ty
-hsPatType (ListPat ty _)                = mkListTy ty
-hsPatType (TuplePat tys _ bx)           = mkTupleTy1 bx tys
-                  -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
-hsPatType (SumPat tys _ _ _ )           = mkSumTy tys
-hsPatType (ConPat { pat_con = lcon
-                  , pat_con_ext = ConPatTc
-                    { cpt_arg_tys = tys
-                    }
-                  })
-                                        = conLikeResTy (unLoc lcon) tys
-hsPatType (SigPat ty _ _)               = ty
-hsPatType (NPat ty _ _ _)               = ty
-hsPatType (NPlusKPat ty _ _ _ _ _)      = ty
-hsPatType (XPat ext) =
-  case ext of
-    CoPat _ _ ty       -> ty
-    ExpansionPat _ pat -> hsPatType pat
-hsPatType (SplicePat v _)               = dataConCantHappen v
-
-hsLitType :: HsLit (GhcPass p) -> Type
-hsLitType (HsChar _ _)       = charTy
-hsLitType (HsCharPrim _ _)   = charPrimTy
-hsLitType (HsString _ _)     = stringTy
-hsLitType (HsStringPrim _ _) = addrPrimTy
-hsLitType (HsInt _ _)        = intTy
-hsLitType (HsIntPrim _ _)    = intPrimTy
-hsLitType (HsWordPrim _ _)   = wordPrimTy
-hsLitType (HsInt64Prim _ _)  = int64PrimTy
-hsLitType (HsWord64Prim _ _) = word64PrimTy
-hsLitType (HsInteger _ _ ty) = ty
-hsLitType (HsRat _ _ ty)     = ty
-hsLitType (HsFloatPrim _ _)  = floatPrimTy
-hsLitType (HsDoublePrim _ _) = doublePrimTy
-
-
--- | Compute the 'Type' of an @'LHsExpr' 'GhcTc'@ in a pure fashion.
-lhsExprType :: LHsExpr GhcTc -> Type
-lhsExprType (L _ e) = hsExprType e
-
--- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion.
-hsExprType :: HsExpr GhcTc -> Type
-hsExprType (HsVar _ (L _ id)) = idType id
-hsExprType (HsUnboundVar (HER _ ty _) _) = ty
-hsExprType (HsRecSel _ (FieldOcc id _)) = idType id
-hsExprType (HsOverLabel v _) = dataConCantHappen v
-hsExprType (HsIPVar v _) = dataConCantHappen v
-hsExprType (HsOverLit _ lit) = overLitType lit
-hsExprType (HsLit _ lit) = hsLitType lit
-hsExprType (HsLam     _ (MG { mg_ext = match_group })) = matchGroupTcType match_group
-hsExprType (HsLamCase _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_group
-hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f
-hsExprType (HsAppType x f _ _) = piResultTy (lhsExprType f) x
-hsExprType (OpApp v _ _ _) = dataConCantHappen v
-hsExprType (NegApp _ _ se) = syntaxExprType se
-hsExprType (HsPar _ _ e _) = lhsExprType e
-hsExprType (SectionL v _ _) = dataConCantHappen v
-hsExprType (SectionR v _ _) = dataConCantHappen v
-hsExprType (ExplicitTuple _ args box) = mkTupleTy box $ map hsTupArgType args
-hsExprType (ExplicitSum alt_tys _ _ _) = mkSumTy alt_tys
-hsExprType (HsCase _ _ (MG { mg_ext = match_group })) = mg_res_ty match_group
-hsExprType (HsIf _ _ t _) = lhsExprType t
-hsExprType (HsMultiIf ty _) = ty
-hsExprType (HsLet _ _ _ _ body) = lhsExprType body
-hsExprType (HsDo ty _ _) = ty
-hsExprType (ExplicitList ty _) = mkListTy ty
-hsExprType (RecordCon con_expr _ _) = hsExprType con_expr
-hsExprType (RecordUpd v _ _) = dataConCantHappen v
-hsExprType (HsGetField { gf_ext = v }) = dataConCantHappen v
-hsExprType (HsProjection { proj_ext = v }) = dataConCantHappen v
-hsExprType (ExprWithTySig _ e _) = lhsExprType e
-hsExprType (ArithSeq _ mb_overloaded_op asi) = case mb_overloaded_op of
-  Just op -> piResultTy (syntaxExprType op) asi_ty
-  Nothing -> asi_ty
-  where
-    asi_ty = arithSeqInfoType asi
-hsExprType (HsTypedBracket   (HsBracketTc { hsb_ty = ty }) _) = ty
-hsExprType (HsUntypedBracket (HsBracketTc { hsb_ty = ty }) _) = ty
-hsExprType e@(HsTypedSplice{}) = pprPanic "hsExprType: Unexpected HsTypedSplice"
-                                          (ppr e)
-                                      -- Typed splices should have been eliminated during zonking, but we
-                                      -- can't use `dataConCantHappen` since they are still present before
-                                      -- than in the typechecked AST.
-hsExprType (HsUntypedSplice ext _) = dataConCantHappen ext
-hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top
-hsExprType (HsStatic (_, ty) _s) = ty
-hsExprType (HsPragE _ _ e) = lhsExprType e
-hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e
-hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e
-hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con
-hsExprType (XExpr (HsTick _ e)) = lhsExprType e
-hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e
-
-arithSeqInfoType :: ArithSeqInfo GhcTc -> Type
-arithSeqInfoType asi = mkListTy $ case asi of
-  From x           -> lhsExprType x
-  FromThen x _     -> lhsExprType x
-  FromTo x _       -> lhsExprType x
-  FromThenTo x _ _ -> lhsExprType x
-
-conLikeType :: ConLike -> Type
-conLikeType (RealDataCon con)  = dataConNonlinearType con
-conLikeType (PatSynCon patsyn) = case patSynBuilder patsyn of
-    Just (_, ty, _) -> ty
-    Nothing         -> pprPanic "conLikeType: Unidirectional pattern synonym in expression position"
-                                (ppr patsyn)
-
-hsTupArgType :: HsTupArg GhcTc -> Type
-hsTupArgType (Present _ e)           = lhsExprType e
-hsTupArgType (Missing (Scaled _ ty)) = ty
-
-
--- | The PRType (ty, tas) is short for (piResultTys ty (reverse tas))
-type PRType = (Type, [Type])
-
-prTypeType :: PRType -> Type
-prTypeType (ty, tys)
-  | null tys  = ty
-  | otherwise = piResultTys ty (reverse tys)
-
-liftPRType :: (Type -> Type) -> PRType -> PRType
-liftPRType f pty = (f (prTypeType pty), [])
-
-hsWrapperType :: HsWrapper -> Type -> Type
-hsWrapperType wrap ty = prTypeType $ go wrap (ty,[])
-  where
-    go WpHole              = id
-    go (w1 `WpCompose` w2) = go w1 . go w2
-    go (WpFun _ w2 (Scaled m exp_arg)) = liftPRType $ \t ->
-      let act_res = funResultTy t
-          exp_res = hsWrapperType w2 act_res
-      in mkFunctionType m exp_arg exp_res
-    go (WpCast co)        = liftPRType $ \_ -> coercionRKind co
-    go (WpEvLam v)        = liftPRType $ mkInvisFunTy (idType v)
-    go (WpEvApp _)        = liftPRType $ funResultTy
-    go (WpTyLam tv)       = liftPRType $ mkForAllTy (Bndr tv Inferred)
-    go (WpTyApp ta)       = \(ty,tas) -> (ty, ta:tas)
-    go (WpLet _)          = id
-    go (WpMultCoercion _) = id
-
-lhsCmdTopType :: LHsCmdTop GhcTc -> Type
-lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty
-
-matchGroupTcType :: MatchGroupTc -> Type
-matchGroupTcType (MatchGroupTc args res _) = mkScaledFunTys args res
-
-syntaxExprType :: SyntaxExpr GhcTc -> Type
-syntaxExprType (SyntaxExprTc e _ _) = hsExprType e
-syntaxExprType NoSyntaxExprTc       = panic "syntaxExprType: Unexpected NoSyntaxExprTc"
diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore.hs
+++ /dev/null
@@ -1,802 +0,0 @@
-{-# LANGUAGE MonadComprehensions #-}
-{-# LANGUAGE TypeFamilies #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-The Desugarer: turning HsSyn into Core.
--}
-
-module GHC.HsToCore (
-    -- * Desugaring operations
-    deSugar, deSugarExpr
-    ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-import GHC.Driver.Config
-import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )
-import GHC.Driver.Config.HsToCore.Ticks
-import GHC.Driver.Config.HsToCore.Usage
-import GHC.Driver.Env
-import GHC.Driver.Backend
-import GHC.Driver.Plugins
-
-import GHC.Hs
-
-import GHC.HsToCore.Usage
-import GHC.HsToCore.Monad
-import GHC.HsToCore.Errors.Types
-import GHC.HsToCore.Expr
-import GHC.HsToCore.Binds
-import GHC.HsToCore.Foreign.Decl
-import GHC.HsToCore.Ticks
-import GHC.HsToCore.Breakpoints
-import GHC.HsToCore.Coverage
-import GHC.HsToCore.Docs
-
-import GHC.Tc.Types
-import GHC.Tc.Utils.Monad  ( finalSafeMode, fixSafeInstances )
-import GHC.Tc.Module ( runTcInteractive )
-
-import GHC.Core.Type
-import GHC.Core.TyCo.Compare( eqType )
-import GHC.Core.TyCon       ( tyConDataCons )
-import GHC.Core
-import GHC.Core.FVs       ( exprsSomeFreeVarsList, exprFreeVars )
-import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr )
-import GHC.Core.Utils
-import GHC.Core.Unfold.Make
-import GHC.Core.Coercion
-import GHC.Core.DataCon ( dataConWrapId )
-import GHC.Core.Make
-import GHC.Core.Rules
-import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )
-import GHC.Core.Ppr
-
-import GHC.Builtin.Names
-import GHC.Builtin.Types.Prim
-import GHC.Builtin.Types
-
-import GHC.Data.FastString
-import GHC.Data.Maybe    ( expectJust )
-import GHC.Data.OrdList
-import GHC.Data.SizedSeq ( sizeSS )
-
-import GHC.Utils.Error
-import GHC.Utils.Outputable
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Misc
-import GHC.Utils.Monad
-import GHC.Utils.Logger
-
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.ForeignStubs
-import GHC.Types.Avail
-import GHC.Types.Basic
-import GHC.Types.Var.Set
-import GHC.Types.SrcLoc
-import GHC.Types.SourceFile
-import GHC.Types.TypeEnv
-import GHC.Types.Name
-import GHC.Types.Name.Set
-import GHC.Types.Name.Env
-import GHC.Types.Name.Ppr
-import GHC.Types.HpcInfo
-
-import GHC.Unit
-import GHC.Unit.Module.ModGuts
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.Deps
-
-import Data.List (partition)
-import Data.IORef
-import Data.Traversable (for)
-
-{-
-************************************************************************
-*                                                                      *
-*              The main function: deSugar
-*                                                                      *
-************************************************************************
--}
-
--- | Main entry point to the desugarer.
-deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DsMessage, Maybe ModGuts)
--- Can modify PCS by faulting in more declarations
-
-deSugar hsc_env
-        mod_loc
-        tcg_env@(TcGblEnv { tcg_mod          = id_mod,
-                            tcg_semantic_mod = mod,
-                            tcg_src          = hsc_src,
-                            tcg_type_env     = type_env,
-                            tcg_imports      = imports,
-                            tcg_exports      = exports,
-                            tcg_keep         = keep_var,
-                            tcg_th_splice_used = tc_splice_used,
-                            tcg_rdr_env      = rdr_env,
-                            tcg_fix_env      = fix_env,
-                            tcg_inst_env     = inst_env,
-                            tcg_fam_inst_env = fam_inst_env,
-                            tcg_merged       = merged,
-                            tcg_warns        = warns,
-                            tcg_anns         = anns,
-                            tcg_binds        = binds,
-                            tcg_imp_specs    = imp_specs,
-                            tcg_dependent_files = dependent_files,
-                            tcg_ev_binds     = ev_binds,
-                            tcg_th_foreign_files = th_foreign_files_var,
-                            tcg_fords        = fords,
-                            tcg_rules        = rules,
-                            tcg_patsyns      = patsyns,
-                            tcg_tcs          = tcs,
-                            tcg_insts        = insts,
-                            tcg_fam_insts    = fam_insts,
-                            tcg_hpc          = other_hpc_info,
-                            tcg_complete_matches = complete_matches,
-                            tcg_self_boot    = self_boot
-                            })
-
-  = do { let dflags = hsc_dflags hsc_env
-             logger = hsc_logger hsc_env
-             ptc = initPromotionTickContext (hsc_dflags hsc_env)
-             name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
-        ; withTiming logger
-                     (text "Desugar"<+>brackets (ppr mod))
-                     (const ()) $
-     do { -- Desugar the program
-        ; let export_set = availsToNameSet exports
-              bcknd      = backend dflags
-
-        ; (binds_cvr, m_tickInfo)
-                         <- if not (isHsBootOrSig hsc_src)
-                              then addTicksToBinds
-                                       (hsc_logger hsc_env)
-                                       (initTicksConfig (hsc_dflags hsc_env))
-                                       mod mod_loc
-                                       export_set (typeEnvTyCons type_env) binds
-                              else return (binds, Nothing)
-        ; modBreaks <- for
-           [ (i, s)
-           | i <- hsc_interp hsc_env
-           , (_, s) <- m_tickInfo
-           , backendWantsBreakpointTicks (backend dflags)
-           ]
-           $ \(interp, specs) -> mkModBreaks interp mod specs
-
-        ; ds_hpc_info <- case m_tickInfo of
-            Just (orig_file2, ticks)
-              | gopt Opt_Hpc $ hsc_dflags hsc_env
-              -> do
-              hashNo <- if gopt Opt_Hpc $ hsc_dflags hsc_env
-                then writeMixEntries (hpcDir dflags) mod ticks orig_file2
-                else return 0 -- dummy hash when none are written
-              pure $ HpcInfo (fromIntegral $ sizeSS ticks) hashNo
-            _ -> pure $ emptyHpcInfo other_hpc_info
-
-        ; (msgs, mb_res) <- initDs hsc_env tcg_env $
-                       do { ds_ev_binds <- dsEvBinds ev_binds
-                          ; core_prs <- dsTopLHsBinds binds_cvr
-                          ; core_prs <- patchMagicDefns core_prs
-                          ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
-                          ; (ds_fords, foreign_prs) <- dsForeigns fords
-                          ; ds_rules <- mapMaybeM dsRule rules
-                          ; let hpc_init
-                                  | gopt Opt_Hpc dflags = hpcInitCode (targetPlatform $ hsc_dflags hsc_env) mod ds_hpc_info
-                                  | otherwise = mempty
-                          ; return ( ds_ev_binds
-                                   , foreign_prs `appOL` core_prs `appOL` spec_prs
-                                   , spec_rules ++ ds_rules
-                                   , ds_fords `appendStubC` hpc_init) }
-
-        ; case mb_res of {
-           Nothing -> return (msgs, Nothing) ;
-           Just (ds_ev_binds, all_prs, all_rules, ds_fords) ->
-
-     do {       -- Add export flags to bindings
-          keep_alive <- readIORef keep_var
-        ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
-              final_prs = addExportFlagsAndRules bcknd export_set keep_alive
-                                                 rules_for_locals (fromOL all_prs)
-
-              final_pgm = combineEvBinds ds_ev_binds final_prs
-        -- Notice that we put the whole lot in a big Rec, even the foreign binds
-        -- When compiling PrelFloat, which defines data Float = F# Float#
-        -- we want F# to be in scope in the foreign marshalling code!
-        -- You might think it doesn't matter, but the simplifier brings all top-level
-        -- things into the in-scope set before simplifying; so we get no unfolding for F#!
-
-        ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugar final_pgm rules_for_imps
-        ; let simpl_opts = initSimpleOpts dflags
-        ; let (ds_binds, ds_rules_for_imps, occ_anald_binds)
-                = simpleOptPgm simpl_opts mod final_pgm rules_for_imps
-                         -- The simpleOptPgm gets rid of type
-                         -- bindings plus any stupid dead code
-        ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"
-            FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps )
-
-        ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugarOpt ds_binds ds_rules_for_imps
-
-        ; let used_names = mkUsedNames tcg_env
-              pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))
-              home_unit = hsc_home_unit hsc_env
-        ; let deps = mkDependencies home_unit
-                                    (tcg_mod tcg_env)
-                                    (tcg_imports tcg_env)
-                                    (map mi_module pluginModules)
-
-        ; used_th <- readIORef tc_splice_used
-        ; dep_files <- readIORef dependent_files
-        ; safe_mode <- finalSafeMode dflags tcg_env
-        ; (needed_mods, needed_pkgs) <- readIORef (tcg_th_needed_deps tcg_env)
-
-        ; let uc = initUsageConfig hsc_env
-        ; let plugins = hsc_plugins hsc_env
-        ; let fc = hsc_FC hsc_env
-        ; let unit_env = hsc_unit_env hsc_env
-        ; usages <- mkUsageInfo uc plugins fc unit_env mod (imp_mods imports) used_names
-                      dep_files merged needed_mods needed_pkgs
-        -- id_mod /= mod when we are processing an hsig, but hsigs
-        -- never desugared and compiled (there's no code!)
-        -- Consequently, this should hold for any ModGuts that make
-        -- past desugaring. See Note [Identity versus semantic module].
-        ; massert (id_mod == mod)
-
-        ; foreign_files <- readIORef th_foreign_files_var
-
-        ; docs <- extractDocs dflags tcg_env
-
-        ; let mod_guts = ModGuts {
-                mg_module       = mod,
-                mg_hsc_src      = hsc_src,
-                mg_loc          = mkFileSrcSpan mod_loc,
-                mg_exports      = exports,
-                mg_usages       = usages,
-                mg_deps         = deps,
-                mg_used_th      = used_th,
-                mg_rdr_env      = rdr_env,
-                mg_fix_env      = fix_env,
-                mg_warns        = warns,
-                mg_anns         = anns,
-                mg_tcs          = tcs,
-                mg_insts        = fixSafeInstances safe_mode insts,
-                mg_fam_insts    = fam_insts,
-                mg_inst_env     = inst_env,
-                mg_fam_inst_env = fam_inst_env,
-                mg_boot_exports = bootExports self_boot,
-                mg_patsyns      = patsyns,
-                mg_rules        = ds_rules_for_imps,
-                mg_binds        = ds_binds,
-                mg_foreign      = ds_fords,
-                mg_foreign_files = foreign_files,
-                mg_hpc_info     = ds_hpc_info,
-                mg_modBreaks    = modBreaks,
-                mg_safe_haskell = safe_mode,
-                mg_trust_pkg    = imp_trust_own_pkg imports,
-                mg_complete_matches = complete_matches,
-                mg_docs         = docs
-              }
-        ; return (msgs, Just mod_guts)
-        }}}}
-
-mkFileSrcSpan :: ModLocation -> SrcSpan
-mkFileSrcSpan mod_loc
-  = case ml_hs_file mod_loc of
-      Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
-      Nothing        -> interactiveSrcSpan   -- Presumably
-
-dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
-dsImpSpecs imp_specs
- = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
-      ; let (spec_binds, spec_rules) = unzip spec_prs
-      ; return (concatOL spec_binds, spec_rules) }
-
-combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
--- Top-level bindings can include coercion bindings, but not via superclasses
--- See Note [Top-level evidence]
-combineEvBinds [] val_prs
-  = [Rec val_prs]
-combineEvBinds (NonRec b r : bs) val_prs
-  | isId b    = combineEvBinds bs ((b,r):val_prs)
-  | otherwise = NonRec b r : combineEvBinds bs val_prs
-combineEvBinds (Rec prs : bs) val_prs
-  = combineEvBinds bs (prs ++ val_prs)
-
-{-
-Note [Top-level evidence]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Top-level evidence bindings may be mutually recursive with the top-level value
-bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
-because the occurrence analyser doesn't take account of type/coercion variables
-when computing dependencies.
-
-So we pull out the type/coercion variables (which are in dependency order),
-and Rec the rest.
--}
-
-deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr)
-deSugarExpr hsc_env tc_expr = do
-    let logger = hsc_logger hsc_env
-
-    showPass logger "Desugar"
-
-    -- Do desugaring
-    (tc_msgs, mb_result) <- runTcInteractive hsc_env $
-                            initDsTc $
-                            dsLExpr tc_expr
-
-    massert (isEmptyMessages tc_msgs)  -- the type-checker isn't doing anything here
-
-      -- mb_result is Nothing only when a failure happens in the type-checker,
-      -- but mb_core_expr is Nothing when a failure happens in the desugarer
-    let (ds_msgs, mb_core_expr) = expectJust "deSugarExpr" mb_result
-
-    case mb_core_expr of
-       Nothing   -> return ()
-       Just expr -> putDumpFileMaybe logger Opt_D_dump_ds "Desugared"
-                    FormatCore (pprCoreExpr expr)
-
-      -- callers (i.e. ioMsgMaybe) expect that no expression is returned if
-      -- there are errors
-    let final_res | errorsFound ds_msgs = Nothing
-                  | otherwise           = mb_core_expr
-
-    return (ds_msgs, final_res)
-
-{-
-************************************************************************
-*                                                                      *
-*              Add rules and export flags to binders
-*                                                                      *
-************************************************************************
--}
-
-addExportFlagsAndRules
-    :: Backend -> NameSet -> NameSet -> [CoreRule]
-    -> [(Id, t)] -> [(Id, t)]
-addExportFlagsAndRules bcknd exports keep_alive rules = mapFst add_one
-  where
-    add_one bndr = add_rules name (add_export name bndr)
-       where
-         name = idName bndr
-
-    ---------- Rules --------
-        -- See Note [Attach rules to local ids]
-        -- NB: the binder might have some existing rules,
-        -- arising from specialisation pragmas
-    add_rules name bndr
-        | Just rules <- lookupNameEnv rule_base name
-        = bndr `addIdSpecialisations` rules
-        | otherwise
-        = bndr
-    rule_base = extendRuleBaseList emptyRuleBase rules
-
-    ---------- Export flag --------
-    -- See Note [Adding export flags]
-    add_export name bndr
-        | dont_discard name = setIdExported bndr
-        | otherwise         = bndr
-
-    dont_discard :: Name -> Bool
-    dont_discard name = is_exported name
-                     || name `elemNameSet` keep_alive
-
-        -- In interactive mode, we don't want to discard any top-level
-        -- entities at all (eg. do not inline them away during
-        -- simplification), and retain them all in the TypeEnv so they are
-        -- available from the command line.
-        --
-        -- isExternalName separates the user-defined top-level names from those
-        -- introduced by the type checker.
-    is_exported :: Name -> Bool
-    is_exported | backendWantsGlobalBindings bcknd = isExternalName
-                | otherwise                       = (`elemNameSet` exports)
-
-{-
-Note [Adding export flags]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Set the no-discard flag if either
-        a) the Id is exported
-        b) it's mentioned in the RHS of an orphan rule
-        c) it's in the keep-alive set
-
-It means that the binding won't be discarded EVEN if the binding
-ends up being trivial (v = w) -- the simplifier would usually just
-substitute w for v throughout, but we don't apply the substitution to
-the rules (maybe we should?), so this substitution would make the rule
-bogus.
-
-You might wonder why exported Ids aren't already marked as such;
-it's just because the type checker is rather busy already and
-I didn't want to pass in yet another mapping.
-
-Note [Attach rules to local ids]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Find the rules for locally-defined Ids; then we can attach them
-to the binders in the top-level bindings
-
-Reason
-  - It makes the rules easier to look up
-  - It means that rewrite rules and specialisations for
-    locally defined Ids are handled uniformly
-  - It keeps alive things that are referred to only from a rule
-    (the occurrence analyser knows about rules attached to Ids)
-  - It makes sure that, when we apply a rule, the free vars
-    of the RHS are more likely to be in scope
-  - The imported rules are carried in the in-scope set
-    which is extended on each iteration by the new wave of
-    local binders; any rules which aren't on the binding will
-    thereby get dropped
-
-
-************************************************************************
-*                                                                      *
-*              Desugaring rewrite rules
-*                                                                      *
-************************************************************************
--}
-
-dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
-dsRule (L loc (HsRule { rd_name = name
-                      , rd_act  = rule_act
-                      , rd_tmvs = vars
-                      , rd_lhs  = lhs
-                      , rd_rhs  = rhs }))
-  = putSrcSpanDs (locA loc) $
-    do  { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]
-
-        ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
-                  unsetWOptM Opt_WarnIdentities $
-                  dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
-
-        ; rhs' <- dsLExpr rhs
-        ; this_mod <- getModule
-
-        ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
-
-        -- Substitute the dict bindings eagerly,
-        -- and take the body apart into a (f args) form
-        ; dflags <- getDynFlags
-        ; case decomposeRuleLhs dflags bndrs'' lhs'' (exprFreeVars rhs'') of {
-                Left msg -> do { diagnosticDs msg; return Nothing } ;
-                Right (final_bndrs, fn_id, args) -> do
-
-        { let is_local = isLocalId fn_id
-                -- NB: isLocalId is False of implicit Ids.  This is good because
-                -- we don't want to attach rules to the bindings of implicit Ids,
-                -- because they don't show up in the bindings until just before code gen
-              fn_name   = idName fn_id
-              simpl_opts = initSimpleOpts dflags
-              final_rhs = simpleOptExpr simpl_opts rhs''    -- De-crap it
-              rule_name = unLoc name
-              rule = mkRule this_mod False is_local rule_name rule_act
-                            fn_name final_bndrs args final_rhs
-        ; dsWarnOrphanRule rule
-        ; dsWarnRuleShadowing fn_id rule
-
-        ; return (Just rule)
-        } } }
-
-dsWarnRuleShadowing :: Id -> CoreRule -> DsM ()
--- See Note [Rules and inlining/other rules]
-dsWarnRuleShadowing fn_id
-    (Rule { ru_name = rule_name, ru_act = rule_act, ru_bndrs = bndrs, ru_args = args})
-  = do { check False fn_id    -- We often have multiple rules for the same Id in a
-                              -- module. Maybe we should check that they don't overlap
-                              -- but currently we don't
-       ; mapM_ (check True) arg_ids }
-  where
-    bndrs_set = mkVarSet bndrs
-    arg_ids = filterOut (`elemVarSet` bndrs_set) $
-              exprsSomeFreeVarsList isId args
-
-    check check_rules_too lhs_id
-      | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
-                       -- If imported with no unfolding, no worries
-      , idInlineActivation lhs_id `competesWith` rule_act
-      = diagnosticDs (DsRuleMightInlineFirst rule_name lhs_id rule_act)
-      | check_rules_too
-      , bad_rule : _ <- get_bad_rules lhs_id
-      = diagnosticDs (DsAnotherRuleMightFireFirst rule_name (ruleName bad_rule) lhs_id)
-      | otherwise
-      = return ()
-
-    get_bad_rules lhs_id
-      = [ rule | rule <- idCoreRules lhs_id
-               , ruleActivation rule `competesWith` rule_act ]
-
-dsWarnRuleShadowing _ _ = return () -- Not expecting built-in rules here
-
--- See Note [Desugaring coerce as cast]
-unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
-unfold_coerce bndrs lhs rhs = do
-    (bndrs', wrap) <- go bndrs
-    return (bndrs', wrap lhs, wrap rhs)
-  where
-    go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
-    go []     = return ([], id)
-    go (v:vs)
-        | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v)
-        , tc `hasKey` coercibleTyConKey = do
-            u <- newUnique
-
-            let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2]
-                v'  = mkLocalCoVar
-                        (mkDerivedInternalName mkRepEqOcc u (getName v)) ty'
-                box = Var (dataConWrapId coercibleDataCon) `mkTyApps`
-                      [k, t1, t2] `App`
-                      Coercion (mkCoVarCo v')
-
-            (bndrs, wrap) <- go vs
-            return (v':bndrs, mkCoreLet (NonRec v box) . wrap)
-        | otherwise = do
-            (bndrs,wrap) <- go vs
-            return (v:bndrs, wrap)
-
-{- Note [Desugaring RULE left hand sides]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For the LHS of a RULE we do *not* want to desugar
-    [x]   to    build (\cn. x `c` n)
-We want to leave explicit lists simply as chains
-of cons's. We can achieve that slightly indirectly by
-switching off EnableRewriteRules.  See GHC.HsToCore.Expr.dsExplicitList.
-
-That keeps the desugaring of list comprehensions simple too.
-
-Nor do we want to warn of conversion identities on the LHS;
-the rule is precisely to optimise them:
-  {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
-
-Note [Desugaring coerce as cast]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We want the user to express a rule saying roughly “mapping a coercion over a
-list can be replaced by a coercion”. But the cast operator of Core (▷) cannot
-be written in Haskell. So we use `coerce` for that (#2110). The user writes
-    map coerce = coerce
-as a RULE, and this optimizes any kind of mapped' casts away, including `map
-MkNewtype`.
-
-For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
-corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
-`let c = MkCoercible co in ...`. This is later simplified to the desired form
-by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
-See also Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt.
-
-Note [Rules and inlining/other rules]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If you have
-  f x = ...
-  g x = ...
-  {-# RULES "rule-for-f" forall x. f (g x) = ... #-}
-then there's a good chance that in a potential rule redex
-    ...f (g e)...
-then 'f' or 'g' will inline before the rule can fire.  Solution: add an
-INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.
-
-Note that this applies to all the free variables on the LHS, both the
-main function and things in its arguments.
-
-We also check if there are Ids on the LHS that have competing RULES.
-In the above example, suppose we had
-  {-# RULES "rule-for-g" forally. g [y] = ... #-}
-Then "rule-for-f" and "rule-for-g" would compete.  Better to add phase
-control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes
-active; or perhaps after "rule-for-g" has become inactive. This is checked
-by 'competesWith'
-
-Class methods have a built-in RULE to select the method from the dictionary,
-so you can't change the phase on this.  That makes id very dubious to
-match on class methods in RULE lhs's.   See #10595.   I'm not happy
-about this. For example in Control.Arrow we have
-
-{-# RULES "compose/arr"   forall f g .
-                          (arr f) . (arr g) = arr (f . g) #-}
-
-and similar, which will elicit exactly these warnings, and risk never
-firing.  But it's not clear what to do instead.  We could make the
-class method rules inactive in phase 2, but that would delay when
-subsequent transformations could fire.
--}
-
-{-
-************************************************************************
-*                                                                      *
-*              Magic definitions
-*                                                                      *
-************************************************************************
-
-Note [Patching magic definitions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We sometimes need to have access to defined Ids in pure contexts. Usually, we
-simply "wire in" these entities, as we do for types in GHC.Builtin.Types and for Ids
-in GHC.Types.Id.Make. See Note [Wired-in Ids] in GHC.Types.Id.Make.
-
-However, it is sometimes *much* easier to define entities in Haskell,
-even if we need pure access; note that wiring-in an Id requires all
-entities used in its definition *also* to be wired in, transitively
-and recursively.  This can be a huge pain.  The little trick
-documented here allows us to have the best of both worlds.
-
-Motivating example: unsafeCoerce#. See [Wiring in unsafeCoerce#] for the
-details.
-
-The trick is to
-
-* Define the known-key Id in a library module, with a stub definition,
-     unsafeCoerce# :: ..a suitable type signature..
-     unsafeCoerce# = error "urk"
-
-* Magically over-write its RHS here in the desugarer, in
-  patchMagicDefns.  This update can be done with full access to the
-  DsM monad, and hence, dsLookupGlobal. We thus do not have to wire in
-  all the entities used internally, a potentially big win.
-
-  This step should not change the Name or type of the Id.
-
-Because an Id stores its unfolding directly (as opposed to in the second
-component of a (Id, CoreExpr) pair), the patchMagicDefns function returns
-a new Id to use.
-
-Here are the moving parts:
-
-- patchMagicDefns checks whether we're in a module with magic definitions;
-  if so, patch the magic definitions. If not, skip.
-
-- patchMagicDefn just looks up in an environment to find a magic defn and
-  patches it in.
-
-- magicDefns holds the magic definitions.
-
-- magicDefnsEnv allows for quick access to magicDefns.
-
-- magicDefnModules, built also from magicDefns, contains the modules that
-  need careful attention.
-
-Note [Wiring in unsafeCoerce#]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We want (Haskell)
-
-  unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
-                          (a :: TYPE r1) (b :: TYPE r2).
-                   a -> b
-  unsafeCoerce# x = case unsafeEqualityProof @r1 @r2 of
-    UnsafeRefl -> case unsafeEqualityProof @a @b of
-      UnsafeRefl -> x
-
-or (Core)
-
-  unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
-                          (a :: TYPE r1) (b :: TYPE r2).
-                   a -> b
-  unsafeCoerce# = \ @r1 @r2 @a @b (x :: a).
-    case unsafeEqualityProof @RuntimeRep @r1 @r2 of
-      UnsafeRefl (co1 :: r1 ~# r2) ->
-        case unsafeEqualityProof @(TYPE r2) @(a |> TYPE co1) @b of
-          UnsafeRefl (co2 :: (a |> TYPE co1) ~# b) ->
-            (x |> (GRefl :: a ~# (a |> TYPE co1)) ; co2)
-
-It looks like we can write this in Haskell directly, but we can't:
-the representation polymorphism checks defeat us. Note that `x` is a
-representation-polymorphic variable. So we must wire it in with a
-compulsory unfolding, like other representation-polymorphic primops.
-
-The challenge is that UnsafeEquality is a GADT, and wiring in a GADT
-is *hard*: it has a worker separate from its wrapper, with all manner
-of complications. (Simon and Richard tried to do this. We nearly wept.)
-
-The solution is documented in Note [Patching magic definitions]. We now
-simply look up the UnsafeEquality GADT in the environment, leaving us
-only to wire in unsafeCoerce# directly.
-
-Wrinkle: see Note [Always expose compulsory unfoldings] in GHC.Iface.Tidy
--}
-
-
--- Postcondition: the returned Ids are in one-to-one correspondence as the
--- input Ids; each returned Id has the same type as the passed-in Id.
--- See Note [Patching magic definitions]
-patchMagicDefns :: OrdList (Id,CoreExpr)
-                -> DsM (OrdList (Id,CoreExpr))
-patchMagicDefns pairs
-  -- optimization: check whether we're in a magic module before looking
-  -- at all the ids
-  = do { this_mod <- getModule
-       ; if this_mod `elemModuleSet` magicDefnModules
-         then traverse patchMagicDefn pairs
-         else return pairs }
-
-patchMagicDefn :: (Id, CoreExpr) -> DsM (Id, CoreExpr)
-patchMagicDefn orig_pair@(orig_id, orig_rhs)
-  | Just mk_magic_pair <- lookupNameEnv magicDefnsEnv (getName orig_id)
-  = do { magic_pair@(magic_id, _) <- mk_magic_pair orig_id orig_rhs
-
-       -- Patching should not change the Name or the type of the Id
-       ; massert (getUnique magic_id == getUnique orig_id)
-       ; massert (varType magic_id `eqType` varType orig_id)
-
-       ; return magic_pair }
-  | otherwise
-  = return orig_pair
-
-magicDefns :: [(Name,    Id -> CoreExpr     -- old Id and RHS
-                      -> DsM (Id, CoreExpr) -- new Id and RHS
-               )]
-magicDefns = [ (unsafeCoercePrimName, mkUnsafeCoercePrimPair) ]
-
-magicDefnsEnv :: NameEnv (Id -> CoreExpr -> DsM (Id, CoreExpr))
-magicDefnsEnv = mkNameEnv magicDefns
-
-magicDefnModules :: ModuleSet
-magicDefnModules = mkModuleSet $ map (nameModule . getName . fst) magicDefns
-
-mkUnsafeCoercePrimPair :: Id -> CoreExpr -> DsM (Id, CoreExpr)
--- See Note [Wiring in unsafeCoerce#] for the defn we are creating here
-mkUnsafeCoercePrimPair _old_id old_expr
-  = do { unsafe_equality_proof_id <- dsLookupGlobalId unsafeEqualityProofName
-       ; unsafe_equality_tc       <- dsLookupTyCon unsafeEqualityTyConName
-
-       ; let [unsafe_refl_data_con] = tyConDataCons unsafe_equality_tc
-
-             rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar
-                          , openAlphaTyVar, openBetaTyVar
-                          , x ] $
-                   mkSingleAltCase scrut1
-                                   (mkWildValBinder ManyTy scrut1_ty)
-                                   (DataAlt unsafe_refl_data_con)
-                                   [rr_cv] $
-                   mkSingleAltCase scrut2
-                                   (mkWildValBinder ManyTy scrut2_ty)
-                                   (DataAlt unsafe_refl_data_con)
-                                   [ab_cv] $
-                   Var x `mkCast` x_co
-
-             [x, rr_cv, ab_cv] = mkTemplateLocals
-               [ openAlphaTy -- x :: a
-               , rr_cv_ty    -- rr_cv :: r1 ~# r2
-               , ab_cv_ty    -- ab_cv :: (alpha |> alpha_co ~# beta)
-               ]
-
-             -- Returns (scrutinee, scrutinee type, type of covar in AltCon)
-             unsafe_equality k a b
-               = ( mkTyApps (Var unsafe_equality_proof_id) [k,b,a]
-                 , mkTyConApp unsafe_equality_tc [k,b,a]
-                 , mkHeteroPrimEqPred k k a b
-                 )
-             -- NB: UnsafeRefl :: (b ~# a) -> UnsafeEquality a b, so we have to
-             -- carefully swap the arguments above
-
-             (scrut1, scrut1_ty, rr_cv_ty) = unsafe_equality runtimeRepTy
-                                                             runtimeRep1Ty
-                                                             runtimeRep2Ty
-             (scrut2, scrut2_ty, ab_cv_ty) = unsafe_equality (mkTYPEapp runtimeRep2Ty)
-                                                             (openAlphaTy `mkCastTy` alpha_co)
-                                                             openBetaTy
-
-             -- alpha_co :: TYPE r1 ~# TYPE r2
-             -- alpha_co = TYPE rr_cv
-             alpha_co = mkTyConAppCo Nominal tYPETyCon [mkCoVarCo rr_cv]
-
-             -- x_co :: alpha ~R# beta
-             x_co = mkGReflCo Representational openAlphaTy (MCo alpha_co) `mkTransCo`
-                    mkSubCo (mkCoVarCo ab_cv)
-
-
-             info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
-                                `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-                                `setArityInfo`     arity
-
-             ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar
-                                  , openAlphaTyVar, openBetaTyVar ] $
-                  mkVisFunTyMany openAlphaTy openBetaTy
-
-             arity = 1
-
-             id   = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info
-       ; return (id, old_expr) }
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ /dev/null
@@ -1,1263 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE TupleSections #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Desugaring arrow commands
--}
-
-module GHC.HsToCore.Arrows ( dsProcExpr ) where
-
-import GHC.Prelude
-
-import GHC.HsToCore.Match
-import GHC.HsToCore.Utils
-import GHC.HsToCore.Monad
-
-import GHC.Hs
-import GHC.Hs.Syn.Type
-
--- NB: The desugarer, which straddles the source and Core worlds, sometimes
---     needs to see source types (newtypes etc), and sometimes not
---     So WATCH OUT; check each use of split*Ty functions.
--- Sigh.  This is a pain.
-
-import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLocalBinds,
-                                          dsSyntaxExpr )
-
-import GHC.Tc.Utils.TcType
-import GHC.Core.Multiplicity
-import GHC.Tc.Types.Evidence
-import GHC.Core
-import GHC.Core.FVs
-import GHC.Core.Utils
-import GHC.Core.Make
-import GHC.HsToCore.Binds (dsHsWrapper)
-
-
-import GHC.Types.Id
-import GHC.Core.ConLike
-import GHC.Builtin.Types
-import GHC.Types.Basic
-import GHC.Builtin.Names
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Types.Var.Set
-import GHC.Types.SrcLoc
-import GHC.Data.List.SetOps( assocMaybe )
-import Data.Foldable (toList)
-import Data.List (mapAccumL)
-import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
-import GHC.Utils.Misc
-import GHC.Types.Unique.DSet
-
-data DsCmdEnv = DsCmdEnv {
-        arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
-    }
-
-mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv)
--- See Note [CmdSyntaxTable] in GHC.Hs.Expr
-mkCmdEnv tc_meths
-  = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths
-
-       -- NB: Some of these lookups might fail, but that's OK if the
-       -- symbol is never used. That's why we use Maybe first and then
-       -- panic. An eager panic caused trouble in typecheck/should_compile/tc192
-       ; let the_arr_id     = assocMaybe prs arrAName
-             the_compose_id = assocMaybe prs composeAName
-             the_first_id   = assocMaybe prs firstAName
-             the_app_id     = assocMaybe prs appAName
-             the_choice_id  = assocMaybe prs choiceAName
-             the_loop_id    = assocMaybe prs loopAName
-
-       ; return (meth_binds, DsCmdEnv {
-               arr_id     = Var (unmaybe the_arr_id arrAName),
-               compose_id = Var (unmaybe the_compose_id composeAName),
-               first_id   = Var (unmaybe the_first_id firstAName),
-               app_id     = Var (unmaybe the_app_id appAName),
-               choice_id  = Var (unmaybe the_choice_id choiceAName),
-               loop_id    = Var (unmaybe the_loop_id loopAName)
-             }) }
-  where
-    mk_bind (std_name, expr)
-      = do { rhs <- dsExpr expr
-           ; id <- newSysLocalDs ManyTy (exprType rhs)
-           -- no check needed; these are functions
-           ; return (NonRec id rhs, (std_name, id)) }
-
-    unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name)
-    unmaybe (Just id) _  = id
-
--- arr :: forall b c. (b -> c) -> a b c
-do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
-do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]
-
--- (>>>) :: forall b c d. a b c -> a c d -> a b d
-do_compose :: DsCmdEnv -> Type -> Type -> Type ->
-                CoreExpr -> CoreExpr -> CoreExpr
-do_compose ids b_ty c_ty d_ty f g
-  = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]
-
--- first :: forall b c d. a b c -> a (b,d) (c,d)
-do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
-do_first ids b_ty c_ty d_ty f
-  = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]
-
--- app :: forall b c. a (a b c, b) c
-do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
-do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]
-
--- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
--- note the swapping of d and c
-do_choice :: DsCmdEnv -> Type -> Type -> Type ->
-                CoreExpr -> CoreExpr -> CoreExpr
-do_choice ids b_ty c_ty d_ty f g
-  = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]
-
--- loop :: forall b d c. a (b,d) (c,d) -> a b c
--- note the swapping of d and c
-do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
-do_loop ids b_ty c_ty d_ty f
-  = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]
-
--- premap :: forall b c d. (b -> c) -> a c d -> a b d
--- premap f g = arr f >>> g
-do_premap :: DsCmdEnv -> Type -> Type -> Type ->
-                CoreExpr -> CoreExpr -> CoreExpr
-do_premap ids b_ty c_ty d_ty f g
-   = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g
-
--- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a
-mkFstExpr :: Type -> Type -> DsM CoreExpr
-mkFstExpr a_ty b_ty = do
-    a_var <- newSysLocalDs ManyTy a_ty
-    b_var <- newSysLocalDs ManyTy b_ty
-    pair_var <- newSysLocalDs ManyTy (mkCorePairTy a_ty b_ty)
-    return (Lam pair_var
-               (coreCasePair pair_var a_var b_var (Var a_var)))
-
--- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
-mkSndExpr :: Type -> Type -> DsM CoreExpr
-mkSndExpr a_ty b_ty = do
-    a_var <- newSysLocalDs ManyTy a_ty
-    b_var <- newSysLocalDs ManyTy b_ty
-    pair_var <- newSysLocalDs ManyTy (mkCorePairTy a_ty b_ty)
-    return (Lam pair_var
-               (coreCasePair pair_var a_var b_var (Var b_var)))
-
-{-
-Build case analysis of a tuple.  This cannot be done in the DsM monad,
-because the list of variables is typically not yet defined.
--}
-
--- coreCaseTuple [u1..] v [x1..xn] body
---      = case v of v { (x1, .., xn) -> body }
--- But the matching may be nested if the tuple is very big
-
-coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
-coreCaseTuple uniqs scrut_var vars body
-  = mkBigTupleCase uniqs vars body (Var scrut_var)
-
-coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
-coreCasePair scrut_var var1 var2 body
-  = Case (Var scrut_var) scrut_var (exprType body)
-         [Alt (DataAlt (tupleDataCon Boxed 2)) [var1, var2] body]
-
-mkCorePairTy :: Type -> Type -> Type
-mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]
-
-mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
-mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
-
-mkCoreUnitExpr :: CoreExpr
-mkCoreUnitExpr = mkCoreTup []
-
-{- Note [Environment and stack]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The input is divided into
-
-* A local environment, which is a flat tuple (unless it's too big)
-  The elements of the local environment can be
-  - of kind Type (for ordinary variables), or
-  - of kind Constraint (for dictionaries bound by patterns)
-
-* A stack, which is a right-nested pair.
-  The elements on the stack are always of kind Type.
-
-So in general, the input has the form
-
-        ((x1,...,xn), (s1,...(sk,())...))
-
-where xi are the environment values, and si the ones on the stack,
-with s1 being the "top", the first one to be matched with a lambda.
--}
-
-envStackType :: [Id] -> Type -> Type
-envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty
-
--- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t)
-splitTypeAt :: Int -> Type -> ([Type], Type)
-splitTypeAt n ty
-  | n == 0 = ([], ty)
-  | otherwise = case tcTyConAppArgs ty of
-      [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r)
-      _ -> pprPanic "splitTypeAt" (ppr ty)
-
-----------------------------------------------
---              buildEnvStack
---
---      ((x1,...,xn),stk)
-
-buildEnvStack :: [Id] -> Id -> CoreExpr
-buildEnvStack env_ids stack_id
-  = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id)
-
-----------------------------------------------
---              matchEnvStack
---
---      \ ((x1,...,xn),stk) -> body
---      =>
---      \ pair ->
---      case pair of (tup,stk) ->
---      case tup of (x1,...,xn) ->
---      body
-
-matchEnvStack   :: [Id]         -- x1..xn
-                -> Id           -- stk
-                -> CoreExpr     -- e
-                -> DsM CoreExpr
-matchEnvStack env_ids stack_id body = do
-    uniqs <- newUniqueSupply
-    tup_var <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids)
-    let match_env = coreCaseTuple uniqs tup_var env_ids body
-    pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType tup_var) (idType stack_id))
-    return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))
-
-----------------------------------------------
---              matchEnv
---
---      \ (x1,...,xn) -> body
---      =>
---      \ tup ->
---      case tup of (x1,...,xn) ->
---      body
-
-matchEnv :: [Id]        -- x1..xn
-         -> CoreExpr    -- e
-         -> DsM CoreExpr
-matchEnv env_ids body = do
-    uniqs <- newUniqueSupply
-    tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy env_ids)
-    return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))
-
-----------------------------------------------
---              matchVarStack
---
---      case (x1, ...(xn, s)...) -> e
---      =>
---      case z0 of (x1,z1) ->
---      case zn-1 of (xn,s) ->
---      e
-matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
-matchVarStack [] stack_id body = return (stack_id, body)
-matchVarStack (param_id:param_ids) stack_id body = do
-    (tail_id, tail_code) <- matchVarStack param_ids stack_id body
-    pair_id <- newSysLocalDs ManyTy (mkCorePairTy (idType param_id) (idType tail_id))
-    return (pair_id, coreCasePair pair_id param_id tail_id tail_code)
-
-mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc
-mkHsEnvStackExpr env_ids stack_id
-  = mkLHsTupleExpr [mkLHsVarTuple env_ids noExtField, nlHsVar stack_id]
-                   noExtField
-
--- Translation of arrow abstraction
-
--- D; xs |-a c : () --> t'      ---> c'
--- --------------------------
--- D |- proc p -> c :: a t t'   ---> premap (\ p -> ((xs),())) c'
---
---              where (xs) is the tuple of variables bound by p
-
-dsProcExpr
-        :: LPat GhcTc
-        -> LHsCmdTop GhcTc
-        -> DsM CoreExpr
-dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
-    (meth_binds, meth_ids) <- mkCmdEnv ids
-    let locals = mkVarSet (collectPatBinders CollWithDictBinders pat)
-    (core_cmd, _free_vars, env_ids)
-       <- dsfixCmd meth_ids locals unitTy cmd_ty cmd
-    let env_ty = mkBigCoreVarTupTy env_ids
-    let env_stk_ty = mkCorePairTy env_ty unitTy
-    let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr
-    fail_expr <- mkFailExpr (ArrowMatchCtxt ProcExpr) env_stk_ty
-    var <- selectSimpleMatchVarL ManyTy pat
-    match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) pat env_stk_expr fail_expr
-    let pat_ty = hsLPatType pat
-    let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty
-                    (Lam var match_code)
-                    core_cmd
-    return (mkLets meth_binds proc_code)
-
-{-
-Translation of a command judgement of the form
-
-        D; xs |-a c : stk --> t
-
-to an expression e such that
-
-        D |- e :: a (xs, stk) t
--}
-
-dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id]
-       -> DsM (CoreExpr, DIdSet)
-dsLCmd ids local_vars stk_ty res_ty cmd env_ids
-  = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids
-
-dsCmd   :: DsCmdEnv             -- arrow combinators
-        -> IdSet                -- set of local vars available to this command
-        -> Type                 -- type of the stack (right-nested tuple)
-        -> Type                 -- return type of the command
-        -> HsCmd GhcTc           -- command to desugar
-        -> [Id]           -- list of vars in the input to this command
-                                -- This is typically fed back,
-                                -- so don't pull on it too early
-        -> DsM (CoreExpr,       -- desugared expression
-                DIdSet)         -- subset of local vars that occur free
-
--- D |- fun :: a t1 t2
--- D, xs |- arg :: t1
--- -----------------------------
--- D; xs |-a fun -< arg : stk --> t2
---
---              ---> premap (\ ((xs), _stk) -> arg) fun
-
-dsCmd ids local_vars stack_ty res_ty
-        (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _)
-        env_ids = do
-    let
-        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
-        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
-    core_arrow <- dsLExpr arrow
-    core_arg   <- dsLExpr arg
-    stack_id   <- newSysLocalDs ManyTy stack_ty
-    core_make_arg <- matchEnvStack env_ids stack_id core_arg
-    return (do_premap ids
-              (envStackType env_ids stack_ty)
-              arg_ty
-              res_ty
-              core_make_arg
-              core_arrow,
-            exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars)
-
--- D, xs |- fun :: a t1 t2
--- D, xs |- arg :: t1
--- ------------------------------
--- D; xs |-a fun -<< arg : stk --> t2
---
---              ---> premap (\ ((xs), _stk) -> (fun, arg)) app
-
-dsCmd ids local_vars stack_ty res_ty
-        (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _)
-        env_ids = do
-    let
-        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
-        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
-
-    core_arrow <- dsLExpr arrow
-    core_arg   <- dsLExpr arg
-    stack_id   <- newSysLocalDs ManyTy stack_ty
-    core_make_pair <- matchEnvStack env_ids stack_id
-          (mkCorePairExpr core_arrow core_arg)
-
-    return (do_premap ids
-              (envStackType env_ids stack_ty)
-              (mkCorePairTy arrow_ty arg_ty)
-              res_ty
-              core_make_pair
-              (do_app ids arg_ty res_ty),
-            (exprsFreeIdsDSet [core_arrow, core_arg])
-              `uniqDSetIntersectUniqSet` local_vars)
-
--- D; ys |-a cmd : (t,stk) --> t'
--- D, xs |-  exp :: t
--- ------------------------
--- D; xs |-a cmd exp : stk --> t'
---
---              ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
-
-dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do
-    core_arg <- dsLExpr arg
-    let
-        arg_ty = exprType core_arg
-        stack_ty' = mkCorePairTy arg_ty stack_ty
-    (core_cmd, free_vars, env_ids')
-             <- dsfixCmd ids local_vars stack_ty' res_ty cmd
-    stack_id <- newSysLocalDs ManyTy stack_ty
-    arg_id <- newSysLocalDs ManyTy arg_ty
-    -- push the argument expression onto the stack
-    let
-        stack' = mkCorePairExpr (Var arg_id) (Var stack_id)
-        core_body = bindNonRec arg_id core_arg
-                        (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')
-
-    -- match the environment and stack against the input
-    core_map <- matchEnvStack env_ids stack_id core_body
-    return (do_premap ids
-                      (envStackType env_ids stack_ty)
-                      (envStackType env_ids' stack_ty')
-                      res_ty
-                      core_map
-                      core_cmd,
-            free_vars `unionDVarSet`
-              (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars))
-
-dsCmd ids local_vars stack_ty res_ty
-        (HsCmdLam _ (MG { mg_alts
-          = (L _ [L _ (Match { m_pats  = pats
-                             , m_grhss = GRHSs _ [L _ (GRHS _ [] body)] _ })]) }))
-        env_ids
-  = dsCmdLam ids local_vars stack_ty res_ty pats body env_ids
-
-dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ _ cmd _) env_ids
-  = dsLCmd ids local_vars stack_ty res_ty cmd env_ids
-
--- D, xs |- e :: Bool
--- D; xs1 |-a c1 : stk --> t
--- D; xs2 |-a c2 : stk --> t
--- ----------------------------------------
--- D; xs |-a if e then c1 else c2 : stk --> t
---
---              ---> premap (\ ((xs),stk) ->
---                       if e then Left ((xs1),stk) else Right ((xs2),stk))
---                     (c1 ||| c2)
-
-dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd)
-        env_ids = do
-    core_cond <- dsLExpr cond
-    (core_then, fvs_then, then_ids)
-       <- dsfixCmd ids local_vars stack_ty res_ty then_cmd
-    (core_else, fvs_else, else_ids)
-       <- dsfixCmd ids local_vars stack_ty res_ty else_cmd
-    stack_id   <- newSysLocalDs ManyTy stack_ty
-    either_con <- dsLookupTyCon eitherTyConName
-    left_con   <- dsLookupDataCon leftDataConName
-    right_con  <- dsLookupDataCon rightDataConName
-
-    let mk_left_expr ty1 ty2 e = mkCoreConApps left_con   [Type ty1,Type ty2, e]
-        mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1,Type ty2, e]
-
-        in_ty = envStackType env_ids stack_ty
-        then_ty = envStackType then_ids stack_ty
-        else_ty = envStackType else_ids stack_ty
-        sum_ty = mkTyConApp either_con [then_ty, else_ty]
-        fvs_cond = exprFreeIdsDSet core_cond
-                   `uniqDSetIntersectUniqSet` local_vars
-
-        core_left  = mk_left_expr  then_ty else_ty
-                       (buildEnvStack then_ids stack_id)
-        core_right = mk_right_expr then_ty else_ty
-                       (buildEnvStack else_ids stack_id)
-
-    core_if <- case mb_fun of
-       NoSyntaxExprTc  -> matchEnvStack env_ids stack_id $
-                          mkIfThenElse core_cond core_left core_right
-       _ -> do { fun_apps <- dsSyntaxExpr mb_fun
-                                      [core_cond, core_left, core_right]
-               ; matchEnvStack env_ids stack_id fun_apps }
-
-    return (do_premap ids in_ty sum_ty res_ty
-                core_if
-                (do_choice ids then_ty else_ty res_ty core_then core_else),
-        fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else)
-
-{-
-Note [Desugaring HsCmdCase]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Case commands are treated in much the same way as if commands
-(see above) except that there are more alternatives.  For example
-
-        case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
-
-is translated to
-
-        premap (\ ((xs)*ts) -> case e of
-                p1 -> (Left (Left (xs1)*ts))
-                p2 -> Left ((Right (xs2)*ts))
-                p3 -> Right ((xs3)*ts))
-        ((c1 ||| c2) ||| c3)
-
-The idea is to extract the commands from the case, build a balanced tree
-of choices, and replace the commands with expressions that build tagged
-tuples, obtaining a case expression that can be desugared normally.
-To build all this, we use triples describing segments of the list of
-case bodies, containing the following fields:
- * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
-   into the case replacing the commands
- * a sum type that is the common type of these expressions, and also the
-   input type of the arrow
- * a CoreExpr for an arrow built by combining the translated command
-   bodies with |||.
--}
-
-dsCmd ids local_vars stack_ty res_ty (HsCmdCase _ exp match) env_ids = do
-    stack_id <- newSysLocalDs ManyTy stack_ty
-    (match', core_choices)
-      <- dsCases ids local_vars stack_id stack_ty res_ty match
-    let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match'
-        in_ty = envStackType env_ids stack_ty
-
-    core_body <- dsExpr (HsCase noExtField exp match')
-
-    core_matches <- matchEnvStack env_ids stack_id core_body
-    return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
-            exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars)
-
-{-
-\cases and \case are desugared analogously to a case command (see above).
-For example
-
-        \cases {p1 q1 -> c1; p2 q2 -> c2; p3 q3 -> c3 }
-
-is translated to
-
-        premap (\ ((xs), (e1, (e2,stk))) -> cases e1 e2 of
-                  p1 q1 -> (Left (Left (xs1), stk))
-                  p2 q2 -> Left ((Right (xs2), stk))
-                  p3 q3 -> Right ((xs3), stk))
-        ((c1 ||| c2) ||| c3)
-
-(cases...of is hypothetical notation that works like case...of but with
-multiple scrutinees)
-
--}
-dsCmd ids local_vars stack_ty res_ty
-      (HsCmdLamCase _ lc_variant match@MG { mg_ext = MatchGroupTc {mg_arg_tys = arg_tys} } )
-      env_ids = do
-    arg_ids <- newSysLocalsDs arg_tys
-
-    let match_ctxt = ArrowLamCaseAlt lc_variant
-        pat_vars = mkVarSet arg_ids
-        local_vars' = pat_vars `unionVarSet` local_vars
-        (pat_tys, stack_ty') = splitTypeAt (length arg_tys) stack_ty
-
-    -- construct and desugar a case expression with multiple scrutinees
-    (core_body, free_vars, env_ids') <- trimInput \env_ids -> do
-      stack_id <- newSysLocalDs ManyTy stack_ty'
-      (match', core_choices)
-        <- dsCases ids local_vars' stack_id stack_ty' res_ty match
-
-      let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match'
-          in_ty = envStackType env_ids stack_ty'
-          discrims = map nlHsVar arg_ids
-      (discrim_vars, matching_code)
-        <- matchWrapper (ArrowMatchCtxt match_ctxt) (Just discrims) match'
-      core_body <- flip (bind_vars discrim_vars) matching_code <$>
-        traverse dsLExpr discrims
-
-      core_matches <- matchEnvStack env_ids stack_id core_body
-      return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
-              exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars')
-
-    param_ids <- mapM (newSysLocalDs ManyTy) pat_tys
-    stack_id' <- newSysLocalDs ManyTy stack_ty'
-
-    -- the expression is built from the inside out, so the actions
-    -- are presented in reverse order
-
-    let -- build a new environment, plus what's left of the stack
-        core_expr = buildEnvStack env_ids' stack_id'
-        in_ty = envStackType env_ids stack_ty
-        in_ty' = envStackType env_ids' stack_ty'
-
-    -- bind the scrutinees to the parameters
-    let match_code = bind_vars arg_ids (map Var param_ids) core_expr
-
-    -- match the parameters against the top of the old stack
-    (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code
-    -- match the old environment and stack against the input
-    select_code <- matchEnvStack env_ids stack_id param_code
-    return (do_premap ids in_ty in_ty' res_ty select_code core_body,
-            free_vars `uniqDSetMinusUniqSet` pat_vars)
-    where
-      bind_vars vars exprs expr = foldr (uncurry bindNonRec) expr $ zip vars exprs
-
--- D; ys |-a cmd : stk --> t
--- ----------------------------------
--- D; xs |-a let binds in cmd : stk --> t
---
---              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
-
-dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ _ lbinds@binds _ body) env_ids = do
-    let
-        defined_vars = mkVarSet (collectLocalBinders CollWithDictBinders binds)
-        local_vars' = defined_vars `unionVarSet` local_vars
-
-    (core_body, _free_vars, env_ids')
-       <- dsfixCmd ids local_vars' stack_ty res_ty body
-    stack_id <- newSysLocalDs ManyTy stack_ty
-    -- build a new environment, plus the stack, using the let bindings
-    core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)
-    -- match the old environment and stack against the input
-    core_map <- matchEnvStack env_ids stack_id core_binds
-    return (do_premap ids
-                        (envStackType env_ids stack_ty)
-                        (envStackType env_ids' stack_ty)
-                        res_ty
-                        core_map
-                        core_body,
-        exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)
-
--- D; xs |-a ss : t
--- ----------------------------------
--- D; xs |-a do { ss } : () --> t
---
---              ---> premap (\ (env,stk) -> env) c
-
-dsCmd ids local_vars stack_ty res_ty (HsCmdDo _ (L _ stmts)) env_ids = do
-    (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
-    let env_ty = mkBigCoreVarTupTy env_ids
-    core_fst <- mkFstExpr env_ty stack_ty
-    return (do_premap ids
-                (mkCorePairTy env_ty stack_ty)
-                env_ty
-                res_ty
-                core_fst
-                core_stmts,
-        env_ids')
-
--- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t
--- D; xs |-a ci :: stki --> ti
--- -----------------------------------
--- D; xs |-a (|e c1 ... cn|) :: stk --> t       ---> e [t_xs] c1 ... cn
-
-dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
-    let env_ty = mkBigCoreVarTupTy env_ids
-    core_op <- dsLExpr op
-    (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
-    return (mkApps (App core_op (Type env_ty)) core_args,
-            unionDVarSets fv_sets)
-
-dsCmd ids local_vars stack_ty res_ty (XCmd (HsWrap wrap cmd)) env_ids = do
-    (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
-    core_wrap <- dsHsWrapper wrap
-    return (core_wrap core_cmd, env_ids')
-
-dsCmd _ _ _ _ c _ = pprPanic "dsCmd" (ppr c)
-
--- D; ys |-a c : stk --> t      (ys <= xs)
--- ---------------------
--- D; xs |-a c : stk --> t      ---> premap (\ ((xs),stk) -> ((ys),stk)) c
-
-dsTrimCmdArg
-        :: IdSet                -- set of local vars available to this command
-        -> [Id]           -- list of vars in the input to this command
-        -> LHsCmdTop GhcTc       -- command argument to desugar
-        -> DsM (CoreExpr,       -- desugared expression
-                DIdSet)         -- subset of local vars that occur free
-dsTrimCmdArg local_vars env_ids
-                       (L _ (HsCmdTop
-                                 (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
-    (meth_binds, meth_ids) <- mkCmdEnv ids
-    (core_cmd, free_vars, env_ids')
-       <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
-    stack_id <- newSysLocalDs ManyTy stack_ty
-    trim_code
-      <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)
-    let
-        in_ty = envStackType env_ids stack_ty
-        in_ty' = envStackType env_ids' stack_ty
-        arg_code = if env_ids' == env_ids then core_cmd else
-                do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
-    return (mkLets meth_binds arg_code, free_vars)
-
--- Given D; xs |-a c : stk --> t, builds c with xs fed back.
--- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
-
-dsfixCmd
-        :: DsCmdEnv             -- arrow combinators
-        -> IdSet                -- set of local vars available to this command
-        -> Type                 -- type of the stack (right-nested tuple)
-        -> Type                 -- return type of the command
-        -> LHsCmd GhcTc         -- command to desugar
-        -> DsM (CoreExpr,       -- desugared expression
-                DIdSet,         -- subset of local vars that occur free
-                [Id])           -- the same local vars as a list, fed back
-dsfixCmd ids local_vars stk_ty cmd_ty cmd
-  = trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd)
-
--- Feed back the list of local variables actually used a command,
--- for use as the input tuple of the generated arrow.
-
-trimInput
-        :: ([Id] -> DsM (CoreExpr, DIdSet))
-        -> DsM (CoreExpr,       -- desugared expression
-                DIdSet,         -- subset of local vars that occur free
-                [Id])           -- same local vars as a list, fed back to
-                                -- the inner function to form the tuple of
-                                -- inputs to the arrow.
-trimInput build_arrow
-  = fixDs (\ ~(_,_,env_ids) -> do
-        (core_cmd, free_vars) <- build_arrow env_ids
-        return (core_cmd, free_vars, dVarSetElems free_vars))
-
--- Desugaring for both HsCmdLam
---
--- D; ys |-a cmd : stk t'
--- -----------------------------------------------
--- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'
---
---              ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
-dsCmdLam :: DsCmdEnv            -- arrow combinators
-         -> IdSet               -- set of local vars available to this command
-         -> Type                -- type of the stack (right-nested tuple)
-         -> Type                -- return type of the command
-         -> [LPat GhcTc]        -- argument patterns to desugar
-         -> LHsCmd GhcTc        -- body to desugar
-         -> [Id]                -- list of vars in the input to this command
-                                -- This is typically fed back,
-                                -- so don't pull on it too early
-         -> DsM (CoreExpr,      -- desugared expression
-                 DIdSet)        -- subset of local vars that occur free
-dsCmdLam ids local_vars stack_ty res_ty pats body env_ids = do
-    let pat_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats)
-    let local_vars' = pat_vars `unionVarSet` local_vars
-        (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty
-    (core_body, free_vars, env_ids')
-       <- dsfixCmd ids local_vars' stack_ty' res_ty body
-    param_ids <- mapM (newSysLocalDs ManyTy) pat_tys
-    stack_id' <- newSysLocalDs ManyTy stack_ty'
-
-    -- the expression is built from the inside out, so the actions
-    -- are presented in reverse order
-
-    let -- build a new environment, plus what's left of the stack
-        core_expr = buildEnvStack env_ids' stack_id'
-        in_ty = envStackType env_ids stack_ty
-        in_ty' = envStackType env_ids' stack_ty'
-
-    fail_expr <- mkFailExpr (ArrowMatchCtxt KappaExpr) in_ty'
-    -- match the patterns against the parameters
-    match_code <- matchSimplys (map Var param_ids) (ArrowMatchCtxt KappaExpr) pats core_expr
-                    fail_expr
-    -- match the parameters against the top of the old stack
-    (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code
-    -- match the old environment and stack against the input
-    select_code <- matchEnvStack env_ids stack_id param_code
-    return (do_premap ids in_ty in_ty' res_ty select_code core_body,
-            free_vars `uniqDSetMinusUniqSet` pat_vars)
-
--- Used for case and \case(s)
--- See Note [Desugaring HsCmdCase]
-dsCases :: DsCmdEnv                               -- arrow combinators
-        -> IdSet                                  -- set of local vars available to this command
-        -> Id                                     -- stack id
-        -> Type                                   -- type of the stack (right-nested tuple)
-        -> Type                                   -- return type of the command
-        -> MatchGroup GhcTc (LHsCmd GhcTc)        -- match group to desugar
-        -> DsM (MatchGroup GhcTc (LHsExpr GhcTc), -- match group with choice tree
-                CoreExpr)                         -- desugared choices
-dsCases ids local_vars stack_id stack_ty res_ty
-        (MG { mg_alts = L l matches
-            , mg_ext = MatchGroupTc arg_tys _ origin
-            }) = do
-
-  -- Extract and desugar the leaf commands in the case, building tuple
-  -- expressions that will (after tagging) replace these leaves
-
-  let leaves = concatMap leavesMatch matches
-      make_branch (leaf, bound_vars) = do
-          (core_leaf, _fvs, leaf_ids)
-             <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty
-                  res_ty leaf
-          return ([mkHsEnvStackExpr leaf_ids stack_id],
-                  envStackType leaf_ids stack_ty,
-                  core_leaf)
-
-  branches <- mapM make_branch leaves
-  either_con <- dsLookupTyCon eitherTyConName
-  left_con <- dsLookupDataCon leftDataConName
-  right_con <- dsLookupDataCon rightDataConName
-  void_ty <- mkTyConTy <$> dsLookupTyCon voidTyConName
-  let
-      left_id  = mkConLikeTc (RealDataCon left_con)
-      right_id = mkConLikeTc (RealDataCon right_con)
-      left_expr  ty1 ty2 e = noLocA $ HsApp noComments
-                         (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
-      right_expr ty1 ty2 e = noLocA $ HsApp noComments
-                         (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
-
-      -- Prefix each tuple with a distinct series of Left's and Right's,
-      -- in a balanced way, keeping track of the types.
-
-      merge_branches :: ([LHsExpr GhcTc], Type, CoreExpr)
-                    -> ([LHsExpr GhcTc], Type, CoreExpr)
-                    -> ([LHsExpr GhcTc], Type, CoreExpr) -- AZ
-      merge_branches (builds1, in_ty1, core_exp1)
-                     (builds2, in_ty2, core_exp2)
-        = (map (left_expr in_ty1 in_ty2) builds1 ++
-              map (right_expr in_ty1 in_ty2) builds2,
-           mkTyConApp either_con [in_ty1, in_ty2],
-           do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
-  (leaves', sum_ty, core_choices) <- case nonEmpty branches of
-    Just bs -> return $ foldb merge_branches bs
-    -- when the case command has no alternatives, the sum type from
-    -- Note [Desugaring HsCmdCase] becomes the empty sum type,
-    -- i.e. Void. The choices then effectively become `arr absurd`,
-    -- implemented as `arr \case {}`.
-    Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$>
-      dsExpr (HsLamCase EpAnnNotUsed LamCase
-        (MG { mg_alts = noLocA []
-            , mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty Generated
-            }))
-
-      -- Replace the commands in the case with these tagged tuples,
-      -- yielding a HsExpr Id we can feed to dsExpr.
-
-  let (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
-
-  -- Note that we replace the MatchGroup result type by sum_ty,
-  -- which is the type of matches'
-  return (MG { mg_alts = L l matches'
-             , mg_ext = MatchGroupTc arg_tys sum_ty origin
-             },
-          core_choices)
-
-{-
-Translation of command judgements of the form
-
-        D |-a do { ss } : t
--}
-
-dsCmdDo :: DsCmdEnv             -- arrow combinators
-        -> IdSet                -- set of local vars available to this statement
-        -> Type                 -- return type of the statement
-        -> [CmdLStmt GhcTc]     -- statements to desugar
-        -> [Id]                 -- list of vars in the input to this statement
-                                -- This is typically fed back,
-                                -- so don't pull on it too early
-        -> DsM (CoreExpr,       -- desugared expression
-                DIdSet)         -- subset of local vars that occur free
-
-dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
-
--- D; xs |-a c : () --> t
--- --------------------------
--- D; xs |-a do { c } : t
---
---              ---> premap (\ (xs) -> ((xs), ())) c
-
-dsCmdDo ids local_vars res_ty [L _ (LastStmt _ body _ _)] env_ids = do
-    (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
-    let env_ty = mkBigCoreVarTupTy env_ids
-    env_var <- newSysLocalDs ManyTy env_ty
-    let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)
-    return (do_premap ids
-                        env_ty
-                        (mkCorePairTy env_ty unitTy)
-                        res_ty
-                        core_map
-                        core_body,
-        env_ids')
-
-dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do
-    let bound_vars  = mkVarSet (collectLStmtBinders CollWithDictBinders stmt)
-    let local_vars' = bound_vars `unionVarSet` local_vars
-    (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)
-    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
-    return (do_compose ids
-                (mkBigCoreVarTupTy env_ids)
-                (mkBigCoreVarTupTy env_ids')
-                res_ty
-                core_stmt
-                core_stmts,
-              fv_stmt)
-
-{-
-A statement maps one local environment to another, and is represented
-as an arrow from one tuple type to another.  A statement sequence is
-translated to a composition of such arrows.
--}
-
-dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id]
-           -> DsM (CoreExpr, DIdSet)
-dsCmdLStmt ids local_vars out_ids cmd env_ids
-  = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
-
-dsCmdStmt
-        :: DsCmdEnv             -- arrow combinators
-        -> IdSet                -- set of local vars available to this statement
-        -> [Id]                 -- list of vars in the output of this statement
-        -> CmdStmt GhcTc        -- statement to desugar
-        -> [Id]                 -- list of vars in the input to this statement
-                                -- This is typically fed back,
-                                -- so don't pull on it too early
-        -> DsM (CoreExpr,       -- desugared expression
-                DIdSet)         -- subset of local vars that occur free
-
--- D; xs1 |-a c : () --> t
--- D; xs' |-a do { ss } : t'
--- ------------------------------
--- D; xs  |-a do { c; ss } : t'
---
---              ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
---                      (first c >>> arr snd) >>> ss
-
-dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
-    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd
-    core_mux <- matchEnv env_ids
-        (mkCorePairExpr
-            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
-            (mkBigCoreVarTup out_ids))
-    let
-        in_ty = mkBigCoreVarTupTy env_ids
-        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
-        out_ty = mkBigCoreVarTupTy out_ids
-        before_c_ty = mkCorePairTy in_ty1 out_ty
-        after_c_ty = mkCorePairTy c_ty out_ty
-    snd_fn <- mkSndExpr c_ty out_ty
-    return (do_premap ids in_ty before_c_ty out_ty core_mux $
-                do_compose ids before_c_ty after_c_ty out_ty
-                        (do_first ids in_ty1 c_ty out_ty core_cmd) $
-                do_arr ids after_c_ty out_ty snd_fn,
-              extendDVarSetList fv_cmd out_ids)
-
--- D; xs1 |-a c : () --> t
--- D; xs' |-a do { ss } : t'            xs2 = xs' - defs(p)
--- -----------------------------------
--- D; xs  |-a do { p <- c; ss } : t'
---
---              ---> premap (\ (xs) -> (((xs1),()),(xs2)))
---                      (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
---
--- It would be simpler and more consistent to do this using second,
--- but that's likely to be defined in terms of first.
-
-dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do
-    let pat_ty = hsLPatType pat
-    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
-    let pat_vars = mkVarSet (collectPatBinders CollWithDictBinders pat)
-    let
-        env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids
-        env_ty2 = mkBigCoreVarTupTy env_ids2
-
-    -- multiplexing function
-    --          \ (xs) -> (((xs1),()),(xs2))
-
-    core_mux <- matchEnv env_ids
-        (mkCorePairExpr
-            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
-            (mkBigCoreVarTup env_ids2))
-
-    -- projection function
-    --          \ (p, (xs2)) -> (zs)
-
-    env_id <- newSysLocalDs ManyTy env_ty2
-    uniqs <- newUniqueSupply
-    let
-       after_c_ty = mkCorePairTy pat_ty env_ty2
-       out_ty = mkBigCoreVarTupTy out_ids
-       body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
-
-    fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty
-    pat_id    <- selectSimpleMatchVarL ManyTy pat
-    match_code
-      <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat body_expr fail_expr
-    pair_id   <- newSysLocalDs ManyTy after_c_ty
-    let
-        proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
-
-    -- put it all together
-    let
-        in_ty = mkBigCoreVarTupTy env_ids
-        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
-        in_ty2 = mkBigCoreVarTupTy env_ids2
-        before_c_ty = mkCorePairTy in_ty1 in_ty2
-    return (do_premap ids in_ty before_c_ty out_ty core_mux $
-                do_compose ids before_c_ty after_c_ty out_ty
-                        (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
-                do_arr ids after_c_ty out_ty proj_expr,
-              fv_cmd `unionDVarSet` (mkDVarSet out_ids
-                                     `uniqDSetMinusUniqSet` pat_vars))
-
--- D; xs' |-a do { ss } : t
--- --------------------------------------
--- D; xs  |-a do { let binds; ss } : t
---
---              ---> arr (\ (xs) -> let binds in (xs')) >>> ss
-
-dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do
-    -- build a new environment using the let bindings
-    core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
-    -- match the old environment against the input
-    core_map <- matchEnv env_ids core_binds
-    return (do_arr ids
-                        (mkBigCoreVarTupTy env_ids)
-                        (mkBigCoreVarTupTy out_ids)
-                        core_map,
-            exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)
-
--- D; ys  |-a do { ss; returnA -< ((xs1), (ys2)) } : ...
--- D; xs' |-a do { ss' } : t
--- ------------------------------------
--- D; xs  |-a do { rec ss; ss' } : t
---
---                      xs1 = xs' /\ defs(ss)
---                      xs2 = xs' - defs(ss)
---                      ys1 = ys - defs(ss)
---                      ys2 = ys /\ defs(ss)
---
---              ---> arr (\(xs) -> ((ys1),(xs2))) >>>
---                      first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
---                      arr (\((xs1),(xs2)) -> (xs')) >>> ss'
-
-dsCmdStmt ids local_vars out_ids
-        (RecStmt { recS_stmts = L _ stmts
-                 , recS_later_ids = later_ids, recS_rec_ids = rec_ids
-                 , recS_ext = RecStmtTc { recS_later_rets = later_rets
-                                        , recS_rec_rets = rec_rets } })
-        env_ids = do
-    let
-        later_ids_set = mkVarSet later_ids
-        env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids
-        env2_id_set = mkDVarSet env2_ids
-        env2_ty = mkBigCoreVarTupTy env2_ids
-
-    -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
-
-    uniqs <- newUniqueSupply
-    env2_id <- newSysLocalDs ManyTy env2_ty
-    let
-        later_ty = mkBigCoreVarTupTy later_ids
-        post_pair_ty = mkCorePairTy later_ty env2_ty
-        post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)
-
-    post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body
-
-    --- loop (...)
-
-    (core_loop, env1_id_set, env1_ids)
-               <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets
-
-    -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
-
-    let
-        env1_ty = mkBigCoreVarTupTy env1_ids
-        pre_pair_ty = mkCorePairTy env1_ty env2_ty
-        pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)
-                                        (mkBigCoreVarTup env2_ids)
-
-    pre_loop_fn <- matchEnv env_ids pre_loop_body
-
-    -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
-
-    let
-        env_ty = mkBigCoreVarTupTy env_ids
-        out_ty = mkBigCoreVarTupTy out_ids
-        core_body = do_premap ids env_ty pre_pair_ty out_ty
-                pre_loop_fn
-                (do_compose ids pre_pair_ty post_pair_ty out_ty
-                        (do_first ids env1_ty later_ty env2_ty
-                                core_loop)
-                        (do_arr ids post_pair_ty out_ty
-                                post_loop_fn))
-
-    return (core_body, env1_id_set `unionDVarSet` env2_id_set)
-
-dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
-
---      loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
---            (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
-
-dsRecCmd
-        :: DsCmdEnv             -- arrow combinators
-        -> IdSet                -- set of local vars available to this statement
-        -> [CmdLStmt GhcTc]     -- list of statements inside the RecCmd
-        -> [Id]                 -- list of vars defined here and used later
-        -> [HsExpr GhcTc]       -- expressions corresponding to later_ids
-        -> [Id]                 -- list of vars fed back through the loop
-        -> [HsExpr GhcTc]       -- expressions corresponding to rec_ids
-        -> DsM (CoreExpr,       -- desugared statement
-                DIdSet,         -- subset of local vars that occur free
-                [Id])           -- same local vars as a list
-
-dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
-    let
-        later_id_set = mkVarSet later_ids
-        rec_id_set = mkVarSet rec_ids
-        local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars
-
-    -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))
-
-    core_later_rets <- mapM dsExpr later_rets
-    core_rec_rets <- mapM dsExpr rec_rets
-    let
-        -- possibly polymorphic version of vars of later_ids and rec_ids
-        out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets)
-        out_ty = mkBigCoreVarTupTy out_ids
-
-        later_tuple = mkBigCoreTup core_later_rets
-        later_ty = mkBigCoreVarTupTy later_ids
-
-        rec_tuple = mkBigCoreTup core_rec_rets
-        rec_ty = mkBigCoreVarTupTy rec_ids
-
-        out_pair = mkCorePairExpr later_tuple rec_tuple
-        out_pair_ty = mkCorePairTy later_ty rec_ty
-
-    mk_pair_fn <- matchEnv out_ids out_pair
-
-    -- ss
-
-    (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts
-
-    -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
-
-    rec_id <- newSysLocalDs ManyTy rec_ty
-    let
-        env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set
-        env1_ids = dVarSetElems env1_id_set
-        env1_ty = mkBigCoreVarTupTy env1_ids
-        in_pair_ty = mkCorePairTy env1_ty rec_ty
-        core_body = mkBigCoreTup (map selectVar env_ids)
-          where
-            selectVar v
-                | v `elemVarSet` rec_id_set
-                  = mkBigTupleSelector rec_ids v rec_id (Var rec_id)
-                | otherwise = Var v
-
-    squash_pair_fn <- matchEnvStack env1_ids rec_id core_body
-
-    -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))
-
-    let
-        env_ty = mkBigCoreVarTupTy env_ids
-        core_loop = do_loop ids env1_ty later_ty rec_ty
-                (do_premap ids in_pair_ty env_ty out_pair_ty
-                        squash_pair_fn
-                        (do_compose ids env_ty out_ty out_pair_ty
-                                core_stmts
-                                (do_arr ids out_ty out_pair_ty mk_pair_fn)))
-
-    return (core_loop, env1_id_set, env1_ids)
-
-{-
-A sequence of statements (as in a rec) is desugared to an arrow between
-two environments (no stack)
--}
-
-dsfixCmdStmts
-        :: DsCmdEnv             -- arrow combinators
-        -> IdSet                -- set of local vars available to this statement
-        -> [Id]                 -- output vars of these statements
-        -> [CmdLStmt GhcTc]     -- statements to desugar
-        -> DsM (CoreExpr,       -- desugared expression
-                DIdSet,         -- subset of local vars that occur free
-                [Id])           -- same local vars as a list
-
-dsfixCmdStmts ids local_vars out_ids stmts
-  = trimInput (dsCmdStmts ids local_vars out_ids stmts)
-   -- TODO: Add representation polymorphism check for the resulting expression.
-   -- But I (Richard E.) don't know enough about arrows to do so.
-
-dsCmdStmts
-        :: DsCmdEnv             -- arrow combinators
-        -> IdSet                -- set of local vars available to this statement
-        -> [Id]                 -- output vars of these statements
-        -> [CmdLStmt GhcTc]     -- statements to desugar
-        -> [Id]                 -- list of vars in the input to these statements
-        -> DsM (CoreExpr,       -- desugared expression
-                DIdSet)         -- subset of local vars that occur free
-
-dsCmdStmts ids local_vars out_ids [stmt] env_ids
-  = dsCmdLStmt ids local_vars out_ids stmt env_ids
-
-dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do
-    let bound_vars  = mkVarSet (collectLStmtBinders CollWithDictBinders stmt)
-    let local_vars' = bound_vars `unionVarSet` local_vars
-    (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
-    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
-    return (do_compose ids
-                (mkBigCoreVarTupTy env_ids)
-                (mkBigCoreVarTupTy env_ids')
-                (mkBigCoreVarTupTy out_ids)
-                core_stmt
-                core_stmts,
-              fv_stmt)
-
-dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
-
--- Match a list of expressions against a list of patterns, left-to-right.
-
-matchSimplys :: [CoreExpr]              -- Scrutinees
-             -> HsMatchContext GhcRn    -- Match kind
-             -> [LPat GhcTc]            -- Patterns they should match
-             -> CoreExpr                -- Return this if they all match
-             -> CoreExpr                -- Return this if they don't
-             -> DsM CoreExpr
-matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr
-matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
-    match_code <- matchSimplys exps ctxt pats result_expr fail_expr
-    matchSimply exp ctxt pat match_code fail_expr
-matchSimplys _ _ _ _ _ = panic "matchSimplys"
-
--- List of leaf expressions, with set of variables bound in each
-
-leavesMatch :: LMatch GhcTc (LocatedA (body GhcTc))
-            -> [(LocatedA (body GhcTc), IdSet)]
-leavesMatch (L _ (Match { m_pats = pats
-                        , m_grhss = GRHSs _ grhss binds }))
-  = let
-        defined_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats)
-                        `unionVarSet`
-                       mkVarSet (collectLocalBinders CollWithDictBinders binds)
-    in
-    [(body,
-      mkVarSet (collectLStmtsBinders CollWithDictBinders stmts)
-        `unionVarSet` defined_vars)
-    | L _ (GRHS _ stmts body) <- grhss]
-
--- Replace the leaf commands in a match
-
-replaceLeavesMatch
-        :: ( Anno (Match GhcTc (LocatedA (body' GhcTc))) ~ Anno (Match GhcTc (LocatedA (body GhcTc)))
-           , Anno (GRHS GhcTc (LocatedA (body' GhcTc))) ~ Anno (GRHS GhcTc (LocatedA (body GhcTc))))
-        => Type                                 -- new result type
-        -> [LocatedA (body' GhcTc)] -- replacement leaf expressions of that type
-        -> LMatch GhcTc (LocatedA (body GhcTc))  -- the matches of a case command
-        -> ([LocatedA (body' GhcTc)],            -- remaining leaf expressions
-            LMatch GhcTc (LocatedA (body' GhcTc))) -- updated match
-replaceLeavesMatch _res_ty leaves
-                        (L loc
-                          match@(Match { m_grhss = GRHSs x grhss binds }))
-  = let
-        (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
-    in
-    (leaves', L loc (match { m_ext = noAnn, m_grhss = GRHSs x grhss' binds }))
-
-replaceLeavesGRHS
-        :: ( Anno (Match GhcTc (LocatedA (body' GhcTc))) ~ Anno (Match GhcTc (LocatedA (body GhcTc)))
-           , Anno (GRHS GhcTc (LocatedA (body' GhcTc))) ~ Anno (GRHS GhcTc (LocatedA (body GhcTc))))
-        => [LocatedA (body' GhcTc)]  -- replacement leaf expressions of that type
-        -> LGRHS GhcTc (LocatedA (body GhcTc))     -- rhss of a case command
-        -> ([LocatedA (body' GhcTc)],              -- remaining leaf expressions
-            LGRHS GhcTc (LocatedA (body' GhcTc)))  -- updated GRHS
-replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _))
-  = (leaves, L loc (GRHS x stmts leaf))
-replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
-
--- Balanced fold of a non-empty list.
-
-foldb :: (a -> a -> a) -> NonEmpty a -> a
-foldb _ (x:|[]) = x
-foldb f xs = foldb f (fold_pairs xs)
-  where
-    fold_pairs (x1:|x2:xs) = f x1 x2 :| keep_empty fold_pairs xs
-    fold_pairs xs          = xs
-
-    keep_empty :: (NonEmpty a -> NonEmpty a) -> [a] -> [a]
-    keep_empty f = maybe [] (toList . f) . nonEmpty
diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Binds.hs
+++ /dev/null
@@ -1,1362 +0,0 @@
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Pattern-matching bindings (HsBinds and MonoBinds)
-
-Handles @HsBinds@; those at the top level require different handling,
-in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
-lower levels it is preserved with @let@/@letrec@s).
--}
-
-module GHC.HsToCore.Binds
-   ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec
-   , dsHsWrapper, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds
-   , dsWarnOrphanRule
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-import GHC.Driver.Config
-import qualified GHC.LanguageExtensions as LangExt
-import GHC.Unit.Module
-
-import {-# SOURCE #-}   GHC.HsToCore.Expr  ( dsLExpr )
-import {-# SOURCE #-}   GHC.HsToCore.Match ( matchWrapper )
-
-import GHC.HsToCore.Monad
-import GHC.HsToCore.Errors.Types
-import GHC.HsToCore.GuardedRHSs
-import GHC.HsToCore.Utils
-import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )
-
-import GHC.Hs             -- lots of things
-import GHC.Core           -- lots of things
-import GHC.Core.SimpleOpt    ( simpleOptExpr )
-import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
-import GHC.Core.Make
-import GHC.Core.Utils
-import GHC.Core.Opt.Arity     ( etaExpand )
-import GHC.Core.Unfold.Make
-import GHC.Core.FVs
-import GHC.Core.Predicate
-import GHC.Core.TyCon
-import GHC.Core.Type
-import GHC.Core.Coercion
-import GHC.Core.Multiplicity
-import GHC.Core.Rules
-import GHC.Core.TyCo.Compare( eqType )
-
-import GHC.Builtin.Names
-import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy )
-
-import GHC.Tc.Types.Evidence
-
-import GHC.Types.Id
-import GHC.Types.Name
-import GHC.Types.Var.Set
-import GHC.Types.Var.Env
-import GHC.Types.Var( EvVar )
-import GHC.Types.SrcLoc
-import GHC.Types.Basic
-import GHC.Types.Unique.Set( nonDetEltsUniqSet )
-
-import GHC.Data.Maybe
-import GHC.Data.OrdList
-import GHC.Data.Graph.Directed
-import GHC.Data.Bag
-
-import GHC.Utils.Constants (debugIsOn)
-import GHC.Utils.Misc
-import GHC.Utils.Monad
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-import Control.Monad
-
-{-**********************************************************************
-*                                                                      *
-           Desugaring a MonoBinds
-*                                                                      *
-**********************************************************************-}
-
--- | Desugar top level binds, strict binds are treated like normal
--- binds since there is no good time to force before first usage.
-dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))
-dsTopLHsBinds binds
-     -- see Note [Strict binds checks]
-  | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)
-  = do { mapBagM_ (top_level_err UnliftedTypeBinds) unlifted_binds
-       ; mapBagM_ (top_level_err StrictBinds)       bang_binds
-       ; return nilOL }
-
-  | otherwise
-  = do { (force_vars, prs) <- dsLHsBinds binds
-       ; when debugIsOn $
-         do { xstrict <- xoptM LangExt.Strict
-            ; massertPpr (null force_vars || xstrict) (ppr binds $$ ppr force_vars) }
-              -- with -XStrict, even top-level vars are listed as force vars.
-
-       ; return (toOL prs) }
-
-  where
-    unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds
-    bang_binds     = filterBag (isBangedHsBind   . unLoc) binds
-
-    top_level_err bindsType (L loc bind)
-      = putSrcSpanDs (locA loc) $
-        diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind)
-
-
--- | Desugar all other kind of bindings, Ids of strict binds are returned to
--- later be forced in the binding group body, see Note [Desugar Strict binds]
-dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
-dsLHsBinds binds
-  = do { ds_bs <- mapBagM dsLHsBind binds
-       ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))
-                         id ([], []) ds_bs) }
-
-------------------------
-dsLHsBind :: LHsBind GhcTc
-          -> DsM ([Id], [(Id,CoreExpr)])
-dsLHsBind (L loc bind) = do dflags <- getDynFlags
-                            putSrcSpanDs (locA loc) $ dsHsBind dflags bind
-
--- | Desugar a single binding (or group of recursive binds).
-dsHsBind :: DynFlags
-         -> HsBind GhcTc
-         -> DsM ([Id], [(Id,CoreExpr)])
-         -- ^ The Ids of strict binds, to be forced in the body of the
-         -- binding group see Note [Desugar Strict binds] and all
-         -- bindings and their desugared right hand sides.
-
-dsHsBind dflags (VarBind { var_id = var
-                         , var_rhs = expr })
-  = do  { core_expr <- dsLExpr expr
-                -- Dictionary bindings are always VarBinds,
-                -- so we only need do this here
-        ; let core_bind@(id,_) = makeCorePair dflags var False 0 core_expr
-              force_var = if xopt LangExt.Strict dflags
-                          then [id]
-                          else []
-        ; return (force_var, [core_bind]) }
-
-dsHsBind dflags b@(FunBind { fun_id = L loc fun
-                           , fun_matches = matches
-                           , fun_ext = (co_fn, tick)
-                           })
- = do   { (args, body) <- addTyCs FromSource (hsWrapDictBinders co_fn) $
-                          -- FromSource might not be accurate (we don't have any
-                          -- origin annotations for things in this module), but at
-                          -- worst we do superfluous calls to the pattern match
-                          -- oracle.
-                          -- addTyCs: Add type evidence to the refinement type
-                          --            predicate of the coverage checker
-                          -- See Note [Long-distance information] in "GHC.HsToCore.Pmc"
-                          matchWrapper (mkPrefixFunRhs (L loc (idName fun))) Nothing matches
-
-        ; core_wrap <- dsHsWrapper co_fn
-        ; let body' = mkOptTickBox tick body
-              rhs   = core_wrap (mkLams args body')
-              core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
-              force_var
-                  -- Bindings are strict when -XStrict is enabled
-                | xopt LangExt.Strict dflags
-                , matchGroupArity matches == 0 -- no need to force lambdas
-                = [id]
-                | isBangedHsBind b
-                = [id]
-                | otherwise
-                = []
-        ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun)
-          --                          , ppr (mg_alts matches)
-          --                          , ppr args, ppr core_binds, ppr body']) $
-          return (force_var, [core_binds]) }
-
-dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
-                         , pat_ext = (ty, (rhs_tick, var_ticks))
-                         })
-  = do  { rhss_nablas <- pmcGRHSs PatBindGuards grhss
-        ; body_expr <- dsGuarded grhss ty rhss_nablas
-        ; let body' = mkOptTickBox rhs_tick body_expr
-              pat'  = decideBangHood dflags pat
-        ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'
-          -- We silently ignore inline pragmas; no makeCorePair
-          -- Not so cool, but really doesn't matter
-        ; let force_var' = if isBangedLPat pat'
-                           then [force_var]
-                           else []
-        ; return (force_var', sel_binds) }
-
-dsHsBind
-  dflags
-  (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
-                        , abs_exports = exports
-                        , abs_ev_binds = ev_binds
-                        , abs_binds = binds, abs_sig = has_sig }))
-  = do { ds_binds <- addTyCs FromSource (listToBag dicts) $
-                     dsLHsBinds binds
-             -- addTyCs: push type constraints deeper
-             --            for inner pattern match check
-             -- See Check, Note [Long-distance information]
-
-       ; ds_ev_binds <- dsTcEvBinds_s ev_binds
-
-       -- dsAbsBinds does the hard work
-       ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
-
-dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
-
------------------------
-dsAbsBinds :: DynFlags
-           -> [TyVar] -> [EvVar] -> [ABExport]
-           -> [CoreBind]                -- Desugared evidence bindings
-           -> ([Id], [(Id,CoreExpr)])   -- Desugared value bindings
-           -> Bool                      -- Single binding with signature
-           -> DsM ([Id], [(Id,CoreExpr)])
-
-dsAbsBinds dflags tyvars dicts exports
-           ds_ev_binds (force_vars, bind_prs) has_sig
-
-    -- A very important common case: one exported variable
-    -- Non-recursive bindings come through this way
-    -- So do self-recursive bindings
-    --    gbl_id = wrap (/\tvs \dicts. let ev_binds
-    --                                 letrec bind_prs
-    --                                 in lcl_id)
-  | [export] <- exports
-  , ABE { abe_poly = global_id, abe_mono = local_id
-        , abe_wrap = wrap, abe_prags = prags } <- export
-  , Just force_vars' <- case force_vars of
-                           []                  -> Just []
-                           [v] | v == local_id -> Just [global_id]
-                           _                   -> Nothing
-       -- If there is a variable to force, it's just the
-       -- single variable we are binding here
-  = do { core_wrap <- dsHsWrapper wrap -- Usually the identity
-
-       ; let rhs = core_wrap $
-                   mkLams tyvars $ mkLams dicts $
-                   mkCoreLets ds_ev_binds $
-                   body
-
-             body | has_sig
-                  , [(_, lrhs)] <- bind_prs
-                  = lrhs
-                  | otherwise
-                  = mkLetRec bind_prs (Var local_id)
-
-       ; (spec_binds, rules) <- dsSpecs rhs prags
-
-       ; let global_id' = addIdSpecialisations global_id rules
-             main_bind  = makeCorePair dflags global_id'
-                                       (isDefaultMethod prags)
-                                       (dictArity dicts) rhs
-
-       ; return (force_vars', main_bind : fromOL spec_binds) }
-
-    -- Another common case: no tyvars, no dicts
-    -- In this case we can have a much simpler desugaring
-    --    lcl_id{inl-prag} = rhs  -- Auxiliary binds
-    --    gbl_id = lcl_id |> co   -- Main binds
-  | null tyvars, null dicts
-  = do { let mk_main :: ABExport -> DsM (Id, CoreExpr)
-             mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id
-                          , abe_wrap = wrap })
-                     -- No SpecPrags (no dicts)
-                     -- Can't be a default method (default methods are singletons)
-               = do { core_wrap <- dsHsWrapper wrap
-                    ; return ( gbl_id `setInlinePragma` defaultInlinePragma
-                             , core_wrap (Var lcl_id)) }
-
-       ; main_prs <- mapM mk_main exports
-       ; return (force_vars, flattenBinds ds_ev_binds
-                              ++ mk_aux_binds bind_prs ++ main_prs ) }
-
-    -- The general case
-    -- See Note [Desugaring AbsBinds]
-  | otherwise
-  = do { let aux_binds = Rec (mk_aux_binds bind_prs)
-                -- Monomorphic recursion possible, hence Rec
-
-             new_force_vars = get_new_force_vars force_vars
-             locals       = map abe_mono exports
-             all_locals   = locals ++ new_force_vars
-             tup_expr     = mkBigCoreVarTup all_locals
-             tup_ty       = exprType tup_expr
-       ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
-                            mkCoreLets ds_ev_binds $
-                            mkLet aux_binds $
-                            tup_expr
-
-       ; poly_tup_id <- newSysLocalDs ManyTy (exprType poly_tup_rhs)
-
-        -- Find corresponding global or make up a new one: sometimes
-        -- we need to make new export to desugar strict binds, see
-        -- Note [Desugar Strict binds]
-       ; (exported_force_vars, extra_exports) <- get_exports force_vars
-
-       ; let mk_bind (ABE { abe_wrap = wrap
-                          , abe_poly = global
-                          , abe_mono = local, abe_prags = spec_prags })
-                          -- See Note [AbsBinds wrappers] in "GHC.Hs.Binds"
-                = do { tup_id  <- newSysLocalDs ManyTy tup_ty
-                     ; core_wrap <- dsHsWrapper wrap
-                     ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $
-                                 mkBigTupleSelector all_locals local tup_id $
-                                 mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
-                           rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
-                     ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
-                     ; let global' = (global `setInlinePragma` defaultInlinePragma)
-                                             `addIdSpecialisations` rules
-                           -- Kill the INLINE pragma because it applies to
-                           -- the user written (local) function.  The global
-                           -- Id is just the selector.  Hmm.
-                     ; return ((global', rhs) : fromOL spec_binds) }
-
-       ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
-
-       ; return ( exported_force_vars
-                , (poly_tup_id, poly_tup_rhs) :
-                   concat export_binds_s) }
-  where
-    mk_aux_binds :: [(Id,CoreExpr)] -> [(Id,CoreExpr)]
-    mk_aux_binds bind_prs = [ makeCorePair dflags lcl_w_inline False 0 rhs
-                            | (lcl_id, rhs) <- bind_prs
-                            , let lcl_w_inline = lookupVarEnv inline_env lcl_id
-                                                 `orElse` lcl_id ]
-
-    inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
-                           -- the inline pragma from the source
-                           -- The type checker put the inline pragma
-                           -- on the *global* Id, so we need to transfer it
-    inline_env
-      = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
-                 | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
-                 , let prag = idInlinePragma gbl_id ]
-
-    global_env :: IdEnv Id -- Maps local Id to its global exported Id
-    global_env =
-      mkVarEnv [ (local, global)
-               | ABE { abe_mono = local, abe_poly = global } <- exports
-               ]
-
-    -- find variables that are not exported
-    get_new_force_vars lcls =
-      foldr (\lcl acc -> case lookupVarEnv global_env lcl of
-                           Just _ -> acc
-                           Nothing -> lcl:acc)
-            [] lcls
-
-    -- find exports or make up new exports for force variables
-    get_exports :: [Id] -> DsM ([Id], [ABExport])
-    get_exports lcls =
-      foldM (\(glbls, exports) lcl ->
-              case lookupVarEnv global_env lcl of
-                Just glbl -> return (glbl:glbls, exports)
-                Nothing   -> do export <- mk_export lcl
-                                let glbl = abe_poly export
-                                return (glbl:glbls, export:exports))
-            ([],[]) lcls
-
-    mk_export local =
-      do global <- newSysLocalDs ManyTy
-                     (exprType (mkLams tyvars (mkLams dicts (Var local))))
-         return (ABE { abe_poly  = global
-                     , abe_mono  = local
-                     , abe_wrap  = WpHole
-                     , abe_prags = SpecPrags [] })
-
--- | This is where we apply INLINE and INLINABLE pragmas. All we need to
--- do is to attach the unfolding information to the Id.
---
--- Other decisions about whether to inline are made in
--- `calcUnfoldingGuidance` but the decision about whether to then expose
--- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal`
--- using this information.
-------------------------
-makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr
-             -> (Id, CoreExpr)
-makeCorePair dflags gbl_id is_default_method dict_arity rhs
-  | is_default_method    -- Default methods are *always* inlined
-                         -- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance
-  = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding' simpl_opts rhs, rhs)
-
-  | otherwise
-  = case inlinePragmaSpec inline_prag of
-          NoUserInlinePrag -> (gbl_id, rhs)
-          NoInline  {}     -> (gbl_id, rhs)
-          Opaque    {}     -> (gbl_id, rhs)
-          Inlinable {}     -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
-          Inline    {}     -> inline_pair
-  where
-    simpl_opts    = initSimpleOpts dflags
-    inline_prag   = idInlinePragma gbl_id
-    inlinable_unf = mkInlinableUnfolding simpl_opts StableUserSrc rhs
-    inline_pair
-       | Just arity <- inlinePragmaSat inline_prag
-        -- Add an Unfolding for an INLINE (but not for NOINLINE)
-        -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
-       , let real_arity = dict_arity + arity
-        -- NB: The arity passed to mkInlineUnfoldingWithArity
-        --     must take account of the dictionaries
-       = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts StableUserSrc real_arity rhs
-         , etaExpand real_arity rhs)
-
-       | otherwise
-       = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
-         (gbl_id `setIdUnfolding` mkInlineUnfoldingNoArity simpl_opts StableUserSrc rhs, rhs)
-
-dictArity :: [Var] -> Arity
--- Don't count coercion variables in arity
-dictArity dicts = count isId dicts
-
-{-
-Note [Desugaring AbsBinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-In the general AbsBinds case we desugar the binding to this:
-
-       tup a (d:Num a) = let fm = ...gm...
-                             gm = ...fm...
-                         in (fm,gm)
-       f a d = case tup a d of { (fm,gm) -> fm }
-       g a d = case tup a d of { (fm,gm) -> fm }
-
-Note [Rules and inlining]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Common special case: no type or dictionary abstraction
-This is a bit less trivial than you might suppose
-The naive way would be to desugar to something like
-        f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
-        M.f = f_lcl             -- Generated from "exports"
-But we don't want that, because if M.f isn't exported,
-it'll be inlined unconditionally at every call site (its rhs is
-trivial).  That would be ok unless it has RULES, which would
-thereby be completely lost.  Bad, bad, bad.
-
-Instead we want to generate
-        M.f = ...f_lcl...
-        f_lcl = M.f
-Now all is cool. The RULES are attached to M.f (by SimplCore),
-and f_lcl is rapidly inlined away.
-
-This does not happen in the same way to polymorphic binds,
-because they desugar to
-        M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
-Although I'm a bit worried about whether full laziness might
-float the f_lcl binding out and then inline M.f at its call site
-
-Note [Specialising in no-dict case]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Even if there are no tyvars or dicts, we may have specialisation pragmas.
-Class methods can generate
-      AbsBinds [] [] [( ... spec-prag]
-         { AbsBinds [tvs] [dicts] ...blah }
-So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
-
-  class  (Real a, Fractional a) => RealFrac a  where
-    round :: (Integral b) => a -> b
-
-  instance  RealFrac Float  where
-    {-# SPECIALIZE round :: Float -> Int #-}
-
-The top-level AbsBinds for $cround has no tyvars or dicts (because the
-instance does not).  But the method is locally overloaded!
-
-Note [Abstracting over tyvars only]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When abstracting over type variable only (not dictionaries), we don't really need to
-built a tuple and select from it, as we do in the general case. Instead we can take
-
-        AbsBinds [a,b] [ ([a,b], fg, fl, _),
-                         ([b],   gg, gl, _) ]
-                { fl = e1
-                  gl = e2
-                   h = e3 }
-
-and desugar it to
-
-        fg = /\ab. let B in e1
-        gg = /\b. let a = () in let B in S(e2)
-        h  = /\ab. let B in e3
-
-where B is the *non-recursive* binding
-        fl = fg a b
-        gl = gg b
-        h  = h a b    -- See (b); note shadowing!
-
-Notice (a) g has a different number of type variables to f, so we must
-             use the mkArbitraryType thing to fill in the gaps.
-             We use a type-let to do that.
-
-         (b) The local variable h isn't in the exports, and rather than
-             clone a fresh copy we simply replace h by (h a b), where
-             the two h's have different types!  Shadowing happens here,
-             which looks confusing but works fine.
-
-         (c) The result is *still* quadratic-sized if there are a lot of
-             small bindings.  So if there are more than some small
-             number (10), we filter the binding set B by the free
-             variables of the particular RHS.  Tiresome.
-
-Why got to this trouble?  It's a common case, and it removes the
-quadratic-sized tuple desugaring.  Less clutter, hopefully faster
-compilation, especially in a case where there are a *lot* of
-bindings.
-
-
-Note [Eta-expanding INLINE things]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   foo :: Eq a => a -> a
-   {-# INLINE foo #-}
-   foo x = ...
-
-If (foo d) ever gets floated out as a common sub-expression (which can
-happen as a result of method sharing), there's a danger that we never
-get to do the inlining, which is a Terribly Bad thing given that the
-user said "inline"!
-
-To avoid this we preemptively eta-expand the definition, so that foo
-has the arity with which it is declared in the source code.  In this
-example it has arity 2 (one for the Eq and one for x). Doing this
-should mean that (foo d) is a PAP and we don't share it.
-
-Note [Nested arities]
-~~~~~~~~~~~~~~~~~~~~~
-For reasons that are not entirely clear, method bindings come out looking like
-this:
-
-  AbsBinds [] [] [$cfromT <= [] fromT]
-    $cfromT [InlPrag=INLINE] :: T Bool -> Bool
-    { AbsBinds [] [] [fromT <= [] fromT_1]
-        fromT :: T Bool -> Bool
-        { fromT_1 ((TBool b)) = not b } } }
-
-Note the nested AbsBind.  The arity for the unfolding on $cfromT should be
-gotten from the binding for fromT_1.
-
-It might be better to have just one level of AbsBinds, but that requires more
-thought!
-
-
-Note [Desugar Strict binds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma
-
-Desugaring strict variable bindings looks as follows (core below ==>)
-
-  let !x = rhs
-  in  body
-==>
-  let x = rhs
-  in x `seq` body -- seq the variable
-
-and if it is a pattern binding the desugaring looks like
-
-  let !pat = rhs
-  in body
-==>
-  let x = rhs -- bind the rhs to a new variable
-      pat = x
-  in x `seq` body -- seq the new variable
-
-if there is no variable in the pattern desugaring looks like
-
-  let False = rhs
-  in body
-==>
-  let x = case rhs of {False -> (); _ -> error "Match failed"}
-  in x `seq` body
-
-In order to force the Ids in the binding group they are passed around
-in the dsHsBind family of functions, and later seq'ed in GHC.HsToCore.Expr.ds_val_bind.
-
-Consider a recursive group like this
-
-  letrec
-     f : g = rhs[f,g]
-  in <body>
-
-Without `Strict`, we get a translation like this:
-
-  let t = /\a. letrec tm = rhs[fm,gm]
-                      fm = case t of fm:_ -> fm
-                      gm = case t of _:gm -> gm
-                in
-                (fm,gm)
-
-  in let f = /\a. case t a of (fm,_) -> fm
-  in let g = /\a. case t a of (_,gm) -> gm
-  in <body>
-
-Here `tm` is the monomorphic binding for `rhs`.
-
-With `Strict`, we want to force `tm`, but NOT `fm` or `gm`.
-Alas, `tm` isn't in scope in the `in <body>` part.
-
-The simplest thing is to return it in the polymorphic
-tuple `t`, thus:
-
-  let t = /\a. letrec tm = rhs[fm,gm]
-                      fm = case t of fm:_ -> fm
-                      gm = case t of _:gm -> gm
-                in
-                (tm, fm, gm)
-
-  in let f = /\a. case t a of (_,fm,_) -> fm
-  in let g = /\a. case t a of (_,_,gm) -> gm
-  in let tm = /\a. case t a of (tm,_,_) -> tm
-  in tm `seq` <body>
-
-
-See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more
-detailed explanation of the desugaring of strict bindings.
-
-Note [Strict binds checks]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are several checks around properly formed strict bindings. They
-all link to this Note. These checks must be here in the desugarer because
-we cannot know whether or not a type is unlifted until after zonking, due
-to representation polymorphism. These checks all used to be handled in the
-typechecker in checkStrictBinds (before Jan '17).
-
-We define an "unlifted bind" to be any bind that binds an unlifted id. Note that
-
-  x :: Char
-  (# True, x #) = blah
-
-is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind.
-
-Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind.
-Define a "strict bind" to be either an unlifted bind or a banged bind.
-
-The restrictions are:
-  1. Strict binds may not be top-level. Checked in dsTopLHsBinds.
-
-  2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged
-     unlifted bind, but an unbanged bind looks lazy, and we don't want users to be
-     surprised by the strictness of an unlifted bind.) Checked in first clause
-     of GHC.HsToCore.Expr.ds_val_bind.
-
-  3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type
-     variables or constraints.) Checked in first clause
-     of GHC.HsToCore.Expr.ds_val_bind.
-
-  4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind.
-
--}
-
-------------------------
-dsSpecs :: CoreExpr     -- Its rhs
-        -> TcSpecPrags
-        -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids
-               , [CoreRule] )           -- Rules for the Global Ids
--- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Bind
-dsSpecs _ IsDefaultMethod = return (nilOL, [])
-dsSpecs poly_rhs (SpecPrags sps)
-  = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
-       ; let (spec_binds_s, rules) = unzip pairs
-       ; return (concatOL spec_binds_s, rules) }
-
-dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding
-                                -- Nothing => RULE is for an imported Id
-                                --            rhs is in the Id's unfolding
-       -> Located TcSpecPrag
-       -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
-dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
-  | isJust (isClassOpId_maybe poly_id)
-  = putSrcSpanDs loc $
-    do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id)
-       ; return Nothing  }  -- There is no point in trying to specialise a class op
-                            -- Moreover, classops don't (currently) have an inl_sat arity set
-                            -- (it would be Just 0) and that in turn makes makeCorePair bleat
-
-  | no_act_spec && isNeverActive rule_act
-  = putSrcSpanDs loc $
-    do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_id)
-       ; return Nothing  }  -- Function is NOINLINE, and the specialisation inherits that
-                            -- See Note [Activation pragmas for SPECIALISE]
-
-  | otherwise
-  = putSrcSpanDs loc $
-    do { uniq <- newUnique
-       ; let poly_name = idName poly_id
-             spec_occ  = mkSpecOcc (getOccName poly_name)
-             spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
-             (spec_bndrs, spec_app) = collectHsWrapBinders spec_co
-               -- spec_co looks like
-               --         \spec_bndrs. [] spec_args
-               -- perhaps with the body of the lambda wrapped in some WpLets
-               -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
-
-       ; core_app <- dsHsWrapper spec_app
-
-       ; let ds_lhs  = core_app (Var poly_id)
-             spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)
-       ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id
-         --                         , text "spec_co:" <+> ppr spec_co
-         --                         , text "ds_rhs:" <+> ppr ds_lhs ]) $
-         dflags <- getDynFlags
-       ; case decomposeRuleLhs dflags spec_bndrs ds_lhs (mkVarSet spec_bndrs) of {
-           Left msg -> do { diagnosticDs msg; return Nothing } ;
-           Right (rule_bndrs, _fn, rule_lhs_args) -> do
-
-       { this_mod <- getModule
-       ; let fn_unf    = realIdUnfolding poly_id
-             simpl_opts = initSimpleOpts dflags
-             spec_unf   = specUnfolding simpl_opts spec_bndrs core_app rule_lhs_args fn_unf
-             spec_id    = mkLocalId spec_name ManyTy spec_ty -- Specialised binding is toplevel, hence Many.
-                            `setInlinePragma` inl_prag
-                            `setIdUnfolding`  spec_unf
-
-             rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")
-                               poly_id rule_bndrs rule_lhs_args
-                               (mkVarApps (Var spec_id) spec_bndrs)
-             spec_rhs = mkLams spec_bndrs (core_app poly_rhs)
-
-       ; dsWarnOrphanRule rule
-
-       ; return (Just (unitOL (spec_id, spec_rhs), rule))
-            -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
-            --     makeCorePair overwrites the unfolding, which we have
-            --     just created using specUnfolding
-       } } }
-  where
-    is_local_id = isJust mb_poly_rhs
-    poly_rhs | Just rhs <-  mb_poly_rhs
-             = rhs          -- Local Id; this is its rhs
-             | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
-             = unfolding    -- Imported Id; this is its unfolding
-                            -- Use realIdUnfolding so we get the unfolding
-                            -- even when it is a loop breaker.
-                            -- We want to specialise recursive functions!
-             | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
-                            -- The type checker has checked that it *has* an unfolding
-
-    id_inl = idInlinePragma poly_id
-
-    -- See Note [Activation pragmas for SPECIALISE]
-    inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl
-             | not is_local_id  -- See Note [Specialising imported functions]
-                                 -- in OccurAnal
-             , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
-             | otherwise                               = id_inl
-     -- Get the INLINE pragma from SPECIALISE declaration, or,
-     -- failing that, from the original Id
-
-    spec_prag_act = inlinePragmaActivation spec_inl
-
-    -- See Note [Activation pragmas for SPECIALISE]
-    -- no_act_spec is True if the user didn't write an explicit
-    -- phase specification in the SPECIALISE pragma
-    no_act_spec = case inlinePragmaSpec spec_inl of
-                    NoInline _   -> isNeverActive  spec_prag_act
-                    Opaque _     -> isNeverActive  spec_prag_act
-                    _            -> isAlwaysActive spec_prag_act
-    rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit
-             | otherwise   = spec_prag_act                   -- Specified by user
-
-
-dsWarnOrphanRule :: CoreRule -> DsM ()
-dsWarnOrphanRule rule
-  = when (isOrphan (ru_orphan rule)) $
-    diagnosticDs (DsOrphanRule rule)
-
-{- Note [SPECIALISE on INLINE functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We used to warn that using SPECIALISE for a function marked INLINE
-would be a no-op; but it isn't!  Especially with worker/wrapper split
-we might have
-   {-# INLINE f #-}
-   f :: Ord a => Int -> a -> ...
-   f d x y = case x of I# x' -> $wf d x' y
-
-We might want to specialise 'f' so that we in turn specialise '$wf'.
-We can't even /name/ '$wf' in the source code, so we can't specialise
-it even if we wanted to.  #10721 is a case in point.
-
-Note [Activation pragmas for SPECIALISE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-From a user SPECIALISE pragma for f, we generate
-  a) A top-level binding    spec_fn = rhs
-  b) A RULE                 f dOrd = spec_fn
-
-We need two pragma-like things:
-
-* spec_fn's inline pragma: inherited from f's inline pragma (ignoring
-                           activation on SPEC), unless overridden by SPEC INLINE
-
-* Activation of RULE: from SPECIALISE pragma (if activation given)
-                      otherwise from f's inline pragma
-
-This is not obvious (see #5237)!
-
-Examples      Rule activation   Inline prag on spec'd fn
----------------------------------------------------------------------
-SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]
-                                  copy f's prag
-
-NOINLINE f
-SPEC [n] f :: ty            [n]   NOINLINE
-                                  copy f's prag
-
-NOINLINE [k] f
-SPEC [n] f :: ty            [n]   NOINLINE [k]
-                                  copy f's prag
-
-INLINE [k] f
-SPEC [n] f :: ty            [n]   INLINE [k]
-                                  copy f's prag
-
-SPEC INLINE [n] f :: ty     [n]   INLINE [n]
-                                  (ignore INLINE prag on f,
-                                  same activation for rule and spec'd fn)
-
-NOINLINE [k] f
-SPEC f :: ty                [n]   INLINE [k]
-
-
-************************************************************************
-*                                                                      *
-\subsection{Adding inline pragmas}
-*                                                                      *
-************************************************************************
--}
-
-decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr
-                 -> VarSet   -- Free vars of the RHS
-                 -> Either DsMessage ([Var], Id, [CoreExpr])
--- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,
--- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
--- may add some extra dictionary binders (see Note [Free dictionaries on rule LHS])
---
--- Returns an error message if the LHS isn't of the expected shape
--- Note [Decomposing the left-hand side of a RULE]
-decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs
-  | Var funId <- fun2
-  , Just con <- isDataConId_maybe funId
-  = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons]
-
-  | otherwise = case decompose fun2 args2 of
-        Nothing -> Left (DsRuleLhsTooComplicated orig_lhs lhs2)
-        Just (fn_id, args)
-          | not (null unbound) ->
-            -- Check for things unbound on LHS
-            -- See Note [Unused spec binders]
-            -- pprTrace "decomposeRuleLhs 1" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
-            --                                     , text "orig_lhs:" <+> ppr orig_lhs
-            --                                     , text "lhs_fvs:" <+> ppr lhs_fvs
-            --                                     , text "rhs_fvs:" <+> ppr rhs_fvs
-            --                                     , text "unbound:" <+> ppr unbound
-            --                                     ]) $
-            Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2)
-          | otherwise ->
-            -- pprTrace "decomposeRuleLhs 2" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
-            --                                    , text "orig_lhs:" <+> ppr orig_lhs
-            --                                    , text "lhs1:"     <+> ppr lhs1
-            --                                    , text "extra_bndrs:" <+> ppr extra_bndrs
-            --                                    , text "fn_id:" <+> ppr fn_id
-            --                                    , text "args:"   <+> ppr args
-            --                                    , text "args fvs:" <+> ppr (exprsFreeVarsList args)
-            --                                    ]) $
-            Right (trimmed_bndrs ++ extra_bndrs, fn_id, args)
-
-          where -- See Note [Variables unbound on the LHS]
-                lhs_fvs = exprsFreeVars args
-                all_fvs       = lhs_fvs `unionVarSet` rhs_fvs
-                trimmed_bndrs = filter (`elemVarSet` all_fvs) orig_bndrs
-                unbound       = filterOut (`elemVarSet` lhs_fvs) trimmed_bndrs
-                    -- Needed on RHS but not bound on LHS
-
-                -- Add extra tyvar binders: Note [Free tyvars on rule LHS]
-                -- and extra dict binders: Note [Free dictionaries on rule LHS]
-                extra_bndrs = scopedSort extra_tvs ++ extra_dicts
-                  where
-                    extra_tvs   = [ v | v <- extra_vars, isTyVar v ]
-                extra_dicts =
-                  [ mkLocalId (localiseName (idName d)) ManyTy (idType d)
-                  | d <- extra_vars, isDictId d ]
-                extra_vars  =
-                  [ v
-                  | v <- exprsFreeVarsList args
-                  , not (v `elemVarSet` orig_bndr_set)
-                  , not (v == fn_id) ]
-                    -- fn_id: do not quantify over the function itself, which may
-                    -- itself be a dictionary (in pathological cases, #10251)
-
- where
-   simpl_opts    = initSimpleOpts dflags
-   orig_bndr_set = mkVarSet orig_bndrs
-
-   lhs1         = drop_dicts orig_lhs
-   lhs2         = simpleOptExpr simpl_opts lhs1  -- See Note [Simplify rule LHS]
-   (fun2,args2) = collectArgs lhs2
-
-   decompose (Var fn_id) args
-      | not (fn_id `elemVarSet` orig_bndr_set)
-      = Just (fn_id, args)
-
-   decompose _ _ = Nothing
-
-   drop_dicts :: CoreExpr -> CoreExpr
-   drop_dicts e
-       = wrap_lets needed bnds body
-     where
-       needed = orig_bndr_set `minusVarSet` exprFreeVars body
-       (bnds, body) = split_lets (occurAnalyseExpr e)
-           -- The occurAnalyseExpr drops dead bindings which is
-           -- crucial to ensure that every binding is used later;
-           -- which in turn makes wrap_lets work right
-
-   split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
-   split_lets (Let (NonRec d r) body)
-     | isDictId d
-     = ((d,r):bs, body')
-     where (bs, body') = split_lets body
-
-    -- handle "unlifted lets" too, needed for "map/coerce"
-   split_lets (Case r d _ [Alt DEFAULT _ body])
-     | isCoVar d
-     = ((d,r):bs, body')
-     where (bs, body') = split_lets body
-
-   split_lets e = ([], e)
-
-   wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
-   wrap_lets _ [] body = body
-   wrap_lets needed ((d, r) : bs) body
-     | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body)
-     | otherwise                         = wrap_lets needed bs body
-     where
-       rhs_fvs = exprFreeVars r
-       needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d
-
-{-
-Note [Variables unbound on the LHS]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We obviously want to complain about
-   RULE   forall x. f True = not x
-because the forall'd variable `x` is not bound on the LHS.
-
-It can be a bit delicate when dictionaries are involved.
-Consider #22471
-  {-# RULES "foo" forall (f :: forall a. [a] -> Int).
-                  foo (\xs. 1 + f xs) = 2 + foo f #-}
-
-We get two dicts on the LHS, one from `1` and one from `+`.
-For reasons described in Note [The SimplifyRule Plan] in
-GHC.Tc.Gen.Rule, we quantify separately over those dictionaries:
-   forall f (d1::Num Int) (d2 :: Num Int).
-   foo (\xs. (+) d1 (fromInteger d2 1) xs) = ...
-
-Now the desugarer shortcircuits (fromInteger d2 1) to (I# 1); so d2 is
-not mentioned at all (on LHS or RHS)! We don't want to complain about
-and unbound d2.  Hence the trimmed_bndrs.
-
-Note [Decomposing the left-hand side of a RULE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are several things going on here.
-* drop_dicts: see Note [Drop dictionary bindings on rule LHS]
-* simpleOptExpr: see Note [Simplify rule LHS]
-* extra_dict_bndrs: see Note [Free dictionaries on rule LHS]
-
-Note [Free tyvars on rule LHS]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  data T a = C
-
-  foo :: T a -> Int
-  foo C = 1
-
-  {-# RULES "myrule"  foo C = 1 #-}
-
-After type checking the LHS becomes (foo alpha (C alpha)), where alpha
-is an unbound meta-tyvar.  The zonker in GHC.Tc.Utils.Zonk is careful not to
-turn the free alpha into Any (as it usually does).  Instead it turns it
-into a TyVar 'a'.  See Note [Zonking the LHS of a RULE] in "GHC.Tc.Utils.Zonk".
-
-Now we must quantify over that 'a'.  It's /really/ inconvenient to do that
-in the zonker, because the HsExpr data type is very large.  But it's /easy/
-to do it here in the desugarer.
-
-Moreover, we have to do something rather similar for dictionaries;
-see Note [Free dictionaries on rule LHS].   So that's why we look for
-type variables free on the LHS, and quantify over them.
-
-This relies on there not being any in-scope tyvars, which is true for
-user-defined RULEs, which are always top-level.
-
-Note [Free dictionaries on rule LHS]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
-which is presumably in scope at the function definition site, we can quantify
-over it too.  *Any* dict with that type will do.
-
-So for example when you have
-        f :: Eq a => a -> a
-        f = <rhs>
-        ... SPECIALISE f :: Int -> Int ...
-
-Then we get the SpecPrag
-        SpecPrag (f Int dInt)
-
-And from that we want the rule
-
-        RULE forall dInt. f Int dInt = f_spec
-        f_spec = let f = <rhs> in f Int dInt
-
-But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
-Name, and you can't bind them in a lambda or forall without getting things
-confused.   Likewise it might have a stable unfolding or something, which would be
-utterly bogus. So we really make a fresh Id, with the same unique and type
-as the old one, but with an Internal name and no IdInfo.
-
-Note [Drop dictionary bindings on rule LHS]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-drop_dicts drops dictionary bindings on the LHS where possible.
-   E.g.  let d:Eq [Int] = $fEqList $fEqInt in f d
-     --> f d
-   Reasoning here is that there is only one d:Eq [Int], and so we can
-   quantify over it. That makes 'd' free in the LHS, but that is later
-   picked up by extra_dict_bndrs (see Note [Unused spec binders]).
-
-   NB 1: We can only drop the binding if the RHS doesn't bind
-         one of the orig_bndrs, which we assume occur on RHS.
-         Example
-            f :: (Eq a) => b -> a -> a
-            {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
-         Here we want to end up with
-            RULE forall d:Eq a.  f ($dfEqList d) = f_spec d
-         Of course, the ($dfEqlist d) in the pattern makes it less likely
-         to match, but there is no other way to get d:Eq a
-
-   NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
-         the evidence bindings to be wrapped around the outside of the
-         LHS.  (After simplOptExpr they'll usually have been inlined.)
-         dsHsWrapper does dependency analysis, so that civilised ones
-         will be simple NonRec bindings.  We don't handle recursive
-         dictionaries!
-
-    NB3: In the common case of a non-overloaded, but perhaps-polymorphic
-         specialisation, we don't need to bind *any* dictionaries for use
-         in the RHS. For example (#8331)
-             {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}
-             useAbstractMonad :: MonadAbstractIOST m => m Int
-         Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code
-         but the RHS uses no dictionaries, so we want to end up with
-             RULE forall s (d :: MonadAbstractIOST (ReaderT s)).
-                useAbstractMonad (ReaderT s) d = $suseAbstractMonad s
-
-   #8848 is a good example of where there are some interesting
-   dictionary bindings to discard.
-
-The drop_dicts algorithm is based on these observations:
-
-  * Given (let d = rhs in e) where d is a DictId,
-    matching 'e' will bind e's free variables.
-
-  * So we want to keep the binding if one of the needed variables (for
-    which we need a binding) is in fv(rhs) but not already in fv(e).
-
-  * The "needed variables" are simply the orig_bndrs.  Consider
-       f :: (Eq a, Show b) => a -> b -> String
-       ... SPECIALISE f :: (Show b) => Int -> b -> String ...
-    Then orig_bndrs includes the *quantified* dictionaries of the type
-    namely (dsb::Show b), but not the one for Eq Int
-
-So we work inside out, applying the above criterion at each step.
-
-
-Note [Simplify rule LHS]
-~~~~~~~~~~~~~~~~~~~~~~~~
-simplOptExpr occurrence-analyses and simplifies the LHS:
-
-   (a) Inline any remaining dictionary bindings (which hopefully
-       occur just once)
-
-   (b) Substitute trivial lets, so that they don't get in the way.
-       Note that we substitute the function too; we might
-       have this as a LHS:  let f71 = M.f Int in f71
-
-   (c) Do eta reduction.  To see why, consider the fold/build rule,
-       which without simplification looked like:
-          fold k z (build (/\a. g a))  ==>  ...
-       This doesn't match unless you do eta reduction on the build argument.
-       Similarly for a LHS like
-         augment g (build h)
-       we do not want to get
-         augment (\a. g a) (build h)
-       otherwise we don't match when given an argument like
-          augment (\a. h a a) (build h)
-
-Note [Unused spec binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-        f :: a -> a
-        ... SPECIALISE f :: Eq a => a -> a ...
-It's true that this *is* a more specialised type, but the rule
-we get is something like this:
-        f_spec d = f
-        RULE: f = f_spec d
-Note that the rule is bogus, because it mentions a 'd' that is
-not bound on the LHS!  But it's a silly specialisation anyway, because
-the constraint is unused.  We could bind 'd' to (error "unused")
-but it seems better to reject the program because it's almost certainly
-a mistake.  That's what the isDeadBinder call detects.
-
-Note [No RULES on datacons]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Previously, `RULES` like
-
-    "JustNothing" forall x . Just x = Nothing
-
-were allowed. Simon Peyton Jones says this seems to have been a
-mistake, that such rules have never been supported intentionally,
-and that he doesn't know if they can break in horrible ways.
-Furthermore, Ben Gamari and Reid Barton are considering trying to
-detect the presence of "static data" that the simplifier doesn't
-need to traverse at all. Such rules do not play well with that.
-So for now, we ban them altogether as requested by #13290. See also #7398.
-
-
-************************************************************************
-*                                                                      *
-                Desugaring evidence
-*                                                                      *
-************************************************************************
-
-Note [Desugaring WpFun]
-~~~~~~~~~~~~~~~~~~~~~~~
-See comments on WpFun in GHC.Tc.Types.Evidence for what WpFun means.
-Roughly:
-
-  (WpFun w_arg w_res)[ e ] = \x. w_res[ e w_arg[x] ]
-
-This eta-expansion risk duplicating work, if `e` is not in HNF.
-At one stage I thought we could avoid that by desugaring to
-      let f = e in \x. w_res[ f w_arg[x] ]
-But that /fundamentally/ doesn't work, because `w_res` may bind
-evidence that is used in `e`.
-
-This question arose when thinking about deep subsumption; see
-https://github.com/ghc-proposals/ghc-proposals/pull/287#issuecomment-1125419649).
--}
-
-dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
-dsHsWrapper WpHole            = return $ \e -> e
-dsHsWrapper (WpTyApp ty)      = return $ \e -> App e (Type ty)
-dsHsWrapper (WpEvLam ev)      = return $ Lam ev
-dsHsWrapper (WpTyLam tv)      = return $ Lam tv
-dsHsWrapper (WpLet ev_binds)  = do { bs <- dsTcEvBinds ev_binds
-                                   ; return (mkCoreLets bs) }
-dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1
-                                   ; w2 <- dsHsWrapper c2
-                                   ; return (w1 . w2) }
-dsHsWrapper (WpFun c1 c2 (Scaled w t1))  -- See Note [Desugaring WpFun]
-                              = do { x <- newSysLocalDs w t1
-                                   ; w1 <- dsHsWrapper c1
-                                   ; w2 <- dsHsWrapper c2
-                                   ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a
-                                         arg     = w1 (Var x)
-                                   ; return (\e -> (Lam x (w2 (app e arg)))) }
-dsHsWrapper (WpCast co)       = assert (coercionRole co == Representational) $
-                                return $ \e -> mkCastDs e co
-dsHsWrapper (WpEvApp tm)      = do { core_tm <- dsEvTerm tm
-                                   ; return (\e -> App e core_tm) }
-  -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
-dsHsWrapper (WpMultCoercion co) = do { when (not (isReflexiveCo co)) $
-                                         diagnosticDs DsMultiplicityCoercionsNotSupported
-                                     ; return $ \e -> e }
---------------------------------------
-dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
-dsTcEvBinds_s []       = return []
-dsTcEvBinds_s (b:rest) = assert (null rest) $  -- Zonker ensures null
-                         dsTcEvBinds b
-
-dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
-dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"    -- Zonker has got rid of this
-dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
-
-dsEvBinds :: Bag EvBind -> DsM [CoreBind]
-dsEvBinds bs
-  = do { ds_bs <- mapBagM dsEvBind bs
-       ; return (mk_ev_binds ds_bs) }
-
-mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind]
--- We do SCC analysis of the evidence bindings, /after/ desugaring
--- them. This is convenient: it means we can use the GHC.Core
--- free-variable functions rather than having to do accurate free vars
--- for EvTerm.
-mk_ev_binds ds_binds
-  = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges)
-  where
-    edges :: [ Node EvVar (EvVar,CoreExpr) ]
-    edges = foldr ((:) . mk_node) [] ds_binds
-
-    mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)
-    mk_node b@(var, rhs)
-      = DigraphNode { node_payload = b
-                    , node_key = var
-                    , node_dependencies = nonDetEltsUniqSet $
-                                          exprFreeVars rhs `unionVarSet`
-                                          coVarsOfType (varType var) }
-      -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices
-      -- is still deterministic even if the edges are in nondeterministic order
-      -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.
-
-    ds_scc (AcyclicSCC (v,r)) = NonRec v r
-    ds_scc (CyclicSCC prs)    = Rec prs
-
-dsEvBind :: EvBind -> DsM (Id, CoreExpr)
-dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
-
-
-{-**********************************************************************
-*                                                                      *
-           Desugaring EvTerms
-*                                                                      *
-**********************************************************************-}
-
-dsEvTerm :: EvTerm -> DsM CoreExpr
-dsEvTerm (EvExpr e)          = return e
-dsEvTerm (EvTypeable ty ev)  = dsEvTypeable ty ev
-dsEvTerm (EvFun { et_tvs = tvs, et_given = given
-                , et_binds = ev_binds, et_body = wanted_id })
-  = do { ds_ev_binds <- dsTcEvBinds ev_binds
-       ; return $ (mkLams (tvs ++ given) $
-                   mkCoreLets ds_ev_binds $
-                   Var wanted_id) }
-
-
-{-**********************************************************************
-*                                                                      *
-           Desugaring Typeable dictionaries
-*                                                                      *
-**********************************************************************-}
-
-dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
--- Return a CoreExpr :: Typeable ty
--- This code is tightly coupled to the representation
--- of TypeRep, in base library Data.Typeable.Internal
-dsEvTypeable ty ev
-  = do { tyCl <- dsLookupTyCon typeableClassName    -- Typeable
-       ; let kind = typeKind ty
-             typeable_data_con = tyConSingleDataCon tyCl  -- "Data constructor"
-                                                    -- for Typeable
-
-       ; rep_expr <- ds_ev_typeable ty ev           -- :: TypeRep a
-
-       -- Package up the method as `Typeable` dictionary
-       ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] }
-
-type TypeRepExpr = CoreExpr
-
--- | Returns a @CoreExpr :: TypeRep ty@
-ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
-ds_ev_typeable ty (EvTypeableTyCon tc kind_ev)
-  = do { mkTrCon <- dsLookupGlobalId mkTrConName
-                    -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a
-       ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName
-       ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName
-                    -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep
-
-       ; tc_rep <- tyConRep tc                      -- :: TyCon
-       ; let ks = tyConAppArgs ty
-             -- Construct a SomeTypeRep
-             toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr
-             toSomeTypeRep t ev = do
-                 rep <- getRep ev t
-                 return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep]
-       ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev   -- :: TypeRep t
-       ; let -- :: [SomeTypeRep]
-             kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps
-
-         -- Note that we use the kind of the type, not the TyCon from which it
-         -- is constructed since the latter may be kind polymorphic whereas the
-         -- former we know is not (we checked in the solver).
-       ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty)
-                                         , Type ty
-                                         , tc_rep
-                                         , kind_args ]
-       -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr
-       ; return expr
-       }
-
-ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
-  | Just (t1,t2) <- splitAppTy_maybe ty
-  = do { e1  <- getRep ev1 t1
-       ; e2  <- getRep ev2 t2
-       ; mkTrApp <- dsLookupGlobalId mkTrAppName
-                    -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
-                    --            TypeRep a -> TypeRep b -> TypeRep (a b)
-       ; let (_, k1, k2) = splitFunTy (typeKind t1)  -- drop the multiplicity,
-                                                     -- since it's a kind
-       ; let expr =  mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])
-                            [ e1, e2 ]
-       -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr
-       ; return expr
-       }
-
-ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2)
-  | Just (_af,m,t1,t2) <- splitFunTy_maybe ty
-  = do { e1 <- getRep ev1 t1
-       ; e2 <- getRep ev2 t2
-       ; em <- getRep evm m
-       ; mkTrFun <- dsLookupGlobalId mkTrFunName
-                    -- mkTrFun :: forall (m :: Multiplicity) r1 r2 (a :: TYPE r1) (b :: TYPE r2).
-                    --            TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a % m -> b)
-       ; let r1 = getRuntimeRep t1
-             r2 = getRuntimeRep t2
-       ; return $ mkApps (mkTyApps (Var mkTrFun) [m, r1, r2, t1, t2])
-                         [ em, e1, e2 ]
-       }
-
-ds_ev_typeable ty (EvTypeableTyLit ev)
-  = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Solver.Interact
-    do { fun  <- dsLookupGlobalId tr_fun
-       ; dict <- dsEvTerm ev       -- Of type KnownNat/KnownSymbol
-       ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict ]) }
-  where
-    ty_kind = typeKind ty
-
-    -- tr_fun is the Name of
-    --       typeNatTypeRep    :: KnownNat    a => TypeRep a
-    -- of    typeSymbolTypeRep :: KnownSymbol a => TypeRep a
-    tr_fun | ty_kind `eqType` naturalTy      = typeNatTypeRepName
-           | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName
-           | ty_kind `eqType` charTy         = typeCharTypeRepName
-           | otherwise = panic "dsEvTypeable: unknown type lit kind"
-
-ds_ev_typeable ty ev
-  = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev)
-
-getRep :: EvTerm          -- ^ EvTerm for @Typeable ty@
-       -> Type            -- ^ The type @ty@
-       -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@
-                          -- namely @typeRep# dict@
--- Remember that
---   typeRep# :: forall k (a::k). Typeable k a -> TypeRep a
-getRep ev ty
-  = do { typeable_expr <- dsEvTerm ev
-       ; typeRepId     <- dsLookupGlobalId typeRepIdName
-       ; let ty_args = [typeKind ty, ty]
-       ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) }
-
-tyConRep :: TyCon -> DsM CoreExpr
--- Returns CoreExpr :: TyCon
-tyConRep tc
-  | Just tc_rep_nm <- tyConRepName_maybe tc
-  = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm
-       ; return (Var tc_rep_id) }
-  | otherwise
-  = pprPanic "tyConRep" (ppr tc)
diff --git a/compiler/GHC/HsToCore/Binds.hs-boot b/compiler/GHC/HsToCore/Binds.hs-boot
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Binds.hs-boot
+++ /dev/null
@@ -1,6 +0,0 @@
-module GHC.HsToCore.Binds where
-import GHC.HsToCore.Monad ( DsM )
-import GHC.Core           ( CoreExpr )
-import GHC.Tc.Types.Evidence    (HsWrapper)
-
-dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
diff --git a/compiler/GHC/HsToCore/Breakpoints.hs b/compiler/GHC/HsToCore/Breakpoints.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Breakpoints.hs
+++ /dev/null
@@ -1,54 +0,0 @@
-module GHC.HsToCore.Breakpoints
-  ( mkModBreaks
-  ) where
-
-import GHC.Prelude
-
-import qualified GHC.Runtime.Interpreter as GHCi
-import GHC.Runtime.Interpreter.Types
-import GHCi.RemoteTypes
-import GHC.ByteCode.Types
-import GHC.Stack.CCS
-import GHC.Unit
-
-import GHC.HsToCore.Ticks (Tick (..))
-
-import GHC.Data.SizedSeq
-import GHC.Utils.Outputable as Outputable
-
-import Data.List (intersperse)
-import Data.Array
-
-mkModBreaks :: Interp -> Module -> SizedSeq Tick -> IO ModBreaks
-mkModBreaks interp mod extendedMixEntries
-  = do
-    let count = fromIntegral $ sizeSS extendedMixEntries
-        entries = ssElts extendedMixEntries
-
-    breakArray <- GHCi.newBreakArray interp count
-    ccs <- mkCCSArray interp mod count entries
-    let
-           locsTicks  = listArray (0,count-1) [ tick_loc  t | t <- entries ]
-           varsTicks  = listArray (0,count-1) [ tick_ids  t | t <- entries ]
-           declsTicks = listArray (0,count-1) [ tick_path t | t <- entries ]
-    return $ emptyModBreaks
-                       { modBreaks_flags = breakArray
-                       , modBreaks_locs  = locsTicks
-                       , modBreaks_vars  = varsTicks
-                       , modBreaks_decls = declsTicks
-                       , modBreaks_ccs   = ccs
-                       }
-
-mkCCSArray
-  :: Interp -> Module -> Int -> [Tick]
-  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
-mkCCSArray interp modul count entries
-  | GHCi.interpreterProfiled interp = do
-      let module_str = moduleNameString (moduleName modul)
-      costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries)
-      return (listArray (0,count-1) costcentres)
-  | otherwise = return (listArray (0,-1) [])
- where
-    mk_one t = (name, src)
-      where name = concat $ intersperse "." $ tick_path t
-            src = renderWithContext defaultSDocContext $ ppr $ tick_loc t
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ /dev/null
@@ -1,139 +0,0 @@
-{-
-(c) Galois, 2006
-(c) University of Glasgow, 2007
--}
-
-module GHC.HsToCore.Coverage
-  ( writeMixEntries
-  , hpcInitCode
-  ) where
-
-import GHC.Prelude as Prelude
-
-import GHC.Unit
-
-import GHC.HsToCore.Ticks
-
-import GHC.Platform
-
-import GHC.Data.FastString
-import GHC.Data.SizedSeq
-
-import GHC.Cmm.CLabel
-
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Outputable
-import GHC.Types.ForeignStubs
-import GHC.Types.HpcInfo
-import GHC.Types.SrcLoc
-
-import Control.Monad
-import Data.Time
-import System.Directory
-
-import Trace.Hpc.Mix
-import Trace.Hpc.Util
-
-import qualified Data.ByteString as BS
-
-writeMixEntries
-  :: FilePath -> Module -> SizedSeq Tick -> FilePath -> IO Int
-writeMixEntries hpc_dir mod extendedMixEntries filename
-  = do
-        let count = fromIntegral $ sizeSS extendedMixEntries
-            entries = ssElts extendedMixEntries
-
-            mod_name = moduleNameString (moduleName mod)
-
-            hpc_mod_dir
-              | moduleUnit mod == mainUnit  = hpc_dir
-              | otherwise = hpc_dir ++ "/" ++ unitString (moduleUnit mod)
-
-            tabStop = 8 -- <tab> counts as a normal char in GHC's
-                        -- location ranges.
-
-        createDirectoryIfMissing True hpc_mod_dir
-        modTime <- getModificationUTCTime filename
-        let entries' = [ (hpcPos, tick_label t)
-                       | t <- entries, hpcPos <- [mkHpcPos $ tick_loc t] ]
-        when (entries' `lengthIsNot` count) $
-          panic "the number of .mix entries are inconsistent"
-        let hashNo = mixHash filename modTime tabStop entries'
-        mixCreate hpc_mod_dir mod_name
-                       $ Mix filename modTime (toHash hashNo) tabStop entries'
-        return hashNo
-
-mkHpcPos :: SrcSpan -> HpcPos
-mkHpcPos pos@(RealSrcSpan s _)
-   | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
-                                    srcSpanStartCol s,
-                                    srcSpanEndLine s,
-                                    srcSpanEndCol s - 1)
-                              -- the end column of a SrcSpan is one
-                              -- greater than the last column of the
-                              -- span (see SrcLoc), whereas HPC
-                              -- expects to the column range to be
-                              -- inclusive, hence we subtract one above.
-mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
-
--- For the hash value, we hash everything: the file name,
---  the timestamp of the original source file, the tab stop,
---  and the mix entries. We cheat, and hash the show'd string.
--- This hash only has to be hashed at Mix creation time,
--- and is for sanity checking only.
-mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
-mixHash file tm tabstop entries = fromIntegral $ hashString
-        (show $ Mix file tm 0 tabstop entries)
-
-{-
-************************************************************************
-*                                                                      *
-*              initialisation
-*                                                                      *
-************************************************************************
--}
-
-{- | Create HPC initialization C code for a module
-
-Each module compiled with -fhpc declares an initialisation function of
-the form `hpc_init_<module>()`, which is emitted into the _stub.c file
-and annotated with __attribute__((constructor)) so that it gets
-executed at startup time.
-
-The function's purpose is to call hs_hpc_module to register this
-module with the RTS, and it looks something like this:
-
-> static void hpc_init_Main(void) __attribute__((constructor));
-> static void hpc_init_Main(void)
-> {
->   extern StgWord64 _hpc_tickboxes_Main_hpc[];
->   hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);
-> }
--}
-hpcInitCode :: Platform -> Module -> HpcInfo -> CStub
-hpcInitCode _ _ (NoHpcInfo {}) = mempty
-hpcInitCode platform this_mod (HpcInfo tickCount hashNo)
- = initializerCStub platform fn_name decls body
-  where
-    fn_name = mkInitializerStubLabel this_mod (fsLit "hpc")
-    decls = text "extern StgWord64 " <> tickboxes <> text "[]" <> semi
-    body = text "hs_hpc_module" <>
-              parens (hcat (punctuate comma [
-                  doubleQuotes full_name_str,
-                  int tickCount, -- really StgWord32
-                  int hashNo,    -- really StgWord32
-                  tickboxes
-                ])) <> semi
-
-    tickboxes = pprCLabel platform (mkHpcTicksLabel $ this_mod)
-
-    module_name  = hcat (map (text.charToC) $ BS.unpack $
-                         bytesFS (moduleNameFS (moduleName this_mod)))
-    package_name = hcat (map (text.charToC) $ BS.unpack $
-                         bytesFS (unitFS  (moduleUnit this_mod)))
-    full_name_str
-       | moduleUnit this_mod == mainUnit
-       = module_name
-       | otherwise
-       = package_name <> char '/' <> module_name
diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Docs.hs
+++ /dev/null
@@ -1,620 +0,0 @@
--- | Extract docs from the renamer output so they can be serialized.
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE BangPatterns #-}
-
-module GHC.HsToCore.Docs where
-
-import GHC.Prelude
-import GHC.Data.Bag
-import GHC.Hs.Binds
-import GHC.Hs.Doc
-import GHC.Hs.Decls
-import Language.Haskell.Syntax.Extension
-import GHC.Hs.Extension
-import GHC.Hs.Type
-import GHC.Hs.Utils
-import GHC.Types.Name
-import GHC.Types.Name.Set
-import GHC.Types.SrcLoc
-import GHC.Tc.Types
-import GHC.Parser.Annotation
-
-import Control.Applicative
-import Control.Monad.IO.Class
-import Data.Bifunctor (first)
-import Data.Foldable (toList)
-import Data.IntMap (IntMap)
-import qualified Data.IntMap as IM
-import Data.Map.Strict (Map)
-import qualified Data.Map as M
-import qualified Data.Set as Set
-import Data.Maybe
-import Data.Semigroup
-import GHC.IORef (readIORef)
-import GHC.Unit.Types
-import GHC.Hs
-import GHC.Types.Avail
-import GHC.Unit.Module
-import qualified Data.List.NonEmpty as NonEmpty
-import Data.List.NonEmpty (NonEmpty ((:|)))
-import GHC.Unit.Module.Imported
-import GHC.Driver.Session
-import GHC.Types.TypeEnv
-import GHC.Types.Id
-import GHC.Types.Unique.Map
-
--- | Extract docs from renamer output.
--- This is monadic since we need to be able to read documentation added from
--- Template Haskell's @putDoc@, which is stored in 'tcg_th_docs'.
-extractDocs :: MonadIO m
-            => DynFlags -> TcGblEnv
-            -> m (Maybe Docs)
-            -- ^
-            -- 1. Module header
-            -- 2. Docs on top level declarations
-            -- 3. Docs on arguments
-extractDocs dflags
-      TcGblEnv { tcg_semantic_mod = semantic_mdl
-               , tcg_mod = mdl
-               , tcg_rn_decls = Just rn_decls
-               , tcg_rn_exports = mb_rn_exports
-               , tcg_exports = all_exports
-               , tcg_imports = import_avails
-               , tcg_insts = insts
-               , tcg_fam_insts = fam_insts
-               , tcg_doc_hdr = mb_doc_hdr
-               , tcg_th_docs = th_docs_var
-               , tcg_type_env = ty_env
-               } = do
-    th_docs <- liftIO $ readIORef th_docs_var
-    let doc_hdr = (unLoc <$> mb_doc_hdr)
-        ExtractedTHDocs th_hdr th_decl_docs th_arg_docs th_inst_docs = extractTHDocs th_docs
-        mod_docs
-         =  Docs
-         { docs_mod_hdr = th_hdr <|> doc_hdr
-         -- Left biased union (see #21220)
-         , docs_decls = plusUniqMap_C (\a _ -> a)
-                          ((:[]) <$> th_decl_docs `plusUniqMap` th_inst_docs)
-                          -- These will not clash so safe to use plusUniqMap
-                          doc_map
-         , docs_args = th_arg_docs `unionArgMaps` arg_map
-         , docs_structure = doc_structure
-         , docs_named_chunks = named_chunks
-         , docs_haddock_opts = haddockOptions dflags
-         , docs_language = language_
-         , docs_extensions = exts
-         }
-    pure (Just mod_docs)
-  where
-    exts = extensionFlags dflags
-    language_ = language dflags
-
-    -- We need to lookup the Names for default methods, so we
-    -- can put them in the correct map
-    -- See Note [default method Name] in GHC.Iface.Recomp
-    def_meths_env = mkOccEnv [(occ, nm)
-                             | id <- typeEnvIds ty_env
-                             , let nm = idName id
-                                   occ = nameOccName nm
-                             , isDefaultMethodOcc occ
-                             ]
-
-    (doc_map, arg_map) = mkMaps def_meths_env local_insts decls_with_docs
-    decls_with_docs = topDecls rn_decls
-    local_insts = filter (nameIsLocalOrFrom semantic_mdl)
-                         $ map getName insts ++ map getName fam_insts
-    doc_structure = mkDocStructure mdl import_avails mb_rn_exports rn_decls
-                                   all_exports def_meths_env
-    named_chunks = getNamedChunks (isJust mb_rn_exports) rn_decls
-extractDocs _ _ = pure Nothing
-
--- | If we have an explicit export list, we extract the documentation structure
--- from that.
--- Otherwise we use the renamed exports and declarations.
-mkDocStructure :: Module                               -- ^ The current module
-               -> ImportAvails                         -- ^ Imports
-               -> Maybe [(LIE GhcRn, Avails)] -- ^ Explicit export list
-               -> HsGroup GhcRn
-               -> [AvailInfo]                          -- ^ All exports
-               -> OccEnv Name                          -- ^ Default Methods
-               -> DocStructure
-mkDocStructure mdl import_avails (Just export_list) _ _ _ =
-    mkDocStructureFromExportList mdl import_avails export_list
-mkDocStructure _ _ Nothing rn_decls all_exports def_meths_env =
-    mkDocStructureFromDecls def_meths_env all_exports rn_decls
-
--- TODO:
--- * Maybe remove items that export nothing?
--- * Combine sequences of DsiExports?
--- * Check the ordering of avails in DsiModExport
-mkDocStructureFromExportList
-  :: Module                         -- ^ The current module
-  -> ImportAvails
-  -> [(LIE GhcRn, Avails)] -- ^ Explicit export list
-  -> DocStructure
-mkDocStructureFromExportList mdl import_avails export_list =
-    toDocStructure . first unLoc <$> export_list
-  where
-    toDocStructure :: (IE GhcRn, Avails) -> DocStructureItem
-    toDocStructure = \case
-      (IEModuleContents _ lmn, avails) -> moduleExport (unLoc lmn) avails
-      (IEGroup _ level doc, _)         -> DsiSectionHeading level (unLoc doc)
-      (IEDoc _ doc, _)                 -> DsiDocChunk (unLoc doc)
-      (IEDocNamed _ name, _)           -> DsiNamedChunkRef name
-      (_, avails)                      -> DsiExports (nubAvails avails)
-
-    moduleExport :: ModuleName -- Alias
-                 -> Avails
-                 -> DocStructureItem
-    moduleExport alias avails =
-        DsiModExport (nubSortNE orig_names) (nubAvails avails)
-      where
-        orig_names = M.findWithDefault aliasErr alias aliasMap
-        aliasErr = error $ "mkDocStructureFromExportList: "
-                           ++ (moduleNameString . moduleName) mdl
-                           ++ ": Can't find alias " ++ moduleNameString alias
-        nubSortNE = NonEmpty.fromList .
-                    Set.toList .
-                    Set.fromList .
-                    NonEmpty.toList
-
-    -- Map from aliases to true module names.
-    aliasMap :: Map ModuleName (NonEmpty ModuleName)
-    aliasMap =
-        M.fromListWith (<>) $
-          (this_mdl_name, this_mdl_name :| [])
-          : (flip concatMap (moduleEnvToList imported) $ \(mdl, imvs) ->
-              [(imv_name imv, moduleName mdl :| []) | imv <- imvs])
-      where
-        this_mdl_name = moduleName mdl
-
-    imported :: ModuleEnv [ImportedModsVal]
-    imported = mapModuleEnv importedByUser (imp_mods import_avails)
-
--- | Figure out the documentation structure by correlating
--- the module exports with the located declarations.
-mkDocStructureFromDecls :: OccEnv Name -- ^ The default method environment
-                        -> [AvailInfo] -- ^ All exports, unordered
-                        -> HsGroup GhcRn
-                        -> DocStructure
-mkDocStructureFromDecls env all_exports decls =
-    map unLoc (sortLocated (docs ++ avails))
-  where
-    avails :: [Located DocStructureItem]
-    avails = flip fmap all_exports $ \avail ->
-      case M.lookup (availName avail) name_locs of
-        Just loc -> L loc (DsiExports [avail])
-        -- FIXME: This is just a workaround that we use when handling e.g.
-        -- associated data families like in the html-test Instances.hs.
-        Nothing -> noLoc (DsiExports [avail])
-        -- Nothing -> panicDoc "mkDocStructureFromDecls: No loc found for"
-        --                     (ppr avail)
-
-    docs = mapMaybe structuralDoc (hs_docs decls)
-
-    structuralDoc :: LDocDecl GhcRn
-                  -> Maybe (Located DocStructureItem)
-    structuralDoc = \case
-      L loc (DocCommentNamed _name doc) ->
-        -- TODO: Is this correct?
-        -- NB: There is no export list where we could reference the named chunk.
-        Just (L (locA loc) (DsiDocChunk (unLoc doc)))
-
-      L loc (DocGroup level doc) ->
-        Just (L (locA loc) (DsiSectionHeading level (unLoc doc)))
-
-      _ -> Nothing
-
-    name_locs = M.fromList (concatMap ldeclNames (ungroup decls))
-    ldeclNames (L loc d) = zip (getMainDeclBinder env d) (repeat (locA loc))
-
--- | Extract named documentation chunks from the renamed declarations.
---
--- If there is no explicit export list, we simply return an empty map
--- since there would be no way to link to a named chunk.
-getNamedChunks :: Bool -- ^ Do we have an explicit export list?
-               -> HsGroup (GhcPass pass)
-               -> Map String (HsDoc (GhcPass pass))
-getNamedChunks True decls =
-  M.fromList $ flip mapMaybe (unLoc <$> hs_docs decls) $ \case
-    DocCommentNamed name doc -> Just (name, unLoc doc)
-    _                        -> Nothing
-getNamedChunks False _ = M.empty
-
--- | Create decl and arg doc-maps by looping through the declarations.
--- For each declaration, find its names, its subordinates, and its doc strings.
-mkMaps :: OccEnv Name
-       -> [Name]
-       -> [(LHsDecl GhcRn, [HsDoc GhcRn])]
-       -> (UniqMap Name [HsDoc GhcRn], UniqMap Name (IntMap (HsDoc GhcRn)))
-mkMaps env instances decls =
-    ( listsToMapWith (++) (map (nubByName fst) decls')
-    , listsToMapWith (<>) (filterMapping (not . IM.null) args)
-    )
-  where
-    (decls', args) = unzip (map mappings decls)
-
-    listsToMapWith f = listToUniqMap_C f . concat
-
-    filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]
-    filterMapping p = map (filter (p . snd))
-
-    mappings :: (LHsDecl GhcRn, [HsDoc GhcRn])
-             -> ( [(Name, [HsDoc GhcRn])]
-                , [(Name, IntMap (HsDoc GhcRn))]
-                )
-    mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, doc) =
-           (dm, am)
-      where
-        args = declTypeDocs decl
-
-        subs :: [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
-        subs = subordinates env instanceMap decl
-
-        (subNs, subDocs, subArgs) =
-          unzip3 subs
-
-        ns = names l decl
-        dm = [(n, d) | (n, d) <- zip ns (repeat doc) ++ zip subNs subDocs, not $ all (isEmptyDocString . hsDocString) d]
-        am = [(n, args) | n <- ns] ++ zip subNs subArgs
-    mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = ([], [])
-
-    instanceMap :: Map RealSrcSpan Name
-    instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ]
-
-    names :: RealSrcSpan -> HsDecl GhcRn -> [Name]
-    names _ (InstD _ d) = maybeToList $ lookupSrcSpan (getInstLoc d) instanceMap
-    names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].
-    names _ decl = getMainDeclBinder env decl
-
-{-
-Note [1]
-~~~~~~~~
-We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried
-inside them. That should work for normal user-written instances (from
-looking at GHC sources). We can assume that commented instances are
-user-written. This lets us relate Names (from ClsInsts) to comments
-(associated with InstDecls and DerivDecls).
--}
-
-getMainDeclBinder
-  :: OccEnv Name -- ^ Default method environment for this module. See Note [default method Name] in GHC.Iface.Recomp
-  -> HsDecl GhcRn -> [Name]
-getMainDeclBinder _ (TyClD _ d) = [tcdName d]
-getMainDeclBinder _ (ValD _ d) =
-  case collectHsBindBinders CollNoDictBinders d of
-    []       -> []
-    (name:_) -> [name]
-getMainDeclBinder env (SigD _ d) = sigNameNoLoc env d
-getMainDeclBinder _   (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
-getMainDeclBinder _   (ForD _ (ForeignExport _ _ _ _)) = []
-getMainDeclBinder _ _ = []
-
-
--- | The "OccEnv Name" is the default method environment for this module
--- Ultimately, the a special "defaultMethodOcc" name is used for
--- the signatures on bindings for default methods. Unfortunately, this
--- name isn't generated until typechecking, so it is not in the renamed AST.
--- We have to look it up from the 'OccEnv' parameter constructed from the typechecked
--- AST.
--- See also Note [default method Name] in GHC.Iface.Recomp
-sigNameNoLoc :: forall a . (UnXRec a, HasOccName (IdP a)) => OccEnv (IdP a) -> Sig a -> [IdP a]
-sigNameNoLoc _   (TypeSig    _   ns _)         = map (unXRec @a) ns
-sigNameNoLoc _   (ClassOpSig _ False ns _)     = map (unXRec @a) ns
-sigNameNoLoc env (ClassOpSig _ True  ns _)     = mapMaybe (lookupOccEnv env . mkDefaultMethodOcc . occName) $ map (unXRec @a) ns
-sigNameNoLoc _   (PatSynSig  _   ns _)         = map (unXRec @a) ns
-sigNameNoLoc _   (SpecSig    _   n _ _)        = [unXRec @a n]
-sigNameNoLoc _   (InlineSig  _   n _)          = [unXRec @a n]
-sigNameNoLoc _   (FixSig _ (FixitySig _ ns _)) = map (unXRec @a) ns
-sigNameNoLoc _   _                             = []
-
--- Extract the source location where an instance is defined. This is used
--- to correlate InstDecls with their Instance/CoAxiom Names, via the
--- instanceMap.
-getInstLoc :: Anno (IdGhcP p) ~ SrcSpanAnnN => InstDecl (GhcPass p) -> SrcSpan
-getInstLoc = \case
-  ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLocA ty
-  -- The Names of data and type family instances have their SrcSpan's attached
-  -- to the *type constructor*. For example, the Name "D:R:Foo:Int" would have
-  -- its SrcSpan attached here:
-  --   type family Foo a
-  --   type instance Foo Int = Bool
-  --                 ^^^
-  DataFamInstD _ (DataFamInstDecl
-    { dfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l
-  -- Since CoAxioms' Names refer to the whole line for type family instances
-  -- in particular, we need to dig a bit deeper to pull out the entire
-  -- equation. This does not happen for data family instances, for some reason.
-  TyFamInstD _ (TyFamInstDecl
-    { tfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l
-
--- | Get all subordinate declarations inside a declaration, and their docs.
--- A subordinate declaration is something like the associate type or data
--- family of a type class.
-subordinates :: OccEnv Name -- ^ The default method environment
-             -> Map RealSrcSpan Name
-             -> HsDecl GhcRn
-             -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
-subordinates env instMap decl = case decl of
-  InstD _ (ClsInstD _ d) -> let
-    data_fams = do
-      DataFamInstDecl { dfid_eqn =
-        FamEqn { feqn_tycon = L l _
-               , feqn_rhs   = defn }} <- unLoc <$> cid_datafam_insts d
-      [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn
-    ty_fams = do
-      TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = L l _ } } <- unLoc <$> cid_tyfam_insts d
-      [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ]
-    in data_fams ++ ty_fams
-
-  InstD _ (DataFamInstD _ (DataFamInstDecl d))
-    -> dataSubs (feqn_rhs d)
-  TyClD _ d | isClassDecl d -> classSubs d
-            | isDataDecl  d -> dataSubs (tcdDataDefn d)
-  _ -> []
-  where
-    classSubs dd = [ (name, doc, declTypeDocs d)
-                   | (L _ d, doc) <- classDecls dd
-                   , name <- getMainDeclBinder env d, not (isValD d)
-                   ]
-    dataSubs :: HsDataDefn GhcRn
-             -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
-    dataSubs dd = constrs ++ fields  ++ derivs
-      where
-        cons = unLoc <$> dd_cons dd
-        constrs = [ ( unLoc cname
-                    , maybeToList $ fmap unLoc $ con_doc c
-                    , conArgDocs c)
-                  | c <- toList cons, cname <- getConNames c ]
-        fields  = [ (foExt n, maybeToList $ fmap unLoc doc, IM.empty)
-                  | Just flds <- toList $ fmap getRecConArgs_maybe cons
-                  , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
-                  , (L _ n) <- ns ]
-        derivs  = [ (instName, [unLoc doc], IM.empty)
-                  | (l, doc) <- concatMap (extract_deriv_clause_tys .
-                                           deriv_clause_tys . unLoc) $
-                                -- unLoc $ dd_derivs dd
-                                dd_derivs dd
-                  , Just instName <- [lookupSrcSpan l instMap] ]
-
-        extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDoc GhcRn)]
-        extract_deriv_clause_tys (L _ dct) =
-          case dct of
-            DctSingle _ ty -> maybeToList $ extract_deriv_ty ty
-            DctMulti _ tys -> mapMaybe extract_deriv_ty tys
-
-        extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDoc GhcRn)
-        extract_deriv_ty (L l (HsSig{sig_body = L _ ty})) =
-          case ty of
-            -- deriving (C a {- ^ Doc comment -})
-            HsDocTy _ _ doc -> Just (locA l, doc)
-            _               -> Nothing
-
--- | Extract constructor argument docs from inside constructor decls.
-conArgDocs :: ConDecl GhcRn -> IntMap (HsDoc GhcRn)
-conArgDocs (ConDeclH98{con_args = args}) =
-  h98ConArgDocs args
-conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =
-  gadtConArgDocs args (unLoc res_ty)
-
-h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap (HsDoc GhcRn)
-h98ConArgDocs con_args = case con_args of
-  PrefixCon _ args   -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args
-  InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)
-                                       , unLoc (hsScaledThing arg2) ]
-  RecCon _           -> IM.empty
-
-gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap (HsDoc GhcRn)
-gadtConArgDocs con_args res_ty = case con_args of
-  PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty]
-  RecConGADT _ _     -> con_arg_docs 1 [res_ty]
-
-con_arg_docs :: Int -> [HsType GhcRn] -> IntMap (HsDoc GhcRn)
-con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..]
-  where
-    f n (HsDocTy _ _ lds) = Just (n, unLoc lds)
-    f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds)
-    f _ _ = Nothing
-
-isValD :: HsDecl a -> Bool
-isValD (ValD _ _) = True
-isValD _ = False
-
--- | All the sub declarations of a class (that we handle), ordered by
--- source location, with documentation attached if it exists.
-classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])]
-classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls
-  where
-    decls = docs ++ defs ++ sigs ++ ats
-    docs  = mkDecls tcdDocs (DocD noExtField) class_
-    defs  = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_
-    sigs  = mkDecls tcdSigs (SigD noExtField) class_
-    ats   = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_
-
--- | Extract function argument docs from inside top-level decls.
-declTypeDocs :: HsDecl GhcRn -> IntMap (HsDoc GhcRn)
-declTypeDocs = \case
-  SigD  _ (TypeSig _ _ ty)          -> sigTypeDocs (unLoc (dropWildCards ty))
-  SigD  _ (ClassOpSig _ _ _ ty)     -> sigTypeDocs (unLoc ty)
-  SigD  _ (PatSynSig _ _ ty)        -> sigTypeDocs (unLoc ty)
-  ForD  _ (ForeignImport _ _ ty _)  -> sigTypeDocs (unLoc ty)
-  TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty)
-  _                                 -> IM.empty
-
-nubByName :: (a -> Name) -> [a] -> [a]
-nubByName f ns = go emptyNameSet ns
-  where
-    go _ [] = []
-    go s (x:xs)
-      | y `elemNameSet` s = go s xs
-      | otherwise         = let !s' = extendNameSet s y
-                            in x : go s' xs
-      where
-        y = f x
-
--- | Extract function argument docs from inside types.
-typeDocs :: HsType GhcRn -> IntMap (HsDoc GhcRn)
-typeDocs = go 0
-  where
-    go n = \case
-      HsForAllTy { hst_body = ty }          -> go n (unLoc ty)
-      HsQualTy   { hst_body = ty }          -> go n (unLoc ty)
-      HsFunTy _ _ (unLoc->HsDocTy _ _ x) ty -> IM.insert n (unLoc x) $ go (n+1) (unLoc ty)
-      HsFunTy _ _ _ ty                      -> go (n+1) (unLoc ty)
-      HsDocTy _ _ doc                       -> IM.singleton n (unLoc doc)
-      _                                     -> IM.empty
-
--- | Extract function argument docs from inside types.
-sigTypeDocs :: HsSigType GhcRn -> IntMap (HsDoc GhcRn)
-sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body)
-
--- | The top-level declarations of a module that we care about,
--- ordered by source location, with documentation attached if it exists.
-topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])]
-topDecls = filterClasses . filterDecls . collectDocs . sortLocatedA . ungroup
-
--- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
-ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
-ungroup group_ =
-  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField)  group_ ++
-  mkDecls hs_derivds             (DerivD noExtField) group_ ++
-  mkDecls hs_defds               (DefD noExtField)   group_ ++
-  mkDecls hs_fords               (ForD noExtField)   group_ ++
-  mkDecls hs_docs                (DocD noExtField)   group_ ++
-  mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField)  group_ ++
-  mkDecls (typesigs . hs_valds)  (SigD noExtField)   group_ ++
-  mkDecls (valbinds . hs_valds)  (ValD noExtField)   group_
-  where
-    typesigs :: HsValBinds GhcRn -> [LSig GhcRn]
-    typesigs (XValBindsLR (NValBinds _ sig)) = filter (isUserSig . unLoc) sig
-    typesigs ValBinds{} = error "expected XValBindsLR"
-
-    valbinds :: HsValBinds GhcRn -> [LHsBind GhcRn]
-    valbinds (XValBindsLR (NValBinds binds _)) =
-      concatMap bagToList . snd . unzip $ binds
-    valbinds ValBinds{} = error "expected XValBindsLR"
-
--- | Collect docs and attach them to the right declarations.
---
--- A declaration may have multiple doc strings attached to it.
-collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDoc p])]
--- ^ This is an example.
-collectDocs = go [] Nothing
-  where
-    go docs mprev decls = case (decls, mprev) of
-      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing)   -> go (unLoc s:docs) Nothing ds
-      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [unLoc s] Nothing ds
-      ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev)     -> go (unLoc s:docs) mprev ds
-      (d                                  : ds, Nothing)   -> go docs (Just d) ds
-      (d                                  : ds, Just prev) -> finished prev docs $ go [] (Just d) ds
-      ([]                                     , Nothing)   -> []
-      ([]                                     , Just prev) -> finished prev docs []
-
-    finished decl docs rest = (decl, reverse docs) : rest
-
--- | Filter out declarations that we don't handle in Haddock
-filterDecls :: forall p doc. UnXRec p => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)]
-filterDecls = filter (isHandled . unXRec @p . fst)
-  where
-    isHandled (ForD _ (ForeignImport {})) = True
-    isHandled (TyClD {})  = True
-    isHandled (InstD {})  = True
-    isHandled (DerivD {}) = True
-    isHandled (SigD _ d)  = isUserSig d
-    isHandled (ValD {})   = True
-    -- we keep doc declarations to be able to get at named docs
-    isHandled (DocD {})   = True
-    isHandled _ = False
-
-
--- | Go through all class declarations and filter their sub-declarations
-filterClasses :: forall p doc. (IsPass p) => [(LHsDecl (GhcPass p), doc)] -> [(LHsDecl (GhcPass p), doc)]
-filterClasses = map (first (fmap filterClass))
-  where
-    filterClass (TyClD x c@(ClassDecl {})) =
-      TyClD x $ c { tcdSigs =
-        filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }
-    filterClass d = d
-
--- | Was this signature given by the user?
-isUserSig :: Sig name -> Bool
-isUserSig TypeSig {}    = True
-isUserSig ClassOpSig {} = True
-isUserSig PatSynSig {}  = True
-isUserSig _             = False
-
--- | Take a field of declarations from a data structure and create HsDecls
--- using the given constructor
-mkDecls :: (struct -> [GenLocated l decl])
-        -> (decl -> hsDecl)
-        -> struct
-        -> [GenLocated l hsDecl]
-mkDecls field con = map (fmap con) . field
-
--- | Extracts out individual maps of documentation added via Template Haskell's
--- @putDoc@.
-extractTHDocs :: THDocs
-              -> ExtractedTHDocs
-extractTHDocs docs =
-  -- Split up docs into separate maps for each 'DocLoc' type
-  ExtractedTHDocs
-    { ethd_mod_header = docHeader
-    , ethd_decl_docs  = searchDocs decl
-    , ethd_arg_docs   = searchDocs args
-    , ethd_inst_docs  = searchDocs insts
-    }
-  where
-    docHeader :: Maybe (HsDoc GhcRn)
-    docHeader
-      | ((_, s):_) <- filter isModDoc (M.toList docs) = Just s
-      | otherwise = Nothing
-
-    isModDoc (ModuleDoc, _) = True
-    isModDoc _ = False
-
-    -- Folds over the docs, applying 'f' as the accumulating function.
-    -- We use different accumulating functions to sift out the specific types of
-    -- documentation
-    searchDocs :: (UniqMap Name a -> (DocLoc, HsDoc GhcRn) -> UniqMap Name a) -> UniqMap Name a
-    searchDocs f = foldl' f emptyUniqMap $ M.toList docs
-
-    -- Pick out the declaration docs
-    decl acc ((DeclDoc name), s) = addToUniqMap acc name s
-    decl acc _ = acc
-
-    -- Pick out the instance docs
-    insts acc ((InstDoc name), s) = addToUniqMap acc name s
-    insts acc _ = acc
-
-    -- Pick out the argument docs
-    args :: UniqMap Name (IntMap (HsDoc GhcRn))
-         -> (DocLoc, HsDoc GhcRn)
-         -> UniqMap Name (IntMap (HsDoc GhcRn))
-    args acc ((ArgDoc name i), s) =
-      -- Insert the doc for the arg into the argument map for the function. This
-      -- means we have to search to see if an map already exists for the
-      -- function, and insert the new argument if it exists, or create a new map
-       addToUniqMap_C (\_ m -> IM.insert i s m) acc name (IM.singleton i s)
-    args acc _ = acc
-
--- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two
--- maps with values for the same key merge the inner map as well.
--- Left biased so @unionArgMaps a b@ prefers @a@ over @b@.
-
-unionArgMaps :: forall b . UniqMap Name (IntMap b)
-             -> UniqMap Name (IntMap b)
-             -> UniqMap Name (IntMap b)
-unionArgMaps a b = nonDetFoldUniqMap go b a
-  where
-    go :: (Name, IntMap b)
-            -> UniqMap Name (IntMap b) -> UniqMap Name (IntMap b)
-    go (n, newArgMap) acc
-      | Just oldArgMap <- lookupUniqMap acc n =
-          addToUniqMap acc n (newArgMap `IM.union` oldArgMap)
-      | otherwise = addToUniqMap acc n newArgMap
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ /dev/null
@@ -1,885 +0,0 @@
-
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Desugaring expressions.
--}
-
-module GHC.HsToCore.Expr
-   ( dsExpr, dsLExpr, dsLocalBinds
-   , dsValBinds, dsLit, dsSyntaxExpr
-   )
-where
-
-import GHC.Prelude
-
-import GHC.HsToCore.Match
-import GHC.HsToCore.Match.Literal
-import GHC.HsToCore.Binds
-import GHC.HsToCore.GuardedRHSs
-import GHC.HsToCore.ListComp
-import GHC.HsToCore.Utils
-import GHC.HsToCore.Arrows
-import GHC.HsToCore.Monad
-import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )
-import GHC.HsToCore.Errors.Types
-import GHC.Types.SourceText
-import GHC.Types.Name
-import GHC.Core.FamInstEnv( topNormaliseType )
-import GHC.HsToCore.Quote
-import GHC.Hs
-
--- NB: The desugarer, which straddles the source and Core worlds, sometimes
---     needs to see source types
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Utils.Monad
-import GHC.Core.Type
-import GHC.Core.TyCo.Rep
-import GHC.Core
-import GHC.Core.Utils
-import GHC.Core.Make
-
-import GHC.Driver.Session
-import GHC.Types.CostCentre
-import GHC.Types.Id
-import GHC.Types.Id.Make
-import GHC.Unit.Module
-import GHC.Core.ConLike
-import GHC.Core.DataCon
-import GHC.Builtin.Types
-import GHC.Builtin.Names
-import GHC.Types.Basic
-import GHC.Types.SrcLoc
-import GHC.Types.Tickish
-import GHC.Utils.Misc
-import GHC.Data.Bag
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Core.PatSyn
-import Control.Monad
-import GHC.HsToCore.Ticks (stripTicksTopHsExpr)
-
-{-
-************************************************************************
-*                                                                      *
-                dsLocalBinds, dsValBinds
-*                                                                      *
-************************************************************************
--}
-
-dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsLocalBinds (EmptyLocalBinds _)  body = return body
-dsLocalBinds b@(HsValBinds _ binds) body = putSrcSpanDs (spanHsLocaLBinds b) $
-                                           dsValBinds binds body
-dsLocalBinds (HsIPBinds _ binds)  body = dsIPBinds  binds body
-
--------------------------
--- caller sets location
-dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsValBinds (XValBindsLR (NValBinds binds _)) body
-  = foldrM ds_val_bind body binds
-dsValBinds (ValBinds {})       _    = panic "dsValBinds ValBindsIn"
-
--------------------------
-dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
-dsIPBinds (IPBinds ev_binds ip_binds) body
-  = do  { ds_binds <- dsTcEvBinds ev_binds
-        ; let inner = mkCoreLets ds_binds body
-                -- The dict bindings may not be in
-                -- dependency order; hence Rec
-        ; foldrM ds_ip_bind inner ip_binds }
-  where
-    ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
-    ds_ip_bind (L _ (IPBind n _ e)) body
-      = do e' <- dsLExpr e
-           return (Let (NonRec n e') body)
-
--------------------------
--- caller sets location
-ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
--- Special case for bindings which bind unlifted variables
--- We need to do a case right away, rather than building
--- a tuple and doing selections.
--- Silently ignore INLINE and SPECIALISE pragmas...
-ds_val_bind (NonRecursive, hsbinds) body
-  | [L loc bind] <- bagToList hsbinds
-        -- Non-recursive, non-overloaded bindings only come in ones
-        -- ToDo: in some bizarre case it's conceivable that there
-        --       could be dict binds in the 'binds'.  (See the notes
-        --       below.  Then pattern-match would fail.  Urk.)
-  , isUnliftedHsBind bind
-  = putSrcSpanDs (locA loc) $
-     -- see Note [Strict binds checks] in GHC.HsToCore.Binds
-    if is_polymorphic bind
-    then errDsCoreExpr (DsCannotMixPolyAndUnliftedBindings bind)
-            -- data Ptr a = Ptr Addr#
-            -- f x = let p@(Ptr y) = ... in ...
-            -- Here the binding for 'p' is polymorphic, but does
-            -- not mix with an unlifted binding for 'y'.  You should
-            -- use a bang pattern.  #6078.
-
-    else do { when (looksLazyPatBind bind) $
-              diagnosticDs (DsUnbangedStrictPatterns bind)
-        -- Complain about a binding that looks lazy
-        --    e.g.    let I# y = x in ...
-        -- Remember, in checkStrictBinds we are going to do strict
-        -- matching, so (for software engineering reasons) we insist
-        -- that the strictness is manifest on each binding
-        -- However, lone (unboxed) variables are ok
-
-
-            ; dsUnliftedBind bind body }
-  where
-    is_polymorphic (XHsBindsLR (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
-                     = not (null tvs && null evs)
-    is_polymorphic _ = False
-
-
-ds_val_bind (is_rec, binds) _body
-  | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in GHC.HsToCore.Binds
-  = assert (isRec is_rec )
-    errDsCoreExpr $ DsRecBindsNotAllowedForUnliftedTys (bagToList binds)
-
--- Ordinary case for bindings; none should be unlifted
-ds_val_bind (is_rec, binds) body
-  = do  { massert (isRec is_rec || isSingletonBag binds)
-               -- we should never produce a non-recursive list of multiple binds
-
-        ; (force_vars,prs) <- dsLHsBinds binds
-        ; let body' = foldr seqVar body force_vars
-        ; assertPpr (not (any (isUnliftedType . idType . fst) prs)) (ppr is_rec $$ ppr binds) $
-          -- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType
-          case prs of
-            [] -> return body
-            _  -> return (Let (Rec prs) body') }
-        -- Use a Rec regardless of is_rec.
-        -- Why? Because it allows the binds to be all
-        -- mixed up, which is what happens in one rare case
-        -- Namely, for an AbsBind with no tyvars and no dicts,
-        --         but which does have dictionary bindings.
-        -- See notes with GHC.Tc.Solver.inferLoop [NO TYVARS]
-        -- It turned out that wrapping a Rec here was the easiest solution
-        --
-        -- NB The previous case dealt with unlifted bindings, so we
-        --    only have to deal with lifted ones now; so Rec is ok
-
-------------------
-dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
-dsUnliftedBind (XHsBindsLR (AbsBinds { abs_tvs = [], abs_ev_vars = []
-                                     , abs_exports = exports
-                                     , abs_ev_binds = ev_binds
-                                     , abs_binds = lbinds })) body
-  = do { let body1 = foldr bind_export body exports
-             bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
-       ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
-                            body1 lbinds
-       ; ds_binds <- dsTcEvBinds_s ev_binds
-       ; return (mkCoreLets ds_binds body2) }
-
-dsUnliftedBind (FunBind { fun_id = L l fun
-                        , fun_matches = matches
-                        , fun_ext = (co_fn, tick)
-                        }) body
-               -- Can't be a bang pattern (that looks like a PatBind)
-               -- so must be simply unboxed
-  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) Nothing matches
-       ; massert (null args) -- Functions aren't unlifted
-       ; core_wrap <- dsHsWrapper co_fn  -- Can be non-identity (#21516)
-       ; let rhs' = core_wrap (mkOptTickBox tick rhs)
-       ; return (bindNonRec fun rhs' body) }
-
-dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
-                        , pat_ext = (ty, _) }) body
-  =     -- let C x# y# = rhs in body
-        -- ==> case rhs of C x# y# -> body
-    do { match_nablas <- pmcGRHSs PatBindGuards grhss
-       ; rhs          <- dsGuarded grhss ty match_nablas
-       ; let upat = unLoc pat
-             eqn = EqnInfo { eqn_pats = [upat],
-                             eqn_orig = FromSource,
-                             eqn_rhs = cantFailMatchResult body }
-       ; var    <- selectMatchVar ManyTy upat
-                    -- `var` will end up in a let binder, so the multiplicity
-                    -- doesn't matter.
-       ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
-       ; return (bindNonRec var rhs result) }
-
-dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
-
-{-
-************************************************************************
-*                                                                      *
-*              Variables, constructors, literals                       *
-*                                                                      *
-************************************************************************
--}
-
-
--- | Replace the body of the function with this block to test the hsExprType
--- function in GHC.Tc.Utils.Zonk:
--- putSrcSpanDs loc $ do
---   { core_expr <- dsExpr e
---   ; massertPpr (exprType core_expr `eqType` hsExprType e)
---                (ppr e <+> dcolon <+> ppr (hsExprType e) $$
---                 ppr core_expr <+> dcolon <+> ppr (exprType core_expr))
---   ; return core_expr }
-dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
-dsLExpr (L loc e) =
-  putSrcSpanDsA loc $ dsExpr e
-
-dsExpr :: HsExpr GhcTc -> DsM CoreExpr
-dsExpr (HsVar    _ (L _ id))           = dsHsVar id
-dsExpr (HsRecSel _ (FieldOcc id _))    = dsHsVar id
-dsExpr (HsUnboundVar (HER ref _ _) _)  = dsEvTerm =<< readMutVar ref
-        -- See Note [Holes] in GHC.Tc.Types.Constraint
-
-dsExpr (HsPar _ _ e _)        = dsLExpr e
-dsExpr (ExprWithTySig _ e _)  = dsLExpr e
-
-dsExpr (HsIPVar x _)          = dataConCantHappen x
-
-dsExpr (HsGetField x _ _)     = dataConCantHappen x
-dsExpr (HsProjection x _)     = dataConCantHappen x
-
-dsExpr (HsLit _ lit)
-  = do { warnAboutOverflowedLit lit
-       ; dsLit (convertLit lit) }
-
-dsExpr (HsOverLit _ lit)
-  = do { warnAboutOverflowedOverLit lit
-       ; dsOverLit lit }
-
-dsExpr e@(XExpr ext_expr_tc)
-  = case ext_expr_tc of
-      ExpansionExpr (HsExpanded _ b) -> dsExpr b
-      WrapExpr {}                    -> dsHsWrapped e
-      ConLikeTc con tvs tys          -> dsConLike con tvs tys
-      -- Hpc Support
-      HsTick tickish e -> do
-        e' <- dsLExpr e
-        return (Tick tickish e')
-
-      -- There is a problem here. The then and else branches
-      -- have no free variables, so they are open to lifting.
-      -- We need someway of stopping this.
-      -- This will make no difference to binary coverage
-      -- (did you go here: YES or NO), but will effect accurate
-      -- tick counting.
-
-      HsBinTick ixT ixF e -> do
-        e2 <- dsLExpr e
-        do { assert (exprType e2 `eqType` boolTy)
-            mkBinaryTickBox ixT ixF e2
-          }
-
--- Strip ticks due to #21701, need to be invariant about warnings we produce whether
--- this is enabled or not.
-dsExpr (NegApp _ (L loc
-                    (stripTicksTopHsExpr -> (ts, (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))))
-              neg_expr)
-  = do { expr' <- putSrcSpanDsA loc $ do
-          { warnAboutOverflowedOverLit
-                -- See Note [Checking "negative literals"]
-              (lit { ol_val = HsIntegral (negateIntegralLit i) })
-          ; dsOverLit lit }
-       ;
-       ; dsSyntaxExpr neg_expr [mkTicks ts expr'] }
-
-dsExpr (NegApp _ expr neg_expr)
-  = do { expr' <- dsLExpr expr
-       ; dsSyntaxExpr neg_expr [expr'] }
-
-dsExpr (HsLam _ a_Match)
-  = uncurry mkCoreLams <$> matchWrapper LambdaExpr Nothing a_Match
-
-dsExpr (HsLamCase _ lc_variant matches)
-  = uncurry mkCoreLams <$> matchWrapper (LamCaseAlt lc_variant) Nothing matches
-
-dsExpr e@(HsApp _ fun arg)
-  = do { fun' <- dsLExpr fun
-       ; arg' <- dsLExpr arg
-       ; return $ mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg' }
-
-dsExpr e@(HsAppType {}) = dsHsWrapped e
-
-{-
-Note [Checking "negative literals"]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-As observed in #13257 it's desirable to warn about overflowing negative literals
-in some situations where the user thinks they are writing a negative literal (ie -1)
-but without `-XNegativeLiterals` enabled.
-
-This catches cases such as (-1 :: Word8) which overflow, because (negate 1 == 255) but
-which we desugar to `negate (fromIntegral 1)`.
-
-Notice it's crucial we still desugar to the correct (negate (fromIntegral ...)) despite
-performing the negation in order to check whether the application of negate will overflow.
-For a user written Integer instance we can't predict the interaction of negate and fromIntegral.
-
-Also note that this works for detecting the right result for `-128 :: Int8`.. which is
-in-range for Int8 but the correct result is achieved via two overflows.
-
-negate (fromIntegral 128 :: Int8)
-= negate (-128 :: Int8)
-= -128 :: Int8
-
-Note [Desugaring vars]
-~~~~~~~~~~~~~~~~~~~~~~
-In one situation we can get a *coercion* variable in a HsVar, namely
-the support method for an equality superclass:
-   class (a~b) => C a b where ...
-   instance (blah) => C (T a) (T b) where ..
-Then we get
-   $dfCT :: forall ab. blah => C (T a) (T b)
-   $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)
-
-   $c$p1C :: forall ab. blah => (T a ~ T b)
-   $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g
-
-That 'g' in the 'in' part is an evidence variable, and when
-converting to core it must become a CO.
--}
-
-dsExpr (ExplicitTuple _ tup_args boxity)
-  = do { let go (lam_vars, args) (Missing (Scaled mult ty))
-                    -- For every missing expression, we need
-                    -- another lambda in the desugaring.
-               = do { lam_var <- newSysLocalDs mult ty
-                    ; return (lam_var : lam_vars, Var lam_var : args) }
-             go (lam_vars, args) (Present _ expr)
-                    -- Expressions that are present don't generate
-                    -- lambdas, just arguments.
-               = do { core_expr <- dsLExpr expr
-                    ; return (lam_vars, core_expr : args) }
-
-       ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
-                -- The reverse is because foldM goes left-to-right
-       ; return $ mkCoreLams lam_vars (mkCoreTupBoxity boxity args) }
-                        -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
-
-dsExpr (ExplicitSum types alt arity expr)
-  = mkCoreUnboxedSum arity alt types <$> dsLExpr expr
-
-dsExpr (HsPragE _ prag expr) =
-  ds_prag_expr prag expr
-
-dsExpr (HsCase _ discrim matches)
-  = do { core_discrim <- dsLExpr discrim
-       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just [discrim]) matches
-       ; return (bindNonRec discrim_var core_discrim matching_code) }
-
--- Pepe: The binds are in scope in the body but NOT in the binding group
---       This is to avoid silliness in breakpoints
-dsExpr (HsLet _ _ binds _ body) = do
-    body' <- dsLExpr body
-    dsLocalBinds binds body'
-
--- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
--- because the interpretation of `stmts' depends on what sort of thing it is.
---
-dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
-dsExpr (HsDo _ ctx@DoExpr{}      (L _ stmts)) = dsDo ctx stmts
-dsExpr (HsDo _ ctx@GhciStmtCtxt  (L _ stmts)) = dsDo ctx stmts
-dsExpr (HsDo _ ctx@MDoExpr{}     (L _ stmts)) = dsDo ctx stmts
-dsExpr (HsDo _ MonadComp     (L _ stmts)) = dsMonadComp stmts
-
-dsExpr (HsIf _ guard_expr then_expr else_expr)
-  = do { pred <- dsLExpr guard_expr
-       ; b1 <- dsLExpr then_expr
-       ; b2 <- dsLExpr else_expr
-       ; return $ mkIfThenElse pred b1 b2 }
-
-dsExpr (HsMultiIf res_ty alts)
-  | null alts
-  = mkErrorExpr
-
-  | otherwise
-  = do { let grhss = GRHSs emptyComments  alts emptyLocalBinds
-       ; rhss_nablas  <- pmcGRHSs IfAlt grhss
-       ; match_result <- dsGRHSs IfAlt grhss res_ty rhss_nablas
-       ; error_expr   <- mkErrorExpr
-       ; extractMatchResult match_result error_expr }
-  where
-    mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
-                               (text "multi-way if")
-
-{-
-\noindent
-\underline{\bf Various data construction things}
-             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--}
-
-dsExpr (ExplicitList elt_ty xs) = dsExplicitList elt_ty xs
-
-dsExpr (ArithSeq expr witness seq)
-  = case witness of
-     Nothing -> dsArithSeq expr seq
-     Just fl -> do { newArithSeq <- dsArithSeq expr seq
-                   ; dsSyntaxExpr fl [newArithSeq] }
-
-{-
-Static Pointers
-~~~~~~~~~~~~~~~
-
-See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.
-
-    g = ... static f ...
-==>
-    g = ... makeStatic loc f ...
--}
-
-dsExpr (HsStatic (_, whole_ty) expr@(L loc _)) = do
-    expr_ds <- dsLExpr expr
-    let (_, [ty]) = splitTyConApp whole_ty
-    makeStaticId <- dsLookupGlobalId makeStaticName
-
-    dflags <- getDynFlags
-    let platform = targetPlatform dflags
-    let (line, col) = case locA loc of
-           RealSrcSpan r _ ->
-                            ( srcLocLine $ realSrcSpanStart r
-                            , srcLocCol  $ realSrcSpanStart r
-                            )
-           _             -> (0, 0)
-        srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
-                     [ Type intTy              , Type intTy
-                     , mkIntExprInt platform line, mkIntExprInt platform col
-                     ]
-
-    putSrcSpanDsA loc $ return $
-      mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]
-
-{-
-\noindent
-\underline{\bf Record construction and update}
-             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For record construction we do this (assuming T has three arguments)
-\begin{verbatim}
-        T { op2 = e }
-==>
-        let err = /\a -> recConError a
-        T (recConError t1 "M.hs/230/op1")
-          e
-          (recConError t1 "M.hs/230/op3")
-\end{verbatim}
-@recConError@ then converts its argument string into a proper message
-before printing it as
-\begin{verbatim}
-        M.hs, line 230: missing field op1 was evaluated
-\end{verbatim}
-
-We also handle @C{}@ as valid construction syntax for an unlabelled
-constructor @C@, setting all of @C@'s fields to bottom.
--}
-
-dsExpr (RecordCon { rcon_con  = L _ con_like
-                  , rcon_flds = rbinds
-                  , rcon_ext  = con_expr })
-  = do { con_expr' <- dsExpr con_expr
-       ; let
-             (arg_tys, _) = tcSplitFunTys (exprType con_expr')
-             -- A newtype in the corner should be opaque;
-             -- hence TcType.tcSplitFunTys
-
-             mk_arg (arg_ty, fl)
-               = case findField (rec_flds rbinds) (flSelector fl) of
-                   (rhs:rhss) -> assert (null rhss)
-                                 dsLExpr rhs
-                   []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
-             unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
-
-             labels = conLikeFieldLabels con_like
-
-       ; con_args <- if null labels
-                     then mapM unlabelled_bottom (map scaledThing arg_tys)
-                     else mapM mk_arg (zipEqual "dsExpr:RecordCon" (map scaledThing arg_tys) labels)
-
-       ; return (mkCoreApps con_expr' con_args) }
-
-dsExpr (RecordUpd x _ _) = dataConCantHappen x
-
--- Here is where we desugar the Template Haskell brackets and escapes
-
--- Template Haskell stuff
--- See Note [The life cycle of a TH quotation]
-
-dsExpr (HsTypedBracket   bracket_tc _) = dsBracket bracket_tc
-dsExpr (HsUntypedBracket bracket_tc _) = dsBracket bracket_tc
-dsExpr (HsTypedSplice   _   s) = pprPanic "dsExpr:typed splice" (pprTypedSplice Nothing s)
-dsExpr (HsUntypedSplice ext _) = dataConCantHappen ext
-
--- Arrow notation extension
-dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd
-
-
--- HsSyn constructs that just shouldn't be here, because
--- the renamer removed them.  See GHC.Rename.Expr.
--- Note [Handling overloaded and rebindable constructs]
-dsExpr (HsOverLabel x _) = dataConCantHappen x
-dsExpr (OpApp x _ _ _)   = dataConCantHappen x
-dsExpr (SectionL x _ _)  = dataConCantHappen x
-dsExpr (SectionR x _ _)  = dataConCantHappen x
-
-ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
-ds_prag_expr (HsPragSCC _ cc) expr = do
-    dflags <- getDynFlags
-    if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags
-      then do
-        mod_name <- getModule
-        count <- goptM Opt_ProfCountEntries
-        let nm = sl_fs cc
-        flavour <- ExprCC <$> getCCIndexDsM nm
-        Tick (ProfNote (mkUserCC nm mod_name (getLocA expr) flavour) count True)
-               <$> dsLExpr expr
-      else dsLExpr expr
-
-------------------------------
-dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
-dsSyntaxExpr (SyntaxExprTc { syn_expr      = expr
-                           , syn_arg_wraps = arg_wraps
-                           , syn_res_wrap  = res_wrap })
-             arg_exprs
-  = do { fun            <- dsExpr expr
-       ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
-       ; core_res_wrap  <- dsHsWrapper res_wrap
-       ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs
-       ; return $ core_res_wrap (mkCoreApps fun wrapped_args) }
-dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr"
-
-findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
-findField rbinds sel
-  = [hfbRHS fld | L _ fld <- rbinds
-                       , sel == idName (hsRecFieldId fld) ]
-
-{-
-%--------------------------------------------------------------------
-
-Note [Desugaring explicit lists]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Explicit lists are desugared in a cleverer way to prevent some
-fruitless allocations.  Essentially, whenever we see a list literal
-[x_1, ..., x_n] we generate the corresponding expression in terms of
-build:
-
-Explicit lists (literals) are desugared to allow build/foldr fusion when
-beneficial. This is a bit of a trade-off,
-
- * build/foldr fusion can generate far larger code than the corresponding
-   cons-chain (e.g. see #11707)
-
- * even when it doesn't produce more code, build can still fail to fuse,
-   requiring that the simplifier do more work to bring the expression
-   back into cons-chain form; this costs compile time
-
- * when it works, fusion can be a significant win. Allocations are reduced
-   by up to 25% in some nofib programs. Specifically,
-
-        Program           Size    Allocs   Runtime  CompTime
-        rewrite          +0.0%    -26.3%      0.02     -1.8%
-           ansi          -0.3%    -13.8%      0.00     +0.0%
-           lift          +0.0%     -8.7%      0.00     -2.3%
-
-At the moment we use a simple heuristic to determine whether build will be
-fruitful: for small lists we assume the benefits of fusion will be worthwhile;
-for long lists we assume that the benefits will be outweighed by the cost of
-code duplication. This magic length threshold is @maxBuildLength@. Also, fusion
-won't work at all if rewrite rules are disabled, so we don't use the build-based
-desugaring in this case.
-
-We used to have a more complex heuristic which would try to break the list into
-"static" and "dynamic" parts and only build-desugar the dynamic part.
-Unfortunately, determining "static-ness" reliably is a bit tricky and the
-heuristic at times produced surprising behavior (see #11710) so it was dropped.
--}
-
-{- | The longest list length which we will desugar using @build@.
-
-This is essentially a magic number and its setting is unfortunate rather
-arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists],
-is to avoid deforesting large static data into large(r) code. Ideally we'd
-want a smaller threshold with larger consumers and vice-versa, but we have no
-way of knowing what will be consuming our list in the desugaring impossible to
-set generally correctly.
-
-The effect of reducing this number will be that 'build' fusion is applied
-less often. From a runtime performance perspective, applying 'build' more
-liberally on "moderately" sized lists should rarely hurt and will often it can
-only expose further optimization opportunities; if no fusion is possible it will
-eventually get rule-rewritten back to a list). We do, however, pay in compile
-time.
--}
-maxBuildLength :: Int
-maxBuildLength = 32
-
-dsExplicitList :: Type -> [LHsExpr GhcTc]
-               -> DsM CoreExpr
--- See Note [Desugaring explicit lists]
-dsExplicitList elt_ty xs
-  = do { dflags <- getDynFlags
-       ; xs' <- mapM dsLExpr xs
-       ; if xs' `lengthExceeds` maxBuildLength
-                -- Don't generate builds if the list is very long.
-         || null xs'
-                -- Don't generate builds when the [] constructor will do
-         || not (gopt Opt_EnableRewriteRules dflags)  -- Rewrite rules off
-                -- Don't generate a build if there are no rules to eliminate it!
-                -- See Note [Desugaring RULE left hand sides] in GHC.HsToCore
-         then return $ mkListExpr elt_ty xs'
-         else mkBuildExpr elt_ty (mk_build_list xs') }
-  where
-    mk_build_list xs' (cons, _) (nil, _)
-      = return (foldr (App . App (Var cons)) (Var nil) xs')
-
-dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr
-dsArithSeq expr (From from)
-  = App <$> dsExpr expr <*> dsLExpr from
-dsArithSeq expr (FromTo from to)
-  = do fam_envs <- dsGetFamInstEnvs
-       dflags <- getDynFlags
-       warnAboutEmptyEnumerations fam_envs dflags from Nothing to
-       expr' <- dsExpr expr
-       from' <- dsLExpr from
-       to'   <- dsLExpr to
-       return $ mkApps expr' [from', to']
-dsArithSeq expr (FromThen from thn)
-  = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
-dsArithSeq expr (FromThenTo from thn to)
-  = do fam_envs <- dsGetFamInstEnvs
-       dflags <- getDynFlags
-       warnAboutEmptyEnumerations fam_envs dflags from (Just thn) to
-       expr' <- dsExpr expr
-       from' <- dsLExpr from
-       thn'  <- dsLExpr thn
-       to'   <- dsLExpr to
-       return $ mkApps expr' [from', thn', to']
-
-{-
-Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
-handled in GHC.HsToCore.ListComp).  Basically does the translation given in the
-Haskell 98 report:
--}
-
-dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
-dsDo ctx stmts
-  = goL stmts
-  where
-    goL [] = panic "dsDo"
-    goL ((L loc stmt):lstmts) = putSrcSpanDsA loc (go loc stmt lstmts)
-
-    go _ (LastStmt _ body _ _) stmts
-      = assert (null stmts ) dsLExpr body
-        -- The 'return' op isn't used for 'do' expressions
-
-    go _ (BodyStmt _ rhs then_expr _) stmts
-      = do { rhs2 <- dsLExpr rhs
-           ; warnDiscardedDoBindings rhs (exprType rhs2)
-           ; rest <- goL stmts
-           ; dsSyntaxExpr then_expr [rhs2, rest] }
-
-    go _ (LetStmt _ binds) stmts
-      = do { rest <- goL stmts
-           ; dsLocalBinds binds rest }
-
-    go _ (BindStmt xbs pat rhs) stmts
-      = do  { body     <- goL stmts
-            ; rhs'     <- dsLExpr rhs
-            ; var   <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat
-            ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
-                         (xbstc_boundResultType xbs) (cantFailMatchResult body)
-            ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs)
-            ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }
-
-    go _ (ApplicativeStmt body_ty args mb_join) stmts
-      = do {
-             let
-               (pats, rhss) = unzip (map (do_arg . snd) args)
-
-               do_arg (ApplicativeArgOne fail_op pat expr _) =
-                 ((pat, fail_op), dsLExpr expr)
-               do_arg (ApplicativeArgMany _ stmts ret pat _) =
-                 ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt (noLocA ret)]))
-
-           ; rhss' <- sequence rhss
-
-           ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts)
-
-           ; let match_args (pat, fail_op) (vs,body)
-                   = do { var   <- selectSimpleMatchVarL ManyTy pat
-                        ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
-                                   body_ty (cantFailMatchResult body)
-                        ; match_code <- dsHandleMonadicFailure ctx pat match fail_op
-                        ; return (var:vs, match_code)
-                        }
-
-           ; (vars, body) <- foldrM match_args ([],body') pats
-           ; let fun' = mkLams vars body
-           ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
-           ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
-           ; case mb_join of
-               Nothing -> return expr
-               Just join_op -> dsSyntaxExpr join_op [expr] }
-
-    go loc (RecStmt { recS_stmts = L _ rec_stmts, recS_later_ids = later_ids
-                    , recS_rec_ids = rec_ids, recS_ret_fn = return_op
-                    , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
-                    , recS_ext = RecStmtTc
-                        { recS_bind_ty = bind_ty
-                        , recS_rec_rets = rec_rets
-                        , recS_ret_ty = body_ty} }) stmts
-      = goL (new_bind_stmt : stmts)  -- rec_ids can be empty; eg  rec { print 'x' }
-      where
-        new_bind_stmt = L loc $ BindStmt
-          XBindStmtTc
-            { xbstc_bindOp          = bind_op
-            , xbstc_boundResultType = bind_ty
-            , xbstc_boundResultMult = ManyTy
-            , xbstc_failOp          = Nothing -- Tuple cannot fail
-            }
-          (mkBigLHsPatTupId later_pats)
-          mfix_app
-
-        tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
-        tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
-        rec_tup_pats = map nlVarPat tup_ids
-        later_pats   = rec_tup_pats
-        rets         = map noLocA rec_rets
-        mfix_app     = nlHsSyntaxApps mfix_op [mfix_arg]
-        mfix_arg     = noLocA $ HsLam noExtField
-                           (MG { mg_alts = noLocA [mkSimpleMatch
-                                                    LambdaExpr
-                                                    [mfix_pat] body]
-                               , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty Generated
-                               })
-        mfix_pat     = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats
-        body         = noLocA $ HsDo body_ty
-                                ctx (noLocA (rec_stmts ++ [ret_stmt]))
-        ret_app      = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
-        ret_stmt     = noLocA $ mkLastStmt ret_app
-                     -- This LastStmt will be desugared with dsDo,
-                     -- which ignores the return_op in the LastStmt,
-                     -- so we must apply the return_op explicitly
-
-    go _ (ParStmt   {}) _ = panic "dsDo ParStmt"
-    go _ (TransStmt {}) _ = panic "dsDo TransStmt"
-
-{-
-************************************************************************
-*                                                                      *
-   Desugaring Variables
-*                                                                      *
-************************************************************************
--}
-
-dsHsVar :: Id -> DsM CoreExpr
--- We could just call dsHsUnwrapped; but this is a short-cut
--- for the very common case of a variable with no wrapper.
-dsHsVar var
-  = return (varToCoreExpr var) -- See Note [Desugaring vars]
-
-dsHsConLike :: ConLike -> DsM CoreExpr
-dsHsConLike (RealDataCon dc)
-  = return (varToCoreExpr (dataConWrapId dc))
-dsHsConLike (PatSynCon ps)
-  | Just (builder_name, _, add_void) <- patSynBuilder ps
-  = do { builder_id <- dsLookupGlobalId builder_name
-       ; return (if add_void
-                 then mkCoreApp (text "dsConLike" <+> ppr ps)
-                                (Var builder_id) unboxedUnitExpr
-                 else Var builder_id) }
-  | otherwise
-  = pprPanic "dsConLike" (ppr ps)
-
--- | This function desugars 'ConLikeTc': it eta-expands
--- data constructors to make linear types work.
---
--- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head
-dsConLike :: ConLike -> [TcTyVar] -> [Scaled Type] -> DsM CoreExpr
-dsConLike con tvs tys
-  = do { ds_con <- dsHsConLike con
-       ; ids    <- newSysLocalsDs tys
-           -- NB: these 'Id's may be representation-polymorphic;
-           -- see Wrinkle [Representation-polymorphic lambda] in
-           -- Note [Typechecking data constructors] in GHC.Tc.Gen.Head.
-       ; return (mkLams tvs $
-                 mkLams ids $
-                 ds_con `mkTyApps` mkTyVarTys tvs
-                        `mkVarApps` ids) }
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Errors and contexts}
-*                                                                      *
-************************************************************************
--}
-
--- Warn about certain types of values discarded in monadic bindings (#3263)
-warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
-warnDiscardedDoBindings rhs rhs_ty
-  | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
-  = do { warn_unused <- woptM Opt_WarnUnusedDoBind
-       ; warn_wrong <- woptM Opt_WarnWrongDoBind
-       ; when (warn_unused || warn_wrong) $
-    do { fam_inst_envs <- dsGetFamInstEnvs
-       ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
-
-           -- Warn about discarding non-() things in 'monadic' binding
-       ; if warn_unused && not (isUnitTy norm_elt_ty)
-         then diagnosticDs (DsUnusedDoBind rhs elt_ty)
-         else
-
-           -- Warn about discarding m a things in 'monadic' binding of the same type,
-           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
-           when warn_wrong $
-                case tcSplitAppTy_maybe norm_elt_ty of
-                      Just (elt_m_ty, _)
-                         | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
-                         -> diagnosticDs (DsWrongDoBind rhs elt_ty)
-                      _ -> return () } }
-
-  | otherwise   -- RHS does have type of form (m ty), which is weird
-  = return ()   -- but at least this warning is irrelevant
-
-{-
-************************************************************************
-*                                                                      *
-            dsHsWrapped
-*                                                                      *
-************************************************************************
--}
-
-------------------------------
-dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr
-dsHsWrapped orig_hs_expr
-  = go idHsWrapper orig_hs_expr
-  where
-    go wrap (HsPar _ _ (L _ hs_e) _)
-       = go wrap hs_e
-    go wrap1 (XExpr (WrapExpr (HsWrap wrap2 hs_e)))
-       = go (wrap1 <.> wrap2) hs_e
-    go wrap (HsAppType ty (L _ hs_e) _ _)
-       = go (wrap <.> WpTyApp ty) hs_e
-
-    go wrap (HsVar _ (L _ var))
-      = do { wrap' <- dsHsWrapper wrap
-           ; let expr = wrap' (varToCoreExpr var)
-                 ty   = exprType expr
-           ; dflags <- getDynFlags
-           ; warnAboutIdentities dflags var ty
-           ; return expr }
-
-    go wrap hs_e
-       = do { wrap' <- dsHsWrapper wrap
-            ; addTyCs FromSource (hsWrapDictBinders wrap) $
-              do { e <- dsExpr hs_e
-                 ; return (wrap' e) } }
diff --git a/compiler/GHC/HsToCore/Expr.hs-boot b/compiler/GHC/HsToCore/Expr.hs-boot
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Expr.hs-boot
+++ /dev/null
@@ -1,10 +0,0 @@
-module GHC.HsToCore.Expr where
-import GHC.Hs             ( HsExpr, LHsExpr, HsLocalBinds, SyntaxExpr )
-import GHC.HsToCore.Monad ( DsM )
-import GHC.Core           ( CoreExpr )
-import GHC.Hs.Extension ( GhcTc)
-
-dsExpr  :: HsExpr GhcTc -> DsM CoreExpr
-dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
-dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
-dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
diff --git a/compiler/GHC/HsToCore/Foreign/C.hs b/compiler/GHC/HsToCore/Foreign/C.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Foreign/C.hs
+++ /dev/null
@@ -1,632 +0,0 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
--- | Handling of C foreign imports/exports
-module GHC.HsToCore.Foreign.C
-  ( dsCImport
-  , dsCFExport
-  , dsCFExportDynamic
-  )
-where
-
-import GHC.Prelude
-
-import GHC.Platform
-
-import GHC.Tc.Utils.Monad        -- temp
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.TcType
-
-import GHC.Core
-import GHC.Core.Unfold.Make
-import GHC.Core.Type
-import GHC.Core.TyCon
-import GHC.Core.Coercion
-import GHC.Core.Multiplicity
-
-import GHC.HsToCore.Foreign.Call
-import GHC.HsToCore.Foreign.Prim
-import GHC.HsToCore.Foreign.Utils
-import GHC.HsToCore.Monad
-import GHC.HsToCore.Types (ds_next_wrapper_num)
-
-import GHC.Hs
-
-import GHC.Types.Id
-import GHC.Types.Literal
-import GHC.Types.ForeignStubs
-import GHC.Types.SourceText
-import GHC.Types.Name
-import GHC.Types.RepType
-import GHC.Types.ForeignCall
-import GHC.Types.Basic
-
-import GHC.Unit.Module
-
-import GHC.Driver.Session
-import GHC.Driver.Config
-
-import GHC.Cmm.Expr
-import GHC.Cmm.Utils
-
-import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim
-import GHC.Builtin.Names
-
-import GHC.Data.FastString
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Encoding
-
-import Data.Maybe
-import Data.List (nub)
-
-dsCFExport:: Id                 -- Either the exported Id,
-                                -- or the foreign-export-dynamic constructor
-          -> Coercion           -- Coercion between the Haskell type callable
-                                -- from C, and its representation type
-          -> CLabelString       -- The name to export to C land
-          -> CCallConv
-          -> Bool               -- True => foreign export dynamic
-                                --         so invoke IO action that's hanging off
-                                --         the first argument's stable pointer
-          -> DsM ( CHeader      -- contents of Module_stub.h
-                 , CStub        -- contents of Module_stub.c
-                 , String       -- string describing type to pass to createAdj.
-                 , Int          -- size of args to stub function
-                 )
-
-dsCFExport fn_id co ext_name cconv isDyn = do
-    let
-       ty                     = coercionRKind co
-       (bndrs, orig_res_ty)   = tcSplitPiTys ty
-       fe_arg_tys'            = mapMaybe anonPiTyBinderType_maybe bndrs
-       -- We must use tcSplits here, because we want to see
-       -- the (IO t) in the corner of the type!
-       fe_arg_tys | isDyn     = tail fe_arg_tys'
-                  | otherwise = fe_arg_tys'
-
-       -- Look at the result type of the exported function, orig_res_ty
-       -- If it's IO t, return         (t, True)
-       -- If it's plain t, return      (t, False)
-       (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
-                                -- The function already returns IO t
-                                Just (_ioTyCon, res_ty) -> (res_ty, True)
-                                -- The function returns t
-                                Nothing                 -> (orig_res_ty, False)
-
-    dflags <- getDynFlags
-    return $
-      mkFExportCBits dflags ext_name
-                     (if isDyn then Nothing else Just fn_id)
-                     fe_arg_tys res_ty is_IO_res_ty cconv
-
-dsCImport :: Id
-          -> Coercion
-          -> CImportSpec
-          -> CCallConv
-          -> Safety
-          -> Maybe Header
-          -> DsM ([Binding], CHeader, CStub)
-dsCImport id co (CLabel cid) cconv _ _ = do
-   dflags <- getDynFlags
-   let ty  = coercionLKind co
-       platform = targetPlatform dflags
-       fod = case tyConAppTyCon_maybe (dropForAlls ty) of
-             Just tycon
-              | tyConUnique tycon == funPtrTyConKey ->
-                 IsFunction
-             _ -> IsData
-   (resTy, foRhs) <- resultWrapper ty
-   assert (fromJust resTy `eqType` addrPrimTy) $    -- typechecker ensures this
-    let
-        rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
-        rhs' = Cast rhs co
-        stdcall_info = fun_type_arg_stdcall_info platform cconv ty
-    in
-    return ([(id, rhs')], mempty, mempty)
-
-dsCImport id co (CFunction target) cconv@PrimCallConv safety _
-  = dsPrimCall id co (CCall (CCallSpec target cconv safety))
-dsCImport id co (CFunction target) cconv safety mHeader
-  = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
-dsCImport id co CWrapper cconv _ _
-  = dsCFExportDynamic id co cconv
-
-
-{-
-@foreign import "wrapper"@ (previously "foreign export dynamic") lets
-you dress up Haskell IO actions of some fixed type behind an
-externally callable interface (i.e., as a C function pointer). Useful
-for callbacks and stuff.
-
-\begin{verbatim}
-type Fun = Bool -> Int -> IO Int
-foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
-
--- Haskell-visible constructor, which is generated from the above:
--- SUP: No check for NULL from createAdjustor anymore???
-
-f :: Fun -> IO (FunPtr Fun)
-f cback =
-   bindIO (newStablePtr cback)
-          (\StablePtr sp# -> IO (\s1# ->
-              case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
-                 (# s2#, a# #) -> (# s2#, A# a# #)))
-
-foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
-
--- and the helper in C: (approximately; see `mkFExportCBits` below)
-
-f_helper(StablePtr s, HsBool b, HsInt i)
-{
-        Capability *cap;
-        cap = rts_lock();
-        rts_inCall(&cap,
-                   rts_apply(rts_apply(deRefStablePtr(s),
-                                       rts_mkBool(b)), rts_mkInt(i)));
-        rts_unlock(cap);
-}
-\end{verbatim}
--}
-dsCFExportDynamic :: Id
-                 -> Coercion
-                 -> CCallConv
-                 -> DsM ([Binding], CHeader, CStub)
-dsCFExportDynamic id co0 cconv = do
-    mod <- getModule
-    dflags <- getDynFlags
-    let platform = targetPlatform dflags
-    let fe_nm = mkFastString $ zEncodeString
-            (moduleStableString mod ++ "$" ++ toCName id)
-        -- Construct the label based on the passed id, don't use names
-        -- depending on Unique. See #13807 and Note [Unique Determinism].
-    cback <- newSysLocalDs arg_mult arg_ty
-    newStablePtrId <- dsLookupGlobalId newStablePtrName
-    stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
-    let
-        stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
-        export_ty     = mkVisFunTyMany stable_ptr_ty arg_ty
-    bindIOId <- dsLookupGlobalId bindIOName
-    stbl_value <- newSysLocalDs ManyTy stable_ptr_ty
-    (h_code, c_code, typestring, args_size) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv True
-    let
-         {-
-          The arguments to the external function which will
-          create a little bit of (template) code on the fly
-          for allowing the (stable pointed) Haskell closure
-          to be entered using an external calling convention
-          (stdcall, ccall).
-         -}
-        adj_args      = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv))
-                        , Var stbl_value
-                        , Lit (LitLabel fe_nm mb_sz_args IsFunction)
-                        , Lit (mkLitString typestring)
-                        ]
-          -- name of external entry point providing these services.
-          -- (probably in the RTS.)
-        adjustor   = fsLit "createAdjustor"
-
-          -- Determine the number of bytes of arguments to the stub function,
-          -- so that we can attach the '@N' suffix to its label if it is a
-          -- stdcall on Windows.
-        mb_sz_args = case cconv of
-                        StdCallConv -> Just args_size
-                        _           -> Nothing
-
-    ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
-        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
-
-    let io_app = mkLams tvs                  $
-                 Lam cback                   $
-                 mkApps (Var bindIOId)
-                        [ Type stable_ptr_ty
-                        , Type res_ty
-                        , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
-                        , Lam stbl_value ccall_adj
-                        ]
-
-        fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
-               -- Never inline the f.e.d. function, because the litlit
-               -- might not be in scope in other modules.
-
-    return ([fed], h_code, c_code)
-
- where
-  ty                       = coercionLKind co0
-  (tvs,sans_foralls)       = tcSplitForAllInvisTyVars ty
-  ([Scaled arg_mult arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
-  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty
-        -- Must have an IO type; hence Just
-
-
--- | Foreign calls
-dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
-        -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
-dsFCall fn_id co fcall mDeclHeader = do
-    let
-        (ty,ty1)             = (coercionLKind co, coercionRKind co)
-        (tv_bndrs, rho)      = tcSplitForAllTyVarBinders ty
-        (arg_tys, io_res_ty) = tcSplitFunTys rho
-
-    let constQual -- provide 'const' qualifier (#22034)
-          | (_, res_ty1) <- tcSplitFunTys ty1
-          , newty <- maybe res_ty1 snd (tcSplitIOType_maybe res_ty1)
-          , Just (ptr, _) <- splitTyConApp_maybe newty
-          , tyConName ptr `elem` [constPtrConName]
-          = text "const"
-          | otherwise = empty
-
-    args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism
-    (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
-
-    let
-        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
-
-    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
-
-    ccall_uniq <- newUnique
-    work_uniq  <- newUnique
-
-    (fcall', cDoc) <-
-              case fcall of
-              CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)
-                               CApiConv safety) ->
-               do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv
-                  wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName)
-                  let fcall' = CCall (CCallSpec
-                                      (StaticTarget NoSourceText
-                                                    wrapperName mUnitId
-                                                    True)
-                                      CApiConv safety)
-                      c = includes
-                       $$ fun_proto <+> braces (cRet <> semi)
-                      includes = vcat [ text "#include \"" <> ftext h
-                                        <> text "\""
-                                      | Header _ h <- nub headers ]
-                      fun_proto = constQual <+> cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
-                      cRet
-                       | isVoidRes =                   cCall
-                       | otherwise = text "return" <+> cCall
-                      cCall
-                        | isFun = ppr cName <> parens argVals
-                        | null arg_tys = ppr cName
-                        | otherwise = panic "dsFCall: Unexpected arguments to FFI value import"
-                      raw_res_ty = case tcSplitIOType_maybe io_res_ty of
-                                   Just (_ioTyCon, res_ty) -> res_ty
-                                   Nothing                 -> io_res_ty
-                      isVoidRes = raw_res_ty `eqType` unitTy
-                      (mHeader, cResType)
-                       | isVoidRes = (Nothing, text "void")
-                       | otherwise = toCType raw_res_ty
-                      pprCconv = ccallConvAttribute CApiConv
-                      mHeadersArgTypeList
-                          = [ (header, cType <+> char 'a' <> int n)
-                            | (t, n) <- zip arg_tys [1..]
-                            , let (header, cType) = toCType (scaledThing t) ]
-                      (mHeaders, argTypeList) = unzip mHeadersArgTypeList
-                      argTypes = if null argTypeList
-                                 then text "void"
-                                 else hsep $ punctuate comma argTypeList
-                      mHeaders' = mDeclHeader : mHeader : mHeaders
-                      headers = catMaybes mHeaders'
-                      argVals = hsep $ punctuate comma
-                                    [ char 'a' <> int n
-                                    | (_, n) <- zip arg_tys [1..] ]
-                  return (fcall', c)
-              _ ->
-                  return (fcall, empty)
-    dflags <- getDynFlags
-    let
-        -- Build the worker
-        worker_ty     = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty)
-        tvs           = map binderVar tv_bndrs
-        the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty
-        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
-        work_id       = mkSysLocal (fsLit "$wccall") work_uniq ManyTy worker_ty
-
-        -- Build the wrapper
-        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
-        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
-        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
-        wrap_rhs'    = Cast wrap_rhs co
-        simpl_opts   = initSimpleOpts dflags
-        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts
-                                                StableSystemSrc (length args)
-                                                wrap_rhs'
-
-    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc [] [])
-
-
-toCName :: Id -> String
-toCName i = showSDocOneLine defaultSDocContext (pprCode (ppr (idName i)))
-
-toCType :: Type -> (Maybe Header, SDoc)
-toCType = f False
-    where f voidOK t
-           -- First, if we have (Ptr t) of (FunPtr t), then we need to
-           -- convert t to a C type and put a * after it. If we don't
-           -- know a type for t, then "void" is fine, though.
-           | Just (ptr, [t']) <- splitTyConApp_maybe t
-           , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
-              = case f True t' of
-                (mh, cType') ->
-                    (mh, cType' <> char '*')
-           -- Otherwise, if we have a type constructor application, then
-           -- see if there is a C type associated with that constructor.
-           -- Note that we aren't looking through type synonyms or
-           -- anything, as it may be the synonym that is annotated.
-           | Just tycon <- tyConAppTyConPicky_maybe t
-           , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
-              = (mHeader, ftext cType)
-           -- If we don't know a C type for this type, then try looking
-           -- through one layer of type synonym etc.
-           | Just t' <- coreView t
-              = f voidOK t'
-          -- Handle 'UnliftedFFITypes' argument
-           | Just tyCon <- tyConAppTyConPicky_maybe t
-           , isPrimTyCon tyCon
-           , Just cType <- ppPrimTyConStgType tyCon
-           = (Nothing, text cType)
-
-           -- Otherwise we don't know the C type. If we are allowing
-           -- void then return that; otherwise something has gone wrong.
-           | voidOK = (Nothing, text "void")
-           | otherwise
-              = pprPanic "toCType" (ppr t)
-
-{-
-*
-
-\subsection{Generating @foreign export@ stubs}
-
-*
-
-For each @foreign export@ function, a C stub function is generated.
-The C stub constructs the application of the exported Haskell function
-using the hugs/ghc rts invocation API.
--}
-
-mkFExportCBits :: DynFlags
-               -> FastString
-               -> Maybe Id      -- Just==static, Nothing==dynamic
-               -> [Type]
-               -> Type
-               -> Bool          -- True <=> returns an IO type
-               -> CCallConv
-               -> (CHeader,
-                   CStub,
-                   String,      -- the argument reps
-                   Int          -- total size of arguments
-                  )
-mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
- = ( header_bits
-   , CStub body [] []
-   , type_string,
-    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
-         -- NB. the calculation here isn't strictly speaking correct.
-         -- We have a primitive Haskell type (eg. Int#, Double#), and
-         -- we want to know the size, when passed on the C stack, of
-         -- the associated C type (eg. HsInt, HsDouble).  We don't have
-         -- this information to hand, but we know what GHC's conventions
-         -- are for passing around the primitive Haskell types, so we
-         -- use that instead.  I hope the two coincide --SDM
-    )
- where
-  platform = targetPlatform dflags
-
-  -- list the arguments to the C function
-  arg_info :: [(SDoc,           -- arg name
-                SDoc,           -- C type
-                Type,           -- Haskell type
-                CmmType)]       -- the CmmType
-  arg_info  = [ let stg_type = showStgType ty in
-                (arg_cname n stg_type,
-                 stg_type,
-                 ty,
-                typeCmmType platform (getPrimTyOf ty))
-              | (ty,n) <- zip arg_htys [1::Int ..] ]
-
-  arg_cname n stg_ty
-        | libffi    = char '*' <> parens (stg_ty <> char '*') <>
-                      text "args" <> brackets (int (n-1))
-        | otherwise = char 'a' <> int n
-
-  -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
-  libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target
-
-  type_string
-      -- libffi needs to know the result type too:
-      | libffi    = primTyDescChar platform res_hty : arg_type_string
-      | otherwise = arg_type_string
-
-  arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info]
-                -- just the real args
-
-  -- add some auxiliary args; the stable ptr in the wrapper case, and
-  -- a slot for the dummy return address in the wrapper + ccall case
-  aug_arg_info
-    | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info
-    | otherwise              = arg_info
-
-  stable_ptr_arg =
-        (text "the_stableptr", text "StgStablePtr", undefined,
-         typeCmmType platform (mkStablePtrPrimTy alphaTy))
-
-  -- stuff to do with the return type of the C function
-  res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
-
-  cResType | res_hty_is_unit = text "void"
-           | otherwise       = showStgType res_hty
-
-  -- when the return type is integral and word-sized or smaller, it
-  -- must be assigned as type ffi_arg (#3516).  To see what type
-  -- libffi is expecting here, take a look in its own testsuite, e.g.
-  -- libffi/testsuite/libffi.call/cls_align_ulonglong.c
-  ffi_cResType
-     | is_ffi_arg_type = text "ffi_arg"
-     | otherwise       = cResType
-     where
-       res_ty_key = getUnique (getName (typeTyCon res_hty))
-       is_ffi_arg_type = res_ty_key `notElem`
-              [floatTyConKey, doubleTyConKey,
-               int64TyConKey, word64TyConKey]
-
-  -- Now we can cook up the prototype for the exported function.
-  pprCconv = ccallConvAttribute cc
-
-  header_bits = CHeader (text "extern" <+> fun_proto <> semi)
-
-  fun_args
-    | null aug_arg_info = text "void"
-    | otherwise         = hsep $ punctuate comma
-                               $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
-
-  fun_proto
-    | libffi
-      = text "void" <+> ftext c_nm <>
-          parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
-    | otherwise
-      = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
-
-  -- the target which will form the root of what we ask rts_inCall to run
-  the_cfun
-     = case maybe_target of
-          Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
-          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
-
-  cap = text "cap" <> comma
-
-  -- the expression we give to rts_inCall
-  expr_to_run
-     = foldl' appArg the_cfun arg_info -- NOT aug_arg_info
-       where
-          appArg acc (arg_cname, _, arg_hty, _)
-             = text "rts_apply"
-               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
-
-  -- various other bits for inside the fn
-  declareResult = text "HaskellObj ret;"
-  declareCResult | res_hty_is_unit = empty
-                 | otherwise       = cResType <+> text "cret;"
-
-  assignCResult | res_hty_is_unit = empty
-                | otherwise       =
-                        text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
-
-  -- an extern decl for the fn being called
-  extern_decl
-     = case maybe_target of
-          Nothing -> empty
-          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
-
-
-  -- finally, the whole darn thing
-  body =
-    space $$
-    extern_decl $$
-    fun_proto  $$
-    vcat
-     [ lbrace
-     ,   text "Capability *cap;"
-     ,   declareResult
-     ,   declareCResult
-     ,   text "cap = rts_lock();"
-          -- create the application + perform it.
-     ,   text "rts_inCall" <> parens (
-                char '&' <> cap <>
-                text "rts_apply" <> parens (
-                    cap <>
-                    text "(HaskellObj)"
-                 <> (if is_IO_res_ty
-                      then text "runIO_closure"
-                      else text "runNonIO_closure")
-                 <> comma
-                 <> expr_to_run
-                ) <+> comma
-               <> text "&ret"
-             ) <> semi
-     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
-                                                <> comma <> text "cap") <> semi
-     ,   assignCResult
-     ,   text "rts_unlock(cap);"
-     ,   ppUnless res_hty_is_unit $
-         if libffi
-                  then char '*' <> parens (ffi_cResType <> char '*') <>
-                       text "resp = cret;"
-                  else text "return cret;"
-     , rbrace
-     ]
-
-mkHObj :: Type -> SDoc
-mkHObj t = text "rts_mk" <> showFFIType t
-
-unpackHObj :: Type -> SDoc
-unpackHObj t = text "rts_get" <> showFFIType t
-
-showStgType :: Type -> SDoc
-showStgType t = text "Hs" <> showFFIType t
-
-showFFIType :: Type -> SDoc
-showFFIType t = ftext (occNameFS (getOccName (typeTyCon t)))
-
-typeTyCon :: Type -> TyCon
-typeTyCon ty
-  | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)
-  = tc
-  | otherwise
-  = pprPanic "GHC.HsToCore.Foreign.C.typeTyCon" (ppr ty)
-
-
-insertRetAddr :: Platform -> CCallConv
-              -> [(SDoc, SDoc, Type, CmmType)]
-              -> [(SDoc, SDoc, Type, CmmType)]
-insertRetAddr platform CCallConv args
-    = case platformArch platform of
-      ArchX86_64
-       | platformOS platform == OSMinGW32 ->
-          -- On other Windows x86_64 we insert the return address
-          -- after the 4th argument, because this is the point
-          -- at which we need to flush a register argument to the stack
-          -- (See rts/Adjustor.c for details).
-          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
-                        -> [(SDoc, SDoc, Type, CmmType)]
-              go 4 args = ret_addr_arg platform : args
-              go n (arg:args) = arg : go (n+1) args
-              go _ [] = []
-          in go 0 args
-       | otherwise ->
-          -- On other x86_64 platforms we insert the return address
-          -- after the 6th integer argument, because this is the point
-          -- at which we need to flush a register argument to the stack
-          -- (See rts/Adjustor.c for details).
-          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
-                        -> [(SDoc, SDoc, Type, CmmType)]
-              go 6 args = ret_addr_arg platform : args
-              go n (arg@(_,_,_,rep):args)
-               | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
-               | otherwise  = arg : go n     args
-              go _ [] = []
-          in go 0 args
-      _ ->
-          ret_addr_arg platform : args
-insertRetAddr _ _ args = args
-
-ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType)
-ret_addr_arg platform = (text "original_return_addr", text "void*", undefined,
-                         typeCmmType platform addrPrimTy)
-
--- For stdcall labels, if the type was a FunPtr or newtype thereof,
--- then we need to calculate the size of the arguments in order to add
--- the @n suffix to the label.
-fun_type_arg_stdcall_info :: Platform -> CCallConv -> Type -> Maybe Int
-fun_type_arg_stdcall_info platform StdCallConv ty
-  | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
-    tyConUnique tc == funPtrTyConKey
-  = let
-       (bndrs, _) = tcSplitPiTys arg_ty
-       fe_arg_tys = mapMaybe anonPiTyBinderType_maybe bndrs
-    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys)
-fun_type_arg_stdcall_info _ _other_conv _
-  = Nothing
diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Foreign/Call.hs
+++ /dev/null
@@ -1,350 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1994-1998
-
-
-Desugaring foreign calls
--}
-
-
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module GHC.HsToCore.Foreign.Call
-   ( dsCCall
-   , mkFCall
-   , unboxArg
-   , boxResult
-   , resultWrapper
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Core
-
-import GHC.HsToCore.Monad
-import GHC.Core.Utils
-import GHC.Core.Make
-import GHC.Types.SourceText
-import GHC.Types.Id.Make
-import GHC.Types.ForeignCall
-import GHC.Core.DataCon
-import GHC.HsToCore.Utils
-
-import GHC.Tc.Utils.TcType
-import GHC.Core.Type
-import GHC.Core.Multiplicity
-import GHC.Core.Coercion
-import GHC.Builtin.Types.Prim
-import GHC.Core.TyCon
-import GHC.Builtin.Types
-import GHC.Types.Basic
-import GHC.Types.Literal
-import GHC.Builtin.Names
-import GHC.Driver.Session
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-import Data.Maybe
-
-{-
-Desugaring of @ccall@s consists of adding some state manipulation,
-unboxing any boxed primitive arguments and boxing the result if
-desired.
-
-The state stuff just consists of adding in
-@PrimIO (\ s -> case s of { State# s# -> ... })@ in an appropriate place.
-
-The unboxing is straightforward, as all information needed to unbox is
-available from the type.  For each boxed-primitive argument, we
-transform:
-\begin{verbatim}
-   _ccall_ foo [ r, t1, ... tm ] e1 ... em
-   |
-   |
-   V
-   case e1 of { T1# x1# ->
-   ...
-   case em of { Tm# xm# -> xm#
-   ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
-   } ... }
-\end{verbatim}
-
-The reboxing of a @_ccall_@ result is a bit tricker: the types don't
-contain information about the state-pairing functions so we have to
-keep a list of \tr{(type, s-p-function)} pairs.  We transform as
-follows:
-\begin{verbatim}
-   ccall# foo [ r, t1#, ... tm# ] e1# ... em#
-   |
-   |
-   V
-   \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
-          (StateAnd<r># result# state#) -> (R# result#, realWorld#)
-\end{verbatim}
--}
-
-dsCCall :: CLabelString -- C routine to invoke
-        -> [CoreExpr]   -- Arguments (desugared)
-        -- Precondition: none have representation-polymorphic types
-        -> Safety       -- Safety of the call
-        -> Type         -- Type of the result: IO t
-        -> DsM CoreExpr -- Result, of type ???
-
-dsCCall lbl args may_gc result_ty
-  = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
-       (ccall_result_ty, res_wrapper) <- boxResult result_ty
-       uniq <- newUnique
-       let
-           target = StaticTarget NoSourceText lbl Nothing True
-           the_fcall    = CCall (CCallSpec target CCallConv may_gc)
-           the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
-       return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
-
-mkFCall :: Unique -> ForeignCall
-        -> [CoreExpr]     -- Args
-        -> Type           -- Result type
-        -> CoreExpr
--- Construct the ccall.  The only tricky bit is that the ccall Id should have
--- no free vars, so if any of the arg tys do we must give it a polymorphic type.
---      [I forget *why* it should have no free vars!]
--- For example:
---      mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
---
--- Here we build a ccall thus
---      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
---                      a b s x c
-mkFCall uniq the_fcall val_args res_ty
-  = assert (all isTyVar tyvars) $ -- this must be true because the type is top-level
-    mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
-  where
-    arg_tys = map exprType val_args
-    body_ty = (mkVisFunTysMany arg_tys res_ty)
-    tyvars  = tyCoVarsOfTypeWellScoped body_ty
-    ty      = mkInfForAllTys tyvars body_ty
-    the_fcall_id = mkFCallId uniq the_fcall ty
-
-unboxArg :: CoreExpr                    -- The supplied argument, not representation-polymorphic
-         -> DsM (CoreExpr,              -- To pass as the actual argument
-                 CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
-                )
--- Example: if the arg is e::Int, unboxArg will return
---      (x#::Int#, \W. case x of I# x# -> W)
--- where W is a CoreExpr that probably mentions x#
-
--- always returns a non-representation-polymorphic expression
-
-unboxArg arg
-  -- Primitive types: nothing to unbox
-  | isPrimitiveType arg_ty
-  = return (arg, \body -> body)
-
-  -- Recursive newtypes
-  | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
-  = unboxArg (mkCastDs arg co)
-
-  -- Booleans
-  | Just tc <- tyConAppTyCon_maybe arg_ty,
-    tc `hasKey` boolTyConKey
-  = do dflags <- getDynFlags
-       let platform = targetPlatform dflags
-       prim_arg <- newSysLocalDs ManyTy intPrimTy
-       return (Var prim_arg,
-              \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0))
-                             prim_arg
-                             (exprType body)
-                             [Alt DEFAULT [] body])
-
-  -- Data types with a single constructor, which has a single, primitive-typed arg
-  -- This deals with Int, Float etc; also Ptr, ForeignPtr
-  | is_product_type && data_con_arity == 1
-  = assertPpr (isUnliftedType data_con_arg_ty1) (pprType arg_ty) $
-                        -- Typechecker ensures this
-    do case_bndr <- newSysLocalDs ManyTy arg_ty
-       prim_arg <- newSysLocalDs ManyTy data_con_arg_ty1
-       return (Var prim_arg,
-               \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body]
-              )
-
-  -- Byte-arrays, both mutable and otherwise; hack warning
-  -- We're looking for values of type ByteArray, MutableByteArray
-  --    data ByteArray          ix = ByteArray        ix ix ByteArray#
-  --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
-  | is_product_type &&
-    data_con_arity == 3 &&
-    isJust maybe_arg3_tycon &&
-    (arg3_tycon ==  byteArrayPrimTyCon ||
-     arg3_tycon ==  mutableByteArrayPrimTyCon)
-  = do case_bndr <- newSysLocalDs ManyTy arg_ty
-       vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs (map unrestricted data_con_arg_tys)
-       return (Var arr_cts_var,
-               \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body]
-              )
-
-  | otherwise
-  = do l <- getSrcSpanDs
-       pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
-  where
-    arg_ty                                      = exprType arg
-    maybe_product_type                          = splitDataProductType_maybe arg_ty
-    is_product_type                             = isJust maybe_product_type
-    Just (_, _, data_con, scaled_data_con_arg_tys) = maybe_product_type
-    data_con_arg_tys                            = map scaledThing scaled_data_con_arg_tys
-    data_con_arity                              = dataConSourceArity data_con
-    (data_con_arg_ty1 : _)                      = data_con_arg_tys
-
-    (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
-    maybe_arg3_tycon               = tyConAppTyCon_maybe data_con_arg_ty3
-    Just arg3_tycon                = maybe_arg3_tycon
-
-boxResult :: Type
-          -> DsM (Type, CoreExpr -> CoreExpr)
-
--- Takes the result of the user-level ccall:
---      either (IO t),
---      or maybe just t for a side-effect-free call
--- Returns a wrapper for the primitive ccall itself, along with the
--- type of the result of the primitive ccall.  This result type
--- will be of the form
---      State# RealWorld -> (# State# RealWorld, t' #)
--- where t' is the unwrapped form of t.  If t is simply (), then
--- the result type will be
---      State# RealWorld -> (# State# RealWorld #)
-
-boxResult result_ty
-  | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
-        -- isIOType_maybe handles the case where the type is a
-        -- simple wrapping of IO.  E.g.
-        --      newtype Wrap a = W (IO a)
-        -- No coercion necessary because its a non-recursive newtype
-        -- (If we wanted to handle a *recursive* newtype too, we'd need
-        -- another case, and a coercion.)
-        -- The result is IO t, so wrap the result in an IO constructor
-  = do  { res <- resultWrapper io_res_ty
-        ; let return_result state anss = mkCoreUnboxedTuple [state, anss]
-
-        ; (ccall_res_ty, the_alt) <- mk_alt return_result res
-
-        ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
-        ; let io_data_con = head (tyConDataCons io_tycon)
-              toIOCon     = dataConWrapId io_data_con
-
-              wrap the_call =
-                              mkApps (Var toIOCon)
-                                     [ Type io_res_ty,
-                                       Lam state_id $
-                                       mkWildCase (App the_call (Var state_id))
-                                             (unrestricted ccall_res_ty)
-                                             (coreAltType the_alt)
-                                             [the_alt]
-                                     ]
-
-        ; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) }
-
-boxResult result_ty
-  = do -- It isn't IO, so do unsafePerformIO
-       -- It's not conveniently available, so we inline it
-       res <- resultWrapper result_ty
-       (ccall_res_ty, the_alt) <- mk_alt return_result res
-       let
-           wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
-                                           (unrestricted ccall_res_ty)
-                                           (coreAltType the_alt)
-                                           [the_alt]
-       return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)
-  where
-    return_result _ ans = ans
-
-
-mk_alt :: (Expr Var -> Expr Var -> Expr Var)
-       -> (Maybe Type, Expr Var -> Expr Var)
-       -> DsM (Type, CoreAlt)
-mk_alt return_result (Nothing, wrap_result)
-  = do -- The ccall returns ()
-       state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
-       let
-             the_rhs = return_result (Var state_id)
-                                     (wrap_result (panic "boxResult"))
-
-             ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]
-             the_alt      = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs
-
-       return (ccall_res_ty, the_alt)
-
-mk_alt return_result (Just prim_res_ty, wrap_result)
-  = -- The ccall returns a non-() value
-    assertPpr (isPrimitiveType prim_res_ty) (ppr prim_res_ty) $
-             -- True because resultWrapper ensures it is so
-    do { result_id <- newSysLocalDs ManyTy prim_res_ty
-       ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
-       ; let the_rhs = return_result (Var state_id)
-                                (wrap_result (Var result_id))
-             ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]
-             the_alt      = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs
-       ; return (ccall_res_ty, the_alt) }
-
-
-resultWrapper :: Type
-              -> DsM (Maybe Type,               -- Type of the expected result, if any
-                      CoreExpr -> CoreExpr)     -- Wrapper for the result
--- resultWrapper deals with the result *value*
--- E.g. foreign import foo :: Int -> IO T
--- Then resultWrapper deals with marshalling the 'T' part
--- So if    resultWrapper ty = (Just ty_rep, marshal)
---  then      marshal (e :: ty_rep) :: ty
--- That is, 'marshal' wrape the result returned by the foreign call,
--- of type ty_rep, into the value Haskell expected, of type 'ty'
---
--- Invariant: ty_rep is always a primitive type
---            i.e. (isPrimitiveType ty_rep) is True
-
-resultWrapper result_ty
-  -- Base case 1: primitive types
-  | isPrimitiveType result_ty
-  = return (Just result_ty, \e -> e)
-
-  -- Base case 2: the unit type ()
-  | Just (tc,_) <- maybe_tc_app
-  , tc `hasKey` unitTyConKey
-  = return (Nothing, \_ -> unitExpr)
-
-  -- Base case 3: the boolean type
-  | Just (tc,_) <- maybe_tc_app
-  , tc `hasKey` boolTyConKey
-  = do { dflags <- getDynFlags
-       ; let platform = targetPlatform dflags
-       ; let marshal_bool e
-               = mkWildCase e (unrestricted intPrimTy) boolTy
-                   [ Alt DEFAULT                        [] (Var trueDataConId )
-                   , Alt (LitAlt (mkLitInt platform 0)) [] (Var falseDataConId)]
-       ; return (Just intPrimTy, marshal_bool) }
-
-  -- Newtypes
-  | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
-  = do { (maybe_ty, wrapper) <- resultWrapper rep_ty
-       ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) }
-
-  -- The type might contain foralls (eg. for dummy type arguments,
-  -- referring to 'Ptr a' is legal).
-  | Just (tyvar, rest) <- splitForAllTyCoVar_maybe result_ty
-  = do { (maybe_ty, wrapper) <- resultWrapper rest
-       ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) }
-
-  -- Data types with a single constructor, which has a single arg
-  -- This includes types like Ptr and ForeignPtr
-  | Just (tycon, tycon_arg_tys) <- maybe_tc_app
-  , Just data_con <- tyConSingleAlgDataCon_maybe tycon  -- One constructor
-  , null (dataConExTyCoVars data_con)                   -- no existentials
-  , [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys  -- One argument
-  = do { (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
-       ; let marshal_con e  = Var (dataConWrapId data_con)
-                              `mkTyApps` tycon_arg_tys
-                              `App` wrapper e
-       ; return (maybe_ty, marshal_con) }
-
-  | otherwise
-  = pprPanic "resultWrapper" (ppr result_ty)
-  where
-    maybe_tc_app = splitTyConApp_maybe result_ty
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ /dev/null
@@ -1,205 +0,0 @@
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1998
--}
-
--- | Desugaring foreign declarations
-module GHC.HsToCore.Foreign.Decl
-  ( dsForeigns
-  )
-where
-
-import GHC.Prelude
-import GHC.Data.FastString
-
-import GHC.Tc.Utils.Monad        -- temp
-
-import GHC.HsToCore.Foreign.C
-import GHC.HsToCore.Foreign.JavaScript
-import GHC.HsToCore.Foreign.Utils
-import GHC.HsToCore.Monad
-
-import GHC.Hs
-import GHC.Types.Id
-import GHC.Types.ForeignStubs
-import GHC.Unit.Module
-import GHC.Core.Coercion
-
-import GHC.Cmm.CLabel
-import GHC.Types.ForeignCall
-import GHC.Types.SrcLoc
-import GHC.Utils.Outputable
-import GHC.Driver.Session
-import GHC.Platform
-import GHC.Data.OrdList
-import GHC.Driver.Hooks
-
-import Data.List (unzip4)
-
-{-
-Desugaring of @foreign@ declarations is naturally split up into
-parts, an @import@ and an @export@  part. A @foreign import@
-declaration
-\begin{verbatim}
-  foreign import cc nm f :: prim_args -> IO prim_res
-\end{verbatim}
-is the same as
-\begin{verbatim}
-  f :: prim_args -> IO prim_res
-  f a1 ... an = _ccall_ nm cc a1 ... an
-\end{verbatim}
-so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with these.
--}
-
-dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
-dsForeigns fos = do
-    hooks <- getHooks
-    case dsForeignsHook hooks of
-        Nothing -> dsForeigns' fos
-        Just h  -> h fos
-
-dsForeigns' :: [LForeignDecl GhcTc]
-            -> DsM (ForeignStubs, OrdList Binding)
-dsForeigns' []
-  = return (NoStubs, nilOL)
-dsForeigns' fos = do
-    mod <- getModule
-    platform <- targetPlatform <$> getDynFlags
-    fives <- mapM do_ldecl fos
-    let
-        (hs, cs, idss, bindss) = unzip4 fives
-        fe_ids = concat idss
-        fe_init_code = foreignExportsInitialiser platform mod fe_ids
-    --
-    return (ForeignStubs
-             (mconcat hs)
-             (mconcat cs `mappend` fe_init_code),
-            foldr (appOL . toOL) nilOL bindss)
-  where
-   do_ldecl (L loc decl) = putSrcSpanDs (locA loc) (do_decl decl)
-
-   do_decl :: ForeignDecl GhcTc -> DsM (CHeader, CStub, [Id], [Binding])
-   do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
-      traceIf (text "fi start" <+> ppr id)
-      let id' = unLoc id
-      (bs, h, c) <- dsFImport id' co spec
-      traceIf (text "fi end" <+> ppr id)
-      return (h, c, [], bs)
-
-   do_decl (ForeignExport { fd_name = L _ id
-                          , fd_e_ext = co
-                          , fd_fe = CExport _
-                              (L _ (CExportStatic _ ext_nm cconv)) }) = do
-      (h, c, _, _) <- dsFExport id co ext_nm cconv False
-      return (h, c, [id], [])
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Foreign import}
-*                                                                      *
-************************************************************************
-
-Desugaring foreign imports is just the matter of creating a binding
-that on its RHS unboxes its arguments, performs the external call
-(using the @CCallOp@ primop), before boxing the result up and returning it.
-
-However, we create a worker/wrapper pair, thus:
-
-        foreign import f :: Int -> IO Int
-==>
-        f x = IO ( \s -> case x of { I# x# ->
-                         case fw s x# of { (# s1, y# #) ->
-                         (# s1, I# y# #)}})
-
-        fw s x# = ccall f s x#
-
-The strictness/CPR analyser won't do this automatically because it doesn't look
-inside returned tuples; but inlining this wrapper is a Really Good Idea
-because it exposes the boxing to the call site.
--}
-
-dsFImport :: Id
-          -> Coercion
-          -> ForeignImport (GhcPass p)
-          -> DsM ([Binding], CHeader, CStub)
-dsFImport id co (CImport _ cconv safety mHeader spec) = do
-  platform <- getPlatform
-  case platformArch platform of
-    ArchJavaScript -> dsJsImport id co spec (unLoc cconv) (unLoc safety) mHeader
-    _              -> dsCImport  id co spec (unLoc cconv) (unLoc safety) mHeader
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Foreign export}
-*                                                                      *
-************************************************************************
-
-The function that does most of the work for `@foreign export@' declarations.
-(see below for the boilerplate code a `@foreign export@' declaration expands
- into.)
-
-For each `@foreign export foo@' in a module M we generate:
-\begin{itemize}
-\item a C function `@foo@', which calls
-\item a Haskell stub `@M.\$ffoo@', which calls
-\end{itemize}
-the user-written Haskell function `@M.foo@'.
--}
-
-dsFExport :: Id                 -- Either the exported Id,
-                                -- or the foreign-export-dynamic constructor
-          -> Coercion           -- Coercion between the Haskell type callable
-                                -- from C, and its representation type
-          -> CLabelString       -- The name to export to C land
-          -> CCallConv
-          -> Bool               -- True => foreign export dynamic
-                                --         so invoke IO action that's hanging off
-                                --         the first argument's stable pointer
-          -> DsM ( CHeader      -- contents of Module_stub.h
-                 , CStub        -- contents of Module_stub.c
-                 , String       -- string describing type to pass to createAdj.
-                 , Int          -- size of args to stub function
-                 )
-dsFExport fn_id co ext_name cconv is_dyn = do
-  platform <- getPlatform
-  case platformArch platform of
-    ArchJavaScript -> dsJsFExport fn_id co ext_name cconv is_dyn
-    _              -> dsCFExport  fn_id co ext_name cconv is_dyn
-
-
-foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub
-foreignExportsInitialiser _        _   []     = mempty
-foreignExportsInitialiser platform mod hs_fns =
-   -- Initialise foreign exports by registering a stable pointer from an
-   -- __attribute__((constructor)) function.
-   -- The alternative is to do this from stginit functions generated in
-   -- codeGen/CodeGen.hs; however, stginit functions have a negative impact
-   -- on binary sizes and link times because the static linker will think that
-   -- all modules that are imported directly or indirectly are actually used by
-   -- the program.
-   -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
-   --
-   -- See Note [Tracking foreign exports] in rts/ForeignExports.c
-   initializerCStub platform fn_nm list_decl fn_body
-  where
-    fn_nm       = mkInitializerStubLabel mod (fsLit "fexports")
-    mod_str     = pprModuleName (moduleName mod)
-    fn_body     = text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi
-    list_symbol = text "stg_exports_" <> mod_str
-    list_decl   = text "static struct ForeignExportsList" <+> list_symbol <+> equals
-         <+> braces (
-           text ".exports = " <+> export_list <> comma <+>
-           text ".n_entries = " <+> ppr (length hs_fns))
-         <> semi
-
-    export_list = braces $ pprWithCommas closure_ptr hs_fns
-
-    closure_ptr :: Id -> SDoc
-    closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure"
-
diff --git a/compiler/GHC/HsToCore/Foreign/JavaScript.hs b/compiler/GHC/HsToCore/Foreign/JavaScript.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Foreign/JavaScript.hs
+++ /dev/null
@@ -1,683 +0,0 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
--- | Handling of JavaScript foreign imports/exports
-module GHC.HsToCore.Foreign.JavaScript
-  ( dsJsImport
-  , dsJsFExport
-  , dsJsFExportDynamic
-  )
-where
-
-import GHC.Prelude
-
-import GHC.Platform
-
-import GHC.Hs
-
-import GHC.HsToCore.Monad
-import GHC.HsToCore.Foreign.Call
-import GHC.HsToCore.Foreign.Prim
-import GHC.HsToCore.Foreign.Utils
-import GHC.HsToCore.Utils
-
-import GHC.Core
-import GHC.Core.Make
-import GHC.Core.Utils
-import GHC.Core.DataCon
-import GHC.Core.Unfold.Make
-import GHC.Core.Type
-import GHC.Core.TyCon
-import GHC.Core.Coercion
-import GHC.Core.Multiplicity
-
-import GHC.Types.Id
-import GHC.Types.Id.Make
-import GHC.Types.Literal
-import GHC.Types.ForeignStubs
-import GHC.Types.SourceText
-import GHC.Types.Name
-import GHC.Types.RepType
-import GHC.Types.ForeignCall
-import GHC.Types.Basic
-import GHC.Types.Unique
-
-import GHC.Unit.Module
-
-import GHC.Tc.Utils.TcType
-
-import GHC.Cmm.Expr
-import GHC.Cmm.Utils
-
-import GHC.JS.Ppr
-
-import GHC.Driver.Session
-import GHC.Driver.Config
-
-import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim
-import GHC.Builtin.Names
-
-import GHC.Data.FastString
-import GHC.Data.Pair
-import GHC.Data.Maybe
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Encoding
-
-dsJsFExport
-  :: Id                 -- Either the exported Id,
-                        -- or the foreign-export-dynamic constructor
-  -> Coercion           -- Coercion between the Haskell type callable
-                        -- from C, and its representation type
-  -> CLabelString       -- The name to export to C land
-  -> CCallConv
-  -> Bool               -- True => foreign export dynamic
-                        --         so invoke IO action that's hanging off
-                        --         the first argument's stable pointer
-  -> DsM ( CHeader      -- contents of Module_stub.h
-         , CStub        -- contents of Module_stub.c
-         , String       -- string describing type to pass to createAdj.
-         , Int          -- size of args to stub function
-         )
-
-dsJsFExport fn_id co ext_name cconv isDyn = do
-    let
-       ty                              = pSnd $ coercionKind co
-       (_tvs,sans_foralls)             = tcSplitForAllTyVars ty
-       (fe_arg_tys', orig_res_ty)      = tcSplitFunTys sans_foralls
-       -- We must use tcSplits here, because we want to see
-       -- the (IO t) in the corner of the type!
-       fe_arg_tys | isDyn     = tail fe_arg_tys'
-                  | otherwise = fe_arg_tys'
-
-       -- Look at the result type of the exported function, orig_res_ty
-       -- If it's IO t, return         (t, True)
-       -- If it's plain t, return      (t, False)
-       (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
-                                -- The function already returns IO t
-                                Just (_ioTyCon, res_ty) -> (res_ty, True)
-                                -- The function returns t
-                                Nothing                 -> (orig_res_ty, False)
-    platform <- targetPlatform <$> getDynFlags
-    return $
-      mkFExportJSBits platform ext_name
-                     (if isDyn then Nothing else Just fn_id)
-                     (map scaledThing fe_arg_tys) res_ty is_IO_res_ty cconv
-
-mkFExportJSBits
-  :: Platform
-  -> FastString
-  -> Maybe Id      -- Just==static, Nothing==dynamic
-  -> [Type]
-  -> Type
-  -> Bool          -- True <=> returns an IO type
-  -> CCallConv
-  -> (CHeader,
-      CStub,
-      String,      -- the argument reps
-      Int          -- total size of arguments
-     )
-mkFExportJSBits platform c_nm maybe_target arg_htys res_hty is_IO_res_ty _cconv
- = (header_bits, js_bits, type_string,
-    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- arg_info] -- all the args
-         -- NB. the calculation here isn't strictly speaking correct.
-         -- We have a primitive Haskell type (eg. Int#, Double#), and
-         -- we want to know the size, when passed on the C stack, of
-         -- the associated C type (eg. HsInt, HsDouble).  We don't have
-         -- this information to hand, but we know what GHC's conventions
-         -- are for passing around the primitive Haskell types, so we
-         -- use that instead.  I hope the two coincide --SDM
-    )
- where
-  -- list the arguments to the JS function
-  arg_info :: [(SDoc,           -- arg name
-                SDoc,           -- C type
-                Type,           -- Haskell type
-                CmmType)]       -- the CmmType
-  arg_info  = [ let stg_type = showStgType ty in
-                (arg_cname n stg_type,
-                 stg_type,
-                 ty,
-                 typeCmmType platform (getPrimTyOf ty))
-              | (ty,n) <- zip arg_htys [1::Int ..] ]
-
-  arg_cname n _stg_ty = text ('a':show n)
-
-  type_string = primTyDescChar platform res_hty : arg_type_string
-
-  arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info]
-
-  -- stuff to do with the return type of the JS function
-  res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
-
-  unboxResType | res_hty_is_unit = text "h$rts_getUnit"
-               | otherwise       = unpackHObj res_hty
-
-  header_bits = maybe mempty idTag maybe_target
-  idTag i = let (tag, u) = unpkUnique (getUnique i)
-            in  CHeader (char tag <> int u)
-
-  fun_args
-    | null arg_info = empty -- text "void"
-    | otherwise         = hsep $ punctuate comma
-                               $ map (\(nm,_ty,_,_) -> nm) arg_info
-
-  fun_proto
-      = text "async" <+>
-        text "function" <+>
-        (if isNothing maybe_target
-         then text "h$" <> ftext c_nm
-         else ftext c_nm) <>
-        parens fun_args
-
-  fun_export
-     = case maybe_target of
-          Just hs_fn | Just m <- nameModule_maybe (getName hs_fn) ->
-            text "h$foreignExport" <>
-                        parens (
-                          ftext c_nm <> comma <>
-                          strlit (unitIdString (moduleUnitId m)) <> comma <>
-                          strlit (moduleNameString (moduleName m)) <> comma <>
-                          strlit (unpackFS c_nm) <> comma <>
-                          strlit type_string
-                        ) <> semi
-          _ -> empty
-
-  strlit xs = docToSDoc (pprStringLit (mkFastString xs))
-
-  -- the target which will form the root of what we ask rts_evalIO to run
-  the_cfun
-     = case maybe_target of
-          Nothing    -> text "h$deRefStablePtr(the_stableptr)"
-          Just hs_fn -> idClosureText hs_fn
-
-  -- the expression we give to rts_eval
-  expr_to_run :: SDoc
-  expr_to_run
-     = foldl appArg the_cfun arg_info
-       where
-          appArg acc (arg_cname, _, arg_hty, _)
-             = text "h$rts_apply"
-               <> parens (acc <> comma <> mkHObj arg_hty <> parens arg_cname)
-
-  -- finally, the whole darn thing
-  js_bits = CStub { getCStub        = js_sdoc
-                  , getInitializers = mempty
-                  , getFinalizers   = mempty
-                  }
-       where js_sdoc = space
-               $$ fun_proto
-               $$ vcat
-                 [ lbrace
-                 ,   text "return"
-                     <+> text "await"
-                     <+> text "h$rts_eval"
-                     <> parens ((if is_IO_res_ty
-                                 then expr_to_run
-                                 else text "h$rts_toIO" <> parens expr_to_run)
-                                <> comma <+> unboxResType)
-                     <> semi
-                 , rbrace
-                 ]
-               $$ fun_export
-
-idClosureText :: Id -> SDoc
-idClosureText i
-  | isExportedId i
-  , name <- getName i
-  , Just m <- nameModule_maybe name
-  = let str = renderWithContext defaultSDocContext (pprFullName m (localiseName name))
-    in text "h$" <> text (zEncodeString str)
-  | otherwise
-  = panic "idClosureText: unknown module"
-
--- | Desugaring of JavaScript foreign imports
-dsJsImport
-  :: Id
-  -> Coercion
-  -> CImportSpec
-  -> CCallConv
-  -> Safety
-  -> Maybe Header
-  -> DsM ([Binding], CHeader, CStub)
-dsJsImport id co (CLabel cid) cconv _ _ = do
-   let ty = pFst $ coercionKind co
-       fod = case tyConAppTyCon_maybe (dropForAlls ty) of
-             Just tycon
-              | tyConUnique tycon == funPtrTyConKey ->
-                 IsFunction
-             _ -> IsData
-   (_resTy, foRhs) <- jsResultWrapper ty
---   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
-   let rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
-       rhs' = Cast rhs co
-       stdcall_info = fun_type_arg_stdcall_info cconv ty
-
-   return ([(id, rhs')], mempty, mempty)
-
-dsJsImport id co (CFunction target) cconv@PrimCallConv safety _
-  = dsPrimCall id co (CCall (CCallSpec target cconv safety))
-dsJsImport id co (CFunction target) cconv safety mHeader
-  = dsJsCall id co (CCall (CCallSpec target cconv safety)) mHeader
-dsJsImport id co CWrapper cconv _ _
-  = dsJsFExportDynamic id co cconv
-
--- fixme work in progress
--- FIXME (Sylvain 2022-03): possibility of code sharing with dsFExportDynamic?
--- Lot of duplication
-dsJsFExportDynamic :: Id
-                 -> Coercion
-                 -> CCallConv
-                 -> DsM ([Binding], CHeader, CStub)
-dsJsFExportDynamic id co0 cconv = do
-    let
-      ty                            = pFst (coercionKind co0)
-      (tvs,sans_foralls)            = tcSplitForAllTyVars ty
-      ([Scaled arg_mult arg_ty], fn_res_ty)  = tcSplitFunTys sans_foralls
-      (io_tc, res_ty)               = expectJust "dsJsFExportDynamic: IO type expected"
-                                        -- Must have an IO type; hence Just
-                                        $ tcSplitIOType_maybe fn_res_ty
-    mod <- getModule
-    platform <- targetPlatform <$> getDynFlags
-    let fe_nm = mkFastString $ zEncodeString
-            ("h$" ++ moduleStableString mod ++ "$" ++ toJsName id)
-        -- Construct the label based on the passed id, don't use names
-        -- depending on Unique. See #13807 and Note [Unique Determinism].
-    cback <- newSysLocalDs arg_mult arg_ty
-    newStablePtrId <- dsLookupGlobalId newStablePtrName
-    stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
-    let
-        stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
-        export_ty     = mkVisFunTyMany stable_ptr_ty arg_ty
-    bindIOId <- dsLookupGlobalId bindIOName
-    stbl_value <- newSysLocalDs ManyTy stable_ptr_ty
-    (h_code, c_code, typestring, args_size) <- dsJsFExport id (mkRepReflCo export_ty) fe_nm cconv True
-    let
-         {-
-          The arguments to the external function which will
-          create a little bit of (template) code on the fly
-          for allowing the (stable pointed) Haskell closure
-          to be entered using an external calling convention
-          (stdcall, ccall).
-         -}
-        adj_args      = [ mkIntLit platform (toInteger (ccallConvToInt cconv))
-                        , Var stbl_value
-                        , Lit (LitLabel fe_nm mb_sz_args IsFunction)
-                        , Lit (mkLitString typestring)
-                        ]
-          -- name of external entry point providing these services.
-          -- (probably in the RTS.)
-        adjustor   = fsLit "createAdjustor"
-
-          -- Determine the number of bytes of arguments to the stub function,
-          -- so that we can attach the '@N' suffix to its label if it is a
-          -- stdcall on Windows.
-        mb_sz_args = case cconv of
-                        StdCallConv -> Just args_size
-                        _           -> Nothing
-
-    ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
-        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
-
-    let io_app = mkLams tvs                  $
-                 Lam cback                   $
-                 mkApps (Var bindIOId)
-                        [ Type stable_ptr_ty
-                        , Type res_ty
-                        , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
-                        , Lam stbl_value ccall_adj
-                        ]
-
-        fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
-               -- Never inline the f.e.d. function, because the litlit
-               -- might not be in scope in other modules.
-
-    return ([fed], h_code, c_code)
-
-toJsName :: Id -> String
-toJsName i = renderWithContext defaultSDocContext (pprCode (ppr (idName i)))
-
-dsJsCall :: Id -> Coercion -> ForeignCall -> Maybe Header
-        -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
-dsJsCall fn_id co (CCall (CCallSpec target cconv safety)) _mDeclHeader = do
-    let
-        ty                   = pFst $ coercionKind co
-        (tv_bndrs, rho)      = tcSplitForAllTyVarBinders ty
-        (arg_tys, io_res_ty) = tcSplitFunTys rho
-
-    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism
-    (val_args, arg_wrappers) <- mapAndUnzipM unboxJsArg (map Var args)
-
-    let
-        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
-
-    (ccall_result_ty, res_wrapper) <- boxJsResult io_res_ty
-
-    ccall_uniq <- newUnique
-    work_uniq  <- newUnique
-
-    simpl_opts <- initSimpleOpts <$> getDynFlags
-
-    let
-        -- Build the worker
-        fcall         = CCall (CCallSpec target cconv safety)
-        worker_ty     = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty)
-        tvs           = map binderVar tv_bndrs
-        the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
-        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
-        work_id       = mkSysLocal (fsLit "$wccall") work_uniq ManyTy worker_ty
-
-        -- Build the wrapper
-        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
-        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
-        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
-        wrap_rhs'    = Cast wrap_rhs co
-        fn_id_w_inl  = fn_id
-                       `setIdUnfolding`
-                       mkInlineUnfoldingWithArity simpl_opts VanillaSrc
-                                                  (length args)  wrap_rhs'
-
-    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, mempty)
-
-
-mkHObj :: Type -> SDoc
-mkHObj t = text "h$rts_mk" <> text (showFFIType t)
-
-unpackHObj :: Type -> SDoc
-unpackHObj t = text "h$rts_get" <> text (showFFIType t)
-
-showStgType :: Type -> SDoc
-showStgType t = text "Hs" <> text (showFFIType t)
-
-showFFIType :: Type -> String
-showFFIType t = getOccString (getName (typeTyCon t))
-
-typeTyCon :: Type -> TyCon
-typeTyCon ty
-  -- UnaryRep rep_ty <- repType ty
-  | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) -- rep_ty
-  = tc
-  | otherwise
-  = pprPanic "typeTyCon" (ppr ty)
-
-
-{-
-  We unbox arguments for JS calls a bit different from native code:
-    - Bool is marshalled to true/false, not 0/1
-    - All int types are narrowed, since JS floats have a greater range than Int32
- -}
-
-unboxJsArg :: CoreExpr                  -- The supplied argument
-           -> DsM (CoreExpr,              -- To pass as the actual argument
-                   CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
-                  )
-unboxJsArg arg
-  -- Primtive types: nothing to unbox
-  | isPrimitiveType arg_ty
-  = return (arg, \body -> body)
-
-  -- Recursive newtypes
-  | Just (co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
-  = unboxJsArg (mkCast arg co)
-
-  -- Booleans, do not convert to 0/1, only force them
-  | Just tc <- tyConAppTyCon_maybe arg_ty,
-    tc `hasKey` boolTyConKey
-  = return (arg,
-              \ body -> mkWildCase arg (unrestricted boolTy) (exprType body) [Alt DEFAULT [] body])
-
-  | Just tc <- tyConAppTyCon_maybe arg_ty,
-    tc `hasKey` anyTyConKey
-  = return (arg,
-              \ body -> mkWildCase arg (unrestricted arg_ty) (exprType body) [Alt DEFAULT [] body])
-  -- Data types with a single constructor, which has a single, primitive-typed arg
-  -- This deals with Int, Float etc; also Ptr, ForeignPtr
-  | is_product_type && data_con_arity == 1
-    = do case_bndr <- newSysLocalDs ManyTy arg_ty
-         prim_arg <- newSysLocalDs ManyTy (scaledThing data_con_arg_ty1)
-         return (Var prim_arg,
-               \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body]
-              )
-
-  -- Byte-arrays, both mutable and otherwise; hack warning
-  -- We're looking for values of type ByteArray, MutableByteArray
-  --    data ByteArray          ix = ByteArray        ix ix ByteArray#
-  --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
-  | is_product_type &&
-    data_con_arity == 3 &&
-    isJust maybe_arg3_tycon &&
-    (arg3_tycon ==  byteArrayPrimTyCon ||
-     arg3_tycon ==  mutableByteArrayPrimTyCon)
-  = do case_bndr <- newSysLocalDs ManyTy arg_ty
-       vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
-       return (Var arr_cts_var,
-               \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body]
-              )
-
-  | otherwise
-  = do l <- getSrcSpanDs
-       pprPanic "unboxJsArg: " (ppr l <+> ppr arg_ty)
-  where
-    arg_ty                                      = exprType arg
-    maybe_product_type                          = splitDataProductType_maybe arg_ty
-    is_product_type                             = isJust maybe_product_type
-    Just (_, _, data_con, data_con_arg_tys)     = maybe_product_type
-    data_con_arity                              = dataConSourceArity data_con
-    (data_con_arg_ty1 : _)                      = data_con_arg_tys
-
-    (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
-    maybe_arg3_tycon               = tyConAppTyCon_maybe (scaledThing data_con_arg_ty3)
-    Just arg3_tycon                = maybe_arg3_tycon
-
-
-boxJsResult :: Type
-            -> DsM (Type, CoreExpr -> CoreExpr)
-boxJsResult result_ty
-  | isRuntimeRepKindedTy result_ty = panic "boxJsResult: runtime rep ty" -- fixme
--- Takes the result of the user-level ccall:
---      either (IO t),
---      or maybe just t for an side-effect-free call
--- Returns a wrapper for the primitive ccall itself, along with the
--- type of the result of the primitive ccall.  This result type
--- will be of the form
---      State# RealWorld -> (# State# RealWorld, t' #)
--- where t' is the unwrapped form of t.  If t is simply (), then
--- the result type will be
---      State# RealWorld -> (# State# RealWorld #)
-
-boxJsResult result_ty
-  | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
-        -- isIOType_maybe handles the case where the type is a
-        -- simple wrapping of IO.  E.g.
-        --      newtype Wrap a = W (IO a)
-        -- No coercion necessary because its a non-recursive newtype
-        -- (If we wanted to handle a *recursive* newtype too, we'd need
-        -- another case, and a coercion.)
-        -- The result is IO t, so wrap the result in an IO constructor
-  = do  { res <- jsResultWrapper io_res_ty
-        ; let return_result state ans
-                = mkCoreUnboxedTuple [state, ans]
-
-        ; (ccall_res_ty, the_alt) <- mk_alt return_result res
-
-        ; state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
-        ; let io_data_con = head (tyConDataCons io_tycon)
-              toIOCon     = dataConWrapId io_data_con
-
-              wrap the_call =
-                              mkApps (Var toIOCon)
-                                     [ Type io_res_ty,
-                                       Lam state_id $
-                                       mkWildCase (App the_call (Var state_id))
-                                             (unrestricted ccall_res_ty)
-                                             (coreAltType the_alt)
-                                             [the_alt]
-                                     ]
-
-        ; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) }
-
-boxJsResult result_ty
-  = do -- It isn't IO, so do unsafePerformIO
-       -- It's not conveniently available, so we inline it
-       res <- jsResultWrapper result_ty
-       (ccall_res_ty, the_alt) <- mk_alt return_result res
-       let
-           wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
-                                           (unrestricted ccall_res_ty)
-                                           (coreAltType the_alt)
-                                           [the_alt]
-       return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)
-  where
-    return_result _ ans = ans
-
-mk_alt :: (Expr Var -> Expr Var -> Expr Var)
-       -> (Maybe Type, Expr Var -> Expr Var)
-       -> DsM (Type, CoreAlt)
-mk_alt return_result (Nothing, wrap_result)
-  = do -- The ccall returns ()
-       state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
-       let
-             the_rhs = return_result (Var state_id)
-                                     (wrap_result $ panic "jsBoxResult")
-             ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]
-             the_alt      = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs
-       return (ccall_res_ty, the_alt)
-
-mk_alt return_result (Just prim_res_ty, wrap_result)
-                -- The ccall returns a non-() value
-  | isUnboxedTupleType prim_res_ty = do
-    let
-        Just ls = fmap dropRuntimeRepArgs (tyConAppArgs_maybe prim_res_ty)
-        arity = 1 + length ls
-    args_ids <- mapM (newSysLocalDs ManyTy) ls
-    state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
-    let
-        result_tup = mkCoreUnboxedTuple (map Var args_ids)
-        the_rhs = return_result (Var state_id)
-                                (wrap_result result_tup)
-        ccall_res_ty = mkTupleTy Unboxed (realWorldStatePrimTy : ls)
-        the_alt      = Alt (DataAlt (tupleDataCon Unboxed arity))
-                           (state_id : args_ids)
-                          the_rhs
-    return (ccall_res_ty, the_alt)
-
-  | otherwise = do
-    result_id <- newSysLocalDs ManyTy prim_res_ty
-    state_id <- newSysLocalDs ManyTy realWorldStatePrimTy
-    let
-        the_rhs = return_result (Var state_id)
-                                (wrap_result (Var result_id))
-        ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]
-        the_alt      = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs
-    return (ccall_res_ty, the_alt)
-
-fun_type_arg_stdcall_info :: CCallConv -> Type -> Maybe Int
-fun_type_arg_stdcall_info _other_conv _ = Nothing
-
-
-jsResultWrapper
-  :: Type
-  -> DsM ( Maybe Type           -- Type of the expected result, if any
-         , CoreExpr -> CoreExpr -- Wrapper for the result
-         )
--- resultWrapper deals with the result *value*
--- E.g. foreign import foo :: Int -> IO T
--- Then resultWrapper deals with marshalling the 'T' part
-jsResultWrapper result_ty
-  | isRuntimeRepKindedTy result_ty = return (Nothing, id) -- fixme this seems like a hack
-  -- Base case 1a: unboxed tuples
-  | Just (tc, args) <- splitTyConApp_maybe result_ty
-  , isUnboxedTupleTyCon tc {- && False -} = do
-    let args' = dropRuntimeRepArgs args
-    (tys, wrappers) <- unzip <$> mapM jsResultWrapper args'
-    matched <- mapM (mapM (newSysLocalDs ManyTy)) tys
-    let tys'    = catMaybes tys
-        -- arity   = length args'
-        -- resCon  = tupleDataCon Unboxed (length args)
-        err     = panic "jsResultWrapper: used Id with result type Nothing"
-        resWrap :: CoreExpr
-        resWrap = mkCoreUnboxedTuple (zipWith (\w -> w . Var . fromMaybe err) wrappers matched)
-    return $
-      if null tys'
-        then (Nothing, \_ -> resWrap)
-        else let innerArity = length tys'
-                 innerTy    = mkTupleTy Unboxed tys'
-                 innerCon   = tupleDataCon Unboxed innerArity
-                 inner :: CoreExpr -> CoreExpr
-                 inner e    = mkWildCase e (unrestricted innerTy) result_ty
-                                         [Alt (DataAlt innerCon)
-                                              (catMaybes matched)
-                                              resWrap
-                                         ]
-             in (Just innerTy, inner)
-
-  -- Base case 1b: primitive types
-  | isPrimitiveType result_ty
-  = return (Just result_ty, \e -> e)
-  -- Base case 1c: boxed tuples
-  -- fixme: levity args?
-  | Just (tc, args) <- splitTyConApp_maybe result_ty
-  , isBoxedTupleTyCon tc = do
-      let args'   = dropRuntimeRepArgs args
-          innerTy = mkTupleTy Unboxed args'
-      (inner_res, w) <- jsResultWrapper innerTy
-      matched <- mapM (newSysLocalDs ManyTy) args'
-      let inner e = mkWildCase (w e) (unrestricted innerTy) result_ty
-                               [ Alt (DataAlt (tupleDataCon Unboxed (length args')))
-                                     matched
-                                     (mkCoreTup (map Var matched))
-                                -- mkCoreConApps (tupleDataCon Boxed (length args)) (map Type args ++ map Var matched)
-                               ]
-      return (inner_res, inner)
-
-  -- Base case 2: the unit type ()
-  | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
-  = return (Nothing, \_ -> Var unitDataConId)
-
-  -- Base case 3: the boolean type
-  | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey = do
---    result_id <- newSysLocalDs boolTy
-    ccall_uniq <- newUnique
-    let forceBool e = mkJsCall ccall_uniq "$r = !(!$1)" [e] boolTy
-    return
-     (Just intPrimTy, \e -> forceBool e)
-
-  -- Base case 4: the any type
-  |  Just (tc,_) <- maybe_tc_app, tc `hasKey` anyTyConKey
-  = return (Just result_ty, \e -> e)
-
-  -- Newtypes
-  | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
-  = do (maybe_ty, wrapper) <- jsResultWrapper rep_ty
-       return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co))
-
-  -- The type might contain foralls (eg. for dummy type arguments,
-  -- referring to 'Ptr a' is legal).
-  | Just (tyvar, rest) <- splitForAllTyCoVar_maybe result_ty
-  = do (maybe_ty, wrapper) <- jsResultWrapper rest
-       return (maybe_ty, \e -> Lam tyvar (wrapper e))
-
-  -- Data types with a single constructor, which has a single arg
-  -- This includes types like Ptr and ForeignPtr
-  | Just (_tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitDataProductType_maybe result_ty,
-    dataConSourceArity data_con == 1
-  = do let (unwrapped_res_ty : _) = data_con_arg_tys
-       (maybe_ty, wrapper) <- jsResultWrapper (scaledThing unwrapped_res_ty)
-       return
-         (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
-                                 (map Type tycon_arg_tys ++ [wrapper e]))
-
-  | otherwise
-  = pprPanic "jsResultWrapper" (ppr result_ty)
-  where
-    maybe_tc_app = splitTyConApp_maybe result_ty
-
--- low-level primitive JavaScript call:
-mkJsCall :: Unique -> String -> [CoreExpr] -> Type -> CoreExpr
-mkJsCall u tgt args t = mkFCall u ccall args t
-  where
-    ccall = CCall $ CCallSpec
-              (StaticTarget NoSourceText (mkFastString tgt) (Just primUnit) True)
-              JavaScriptCallConv
-              PlayRisky
diff --git a/compiler/GHC/HsToCore/Foreign/Prim.hs b/compiler/GHC/HsToCore/Foreign/Prim.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Foreign/Prim.hs
+++ /dev/null
@@ -1,45 +0,0 @@
--- | Foreign primitive calls
---
--- This is for `@foreign import prim@' declarations.
---
--- Currently, at the core level we pretend that these primitive calls are
--- foreign calls. It may make more sense in future to have them as a distinct
--- kind of Id, or perhaps to bundle them with PrimOps since semantically and for
--- calling convention they are really prim ops.
-module GHC.HsToCore.Foreign.Prim
-  ( dsPrimCall
-  )
-where
-
-import GHC.Prelude
-
-import GHC.Tc.Utils.Monad        -- temp
-import GHC.Tc.Utils.TcType
-
-import GHC.Core
-import GHC.Core.Type
-import GHC.Core.Coercion
-
-import GHC.HsToCore.Monad
-import GHC.HsToCore.Foreign.Call
-
-import GHC.Types.Id
-import GHC.Types.ForeignStubs
-import GHC.Types.ForeignCall
-
-dsPrimCall :: Id -> Coercion -> ForeignCall
-           -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
-dsPrimCall fn_id co fcall = do
-    let
-        ty                   = coercionLKind co
-        (tvs, fun_ty)        = tcSplitForAllInvisTyVars ty
-        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
-
-    args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism
-
-    ccall_uniq <- newUnique
-    let
-        call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty
-        rhs      = mkLams tvs (mkLams args call_app)
-        rhs'     = Cast rhs co
-    return ([(fn_id, rhs')], mempty, mempty)
diff --git a/compiler/GHC/HsToCore/Foreign/Utils.hs b/compiler/GHC/HsToCore/Foreign/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Foreign/Utils.hs
+++ /dev/null
@@ -1,105 +0,0 @@
-{-# LANGUAGE MultiWayIf #-}
-
-module GHC.HsToCore.Foreign.Utils
-  ( Binding
-  , getPrimTyOf
-  , primTyDescChar
-  , ppPrimTyConStgType
-  )
-where
-
-import GHC.Prelude
-
-import GHC.Platform
-
-import GHC.Tc.Utils.TcType
-
-import GHC.Core (CoreExpr)
-import GHC.Core.DataCon
-import GHC.Core.TyCon
-import GHC.Core.TyCo.Rep
-
-import GHC.Types.Id
-import GHC.Types.RepType
-
-import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
-                              -- the occurrence analyser will sort it all out
-
--- This function returns the primitive type associated with the boxed
--- type argument to a foreign export (eg. Int ==> Int#).
-getPrimTyOf :: Type -> UnaryType
-getPrimTyOf ty
-  | isBoolTy rep_ty = intPrimTy
-  -- Except for Bool, the types we are interested in have a single constructor
-  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
-  | otherwise =
-  case splitDataProductType_maybe rep_ty of
-     Just (_, _, data_con, [Scaled _ prim_ty]) ->
-        assert (dataConSourceArity data_con == 1) $
-        assertPpr (isUnliftedType prim_ty) (ppr prim_ty)
-          -- NB: it's OK to call isUnliftedType here, as we don't allow
-          -- representation-polymorphic types in foreign import/export declarations
-        prim_ty
-     _other -> pprPanic "getPrimTyOf" (ppr ty)
-  where
-        rep_ty = unwrapType ty
-
--- represent a primitive type as a Char, for building a string that
--- described the foreign function type.  The types are size-dependent,
--- e.g. 'W' is a signed 32-bit integer.
-primTyDescChar :: Platform -> Type -> Char
-primTyDescChar !platform ty
- | ty `eqType` unitTy = 'v'
- | otherwise
- = case typePrimRep1 (getPrimTyOf ty) of
-     IntRep      -> signed_word
-     WordRep     -> unsigned_word
-     Int8Rep     -> 'B'
-     Word8Rep    -> 'b'
-     Int16Rep    -> 'S'
-     Word16Rep   -> 's'
-     Int32Rep    -> 'W'
-     Word32Rep   -> 'w'
-     Int64Rep    -> 'L'
-     Word64Rep   -> 'l'
-     AddrRep     -> 'p'
-     FloatRep    -> 'f'
-     DoubleRep   -> 'd'
-     _           -> pprPanic "primTyDescChar" (ppr ty)
-  where
-    (signed_word, unsigned_word) = case platformWordSize platform of
-      PW4 -> ('W','w')
-      PW8 -> ('L','l')
-
--- | Printed C Type to be used with CAPI calling convention
-ppPrimTyConStgType :: TyCon -> Maybe String
-ppPrimTyConStgType tc =
-  if | tc == charPrimTyCon -> Just "StgChar"
-     | tc == intPrimTyCon -> Just "StgInt"
-     | tc == int8PrimTyCon -> Just "StgInt8"
-     | tc == int16PrimTyCon -> Just "StgInt16"
-     | tc == int32PrimTyCon -> Just "StgInt32"
-     | tc == int64PrimTyCon -> Just "StgInt64"
-     | tc == wordPrimTyCon -> Just "StgWord"
-     | tc == word8PrimTyCon -> Just "StgWord8"
-     | tc == word16PrimTyCon -> Just "StgWord16"
-     | tc == word32PrimTyCon -> Just "StgWord32"
-     | tc == word64PrimTyCon -> Just "StgWord64"
-     | tc == floatPrimTyCon -> Just "StgFloat"
-     | tc == doublePrimTyCon -> Just "StgDouble"
-     | tc == addrPrimTyCon -> Just "StgAddr"
-     | tc == stablePtrPrimTyCon -> Just "StgStablePtr"
-     | tc == arrayPrimTyCon -> Just "const StgAddr"
-     | tc == mutableArrayPrimTyCon -> Just "StgAddr"
-     | tc == byteArrayPrimTyCon -> Just "const StgAddr"
-     | tc == mutableByteArrayPrimTyCon -> Just "StgAddr"
-     | tc == smallArrayPrimTyCon -> Just "const StgAddr"
-     | tc == smallMutableArrayPrimTyCon -> Just "StgAddr"
-     | otherwise -> Nothing
diff --git a/compiler/GHC/HsToCore/GuardedRHSs.hs b/compiler/GHC/HsToCore/GuardedRHSs.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/GuardedRHSs.hs
+++ /dev/null
@@ -1,156 +0,0 @@
-
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Matching guarded right-hand-sides (GRHSs)
--}
-
-module GHC.HsToCore.GuardedRHSs ( dsGuarded, dsGRHSs, isTrueLHsExpr ) where
-
-import GHC.Prelude
-
-import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsLExpr, dsLocalBinds )
-import {-# SOURCE #-} GHC.HsToCore.Match ( matchSinglePatVar )
-
-import GHC.Hs
-import GHC.Core.Make
-import GHC.Core
-import GHC.Core.Utils (bindNonRec)
-
-import GHC.HsToCore.Monad
-import GHC.HsToCore.Utils
-import GHC.HsToCore.Pmc.Types ( Nablas )
-import GHC.Core.Type ( Type )
-import GHC.Utils.Misc
-import GHC.Types.SrcLoc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Core.Multiplicity
-import Control.Monad ( zipWithM )
-import Data.List.NonEmpty ( NonEmpty, toList )
-
-{-
-@dsGuarded@ is used for GRHSs.
-It desugars:
-\begin{verbatim}
-        | g1 -> e1
-        ...
-        | gn -> en
-        where binds
-\end{verbatim}
-producing an expression with a runtime error in the corner case if
-necessary.  The type argument gives the type of the @ei@.
--}
-
-dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> NonEmpty Nablas -> DsM CoreExpr
-dsGuarded grhss rhs_ty rhss_nablas = do
-    match_result <- dsGRHSs PatBindRhs grhss rhs_ty rhss_nablas
-    error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty
-                               (text "pattern binding")
-    extractMatchResult match_result error_expr
-
--- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@.
-
-dsGRHSs :: HsMatchContext GhcRn
-        -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs
-        -> Type                        -- ^ Type of RHS
-        -> NonEmpty Nablas             -- ^ Refined pattern match checking
-                                       --   models, one for the pattern part and
-                                       --   one for each GRHS.
-        -> DsM (MatchResult CoreExpr)
-dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas
-  = assert (notNull grhss) $
-    do { match_results <- assert (length grhss == length rhss_nablas) $
-                          zipWithM (dsGRHS hs_ctx rhs_ty) (toList rhss_nablas) grhss
-       ; nablas <- getPmNablas
-       -- We need to remember the Nablas from the particular match context we
-       -- are in, which might be different to when dsLocalBinds is actually
-       -- called.
-       ; let ds_binds      = updPmNablas nablas . dsLocalBinds binds
-             match_result1 = foldr1 combineMatchResults match_results
-             match_result2 = adjustMatchResultDs ds_binds match_result1
-                             -- NB: nested dsLet inside matchResult
-       ; return match_result2 }
-
-dsGRHS :: HsMatchContext GhcRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc)
-       -> DsM (MatchResult CoreExpr)
-dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))
-  = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs_nablas rhs rhs_ty
-
-{-
-************************************************************************
-*                                                                      *
-*  matchGuard : make a MatchResult CoreExpr CoreExpr from a guarded RHS                  *
-*                                                                      *
-************************************************************************
--}
-
-matchGuards :: [GuardStmt GhcTc]     -- Guard
-            -> HsStmtContext GhcRn   -- Context
-            -> Nablas                -- The RHS's covered set for PmCheck
-            -> LHsExpr GhcTc         -- RHS
-            -> Type                  -- Type of RHS of guard
-            -> DsM (MatchResult CoreExpr)
-
--- See comments with HsExpr.Stmt re what a BodyStmt means
--- Here we must be in a guard context (not do-expression, nor list-comp)
-
-matchGuards [] _ nablas rhs _
-  = do  { core_rhs <- updPmNablas nablas (dsLExpr rhs)
-        ; return (cantFailMatchResult core_rhs) }
-
-        -- BodyStmts must be guards
-        -- Turn an "otherwise" guard is a no-op.  This ensures that
-        -- you don't get a "non-exhaustive eqns" message when the guards
-        -- finish in "otherwise".
-        -- NB:  The success of this clause depends on the typechecker not
-        --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
-        --      If it does, you'll get bogus overlap warnings
-matchGuards (BodyStmt _ e _ _ : stmts) ctx nablas rhs rhs_ty
-  | Just addTicks <- isTrueLHsExpr e = do
-    match_result <- matchGuards stmts ctx nablas rhs rhs_ty
-    return (adjustMatchResultDs addTicks match_result)
-matchGuards (BodyStmt _ expr _ _ : stmts) ctx nablas rhs rhs_ty = do
-    match_result <- matchGuards stmts ctx nablas rhs rhs_ty
-    pred_expr <- dsLExpr expr
-    return (mkGuardedMatchResult pred_expr match_result)
-
-matchGuards (LetStmt _ binds : stmts) ctx nablas rhs rhs_ty = do
-    match_result <- matchGuards stmts ctx nablas rhs rhs_ty
-    return (adjustMatchResultDs (dsLocalBinds binds) match_result)
-        -- NB the dsLet occurs inside the match_result
-        -- Reason: dsLet takes the body expression as its argument
-        --         so we can't desugar the bindings without the
-        --         body expression in hand
-
-matchGuards (BindStmt _ pat bind_rhs : stmts) ctx nablas rhs rhs_ty = do
-    let upat = unLoc pat
-    match_var <- selectMatchVar ManyTy upat
-       -- We only allow unrestricted patterns in guard, hence the `Many`
-       -- above. It isn't clear what linear patterns would mean, maybe we will
-       -- figure it out in the future.
-
-    match_result <- matchGuards stmts ctx nablas rhs rhs_ty
-    core_rhs <- dsLExpr bind_rhs
-    match_result' <- matchSinglePatVar match_var (Just core_rhs) (StmtCtxt ctx)
-                                       pat rhs_ty match_result
-    pure $ bindNonRec match_var core_rhs <$> match_result'
-
-matchGuards (LastStmt  {} : _) _ _ _ _ = panic "matchGuards LastStmt"
-matchGuards (ParStmt   {} : _) _ _ _ _ = panic "matchGuards ParStmt"
-matchGuards (TransStmt {} : _) _ _ _ _ = panic "matchGuards TransStmt"
-matchGuards (RecStmt   {} : _) _ _ _ _ = panic "matchGuards RecStmt"
-matchGuards (ApplicativeStmt {} : _) _ _ _ _ =
-  panic "matchGuards ApplicativeLastStmt"
-
-{-
-Should {\em fail} if @e@ returns @D@
-\begin{verbatim}
-f x | p <- e', let C y# = e, f y# = r1
-    | otherwise          = r2
-\end{verbatim}
--}
diff --git a/compiler/GHC/HsToCore/ListComp.hs b/compiler/GHC/HsToCore/ListComp.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/ListComp.hs
+++ /dev/null
@@ -1,662 +0,0 @@
-
-{-# LANGUAGE TypeFamilies   #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Desugaring list comprehensions, monad comprehensions and array comprehensions
--}
-
-module GHC.HsToCore.ListComp ( dsListComp, dsMonadComp ) where
-
-import GHC.Prelude
-
-import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr )
-
-import GHC.Hs
-import GHC.Hs.Syn.Type
-import GHC.Core
-import GHC.Core.Make
-
-import GHC.HsToCore.Monad          -- the monadery used in the desugarer
-import GHC.HsToCore.Utils
-
-import GHC.Driver.Session
-import GHC.Core.Utils
-import GHC.Types.Id
-import GHC.Core.Type
-import GHC.Builtin.Types
-import GHC.HsToCore.Match
-import GHC.Builtin.Names
-import GHC.Types.SrcLoc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Tc.Utils.TcType
-import GHC.Data.List.SetOps( getNth )
-
-{-
-List comprehensions may be desugared in one of two ways: ``ordinary''
-(as you would expect if you read SLPJ's book) and ``with foldr/build
-turned on'' (if you read Gill {\em et al.}'s paper on the subject).
-
-There will be at least one ``qualifier'' in the input.
--}
-
-dsListComp :: [ExprLStmt GhcTc]
-           -> Type              -- Type of entire list
-           -> DsM CoreExpr
-dsListComp lquals res_ty = do
-    dflags <- getDynFlags
-    let quals = map unLoc lquals
-        elt_ty = case tcTyConAppArgs res_ty of
-                   [elt_ty] -> elt_ty
-                   _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)
-
-    if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags
-       -- Either rules are switched off, or we are ignoring what there are;
-       -- Either way foldr/build won't happen, so use the more efficient
-       -- Wadler-style desugaring
-       || isParallelComp quals
-       -- Foldr-style desugaring can't handle parallel list comprehensions
-        then deListComp quals (mkNilExpr elt_ty)
-        else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)
-             -- Foldr/build should be enabled, so desugar
-             -- into foldrs and builds
-
-  where
-    -- We must test for ParStmt anywhere, not just at the head, because an extension
-    -- to list comprehensions would be to add brackets to specify the associativity
-    -- of qualifier lists. This is really easy to do by adding extra ParStmts into the
-    -- mix of possibly a single element in length, so we do this to leave the possibility open
-    isParallelComp = any isParallelStmt
-
-    isParallelStmt (ParStmt {}) = True
-    isParallelStmt _            = False
-
-
--- This function lets you desugar a inner list comprehension and a list of the binders
--- of that comprehension that we need in the outer comprehension into such an expression
--- and the type of the elements that it outputs (tuples of binders)
-dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type)
-dsInnerListComp (ParStmtBlock _ stmts bndrs _)
-  = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs
-             list_ty          = mkListTy bndrs_tuple_type
-
-             -- really use original bndrs below!
-       ; expr <- dsListComp (stmts ++ [noLocA $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty
-
-       ; return (expr, bndrs_tuple_type) }
-
--- This function factors out commonality between the desugaring strategies for GroupStmt.
--- Given such a statement it gives you back an expression representing how to compute the transformed
--- list and the tuple that you need to bind from that list in order to proceed with your desugaring
-dsTransStmt :: ExprStmt GhcTc -> DsM (CoreExpr, LPat GhcTc)
-dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap
-                       , trS_by = by, trS_using = using }) = do
-    let (from_bndrs, to_bndrs) = unzip binderMap
-
-    let from_bndrs_tys  = map idType from_bndrs
-        to_bndrs_tys    = map idType to_bndrs
-
-        to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
-
-    -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
-    (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExtField stmts
-                                                        from_bndrs noSyntaxExpr)
-
-    -- Work out what arguments should be supplied to that expression: i.e. is an extraction
-    -- function required? If so, create that desugared function and add to arguments
-    usingExpr' <- dsLExpr using
-    usingArgs' <- case by of
-                    Nothing   -> return [expr']
-                    Just by_e -> do { by_e' <- dsLExpr by_e
-                                    ; lam' <- matchTuple from_bndrs by_e'
-                                    ; return [lam', expr'] }
-
-    -- Create an unzip function for the appropriate arity and element types and find "map"
-    unzip_stuff' <- mkUnzipBind form from_bndrs_tys
-    map_id <- dsLookupGlobalId mapName
-
-    -- Generate the expressions to build the grouped list
-    let -- First we apply the grouping function to the inner list
-        inner_list_expr' = mkApps usingExpr' usingArgs'
-        -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
-        -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
-        -- the "b" to be a tuple of "to" lists!
-        -- Then finally we bind the unzip function around that expression
-        bound_unzipped_inner_list_expr'
-          = case unzip_stuff' of
-              Nothing -> inner_list_expr'
-              Just (unzip_fn', unzip_rhs') ->
-                Let (Rec [(unzip_fn', unzip_rhs')]) $
-                mkApps (Var map_id) $
-                [ Type (mkListTy from_tup_ty)
-                , Type to_bndrs_tup_ty
-                , Var unzip_fn'
-                , inner_list_expr' ]
-
-    -- Build a pattern that ensures the consumer binds into the NEW binders,
-    -- which hold lists rather than single values
-    let pat = mkBigLHsVarPatTupId to_bndrs  -- NB: no '!
-    return (bound_unzipped_inner_list_expr', pat)
-
-dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt"
-
-{-
-************************************************************************
-*                                                                      *
-*           Ordinary desugaring of list comprehensions                 *
-*                                                                      *
-************************************************************************
-
-Just as in Phil's chapter~7 in SLPJ, using the rules for
-optimally-compiled list comprehensions.  This is what Kevin followed
-as well, and I quite happily do the same.  The TQ translation scheme
-transforms a list of qualifiers (either boolean expressions or
-generators) into a single expression which implements the list
-comprehension.  Because we are generating 2nd-order polymorphic
-lambda-calculus, calls to NIL and CONS must be applied to a type
-argument, as well as their usual value arguments.
-\begin{verbatim}
-TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>
-
-(Rule C)
-TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
-
-(Rule B)
-TQ << [ e | b , qs ] ++ L >> =
-    if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
-
-(Rule A')
-TQ << [ e | p <- L1, qs ]  ++  L2 >> =
-  letrec
-    h = \ u1 ->
-          case u1 of
-            []        ->  TE << L2 >>
-            (u2 : u3) ->
-                  (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)
-                    [] (h u3)
-  in
-    h ( TE << L1 >> )
-
-"h", "u1", "u2", and "u3" are new variables.
-\end{verbatim}
-
-@deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@
-is the TE translation scheme.  Note that we carry around the @L@ list
-already desugared.  @dsListComp@ does the top TE rule mentioned above.
-
-To the above, we add an additional rule to deal with parallel list
-comprehensions.  The translation goes roughly as follows:
-     [ e | p1 <- e11, let v1 = e12, p2 <- e13
-         | q1 <- e21, let v2 = e22, q2 <- e23]
-     =>
-     [ e | ((x1, .., xn), (y1, ..., ym)) <-
-               zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]
-                   [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]
-where (x1, .., xn) are the variables bound in p1, v1, p2
-      (y1, .., ym) are the variables bound in q1, v2, q2
-
-In the translation below, the ParStmt branch translates each parallel branch
-into a sub-comprehension, and desugars each independently.  The resulting lists
-are fed to a zip function, we create a binding for all the variables bound in all
-the comprehensions, and then we hand things off the desugarer for bindings.
-The zip function is generated here a) because it's small, and b) because then we
-don't have to deal with arbitrary limits on the number of zip functions in the
-prelude, nor which library the zip function came from.
-The introduced tuples are Boxed, but only because I couldn't get it to work
-with the Unboxed variety.
--}
-
-deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr
-
-deListComp [] _ = panic "deListComp"
-
-deListComp (LastStmt _ body _ _ : quals) list
-  =     -- Figure 7.4, SLPJ, p 135, rule C above
-    assert (null quals) $
-    do { core_body <- dsLExpr body
-       ; return (mkConsExpr (exprType core_body) core_body list) }
-
-        -- Non-last: must be a guard
-deListComp (BodyStmt _ guard _ _ : quals) list = do  -- rule B above
-    core_guard <- dsLExpr guard
-    core_rest <- deListComp quals list
-    return (mkIfThenElse core_guard core_rest list)
-
--- [e | let B, qs] = let B in [e | qs]
-deListComp (LetStmt _ binds : quals) list = do
-    core_rest <- deListComp quals list
-    dsLocalBinds binds core_rest
-
-deListComp (stmt@(TransStmt {}) : quals) list = do
-    (inner_list_expr, pat) <- dsTransStmt stmt
-    deBindComp pat inner_list_expr quals list
-
-deListComp (BindStmt _ pat list1 : quals) core_list2 = do -- rule A' above
-    core_list1 <- dsLExpr list1
-    deBindComp pat core_list1 quals core_list2
-
-deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list
-  = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
-       ; let (exps, qual_tys) = unzip exps_and_qual_tys
-
-       ; (zip_fn, zip_rhs) <- mkZipBind qual_tys
-
-        -- Deal with [e | pat <- zip l1 .. ln] in example above
-       ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
-                    quals list }
-  where
-        bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs]
-
-        -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
-        pat  = mkBigLHsPatTupId pats
-        pats = map mkBigLHsVarPatTupId bndrs_s
-
-deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
-
-deListComp (ApplicativeStmt {} : _) _ =
-  panic "deListComp ApplicativeStmt"
-
-deBindComp :: LPat GhcTc
-           -> CoreExpr
-           -> [ExprStmt GhcTc]
-           -> CoreExpr
-           -> DsM (Expr Id)
-deBindComp pat core_list1 quals core_list2 = do
-    let u3_ty@u1_ty = exprType core_list1       -- two names, same thing
-
-        -- u1_ty is a [alpha] type, and u2_ty = alpha
-    let u2_ty = hsLPatType pat
-
-    let res_ty = exprType core_list2
-        h_ty   = u1_ty `mkVisFunTyMany` res_ty
-
-       -- no representation polymorphism here, as list comprehensions
-       -- don't work with RebindableSyntax. NB: These are *not* monad comps.
-    [h, u1, u2, u3] <- newSysLocalsDs $ map unrestricted [h_ty, u1_ty, u2_ty, u3_ty]
-
-    -- the "fail" value ...
-    let
-        core_fail   = App (Var h) (Var u3)
-        letrec_body = App (Var h) core_list1
-
-    rest_expr <- deListComp quals core_fail
-    core_match <- matchSimply (Var u2) (StmtCtxt (HsDoStmt ListComp)) pat rest_expr core_fail
-
-    let
-        rhs = Lam u1 $
-              Case (Var u1) u1 res_ty
-                   [Alt (DataAlt nilDataCon)  []       core_list2
-                   ,Alt (DataAlt consDataCon) [u2, u3] core_match]
-                        -- Increasing order of tag
-
-    return (Let (Rec [(h, rhs)]) letrec_body)
-
-{-
-************************************************************************
-*                                                                      *
-*           Foldr/Build desugaring of list comprehensions              *
-*                                                                      *
-************************************************************************
-
-@dfListComp@ are the rules used with foldr/build turned on:
-
-\begin{verbatim}
-TE[ e | ]            c n = c e n
-TE[ e | b , q ]      c n = if b then TE[ e | q ] c n else n
-TE[ e | p <- l , q ] c n = let
-                                f = \ x b -> case x of
-                                                  p -> TE[ e | q ] c b
-                                                  _ -> b
-                           in
-                           foldr f n l
-\end{verbatim}
--}
-
-dfListComp :: Id -> Id            -- 'c' and 'n'
-           -> [ExprStmt GhcTc]    -- the rest of the qual's
-           -> DsM CoreExpr
-
-dfListComp _ _ [] = panic "dfListComp"
-
-dfListComp c_id n_id (LastStmt _ body _ _ : quals)
-  = assert (null quals) $
-    do { core_body <- dsLExpr body
-       ; return (mkApps (Var c_id) [core_body, Var n_id]) }
-
-        -- Non-last: must be a guard
-dfListComp c_id n_id (BodyStmt _ guard _ _  : quals) = do
-    core_guard <- dsLExpr guard
-    core_rest <- dfListComp c_id n_id quals
-    return (mkIfThenElse core_guard core_rest (Var n_id))
-
-dfListComp c_id n_id (LetStmt _ binds : quals) = do
-    -- new in 1.3, local bindings
-    core_rest <- dfListComp c_id n_id quals
-    dsLocalBinds binds core_rest
-
-dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
-    (inner_list_expr, pat) <- dsTransStmt stmt
-    -- Anyway, we bind the newly grouped list via the generic binding function
-    dfBindComp c_id n_id (pat, inner_list_expr) quals
-
-dfListComp c_id n_id (BindStmt _ pat list1 : quals) = do
-    -- evaluate the two lists
-    core_list1 <- dsLExpr list1
-
-    -- Do the rest of the work in the generic binding builder
-    dfBindComp c_id n_id (pat, core_list1) quals
-
-dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
-dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
-dfListComp _ _ (ApplicativeStmt {} : _) =
-  panic "dfListComp ApplicativeStmt"
-
-dfBindComp :: Id -> Id             -- 'c' and 'n'
-           -> (LPat GhcTc, CoreExpr)
-           -> [ExprStmt GhcTc]     -- the rest of the qual's
-           -> DsM CoreExpr
-dfBindComp c_id n_id (pat, core_list1) quals = do
-    -- find the required type
-    let x_ty   = hsLPatType pat
-    let b_ty   = idType n_id
-
-    -- create some new local id's
-    b <- newSysLocalDs ManyTy b_ty
-    x <- newSysLocalDs ManyTy x_ty
-
-    -- build rest of the comprehension
-    core_rest <- dfListComp c_id b quals
-
-    -- build the pattern match
-    core_expr <- matchSimply (Var x) (StmtCtxt (HsDoStmt ListComp))
-                pat core_rest (Var b)
-
-    -- now build the outermost foldr, and return
-    mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1
-
-{-
-************************************************************************
-*                                                                      *
-\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}
-*                                                                      *
-************************************************************************
--}
-
-mkZipBind :: [Type] -> DsM (Id, CoreExpr)
--- mkZipBind [t1, t2]
--- = (zip, \as1:[t1] as2:[t2]
---         -> case as1 of
---              [] -> []
---              (a1:as'1) -> case as2 of
---                              [] -> []
---                              (a2:as'2) -> (a1, a2) : zip as'1 as'2)]
-
-mkZipBind elt_tys = do
-    ass  <- mapM (newSysLocalDs ManyTy)  elt_list_tys
-    as'  <- mapM (newSysLocalDs ManyTy)  elt_tys
-    as's <- mapM (newSysLocalDs ManyTy)  elt_list_tys
-
-    zip_fn <- newSysLocalDs ManyTy zip_fn_ty
-
-    let inner_rhs = mkConsExpr elt_tuple_ty
-                        (mkBigCoreVarTup as')
-                        (mkVarApps (Var zip_fn) as's)
-        zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)
-
-    return (zip_fn, mkLams ass zip_body)
-  where
-    elt_list_tys      = map mkListTy elt_tys
-    elt_tuple_ty      = mkBigCoreTupTy elt_tys
-    elt_tuple_list_ty = mkListTy elt_tuple_ty
-
-    zip_fn_ty         = mkVisFunTysMany elt_list_tys elt_tuple_list_ty
-
-    mk_case (as, a', as') rest
-          = Case (Var as) as elt_tuple_list_ty
-                  [ Alt (DataAlt nilDataCon)  []        (mkNilExpr elt_tuple_ty)
-                  , Alt (DataAlt consDataCon) [a', as'] rest]
-                        -- Increasing order of tag
-
-
-mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))
--- mkUnzipBind [t1, t2]
--- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])
---     -> case ax of
---      (x1, x2) -> case axs of
---                (xs1, xs2) -> (x1 : xs1, x2 : xs2))
---      ([], [])
---      ys)
---
--- We use foldr here in all cases, even if rules are turned off, because we may as well!
-mkUnzipBind ThenForm _
- = return Nothing    -- No unzipping for ThenForm
-mkUnzipBind _ elt_tys
-  = do { ax  <- newSysLocalDs ManyTy elt_tuple_ty
-       ; axs <- newSysLocalDs ManyTy elt_list_tuple_ty
-       ; ys  <- newSysLocalDs ManyTy elt_tuple_list_ty
-       ; xs  <- mapM (newSysLocalDs ManyTy) elt_tys
-       ; xss <- mapM (newSysLocalDs ManyTy) elt_list_tys
-
-       ; unzip_fn <- newSysLocalDs ManyTy unzip_fn_ty
-
-       ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
-
-       ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
-             concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
-             tupled_concat_expression = mkBigCoreTup concat_expressions
-
-             folder_body_inner_case = mkBigTupleCase us1 xss tupled_concat_expression (Var axs)
-             folder_body_outer_case = mkBigTupleCase us2 xs folder_body_inner_case (Var ax)
-             folder_body = mkLams [ax, axs] folder_body_outer_case
-
-       ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
-       ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }
-  where
-    elt_tuple_ty       = mkBigCoreTupTy elt_tys
-    elt_tuple_list_ty  = mkListTy elt_tuple_ty
-    elt_list_tys       = map mkListTy elt_tys
-    elt_list_tuple_ty  = mkBigCoreTupTy elt_list_tys
-
-    unzip_fn_ty        = elt_tuple_list_ty `mkVisFunTyMany` elt_list_tuple_ty
-
-    mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
-
--- Translation for monad comprehensions
-
--- Entry point for monad comprehension desugaring
-dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr
-dsMonadComp stmts = dsMcStmts stmts
-
-dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr
-dsMcStmts []                      = panic "dsMcStmts"
-dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDsA loc (dsMcStmt stmt lstmts)
-
----------------
-dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr
-
-dsMcStmt (LastStmt _ body _ ret_op) stmts
-  = assert (null stmts) $
-    do { body' <- dsLExpr body
-       ; dsSyntaxExpr ret_op [body'] }
-
---   [ .. | let binds, stmts ]
-dsMcStmt (LetStmt _ binds) stmts
-  = do { rest <- dsMcStmts stmts
-       ; dsLocalBinds binds rest }
-
---   [ .. | a <- m, stmts ]
-dsMcStmt (BindStmt xbs pat rhs) stmts
-  = do { rhs' <- dsLExpr rhs
-       ; dsMcBindStmt pat rhs' (xbstc_bindOp xbs) (xbstc_failOp xbs) (xbstc_boundResultType xbs) stmts }
-
--- Apply `guard` to the `exp` expression
---
---   [ .. | exp, stmts ]
---
-dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts
-  = do { exp'       <- dsLExpr exp
-       ; rest       <- dsMcStmts stmts
-       ; guard_exp' <- dsSyntaxExpr guard_exp [exp']
-       ; dsSyntaxExpr then_exp [guard_exp', rest] }
-
--- Group statements desugar like this:
---
---   [| (q, then group by e using f); rest |]
---   --->  f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->
---         case unzip n_tup of qv' -> [| rest |]
---
--- where   variables (v1:t1, ..., vk:tk) are bound by q
---         qv = (v1, ..., vk)
---         qt = (t1, ..., tk)
---         (>>=) :: m2 a -> (a -> m3 b) -> m3 b
---         f :: forall a. (a -> t) -> m1 a -> m2 (n a)
---         n_tup :: n qt
---         unzip :: n qt -> (n t1, ..., n tk)    (needs Functor n)
-
-dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
-                    , trS_by = by, trS_using = using
-                    , trS_ret = return_op, trS_bind = bind_op
-                    , trS_ext = n_tup_ty'  -- n (a,b,c)
-                    , trS_fmap = fmap_op, trS_form = form }) stmts_rest
-  = do { let (from_bndrs, to_bndrs) = unzip bndrs
-
-       ; let from_bndr_tys = map idType from_bndrs     -- Types ty
-
-
-       -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
-       ; expr' <- dsInnerMonadComp stmts from_bndrs return_op
-
-       -- Work out what arguments should be supplied to that expression: i.e. is an extraction
-       -- function required? If so, create that desugared function and add to arguments
-       ; usingExpr' <- dsLExpr using
-       ; usingArgs' <- case by of
-                         Nothing   -> return [expr']
-                         Just by_e -> do { by_e' <- dsLExpr by_e
-                                         ; lam' <- matchTuple from_bndrs by_e'
-                                         ; return [lam', expr'] }
-
-       -- Generate the expressions to build the grouped list
-       -- Build a pattern that ensures the consumer binds into the NEW binders,
-       -- which hold monads rather than single values
-       ; body        <- dsMcStmts stmts_rest
-       ; n_tup_var'  <- newSysLocalDs ManyTy n_tup_ty'
-       ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys
-       ; us          <- newUniqueSupply
-       ; let rhs'  = mkApps usingExpr' usingArgs'
-             body' = mkBigTupleCase us to_bndrs body tup_n_expr'
-
-       ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] }
-
--- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel
--- statements, for example:
---
---   [ body | qs1 | qs2 | qs3 ]
---     ->  [ body | (bndrs1, (bndrs2, bndrs3))
---                     <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]
---
--- where `mzip` has type
---   mzip :: forall a b. m a -> m b -> m (a,b)
--- NB: we need a polymorphic mzip because we call it several times
-
-dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
- = do  { exps_w_tys  <- mapM ds_inner blocks   -- Pairs (exp :: m ty, ty)
-       ; mzip_op'    <- dsExpr mzip_op
-
-       ; let -- The pattern variables
-             pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks]
-             -- Pattern with tuples of variables
-             -- [v1,v2,v3]  =>  (v1, (v2, v3))
-             pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
-             (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->
-                                 (mkApps mzip_op' [Type t1, Type t2, e1, e2],
-                                  mkBoxedTupleTy [t1,t2]))
-                               exps_w_tys
-
-       ; dsMcBindStmt pat rhs bind_op Nothing bind_ty stmts_rest }
-  where
-    ds_inner :: ParStmtBlock GhcTc GhcTc -> DsM (CoreExpr, Type)
-    ds_inner (ParStmtBlock _ stmts bndrs return_op)
-       = do { exp <- dsInnerMonadComp stmts bndrs return_op
-            ; return (exp, mkBigCoreVarTupTy bndrs) }
-
-dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
-
-
-matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
--- (matchTuple [a,b,c] body)
---       returns the Core term
---  \x. case x of (a,b,c) -> body
-matchTuple ids body
-  = do { us <- newUniqueSupply
-       ; tup_id <- newSysLocalDs ManyTy (mkBigCoreVarTupTy ids)
-       ; return (Lam tup_id $ mkBigTupleCase us ids body (Var tup_id)) }
-
--- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
--- desugared `CoreExpr`
-dsMcBindStmt :: LPat GhcTc
-             -> CoreExpr        -- ^ the desugared rhs of the bind statement
-             -> SyntaxExpr GhcTc
-             -> Maybe (SyntaxExpr GhcTc)
-             -> Type            -- ^ S in (>>=) :: Q -> (R -> S) -> T
-             -> [ExprLStmt GhcTc]
-             -> DsM CoreExpr
-dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
-  = do  { body     <- dsMcStmts stmts
-        ; var      <- selectSimpleMatchVarL ManyTy pat
-        ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat
-                                  res1_ty (cantFailMatchResult body)
-        ; match_code <- dsHandleMonadicFailure MonadComp pat match fail_op
-        ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
-
--- Desugar nested monad comprehensions, for example in `then..` constructs
---    dsInnerMonadComp quals [a,b,c] ret_op
--- returns the desugaring of
---       [ (a,b,c) | quals ]
-
-dsInnerMonadComp :: [ExprLStmt GhcTc]
-                 -> [Id]               -- Return a tuple of these variables
-                 -> SyntaxExpr GhcTc   -- The monomorphic "return" operator
-                 -> DsM CoreExpr
-dsInnerMonadComp stmts bndrs ret_op
-  = dsMcStmts (stmts ++
-                 [noLocA (LastStmt noExtField (mkBigLHsVarTupId bndrs) Nothing ret_op)])
-
-
--- The `unzip` function for `GroupStmt` in a monad comprehensions
---
---   unzip :: m (a,b,..) -> (m a,m b,..)
---   unzip m_tuple = ( liftM selN1 m_tuple
---                   , liftM selN2 m_tuple
---                   , .. )
---
---   mkMcUnzipM fmap ys [t1, t2]
---     = ( fmap (selN1 :: (t1, t2) -> t1) ys
---       , fmap (selN2 :: (t1, t2) -> t2) ys )
-
-mkMcUnzipM :: TransForm
-           -> HsExpr GhcTc      -- fmap
-           -> Id                -- Of type n (a,b,c)
-           -> [Type]            -- [a,b,c]   (not representation-polymorphic)
-           -> DsM CoreExpr      -- Of type (n a, n b, n c)
-mkMcUnzipM ThenForm _ ys _
-  = return (Var ys) -- No unzipping to do
-
-mkMcUnzipM _ fmap_op ys elt_tys
-  = do { fmap_op' <- dsExpr fmap_op
-       ; xs       <- mapM (newSysLocalDs ManyTy) elt_tys
-       ; let tup_ty = mkBigCoreTupTy elt_tys
-       ; tup_xs   <- newSysLocalDs ManyTy tup_ty
-
-       ; let mk_elt i = mkApps fmap_op'  -- fmap :: forall a b. (a -> b) -> n a -> n b
-                           [ Type tup_ty, Type (getNth elt_tys i)
-                           , mk_sel i, Var ys]
-
-             mk_sel n = Lam tup_xs $
-                        mkBigTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)
-
-       ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ /dev/null
@@ -1,1220 +0,0 @@
-
-{-# LANGUAGE MonadComprehensions #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE PatternSynonyms #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-The @match@ function
--}
-
-module GHC.HsToCore.Match
-   ( match, matchEquations, matchWrapper, matchSimply
-   , matchSinglePat, matchSinglePatVar
-   )
-where
-
-import GHC.Prelude
-import GHC.Platform
-
-import Language.Haskell.Syntax.Basic (Boxity(..))
-
-import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
-
-import GHC.Types.Basic ( Origin(..), isGenerated )
-import GHC.Types.SourceText
-import GHC.Driver.Session
-import GHC.Hs
-import GHC.Hs.Syn.Type
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Utils.Monad
-import GHC.HsToCore.Pmc
-import GHC.HsToCore.Pmc.Types ( Nablas, initNablas )
-import GHC.HsToCore.Monad
-import GHC.HsToCore.Binds
-import GHC.HsToCore.GuardedRHSs
-import GHC.HsToCore.Utils
-import GHC.HsToCore.Errors.Types
-import GHC.HsToCore.Match.Constructor
-import GHC.HsToCore.Match.Literal
-
-import GHC.Core
-import GHC.Core.Utils
-import GHC.Core.Make
-import GHC.Core.ConLike
-import GHC.Core.DataCon
-import GHC.Core.PatSyn
-import GHC.Core.Type
-import GHC.Core.TyCo.Compare( eqType, eqTypes )
-import GHC.Core.Coercion ( eqCoercion )
-import GHC.Core.TyCon    ( isNewTyCon )
-import GHC.Core.Multiplicity
-import GHC.Builtin.Types
-
-import GHC.Types.Id
-import GHC.Types.Literal
-import GHC.Types.SrcLoc
-
-import GHC.Data.Maybe
-import GHC.Utils.Misc
-import GHC.Types.Name
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Data.FastString
-import GHC.Types.Unique
-import GHC.Types.Unique.DFM
-
-import Control.Monad ( zipWithM, unless, when )
-import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NEL
-import qualified Data.Map as Map
-
-{-
-************************************************************************
-*                                                                      *
-                The main matching function
-*                                                                      *
-************************************************************************
-
-The function @match@ is basically the same as in the Wadler chapter
-from "The Implementation of Functional Programming Languages",
-except it is monadised, to carry around the name supply, info about
-annotations, etc.
-
-Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
-\begin{enumerate}
-\item
-A list of $n$ variable names, those variables presumably bound to the
-$n$ expressions being matched against the $n$ patterns.  Using the
-list of $n$ expressions as the first argument showed no benefit and
-some inelegance.
-
-\item
-The second argument, a list giving the ``equation info'' for each of
-the $m$ equations:
-\begin{itemize}
-\item
-the $n$ patterns for that equation, and
-\item
-a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
-the front'' of the matching code, as in:
-\begin{verbatim}
-let <binds>
-in  <matching-code>
-\end{verbatim}
-\item
-and finally: (ToDo: fill in)
-
-The right way to think about the ``after-match function'' is that it
-is an embryonic @CoreExpr@ with a ``hole'' at the end for the
-final ``else expression''.
-\end{itemize}
-
-There is a data type, @EquationInfo@, defined in module @GHC.HsToCore.Monad@.
-
-An experiment with re-ordering this information about equations (in
-particular, having the patterns available in column-major order)
-showed no benefit.
-
-\item
-A default expression---what to evaluate if the overall pattern-match
-fails.  This expression will (almost?) always be
-a measly expression @Var@, unless we know it will only be used once
-(as we do in @glue_success_exprs@).
-
-Leaving out this third argument to @match@ (and slamming in lots of
-@Var "fail"@s) is a positively {\em bad} idea, because it makes it
-impossible to share the default expressions.  (Also, it stands no
-chance of working in our post-upheaval world of @Locals@.)
-\end{enumerate}
-
-Note: @match@ is often called via @matchWrapper@ (end of this module),
-a function that does much of the house-keeping that goes with a call
-to @match@.
-
-It is also worth mentioning the {\em typical} way a block of equations
-is desugared with @match@.  At each stage, it is the first column of
-patterns that is examined.  The steps carried out are roughly:
-\begin{enumerate}
-\item
-Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
-bindings to the second component of the equation-info):
-\item
-Now {\em unmix} the equations into {\em blocks} [w\/ local function
-@match_groups@], in which the equations in a block all have the same
- match group.
-(see ``the mixture rule'' in SLPJ).
-\item
-Call the right match variant on each block of equations; it will do the
-appropriate thing for each kind of column-1 pattern.
-\end{enumerate}
-
-We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
-than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
-And gluing the ``success expressions'' together isn't quite so pretty.
-
-This  @match@ uses @tidyEqnInfo@
-to get `as'- and `twiddle'-patterns out of the way (tidying), before
-applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em
-un}mixes the equations], producing a list of equation-info
-blocks, each block having as its first column patterns compatible with each other.
-
-Note [Match Ids]
-~~~~~~~~~~~~~~~~
-Most of the matching functions take an Id or [Id] as argument.  This Id
-is the scrutinee(s) of the match. The desugared expression may
-sometimes use that Id in a local binding or as a case binder.  So it
-should not have an External name; Lint rejects non-top-level binders
-with External names (#13043).
-
-See also Note [Localise pattern binders] in GHC.HsToCore.Utils
--}
-
-type MatchId = Id   -- See Note [Match Ids]
-
-match :: [MatchId]        -- ^ Variables rep\'ing the exprs we\'re matching with
-                          -- ^ See Note [Match Ids]
-                          --
-                          -- ^ Note that the Match Ids carry not only a name, but
-                          -- ^ also the multiplicity at which each column has been
-                          -- ^ type checked.
-      -> Type             -- ^ Type of the case expression
-      -> [EquationInfo]   -- ^ Info about patterns, etc. (type synonym below)
-      -> DsM (MatchResult CoreExpr) -- ^ Desugared result!
-
-match [] ty eqns
-  = assertPpr (not (null eqns)) (ppr ty) $
-    return (foldr1 combineMatchResults match_results)
-  where
-    match_results = [ assert (null (eqn_pats eqn)) $
-                      eqn_rhs eqn
-                    | eqn <- eqns ]
-
-match (v:vs) ty eqns    -- Eqns *can* be empty
-  = assertPpr (all (isInternalName . idName) vars) (ppr vars) $
-    do  { dflags <- getDynFlags
-        ; let platform = targetPlatform dflags
-                -- Tidy the first pattern, generating
-                -- auxiliary bindings if necessary
-        ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
-                -- Group the equations and match each group in turn
-        ; let grouped = groupEquations platform tidy_eqns
-
-         -- print the view patterns that are commoned up to help debug
-        ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
-
-        ; match_results <- match_groups grouped
-        ; return $ foldr (.) id aux_binds <$>
-            foldr1 combineMatchResults match_results
-        }
-  where
-    vars = v :| vs
-
-    dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo
-    dropGroup = fmap snd
-
-    match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty (MatchResult CoreExpr))
-    -- Result list of [MatchResult CoreExpr] is always non-empty
-    match_groups [] = matchEmpty v ty
-    match_groups (g:gs) = mapM match_group $ g :| gs
-
-    match_group :: NonEmpty (PatGroup,EquationInfo) -> DsM (MatchResult CoreExpr)
-    match_group eqns@((group,_) :| _)
-        = case group of
-            PgCon {}  -> matchConFamily  vars ty (ne $ subGroupUniq [(c,e) | (PgCon c, e) <- eqns'])
-            PgSyn {}  -> matchPatSyn     vars ty (dropGroup eqns)
-            PgLit {}  -> matchLiterals   vars ty (ne $ subGroupOrd [(l,e) | (PgLit l, e) <- eqns'])
-            PgAny     -> matchVariables  vars ty (dropGroup eqns)
-            PgN {}    -> matchNPats      vars ty (dropGroup eqns)
-            PgOverS {}-> matchNPats      vars ty (dropGroup eqns)
-            PgNpK {}  -> matchNPlusKPats vars ty (dropGroup eqns)
-            PgBang    -> matchBangs      vars ty (dropGroup eqns)
-            PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)
-            PgView {} -> matchView       vars ty (dropGroup eqns)
-      where eqns' = NEL.toList eqns
-            ne l = case NEL.nonEmpty l of
-              Just nel -> nel
-              Nothing -> pprPanic "match match_group" $ text "Empty result should be impossible since input was non-empty"
-
-    -- FIXME: we should also warn about view patterns that should be
-    -- commoned up but are not
-
-    -- print some stuff to see what's getting grouped
-    -- use -dppr-debug to see the resolution of overloaded literals
-    debug eqns =
-        let gs = map (\group -> foldr (\ (p,_) -> \acc ->
-                                           case p of PgView e _ -> e:acc
-                                                     _ -> acc) [] group) eqns
-            maybeWarn [] = return ()
-            maybeWarn l  = diagnosticDs (DsAggregatedViewExpressions l)
-        in
-          maybeWarn $ filter (not . null) gs
-
-matchEmpty :: MatchId -> Type -> DsM (NonEmpty (MatchResult CoreExpr))
--- See Note [Empty case alternatives]
-matchEmpty var res_ty
-  = return [MR_Fallible mk_seq]
-  where
-    mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty
-                                      [Alt DEFAULT [] fail]
-
-matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
--- Real true variables, just like in matchVar, SLPJ p 94
--- No binding to do: they'll all be wildcards by now (done in tidy)
-matchVariables (_ :| vars) ty eqns = match vars ty $ NEL.toList $ shiftEqns eqns
-
-matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
-matchBangs (var :| vars) ty eqns
-  = do  { match_result <- match (var:vars) ty $ NEL.toList $
-            decomposeFirstPat getBangPat <$> eqns
-        ; return (mkEvalMatchResult var ty match_result) }
-
-matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
--- Apply the coercion to the match variable and then match that
-matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
-  = do  { let XPat (CoPat co pat _) = firstPat eqn1
-        ; let pat_ty' = hsPatType pat
-        ; var' <- newUniqueId var (idMult var) pat_ty'
-        ; match_result <- match (var':vars) ty $ NEL.toList $
-            decomposeFirstPat getCoPat <$> eqns
-        ; core_wrap <- dsHsWrapper co
-        ; let bind = NonRec var' (core_wrap (Var var))
-        ; return (mkCoLetMatchResult bind match_result) }
-
-matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
--- Apply the view function to the match variable and then match that
-matchView (var :| vars) ty (eqns@(eqn1 :| _))
-  = do  { -- we could pass in the expr from the PgView,
-         -- but this needs to extract the pat anyway
-         -- to figure out the type of the fresh variable
-         let TcViewPat viewExpr pat = firstPat eqn1
-         -- do the rest of the compilation
-        ; let pat_ty' = hsPatType pat
-        ; var' <- newUniqueId var (idMult var) pat_ty'
-        ; match_result <- match (var':vars) ty $ NEL.toList $
-            decomposeFirstPat getViewPat <$> eqns
-         -- compile the view expressions
-        ; viewExpr' <- dsExpr viewExpr
-        ; return (mkViewMatchResult var'
-                    (mkCoreAppDs (text "matchView") viewExpr' (Var var))
-                    match_result) }
-
--- decompose the first pattern and leave the rest alone
-decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
-decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
-        = eqn { eqn_pats = extractpat pat : pats}
-decomposeFirstPat _ _ = panic "decomposeFirstPat"
-
-getCoPat, getBangPat, getViewPat :: Pat GhcTc -> Pat GhcTc
-getCoPat (XPat (CoPat _ pat _)) = pat
-getCoPat _                   = panic "getCoPat"
-getBangPat (BangPat _ pat  ) = unLoc pat
-getBangPat _                 = panic "getBangPat"
-getViewPat (TcViewPat _ pat) = pat
-getViewPat _                 = panic "getViewPat"
-
--- | Use this pattern synonym to match on a 'ViewPat'.
---
--- N.B.: View patterns can occur inside HsExpansions.
-pattern TcViewPat :: HsExpr GhcTc -> Pat GhcTc -> Pat GhcTc
-pattern TcViewPat viewExpr pat <- (getTcViewPat -> (viewExpr, pat))
-
-getTcViewPat :: Pat GhcTc -> (HsExpr GhcTc, Pat GhcTc)
-getTcViewPat (ViewPat _ viewLExpr pat)  = (unLoc viewLExpr, unLoc pat)
-getTcViewPat (XPat (ExpansionPat  _ p)) = getTcViewPat p
-getTcViewPat p = pprPanic "getTcViewPat" (ppr p)
-
-{-
-Note [Empty case alternatives]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The list of EquationInfo can be empty, arising from
-    case x of {}   or    \case {}
-In that situation we desugar to
-    case x of { _ -> error "pattern match failure" }
-The *desugarer* isn't certain whether there really should be no
-alternatives, so it adds a default case, as it always does.  A later
-pass may remove it if it's inaccessible.  (See also Note [Empty case
-alternatives] in GHC.Core.)
-
-We do *not* desugar simply to
-   error "empty case"
-or some such, because 'x' might be bound to (error "hello"), in which
-case we want to see that "hello" exception, not (error "empty case").
-See also the "lifted case" discussion in Note [Case elimination] in GHC.Core.Opt.Simplify.
-
-
-************************************************************************
-*                                                                      *
-                Tidying patterns
-*                                                                      *
-************************************************************************
-
-Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
-which will be scrutinised.
-
-This makes desugaring the pattern match simpler by transforming some of
-the patterns to simpler forms. (Tuples to Constructor Patterns)
-
-Among other things in the resulting Pattern:
-* Variables and irrefutable(lazy) patterns are replaced by Wildcards
-* As patterns are replaced by the patterns they wrap.
-
-The bindings created by the above patterns are put into the returned wrapper
-instead.
-
-This means a definition of the form:
-  f x = rhs
-when called with v get's desugared to the equivalent of:
-  let x = v
-  in
-  f _ = rhs
-
-The same principle holds for as patterns (@) and
-irrefutable/lazy patterns (~).
-In the case of irrefutable patterns the irrefutable pattern is pushed into
-the binding.
-
-Pattern Constructors which only represent syntactic sugar are converted into
-their desugared representation.
-This usually means converting them to Constructor patterns but for some
-depends on enabled extensions. (Eg OverloadedLists)
-
-GHC also tries to convert overloaded Literals into regular ones.
-
-The result of this tidying is that the column of patterns will include
-only these which can be assigned a PatternGroup (see patGroup).
-
--}
-
-tidyEqnInfo :: Id -> EquationInfo
-            -> DsM (DsWrapper, EquationInfo)
-        -- DsM'd because of internal call to dsLHsBinds
-        --      and mkSelectorBinds.
-        -- "tidy1" does the interesting stuff, looking at
-        -- one pattern and fiddling the list of bindings.
-        --
-        -- POST CONDITION: head pattern in the EqnInfo is
-        --      one of these for which patGroup is defined.
-
-tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
-  = panic "tidyEqnInfo"
-
-tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })
-  = do { (wrap, pat') <- tidy1 v orig pat
-       ; return (wrap, eqn { eqn_pats = pat' : pats }) }
-
-tidy1 :: Id                  -- The Id being scrutinised
-      -> Origin              -- Was this a pattern the user wrote?
-      -> Pat GhcTc           -- The pattern against which it is to be matched
-      -> DsM (DsWrapper,     -- Extra bindings to do before the match
-              Pat GhcTc)     -- Equivalent pattern
-
--------------------------------------------------------
---      (pat', mr') = tidy1 v pat mr
--- tidies the *outer level only* of pat, giving pat'
--- It eliminates many pattern forms (as-patterns, variable patterns,
--- list patterns, etc) and returns any created bindings in the wrapper.
-
-tidy1 v o (ParPat _ _ pat _)  = tidy1 v o (unLoc pat)
-tidy1 v o (SigPat _ pat _)    = tidy1 v o (unLoc pat)
-tidy1 _ _ (WildPat ty)        = return (idDsWrapper, WildPat ty)
-tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
-
-        -- case v of { x -> mr[] }
-        -- = case v of { _ -> let x=v in mr[] }
-tidy1 v _ (VarPat _ (L _ var))
-  = return (wrapBind var v, WildPat (idType var))
-
-        -- case v of { x@p -> mr[] }
-        -- = case v of { p -> let x=v in mr[] }
-tidy1 v o (AsPat _ (L _ var) _ pat)
-  = do  { (wrap, pat') <- tidy1 v o (unLoc pat)
-        ; return (wrapBind var v . wrap, pat') }
-
-{- now, here we handle lazy patterns:
-    tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
-                        v2 = case v of p -> v2 : ... : bs )
-
-    where the v_i's are the binders in the pattern.
-
-    ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
-
-    The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
--}
-
-tidy1 v _ (LazyPat _ pat)
-    -- This is a convenient place to check for unlifted types under a lazy pattern.
-    -- Doing this check during type-checking is unsatisfactory because we may
-    -- not fully know the zonked types yet. We sure do here.
-  = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat)
-            -- NB: the binders can't be representation-polymorphic, so we're OK to call isUnliftedType
-        ; unless (null unlifted_bndrs) $
-          putSrcSpanDs (getLocA pat) $
-          diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs)
-
-        ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
-        ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
-        ; return (mkCoreLets sel_binds, WildPat (idType v)) }
-
-tidy1 _ _ (ListPat ty pats)
-  = return (idDsWrapper, unLoc list_ConPat)
-  where
-    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
-                        (mkNilPat ty)
-                        pats
-
-tidy1 _ _ (TuplePat tys pats boxity)
-  = return (idDsWrapper, unLoc tuple_ConPat)
-  where
-    arity = length pats
-    tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys'
-    tys' = case boxity of
-             Unboxed -> map getRuntimeRep tys ++ tys
-             Boxed   -> tys
-           -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
-
-tidy1 _ _ (SumPat tys pat alt arity)
-  = return (idDsWrapper, unLoc sum_ConPat)
-  where
-    sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] (map getRuntimeRep tys ++ tys)
-                 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
-
--- LitPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ o (LitPat _ lit)
-  = do { unless (isGenerated o) $
-           warnAboutOverflowedLit lit
-       ; return (idDsWrapper, tidyLitPat lit) }
-
--- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)
-  = do { unless (isGenerated o) $
-           let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
-                    | otherwise = lit
-           in warnAboutOverflowedOverLit lit'
-       ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
-
--- NPlusKPat: we may want to warn about the literals
-tidy1 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)
-  = do { unless (isGenerated o) $ do
-           warnAboutOverflowedOverLit lit1
-           warnAboutOverflowedOverLit lit2
-       ; return (idDsWrapper, n) }
-
--- Everything else goes through unchanged...
-tidy1 _ _ non_interesting_pat
-  = return (idDsWrapper, non_interesting_pat)
-
---------------------
-tidy_bang_pat :: Id -> Origin -> SrcSpanAnnA -> Pat GhcTc
-              -> DsM (DsWrapper, Pat GhcTc)
-
--- Discard par/sig under a bang
-tidy_bang_pat v o _ (ParPat _ _ (L l p) _) = tidy_bang_pat v o l p
-tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p
-
--- Push the bang-pattern inwards, in the hope that
--- it may disappear next time
-tidy_bang_pat v o l (AsPat x v' at p)
-  = tidy1 v o (AsPat x v' at (L l (BangPat noExtField p)))
-tidy_bang_pat v o l (XPat (CoPat w p t))
-  = tidy1 v o (XPat $ CoPat w (BangPat noExtField (L l p)) t)
-
--- Discard bang around strict pattern
-tidy_bang_pat v o _ p@(LitPat {})    = tidy1 v o p
-tidy_bang_pat v o _ p@(ListPat {})   = tidy1 v o p
-tidy_bang_pat v o _ p@(TuplePat {})  = tidy1 v o p
-tidy_bang_pat v o _ p@(SumPat {})    = tidy1 v o p
-
--- Data/newtype constructors
-tidy_bang_pat v o l p@(ConPat { pat_con = L _ (RealDataCon dc)
-                              , pat_args = args
-                              , pat_con_ext = ConPatTc
-                                { cpt_arg_tys = arg_tys
-                                }
-                              })
-  -- Newtypes: push bang inwards (#9844)
-  =
-    if isNewTyCon (dataConTyCon dc)
-      then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })
-      else tidy1 v o p  -- Data types: discard the bang
-    where
-      (ty:_) = dataConInstArgTys dc arg_tys
-
--------------------
--- Default case, leave the bang there:
---    VarPat,
---    LazyPat,
---    WildPat,
---    ViewPat,
---    pattern synonyms (ConPatOut with PatSynCon)
---    NPat,
---    NPlusKPat
---
--- For LazyPat, remember that it's semantically like a VarPat
---  i.e.  !(~p) is not like ~p, or p!  (#8952)
---
--- NB: SigPatIn, ConPatIn should not happen
-
-tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p))
-
--------------------
-push_bang_into_newtype_arg :: SrcSpanAnnA
-                           -> Type -- The type of the argument we are pushing
-                                   -- onto
-                           -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
--- See Note [Bang patterns and newtypes]
--- We are transforming   !(N p)   into   (N !p)
-push_bang_into_newtype_arg l _ty (PrefixCon ts (arg:args))
-  = assert (null args) $
-    PrefixCon ts [L l (BangPat noExtField arg)]
-push_bang_into_newtype_arg l _ty (RecCon rf)
-  | HsRecFields { rec_flds = L lf fld : flds } <- rf
-  , HsFieldBind { hfbRHS = arg } <- fld
-  = assert (null flds) $
-    RecCon (rf { rec_flds = [L lf (fld { hfbRHS
-                                           = L l (BangPat noExtField arg) })] })
-push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
-  | HsRecFields { rec_flds = [] } <- rf
-  = PrefixCon [] [L l (BangPat noExtField (noLocA (WildPat ty)))]
-push_bang_into_newtype_arg _ _ cd
-  = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
-
-{-
-Note [Bang patterns and newtypes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For the pattern  !(Just pat)  we can discard the bang, because
-the pattern is strict anyway. But for !(N pat), where
-  newtype NT = N Int
-we definitely can't discard the bang.  #9844.
-
-So what we do is to push the bang inwards, in the hope that it will
-get discarded there.  So we transform
-   !(N pat)   into    (N !pat)
-
-But what if there is nothing to push the bang onto? In at least one instance
-a user has written !(N {}) which we translate into (N !_). See #13215
-
-
-\noindent
-{\bf Previous @matchTwiddled@ stuff:}
-
-Now we get to the only interesting part; note: there are choices for
-translation [from Simon's notes]; translation~1:
-\begin{verbatim}
-deTwiddle [s,t] e
-\end{verbatim}
-returns
-\begin{verbatim}
-[ w = e,
-  s = case w of [s,t] -> s
-  t = case w of [s,t] -> t
-]
-\end{verbatim}
-
-Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
-evaluation of \tr{e}.  An alternative translation (No.~2):
-\begin{verbatim}
-[ w = case e of [s,t] -> (s,t)
-  s = case w of (s,t) -> s
-  t = case w of (s,t) -> t
-]
-\end{verbatim}
-
-************************************************************************
-*                                                                      *
-\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
-*                                                                      *
-************************************************************************
-
-We might be able to optimise unmixing when confronted by
-only-one-constructor-possible, of which tuples are the most notable
-examples.  Consider:
-\begin{verbatim}
-f (a,b,c) ... = ...
-f d ... (e:f) = ...
-f (g,h,i) ... = ...
-f j ...       = ...
-\end{verbatim}
-This definition would normally be unmixed into four equation blocks,
-one per equation.  But it could be unmixed into just one equation
-block, because if the one equation matches (on the first column),
-the others certainly will.
-
-You have to be careful, though; the example
-\begin{verbatim}
-f j ...       = ...
--------------------
-f (a,b,c) ... = ...
-f d ... (e:f) = ...
-f (g,h,i) ... = ...
-\end{verbatim}
-{\em must} be broken into two blocks at the line shown; otherwise, you
-are forcing unnecessary evaluation.  In any case, the top-left pattern
-always gives the cue.  You could then unmix blocks into groups of...
-\begin{description}
-\item[all variables:]
-As it is now.
-\item[constructors or variables (mixed):]
-Need to make sure the right names get bound for the variable patterns.
-\item[literals or variables (mixed):]
-Presumably just a variant on the constructor case (as it is now).
-\end{description}
-
-************************************************************************
-*                                                                      *
-*  matchWrapper: a convenient way to call @match@                      *
-*                                                                      *
-************************************************************************
-\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
-
-Calls to @match@ often involve similar (non-trivial) work; that work
-is collected here, in @matchWrapper@.  This function takes as
-arguments:
-\begin{itemize}
-\item
-Typechecked @Matches@ (of a function definition, or a case or lambda
-expression)---the main input;
-\item
-An error message to be inserted into any (runtime) pattern-matching
-failure messages.
-\end{itemize}
-
-As results, @matchWrapper@ produces:
-\begin{itemize}
-\item
-A list of variables (@Locals@) that the caller must ``promise'' to
-bind to appropriate values; and
-\item
-a @CoreExpr@, the desugared output (main result).
-\end{itemize}
-
-The main actions of @matchWrapper@ include:
-\begin{enumerate}
-\item
-Flatten the @[TypecheckedMatch]@ into a suitable list of
-@EquationInfo@s.
-\item
-Create as many new variables as there are patterns in a pattern-list
-(in any one of the @EquationInfo@s).
-\item
-Create a suitable ``if it fails'' expression---a call to @error@ using
-the error-string input; the {\em type} of this fail value can be found
-by examining one of the RHS expressions in one of the @EquationInfo@s.
-\item
-Call @match@ with all of this information!
-\end{enumerate}
--}
-
--- Note [matchWrapper scrutinees]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- There are three possible cases for matchWrapper's scrutinees argument:
---
--- 1. Nothing   Used for FunBind, HsLam, HsLamcase, where there is no explicit scrutinee
---              The MatchGroup may have matchGroupArity of 0 or more. Examples:
---                  f p1 q1 = ... -- matchGroupArity 2
---                  f p2 q2 = ...
---
---                  \cases | g1 -> ... -- matchGroupArity 0
---                         | g2 -> ...
---
--- 2. Just [e]  Used for HsCase, RecordUpd; exactly one scrutinee
---              The MatchGroup has matchGroupArity of exactly 1. Example:
---                  case e of p1 -> e1 -- matchGroupArity 1
---                            p2 -> e2
---
--- 3. Just es   Used for HsCmdLamCase; zero or more scrutinees
---              The MatchGroup has matchGroupArity of (length es). Example:
---                  \cases p1 q1 -> returnA -< ... -- matchGroupArity 2
---                         p2 q2 -> ...
-
-matchWrapper
-  :: HsMatchContext GhcRn              -- ^ For shadowing warning messages
-  -> Maybe [LHsExpr GhcTc]             -- ^ Scrutinee(s)
-                                       -- see Note [matchWrapper scrutinees]
-  -> MatchGroup GhcTc (LHsExpr GhcTc)  -- ^ Matches being desugared
-  -> DsM ([Id], CoreExpr)              -- ^ Results (usually passed to 'match')
-
-{-
- There is one small problem with the Lambda Patterns, when somebody
- writes something similar to:
-\begin{verbatim}
-    (\ (x:xs) -> ...)
-\end{verbatim}
- he/she don't want a warning about incomplete patterns, that is done with
- the flag @opt_WarnSimplePatterns@.
- This problem also appears in the:
-\begin{itemize}
-\item @do@ patterns, but if the @do@ can fail
-      it creates another equation if the match can fail
-      (see @GHC.HsToCore.Expr.doDo@ function)
-\item @let@ patterns, are treated by @matchSimply@
-   List Comprehension Patterns, are treated by @matchSimply@ also
-\end{itemize}
-
-We can't call @matchSimply@ with Lambda patterns,
-due to the fact that lambda patterns can have more than
-one pattern, and match simply only accepts one pattern.
-
-JJQC 30-Nov-1997
--}
-
-matchWrapper ctxt scrs (MG { mg_alts = L _ matches
-                           , mg_ext = MatchGroupTc arg_tys rhs_ty origin
-                           })
-  = do  { dflags <- getDynFlags
-        ; locn   <- getSrcSpanDs
-
-        ; new_vars    <- case matches of
-                           []    -> newSysLocalsDs arg_tys
-                           (m:_) ->
-                            selectMatchVars (zipWithEqual "matchWrapper"
-                                              (\a b -> (scaledMult a, unLoc b))
-                                                arg_tys
-                                                (hsLMatchPats m))
-
-        -- Pattern match check warnings for /this match-group/.
-        -- @rhss_nablas@ is a flat list of covered Nablas for each RHS.
-        -- Each Match will split off one Nablas for its RHSs from this.
-        ; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt
-            then addHsScrutTmCs (concat scrs) new_vars $
-                 -- See Note [Long-distance information]
-                 pmcMatches (DsMatchContext ctxt locn) new_vars matches
-            else pure (initNablasMatches matches)
-
-        ; eqns_info   <- zipWithM mk_eqn_info matches matches_nablas
-
-        ; result_expr <- handleWarnings $
-                         matchEquations ctxt new_vars eqns_info rhs_ty
-        ; return (new_vars, result_expr) }
-  where
-    -- Called once per equation in the match, or alternative in the case
-    mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Nablas, NonEmpty Nablas) -> DsM EquationInfo
-    mk_eqn_info (L _ (Match { m_pats = pats, m_grhss = grhss })) (pat_nablas, rhss_nablas)
-      = do { dflags <- getDynFlags
-           ; let upats = map (unLoc . decideBangHood dflags) pats
-           -- pat_nablas is the covered set *after* matching the pattern, but
-           -- before any of the GRHSs. We extend the environment with pat_nablas
-           -- (via updPmNablas) so that the where-clause of 'grhss' can profit
-           -- from that knowledge (#18533)
-           ; match_result <- updPmNablas pat_nablas $
-                             dsGRHSs ctxt grhss rhs_ty rhss_nablas
-           ; return EqnInfo { eqn_pats = upats
-                            , eqn_orig = FromSource
-                            , eqn_rhs  = match_result } }
-
-    handleWarnings = if isGenerated origin
-                     then discardWarningsDs
-                     else id
-
-    initNablasMatches :: [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]
-    initNablasMatches ms
-      = map (\(L _ m) -> (initNablas, initNablasGRHSs (m_grhss m))) ms
-
-    initNablasGRHSs :: GRHSs GhcTc b -> NonEmpty Nablas
-    initNablasGRHSs m = expectJust "GRHSs non-empty"
-                      $ NEL.nonEmpty
-                      $ replicate (length (grhssGRHSs m)) initNablas
-
-
-matchEquations  :: HsMatchContext GhcRn
-                -> [MatchId] -> [EquationInfo] -> Type
-                -> DsM CoreExpr
-matchEquations ctxt vars eqns_info rhs_ty
-  = do  { match_result <- match vars rhs_ty eqns_info
-
-        ; fail_expr <- mkFailExpr ctxt rhs_ty
-
-        ; extractMatchResult match_result fail_expr }
-
--- | @matchSimply@ is a wrapper for 'match' which deals with the
--- situation where we want to match a single expression against a single
--- pattern. It returns an expression.
-matchSimply :: CoreExpr                 -- ^ Scrutinee
-            -> HsMatchContext GhcRn     -- ^ Match kind
-            -> LPat GhcTc               -- ^ Pattern it should match
-            -> CoreExpr                 -- ^ Return this if it matches
-            -> CoreExpr                 -- ^ Return this if it doesn't
-            -> DsM CoreExpr
--- Some reasons 'matchSimply' is not defined using 'matchWrapper' (#18572):
---   * Some call sites like in 'deBindComp' specify a @fail_expr@ that isn't a
---     straight @patError@
---   * It receives an already desugared 'CoreExpr' for the scrutinee, not an
---     'HsExpr' like 'matchWrapper' expects
---   * Filling in all the phony fields for the 'MatchGroup' for a single pattern
---     match is awkward
---   * And we still export 'matchSinglePatVar', so not much is gained if we
---     don't also implement it in terms of 'matchWrapper'
-matchSimply scrut hs_ctx pat result_expr fail_expr = do
-    let
-      match_result = cantFailMatchResult result_expr
-      rhs_ty       = exprType fail_expr
-        -- Use exprType of fail_expr, because won't refine in the case of failure!
-    match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
-    extractMatchResult match_result' fail_expr
-
-matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc
-               -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
--- matchSinglePat ensures that the scrutinee is a variable
--- and then calls matchSinglePatVar
---
--- matchSinglePat does not warn about incomplete patterns
--- Used for things like [ e | pat <- stuff ], where
--- incomplete patterns are just fine
-
-matchSinglePat (Var var) ctx pat ty match_result
-  | not (isExternalName (idName var))
-  = matchSinglePatVar var Nothing ctx pat ty match_result
-
-matchSinglePat scrut hs_ctx pat ty match_result
-  = do { var           <- selectSimpleMatchVarL ManyTy pat
-                            -- matchSinglePat is only used in matchSimply, which
-                            -- is used in list comprehension, arrow notation,
-                            -- and to create field selectors. All of which only
-                            -- bind unrestricted variables, hence the 'Many'
-                            -- above.
-       ; match_result' <- matchSinglePatVar var (Just scrut) hs_ctx pat ty match_result
-       ; return $ bindNonRec var scrut <$> match_result'
-       }
-
-matchSinglePatVar :: Id   -- See Note [Match Ids]
-                  -> Maybe CoreExpr -- ^ The scrutinee the match id is bound to
-                  -> HsMatchContext GhcRn -> LPat GhcTc
-                  -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)
-matchSinglePatVar var mb_scrut ctx pat ty match_result
-  = assertPpr (isInternalName (idName var)) (ppr var) $
-    do { dflags <- getDynFlags
-       ; locn   <- getSrcSpanDs
-       -- Pattern match check warnings
-       ; when (isMatchContextPmChecked dflags FromSource ctx) $
-           addCoreScrutTmCs (maybeToList mb_scrut) [var] $
-           pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)
-
-       ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
-                                , eqn_orig = FromSource
-                                , eqn_rhs  = match_result }
-       ; match [var] ty [eqn_info] }
-
-
-{-
-************************************************************************
-*                                                                      *
-                Pattern classification
-*                                                                      *
-************************************************************************
--}
-
-data PatGroup
-  = PgAny               -- Immediate match: variables, wildcards,
-                        --                  lazy patterns
-  | PgCon DataCon       -- Constructor patterns (incl list, tuple)
-  | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]
-  | PgLit Literal       -- Literal patterns
-  | PgN   FractionalLit -- Overloaded numeric literals;
-                        -- see Note [Don't use Literal for PgN]
-  | PgOverS FastString  -- Overloaded string literals
-  | PgNpK Integer       -- n+k patterns
-  | PgBang              -- Bang patterns
-  | PgCo Type           -- Coercion patterns; the type is the type
-                        --      of the pattern *inside*
-  | PgView (LHsExpr GhcTc) -- view pattern (e -> p):
-                        -- the LHsExpr is the expression e
-           Type         -- the Type is the type of p (equivalently, the result type of e)
-
-{- Note [Don't use Literal for PgN]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Previously we had, as PatGroup constructors
-
-  | ...
-  | PgN   Literal       -- Overloaded literals
-  | PgNpK Literal       -- n+k patterns
-  | ...
-
-But Literal is really supposed to represent an *unboxed* literal, like Int#.
-We were sticking the literal from, say, an overloaded numeric literal pattern
-into a LitInt constructor. This didn't really make sense; and we now have
-the invariant that value in a LitInt must be in the range of the target
-machine's Int# type, and an overloaded literal could meaningfully be larger.
-
-Solution: For pattern grouping purposes, just store the literal directly in
-the PgN constructor as a FractionalLit if numeric, and add a PgOverStr constructor
-for overloaded strings.
--}
-
-groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]
--- If the result is of form [g1, g2, g3],
--- (a) all the (pg,eq) pairs in g1 have the same pg
--- (b) none of the gi are empty
--- The ordering of equations is unchanged
-groupEquations platform eqns
-  = NEL.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]
-  -- comprehension on NonEmpty
-  where
-    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
-    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
-
--- TODO Make subGroup1 using a NonEmptyMap
-subGroup :: (m -> [NonEmpty EquationInfo]) -- Map.elems
-         -> m -- Map.empty
-         -> (a -> m -> Maybe (NonEmpty EquationInfo)) -- Map.lookup
-         -> (a -> NonEmpty EquationInfo -> m -> m) -- Map.insert
-         -> [(a, EquationInfo)] -> [NonEmpty EquationInfo]
--- Input is a particular group.  The result sub-groups the
--- equations by with particular constructor, literal etc they match.
--- Each sub-list in the result has the same PatGroup
--- See Note [Take care with pattern order]
--- Parameterized by map operations to allow different implementations
--- and constraints, eg. types without Ord instance.
-subGroup elems empty lookup insert group
-    = fmap NEL.reverse $ elems $ foldl' accumulate empty group
-  where
-    accumulate pg_map (pg, eqn)
-      = case lookup pg pg_map of
-          Just eqns -> insert pg (NEL.cons eqn eqns) pg_map
-          Nothing   -> insert pg [eqn] pg_map
-    -- pg_map :: Map a [EquationInfo]
-    -- Equations seen so far in reverse order of appearance
-
-subGroupOrd :: Ord a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
-subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert
-
-subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [NonEmpty EquationInfo]
-subGroupUniq =
-  subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v)
-
-{- Note [Pattern synonym groups]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we see
-  f (P a) = e1
-  f (P b) = e2
-    ...
-where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the
-same group?  We can if P is a constructor, but /not/ if P is a pattern synonym.
-Consider (#11224)
-   -- readMaybe :: Read a => String -> Maybe a
-   pattern PRead :: Read a => () => a -> String
-   pattern PRead a <- (readMaybe -> Just a)
-
-   f (PRead (x::Int))  = e1
-   f (PRead (y::Bool)) = e2
-This is all fine: we match the string by trying to read an Int; if that
-fails we try to read a Bool. But clearly we can't combine the two into a single
-match.
-
-Conclusion: we can combine when we invoke PRead /at the same type/.  Hence
-in PgSyn we record the instantiating types, and use them in sameGroup.
-
-Note [Take care with pattern order]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In the subGroup function we must be very careful about pattern re-ordering,
-Consider the patterns [ (True, Nothing), (False, x), (True, y) ]
-Then in bringing together the patterns for True, we must not
-swap the Nothing and y!
--}
-
-sameGroup :: PatGroup -> PatGroup -> Bool
--- Same group means that a single case expression
--- or test will suffice to match both, *and* the order
--- of testing within the group is insignificant.
-sameGroup PgAny         PgAny         = True
-sameGroup PgBang        PgBang        = True
-sameGroup (PgCon _)     (PgCon _)     = True    -- One case expression
-sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2
-                                                -- eqTypes: See Note [Pattern synonym groups]
-sameGroup (PgLit _)     (PgLit _)     = True    -- One case expression
-sameGroup (PgN l1)      (PgN l2)      = l1==l2  -- Order is significant
-        -- Order is significant, match PgN after PgLit
-        -- If the exponents are small check for value equality rather than syntactic equality
-        -- This is implemented in the Eq instance for FractionalLit, we do this to avoid
-        -- computing the value of excessively large rationals.
-sameGroup (PgOverS s1)  (PgOverS s2)  = s1==s2
-sameGroup (PgNpK l1)    (PgNpK l2)    = l1==l2  -- See Note [Grouping overloaded literal patterns]
-sameGroup (PgCo t1)     (PgCo t2)     = t1 `eqType` t2
-        -- CoPats are in the same group only if the type of the
-        -- enclosed pattern is the same. The patterns outside the CoPat
-        -- always have the same type, so this boils down to saying that
-        -- the two coercions are identical.
-sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
-       -- ViewPats are in the same group iff the expressions
-       -- are "equal"---conservatively, we use syntactic equality
-sameGroup _          _          = False
-
--- An approximation of syntactic equality used for determining when view
--- exprs are in the same group.
--- This function can always safely return false;
--- but doing so will result in the application of the view function being repeated.
---
--- Currently: compare applications of literals and variables
---            and anything else that we can do without involving other
---            HsSyn types in the recursion
---
--- NB we can't assume that the two view expressions have the same type.  Consider
---   f (e1 -> True) = ...
---   f (e2 -> "hi") = ...
-viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool
-viewLExprEq (e1,_) (e2,_) = lexp e1 e2
-  where
-    lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
-    lexp e e' = exp (unLoc e) (unLoc e')
-
-    ---------
-    exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
-    -- real comparison is on HsExpr's
-    -- strip parens
-    exp (HsPar _ _ (L _ e) _) e' = exp e e'
-    exp e (HsPar _ _ (L _ e') _) = exp e e'
-    -- because the expressions do not necessarily have the same type,
-    -- we have to compare the wrappers
-    exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap  h' e'))) =
-      wrap h h' && exp e e'
-    exp (XExpr (ExpansionExpr (HsExpanded _ b))) (XExpr (ExpansionExpr (HsExpanded _ b'))) =
-      exp b b'
-    exp (HsVar _ i) (HsVar _ i') =  i == i'
-    exp (XExpr (ConLikeTc c _ _)) (XExpr (ConLikeTc c' _ _)) = c == c'
-    -- the instance for IPName derives using the id, so this works if the
-    -- above does
-    exp (HsIPVar _ i) (HsIPVar _ i') = i == i'
-    exp (HsOverLit _ l) (HsOverLit _ l') =
-        -- Overloaded lits are equal if they have the same type
-        -- and the data is the same.
-        -- this is coarser than comparing the SyntaxExpr's in l and l',
-        -- which resolve the overloading (e.g., fromInteger 1),
-        -- because these expressions get written as a bunch of different variables
-        -- (presumably to improve sharing)
-        eqType (overLitType l) (overLitType l') && l == l'
-    exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
-    -- the fixities have been straightened out by now, so it's safe
-    -- to ignore them?
-    exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
-        lexp l l' && lexp o o' && lexp ri ri'
-    exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
-    exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
-        lexp e1 e1' && lexp e2 e2'
-    exp (SectionR _ e1 e2) (SectionR _ e1' e2') =
-        lexp e1 e1' && lexp e2 e2'
-    exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) =
-        eq_list tup_arg es1 es2
-    exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'
-    exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
-        lexp e e' && lexp e1 e1' && lexp e2 e2'
-
-    -- Enhancement: could implement equality for more expressions
-    --   if it seems useful
-    -- But no need for HsLit, ExplicitList, ExplicitTuple,
-    -- because they cannot be functions
-    exp _ _  = False
-
-    ---------
-    syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool
-    syn_exp (SyntaxExprTc { syn_expr      = expr1
-                          , syn_arg_wraps = arg_wraps1
-                          , syn_res_wrap  = res_wrap1 })
-            (SyntaxExprTc { syn_expr      = expr2
-                          , syn_arg_wraps = arg_wraps2
-                          , syn_res_wrap  = res_wrap2 })
-      = exp expr1 expr2 &&
-        and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&
-        wrap res_wrap1 res_wrap2
-    syn_exp NoSyntaxExprTc NoSyntaxExprTc = True
-    syn_exp _              _              = False
-
-    ---------
-    tup_arg (Present _ e1)           (Present _ e2)         = lexp e1 e2
-    tup_arg (Missing (Scaled _ t1)) (Missing (Scaled _ t2)) = eqType t1 t2
-    tup_arg _ _ = False
-
-    ---------
-    wrap :: HsWrapper -> HsWrapper -> Bool
-    -- Conservative, in that it demands that wrappers be
-    -- syntactically identical and doesn't look under binders
-    --
-    -- Coarser notions of equality are possible
-    -- (e.g., reassociating compositions,
-    --        equating different ways of writing a coercion)
-    wrap WpHole WpHole = True
-    wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
-    wrap (WpFun w1 w2 _)   (WpFun w1' w2' _)   = wrap w1 w1' && wrap w2 w2'
-    wrap (WpCast co)       (WpCast co')        = co `eqCoercion` co'
-    wrap (WpEvApp et1)     (WpEvApp et2)       = et1 `ev_term` et2
-    wrap (WpTyApp t)       (WpTyApp t')        = eqType t t'
-    -- Enhancement: could implement equality for more wrappers
-    --   if it seems useful (lams and lets)
-    wrap _ _ = False
-
-    ---------
-    ev_term :: EvTerm -> EvTerm -> Bool
-    ev_term (EvExpr (Var a)) (EvExpr  (Var b))
-      = idType a `eqType` idType b
-        -- The /type/ of the evidence matters, not its precise proof term.
-        -- Caveat: conceivably a sufficiently exotic use of incoherent instances
-        -- could make a difference, but remember this is only used within the
-        -- pattern matches for a single function, so it's hard to see how that
-        -- could really happen.  And we don't want accidentally different proofs
-        -- to prevent spotting equalities, and hence degrade pattern-match
-        -- overlap checking.
-    ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b))
-      = a `eqCoercion` b
-    ev_term _ _ = False
-
-    ---------
-    eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
-    eq_list _  []     []     = True
-    eq_list _  []     (_:_)  = False
-    eq_list _  (_:_)  []     = False
-    eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
-
-patGroup :: Platform -> Pat GhcTc -> PatGroup
-patGroup _ (ConPat { pat_con = L _ con
-                   , pat_con_ext = ConPatTc { cpt_arg_tys = tys }
-                   })
- | RealDataCon dcon <- con              = PgCon dcon
- | PatSynCon psyn <- con                = PgSyn psyn tys
-patGroup _ (WildPat {})                 = PgAny
-patGroup _ (BangPat {})                 = PgBang
-patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) =
-  case (oval, isJust mb_neg) of
-    (HsIntegral   i, is_neg) -> PgN (integralFractionalLit is_neg (if is_neg
-                                                                    then negate (il_value i)
-                                                                    else il_value i))
-    (HsFractional f, is_neg)
-      | is_neg    -> PgN $! negateFractionalLit f
-      | otherwise -> PgN f
-    (HsIsString _ s, _) -> assert (isNothing mb_neg) $
-                            PgOverS s
-patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =
-  case oval of
-   HsIntegral i -> PgNpK (il_value i)
-   _ -> pprPanic "patGroup NPlusKPat" (ppr oval)
-patGroup _ (ViewPat _ expr p)           = PgView expr (hsPatType (unLoc p))
-patGroup platform (LitPat _ lit)        = PgLit (hsLitKey platform lit)
-patGroup platform (XPat ext) = case ext of
-  CoPat _ p _      -> PgCo (hsPatType p) -- Type of innelexp pattern
-  ExpansionPat _ p -> patGroup platform p
-patGroup _ pat                          = pprPanic "patGroup" (ppr pat)
-
-{-
-Note [Grouping overloaded literal patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-WATCH OUT!  Consider
-
-        f (n+1) = ...
-        f (n+2) = ...
-        f (n+1) = ...
-
-We can't group the first and third together, because the second may match
-the same thing as the first.  Same goes for *overloaded* literal patterns
-        f 1 True = ...
-        f 2 False = ...
-        f 1 False = ...
-If the first arg matches '1' but the second does not match 'True', we
-cannot jump to the third equation!  Because the same argument might
-match '2'!
-Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
--}
diff --git a/compiler/GHC/HsToCore/Match.hs-boot b/compiler/GHC/HsToCore/Match.hs-boot
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Match.hs-boot
+++ /dev/null
@@ -1,37 +0,0 @@
-module GHC.HsToCore.Match where
-
-import GHC.Prelude
-import GHC.Types.Var ( Id )
-import GHC.Tc.Utils.TcType  ( Type )
-import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult )
-import GHC.Core ( CoreExpr )
-import GHC.Hs   ( LPat, HsMatchContext, MatchGroup, LHsExpr )
-import GHC.Hs.Extension ( GhcTc, GhcRn )
-
-match   :: [Id]
-        -> Type
-        -> [EquationInfo]
-        -> DsM (MatchResult CoreExpr)
-
-matchWrapper
-        :: HsMatchContext GhcRn
-        -> Maybe [LHsExpr GhcTc]
-        -> MatchGroup GhcTc (LHsExpr GhcTc)
-        -> DsM ([Id], CoreExpr)
-
-matchSimply
-        :: CoreExpr
-        -> HsMatchContext GhcRn
-        -> LPat GhcTc
-        -> CoreExpr
-        -> CoreExpr
-        -> DsM CoreExpr
-
-matchSinglePatVar
-        :: Id
-        -> Maybe CoreExpr
-        -> HsMatchContext GhcRn
-        -> LPat GhcTc
-        -> Type
-        -> MatchResult CoreExpr
-        -> DsM (MatchResult CoreExpr)
diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Match/Constructor.hs
+++ /dev/null
@@ -1,296 +0,0 @@
-
-{-# LANGUAGE TypeFamilies #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Pattern-matching constructors
--}
-
-module GHC.HsToCore.Match.Constructor ( matchConFamily, matchPatSyn ) where
-
-import GHC.Prelude
-
-import {-# SOURCE #-} GHC.HsToCore.Match ( match )
-
-import GHC.Hs
-import GHC.HsToCore.Binds
-import GHC.Core.ConLike
-import GHC.Types.Basic ( Origin(..) )
-import GHC.Tc.Utils.TcType
-import GHC.Core.Multiplicity
-import GHC.HsToCore.Monad
-import GHC.HsToCore.Utils
-import GHC.Core ( CoreExpr )
-import GHC.Core.Make ( mkCoreLets )
-import GHC.Utils.Misc
-import GHC.Types.Id
-import GHC.Types.Name.Env
-import GHC.Types.FieldLabel ( flSelector )
-import GHC.Types.SrcLoc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import Control.Monad(liftM)
-import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NE
-
-{-
-We are confronted with the first column of patterns in a set of
-equations, all beginning with constructors from one ``family'' (e.g.,
-@[]@ and @:@ make up the @List@ ``family'').  We want to generate the
-alternatives for a @Case@ expression.  There are several choices:
-\begin{enumerate}
-\item
-Generate an alternative for every constructor in the family, whether
-they are used in this set of equations or not; this is what the Wadler
-chapter does.
-\begin{description}
-\item[Advantages:]
-(a)~Simple.  (b)~It may also be that large sparsely-used constructor
-families are mainly handled by the code for literals.
-\item[Disadvantages:]
-(a)~Not practical for large sparsely-used constructor families, e.g.,
-the ASCII character set.  (b)~Have to look up a list of what
-constructors make up the whole family.
-\end{description}
-
-\item
-Generate an alternative for each constructor used, then add a default
-alternative in case some constructors in the family weren't used.
-\begin{description}
-\item[Advantages:]
-(a)~Alternatives aren't generated for unused constructors.  (b)~The
-STG is quite happy with defaults.  (c)~No lookup in an environment needed.
-\item[Disadvantages:]
-(a)~A spurious default alternative may be generated.
-\end{description}
-
-\item
-``Do it right:'' generate an alternative for each constructor used,
-and add a default alternative if all constructors in the family
-weren't used.
-\begin{description}
-\item[Advantages:]
-(a)~You will get cases with only one alternative (and no default),
-which should be amenable to optimisation.  Tuples are a common example.
-\item[Disadvantages:]
-(b)~Have to look up constructor families in TDE (as above).
-\end{description}
-\end{enumerate}
-
-We are implementing the ``do-it-right'' option for now.  The arguments
-to @matchConFamily@ are the same as to @match@; the extra @Int@
-returned is the number of constructors in the family.
-
-The function @matchConFamily@ is concerned with this
-have-we-used-all-the-constructors? question; the local function
-@match_cons_used@ does all the real work.
--}
-
-matchConFamily :: NonEmpty Id
-               -> Type
-               -> NonEmpty (NonEmpty EquationInfo)
-               -> DsM (MatchResult CoreExpr)
--- Each group of eqns is for a single constructor
-matchConFamily (var :| vars) ty groups
-  = do let mult = idMult var
-           -- Each variable in the argument list correspond to one column in the
-           -- pattern matching equations. Its multiplicity is the context
-           -- multiplicity of the pattern. We extract that multiplicity, so that
-           -- 'matchOneconLike' knows the context multiplicity, in case it needs
-           -- to come up with new variables.
-       alts <- mapM (fmap toRealAlt . matchOneConLike vars ty mult) groups
-       return (mkCoAlgCaseMatchResult var ty alts)
-  where
-    toRealAlt alt = case alt_pat alt of
-        RealDataCon dcon -> alt{ alt_pat = dcon }
-        _ -> panic "matchConFamily: not RealDataCon"
-
-matchPatSyn :: NonEmpty Id
-            -> Type
-            -> NonEmpty EquationInfo
-            -> DsM (MatchResult CoreExpr)
-matchPatSyn (var :| vars) ty eqns
-  = do let mult = idMult var
-       alt <- fmap toSynAlt $ matchOneConLike vars ty mult eqns
-       return (mkCoSynCaseMatchResult var ty alt)
-  where
-    toSynAlt alt = case alt_pat alt of
-        PatSynCon psyn -> alt{ alt_pat = psyn }
-        _ -> panic "matchPatSyn: not PatSynCon"
-
-type ConArgPats = HsConPatDetails GhcTc
-
-matchOneConLike :: [Id]
-                -> Type
-                -> Mult
-                -> NonEmpty EquationInfo
-                -> DsM (CaseAlt ConLike)
-matchOneConLike vars ty mult (eqn1 :| eqns)   -- All eqns for a single constructor
-  = do  { let inst_tys = assert (all tcIsTcTyVar ex_tvs) $
-                           -- ex_tvs can only be tyvars as data types in source
-                           -- Haskell cannot mention covar yet (Aug 2018).
-                         assert (tvs1 `equalLength` ex_tvs) $
-                         arg_tys ++ mkTyVarTys tvs1
-
-              val_arg_tys = conLikeInstOrigArgTys con1 inst_tys
-        -- dataConInstOrigArgTys takes the univ and existential tyvars
-        -- and returns the types of the *value* args, which is what we want
-
-              match_group :: [Id]
-                          -> NonEmpty (ConArgPats, EquationInfo)
-                          -> DsM (MatchResult CoreExpr)
-              -- All members of the group have compatible ConArgPats
-              match_group arg_vars arg_eqn_prs
-                = do { (wraps, eqns') <- liftM NE.unzip (mapM shift arg_eqn_prs)
-                     ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
-                     ; match_result <- match (group_arg_vars ++ vars) ty (NE.toList eqns')
-                     ; return $ foldr1 (.) wraps <$> match_result
-                     }
-
-              shift (_, eqn@(EqnInfo
-                             { eqn_pats = ConPat
-                               { pat_args = args
-                               , pat_con_ext = ConPatTc
-                                 { cpt_tvs = tvs
-                                 , cpt_dicts = ds
-                                 , cpt_binds = bind
-                                 }
-                               } : pats
-                             }))
-                = do ds_bind <- dsTcEvBinds bind
-                     return ( wrapBinds (tvs `zip` tvs1)
-                            . wrapBinds (ds  `zip` dicts1)
-                            . mkCoreLets ds_bind
-                            , eqn { eqn_orig = Generated
-                                  , eqn_pats = conArgPats val_arg_tys args ++ pats }
-                            )
-              shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
-        ; let scaled_arg_tys = map (scaleScaled mult) val_arg_tys
-            -- The 'val_arg_tys' are taken from the data type definition, they
-            -- do not take into account the context multiplicity, therefore we
-            -- need to scale them back to get the correct context multiplicity
-            -- to desugar the sub-pattern in each field. We need to know these
-            -- multiplicity because of the invariant that, in Core, binders in a
-            -- constructor pattern must be scaled by the multiplicity of the
-            -- case. See Note [Case expression invariants].
-        ; arg_vars <- selectConMatchVars scaled_arg_tys args1
-                -- Use the first equation as a source of
-                -- suggestions for the new variables
-
-        -- Divide into sub-groups; see Note [Record patterns]
-        ; let groups :: NonEmpty (NonEmpty (ConArgPats, EquationInfo))
-              groups = NE.groupBy1 compatible_pats
-                     $ fmap (\eqn -> (pat_args (firstPat eqn), eqn)) (eqn1 :| eqns)
-
-        ; match_results <- mapM (match_group arg_vars) groups
-
-        ; return $ MkCaseAlt{ alt_pat = con1,
-                              alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,
-                              alt_wrapper = wrapper1,
-                              alt_result = foldr1 combineMatchResults match_results } }
-  where
-    ConPat { pat_con = L _ con1
-           , pat_args = args1
-           , pat_con_ext = ConPatTc
-             { cpt_arg_tys = arg_tys
-             , cpt_wrap = wrapper1
-             , cpt_tvs = tvs1
-             , cpt_dicts = dicts1
-             }
-           } = firstPat eqn1
-    fields1 = map flSelector (conLikeFieldLabels con1)
-
-    ex_tvs = conLikeExTyCoVars con1
-
-    -- Choose the right arg_vars in the right order for this group
-    -- Note [Record patterns]
-    select_arg_vars :: [Id] -> NonEmpty (ConArgPats, EquationInfo) -> [Id]
-    select_arg_vars arg_vars ((arg_pats, _) :| _)
-      | RecCon flds <- arg_pats
-      , let rpats = rec_flds flds
-      , not (null rpats)     -- Treated specially; cf conArgPats
-      = assertPpr (fields1 `equalLength` arg_vars)
-                  (ppr con1 $$ ppr fields1 $$ ppr arg_vars) $
-        map lookup_fld rpats
-      | otherwise
-      = arg_vars
-      where
-        fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
-        lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env
-                                            (idName (hsRecFieldId rpat))
-
------------------
-compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool
--- Two constructors have compatible argument patterns if the number
--- and order of sub-matches is the same in both cases
-compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2
-compatible_pats (RecCon flds1, _) _                 = null (rec_flds flds1)
-compatible_pats _                 (RecCon flds2, _) = null (rec_flds flds2)
-compatible_pats _                 _                 = True -- Prefix or infix con
-
-same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc)
-            -> Bool
-same_fields flds1 flds2
-  = all2 (\(L _ f1) (L _ f2)
-                          -> hsRecFieldId f1 == hsRecFieldId f2)
-         (rec_flds flds1) (rec_flds flds2)
-
-
------------------
-selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id]
-selectConMatchVars arg_tys con
-  = case con of
-      RecCon {}      -> newSysLocalsDs arg_tys
-      PrefixCon _ ps -> selectMatchVars (zipMults arg_tys ps)
-      InfixCon p1 p2 -> selectMatchVars (zipMults arg_tys [p1, p2])
-  where
-    zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b))
-
-conArgPats :: [Scaled Type]-- Instantiated argument types
-                          -- Used only to fill in the types of WildPats, which
-                          -- are probably never looked at anyway
-           -> ConArgPats
-           -> [Pat GhcTc]
-conArgPats _arg_tys (PrefixCon _ ps) = map unLoc ps
-conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
-conArgPats  arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
-  | null rpats = map WildPat (map scaledThing arg_tys)
-        -- Important special case for C {}, which can be used for a
-        -- datacon that isn't declared to have fields at all
-  | otherwise  = map (unLoc . hfbRHS . unLoc) rpats
-
-{-
-Note [Record patterns]
-~~~~~~~~~~~~~~~~~~~~~~
-Consider
-         data T = T { x,y,z :: Bool }
-
-         f (T { y=True, x=False }) = ...
-
-We must match the patterns IN THE ORDER GIVEN, thus for the first
-one we match y=True before x=False.  See #246; or imagine
-matching against (T { y=False, x=undefined }): should fail without
-touching the undefined.
-
-Now consider:
-
-         f (T { y=True, x=False }) = ...
-         f (T { x=True, y= False}) = ...
-
-In the first we must test y first; in the second we must test x
-first.  So we must divide even the equations for a single constructor
-T into sub-groups, based on whether they match the same field in the
-same order.  That's what the (groupBy compatible_pats) grouping.
-
-All non-record patterns are "compatible" in this sense, because the
-positional patterns (T a b) and (a `T` b) all match the arguments
-in order.  Also T {} is special because it's equivalent to (T _ _).
-Hence the (null rpats) checks here and there.
-
--}
diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Match/Literal.hs
+++ /dev/null
@@ -1,707 +0,0 @@
-
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE MultiWayIf          #-}
-{-# LANGUAGE TypeApplications    #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Pattern-matching literal patterns
--}
-
-module GHC.HsToCore.Match.Literal
-   ( dsLit, dsOverLit, hsLitKey
-   , tidyLitPat, tidyNPat
-   , matchLiterals, matchNPlusKPats, matchNPats
-   , warnAboutIdentities
-   , warnAboutOverflowedOverLit, warnAboutOverflowedLit
-   , warnAboutEmptyEnumerations
-   )
-where
-
-import GHC.Prelude
-import GHC.Platform
-
-import {-# SOURCE #-} GHC.HsToCore.Match ( match )
-import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsExpr, dsSyntaxExpr )
-
-import GHC.HsToCore.Errors.Types
-import GHC.HsToCore.Monad
-import GHC.HsToCore.Utils
-
-import GHC.Hs
-
-import GHC.Tc.Utils.Zonk ( shortCutLit )
-import GHC.Tc.Utils.TcType
-
-import GHC.Core
-import GHC.Core.Make
-import GHC.Core.TyCon
-import GHC.Core.Reduction ( Reduction(..) )
-import GHC.Core.DataCon
-import GHC.Core.Type
-import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType )
-
-import GHC.Types.Name
-import GHC.Types.Literal
-import GHC.Types.SrcLoc
-
-import GHC.Builtin.Names
-import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim
-
-import GHC.Types.Id
-import GHC.Types.SourceText
-
-import GHC.Driver.Session
-
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-import GHC.Data.FastString
-
-import Control.Monad
-import Data.Int
-import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NEL
-import Data.Word
-import GHC.Real ( Ratio(..), numerator, denominator )
-
-{-
-************************************************************************
-*                                                                      *
-                Desugaring literals
- [used to be in GHC.HsToCore.Expr, but GHC.HsToCore.Quote needs it,
-  and it's nice to avoid a loop]
-*                                                                      *
-************************************************************************
-
-We give int/float literals type @Integer@ and @Rational@, respectively.
-The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
-around them.
-
-ToDo: put in range checks for when converting ``@i@''
-(or should that be in the typechecker?)
-
-For numeric literals, we try to detect there use at a standard type
-(@Int@, @Float@, etc.) are directly put in the right constructor.
-[NB: down with the @App@ conversion.]
-
-See also below where we look for @DictApps@ for \tr{plusInt}, etc.
--}
-
-dsLit :: HsLit GhcRn -> DsM CoreExpr
-dsLit l = do
-  dflags <- getDynFlags
-  let platform = targetPlatform dflags
-  case l of
-    HsStringPrim _ s -> return (Lit (LitString s))
-    HsCharPrim   _ c -> return (Lit (LitChar c))
-    HsIntPrim    _ i -> return (Lit (mkLitIntWrap platform i))
-    HsWordPrim   _ w -> return (Lit (mkLitWordWrap platform w))
-    HsInt64Prim  _ i -> return (Lit (mkLitInt64Wrap i))
-    HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap w))
-
-    -- This can be slow for very large literals. See Note [FractionalLit representation]
-    -- and #15646
-    HsFloatPrim  _ fl -> return (Lit (LitFloat (rationalFromFractionalLit fl)))
-    HsDoublePrim _ fl -> return (Lit (LitDouble (rationalFromFractionalLit fl)))
-    HsChar _ c       -> return (mkCharExpr c)
-    HsString _ str   -> mkStringExprFS str
-    HsInteger _ i _  -> return (mkIntegerExpr platform i)
-    HsInt _ i        -> return (mkIntExpr platform (il_value i))
-    HsRat _ fl ty    -> dsFractionalLitToRational fl ty
-
-{-
-Note [FractionalLit representation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There is a fun wrinkle to this, we used to simply compute the value
-for these literals and store it as `Rational`. While this might seem
-reasonable it meant typechecking literals of extremely large numbers
-wasn't possible. This happened for example in #15646.
-
-There a user would write in GHCi e.g. `:t 1e1234111111111111111111111`
-which would trip up the compiler. The reason being we would parse it as
-<Literal of value n>. Try to compute n, which would run out of memory
-for truly large numbers, or take far too long for merely large ones.
-
-To fix this we instead now store the significand and exponent of the
-literal instead. Depending on the size of the exponent we then defer
-the computation of the Rational value, potentially up to runtime of the
-program! There are still cases left were we might compute large rationals
-but it's a lot rarer then.
-
-The current state of affairs for large literals is:
-* Typechecking: Will produce a FractionalLit
-* Desugaring a large overloaded literal to Float/Double *is* done
-  at compile time. So can still fail. But this only matters for values too large
-  to be represented as float anyway.
-* Converting overloaded literals to a value of *Rational* is done at *runtime*.
-  If such a value is then demanded at runtime the program might hang or run out of
-  memory. But that is perhaps expected and acceptable.
-* TH might also evaluate the literal even when overloaded.
-  But there a user should be able to work around #15646 by
-  generating a call to `mkRationalBase10/2` for large literals instead.
-
-
-Note [FractionalLit representation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For fractional literals, like 1.3 or 0.79e22, we do /not/ represent
-them within the compiler as a Rational.  Doing so would force the
-compiler to compute a huge Rational for 2.3e300000000000, at compile
-time (#15646)!
-
-So instead we represent fractional literals as a FractionalLit,
-in which we record the significand and exponent separately.  Then
-we can compute the huge Rational at /runtime/, by emitting code
-for
-       mkRationalBase10 2.3 300000000000
-
-where mkRationalBase10 is defined in the library GHC.Real
-
-The moving parts are here:
-
-* Parsing, renaming, typechecking: use FractionalLit, in which the
-  significand and exponent are represented separately.
-
-* Desugaring.  Remember that a fractional literal like 54.4e20 has type
-     Fractional a => a
-
-  - For fractional literals whose type turns out to be Float/Double,
-    we desugar to a Float/Double literal at /compile time/.
-    This conversion can still fail. But this only matters for values
-    too large to be represented as float anyway.  See dsLit in
-    GHC.HsToCore.Match.Literal
-
-  - For fractional literals whose type turns out to be Rational, we
-    desugar the literal to a call of `mkRationalBase10` (etc for hex
-    literals), so that we only compute the Rational at /run time/.  If
-    this value is then demanded at runtime the program might hang or
-    run out of memory. But that is perhaps expected and acceptable.
-    See dsFractionalLitToRational in GHC.HsToCore.Match.Literal
-
-  - For fractional literals whose type isn't one of the above, we just
-    call the typeclass method `fromRational`.  But to do that we need
-    the rational to give to it, and we compute that at runtime, as
-    above.
-
-* Template Haskell definitions are also problematic. While the TH code
-  works as expected once it's spliced into a program it will compute the
-  value of the large literal.
-  But there a user should be able to work around #15646
-  by having their TH code generating a call to `mkRationalBase[10/2]` for
-  large literals  instead.
-
--}
-
--- | See Note [FractionalLit representation]
-dsFractionalLitToRational :: FractionalLit -> Type -> DsM CoreExpr
-dsFractionalLitToRational fl@FL{ fl_signi = signi, fl_exp = exp, fl_exp_base = base } ty
-  -- We compute "small" rationals here and now
-  | abs exp <= 100
-  = do
-    platform <- targetPlatform <$> getDynFlags
-    let !val   = rationalFromFractionalLit fl
-        !num   = mkIntegerExpr platform (numerator val)
-        !denom = mkIntegerExpr platform (denominator val)
-        (ratio_data_con, integer_ty)
-            = case tcSplitTyConApp ty of
-                    (tycon, [i_ty]) -> assert (isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
-                                       (head (tyConDataCons tycon), i_ty)
-                    x -> pprPanic "dsLit" (ppr x)
-    return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
-  -- Large rationals will be computed at runtime.
-  | otherwise
-  = do
-      let mkRationalName = case base of
-                             Base2 -> mkRationalBase2Name
-                             Base10 -> mkRationalBase10Name
-      mkRational <- dsLookupGlobalId mkRationalName
-      litR <- dsRational signi
-      platform <- targetPlatform <$> getDynFlags
-      let litE = mkIntegerExpr platform exp
-      return (mkCoreApps (Var mkRational) [litR, litE])
-
-dsRational :: Rational -> DsM CoreExpr
-dsRational (n :% d) = do
-  platform <- targetPlatform <$> getDynFlags
-  dcn <- dsLookupDataCon ratioDataConName
-  let cn = mkIntegerExpr platform n
-  let dn = mkIntegerExpr platform d
-  return $ mkCoreConApps dcn [Type integerTy, cn, dn]
-
-
-dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
--- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains
--- (an expression for) the literal value itself.
-dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable witness ty }) = do
-  dflags <- getDynFlags
-  let platform = targetPlatform dflags
-  case shortCutLit platform val ty of
-    Just expr | not rebindable -> dsExpr expr        -- Note [Literal short cut]
-    _                          -> dsExpr witness
-
-{-
-Note [Literal short cut]
-~~~~~~~~~~~~~~~~~~~~~~~~
-The type checker tries to do this short-cutting as early as possible, but
-because of unification etc, more information is available to the desugarer.
-And where it's possible to generate the correct literal right away, it's
-much better to do so.
-
-
-************************************************************************
-*                                                                      *
-                 Warnings about overflowed literals
-*                                                                      *
-************************************************************************
-
-Warn about functions like toInteger, fromIntegral, that convert
-between one type and another when the to- and from- types are the
-same.  Then it's probably (albeit not definitely) the identity
--}
-
-warnAboutIdentities :: DynFlags -> Id -> Type -> DsM ()
-warnAboutIdentities dflags conv_fn type_of_conv
-  | wopt Opt_WarnIdentities dflags
-  , idName conv_fn `elem` conversionNames
-  , Just (_, _, arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
-  , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
-  = diagnosticDs (DsIdentitiesFound conv_fn type_of_conv)
-warnAboutIdentities _ _ _ = return ()
-
-conversionNames :: [Name]
-conversionNames
-  = [ toIntegerName, toRationalName
-    , fromIntegralName, realToFracName ]
- -- We can't easily add fromIntegerName, fromRationalName,
- -- because they are generated by literals
-
-
--- | Emit warnings on overloaded integral literals which overflow the bounds
--- implied by their type.
-warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
-warnAboutOverflowedOverLit hsOverLit = do
-  dflags <- getDynFlags
-  fam_envs <- dsGetFamInstEnvs
-  warnAboutOverflowedLiterals dflags $
-      getIntegralLit hsOverLit >>= getNormalisedTyconName fam_envs
-
--- | Emit warnings on integral literals which overflow the bounds implied by
--- their type.
-warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
-warnAboutOverflowedLit hsLit = do
-  dflags <- getDynFlags
-  warnAboutOverflowedLiterals dflags $
-      getSimpleIntegralLit hsLit >>= getTyconName
-
--- | Emit warnings on integral literals which overflow the bounds implied by
--- their type.
-warnAboutOverflowedLiterals
-  :: DynFlags
-  -> Maybe (Integer, Name)  -- ^ the literal value and name of its tycon
-  -> DsM ()
-warnAboutOverflowedLiterals dflags lit
- | wopt Opt_WarnOverflowedLiterals dflags
- , Just (i, tc) <- lit
- = if
-    -- These only show up via the 'HsOverLit' route
-    | tc == intTyConName        -> check i tc minInt         maxInt
-    | tc == wordTyConName       -> check i tc minWord        maxWord
-    | tc == int8TyConName       -> check i tc (min' @Int8)   (max' @Int8)
-    | tc == int16TyConName      -> check i tc (min' @Int16)  (max' @Int16)
-    | tc == int32TyConName      -> check i tc (min' @Int32)  (max' @Int32)
-    | tc == int64TyConName      -> check i tc (min' @Int64)  (max' @Int64)
-    | tc == word8TyConName      -> check i tc (min' @Word8)  (max' @Word8)
-    | tc == word16TyConName     -> check i tc (min' @Word16) (max' @Word16)
-    | tc == word32TyConName     -> check i tc (min' @Word32) (max' @Word32)
-    | tc == word64TyConName     -> check i tc (min' @Word64) (max' @Word64)
-    | tc == naturalTyConName    -> checkPositive i tc
-
-    -- These only show up via the 'HsLit' route
-    | tc == intPrimTyConName    -> check i tc minInt         maxInt
-    | tc == wordPrimTyConName   -> check i tc minWord        maxWord
-    | tc == int8PrimTyConName   -> check i tc (min' @Int8)   (max' @Int8)
-    | tc == int16PrimTyConName  -> check i tc (min' @Int16)  (max' @Int16)
-    | tc == int32PrimTyConName  -> check i tc (min' @Int32)  (max' @Int32)
-    | tc == int64PrimTyConName  -> check i tc (min' @Int64)  (max' @Int64)
-    | tc == word8PrimTyConName  -> check i tc (min' @Word8)  (max' @Word8)
-    | tc == word16PrimTyConName -> check i tc (min' @Word16) (max' @Word16)
-    | tc == word32PrimTyConName -> check i tc (min' @Word32) (max' @Word32)
-    | tc == word64PrimTyConName -> check i tc (min' @Word64) (max' @Word64)
-
-    | otherwise -> return ()
-
-  | otherwise = return ()
-  where
-    -- use target Int/Word sizes! See #17336
-    platform          = targetPlatform dflags
-    (minInt,maxInt)   = (platformMinInt platform, platformMaxInt platform)
-    (minWord,maxWord) = (0,                       platformMaxWord platform)
-
-    min' :: forall a. (Integral a, Bounded a) => Integer
-    min' = fromIntegral (minBound :: a)
-
-    max' :: forall a. (Integral a, Bounded a) => Integer
-    max' = fromIntegral (maxBound :: a)
-
-    checkPositive :: Integer -> Name -> DsM ()
-    checkPositive i tc
-      = when (i < 0) $
-        diagnosticDs (DsOverflowedLiterals i tc Nothing (negLiteralExtEnabled dflags))
-
-    check i tc minB maxB
-      = when (i < minB || i > maxB) $
-        diagnosticDs (DsOverflowedLiterals i tc bounds (negLiteralExtEnabled dflags))
-      where
-        bounds = Just (MinBound minB, MaxBound maxB)
-
-warnAboutEmptyEnumerations :: FamInstEnvs -> DynFlags -> LHsExpr GhcTc
-                           -> Maybe (LHsExpr GhcTc)
-                           -> LHsExpr GhcTc -> DsM ()
--- ^ Warns about @[2,3 .. 1]@ or @['b' .. 'a']@ which return the empty list.
--- For numeric literals, only works for integral types, not floating point.
-warnAboutEmptyEnumerations fam_envs dflags fromExpr mThnExpr toExpr
-  | not $ wopt Opt_WarnEmptyEnumerations dflags
-  = return ()
-  -- Numeric Literals
-  | Just from_ty@(from',_) <- getLHsIntegralLit fromExpr
-  , Just (_, tc)           <- getNormalisedTyconName fam_envs from_ty
-  , Just mThn'             <- traverse getLHsIntegralLit mThnExpr
-  , Just (to',_)           <- getLHsIntegralLit toExpr
-  = do
-      let
-        check :: forall a. (Integral a, Num a) => DsM ()
-        check = when (null enumeration) raiseWarning
-          where
-            enumeration = case mThn of
-              Nothing  -> [from      .. to]
-              Just thn -> [from, thn .. to]
-            wrap :: forall a. (Integral a, Num a) => Integer -> Integer
-            wrap i = toInteger (fromIntegral i :: a)
-            from = wrap @a from'
-            to   = wrap @a to'
-            mThn = fmap (wrap @a . fst) mThn'
-
-      platform <- targetPlatform <$> getDynFlags
-         -- Be careful to use target Int/Word sizes! cf #17336
-      if | tc == intTyConName     -> case platformWordSize platform of
-                                      PW4 -> check @Int32
-                                      PW8 -> check @Int64
-         | tc == wordTyConName    -> case platformWordSize platform of
-                                      PW4 -> check @Word32
-                                      PW8 -> check @Word64
-         | tc == int8TyConName    -> check @Int8
-         | tc == int16TyConName   -> check @Int16
-         | tc == int32TyConName   -> check @Int32
-         | tc == int64TyConName   -> check @Int64
-         | tc == word8TyConName   -> check @Word8
-         | tc == word16TyConName  -> check @Word16
-         | tc == word32TyConName  -> check @Word32
-         | tc == word64TyConName  -> check @Word64
-         | tc == integerTyConName -> check @Integer
-         | tc == naturalTyConName -> check @Integer
-            -- We use 'Integer' because otherwise a negative 'Natural' literal
-            -- could cause a compile time crash (instead of a runtime one).
-            -- See the T10930b test case for an example of where this matters.
-         | otherwise -> return ()
-
-  -- Char literals (#18402)
-  | Just fromChar <- getLHsCharLit fromExpr
-  , Just mThnChar <- traverse getLHsCharLit mThnExpr
-  , Just toChar   <- getLHsCharLit toExpr
-  , let enumeration = case mThnChar of
-                        Nothing      -> [fromChar          .. toChar]
-                        Just thnChar -> [fromChar, thnChar .. toChar]
-  = when (null enumeration) raiseWarning
-
-  | otherwise = return ()
-  where
-    raiseWarning =
-      diagnosticDs DsEmptyEnumeration
-
-getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type)
--- ^ See if the expression is an 'Integral' literal.
-getLHsIntegralLit (L _ e) = go e
-  where
-    go (HsPar _ _ e _)        = getLHsIntegralLit e
-    go (HsOverLit _ over_lit) = getIntegralLit over_lit
-    go (HsLit _ lit)          = getSimpleIntegralLit lit
-
-    -- Remember to look through automatically-added tick-boxes! (#8384)
-    go (XExpr (HsTick _ e))       = getLHsIntegralLit e
-    go (XExpr (HsBinTick _ _ e))  = getLHsIntegralLit e
-
-    -- The literal might be wrapped in a case with -XOverloadedLists
-    go (XExpr (WrapExpr (HsWrap _ e))) = go e
-    go _ = Nothing
-
--- | If 'Integral', extract the value and type of the overloaded literal.
--- See Note [Literals and the OverloadedLists extension]
-getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Type)
-getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc { ol_type = ty } })
-  = Just (il_value i, ty)
-getIntegralLit _ = Nothing
-
--- | If 'Integral', extract the value and type of the non-overloaded literal.
-getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Type)
-getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTy)
-getSimpleIntegralLit (HsIntPrim _ i)    = Just (i, intPrimTy)
-getSimpleIntegralLit (HsWordPrim _ i)   = Just (i, wordPrimTy)
-getSimpleIntegralLit (HsInt64Prim _ i)  = Just (i, int64PrimTy)
-getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTy)
-getSimpleIntegralLit (HsInteger _ i ty) = Just (i, ty)
-getSimpleIntegralLit _ = Nothing
-
--- | Extract the Char if the expression is a Char literal.
-getLHsCharLit :: LHsExpr GhcTc -> Maybe Char
-getLHsCharLit (L _ (HsPar _ _ e _))        = getLHsCharLit e
-getLHsCharLit (L _ (HsLit _ (HsChar _ c))) = Just c
-getLHsCharLit (L _ (XExpr (HsTick _ e)))         = getLHsCharLit e
-getLHsCharLit (L _ (XExpr (HsBinTick _ _ e)))    = getLHsCharLit e
-getLHsCharLit _ = Nothing
-
--- | Convert a pair (Integer, Type) to (Integer, Name) after eventually
--- normalising the type
-getNormalisedTyconName :: FamInstEnvs -> (Integer, Type) -> Maybe (Integer, Name)
-getNormalisedTyconName fam_envs (i,ty)
-    | Just tc <- tyConAppTyCon_maybe (normaliseNominal fam_envs ty)
-    = Just (i, tyConName tc)
-    | otherwise = Nothing
-  where
-    normaliseNominal :: FamInstEnvs -> Type -> Type
-    normaliseNominal fam_envs ty
-      = reductionReducedType
-      $ normaliseType fam_envs Nominal ty
-
--- | Convert a pair (Integer, Type) to (Integer, Name) without normalising
--- the type
-getTyconName :: (Integer, Type) -> Maybe (Integer, Name)
-getTyconName (i,ty)
-  | Just tc <- tyConAppTyCon_maybe ty = Just (i, tyConName tc)
-  | otherwise = Nothing
-
-{-
-Note [Literals and the OverloadedLists extension]
-~~~~
-Consider the Literal `[256] :: [Data.Word.Word8]`
-
-When the `OverloadedLists` extension is not active, then the `ol_ext` field
-in the `OverLitTc` record that is passed to the function `getIntegralLit`
-contains the type `Word8`. This is a simple type, and we can use its
-type constructor immediately for the `warnAboutOverflowedLiterals` function.
-
-When the `OverloadedLists` extension is active, then the `ol_ext` field
-contains the type family `Item [Word8]`. The function `nomaliseType` is used
-to convert it to the needed type `Word8`.
--}
-
-{-
-************************************************************************
-*                                                                      *
-        Tidying lit pats
-*                                                                      *
-************************************************************************
--}
-
-tidyLitPat :: HsLit GhcTc -> Pat GhcTc
--- Result has only the following HsLits:
---      HsIntPrim, HsWordPrim, HsCharPrim, HsString
---  * HsInteger, HsRat, HsInt, as well as HsStringPrim,
---    HsFloatPrim and HsDoublePrim can't show up in LitPats
---  * We get rid of HsChar right here
-tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)
-tidyLitPat (HsString src s)
-  | lengthFS s <= 1     -- Short string literals only
-  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon
-                                             [mkCharLitPat src c, pat] [charTy])
-                  (mkNilPat charTy) (unpackFS s)
-        -- The stringTy is the type of the whole pattern, not
-        -- the type to instantiate (:) or [] with!
-tidyLitPat lit = LitPat noExtField lit
-
-----------------
-tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
-         -> Type
-         -> Pat GhcTc
-tidyNPat (OverLit (OverLitTc False _ ty) val) mb_neg _eq outer_ty
-        -- False: Take short cuts only if the literal is not using rebindable syntax
-        --
-        -- Once that is settled, look for cases where the type of the
-        -- entire overloaded literal matches the type of the underlying literal,
-        -- and in that case take the short cut
-        -- NB: Watch out for weird cases like #3382
-        --        f :: Int -> Int
-        --        f "blah" = 4
-        --     which might be ok if we have 'instance IsString Int'
-        --
-  | not type_change, isIntTy ty,    Just int_lit <- mb_int_lit
-                 = mk_con_pat intDataCon    (HsIntPrim    NoSourceText int_lit)
-  | not type_change, isWordTy ty,   Just int_lit <- mb_int_lit
-                 = mk_con_pat wordDataCon   (HsWordPrim   NoSourceText int_lit)
-  | not type_change, isStringTy ty, Just str_lit <- mb_str_lit
-                 = tidyLitPat (HsString NoSourceText str_lit)
-     -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
-     -- If we do convert to the constructor form, we'll generate a case
-     -- expression on a Float# or Double# and that's not allowed in Core; see
-     -- #9238 and Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold
-  where
-    -- Sometimes (like in test case
-    -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include
-    -- type-changing wrappers (for example, from Id Int to Int, for the identity
-    -- type family Id). In these cases, we can't do the short-cut.
-    type_change = not (outer_ty `eqType` ty)
-
-    mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
-    mk_con_pat con lit
-      = unLoc (mkPrefixConPat con [noLocA $ LitPat noExtField lit] [])
-
-    mb_int_lit :: Maybe Integer
-    mb_int_lit = case (mb_neg, val) of
-                   (Nothing, HsIntegral i) -> Just (il_value i)
-                   (Just _,  HsIntegral i) -> Just (-(il_value i))
-                   _ -> Nothing
-
-    mb_str_lit :: Maybe FastString
-    mb_str_lit = case (mb_neg, val) of
-                   (Nothing, HsIsString _ s) -> Just s
-                   _ -> Nothing
-
-tidyNPat over_lit mb_neg eq outer_ty
-  = NPat outer_ty (noLocA over_lit) mb_neg eq
-
-{-
-************************************************************************
-*                                                                      *
-                Pattern matching on LitPat
-*                                                                      *
-************************************************************************
--}
-
-matchLiterals :: NonEmpty Id
-              -> Type -- ^ Type of the whole case expression
-              -> NonEmpty (NonEmpty EquationInfo) -- ^ All PgLits
-              -> DsM (MatchResult CoreExpr)
-
-matchLiterals (var :| vars) ty sub_groups
-  = do  {       -- Deal with each group
-        ; alts <- mapM match_group sub_groups
-
-                -- Combine results.  For everything except String
-                -- we can use a case expression; for String we need
-                -- a chain of if-then-else
-        ; if isStringTy (idType var) then
-            do  { eq_str <- dsLookupGlobalId eqStringName
-                ; mrs <- mapM (wrap_str_guard eq_str) alts
-                ; return (foldr1 combineMatchResults mrs) }
-          else
-            return (mkCoPrimCaseMatchResult var ty $ NEL.toList alts)
-        }
-  where
-    match_group :: NonEmpty EquationInfo -> DsM (Literal, MatchResult CoreExpr)
-    match_group eqns@(firstEqn :| _)
-        = do { dflags <- getDynFlags
-             ; let platform = targetPlatform dflags
-             ; let LitPat _ hs_lit = firstPat firstEqn
-             ; match_result <- match vars ty (NEL.toList $ shiftEqns eqns)
-             ; return (hsLitKey platform hs_lit, match_result) }
-
-    wrap_str_guard :: Id -> (Literal,MatchResult CoreExpr) -> DsM (MatchResult CoreExpr)
-        -- Equality check for string literals
-    wrap_str_guard eq_str (LitString s, mr)
-        = do { -- We now have to convert back to FastString. Perhaps there
-               -- should be separate LitBytes and LitString constructors?
-               let s'  = mkFastStringByteString s
-             ; lit    <- mkStringExprFS s'
-             ; let pred = mkApps (Var eq_str) [Var var, lit]
-             ; return (mkGuardedMatchResult pred mr) }
-    wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
-
-
----------------------------
-hsLitKey :: Platform -> HsLit GhcTc -> Literal
--- Get the Core literal corresponding to a HsLit.
--- It only works for primitive types and strings;
--- others have been removed by tidy
--- For HsString, it produces a LitString, which really represents an _unboxed_
--- string literal; and we deal with it in matchLiterals above. Otherwise, it
--- produces a primitive Literal of type matching the original HsLit.
--- In the case of the fixed-width numeric types, we need to wrap here
--- because Literal has an invariant that the literal is in range, while
--- HsLit does not.
-hsLitKey platform (HsIntPrim    _ i)  = mkLitIntWrap  platform i
-hsLitKey platform (HsWordPrim   _ w)  = mkLitWordWrap platform w
-hsLitKey _        (HsInt64Prim  _ i)  = mkLitInt64Wrap  i
-hsLitKey _        (HsWord64Prim _ w)  = mkLitWord64Wrap w
-hsLitKey _        (HsCharPrim   _ c)  = mkLitChar            c
--- This following two can be slow. See Note [FractionalLit representation]
-hsLitKey _        (HsFloatPrim  _ fl) = mkLitFloat (rationalFromFractionalLit fl)
-hsLitKey _        (HsDoublePrim _ fl) = mkLitDouble (rationalFromFractionalLit fl)
-
-hsLitKey _        (HsString _ s)      = LitString (bytesFS s)
-hsLitKey _        l                   = pprPanic "hsLitKey" (ppr l)
-
-{-
-************************************************************************
-*                                                                      *
-                Pattern matching on NPat
-*                                                                      *
-************************************************************************
--}
-
-matchNPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
-matchNPats (var :| vars) ty (eqn1 :| eqns)    -- All for the same literal
-  = do  { let NPat _ (L _ lit) mb_neg eq_chk = firstPat eqn1
-        ; lit_expr <- dsOverLit lit
-        ; neg_lit <- case mb_neg of
-                            Nothing  -> return lit_expr
-                            Just neg -> dsSyntaxExpr neg [lit_expr]
-        ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]
-        ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
-        ; return (mkGuardedMatchResult pred_expr match_result) }
-
-{-
-************************************************************************
-*                                                                      *
-                Pattern matching on n+k patterns
-*                                                                      *
-************************************************************************
-
-For an n+k pattern, we use the various magic expressions we've been given.
-We generate:
-\begin{verbatim}
-    if ge var lit then
-        let n = sub var lit
-        in  <expr-for-a-successful-match>
-    else
-        <try-next-pattern-or-whatever>
-\end{verbatim}
--}
-
-matchNPlusKPats :: NonEmpty Id -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)
--- All NPlusKPats, for the *same* literal k
-matchNPlusKPats (var :| vars) ty (eqn1 :| eqns)
-  = do  { let NPlusKPat _ (L _ n1) (L _ lit1) lit2 ge minus
-                = firstPat eqn1
-        ; lit1_expr   <- dsOverLit lit1
-        ; lit2_expr   <- dsOverLit lit2
-        ; pred_expr   <- dsSyntaxExpr ge    [Var var, lit1_expr]
-        ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]
-        ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
-        ; match_result <- match vars ty eqns'
-        ; return  (mkGuardedMatchResult pred_expr               $
-                   mkCoLetMatchResult (NonRec n1 minusk_expr)   $
-                   fmap (foldr1 (.) wraps)                      $
-                   match_result) }
-  where
-    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (L _ n) _ _ _ _ : pats })
-        = (wrapBind n n1, eqn { eqn_pats = pats })
-        -- The wrapBind is a no-op for the first equation
-    shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ /dev/null
@@ -1,544 +0,0 @@
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Monadery used in desugaring
--}
-
-module GHC.HsToCore.Monad (
-        DsM, mapM, mapAndUnzipM,
-        initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
-        foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
-        Applicative(..),(<$>),
-
-        duplicateLocalDs, newSysLocalDs,
-        newSysLocalsDs, newUniqueId,
-        newFailLocalDs, newPredVarDs,
-        getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,
-        mkNamePprCtxDs,
-        newUnique,
-        UniqSupply, newUniqueSupply,
-        getGhcModeDs, dsGetFamInstEnvs,
-        dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
-        dsLookupDataCon, dsLookupConLike,
-        getCCIndexDsM,
-
-        DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
-
-        -- Getting and setting pattern match oracle states
-        getPmNablas, updPmNablas,
-
-        -- Get COMPLETE sets of a TyCon
-        dsGetCompleteMatches,
-
-        -- Warnings and errors
-        DsWarning, diagnosticDs, errDsCoreExpr,
-        failWithDs, failDs, discardWarningsDs,
-
-        -- Data types
-        DsMatchContext(..),
-        EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
-
-        -- Trace injection
-        pprRuntimeTrace
-    ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Env
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Driver.Config.Diagnostic
-
-import GHC.Hs
-
-import GHC.HsToCore.Types
-import GHC.HsToCore.Errors.Types
-import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas)
-
-import GHC.Core.FamInstEnv
-import GHC.Core
-import GHC.Core.Make  ( unitExpr )
-import GHC.Core.Utils ( exprType )
-import GHC.Core.DataCon
-import GHC.Core.ConLike
-import GHC.Core.TyCon
-import GHC.Core.Type
-import GHC.Core.Multiplicity
-
-import GHC.IfaceToCore
-
-import GHC.Tc.Utils.Monad
-
-import GHC.Builtin.Names
-
-import GHC.Data.FastString
-
-import GHC.Unit.Env
-import GHC.Unit.External
-import GHC.Unit.Module
-import GHC.Unit.Module.ModGuts
-
-import GHC.Types.Name.Reader
-import GHC.Types.Basic ( Origin )
-import GHC.Types.SourceFile
-import GHC.Types.Id
-import GHC.Types.SrcLoc
-import GHC.Types.TypeEnv
-import GHC.Types.Unique.Supply
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.Name.Ppr
-import GHC.Types.Literal ( mkLitString )
-import GHC.Types.CostCentre.State
-import GHC.Types.TyThing
-import GHC.Types.Error
-
-import GHC.Utils.Error
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import qualified GHC.Data.Strict as Strict
-
-import Data.IORef
-import GHC.Driver.Env.KnotVars
-
-{-
-************************************************************************
-*                                                                      *
-                Data types for the desugarer
-*                                                                      *
-************************************************************************
--}
-
-data DsMatchContext
-  = DsMatchContext (HsMatchContext GhcRn) SrcSpan
-  deriving ()
-
-instance Outputable DsMatchContext where
-  ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
-
-data EquationInfo
-  = EqnInfo { eqn_pats :: [Pat GhcTc]
-              -- ^ The patterns for an equation
-              --
-              -- NB: We have /already/ applied 'decideBangHood' to
-              -- these patterns.  See Note [decideBangHood] in "GHC.HsToCore.Utils"
-
-            , eqn_orig :: Origin
-              -- ^ Was this equation present in the user source?
-              --
-              -- This helps us avoid warnings on patterns that GHC elaborated.
-              --
-              -- For instance, the pattern @-1 :: Word@ gets desugared into
-              -- @W# -1## :: Word@, but we shouldn't warn about an overflowed
-              -- literal for /both/ of these cases.
-
-            , eqn_rhs  :: MatchResult CoreExpr
-              -- ^ What to do after match
-            }
-
-instance Outputable EquationInfo where
-    ppr (EqnInfo pats _ _) = ppr pats
-
-type DsWrapper = CoreExpr -> CoreExpr
-idDsWrapper :: DsWrapper
-idDsWrapper e = e
-
--- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult CoreExpr
---      \fail. wrap (case vs of { pats -> rhs fail })
--- where vs are not bound by wrap
-
--- | This is a value of type a with potentially a CoreExpr-shaped hole in it.
--- This is used to deal with cases where we are potentially handling pattern
--- match failure, and want to later specify how failure is handled.
-data MatchResult a
-  -- | We represent the case where there is no hole without a function from
-  -- 'CoreExpr', like this, because sometimes we have nothing to put in the
-  -- hole and so want to be sure there is in fact no hole.
-  = MR_Infallible (DsM a)
-  | MR_Fallible (CoreExpr -> DsM a)
-  deriving (Functor)
-
--- | Product is an "or" on fallibility---the combined match result is infallible
--- only if the left and right argument match results both were.
---
--- This is useful for combining a bunch of alternatives together and then
--- getting the overall fallibility of the entire group. See 'mkDataConCase' for
--- an example.
-instance Applicative MatchResult where
-  pure v = MR_Infallible (pure v)
-  MR_Infallible f <*> MR_Infallible x = MR_Infallible (f <*> x)
-  f <*> x = MR_Fallible $ \fail -> runMatchResult fail f <*> runMatchResult fail x
-
--- Given a fail expression to use, and a MatchResult CoreExpr, compute the filled CoreExpr whether
--- the MatchResult CoreExpr was failable or not.
-runMatchResult :: CoreExpr -> MatchResult a -> DsM a
-runMatchResult fail = \case
-  MR_Infallible body -> body
-  MR_Fallible body_fn -> body_fn fail
-
-{-
-************************************************************************
-*                                                                      *
-                Monad functions
-*                                                                      *
-************************************************************************
--}
-
--- Compatibility functions
-fixDs :: (a -> DsM a) -> DsM a
-fixDs    = fixM
-
-type DsWarning = (SrcSpan, SDoc)
-        -- Not quite the same as a WarnMsg, we have an SDoc here
-        -- and we'll do the name_ppr_ctx stuff later on to turn it
-        -- into a Doc.
-
--- | Run a 'DsM' action inside the 'TcM' monad.
-initDsTc :: DsM a -> TcM (Messages DsMessage, Maybe a)
-initDsTc thing_inside
-  = do { tcg_env  <- getGblEnv
-       ; msg_var  <- liftIO $ newIORef emptyMessages
-       ; hsc_env  <- getTopEnv
-       ; envs     <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
-       ; e_result <- tryM $  -- need to tryM so that we don't discard
-                             -- DsMessages
-                     setEnvs envs thing_inside
-       ; msgs     <- liftIO $ readIORef msg_var
-       ; return (msgs, case e_result of Left _  -> Nothing
-                                        Right x -> Just x)
-       }
-
--- | Run a 'DsM' action inside the 'IO' monad.
-initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DsMessage, Maybe a)
-initDs hsc_env tcg_env thing_inside
-  = do { msg_var <- newIORef emptyMessages
-       ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
-       ; runDs hsc_env envs thing_inside
-       }
-
--- | Build a set of desugarer environments derived from a 'TcGblEnv'.
-mkDsEnvsFromTcGbl :: MonadIO m
-                  => HscEnv -> IORef (Messages DsMessage) -> TcGblEnv
-                  -> m (DsGblEnv, DsLclEnv)
-mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
-  = do { cc_st_var   <- liftIO $ newIORef newCostCentreState
-       ; eps <- liftIO $ hscEPS hsc_env
-       ; let unit_env = hsc_unit_env hsc_env
-             this_mod = tcg_mod tcg_env
-             type_env = tcg_type_env tcg_env
-             rdr_env  = tcg_rdr_env tcg_env
-             fam_inst_env = tcg_fam_inst_env tcg_env
-             ptc = initPromotionTickContext (hsc_dflags hsc_env)
-             complete_matches = hptCompleteSigs hsc_env         -- from the home package
-                                ++ tcg_complete_matches tcg_env -- from the current module
-                                ++ eps_complete_matches eps     -- from imports
-             -- re-use existing next_wrapper_num to ensure uniqueness
-             next_wrapper_num_var = tcg_next_wrapper_num tcg_env
-       ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
-                           msg_var cc_st_var next_wrapper_num_var complete_matches
-       }
-
-runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a)
-runDs hsc_env (ds_gbl, ds_lcl) thing_inside
-  = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
-                              (tryM thing_inside)
-       ; msgs   <- readIORef (ds_msgs ds_gbl)
-       ; let final_res
-               | errorsFound msgs = Nothing
-               | Right r <- res   = Just r
-               | otherwise        = panic "initDs"
-       ; return (msgs, final_res)
-       }
-
--- | Run a 'DsM' action in the context of an existing 'ModGuts'
-initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DsMessage, Maybe a)
-initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
-                                   , mg_tcs = tycons, mg_fam_insts = fam_insts
-                                   , mg_patsyns = patsyns, mg_rdr_env = rdr_env
-                                   , mg_fam_inst_env = fam_inst_env
-                                   , mg_complete_matches = local_complete_matches
-                          }) thing_inside
-  = do { cc_st_var   <- newIORef newCostCentreState
-       ; next_wrapper_num <- newIORef emptyModuleEnv
-       ; msg_var <- newIORef emptyMessages
-       ; eps <- liftIO $ hscEPS hsc_env
-       ; let unit_env = hsc_unit_env hsc_env
-             type_env = typeEnvFromEntities ids tycons patsyns fam_insts
-             ptc = initPromotionTickContext (hsc_dflags hsc_env)
-             complete_matches = hptCompleteSigs hsc_env     -- from the home package
-                                ++ local_complete_matches  -- from the current module
-                                ++ eps_complete_matches eps -- from imports
-
-             bindsToIds (NonRec v _)   = [v]
-             bindsToIds (Rec    binds) = map fst binds
-             ids = concatMap bindsToIds binds
-
-             envs  = mkDsEnvs unit_env this_mod rdr_env type_env
-                              fam_inst_env ptc msg_var cc_st_var
-                              next_wrapper_num complete_matches
-       ; runDs hsc_env envs thing_inside
-       }
-
-initTcDsForSolver :: TcM a -> DsM a
--- Spin up a TcM context so that we can run the constraint solver
--- Returns any error messages generated by the constraint solver
--- and (Just res) if no error happened; Nothing if an error happened
---
--- Simon says: I'm not very happy about this.  We spin up a complete TcM monad
---             only to immediately refine it to a TcS monad.
--- Better perhaps to make TcS into its own monad, rather than building on TcS
--- But that may in turn interact with plugins
-
-initTcDsForSolver thing_inside
-  = do { (gbl, lcl) <- getEnvs
-       ; hsc_env    <- getTopEnv
-
-       ; let DsGblEnv { ds_mod = mod
-                      , ds_fam_inst_env = fam_inst_env
-                      , ds_gbl_rdr_env  = rdr_env }      = gbl
-       -- This is *the* use of ds_gbl_rdr_env:
-       -- Make sure the solver (used by the pattern-match overlap checker) has
-       -- access to the GlobalRdrEnv and FamInstEnv for the module, so that it
-       -- knows how to reduce type families, and which newtypes it can unwrap.
-
-
-             DsLclEnv { dsl_loc = loc }                  = lcl
-
-       ; (msgs, mb_ret) <- liftIO $ initTc hsc_env HsSrcFile False mod loc $
-         updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env
-                                      , tcg_rdr_env      = rdr_env }) $
-         thing_inside
-       ; case mb_ret of
-           Just ret -> pure ret
-           Nothing  -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
-
-mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-         -> PromotionTickContext
-         -> IORef (Messages DsMessage) -> IORef CostCentreState
-         -> IORef (ModuleEnv Int) -> CompleteMatches
-         -> (DsGblEnv, DsLclEnv)
-mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
-         next_wrapper_num complete_matches
-  = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs"
-  -- Failing tests here are `ghci` and `T11985` if you get this wrong.
-  -- this is very very "at a distance" because the reason for this check is that the type_env in interactive
-  -- mode is the smushed together of all the interactive modules.
-  -- See Note [Why is KnotVars not a ModuleEnv]
-                             , if_rec_types = KnotVars [mod] (\that_mod -> if that_mod == mod || isInteractiveModule mod
-                                                          then Just (return type_env)
-                                                          else Nothing) }
-        if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
-                             NotBoot
-        real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
-        gbl_env = DsGblEnv { ds_mod     = mod
-                           , ds_fam_inst_env = fam_inst_env
-                           , ds_gbl_rdr_env  = rdr_env
-                           , ds_if_env  = (if_genv, if_lenv)
-                           , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
-                           , ds_msgs    = msg_var
-                           , ds_complete_matches = complete_matches
-                           , ds_cc_st   = cc_st_var
-                           , ds_next_wrapper_num = next_wrapper_num
-                           }
-        lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv
-                           , dsl_loc     = real_span
-                           , dsl_nablas  = initNablas
-                           }
-    in (gbl_env, lcl_env)
-
-
-{-
-************************************************************************
-*                                                                      *
-                Operations in the monad
-*                                                                      *
-************************************************************************
-
-And all this mysterious stuff is so we can occasionally reach out and
-grab one or more names.  @newLocalDs@ isn't exported---exported
-functions are defined with it.  The difference in name-strings makes
-it easier to read debugging output.
-
--}
-
--- Make a new Id with the same print name, but different type, and new unique
-newUniqueId :: Id -> Mult -> Type -> DsM Id
-newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id)))
-
-duplicateLocalDs :: Id -> DsM Id
-duplicateLocalDs old_local
-  = do  { uniq <- newUnique
-        ; return (setIdUnique old_local uniq) }
-
-newPredVarDs :: PredType -> DsM Var
-newPredVarDs
- = mkSysLocalOrCoVarM (fsLit "ds") ManyTy  -- like newSysLocalDs, but we allow covars
-
-newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id
-newSysLocalDs = mkSysLocalM (fsLit "ds")
-newFailLocalDs = mkSysLocalM (fsLit "fail")
-
-newSysLocalsDs :: [Scaled Type] -> DsM [Id]
-newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t)
-
-{-
-We can also reach out and either set/grab location information from
-the @SrcSpan@ being carried around.
--}
-
-getGhcModeDs :: DsM GhcMode
-getGhcModeDs =  getDynFlags >>= return . ghcMode
-
--- | Get the current pattern match oracle state. See 'dsl_nablas'.
-getPmNablas :: DsM Nablas
-getPmNablas = do { env <- getLclEnv; return (dsl_nablas env) }
-
--- | Set the pattern match oracle state within the scope of the given action.
--- See 'dsl_nablas'.
-updPmNablas :: Nablas -> DsM a -> DsM a
-updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas })
-
-getSrcSpanDs :: DsM SrcSpan
-getSrcSpanDs = do { env <- getLclEnv
-                  ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) }
-
-putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
-putSrcSpanDs (UnhelpfulSpan {}) thing_inside
-  = thing_inside
-putSrcSpanDs (RealSrcSpan real_span _) thing_inside
-  = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
-
-putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a
-putSrcSpanDsA loc = putSrcSpanDs (locA loc)
-
--- | Emit a diagnostic for the current source location. In case the diagnostic is a warning,
--- the latter will be ignored and discarded if the relevant 'WarningFlag' is not set in the DynFlags.
--- See Note [Discarding Messages] in 'GHC.Types.Error'.
-diagnosticDs :: DsMessage -> DsM ()
-diagnosticDs dsMessage
-  = do { env <- getGblEnv
-       ; loc <- getSrcSpanDs
-       ; !diag_opts <- initDiagOpts <$> getDynFlags
-       ; let msg = mkMsgEnvelope diag_opts loc (ds_name_ppr_ctx env) dsMessage
-       ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
-
--- | Issue an error, but return the expression for (), so that we can continue
--- reporting errors.
-errDsCoreExpr :: DsMessage -> DsM CoreExpr
-errDsCoreExpr msg
-  = do { diagnosticDs msg
-       ; return unitExpr }
-
-failWithDs :: DsMessage -> DsM a
-failWithDs msg
-  = do  { diagnosticDs msg
-        ; failM }
-
-failDs :: DsM a
-failDs = failM
-
-mkNamePprCtxDs :: DsM NamePprCtx
-mkNamePprCtxDs = ds_name_ppr_ctx <$> getGblEnv
-
-instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
-    lookupThing = dsLookupGlobal
-
-dsLookupGlobal :: Name -> DsM TyThing
--- Very like GHC.Tc.Utils.Env.tcLookupGlobal
-dsLookupGlobal name
-  = do  { env <- getGblEnv
-        ; setEnvs (ds_if_env env)
-                  (tcIfaceGlobal name) }
-
-dsLookupGlobalId :: Name -> DsM Id
-dsLookupGlobalId name
-  = tyThingId <$> dsLookupGlobal name
-
-dsLookupTyCon :: Name -> DsM TyCon
-dsLookupTyCon name
-  = tyThingTyCon <$> dsLookupGlobal name
-
-dsLookupDataCon :: Name -> DsM DataCon
-dsLookupDataCon name
-  = tyThingDataCon <$> dsLookupGlobal name
-
-dsLookupConLike :: Name -> DsM ConLike
-dsLookupConLike name
-  = tyThingConLike <$> dsLookupGlobal name
-
-
-dsGetFamInstEnvs :: DsM FamInstEnvs
--- Gets both the external-package inst-env
--- and the home-pkg inst env (includes module being compiled)
-dsGetFamInstEnvs
-  = do { eps <- getEps; env <- getGblEnv
-       ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
-
-dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
-dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
-
--- | The @COMPLETE@ pragmas that are in scope.
-dsGetCompleteMatches :: DsM CompleteMatches
-dsGetCompleteMatches = ds_complete_matches <$> getGblEnv
-
-dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
-dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
-
-dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
-dsExtendMetaEnv menv thing_inside
-  = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
-
-discardWarningsDs :: DsM a -> DsM a
--- Ignore warnings inside the thing inside;
--- used to ignore inaccessible cases etc. inside generated code
-discardWarningsDs thing_inside
-  = do  { env <- getGblEnv
-        ; old_msgs <- readTcRef (ds_msgs env)
-
-        ; result <- thing_inside
-
-        -- Revert messages to old_msgs
-        ; writeTcRef (ds_msgs env) old_msgs
-
-        ; return result }
-
--- | Inject a trace message into the compiled program. Whereas
--- pprTrace prints out information *while compiling*, pprRuntimeTrace
--- captures that information and causes it to be printed *at runtime*
--- using Debug.Trace.trace.
---
---   pprRuntimeTrace hdr doc expr
---
--- will produce an expression that looks like
---
---   trace (hdr + doc) expr
---
--- When using this to debug a module that Debug.Trace depends on,
--- it is necessary to import {-# SOURCE #-} Debug.Trace () in that
--- module. We could avoid this inconvenience by wiring in Debug.Trace.trace,
--- but that doesn't seem worth the effort and maintenance cost.
-pprRuntimeTrace :: String   -- ^ header
-                -> SDoc     -- ^ information to output
-                -> CoreExpr -- ^ expression
-                -> DsM CoreExpr
-pprRuntimeTrace str doc expr = do
-  traceId <- dsLookupGlobalId traceName
-  unpackCStringId <- dsLookupGlobalId unpackCStringName
-  dflags <- getDynFlags
-  let message :: CoreExpr
-      message = App (Var unpackCStringId) $
-                Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc)
-  return $ mkApps (Var traceId) [Type (exprType expr), message, expr]
-
--- | See 'getCCIndexM'.
-getCCIndexDsM :: FastString -> DsM CostCentreIndex
-getCCIndexDsM = getCCIndexM ds_cc_st
diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Pmc.hs
+++ /dev/null
@@ -1,484 +0,0 @@
-
-{-# LANGUAGE FlexibleInstances  #-}
-{-# LANGUAGE GADTs              #-}
-{-# LANGUAGE LambdaCase         #-}
-{-# LANGUAGE StandaloneDeriving #-}
-
--- | This module coverage checks pattern matches. It finds
---
---     * Uncovered patterns, certifying non-exhaustivity
---     * Redundant equations
---     * Equations with an inaccessible right-hand-side
---
--- The algorithm is based on the paper
--- [Lower Your Guards: A Compositional Pattern-Match Coverage Checker"](https://dl.acm.org/doi/abs/10.1145/3408989)
---
--- There is an overview Figure 2 in there that's probably helpful.
--- Here is an overview of how it's implemented, which follows the structure of
--- the entry points such as 'pmcMatches':
---
---  1. Desugar source syntax (like 'LMatch') to guard tree variants (like
---     'GrdMatch'), with one of the desugaring functions (like 'desugarMatch').
---     See "GHC.HsToCore.Pmc.Desugar".
---     Follows Section 3.1 in the paper.
---  2. Coverage check guard trees (with a function like 'checkMatch') to get a
---     'CheckResult'. See "GHC.HsToCore.Pmc.Check".
---     The normalised refinement types 'Nabla' are tested for inhabitants by
---     "GHC.HsToCore.Pmc.Solver".
---  3. Collect redundancy information into a 'CIRB' with a function such
---     as 'cirbsMatch'. Follows the R function from Figure 6 of the paper.
---  4. Format and report uncovered patterns and redundant equations ('CIRB')
---     with 'formatReportWarnings'. Basically job of the G function, plus proper
---     pretty printing of the warnings (Section 5.4 of the paper).
---  5. Return 'Nablas' reaching syntactic sub-components for
---     Note [Long-distance information]. Collected by functions such as
---     'ldiMatch'. See Section 4.1 of the paper.
-module GHC.HsToCore.Pmc (
-        -- Checking and printing
-        pmcPatBind, pmcMatches, pmcGRHSs,
-        isMatchContextPmChecked,
-
-        -- See Note [Long-distance information]
-        addTyCs, addCoreScrutTmCs, addHsScrutTmCs
-    ) where
-
-import GHC.Prelude
-
-import GHC.HsToCore.Errors.Types
-import GHC.HsToCore.Pmc.Types
-import GHC.HsToCore.Pmc.Utils
-import GHC.HsToCore.Pmc.Desugar
-import GHC.HsToCore.Pmc.Check
-import GHC.HsToCore.Pmc.Solver
-import GHC.Types.Basic (Origin(..))
-import GHC.Core (CoreExpr)
-import GHC.Driver.Session
-import GHC.Hs
-import GHC.Types.Id
-import GHC.Types.SrcLoc
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Types.Var (EvVar)
-import GHC.Tc.Utils.TcType (evVarPred)
-import GHC.Tc.Utils.Monad (updTopFlags)
-import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr)
-import GHC.HsToCore.Monad
-import GHC.Data.Bag
-import GHC.Data.IOEnv (unsafeInterleaveM)
-import GHC.Data.OrdList
-import GHC.Utils.Monad (mapMaybeM)
-
-import Control.Monad (when, forM_)
-import qualified Data.Semigroup as Semi
-import Data.List.NonEmpty ( NonEmpty(..) )
-import qualified Data.List.NonEmpty as NE
-import Data.Coerce
-
---
--- * Exported entry points to the checker
---
-
--- | A non-empty delta that is initialised from the ambient refinement type
--- capturing long-distance information, or the trivially habitable 'Nablas' if
--- the former is uninhabited.
--- See Note [Recovering from unsatisfiable pattern-matching constraints].
-getLdiNablas :: DsM Nablas
-getLdiNablas = do
-  nablas <- getPmNablas
-  isInhabited nablas >>= \case
-    True  -> pure nablas
-    False -> pure initNablas
-
--- | We need to call the Hs desugarer to get the Core of a let-binding or where
--- clause. We don't want to run the coverage checker when doing so! Efficiency
--- is one concern, but also a lack of properly set up long-distance information
--- might trigger warnings that we normally wouldn't emit.
-noCheckDs :: DsM a -> DsM a
-noCheckDs = updTopFlags (\dflags -> foldl' wopt_unset dflags allPmCheckWarnings)
-
--- | Check a pattern binding (let, where) for exhaustiveness.
-pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM ()
--- See Note [pmcPatBind only checks PatBindRhs]
-pmcPatBind ctxt@(DsMatchContext PatBindRhs loc) var p = do
-  !missing <- getLdiNablas
-  pat_bind <- noCheckDs $ desugarPatBind loc var p
-  tracePm "pmcPatBind {" (vcat [ppr ctxt, ppr var, ppr p, ppr pat_bind, ppr missing])
-  result <- unCA (checkPatBind pat_bind) missing
-  tracePm "}: " (ppr (cr_uncov result))
-  formatReportWarnings ReportPatBind ctxt [var] result
-pmcPatBind _ _ _ = pure ()
-
--- | Exhaustive for guard matches, is used for guards in pattern bindings and
--- in @MultiIf@ expressions. Returns the 'Nablas' covered by the RHSs.
-pmcGRHSs
-  :: HsMatchContext GhcRn         -- ^ Match context, for warning messages
-  -> GRHSs GhcTc (LHsExpr GhcTc)  -- ^ The GRHSs to check
-  -> DsM (NonEmpty Nablas)        -- ^ Covered 'Nablas' for each RHS, for long
-                                  --   distance info
-pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do
-  let combined_loc = foldl1 combineSrcSpans (map getLocA grhss)
-      ctxt = DsMatchContext hs_ctxt combined_loc
-  !missing <- getLdiNablas
-  matches  <- noCheckDs $ desugarGRHSs combined_loc empty guards
-  tracePm "pmcGRHSs" (hang (vcat [ppr ctxt
-                                , text "Guards:"])
-                                2
-                                (pprGRHSs hs_ctxt guards $$ ppr missing))
-  result <- unCA (checkGRHSs matches) missing
-  tracePm "}: " (ppr (cr_uncov result))
-  formatReportWarnings ReportGRHSs ctxt [] result
-  return (ldiGRHSs (cr_ret result))
-
--- | Check a list of syntactic 'Match'es (part of case, functions, etc.), each
--- with a 'Pat' and one or more 'GRHSs':
---
--- @
---   f x y | x == y    = 1   -- match on x and y with two guarded RHSs
---         | otherwise = 2
---   f _ _             = 3   -- clause with a single, un-guarded RHS
--- @
---
--- Returns one non-empty 'Nablas' for 1.) each pattern of a 'Match' and 2.)
--- each of a 'Match'es 'GRHS' for Note [Long-distance information].
---
--- Special case: When there are /no matches/, then the functionassumes it
--- checks and @-XEmptyCase@ with only a single match variable.
--- See Note [Checking EmptyCase].
-pmcMatches
-  :: DsMatchContext                  -- ^ Match context, for warnings messages
-  -> [Id]                            -- ^ Match variables, i.e. x and y above
-  -> [LMatch GhcTc (LHsExpr GhcTc)]  -- ^ List of matches
-  -> DsM [(Nablas, NonEmpty Nablas)] -- ^ One covered 'Nablas' per Match and
-                                     --   GRHS, for long distance info.
-pmcMatches ctxt vars matches = {-# SCC "pmcMatches" #-} do
-  -- We have to force @missing@ before printing out the trace message,
-  -- otherwise we get interleaved output from the solver. This function
-  -- should be strict in @missing@ anyway!
-  !missing <- getLdiNablas
-  tracePm "pmcMatches {" $
-          hang (vcat [ppr ctxt, ppr vars, text "Matches:"])
-               2
-               (vcat (map ppr matches) $$ ppr missing)
-  case NE.nonEmpty matches of
-    Nothing -> do
-      -- This must be an -XEmptyCase. See Note [Checking EmptyCase]
-      let var = only vars
-      empty_case <- noCheckDs $ desugarEmptyCase var
-      result <- unCA (checkEmptyCase empty_case) missing
-      tracePm "}: " (ppr (cr_uncov result))
-      formatReportWarnings ReportEmptyCase ctxt vars result
-      return []
-    Just matches -> do
-      matches <- {-# SCC "desugarMatches" #-}
-                 noCheckDs $ desugarMatches vars matches
-      result  <- {-# SCC "checkMatchGroup" #-}
-                 unCA (checkMatchGroup matches) missing
-      tracePm "}: " (ppr (cr_uncov result))
-      {-# SCC "formatReportWarnings" #-} formatReportWarnings ReportMatchGroup ctxt vars result
-      return (NE.toList (ldiMatchGroup (cr_ret result)))
-
-{- Note [pmcPatBind only checks PatBindRhs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-@pmcPatBind@'s sole purpose is to check vanilla pattern bindings, like
-@x :: Int; Just x = e@, which is in a @PatBindRhs@ context.
-But its caller is also called for individual pattern guards in a @StmtCtxt@.
-For example, both pattern guards in @f x y | True <- x, False <- y = ...@ will
-go through this function. It makes no sense to do coverage checking there:
-  * Pattern guards may well fail. Fall-through is not an unrecoverable panic,
-    but rather behavior the programmer expects, so inexhaustivity should not be
-    reported.
-  * Redundancy is already reported for the whole GRHS via one of the other
-    exported coverage checking functions. Also reporting individual redundant
-    guards is... redundant. See #17646.
-Note that we can't just omit checking of @StmtCtxt@ altogether (by adjusting
-'isMatchContextPmChecked'), because that affects the other checking functions,
-too.
--}
-
---
--- * Collecting long-distance information
---
-
-ldiMatchGroup :: PmMatchGroup Post -> NonEmpty (Nablas, NonEmpty Nablas)
-ldiMatchGroup (PmMatchGroup matches) = ldiMatch <$> matches
-
-ldiMatch :: PmMatch Post -> (Nablas, NonEmpty Nablas)
-ldiMatch (PmMatch { pm_pats = red, pm_grhss = grhss }) =
-  (rs_cov red, ldiGRHSs grhss)
-
-ldiGRHSs :: PmGRHSs Post -> NonEmpty Nablas
-ldiGRHSs (PmGRHSs { pgs_grhss = grhss }) = ldiGRHS <$> grhss
-
-ldiGRHS :: PmGRHS Post -> Nablas
-ldiGRHS (PmGRHS { pg_grds = red }) = rs_cov red
-
---
--- * Collecting redundancy information
---
-
--- | The result of redundancy checking:
---    * RHSs classified as /C/overed, /I/naccessible and /R/edundant
---    * And redundant /B/ang patterns. See Note [Dead bang patterns].
-data CIRB
-  = CIRB
-  { cirb_cov   :: !(OrdList SrcInfo) -- ^ Covered clauses
-  , cirb_inacc :: !(OrdList SrcInfo) -- ^ Inaccessible clauses
-  , cirb_red   :: !(OrdList SrcInfo) -- ^ Redundant clauses
-  , cirb_bangs :: !(OrdList SrcInfo) -- ^ Redundant bang patterns
-  }
-
-instance Semigroup CIRB where
-  CIRB a b c d <> CIRB e f g h = CIRB (a <> e) (b <> f) (c <> g) (d <> h)
-    where (<>) = (Semi.<>)
-
-instance Monoid CIRB where
-  mempty = CIRB mempty mempty mempty mempty
-
--- See Note [Determining inaccessible clauses]
-ensureOneNotRedundant :: CIRB -> CIRB
-ensureOneNotRedundant ci = case ci of
-  CIRB { cirb_cov = NilOL, cirb_inacc = NilOL, cirb_red = ConsOL r rs }
-    -> ci { cirb_inacc = unitOL r, cirb_red = rs }
-  _ -> ci
-
--- | Only adds the redundant bangs to the @CIRB@ if there is at least one
--- non-redundant 'SrcInfo'. There is no point in remembering a redundant bang
--- if the whole match is redundant!
-addRedundantBangs :: OrdList SrcInfo -> CIRB -> CIRB
-addRedundantBangs _red_bangs cirb@CIRB { cirb_cov = NilOL, cirb_inacc = NilOL } =
-  cirb
-addRedundantBangs red_bangs  cirb =
-  cirb { cirb_bangs = cirb_bangs cirb Semi.<> red_bangs }
-
--- | Checks the 'Nablas' in a 'RedSets' for inhabitants and returns
---    1. Whether the Covered set was inhabited
---    2. Whether the Diverging set was inhabited
---    3. All source bangs whose 'Nablas' were empty, which means they are
---       redundant.
-testRedSets :: RedSets -> DsM (Bool, Bool, OrdList SrcInfo)
-testRedSets RedSets { rs_cov = cov, rs_div = div, rs_bangs = bangs } = do
-  is_covered  <- isInhabited cov
-  may_diverge <- isInhabited div
-  red_bangs   <- flip mapMaybeM (fromOL bangs) $ \(nablas, bang) ->
-    isInhabited nablas >>= \case
-      True  -> pure Nothing
-      False -> pure (Just bang)
-  pure (is_covered, may_diverge, toOL red_bangs)
-
-cirbsMatchGroup :: PmMatchGroup Post -> DsM CIRB
-cirbsMatchGroup (PmMatchGroup matches) =
-  Semi.sconcat <$> traverse cirbsMatch matches
-
-cirbsMatch :: PmMatch Post -> DsM CIRB
-cirbsMatch PmMatch { pm_pats = red, pm_grhss = grhss } = do
-  (_is_covered, may_diverge, red_bangs) <- testRedSets red
-  -- Don't look at is_covered: If it is True, all children are redundant anyway,
-  -- unless there is a 'considerAccessible', which may break that rule
-  -- intentionally. See Note [considerAccessible] in "GHC.HsToCore.Pmc.Check".
-  cirb <- cirbsGRHSs grhss
-  pure $ addRedundantBangs red_bangs
-       -- See Note [Determining inaccessible clauses]
-       $ applyWhen may_diverge ensureOneNotRedundant
-       $ cirb
-
-cirbsGRHSs :: PmGRHSs Post -> DsM CIRB
-cirbsGRHSs (PmGRHSs { pgs_grhss = grhss }) = Semi.sconcat <$> traverse cirbsGRHS grhss
-
-cirbsGRHS :: PmGRHS Post -> DsM CIRB
-cirbsGRHS PmGRHS { pg_grds = red, pg_rhs = info } = do
-  (is_covered, may_diverge, red_bangs) <- testRedSets red
-  let cirb | is_covered  = mempty { cirb_cov   = unitOL info }
-           | may_diverge = mempty { cirb_inacc = unitOL info }
-           | otherwise   = mempty { cirb_red   = unitOL info }
-  pure (addRedundantBangs red_bangs cirb)
-
-cirbsEmptyCase :: PmEmptyCase -> DsM CIRB
-cirbsEmptyCase _ = pure mempty
-
-cirbsPatBind :: PmPatBind Post -> DsM CIRB
-cirbsPatBind = coerce cirbsGRHS
-
-{- Note [Determining inaccessible clauses]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  f _  True = ()
-  f () True = ()
-  f _  _    = ()
-Is f's second clause redundant? The perhaps surprising answer is, no, it isn't!
-@f (error "boom") False@ will force the error with clause 2, but will return
-() if it was deleted, so clearly not redundant. Yet for now combination of
-arguments we can ever reach clause 2's RHS, so we say it has inaccessible RHS
-(as opposed to being completely redundant).
-
-We detect an inaccessible RHS simply by pretending it's redundant, until we see
--}
-
---
--- * Formatting and reporting warnings
---
-
--- | A datatype to accommodate the different call sites of
--- 'formatReportWarnings'. Used for extracting 'CIRB's from a concrete 'ann'
--- through 'collectInMode'. Since this is only possible for a couple of
--- well-known 'ann's, this is a GADT.
-data FormatReportWarningsMode ann where
-  ReportPatBind :: FormatReportWarningsMode (PmPatBind Post)
-  ReportGRHSs   :: FormatReportWarningsMode (PmGRHSs Post)
-  ReportMatchGroup:: FormatReportWarningsMode (PmMatchGroup Post)
-  ReportEmptyCase:: FormatReportWarningsMode PmEmptyCase
-
-deriving instance Eq (FormatReportWarningsMode ann)
-
--- | A function collecting 'CIRB's for each of the different
--- 'FormatReportWarningsMode's.
-collectInMode :: FormatReportWarningsMode ann -> ann -> DsM CIRB
-collectInMode ReportPatBind    = cirbsPatBind
-collectInMode ReportGRHSs      = cirbsGRHSs
-collectInMode ReportMatchGroup = cirbsMatchGroup
-collectInMode ReportEmptyCase  = cirbsEmptyCase
-
--- | Given a 'FormatReportWarningsMode', this function will emit warnings
--- for a 'CheckResult'.
-formatReportWarnings :: FormatReportWarningsMode ann -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()
-formatReportWarnings report_mode ctx vars cr@CheckResult { cr_ret = ann } = do
-  cov_info <- collectInMode report_mode ann
-  dflags <- getDynFlags
-  reportWarnings dflags report_mode ctx vars cr{cr_ret=cov_info}
-
--- | Issue all the warnings
--- (redundancy, inaccessibility, exhaustiveness, redundant bangs).
-reportWarnings :: DynFlags -> FormatReportWarningsMode ann -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()
-reportWarnings dflags report_mode (DsMatchContext kind loc) vars
-  CheckResult { cr_ret    = CIRB { cirb_inacc = inaccessible_rhss
-                                 , cirb_red   = redundant_rhss
-                                 , cirb_bangs = redundant_bangs }
-              , cr_uncov  = uncovered
-              , cr_approx = precision }
-  = when (flag_i || flag_u || flag_b) $ do
-      unc_examples <- getNFirstUncovered gen_mode vars (maxPatterns + 1) uncovered
-      let exists_r = flag_i && notNull redundant_rhss
-          exists_i = flag_i && notNull inaccessible_rhss
-          exists_u = flag_u && notNull unc_examples
-          exists_b = flag_b && notNull redundant_bangs
-          approx   = precision == Approximate
-
-      when (approx && (exists_u || exists_i)) $
-        putSrcSpanDs loc (diagnosticDs (DsMaxPmCheckModelsReached (maxPmCheckModels dflags)))
-
-      when exists_b $ forM_ redundant_bangs $ \(SrcInfo (L l q)) ->
-        putSrcSpanDs l (diagnosticDs (DsRedundantBangPatterns kind q))
-
-      when exists_r $ forM_ redundant_rhss $ \(SrcInfo (L l q)) ->
-        putSrcSpanDs l (diagnosticDs (DsOverlappingPatterns kind q))
-      when exists_i $ forM_ inaccessible_rhss $ \(SrcInfo (L l q)) ->
-        putSrcSpanDs l (diagnosticDs (DsInaccessibleRhs kind q))
-
-      when exists_u $
-        putSrcSpanDs loc (diagnosticDs (DsNonExhaustivePatterns kind check_type maxPatterns vars unc_examples))
-  where
-    flag_i = overlapping dflags kind
-    flag_u = exhaustive dflags kind
-    flag_b = redundantBang dflags
-    check_type = ExhaustivityCheckType (exhaustiveWarningFlag kind)
-    gen_mode = case report_mode of -- See Note [Case split inhabiting patterns]
-      ReportEmptyCase -> CaseSplitTopLevel
-      _               -> MinimalCover
-
-    maxPatterns = maxUncoveredPatterns dflags
-
-getNFirstUncovered :: GenerateInhabitingPatternsMode -> [Id] -> Int -> Nablas -> DsM [Nabla]
-getNFirstUncovered mode vars n (MkNablas nablas) = go n (bagToList nablas)
-  where
-    go 0 _              = pure []
-    go _ []             = pure []
-    go n (nabla:nablas) = do
-      front <- generateInhabitingPatterns mode vars n nabla
-      back <- go (n - length front) nablas
-      pure (front ++ back)
-
---
--- * Adding external long-distance information
---
-
--- | Locally update 'dsl_nablas' with the given action, but defer evaluation
--- with 'unsafeInterleaveM' in order not to do unnecessary work.
-locallyExtendPmNablas :: (Nablas -> DsM Nablas) -> DsM a -> DsM a
-locallyExtendPmNablas ext k = do
-  nablas <- getLdiNablas
-  nablas' <- unsafeInterleaveM $ ext nablas
-  updPmNablas nablas' k
-
--- | Add in-scope type constraints if the coverage checker might run and then
--- run the given action.
-addTyCs :: Origin -> Bag EvVar -> DsM a -> DsM a
-addTyCs origin ev_vars m = do
-  dflags <- getDynFlags
-  applyWhen (needToRunPmCheck dflags origin)
-            (locallyExtendPmNablas $ \nablas ->
-              addPhiCtsNablas nablas (PhiTyCt . evVarPred <$> ev_vars))
-            m
-
--- | Add equalities for the 'CoreExpr' scrutinees to the local 'DsM' environment,
--- e.g. when checking a case expression:
---     case e of x { matches }
--- When checking matches we record that (x ~ e) where x is the initial
--- uncovered. All matches will have to satisfy this equality.
--- This is also used for the Arrows \cases command, where these equalities have
--- to be added for multiple scrutinees rather than just one.
-addCoreScrutTmCs :: [CoreExpr] -> [Id] -> DsM a -> DsM a
-addCoreScrutTmCs []         _      k = k
-addCoreScrutTmCs (scr:scrs) (x:xs) k =
-  flip locallyExtendPmNablas (addCoreScrutTmCs scrs xs k) $ \nablas ->
-    addPhiCtsNablas nablas (unitBag (PhiCoreCt x scr))
-addCoreScrutTmCs _   _   _ = panic "addCoreScrutTmCs: numbers of scrutinees and match ids differ"
-
--- | 'addCoreScrutTmCs', but desugars the 'LHsExpr's first.
-addHsScrutTmCs :: [LHsExpr GhcTc] -> [Id] -> DsM a -> DsM a
-addHsScrutTmCs scrs vars k = do
-  scr_es <- traverse dsLExpr scrs
-  addCoreScrutTmCs scr_es vars k
-
-{- Note [Long-distance information]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-  data Color = R | G | B
-  f :: Color -> Int
-  f R = …
-  f c = … (case c of
-          G -> True
-          B -> False) …
-
-Humans can make the "long-distance connection" between the outer pattern match
-and the nested case pattern match to see that the inner pattern match is
-exhaustive: @c@ can't be @R@ anymore because it was matched in the first clause
-of @f@.
-
-To achieve similar reasoning in the coverage checker, we keep track of the set
-of values that can reach a particular program point (often loosely referred to
-as "Covered set") in 'GHC.HsToCore.Monad.dsl_nablas'.
-We fill that set with Covered Nablas returned by the exported checking
-functions, which the call sites put into place with
-'GHC.HsToCore.Monad.updPmNablas'.
-Call sites also extend this set with facts from type-constraint dictionaries,
-case scrutinees, etc. with the exported functions 'addTyCs', 'addCoreScrutTmCs'
-and 'addHsScrutTmCs'.
-
-Note [Recovering from unsatisfiable pattern-matching constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider the following code (see #12957 and #15450):
-
-  f :: Int ~ Bool => ()
-  f = case True of { False -> () }
-
-We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC
-used not to do this; in fact, it would warn that the match was /redundant/!
-This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the
-coverage checker deems any matches with unsatisfiable constraint sets to be
-unreachable.
-
-We make sure to always start from an inhabited 'Nablas' by calling
-'getLdiNablas', which falls back to the trivially inhabited 'Nablas' if the
-long-distance info returned by 'GHC.HsToCore.Monad.getPmNablas' is empty.
--}
diff --git a/compiler/GHC/HsToCore/Pmc/Check.hs b/compiler/GHC/HsToCore/Pmc/Check.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Pmc/Check.hs
+++ /dev/null
@@ -1,351 +0,0 @@
-
-{-# LANGUAGE DeriveFunctor     #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs             #-}
-
--- | Coverage checking step of the
--- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989).
---
--- Coverage check guard trees (like @'PmMatch' 'Pre'@) to get a
--- 'CheckResult', containing
---
---   1. The set of uncovered values, 'cr_uncov'
---   2. And an annotated tree variant (like @'PmMatch' 'Post'@) that captures
---      redundancy and inaccessibility information as 'RedSets' annotations
---
--- Basically the UA function from Section 5.1, which is an optimised
--- interleaving of U and A from Section 3.2 (Figure 5).
--- The Normalised Refinement Types 'Nablas' are maintained in
--- "GHC.HsToCore.Pmc.Solver".
-module GHC.HsToCore.Pmc.Check (
-        CheckAction(..),
-        checkMatchGroup, checkGRHSs, checkPatBind, checkEmptyCase
-    ) where
-
-import GHC.Prelude
-
-import GHC.Builtin.Names ( hasKey, considerAccessibleIdKey, trueDataConKey )
-import GHC.HsToCore.Monad ( DsM )
-import GHC.HsToCore.Pmc.Types
-import GHC.HsToCore.Pmc.Utils
-import GHC.HsToCore.Pmc.Solver
-import GHC.Driver.Session
-import GHC.Utils.Outputable
-import GHC.Tc.Utils.TcType (evVarPred)
-import GHC.Data.OrdList
-
-import qualified Data.Semigroup as Semi
-import Data.List.NonEmpty ( NonEmpty(..) )
-import qualified Data.List.NonEmpty as NE
-import Data.Coerce
-
--- | Coverage checking action. Can be composed 'leftToRight' or 'topToBottom'.
-newtype CheckAction a = CA { unCA :: Nablas -> DsM (CheckResult a) }
-  deriving Functor
-
--- | Composes 'CheckAction's top-to-bottom:
--- If a value falls through the resulting action, then it must fall through the
--- first action and then through the second action.
--- If a value matches the resulting action, then it either matches the
--- first action or matches the second action.
--- Basically the semantics of the LYG branching construct.
-topToBottom :: (top -> bot -> ret)
-            -> CheckAction top
-            -> CheckAction bot
-            -> CheckAction ret
-topToBottom f (CA top) (CA bot) = CA $ \inc -> do
-  t <- top inc
-  b <- bot (cr_uncov t)
-  pure CheckResult { cr_ret = f (cr_ret t) (cr_ret b)
-                   , cr_uncov = cr_uncov b
-                   , cr_approx = cr_approx t Semi.<> cr_approx b }
-
-
--- | Composes 'CheckAction's left-to-right:
--- If a value falls through the resulting action, then it either falls through the
--- first action or through the second action.
--- If a value matches the resulting action, then it must match the first action
--- and then match the second action.
--- Basically the semantics of the LYG guard construct.
-leftToRight :: (RedSets -> right -> ret)
-            -> CheckAction RedSets
-            -> CheckAction right
-            -> CheckAction ret
-leftToRight f (CA left) (CA right) = CA $ \inc -> do
-  l <- left inc
-  r <- right (rs_cov (cr_ret l))
-  limit <- maxPmCheckModels <$> getDynFlags
-  let uncov = cr_uncov l Semi.<> cr_uncov r
-  -- See Note [Countering exponential blowup]
-  let (prec', uncov') = throttle limit inc uncov
-  pure CheckResult { cr_ret = f (cr_ret l) (cr_ret r)
-                   , cr_uncov = uncov'
-                   , cr_approx = prec' Semi.<> cr_approx l Semi.<> cr_approx r }
-
--- | @throttle limit old new@ returns @old@ if the number of 'Nabla's in @new@
--- is exceeding the given @limit@ and the @old@ number of 'Nabla's.
--- See Note [Countering exponential blowup].
-throttle :: Int -> Nablas -> Nablas -> (Precision, Nablas)
-throttle limit old@(MkNablas old_ds) new@(MkNablas new_ds)
-  --- | pprTrace "PmCheck:throttle" (ppr (length old_ds) <+> ppr (length new_ds) <+> ppr limit) False = undefined
-  | length new_ds > max limit (length old_ds) = (Approximate, old)
-  | otherwise                                 = (Precise,     new)
-
-checkSequence :: (grdtree -> CheckAction anntree) -> NonEmpty grdtree -> CheckAction (NonEmpty anntree)
--- The implementation is pretty similar to
--- @traverse1 :: Apply f => (a -> f b) -> NonEmpty a -> f (NonEmpty b)@
-checkSequence act (t :| [])       = (:| []) <$> act t
-checkSequence act (t1 :| (t2:ts)) =
-  topToBottom (NE.<|) (act t1) (checkSequence act (t2:|ts))
-
-emptyRedSets :: RedSets
--- Semigroup instance would be misleading!
-emptyRedSets = RedSets mempty mempty mempty
-
-checkGrd :: PmGrd -> CheckAction RedSets
-checkGrd grd = CA $ \inc -> case grd of
-  -- let x = e: Refine with x ~ e
-  PmLet x e -> do
-    matched <- addPhiCtNablas inc (PhiCoreCt x e)
-    tracePm "check:Let" (ppr x <+> char '=' <+> ppr e)
-    pure CheckResult { cr_ret = emptyRedSets { rs_cov = matched }
-                     , cr_uncov = mempty
-                     , cr_approx = Precise }
-  -- Bang x _: Diverge on x ~ ⊥, refine with x ≁ ⊥
-  PmBang x mb_info -> do
-    div <- addPhiCtNablas inc (PhiBotCt x)
-    matched <- addPhiCtNablas inc (PhiNotBotCt x)
-    -- See Note [Dead bang patterns]
-    -- mb_info = Just info <==> PmBang originates from bang pattern in source
-    let bangs | Just info <- mb_info = unitOL (div, info)
-              | otherwise            = NilOL
-    tracePm "check:Bang" (ppr x <+> ppr div)
-    pure CheckResult { cr_ret = RedSets { rs_cov = matched, rs_div = div, rs_bangs = bangs }
-                     , cr_uncov = mempty
-                     , cr_approx = Precise }
-  -- See point (3) of Note [considerAccessible]
-  PmCon x (PmAltConLike con) _ _ _
-    | x `hasKey` considerAccessibleIdKey
-    , con `hasKey` trueDataConKey
-    -> pure CheckResult { cr_ret = emptyRedSets { rs_cov = initNablas }
-                        , cr_uncov = mempty
-                        , cr_approx = Precise }
-  -- Con: Fall through on x ≁ K and refine with x ~ K ys and type info
-  PmCon x con tvs dicts args -> do
-    !div <- if isPmAltConMatchStrict con
-      then addPhiCtNablas inc (PhiBotCt x)
-      else pure mempty
-    !matched <- addPhiCtNablas inc (PhiConCt x con tvs (map evVarPred dicts) args)
-    !uncov   <- addPhiCtNablas inc (PhiNotConCt x con)
-    tracePm "check:Con" $ vcat
-      [ ppr grd
-      , ppr inc
-      , hang (text "div") 2 (ppr div)
-      , hang (text "matched") 2 (ppr matched)
-      , hang (text "uncov") 2 (ppr uncov)
-      ]
-    pure CheckResult { cr_ret = emptyRedSets { rs_cov = matched, rs_div = div }
-                     , cr_uncov = uncov
-                     , cr_approx = Precise }
-
-checkGrds :: [PmGrd] -> CheckAction RedSets
-checkGrds [] = CA $ \inc ->
-  pure CheckResult { cr_ret = emptyRedSets { rs_cov = inc }
-                   , cr_uncov = mempty
-                   , cr_approx = Precise }
-checkGrds (g:grds) = leftToRight merge (checkGrd g) (checkGrds grds)
-  where
-    merge ri_g ri_grds = -- This operation would /not/ form a Semigroup!
-      RedSets { rs_cov   = rs_cov ri_grds
-              , rs_div   = rs_div ri_g   Semi.<> rs_div ri_grds
-              , rs_bangs = rs_bangs ri_g Semi.<> rs_bangs ri_grds }
-
-checkMatchGroup :: PmMatchGroup Pre -> CheckAction (PmMatchGroup Post)
-checkMatchGroup (PmMatchGroup matches) =
-  PmMatchGroup <$> checkSequence checkMatch matches
-
-checkMatch :: PmMatch Pre -> CheckAction (PmMatch Post)
-checkMatch (PmMatch { pm_pats = GrdVec grds, pm_grhss = grhss }) =
-  leftToRight PmMatch (checkGrds grds) (checkGRHSs grhss)
-
-checkGRHSs :: PmGRHSs Pre -> CheckAction (PmGRHSs Post)
-checkGRHSs (PmGRHSs { pgs_lcls = GrdVec lcls, pgs_grhss = grhss }) =
-  leftToRight PmGRHSs (checkGrds lcls) (checkSequence checkGRHS grhss)
-
-checkGRHS :: PmGRHS Pre -> CheckAction (PmGRHS Post)
-checkGRHS (PmGRHS { pg_grds = GrdVec grds, pg_rhs = rhs_info }) =
-  flip PmGRHS rhs_info <$> checkGrds grds
-
-checkEmptyCase :: PmEmptyCase -> CheckAction PmEmptyCase
--- See Note [Checking EmptyCase]
-checkEmptyCase pe@(PmEmptyCase { pe_var = var }) = CA $ \inc -> do
-  unc <- addPhiCtNablas inc (PhiNotBotCt var)
-  pure CheckResult { cr_ret = pe, cr_uncov = unc, cr_approx = mempty }
-
-checkPatBind :: (PmPatBind Pre) -> CheckAction (PmPatBind Post)
-checkPatBind = coerce checkGRHS
-
-{- Note [Checking EmptyCase]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--XEmptyCase is useful for matching on empty data types like 'Void'. For example,
-the following is a complete match:
-
-    f :: Void -> ()
-    f x = case x of {}
-
-Really, -XEmptyCase is the only way to write a program that at the same time is
-safe (@f _ = error "boom"@ is not because of ⊥), doesn't trigger a warning
-(@f !_ = error "inaccessible" has inaccessible RHS) and doesn't turn an
-exception into divergence (@f x = f x@).
-
-Semantically, unlike every other case expression, -XEmptyCase is strict in its
-match var x, which rules out ⊥ as an inhabitant. So we add x ≁ ⊥ to the
-initial Nabla and check if there are any values left to match on.
-
-Note [Dead bang patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-  f :: Bool -> Int
-  f True = 1
-  f !x   = 2
-
-Whenever we fall through to the second equation, we will already have evaluated
-the argument. Thus, the bang pattern serves no purpose and should be warned
-about. We call this kind of bang patterns "dead". Dead bangs are the ones
-that under no circumstances can force a thunk that wasn't already forced.
-Dead bangs are a form of redundant bangs; see below.
-
-We can detect dead bang patterns by checking whether @x ~ ⊥@ is satisfiable
-where the PmBang appears in 'checkGrd'. If not, then clearly the bang is
-dead. So for a source bang, we add the refined Nabla and the source info to
-the 'RedSet's 'rs_bangs'. When collecting stuff to warn, we test that Nabla for
-inhabitants. If it's empty, we'll warn that it's redundant.
-
-Note that we don't want to warn for a dead bang that appears on a redundant
-clause. That is because in that case, we recommend to delete the clause wholly,
-including its leading pattern match.
-
-Dead bang patterns are redundant. But there are bang patterns which are
-redundant that aren't dead, for example
-
-  f !() = 0
-
-the bang still forces the match variable, before we attempt to match on (). But
-it is redundant with the forcing done by the () match. We currently don't
-detect redundant bangs that aren't dead.
-
-Note [Countering exponential blowup]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Precise pattern match exhaustiveness checking is necessarily exponential in
-the size of some input programs. We implement a counter-measure in the form of
-the -fmax-pmcheck-models flag, limiting the number of Nablas we check against
-each pattern by a constant.
-
-How do we do that? Consider
-
-  f True True = ()
-  f True True = ()
-
-And imagine we set our limit to 1 for the sake of the example. The first clause
-will be checked against the initial Nabla, {}. Doing so will produce an
-Uncovered set of size 2, containing the models {x≁True} and {x~True,y≁True}.
-Also we find the first clause to cover the model {x~True,y~True}.
-
-But the Uncovered set we get out of the match is too huge! We somehow have to
-ensure not to make things worse as they are already, so we continue checking
-with a singleton Uncovered set of the initial Nabla {}. Why is this
-sound (wrt. the notion in GADTs Meet Their Match)? Well, it basically amounts
-to forgetting that we matched against the first clause. The values represented
-by {} are a superset of those represented by its two refinements {x≁True} and
-{x~True,y≁True}.
-
-This forgetfulness becomes very apparent in the example above: By continuing
-with {} we don't detect the second clause as redundant, as it again covers the
-same non-empty subset of {}. So we don't flag everything as redundant anymore,
-but still will never flag something as redundant that isn't.
-
-For exhaustivity, the converse applies: We will report @f@ as non-exhaustive
-and report @f _ _@ as missing, which is a superset of the actual missing
-matches. But soundness means we will never fail to report a missing match.
-
-This mechanism is implemented in 'throttle'.
-
-Guards are an extreme example in this regard, with #11195 being a particularly
-dreadful example: Since their RHS are often pretty much unique, we split on a
-variable (the one representing the RHS) that doesn't occur anywhere else in the
-program, so we don't actually get useful information out of that split!
-
-Note [considerAccessible]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (T18610)
-
-  f :: Bool -> Int
-  f x = case (x, x) of
-    (True,  True)  -> 1
-    (False, False) -> 2
-    (True,  False) -> 3 -- Warning: Redundant
-
-The third case is detected as redundant. But it may be the intent of the
-programmer to keep the dead code, in order for it not to bitrot or to support
-debugging scenarios. But there is no way to communicate that to the
-pattern-match checker! The only way is to deactivate pattern-match checking
-whole-sale, which is quite annoying. Hence, we define in "GHC.Exts":
-
-  considerAccessible = True
-
-'considerAccessible' is treated specially by the pattern-match checker in that a
-guard with it as the scrutinee expression will keep its parent clause alive:
-
-  g :: Bool -> Int
-  g x = case (x, x) of
-    (True,  True)  -> 1
-    (False, False) -> 2
-    (True,  False) | GHC.Exts.considerAccessible -> 3 -- No warning
-
-The key bits of the implementation are:
-
-  1. Its definition is recognised as known-key (see "GHC.Builtin.Names").
-  2. After "GHC.HsToCore.Pmc.Desugar", the guard will end up as a 'PmCon', where
-     the match var is the known-key 'considerAccessible' and the constructor
-     against which it matches is 'True'.
-  3. We recognise the 'PmCon' in 'GHC.HsToCore.Check.checkGrd' and inflate the
-     incoming set of values for all guards downstream to the unconstrained
-     'initNablas' set, e.g. /all/ values.
-     (The set of values that falls through that particular guard is empty, as
-     matching 'considerAccessible' against 'True' can't fail.)
-
-Note that 'considerAccessible' breaks the invariant that incoming sets of values
-reaching syntactic children are subsets of that of the syntactic ancestor:
-A whole match, like that of the third clause of the example, might have no
-incoming value, but its single RHS has incoming values because of (3).
-
-That means the 'is_covered' flag computed in 'GHC.HsToCore.Pmc.cirbsMatch'
-is irrelevant and should not be used to flag all children as redundant (which is
-what we used to do).
-
-We achieve great benefits with a very simple implementation.
-There are caveats, though:
-
-  (A) Putting potentially failing guards /after/ the
-      'considerAccessible' guard might lead to weird check results, e.g.,
-
-        h :: Bool -> Int
-        h x = case (x, x) of
-          (True,  True)  -> 1
-          (False, False) -> 2
-          (True,  False) | GHC.Exts.considerAccessible, False <- x -> 3
-          -- Warning: Not matched: (_, _)
-
-      That *is* fixable, although we would pay with a much more complicated
-      implementation.
-  (B) If the programmer puts a 'considerAccessible' marker on an accessible
-      clause, the checker doesn't warn about it. E.g.,
-
-        f :: Bool -> Int
-        f True | considerAccessible = 0
-        f False = 1
-
-      will not emit any warning whatsoever. We could implement code that warns
-      here, but it wouldn't be as simple as it is now.
--}
diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Pmc/Desugar.hs
+++ /dev/null
@@ -1,536 +0,0 @@
-
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs             #-}
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE DisambiguateRecordFields #-}
-
--- | Desugaring step of the
--- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989).
---
--- Desugars Haskell source syntax into guard tree variants Pm*.
--- In terms of the paper, this module is concerned with Sections 3.1, Figure 4,
--- in particular.
-module GHC.HsToCore.Pmc.Desugar (
-      desugarPatBind, desugarGRHSs, desugarMatches, desugarEmptyCase
-    ) where
-
-import GHC.Prelude
-
-import GHC.HsToCore.Pmc.Types
-import GHC.HsToCore.Pmc.Utils
-import GHC.Core (Expr(Var,App))
-import GHC.Data.FastString (unpackFS, lengthFS)
-import GHC.Data.Bag (bagToList)
-import GHC.Driver.Session
-import GHC.Hs
-import GHC.Tc.Utils.Zonk (shortCutLit)
-import GHC.Types.Id
-import GHC.Core.ConLike
-import GHC.Types.Name
-import GHC.Builtin.Types
-import GHC.Builtin.Names (rationalTyConName)
-import GHC.Types.SrcLoc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Core.DataCon
-import GHC.Types.Var (EvVar)
-import GHC.Core.Coercion
-import GHC.Tc.Types.Evidence (HsWrapper(..), isIdHsWrapper)
-import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr)
-import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper)
-import GHC.HsToCore.Utils (isTrueLHsExpr, selectMatchVar)
-import GHC.HsToCore.Match.Literal (dsLit, dsOverLit)
-import GHC.HsToCore.Monad
-import GHC.Core.TyCo.Rep
-import GHC.Core.TyCo.Compare( eqType )
-import GHC.Core.Type
-import GHC.Data.Maybe
-import qualified GHC.LanguageExtensions as LangExt
-import GHC.Utils.Monad (concatMapM)
-import GHC.Types.SourceText (FractionalLit(..))
-import Control.Monad (zipWithM)
-import Data.List (elemIndex)
-import Data.List.NonEmpty ( NonEmpty(..) )
-import qualified Data.List.NonEmpty as NE
-
--- import GHC.Driver.Ppr
-
--- | Smart constructor that eliminates trivial lets
-mkPmLetVar :: Id -> Id -> [PmGrd]
-mkPmLetVar x y | x == y = []
-mkPmLetVar x y          = [PmLet x (Var y)]
-
--- | ADT constructor pattern => no existentials, no local constraints
-vanillaConGrd :: Id -> DataCon -> [Id] -> PmGrd
-vanillaConGrd scrut con arg_ids =
-  PmCon { pm_id = scrut, pm_con_con = PmAltConLike (RealDataCon con)
-        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = arg_ids }
-
--- | Creates a '[PmGrd]' refining a match var of list type to a list,
--- where list fields are matched against the incoming tagged '[PmGrd]'s.
--- For example:
---   @mkListGrds "a" "[(x, True <- x),(y, !y)]"@
--- to
---   @"[(x:b) <- a, True <- x, (y:c) <- b, !y, [] <- c]"@
--- where @b@ and @c@ are freshly allocated in @mkListGrds@ and @a@ is the match
--- variable.
-mkListGrds :: Id -> [(Id, [PmGrd])] -> DsM [PmGrd]
--- See Note [Order of guards matters] for why we need to intertwine guards
--- on list elements.
-mkListGrds a []                  = pure [vanillaConGrd a nilDataCon []]
-mkListGrds a ((x, head_grds):xs) = do
-  b <- mkPmId (idType a)
-  tail_grds <- mkListGrds b xs
-  pure $ vanillaConGrd a consDataCon [x, b] : head_grds ++ tail_grds
-
--- | Create a '[PmGrd]' refining a match variable to a 'PmLit'.
-mkPmLitGrds :: Id -> PmLit -> DsM [PmGrd]
-mkPmLitGrds x (PmLit _ (PmLitString s)) = do
-  -- We desugar String literals to list literals for better overlap reasoning.
-  -- It's a little unfortunate we do this here rather than in
-  -- 'GHC.HsToCore.Pmc.Solver.trySolve' and
-  -- 'GHC.HsToCore.Pmc.Solver.addRefutableAltCon', but it's so much simpler
-  -- here. See Note [Representation of Strings in TmState] in
-  -- GHC.HsToCore.Pmc.Solver
-  vars <- traverse mkPmId (take (lengthFS s) (repeat charTy))
-  let mk_char_lit y c = mkPmLitGrds y (PmLit charTy (PmLitChar c))
-  char_grdss <- zipWithM mk_char_lit vars (unpackFS s)
-  mkListGrds x (zip vars char_grdss)
-mkPmLitGrds x lit = do
-  let grd = PmCon { pm_id = x
-                  , pm_con_con = PmAltLit lit
-                  , pm_con_tvs = []
-                  , pm_con_dicts = []
-                  , pm_con_args = [] }
-  pure [grd]
-
--- | @desugarPat _ x pat@ transforms @pat@ into a '[PmGrd]', where
--- the variable representing the match is @x@.
-desugarPat :: Id -> Pat GhcTc -> DsM [PmGrd]
-desugarPat x pat = case pat of
-  WildPat  _ty -> pure []
-  VarPat _ y   -> pure (mkPmLetVar (unLoc y) x)
-  ParPat _ _ p _ -> desugarLPat x p
-  LazyPat _ _  -> pure [] -- like a wildcard
-  BangPat _ p@(L l p') ->
-    -- Add the bang in front of the list, because it will happen before any
-    -- nested stuff.
-    (PmBang x pm_loc :) <$> desugarLPat x p
-      where pm_loc = Just (SrcInfo (L (locA l) (ppr p')))
-
-  -- (x@pat)   ==>   Desugar pat with x as match var and handle impedance
-  --                 mismatch with incoming match var
-  AsPat _ (L _ y) _ p -> (mkPmLetVar y x ++) <$> desugarLPat y p
-
-  SigPat _ p _ty -> desugarLPat x p
-
-  XPat ext -> case ext of
-
-    ExpansionPat orig expansion -> do
-      dflags <- getDynFlags
-      case orig of
-        -- We add special logic for overloaded list patterns. When:
-        --   - a ViewPat is the expansion of a ListPat,
-        --   - RebindableSyntax is off,
-        --   - the type of the pattern is the built-in list type,
-        -- then we assume that the view function, 'toList', is the identity.
-        -- This improves pattern-match overload checks, as this will allow
-        -- the pattern match checker to directly inspect the inner pattern.
-        -- See #14547, and Note [Desugaring overloaded list patterns] (Wrinkle).
-        ListPat {}
-          | ViewPat arg_ty _lexpr pat <- expansion
-          , not (xopt LangExt.RebindableSyntax dflags)
-          , Just tc <- tyConAppTyCon_maybe arg_ty
-          , tc == listTyCon
-          -> desugarLPat x pat
-
-        _ -> desugarPat x expansion
-
-    -- See Note [Desugar CoPats]
-    -- Generally the translation is
-    -- pat |> co   ===>   let y = x |> co, pat <- y  where y is a match var of pat
-    CoPat wrapper p _ty
-      | isIdHsWrapper wrapper                   -> desugarPat x p
-      | WpCast co <-  wrapper, isReflexiveCo co -> desugarPat x p
-      | otherwise -> do
-          (y, grds) <- desugarPatV p
-          wrap_rhs_y <- dsHsWrapper wrapper
-          pure (PmLet y (wrap_rhs_y (Var x)) : grds)
-
-  -- (n + k)  ===>   let b = x >= k, True <- b, let n = x-k
-  NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do
-    b <- mkPmId boolTy
-    let grd_b = vanillaConGrd b trueDataCon []
-    [ke1, ke2] <- traverse dsOverLit [unLoc k1, k2]
-    rhs_b <- dsSyntaxExpr ge    [Var x, ke1]
-    rhs_n <- dsSyntaxExpr minus [Var x, ke2]
-    pure [PmLet b rhs_b, grd_b, PmLet n rhs_n]
-
-  -- (fun -> pat)   ===>   let y = fun x, pat <- y where y is a match var of pat
-  ViewPat _arg_ty lexpr pat -> do
-    (y, grds) <- desugarLPatV pat
-    fun <- dsLExpr lexpr
-    pure $ PmLet y (App fun (Var x)) : grds
-
-  -- list
-  ListPat _ ps ->
-    desugarListPat x ps
-
-  ConPat { pat_con     = L _ con
-         , pat_args    = ps
-         , pat_con_ext = ConPatTc
-           { cpt_arg_tys = arg_tys
-           , cpt_tvs     = ex_tvs
-           , cpt_dicts   = dicts
-           }
-         } ->
-    desugarConPatOut x con arg_tys ex_tvs dicts ps
-
-  NPat ty (L _ olit) mb_neg _ -> do
-    -- See Note [Literal short cut] in "GHC.HsToCore.Match.Literal"
-    -- We inline the Literal short cut for @ty@ here, because @ty@ is more
-    -- precise than the field of OverLitTc, which is all that dsOverLit (which
-    -- normally does the literal short cut) can look at. Also @ty@ matches the
-    -- type of the scrutinee, so info on both pattern and scrutinee (for which
-    -- short cutting in dsOverLit works properly) is overloaded iff either is.
-    dflags <- getDynFlags
-    let platform = targetPlatform dflags
-    pm_lit <- case olit of
-      OverLit{ ol_val = val, ol_ext = OverLitTc { ol_rebindable = rebindable } }
-        | not rebindable
-        , Just expr <- shortCutLit platform val ty
-        -> coreExprAsPmLit <$> dsExpr expr
-        | not rebindable
-        , (HsFractional f) <- val
-        , negates <- if fl_neg f then 1 else 0
-        -> do
-            rat_tc <- dsLookupTyCon rationalTyConName
-            let rat_ty = mkTyConTy rat_tc
-            return $ Just $ PmLit rat_ty (PmLitOverRat negates f)
-        | otherwise
-        -> do
-           dsLit <- dsOverLit olit
-           let !pmLit = coreExprAsPmLit dsLit :: Maybe PmLit
-          --  pprTraceM "desugarPat"
-          --     (
-          --       text "val" <+> ppr val $$
-          --       text "witness" <+> ppr (ol_witness olit) $$
-          --       text "dsLit" <+> ppr dsLit $$
-          --       text "asPmLit" <+> ppr pmLit
-          --     )
-           return pmLit
-
-    let lit = case pm_lit of
-          Just l -> l
-          Nothing -> pprPanic "failed to detect OverLit" (ppr olit)
-    let lit' = case mb_neg of
-          Just _  -> expectJust "failed to negate lit" (negatePmLit lit)
-          Nothing -> lit
-    mkPmLitGrds x lit'
-
-  LitPat _ lit -> do
-    core_expr <- dsLit (convertLit lit)
-    let lit = expectJust "failed to detect Lit" (coreExprAsPmLit core_expr)
-    mkPmLitGrds x lit
-
-  TuplePat _tys pats boxity -> do
-    (vars, grdss) <- mapAndUnzipM desugarLPatV pats
-    let tuple_con = tupleDataCon boxity (length vars)
-    pure $ vanillaConGrd x tuple_con vars : concat grdss
-
-  SumPat _ty p alt arity -> do
-    (y, grds) <- desugarLPatV p
-    let sum_con = sumDataCon alt arity
-    -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
-    pure $ vanillaConGrd x sum_con [y] : grds
-
-  SplicePat {} -> panic "Check.desugarPat: SplicePat"
-
--- | 'desugarPat', but also select and return a new match var.
-desugarPatV :: Pat GhcTc -> DsM (Id, [PmGrd])
-desugarPatV pat = do
-  x <- selectMatchVar ManyTy pat
-  grds <- desugarPat x pat
-  pure (x, grds)
-
-desugarLPat :: Id -> LPat GhcTc -> DsM [PmGrd]
-desugarLPat x = desugarPat x . unLoc
-
--- | 'desugarLPat', but also select and return a new match var.
-desugarLPatV :: LPat GhcTc -> DsM (Id, [PmGrd])
-desugarLPatV = desugarPatV . unLoc
-
--- | @desugarListPat _ x [p1, ..., pn]@ is basically
---   @desugarConPatOut _ x $(mkListConPatOuts [p1, ..., pn]>@ without ever
--- constructing the 'ConPatOut's.
-desugarListPat :: Id -> [LPat GhcTc] -> DsM [PmGrd]
-desugarListPat x pats = do
-  vars_and_grdss <- traverse desugarLPatV pats
-  mkListGrds x vars_and_grdss
-
--- | Desugar a constructor pattern
-desugarConPatOut :: Id -> ConLike -> [Type] -> [TyVar]
-                 -> [EvVar] -> HsConPatDetails GhcTc -> DsM [PmGrd]
-desugarConPatOut x con univ_tys ex_tvs dicts = \case
-    PrefixCon _ ps               -> go_field_pats (zip [0..] ps)
-    InfixCon  p1 p2              -> go_field_pats (zip [0..] [p1,p2])
-    RecCon    (HsRecFields fs _) -> go_field_pats (rec_field_ps fs)
-  where
-    -- The actual argument types (instantiated)
-    arg_tys     = map scaledThing $ conLikeInstOrigArgTys con (univ_tys ++ mkTyVarTys ex_tvs)
-
-    -- Extract record field patterns tagged by field index from a list of
-    -- LHsRecField
-    rec_field_ps fs = map (tagged_pat . unLoc) fs
-      where
-        tagged_pat f = (lbl_to_index (getName (hsRecFieldId f)), hfbRHS f)
-        -- Unfortunately the label info is empty when the DataCon wasn't defined
-        -- with record field labels, hence we desugar to field index.
-        orig_lbls        = map flSelector $ conLikeFieldLabels con
-        lbl_to_index lbl = expectJust "lbl_to_index" $ elemIndex lbl orig_lbls
-
-    go_field_pats tagged_pats = do
-      -- The fields that appear might not be in the correct order. So
-      --   1. Do the PmCon match
-      --   2. Then pattern match on the fields in the order given by the first
-      --      field of @tagged_pats@.
-      -- See Note [Field match order for RecCon]
-
-      -- Desugar the mentioned field patterns. We're doing this first to get
-      -- the Ids for pm_con_args and bring them in order afterwards.
-      let trans_pat (n, pat) = do
-            (var, pvec) <- desugarLPatV pat
-            pure ((n, var), pvec)
-      (tagged_vars, arg_grdss) <- mapAndUnzipM trans_pat tagged_pats
-
-      let get_pat_id n ty = case lookup n tagged_vars of
-            Just var -> pure var
-            Nothing  -> mkPmId ty
-
-      -- 1. the constructor pattern match itself
-      arg_ids <- zipWithM get_pat_id [0..] arg_tys
-      let con_grd = PmCon x (PmAltConLike con) ex_tvs dicts arg_ids
-
-      -- 2. guards from field selector patterns
-      let arg_grds = concat arg_grdss
-
-      -- tracePm "ConPatOut" (ppr x $$ ppr con $$ ppr arg_ids)
-      pure (con_grd : arg_grds)
-
-desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre)
--- See 'GrdPatBind' for how this simply repurposes GrdGRHS.
-desugarPatBind loc var pat =
-  PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) . GrdVec <$> desugarPat var pat
-
-desugarEmptyCase :: Id -> DsM PmEmptyCase
-desugarEmptyCase var = pure PmEmptyCase { pe_var = var }
-
--- | Desugar the non-empty 'Match'es of a 'MatchGroup'.
-desugarMatches :: [Id] -> NonEmpty (LMatch GhcTc (LHsExpr GhcTc))
-               -> DsM (PmMatchGroup Pre)
-desugarMatches vars matches =
-  PmMatchGroup <$> traverse (desugarMatch vars) matches
-
--- Desugar a single match
-desugarMatch :: [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (PmMatch Pre)
-desugarMatch vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do
-  pats'  <- concat <$> zipWithM desugarLPat vars pats
-  grhss' <- desugarGRHSs (locA match_loc) (sep (map ppr pats)) grhss
-  -- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr grhss'])
-  return PmMatch { pm_pats = GrdVec pats', pm_grhss = grhss' }
-
-desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre)
-desugarGRHSs match_loc pp_pats grhss = do
-  lcls <- desugarLocalBinds (grhssLocalBinds grhss)
-  grhss' <- traverse (desugarLGRHS match_loc pp_pats)
-              . expectJust "desugarGRHSs"
-              . NE.nonEmpty
-              $ grhssGRHSs grhss
-  return PmGRHSs { pgs_lcls = GrdVec lcls, pgs_grhss = grhss' }
-
--- | Desugar a guarded right-hand side to a single 'GrdTree'
-desugarLGRHS :: SrcSpan -> SDoc -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (PmGRHS Pre)
-desugarLGRHS match_loc pp_pats (L _loc (GRHS _ gs _)) = do
-  -- _loc points to the match separator (ie =, ->) that comes after the guards.
-  -- Hence we have to pass in the match_loc, which we use in case that the RHS
-  -- is unguarded.
-  -- pp_pats is the space-separated pattern of the current Match this
-  -- GRHS belongs to, so the @A B x@ part in @A B x | 0 <- x@.
-  let rhs_info = case gs of
-        []              -> L match_loc      pp_pats
-        (L grd_loc _):_ -> L (locA grd_loc) (pp_pats <+> vbar <+> interpp'SP gs)
-  grds <- concatMapM (desugarGuard . unLoc) gs
-  pure PmGRHS { pg_grds = GrdVec grds, pg_rhs = SrcInfo rhs_info }
-
--- | Desugar a guard statement to a '[PmGrd]'
-desugarGuard :: GuardStmt GhcTc -> DsM [PmGrd]
-desugarGuard guard = case guard of
-  BodyStmt _   e _ _ -> desugarBoolGuard e
-  LetStmt  _   binds -> desugarLocalBinds binds
-  BindStmt _ p e     -> desugarBind p e
-  LastStmt        {} -> panic "desugarGuard LastStmt"
-  ParStmt         {} -> panic "desugarGuard ParStmt"
-  TransStmt       {} -> panic "desugarGuard TransStmt"
-  RecStmt         {} -> panic "desugarGuard RecStmt"
-  ApplicativeStmt {} -> panic "desugarGuard ApplicativeLastStmt"
-
--- | Desugar local bindings to a bunch of 'PmLet' guards.
--- Deals only with simple @let@ or @where@ bindings without any polymorphism,
--- recursion, pattern bindings etc.
--- See Note [Long-distance information for HsLocalBinds].
-desugarLocalBinds :: HsLocalBinds GhcTc -> DsM [PmGrd]
-desugarLocalBinds (HsValBinds _ (XValBindsLR (NValBinds binds _))) =
-  concatMapM (concatMapM go . bagToList) (map snd binds)
-  where
-    go :: LHsBind GhcTc -> DsM [PmGrd]
-    go (L _ FunBind{fun_id = L _ x, fun_matches = mg})
-      -- See Note [Long-distance information for HsLocalBinds] for why this
-      -- pattern match is so very specific.
-      | L _ [L _ Match{m_pats = [], m_grhss = grhss}] <- mg_alts mg
-      , GRHSs{grhssGRHSs = [L _ (GRHS _ _grds rhs)]} <- grhss = do
-          core_rhs <- dsLExpr rhs
-          return [PmLet x core_rhs]
-    go (L _ (XHsBindsLR (AbsBinds
-                          { abs_tvs = [], abs_ev_vars = []
-                          , abs_exports=exports, abs_binds = binds }))) = do
-      -- Typechecked HsLocalBinds are wrapped in AbsBinds, which carry
-      -- renamings. See Note [Long-distance information for HsLocalBinds]
-      -- for the details.
-      let go_export :: ABExport -> Maybe PmGrd
-          go_export ABE{abe_poly = x, abe_mono = y, abe_wrap = wrap}
-            | isIdHsWrapper wrap
-            = assertPpr (idType x `eqType` idType y)
-                        (ppr x $$ ppr (idType x) $$ ppr y $$ ppr (idType y)) $
-              Just $ PmLet x (Var y)
-            | otherwise
-            = Nothing
-      let exps = mapMaybe go_export exports
-      bs <- concatMapM go (bagToList binds)
-      return (exps ++ bs)
-    go _ = return []
-desugarLocalBinds _binds = return []
-
--- | Desugar a pattern guard
---   @pat <- e ==>  let x = e;  <guards for pat <- x>@
-desugarBind :: LPat GhcTc -> LHsExpr GhcTc -> DsM [PmGrd]
-desugarBind p e = dsLExpr e >>= \case
-  Var y
-    | Nothing <- isDataConId_maybe y
-    -- RHS is a variable, so that will allow us to omit the let
-    -> desugarLPat y p
-  rhs -> do
-    (x, grds) <- desugarLPatV p
-    pure (PmLet x rhs : grds)
-
--- | Desugar a boolean guard
---   @e ==>  let x = e; True <- x@
-desugarBoolGuard :: LHsExpr GhcTc -> DsM [PmGrd]
-desugarBoolGuard e
-  | isJust (isTrueLHsExpr e) = return []
-    -- The formal thing to do would be to generate (True <- True)
-    -- but it is trivial to solve so instead we give back an empty
-    -- [PmGrd] for efficiency
-  | otherwise = dsLExpr e >>= \case
-      Var y
-        | Nothing <- isDataConId_maybe y
-        -- Omit the let by matching on y
-        -> pure [vanillaConGrd y trueDataCon []]
-      rhs -> do
-        x <- mkPmId boolTy
-        pure [PmLet x rhs, vanillaConGrd x trueDataCon []]
-
-{- Note [Field match order for RecCon]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The order for RecCon field patterns actually determines evaluation order of
-the pattern match. For example:
-
-  data T = T { a :: Char, b :: Int }
-  f :: T -> ()
-  f T{ b = 42, a = 'a' } = ()
-
-Then @f (T (error "a") (error "b"))@ errors out with "b" because it is mentioned
-first in the pattern match.
-
-This means we can't just desugar the pattern match to
-@[T a b <- x, 'a' <- a, 42 <- b]@. Instead we have to force them in the
-right order: @[T a b <- x, 42 <- b, 'a' <- a]@.
-
-Note [Order of guards matters]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Similar to Note [Field match order for RecCon], the order in which the guards
-for a pattern match appear matter. Consider a situation similar to T5117:
-
-  f (0:_)  = ()
-  f (0:[]) = ()
-
-The latter clause is clearly redundant. Yet if we desugar the second clause as
-
-  [x:xs' <- xs, [] <- xs', 0 <- x]
-
-We will say that the second clause only has an inaccessible RHS. That's because
-we force the tail of the list before comparing its head! So the correct
-translation would have been
-
-  [x:xs' <- xs, 0 <- x, [] <- xs']
-
-And we have to take in the guards on list cells into @mkListGrds@.
-
-Note [Desugar CoPats]
-~~~~~~~~~~~~~~~~~~~~~~~
-The pattern match checker did not know how to handle coerced patterns
-`CoPat` efficiently, which gave rise to #11276. The original approach
-desugared `CoPat`s:
-
-    pat |> co    ===>    x (pat <- (x |> co))
-
-Why did we do this seemingly unnecessary expansion in the first place?
-The reason is that the type of @pat |> co@ (which is the type of the value
-abstraction we match against) might be different than that of @pat@. Data
-instances such as @Sing (a :: Bool)@ are a good example of this: If we would
-just drop the coercion, we'd get a type error when matching @pat@ against its
-value abstraction, with the result being that pmIsSatisfiable decides that every
-possible data constructor fitting @pat@ is rejected as uninhabited, leading to
-a lot of false warnings.
-
-But we can check whether the coercion is a hole or if it is just refl, in
-which case we can drop it.
-
-Note [Long-distance information for HsLocalBinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#18626)
-
-  f :: Int -> ()
-  f x | y = ()
-    where
-      y = True
-
-  x :: ()
-  x | let y = True, y = ()
-
-Both definitions are exhaustive, but to make the necessary long-distance
-connection from @y@'s binding to its use site in a guard, we have to collect
-'PmLet' guards for the 'HsLocalBinds' which contain @y@'s definitions.
-
-In principle, we are only interested in desugaring local binds that are
-'FunBind's, that
-
-  * Have no pattern matches. If @y@ above had any patterns, it would be a
-    function and we can't reason about them anyway.
-  * Have singleton match group with a single GRHS.
-    Otherwise, what expression to pick in the generated guard @let y = <rhs>@?
-
-It turns out that desugaring type-checked local binds in this way is a bit
-more complex than expected: Apparently, all bindings are wrapped in 'AbsBinds'
-Nfter type-checking. See Note [AbsBinds] in "GHC.Hs.Binds".
-
-We make sure that there is no polymorphism in the way by checking that there
-are no 'abs_tvs' or 'abs_ev_vars' (we don't reason about
-@y :: forall a. Eq a => ...@) and that the exports carry no 'HsWrapper's. In
-this case, the exports are a simple renaming substitution that we can capture
-with 'PmLet'. Ultimately we'll hit those renamed 'FunBind's, though, which is
-the whole point.
-
-The place to store the 'PmLet' guards for @where@ clauses (which are per
-'GRHSs') is as a field of 'PmGRHSs'. For plain @let@ guards as in the guards of
-@x@, we can simply add them to the 'pg_grds' field of 'PmGRHS'.
--}
diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Pmc/Solver.hs
+++ /dev/null
@@ -1,2081 +0,0 @@
-{-# LANGUAGE LambdaCase          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE ViewPatterns        #-}
-
-{-
-Authors: George Karachalias <george.karachalias@cs.kuleuven.be>
-         Sebastian Graf <sgraf1337@gmail.com>
-         Ryan Scott <ryan.gl.scott@gmail.com>
--}
-
--- | Model refinements type as per the
--- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989).
--- The main export of the module are the functions 'addPhiCtsNablas' for adding
--- facts to the oracle, 'isInhabited' to check if a refinement type is inhabited
--- and 'generateInhabitingPatterns' to turn a 'Nabla' into a concrete pattern
--- for an equation.
---
--- In terms of the LYG paper, this module is concerned with Sections 3.4, 3.6
--- and 3.7. E.g., it represents refinement types directly as a bunch of
--- normalised refinement types 'Nabla'.
-
-module GHC.HsToCore.Pmc.Solver (
-
-        Nabla, Nablas(..), initNablas,
-
-        PhiCt(..), PhiCts,
-        addPhiCtNablas,
-        addPhiCtsNablas,
-
-        isInhabited,
-        generateInhabitingPatterns, GenerateInhabitingPatternsMode(..)
-
-    ) where
-
-import GHC.Prelude
-
-import GHC.HsToCore.Pmc.Types
-import GHC.HsToCore.Pmc.Utils (tracePm, traceWhenFailPm, mkPmId)
-
-import GHC.Driver.Session
-import GHC.Driver.Config
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Monad (allM)
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Data.Bag
-
-import GHC.Types.Basic (Levity(..))
-import GHC.Types.CompleteMatch
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.DSet
-import GHC.Types.Unique.SDFM
-import GHC.Types.Id
-import GHC.Types.Name
-import GHC.Types.Var      (EvVar)
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
-import GHC.Types.Unique.Supply
-
-import GHC.Core
-import GHC.Core.FVs         (exprFreeVars)
-import GHC.Core.TyCo.Compare( eqType )
-import GHC.Core.Map.Expr
-import GHC.Core.Predicate (typeDeterminesValue)
-import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe)
-import GHC.Core.Utils     (exprType)
-import GHC.Core.Make      (mkListExpr, mkCharExpr, mkRuntimeErrorApp, rUNTIME_ERROR_ID)
-
-import GHC.Data.FastString
-import GHC.Types.SrcLoc
-import GHC.Data.Maybe
-import GHC.Core.ConLike
-import GHC.Core.DataCon
-import GHC.Core.PatSyn
-import GHC.Core.TyCon
-import GHC.Core.TyCon.RecWalk
-import GHC.Builtin.Names
-import GHC.Builtin.Types
-import GHC.Core.TyCo.Rep
-import GHC.Core.TyCo.Subst (elemSubst)
-import GHC.Core.Type
-import GHC.Tc.Solver   (tcNormalise, tcCheckGivens, tcCheckWanteds)
-import GHC.Core.Unify    (tcMatchTy)
-import GHC.Core.Coercion
-import GHC.Core.Reduction
-import GHC.HsToCore.Monad hiding (foldlM)
-import GHC.Tc.Instance.Family
-import GHC.Core.FamInstEnv
-
-import Control.Applicative ((<|>))
-import Control.Monad (foldM, forM, guard, mzero, when, filterM)
-import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.State.Strict
-import Data.Coerce
-import Data.Either   (partitionEithers)
-import Data.Foldable (foldlM, minimumBy, toList)
-import Data.Monoid   (Any(..))
-import Data.List     (sortBy, find)
-import qualified Data.List.NonEmpty as NE
-import Data.Ord      (comparing)
-
---
--- * Main exports
---
-
--- | Add a bunch of 'PhiCt's to all the 'Nabla's.
--- Lifts 'addPhiCts' over many 'Nablas'.
-addPhiCtsNablas :: Nablas -> PhiCts -> DsM Nablas
-addPhiCtsNablas nablas cts = liftNablasM (\d -> addPhiCts d cts) nablas
-
--- | 'addPmCtsNablas' for a single 'PmCt'.
-addPhiCtNablas :: Nablas -> PhiCt -> DsM Nablas
-addPhiCtNablas nablas ct = addPhiCtsNablas nablas (unitBag ct)
-
-liftNablasM :: Monad m => (Nabla -> m (Maybe Nabla)) -> Nablas -> m Nablas
-liftNablasM f (MkNablas ds) = MkNablas . catBagMaybes <$> (traverse f ds)
-
--- | Test if any of the 'Nabla's is inhabited. Currently this is pure, because
--- we preserve the invariant that there are no uninhabited 'Nabla's. But that
--- could change in the future, for example by implementing this function in
--- terms of @notNull <$> generateInhabitingPatterns 1 ds@.
-isInhabited :: Nablas -> DsM Bool
-isInhabited (MkNablas ds) = pure (not (null ds))
-
------------------------------------------------
--- * Caching residual COMPLETE sets
-
--- See Note [Implementation of COMPLETE pragmas]
-
--- | Update the COMPLETE sets of 'ResidualCompleteMatches', or 'Nothing'
--- if there was no change as per the update function.
-updRcm :: (CompleteMatch          -> (Bool, CompleteMatch))
-       -> ResidualCompleteMatches -> (Maybe ResidualCompleteMatches)
-updRcm f (RCM vanilla pragmas)
-  | not any_change = Nothing
-  | otherwise      = Just (RCM vanilla' pragmas')
-  where
-    f' ::  CompleteMatch          -> (Any,  CompleteMatch)
-    f' = coerce f
-    (chgd, vanilla')  = traverse f' vanilla
-    (chgds, pragmas') = traverse (traverse f') pragmas
-    any_change        = getAny $ chgd `mappend` chgds
-
--- | A pseudo-'CompleteMatch' for the vanilla complete set of the given data
--- 'TyCon'.
--- Ex.: @vanillaCompleteMatchTC 'Maybe' ==> Just ("Maybe", {'Just','Nothing'})@
-vanillaCompleteMatchTC :: TyCon -> Maybe CompleteMatch
-vanillaCompleteMatchTC tc =
-  let -- TYPE acts like an empty data type on the term-level (#14086), but
-      -- it is a PrimTyCon, so tyConDataCons_maybe returns Nothing. Hence a
-      -- special case.
-      mb_dcs | tc == tYPETyCon = Just []
-             | otherwise       = tyConDataCons_maybe tc
-  in vanillaCompleteMatch . mkUniqDSet . map RealDataCon <$> mb_dcs
-
--- | Initialise from 'dsGetCompleteMatches' (containing all COMPLETE pragmas)
--- if the given 'ResidualCompleteMatches' were empty.
-addCompleteMatches :: ResidualCompleteMatches -> DsM ResidualCompleteMatches
-addCompleteMatches (RCM v Nothing) = RCM v . Just <$> dsGetCompleteMatches
-addCompleteMatches rcm             = pure rcm
-
--- | Adds the declared 'CompleteMatches' from COMPLETE pragmas, as well as the
--- vanilla data defn if it is a 'DataCon'.
-addConLikeMatches :: ConLike -> ResidualCompleteMatches -> DsM ResidualCompleteMatches
-addConLikeMatches (RealDataCon dc) rcm = addTyConMatches (dataConTyCon dc) rcm
-addConLikeMatches (PatSynCon _)    rcm = addCompleteMatches rcm
-
--- | Adds
---    * the 'CompleteMatches' from COMPLETE pragmas
---    * and the /vanilla/ 'CompleteMatch' from the data 'TyCon'
--- to the 'ResidualCompleteMatches', if not already present.
-addTyConMatches :: TyCon -> ResidualCompleteMatches -> DsM ResidualCompleteMatches
-addTyConMatches tc rcm = add_tc_match <$> addCompleteMatches rcm
-  where
-    -- Add the vanilla COMPLETE set from the data defn, if any. But only if
-    -- it's not already present.
-    add_tc_match rcm
-      = rcm{rcm_vanilla = rcm_vanilla rcm <|> vanillaCompleteMatchTC tc}
-
-markMatched :: PmAltCon -> ResidualCompleteMatches -> DsM (Maybe ResidualCompleteMatches)
--- Nothing means the PmAltCon didn't occur in any COMPLETE set.
--- See Note [Shortcutting the inhabitation test] for how this is useful for
--- performance on T17836.
-markMatched (PmAltLit _)      _   = pure Nothing -- lits are never part of a COMPLETE set
-markMatched (PmAltConLike cl) rcm = do
-  rcm' <- addConLikeMatches cl rcm
-  let go cm = case lookupUniqDSet (cmConLikes cm) cl of
-        Nothing -> (False, cm)
-        Just _  -> (True,  cm { cmConLikes = delOneFromUniqDSet (cmConLikes cm) cl })
-  pure $ updRcm go rcm'
-
-{-
-Note [Implementation of COMPLETE pragmas]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A COMPLETE set represents a set of conlikes (i.e., constructors or
-pattern synonyms) such that if they are all pattern-matched against in a
-function, it gives rise to a total function. An example is:
-
-  newtype Boolean = Boolean Int
-  pattern F, T :: Boolean
-  pattern F = Boolean 0
-  pattern T = Boolean 1
-  {-# COMPLETE F, T #-}
-
-  -- This is a total function
-  booleanToInt :: Boolean -> Int
-  booleanToInt F = 0
-  booleanToInt T = 1
-
-COMPLETE sets are represented internally in GHC as a set of 'ConLike's. For
-example, the pragma {-# COMPLETE F, T #-} would be represented as:
-
-  CompleteMatch {F, T} Nothing
-
-What is the Maybe for? Answer: COMPLETE pragmas may optionally specify a
-result *type constructor* (cf. T14422):
-
-  class C f where
-    foo :: f a -> ()
-  pattern P :: C f => f a
-  pattern P <- (foo -> ())
-
-  instance C State where
-    foo _ = ()
-  {-# COMPLETE P :: State #-}
-
-  f :: State a -> ()
-  f P = ()
-  g :: C f => f a -> ()
-  g P = ()
-
-The @:: State@ here means that the types at which the COMPLETE pragma *applies*
-is restricted to scrutinee types that are applications of the 'State' TyCon. So
-it applies to the match in @f@ but not in @g@ above, resulting in a warning for
-the latter but not for the former. The pragma is represented as
-
-  CompleteMatch {P} (Just State)
-
-GHC collects all COMPLETE pragmas from the current module and from imports
-into a field in the DsM environment, which can be accessed with
-dsGetCompleteMatches from "GHC.HsToCore.Monad".
-Currently, COMPLETE pragmas can't be orphans (e.g. at least one ConLike must
-also be defined in the module of the pragma) and do not impact recompilation
-checking (#18675).
-
-The pattern-match checker will then initialise each variable's 'VarInfo' with
-*all* imported COMPLETE sets (in 'GHC.HsToCore.Pmc.Solver.addCompleteMatches'),
-well-typed or not, into a 'ResidualCompleteMatches'. The trick is that a
-COMPLETE set that is ill-typed for that match variable could never be written by
-the user! And we make sure not to report any ill-typed COMPLETE sets when
-formatting 'Nabla's for warnings in 'generateInhabitingPatterns'.
-
-A 'ResidualCompleteMatches' is a list of all COMPLETE sets, minus the ConLikes
-we know a particular variable can't be (through negative constructor constraints
-@x /~ K@ or a failed attempt at instantiating that ConLike during inhabitation
-testing). If *any* of the COMPLETE sets become empty, we know that the match
-was exhaustive.
-
-We assume that a COMPLETE set does not apply if for one of its
-ConLikes we fail to 'matchConLikeResTy' or the
-type of the match variable isn't an application of the optional
-result type constructor from the pragma. Why don't we simply
-prune inapplicable COMPLETE sets from 'ResidualCompleteMatches'?
-The answer is that additional type constraints might make more
-COMPLETE sets applicable! Example:
-
-  h :: a -> a :~: Boolean -> ()
-  h x Refl | T <- x = ()
-           | F <- x = ()
-
-If we eagerly prune {F,T} from the residual matches of @x@, then we don't see
-that the match in the guards of @h@ is exhaustive, where the COMPLETE set
-applies due to refined type information.
--}
-
------------------------
--- * Type normalisation
-
--- | The return value of 'pmTopNormaliseType'
-data TopNormaliseTypeResult
-  = NormalisedByConstraints Type
-  -- ^ 'tcNormalise' was able to simplify the type with some local constraint
-  -- from the type oracle, but 'topNormaliseTypeX' couldn't identify a type
-  -- redex.
-  | HadRedexes Type [(Type, DataCon, Type)] Type
-  -- ^ 'tcNormalise' may or may not been able to simplify the type, but
-  -- 'topNormaliseTypeX' made progress either way and got rid of at least one
-  -- outermost type or data family redex or newtype.
-  -- The first field is the last type that was reduced solely through type
-  -- family applications (possibly just the 'tcNormalise'd type). This is the
-  -- one that is equal (in source Haskell) to the initial type.
-  -- The third field is the type that we get when also looking through data
-  -- family applications and newtypes. This would be the representation type in
-  -- Core (modulo casts).
-  -- The second field is the list of Newtype 'DataCon's that we looked through
-  -- in the chain of reduction steps between the Source type and the Core type.
-  -- We also keep the type of the DataCon application and its field, so that we
-  -- don't have to reconstruct it in 'inhabitationCandidates' and
-  -- 'generateInhabitingPatterns'.
-  -- For an example, see Note [Type normalisation].
-
--- | Return the fields of 'HadRedexes'. Returns appropriate defaults in the
--- other cases.
-tntrGuts :: TopNormaliseTypeResult -> (Type, [(Type, DataCon, Type)], Type)
-tntrGuts (NormalisedByConstraints ty)   = (ty,     [],      ty)
-tntrGuts (HadRedexes src_ty ds core_ty) = (src_ty, ds, core_ty)
-
-instance Outputable TopNormaliseTypeResult where
-  ppr (NormalisedByConstraints ty)   = text "NormalisedByConstraints" <+> ppr ty
-  ppr (HadRedexes src_ty ds core_ty) = text "HadRedexes" <+> braces fields
-    where
-      fields = fsep (punctuate comma [ text "src_ty =" <+> ppr src_ty
-                                     , text "newtype_dcs =" <+> ppr ds
-                                     , text "core_ty =" <+> ppr core_ty ])
-
-pmTopNormaliseType :: TyState -> Type -> DsM TopNormaliseTypeResult
--- ^ Get rid of *outermost* (or toplevel)
---      * type function redex
---      * data family redex
---      * newtypes
---
--- Behaves like `topNormaliseType_maybe`, but instead of returning a
--- coercion, it returns useful information for issuing pattern matching
--- warnings. See Note [Type normalisation] for details.
--- It also initially 'tcNormalise's the type with the bag of local constraints.
---
--- See 'TopNormaliseTypeResult' for the meaning of the return value.
---
--- NB: Normalisation can potentially change kinds, if the head of the type
--- is a type family with a variable result kind. I (Richard E) can't think
--- of a way to cause trouble here, though.
-pmTopNormaliseType (TySt _ inert) typ = {-# SCC "pmTopNormaliseType" #-} do
-  env <- dsGetFamInstEnvs
-  tracePm "normalise" (ppr typ)
-  -- Before proceeding, we chuck typ into the constraint solver, in case
-  -- solving for given equalities may reduce typ some. See
-  -- "Wrinkle: local equalities" in Note [Type normalisation].
-  typ' <- initTcDsForSolver $ tcNormalise inert typ
-  -- Now we look with topNormaliseTypeX through type and data family
-  -- applications and newtypes, which tcNormalise does not do.
-  -- See also 'TopNormaliseTypeResult'.
-  pure $ case topNormaliseTypeX (stepper env) comb typ' of
-    Nothing                -> NormalisedByConstraints typ'
-    Just ((ty_f,tm_f), ty) -> HadRedexes src_ty newtype_dcs core_ty
-      where
-        src_ty = eq_src_ty ty (typ' : ty_f [ty])
-        newtype_dcs = tm_f []
-        core_ty = ty
-  where
-    -- Find the first type in the sequence of rewrites that is a data type,
-    -- newtype, or a data family application (not the representation tycon!).
-    -- This is the one that is equal (in source Haskell) to the initial type.
-    -- If none is found in the list, then all of them are type family
-    -- applications, so we simply return the last one, which is the *simplest*.
-    eq_src_ty :: Type -> [Type] -> Type
-    eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys)
-
-    is_closed_or_data_family :: Type -> Bool
-    is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty
-
-    -- For efficiency, represent both lists as difference lists.
-    -- comb performs the concatenation, for both lists.
-    comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2)
-
-    stepper env = newTypeStepper `composeSteppers` tyFamStepper env
-
-    -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into
-    -- a loop. If it would fall into a loop, it produces 'NS_Abort'.
-    newTypeStepper :: NormaliseStepper ([Type] -> [Type],[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])
-    newTypeStepper rec_nts tc tys
-      | Just (ty', _co) <- instNewTyCon_maybe tc tys
-      , let orig_ty = TyConApp tc tys
-      = case checkRecTc rec_nts tc of
-          Just rec_nts' -> let tyf = (orig_ty:)
-                               tmf = ((orig_ty, tyConSingleDataCon tc, ty'):)
-                           in  NS_Step rec_nts' ty' (tyf, tmf)
-          Nothing       -> NS_Abort
-      | otherwise
-      = NS_Done
-
-    tyFamStepper :: FamInstEnvs -> NormaliseStepper ([Type] -> [Type], a -> a)
-    tyFamStepper env rec_nts tc tys  -- Try to step a type/data family
-      = case topReduceTyFamApp_maybe env tc tys of
-          Just (HetReduction (Reduction _ rhs) _)
-            -> NS_Step rec_nts rhs ((rhs:), id)
-          _ -> NS_Done
-
--- | Returns 'True' if the argument 'Type' is a fully saturated application of
--- a closed type constructor.
---
--- Closed type constructors are those with a fixed right hand side, as
--- opposed to e.g. associated types. These are of particular interest for
--- pattern-match coverage checking, because GHC can exhaustively consider all
--- possible forms that values of a closed type can take on.
---
--- Note that this function is intended to be used to check types of value-level
--- patterns, so as a consequence, the 'Type' supplied as an argument to this
--- function should be of kind @Type@.
-pmIsClosedType :: Type -> Bool
-pmIsClosedType ty
-  = case splitTyConApp_maybe ty of
-      Just (tc, ty_args)
-             | is_algebraic_like tc && not (isFamilyTyCon tc)
-             -> assertPpr (ty_args `lengthIs` tyConArity tc) (ppr ty) True
-      _other -> False
-  where
-    -- This returns True for TyCons which /act like/ algebraic types.
-    -- (See "Type#type_classification" for what an algebraic type is.)
-    --
-    -- This is qualified with \"like\" because of a particular special
-    -- case: TYPE (the underlying kind behind Type, among others). TYPE
-    -- is conceptually a datatype (and thus algebraic), but in practice it is
-    -- a primitive builtin type, so we must check for it specially.
-    --
-    -- NB: it makes sense to think of TYPE as a closed type in a value-level,
-    -- pattern-matching context. However, at the kind level, TYPE is certainly
-    -- not closed! Since this function is specifically tailored towards pattern
-    -- matching, however, it's OK to label TYPE as closed.
-    is_algebraic_like :: TyCon -> Bool
-    is_algebraic_like tc = isAlgTyCon tc || tc == tYPETyCon
-
--- | Normalise the given source type to WHNF. If it isn't already in WHNF
--- ('isSourceTypeInWHNF') , it will normalise the type and then try to step
--- through type family applications, but not data family applications or
--- newtypes.
---
--- This is a pretty common case of calling 'pmTopNormaliseType' and it should be
--- efficient.
-normaliseSourceTypeWHNF :: TyState -> Type -> DsM Type
-normaliseSourceTypeWHNF _     ty | isSourceTypeInWHNF ty = pure ty
-normaliseSourceTypeWHNF ty_st ty =
-  pmTopNormaliseType ty_st ty >>= \case
-    NormalisedByConstraints ty -> pure ty
-    HadRedexes ty _ _          -> pure ty
-
--- | Is the source type in WHNF wrt. 'pmTopNormaliseType'?
---
--- Returns False if the given type is not a TyCon application, or if the TyCon
--- app head is a type family TyCon. (But not for data family TyCons!)
-isSourceTypeInWHNF :: Type -> Bool
-isSourceTypeInWHNF ty
-  | Just (tc, _) <- splitTyConApp_maybe ty = not (isTypeFamilyTyCon tc)
-  | otherwise                              = False
-
-{- Note [Type normalisation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Constructs like -XEmptyCase or a previous unsuccessful pattern match on a data
-constructor place a non-void constraint on the matched thing. This means that it
-boils down to checking whether the type of the scrutinee is inhabited. Function
-pmTopNormaliseType gets rid of the outermost type function/data family redex and
-newtypes, in search of an algebraic type constructor, which is easier to check
-for inhabitation.
-
-It returns 3 results instead of one, because there are 2 subtle points:
-1. Newtypes are isomorphic to the underlying type in core but not in the source
-   language,
-2. The representational data family tycon is used internally but should not be
-   shown to the user
-
-Hence, if pmTopNormaliseType env ty_cs ty = Just (src_ty, dcs, core_ty),
-then
-  (a) src_ty is the rewritten type which we can show to the user. That is, the
-      type we get if we rewrite type families but not data families or
-      newtypes.
-  (b) dcs is the list of newtype constructors "skipped", every time we normalise
-      a newtype to its core representation, we keep track of the source data
-      constructor. For convenience, we also track the type we unwrap and the
-      type of its field. Example: @Down 42@ => @[(Down @Int, Down, Int)]
-  (c) core_ty is the rewritten type. That is,
-        pmTopNormaliseType env ty_cs ty = Just (src_ty, dcs, core_ty)
-      implies
-        topNormaliseType_maybe env ty = Just (co, core_ty)
-      for some coercion co.
-
-To see how all cases come into play, consider the following example:
-
-  data family T a :: *
-  data instance T Int = T1 | T2 Bool
-  -- Which gives rise to FC:
-  --   data T a
-  --   data R:TInt = T1 | T2 Bool
-  --   axiom ax_ti : T Int ~R R:TInt
-
-  newtype G1 = MkG1 (T Int)
-  newtype G2 = MkG2 G1
-
-  type instance F Int  = F Char
-  type instance F Char = G2
-
-In this case pmTopNormaliseType env ty_cs (F Int) results in
-
-  Just (G2, [(G2,MkG2,G1),(G1,MkG1,T Int)], R:TInt)
-
-Which means that in source Haskell:
-  - G2 is equivalent to F Int (in contrast, G1 isn't).
-  - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int).
-
------
--- Wrinkle: Local equalities
------
-
-Given the following type family:
-
-  type family F a
-  type instance F Int = Void
-
-Should the following program (from #14813) be considered exhaustive?
-
-  f :: (i ~ Int) => F i -> a
-  f x = case x of {}
-
-You might think "of course, since `x` is obviously of type Void". But the
-idType of `x` is technically F i, not Void, so if we pass F i to
-inhabitationCandidates, we'll mistakenly conclude that `f` is non-exhaustive.
-In order to avoid this pitfall, we need to normalise the type passed to
-pmTopNormaliseType, using the constraint solver to solve for any local
-equalities (such as i ~ Int) that may be in scope.
-
-Note [Coverage checking Newtype matches]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Newtypes have quite peculiar match semantics compared to ordinary DataCons. In a
-pattern-match, they behave like a irrefutable (lazy) match, but for inhabitation
-testing purposes (e.g. at construction sites), they behave rather like a DataCon
-with a *strict* field, because they don't contribute their own bottom and are
-inhabited iff the wrapped type is inhabited.
-
-This distinction becomes apparent in #17248:
-
-  newtype T2 a = T2 a
-  g _      True = ()
-  g (T2 _) True = ()
-  g !_     True = ()
-
-If we treat Newtypes like we treat regular DataCons, we would mark the third
-clause as redundant, which clearly is unsound. The solution:
-1. 'isPmAltConMatchStrict' returns False for newtypes, indicating that a
-   newtype match is lazy.
-2. When we find @x ~ T2 y@, transfer all constraints on @x@ (which involve @⊥@)
-   to @y@, similar to what 'equate' does, and don't add a @x ≁ ⊥@ constraint.
-   This way, the third clause will still be marked as inaccessible RHS instead
-   of redundant. This is ensured by calling 'lookupVarInfoNT'.
-3. Immediately reject when we find @x ≁ T2@.
-Handling of Newtypes is also described in the Appendix of the Lower Your Guards paper,
-where you can find the solution in a perhaps more digestible format.
--}
-
--------------------------
--- * Adding φ constraints
---
--- Figure 7 in the LYG paper.
-
--- | A high-level pattern-match constraint. Corresponds to φ from Figure 3 of
--- the LYG paper.
-data PhiCt
-  = PhiTyCt !PredType
-  -- ^ A type constraint "T ~ U".
-  | PhiCoreCt    !Id !CoreExpr
-  -- ^ @PhiCoreCt x e@ encodes "x ~ e", equating @x@ with the 'CoreExpr' @e@.
-  | PhiConCt     !Id !PmAltCon ![TyVar] ![PredType] ![Id]
-  -- ^ @PhiConCt x K tvs dicts ys@ encodes @K \@tvs dicts ys <- x@, matching @x@
-  -- against the 'PmAltCon' application @K \@tvs dicts ys@, binding @tvs@,
-  -- @dicts@ and possibly unlifted fields @ys@ in the process.
-  -- See Note [Strict fields and variables of unlifted type].
-  | PhiNotConCt  !Id !PmAltCon
-  -- ^ @PhiNotConCt x K@ encodes "x ≁ K", asserting that @x@ can't be headed
-  -- by @K@.
-  | PhiBotCt     !Id
-  -- ^ @PhiBotCt x@ encodes "x ~ ⊥", equating @x@ to ⊥.
-  -- by @K@.
-  | PhiNotBotCt !Id
-  -- ^ @PhiNotBotCt x y@ encodes "x ≁ ⊥", asserting that @x@ can't be ⊥.
-
-instance Outputable PhiCt where
-  ppr (PhiTyCt ty_ct)                 = ppr ty_ct
-  ppr (PhiCoreCt x e)                 = ppr x <+> char '~' <+> ppr e
-  ppr (PhiConCt x con tvs dicts args) =
-    hsep (ppr con : pp_tvs ++ pp_dicts ++ pp_args) <+> text "<-" <+> ppr x
-    where
-      pp_tvs   = map ((<> char '@') . ppr) tvs
-      pp_dicts = map ppr dicts
-      pp_args  = map ppr args
-  ppr (PhiNotConCt x con)             = ppr x <+> text "≁" <+> ppr con
-  ppr (PhiBotCt x)                    = ppr x <+> text "~ ⊥"
-  ppr (PhiNotBotCt x)                 = ppr x <+> text "≁ ⊥"
-
-type PhiCts = Bag PhiCt
-
--- | The fuel for the inhabitation test.
--- See Note [Fuel for the inhabitation test].
-initFuel :: Int
-initFuel = 4 -- 4 because it's the smallest number that passes f' in T17977b
-
--- | Adds new constraints to 'Nabla' and returns 'Nothing' if that leads to a
--- contradiction.
---
--- In terms of the paper, this function models the \(⊕_φ\) function in
--- Figure 7 on batches of φ constraints.
-addPhiCts :: Nabla -> PhiCts -> DsM (Maybe Nabla)
--- See Note [TmState invariants].
-addPhiCts nabla cts = runMaybeT $ do
-  let (ty_cts, tm_cts) = partitionPhiCts cts
-  nabla' <- addTyCts nabla (listToBag ty_cts)
-  nabla'' <- foldlM addPhiTmCt nabla' (listToBag tm_cts)
-  inhabitationTest initFuel (nabla_ty_st nabla) nabla''
-
-partitionPhiCts :: PhiCts -> ([PredType], [PhiCt])
-partitionPhiCts = partitionEithers . map to_either . toList
-  where
-    to_either (PhiTyCt pred_ty) = Left pred_ty
-    to_either ct                = Right ct
-
------------------------------
--- ** Adding type constraints
-
--- | Adds new type-level constraints by calling out to the type-checker via
--- 'tyOracle'.
-addTyCts :: Nabla -> Bag PredType -> MaybeT DsM Nabla
-addTyCts nabla@MkNabla{ nabla_ty_st = ty_st } new_ty_cs = do
-  ty_st' <- MaybeT (tyOracle ty_st new_ty_cs)
-  pure nabla{ nabla_ty_st = ty_st' }
-
--- | Add some extra type constraints to the 'TyState'; return 'Nothing' if we
--- find a contradiction (e.g. @Int ~ Bool@).
---
--- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver.
-tyOracle :: TyState -> Bag PredType -> DsM (Maybe TyState)
-tyOracle ty_st@(TySt n inert) cts
-  | isEmptyBag cts
-  = pure (Just ty_st)
-  | otherwise
-  = {-# SCC "tyOracle" #-}
-    do { evs <- traverse nameTyCt cts
-       ; tracePm "tyOracle" (ppr n $$ ppr cts $$ ppr inert)
-       ; mb_new_inert <- initTcDsForSolver $ tcCheckGivens inert evs
-         -- return the new inert set and increment the sequence number n
-       ; return (TySt (n+1) <$> mb_new_inert) }
-
--- | Allocates a fresh 'EvVar' name for 'PredTy's.
-nameTyCt :: PredType -> DsM EvVar
-nameTyCt pred_ty = do
-  unique <- getUniqueM
-  let occname = mkVarOccFS (fsLit ("pm_"++show unique))
-      idname  = mkInternalName unique occname noSrcSpan
-  return (mkLocalIdOrCoVar idname ManyTy pred_ty)
-
------------------------------
--- ** Adding term constraints
-
--- | Adds a single higher-level φ constraint by dispatching to the various
--- oracle functions.
---
--- In terms of the paper, this function amounts to the constructor constraint
--- case of \(⊕_φ\) in Figure 7, which "desugars" higher-level φ constraints
--- into lower-level δ constraints. We don't have a data type for δ constraints
--- and call the corresponding oracle function directly instead.
---
--- Precondition: The φ is /not/ a type constraint! These should be handled by
--- 'addTyCts' before, through 'addPhiCts'.
-addPhiTmCt :: Nabla -> PhiCt -> MaybeT DsM Nabla
-addPhiTmCt _     (PhiTyCt ct)              = pprPanic "addPhiCt:TyCt" (ppr ct) -- See the precondition
-addPhiTmCt nabla (PhiCoreCt x e)           = addCoreCt nabla x e
-addPhiTmCt nabla (PhiConCt x con tvs dicts args) = do
-  -- Case (1) of Note [Strict fields and variables of unlifted type]
-  -- PhiConCt correspond to the higher-level φ constraints from the paper with
-  -- bindings semantics. It disperses into lower-level δ constraints that the
-  -- 'add*Ct' functions correspond to.
-  nabla' <- addTyCts nabla (listToBag dicts)
-  nabla'' <- addConCt nabla' x con tvs args
-  foldlM addNotBotCt nabla'' (filterUnliftedFields con args)
-addPhiTmCt nabla (PhiNotConCt x con)       = addNotConCt nabla x con
-addPhiTmCt nabla (PhiBotCt x)              = addBotCt nabla x
-addPhiTmCt nabla (PhiNotBotCt x)           = addNotBotCt nabla x
-
-filterUnliftedFields :: PmAltCon -> [Id] -> [Id]
-filterUnliftedFields con args =
-  [ arg | (arg, bang) <- zipEqual "addPhiCt" args (pmAltConImplBangs con)
-        , isBanged bang || typeLevity_maybe (idType arg) == Just Unlifted ]
-
--- | Adds the constraint @x ~ ⊥@, e.g. that evaluation of a particular 'Id' @x@
--- surely diverges. Quite similar to 'addConCt', only that it only cares about
--- ⊥.
-addBotCt :: Nabla -> Id -> MaybeT DsM Nabla
-addBotCt nabla@MkNabla{ nabla_tm_st = ts@TmSt{ ts_facts=env } } x = do
-  let (y, vi@VI { vi_bot = bot }) = lookupVarInfoNT (nabla_tm_st nabla) x
-  case bot of
-    IsNotBot -> mzero      -- There was x ≁ ⊥. Contradiction!
-    IsBot    -> pure nabla -- There already is x ~ ⊥. Nothing left to do
-    MaybeBot               -- We add x ~ ⊥
-      | Just Unlifted <- typeLevity_maybe (idType x)
-      -- Case (3) in Note [Strict fields and variables of unlifted type]
-      -> mzero -- unlifted vars can never be ⊥
-      | otherwise
-      -> do
-          let vi' = vi{ vi_bot = IsBot }
-          pure nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env y vi' } }
-
--- | Adds the constraint @x ~/ ⊥@ to 'Nabla'. Quite similar to 'addNotConCt',
--- but only cares for the ⊥ "constructor".
-addNotBotCt :: Nabla -> Id -> MaybeT DsM Nabla
-addNotBotCt nabla@MkNabla{ nabla_tm_st = ts@TmSt{ts_facts=env} } x = do
-  let (y, vi@VI { vi_bot = bot }) = lookupVarInfoNT (nabla_tm_st nabla) x
-  case bot of
-    IsBot    -> mzero      -- There was x ~ ⊥. Contradiction!
-    IsNotBot -> pure nabla -- There already is x ≁ ⊥. Nothing left to do
-    MaybeBot -> do         -- We add x ≁ ⊥ and test if x is still inhabited
-      -- Mark dirty for a delayed inhabitation test
-      let vi' = vi{ vi_bot = IsNotBot}
-      pure $ markDirty y
-           $ nabla{ nabla_tm_st = ts{ ts_facts = addToUSDFM env y vi' } }
-
--- | Record a @x ~/ K@ constraint, e.g. that a particular 'Id' @x@ can't
--- take the shape of a 'PmAltCon' @K@ in the 'Nabla' and return @Nothing@ if
--- that leads to a contradiction.
--- See Note [TmState invariants].
-addNotConCt :: Nabla -> Id -> PmAltCon -> MaybeT DsM Nabla
-addNotConCt _     _ (PmAltConLike (RealDataCon dc))
-  | isNewDataCon dc = mzero -- (3) in Note [Coverage checking Newtype matches]
-addNotConCt nabla x nalt = do
-  (mb_mark_dirty, nabla') <- trvVarInfo go nabla x
-  pure $ case mb_mark_dirty of
-    Just x  -> markDirty x nabla'
-    Nothing -> nabla'
-  where
-    -- Update `x`'s 'VarInfo' entry. Fail ('MaybeT') if contradiction,
-    -- otherwise return updated entry and `Just x'` if `x` should be marked dirty,
-    -- where `x'` is the representative of `x`.
-    go :: VarInfo -> MaybeT DsM (Maybe Id, VarInfo)
-    go vi@(VI x' pos neg _ rcm) = do
-      -- 1. Bail out quickly when nalt contradicts a solution
-      let contradicts nalt sol = eqPmAltCon (paca_con sol) nalt == Equal
-      guard (not (any (contradicts nalt) pos))
-      -- 2. Only record the new fact when it's not already implied by one of the
-      -- solutions
-      let implies nalt sol = eqPmAltCon (paca_con sol) nalt == Disjoint
-      let neg'
-            | any (implies nalt) pos = neg
-            -- See Note [Completeness checking with required Thetas]
-            | hasRequiredTheta nalt  = neg
-            | otherwise              = extendPmAltConSet neg nalt
-      massert (isPmAltConMatchStrict nalt)
-      let vi' = vi{ vi_neg = neg', vi_bot = IsNotBot }
-      -- 3. Make sure there's at least one other possible constructor
-      mb_rcm' <- lift (markMatched nalt rcm)
-      pure $ case mb_rcm' of
-        -- If nalt could be removed from a COMPLETE set, we'll get back Just and
-        -- have to mark x dirty, by returning Just x'.
-        Just rcm' -> (Just x',  vi'{ vi_rcm = rcm' })
-        -- Otherwise, nalt didn't occur in any residual COMPLETE set and we
-        -- don't have to mark it dirty. So we return Nothing, which in the case
-        -- above would have compromised precision.
-        -- See Note [Shortcutting the inhabitation test], grep for T17836.
-        Nothing   -> (Nothing, vi')
-
-hasRequiredTheta :: PmAltCon -> Bool
-hasRequiredTheta (PmAltConLike cl) = notNull req_theta
-  where
-    (_,_,_,_,req_theta,_,_) = conLikeFullSig cl
-hasRequiredTheta _                 = False
-
--- | Add a @x ~ K tvs args ts@ constraint.
--- @addConCt x K tvs args ts@ extends the substitution with a solution
--- @x :-> (K, tvs, args)@ if compatible with the negative and positive info we
--- have on @x@, reject (@Nothing@) otherwise.
---
--- See Note [TmState invariants].
-addConCt :: Nabla -> Id -> PmAltCon -> [TyVar] -> [Id] -> MaybeT DsM Nabla
-addConCt nabla@MkNabla{ nabla_tm_st = ts@TmSt{ ts_facts=env } } x alt tvs args = do
-  let vi@(VI _ pos neg bot _) = lookupVarInfo ts x
-  -- First try to refute with a negative fact
-  guard (not (elemPmAltConSet alt neg))
-  -- Then see if any of the other solutions (remember: each of them is an
-  -- additional refinement of the possible values x could take) indicate a
-  -- contradiction
-  guard (all ((/= Disjoint) . eqPmAltCon alt . paca_con) pos)
-  -- Now we should be good! Add (alt, tvs, args) as a possible solution, or
-  -- refine an existing one
-  case find ((== Equal) . eqPmAltCon alt . paca_con) pos of
-    Just (PACA _con other_tvs other_args) -> do
-      -- We must unify existentially bound ty vars and arguments!
-      let ty_cts = equateTys (map mkTyVarTy tvs) (map mkTyVarTy other_tvs)
-      nabla' <- MaybeT $ addPhiCts nabla (listToBag ty_cts)
-      let add_var_ct nabla (a, b) = addVarCt nabla a b
-      foldlM add_var_ct nabla' $ zipEqual "addConCt" args other_args
-    Nothing -> do
-      let pos' = PACA alt tvs args : pos
-      let nabla_with bot' =
-            nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env x (vi{vi_pos = pos', vi_bot = bot'})} }
-      -- Do (2) in Note [Coverage checking Newtype matches]
-      case (alt, args) of
-        (PmAltConLike (RealDataCon dc), [y]) | isNewDataCon dc ->
-          case bot of
-            MaybeBot -> pure (nabla_with MaybeBot)
-            IsBot    -> addBotCt (nabla_with MaybeBot) y
-            IsNotBot -> addNotBotCt (nabla_with MaybeBot) y
-        _ -> assert (isPmAltConMatchStrict alt )
-             pure (nabla_with IsNotBot) -- strict match ==> not ⊥
-
-equateTys :: [Type] -> [Type] -> [PhiCt]
-equateTys ts us =
-  [ PhiTyCt (mkPrimEqPred t u)
-  | (t, u) <- zipEqual "equateTys" ts us
-  -- The following line filters out trivial Refl constraints, so that we don't
-  -- need to initialise the type oracle that often
-  , not (eqType t u)
-  ]
-
--- | Adds a @x ~ y@ constraint by merging the two 'VarInfo's and record the
--- gained knowledge in 'Nabla'.
---
--- Returns @Nothing@ when there's a contradiction while merging. Returns @Just
--- nabla@ when the constraint was compatible with prior facts, in which case
--- @nabla@ has integrated the knowledge from the equality constraint.
---
--- See Note [TmState invariants].
-addVarCt :: Nabla -> Id -> Id -> MaybeT DsM Nabla
-addVarCt nabla@MkNabla{ nabla_tm_st = ts@TmSt{ ts_facts = env } } x y =
-  case equateUSDFM env x y of
-    (Nothing,   env') -> pure (nabla{ nabla_tm_st = ts{ ts_facts = env' } })
-    -- Add the constraints we had for x to y
-    (Just vi_x, env') -> do
-      let nabla_equated = nabla{ nabla_tm_st = ts{ts_facts = env'} }
-      -- and then gradually merge every positive fact we have on x into y
-      let add_pos nabla (PACA cl tvs args) = addConCt nabla y cl tvs args
-      nabla_pos <- foldlM add_pos nabla_equated (vi_pos vi_x)
-      -- Do the same for negative info
-      let add_neg nabla nalt = addNotConCt nabla y nalt
-      foldlM add_neg nabla_pos (pmAltConSetElems (vi_neg vi_x))
-
--- | Inspects a 'PmCoreCt' @let x = e@ by recording constraints for @x@ based
--- on the shape of the 'CoreExpr' @e@. Examples:
---
---   * For @let x = Just (42, 'z')@ we want to record the
---     constraints @x ~ Just a, a ~ (b, c), b ~ 42, c ~ 'z'@.
---     See 'data_con_app'.
---   * For @let x = unpackCString# "tmp"@ we want to record the literal
---     constraint @x ~ "tmp"@.
---   * For @let x = I# 42@ we want the literal constraint @x ~ 42@. Similar
---     for other literals. See 'coreExprAsPmLit'.
---   * Finally, if we have @let x = e@ and we already have seen @let y = e@, we
---     want to record @x ~ y@.
-addCoreCt :: Nabla -> Id -> CoreExpr -> MaybeT DsM Nabla
-addCoreCt nabla x e = do
-  simpl_opts <- initSimpleOpts <$> getDynFlags
-  let e' = simpleOptExpr simpl_opts e
-  -- lift $ tracePm "addCoreCt" (ppr x <+> dcolon <+> ppr (idType x) $$ ppr e $$ ppr e')
-  execStateT (core_expr x e') nabla
-  where
-    -- Takes apart a 'CoreExpr' and tries to extract as much information about
-    -- literals and constructor applications as possible.
-    core_expr :: Id -> CoreExpr -> StateT Nabla (MaybeT DsM) ()
-    -- TODO: Handle newtypes properly, by wrapping the expression in a DataCon
-    -- This is the right thing for casts involving data family instances and
-    -- their representation TyCon, though (which are not visible in source
-    -- syntax). See Note [COMPLETE sets on data families]
-    -- core_expr x e | pprTrace "core_expr" (ppr x $$ ppr e) False = undefined
-    core_expr x (Cast e _co) = core_expr x e
-    core_expr x (Tick _t e) = core_expr x e
-    core_expr x e
-      | Just (pmLitAsStringLit -> Just s) <- coreExprAsPmLit e
-      , expr_ty `eqType` stringTy
-      -- See Note [Representation of Strings in TmState]
-      = case unpackFS s of
-          -- We need this special case to break a loop with coreExprAsPmLit
-          -- Otherwise we alternate endlessly between [] and ""
-          [] -> data_con_app x emptyInScopeSet nilDataCon []
-          s' -> core_expr x (mkListExpr charTy (map mkCharExpr s'))
-      | Just lit <- coreExprAsPmLit e
-      = pm_lit x lit
-      | Just (in_scope, _empty_floats@[], dc, _arg_tys, args)
-            <- exprIsConApp_maybe in_scope_env e
-      = data_con_app x in_scope dc args
-      -- See Note [Detecting pattern synonym applications in expressions]
-      | Var y <- e, Nothing <- isDataConId_maybe x
-      -- We don't consider DataCons flexible variables
-      = modifyT (\nabla -> addVarCt nabla x y)
-      | otherwise
-      -- Any other expression. Try to find other uses of a semantically
-      -- equivalent expression and represent them by the same variable!
-      = equate_with_similar_expr x e
-      where
-        expr_ty       = exprType e
-        expr_in_scope = mkInScopeSet (exprFreeVars e)
-        in_scope_env  = (expr_in_scope, const NoUnfolding)
-        -- It's inconvenient to get hold of a global in-scope set
-        -- here, but it'll only be needed if exprIsConApp_maybe ends
-        -- up substituting inside a forall or lambda (i.e. seldom)
-        -- so using exprFreeVars seems fine.   See MR !1647.
-
-    -- The @e@ in @let x = e@ had no familiar form. But we can still see if
-    -- see if we already encountered a constraint @let y = e'@ with @e'@
-    -- semantically equivalent to @e@, in which case we may add the constraint
-    -- @x ~ y@.
-    equate_with_similar_expr :: Id -> CoreExpr -> StateT Nabla (MaybeT DsM) ()
-    equate_with_similar_expr x e = do
-      rep <- StateT $ \nabla -> lift (representCoreExpr nabla e)
-      -- Note that @rep == x@ if we encountered @e@ for the first time.
-      modifyT (\nabla -> addVarCt nabla x rep)
-
-    bind_expr :: CoreExpr -> StateT Nabla (MaybeT DsM) Id
-    bind_expr e = do
-      x <- lift (lift (mkPmId (exprType e)))
-      core_expr x e
-      pure x
-
-    -- Look at @let x = K taus theta es@ and generate the following
-    -- constraints (assuming universals were dropped from @taus@ before):
-    --   1. @x ≁ ⊥@ if 'K' is not a Newtype constructor.
-    --   2. @a_1 ~ tau_1, ..., a_n ~ tau_n@ for fresh @a_i@
-    --   3. @y_1 ~ e_1, ..., y_m ~ e_m@ for fresh @y_i@
-    --   4. @x ~ K as ys@
-    -- This is quite similar to PmCheck.pmConCts.
-    data_con_app :: Id -> InScopeSet -> DataCon -> [CoreExpr] -> StateT Nabla (MaybeT DsM) ()
-    data_con_app x in_scope dc args = do
-      let dc_ex_tvs              = dataConExTyCoVars dc
-          arty                   = dataConSourceArity dc
-          (ex_ty_args, val_args) = splitAtList dc_ex_tvs args
-          ex_tys                 = map exprToType ex_ty_args
-          vis_args               = reverse $ take arty $ reverse val_args
-      uniq_supply <- lift $ lift $ getUniqueSupplyM
-      let (_, ex_tvs) = cloneTyVarBndrs (mkEmptySubst in_scope) dc_ex_tvs uniq_supply
-          ty_cts      = equateTys (map mkTyVarTy ex_tvs) ex_tys
-      -- 1. @x ≁ ⊥@ if 'K' is not a Newtype constructor (#18341)
-      when (not (isNewDataCon dc)) $
-        modifyT $ \nabla -> addNotBotCt nabla x
-      -- 2. @a_1 ~ tau_1, ..., a_n ~ tau_n@ for fresh @a_i@. See also #17703
-      modifyT $ \nabla -> MaybeT $ addPhiCts nabla (listToBag ty_cts)
-      -- 3. @y_1 ~ e_1, ..., y_m ~ e_m@ for fresh @y_i@
-      arg_ids <- traverse bind_expr vis_args
-      -- 4. @x ~ K as ys@
-      pm_alt_con_app x (PmAltConLike (RealDataCon dc)) ex_tvs arg_ids
-
-    -- Adds a literal constraint, i.e. @x ~ 42@.
-    -- Also we assume that literal expressions won't diverge, so this
-    -- will add a @x ~/ ⊥@ constraint.
-    pm_lit :: Id -> PmLit -> StateT Nabla (MaybeT DsM) ()
-    pm_lit x lit = do
-      modifyT $ \nabla -> addNotBotCt nabla x
-      pm_alt_con_app x (PmAltLit lit) [] []
-
-    -- Adds the given constructor application as a solution for @x@.
-    pm_alt_con_app :: Id -> PmAltCon -> [TyVar] -> [Id] -> StateT Nabla (MaybeT DsM) ()
-    pm_alt_con_app x con tvs args = modifyT $ \nabla -> addConCt nabla x con tvs args
-
--- | Like 'modify', but with an effectful modifier action
-modifyT :: Monad m => (s -> m s) -> StateT s m ()
-modifyT f = StateT $ fmap ((,) ()) . f
-
--- | Finds a representant of the semantic equality class of the given @e@.
--- Which is the @x@ of a @let x = e'@ constraint (with @e@ semantically
--- equivalent to @e'@) we encountered earlier, or a fresh identifier if
--- there weren't any such constraints.
-representCoreExpr :: Nabla -> CoreExpr -> DsM (Id, Nabla)
-representCoreExpr nabla@MkNabla{ nabla_tm_st = ts@TmSt{ ts_reps = reps } } e
-  | Just rep <- lookupCoreMap reps key = pure (rep, nabla)
-  | otherwise = do
-      rep <- mkPmId (exprType e)
-      let reps'  = extendCoreMap reps key rep
-      let nabla' = nabla{ nabla_tm_st = ts{ ts_reps = reps' } }
-      pure (rep, nabla')
-  where
-    key = makeDictsCoherent e
-      -- Use a key in which dictionaries for the same type become equal.
-      -- See Note [Unique dictionaries in the TmOracle CoreMap]
-
--- | Change out 'Id's which are uniquely determined by their type to a
--- common value, so that different names for dictionaries of the same type
--- are considered equal when building a 'CoreMap'.
---
--- See Note [Unique dictionaries in the TmOracle CoreMap]
-makeDictsCoherent :: CoreExpr -> CoreExpr
-makeDictsCoherent var@(Var v)
-  | let ty = idType v
-  , typeDeterminesValue ty
-  = mkRuntimeErrorApp rUNTIME_ERROR_ID ty "dictionary"
-  | otherwise
-  = var
-makeDictsCoherent lit@(Lit {})
-  = lit
-makeDictsCoherent (App f a)
-  = App (makeDictsCoherent f) (makeDictsCoherent a)
-makeDictsCoherent (Lam f body)
-  = Lam f (makeDictsCoherent body)
-makeDictsCoherent (Let bndr body)
-  = Let
-      (go_bndr bndr)
-      (makeDictsCoherent body)
-  where
-    go_bndr (NonRec bndr expr) = NonRec bndr (makeDictsCoherent expr)
-    go_bndr (Rec bndrs) = Rec (map ( \(b, expr) -> (b, makeDictsCoherent expr) ) bndrs)
-makeDictsCoherent (Case scrut bndr ty alts)
-  = Case scrut bndr ty
-      [ Alt con bndr expr'
-      | Alt con bndr expr <- alts
-      , let expr' = makeDictsCoherent expr ]
-makeDictsCoherent (Cast expr co)
-  = Cast (makeDictsCoherent expr) co
-makeDictsCoherent (Tick tick expr)
-  = Tick tick (makeDictsCoherent expr)
-makeDictsCoherent ty@(Type {})
-  = ty
-makeDictsCoherent co@(Coercion {})
-  = co
-
-{- Note [Unique dictionaries in the TmOracle CoreMap]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Any two dictionaries for a coherent typeclass should be considered equal
-in the TmOracle CoreMap, as this allows us to report better pattern-match
-warnings.
-
-Consider for example T21662:
-
-  view_fn :: forall (n :: Nat). KnownNat n => Int -> Bool
-
-  foo :: Int -> Int
-  foo (view_fn @12 -> True ) = 0
-  foo (view_fn @12 -> False) = 1
-
-In this example, the pattern match is exhaustive because we have covered
-the range of the view pattern function. However, we may fail to recognise
-the fact that the two cases use the same view function if the KnownNat
-dictionaries aren't syntactically equal:
-
-  eqn 1: [let ds_d1p0 = view_fn @12 $dKnownNat_a1ny ds_d1oR,  True <- ds_d1p0]
-  eqn 2: [let ds_d1p6 = view_fn @12 $dKnownNat_a1nC ds_d1oR, False <- ds_d1p6]
-
-Note that the uniques of the KnownNat 12 dictionary differ. If we fail to utilise
-the coherence of the KnownNat constraint, then we have to pessimistically assume
-that we have two function calls with different arguments:
-
-  foo (fn arg1 -> True ) = ...
-  foo (fn arg2 -> False) = ...
-
-In this case we can't determine whether the pattern matches are complete, so we
-emit a pattern match warning.
-
-Solution: replace all 'Id's whose type uniquely determines its value with
-a common value, e.g. in the above example we would replace both
-$dKnownNat_a1ny and $dKnownNat_a1nC with error @(KnownNat 12).
-
-Why did we choose this solution? Here are some alternatives that were considered:
-
-  1. Perform CSE first. This would common up the dictionaries before we compare
-     using the CoreMap.
-     However, this is architecturally difficult as it would require threading
-     a CSEnv through to desugarPat.
-  2. Directly modify CoreMap so that any two dictionaries of the same type are
-     considered equal.
-     The problem is that this affects all users of CoreMap. For example, CSE
-     would now assume that any two dictionaries of the same type are equal,
-     but this isn't necessarily true in the presence of magicDict, which
-     violates coherence by design. It seems more prudent to limit the changes
-     to the pattern-match checker only, to avoid undesirable consequences.
-
-In the end, replacing dictionaries with an error value in the pattern-match
-checker was the most self-contained, although we might want to revisit once
-we implement a more robust approach to computing equality in the pattern-match
-checker (see #19272).
--}
-
-{- Note [The Pos/Neg invariant]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Invariant applying to each VarInfo: Whenever we have @C @tvs args@ in 'vi_pos',
-any entry in 'vi_neg' must be incomparable to C (return Nothing) according to
-'eqPmAltCons'. Those entries that are comparable either lead to a refutation
-or are redundant. Examples:
-* @x ~ Just y@, @x ≁ [Just]@. 'eqPmAltCon' returns @Equal@, so refute.
-* @x ~ Nothing@, @x ≁ [Just]@. 'eqPmAltCon' returns @Disjoint@, so negative
-  info is redundant and should be discarded.
-* @x ~ I# y@, @x ≁ [4,2]@. 'eqPmAltCon' returns @PossiblyOverlap@, so orthogonal.
-  We keep this info in order to be able to refute a redundant match on i.e. 4
-  later on.
-
-This carries over to pattern synonyms and overloaded literals. Say, we have
-    pattern Just42 = Just 42
-    case Just42 of x
-      Nothing -> ()
-      Just _  -> ()
-Even though we had a solution for the value abstraction called x here in form
-of a PatSynCon Just42, this solution is incomparable to both Nothing and
-Just. Hence we retain the info in vi_neg, which eventually allows us to detect
-the complete pattern match.
-
-The Pos/Neg invariant extends to vi_rcm, which essentially stores positive
-information. We make sure that vi_neg and vi_rcm never overlap. This isn't
-strictly necessary since vi_rcm is just a cache, so doesn't need to be
-accurate: Every suggestion of a possible ConLike from vi_rcm might be
-refutable by the type oracle anyway. But it helps to maintain sanity while
-debugging traces.
-
-Note [Why record both positive and negative info?]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-You might think that knowing positive info (like x ~ Just y) would render
-negative info irrelevant, but not so because of pattern synonyms.  E.g we might
-know that x cannot match (Foo 4), where pattern Foo p = Just p
-
-Also overloaded literals themselves behave like pattern synonyms. E.g if
-postively we know that (x ~ I# y), we might also negatively want to record that
-x does not match 45 f 45       = e2 f (I# 22#) = e3 f 45       = e4  --
-Overlapped
-
-Note [TmState invariants]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-The term oracle state is never obviously (i.e., without consulting the type
-oracle or doing inhabitation testing) contradictory. This implies a few
-invariants:
-* Whenever vi_pos overlaps with vi_neg according to 'eqPmAltCon', we refute.
-  This is implied by the Note [The Pos/Neg invariant].
-* Whenever vi_neg subsumes a COMPLETE set, we refute. We consult vi_rcm to
-  detect this, but we could just compare whole COMPLETE sets to vi_neg every
-  time, if it weren't for performance.
-
-Maintaining these invariants in 'addVarCt' (the core of the term oracle) and
-'addNotConCt' is subtle.
-* Merging VarInfos. Example: Add the fact @x ~ y@ (see 'equate').
-  - (COMPLETE) If we had @x ≁ True@ and @y ≁ False@, then we get
-    @x ≁ [True,False]@. This is vacuous by matter of comparing to the built-in
-    COMPLETE set, so should refute.
-  - (Pos/Neg) If we had @x ≁ True@ and @y ~ True@, we have to refute.
-* Adding positive information. Example: Add the fact @x ~ K ys@ (see 'addConCt')
-  - (Neg) If we had @x ≁ K@, refute.
-  - (Pos) If we had @x ~ K2@, and that contradicts the new solution according to
-    'eqPmAltCon' (ex. K2 is [] and K is (:)), then refute.
-  - (Refine) If we had @x ≁ K zs@, unify each y with each z in turn.
-* Adding negative information. Example: Add the fact @x ≁ Nothing@ (see 'addNotConCt')
-  - (Refut) If we have @x ~ K ys@, refute.
-  - (COMPLETE) If K=Nothing and we had @x ≁ Just@, then we get
-    @x ≁ [Just,Nothing]@. This is vacuous by matter of comparing to the built-in
-    COMPLETE set, so should refute.
-
-Note that merging VarInfo in equate can be done by calling out to 'addConCt' and
-'addNotConCt' for each of the facts individually.
-
-Note [Representation of Strings in TmState]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Instead of treating regular String literals as a PmLits, we treat it as a list
-of characters in the oracle for better overlap reasoning. The following example
-shows why:
-
-  f :: String -> ()
-  f ('f':_) = ()
-  f "foo"   = ()
-  f _       = ()
-
-The second case is redundant, and we like to warn about it. Therefore either
-the oracle will have to do some smart conversion between the list and literal
-representation or treat is as the list it really is at runtime.
-
-The "smart conversion" has the advantage of leveraging the more compact literal
-representation wherever possible, but is really nasty to get right with negative
-equalities: Just think of how to encode @x /= "foo"@.
-The "list" option is far simpler, but incurs some overhead in representation and
-warning messages (which can be alleviated by someone with enough dedication).
-
-Note [Detecting pattern synonym applications in expressions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-At the moment we fail to detect pattern synonyms in scrutinees and RHS of
-guards. This could be alleviated with considerable effort and complexity, but
-the returns are meager. Consider:
-
-    pattern P
-    pattern Q
-    case P 15 of
-      Q _  -> ...
-      P 15 ->
-
-Compared to the situation where P and Q are DataCons, the lack of generativity
-means we could never flag Q as redundant. (also see Note [Undecidable Equality
-for PmAltCons] in PmTypes.) On the other hand, if we fail to recognise the
-pattern synonym, we flag the pattern match as inexhaustive. That wouldn't happen
-if we had knowledge about the scrutinee, in which case the oracle basically
-knows "If it's a P, then its field is 15".
-
-This is a pretty narrow use case and I don't think we should to try to fix it
-until a user complains energetically.
-
-Note [Completeness checking with required Thetas]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider the situation in #11224
-
-    import Text.Read (readMaybe)
-    pattern PRead :: Read a => () => a -> String
-    pattern PRead x <- (readMaybe -> Just x)
-    f :: String -> Int
-    f (PRead x)  = x
-    f (PRead xs) = length xs
-    f _          = 0
-
-Is the first match exhaustive on the PRead synonym? Should the second line thus
-deemed redundant? The answer is, of course, No! The required theta is like a
-hidden parameter which must be supplied at the pattern match site, so PRead
-is much more like a view pattern (where behavior depends on the particular value
-passed in).
-The simple solution here is to forget in 'addNotConCt' that we matched
-on synonyms with a required Theta like @PRead@, so that subsequent matches on
-the same constructor are never flagged as redundant. The consequence is that
-we no longer detect the actually redundant match in
-
-    g :: String -> Int
-    g (PRead x) = x
-    g (PRead y) = y -- redundant!
-    g _         = 0
-
-But that's a small price to pay, compared to the proper solution here involving
-storing required arguments along with the PmAltConLike in 'vi_neg'.
-
-Note [Strict fields and variables of unlifted type]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Binders of unlifted type (and strict fields) are unlifted by construction;
-they are conceived with an implicit (but delayed checked) @≁⊥@ constraint to
-begin with. Hence, desugaring in "GHC.HsToCore.Pmc" is entirely unconcerned
-by strict fields, since the forcing happens *before* pattern matching. And
-the φ constructor constraints emitted by 'GHC.HsToCore.Pmc.checkGrd' have
-complex binding semantics (binding type constraints and unlifted fields), so
-unliftedness semantics are entirely confined to the oracle.
-
-These are the moving parts:
-
-  1.  For each strict (or more generally, unlifted) field @s@ of a 'PhiConCt'
-      we have to add a @s ≁ ⊥@ constraint in the corresponding case of
-      'addPhiTmCt'. Strict fields are devoid of ⊥ by construction, there's
-      nothing that a bang pattern would act on. Example from #18341:
-
-        data T = MkT !Int
-        f :: T -> ()
-        f (MkT  _) | False = () -- inaccessible
-        f (MkT !_) | False = () -- redundant, not only inaccessible!
-        f _                = ()
-
-      The second clause desugars to @MkT n <- x, !n@. When coverage checked,
-      the 'PmCon' @MkT n <- x@ refines the set of values that reach the bang
-      pattern with the φ constraints @MkT n <- x@ (Nothing surprising so far).
-      Upon that constraint, it disperses into two lower-level δ constraints
-      @x ~ MkT n, n ≁ ⊥@ per Equation (3) in Figure 7 of the paper.
-
-      Checking the 'PmBang' @!n@ will then try to add the
-      constraint @n ~ ⊥@ to this set to get the diverging set, which is found
-      to be empty. Hence the whole clause is detected as redundant, as
-      expected.
-
-  2.  Similarly, when performing the 'inhabitationTest', when instantiating a
-      constructor we call 'instCon', which generates a higher-level φ
-      constructor constraint.
-
-  3.  The preceding points handle unlifted constructor fields, but there also
-      are regular binders of unlifted type. We simply fail in 'addBotCt' for
-      any binder of unlifted type.
-      It would be enough to check for unliftedness once, when the binder comes
-      into scope, but we haven't really a way to track that.
-
-  4.  Why not start an 'emptyVarInfo' of unlifted type with @vi_bot = IsNotBot@?
-      Because then we'd need to trigger an inhabitation test, because the var
-      might actually be void to begin with. But we can't trigger the test from
-      'emptyVarInfo'.
-      Historically, that is what we did and not doing the test led to #20631,
-      where 'addNotBotCt' trivially succeeded, because the 'VarInfo' already
-      said 'IsNotBot', implying that a prior inhabitation test succeeded.
--}
-
--------------------------
--- * Inhabitation testing
---
--- Figure 8 in the LYG paper.
-
-tyStateRefined :: TyState -> TyState -> Bool
--- Makes use of the fact that the two TyStates we compare will never have the
--- same sequence number. It is invalid to call this function when a is not a
--- refinement of b or vice versa!
-tyStateRefined a b = ty_st_n a /= ty_st_n b
-
-markDirty :: Id -> Nabla -> Nabla
-markDirty x nabla@MkNabla{nabla_tm_st = ts@TmSt{ts_dirty = dirty} } =
-  nabla{ nabla_tm_st = ts{ ts_dirty = extendDVarSet dirty x } }
-
-traverseDirty :: Monad m => (VarInfo -> m VarInfo) -> TmState -> m TmState
-traverseDirty f ts@TmSt{ts_facts = env, ts_dirty = dirty} =
-  go (uniqDSetToList dirty) env
-  where
-    go []     env  = pure ts{ts_facts=env}
-    go (x:xs) !env = do
-      vi' <- f (lookupVarInfo ts x)
-      go xs (addToUSDFM env x vi')
-
-traverseAll :: Monad m => (VarInfo -> m VarInfo) -> TmState -> m TmState
-traverseAll f ts@TmSt{ts_facts = env} = do
-  env' <- traverseUSDFM f env
-  pure ts{ts_facts = env'}
-
--- | Makes sure the given 'Nabla' is still inhabited, by trying to instantiate
--- all dirty variables (or all variables when the 'TyState' changed) to concrete
--- inhabitants. It returns a 'Nabla' with the *same* inhabitants, but with some
--- amount of work cached (like failed instantiation attempts) from the test.
---
--- The \(∇ ⊢ x inh\) judgment form in Figure 8 of the LYG paper.
-inhabitationTest :: Int -> TyState -> Nabla -> MaybeT DsM Nabla
-inhabitationTest 0     _         nabla             = pure nabla
-inhabitationTest fuel  old_ty_st nabla@MkNabla{ nabla_tm_st = ts } = {-# SCC "inhabitationTest" #-} do
-  -- lift $ tracePm "inhabitation test" $ vcat
-  --   [ ppr fuel
-  --   , ppr old_ty_st
-  --   , ppr nabla
-  --   , text "tyStateRefined:" <+> ppr (tyStateRefined old_ty_st (nabla_ty_st nabla))
-  --   ]
-  -- When type state didn't change, we only need to traverse dirty VarInfos
-  ts' <- if tyStateRefined old_ty_st (nabla_ty_st nabla)
-            then traverseAll   test_one ts
-            else traverseDirty test_one ts
-  pure nabla{ nabla_tm_st = ts'{ts_dirty=emptyDVarSet}}
-  where
-    nabla_not_dirty = nabla{ nabla_tm_st = ts{ts_dirty=emptyDVarSet} }
-    test_one :: VarInfo -> MaybeT DsM VarInfo
-    test_one vi =
-      lift (varNeedsTesting old_ty_st nabla vi) >>= \case
-        True -> do
-          -- lift $ tracePm "test_one" (ppr vi)
-          -- No solution yet and needs testing
-          -- We have to test with a Nabla where all dirty bits are cleared
-          instantiate (fuel-1) nabla_not_dirty vi
-        _ -> pure vi
-
--- | Checks whether the given 'VarInfo' needs to be tested for inhabitants.
--- Returns `False` when we can skip the inhabitation test, presuming it would
--- say "yes" anyway. See Note [Shortcutting the inhabitation test].
-varNeedsTesting :: TyState -> Nabla -> VarInfo -> DsM Bool
-varNeedsTesting _         MkNabla{nabla_tm_st=tm_st}     vi
-  | elemDVarSet (vi_id vi) (ts_dirty tm_st) = pure True
-varNeedsTesting _         _                              vi
-  | notNull (vi_pos vi)                     = pure False
-varNeedsTesting old_ty_st MkNabla{nabla_ty_st=new_ty_st} _
-  -- Same type state => still inhabited
-  | not (tyStateRefined old_ty_st new_ty_st) = pure False
-varNeedsTesting old_ty_st MkNabla{nabla_ty_st=new_ty_st} vi = do
-  -- These normalisations are relatively expensive, but still better than having
-  -- to perform a full inhabitation test
-  (_, _, old_norm_ty) <- tntrGuts <$> pmTopNormaliseType old_ty_st (idType $ vi_id vi)
-  (_, _, new_norm_ty) <- tntrGuts <$> pmTopNormaliseType new_ty_st (idType $ vi_id vi)
-  if old_norm_ty `eqType` new_norm_ty
-    then pure False
-    else pure True
-
--- | Returns (Just vi) if at least one member of each ConLike in the COMPLETE
--- set satisfies the oracle
---
--- Internally uses and updates the CompleteMatchs in vi_rcm.
---
--- NB: Does /not/ filter each CompleteMatch with the oracle; members may
---     remain that do not satisfy it.  This lazy approach just
---     avoids doing unnecessary work.
-instantiate :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo
-instantiate fuel nabla vi = {-# SCC "instantiate" #-}
-  (instBot fuel nabla vi <|> instCompleteSets fuel nabla vi)
-
--- | The \(⊢_{Bot}\) rule from the paper
-instBot :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo
-instBot _fuel nabla vi = {-# SCC "instBot" #-} do
-  _nabla' <- addBotCt nabla (vi_id vi)
-  pure vi
-
-addNormalisedTypeMatches :: Nabla -> Id -> DsM (ResidualCompleteMatches, Nabla)
-addNormalisedTypeMatches nabla@MkNabla{ nabla_ty_st = ty_st } x
-  = trvVarInfo add_matches nabla x
-  where
-    add_matches vi@VI{ vi_rcm = rcm }
-      -- important common case, shaving down allocations of PmSeriesG by -5%
-      | isRcmInitialised rcm = pure (rcm, vi)
-    add_matches vi@VI{ vi_rcm = rcm } = do
-      norm_res_ty <- normaliseSourceTypeWHNF ty_st (idType x)
-      env <- dsGetFamInstEnvs
-      rcm' <- case splitReprTyConApp_maybe env norm_res_ty of
-        Just (rep_tc, _args, _co)  -> addTyConMatches rep_tc rcm
-        Nothing                    -> addCompleteMatches rcm
-      pure (rcm', vi{ vi_rcm = rcm' })
-
--- | Does a 'splitTyConApp_maybe' and then tries to look through a data family
--- application to find the representation TyCon, to which the data constructors
--- are attached. Returns the representation TyCon, the TyCon application args
--- and a representational coercion that will be Refl for non-data family apps.
-splitReprTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)
-splitReprTyConApp_maybe env ty =
-  uncurry (tcLookupDataFamInst env) <$> splitTyConApp_maybe ty
-
--- | This is the |-Inst rule from the paper (section 4.5). Tries to
--- find an inhabitant in every complete set by instantiating with one their
--- constructors. If there is any complete set where we can't find an
--- inhabitant, the whole thing is uninhabited. It returns the updated 'VarInfo'
--- where all the attempted ConLike instantiations have been purged from the
--- 'ResidualCompleteMatches', which functions as a cache.
-instCompleteSets :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo
-instCompleteSets fuel nabla vi = {-# SCC "instCompleteSets" #-} do
-  let x = vi_id vi
-  (rcm, nabla) <- lift (addNormalisedTypeMatches nabla x)
-  nabla <- foldM (\nabla cls -> instCompleteSet fuel nabla x cls) nabla (getRcm rcm)
-  pure (lookupVarInfo (nabla_tm_st nabla) x)
-
-anyConLikeSolution :: (ConLike -> Bool) -> [PmAltConApp] -> Bool
-anyConLikeSolution p = any (go . paca_con)
-  where
-    go (PmAltConLike cl) = p cl
-    go _                 = False
-
--- | @instCompleteSet fuel nabla x cls@ iterates over @cls@ until it finds
--- the first inhabited ConLike (as per 'instCon'). Any failed instantiation
--- attempts of a ConLike are recorded as negative information in the returned
--- 'Nabla', so that later calls to this function can skip repeatedly fruitless
--- instantiation of that same constructor.
---
--- Note that the returned Nabla is just a different representation of the
--- original Nabla, not a proper refinement! No positive information will be
--- added, only negative information from failed instantiation attempts,
--- entirely as an optimisation.
-instCompleteSet :: Int -> Nabla -> Id -> CompleteMatch -> MaybeT DsM Nabla
-instCompleteSet fuel nabla x cs
-  | anyConLikeSolution (`elementOfUniqDSet` (cmConLikes cs)) (vi_pos vi)
-  -- No need to instantiate a constructor of this COMPLETE set if we already
-  -- have a solution!
-  = pure nabla
-  | not (completeMatchAppliesAtType (varType x) cs)
-  = pure nabla
-  | otherwise
-  = {-# SCC "instCompleteSet" #-} go nabla (sorted_candidates cs)
-  where
-    vi = lookupVarInfo (nabla_tm_st nabla) x
-
-    sorted_candidates :: CompleteMatch -> [ConLike]
-    sorted_candidates cm
-      -- If there aren't many candidates, we can try to sort them by number of
-      -- strict fields, type constraints, etc., so that we are fast in the
-      -- common case
-      -- (either many simple constructors *or* few "complicated" ones).
-      | sizeUniqDSet cs <= 5 = sortBy compareConLikeTestability (uniqDSetToList cs)
-      | otherwise            = uniqDSetToList cs
-      where cs = cmConLikes cm
-
-    go :: Nabla -> [ConLike] -> MaybeT DsM Nabla
-    go _     []         = mzero
-    go nabla (RealDataCon dc:_)
-      -- See Note [DataCons that are definitely inhabitable]
-      -- Recall that dc can't be in vi_neg, because then it would be
-      -- deleted from the residual COMPLETE set.
-      | isDataConTriviallyInhabited dc
-      = pure nabla
-    go nabla (con:cons) = do
-      let x = vi_id vi
-      let recur_not_con = do
-            nabla' <- addNotConCt nabla x (PmAltConLike con)
-            go nabla' cons
-      (nabla <$ instCon fuel nabla x con) -- return the original nabla, not the
-                                          -- refined one!
-            <|> recur_not_con -- Assume that x can't be con. Encode that fact
-                              -- with addNotConCt and recur.
-
--- | Is this 'DataCon' trivially inhabited, that is, without needing to perform
--- any inhabitation testing because of strict/unlifted fields or type
--- equalities? See Note [DataCons that are definitely inhabitable]
-isDataConTriviallyInhabited :: DataCon -> Bool
-isDataConTriviallyInhabited dc
-  | isTyConTriviallyInhabited (dataConTyCon dc) = True
-isDataConTriviallyInhabited dc =
-  null (dataConTheta dc) &&                -- (1)
-  null (dataConImplBangs dc) &&            -- (2)
-  null (dataConMightBeUnliftedFieldTys dc) -- (3)
-
-dataConMightBeUnliftedFieldTys :: DataCon -> [Type]
-dataConMightBeUnliftedFieldTys =
-  filter mightBeUnliftedType . map scaledThing . dataConOrigArgTys
-
-isTyConTriviallyInhabited :: TyCon -> Bool
-isTyConTriviallyInhabited tc = elementOfUniqSet (getUnique tc) triviallyInhabitedTyConKeys
-
--- | All these types are trivially inhabited
-triviallyInhabitedTyConKeys :: UniqSet Unique
-triviallyInhabitedTyConKeys = mkUniqSet [
-    charTyConKey, doubleTyConKey, floatTyConKey,
-    intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey,
-    intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,
-    wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey,
-    wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey,
-    trTyConTyConKey
-  ]
-
-compareConLikeTestability :: ConLike -> ConLike -> Ordering
--- We should instantiate DataCons first, because they are likely to occur in
--- multiple COMPLETE sets at once and we might find that multiple COMPLETE sets
--- are inhabited by instantiating only a single DataCon.
-compareConLikeTestability PatSynCon{}     _               = GT
-compareConLikeTestability _               PatSynCon{}     = GT
-compareConLikeTestability (RealDataCon a) (RealDataCon b) = mconcat
-  -- Thetas are most expensive to check, as they might incur a whole new round
-  -- of inhabitation testing
-  [ comparing (fast_length . dataConTheta)
-  -- Unlifted or strict fields only incur an inhabitation test for that
-  -- particular field. Still something to avoid.
-  , comparing unlifted_or_strict_fields
-  ] a b
-  where
-    fast_length :: [a] -> Int
-    fast_length xs = atLength length 6 xs 5 -- @min 6 (length xs)@, but O(1)
-
-    -- An upper bound on the number of strict or unlifted fields. Approximate in
-    -- the unlikely bogus case of an unlifted field that has a bang.
-    unlifted_or_strict_fields :: DataCon -> Int
-    unlifted_or_strict_fields dc = fast_length (dataConImplBangs dc)
-                                 + fast_length (dataConMightBeUnliftedFieldTys dc)
-
--- | @instCon fuel nabla (x::match_ty) K@ tries to instantiate @x@ to @K@ by
--- adding the proper constructor constraint.
---
--- See Note [Instantiating a ConLike].
-instCon :: Int -> Nabla -> Id -> ConLike -> MaybeT DsM Nabla
-instCon fuel nabla@MkNabla{nabla_ty_st = ty_st} x con = {-# SCC "instCon" #-} MaybeT $ do
-  let hdr what = "instCon " ++ show fuel ++ " " ++ what
-  env <- dsGetFamInstEnvs
-  let match_ty = idType x
-  tracePm (hdr "{") $
-    ppr con <+> text "... <-" <+> ppr x <+> dcolon <+> ppr match_ty
-  norm_match_ty <- normaliseSourceTypeWHNF ty_st match_ty
-  mb_sigma_univ <- matchConLikeResTy env ty_st norm_match_ty con
-  case mb_sigma_univ of
-    Just sigma_univ -> do
-      let (_univ_tvs, ex_tvs, eq_spec, thetas, _req_theta, field_tys, _con_res_ty)
-            = conLikeFullSig con
-      -- Following Note [Instantiating a ConLike]:
-      -- (1) _req_theta has been tested in 'matchConLikeResTy'
-      -- (2) Instantiate fresh existentials
-      (sigma_ex, _) <- cloneTyVarBndrs sigma_univ ex_tvs <$> getUniqueSupplyM
-      -- (3) Substitute provided constraints bound by the constructor.
-      --     These are added to the type oracle as new facts (in a moment)
-      let gammas = substTheta sigma_ex (eqSpecPreds eq_spec ++ thetas)
-      -- (4) Instantiate fresh term variables as arguments to the constructor
-      let field_tys' = substTys sigma_ex $ map scaledThing field_tys
-      arg_ids <- mapM mkPmId field_tys'
-      tracePm (hdr "(cts)") $ vcat
-        [ ppr x <+> dcolon <+> ppr match_ty
-        , text "In WHNF:" <+> ppr (isSourceTypeInWHNF match_ty) <+> ppr norm_match_ty
-        , ppr con <+> dcolon <+> text "... ->" <+> ppr _con_res_ty
-        , ppr (map (\tv -> ppr tv <+> char '↦' <+> ppr (substTyVar sigma_univ tv)) _univ_tvs)
-        , ppr gammas
-        , ppr (map (\x -> ppr x <+> dcolon <+> ppr (idType x)) arg_ids)
-        ]
-      -- (5) Finally add the new constructor constraint
-      runMaybeT $ do
-        -- Case (2) of Note [Strict fields and variables of unlifted type]
-        let alt = PmAltConLike con
-        let branching_factor = length $ filterUnliftedFields alt arg_ids
-        let ct = PhiConCt x alt ex_tvs gammas arg_ids
-        nabla1 <- traceWhenFailPm (hdr "(ct unsatisfiable) }") (ppr ct) $
-                  addPhiTmCt nabla ct
-        -- See Note [Fuel for the inhabitation test]
-        let new_fuel
-              | branching_factor <= 1 = fuel
-              | otherwise             = min fuel 2
-        lift $ tracePm (hdr "(ct satisfiable)") $ vcat
-          [ ppr ct
-          , ppr x <+> dcolon <+> ppr match_ty
-          , text "In WHNF:" <+> ppr (isSourceTypeInWHNF match_ty) <+> ppr norm_match_ty
-          , ppr con <+> dcolon <+> text "... ->" <+> ppr _con_res_ty
-          , ppr (map (\tv -> ppr tv <+> char '↦' <+> ppr (substTyVar sigma_univ tv)) _univ_tvs)
-          , ppr gammas
-          , ppr (map (\x -> ppr x <+> dcolon <+> ppr (idType x)) arg_ids)
-          , ppr branching_factor
-          , ppr new_fuel
-          ]
-        nabla2 <- traceWhenFailPm (hdr "(inh test failed) }") (ppr nabla1) $
-                  inhabitationTest new_fuel (nabla_ty_st nabla) nabla1
-        lift $ tracePm (hdr "(inh test succeeded) }") (ppr nabla2)
-        pure nabla2
-    Nothing -> do
-      tracePm (hdr "(match_ty not instance of res_ty) }") empty
-      pure (Just nabla) -- Matching against match_ty failed. Inhabited!
-                        -- See Note [Instantiating a ConLike].
-
--- | @matchConLikeResTy _ _ ty K@ tries to match @ty@ against the result
--- type of @K@, @res_ty@. It returns a substitution @s@ for @K@'s universal
--- tyvars such that @s(res_ty)@ equals @ty@ if successful.
---
--- Make sure that @ty@ is normalised before.
---
--- See Note [Matching against a ConLike result type].
-matchConLikeResTy :: FamInstEnvs -> TyState -> Type -> ConLike -> DsM (Maybe Subst)
-matchConLikeResTy env _              ty (RealDataCon dc) = pure $ do
-  (rep_tc, tc_args, _co) <- splitReprTyConApp_maybe env ty
-  if rep_tc == dataConTyCon dc
-    then Just (zipTCvSubst (dataConUnivTyVars dc) tc_args)
-    else Nothing
-matchConLikeResTy _   (TySt _ inert) ty (PatSynCon ps) = {-# SCC "matchConLikeResTy" #-} runMaybeT $ do
-  let (univ_tvs,req_theta,_,_,_,con_res_ty) = patSynSig ps
-  subst <- MaybeT $ pure $ tcMatchTy con_res_ty ty
-  guard $ all (`elemSubst` subst) univ_tvs -- See the Note about T11336b
-  if null req_theta
-    then pure subst
-    else do
-      let req_theta' = substTys subst req_theta
-      satisfiable <- lift $ initTcDsForSolver $ tcCheckWanteds inert req_theta'
-      if satisfiable
-        then pure subst
-        else mzero
-
-{- Note [Soundness and Completeness]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Soundness and completeness of the pattern-match checker depend entirely on the
-soundness and completeness of the inhabitation test.
-
-Achieving both soundness and completeness at the same time is undecidable.
-See also T17977 and Note [Fuel for the inhabitation test].
-Losing soundness would make the algorithm pointless; hence we give up on
-completeness, but try to get as close as possible (how close is called
-the 'precision' of the algorithm).
-
-Soundness means that you
-  1. Can remove clauses flagged as redundant without changing program semantics
-     (no false positives).
-  2. Can be sure that your program is free of incomplete pattern matches
-     when the checker doesn't flag any inexhaustive definitions
-     (no false negatives).
-
-A complete algorithm would mean that
-  1. When a clause can be deleted without changing program semantics, it will
-     be flagged as redundant (no false negatives).
-  2. A program that is free of incomplete pattern matches will never have a
-     definition be flagged as inexhaustive (no false positives).
-
-Via the LYG algorithm, we reduce both these properties to a property on
-the inhabitation test of refinement types:
-  *Soundness*:    If the inhabitation test says "no" for a given refinement type
-                  Nabla, then it provably has no inhabitant.
-  *Completeness*: If the inhabitation test says "yes" for a given refinement type
-                  Nabla, then it provably has an inhabitant.
-Our test is sound, but incomplete, so there are instances where we say
-"yes" but in fact the Nabla is empty. Which entails false positive exhaustivity
-and false negative redundancy warnings, as above.
-
-In summary, we have the following correspondence:
-
-Property     | Exhaustiveness warnings | Redundancy warnings | Inhabitation test |
--------------|-------------------------|---------------------|-------------------|
-Soundness    | No false negatives      | No false positives  | Only says "no"    |
-             |                         |                     | if there is no    |
-             |                         |                     | inhabitant        |
-Completeness | No false positives      | No false negatives  | Only says "yes"   |
-             |                         |                     | if there is an    |
-             |                         |                     | inhabitant        |
-
-Note [Shortcutting the inhabitation test]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Generally, we have to re-test a refinement type for inhabitants whenever we
-add a new constraint. Often, we can say "no" early, upon trying to add a
-contradicting constraint, see Note [The Pos/Neg invariant]. Still, COMPLETE
-sets and type evidence are best handled in a delayed fashion, because of
-the recursive nature of the test and our fuel-based approach.
-But even then there are some cases in which we can skip the full test,
-because we are sure that the refinement type is still inhabited. These
-conditions are monitored by 'varNeedsTesting'. It returns
-
-- `True` whenever a full inhabitation test is needed
-- `False` whenever the test can be skipped, amounting to an inhabitation test
-  that says "yes".
-
-According to Note [Soundness and Completeness], this test will never compromise
-soundness: The `True` case just forwards to the actual inhabitation test and the
-`False` case amounts to an inhabitation test that is trivially sound, because it
-never says "no".
-
-Of course, if the returns says `False`, Completeness (and thus Precision) of the
-algorithm is affected, but we get to skip costly inhabitation tests. We try to
-trade as little Precision as possible against as much Performance as possible.
-Here are the tests, in order:
-
-  1. If a variable is dirty (because of a newly added negative term constraint),
-     we have to test.
-  2. If a variable has positive information, we don't have to test: The
-     positive information acts as constructive proof for inhabitation.
-  3. If the type state didn't change, there is no need to test.
-  4. If the variable's normalised type didn't change, there is no need to test.
-  5. Otherwise, we have to test.
-
-Why (1) before (2)?
--------------------
-Consider the reverse for (T18960):
-  pattern P x = x
-  {-# COMPLETE P :: () #-}
-  foo = case () of x@(P _) -> ()
-This should be exhaustive. But if we say "We know `x` has solution `()`, so it's
-inhabited", then we'll get a warning saying that `()` wasn't matched.
-But the match on `P` added the new negative information to the uncovered set,
-in the process of which we marked `x` as dirty. By giving the dirty flag a
-higher priority than positive info, we get to test again and see that `x` is
-uninhabited and the match is exhaustive.
-
-But suppose that `P` wasn't mentioned in any COMPLETE set. Then we simply
-don't mark `x` as dirty and will emit a warning again (which we would anyway),
-without running a superfluous inhabitation test. That speeds up T17836
-considerably.
-
-Why (2) before (3) and (4)?
----------------------------
-Simply because (2) is more efficient to test than (3) (not by a lot), which
-is more efficient to test than (4), which is still more efficient than running
-the full inhabitation test (5).
-
-Note [Fuel for the inhabitation test]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Whether or not a type is inhabited is undecidable in general, see also
-Note [Soundness and Completeness]. As a result, we can run into infinite
-loops in `inhabitationTest`. Therefore, we adopt a fuel-based approach to
-prevent that.
-
-Consider the following example:
-
-  data Abyss = MkAbyss !Abyss
-  stareIntoTheAbyss :: Abyss -> a
-  stareIntoTheAbyss x = case x of {}
-
-In principle, stareIntoTheAbyss is exhaustive, since there is no way to
-construct a terminating value using MkAbyss. But this can't be proven by mere
-instantiation and requires an inductive argument, which `inhabitationTest`
-currently isn't equipped to do.
-
-In order to prevent endless instantiation attempts in @inhabitationTest@, we
-use the fuel as an upper bound on such attempts.
-
-The same problem occurs with recursive newtypes, like in the following code:
-
-  newtype Chasm = MkChasm Chasm
-  gazeIntoTheChasm :: Chasm -> a
-  gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive
-
-So this limitation is somewhat understandable.
-
-Note that even with this recursion detection, there is still a possibility that
-`inhabitationTest` can run in exponential time in the amount of fuel. Consider
-the following data type:
-
-  data T = MkT !T !T !T
-
-If we try to instantiate each of its fields, that will require us to once again
-check if `MkT` is inhabitable in each of those three fields, which in turn will
-require us to check if `MkT` is inhabitable again... As you can see, the
-branching factor adds up quickly, and if the initial fuel is, say,
-100, then the inhabitation test will effectively take forever.
-
-To mitigate this, we check the branching factor every time we are about to do
-inhabitation testing in 'instCon'. If the branching factor exceeds 1
-(i.e., if there is potential for exponential runtime), then we limit the
-maximum recursion depth to 1 to mitigate the problem. If the branching factor
-is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay
-to stick with a larger maximum recursion depth.
-
-In #17977 we saw that the defaultRecTcMaxBound (100 at the time of writing) was
-too large and had detrimental effect on performance of the coverage checker.
-Given that we only commit to a best effort anyway, we decided to substantially
-decrement the fuel to 4, at the cost of precision in some edge cases
-like
-
-  data Nat = Z | S Nat
-  data Down :: Nat -> Type where
-    Down :: !(Down n) -> Down (S n)
-  f :: Down (S (S (S (S (S Z))))) -> ()
-  f x = case x of {}
-
-Since the coverage won't bother to instantiate Down 4 levels deep to see that it
-is in fact uninhabited, it will emit a inexhaustivity warning for the case.
-
-Note [DataCons that are definitely inhabitable]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Another microoptimization applies to data types like this one:
-
-  data S a = S ![a] !T
-
-Even though there is a strict field of type [a], it's quite silly to call
-'instCon' on it, since it's "obvious" that it is inhabitable. To make this
-intuition formal, we say that a DataCon C is definitely inhabitable (DI) if:
-
-  1. C has no equality constraints (since they might be unsatisfiable)
-  2. C has no strict arguments (since they might be uninhabitable)
-  3. C has no unlifted argument types (since they might be uninhabitable)
-
-It's relatively cheap to check if a DataCon is DI, so before we call 'instCon'
-on a constructor of a COMPLETE set, we filter out all of the DI ones.
-
-This fast path shaves down -7% allocations for PmSeriesG, for example.
-
-Note [Matching against a ConLike result type]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given a ConLike
-
-> C :: forall us. R => ... -> res_ty
-
-is a pattern `C ...` compatible with the type `ty`? Clearly that is the case if
-`res_ty` /subsumes/ `ty` and the required constraints `R` (strictly a feature of
-pattern synonyms) are satisfiable. In that case, 'matchConLikeResTy' returns a
-substitution σ over `us` such that `σ(res_ty) == ty`.
-
-It's surprisingly tricky to implement correctly, and works quite different for
-DataCons and PatSynCons:
-
-  * For data cons, we look at `ty` and see if it's a TyCon app `T t1 ... tn`.
-    If that is the case, we make sure that `C` is a DataCon of `T` and return
-    a substitution mapping `C`'s universal tyvars `us` to `t1`...`tn`.
-
-    Wrinkle: Since `T` might be a data family TyCon, we have to look up its
-    representation TyCon before we compare to `C`'s TyCon.
-    So we use 'splitReprTyConApp_maybe' instead of 'splitTyConApp_maybe'.
-
-  * For pattern synonyms, we directly match `ty` against `res_ty` to get the
-    substitution σ. See Note [Pattern synonym result type] in "GHC.Core.PatSyn".
-
-    Fortunately, we don't have to treat data family TyCons specially:
-    Pattern synonyms /never/ apply to a data family representation TyCon.
-    We do have to consider the required constraints `σ(R)`, though, as we have
-    seen in #19475. That is done by solving them as Wanted constraints given the
-    inert set of the current type state (which is part of a Nabla's TySt). Since
-    spinning up a constraint solver session is costly, we only do so in the rare
-    cases that a pattern synonym actually carries any required constraints.
-
-    We can get into the strange situation that not all universal type variables
-    `us` occur in `res_ty`. Example from T11336b:
-
-      instance C Proxy where ...                      -- impl uninteresting
-      pattern P :: forall f a. C f => f a -> Proxy a  -- impl uninteresting
-
-      fun :: Proxy a -> ()
-      fun (P Proxy) = ()
-      fun (P Proxy) = () -- ideally detected as redundant
-
-    `f` is a universal type variable and `C f` the required constraint of
-    pattern synonym `P`. But `f` doesn't occur in the result type `Proxy a` of
-    `P`, so σ will not even have `f` in its in-scope set. It's a bit unclear
-    what to do here; we might want to freshen `f` to `f'` and see if we can
-    solve `C f'` as a Wanted constraint, which we most likely can't.
-    Hence, we simply skip the freshening and declare the match as failed when
-    there is a variable like `f`. For the definition of `fun`, that
-    means we will not remember that we matched on `P` and thus will
-    not detect its second clause as redundant.
-
-    See Note [Pattern synonym result type] in "GHC.Core.PatSyn" for similar
-    oddities.
-
-Note [Instantiating a ConLike]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-`instCon` implements the \(Inst\) function from Figure 8 of the LYG paper.
-
-Given the following type of ConLike `K`
-
-> K :: forall us. R => forall es. P => t1 -> ... -> tn -> res_ty
-
-and a variable `x::match_ty`, it tries to find an instantiation
-`K ex_tvs gammas arg_ids :: match_ty` (for fresh `arg_ids`) and ultimately adds
-a constructor constraint `K ex_tvs gammas arg_ids <- x` to the given Nabla.
-
-As a first step, it tries (via 'matchConLikeResTy') to match `match_ty` against
-`res_ty` and checks that that the required constraints @R@ are satisfiable.
-See Note [Matching against a ConLike result type].
-
-If matching /fails/, it trivially (and conservatively) reports "inhabited" by
-returning the unrefined input Nabla. After all, the match might have failed due
-to incomplete type information in Nabla.
-(Later type refinement from unpacking GADT constructors might monomorphise
-`match_ty` so much that `res_ty` ultimately subsumes it.)
-
-If matching /succeeds/, we get a substitution σ for the (universal)
-tyvars `us`. After applying σ, we get
-
-> K @σ(us) :: σ(R) => forall σ(es). σ(P) => σ(t1) -> ... -> σ(tn) -> match_ty
-
-The existentials `es` might still occur in argument types `σ(tn)`, though.
-Now 'instCon' performs the following steps:
-
- 1. It drops the required constraints `σ(R)`, as they have already been
-    discharged by 'matchConLikeResTy'.
- 2. It instantiates fresh binders `es'` for the other type variables `es`
-    bound by `K` and adds the mapping to σ to get σ', so that we have
-
-    > K @σ(us) @es' :: σ'(P) => σ'(t1) -> ... -> σ'(tn) -> match_ty
-
- 3. It adds new type constraints from the substituted
-    provided constraints @σ'(P)@.
- 4. It substitutes and conjures new binders @arg_ids@ for the argument types
-    @σ'(t1) ... σ'(tn)@.
- 5. It adds a term constraint @K es' σ'(P) arg_ids <- x@, which handles
-    the details regarding type constraints and unlifted fields.
-
-And finally the extended 'Nabla' is returned if all the constraints were
-compatible.
--}
-
---------------------------------------
--- * Generating inhabitants of a Nabla
---
--- This is important for warnings. Roughly corresponds to G in Figure 6 of the
--- LYG paper, with a few tweaks for better warning messages.
-
--- | See Note [Case split inhabiting patterns]
-data GenerateInhabitingPatternsMode
-  = CaseSplitTopLevel
-  | MinimalCover
-  deriving (Eq, Show)
-
-instance Outputable GenerateInhabitingPatternsMode where
-  ppr = text . show
-
--- | @generateInhabitingPatterns vs n nabla@ returns a list of at most @n@ (but
--- perhaps empty) refinements of @nabla@ that represent inhabited patterns.
--- Negative information is only retained if literals are involved or for
--- recursive GADTs.
-generateInhabitingPatterns :: GenerateInhabitingPatternsMode -> [Id] -> Int -> Nabla -> DsM [Nabla]
--- See Note [Why inhabitationTest doesn't call generateInhabitingPatterns]
-generateInhabitingPatterns _    _      0 _     = pure []
-generateInhabitingPatterns _    []     _ nabla = pure [nabla]
-generateInhabitingPatterns mode (x:xs) n nabla = do
-  tracePm "generateInhabitingPatterns" (ppr mode <+> ppr n <+> ppr (x:xs) $$ ppr nabla)
-  let VI _ pos neg _ _ = lookupVarInfo (nabla_tm_st nabla) x
-  case pos of
-    _:_ -> do
-      -- Example for multiple solutions (must involve a PatSyn):
-      --   f x@(Just _) True | SomePatSyn _ <- x = ...
-      -- within the RHS, we know that
-      --   * @x ~ Just y@ for some @y@
-      --   * @x ~ SomePatSyn z@ for some @z@
-      -- and both conditions have to hold /at the same time/. Hence we must
-      -- find evidence for @y@ and @z@ that is valid at the same time. These
-      -- constitute arg_vas below.
-      let arg_vas = concatMap paca_ids pos
-      generateInhabitingPatterns mode (arg_vas ++ xs) n nabla
-    []
-      -- When there are literals involved, just print negative info
-      -- instead of listing missed constructors
-      | notNull [ l | PmAltLit l <- pmAltConSetElems neg ]
-      -> generateInhabitingPatterns mode xs n nabla
-      -- When some constructors are impossible or when we don't care for a
-      -- minimal cover (Note [Case split inhabiting patterns]), do a case split.
-      | not (isEmptyPmAltConSet neg) || mode == CaseSplitTopLevel
-      -> try_instantiate x xs n nabla
-      -- Else don't do a case split on this var, just print a wildcard.
-      -- But try splitting for the remaining vars, of course
-      | otherwise
-      -> generateInhabitingPatterns mode xs n nabla
-  where
-    -- Tries to instantiate a variable by possibly following the chain of
-    -- newtypes and then instantiating to all ConLikes of the wrapped type's
-    -- minimal residual COMPLETE set.
-    try_instantiate :: Id -> [Id] -> Int -> Nabla -> DsM [Nabla]
-    -- Convention: x binds the outer constructor in the chain, y the inner one.
-    try_instantiate x xs n nabla = do
-      (_src_ty, dcs, rep_ty) <- tntrGuts <$> pmTopNormaliseType (nabla_ty_st nabla) (idType x)
-      mb_stuff <- runMaybeT $ instantiate_newtype_chain x nabla dcs
-      case mb_stuff of
-        Nothing -> pure []
-        Just (y, newty_nabla) -> do
-          let vi = lookupVarInfo (nabla_tm_st newty_nabla) y
-          env <- dsGetFamInstEnvs
-          rcm <- case splitReprTyConApp_maybe env rep_ty of
-            Just (tc, _, _) -> addTyConMatches tc (vi_rcm vi)
-            Nothing         -> addCompleteMatches (vi_rcm vi)
-
-          -- Test all COMPLETE sets for inhabitants (n inhs at max). Take care of ⊥.
-          clss <- pickApplicableCompleteSets (nabla_ty_st nabla) rep_ty rcm
-          case NE.nonEmpty (uniqDSetToList . cmConLikes <$> clss) of
-            Nothing ->
-              -- No COMPLETE sets ==> inhabited
-              generateInhabitingPatterns mode xs n newty_nabla
-            Just clss -> do
-              -- Try each COMPLETE set, pick the one with the smallest number of
-              -- inhabitants
-              nablass' <- forM clss (instantiate_cons y rep_ty xs n newty_nabla)
-              let nablas' = minimumBy (comparing length) nablass'
-              if null nablas' && vi_bot vi /= IsNotBot
-                then generateInhabitingPatterns mode xs n newty_nabla -- bot is still possible. Display a wildcard!
-                else pure nablas'
-
-    -- Instantiates a chain of newtypes, beginning at @x@.
-    -- Turns @x nabla [T,U,V]@ to @(y, nabla')@, where @nabla'@ we has the fact
-    -- @x ~ T (U (V y))@.
-    instantiate_newtype_chain :: Id -> Nabla -> [(Type, DataCon, Type)] -> MaybeT DsM (Id, Nabla)
-    instantiate_newtype_chain x nabla []                      = pure (x, nabla)
-    instantiate_newtype_chain x nabla ((_ty, dc, arg_ty):dcs) = do
-      y <- lift $ mkPmId arg_ty
-      -- Newtypes don't have existentials (yet?!), so passing an empty
-      -- list as ex_tvs.
-      nabla' <- addConCt nabla x (PmAltConLike (RealDataCon dc)) [] [y]
-      instantiate_newtype_chain y nabla' dcs
-
-    instantiate_cons :: Id -> Type -> [Id] -> Int -> Nabla -> [ConLike] -> DsM [Nabla]
-    instantiate_cons _ _  _  _ _     []       = pure []
-    instantiate_cons _ _  _  0 _     _        = pure []
-    instantiate_cons _ ty xs n nabla _
-      -- We don't want to expose users to GHC-specific constructors for Int etc.
-      | fmap (isTyConTriviallyInhabited . fst) (splitTyConApp_maybe ty) == Just True
-      = generateInhabitingPatterns mode xs n nabla
-    instantiate_cons x ty xs n nabla (cl:cls) = do
-      -- The following line is where we call out to the inhabitationTest!
-      mb_nabla <- runMaybeT $ instCon 4 nabla x cl
-      tracePm "instantiate_cons" (vcat [ ppr x <+> dcolon <+> ppr (idType x)
-                                       , ppr ty
-                                       , ppr cl
-                                       , ppr nabla
-                                       , ppr mb_nabla
-                                       , ppr n ])
-      con_nablas <- case mb_nabla of
-        Nothing     -> pure []
-        -- NB: We don't prepend arg_vars as we don't have any evidence on
-        -- them and we only want to split once on a data type. They are
-        -- inhabited, otherwise the inhabitation test would have refuted.
-        Just nabla' -> generateInhabitingPatterns mode xs n nabla'
-      other_cons_nablas <- instantiate_cons x ty xs (n - length con_nablas) nabla cls
-      pure (con_nablas ++ other_cons_nablas)
-
-pickApplicableCompleteSets :: TyState -> Type -> ResidualCompleteMatches -> DsM [CompleteMatch]
--- See Note [Implementation of COMPLETE pragmas] on what "applicable" means
-pickApplicableCompleteSets ty_st ty rcm = do
-  let cl_res_ty_ok :: ConLike -> DsM Bool
-      cl_res_ty_ok cl = do
-        env <- dsGetFamInstEnvs
-        isJust <$> matchConLikeResTy env ty_st ty cl
-  let cm_applicable :: CompleteMatch -> DsM Bool
-      cm_applicable cm = do
-        cls_ok <- allM cl_res_ty_ok (uniqDSetToList (cmConLikes cm))
-        let match_ty_ok = completeMatchAppliesAtType ty cm
-        pure (cls_ok && match_ty_ok)
-  applicable_cms <- filterM cm_applicable (getRcm rcm)
-  tracePm "pickApplicableCompleteSets:" $
-    vcat
-      [ ppr ty
-      , ppr rcm
-      , ppr applicable_cms
-      ]
-  return applicable_cms
-
-{- Note [Why inhabitationTest doesn't call generateInhabitingPatterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Why can't we define `inhabitationTest` (IT) in terms of
-`generateInhabitingPatterns` (GIP) as
-
-  inhabitationTest nabla = do
-    nablas <- lift $ generateInhabitingPatterns all_variables 1 nabla
-    guard (notNull nablas)
-
-There are a few technical reasons, like the lack of a fuel-tracking approach
-to stay decidable, that could be overcome. But the nail in the coffin is
-performance: In order to provide good warning messages, GIP commits to *one*
-COMPLETE set, and goes through some hoops to find the minimal one. This implies
-it has to look at *all* constructors in the residual COMPLETE matches and see if
-they match, if only to filter out ill-typed COMPLETE sets
-(see Note [Implementation of COMPLETE pragmas]). That is untractable for an
-efficient IT on huge enumerations.
-
-But we still need GIP to produce the Nablas as proxies for
-uncovered patterns that we display warnings for. It's fine to pay this price
-once at the end, but IT is called far more often than that.
-
-Note [Case split inhabiting patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we have an -XEmptyCase,
-```hs
-f :: Maybe a -> ()
-f x = case x of {}
-```
-we want to show the different missing patterns {'Just _', 'Nothing'} to the user
-instead of an uninformative wildcard pattern '_'.
-
-But when we have a match as part of a function definition, such as
-```hs
-g :: (Bool, [a]) -> ()
-g (_, []) = ()
-```
-we established in #20642 that we *do not* want to report P1={'(False, (_:_))',
-'(True, (_:_))'} when we could just give the singleton set P2={'(_, (_:_))'}!
-The latter set M is a "minimal cover" of the space of missing patterns S, in
-that
-
-1. The union of M is *exactly* S
-2. The size of M is minimal under all such candidates.
-
-In terms of 'g', P2 satisfies both (1) and (2). While P1 satisfies (1), it does
-not satisfy (2). The set {'_'} satisfies (2), but it does not satisfy (1) as
-it also covers the pattern '(_,[])' which is not part of the space of missing
-patterns of 'g', so it would be a bad (too conservative) suggestion.
-
-Note that for -XEmptyCase, we don't want to emit a minimal cover. We arrange
-that by passing 'CaseSplitTopLevel' to 'generateInhabitingPatterns'. We detect
-the -XEmptyCase case in 'reportWarnings' by looking for 'ReportEmptyCase'.
--}
diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Pmc/Utils.hs
+++ /dev/null
@@ -1,158 +0,0 @@
-
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
--- | Utility module for the pattern-match coverage checker.
-module GHC.HsToCore.Pmc.Utils (
-
-        tracePm, traceWhenFailPm, mkPmId,
-        allPmCheckWarnings, overlapping, exhaustive, redundantBang,
-        exhaustiveWarningFlag,
-        isMatchContextPmChecked, needToRunPmCheck
-
-    ) where
-
-import GHC.Prelude
-
-import GHC.Types.Basic (Origin(..), isGenerated)
-import GHC.Driver.Session
-import GHC.Hs
-import GHC.Core.Type
-import GHC.Data.FastString
-import GHC.Data.IOEnv
-import GHC.Data.Maybe
-import GHC.Types.Id
-import GHC.Types.Name
-import GHC.Types.Unique.Supply
-import GHC.Types.SrcLoc
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Logger
-import GHC.HsToCore.Monad
-
-import Control.Monad
-
-tracePm :: String -> SDoc -> DsM ()
-tracePm herald doc = do
-  logger  <- getLogger
-  name_ppr_ctx <- mkNamePprCtxDs
-  liftIO $ putDumpFileMaybe' logger name_ppr_ctx
-            Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc))
-{-# INLINE tracePm #-}  -- see Note [INLINE conditional tracing utilities]
-
-traceWhenFailPm :: String -> SDoc -> MaybeT DsM a -> MaybeT DsM a
-traceWhenFailPm herald doc act = MaybeT $ do
-  mb_a <- runMaybeT act
-  when (isNothing mb_a) $ tracePm herald doc
-  pure mb_a
-{-# INLINE traceWhenFailPm #-}  -- see Note [INLINE conditional tracing utilities]
-
--- | Generate a fresh `Id` of a given type
-mkPmId :: Type -> DsM Id
-mkPmId ty = getUniqueM >>= \unique ->
-  let occname = mkVarOccFS $ fsLit "pm"
-      name    = mkInternalName unique occname noSrcSpan
-  in  return (mkLocalIdOrCoVar name ManyTy ty)
-{-# NOINLINE mkPmId #-} -- We'll CPR deeply, that should be enough
-
--- | All warning flags that need to run the pattern match checker.
-allPmCheckWarnings :: [WarningFlag]
-allPmCheckWarnings =
-  [ Opt_WarnIncompletePatterns
-  , Opt_WarnIncompleteUniPatterns
-  , Opt_WarnIncompletePatternsRecUpd
-  , Opt_WarnOverlappingPatterns
-  ]
-
--- | Check whether the redundancy checker should run (redundancy only)
-overlapping :: DynFlags -> HsMatchContext id -> Bool
--- See Note [Inaccessible warnings for record updates]
-overlapping _      RecUpd = False
-overlapping dflags _      = wopt Opt_WarnOverlappingPatterns dflags
-
--- | Check whether the exhaustiveness checker should run (exhaustiveness only)
-exhaustive :: DynFlags -> HsMatchContext id -> Bool
-exhaustive  dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
-
--- | Check whether unnecessary bangs should be warned about
-redundantBang :: DynFlags -> Bool
-redundantBang dflags = wopt Opt_WarnRedundantBangPatterns dflags
-
--- | Denotes whether an exhaustiveness check is supported, and if so,
--- via which 'WarningFlag' it's controlled.
--- Returns 'Nothing' if check is not supported.
-exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
-exhaustiveWarningFlag FunRhs{}           = Just Opt_WarnIncompletePatterns
-exhaustiveWarningFlag CaseAlt            = Just Opt_WarnIncompletePatterns
-exhaustiveWarningFlag LamCaseAlt{}       = Just Opt_WarnIncompletePatterns
-exhaustiveWarningFlag IfAlt              = Just Opt_WarnIncompletePatterns
-exhaustiveWarningFlag LambdaExpr         = Just Opt_WarnIncompleteUniPatterns
-exhaustiveWarningFlag PatBindRhs         = Just Opt_WarnIncompleteUniPatterns
-exhaustiveWarningFlag PatBindGuards      = Just Opt_WarnIncompletePatterns
-exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c
-exhaustiveWarningFlag RecUpd             = Just Opt_WarnIncompletePatternsRecUpd
-exhaustiveWarningFlag ThPatSplice        = Nothing
-exhaustiveWarningFlag PatSyn             = Nothing
-exhaustiveWarningFlag ThPatQuote         = Nothing
--- Don't warn about incomplete patterns in list comprehensions, pattern guards
--- etc. They are often *supposed* to be incomplete
-exhaustiveWarningFlag StmtCtxt{}         = Nothing
-
-arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag
-arrowMatchContextExhaustiveWarningFlag = \ case
-  ProcExpr          -> Just Opt_WarnIncompleteUniPatterns
-  ArrowCaseAlt      -> Just Opt_WarnIncompletePatterns
-  ArrowLamCaseAlt _ -> Just Opt_WarnIncompletePatterns
-  KappaExpr         -> Just Opt_WarnIncompleteUniPatterns
-
--- | Check whether any part of pattern match checking is enabled for this
--- 'HsMatchContext' (does not matter whether it is the redundancy check or the
--- exhaustiveness check).
-isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool
-isMatchContextPmChecked dflags origin kind
-  | isGenerated origin
-  = False
-  | otherwise
-  = overlapping dflags kind || exhaustive dflags kind
-
--- | Return True when any of the pattern match warnings ('allPmCheckWarnings')
--- are enabled, in which case we need to run the pattern match checker.
-needToRunPmCheck :: DynFlags -> Origin -> Bool
-needToRunPmCheck dflags origin
-  | isGenerated origin
-  = False
-  | otherwise
-  = notNull (filter (`wopt` dflags) allPmCheckWarnings)
-
-{- Note [Inaccessible warnings for record updates]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#12957)
-  data T a where
-    T1 :: { x :: Int } -> T Bool
-    T2 :: { x :: Int } -> T a
-    T3 :: T a
-
-  f :: T Char -> T a
-  f r = r { x = 3 }
-
-The desugarer will conservatively generate a case for T1 even though
-it's impossible:
-  f r = case r of
-          T1 x -> T1 3   -- Inaccessible branch
-          T2 x -> T2 3
-          _    -> error "Missing"
-
-We don't want to warn about the inaccessible branch because the programmer
-didn't put it there!  So we filter out the warning here.
-
-The same can happen for long distance term constraints instead of type
-constraints (#17783):
-
-  data T = A { x :: Int } | B { x :: Int }
-  f r@A{} = r { x = 3 }
-  f _     = B 0
-
-Here, the long distance info from the FunRhs match (@r ~ A x@) will make the
-clause matching on @B@ of the desugaring to @case@ redundant. It's generated
-code that we don't want to warn about.
--}
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ /dev/null
@@ -1,3087 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes    #-}
-
-{-# LANGUAGE DataKinds              #-}
-{-# LANGUAGE FlexibleContexts       #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE PatternSynonyms        #-}
-{-# LANGUAGE RankNTypes             #-}
-{-# LANGUAGE ScopedTypeVariables    #-}
-{-# LANGUAGE TypeApplications       #-}
-{-# LANGUAGE TypeFamilies           #-}
-{-# LANGUAGE UndecidableInstances   #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow 2006
---
--- The purpose of this module is to transform an HsExpr into a CoreExpr which
--- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
--- input HsExpr. We do this in the DsM monad, which supplies access to
--- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
---
--- It also defines a bunch of knownKeyNames, in the same way as is done
--- in prelude/GHC.Builtin.Names.  It's much more convenient to do it here, because
--- otherwise we have to recompile GHC.Builtin.Names whenever we add a Name, which is
--- a Royal Pain (triggers other recompilation).
------------------------------------------------------------------------------
-
-module GHC.HsToCore.Quote( dsBracket ) where
-
-import GHC.Prelude
-import GHC.Platform
-
-import GHC.Driver.Session
-
-import GHC.HsToCore.Errors.Types
-import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr )
-import GHC.HsToCore.Match.Literal
-import GHC.HsToCore.Monad
-import GHC.HsToCore.Binds
-
-import qualified Language.Haskell.TH as TH
-import qualified Language.Haskell.TH.Syntax as TH
-
-import GHC.Hs
-
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Types.Evidence
-
-import GHC.Core.Class
-import GHC.Core.DataCon
-import GHC.Core.TyCon
-import GHC.Core
-import GHC.Core.Type( pattern ManyTy, mkFunTy )
-import GHC.Core.Make
-import GHC.Core.Utils
-
-import GHC.Builtin.Names
-import GHC.Builtin.Names.TH
-import GHC.Builtin.Types
-
-import GHC.Unit.Module
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Misc
-import GHC.Utils.Monad
-
-import GHC.Data.Bag
-import GHC.Data.FastString
-import GHC.Data.Maybe
-
-import GHC.Types.SrcLoc as SrcLoc
-import GHC.Types.Unique
-import GHC.Types.Basic
-import GHC.Types.ForeignCall
-import GHC.Types.Var
-import GHC.Types.Id
-import GHC.Types.SourceText
-import GHC.Types.Fixity
-import GHC.Types.TyThing
-import GHC.Types.Name hiding( varName, tcName )
-import GHC.Types.Name.Env
-
-import GHC.TypeLits
-import Data.Kind (Constraint)
-
-import qualified GHC.LanguageExtensions as LangExt
-
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-import Data.ByteString ( unpack )
-import Control.Monad
-import Data.List (sort, sortBy)
-import Data.List.NonEmpty ( NonEmpty(..) )
-import Data.Function
-import Control.Monad.Trans.Reader
-import Control.Monad.Trans.Class
-import Data.Foldable ( toList )
-
-data MetaWrappers = MetaWrappers {
-      -- Applies its argument to a type argument `m` and dictionary `Quote m`
-      quoteWrapper :: CoreExpr -> CoreExpr
-      -- Apply its argument to a type argument `m` and a dictionary `Monad m`
-    , monadWrapper :: CoreExpr -> CoreExpr
-      -- Apply the container typed variable `m` to the argument type `T` to get `m T`.
-    , metaTy :: Type -> Type
-      -- Information about the wrappers which be printed to be inspected
-    , _debugWrappers :: (HsWrapper, HsWrapper, Type)
-    }
-
--- | Construct the functions which will apply the relevant part of the
--- QuoteWrapper to identifiers during desugaring.
-mkMetaWrappers :: QuoteWrapper -> DsM MetaWrappers
-mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do
-      let quote_var = Var quote_var_raw
-      -- Get the superclass selector to select the Monad dictionary, going
-      -- to be used to construct the monadWrapper.
-      quote_tc <- dsLookupTyCon quoteClassName
-      monad_tc <- dsLookupTyCon monadClassName
-      let Just cls = tyConClass_maybe quote_tc
-          Just monad_cls = tyConClass_maybe monad_tc
-          -- Quote m -> Monad m
-          monad_sel = classSCSelId cls 0
-
-          -- Only used for the defensive assertion that the selector has
-          -- the expected type
-          tyvars = dataConUserTyVarBinders (classDataCon cls)
-          expected_ty = mkInvisForAllTys tyvars $
-                        mkFunTy invisArgConstraintLike ManyTy
-                                (mkClassPred cls (mkTyVarTys (binderVars tyvars)))
-                                (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars)))
-
-      massertPpr (idType monad_sel `eqType` expected_ty) (ppr monad_sel $$ ppr expected_ty)
-
-      let m_ty = Type m_var
-          -- Construct the contents of MetaWrappers
-          quoteWrapper = applyQuoteWrapper q
-          monadWrapper = mkWpEvApps [EvExpr $ mkCoreApps (Var monad_sel) [m_ty, quote_var]] <.>
-                            mkWpTyApps [m_var]
-          tyWrapper t = mkAppTy m_var t
-          debug = (quoteWrapper, monadWrapper, m_var)
-      q_f <- dsHsWrapper quoteWrapper
-      m_f <- dsHsWrapper monadWrapper
-      return (MetaWrappers q_f m_f tyWrapper debug)
-
--- Turn A into m A
-wrapName :: Name -> MetaM Type
-wrapName n = do
-  t <- lookupType n
-  wrap_fn <- asks metaTy
-  return (wrap_fn t)
-
--- The local state is always the same, calculated from the passed in
--- wrapper
-type MetaM a = ReaderT MetaWrappers DsM a
-
-getPlatform :: MetaM Platform
-getPlatform = targetPlatform <$> getDynFlags
-
------------------------------------------------------------------------------
-dsBracket :: HsBracketTc -> DsM CoreExpr
--- See Note [Desugaring Brackets]
--- Returns a CoreExpr of type (M TH.Exp)
--- The quoted thing is parameterised over Name, even though it has
--- been type checked.  We don't want all those type decorations!
-
-dsBracket (HsBracketTc { hsb_wrap = mb_wrap, hsb_splices = splices, hsb_quote = quote })
-  = case quote of
-      VarBr _ _ n -> do { MkC e1  <- lookupOccDsM (unLoc n) ; return e1 }
-      ExpBr _ e   -> runOverloaded $ do { MkC e1  <- repLE e     ; return e1 }
-      PatBr _ p   -> runOverloaded $ do { MkC p1  <- repTopP p   ; return p1 }
-      TypBr _ t   -> runOverloaded $ do { MkC t1  <- repLTy t    ; return t1 }
-      DecBrG _ gp -> runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }
-      DecBrL {}   -> panic "dsUntypedBracket: unexpected DecBrL"
-  where
-    Just wrap = mb_wrap  -- Not used in VarBr case
-      -- In the overloaded case we have to get given a wrapper, it is just
-      -- the VarBr case that there is no wrapper, because they
-      -- have a simple type.
-
-    runOverloaded act = do { mw <- mkMetaWrappers wrap
-                           ; runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw }
-
-    new_bit = mkNameEnv [(n, DsSplice (unLoc e))
-                        | PendingTcSplice n e <- splices]
-
-{-
-Note [Desugaring Brackets]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-In the old days (pre Dec 2019) quotation brackets used to be monomorphic, ie
-an expression bracket was of type Q Exp. This made the desugaring process simple
-as there were no complicated type variables to keep consistent throughout the
-whole AST. Due to the overloaded quotations proposal a quotation bracket is now
-of type `Quote m => m Exp` and all the combinators defined in TH.Lib have been
-generalised to work with any monad implementing a minimal interface.
-
-https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst
-
-Users can rejoice at the flexibility but now there is some additional complexity in
-how brackets are desugared as all these polymorphic combinators need their arguments
-instantiated.
-
-> IF YOU ARE MODIFYING THIS MODULE DO NOT USE ANYTHING SPECIFIC TO Q. INSTEAD
-> USE THE `wrapName` FUNCTION TO APPLY THE `m` TYPE VARIABLE TO A TYPE CONSTRUCTOR.
-
-What the arguments should be instantiated to is supplied by the `QuoteWrapper`
-datatype which is produced by `GHC.Tc.Gen.Splice`. It is a pair of an evidence variable
-for `Quote m` and a type variable `m`. All the polymorphic combinators in desugaring
-need to be applied to these two type variables.
-
-There are three important functions which do the application.
-
-1. The default is `rep2` which takes a function name of type `Quote m => T` as an argument.
-2. `rep2M` takes a function name of type `Monad m => T` as an argument
-3. `rep2_nw` takes a function name without any constraints as an argument.
-
-These functions then use the information in QuoteWrapper to apply the correct
-arguments to the functions as the representation is constructed.
-
-The `MetaM` monad carries around an environment of three functions which are
-used in order to wrap the polymorphic combinators and instantiate the arguments
-to the correct things.
-
-1. quoteWrapper wraps functions of type `forall m . Quote m => T`
-2. monadWrapper wraps functions of type `forall m . Monad m => T`
-3. metaTy wraps a type in the polymorphic `m` variable of the whole representation.
-
-Historical note about the implementation: At the first attempt, I attempted to
-lie that the type of any quotation was `Quote m => m Exp` and then specialise it
-by applying a wrapper to pass the `m` and `Quote m` arguments. This approach was
-simpler to implement but didn't work because of nested splices. For example,
-you might have a nested splice of a more specific type which fixes the type of
-the overall quote and so all the combinators used must also be instantiated to
-that specific type. Therefore you really have to use the contents of the quote
-wrapper to directly apply the right type to the combinators rather than
-first generate a polymorphic definition and then just apply the wrapper at the end.
-
--}
-
-{- -------------- Examples --------------------
-
-  [| \x -> x |]
-====>
-  gensym (unpackString "x"#) `bindQ` \ x1::String ->
-  lam (pvar x1) (var x1)
-
-
-  [| \x -> $(f [| x |]) |]
-====>
-  gensym (unpackString "x"#) `bindQ` \ x1::String ->
-  lam (pvar x1) (f (var x1))
--}
-
-
--------------------------------------------------------
---                      Declarations
--------------------------------------------------------
-
--- Proxy for the phantom type of `Core`. All the generated fragments have
--- type something like `Quote m => m Exp` so to keep things simple we represent fragments
--- of that type as `M Exp`.
-data M a
-
-repTopP :: LPat GhcRn -> MetaM (Core (M TH.Pat))
-repTopP pat = do { ss <- mkGenSyms (collectPatBinders CollNoDictBinders pat)
-                 ; pat' <- addBinds ss (repLP pat)
-                 ; wrapGenSyms ss pat' }
-
-repTopDs :: HsGroup GhcRn -> MetaM (Core (M [TH.Dec]))
-repTopDs group@(HsGroup { hs_valds   = valds
-                        , hs_splcds  = splcds
-                        , hs_tyclds  = tyclds
-                        , hs_derivds = derivds
-                        , hs_fixds   = fixds
-                        , hs_defds   = defds
-                        , hs_fords   = fords
-                        , hs_warnds  = warnds
-                        , hs_annds   = annds
-                        , hs_ruleds  = ruleds
-                        , hs_docs    = docs })
- = do { let { bndrs  = hsScopedTvBinders valds
-                       ++ hsGroupBinders group
-                       ++ map foExt (hsPatSynSelectors valds)
-            ; instds = tyclds >>= group_instds } ;
-        ss <- mkGenSyms bndrs ;
-
-        -- Bind all the names mainly to avoid repeated use of explicit strings.
-        -- Thus we get
-        --      do { t :: String <- genSym "T" ;
-        --           return (Data t [] ...more t's... }
-        -- The other important reason is that the output must mention
-        -- only "T", not "Foo:T" where Foo is the current module
-
-        decls <- addBinds ss (
-                  do { val_ds   <- rep_val_binds valds
-                     ; _        <- mapM no_splice splcds
-                     ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)
-                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)
-                     ; kisig_ds <- mapM repKiSigD (concatMap group_kisigs tyclds)
-                     ; inst_ds  <- mapM repInstD instds
-                     ; deriv_ds <- mapM repStandaloneDerivD derivds
-                     ; fix_ds   <- mapM repLFixD fixds
-                     ; def_ds   <- mapM repDefD defds
-                     ; for_ds   <- mapM repForD fords
-                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
-                                                           warnds)
-                     ; ann_ds   <- mapM repAnnD annds
-                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
-                                                            ruleds)
-                     ; _        <- mapM no_doc docs
-
-                        -- more needed
-                     ;  return (de_loc $ sort_by_loc $
-                                val_ds ++ catMaybes tycl_ds ++ role_ds
-                                       ++ kisig_ds
-                                       ++ (concat fix_ds)
-                                       ++ def_ds
-                                       ++ inst_ds ++ rule_ds ++ for_ds
-                                       ++ ann_ds ++ deriv_ds) }) ;
-
-        core_list <- repListM decTyConName return decls ;
-
-        dec_ty <- lookupType decTyConName ;
-        q_decs  <- repSequenceM dec_ty core_list ;
-
-        wrapGenSyms ss q_decs
-      }
-  where
-    no_splice (L loc _)
-      = notHandledL (locA loc) ThSplicesWithinDeclBrackets
-    no_warn :: LWarnDecl GhcRn -> MetaM a
-    no_warn (L loc (Warning _ thing _))
-      = notHandledL (locA loc) (ThWarningAndDeprecationPragmas thing)
-    no_doc (L loc _)
-      = notHandledL (locA loc) ThHaddockDocumentation
-
-hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
--- See Note [Scoped type variables in quotes]
-hsScopedTvBinders binds
-  = concatMap get_scoped_tvs sigs
-  where
-    sigs = case binds of
-             ValBinds           _ _ sigs  -> sigs
-             XValBindsLR (NValBinds _ sigs) -> sigs
-
-get_scoped_tvs :: LSig GhcRn -> [Name]
-get_scoped_tvs (L _ signature)
-  | TypeSig _ _ sig <- signature
-  = get_scoped_tvs_from_sig (hswc_body sig)
-  | ClassOpSig _ _ _ sig <- signature
-  = get_scoped_tvs_from_sig sig
-  | PatSynSig _ _ sig <- signature
-  = get_scoped_tvs_from_sig sig
-  | otherwise
-  = []
-
-get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name]
-  -- Collect both implicit and explicit quantified variables, since
-  -- the types in instance heads, as well as `via` types in DerivingVia, can
-  -- bring implicitly quantified type variables into scope, e.g.,
-  --
-  --   instance Foo [a] where
-  --     m = n @a
-  --
-  -- See also Note [Scoped type variables in quotes]
-get_scoped_tvs_from_sig (L _ (HsSig{sig_bndrs = outer_bndrs})) =
-  hsOuterTyVarNames outer_bndrs
-
-{- Notes
-
-Note [Scoped type variables in quotes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Quoting declarations with scoped type variables requires some care. Consider:
-
-  $([d| f :: forall a. a -> a
-        f x = x::a
-      |])
-
-Here, the `forall a` brings `a` into scope over the binding group. This has
-ramifications when desugaring the quote, as we must ensure that that the
-desugared code binds `a` with `Language.Haskell.TH.newName` and refers to the
-bound `a` type variable in the type signature and in the body of `f`. As a
-result, the call to `newName` must occur before any part of the declaration for
-`f` is processed. To achieve this, we:
-
- (a) Gensym a binding for `a` at the same time as we do one for `f`,
-     collecting the relevant binders with the hsScopedTvBinders family of
-     functions.
-
- (b) Use `addBinds` to bring these gensymmed bindings into scope over any
-     part of the code where the type variables scope. In the `f` example,
-     above, that means the type signature and the body of `f`.
-
- (c) When processing the `forall`, /don't/ gensym the type variables. We have
-     already brought the type variables into scope in part (b), after all, so
-     gensymming them again would lead to shadowing. We use the rep_ty_sig
-     family of functions for processing types without gensymming the type
-     variables again.
-
- (d) Finally, we use wrapGenSyms to generate the Core for these scoped type
-     variables:
-
-       newName "a" >>= \a ->
-         ... -- process the type signature and body of `f`
-
-The relevant places are signposted with references to this Note.
-
-Note [Binders and occurrences]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we desugar [d| data T = MkT |]
-we want to get
-        Data "T" [] [Con "MkT" []] []
-and *not*
-        Data "Foo:T" [] [Con "Foo:MkT" []] []
-That is, the new data decl should fit into whatever new module it is
-asked to fit in.   We do *not* clone, though; no need for this:
-        Data "T79" ....
-
-But if we see this:
-        data T = MkT
-        foo = reifyDecl T
-
-then we must desugar to
-        foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
-
-So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
-And we use lookupOcc, rather than lookupBinder
-in repTyClD and repC.
-
-Note [Don't quantify implicit type variables in quotes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If you're not careful, it's surprisingly easy to take this quoted declaration:
-
-  [d| id :: a -> a
-      id x = x
-    |]
-
-and have Template Haskell turn it into this:
-
-  id :: forall a. a -> a
-  id x = x
-
-Notice that we explicitly quantified the variable `a`! The latter declaration
-isn't what the user wrote in the first place.
-
-Usually, the culprit behind these bugs is taking implicitly quantified type
-variables (often from the hsib_vars field of HsImplicitBinders) and putting
-them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
--}
-
--- represent associated family instances
---
-repTyClD :: LTyClDecl GhcRn -> MetaM (Maybe (SrcSpan, Core (M TH.Dec)))
-
-repTyClD (L loc (FamDecl { tcdFam = fam })) = liftM Just $
-                                              repFamilyDecl (L loc fam)
-
-repTyClD (L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
-  = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]
-       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
-                repSynDecl tc1 bndrs rhs
-       ; return (Just (locA loc, dec)) }
-
-repTyClD (L loc (DataDecl { tcdLName = tc
-                          , tcdTyVars = tvs
-                          , tcdDataDefn = defn }))
-  = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]
-       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
-                repDataDefn tc1 (Left bndrs) defn
-       ; return (Just (locA loc, dec)) }
-
-repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
-                             tcdTyVars = tvs, tcdFDs = fds,
-                             tcdSigs = sigs, tcdMeths = meth_binds,
-                             tcdATs = ats, tcdATDefs = atds }))
-  = do { cls1 <- lookupLOcc cls         -- See Note [Binders and occurrences]
-       ; dec  <- addQTyVarBinds tvs $ \bndrs ->
-           do { cxt1   <- repLContext cxt
-          -- See Note [Scoped type variables in quotes]
-              ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs meth_binds
-              ; fds1   <- repLFunDeps fds
-              ; ats1   <- repFamilyDecls ats
-              ; atds1  <- mapM (repAssocTyFamDefaultD . unLoc) atds
-              ; decls1 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds)
-              ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1
-              ; wrapGenSyms ss decls2 }
-       ; return $ Just (locA loc, dec)
-       }
-
--------------------------
-repRoleD :: LRoleAnnotDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repRoleD (L loc (RoleAnnotDecl _ tycon roles))
-  = do { tycon1 <- lookupLOcc tycon
-       ; roles1 <- mapM repRole roles
-       ; roles2 <- coreList roleTyConName roles1
-       ; dec <- repRoleAnnotD tycon1 roles2
-       ; return (locA loc, dec) }
-
--------------------------
-repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repKiSigD (L loc kisig) =
-  case kisig of
-    StandaloneKindSig _ v ki -> do
-      MkC th_v  <- lookupLOcc v
-      MkC th_ki <- repHsSigType ki
-      dec       <- rep2 kiSigDName [th_v, th_ki]
-      pure (locA loc, dec)
-
--------------------------
-repDataDefn :: Core TH.Name
-            -> Either (Core [(M (TH.TyVarBndr ()))])
-                        -- the repTyClD case
-                      (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type))
-                        -- the repDataFamInstD case
-            -> HsDataDefn GhcRn
-            -> MetaM (Core (M TH.Dec))
-repDataDefn tc opts
-          (HsDataDefn { dd_ctxt = cxt, dd_kindSig = ksig
-                      , dd_cons = cons, dd_derivs = mb_derivs })
-  = do { cxt1     <- repLContext cxt
-       ; derivs1  <- repDerivs mb_derivs
-       ; case cons of
-           NewTypeCon con  -> do { con'  <- repC con
-                                   ; ksig' <- repMaybeLTy ksig
-                                   ; repNewtype cxt1 tc opts ksig' con'
-                                                derivs1 }
-           DataTypeCons _ cons -> do { ksig' <- repMaybeLTy ksig
-                               ; consL <- mapM repC cons
-                               ; cons1 <- coreListM conTyConName consL
-                               ; repData cxt1 tc opts ksig' cons1
-                                         derivs1 }
-       }
-
-repSynDecl :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))]
-           -> LHsType GhcRn
-           -> MetaM (Core (M TH.Dec))
-repSynDecl tc bndrs ty
-  = do { ty1 <- repLTy ty
-       ; repTySyn tc bndrs ty1 }
-
-repFamilyDecl :: LFamilyDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repFamilyDecl decl@(L loc (FamilyDecl { fdInfo      = info
-                                      , fdLName     = tc
-                                      , fdTyVars    = tvs
-                                      , fdResultSig = L _ resultSig
-                                      , fdInjectivityAnn = injectivity }))
-  = do { tc1 <- lookupLOcc tc           -- See Note [Binders and occurrences]
-       ; let mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn
-             mkHsQTvs tvs = HsQTvs { hsq_ext = []
-                                   , hsq_explicit = tvs }
-             resTyVar = case resultSig of
-                     TyVarSig _ bndr -> mkHsQTvs [bndr]
-                     _               -> mkHsQTvs []
-       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
-                addTyClTyVarBinds resTyVar $ \_ ->
-           case info of
-             ClosedTypeFamily Nothing ->
-                 notHandled (ThAbstractClosedTypeFamily decl)
-             ClosedTypeFamily (Just eqns) ->
-               do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns
-                  ; eqns2  <- coreListM tySynEqnTyConName eqns1
-                  ; result <- repFamilyResultSig resultSig
-                  ; inj    <- repInjectivityAnn injectivity
-                  ; repClosedFamilyD tc1 bndrs result inj eqns2 }
-             OpenTypeFamily ->
-               do { result <- repFamilyResultSig resultSig
-                  ; inj    <- repInjectivityAnn injectivity
-                  ; repOpenFamilyD tc1 bndrs result inj }
-             DataFamily ->
-               do { kind <- repFamilyResultSigToMaybeKind resultSig
-                  ; repDataFamilyD tc1 bndrs kind }
-       ; return (locA loc, dec)
-       }
-
--- | Represent result signature of a type family
-repFamilyResultSig :: FamilyResultSig GhcRn -> MetaM (Core (M TH.FamilyResultSig))
-repFamilyResultSig (NoSig _)         = repNoSig
-repFamilyResultSig (KindSig _ ki)    = do { ki' <- repLTy ki
-                                          ; repKindSig ki' }
-repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr
-                                          ; repTyVarSig bndr' }
-
--- | Represent result signature using a Maybe Kind. Used with data families,
--- where the result signature can be either missing or a kind but never a named
--- result variable.
-repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
-                              -> MetaM (Core (Maybe (M TH.Kind)))
-repFamilyResultSigToMaybeKind (NoSig _) =
-    coreNothingM kindTyConName
-repFamilyResultSigToMaybeKind (KindSig _ ki) =
-    coreJustM kindTyConName =<< repLTy ki
-repFamilyResultSigToMaybeKind TyVarSig{} =
-    panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig"
-
--- | Represent injectivity annotation of a type family
-repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
-                  -> MetaM (Core (Maybe TH.InjectivityAnn))
-repInjectivityAnn Nothing =
-    coreNothing injAnnTyConName
-repInjectivityAnn (Just (L _ (InjectivityAnn _ lhs rhs))) =
-    do { lhs'   <- lookupBinder (unLoc lhs)
-       ; rhs1   <- mapM (lookupBinder . unLoc) rhs
-       ; rhs2   <- coreList nameTyConName rhs1
-       ; injAnn <- rep2_nw injectivityAnnName [unC lhs', unC rhs2]
-       ; coreJust injAnnTyConName injAnn }
-
-repFamilyDecls :: [LFamilyDecl GhcRn] -> MetaM [Core (M TH.Dec)]
-repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
-
-repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> MetaM (Core (M TH.Dec))
-repAssocTyFamDefaultD = repTyFamInstD
-
--------------------------
--- represent fundeps
---
-repLFunDeps :: [LHsFunDep GhcRn] -> MetaM (Core [TH.FunDep])
-repLFunDeps fds = repList funDepTyConName repLFunDep fds
-
-repLFunDep :: LHsFunDep GhcRn -> MetaM (Core TH.FunDep)
-repLFunDep (L _ (FunDep _ xs ys))
-   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
-        ys' <- repList nameTyConName (lookupBinder . unLoc) ys
-        repFunDep xs' ys'
-
--- Represent instance declarations
---
-repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))
-  = do { dec <- repTyFamInstD fi_decl
-       ; return (locA loc, dec) }
-repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))
-  = do { dec <- repDataFamInstD fi_decl
-       ; return (locA loc, dec) }
-repInstD (L loc (ClsInstD { cid_inst = cls_decl }))
-  = do { dec <- repClsInstD cls_decl
-       ; return (locA loc, dec) }
-
-repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec))
-repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
-                         , cid_sigs = sigs, cid_tyfam_insts = ats
-                         , cid_datafam_insts = adts
-                         , cid_overlap_mode = overlap
-                         })
-  = addSimpleTyVarBinds tvs $
-            -- We must bring the type variables into scope, so their
-            -- occurrences don't fail, even though the binders don't
-            -- appear in the resulting data structure
-            --
-            -- But we do NOT bring the binders of 'binds' into scope
-            -- because they are properly regarded as occurrences
-            -- For example, the method names should be bound to
-            -- the selector Ids, not to fresh names (#5410)
-            --
-            do { cxt1     <- repLContext cxt
-               ; inst_ty1 <- repLTy inst_ty
-          -- See Note [Scoped type variables in quotes]
-               ; (ss, sigs_binds) <- rep_meth_sigs_binds sigs binds
-               ; ats1   <- mapM (repTyFamInstD . unLoc) ats
-               ; adts1  <- mapM (repDataFamInstD . unLoc) adts
-               ; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds)
-               ; rOver  <- repOverlap (fmap unLoc overlap)
-               ; decls2 <- repInst rOver cxt1 inst_ty1 decls1
-               ; wrapGenSyms ss decls2 }
- where
-   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
-
-repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
-                                       , deriv_type     = ty }))
-  = do { dec <- repDerivStrategy strat  $ \strat' ->
-                addSimpleTyVarBinds tvs $
-                do { cxt'     <- repLContext cxt
-                   ; inst_ty' <- repLTy inst_ty
-                   ; repDeriv strat' cxt' inst_ty' }
-       ; return (locA loc, dec) }
-  where
-    (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
-
-repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
-repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
-  = do { eqn1 <- repTyFamEqn eqn
-       ; repTySynInst eqn1 }
-
-repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn))
-repTyFamEqn (FamEqn { feqn_tycon = tc_name
-                    , feqn_bndrs = outer_bndrs
-                    , feqn_pats = tys
-                    , feqn_fixity = fixity
-                    , feqn_rhs  = rhs })
-  = do { tc <- lookupLOcc tc_name     -- See Note [Binders and occurrences]
-       ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->
-         do { tys1 <- case fixity of
-                        Prefix -> repTyArgs (repNamedTyCon tc) tys
-                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
-                                     ; t1' <- repLTy t1
-                                     ; t2'  <- repLTy t2
-                                     ; repTyArgs (repTInfix t1' tc t2') args }
-            ; rhs1 <- repLTy rhs
-            ; repTySynEqn mb_exp_bndrs tys1 rhs1 } }
-     where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
-           checkTys tys@(HsValArg _:HsValArg _:_) = return tys
-           checkTys _ = panic "repTyFamEqn:checkTys"
-
-repTyArgs :: MetaM (Core (M TH.Type)) -> [LHsTypeArg GhcRn] -> MetaM (Core (M TH.Type))
-repTyArgs f [] = f
-repTyArgs f (HsValArg ty : as) = do { f' <- f
-                                    ; ty' <- repLTy ty
-                                    ; repTyArgs (repTapp f' ty') as }
-repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f
-                                       ; ki' <- repLTy ki
-                                       ; repTyArgs (repTappKind f' ki') as }
-repTyArgs f (HsArgPar _ : as) = repTyArgs f as
-
-repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
-repDataFamInstD (DataFamInstDecl { dfid_eqn =
-                                      FamEqn { feqn_tycon = tc_name
-                                             , feqn_bndrs = outer_bndrs
-                                             , feqn_pats  = tys
-                                             , feqn_fixity = fixity
-                                             , feqn_rhs   = defn }})
-  = do { tc <- lookupLOcc tc_name         -- See Note [Binders and occurrences]
-       ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->
-         do { tys1 <- case fixity of
-                        Prefix -> repTyArgs (repNamedTyCon tc) tys
-                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
-                                     ; t1' <- repLTy t1
-                                     ; t2'  <- repLTy t2
-                                     ; repTyArgs (repTInfix t1' tc t2') args }
-            ; repDataDefn tc (Right (mb_exp_bndrs, tys1)) defn } }
-
-      where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]
-            checkTys tys@(HsValArg _: HsValArg _: _) = return tys
-            checkTys _ = panic "repDataFamInstD:checkTys"
-
-repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
-                                  , fd_fi = CImport _ (L _ cc)
-                                                    (L _ s) mch cis }))
- = do MkC name' <- lookupLOcc name
-      MkC typ' <- repHsSigType typ
-      MkC cc' <- repCCallConv cc
-      MkC s' <- repSafety s
-      cis' <- conv_cimportspec cis
-      MkC str <- coreStringLit (mkFastString (static ++ chStr ++ cis'))
-      dec <- rep2 forImpDName [cc', s', str, name', typ']
-      return (locA loc, dec)
- where
-    conv_cimportspec (CLabel cls)
-      = notHandled (ThForeignLabel cls)
-    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
-    conv_cimportspec (CFunction (StaticTarget _ fs _ True))
-                            = return (unpackFS fs)
-    conv_cimportspec (CFunction (StaticTarget _ _  _ False))
-                            = panic "conv_cimportspec: values not supported yet"
-    conv_cimportspec CWrapper = return "wrapper"
-    -- these calling conventions do not support headers and the static keyword
-    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
-    static = case cis of
-                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
-                 _ -> ""
-    chStr = case mch of
-            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
-            _ -> ""
-repForD decl@(L _ ForeignExport{}) = notHandled (ThForeignExport decl)
-
-repCCallConv :: CCallConv -> MetaM (Core TH.Callconv)
-repCCallConv CCallConv          = rep2_nw cCallName []
-repCCallConv StdCallConv        = rep2_nw stdCallName []
-repCCallConv CApiConv           = rep2_nw cApiCallName []
-repCCallConv PrimCallConv       = rep2_nw primCallName []
-repCCallConv JavaScriptCallConv = rep2_nw javaScriptCallName []
-
-repSafety :: Safety -> MetaM (Core TH.Safety)
-repSafety PlayRisky = rep2_nw unsafeName []
-repSafety PlayInterruptible = rep2_nw interruptibleName []
-repSafety PlaySafe = rep2_nw safeName []
-
-repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-repLFixD (L loc fix_sig) = rep_fix_d (locA loc) fix_sig
-
-rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_fix_d loc (FixitySig _ names (Fixity _ prec dir))
-  = do { MkC prec' <- coreIntLit prec
-       ; let rep_fn = case dir of
-                        InfixL -> infixLDName
-                        InfixR -> infixRDName
-                        InfixN -> infixNDName
-       ; let do_one name
-              = do { MkC name' <- lookupLOcc name
-                   ; dec <- rep2 rep_fn [prec', name']
-                   ; return (loc,dec) }
-       ; mapM do_one names }
-
-repDefD :: LDefaultDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repDefD (L loc (DefaultDecl _ tys)) = do { tys1 <- repLTys tys
-                                         ; MkC tys2 <- coreListM typeTyConName tys1
-                                         ; dec <- rep2 defaultDName [tys2]
-                                         ; return (locA loc, dec)}
-
-repRuleD :: LRuleDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repRuleD (L loc (HsRule { rd_name = n
-                        , rd_act = act
-                        , rd_tyvs = ty_bndrs
-                        , rd_tmvs = tm_bndrs
-                        , rd_lhs = lhs
-                        , rd_rhs = rhs }))
-  = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
-         do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
-            ; ss <- mkGenSyms tm_bndr_names
-            ; rule <- addBinds ss $
-                      do { elt_ty <- wrapName tyVarBndrUnitTyConName
-                         ; ty_bndrs' <- return $ case ty_bndrs of
-                             Nothing -> coreNothing' (mkListTy elt_ty)
-                             Just _  -> coreJust' (mkListTy elt_ty) ex_bndrs
-                         ; tm_bndrs' <- repListM ruleBndrTyConName
-                                                repRuleBndr
-                                                tm_bndrs
-                         ; n'   <- coreStringLit $ unLoc n
-                         ; act' <- repPhases act
-                         ; lhs' <- repLE lhs
-                         ; rhs' <- repLE rhs
-                         ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
-           ; wrapGenSyms ss rule  }
-       ; return (locA loc, rule) }
-
-ruleBndrNames :: LRuleBndr GhcRn -> [Name]
-ruleBndrNames (L _ (RuleBndr _ n))      = [unLoc n]
-ruleBndrNames (L _ (RuleBndrSig _ n sig))
-  | HsPS { hsps_ext = HsPSRn { hsps_imp_tvs = vars }} <- sig
-  = unLoc n : vars
-
-repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr))
-repRuleBndr (L _ (RuleBndr _ n))
-  = do { MkC n' <- lookupNBinder n
-       ; rep2 ruleVarName [n'] }
-repRuleBndr (L _ (RuleBndrSig _ n sig))
-  = do { MkC n'  <- lookupNBinder n
-       ; MkC ty' <- repLTy (hsPatSigType sig)
-       ; rep2 typedRuleVarName [n', ty'] }
-
-repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp)))
-  = do { target <- repAnnProv ann_prov
-       ; exp'   <- repE exp
-       ; dec    <- repPragAnn target exp'
-       ; return (locA loc, dec) }
-
-repAnnProv :: AnnProvenance GhcRn -> MetaM (Core TH.AnnTarget)
-repAnnProv (ValueAnnProvenance n)
-  = do { -- An ANN references an identifier bound elsewhere in the module, so
-         -- we must look it up using lookupLOcc (#19377).
-         -- Similarly for TypeAnnProvenance (`ANN type`) below.
-         MkC n' <- lookupLOcc n
-       ; rep2_nw valueAnnotationName [ n' ] }
-repAnnProv (TypeAnnProvenance n)
-  = do { MkC n' <- lookupLOcc n
-       ; rep2_nw typeAnnotationName [ n' ] }
-repAnnProv ModuleAnnProvenance
-  = rep2_nw moduleAnnotationName []
-
--------------------------------------------------------
---                      Constructors
--------------------------------------------------------
-
-repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con))
-repC (L _ (ConDeclH98 { con_name   = con
-                      , con_forall = False
-                      , con_mb_cxt = Nothing
-                      , con_args   = args }))
-  = repH98DataCon con args
-
-repC (L _ (ConDeclH98 { con_name = con
-                      , con_forall = is_existential
-                      , con_ex_tvs = con_tvs
-                      , con_mb_cxt = mcxt
-                      , con_args = args }))
-  = addHsTyVarBinds con_tvs $ \ ex_bndrs ->
-         do { c'    <- repH98DataCon con args
-            ; ctxt' <- repMbContext mcxt
-            ; if not is_existential && isNothing mcxt
-              then return c'
-              else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
-            }
-
-repC (L _ (ConDeclGADT { con_names  = cons
-                       , con_bndrs  = L _ outer_bndrs
-                       , con_mb_cxt = mcxt
-                       , con_g_args = args
-                       , con_res_ty = res_ty }))
-  | null_outer_imp_tvs && null_outer_exp_tvs
-                                 -- No implicit or explicit variables
-  , Nothing <- mcxt              -- No context
-                                 -- ==> no need for a forall
-  = repGadtDataCons cons args res_ty
-
-  | otherwise
-  = addHsOuterSigTyVarBinds outer_bndrs $ \ outer_bndrs' ->
-             -- See Note [Don't quantify implicit type variables in quotes]
-    do { c'    <- repGadtDataCons cons args res_ty
-       ; ctxt' <- repMbContext mcxt
-       ; if null_outer_exp_tvs && isNothing mcxt
-         then return c'
-         else rep2 forallCName ([unC outer_bndrs', unC ctxt', unC c']) }
-  where
-    null_outer_imp_tvs = nullOuterImplicit outer_bndrs
-    null_outer_exp_tvs = nullOuterExplicit outer_bndrs
-
-repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt))
-repMbContext Nothing          = repContext []
-repMbContext (Just (L _ cxt)) = repContext cxt
-
-repSrcUnpackedness :: SrcUnpackedness -> MetaM (Core (M TH.SourceUnpackedness))
-repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []
-repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName       []
-repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []
-
-repSrcStrictness :: SrcStrictness -> MetaM (Core (M TH.SourceStrictness))
-repSrcStrictness SrcLazy     = rep2 sourceLazyName         []
-repSrcStrictness SrcStrict   = rep2 sourceStrictName       []
-repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []
-
-repBangTy :: LBangType GhcRn -> MetaM (Core (M TH.BangType))
-repBangTy ty = do
-  MkC u <- repSrcUnpackedness su'
-  MkC s <- repSrcStrictness ss'
-  MkC b <- rep2 bangName [u, s]
-  MkC t <- repLTy ty'
-  rep2 bangTypeName [b, t]
-  where
-    (su', ss', ty') = case unLoc ty of
-            HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty)
-            _ -> (NoSrcUnpack, NoSrcStrict, ty)
-
--------------------------------------------------------
---                      Deriving clauses
--------------------------------------------------------
-
-repDerivs :: HsDeriving GhcRn -> MetaM (Core [M TH.DerivClause])
-repDerivs clauses
-  = repListM derivClauseTyConName repDerivClause clauses
-
-repDerivClause :: LHsDerivingClause GhcRn
-               -> MetaM (Core (M TH.DerivClause))
-repDerivClause (L _ (HsDerivingClause
-                          { deriv_clause_strategy = dcs
-                          , deriv_clause_tys      = dct }))
-  = repDerivStrategy dcs $ \(MkC dcs') ->
-    do MkC dct' <- rep_deriv_clause_tys dct
-       rep2 derivClauseName [dcs',dct']
-  where
-    rep_deriv_clause_tys :: LDerivClauseTys GhcRn -> MetaM (Core [M TH.Type])
-    rep_deriv_clause_tys (L _ dct) = case dct of
-      DctSingle _ ty -> rep_deriv_tys [ty]
-      DctMulti _ tys -> rep_deriv_tys tys
-
-    rep_deriv_tys :: [LHsSigType GhcRn] -> MetaM (Core [M TH.Type])
-    rep_deriv_tys = repListM typeTyConName repHsSigType
-
-rep_meth_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
-                    -> MetaM ([GenSymBind], [Core (M TH.Dec)])
--- Represent signatures and methods in class/instance declarations.
--- See Note [Scoped type variables in quotes]
---
--- Why not use 'repBinds': we have already created symbols for methods in
--- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate
--- these fun_id via 'collectHsValBinders decs', which would lead to the
--- instance declarations failing in TH.
-rep_meth_sigs_binds sigs binds
-  = do { let tvs = concatMap get_scoped_tvs sigs
-       ; ss <- mkGenSyms tvs
-       ; sigs1 <- addBinds ss $ rep_sigs sigs
-       ; binds1 <- addBinds ss $ rep_binds binds
-       ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) }
-
--------------------------------------------------------
---   Signatures in a class decl, or a group of bindings
--------------------------------------------------------
-
-rep_sigs :: [LSig GhcRn] -> MetaM [(SrcSpan, Core (M TH.Dec))]
-        -- We silently ignore ones we don't recognise
-rep_sigs = concatMapM rep_sig
-
-rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_sig (L loc (TypeSig _ nms ty))
-  = mapM (rep_wc_ty_sig sigDName (locA loc) ty) nms
-rep_sig (L loc (PatSynSig _ nms ty))
-  = mapM (rep_patsyn_ty_sig (locA loc) ty) nms
-rep_sig (L loc (ClassOpSig _ is_deflt nms ty))
-  | is_deflt     = mapM (rep_ty_sig defaultSigDName (locA loc) ty) nms
-  | otherwise    = mapM (rep_ty_sig sigDName (locA loc) ty) nms
-rep_sig (L loc (FixSig _ fix_sig))   = rep_fix_d (locA loc) fix_sig
-rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc)
-rep_sig (L loc (SpecSig _ nm tys ispec))
-  = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys
-rep_sig (L loc (SpecInstSig _ ty))  = rep_specialiseInst ty (locA loc)
-rep_sig (L _   (MinimalSig {}))       = notHandled ThMinimalPragmas
-rep_sig (L _   (SCCFunSig {}))        = notHandled ThSCCPragmas
-rep_sig (L loc (CompleteMatchSig _ cls mty))
-  = rep_complete_sig cls mty (locA loc)
-rep_sig d@(L _ (XSig {}))             = pprPanic "rep_sig IdSig" (ppr d)
-
--- Desugar the explicit type variable binders in an 'LHsSigType', making
--- sure not to gensym them.
--- See Note [Scoped type variables in quotes]
--- and Note [Don't quantify implicit type variables in quotes]
-rep_ty_sig_tvs :: [LHsTyVarBndr Specificity GhcRn]
-               -> MetaM (Core [M TH.TyVarBndrSpec])
-rep_ty_sig_tvs explicit_tvs
-  = repListM tyVarBndrSpecTyConName repTyVarBndr
-             explicit_tvs
-
--- Desugar the outer type variable binders in an 'LHsSigType', making
--- sure not to gensym them.
--- See Note [Scoped type variables in quotes]
--- and Note [Don't quantify implicit type variables in quotes]
-rep_ty_sig_outer_tvs :: HsOuterSigTyVarBndrs GhcRn
-                     -> MetaM (Core [M TH.TyVarBndrSpec])
-rep_ty_sig_outer_tvs (HsOuterImplicit{}) =
-  coreListM tyVarBndrSpecTyConName []
-rep_ty_sig_outer_tvs (HsOuterExplicit{hso_bndrs = explicit_tvs}) =
-  rep_ty_sig_tvs explicit_tvs
-
--- Desugar a top-level type signature. Unlike 'repHsSigType', this
--- deliberately avoids gensymming the type variables.
--- See Note [Scoped type variables in quotes]
--- and Note [Don't quantify implicit type variables in quotes]
-rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> LocatedN Name
-           -> MetaM (SrcSpan, Core (M TH.Dec))
-rep_ty_sig mk_sig loc sig_ty nm
-  = do { nm1 <- lookupLOcc nm
-       ; ty1 <- rep_ty_sig' sig_ty
-       ; sig <- repProto mk_sig nm1 ty1
-       ; return (loc, sig) }
-
--- Desugar an 'LHsSigType', making sure not to gensym the type variables at
--- the front of the type signature.
--- See Note [Scoped type variables in quotes]
--- and Note [Don't quantify implicit type variables in quotes]
-rep_ty_sig' :: LHsSigType GhcRn
-            -> MetaM (Core (M TH.Type))
-rep_ty_sig' (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body}))
-  | (ctxt, tau) <- splitLHsQualTy body
-  = do { th_explicit_tvs <- rep_ty_sig_outer_tvs outer_bndrs
-       ; th_ctxt <- repLContext ctxt
-       ; th_tau  <- repLTy tau
-       ; if nullOuterExplicit outer_bndrs && null (fromMaybeContext ctxt)
-            then return th_tau
-            else repTForall th_explicit_tvs th_ctxt th_tau }
-
-rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> LocatedN Name
-                  -> MetaM (SrcSpan, Core (M TH.Dec))
--- represents a pattern synonym type signature;
--- see Note [Pattern synonym type signatures and Template Haskell] in "GHC.ThToHs"
---
--- Don't create the implicit and explicit variables when desugaring signatures,
--- see Note [Scoped type variables in quotes]
--- and Note [Don't quantify implicit type variables in quotes]
-rep_patsyn_ty_sig loc sig_ty nm
-  | (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy sig_ty
-  = do { nm1 <- lookupLOcc nm
-       ; th_univs <- rep_ty_sig_tvs univs
-       ; th_exis  <- rep_ty_sig_tvs exis
-
-       ; th_reqs  <- repLContext reqs
-       ; th_provs <- repLContext provs
-       ; th_ty    <- repLTy ty
-       ; ty1      <- repTForall th_univs th_reqs =<<
-                       repTForall th_exis th_provs th_ty
-       ; sig      <- repProto patSynSigDName nm1 ty1
-       ; return (loc, sig) }
-
-rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> LocatedN Name
-              -> MetaM (SrcSpan, Core (M TH.Dec))
-rep_wc_ty_sig mk_sig loc sig_ty nm
-  = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm
-
-rep_inline :: LocatedN Name
-           -> InlinePragma      -- Never defaultInlinePragma
-           -> SrcSpan
-           -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_inline nm ispec loc
-  | Opaque {} <- inl_inline ispec
-  = do { nm1    <- lookupLOcc nm
-       ; opq <- repPragOpaque nm1
-       ; return [(loc, opq)]
-       }
-
-rep_inline nm ispec loc
-  = do { nm1    <- lookupLOcc nm
-       ; inline <- repInline $ inl_inline ispec
-       ; rm     <- repRuleMatch $ inl_rule ispec
-       ; phases <- repPhases $ inl_act ispec
-       ; pragma <- repPragInl nm1 inline rm phases
-       ; return [(loc, pragma)]
-       }
-
-rep_specialise :: LocatedN Name -> LHsSigType GhcRn -> InlinePragma
-               -> SrcSpan
-               -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_specialise nm ty ispec loc
-  = do { nm1 <- lookupLOcc nm
-       ; ty1 <- repHsSigType ty
-       ; phases <- repPhases $ inl_act ispec
-       ; let inline = inl_inline ispec
-       ; pragma <- if noUserInlineSpec inline
-                   then -- SPECIALISE
-                     repPragSpec nm1 ty1 phases
-                   else -- SPECIALISE INLINE
-                     do { inline1 <- repInline inline
-                        ; repPragSpecInl nm1 ty1 inline1 phases }
-       ; return [(loc, pragma)]
-       }
-
-rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
-                   -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_specialiseInst ty loc
-  = do { ty1    <- repHsSigType ty
-       ; pragma <- repPragSpecInst ty1
-       ; return [(loc, pragma)] }
-
-repInline :: InlineSpec -> MetaM (Core TH.Inline)
-repInline (NoInline          _ )   = dataCon noInlineDataConName
--- There is a mismatch between the TH and GHC representation because
--- OPAQUE pragmas can't have phase activation annotations (which is
--- enforced by the TH API), therefore they are desugared to OpaqueP rather than
--- InlineP, see special case in rep_inline.
-repInline (Opaque            _ )   = panic "repInline: Opaque"
-repInline (Inline            _ )   = dataCon inlineDataConName
-repInline (Inlinable         _ )   = dataCon inlinableDataConName
-repInline NoUserInlinePrag        = notHandled ThNoUserInline
-
-repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch)
-repRuleMatch ConLike = dataCon conLikeDataConName
-repRuleMatch FunLike = dataCon funLikeDataConName
-
-repPhases :: Activation -> MetaM (Core TH.Phases)
-repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i
-                                  ; dataCon' beforePhaseDataConName [arg] }
-repPhases (ActiveAfter _ i)  = do { MkC arg <- coreIntLit i
-                                  ; dataCon' fromPhaseDataConName [arg] }
-repPhases _                  = dataCon allPhasesDataConName
-
-rep_complete_sig :: Located [LocatedN Name]
-                 -> Maybe (LocatedN Name)
-                 -> SrcSpan
-                 -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_complete_sig (L _ cls) mty loc
-  = do { mty' <- repMaybe nameTyConName lookupLOcc mty
-       ; cls' <- repList nameTyConName lookupLOcc cls
-       ; sig <- repPragComplete cls' mty'
-       ; return [(loc, sig)] }
-
--------------------------------------------------------
---                      Types
--------------------------------------------------------
-
-class RepTV flag flag' | flag -> flag' where
-    tyVarBndrName :: Name
-    repPlainTV  :: Core TH.Name -> flag -> MetaM (Core (M (TH.TyVarBndr flag')))
-    repKindedTV :: Core TH.Name -> flag -> Core (M TH.Kind)
-                -> MetaM (Core (M (TH.TyVarBndr flag')))
-
-instance RepTV () () where
-    tyVarBndrName = tyVarBndrUnitTyConName
-    repPlainTV  (MkC nm) ()          = rep2 plainTVName  [nm]
-    repKindedTV (MkC nm) () (MkC ki) = rep2 kindedTVName [nm, ki]
-
-instance RepTV Specificity TH.Specificity where
-    tyVarBndrName = tyVarBndrSpecTyConName
-    repPlainTV  (MkC nm) spec          = do { (MkC spec') <- rep_flag spec
-                                            ; rep2 plainInvisTVName  [nm, spec'] }
-    repKindedTV (MkC nm) spec (MkC ki) = do { (MkC spec') <- rep_flag spec
-                                            ; rep2 kindedInvisTVName [nm, spec', ki] }
-
-rep_flag :: Specificity -> MetaM (Core TH.Specificity)
-rep_flag SpecifiedSpec = rep2_nw specifiedSpecName []
-rep_flag InferredSpec  = rep2_nw inferredSpecName []
-
-addHsOuterFamEqnTyVarBinds ::
-     HsOuterFamEqnTyVarBndrs GhcRn
-  -> (Core (Maybe [M TH.TyVarBndrUnit]) -> MetaM (Core (M a)))
-  -> MetaM (Core (M a))
-addHsOuterFamEqnTyVarBinds outer_bndrs thing_inside = do
-  elt_ty <- wrapName tyVarBndrUnitTyConName
-  case outer_bndrs of
-    HsOuterImplicit{hso_ximplicit = imp_tvs} ->
-      addTyClTyVarBinds (mk_qtvs imp_tvs []) $ \_th_exp_bndrs ->
-      thing_inside $ coreNothingList elt_ty
-    HsOuterExplicit{hso_bndrs = exp_bndrs} ->
-      addTyClTyVarBinds (mk_qtvs [] exp_bndrs) $ \th_exp_bndrs ->
-      thing_inside $ coreJustList elt_ty th_exp_bndrs
-  where
-    mk_qtvs imp_tvs exp_tvs = HsQTvs { hsq_ext = imp_tvs
-                                     , hsq_explicit = exp_tvs }
-
-addHsOuterSigTyVarBinds ::
-     HsOuterSigTyVarBndrs GhcRn
-  -> (Core [M TH.TyVarBndrSpec] -> MetaM (Core (M a)))
-  -> MetaM (Core (M a))
-addHsOuterSigTyVarBinds outer_bndrs thing_inside = case outer_bndrs of
-  HsOuterImplicit{hso_ximplicit = imp_tvs} ->
-    do th_nil <- coreListM tyVarBndrSpecTyConName []
-       addSimpleTyVarBinds imp_tvs $ thing_inside th_nil
-  HsOuterExplicit{hso_bndrs = exp_bndrs} ->
-    addHsTyVarBinds exp_bndrs thing_inside
-
--- | If a type implicitly quantifies its outermost type variables, return
--- 'True' if the list of implicitly bound type variables is empty. If a type
--- explicitly quantifies its outermost type variables, always return 'True'.
---
--- This is used in various places to determine if a Template Haskell 'Type'
--- should be headed by a 'ForallT' or not.
-nullOuterImplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool
-nullOuterImplicit (HsOuterImplicit{hso_ximplicit = imp_tvs}) = null imp_tvs
-nullOuterImplicit (HsOuterExplicit{})                        = True
-  -- Vacuously true, as there is no implicit quantification
-
--- | If a type explicitly quantifies its outermost type variables, return
--- 'True' if the list of explicitly bound type variables is empty. If a type
--- implicitly quantifies its outermost type variables, always return 'True'.
---
--- This is used in various places to determine if a Template Haskell 'Type'
--- should be headed by a 'ForallT' or not.
-nullOuterExplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool
-nullOuterExplicit (HsOuterExplicit{hso_bndrs = exp_bndrs}) = null exp_bndrs
-nullOuterExplicit (HsOuterImplicit{})                      = True
-  -- Vacuously true, as there is no outermost explicit quantification
-
-addSimpleTyVarBinds :: [Name]             -- the binders to be added
-                    -> MetaM (Core (M a)) -- action in the ext env
-                    -> MetaM (Core (M a))
-addSimpleTyVarBinds names thing_inside
-  = do { fresh_names <- mkGenSyms names
-       ; term <- addBinds fresh_names thing_inside
-       ; wrapGenSyms fresh_names term }
-
-addHsTyVarBinds :: forall flag flag' a. RepTV flag flag'
-                => [LHsTyVarBndr flag GhcRn] -- the binders to be added
-                -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env
-                -> MetaM (Core (M a))
-addHsTyVarBinds exp_tvs thing_inside
-  = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)
-       ; term <- addBinds fresh_exp_names $
-                 do { kbs <- repListM (tyVarBndrName @flag @flag') repTyVarBndr
-                                      exp_tvs
-                    ; thing_inside kbs }
-       ; wrapGenSyms fresh_exp_names term }
-
-addQTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added
-               -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env
-               -> MetaM (Core (M a))
-addQTyVarBinds (HsQTvs { hsq_ext = imp_tvs
-                      , hsq_explicit = exp_tvs })
-              thing_inside
-  = addTyVarBinds exp_tvs imp_tvs thing_inside
-
-addTyVarBinds :: RepTV flag flag'
-              => [LHsTyVarBndr flag GhcRn] -- the binders to be added
-              -> [Name]
-              -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env
-              -> MetaM (Core (M a))
--- gensym a list of type variables and enter them into the meta environment;
--- the computations passed as the second argument is executed in that extended
--- meta environment and gets the *new* names on Core-level as an argument
-addTyVarBinds exp_tvs imp_tvs thing_inside
-  = addSimpleTyVarBinds imp_tvs $
-    addHsTyVarBinds exp_tvs $
-    thing_inside
-
-addTyClTyVarBinds :: LHsQTyVars GhcRn
-                  -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a)))
-                  -> MetaM (Core (M a))
--- Used for data/newtype declarations, and family instances,
--- so that the nested type variables work right
---    instance C (T a) where
---      type W (T a) = blah
--- The 'a' in the type instance is the one bound by the instance decl
-addTyClTyVarBinds tvs m
-  = do { let tv_names = hsAllLTyVarNames tvs
-       ; env <- lift $ dsGetMetaEnv
-       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
-            -- Make fresh names for the ones that are not already in scope
-            -- This makes things work for family declarations
-
-       ; term <- addBinds freshNames $
-                 do { kbs <- repListM tyVarBndrUnitTyConName repTyVarBndr
-                                     (hsQTvExplicit tvs)
-                    ; m kbs }
-
-       ; wrapGenSyms freshNames term }
-
--- | Represent a type variable binder
-repTyVarBndr :: RepTV flag flag'
-             => LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TH.TyVarBndr flag')))
-repTyVarBndr (L _ (UserTyVar _ fl (L _ nm)) )
-  = do { nm' <- lookupBinder nm
-       ; repPlainTV nm' fl }
-repTyVarBndr (L _ (KindedTyVar _ fl (L _ nm) ki))
-  = do { nm' <- lookupBinder nm
-       ; ki' <- repLTy ki
-       ; repKindedTV nm' fl ki' }
-
--- represent a type context
---
-repLContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt))
-repLContext Nothing = repContext []
-repLContext (Just ctxt) = repContext (unLoc ctxt)
-
-repContext :: HsContext GhcRn -> MetaM (Core (M TH.Cxt))
-repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt
-                     repCtxt preds
-
-repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type))
-repHsSigType (L _ (HsSig { sig_bndrs = outer_bndrs, sig_body = body }))
-  | (ctxt, tau) <- splitLHsQualTy body
-  = addHsOuterSigTyVarBinds outer_bndrs $ \ th_outer_bndrs ->
-    do { th_ctxt <- repLContext ctxt
-       ; th_tau  <- repLTy tau
-       ; if nullOuterExplicit outer_bndrs && null (fromMaybeContext ctxt)
-         then pure th_tau
-         else repTForall th_outer_bndrs th_ctxt th_tau }
-
--- yield the representation of a list of types
-repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)]
-repLTys tys = mapM repLTy tys
-
--- represent a type
-repLTy :: LHsType GhcRn -> MetaM (Core (M TH.Type))
-repLTy ty = repTy (unLoc ty)
-
--- Desugar a type headed by an invisible forall (e.g., @forall a. a@) or
--- a context (e.g., @Show a => a@) into a ForallT from L.H.TH.Syntax.
--- In other words, the argument to this function is always an
--- @HsForAllTy HsForAllInvis{}@ or @HsQualTy@.
--- Types headed by visible foralls (which are desugared to ForallVisT) are
--- handled separately in repTy.
-repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type))
-repForallT ty
- | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLocA ty)
- = addHsTyVarBinds tvs $ \bndrs ->
-   do { ctxt1  <- repLContext ctxt
-      ; tau1   <- repLTy tau
-      ; repTForall bndrs ctxt1 tau1 -- forall a. C a => {...}
-      }
-
-repTy :: HsType GhcRn -> MetaM (Core (M TH.Type))
-repTy ty@(HsForAllTy { hst_tele = tele, hst_body = body }) =
-  case tele of
-    HsForAllInvis{} -> repForallT ty
-    HsForAllVis { hsf_vis_bndrs = tvs } ->
-      addHsTyVarBinds tvs $ \bndrs ->
-      do body1 <- repLTy body
-         repTForallVis bndrs body1
-repTy ty@(HsQualTy {}) = repForallT ty
-
-repTy (HsTyVar _ _ (L _ n))
-  | n `hasKey` liftedTypeKindTyConKey  = repTStar
-  | n `hasKey` constraintKindTyConKey  = repTConstraint
-  | n `hasKey` unrestrictedFunTyConKey = repArrowTyCon
-  | n `hasKey` fUNTyConKey             = repMulArrowTyCon
-  | isTvOcc occ   = do tv1 <- lookupOcc n
-                       repTvar tv1
-  | isDataOcc occ = do tc1 <- lookupOcc n
-                       repPromotedDataCon tc1
-  | n == eqTyConName = repTequality
-  | otherwise     = do tc1 <- lookupOcc n
-                       repNamedTyCon tc1
-  where
-    occ = nameOccName n
-
-repTy (HsAppTy _ f a)       = do
-                                f1 <- repLTy f
-                                a1 <- repLTy a
-                                repTapp f1 a1
-repTy (HsAppKindTy _ ty ki) = do
-                                ty1 <- repLTy ty
-                                ki1 <- repLTy ki
-                                repTappKind ty1 ki1
-repTy (HsFunTy _ w f a) | isUnrestricted w = do
-                                f1   <- repLTy f
-                                a1   <- repLTy a
-                                tcon <- repArrowTyCon
-                                repTapps tcon [f1, a1]
-repTy (HsFunTy _ w f a) = do w1   <- repLTy (arrowToHsType w)
-                             f1   <- repLTy f
-                             a1   <- repLTy a
-                             tcon <- repMulArrowTyCon
-                             repTapps tcon [w1, f1, a1]
-repTy (HsListTy _ t)        = do
-                                t1   <- repLTy t
-                                tcon <- repListTyCon
-                                repTapp tcon t1
-repTy (HsTupleTy _ HsUnboxedTuple tys) = do
-                                tys1 <- repLTys tys
-                                tcon <- repUnboxedTupleTyCon (length tys)
-                                repTapps tcon tys1
-repTy (HsTupleTy _ _ tys)   = do tys1 <- repLTys tys
-                                 tcon <- repTupleTyCon (length tys)
-                                 repTapps tcon tys1
-repTy (HsSumTy _ tys)       = do tys1 <- repLTys tys
-                                 tcon <- repUnboxedSumTyCon (length tys)
-                                 repTapps tcon tys1
-repTy (HsOpTy _ prom ty1 n ty2) = repLTy ((nlHsTyVar prom (unLoc n) `nlHsAppTy` ty1)
-                                   `nlHsAppTy` ty2)
-repTy (HsParTy _ t)         = repLTy t
-repTy (HsStarTy _ _) =  repTStar
-repTy (HsKindSig _ t k)     = do
-                                t1 <- repLTy t
-                                k1 <- repLTy k
-                                repTSig t1 k1
-repTy (HsSpliceTy (HsUntypedSpliceNested n) _) = rep_splice n
-repTy t@(HsSpliceTy (HsUntypedSpliceTop _ _) _) = pprPanic "repTy: top level splice" (ppr t)
-repTy (HsExplicitListTy _ _ tys) = do
-                                    tys1 <- repLTys tys
-                                    repTPromotedList tys1
-repTy (HsExplicitTupleTy _ tys) = do
-                                    tys1 <- repLTys tys
-                                    tcon <- repPromotedTupleTyCon (length tys)
-                                    repTapps tcon tys1
-repTy (HsTyLit _ lit) = do
-                          lit' <- repTyLit lit
-                          repTLit lit'
-repTy (HsWildCardTy _) = repTWildCard
-repTy (HsIParamTy _ n t) = do
-                             n' <- rep_implicit_param_name (unLoc n)
-                             t' <- repLTy t
-                             repTImplicitParam n' t'
-
-repTy ty                      = notHandled (ThExoticFormOfType ty)
-
-repTyLit :: HsTyLit (GhcPass p) -> MetaM (Core (M TH.TyLit))
-repTyLit (HsNumTy _ i) = do
-                         platform <- getPlatform
-                         rep2 numTyLitName [mkIntegerExpr platform i]
-repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
-                            ; rep2 strTyLitName [s']
-                            }
-repTyLit (HsCharTy _ c) = do { c' <- return (mkCharExpr c)
-                             ; rep2 charTyLitName [c']
-                             }
-
--- | Represent a type wrapped in a Maybe
-repMaybeLTy :: Maybe (LHsKind GhcRn)
-            -> MetaM (Core (Maybe (M TH.Type)))
-repMaybeLTy m = do
-  k_ty <- wrapName kindTyConName
-  repMaybeT k_ty repLTy m
-
-repRole :: LocatedAn NoEpAnns (Maybe Role) -> MetaM (Core TH.Role)
-repRole (L _ (Just Nominal))          = rep2_nw nominalRName []
-repRole (L _ (Just Representational)) = rep2_nw representationalRName []
-repRole (L _ (Just Phantom))          = rep2_nw phantomRName []
-repRole (L _ Nothing)                 = rep2_nw inferRName []
-
------------------------------------------------------------------------------
---              Splices
------------------------------------------------------------------------------
-
--- See Note [How brackets and nested splices are handled] in GHC.Tc.Gen.Splice
--- We return a CoreExpr of any old type; the context should know
-
-rep_splice :: Name -> MetaM (Core a)
-rep_splice splice_name
- = do { mb_val <- lift $ dsLookupMetaEnv splice_name
-       ; case mb_val of
-           Just (DsSplice e) -> do { e' <- lift $ dsExpr e
-                                   ; return (MkC e') }
-           _ -> pprPanic "HsSplice" (ppr splice_name) }
-                        -- Should not happen; statically checked
-
------------------------------------------------------------------------------
---              Expressions
------------------------------------------------------------------------------
-
-repLEs :: [LHsExpr GhcRn] -> MetaM (Core [(M TH.Exp)])
-repLEs es = repListM expTyConName repLE es
-
--- FIXME: some of these panics should be converted into proper error messages
---        unless we can make sure that constructs, which are plainly not
---        supported in TH already lead to error messages at an earlier stage
-repLE :: LHsExpr GhcRn -> MetaM (Core (M TH.Exp))
-repLE (L loc e) = mapReaderT (putSrcSpanDs (locA loc)) (repE e)
-
-repE :: HsExpr GhcRn -> MetaM (Core (M TH.Exp))
-repE (HsVar _ (L _ x)) =
-  do { mb_val <- lift $ dsLookupMetaEnv x
-     ; case mb_val of
-        Nothing            -> do { str <- lift $ globalVar x
-                                 ; repVarOrCon x str }
-        Just (DsBound y)   -> repVarOrCon x (coreVar y)
-        Just (DsSplice e)  -> do { e' <- lift $ dsExpr e
-                                 ; return (MkC e') } }
-repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
-repE (HsOverLabel _ s) = repOverLabel s
-
-repE (HsRecSel _ (FieldOcc x _)) = repE (HsVar noExtField (noLocA x))
-
-        -- Remember, we're desugaring renamer output here, so
-        -- HsOverlit can definitely occur
-repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
-repE (HsLit _ l)     = do { a <- repLiteral l;           repLit a }
-repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m
-repE e@(HsLam _ (MG { mg_alts = (L _ _) })) = pprPanic "repE: HsLam with multiple alternatives" (ppr e)
-repE (HsLamCase _ LamCase (MG { mg_alts = (L _ ms) }))
-                   = do { ms' <- mapM repMatchTup ms
-                        ; core_ms <- coreListM matchTyConName ms'
-                        ; repLamCase core_ms }
-repE (HsLamCase _ LamCases (MG { mg_alts = (L _ ms) }))
-                   = do { ms' <- mapM repClauseTup ms
-                        ; core_ms <- coreListM matchTyConName ms'
-                        ; repLamCases core_ms }
-repE (HsApp _ x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
-repE (HsAppType _ e _ t)
-                       = do { a <- repLE e
-                            ; s <- repLTy (hswc_body t)
-                            ; repAppType a s }
-
-repE (OpApp _ e1 op e2) =
-  do { arg1 <- repLE e1;
-       arg2 <- repLE e2;
-       the_op <- repLE op ;
-       repInfixApp arg1 the_op arg2 }
-repE (NegApp _ x _)      = do
-                              a         <- repLE x
-                              negateVar <- lookupOcc negateName >>= repVar
-                              negateVar `repApp` a
-repE (HsPar _ _ x _)        = repLE x
-repE (SectionL _ x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
-repE (SectionR _ x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
-repE (HsCase _ e (MG { mg_alts = (L _ ms) }))
-                          = do { arg <- repLE e
-                               ; ms2 <- mapM repMatchTup ms
-                               ; core_ms2 <- coreListM matchTyConName ms2
-                               ; repCaseE arg core_ms2 }
-repE (HsIf _ x y z)       = do
-                            a <- repLE x
-                            b <- repLE y
-                            c <- repLE z
-                            repCond a b c
-repE (HsMultiIf _ alts)
-  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
-       ; expr' <- repMultiIf (nonEmptyCoreList alts')
-       ; wrapGenSyms (concat binds) expr' }
-repE (HsLet _ _ bs _ e)         = do { (ss,ds) <- repBinds bs
-                                     ; e2 <- addBinds ss (repLE e)
-                                     ; z <- repLetE ds e2
-                                     ; wrapGenSyms ss z }
-
--- FIXME: I haven't got the types here right yet
-repE e@(HsDo _ ctxt (L _ sts))
- | Just maybeModuleName <- case ctxt of
-     { DoExpr m -> Just m; GhciStmtCtxt -> Just Nothing; _ -> Nothing }
- = do { (ss,zs) <- repLSts sts;
-        e'      <- repDoE maybeModuleName (nonEmptyCoreList zs);
-        wrapGenSyms ss e' }
-
- | ListComp <- ctxt
- = do { (ss,zs) <- repLSts sts;
-        e'      <- repComp (nonEmptyCoreList zs);
-        wrapGenSyms ss e' }
-
- | MDoExpr maybeModuleName <- ctxt
- = do { (ss,zs) <- repLSts sts;
-        e'      <- repMDoE maybeModuleName (nonEmptyCoreList zs);
-        wrapGenSyms ss e' }
-
-  | otherwise
-  = notHandled (ThMonadComprehensionSyntax e)
-
-repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs }
-repE (ExplicitTuple _ es boxity) =
-  let tupArgToCoreExp :: HsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp)))
-      tupArgToCoreExp a
-        | (Present _ e) <- a = do { e' <- repLE e
-                                  ; coreJustM expTyConName e' }
-        | otherwise = coreNothingM expTyConName
-
-  in do { args <- mapM tupArgToCoreExp es
-        ; expTy <- wrapName  expTyConName
-        ; let maybeExpQTy = mkTyConApp maybeTyCon [expTy]
-              listArg = coreList' maybeExpQTy args
-        ; if isBoxed boxity
-          then repTup listArg
-          else repUnboxedTup listArg }
-
-repE (ExplicitSum _ alt arity e)
- = do { e1 <- repLE e
-      ; repUnboxedSum e1 alt arity }
-
-repE (RecordCon { rcon_con = c, rcon_flds = flds })
- = do { x <- lookupLOcc c;
-        fs <- repFields flds;
-        repRecCon x fs }
-repE (RecordUpd { rupd_expr = e, rupd_flds = Left flds })
- = do { x <- repLE e;
-        fs <- repUpdFields flds;
-        repRecUpd x fs }
-repE (RecordUpd { rupd_flds = Right _ })
-  = do
-      -- Not possible due to elimination in the renamer. See Note
-      -- [Handling overloaded and rebindable constructs]
-      panic "The impossible has happened!"
-
-repE (ExprWithTySig _ e wc_ty)
-  = addSimpleTyVarBinds (get_scoped_tvs_from_sig sig_ty) $
-    do { e1 <- repLE e
-       ; t1 <- rep_ty_sig' sig_ty
-       ; repSigExp e1 t1 }
-  where
-    sig_ty = dropWildCards wc_ty
-
-repE (ArithSeq _ _ aseq) =
-  case aseq of
-    From e              -> do { ds1 <- repLE e; repFrom ds1 }
-    FromThen e1 e2      -> do
-                             ds1 <- repLE e1
-                             ds2 <- repLE e2
-                             repFromThen ds1 ds2
-    FromTo   e1 e2      -> do
-                             ds1 <- repLE e1
-                             ds2 <- repLE e2
-                             repFromTo ds1 ds2
-    FromThenTo e1 e2 e3 -> do
-                             ds1 <- repLE e1
-                             ds2 <- repLE e2
-                             ds3 <- repLE e3
-                             repFromThenTo ds1 ds2 ds3
-
-repE (HsTypedSplice n _) = rep_splice n
-repE (HsUntypedSplice (HsUntypedSpliceNested n) _)  = rep_splice n
-repE e@(HsUntypedSplice (HsUntypedSpliceTop _ _) _) = pprPanic "repE: top level splice" (ppr e)
-repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC
-repE (HsUnboundVar _ uv)   = do
-                               occ   <- occNameLit uv
-                               sname <- repNameS occ
-                               repUnboundVar sname
-repE (HsGetField _ e (L _ (DotFieldOcc _ (L _ (FieldLabelString f))))) = do
-  e1 <- repLE e
-  repGetField e1 f
-repE (HsProjection _ xs) = repProjection (fmap (field_label . unLoc . dfoLabel . unLoc) xs)
-repE (XExpr (HsExpanded orig_expr ds_expr))
-  = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax
-       ; if rebindable_on  -- See Note [Quotation and rebindable syntax]
-         then repE ds_expr
-         else repE orig_expr }
-repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)
-repE e@(HsTypedBracket{})   = notHandled (ThExpressionForm e)
-repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e)
-repE e@(HsProc{}) = notHandled (ThExpressionForm e)
-
-{- Note [Quotation and rebindable syntax]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  f = [| (* 3) |]
-
-Because of Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr,
-the renamer will expand (* 3) to (rightSection (*) 3), regardless of RebindableSyntax.
-Then, concerning the TH quotation,
-
-* If RebindableSyntax is off, we want the TH quote to generate the section (* 3),
-  as the user originally wrote.
-
-* If RebindableSyntax is on, we perhaps want the TH quote to generate
-  (rightSection (*) 3), using whatever 'rightSection' is in scope, because
-  (a) RebindableSyntax might not be on in the splicing context
-  (b) Even if it is, 'rightSection' might not be in scope
-  (c) At least in the case of Typed Template Haskell we should never get
-      a type error from the splice.
-
-We consult the module-wide RebindableSyntax flag here. We could instead record
-the choice in HsExpanded, but it seems simpler to consult the flag (again).
--}
-
------------------------------------------------------------------------------
--- Building representations of auxiliary structures like Match, Clause, Stmt,
-
-repMatchTup ::  LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match))
-repMatchTup (L _ (Match { m_pats = [p]
-                        , m_grhss = GRHSs _ guards wheres })) =
-  do { ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p)
-     ; addBinds ss1 $ do {
-     ; p1 <- repLP p
-     ; (ss2,ds) <- repBinds wheres
-     ; addBinds ss2 $ do {
-     ; gs    <- repGuards guards
-     ; match <- repMatch p1 gs ds
-     ; wrapGenSyms (ss1++ss2) match }}}
-repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
-
-repClauseTup ::  LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause))
-repClauseTup (L _ (Match { m_pats = ps
-                         , m_grhss = GRHSs _ guards  wheres })) =
-  do { ss1 <- mkGenSyms (collectPatsBinders CollNoDictBinders ps)
-     ; addBinds ss1 $ do {
-       ps1 <- repLPs ps
-     ; (ss2,ds) <- repBinds wheres
-     ; addBinds ss2 $ do {
-       gs <- repGuards guards
-     ; clause <- repClause ps1 gs ds
-     ; wrapGenSyms (ss1++ss2) clause }}}
-
-repGuards ::  [LGRHS GhcRn (LHsExpr GhcRn)] ->  MetaM (Core (M TH.Body))
-repGuards [L _ (GRHS _ [] e)]
-  = do {a <- repLE e; repNormal a }
-repGuards other
-  = do { zs <- mapM repLGRHS other
-       ; let (xs, ys) = unzip zs
-       ; gd <- repGuarded (nonEmptyCoreList ys)
-       ; wrapGenSyms (concat xs) gd }
-
-repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
-         -> MetaM ([GenSymBind], (Core (M (TH.Guard, TH.Exp))))
-repLGRHS (L _ (GRHS _ [L _ (BodyStmt _ e1 _ _)] e2))
-  = do { guarded <- repLNormalGE e1 e2
-       ; return ([], guarded) }
-repLGRHS (L _ (GRHS _ ss rhs))
-  = do { (gs, ss') <- repLSts ss
-       ; rhs' <- addBinds gs $ repLE rhs
-       ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
-       ; return (gs, guarded) }
-
-repFields :: HsRecordBinds GhcRn -> MetaM (Core [M TH.FieldExp])
-repFields (HsRecFields { rec_flds = flds })
-  = repListM fieldExpTyConName rep_fld flds
-  where
-    rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
-            -> MetaM (Core (M TH.FieldExp))
-    rep_fld (L _ fld) = do { fn <- lookupOcc (hsRecFieldSel fld)
-                           ; e  <- repLE (hfbRHS fld)
-                           ; repFieldExp fn e }
-
-repUpdFields :: [LHsRecUpdField GhcRn] -> MetaM (Core [M TH.FieldExp])
-repUpdFields = repListM fieldExpTyConName rep_fld
-  where
-    rep_fld :: LHsRecUpdField GhcRn -> MetaM (Core (M TH.FieldExp))
-    rep_fld (L l fld) = case unLoc (hfbLHS fld) of
-      Unambiguous sel_name _ -> do { fn <- lookupLOcc (L l sel_name)
-                                   ; e  <- repLE (hfbRHS fld)
-                                   ; repFieldExp fn e }
-      Ambiguous{}            -> notHandled (ThAmbiguousRecordUpdates fld)
-
-
-
------------------------------------------------------------------------------
--- Representing Stmt's is tricky, especially if bound variables
--- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
--- First gensym new names for every variable in any of the patterns.
--- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
--- if variables didn't shadow, the static gensym wouldn't be necessary
--- and we could reuse the original names (x and x).
---
--- do { x'1 <- gensym "x"
---    ; x'2 <- gensym "x"
---    ; doE Nothing
---          [ BindSt (pvar x'1) [| f 1 |]
---          , BindSt (pvar x'2) [| f x |]
---          , NoBindSt [| g x |]
---          ]
---    }
-
--- The strategy is to translate a whole list of do-bindings by building a
--- bigger environment, and a bigger set of meta bindings
--- (like:  x'1 <- gensym "x" ) and then combining these with the translations
--- of the expressions within the Do
-
------------------------------------------------------------------------------
--- The helper function repSts computes the translation of each sub expression
--- and a bunch of prefix bindings denoting the dynamic renaming.
-
-repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)])
-repLSts stmts = repSts (map unLoc stmts)
-
-repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)])
-repSts (BindStmt _ p e : ss) =
-   do { e2 <- repLE e
-      ; ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p)
-      ; addBinds ss1 $ do {
-      ; p1 <- repLP p;
-      ; (ss2,zs) <- repSts ss
-      ; z <- repBindSt p1 e2
-      ; return (ss1++ss2, z : zs) }}
-repSts (LetStmt _ bs : ss) =
-   do { (ss1,ds) <- repBinds bs
-      ; z <- repLetSt ds
-      ; (ss2,zs) <- addBinds ss1 (repSts ss)
-      ; return (ss1++ss2, z : zs) }
-repSts (BodyStmt _ e _ _ : ss) =
-   do { e2 <- repLE e
-      ; z <- repNoBindSt e2
-      ; (ss2,zs) <- repSts ss
-      ; return (ss2, z : zs) }
-repSts (ParStmt _ stmt_blocks _ _ : ss) =
-   do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
-      ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
-            ss1 = concat ss_s
-      ; z <- repParSt stmt_blocks2
-      ; (ss2, zs) <- addBinds ss1 (repSts ss)
-      ; return (ss1++ss2, z : zs) }
-   where
-     rep_stmt_block :: ParStmtBlock GhcRn GhcRn
-                    -> MetaM ([GenSymBind], Core [(M TH.Stmt)])
-     rep_stmt_block (ParStmtBlock _ stmts _ _) =
-       do { (ss1, zs) <- repSts (map unLoc stmts)
-          ; zs1 <- coreListM stmtTyConName zs
-          ; return (ss1, zs1) }
-repSts [LastStmt _ e _ _]
-  = do { e2 <- repLE e
-       ; z <- repNoBindSt e2
-       ; return ([], [z]) }
-repSts (stmt@RecStmt{} : ss)
-  = do { let binders = collectLStmtsBinders CollNoDictBinders (unLoc $ recS_stmts stmt)
-       ; ss1 <- mkGenSyms binders
-       -- Bring all of binders in the recursive group into scope for the
-       -- whole group.
-       ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (unLoc $ recS_stmts stmt))
-       ; massert (sort ss1 == sort ss1_other)
-       ; z <- repRecSt (nonEmptyCoreList rss)
-       ; (ss2,zs) <- addBinds ss1 (repSts ss)
-       ; return (ss1++ss2, z : zs) }
-repSts []    = return ([],[])
-repSts other = notHandled (ThExoticStatement other)
-
-
------------------------------------------------------------
---                      Bindings
------------------------------------------------------------
-
-repBinds :: HsLocalBinds GhcRn -> MetaM ([GenSymBind], Core [(M TH.Dec)])
-repBinds (EmptyLocalBinds _)
-  = do  { core_list <- coreListM decTyConName []
-        ; return ([], core_list) }
-
-repBinds (HsIPBinds _ (IPBinds _ decs))
- = do   { ips <- mapM rep_implicit_param_bind decs
-        ; core_list <- coreListM decTyConName
-                                (de_loc (sort_by_loc ips))
-        ; return ([], core_list)
-        }
-
-repBinds (HsValBinds _ decs)
- = do   { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders CollNoDictBinders decs }
-                -- No need to worry about detailed scopes within
-                -- the binding group, because we are talking Names
-                -- here, so we can safely treat it as a mutually
-                -- recursive group
-                -- For hsScopedTvBinders see Note [Scoped type variables in quotes]
-        ; ss        <- mkGenSyms bndrs
-        ; prs       <- addBinds ss (rep_val_binds decs)
-        ; core_list <- coreListM decTyConName
-                                (de_loc (sort_by_loc prs))
-        ; return (ss, core_list) }
-
-rep_implicit_param_bind :: LIPBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
-rep_implicit_param_bind (L loc (IPBind _ (L _ n) (L _ rhs)))
- = do { name <- rep_implicit_param_name n
-      ; rhs' <- repE rhs
-      ; ipb <- repImplicitParamBind name rhs'
-      ; return (locA loc, ipb) }
-
-rep_implicit_param_name :: HsIPName -> MetaM (Core String)
-rep_implicit_param_name (HsIPName name) = coreStringLit name
-
-rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
--- Assumes: all the binders of the binding are already in the meta-env
-rep_val_binds (XValBindsLR (NValBinds binds sigs))
- = do { core1 <- rep_binds (unionManyBags (map snd binds))
-      ; core2 <- rep_sigs sigs
-      ; return (core1 ++ core2) }
-rep_val_binds (ValBinds _ _ _)
- = panic "rep_val_binds: ValBinds"
-
-rep_binds :: LHsBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_binds = mapM rep_bind . bagToList
-
-rep_bind :: LHsBind GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
--- Assumes: all the binders of the binding are already in the meta-env
-
--- Note GHC treats declarations of a variable (not a pattern)
--- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
--- with an empty list of patterns
-rep_bind (L loc (FunBind
-                 { fun_id = fn,
-                   fun_matches = MG { mg_alts
-                           = (L _ [L _ (Match
-                                   { m_pats = []
-                                   , m_grhss = GRHSs _ guards wheres }
-                                      )]) } }))
- = do { (ss,wherecore) <- repBinds wheres
-        ; guardcore <- addBinds ss (repGuards guards)
-        ; fn'  <- lookupNBinder fn
-        ; p    <- repPvar fn'
-        ; ans  <- repVal p guardcore wherecore
-        ; ans' <- wrapGenSyms ss ans
-        ; return (locA loc, ans') }
-
-rep_bind (L loc (FunBind { fun_id = fn
-                         , fun_matches = MG { mg_alts = L _ ms } }))
- =   do { ms1 <- mapM repClauseTup ms
-        ; fn' <- lookupNBinder fn
-        ; ans <- repFun fn' (nonEmptyCoreList ms1)
-        ; return (locA loc, ans) }
-
-rep_bind (L loc (PatBind { pat_lhs = pat
-                         , pat_rhs = GRHSs _ guards wheres }))
- =   do { patcore <- repLP pat
-        ; (ss,wherecore) <- repBinds wheres
-        ; guardcore <- addBinds ss (repGuards guards)
-        ; ans  <- repVal patcore guardcore wherecore
-        ; ans' <- wrapGenSyms ss ans
-        ; return (locA loc, ans') }
-
-rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))
- =   do { v' <- lookupBinder v
-        ; e2 <- repLE e
-        ; x <- repNormal e2
-        ; patcore <- repPvar v'
-        ; empty_decls <- coreListM decTyConName []
-        ; ans <- repVal patcore x empty_decls
-        ; return (srcLocSpan (getSrcLoc v), ans) }
-
-rep_bind (L loc (PatSynBind _ (PSB { psb_id   = syn
-                                   , psb_args = args
-                                   , psb_def  = pat
-                                   , psb_dir  = dir })))
-  = do { syn'      <- lookupNBinder syn
-       ; dir'      <- repPatSynDir dir
-       ; ss        <- mkGenArgSyms args
-       ; patSynD'  <- addBinds ss (
-         do { args'  <- repPatSynArgs args
-            ; pat'   <- repLP pat
-            ; repPatSynD syn' args' dir' pat' })
-       ; patSynD'' <- wrapGenArgSyms args ss patSynD'
-       ; return (locA loc, patSynD'') }
-  where
-    mkGenArgSyms :: HsPatSynDetails GhcRn -> MetaM [GenSymBind]
-    -- for Record Pattern Synonyms we want to conflate the selector
-    -- and the pattern-only names in order to provide a nicer TH
-    -- API. Whereas inside GHC, record pattern synonym selectors and
-    -- their pattern-only bound right hand sides have different names,
-    -- we want to treat them the same in TH. This is the reason why we
-    -- need an adjusted mkGenArgSyms in the `RecCon` case below.
-    mkGenArgSyms (PrefixCon _ args)   = mkGenSyms (map unLoc args)
-    mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
-    mkGenArgSyms (RecCon fields)
-      = do { let pats = map (unLoc . recordPatSynPatVar) fields
-                 sels = map (foExt . recordPatSynField) fields
-           ; ss <- mkGenSyms sels
-           ; return $ replaceNames (zip sels pats) ss }
-
-    replaceNames selsPats genSyms
-      = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats
-                    , sel == sel' ]
-
-    wrapGenArgSyms :: HsPatSynDetails GhcRn
-                   -> [GenSymBind] -> Core (M TH.Dec) -> MetaM (Core (M TH.Dec))
-    wrapGenArgSyms (RecCon _) _  dec = return dec
-    wrapGenArgSyms _          ss dec = wrapGenSyms ss dec
-
-repPatSynD :: Core TH.Name
-           -> Core (M TH.PatSynArgs)
-           -> Core (M TH.PatSynDir)
-           -> Core (M TH.Pat)
-           -> MetaM (Core (M TH.Dec))
-repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
-  = rep2 patSynDName [syn, args, dir, pat]
-
-repPatSynArgs :: HsPatSynDetails GhcRn -> MetaM (Core (M TH.PatSynArgs))
-repPatSynArgs (PrefixCon _ args)
-  = do { args' <- repList nameTyConName lookupLOcc args
-       ; repPrefixPatSynArgs args' }
-repPatSynArgs (InfixCon arg1 arg2)
-  = do { arg1' <- lookupLOcc arg1
-       ; arg2' <- lookupLOcc arg2
-       ; repInfixPatSynArgs arg1' arg2' }
-repPatSynArgs (RecCon fields)
-  = do { sels' <- repList nameTyConName (lookupOcc . foExt) sels
-       ; repRecordPatSynArgs sels' }
-  where sels = map recordPatSynField fields
-
-repPrefixPatSynArgs :: Core [TH.Name] -> MetaM (Core (M TH.PatSynArgs))
-repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]
-
-repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> MetaM (Core (M TH.PatSynArgs))
-repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]
-
-repRecordPatSynArgs :: Core [TH.Name]
-                    -> MetaM (Core (M TH.PatSynArgs))
-repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
-
-repPatSynDir :: HsPatSynDir GhcRn -> MetaM (Core (M TH.PatSynDir))
-repPatSynDir Unidirectional        = rep2 unidirPatSynName []
-repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
-repPatSynDir (ExplicitBidirectional (MG { mg_alts = (L _ clauses) }))
-  = do { clauses' <- mapM repClauseTup clauses
-       ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
-
-repExplBidirPatSynDir :: Core [(M TH.Clause)] -> MetaM (Core (M TH.PatSynDir))
-repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
-
-
------------------------------------------------------------------------------
--- Since everything in a Bind is mutually recursive we need rename all
--- all the variables simultaneously. For example:
--- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
--- do { f'1 <- gensym "f"
---    ; g'2 <- gensym "g"
---    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
---        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
---      ]}
--- This requires collecting the bindings (f'1 <- gensym "f"), and the
--- environment ( f |-> f'1 ) from each binding, and then unioning them
--- together. As we do this we collect GenSymBinds's which represent the renamed
--- variables bound by the Bindings. In order not to lose track of these
--- representations we build a shadow datatype MB with the same structure as
--- MonoBinds, but which has slots for the representations
-
-
------------------------------------------------------------------------------
--- GHC allows a more general form of lambda abstraction than specified
--- by Haskell 98. In particular it allows guarded lambda's like :
--- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
--- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
--- (\ p1 .. pn -> exp) by causing an error.
-
-repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp))
-repLambda (L _ (Match { m_pats = ps
-                      , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]
-                                              (EmptyLocalBinds _) } ))
- = do { let bndrs = collectPatsBinders CollNoDictBinders ps ;
-      ; ss  <- mkGenSyms bndrs
-      ; lam <- addBinds ss (
-                do { xs <- repLPs ps; body <- repLE e; repLam xs body })
-      ; wrapGenSyms ss lam }
-
-repLambda (L _ m) = notHandled (ThGuardedLambdas m)
-
-
------------------------------------------------------------------------------
---                      Patterns
--- repP deals with patterns.  It assumes that we have already
--- walked over the pattern(s) once to collect the binders, and
--- have extended the environment.  So every pattern-bound
--- variable should already appear in the environment.
-
--- Process a list of patterns
-repLPs :: [LPat GhcRn] -> MetaM (Core [(M TH.Pat)])
-repLPs ps = repListM patTyConName repLP ps
-
-repLP :: LPat GhcRn -> MetaM (Core (M TH.Pat))
-repLP p = repP (unLoc p)
-
-repP :: Pat GhcRn -> MetaM (Core (M TH.Pat))
-repP (WildPat _)        = repPwild
-repP (LitPat _ l)       = do { l2 <- repLiteral l; repPlit l2 }
-repP (VarPat _ x)       = do { x' <- lookupBinder (unLoc x); repPvar x' }
-repP (LazyPat _ p)      = do { p1 <- repLP p; repPtilde p1 }
-repP (BangPat _ p)      = do { p1 <- repLP p; repPbang p1 }
-repP (AsPat _ x _ p)    = do { x' <- lookupNBinder x; p1 <- repLP p
-                             ; repPaspat x' p1 }
-repP (ParPat _ _ p _)   = repLP p
-repP (ListPat _ ps)     = do { qs <- repLPs ps; repPlist qs }
-repP (TuplePat _ ps boxed)
-  | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }
-  | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }
-repP (SumPat _ p alt arity) = do { p1 <- repLP p
-                                 ; repPunboxedSum p1 alt arity }
-repP (ConPat NoExtField dc details)
- = do { con_str <- lookupLOcc dc
-      ; case details of
-         PrefixCon tyargs ps -> do { qs <- repLPs ps
-                                   ; let unwrapTyArg (HsConPatTyArg _ t) = unLoc (hsps_body t)
-                                   ; ts <- repListM typeTyConName (repTy . unwrapTyArg) tyargs
-                                   ; repPcon con_str ts qs }
-         RecCon rec   -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec)
-                            ; repPrec con_str fps }
-         InfixCon p1 p2 -> do { p1' <- repLP p1;
-                                p2' <- repLP p2;
-                                repPinfix p1' con_str p2' }
-   }
- where
-   rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> MetaM (Core (M (TH.Name, TH.Pat)))
-   rep_fld (L _ fld) = do { MkC v <- lookupOcc (hsRecFieldSel fld)
-                          ; MkC p <- repLP (hfbRHS fld)
-                          ; rep2 fieldPatName [v,p] }
-repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l
-                                     ; repPlit a }
-repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
-repP p@(NPat _ (L _ l) (Just _) _)
-  | OverLitRn rebindable _ <- ol_ext l
-  , rebindable = notHandled (ThNegativeOverloadedPatterns p)
-  | HsIntegral i <- ol_val l = do { a <- repOverloadedLiteral l{ol_val = HsIntegral (negateIntegralLit i)}
-                                  ; repPlit a }
-  | HsFractional i <- ol_val l = do { a <- repOverloadedLiteral l{ol_val = HsFractional (negateFractionalLit i)}
-                                  ; repPlit a }
-  | otherwise = notHandled (ThExoticPattern p)
-repP (SigPat _ p t) = do { p' <- repLP p
-                         ; t' <- repLTy (hsPatSigType t)
-                         ; repPsig p' t' }
-repP (SplicePat (HsUntypedSpliceNested n) _) = rep_splice n
-repP p@(SplicePat (HsUntypedSpliceTop _ _) _) = pprPanic "repP: top level splice" (ppr p)
-repP other = notHandled (ThExoticPattern other)
-
-----------------------------------------------------------
--- Declaration ordering helpers
-
-sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
-sort_by_loc = sortBy (SrcLoc.leftmost_smallest `on` fst)
-
-de_loc :: [(a, b)] -> [b]
-de_loc = map snd
-
-----------------------------------------------------------
---      The meta-environment
-
--- A name/identifier association for fresh names of locally bound entities
-type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id
-                                -- I.e.         (x, x_id) means
-                                --      let x_id = gensym "x" in ...
-
--- Generate a fresh name for a locally bound entity
-
-mkGenSyms :: [Name] -> MetaM [GenSymBind]
--- We can use the existing name.  For example:
---      [| \x_77 -> x_77 + x_77 |]
--- desugars to
---      do { x_77 <- genSym "x"; .... }
--- We use the same x_77 in the desugared program, but with the type Bndr
--- instead of Int
---
--- We do make it an Internal name, though (hence localiseName)
---
--- Nevertheless, it's monadic because we have to generate nameTy
-mkGenSyms ns = do { var_ty <- lookupType nameTyConName
-                  ; return [ (nm, mkLocalId (localiseName nm) ManyTy var_ty)
-                           | nm <- ns] }
-
-
-addBinds :: [GenSymBind] -> MetaM a -> MetaM a
--- Add a list of fresh names for locally bound entities to the
--- meta environment (which is part of the state carried around
--- by the desugarer monad)
-addBinds bs m = mapReaderT (dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs])) m
-
--- Look up a locally bound name
---
-lookupNBinder :: LocatedN Name -> MetaM (Core TH.Name)
-lookupNBinder n = lookupBinder (unLoc n)
-
-lookupBinder :: Name -> MetaM (Core TH.Name)
-lookupBinder = lookupOcc
-  -- Binders are brought into scope before the pattern or what-not is
-  -- desugared.  Moreover, in instance declaration the binder of a method
-  -- will be the selector Id and hence a global; so we need the
-  -- globalVar case of lookupOcc
-
--- Look up a name that is either locally bound or a global name
---
---  * If it is a global name, generate the "original name" representation (ie,
---   the <module>:<name> form) for the associated entity
---
-lookupLOcc :: GenLocated l Name -> MetaM (Core TH.Name)
--- Lookup an occurrence; it can't be a splice.
--- Use the in-scope bindings if they exist
-lookupLOcc n = lookupOcc (unLoc n)
-
-lookupOcc :: Name -> MetaM (Core TH.Name)
-lookupOcc = lift . lookupOccDsM
-
-lookupOccDsM :: Name -> DsM (Core TH.Name)
-lookupOccDsM n
-  = do {  mb_val <- dsLookupMetaEnv n ;
-          case mb_val of
-                Nothing           -> globalVar n
-                Just (DsBound x)  -> return (coreVar x)
-                Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
-    }
-
-globalVar :: Name -> DsM (Core TH.Name)
--- Not bound by the meta-env
--- Could be top-level; or could be local
---      f x = $(g [| x |])
--- Here the x will be local
-globalVar name
-  | isExternalName name
-  = do  { MkC mod <- coreStringLit name_mod
-        ; MkC pkg <- coreStringLit name_pkg
-        ; MkC occ <- nameLit name
-        ; rep2_nwDsM mk_varg [pkg,mod,occ] }
-  | otherwise
-  = do  { MkC occ <- nameLit name
-        ; platform <- targetPlatform <$> getDynFlags
-        ; let uni = mkIntegerExpr platform (toInteger $ getKey (getUnique name))
-        ; rep2_nwDsM mkNameLName [occ,uni] }
-  where
-      mod = assert (isExternalName name) nameModule name
-      name_mod = moduleNameFS (moduleName mod)
-      name_pkg = unitFS (moduleUnit mod)
-      name_occ = nameOccName name
-      mk_varg | isDataOcc name_occ = mkNameG_dName
-              | isVarOcc  name_occ = mkNameG_vName
-              | isTcOcc   name_occ = mkNameG_tcName
-              | otherwise          = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name)
-
-lookupType :: Name      -- Name of type constructor (e.g. (M TH.Exp))
-           -> MetaM Type  -- The type
-lookupType tc_name = do { tc <- lift $ dsLookupTyCon tc_name ;
-                          return (mkTyConApp tc []) }
-
-wrapGenSyms :: [GenSymBind]
-            -> Core (M a) -> MetaM (Core (M a))
--- wrapGenSyms [(nm1,id1), (nm2,id2)] y
---      --> bindQ (gensym nm1) (\ id1 ->
---          bindQ (gensym nm2 (\ id2 ->
---          y))
-
-wrapGenSyms binds body@(MkC b)
-  = do  { var_ty <- lookupType nameTyConName
-        ; go var_ty binds }
-  where
-    (_, elt_ty) = tcSplitAppTy (exprType b)
-        -- b :: m a, so we can get the type 'a' by looking at the
-        -- argument type. Need to use `tcSplitAppTy` here as since
-        -- the overloaded quotations patch the type of the expression can
-        -- be something more complicated than just `Q a`.
-        -- See #17839 for when this went wrong with the type `WriterT () m a`
-
-    go _ [] = return body
-    go var_ty ((name,id) : binds)
-      = do { MkC body'  <- go var_ty binds
-           ; lit_str    <- lift $ nameLit name
-           ; gensym_app <- repGensym lit_str
-           ; repBindM var_ty elt_ty
-                      gensym_app (MkC (Lam id body')) }
-
-nameLit :: Name -> DsM (Core String)
-nameLit n = coreStringLit (occNameFS (nameOccName n))
-
-occNameLit :: OccName -> MetaM (Core String)
-occNameLit name = coreStringLit (occNameFS name)
-
-
--- %*********************************************************************
--- %*                                                                   *
---              Constructing code
--- %*                                                                   *
--- %*********************************************************************
-
------------------------------------------------------------------------------
--- PHANTOM TYPES for consistency. In order to make sure we do this correct
--- we invent a new datatype which uses phantom types.
-
-newtype Core a = MkC CoreExpr
-unC :: Core a -> CoreExpr
-unC (MkC x) = x
-
-type family NotM a where
-  NotM (M _) = TypeError ('Text ("rep2_nw must not produce something of overloaded type"))
-  NotM _other = (() :: Constraint)
-
-rep2M :: Name -> [CoreExpr] -> MetaM (Core (M a))
-rep2 :: Name -> [CoreExpr] -> MetaM (Core (M a))
-rep2_nw :: NotM a => Name -> [CoreExpr] -> MetaM (Core a)
-rep2_nwDsM :: NotM a => Name -> [CoreExpr] -> DsM (Core a)
-rep2 = rep2X lift (asks quoteWrapper)
-rep2M = rep2X lift (asks monadWrapper)
-rep2_nw n xs = lift (rep2_nwDsM n xs)
-rep2_nwDsM = rep2X id (return id)
-
-rep2X :: Monad m => (forall z . DsM z -> m z)
-      -> m (CoreExpr -> CoreExpr)
-      -> Name
-      -> [ CoreExpr ]
-      -> m (Core a)
-rep2X lift_dsm get_wrap n xs = do
-  { rep_id <- lift_dsm $ dsLookupGlobalId n
-  ; wrap <- get_wrap
-  ; return (MkC $ (foldl' App (wrap (Var rep_id)) xs)) }
-
-
-dataCon' :: Name -> [CoreExpr] -> MetaM (Core a)
-dataCon' n args = do { id <- lift $ dsLookupDataCon n
-                     ; return $ MkC $ mkCoreConApps id args }
-
-dataCon :: Name -> MetaM (Core a)
-dataCon n = dataCon' n []
-
-
--- %*********************************************************************
--- %*                                                                   *
---              The 'smart constructors'
--- %*                                                                   *
--- %*********************************************************************
-
---------------- Patterns -----------------
-repPlit   :: Core TH.Lit -> MetaM (Core (M TH.Pat))
-repPlit (MkC l) = rep2 litPName [l]
-
-repPvar :: Core TH.Name -> MetaM (Core (M TH.Pat))
-repPvar (MkC s) = rep2 varPName [s]
-
-repPtup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
-repPtup (MkC ps) = rep2 tupPName [ps]
-
-repPunboxedTup :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
-repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
-
-repPunboxedSum :: Core (M TH.Pat) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Pat))
--- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
-repPunboxedSum (MkC p) alt arity
- = do { platform <- getPlatform
-      ; rep2 unboxedSumPName [ p
-                             , mkIntExprInt platform alt
-                             , mkIntExprInt platform arity ] }
-
-repPcon   :: Core TH.Name -> Core [(M TH.Type)] -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
-repPcon (MkC s) (MkC ts) (MkC ps) = rep2 conPName [s, ts, ps]
-
-repPrec   :: Core TH.Name -> Core [M (TH.Name, TH.Pat)] -> MetaM (Core (M TH.Pat))
-repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
-
-repPinfix :: Core (M TH.Pat) -> Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
-repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
-
-repPtilde :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
-repPtilde (MkC p) = rep2 tildePName [p]
-
-repPbang :: Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
-repPbang (MkC p) = rep2 bangPName [p]
-
-repPaspat :: Core TH.Name -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
-repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
-
-repPwild  :: MetaM (Core (M TH.Pat))
-repPwild = rep2 wildPName []
-
-repPlist :: Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))
-repPlist (MkC ps) = rep2 listPName [ps]
-
-repPview :: Core (M TH.Exp) -> Core (M TH.Pat) -> MetaM (Core (M TH.Pat))
-repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
-
-repPsig :: Core (M TH.Pat) -> Core (M TH.Type) -> MetaM (Core (M TH.Pat))
-repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
-
---------------- Expressions -----------------
-repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp))
-repVarOrCon vc str
-    | isVarNameSpace ns = repVar str  -- Both type and term variables (#18740)
-    | otherwise         = repCon str
-  where
-    ns = nameNameSpace vc
-
-repVar :: Core TH.Name -> MetaM (Core (M TH.Exp))
-repVar (MkC s) = rep2 varEName [s]
-
-repCon :: Core TH.Name -> MetaM (Core (M TH.Exp))
-repCon (MkC s) = rep2 conEName [s]
-
-repLit :: Core TH.Lit -> MetaM (Core (M TH.Exp))
-repLit (MkC c) = rep2 litEName [c]
-
-repApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repApp (MkC x) (MkC y) = rep2 appEName [x,y]
-
-repAppType :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp))
-repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]
-
-repLam :: Core [(M TH.Pat)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
-
-repLamCase :: Core [(M TH.Match)] -> MetaM (Core (M TH.Exp))
-repLamCase (MkC ms) = rep2 lamCaseEName [ms]
-
-repLamCases :: Core [(M TH.Clause)] -> MetaM (Core (M TH.Exp))
-repLamCases (MkC ms) = rep2 lamCasesEName [ms]
-
-repTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp))
-repTup (MkC es) = rep2 tupEName [es]
-
-repUnboxedTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp))
-repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
-
-repUnboxedSum :: Core (M TH.Exp) -> TH.SumAlt -> TH.SumArity -> MetaM (Core (M TH.Exp))
--- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
-repUnboxedSum (MkC e) alt arity
- = do { platform <- getPlatform
-      ; rep2 unboxedSumEName [ e
-                             , mkIntExprInt platform alt
-                             , mkIntExprInt platform arity ] }
-
-repCond :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
-
-repMultiIf :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Exp))
-repMultiIf (MkC alts) = rep2 multiIfEName [alts]
-
-repLetE :: Core [(M TH.Dec)] -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
-
-repCaseE :: Core (M TH.Exp) -> Core [(M TH.Match)] -> MetaM (Core (M TH.Exp))
-repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
-
-repDoE :: Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
-repDoE = repDoBlock doEName
-
-repMDoE :: Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
-repMDoE = repDoBlock mdoEName
-
-repDoBlock :: Name -> Maybe ModuleName -> Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
-repDoBlock doName maybeModName (MkC ss) = do
-    MkC coreModName <- coreModNameM
-    rep2 doName [coreModName, ss]
-  where
-    coreModNameM :: MetaM (Core (Maybe TH.ModName))
-    coreModNameM = case maybeModName of
-      Just m -> do
-        MkC s <- coreStringLit (moduleNameFS m)
-        mName <- rep2_nw mkModNameName [s]
-        coreJust modNameTyConName mName
-      _ -> coreNothing modNameTyConName
-
-repComp :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Exp))
-repComp (MkC ss) = rep2 compEName [ss]
-
-repListExp :: Core [(M TH.Exp)] -> MetaM (Core (M TH.Exp))
-repListExp (MkC es) = rep2 listEName [es]
-
-repSigExp :: Core (M TH.Exp) -> Core (M TH.Type) -> MetaM (Core (M TH.Exp))
-repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
-
-repRecCon :: Core TH.Name -> Core [M TH.FieldExp]-> MetaM (Core (M TH.Exp))
-repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
-
-repRecUpd :: Core (M TH.Exp) -> Core [M TH.FieldExp] -> MetaM (Core (M TH.Exp))
-repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
-
-repFieldExp :: Core TH.Name -> Core (M TH.Exp) -> MetaM (Core (M TH.FieldExp))
-repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
-
-repInfixApp :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
-
-repSectionL :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
-
-repSectionR :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
-
-repImplicitParamVar :: Core String -> MetaM (Core (M TH.Exp))
-repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]
-
------------- Right hand sides (guarded expressions) ----
-repGuarded :: Core [M (TH.Guard, TH.Exp)] -> MetaM (Core (M TH.Body))
-repGuarded (MkC pairs) = rep2 guardedBName [pairs]
-
-repNormal :: Core (M TH.Exp) -> MetaM (Core (M TH.Body))
-repNormal (MkC e) = rep2 normalBName [e]
-
------------- Guards ----
-repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn
-             -> MetaM (Core (M (TH.Guard, TH.Exp)))
-repLNormalGE g e = do g' <- repLE g
-                      e' <- repLE e
-                      repNormalGE g' e'
-
-repNormalGE :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp)))
-repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
-
-repPatGE :: Core [(M TH.Stmt)] -> Core (M TH.Exp) -> MetaM (Core (M (TH.Guard, TH.Exp)))
-repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
-
-------------- Stmts -------------------
-repBindSt :: Core (M TH.Pat) -> Core (M TH.Exp) -> MetaM (Core (M TH.Stmt))
-repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
-
-repLetSt :: Core [(M TH.Dec)] -> MetaM (Core (M TH.Stmt))
-repLetSt (MkC ds) = rep2 letSName [ds]
-
-repNoBindSt :: Core (M TH.Exp) -> MetaM (Core (M TH.Stmt))
-repNoBindSt (MkC e) = rep2 noBindSName [e]
-
-repParSt :: Core [[(M TH.Stmt)]] -> MetaM (Core (M TH.Stmt))
-repParSt (MkC sss) = rep2 parSName [sss]
-
-repRecSt :: Core [(M TH.Stmt)] -> MetaM (Core (M TH.Stmt))
-repRecSt (MkC ss) = rep2 recSName [ss]
-
--------------- Range (Arithmetic sequences) -----------
-repFrom :: Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repFrom (MkC x) = rep2 fromEName [x]
-
-repFromThen :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
-
-repFromTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
-
-repFromThenTo :: Core (M TH.Exp) -> Core (M TH.Exp) -> Core (M TH.Exp) -> MetaM (Core (M TH.Exp))
-repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
-
------------- Match and Clause Tuples -----------
-repMatch :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Match))
-repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
-
-repClause :: Core [(M TH.Pat)] -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Clause))
-repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
-
--------------- Dec -----------------------------
-repVal :: Core (M TH.Pat) -> Core (M TH.Body) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec))
-repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
-
-repFun :: Core TH.Name -> Core [(M TH.Clause)] -> MetaM (Core (M TH.Dec))
-repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
-
-repData :: Core (M TH.Cxt) -> Core TH.Name
-        -> Either (Core [(M (TH.TyVarBndr ()))])
-                  (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type))
-        -> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause]
-        -> MetaM (Core (M TH.Dec))
-repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)
-  = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
-repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)
-        (MkC derivs)
-  = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs]
-
-repNewtype :: Core (M TH.Cxt) -> Core TH.Name
-           -> Either (Core [(M (TH.TyVarBndr ()))])
-                     (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type))
-           -> Core (Maybe (M TH.Kind)) -> Core (M TH.Con) -> Core [M TH.DerivClause]
-           -> MetaM (Core (M TH.Dec))
-repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)
-           (MkC derivs)
-  = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
-repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con)
-           (MkC derivs)
-  = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs]
-
-repTySyn :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))]
-         -> Core (M TH.Type) -> MetaM (Core (M TH.Dec))
-repTySyn (MkC nm) (MkC tvs) (MkC rhs)
-  = rep2 tySynDName [nm, tvs, rhs]
-
-repInst :: Core (Maybe TH.Overlap) ->
-           Core (M TH.Cxt) -> Core (M TH.Type) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec))
-repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
-                                                              [o, cxt, ty, ds]
-
-repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
-                 -> (Core (Maybe (M TH.DerivStrategy)) -> MetaM (Core (M a)))
-                 -> MetaM (Core (M a))
-repDerivStrategy mds thing_inside =
-  case mds of
-    Nothing -> thing_inside =<< nothing
-    Just ds ->
-      case unLoc ds of
-        StockStrategy    _ -> thing_inside =<< just =<< repStockStrategy
-        AnyclassStrategy _ -> thing_inside =<< just =<< repAnyclassStrategy
-        NewtypeStrategy  _ -> thing_inside =<< just =<< repNewtypeStrategy
-        ViaStrategy ty     -> addSimpleTyVarBinds (get_scoped_tvs_from_sig ty) $
-                              do ty' <- rep_ty_sig' ty
-                                 via_strat <- repViaStrategy ty'
-                                 m_via_strat <- just via_strat
-                                 thing_inside m_via_strat
-  where
-  nothing = coreNothingM derivStrategyTyConName
-  just    = coreJustM    derivStrategyTyConName
-
-repStockStrategy :: MetaM (Core (M TH.DerivStrategy))
-repStockStrategy = rep2 stockStrategyName []
-
-repAnyclassStrategy :: MetaM (Core (M TH.DerivStrategy))
-repAnyclassStrategy = rep2 anyclassStrategyName []
-
-repNewtypeStrategy :: MetaM (Core (M TH.DerivStrategy))
-repNewtypeStrategy = rep2 newtypeStrategyName []
-
-repViaStrategy :: Core (M TH.Type) -> MetaM (Core (M TH.DerivStrategy))
-repViaStrategy (MkC t) = rep2 viaStrategyName [t]
-
-repOverlap :: Maybe OverlapMode -> MetaM (Core (Maybe TH.Overlap))
-repOverlap mb =
-  case mb of
-    Nothing -> nothing
-    Just o ->
-      case o of
-        NoOverlap _    -> nothing
-        Overlappable _ -> just =<< dataCon overlappableDataConName
-        Overlapping _  -> just =<< dataCon overlappingDataConName
-        Overlaps _     -> just =<< dataCon overlapsDataConName
-        Incoherent _   -> just =<< dataCon incoherentDataConName
-  where
-  nothing = coreNothing overlapTyConName
-  just    = coreJust overlapTyConName
-
-
-repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M (TH.TyVarBndr ()))]
-         -> Core [TH.FunDep] -> Core [(M TH.Dec)]
-         -> MetaM (Core (M TH.Dec))
-repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
-  = rep2 classDName [cxt, cls, tvs, fds, ds]
-
-repDeriv :: Core (Maybe (M TH.DerivStrategy))
-         -> Core (M TH.Cxt) -> Core (M TH.Type)
-         -> MetaM (Core (M TH.Dec))
-repDeriv (MkC ds) (MkC cxt) (MkC ty)
-  = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
-
-repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
-           -> Core TH.Phases -> MetaM (Core (M TH.Dec))
-repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
-  = rep2 pragInlDName [nm, inline, rm, phases]
-
-repPragOpaque :: Core TH.Name -> MetaM (Core (M TH.Dec))
-repPragOpaque (MkC nm) = rep2 pragOpaqueDName [nm]
-
-repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases
-            -> MetaM (Core (M TH.Dec))
-repPragSpec (MkC nm) (MkC ty) (MkC phases)
-  = rep2 pragSpecDName [nm, ty, phases]
-
-repPragSpecInl :: Core TH.Name -> Core (M TH.Type) -> Core TH.Inline
-               -> Core TH.Phases -> MetaM (Core (M TH.Dec))
-repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
-  = rep2 pragSpecInlDName [nm, ty, inline, phases]
-
-repPragSpecInst :: Core (M TH.Type) -> MetaM (Core (M TH.Dec))
-repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
-
-repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> MetaM (Core (M TH.Dec))
-repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
-
-repPragRule :: Core String -> Core (Maybe [(M (TH.TyVarBndr ()))])
-            -> Core [(M TH.RuleBndr)] -> Core (M TH.Exp) -> Core (M TH.Exp)
-            -> Core TH.Phases -> MetaM (Core (M TH.Dec))
-repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases)
-  = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases]
-
-repPragAnn :: Core TH.AnnTarget -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec))
-repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
-
-repTySynInst :: Core (M TH.TySynEqn) -> MetaM (Core (M TH.Dec))
-repTySynInst (MkC eqn)
-    = rep2 tySynInstDName [eqn]
-
-repDataFamilyD :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))]
-               -> Core (Maybe (M TH.Kind)) -> MetaM (Core (M TH.Dec))
-repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
-    = rep2 dataFamilyDName [nm, tvs, kind]
-
-repOpenFamilyD :: Core TH.Name
-               -> Core [(M (TH.TyVarBndr ()))]
-               -> Core (M TH.FamilyResultSig)
-               -> Core (Maybe TH.InjectivityAnn)
-               -> MetaM (Core (M TH.Dec))
-repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
-    = rep2 openTypeFamilyDName [nm, tvs, result, inj]
-
-repClosedFamilyD :: Core TH.Name
-                 -> Core [(M (TH.TyVarBndr ()))]
-                 -> Core (M TH.FamilyResultSig)
-                 -> Core (Maybe TH.InjectivityAnn)
-                 -> Core [(M TH.TySynEqn)]
-                 -> MetaM (Core (M TH.Dec))
-repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
-    = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
-
-repTySynEqn :: Core (Maybe [(M (TH.TyVarBndr ()))]) ->
-               Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.TySynEqn))
-repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)
-  = rep2 tySynEqnName [mb_bndrs, lhs, rhs]
-
-repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> MetaM (Core (M TH.Dec))
-repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
-
-repFunDep :: Core [TH.Name] -> Core [TH.Name] -> MetaM (Core TH.FunDep)
-repFunDep (MkC xs) (MkC ys) = rep2_nw funDepName [xs, ys]
-
-repProto :: Name -> Core TH.Name -> Core (M TH.Type) -> MetaM (Core (M TH.Dec))
-repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
-
-repImplicitParamBind :: Core String -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec))
-repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
-
-repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt))
-repCtxt (MkC tys) = rep2 cxtName [tys]
-
-repH98DataCon :: LocatedN Name
-              -> HsConDeclH98Details GhcRn
-              -> MetaM (Core (M TH.Con))
-repH98DataCon con details
-    = do con' <- lookupLOcc con -- See Note [Binders and occurrences]
-         case details of
-           PrefixCon _ ps -> do
-             arg_tys <- repPrefixConArgs ps
-             rep2 normalCName [unC con', unC arg_tys]
-           InfixCon st1 st2 -> do
-             verifyLinearFields [st1, st2]
-             arg1 <- repBangTy (hsScaledThing st1)
-             arg2 <- repBangTy (hsScaledThing st2)
-             rep2 infixCName [unC arg1, unC con', unC arg2]
-           RecCon ips -> do
-             arg_vtys <- repRecConArgs ips
-             rep2 recCName [unC con', unC arg_vtys]
-
-repGadtDataCons :: NonEmpty (LocatedN Name)
-                -> HsConDeclGADTDetails GhcRn
-                -> LHsType GhcRn
-                -> MetaM (Core (M TH.Con))
-repGadtDataCons cons details res_ty
-    = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
-         case details of
-           PrefixConGADT ps -> do
-             arg_tys <- repPrefixConArgs ps
-             res_ty' <- repLTy res_ty
-             rep2 gadtCName [ unC (nonEmptyCoreList' cons'), unC arg_tys, unC res_ty']
-           RecConGADT ips _ -> do
-             arg_vtys <- repRecConArgs ips
-             res_ty'  <- repLTy res_ty
-             rep2 recGadtCName [unC (nonEmptyCoreList' cons'), unC arg_vtys,
-                                unC res_ty']
-
--- TH currently only supports linear constructors.
--- We also accept the (->) arrow when -XLinearTypes is off, because this
--- denotes a linear field.
--- This check is not performed in repRecConArgs, since the GADT record
--- syntax currently does not have a way to mark fields as nonlinear.
-verifyLinearFields :: [HsScaled GhcRn (LHsType GhcRn)] -> MetaM ()
-verifyLinearFields ps = do
-  linear <- lift $ xoptM LangExt.LinearTypes
-  let allGood = all (\st -> case hsMult st of
-                              HsUnrestrictedArrow _ -> not linear
-                              HsLinearArrow _       -> True
-                              _                     -> False) ps
-  unless allGood $ notHandled ThNonLinearDataCon
-
--- Desugar the arguments in a data constructor declared with prefix syntax.
-repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)]
-                 -> MetaM (Core [M TH.BangType])
-repPrefixConArgs ps = do
-  verifyLinearFields ps
-  repListM bangTypeTyConName repBangTy (map hsScaledThing ps)
-
--- Desugar the arguments in a data constructor declared with record syntax.
-repRecConArgs :: LocatedL [LConDeclField GhcRn]
-              -> MetaM (Core [M TH.VarBangType])
-repRecConArgs ips = do
-  args     <- concatMapM rep_ip (unLoc ips)
-  coreListM varBangTypeTyConName args
-    where
-      rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
-
-      rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> MetaM (Core (M TH.VarBangType))
-      rep_one_ip t n = do { MkC v  <- lookupOcc (foExt $ unLoc n)
-                          ; MkC ty <- repBangTy  t
-                          ; rep2 varBangTypeName [v,ty] }
-
------------- Types -------------------
-
-repTForall :: Core [(M (TH.TyVarBndr TH.Specificity))] -> Core (M TH.Cxt) -> Core (M TH.Type)
-           -> MetaM (Core (M TH.Type))
-repTForall (MkC tvars) (MkC ctxt) (MkC ty)
-    = rep2 forallTName [tvars, ctxt, ty]
-
-repTForallVis :: Core [(M (TH.TyVarBndr ()))] -> Core (M TH.Type)
-              -> MetaM (Core (M TH.Type))
-repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty]
-
-repTvar :: Core TH.Name -> MetaM (Core (M TH.Type))
-repTvar (MkC s) = rep2 varTName [s]
-
-repTapp :: Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.Type))
-repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
-
-repTappKind :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type))
-repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki]
-
-repTapps :: Core (M TH.Type) -> [Core (M TH.Type)] -> MetaM (Core (M TH.Type))
-repTapps f []     = return f
-repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
-
-repTSig :: Core (M TH.Type) -> Core (M TH.Kind) -> MetaM (Core (M TH.Type))
-repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
-
-repTequality :: MetaM (Core (M TH.Type))
-repTequality = rep2 equalityTName []
-
-repTPromotedList :: [Core (M TH.Type)] -> MetaM (Core (M TH.Type))
-repTPromotedList []     = repPromotedNilTyCon
-repTPromotedList (t:ts) = do  { tcon <- repPromotedConsTyCon
-                              ; f <- repTapp tcon t
-                              ; t' <- repTPromotedList ts
-                              ; repTapp f t'
-                              }
-
-repTLit :: Core (M TH.TyLit) -> MetaM (Core (M TH.Type))
-repTLit (MkC lit) = rep2 litTName [lit]
-
-repTWildCard :: MetaM (Core (M TH.Type))
-repTWildCard = rep2 wildCardTName []
-
-repTImplicitParam :: Core String -> Core (M TH.Type) -> MetaM (Core (M TH.Type))
-repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]
-
-repTStar :: MetaM (Core (M TH.Type))
-repTStar = rep2 starKName []
-
-repTConstraint :: MetaM (Core (M TH.Type))
-repTConstraint = rep2 constraintKName []
-
---------- Type constructors --------------
-
-repNamedTyCon :: Core TH.Name -> MetaM (Core (M TH.Type))
-repNamedTyCon (MkC s) = rep2 conTName [s]
-
-repTInfix :: Core (M TH.Type) -> Core TH.Name -> Core (M TH.Type)
-             -> MetaM (Core (M TH.Type))
-repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2]
-
-repTupleTyCon :: Int -> MetaM (Core (M TH.Type))
--- Note: not Core Int; it's easier to be direct here
-repTupleTyCon i = do platform <- getPlatform
-                     rep2 tupleTName [mkIntExprInt platform i]
-
-repUnboxedTupleTyCon :: Int -> MetaM (Core (M TH.Type))
--- Note: not Core Int; it's easier to be direct here
-repUnboxedTupleTyCon i = do platform <- getPlatform
-                            rep2 unboxedTupleTName [mkIntExprInt platform i]
-
-repUnboxedSumTyCon :: TH.SumArity -> MetaM (Core (M TH.Type))
--- Note: not Core TH.SumArity; it's easier to be direct here
-repUnboxedSumTyCon arity = do platform <- getPlatform
-                              rep2 unboxedSumTName [mkIntExprInt platform arity]
-
-repArrowTyCon :: MetaM (Core (M TH.Type))
-repArrowTyCon = rep2 arrowTName []
-
-repMulArrowTyCon :: MetaM (Core (M TH.Type))
-repMulArrowTyCon = rep2 mulArrowTName []
-
-repListTyCon :: MetaM (Core (M TH.Type))
-repListTyCon = rep2 listTName []
-
-repPromotedDataCon :: Core TH.Name -> MetaM (Core (M TH.Type))
-repPromotedDataCon (MkC s) = rep2 promotedTName [s]
-
-repPromotedTupleTyCon :: Int -> MetaM (Core (M TH.Type))
-repPromotedTupleTyCon i = do platform <- getPlatform
-                             rep2 promotedTupleTName [mkIntExprInt platform i]
-
-repPromotedNilTyCon :: MetaM (Core (M TH.Type))
-repPromotedNilTyCon = rep2 promotedNilTName []
-
-repPromotedConsTyCon :: MetaM (Core (M TH.Type))
-repPromotedConsTyCon = rep2 promotedConsTName []
-
-----------------------------------------------------------
---       Type family result signature
-
-repNoSig :: MetaM (Core (M TH.FamilyResultSig))
-repNoSig = rep2 noSigName []
-
-repKindSig :: Core (M TH.Kind) -> MetaM (Core (M TH.FamilyResultSig))
-repKindSig (MkC ki) = rep2 kindSigName [ki]
-
-repTyVarSig :: Core (M (TH.TyVarBndr ())) -> MetaM (Core (M TH.FamilyResultSig))
-repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
-
-----------------------------------------------------------
---              Literals
-
-repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit)
-repLiteral (HsStringPrim _ bs)
-  = do word8_ty <- lookupType word8TyConName
-       let w8s = unpack bs
-           w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
-                                  [mkWord8Lit (toInteger w8)]) w8s
-       rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr]
-repLiteral lit
-  = do lit' <- case lit of
-                   HsIntPrim _ i    -> mk_integer i
-                   HsWordPrim _ w   -> mk_integer w
-                   HsInt _ i        -> mk_integer (il_value i)
-                   HsFloatPrim _ r  -> mk_rational r
-                   HsDoublePrim _ r -> mk_rational r
-                   HsCharPrim _ c   -> mk_char c
-                   _ -> return lit
-       lit_expr <- lift $ dsLit lit'
-       case mb_lit_name of
-          Just lit_name -> rep2_nw lit_name [lit_expr]
-          Nothing -> notHandled (ThExoticLiteral lit)
-  where
-    mb_lit_name = case lit of
-                 HsInteger _ _ _  -> Just integerLName
-                 HsInt _ _        -> Just integerLName
-                 HsIntPrim _ _    -> Just intPrimLName
-                 HsWordPrim _ _   -> Just wordPrimLName
-                 HsFloatPrim _ _  -> Just floatPrimLName
-                 HsDoublePrim _ _ -> Just doublePrimLName
-                 HsChar _ _       -> Just charLName
-                 HsCharPrim _ _   -> Just charPrimLName
-                 HsString _ _     -> Just stringLName
-                 HsRat _ _ _      -> Just rationalLName
-                 _                -> Nothing
-
-mk_integer :: Integer -> MetaM (HsLit GhcRn)
-mk_integer  i = return $ HsInteger NoSourceText i integerTy
-
-mk_rational :: FractionalLit -> MetaM (HsLit GhcRn)
-mk_rational r = do rat_ty <- lookupType rationalTyConName
-                   return $ HsRat noExtField r rat_ty
-mk_string :: FastString -> MetaM (HsLit GhcRn)
-mk_string s = return $ HsString NoSourceText s
-
-mk_char :: Char -> MetaM (HsLit GhcRn)
-mk_char c = return $ HsChar NoSourceText c
-
-repOverloadedLiteral :: HsOverLit GhcRn -> MetaM (Core TH.Lit)
-repOverloadedLiteral (OverLit { ol_val = val})
-  = do { lit <- mk_lit val; repLiteral lit }
-        -- The type Rational will be in the environment, because
-        -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
-        -- and rationalL is sucked in when any TH stuff is used
-
-mk_lit :: OverLitVal -> MetaM (HsLit GhcRn)
-mk_lit (HsIntegral i)     = mk_integer  (il_value i)
-mk_lit (HsFractional f)   = mk_rational f
-mk_lit (HsIsString _ s)   = mk_string   s
-
-repNameS :: Core String -> MetaM (Core TH.Name)
-repNameS (MkC name) = rep2_nw mkNameSName [name]
-
---------------- Miscellaneous -------------------
-
-repGensym :: Core String -> MetaM (Core (M TH.Name))
-repGensym (MkC lit_str) = rep2 newNameName [lit_str]
-
-repBindM :: Type -> Type        -- a and b
-         -> Core (M a) -> Core (a -> M b) -> MetaM (Core (M b))
-repBindM ty_a ty_b (MkC x) (MkC y)
-  = rep2M bindMName [Type ty_a, Type ty_b, x, y]
-
-repSequenceM :: Type -> Core [M a] -> MetaM (Core (M [a]))
-repSequenceM ty_a (MkC list)
-  = rep2M sequenceQName [Type ty_a, list]
-
-repUnboundVar :: Core TH.Name -> MetaM (Core (M TH.Exp))
-repUnboundVar (MkC name) = rep2 unboundVarEName [name]
-
-repOverLabel :: FastString -> MetaM (Core (M TH.Exp))
-repOverLabel fs = do
-                    MkC s <- coreStringLit fs
-                    rep2 labelEName [s]
-
-repGetField :: Core (M TH.Exp) -> FastString -> MetaM (Core (M TH.Exp))
-repGetField (MkC exp) fs = do
-  MkC s <- coreStringLit fs
-  rep2 getFieldEName [exp,s]
-
-repProjection :: NonEmpty FastString -> MetaM (Core (M TH.Exp))
-repProjection fs = do
-  ne_tycon <- lift $ dsLookupTyCon nonEmptyTyConName
-  MkC xs <- coreListNonEmpty ne_tycon stringTy <$>
-            mapM coreStringLit fs
-  rep2 projectionEName [xs]
-
------------- Lists -------------------
--- turn a list of patterns into a single pattern matching a list
-
-repList :: Name -> (a  -> MetaM (Core b))
-                    -> [a] -> MetaM (Core [b])
-repList tc_name f args
-  = do { args1 <- mapM f args
-       ; coreList tc_name args1 }
-
--- Create a list of m a values
-repListM :: Name -> (a  -> MetaM (Core b))
-                    -> [a] -> MetaM (Core [b])
-repListM tc_name f args
-  = do { ty <- wrapName tc_name
-       ; args1 <- mapM f args
-       ; return $ coreList' ty args1 }
-
-coreListM :: Name -> [Core a] -> MetaM (Core [a])
-coreListM tc as = repListM tc return as
-
-coreList :: Name    -- Of the TyCon of the element type
-         -> [Core a] -> MetaM (Core [a])
-coreList tc_name es
-  = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
-
-coreList' :: Type       -- The element type
-          -> [Core a] -> Core [a]
-coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
-
-coreListNonEmpty :: TyCon -- TyCon for NonEmpty
-                 -> Type  -- Element type
-                 -> NonEmpty (Core a)
-                 -> Core (NonEmpty a)
-coreListNonEmpty ne_tc ty (MkC x :| xs)
-  = MkC $ mkCoreConApps (tyConSingleDataCon ne_tc)
-          [Type ty, x, mkListExpr ty (map unC xs)]
-
-nonEmptyCoreList :: [Core a] -> Core [a]
-  -- The list must be non-empty so we can get the element type
-  -- Otherwise use coreList
-nonEmptyCoreList []           = panic "coreList: empty argument"
-nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
-
-nonEmptyCoreList' :: NonEmpty (Core a) -> Core [a]
-nonEmptyCoreList' xs@(MkC x:|_) = MkC (mkListExpr (exprType x) (toList $ fmap unC xs))
-
-coreStringLit :: MonadThings m => FastString -> m (Core String)
-coreStringLit s = do { z <- mkStringExprFS s; return (MkC z) }
-
-------------------- Maybe ------------------
-
-repMaybe :: Name -> (a -> MetaM (Core b))
-                    -> Maybe a -> MetaM (Core (Maybe b))
-repMaybe tc_name f m = do
-  t <- lookupType tc_name
-  repMaybeT t f m
-
-repMaybeT :: Type -> (a -> MetaM (Core b))
-                    -> Maybe a -> MetaM (Core (Maybe b))
-repMaybeT ty _ Nothing   = return $ coreNothing' ty
-repMaybeT ty f (Just es) = coreJust' ty <$> f es
-
--- | Construct Core expression for Nothing of a given type name
-coreNothing :: Name        -- ^ Name of the TyCon of the element type
-            -> MetaM (Core (Maybe a))
-coreNothing tc_name =
-    do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }
-
-coreNothingM :: Name -> MetaM (Core (Maybe a))
-coreNothingM tc_name =
-    do { elt_ty <- wrapName tc_name; return (coreNothing' elt_ty) }
-
--- | Construct Core expression for Nothing of a given type
-coreNothing' :: Type       -- ^ The element type
-             -> Core (Maybe a)
-coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)
-
--- | Store given Core expression in a Just of a given type name
-coreJust :: Name        -- ^ Name of the TyCon of the element type
-         -> Core a -> MetaM (Core (Maybe a))
-coreJust tc_name es
-  = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }
-
-coreJustM :: Name -> Core a -> MetaM (Core (Maybe a))
-coreJustM tc_name es = do { elt_ty <- wrapName tc_name; return (coreJust' elt_ty es) }
-
--- | Store given Core expression in a Just of a given type
-coreJust' :: Type       -- ^ The element type
-          -> Core a -> Core (Maybe a)
-coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
-
-------------------- Maybe Lists ------------------
-
-coreJustList :: Type -> Core [a] -> Core (Maybe [a])
-coreJustList elt_ty = coreJust' (mkListTy elt_ty)
-
-coreNothingList :: Type -> Core (Maybe [a])
-coreNothingList elt_ty = coreNothing' (mkListTy elt_ty)
-
------------- Literals & Variables -------------------
-
-coreIntLit :: Int -> MetaM (Core Int)
-coreIntLit i = do platform <- getPlatform
-                  return (MkC (mkIntExprInt platform i))
-
-coreVar :: Id -> Core TH.Name   -- The Id has type Name
-coreVar id = MkC (Var id)
-
------------------ Failure -----------------------
-notHandledL :: SrcSpan -> ThRejectionReason -> MetaM a
-notHandledL loc reason
-  | isGoodSrcSpan loc
-  = mapReaderT (putSrcSpanDs loc) $ notHandled reason
-  | otherwise
-  = notHandled reason
-
-notHandled :: ThRejectionReason -> MetaM a
-notHandled reason = lift $ failWithDs (DsNotYetHandledByTH reason)
diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Ticks.hs
+++ /dev/null
@@ -1,1249 +0,0 @@
-{-# LANGUAGE DeriveFunctor            #-}
-{-# LANGUAGE NondecreasingIndentation #-}
-{-# LANGUAGE TypeFamilies             #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
-{-
-(c) Galois, 2006
-(c) University of Glasgow, 2007
--}
-
-module GHC.HsToCore.Ticks
-  ( TicksConfig (..)
-  , Tick (..)
-  , TickishType (..)
-  , addTicksToBinds
-  , isGoodSrcSpan'
-  , stripTicksTopHsExpr
-  ) where
-
-import GHC.Prelude as Prelude
-
-import GHC.Hs
-import GHC.Unit
-
-import GHC.Core.Type
-import GHC.Core.TyCon
-
-import GHC.Data.Maybe
-import GHC.Data.FastString
-import GHC.Data.Bag
-import GHC.Data.SizedSeq
-
-import GHC.Driver.Flags (DumpFlag(..))
-
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Logger
-import GHC.Types.SrcLoc
-import GHC.Types.Basic
-import GHC.Types.Id
-import GHC.Types.Var.Set
-import GHC.Types.Name.Set hiding (FreeVars)
-import GHC.Types.Name
-import GHC.Types.CostCentre
-import GHC.Types.CostCentre.State
-import GHC.Types.Tickish
-import GHC.Types.ProfAuto
-
-import Control.Monad
-import Data.List (isSuffixOf, intersperse)
-
-import Trace.Hpc.Mix
-
-import Data.Bifunctor (second)
-import Data.Set (Set)
-import qualified Data.Set as Set
-
-{-
-************************************************************************
-*                                                                      *
-*              The main function: addTicksToBinds
-*                                                                      *
-************************************************************************
--}
-
--- | Configuration for compilation pass to add tick for instrumentation
--- to binding sites.
-data TicksConfig = TicksConfig
-  { ticks_passes       :: ![TickishType]
-  -- ^ What purposes do we need ticks for
-
-  , ticks_profAuto     :: !ProfAuto
-  -- ^ What kind of {-# SCC #-} to add automatically
-
-  , ticks_countEntries :: !Bool
-  -- ^ Whether to count the entries to functions
-  --
-  -- Requires extra synchronization which can vastly degrade
-  -- performance.
-  }
-
-data Tick = Tick
-  { tick_loc   :: SrcSpan   -- ^ Tick source span
-  , tick_path  :: [String]  -- ^ Path to the declaration
-  , tick_ids   :: [OccName] -- ^ Identifiers being bound
-  , tick_label :: BoxLabel  -- ^ Label for the tick counter
-  }
-
-
-addTicksToBinds
-        :: Logger
-        -> TicksConfig
-        -> Module
-        -> ModLocation          -- ^ location of the current module
-        -> NameSet              -- ^ Exported Ids.  When we call addTicksToBinds,
-                                -- isExportedId doesn't work yet (the desugarer
-                                -- hasn't set it), so we have to work from this set.
-        -> [TyCon]              -- ^ Type constructors in this module
-        -> LHsBinds GhcTc
-        -> IO (LHsBinds GhcTc, Maybe (FilePath, SizedSeq Tick))
-
-addTicksToBinds logger cfg
-                mod mod_loc exports tyCons binds
-  | let passes = ticks_passes cfg
-  , not (null passes)
-  , Just orig_file <- ml_hs_file mod_loc = do
-
-     let  orig_file2 = guessSourceFile binds orig_file
-
-          tickPass tickish (binds,st) =
-            let env = TTE
-                      { fileName     = mkFastString orig_file2
-                      , declPath     = []
-                      , tte_countEntries = ticks_countEntries cfg
-                      , exports      = exports
-                      , inlines      = emptyVarSet
-                      , inScope      = emptyVarSet
-                      , blackList    = Set.fromList $
-                                       mapMaybe (\tyCon -> case getSrcSpan (tyConName tyCon) of
-                                                             RealSrcSpan l _ -> Just l
-                                                             UnhelpfulSpan _ -> Nothing)
-                                                tyCons
-                      , density      = mkDensity tickish $ ticks_profAuto cfg
-                      , this_mod     = mod
-                      , tickishType  = tickish
-                      }
-                (binds',_,st') = unTM (addTickLHsBinds binds) env st
-            in (binds', st')
-
-          (binds1,st) = foldr tickPass (binds, initTTState) passes
-
-          extendedMixEntries = ticks st
-
-     putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell
-       (pprLHsBinds binds1)
-
-     return (binds1, Just (orig_file2, extendedMixEntries))
-
-  | otherwise = return (binds, Nothing)
-
-guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath
-guessSourceFile binds orig_file =
-     -- Try look for a file generated from a .hsc file to a
-     -- .hs file, by peeking ahead.
-     let top_pos = catMaybes $ foldr (\ (L pos _) rest ->
-                               srcSpanFileName_maybe (locA pos) : rest) [] binds
-     in
-     case top_pos of
-        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name
-                      -> unpackFS file_name
-        _ -> orig_file
-
-
--- -----------------------------------------------------------------------------
--- TickDensity
-
--- | Where to insert ticks
-data TickDensity
-  = TickForCoverage       -- ^ for Hpc
-  | TickForBreakPoints    -- ^ for GHCi
-  | TickAllFunctions      -- ^ for -prof-auto-all
-  | TickTopFunctions      -- ^ for -prof-auto-top
-  | TickExportedFunctions -- ^ for -prof-auto-exported
-  | TickCallSites         -- ^ for stack tracing
-  deriving Eq
-
-mkDensity :: TickishType -> ProfAuto -> TickDensity
-mkDensity tickish pa = case tickish of
-  HpcTicks             -> TickForCoverage
-  SourceNotes          -> TickForCoverage
-  Breakpoints          -> TickForBreakPoints
-  ProfNotes ->
-    case pa of
-      ProfAutoAll      -> TickAllFunctions
-      ProfAutoTop      -> TickTopFunctions
-      ProfAutoExports  -> TickExportedFunctions
-      ProfAutoCalls    -> TickCallSites
-      _other           -> panic "mkDensity"
-
--- | Decide whether to add a tick to a binding or not.
-shouldTickBind  :: TickDensity
-                -> Bool         -- ^ top level?
-                -> Bool         -- ^ exported?
-                -> Bool         -- ^ simple pat bind?
-                -> Bool         -- ^ INLINE pragma?
-                -> Bool
-
-shouldTickBind density top_lev exported _simple_pat inline
- = case density of
-      TickForBreakPoints    -> False
-        -- we never add breakpoints to simple pattern bindings
-        -- (there's always a tick on the rhs anyway).
-      TickAllFunctions      -> not inline
-      TickTopFunctions      -> top_lev && not inline
-      TickExportedFunctions -> exported && not inline
-      TickForCoverage       -> True
-      TickCallSites         -> False
-
-shouldTickPatBind :: TickDensity -> Bool -> Bool
-shouldTickPatBind density top_lev
-  = case density of
-      TickForBreakPoints    -> False
-      TickAllFunctions      -> True
-      TickTopFunctions      -> top_lev
-      TickExportedFunctions -> False
-      TickForCoverage       -> False
-      TickCallSites         -> False
-
--- Strip ticks HsExpr
-
--- | Strip CoreTicks from an HsExpr
-stripTicksTopHsExpr :: HsExpr GhcTc -> ([CoreTickish], HsExpr GhcTc)
-stripTicksTopHsExpr (XExpr (HsTick t e)) = let (ts, body) = stripTicksTopHsExpr (unLoc e)
-                                            in (t:ts, body)
-stripTicksTopHsExpr e = ([], e)
-
--- -----------------------------------------------------------------------------
--- Adding ticks to bindings
-
-addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)
-addTickLHsBinds = mapBagM addTickLHsBind
-
-addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
-addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds
-                                                 , abs_exports = abs_exports
-                                                 }))) =
-  withEnv add_exports $
-    withEnv add_inlines $ do
-      binds' <- addTickLHsBinds binds
-      return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' }
-  where
-   -- in AbsBinds, the Id on each binding is not the actual top-level
-   -- Id that we are defining, they are related by the abs_exports
-   -- field of AbsBinds.  So if we're doing TickExportedFunctions we need
-   -- to add the local Ids to the set of exported Names so that we know to
-   -- tick the right bindings.
-   add_exports env =
-     env{ exports = exports env `extendNameSetList`
-                      [ idName mid
-                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
-                      , idName pid `elemNameSet` (exports env) ] }
-
-   -- See Note [inline sccs]
-   add_inlines env =
-     env{ inlines = inlines env `extendVarSetList`
-                      [ mid
-                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
-                      , isInlinePragma (idInlinePragma pid) ] }
-
-addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = do
-  let name = getOccString id
-  decl_path <- getPathEntry
-  density <- getDensity
-
-  inline_ids <- liftM inlines getEnv
-  -- See Note [inline sccs]
-  let inline   = isInlinePragma (idInlinePragma id)
-                 || id `elemVarSet` inline_ids
-
-  -- See Note [inline sccs]
-  tickish <- tickishType `liftM` getEnv
-  case tickish of { ProfNotes | inline -> return (L pos funBind); _ -> do
-
-  (fvs, mg) <-
-        getFreeVars $
-        addPathEntry name $
-        addTickMatchGroup False (fun_matches funBind)
-
-  blackListed <- isBlackListed (locA pos)
-  exported_names <- liftM exports getEnv
-
-  -- We don't want to generate code for blacklisted positions
-  -- We don't want redundant ticks on simple pattern bindings
-  -- We don't want to tick non-exported bindings in TickExportedFunctions
-  let simple = isSimplePatBind funBind
-      toplev = null decl_path
-      exported = idName id `elemNameSet` exported_names
-
-  tick <- if not blackListed &&
-               shouldTickBind density toplev exported simple inline
-             then
-                bindTick density name (locA pos) fvs
-             else
-                return Nothing
-
-  let mbCons = maybe Prelude.id (:)
-  return $ L pos $ funBind { fun_matches = mg
-                           , fun_ext = second (tick `mbCons`) (fun_ext funBind) }
-  }
-
-   where
-   -- a binding is a simple pattern binding if it is a funbind with
-   -- zero patterns
-   isSimplePatBind :: HsBind GhcTc -> Bool
-   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
-
--- TODO: Revisit this
-addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs
-                                    , pat_rhs = rhs }))) = do
-
-  let simplePatId = isSimplePat lhs
-
-  -- TODO: better name for rhs's for non-simple patterns?
-  let name = maybe "(...)" getOccString simplePatId
-
-  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
-  let pat' = pat { pat_rhs = rhs'}
-
-  -- Should create ticks here?
-  density <- getDensity
-  decl_path <- getPathEntry
-  let top_lev = null decl_path
-  if not (shouldTickPatBind density top_lev)
-    then return (L pos pat')
-    else do
-
-    let mbCons = maybe id (:)
-
-    let (initial_rhs_ticks, initial_patvar_tickss) = snd $ pat_ext pat'
-
-    -- Allocate the ticks
-
-    rhs_tick <- bindTick density name (locA pos) fvs
-    let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks
-
-    patvar_tickss <- case simplePatId of
-      Just{} -> return initial_patvar_tickss
-      Nothing -> do
-        let patvars = map getOccString (collectPatBinders CollNoDictBinders lhs)
-        patvar_ticks <- mapM (\v -> bindTick density v (locA pos) fvs) patvars
-        return
-          (zipWith mbCons patvar_ticks
-                          (initial_patvar_tickss ++ repeat []))
-
-    return $ L pos $ pat' { pat_ext = second (const (rhs_ticks, patvar_tickss)) (pat_ext pat') }
-
--- Only internal stuff, not from source, uses VarBind, so we ignore it.
-addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
-addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind
-
-bindTick
-  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish)
-bindTick density name pos fvs = do
-  decl_path <- getPathEntry
-  let
-      toplev        = null decl_path
-      count_entries = toplev || density == TickAllFunctions
-      top_only      = density /= TickAllFunctions
-      box_label     = if toplev then TopLevelBox [name]
-                                else LocalBox (decl_path ++ [name])
-  --
-  allocATickBox box_label count_entries top_only pos fvs
-
-
--- Note [inline sccs]
--- ~~~~~~~~~~~~~~~~~~
--- The reason not to add ticks to INLINE functions is that this is
--- sometimes handy for avoiding adding a tick to a particular function
--- (see #6131)
---
--- So for now we do not add any ticks to INLINE functions at all.
---
--- We used to use isAnyInlinePragma to figure out whether to avoid adding
--- ticks for this purpose. However, #12962 indicates that this contradicts
--- the documentation on profiling (which only mentions INLINE pragmas).
--- So now we're more careful about what we avoid adding ticks to.
-
--- -----------------------------------------------------------------------------
--- Decorate an LHsExpr with ticks
-
--- selectively add ticks to interesting expressions
-addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExpr e@(L pos e0) = do
-  d <- getDensity
-  case d of
-    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
-    TickForCoverage    -> tick_it
-    TickCallSites      | isCallSite e0      -> tick_it
-    _other             -> dont_tick_it
- where
-   tick_it      = allocTickBox (ExpBox False) False False (locA pos)
-                  $ addTickHsExpr e0
-   dont_tick_it = addTickLHsExprNever e
-
--- Add a tick to an expression which is the RHS of an equation or a binding.
--- We always consider these to be breakpoints, unless the expression is a 'let'
--- (because the body will definitely have a tick somewhere).  ToDo: perhaps
--- we should treat 'case' and 'if' the same way?
-addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprRHS e@(L pos e0) = do
-  d <- getDensity
-  case d of
-     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
-                        | otherwise     -> tick_it
-     TickForCoverage -> tick_it
-     TickCallSites   | isCallSite e0 -> tick_it
-     _other          -> dont_tick_it
- where
-   tick_it      = allocTickBox (ExpBox False) False False (locA pos)
-                  $ addTickHsExpr e0
-   dont_tick_it = addTickLHsExprNever e
-
--- The inner expression of an evaluation context:
---    let binds in [], ( [] )
--- we never tick these if we're doing HPC, but otherwise
--- we treat it like an ordinary expression.
-addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprEvalInner e = do
-   d <- getDensity
-   case d of
-     TickForCoverage -> addTickLHsExprNever e
-     _otherwise      -> addTickLHsExpr e
-
--- | A let body is treated differently from addTickLHsExprEvalInner
--- above with TickForBreakPoints, because for breakpoints we always
--- want to tick the body, even if it is not a redex.  See test
--- break012.  This gives the user the opportunity to inspect the
--- values of the let-bound variables.
-addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprLetBody e@(L pos e0) = do
-  d <- getDensity
-  case d of
-     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
-                        | otherwise     -> tick_it
-     _other -> addTickLHsExprEvalInner e
- where
-   tick_it      = allocTickBox (ExpBox False) False False (locA pos)
-                  $ addTickHsExpr e0
-   dont_tick_it = addTickLHsExprNever e
-
--- version of addTick that does not actually add a tick,
--- because the scope of this tick is completely subsumed by
--- another.
-addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprNever (L pos e0) = do
-    e1 <- addTickHsExpr e0
-    return $ L pos e1
-
--- General heuristic: expressions which are calls (do not denote
--- values) are good break points.
-isGoodBreakExpr :: HsExpr GhcTc -> Bool
-isGoodBreakExpr e = isCallSite e
-
-isCallSite :: HsExpr GhcTc -> Bool
-isCallSite HsApp{}     = True
-isCallSite HsAppType{} = True
-isCallSite (XExpr (ExpansionExpr (HsExpanded _ e)))
-                       = isCallSite e
--- NB: OpApp, SectionL, SectionR are all expanded out
-isCallSite _           = False
-
-addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickLHsExprOptAlt oneOfMany (L pos e0)
-  = ifDensity TickForCoverage
-        (allocTickBox (ExpBox oneOfMany) False False (locA pos)
-          $ addTickHsExpr e0)
-        (addTickLHsExpr (L pos e0))
-
-addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addBinTickLHsExpr boxLabel (L pos e0)
-  = ifDensity TickForCoverage
-        (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0)
-        (addTickLHsExpr (L pos e0))
-
-
--- -----------------------------------------------------------------------------
--- Decorate the body of an HsExpr with ticks.
--- (Whether to put a tick around the whole expression was already decided,
--- in the addTickLHsExpr family of functions.)
-
-addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
-addTickHsExpr e@(HsVar _ (L _ id))  = do freeVar id; return e
-addTickHsExpr e@(HsUnboundVar {})   = return e
-addTickHsExpr e@(HsRecSel _ (FieldOcc id _))   = do freeVar id; return e
-
-addTickHsExpr e@(HsIPVar {})            = return e
-addTickHsExpr e@(HsOverLit {})          = return e
-addTickHsExpr e@(HsOverLabel{})         = return e
-addTickHsExpr e@(HsLit {})              = return e
-addTickHsExpr (HsLam x mg)              = liftM (HsLam x)
-                                                (addTickMatchGroup True mg)
-addTickHsExpr (HsLamCase x lc_variant mgs) = liftM (HsLamCase x lc_variant)
-                                                   (addTickMatchGroup True mgs)
-addTickHsExpr (HsApp x e1 e2)          = liftM2 (HsApp x) (addTickLHsExprNever e1)
-                                                          (addTickLHsExpr      e2)
-addTickHsExpr (HsAppType x e at ty) = do
-        e' <- addTickLHsExprNever e
-        return (HsAppType x e' at ty)
-addTickHsExpr (OpApp fix e1 e2 e3) =
-        liftM4 OpApp
-                (return fix)
-                (addTickLHsExpr e1)
-                (addTickLHsExprNever e2)
-                (addTickLHsExpr e3)
-addTickHsExpr (NegApp x e neg) =
-        liftM2 (NegApp x)
-                (addTickLHsExpr e)
-                (addTickSyntaxExpr hpcSrcSpan neg)
-addTickHsExpr (HsPar x lpar e rpar) = do
-        e' <- addTickLHsExprEvalInner e
-        return (HsPar x lpar e' rpar)
-addTickHsExpr (SectionL x e1 e2) =
-        liftM2 (SectionL x)
-                (addTickLHsExpr e1)
-                (addTickLHsExprNever e2)
-addTickHsExpr (SectionR x e1 e2) =
-        liftM2 (SectionR x)
-                (addTickLHsExprNever e1)
-                (addTickLHsExpr e2)
-addTickHsExpr (ExplicitTuple x es boxity) =
-        liftM2 (ExplicitTuple x)
-                (mapM addTickTupArg es)
-                (return boxity)
-addTickHsExpr (ExplicitSum ty tag arity e) = do
-        e' <- addTickLHsExpr e
-        return (ExplicitSum ty tag arity e')
-addTickHsExpr (HsCase x e mgs) =
-        liftM2 (HsCase x)
-                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
-                                   -- be evaluated.
-                (addTickMatchGroup False mgs)
-addTickHsExpr (HsIf x e1 e2 e3) =
-        liftM3 (HsIf x)
-                (addBinTickLHsExpr (BinBox CondBinBox) e1)
-                (addTickLHsExprOptAlt True e2)
-                (addTickLHsExprOptAlt True e3)
-addTickHsExpr (HsMultiIf ty alts)
-  = do { let isOneOfMany = case alts of [_] -> False; _ -> True
-       ; alts' <- mapM (traverse $ addTickGRHS isOneOfMany False) alts
-       ; return $ HsMultiIf ty alts' }
-addTickHsExpr (HsLet x tkLet binds tkIn e) =
-        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do
-          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.
-          e' <- addTickLHsExprLetBody e
-          return (HsLet x tkLet binds' tkIn e')
-addTickHsExpr (HsDo srcloc cxt (L l stmts))
-  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
-       ; return (HsDo srcloc cxt (L l stmts')) }
-  where
-        forQual = case cxt of
-                    ListComp -> Just $ BinBox QualBinBox
-                    _        -> Nothing
-addTickHsExpr (ExplicitList ty es)
-  = liftM2 ExplicitList (return ty) (mapM (addTickLHsExpr) es)
-
-addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
-
-addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })
-  = do { rec_binds' <- addTickHsRecordBinds rec_binds
-       ; return (expr { rcon_flds = rec_binds' }) }
-
-addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Left flds })
-  = do { e' <- addTickLHsExpr e
-       ; flds' <- mapM addTickHsRecField flds
-       ; return (expr { rupd_expr = e', rupd_flds = Left flds' }) }
-addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Right flds })
-  = do { e' <- addTickLHsExpr e
-       ; flds' <- mapM addTickHsRecField flds
-       ; return (expr { rupd_expr = e', rupd_flds = Right flds' }) }
-
-addTickHsExpr (ExprWithTySig x e ty) =
-        liftM3 ExprWithTySig
-                (return x)
-                (addTickLHsExprNever e) -- No need to tick the inner expression
-                                        -- for expressions with signatures
-                (return ty)
-addTickHsExpr (ArithSeq ty wit arith_seq) =
-        liftM3 ArithSeq
-                (return ty)
-                (addTickWit wit)
-                (addTickArithSeqInfo arith_seq)
-             where addTickWit Nothing = return Nothing
-                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
-                                             return (Just fl')
-
-addTickHsExpr (HsPragE x p e) =
-        liftM (HsPragE x p) (addTickLHsExpr e)
-addTickHsExpr e@(HsTypedBracket {})  = return e
-addTickHsExpr e@(HsUntypedBracket{}) = return e
-addTickHsExpr e@(HsTypedSplice{})    = return e
-addTickHsExpr e@(HsUntypedSplice{})  = return e
-addTickHsExpr e@(HsGetField {})      = return e
-addTickHsExpr e@(HsProjection {})    = return e
-addTickHsExpr (HsProc x pat cmdtop) =
-        liftM2 (HsProc x)
-                (addTickLPat pat)
-                (traverse (addTickHsCmdTop) cmdtop)
-addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) =
-        liftM (XExpr . WrapExpr . HsWrap w) $
-              (addTickHsExpr e)        -- Explicitly no tick on inside
-addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) =
-        liftM (XExpr . ExpansionExpr . HsExpanded a) $
-              (addTickHsExpr b)
-
-addTickHsExpr e@(XExpr (ConLikeTc {})) = return e
-  -- We used to do a freeVar on a pat-syn builder, but actually
-  -- such builders are never in the inScope env, which
-  -- doesn't include top level bindings
-
--- We might encounter existing ticks (multiple Coverage passes)
-addTickHsExpr (XExpr (HsTick t e)) =
-        liftM (XExpr . HsTick t) (addTickLHsExprNever e)
-addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =
-        liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)
-
-addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)
-addTickTupArg (Present x e)  = do { e' <- addTickLHsExpr e
-                                  ; return (Present x e') }
-addTickTupArg (Missing ty) = return (Missing ty)
-
-
-addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
-                  -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
-addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
-  let isOneOfMany = matchesOneOfMany matches
-  matches' <- mapM (traverse (addTickMatch isOneOfMany is_lam)) matches
-  return $ mg { mg_alts = L l matches' }
-
-addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
-             -> TM (Match GhcTc (LHsExpr GhcTc))
-addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats
-                                               , m_grhss = gRHSs }) =
-  bindLocals (collectPatsBinders CollNoDictBinders pats) $ do
-    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
-    return $ match { m_grhss = gRHSs' }
-
-addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
-             -> TM (GRHSs GhcTc (LHsExpr GhcTc))
-addTickGRHSs isOneOfMany isLambda (GRHSs x guarded local_binds) =
-  bindLocals binders $ do
-    local_binds' <- addTickHsLocalBinds local_binds
-    guarded' <- mapM (traverse (addTickGRHS isOneOfMany isLambda)) guarded
-    return $ GRHSs x guarded' local_binds'
-  where
-    binders = collectLocalBinders CollNoDictBinders local_binds
-
-addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
-            -> TM (GRHS GhcTc (LHsExpr GhcTc))
-addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do
-  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
-                        (addTickGRHSBody isOneOfMany isLambda expr)
-  return $ GRHS x stmts' expr'
-
-addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTickGRHSBody isOneOfMany isLambda expr@(L pos e0) = do
-  d <- getDensity
-  case d of
-    TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr
-    TickAllFunctions | isLambda ->
-       addPathEntry "\\" $
-         allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $
-           addTickHsExpr e0
-    _otherwise ->
-       addTickLHsExprRHS expr
-
-addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]
-              -> TM [ExprLStmt GhcTc]
-addTickLStmts isGuard stmts = do
-  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
-  return stmts
-
-addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
-               -> TM ([ExprLStmt GhcTc], a)
-addTickLStmts' isGuard lstmts res
-  = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $
-    do { lstmts' <- mapM (traverse (addTickStmt isGuard)) lstmts
-       ; a <- res
-       ; return (lstmts', a) }
-
-addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)
-            -> TM (Stmt GhcTc (LHsExpr GhcTc))
-addTickStmt _isGuard (LastStmt x e noret ret) =
-        liftM3 (LastStmt x)
-                (addTickLHsExpr e)
-                (pure noret)
-                (addTickSyntaxExpr hpcSrcSpan ret)
-addTickStmt _isGuard (BindStmt xbs pat e) =
-        liftM4 (\b f -> BindStmt $ XBindStmtTc
-                    { xbstc_bindOp = b
-                    , xbstc_boundResultType = xbstc_boundResultType xbs
-                    , xbstc_boundResultMult = xbstc_boundResultMult xbs
-                    , xbstc_failOp = f
-                    })
-                (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs))
-                (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs))
-                (addTickLPat pat)
-                (addTickLHsExprRHS e)
-addTickStmt isGuard (BodyStmt x e bind' guard') =
-        liftM3 (BodyStmt x)
-                (addTick isGuard e)
-                (addTickSyntaxExpr hpcSrcSpan bind')
-                (addTickSyntaxExpr hpcSrcSpan guard')
-addTickStmt _isGuard (LetStmt x binds) =
-        liftM (LetStmt x)
-                (addTickHsLocalBinds binds)
-addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) =
-    liftM3 (ParStmt x)
-        (mapM (addTickStmtAndBinders isGuard) pairs)
-        (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) mzipExpr))
-        (addTickSyntaxExpr hpcSrcSpan bindExpr)
-addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do
-    args' <- mapM (addTickApplicativeArg isGuard) args
-    return (ApplicativeStmt body_ty args' mb_join)
-
-addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
-                                    , trS_by = by, trS_using = using
-                                    , trS_ret = returnExpr, trS_bind = bindExpr
-                                    , trS_fmap = liftMExpr }) = do
-    t_s <- addTickLStmts isGuard stmts
-    t_y <- traverse  addTickLHsExprRHS by
-    t_u <- addTickLHsExprRHS using
-    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
-    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
-    t_m <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) liftMExpr))
-    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
-                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
-
-addTickStmt isGuard stmt@(RecStmt {})
-  = do { stmts' <- addTickLStmts isGuard (unLoc $ recS_stmts stmt)
-       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
-       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
-       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
-       ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'
-                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
-
-addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
-addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
-                  | otherwise          = addTickLHsExprRHS e
-
-addTickApplicativeArg
-  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-addTickApplicativeArg isGuard (op, arg) =
-  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
- where
-  addTickArg (ApplicativeArgOne m_fail pat expr isBody) =
-    ApplicativeArgOne
-      <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail
-      <*> addTickLPat pat
-      <*> addTickLHsExpr expr
-      <*> pure isBody
-  addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =
-    (ApplicativeArgMany x)
-      <$> addTickLStmts isGuard stmts
-      <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret))
-      <*> addTickLPat pat
-      <*> pure ctxt
-
-addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
-                      -> TM (ParStmtBlock GhcTc GhcTc)
-addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
-    liftM3 (ParStmtBlock x)
-        (addTickLStmts isGuard stmts)
-        (return ids)
-        (addTickSyntaxExpr hpcSrcSpan returnExpr)
-
-addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
-addTickHsLocalBinds (HsValBinds x binds) =
-        liftM (HsValBinds x)
-                (addTickHsValBinds binds)
-addTickHsLocalBinds (HsIPBinds x binds)  =
-        liftM (HsIPBinds x)
-                (addTickHsIPBinds binds)
-addTickHsLocalBinds (EmptyLocalBinds x)  = return (EmptyLocalBinds x)
-
-addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
-                  -> TM (HsValBindsLR GhcTc (GhcPass b))
-addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
-        b <- liftM2 NValBinds
-                (mapM (\ (rec,binds') ->
-                                liftM2 (,)
-                                        (return rec)
-                                        (addTickLHsBinds binds'))
-                        binds)
-                (return sigs)
-        return $ XValBindsLR b
-addTickHsValBinds _ = panic "addTickHsValBinds"
-
-addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
-addTickHsIPBinds (IPBinds dictbinds ipbinds) =
-        liftM2 IPBinds
-                (return dictbinds)
-                (mapM (traverse (addTickIPBind)) ipbinds)
-
-addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
-addTickIPBind (IPBind x nm e) =
-        liftM (IPBind x nm)
-               (addTickLHsExpr e)
-
--- There is no location here, so we might need to use a context location??
-addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
-addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do
-        x' <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan pos) x))
-        return $ syn { syn_expr = x' }
-addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc
-
--- we do not walk into patterns.
-addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
-addTickLPat pat = return pat
-
-addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
-addTickHsCmdTop (HsCmdTop x cmd) =
-        liftM2 HsCmdTop
-                (return x)
-                (addTickLHsCmd cmd)
-
-addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)
-addTickLHsCmd (L pos c0) = do
-        c1 <- addTickHsCmd c0
-        return $ L pos c1
-
-addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
-addTickHsCmd (HsCmdLam x matchgroup) =
-        liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
-addTickHsCmd (HsCmdApp x c e) =
-        liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)
-{-
-addTickHsCmd (OpApp e1 c2 fix c3) =
-        liftM4 OpApp
-                (addTickLHsExpr e1)
-                (addTickLHsCmd c2)
-                (return fix)
-                (addTickLHsCmd c3)
--}
-addTickHsCmd (HsCmdPar x lpar e rpar) = do
-        e' <- addTickLHsCmd e
-        return (HsCmdPar x lpar e' rpar)
-addTickHsCmd (HsCmdCase x e mgs) =
-        liftM2 (HsCmdCase x)
-                (addTickLHsExpr e)
-                (addTickCmdMatchGroup mgs)
-addTickHsCmd (HsCmdLamCase x lc_variant mgs) =
-        liftM (HsCmdLamCase x lc_variant) (addTickCmdMatchGroup mgs)
-addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
-        liftM3 (HsCmdIf x cnd)
-                (addBinTickLHsExpr (BinBox CondBinBox) e1)
-                (addTickLHsCmd c2)
-                (addTickLHsCmd c3)
-addTickHsCmd (HsCmdLet x tkLet binds tkIn c) =
-        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do
-          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.
-          c' <- addTickLHsCmd c
-          return (HsCmdLet x tkLet binds' tkIn c')
-addTickHsCmd (HsCmdDo srcloc (L l stmts))
-  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
-       ; return (HsCmdDo srcloc (L l stmts')) }
-
-addTickHsCmd (HsCmdArrApp  arr_ty e1 e2 ty1 lr) =
-        liftM5 HsCmdArrApp
-               (return arr_ty)
-               (addTickLHsExpr e1)
-               (addTickLHsExpr e2)
-               (return ty1)
-               (return lr)
-addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
-        liftM4 (HsCmdArrForm x)
-               (addTickLHsExpr e)
-               (return f)
-               (return fix)
-               (mapM (traverse (addTickHsCmdTop)) cmdtop)
-
-addTickHsCmd (XCmd (HsWrap w cmd)) =
-  liftM XCmd $
-  liftM (HsWrap w) (addTickHsCmd cmd)
-
--- Others should never happen in a command context.
---addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
-
-addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
-                     -> TM (MatchGroup GhcTc (LHsCmd GhcTc))
-addTickCmdMatchGroup mg@(MG { mg_alts = (L l matches) }) = do
-  matches' <- mapM (traverse addTickCmdMatch) matches
-  return $ mg { mg_alts = L l matches' }
-
-addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
-addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
-  bindLocals (collectPatsBinders CollNoDictBinders pats) $ do
-    gRHSs' <- addTickCmdGRHSs gRHSs
-    return $ match { m_grhss = gRHSs' }
-
-addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
-addTickCmdGRHSs (GRHSs x guarded local_binds) =
-  bindLocals binders $ do
-    local_binds' <- addTickHsLocalBinds local_binds
-    guarded' <- mapM (traverse addTickCmdGRHS) guarded
-    return $ GRHSs x guarded' local_binds'
-  where
-    binders = collectLocalBinders CollNoDictBinders local_binds
-
-addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
--- The *guards* are *not* Cmds, although the body is
--- C.f. addTickGRHS for the BinBox stuff
-addTickCmdGRHS (GRHS x stmts cmd)
-  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
-                                   stmts (addTickLHsCmd cmd)
-       ; return $ GRHS x stmts' expr' }
-
-addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]
-                 -> TM [LStmt GhcTc (LHsCmd GhcTc)]
-addTickLCmdStmts stmts = do
-  (stmts, _) <- addTickLCmdStmts' stmts (return ())
-  return stmts
-
-addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a
-                  -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)
-addTickLCmdStmts' lstmts res
-  = bindLocals binders $ do
-        lstmts' <- mapM (traverse addTickCmdStmt) lstmts
-        a <- res
-        return (lstmts', a)
-  where
-        binders = collectLStmtsBinders CollNoDictBinders lstmts
-
-addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
-addTickCmdStmt (BindStmt x pat c) =
-        liftM2 (BindStmt x)
-                (addTickLPat pat)
-                (addTickLHsCmd c)
-addTickCmdStmt (LastStmt x c noret ret) =
-        liftM3 (LastStmt x)
-                (addTickLHsCmd c)
-                (pure noret)
-                (addTickSyntaxExpr hpcSrcSpan ret)
-addTickCmdStmt (BodyStmt x c bind' guard') =
-        liftM3 (BodyStmt x)
-                (addTickLHsCmd c)
-                (addTickSyntaxExpr hpcSrcSpan bind')
-                (addTickSyntaxExpr hpcSrcSpan guard')
-addTickCmdStmt (LetStmt x binds) =
-        liftM (LetStmt x)
-                (addTickHsLocalBinds binds)
-addTickCmdStmt stmt@(RecStmt {})
-  = do { stmts' <- addTickLCmdStmts (unLoc $ recS_stmts stmt)
-       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
-       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
-       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
-       ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'
-                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
-addTickCmdStmt ApplicativeStmt{} =
-  panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
-
--- Others should never happen in a command context.
-addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)
-
-addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)
-addTickHsRecordBinds (HsRecFields fields dd)
-  = do  { fields' <- mapM addTickHsRecField fields
-        ; return (HsRecFields fields' dd) }
-
-addTickHsRecField :: LHsFieldBind GhcTc id (LHsExpr GhcTc)
-                  -> TM (LHsFieldBind GhcTc id (LHsExpr GhcTc))
-addTickHsRecField (L l (HsFieldBind x id expr pun))
-        = do { expr' <- addTickLHsExpr expr
-             ; return (L l (HsFieldBind x id expr' pun)) }
-
-addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
-addTickArithSeqInfo (From e1) =
-        liftM From
-                (addTickLHsExpr e1)
-addTickArithSeqInfo (FromThen e1 e2) =
-        liftM2 FromThen
-                (addTickLHsExpr e1)
-                (addTickLHsExpr e2)
-addTickArithSeqInfo (FromTo e1 e2) =
-        liftM2 FromTo
-                (addTickLHsExpr e1)
-                (addTickLHsExpr e2)
-addTickArithSeqInfo (FromThenTo e1 e2 e3) =
-        liftM3 FromThenTo
-                (addTickLHsExpr e1)
-                (addTickLHsExpr e2)
-                (addTickLHsExpr e3)
-
-data TickTransState = TT { ticks       :: !(SizedSeq Tick)
-                         , ccIndices   :: !CostCentreState
-                         }
-
-initTTState :: TickTransState
-initTTState = TT { ticks        = emptySS
-                 , ccIndices    = newCostCentreState
-                 }
-
-addMixEntry :: Tick -> TM Int
-addMixEntry ent = do
-  c <- fromIntegral . sizeSS . ticks <$> getState
-  setState $ \st ->
-    st { ticks = addToSS (ticks st) ent
-       }
-  return c
-
-data TickTransEnv = TTE { fileName     :: FastString
-                        , density      :: TickDensity
-                        , tte_countEntries :: !Bool
-                          -- ^ Whether the number of times functions are
-                          -- entered should be counted.
-                        , exports      :: NameSet
-                        , inlines      :: VarSet
-                        , declPath     :: [String]
-                        , inScope      :: VarSet
-                        , blackList    :: Set RealSrcSpan
-                        , this_mod     :: Module
-                        , tickishType  :: TickishType
-                        }
-
---      deriving Show
-
--- | Reasons why we need ticks,
-data TickishType
-  -- | For profiling
-  = ProfNotes
-  -- | For Haskell Program Coverage
-  | HpcTicks
-  -- | For ByteCode interpreter break points
-  | Breakpoints
-  -- | For source notes
-  | SourceNotes
-  deriving (Eq)
-
--- | Tickishs that only make sense when their source code location
--- refers to the current file. This might not always be true due to
--- LINE pragmas in the code - which would confuse at least HPC.
-tickSameFileOnly :: TickishType -> Bool
-tickSameFileOnly HpcTicks = True
-tickSameFileOnly _other   = False
-
-type FreeVars = OccEnv Id
-noFVs :: FreeVars
-noFVs = emptyOccEnv
-
--- Note [freevars]
--- ~~~~~~~~~~~~~~~
---   For breakpoints we want to collect the free variables of an
---   expression for pinning on the HsTick.  We don't want to collect
---   *all* free variables though: in particular there's no point pinning
---   on free variables that are will otherwise be in scope at the GHCi
---   prompt, which means all top-level bindings.  Unfortunately detecting
---   top-level bindings isn't easy (collectHsBindsBinders on the top-level
---   bindings doesn't do it), so we keep track of a set of "in-scope"
---   variables in addition to the free variables, and the former is used
---   to filter additions to the latter.  This gives us complete control
---   over what free variables we track.
-
-newtype TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
-    deriving (Functor)
-        -- a combination of a state monad (TickTransState) and a writer
-        -- monad (FreeVars).
-
-instance Applicative TM where
-    pure a = TM $ \ _env st -> (a,noFVs,st)
-    (<*>) = ap
-
-instance Monad TM where
-  (TM m) >>= k = TM $ \ env st ->
-                                case m env st of
-                                  (r1,fv1,st1) ->
-                                     case unTM (k r1) env st1 of
-                                       (r2,fv2,st2) ->
-                                          (r2, fv1 `plusOccEnv` fv2, st2)
-
--- | Get the next HPC cost centre index for a given centre name
-getCCIndexM :: FastString -> TM CostCentreIndex
-getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $
-                                                 ccIndices st
-                              in (idx, noFVs, st { ccIndices = is' })
-
-getState :: TM TickTransState
-getState = TM $ \ _ st -> (st, noFVs, st)
-
-setState :: (TickTransState -> TickTransState) -> TM ()
-setState f = TM $ \ _ st -> ((), noFVs, f st)
-
-getEnv :: TM TickTransEnv
-getEnv = TM $ \ env st -> (env, noFVs, st)
-
-withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
-withEnv f (TM m) = TM $ \ env st ->
-                                 case m (f env) st of
-                                   (a, fvs, st') -> (a, fvs, st')
-
-getDensity :: TM TickDensity
-getDensity = TM $ \env st -> (density env, noFVs, st)
-
-ifDensity :: TickDensity -> TM a -> TM a -> TM a
-ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el
-
-getFreeVars :: TM a -> TM (FreeVars, a)
-getFreeVars (TM m)
-  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
-
-freeVar :: Id -> TM ()
-freeVar id = TM $ \ env st ->
-                if id `elemVarSet` inScope env
-                   then ((), unitOccEnv (nameOccName (idName id)) id, st)
-                   else ((), noFVs, st)
-
-addPathEntry :: String -> TM a -> TM a
-addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
-
-getPathEntry :: TM [String]
-getPathEntry = declPath `liftM` getEnv
-
-getFileName :: TM FastString
-getFileName = fileName `liftM` getEnv
-
-isGoodSrcSpan' :: SrcSpan -> Bool
-isGoodSrcSpan' pos@(RealSrcSpan _ _) = srcSpanStart pos /= srcSpanEnd pos
-isGoodSrcSpan' (UnhelpfulSpan _) = False
-
-isGoodTickSrcSpan :: SrcSpan -> TM Bool
-isGoodTickSrcSpan pos = do
-  file_name <- getFileName
-  tickish <- tickishType `liftM` getEnv
-  let need_same_file = tickSameFileOnly tickish
-      same_file      = Just file_name == srcSpanFileName_maybe pos
-  return (isGoodSrcSpan' pos && (not need_same_file || same_file))
-
-ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a
-ifGoodTickSrcSpan pos then_code else_code = do
-  good <- isGoodTickSrcSpan pos
-  if good then then_code else else_code
-
-bindLocals :: [Id] -> TM a -> TM a
-bindLocals new_ids (TM m)
-  = TM $ \ env st ->
-                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
-                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
-  where occs = [ nameOccName (idName id) | id <- new_ids ]
-
-isBlackListed :: SrcSpan -> TM Bool
-isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st)
-isBlackListed (UnhelpfulSpan _) = return False
-
--- the tick application inherits the source position of its
--- expression argument to support nested box allocations
-allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)
-             -> TM (LHsExpr GhcTc)
-allocTickBox boxLabel countEntries topOnly pos m =
-  ifGoodTickSrcSpan pos (do
-    (fvs, e) <- getFreeVars m
-    env <- getEnv
-    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
-    return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e))
-  ) (do
-    e <- m
-    return (L (noAnnSrcSpan pos) e)
-  )
-
--- the tick application inherits the source position of its
--- expression argument to support nested box allocations
-allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
-              -> TM (Maybe CoreTickish)
-allocATickBox boxLabel countEntries topOnly  pos fvs =
-  ifGoodTickSrcSpan pos (do
-    let
-      mydecl_path = case boxLabel of
-                      TopLevelBox x -> x
-                      LocalBox xs  -> xs
-                      _ -> panic "allocATickBox"
-    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path
-    return (Just tickish)
-  ) (return Nothing)
-
-
-mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
-          -> TM CoreTickish
-mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
-
-  let ids = filter (not . mightBeUnliftedType . idType) $ nonDetOccEnvElts fvs
-          -- unlifted types cause two problems here:
-          --   * we can't bind them  at the GHCi prompt
-          --     (bindLocalsAtBreakpoint already filters them out),
-          --   * the simplifier might try to substitute a literal for
-          --     the Id, and we can't handle that.
-
-      me = Tick
-        { tick_loc   = pos
-        , tick_path  = decl_path
-        , tick_ids   = map (nameOccName.idName) ids
-        , tick_label = boxLabel
-        }
-
-      cc_name | topOnly   = head decl_path
-              | otherwise = concat (intersperse "." decl_path)
-
-  env <- getEnv
-  case tickishType env of
-    HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me
-
-    ProfNotes -> do
-      let nm = mkFastString cc_name
-      flavour <- HpcCC <$> getCCIndexM nm
-      let cc = mkUserCC nm (this_mod env) pos flavour
-          count = countEntries && tte_countEntries env
-      return $ ProfNote cc count True{-scopes-}
-
-    Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids
-
-    SourceNotes | RealSrcSpan pos' _ <- pos ->
-      return $ SourceNote pos' cc_name
-
-    _otherwise -> panic "mkTickish: bad source span!"
-
-
-allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)
-                -> TM (LHsExpr GhcTc)
-allocBinTickBox boxLabel pos m = do
-  env <- getEnv
-  case tickishType env of
-    HpcTicks -> do e <- liftM (L (noAnnSrcSpan pos)) m
-                   ifGoodTickSrcSpan pos
-                     (mkBinTickBoxHpc boxLabel pos e)
-                     (return e)
-    _other   -> allocTickBox (ExpBox False) False False pos m
-
-mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc
-                -> TM (LHsExpr GhcTc)
-mkBinTickBoxHpc boxLabel pos e = do
-  env <- getEnv
-  binTick <- HsBinTick
-    <$> addMixEntry (Tick { tick_loc = pos
-                          , tick_path = declPath env
-                          , tick_ids = []
-                          , tick_label = boxLabel True
-                          })
-    <*> addMixEntry (Tick { tick_loc = pos
-                          , tick_path = declPath env
-                          , tick_ids = []
-                          , tick_label = boxLabel False
-                          })
-    <*> pure e
-  tick <- HpcTick (this_mod env)
-    <$> addMixEntry (Tick { tick_loc = pos
-                          , tick_path = declPath env
-                          , tick_ids = []
-                          , tick_label = ExpBox False
-                          })
-  let pos' = noAnnSrcSpan pos
-  return $ L pos' $ XExpr $ HsTick tick (L pos' (XExpr binTick))
-
-hpcSrcSpan :: SrcSpan
-hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
-
-matchesOneOfMany :: [LMatch GhcTc body] -> Bool
-matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
-  where
-        matchCount :: LMatch GhcTc body -> Int
-        matchCount (L _ (Match { m_grhss = GRHSs _ grhss _ }))
-          = length grhss
diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Types.hs
+++ /dev/null
@@ -1,94 +0,0 @@
-{-# LANGUAGE TypeFamilies, UndecidableInstances #-}
-
--- | Various types used during desugaring.
-module GHC.HsToCore.Types (
-        DsM, DsLclEnv(..), DsGblEnv(..),
-        DsMetaEnv, DsMetaVal(..), CompleteMatches
-    ) where
-
-import GHC.Prelude (Int)
-
-import Data.IORef
-
-import GHC.Types.CostCentre.State
-import GHC.Types.Error
-import GHC.Types.Name.Env
-import GHC.Types.SrcLoc
-import GHC.Types.Var
-import GHC.Types.Name.Reader (GlobalRdrEnv)
-import GHC.Hs (LForeignDecl, HsExpr, GhcTc)
-import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches)
-import GHC.HsToCore.Pmc.Types (Nablas)
-import GHC.HsToCore.Errors.Types
-import GHC.Core (CoreExpr)
-import GHC.Core.FamInstEnv
-import GHC.Utils.Outputable as Outputable
-import GHC.Unit.Module
-import GHC.Driver.Hooks (DsForeignsHook)
-import GHC.Data.OrdList (OrdList)
-import GHC.Types.ForeignStubs (ForeignStubs)
-
-{-
-************************************************************************
-*                                                                      *
-                Desugarer monad
-*                                                                      *
-************************************************************************
-
-Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
-a @UniqueSupply@ and some annotations, which
-presumably include source-file location information:
--}
-
--- | Global read-only context and state of the desugarer.
--- The statefulness is implemented through 'IORef's.
-data DsGblEnv
-  = DsGblEnv
-  { ds_mod          :: Module             -- For SCC profiling
-  , ds_fam_inst_env :: FamInstEnv         -- Like tcg_fam_inst_env
-  , ds_gbl_rdr_env  :: GlobalRdrEnv       -- needed *only* to know what newtype
-                                          -- constructors are in scope during
-                                          -- pattern-match satisfiability checking
-  , ds_name_ppr_ctx :: NamePprCtx
-  , ds_msgs    :: IORef (Messages DsMessage) -- Diagnostic messages
-  , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global,
-                                          -- possibly-imported things
-  , ds_complete_matches :: CompleteMatches
-     -- Additional complete pattern matches
-  , ds_cc_st   :: IORef CostCentreState
-     -- Tracking indices for cost centre annotations
-  , ds_next_wrapper_num :: IORef (ModuleEnv Int)
-    -- ^ See Note [Generating fresh names for FFI wrappers]
-  }
-
-instance ContainsModule DsGblEnv where
-  extractModule = ds_mod
-
--- | Local state of the desugarer, extended as we lexically descend
-data DsLclEnv
-  = DsLclEnv
-  { dsl_meta    :: DsMetaEnv   -- ^ Template Haskell bindings
-  , dsl_loc     :: RealSrcSpan -- ^ To put in pattern-matching error msgs
-  , dsl_nablas  :: Nablas
-  -- ^ See Note [Long-distance information] in "GHC.HsToCore.Pmc".
-  -- The set of reaching values Nablas is augmented as we walk inwards, refined
-  -- through each pattern match in turn
-  }
-
--- Inside [| |] brackets, the desugarer looks
--- up variables in the DsMetaEnv
-type DsMetaEnv = NameEnv DsMetaVal
-
-data DsMetaVal
-  = DsBound Id         -- Bound by a pattern inside the [| |].
-                       -- Will be dynamically alpha renamed.
-                       -- The Id has type THSyntax.Var
-
-  | DsSplice (HsExpr GhcTc) -- These bindings are introduced by
-                            -- the PendingSplices on a Hs*Bracket
-
--- | Desugaring monad. See also 'TcM'.
-type DsM = TcRnIf DsGblEnv DsLclEnv
-
--- See Note [The Decoupling Abstract Data Hack]
-type instance DsForeignsHook = [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr))
diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Usage.hs
+++ /dev/null
@@ -1,344 +0,0 @@
-
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module GHC.HsToCore.Usage (
-    -- * Dependency/fingerprinting code (used by GHC.Iface.Make)
-    mkUsageInfo, mkUsedNames,
-
-    UsageConfig(..),
-    ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Env
-
-import GHC.Tc.Types
-
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Fingerprint
-import GHC.Utils.Panic
-
-import GHC.Types.Name
-import GHC.Types.Name.Set ( NameSet, allUses )
-import GHC.Types.Unique.Set
-
-import GHC.Unit
-import GHC.Unit.Env
-import GHC.Unit.External
-import GHC.Unit.Module.Imported
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.Deps
-
-import GHC.Data.Maybe
-
-import Data.IORef
-import Data.List (sortBy)
-import Data.Map (Map)
-import qualified Data.Map as Map
-
-import GHC.Linker.Types
-import GHC.Unit.Finder
-import GHC.Types.Unique.DFM
-import GHC.Driver.Plugins
-
-{- Note [Module self-dependency]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-GHC.Rename.Names.calculateAvails asserts the invariant that a module must not occur in
-its own dep_orphs or dep_finsts. However, if we aren't careful this can occur
-in the presence of hs-boot files: Consider that we have two modules, A and B,
-both with hs-boot files,
-
-    A.hs contains a SOURCE import of B B.hs-boot contains a SOURCE import of A
-    A.hs-boot declares an orphan instance A.hs defines the orphan instance
-
-In this case, B's dep_orphs will contain A due to its SOURCE import of A.
-Consequently, A will contain itself in its imp_orphs due to its import of B.
-This fact would end up being recorded in A's interface file. This would then
-break the invariant asserted by calculateAvails that a module does not itself in
-its dep_orphs. This was the cause of #14128.
-
--}
-
-mkUsedNames :: TcGblEnv -> NameSet
-mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
-
-data UsageConfig = UsageConfig
-  { uc_safe_implicit_imps_req :: !Bool -- ^ Are all implicit imports required to be safe for this Safe Haskell mode?
-  }
-
-mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv -> Module -> ImportedMods -> NameSet -> [FilePath]
-            -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded -> IO [Usage]
-mkUsageInfo uc plugins fc unit_env this_mod dir_imp_mods used_names dependent_files merged needed_links needed_pkgs
-  = do
-    eps <- readIORef (euc_eps (ue_eps unit_env))
-    hashes <- mapM getFileHash dependent_files
-    let hu = unsafeGetHomeUnit unit_env
-        hug = ue_home_unit_graph unit_env
-    -- Dependencies on object files due to TH and plugins
-    object_usages <- mkObjectUsage (eps_PIT eps) plugins fc hug needed_links needed_pkgs
-    let mod_usages = mk_mod_usage_info (eps_PIT eps) uc hug hu this_mod
-                                       dir_imp_mods used_names
-        usages = mod_usages ++ [ UsageFile { usg_file_path = f
-                                           , usg_file_hash = hash
-                                           , usg_file_label = Nothing }
-                               | (f, hash) <- zip dependent_files hashes ]
-                            ++ [ UsageMergedRequirement
-                                    { usg_mod = mod,
-                                      usg_mod_hash = hash
-                                    }
-                               | (mod, hash) <- merged ]
-                            ++ object_usages
-    usages `seqList` return usages
-    -- seq the list of Usages returned: occasionally these
-    -- don't get evaluated for a while and we can end up hanging on to
-    -- the entire collection of Ifaces.
-
-{- Note [Plugin dependencies]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Modules for which plugins were used in the compilation process, should be
-recompiled whenever one of those plugins changes. But how do we know if a
-plugin changed from the previous time a module was compiled?
-
-We could try storing the fingerprints of the interface files of plugins in
-the interface file of the module. And see if there are changes between
-compilation runs. However, this is pretty much a non-option because interface
-fingerprints of plugin modules are fairly stable, unless you compile plugins
-with optimisations turned on, and give basically all binders an INLINE pragma.
-
-So instead:
-
-  * For plugins that were built locally: we store the filepath and hash of the
-    object files of the module with the `plugin` binder, and the object files of
-    modules that are dependencies of the plugin module and belong to the same
-    `UnitId` as the plugin
-  * For plugins in an external package: we store the filepath and hash of
-    the dynamic library containing the plugin module.
-
-During recompilation we then compare the hashes of those files again to see
-if anything has changed.
-
-One issue with this approach is that object files are currently (GHC 8.6.1)
-not created fully deterministically, which could sometimes induce accidental
-recompilation of a module for which plugins were used in the compile process.
-
-One way to improve this is to either:
-
-  * Have deterministic object file creation
-  * Create and store implementation hashes, which would be based on the Core
-    of the module and the implementation hashes of its dependencies, and then
-    compare implementation hashes for recompilation. Creation of implementation
-    hashes is however potentially expensive.
-
-    A serious issue with the interface hash idea is that if you include an
-    interface hash, that hash also needs to depend on the hash of its
-    dependencies. Therefore, if any of the transitive dependencies of a modules
-    gets updated then you need to recompile the module in case the interface
-    hash has changed irrespective if the module uses TH or not.
-
-    This is important to maintain the invariant that the information in the
-    interface file is always up-to-date.
-
-
-    See #20790 (comment 3)
--}
-
-{-
-Note [Object File Dependencies]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In addition to the Note [Plugin dependencies] above, for TH we also need to record
-the hashes of object files that the TH code is required to load. These are
-calculated by the loader in `getLinkDeps` and are accumulated in each individual
-`TcGblEnv`, in `tcg_th_needed_deps`. We read this just before compute the UsageInfo
-to inject the appropriate dependencies.
--}
-
--- | Find object files corresponding to the transitive closure of given home
--- modules and direct object files for pkg dependencies
-mkObjectUsage :: PackageIfaceTable -> Plugins -> FinderCache -> HomeUnitGraph-> [Linkable] -> PkgsLoaded -> IO [Usage]
-mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do
-      let ls = ordNubOn linkableModule  (th_links_needed ++ plugins_links_needed)
-          ds = concatMap loaded_pkg_hs_objs $ eltsUDFM (plusUDFM th_pkgs_needed plugin_pkgs_needed) -- TODO possibly record loaded_pkg_non_hs_objs as well
-          (plugins_links_needed, plugin_pkgs_needed) = loadedPluginDeps plugins
-      concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds)
-  where
-    linkableToUsage (LM _ m uls) = mapM (unlinkedToUsage m) uls
-
-    msg m = moduleNameString (moduleName m) ++ "[TH] changed"
-
-    fing mmsg fn = UsageFile fn <$> lookupFileCache fc fn <*> pure mmsg
-
-    unlinkedToUsage m ul =
-      case nameOfObject_maybe ul of
-        Just fn -> fing (Just (msg m)) fn
-        Nothing ->  do
-          -- This should only happen for home package things but oneshot puts
-          -- home package ifaces in the PIT.
-          let miface = lookupIfaceByModule hug pit m
-          case miface of
-            Nothing -> pprPanic "mkObjectUsage" (ppr m)
-            Just iface ->
-              return $ UsageHomeModuleInterface (moduleName m) (mi_iface_hash (mi_final_exts iface))
-
-    librarySpecToUsage :: LibrarySpec -> IO [Usage]
-    librarySpecToUsage (Objects os) = traverse (fing Nothing) os
-    librarySpecToUsage (Archive fn) = traverse (fing Nothing) [fn]
-    librarySpecToUsage (DLLPath fn) = traverse (fing Nothing) [fn]
-    librarySpecToUsage _ = return []
-
-mk_mod_usage_info :: PackageIfaceTable
-              -> UsageConfig
-              -> HomeUnitGraph
-              -> HomeUnit
-              -> Module
-              -> ImportedMods
-              -> NameSet
-              -> [Usage]
-mk_mod_usage_info pit uc hpt home_unit this_mod direct_imports used_names
-  = mapMaybe mkUsage usage_mods
-  where
-    safe_implicit_imps_req = uc_safe_implicit_imps_req uc
-
-    used_mods    = moduleEnvKeys ent_map
-    dir_imp_mods = moduleEnvKeys direct_imports
-    all_mods     = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
-    usage_mods   = sortBy stableModuleCmp all_mods
-                        -- canonical order is imported, to avoid interface-file
-                        -- wobblage.
-
-    -- ent_map groups together all the things imported and used
-    -- from a particular module
-    ent_map :: ModuleEnv [OccName]
-    ent_map  = nonDetStrictFoldUniqSet add_mv emptyModuleEnv used_names
-     -- nonDetStrictFoldUniqSet is OK here. If you follow the logic, we sort by
-     -- OccName in ent_hashs
-     where
-      add_mv name mv_map
-        | isWiredInName name = mv_map  -- ignore wired-in names
-        | otherwise
-        = case nameModule_maybe name of
-             Nothing  -> assertPpr (isSystemName name) (ppr name) mv_map
-                -- See Note [Internal used_names]
-
-             Just mod ->
-                -- See Note [Identity versus semantic module]
-                let mod' = if isHoleModule mod
-                            then mkHomeModule home_unit (moduleName mod)
-                            else mod
-                -- This lambda function is really just a
-                -- specialised (++); originally came about to
-                -- avoid quadratic behaviour (trac #2680)
-                in extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod' [occ]
-            where occ = nameOccName name
-
-    -- We want to create a Usage for a home module if
-    --  a) we used something from it; has something in used_names
-    --  b) we imported it, even if we used nothing from it
-    --     (need to recompile if its export list changes: export_fprint)
-    mkUsage :: Module -> Maybe Usage
-    mkUsage mod
-      | isNothing maybe_iface           -- We can't depend on it if we didn't
-                                        -- load its interface.
-      || mod == this_mod                -- We don't care about usages of
-                                        -- things in *this* module
-      = Nothing
-
-      | not (isHomeModule home_unit mod)
-      = Just UsagePackageModule{ usg_mod      = mod,
-                                 usg_mod_hash = mod_hash,
-                                 usg_safe     = imp_safe }
-        -- for package modules, we record the module hash only
-
-      | (null used_occs
-          && isNothing export_hash
-          && not is_direct_import
-          && not finsts_mod)
-      = Nothing                 -- Record no usage info
-        -- for directly-imported modules, we always want to record a usage
-        -- on the orphan hash.  This is what triggers a recompilation if
-        -- an orphan is added or removed somewhere below us in the future.
-
-      | otherwise
-      = Just UsageHomeModule {
-                      usg_mod_name = moduleName mod,
-                      usg_mod_hash = mod_hash,
-                      usg_exports  = export_hash,
-                      usg_entities = Map.toList ent_hashs,
-                      usg_safe     = imp_safe }
-      where
-        maybe_iface  = lookupIfaceByModule hpt pit mod
-                -- In one-shot mode, the interfaces for home-package
-                -- modules accumulate in the PIT not HPT.  Sigh.
-
-        Just iface   = maybe_iface
-        finsts_mod   = mi_finsts (mi_final_exts iface)
-        hash_env     = mi_hash_fn (mi_final_exts iface)
-        mod_hash     = mi_mod_hash (mi_final_exts iface)
-        export_hash | depend_on_exports = Just (mi_exp_hash (mi_final_exts iface))
-                    | otherwise         = Nothing
-
-        by_is_safe (ImportedByUser imv) = imv_is_safe imv
-        by_is_safe _ = False
-        (is_direct_import, imp_safe)
-            = case lookupModuleEnv direct_imports mod of
-                -- ezyang: I'm not sure if any is the correct
-                -- metric here. If safety was guaranteed to be uniform
-                -- across all imports, why did the old code only look
-                -- at the first import?
-                Just bys -> (True, any by_is_safe bys)
-                Nothing  -> (False, safe_implicit_imps_req)
-                -- Nothing case is for references to entities which were
-                -- not directly imported (NB: the "implicit" Prelude import
-                -- counts as directly imported!  An entity is not directly
-                -- imported if, e.g., we got a reference to it from a
-                -- reexport of another module.)
-
-        used_occs = lookupModuleEnv ent_map mod `orElse` []
-
-        -- Making a Map here ensures that (a) we remove duplicates
-        -- when we have usages on several subordinates of a single parent,
-        -- and (b) that the usages emerge in a canonical order, which
-        -- is why we use Map rather than OccEnv: Map works
-        -- using Ord on the OccNames, which is a lexicographic ordering.
-        ent_hashs :: Map OccName Fingerprint
-        ent_hashs = Map.fromList (map lookup_occ used_occs)
-
-        lookup_occ occ =
-            case hash_env occ of
-                Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
-                Just r  -> r
-
-        depend_on_exports = is_direct_import
-        {- True
-              Even if we used 'import M ()', we have to register a
-              usage on the export list because we are sensitive to
-              changes in orphan instances/rules.
-           False
-              In GHC 6.8.x we always returned true, and in
-              fact it recorded a dependency on *all* the
-              modules underneath in the dependency tree.  This
-              happens to make orphans work right, but is too
-              expensive: it'll read too many interface files.
-              The 'isNothing maybe_iface' check above saved us
-              from generating many of these usages (at least in
-              one-shot mode), but that's even more bogus!
-        -}
-
-{-
-Note [Internal used_names]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Most of the used_names are External Names, but we can have System
-Names too. Two examples:
-
-* Names arising from Language.Haskell.TH.newName.
-  See Note [Binders in Template Haskell] in GHC.ThToHs (and #5362).
-* The names of auxiliary bindings in derived instances.
-  See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
-
-Such Names are always for locally-defined things, for which we don't gather
-usage info, so we can just ignore them in ent_map. Moreover, they are always
-System Names, hence the assert, just as a double check.
--}
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ /dev/null
@@ -1,1092 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE TypeFamilies #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Utilities for desugaring
-
-This module exports some utility functions of no great interest.
--}
-
--- | Utility functions for constructing Core syntax, principally for desugaring
-module GHC.HsToCore.Utils (
-        EquationInfo(..),
-        firstPat, shiftEqns,
-
-        MatchResult (..), CaseAlt(..),
-        cantFailMatchResult, alwaysFailMatchResult,
-        extractMatchResult, combineMatchResults,
-        adjustMatchResultDs,
-        shareFailureHandler,
-        dsHandleMonadicFailure,
-        mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
-        matchCanFail, mkEvalMatchResult,
-        mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
-        wrapBind, wrapBinds,
-
-        mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,
-        mkFailExpr,
-
-        seqVar,
-
-        -- LHs tuples
-        mkLHsPatTup, mkVanillaTuplePat,
-        mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,
-
-        mkSelectorBinds,
-
-        selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
-        mkOptTickBox, mkBinaryTickBox, decideBangHood,
-        isTrueLHsExpr
-    ) where
-
-import GHC.Prelude
-
-import Language.Haskell.Syntax.Basic (Boxity(..))
-
-import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply )
-import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsLExpr, dsSyntaxExpr )
-
-import GHC.Hs
-import GHC.Hs.Syn.Type
-import GHC.Core
-import GHC.HsToCore.Monad
-
-import GHC.Core.Utils
-import GHC.Core.Make
-import GHC.Types.Id.Make
-import GHC.Types.Id
-import GHC.Types.Literal
-import GHC.Core.TyCon
-import GHC.Core.DataCon
-import GHC.Core.PatSyn
-import GHC.Core.Type
-import GHC.Core.Coercion
-import GHC.Builtin.Types
-import GHC.Core.ConLike
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.Supply
-import GHC.Unit.Module
-import GHC.Builtin.Names
-import GHC.Types.Name( isInternalName )
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Types.SrcLoc
-import GHC.Types.Tickish
-import GHC.Utils.Misc
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Data.FastString
-import qualified GHC.LanguageExtensions as LangExt
-
-import GHC.Tc.Types.Evidence
-
-import Control.Monad    ( zipWithM )
-import Data.List.NonEmpty (NonEmpty(..))
-import Data.Maybe (maybeToList)
-import qualified Data.List.NonEmpty as NEL
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{ Selecting match variables}
-*                                                                      *
-************************************************************************
-
-We're about to match against some patterns.  We want to make some
-@Ids@ to use as match variables.  If a pattern has an @Id@ readily at
-hand, which should indeed be bound to the pattern as a whole, then use it;
-otherwise, make one up. The multiplicity argument is chosen as the multiplicity
-of the variable if it is made up.
--}
-
-selectSimpleMatchVarL :: Mult -> LPat GhcTc -> DsM Id
--- Postcondition: the returned Id has an Internal Name
-selectSimpleMatchVarL w pat = selectMatchVar w (unLoc pat)
-
--- (selectMatchVars ps tys) chooses variables of type tys
--- to use for matching ps against.  If the pattern is a variable,
--- we try to use that, to save inventing lots of fresh variables.
---
--- OLD, but interesting note:
---    But even if it is a variable, its type might not match.  Consider
---      data T a where
---        T1 :: Int -> T Int
---        T2 :: a   -> T a
---
---      f :: T a -> a -> Int
---      f (T1 i) (x::Int) = x
---      f (T2 i) (y::a)   = 0
---    Then we must not choose (x::Int) as the matching variable!
--- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
-
-selectMatchVars :: [(Mult, Pat GhcTc)] -> DsM [Id]
--- Postcondition: the returned Ids have Internal Names
-selectMatchVars ps = mapM (uncurry selectMatchVar) ps
-
-selectMatchVar :: Mult -> Pat GhcTc -> DsM Id
--- Postcondition: the returned Id has an Internal Name
-selectMatchVar w (BangPat _ pat)    = selectMatchVar w (unLoc pat)
-selectMatchVar w (LazyPat _ pat)    = selectMatchVar w (unLoc pat)
-selectMatchVar w (ParPat _ _ pat _) = selectMatchVar w (unLoc pat)
-selectMatchVar _w (VarPat _ var)    = return (localiseId (unLoc var))
-                                  -- Note [Localise pattern binders]
-                                  --
-                                  -- Remark: when the pattern is a variable (or
-                                  -- an @-pattern), then w is the same as the
-                                  -- multiplicity stored within the variable
-                                  -- itself. It's easier to pull it from the
-                                  -- variable, so we ignore the multiplicity.
-selectMatchVar _w (AsPat _ var _ _) = assert (isManyTy _w ) (return (unLoc var))
-selectMatchVar w other_pat        = newSysLocalDs w (hsPatType other_pat)
-
-{- Note [Localise pattern binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider     module M where
-               [Just a] = e
-After renaming it looks like
-             module M where
-               [Just M.a] = e
-
-We don't generalise, since it's a pattern binding, monomorphic, etc,
-so after desugaring we may get something like
-             M.a = case e of (v:_) ->
-                   case v of Just M.a -> M.a
-Notice the "M.a" in the pattern; after all, it was in the original
-pattern.  However, after optimisation those pattern binders can become
-let-binders, and then end up floated to top level.  They have a
-different *unique* by then (the simplifier is good about maintaining
-proper scoping), but it's BAD to have two top-level bindings with the
-External Name M.a, because that turns into two linker symbols for M.a.
-It's quite rare for this to actually *happen* -- the only case I know
-of is tc003 compiled with the 'hpc' way -- but that only makes it
-all the more annoying.
-
-To avoid this, we craftily call 'localiseId' in the desugarer, which
-simply turns the External Name for the Id into an Internal one, but
-doesn't change the unique.  So the desugarer produces this:
-             M.a{r8} = case e of (v:_) ->
-                       case v of Just a{r8} -> M.a{r8}
-The unique is still 'r8', but the binding site in the pattern
-is now an Internal Name.  Now the simplifier's usual mechanisms
-will propagate that Name to all the occurrence sites, as well as
-un-shadowing it, so we'll get
-             M.a{r8} = case e of (v:_) ->
-                       case v of Just a{s77} -> a{s77}
-In fact, even GHC.Core.Subst.simplOptExpr will do this, and simpleOptExpr
-runs on the output of the desugarer, so all is well by the end of
-the desugaring pass.
-
-See also Note [Match Ids] in GHC.HsToCore.Match
-
-************************************************************************
-*                                                                      *
-* type synonym EquationInfo and access functions for its pieces        *
-*                                                                      *
-************************************************************************
-\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
-
-The ``equation info'' used by @match@ is relatively complicated and
-worthy of a type synonym and a few handy functions.
--}
-
-firstPat :: EquationInfo -> Pat GhcTc
-firstPat eqn = assert (notNull (eqn_pats eqn)) $ head (eqn_pats eqn)
-
-shiftEqns :: Functor f => f EquationInfo -> f EquationInfo
--- Drop the first pattern in each equation
-shiftEqns = fmap $ \eqn -> eqn { eqn_pats = tail (eqn_pats eqn) }
-
--- Functions on MatchResult CoreExprs
-
-matchCanFail :: MatchResult a -> Bool
-matchCanFail (MR_Fallible {})  = True
-matchCanFail (MR_Infallible {}) = False
-
-alwaysFailMatchResult :: MatchResult CoreExpr
-alwaysFailMatchResult = MR_Fallible $ \fail -> return fail
-
-cantFailMatchResult :: CoreExpr -> MatchResult CoreExpr
-cantFailMatchResult expr = MR_Infallible $ return expr
-
-extractMatchResult :: MatchResult CoreExpr -> CoreExpr -> DsM CoreExpr
-extractMatchResult match_result failure_expr =
-  runMatchResult
-    failure_expr
-    (shareFailureHandler match_result)
-
-combineMatchResults :: MatchResult CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
-combineMatchResults match_result1@(MR_Infallible _) _
-  = match_result1
-combineMatchResults match_result1 match_result2 =
-  -- if the first pattern needs a failure handler (i.e. if it is fallible),
-  -- make it let-bind it bind it with `shareFailureHandler`.
-  case shareFailureHandler match_result1 of
-    MR_Infallible _ -> match_result1
-    MR_Fallible body_fn1 -> MR_Fallible $ \fail_expr ->
-      -- Before actually failing, try the next match arm.
-      body_fn1 =<< runMatchResult fail_expr match_result2
-
-adjustMatchResultDs :: (a -> DsM b) -> MatchResult a -> MatchResult b
-adjustMatchResultDs encl_fn = \case
-  MR_Infallible body_fn -> MR_Infallible $
-    encl_fn =<< body_fn
-  MR_Fallible body_fn -> MR_Fallible $ \fail ->
-    encl_fn =<< body_fn fail
-
-wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
-wrapBinds [] e = e
-wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
-
-wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
-wrapBind new old body   -- NB: this function must deal with term
-  | new==old    = body  -- variables, type variables or coercion variables
-  | otherwise   = Let (NonRec new (varToCoreExpr old)) body
-
-seqVar :: Var -> CoreExpr -> CoreExpr
-seqVar var body = mkDefaultCase (Var var) var body
-
-mkCoLetMatchResult :: CoreBind -> MatchResult CoreExpr -> MatchResult CoreExpr
-mkCoLetMatchResult bind = fmap (mkCoreLet bind)
-
--- (mkViewMatchResult var' viewExpr mr) makes the expression
--- let var' = viewExpr in mr
-mkViewMatchResult :: Id -> CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
-mkViewMatchResult var' viewExpr = fmap $ mkCoreLet $ NonRec var' viewExpr
-
-mkEvalMatchResult :: Id -> Type -> MatchResult CoreExpr -> MatchResult CoreExpr
-mkEvalMatchResult var ty = fmap $ \e ->
-  Case (Var var) var ty [Alt DEFAULT [] e]
-
-mkGuardedMatchResult :: CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr
-mkGuardedMatchResult pred_expr mr = MR_Fallible $ \fail -> do
-  body <- runMatchResult fail mr
-  return (mkIfThenElse pred_expr body fail)
-
-mkCoPrimCaseMatchResult :: Id                  -- Scrutinee
-                        -> Type                      -- Type of the case
-                        -> [(Literal, MatchResult CoreExpr)]  -- Alternatives
-                        -> MatchResult CoreExpr               -- Literals are all unlifted
-mkCoPrimCaseMatchResult var ty match_alts
-  = MR_Fallible mk_case
-  where
-    mk_case fail = do
-        alts <- mapM (mk_alt fail) sorted_alts
-        return (Case (Var var) var ty (Alt DEFAULT [] fail : alts))
-
-    sorted_alts = sortWith fst match_alts       -- Right order for a Case
-    mk_alt fail (lit, mr)
-       = assert (not (litIsLifted lit)) $
-         do body <- runMatchResult fail mr
-            return (Alt (LitAlt lit) [] body)
-
-data CaseAlt a = MkCaseAlt{ alt_pat :: a,
-                            alt_bndrs :: [Var],
-                            alt_wrapper :: HsWrapper,
-                            alt_result :: MatchResult CoreExpr }
-
-mkCoAlgCaseMatchResult
-  :: Id -- ^ Scrutinee
-  -> Type -- ^ Type of exp
-  -> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts)
-  -> MatchResult CoreExpr
-mkCoAlgCaseMatchResult var ty match_alts
-  | isNewtype  -- Newtype case; use a let
-  = assert (null match_alts_tail && null (tail arg_ids1)) $
-    mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
-
-  | otherwise
-  = mkDataConCase var ty match_alts
-  where
-    isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))
-
-        -- [Interesting: because of GADTs, we can't rely on the type of
-        --  the scrutinised Id to be sufficiently refined to have a TyCon in it]
-
-    alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 } :| match_alts_tail
-      = match_alts
-    -- Stuff for newtype
-    arg_id1       = assert (notNull arg_ids1) $ head arg_ids1
-    var_ty        = idType var
-    (tc, ty_args) = tcSplitTyConApp var_ty      -- Don't look through newtypes
-                                                -- (not that splitTyConApp does, these days)
-    newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
-
-mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult CoreExpr
-mkCoSynCaseMatchResult var ty alt = MR_Fallible $ mkPatSynCase var ty alt
-
-mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
-mkPatSynCase var ty alt fail = do
-    matcher_id <- dsLookupGlobalId matcher_name
-    matcher <- dsLExpr $ mkLHsWrap wrapper $
-                         nlHsTyApp matcher_id [getRuntimeRep ty, ty]
-    cont <- mkCoreLams bndrs <$> runMatchResult fail match_result
-    return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
-  where
-    MkCaseAlt{ alt_pat = psyn,
-               alt_bndrs = bndrs,
-               alt_wrapper = wrapper,
-               alt_result = match_result} = alt
-    (matcher_name, _, needs_void_lam) = patSynMatcher psyn
-
-    -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn
-    -- on these extra Void# arguments
-    ensure_unstrict cont | needs_void_lam = Lam voidArgId cont
-                         | otherwise      = cont
-
-mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult CoreExpr
-mkDataConCase var ty alts@(alt1 :| _)
-    = liftA2 mk_case mk_default mk_alts
-    -- The liftA2 combines the failability of all the alternatives and the default
-  where
-    con1          = alt_pat alt1
-    tycon         = dataConTyCon con1
-    data_cons     = tyConDataCons tycon
-
-    sorted_alts :: [ CaseAlt DataCon ]
-    sorted_alts  = sortWith (dataConTag . alt_pat) $ NEL.toList alts
-
-    var_ty       = idType var
-    (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
-                                          -- (not that splitTyConApp does, these days)
-
-    mk_case :: Maybe CoreAlt -> [CoreAlt] -> CoreExpr
-    mk_case def alts = mkWildCase (Var var) (idScaledType var) ty $
-      maybeToList def ++ alts
-
-    mk_alts :: MatchResult [CoreAlt]
-    mk_alts = traverse mk_alt sorted_alts
-
-    mk_alt :: CaseAlt DataCon -> MatchResult CoreAlt
-    mk_alt MkCaseAlt { alt_pat = con
-                     , alt_bndrs = args
-                     , alt_result = match_result } =
-      flip adjustMatchResultDs match_result $ \body -> do
-        case dataConBoxer con of
-          Nothing -> return (Alt (DataAlt con) args body)
-          Just (DCB boxer) -> do
-            us <- newUniqueSupply
-            let (rep_ids, binds) = initUs_ us (boxer ty_args args)
-            let rep_ids' = map (scaleVarBy (idMult var)) rep_ids
-              -- Upholds the invariant that the binders of a case expression
-              -- must be scaled by the case multiplicity. See Note [Case
-              -- expression invariants] in CoreSyn.
-            return (Alt (DataAlt con) rep_ids' (mkLets binds body))
-
-    mk_default :: MatchResult (Maybe CoreAlt)
-    mk_default
-      | exhaustive_case = MR_Infallible $ return Nothing
-      | otherwise       = MR_Fallible $ \fail -> return $ Just (Alt DEFAULT [] fail)
-
-    mentioned_constructors = mkUniqSet $ map alt_pat sorted_alts
-    un_mentioned_constructors
-        = mkUniqSet data_cons `minusUniqSet` mentioned_constructors
-    exhaustive_case = isEmptyUniqSet un_mentioned_constructors
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Desugarer's versions of some Core functions}
-*                                                                      *
-************************************************************************
--}
-
-mkErrorAppDs :: Id              -- The error function
-             -> Type            -- Type to which it should be applied
-             -> SDoc            -- The error message string to pass
-             -> DsM CoreExpr
-
-mkErrorAppDs err_id ty msg = do
-    src_loc <- getSrcSpanDs
-    dflags <- getDynFlags
-    let full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
-        fail_expr = mkRuntimeErrorApp err_id unitTy full_msg
-    return $ mkWildCase fail_expr (unrestricted unitTy) ty []
-    -- See Note [Incompleteness and linearity]
-
-{-
-Note [Incompleteness and linearity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The default branch of an incomplete pattern match is compiled to a call
-to 'error'.
-Because of linearity, we wrap it with an empty case. Example:
-
-f :: a %1 -> Bool -> a
-f x True = False
-
-Adding 'f x False = error "Non-exhaustive pattern..."' would violate
-the linearity of x.
-Instead, we use 'f x False = case error "Non-exhaustive pattern..." :: () of {}'.
-This case expression accounts for linear variables by assigning bottom usage
-(See Note [Bottom as a usage] in GHC.Core.Multiplicity).
-This is done in mkErrorAppDs, called from mkFailExpr.
-We use '()' instead of the original return type ('a' in this case)
-because there might be representation polymorphism, e.g. in
-
-g :: forall (a :: TYPE r). (() -> a) %1 -> Bool -> a
-g x True = x ()
-
-adding 'g x False = case error "Non-exhaustive pattern" :: a of {}'
-would create an illegal representation-polymorphic case binder.
-This is important for pattern synonym matchers, which often look like this 'g'.
-
-Similarly, a hole
-h :: a %1 -> a
-h x = _
-is desugared to 'case error "Hole" :: () of {}'. Test: LinearHole.
-
-Instead of () we could use Data.Void.Void, but that would require
-moving Void to GHC.Types: partial pattern matching is used in modules
-that are compiled before Data.Void.
-We can use () even though it has a constructor, because
-Note [Case expression invariants] point 4 in GHC.Core is satisfied
-when the scrutinee is bottoming.
-
-You might wonder if this change slows down compilation, but the
-performance testsuite did not show up any regressions.
-
-For uniformity, calls to 'error' in both cases are wrapped even if -XLinearTypes
-is disabled.
--}
-
-mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr
-mkFailExpr ctxt ty
-  = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
-
-{-
-'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'.
-
-Note [Desugaring seq]
-~~~~~~~~~~~~~~~~~~~~~
-
-There are a few subtleties in the desugaring of `seq`:
-
- 1. (as described in #1031)
-
-    Consider,
-       f x y = x `seq` (y `seq` (# x,y #))
-
-    Because the argument to the outer 'seq' has an unlifted type, we'll use
-    call-by-value, and compile it as if we had
-
-       f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
-
-    But that is bad, because we now evaluate y before x!
-
-    Seq is very, very special!  So we recognise it right here, and desugar to
-            case x of _ -> case y of _ -> (# x,y #)
-
- 2. (as described in #2273)
-
-    Consider
-       let chp = case b of { True -> fst x; False -> 0 }
-       in chp `seq` ...chp...
-    Here the seq is designed to plug the space leak of retaining (snd x)
-    for too long.
-
-    If we rely on the ordinary inlining of seq, we'll get
-       let chp = case b of { True -> fst x; False -> 0 }
-       case chp of _ { I# -> ...chp... }
-
-    But since chp is cheap, and the case is an alluring context, we'll
-    inline chp into the case scrutinee.  Now there is only one use of chp,
-    so we'll inline a second copy.  Alas, we've now ruined the purpose of
-    the seq, by re-introducing the space leak:
-        case (case b of {True -> fst x; False -> 0}) of
-          I# _ -> ...case b of {True -> fst x; False -> 0}...
-
-    We can try to avoid doing this by ensuring that the binder-swap in the
-    case happens, so we get this at an early stage:
-       case chp of chp2 { I# -> ...chp2... }
-    But this is fragile.  The real culprit is the source program.  Perhaps we
-    should have said explicitly
-       let !chp2 = chp in ...chp2...
-
-    But that's painful.  So the code here does a little hack to make seq
-    more robust: a saturated application of 'seq' is turned *directly* into
-    the case expression, thus:
-       x  `seq` e2 ==> case x of x -> e2    -- Note shadowing!
-       e1 `seq` e2 ==> case x of _ -> e2
-
-    So we desugar our example to:
-       let chp = case b of { True -> fst x; False -> 0 }
-       case chp of chp { I# -> ...chp... }
-    And now all is well.
-
-    The reason it's a hack is because if you define mySeq=seq, the hack
-    won't work on mySeq.
-
- 3. (as described in #2409)
-
-    The isInternalName ensures that we don't turn
-            True `seq` e
-    into
-            case True of True { ... }
-    which stupidly tries to bind the datacon 'True'.
--}
-
--- NB: Make sure the argument is not representation-polymorphic
-mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
-mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2
-  | f `hasKey` seqIdKey            -- Note [Desugaring seq], points (1) and (2)
-  = Case arg1 case_bndr ty2 [Alt DEFAULT [] arg2]
-  where
-    case_bndr = case arg1 of
-                   Var v1 | isInternalName (idName v1)
-                          -> v1        -- Note [Desugaring seq], points (2) and (3)
-                   _      -> mkWildValBinder ManyTy ty1
-
-mkCoreAppDs _ (Var f `App` Type _r) arg
-  | f `hasKey` noinlineIdKey   -- See Note [noinlineId magic] in GHC.Types.Id.Make
-  , (fun, args) <- collectArgs arg
-  , not (null args)
-  = (Var f `App` Type (exprType fun) `App` fun)
-    `mkCoreApps` args
-
-mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in GHC.Core.Make
-
--- NB: No argument can be representation-polymorphic
-mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
-mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args
-
-mkCastDs :: CoreExpr -> Coercion -> CoreExpr
--- We define a desugarer-specific version of GHC.Core.Utils.mkCast,
--- because in the immediate output of the desugarer, we can have
--- apparently-mis-matched coercions:  E.g.
---     let a = b
---     in (x :: a) |> (co :: b ~ Int)
--- Lint know about type-bindings for let and does not complain
--- So here we do not make the assertion checks that we make in
--- GHC.Core.Utils.mkCast; and we do less peephole optimisation too
-mkCastDs e co | isReflCo co = e
-              | otherwise   = Cast e co
-
-{-
-************************************************************************
-*                                                                      *
-               Tuples and selector bindings
-*                                                                      *
-************************************************************************
-
-This is used in various places to do with lazy patterns.
-For each binder $b$ in the pattern, we create a binding:
-\begin{verbatim}
-    b = case v of pat' -> b'
-\end{verbatim}
-where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
-
-ToDo: making these bindings should really depend on whether there's
-much work to be done per binding.  If the pattern is complex, it
-should be de-mangled once, into a tuple (and then selected from).
-Otherwise the demangling can be in-line in the bindings (as here).
-
-Boring!  Boring!  One error message per binder.  The above ToDo is
-even more helpful.  Something very similar happens for pattern-bound
-expressions.
-
-Note [mkSelectorBinds]
-~~~~~~~~~~~~~~~~~~~~~~
-mkSelectorBinds is used to desugar a pattern binding {p = e},
-in a binding group:
-  let { ...; p = e; ... } in body
-where p binds x,y (this list of binders can be empty).
-There are two cases.
-
------- Special case (A) -------
-  For a pattern that is just a variable,
-     let !x = e in body
-  ==>
-     let x = e in x `seq` body
-  So we return the binding, with 'x' as the variable to seq.
-
------- Special case (B) -------
-  For a pattern that is essentially just a tuple:
-      * A product type, so cannot fail
-      * Boxed, so that it can be matched lazily
-      * Only one level, so that
-          - generating multiple matches is fine
-          - seq'ing it evaluates the same as matching it
-  Then instead we generate
-       { v = e
-       ; x = case v of p -> x
-       ; y = case v of p -> y }
-  with 'v' as the variable to force
-
------- General case (C) -------
-  In the general case we generate these bindings:
-       let { ...; p = e; ... } in body
-  ==>
-       let { t = case e of p -> (x,y)
-           ; x = case t of (x,y) -> x
-           ; y = case t of (x,y) -> y }
-       in t `seq` body
-
-  Note that we return 't' as the variable to force if the pattern
-  is strict (i.e. with -XStrict or an outermost-bang-pattern)
-
-  Note that (C) /includes/ the situation where
-
-   * The pattern binds exactly one variable
-        let !(Just (Just x) = e in body
-     ==>
-       let { t = case e of Just (Just v) -> Solo v
-           ; v = case t of Solo v -> v }
-       in t `seq` body
-    The 'Solo' is a one-tuple; see Note [One-tuples] in GHC.Builtin.Types
-    Note that forcing 't' makes the pattern match happen,
-    but does not force 'v'.  That's why we call `mkBigCoreVarTupSolo`
-    in `mkSeletcorBinds`
-
-  * The pattern binds no variables
-        let !(True,False) = e in body
-    ==>
-        let t = case e of (True,False) -> ()
-        in t `seq` body
-
-
------- Examples ----------
-  *   !(_, (_, a)) = e
-    ==>
-      t = case e of (_, (_, a)) -> Solo a
-      a = case t of Solo a -> a
-
-    Note that
-     - Forcing 't' will force the pattern to match fully;
-       e.g. will diverge if (snd e) is bottom
-     - But 'a' itself is not forced; it is wrapped in a one-tuple
-       (see Note [One-tuples] in GHC.Builtin.Types)
-
-  *   !(Just x) = e
-    ==>
-      t = case e of Just x -> Solo x
-      x = case t of Solo x -> x
-
-    Again, forcing 't' will fail if 'e' yields Nothing.
-
-Note that even though this is rather general, the special cases
-work out well:
-
-* One binder, not -XStrict:
-
-    let Just (Just v) = e in body
-  ==>
-    let t = case e of Just (Just v) -> Solo v
-        v = case t of Solo v -> v
-    in body
-  ==>
-    let v = case (case e of Just (Just v) -> Solo v) of
-              Solo v -> v
-    in body
-  ==>
-    let v = case e of Just (Just v) -> v
-    in body
-
-* Non-recursive, -XStrict
-     let p = e in body
-  ==>
-     let { t = case e of p -> (x,y)
-         ; x = case t of (x,y) -> x
-         ; y = case t of (x,y) -> x }
-     in t `seq` body
-  ==> {inline seq, float x,y bindings inwards}
-     let t = case e of p -> (x,y) in
-     case t of t' ->
-     let { x = case t' of (x,y) -> x
-         ; y = case t' of (x,y) -> x } in
-     body
-  ==> {inline t, do case of case}
-     case e of p ->
-     let t = (x,y) in
-     let { x = case t' of (x,y) -> x
-         ; y = case t' of (x,y) -> x } in
-     body
-  ==> {case-cancellation, drop dead code}
-     case e of p -> body
-
-* Special case (B) is there to avoid fruitlessly taking the tuple
-  apart and rebuilding it. For example, consider
-     { K x y = e }
-  where K is a product constructor.  Then general case (A) does:
-     { t = case e of K x y -> (x,y)
-     ; x = case t of (x,y) -> x
-     ; y = case t of (x,y) -> y }
-  In the lazy case we can't optimise out this fruitless taking apart
-  and rebuilding.  Instead (B) builds
-     { v = e
-     ; x = case v of K x y -> x
-     ; y = case v of K x y -> y }
-  which is better.
--}
--- Remark: pattern selectors only occur in unrestricted patterns so we are free
--- to select Many as the multiplicity of every let-expression introduced.
-mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly
-                -> LPat GhcTc      -- ^ The pattern
-                -> CoreExpr        -- ^ Expression to which the pattern is bound
-                -> DsM (Id,[(Id,CoreExpr)])
-                -- ^ Id the rhs is bound to, for desugaring strict
-                -- binds (see Note [Desugar Strict binds] in "GHC.HsToCore.Binds")
-                -- and all the desugared binds
-
-mkSelectorBinds ticks pat val_expr
-  | L _ (VarPat _ (L _ v)) <- pat'     -- Special case (A)
-  = return (v, [(v, val_expr)])
-
-  | is_flat_prod_lpat pat'           -- Special case (B)
-  = do { let pat_ty = hsLPatType pat'
-       ; val_var <- newSysLocalDs ManyTy pat_ty
-
-       ; let mk_bind tick bndr_var
-               -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }
-               -- Remember, 'pat' binds 'bv'
-               = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'
-                                       (Var bndr_var)
-                                       (Var bndr_var)  -- Neat hack
-                      -- Neat hack: since 'pat' can't fail, the
-                      -- "fail-expr" passed to matchSimply is not
-                      -- used. But it /is/ used for its type, and for
-                      -- that bndr_var is just the ticket.
-                    ; return (bndr_var, mkOptTickBox tick rhs_expr) }
-
-       ; binds <- zipWithM mk_bind ticks' binders
-       ; return ( val_var, (val_var, val_expr) : binds) }
-
-  | otherwise                          -- General case (C)
-  = do { tuple_var  <- newSysLocalDs ManyTy tuple_ty
-       ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')
-       ; tuple_expr <- matchSimply val_expr PatBindRhs pat
-                                   local_tuple error_expr
-       ; let mk_tup_bind tick binder
-               = (binder, mkOptTickBox tick $
-                          mkBigTupleSelectorSolo local_binders binder
-                                           tuple_var (Var tuple_var))
-             tup_binds = zipWith mk_tup_bind ticks' binders
-       ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) }
-  where
-    pat' = strip_bangs pat
-           -- Strip the bangs before looking for case (A) or (B)
-           -- The incoming pattern may well have a bang on it
-
-    binders = collectPatBinders CollNoDictBinders pat'
-    ticks'  = ticks ++ repeat []
-
-    local_binders = map localiseId binders      -- See Note [Localise pattern binders]
-    local_tuple   = mkBigCoreVarTupSolo binders
-    tuple_ty      = exprType local_tuple
-
-strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p)
--- Remove outermost bangs and parens
-strip_bangs (L _ (ParPat _ _ p _))  = strip_bangs p
-strip_bangs (L _ (BangPat _ p)) = strip_bangs p
-strip_bangs lp                  = lp
-
-is_flat_prod_lpat :: LPat GhcTc -> Bool
--- Pattern is equivalent to a flat, boxed, lifted tuple
-is_flat_prod_lpat = is_flat_prod_pat . unLoc
-
-is_flat_prod_pat :: Pat GhcTc -> Bool
-is_flat_prod_pat (ParPat _ _ p _)      = is_flat_prod_lpat p
-is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
-is_flat_prod_pat (ConPat { pat_con  = L _ pcon
-                         , pat_args = ps})
-  | RealDataCon con <- pcon
-  , let tc = dataConTyCon con
-  , Just _ <- tyConSingleDataCon_maybe tc
-  , isLiftedAlgTyCon tc
-  = all is_triv_lpat (hsConPatArgs ps)
-is_flat_prod_pat _ = False
-
-is_triv_lpat :: LPat (GhcPass p) -> Bool
-is_triv_lpat = is_triv_pat . unLoc
-
-is_triv_pat :: Pat (GhcPass p) -> Bool
-is_triv_pat (VarPat {})  = True
-is_triv_pat (WildPat{})  = True
-is_triv_pat (ParPat _ _ p _) = is_triv_lpat p
-is_triv_pat _            = False
-
-
-{- *********************************************************************
-*                                                                      *
-  Creating big tuples and their types for full Haskell expressions.
-  They work over *Ids*, and create tuples replete with their types,
-  which is whey they are not in GHC.Hs.Utils.
-*                                                                      *
-********************************************************************* -}
-
-mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
-mkLHsPatTup []     = noLocA $ mkVanillaTuplePat [] Boxed
-mkLHsPatTup [lpat] = lpat
-mkLHsPatTup lpats@(L l _:_)  = L l $
-                     mkVanillaTuplePat lpats Boxed
-
-mkVanillaTuplePat :: [LPat GhcTc] -> Boxity -> Pat GhcTc
--- A vanilla tuple pattern simply gets its type from its sub-patterns
-mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
-
--- The Big equivalents for the source tuple expressions
-mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
-mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)
-
-mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc
-mkBigLHsTupId = mkChunkified (\e -> mkLHsTupleExpr e noExtField)
-
--- The Big equivalents for the source tuple patterns
-mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc
-mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)
-
-mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc
-mkBigLHsPatTupId = mkChunkified mkLHsPatTup
-
-{-
-************************************************************************
-*                                                                      *
-        Code for pattern-matching and other failures
-*                                                                      *
-************************************************************************
-
-Generally, we handle pattern matching failure like this: let-bind a
-fail-variable, and use that variable if the thing fails:
-\begin{verbatim}
-        let fail.33 = error "Help"
-        in
-        case x of
-                p1 -> ...
-                p2 -> fail.33
-                p3 -> fail.33
-                p4 -> ...
-\end{verbatim}
-Then
-\begin{itemize}
-\item
-If the case can't fail, then there'll be no mention of @fail.33@, and the
-simplifier will later discard it.
-
-\item
-If it can fail in only one way, then the simplifier will inline it.
-
-\item
-Only if it is used more than once will the let-binding remain.
-\end{itemize}
-
-There's a problem when the result of the case expression is of
-unboxed type.  Then the type of @fail.33@ is unboxed too, and
-there is every chance that someone will change the let into a case:
-\begin{verbatim}
-        case error "Help" of
-          fail.33 -> case ....
-\end{verbatim}
-
-which is of course utterly wrong.  Rather than drop the condition that
-only boxed types can be let-bound, we just turn the fail into a function
-for the primitive case:
-\begin{verbatim}
-        let fail.33 :: Void -> Int#
-            fail.33 = \_ -> error "Help"
-        in
-        case x of
-                p1 -> ...
-                p2 -> fail.33 void
-                p3 -> fail.33 void
-                p4 -> ...
-\end{verbatim}
-
-Now @fail.33@ is a function, so it can be let-bound.
-
-We would *like* to use join points here; in fact, these "fail variables" are
-paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as
-CPS functions - i.e. they take "join points" as parameters. It's not impossible
-to imagine extending our type system to allow passing join points around (very
-carefully), but we certainly don't support it now.
-
-99.99% of the time, the fail variables wind up as join points in short order
-anyway, and the Void# doesn't do much harm.
--}
-
-mkFailurePair :: CoreExpr       -- Result type of the whole case expression
-              -> DsM (CoreBind, -- Binds the newly-created fail variable
-                                -- to \ _ -> expression
-                      CoreExpr) -- Fail variable applied to realWorld#
--- See Note [Failure thunks and CPR]
-mkFailurePair expr
-  = do { fail_fun_var <- newFailLocalDs ManyTy (unboxedUnitTy `mkVisFunTyMany` ty)
-       ; fail_fun_arg <- newSysLocalDs ManyTy unboxedUnitTy
-       ; let real_arg = setOneShotLambda fail_fun_arg
-       ; return (NonRec fail_fun_var (Lam real_arg expr),
-                 App (Var fail_fun_var) unboxedUnitExpr) }
-  where
-    ty = exprType expr
-
--- Uses '@mkFailurePair@' to bind the failure case. Infallible matches have
--- neither a failure arg or failure "hole", so nothing is let-bound, and no
--- extraneous Core is produced.
-shareFailureHandler :: MatchResult CoreExpr -> MatchResult CoreExpr
-shareFailureHandler = \case
-  mr@(MR_Infallible _) -> mr
-  MR_Fallible match_fn -> MR_Fallible $ \fail_expr -> do
-    (fail_bind, shared_failure_handler) <- mkFailurePair fail_expr
-    body <- match_fn shared_failure_handler
-    -- Never unboxed, per the above, so always OK for `let` not `case`.
-    return $ Let fail_bind body
-
-{-
-Note [Failure thunks and CPR]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-(This note predates join points as formal entities (hence the quotation marks).
-We can't use actual join points here (see above); if we did, this would also
-solve the CPR problem, since join points don't get CPR'd. See Note [Don't w/w
-join points for CPR] in GHC.Core.Opt.WorkWrap.)
-
-When we make a failure point we ensure that it
-does not look like a thunk. Example:
-
-   let fail = \rw -> error "urk"
-   in case x of
-        [] -> fail realWorld#
-        (y:ys) -> case ys of
-                    [] -> fail realWorld#
-                    (z:zs) -> (y,z)
-
-Reason: we know that a failure point is always a "join point" and is
-entered at most once.  Adding a dummy 'realWorld' token argument makes
-it clear that sharing is not an issue.  And that in turn makes it more
-CPR-friendly.  This matters a lot: if you don't get it right, you lose
-the tail call property.  For example, see #3403.
--}
-
-dsHandleMonadicFailure :: HsDoFlavour -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr
-    -- In a do expression, pattern-match failure just calls
-    -- the monadic 'fail' rather than throwing an exception
-dsHandleMonadicFailure ctx pat match m_fail_op =
-  case shareFailureHandler match of
-    MR_Infallible body -> body
-    MR_Fallible body -> do
-      fail_op <- case m_fail_op of
-        -- Note that (non-monadic) list comprehension, pattern guards, etc could
-        -- have fallible bindings without an explicit failure op, but this is
-        -- handled elsewhere. See Note [Failing pattern matches in Stmts] the
-        -- breakdown of regular and special binds.
-        Nothing -> pprPanic "missing fail op" $
-          text "Pattern match:" <+> ppr pat <+>
-          text "is failable, and fail_expr was left unset"
-        Just fail_op -> pure fail_op
-      dflags <- getDynFlags
-      fail_msg <- mkStringExpr (mk_fail_msg dflags ctx pat)
-      fail_expr <- dsSyntaxExpr fail_op [fail_msg]
-      body fail_expr
-
-mk_fail_msg :: DynFlags -> HsDoFlavour -> LocatedA e -> String
-mk_fail_msg dflags ctx pat
-  = showPpr dflags $ text "Pattern match failure in" <+> pprHsDoFlavour ctx
-                   <+> text "at" <+> ppr (getLocA pat)
-
-{- *********************************************************************
-*                                                                      *
-              Ticks
-*                                                                      *
-********************************************************************* -}
-
-mkOptTickBox :: [CoreTickish] -> CoreExpr -> CoreExpr
-mkOptTickBox = flip (foldr Tick)
-
-mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
-mkBinaryTickBox ixT ixF e = do
-       uq <- newUnique
-       this_mod <- getModule
-       let bndr1 = mkSysLocal (fsLit "t1") uq OneTy boolTy
-         -- It's always sufficient to pattern-match on a boolean with
-         -- multiplicity 'One'.
-       let
-           falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)
-           trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)
-       --
-       return $ Case e bndr1 boolTy
-                       [ Alt (DataAlt falseDataCon) [] falseBox
-                       , Alt (DataAlt trueDataCon)  [] trueBox
-                       ]
-
-
-
--- *******************************************************************
-
-{- Note [decideBangHood]
-~~~~~~~~~~~~~~~~~~~~~~~~
-With -XStrict we may make /outermost/ patterns more strict.
-E.g.
-       let (Just x) = e in ...
-          ==>
-       let !(Just x) = e in ...
-and
-       f x = e
-          ==>
-       f !x = e
-
-This adjustment is done by decideBangHood,
-
-  * Just before constructing an EqnInfo, in GHC.HsToCore.Match
-      (matchWrapper and matchSinglePat)
-
-  * When desugaring a pattern-binding in GHC.HsToCore.Binds.dsHsBind
-
-Note that it is /not/ done recursively.  See the -XStrict
-spec in the user manual.
-
-Specifically:
-   ~pat    => pat    -- when -XStrict (even if pat = ~pat')
-   !pat    => !pat   -- always
-   pat     => !pat   -- when -XStrict
-   pat     => pat    -- otherwise
--}
-
-
--- | Use -XStrict to add a ! or remove a ~
--- See Note [decideBangHood]
-decideBangHood :: DynFlags
-               -> LPat GhcTc  -- ^ Original pattern
-               -> LPat GhcTc  -- Pattern with bang if necessary
-decideBangHood dflags lpat
-  | not (xopt LangExt.Strict dflags)
-  = lpat
-  | otherwise   --  -XStrict
-  = go lpat
-  where
-    go lp@(L l p)
-      = case p of
-           ParPat x lpar p rpar -> L l (ParPat x lpar (go p) rpar)
-           LazyPat _ lp' -> lp'
-           BangPat _ _   -> lp
-           _             -> L l (BangPat noExtField lp)
-
-isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
-
--- Returns Just {..} if we're sure that the expression is True
--- I.e.   * 'True' datacon
---        * 'otherwise' Id
---        * Trivial wrappings of these
--- The arguments to Just are any HsTicks that we have found,
--- because we still want to tick then, even it they are always evaluated.
-isTrueLHsExpr (L _ (HsVar _ (L _ v)))
-  |  v `hasKey` otherwiseIdKey
-     || v `hasKey` getUnique trueDataConId
-                                              = Just return
-        -- trueDataConId doesn't have the same unique as trueDataCon
-isTrueLHsExpr (L _ (XExpr (ConLikeTc con _ _)))
-  | con `hasKey` getUnique trueDataCon = Just return
-isTrueLHsExpr (L _ (XExpr (HsTick tickish e)))
-    | Just ticks <- isTrueLHsExpr e
-    = Just (\x -> do wrapped <- ticks x
-                     return (Tick tickish wrapped))
-   -- This encodes that the result is constant True for Hpc tick purposes;
-   -- which is specifically what isTrueLHsExpr is trying to find out.
-isTrueLHsExpr (L _ (XExpr (HsBinTick ixT _ e)))
-    | Just ticks <- isTrueLHsExpr e
-    = Just (\x -> do e <- ticks x
-                     this_mod <- getModule
-                     return (Tick (HpcTick this_mod ixT) e))
-
-isTrueLHsExpr (L _ (HsPar _ _ e _)) = isTrueLHsExpr e
-isTrueLHsExpr _                     = Nothing
diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs
deleted file mode 100644
--- a/compiler/GHC/Iface/Binary.hs
+++ /dev/null
@@ -1,385 +0,0 @@
-{-# LANGUAGE BinaryLiterals, ScopedTypeVariables #-}
-
---
---  (c) The University of Glasgow 2002-2006
---
-
-{-# OPTIONS_GHC -O2 #-}
--- We always optimise this, otherwise performance of a non-optimised
--- compiler is severely affected
-
--- | Binary interface file support.
-module GHC.Iface.Binary (
-        -- * Public API for interface file serialisation
-        writeBinIface,
-        readBinIface,
-        readBinIfaceHeader,
-        getSymtabName,
-        CheckHiWay(..),
-        TraceBinIFace(..),
-        getWithUserData,
-        putWithUserData,
-
-        -- * Internal serialisation functions
-        getSymbolTable,
-        putName,
-        putSymbolTable,
-        BinSymbolTable(..),
-    ) where
-
-import GHC.Prelude
-
-import GHC.Tc.Utils.Monad
-import GHC.Builtin.Utils   ( isKnownKeyName, lookupKnownKeyName )
-import GHC.Unit
-import GHC.Unit.Module.ModIface
-import GHC.Types.Name
-import GHC.Platform.Profile
-import GHC.Types.Unique.FM
-import GHC.Utils.Panic
-import GHC.Utils.Binary as Binary
-import GHC.Data.FastMutInt
-import GHC.Types.Unique
-import GHC.Utils.Outputable
-import GHC.Types.Name.Cache
-import GHC.Types.SrcLoc
-import GHC.Platform
-import GHC.Settings.Constants
-import GHC.Utils.Fingerprint
-
-import Data.Array
-import Data.Array.IO
-import Data.Array.Unsafe
-import Data.Char
-import Data.Word
-import Data.IORef
-import Control.Monad
-
--- ---------------------------------------------------------------------------
--- Reading and writing binary interface files
---
-
-data CheckHiWay = CheckHiWay | IgnoreHiWay
-    deriving Eq
-
-data TraceBinIFace
-   = TraceBinIFace (SDoc -> IO ())
-   | QuietBinIFace
-
--- | Read an interface file header, checking the magic number, version, and
--- way. Returns the hash of the source file and a BinHandle which points at the
--- start of the rest of the interface file data.
-readBinIfaceHeader
-  :: Profile
-  -> NameCache
-  -> CheckHiWay
-  -> TraceBinIFace
-  -> FilePath
-  -> IO (Fingerprint, BinHandle)
-readBinIfaceHeader profile _name_cache checkHiWay traceBinIFace hi_path = do
-    let platform = profilePlatform profile
-
-        wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()
-        wantedGot what wanted got ppr' =
-            case traceBinIFace of
-               QuietBinIFace         -> return ()
-               TraceBinIFace printer -> printer $
-                     text what <> text ": " <>
-                     vcat [text "Wanted " <> ppr' wanted <> text ",",
-                           text "got    " <> ppr' got]
-
-        errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
-        errorOnMismatch what wanted got =
-            -- This will be caught by readIface which will emit an error
-            -- msg containing the iface module name.
-            when (wanted /= got) $ throwGhcExceptionIO $ ProgramError
-                         (what ++ " (wanted " ++ show wanted
-                               ++ ", got "    ++ show got ++ ")")
-    bh <- Binary.readBinMem hi_path
-
-    -- Read the magic number to check that this really is a GHC .hi file
-    -- (This magic number does not change when we change
-    --  GHC interface file format)
-    magic <- get bh
-    wantedGot "Magic" (binaryInterfaceMagic platform) magic (ppr . unFixedLength)
-    errorOnMismatch "magic number mismatch: old/corrupt interface file?"
-        (unFixedLength $ binaryInterfaceMagic platform) (unFixedLength magic)
-
-    -- Check the interface file version and profile tag.
-    check_ver  <- get bh
-    let our_ver = show hiVersion
-    wantedGot "Version" our_ver check_ver text
-    errorOnMismatch "mismatched interface file versions" our_ver check_ver
-
-    check_tag <- get bh
-    let tag = profileBuildTag profile
-    wantedGot "Way" tag check_tag text
-    when (checkHiWay == CheckHiWay) $
-        errorOnMismatch "mismatched interface file profile tag" tag check_tag
-
-    src_hash <- get bh
-    pure (src_hash, bh)
-
--- | Read an interface file.
-readBinIface
-  :: Profile
-  -> NameCache
-  -> CheckHiWay
-  -> TraceBinIFace
-  -> FilePath
-  -> IO ModIface
-readBinIface profile name_cache checkHiWay traceBinIface hi_path = do
-    (src_hash, bh) <- readBinIfaceHeader profile name_cache checkHiWay traceBinIface hi_path
-
-    extFields_p <- get bh
-
-    mod_iface <- getWithUserData name_cache bh
-
-    seekBin bh extFields_p
-    extFields <- get bh
-
-    return mod_iface
-      { mi_ext_fields = extFields
-      , mi_src_hash = src_hash
-      }
-
--- | This performs a get action after reading the dictionary and symbol
--- table. It is necessary to run this before trying to deserialise any
--- Names or FastStrings.
-getWithUserData :: Binary a => NameCache -> BinHandle -> IO a
-getWithUserData name_cache bh = do
-  bh <- getTables name_cache bh
-  get bh
-
--- | Setup a BinHandle to read something written using putWithTables
---
--- Reading names has the side effect of adding them into the given NameCache.
-getTables :: NameCache -> BinHandle -> IO BinHandle
-getTables name_cache bh = do
-    -- Read the dictionary
-    -- The next word in the file is a pointer to where the dictionary is
-    -- (probably at the end of the file)
-    dict <- Binary.forwardGet bh (getDictionary bh)
-
-    -- Initialise the user-data field of bh
-    let bh_fs = setUserData bh $ newReadState (error "getSymtabName")
-                                              (getDictFastString dict)
-
-    symtab <- Binary.forwardGet bh_fs (getSymbolTable bh_fs name_cache)
-
-    -- It is only now that we know how to get a Name
-    return $ setUserData bh $ newReadState (getSymtabName name_cache dict symtab)
-                                           (getDictFastString dict)
-
--- | Write an interface file
-writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()
-writeBinIface profile traceBinIface hi_path mod_iface = do
-    bh <- openBinMem initBinMemSize
-    let platform = profilePlatform profile
-    put_ bh (binaryInterfaceMagic platform)
-
-    -- The version, profile tag, and source hash go next
-    put_ bh (show hiVersion)
-    let tag = profileBuildTag profile
-    put_  bh tag
-    put_  bh (mi_src_hash mod_iface)
-
-    extFields_p_p <- tellBin bh
-    put_ bh extFields_p_p
-
-    putWithUserData traceBinIface bh mod_iface
-
-    extFields_p <- tellBin bh
-    putAt bh extFields_p_p extFields_p
-    seekBin bh extFields_p
-    put_ bh (mi_ext_fields mod_iface)
-
-    -- And send the result to the file
-    writeBinMem bh hi_path
-
--- | Put a piece of data with an initialised `UserData` field. This
--- is necessary if you want to serialise Names or FastStrings.
--- It also writes a symbol table and the dictionary.
--- This segment should be read using `getWithUserData`.
-putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
-putWithUserData traceBinIface bh payload = do
-  (name_count, fs_count, _b) <- putWithTables bh (\bh' -> put bh' payload)
-
-  case traceBinIface of
-    QuietBinIFace         -> return ()
-    TraceBinIFace printer -> do
-       printer (text "writeBinIface:" <+> int name_count
-                                      <+> text "Names")
-       printer (text "writeBinIface:" <+> int fs_count
-                                      <+> text "dict entries")
-
--- | Write name/symbol tables
---
--- 1. setup the given BinHandle with Name/FastString table handling
--- 2. write the following
---    - FastString table pointer
---    - Name table pointer
---    - payload
---    - Name table
---    - FastString table
---
--- It returns (number of names, number of FastStrings, payload write result)
---
-putWithTables :: BinHandle -> (BinHandle -> IO b) -> IO (Int,Int,b)
-putWithTables bh put_payload = do
-    -- initialize state for the name table and the FastString table.
-    symtab_next <- newFastMutInt 0
-    symtab_map <- newIORef emptyUFM
-    let bin_symtab = BinSymbolTable
-                      { bin_symtab_next = symtab_next
-                      , bin_symtab_map  = symtab_map
-                      }
-
-    (bh_fs, bin_dict, put_dict) <- initFSTable bh
-
-    (fs_count,(name_count,r)) <- forwardPut bh (const put_dict) $ do
-
-      -- NB. write the dictionary after the symbol table, because
-      -- writing the symbol table may create more dictionary entries.
-      let put_symtab = do
-            name_count <- readFastMutInt symtab_next
-            symtab_map  <- readIORef symtab_map
-            putSymbolTable bh_fs name_count symtab_map
-            pure name_count
-
-      forwardPut bh_fs (const put_symtab) $ do
-
-        -- BinHandle with FastString and Name writing support
-        let ud_fs = getUserData bh_fs
-        let ud_name = ud_fs
-                        { ud_put_nonbinding_name = putName bin_dict bin_symtab
-                        , ud_put_binding_name    = putName bin_dict bin_symtab
-                        }
-        let bh_name = setUserData bh ud_name
-
-        put_payload bh_name
-
-    return (name_count, fs_count, r)
-
-
-
--- | Initial ram buffer to allocate for writing interface files
-initBinMemSize :: Int
-initBinMemSize = 1024 * 1024
-
-binaryInterfaceMagic :: Platform -> FixedLengthEncoding Word32
-binaryInterfaceMagic platform
- | target32Bit platform = FixedLengthEncoding 0x1face
- | otherwise            = FixedLengthEncoding 0x1face64
-
-
--- -----------------------------------------------------------------------------
--- The symbol table
---
-
-putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO ()
-putSymbolTable bh name_count symtab = do
-    put_ bh name_count
-    let names = elems (array (0,name_count-1) (nonDetEltsUFM symtab))
-      -- It's OK to use nonDetEltsUFM here because the elements have
-      -- indices that array uses to create order
-    mapM_ (\n -> serialiseName bh n symtab) names
-
-
-getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
-getSymbolTable bh name_cache = do
-    sz <- get bh :: IO Int
-    -- create an array of Names for the symbols and add them to the NameCache
-    updateNameCache' name_cache $ \cache0 -> do
-        mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int Name)
-        cache <- foldGet (fromIntegral sz) bh cache0 $ \i (uid, mod_name, occ) cache -> do
-          let mod = mkModule uid mod_name
-          case lookupOrigNameCache cache mod occ of
-            Just name -> do
-              writeArray mut_arr (fromIntegral i) name
-              return cache
-            Nothing   -> do
-              uniq <- takeUniqFromNameCache name_cache
-              let name      = mkExternalName uniq mod occ noSrcSpan
-                  new_cache = extendOrigNameCache cache mod occ name
-              writeArray mut_arr (fromIntegral i) name
-              return new_cache
-        arr <- unsafeFreeze mut_arr
-        return (cache, arr)
-
-serialiseName :: BinHandle -> Name -> UniqFM key (Int,Name) -> IO ()
-serialiseName bh name _ = do
-    let mod = assertPpr (isExternalName name) (ppr name) (nameModule name)
-    put_ bh (moduleUnit mod, moduleName mod, nameOccName name)
-
-
--- Note [Symbol table representation of names]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- An occurrence of a name in an interface file is serialized as a single 32-bit
--- word. The format of this word is:
---  00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
---   A normal name. x is an index into the symbol table
---  10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
---   A known-key name. x is the Unique's Char, y is the int part. We assume that
---   all known-key uniques fit in this space. This is asserted by
---   GHC.Builtin.Utils.knownKeyNamesOkay.
---
--- During serialization we check for known-key things using isKnownKeyName.
--- During deserialization we use lookupKnownKeyName to get from the unique back
--- to its corresponding Name.
-
-
--- See Note [Symbol table representation of names]
-putName :: FSTable -> BinSymbolTable -> BinHandle -> Name -> IO ()
-putName _dict BinSymbolTable{
-               bin_symtab_map = symtab_map_ref,
-               bin_symtab_next = symtab_next }
-        bh name
-  | isKnownKeyName name
-  , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
-  = -- assert (u < 2^(22 :: Int))
-    put_ bh (0x80000000
-             .|. (fromIntegral (ord c) `shiftL` 22)
-             .|. (fromIntegral u :: Word32))
-
-  | otherwise
-  = do symtab_map <- readIORef symtab_map_ref
-       case lookupUFM symtab_map name of
-         Just (off,_) -> put_ bh (fromIntegral off :: Word32)
-         Nothing -> do
-            off <- readFastMutInt symtab_next
-            -- massert (off < 2^(30 :: Int))
-            writeFastMutInt symtab_next (off+1)
-            writeIORef symtab_map_ref
-                $! addToUFM symtab_map name (off,name)
-            put_ bh (fromIntegral off :: Word32)
-
--- See Note [Symbol table representation of names]
-getSymtabName :: NameCache
-              -> Dictionary -> SymbolTable
-              -> BinHandle -> IO Name
-getSymtabName _name_cache _dict symtab bh = do
-    i :: Word32 <- get bh
-    case i .&. 0xC0000000 of
-      0x00000000 -> return $! symtab ! fromIntegral i
-
-      0x80000000 ->
-        let
-          tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
-          ix  = fromIntegral i .&. 0x003FFFFF
-          u   = mkUnique tag ix
-        in
-          return $! case lookupKnownKeyName u of
-                      Nothing -> pprPanic "getSymtabName:unknown known-key unique"
-                                          (ppr i $$ ppr u $$ char tag $$ ppr ix)
-                      Just n  -> n
-
-      _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
-
-data BinSymbolTable = BinSymbolTable {
-        bin_symtab_next :: !FastMutInt, -- The next index to use
-        bin_symtab_map  :: !(IORef (UniqFM Name (Int,Name)))
-                                -- indexed by Name
-  }
-
diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs
deleted file mode 100644
--- a/compiler/GHC/Iface/Env.hs
+++ /dev/null
@@ -1,275 +0,0 @@
--- (c) The University of Glasgow 2002-2006
-
-{-# LANGUAGE RankNTypes #-}
-
-module GHC.Iface.Env (
-        newGlobalBinder, newInteractiveBinder,
-        externaliseName,
-        lookupIfaceTop,
-        lookupOrig, lookupNameCache, lookupOrigNameCache,
-        newIfaceName, newIfaceNames,
-        extendIfaceIdEnv, extendIfaceTyVarEnv,
-        tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,
-        lookupIfaceTyVar, extendIfaceEnvs,
-        setNameModule,
-
-        ifaceExportNames,
-
-        trace_if, trace_hi_diffs,
-
-        -- Name-cache stuff
-        allocateGlobalBinder,
-   ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Env
-import GHC.Driver.Session
-
-import GHC.Tc.Utils.Monad
-import GHC.Core.Type
-import GHC.Iface.Type
-import GHC.Runtime.Context
-
-import GHC.Unit.Module
-import GHC.Unit.Module.ModIface
-
-import GHC.Data.FastString
-import GHC.Data.FastString.Env
-
-import GHC.Types.Var
-import GHC.Types.Name
-import GHC.Types.Avail
-import GHC.Types.Name.Cache
-import GHC.Types.Unique.Supply
-import GHC.Types.SrcLoc
-
-import GHC.Utils.Outputable
-import GHC.Utils.Error
-import GHC.Utils.Logger
-
-import Data.List     ( partition )
-import Control.Monad
-
-{-
-*********************************************************
-*                                                      *
-        Allocating new Names in the Name Cache
-*                                                      *
-*********************************************************
-
-See Also: Note [The Name Cache] in GHC.Types.Name.Cache
--}
-
-newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
--- Used for source code and interface files, to make the
--- Name for a thing, given its Module and OccName
--- See Note [The Name Cache] in GHC.Types.Name.Cache
---
--- The cache may already have a binding for this thing,
--- because we may have seen an occurrence before, but now is the
--- moment when we know its Module and SrcLoc in their full glory
-
-newGlobalBinder mod occ loc
-  = do { hsc_env <- getTopEnv
-       ; name <- liftIO $ allocateGlobalBinder (hsc_NC hsc_env) mod occ loc
-       ; traceIf (text "newGlobalBinder" <+>
-                  (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))
-       ; return name }
-
-newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name
--- Works in the IO monad, and gets the Module
--- from the interactive context
-newInteractiveBinder hsc_env occ loc = do
-  let mod = icInteractiveModule (hsc_IC hsc_env)
-  allocateGlobalBinder (hsc_NC hsc_env) mod occ loc
-
-allocateGlobalBinder
-  :: NameCache
-  -> Module -> OccName -> SrcSpan
-  -> IO Name
--- See Note [The Name Cache] in GHC.Types.Name.Cache
-allocateGlobalBinder nc mod occ loc
-  = updateNameCache nc mod occ $ \cache0 -> do
-      case lookupOrigNameCache cache0 mod occ of
-        -- A hit in the cache!  We are at the binding site of the name.
-        -- This is the moment when we know the SrcLoc
-        -- of the Name, so we set this field in the Name we return.
-        --
-        -- Then (bogus) multiple bindings of the same Name
-        -- get different SrcLocs can be reported as such.
-        --
-        -- Possible other reason: it might be in the cache because we
-        --      encountered an occurrence before the binding site for an
-        --      implicitly-imported Name.  Perhaps the current SrcLoc is
-        --      better... but not really: it'll still just say 'imported'
-        --
-        -- IMPORTANT: Don't mess with wired-in names.
-        --            Their wired-in-ness is in their NameSort
-        --            and their Module is correct.
-
-        Just name | isWiredInName name
-                  -> pure (cache0, name)
-                  | otherwise
-                  -> pure (new_cache, name')
-                  where
-                    uniq      = nameUnique name
-                    name'     = mkExternalName uniq mod occ loc
-                                -- name' is like name, but with the right SrcSpan
-                    new_cache = extendOrigNameCache cache0 mod occ name'
-
-        -- Miss in the cache!
-        -- Build a completely new Name, and put it in the cache
-        _ -> do
-              uniq <- takeUniqFromNameCache nc
-              let name      = mkExternalName uniq mod occ loc
-              let new_cache = extendOrigNameCache cache0 mod occ name
-              pure (new_cache, name)
-
-ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
-ifaceExportNames exports = return exports
-
-{-
-************************************************************************
-*                                                                      *
-                Name cache access
-*                                                                      *
-************************************************************************
--}
-
--- | Look up the 'Name' for a given 'Module' and 'OccName'.
--- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad
--- and 'Module' is simply that of the 'ModIface' you are typechecking.
-lookupOrig :: Module -> OccName -> TcRnIf a b Name
-lookupOrig mod occ = do
-  hsc_env <- getTopEnv
-  traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
-  liftIO $ lookupNameCache (hsc_NC hsc_env) mod occ
-
-lookupNameCache :: NameCache -> Module -> OccName -> IO Name
--- Lookup up the (Module,OccName) in the NameCache
--- If you find it, return it; if not, allocate a fresh original name and extend
--- the NameCache.
--- Reason: this may the first occurrence of (say) Foo.bar we have encountered.
--- If we need to explore its value we will load Foo.hi; but meanwhile all we
--- need is a Name for it.
-lookupNameCache nc mod occ = updateNameCache nc mod occ $ \cache0 ->
-  case lookupOrigNameCache cache0 mod occ of
-    Just name -> pure (cache0, name)
-    Nothing   -> do
-      uniq <- takeUniqFromNameCache nc
-      let name      = mkExternalName uniq mod occ noSrcSpan
-      let new_cache = extendOrigNameCache cache0 mod occ name
-      pure (new_cache, name)
-
-externaliseName :: Module -> Name -> TcRnIf m n Name
--- Take an Internal Name and make it an External one,
--- with the same unique
-externaliseName mod name
-  = do { let occ = nameOccName name
-             loc = nameSrcSpan name
-             uniq = nameUnique name
-       ; occ `seq` return ()  -- c.f. seq in newGlobalBinder
-       ; hsc_env <- getTopEnv
-       ; liftIO $ updateNameCache (hsc_NC hsc_env) mod occ $ \cache -> do
-         let name'  = mkExternalName uniq mod occ loc
-             cache' = extendOrigNameCache cache mod occ name'
-         pure (cache', name') }
-
--- | Set the 'Module' of a 'Name'.
-setNameModule :: Maybe Module -> Name -> TcRnIf m n Name
-setNameModule Nothing n = return n
-setNameModule (Just m) n =
-    newGlobalBinder m (nameOccName n) (nameSrcSpan n)
-
-{-
-************************************************************************
-*                                                                      *
-                Type variables and local Ids
-*                                                                      *
-************************************************************************
--}
-
-tcIfaceLclId :: FastString -> IfL Id
-tcIfaceLclId occ
-  = do  { lcl <- getLclEnv
-        ; case (lookupFsEnv (if_id_env lcl) occ) of
-            Just ty_var -> return ty_var
-            Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
-        }
-
-extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
-extendIfaceIdEnv ids
-  = updLclEnv $ \env ->
-    let { id_env' = extendFsEnvList (if_id_env env) pairs
-        ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }
-    in env { if_id_env = id_env' }
-
-
-tcIfaceTyVar :: FastString -> IfL TyVar
-tcIfaceTyVar occ
-  = do  { lcl <- getLclEnv
-        ; case (lookupFsEnv (if_tv_env lcl) occ) of
-            Just ty_var -> return ty_var
-            Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
-        }
-
-lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)
-lookupIfaceTyVar (occ, _)
-  = do  { lcl <- getLclEnv
-        ; return (lookupFsEnv (if_tv_env lcl) occ) }
-
-lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)
-lookupIfaceVar (IfaceIdBndr (_, occ, _))
-  = do  { lcl <- getLclEnv
-        ; return (lookupFsEnv (if_id_env lcl) occ) }
-lookupIfaceVar (IfaceTvBndr (occ, _))
-  = do  { lcl <- getLclEnv
-        ; return (lookupFsEnv (if_tv_env lcl) occ) }
-
-extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
-extendIfaceTyVarEnv tyvars
-  = updLclEnv $ \env ->
-    let { tv_env' = extendFsEnvList (if_tv_env env) pairs
-        ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
-    in env { if_tv_env = tv_env' }
-
-extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a
-extendIfaceEnvs tcvs thing_inside
-  = extendIfaceTyVarEnv tvs $
-    extendIfaceIdEnv    cvs $
-    thing_inside
-  where
-    (tvs, cvs) = partition isTyVar tcvs
-
-{-
-************************************************************************
-*                                                                      *
-                Getting from RdrNames to Names
-*                                                                      *
-************************************************************************
--}
-
--- | Look up a top-level name from the current Iface module
-lookupIfaceTop :: OccName -> IfL Name
-lookupIfaceTop occ
-  = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
-
-newIfaceName :: OccName -> IfL Name
-newIfaceName occ
-  = do  { uniq <- newUnique
-        ; return $! mkInternalName uniq occ noSrcSpan }
-
-newIfaceNames :: [OccName] -> IfL [Name]
-newIfaceNames occs
-  = do  { uniqs <- newUniqueSupply
-        ; return [ mkInternalName uniq occ noSrcSpan
-                 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
-
-trace_if :: Logger -> SDoc -> IO ()
-{-# INLINE trace_if #-}
-trace_if logger doc = when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger doc
-
-trace_hi_diffs :: Logger -> SDoc -> IO ()
-{-# INLINE trace_hi_diffs #-}
-trace_hi_diffs logger doc = when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $ putMsg logger doc
diff --git a/compiler/GHC/Iface/Env.hs-boot b/compiler/GHC/Iface/Env.hs-boot
deleted file mode 100644
--- a/compiler/GHC/Iface/Env.hs-boot
+++ /dev/null
@@ -1,9 +0,0 @@
-module GHC.Iface.Env where
-
-import GHC.Unit.Module
-import GHC.Types.Name.Occurrence
-import GHC.Tc.Utils.Monad
-import GHC.Types.Name
-import GHC.Types.SrcLoc
-
-newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
diff --git a/compiler/GHC/Iface/Errors.hs b/compiler/GHC/Iface/Errors.hs
deleted file mode 100644
--- a/compiler/GHC/Iface/Errors.hs
+++ /dev/null
@@ -1,335 +0,0 @@
-
-{-# LANGUAGE FlexibleContexts #-}
-
-module GHC.Iface.Errors
-  ( badIfaceFile
-  , hiModuleNameMismatchWarn
-  , homeModError
-  , cannotFindInterface
-  , cantFindInstalledErr
-  , cannotFindModule
-  , cantFindErr
-  -- * Utility functions
-  , mayShowLocations
-  ) where
-
-import GHC.Platform.Profile
-import GHC.Platform.Ways
-import GHC.Utils.Panic.Plain
-import GHC.Driver.Session
-import GHC.Driver.Env
-import GHC.Driver.Errors.Types
-import GHC.Data.Maybe
-import GHC.Prelude
-import GHC.Unit
-import GHC.Unit.Env
-import GHC.Unit.Finder.Types
-import GHC.Utils.Outputable as Outputable
-
-
-badIfaceFile :: String -> SDoc -> SDoc
-badIfaceFile file err
-  = vcat [text "Bad interface file:" <+> text file,
-          nest 4 err]
-
-hiModuleNameMismatchWarn :: Module -> Module -> SDoc
-hiModuleNameMismatchWarn requested_mod read_mod
- | moduleUnit requested_mod == moduleUnit read_mod =
-    sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,
-         text "but we were expecting module" <+> quotes (ppr requested_mod),
-         sep [text "Probable cause: the source code which generated interface file",
-             text "has an incompatible module name"
-            ]
-        ]
- | otherwise =
-  -- ToDo: This will fail to have enough qualification when the package IDs
-  -- are the same
-  withPprStyle (mkUserStyle alwaysQualify AllTheWay) $
-    -- we want the Modules below to be qualified with package names,
-    -- so reset the NamePprCtx setting.
-    hsep [ text "Something is amiss; requested module "
-         , ppr requested_mod
-         , text "differs from name found in the interface file"
-         , ppr read_mod
-         , parens (text "if these names look the same, try again with -dppr-debug")
-         ]
-
-homeModError :: InstalledModule -> ModLocation -> SDoc
--- See Note [Home module load error]
-homeModError mod location
-  = text "attempting to use module " <> quotes (ppr mod)
-    <> (case ml_hs_file location of
-           Just file -> space <> parens (text file)
-           Nothing   -> Outputable.empty)
-    <+> text "which is not loaded"
-
-
--- -----------------------------------------------------------------------------
--- Error messages
-
-cannotFindInterface :: UnitState -> Maybe HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc
-cannotFindInterface = cantFindInstalledErr (text "Failed to load interface for")
-                                           (text "Ambiguous interface for")
-
-cantFindInstalledErr
-    :: SDoc
-    -> SDoc
-    -> UnitState
-    -> Maybe HomeUnit
-    -> Profile
-    -> ([FilePath] -> SDoc)
-    -> ModuleName
-    -> InstalledFindResult
-    -> SDoc
-cantFindInstalledErr cannot_find _ unit_state mhome_unit profile tried_these mod_name find_result
-  = cannot_find <+> quotes (ppr mod_name)
-    $$ more_info
-  where
-    build_tag  = waysBuildTag (profileWays profile)
-
-    more_info
-      = case find_result of
-            InstalledNoPackage pkg
-                -> text "no unit id matching" <+> quotes (ppr pkg) <+>
-                   text "was found" $$ looks_like_srcpkgid pkg
-
-            InstalledNotFound files mb_pkg
-                | Just pkg <- mb_pkg
-                , notHomeUnitId mhome_unit pkg
-                -> not_found_in_package pkg files
-
-                | null files
-                -> text "It is not a module in the current program, or in any known package."
-
-                | otherwise
-                -> tried_these files
-
-            _ -> panic "cantFindInstalledErr"
-
-    looks_like_srcpkgid :: UnitId -> SDoc
-    looks_like_srcpkgid pk
-     -- Unsafely coerce a unit id (i.e. an installed package component
-     -- identifier) into a PackageId and see if it means anything.
-     | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk))
-     = parens (text "This unit ID looks like the source package ID;" $$
-       text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$
-       (if null pkgs then Outputable.empty
-        else text "and" <+> int (length pkgs) <+> text "other candidates"))
-     -- Todo: also check if it looks like a package name!
-     | otherwise = Outputable.empty
-
-    not_found_in_package pkg files
-       | build_tag /= ""
-       = let
-            build = if build_tag == "p" then "profiling"
-                                        else "\"" ++ build_tag ++ "\""
-         in
-         text "Perhaps you haven't installed the " <> text build <>
-         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$
-         tried_these files
-
-       | otherwise
-       = text "There are files missing in the " <> quotes (ppr pkg) <>
-         text " package," $$
-         text "try running 'ghc-pkg check'." $$
-         tried_these files
-
-mayShowLocations :: DynFlags -> [FilePath] -> SDoc
-mayShowLocations dflags files
-    | null files = Outputable.empty
-    | verbosity dflags < 3 =
-          text "Use -v (or `:set -v` in ghci) " <>
-              text "to see a list of the files searched for."
-    | otherwise =
-          hang (text "Locations searched:") 2 $ vcat (map text files)
-
-cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc
-cannotFindModule hsc_env = cannotFindModule'
-    (hsc_dflags   hsc_env)
-    (hsc_unit_env hsc_env)
-    (targetProfile (hsc_dflags hsc_env))
-
-
-cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult -> SDoc
-cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units unit_env) $
-  cantFindErr (checkBuildingCabalPackage dflags)
-              cannotFindMsg
-              (text "Ambiguous module name")
-              unit_env
-              profile
-              (mayShowLocations dflags)
-              mod
-              res
-  where
-    cannotFindMsg =
-      case res of
-        NotFound { fr_mods_hidden = hidden_mods
-                 , fr_pkgs_hidden = hidden_pkgs
-                 , fr_unusables = unusables }
-          | not (null hidden_mods && null hidden_pkgs && null unusables)
-          -> text "Could not load module"
-        _ -> text "Could not find module"
-
-cantFindErr
-    :: BuildingCabalPackage -- ^ Using Cabal?
-    -> SDoc
-    -> SDoc
-    -> UnitEnv
-    -> Profile
-    -> ([FilePath] -> SDoc)
-    -> ModuleName
-    -> FindResult
-    -> SDoc
-cantFindErr _ _ multiple_found _ _ _ mod_name (FoundMultiple mods)
-  | Just pkgs <- unambiguousPackages
-  = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 (
-       sep [text "it was found in multiple packages:",
-                hsep (map ppr pkgs) ]
-    )
-  | otherwise
-  = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 (
-       vcat (map pprMod mods)
-    )
-  where
-    unambiguousPackages = foldl' unambiguousPackage (Just []) mods
-    unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)
-        = Just (moduleUnit m : xs)
-    unambiguousPackage _ _ = Nothing
-
-    pprMod (m, o) = text "it is bound as" <+> ppr m <+>
-                                text "by" <+> pprOrigin m o
-    pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"
-    pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"
-    pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (
-      if e == Just True
-          then [text "package" <+> ppr (moduleUnit m)]
-          else [] ++
-      map ((text "a reexport in package" <+>)
-                .ppr.mkUnit) res ++
-      if f then [text "a package flag"] else []
-      )
-
-cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find_result
-  = cannot_find <+> quotes (ppr mod_name)
-    $$ more_info
-  where
-    mhome_unit = ue_homeUnit unit_env
-    more_info
-      = case find_result of
-            NoPackage pkg
-                -> text "no unit id matching" <+> quotes (ppr pkg) <+>
-                   text "was found"
-
-            NotFound { fr_paths = files, fr_pkg = mb_pkg
-                     , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens
-                     , fr_unusables = unusables, fr_suggestions = suggest }
-                | Just pkg <- mb_pkg
-                , Nothing <- mhome_unit           -- no home-unit
-                -> not_found_in_package pkg files
-
-                | Just pkg <- mb_pkg
-                , Just home_unit <- mhome_unit    -- there is a home-unit but the
-                , not (isHomeUnit home_unit pkg)  -- module isn't from it
-                -> not_found_in_package pkg files
-
-                | not (null suggest)
-                -> pp_suggestions suggest $$ tried_these files
-
-                | null files && null mod_hiddens &&
-                  null pkg_hiddens && null unusables
-                -> text "It is not a module in the current program, or in any known package."
-
-                | otherwise
-                -> vcat (map pkg_hidden pkg_hiddens) $$
-                   vcat (map mod_hidden mod_hiddens) $$
-                   vcat (map unusable unusables) $$
-                   tried_these files
-
-            _ -> panic "cantFindErr"
-
-    build_tag = waysBuildTag (profileWays profile)
-
-    not_found_in_package pkg files
-       | build_tag /= ""
-       = let
-            build = if build_tag == "p" then "profiling"
-                                        else "\"" ++ build_tag ++ "\""
-         in
-         text "Perhaps you haven't installed the " <> text build <>
-         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$
-         tried_these files
-
-       | otherwise
-       = text "There are files missing in the " <> quotes (ppr pkg) <>
-         text " package," $$
-         text "try running 'ghc-pkg check'." $$
-         tried_these files
-
-    pkg_hidden :: Unit -> SDoc
-    pkg_hidden uid =
-        text "It is a member of the hidden package"
-        <+> quotes (ppr uid)
-        --FIXME: we don't really want to show the unit id here we should
-        -- show the source package id or installed package id if it's ambiguous
-        <> dot $$ pkg_hidden_hint uid
-
-    pkg_hidden_hint uid
-     | using_cabal == YesBuildingCabalPackage
-        = let pkg = expectJust "pkg_hidden" (lookupUnit (ue_units unit_env) uid)
-           in text "Perhaps you need to add" <+>
-              quotes (ppr (unitPackageName pkg)) <+>
-              text "to the build-depends in your .cabal file."
-     | Just pkg <- lookupUnit (ue_units unit_env) uid
-         = text "You can run" <+>
-           quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>
-           text "to expose it." $$
-           text "(Note: this unloads all the modules in the current scope.)"
-     | otherwise = Outputable.empty
-
-    mod_hidden pkg =
-        text "it is a hidden module in the package" <+> quotes (ppr pkg)
-
-    unusable (pkg, reason)
-      = text "It is a member of the package"
-      <+> quotes (ppr pkg)
-      $$ pprReason (text "which is") reason
-
-    pp_suggestions :: [ModuleSuggestion] -> SDoc
-    pp_suggestions sugs
-      | null sugs = Outputable.empty
-      | otherwise = hang (text "Perhaps you meant")
-                       2 (vcat (map pp_sugg sugs))
-
-    -- NB: Prefer the *original* location, and then reexports, and then
-    -- package flags when making suggestions.  ToDo: if the original package
-    -- also has a reexport, prefer that one
-    pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o
-      where provenance ModHidden = Outputable.empty
-            provenance (ModUnusable _) = Outputable.empty
-            provenance (ModOrigin{ fromOrigUnit = e,
-                                   fromExposedReexport = res,
-                                   fromPackageFlag = f })
-              | Just True <- e
-                 = parens (text "from" <+> ppr (moduleUnit mod))
-              | f && moduleName mod == m
-                 = parens (text "from" <+> ppr (moduleUnit mod))
-              | (pkg:_) <- res
-                 = parens (text "from" <+> ppr (mkUnit pkg)
-                    <> comma <+> text "reexporting" <+> ppr mod)
-              | f
-                 = parens (text "defined via package flags to be"
-                    <+> ppr mod)
-              | otherwise = Outputable.empty
-    pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o
-      where provenance ModHidden =  Outputable.empty
-            provenance (ModUnusable _) = Outputable.empty
-            provenance (ModOrigin{ fromOrigUnit = e,
-                                   fromHiddenReexport = rhs })
-              | Just False <- e
-                 = parens (text "needs flag -package-id"
-                    <+> ppr (moduleUnit mod))
-              | (pkg:_) <- rhs
-                 = parens (text "needs flag -package-id"
-                    <+> ppr (mkUnit pkg))
-              | otherwise = Outputable.empty
-
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
deleted file mode 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ /dev/null
@@ -1,2152 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes     #-}
-{-# LANGUAGE CPP                     #-}
-{-# LANGUAGE ConstraintKinds         #-}
-{-# LANGUAGE DataKinds               #-}
-{-# LANGUAGE DeriveDataTypeable      #-}
-{-# LANGUAGE FlexibleContexts        #-}
-{-# LANGUAGE FlexibleInstances       #-}
-{-# LANGUAGE GADTs                   #-}
-{-# LANGUAGE OverloadedStrings       #-}
-{-# LANGUAGE ScopedTypeVariables     #-}
-{-# LANGUAGE TypeApplications        #-}
-{-# LANGUAGE TypeFamilies            #-}
-{-# LANGUAGE UndecidableInstances    #-}
-{-# LANGUAGE UndecidableSuperClasses #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-{-
-Main functions for .hie file generation
--}
-
-module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts, enrichHie) where
-
-import GHC.Utils.Outputable(ppr)
-
-import GHC.Prelude hiding ( head, init, last, tail )
-
-import GHC.Types.Avail            ( Avails )
-import GHC.Data.Bag               ( Bag, bagToList )
-import GHC.Types.Basic
-import GHC.Data.BooleanFormula
-import GHC.Core.Class             ( className, classSCSelIds )
-import GHC.Core.ConLike           ( conLikeName )
-import GHC.Core.TyCon             ( TyCon, tyConClass_maybe )
-import GHC.Core.FVs
-import GHC.Core.DataCon           ( dataConNonlinearType )
-import GHC.Types.FieldLabel
-import GHC.Hs
-import GHC.Hs.Syn.Type
-import GHC.Utils.Monad            ( concatMapM, MonadIO(liftIO) )
-import GHC.Types.Id               ( isDataConId_maybe )
-import GHC.Types.Name             ( Name, nameSrcSpan, nameUnique )
-import GHC.Types.Name.Env         ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )
-import GHC.Types.SrcLoc
-import GHC.Core.Type              ( Type )
-import GHC.Core.Predicate
-import GHC.Core.InstEnv
-import GHC.Tc.Types
-import GHC.Tc.Types.Evidence
-import GHC.Types.Var              ( Id, Var, EvId, varName, varType, varUnique )
-import GHC.Types.Var.Env
-import GHC.Builtin.Uniques
-import GHC.Iface.Make             ( mkIfaceExports )
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Misc
-import GHC.Data.Maybe
-import GHC.Data.FastString
-import qualified GHC.Data.Strict as Strict
-
-import GHC.Iface.Ext.Types
-import GHC.Iface.Ext.Utils
-
-import GHC.Unit.Module            ( ml_hs_file )
-import GHC.Unit.Module.ModSummary
-
-import qualified Data.Array as A
-import qualified Data.ByteString as BS
-import qualified Data.Map as M
-import qualified Data.Set as S
-import Data.Data                  ( Data, Typeable )
-import Data.Foldable              ( toList )
-import Data.Functor.Identity      ( Identity(..) )
-import Data.List.NonEmpty         ( NonEmpty(..), nonEmpty )
-import qualified Data.List.NonEmpty as NE
-import Data.Void                  ( Void, absurd )
-import Control.Monad              ( forM_ )
-import Control.Monad.Trans.State.Strict
-import Control.Monad.Trans.Reader
-import Control.Monad.Trans.Class  ( lift )
-import Control.Applicative        ( (<|>) )
-
-{- Note [Updating HieAst for changes in the GHC AST]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When updating the code in this file for changes in the GHC AST, you
-need to pay attention to the following things:
-
-1) Symbols (Names/Vars/Modules) in the following categories:
-
-   a) Symbols that appear in the source file that directly correspond to
-   something the user typed
-   b) Symbols that don't appear in the source, but should be in some sense
-   "visible" to a user, particularly via IDE tooling or the like. This
-   includes things like the names introduced by RecordWildcards (We record
-   all the names introduced by a (..) in HIE files), and will include implicit
-   parameters and evidence variables after one of my pending MRs lands.
-
-2) Subtrees that may contain such symbols, or correspond to a SrcSpan in
-   the file. This includes all `Located` things
-
-For 1), you need to call `toHie` for one of the following instances
-
-instance ToHie (Context (Located Name)) where ...
-instance ToHie (Context (Located Var)) where ...
-instance ToHie (IEContext (Located ModuleName)) where ...
-
-`Context` is a data type that looks like:
-
-data Context a = C ContextInfo a -- Used for names and bindings
-
-`ContextInfo` is defined in `GHC.Iface.Ext.Types`, and looks like
-
-data ContextInfo
-  = Use                -- ^ regular variable
-  | MatchBind
-  | IEThing IEType     -- ^ import/export
-  | TyDecl
-  -- | Value binding
-  | ValBind
-      BindType     -- ^ whether or not the binding is in an instance
-      Scope        -- ^ scope over which the value is bound
-      (Maybe Span) -- ^ span of entire binding
-  ...
-
-It is used to annotate symbols in the .hie files with some extra information on
-the context in which they occur and should be fairly self explanatory. You need
-to select one that looks appropriate for the symbol usage. In very rare cases,
-you might need to extend this sum type if none of the cases seem appropriate.
-
-So, given a `Located Name` that is just being "used", and not defined at a
-particular location, you would do the following:
-
-   toHie $ C Use located_name
-
-If you select one that corresponds to a binding site, you will need to
-provide a `Scope` and a `Span` for your binding. Both of these are basically
-`SrcSpans`.
-
-The `SrcSpan` in the `Scope` is supposed to span over the part of the source
-where the symbol can be legally allowed to occur. For more details on how to
-calculate this, see Note [Capturing Scopes and other non local information]
-in GHC.Iface.Ext.Ast.
-
-The binding `Span` is supposed to be the span of the entire binding for
-the name.
-
-For a function definition `foo`:
-
-foo x = x + y
-  where y = x^2
-
-The binding `Span` is the span of the entire function definition from `foo x`
-to `x^2`.  For a class definition, this is the span of the entire class, and
-so on.  If this isn't well defined for your bit of syntax (like a variable
-bound by a lambda), then you can just supply a `Nothing`
-
-There is a test that checks that all symbols in the resulting HIE file
-occur inside their stated `Scope`. This can be turned on by passing the
--fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the
-.hie file.
-
-You may also want to provide a test in testsuite/test/hiefile that includes
-a file containing your new construction, and tests that the calculated scope
-is valid (by using -fvalidate-ide-info)
-
-For subtrees in the AST that may contain symbols, the procedure is fairly
-straightforward.  If you are extending the GHC AST, you will need to provide a
-`ToHie` instance for any new types you may have introduced in the AST.
-
-Here is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)):
-
-  toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
-      HsVar _ (L _ var) ->
-        [ toHie $ C Use (L mspan var)
-             -- Patch up var location since typechecker removes it
-        ]
-      ...
-      HsApp _ a b ->
-        [ toHie a
-        , toHie b
-        ]
-
-If your subtree is `Located` or has a `SrcSpan` available, the output list
-should contain a HieAst `Node` corresponding to the subtree. You can use
-either `makeNode` or `getTypeNode` for this purpose, depending on whether it
-makes sense to assign a `Type` to the subtree. After this, you just need
-to concatenate the result of calling `toHie` on all subexpressions and
-appropriately annotated symbols contained in the subtree.
-
-The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed
-to work for both the renamed and typechecked source. `getTypeNode` is from
-the `HasType` class defined in this file, and it has different instances
-for `GhcTc` and `GhcRn` that allow it to access the type of the expression
-when given a typechecked AST:
-
-class Data a => HasType a where
-  getTypeNode :: a -> HieM [HieAST Type]
-instance HasType (LHsExpr GhcTc) where
-  getTypeNode e@(L spn e') = ... -- Actually get the type for this expression
-instance HasType (LHsExpr GhcRn) where
-  getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type
-
-If your subtree doesn't have a span available, you can omit the `makeNode`
-call and just recurse directly in to the subexpressions.
-
--}
-
--- These synonyms match those defined in compiler/GHC.hs
-type RenamedSource     = ( HsGroup GhcRn, [LImportDecl GhcRn]
-                         , Maybe [(LIE GhcRn, Avails)]
-                         , Maybe (LHsDoc GhcRn) )
-type TypecheckedSource = LHsBinds GhcTc
-
-
-{- Note [Name Remapping]
-   ~~~~~~~~~~~~~~~~~~~~~
-The Typechecker introduces new names for mono names in AbsBinds.
-We don't care about the distinction between mono and poly bindings,
-so we replace all occurrences of the mono name with the poly name.
--}
-type VarMap a = DVarEnv (Var,a)
-data HieState = HieState
-  { name_remapping :: NameEnv Id
-  , unlocated_ev_binds :: VarMap (S.Set ContextInfo)
-  -- These contain evidence bindings that we don't have a location for
-  -- These are placed at the top level Node in the HieAST after everything
-  -- else has been generated
-  -- This includes things like top level evidence bindings.
-  }
-
-addUnlocatedEvBind :: Var -> ContextInfo -> HieM ()
-addUnlocatedEvBind var ci = do
-  let go (a,b) (_,c) = (a,S.union b c)
-  lift $ modify' $ \s ->
-    s { unlocated_ev_binds =
-          extendDVarEnv_C go (unlocated_ev_binds s)
-                          var (var,S.singleton ci)
-      }
-
-getUnlocatedEvBinds :: FastString -> HieM (NodeIdentifiers Type,[HieAST Type])
-getUnlocatedEvBinds file = do
-  binds <- lift $ gets unlocated_ev_binds
-  org <- ask
-  let elts = dVarEnvElts binds
-
-      mkNodeInfo (n,ci) = (Right (varName n), IdentifierDetails (Just $ varType n) ci)
-
-      go e@(v,_) (xs,ys) = case nameSrcSpan $ varName v of
-        RealSrcSpan spn _
-          | srcSpanFile spn == file ->
-            let node = Node (mkSourcedNodeInfo org ni) spn []
-                ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e]
-              in (xs,node:ys)
-        _ -> (mkNodeInfo e : xs,ys)
-
-      (nis,asts) = foldr go ([],[]) elts
-
-  pure $ (M.fromList nis, asts)
-
-initState :: HieState
-initState = HieState emptyNameEnv emptyDVarEnv
-
-class ModifyState a where -- See Note [Name Remapping]
-  addSubstitution :: a -> a -> HieState -> HieState
-
-instance ModifyState Name where
-  addSubstitution _ _ hs = hs
-
-instance ModifyState Id where
-  addSubstitution mono poly hs =
-    hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly}
-
-modifyState :: [ABExport] -> HieState -> HieState
-modifyState = foldr go id
-  where
-    go ABE{abe_poly=poly,abe_mono=mono} f
-      = addSubstitution mono poly . f
-
-type HieM = ReaderT NodeOrigin (State HieState)
-
--- | Construct an 'HieFile' from the outputs of the typechecker.
-mkHieFile :: MonadIO m
-          => ModSummary
-          -> TcGblEnv
-          -> RenamedSource -> m HieFile
-mkHieFile ms ts rs = do
-  let src_file = expectJust "mkHieFile" (ml_hs_file $ ms_location ms)
-  src <- liftIO $ BS.readFile src_file
-  pure $ mkHieFileWithSource src_file src ms ts rs
-
--- | Construct an 'HieFile' from the outputs of the typechecker but don't
--- read the source file again from disk.
-mkHieFileWithSource :: FilePath
-                    -> BS.ByteString
-                    -> ModSummary
-                    -> TcGblEnv
-                    -> RenamedSource -> HieFile
-mkHieFileWithSource src_file src ms ts rs =
-  let tc_binds = tcg_binds ts
-      top_ev_binds = tcg_ev_binds ts
-      insts = tcg_insts ts
-      tcs = tcg_tcs ts
-      (asts',arr) = getCompressedAsts tc_binds rs top_ev_binds insts tcs in
-  HieFile
-      { hie_hs_file = src_file
-      , hie_module = ms_mod ms
-      , hie_types = arr
-      , hie_asts = asts'
-      -- mkIfaceExports sorts the AvailInfos for stability
-      , hie_exports = mkIfaceExports (tcg_exports ts)
-      , hie_hs_src = src
-      }
-
-getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]
-  -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
-getCompressedAsts ts rs top_ev_binds insts tcs =
-  let asts = enrichHie ts rs top_ev_binds insts tcs in
-  compressTypes asts
-
-enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]
-  -> HieASTs Type
-enrichHie ts (hsGrp, imports, exports, docs) ev_bs insts tcs =
-  runIdentity $ flip evalStateT initState $ flip runReaderT SourceInfo $ do
-    tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
-    rasts <- processGrp hsGrp
-    imps <- toHie $ filter (not . ideclImplicit . ideclExt . unLoc) imports
-    exps <- toHie $ fmap (map $ IEC Export . fst) exports
-    docs <- toHie docs
-    -- Add Instance bindings
-    forM_ insts $ \i ->
-      addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing)
-    -- Add class parent bindings
-    forM_ tcs $ \tc ->
-      case tyConClass_maybe tc of
-        Nothing -> pure ()
-        Just c -> forM_ (classSCSelIds c) $ \v ->
-          addUnlocatedEvBind v (EvidenceVarBind (EvInstBind True (className c)) ModuleScope Nothing)
-    let spanFile file children = case nonEmpty children of
-          Nothing -> realSrcLocSpan (mkRealSrcLoc file 1 1)
-          Just children -> mkRealSrcSpan
-              (realSrcSpanStart $ nodeSpan (NE.head children))
-              (realSrcSpanEnd   $ nodeSpan (NE.last children))
-
-        flat_asts = concat
-          [ tasts
-          , rasts
-          , imps
-          , exps
-          , docs
-          ]
-
-        modulify (HiePath file) xs' = do
-
-          top_ev_asts :: [HieAST Type] <- do
-            let
-              l :: SrcSpanAnnA
-              l = noAnnSrcSpan (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Strict.Nothing)
-            toHie $ EvBindContext ModuleScope Nothing
-                  $ L l (EvBinds ev_bs)
-
-          (uloc_evs,more_ev_asts) <- getUnlocatedEvBinds file
-
-          let xs = mergeSortAsts $ xs' ++ top_ev_asts ++ more_ev_asts
-              span = spanFile file xs
-
-              moduleInfo = SourcedNodeInfo
-                             $ M.singleton SourceInfo
-                               $ (simpleNodeInfo "Module" "Module")
-                                  {nodeIdentifiers = uloc_evs}
-
-              moduleNode = Node moduleInfo span []
-
-          case mergeSortAsts $ moduleNode : xs of
-            [x] -> return x
-            xs -> panicDoc "enrichHie: mergeSortAsts retur:ed more than one result" (ppr $ map nodeSpan xs)
-
-    asts' <- sequence
-          $ M.mapWithKey modulify
-          $ M.fromListWith (++)
-          $ map (\x -> (HiePath (srcSpanFile (nodeSpan x)),[x])) flat_asts
-
-    let asts = HieASTs $ resolveTyVarScopes asts'
-    return asts
-
-processGrp :: HsGroup GhcRn -> HieM [HieAST Type]
-processGrp grp = concatM
-      [ toHie $ fmap (RS ModuleScope ) hs_valds grp
-      , toHie $ hs_splcds grp
-      , toHie $ hs_tyclds grp
-      , toHie $ hs_derivds grp
-      , toHie $ hs_fixds grp
-      , toHie $ hs_defds grp
-      , toHie $ hs_fords grp
-      , toHie $ hs_warnds grp
-      , toHie $ hs_annds grp
-      , toHie $ hs_ruleds grp
-      , toHie $ hs_docs grp
-      ]
-
-getRealSpanA :: SrcSpanAnn' ann -> Maybe Span
-getRealSpanA la = getRealSpan (locA la)
-
-getRealSpan :: SrcSpan -> Maybe Span
-getRealSpan (RealSrcSpan sp _) = Just sp
-getRealSpan _ = Nothing
-
-grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcAnn NoEpAnns)
-           => GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan
-grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLocA xs)
-
-bindingsOnly :: [Context Name] -> HieM [HieAST a]
-bindingsOnly [] = pure []
-bindingsOnly (C c n : xs) = do
-  org <- ask
-  rest <- bindingsOnly xs
-  pure $ case nameSrcSpan n of
-    RealSrcSpan span _ -> Node (mkSourcedNodeInfo org nodeinfo) span [] : rest
-      where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
-            info = mempty{identInfo = S.singleton c}
-    _ -> rest
-
-concatM :: Monad m => [m [a]] -> m [a]
-concatM xs = concat <$> sequence xs
-
-{- Note [Capturing Scopes and other non local information]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-toHie is a local transformation, but scopes of bindings cannot be known locally,
-hence we have to push the relevant info down into the binding nodes.
-We use the following types (*Context and *Scoped) to wrap things and
-carry the required info
-(Maybe Span) always carries the span of the entire binding, including rhs
--}
-data Context a = C ContextInfo a -- Used for names and bindings
-
-data RContext a = RC RecFieldContext a
-data RFContext a = RFC RecFieldContext (Maybe Span) a
--- ^ context for record fields
-
-data IEContext a = IEC IEType a
--- ^ context for imports/exports
-
-data BindContext a = BC BindType Scope a
--- ^ context for imports/exports
-
-data PatSynFieldContext a = PSC (Maybe Span) a
--- ^ context for pattern synonym fields.
-
-data SigContext a = SC SigInfo a
--- ^ context for type signatures
-
-data SigInfo = SI SigType (Maybe Span)
-
-data SigType = BindSig | ClassSig | InstSig
-
-data EvBindContext a = EvBindContext Scope (Maybe Span) a
-
-data RScoped a = RS Scope a
--- ^ Scope spans over everything to the right of a, (mostly) not
--- including a itself
--- (Includes a in a few special cases like recursive do bindings) or
--- let/where bindings
-
--- | Pattern scope
-data PScoped a = PS (Maybe Span)
-                    Scope       -- ^ use site of the pattern
-                    Scope       -- ^ pattern to the right of a, not including a
-                    a
-  deriving (Typeable, Data) -- Pattern Scope
-
-{- Note [TyVar Scopes]
-   ~~~~~~~~~~~~~~~~~~~
-Due to -XScopedTypeVariables, type variables can be in scope quite far from
-their original binding. We resolve the scope of these type variables
-in a separate pass
--}
-data TScoped a = TS TyVarScope a -- TyVarScope
-
-data TVScoped a = TVS TyVarScope Scope a -- TyVarScope
--- ^ First scope remains constant
--- Second scope is used to build up the scope of a tyvar over
--- things to its right, ala RScoped
-
--- | Each element scopes over the elements to the right
-listScopes :: Scope -> [LocatedA a] -> [RScoped (LocatedA a)]
-listScopes _ [] = []
-listScopes rhsScope [pat] = [RS rhsScope pat]
-listScopes rhsScope (pat : pats) = RS sc pat : pats'
-  where
-    pats'@((RS scope p):_) = listScopes rhsScope pats
-    sc = combineScopes scope $ mkScope $ getLocA p
-
--- | 'listScopes' specialised to 'PScoped' things
-patScopes
-  :: Maybe Span
-  -> Scope
-  -> Scope
-  -> [LPat (GhcPass p)]
-  -> [PScoped (LPat (GhcPass p))]
-patScopes rsp useScope patScope xs =
-  map (\(RS sc a) -> PS rsp useScope sc a) $
-    listScopes patScope xs
-
--- | 'listScopes' specialised to 'HsConPatTyArg'
-taScopes
-  :: Scope
-  -> Scope
-  -> [HsConPatTyArg (GhcPass a)]
-  -> [TScoped (HsPatSigType (GhcPass a))]
-taScopes scope rhsScope xs =
-  map (\(RS sc a) -> TS (ResolvedScopes [scope, sc]) (unLoc a)) $
-    listScopes rhsScope (map (\(HsConPatTyArg _ hsps) -> L (getLoc $ hsps_body hsps) hsps) xs)
-  -- We make the HsPatSigType into a Located one by using the location of the underlying LHsType.
-  -- We then strip off the redundant location information afterward, and take the union of the given scope and those to the right when forming the TS.
-
--- | 'listScopes' specialised to 'TVScoped' things
-tvScopes
-  :: TyVarScope
-  -> Scope
-  -> [LHsTyVarBndr flag (GhcPass a)]
-  -> [TVScoped (LHsTyVarBndr flag (GhcPass a))]
-tvScopes tvScope rhsScope xs =
-  map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs
-
-{- Note [Scoping Rules for SigPat]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Explicitly quantified variables in pattern type signatures are not
-brought into scope in the rhs, but implicitly quantified variables
-are (HsWC and HsIB).
-This is unlike other signatures, where explicitly quantified variables
-are brought into the RHS Scope
-For example
-foo :: forall a. ...;
-foo = ... -- a is in scope here
-
-bar (x :: forall a. a -> a) = ... -- a is not in scope here
---   ^ a is in scope here (pattern body)
-
-bax (x :: a) = ... -- a is in scope here
-
-This case in handled in the instance for HsPatSigType
--}
-
-class HasLoc a where
-  -- ^ conveniently calculate locations for things without locations attached
-  loc :: a -> SrcSpan
-
-instance HasLoc thing => HasLoc (PScoped thing) where
-  loc (PS _ _ _ a) = loc a
-
-instance HasLoc (Located a) where
-  loc (L l _) = l
-
-instance HasLoc (LocatedA a) where
-  loc (L la _) = locA la
-
-instance HasLoc (LocatedN a) where
-  loc (L la _) = locA la
-
-instance HasLoc a => HasLoc [a] where
-  loc [] = noSrcSpan
-  loc xs = foldl1' combineSrcSpans $ map loc xs
-
-instance HasLoc a => HasLoc (DataDefnCons a) where
-  loc = loc . toList
-
-instance (HasLoc a, HiePass p) => HasLoc (FamEqn (GhcPass p) a) where
-  loc (FamEqn _ a outer_bndrs b _ c) = case outer_bndrs of
-    HsOuterImplicit{} ->
-      foldl1' combineSrcSpans [loc a, loc b, loc c]
-    HsOuterExplicit{hso_bndrs = tvs} ->
-      foldl1' combineSrcSpans [loc a, loc tvs, loc b, loc c]
-
-instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
-  loc (HsValArg tm) = loc tm
-  loc (HsTypeArg _ ty) = loc ty
-  loc (HsArgPar sp)  = sp
-
-instance HasLoc (HsDataDefn GhcRn) where
-  loc def@(HsDataDefn{}) = loc $ dd_cons def
-    -- Only used for data family instances, so we only need rhs
-    -- Most probably the rest will be unhelpful anyway
-
--- | The main worker class
--- See Note [Updating HieAst for changes in the GHC AST] for more information
--- on how to add/modify instances for this.
-class ToHie a where
-  toHie :: a -> HieM [HieAST Type]
-
--- | Used to collect type info
-class HasType a where
-  getTypeNode :: a -> HieM [HieAST Type]
-
-instance ToHie Void where
-  toHie v = absurd v
-
-instance (ToHie a) => ToHie [a] where
-  toHie = concatMapM toHie
-
-instance (ToHie a) => ToHie (NonEmpty a) where
-  toHie = concatMapM toHie
-
-instance (ToHie a) => ToHie (DataDefnCons a) where
-  toHie = concatMapM toHie
-
-instance (ToHie a) => ToHie (Bag a) where
-  toHie = toHie . bagToList
-
-instance (ToHie a) => ToHie (Maybe a) where
-  toHie = maybe (pure []) toHie
-
-instance ToHie (IEContext (LocatedA ModuleName)) where
-  toHie (IEC c (L (SrcSpanAnn _ (RealSrcSpan span _)) mname)) = do
-      org <- ask
-      pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []]
-    where details = mempty{identInfo = S.singleton (IEThing c)}
-          idents = M.singleton (Left mname) details
-  toHie _ = pure []
-
-instance ToHie (Context (Located a)) => ToHie (Context (LocatedN a)) where
-  toHie (C c (L l a)) = toHie (C c (L (locA l) a))
-
-instance ToHie (Context (Located a)) => ToHie (Context (LocatedA a)) where
-  toHie (C c (L l a)) = toHie (C c (L (locA l) a))
-
-instance ToHie (Context (Located Var)) where
-  toHie c = case c of
-      C context (L (RealSrcSpan span _) name')
-        | varUnique name' == mkBuiltinUnique 1 -> pure []
-          -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
-        | otherwise -> do
-          m <- lift $ gets name_remapping
-          org <- ask
-          let name = case lookupNameEnv m (varName name') of
-                Just var -> var
-                Nothing-> name'
-              ty = case isDataConId_maybe name' of
-                      Nothing -> varType name'
-                      Just dc -> dataConNonlinearType dc
-          pure
-            [Node
-              (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
-                M.singleton (Right $ varName name)
-                            (IdentifierDetails (Just ty)
-                                               (S.singleton context)))
-              span
-              []]
-      C (EvidenceVarBind i _ sp)  (L _ name) -> do
-        addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp)
-        pure []
-      _ -> pure []
-
-instance ToHie (Context (Located Name)) where
-  toHie c = case c of
-      C context (L (RealSrcSpan span _) name')
-        | nameUnique name' == mkBuiltinUnique 1 -> pure []
-          -- `mkOneRecordSelector` makes a field var using this unique, which we ignore
-        | otherwise -> do
-          m <- lift $ gets name_remapping
-          org <- ask
-          let name = case lookupNameEnv m name' of
-                Just var -> varName var
-                Nothing -> name'
-          pure
-            [Node
-              (mkSourcedNodeInfo org $ NodeInfo S.empty [] $
-                M.singleton (Right name)
-                            (IdentifierDetails Nothing
-                                               (S.singleton context)))
-              span
-              []]
-      _ -> pure []
-
-evVarsOfTermList :: EvTerm -> [EvId]
-evVarsOfTermList (EvExpr e)         = exprSomeFreeVarsList isEvVar e
-evVarsOfTermList (EvTypeable _ ev)  =
-  case ev of
-    EvTypeableTyCon _ e   -> concatMap evVarsOfTermList e
-    EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2]
-    EvTypeableTrFun e1 e2 e3 -> concatMap evVarsOfTermList [e1,e2,e3]
-    EvTypeableTyLit e     -> evVarsOfTermList e
-evVarsOfTermList (EvFun{}) = []
-
-instance ToHie (EvBindContext (LocatedA TcEvBinds)) where
-  toHie (EvBindContext sc sp (L span (EvBinds bs)))
-    = concatMapM go $ bagToList bs
-    where
-      go evbind = do
-          let evDeps = evVarsOfTermList $ eb_rhs evbind
-              depNames = EvBindDeps $ map varName evDeps
-          concatM $
-            [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScopeA span)) sp)
-                                        (L span $ eb_lhs evbind))
-            , toHie $ map (C EvidenceVarUse . L span) $ evDeps
-            ]
-  toHie _ = pure []
-
-instance ToHie (LocatedA HsWrapper) where
-  toHie (L osp wrap)
-    = case wrap of
-        (WpLet bs)      -> toHie $ EvBindContext (mkScopeA osp) (getRealSpanA osp) (L osp bs)
-        (WpCompose a b) -> concatM $
-          [toHie (L osp a), toHie (L osp b)]
-        (WpFun a b _)   -> concatM $
-          [toHie (L osp a), toHie (L osp b)]
-        (WpEvLam a) ->
-          toHie $ C (EvidenceVarBind EvWrapperBind (mkScopeA osp) (getRealSpanA osp))
-                $ L osp a
-        (WpEvApp a) ->
-          concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a
-        _               -> pure []
-
-instance HiePass p => HasType (LocatedA (HsBind (GhcPass p))) where
-  getTypeNode (L spn bind) =
-    case hiePass @p of
-      HieRn -> makeNode bind (locA spn)
-      HieTc ->  case bind of
-        FunBind{fun_id = name} -> makeTypeNode bind (locA spn) (varType $ unLoc name)
-        _ -> makeNode bind (locA spn)
-
-instance HiePass p => HasType (LocatedA (Pat (GhcPass p))) where
-  getTypeNode (L spn pat) =
-    case hiePass @p of
-      HieRn -> makeNodeA pat spn
-      HieTc -> makeTypeNodeA pat spn (hsPatType pat)
-
--- | This instance tries to construct 'HieAST' nodes which include the type of
--- the expression. It is not yet possible to do this efficiently for all
--- expression forms, so we skip filling in the type for those inputs.
---
--- See Note [Computing the type of every node in the tree]
-instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where
-  getTypeNode (L spn e) =
-    case hiePass @p of
-      HieRn -> fallback
-      HieTc -> case computeType e of
-          Just ty -> makeTypeNodeA e spn ty
-          Nothing -> fallback
-    where
-      fallback :: HieM [HieAST Type]
-      fallback = makeNodeA e spn
-
-      -- Skip computing the type of some expressions for performance reasons.
-      --
-      -- See impact on Haddock output (esp. missing type annotations or links)
-      -- before skipping more kinds of expressions. See impact on Haddock
-      -- performance before computing the types of more expressions.
-      --
-      -- See Note [Computing the type of every node in the tree]
-      computeType :: HsExpr GhcTc -> Maybe Type
-      computeType e = case e of
-        HsApp{} -> Nothing
-        HsAppType{} -> Nothing
-        NegApp{} -> Nothing
-        HsPar _ _ e _ -> computeLType e
-        ExplicitTuple{} -> Nothing
-        HsIf _ _ t f -> computeLType t <|> computeLType f
-        HsLet _ _ _ _ body -> computeLType body
-        RecordCon con_expr _ _ -> computeType con_expr
-        ExprWithTySig _ e _ -> computeLType e
-        HsPragE _ _ e -> computeLType e
-        XExpr (ExpansionExpr (HsExpanded (HsGetField _ _ _) e)) -> Just (hsExprType e) -- for record-dot-syntax
-        XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e
-        XExpr (HsTick _ e) -> computeLType e
-        XExpr (HsBinTick _ _ e) -> computeLType e
-        e -> Just (hsExprType e)
-
-      computeLType :: LHsExpr GhcTc -> Maybe Type
-      computeLType (L _ e) = computeType e
-
-{- Note [Computing the type of every node in the tree]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In GHC.Iface.Ext.Ast we decorate every node in the AST with its
-type, computed by `hsExprType` applied to that node.  So it's
-important that `hsExprType` takes roughly constant time per node.
-There are three cases to consider:
-
-1. For many nodes (e.g. HsVar, HsDo, HsCase) it is easy to get their
-   type -- e.g. it is stored in the node, or in sub-node thereof.
-
-2. For some nodes (e.g. HsPar, HsTick, HsIf) the type of the node is
-   the type of a child, so we can recurse, fast.  We don't expect the
-   nesting to be very deep, so while this is theoretically non-linear,
-   we don't expect it to be a problem in practice.
-
-3. A very few nodes (e.g. HsApp) are more troublesome because we need to
-   take the type of a child, and then do some non-trivial processing.
-   To be conservative on computation, we decline to decorate these
-   nodes, using `fallback` instead.
-
-The function `computeType e` returns `Just t` if we can find the type
-of `e` cheaply, and `Nothing` otherwise.  The base `Nothing` cases
-are the troublesome ones in (3) above. Hopefully we can ultimately
-get rid of them all.
-
-See #16233
-
--}
-
-data HiePassEv p where
-  HieRn :: HiePassEv 'Renamed
-  HieTc :: HiePassEv 'Typechecked
-
-class ( HiePass (NoGhcTcPass p)
-      , NoGhcTcPass p ~ 'Renamed
-      , ModifyState (IdGhcP p)
-      , Data (GRHS  (GhcPass p) (LocatedA (HsExpr (GhcPass p))))
-      , Data (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))
-      , Data (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p))))
-      , Data (Stmt  (GhcPass p) (LocatedA (HsExpr (GhcPass p))))
-      , Data (Stmt  (GhcPass p) (LocatedA (HsCmd  (GhcPass p))))
-      , Data (HsExpr (GhcPass p))
-      , Data (HsCmd  (GhcPass p))
-      , Data (AmbiguousFieldOcc (GhcPass p))
-      , Data (HsCmdTop (GhcPass p))
-      , Data (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p))))
-      , Data (HsUntypedSplice (GhcPass p))
-      , Data (HsLocalBinds (GhcPass p))
-      , Data (FieldOcc (GhcPass p))
-      , Data (HsTupArg (GhcPass p))
-      , Data (IPBind (GhcPass p))
-      , ToHie (Context (Located (IdGhcP p)))
-      , Anno (IdGhcP p) ~ SrcSpanAnnN
-      )
-      => HiePass p where
-  hiePass :: HiePassEv p
-
-instance HiePass 'Renamed where
-  hiePass = HieRn
-instance HiePass 'Typechecked where
-  hiePass = HieTc
-
-instance ToHie (Context (Located NoExtField)) where
-  toHie _ = pure []
-
-type AnnoBody p body
-  = ( Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
-                   ~ SrcSpanAnnA
-    , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-                   ~ SrcSpanAnnL
-    , Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
-                   ~ SrcAnn NoEpAnns
-    , Anno (StmtLR (GhcPass p) (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA
-
-    , Data (body (GhcPass p))
-    , Data (Match (GhcPass p) (LocatedA (body (GhcPass p))))
-    , Data (GRHS  (GhcPass p) (LocatedA (body (GhcPass p))))
-    , Data (Stmt  (GhcPass p) (LocatedA (body (GhcPass p))))
-    )
-
-instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where
-  toHie (BC context scope b@(L span bind)) =
-    concatM $ getTypeNode b : case bind of
-      FunBind{fun_id = name, fun_matches = matches, fun_ext = ext} ->
-        [ toHie $ C (ValBind context scope $ getRealSpanA span) name
-        , toHie matches
-        , case hiePass @p of
-            HieTc | (wrap, _) <- ext -> toHie $ L span wrap
-            _ -> pure []
-        ]
-      PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
-        [ toHie $ PS (getRealSpan (locA span)) scope NoScope lhs
-        , toHie rhs
-        ]
-      VarBind{var_rhs = expr} ->
-        [ toHie expr
-        ]
-      XHsBindsLR ext -> case hiePass @p of
-#if __GLASGOW_HASKELL__ < 811
-        HieRn -> dataConCantHappen ext
-#endif
-        HieTc
-          | AbsBinds{ abs_exports = xs, abs_binds = binds
-                    , abs_ev_binds = ev_binds
-                    , abs_ev_vars = ev_vars } <- ext
-          ->
-            [  lift (modify (modifyState xs)) >> -- Note [Name Remapping]
-                    (toHie $ fmap (BC context scope) binds)
-            , toHie $ map (L span . abe_wrap) xs
-            , toHie $
-                map (EvBindContext (mkScopeA span) (getRealSpanA span)
-                    . L span) ev_binds
-            , toHie $
-                map (C (EvidenceVarBind EvSigBind
-                                        (mkScopeA span)
-                                        (getRealSpanA span))
-                    . L span) ev_vars
-            ]
-      PatSynBind _ psb ->
-        [ toHie $ L (locA span) psb -- PatSynBinds only occur at the top level
-        ]
-
-instance ( HiePass p
-         , AnnoBody p body
-         , ToHie (LocatedA (body (GhcPass p)))
-         ) => ToHie (MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))) where
-  toHie mg = case mg of
-    MG{ mg_alts = (L span alts) } ->
-      local (setOrigin origin) $ concatM
-        [ locOnly (locA span)
-        , toHie alts
-        ]
-    where origin = case hiePass @p of
-             HieRn -> mg_ext mg
-             HieTc -> mg_origin $ mg_ext mg
-
-setOrigin :: Origin -> NodeOrigin -> NodeOrigin
-setOrigin FromSource _ = SourceInfo
-setOrigin Generated _ = GeneratedInfo
-
-instance HiePass p => ToHie (Located (PatSynBind (GhcPass p) (GhcPass p))) where
-    toHie (L sp psb) = concatM $ case psb of
-      PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
-        [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
-        , toHie $ toBind dets
-        , toHie $ PS Nothing lhsScope patScope pat
-        , toHie dir
-        ]
-        where
-          lhsScope = combineScopes varScope detScope
-          varScope = mkLScopeN var
-          patScope = mkScopeA $ getLoc pat
-          detScope = case dets of
-            (PrefixCon _ args) -> foldr combineScopes NoScope $ map mkLScopeN args
-            (InfixCon a b) -> combineScopes (mkLScopeN a) (mkLScopeN b)
-            (RecCon r) -> foldr go NoScope r
-          go (RecordPatSynField a b) c = combineScopes c
-            $ combineScopes (mkLScopeN (foLabel a)) (mkLScopeN b)
-          detSpan = case detScope of
-            LocalScope a -> Just a
-            _ -> Nothing
-          toBind (PrefixCon ts args) = assert (null ts) $ PrefixCon ts $ map (C Use) args
-          toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
-          toBind (RecCon r) = RecCon $ map (PSC detSpan) r
-
-instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where
-  toHie dir = case dir of
-    ExplicitBidirectional mg -> toHie mg
-    _ -> pure []
-
-instance ( HiePass p
-         , Data (body (GhcPass p))
-         , AnnoBody p body
-         , ToHie (LocatedA (body (GhcPass p)))
-         ) => ToHie (LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))) where
-  toHie (L span m ) = concatM $ makeNodeA m span : case m of
-    Match{m_ctxt=mctx, m_pats = pats, m_grhss =  grhss } ->
-      [ toHie mctx
-      , let rhsScope = mkScope $ grhss_span grhss
-          in toHie $ patScopes Nothing rhsScope NoScope pats
-      , toHie grhss
-      ]
-
-instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where
-  toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name'
-    where
-      -- See a paragraph about Haddock in #20415.
-      name' :: LocatedN Name
-      name' = case hiePass @p of
-        HieRn -> name
-        HieTc -> fmap varName name
-  toHie (StmtCtxt a) = toHie a
-  toHie _ = pure []
-
-instance HiePass p => ToHie (HsStmtContext (GhcPass p)) where
-  toHie (PatGuard a) = toHie a
-  toHie (ParStmtCtxt a) = toHie a
-  toHie (TransStmtCtxt a) = toHie a
-  toHie _ = pure []
-
-instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where
-  toHie (PS rsp scope pscope lpat@(L ospan opat)) =
-    concatM $ getTypeNode lpat : case opat of
-      WildPat _ ->
-        []
-      VarPat _ lname ->
-        [ toHie $ C (PatternBind scope pscope rsp) lname
-        ]
-      LazyPat _ p ->
-        [ toHie $ PS rsp scope pscope p
-        ]
-      AsPat _ lname _ pat ->
-        [ toHie $ C (PatternBind scope
-                                 (combineScopes (mkLScopeA pat) pscope)
-                                 rsp)
-                    lname
-        , toHie $ PS rsp scope pscope pat
-        ]
-      ParPat _ _ pat _ ->
-        [ toHie $ PS rsp scope pscope pat
-        ]
-      BangPat _ pat ->
-        [ toHie $ PS rsp scope pscope pat
-        ]
-      ListPat _ pats ->
-        [ toHie $ patScopes rsp scope pscope pats
-        ]
-      TuplePat _ pats _ ->
-        [ toHie $ patScopes rsp scope pscope pats
-        ]
-      SumPat _ pat _ _ ->
-        [ toHie $ PS rsp scope pscope pat
-        ]
-      ConPat {pat_con = con, pat_args = dets, pat_con_ext = ext} ->
-        case hiePass @p of
-          HieTc ->
-            [ toHie $ C Use $ fmap conLikeName con
-            , toHie $ contextify dets
-            , let ev_binds = cpt_binds ext
-                  ev_vars = cpt_dicts ext
-                  wrap = cpt_wrap ext
-                  evscope = mkScopeA ospan `combineScopes` scope `combineScopes` pscope
-                 in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds
-                            , toHie $ L ospan wrap
-                            , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp)
-                                          . L ospan) ev_vars
-                            ]
-            ]
-          HieRn ->
-            [ toHie $ C Use con
-            , toHie $ contextify dets
-            ]
-      ViewPat _ expr pat ->
-        [ toHie expr
-        , toHie $ PS rsp scope pscope pat
-        ]
-      SplicePat _ sp ->
-        [ toHie $ L ospan sp
-        ]
-      LitPat _ _ ->
-        []
-      NPat _ _ _ _ ->
-        []
-      NPlusKPat _ n _ _ _ _ ->
-        [ toHie $ C (PatternBind scope pscope rsp) n
-        ]
-      SigPat _ pat sig ->
-        [ toHie $ PS rsp scope pscope pat
-        , case hiePass @p of
-            HieTc ->
-              let cscope = mkLScopeA pat in
-                toHie $ TS (ResolvedScopes [cscope, scope, pscope])
-                           sig
-            HieRn -> pure []
-        ]
-      XPat e ->
-        case hiePass @p of
-          HieRn -> case e of
-            HsPatExpanded _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ]
-          HieTc -> case e of
-            CoPat wrap pat _ ->
-              [ toHie $ L ospan wrap
-              , toHie $ PS rsp scope pscope $ (L ospan pat)
-              ]
-            ExpansionPat _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ]
-    where
-      contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsConPatTyArg GhcRn) a (HsRecFields (GhcPass p) a)
-                 -> HsConDetails (TScoped (HsPatSigType GhcRn)) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))
-      contextify (PrefixCon tyargs args) =
-        PrefixCon (taScopes scope argscope tyargs)
-                  (patScopes rsp scope pscope args)
-        where argscope = foldr combineScopes NoScope $ map mkLScopeA args
-      contextify (InfixCon a b) = InfixCon a' b'
-        where [a', b'] = patScopes rsp scope pscope [a,b]
-      contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r
-      contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a
-        where
-          go :: RScoped (LocatedA (HsFieldBind id a1))
-                      -> LocatedA (HsFieldBind id (PScoped a1)) -- AZ
-          go (RS fscope (L spn (HsFieldBind x lbl pat pun))) =
-            L spn $ HsFieldBind x lbl (PS rsp scope fscope pat) pun
-          scoped_fds = listScopes pscope fds
-
-instance ToHie (TScoped (HsPatSigType GhcRn)) where
-  toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $
-      [ bindingsOnly $ map (C $ TyVarBind (mkScopeA span) sc) (wcs++tvs)
-      , toHie body
-      ]
-  -- See Note [Scoping Rules for SigPat]
-
-instance ( ToHie (LocatedA (body (GhcPass p)))
-         , HiePass p
-         , AnnoBody p body
-         ) => ToHie (GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))) where
-  toHie grhs = concatM $ case grhs of
-    GRHSs _ grhss binds ->
-     [ toHie grhss
-     , toHie $ RS (mkScope $ grhss_span grhs) binds
-     ]
-
-instance ( ToHie (LocatedA (body (GhcPass p)))
-         , HiePass p
-         , AnnoBody p body
-         ) => ToHie (LocatedAn NoEpAnns (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where
-  toHie (L span g) = concatM $ makeNodeA g span : case g of
-    GRHS _ guards body ->
-      [ toHie $ listScopes (mkLScopeA body) guards
-      , toHie body
-      ]
-
-instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
-  toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
-      HsVar _ (L _ var) ->
-        [ toHie $ C Use (L mspan var)
-             -- Patch up var location since typechecker removes it
-        ]
-      HsUnboundVar _ _ -> []  -- there is an unbound name here, but that causes trouble
-      HsRecSel _ fld ->
-        [ toHie $ RFC RecFieldOcc Nothing (L (l2l mspan:: SrcAnn NoEpAnns) fld)
-        ]
-      HsOverLabel {} -> []
-      HsIPVar _ _ -> []
-      HsOverLit _ _ -> []
-      HsLit _ _ -> []
-      HsLam _ mg ->
-        [ toHie mg
-        ]
-      HsLamCase _ _ mg ->
-        [ toHie mg
-        ]
-      HsApp _ a b ->
-        [ toHie a
-        , toHie b
-        ]
-      HsAppType _ expr _ sig ->
-        [ toHie expr
-        , toHie $ TS (ResolvedScopes []) sig
-        ]
-      OpApp _ a b c ->
-        [ toHie a
-        , toHie b
-        , toHie c
-        ]
-      NegApp _ a _ ->
-        [ toHie a
-        ]
-      HsPar _ _ a _ ->
-        [ toHie a
-        ]
-      SectionL _ a b ->
-        [ toHie a
-        , toHie b
-        ]
-      SectionR _ a b ->
-        [ toHie a
-        , toHie b
-        ]
-      ExplicitTuple _ args _ ->
-        [ toHie args
-        ]
-      ExplicitSum _ _ _ expr ->
-        [ toHie expr
-        ]
-      HsCase _ expr matches ->
-        [ toHie expr
-        , toHie matches
-        ]
-      HsIf _ a b c ->
-        [ toHie a
-        , toHie b
-        , toHie c
-        ]
-      HsMultiIf _ grhss ->
-        [ toHie grhss
-        ]
-      HsLet _ _ binds _ expr ->
-        [ toHie $ RS (mkLScopeA expr) binds
-        , toHie expr
-        ]
-      HsDo _ _ (L ispan stmts) ->
-        [ locOnly (locA ispan)
-        , toHie $ listScopes NoScope stmts
-        ]
-      ExplicitList _ exprs ->
-        [ toHie exprs
-        ]
-      RecordCon { rcon_con = con, rcon_flds = binds} ->
-        [ toHie $ C Use $ con_name
-        , toHie $ RC RecFieldAssign $ binds
-        ]
-        where
-          con_name :: LocatedN Name
-          con_name = case hiePass @p of       -- Like ConPat
-                       HieRn -> con
-                       HieTc -> fmap conLikeName con
-      RecordUpd {rupd_expr = expr, rupd_flds = Left upds}->
-        [ toHie expr
-        , toHie $ map (RC RecFieldAssign) upds
-        ]
-      RecordUpd {rupd_expr = expr, rupd_flds = Right _}->
-        [ toHie expr
-        ]
-      ExprWithTySig _ expr sig ->
-        [ toHie expr
-        , toHie $ TS (ResolvedScopes [mkLScopeA expr]) sig
-        ]
-      ArithSeq _ _ info ->
-        [ toHie info
-        ]
-      HsPragE _ _ expr ->
-        [ toHie expr
-        ]
-      HsProc _ pat cmdtop ->
-        [ toHie $ PS Nothing (mkLScopeA cmdtop) NoScope pat
-        , toHie cmdtop
-        ]
-      HsStatic _ expr ->
-        [ toHie expr
-        ]
-      HsTypedBracket xbracket b -> case hiePass @p of
-        HieRn ->
-          [ toHie b
-          ]
-        HieTc | HsBracketTc _ _ _ p <- xbracket ->
-          [ toHie b
-          , toHie p
-          ]
-      HsUntypedBracket xbracket b -> case hiePass @p of
-        HieRn ->
-            [ toHie b
-            , toHie xbracket
-            ]
-        HieTc | HsBracketTc q _ _ p <- xbracket ->
-          [ toHie q
-          , toHie p
-          ]
-      HsTypedSplice _ x ->
-        [ toHie x
-        ]
-      HsUntypedSplice _ x ->
-        [ toHie $ L mspan x
-        ]
-      HsGetField {} -> []
-      HsProjection {} -> []
-      XExpr x
-        | HieTc <- hiePass @p
-        -> case x of
-             WrapExpr (HsWrap w a)
-               -> [ toHie $ L mspan a
-                  , toHie (L mspan w) ]
-             ExpansionExpr (HsExpanded _ b)
-               -> [ toHie (L mspan b) ]
-             ConLikeTc con _ _
-               -> [ toHie $ C Use $ L mspan $ conLikeName con ]
-             HsTick _ expr
-               -> [ toHie expr
-                  ]
-             HsBinTick _ _ expr
-               -> [ toHie expr
-                  ]
-        | otherwise -> []
-
--- NOTE: no longer have the location
-instance HiePass p => ToHie (HsTupArg (GhcPass p)) where
-  toHie arg = concatM $ case arg of
-    Present _ expr ->
-      [ toHie expr
-      ]
-    Missing _ -> []
-
-instance ( ToHie (LocatedA (body (GhcPass p)))
-         , AnnoBody p body
-         , HiePass p
-         ) => ToHie (RScoped (LocatedA (Stmt (GhcPass p) (LocatedA (body (GhcPass p)))))) where
-  toHie (RS scope (L span stmt)) = concatM $ node : case stmt of
-      LastStmt _ body _ _ ->
-        [ toHie body
-        ]
-      BindStmt _ pat body ->
-        [ toHie $ PS (getRealSpan $ getLocA body) scope NoScope pat
-        , toHie body
-        ]
-      ApplicativeStmt _ stmts _ ->
-        [ concatMapM (toHie . RS scope . snd) stmts
-        ]
-      BodyStmt _ body _ _ ->
-        [ toHie body
-        ]
-      LetStmt _ binds ->
-        [ toHie $ RS scope binds
-        ]
-      ParStmt _ parstmts _ _ ->
-        [ concatMapM (\(ParStmtBlock _ stmts _ _) ->
-                          toHie $ listScopes NoScope stmts)
-                     parstmts
-        ]
-      TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->
-        [ toHie $ listScopes scope stmts
-        , toHie using
-        , toHie by
-        ]
-      RecStmt {recS_stmts = L _ stmts} ->
-        [ toHie $ map (RS $ combineScopes scope (mkScope (locA span))) stmts
-        ]
-    where
-      node = case hiePass @p of
-        HieTc -> makeNodeA stmt span
-        HieRn -> makeNodeA stmt span
-
-instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where
-  toHie (RS scope binds) = concatM $ makeNode binds (spanHsLocaLBinds binds) : case binds of
-      EmptyLocalBinds _ -> []
-      HsIPBinds _ ipbinds -> case ipbinds of
-        IPBinds evbinds xs -> let sc = combineScopes scope $ scopeHsLocaLBinds binds
-                                  sp :: SrcSpanAnnA
-                                  sp = noAnnSrcSpan $ spanHsLocaLBinds binds in
-          [
-            case hiePass @p of
-              HieTc -> toHie $ EvBindContext sc (getRealSpan $ locA sp) $ L sp evbinds
-              HieRn -> pure []
-          , toHie $ map (RS sc) xs
-          ]
-      HsValBinds _ valBinds ->
-        [
-          toHie $ RS (combineScopes scope (scopeHsLocaLBinds binds))
-                      valBinds
-        ]
-
-scopeHsLocaLBinds :: HsLocalBinds (GhcPass p) -> Scope
-scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))
-  = foldr combineScopes NoScope (bsScope ++ sigsScope)
-  where
-    bsScope :: [Scope]
-    bsScope = map (mkScopeA . getLoc) $ bagToList bs
-    sigsScope :: [Scope]
-    sigsScope = map (mkScope . getLocA) sigs
-scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))
-  = foldr combineScopes NoScope (bsScope ++ sigsScope)
-  where
-    bsScope :: [Scope]
-    bsScope = map (mkScopeA . getLoc) $ concatMap (bagToList . snd) bs
-    sigsScope :: [Scope]
-    sigsScope = map (mkScope . getLocA) sigs
-
-scopeHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
-  = foldr combineScopes NoScope (map (mkScopeA . getLoc) bs)
-scopeHsLocaLBinds (EmptyLocalBinds _) = NoScope
-
-instance HiePass p => ToHie (RScoped (LocatedA (IPBind (GhcPass p)))) where
-  toHie (RS scope (L sp bind@(IPBind v _ expr))) = concatM $ makeNodeA bind sp : case hiePass @p of
-    HieRn -> [toHie expr]
-    HieTc -> [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpanA sp))
-                       $ L sp v
-             , toHie expr
-             ]
-
-instance HiePass p => ToHie (RScoped (HsValBindsLR (GhcPass p) (GhcPass p))) where
-  toHie (RS sc v) = concatM $ case v of
-    ValBinds _ binds sigs ->
-      [ toHie $ fmap (BC RegularBind sc) binds
-      , toHie $ fmap (SC (SI BindSig Nothing)) sigs
-      ]
-    XValBindsLR x -> [ toHie $ RS sc x ]
-
-instance HiePass p => ToHie (RScoped (NHsValBindsLR (GhcPass p))) where
-  toHie (RS sc (NValBinds binds sigs)) = concatM $
-    [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
-    , toHie $ fmap (SC (SI BindSig Nothing)) sigs
-    ]
-
-instance ( ToHie arg , HasLoc arg , Data arg
-         , HiePass p ) => ToHie (RContext (HsRecFields (GhcPass p) arg)) where
-  toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields
-
-instance ( ToHie (RFContext label)
-         , ToHie arg, HasLoc arg, Data arg
-         , Data label
-         ) => ToHie (RContext (LocatedA (HsFieldBind label arg))) where
-  toHie (RC c (L span recfld)) = concatM $ makeNode recfld (locA span) : case recfld of
-    HsFieldBind _ label expr _ ->
-      [ toHie $ RFC c (getRealSpan $ loc expr) label
-      , toHie expr
-      ]
-
-instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (FieldOcc (GhcPass p)))) where
-  toHie (RFC c rhs (L nspan f)) = concatM $ case f of
-    FieldOcc fld _ ->
-      case hiePass @p of
-        HieRn -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)]
-        HieTc -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)]
-
-instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (AmbiguousFieldOcc (GhcPass p)))) where
-  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
-    Unambiguous fld _ ->
-      case hiePass @p of
-        HieRn -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld]
-        HieTc -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld]
-    Ambiguous fld _ ->
-      case hiePass @p of
-        HieRn -> []
-        HieTc -> [ toHie $ C (RecField c rhs) (L (locA nspan) fld) ]
-
-instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
-  toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
-    [ toHie $ PS Nothing sc NoScope pat
-    , toHie expr
-    ]
-  toHie (RS sc (ApplicativeArgMany _ stmts _ pat _)) = concatM
-    [ toHie $ listScopes NoScope stmts
-    , toHie $ PS Nothing sc NoScope pat
-    ]
-
-instance (ToHie tyarg, ToHie arg, ToHie rec) => ToHie (HsConDetails tyarg arg rec) where
-  toHie (PrefixCon tyargs args) = concatM [ toHie tyargs, toHie args ]
-  toHie (RecCon rec) = toHie rec
-  toHie (InfixCon a b) = concatM [ toHie a, toHie b]
-
-instance ToHie (HsConDeclGADTDetails GhcRn) where
-  toHie (PrefixConGADT args) = toHie args
-  toHie (RecConGADT rec _) = toHie rec
-
-instance HiePass p => ToHie (LocatedAn NoEpAnns (HsCmdTop (GhcPass p))) where
-  toHie (L span top) = concatM $ makeNodeA top span : case top of
-    HsCmdTop _ cmd ->
-      [ toHie cmd
-      ]
-
-instance HiePass p => ToHie (LocatedA (HsCmd (GhcPass p))) where
-  toHie (L span cmd) = concatM $ makeNodeA cmd span : case cmd of
-      HsCmdArrApp _ a b _ _ ->
-        [ toHie a
-        , toHie b
-        ]
-      HsCmdArrForm _ a _ _ cmdtops ->
-        [ toHie a
-        , toHie cmdtops
-        ]
-      HsCmdApp _ a b ->
-        [ toHie a
-        , toHie b
-        ]
-      HsCmdLam _ mg ->
-        [ toHie mg
-        ]
-      HsCmdPar _ _ a _ ->
-        [ toHie a
-        ]
-      HsCmdCase _ expr alts ->
-        [ toHie expr
-        , toHie alts
-        ]
-      HsCmdLamCase _ _ alts ->
-        [ toHie alts
-        ]
-      HsCmdIf _ _ a b c ->
-        [ toHie a
-        , toHie b
-        , toHie c
-        ]
-      HsCmdLet _ _ binds _ cmd' ->
-        [ toHie $ RS (mkLScopeA cmd') binds
-        , toHie cmd'
-        ]
-      HsCmdDo _ (L ispan stmts) ->
-        [ locOnly (locA ispan)
-        , toHie $ listScopes NoScope stmts
-        ]
-      XCmd _ -> []
-
-instance ToHie (TyClGroup GhcRn) where
-  toHie TyClGroup{ group_tyclds = classes
-                 , group_roles  = roles
-                 , group_kisigs = sigs
-                 , group_instds = instances } =
-    concatM
-    [ toHie classes
-    , toHie sigs
-    , toHie roles
-    , toHie instances
-    ]
-
-instance ToHie (LocatedA (TyClDecl GhcRn)) where
-  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
-      FamDecl {tcdFam = fdecl} ->
-        [ toHie ((L span fdecl) :: LFamilyDecl GhcRn)
-        ]
-      SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->
-        [ toHie $ C (Decl SynDec $ getRealSpanA span) name
-        , toHie $ TS (ResolvedScopes [mkScope $ getLocA typ]) vars
-        , toHie typ
-        ]
-      DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->
-        [ toHie $ C (Decl DataDec $ getRealSpanA span) name
-        , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars
-        , toHie defn
-        ]
-        where
-          quant_scope = mkLScopeA $ fromMaybe (noLocA []) $ dd_ctxt defn
-          rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc
-          sig_sc = maybe NoScope mkLScopeA $ dd_kindSig defn
-          con_sc = foldr combineScopes NoScope $ mkLScopeA <$> dd_cons defn
-          deriv_sc = foldr combineScopes NoScope $ mkLScopeA <$> dd_derivs defn
-      ClassDecl { tcdCtxt = context
-                , tcdLName = name
-                , tcdTyVars = vars
-                , tcdFDs = deps
-                , tcdSigs = sigs
-                , tcdMeths = meths
-                , tcdATs = typs
-                , tcdATDefs = deftyps
-                } ->
-        [ toHie $ C (Decl ClassDec $ getRealSpanA span) name
-        , toHie context
-        , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars
-        , toHie deps
-        , toHie $ map (SC $ SI ClassSig $ getRealSpanA span) sigs
-        , toHie $ fmap (BC InstanceBind ModuleScope) meths
-        , toHie typs
-        , concatMapM (locOnly . getLocA) deftyps
-        , toHie deftyps
-        ]
-        where
-          context_scope = mkLScopeA $ fromMaybe (noLocA []) context
-          rhs_scope = foldl1' combineScopes $ map mkScope
-            [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
-
-instance ToHie (LocatedA (FamilyDecl GhcRn)) where
-  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
-      FamilyDecl _ info _ name vars _ sig inj ->
-        [ toHie $ C (Decl FamDec $ getRealSpanA span) name
-        , toHie $ TS (ResolvedScopes [rhsSpan]) vars
-        , toHie info
-        , toHie $ RS injSpan sig
-        , toHie inj
-        ]
-        where
-          rhsSpan = sigSpan `combineScopes` injSpan
-          sigSpan = mkScope $ getLocA sig
-          injSpan = maybe NoScope (mkScope . getLocA) inj
-
-instance ToHie (FamilyInfo GhcRn) where
-  toHie (ClosedTypeFamily (Just eqns)) = concatM $
-    [ concatMapM (locOnly . getLocA) eqns
-    , toHie $ map go eqns
-    ]
-    where
-      go (L l ib) = TS (ResolvedScopes [mkScopeA l]) ib
-  toHie _ = pure []
-
-instance ToHie (RScoped (LocatedAn NoEpAnns (FamilyResultSig GhcRn))) where
-  toHie (RS sc (L span sig)) = concatM $ makeNodeA sig span : case sig of
-      NoSig _ ->
-        []
-      KindSig _ k ->
-        [ toHie k
-        ]
-      TyVarSig _ bndr ->
-        [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr
-        ]
-
-instance ToHie (LocatedA (FunDep GhcRn)) where
-  toHie (L span fd@(FunDep _ lhs rhs)) = concatM $
-    [ makeNode fd (locA span)
-    , toHie $ map (C Use) lhs
-    , toHie $ map (C Use) rhs
-    ]
-
-
-instance ToHie (TScoped (FamEqn GhcRn (HsDataDefn GhcRn))) where
-  toHie (TS _ f) = toHie f
-
-instance ToHie (TScoped (FamEqn GhcRn (LocatedA (HsType GhcRn)))) where
-  toHie (TS _ f) = toHie f
-
-instance (ToHie rhs, HasLoc rhs)
-    => ToHie (FamEqn GhcRn rhs) where
-  toHie fe@(FamEqn _ var outer_bndrs pats _ rhs) = concatM $
-    [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
-    , toHie $ TVS (ResolvedScopes []) scope outer_bndrs
-    , toHie pats
-    , toHie rhs
-    ]
-    where scope = combineScopes patsScope rhsScope
-          patsScope = mkScope (loc pats)
-          rhsScope = mkScope (loc rhs)
-
-instance ToHie (LocatedAn NoEpAnns (InjectivityAnn GhcRn)) where
-  toHie (L span ann) = concatM $ makeNodeA ann span : case ann of
-      InjectivityAnn _ lhs rhs ->
-        [ toHie $ C Use lhs
-        , toHie $ map (C Use) rhs
-        ]
-
-instance ToHie (HsDataDefn GhcRn) where
-  toHie (HsDataDefn _ ctx _ mkind cons derivs) = concatM
-    [ toHie ctx
-    , toHie mkind
-    , toHie cons
-    , toHie derivs
-    ]
-
-instance ToHie (Located [LocatedAn NoEpAnns (HsDerivingClause GhcRn)]) where
-  toHie (L span clauses) = concatM
-    [ locOnly span
-    , toHie clauses
-    ]
-
-instance ToHie (LocatedAn NoEpAnns (HsDerivingClause GhcRn)) where
-  toHie (L span cl) = concatM $ makeNodeA cl span : case cl of
-      HsDerivingClause _ strat dct ->
-        [ toHie (RS (mkLScopeA dct) <$> strat)
-        , toHie dct
-        ]
-
-instance ToHie (LocatedC (DerivClauseTys GhcRn)) where
-  toHie (L span dct) = concatM $ makeNodeA dct span : case dct of
-      DctSingle _ ty -> [ toHie $ TS (ResolvedScopes []) ty ]
-      DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ]
-
-instance ToHie (RScoped (LocatedAn NoEpAnns (DerivStrategy GhcRn))) where
-  toHie (RS sc (L span strat)) = concatM $ makeNodeA strat span : case strat of
-      StockStrategy _ -> []
-      AnyclassStrategy _ -> []
-      NewtypeStrategy _ -> []
-      ViaStrategy s -> [ toHie (TS (ResolvedScopes [sc]) s) ]
-
-instance ToHie (LocatedP OverlapMode) where
-  toHie (L span _) = locOnly (locA span)
-
-instance ToHie a => ToHie (HsScaled GhcRn a) where
-  toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t]
-
-instance ToHie (LocatedA (ConDecl GhcRn)) where
-  toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of
-      ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs
-                  , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ
-                  , con_doc = doc} ->
-        [ toHie $ C (Decl ConDec $ getRealSpanA span) <$> names
-        , case outer_bndrs of
-            HsOuterImplicit{hso_ximplicit = imp_vars} ->
-              bindingsOnly $ map (C $ TyVarBind (mkScopeA outer_bndrs_loc) resScope)
-                             imp_vars
-            HsOuterExplicit{hso_bndrs = exp_bndrs} ->
-              toHie $ tvScopes resScope NoScope exp_bndrs
-        , toHie ctx
-        , toHie args
-        , toHie typ
-        , toHie doc
-        ]
-        where
-          rhsScope = combineScopes argsScope tyScope
-          ctxScope = maybe NoScope mkLScopeA ctx
-          argsScope = case args of
-            PrefixConGADT xs -> scaled_args_scope xs
-            RecConGADT x _   -> mkLScopeA x
-          tyScope = mkLScopeA typ
-          resScope = ResolvedScopes [ctxScope, rhsScope]
-      ConDeclH98 { con_name = name, con_ex_tvs = qvars
-                 , con_mb_cxt = ctx, con_args = dets
-                 , con_doc = doc} ->
-        [ toHie $ C (Decl ConDec $ getRealSpan (locA span)) name
-        , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars
-        , toHie ctx
-        , toHie dets
-        , toHie doc
-        ]
-        where
-          rhsScope = combineScopes ctxScope argsScope
-          ctxScope = maybe NoScope mkLScopeA ctx
-          argsScope = case dets of
-            PrefixCon _ xs -> scaled_args_scope xs
-            InfixCon a b   -> scaled_args_scope [a, b]
-            RecCon x       -> mkLScopeA x
-    where scaled_args_scope :: [HsScaled GhcRn (LHsType GhcRn)] -> Scope
-          scaled_args_scope = foldr combineScopes NoScope . map (mkLScopeA . hsScaledThing)
-
-instance ToHie (LocatedL [LocatedA (ConDeclField GhcRn)]) where
-  toHie (L span decls) = concatM $
-    [ locOnly (locA span)
-    , toHie decls
-    ]
-
-instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsSigType GhcRn)))) where
-  toHie (TS sc (HsWC names a)) = concatM $
-      [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
-      , toHie $ TS sc a
-      ]
-    where span = loc a
-
-instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsType GhcRn)))) where
-  toHie (TS sc (HsWC names a)) = concatM $
-      [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
-      , toHie a
-      ]
-    where span = loc a
-
-instance ToHie (LocatedA (StandaloneKindSig GhcRn)) where
-  toHie (L sp sig) = concatM [makeNodeA sig sp, toHie sig]
-
-instance ToHie (StandaloneKindSig GhcRn) where
-  toHie sig = concatM $ case sig of
-    StandaloneKindSig _ name typ ->
-      [ toHie $ C TyDecl name
-      , toHie $ TS (ResolvedScopes []) typ
-      ]
-
-instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where
-  toHie (SC (SI styp msp) (L sp sig)) =
-    case hiePass @p of
-      HieTc -> pure []
-      HieRn -> concatM $ makeNodeA sig sp : case sig of
-        TypeSig _ names typ ->
-          [ toHie $ map (C TyDecl) names
-          , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
-          ]
-        PatSynSig _ names typ ->
-          [ toHie $ map (C TyDecl) names
-          , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
-          ]
-        ClassOpSig _ _ names typ ->
-          [ case styp of
-              ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpanA sp) names
-              _  -> toHie $ map (C $ TyDecl) names
-          , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
-          ]
-        FixSig _ fsig ->
-          [ toHie $ L sp fsig
-          ]
-        InlineSig _ name _ ->
-          [ toHie $ (C Use) name
-          ]
-        SpecSig _ name typs _ ->
-          [ toHie $ (C Use) name
-          , toHie $ map (TS (ResolvedScopes [])) typs
-          ]
-        SpecInstSig _ typ ->
-          [ toHie $ TS (ResolvedScopes []) typ
-          ]
-        MinimalSig _ form ->
-          [ toHie form
-          ]
-        SCCFunSig _ name mtxt ->
-          [ toHie $ (C Use) name
-          , maybe (pure []) (locOnly . getLocA) mtxt
-          ]
-        CompleteMatchSig _ (L ispan names) typ ->
-          [ locOnly ispan
-          , toHie $ map (C Use) names
-          , toHie $ fmap (C Use) typ
-          ]
-        XSig _ -> []
-
-instance ToHie (TScoped (LocatedA (HsSigType GhcRn))) where
-  toHie (TS tsc (L span t@HsSig{sig_bndrs=bndrs,sig_body=body})) = concatM $ makeNodeA t span :
-      [ toHie (TVS tsc (mkScopeA span) bndrs)
-      , toHie body
-      ]
-
--- Check this
-instance Data flag => ToHie (TVScoped (HsOuterTyVarBndrs flag GhcRn)) where
-  toHie (TVS tsc sc bndrs) = case bndrs of
-    HsOuterImplicit xs -> bindingsOnly $ map (C $ TyVarBind sc tsc) xs
-    HsOuterExplicit _ xs -> toHie $ tvScopes tsc sc xs
-
-instance ToHie (LocatedA (HsType GhcRn)) where
-  toHie (L span t) = concatM $ makeNode t (locA span) : case t of
-      HsForAllTy _ tele body ->
-        let scope = mkScope $ getLocA body in
-        [ case tele of
-            HsForAllVis { hsf_vis_bndrs = bndrs } ->
-              toHie $ tvScopes (ResolvedScopes []) scope bndrs
-            HsForAllInvis { hsf_invis_bndrs = bndrs } ->
-              toHie $ tvScopes (ResolvedScopes []) scope bndrs
-        , toHie body
-        ]
-      HsQualTy _ ctx body ->
-        [ toHie ctx
-        , toHie body
-        ]
-      HsTyVar _ _ var ->
-        [ toHie $ C Use var
-        ]
-      HsAppTy _ a b ->
-        [ toHie a
-        , toHie b
-        ]
-      HsAppKindTy _ ty ki ->
-        [ toHie ty
-        , toHie ki
-        ]
-      HsFunTy _ w a b ->
-        [ toHie (arrowToHsType w)
-        , toHie a
-        , toHie b
-        ]
-      HsListTy _ a ->
-        [ toHie a
-        ]
-      HsTupleTy _ _ tys ->
-        [ toHie tys
-        ]
-      HsSumTy _ tys ->
-        [ toHie tys
-        ]
-      HsOpTy _ _prom a op b ->
-        [ toHie a
-        , toHie $ C Use op
-        , toHie b
-        ]
-      HsParTy _ a ->
-        [ toHie a
-        ]
-      HsIParamTy _ ip ty ->
-        [ toHie ip
-        , toHie ty
-        ]
-      HsKindSig _ a b ->
-        [ toHie a
-        , toHie b
-        ]
-      HsSpliceTy _ a ->
-        [ toHie $ L span a
-        ]
-      HsDocTy _ a doc ->
-        [ toHie a
-        , toHie doc
-        ]
-      HsBangTy _ _ ty ->
-        [ toHie ty
-        ]
-      HsRecTy _ fields ->
-        [ toHie fields
-        ]
-      HsExplicitListTy _ _ tys ->
-        [ toHie tys
-        ]
-      HsExplicitTupleTy _ tys ->
-        [ toHie tys
-        ]
-      HsTyLit _ _ -> []
-      HsWildCardTy _ -> []
-      HsStarTy _ _ -> []
-      XHsType _ -> []
-
-instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
-  toHie (HsValArg tm) = toHie tm
-  toHie (HsTypeArg _ ty) = toHie ty
-  toHie (HsArgPar sp) = locOnly sp
-
-instance Data flag => ToHie (TVScoped (LocatedA (HsTyVarBndr flag GhcRn))) where
-  toHie (TVS tsc sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of
-      UserTyVar _ _ var ->
-        [ toHie $ C (TyVarBind sc tsc) var
-        ]
-      KindedTyVar _ _ var kind ->
-        [ toHie $ C (TyVarBind sc tsc) var
-        , toHie kind
-        ]
-
-instance ToHie (TScoped (LHsQTyVars GhcRn)) where
-  toHie (TS sc (HsQTvs implicits vars)) = concatM $
-    [ bindingsOnly bindings
-    , toHie $ tvScopes sc NoScope vars
-    ]
-    where
-      varLoc = loc vars
-      bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
-
-instance ToHie (LocatedC [LocatedA (HsType GhcRn)]) where
-  toHie (L span tys) = concatM $
-      [ locOnly (locA span)
-      , toHie tys
-      ]
-
-instance ToHie (LocatedA (ConDeclField GhcRn)) where
-  toHie (L span field) = concatM $ makeNode field (locA span) : case field of
-      ConDeclField _ fields typ doc ->
-        [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
-        , toHie typ
-        , toHie doc
-        ]
-
-instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
-  toHie (From expr) = toHie expr
-  toHie (FromThen a b) = concatM $
-    [ toHie a
-    , toHie b
-    ]
-  toHie (FromTo a b) = concatM $
-    [ toHie a
-    , toHie b
-    ]
-  toHie (FromThenTo a b c) = concatM $
-    [ toHie a
-    , toHie b
-    , toHie c
-    ]
-
-instance ToHie (LocatedA (SpliceDecl GhcRn)) where
-  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
-      SpliceDecl _ splice _ ->
-        [ toHie splice
-        ]
-
-instance ToHie (HsQuote GhcRn) where
-  toHie (ExpBr _ e)  = toHie e
-  toHie (PatBr _ b)  = toHie (PS Nothing NoScope NoScope b)
-  toHie (DecBrL {} ) = pure []
-  toHie (DecBrG _ decls) = processGrp decls
-  toHie (TypBr _ ty) = toHie ty
-  toHie (VarBr {} )  = pure []
-
-instance ToHie PendingRnSplice where
-  toHie (PendingRnSplice _ _ e) = toHie e
-
-instance ToHie PendingTcSplice where
-  toHie (PendingTcSplice _ e) = toHie e
-
-instance ToHie (LBooleanFormula (LocatedN Name)) where
-  toHie (L span form) = concatM $ makeNode form (locA span) : case form of
-      Var a ->
-        [ toHie $ C Use a
-        ]
-      And forms ->
-        [ toHie forms
-        ]
-      Or forms ->
-        [ toHie forms
-        ]
-      Parens f ->
-        [ toHie f
-        ]
-
-instance ToHie (LocatedAn NoEpAnns HsIPName) where
-  toHie (L span e) = makeNodeA e span
-
-instance HiePass p => ToHie (LocatedA (HsUntypedSplice (GhcPass p))) where
-  toHie (L span sp) = concatM $ makeNodeA sp span : case sp of
-      HsUntypedSpliceExpr _ expr ->
-        [ toHie expr
-        ]
-      HsQuasiQuote _ _ ispanFs ->
-        [ locOnly (getLocA ispanFs)
-        ]
-
-instance ToHie (LocatedA (RoleAnnotDecl GhcRn)) where
-  toHie (L span annot) = concatM $ makeNodeA annot span : case annot of
-      RoleAnnotDecl _ var roles ->
-        [ toHie $ C Use var
-        , concatMapM (locOnly . getLocA) roles
-        ]
-
-instance ToHie (LocatedA (InstDecl GhcRn)) where
-  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
-      ClsInstD _ d ->
-        [ toHie $ L span d
-        ]
-      DataFamInstD _ d ->
-        [ toHie $ L span d
-        ]
-      TyFamInstD _ d ->
-        [ toHie $ L span d
-        ]
-
-instance ToHie (LocatedA (ClsInstDecl GhcRn)) where
-  toHie (L span decl) = concatM
-    [ toHie $ TS (ResolvedScopes [mkScopeA span]) $ cid_poly_ty decl
-    , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
-    , toHie $ map (SC $ SI InstSig $ getRealSpanA span) $ cid_sigs decl
-    , concatMapM (locOnly . getLocA) $ cid_tyfam_insts decl
-    , toHie $ cid_tyfam_insts decl
-    , concatMapM (locOnly . getLocA) $ cid_datafam_insts decl
-    , toHie $ cid_datafam_insts decl
-    , toHie $ cid_overlap_mode decl
-    ]
-
-instance ToHie (LocatedA (DataFamInstDecl GhcRn)) where
-  toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScopeA sp]) d
-
-instance ToHie (LocatedA (TyFamInstDecl GhcRn)) where
-  toHie (L sp (TyFamInstDecl _ d)) = toHie $ TS (ResolvedScopes [mkScopeA sp]) d
-
-instance HiePass p => ToHie (Context (FieldOcc (GhcPass p))) where
-  toHie (C c (FieldOcc n (L l _))) = case hiePass @p of
-    HieTc -> toHie (C c (L l n))
-    HieRn -> toHie (C c (L l n))
-
-instance HiePass p => ToHie (PatSynFieldContext (RecordPatSynField (GhcPass p))) where
-  toHie (PSC sp (RecordPatSynField a b)) = concatM $
-    [ toHie $ C (RecField RecFieldDecl sp) a
-    , toHie $ C Use b
-    ]
-
-instance ToHie (LocatedA (DerivDecl GhcRn)) where
-  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
-      DerivDecl _ typ strat overlap ->
-        [ toHie $ TS (ResolvedScopes []) typ
-        , toHie $ (RS (mkScopeA span) <$> strat)
-        , toHie overlap
-        ]
-
-instance ToHie (LocatedA (FixitySig GhcRn)) where
-  toHie (L span sig) = concatM $ makeNodeA sig span : case sig of
-      FixitySig _ vars _ ->
-        [ toHie $ map (C Use) vars
-        ]
-
-instance ToHie (LocatedA (DefaultDecl GhcRn)) where
-  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
-      DefaultDecl _ typs ->
-        [ toHie typs
-        ]
-
-instance ToHie (LocatedA (ForeignDecl GhcRn)) where
-  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
-      ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->
-        [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpanA span) name
-        , toHie $ TS (ResolvedScopes []) sig
-        , toHie fi
-        ]
-      ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->
-        [ toHie $ C Use name
-        , toHie $ TS (ResolvedScopes []) sig
-        , toHie fe
-        ]
-
-instance ToHie (ForeignImport GhcRn) where
-  toHie (CImport (L c _) (L a _) (L b _) _ _) = concatM $
-    [ locOnly a
-    , locOnly b
-    , locOnly c
-    ]
-
-instance ToHie (ForeignExport GhcRn) where
-  toHie (CExport (L b _) (L a _)) = concatM $
-    [ locOnly a
-    , locOnly b
-    ]
-
-instance ToHie (LocatedA (WarnDecls GhcRn)) where
-  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
-      Warnings _ warnings ->
-        [ toHie warnings
-        ]
-
-instance ToHie (LocatedA (WarnDecl GhcRn)) where
-  toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of
-      Warning _ vars _ ->
-        [ toHie $ map (C Use) vars
-        ]
-
-instance ToHie (LocatedA (AnnDecl GhcRn)) where
-  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
-      HsAnnotation _ prov expr ->
-        [ toHie prov
-        , toHie expr
-        ]
-
-instance ToHie (AnnProvenance GhcRn) where
-  toHie (ValueAnnProvenance a) = toHie $ C Use a
-  toHie (TypeAnnProvenance a) = toHie $ C Use a
-  toHie ModuleAnnProvenance = pure []
-
-instance ToHie (LocatedA (RuleDecls GhcRn)) where
-  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of
-      HsRules _ rules ->
-        [ toHie rules
-        ]
-
-instance ToHie (LocatedA (RuleDecl GhcRn)) where
-  toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
-        [ makeNodeA r span
-        , locOnly $ getLocA rname
-        , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
-        , toHie $ map (RS $ mkScope (locA span)) bndrs
-        , toHie exprA
-        , toHie exprB
-        ]
-    where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
-          bndrs_sc = maybe NoScope mkLScopeA (listToMaybe bndrs)
-          exprA_sc = mkLScopeA exprA
-          exprB_sc = mkLScopeA exprB
-
-instance ToHie (RScoped (LocatedAn NoEpAnns (RuleBndr GhcRn))) where
-  toHie (RS sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of
-      RuleBndr _ var ->
-        [ toHie $ C (ValBind RegularBind sc Nothing) var
-        ]
-      RuleBndrSig _ var typ ->
-        [ toHie $ C (ValBind RegularBind sc Nothing) var
-        , toHie $ TS (ResolvedScopes [sc]) typ
-        ]
-
-instance ToHie (LocatedA (ImportDecl GhcRn)) where
-  toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of
-      ImportDecl { ideclName = name, ideclAs = as, ideclImportList = hidden } ->
-        [ toHie $ IEC Import name
-        , toHie $ fmap (IEC ImportAs) as
-        , maybe (pure []) goIE hidden
-        ]
-    where
-      goIE (hiding, (L sp liens)) = concatM $
-        [ locOnly (locA sp)
-        , toHie $ map (IEC c) liens
-        ]
-        where
-         -- ROMES:TODO: I notice some overlap here with Iface types, eventually
-         -- we could join these
-         c = case hiding of
-               Exactly -> Import
-               EverythingBut -> ImportHiding
-
-
-instance ToHie (IEContext (LocatedA (IE GhcRn))) where
-  toHie (IEC c (L span ie)) = concatM $ makeNode ie (locA span) : case ie of
-      IEVar _ n ->
-        [ toHie $ IEC c n
-        ]
-      IEThingAbs _ n ->
-        [ toHie $ IEC c n
-        ]
-      IEThingAll _ n ->
-        [ toHie $ IEC c n
-        ]
-      IEThingWith flds n _ ns ->
-        [ toHie $ IEC c n
-        , toHie $ map (IEC c) ns
-        , toHie $ map (IEC c) flds
-        ]
-      IEModuleContents _ n ->
-        [ toHie $ IEC c n
-        ]
-      IEGroup _ _ d -> [toHie d]
-      IEDoc _ d -> [toHie d]
-      IEDocNamed _ _ -> []
-
-instance ToHie (IEContext (LocatedA (IEWrappedName GhcRn))) where
-  toHie (IEC c (L span iewn)) = concatM $ makeNodeA iewn span : case iewn of
-      IEName _ (L l n) ->
-        [ toHie $ C (IEThing c) (L l n)
-        ]
-      IEPattern _ (L l p) ->
-        [ toHie $ C (IEThing c) (L l p)
-        ]
-      IEType _ (L l n) ->
-        [ toHie $ C (IEThing c) (L l n)
-        ]
-
-instance ToHie (IEContext (Located FieldLabel)) where
-  toHie (IEC c (L span lbl)) = concatM
-      [ makeNode lbl span
-      , toHie $ C (IEThing c) $ L span (flSelector lbl)
-      ]
-
-instance ToHie (LocatedA (DocDecl GhcRn)) where
-  toHie (L span d) = concatM $ makeNodeA d span : case d of
-    DocCommentNext d -> [ toHie d ]
-    DocCommentPrev d -> [ toHie d ]
-    DocCommentNamed _ d -> [ toHie d ]
-    DocGroup _ d -> [ toHie d ]
-
-instance ToHie (LHsDoc GhcRn) where
-  toHie (L span d@(WithHsDocIdentifiers _ ids)) = concatM $ makeNode d span : [toHie $ map (C Use) ids]
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
deleted file mode 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ /dev/null
@@ -1,362 +0,0 @@
-{-
-Binary serialization for .hie files.
--}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE BangPatterns #-}
-
-module GHC.Iface.Ext.Binary
-   ( readHieFile
-   , readHieFileWithVersion
-   , HieHeader
-   , writeHieFile
-   , HieName(..)
-   , toHieName
-   , HieFileResult(..)
-   , hieMagic
-   , hieNameOcc
-   )
-where
-
-import GHC.Settings.Utils         ( maybeRead )
-import GHC.Settings.Config        ( cProjectVersion )
-import GHC.Prelude
-import GHC.Utils.Binary
-import GHC.Data.FastMutInt
-import GHC.Data.FastString        ( FastString )
-import GHC.Types.Name
-import GHC.Types.Name.Cache
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Builtin.Utils
-import GHC.Types.SrcLoc as SrcLoc
-import GHC.Types.Unique
-import GHC.Types.Unique.FM
-
-import qualified Data.Array        as A
-import qualified Data.Array.IO     as A
-import qualified Data.Array.Unsafe as A
-import Data.IORef
-import Data.ByteString            ( ByteString )
-import qualified Data.ByteString  as BS
-import qualified Data.ByteString.Char8 as BSC
-import Data.Word                  ( Word8, Word32 )
-import Control.Monad              ( replicateM, when, forM_ )
-import System.Directory           ( createDirectoryIfMissing )
-import System.FilePath            ( takeDirectory )
-
-import GHC.Iface.Ext.Types
-
-data HieSymbolTable = HieSymbolTable
-  { hie_symtab_next :: !FastMutInt
-  , hie_symtab_map  :: !(IORef (UniqFM Name (Int, HieName)))
-  }
-
-data HieDictionary = HieDictionary
-  { hie_dict_next :: !FastMutInt -- The next index to use
-  , hie_dict_map  :: !(IORef (UniqFM FastString (Int,FastString))) -- indexed by FastString
-  }
-
-initBinMemSize :: Int
-initBinMemSize = 1024*1024
-
--- | The header for HIE files - Capital ASCII letters \"HIE\".
-hieMagic :: [Word8]
-hieMagic = [72,73,69]
-
-hieMagicLen :: Int
-hieMagicLen = length hieMagic
-
-ghcVersion :: ByteString
-ghcVersion = BSC.pack cProjectVersion
-
-putBinLine :: BinHandle -> ByteString -> IO ()
-putBinLine bh xs = do
-  mapM_ (putByte bh) $ BS.unpack xs
-  putByte bh 10 -- newline char
-
--- | Write a `HieFile` to the given `FilePath`, with a proper header and
--- symbol tables for `Name`s and `FastString`s
-writeHieFile :: FilePath -> HieFile -> IO ()
-writeHieFile hie_file_path hiefile = do
-  bh0 <- openBinMem initBinMemSize
-
-  -- Write the header: hieHeader followed by the
-  -- hieVersion and the GHC version used to generate this file
-  mapM_ (putByte bh0) hieMagic
-  putBinLine bh0 $ BSC.pack $ show hieVersion
-  putBinLine bh0 $ ghcVersion
-
-  -- remember where the dictionary pointer will go
-  dict_p_p <- tellBin bh0
-  put_ bh0 dict_p_p
-
-  -- remember where the symbol table pointer will go
-  symtab_p_p <- tellBin bh0
-  put_ bh0 symtab_p_p
-
-  -- Make some initial state
-  symtab_next <- newFastMutInt 0
-  symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName)))
-  let hie_symtab = HieSymbolTable {
-                      hie_symtab_next = symtab_next,
-                      hie_symtab_map  = symtab_map }
-  dict_next_ref <- newFastMutInt 0
-  dict_map_ref <- newIORef emptyUFM
-  let hie_dict = HieDictionary {
-                      hie_dict_next = dict_next_ref,
-                      hie_dict_map  = dict_map_ref }
-
-  -- put the main thing
-  let bh = setUserData bh0 $ newWriteState (putName hie_symtab)
-                                           (putName hie_symtab)
-                                           (putFastString hie_dict)
-  put_ bh hiefile
-
-  -- write the symtab pointer at the front of the file
-  symtab_p <- tellBin bh
-  putAt bh symtab_p_p symtab_p
-  seekBin bh symtab_p
-
-  -- write the symbol table itself
-  symtab_next' <- readFastMutInt symtab_next
-  symtab_map'  <- readIORef symtab_map
-  putSymbolTable bh symtab_next' symtab_map'
-
-  -- write the dictionary pointer at the front of the file
-  dict_p <- tellBin bh
-  putAt bh dict_p_p dict_p
-  seekBin bh dict_p
-
-  -- write the dictionary itself
-  dict_next <- readFastMutInt dict_next_ref
-  dict_map  <- readIORef dict_map_ref
-  putDictionary bh dict_next dict_map
-
-  -- and send the result to the file
-  createDirectoryIfMissing True (takeDirectory hie_file_path)
-  writeBinMem bh hie_file_path
-  return ()
-
-data HieFileResult
-  = HieFileResult
-  { hie_file_result_version :: Integer
-  , hie_file_result_ghc_version :: ByteString
-  , hie_file_result :: HieFile
-  }
-
-type HieHeader = (Integer, ByteString)
-
--- | Read a `HieFile` from a `FilePath`. Can use
--- an existing `NameCache`. Allows you to specify
--- which versions of hieFile to attempt to read.
--- `Left` case returns the failing header versions.
-readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader HieFileResult)
-readHieFileWithVersion readVersion name_cache file = do
-  bh0 <- readBinMem file
-
-  (hieVersion, ghcVersion) <- readHieFileHeader file bh0
-
-  if readVersion (hieVersion, ghcVersion)
-  then do
-    hieFile <- readHieFileContents bh0 name_cache
-    return $ Right (HieFileResult hieVersion ghcVersion hieFile)
-  else return $ Left (hieVersion, ghcVersion)
-
-
--- | Read a `HieFile` from a `FilePath`. Can use
--- an existing `NameCache`.
-readHieFile :: NameCache -> FilePath -> IO HieFileResult
-readHieFile name_cache file = do
-
-  bh0 <- readBinMem file
-
-  (readHieVersion, ghcVersion) <- readHieFileHeader file bh0
-
-  -- Check if the versions match
-  when (readHieVersion /= hieVersion) $
-    panic $ unwords ["readHieFile: hie file versions don't match for file:"
-                    , file
-                    , "Expected"
-                    , show hieVersion
-                    , "but got", show readHieVersion
-                    ]
-  hieFile <- readHieFileContents bh0 name_cache
-  return $ HieFileResult hieVersion ghcVersion hieFile
-
-readBinLine :: BinHandle -> IO ByteString
-readBinLine bh = BS.pack . reverse <$> loop []
-  where
-    loop acc = do
-      char <- get bh :: IO Word8
-      if char == 10 -- ASCII newline '\n'
-      then return acc
-      else loop (char : acc)
-
-readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader
-readHieFileHeader file bh0 = do
-  -- Read the header
-  magic <- replicateM hieMagicLen (get bh0)
-  version <- BSC.unpack <$> readBinLine bh0
-  case maybeRead version of
-    Nothing ->
-      panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:"
-                      , show version
-                      ]
-    Just readHieVersion -> do
-      ghcVersion <- readBinLine bh0
-
-      -- Check if the header is valid
-      when (magic /= hieMagic) $
-        panic $ unwords ["readHieFileHeader: headers don't match for file:"
-                        , file
-                        , "Expected"
-                        , show hieMagic
-                        , "but got", show magic
-                        ]
-      return (readHieVersion, ghcVersion)
-
-readHieFileContents :: BinHandle -> NameCache -> IO HieFile
-readHieFileContents bh0 name_cache = do
-  dict <- get_dictionary bh0
-  -- read the symbol table so we are capable of reading the actual data
-  bh1 <- do
-      let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
-                                               (getDictFastString dict)
-      symtab <- get_symbol_table bh1
-      let bh1' = setUserData bh1
-               $ newReadState (getSymTabName symtab)
-                              (getDictFastString dict)
-      return bh1'
-
-  -- load the actual data
-  get bh1
-  where
-    get_dictionary bin_handle = do
-      dict_p <- get bin_handle
-      data_p <- tellBin bin_handle
-      seekBin bin_handle dict_p
-      dict <- getDictionary bin_handle
-      seekBin bin_handle data_p
-      return dict
-
-    get_symbol_table bh1 = do
-      symtab_p <- get bh1
-      data_p'  <- tellBin bh1
-      seekBin bh1 symtab_p
-      symtab <- getSymbolTable bh1 name_cache
-      seekBin bh1 data_p'
-      return symtab
-
-putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
-putFastString HieDictionary { hie_dict_next = j_r,
-                              hie_dict_map  = out_r}  bh f
-  = do
-    out <- readIORef out_r
-    let !unique = getUnique f
-    case lookupUFM_Directly out unique of
-        Just (j, _)  -> put_ bh (fromIntegral j :: Word32)
-        Nothing -> do
-           j <- readFastMutInt j_r
-           put_ bh (fromIntegral j :: Word32)
-           writeFastMutInt j_r (j + 1)
-           writeIORef out_r $! addToUFM_Directly out unique (j, f)
-
-putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,HieName) -> IO ()
-putSymbolTable bh next_off symtab = do
-  put_ bh next_off
-  let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))
-  mapM_ (putHieName bh) names
-
-getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
-getSymbolTable bh name_cache = do
-  sz <- get bh
-  mut_arr <- A.newArray_ (0, sz-1) :: IO (A.IOArray Int Name)
-  forM_ [0..(sz-1)] $ \i -> do
-    od_name <- getHieName bh
-    name <- fromHieName name_cache od_name
-    A.writeArray mut_arr i name
-  A.unsafeFreeze mut_arr
-
-getSymTabName :: SymbolTable -> BinHandle -> IO Name
-getSymTabName st bh = do
-  i :: Word32 <- get bh
-  return $ st A.! (fromIntegral i)
-
-putName :: HieSymbolTable -> BinHandle -> Name -> IO ()
-putName (HieSymbolTable next ref) bh name = do
-  symmap <- readIORef ref
-  case lookupUFM symmap name of
-    Just (off, ExternalName mod occ (UnhelpfulSpan _))
-      | isGoodSrcSpan (nameSrcSpan name) -> do
-      let hieName = ExternalName mod occ (nameSrcSpan name)
-      writeIORef ref $! addToUFM symmap name (off, hieName)
-      put_ bh (fromIntegral off :: Word32)
-    Just (off, LocalName _occ span)
-      | notLocal (toHieName name) || nameSrcSpan name /= span -> do
-      writeIORef ref $! addToUFM symmap name (off, toHieName name)
-      put_ bh (fromIntegral off :: Word32)
-    Just (off, _) -> put_ bh (fromIntegral off :: Word32)
-    Nothing -> do
-        off <- readFastMutInt next
-        writeFastMutInt next (off+1)
-        writeIORef ref $! addToUFM symmap name (off, toHieName name)
-        put_ bh (fromIntegral off :: Word32)
-
-  where
-    notLocal :: HieName -> Bool
-    notLocal LocalName{} = False
-    notLocal _ = True
-
-
--- ** Converting to and from `HieName`'s
-
-fromHieName :: NameCache -> HieName -> IO Name
-fromHieName nc hie_name = do
-
-  case hie_name of
-    ExternalName mod occ span -> updateNameCache nc mod occ $ \cache -> do
-      case lookupOrigNameCache cache mod occ of
-        Just name -> pure (cache, name)
-        Nothing   -> do
-          uniq <- takeUniqFromNameCache nc
-          let name       = mkExternalName uniq mod occ span
-              new_cache  = extendOrigNameCache cache mod occ name
-          pure (new_cache, name)
-
-    LocalName occ span -> do
-      uniq <- takeUniqFromNameCache nc
-      -- don't update the NameCache for local names
-      pure $ mkInternalName uniq occ span
-
-    KnownKeyName u -> case lookupKnownKeyName u of
-      Nothing -> pprPanic "fromHieName:unknown known-key unique"
-                          (ppr u)
-      Just n -> pure n
-
--- ** Reading and writing `HieName`'s
-
-putHieName :: BinHandle -> HieName -> IO ()
-putHieName bh (ExternalName mod occ span) = do
-  putByte bh 0
-  put_ bh (mod, occ, BinSrcSpan span)
-putHieName bh (LocalName occName span) = do
-  putByte bh 1
-  put_ bh (occName, BinSrcSpan span)
-putHieName bh (KnownKeyName uniq) = do
-  putByte bh 2
-  put_ bh $ unpkUnique uniq
-
-getHieName :: BinHandle -> IO HieName
-getHieName bh = do
-  t <- getByte bh
-  case t of
-    0 -> do
-      (modu, occ, span) <- get bh
-      return $ ExternalName modu occ $ unBinSrcSpan span
-    1 -> do
-      (occ, span) <- get bh
-      return $ LocalName occ $ unBinSrcSpan span
-    2 -> do
-      (c,i) <- get bh
-      return $ KnownKeyName $ mkUnique c i
-    _ -> panic "GHC.Iface.Ext.Binary.getHieName: invalid tag"
diff --git a/compiler/GHC/Iface/Ext/Debug.hs b/compiler/GHC/Iface/Ext/Debug.hs
deleted file mode 100644
--- a/compiler/GHC/Iface/Ext/Debug.hs
+++ /dev/null
@@ -1,158 +0,0 @@
-{-# LANGUAGE FlexibleContexts   #-}
-{-# LANGUAGE OverloadedStrings  #-}
-
-{-
-Functions to validate and check .hie file ASTs generated by GHC.
--}
-
-module GHC.Iface.Ext.Debug where
-
-import GHC.Prelude
-
-import GHC.Types.SrcLoc
-import GHC.Unit.Module
-import GHC.Utils.Outputable
-
-import GHC.Iface.Ext.Types
-import GHC.Iface.Ext.Utils
-import GHC.Types.Name
-
-import qualified Data.Map as M
-import qualified Data.Set as S
-import Data.Function    ( on )
-import Data.List        ( sortOn )
-
-type Diff a = a -> a -> [SDoc]
-
-diffFile :: Diff HieFile
-diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)
-
-diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map HiePath (HieAST a))
-diffAsts f = diffList (diffAst f) `on` M.elems
-
-diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a)
-diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =
-    infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2
-  where
-    spanDiff
-      | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]]
-      | otherwise = []
-    infoDiff' i1 i2
-      = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) i1 i2
-     ++ (diffList diffType `on` nodeType) i1 i2
-     ++ (diffIdents `on` nodeIdentifiers) i1 i2
-    sinfoDiff = diffList (\(k1,a) (k2,b) -> eqDiff k1 k2 ++ infoDiff' a b) `on` (M.toList . getSourcedNodeInfo)
-    infoDiff = case sinfoDiff info1 info2 of
-      [] -> []
-      xs -> xs ++ [vcat ["In Node:",ppr (sourcedNodeIdents info1,span1)
-                           , "and", ppr (sourcedNodeIdents info2,span2)
-                        , "While comparing"
-                        , ppr (normalizeIdents $ sourcedNodeIdents info1), "and"
-                        , ppr (normalizeIdents $ sourcedNodeIdents info2)
-                        ]
-                  ]
-
-    diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b
-    diffIdent (a,b) (c,d) = diffName a c
-                         ++ eqDiff b d
-    diffName (Right a) (Right b) = case (a,b) of
-      (ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o')
-      (LocalName o _, ExternalName _ o' _) -> eqDiff o o'
-      _ -> eqDiff a b
-    diffName a b = eqDiff a b
-
-type DiffIdent = Either ModuleName HieName
-
-normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]
-normalizeIdents = sortOn go . map (first toHieName) . M.toList
-  where
-    first f (a,b) = (fmap f a, b)
-    go (a,b) = (hieNameOcc <$> a,identInfo b,identType b)
-
-diffList :: Diff a -> Diff [a]
-diffList f xs ys
-  | length xs == length ys = concat $ zipWith f xs ys
-  | otherwise = ["length of lists doesn't match"]
-
-eqDiff :: (Outputable a, Eq a) => Diff a
-eqDiff a b
-  | a == b = []
-  | otherwise = [hsep [ppr a, "and", ppr b, "do not match"]]
-
-validAst :: HieAST a -> Either SDoc ()
-validAst (Node _ span children) = do
-  checkContainment children
-  checkSorted children
-  mapM_ validAst children
-  where
-    checkSorted [] = return ()
-    checkSorted [_] = return ()
-    checkSorted (x:y:xs)
-      | nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs)
-      | otherwise = Left $ hsep
-          [ ppr $ nodeSpan x
-          , "is not to the left of"
-          , ppr $ nodeSpan y
-          ]
-    checkContainment [] = return ()
-    checkContainment (x:xs)
-      | span `containsSpan` (nodeSpan x) = checkContainment xs
-      | otherwise = Left $ hsep
-          [ ppr $ span
-          , "does not contain"
-          , ppr $ nodeSpan x
-          ]
-
--- | Look for any identifiers which occur outside of their supposed scopes.
--- Returns a list of error messages.
-validateScopes :: Module -> M.Map HiePath (HieAST a) -> [SDoc]
-validateScopes mod asts = validScopes ++ validEvs
-  where
-    refMap = generateReferencesMap asts
-    -- We use a refmap for most of the computation
-
-    evs = M.keys
-      $ M.filter (any isEvidenceContext . concatMap (S.toList . identInfo . snd)) refMap
-
-    validEvs = do
-      i@(Right ev) <- evs
-      case M.lookup i refMap of
-        Nothing -> ["Impossible, ev"<+> ppr ev <+> "not found in refmap" ]
-        Just refs
-          | nameIsLocalOrFrom mod ev
-          , not (any isEvidenceBind . concatMap (S.toList . identInfo . snd) $ refs)
-          -> ["Evidence var" <+> ppr ev <+> "not bound in refmap"]
-          | otherwise -> []
-
-    -- Check if all the names occur in their calculated scopes
-    validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap
-    valid (Left _) _ = []
-    valid (Right n) refs = concatMap inScope refs
-      where
-        mapRef = foldMap getScopeFromContext . identInfo . snd
-        scopes = case foldMap mapRef refs of
-          Just xs -> xs
-          Nothing -> []
-        inScope (sp, dets)
-          |  (definedInAsts asts n || (any isEvidenceContext (identInfo dets)))
-          && any isOccurrence (identInfo dets)
-          -- We validate scopes for names which are defined locally, and occur
-          -- in this span, or are evidence variables
-            = case scopes of
-              [] | nameIsLocalOrFrom mod n
-                  , (  not (isDerivedOccName $ nameOccName n)
-                    || any isEvidenceContext (identInfo dets))
-                   -- If we don't get any scopes for a local name or
-                   -- an evidence variable, then its an error.
-                   -- We can ignore other kinds of derived names as
-                   -- long as we take evidence vars into account
-                   -> return $ hsep $
-                     [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp
-                     , "Doesn't have a calculated scope: ", ppr scopes]
-                 | otherwise -> []
-              _ -> if any (`scopeContainsSpan` sp) scopes
-                   then []
-                   else return $ hsep $
-                     [ "Name", ppr n, pprDefinedAt n, "at position", ppr sp
-                     , "doesn't occur in calculated scope", ppr scopes]
-          | otherwise = []
diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs
deleted file mode 100644
--- a/compiler/GHC/Iface/Ext/Types.hs
+++ /dev/null
@@ -1,785 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable         #-}
-{-# LANGUAGE DeriveTraversable          #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE PatternSynonyms            #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-
-{-
-Types for the .hie file format are defined here.
-
-For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files
--}
-
-module GHC.Iface.Ext.Types where
-
-import GHC.Prelude
-
-import GHC.Settings.Config
-import GHC.Utils.Binary
-import GHC.Data.FastString
-import GHC.Builtin.Utils
-import GHC.Iface.Type
-import GHC.Unit.Module            ( ModuleName, Module )
-import GHC.Types.Name
-import GHC.Utils.Outputable hiding ( (<>) )
-import GHC.Types.SrcLoc
-import GHC.Types.Avail
-import GHC.Types.Unique
-import qualified GHC.Utils.Outputable as O ( (<>) )
-import GHC.Utils.Panic
-
-import qualified Data.Array as A
-import qualified Data.Map as M
-import qualified Data.Set as S
-import Data.ByteString            ( ByteString )
-import Data.Data                  ( Typeable, Data )
-import Data.Semigroup             ( Semigroup(..) )
-import Data.Word                  ( Word8 )
-import Control.Applicative        ( (<|>) )
-import Data.Coerce                ( coerce  )
-import Data.Function              ( on )
-import qualified Data.Semigroup as S
-
-type Span = RealSrcSpan
-
--- | Current version of @.hie@ files
-hieVersion :: Integer
-hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer
-
-{- |
-GHC builds up a wealth of information about Haskell source as it compiles it.
-@.hie@ files are a way of persisting some of this information to disk so that
-external tools that need to work with haskell source don't need to parse,
-typecheck, and rename all over again. These files contain:
-
-  * a simplified AST
-
-       * nodes are annotated with source positions and types
-       * identifiers are annotated with scope information
-
-  * the raw bytes of the initial Haskell source
-
-Besides saving compilation cycles, @.hie@ files also offer a more stable
-interface than the GHC API.
--}
-data HieFile = HieFile
-    { hie_hs_file :: FilePath
-    -- ^ Initial Haskell source file path
-
-    , hie_module :: Module
-    -- ^ The module this HIE file is for
-
-    , hie_types :: A.Array TypeIndex HieTypeFlat
-    -- ^ Types referenced in the 'hie_asts'.
-    --
-    -- See Note [Efficient serialization of redundant type info]
-
-    , hie_asts :: HieASTs TypeIndex
-    -- ^ Type-annotated abstract syntax trees
-
-    , hie_exports :: [AvailInfo]
-    -- ^ The names that this module exports
-
-    , hie_hs_src :: ByteString
-    -- ^ Raw bytes of the initial Haskell source
-    }
-instance Binary HieFile where
-  put_ bh hf = do
-    put_ bh $ hie_hs_file hf
-    put_ bh $ hie_module hf
-    put_ bh $ hie_types hf
-    put_ bh $ hie_asts hf
-    put_ bh $ hie_exports hf
-    put_ bh $ hie_hs_src hf
-
-  get bh = HieFile
-    <$> get bh
-    <*> get bh
-    <*> get bh
-    <*> get bh
-    <*> get bh
-    <*> get bh
-
-
-{-
-Note [Efficient serialization of redundant type info]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The type information in .hie files is highly repetitive and redundant. For
-example, consider the expression
-
-    const True 'a'
-
-There is a lot of shared structure between the types of subterms:
-
-  * const True 'a' ::                 Bool
-  * const True     ::         Char -> Bool
-  * const          :: Bool -> Char -> Bool
-
-Since all 3 of these types need to be stored in the .hie file, it is worth
-making an effort to deduplicate this shared structure. The trick is to define
-a new data type that is a flattened version of 'Type':
-
-    data HieType a = HAppTy a a  -- data Type = AppTy Type Type
-                   | HFunTy a a  --           | FunTy Type Type
-                   | ...
-
-    type TypeIndex = Int
-
-Types in the final AST are stored in an 'A.Array TypeIndex (HieType TypeIndex)',
-where the 'TypeIndex's in the 'HieType' are references to other elements of the
-array. Types recovered from GHC are deduplicated and stored in this compressed
-form with sharing of subtrees.
--}
-
-type TypeIndex = Int
-
--- | A flattened version of 'Type'.
---
--- See Note [Efficient serialization of redundant type info]
-data HieType a
-  = HTyVarTy Name
-  | HAppTy a (HieArgs a)
-  | HTyConApp IfaceTyCon (HieArgs a)
-  | HForAllTy ((Name, a),ForAllTyFlag) a
-  | HFunTy a a a
-  | HQualTy a a           -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy')
-  | HLitTy IfaceTyLit
-  | HCastTy a
-  | HCoercionTy
-    deriving (Functor, Foldable, Traversable, Eq)
-
-type HieTypeFlat = HieType TypeIndex
-
--- | Roughly isomorphic to the original core 'Type'.
-newtype HieTypeFix = Roll (HieType (HieTypeFix))
-  deriving Eq
-
-instance Binary (HieType TypeIndex) where
-  put_ bh (HTyVarTy n) = do
-    putByte bh 0
-    put_ bh n
-  put_ bh (HAppTy a b) = do
-    putByte bh 1
-    put_ bh a
-    put_ bh b
-  put_ bh (HTyConApp n xs) = do
-    putByte bh 2
-    put_ bh n
-    put_ bh xs
-  put_ bh (HForAllTy bndr a) = do
-    putByte bh 3
-    put_ bh bndr
-    put_ bh a
-  put_ bh (HFunTy w a b) = do
-    putByte bh 4
-    put_ bh w
-    put_ bh a
-    put_ bh b
-  put_ bh (HQualTy a b) = do
-    putByte bh 5
-    put_ bh a
-    put_ bh b
-  put_ bh (HLitTy l) = do
-    putByte bh 6
-    put_ bh l
-  put_ bh (HCastTy a) = do
-    putByte bh 7
-    put_ bh a
-  put_ bh (HCoercionTy) = putByte bh 8
-
-  get bh = do
-    (t :: Word8) <- get bh
-    case t of
-      0 -> HTyVarTy <$> get bh
-      1 -> HAppTy <$> get bh <*> get bh
-      2 -> HTyConApp <$> get bh <*> get bh
-      3 -> HForAllTy <$> get bh <*> get bh
-      4 -> HFunTy <$> get bh <*> get bh <*> get bh
-      5 -> HQualTy <$> get bh <*> get bh
-      6 -> HLitTy <$> get bh
-      7 -> HCastTy <$> get bh
-      8 -> return HCoercionTy
-      _ -> panic "Binary (HieArgs Int): invalid tag"
-
-
--- | A list of type arguments along with their respective visibilities (ie. is
--- this an argument that would return 'True' for 'isVisibleForAllTyFlag'?).
-newtype HieArgs a = HieArgs [(Bool,a)]
-  deriving (Functor, Foldable, Traversable, Eq)
-
-instance Binary (HieArgs TypeIndex) where
-  put_ bh (HieArgs xs) = put_ bh xs
-  get bh = HieArgs <$> get bh
-
-
--- A HiePath is just a lexical FastString. We use a lexical FastString to avoid
--- non-determinism when printing or storing HieASTs which are sorted by their
--- HiePath.
-type HiePath = LexicalFastString
-
-{-# COMPLETE HiePath #-}
-pattern HiePath :: FastString -> HiePath
-pattern HiePath fs = LexicalFastString fs
-
--- | Mapping from filepaths to the corresponding AST
-newtype HieASTs a = HieASTs { getAsts :: M.Map HiePath (HieAST a) }
-  deriving (Functor, Foldable, Traversable)
-
-instance Binary (HieASTs TypeIndex) where
-  put_ bh asts = put_ bh $ M.toAscList $ getAsts asts
-  get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh)
-
-instance Outputable a => Outputable (HieASTs a) where
-  ppr (HieASTs asts) = M.foldrWithKey go "" asts
-    where
-      go k a rest = vcat $
-        [ "File: " O.<> ppr k
-        , ppr a
-        , rest
-        ]
-
-data HieAST a =
-  Node
-    { sourcedNodeInfo :: SourcedNodeInfo a
-    , nodeSpan :: Span
-    , nodeChildren :: [HieAST a]
-    } deriving (Functor, Foldable, Traversable)
-
-instance Binary (HieAST TypeIndex) where
-  put_ bh ast = do
-    put_ bh $ sourcedNodeInfo ast
-    put_ bh $ BinSpan $ nodeSpan ast
-    put_ bh $ nodeChildren ast
-
-  get bh = Node
-    <$> get bh
-    <*> (unBinSpan <$> get bh)
-    <*> get bh
-
-instance Outputable a => Outputable (HieAST a) where
-  ppr (Node ni sp ch) = hang header 2 rest
-    where
-      header = text "Node@" O.<> ppr sp O.<> ":" <+> ppr ni
-      rest = vcat (map ppr ch)
-
-
--- | NodeInfos grouped by source
-newtype SourcedNodeInfo a = SourcedNodeInfo { getSourcedNodeInfo :: (M.Map NodeOrigin (NodeInfo a)) }
-  deriving (Functor, Foldable, Traversable)
-
-instance Binary (SourcedNodeInfo TypeIndex) where
-  put_ bh asts = put_ bh $ M.toAscList $ getSourcedNodeInfo asts
-  get bh = SourcedNodeInfo <$> fmap M.fromDistinctAscList (get bh)
-
-instance Outputable a => Outputable (SourcedNodeInfo a) where
-  ppr (SourcedNodeInfo asts) = M.foldrWithKey go "" asts
-    where
-      go k a rest = vcat $
-        [ "Source: " O.<> ppr k
-        , ppr a
-        , rest
-        ]
-
--- | Source of node info
-data NodeOrigin
-  = SourceInfo
-  | GeneratedInfo
-    deriving (Eq, Enum, Ord)
-
-instance Outputable NodeOrigin where
-  ppr SourceInfo = text "From source"
-  ppr GeneratedInfo = text "generated by ghc"
-
-instance Binary NodeOrigin where
-  put_ bh b = putByte bh (fromIntegral (fromEnum b))
-  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
-
--- | A node annotation
-data NodeAnnotation = NodeAnnotation
-   { nodeAnnotConstr :: !FastString -- ^ name of the AST node constructor
-   , nodeAnnotType   :: !FastString -- ^ name of the AST node Type
-   }
-   deriving (Eq)
-
-instance Ord NodeAnnotation where
-   compare (NodeAnnotation c0 t0) (NodeAnnotation c1 t1)
-      = mconcat [lexicalCompareFS c0 c1, lexicalCompareFS t0 t1]
-
-instance Outputable NodeAnnotation where
-   ppr (NodeAnnotation c t) = ppr (c,t)
-
-instance Binary NodeAnnotation where
-  put_ bh (NodeAnnotation c t) = do
-    put_ bh c
-    put_ bh t
-  get bh = NodeAnnotation
-    <$> get bh
-    <*> get bh
-
--- | The information stored in one AST node.
---
--- The type parameter exists to provide flexibility in representation of types
--- (see Note [Efficient serialization of redundant type info]).
-data NodeInfo a = NodeInfo
-    { nodeAnnotations :: S.Set NodeAnnotation
-    -- ^ Annotations
-
-    , nodeType :: [a]
-    -- ^ The Haskell types of this node, if any.
-
-    , nodeIdentifiers :: NodeIdentifiers a
-    -- ^ All the identifiers and their details
-    } deriving (Functor, Foldable, Traversable)
-
-instance Binary (NodeInfo TypeIndex) where
-  put_ bh ni = do
-    put_ bh $ S.toAscList $ nodeAnnotations ni
-    put_ bh $ nodeType ni
-    put_ bh $ M.toList $ nodeIdentifiers ni
-  get bh = NodeInfo
-    <$> fmap (S.fromDistinctAscList) (get bh)
-    <*> get bh
-    <*> fmap (M.fromList) (get bh)
-
-instance Outputable a => Outputable (NodeInfo a) where
-  ppr (NodeInfo anns typs idents) = braces $ fsep $ punctuate ", "
-    [ parens (text "annotations:" <+> ppr anns)
-    , parens (text "types:" <+> ppr typs)
-    , parens (text "identifier info:" <+> pprNodeIdents idents)
-    ]
-
-pprNodeIdents :: Outputable a => NodeIdentifiers a -> SDoc
-pprNodeIdents ni = braces $ fsep $ punctuate ", " $ map go $ M.toList ni
-  where
-    go (i,id) = parens $ hsep $ punctuate ", " [pprIdentifier i, ppr id]
-
-pprIdentifier :: Identifier -> SDoc
-pprIdentifier (Left mod) = text "module" <+> ppr mod
-pprIdentifier (Right name) = text "name" <+> ppr name
-
-type Identifier = Either ModuleName Name
-
-type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a)
-
--- | Information associated with every identifier
---
--- We need to include types with identifiers because sometimes multiple
--- identifiers occur in the same span(Overloaded Record Fields and so on)
-data IdentifierDetails a = IdentifierDetails
-  { identType :: Maybe a
-  , identInfo :: S.Set ContextInfo
-  } deriving (Eq, Functor, Foldable, Traversable)
-
-instance Outputable a => Outputable (IdentifierDetails a) where
-  ppr x = text "Details: " <+> ppr (identType x) <+> ppr (identInfo x)
-
-instance Semigroup (IdentifierDetails a) where
-  d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2)
-                               (S.union (identInfo d1) (identInfo d2))
-
-instance Monoid (IdentifierDetails a) where
-  mempty = IdentifierDetails Nothing S.empty
-
-instance Binary (IdentifierDetails TypeIndex) where
-  put_ bh dets = do
-    put_ bh $ identType dets
-    put_ bh $ S.toList $ identInfo dets
-  get bh =  IdentifierDetails
-    <$> get bh
-    <*> fmap S.fromDistinctAscList (get bh)
-
-
--- | Different contexts under which identifiers exist
-data ContextInfo
-  = Use                -- ^ regular variable
-  | MatchBind
-  | IEThing IEType     -- ^ import/export
-  | TyDecl
-
-  -- | Value binding
-  | ValBind
-      BindType     -- ^ whether or not the binding is in an instance
-      Scope        -- ^ scope over which the value is bound
-      (Maybe Span) -- ^ span of entire binding
-
-  -- | Pattern binding
-  --
-  -- This case is tricky because the bound identifier can be used in two
-  -- distinct scopes. Consider the following example (with @-XViewPatterns@)
-  --
-  -- @
-  -- do (b, a, (a -> True)) <- bar
-  --    foo a
-  -- @
-  --
-  -- The identifier @a@ has two scopes: in the view pattern @(a -> True)@ and
-  -- in the rest of the @do@-block in @foo a@.
-  | PatternBind
-      Scope        -- ^ scope /in the pattern/ (the variable bound can be used
-                   -- further in the pattern)
-      Scope        -- ^ rest of the scope outside the pattern
-      (Maybe Span) -- ^ span of entire binding
-
-  | ClassTyDecl (Maybe Span)
-
-  -- | Declaration
-  | Decl
-      DeclType     -- ^ type of declaration
-      (Maybe Span) -- ^ span of entire binding
-
-  -- | Type variable
-  | TyVarBind Scope TyVarScope
-
-  -- | Record field
-  | RecField RecFieldContext (Maybe Span)
-  -- | Constraint/Dictionary evidence variable binding
-  | EvidenceVarBind
-      EvVarSource  -- ^ how did this bind come into being
-      Scope        -- ^ scope over which the value is bound
-      (Maybe Span) -- ^ span of the binding site
-
-  -- | Usage of evidence variable
-  | EvidenceVarUse
-    deriving (Eq, Ord)
-
-instance Outputable ContextInfo where
- ppr (Use) = text "usage"
- ppr (MatchBind) = text "LHS of a match group"
- ppr (IEThing x) = ppr x
- ppr (TyDecl) = text "bound in a type signature declaration"
- ppr (ValBind t sc sp) =
-   ppr t <+> text "value bound with scope:" <+> ppr sc <+> pprBindSpan sp
- ppr (PatternBind sc1 sc2 sp) =
-   text "bound in a pattern with scope:"
-     <+> ppr sc1 <+> "," <+> ppr sc2
-     <+> pprBindSpan sp
- ppr (ClassTyDecl sp) =
-   text "bound in a class type declaration" <+> pprBindSpan sp
- ppr (Decl d sp) =
-   text "declaration of" <+> ppr d <+> pprBindSpan sp
- ppr (TyVarBind sc1 sc2) =
-   text "type variable binding with scope:"
-     <+> ppr sc1 <+> "," <+> ppr sc2
- ppr (RecField ctx sp) =
-   text "record field" <+> ppr ctx <+> pprBindSpan sp
- ppr (EvidenceVarBind ctx sc sp) =
-   text "evidence variable" <+> ppr ctx
-     $$ "with scope:" <+> ppr sc
-     $$ pprBindSpan sp
- ppr (EvidenceVarUse) =
-   text "usage of evidence variable"
-
-pprBindSpan :: Maybe Span -> SDoc
-pprBindSpan Nothing = text ""
-pprBindSpan (Just sp) = text "bound at:" <+> ppr sp
-
-instance Binary ContextInfo where
-  put_ bh Use = putByte bh 0
-  put_ bh (IEThing t) = do
-    putByte bh 1
-    put_ bh t
-  put_ bh TyDecl = putByte bh 2
-  put_ bh (ValBind bt sc msp) = do
-    putByte bh 3
-    put_ bh bt
-    put_ bh sc
-    put_ bh $ BinSpan <$> msp
-  put_ bh (PatternBind a b c) = do
-    putByte bh 4
-    put_ bh a
-    put_ bh b
-    put_ bh $ BinSpan <$> c
-  put_ bh (ClassTyDecl sp) = do
-    putByte bh 5
-    put_ bh $ BinSpan <$> sp
-  put_ bh (Decl a b) = do
-    putByte bh 6
-    put_ bh a
-    put_ bh $ BinSpan <$> b
-  put_ bh (TyVarBind a b) = do
-    putByte bh 7
-    put_ bh a
-    put_ bh b
-  put_ bh (RecField a b) = do
-    putByte bh 8
-    put_ bh a
-    put_ bh $ BinSpan <$> b
-  put_ bh MatchBind = putByte bh 9
-  put_ bh (EvidenceVarBind a b c) = do
-    putByte bh 10
-    put_ bh a
-    put_ bh b
-    put_ bh $ BinSpan <$> c
-  put_ bh EvidenceVarUse = putByte bh 11
-
-  get bh = do
-    (t :: Word8) <- get bh
-    case t of
-      0 -> return Use
-      1 -> IEThing <$> get bh
-      2 -> return TyDecl
-      3 -> ValBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh)
-      4 -> PatternBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh)
-      5 -> ClassTyDecl <$> (fmap unBinSpan <$> get bh)
-      6 -> Decl <$> get bh <*> (fmap unBinSpan <$> get bh)
-      7 -> TyVarBind <$> get bh <*> get bh
-      8 -> RecField <$> get bh <*> (fmap unBinSpan <$> get bh)
-      9 -> return MatchBind
-      10 -> EvidenceVarBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh)
-      11 -> return EvidenceVarUse
-      _ -> panic "Binary ContextInfo: invalid tag"
-
-data EvVarSource
-  = EvPatternBind -- ^ bound by a pattern match
-  | EvSigBind -- ^ bound by a type signature
-  | EvWrapperBind -- ^ bound by a hswrapper
-  | EvImplicitBind -- ^ bound by an implicit variable
-  | EvInstBind { isSuperInst :: Bool, cls :: Name } -- ^ Bound by some instance of given class
-  | EvLetBind EvBindDeps -- ^ A direct let binding
-  deriving (Eq,Ord)
-
-instance Binary EvVarSource where
-  put_ bh EvPatternBind = putByte bh 0
-  put_ bh EvSigBind = putByte bh 1
-  put_ bh EvWrapperBind = putByte bh 2
-  put_ bh EvImplicitBind = putByte bh 3
-  put_ bh (EvInstBind b cls) = do
-    putByte bh 4
-    put_ bh b
-    put_ bh cls
-  put_ bh (EvLetBind deps) = do
-    putByte bh 5
-    put_ bh deps
-
-  get bh = do
-    (t :: Word8) <- get bh
-    case t of
-      0 -> pure EvPatternBind
-      1 -> pure EvSigBind
-      2 -> pure EvWrapperBind
-      3 -> pure EvImplicitBind
-      4 -> EvInstBind <$> get bh <*> get bh
-      5 -> EvLetBind <$> get bh
-      _ -> panic "Binary EvVarSource: invalid tag"
-
-instance Outputable EvVarSource where
-  ppr EvPatternBind = text "bound by a pattern"
-  ppr EvSigBind = text "bound by a type signature"
-  ppr EvWrapperBind = text "bound by a HsWrapper"
-  ppr EvImplicitBind = text "bound by an implicit variable binding"
-  ppr (EvInstBind False cls) = text "bound by an instance of class" <+> ppr cls
-  ppr (EvInstBind True cls) = text "bound due to a superclass of " <+> ppr cls
-  ppr (EvLetBind deps) = text "bound by a let, depending on:" <+> ppr deps
-
--- | Eq/Ord instances compare on the converted HieName,
--- as non-exported names may have different uniques after
--- a roundtrip
-newtype EvBindDeps = EvBindDeps { getEvBindDeps :: [Name] }
-  deriving Outputable
-
-instance Eq EvBindDeps where
-  (==) = coerce ((==) `on` map toHieName)
-
-instance Ord EvBindDeps where
-  compare = coerce (compare `on` map toHieName)
-
-instance Binary EvBindDeps where
-  put_ bh (EvBindDeps xs) = put_ bh xs
-  get bh = EvBindDeps <$> get bh
-
-
--- | Types of imports and exports
-data IEType
-  = Import
-  | ImportAs
-  | ImportHiding
-  | Export
-    deriving (Eq, Enum, Ord)
-
-instance Outputable IEType where
-  ppr Import = text "import"
-  ppr ImportAs = text "import as"
-  ppr ImportHiding = text "import hiding"
-  ppr Export = text "export"
-
-instance Binary IEType where
-  put_ bh b = putByte bh (fromIntegral (fromEnum b))
-  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
-
-
-data RecFieldContext
-  = RecFieldDecl
-  | RecFieldAssign
-  | RecFieldMatch
-  | RecFieldOcc
-    deriving (Eq, Enum, Ord)
-
-instance Outputable RecFieldContext where
-  ppr RecFieldDecl = text "declaration"
-  ppr RecFieldAssign = text "assignment"
-  ppr RecFieldMatch = text "pattern match"
-  ppr RecFieldOcc = text "occurrence"
-
-instance Binary RecFieldContext where
-  put_ bh b = putByte bh (fromIntegral (fromEnum b))
-  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
-
-
-data BindType
-  = RegularBind
-  | InstanceBind
-    deriving (Eq, Ord, Enum)
-
-instance Outputable BindType where
-  ppr RegularBind = "regular"
-  ppr InstanceBind = "instance"
-
-instance Binary BindType where
-  put_ bh b = putByte bh (fromIntegral (fromEnum b))
-  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
-
-data DeclType
-  = FamDec     -- ^ type or data family
-  | SynDec     -- ^ type synonym
-  | DataDec    -- ^ data declaration
-  | ConDec     -- ^ constructor declaration
-  | PatSynDec  -- ^ pattern synonym
-  | ClassDec   -- ^ class declaration
-  | InstDec    -- ^ instance declaration
-    deriving (Eq, Ord, Enum)
-
-instance Outputable DeclType where
-  ppr FamDec = text "type or data family"
-  ppr SynDec = text "type synonym"
-  ppr DataDec = text "data"
-  ppr ConDec = text "constructor"
-  ppr PatSynDec = text "pattern synonym"
-  ppr ClassDec = text "class"
-  ppr InstDec = text "instance"
-
-instance Binary DeclType where
-  put_ bh b = putByte bh (fromIntegral (fromEnum b))
-  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
-
-data Scope
-  = NoScope
-  | LocalScope Span
-  | ModuleScope
-    deriving (Eq, Ord, Typeable, Data)
-
-instance Outputable Scope where
-  ppr NoScope = text "NoScope"
-  ppr (LocalScope sp) = text "LocalScope" <+> ppr sp
-  ppr ModuleScope = text "ModuleScope"
-
-instance Binary Scope where
-  put_ bh NoScope = putByte bh 0
-  put_ bh (LocalScope span) = do
-    putByte bh 1
-    put_ bh $ BinSpan span
-  put_ bh ModuleScope = putByte bh 2
-
-  get bh = do
-    (t :: Word8) <- get bh
-    case t of
-      0 -> return NoScope
-      1 -> LocalScope . unBinSpan <$> get bh
-      2 -> return ModuleScope
-      _ -> panic "Binary Scope: invalid tag"
-
-
--- | Scope of a type variable.
---
--- This warrants a data type apart from 'Scope' because of complexities
--- introduced by features like @-XScopedTypeVariables@ and @-XInstanceSigs@. For
--- example, consider:
---
--- @
--- foo, bar, baz :: forall a. a -> a
--- @
---
--- Here @a@ is in scope in all the definitions of @foo@, @bar@, and @baz@, so we
--- need a list of scopes to keep track of this. Furthermore, this list cannot be
--- computed until we resolve the binding sites of @foo@, @bar@, and @baz@.
---
--- Consequently, @a@ starts with an @'UnresolvedScope' [foo, bar, baz] Nothing@
--- which later gets resolved into a 'ResolvedScopes'.
-data TyVarScope
-  = ResolvedScopes [Scope]
-
-  -- | Unresolved scopes should never show up in the final @.hie@ file
-  | UnresolvedScope
-        [Name]        -- ^ names of the definitions over which the scope spans
-        (Maybe Span)  -- ^ the location of the instance/class declaration for
-                      -- the case where the type variable is declared in a
-                      -- method type signature
-    deriving (Eq, Ord)
-
-instance Outputable TyVarScope where
-  ppr (ResolvedScopes xs) =
-    text "type variable scopes:" <+> hsep (punctuate ", " $ map ppr xs)
-  ppr (UnresolvedScope ns sp) =
-    text "unresolved type variable scope for name" O.<> plural ns
-      <+> pprBindSpan sp
-
-instance Binary TyVarScope where
-  put_ bh (ResolvedScopes xs) = do
-    putByte bh 0
-    put_ bh xs
-  put_ bh (UnresolvedScope ns span) = do
-    putByte bh 1
-    put_ bh ns
-    put_ bh (BinSpan <$> span)
-
-  get bh = do
-    (t :: Word8) <- get bh
-    case t of
-      0 -> ResolvedScopes <$> get bh
-      1 -> UnresolvedScope <$> get bh <*> (fmap unBinSpan <$> get bh)
-      _ -> panic "Binary TyVarScope: invalid tag"
-
--- | `Name`'s get converted into `HieName`'s before being written into @.hie@
--- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
--- these two types.
-data HieName
-  = ExternalName !Module !OccName !SrcSpan
-  | LocalName !OccName !SrcSpan
-  | KnownKeyName !Unique
-  deriving (Eq)
-
-instance Ord HieName where
-  compare (ExternalName a b c) (ExternalName d e f) = compare (a,b) (d,e) S.<> leftmost_smallest c f
-    -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
-  compare (LocalName a b) (LocalName c d) = compare a c S.<> leftmost_smallest b d
-    -- TODO (int-index): Perhaps use RealSrcSpan in HieName?
-  compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
-    -- Not actually non deterministic as it is a KnownKey
-  compare ExternalName{} _ = LT
-  compare LocalName{} ExternalName{} = GT
-  compare LocalName{} _ = LT
-  compare KnownKeyName{} _ = GT
-
-instance Outputable HieName where
-  ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
-  ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
-  ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
-
-hieNameOcc :: HieName -> OccName
-hieNameOcc (ExternalName _ occ _) = occ
-hieNameOcc (LocalName occ _) = occ
-hieNameOcc (KnownKeyName u) =
-  case lookupKnownKeyName u of
-    Just n -> nameOccName n
-    Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
-                        (ppr u)
-
-toHieName :: Name -> HieName
-toHieName name
-  | isKnownKeyName name = KnownKeyName (nameUnique name)
-  | isExternalName name = ExternalName (nameModule name)
-                                       (nameOccName name)
-                                       (removeBufSpan $ nameSrcSpan name)
-  | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name)
diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/Iface/Ext/Utils.hs
+++ /dev/null
@@ -1,604 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE DeriveFunctor #-}
-module GHC.Iface.Ext.Utils where
-
-import GHC.Prelude
-
-import GHC.Core.Map.Type
-import GHC.Driver.Session    ( DynFlags )
-import GHC.Driver.Ppr
-import GHC.Data.FastString   ( FastString, mkFastString )
-import GHC.Iface.Type
-import GHC.Types.Name hiding (varName)
-import GHC.Types.Name.Set
-import GHC.Utils.Outputable hiding ( (<>) )
-import qualified GHC.Utils.Outputable as O
-import GHC.Types.SrcLoc
-import GHC.CoreToIface
-import GHC.Core.TyCon
-import GHC.Core.TyCo.Rep
-import GHC.Core.TyCo.Compare( nonDetCmpType )
-import GHC.Core.Type
-import GHC.Types.Var
-import GHC.Types.Var.Env
-import GHC.Parser.Annotation
-import qualified GHC.Data.Strict as Strict
-
-import GHC.Iface.Ext.Types
-
-import qualified Data.Map as M
-import qualified Data.Set as S
-import qualified Data.IntMap.Strict as IM
-import qualified Data.Array as A
-import Data.Data                  ( typeOf, typeRepTyCon, Data(toConstr) )
-import Data.Maybe                 ( maybeToList, mapMaybe)
-import Data.Monoid
-import Data.List                  (find)
-import Data.Traversable           ( for )
-import Data.Coerce
-import GHC.Utils.Monad.State.Strict hiding (get)
-import GHC.Utils.Panic.Plain( assert )
-import Control.Monad.Trans.Reader
-import qualified Data.Tree as Tree
-
-type RefMap a = M.Map Identifier [(Span, IdentifierDetails a)]
-
-generateReferencesMap
-  :: Foldable f
-  => f (HieAST a)
-  -> RefMap a
-generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty
-  where
-    go ast = M.unionsWith (++) (this : map go (nodeChildren ast))
-      where
-        this = fmap (pure . (nodeSpan ast,)) $ sourcedNodeIdents $ sourcedNodeInfo ast
-
-renderHieType :: DynFlags -> HieTypeFix -> String
-renderHieType dflags ht = showSDoc dflags (ppr $ hieTypeToIface ht)
-
-resolveVisibility :: Type -> [Type] -> [(Bool,Type)]
-resolveVisibility kind ty_args
-  = go (mkEmptySubst in_scope) kind ty_args
-  where
-    in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)
-
-    go _   _                   []     = []
-    go env ty                  ts
-      | Just ty' <- coreView ty
-      = go env ty' ts
-    go env (ForAllTy (Bndr tv vis) res) (t:ts)
-      | isVisibleForAllTyFlag vis = (True , t) : ts'
-      | otherwise                 = (False, t) : ts'
-      where
-        ts' = go (extendTvSubst env tv t) res ts
-
-    go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps
-      = (True,t) : (go env res ts)
-
-    go env (TyVarTy tv) ts
-      | Just ki <- lookupTyVar env tv = go env ki ts
-    go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded
-
-foldType :: (HieType a -> a) -> HieTypeFix -> a
-foldType f (Roll t) = f $ fmap (foldType f) t
-
-selectPoint :: HieFile -> (Int,Int) -> Maybe (HieAST Int)
-selectPoint hf (sl,sc) = getFirst $
-  flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(HiePath fs,ast) -> First $
-      case selectSmallestContaining (sp fs) ast of
-        Nothing -> Nothing
-        Just ast' -> Just ast'
- where
-   sloc fs = mkRealSrcLoc fs sl sc
-   sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
-
-findEvidenceUse :: NodeIdentifiers a -> [Name]
-findEvidenceUse ni = [n | (Right n, dets) <- xs, any isEvidenceUse (identInfo dets)]
- where
-   xs = M.toList ni
-
-data EvidenceInfo a
-  = EvidenceInfo
-  { evidenceVar :: Name
-  , evidenceSpan :: RealSrcSpan
-  , evidenceType :: a
-  , evidenceDetails :: Maybe (EvVarSource, Scope, Maybe Span)
-  } deriving (Eq,Ord,Functor)
-
-instance (Outputable a) => Outputable (EvidenceInfo a) where
-  ppr (EvidenceInfo name span typ dets) =
-    hang (ppr name <+> text "at" <+> ppr span O.<> text ", of type:" <+> ppr typ) 4 $
-      pdets $$ (pprDefinedAt name)
-    where
-      pdets = case dets of
-        Nothing -> text "is a usage of an external evidence variable"
-        Just (src,scp,spn) -> text "is an" <+> ppr (EvidenceVarBind src scp spn)
-
-getEvidenceTreesAtPoint :: HieFile -> RefMap a -> (Int,Int) -> Tree.Forest (EvidenceInfo a)
-getEvidenceTreesAtPoint hf refmap point =
-  [t | Just ast <- pure $ selectPoint hf point
-     , n        <- findEvidenceUse (sourcedNodeIdents $ sourcedNodeInfo ast)
-     , Just t   <- pure $ getEvidenceTree refmap n
-     ]
-
-getEvidenceTree :: RefMap a -> Name -> Maybe (Tree.Tree (EvidenceInfo a))
-getEvidenceTree refmap var = go emptyNameSet var
-  where
-    go seen var
-      | var `elemNameSet` seen = Nothing
-      | otherwise = do
-          xs <- M.lookup (Right var) refmap
-          case find (any isEvidenceBind . identInfo . snd) xs of
-            Just (sp,dets) -> do
-              typ <- identType dets
-              (evdet,children) <- getFirst $ foldMap First $ do
-                 det <- S.toList $ identInfo dets
-                 case det of
-                   EvidenceVarBind src@(EvLetBind (getEvBindDeps -> xs)) scp spn ->
-                     pure $ Just ((src,scp,spn),mapMaybe (go $ extendNameSet seen var) xs)
-                   EvidenceVarBind src scp spn -> pure $ Just ((src,scp,spn),[])
-                   _ -> pure Nothing
-              pure $ Tree.Node (EvidenceInfo var sp typ (Just evdet)) children
-            -- It is externally bound
-            Nothing -> getFirst $ foldMap First $ do
-              (sp,dets) <- xs
-              if (any isEvidenceUse $ identInfo dets)
-                then do
-                  case identType dets of
-                    Nothing -> pure Nothing
-                    Just typ -> pure $ Just $ Tree.Node (EvidenceInfo var sp typ Nothing) []
-                else pure Nothing
-
-hieTypeToIface :: HieTypeFix -> IfaceType
-hieTypeToIface = foldType go
-  where
-    go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n
-    go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)
-    go (HLitTy l) = IfaceLitTy l
-    go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)
-                                  in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
-    go (HFunTy w a b)   = IfaceFunTy visArgTypeLike   w       a    b
-    go (HQualTy pred b) = IfaceFunTy invisArgTypeLike many_ty pred b
-    go (HCastTy a) = a
-    go HCoercionTy = IfaceTyVar "<coercion type>"
-    go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
-
-    -- This isn't fully faithful - we can't produce the 'Inferred' case
-    hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs
-    hieToIfaceArgs (HieArgs xs) = go' xs
-      where
-        go' [] = IA_Nil
-        go' ((True ,x):xs) = IA_Arg x Required $ go' xs
-        go' ((False,x):xs) = IA_Arg x Specified $ go' xs
-
-data HieTypeState
-  = HTS
-    { tyMap      :: !(TypeMap TypeIndex)
-    , htyTable   :: !(IM.IntMap HieTypeFlat)
-    , freshIndex :: !TypeIndex
-    }
-
-initialHTS :: HieTypeState
-initialHTS = HTS emptyTypeMap IM.empty 0
-
-freshTypeIndex :: State HieTypeState TypeIndex
-freshTypeIndex = do
-  index <- gets freshIndex
-  modify $ \hts -> hts { freshIndex = index+1 }
-  return index
-
-compressTypes
-  :: HieASTs Type
-  -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
-compressTypes asts = (a, arr)
-  where
-    (a, (HTS _ m i)) = flip runState initialHTS $
-      for asts $ \typ ->
-        getTypeIndex typ
-    arr = A.array (0,i-1) (IM.toList m)
-
-recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix
-recoverFullType i m = go i
-  where
-    go i = Roll $ fmap go (m A.! i)
-
-getTypeIndex :: Type -> State HieTypeState TypeIndex
-getTypeIndex t
-  | otherwise = do
-      tm <- gets tyMap
-      case lookupTypeMap tm t of
-        Just i -> return i
-        Nothing -> do
-          ht <- go t
-          extendHTS t ht
-  where
-    extendHTS t ht = do
-      i <- freshTypeIndex
-      modify $ \(HTS tm tt fi) ->
-        HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi
-      return i
-
-    go (TyVarTy v) = return $ HTyVarTy $ varName v
-    go ty@(AppTy _ _) = do
-      let (head,args) = splitAppTys ty
-          visArgs = HieArgs $ resolveVisibility (typeKind head) args
-      ai <- getTypeIndex head
-      argsi <- mapM getTypeIndex visArgs
-      return $ HAppTy ai argsi
-    go (TyConApp f xs) = do
-      let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs
-      is <- mapM getTypeIndex visArgs
-      return $ HTyConApp (toIfaceTyCon f) is
-    go (ForAllTy (Bndr v a) t) = do
-      k <- getTypeIndex (varType v)
-      i <- getTypeIndex t
-      return $ HForAllTy ((varName v,k),a) i
-    go (FunTy { ft_af = af, ft_mult = w, ft_arg = a, ft_res = b }) = do
-      ai <- getTypeIndex a
-      bi <- getTypeIndex b
-      wi <- getTypeIndex w
-      return $ if isInvisibleFunArg af
-               then assert (isManyTy w) $ HQualTy ai bi
-               else                       HFunTy wi ai bi
-    go (LitTy a) = return $ HLitTy $ toIfaceTyLit a
-    go (CastTy t _) = do
-      i <- getTypeIndex t
-      return $ HCastTy i
-    go (CoercionTy _) = return HCoercionTy
-
-resolveTyVarScopes :: M.Map HiePath (HieAST a) -> M.Map HiePath (HieAST a)
-resolveTyVarScopes asts = M.map go asts
-  where
-    go ast = resolveTyVarScopeLocal ast asts
-
-resolveTyVarScopeLocal :: HieAST a -> M.Map HiePath (HieAST a) -> HieAST a
-resolveTyVarScopeLocal ast asts = go ast
-  where
-    resolveNameScope dets = dets{identInfo =
-      S.map resolveScope (identInfo dets)}
-    resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) =
-      TyVarBind sc $ ResolvedScopes
-        [ LocalScope binding
-        | name <- names
-        , Just binding <- [getNameBinding name asts]
-        ]
-    resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) =
-      TyVarBind sc $ ResolvedScopes
-        [ LocalScope binding
-        | name <- names
-        , Just binding <- [getNameBindingInClass name sp asts]
-        ]
-    resolveScope scope = scope
-    go (Node info span children) = Node info' span $ map go children
-      where
-        info' = SourcedNodeInfo (updateNodeInfo <$> getSourcedNodeInfo info)
-        updateNodeInfo i = i { nodeIdentifiers = idents }
-          where
-            idents = M.map resolveNameScope $ nodeIdentifiers i
-
-getNameBinding :: Name -> M.Map HiePath (HieAST a) -> Maybe Span
-getNameBinding n asts = do
-  (_,msp) <- getNameScopeAndBinding n asts
-  msp
-
-getNameScope :: Name -> M.Map HiePath (HieAST a) -> Maybe [Scope]
-getNameScope n asts = do
-  (scopes,_) <- getNameScopeAndBinding n asts
-  return scopes
-
-getNameBindingInClass
-  :: Name
-  -> Span
-  -> M.Map HiePath (HieAST a)
-  -> Maybe Span
-getNameBindingInClass n sp asts = do
-  ast <- M.lookup (HiePath (srcSpanFile sp)) asts
-  clsNode <- selectLargestContainedBy sp ast
-  getFirst $ foldMap First $ do
-    child <- flattenAst clsNode
-    dets <- maybeToList
-      $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo child
-    let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
-    return (getFirst binding)
-
-getNameScopeAndBinding
-  :: Name
-  -> M.Map HiePath (HieAST a)
-  -> Maybe ([Scope], Maybe Span)
-getNameScopeAndBinding n asts = case nameSrcSpan n of
-  RealSrcSpan sp _ -> do -- @Maybe
-    ast <- M.lookup (HiePath (srcSpanFile sp)) asts
-    defNode <- selectLargestContainedBy sp ast
-    getFirst $ foldMap First $ do -- @[]
-      node <- flattenAst defNode
-      dets <- maybeToList
-        $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo node
-      scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)
-      let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
-      return $ Just (scopes, getFirst binding)
-  _ -> Nothing
-
-getScopeFromContext :: ContextInfo -> Maybe [Scope]
-getScopeFromContext (ValBind _ sc _) = Just [sc]
-getScopeFromContext (PatternBind a b _) = Just [a, b]
-getScopeFromContext (ClassTyDecl _) = Just [ModuleScope]
-getScopeFromContext (Decl _ _) = Just [ModuleScope]
-getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs
-getScopeFromContext (TyVarBind a _) = Just [a]
-getScopeFromContext (EvidenceVarBind _ a _) = Just [a]
-getScopeFromContext _ = Nothing
-
-getBindSiteFromContext :: ContextInfo -> Maybe Span
-getBindSiteFromContext (ValBind _ _ sp) = sp
-getBindSiteFromContext (PatternBind _ _ sp) = sp
-getBindSiteFromContext _ = Nothing
-
-flattenAst :: HieAST a -> [HieAST a]
-flattenAst n =
-  n : concatMap flattenAst (nodeChildren n)
-
-smallestContainingSatisfying
-  :: Span
-  -> (HieAST a -> Bool)
-  -> HieAST a
-  -> Maybe (HieAST a)
-smallestContainingSatisfying sp cond node
-  | nodeSpan node `containsSpan` sp = getFirst $ mconcat
-      [ foldMap (First . smallestContainingSatisfying sp cond) $
-          nodeChildren node
-      , First $ if cond node then Just node else Nothing
-      ]
-  | sp `containsSpan` nodeSpan node = Nothing
-  | otherwise = Nothing
-
-selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a)
-selectLargestContainedBy sp node
-  | sp `containsSpan` nodeSpan node = Just node
-  | nodeSpan node `containsSpan` sp =
-      getFirst $ foldMap (First . selectLargestContainedBy sp) $
-        nodeChildren node
-  | otherwise = Nothing
-
-selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a)
-selectSmallestContaining sp node
-  | nodeSpan node `containsSpan` sp = getFirst $ mconcat
-      [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node
-      , First (Just node)
-      ]
-  | sp `containsSpan` nodeSpan node = Nothing
-  | otherwise = Nothing
-
-definedInAsts :: M.Map HiePath (HieAST a) -> Name -> Bool
-definedInAsts asts n = case nameSrcSpan n of
-  RealSrcSpan sp _ -> M.member (HiePath (srcSpanFile sp)) asts
-  _ -> False
-
-getEvidenceBindDeps :: ContextInfo -> [Name]
-getEvidenceBindDeps (EvidenceVarBind (EvLetBind xs) _ _) =
-  getEvBindDeps xs
-getEvidenceBindDeps _ = []
-
-isEvidenceBind :: ContextInfo -> Bool
-isEvidenceBind EvidenceVarBind{} = True
-isEvidenceBind _ = False
-
-isEvidenceContext :: ContextInfo -> Bool
-isEvidenceContext EvidenceVarUse = True
-isEvidenceContext EvidenceVarBind{} = True
-isEvidenceContext _ = False
-
-isEvidenceUse :: ContextInfo -> Bool
-isEvidenceUse EvidenceVarUse = True
-isEvidenceUse _ = False
-
-isOccurrence :: ContextInfo -> Bool
-isOccurrence Use = True
-isOccurrence EvidenceVarUse = True
-isOccurrence _ = False
-
-scopeContainsSpan :: Scope -> Span -> Bool
-scopeContainsSpan NoScope _ = False
-scopeContainsSpan ModuleScope _ = True
-scopeContainsSpan (LocalScope a) b = a `containsSpan` b
-
--- | One must contain the other. Leaf nodes cannot contain anything
-combineAst :: HieAST Type -> HieAST Type -> HieAST Type
-combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys)
-  | aSpn == bSpn = Node (aInf `combineSourcedNodeInfo` bInf) aSpn (mergeAsts xs ys)
-  | aSpn `containsSpan` bSpn = combineAst b a
-combineAst a (Node xs span children) = Node xs span (insertAst a children)
-
--- | Insert an AST in a sorted list of disjoint Asts
-insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]
-insertAst x = mergeAsts [x]
-
-nodeInfo :: HieAST Type -> NodeInfo Type
-nodeInfo = foldl' combineNodeInfo emptyNodeInfo . getSourcedNodeInfo . sourcedNodeInfo
-
-emptyNodeInfo :: NodeInfo a
-emptyNodeInfo = NodeInfo S.empty [] M.empty
-
-sourcedNodeIdents :: SourcedNodeInfo a -> NodeIdentifiers a
-sourcedNodeIdents = M.unionsWith (<>) . fmap nodeIdentifiers . getSourcedNodeInfo
-
-combineSourcedNodeInfo :: SourcedNodeInfo Type -> SourcedNodeInfo Type -> SourcedNodeInfo Type
-combineSourcedNodeInfo = coerce $ M.unionWith combineNodeInfo
-
--- | Merge two nodes together.
---
--- Precondition and postcondition: elements in 'nodeType' are ordered.
-combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type
-(NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) =
-  NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd)
-  where
-    mergeSorted :: [Type] -> [Type] -> [Type]
-    mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of
-                                        LT -> a : mergeSorted as lb
-                                        EQ -> a : mergeSorted as bs
-                                        GT -> b : mergeSorted la bs
-    mergeSorted as [] = as
-    mergeSorted [] bs = bs
-
-
-{- | Merge two sorted, disjoint lists of ASTs, combining when necessary.
-
-In the absence of position-altering pragmas (ex: @# line "file.hs" 3@),
-different nodes in an AST tree should either have disjoint spans (in
-which case you can say for sure which one comes first) or one span
-should be completely contained in the other (in which case the contained
-span corresponds to some child node).
-
-However, since Haskell does have position-altering pragmas it /is/
-possible for spans to be overlapping. Here is an example of a source file
-in which @foozball@ and @quuuuuux@ have overlapping spans:
-
-@
-module Baz where
-
-# line 3 "Baz.hs"
-foozball :: Int
-foozball = 0
-
-# line 3 "Baz.hs"
-bar, quuuuuux :: Int
-bar = 1
-quuuuuux = 2
-@
-
-In these cases, we just do our best to produce sensible `HieAST`'s. The blame
-should be laid at the feet of whoever wrote the line pragmas in the first place
-(usually the C preprocessor...).
--}
-mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type]
-mergeAsts xs [] = xs
-mergeAsts [] ys = ys
-mergeAsts xs@(a:as) ys@(b:bs)
-  | span_a `containsSpan`   span_b = mergeAsts (combineAst a b : as) bs
-  | span_b `containsSpan`   span_a = mergeAsts as (combineAst a b : bs)
-  | span_a `rightOf`        span_b = b : mergeAsts xs bs
-  | span_a `leftOf`         span_b = a : mergeAsts as ys
-
-  -- These cases are to work around ASTs that are not fully disjoint
-  | span_a `startsRightOf`  span_b = b : mergeAsts as ys
-  | otherwise                      = a : mergeAsts as ys
-  where
-    span_a = nodeSpan a
-    span_b = nodeSpan b
-
-rightOf :: Span -> Span -> Bool
-rightOf s1 s2
-  = (srcSpanStartLine s1, srcSpanStartCol s1)
-       >= (srcSpanEndLine s2, srcSpanEndCol s2)
-    && (srcSpanFile s1 == srcSpanFile s2)
-
-leftOf :: Span -> Span -> Bool
-leftOf s1 s2
-  = (srcSpanEndLine s1, srcSpanEndCol s1)
-       <= (srcSpanStartLine s2, srcSpanStartCol s2)
-    && (srcSpanFile s1 == srcSpanFile s2)
-
-startsRightOf :: Span -> Span -> Bool
-startsRightOf s1 s2
-  = (srcSpanStartLine s1, srcSpanStartCol s1)
-       >= (srcSpanStartLine s2, srcSpanStartCol s2)
-
--- | combines and sorts ASTs using a merge sort
-mergeSortAsts :: [HieAST Type] -> [HieAST Type]
-mergeSortAsts = go . map pure
-  where
-    go [] = []
-    go [xs] = xs
-    go xss = go (mergePairs xss)
-    mergePairs [] = []
-    mergePairs [xs] = [xs]
-    mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss
-
-simpleNodeInfo :: FastString -> FastString -> NodeInfo a
-simpleNodeInfo cons typ = NodeInfo (S.singleton (NodeAnnotation cons typ)) [] M.empty
-
-locOnly :: Monad m => SrcSpan -> ReaderT NodeOrigin m [HieAST a]
-locOnly (RealSrcSpan span _) = do
-  org <- ask
-  let e = mkSourcedNodeInfo org $ emptyNodeInfo
-  pure [Node e span []]
-locOnly _ = pure []
-
-mkScopeA :: SrcSpanAnn' ann -> Scope
-mkScopeA l = mkScope (locA l)
-
-mkScope :: SrcSpan -> Scope
-mkScope (RealSrcSpan sp _) = LocalScope sp
-mkScope _ = NoScope
-
-mkLScope :: Located a -> Scope
-mkLScope = mkScope . getLoc
-
-mkLScopeA :: GenLocated (SrcSpanAnn' a) e -> Scope
-mkLScopeA = mkScope . locA . getLoc
-
-mkLScopeN :: LocatedN a -> Scope
-mkLScopeN = mkScope . getLocA
-
-combineScopes :: Scope -> Scope -> Scope
-combineScopes ModuleScope _ = ModuleScope
-combineScopes _ ModuleScope = ModuleScope
-combineScopes NoScope x = x
-combineScopes x NoScope = x
-combineScopes (LocalScope a) (LocalScope b) =
-  mkScope $ combineSrcSpans (RealSrcSpan a Strict.Nothing) (RealSrcSpan b Strict.Nothing)
-
-mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a
-mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni
-
-{-# INLINEABLE makeNodeA #-}
-makeNodeA
-  :: (Monad m, Data a)
-  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')
-  -> SrcSpanAnn' ann         -- ^ return an empty list if this is unhelpful
-  -> ReaderT NodeOrigin m [HieAST b]
-makeNodeA x spn = makeNode x (locA spn)
-
-{-# INLINEABLE makeNode #-}
-makeNode
-  :: (Monad m, Data a)
-  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')
-  -> SrcSpan                 -- ^ return an empty list if this is unhelpful
-  -> ReaderT NodeOrigin m [HieAST b]
-makeNode x spn = do
-  org <- ask
-  pure $ case spn of
-    RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []]
-    _ -> []
-  where
-    cons = mkFastString . show . toConstr $ x
-    typ = mkFastString . show . typeRepTyCon . typeOf $ x
-
-{-# INLINEABLE makeTypeNodeA #-}
-makeTypeNodeA
-  :: (Monad m, Data a)
-  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')
-  -> SrcSpanAnnA             -- ^ return an empty list if this is unhelpful
-  -> Type                    -- ^ type to associate with the node
-  -> ReaderT NodeOrigin m [HieAST Type]
-makeTypeNodeA x spn etyp = makeTypeNode x (locA spn) etyp
-
-{-# INLINEABLE makeTypeNode #-}
-makeTypeNode
-  :: (Monad m, Data a)
-  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')
-  -> SrcSpan                 -- ^ return an empty list if this is unhelpful
-  -> Type                    -- ^ type to associate with the node
-  -> ReaderT NodeOrigin m [HieAST Type]
-makeTypeNode x spn etyp = do
-  org <- ask
-  pure $ case spn of
-    RealSrcSpan span _ ->
-      [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []]
-    _ -> []
-  where
-    cons = mkFastString . show . toConstr $ x
-    typ = mkFastString . show . typeRepTyCon . typeOf $ x
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
deleted file mode 100644
--- a/compiler/GHC/Iface/Load.hs
+++ /dev/null
@@ -1,1226 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
-{-# LANGUAGE BangPatterns, NondecreasingIndentation #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE ViewPatterns #-}
-
--- | Loading interface files
-module GHC.Iface.Load (
-        -- Importing one thing
-        tcLookupImported_maybe, importDecl,
-        checkWiredInTyCon, ifCheckWiredInThing,
-
-        -- RnM/TcM functions
-        loadModuleInterface, loadModuleInterfaces,
-        loadSrcInterface, loadSrcInterface_maybe,
-        loadInterfaceForName, loadInterfaceForModule,
-
-        -- IfM functions
-        loadInterface,
-        loadSysInterface, loadUserInterface, loadPluginInterface,
-        findAndReadIface, readIface, writeIface,
-        moduleFreeHolesPrecise,
-        needWiredInHomeIface, loadWiredInHomeIface,
-
-        pprModIfaceSimple,
-        ifaceStats, pprModIface, showIface,
-
-        module Iface_Errors -- avoids boot files in Ppr modules
-   ) where
-
-import GHC.Prelude
-
-import GHC.Platform.Profile
-
-import {-# SOURCE #-} GHC.IfaceToCore
-   ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst
-   , tcIfaceAnnotations, tcIfaceCompleteMatches )
-
-import GHC.Driver.Config.Finder
-import GHC.Driver.Env
-import GHC.Driver.Errors.Types
-import GHC.Driver.Session
-import GHC.Driver.Hooks
-import GHC.Driver.Plugins
-
-import GHC.Iface.Syntax
-import GHC.Iface.Ext.Fields
-import GHC.Iface.Binary
-import GHC.Iface.Rename
-import GHC.Iface.Env
-import GHC.Iface.Errors as Iface_Errors
-
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-
-import GHC.Utils.Binary   ( BinData(..) )
-import GHC.Utils.Error
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Constants (debugIsOn)
-import GHC.Utils.Logger
-
-import GHC.Settings.Constants
-
-import GHC.Builtin.Names
-import GHC.Builtin.Utils
-import GHC.Builtin.PrimOps    ( allThePrimOps, primOpFixity, primOpOcc )
-
-import GHC.Core.Rules
-import GHC.Core.TyCon
-import GHC.Core.InstEnv
-import GHC.Core.FamInstEnv
-
-import GHC.Types.Id.Make      ( seqId )
-import GHC.Types.Annotations
-import GHC.Types.Name
-import GHC.Types.Name.Cache
-import GHC.Types.Name.Env
-import GHC.Types.Avail
-import GHC.Types.Fixity
-import GHC.Types.Fixity.Env
-import GHC.Types.SourceError
-import GHC.Types.SourceText
-import GHC.Types.SourceFile
-import GHC.Types.SafeHaskell
-import GHC.Types.TypeEnv
-import GHC.Types.Unique.DSet
-import GHC.Types.SrcLoc
-import GHC.Types.TyThing
-import GHC.Types.PkgQual
-
-import GHC.Unit.External
-import GHC.Unit.Module
-import GHC.Unit.Module.Warnings
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.Deps
-import GHC.Unit.State
-import GHC.Unit.Home
-import GHC.Unit.Home.ModInfo
-import GHC.Unit.Finder
-import GHC.Unit.Env
-
-import GHC.Data.Maybe
-
-import Control.Monad
-import Data.Map ( toList )
-import System.FilePath
-import System.Directory
-import GHC.Driver.Env.KnotVars
-
-{-
-************************************************************************
-*                                                                      *
-*      tcImportDecl is the key function for "faulting in"              *
-*      imported things
-*                                                                      *
-************************************************************************
-
-The main idea is this.  We are chugging along type-checking source code, and
-find a reference to GHC.Base.map.  We call tcLookupGlobal, which doesn't find
-it in the EPS type envt.  So it
-        1 loads GHC.Base.hi
-        2 gets the decl for GHC.Base.map
-        3 typechecks it via tcIfaceDecl
-        4 and adds it to the type env in the EPS
-
-Note that DURING STEP 4, we may find that map's type mentions a type
-constructor that also
-
-Notice that for imported things we read the current version from the EPS
-mutable variable.  This is important in situations like
-        ...$(e1)...$(e2)...
-where the code that e1 expands to might import some defns that
-also turn out to be needed by the code that e2 expands to.
--}
-
-tcLookupImported_maybe :: Name -> TcM (MaybeErr SDoc TyThing)
--- Returns (Failed err) if we can't find the interface file for the thing
-tcLookupImported_maybe name
-  = do  { hsc_env <- getTopEnv
-        ; mb_thing <- liftIO (lookupType hsc_env name)
-        ; case mb_thing of
-            Just thing -> return (Succeeded thing)
-            Nothing    -> tcImportDecl_maybe name }
-
-tcImportDecl_maybe :: Name -> TcM (MaybeErr SDoc TyThing)
--- Entry point for *source-code* uses of importDecl
-tcImportDecl_maybe name
-  | Just thing <- wiredInNameTyThing_maybe name
-  = do  { when (needWiredInHomeIface thing)
-               (initIfaceTcRn (loadWiredInHomeIface name))
-                -- See Note [Loading instances for wired-in things]
-        ; return (Succeeded thing) }
-  | otherwise
-  = initIfaceTcRn (importDecl name)
-
-importDecl :: Name -> IfM lcl (MaybeErr SDoc TyThing)
--- Get the TyThing for this Name from an interface file
--- It's not a wired-in thing -- the caller caught that
-importDecl name
-  = assert (not (isWiredInName name)) $
-    do  { logger <- getLogger
-        ; liftIO $ trace_if logger nd_doc
-
-        -- Load the interface, which should populate the PTE
-        ; mb_iface <- assertPpr (isExternalName name) (ppr name) $
-                      loadInterface nd_doc (nameModule name) ImportBySystem
-        ; case mb_iface of {
-                Failed err_msg  -> return (Failed err_msg) ;
-                Succeeded _ -> do
-
-        -- Now look it up again; this time we should find it
-        { eps <- getEps
-        ; case lookupTypeEnv (eps_PTE eps) name of
-            Just thing -> return $ Succeeded thing
-            Nothing    -> let doc = whenPprDebug (found_things_msg eps $$ empty)
-                                    $$ not_found_msg
-                          in return $ Failed doc
-    }}}
-  where
-    nd_doc = text "Need decl for" <+> ppr name
-    not_found_msg = hang (text "Can't find interface-file declaration for" <+>
-                                pprNameSpace (nameNameSpace name) <+> ppr name)
-                       2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file",
-                                text "Use -ddump-if-trace to get an idea of which file caused the error"])
-    found_things_msg eps =
-        hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon)
-           2 (vcat (map ppr $ filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps))
-      where
-        is_interesting thing = nameModule name == nameModule (getName thing)
-
-
-{-
-************************************************************************
-*                                                                      *
-           Checks for wired-in things
-*                                                                      *
-************************************************************************
-
-Note [Loading instances for wired-in things]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We need to make sure that we have at least *read* the interface files
-for any module with an instance decl or RULE that we might want.
-
-* If the instance decl is an orphan, we have a whole separate mechanism
-  (loadOrphanModules)
-
-* If the instance decl is not an orphan, then the act of looking at the
-  TyCon or Class will force in the defining module for the
-  TyCon/Class, and hence the instance decl
-
-* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface;
-  but we must make sure we read its interface in case it has instances or
-  rules.  That is what GHC.Iface.Load.loadWiredInHomeIface does.  It's called
-  from GHC.IfaceToCore.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing}
-
-* HOWEVER, only do this for TyCons.  There are no wired-in Classes.  There
-  are some wired-in Ids, but we don't want to load their interfaces. For
-  example, Control.Exception.Base.recSelError is wired in, but that module
-  is compiled late in the base library, and we don't want to force it to
-  load before it's been compiled!
-
-All of this is done by the type checker. The renamer plays no role.
-(It used to, but no longer.)
--}
-
-checkWiredInTyCon :: TyCon -> TcM ()
--- Ensure that the home module of the TyCon (and hence its instances)
--- are loaded. See Note [Loading instances for wired-in things]
--- It might not be a wired-in tycon (see the calls in GHC.Tc.Utils.Unify),
--- in which case this is a no-op.
-checkWiredInTyCon tc
-  | not (isWiredInName tc_name)
-  = return ()
-  | otherwise
-  = do  { mod <- getModule
-        ; logger <- getLogger
-        ; liftIO $ trace_if logger (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)
-        ; assert (isExternalName tc_name )
-          when (mod /= nameModule tc_name)
-               (initIfaceTcRn (loadWiredInHomeIface tc_name))
-                -- Don't look for (non-existent) Float.hi when
-                -- compiling Float.hs, which mentions Float of course
-                -- A bit yukky to call initIfaceTcRn here
-        }
-  where
-    tc_name = tyConName tc
-
-ifCheckWiredInThing :: TyThing -> IfL ()
--- Even though we are in an interface file, we want to make
--- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double)
--- Ditto want to ensure that RULES are loaded too
--- See Note [Loading instances for wired-in things]
-ifCheckWiredInThing thing
-  = do  { mod <- getIfModule
-                -- Check whether we are typechecking the interface for this
-                -- very module.  E.g when compiling the base library in --make mode
-                -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in
-                -- the HPT, so without the test we'll demand-load it into the PIT!
-                -- C.f. the same test in checkWiredInTyCon above
-        ; let name = getName thing
-        ; assertPpr (isExternalName name) (ppr name) $
-          when (needWiredInHomeIface thing && mod /= nameModule name)
-               (loadWiredInHomeIface name) }
-
-needWiredInHomeIface :: TyThing -> Bool
--- Only for TyCons; see Note [Loading instances for wired-in things]
-needWiredInHomeIface (ATyCon {}) = True
-needWiredInHomeIface _           = False
-
-
-{-
-************************************************************************
-*                                                                      *
-        loadSrcInterface, loadOrphanModules, loadInterfaceForName
-
-                These three are called from TcM-land
-*                                                                      *
-************************************************************************
--}
-
--- | Load the interface corresponding to an @import@ directive in
--- source code.  On a failure, fail in the monad with an error message.
-loadSrcInterface :: SDoc
-                 -> ModuleName
-                 -> IsBootInterface     -- {-# SOURCE #-} ?
-                 -> PkgQual             -- "package", if any
-                 -> RnM ModIface
-
-loadSrcInterface doc mod want_boot maybe_pkg
-  = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg
-       ; case res of
-           Failed err      -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err)
-           Succeeded iface -> return iface }
-
--- | Like 'loadSrcInterface', but returns a 'MaybeErr'.
-loadSrcInterface_maybe :: SDoc
-                       -> ModuleName
-                       -> IsBootInterface     -- {-# SOURCE #-} ?
-                       -> PkgQual             -- "package", if any
-                       -> RnM (MaybeErr SDoc ModIface)
-
-loadSrcInterface_maybe doc mod want_boot maybe_pkg
-  -- We must first find which Module this import refers to.  This involves
-  -- calling the Finder, which as a side effect will search the filesystem
-  -- and create a ModLocation.  If successful, loadIface will read the
-  -- interface; it will call the Finder again, but the ModLocation will be
-  -- cached from the first search.
-  = do hsc_env <- getTopEnv
-       res <- liftIO $ findImportedModule hsc_env mod maybe_pkg
-       case res of
-           Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
-           -- TODO: Make sure this error message is good
-           err         -> return (Failed (cannotFindModule hsc_env mod err))
-
--- | Load interface directly for a fully qualified 'Module'.  (This is a fairly
--- rare operation, but in particular it is used to load orphan modules
--- in order to pull their instances into the global package table and to
--- handle some operations in GHCi).
-loadModuleInterface :: SDoc -> Module -> TcM ModIface
-loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod)
-
--- | Load interfaces for a collection of modules.
-loadModuleInterfaces :: SDoc -> [Module] -> TcM ()
-loadModuleInterfaces doc mods
-  | null mods = return ()
-  | otherwise = initIfaceTcRn (mapM_ load mods)
-  where
-    load mod = loadSysInterface (doc <+> parens (ppr mod)) mod
-
--- | Loads the interface for a given Name.
--- Should only be called for an imported name;
--- otherwise loadSysInterface may not find the interface
-loadInterfaceForName :: SDoc -> Name -> TcRn ModIface
-loadInterfaceForName doc name
-  = do { when debugIsOn $  -- Check pre-condition
-         do { this_mod <- getModule
-            ; massertPpr (not (nameIsLocalOrFrom this_mod name)) (ppr name <+> parens doc) }
-      ; assertPpr (isExternalName name) (ppr name) $
-        initIfaceTcRn $ loadSysInterface doc (nameModule name) }
-
--- | Loads the interface for a given Module.
-loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface
-loadInterfaceForModule doc m
-  = do
-    -- Should not be called with this module
-    when debugIsOn $ do
-      this_mod <- getModule
-      massertPpr (this_mod /= m) (ppr m <+> parens doc)
-    initIfaceTcRn $ loadSysInterface doc m
-
-{-
-*********************************************************
-*                                                      *
-                loadInterface
-
-        The main function to load an interface
-        for an imported module, and put it in
-        the External Package State
-*                                                      *
-*********************************************************
--}
-
--- | An 'IfM' function to load the home interface for a wired-in thing,
--- so that we're sure that we see its instance declarations and rules
--- See Note [Loading instances for wired-in things]
-loadWiredInHomeIface :: Name -> IfM lcl ()
-loadWiredInHomeIface name
-  = assert (isWiredInName name) $
-    do _ <- loadSysInterface doc (nameModule name); return ()
-  where
-    doc = text "Need home interface for wired-in thing" <+> ppr name
-
-------------------
--- | Loads a system interface and throws an exception if it fails
-loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
-loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem
-
-------------------
--- | Loads a user interface and throws an exception if it fails. The first parameter indicates
--- whether we should import the boot variant of the module
-loadUserInterface :: IsBootInterface -> SDoc -> Module -> IfM lcl ModIface
-loadUserInterface is_boot doc mod_name
-  = loadInterfaceWithException doc mod_name (ImportByUser is_boot)
-
-loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface
-loadPluginInterface doc mod_name
-  = loadInterfaceWithException doc mod_name ImportByPlugin
-
-------------------
--- | A wrapper for 'loadInterface' that throws an exception if it fails
-loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface
-loadInterfaceWithException doc mod_name where_from
-  = do
-    dflags <- getDynFlags
-    let ctx = initSDocContext dflags defaultUserStyle
-    withException ctx (loadInterface doc mod_name where_from)
-
-------------------
-loadInterface :: SDoc -> Module -> WhereFrom
-              -> IfM lcl (MaybeErr SDoc ModIface)
-
--- loadInterface looks in both the HPT and PIT for the required interface
--- If not found, it loads it, and puts it in the PIT (always).
-
--- If it can't find a suitable interface file, we
---      a) modify the PackageIfaceTable to have an empty entry
---              (to avoid repeated complaints)
---      b) return (Left message)
---
--- It's not necessarily an error for there not to be an interface
--- file -- perhaps the module has changed, and that interface
--- is no longer used
-
-loadInterface doc_str mod from
-  | isHoleModule mod
-  -- Hole modules get special treatment
-  = do hsc_env <- getTopEnv
-       let home_unit = hsc_home_unit hsc_env
-       -- Redo search for our local hole module
-       loadInterface doc_str (mkHomeModule home_unit (moduleName mod)) from
-  | otherwise
-  = do
-    logger <- getLogger
-    withTimingSilent logger (text "loading interface") (pure ()) $ do
-        {       -- Read the state
-          (eps,hug) <- getEpsAndHug
-        ; gbl_env <- getGblEnv
-
-        ; liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+> ppr from)
-
-                -- Check whether we have the interface already
-        ; hsc_env <- getTopEnv
-        ; let mhome_unit = ue_homeUnit (hsc_unit_env hsc_env)
-        ; case lookupIfaceByModule hug (eps_PIT eps) mod of {
-            Just iface
-                -> return (Succeeded iface) ;   -- Already loaded
-                        -- The (src_imp == mi_boot iface) test checks that the already-loaded
-                        -- interface isn't a boot iface.  This can conceivably happen,
-                        -- if an earlier import had a before we got to real imports.   I think.
-            _ -> do {
-
-        -- READ THE MODULE IN
-        ; read_result <- case wantHiBootFile mhome_unit eps mod from of
-                           Failed err             -> return (Failed err)
-                           Succeeded hi_boot_file -> do
-                             hsc_env <- getTopEnv
-                             liftIO $ computeInterface hsc_env doc_str hi_boot_file mod
-        ; case read_result of {
-            Failed err -> do
-                { let fake_iface = emptyFullModIface mod
-
-                ; updateEps_ $ \eps ->
-                        eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
-                        -- Not found, so add an empty iface to
-                        -- the EPS map so that we don't look again
-
-                ; return (Failed err) } ;
-
-        -- Found and parsed!
-        -- We used to have a sanity check here that looked for:
-        --  * System importing ..
-        --  * a home package module ..
-        --  * that we know nothing about (mb_dep == Nothing)!
-        --
-        -- But this is no longer valid because thNameToGhcName allows users to
-        -- cause the system to load arbitrary interfaces (by supplying an appropriate
-        -- Template Haskell original-name).
-            Succeeded (iface, loc) ->
-        let
-            loc_doc = text loc
-        in
-        initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $
-
-        dontLeakTheHUG $ do
-
-        --      Load the new ModIface into the External Package State
-        -- Even home-package interfaces loaded by loadInterface
-        --      (which only happens in OneShot mode; in Batch/Interactive
-        --      mode, home-package modules are loaded one by one into the HPT)
-        -- are put in the EPS.
-        --
-        -- The main thing is to add the ModIface to the PIT, but
-        -- we also take the
-        --      IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules,
-        -- out of the ModIface and put them into the big EPS pools
-
-        -- NB: *first* we do tcIfaceDecls, so that the provenance of all the locally-defined
-        ---    names is done correctly (notably, whether this is an .hi file or .hi-boot file).
-        --     If we do loadExport first the wrong info gets into the cache (unless we
-        --      explicitly tag each export which seems a bit of a bore)
-
-        -- Crucial assertion that checks if you are trying to load a HPT module into the EPS.
-        -- If you start loading HPT modules into the EPS then you get strange errors about
-        -- overlapping instances.
-        ; massertPpr
-              ((isOneShot (ghcMode (hsc_dflags hsc_env)))
-                || moduleUnitId mod `notElem` hsc_all_home_unit_ids hsc_env
-                || mod == gHC_PRIM)
-                (text "Attempting to load home package interface into the EPS" $$ ppr hug $$ doc_str $$ ppr mod $$ ppr (moduleUnitId mod))
-        ; ignore_prags      <- goptM Opt_IgnoreInterfacePragmas
-        ; new_eps_decls     <- tcIfaceDecls ignore_prags (mi_decls iface)
-        ; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)
-        ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
-        ; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)
-        ; new_eps_anns      <- tcIfaceAnnotations (mi_anns iface)
-        ; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
-
-        ; let { final_iface = iface {
-                                mi_decls     = panic "No mi_decls in PIT",
-                                mi_insts     = panic "No mi_insts in PIT",
-                                mi_fam_insts = panic "No mi_fam_insts in PIT",
-                                mi_rules     = panic "No mi_rules in PIT",
-                                mi_anns      = panic "No mi_anns in PIT"
-                              }
-               }
-
-        ; let bad_boot = mi_boot iface == IsBoot
-                          && isJust (lookupKnotVars (if_rec_types gbl_env) mod)
-                            -- Warn against an EPS-updating import
-                            -- of one's own boot file! (one-shot only)
-                            -- See Note [Loading your own hi-boot file]
-
-        ; warnPprTrace bad_boot "loadInterface" (ppr mod) $
-          updateEps_  $ \ eps ->
-           if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface
-                then eps
-           else if bad_boot
-                -- See Note [Loading your own hi-boot file]
-                then eps { eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls }
-           else
-                eps {
-                  eps_PIT          = extendModuleEnv (eps_PIT eps) mod final_iface,
-                  eps_PTE          = addDeclsToPTE   (eps_PTE eps) new_eps_decls,
-                  eps_rule_base    = extendRuleBaseList (eps_rule_base eps)
-                                                        new_eps_rules,
-                  eps_complete_matches
-                                   = eps_complete_matches eps ++ new_eps_complete_matches,
-                  eps_inst_env     = extendInstEnvList (eps_inst_env eps)
-                                                       new_eps_insts,
-                  eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
-                                                          new_eps_fam_insts,
-                  eps_ann_env      = extendAnnEnvList (eps_ann_env eps)
-                                                      new_eps_anns,
-                  eps_mod_fam_inst_env
-                                   = let
-                                       fam_inst_env =
-                                         extendFamInstEnvList emptyFamInstEnv
-                                                              new_eps_fam_insts
-                                     in
-                                     extendModuleEnv (eps_mod_fam_inst_env eps)
-                                                     mod
-                                                     fam_inst_env,
-                  eps_stats        = addEpsInStats (eps_stats eps)
-                                                   (length new_eps_decls)
-                                                   (length new_eps_insts)
-                                                   (length new_eps_rules) }
-
-        ; -- invoke plugins with *full* interface, not final_iface, to ensure
-          -- that plugins have access to declarations, etc.
-          res <- withPlugins (hsc_plugins hsc_env) (\p -> interfaceLoadAction p) iface
-        ; return (Succeeded res)
-    }}}}
-
-{- Note [Loading your own hi-boot file]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Generally speaking, when compiling module M, we should not
-load M.hi boot into the EPS.  After all, we are very shortly
-going to have full information about M.  Moreover, see
-Note [Do not update EPS with your own hi-boot] in GHC.Iface.Recomp.
-
-But there is a HORRIBLE HACK here.
-
-* At the end of tcRnImports, we call checkFamInstConsistency to
-  check consistency of imported type-family instances
-  See Note [The type family instance consistency story] in GHC.Tc.Instance.Family
-
-* Alas, those instances may refer to data types defined in M,
-  if there is a M.hs-boot.
-
-* And that means we end up loading M.hi-boot, because those
-  data types are not yet in the type environment.
-
-But in this weird case, /all/ we need is the types. We don't need
-instances, rules etc.  And if we put the instances in the EPS
-we get "duplicate instance" warnings when we compile the "real"
-instance in M itself.  Hence the strange business of just updateing
-the eps_PTE.
-
-This really happens in practice.  The module "GHC.Hs.Expr" gets
-"duplicate instance" errors if this hack is not present.
-
-This is a mess.
-
-
-Note [Home Unit Graph space leak]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Ticket: #15111
-
-In IfL, we defer some work until it is demanded using forkM, such
-as building TyThings from IfaceDecls. These thunks are stored in
-the ExternalPackageState, and they might never be poked.  If we're
-not careful, these thunks will capture the state of the loaded
-program when we read an interface file, and retain all that data
-for ever.
-
-Therefore, when loading a package interface file , we use a "clean"
-version of the HscEnv with all the data about the currently loaded
-program stripped out. Most of the fields can be panics because
-we'll never read them, but hsc_HUG needs to be empty because this
-interface will cause other interfaces to be loaded recursively, and
-when looking up those interfaces we use the HUG in loadInterface.
-We know that none of the interfaces below here can refer to
-home-package modules however, so it's safe for the HUG to be empty.
--}
-
--- Note [GHC Heap Invariants]
--- Note [Home Unit Graph space leak]
-dontLeakTheHUG :: IfL a -> IfL a
-dontLeakTheHUG thing_inside = do
-  env <- getTopEnv
-  let
-    inOneShot =
-      isOneShot (ghcMode (hsc_dflags env))
-    cleanGblEnv gbl_env
-      | inOneShot = gbl_env
-      | otherwise = gbl_env { if_rec_types = emptyKnotVars }
-    cleanTopEnv hsc_env =
-
-       let
-         !maybe_type_vars | inOneShot = Just (hsc_type_env_vars env)
-                          | otherwise = Nothing
-         -- wrinkle: when we're typechecking in --backpack mode, the
-         -- instantiation of a signature might reside in the HPT, so
-         -- this case breaks the assumption that EPS interfaces only
-         -- refer to other EPS interfaces.
-         -- As a temporary (MP Oct 2021 #20509) we only keep the HPT if it
-         -- contains any hole modules.
-         -- Quite a few tests in testsuite/tests/backpack break without this
-         -- tweak.
-         old_unit_env = hsc_unit_env hsc_env
-         keepFor20509 hmi
-          | isHoleModule (mi_semantic_module (hm_iface hmi)) = True
-          | otherwise = False
-         pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable }
-         !unit_env
-          = old_unit_env
-             { ue_home_unit_graph = if anyHpt keepFor20509 (ue_hpt old_unit_env) then ue_home_unit_graph old_unit_env
-                                                                                 else unitEnv_map pruneHomeUnitEnv (ue_home_unit_graph old_unit_env)
-             }
-       in
-       hsc_env {  hsc_targets      = panic "cleanTopEnv: hsc_targets"
-               ,  hsc_mod_graph    = panic "cleanTopEnv: hsc_mod_graph"
-               ,  hsc_IC           = panic "cleanTopEnv: hsc_IC"
-               ,  hsc_type_env_vars = case maybe_type_vars of
-                                          Just vars -> vars
-                                          Nothing -> panic "cleanTopEnv: hsc_type_env_vars"
-               ,  hsc_unit_env     = unit_env
-               }
-
-  updTopEnv cleanTopEnv $ updGblEnv cleanGblEnv $ do
-  !_ <- getTopEnv        -- force the updTopEnv
-  !_ <- getGblEnv
-  thing_inside
-
-
--- | Returns @True@ if a 'ModIface' comes from an external package.
--- In this case, we should NOT load it into the EPS; the entities
--- should instead come from the local merged signature interface.
-is_external_sig :: Maybe HomeUnit -> ModIface -> Bool
-is_external_sig mhome_unit iface =
-    -- It's a signature iface...
-    mi_semantic_module iface /= mi_module iface &&
-    -- and it's not from the local package
-    notHomeModuleMaybe mhome_unit (mi_module iface)
-
--- | This is an improved version of 'findAndReadIface' which can also
--- handle the case when a user requests @p[A=<B>]:M@ but we only
--- have an interface for @p[A=<A>]:M@ (the indefinite interface.
--- If we are not trying to build code, we load the interface we have,
--- *instantiating it* according to how the holes are specified.
--- (Of course, if we're actually building code, this is a hard error.)
---
--- In the presence of holes, 'computeInterface' has an important invariant:
--- to load module M, its set of transitively reachable requirements must
--- have an up-to-date local hi file for that requirement.  Note that if
--- we are loading the interface of a requirement, this does not
--- apply to the requirement itself; e.g., @p[A=<A>]:A@ does not require
--- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless
--- we are actually typechecking p.)
-computeInterface
-  :: HscEnv
-  -> SDoc
-  -> IsBootInterface
-  -> Module
-  -> IO (MaybeErr SDoc (ModIface, FilePath))
-computeInterface hsc_env doc_str hi_boot_file mod0 = do
-  massert (not (isHoleModule mod0))
-  let mhome_unit  = hsc_home_unit_maybe hsc_env
-  let find_iface m = findAndReadIface hsc_env doc_str
-                                      m mod0 hi_boot_file
-  case getModuleInstantiation mod0 of
-      (imod, Just indef)
-        | Just home_unit <- mhome_unit
-        , isHomeUnitIndefinite home_unit ->
-          find_iface imod >>= \case
-            Succeeded (iface0, path) ->
-              rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case
-                Right x   -> return (Succeeded (x, path))
-                Left errs -> throwErrors (GhcTcRnMessage <$> errs)
-            Failed err -> return (Failed err)
-      (mod, _) -> find_iface mod
-
--- | Compute the signatures which must be compiled in order to
--- load the interface for a 'Module'.  The output of this function
--- is always a subset of 'moduleFreeHoles'; it is more precise
--- because in signature @p[A=\<A>,B=\<B>]:B@, although the free holes
--- are A and B, B might not depend on A at all!
---
--- If this is invoked on a signature, this does NOT include the
--- signature itself; e.g. precise free module holes of
--- @p[A=\<A>,B=\<B>]:B@ never includes B.
-moduleFreeHolesPrecise
-    :: SDoc -> Module
-    -> TcRnIf gbl lcl (MaybeErr SDoc (UniqDSet ModuleName))
-moduleFreeHolesPrecise doc_str mod
- | moduleIsDefinite mod = return (Succeeded emptyUniqDSet)
- | otherwise =
-   case getModuleInstantiation mod of
-    (imod, Just indef) -> do
-        logger <- getLogger
-        let insts = instUnitInsts (moduleUnit indef)
-        liftIO $ trace_if logger (text "Considering whether to load" <+> ppr mod <+>
-                 text "to compute precise free module holes")
-        (eps, hpt) <- getEpsAndHug
-        case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of
-            Just r -> return (Succeeded r)
-            Nothing -> readAndCache imod insts
-    (_, Nothing) -> return (Succeeded emptyUniqDSet)
-  where
-    tryEpsAndHpt eps hpt =
-        fmap mi_free_holes (lookupIfaceByModule hpt (eps_PIT eps) mod)
-    tryDepsCache eps imod insts =
-        case lookupInstalledModuleEnv (eps_free_holes eps) imod of
-            Just ifhs  -> Just (renameFreeHoles ifhs insts)
-            _otherwise -> Nothing
-    readAndCache imod insts = do
-        hsc_env <- getTopEnv
-        mb_iface <- liftIO $ findAndReadIface hsc_env
-                                              (text "moduleFreeHolesPrecise" <+> doc_str)
-                                              imod mod NotBoot
-        case mb_iface of
-            Succeeded (iface, _) -> do
-                let ifhs = mi_free_holes iface
-                -- Cache it
-                updateEps_ (\eps ->
-                    eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs })
-                return (Succeeded (renameFreeHoles ifhs insts))
-            Failed err -> return (Failed err)
-
-wantHiBootFile :: Maybe HomeUnit -> ExternalPackageState -> Module -> WhereFrom
-               -> MaybeErr SDoc IsBootInterface
--- Figure out whether we want Foo.hi or Foo.hi-boot
-wantHiBootFile mhome_unit eps mod from
-  = case from of
-       ImportByUser usr_boot
-          | usr_boot == IsBoot && notHomeModuleMaybe mhome_unit mod
-          -> Failed (badSourceImport mod)
-          | otherwise -> Succeeded usr_boot
-
-       ImportByPlugin
-          -> Succeeded NotBoot
-
-       ImportBySystem
-          | notHomeModuleMaybe mhome_unit mod
-          -> Succeeded NotBoot
-             -- If the module to be imported is not from this package
-             -- don't look it up in eps_is_boot, because that is keyed
-             -- on the ModuleName of *home-package* modules only.
-             -- We never import boot modules from other packages!
-
-          | otherwise
-          -> case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of
-                Just (GWIB { gwib_isBoot = is_boot }) ->
-                  Succeeded is_boot
-                Nothing ->
-                  Succeeded NotBoot
-                     -- The boot-ness of the requested interface,
-                     -- based on the dependencies in directly-imported modules
-
-badSourceImport :: Module -> SDoc
-badSourceImport mod
-  = hang (text "You cannot {-# SOURCE #-} import a module from another package")
-       2 (text "but" <+> quotes (ppr mod) <+> text "is from package"
-          <+> quotes (ppr (moduleUnit mod)))
-
------------------------------------------------------
---      Loading type/class/value decls
--- We pass the full Module name here, replete with
--- its package info, so that we can build a Name for
--- each binder with the right package info in it
--- All subsequent lookups, including crucially lookups during typechecking
--- the declaration itself, will find the fully-glorious Name
---
--- We handle ATs specially.  They are not main declarations, but also not
--- implicit things (in particular, adding them to `implicitTyThings' would mess
--- things up in the renaming/type checking of source programs).
------------------------------------------------------
-
-addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
-addDeclsToPTE pte things = extendNameEnvList pte things
-
-{-
-*********************************************************
-*                                                      *
-\subsection{Reading an interface file}
-*                                                      *
-*********************************************************
-
-Note [Home module load error]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If the sought-for interface is in the current package (as determined
-by -package-name flag) then it jolly well should already be in the HPT
-because we process home-package modules in dependency order.  (Except
-in one-shot mode; see notes with hsc_HPT decl in GHC.Driver.Env).
-
-It is possible (though hard) to get this error through user behaviour.
-  * Suppose package P (modules P1, P2) depends on package Q (modules Q1,
-    Q2, with Q2 importing Q1)
-  * We compile both packages.
-  * Now we edit package Q so that it somehow depends on P
-  * Now recompile Q with --make (without recompiling P).
-  * Then Q1 imports, say, P1, which in turn depends on Q2. So Q2
-    is a home-package module which is not yet in the HPT!  Disaster.
-
-This actually happened with P=base, Q=ghc-prim, via the AMP warnings.
-See #8320.
--}
-
-findAndReadIface
-  :: HscEnv
-  -> SDoc            -- ^ Reason for loading the iface (used for tracing)
-  -> InstalledModule -- ^ The unique identifier of the on-disk module we're looking for
-  -> Module          -- ^ The *actual* module we're looking for.  We use
-                     -- this to check the consistency of the requirements of the
-                     -- module we read out.
-  -> IsBootInterface -- ^ Looking for .hi-boot or .hi file
-  -> IO (MaybeErr SDoc (ModIface, FilePath))
-findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do
-
-  let profile = targetProfile dflags
-      unit_state = hsc_units hsc_env
-      fc         = hsc_FC hsc_env
-      name_cache = hsc_NC hsc_env
-      mhome_unit  = hsc_home_unit_maybe hsc_env
-      dflags     = hsc_dflags hsc_env
-      logger     = hsc_logger hsc_env
-      hooks      = hsc_hooks hsc_env
-      other_fopts = initFinderOpts . homeUnitEnv_dflags <$> (hsc_HUG hsc_env)
-
-
-  trace_if logger (sep [hsep [text "Reading",
-                           if hi_boot_file == IsBoot
-                             then text "[boot]"
-                             else Outputable.empty,
-                           text "interface for",
-                           ppr mod <> semi],
-                     nest 4 (text "reason:" <+> doc_str)])
-
-  -- Check for GHC.Prim, and return its static interface
-  -- See Note [GHC.Prim] in primops.txt.pp.
-  -- TODO: make this check a function
-  if mod `installedModuleEq` gHC_PRIM
-      then do
-          let iface = case ghcPrimIfaceHook hooks of
-                       Nothing -> ghcPrimIface
-                       Just h  -> h
-          return (Succeeded (iface, "<built in interface for GHC.Prim>"))
-      else do
-          let fopts = initFinderOpts dflags
-          -- Look for the file
-          mb_found <- liftIO (findExactModule fc fopts other_fopts unit_state mhome_unit mod)
-          case mb_found of
-              InstalledFound (addBootSuffixLocn_maybe hi_boot_file -> loc) mod -> do
-                  -- See Note [Home module load error]
-                  case mhome_unit of
-                    Just home_unit
-                      | isHomeInstalledModule home_unit mod
-                      , not (isOneShot (ghcMode dflags))
-                      -> return (Failed (homeModError mod loc))
-                    _ -> do
-                        r <- read_file logger name_cache unit_state dflags wanted_mod (ml_hi_file loc)
-                        case r of
-                          Failed _
-                            -> return r
-                          Succeeded (iface,_fp)
-                            -> do
-                                r2 <- load_dynamic_too_maybe logger name_cache unit_state
-                                                         (setDynamicNow dflags) wanted_mod
-                                                         iface loc
-                                case r2 of
-                                  Failed sdoc -> return (Failed sdoc)
-                                  Succeeded {} -> return r
-              err -> do
-                  trace_if logger (text "...not found")
-                  return $ Failed $ cannotFindInterface
-                                      unit_state
-                                      mhome_unit
-                                      profile
-                                      (Iface_Errors.mayShowLocations dflags)
-                                      (moduleName mod)
-                                      err
-
--- | Check if we need to try the dynamic interface for -dynamic-too
-load_dynamic_too_maybe :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ())
-load_dynamic_too_maybe logger name_cache unit_state dflags wanted_mod iface loc
-  -- Indefinite interfaces are ALWAYS non-dynamic.
-  | not (moduleIsDefinite (mi_module iface)) = return (Succeeded ())
-  | gopt Opt_BuildDynamicToo dflags = load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc
-  | otherwise = return (Succeeded ())
-
-load_dynamic_too :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> ModIface -> ModLocation -> IO (MaybeErr SDoc ())
-load_dynamic_too logger name_cache unit_state dflags wanted_mod iface loc = do
-  read_file logger name_cache unit_state dflags wanted_mod (ml_dyn_hi_file loc) >>= \case
-    Succeeded (dynIface, _)
-     | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface)
-     -> return (Succeeded ())
-     | otherwise ->
-        do return $ (Failed $ dynamicHashMismatchError wanted_mod loc)
-    Failed err ->
-        do return $ (Failed $ ((text "Failed to load dynamic interface file for" <+> ppr wanted_mod <> colon) $$ err))
-
-
-dynamicHashMismatchError :: Module -> ModLocation -> SDoc
-dynamicHashMismatchError wanted_mod loc  =
-  vcat [ text "Dynamic hash doesn't match for" <+> quotes (ppr wanted_mod)
-       , text "Normal interface file from"  <+> text (ml_hi_file loc)
-       , text "Dynamic interface file from" <+> text (ml_dyn_hi_file loc)
-       , text "You probably need to recompile" <+> quotes (ppr wanted_mod) ]
-
-
-read_file :: Logger -> NameCache -> UnitState -> DynFlags -> Module -> FilePath -> IO (MaybeErr SDoc (ModIface, FilePath))
-read_file logger name_cache unit_state dflags wanted_mod file_path = do
-  trace_if logger (text "readIFace" <+> text file_path)
-
-  -- Figure out what is recorded in mi_module.  If this is
-  -- a fully definite interface, it'll match exactly, but
-  -- if it's indefinite, the inside will be uninstantiated!
-  let wanted_mod' =
-        case getModuleInstantiation wanted_mod of
-            (_, Nothing) -> wanted_mod
-            (_, Just indef_mod) ->
-              instModuleToModule unit_state
-                (uninstantiateInstantiatedModule indef_mod)
-  read_result <- readIface dflags name_cache wanted_mod' file_path
-  case read_result of
-    Failed err -> return (Failed (badIfaceFile file_path err))
-    Succeeded iface -> return (Succeeded (iface, file_path))
-                -- Don't forget to fill in the package name...
-
-
--- | Write interface file
-writeIface :: Logger -> Profile -> FilePath -> ModIface -> IO ()
-writeIface logger profile hi_file_path new_iface
-    = do createDirectoryIfMissing True (takeDirectory hi_file_path)
-         let printer = TraceBinIFace (debugTraceMsg logger 3)
-         writeBinIface profile printer hi_file_path new_iface
-
--- | @readIface@ tries just the one file.
---
--- Failed err    <=> file not found, or unreadable, or illegible
--- Succeeded iface <=> successfully found and parsed
-readIface
-  :: DynFlags
-  -> NameCache
-  -> Module
-  -> FilePath
-  -> IO (MaybeErr SDoc ModIface)
-readIface dflags name_cache wanted_mod file_path = do
-  let profile = targetProfile dflags
-  res <- tryMost $ readBinIface profile name_cache CheckHiWay QuietBinIFace file_path
-  case res of
-    Right iface
-        -- NB: This check is NOT just a sanity check, it is
-        -- critical for correctness of recompilation checking
-        -- (it lets us tell when -this-unit-id has changed.)
-        | wanted_mod == actual_mod
-                        -> return (Succeeded iface)
-        | otherwise     -> return (Failed err)
-        where
-          actual_mod = mi_module iface
-          err = hiModuleNameMismatchWarn wanted_mod actual_mod
-
-    Left exn    -> return (Failed (text (showException exn)))
-
-{-
-*********************************************************
-*                                                       *
-        Wired-in interface for GHC.Prim
-*                                                       *
-*********************************************************
--}
-
--- See Note [GHC.Prim] in primops.txt.pp.
-ghcPrimIface :: ModIface
-ghcPrimIface
-  = empty_iface {
-        mi_exports  = ghcPrimExports,
-        mi_decls    = [],
-        mi_fixities = fixities,
-        mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities },
-        mi_docs = Just ghcPrimDeclDocs -- See Note [GHC.Prim Docs]
-        }
-  where
-    empty_iface = emptyFullModIface gHC_PRIM
-
-    -- The fixity listed here for @`seq`@ should match
-    -- those in primops.txt.pp (from which Haddock docs are generated).
-    fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)
-             : mapMaybe mkFixity allThePrimOps
-    mkFixity op = (,) (primOpOcc op) <$> primOpFixity op
-
-{-
-*********************************************************
-*                                                      *
-\subsection{Statistics}
-*                                                      *
-*********************************************************
--}
-
-ifaceStats :: ExternalPackageState -> SDoc
-ifaceStats eps
-  = hcat [text "Renamer stats: ", msg]
-  where
-    stats = eps_stats eps
-    msg = vcat
-        [int (n_ifaces_in stats) <+> text "interfaces read",
-         hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",
-                int (n_decls_in stats), text "read"],
-         hsep [ int (n_insts_out stats), text "instance decls imported, out of",
-                int (n_insts_in stats), text "read"],
-         hsep [ int (n_rules_out stats), text "rule decls imported, out of",
-                int (n_rules_in stats), text "read"]
-        ]
-
-{-
-************************************************************************
-*                                                                      *
-                Printing interfaces
-*                                                                      *
-************************************************************************
-
-Note [Name qualification with --show-iface]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-In order to disambiguate between identifiers from different modules, we qualify
-all names that don't originate in the current module. In order to keep visual
-noise as low as possible, we keep local names unqualified.
-
-For some background on this choice see trac #15269.
--}
-
--- | Read binary interface, and print it out
-showIface :: Logger -> DynFlags -> UnitState -> NameCache -> FilePath -> IO ()
-showIface logger dflags unit_state name_cache filename = do
-   let profile = targetProfile dflags
-       printer = logMsg logger MCOutput noSrcSpan . withPprStyle defaultDumpStyle
-
-   -- skip the hi way check; we don't want to worry about profiled vs.
-   -- non-profiled interfaces, for example.
-   iface <- readBinIface profile name_cache IgnoreHiWay (TraceBinIFace printer) filename
-
-   let -- See Note [Name qualification with --show-iface]
-       qualifyImportedNames mod _
-           | mod == mi_module iface = NameUnqual
-           | otherwise              = NameNotInScope1
-       name_ppr_ctx = QueryQualify qualifyImportedNames
-                                   neverQualifyModules
-                                   neverQualifyPackages
-                                   alwaysPrintPromTick
-   logMsg logger MCDump noSrcSpan
-      $ withPprStyle (mkDumpStyle name_ppr_ctx)
-      $ pprModIface unit_state iface
-
--- | Show a ModIface but don't display details; suitable for ModIfaces stored in
--- the EPT.
-pprModIfaceSimple :: UnitState -> ModIface -> SDoc
-pprModIfaceSimple unit_state iface =
-    ppr (mi_module iface)
-    $$ pprDeps unit_state (mi_deps iface)
-    $$ nest 2 (vcat (map pprExport (mi_exports iface)))
-
--- | Show a ModIface
---
--- The UnitState is used to pretty-print units
-pprModIface :: UnitState -> ModIface -> SDoc
-pprModIface unit_state iface@ModIface{ mi_final_exts = exts }
- = vcat [ text "interface"
-                <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface)
-                <+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty)
-                <+> (if mi_finsts exts then text "[family instance module]" else Outputable.empty)
-                <+> (if mi_hpc iface then text "[hpc]" else Outputable.empty)
-                <+> integer hiVersion
-        , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash exts))
-        , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash exts))
-        , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash exts))
-        , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash exts))
-        , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash exts))
-        , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts))
-        , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts))
-        , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts))
-        , nest 2 (text "src_hash:" <+> ppr (mi_src_hash iface))
-        , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))
-        , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))
-        , nest 2 (text "where")
-        , text "exports:"
-        , nest 2 (vcat (map pprExport (mi_exports iface)))
-        , pprDeps unit_state (mi_deps iface)
-        , vcat (map pprUsage (mi_usages iface))
-        , vcat (map pprIfaceAnnotation (mi_anns iface))
-        , pprFixities (mi_fixities iface)
-        , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface]
-        , case mi_extra_decls iface of
-            Nothing -> empty
-            Just eds -> text "extra decls:"
-                          $$ nest 2 (vcat ([ppr bs | bs <- eds]))
-        , vcat (map ppr (mi_insts iface))
-        , vcat (map ppr (mi_fam_insts iface))
-        , vcat (map ppr (mi_rules iface))
-        , ppr (mi_warns iface)
-        , pprTrustInfo (mi_trust iface)
-        , pprTrustPkg (mi_trust_pkg iface)
-        , vcat (map ppr (mi_complete_matches iface))
-        , text "docs:" $$ nest 2 (ppr (mi_docs iface))
-        , text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface))
-        ]
-  where
-    pp_hsc_src HsBootFile = text "[boot]"
-    pp_hsc_src HsigFile = text "[hsig]"
-    pp_hsc_src HsSrcFile = Outputable.empty
-
-{-
-When printing export lists, we print like this:
-        Avail   f               f
-        AvailTC C [C, x, y]     C(x,y)
-        AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C
--}
-
-pprExport :: IfaceExport -> SDoc
-pprExport (Avail n)      = ppr n
-pprExport (AvailTC _ []) = Outputable.empty
-pprExport avail@(AvailTC n _) =
-    ppr n <> mark <> pp_export (availSubordinateGreNames avail)
-  where
-    mark | availExportsDecl avail = Outputable.empty
-         | otherwise              = vbar
-
-    pp_export []    = Outputable.empty
-    pp_export names = braces (hsep (map ppr names))
-
-pprUsage :: Usage -> SDoc
-pprUsage usage@UsagePackageModule{}
-  = pprUsageImport usage usg_mod
-pprUsage usage@UsageHomeModule{}
-  = pprUsageImport usage usg_mod_name $$
-    nest 2 (
-        maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
-        vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
-        )
-pprUsage usage@UsageFile{}
-  = hsep [text "addDependentFile",
-          doubleQuotes (text (usg_file_path usage)),
-          ppr (usg_file_hash usage)]
-pprUsage usage@UsageMergedRequirement{}
-  = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
-pprUsage usage@UsageHomeModuleInterface{}
-  = hsep [text "implementation", ppr (usg_mod_name usage), ppr (usg_iface_hash usage)]
-
-pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc
-pprUsageImport usage usg_mod'
-  = hsep [text "import", safe, ppr (usg_mod' usage),
-                       ppr (usg_mod_hash usage)]
-    where
-        safe | usg_safe usage = text "safe"
-             | otherwise      = text " -/ "
-
-pprFixities :: [(OccName, Fixity)] -> SDoc
-pprFixities []    = Outputable.empty
-pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes
-                  where
-                    pprFix (occ,fix) = ppr fix <+> ppr occ
-
-pprTrustInfo :: IfaceTrustInfo -> SDoc
-pprTrustInfo trust = text "trusted:" <+> ppr trust
-
-pprTrustPkg :: Bool -> SDoc
-pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg
-
-instance Outputable (Warnings pass) where
-    ppr = pprWarns
-
-pprWarns :: Warnings pass -> SDoc
-pprWarns NoWarnings         = Outputable.empty
-pprWarns (WarnAll txt)  = text "Warn all" <+> ppr txt
-pprWarns (WarnSome prs) = text "Warnings:"
-                        <+> vcat (map pprWarning prs)
-    where pprWarning (name, txt) = ppr name <+> ppr txt
-
-pprIfaceAnnotation :: IfaceAnnotation -> SDoc
-pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })
-  = ppr target <+> text "annotated by" <+> ppr serialized
-
-pprExtensibleFields :: ExtensibleFields -> SDoc
-pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs
-  where
-    pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes"
diff --git a/compiler/GHC/Iface/Load.hs-boot b/compiler/GHC/Iface/Load.hs-boot
deleted file mode 100644
--- a/compiler/GHC/Iface/Load.hs-boot
+++ /dev/null
@@ -1,8 +0,0 @@
-module GHC.Iface.Load where
-
-import GHC.Unit.Module (Module)
-import GHC.Tc.Utils.Monad (IfM)
-import GHC.Unit.Module.ModIface (ModIface)
-import GHC.Utils.Outputable (SDoc)
-
-loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
deleted file mode 100644
--- a/compiler/GHC/Iface/Make.hs
+++ /dev/null
@@ -1,783 +0,0 @@
-
-{-# LANGUAGE NondecreasingIndentation #-}
-
-{-
-(c) The University of Glasgow 2006-2008
-(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
--}
-
--- | Module for constructing @ModIface@ values (interface files),
--- writing them to disk and comparing two versions to see if
--- recompilation is required.
-module GHC.Iface.Make
-   ( mkPartialIface
-   , mkFullIface
-   , mkIfaceTc
-   , mkIfaceExports
-   , coAxiomToIfaceDecl
-   , tyThingToIfaceDecl -- Converting things to their Iface equivalents
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Hs
-
-import GHC.StgToCmm.Types (CmmCgInfos (..))
-
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.Monad
-
-import GHC.Iface.Syntax
-import GHC.Iface.Recomp
-import GHC.Iface.Load
-import GHC.Iface.Ext.Fields
-
-import GHC.CoreToIface
-
-import qualified GHC.LanguageExtensions as LangExt
-import GHC.Core
-import GHC.Core.Class
-import GHC.Core.TyCon
-import GHC.Core.Coercion.Axiom
-import GHC.Core.ConLike
-import GHC.Core.DataCon
-import GHC.Core.Type
-import GHC.Core.Multiplicity
-import GHC.Core.InstEnv
-import GHC.Core.FamInstEnv
-import GHC.Core.Ppr
-import GHC.Core.RoughMap( RoughMatchTc(..) )
-
-import GHC.Driver.Config.HsToCore.Usage
-import GHC.Driver.Env
-import GHC.Driver.Backend
-import GHC.Driver.Session
-import GHC.Driver.Plugins
-
-import GHC.Types.Id
-import GHC.Types.Fixity.Env
-import GHC.Types.SafeHaskell
-import GHC.Types.Annotations
-import GHC.Types.Var.Env
-import GHC.Types.Var
-import GHC.Types.Name
-import GHC.Types.Avail
-import GHC.Types.Name.Reader
-import GHC.Types.Name.Env
-import GHC.Types.Name.Set
-import GHC.Types.Unique.DSet
-import GHC.Types.Basic hiding ( SuccessFlag(..) )
-import GHC.Types.TypeEnv
-import GHC.Types.SourceFile
-import GHC.Types.TyThing
-import GHC.Types.HpcInfo
-import GHC.Types.CompleteMatch
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Misc
-import GHC.Utils.Logger
-
-import GHC.Data.FastString
-import GHC.Data.Maybe
-
-import GHC.HsToCore.Docs
-import GHC.HsToCore.Usage
-
-import GHC.Unit
-import GHC.Unit.Module.Warnings
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.ModDetails
-import GHC.Unit.Module.ModGuts
-import GHC.Unit.Module.ModSummary
-import GHC.Unit.Module.Deps
-
-import Data.Function
-import Data.List ( findIndex, mapAccumL, sortBy )
-import Data.Ord
-import Data.IORef
-import GHC.Stg.Pipeline (StgCgInfos)
-
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Completing an interface}
-*                                                                      *
-************************************************************************
--}
-
-mkPartialIface :: HscEnv
-               -> CoreProgram
-               -> ModDetails
-               -> ModSummary
-               -> ModGuts
-               -> PartialModIface
-mkPartialIface hsc_env core_prog mod_details mod_summary
-  ModGuts{ mg_module       = this_mod
-         , mg_hsc_src      = hsc_src
-         , mg_usages       = usages
-         , mg_used_th      = used_th
-         , mg_deps         = deps
-         , mg_rdr_env      = rdr_env
-         , mg_fix_env      = fix_env
-         , mg_warns        = warns
-         , mg_hpc_info     = hpc_info
-         , mg_safe_haskell = safe_mode
-         , mg_trust_pkg    = self_trust
-         , mg_docs         = docs
-         }
-  = mkIface_ hsc_env this_mod core_prog hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust
-             safe_mode usages docs mod_summary mod_details
-
--- | Fully instantiate an interface. Adds fingerprints and potentially code
--- generator produced information.
---
--- CmmCgInfos is not available when not generating code (-fno-code), or when not
--- generating interface pragmas (-fomit-interface-pragmas). See also
--- Note [Conveying CAF-info and LFInfo between modules] in GHC.StgToCmm.Types.
-mkFullIface :: HscEnv -> PartialModIface -> Maybe StgCgInfos -> Maybe CmmCgInfos -> IO ModIface
-mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos = do
-    let decls
-          | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)
-          = mi_decls partial_iface
-          | otherwise
-          = updateDecl (mi_decls partial_iface) mb_stg_infos mb_cmm_infos
-
-    full_iface <-
-      {-# SCC "addFingerprints" #-}
-      addFingerprints hsc_env partial_iface{ mi_decls = decls }
-
-    -- Debug printing
-    let unit_state = hsc_units hsc_env
-    putDumpFileMaybe (hsc_logger hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText
-      (pprModIface unit_state full_iface)
-
-    return full_iface
-
-updateDecl :: [IfaceDecl] -> Maybe StgCgInfos -> Maybe CmmCgInfos -> [IfaceDecl]
-updateDecl decls Nothing Nothing = decls
-updateDecl decls m_stg_infos m_cmm_infos
-  = map update_decl decls
-  where
-    (non_cafs,lf_infos) = maybe (mempty, mempty)
-                                (\cmm_info -> (ncs_nameSet (cgNonCafs cmm_info), cgLFInfos cmm_info))
-                                m_cmm_infos
-    tag_sigs = fromMaybe mempty m_stg_infos
-
-    update_decl (IfaceId nm ty details infos)
-      | let not_caffy = elemNameSet nm non_cafs
-      , let mb_lf_info = lookupNameEnv lf_infos nm
-      , let sig = lookupNameEnv tag_sigs nm
-      , warnPprTrace (isNothing mb_lf_info) "updateDecl" (text "Name without LFInfo:" <+> ppr nm) True
-        -- Only allocate a new IfaceId if we're going to update the infos
-      , isJust mb_lf_info || not_caffy || isJust sig
-      = IfaceId nm ty details $
-          (if not_caffy then (HsNoCafRefs :) else id) $
-          (if isJust sig then (HsTagSig (fromJust sig):) else id) $
-          (case mb_lf_info of
-             Nothing -> infos -- LFInfos not available when building .cmm files
-             Just lf_info -> HsLFInfo (toIfaceLFInfo nm lf_info) : infos)
-
-    update_decl decl
-      = decl
-
-
-
-
--- | Make an interface from the results of typechecking only.  Useful
--- for non-optimising compilation, or where we aren't generating any
--- object code at all ('NoBackend').
-mkIfaceTc :: HscEnv
-          -> SafeHaskellMode    -- The safe haskell mode
-          -> ModDetails         -- gotten from mkBootModDetails, probably
-          -> ModSummary
-          -> Maybe CoreProgram
-          -> TcGblEnv           -- Usages, deprecations, etc
-          -> IO ModIface
-mkIfaceTc hsc_env safe_mode mod_details mod_summary mb_program
-  tc_result@TcGblEnv{ tcg_mod = this_mod,
-                      tcg_src = hsc_src,
-                      tcg_imports = imports,
-                      tcg_rdr_env = rdr_env,
-                      tcg_fix_env = fix_env,
-                      tcg_merged = merged,
-                      tcg_warns = warns,
-                      tcg_hpc = other_hpc_info,
-                      tcg_th_splice_used = tc_splice_used,
-                      tcg_dependent_files = dependent_files
-                    }
-  = do
-          let used_names = mkUsedNames tc_result
-          let pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))
-          let home_unit = hsc_home_unit hsc_env
-          let deps = mkDependencies home_unit
-                                    (tcg_mod tc_result)
-                                    (tcg_imports tc_result)
-                                    (map mi_module pluginModules)
-          let hpc_info = emptyHpcInfo other_hpc_info
-          used_th <- readIORef tc_splice_used
-          dep_files <- (readIORef dependent_files)
-          (needed_links, needed_pkgs) <- readIORef (tcg_th_needed_deps tc_result)
-          let uc = initUsageConfig hsc_env
-              plugins = hsc_plugins hsc_env
-              fc = hsc_FC hsc_env
-              unit_env = hsc_unit_env hsc_env
-          -- Do NOT use semantic module here; this_mod in mkUsageInfo
-          -- is used solely to decide if we should record a dependency
-          -- or not.  When we instantiate a signature, the semantic
-          -- module is something we want to record dependencies for,
-          -- but if you pass that in here, we'll decide it's the local
-          -- module and does not need to be recorded as a dependency.
-          -- See Note [Identity versus semantic module]
-          usages <- mkUsageInfo uc plugins fc unit_env this_mod (imp_mods imports) used_names
-                      dep_files merged needed_links needed_pkgs
-
-          docs <- extractDocs (ms_hspp_opts mod_summary) tc_result
-
-          let partial_iface = mkIface_ hsc_env
-                   this_mod (fromMaybe [] mb_program) hsc_src
-                   used_th deps rdr_env
-                   fix_env warns hpc_info
-                   (imp_trust_own_pkg imports) safe_mode usages
-                   docs mod_summary
-                   mod_details
-
-          mkFullIface hsc_env partial_iface Nothing Nothing
-
-mkIface_ :: HscEnv -> Module -> CoreProgram -> HscSource
-         -> Bool -> Dependencies -> GlobalRdrEnv
-         -> NameEnv FixItem -> Warnings GhcRn -> HpcInfo
-         -> Bool
-         -> SafeHaskellMode
-         -> [Usage]
-         -> Maybe Docs
-         -> ModSummary
-         -> ModDetails
-         -> PartialModIface
-mkIface_ hsc_env
-         this_mod core_prog hsc_src used_th deps rdr_env fix_env src_warns
-         hpc_info pkg_trust_req safe_mode usages
-         docs mod_summary
-         ModDetails{  md_insts     = insts,
-                      md_fam_insts = fam_insts,
-                      md_rules     = rules,
-                      md_anns      = anns,
-                      md_types     = type_env,
-                      md_exports   = exports,
-                      md_complete_matches = complete_matches }
--- NB:  notice that mkIface does not look at the bindings
---      only at the TypeEnv.  The previous Tidy phase has
---      put exactly the info into the TypeEnv that we want
---      to expose in the interface
-
-  = do
-    let home_unit    = hsc_home_unit hsc_env
-        semantic_mod = homeModuleNameInstantiation home_unit (moduleName this_mod)
-        entities = typeEnvElts type_env
-        show_linear_types = xopt LangExt.LinearTypes (hsc_dflags hsc_env)
-
-        extra_decls = if gopt Opt_WriteIfSimplifiedCore dflags then Just [ toIfaceTopBind b | b <- core_prog ]
-                                                               else Nothing
-        decls  = [ tyThingToIfaceDecl show_linear_types entity
-                 | entity <- entities,
-                   let name = getName entity,
-                   not (isImplicitTyThing entity),
-                      -- No implicit Ids and class tycons in the interface file
-                   not (isWiredInName name),
-                      -- Nor wired-in things; the compiler knows about them anyhow
-                   nameIsLocalOrFrom semantic_mod name  ]
-                      -- Sigh: see Note [Root-main Id] in GHC.Tc.Module
-                      -- NB: ABSOLUTELY need to check against semantic_mod,
-                      -- because all of the names in an hsig p[H=<H>]:H
-                      -- are going to be for <H>, not the former id!
-                      -- See Note [Identity versus semantic module]
-
-        fixities    = sortBy (comparing fst)
-          [(occ,fix) | FixItem occ fix <- nonDetNameEnvElts fix_env]
-          -- The order of fixities returned from nonDetNameEnvElts is not
-          -- deterministic, so we sort by OccName to canonicalize it.
-          -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details.
-        warns       = src_warns
-        iface_rules = map coreRuleToIfaceRule rules
-        iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode (instEnvElts insts)
-        iface_fam_insts = map famInstToIfaceFamInst fam_insts
-        trust_info  = setSafeMode safe_mode
-        annotations = map mkIfaceAnnotation anns
-        icomplete_matches = map mkIfaceCompleteMatch complete_matches
-
-    ModIface {
-          mi_module      = this_mod,
-          -- Need to record this because it depends on the -instantiated-with flag
-          -- which could change
-          mi_sig_of      = if semantic_mod == this_mod
-                            then Nothing
-                            else Just semantic_mod,
-          mi_hsc_src     = hsc_src,
-          mi_deps        = deps,
-          mi_usages      = usages,
-          mi_exports     = mkIfaceExports exports,
-
-          -- Sort these lexicographically, so that
-          -- the result is stable across compilations
-          mi_insts       = sortBy cmp_inst     iface_insts,
-          mi_fam_insts   = sortBy cmp_fam_inst iface_fam_insts,
-          mi_rules       = sortBy cmp_rule     iface_rules,
-
-          mi_fixities    = fixities,
-          mi_warns       = warns,
-          mi_anns        = annotations,
-          mi_globals     = maybeGlobalRdrEnv rdr_env,
-          mi_used_th     = used_th,
-          mi_decls       = decls,
-          mi_extra_decls = extra_decls,
-          mi_hpc         = isHpcUsed hpc_info,
-          mi_trust       = trust_info,
-          mi_trust_pkg   = pkg_trust_req,
-          mi_complete_matches = icomplete_matches,
-          mi_docs        = docs,
-          mi_final_exts  = (),
-          mi_ext_fields  = emptyExtensibleFields,
-          mi_src_hash = ms_hs_hash mod_summary
-          }
-  where
-     cmp_rule     = lexicalCompareFS `on` ifRuleName
-     -- Compare these lexicographically by OccName, *not* by unique,
-     -- because the latter is not stable across compilations:
-     cmp_inst     = comparing (nameOccName . ifDFun)
-     cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)
-
-     dflags = hsc_dflags hsc_env
-
-     -- We only fill in mi_globals if the module was compiled to byte
-     -- code.  Otherwise, the compiler may not have retained all the
-     -- top-level bindings and they won't be in the TypeEnv (see
-     -- Desugar.addExportFlagsAndRules).  The mi_globals field is used
-     -- by GHCi to decide whether the module has its full top-level
-     -- scope available. (#5534)
-     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
-     maybeGlobalRdrEnv rdr_env
-         | backendWantsGlobalBindings (backend dflags) = Just rdr_env
-         | otherwise                                  = Nothing
-
-     ifFamInstTcName = ifFamInstFam
-
-
-{-
-************************************************************************
-*                                                                      *
-       COMPLETE Pragmas
-*                                                                      *
-************************************************************************
--}
-
-mkIfaceCompleteMatch :: CompleteMatch -> IfaceCompleteMatch
-mkIfaceCompleteMatch (CompleteMatch cls mtc) =
-  IfaceCompleteMatch (map conLikeName (uniqDSetToList cls)) (toIfaceTyCon <$> mtc)
-
-
-{-
-************************************************************************
-*                                                                      *
-       Keeping track of what we've slurped, and fingerprints
-*                                                                      *
-************************************************************************
--}
-
-
-mkIfaceAnnotation :: Annotation -> IfaceAnnotation
-mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload })
-  = IfaceAnnotation {
-        ifAnnotatedTarget = fmap nameOccName target,
-        ifAnnotatedValue = payload
-    }
-
-mkIfaceExports :: [AvailInfo] -> [IfaceExport]  -- Sort to make canonical
-mkIfaceExports exports
-  = sortBy stableAvailCmp (map sort_subs exports)
-  where
-    sort_subs :: AvailInfo -> AvailInfo
-    sort_subs (Avail n) = Avail n
-    sort_subs (AvailTC n []) = AvailTC n []
-    sort_subs (AvailTC n (m:ms))
-       | NormalGreName n==m  = AvailTC n (m:sortBy stableGreNameCmp ms)
-       | otherwise = AvailTC n (sortBy stableGreNameCmp (m:ms))
-       -- Maintain the AvailTC Invariant
-
-{-
-Note [Original module]
-~~~~~~~~~~~~~~~~~~~~~
-Consider this:
-        module X where { data family T }
-        module Y( T(..) ) where { import X; data instance T Int = MkT Int }
-The exported Avail from Y will look like
-        X.T{X.T, Y.MkT}
-That is, in Y,
-  - only MkT is brought into scope by the data instance;
-  - but the parent (used for grouping and naming in T(..) exports) is X.T
-  - and in this case we export X.T too
-
-In the result of mkIfaceExports, the names are grouped by defining module,
-so we may need to split up a single Avail into multiple ones.
--}
-
-
-{-
-************************************************************************
-*                                                                      *
-                Converting things to their Iface equivalents
-*                                                                      *
-************************************************************************
--}
-
-tyThingToIfaceDecl :: Bool -> TyThing -> IfaceDecl
-tyThingToIfaceDecl _ (AnId id)      = idToIfaceDecl id
-tyThingToIfaceDecl _ (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)
-tyThingToIfaceDecl _ (ACoAxiom ax)  = coAxiomToIfaceDecl ax
-tyThingToIfaceDecl show_linear_types (AConLike cl)  = case cl of
-    RealDataCon dc -> dataConToIfaceDecl show_linear_types dc -- for ppr purposes only
-    PatSynCon ps   -> patSynToIfaceDecl ps
-
---------------------------
-idToIfaceDecl :: Id -> IfaceDecl
--- The Id is already tidied, so that locally-bound names
--- (lambdas, for-alls) already have non-clashing OccNames
--- We can't tidy it here, locally, because it may have
--- free variables in its type or IdInfo
-idToIfaceDecl id
-  = IfaceId { ifName      = getName id,
-              ifType      = toIfaceType (idType id),
-              ifIdDetails = toIfaceIdDetails (idDetails id),
-              ifIdInfo    = toIfaceIdInfo (idInfo id) }
-
---------------------------
-dataConToIfaceDecl :: Bool -> DataCon -> IfaceDecl
-dataConToIfaceDecl show_linear_types dataCon
-  = IfaceId { ifName      = getName dataCon,
-              ifType      = toIfaceType (dataConDisplayType show_linear_types dataCon),
-              ifIdDetails = IfVanillaId,
-              ifIdInfo    = [] }
-
---------------------------
-coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
--- We *do* tidy Axioms, because they are not (and cannot
--- conveniently be) built in tidy form
-coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
-                               , co_ax_role = role })
- = IfaceAxiom { ifName       = getName ax
-              , ifTyCon      = toIfaceTyCon tycon
-              , ifRole       = role
-              , ifAxBranches = map (coAxBranchToIfaceBranch tycon
-                                     (map coAxBranchLHS branch_list))
-                                   branch_list }
- where
-   branch_list = fromBranches branches
-
--- 2nd parameter is the list of branch LHSs, in case of a closed type family,
--- for conversion from incompatible branches to incompatible indices.
--- For an open type family the list should be empty.
--- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom
-coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch
-coAxBranchToIfaceBranch tc lhs_s
-                        (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
-                                    , cab_eta_tvs = eta_tvs
-                                    , cab_lhs = lhs, cab_roles = roles
-                                    , cab_rhs = rhs, cab_incomps = incomps })
-
-  = IfaceAxBranch { ifaxbTyVars  = toIfaceTvBndrs tvs
-                  , ifaxbCoVars  = map toIfaceIdBndr cvs
-                  , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs
-                  , ifaxbLHS     = toIfaceTcArgs tc lhs
-                  , ifaxbRoles   = roles
-                  , ifaxbRHS     = toIfaceType rhs
-                  , ifaxbIncomps = iface_incomps }
-  where
-    iface_incomps = map (expectJust "iface_incomps"
-                        . flip findIndex lhs_s
-                        . eqTypes
-                        . coAxBranchLHS) incomps
-
------------------
-tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
--- We *do* tidy TyCons, because they are not (and cannot
--- conveniently be) built in tidy form
--- The returned TidyEnv is the one after tidying the tyConTyVars
-tyConToIfaceDecl env tycon
-  | Just clas <- tyConClass_maybe tycon
-  = classToIfaceDecl env clas
-
-  | Just syn_rhs <- synTyConRhs_maybe tycon
-  = ( tc_env1
-    , IfaceSynonym { ifName    = getName tycon,
-                     ifRoles   = tyConRoles tycon,
-                     ifSynRhs  = if_syn_type syn_rhs,
-                     ifBinders = if_binders,
-                     ifResKind = if_res_kind
-                   })
-
-  | Just fam_flav <- famTyConFlav_maybe tycon
-  = ( tc_env1
-    , IfaceFamily { ifName    = getName tycon,
-                    ifResVar  = if_res_var,
-                    ifFamFlav = to_if_fam_flav fam_flav,
-                    ifBinders = if_binders,
-                    ifResKind = if_res_kind,
-                    ifFamInj  = tyConInjectivityInfo tycon
-                  })
-
-  | isAlgTyCon tycon
-  = ( tc_env1
-    , IfaceData { ifName    = getName tycon,
-                  ifBinders = if_binders,
-                  ifResKind = if_res_kind,
-                  ifCType   = tyConCType tycon,
-                  ifRoles   = tyConRoles tycon,
-                  ifCtxt    = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
-                  ifCons    = ifaceConDecls (algTyConRhs tycon),
-                  ifGadtSyntax = isGadtSyntaxTyCon tycon,
-                  ifParent  = parent })
-
-  | otherwise  -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
-  -- We only convert these TyCons to IfaceTyCons when we are
-  -- just about to pretty-print them, not because we are going
-  -- to put them into interface files
-  = ( env
-    , IfaceData { ifName       = getName tycon,
-                  ifBinders    = if_binders,
-                  ifResKind    = if_res_kind,
-                  ifCType      = Nothing,
-                  ifRoles      = tyConRoles tycon,
-                  ifCtxt       = [],
-                  ifCons       = IfDataTyCon False [],
-                  ifGadtSyntax = False,
-                  ifParent     = IfNoParent })
-  where
-    -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon`
-    -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause
-    -- an error.
-    (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
-    tc_tyvars      = binderVars tc_binders
-    if_binders     = toIfaceForAllBndrs tc_binders
-                     -- No tidying of the binders; they are already tidy
-    if_res_kind    = tidyToIfaceType tc_env1 (tyConResKind tycon)
-    if_syn_type ty = tidyToIfaceType tc_env1 ty
-    if_res_var     = getOccFS `fmap` tyConFamilyResVar_maybe tycon
-
-    parent = case tyConFamInstSig_maybe tycon of
-               Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)
-                                                   (toIfaceTyCon tc)
-                                                   (tidyToIfaceTcArgs tc_env1 tc ty)
-               Nothing           -> IfNoParent
-
-    to_if_fam_flav OpenSynFamilyTyCon             = IfaceOpenSynFamilyTyCon
-    to_if_fam_flav AbstractClosedSynFamilyTyCon   = IfaceAbstractClosedSynFamilyTyCon
-    to_if_fam_flav (DataFamilyTyCon {})           = IfaceDataFamilyTyCon
-    to_if_fam_flav (BuiltInSynFamTyCon {})        = IfaceBuiltInSynFamTyCon
-    to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing
-    to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))
-      = IfaceClosedSynFamilyTyCon (Just (axn, ibr))
-      where defs = fromBranches $ coAxiomBranches ax
-            lhss = map coAxBranchLHS defs
-            ibr  = map (coAxBranchToIfaceBranch tycon lhss) defs
-            axn  = coAxiomName ax
-
-    ifaceConDecls (NewTyCon { data_con = con })    = IfNewTyCon  (ifaceConDecl con)
-    ifaceConDecls (DataTyCon { data_cons = cons, is_type_data = type_data })
-      = IfDataTyCon type_data (map ifaceConDecl cons)
-    ifaceConDecls (TupleTyCon { data_con = con })  = IfDataTyCon False [ifaceConDecl con]
-    ifaceConDecls (SumTyCon { data_cons = cons })  = IfDataTyCon False (map ifaceConDecl cons)
-    ifaceConDecls AbstractTyCon                    = IfAbstractTyCon
-        -- The AbstractTyCon case happens when a TyCon has been trimmed
-        -- during tidying.
-        -- Furthermore, tyThingToIfaceDecl is also used in GHC.Tc.Module
-        -- for GHCi, when browsing a module, in which case the
-        -- AbstractTyCon and TupleTyCon cases are perfectly sensible.
-        -- (Tuple declarations are not serialised into interface files.)
-
-    ifaceConDecl data_con
-        = IfCon   { ifConName    = dataConName data_con,
-                    ifConInfix   = dataConIsInfix data_con,
-                    ifConWrapper = isJust (dataConWrapId_maybe data_con),
-                    ifConExTCvs  = map toIfaceBndr ex_tvs',
-                    ifConUserTvBinders = toIfaceForAllBndrs user_bndrs',
-                    ifConEqSpec  = map (to_eq_spec . eqSpecPair) eq_spec,
-                    ifConCtxt    = tidyToIfaceContext con_env2 theta,
-                    ifConArgTys  =
-                      map (\(Scaled w t) -> (tidyToIfaceType con_env2 w
-                                          , (tidyToIfaceType con_env2 t))) arg_tys,
-                    ifConFields  = dataConFieldLabels data_con,
-                    ifConStricts = map (toIfaceBang con_env2)
-                                       (dataConImplBangs data_con),
-                    ifConSrcStricts = map toIfaceSrcBang
-                                          (dataConSrcBangs data_con)}
-        where
-          (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
-            = dataConFullSig data_con
-          user_bndrs = dataConUserTyVarBinders data_con
-
-          -- Tidy the univ_tvs of the data constructor to be identical
-          -- to the tyConTyVars of the type constructor.  This means
-          -- (a) we don't need to redundantly put them into the interface file
-          -- (b) when pretty-printing an Iface data declaration in H98-style syntax,
-          --     we know that the type variables will line up
-          -- The latter (b) is important because we pretty-print type constructors
-          -- by converting to Iface syntax and pretty-printing that
-          con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
-                     -- A bit grimy, perhaps, but it's simple!
-
-          (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs
-          user_bndrs' = map (tidyUserForAllTyBinder con_env2) user_bndrs
-          to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)
-
-          -- By this point, we have tidied every universal and existential
-          -- tyvar. Because of the dcUserForAllTyBinders invariant
-          -- (see Note [DataCon user type variable binders]), *every*
-          -- user-written tyvar must be contained in the substitution that
-          -- tidying produced. Therefore, tidying the user-written tyvars is a
-          -- simple matter of looking up each variable in the substitution,
-          -- which tidyTyCoVarOcc accomplishes.
-          tidyUserForAllTyBinder :: TidyEnv -> InvisTVBinder -> InvisTVBinder
-          tidyUserForAllTyBinder env (Bndr tv vis) =
-            Bndr (tidyTyCoVarOcc env tv) vis
-
-classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
-classToIfaceDecl env clas
-  = ( env1
-    , IfaceClass { ifName   = getName tycon,
-                   ifRoles  = tyConRoles (classTyCon clas),
-                   ifBinders = toIfaceForAllBndrs tc_binders,
-                   ifBody   = body,
-                   ifFDs    = map toIfaceFD clas_fds })
-  where
-    (_, clas_fds, sc_theta, _, clas_ats, op_stuff)
-      = classExtraBigSig clas
-    tycon = classTyCon clas
-
-    body | isAbstractTyCon tycon = IfAbstractClass
-         | otherwise
-         = IfConcreteClass {
-                ifClassCtxt   = tidyToIfaceContext env1 sc_theta,
-                ifATs    = map toIfaceAT clas_ats,
-                ifSigs   = map toIfaceClassOp op_stuff,
-                ifMinDef = fmap getOccFS (classMinimalDef clas)
-            }
-
-    (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
-
-    toIfaceAT :: ClassATItem -> IfaceAT
-    toIfaceAT (ATI tc def)
-      = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)
-      where
-        (env2, if_decl) = tyConToIfaceDecl env1 tc
-
-    toIfaceClassOp (sel_id, def_meth)
-        = assert (sel_tyvars == binderVars tc_binders) $
-          IfaceClassOp (getName sel_id)
-                       (tidyToIfaceType env1 op_ty)
-                       (fmap toDmSpec def_meth)
-        where
-                -- Be careful when splitting the type, because of things
-                -- like         class Foo a where
-                --                op :: (?x :: String) => a -> a
-                -- and          class Baz a where
-                --                op :: (Ord a) => a -> a
-          (sel_tyvars, rho_ty) = splitForAllTyCoVars (idType sel_id)
-          op_ty                = funResultTy rho_ty
-
-    toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType
-    toDmSpec (_, VanillaDM)       = VanillaDM
-    toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)
-
-    toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1
-                             ,map (tidyTyVar env1) tvs2)
-
---------------------------
-
-tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)
--- If the type variable "binder" is in scope, don't re-bind it
--- In a class decl, for example, the ATD binders mention
--- (amd must mention) the class tyvars
-tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)
- = case lookupVarEnv subst tv of
-     Just tv' -> (env,  Bndr tv' vis)
-     Nothing  -> tidyForAllTyBinder env tvb
-
-tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
-tidyTyConBinders = mapAccumL tidyTyConBinder
-
-tidyTyVar :: TidyEnv -> TyVar -> FastString
-tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
-
---------------------------
-instanceToIfaceInst :: ClsInst -> IfaceClsInst
-instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
-                             , is_cls_nm = cls_name, is_cls = cls
-                             , is_tcs = rough_tcs
-                             , is_orphan = orph })
-  = assert (cls_name == className cls) $
-    IfaceClsInst { ifDFun     = idName dfun_id
-                 , ifOFlag    = oflag
-                 , ifInstCls  = cls_name
-                 , ifInstTys  = ifaceRoughMatchTcs $ tail rough_tcs
-                   -- N.B. Drop the class name from the rough match template
-                   --      It is put back by GHC.Core.InstEnv.mkImportedInstance
-                 , ifInstOrph = orph }
-
---------------------------
-famInstToIfaceFamInst :: FamInst -> IfaceFamInst
-famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,
-                                 fi_fam      = fam,
-                                 fi_tcs      = rough_tcs })
-  = IfaceFamInst { ifFamInstAxiom    = coAxiomName axiom
-                 , ifFamInstFam      = fam
-                 , ifFamInstTys      = ifaceRoughMatchTcs rough_tcs
-                 , ifFamInstOrph     = orph }
-  where
-    fam_decl = tyConName $ coAxiomTyCon axiom
-    mod = assert (isExternalName (coAxiomName axiom)) $
-          nameModule (coAxiomName axiom)
-    is_local name = nameIsLocalOrFrom mod name
-
-    lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)
-
-    orph | is_local fam_decl
-         = NotOrphan (nameOccName fam_decl)
-         | otherwise
-         = chooseOrphanAnchor lhs_names
-
-ifaceRoughMatchTcs :: [RoughMatchTc] -> [Maybe IfaceTyCon]
-ifaceRoughMatchTcs tcs = map do_rough tcs
-  where
-    do_rough RM_WildCard     = Nothing
-    do_rough (RM_KnownTc n) = Just (toIfaceTyCon_name n)
-
---------------------------
-coreRuleToIfaceRule :: CoreRule -> IfaceRule
--- A plugin that installs a BuiltinRule in a CoreDoPluginPass should
--- ensure that there's another CoreDoPluginPass that removes the rule.
--- Otherwise a module using the plugin and compiled with -fno-omit-interface-pragmas
--- would cause panic when the rule is attempted to be written to the interface file.
-coreRuleToIfaceRule rule@(BuiltinRule {})
-  = pprPanic "toHsRule:" (pprRule rule)
-
-coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,
-                            ru_act = act, ru_bndrs = bndrs,
-                            ru_args = args, ru_rhs = rhs,
-                            ru_orphan = orph, ru_auto = auto })
-  = IfaceRule { ifRuleName  = name, ifActivation = act,
-                ifRuleBndrs = map toIfaceBndr bndrs,
-                ifRuleHead  = fn,
-                ifRuleArgs  = map do_arg args,
-                ifRuleRhs   = toIfaceExpr rhs,
-                ifRuleAuto  = auto,
-                ifRuleOrph  = orph }
-  where
-        -- For type args we must remove synonyms from the outermost
-        -- level.  Reason: so that when we read it back in we'll
-        -- construct the same ru_rough field as we have right now;
-        -- see tcIfaceRule
-    do_arg (Type ty)     = IfaceType (toIfaceType (deNoteType ty))
-    do_arg (Coercion co) = IfaceCo   (toIfaceCoercion co)
-    do_arg arg           = toIfaceExpr arg
diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs
deleted file mode 100644
--- a/compiler/GHC/Iface/Recomp.hs
+++ /dev/null
@@ -1,1645 +0,0 @@
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE LambdaCase #-}
-
--- | Module for detecting if recompilation is required
-module GHC.Iface.Recomp
-   ( checkOldIface
-   , RecompileRequired(..)
-   , needsRecompileBecause
-   , recompThen
-   , MaybeValidated(..)
-   , outOfDateItemBecause
-   , RecompReason (..)
-   , CompileReason(..)
-   , recompileRequired
-   , addFingerprints
-   )
-where
-
-import GHC.Prelude
-import GHC.Data.FastString
-
-import GHC.Driver.Backend
-import GHC.Driver.Config.Finder
-import GHC.Driver.Env
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Driver.Plugins
-
-import GHC.Iface.Syntax
-import GHC.Iface.Recomp.Binary
-import GHC.Iface.Load
-import GHC.Iface.Recomp.Flags
-import GHC.Iface.Env
-
-import GHC.Core
-import GHC.Tc.Utils.Monad
-import GHC.Hs
-
-import GHC.Data.Graph.Directed
-import GHC.Data.Maybe
-
-import GHC.Utils.Error
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Misc as Utils
-import GHC.Utils.Binary
-import GHC.Utils.Fingerprint
-import GHC.Utils.Exception
-import GHC.Utils.Logger
-import GHC.Utils.Constants (debugIsOn)
-
-import GHC.Types.Annotations
-import GHC.Types.Name
-import GHC.Types.Name.Set
-import GHC.Types.SrcLoc
-import GHC.Types.Unique
-import GHC.Types.Unique.Set
-import GHC.Types.Fixity.Env
-import GHC.Unit.External
-import GHC.Unit.Finder
-import GHC.Unit.State
-import GHC.Unit.Home
-import GHC.Unit.Module
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.ModSummary
-import GHC.Unit.Module.Warnings
-import GHC.Unit.Module.Deps
-
-import Control.Monad
-import Data.List (sortBy, sort, sortOn)
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import Data.Word (Word64)
-import Data.Either
-
---Qualified import so we can define a Semigroup instance
--- but it doesn't clash with Outputable.<>
-import qualified Data.Semigroup
-import GHC.List (uncons)
-import Data.Ord
-import Data.Containers.ListUtils
-import Data.Bifunctor
-
-{-
-  -----------------------------------------------
-          Recompilation checking
-  -----------------------------------------------
-
-A complete description of how recompilation checking works can be
-found in the wiki commentary:
-
- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance
-
-Please read the above page for a top-down description of how this all
-works.  Notes below cover specific issues related to the implementation.
-
-Basic idea:
-
-  * In the mi_usages information in an interface, we record the
-    fingerprint of each free variable of the module
-
-  * In mkIface, we compute the fingerprint of each exported thing A.f.
-    For each external thing that A.f refers to, we include the fingerprint
-    of the external reference when computing the fingerprint of A.f.  So
-    if anything that A.f depends on changes, then A.f's fingerprint will
-    change.
-    Also record any dependent files added with
-      * addDependentFile
-      * #include
-      * -optP-include
-
-  * In checkOldIface we compare the mi_usages for the module with
-    the actual fingerprint for all each thing recorded in mi_usages
--}
-
-data RecompileRequired
-  -- | everything is up to date, recompilation is not required
-  = UpToDate
-  -- | Need to compile the module
-  | NeedsRecompile !CompileReason
-   deriving (Eq)
-
-needsRecompileBecause :: RecompReason -> RecompileRequired
-needsRecompileBecause = NeedsRecompile . RecompBecause
-
-data MaybeValidated a
-  -- | The item contained is validated to be up to date
-  = UpToDateItem a
-  -- | The item is are absent altogether or out of date, for the reason given.
-  | OutOfDateItem
-      !CompileReason
-      -- ^ the reason we need to recompile.
-      (Maybe a)
-      -- ^ The old item, if it exists
-  deriving (Functor)
-
-instance Outputable a => Outputable (MaybeValidated a) where
-  ppr (UpToDateItem a) = text "UpToDate" <+> ppr a
-  ppr (OutOfDateItem r _) = text "OutOfDate: " <+> ppr r
-
-outOfDateItemBecause :: RecompReason -> Maybe a -> MaybeValidated a
-outOfDateItemBecause reason item = OutOfDateItem (RecompBecause reason) item
-
-data CompileReason
-  -- | The .hs file has been touched, or the .o/.hi file does not exist
-  = MustCompile
-  -- | The .o/.hi files are up to date, but something else has changed
-  -- to force recompilation; the String says what (one-line summary)
-  | RecompBecause !RecompReason
-   deriving (Eq)
-
-instance Outputable RecompileRequired where
-  ppr UpToDate = text "UpToDate"
-  ppr (NeedsRecompile reason) = ppr reason
-
-instance Outputable CompileReason where
-  ppr MustCompile = text "MustCompile"
-  ppr (RecompBecause r) = text "RecompBecause" <+> ppr r
-
-instance Semigroup RecompileRequired where
-  UpToDate <> r = r
-  mc <> _       = mc
-
-instance Monoid RecompileRequired where
-  mempty = UpToDate
-
-data RecompReason
-  = UnitDepRemoved UnitId
-  | ModulePackageChanged FastString
-  | SourceFileChanged
-  | ThisUnitIdChanged
-  | ImpurePlugin
-  | PluginsChanged
-  | PluginFingerprintChanged
-  | ModuleInstChanged
-  | HieMissing
-  | HieOutdated
-  | SigsMergeChanged
-  | ModuleChanged ModuleName
-  | ModuleRemoved (UnitId, ModuleName)
-  | ModuleAdded (UnitId, ModuleName)
-  | ModuleChangedRaw ModuleName
-  | ModuleChangedIface ModuleName
-  | FileChanged FilePath
-  | CustomReason String
-  | FlagsChanged
-  | OptimFlagsChanged
-  | HpcFlagsChanged
-  | MissingBytecode
-  | MissingObjectFile
-  | MissingDynObjectFile
-  | MissingDynHiFile
-  | MismatchedDynHiFile
-  | ObjectsChanged
-  | LibraryChanged
-  deriving (Eq)
-
-instance Outputable RecompReason where
-  ppr = \case
-    UnitDepRemoved uid       -> ppr uid <+> text "removed"
-    ModulePackageChanged s   -> ftext s <+> text "package changed"
-    SourceFileChanged        -> text "Source file changed"
-    ThisUnitIdChanged        -> text "-this-unit-id changed"
-    ImpurePlugin             -> text "Impure plugin forced recompilation"
-    PluginsChanged           -> text "Plugins changed"
-    PluginFingerprintChanged -> text "Plugin fingerprint changed"
-    ModuleInstChanged        -> text "Implementing module changed"
-    HieMissing               -> text "HIE file is missing"
-    HieOutdated              -> text "HIE file is out of date"
-    SigsMergeChanged         -> text "Signatures to merge in changed"
-    ModuleChanged m          -> ppr m <+> text "changed"
-    ModuleChangedRaw m       -> ppr m <+> text "changed (raw)"
-    ModuleChangedIface m     -> ppr m <+> text "changed (interface)"
-    ModuleRemoved (_uid, m)   -> ppr m <+> text "removed"
-    ModuleAdded (_uid, m)     -> ppr m <+> text "added"
-    FileChanged fp           -> text fp <+> text "changed"
-    CustomReason s           -> text s
-    FlagsChanged             -> text "Flags changed"
-    OptimFlagsChanged        -> text "Optimisation flags changed"
-    HpcFlagsChanged          -> text "HPC flags changed"
-    MissingBytecode          -> text "Missing bytecode"
-    MissingObjectFile        -> text "Missing object file"
-    MissingDynObjectFile     -> text "Missing dynamic object file"
-    MissingDynHiFile         -> text "Missing dynamic interface file"
-    MismatchedDynHiFile     -> text "Mismatched dynamic interface file"
-    ObjectsChanged          -> text "Objects changed"
-    LibraryChanged          -> text "Library changed"
-
-recompileRequired :: RecompileRequired -> Bool
-recompileRequired UpToDate = False
-recompileRequired _ = True
-
-recompThen :: Monad m => m RecompileRequired -> m RecompileRequired -> m RecompileRequired
-recompThen ma mb = ma >>= \case
-  UpToDate              -> mb
-  rr@(NeedsRecompile _) -> pure rr
-
-checkList :: Monad m => [m RecompileRequired] -> m RecompileRequired
-checkList = \case
-  []               -> return UpToDate
-  (check : checks) -> check `recompThen` checkList checks
-
-----------------------
-
--- | Top level function to check if the version of an old interface file
--- is equivalent to the current source file the user asked us to compile.
--- If the same, we can avoid recompilation.
---
--- We return on the outside whether the interface file is up to date, providing
--- evidence that is with a `ModIface`. In the case that it isn't, we may also
--- return a found or provided `ModIface`. Why we don't always return the old
--- one, if it exists, is unclear to me, except that I tried it and some tests
--- failed (see #18205).
-checkOldIface
-  :: HscEnv
-  -> ModSummary
-  -> Maybe ModIface         -- Old interface from compilation manager, if any
-  -> IO (MaybeValidated ModIface)
-
-checkOldIface hsc_env mod_summary maybe_iface
-  = do  let dflags = hsc_dflags hsc_env
-        let logger = hsc_logger hsc_env
-        showPass logger $
-            "Checking old interface for " ++
-              (showPpr dflags $ ms_mod mod_summary) ++
-              " (use -ddump-hi-diffs for more details)"
-        initIfaceCheck (text "checkOldIface") hsc_env $
-            check_old_iface hsc_env mod_summary maybe_iface
-
-check_old_iface
-  :: HscEnv
-  -> ModSummary
-  -> Maybe ModIface
-  -> IfG (MaybeValidated ModIface)
-
-check_old_iface hsc_env mod_summary maybe_iface
-  = let dflags = hsc_dflags hsc_env
-        logger = hsc_logger hsc_env
-        getIface =
-            case maybe_iface of
-                Just _  -> do
-                    trace_if logger (text "We already have the old interface for" <+>
-                      ppr (ms_mod mod_summary))
-                    return maybe_iface
-                Nothing -> loadIface dflags (msHiFilePath mod_summary)
-
-        loadIface read_dflags iface_path = do
-             let ncu        = hsc_NC hsc_env
-             read_result <- readIface read_dflags ncu (ms_mod mod_summary) iface_path
-             case read_result of
-                 Failed err -> do
-                     trace_if logger (text "FYI: cannot read old interface file:" $$ nest 4 err)
-                     trace_hi_diffs logger (text "Old interface file was invalid:" $$ nest 4 err)
-                     return Nothing
-                 Succeeded iface -> do
-                     trace_if logger (text "Read the interface file" <+> text iface_path)
-                     return $ Just iface
-        check_dyn_hi :: ModIface
-                  -> IfG (MaybeValidated ModIface)
-                  -> IfG (MaybeValidated ModIface)
-        check_dyn_hi normal_iface recomp_check | gopt Opt_BuildDynamicToo dflags = do
-          res <- recomp_check
-          case res of
-            UpToDateItem _ -> do
-              maybe_dyn_iface <- liftIO $ loadIface (setDynamicNow dflags) (msDynHiFilePath mod_summary)
-              case maybe_dyn_iface of
-                Nothing -> return $ outOfDateItemBecause MissingDynHiFile Nothing
-                Just dyn_iface | mi_iface_hash (mi_final_exts dyn_iface)
-                                    /= mi_iface_hash (mi_final_exts normal_iface)
-                  -> return $ outOfDateItemBecause MismatchedDynHiFile Nothing
-                Just {} -> return res
-            _ -> return res
-        check_dyn_hi _ recomp_check = recomp_check
-
-
-        src_changed
-            | gopt Opt_ForceRecomp dflags    = True
-            | otherwise = False
-    in do
-        when src_changed $
-            liftIO $ trace_hi_diffs logger (nest 4 $ text "Recompilation check turned off")
-
-        case src_changed of
-            -- If the source has changed and we're in interactive mode,
-            -- avoid reading an interface; just return the one we might
-            -- have been supplied with.
-            True | not (backendWritesFiles $ backend dflags) ->
-                return $ OutOfDateItem MustCompile maybe_iface
-
-            -- Try and read the old interface for the current module
-            -- from the .hi file left from the last time we compiled it
-            True -> do
-                maybe_iface' <- liftIO $ getIface
-                return $ OutOfDateItem MustCompile maybe_iface'
-
-            False -> do
-                maybe_iface' <- liftIO $ getIface
-                case maybe_iface' of
-                    -- We can't retrieve the iface
-                    Nothing    -> return $ OutOfDateItem MustCompile Nothing
-
-                    -- We have got the old iface; check its versions
-                    -- even in the SourceUnmodifiedAndStable case we
-                    -- should check versions because some packages
-                    -- might have changed or gone away.
-                    Just iface ->
-                      check_dyn_hi iface $ checkVersions hsc_env mod_summary iface
-
--- | Check if a module is still the same 'version'.
---
--- This function is called in the recompilation checker after we have
--- determined that the module M being checked hasn't had any changes
--- to its source file since we last compiled M. So at this point in general
--- two things may have changed that mean we should recompile M:
---   * The interface export by a dependency of M has changed.
---   * The compiler flags specified this time for M have changed
---     in a manner that is significant for recompilation.
--- We return not just if we should recompile the object file but also
--- if we should rebuild the interface file.
-checkVersions :: HscEnv
-              -> ModSummary
-              -> ModIface       -- Old interface
-              -> IfG (MaybeValidated ModIface)
-checkVersions hsc_env mod_summary iface
-  = do { liftIO $ trace_hi_diffs logger
-                        (text "Considering whether compilation is required for" <+>
-                        ppr (mi_module iface) <> colon)
-
-       -- readIface will have verified that the UnitId matches,
-       -- but we ALSO must make sure the instantiation matches up.  See
-       -- test case bkpcabal04!
-       ; hsc_env <- getTopEnv
-       ; if mi_src_hash iface /= ms_hs_hash mod_summary
-            then return $ outOfDateItemBecause SourceFileChanged Nothing else do {
-       ; if not (isHomeModule home_unit (mi_module iface))
-            then return $ outOfDateItemBecause ThisUnitIdChanged Nothing else do {
-       ; recomp <- liftIO $ checkFlagHash hsc_env iface
-                             `recompThen` checkOptimHash hsc_env iface
-                             `recompThen` checkHpcHash hsc_env iface
-                             `recompThen` checkMergedSignatures hsc_env mod_summary iface
-                             `recompThen` checkHsig logger home_unit mod_summary iface
-                             `recompThen` pure (checkHie dflags mod_summary)
-       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do {
-       ; recomp <- checkDependencies hsc_env mod_summary iface
-       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {
-       ; recomp <- checkPlugins (hsc_plugins hsc_env) iface
-       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason Nothing ; _ -> do {
-
-
-       -- Source code unchanged and no errors yet... carry on
-       --
-       -- First put the dependent-module info, read from the old
-       -- interface, into the envt, so that when we look for
-       -- interfaces we look for the right one (.hi or .hi-boot)
-       --
-       -- It's just temporary because either the usage check will succeed
-       -- (in which case we are done with this module) or it'll fail (in which
-       -- case we'll compile the module from scratch anyhow).
-
-       when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do {
-          ; updateEps_ $ \eps  -> eps { eps_is_boot = mkModDeps $ dep_boot_mods (mi_deps iface) }
-       }
-       ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) (homeUnitAsUnit home_unit) u
-                             | u <- mi_usages iface]
-       ; case recomp of (NeedsRecompile reason) -> return $ OutOfDateItem reason (Just iface) ; _ -> do {
-       ; return $ UpToDateItem iface
-    }}}}}}}
-  where
-    logger = hsc_logger hsc_env
-    dflags = hsc_dflags hsc_env
-    home_unit = hsc_home_unit hsc_env
-
-
-
--- | Check if any plugins are requesting recompilation
-checkPlugins :: Plugins -> ModIface -> IfG RecompileRequired
-checkPlugins plugins iface = liftIO $ do
-  recomp <- recompPlugins plugins
-  let new_fingerprint = fingerprintPluginRecompile recomp
-  let old_fingerprint = mi_plugin_hash (mi_final_exts iface)
-  return $ pluginRecompileToRecompileRequired old_fingerprint new_fingerprint recomp
-
-recompPlugins :: Plugins -> IO PluginRecompile
-recompPlugins plugins = mconcat <$> mapM pluginRecompile' (pluginsWithArgs plugins)
-
-fingerprintPlugins :: Plugins -> IO Fingerprint
-fingerprintPlugins plugins = fingerprintPluginRecompile <$> recompPlugins plugins
-
-fingerprintPluginRecompile :: PluginRecompile -> Fingerprint
-fingerprintPluginRecompile recomp = case recomp of
-  NoForceRecompile  -> fingerprintString "NoForceRecompile"
-  ForceRecompile    -> fingerprintString "ForceRecompile"
-  -- is the chance of collision worth worrying about?
-  -- An alternative is to fingerprintFingerprints [fingerprintString
-  -- "maybeRecompile", fp]
-  MaybeRecompile fp -> fp
-
-
-pluginRecompileToRecompileRequired
-    :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired
-pluginRecompileToRecompileRequired old_fp new_fp pr
-  | old_fp == new_fp =
-    case pr of
-      NoForceRecompile  -> UpToDate
-
-      -- we already checked the fingerprint above so a mismatch is not possible
-      -- here, remember that: `fingerprint (MaybeRecomp x) == x`.
-      MaybeRecompile _  -> UpToDate
-
-      -- when we have an impure plugin in the stack we have to unconditionally
-      -- recompile since it might integrate all sorts of crazy IO results into
-      -- its compilation output.
-      ForceRecompile    -> needsRecompileBecause ImpurePlugin
-
-  | old_fp `elem` magic_fingerprints ||
-    new_fp `elem` magic_fingerprints
-    -- The fingerprints do not match either the old or new one is a magic
-    -- fingerprint. This happens when non-pure plugins are added for the first
-    -- time or when we go from one recompilation strategy to another: (force ->
-    -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.)
-    --
-    -- For example when we go from ForceRecomp to NoForceRecomp
-    -- recompilation is triggered since the old impure plugins could have
-    -- changed the build output which is now back to normal.
-    = needsRecompileBecause PluginsChanged
-
-  | otherwise =
-    case pr of
-      -- even though a plugin is forcing recompilation the fingerprint changed
-      -- which would cause recompilation anyways so we report the fingerprint
-      -- change instead.
-      ForceRecompile   -> needsRecompileBecause PluginFingerprintChanged
-
-      _                -> needsRecompileBecause PluginFingerprintChanged
-
- where
-   magic_fingerprints =
-       [ fingerprintString "NoForceRecompile"
-       , fingerprintString "ForceRecompile"
-       ]
-
-
--- | Check if an hsig file needs recompilation because its
--- implementing module has changed.
-checkHsig :: Logger -> HomeUnit -> ModSummary -> ModIface -> IO RecompileRequired
-checkHsig logger home_unit mod_summary iface = do
-    let outer_mod = ms_mod mod_summary
-        inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod)
-    massert (isHomeModule home_unit outer_mod)
-    case inner_mod == mi_semantic_module iface of
-        True -> up_to_date logger (text "implementing module unchanged")
-        False -> return $ needsRecompileBecause ModuleInstChanged
-
--- | Check if @.hie@ file is out of date or missing.
-checkHie :: DynFlags -> ModSummary -> RecompileRequired
-checkHie dflags mod_summary =
-    let hie_date_opt = ms_hie_date mod_summary
-        hi_date = ms_iface_date mod_summary
-    in if not (gopt Opt_WriteHie dflags)
-      then UpToDate
-      else case (hie_date_opt, hi_date) of
-             (Nothing, _) -> needsRecompileBecause HieMissing
-             (Just hie_date, Just hi_date)
-                 | hie_date < hi_date
-                 -> needsRecompileBecause HieOutdated
-             _ -> UpToDate
-
--- | Check the flags haven't changed
-checkFlagHash :: HscEnv -> ModIface -> IO RecompileRequired
-checkFlagHash hsc_env iface = do
-    let logger   = hsc_logger hsc_env
-    let old_hash = mi_flag_hash (mi_final_exts iface)
-    new_hash <- fingerprintDynFlags hsc_env (mi_module iface) putNameLiterally
-    case old_hash == new_hash of
-        True  -> up_to_date logger (text "Module flags unchanged")
-        False -> out_of_date_hash logger FlagsChanged
-                     (text "  Module flags have changed")
-                     old_hash new_hash
-
--- | Check the optimisation flags haven't changed
-checkOptimHash :: HscEnv -> ModIface -> IO RecompileRequired
-checkOptimHash hsc_env iface = do
-    let logger   = hsc_logger hsc_env
-    let old_hash = mi_opt_hash (mi_final_exts iface)
-    new_hash <- fingerprintOptFlags (hsc_dflags hsc_env)
-                                               putNameLiterally
-    if | old_hash == new_hash
-         -> up_to_date logger (text "Optimisation flags unchanged")
-       | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)
-         -> up_to_date logger (text "Optimisation flags changed; ignoring")
-       | otherwise
-         -> out_of_date_hash logger OptimFlagsChanged
-                     (text "  Optimisation flags have changed")
-                     old_hash new_hash
-
--- | Check the HPC flags haven't changed
-checkHpcHash :: HscEnv -> ModIface -> IO RecompileRequired
-checkHpcHash hsc_env iface = do
-    let logger   = hsc_logger hsc_env
-    let old_hash = mi_hpc_hash (mi_final_exts iface)
-    new_hash <- fingerprintHpcFlags (hsc_dflags hsc_env)
-                                               putNameLiterally
-    if | old_hash == new_hash
-         -> up_to_date logger (text "HPC flags unchanged")
-       | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)
-         -> up_to_date logger (text "HPC flags changed; ignoring")
-       | otherwise
-         -> out_of_date_hash logger HpcFlagsChanged
-                     (text "  HPC flags have changed")
-                     old_hash new_hash
-
--- Check that the set of signatures we are merging in match.
--- If the -unit-id flags change, this can change too.
-checkMergedSignatures :: HscEnv -> ModSummary -> ModIface -> IO RecompileRequired
-checkMergedSignatures hsc_env mod_summary iface = do
-    let logger     = hsc_logger hsc_env
-    let unit_state = hsc_units hsc_env
-    let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]
-        new_merged = case Map.lookup (ms_mod_name mod_summary)
-                                     (requirementContext unit_state) of
-                        Nothing -> []
-                        Just r -> sort $ map (instModuleToModule unit_state) r
-    if old_merged == new_merged
-        then up_to_date logger (text "signatures to merge in unchanged" $$ ppr new_merged)
-        else return $ needsRecompileBecause SigsMergeChanged
-
--- If the direct imports of this module are resolved to targets that
--- are not among the dependencies of the previous interface file,
--- then we definitely need to recompile.  This catches cases like
---   - an exposed package has been upgraded
---   - we are compiling with different package flags
---   - a home module that was shadowing a package module has been removed
---   - a new home module has been added that shadows a package module
--- See bug #1372.
---
--- Returns (RecompBecause <reason>) if recompilation is required.
-checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
-checkDependencies hsc_env summary iface
- = do
-    res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
-    res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
-    case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
-      Left recomp -> return $ NeedsRecompile recomp
-      Right es -> do
-        let (hs, ps) = partitionEithers es
-        liftIO $
-          check_mods (sort hs) prev_dep_mods
-          `recompThen`
-            let allPkgDeps = sortBy (comparing snd) $ nubOrdOn snd (ps ++ implicit_deps ++ bkpk_units)
-            in check_packages allPkgDeps prev_dep_pkgs
- where
-
-   classify_import :: (ModuleName -> t -> IO FindResult)
-                      -> [(t, GenLocated l ModuleName)]
-                    -> IfG
-                       [Either
-                          CompileReason (Either (UnitId, ModuleName) (FastString, UnitId))]
-   classify_import find_import imports =
-    liftIO $ traverse (\(mb_pkg, L _ mod) ->
-           let reason = ModuleChanged mod
-           in classify reason <$> find_import mod mb_pkg)
-           imports
-   dflags        = hsc_dflags hsc_env
-   fopts         = initFinderOpts dflags
-   logger        = hsc_logger hsc_env
-   fc            = hsc_FC hsc_env
-   mhome_unit    = hsc_home_unit_maybe hsc_env
-   all_home_units = hsc_all_home_unit_ids hsc_env
-   units         = hsc_units hsc_env
-   prev_dep_mods = map (second gwib_mod) $ Set.toAscList $ dep_direct_mods (mi_deps iface)
-   prev_dep_pkgs = Set.toAscList (Set.union (dep_direct_pkgs (mi_deps iface))
-                                            (dep_plugin_pkgs (mi_deps iface)))
-   bkpk_units    = map ((fsLit "Signature",) . instUnitInstanceOf . moduleUnit) (requirementMerges units (moduleName (mi_module iface)))
-
-   implicit_deps = map (fsLit "Implicit",) (implicitPackageDeps dflags)
-
-   -- GHC.Prim is very special and doesn't appear in ms_textual_imps but
-   -- ghc-prim will appear in the package dependencies still. In order to not confuse
-   -- the recompilation logic we need to not forget we imported GHC.Prim.
-   fake_ghc_prim_import =  case mhome_unit of
-                              Just home_unit
-                                | homeUnitId home_unit == primUnitId
-                                -> Left (primUnitId, mkModuleName "GHC.Prim")
-                              _ -> Right (fsLit "GHC.Prim", primUnitId)
-
-
-   classify _ (Found _ mod)
-    | (toUnitId $ moduleUnit mod) `elem` all_home_units = Right (Left ((toUnitId $ moduleUnit mod), moduleName mod))
-    | otherwise = Right (Right (moduleNameFS (moduleName mod), toUnitId $ moduleUnit mod))
-   classify reason _ = Left (RecompBecause reason)
-
-   check_mods :: [(UnitId, ModuleName)] -> [(UnitId, ModuleName)] -> IO RecompileRequired
-   check_mods [] [] = return UpToDate
-   check_mods [] (old:_) = do
-     -- This case can happen when a module is change from HPT to package import
-     trace_hi_diffs logger $
-      text "module no longer" <+> quotes (ppr old) <+>
-        text "in dependencies"
-
-     return $ needsRecompileBecause $ ModuleRemoved old
-   check_mods (new:news) olds
-    | Just (old, olds') <- uncons olds
-    , new == old = check_mods (dropWhile (== new) news) olds'
-    | otherwise = do
-        trace_hi_diffs logger $
-           text "imported module " <> quotes (ppr new) <>
-           text " not among previous dependencies"
-        return $ needsRecompileBecause $ ModuleAdded new
-
-   check_packages :: [(FastString, UnitId)] -> [UnitId] -> IO RecompileRequired
-   check_packages [] [] = return UpToDate
-   check_packages [] (old:_) = do
-     trace_hi_diffs logger $
-      text "package " <> quotes (ppr old) <>
-        text "no longer in dependencies"
-     return $ needsRecompileBecause $ UnitDepRemoved old
-   check_packages ((new_name, new_unit):news) olds
-    | Just (old, olds') <- uncons olds
-    , new_unit == old = check_packages (dropWhile ((== new_unit) . snd) news) olds'
-    | otherwise = do
-        trace_hi_diffs logger $
-         text "imported package" <+> ftext new_name <+> ppr new_unit <+>
-           text "not among previous dependencies"
-        return $ needsRecompileBecause $ ModulePackageChanged new_name
-
-
-needInterface :: Module -> (ModIface -> IO RecompileRequired)
-             -> IfG RecompileRequired
-needInterface mod continue
-  = do
-      mb_recomp <- tryGetModIface
-        "need version info for"
-        mod
-      case mb_recomp of
-        Nothing -> return $ NeedsRecompile MustCompile
-        Just iface -> liftIO $ continue iface
-
-tryGetModIface :: String -> Module -> IfG (Maybe ModIface)
-tryGetModIface doc_msg mod
-  = do  -- Load the imported interface if possible
-    logger <- getLogger
-    let doc_str = sep [text doc_msg, ppr mod]
-    liftIO $ trace_hi_diffs logger (text "Checking interface for module" <+> ppr mod)
-
-    mb_iface <- loadInterface doc_str mod ImportBySystem
-        -- Load the interface, but don't complain on failure;
-        -- Instead, get an Either back which we can test
-
-    case mb_iface of
-      Failed _ -> do
-        liftIO $ trace_hi_diffs logger (sep [text "Couldn't load interface for module", ppr mod])
-        return Nothing
-                  -- Couldn't find or parse a module mentioned in the
-                  -- old interface file.  Don't complain: it might
-                  -- just be that the current module doesn't need that
-                  -- import and it's been deleted
-      Succeeded iface -> pure $ Just iface
-
--- | Given the usage information extracted from the old
--- M.hi file for the module being compiled, figure out
--- whether M needs to be recompiled.
-checkModUsage :: FinderCache -> Unit -> Usage -> IfG RecompileRequired
-checkModUsage _ _this_pkg UsagePackageModule{
-                                usg_mod = mod,
-                                usg_mod_hash = old_mod_hash } = do
-  logger <- getLogger
-  needInterface mod $ \iface -> do
-    let reason = ModuleChanged (moduleName mod)
-    checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
-        -- We only track the ABI hash of package modules, rather than
-        -- individual entity usages, so if the ABI hash changes we must
-        -- recompile.  This is safe but may entail more recompilation when
-        -- a dependent package has changed.
-
-checkModUsage _ _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do
-  logger <- getLogger
-  needInterface mod $ \iface -> do
-    let reason = ModuleChangedRaw (moduleName mod)
-    checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface))
-checkModUsage _ this_pkg UsageHomeModuleInterface{ usg_mod_name = mod_name, usg_iface_hash = old_mod_hash } = do
-  let mod = mkModule this_pkg mod_name
-  logger <- getLogger
-  needInterface mod $ \iface -> do
-    let reason = ModuleChangedIface mod_name
-    checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash (mi_final_exts iface))
-
-checkModUsage _ this_pkg UsageHomeModule{
-                                usg_mod_name = mod_name,
-                                usg_mod_hash = old_mod_hash,
-                                usg_exports = maybe_old_export_hash,
-                                usg_entities = old_decl_hash }
-  = do
-    let mod = mkModule this_pkg mod_name
-    logger <- getLogger
-    needInterface mod $ \iface -> do
-     let
-         new_mod_hash    = mi_mod_hash (mi_final_exts iface)
-         new_decl_hash   = mi_hash_fn  (mi_final_exts iface)
-         new_export_hash = mi_exp_hash (mi_final_exts iface)
-
-         reason = ModuleChanged (moduleName mod)
-
-     liftIO $ do
-           -- CHECK MODULE
-       recompile <- checkModuleFingerprint logger reason old_mod_hash new_mod_hash
-       if not (recompileRequired recompile)
-         then return UpToDate
-         else checkList
-           [ -- CHECK EXPORT LIST
-             checkMaybeHash logger reason maybe_old_export_hash new_export_hash
-               (text "  Export list changed")
-           , -- CHECK ITEMS ONE BY ONE
-             checkList [ checkEntityUsage logger reason new_decl_hash u
-                       | u <- old_decl_hash]
-           , up_to_date logger (text "  Great!  The bits I use are up to date")
-           ]
-
-checkModUsage fc _this_pkg UsageFile{ usg_file_path = file,
-                                   usg_file_hash = old_hash,
-                                   usg_file_label = mlabel } =
-  liftIO $
-    handleIO handler $ do
-      new_hash <- lookupFileCache fc file
-      if (old_hash /= new_hash)
-         then return recomp
-         else return UpToDate
- where
-   reason = FileChanged file
-   recomp  = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel
-   handler = if debugIsOn
-      then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
-      else \_ -> return recomp -- if we can't find the file, just recompile, don't fail
-
-------------------------
-checkModuleFingerprint
-  :: Logger
-  -> RecompReason
-  -> Fingerprint
-  -> Fingerprint
-  -> IO RecompileRequired
-checkModuleFingerprint logger reason old_mod_hash new_mod_hash
-  | new_mod_hash == old_mod_hash
-  = up_to_date logger (text "Module fingerprint unchanged")
-
-  | otherwise
-  = out_of_date_hash logger reason (text "  Module fingerprint has changed")
-                     old_mod_hash new_mod_hash
-
-checkIfaceFingerprint
-  :: Logger
-  -> RecompReason
-  -> Fingerprint
-  -> Fingerprint
-  -> IO RecompileRequired
-checkIfaceFingerprint logger reason old_mod_hash new_mod_hash
-  | new_mod_hash == old_mod_hash
-  = up_to_date logger (text "Iface fingerprint unchanged")
-
-  | otherwise
-  = out_of_date_hash logger reason (text "  Iface fingerprint has changed")
-                     old_mod_hash new_mod_hash
-
-------------------------
-checkMaybeHash
-  :: Logger
-  -> RecompReason
-  -> Maybe Fingerprint
-  -> Fingerprint
-  -> SDoc
-  -> IO RecompileRequired
-checkMaybeHash logger reason maybe_old_hash new_hash doc
-  | Just hash <- maybe_old_hash, hash /= new_hash
-  = out_of_date_hash logger reason doc hash new_hash
-  | otherwise
-  = return UpToDate
-
-------------------------
-checkEntityUsage :: Logger
-                 -> RecompReason
-                 -> (OccName -> Maybe (OccName, Fingerprint))
-                 -> (OccName, Fingerprint)
-                 -> IO RecompileRequired
-checkEntityUsage logger reason new_hash (name,old_hash) = do
-  case new_hash name of
-    -- We used it before, but it ain't there now
-    Nothing       -> out_of_date logger reason (sep [text "No longer exported:", ppr name])
-    -- It's there, but is it up to date?
-    Just (_, new_hash)
-      | new_hash == old_hash
-      -> do trace_hi_diffs logger (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))
-            return UpToDate
-      | otherwise
-      -> out_of_date_hash logger reason (text "  Out of date:" <+> ppr name) old_hash new_hash
-
-up_to_date :: Logger -> SDoc -> IO RecompileRequired
-up_to_date logger msg = trace_hi_diffs logger msg >> return UpToDate
-
-out_of_date :: Logger -> RecompReason -> SDoc -> IO RecompileRequired
-out_of_date logger reason msg = trace_hi_diffs logger msg >> return (needsRecompileBecause reason)
-
-out_of_date_hash :: Logger -> RecompReason -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired
-out_of_date_hash logger reason msg old_hash new_hash
-  = out_of_date logger reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])
-
--- ---------------------------------------------------------------------------
--- Compute fingerprints for the interface
-
-{-
-Note [Fingerprinting IfaceDecls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The general idea here is that we first examine the 'IfaceDecl's and determine
-the recursive groups of them. We then walk these groups in dependency order,
-serializing each contained 'IfaceDecl' to a "Binary" buffer which we then
-hash using MD5 to produce a fingerprint for the group.
-
-However, the serialization that we use is a bit funny: we override the @putName@
-operation with our own which serializes the hash of a 'Name' instead of the
-'Name' itself. This ensures that the fingerprint of a decl changes if anything
-in its transitive closure changes. This trick is why we must be careful about
-traversing in dependency order: we need to ensure that we have hashes for
-everything referenced by the decl which we are fingerprinting.
-
-Moreover, we need to be careful to distinguish between serialization of binding
-Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls
-field of a IfaceClsInst): only in the non-binding case should we include the
-fingerprint; in the binding case we shouldn't since it is merely the name of the
-thing that we are currently fingerprinting.
-
-
-Note [Fingerprinting recursive groups]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The fingerprinting of a single recursive group is a rather subtle affair, as
-seen in #18733.
-
-How not to fingerprint
-----------------------
-
-Prior to fixing #18733 we used the following (flawed) scheme to fingerprint a
-group in hash environment `hash_env0`:
-
- 1. extend hash_env0, giving each declaration in the group the fingerprint 0
- 2. use this environment to hash the declarations' ABIs, resulting in
-    group_fingerprint
- 3. produce the final hash environment by extending hash_env0, mapping each
-    declaration of the group to group_fingerprint
-
-However, this is wrong. Consider, for instance, a program like:
-
-    data A = ARecu B | ABase String deriving (Show)
-    data B = BRecu A | BBase Int deriving (Show)
-
-    info :: B
-    info = BBase 1
-
-A consequence of (3) is that A and B will have the same fingerprint. This means
-that if the user changes `info` to:
-
-    info :: A
-    info = ABase "hello"
-
-The program's ABI fingerprint will not change despite `info`'s type, and
-therefore ABI, being clearly different.
-
-However, the incorrectness doesn't end there: (1) means that all recursive
-occurrences of names within the group will be given the same fingerprint. This
-means that the group's fingerprint won't change if we change an occurrence of A
-to B.
-
-Surprisingly, this bug (#18733) lurked for many years before being uncovered.
-
-How we now fingerprint
-----------------------
-
-As seen above, the fingerprinting function must ensure that a groups
-fingerprint captures the structure of within-group occurrences. The scheme that
-we use is:
-
- 0. To ensure determinism, sort the declarations into a stable order by
-    declaration name
-
- 1. Extend hash_env0, giving each declaration in the group a sequential
-    fingerprint (e.g. 0, 1, 2, ...).
-
- 2. Use this environment to hash the declarations' ABIs, resulting in
-    group_fingerprint.
-
-    Since we included the sequence number in step (1) programs identical up to
-    transposition of recursive occurrences are distinguishable, avoiding the
-    second issue mentioned above.
-
- 3. Produce the final environment by extending hash_env, mapping each
-    declaration of the group to the hash of (group_fingerprint, i), where
-    i is the position of the declaration in the stable ordering.
-
-    Including i in the hash ensures that the first issue noted above is
-    avoided.
-
--}
-
--- | Add fingerprints for top-level declarations to a 'ModIface'.
---
--- See Note [Fingerprinting IfaceDecls]
-addFingerprints
-        :: HscEnv
-        -> PartialModIface
-        -> IO ModIface
-addFingerprints hsc_env iface0
- = do
-   eps <- hscEPS hsc_env
-   let
-       decls = mi_decls iface0
-       warn_fn = mkIfaceWarnCache (mi_warns iface0)
-       fix_fn = mkIfaceFixCache (mi_fixities iface0)
-
-        -- The ABI of a declaration represents everything that is made
-        -- visible about the declaration that a client can depend on.
-        -- see IfaceDeclABI below.
-       declABI :: IfaceDecl -> IfaceDeclABI
-       -- TODO: I'm not sure if this should be semantic_mod or this_mod.
-       -- See also Note [Identity versus semantic module]
-       declABI decl = (this_mod, decl, extras)
-        where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts
-                                  non_orph_fis top_lvl_name_env decl
-
-       -- This is used for looking up the Name of a default method
-       -- from its OccName. See Note [default method Name]
-       top_lvl_name_env =
-         mkOccEnv [ (nameOccName nm, nm)
-                  | IfaceId { ifName = nm } <- decls ]
-
-       -- Dependency edges between declarations in the current module.
-       -- This is computed by finding the free external names of each
-       -- declaration, including IfaceDeclExtras (things that a
-       -- declaration implicitly depends on).
-       edges :: [ Node Unique IfaceDeclABI ]
-       edges = [ DigraphNode abi (getUnique (getOccName decl)) out
-               | decl <- decls
-               , let abi = declABI decl
-               , let out = localOccs $ freeNamesDeclABI abi
-               ]
-
-       name_module n = assertPpr (isExternalName n) (ppr n) (nameModule n)
-       localOccs =
-         map (getUnique . getParent . getOccName)
-                        -- NB: names always use semantic module, so
-                        -- filtering must be on the semantic module!
-                        -- See Note [Identity versus semantic module]
-                        . filter ((== semantic_mod) . name_module)
-                        . nonDetEltsUniqSet
-                   -- It's OK to use nonDetEltsUFM as localOccs is only
-                   -- used to construct the edges and
-                   -- stronglyConnCompFromEdgedVertices is deterministic
-                   -- even with non-deterministic order of edges as
-                   -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.
-          where getParent :: OccName -> OccName
-                getParent occ = lookupOccEnv parent_map occ `orElse` occ
-
-        -- maps OccNames to their parents in the current module.
-        -- e.g. a reference to a constructor must be turned into a reference
-        -- to the TyCon for the purposes of calculating dependencies.
-       parent_map :: OccEnv OccName
-       parent_map = foldl' extend emptyOccEnv decls
-          where extend env d =
-                  extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]
-                  where n = getOccName d
-
-        -- Strongly-connected groups of declarations, in dependency order
-       groups :: [SCC IfaceDeclABI]
-       groups = stronglyConnCompFromEdgedVerticesUniq edges
-
-       global_hash_fn = mkHashFun hsc_env eps
-
-        -- How to output Names when generating the data to fingerprint.
-        -- Here we want to output the fingerprint for each top-level
-        -- Name, whether it comes from the current module or another
-        -- module.  In this way, the fingerprint for a declaration will
-        -- change if the fingerprint for anything it refers to (transitively)
-        -- changes.
-       mk_put_name :: OccEnv (OccName,Fingerprint)
-                   -> BinHandle -> Name -> IO  ()
-       mk_put_name local_env bh name
-          | isWiredInName name  =  putNameLiterally bh name
-           -- wired-in names don't have fingerprints
-          | otherwise
-          = assertPpr (isExternalName name) (ppr name) $
-            let hash | nameModule name /= semantic_mod =  global_hash_fn name
-                     -- Get it from the REAL interface!!
-                     -- This will trigger when we compile an hsig file
-                     -- and we know a backing impl for it.
-                     -- See Note [Identity versus semantic module]
-                     | semantic_mod /= this_mod
-                     , not (isHoleModule semantic_mod) = global_hash_fn name
-                     | otherwise = return (snd (lookupOccEnv local_env (getOccName name)
-                           `orElse` pprPanic "urk! lookup local fingerprint"
-                                       (ppr name $$ ppr local_env)))
-                -- This panic indicates that we got the dependency
-                -- analysis wrong, because we needed a fingerprint for
-                -- an entity that wasn't in the environment.  To debug
-                -- it, turn the panic into a trace, uncomment the
-                -- pprTraces below, run the compile again, and inspect
-                -- the output and the generated .hi file with
-                -- --show-iface.
-            in hash >>= put_ bh
-
-        -- take a strongly-connected group of declarations and compute
-        -- its fingerprint.
-
-       fingerprint_group :: (OccEnv (OccName,Fingerprint),
-                             [(Fingerprint,IfaceDecl)])
-                         -> SCC IfaceDeclABI
-                         -> IO (OccEnv (OccName,Fingerprint),
-                                [(Fingerprint,IfaceDecl)])
-
-       fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
-          = do let hash_fn = mk_put_name local_env
-                   decl = abiDecl abi
-               --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
-               hash <- computeFingerprint hash_fn abi
-               env' <- extend_hash_env local_env (hash,decl)
-               return (env', (hash,decl) : decls_w_hashes)
-
-       fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
-          = do let stable_abis = sortBy cmp_abiNames abis
-                   stable_decls = map abiDecl stable_abis
-               local_env1 <- foldM extend_hash_env local_env
-                                   (zip (map mkRecFingerprint [0..]) stable_decls)
-                -- See Note [Fingerprinting recursive groups]
-               let hash_fn = mk_put_name local_env1
-               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
-                -- put the cycle in a canonical order
-               hash <- computeFingerprint hash_fn stable_abis
-               let pairs = zip (map (bumpFingerprint hash) [0..]) stable_decls
-                -- See Note [Fingerprinting recursive groups]
-               local_env2 <- foldM extend_hash_env local_env pairs
-               return (local_env2, pairs ++ decls_w_hashes)
-
-       -- Make a fingerprint from the ordinal position of a binding in its group.
-       mkRecFingerprint :: Word64 -> Fingerprint
-       mkRecFingerprint i = Fingerprint 0 i
-
-       bumpFingerprint :: Fingerprint -> Word64 -> Fingerprint
-       bumpFingerprint fp n = fingerprintFingerprints [ fp, mkRecFingerprint n ]
-
-       -- we have fingerprinted the whole declaration, but we now need
-       -- to assign fingerprints to all the OccNames that it binds, to
-       -- use when referencing those OccNames in later declarations.
-       --
-       extend_hash_env :: OccEnv (OccName,Fingerprint)
-                       -> (Fingerprint,IfaceDecl)
-                       -> IO (OccEnv (OccName,Fingerprint))
-       extend_hash_env env0 (hash,d) =
-          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0
-                 (ifaceDeclFingerprints hash d))
-
-   --
-   (local_env, decls_w_hashes) <-
-       foldM fingerprint_group (emptyOccEnv, []) groups
-
-   -- when calculating fingerprints, we always need to use canonical ordering
-   -- for lists of things. The mi_deps has various lists of modules and
-   -- suchlike, which are stored in canonical order:
-   let sorted_deps :: Dependencies
-       sorted_deps = mi_deps iface0
-
-   -- The export hash of a module depends on the orphan hashes of the
-   -- orphan modules below us in the dependency tree.  This is the way
-   -- that changes in orphans get propagated all the way up the
-   -- dependency tree.
-   --
-   -- Note [A bad dep_orphs optimization]
-   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-   -- In a previous version of this code, we filtered out orphan modules which
-   -- were not from the home package, justifying it by saying that "we'd
-   -- pick up the ABI hashes of the external module instead".  This is wrong.
-   -- Suppose that we have:
-   --
-   --       module External where
-   --           instance Show (a -> b)
-   --
-   --       module Home1 where
-   --           import External
-   --
-   --       module Home2 where
-   --           import Home1
-   --
-   -- The export hash of Home1 needs to reflect the orphan instances of
-   -- External. It's true that Home1 will get rebuilt if the orphans
-   -- of External, but we also need to make sure Home2 gets rebuilt
-   -- as well.  See #12733 for more details.
-   let orph_mods
-        = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]
-        $ dep_orphs sorted_deps
-   dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
-
-   -- Note [Do not update EPS with your own hi-boot]
-   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-   -- (See also #10182).  When your hs-boot file includes an orphan
-   -- instance declaration, you may find that the dep_orphs of a module you
-   -- import contains reference to yourself.  DO NOT actually load this module
-   -- or add it to the orphan hashes: you're going to provide the orphan
-   -- instances yourself, no need to consult hs-boot; if you do load the
-   -- interface into EPS, you will see a duplicate orphan instance.
-
-   orphan_hash <- computeFingerprint (mk_put_name local_env)
-                                     (map ifDFun orph_insts, orph_rules, orph_fis)
-
-   -- Hash of the transitive things in dependencies
-   dep_hash <- computeFingerprint putNameLiterally
-                       (dep_sig_mods (mi_deps iface0),
-                        dep_boot_mods (mi_deps iface0),
-                        -- Trusted packages are like orphans
-                        dep_trusted_pkgs (mi_deps iface0),
-                       -- See Note [Export hash depends on non-orphan family instances]
-                        dep_finsts (mi_deps iface0) )
-
-   -- the export list hash doesn't depend on the fingerprints of
-   -- the Names it mentions, only the Names themselves, hence putNameLiterally.
-   export_hash <- computeFingerprint putNameLiterally
-                      (mi_exports iface0,
-                       orphan_hash,
-                       dep_hash,
-                       dep_orphan_hashes,
-                       mi_trust iface0)
-                        -- Make sure change of Safe Haskell mode causes recomp.
-
-   -- Note [Export hash depends on non-orphan family instances]
-   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-   --
-   -- Suppose we have:
-   --
-   --   module A where
-   --       type instance F Int = Bool
-   --
-   --   module B where
-   --       import A
-   --
-   --   module C where
-   --       import B
-   --
-   -- The family instance consistency check for C depends on the dep_finsts of
-   -- B.  If we rename module A to A2, when the dep_finsts of B changes, we need
-   -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of
-   -- the exports of B, because C always considers them when checking
-   -- consistency.
-   --
-   -- A full discussion is in #12723.
-   --
-   -- We do NOT need to hash dep_orphs, because this is implied by
-   -- dep_orphan_hashes, and we do not need to hash ordinary class instances,
-   -- because there is no eager consistency check as there is with type families
-   -- (also we didn't store it anywhere!)
-   --
-
-   -- put the declarations in a canonical order, sorted by OccName
-   let sorted_decls :: [(Fingerprint, IfaceDecl)]
-       sorted_decls = Map.elems $ Map.fromList $
-                          [(getOccName d, e) | e@(_, d) <- decls_w_hashes]
-
-       -- This key is safe because mi_extra_decls contains tidied things.
-       getOcc (IfGblTopBndr b) = getOccName b
-       getOcc (IfLclTopBndr fs _ _ _) = mkVarOccFS fs
-
-       binding_key (IfaceNonRec b _) = IfaceNonRec (getOcc b) ()
-       binding_key (IfaceRec bs) = IfaceRec (map (\(b, _) -> (getOcc b, ())) bs)
-
-       sorted_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-       sorted_extra_decls = sortOn binding_key <$> mi_extra_decls iface0
-
-   -- the flag hash depends on:
-   --   - (some of) dflags
-   -- it returns two hashes, one that shouldn't change
-   -- the abi hash and one that should
-   flag_hash <- fingerprintDynFlags hsc_env this_mod putNameLiterally
-
-   opt_hash <- fingerprintOptFlags dflags putNameLiterally
-
-   hpc_hash <- fingerprintHpcFlags dflags putNameLiterally
-
-   plugin_hash <- fingerprintPlugins (hsc_plugins hsc_env)
-
-   -- the ABI hash depends on:
-   --   - decls
-   --   - export list
-   --   - orphans
-   --   - deprecations
-   --   - flag abi hash
-   mod_hash <- computeFingerprint putNameLiterally
-                      (map fst sorted_decls,
-                       export_hash,  -- includes orphan_hash
-                       mi_warns iface0)
-
-   -- The interface hash depends on:
-   --   - the ABI hash, plus
-   --   - the source file hash,
-   --   - the module level annotations,
-   --   - usages
-   --   - deps (home and external packages, dependent files)
-   --   - hpc
-   iface_hash <- computeFingerprint putNameLiterally
-                      (mod_hash,
-                       mi_src_hash iface0,
-                       ann_fn (mkVarOccFS (fsLit "module")),  -- See mkIfaceAnnCache
-                       mi_usages iface0,
-                       sorted_deps,
-                       mi_hpc iface0)
-
-   let
-    final_iface_exts = ModIfaceBackend
-      { mi_iface_hash  = iface_hash
-      , mi_mod_hash    = mod_hash
-      , mi_flag_hash   = flag_hash
-      , mi_opt_hash    = opt_hash
-      , mi_hpc_hash    = hpc_hash
-      , mi_plugin_hash = plugin_hash
-      , mi_orphan      = not (   all ifRuleAuto orph_rules
-                                   -- See Note [Orphans and auto-generated rules]
-                              && null orph_insts
-                              && null orph_fis)
-      , mi_finsts      = not (null (mi_fam_insts iface0))
-      , mi_exp_hash    = export_hash
-      , mi_orphan_hash = orphan_hash
-      , mi_warn_fn     = warn_fn
-      , mi_fix_fn      = fix_fn
-      , mi_hash_fn     = lookupOccEnv local_env
-      }
-    final_iface = iface0 { mi_decls = sorted_decls, mi_extra_decls = sorted_extra_decls, mi_final_exts = final_iface_exts }
-   --
-   return final_iface
-
-  where
-    this_mod = mi_module iface0
-    semantic_mod = mi_semantic_module iface0
-    dflags = hsc_dflags hsc_env
-    (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    (mi_insts iface0)
-    (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    (mi_rules iface0)
-    (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)
-    ann_fn = mkIfaceAnnCache (mi_anns iface0)
-
--- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules
--- (in particular, the orphan modules which are transitively imported by the
--- current module).
---
--- Q: Why do we need the hash at all, doesn't the list of transitively
--- imported orphan modules suffice?
---
--- A: If one of our transitive imports adds a new orphan instance, our
--- export hash must change so that modules which import us rebuild.  If we just
--- hashed the [Module], the hash would not change even when a new instance was
--- added to a module that already had an orphan instance.
---
--- Q: Why don't we just hash the orphan hashes of our direct dependencies?
--- Why the full transitive closure?
---
--- A: Suppose we have these modules:
---
---      module A where
---          instance Show (a -> b) where
---      module B where
---          import A -- **
---      module C where
---          import A
---          import B
---
--- Whether or not we add or remove the import to A in B affects the
--- orphan hash of B.  But it shouldn't really affect the orphan hash
--- of C.  If we hashed only direct dependencies, there would be no
--- way to tell that the net effect was a wash, and we'd be forced
--- to recompile C and everything else.
-getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
-getOrphanHashes hsc_env mods = do
-  let
-    dflags     = hsc_dflags hsc_env
-    ctx        = initSDocContext dflags defaultUserStyle
-    get_orph_hash mod = do
-          iface <- initIfaceLoad hsc_env . withException ctx
-                            $ loadInterface (text "getOrphanHashes") mod ImportBySystem
-          return (mi_orphan_hash (mi_final_exts iface))
-
-  mapM get_orph_hash mods
-
-
-{-
-************************************************************************
-*                                                                      *
-          The ABI of an IfaceDecl
-*                                                                      *
-************************************************************************
-
-Note [The ABI of an IfaceDecl]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The ABI of a declaration consists of:
-
-   (a) the full name of the identifier (inc. module and package,
-       because these are used to construct the symbol name by which
-       the identifier is known externally).
-
-   (b) the declaration itself, as exposed to clients.  That is, the
-       definition of an Id is included in the fingerprint only if
-       it is made available as an unfolding in the interface.
-
-   (c) the fixity of the identifier (if it exists)
-   (d) for Ids: rules
-   (e) for classes: instances, fixity & rules for methods
-   (f) for datatypes: instances, fixity & rules for constrs
-
-Items (c)-(f) are not stored in the IfaceDecl, but instead appear
-elsewhere in the interface file.  But they are *fingerprinted* with
-the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
-and fingerprinting that as part of the declaration.
--}
-
-type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
-
-data IfaceDeclExtras
-  = IfaceIdExtras IfaceIdExtras
-
-  | IfaceDataExtras
-       (Maybe Fixity)           -- Fixity of the tycon itself (if it exists)
-       [IfaceInstABI]           -- Local class and family instances of this tycon
-                                -- See Note [Orphans] in GHC.Core.InstEnv
-       [AnnPayload]             -- Annotations of the type itself
-       [IfaceIdExtras]          -- For each constructor: fixity, RULES and annotations
-
-  | IfaceClassExtras
-       (Maybe Fixity)           -- Fixity of the class itself (if it exists)
-       [IfaceInstABI]           -- Local instances of this class *or*
-                                --   of its associated data types
-                                -- See Note [Orphans] in GHC.Core.InstEnv
-       [AnnPayload]             -- Annotations of the type itself
-       [IfaceIdExtras]          -- For each class method: fixity, RULES and annotations
-       [IfExtName]              -- Default methods. If a module
-                                -- mentions a class, then it can
-                                -- instantiate the class and thereby
-                                -- use the default methods, so we must
-                                -- include these in the fingerprint of
-                                -- a class.
-
-  | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]
-
-  | IfaceFamilyExtras   (Maybe Fixity) [IfaceInstABI] [AnnPayload]
-
-  | IfaceOtherDeclExtras
-
-data IfaceIdExtras
-  = IdExtras
-       (Maybe Fixity)           -- Fixity of the Id (if it exists)
-       [IfaceRule]              -- Rules for the Id
-       [AnnPayload]             -- Annotations for the Id
-
--- When hashing a class or family instance, we hash only the
--- DFunId or CoAxiom, because that depends on all the
--- information about the instance.
---
-type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance
-
-abiDecl :: IfaceDeclABI -> IfaceDecl
-abiDecl (_, decl, _) = decl
-
-cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
-cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare`
-                         getOccName (abiDecl abi2)
-
-freeNamesDeclABI :: IfaceDeclABI -> NameSet
-freeNamesDeclABI (_mod, decl, extras) =
-  freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras
-
-freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
-freeNamesDeclExtras (IfaceIdExtras id_extras)
-  = freeNamesIdExtras id_extras
-freeNamesDeclExtras (IfaceDataExtras  _ insts _ subs)
-  = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)
-freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms)
-  = unionNameSets $
-      mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs
-freeNamesDeclExtras (IfaceSynonymExtras _ _)
-  = emptyNameSet
-freeNamesDeclExtras (IfaceFamilyExtras _ insts _)
-  = mkNameSet insts
-freeNamesDeclExtras IfaceOtherDeclExtras
-  = emptyNameSet
-
-freeNamesIdExtras :: IfaceIdExtras -> NameSet
-freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules)
-
-instance Outputable IfaceDeclExtras where
-  ppr IfaceOtherDeclExtras       = Outputable.empty
-  ppr (IfaceIdExtras  extras)    = ppr_id_extras extras
-  ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]
-  ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]
-  ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
-                                                ppr_id_extras_s stuff]
-  ppr (IfaceClassExtras fix insts anns stuff defms) =
-    vcat [ppr fix, ppr_insts insts, ppr anns,
-          ppr_id_extras_s stuff, ppr defms]
-
-ppr_insts :: [IfaceInstABI] -> SDoc
-ppr_insts _ = text "<insts>"
-
-ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
-ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)
-
-ppr_id_extras :: IfaceIdExtras -> SDoc
-ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)
-
--- This instance is used only to compute fingerprints
-instance Binary IfaceDeclExtras where
-  get _bh = panic "no get for IfaceDeclExtras"
-  put_ bh (IfaceIdExtras extras) = do
-   putByte bh 1; put_ bh extras
-  put_ bh (IfaceDataExtras fix insts anns cons) = do
-   putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons
-  put_ bh (IfaceClassExtras fix insts anns methods defms) = do
-   putByte bh 3
-   put_ bh fix
-   put_ bh insts
-   put_ bh anns
-   put_ bh methods
-   put_ bh defms
-  put_ bh (IfaceSynonymExtras fix anns) = do
-   putByte bh 4; put_ bh fix; put_ bh anns
-  put_ bh (IfaceFamilyExtras fix finsts anns) = do
-   putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns
-  put_ bh IfaceOtherDeclExtras = putByte bh 6
-
-instance Binary IfaceIdExtras where
-  get _bh = panic "no get for IfaceIdExtras"
-  put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }
-
-declExtras :: (OccName -> Maybe Fixity)
-           -> (OccName -> [AnnPayload])
-           -> OccEnv [IfaceRule]
-           -> OccEnv [IfaceClsInst]
-           -> OccEnv [IfaceFamInst]
-           -> OccEnv IfExtName          -- lookup default method names
-           -> IfaceDecl
-           -> IfaceDeclExtras
-
-declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env decl
-  = case decl of
-      IfaceId{} -> IfaceIdExtras (id_extras n)
-      IfaceData{ifCons=cons} ->
-                     IfaceDataExtras (fix_fn n)
-                        (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++
-                         map ifDFun         (lookupOccEnvL inst_env n))
-                        (ann_fn n)
-                        (map (id_extras . occName . ifConName) (visibleIfConDecls cons))
-      IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->
-                     IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms
-          where
-            insts = (map ifDFun $ (concatMap at_extras ats)
-                                    ++ lookupOccEnvL inst_env n)
-                           -- Include instances of the associated types
-                           -- as well as instances of the class (#5147)
-            meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]
-            -- Names of all the default methods (see Note [default method Name])
-            defms = [ dmName
-                    | IfaceClassOp bndr _ (Just _) <- sigs
-                    , let dmOcc = mkDefaultMethodOcc (nameOccName bndr)
-                    , Just dmName <- [lookupOccEnv dm_env dmOcc] ]
-      IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)
-                                           (ann_fn n)
-      IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)
-                        (map ifFamInstAxiom (lookupOccEnvL fi_env n))
-                        (ann_fn n)
-      _other -> IfaceOtherDeclExtras
-  where
-        n = getOccName decl
-        id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)
-        at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl)
-
-
-{- Note [default method Name] (see also #15970)
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The Names for the default methods aren't available in Iface syntax.
-
-* We originally start with a DefMethInfo from the class, contain a
-  Name for the default method
-
-* We turn that into Iface syntax as a DefMethSpec which lacks a Name
-  entirely. Why? Because the Name can be derived from the method name
-  (in GHC.IfaceToCore), so doesn't need to be serialised into the interface
-  file.
-
-But now we have to get the Name back, because the class declaration's
-fingerprint needs to depend on it (this was the bug in #15970).  This
-is done in a slightly convoluted way:
-
-* Then, in addFingerprints we build a map that maps OccNames to Names
-
-* We pass that map to declExtras which laboriously looks up in the map
-  (using the derived occurrence name) to recover the Name we have just
-  thrown away.
--}
-
-lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
-lookupOccEnvL env k = lookupOccEnv env k `orElse` []
-
-{-
--- for testing: use the md5sum command to generate fingerprints and
--- compare the results against our built-in version.
-  fp' <- oldMD5 dflags bh
-  if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
-               else return fp
-
-oldMD5 dflags bh = do
-  tmp <- newTempName dflags CurrentModule "bin"
-  writeBinMem bh tmp
-  tmp2 <- newTempName dflags CurrentModule "md5"
-  let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
-  r <- system cmd
-  case r of
-    ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)
-    ExitSuccess -> do
-        hash_str <- readFile tmp2
-        return $! readHexFingerprint hash_str
--}
-
-----------------------
--- mkOrphMap partitions instance decls or rules into
---      (a) an OccEnv for ones that are not orphans,
---          mapping the local OccName to a list of its decls
---      (b) a list of orphan decls
-mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl
-          -> [decl]             -- Sorted into canonical order
-          -> (OccEnv [decl],    -- Non-orphan decls associated with their key;
-                                --      each sublist in canonical order
-              [decl])           -- Orphan decls; in canonical order
-mkOrphMap get_key decls
-  = foldl' go (emptyOccEnv, []) decls
-  where
-    go (non_orphs, orphs) d
-        | NotOrphan occ <- get_key d
-        = (extendOccEnv_Acc (:) Utils.singleton non_orphs occ d, orphs)
-        | otherwise = (non_orphs, d:orphs)
-
--- -----------------------------------------------------------------------------
--- Look up parents and versions of Names
-
--- This is like a global version of the mi_hash_fn field in each ModIface.
--- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
--- the parent and version info.
-
-mkHashFun
-        :: HscEnv                       -- needed to look up versions
-        -> ExternalPackageState         -- ditto
-        -> (Name -> IO Fingerprint)
-mkHashFun hsc_env eps name
-  | isHoleModule orig_mod
-  = lookup (mkHomeModule home_unit (moduleName orig_mod))
-  | otherwise
-  = lookup orig_mod
-  where
-      home_unit = hsc_home_unit hsc_env
-      dflags = hsc_dflags hsc_env
-      hpt = hsc_HUG hsc_env
-      pit = eps_PIT eps
-      ctx = initSDocContext dflags defaultUserStyle
-      occ = nameOccName name
-      orig_mod = nameModule name
-      lookup mod = do
-        massertPpr (isExternalName name) (ppr name)
-        iface <- case lookupIfaceByModule hpt pit mod of
-                  Just iface -> return iface
-                  Nothing ->
-                      -- This can occur when we're writing out ifaces for
-                      -- requirements; we didn't do any /real/ typechecking
-                      -- so there's no guarantee everything is loaded.
-                      -- Kind of a heinous hack.
-                      initIfaceLoad hsc_env . withException ctx
-                          $ withoutDynamicNow
-                            -- If you try and load interfaces when dynamic-too
-                            -- enabled then it attempts to load the dyn_hi and hi
-                            -- interface files. Backpack doesn't really care about
-                            -- dynamic object files as it isn't doing any code
-                            -- generation so -dynamic-too is turned off.
-                            -- Some tests fail without doing this (such as T16219),
-                            -- but they fail because dyn_hi files are not found for
-                            -- one of the dependencies (because they are deliberately turned off)
-                            -- Why is this check turned off here? That is unclear but
-                            -- just one of the many horrible hacks in the backpack
-                            -- implementation.
-                          $ loadInterface (text "lookupVers2") mod ImportBySystem
-        return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`
-                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))
-
-
--- | Creates cached lookup for the 'mi_anns' field of ModIface
--- Hackily, we use "module" as the OccName for any module-level annotations
-mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
-mkIfaceAnnCache anns
-  = \n -> lookupOccEnv env n `orElse` []
-  where
-    pair (IfaceAnnotation target value) =
-      (case target of
-          NamedTarget occn -> occn
-          ModuleTarget _   -> mkVarOccFS (fsLit "module")
-      , [value])
-    -- flipping (++), so the first argument is always short
-    env = mkOccEnv_C (flip (++)) (map pair anns)
diff --git a/compiler/GHC/Iface/Recomp/Flags.hs b/compiler/GHC/Iface/Recomp/Flags.hs
deleted file mode 100644
--- a/compiler/GHC/Iface/Recomp/Flags.hs
+++ /dev/null
@@ -1,188 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-
--- | This module manages storing the various GHC option flags in a modules
--- interface file as part of the recompilation checking infrastructure.
-module GHC.Iface.Recomp.Flags (
-        fingerprintDynFlags
-      , fingerprintOptFlags
-      , fingerprintHpcFlags
-    ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-import GHC.Driver.Env
-
-import GHC.Utils.Binary
-import GHC.Unit.Module
-import GHC.Types.Name
-import GHC.Types.SafeHaskell
-import GHC.Utils.Fingerprint
-import GHC.Iface.Recomp.Binary
-import GHC.Core.Opt.CallerCC () -- for Binary instances
-
-import GHC.Data.EnumSet as EnumSet
-import System.FilePath (normalise)
-
--- | Produce a fingerprint of a @DynFlags@ value. We only base
--- the finger print on important fields in @DynFlags@ so that
--- the recompilation checker can use this fingerprint.
---
--- NB: The 'Module' parameter is the 'Module' recorded by the *interface*
--- file, not the actual 'Module' according to our 'DynFlags'.
-fingerprintDynFlags :: HscEnv -> Module
-                    -> (BinHandle -> Name -> IO ())
-                    -> IO Fingerprint
-
-fingerprintDynFlags hsc_env this_mod nameio =
-    let dflags@DynFlags{..} = hsc_dflags hsc_env
-        mainis   = if mainModIs (hsc_HUE hsc_env) == this_mod then Just mainFunIs else Nothing
-                      -- see #5878
-        -- pkgopts  = (homeUnit home_unit, sort $ packageFlags dflags)
-        safeHs   = setSafeMode safeHaskell
-        -- oflags   = sort $ filter filterOFlags $ flags dflags
-
-        -- all the extension flags and the language
-        lang = (fmap fromEnum language,
-                map fromEnum $ EnumSet.toList extensionFlags)
-
-        -- avoid fingerprinting the absolute path to the directory of the source file
-        -- see Note [Implicit include paths]
-        includePathsMinusImplicit = includePaths { includePathsQuoteImplicit = [] }
-
-        -- -I, -D and -U flags affect CPP
-        cpp = ( map normalise $ flattenIncludes includePathsMinusImplicit
-            -- normalise: eliminate spurious differences due to "./foo" vs "foo"
-              , picPOpts dflags
-              , opt_P_signature dflags)
-            -- See Note [Repeated -optP hashing]
-
-        -- Note [path flags and recompilation]
-        paths = [ hcSuf ]
-
-        -- -fprof-auto etc.
-        prof = if sccProfilingEnabled dflags then fromEnum profAuto else 0
-
-        -- Ticky
-        ticky =
-          map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk, Opt_Ticky_Tag]
-
-        flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel, callerCcFilters))
-
-    in -- pprTrace "flags" (ppr flags) $
-       computeFingerprint nameio flags
-
--- Fingerprint the optimisation info. We keep this separate from the rest of
--- the flags because GHCi users (especially) may wish to ignore changes in
--- optimisation level or optimisation flags so as to use as many pre-existing
--- object files as they can.
--- See Note [Ignoring some flag changes]
-fingerprintOptFlags :: DynFlags
-                      -> (BinHandle -> Name -> IO ())
-                      -> IO Fingerprint
-fingerprintOptFlags DynFlags{..} nameio =
-      let
-        -- See https://gitlab.haskell.org/ghc/ghc/issues/10923
-        -- We used to fingerprint the optimisation level, but as Joachim
-        -- Breitner pointed out in comment 9 on that ticket, it's better
-        -- to ignore that and just look at the individual optimisation flags.
-        opt_flags = map fromEnum $ filter (`EnumSet.member` optimisationFlags)
-                                          (EnumSet.toList generalFlags)
-
-      in computeFingerprint nameio opt_flags
-
--- Fingerprint the HPC info. We keep this separate from the rest of
--- the flags because GHCi users (especially) may wish to use an object
--- file compiled for HPC when not actually using HPC.
--- See Note [Ignoring some flag changes]
-fingerprintHpcFlags :: DynFlags
-                      -> (BinHandle -> Name -> IO ())
-                      -> IO Fingerprint
-fingerprintHpcFlags dflags@DynFlags{..} nameio =
-      let
-        -- -fhpc, see https://gitlab.haskell.org/ghc/ghc/issues/11798
-        -- hpcDir is output-only, so we should recompile if it changes
-        hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing
-
-      in computeFingerprint nameio hpc
-
-
-{- Note [path flags and recompilation]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are several flags that we deliberately omit from the
-recompilation check; here we explain why.
-
--osuf, -odir, -hisuf, -hidir
-  If GHC decides that it does not need to recompile, then
-  it must have found an up-to-date .hi file and .o file.
-  There is no point recording these flags - the user must
-  have passed the correct ones.  Indeed, the user may
-  have compiled the source file in one-shot mode using
-  -o to specify the .o file, and then loaded it in GHCi
-  using -odir.
-
--stubdir
-  We omit this one because it is automatically set by -outputdir, and
-  we don't want changes in -outputdir to automatically trigger
-  recompilation.  This could be wrong, but only in very rare cases.
-
--i (importPaths)
-  For the same reason as -osuf etc. above: if GHC decides not to
-  recompile, then it must have already checked all the .hi files on
-  which the current module depends, so it must have found them
-  successfully.  It is occasionally useful to be able to cd to a
-  different directory and use -i flags to enable GHC to find the .hi
-  files; we don't want this to force recompilation.
-
-The only path-related flag left is -hcsuf.
--}
-
-{- Note [Ignoring some flag changes]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Normally, --make tries to reuse only compilation products that are
-the same as those that would have been produced compiling from
-scratch. Sometimes, however, users would like to be more aggressive
-about recompilation avoidance. This is particularly likely when
-developing using GHCi (see #13604). Currently, we allow users to
-ignore optimisation changes using -fignore-optim-changes, and to
-ignore HPC option changes using -fignore-hpc-changes. If there's a
-demand for it, we could also allow changes to -fprof-auto-* flags
-(although we can't allow -prof flags to differ). The key thing about
-these options is that we can still successfully link a library or
-executable when some of its components differ in these ways.
-
-The way we accomplish this is to leave the optimization and HPC
-options out of the flag hash, hashing them separately.
--}
-
-{- Note [Repeated -optP hashing]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We invoke fingerprintDynFlags for each compiled module to include
-the hash of relevant DynFlags in the resulting interface file.
--optP (preprocessor) flags are part of that hash.
--optP flags can come from multiple places:
-
-  1. -optP flags directly passed on command line.
-  2. -optP flags implied by other flags. Eg. -DPROFILING implied by -prof.
-  3. -optP flags added with {-# OPTIONS -optP-D__F__ #-} in a file.
-
-When compiling many modules at once with many -optP command line arguments
-the work of hashing -optP flags would be repeated. This can get expensive
-and as noted on #14697 it can take 7% of time and 14% of allocations on
-a real codebase.
-
-The obvious solution is to cache the hash of -optP flags per GHC invocation.
-However, one has to be careful there, as the flags that were added in 3. way
-have to be accounted for.
-
-The current strategy is as follows:
-
-  1. Lazily compute the hash of sOpt_p in sOpt_P_fingerprint whenever sOpt_p
-     is modified. This serves dual purpose. It ensures correctness for when
-     we add per file -optP flags and lets us save work for when we don't.
-  2. When computing the fingerprint in fingerprintDynFlags use the cached
-     value *and* fingerprint the additional implied (see 2. above) -optP flags.
-     This is relatively cheap and saves the headache of fingerprinting all
-     the -optP flags and tracking all the places that could invalidate the
-     cache.
--}
diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs
deleted file mode 100644
--- a/compiler/GHC/Iface/Rename.hs
+++ /dev/null
@@ -1,739 +0,0 @@
--- | This module implements interface renaming, which is
--- used to rewrite interface files on the fly when we
--- are doing indefinite typechecking and need instantiations
--- of modules which do not necessarily exist yet.
-
-module GHC.Iface.Rename (
-    rnModIface,
-    rnModExports,
-    tcRnModIface,
-    tcRnModExports,
-    ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Env
-
-import GHC.Tc.Utils.Monad
-
-import GHC.Iface.Syntax
-import GHC.Iface.Env
-import {-# SOURCE #-} GHC.Iface.Load -- a bit vexing
-
-import GHC.Unit
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.Deps
-
-import GHC.Tc.Errors.Types
-import GHC.Types.SrcLoc
-import GHC.Types.Unique.FM
-import GHC.Types.Avail
-import GHC.Types.Error
-import GHC.Types.FieldLabel
-import GHC.Types.Var
-import GHC.Types.Basic
-import GHC.Types.Name
-import GHC.Types.Name.Shape
-
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Error
-import GHC.Utils.Fingerprint
-import GHC.Utils.Panic
-
-import qualified Data.Traversable as T
-
-import Data.IORef
-
-tcRnMsgMaybe :: IO (Either (Messages TcRnMessage) a) -> TcM a
-tcRnMsgMaybe do_this = do
-    r <- liftIO $ do_this
-    case r of
-        Left msgs -> do
-            addMessages msgs
-            failM
-        Right x -> return x
-
-tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface
-tcRnModIface x y z = do
-    hsc_env <- getTopEnv
-    tcRnMsgMaybe $ rnModIface hsc_env x y z
-
-tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo]
-tcRnModExports x y = do
-    hsc_env <- getTopEnv
-    tcRnMsgMaybe $ rnModExports hsc_env x y
-
-failWithRn :: TcRnMessage -> ShIfM a
-failWithRn tcRnMessage = do
-    errs_var <- fmap sh_if_errs getGblEnv
-    errs <- readTcRef errs_var
-    -- TODO: maybe associate this with a source location?
-    let msg = mkPlainErrorMsgEnvelope noSrcSpan tcRnMessage
-    writeTcRef errs_var (msg `addMessage` errs)
-    failM
-
--- | What we have is a generalized ModIface, which corresponds to
--- a module that looks like p[A=\<A>]:B.  We need a *specific* ModIface, e.g.
--- p[A=q():A]:B (or maybe even p[A=\<B>]:B) which we load
--- up (either to merge it, or to just use during typechecking).
---
--- Suppose we have:
---
---  p[A=\<A>]:M  ==>  p[A=q():A]:M
---
--- Substitute all occurrences of \<A> with q():A (renameHoleModule).
--- Then, for any Name of form {A.T}, replace the Name with
--- the Name according to the exports of the implementing module.
--- This works even for p[A=\<B>]:M, since we just read in the
--- exports of B.hi, which is assumed to be ready now.
---
--- This function takes an optional 'NameShape', which can be used
--- to further refine the identities in this interface: suppose
--- we read a declaration for {H.T} but we actually know that this
--- should be Foo.T; then we'll also rename this (this is used
--- when loading an interface to merge it into a requirement.)
-rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape
-           -> ModIface -> IO (Either (Messages TcRnMessage) ModIface)
-rnModIface hsc_env insts nsubst iface =
-    initRnIface hsc_env iface insts nsubst $ do
-        mod <- rnModule (mi_module iface)
-        sig_of <- case mi_sig_of iface of
-                    Nothing -> return Nothing
-                    Just x  -> fmap Just (rnModule x)
-        exports <- mapM rnAvailInfo (mi_exports iface)
-        decls <- mapM rnIfaceDecl' (mi_decls iface)
-        insts <- mapM rnIfaceClsInst (mi_insts iface)
-        fams <- mapM rnIfaceFamInst (mi_fam_insts iface)
-        deps <- rnDependencies (mi_deps iface)
-        -- TODO:
-        -- mi_rules
-        return iface { mi_module = mod
-                     , mi_sig_of = sig_of
-                     , mi_insts = insts
-                     , mi_fam_insts = fams
-                     , mi_exports = exports
-                     , mi_decls = decls
-                     , mi_deps = deps }
-
--- | Rename just the exports of a 'ModIface'.  Useful when we're doing
--- shaping prior to signature merging.
-rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either (Messages TcRnMessage) [AvailInfo])
-rnModExports hsc_env insts iface
-    = initRnIface hsc_env iface insts Nothing
-    $ mapM rnAvailInfo (mi_exports iface)
-
-rnDependencies :: Rename Dependencies
-rnDependencies deps0 = do
-    deps1  <- dep_orphs_update deps0 (rnDepModules dep_orphs)
-    dep_finsts_update deps1 (rnDepModules dep_finsts)
-
-rnDepModules :: (Dependencies -> [Module]) -> [Module] -> ShIfM [Module]
-rnDepModules sel mods = do
-    hsc_env <- getTopEnv
-    hmap <- getHoleSubst
-    -- NB: It's not necessary to test if we're doing signature renaming,
-    -- because ModIface will never contain module reference for itself
-    -- in these dependencies.
-    fmap (nubSort . concat) . T.forM mods $ \mod -> do
-        -- For holes, its necessary to "see through" the instantiation
-        -- of the hole to get accurate family instance dependencies.
-        -- For example, if B imports <A>, and <A> is instantiated with
-        -- F, we must grab and include all of the dep_finsts from
-        -- F to have an accurate transitive dep_finsts list.
-        --
-        -- However, we MUST NOT do this for regular modules.
-        -- First, for efficiency reasons, doing this
-        -- bloats the dep_finsts list, because we *already* had
-        -- those modules in the list (it wasn't a hole module, after
-        -- all). But there's a second, more important correctness
-        -- consideration: we perform module renaming when running
-        -- --abi-hash.  In this case, GHC's contract to the user is that
-        -- it will NOT go and read out interfaces of any dependencies
-        -- (https://github.com/haskell/cabal/issues/3633); the point of
-        -- --abi-hash is just to get a hash of the on-disk interfaces
-        -- for this *specific* package.  If we go off and tug on the
-        -- interface for /everything/ in dep_finsts, we're gonna have a
-        -- bad time.  (It's safe to do this for hole modules, though,
-        -- because the hmap for --abi-hash is always trivial, so the
-        -- interface we request is local.  Though, maybe we ought
-        -- not to do it in this case either...)
-        --
-        -- This mistake was bug #15594.
-        let mod' = renameHoleModule (hsc_units hsc_env) hmap mod
-        if isHoleModule mod
-          then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env
-                                  $ loadSysInterface (text "rnDepModule") mod'
-                  return (mod' : sel (mi_deps iface))
-          else return [mod']
-
-{-
-************************************************************************
-*                                                                      *
-                        ModIface substitution
-*                                                                      *
-************************************************************************
--}
-
--- | Run a computation in the 'ShIfM' monad.
-initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape
-            -> ShIfM a -> IO (Either (Messages TcRnMessage) a)
-initRnIface hsc_env iface insts nsubst do_this = do
-    errs_var <- newIORef emptyMessages
-    let hsubst = listToUFM insts
-        rn_mod = renameHoleModule (hsc_units hsc_env) hsubst
-        env = ShIfEnv {
-            sh_if_module = rn_mod (mi_module iface),
-            sh_if_semantic_module = rn_mod (mi_semantic_module iface),
-            sh_if_hole_subst = listToUFM insts,
-            sh_if_shape = nsubst,
-            sh_if_errs = errs_var
-        }
-    -- Modeled off of 'initTc'
-    res <- initTcRnIf 'c' hsc_env env () $ tryM do_this
-    msgs <- readIORef errs_var
-    case res of
-        Left _                               -> return (Left msgs)
-        Right r | not (isEmptyMessages msgs) -> return (Left msgs)
-                | otherwise                  -> return (Right r)
-
--- | Environment for 'ShIfM' monads.
-data ShIfEnv = ShIfEnv {
-        -- What we are renaming the ModIface to.  It assumed that
-        -- the original mi_module of the ModIface is
-        -- @generalizeModule (mi_module iface)@.
-        sh_if_module :: Module,
-        -- The semantic module that we are renaming to
-        sh_if_semantic_module :: Module,
-        -- Cached hole substitution, e.g.
-        -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnit . sh_if_module@
-        sh_if_hole_subst :: ShHoleSubst,
-        -- An optional name substitution to be applied when renaming
-        -- the names in the interface.  If this is 'Nothing', then
-        -- we just load the target interface and look at the export
-        -- list to determine the renaming.
-        sh_if_shape :: Maybe NameShape,
-        -- Mutable reference to keep track of diagnostics (similar to 'tcl_errs')
-        sh_if_errs :: IORef (Messages TcRnMessage)
-    }
-
-getHoleSubst :: ShIfM ShHoleSubst
-getHoleSubst = fmap sh_if_hole_subst getGblEnv
-
-type ShIfM = TcRnIf ShIfEnv ()
-type Rename a = a -> ShIfM a
-
-
-rnModule :: Rename Module
-rnModule mod = do
-    hmap <- getHoleSubst
-    unit_state <- hsc_units <$> getTopEnv
-    return (renameHoleModule unit_state hmap mod)
-
-rnAvailInfo :: Rename AvailInfo
-rnAvailInfo (Avail c) = Avail <$> rnGreName c
-rnAvailInfo (AvailTC n ns) = do
-    -- Why don't we rnIfaceGlobal the availName itself?  It may not
-    -- actually be exported by the module it putatively is from, in
-    -- which case we won't be able to tell what the name actually
-    -- is.  But for the availNames they MUST be exported, so they
-    -- will rename fine.
-    ns' <- mapM rnGreName ns
-    case ns' of
-        [] -> panic "rnAvailInfoEmpty AvailInfo"
-        (rep:rest) -> assertPpr (all ((== childModule rep) . childModule) rest)
-                                (ppr rep $$ hcat (map ppr rest)) $ do
-                         n' <- setNameModule (Just (childModule rep)) n
-                         return (AvailTC n' ns')
-  where
-    childModule = nameModule . greNameMangledName
-
-rnGreName :: Rename GreName
-rnGreName (NormalGreName n) = NormalGreName <$> rnIfaceGlobal n
-rnGreName (FieldGreName fl) = FieldGreName  <$> rnFieldLabel fl
-
-rnFieldLabel :: Rename FieldLabel
-rnFieldLabel fl = do
-    sel' <- rnIfaceGlobal (flSelector fl)
-    return (fl { flSelector = sel' })
-
-
-
-
--- | The key function.  This gets called on every Name embedded
--- inside a ModIface.  Our job is to take a Name from some
--- generalized unit ID p[A=\<A>, B=\<B>], and change
--- it to the correct name for a (partially) instantiated unit
--- ID, e.g. p[A=q[]:A, B=\<B>].
---
--- There are two important things to do:
---
--- If a hole is substituted with a real module implementation,
--- we need to look at that actual implementation to determine what
--- the true identity of this name should be.  We'll do this by
--- loading that module's interface and looking at the mi_exports.
---
--- However, there is one special exception: when we are loading
--- the interface of a requirement.  In this case, we may not have
--- the "implementing" interface, because we are reading this
--- interface precisely to "merge it in".
---
---     External case:
---         p[A=\<B>]:A (and thisUnitId is something else)
---     We are loading this in order to determine B.hi!  So
---     don't load B.hi to find the exports.
---
---     Local case:
---         p[A=\<A>]:A (and thisUnitId is p[A=\<A>])
---     This should not happen, because the rename is not necessary
---     in this case, but if it does we shouldn't load A.hi!
---
--- Compare me with 'tcIfaceGlobal'!
-
--- In effect, this function needs compute the name substitution on the
--- fly.  What it has is the name that we would like to substitute.
--- If the name is not a hole name {M.x} (e.g. isHoleModule) then
--- no renaming can take place (although the inner hole structure must
--- be updated to account for the hole module renaming.)
-rnIfaceGlobal :: Name -> ShIfM Name
-rnIfaceGlobal n = do
-    hsc_env <- getTopEnv
-    let unit_state = hsc_units hsc_env
-        home_unit  = hsc_home_unit hsc_env
-    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
-    mb_nsubst <- fmap sh_if_shape getGblEnv
-    hmap <- getHoleSubst
-    let m = nameModule n
-        m' = renameHoleModule unit_state hmap m
-    case () of
-       -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so,
-       -- do NOT assume B.hi is available.
-       -- In this case, rename {A.T} to {B.T} but don't look up exports.
-     _ | m' == iface_semantic_mod
-       , isHoleModule m'
-      -- NB: this could be Nothing for computeExports, we have
-      -- nothing to say.
-      -> do n' <- setNameModule (Just m') n
-            case mb_nsubst of
-                Nothing -> return n'
-                Just nsubst ->
-                    case maybeSubstNameShape nsubst n' of
-                        -- TODO: would love to have context
-                        -- TODO: This will give an unpleasant message if n'
-                        -- is a constructor; then we'll suggest adding T
-                        -- but it won't work.
-                        Nothing ->
-                          failWithRn $ TcRnIdNotExportedFromLocalSig n'
-                        Just n'' -> return n''
-       -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the
-       -- export list is irrelevant.
-       | not (isHoleModule m)
-      -> setNameModule (Just m') n
-       -- The substitution was from <A> to p[]:A.
-       -- But this does not mean {A.T} goes to p[]:A.T:
-       -- p[]:A may reexport T from somewhere else.  Do the name
-       -- substitution.  Furthermore, we need
-       -- to make sure we pick the accurate name NOW,
-       -- or we might accidentally reject a merge.
-       | otherwise
-      -> do -- Make sure we look up the local interface if substitution
-            -- went from <A> to <B>.
-            let m'' = if isHoleModule m'
-                        -- Pull out the local guy!!
-                        then mkHomeModule home_unit (moduleName m')
-                        else m'
-            iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env
-                            $ loadSysInterface (text "rnIfaceGlobal") m''
-            let nsubst = mkNameShape (moduleName m) (mi_exports iface)
-            case maybeSubstNameShape nsubst n of
-                -- NB: report m' because it's more user-friendly
-                Nothing -> failWithRn $ TcRnIdNotExportedFromModuleSig n m'
-                Just n' -> return n'
-
--- | Rename an implicit name, e.g., a DFun or coercion axiom.
--- Here is where we ensure that DFuns have the correct module as described in
--- Note [rnIfaceNeverExported].
-rnIfaceNeverExported :: Name -> ShIfM Name
-rnIfaceNeverExported name = do
-    hmap <- getHoleSubst
-    unit_state <- hsc_units <$> getTopEnv
-    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
-    let m = renameHoleModule unit_state hmap $ nameModule name
-    -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.
-    massertPpr (iface_semantic_mod == m) (ppr iface_semantic_mod <+> ppr m)
-    setNameModule (Just m) name
-
--- Note [rnIfaceNeverExported]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- For the high-level overview, see
--- Note [Handling never-exported TyThings under Backpack]
---
--- When we see a reference to an entity that was defined in a signature,
--- 'rnIfaceGlobal' relies on the identifier in question being part of the
--- exports of the implementing 'ModIface', so that we can use the exports to
--- decide how to rename the identifier.  Unfortunately, references to 'DFun's
--- and 'CoAxiom's will run into trouble under this strategy, because they are
--- never exported.
---
--- Let us consider first what should happen in the absence of promotion.  In
--- this setting, a reference to a 'DFun' or a 'CoAxiom' can only occur inside
--- the signature *that is defining it* (as there are no Core terms in
--- typechecked-only interface files, there's no way for a reference to occur
--- besides from the defining 'ClsInst' or closed type family).  Thus,
--- it doesn't really matter what names we give the DFun/CoAxiom, as long
--- as it's consistent between the declaration site and the use site.
---
--- We have to make sure that these bogus names don't get propagated,
--- but it is fine: see Note [Signature merging DFuns] for the fixups
--- to the names we do before writing out the merged interface.
--- (It's even easier for instantiation, since the DFuns all get
--- dropped entirely; the instances are reexported implicitly.)
---
--- Unfortunately, this strategy is not enough in the presence of promotion
--- (see bug #13149), where modules which import the signature may make
--- reference to their coercions.  It's not altogether clear how to
--- fix this case, but it is definitely a bug!
-
--- PILES AND PILES OF BOILERPLATE
-
--- | Rename an 'IfaceClsInst', with special handling for an associated
--- dictionary function.
-rnIfaceClsInst :: Rename IfaceClsInst
-rnIfaceClsInst cls_inst = do
-    n <- rnIfaceGlobal (ifInstCls cls_inst)
-    tys <- mapM rnRoughMatchTyCon (ifInstTys cls_inst)
-
-    dfun <- rnIfaceNeverExported (ifDFun cls_inst)
-    return cls_inst { ifInstCls = n
-                    , ifInstTys = tys
-                    , ifDFun = dfun
-                    }
-
-rnRoughMatchTyCon :: Rename (Maybe IfaceTyCon)
-rnRoughMatchTyCon Nothing = return Nothing
-rnRoughMatchTyCon (Just tc) = Just <$> rnIfaceTyCon tc
-
-rnIfaceFamInst :: Rename IfaceFamInst
-rnIfaceFamInst d = do
-    fam <- rnIfaceGlobal (ifFamInstFam d)
-    tys <- mapM rnRoughMatchTyCon (ifFamInstTys d)
-    axiom <- rnIfaceGlobal (ifFamInstAxiom d)
-    return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom }
-
-rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl)
-rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl
-
-rnIfaceDecl :: Rename IfaceDecl
-rnIfaceDecl d@IfaceId{} = do
-            name <- case ifIdDetails d of
-                      IfDFunId -> rnIfaceNeverExported (ifName d)
-                      _ | isDefaultMethodOcc (occName (ifName d))
-                        -> rnIfaceNeverExported (ifName d)
-                      -- Typeable bindings. See Note [Grand plan for Typeable].
-                      _ | isTypeableBindOcc (occName (ifName d))
-                        -> rnIfaceNeverExported (ifName d)
-                        | otherwise -> rnIfaceGlobal (ifName d)
-            ty <- rnIfaceType (ifType d)
-            details <- rnIfaceIdDetails (ifIdDetails d)
-            info <- rnIfaceIdInfo (ifIdInfo d)
-            return d { ifName = name
-                     , ifType = ty
-                     , ifIdDetails = details
-                     , ifIdInfo = info
-                     }
-rnIfaceDecl d@IfaceData{} = do
-            name <- rnIfaceGlobal (ifName d)
-            binders <- mapM rnIfaceTyConBinder (ifBinders d)
-            ctxt <- mapM rnIfaceType (ifCtxt d)
-            cons <- rnIfaceConDecls (ifCons d)
-            res_kind <- rnIfaceType (ifResKind d)
-            parent <- rnIfaceTyConParent (ifParent d)
-            return d { ifName = name
-                     , ifBinders = binders
-                     , ifCtxt = ctxt
-                     , ifCons = cons
-                     , ifResKind = res_kind
-                     , ifParent = parent
-                     }
-rnIfaceDecl d@IfaceSynonym{} = do
-            name <- rnIfaceGlobal (ifName d)
-            binders <- mapM rnIfaceTyConBinder (ifBinders d)
-            syn_kind <- rnIfaceType (ifResKind d)
-            syn_rhs <- rnIfaceType (ifSynRhs d)
-            return d { ifName = name
-                     , ifBinders = binders
-                     , ifResKind = syn_kind
-                     , ifSynRhs = syn_rhs
-                     }
-rnIfaceDecl d@IfaceFamily{} = do
-            name <- rnIfaceGlobal (ifName d)
-            binders <- mapM rnIfaceTyConBinder (ifBinders d)
-            fam_kind <- rnIfaceType (ifResKind d)
-            fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d)
-            return d { ifName = name
-                     , ifBinders = binders
-                     , ifResKind = fam_kind
-                     , ifFamFlav = fam_flav
-                     }
-rnIfaceDecl d@IfaceClass{} = do
-            name <- rnIfaceGlobal (ifName d)
-            binders <- mapM rnIfaceTyConBinder (ifBinders d)
-            body <- rnIfaceClassBody (ifBody d)
-            return d { ifName    = name
-                     , ifBinders = binders
-                     , ifBody    = body
-                     }
-rnIfaceDecl d@IfaceAxiom{} = do
-            name <- rnIfaceNeverExported (ifName d)
-            tycon <- rnIfaceTyCon (ifTyCon d)
-            ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d)
-            return d { ifName = name
-                     , ifTyCon = tycon
-                     , ifAxBranches = ax_branches
-                     }
-rnIfaceDecl d@IfacePatSyn{} =  do
-            name <- rnIfaceGlobal (ifName d)
-            let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b
-            pat_matcher <- rnPat (ifPatMatcher d)
-            pat_builder <- T.traverse rnPat (ifPatBuilder d)
-            pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d)
-            pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d)
-            pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d)
-            pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d)
-            pat_args <- mapM rnIfaceType (ifPatArgs d)
-            pat_ty <- rnIfaceType (ifPatTy d)
-            return d { ifName = name
-                     , ifPatMatcher = pat_matcher
-                     , ifPatBuilder = pat_builder
-                     , ifPatUnivBndrs = pat_univ_bndrs
-                     , ifPatExBndrs = pat_ex_bndrs
-                     , ifPatProvCtxt = pat_prov_ctxt
-                     , ifPatReqCtxt = pat_req_ctxt
-                     , ifPatArgs = pat_args
-                     , ifPatTy = pat_ty
-                     }
-
-rnIfaceClassBody :: Rename IfaceClassBody
-rnIfaceClassBody IfAbstractClass = return IfAbstractClass
-rnIfaceClassBody d@IfConcreteClass{} = do
-    ctxt <- mapM rnIfaceType (ifClassCtxt d)
-    ats <- mapM rnIfaceAT (ifATs d)
-    sigs <- mapM rnIfaceClassOp (ifSigs d)
-    return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }
-
-rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav
-rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs)))
-    = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n
-                                                <*> mapM rnIfaceAxBranch axs)
-rnIfaceFamTyConFlav flav = pure flav
-
-rnIfaceAT :: Rename IfaceAT
-rnIfaceAT (IfaceAT decl mb_ty)
-    = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty
-
-rnIfaceTyConParent :: Rename IfaceTyConParent
-rnIfaceTyConParent (IfDataInstance n tc args)
-    = IfDataInstance <$> rnIfaceGlobal n
-                     <*> rnIfaceTyCon tc
-                     <*> rnIfaceAppArgs args
-rnIfaceTyConParent IfNoParent = pure IfNoParent
-
-rnIfaceConDecls :: Rename IfaceConDecls
-rnIfaceConDecls (IfDataTyCon type_data ds)
-    = IfDataTyCon type_data <$> mapM rnIfaceConDecl ds
-rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d
-rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon
-
-rnIfaceConDecl :: Rename IfaceConDecl
-rnIfaceConDecl d = do
-    con_name <- rnIfaceGlobal (ifConName d)
-    con_ex_tvs <- mapM rnIfaceBndr (ifConExTCvs d)
-    con_user_tvbs <- mapM rnIfaceForAllBndr (ifConUserTvBinders d)
-    let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t
-    con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)
-    con_ctxt <- mapM rnIfaceType (ifConCtxt d)
-    con_arg_tys <- mapM rnIfaceScaledType (ifConArgTys d)
-    con_fields <- mapM rnFieldLabel (ifConFields d)
-    let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co
-        rnIfaceBang bang = pure bang
-    con_stricts <- mapM rnIfaceBang (ifConStricts d)
-    return d { ifConName = con_name
-             , ifConExTCvs = con_ex_tvs
-             , ifConUserTvBinders = con_user_tvbs
-             , ifConEqSpec = con_eq_spec
-             , ifConCtxt = con_ctxt
-             , ifConArgTys = con_arg_tys
-             , ifConFields = con_fields
-             , ifConStricts = con_stricts
-             }
-
-rnIfaceClassOp :: Rename IfaceClassOp
-rnIfaceClassOp (IfaceClassOp n ty dm) =
-    IfaceClassOp <$> rnIfaceGlobal n
-                 <*> rnIfaceType ty
-                 <*> rnMaybeDefMethSpec dm
-
-rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType))
-rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty
-rnMaybeDefMethSpec mb = return mb
-
-rnIfaceAxBranch :: Rename IfaceAxBranch
-rnIfaceAxBranch d = do
-    ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d)
-    lhs <- rnIfaceAppArgs (ifaxbLHS d)
-    rhs <- rnIfaceType (ifaxbRHS d)
-    return d { ifaxbTyVars = ty_vars
-             , ifaxbLHS = lhs
-             , ifaxbRHS = rhs }
-
-rnIfaceIdInfo :: Rename IfaceIdInfo
-rnIfaceIdInfo = mapM rnIfaceInfoItem
-
-rnIfaceInfoItem :: Rename IfaceInfoItem
-rnIfaceInfoItem (HsUnfold lb if_unf)
-    = HsUnfold lb <$> rnIfaceUnfolding if_unf
-rnIfaceInfoItem i
-    = pure i
-
-rnIfaceUnfolding :: Rename IfaceUnfolding
-rnIfaceUnfolding (IfCoreUnfold src guide if_expr)
-    = IfCoreUnfold src guide <$> rnIfaceExpr if_expr
-rnIfaceUnfolding (IfDFunUnfold bs ops)
-    = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops
-
-rnIfaceExpr :: Rename IfaceExpr
-rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name)
-rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl
-rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty
-rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co
-rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args
-rnIfaceExpr (IfaceLam lam_bndr expr)
-    = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr
-rnIfaceExpr (IfaceApp fun arg)
-    = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg
-rnIfaceExpr (IfaceCase scrut case_bndr alts)
-    = IfaceCase <$> rnIfaceExpr scrut
-                <*> pure case_bndr
-                <*> mapM rnIfaceAlt alts
-rnIfaceExpr (IfaceECase scrut ty)
-    = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty
-rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
-    = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs)
-               <*> rnIfaceExpr body
-rnIfaceExpr (IfaceLet (IfaceRec pairs) body)
-    = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) ->
-                                        (,) <$> rnIfaceLetBndr bndr
-                                            <*> rnIfaceExpr rhs) pairs)
-               <*> rnIfaceExpr body
-rnIfaceExpr (IfaceCast expr co)
-    = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co
-rnIfaceExpr (IfaceLit lit)           = pure (IfaceLit lit)
-rnIfaceExpr (IfaceLitRubbish tc rep) = IfaceLitRubbish tc <$> rnIfaceType rep
-rnIfaceExpr (IfaceFCall cc ty)       = IfaceFCall cc <$> rnIfaceType ty
-rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr
-
-rnIfaceBndrs :: Rename [IfaceBndr]
-rnIfaceBndrs = mapM rnIfaceBndr
-
-rnIfaceBndr :: Rename IfaceBndr
-rnIfaceBndr (IfaceIdBndr (w, fs, ty)) = IfaceIdBndr <$> ((,,) w fs <$> rnIfaceType ty)
-rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceTvBndr <$> rnIfaceTvBndr tv_bndr
-
-rnIfaceTvBndr :: Rename IfaceTvBndr
-rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind
-
-rnIfaceTyConBinder :: Rename IfaceTyConBinder
-rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis
-
-rnIfaceAlt :: Rename IfaceAlt
-rnIfaceAlt (IfaceAlt conalt names rhs)
-     = IfaceAlt <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs
-
-rnIfaceConAlt :: Rename IfaceConAlt
-rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ
-rnIfaceConAlt alt = pure alt
-
-rnIfaceLetBndr :: Rename IfaceLetBndr
-rnIfaceLetBndr (IfLetBndr fs ty info jpi)
-    = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info <*> pure jpi
-
-rnIfaceLamBndr :: Rename IfaceLamBndr
-rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot
-
-rnIfaceMCo :: Rename IfaceMCoercion
-rnIfaceMCo IfaceMRefl    = pure IfaceMRefl
-rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co
-
-rnIfaceCo :: Rename IfaceCoercion
-rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty
-rnIfaceCo (IfaceGReflCo role ty mco)
-  = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco
-rnIfaceCo (IfaceFunCo role w co1 co2)
-    = IfaceFunCo role <$> rnIfaceCo w <*> rnIfaceCo co1 <*> rnIfaceCo co2
-rnIfaceCo (IfaceTyConAppCo role tc cos)
-    = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos
-rnIfaceCo (IfaceAppCo co1 co2)
-    = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2
-rnIfaceCo (IfaceForAllCo bndr co1 co2)
-    = IfaceForAllCo <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2
-rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c)
-rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl
-rnIfaceCo (IfaceHoleCo lcl)  = IfaceHoleCo  <$> pure lcl
-rnIfaceCo (IfaceAxiomInstCo n i cs)
-    = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs
-rnIfaceCo (IfaceUnivCo s r t1 t2)
-    = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2
-rnIfaceCo (IfaceSymCo c)
-    = IfaceSymCo <$> rnIfaceCo c
-rnIfaceCo (IfaceTransCo c1 c2)
-    = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
-rnIfaceCo (IfaceInstCo c1 c2)
-    = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
-rnIfaceCo (IfaceSelCo d c) = IfaceSelCo d <$> rnIfaceCo c
-rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c
-rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c
-rnIfaceCo (IfaceAxiomRuleCo ax cos)
-    = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos
-rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c
-
-rnIfaceTyCon :: Rename IfaceTyCon
-rnIfaceTyCon (IfaceTyCon n info)
-    = IfaceTyCon <$> rnIfaceGlobal n <*> pure info
-
-rnIfaceExprs :: Rename [IfaceExpr]
-rnIfaceExprs = mapM rnIfaceExpr
-
-rnIfaceIdDetails :: Rename IfaceIdDetails
-rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b
-rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b
-rnIfaceIdDetails details = pure details
-
-rnIfaceType :: Rename IfaceType
-rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n)
-rnIfaceType (IfaceTyVar   n)   = pure (IfaceTyVar n)
-rnIfaceType (IfaceAppTy t1 t2)
-    = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2
-rnIfaceType (IfaceLitTy l)         = return (IfaceLitTy l)
-rnIfaceType (IfaceFunTy af w t1 t2)
-    = IfaceFunTy af <$> rnIfaceType w <*> rnIfaceType t1 <*> rnIfaceType t2
-rnIfaceType (IfaceTupleTy s i tks)
-    = IfaceTupleTy s i <$> rnIfaceAppArgs tks
-rnIfaceType (IfaceTyConApp tc tks)
-    = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceAppArgs tks
-rnIfaceType (IfaceForAllTy tv t)
-    = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t
-rnIfaceType (IfaceCoercionTy co)
-    = IfaceCoercionTy <$> rnIfaceCo co
-rnIfaceType (IfaceCastTy ty co)
-    = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co
-
-rnIfaceScaledType :: Rename (IfaceMult, IfaceType)
-rnIfaceScaledType (m, t) = (,) <$> rnIfaceType m <*> rnIfaceType t
-
-rnIfaceForAllBndr :: Rename (VarBndr IfaceBndr flag)
-rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis
-
-rnIfaceAppArgs :: Rename IfaceAppArgs
-rnIfaceAppArgs (IA_Arg t a ts) = IA_Arg <$> rnIfaceType t <*> pure a
-                                        <*> rnIfaceAppArgs ts
-rnIfaceAppArgs IA_Nil = pure IA_Nil
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
deleted file mode 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ /dev/null
@@ -1,1460 +0,0 @@
-
-{-# LANGUAGE DeriveFunctor #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-{-# LANGUAGE NamedFieldPuns #-}
-
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
--}
-
--- | Tidying up Core
-module GHC.Iface.Tidy
-  ( TidyOpts (..)
-  , UnfoldingExposure (..)
-  , tidyProgram
-  , mkBootModDetailsTc
-  )
-where
-
-import GHC.Prelude
-
-import GHC.Tc.Types
-import GHC.Tc.Utils.Env
-
-import GHC.Core
-import GHC.Core.Unfold
--- import GHC.Core.Unfold.Make
-import GHC.Core.FVs
-import GHC.Core.Tidy
-import GHC.Core.Seq         ( seqBinds )
-import GHC.Core.Opt.Arity   ( exprArity, typeArity, exprBotStrictness_maybe )
-import GHC.Core.InstEnv
-import GHC.Core.Type     ( Type, tidyTopType )
-import GHC.Core.DataCon
-import GHC.Core.TyCon
-import GHC.Core.Class
-import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
-
-import GHC.Iface.Tidy.StaticPtrTable
-import GHC.Iface.Env
-
-import GHC.Utils.Outputable
-import GHC.Utils.Misc( filterOut )
-import GHC.Utils.Panic
-import GHC.Utils.Logger as Logger
-import qualified GHC.Utils.Error as Err
-
-import GHC.Types.ForeignStubs
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
-import GHC.Types.Var
-import GHC.Types.Id
-import GHC.Types.Id.Make ( mkDictSelRhs )
-import GHC.Types.Id.Info
-import GHC.Types.Demand  ( isDeadEndAppSig, isNopSig, nopSig, isDeadEndSig )
-import GHC.Types.Basic
-import GHC.Types.Name hiding (varName)
-import GHC.Types.Name.Set
-import GHC.Types.Name.Cache
-import GHC.Types.Avail
-import GHC.Types.Tickish
-import GHC.Types.TypeEnv
-
-import GHC.Unit.Module
-import GHC.Unit.Module.ModGuts
-import GHC.Unit.Module.ModDetails
-import GHC.Unit.Module.Deps
-
-import GHC.Data.Maybe
-
-import Control.Monad
-import Data.Function
-import Data.List        ( sortBy, mapAccumL )
-import qualified Data.Set as S
-import GHC.Types.CostCentre
-
-{-
-Constructing the TypeEnv, Instances, Rules from which the
-ModIface is constructed, and which goes on to subsequent modules in
---make mode.
-
-Most of the interface file is obtained simply by serialising the
-TypeEnv.  One important consequence is that if the *interface file*
-has pragma info if and only if the final TypeEnv does. This is not so
-important for *this* module, but it's essential for ghc --make:
-subsequent compilations must not see (e.g.) the arity if the interface
-file does not contain arity If they do, they'll exploit the arity;
-then the arity might change, but the iface file doesn't change =>
-recompilation does not happen => disaster.
-
-For data types, the final TypeEnv will have a TyThing for the TyCon,
-plus one for each DataCon; the interface file will contain just one
-data type declaration, but it is de-serialised back into a collection
-of TyThings.
-
-************************************************************************
-*                                                                      *
-                Plan A: simpleTidyPgm
-*                                                                      *
-************************************************************************
-
-
-Plan A: mkBootModDetails: omit pragmas, make interfaces small
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* Ignore the bindings
-
-* Drop all WiredIn things from the TypeEnv
-        (we never want them in interface files)
-
-* Retain all TyCons and Classes in the TypeEnv, to avoid
-        having to find which ones are mentioned in the
-        types of exported Ids
-
-* Trim off the constructors of non-exported TyCons, both
-        from the TyCon and from the TypeEnv
-
-* Drop non-exported Ids from the TypeEnv
-
-* Tidy the types of the DFunIds of Instances,
-  make them into GlobalIds, (they already have External Names)
-  and add them to the TypeEnv
-
-* Tidy the types of the (exported) Ids in the TypeEnv,
-  make them into GlobalIds (they already have External Names)
-
-* Drop rules altogether
-
-* Tidy the bindings, to ensure that the Arity
-  information is correct for each top-level binder; the
-  code generator needs it. And to ensure that local names have
-  distinct OccNames in case of object-file splitting
-
-* If this an hsig file, drop the instances altogether too (they'll
-  get pulled in by the implicit module import.
--}
-
--- This is Plan A: make a small type env when typechecking only,
--- or when compiling a hs-boot file, or simply when not using -O
---
--- We don't look at the bindings at all -- there aren't any
--- for hs-boot files
-
-mkBootModDetailsTc :: Logger -> TcGblEnv -> IO ModDetails
-mkBootModDetailsTc logger
-        TcGblEnv{ tcg_exports          = exports,
-                  tcg_type_env         = type_env, -- just for the Ids
-                  tcg_tcs              = tcs,
-                  tcg_patsyns          = pat_syns,
-                  tcg_insts            = insts,
-                  tcg_fam_insts        = fam_insts,
-                  tcg_complete_matches = complete_matches,
-                  tcg_mod              = this_mod
-                }
-  = -- This timing isn't terribly useful since the result isn't forced, but
-    -- the message is useful to locating oneself in the compilation process.
-    Err.withTiming logger
-                   (text "CoreTidy"<+>brackets (ppr this_mod))
-                   (const ()) $
-    return (ModDetails { md_types            = type_env'
-                       , md_insts            = insts'
-                       , md_fam_insts        = fam_insts
-                       , md_rules            = []
-                       , md_anns             = []
-                       , md_exports          = exports
-                       , md_complete_matches = complete_matches
-                       })
-  where
-    -- Find the LocalIds in the type env that are exported
-    -- Make them into GlobalIds, and tidy their types
-    --
-    -- It's very important to remove the non-exported ones
-    -- because we don't tidy the OccNames, and if we don't remove
-    -- the non-exported ones we'll get many things with the
-    -- same name in the interface file, giving chaos.
-    --
-    -- Do make sure that we keep Ids that are already Global.
-    -- When typechecking an .hs-boot file, the Ids come through as
-    -- GlobalIds.
-    final_ids = [ globaliseAndTidyBootId id
-                | id <- typeEnvIds type_env
-                , keep_it id ]
-
-    final_tcs  = filterOut isWiredIn tcs
-                 -- See Note [Drop wired-in things]
-    type_env'  = typeEnvFromEntities final_ids final_tcs pat_syns fam_insts
-    insts'     = mkFinalClsInsts type_env' $ mkInstEnv insts
-
-    -- Default methods have their export flag set (isExportedId),
-    -- but everything else doesn't (yet), because this is
-    -- pre-desugaring, so we must test against the exports too.
-    keep_it id | isWiredInName id_name           = False
-                 -- See Note [Drop wired-in things]
-               | isExportedId id                 = True
-               | id_name `elemNameSet` exp_names = True
-               | otherwise                       = False
-               where
-                 id_name = idName id
-
-    exp_names = availsToNameSet exports
-
-lookupFinalId :: TypeEnv -> Id -> Id
-lookupFinalId type_env id
-  = case lookupTypeEnv type_env (idName id) of
-      Just (AnId id') -> id'
-      _ -> pprPanic "lookup_final_id" (ppr id)
-
-mkFinalClsInsts :: TypeEnv -> InstEnv -> InstEnv
-mkFinalClsInsts env = updateClsInstDFuns (lookupFinalId env)
-
-globaliseAndTidyBootId :: Id -> Id
--- For a LocalId with an External Name,
--- makes it into a GlobalId
---     * unchanged Name (might be Internal or External)
---     * unchanged details
---     * VanillaIdInfo (makes a conservative assumption about arity)
---     * BootUnfolding (see Note [Inlining and hs-boot files] in GHC.CoreToIface)
-globaliseAndTidyBootId id
-  = updateIdTypeAndMult tidyTopType (globaliseId id)
-                   `setIdUnfolding` BootUnfolding
-
-{-
-************************************************************************
-*                                                                      *
-        Plan B: tidy bindings, make TypeEnv full of IdInfo
-*                                                                      *
-************************************************************************
-
-Plan B: include pragmas, make interfaces
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* Step 1: Figure out which Ids are externally visible
-          See Note [Choosing external Ids]
-
-* Step 2: Gather the externally visible rules, separately from
-          the top-level bindings.
-          See Note [Finding external rules]
-
-* Step 3: Tidy the bindings, externalising appropriate Ids
-          See Note [Tidy the top-level bindings]
-
-* Drop all Ids from the TypeEnv, and add all the External Ids from
-  the bindings.  (This adds their IdInfo to the TypeEnv; and adds
-  floated-out Ids that weren't even in the TypeEnv before.)
-
-Note [Choosing external Ids]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See also the section "Interface stability" in the
-recompilation-avoidance commentary:
-  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance
-
-First we figure out which Ids are "external" Ids.  An
-"external" Id is one that is visible from outside the compilation
-unit.  These are
-  a) the user exported ones
-  b) the ones bound to static forms
-  c) ones mentioned in the unfoldings, workers, or
-     rules of externally-visible ones
-
-While figuring out which Ids are external, we pick a "tidy" OccName
-for each one.  That is, we make its OccName distinct from the other
-external OccNames in this module, so that in interface files and
-object code we can refer to it unambiguously by its OccName.  The
-OccName for each binder is prefixed by the name of the exported Id
-that references it; e.g. if "f" references "x" in its unfolding, then
-"x" is renamed to "f_x".  This helps distinguish the different "x"s
-from each other, and means that if "f" is later removed, things that
-depend on the other "x"s will not need to be recompiled.  Of course,
-if there are multiple "f_x"s, then we have to disambiguate somehow; we
-use "f_x0", "f_x1" etc.
-
-As far as possible we should assign names in a deterministic fashion.
-Each time this module is compiled with the same options, we should end
-up with the same set of external names with the same types.  That is,
-the ABI hash in the interface should not change.  This turns out to be
-quite tricky, since the order of the bindings going into the tidy
-phase is already non-deterministic, as it is based on the ordering of
-Uniques, which are assigned unpredictably.
-
-To name things in a stable way, we do a depth-first-search of the
-bindings, starting from the exports sorted by name.  This way, as long
-as the bindings themselves are deterministic (they sometimes aren't!),
-the order in which they are presented to the tidying phase does not
-affect the names we assign.
-
-Note [Tidy the top-level bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Next we traverse the bindings top to bottom.  For each *top-level*
-binder
-
- 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal,
-    reflecting the fact that from now on we regard it as a global,
-    not local, Id
-
- 2. Give it a system-wide Unique.
-    [Even non-exported things need system-wide Uniques because the
-    byte-code generator builds a single Name->BCO symbol table.]
-
-    We use the given NameCache as the source of such system-wide uniques.
-
-    For external Ids, use the original-name cache in the NameCache
-    to ensure that the unique assigned is the same as the Id had
-    in any previous compilation run.
-
- 3. Rename top-level Ids according to the names we chose in step 1.
-    If it's an external Id, make it have a External Name, otherwise
-    make it have an Internal Name.  This is used by the code generator
-    to decide whether to make the label externally visible
-
- 4. Give it its UTTERLY FINAL IdInfo; in ptic,
-        * its unfolding, if it should have one
-
-        * its arity, computed from the number of visible lambdas
-
-
-Finally, substitute these new top-level binders consistently
-throughout, including in unfoldings.  We also tidy binders in
-RHSs, so that they print nicely in interfaces.
-
-Note [Always expose compulsory unfoldings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must make absolutely sure that unsafeCoerce# is inlined. You might
-think that giving it a compulsory unfolding is enough. However,
-unsafeCoerce# is put in an interface file just like any other definition.
-So, unless we take special precuations
-- If we compiled Unsafe.Coerce with -O0, we might not put the unfolding
-  into the interface file.
-- If we compile a module M, that imports Unsafe.Coerce, with -O0 we might
-  not read the unfolding out of the interface file.
-
-So we need to take care, to ensure that Compulsory unfoldings are written
-and read.  That makes sense: they are compulsory, after all. There are
-three places this is actioned:
-
-* GHC.Iface.Tidy.addExternal.  Export end: expose compulsory
-  unfoldings, even with -O0.
-
-* GHC.IfaceToCore.tcIdInfo.  Import end: when reading in from
-  interface file, even with -O0 (fignore-interface-pragmas.)  we must
-  load a compulsory unfolding
--}
-
-data UnfoldingExposure
-  = ExposeNone -- ^ Don't expose unfoldings
-  | ExposeSome -- ^ Only expose required unfoldings
-  | ExposeAll  -- ^ Expose all unfoldings
-  deriving (Show,Eq,Ord)
-
-data TidyOpts = TidyOpts
-  { opt_name_cache        :: !NameCache
-  , opt_collect_ccs       :: !Bool -- ^ Always true if we compile with -prof
-  , opt_unfolding_opts    :: !UnfoldingOpts
-  , opt_expose_unfoldings :: !UnfoldingExposure
-      -- ^ Which unfoldings to expose
-  , opt_trim_ids :: !Bool
-      -- ^ trim off the arity, one-shot-ness, strictness etc which were
-      -- retained for the benefit of the code generator
-  , opt_expose_rules :: !Bool
-      -- ^ Are rules exposed or not?
-  , opt_static_ptr_opts :: !(Maybe StaticPtrOpts)
-      -- ^ Options for generated static pointers, if enabled (/= Nothing).
-  }
-
-tidyProgram :: TidyOpts -> ModGuts -> IO (CgGuts, ModDetails)
-tidyProgram opts (ModGuts { mg_module           = mod
-                          , mg_exports          = exports
-                          , mg_tcs              = tcs
-                          , mg_insts            = cls_insts
-                          , mg_fam_insts        = fam_insts
-                          , mg_binds            = binds
-                          , mg_patsyns          = patsyns
-                          , mg_rules            = imp_rules
-                          , mg_anns             = anns
-                          , mg_complete_matches = complete_matches
-                          , mg_deps             = deps
-                          , mg_foreign          = foreign_stubs
-                          , mg_foreign_files    = foreign_files
-                          , mg_hpc_info         = hpc_info
-                          , mg_modBreaks        = modBreaks
-                          , mg_boot_exports     = boot_exports
-                          }) = do
-
-  let implicit_binds = concatMap getImplicitBinds tcs
-      all_binds = implicit_binds ++ binds
-
-  (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod all_binds imp_rules
-  let (trimmed_binds, trimmed_rules) = findExternalRules opts all_binds imp_rules unfold_env
-
-  (tidy_env, tidy_binds) <- tidyTopBinds unfold_env boot_exports tidy_occ_env trimmed_binds
-
-  -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
-  (spt_entries, mcstub, tidy_binds') <- case opt_static_ptr_opts opts of
-    Nothing    -> pure ([], Nothing, tidy_binds)
-    Just sopts -> sptCreateStaticBinds sopts mod tidy_binds
-
-  let all_foreign_stubs = case mcstub of
-        Nothing    -> foreign_stubs
-        Just cstub -> foreign_stubs `appendStubC` cstub
-
-      -- The completed type environment is gotten from
-      --      a) the types and classes defined here (plus implicit things)
-      --      b) adding Ids with correct IdInfo, including unfoldings,
-      --              gotten from the bindings
-      -- From (b) we keep only those Ids with External names;
-      --          the CoreTidy pass makes sure these are all and only
-      --          the externally-accessible ones
-      -- This truncates the type environment to include only the
-      -- exported Ids and things needed from them, which saves space
-      --
-      -- See Note [Don't attempt to trim data types]
-      final_ids  = [ trimId (opt_trim_ids opts) id
-                   | id <- bindersOfBinds tidy_binds
-                   , isExternalName (idName id)
-                   , not (isWiredIn id)
-                   ]   -- See Note [Drop wired-in things]
-
-      final_tcs      = filterOut isWiredIn tcs
-                       -- See Note [Drop wired-in things]
-      tidy_type_env  = typeEnvFromEntities final_ids final_tcs patsyns fam_insts
-      tidy_cls_insts = mkFinalClsInsts tidy_type_env $ mkInstEnv cls_insts
-      tidy_rules     = tidyRules tidy_env trimmed_rules
-
-      -- See Note [Injecting implicit bindings]
-      all_tidy_binds = tidy_binds'
-
-      -- Get the TyCons to generate code for.  Careful!  We must use
-      -- the untidied TyCons here, because we need
-      --  (a) implicit TyCons arising from types and classes defined
-      --      in this module
-      --  (b) wired-in TyCons, which are normally removed from the
-      --      TypeEnv we put in the ModDetails
-      --  (c) Constructors even if they are not exported (the
-      --      tidied TypeEnv has trimmed these away)
-      alg_tycons = filter isAlgTyCon tcs
-
-      local_ccs
-        | opt_collect_ccs opts
-              = collectCostCentres mod all_tidy_binds tidy_rules
-        | otherwise
-              = S.empty
-
-  return (CgGuts { cg_module        = mod
-                 , cg_tycons        = alg_tycons
-                 , cg_binds         = all_tidy_binds
-                 , cg_ccs           = S.toList local_ccs
-                 , cg_foreign       = all_foreign_stubs
-                 , cg_foreign_files = foreign_files
-                 , cg_dep_pkgs      = dep_direct_pkgs deps
-                 , cg_hpc_info      = hpc_info
-                 , cg_modBreaks     = modBreaks
-                 , cg_spt_entries   = spt_entries
-                 }
-         , ModDetails { md_types            = tidy_type_env
-                      , md_rules            = tidy_rules
-                      , md_insts            = tidy_cls_insts
-                      , md_fam_insts        = fam_insts
-                      , md_exports          = exports
-                      , md_anns             = anns      -- are already tidy
-                      , md_complete_matches = complete_matches
-                      }
-         )
-
-
-------------------------------------------------------------------------------
--- Collecting cost centres
--- ---------------------------------------------------------------------------
-
--- | Collect cost centres defined in the current module, including those in
--- unfoldings.
-collectCostCentres :: Module -> CoreProgram -> [CoreRule] -> S.Set CostCentre
-collectCostCentres mod_name binds rules
-  = {-# SCC collectCostCentres #-} foldl' go_bind (go_rules S.empty) binds
-  where
-    go cs e = case e of
-      Var{} -> cs
-      Lit{} -> cs
-      App e1 e2 -> go (go cs e1) e2
-      Lam _ e -> go cs e
-      Let b e -> go (go_bind cs b) e
-      Case scrt _ _ alts -> go_alts (go cs scrt) alts
-      Cast e _ -> go cs e
-      Tick (ProfNote cc _ _) e ->
-        go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e
-      Tick _ e -> go cs e
-      Type{} -> cs
-      Coercion{} -> cs
-
-    go_alts = foldl' (\cs (Alt _con _bndrs e) -> go cs e)
-
-    go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre
-    go_bind cs (NonRec b e) =
-      go (do_binder cs b) e
-    go_bind cs (Rec bs) =
-      foldl' (\cs' (b, e) -> go (do_binder cs' b) e) cs bs
-
-    do_binder cs b = maybe cs (go cs) (get_unf b)
-
-
-    -- Unfoldings may have cost centres that in the original definion are
-    -- optimized away, see #5889.
-    get_unf = maybeUnfoldingTemplate . realIdUnfolding
-
-    -- Have to look at the RHS of rules as well, as these may contain ticks which
-    -- don't appear anywhere else. See #19894
-    go_rules cs = foldl' go cs (mapMaybe get_rhs rules)
-
-    get_rhs Rule { ru_rhs } = Just ru_rhs
-    get_rhs BuiltinRule {} = Nothing
-
---------------------------
-trimId :: Bool -> Id -> Id
--- With -O0 we now trim off the arity, one-shot-ness, strictness
--- etc which tidyTopIdInfo retains for the benefit of the code generator
--- but which we don't want in the interface file or ModIface for
--- downstream compilations
-trimId do_trim id
-  | do_trim, not (isImplicitId id)
-  = id `setIdInfo`      vanillaIdInfo
-       `setIdUnfolding` idUnfolding id
-       -- We respect the final unfolding chosen by tidyTopIdInfo.
-       -- We have already trimmed it if we don't want it for -O0;
-       -- see also Note [Always expose compulsory unfoldings]
-
-  | otherwise   -- No trimming
-  = id
-
-{- Note [Drop wired-in things]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We never put wired-in TyCons or Ids in an interface file.
-They are wired-in, so the compiler knows about them already.
-
-Note [Don't attempt to trim data types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For some time GHC tried to avoid exporting the data constructors
-of a data type if it wasn't strictly necessary to do so; see #835.
-But "strictly necessary" accumulated a longer and longer list
-of exceptions, and finally I gave up the battle:
-
-    commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11
-    Author: Simon Peyton Jones <simonpj@microsoft.com>
-    Date:   Thu Dec 6 16:03:16 2012 +0000
-
-    Stop attempting to "trim" data types in interface files
-
-    Without -O, we previously tried to make interface files smaller
-    by not including the data constructors of data types.  But
-    there are a lot of exceptions, notably when Template Haskell is
-    involved or, more recently, DataKinds.
-
-    However #7445 shows that even without TemplateHaskell, using
-    the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ
-    is enough to require us to expose the data constructors.
-
-    So I've given up on this "optimisation" -- it's probably not
-    important anyway.  Now I'm simply not attempting to trim off
-    the data constructors.  The gain in simplicity is worth the
-    modest cost in interface file growth, which is limited to the
-    bits reqd to describe those data constructors.
-
-************************************************************************
-*                                                                      *
-        Implicit bindings
-*                                                                      *
-************************************************************************
-
-Note [Injecting implicit bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We inject the implicit bindings right at the end, in GHC.Core.Tidy.
-Some of these bindings, notably record selectors, are not
-constructed in an optimised form.  E.g. record selector for
-        data T = MkT { x :: {-# UNPACK #-} !Int }
-Then the unfolding looks like
-        x = \t. case t of MkT x1 -> let x = I# x1 in x
-This generates bad code unless it's first simplified a bit.  That is
-why GHC.Core.Unfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of
-optimisation first.  (Only matters when the selector is used curried;
-eg map x ys.)  See #2070.
-
-[Oct 09: in fact, record selectors are no longer implicit Ids at all,
-because we really do want to optimise them properly. They are treated
-much like any other Id.  But doing "light" optimisation on an implicit
-Id still makes sense.]
-
-At one time I tried injecting the implicit bindings *early*, at the
-beginning of SimplCore.  But that gave rise to real difficulty,
-because GlobalIds are supposed to have *fixed* IdInfo, but the
-simplifier and other core-to-core passes mess with IdInfo all the
-time.  The straw that broke the camels back was when a class selector
-got the wrong arity -- ie the simplifier gave it arity 2, whereas
-importing modules were expecting it to have arity 1 (#2844).
-It's much safer just to inject them right at the end, after tidying.
-
-Oh: two other reasons for injecting them late:
-
-  - If implicit Ids are already in the bindings when we start tidying,
-    we'd have to be careful not to treat them as external Ids (in
-    the sense of chooseExternalIds); else the Ids mentioned in *their*
-    RHSs will be treated as external and you get an interface file
-    saying      a18 = <blah>
-    but nothing referring to a18 (because the implicit Id is the
-    one that does, and implicit Ids don't appear in interface files).
-
-  - More seriously, the tidied type-envt will include the implicit
-    Id replete with a18 in its unfolding; but we won't take account
-    of a18 when computing a fingerprint for the class; result chaos.
-
-There is one sort of implicit binding that is injected still later,
-namely those for data constructor workers. Reason (I think): it's
-really just a code generation trick.... binding itself makes no sense.
-See Note [Data constructor workers] in "GHC.CoreToStg.Prep".
--}
-
-getImplicitBinds :: TyCon -> [CoreBind]
-getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc
-  where
-    cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc)
-
-getTyConImplicitBinds :: TyCon -> [CoreBind]
-getTyConImplicitBinds tc
-  | isNewTyCon tc = []  -- See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make
-  | otherwise     = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))
-
-getClassImplicitBinds :: Class -> [CoreBind]
-getClassImplicitBinds cls
-  = [ NonRec op (mkDictSelRhs cls val_index)
-    | (op, val_index) <- classAllSelIds cls `zip` [0..] ]
-
-get_defn :: Id -> CoreBind
-get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Step 1: finding externals}
-*                                                                      *
-************************************************************************
-
-See Note [Choosing external Ids].
--}
-
-type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})
-  -- Maps each top-level Id to its new Name (the Id is tidied in step 2)
-  -- The Unique is unchanged.  If the new Name is external, it will be
-  -- visible in the interface file.
-  --
-  -- Bool => expose unfolding or not.
-
-chooseExternalIds :: TidyOpts
-                  -> Module
-                  -> [CoreBind]
-                  -> [CoreRule]
-                  -> IO (UnfoldEnv, TidyOccEnv)
-                  -- Step 1 from the notes above
-
-chooseExternalIds opts mod binds imp_id_rules
-  = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env
-       ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders
-       ; tidy_internal internal_ids unfold_env1 occ_env1 }
- where
-  name_cache = opt_name_cache opts
-
-  -- init_ext_ids is the initial list of Ids that should be
-  -- externalised.  It serves as the starting point for finding a
-  -- deterministic, tidy, renaming for all external Ids in this
-  -- module.
-  --
-  -- It is sorted, so that it has a deterministic order (i.e. it's the
-  -- same list every time this module is compiled), in contrast to the
-  -- bindings, which are ordered non-deterministically.
-  init_work_list = zip init_ext_ids init_ext_ids
-  init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders
-
-  -- An Id should be external if either (a) it is exported,
-  -- (b) local rules are exposed and it appears in the RHS of a local rule for
-  -- an imported Id, or See Note [Which rules to expose]
-  is_external id
-    | isExportedId id       = True
-    | opt_expose_rules opts = id `elemVarSet` rule_rhs_vars
-    | otherwise             = False
-
-  rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules
-
-  binders          = map fst $ flattenBinds binds
-  binder_set       = mkVarSet binders
-
-  avoids   = [getOccName name | bndr <- binders,
-                                let name = idName bndr,
-                                isExternalName name ]
-                -- In computing our "avoids" list, we must include
-                --      all implicit Ids
-                --      all things with global names (assigned once and for
-                --                                      all by the renamer)
-                -- since their names are "taken".
-                -- The type environment is a convenient source of such things.
-                -- In particular, the set of binders doesn't include
-                -- implicit Ids at this stage.
-
-        -- We also make sure to avoid any exported binders.  Consider
-        --      f{-u1-} = 1     -- Local decl
-        --      ...
-        --      f{-u2-} = 2     -- Exported decl
-        --
-        -- The second exported decl must 'get' the name 'f', so we
-        -- have to put 'f' in the avoids list before we get to the first
-        -- decl.  tidyTopId then does a no-op on exported binders.
-  init_occ_env = initTidyOccEnv avoids
-
-
-  search :: [(Id,Id)]    -- The work-list: (external id, referring id)
-                         -- Make a tidy, external Name for the external id,
-                         --   add it to the UnfoldEnv, and do the same for the
-                         --   transitive closure of Ids it refers to
-                         -- The referring id is used to generate a tidy
-                         ---  name for the external id
-         -> UnfoldEnv    -- id -> (new Name, show_unfold)
-         -> TidyOccEnv   -- occ env for choosing new Names
-         -> IO (UnfoldEnv, TidyOccEnv)
-
-  search [] unfold_env occ_env = return (unfold_env, occ_env)
-
-  search ((idocc,referrer) : rest) unfold_env occ_env
-    | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env
-    | otherwise = do
-      (occ_env', name') <- tidyTopName mod name_cache (Just referrer) occ_env idocc
-      let
-          (new_ids, show_unfold) = addExternal opts refined_id
-
-                -- 'idocc' is an *occurrence*, but we need to see the
-                -- unfolding in the *definition*; so look up in binder_set
-          refined_id = case lookupVarSet binder_set idocc of
-                         Just id -> id
-                         Nothing -> warnPprTrace True "chooseExternalIds" (ppr idocc) idocc
-
-          unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)
-          referrer' | isExportedId refined_id = refined_id
-                    | otherwise               = referrer
-      --
-      search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env'
-
-  tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv
-                -> IO (UnfoldEnv, TidyOccEnv)
-  tidy_internal []       unfold_env occ_env = return (unfold_env,occ_env)
-  tidy_internal (id:ids) unfold_env occ_env = do
-      (occ_env', name') <- tidyTopName mod name_cache Nothing occ_env id
-      let unfold_env' = extendVarEnv unfold_env id (name',False)
-      tidy_internal ids unfold_env' occ_env'
-
-addExternal :: TidyOpts -> Id -> ([Id], Bool)
-addExternal opts id
-  | ExposeNone <- opt_expose_unfoldings opts
-  , not (isCompulsoryUnfolding unfolding)
-  = ([], False)  -- See Note [Always expose compulsory unfoldings]
-                 -- in GHC.HsToCore
-
-  | otherwise
-  = (new_needed_ids, show_unfold)
-
-  where
-    new_needed_ids = bndrFvsInOrder show_unfold id
-    idinfo         = idInfo id
-    unfolding      = realUnfoldingInfo idinfo
-    show_unfold    = show_unfolding unfolding
-    never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
-    loop_breaker   = isStrongLoopBreaker (occInfo idinfo)
-    bottoming_fn   = isDeadEndSig (dmdSigInfo idinfo)
-
-        -- Stuff to do with the Id's unfolding
-        -- We leave the unfolding there even if there is a worker
-        -- In GHCi the unfolding is used by importers
-
-    show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })
-       = opt_expose_unfoldings opts == ExposeAll
-            -- 'ExposeAll' says to expose all
-            -- unfoldings willy-nilly
-
-       || isStableSource src     -- Always expose things whose
-                                 -- source is an inline rule
-
-       || not dont_inline
-       where
-         dont_inline
-            | never_active = True   -- Will never inline
-            | loop_breaker = True   -- Ditto
-            | otherwise    = case guidance of
-                                UnfWhen {}       -> False
-                                UnfIfGoodArgs {} -> bottoming_fn
-                                UnfNever {}      -> True
-         -- bottoming_fn: don't inline bottoming functions, unless the
-         -- RHS is very small or trivial (UnfWhen), in which case we
-         -- may as well do so For example, a cast might cancel with
-         -- the call site.
-
-    show_unfolding (DFunUnfolding {}) = True
-    show_unfolding _                  = False
-
-{-
-************************************************************************
-*                                                                      *
-               Deterministic free variables
-*                                                                      *
-************************************************************************
-
-We want a deterministic free-variable list.  exprFreeVars gives us
-a VarSet, which is in a non-deterministic order when converted to a
-list.  Hence, here we define a free-variable finder that returns
-the free variables in the order that they are encountered.
-
-See Note [Choosing external Ids]
--}
-
-bndrFvsInOrder :: Bool -> Id -> [Id]
-bndrFvsInOrder show_unfold id
-  = run (dffvLetBndr show_unfold id)
-
-run :: DFFV () -> [Id]
-run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of
-                 ((_,ids),_) -> ids
-
-newtype DFFV a
-  = DFFV (VarSet              -- Envt: non-top-level things that are in scope
-                              -- we don't want to record these as free vars
-      -> (VarSet, [Var])      -- Input State: (set, list) of free vars so far
-      -> ((VarSet,[Var]),a))  -- Output state
-    deriving (Functor)
-
-instance Applicative DFFV where
-    pure a = DFFV $ \_ st -> (st, a)
-    (<*>) = ap
-
-instance Monad DFFV where
-  (DFFV m) >>= k = DFFV $ \env st ->
-    case m env st of
-       (st',a) -> case k a of
-                     DFFV f -> f env st'
-
-extendScope :: Var -> DFFV a -> DFFV a
-extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st)
-
-extendScopeList :: [Var] -> DFFV a -> DFFV a
-extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st)
-
-insert :: Var -> DFFV ()
-insert v = DFFV $ \ env (set, ids) ->
-           let keep_me = isLocalId v &&
-                         not (v `elemVarSet` env) &&
-                           not (v `elemVarSet` set)
-           in if keep_me
-              then ((extendVarSet set v, v:ids), ())
-              else ((set,                ids),   ())
-
-
-dffvExpr :: CoreExpr -> DFFV ()
-dffvExpr (Var v)              = insert v
-dffvExpr (App e1 e2)          = dffvExpr e1 >> dffvExpr e2
-dffvExpr (Lam v e)            = extendScope v (dffvExpr e)
-dffvExpr (Tick (Breakpoint _ _ ids) e) = mapM_ insert ids >> dffvExpr e
-dffvExpr (Tick _other e)    = dffvExpr e
-dffvExpr (Cast e _)           = dffvExpr e
-dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e)
-dffvExpr (Let (Rec prs) e)    = extendScopeList (map fst prs) $
-                                (mapM_ dffvBind prs >> dffvExpr e)
-dffvExpr (Case e b _ as)      = dffvExpr e >> extendScope b (mapM_ dffvAlt as)
-dffvExpr _other               = return ()
-
-dffvAlt :: CoreAlt -> DFFV ()
-dffvAlt (Alt _ xs r) = extendScopeList xs (dffvExpr r)
-
-dffvBind :: (Id, CoreExpr) -> DFFV ()
-dffvBind(x,r)
-  | not (isId x) = dffvExpr r
-  | otherwise    = dffvLetBndr False x >> dffvExpr r
-                -- Pass False because we are doing the RHS right here
-                -- If you say True you'll get *exponential* behaviour!
-
-dffvLetBndr :: Bool -> Id -> DFFV ()
--- Gather the free vars of the RULES and unfolding of a binder
--- We always get the free vars of a *stable* unfolding, but
--- for a *vanilla* one (VanillaSrc), the flag controls what happens:
---   True <=> get fvs of even a *vanilla* unfolding
---   False <=> ignore a VanillaSrc
--- For nested bindings (call from dffvBind) we always say "False" because
---       we are taking the fvs of the RHS anyway
--- For top-level bindings (call from addExternal, via bndrFvsInOrder)
---       we say "True" if we are exposing that unfolding
-dffvLetBndr vanilla_unfold id
-  = do { go_unf (realUnfoldingInfo idinfo)
-       ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) }
-  where
-    idinfo = idInfo id
-
-    go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
-       | isStableSource src = dffvExpr rhs
-       | vanilla_unfold     = dffvExpr rhs
-       | otherwise          = return ()
-
-    go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args })
-             = extendScopeList bndrs $ mapM_ dffvExpr args
-    go_unf _ = return ()
-
-    go_rule (BuiltinRule {}) = return ()
-    go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs })
-      = extendScopeList bndrs (dffvExpr rhs)
-
-{-
-************************************************************************
-*                                                                      *
-               findExternalRules
-*                                                                      *
-************************************************************************
-
-Note [Finding external rules]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The complete rules are gotten by combining
-   a) local rules for imported Ids
-   b) rules embedded in the top-level Ids
-
-There are two complications:
-  * Note [Which rules to expose]
-  * Note [Trimming auto-rules]
-
-Note [Which rules to expose]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The function 'expose_rule' filters out rules that mention, on the LHS,
-Ids that aren't externally visible; these rules can't fire in a client
-module.
-
-The externally-visible binders are computed (by chooseExternalIds)
-assuming that all orphan rules are externalised (see init_ext_ids in
-function 'search'). So in fact it's a bit conservative and we may
-export more than we need.  (It's a sort of mutual recursion.)
-
-Note [Trimming auto-rules]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Second, with auto-specialisation we may specialise local or imported
-dfuns or INLINE functions, and then later inline them.  That may leave
-behind something like
-   RULE "foo" forall d. f @ Int d = f_spec
-where f is either local or imported, and there is no remaining
-reference to f_spec except from the RULE.
-
-Now that RULE *might* be useful to an importing module, but that is
-purely speculative, and meanwhile the code is taking up space and
-codegen time.  I found that binary sizes jumped by 6-10% when I
-started to specialise INLINE functions (again, Note [Inline
-specialisations] in GHC.Core.Opt.Specialise).
-
-So it seems better to drop the binding for f_spec, and the rule
-itself, if the auto-generated rule is the *only* reason that it is
-being kept alive.
-
-(The RULE still might have been useful in the past; that is, it was
-the right thing to have generated it in the first place.  See Note
-[Inline specialisations] in GHC.Core.Opt.Specialise. But now it has
-served its purpose, and can be discarded.)
-
-So findExternalRules does this:
-  * Remove all bindings that are kept alive *only* by isAutoRule rules
-      (this is done in trim_binds)
-  * Remove all auto rules that mention bindings that have been removed
-      (this is done by filtering by keep_rule)
-
-NB: if a binding is kept alive for some *other* reason (e.g. f_spec is
-called in the final code), we keep the rule too.
-
-This stuff is the only reason for the ru_auto field in a Rule.
-
-NB: In #18532 we looked at keeping auto-rules and it turned out to just make
-compiler performance worse while increasing code sizes at the same time. The impact
-varied. Compiling Cabal got ~3% slower, allocated ~3% more and wrote 15% more code to disk.
-Nofib only saw 0.7% more compiler allocations and executable file size growth. But given
-there was no difference in runtime for these benchmarks it turned out to be flat out worse.
-See the ticket for more details.
--}
-
-findExternalRules :: TidyOpts
-                  -> [CoreBind]
-                  -> [CoreRule] -- Local rules for imported fns
-                  -> UnfoldEnv  -- Ids that are exported, so we need their rules
-                  -> ([CoreBind], [CoreRule])
--- See Note [Finding external rules]
-findExternalRules opts binds imp_id_rules unfold_env
-  = (trimmed_binds, filter keep_rule all_rules)
-  where
-    imp_rules | (opt_expose_rules opts) = filter expose_rule imp_id_rules
-              | otherwise               = []
-    imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules
-
-    user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet
-                           | otherwise       = ruleRhsFreeVars rule
-
-    (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds
-
-    keep_rule rule = ruleFreeVars rule `subVarSet` local_bndrs
-        -- Remove rules that make no sense, because they mention a
-        -- local binder (on LHS or RHS) that we have now discarded.
-        -- (NB: ruleFreeVars only includes LocalIds)
-        --
-        -- LHS: we have already filtered out rules that mention internal Ids
-        --     on LHS but that isn't enough because we might have by now
-        --     discarded a binding with an external Id. (How?
-        --     chooseExternalIds is a bit conservative.)
-        --
-        -- RHS: the auto rules that might mention a binder that has
-        --      been discarded; see Note [Trimming auto-rules]
-
-    expose_rule rule = all is_external_id (ruleLhsFreeIdsList rule)
-                -- Don't expose a rule whose LHS mentions a locally-defined
-                -- Id that is completely internal (i.e. not visible to an
-                -- importing module).  NB: ruleLhsFreeIds only returns LocalIds.
-                -- See Note [Which rules to expose]
-
-    is_external_id id = case lookupVarEnv unfold_env id of
-                          Just (name, _) -> isExternalName name && not (isImplicitId id)
-                          Nothing        -> False
-
-    trim_binds :: [CoreBind]
-               -> ( [CoreBind]   -- Trimmed bindings
-                  , VarSet       -- Binders of those bindings
-                  , VarSet       -- Free vars of those bindings + rhs of user rules
-                                 -- (we don't bother to delete the binders)
-                  , [CoreRule])  -- All rules, imported + from the bindings
-    -- This function removes unnecessary bindings, and gathers up rules from
-    -- the bindings we keep.  See Note [Trimming auto-rules]
-    trim_binds []  -- Base case, start with imp_user_rule_fvs
-       = ([], emptyVarSet, imp_user_rule_fvs, imp_rules)
-
-    trim_binds (bind:binds)
-       | any needed bndrs    -- Keep this binding
-       = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules )
-       | otherwise           -- Discard binding altogether
-       = stuff
-       where
-         stuff@(binds', bndr_set, needed_fvs, rules)
-                       = trim_binds binds
-         needed bndr   = isExportedId bndr || bndr `elemVarSet` needed_fvs
-
-         bndrs         = bindersOf  bind
-         rhss          = rhssOfBind bind
-         bndr_set'     = bndr_set `extendVarSetList` bndrs
-
-         needed_fvs'   = needed_fvs                                   `unionVarSet`
-                         mapUnionVarSet idUnfoldingVars   bndrs       `unionVarSet`
-                              -- Ignore type variables in the type of bndrs
-                         mapUnionVarSet exprFreeVars      rhss        `unionVarSet`
-                         mapUnionVarSet user_rule_rhs_fvs local_rules
-            -- In needed_fvs', we don't bother to delete binders from the fv set
-
-         local_rules  = [ rule
-                        | (opt_expose_rules opts)
-                        , id <- bndrs
-                        , is_external_id id   -- Only collect rules for external Ids
-                        , rule <- idCoreRules id
-                        , expose_rule rule ]  -- and ones that can fire in a client
-
-{-
-************************************************************************
-*                                                                      *
-               tidyTopName
-*                                                                      *
-************************************************************************
-
-This is where we set names to local/global based on whether they really are
-externally visible (see comment at the top of this module).  If the name
-was previously local, we have to give it a unique occurrence name if
-we intend to externalise it.
--}
-
-tidyTopName :: Module -> NameCache -> Maybe Id -> TidyOccEnv
-            -> Id -> IO (TidyOccEnv, Name)
-tidyTopName mod name_cache maybe_ref occ_env id
-  | global && internal = return (occ_env, localiseName name)
-
-  | global && external = return (occ_env, name)
-        -- Global names are assumed to have been allocated by the renamer,
-        -- so they already have the "right" unique
-        -- And it's a system-wide unique too
-
-  -- Now we get to the real reason that all this is in the IO Monad:
-  -- we have to update the name cache in a nice atomic fashion
-
-  | local  && internal = do uniq <- takeUniqFromNameCache name_cache
-                            let new_local_name = mkInternalName uniq occ' loc
-                            return (occ_env', new_local_name)
-        -- Even local, internal names must get a unique occurrence, because
-        -- if we do -split-objs we externalise the name later, in the code generator
-        --
-        -- Similarly, we must make sure it has a system-wide Unique, because
-        -- the byte-code generator builds a system-wide Name->BCO symbol table
-
-  | local  && external = do new_external_name <- allocateGlobalBinder name_cache mod occ' loc
-                            return (occ_env', new_external_name)
-        -- If we want to externalise a currently-local name, check
-        -- whether we have already assigned a unique for it.
-        -- If so, use it; if not, extend the table.
-        -- All this is done by allocateGlobalBinder.
-        -- This is needed when *re*-compiling a module in GHCi; we must
-        -- use the same name for externally-visible things as we did before.
-
-  | otherwise = panic "tidyTopName"
-  where
-    !name       = idName id
-    external    = isJust maybe_ref
-    global      = isExternalName name
-    local       = not global
-    internal    = not external
-    !loc        = nameSrcSpan name
-
-    old_occ     = nameOccName name
-    new_occ | Just ref <- maybe_ref
-            , ref /= id
-            = mkOccName (occNameSpace old_occ) $
-                   let
-                       ref_str = occNameString (getOccName ref)
-                       occ_str = occNameString old_occ
-                   in
-                   case occ_str of
-                     '$':'w':_ -> occ_str
-                        -- workers: the worker for a function already
-                        -- includes the occname for its parent, so there's
-                        -- no need to prepend the referrer.
-                     _other | isSystemName name -> ref_str
-                            | otherwise         -> ref_str ++ '_' : occ_str
-                        -- If this name was system-generated, then don't bother
-                        -- to retain its OccName, just use the referrer.  These
-                        -- system-generated names will become "f1", "f2", etc. for
-                        -- a referrer "f".
-            | otherwise = old_occ
-
-    (occ_env', occ') = tidyOccName occ_env new_occ
-
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Step 2: top-level tidying}
-*                                                                      *
-************************************************************************
--}
-
--- TopTidyEnv: when tidying we need to know
---   * name_cache: The NameCache, containing a unique supply and any pre-ordained Names.
---        These may have arisen because the
---        renamer read in an interface file mentioning M.$wf, say,
---        and assigned it unique r77.  If, on this compilation, we've
---        invented an Id whose name is $wf (but with a different unique)
---        we want to rename it to have unique r77, so that we can do easy
---        comparisons with stuff from the interface file
---
---   * occ_env: The TidyOccEnv, which tells us which local occurrences
---     are 'used'
---
---   * subst_env: A Var->Var mapping that substitutes the new Var for the old
-
-tidyTopBinds :: UnfoldEnv
-             -> NameSet
-             -> TidyOccEnv
-             -> CoreProgram
-             -> IO (TidyEnv, CoreProgram)
-
-tidyTopBinds unfold_env boot_exports init_occ_env binds
-  = do let result = tidy init_env binds
-       seqBinds (snd result) `seq` return result
-       -- This seqBinds avoids a spike in space usage (see #13564)
-  where
-    init_env = (init_occ_env, emptyVarEnv)
-
-    tidy = mapAccumL (tidyTopBind unfold_env boot_exports)
-
-------------------------
-tidyTopBind  :: UnfoldEnv
-             -> NameSet
-             -> TidyEnv
-             -> CoreBind
-             -> (TidyEnv, CoreBind)
-
-tidyTopBind unfold_env boot_exports
-            (occ_env,subst1) (NonRec bndr rhs)
-  = (tidy_env2,  NonRec bndr' rhs')
-  where
-    (bndr', rhs') = tidyTopPair unfold_env boot_exports tidy_env2 (bndr, rhs)
-    subst2        = extendVarEnv subst1 bndr bndr'
-    tidy_env2     = (occ_env, subst2)
-
-tidyTopBind unfold_env boot_exports (occ_env, subst1) (Rec prs)
-  = (tidy_env2, Rec prs')
-  where
-    prs'      = map (tidyTopPair unfold_env boot_exports tidy_env2) prs
-    subst2    = extendVarEnvList subst1 (map fst prs `zip` map fst prs')
-    tidy_env2 = (occ_env, subst2)
-    -- This is where we "tie the knot": tidy_env2 is fed into tidyTopPair
-
------------------------------------------------------------
-tidyTopPair :: UnfoldEnv
-            -> NameSet
-            -> TidyEnv  -- The TidyEnv is used to tidy the IdInfo
-                        -- It is knot-tied: don't look at it!
-            -> (Id, CoreExpr)   -- Binder and RHS before tidying
-            -> (Id, CoreExpr)
-        -- This function is the heart of Step 2
-        -- The rec_tidy_env is the one to use for the IdInfo
-        -- It's necessary because when we are dealing with a recursive
-        -- group, a variable late in the group might be mentioned
-        -- in the IdInfo of one early in the group
-
-tidyTopPair unfold_env boot_exports rhs_tidy_env (bndr, rhs)
-  = -- pprTrace "tidyTop" (ppr name' <+> ppr details <+> ppr rhs) $
-    (bndr1, rhs1)
-
-  where
-    Just (name',show_unfold) = lookupVarEnv unfold_env bndr
-    !cbv_bndr = tidyCbvInfoTop boot_exports bndr rhs
-    bndr1    = mkGlobalId details name' ty' idinfo'
-    details  = idDetails cbv_bndr -- Preserve the IdDetails
-    ty'      = tidyTopType (idType cbv_bndr)
-    rhs1     = tidyExpr rhs_tidy_env rhs
-    idinfo'  = tidyTopIdInfo rhs_tidy_env name' ty'
-                             rhs rhs1 (idInfo cbv_bndr) show_unfold
-
--- tidyTopIdInfo creates the final IdInfo for top-level
--- binders.  The delicate piece:
---
---  * Arity.  After CoreTidy, this arity must not change any more.
---      Indeed, CorePrep must eta expand where necessary to make
---      the manifest arity equal to the claimed arity.
---
-tidyTopIdInfo :: TidyEnv -> Name -> Type
-              -> CoreExpr -> CoreExpr -> IdInfo -> Bool -> IdInfo
-tidyTopIdInfo rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold
-  | not is_external     -- For internal Ids (not externally visible)
-  = vanillaIdInfo       -- we only need enough info for code generation
-                        -- Arity and strictness info are enough;
-                        --      c.f. GHC.Core.Tidy.tidyLetBndr
-        `setArityInfo`      arity
-        `setDmdSigInfo`     final_sig
-        `setCprSigInfo`     final_cpr
-        `setUnfoldingInfo`  minimal_unfold_info  -- See note [Preserve evaluatedness]
-                                                 -- in GHC.Core.Tidy
-
-  | otherwise           -- Externally-visible Ids get the whole lot
-  = vanillaIdInfo
-        `setArityInfo`       arity
-        `setDmdSigInfo`      final_sig
-        `setCprSigInfo`      final_cpr
-        `setOccInfo`         robust_occ_info
-        `setInlinePragInfo`  inlinePragInfo idinfo
-        `setUnfoldingInfo`   unfold_info
-                -- NB: we throw away the Rules
-                -- They have already been extracted by findExternalRules
-  where
-    is_external = isExternalName name
-
-    --------- OccInfo ------------
-    robust_occ_info = zapFragileOcc (occInfo idinfo)
-    -- It's important to keep loop-breaker information
-    -- when we are doing -fexpose-all-unfoldings
-
-    --------- Strictness ------------
-    mb_bot_str = exprBotStrictness_maybe orig_rhs
-
-    sig = dmdSigInfo idinfo
-    final_sig | not (isNopSig sig)
-              = warnPprTrace (_bottom_hidden sig) "tidyTopIdInfo" (ppr name) sig
-
-              -- No demand signature, so try a
-              -- cheap-and-cheerful bottom analyser
-              | Just (_, bot_str_sig, _) <- mb_bot_str
-              = bot_str_sig
-
-              -- No strictness info
-              | otherwise = nopSig
-
-    cpr = cprSigInfo idinfo
-    final_cpr | Just (_, _, bot_cpr_sig) <- mb_bot_str
-              = bot_cpr_sig
-              | otherwise
-              = cpr
-
-    _bottom_hidden id_sig
-      = case mb_bot_str of
-          Nothing            -> False
-          Just (arity, _, _) -> not (isDeadEndAppSig id_sig arity)
-
-    --------- Unfolding ------------
-    -- Force unfold_info (hence bangs), otherwise the old unfolding
-    -- is retained during code generation. See #22071
-
-    unf_info = realUnfoldingInfo idinfo
-    !minimal_unfold_info = trimUnfolding unf_info
-
-    !unfold_info | isCompulsoryUnfolding unf_info || show_unfold
-                 = tidyTopUnfolding rhs_tidy_env tidy_rhs unf_info
-                 | otherwise
-                 = minimal_unfold_info
-     -- NB: use `orig_rhs` not `tidy_rhs` in this call to mkFinalUnfolding
-     -- else you get a black hole (#22122). Reason: mkFinalUnfolding
-     -- looks at IdInfo, and that is knot-tied in tidyTopBind (the Rec case)
-
-    --------- Arity ------------
-    -- Usually the Id will have an accurate arity on it, because
-    -- the simplifier has just run, but not always.
-    -- One case I found was when the last thing the simplifier
-    -- did was to let-bind a non-atomic argument and then float
-    -- it to the top level. So it seems more robust just to
-    -- fix it here.
-    arity = exprArity orig_rhs `min` typeArity rhs_ty
-            -- orig_rhs: using tidy_rhs would make a black hole, since
-            --           exprArity uses the arities of Ids inside the rhs
-            --
-            -- typeArity: see Note [Arity invariants for bindings]
-            --            in GHC.Core.Opt.Arity
-
------------- Unfolding  --------------
-tidyTopUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding
-tidyTopUnfolding _ _ NoUnfolding   = NoUnfolding
-tidyTopUnfolding _ _ BootUnfolding = BootUnfolding
-tidyTopUnfolding _ _ (OtherCon {}) = evaldUnfolding
-
-tidyTopUnfolding tidy_env _ df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
-  = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }
-  where
-    (tidy_env', bndrs') = tidyBndrs tidy_env bndrs
-
-tidyTopUnfolding tidy_env tidy_rhs
-     unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src  })
-  = -- See Note [tidyTopUnfolding: avoiding black holes]
-    unf { uf_tmpl = tidy_unf_rhs }
-  where
-    tidy_unf_rhs | isStableSource src
-                 = tidyExpr tidy_env unf_rhs    -- Preserves OccInfo in unf_rhs
-                 | otherwise
-                 = occurAnalyseExpr tidy_rhs    -- Do occ-anal
-
-{- Note [tidyTopUnfolding: avoiding black holes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we are exposing all unfoldings we don't want to tidy the unfolding
-twice -- we just want to use the tidied RHS.  That tidied RHS itself
-contains fully-tidied Ids -- it is knot-tied.  So the uf_tmpl for the
-unfolding contains stuff we can't look at.  Now consider (#22112)
-   foo = foo
-If we freshly compute the uf_is_value field for foo's unfolding,
-we'll call `exprIsValue`, which will look at foo's unfolding!
-Whether or not the RHS is a value depends on whether foo is a value...
-black hole.
-
-In the Simplifier we deal with this by not giving `foo` an unfolding
-in its own RHS.  And we could do that here.  But it's qite nice
-to common everything up to a single Id for foo, used everywhere.
-
-And it's not too hard: simply leave the unfolding undisturbed, except
-tidy the uf_tmpl field. Hence tidyTopUnfolding does
-   unf { uf_tmpl = tidy_unf_rhs }
-
-Don't mess with uf_is_value, or guidance; in particular don't recompute
-them from tidy_unf_rhs.
-
-And (unlike tidyNestedUnfolding) don't deep-seq the new unfolding,
-because that'll cause a black hole (I /think/ because occurAnalyseExpr
-looks in IdInfo).
-
-
-************************************************************************
-*                                                                      *
-                  Old, dead, type-trimming code
-*                                                                      *
-************************************************************************
-
-We used to try to "trim off" the constructors of data types that are
-not exported, to reduce the size of interface files, at least without
--O.  But that is not always possible: see the old Note [When we can't
-trim types] below for exceptions.
-
-Then (#7445) I realised that the TH problem arises for any data type
-that we have deriving( Data ), because we can invoke
-   Language.Haskell.TH.Quote.dataToExpQ
-to get a TH Exp representation of a value built from that data type.
-You don't even need {-# LANGUAGE TemplateHaskell #-}.
-
-At this point I give up. The pain of trimming constructors just
-doesn't seem worth the gain.  So I've dumped all the code, and am just
-leaving it here at the end of the module in case something like this
-is ever resurrected.
-
-
-Note [When we can't trim types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The basic idea of type trimming is to export algebraic data types
-abstractly (without their data constructors) when compiling without
--O, unless of course they are explicitly exported by the user.
-
-We always export synonyms, because they can be mentioned in the type
-of an exported Id.  We could do a full dependency analysis starting
-from the explicit exports, but that's quite painful, and not done for
-now.
-
-But there are some times we can't do that, indicated by the 'no_trim_types' flag.
-
-First, Template Haskell.  Consider (#2386) this
-        module M(T, makeOne) where
-          data T = Yay String
-          makeOne = [| Yay "Yep" |]
-Notice that T is exported abstractly, but makeOne effectively exports it too!
-A module that splices in $(makeOne) will then look for a declaration of Yay,
-so it'd better be there.  Hence, brutally but simply, we switch off type
-constructor trimming if TH is enabled in this module.
-
-Second, data kinds.  Consider (#5912)
-     {-# LANGUAGE DataKinds #-}
-     module M() where
-     data UnaryTypeC a = UnaryDataC a
-     type Bug = 'UnaryDataC
-We always export synonyms, so Bug is exposed, and that means that
-UnaryTypeC must be too, even though it's not explicitly exported.  In
-effect, DataKinds means that we'd need to do a full dependency analysis
-to see what data constructors are mentioned.  But we don't do that yet.
-
-In these two cases we just switch off type trimming altogether.
-
-mustExposeTyCon :: Bool         -- Type-trimming flag
-                -> NameSet      -- Exports
-                -> TyCon        -- The tycon
-                -> Bool         -- Can its rep be hidden?
--- We are compiling without -O, and thus trying to write as little as
--- possible into the interface file.  But we must expose the details of
--- any data types whose constructors or fields are exported
-mustExposeTyCon no_trim_types exports tc
-  | no_trim_types               -- See Note [When we can't trim types]
-  = True
-
-  | not (isAlgTyCon tc)         -- Always expose synonyms (otherwise we'd have to
-                                -- figure out whether it was mentioned in the type
-                                -- of any other exported thing)
-  = True
-
-  | isEnumerationTyCon tc       -- For an enumeration, exposing the constructors
-  = True                        -- won't lead to the need for further exposure
-
-  | isFamilyTyCon tc            -- Open type family
-  = True
-
-  -- Below here we just have data/newtype decls or family instances
-
-  | null data_cons              -- Ditto if there are no data constructors
-  = True                        -- (NB: empty data types do not count as enumerations
-                                -- see Note [Enumeration types] in GHC.Core.TyCon
-
-  | any exported_con data_cons  -- Expose rep if any datacon or field is exported
-  = True
-
-  | isNewTyCon tc && isFFITy (snd (newTyConRhs tc))
-  = True   -- Expose the rep for newtypes if the rep is an FFI type.
-           -- For a very annoying reason.  'Foreign import' is meant to
-           -- be able to look through newtypes transparently, but it
-           -- can only do that if it can "see" the newtype representation
-
-  | otherwise
-  = False
-  where
-    data_cons = tyConDataCons tc
-    exported_con con = any (`elemNameSet` exports)
-                           (dataConName con : dataConFieldLabels con)
--}
-
diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
deleted file mode 100644
--- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs
+++ /dev/null
@@ -1,282 +0,0 @@
-{-# LANGUAGE ViewPatterns #-}
-
--- | Code generation for the Static Pointer Table
---
--- (c) 2014 I/O Tweag
---
--- Each module that uses 'static' keyword declares an initialization function of
--- the form hs_spt_init_\<module>() which is emitted into the _stub.c file and
--- annotated with __attribute__((constructor)) so that it gets executed at
--- startup time.
---
--- The function's purpose is to call hs_spt_insert to insert the static
--- pointers of this module in the hashtable of the RTS, and it looks something
--- like this:
---
--- > static void hs_hpc_init_Main(void) __attribute__((constructor));
--- > static void hs_hpc_init_Main(void) {
--- >
--- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
--- >   extern StgPtr Main_r2wb_closure;
--- >   hs_spt_insert(k0, &Main_r2wb_closure);
--- >
--- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
--- >   extern StgPtr Main_r2wc_closure;
--- >   hs_spt_insert(k1, &Main_r2wc_closure);
--- >
--- > }
---
--- where the constants are fingerprints produced from the static forms.
---
--- The linker must find the definitions matching the @extern StgPtr <name>@
--- declarations. For this to work, the identifiers of static pointers need to be
--- exported. This is done in 'GHC.Core.Opt.SetLevels.newLvlVar'.
---
--- There is also a finalization function for the time when the module is
--- unloaded.
---
--- > static void hs_hpc_fini_Main(void) __attribute__((destructor));
--- > static void hs_hpc_fini_Main(void) {
--- >
--- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
--- >   hs_spt_remove(k0);
--- >
--- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
--- >   hs_spt_remove(k1);
--- >
--- > }
---
-
-module GHC.Iface.Tidy.StaticPtrTable
-  ( sptCreateStaticBinds
-  , sptModuleInitCode
-  , StaticPtrOpts (..)
-  )
-where
-
-{- Note [Grand plan for static forms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Static forms go through the compilation phases as follows.
-Here is a running example:
-
-   f x = let k = map toUpper
-         in ...(static k)...
-
-* The renamer looks for out-of-scope names in the body of the static
-  form, as always. If all names are in scope, the free variables of the
-  body are stored in AST at the location of the static form.
-
-* The typechecker verifies that all free variables occurring in the
-  static form are floatable to top level (see Note [Meaning of
-  IdBindingInfo] in GHC.Tc.Types).  In our example, 'k' is floatable.
-  Even though it is bound in a nested let, we are fine.
-
-* The desugarer replaces the static form with an application of the
-  function 'makeStatic' (defined in module GHC.StaticPtr.Internal of
-  base).  So we get
-
-   f x = let k = map toUpper
-         in ...fromStaticPtr (makeStatic location k)...
-
-* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic'
-  to the top level. Thus the FloatOut pass is always executed, even when
-  optimizations are disabled.  So we get
-
-   k = map toUpper
-   static_ptr = makeStatic location k
-   f x = ...fromStaticPtr static_ptr...
-
-  The FloatOut pass is careful to produce an /exported/ Id for a floated
-  'makeStatic' call, so the binding is not removed or inlined by the
-  simplifier.
-  E.g. the code for `f` above might look like
-
-    static_ptr = makeStatic location k
-    f x = ...(case static_ptr of ...)...
-
-  which might be simplified to
-
-    f x = ...(case makeStatic location k of ...)...
-
-  BUT the top-level binding for static_ptr must remain, so that it can be
-  collected to populate the Static Pointer Table.
-
-  Making the binding exported also has a necessary effect during the
-  CoreTidy pass.
-
-* The CoreTidy pass replaces all bindings of the form
-
-  b = /\ ... -> makeStatic location value
-
-  with
-
-  b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value
-
-  where a distinct key is generated for each binding.
-
-* If we are compiling to object code we insert a C stub (generated by
-  sptModuleInitCode) into the final object which runs when the module is loaded,
-  inserting the static forms defined by the module into the RTS's static pointer
-  table.
-
-* If we are compiling for the byte-code interpreter, we instead explicitly add
-  the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter
-  process' SPT table using the addSptEntry interpreter message. This happens
-  in upsweep after we have compiled the module (see GHC.Driver.Make.upsweep').
--}
-
-import GHC.Prelude
-import GHC.Platform
-
-import GHC.Core
-import GHC.Core.Utils (collectMakeStaticArgs)
-import GHC.Core.DataCon
-import GHC.Core.Make (mkStringExprFSWith,MkStringIds(..))
-import GHC.Core.Type
-
-import GHC.Cmm.CLabel
-
-import GHC.Unit.Module
-import GHC.Utils.Outputable as Outputable
-
-import GHC.Linker.Types
-
-import GHC.Types.Id
-import GHC.Types.ForeignStubs
-import GHC.Data.Maybe
-import GHC.Data.FastString
-
-import Control.Monad.Trans.State.Strict
-import Data.List (intercalate)
-import GHC.Fingerprint
-
-data StaticPtrOpts = StaticPtrOpts
-  { opt_platform                :: !Platform    -- ^ Target platform
-  , opt_gen_cstub               :: !Bool        -- ^ Generate CStub or not
-  , opt_mk_string               :: !MkStringIds -- ^ Ids for `unpackCString[Utf8]#`
-  , opt_static_ptr_info_datacon :: !DataCon          -- ^ `StaticPtrInfo` datacon
-  , opt_static_ptr_datacon      :: !DataCon          -- ^ `StaticPtr` datacon
-  }
-
--- | Replaces all bindings of the form
---
--- > b = /\ ... -> makeStatic location value
---
---  with
---
--- > b = /\ ... ->
--- >   StaticPtr key (StaticPtrInfo "pkg key" "module" location) value
---
---  where a distinct key is generated for each binding.
---
--- It also yields the C stub that inserts these bindings into the static
--- pointer table.
-sptCreateStaticBinds :: StaticPtrOpts -> Module -> CoreProgram -> IO ([SptEntry], Maybe CStub, CoreProgram)
-sptCreateStaticBinds opts this_mod binds = do
-      (fps, binds') <- evalStateT (go [] [] binds) 0
-      let cstub
-            | opt_gen_cstub opts = Just (sptModuleInitCode (opt_platform opts) this_mod fps)
-            | otherwise          = Nothing
-      return (fps, cstub, binds')
-  where
-    go fps bs xs = case xs of
-      []        -> return (reverse fps, reverse bs)
-      bnd : xs' -> do
-        (fps', bnd') <- replaceStaticBind bnd
-        go (reverse fps' ++ fps) (bnd' : bs) xs'
-
-    -- Generates keys and replaces 'makeStatic' with 'StaticPtr'.
-    --
-    -- The 'Int' state is used to produce a different key for each binding.
-    replaceStaticBind :: CoreBind
-                      -> StateT Int IO ([SptEntry], CoreBind)
-    replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e
-                                        return (maybeToList mfp, NonRec b' e')
-    replaceStaticBind (Rec rbs) = do
-      (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs
-      return (catMaybes mfps, Rec rbs')
-
-    replaceStatic :: Id -> CoreExpr
-                  -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr))
-    replaceStatic b e@(collectTyBinders -> (tvs, e0)) =
-      case collectMakeStaticArgs e0 of
-        Nothing      -> return (Nothing, (b, e))
-        Just (_, t, info, arg) -> do
-          (fp, e') <- mkStaticBind t info arg
-          return (Just (SptEntry b fp), (b, foldr Lam e' tvs))
-
-    mkStaticBind :: Type -> CoreExpr -> CoreExpr
-                 -> StateT Int IO (Fingerprint, CoreExpr)
-    mkStaticBind t srcLoc e = do
-      i <- get
-      put (i + 1)
-      let staticPtrInfoDataCon = opt_static_ptr_info_datacon opts
-      let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i
-      let mk_string_fs = mkStringExprFSWith (opt_mk_string opts)
-      let info = mkConApp staticPtrInfoDataCon
-                  [ mk_string_fs $ unitFS $ moduleUnit this_mod
-                  , mk_string_fs $ moduleNameFS $ moduleName this_mod
-                  , srcLoc
-                  ]
-
-      let staticPtrDataCon = opt_static_ptr_datacon opts
-      return (fp, mkConApp staticPtrDataCon
-                               [ Type t
-                               , mkWord64LitWord64 w0
-                               , mkWord64LitWord64 w1
-                               , info
-                               , e ])
-
-    mkStaticPtrFingerprint :: Int -> Fingerprint
-    mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"
-        [ unitString $ moduleUnit this_mod
-        , moduleNameString $ moduleName this_mod
-        , show n
-        ]
-
--- | @sptModuleInitCode module fps@ is a C stub to insert the static entries
--- of @module@ into the static pointer table.
---
--- @fps@ is a list associating each binding corresponding to a static entry with
--- its fingerprint.
-sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub
-sptModuleInitCode platform this_mod entries
-    -- no CStub if there is no entry
-  | [] <- entries                           = mempty
-    -- no CStub for the JS backend: it deals with it directly during JS code
-    -- generation
-  | ArchJavaScript <- platformArch platform = mempty
-  | otherwise =
-    initializerCStub platform init_fn_nm empty init_fn_body `mappend`
-    finalizerCStub platform fini_fn_nm empty fini_fn_body
-  where
-    init_fn_nm = mkInitializerStubLabel this_mod (fsLit "spt")
-    init_fn_body = vcat
-        [  text "static StgWord64 k" <> int i <> text "[2] = "
-           <> pprFingerprint fp <> semi
-        $$ text "extern StgPtr "
-           <> (pprCLabel platform $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
-        $$ text "hs_spt_insert" <> parens
-             (hcat $ punctuate comma
-                [ char 'k' <> int i
-                , char '&' <> pprCLabel platform (mkClosureLabel (idName n) (idCafInfo n))
-                ]
-             )
-        <> semi
-        |  (i, SptEntry n fp) <- zip [0..] entries
-        ]
-
-    fini_fn_nm = mkFinalizerStubLabel this_mod (fsLit "spt")
-    fini_fn_body = vcat
-        [  text "StgWord64 k" <> int i <> text "[2] = "
-           <> pprFingerprint fp <> semi
-        $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
-        | (i, (SptEntry _ fp)) <- zip [0..] entries
-        ]
-
-    pprFingerprint :: Fingerprint -> SDoc
-    pprFingerprint (Fingerprint w1 w2) =
-      braces $ hcat $ punctuate comma
-                 [ integer (fromIntegral w1) <> text "ULL"
-                 , integer (fromIntegral w2) <> text "ULL"
-                 ]
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
deleted file mode 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ /dev/null
@@ -1,2113 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-Type checking of type signatures in interface files
--}
-
-
-{-# LANGUAGE NondecreasingIndentation #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-{-# LANGUAGE TupleSections #-}
-
-module GHC.IfaceToCore (
-        tcLookupImported_maybe,
-        importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
-        typecheckWholeCoreBindings,
-        typecheckIfacesForMerging,
-        typecheckIfaceForInstantiate,
-        tcIfaceDecl, tcIfaceDecls,
-        tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
-        tcIfaceAnnotations, tcIfaceCompleteMatches,
-        tcIfaceExpr,    -- Desired by HERMIT (#7683)
-        tcIfaceGlobal,
-        tcIfaceOneShot, tcTopIfaceBindings,
- ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Env
-import GHC.Driver.Session
-import GHC.Driver.Config.Core.Lint ( initLintConfig )
-
-import GHC.Builtin.Types.Literals(typeNatCoAxiomRules)
-import GHC.Builtin.Types
-
-import GHC.Iface.Syntax
-import GHC.Iface.Load
-import GHC.Iface.Env
-
-import GHC.StgToCmm.Types
-import GHC.Runtime.Heap.Layout
-
-import GHC.Tc.Errors.Types
-import GHC.Tc.TyCl.Build
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.TcType
-
-import GHC.Core.Type
-import GHC.Core.Coercion
-import GHC.Core.Coercion.Axiom
-import GHC.Core.FVs
-import GHC.Core.TyCo.Rep    -- needs to build types & coercions in a knot
-import GHC.Core.TyCo.Subst ( substTyCoVars )
-import GHC.Core.InstEnv
-import GHC.Core.FamInstEnv
-import GHC.Core
-import GHC.Core.RoughMap( RoughMatchTc(..) )
-import GHC.Core.Utils
-import GHC.Core.Unfold( calcUnfoldingGuidance )
-import GHC.Core.Unfold.Make
-import GHC.Core.Lint
-import GHC.Core.Make
-import GHC.Core.Class
-import GHC.Core.TyCon
-import GHC.Core.ConLike
-import GHC.Core.DataCon
-import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
-import GHC.Core.Ppr
-
-import GHC.Unit.Env
-import GHC.Unit.External
-import GHC.Unit.Module
-import GHC.Unit.Module.ModDetails
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Home.ModInfo
-
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Constants (debugIsOn)
-import GHC.Utils.Logger
-
-import GHC.Data.Bag
-import GHC.Data.Maybe
-import GHC.Data.FastString
-import GHC.Data.List.SetOps
-
-import GHC.Types.Annotations
-import GHC.Types.SourceFile
-import GHC.Types.SourceText
-import GHC.Types.Basic hiding ( SuccessFlag(..) )
-import GHC.Types.CompleteMatch
-import GHC.Types.SrcLoc
-import GHC.Types.TypeEnv
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.DSet ( mkUniqDSet )
-import GHC.Types.Unique.Set ( nonDetEltsUniqSet )
-import GHC.Types.Unique.Supply
-import GHC.Types.Demand( isDeadEndSig )
-import GHC.Types.Literal
-import GHC.Types.Var as Var
-import GHC.Types.Var.Set
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.Name.Set
-import GHC.Types.Id
-import GHC.Types.Id.Make
-import GHC.Types.Id.Info
-import GHC.Types.Tickish
-import GHC.Types.TyThing
-import GHC.Types.Error
-
-import GHC.Fingerprint
-import qualified GHC.Data.BooleanFormula as BF
-
-import Control.Monad
-import GHC.Parser.Annotation
-import GHC.Driver.Env.KnotVars
-import GHC.Unit.Module.WholeCoreBindings
-import Data.IORef
-import Data.Foldable
-
-{-
-This module takes
-
-        IfaceDecl -> TyThing
-        IfaceType -> Type
-        etc
-
-An IfaceDecl is populated with RdrNames, and these are not renamed to
-Names before typechecking, because there should be no scope errors etc.
-
-        -- For (b) consider: f = \$(...h....)
-        -- where h is imported, and calls f via an hi-boot file.
-        -- This is bad!  But it is not seen as a staging error, because h
-        -- is indeed imported.  We don't want the type-checker to black-hole
-        -- when simplifying and compiling the splice!
-        --
-        -- Simple solution: discard any unfolding that mentions a variable
-        -- bound in this module (and hence not yet processed).
-        -- The discarding happens when forkM finds a type error.
-
-
-************************************************************************
-*                                                                      *
-                Type-checking a complete interface
-*                                                                      *
-************************************************************************
-
-Suppose we discover we don't need to recompile.  Then we must type
-check the old interface file.  This is a bit different to the
-incremental type checking we do as we suck in interface files.  Instead
-we do things similarly as when we are typechecking source decls: we
-bring into scope the type envt for the interface all at once, using a
-knot.  Remember, the decls aren't necessarily in dependency order --
-and even if they were, the type decls might be mutually recursive.
-
-Note [Knot-tying typecheckIface]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we are typechecking an interface A.hi, and we come across
-a Name for another entity defined in A.hi.  How do we get the
-'TyCon', in this case?  There are three cases:
-
-    1) tcHiBootIface in GHC.IfaceToCore: We're typechecking an
-    hi-boot file in preparation of checking if the hs file we're
-    building is compatible.  In this case, we want all of the
-    internal TyCons to MATCH the ones that we just constructed
-    during typechecking: the knot is thus tied through if_rec_types.
-
-    2) rehydrate in GHC.Driver.Make: We are rehydrating a
-    mutually recursive cluster of hi files, in order to ensure
-    that all of the references refer to each other correctly.
-    In this case, the knot is tied through the HPT passed in,
-    which contains all of the interfaces we are in the process
-    of typechecking.
-
-    3) genModDetails in GHC.Driver.Main: We are typechecking an
-    old interface to generate the ModDetails.  In this case,
-    we do the same thing as (2) and pass in an HPT with
-    the HomeModInfo being generated to tie knots.
-
-The upshot is that the CLIENT of this function is responsible
-for making sure that the knot is tied correctly.  If you don't,
-then you'll get a message saying that we couldn't load the
-declaration you wanted.
-
-BTW, in one-shot mode we never call typecheckIface; instead,
-loadInterface handles type-checking interface.  In that case,
-knots are tied through the EPS.  No problem!
--}
-
--- Clients of this function be careful, see Note [Knot-tying typecheckIface]
-typecheckIface :: ModIface      -- Get the decls from here
-               -> IfG ModDetails
-typecheckIface iface
-  = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do
-        {       -- Get the right set of decls and rules.  If we are compiling without -O
-                -- we discard pragmas before typechecking, so that we don't "see"
-                -- information that we shouldn't.  From a versioning point of view
-                -- It's not actually *wrong* to do so, but in fact GHCi is unable
-                -- to handle unboxed tuples, so it must not see unfoldings.
-          ignore_prags <- goptM Opt_IgnoreInterfacePragmas
-
-                -- Typecheck the decls.  This is done lazily, so that the knot-tying
-                -- within this single module works out right.  It's the callers
-                -- job to make sure the knot is tied.
-        ; names_w_things <- tcIfaceDecls ignore_prags (mi_decls iface)
-        ; let type_env = mkNameEnv names_w_things
-
-                -- Now do those rules, instances and annotations
-        ; insts     <- mapM tcIfaceInst (mi_insts iface)
-        ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
-        ; rules     <- tcIfaceRules ignore_prags (mi_rules iface)
-        ; anns      <- tcIfaceAnnotations (mi_anns iface)
-
-                -- Exports
-        ; exports <- ifaceExportNames (mi_exports iface)
-
-                -- Complete Sigs
-        ; complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
-
-                -- Finished
-        ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
-                         -- Careful! If we tug on the TyThing thunks too early
-                         -- we'll infinite loop with hs-boot.  See #10083 for
-                         -- an example where this would cause non-termination.
-                         text "Type envt:" <+> ppr (map fst names_w_things)])
-        ; return $ ModDetails { md_types     = type_env
-                              , md_insts     = mkInstEnv insts
-                              , md_fam_insts = fam_insts
-                              , md_rules     = rules
-                              , md_anns      = anns
-                              , md_exports   = exports
-                              , md_complete_matches = complete_matches
-                              }
-    }
-
-typecheckWholeCoreBindings :: IORef TypeEnv ->  WholeCoreBindings -> IfG [CoreBind]
-typecheckWholeCoreBindings type_var (WholeCoreBindings tidy_bindings this_mod _) =
-  initIfaceLcl this_mod (text "typecheckWholeCoreBindings") NotBoot $ do
-    tcTopIfaceBindings type_var tidy_bindings
-
-
-{-
-************************************************************************
-*                                                                      *
-                Typechecking for merging
-*                                                                      *
-************************************************************************
--}
-
--- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type)
-isAbstractIfaceDecl :: IfaceDecl -> Bool
-isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon {} } = True
-isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True
-isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True
-isAbstractIfaceDecl _ = False
-
-ifMaybeRoles :: IfaceDecl -> Maybe [Role]
-ifMaybeRoles IfaceData    { ifRoles = rs } = Just rs
-ifMaybeRoles IfaceSynonym { ifRoles = rs } = Just rs
-ifMaybeRoles IfaceClass   { ifRoles = rs } = Just rs
-ifMaybeRoles _ = Nothing
-
--- | Merge two 'IfaceDecl's together, preferring a non-abstract one.  If
--- both are non-abstract we pick one arbitrarily (and check for consistency
--- later.)
-mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl
-mergeIfaceDecl d1 d2
-    | isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1
-    | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2
-    | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1
-    , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2
-    = let ops = nonDetNameEnvElts $
-                  plusNameEnv_C mergeIfaceClassOp
-                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])
-                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])
-      in d1 { ifBody = (ifBody d1) {
-                ifSigs  = ops,
-                ifMinDef = BF.mkOr [noLocA bf1, noLocA bf2]
-                }
-            } `withRolesFrom` d2
-    -- It doesn't matter; we'll check for consistency later when
-    -- we merge, see 'mergeSignatures'
-    | otherwise              = d1 `withRolesFrom` d2
-
--- Note [Role merging]
--- ~~~~~~~~~~~~~~~~~~~
--- First, why might it be necessary to do a non-trivial role
--- merge?  It may rescue a merge that might otherwise fail:
---
---      signature A where
---          type role T nominal representational
---          data T a b
---
---      signature A where
---          type role T representational nominal
---          data T a b
---
--- A module that defines T as representational in both arguments
--- would successfully fill both signatures, so it would be better
--- if we merged the roles of these types in some nontrivial
--- way.
---
--- However, we have to be very careful about how we go about
--- doing this, because role subtyping is *conditional* on
--- the supertype being NOT representationally injective, e.g.,
--- if we have instead:
---
---      signature A where
---          type role T nominal representational
---          data T a b = T a b
---
---      signature A where
---          type role T representational nominal
---          data T a b = T a b
---
--- Should we merge the definitions of T so that the roles are R/R (or N/N)?
--- Absolutely not: neither resulting type is a subtype of the original
--- types (see Note [Role subtyping]), because data is not representationally
--- injective.
---
--- Thus, merging only occurs when BOTH TyCons in question are
--- representationally injective.  If they're not, no merge.
-
-withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl
-d1 `withRolesFrom` d2
-    | Just roles1 <- ifMaybeRoles d1
-    , Just roles2 <- ifMaybeRoles d2
-    , not (isRepInjectiveIfaceDecl d1 || isRepInjectiveIfaceDecl d2)
-    = d1 { ifRoles = mergeRoles roles1 roles2 }
-    | otherwise = d1
-  where
-    mergeRoles roles1 roles2 = zipWithEqual "mergeRoles" max roles1 roles2
-
-isRepInjectiveIfaceDecl :: IfaceDecl -> Bool
-isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon{} } = True
-isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True
-isRepInjectiveIfaceDecl _ = False
-
-mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp
-mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1
-mergeIfaceClassOp _ op2 = op2
-
--- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'.
-mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl
-mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl
-
--- | This is a very interesting function.  Like typecheckIface, we want
--- to type check an interface file into a ModDetails.  However, the use-case
--- for these ModDetails is different: we want to compare all of the
--- ModDetails to ensure they define compatible declarations, and then
--- merge them together.  So in particular, we have to take a different
--- strategy for knot-tying: we first speculatively merge the declarations
--- to get the "base" truth for what we believe the types will be
--- (this is "type computation.")  Then we read everything in relative
--- to this truth and check for compatibility.
---
--- During the merge process, we may need to nondeterministically
--- pick a particular declaration to use, if multiple signatures define
--- the declaration ('mergeIfaceDecl').  If, for all choices, there
--- are no type synonym cycles in the resulting merged graph, then
--- we can show that our choice cannot matter. Consider the
--- set of entities which the declarations depend on: by assumption
--- of acyclicity, we can assume that these have already been shown to be equal
--- to each other (otherwise merging will fail).  Then it must
--- be the case that all candidate declarations here are type-equal
--- (the choice doesn't matter) or there is an inequality (in which
--- case merging will fail.)
---
--- Unfortunately, the choice can matter if there is a cycle.  Consider the
--- following merge:
---
---      signature H where { type A = C;  type B = A; data C      }
---      signature H where { type A = (); data B;     type C = B  }
---
--- If we pick @type A = C@ as our representative, there will be
--- a cycle and merging will fail. But if we pick @type A = ()@ as
--- our representative, no cycle occurs, and we instead conclude
--- that all of the types are unit.  So it seems that we either
--- (a) need a stronger acyclicity check which considers *all*
--- possible choices from a merge, or (b) we must find a selection
--- of declarations which is acyclic, and show that this is always
--- the "best" choice we could have made (ezyang conjectures this
--- is the case but does not have a proof).  For now this is
--- not implemented.
---
--- It's worth noting that at the moment, a data constructor and a
--- type synonym are never compatible.  Consider:
---
---      signature H where { type Int=C;         type B = Int; data C = Int}
---      signature H where { export Prelude.Int; data B;       type C = B; }
---
--- This will be rejected, because the reexported Int in the second
--- signature (a proper data type) is never considered equal to a
--- type synonym.  Perhaps this should be relaxed, where a type synonym
--- in a signature is considered implemented by a data type declaration
--- which matches the reference of the type synonym.
-typecheckIfacesForMerging :: Module -> [ModIface] -> (KnotVars (IORef TypeEnv)) -> IfM lcl (TypeEnv, [ModDetails])
-typecheckIfacesForMerging mod ifaces tc_env_vars =
-  -- cannot be boot (False)
-  initIfaceLcl mod (text "typecheckIfacesForMerging") NotBoot $ do
-    ignore_prags <- goptM Opt_IgnoreInterfacePragmas
-    -- Build the initial environment
-    -- NB: Don't include dfuns here, because we don't want to
-    -- serialize them out.  See Note [rnIfaceNeverExported] in GHC.Iface.Rename
-    -- NB: But coercions are OK, because they will have the right OccName.
-    let mk_decl_env decls
-            = mkOccEnv [ (getOccName decl, decl)
-                       | decl <- decls
-                       , case decl of
-                            IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns
-                            _ -> True ]
-        decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces
-                        :: [OccEnv IfaceDecl]
-        decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs
-                        ::  OccEnv IfaceDecl
-    -- TODO: change tcIfaceDecls to accept w/o Fingerprint
-    names_w_things <- tcIfaceDecls ignore_prags (map (\x -> (fingerprint0, x))
-                                                  (nonDetOccEnvElts decl_env))
-    let global_type_env = mkNameEnv names_w_things
-    case lookupKnotVars tc_env_vars mod of
-      Just tc_env_var -> writeMutVar tc_env_var global_type_env
-      Nothing -> return ()
-
-    -- OK, now typecheck each ModIface using this environment
-    details <- forM ifaces $ \iface -> do
-        -- See Note [Resolving never-exported Names] in GHC.IfaceToCore
-        type_env <- fixM $ \type_env ->
-            setImplicitEnvM type_env $ do
-                decls <- tcIfaceDecls ignore_prags (mi_decls iface)
-                return (mkNameEnv decls)
-        -- But note that we use this type_env to typecheck references to DFun
-        -- in 'IfaceInst'
-        setImplicitEnvM type_env $ do
-        insts     <- mapM tcIfaceInst (mi_insts iface)
-        fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
-        rules     <- tcIfaceRules ignore_prags (mi_rules iface)
-        anns      <- tcIfaceAnnotations (mi_anns iface)
-        exports   <- ifaceExportNames (mi_exports iface)
-        complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
-        return $ ModDetails { md_types     = type_env
-                            , md_insts     = mkInstEnv insts
-                            , md_fam_insts = fam_insts
-                            , md_rules     = rules
-                            , md_anns      = anns
-                            , md_exports   = exports
-                            , md_complete_matches = complete_matches
-                            }
-    return (global_type_env, details)
-
--- | Typecheck a signature 'ModIface' under the assumption that we have
--- instantiated it under some implementation (recorded in 'mi_semantic_module')
--- and want to check if the implementation fills the signature.
---
--- This needs to operate slightly differently than 'typecheckIface'
--- because (1) we have a 'NameShape', from the exports of the
--- implementing module, which we will use to give our top-level
--- declarations the correct 'Name's even when the implementor
--- provided them with a reexport, and (2) we have to deal with
--- DFun silliness (see Note [rnIfaceNeverExported])
-typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails
-typecheckIfaceForInstantiate nsubst iface =
-  initIfaceLclWithSubst (mi_semantic_module iface)
-                        (text "typecheckIfaceForInstantiate")
-                        (mi_boot iface) nsubst $ do
-    ignore_prags <- goptM Opt_IgnoreInterfacePragmas
-    -- See Note [Resolving never-exported Names] in GHC.IfaceToCore
-    type_env <- fixM $ \type_env ->
-        setImplicitEnvM type_env $ do
-            decls     <- tcIfaceDecls ignore_prags (mi_decls iface)
-            return (mkNameEnv decls)
-    -- See Note [rnIfaceNeverExported]
-    setImplicitEnvM type_env $ do
-    insts     <- mapM tcIfaceInst (mi_insts iface)
-    fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
-    rules     <- tcIfaceRules ignore_prags (mi_rules iface)
-    anns      <- tcIfaceAnnotations (mi_anns iface)
-    exports   <- ifaceExportNames (mi_exports iface)
-    complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface)
-    return $ ModDetails { md_types     = type_env
-                        , md_insts     = mkInstEnv insts
-                        , md_fam_insts = fam_insts
-                        , md_rules     = rules
-                        , md_anns      = anns
-                        , md_exports   = exports
-                        , md_complete_matches = complete_matches
-                        }
-
--- Note [Resolving never-exported Names]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- For the high-level overview, see
--- Note [Handling never-exported TyThings under Backpack]
---
--- As described in 'typecheckIfacesForMerging', the splendid innovation
--- of signature merging is to rewrite all Names in each of the signatures
--- we are merging together to a pre-merged structure; this is the key
--- ingredient that lets us solve some problems when merging type
--- synonyms.
---
--- However, when a 'Name' refers to a NON-exported entity, as is the
--- case with the DFun of a ClsInst, or a CoAxiom of a type family,
--- this strategy causes problems: if we pick one and rewrite all
--- references to a shared 'Name', we will accidentally fail to check
--- if the DFun or CoAxioms are compatible, as they will never be
--- checked--only exported entities are checked for compatibility,
--- and a non-exported TyThing is checked WHEN we are checking the
--- ClsInst or type family for compatibility in checkBootDeclM.
--- By virtue of the fact that everything's been pointed to the merged
--- declaration, you'll never notice there's a difference even if there
--- is one.
---
--- Fortunately, there are only a few places in the interface declarations
--- where this can occur, so we replace those calls with 'tcIfaceImplicit',
--- which will consult a local TypeEnv that records any never-exported
--- TyThings which we should wire up with.
---
--- Note that we actually knot-tie this local TypeEnv (the 'fixM'), because a
--- type family can refer to a coercion axiom, all of which are done in one go
--- when we typecheck 'mi_decls'.  An alternate strategy would be to typecheck
--- coercions first before type families, but that seemed more fragile.
---
-
-{-
-************************************************************************
-*                                                                      *
-                Type and class declarations
-*                                                                      *
-************************************************************************
--}
-
-tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo
--- Load the hi-boot iface for the module being compiled,
--- if it indeed exists in the transitive closure of imports
--- Return the ModDetails; Nothing if no hi-boot iface
-tcHiBootIface hsc_src mod
-  | HsBootFile <- hsc_src            -- Already compiling a hs-boot file
-  = return NoSelfBoot
-  | otherwise
-  = do  { traceIf (text "loadHiBootInterface" <+> ppr mod)
-
-        ; mode <- getGhcMode
-        ; if not (isOneShot mode)
-                -- In --make and interactive mode, if this module has an hs-boot file
-                -- we'll have compiled it already, and it'll be in the HPT
-                --
-                -- We check whether the interface is a *boot* interface.
-                -- It can happen (when using GHC from Visual Studio) that we
-                -- compile a module in TypecheckOnly mode, with a stable,
-                -- fully-populated HPT.  In that case the boot interface isn't there
-                -- (it's been replaced by the mother module) so we can't check it.
-                -- And that's fine, because if M's ModInfo is in the HPT, then
-                -- it's been compiled once, and we don't need to check the boot iface
-          then do { (_, hug) <- getEpsAndHug
-                 ; case lookupHugByModule mod hug  of
-                      Just info | mi_boot (hm_iface info) == IsBoot
-                                -> mkSelfBootInfo (hm_iface info) (hm_details info)
-                      _ -> return NoSelfBoot }
-          else do
-
-        -- OK, so we're in one-shot mode.
-        -- Re #9245, we always check if there is an hi-boot interface
-        -- to check consistency against, rather than just when we notice
-        -- that an hi-boot is necessary due to a circular import.
-        { hsc_env <- getTopEnv
-        ; read_result <- liftIO $ findAndReadIface hsc_env
-                                need (fst (getModuleInstantiation mod)) mod
-                                IsBoot  -- Hi-boot file
-
-        ; case read_result of {
-            Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface
-                                           ; mkSelfBootInfo iface tc_iface } ;
-            Failed err               ->
-
-        -- There was no hi-boot file. But if there is circularity in
-        -- the module graph, there really should have been one.
-        -- Since we've read all the direct imports by now,
-        -- eps_is_boot will record if any of our imports mention the
-        -- current module, which either means a module loop (not
-        -- a SOURCE import) or that our hi-boot file has mysteriously
-        -- disappeared.
-    do  { eps <- getEps
-        ; case lookupInstalledModuleEnv (eps_is_boot eps) (toUnitId <$> mod) of
-            -- The typical case
-            Nothing -> return NoSelfBoot
-            -- error cases
-            Just (GWIB { gwib_isBoot = is_boot }) -> case is_boot of
-              IsBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints (elaborate err))
-              -- The hi-boot file has mysteriously disappeared.
-              NotBoot -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints moduleLoop)
-              -- Someone below us imported us!
-              -- This is a loop with no hi-boot in the way
-    }}}}
-  where
-    need = text "Need the hi-boot interface for" <+> ppr mod
-                 <+> text "to compare against the Real Thing"
-
-    moduleLoop = text "Circular imports: module" <+> quotes (ppr mod)
-                     <+> text "depends on itself"
-
-    elaborate err = hang (text "Could not find hi-boot interface for" <+>
-                          quotes (ppr mod) <> colon) 4 err
-
-
-mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo
-mkSelfBootInfo iface mds
-  = do -- NB: This is computed DIRECTLY from the ModIface rather
-       -- than from the ModDetails, so that we can query 'sb_tcs'
-       -- WITHOUT forcing the contents of the interface.
-       let tcs = map ifName
-                 . filter isIfaceTyCon
-                 . map snd
-                 $ mi_decls iface
-       return $ SelfBoot { sb_mds = mds
-                         , sb_tcs = mkNameSet tcs }
-  where
-    -- Returns @True@ if, when you call 'tcIfaceDecl' on
-    -- this 'IfaceDecl', an ATyCon would be returned.
-    -- NB: This code assumes that a TyCon cannot be implicit.
-    isIfaceTyCon IfaceId{}      = False
-    isIfaceTyCon IfaceData{}    = True
-    isIfaceTyCon IfaceSynonym{} = True
-    isIfaceTyCon IfaceFamily{}  = True
-    isIfaceTyCon IfaceClass{}   = True
-    isIfaceTyCon IfaceAxiom{}   = False
-    isIfaceTyCon IfacePatSyn{}  = False
-
-{-
-************************************************************************
-*                                                                      *
-                Type and class declarations
-*                                                                      *
-************************************************************************
-
-When typechecking a data type decl, we *lazily* (via forkM) typecheck
-the constructor argument types.  This is in the hope that we may never
-poke on those argument types, and hence may never need to load the
-interface files for types mentioned in the arg types.
-
-E.g.
-        data Foo.S = MkS Baz.T
-Maybe we can get away without even loading the interface for Baz!
-
-This is not just a performance thing.  Suppose we have
-        data Foo.S = MkS Baz.T
-        data Baz.T = MkT Foo.S
-(in different interface files, of course).
-Now, first we load and typecheck Foo.S, and add it to the type envt.
-If we do explore MkS's argument, we'll load and typecheck Baz.T.
-If we explore MkT's argument we'll find Foo.S already in the envt.
-
-If we typechecked constructor args eagerly, when loading Foo.S we'd try to
-typecheck the type Baz.T.  So we'd fault in Baz.T... and then need Foo.S...
-which isn't done yet.
-
-All very cunning. However, there is a rather subtle gotcha which bit
-me when developing this stuff.  When we typecheck the decl for S, we
-extend the type envt with S, MkS, and all its implicit Ids.  Suppose
-(a bug, but it happened) that the list of implicit Ids depended in
-turn on the constructor arg types.  Then the following sequence of
-events takes place:
-        * we build a thunk <t> for the constructor arg tys
-        * we build a thunk for the extended type environment (depends on <t>)
-        * we write the extended type envt into the global EPS mutvar
-
-Now we look something up in the type envt
-        * that pulls on <t>
-        * which reads the global type envt out of the global EPS mutvar
-        * but that depends in turn on <t>
-
-It's subtle, because, it'd work fine if we typechecked the constructor args
-eagerly -- they don't need the extended type envt.  They just get the extended
-type envt by accident, because they look at it later.
-
-What this means is that the implicitTyThings MUST NOT DEPEND on any of
-the forkM stuff.
--}
-
-tcIfaceDecl :: Bool     -- ^ True <=> discard IdInfo on IfaceId bindings
-            -> IfaceDecl
-            -> IfL TyThing
-tcIfaceDecl = tc_iface_decl Nothing
-
-tc_iface_decl :: Maybe Class  -- ^ For associated type/data family declarations
-              -> Bool         -- ^ True <=> discard IdInfo on IfaceId bindings
-              -> IfaceDecl
-              -> IfL TyThing
-tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,
-                                       ifIdDetails = details, ifIdInfo = info})
-  = do  { ty <- tcIfaceType iface_type
-        ; details <- tcIdDetails ty details
-        ; info <- tcIdInfo ignore_prags TopLevel name ty info
-        ; return (AnId (mkGlobalId details name ty info)) }
-
-tc_iface_decl _ _ (IfaceData {ifName = tc_name,
-                          ifCType = cType,
-                          ifBinders = binders,
-                          ifResKind = res_kind,
-                          ifRoles = roles,
-                          ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
-                          ifCons = rdr_cons,
-                          ifParent = mb_parent })
-  = bindIfaceTyConBinders_AT binders $ \ binders' -> do
-    { res_kind' <- tcIfaceType res_kind
-
-    ; tycon <- fixM $ \ tycon -> do
-            { stupid_theta <- tcIfaceCtxt ctxt
-            ; parent' <- tc_parent tc_name mb_parent
-            ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons
-            ; return (mkAlgTyCon tc_name binders' res_kind'
-                                 roles cType stupid_theta
-                                 cons parent' gadt_syn) }
-    ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
-    ; return (ATyCon tycon) }
-  where
-    tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav
-    tc_parent tc_name IfNoParent
-      = do { tc_rep_name <- newTyConRepName tc_name
-           ; return (VanillaAlgTyCon tc_rep_name) }
-    tc_parent _ (IfDataInstance ax_name _ arg_tys)
-      = do { ax <- tcIfaceCoAxiom ax_name
-           ; let fam_tc  = coAxiomTyCon ax
-                 ax_unbr = toUnbranchedAxiom ax
-           ; lhs_tys <- tcIfaceAppArgs arg_tys
-           ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }
-
-tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name,
-                                      ifRoles = roles,
-                                      ifSynRhs = rhs_ty,
-                                      ifBinders = binders,
-                                      ifResKind = res_kind })
-   = bindIfaceTyConBinders_AT binders $ \ binders' -> do
-     { res_kind' <- tcIfaceType res_kind     -- Note [Synonym kind loop]
-     ; rhs      <- forkM (mk_doc tc_name) $
-                   tcIfaceType rhs_ty
-     ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs
-     ; return (ATyCon tycon) }
-   where
-     mk_doc n = text "Type synonym" <+> ppr n
-
-tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,
-                                     ifFamFlav = fam_flav,
-                                     ifBinders = binders,
-                                     ifResKind = res_kind,
-                                     ifResVar = res, ifFamInj = inj })
-   = bindIfaceTyConBinders_AT binders $ \ binders' -> do
-     { res_kind' <- tcIfaceType res_kind    -- Note [Synonym kind loop]
-     ; rhs      <- forkM (mk_doc tc_name) $
-                   tc_fam_flav tc_name fam_flav
-     ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
-     ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj
-     ; return (ATyCon tycon) }
-   where
-     mk_doc n = text "Type synonym" <+> ppr n
-
-     tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav
-     tc_fam_flav tc_name IfaceDataFamilyTyCon
-       = do { tc_rep_name <- newTyConRepName tc_name
-            ; return (DataFamilyTyCon tc_rep_name) }
-     tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon
-     tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
-       = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches
-            ; return (ClosedSynFamilyTyCon ax) }
-     tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon
-         = return AbstractClosedSynFamilyTyCon
-     tc_fam_flav _ IfaceBuiltInSynFamTyCon
-         = pprPanic "tc_iface_decl"
-                    (text "IfaceBuiltInSynFamTyCon in interface file")
-
-tc_iface_decl _parent _ignore_prags
-            (IfaceClass {ifName = tc_name,
-                         ifRoles = roles,
-                         ifBinders = binders,
-                         ifFDs = rdr_fds,
-                         ifBody = IfAbstractClass})
-  = bindIfaceTyConBinders binders $ \ binders' -> do
-    { fds  <- mapM tc_fd rdr_fds
-    ; cls  <- buildClass tc_name binders' roles fds Nothing
-    ; return (ATyCon (classTyCon cls)) }
-
-tc_iface_decl _parent ignore_prags
-            (IfaceClass {ifName = tc_name,
-                         ifRoles = roles,
-                         ifBinders = binders,
-                         ifFDs = rdr_fds,
-                         ifBody = IfConcreteClass {
-                             ifClassCtxt = rdr_ctxt,
-                             ifATs = rdr_ats, ifSigs = rdr_sigs,
-                             ifMinDef = mindef_occ
-                         }})
-  = bindIfaceTyConBinders binders $ \ binders' -> do
-    { traceIf (text "tc-iface-class1" <+> ppr tc_name)
-    ; ctxt <- mapM tc_sc rdr_ctxt
-    ; traceIf (text "tc-iface-class2" <+> ppr tc_name)
-    ; sigs <- mapM tc_sig rdr_sigs
-    ; fds  <- mapM tc_fd rdr_fds
-    ; traceIf (text "tc-iface-class3" <+> ppr tc_name)
-    ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ
-    ; cls  <- fixM $ \ cls -> do
-              { ats  <- mapM (tc_at cls) rdr_ats
-              ; traceIf (text "tc-iface-class4" <+> ppr tc_name)
-              ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) }
-    ; return (ATyCon (classTyCon cls)) }
-  where
-   tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
-        -- The *length* of the superclasses is used by buildClass, and hence must
-        -- not be inside the thunk.  But the *content* maybe recursive and hence
-        -- must be lazy (via forkM).  Example:
-        --     class C (T a) => D a where
-        --       data T a
-        -- Here the associated type T is knot-tied with the class, and
-        -- so we must not pull on T too eagerly.  See #5970
-
-   tc_sig :: IfaceClassOp -> IfL TcMethInfo
-   tc_sig (IfaceClassOp op_name rdr_ty dm)
-     = do { let doc = mk_op_doc op_name rdr_ty
-          ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty
-                -- Must be done lazily for just the same reason as the
-                -- type of a data con; to avoid sucking in types that
-                -- it mentions unless it's necessary to do so
-          ; dm'   <- tc_dm doc dm
-          ; return (op_name, op_ty, dm') }
-
-   tc_dm :: SDoc
-         -> Maybe (DefMethSpec IfaceType)
-         -> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
-   tc_dm _   Nothing               = return Nothing
-   tc_dm _   (Just VanillaDM)      = return (Just VanillaDM)
-   tc_dm doc (Just (GenericDM ty))
-        = do { -- Must be done lazily to avoid sucking in types
-             ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty
-             ; return (Just (GenericDM (noSrcSpan, ty'))) }
-
-   tc_at cls (IfaceAT tc_decl if_def)
-     = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
-          mb_def <- case if_def of
-                      Nothing  -> return Nothing
-                      Just def -> forkM (mk_at_doc tc)                 $
-                                  extendIfaceTyVarEnv (tyConTyVars tc) $
-                                  do { tc_def <- tcIfaceType def
-                                     ; return (Just (tc_def, NoATVI)) }
-                  -- Must be done lazily in case the RHS of the defaults mention
-                  -- the type constructor being defined here
-                  -- e.g.   type AT a; type AT b = AT [b]   #8002
-          return (ATI tc mb_def)
-
-   mk_sc_doc pred = text "Superclass" <+> ppr pred
-   mk_at_doc tc = text "Associated type" <+> ppr tc
-   mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty]
-
-tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc
-                              , ifAxBranches = branches, ifRole = role })
-  = do { tc_tycon    <- tcIfaceTyCon tc
-       -- Must be done lazily, because axioms are forced when checking
-       -- for family instance consistency, and the RHS may mention
-       -- a hs-boot declared type constructor that is going to be
-       -- defined by this module.
-       -- e.g. type instance F Int = ToBeDefined
-       -- See #13803
-       ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name)
-                      $ tc_ax_branches branches
-       ; let axiom = CoAxiom { co_ax_unique   = nameUnique tc_name
-                             , co_ax_name     = tc_name
-                             , co_ax_tc       = tc_tycon
-                             , co_ax_role     = role
-                             , co_ax_branches = manyBranches tc_branches
-                             , co_ax_implicit = False }
-       ; return (ACoAxiom axiom) }
-
-tc_iface_decl _ _ (IfacePatSyn{ ifName = name
-                              , ifPatMatcher = if_matcher
-                              , ifPatBuilder = if_builder
-                              , ifPatIsInfix = is_infix
-                              , ifPatUnivBndrs = univ_bndrs
-                              , ifPatExBndrs = ex_bndrs
-                              , ifPatProvCtxt = prov_ctxt
-                              , ifPatReqCtxt = req_ctxt
-                              , ifPatArgs = args
-                              , ifPatTy = pat_ty
-                              , ifFieldLabels = field_labels })
-  = do { traceIf (text "tc_iface_decl" <+> ppr name)
-       ; matcher <- tc_pr if_matcher
-       ; builder <- traverse tc_pr if_builder
-       ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do
-       { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do
-       { patsyn <- forkM (mk_doc name) $
-             do { prov_theta <- tcIfaceCtxt prov_ctxt
-                ; req_theta  <- tcIfaceCtxt req_ctxt
-                ; pat_ty     <- tcIfaceType pat_ty
-                ; arg_tys    <- mapM tcIfaceType args
-                ; return $ buildPatSyn name is_infix matcher builder
-                                       (univ_tvs, req_theta)
-                                       (ex_tvs, prov_theta)
-                                       arg_tys pat_ty field_labels }
-       ; return $ AConLike . PatSynCon $ patsyn }}}
-  where
-     mk_doc n = text "Pattern synonym" <+> ppr n
-     tc_pr :: (IfExtName, Bool) -> IfL (Name, Type, Bool)
-     tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)
-                        ; return (nm, idType id, b) }
-
-tcTopIfaceBindings :: IORef TypeEnv -> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-          -> IfL [CoreBind]
-tcTopIfaceBindings ty_var ver_decls
-   = do
-      int <- mapM tcTopBinders  ver_decls
-      let all_ids :: [Id] = concatMap toList int
-      liftIO $ modifyIORef ty_var (flip extendTypeEnvList (map AnId all_ids))
-
-      extendIfaceIdEnv all_ids $ mapM (tc_iface_bindings) int
-
-tcTopBinders :: IfaceBindingX a IfaceTopBndrInfo -> IfL (IfaceBindingX a Id)
-tcTopBinders = traverse mk_top_id
-
-tc_iface_bindings ::  IfaceBindingX IfaceMaybeRhs Id -> IfL CoreBind
-tc_iface_bindings (IfaceNonRec b rhs) = do
-    rhs' <- tc_iface_binding b rhs
-    return $ NonRec b rhs'
-tc_iface_bindings (IfaceRec bs) = do
-  rs <- mapM (\(b, rhs) -> (b,) <$> tc_iface_binding b rhs) bs
-  return (Rec rs)
-
--- | See Note [Interface File with Core: Sharing RHSs]
-tc_iface_binding :: Id -> IfaceMaybeRhs -> IfL CoreExpr
-tc_iface_binding i IfUseUnfoldingRhs = return (unfoldingTemplate $ realIdUnfolding i)
-tc_iface_binding _ (IfRhs rhs) = tcIfaceExpr rhs
-
-mk_top_id :: IfaceTopBndrInfo -> IfL Id
-mk_top_id (IfGblTopBndr gbl_name) = tcIfaceExtId gbl_name
-mk_top_id (IfLclTopBndr raw_name iface_type info details) = do
-   name <- newIfaceName (mkVarOccFS raw_name)
-   ty <- tcIfaceType iface_type
-   info' <- tcIdInfo False TopLevel name ty info
-   details' <- tcIdDetails ty details
-   let new_id = mkGlobalId details' name ty info'
-   return new_id
-
-tcIfaceDecls :: Bool
-          -> [(Fingerprint, IfaceDecl)]
-          -> IfL [(Name,TyThing)]
-tcIfaceDecls ignore_prags ver_decls
-   = concatMapM (tc_iface_decl_fingerprint ignore_prags) ver_decls
-
-tc_iface_decl_fingerprint :: Bool                    -- Don't load pragmas into the decl pool
-          -> (Fingerprint, IfaceDecl)
-          -> IfL [(Name,TyThing)]   -- The list can be poked eagerly, but the
-                                    -- TyThings are forkM'd thunks
-tc_iface_decl_fingerprint ignore_prags (_version, decl)
-  = do  {       -- Populate the name cache with final versions of all
-                -- the names associated with the decl
-          let main_name = ifName decl
-
-        -- Typecheck the thing, lazily
-        -- NB. Firstly, the laziness is there in case we never need the
-        -- declaration (in one-shot mode), and secondly it is there so that
-        -- we don't look up the occurrence of a name before calling mk_new_bndr
-        -- on the binder.  This is important because we must get the right name
-        -- which includes its nameParent.
-
-        ; thing <- forkM doc $ do { bumpDeclStats main_name
-                                  ; tcIfaceDecl ignore_prags decl }
-
-        -- Populate the type environment with the implicitTyThings too.
-        --
-        -- Note [Tricky iface loop]
-        -- ~~~~~~~~~~~~~~~~~~~~~~~~
-        -- Summary: The delicate point here is that 'mini-env' must be
-        -- buildable from 'thing' without demanding any of the things
-        -- 'forkM'd by tcIfaceDecl.
-        --
-        -- In more detail: Consider the example
-        --      data T a = MkT { x :: T a }
-        -- The implicitTyThings of T are:  [ <datacon MkT>, <selector x>]
-        -- (plus their workers, wrappers, coercions etc etc)
-        --
-        -- We want to return an environment
-        --      [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ]
-        -- (where the "MkT" is the *Name* associated with MkT, etc.)
-        --
-        -- We do this by mapping the implicit_names to the associated
-        -- TyThings.  By the invariant on ifaceDeclImplicitBndrs and
-        -- implicitTyThings, we can use getOccName on the implicit
-        -- TyThings to make this association: each Name's OccName should
-        -- be the OccName of exactly one implicitTyThing.  So the key is
-        -- to define a "mini-env"
-        --
-        -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ]
-        -- where the 'MkT' here is the *OccName* associated with MkT.
-        --
-        -- However, there is a subtlety: due to how type checking needs
-        -- to be staged, we can't poke on the forkM'd thunks inside the
-        -- implicitTyThings while building this mini-env.
-        -- If we poke these thunks too early, two problems could happen:
-        --    (1) When processing mutually recursive modules across
-        --        hs-boot boundaries, poking too early will do the
-        --        type-checking before the recursive knot has been tied,
-        --        so things will be type-checked in the wrong
-        --        environment, and necessary variables won't be in
-        --        scope.
-        --
-        --    (2) Looking up one OccName in the mini_env will cause
-        --        others to be looked up, which might cause that
-        --        original one to be looked up again, and hence loop.
-        --
-        -- The code below works because of the following invariant:
-        -- getOccName on a TyThing does not force the suspended type
-        -- checks in order to extract the name. For example, we don't
-        -- poke on the "T a" type of <selector x> on the way to
-        -- extracting <selector x>'s OccName. Of course, there is no
-        -- reason in principle why getting the OccName should force the
-        -- thunks, but this means we need to be careful in
-        -- implicitTyThings and its helper functions.
-        --
-        -- All a bit too finely-balanced for my liking.
-
-        -- This mini-env and lookup function mediates between the
-        --'Name's n and the map from 'OccName's to the implicit TyThings
-        ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
-              lookup n = case lookupOccEnv mini_env (getOccName n) of
-                           Just thing -> thing
-                           Nothing    ->
-                             pprPanic "tc_iface_decl_fingerprint" (ppr main_name <+> ppr n $$ ppr (decl))
-
-        ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl)
-
---         ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names)
-        ; return $ (main_name, thing) :
-                      -- uses the invariant that implicit_names and
-                      -- implicitTyThings are bijective
-                      [(n, lookup n) | n <- implicit_names]
-        }
-  where
-    doc = text "Declaration for" <+> ppr (ifName decl)
-
-bumpDeclStats :: Name -> IfL ()         -- Record that one more declaration has actually been used
-bumpDeclStats name
-  = do  { traceIf (text "Loading decl for" <+> ppr name)
-        ; updateEps_ (\eps -> let stats = eps_stats eps
-                              in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
-        }
-
-tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar)
-tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
-                        ; tvs2' <- mapM tcIfaceTyVar tvs2
-                        ; return (tvs1', tvs2') }
-
-tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
-tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
-
-tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
-tc_ax_branch prev_branches
-             (IfaceAxBranch { ifaxbTyVars = tv_bndrs
-                            , ifaxbEtaTyVars = eta_tv_bndrs
-                            , ifaxbCoVars = cv_bndrs
-                            , ifaxbLHS = lhs, ifaxbRHS = rhs
-                            , ifaxbRoles = roles, ifaxbIncomps = incomps })
-  = bindIfaceTyConBinders_AT
-      (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
-         -- The _AT variant is needed here; see Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom
-    bindIfaceIds cv_bndrs $ \ cvs -> do
-    { tc_lhs   <- tcIfaceAppArgs lhs
-    ; tc_rhs   <- tcIfaceType rhs
-    ; eta_tvs  <- bindIfaceTyVars eta_tv_bndrs return
-    ; this_mod <- getIfModule
-    ; let loc = mkGeneralSrcSpan (fsLit "module " `appendFS`
-                                  moduleNameFS (moduleName this_mod))
-          br = CoAxBranch { cab_loc     = loc
-                          , cab_tvs     = binderVars tvs
-                          , cab_eta_tvs = eta_tvs
-                          , cab_cvs     = cvs
-                          , cab_lhs     = tc_lhs
-                          , cab_roles   = roles
-                          , cab_rhs     = tc_rhs
-                          , cab_incomps = map (prev_branches `getNth`) incomps }
-    ; return (prev_branches ++ [br]) }
-
-tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs
-tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
-  = case if_cons of
-        IfAbstractTyCon
-          -> return AbstractTyCon
-        IfDataTyCon type_data cons
-          -> do  { data_cons  <- mapM tc_con_decl cons
-                 ; return $
-                     mkLevPolyDataTyConRhs
-                       (isFixedRuntimeRepKind $ tyConResKind tycon)
-                       type_data
-                       data_cons }
-        IfNewTyCon con
-          -> do  { data_con  <- tc_con_decl con
-                 ; mkNewTyConRhs tycon_name tycon data_con }
-  where
-    univ_tvs :: [TyVar]
-    univ_tvs = binderVars tc_tybinders
-
-    tag_map :: NameEnv ConTag
-    tag_map = mkTyConTagMap tycon
-
-    tc_con_decl (IfCon { ifConInfix = is_infix,
-                         ifConExTCvs = ex_bndrs,
-                         ifConUserTvBinders = user_bndrs,
-                         ifConName = dc_name,
-                         ifConCtxt = ctxt, ifConEqSpec = spec,
-                         ifConArgTys = args, ifConFields = lbl_names,
-                         ifConStricts = if_stricts,
-                         ifConSrcStricts = if_src_stricts})
-     = -- Universally-quantified tyvars are shared with
-       -- parent TyCon, and are already in scope
-       bindIfaceBndrs ex_bndrs    $ \ ex_tvs -> do
-        { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name)
-
-          -- By this point, we have bound every universal and existential
-          -- tyvar. Because of the dcUserTyVarBinders invariant
-          -- (see Note [DataCon user type variable binders]), *every* tyvar in
-          -- ifConUserTvBinders has a matching counterpart somewhere in the
-          -- bound universals/existentials. As a result, calling tcIfaceTyVar
-          -- below is always guaranteed to succeed.
-        ; user_tv_bndrs <- mapM (\(Bndr bd vis) ->
-                                   case bd of
-                                     IfaceIdBndr (_, name, _) ->
-                                       Bndr <$> tcIfaceLclId name <*> pure vis
-                                     IfaceTvBndr (name, _) ->
-                                       Bndr <$> tcIfaceTyVar name <*> pure vis)
-                                user_bndrs
-
-        -- Read the context and argument types, but lazily for two reasons
-        -- (a) to avoid looking tugging on a recursive use of
-        --     the type itself, which is knot-tied
-        -- (b) to avoid faulting in the component types unless
-        --     they are really needed
-        ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $
-             do { eq_spec <- tcIfaceEqSpec spec
-                ; theta   <- tcIfaceCtxt ctxt
-                -- This fixes #13710.  The enclosing lazy thunk gets
-                -- forced when typechecking record wildcard pattern
-                -- matching (it's not completely clear why this
-                -- tuple is needed), which causes trouble if one of
-                -- the argument types was recursively defined.
-                -- See also Note [Tying the knot]
-                ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys")
-                           $ mapM (\(w, ty) -> mkScaled <$> tcIfaceType w <*> tcIfaceType ty) args
-                ; stricts <- mapM tc_strict if_stricts
-                        -- The IfBang field can mention
-                        -- the type itself; hence inside forkM
-                ; return (eq_spec, theta, arg_tys, stricts) }
-
-        -- Remember, tycon is the representation tycon
-        ; let orig_res_ty = mkFamilyTyConApp tycon
-                              (substTyCoVars (mkTvSubstPrs (map eqSpecPair eq_spec))
-                                             (binderVars tc_tybinders))
-
-        ; prom_rep_name <- newTyConRepName dc_name
-
-        ; let bang_opts = FixedBangOpts stricts
-            -- Pass the HsImplBangs (i.e. final decisions) to buildDataCon;
-            -- it'll use these to guide the construction of a worker.
-            -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make
-
-        ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))
-                       bang_opts
-                       dc_name is_infix prom_rep_name
-                       (map src_strict if_src_stricts)
-                       lbl_names
-                       univ_tvs ex_tvs user_tv_bndrs
-                       eq_spec theta
-                       arg_tys orig_res_ty tycon tag_map
-        ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
-        ; return con }
-    mk_doc con_name = text "Constructor" <+> ppr con_name
-
-    tc_strict :: IfaceBang -> IfL HsImplBang
-    tc_strict IfNoBang = return (HsLazy)
-    tc_strict IfStrict = return (HsStrict)
-    tc_strict IfUnpack = return (HsUnpack Nothing)
-    tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
-                                      ; return (HsUnpack (Just co)) }
-
-    src_strict :: IfaceSrcBang -> HsSrcBang
-    src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang
-
-tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]
-tcIfaceEqSpec spec
-  = mapM do_item spec
-  where
-    do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ
-                              ; ty <- tcIfaceType if_ty
-                              ; return (mkEqSpec tv ty) }
-
-{-
-Note [Synonym kind loop]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Notice that we eagerly grab the *kind* from the interface file, but
-build a forkM thunk for the *rhs* (and family stuff).  To see why,
-consider this (#2412)
-
-M.hs:       module M where { import X; data T = MkT S }
-X.hs:       module X where { import {-# SOURCE #-} M; type S = T }
-M.hs-boot:  module M where { data T }
-
-When kind-checking M.hs we need S's kind.  But we do not want to
-find S's kind from (typeKind S-rhs), because we don't want to look at
-S-rhs yet!  Since S is imported from X.hi, S gets just one chance to
-be defined, and we must not do that until we've finished with M.T.
-
-Solution: record S's kind in the interface file; now we can safely
-look at it.
-
-************************************************************************
-*                                                                      *
-                Instances
-*                                                                      *
-************************************************************************
--}
-
-tcRoughTyCon :: Maybe IfaceTyCon -> RoughMatchTc
-tcRoughTyCon (Just tc) = RM_KnownTc (ifaceTyConName tc)
-tcRoughTyCon Nothing   = RM_WildCard
-
-tcIfaceInst :: IfaceClsInst -> IfL ClsInst
-tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
-                          , ifInstCls = cls, ifInstTys = mb_tcs
-                          , ifInstOrph = orph })
-  = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $
-                    fmap tyThingId (tcIfaceImplicit dfun_name)
-       ; let mb_tcs' = map tcRoughTyCon mb_tcs
-       ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }
-
-tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
-tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
-                             , ifFamInstAxiom = axiom_name } )
-    = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $
-                     tcIfaceCoAxiom axiom_name
-             -- will panic if branched, but that's OK
-         ; let axiom'' = toUnbranchedAxiom axiom'
-               mb_tcs' = map tcRoughTyCon mb_tcs
-         ; return (mkImportedFamInst fam mb_tcs' axiom'') }
-
-{-
-************************************************************************
-*                                                                      *
-                Rules
-*                                                                      *
-************************************************************************
-
-We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
-are in the type environment.  However, remember that typechecking a Rule may
-(as a side effect) augment the type envt, and so we may need to iterate the process.
--}
-
-tcIfaceRules :: Bool            -- True <=> ignore rules
-             -> [IfaceRule]
-             -> IfL [CoreRule]
-tcIfaceRules ignore_prags if_rules
-  | ignore_prags = return []
-  | otherwise    = mapM tcIfaceRule if_rules
-
-tcIfaceRule :: IfaceRule -> IfL CoreRule
-tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
-                        ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
-                        ifRuleAuto = auto, ifRuleOrph = orph })
-  = do  { ~(bndrs', args', rhs') <-
-                -- Typecheck the payload lazily, in the hope it'll never be looked at
-                forkM (text "Rule" <+> pprRuleName name) $
-                bindIfaceBndrs bndrs                      $ \ bndrs' ->
-                do { args'  <- mapM tcIfaceExpr args
-                   ; rhs'   <- tcIfaceExpr rhs
-                   ; whenGOptM Opt_DoCoreLinting $ do
-                      { dflags <- getDynFlags
-                      ; (_, lcl_env) <- getEnvs
-                      ; let in_scope :: [Var]
-                            in_scope = ((nonDetEltsUFM $ if_tv_env lcl_env) ++
-                                        (nonDetEltsUFM $ if_id_env lcl_env) ++
-                                        bndrs' ++
-                                        exprsFreeIdsList args')
-                      ; case lintExpr (initLintConfig dflags in_scope) rhs' of
-                          Nothing   -> return ()
-                          Just errs -> do
-                            logger <- getLogger
-                            liftIO $ displayLintResults logger False doc
-                                               (pprCoreExpr rhs')
-                                               (emptyBag, errs) }
-                   ; return (bndrs', args', rhs') }
-        ; let mb_tcs = map ifTopFreeName args
-        ; this_mod <- getIfModule
-        ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
-                          ru_bndrs = bndrs', ru_args = args',
-                          ru_rhs = occurAnalyseExpr rhs',
-                          ru_rough = mb_tcs,
-                          ru_origin = this_mod,
-                          ru_orphan = orph,
-                          ru_auto = auto,
-                          ru_local = False }) } -- An imported RULE is never for a local Id
-                                                -- or, even if it is (module loop, perhaps)
-                                                -- we'll just leave it in the non-local set
-  where
-        -- This function *must* mirror exactly what Rules.roughTopNames does
-        -- We could have stored the ru_rough field in the iface file
-        -- but that would be redundant, I think.
-        -- The only wrinkle is that we must not be deceived by
-        -- type synonyms at the top of a type arg.  Since
-        -- we can't tell at this point, we are careful not
-        -- to write them out in coreRuleToIfaceRule
-    ifTopFreeName :: IfaceExpr -> Maybe Name
-    ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
-    ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))
-    ifTopFreeName (IfaceApp f _)                    = ifTopFreeName f
-    ifTopFreeName (IfaceExt n)                      = Just n
-    ifTopFreeName _                                 = Nothing
-
-    doc = text "Unfolding of" <+> ppr name
-
-{-
-************************************************************************
-*                                                                      *
-                Annotations
-*                                                                      *
-************************************************************************
--}
-
-tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
-tcIfaceAnnotations = mapM tcIfaceAnnotation
-
-tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
-tcIfaceAnnotation (IfaceAnnotation target serialized) = do
-    target' <- tcIfaceAnnTarget target
-    return $ Annotation {
-        ann_target = target',
-        ann_value = serialized
-    }
-
-tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
-tcIfaceAnnTarget (NamedTarget occ) =
-    NamedTarget <$> lookupIfaceTop occ
-tcIfaceAnnTarget (ModuleTarget mod) =
-    return $ ModuleTarget mod
-
-{-
-************************************************************************
-*                                                                      *
-                Complete Match Pragmas
-*                                                                      *
-************************************************************************
--}
-
-tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
-tcIfaceCompleteMatches = mapM tcIfaceCompleteMatch
-
-tcIfaceCompleteMatch :: IfaceCompleteMatch -> IfL CompleteMatch
-tcIfaceCompleteMatch (IfaceCompleteMatch ms mtc) = forkM doc $ do -- See Note [Positioning of forkM]
-  conlikes <- mkUniqDSet <$> mapM tcIfaceConLike ms
-  mtc' <- traverse tcIfaceTyCon mtc
-  return (CompleteMatch conlikes mtc')
-  where
-    doc = text "COMPLETE sig" <+> ppr ms
-
-{- Note [Positioning of forkM]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We need to be lazy when type checking the interface, since these functions are
-called when the interface itself is being loaded, which means it is not in the
-PIT yet. In particular, the `tcIfaceTCon` must be inside the forkM, otherwise
-we'll try to look it up the TyCon, find it's not there, and so initiate the
-process (again) of loading the (very same) interface file. Result: infinite
-loop. See #19744.
--}
-
-{-
-************************************************************************
-*                                                                      *
-                        Types
-*                                                                      *
-************************************************************************
--}
-
-tcIfaceType :: IfaceType -> IfL Type
-tcIfaceType = go
-  where
-    go (IfaceTyVar n)            = TyVarTy <$> tcIfaceTyVar n
-    go (IfaceFreeTyVar n)        = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)
-    go (IfaceLitTy l)            = LitTy <$> tcIfaceTyLit l
-    go (IfaceFunTy flag w t1 t2) = FunTy flag <$> tcIfaceType w <*> go t1 <*> go t2
-    go (IfaceTupleTy s i tks)    = tcIfaceTupleTy s i tks
-    go (IfaceAppTy t ts)
-      = do { t'  <- go t
-           ; ts' <- traverse go (appArgsIfaceTypes ts)
-           ; pure (foldl' AppTy t' ts') }
-    go (IfaceTyConApp tc tks)
-      = do { tc' <- tcIfaceTyCon tc
-           ; tks' <- mapM go (appArgsIfaceTypes tks)
-           ; return (mkTyConApp tc' tks') }
-    go (IfaceForAllTy bndr t)
-      = bindIfaceForAllBndr bndr $ \ tv' vis ->
-        ForAllTy (Bndr tv' vis) <$> go t
-    go (IfaceCastTy ty co)   = CastTy <$> go ty <*> tcIfaceCo co
-    go (IfaceCoercionTy co)  = CoercionTy <$> tcIfaceCo co
-
-tcIfaceTupleTy :: TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type
-tcIfaceTupleTy sort is_promoted args
- = do { args' <- tcIfaceAppArgs args
-      ; let arity = length args'
-      ; base_tc <- tcTupleTyCon True sort arity
-      ; case is_promoted of
-          NotPromoted
-            -> return (mkTyConApp base_tc args')
-
-          IsPromoted
-            -> do { let tc        = promoteDataCon (tyConSingleDataCon base_tc)
-                        kind_args = map typeKind args'
-                  ; return (mkTyConApp tc (kind_args ++ args')) } }
-
--- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
-tcTupleTyCon :: Bool    -- True <=> typechecking a *type* (vs. an expr)
-             -> TupleSort
-             -> Arity   -- the number of args. *not* the tuple arity.
-             -> IfL TyCon
-tcTupleTyCon in_type sort arity
-  = case sort of
-      ConstraintTuple -> return (cTupleTyCon arity)
-      BoxedTuple      -> return (tupleTyCon Boxed   arity)
-      UnboxedTuple    -> return (tupleTyCon Unboxed arity')
-        where arity' | in_type   = arity `div` 2
-                     | otherwise = arity
-                      -- in expressions, we only have term args
-
-tcIfaceAppArgs :: IfaceAppArgs -> IfL [Type]
-tcIfaceAppArgs = mapM tcIfaceType . appArgsIfaceTypes
-
------------------------------------------
-tcIfaceCtxt :: IfaceContext -> IfL ThetaType
-tcIfaceCtxt sts = mapM tcIfaceType sts
-
------------------------------------------
-tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
-tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
-tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
-tcIfaceTyLit (IfaceCharTyLit n) = return (CharTyLit n)
-
-{-
-%************************************************************************
-%*                                                                      *
-                        Coercions
-*                                                                      *
-************************************************************************
--}
-
-tcIfaceCo :: IfaceCoercion -> IfL Coercion
-tcIfaceCo = go
-  where
-    go_mco IfaceMRefl    = pure MRefl
-    go_mco (IfaceMCo co) = MCo <$> (go co)
-
-    go (IfaceReflCo t)           = Refl <$> tcIfaceType t
-    go (IfaceGReflCo r t mco)    = GRefl r <$> tcIfaceType t <*> go_mco mco
-    go (IfaceFunCo r w c1 c2)    = mkFunCoNoFTF r <$> go w <*> go c1 <*> go c2
-    go (IfaceTyConAppCo r tc cs) = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
-    go (IfaceAppCo c1 c2)        = AppCo <$> go c1 <*> go c2
-    go (IfaceForAllCo tv k c)    = do { k' <- go k
-                                      ; bindIfaceBndr tv $ \ tv' ->
-                                        ForAllCo tv' k' <$> go c }
-    go (IfaceCoVarCo n)          = CoVarCo <$> go_var n
-    go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs
-    go (IfaceUnivCo p r t1 t2)   = UnivCo <$> tcIfaceUnivCoProv p <*> pure r
-                                          <*> tcIfaceType t1 <*> tcIfaceType t2
-    go (IfaceSymCo c)            = SymCo    <$> go c
-    go (IfaceTransCo c1 c2)      = TransCo  <$> go c1
-                                            <*> go c2
-    go (IfaceInstCo c1 t2)       = InstCo   <$> go c1
-                                            <*> go t2
-    go (IfaceSelCo d c)          = do { c' <- go c
-                                      ; return $ mkSelCo d c' }
-    go (IfaceLRCo lr c)          = LRCo lr  <$> go c
-    go (IfaceKindCo c)           = KindCo   <$> go c
-    go (IfaceSubCo c)            = SubCo    <$> go c
-    go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax
-                                               <*> mapM go cos
-    go (IfaceFreeCoVar c)        = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)
-    go (IfaceHoleCo c)           = pprPanic "tcIfaceCo:IfaceHoleCo"    (ppr c)
-
-    go_var :: FastString -> IfL CoVar
-    go_var = tcIfaceLclId
-
-tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
-tcIfaceUnivCoProv (IfacePhantomProv kco)    = PhantomProv <$> tcIfaceCo kco
-tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
-tcIfaceUnivCoProv (IfacePluginProv str)     = return $ PluginProv str
-tcIfaceUnivCoProv (IfaceCorePrepProv b)     = return $ CorePrepProv b
-
-{-
-************************************************************************
-*                                                                      *
-                        Core
-*                                                                      *
-************************************************************************
--}
-
-tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
-tcIfaceExpr (IfaceType ty)
-  = Type <$> tcIfaceType ty
-
-tcIfaceExpr (IfaceCo co)
-  = Coercion <$> tcIfaceCo co
-
-tcIfaceExpr (IfaceCast expr co)
-  = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
-
-tcIfaceExpr (IfaceLcl name)
-  = Var <$> tcIfaceLclId name
-
-tcIfaceExpr (IfaceExt gbl)
-  = Var <$> tcIfaceExtId gbl
-
-tcIfaceExpr (IfaceLitRubbish tc rep)
-  = do rep' <- tcIfaceType rep
-       return (Lit (LitRubbish tc rep'))
-
-tcIfaceExpr (IfaceLit lit)
-  = do lit' <- tcIfaceLit lit
-       return (Lit lit')
-
-tcIfaceExpr (IfaceFCall cc ty) = do
-    ty' <- tcIfaceType ty
-    u <- newUnique
-    return (Var (mkFCallId u cc ty'))
-
-tcIfaceExpr (IfaceTuple sort args)
-  = do { args' <- mapM tcIfaceExpr args
-       ; tc <- tcTupleTyCon False sort arity
-       ; let con_tys = map exprType args'
-             some_con_args = map Type con_tys ++ args'
-             con_args = case sort of
-               UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args
-               _            -> some_con_args
-                        -- Put the missing type arguments back in
-             con_id   = dataConWorkId (tyConSingleDataCon tc)
-       ; return (mkApps (Var con_id) con_args) }
-  where
-    arity = length args
-
-tcIfaceExpr (IfaceLam (bndr, os) body)
-  = bindIfaceBndr bndr $ \bndr' ->
-    Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body
-  where
-    tcIfaceOneShot IfaceOneShot b = setOneShotLambda b
-    tcIfaceOneShot _            b = b
-
-tcIfaceExpr (IfaceApp fun arg)
-  = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
-
-tcIfaceExpr (IfaceECase scrut ty)
-  = do { scrut' <- tcIfaceExpr scrut
-       ; ty' <- tcIfaceType ty
-       ; return (castBottomExpr scrut' ty') }
-
-tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do
-    scrut' <- tcIfaceExpr scrut
-    case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
-    let
-        scrut_ty   = exprType scrut'
-        case_mult  = ManyTy
-        case_bndr' = mkLocalIdOrCoVar case_bndr_name case_mult scrut_ty
-     -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors
-     -- (e.g. see test T15695). Ticket #17291 covers fixing this problem.
-        tc_app     = splitTyConApp scrut_ty
-                -- NB: Won't always succeed (polymorphic case)
-                --     but won't be demanded in those cases
-                -- NB: not tcSplitTyConApp; we are looking at Core here
-                --     look through non-rec newtypes to find the tycon that
-                --     corresponds to the datacon in this case alternative
-
-    extendIfaceIdEnv [case_bndr'] $ do
-     alts' <- mapM (tcIfaceAlt scrut' case_mult tc_app) alts
-     return (Case scrut' case_bndr' (coreAltsType alts') alts')
-
-tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
-  = do  { name    <- newIfaceName (mkVarOccFS fs)
-        ; ty'     <- tcIfaceType ty
-        ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
-                              NotTopLevel name ty' info
-        ; let id = mkLocalIdWithInfo name ManyTy ty' id_info
-                     `asJoinId_maybe` tcJoinInfo ji
-        ; rhs' <- tcIfaceExpr rhs
-        ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
-        ; return (Let (NonRec id rhs') body') }
-
-tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
-  = do { ids <- mapM tc_rec_bndr (map fst pairs)
-       ; extendIfaceIdEnv ids $ do
-       { pairs' <- zipWithM tc_pair pairs ids
-       ; body' <- tcIfaceExpr body
-       ; return (Let (Rec pairs') body') } }
- where
-   tc_rec_bndr (IfLetBndr fs ty _ ji)
-     = do { name <- newIfaceName (mkVarOccFS fs)
-          ; ty'  <- tcIfaceType ty
-          ; return (mkLocalId name ManyTy ty' `asJoinId_maybe` tcJoinInfo ji) }
-   tc_pair (IfLetBndr _ _ info _, rhs) id
-     = do { rhs' <- tcIfaceExpr rhs
-          ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
-                                NotTopLevel (idName id) (idType id) info
-          ; return (setIdInfo id id_info, rhs') }
-
-tcIfaceExpr (IfaceTick tickish expr) = do
-    expr' <- tcIfaceExpr expr
-    -- If debug flag is not set: Ignore source notes
-    need_notes <- needSourceNotes <$> getDynFlags
-    case tickish of
-      IfaceSource{} | not (need_notes)
-                    -> return expr'
-      _otherwise    -> do
-        tickish' <- tcIfaceTickish tickish
-        return (Tick tickish' expr')
-
--------------------------
-tcIfaceTickish :: IfaceTickish -> IfM lcl CoreTickish
-tcIfaceTickish (IfaceHpcTick modl ix)   = return (HpcTick modl ix)
-tcIfaceTickish (IfaceSCC  cc tick push) = return (ProfNote cc tick push)
-tcIfaceTickish (IfaceSource src name)   = return (SourceNote src name)
-
--------------------------
-tcIfaceLit :: Literal -> IfL Literal
-tcIfaceLit lit = return lit
-
--------------------------
-tcIfaceAlt :: CoreExpr -> Mult -> (TyCon, [Type])
-           -> IfaceAlt
-           -> IfL CoreAlt
-tcIfaceAlt _ _ _ (IfaceAlt IfaceDefault names rhs)
-  = assert (null names) $ do
-    rhs' <- tcIfaceExpr rhs
-    return (Alt DEFAULT [] rhs')
-
-tcIfaceAlt _ _ _ (IfaceAlt (IfaceLitAlt lit) names rhs)
-  = assert (null names) $ do
-    lit' <- tcIfaceLit lit
-    rhs' <- tcIfaceExpr rhs
-    return (Alt (LitAlt lit') [] rhs')
-
--- A case alternative is made quite a bit more complicated
--- by the fact that we omit type annotations because we can
--- work them out.  True enough, but its not that easy!
-tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceAlt (IfaceDataAlt data_occ) arg_strs rhs)
-  = do  { con <- tcIfaceDataCon data_occ
-        ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
-               (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
-        ; tcIfaceDataAlt mult con inst_tys arg_strs rhs }
-
-tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [FastString] -> IfaceExpr
-               -> IfL CoreAlt
-tcIfaceDataAlt mult con inst_tys arg_strs rhs
-  = do  { us <- newUniqueSupply
-        ; let uniqs = uniqsFromSupply us
-        ; let (ex_tvs, arg_ids)
-                      = dataConRepFSInstPat arg_strs uniqs mult con inst_tys
-
-        ; rhs' <- extendIfaceEnvs  ex_tvs       $
-                  extendIfaceIdEnv arg_ids      $
-                  tcIfaceExpr rhs
-        ; return (Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs') }
-
-{-
-************************************************************************
-*                                                                      *
-                IdInfo
-*                                                                      *
-************************************************************************
--}
-
-tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
-tcIdDetails _  IfVanillaId = return VanillaId
-tcIdDetails _  (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds
-tcIdDetails ty IfDFunId
-  = return (DFunId (isNewTyCon (classTyCon cls)))
-  where
-    (_, _, cls, _) = tcSplitDFunTy ty
-
-tcIdDetails _ (IfRecSelId tc naughty)
-  = do { tc' <- either (fmap RecSelData . tcIfaceTyCon)
-                       (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)
-                       tc
-       ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
-  where
-    tyThingPatSyn (AConLike (PatSynCon ps)) = ps
-    tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"
-
-tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
-tcIdInfo ignore_prags toplvl name ty info = do
-    lcl_env <- getLclEnv
-    -- Set the CgInfo to something sensible but uninformative before
-    -- we start; default assumption is that it has CAFs
-    let init_info = if if_boot lcl_env == IsBoot
-                      then vanillaIdInfo `setUnfoldingInfo` BootUnfolding
-                      else vanillaIdInfo
-
-    foldlM tcPrag init_info (needed_prags info)
-  where
-    needed_prags :: [IfaceInfoItem] -> [IfaceInfoItem]
-    needed_prags items
-      | not ignore_prags = items
-      | otherwise        = filter need_prag items
-
-    need_prag :: IfaceInfoItem -> Bool
-      -- Always read in compulsory unfoldings
-      -- See Note [Always expose compulsory unfoldings] in GHC.Iface.Tidy
-    need_prag (HsUnfold _ (IfCoreUnfold src _ _)) = isCompulsorySource src
-    need_prag _ = False
-
-    tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
-    tcPrag info HsNoCafRefs        = return (info `setCafInfo`   NoCafRefs)
-    tcPrag info (HsArity arity)    = return (info `setArityInfo` arity)
-    tcPrag info (HsDmdSig str)     = return (info `setDmdSigInfo` str)
-    tcPrag info (HsCprSig cpr)     = return (info `setCprSigInfo` cpr)
-    tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)
-    tcPrag info (HsLFInfo lf_info) = do
-      lf_info <- tcLFInfo lf_info
-      return (info `setLFInfo` lf_info)
-
-    tcPrag info (HsTagSig sig) = do
-      return (info `setTagSig` sig)
-
-        -- The next two are lazy, so they don't transitively suck stuff in
-    tcPrag info (HsUnfold lb if_unf)
-      = do { unf <- tcUnfolding toplvl name ty info if_unf
-           ; let info1 | lb        = info `setOccInfo` strongLoopBreaker
-                       | otherwise = info
-           ; return (info1 `setUnfoldingInfo` unf) }
-
-tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
-tcJoinInfo (IfaceJoinPoint ar) = Just ar
-tcJoinInfo IfaceNotJoinPoint   = Nothing
-
-tcLFInfo :: IfaceLFInfo -> IfL LambdaFormInfo
-tcLFInfo lfi = case lfi of
-    IfLFReEntrant rep_arity ->
-      -- LFReEntrant closures in interface files are guaranteed to
-      --
-      -- - Be top-level, as only top-level closures are exported.
-      -- - Have no free variables, as only non-top-level closures have free
-      --   variables
-      -- - Don't have ArgDescrs, as ArgDescr is used when generating code for
-      --   the closure
-      --
-      -- These invariants are checked when generating LFInfos in toIfaceLFInfo.
-      return (LFReEntrant TopLevel rep_arity True ArgUnknown)
-
-    IfLFThunk updatable mb_fun ->
-      -- LFThunk closure in interface files are guaranteed to
-      --
-      -- - Be top-level
-      -- - No have free variables
-      --
-      -- These invariants are checked when generating LFInfos in toIfaceLFInfo.
-      return (LFThunk TopLevel True updatable NonStandardThunk mb_fun)
-
-    IfLFUnlifted ->
-      return LFUnlifted
-
-    IfLFCon con_name ->
-      LFCon <$!> tcIfaceDataCon con_name
-
-    IfLFUnknown fun_flag ->
-      return (LFUnknown fun_flag)
-
-tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
--- See Note [Lazily checking Unfoldings]
-tcUnfolding toplvl name _ info (IfCoreUnfold src if_guidance if_expr)
-  = do  { uf_opts <- unfoldingOpts <$> getDynFlags
-        ; expr <- tcUnfoldingRhs (isCompulsorySource src) toplvl name if_expr
-        ; let guidance = case if_guidance of
-                 IfWhen arity unsat_ok boring_ok -> UnfWhen arity unsat_ok boring_ok
-                 IfNoGuidance -> calcUnfoldingGuidance uf_opts is_top_bottoming expr
-        ; return $ mkCoreUnfolding src True expr guidance }
-  where
-    -- Strictness should occur before unfolding!
-    is_top_bottoming = isTopLevel toplvl && isDeadEndSig (dmdSigInfo info)
-
-tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)
-  = bindIfaceBndrs bs $ \ bs' ->
-    do { ops1 <- forkM doc $ mapM tcIfaceExpr ops
-       ; return $ mkDFunUnfolding bs' (classDataCon cls) ops1 }
-  where
-    doc = text "Class ops for dfun" <+> ppr name
-    (_, _, cls, _) = tcSplitDFunTy dfun_ty
-
-{- Note [Lazily checking Unfoldings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For unfoldings, we try to do the job lazily, so that we never typecheck
-an unfolding that isn't going to be looked at.
-
-The main idea is that if M.hi has a declaration
-   f :: Int -> Int
-   f = \x. ...A.g...   -- The unfolding for f
-
-then we don't even want to /read/ A.hi unless f's unfolding is actually used; say,
-if f is inlined. But we need to be careful. Even if we don't inline f, we might ask
-hasNoBinding of it (Core Lint does this in GHC.Core.Lint.checkCanEtaExpand),
-and hasNoBinding looks to see if f has a compulsory unfolding.
-So the root Unfolding constructor must be visible: we want to be able to read the 'uf_src'
-field which says whether it is a compulsory unfolding, without forcing the unfolding RHS
-which is stored in 'uf_tmpl'. This matters for efficiency, but not only: if g's unfolding
-mentions f, we must not look at the unfolding RHS for f, as this is precisely what we are
-in the middle of checking (so looking at it would cause a loop).
-
-Conclusion: `tcUnfolding` must return an `Unfolding` whose `uf_src` field is readable without
-forcing the `uf_tmpl` field. In particular, all the functions used at the end of
-`tcUnfolding` (such as `mkFinalUnfolding`, `mkCoreUnfolding`) must be
-lazy in `expr`.
-
-Ticket #21139
--}
-
-tcUnfoldingRhs :: Bool -- ^ Is this unfolding compulsory?
-                       -- See Note [Checking for representation polymorphism] in GHC.Core.Lint
-               -> TopLevelFlag -> Name -> IfaceExpr -> IfL CoreExpr
-tcUnfoldingRhs is_compulsory toplvl name expr
-  = forkM doc $ do
-    core_expr' <- tcIfaceExpr expr
-
-    -- Check for type consistency in the unfolding
-    -- See Note [Linting Unfoldings from Interfaces] in GHC.Core.Lint
-    when (isTopLevel toplvl) $
-      whenGOptM Opt_DoCoreLinting $ do
-        in_scope <- nonDetEltsUniqSet <$> get_in_scope
-        dflags   <- getDynFlags
-        logger   <- getLogger
-        case lintUnfolding is_compulsory (initLintConfig dflags in_scope) noSrcLoc core_expr' of
-          Nothing   -> return ()
-          Just errs -> liftIO $
-            displayLintResults logger False doc
-                               (pprCoreExpr core_expr') (emptyBag, errs)
-    return core_expr'
-  where
-    doc = ppWhen is_compulsory (text "Compulsory") <+>
-          text "Unfolding of" <+> ppr name
-
-    get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting
-    get_in_scope
-        = do { (gbl_env, lcl_env) <- getEnvs
-             ; let type_envs = knotVarElems (if_rec_types gbl_env)
-             ; top_level_vars <- concat <$> mapM (fmap typeEnvIds . setLclEnv ())  type_envs
-             ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`
-                       bindingsVars (if_id_env lcl_env) `unionVarSet`
-                       mkVarSet top_level_vars) }
-
-    bindingsVars :: FastStringEnv Var -> VarSet
-    bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm
-      -- It's OK to use nonDetEltsUFM here because we immediately forget
-      -- the ordering by creating a set
-
-tcIfaceOneShot :: IfaceOneShot -> OneShotInfo
-tcIfaceOneShot IfaceNoOneShot = NoOneShotInfo
-tcIfaceOneShot IfaceOneShot = OneShotLam
-
-{-
-************************************************************************
-*                                                                      *
-                Getting from Names to TyThings
-*                                                                      *
-************************************************************************
--}
-
-tcIfaceGlobal :: Name -> IfL TyThing
-tcIfaceGlobal name
-  | Just thing <- wiredInNameTyThing_maybe name
-        -- Wired-in things include TyCons, DataCons, and Ids
-        -- Even though we are in an interface file, we want to make
-        -- sure the instances and RULES of this thing (particularly TyCon) are loaded
-        -- Imagine: f :: Double -> Double
-  = do { ifCheckWiredInThing thing; return thing }
-
-  | otherwise
-  = do  { env <- getGblEnv
-        ; cur_mod <- if_mod <$> getLclEnv
-        ; case lookupKnotVars (if_rec_types env) (fromMaybe cur_mod (nameModule_maybe name))  of     -- Note [Tying the knot]
-            Just get_type_env
-                -> do           -- It's defined in a module in the hs-boot loop
-                { type_env <- setLclEnv () get_type_env         -- yuk
-                ; case lookupNameEnv type_env name of
-                    Just thing -> return thing
-                    -- See Note [Knot-tying fallback on boot]
-                    Nothing   -> via_external
-                }
-
-            _ -> via_external }
-  where
-    via_external =  do
-        { hsc_env <- getTopEnv
-        ; mb_thing <- liftIO (lookupType hsc_env name)
-        ; case mb_thing of {
-            Just thing -> return thing ;
-            Nothing    -> do
-
-        { mb_thing <- importDecl name   -- It's imported; go get it
-        ; case mb_thing of
-            Failed err      -> failIfM (ppr name <+> err)
-            Succeeded thing -> return thing
-        }}}
-
--- Note [Tying the knot]
--- ~~~~~~~~~~~~~~~~~~~~~
--- The if_rec_types field is used when we are compiling M.hs, which indirectly
--- imports Foo.hi, which mentions M.T Then we look up M.T in M's type
--- environment, which is splatted into if_rec_types after we've built M's type
--- envt.
---
--- This is a dark and complicated part of GHC type checking, with a lot
--- of moving parts.  Interested readers should also look at:
---
---      * Note [Knot-tying typecheckIface]
---      * Note [DFun knot-tying]
---      * Note [hsc_type_env_var hack]
---      * Note [Knot-tying fallback on boot]
---      * Note [Hydrating Modules]
---
--- There is also a wiki page on the subject, see:
---
---      https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/tying-the-knot
-
--- Note [Knot-tying fallback on boot]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Suppose that you are typechecking A.hs, which transitively imports,
--- via B.hs, A.hs-boot. When we poke on B.hs and discover that it
--- has a reference to a type T from A, what TyThing should we wire
--- it up with? Clearly, if we have already typechecked T and
--- added it into the type environment, we should go ahead and use that
--- type. But what if we haven't typechecked it yet?
---
--- For the longest time, GHC adopted the policy that this was
--- *an error condition*; that you MUST NEVER poke on B.hs's reference
--- to a T defined in A.hs until A.hs has gotten around to kind-checking
--- T and adding it to the env. However, actually ensuring this is the
--- case has proven to be a bug farm, because it's really difficult to
--- actually ensure this never happens. The problem was especially poignant
--- with type family consistency checks, which eagerly happen before any
--- typechecking takes place.
---
--- Today, we take a different strategy: if we ever try to access
--- an entity from A which doesn't exist, we just fall back on the
--- definition of A from the hs-boot file. This is complicated in
--- its own way: it means that you may end up with a mix of A.hs and
--- A.hs-boot TyThings during the course of typechecking.  We don't
--- think (and have not observed) any cases where this would cause
--- problems, but the hypothetical situation one might worry about
--- is something along these lines in Core:
---
---    case x of
---        A -> e1
---        B -> e2
---
--- If, when typechecking this, we find x :: T, and the T we are hooked
--- up with is the abstract one from the hs-boot file, rather than the
--- one defined in this module with constructors A and B.  But it's hard
--- to see how this could happen, especially because the reference to
--- the constructor (A and B) means that GHC will always typecheck
--- this expression *after* typechecking T.
-
-tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
-tcIfaceTyCon (IfaceTyCon name _info)
-  = do { thing <- tcIfaceGlobal name
-       ; case thing of
-              ATyCon tc -> return tc
-              AConLike (RealDataCon dc) -> return (promoteDataCon dc)
-              _ -> pprPanic "tcIfaceTyCon" (ppr thing) }
-
-tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
-tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
-                         ; return (tyThingCoAxiom thing) }
-
-
-tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule
--- Unlike CoAxioms, which arise from user 'type instance' declarations,
--- there are a fixed set of CoAxiomRules:
---   - axioms for type-level literals (Nat and Symbol),
---     enumerated in typeNatCoAxiomRules
-tcIfaceCoAxiomRule n
-  | Just ax <- lookupUFM typeNatCoAxiomRules n
-  = return ax
-  | otherwise
-  = pprPanic "tcIfaceCoAxiomRule" (ppr n)
-
-tcIfaceDataCon :: Name -> IfL DataCon
-tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
-                         ; case thing of
-                                AConLike (RealDataCon dc) -> return dc
-                                _       -> pprPanic "tcIfaceDataCon" (ppr name$$ ppr thing) }
-
-tcIfaceConLike :: Name -> IfL ConLike
-tcIfaceConLike name = do { thing <- tcIfaceGlobal name
-                         ; case thing of
-                                AConLike cl -> return cl
-                                _           -> pprPanic "tcIfaceConLike" (ppr name$$ ppr thing) }
-
-tcIfaceExtId :: Name -> IfL Id
-tcIfaceExtId name = do { thing <- tcIfaceGlobal name
-                       ; case thing of
-                          AnId id -> return id
-                          _       -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
-
--- See Note [Resolving never-exported Names] in GHC.IfaceToCore
-tcIfaceImplicit :: Name -> IfL TyThing
-tcIfaceImplicit n = do
-    lcl_env <- getLclEnv
-    case if_implicits_env lcl_env of
-        Nothing -> tcIfaceGlobal n
-        Just tenv ->
-            case lookupTypeEnv tenv n of
-                Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv)
-                Just tything -> return tything
-
-{-
-************************************************************************
-*                                                                      *
-                Bindings
-*                                                                      *
-************************************************************************
--}
-
-bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
-bindIfaceId (w, fs, ty) thing_inside
-  = do  { name <- newIfaceName (mkVarOccFS fs)
-        ; ty' <- tcIfaceType ty
-        ; w' <- tcIfaceType w
-        ; let id = mkLocalIdOrCoVar name w' ty'
-          -- We should not have "OrCoVar" here, this is a bug (#17545)
-        ; extendIfaceIdEnv [id] (thing_inside id) }
-
-bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
-bindIfaceIds [] thing_inside = thing_inside []
-bindIfaceIds (b:bs) thing_inside
-  = bindIfaceId b   $ \b'  ->
-    bindIfaceIds bs $ \bs' ->
-    thing_inside (b':bs')
-
-bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
-bindIfaceBndr (IfaceIdBndr bndr) thing_inside
-  = bindIfaceId bndr thing_inside
-bindIfaceBndr (IfaceTvBndr bndr) thing_inside
-  = bindIfaceTyVar bndr thing_inside
-
-bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
-bindIfaceBndrs []     thing_inside = thing_inside []
-bindIfaceBndrs (b:bs) thing_inside
-  = bindIfaceBndr b     $ \ b' ->
-    bindIfaceBndrs bs   $ \ bs' ->
-    thing_inside (b':bs')
-
------------------------
-bindIfaceForAllBndrs :: [VarBndr IfaceBndr vis] -> ([VarBndr TyCoVar vis] -> IfL a) -> IfL a
-bindIfaceForAllBndrs [] thing_inside = thing_inside []
-bindIfaceForAllBndrs (bndr:bndrs) thing_inside
-  = bindIfaceForAllBndr bndr $ \tv vis ->
-    bindIfaceForAllBndrs bndrs $ \bndrs' ->
-    thing_inside (Bndr tv vis : bndrs')
-
-bindIfaceForAllBndr :: (VarBndr IfaceBndr vis) -> (TyCoVar -> vis -> IfL a) -> IfL a
-bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside
-  = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis
-bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside
-  = bindIfaceId tv $ \tv' -> thing_inside tv' vis
-
-bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
-bindIfaceTyVar (occ,kind) thing_inside
-  = do  { name <- newIfaceName (mkTyVarOccFS occ)
-        ; tyvar <- mk_iface_tyvar name kind
-        ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
-
-bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
-bindIfaceTyVars [] thing_inside = thing_inside []
-bindIfaceTyVars (bndr:bndrs) thing_inside
-  = bindIfaceTyVar bndr   $ \tv  ->
-    bindIfaceTyVars bndrs $ \tvs ->
-    thing_inside (tv : tvs)
-
-mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
-mk_iface_tyvar name ifKind
-   = do { kind <- tcIfaceType ifKind
-        ; return (Var.mkTyVar name kind) }
-
-bindIfaceTyConBinders :: [IfaceTyConBinder]
-                      -> ([TyConBinder] -> IfL a) -> IfL a
-bindIfaceTyConBinders [] thing_inside = thing_inside []
-bindIfaceTyConBinders (b:bs) thing_inside
-  = bindIfaceTyConBinderX bindIfaceBndr b $ \ b'  ->
-    bindIfaceTyConBinders bs              $ \ bs' ->
-    thing_inside (b':bs')
-
-bindIfaceTyConBinders_AT :: [IfaceTyConBinder]
-                         -> ([TyConBinder] -> IfL a) -> IfL a
--- Used for type variable in nested associated data/type declarations
--- where some of the type variables are already in scope
---    class C a where { data T a b }
--- Here 'a' is in scope when we look at the 'data T'
-bindIfaceTyConBinders_AT [] thing_inside
-  = thing_inside []
-bindIfaceTyConBinders_AT (b : bs) thing_inside
-  = bindIfaceTyConBinderX bind_tv b  $ \b'  ->
-    bindIfaceTyConBinders_AT      bs $ \bs' ->
-    thing_inside (b':bs')
-  where
-    bind_tv tv thing
-      = do { mb_tv <- lookupIfaceVar tv
-           ; case mb_tv of
-               Just b' -> thing b'
-               Nothing -> bindIfaceBndr tv thing }
-
-bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a)
-                      -> IfaceTyConBinder
-                      -> (TyConBinder -> IfL a) -> IfL a
-bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside
-  = bind_tv tv $ \tv' ->
-    thing_inside (Bndr tv' vis)
diff --git a/compiler/GHC/IfaceToCore.hs-boot b/compiler/GHC/IfaceToCore.hs-boot
deleted file mode 100644
--- a/compiler/GHC/IfaceToCore.hs-boot
+++ /dev/null
@@ -1,22 +0,0 @@
-module GHC.IfaceToCore where
-
-import GHC.Prelude
-import GHC.Iface.Syntax ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule
-                        , IfaceAnnotation, IfaceCompleteMatch )
-import GHC.Types.TyThing   ( TyThing )
-import GHC.Tc.Types        ( IfL )
-import GHC.Core.InstEnv    ( ClsInst )
-import GHC.Core.FamInstEnv ( FamInst )
-import GHC.Core         ( CoreRule )
-import GHC.Types.CompleteMatch
-import GHC.Types.Annotations ( Annotation )
-import GHC.Types.Name
-import GHC.Fingerprint.Type
-
-tcIfaceDecl            :: Bool -> IfaceDecl -> IfL TyThing
-tcIfaceRules           :: Bool -> [IfaceRule] -> IfL [CoreRule]
-tcIfaceInst            :: IfaceClsInst -> IfL ClsInst
-tcIfaceFamInst         :: IfaceFamInst -> IfL FamInst
-tcIfaceAnnotations     :: [IfaceAnnotation] -> IfL [Annotation]
-tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
-tcIfaceDecls           :: Bool -> [(Fingerprint, IfaceDecl)] -> IfL [(Name,TyThing)]
diff --git a/compiler/GHC/JS/Make.hs b/compiler/GHC/JS/Make.hs
deleted file mode 100644
--- a/compiler/GHC/JS/Make.hs
+++ /dev/null
@@ -1,715 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE GADTs #-}
-
-{-# OPTIONS_GHC -fno-warn-orphans #-} -- only for Num, Fractional on JExpr
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.JS.Make
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
---
--- * Domain and Purpose
---
---     GHC.JS.Make defines helper functions to ease the creation of JavaScript
---     ASTs as defined in 'GHC.JS.Syntax'. Its purpose is twofold: make the EDSL
---     more ergonomic to program in, and make errors in the EDSL /look/ obvious
---     because the EDSL is untyped. It is primarily concerned with injecting
---     terms into the domain of the EDSL to construct JS programs in Haskell.
---
--- * Strategy
---
---     The strategy for this module comes straight from gentzen; where we have
---     two types of helper functions. Functions which inject terms into the
---     EDSL, and combinator functions which operate on terms in the EDSL to
---     construct new terms in the EDSL. Crucially, missing from this module are
---     corresponding /elimination/ or /destructing/ functions which would
---     project information from the EDSL back to Haskell. See
---     'GHC.StgToJS.UnitUtils' and 'GHC.StgToJS.CoreUtils' for such functions.
---
---      * /Introduction/ functions
---
---           We define various primitive helpers which /introduce/ terms in the
---           EDSL, for example 'jVar', 'jLam', and 'var' and 'jString'. Notice
---           that the type of each of these functions have the domain @isSat a
---           => a -> ...@; indicating that they each take something that /can/
---           be injected into the EDSL domain, and the range 'JExpr' or 'JStat';
---           indicating the corresponding value in the EDSL domain. Similarly
---           this module exports two typeclasses 'ToExpr' and 'ToSat', 'ToExpr'
---           injects values as a JS expression into the EDSL. 'ToSat' ensures
---           that terms introduced into the EDSL carry identifier information so
---           terms in the EDSL must have meaning.
---
---      * /Combinator/ functions
---
---           The rest of the module defines combinators which create terms in
---           the EDSL from terms in the EDSL. Notable examples are '|=' and
---           '||=', '|=' is sugar for 'AssignStat', it is a binding form that
---           declares @foo = bar@ /assuming/ foo has been already declared.
---           '||=' is more sugar on top of '|=', it is also a binding form that
---           declares the LHS of '|=' before calling '|=' to bind a value, bar,
---           to a variable foo. Other common examples are the 'if_' and 'math_'
---           helpers such as 'math_cos'.
---
--- * Consumers
---
---     The entire JS backend consumes this module, e.g., the modules in
---     GHC.StgToJS.\*.
---
--- * Notation
---
---     In this module we use @==>@ in docstrings to show the translation from
---     the JS EDSL domain to JS code. For example, @foo ||= bar ==> var foo; foo
---     = bar;@ should be read as @foo ||= bar@ is in the EDSL domain and results
---     in the JS code @var foo; foo = bar;@ when compiled.
------------------------------------------------------------------------------
-module GHC.JS.Make
-  ( -- * Injection Type classes
-    -- $classes
-    ToJExpr(..)
-  , ToStat(..)
-  -- * Introduction functions
-  -- $intro_funcs
-  , var
-  , jString
-  , jLam, jVar, jFor, jForIn, jForEachIn, jTryCatchFinally
-  -- * Combinators
-  -- $combinators
-  , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!)
-  , (.>.), (.>=.), (.<.), (.<=.)
-  , (.<<.), (.>>.), (.>>>.)
-  , (.|.), (.||.), (.&&.)
-  , if_, if10, if01, ifS, ifBlockS
-  , jwhenS
-  , app, appS, returnS
-  , loop, loopBlockS
-  , preIncrS, postIncrS
-  , preDecrS, postDecrS
-  , off8, off16, off32, off64
-  , mask8, mask16
-  , signExtend8, signExtend16
-  , typeof
-  , returnStack, assignAllEqual, assignAll, assignAllReverseOrder
-  , declAssignAll
-  , nullStat, (.^)
-  , trace
-  -- ** Hash combinators
-  , jhEmpty
-  , jhSingle
-  , jhAdd
-  , jhFromList
-  -- * Literals
-  -- $literals
-  , null_
-  , undefined_
-  , false_
-  , true_
-  , zero_
-  , one_
-  , two_
-  , three_
-  -- ** Math functions
-  -- $math
-  , math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin,
-    math_atan, math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh,
-    math_cosh, math_sinh, math_tanh, math_expm1, math_log1p, math_fround
-  -- * Statement helpers
-  , decl
-  -- * Miscellaneous
-  -- $misc
-  , allocData, allocClsA
-  , dataFieldName, dataFieldNames
-  )
-where
-
-import GHC.Prelude hiding ((.|.))
-
-import GHC.JS.Syntax
-
-import Control.Arrow ((***))
-
-import Data.Array
-import qualified Data.Map as M
-import qualified Data.List as List
-
-import GHC.Utils.Outputable (Outputable (..))
-import GHC.Data.FastString
-import GHC.Utils.Monad.State.Strict
-import GHC.Utils.Panic
-import GHC.Utils.Misc
-import GHC.Types.Unique.Map
-
---------------------------------------------------------------------------------
---                        Type Classes
---------------------------------------------------------------------------------
--- $classes
--- The 'ToJExpr' class handles injection of of things into the EDSL as a JS
--- expression
-
--- | Things that can be marshalled into javascript values.
--- Instantiate for any necessary data structures.
-class ToJExpr a where
-    toJExpr         :: a   -> JExpr
-    toJExprFromList :: [a] -> JExpr
-    toJExprFromList = ValExpr . JList . map toJExpr
-
-instance ToJExpr a => ToJExpr [a] where
-    toJExpr = toJExprFromList
-
-instance ToJExpr JExpr where
-    toJExpr = id
-
-instance ToJExpr () where
-    toJExpr _ = ValExpr $ JList []
-
-instance ToJExpr Bool where
-    toJExpr True  = var "true"
-    toJExpr False = var "false"
-
-instance ToJExpr JVal where
-    toJExpr = ValExpr
-
-instance ToJExpr a => ToJExpr (UniqMap FastString a) where
-    toJExpr = ValExpr . JHash . mapUniqMap toJExpr
-
-instance ToJExpr a => ToJExpr (M.Map String a) where
-    toJExpr = ValExpr . JHash . listToUniqMap . map (mkFastString *** toJExpr) . M.toList
-
-instance ToJExpr Double where
-    toJExpr = ValExpr . JDouble . SaneDouble
-
-instance ToJExpr Int where
-    toJExpr = ValExpr . JInt . fromIntegral
-
-instance ToJExpr Integer where
-    toJExpr = ValExpr . JInt
-
-instance ToJExpr Char where
-    toJExpr = ValExpr . JStr . mkFastString . (:[])
-    toJExprFromList = ValExpr . JStr . mkFastString
---        where escQuotes = tailDef "" . initDef "" . show
-
-instance ToJExpr Ident where
-    toJExpr = ValExpr . JVar
-
-instance ToJExpr FastString where
-    toJExpr = ValExpr . JStr
-
-instance (ToJExpr a, ToJExpr b) => ToJExpr (a,b) where
-    toJExpr (a,b) = ValExpr . JList $ [toJExpr a, toJExpr b]
-
-instance (ToJExpr a, ToJExpr b, ToJExpr c) => ToJExpr (a,b,c) where
-    toJExpr (a,b,c) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c]
-
-instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d) => ToJExpr (a,b,c,d) where
-    toJExpr (a,b,c,d) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d]
-instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e) => ToJExpr (a,b,c,d,e) where
-    toJExpr (a,b,c,d,e) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e]
-instance (ToJExpr a, ToJExpr b, ToJExpr c, ToJExpr d, ToJExpr e, ToJExpr f) => ToJExpr (a,b,c,d,e,f) where
-    toJExpr (a,b,c,d,e,f) = ValExpr . JList $ [toJExpr a, toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f]
-
-
--- | The 'ToStat' class handles injection of of things into the EDSL as a JS
--- statement. This ends up being polymorphic sugar for JS blocks, see helper
--- function 'GHC.JS.Make.expr2stat'. Instantiate for any necessary data
--- structures.
-class ToStat a where
-    toStat :: a -> JStat
-
-instance ToStat JStat where
-    toStat = id
-
-instance ToStat [JStat] where
-    toStat = BlockStat
-
-instance ToStat JExpr where
-    toStat = expr2stat
-
-instance ToStat [JExpr] where
-    toStat = BlockStat . map expr2stat
-
---------------------------------------------------------------------------------
---                        Introduction Functions
---------------------------------------------------------------------------------
--- $intro_functions
--- Introduction functions are functions that map values or terms in the Haskell
--- domain to the JS EDSL domain
-
--- | Create a new anonymous function. The result is a 'GHC.JS.Syntax.JExpr'
--- expression.
--- Usage:
---
--- > jLam $ \x -> jVar x + one_
--- > jLam $ \f -> (jLam $ \x -> (f `app` (x `app` x))) `app` (jLam $ \x -> (f `app` (x `app` x)))
-jLam :: ToSat a => a -> JExpr
-jLam f = ValExpr . UnsatVal . IS $ do
-           (block,is) <- runIdentSupply $ toSat_ f []
-           return $ JFunc is block
-
--- | Introduce a new variable into scope for the duration
--- of the enclosed expression. The result is a block statement.
--- Usage:
---
--- @jVar $ \x y -> mconcat [jVar x ||= one_, jVar y ||= two_, jVar x + jVar y]@
-jVar :: ToSat a => a -> JStat
-jVar f = UnsatBlock . IS $ do
-           (block, is) <- runIdentSupply $ toSat_ f []
-           let addDecls (BlockStat ss) =
-                  BlockStat $ map decl is ++ ss
-               addDecls x = x
-           return $ addDecls block
-
--- | Create a 'for in' statement.
--- Usage:
---
--- @jForIn {expression} $ \x -> {block involving x}@
-jForIn :: ToSat a => JExpr -> (JExpr -> a)  -> JStat
-jForIn e f = UnsatBlock . IS $ do
-               (block, is) <- runIdentSupply $ toSat_ f []
-               let i = List.head is
-               return $ decl i `mappend` ForInStat False i e block
-
--- | As with "jForIn" but creating a \"for each in\" statement.
-jForEachIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat
-jForEachIn e f = UnsatBlock . IS $ do
-               (block, is) <- runIdentSupply $ toSat_ f []
-               let i = List.head is
-               return $ decl i `mappend` ForInStat True i e block
-
--- | As with "jForIn" but creating a \"for each in\" statement.
-jTryCatchFinally :: (ToSat a) => JStat -> a -> JStat -> JStat
-jTryCatchFinally s f s2 = UnsatBlock . IS $ do
-                     (block, is) <- runIdentSupply $ toSat_ f []
-                     let i = List.head is
-                     return $ TryStat s i block s2
-
--- | construct a JS variable reference
-var :: FastString -> JExpr
-var = ValExpr . JVar . TxtI
-
--- | Convert a ShortText to a Javascript String
-jString :: FastString -> JExpr
-jString = toJExpr
-
--- | Create a 'for' statement
-jFor :: (ToJExpr a, ToStat b) => JStat -> a -> JStat -> b -> JStat
-jFor before p after b = BlockStat [before, WhileStat False (toJExpr p) b']
-    where b' = case toStat b of
-                 BlockStat xs -> BlockStat $ xs ++ [after]
-                 x -> BlockStat [x,after]
-
--- | construct a js declaration with the given identifier
-decl :: Ident -> JStat
-decl i = DeclStat i Nothing
-
--- | The empty JS HashMap
-jhEmpty :: M.Map k JExpr
-jhEmpty = M.empty
-
--- | A singleton JS HashMap
-jhSingle :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr
-jhSingle k v = jhAdd k v jhEmpty
-
--- | insert a key-value pair into a JS HashMap
-jhAdd :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr -> M.Map k JExpr
-jhAdd  k v m = M.insert k (toJExpr v) m
-
--- | Construct a JS HashMap from a list of key-value pairs
-jhFromList :: [(FastString, JExpr)] -> JVal
-jhFromList = JHash . listToUniqMap
-
--- | The empty JS statement
-nullStat :: JStat
-nullStat = BlockStat []
-
-
---------------------------------------------------------------------------------
---                             Combinators
---------------------------------------------------------------------------------
--- $combinators
--- Combinators operate on terms in the JS EDSL domain to create new terms in the
--- EDSL domain.
-
--- | JS infix Equality operators
-(.==.), (.===.), (.!=.), (.!==.) :: JExpr -> JExpr -> JExpr
-(.==.)  = InfixExpr EqOp
-(.===.) = InfixExpr StrictEqOp
-(.!=.)  = InfixExpr NeqOp
-(.!==.) = InfixExpr StrictNeqOp
-
-infixl 6 .==., .===., .!=., .!==.
-
--- | JS infix Ord operators
-(.>.), (.>=.), (.<.), (.<=.) :: JExpr -> JExpr -> JExpr
-(.>.)  = InfixExpr GtOp
-(.>=.) = InfixExpr GeOp
-(.<.)  = InfixExpr LtOp
-(.<=.) = InfixExpr LeOp
-
-infixl 7 .>., .>=., .<., .<=.
-
--- | JS infix bit operators
-(.|.), (.||.), (.&&.)  :: JExpr -> JExpr -> JExpr
-(.|.)   = InfixExpr BOrOp
-(.||.)  = InfixExpr LOrOp
-(.&&.)  = InfixExpr LAndOp
-
-infixl 8 .||., .&&.
-
--- | JS infix bit shift operators
-(.<<.), (.>>.), (.>>>.) :: JExpr -> JExpr -> JExpr
-(.<<.)  = InfixExpr LeftShiftOp
-(.>>.)  = InfixExpr RightShiftOp
-(.>>>.) = InfixExpr ZRightShiftOp
-
-infixl 9 .<<., .>>., .>>>.
-
--- | Given a 'JExpr', return the its type.
-typeof :: JExpr -> JExpr
-typeof = UOpExpr TypeofOp
-
--- | JS if-expression
---
--- > if_ e1 e2 e3 ==> e1 ? e2 : e3
-if_ :: JExpr -> JExpr -> JExpr -> JExpr
-if_ e1 e2 e3 = IfExpr e1 e2 e3
-
--- | If-expression which returns statements, see related 'ifBlockS'
---
--- > if e s1 s2 ==> if(e) { s1 } else { s2 }
-ifS :: JExpr -> JStat -> JStat -> JStat
-ifS e s1 s2 = IfStat e s1 s2
-
--- | A when-statement as syntactic sugar via `ifS`
---
--- > jwhenS cond block ==> if(cond) { block } else {  }
-jwhenS :: JExpr -> JStat -> JStat
-jwhenS cond block = ifS cond block mempty
-
--- | If-expression which returns blocks
---
--- > ifBlockS e s1 s2 ==> if(e) { s1 } else { s2 }
-ifBlockS :: JExpr -> [JStat] -> [JStat] -> JStat
-ifBlockS e s1 s2 = IfStat e (mconcat s1) (mconcat s2)
-
--- | if-expression that returns 1 if condition <=> true, 0 otherwise
---
--- > if10 e ==> e ? 1 : 0
-if10 :: JExpr -> JExpr
-if10 e = IfExpr e one_ zero_
-
--- | if-expression that returns 0 if condition <=> true, 1 otherwise
---
--- > if01 e ==> e ? 0 : 1
-if01 :: JExpr -> JExpr
-if01 e = IfExpr e zero_ one_
-
--- | an expression application, see related 'appS'
---
--- > app f xs ==> f(xs)
-app :: FastString -> [JExpr] -> JExpr
-app f xs = ApplExpr (var f) xs
-
--- | A statement application, see the expression form 'app'
-appS :: FastString -> [JExpr] -> JStat
-appS f xs = ApplStat (var f) xs
-
--- | Return a 'JExpr'
-returnS :: JExpr -> JStat
-returnS e = ReturnStat e
-
--- | "for" loop with increment at end of body
-loop :: JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
-loop initial test body = jVar $ \i ->
-  mconcat [ i |= initial
-          , WhileStat False (test i) (body i)
-          ]
-
--- | "for" loop with increment at end of body
-loopBlockS :: JExpr -> (JExpr -> JExpr) -> (JExpr -> [JStat]) -> JStat
-loopBlockS initial test body = jVar $ \i ->
-  mconcat [ i |= initial
-          , WhileStat False (test i) (mconcat (body i))
-          ]
-
--- | Prefix-increment a 'JExpr'
-preIncrS :: JExpr -> JStat
-preIncrS x = UOpStat PreIncOp x
-
--- | Postfix-increment a 'JExpr'
-postIncrS :: JExpr -> JStat
-postIncrS x = UOpStat PostIncOp x
-
--- | Prefix-decrement a 'JExpr'
-preDecrS :: JExpr -> JStat
-preDecrS x = UOpStat PreDecOp x
-
--- | Postfix-decrement a 'JExpr'
-postDecrS :: JExpr -> JStat
-postDecrS x = UOpStat PostDecOp x
-
--- | Byte indexing of o with a 64-bit offset
-off64 :: JExpr -> JExpr -> JExpr
-off64 o i = Add o (i .<<. three_)
-
--- | Byte indexing of o with a 32-bit offset
-off32 :: JExpr -> JExpr -> JExpr
-off32 o i = Add o (i .<<. two_)
-
--- | Byte indexing of o with a 16-bit offset
-off16 :: JExpr -> JExpr -> JExpr
-off16 o i = Add o (i .<<. one_)
-
--- | Byte indexing of o with a 8-bit offset
-off8 :: JExpr -> JExpr -> JExpr
-off8 o i = Add o i
-
--- | a bit mask to retrieve the lower 8-bits
-mask8 :: JExpr -> JExpr
-mask8 x = BAnd x (Int 0xFF)
-
--- | a bit mask to retrieve the lower 16-bits
-mask16 :: JExpr -> JExpr
-mask16 x = BAnd x (Int 0xFFFF)
-
--- | Sign-extend/narrow a 8-bit value
-signExtend8 :: JExpr -> JExpr
-signExtend8 x = (BAnd x (Int 0x7F  )) `Sub` (BAnd x (Int 0x80))
-
--- | Sign-extend/narrow a 16-bit value
-signExtend16 :: JExpr -> JExpr
-signExtend16 x = (BAnd x (Int 0x7FFF)) `Sub` (BAnd x (Int 0x8000))
-
--- | Select a property 'prop', from and object 'obj'
---
--- > obj .^ prop ==> obj.prop
-(.^) :: JExpr -> FastString -> JExpr
-obj .^ prop = SelExpr obj (TxtI prop)
-infixl 8 .^
-
--- | Assign a variable to an expression
---
--- > foo |= expr ==> var foo = expr;
-(|=) :: JExpr -> JExpr -> JStat
-(|=) = AssignStat
-
--- | Declare a variable and then Assign the variable to an expression
---
--- > foo |= expr ==> var foo; foo = expr;
-(||=) :: Ident -> JExpr -> JStat
-i ||= ex = DeclStat i (Just ex)
-
-infixl 2 ||=, |=
-
--- | return the expression at idx of obj
---
--- > obj .! idx ==> obj[idx]
-(.!) :: JExpr -> JExpr -> JExpr
-(.!) = IdxExpr
-
-infixl 8 .!
-
-assignAllEqual :: HasDebugCallStack => [JExpr] -> [JExpr] -> JStat
-assignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" (|=) xs ys)
-
-assignAll :: [JExpr] -> [JExpr] -> JStat
-assignAll xs ys = mconcat (zipWith (|=) xs ys)
-
-assignAllReverseOrder :: [JExpr] -> [JExpr] -> JStat
-assignAllReverseOrder xs ys = mconcat (reverse (zipWith (|=) xs ys))
-
-declAssignAll :: [Ident] -> [JExpr] -> JStat
-declAssignAll xs ys = mconcat (zipWith (||=) xs ys)
-
-trace :: ToJExpr a => a -> JStat
-trace ex = appS "h$log" [toJExpr ex]
-
-
---------------------------------------------------------------------------------
---                             Literals
---------------------------------------------------------------------------------
--- $literals
--- Literals in the JS EDSL are constants in the Haskell domain. These are useful
--- helper values and never change
-
--- | The JS literal 'null'
-null_ :: JExpr
-null_ = var "null"
-
--- | The JS literal 0
-zero_ :: JExpr
-zero_ = Int 0
-
--- | The JS literal 1
-one_ :: JExpr
-one_ = Int 1
-
--- | The JS literal 2
-two_ :: JExpr
-two_ = Int 2
-
--- | The JS literal 3
-three_ :: JExpr
-three_ = Int 3
-
--- | The JS literal 'undefined'
-undefined_ :: JExpr
-undefined_ = var "undefined"
-
--- | The JS literal 'true'
-true_ :: JExpr
-true_ = var "true"
-
--- | The JS literal 'false'
-false_ :: JExpr
-false_ = var "false"
-
-returnStack :: JStat
-returnStack = ReturnStat (ApplExpr (var "h$rs") [])
-
-
---------------------------------------------------------------------------------
---                             Math functions
---------------------------------------------------------------------------------
--- $math
--- Math functions in the EDSL are literals, with the exception of 'math_' which
--- is the sole math introduction function.
-
-math :: JExpr
-math = var "Math"
-
-math_ :: FastString -> [JExpr] -> JExpr
-math_ op args = ApplExpr (math .^ op) args
-
-math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, math_atan,
-  math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh, math_sign,
-  math_sinh, math_cosh, math_tanh, math_expm1, math_log1p, math_fround
-  :: [JExpr] -> JExpr
-math_log   = math_ "log"
-math_sin   = math_ "sin"
-math_cos   = math_ "cos"
-math_tan   = math_ "tan"
-math_exp   = math_ "exp"
-math_acos  = math_ "acos"
-math_asin  = math_ "asin"
-math_atan  = math_ "atan"
-math_abs   = math_ "abs"
-math_pow   = math_ "pow"
-math_sign  = math_ "sign"
-math_sqrt  = math_ "sqrt"
-math_asinh = math_ "asinh"
-math_acosh = math_ "acosh"
-math_atanh = math_ "atanh"
-math_sinh  = math_ "sinh"
-math_cosh  = math_ "cosh"
-math_tanh  = math_ "tanh"
-math_expm1 = math_ "expm1"
-math_log1p = math_ "log1p"
-math_fround = math_ "fround"
-
-instance Num JExpr where
-    x + y = InfixExpr AddOp x y
-    x - y = InfixExpr SubOp x y
-    x * y = InfixExpr MulOp x y
-    abs x    = math_abs [x]
-    negate x = UOpExpr NegOp x
-    signum x = math_sign [x]
-    fromInteger x = ValExpr (JInt x)
-
-instance Fractional JExpr where
-    x / y = InfixExpr DivOp x y
-    fromRational x = ValExpr (JDouble (realToFrac x))
-
-
---------------------------------------------------------------------------------
---                             Miscellaneous
---------------------------------------------------------------------------------
--- $misc
--- Everything else,
-
--- | Cache "dXXX" field names
-dataFieldCache :: Array Int FastString
-dataFieldCache = listArray (0,nFieldCache) (map (mkFastString . ('d':) . show) [(0::Int)..nFieldCache])
-
-nFieldCache :: Int
-nFieldCache  = 16384
-
-dataFieldName :: Int -> FastString
-dataFieldName i
-  | i < 1 || i > nFieldCache = panic "dataFieldName" (ppr i)
-  | otherwise                = dataFieldCache ! i
-
-dataFieldNames :: [FastString]
-dataFieldNames = fmap dataFieldName [1..nFieldCache]
-
-
--- | Cache "h$dXXX" names
-dataCache :: Array Int FastString
-dataCache = listArray (0,1024) (map (mkFastString . ("h$d"++) . show) [(0::Int)..1024])
-
-allocData :: Int -> JExpr
-allocData i = toJExpr (TxtI (dataCache ! i))
-
--- | Cache "h$cXXX" names
-clsCache :: Array Int FastString
-clsCache = listArray (0,1024) (map (mkFastString . ("h$c"++) . show) [(0::Int)..1024])
-
-allocClsA :: Int -> JExpr
-allocClsA i = toJExpr (TxtI (clsCache ! i))
-
-
---------------------------------------------------------------------------------
--- New Identifiers
---------------------------------------------------------------------------------
-
--- | The 'ToSat' class is heavily used in the Introduction function. It ensures
--- that all identifiers in the EDSL are tracked and named with an 'IdentSupply'.
-class ToSat a where
-    toSat_ :: a -> [Ident] -> IdentSupply (JStat, [Ident])
-
-instance ToSat [JStat] where
-    toSat_ f vs = IS $ return $ (BlockStat f, reverse vs)
-
-instance ToSat JStat where
-    toSat_ f vs = IS $ return $ (f, reverse vs)
-
-instance ToSat JExpr where
-    toSat_ f vs = IS $ return $ (toStat f, reverse vs)
-
-instance ToSat [JExpr] where
-    toSat_ f vs = IS $ return $ (BlockStat $ map expr2stat f, reverse vs)
-
-instance (ToSat a, b ~ JExpr) => ToSat (b -> a) where
-    toSat_ f vs = IS $ do
-      x <- takeOneIdent
-      runIdentSupply $ toSat_ (f (ValExpr $ JVar x)) (x:vs)
-
--- | Convert A JS expression to a JS statement where applicable. This only
--- affects applications; 'ApplExpr', If-expressions; 'IfExpr', and Unary
--- expression; 'UOpExpr'.
-expr2stat :: JExpr -> JStat
-expr2stat (ApplExpr x y) = (ApplStat x y)
-expr2stat (IfExpr x y z) = IfStat x (expr2stat y) (expr2stat z)
-expr2stat (UOpExpr o x) = UOpStat o x
-expr2stat _ = nullStat
-
-takeOneIdent :: State [Ident] Ident
-takeOneIdent = do
-  xxs <- get
-  case xxs of
-    (x:xs) -> do
-      put xs
-      return x
-    _ -> error "takeOneIdent: empty list"
-
diff --git a/compiler/GHC/JS/Ppr.hs b/compiler/GHC/JS/Ppr.hs
deleted file mode 100644
--- a/compiler/GHC/JS/Ppr.hs
+++ /dev/null
@@ -1,294 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE BlockArguments #-}
-
--- For Outputable instances for JS syntax
-{-# OPTIONS_GHC -Wno-orphans #-}
-
--- | Pretty-printing JavaScript
-module GHC.JS.Ppr
-  ( renderJs
-  , renderJs'
-  , renderPrefixJs
-  , renderPrefixJs'
-  , JsToDoc(..)
-  , defaultRenderJs
-  , RenderJs(..)
-  , jsToDoc
-  , pprStringLit
-  , flattenBlocks
-  , braceNest
-  , hangBrace
-  )
-where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax
-import GHC.JS.Transform
-
-
-import Data.Char (isControl, ord)
-import Data.List (sortOn)
-
-import Numeric(showHex)
-
-import GHC.Utils.Outputable (Outputable (..), docToSDoc)
-import GHC.Utils.Ppr as PP
-import GHC.Data.FastString
-import GHC.Types.Unique.Map
-
-instance Outputable JExpr where
-  ppr = docToSDoc . renderJs
-
-instance Outputable JVal where
-  ppr = docToSDoc . renderJs
-
-
-($$$) :: Doc -> Doc -> Doc
-x $$$ y = nest 2 $ x $+$ y
-
--- | Render a syntax tree as a pretty-printable document
--- (simply showing the resultant doc produces a nice,
--- well formatted String).
-renderJs :: (JsToDoc a, JMacro a) => a -> Doc
-renderJs = renderJs' defaultRenderJs
-
-renderJs' :: (JsToDoc a, JMacro a) => RenderJs -> a -> Doc
-renderJs' r = jsToDocR r . jsSaturate Nothing
-
-data RenderJs = RenderJs
-  { renderJsS :: !(RenderJs -> JStat -> Doc)
-  , renderJsE :: !(RenderJs -> JExpr -> Doc)
-  , renderJsV :: !(RenderJs -> JVal  -> Doc)
-  , renderJsI :: !(RenderJs -> Ident -> Doc)
-  }
-
-defaultRenderJs :: RenderJs
-defaultRenderJs = RenderJs defRenderJsS defRenderJsE defRenderJsV defRenderJsI
-
-jsToDoc :: JsToDoc a => a -> Doc
-jsToDoc = jsToDocR defaultRenderJs
-
--- | Render a syntax tree as a pretty-printable document, using a given prefix
--- to all generated names. Use this with distinct prefixes to ensure distinct
--- generated names between independent calls to render(Prefix)Js.
-renderPrefixJs :: (JsToDoc a, JMacro a) => FastString -> a -> Doc
-renderPrefixJs pfx = renderPrefixJs' defaultRenderJs pfx
-
-renderPrefixJs' :: (JsToDoc a, JMacro a) => RenderJs -> FastString -> a -> Doc
-renderPrefixJs' r pfx = jsToDocR r . jsSaturate (Just $ "jmId_" `mappend` pfx)
-
-braceNest :: Doc -> Doc
-braceNest x = char '{' <+> nest 2 x $$ char '}'
-
--- | Hang with braces:
---
---  hdr {
---    body
---  }
-hangBrace :: Doc -> Doc -> Doc
-hangBrace hdr body = sep [ hdr <> char ' ' <> char '{', nest 2 body, char '}' ]
-
-class JsToDoc a where jsToDocR :: RenderJs -> a -> Doc
-instance JsToDoc JStat where jsToDocR r = renderJsS r r
-instance JsToDoc JExpr where jsToDocR r = renderJsE r r
-instance JsToDoc JVal  where jsToDocR r = renderJsV r r
-instance JsToDoc Ident where jsToDocR r = renderJsI r r
-instance JsToDoc [JExpr] where
-    jsToDocR r = vcat . map ((<> semi) . jsToDocR r)
-instance JsToDoc [JStat] where
-    jsToDocR r = vcat . map ((<> semi) . jsToDocR r)
-
-defRenderJsS :: RenderJs -> JStat -> Doc
-defRenderJsS r = \case
-  IfStat cond x y -> hangBrace (text "if" <> parens (jsToDocR r cond))
-                               (jsToDocR r x)
-                     $$ mbElse
-        where mbElse | y == BlockStat []  = PP.empty
-                     | otherwise = hangBrace (text "else") (jsToDocR r y)
-  DeclStat x Nothing  -> text "var" <+> jsToDocR r x
-  DeclStat x (Just e) -> text "var" <+> jsToDocR r x <+> char '=' <+> jsToDocR r e
-  WhileStat False p b -> hangBrace (text "while" <> parens (jsToDocR r p)) (jsToDocR r b)
-  WhileStat True  p b -> (hangBrace (text "do") (jsToDocR r b)) $+$ text "while" <+> parens (jsToDocR r p)
-  UnsatBlock e        -> jsToDocR r $ pseudoSaturate e
-  BreakStat l         -> maybe (text "break")    (\(LexicalFastString s) -> (text "break"    <+> ftext s)) l
-  ContinueStat l      -> maybe (text "continue") (\(LexicalFastString s) -> (text "continue" <+> ftext s)) l
-  LabelStat (LexicalFastString l) s -> ftext l <> char ':' $$ printBS s
-        where
-          printBS (BlockStat ss) = vcat $ interSemi $ flattenBlocks ss
-          printBS x = jsToDocR r x
-          interSemi [x] = [jsToDocR r x]
-          interSemi [] = []
-          interSemi (x:xs) = (jsToDocR r x <> semi) : interSemi xs
-
-  ForInStat each i e b -> hangBrace (text txt <> parens (jsToDocR r i <+> text "in" <+> jsToDocR r e)) (jsToDocR r b)
-        where txt | each = "for each"
-                  | otherwise = "for"
-  SwitchStat e l d     -> hangBrace (text "switch" <+> parens (jsToDocR r e)) cases
-        where l' = map (\(c,s) -> (text "case" <+> parens (jsToDocR r c) <> char ':') $$$ (jsToDocR r s)) l ++ [text "default:" $$$ (jsToDocR r d)]
-              cases = vcat l'
-  ReturnStat e      -> text "return" <+> jsToDocR r e
-  ApplStat e es     -> jsToDocR r e <> (parens . hsep . punctuate comma $ map (jsToDocR r) es)
-  TryStat s i s1 s2 -> hangBrace (text "try") (jsToDocR r s) $$ mbCatch $$ mbFinally
-        where mbCatch | s1 == BlockStat [] = PP.empty
-                      | otherwise = hangBrace (text "catch" <> parens (jsToDocR r i)) (jsToDocR r s1)
-              mbFinally | s2 == BlockStat [] = PP.empty
-                        | otherwise = hangBrace (text "finally") (jsToDocR r s2)
-  AssignStat i x    -> case x of
-    -- special treatment for functions, otherwise there is too much left padding
-    -- (more than the length of the expression assigned to). E.g.
-    --
-    --    var long_variable_name = (function()
-    --                               {
-    --                               ...
-    --                             });
-    --
-    ValExpr (JFunc is b) -> sep [jsToDocR r i <+> text "= function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is) <> char '{', nest 2 (jsToDocR r b), text "}"]
-    _                    -> jsToDocR r i <+> char '=' <+> jsToDocR r x
-  UOpStat op x
-    | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x
-    | isPre op                 -> ftext (uOpText op) <> optParens r x
-    | otherwise                -> optParens r x <> ftext (uOpText op)
-  BlockStat xs -> jsToDocR r (flattenBlocks xs)
-
-flattenBlocks :: [JStat] -> [JStat]
-flattenBlocks = \case
-  BlockStat y:ys -> flattenBlocks y ++ flattenBlocks ys
-  y:ys           -> y : flattenBlocks ys
-  []             -> []
-
-optParens :: RenderJs -> JExpr -> Doc
-optParens r x = case x of
-  UOpExpr _ _ -> parens (jsToDocR r x)
-  _           -> jsToDocR r x
-
-defRenderJsE :: RenderJs -> JExpr -> Doc
-defRenderJsE r = \case
-  ValExpr x         -> jsToDocR r x
-  SelExpr x y       -> jsToDocR r x <> char '.' <> jsToDocR r y
-  IdxExpr x y       -> jsToDocR r x <> brackets (jsToDocR r y)
-  IfExpr x y z      -> parens (jsToDocR r x <+> char '?' <+> jsToDocR r y <+> char ':' <+> jsToDocR r z)
-  InfixExpr op x y  -> parens $ hsep [jsToDocR r x, ftext (opText op), jsToDocR r y]
-  UOpExpr op x
-    | isPre op && isAlphaOp op -> ftext (uOpText op) <+> optParens r x
-    | isPre op                 -> ftext (uOpText op) <> optParens r x
-    | otherwise                -> optParens r x <> ftext (uOpText op)
-  ApplExpr je xs -> jsToDocR r je <> (parens . hsep . punctuate comma $ map (jsToDocR r) xs)
-  UnsatExpr e    -> jsToDocR r $ pseudoSaturate e
-
-defRenderJsV :: RenderJs -> JVal -> Doc
-defRenderJsV r = \case
-  JVar i    -> jsToDocR r i
-  JList xs  -> brackets . hsep . punctuate comma $ map (jsToDocR r) xs
-  JDouble (SaneDouble d)
-    | d < 0 || isNegativeZero d -> parens (double d)
-    | otherwise                 -> double d
-  JInt i
-    | i < 0     -> parens (integer i)
-    | otherwise -> integer i
-  JStr   s -> pprStringLit s
-  JRegEx s -> hcat [char '/',ftext s, char '/']
-  JHash m
-    | isNullUniqMap m  -> text "{}"
-    | otherwise -> braceNest . hsep . punctuate comma .
-                          map (\(x,y) -> squotes (ftext x) <> colon <+> jsToDocR r y)
-                          -- nonDetEltsUniqMap doesn't introduce non-determinism here
-                          -- because we sort the elements lexically
-                          $ sortOn (LexicalFastString . fst) (nonDetEltsUniqMap m)
-  JFunc is b -> parens $ hangBrace (text "function" <> parens (hsep . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b)
-  UnsatVal f -> jsToDocR r $ pseudoSaturate f
-
-defRenderJsI :: RenderJs -> Ident -> Doc
-defRenderJsI _ (TxtI t) = ftext t
-
-
-pprStringLit :: FastString -> Doc
-pprStringLit s = hcat [char '\"',encodeJson s, char '\"']
-
-encodeJson :: FastString -> Doc
-encodeJson xs = hcat (map encodeJsonChar (unpackFS xs))
-
-encodeJsonChar :: Char -> Doc
-encodeJsonChar = \case
-  '/'  -> text "\\/"
-  '\b' -> text "\\b"
-  '\f' -> text "\\f"
-  '\n' -> text "\\n"
-  '\r' -> text "\\r"
-  '\t' -> text "\\t"
-  '"'  -> text "\\\""
-  '\\' -> text "\\\\"
-  c
-    | not (isControl c) && ord c <= 127 -> char c
-    | ord c <= 0xff   -> hexxs "\\x" 2 (ord c)
-    | ord c <= 0xffff -> hexxs "\\u" 4 (ord c)
-    | otherwise      -> let cp0 = ord c - 0x10000 -- output surrogate pair
-                        in hexxs "\\u" 4 ((cp0 `shiftR` 10) + 0xd800) <>
-                           hexxs "\\u" 4 ((cp0 .&. 0x3ff) + 0xdc00)
-    where hexxs prefix pad cp =
-            let h = showHex cp ""
-            in  text (prefix ++ replicate (pad - length h) '0' ++ h)
-
-uOpText :: JUOp -> FastString
-uOpText = \case
-  NotOp     -> "!"
-  BNotOp    -> "~"
-  NegOp     -> "-"
-  PlusOp    -> "+"
-  NewOp     -> "new"
-  TypeofOp  -> "typeof"
-  DeleteOp  -> "delete"
-  YieldOp   -> "yield"
-  VoidOp    -> "void"
-  PreIncOp  -> "++"
-  PostIncOp -> "++"
-  PreDecOp  -> "--"
-  PostDecOp -> "--"
-
-opText :: JOp -> FastString
-opText = \case
-  EqOp          -> "=="
-  StrictEqOp    -> "==="
-  NeqOp         -> "!="
-  StrictNeqOp   -> "!=="
-  GtOp          -> ">"
-  GeOp          -> ">="
-  LtOp          -> "<"
-  LeOp          -> "<="
-  AddOp         -> "+"
-  SubOp         -> "-"
-  MulOp         -> "*"
-  DivOp         -> "/"
-  ModOp         -> "%"
-  LeftShiftOp   -> "<<"
-  RightShiftOp  -> ">>"
-  ZRightShiftOp -> ">>>"
-  BAndOp        -> "&"
-  BOrOp         -> "|"
-  BXorOp        -> "^"
-  LAndOp        -> "&&"
-  LOrOp         -> "||"
-  InstanceofOp  -> "instanceof"
-  InOp          -> "in"
-
-
-isPre :: JUOp -> Bool
-isPre = \case
-  PostIncOp -> False
-  PostDecOp -> False
-  _         -> True
-
-isAlphaOp :: JUOp -> Bool
-isAlphaOp = \case
-  NewOp    -> True
-  TypeofOp -> True
-  DeleteOp -> True
-  YieldOp  -> True
-  VoidOp   -> True
-  _        -> False
diff --git a/compiler/GHC/JS/Syntax.hs b/compiler/GHC/JS/Syntax.hs
deleted file mode 100644
--- a/compiler/GHC/JS/Syntax.hs
+++ /dev/null
@@ -1,392 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DerivingVia #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE PatternSynonyms #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.JS.Syntax
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
---
--- * Domain and Purpose
---
---     GHC.JS.Syntax defines the Syntax for the JS backend in GHC. It comports
---     with the [ECMA-262](https://tc39.es/ecma262/) although not every
---     production rule of the standard is represented. Code in this module is a
---     fork of [JMacro](https://hackage.haskell.org/package/jmacro) (BSD 3
---     Clause) by Gershom Bazerman, heavily modified to accomodate GHC's
---     constraints.
---
---
--- * Strategy
---
---     Nothing fancy in this module, this is a classic deeply embeded AST for
---     JS. We define numerous ADTs and pattern synonyms to make pattern matching
---     and constructing ASTs easier.
---
---
--- * Consumers
---
---     The entire JS backend consumes this module, e.g., the modules in
---     GHC.StgToJS.\*. Please see 'GHC.JS.Make' for a module which provides
---     helper functions that use the deeply embedded DSL defined in this module
---     to provide some of the benefits of a shallow embedding.
------------------------------------------------------------------------------
-module GHC.JS.Syntax
-  ( -- * Deeply embedded JS datatypes
-    JStat(..)
-  , JExpr(..)
-  , JVal(..)
-  , JOp(..)
-  , JUOp(..)
-  , Ident(..)
-  , identFS
-  , JsLabel
-  -- * pattern synonyms over JS operators
-  , pattern New
-  , pattern Not
-  , pattern Negate
-  , pattern Add
-  , pattern Sub
-  , pattern Mul
-  , pattern Div
-  , pattern Mod
-  , pattern BOr
-  , pattern BAnd
-  , pattern BXor
-  , pattern BNot
-  , pattern LOr
-  , pattern LAnd
-  , pattern Int
-  , pattern String
-  , pattern PreInc
-  , pattern PostInc
-  , pattern PreDec
-  , pattern PostDec
-  -- * Ident supply
-  , IdentSupply(..)
-  , newIdentSupply
-  , pseudoSaturate
-  -- * Utility
-  , SaneDouble(..)
-  ) where
-
-import GHC.Prelude
-
-import Control.DeepSeq
-
-import Data.Function
-import Data.Data
-import Data.Word
-import qualified Data.Semigroup as Semigroup
-
-import GHC.Generics
-
-import GHC.Data.FastString
-import GHC.Utils.Monad.State.Strict
-import GHC.Types.Unique
-import GHC.Types.Unique.Map
-
--- | A supply of identifiers, possibly empty
-newtype IdentSupply a
-  = IS {runIdentSupply :: State [Ident] a}
-  deriving Typeable
-
-instance NFData (IdentSupply a) where rnf IS{} = ()
-
-inIdentSupply :: (State [Ident] a -> State [Ident] b) -> IdentSupply a -> IdentSupply b
-inIdentSupply f x = IS $ f (runIdentSupply x)
-
-instance Functor IdentSupply where
-    fmap f x = inIdentSupply (fmap f) x
-
-newIdentSupply :: Maybe FastString -> [Ident]
-newIdentSupply Nothing    = newIdentSupply (Just "jmId")
-newIdentSupply (Just pfx) = [ TxtI (mconcat [pfx,"_",mkFastString (show x)])
-                            | x <- [(0::Word64)..]
-                            ]
-
--- | Given a Pseudo-saturate a value with garbage @<<unsatId>>@ identifiers.
-pseudoSaturate :: IdentSupply a -> a
-pseudoSaturate x = evalState (runIdentSupply x) $ newIdentSupply (Just "<<unsatId>>")
-
-instance Eq a => Eq (IdentSupply a) where
-    (==) = (==) `on` pseudoSaturate
-instance Ord a => Ord (IdentSupply a) where
-    compare = compare `on` pseudoSaturate
-instance Show a => Show (IdentSupply a) where
-    show x = "(" ++ show (pseudoSaturate x) ++ ")"
-
-
---------------------------------------------------------------------------------
---                            Statements
---------------------------------------------------------------------------------
--- | JavaScript statements, see the [ECMA262
--- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations)
--- for details
-data JStat
-  = DeclStat   !Ident !(Maybe JExpr)         -- ^ Variable declarations: var foo [= e]
-  | ReturnStat JExpr                         -- ^ Return
-  | IfStat     JExpr JStat JStat             -- ^ If
-  | WhileStat  Bool JExpr JStat              -- ^ While, bool is "do" when True
-  | ForInStat  Bool Ident JExpr JStat        -- ^ For-in, bool is "each' when True
-  | SwitchStat JExpr [(JExpr, JStat)] JStat  -- ^ Switch
-  | TryStat    JStat Ident JStat JStat       -- ^ Try
-  | BlockStat  [JStat]                       -- ^ Blocks
-  | ApplStat   JExpr [JExpr]                 -- ^ Application
-  | UOpStat JUOp JExpr                       -- ^ Unary operators
-  | AssignStat JExpr JExpr                   -- ^ Binding form: @foo = bar@
-  | UnsatBlock (IdentSupply JStat)           -- ^ /Unsaturated/ blocks see 'pseudoSaturate'
-  | LabelStat JsLabel JStat                  -- ^ Statement Labels, makes me nostalgic for qbasic
-  | BreakStat (Maybe JsLabel)                -- ^ Break
-  | ContinueStat (Maybe JsLabel)             -- ^ Continue
-  deriving (Eq, Typeable, Generic)
-
--- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of
--- course 'LabelStat'
-type JsLabel = LexicalFastString
-
-instance Semigroup JStat where
-  (<>) = appendJStat
-
-instance Monoid JStat where
-  mempty = BlockStat []
-
--- | Append a statement to another statement. 'appendJStat' only returns a
--- 'JStat' that is /not/ a 'BlockStat' when either @mx@ or @my is an empty
--- 'BlockStat'. That is:
--- > (BlockStat [] , y           ) = y
--- > (x            , BlockStat []) = x
-appendJStat :: JStat -> JStat -> JStat
-appendJStat mx my = case (mx,my) of
-  (BlockStat [] , y           ) -> y
-  (x            , BlockStat []) -> x
-  (BlockStat xs , BlockStat ys) -> BlockStat $ xs ++ ys
-  (BlockStat xs , ys          ) -> BlockStat $ xs ++ [ys]
-  (xs           , BlockStat ys) -> BlockStat $ xs : ys
-  (xs           , ys          ) -> BlockStat [xs,ys]
-
-
---------------------------------------------------------------------------------
---                            Expressions
---------------------------------------------------------------------------------
--- | JavaScript Expressions
-data JExpr
-  = ValExpr    JVal                 -- ^ All values are trivially expressions
-  | SelExpr    JExpr Ident          -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^'
-  | IdxExpr    JExpr JExpr          -- ^ Indexing:  Obj[foo], see 'GHC.JS.Make..!'
-  | InfixExpr  JOp JExpr JExpr      -- ^ Infix Expressions, see 'JExpr'
-                                    --   pattern synonyms
-  | UOpExpr    JUOp JExpr           -- ^ Unary Expressions
-  | IfExpr     JExpr JExpr JExpr    -- ^ If-expression
-  | ApplExpr   JExpr [JExpr]        -- ^ Application
-  | UnsatExpr  (IdentSupply JExpr)  -- ^ An /Unsaturated/ expression.
-                                    --   See 'pseudoSaturate'
-  deriving (Eq, Typeable, Generic)
-
--- * Useful pattern synonyms to ease programming with the deeply embedded JS
---   AST. Each pattern wraps @JUOp@ and @JOp@ into a @JExpr@s to save typing and
---   for convienience. In addition we include a string wrapper for JS string
---   and Integer literals.
-
--- | pattern synonym for a unary operator new
-pattern New :: JExpr -> JExpr
-pattern New x = UOpExpr NewOp x
-
--- | pattern synonym for prefix increment @++x@
-pattern PreInc :: JExpr -> JExpr
-pattern PreInc x = UOpExpr PreIncOp x
-
--- | pattern synonym for postfix increment @x++@
-pattern PostInc :: JExpr -> JExpr
-pattern PostInc x = UOpExpr PostIncOp x
-
--- | pattern synonym for prefix decrement @--x@
-pattern PreDec :: JExpr -> JExpr
-pattern PreDec x = UOpExpr PreDecOp x
-
--- | pattern synonym for postfix decrement @--x@
-pattern PostDec :: JExpr -> JExpr
-pattern PostDec x = UOpExpr PostDecOp x
-
--- | pattern synonym for logical not @!@
-pattern Not :: JExpr -> JExpr
-pattern Not x = UOpExpr NotOp x
-
--- | pattern synonym for unary negation @-@
-pattern Negate :: JExpr -> JExpr
-pattern Negate x = UOpExpr NegOp x
-
--- | pattern synonym for addition @+@
-pattern Add :: JExpr -> JExpr -> JExpr
-pattern Add x y = InfixExpr AddOp x y
-
--- | pattern synonym for subtraction @-@
-pattern Sub :: JExpr -> JExpr -> JExpr
-pattern Sub x y = InfixExpr SubOp x y
-
--- | pattern synonym for multiplication @*@
-pattern Mul :: JExpr -> JExpr -> JExpr
-pattern Mul x y = InfixExpr MulOp x y
-
--- | pattern synonym for division @*@
-pattern Div :: JExpr -> JExpr -> JExpr
-pattern Div x y = InfixExpr DivOp x y
-
--- | pattern synonym for remainder @%@
-pattern Mod :: JExpr -> JExpr -> JExpr
-pattern Mod x y = InfixExpr ModOp x y
-
--- | pattern synonym for Bitwise Or @|@
-pattern BOr :: JExpr -> JExpr -> JExpr
-pattern BOr x y = InfixExpr BOrOp x y
-
--- | pattern synonym for Bitwise And @&@
-pattern BAnd :: JExpr -> JExpr -> JExpr
-pattern BAnd x y = InfixExpr BAndOp x y
-
--- | pattern synonym for Bitwise XOr @^@
-pattern BXor :: JExpr -> JExpr -> JExpr
-pattern BXor x y = InfixExpr BXorOp x y
-
--- | pattern synonym for Bitwise Not @~@
-pattern BNot :: JExpr -> JExpr
-pattern BNot x = UOpExpr BNotOp x
-
--- | pattern synonym for logical Or @||@
-pattern LOr :: JExpr -> JExpr -> JExpr
-pattern LOr x y = InfixExpr LOrOp x y
-
--- | pattern synonym for logical And @&&@
-pattern LAnd :: JExpr -> JExpr -> JExpr
-pattern LAnd x y = InfixExpr LAndOp x y
-
-
--- | pattern synonym to create integer values
-pattern Int :: Integer -> JExpr
-pattern Int x = ValExpr (JInt x)
-
--- | pattern synonym to create string values
-pattern String :: FastString -> JExpr
-pattern String x = ValExpr (JStr x)
-
-
---------------------------------------------------------------------------------
---                            Values
---------------------------------------------------------------------------------
--- | JavaScript values
-data JVal
-  = JVar     Ident                      -- ^ A variable reference
-  | JList    [JExpr]                    -- ^ A JavaScript list, or what JS
-                                        --   calls an Array
-  | JDouble  SaneDouble                 -- ^ A Double
-  | JInt     Integer                    -- ^ A BigInt
-  | JStr     FastString                 -- ^ A String
-  | JRegEx   FastString                 -- ^ A Regex
-  | JHash    (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@
-  | JFunc    [Ident] JStat              -- ^ A function
-  | UnsatVal (IdentSupply JVal)         -- ^ An /Unsaturated/ value, see 'pseudoSaturate'
-  deriving (Eq, Typeable, Generic)
-
---------------------------------------------------------------------------------
---                            Operators
---------------------------------------------------------------------------------
--- | JS Binary Operators. We do not deeply embed the comma operator and the
--- assignment operators
-data JOp
-  = EqOp            -- ^ Equality:              `==`
-  | StrictEqOp      -- ^ Strict Equality:       `===`
-  | NeqOp           -- ^ InEquality:            `!=`
-  | StrictNeqOp     -- ^ Strict InEquality      `!==`
-  | GtOp            -- ^ Greater Than:          `>`
-  | GeOp            -- ^ Greater Than or Equal: `>=`
-  | LtOp            -- ^ Less Than:              <
-  | LeOp            -- ^ Less Than or Equal:     <=
-  | AddOp           -- ^ Addition:               +
-  | SubOp           -- ^ Subtraction:            -
-  | MulOp           -- ^ Multiplication          \*
-  | DivOp           -- ^ Division:               \/
-  | ModOp           -- ^ Remainder:              %
-  | LeftShiftOp     -- ^ Left Shift:             \<\<
-  | RightShiftOp    -- ^ Right Shift:            \>\>
-  | ZRightShiftOp   -- ^ Unsigned RightShift:    \>\>\>
-  | BAndOp          -- ^ Bitwise And:            &
-  | BOrOp           -- ^ Bitwise Or:             |
-  | BXorOp          -- ^ Bitwise XOr:            ^
-  | LAndOp          -- ^ Logical And:            &&
-  | LOrOp           -- ^ Logical Or:             ||
-  | InstanceofOp    -- ^ @instanceof@
-  | InOp            -- ^ @in@
-  deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic)
-
-instance NFData JOp
-
--- | JS Unary Operators
-data JUOp
-  = NotOp           -- ^ Logical Not: @!@
-  | BNotOp          -- ^ Bitwise Not: @~@
-  | NegOp           -- ^ Negation:    @-@
-  | PlusOp          -- ^ Unary Plus:  @+x@
-  | NewOp           -- ^ new    x
-  | TypeofOp        -- ^ typeof x
-  | DeleteOp        -- ^ delete x
-  | YieldOp         -- ^ yield  x
-  | VoidOp          -- ^ void   x
-  | PreIncOp        -- ^ Prefix Increment:  @++x@
-  | PostIncOp       -- ^ Postfix Increment: @x++@
-  | PreDecOp        -- ^ Prefix Decrement:  @--x@
-  | PostDecOp       -- ^ Postfix Decrement: @x--@
-  deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic)
-
-instance NFData JUOp
-
--- | A newtype wrapper around 'Double' to ensure we never generate a 'Double'
--- that becomes a 'NaN', see 'Eq SaneDouble', 'Ord SaneDouble' for details on
--- Sane-ness
-newtype SaneDouble = SaneDouble
-  { unSaneDouble :: Double
-  }
-  deriving (Data, Typeable, Fractional, Num, Generic, NFData)
-
-instance Eq SaneDouble where
-    (SaneDouble x) == (SaneDouble y) = x == y || (isNaN x && isNaN y)
-
-instance Ord SaneDouble where
-    compare (SaneDouble x) (SaneDouble y) = compare (fromNaN x) (fromNaN y)
-        where fromNaN z | isNaN z = Nothing
-                        | otherwise = Just z
-
-instance Show SaneDouble where
-    show (SaneDouble x) = show x
-
-
---------------------------------------------------------------------------------
---                            Identifiers
---------------------------------------------------------------------------------
--- We use FastString for identifiers in JS backend
-
--- | A newtype wrapper around 'FastString' for JS identifiers.
-newtype Ident = TxtI { itxt :: FastString }
- deriving stock   (Show, Eq)
- deriving newtype (Uniquable)
-
-identFS :: Ident -> FastString
-identFS = \case
-  TxtI fs -> fs
diff --git a/compiler/GHC/JS/Transform.hs b/compiler/GHC/JS/Transform.hs
deleted file mode 100644
--- a/compiler/GHC/JS/Transform.hs
+++ /dev/null
@@ -1,264 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE BlockArguments #-}
-
-module GHC.JS.Transform
-  ( mapIdent
-  , mapStatIdent
-  , mapExprIdent
-  , identsS
-  , identsV
-  , identsE
-  -- * Saturation
-  , jsSaturate
-  -- * Generic traversal (via compos)
-  , JMacro(..)
-  , JMGadt(..)
-  , Compos(..)
-  , composOp
-  , composOpM
-  , composOpM_
-  , composOpFold
-  )
-where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax
-
-import Data.Functor.Identity
-import Control.Monad
-import Data.Bifunctor
-
-import GHC.Data.FastString
-import GHC.Utils.Monad.State.Strict
-import GHC.Types.Unique.Map
-
-mapExprIdent :: (Ident -> JExpr) -> JExpr -> JExpr
-mapExprIdent f = fst (mapIdent f)
-
-mapStatIdent :: (Ident -> JExpr) -> JStat -> JStat
-mapStatIdent f = snd (mapIdent f)
-
--- | Map on every variable ident
-mapIdent :: (Ident -> JExpr) -> (JExpr -> JExpr, JStat -> JStat)
-mapIdent f = (map_expr, map_stat)
-  where
-    map_expr = \case
-      ValExpr    v        -> map_val v
-      SelExpr    e i      -> SelExpr (map_expr e) i
-      IdxExpr    e1 e2    -> IdxExpr (map_expr e1) (map_expr e2)
-      InfixExpr  o e1 e2  -> InfixExpr o (map_expr e1) (map_expr e2)
-      UOpExpr    o e      -> UOpExpr o (map_expr e)
-      IfExpr     e1 e2 e3 -> IfExpr (map_expr e1) (map_expr e2) (map_expr e3)
-      ApplExpr   e es     -> ApplExpr (map_expr e) (fmap map_expr es)
-      UnsatExpr  me       -> UnsatExpr (fmap map_expr me)
-
-    map_val v = case v of
-      JVar     i  -> f i
-      JList    es -> ValExpr $ JList (fmap map_expr es)
-      JDouble{}   -> ValExpr $ v
-      JInt{}      -> ValExpr $ v
-      JStr{}      -> ValExpr $ v
-      JRegEx{}    -> ValExpr $ v
-      JHash me    -> ValExpr $ JHash (fmap map_expr me)
-      JFunc is s  -> ValExpr $ JFunc is (map_stat s)
-      UnsatVal v2 -> ValExpr $ UnsatVal v2
-
-    map_stat s = case s of
-      DeclStat i e          -> DeclStat i (fmap map_expr e)
-      ReturnStat e          -> ReturnStat (map_expr e)
-      IfStat     e s1 s2    -> IfStat (map_expr e) (map_stat s1) (map_stat s2)
-      WhileStat  b e s2     -> WhileStat b (map_expr e) (map_stat s2)
-      ForInStat  b i e s2   -> ForInStat b i (map_expr e) (map_stat s2)
-      SwitchStat e les s2   -> SwitchStat (map_expr e) (fmap (bimap map_expr map_stat) les) (map_stat s2)
-      TryStat    s2 i s3 s4 -> TryStat (map_stat s2) i (map_stat s3) (map_stat s4)
-      BlockStat  ls         -> BlockStat (fmap map_stat ls)
-      ApplStat   e es       -> ApplStat (map_expr e) (fmap map_expr es)
-      UOpStat    o e        -> UOpStat o (map_expr e)
-      AssignStat e1 e2      -> AssignStat (map_expr e1) (map_expr e2)
-      UnsatBlock ms         -> UnsatBlock (fmap map_stat ms)
-      LabelStat  l s2       -> LabelStat l (map_stat s2)
-      BreakStat{}           -> s
-      ContinueStat{}        -> s
-
-{-# INLINE identsS #-}
-identsS :: JStat -> [Ident]
-identsS = \case
-  DeclStat i e       -> [i] ++ maybe [] identsE e
-  ReturnStat e       -> identsE e
-  IfStat e s1 s2     -> identsE e ++ identsS s1 ++ identsS s2
-  WhileStat _ e s    -> identsE e ++ identsS s
-  ForInStat _ i e s  -> [i] ++ identsE e ++ identsS s
-  SwitchStat e xs s  -> identsE e ++ concatMap traverseCase xs ++ identsS s
-                          where traverseCase (e,s) = identsE e ++ identsS s
-  TryStat s1 i s2 s3 -> identsS s1 ++ [i] ++ identsS s2 ++ identsS s3
-  BlockStat xs       -> concatMap identsS xs
-  ApplStat e es      -> identsE e ++ concatMap identsE es
-  UOpStat _op e      -> identsE e
-  AssignStat e1 e2   -> identsE e1 ++ identsE e2
-  UnsatBlock{}       -> error "identsS: UnsatBlock"
-  LabelStat _l s     -> identsS s
-  BreakStat{}        -> []
-  ContinueStat{}     -> []
-
-{-# INLINE identsE #-}
-identsE :: JExpr -> [Ident]
-identsE = \case
-  ValExpr v         -> identsV v
-  SelExpr e _i      -> identsE e -- do not rename properties
-  IdxExpr e1 e2     -> identsE e1 ++ identsE e2
-  InfixExpr _ e1 e2 -> identsE e1 ++ identsE e2
-  UOpExpr _ e       -> identsE e
-  IfExpr e1 e2 e3   -> identsE e1 ++ identsE e2 ++ identsE e3
-  ApplExpr e es     -> identsE e  ++ concatMap identsE es
-  UnsatExpr{}       -> error "identsE: UnsatExpr"
-
-{-# INLINE identsV #-}
-identsV :: JVal -> [Ident]
-identsV = \case
-  JVar i       -> [i]
-  JList xs     -> concatMap identsE xs
-  JDouble{}    -> []
-  JInt{}       -> []
-  JStr{}       -> []
-  JRegEx{}     -> []
-  JHash m      -> concatMap (identsE . snd) (nonDetEltsUniqMap m)
-  JFunc args s -> args ++ identsS s
-  UnsatVal{}   -> error "identsV: UnsatVal"
-
-
-{--------------------------------------------------------------------
-  Compos
---------------------------------------------------------------------}
--- | Compos and ops for generic traversal as defined over
--- the JMacro ADT.
-
--- | Utility class to coerce the ADT into a regular structure.
-
-class JMacro a where
-    jtoGADT :: a -> JMGadt a
-    jfromGADT :: JMGadt a -> a
-
-instance JMacro Ident where
-    jtoGADT = JMGId
-    jfromGADT (JMGId x) = x
-
-instance JMacro JStat where
-    jtoGADT = JMGStat
-    jfromGADT (JMGStat x) = x
-
-instance JMacro JExpr where
-    jtoGADT = JMGExpr
-    jfromGADT (JMGExpr x) = x
-
-instance JMacro JVal where
-    jtoGADT = JMGVal
-    jfromGADT (JMGVal x) = x
-
--- | Union type to allow regular traversal by compos.
-data JMGadt a where
-    JMGId   :: Ident -> JMGadt Ident
-    JMGStat :: JStat -> JMGadt JStat
-    JMGExpr :: JExpr -> JMGadt JExpr
-    JMGVal  :: JVal  -> JMGadt JVal
-
-composOp :: Compos t => (forall a. t a -> t a) -> t b -> t b
-composOp f = runIdentity . composOpM (Identity . f)
-
-composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t b -> m (t b)
-composOpM = compos return ap
-
-composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t b -> m ()
-composOpM_ = composOpFold (return ()) (>>)
-
-composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b
-composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f)
-
-newtype C b a = C { unC :: b }
-
-class Compos t where
-    compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)
-           -> (forall a. t a -> m (t a)) -> t c -> m (t c)
-
-instance Compos JMGadt where
-    compos = jmcompos
-
-jmcompos :: forall m c. (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) -> (forall a. JMGadt a -> m (JMGadt a)) -> JMGadt c -> m (JMGadt c)
-jmcompos ret app f' v =
-    case v of
-     JMGId _ -> ret v
-     JMGStat v' -> ret JMGStat `app` case v' of
-           DeclStat i e -> ret DeclStat `app` f i `app` mapMaybeM' f e
-           ReturnStat i -> ret ReturnStat `app` f i
-           IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s'
-           WhileStat b e s -> ret (WhileStat b) `app` f e `app` f s
-           ForInStat b i e s -> ret (ForInStat b) `app` f i `app` f e `app` f s
-           SwitchStat e l d -> ret SwitchStat `app` f e `app` l' `app` f d
-               where l' = mapM' (\(c,s) -> ret (,) `app` f c `app` f s) l
-           BlockStat xs -> ret BlockStat `app` mapM' f xs
-           ApplStat  e xs -> ret ApplStat `app` f e `app` mapM' f xs
-           TryStat s i s1 s2 -> ret TryStat `app` f s `app` f i `app` f s1 `app` f s2
-           UOpStat o e -> ret (UOpStat o) `app` f e
-           AssignStat e e' -> ret AssignStat `app` f e `app` f e'
-           UnsatBlock _ -> ret v'
-           ContinueStat l -> ret (ContinueStat l)
-           BreakStat l -> ret (BreakStat l)
-           LabelStat l s -> ret (LabelStat l) `app` f s
-     JMGExpr v' -> ret JMGExpr `app` case v' of
-           ValExpr e -> ret ValExpr `app` f e
-           SelExpr e e' -> ret SelExpr `app` f e `app` f e'
-           IdxExpr e e' -> ret IdxExpr `app` f e `app` f e'
-           InfixExpr o e e' -> ret (InfixExpr o) `app` f e `app` f e'
-           UOpExpr o e -> ret (UOpExpr o) `app` f e
-           IfExpr e e' e'' -> ret IfExpr `app` f e `app` f e' `app` f e''
-           ApplExpr e xs -> ret ApplExpr `app` f e `app` mapM' f xs
-           UnsatExpr _ -> ret v'
-     JMGVal v' -> ret JMGVal `app` case v' of
-           JVar i -> ret JVar `app` f i
-           JList xs -> ret JList `app` mapM' f xs
-           JDouble _ -> ret v'
-           JInt    _ -> ret v'
-           JStr    _ -> ret v'
-           JRegEx  _ -> ret v'
-           JHash   m -> ret JHash `app` m'
-               -- nonDetEltsUniqMap doesn't introduce nondeterminism here because the
-               -- elements are treated independently before being re-added to a UniqMap
-               where (ls, vs) = unzip (nonDetEltsUniqMap m)
-                     m' = ret (listToUniqMap . zip ls) `app` mapM' f vs
-           JFunc xs s -> ret JFunc `app` mapM' f xs `app` f s
-           UnsatVal _ -> ret v'
-
-  where
-    mapM' :: forall a. (a -> m a) -> [a] -> m [a]
-    mapM' g = foldr (app . app (ret (:)) . g) (ret [])
-    mapMaybeM' :: forall a. (a -> m a) -> Maybe a -> m (Maybe a)
-    mapMaybeM' g = \case
-      Nothing -> ret Nothing
-      Just a  -> app (ret Just) (g a)
-    f :: forall b. JMacro b => b -> m b
-    f x = ret jfromGADT `app` f' (jtoGADT x)
-
-{--------------------------------------------------------------------
-  Saturation
---------------------------------------------------------------------}
-
--- | Given an optional prefix, fills in all free variable names with a supply
--- of names generated by the prefix.
-jsSaturate :: (JMacro a) => Maybe FastString -> a -> a
-jsSaturate str x = evalState (runIdentSupply $ jsSaturate_ x) (newIdentSupply str)
-
-jsSaturate_ :: (JMacro a) => a -> IdentSupply a
-jsSaturate_ e = IS $ jfromGADT <$> go (jtoGADT e)
-    where
-      go :: forall a. JMGadt a -> State [Ident] (JMGadt a)
-      go v = case v of
-               JMGStat (UnsatBlock us) -> go =<< (JMGStat <$> runIdentSupply us)
-               JMGExpr (UnsatExpr  us) -> go =<< (JMGExpr <$> runIdentSupply us)
-               JMGVal  (UnsatVal   us) -> go =<< (JMGVal  <$> runIdentSupply us)
-               _ -> composOpM go v
diff --git a/compiler/GHC/Linker.hs b/compiler/GHC/Linker.hs
deleted file mode 100644
--- a/compiler/GHC/Linker.hs
+++ /dev/null
@@ -1,36 +0,0 @@
-module GHC.Linker
-   (
-   )
-where
-
-import GHC.Prelude ()
-   -- We need this dummy dependency for the make build system. Otherwise it
-   -- tries to load GHC.Types which may not be built yet.
-
--- Note [Linkers and loaders]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- Linkers are used to produce linked objects (.so, executables); loaders are
--- used to link in memory (e.g., in GHCi) with the already loaded libraries
--- (ghc-lib, rts, etc.).
---
--- Linking can usually be done with an external linker program ("ld"), but
--- loading is more tricky:
---
---    * Fully dynamic:
---       when GHC is built as a set of dynamic libraries (ghc-lib, rts, etc.)
---       and the modules to load are also compiled for dynamic linking, a
---       solution is to fully rely on external tools:
---
---       1) link a .so with the external linker
---       2) load the .so with POSIX's "dlopen"
---
---    * When GHC is built as a static program or when libraries we want to load
---    aren't compiled for dynamic linking, GHC uses its own loader ("runtime
---    linker"). The runtime linker is part of the rts (rts/Linker.c).
---
--- Note that within GHC's codebase we often use the word "linker" to refer to
--- the static object loader in the runtime system.
---
--- Loading can be delegated to an external interpreter ("iserv") when
--- -fexternal-interpreter is used.
diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs
deleted file mode 100644
--- a/compiler/GHC/Linker/Dynamic.hs
+++ /dev/null
@@ -1,258 +0,0 @@
-{-# LANGUAGE CPP #-}
-
--- | Dynamic linker
-module GHC.Linker.Dynamic
-   ( linkDynLib
-   -- * Platform-specifics
-   , libmLinkOpts
-   )
-where
-
-import GHC.Prelude
-import GHC.Platform
-import GHC.Platform.Ways
-
-import GHC.Driver.Session
-
-import GHC.Unit.Env
-import GHC.Unit.Types
-import GHC.Unit.State
-import GHC.Linker.MacOS
-import GHC.Linker.Unit
-import GHC.SysTools.Tasks
-import GHC.Utils.Logger
-import GHC.Utils.TmpFs
-
-import System.FilePath
-
-linkDynLib :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
-linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages
- = do
-    let platform   = ue_platform unit_env
-        os         = platformOS platform
-
-        -- This is a rather ugly hack to fix dynamically linked
-        -- GHC on Windows. If GHC is linked with -threaded, then
-        -- it links against libHSrts_thr. But if base is linked
-        -- against libHSrts, then both end up getting loaded,
-        -- and things go wrong. We therefore link the libraries
-        -- with the same RTS flags that we link GHC with.
-        dflags | OSMinGW32 <- os
-               , hostWays `hasWay` WayDyn
-               = dflags0 { targetWays_ = hostWays }
-               | otherwise
-               = dflags0
-
-        verbFlags = getVerbFlags dflags
-        o_file = outputFile_ dflags
-
-    pkgs_with_rts <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages)
-
-    let pkg_lib_paths = collectLibraryDirs (ways dflags) pkgs_with_rts
-    let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
-        get_pkg_lib_path_opts l
-         | osElfTarget os || osMachOTarget os
-         , dynLibLoader dflags == SystemDependent
-         , -- Only if we want dynamic libraries
-           ways dflags `hasWay` WayDyn
-           -- Only use RPath if we explicitly asked for it
-         , useXLinkerRPath dflags os
-            = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]
-              -- See Note [-Xlinker -rpath vs -Wl,-rpath]
-         | otherwise = ["-L" ++ l]
-
-    let lib_paths = libraryPaths dflags
-    let lib_path_opts = map ("-L"++) lib_paths
-
-    -- In general we don't want to link our dynamic libs against the RTS
-    -- package, because the RTS lib comes in several flavours and we want to be
-    -- able to pick the flavour when a binary is linked.
-    --
-    -- But:
-    --   * on Windows we need to link the RTS import lib as Windows does not
-    --   allow undefined symbols.
-    --
-    --   * the RTS library path is still added to the library search path above
-    --   in case the RTS is being explicitly linked in (see #3807).
-    --
-    --   * if -flink-rts is used, we link with the rts.
-    --
-    let pkgs_without_rts = filter ((/= rtsUnitId) . unitId) pkgs_with_rts
-        pkgs
-         | OSMinGW32 <- os         = pkgs_with_rts
-         | gopt Opt_LinkRts dflags = pkgs_with_rts
-         | otherwise               = pkgs_without_rts
-        pkg_link_opts = package_hs_libs ++ extra_libs ++ other_flags
-          where
-            namever = ghcNameVersion dflags
-            ways_   = ways dflags
-            (package_hs_libs, extra_libs, other_flags) = collectLinkOpts namever ways_ pkgs
-
-        -- probably _stub.o files
-        -- and last temporary shared object file
-    let extra_ld_inputs = ldInputs dflags
-
-    -- frameworks
-    pkg_framework_opts <- getUnitFrameworkOpts unit_env (map unitId pkgs)
-    let framework_opts = getFrameworkOpts dflags platform
-
-    case os of
-        OSMinGW32 -> do
-            -------------------------------------------------------------
-            -- Making a DLL
-            -------------------------------------------------------------
-            let output_fn = case o_file of
-                            Just s -> s
-                            Nothing -> "HSdll.dll"
-
-            runLink logger tmpfs dflags (
-                    map Option verbFlags
-                 ++ [ Option "-o"
-                    , FileOption "" output_fn
-                    , Option "-shared"
-                    ] ++
-                    [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
-                    | gopt Opt_SharedImplib dflags
-                    ]
-                 ++ map (FileOption "") o_files
-
-                 -- Permit the linker to auto link _symbol to _imp_symbol
-                 -- This lets us link against DLLs without needing an "import library"
-                 ++ [Option "-Wl,--enable-auto-import"]
-
-                 ++ extra_ld_inputs
-                 ++ map Option (
-                    lib_path_opts
-                 ++ pkg_lib_path_opts
-                 ++ pkg_link_opts
-                ))
-        _ | os == OSDarwin -> do
-            -------------------------------------------------------------------
-            -- Making a darwin dylib
-            -------------------------------------------------------------------
-            -- About the options used for Darwin:
-            -- -dynamiclib
-            --   Apple's way of saying -shared
-            -- -undefined dynamic_lookup:
-            --   Without these options, we'd have to specify the correct
-            --   dependencies for each of the dylibs. Note that we could
-            --   (and should) do without this for all libraries except
-            --   the RTS; all we need to do is to pass the correct
-            --   HSfoo_dyn.dylib files to the link command.
-            --   This feature requires Mac OS X 10.3 or later; there is
-            --   a similar feature, -flat_namespace -undefined suppress,
-            --   which works on earlier versions, but it has other
-            --   disadvantages.
-            -- -single_module
-            --   Build the dynamic library as a single "module", i.e. no
-            --   dynamic binding nonsense when referring to symbols from
-            --   within the library. The NCG assumes that this option is
-            --   specified (on i386, at least).
-            -- -install_name
-            --   Mac OS/X stores the path where a dynamic library is (to
-            --   be) installed in the library itself.  It's called the
-            --   "install name" of the library. Then any library or
-            --   executable that links against it before it's installed
-            --   will search for it in its ultimate install location.
-            --   By default we set the install name to the absolute path
-            --   at build time, but it can be overridden by the
-            --   -dylib-install-name option passed to ghc. Cabal does
-            --   this.
-            -------------------------------------------------------------------
-
-            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
-
-            instName <- case dylibInstallName dflags of
-                Just n -> return n
-                Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)
-            runLink logger tmpfs dflags (
-                    map Option verbFlags
-                 ++ [ Option "-dynamiclib"
-                    , Option "-o"
-                    , FileOption "" output_fn
-                    ]
-                 ++ map Option o_files
-                 ++ [ Option "-undefined",
-                      Option "dynamic_lookup",
-                      Option "-single_module" ]
-                 ++ (if platformArch platform `elem` [ ArchX86_64, ArchAArch64 ]
-                     then [ ]
-                     else [ Option "-Wl,-read_only_relocs,suppress" ])
-                 ++ [ Option "-install_name", Option instName ]
-                 ++ map Option lib_path_opts
-                 ++ extra_ld_inputs
-                 ++ map Option framework_opts
-                 ++ map Option pkg_lib_path_opts
-                 ++ map Option pkg_link_opts
-                 ++ map Option pkg_framework_opts
-                 -- dead_strip_dylibs, will remove unused dylibs, and thus save
-                 -- space in the load commands. The -headerpad is necessary so
-                 -- that we can inject more @rpath's later for the leftover
-                 -- libraries in the runInjectRpaths phase below.
-                 --
-                 -- See Note [Dynamic linking on macOS]
-                 ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ]
-              )
-            runInjectRPaths logger dflags pkg_lib_paths output_fn
-        _ -> do
-            -------------------------------------------------------------------
-            -- Making a DSO
-            -------------------------------------------------------------------
-
-            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
-                platform  = targetPlatform dflags
-                unregisterised = platformUnregisterised platform
-            let bsymbolicFlag = -- we need symbolic linking to resolve
-                                -- non-PIC intra-package-relocations for
-                                -- performance (where symbolic linking works)
-                                -- See Note [-Bsymbolic assumptions by GHC]
-                                ["-Wl,-Bsymbolic" | not unregisterised]
-
-            runLink logger tmpfs dflags (
-                    map Option verbFlags
-                 ++ libmLinkOpts platform
-                 ++ [ Option "-o"
-                    , FileOption "" output_fn
-                    ]
-                 ++ map Option o_files
-                 ++ [ Option "-shared" ]
-                 ++ map Option bsymbolicFlag
-                    -- Set the library soname. We use -h rather than -soname as
-                    -- Solaris 10 doesn't support the latter:
-                 ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]
-                 ++ extra_ld_inputs
-                 ++ map Option lib_path_opts
-                 ++ map Option pkg_lib_path_opts
-                 ++ map Option pkg_link_opts
-              )
-
--- | Some platforms require that we explicitly link against @libm@ if any
--- math-y things are used (which we assume to include all programs). See #14022.
-libmLinkOpts :: Platform -> [Option]
-libmLinkOpts platform
-  | platformHasLibm platform = [Option "-lm"]
-  | otherwise                = []
-
-{-
-Note [-Bsymbolic assumptions by GHC]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-GHC has a few assumptions about interaction of relocations in NCG and linker:
-
-1. -Bsymbolic resolves internal references when the shared library is linked,
-   which is important for performance.
-2. When there is a reference to data in a shared library from the main program,
-   the runtime linker relocates the data object into the main program using an
-   R_*_COPY relocation.
-3. If we used -Bsymbolic, then this results in multiple copies of the data
-   object, because some references have already been resolved to point to the
-   original instance. This is bad!
-
-We work around [3.] for native compiled code by avoiding the generation of
-R_*_COPY relocations.
-
-Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable
--Bsymbolic linking there.
-
-See related tickets: #4210, #15338
--}
diff --git a/compiler/GHC/Linker/ExtraObj.hs b/compiler/GHC/Linker/ExtraObj.hs
deleted file mode 100644
--- a/compiler/GHC/Linker/ExtraObj.hs
+++ /dev/null
@@ -1,269 +0,0 @@
------------------------------------------------------------------------------
---
--- GHC Extra object linking code
---
--- (c) The GHC Team 2017
---
------------------------------------------------------------------------------
-
-module GHC.Linker.ExtraObj
-   ( mkExtraObj
-   , mkExtraObjToLinkIntoBinary
-   , mkNoteObjsToLinkIntoBinary
-   , checkLinkInfo
-   , getLinkInfo
-   , getCompilerInfo
-   , ghcLinkInfoSectionName
-   , ghcLinkInfoNoteName
-   , platformSupportsSavingLinkOpts
-   , haveRtsOptsFlags
-   )
-where
-
-import GHC.Prelude
-import GHC.Platform
-
-import GHC.Unit
-import GHC.Unit.Env
-
-import GHC.Utils.Asm
-import GHC.Utils.Error
-import GHC.Utils.Misc
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Logger
-import GHC.Utils.TmpFs
-
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-
-import qualified GHC.Data.ShortText as ST
-
-import GHC.SysTools.Elf
-import GHC.SysTools.Tasks
-import GHC.SysTools.Info
-import GHC.Linker.Unit
-
-import Control.Monad.IO.Class
-import Control.Monad
-import Data.Maybe
-
-mkExtraObj :: Logger -> TmpFs -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath
-mkExtraObj logger tmpfs dflags unit_state extn xs
- = do cFile <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule extn
-      oFile <- newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession "o"
-      writeFile cFile xs
-      ccInfo <- liftIO $ getCompilerInfo logger dflags
-      runCc Nothing logger tmpfs dflags
-            ([Option        "-c",
-              FileOption "" cFile,
-              Option        "-o",
-              FileOption "" oFile]
-              ++ if extn /= "s"
-                    then cOpts
-                    else asmOpts ccInfo)
-      return oFile
-    where
-      -- Pass a different set of options to the C compiler depending one whether
-      -- we're compiling C or assembler. When compiling C, we pass the usual
-      -- set of include directories and PIC flags.
-      cOpts = map Option (picCCOpts dflags)
-                    ++ map (FileOption "-I" . ST.unpack)
-                            (unitIncludeDirs $ unsafeLookupUnit unit_state rtsUnit)
-
-      -- When compiling assembler code, we drop the usual C options, and if the
-      -- compiler is Clang, we add an extra argument to tell Clang to ignore
-      -- unused command line options. See trac #11684.
-      asmOpts ccInfo =
-            if any (ccInfo ==) [Clang, AppleClang, AppleClang51]
-                then [Option "-Qunused-arguments"]
-                else []
-
--- When linking a binary, we need to create a C main() function that
--- starts everything off.  This used to be compiled statically as part
--- of the RTS, but that made it hard to change the -rtsopts setting,
--- so now we generate and compile a main() stub as part of every
--- binary and pass the -rtsopts setting directly to the RTS (#5373)
---
--- On Windows, when making a shared library we also may need a DllMain.
---
-mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe FilePath)
-mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state = do
-  when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $
-     logInfo logger $ withPprStyle defaultUserStyle
-         (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
-          text "    Call hs_init_ghc() from your main() function to set these options.")
-
-  case ghcLink dflags of
-    -- Don't try to build the extra object if it is not needed.  Compiling the
-    -- extra object assumes the presence of the RTS in the unit database
-    -- (because the extra object imports Rts.h) but GHC's build system may try
-    -- to build some helper programs before building and registering the RTS!
-    -- See #18938 for an example where hp2ps failed to build because of a failed
-    -- (unsafe) lookup for the RTS in the unit db.
-    _ | gopt Opt_NoHsMain dflags
-      -> return Nothing
-
-    LinkDynLib
-      | OSMinGW32 <- platformOS (targetPlatform dflags)
-      -> mk_extra_obj dllMain
-
-      | otherwise
-      -> return Nothing
-
-    _ -> mk_extra_obj exeMain
-
-  where
-    mk_extra_obj = fmap Just . mkExtraObj logger tmpfs dflags unit_state "c" . showSDoc dflags
-
-    exeMain = vcat [
-        text "#include <Rts.h>",
-        text "extern StgClosure ZCMain_main_closure;",
-        text "int main(int argc, char *argv[])",
-        char '{',
-        text " RtsConfig __conf = defaultRtsConfig;",
-        text " __conf.rts_opts_enabled = "
-            <> text (show (rtsOptsEnabled dflags)) <> semi,
-        text " __conf.rts_opts_suggestions = "
-            <> (if rtsOptsSuggestions dflags
-                then text "true"
-                else text "false") <> semi,
-        text "__conf.keep_cafs = "
-            <> (if gopt Opt_KeepCAFs dflags
-                then text "true"
-                else text "false") <> semi,
-        case rtsOpts dflags of
-            Nothing   -> Outputable.empty
-            Just opts -> text "    __conf.rts_opts= " <>
-                          text (show opts) <> semi,
-        text " __conf.rts_hs_main = true;",
-        text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);",
-        char '}',
-        char '\n' -- final newline, to keep gcc happy
-        ]
-
-    dllMain = vcat [
-        text "#include <Rts.h>",
-        text "#include <windows.h>",
-        text "#include <stdbool.h>",
-        char '\n',
-        text "bool",
-        text "WINAPI",
-        text "DllMain ( HINSTANCE hInstance STG_UNUSED",
-        text "        , DWORD reason STG_UNUSED",
-        text "        , LPVOID reserved STG_UNUSED",
-        text "        )",
-        text "{",
-        text "  return true;",
-        text "}",
-        char '\n' -- final newline, to keep gcc happy
-        ]
-
--- Write out the link info section into a new assembly file. Previously
--- this was included as inline assembly in the main.c file but this
--- is pretty fragile. gas gets upset trying to calculate relative offsets
--- that span the .note section (notably .text) when debug info is present
-mkNoteObjsToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath]
-mkNoteObjsToLinkIntoBinary logger tmpfs dflags unit_env dep_packages = do
-   link_info <- getLinkInfo dflags unit_env dep_packages
-
-   if (platformSupportsSavingLinkOpts (platformOS platform ))
-     then fmap (:[]) $ mkExtraObj logger tmpfs dflags unit_state "s" (showSDoc dflags (link_opts link_info))
-     else return []
-
-  where
-    unit_state = ue_units unit_env
-    platform   = ue_platform unit_env
-    link_opts info = hcat
-        [ -- "link info" section (see Note [LinkInfo section])
-          makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info
-
-        -- ALL generated assembly must have this section to disable
-        -- executable stacks.  See also
-        -- "GHC.CmmToAsm" for another instance
-        -- where we need to do this.
-        , if platformHasGnuNonexecStack platform
-            then text ".section .note.GNU-stack,\"\","
-                 <> sectionType platform "progbits" <> char '\n'
-            else Outputable.empty
-        ]
-
--- | Return the "link info" string
---
--- See Note [LinkInfo section]
-getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String
-getLinkInfo dflags unit_env dep_packages = do
-    package_link_opts <- getUnitLinkOpts (ghcNameVersion dflags) (ways dflags) unit_env dep_packages
-    pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env))
-      then return []
-      else do
-         ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages)
-         return (collectFrameworks ps)
-    let link_info =
-             ( package_link_opts
-             , pkg_frameworks
-             , rtsOpts dflags
-             , rtsOptsEnabled dflags
-             , gopt Opt_NoHsMain dflags
-             , map showOpt (ldInputs dflags)
-             , getOpts dflags opt_l
-             )
-    return (show link_info)
-
-platformSupportsSavingLinkOpts :: OS -> Bool
-platformSupportsSavingLinkOpts os
- | os == OSSolaris2 = False -- see #5382
- | otherwise        = osElfTarget os
-
--- See Note [LinkInfo section]
-ghcLinkInfoSectionName :: String
-ghcLinkInfoSectionName = ".debug-ghc-link-info"
-  -- if we use the ".debug" prefix, then strip will strip it by default
-
--- Identifier for the note (see Note [LinkInfo section])
-ghcLinkInfoNoteName :: String
-ghcLinkInfoNoteName = "GHC link info"
-
--- Returns 'False' if it was, and we can avoid linking, because the
--- previous binary was linked with "the same options".
-checkLinkInfo :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool
-checkLinkInfo logger dflags unit_env pkg_deps exe_file
- | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env)))
- -- ToDo: Windows and OS X do not use the ELF binary format, so
- -- readelf does not work there.  We need to find another way to do
- -- this.
- = return False -- conservatively we should return True, but not
-                -- linking in this case was the behaviour for a long
-                -- time so we leave it as-is.
- | otherwise
- = do
-   link_info <- getLinkInfo dflags unit_env pkg_deps
-   debugTraceMsg logger 3 $ text ("Link info: " ++ link_info)
-   m_exe_link_info <- readElfNoteAsString logger exe_file
-                          ghcLinkInfoSectionName ghcLinkInfoNoteName
-   let sameLinkInfo = (Just link_info == m_exe_link_info)
-   debugTraceMsg logger 3 $ case m_exe_link_info of
-     Nothing -> text "Exe link info: Not found"
-     Just s
-       | sameLinkInfo -> text ("Exe link info is the same")
-       | otherwise    -> text ("Exe link info is different: " ++ s)
-   return (not sameLinkInfo)
-
-{- Note [LinkInfo section]
-   ~~~~~~~~~~~~~~~~~~~~~~~
-
-The "link info" is a string representing the parameters of the link. We save
-this information in the binary, and the next time we link, if nothing else has
-changed, we use the link info stored in the existing binary to decide whether
-to re-link or not.
-
-The "link info" string is stored in a ELF section called ".debug-ghc-link-info"
-(see ghcLinkInfoSectionName) with the SHT_NOTE type.  For some time, it used to
-not follow the specified record-based format (see #11022).
-
--}
-
-haveRtsOptsFlags :: DynFlags -> Bool
-haveRtsOptsFlags dflags =
-        isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of
-                                       RtsOptsSafeOnly -> False
-                                       _ -> True
diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs
deleted file mode 100644
--- a/compiler/GHC/Linker/Loader.hs
+++ /dev/null
@@ -1,1879 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TupleSections, RecordWildCards #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE LambdaCase #-}
-
---
---  (c) The University of Glasgow 2002-2006
-
--- | The loader
---
--- This module deals with the top-level issues of dynamic linking (loading),
--- calling the object-code linker and the byte-code linker where necessary.
-module GHC.Linker.Loader
-   ( Loader (..)
-   , LoaderState (..)
-   , initLoaderState
-   , uninitializedLoader
-   , showLoaderState
-   , getLoaderState
-   -- * Load & Unload
-   , loadExpr
-   , loadDecls
-   , loadPackages
-   , loadModule
-   , loadCmdLineLibs
-   , loadName
-   , unload
-   -- * LoadedEnv
-   , withExtendedLoadedEnv
-   , extendLoadedEnv
-   , deleteFromLoadedEnv
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Settings
-
-import GHC.Platform
-import GHC.Platform.Ways
-
-import GHC.Driver.Phases
-import GHC.Driver.Env
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Driver.Config
-import GHC.Driver.Config.Diagnostic
-import GHC.Driver.Config.Finder
-
-import GHC.Tc.Utils.Monad
-
-import GHC.Runtime.Interpreter
-import GHCi.RemoteTypes
-
-
-import GHC.ByteCode.Linker
-import GHC.ByteCode.Asm
-import GHC.ByteCode.Types
-
-import GHC.SysTools
-
-import GHC.Types.Basic
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.SrcLoc
-import GHC.Types.Unique.DSet
-import GHC.Types.Unique.DFM
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Error
-import GHC.Utils.Logger
-import GHC.Utils.TmpFs
-
-import GHC.Unit.Env
-import GHC.Unit.Finder
-import GHC.Unit.Module
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.WholeCoreBindings
-import GHC.Unit.Module.Deps
-import GHC.Unit.Home.ModInfo
-import GHC.Unit.State as Packages
-
-import qualified GHC.Data.ShortText as ST
-import qualified GHC.Data.Maybe as Maybes
-import GHC.Data.FastString
-
-import GHC.Linker.MacOS
-import GHC.Linker.Dynamic
-import GHC.Linker.Types
-
--- Standard libraries
-import Control.Monad
-
-import qualified Data.Set as Set
-import qualified Data.Map as M
-import Data.Char (isSpace)
-import Data.IORef
-import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition)
-import Data.Maybe
-import Control.Concurrent.MVar
-import qualified Control.Monad.Catch as MC
-
-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 GHC.Utils.Exception
-
-import GHC.Unit.Module.Graph
-import GHC.Types.SourceFile
-import GHC.Utils.Misc
-import GHC.Iface.Load
-import GHC.Unit.Home
-import Data.Either
-import Control.Applicative
-
-uninitialised :: a
-uninitialised = panic "Loader not initialised"
-
-modifyLoaderState_ :: Interp -> (LoaderState -> IO LoaderState) -> IO ()
-modifyLoaderState_ interp f =
-  modifyMVar_ (loader_state (interpLoader interp))
-    (fmap pure . f . fromMaybe uninitialised)
-
-modifyLoaderState :: Interp -> (LoaderState -> IO (LoaderState, a)) -> IO a
-modifyLoaderState interp f =
-  modifyMVar (loader_state (interpLoader interp))
-    (fmapFst pure . f . fromMaybe uninitialised)
-  where fmapFst f = fmap (\(x, y) -> (f x, y))
-
-getLoaderState :: Interp -> IO (Maybe LoaderState)
-getLoaderState interp = readMVar (loader_state (interpLoader interp))
-
-
-emptyLoaderState :: LoaderState
-emptyLoaderState = LoaderState
-   { closure_env = emptyNameEnv
-   , itbl_env    = emptyNameEnv
-   , pkgs_loaded = init_pkgs
-   , bcos_loaded = emptyModuleEnv
-   , objs_loaded = emptyModuleEnv
-   , 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 = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] emptyUniqDSet)
-
-extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO ()
-extendLoadedEnv interp new_bindings =
-  modifyLoaderState_ interp $ \pls@LoaderState{..} -> 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
-
-deleteFromLoadedEnv :: Interp -> [Name] -> IO ()
-deleteFromLoadedEnv interp to_remove =
-  modifyLoaderState_ interp $ \pls -> do
-    let ce = closure_env pls
-    let new_ce = delListFromNameEnv ce to_remove
-    return pls{ closure_env = new_ce }
-
--- | Load the module containing the given Name and get its associated 'HValue'.
---
--- Throws a 'ProgramError' if loading fails or the name cannot be found.
-loadName :: Interp -> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded)
-loadName interp hsc_env name = do
-  initLoaderState interp hsc_env
-  modifyLoaderState interp $ \pls0 -> do
-    (pls, links, pkgs) <- if not (isExternalName name)
-       then return (pls0, [], emptyUDFM)
-       else do
-         (pls', ok, links, pkgs) <- loadDependencies interp hsc_env pls0 noSrcSpan
-                                      [nameModule name]
-         if failed ok
-           then throwGhcExceptionIO (ProgramError "")
-           else return (pls', links, pkgs)
-
-    case lookupNameEnv (closure_env pls) name of
-      Just (_,aa) -> return (pls,(aa, links, pkgs))
-      Nothing     -> assertPpr (isExternalName name) (ppr name) $
-                     do let sym_to_find = nameToCLabel name "closure"
-                        m <- lookupClosure interp (unpackFS sym_to_find)
-                        r <- case m of
-                          Just hvref -> mkFinalizedHValue interp hvref
-                          Nothing -> linkFail "GHC.Linker.Loader.loadName"
-                                       (unpackFS sym_to_find)
-                        return (pls,(r, links, pkgs))
-
-loadDependencies
-  :: Interp
-  -> HscEnv
-  -> LoaderState
-  -> SrcSpan
-  -> [Module]
-  -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required
-loadDependencies interp hsc_env pls span needed_mods = do
---   initLoaderState (hsc_dflags hsc_env) dl
-   let 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 interp span
-
-   -- Find what packages and linkables are required
-   (lnks, all_lnks, pkgs, this_pkgs_needed)
-      <- getLinkDeps hsc_env pls
-           maybe_normal_osuf span needed_mods
-
-   -- Link the packages and modules required
-   pls1 <- loadPackages' interp hsc_env pkgs pls
-   (pls2, succ) <- loadModuleLinkables interp hsc_env pls1 lnks
-   let this_pkgs_loaded = udfmRestrictKeys all_pkgs_loaded $ getUniqDSet trans_pkgs_needed
-       all_pkgs_loaded = pkgs_loaded pls2
-       trans_pkgs_needed = unionManyUniqDSets (this_pkgs_needed : [ loaded_pkg_trans_deps pkg
-                                                                  | pkg_id <- uniqDSetToList this_pkgs_needed
-                                                                  , Just pkg <- [lookupUDFM all_pkgs_loaded pkg_id]
-                                                                  ])
-   return (pls2, succ, all_lnks, this_pkgs_loaded)
-
-
--- | Temporarily extend the loaded env.
-withExtendedLoadedEnv
-  :: (ExceptionMonad m)
-  => Interp
-  -> [(Name,ForeignHValue)]
-  -> m a
-  -> m a
-withExtendedLoadedEnv interp new_env action
-    = MC.bracket (liftIO $ extendLoadedEnv interp 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 $
-            modifyLoaderState_ interp $ \pls ->
-                let cur = closure_env pls
-                    new = delListFromNameEnv cur (map fst new_env)
-                in return pls{ closure_env = new }
-
-
--- | Display the loader state.
-showLoaderState :: Interp -> IO SDoc
-showLoaderState interp = do
-  ls <- readMVar (loader_state (interpLoader interp))
-  let docs = case ls of
-        Nothing  -> [ text "Loader not initialised"]
-        Just pls -> [ text "Pkgs:" <+> ppr (map loaded_pkg_uid $ eltsUDFM $ pkgs_loaded pls)
-                    , text "Objs:" <+> ppr (moduleEnvElts $ objs_loaded pls)
-                    , text "BCOs:" <+> ppr (moduleEnvElts $ bcos_loaded pls)
-                    ]
-
-  return $ withPprStyle defaultDumpStyle
-         $ vcat (text "----- Loader state -----":docs)
-
-
-{- **********************************************************************
-
-                        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.
---
-initLoaderState :: Interp -> HscEnv -> IO ()
-initLoaderState interp hsc_env = do
-  modifyMVar_ (loader_state (interpLoader interp)) $ \pls -> do
-    case pls of
-      Just  _ -> return pls
-      Nothing -> Just <$> reallyInitLoaderState interp hsc_env
-
-reallyInitLoaderState :: Interp -> HscEnv -> IO LoaderState
-reallyInitLoaderState interp hsc_env = do
-  -- Initialise the linker state
-  let pls0 = emptyLoaderState
-
-  -- (a) initialise the C dynamic linker
-  initObjLinker interp
-
-
-  -- (b) Load packages from the command-line (Note [preload packages])
-  pls <- unitEnv_foldWithKey (\k u env -> k >>= \pls' -> loadPackages' interp (hscSetActiveUnitId u hsc_env) (preloadUnits (homeUnitEnv_units env)) pls') (return pls0) (hsc_HUG hsc_env)
-
-  -- steps (c), (d) and (e)
-  loadCmdLineLibs' interp hsc_env pls
-
-
-loadCmdLineLibs :: Interp -> HscEnv -> IO ()
-loadCmdLineLibs interp hsc_env = do
-  initLoaderState interp hsc_env
-  modifyLoaderState_ interp $ \pls ->
-    loadCmdLineLibs' interp hsc_env pls
-
-
-loadCmdLineLibs' :: Interp -> HscEnv -> LoaderState -> IO LoaderState
-loadCmdLineLibs' interp hsc_env pls = snd <$>
-    foldM
-      (\(done', pls') cur_uid ->  load done' cur_uid pls')
-      (Set.empty, pls)
-      (hsc_all_home_unit_ids hsc_env)
-
-  where
-    load :: Set.Set UnitId -> UnitId -> LoaderState -> IO (Set.Set UnitId, LoaderState)
-    load done uid pls | uid `Set.member` done = return (done, pls)
-    load done uid pls = do
-      let hsc' = hscSetActiveUnitId uid hsc_env
-      -- Load potential dependencies first
-      (done', pls') <- foldM (\(done', pls') uid -> load done' uid pls') (done, pls)
-                          (homeUnitDepends (hsc_units hsc'))
-      pls'' <- loadCmdLineLibs'' interp hsc' pls'
-      return $ (Set.insert uid done', pls'')
-
-loadCmdLineLibs''
-  :: Interp
-  -> HscEnv
-  -> LoaderState
-  -> IO LoaderState
-loadCmdLineLibs'' interp hsc_env pls =
-  do
-
-      let dflags@(DynFlags { ldInputs = cmdline_ld_inputs
-                           , libraryPaths = lib_paths_base})
-            = hsc_dflags hsc_env
-      let logger = hsc_logger 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 logger dflags os
-
-      lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base
-
-      maybePutStrLn logger "Search directories (user):"
-      maybePutStr logger (unlines $ map ("  "++) lib_paths_env)
-      maybePutStrLn logger "Search directories (gcc):"
-      maybePutStr logger (unlines $ map ("  "++) gcc_paths)
-
-      libspecs
-        <- mapM (locateLib interp hsc_env False lib_paths_env gcc_paths) minus_ls
-
-      -- (d) Link .o files from the command-line
-      classified_ld_inputs <- mapM (classifyLdInput logger platform)
-                                [ 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 interp) all_paths_env
-
-           let merged_specs = mergeStaticObjects cmdline_lib_specs
-           pls1 <- foldM (preloadLib interp hsc_env lib_paths framework_paths) pls
-                         merged_specs
-
-           maybePutStr logger "final link ... "
-           ok <- resolveObjs interp
-
-           -- DLLs are loaded, reset the search paths
-           mapM_ (removeLibrarySearchPath interp) $ reverse pathCache
-
-           if succeeded ok then maybePutStrLn logger "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 :: Logger -> Platform -> FilePath -> IO (Maybe LibrarySpec)
-classifyLdInput logger platform f
-  | isObjectFilename platform f = return (Just (Objects [f]))
-  | isDynLibFilename platform f = return (Just (DLLPath f))
-  | otherwise          = do
-        logMsg logger MCInfo noSrcSpan
-            $ withPprStyle defaultUserStyle
-            (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
-        return Nothing
-
-preloadLib
-  :: Interp
-  -> HscEnv
-  -> [String]
-  -> [String]
-  -> LoaderState
-  -> LibrarySpec
-  -> IO LoaderState
-preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do
-  maybePutStr logger ("Loading object " ++ showLS lib_spec ++ " ... ")
-  case lib_spec of
-    Objects static_ishs -> do
-      (b, pls1) <- preload_statics lib_paths static_ishs
-      maybePutStrLn logger (if b  then "done" else "not found")
-      return pls1
-
-    Archive static_ish -> do
-      b <- preload_static_archive lib_paths static_ish
-      maybePutStrLn logger (if b  then "done" else "not found")
-      return pls
-
-    DLL dll_unadorned -> do
-      maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned)
-      case maybe_errstr of
-         Nothing -> maybePutStrLn logger "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 interp libfile
-           case err2 of
-             Nothing -> maybePutStrLn logger "done"
-             Just _  -> preloadFailed mm lib_paths lib_spec
-      return pls
-
-    DLLPath dll_path -> do
-      do maybe_errstr <- loadDLL interp dll_path
-         case maybe_errstr of
-            Nothing -> maybePutStrLn logger "done"
-            Just mm -> preloadFailed mm lib_paths lib_spec
-         return pls
-
-    Framework framework ->
-      if platformUsesFrameworks (targetPlatform dflags)
-      then do maybe_errstr <- loadFramework interp framework_paths framework
-              case maybe_errstr of
-                 Nothing -> maybePutStrLn logger "done"
-                 Just mm -> preloadFailed mm framework_paths lib_spec
-              return pls
-      else throwGhcExceptionIO (ProgramError "preloadLib Framework")
-
-  where
-    dflags = hsc_dflags hsc_env
-    logger = hsc_logger hsc_env
-
-    platform = targetPlatform dflags
-
-    preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
-    preloadFailed sys_errmsg paths spec
-       = do maybePutStr logger "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 hostIsDynamic
-                             then  do pls1 <- dynLoadObjs interp hsc_env pls names
-                                      return (True, pls1)
-                             else  do mapM_ (loadObj interp) names
-                                      return (True, pls)
-
-    preload_static_archive _paths name
-       = do b <- doesFileExist name
-            if not b then return False
-                     else do if hostIsDynamic
-                                 then throwGhcExceptionIO $
-                                      CmdLineError dynamic_msg
-                                 else loadArchive interp 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
-
-  ********************************************************************* -}
-
--- | Load a single expression, /including/ first loading 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 load.
---
-loadExpr :: Interp -> HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
-loadExpr interp hsc_env span root_ul_bco = do
-  -- Initialise the linker (if it's not been done already)
-  initLoaderState interp hsc_env
-
-  -- Take lock for the actual work.
-  modifyLoaderState interp $ \pls0 -> do
-    -- Load the packages and modules required
-    (pls, ok, _, _) <- loadDependencies interp hsc_env pls0 span needed_mods
-    if failed ok
-      then throwGhcExceptionIO (ProgramError "")
-      else do
-        -- Load the expression itself
-        let ie = itbl_env pls
-            ce = closure_env pls
-
-        -- Load the necessary packages and linkables
-        let nobreakarray = error "no break array"
-            bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]
-        resolved <- linkBCO interp ie ce bco_ix nobreakarray root_ul_bco
-        bco_opts <- initBCOOpts (hsc_dflags hsc_env)
-        [root_hvref] <- createBCOs interp bco_opts [resolved]
-        fhv <- mkFinalizedHValue interp 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 -> SDoc -> IO a
-dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage MCFatal span msg)))
-
-
-checkNonStdWay :: DynFlags -> Interp -> SrcSpan -> IO (Maybe FilePath)
-checkNonStdWay _dflags interp _srcspan
-  | ExternalInterp {} <- interpInstance interp = 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.
-
--- #if-guard the following equations otherwise the pattern match checker will
--- complain that they are redundant.
-#if defined(HAVE_INTERNAL_INTERPRETER)
-checkNonStdWay dflags _interp srcspan
-  | hostFullWays == targetFullWays = 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 targetFullWays)
-  = failNonStd dflags srcspan
-
-  | otherwise = return (Just (hostWayTag ++ "o"))
-  where
-    targetFullWays = fullWays (ways dflags)
-    hostWayTag = case waysTag hostFullWays of
-                  "" -> ""
-                  tag -> tag ++ "_"
-
-    normalObjectSuffix :: String
-    normalObjectSuffix = phaseInputExt StopLn
-
-data Way' = Normal | Prof | Dyn
-
-failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)
-failNonStd dflags srcspan = dieWith dflags srcspan $
-  text "Cannot load" <+> pprWay' compWay <+>
-     text "objects when GHC is built" <+> pprWay' ghciWay $$
-  text "To fix this, either:" $$
-  text "  (1) Use -fexternal-interpreter, or" $$
-  buildTwiceMsg
-    where compWay
-            | ways dflags `hasWay` WayDyn  = Dyn
-            | ways dflags `hasWay` WayProf = Prof
-            | otherwise = Normal
-          ghciWay
-            | hostIsDynamic = Dyn
-            | hostIsProfiled = Prof
-            | otherwise = Normal
-          buildTwiceMsg = case (ghciWay, compWay) of
-            (Normal, Dyn) -> dynamicTooMsg
-            (Dyn, Normal) -> dynamicTooMsg
-            _ ->
-              text "  (2) Build the program twice: once" <+>
-                pprWay' ghciWay <> text ", and then" $$
-              text "      " <> pprWay' compWay <+>
-                text "using -osuf to set a different object file suffix."
-          dynamicTooMsg = text "  (2) Use -dynamic-too," <+>
-            text "and use -osuf and -dynosuf to set object file suffixes as needed."
-          pprWay' :: Way' -> SDoc
-          pprWay' way = text $ case way of
-            Normal -> "the normal way"
-            Prof -> "with -prof"
-            Dyn -> "with -dynamic"
-#endif
-
-getLinkDeps :: HscEnv
-            -> LoaderState
-            -> Maybe FilePath                   -- replace object suffixes?
-            -> SrcSpan                          -- for error messages
-            -> [Module]                         -- If you need these
-            -> IO ([Linkable], [Linkable], [UnitId], UniqDSet UnitId)     -- ... then link these first
-            -- The module and package dependencies for the needed modules are returned.
-            -- See Note [Object File Dependencies]
--- Fails with an IO exception if it can't find enough files
-
-getLinkDeps hsc_env 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) <-
-          -- Why two code paths here? There is a significant amount of repeated work
-          -- performed calculating transitive dependencies
-          -- if --make uses the oneShot code path (see MultiLayerModulesTH_* tests)
-          if isOneShot (ghcMode dflags)
-            then follow_deps (filterOut isInteractiveModule mods)
-                              emptyUniqDSet emptyUniqDSet;
-            else do
-              (pkgs, mmods) <- unzip <$> mapM get_mod_info all_home_mods
-              return (catMaybes mmods, unionManyUniqDSets (init_pkg_set : pkgs))
-
-      ; let
-        -- 2.  Exclude ones already linked
-        --      Main reason: avoid findModule calls in get_linkable
-            (mods_needed, links_got) = partitionEithers (map split_mods mods_s)
-            pkgs_needed = eltsUDFM $ getUniqDSet pkgs_s `minusUDFM` pkgs_loaded pls
-
-            split_mods mod =
-                let is_linked = findModuleLinkable_maybe (objs_loaded pls) mod <|> findModuleLinkable_maybe (bcos_loaded pls) mod
-                in case is_linked of
-                     Just linkable -> Right linkable
-                     Nothing -> Left mod
-
-        -- 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, links_got ++ lnks_needed, pkgs_needed, pkgs_s) }
-  where
-    dflags = hsc_dflags hsc_env
-    mod_graph = hsc_mod_graph hsc_env
-
-    -- This code is used in `--make` mode to calculate the home package and unit dependencies
-    -- for a set of modules.
-    --
-    -- It is significantly more efficient to use the shared transitive dependency
-    -- calculation than to compute the transitive dependency set in the same manner as oneShot mode.
-
-    -- It is also a matter of correctness to use the module graph so that dependencies between home units
-    -- is resolved correctly.
-    make_deps_loop :: (UniqDSet UnitId, Set.Set NodeKey) -> [ModNodeKeyWithUid] -> (UniqDSet UnitId, Set.Set NodeKey)
-    make_deps_loop found [] = found
-    make_deps_loop found@(found_units, found_mods) (nk:nexts)
-      | NodeKey_Module nk `Set.member` found_mods = make_deps_loop found nexts
-      | otherwise =
-        case M.lookup (NodeKey_Module nk) (mgTransDeps mod_graph) of
-            Just trans_deps ->
-              let deps = Set.insert (NodeKey_Module nk) trans_deps
-                  -- See #936 and the ghci.prog007 test for why we have to continue traversing through
-                  -- boot modules.
-                  todo_boot_mods = [ModNodeKeyWithUid (GWIB mn NotBoot) uid | NodeKey_Module (ModNodeKeyWithUid (GWIB mn IsBoot) uid) <- Set.toList trans_deps]
-              in make_deps_loop (found_units, deps `Set.union` found_mods) (todo_boot_mods ++ nexts)
-            Nothing ->
-              let (ModNodeKeyWithUid _ uid) = nk
-              in make_deps_loop (addOneToUniqDSet found_units uid, found_mods) nexts
-
-    mkNk m = ModNodeKeyWithUid (GWIB (moduleName m) NotBoot) (moduleUnitId m)
-    (init_pkg_set, all_deps) = make_deps_loop (emptyUniqDSet, Set.empty) $ map mkNk (filterOut isInteractiveModule mods)
-
-    all_home_mods = [with_uid | NodeKey_Module with_uid <- Set.toList all_deps]
-
-    get_mod_info (ModNodeKeyWithUid gwib uid) =
-      case lookupHug (hsc_HUG hsc_env) uid (gwib_mod gwib) of
-        Just hmi ->
-          let iface = (hm_iface hmi)
-              mmod = case mi_hsc_src iface of
-                      HsBootFile -> link_boot_mod_error (mi_module iface)
-                      _ -> return $ Just (mi_module iface)
-
-          in (mkUniqDSet $ Set.toList $ dep_direct_pkgs (mi_deps iface),) <$>  mmod
-        Nothing ->
-          let err = text "getLinkDeps: Home module not loaded" <+> ppr (gwib_mod gwib) <+> ppr uid
-          in throwGhcExceptionIO (ProgramError (showSDoc dflags err))
-
-
-       -- This code is used in one-shot mode to traverse downwards through the HPT
-       -- to find all link dependencies.
-       -- 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 Module         -- accum. module dependencies
-                -> UniqDSet UnitId          -- accum. package dependencies
-                -> IO ([Module], UniqDSet UnitId) -- result
-    follow_deps []     acc_mods acc_pkgs
-        = return (uniqDSetToList acc_mods, acc_pkgs)
-    follow_deps (mod:mods) acc_mods acc_pkgs
-        = do
-          mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $
-                        loadInterface msg mod (ImportByUser NotBoot)
-          iface <- case mb_iface of
-                    Maybes.Failed err      -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))
-                    Maybes.Succeeded iface -> return iface
-
-          when (mi_boot iface == IsBoot) $ link_boot_mod_error mod
-
-          let
-            pkg = moduleUnit mod
-            deps  = mi_deps iface
-
-            pkg_deps = dep_direct_pkgs deps
-            (boot_deps, mod_deps) = flip partitionWith (Set.toList (dep_direct_mods deps)) $
-              \case
-                (_, GWIB m IsBoot)  -> Left m
-                (_, GWIB m NotBoot) -> Right m
-
-            mod_deps' = case hsc_home_unit_maybe hsc_env of
-                          Nothing -> []
-                          Just home_unit -> filter (not . (`elementOfUniqDSet` acc_mods)) (map (mkHomeModule home_unit) $ (boot_deps ++ mod_deps))
-            acc_mods'  = case hsc_home_unit_maybe hsc_env of
-                          Nothing -> acc_mods
-                          Just home_unit -> addListToUniqDSet acc_mods (mod : map (mkHomeModule home_unit) mod_deps)
-            acc_pkgs'  = addListToUniqDSet acc_pkgs (Set.toList pkg_deps)
-
-          case hsc_home_unit_maybe hsc_env of
-            Just home_unit | isHomeUnit home_unit pkg ->  follow_deps (mod_deps' ++ mods)
-                                                                      acc_mods' acc_pkgs'
-            _ ->  follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))
-        where
-           msg = text "need to link module" <+> ppr mod <+>
-                  text "due to use of Template Haskell"
-
-
-
-    link_boot_mod_error :: Module -> IO a
-    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"
-
-
-    -- See Note [Using Byte Code rather than Object Code for Template Haskell]
-    homeModLinkable :: DynFlags -> HomeModInfo -> Maybe Linkable
-    homeModLinkable dflags hmi =
-      if gopt Opt_UseBytecodeRatherThanObjects dflags
-        then homeModInfoByteCode hmi <|> homeModInfoObject hmi
-        else homeModInfoObject hmi   <|> homeModInfoByteCode hmi
-
-    get_linkable osuf mod      -- A home-package module
-        | Just mod_info <- lookupHugByModule mod (hsc_HUG hsc_env)
-        = adjust_linkable (Maybes.expectJust "getLinkDeps" (homeModLinkable dflags 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...
-             case hsc_home_unit_maybe hsc_env of
-              Nothing -> no_obj mod
-              Just home_unit -> do
-
-                let fc = hsc_FC hsc_env
-                let dflags = hsc_dflags hsc_env
-                let fopts = initFinderOpts dflags
-                mb_stuff <- findHomeModule fc fopts home_unit (moduleName mod)
-                case mb_stuff of
-                  Found loc mod -> found loc mod
-                  _ -> no_obj (moduleName mod)
-        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
-            adjust_ul _ l@LoadedBCOs{} = return l
-            adjust_ul _ (CoreBindings (WholeCoreBindings _ mod _))     = pprPanic "Unhydrated core bindings" (ppr mod)
-
-{-
-Note [Using Byte Code rather than Object Code for Template Haskell]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The `-fprefer-byte-code` flag allows a user to specify that they want to use
-byte code (if availble) rather than object code for home module dependenices
-when executing Template Haskell splices.
-
-Why might you want to use byte code rather than object code?
-
-* Producing object code is much slower than producing byte code (for example if you're using -fno-code)
-* Linking many large object files, which happens once per splice, is quite expensive. (#21700)
-
-So we allow the user to choose to use byte code rather than object files if they want to avoid these
-two pitfalls.
-
-When using `-fprefer-byte-code` you have to arrange to have the byte code availble.
-In normal --make mode it will not be produced unless you enable `-fbyte-code-and-object-code`.
-See Note [Home module build products] for some more information about that.
-
-The only other place where the flag is consulted is when enabling code generation
-with `-fno-code`, which does so to anticipate what decision we will make at the
-splice point about what we would prefer.
-
--}
-
-{- **********************************************************************
-
-              Loading a Decls statement
-
-  ********************************************************************* -}
-
-loadDecls :: Interp -> HscEnv -> SrcSpan -> CompiledByteCode -> IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded)
-loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do
-    -- Initialise the linker (if it's not been done already)
-    initLoaderState interp hsc_env
-
-    -- Take lock for the actual work.
-    modifyLoaderState interp $ \pls0 -> do
-      -- Link the packages and modules required
-      (pls, ok, links_needed, units_needed) <- loadDependencies interp 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
-          bco_opts <- initBCOOpts (hsc_dflags hsc_env)
-          new_bindings <- linkSomeBCOs bco_opts interp ie ce [cbc]
-          nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings
-          let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs
-                         , itbl_env    = ie }
-          return (pls2, (nms_fhvs, links_needed, units_needed))
-  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
-
-  ********************************************************************* -}
-
-loadModule :: Interp -> HscEnv -> Module -> IO ()
-loadModule interp hsc_env mod = do
-  initLoaderState interp hsc_env
-  modifyLoaderState_ interp $ \pls -> do
-    (pls', ok, _, _) <- loadDependencies interp hsc_env pls noSrcSpan [mod]
-    if failed ok
-      then throwGhcExceptionIO (ProgramError "could not load module")
-      else return pls'
-
-{- **********************************************************************
-
-                Link some linkables
-        The linkables may consist of a mixture of
-        byte-code modules and object modules
-
-  ********************************************************************* -}
-
-loadModuleLinkables :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag)
-loadModuleLinkables interp hsc_env pls linkables
-  = mask_ $ do  -- don't want to be interrupted by ^C in here
-
-        let (objs, bcos) = partition isObjectLinkable
-                              (concatMap partitionLinkable linkables)
-        bco_opts <- initBCOOpts (hsc_dflags hsc_env)
-
-                -- Load objects first; they can't depend on BCOs
-        (pls1, ok_flag) <- loadObjects interp hsc_env pls objs
-
-        if failed ok_flag then
-                return (pls1, Failed)
-          else do
-                pls2 <- dynLinkBCOs bco_opts interp 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 :: LinkableSet -> Module -> Maybe Linkable
-findModuleLinkable_maybe = lookupModuleEnv
-
-linkableInSet :: Linkable -> LinkableSet -> 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
-
-  ********************************************************************* -}
-
--- | Load the object files and link them
---
--- If the interpreter uses dynamic-linking, build a shared library and load it.
--- Otherwise, use the RTS linker.
-loadObjects
-  :: Interp
-  -> HscEnv
-  -> LoaderState
-  -> [Linkable]
-  -> IO (LoaderState, SuccessFlag)
-loadObjects interp hsc_env pls objs = do
-        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 interp
-            then do pls2 <- dynLoadObjs interp hsc_env pls1 wanted_objs
-                    return (pls2, Succeeded)
-            else do mapM_ (loadObj interp) wanted_objs
-
-                    -- Link them all together
-                    ok <- resolveObjs interp
-
-                    -- If resolving failed, unload all our
-                    -- object modules and carry on
-                    if succeeded ok then
-                            return (pls1, Succeeded)
-                      else do
-                            pls2 <- unload_wkr interp [] pls1
-                            return (pls2, Failed)
-
-
--- | Create a shared library containing the given object files and load it.
-dynLoadObjs :: Interp -> HscEnv -> LoaderState -> [FilePath] -> IO LoaderState
-dynLoadObjs _      _       pls                           []   = return pls
-dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do
-    let unit_env = hsc_unit_env hsc_env
-    let dflags   = hsc_dflags hsc_env
-    let logger   = hsc_logger hsc_env
-    let tmpfs    = hsc_tmpfs hsc_env
-    let platform = ue_platform unit_env
-    let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]
-    let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]
-    (soFile, libPath , libName) <-
-      newTempLibName logger tmpfs (tmpDir dflags) TFL_CurrentModule (platformSOExt 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)
-                                          : if useXLinkerRPath dflags (platformOS platform)
-                                            then [ Option "-Xlinker"
-                                                 , Option "-rpath"
-                                                 , Option "-Xlinker"
-                                                 , Option lp ]
-                                            else [])
-                                     (nub $ fst <$> temp_sos)
-                        ++ concatMap
-                             (\lp -> Option ("-L" ++ lp)
-                                  : if useXLinkerRPath dflags (platformOS platform)
-                                    then [ Option "-Xlinker"
-                                         , Option "-rpath"
-                                         , Option "-Xlinker"
-                                         , Option lp ]
-                                    else [])
-                             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.
-                      targetWays_ = Set.singleton 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 logger tmpfs dflags2 unit_env objs (loaded_pkg_uid <$> eltsUDFM pkgs_loaded)
-
-    -- if we got this far, extend the lifetime of the library file
-    changeTempFilesLifetime tmpfs TFL_GhcSession [soFile]
-    m <- loadDLL interp soFile
-    case m of
-        Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
-        Just err -> linkFail msg err
-  where
-    msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed"
-
-rmDupLinkables :: LinkableSet    -- Already loaded
-               -> [Linkable]    -- New linkables
-               -> (LinkableSet,  -- 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 (extendModuleEnv already (linkableModule l) l) (l:extras) ls
-
-{- **********************************************************************
-
-                The byte-code linker
-
-  ********************************************************************* -}
-
-
-dynLinkBCOs :: BCOOpts -> Interp -> LoaderState -> [Linkable] -> IO LoaderState
-dynLinkBCOs bco_opts interp 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      = concatMap byteCodeOfObject unlinkeds
-
-
-            ies        = map bc_itbls cbcs
-            gce       = closure_env pls
-            final_ie  = foldr plusNameEnv (itbl_env pls) ies
-
-        names_and_refs <- linkSomeBCOs bco_opts interp 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 interp (map snd to_drop)
-        -- Wrap finalizers on the ones we want to keep
-        new_binds <- makeForeignNamedHValueRefs interp 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 :: BCOOpts
-             -> Interp
-             -> 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 bco_opts interp 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 interp ie ce bco_ix breakarray bco
-                         | (breakarray, bco) <- flat ]
-    hvrefs <- createBCOs interp bco_opts resolved
-    return (zip names hvrefs)
-
--- | Useful to apply to the result of 'linkSomeBCOs'
-makeForeignNamedHValueRefs
-  :: Interp -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)]
-makeForeignNamedHValueRefs interp bindings =
-  mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue interp 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
-  :: Interp
-  -> HscEnv
-  -> [Linkable] -- ^ The linkables to *keep*.
-  -> IO ()
-unload interp 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)
-        initLoaderState interp hsc_env
-
-        new_pls
-            <- modifyLoaderState interp $ \pls -> do
-                 pls1 <- unload_wkr interp linkables pls
-                 return (pls1, pls1)
-
-        let logger = hsc_logger hsc_env
-        debugTraceMsg logger 3 $
-          text "unload: retaining objs" <+> ppr (moduleEnvElts $ objs_loaded new_pls)
-        debugTraceMsg logger 3 $
-          text "unload: retaining bcos" <+> ppr (moduleEnvElts $ bcos_loaded new_pls)
-        return ()
-
-unload_wkr
-  :: Interp
-  -> [Linkable]                -- stable linkables
-  -> LoaderState
-  -> IO LoaderState
--- Does the core unload business
--- (the wrapper blocks exceptions and deals with the LS get and put)
-
-unload_wkr interp keep_linkables pls@LoaderState{..}  = do
-  -- NB. careful strictness here to avoid keeping the old LS 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
-      objs_to_keep = mkLinkableSet objs_to_keep'
-      bcos_to_keep = mkLinkableSet bcos_to_keep'
-
-      discard keep l = not (linkableInSet l keep)
-
-      (objs_to_unload, remaining_objs_loaded) =
-         partitionModuleEnv (discard objs_to_keep) objs_loaded
-      (bcos_to_unload, remaining_bcos_loaded) =
-         partitionModuleEnv (discard bcos_to_keep) bcos_loaded
-
-      linkables_to_unload = moduleEnvElts objs_to_unload ++ moduleEnvElts bcos_to_unload
-
-  mapM_ unloadObjs linkables_to_unload
-
-  -- If we unloaded any object files at all, we need to purge the cache
-  -- of lookupSymbol results.
-  when (not (null (filter (not . null . linkableObjs) linkables_to_unload))) $
-    purgeLookupSymbolCache interp
-
-  let -- 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 :: (Name, a) -> Bool
-      keep_name (n,_) = isExternalName n &&
-                        nameModule n `elemModuleEnv` remaining_bcos_loaded
-
-      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
-      | interpreterDynamic interp = return ()
-        -- We don't do any cleanup when linking objects with the
-        -- dynamic linker.  Doing so introduces extra complexity for
-        -- not much benefit.
-
-      | otherwise
-      = mapM_ (unloadObj interp) [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)
-
-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
-
--- | Load exactly the specified packages, and their dependents (unless of
--- course they are already loaded).  The dependents are loaded
--- automatically, and it doesn't matter what order you specify the input
--- packages.
---
-loadPackages :: Interp -> HscEnv -> [UnitId] -> 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.
-
-loadPackages interp hsc_env new_pkgs = do
-  -- It's probably not safe to try to load packages concurrently, so we take
-  -- a lock.
-  initLoaderState interp hsc_env
-  modifyLoaderState_ interp $ \pls ->
-    loadPackages' interp hsc_env new_pkgs pls
-
-loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState
-loadPackages' interp hsc_env new_pks pls = do
-    pkgs' <- link (pkgs_loaded pls) new_pks
-    return $! pls { pkgs_loaded = pkgs'
-                  }
-  where
-     link :: PkgsLoaded -> [UnitId] -> IO PkgsLoaded
-     link pkgs new_pkgs =
-         foldM link_one pkgs new_pkgs
-
-     link_one pkgs new_pkg
-        | new_pkg `elemUDFM` pkgs   -- Already linked
-        = return pkgs
-
-        | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg
-        = do { let deps = unitDepends pkg_cfg
-               -- Link dependents first
-             ; pkgs' <- link pkgs deps
-                -- Now link the package itself
-             ; (hs_cls, extra_cls) <- loadPackage interp hsc_env pkg_cfg
-             ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg
-                                                   | dep_pkg <- deps
-                                                   , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg)
-                                                   ]
-             ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls trans_deps)) }
-
-        | otherwise
-        = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))
-
-
-loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec])
-loadPackage interp hsc_env pkg
-   = do
-        let dflags    = hsc_dflags hsc_env
-        let logger    = hsc_logger hsc_env
-            platform  = targetPlatform dflags
-            is_dyn    = interpreterDynamic interp
-            dirs | is_dyn    = map ST.unpack $ Packages.unitLibraryDynDirs pkg
-                 | otherwise = map ST.unpack $ Packages.unitLibraryDirs pkg
-
-        let hs_libs   = map ST.unpack $ Packages.unitLibraries pkg
-            -- The FFI GHCi import lib isn't needed as
-            -- GHC.Linker.Loader + 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.
-            extdeplibs = map ST.unpack (if null (Packages.unitExtDepLibsGhc pkg)
-                                      then Packages.unitExtDepLibsSys pkg
-                                      else Packages.unitExtDepLibsGhc pkg)
-            linkerlibs = [ lib | '-':'l':lib <- (map ST.unpack $ Packages.unitLinkerOptions pkg) ]
-            extra_libs = extdeplibs ++ linkerlibs
-
-        -- See Note [Fork/Exec Windows]
-        gcc_paths <- getGCCPaths logger dflags (platformOS platform)
-        dirs_env <- addEnvPaths "LIBRARY_PATH" dirs
-
-        hs_classifieds
-           <- mapM (locateLib interp hsc_env True  dirs_env gcc_paths) hs_libs'
-        extra_classifieds
-           <- mapM (locateLib interp 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 ]
-#if defined(CAN_LOAD_DLL)
-            dlls       = [ dll  | DLL dll        <- classifieds ]
-#endif
-            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 interp) all_paths_env
-
-        maybePutSDoc logger
-            (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ")
-
-#if defined(CAN_LOAD_DLL)
-        loadFrameworks interp platform pkg
-        -- See Note [Crash early load_dyn and locateLib]
-        -- Crash early if can't load any of `known_dlls`
-        mapM_ (load_dyn interp 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 interp hsc_env (not is_dyn) . platformSOName platform) dlls
-#endif
-        -- 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 interp) objs
-        mapM_ (loadArchive interp) archs
-
-        maybePutStr logger "linking ... "
-        ok <- resolveObjs interp
-
-        -- 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 interp) $ reverse pathCache
-
-        if succeeded ok
-           then do
-             maybePutStrLn logger "done."
-             return (hs_classifieds, extra_classifieds)
-           else let errmsg = text "unable to load unit `"
-                             <> pprUnitInfoForUser pkg <> text "'"
-                 in throwGhcExceptionIO (InstallationError (showSDoc dflags 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.
--}
-
-#if defined(CAN_LOAD_DLL)
--- 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 :: Interp -> HscEnv -> Bool -> FilePath -> IO ()
-load_dyn interp hsc_env crash_early dll = do
-  r <- loadDLL interp dll
-  case r of
-    Nothing  -> return ()
-    Just err ->
-      if crash_early
-        then cmdLineErrorIO err
-        else
-          when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts)
-            $ logMsg logger
-                (mkMCDiagnostic diag_opts (WarningWithFlag Opt_WarnMissedExtraSharedLib) Nothing)
-                  noSrcSpan $ withPprStyle defaultUserStyle (note err)
-  where
-    diag_opts = initDiagOpts (hsc_dflags hsc_env)
-    logger = hsc_logger hsc_env
-    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 :: Interp -> Platform -> UnitInfo -> IO ()
-loadFrameworks interp platform pkg
-    = when (platformUsesFrameworks platform) $ mapM_ load frameworks
-  where
-    fw_dirs    = map ST.unpack $ Packages.unitExtDepFrameworkDirs pkg
-    frameworks = map ST.unpack $ Packages.unitExtDepFrameworks pkg
-
-    load fw = do  r <- loadFramework interp fw_dirs fw
-                  case r of
-                    Nothing  -> return ()
-                    Just err -> cmdLineErrorIO ("can't load framework: "
-                                                ++ fw ++ " (" ++ err ++ ")" )
-#endif
-
--- 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
-  :: Interp
-  -> HscEnv
-  -> Bool
-  -> [FilePath]
-  -> [FilePath]
-  -> String
-  -> IO LibrarySpec
-locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0
-  | 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.
-    --
-  =
-#if defined(CAN_LOAD_DLL)
-    findDll   user `orElse`
-#endif
-    tryImpLib user `orElse`
-#if defined(CAN_LOAD_DLL)
-    findDll   gcc  `orElse`
-    findSysDll     `orElse`
-#endif
-    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
-     logger = hsc_logger hsc_env
-     diag_opts = initDiagOpts dflags
-     dirs   = lib_dirs ++ gcc_dirs
-     gcc    = False
-     user   = True
-
-     -- Emulate ld's behavior of treating $LIB in `-l:$LIB` as a literal file
-     -- name
-     (lib, verbatim) = case lib0 of
-       ':' : rest -> (rest, True)
-       other      -> (other, False)
-
-     obj_file
-       | is_hs && loading_profiled_hs_libs = lib <.> "p_o"
-       | otherwise = lib <.> "o"
-     dyn_obj_file = lib <.> "dyn_o"
-     arch_files
-       | verbatim = [lib]
-       | otherwise = [ "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 interp
-     loading_dynamic_hs_libs  = interpreterDynamic  interp
-
-     import_libs
-       | verbatim = [lib]
-       | otherwise = [ lib <.> "lib"
-                     , "lib" ++ lib <.> "lib"
-                     , "lib" ++ lib <.> "dll.a"
-                     , lib <.> "dll.a"
-                     ]
-
-     hs_dyn_lib_name = lib ++ dynLibSuffix (ghcNameVersion dflags)
-     hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name
-
-#if defined(CAN_LOAD_DLL)
-     so_name     = platformSOName platform lib
-     lib_so_name = "lib" ++ so_name
-     dyn_lib_file
-       | verbatim && any (`isExtensionOf` lib) [".so", ".dylib", ".dll"]
-       = lib
-
-       | ArchX86_64 <- arch
-       , OSSolaris2 <- os
-       = "64" </> so_name
-
-       | otherwise
-        = so_name
-#endif
-
-     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
-#if defined(CAN_LOAD_DLL)
-     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 interp so_name
-#endif
-     tryGcc        = let search   = searchForLibUsingGcc logger dflags
-#if defined(CAN_LOAD_DLL)
-                         dllpath  = liftM (fmap DLLPath)
-                         short    = dllpath $ search so_name lib_dirs
-                         full     = dllpath $ search lib_so_name lib_dirs
-                         dlls     = [short, full]
-#endif
-                         gcc name = liftM (fmap Archive) $ search name lib_dirs
-                         files    = import_libs ++ arch_files
-                         archives = map gcc files
-                     in apply $
-#if defined(CAN_LOAD_DLL)
-                          dlls ++
-#endif
-                          archives
-     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 interp
-      = do
-          let diag = mkMCDiagnostic diag_opts WarningWithoutFlag Nothing
-          logMsg logger diag noSrcSpan $ withPprStyle defaultErrStyle $
-            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
-#if defined(CAN_LOAD_DLL)
-     arch = platformArch platform
-#endif
-     os = platformOS platform
-
-searchForLibUsingGcc :: Logger -> DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)
-searchForLibUsingGcc logger 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 logger 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 :: Logger -> DynFlags -> OS -> IO [FilePath]
-getGCCPaths logger dflags os
-  = case os of
-      OSMinGW32 ->
-        do gcc_dirs <- getGccSearchDirectory logger 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 manner 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 :: Logger -> DynFlags -> String -> IO [FilePath]
-getGccSearchDirectory logger dflags key = do
-    cache <- readIORef gccSearchDirCache
-    case lookup key cache of
-      Just x  -> return x
-      Nothing -> do
-        str <- askLd logger 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 case val of
-                              [] -> []
-                              x:_ -> case break (=='=') x 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)
-
-
-{- **********************************************************************
-
-                Helper functions
-
-  ********************************************************************* -}
-
-maybePutSDoc :: Logger -> SDoc -> IO ()
-maybePutSDoc logger s
-    = when (logVerbAtLeast logger 2) $
-          logMsg logger
-              MCInteractive
-              noSrcSpan
-              $ withPprStyle defaultUserStyle s
-
-maybePutStr :: Logger -> String -> IO ()
-maybePutStr logger s = maybePutSDoc logger (text s)
-
-maybePutStrLn :: Logger -> String -> IO ()
-maybePutStrLn logger s = maybePutSDoc logger (text s <> text "\n")
diff --git a/compiler/GHC/Linker/MacOS.hs b/compiler/GHC/Linker/MacOS.hs
deleted file mode 100644
--- a/compiler/GHC/Linker/MacOS.hs
+++ /dev/null
@@ -1,176 +0,0 @@
-module GHC.Linker.MacOS
-   ( runInjectRPaths
-   , getUnitFrameworkOpts
-   , getFrameworkOpts
-   , loadFramework
-   )
-where
-
-import GHC.Prelude
-import GHC.Platform
-
-import GHC.Driver.Session
-
-import GHC.Unit.Types
-import GHC.Unit.State
-import GHC.Unit.Env
-
-import GHC.SysTools.Tasks
-
-import GHC.Runtime.Interpreter
-
-import GHC.Utils.Exception
-import GHC.Utils.Logger
-
-import Data.List (isPrefixOf, nub, sort, intersperse, intercalate)
-import Data.Char
-import Data.Maybe
-import Control.Monad (join, forM, filterM, void)
-import System.Directory (doesFileExist, getHomeDirectory)
-import System.FilePath ((</>), (<.>))
-import Text.ParserCombinators.ReadP as Parser
-
--- | On macOS we rely on the linkers @-dead_strip_dylibs@ flag to remove unused
--- libraries from the dynamic library.  We do this to reduce the number of load
--- commands that end up in the dylib, and has been limited to 32K (32768) since
--- macOS Sierra (10.14).
---
--- @-dead_strip_dylibs@ does not dead strip @-rpath@ entries, as such passing
--- @-l@ and @-rpath@ to the linker will result in the unnecessary libraries not
--- being included in the load commands, however the @-rpath@ entries are all
--- forced to be included.  This can lead to 100s of @-rpath@ entries being
--- included when only a handful of libraries end up being truly linked.
---
--- Thus after building the library, we run a fixup phase where we inject the
--- @-rpath@ for each found library (in the given library search paths) into the
--- dynamic library through @-add_rpath@.
---
--- See Note [Dynamic linking on macOS]
-runInjectRPaths :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO ()
--- Make sure to honour -fno-use-rpaths if set on darwin as well see #20004
-runInjectRPaths _ dflags _ _ | not (gopt Opt_RPath dflags) = return ()
-runInjectRPaths logger dflags lib_paths dylib = do
-  info <- lines <$> askOtool logger dflags Nothing [Option "-L", Option dylib]
-  -- filter the output for only the libraries. And then drop the @rpath prefix.
-  let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info
-  -- find any pre-existing LC_PATH items
-  info <- lines <$> askOtool logger dflags Nothing [Option "-l", Option dylib]
-  let paths = mapMaybe get_rpath info
-      lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ]
-  -- only find those rpaths, that aren't already in the library.
-  rpaths <- nub . sort . join <$> forM libs (\f -> filterM (\l -> doesFileExist (l </> f)) lib_paths')
-  -- inject the rpaths
-  case rpaths of
-    [] -> return ()
-    _  -> runInstallNameTool logger dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib]
-
-get_rpath :: String -> Maybe FilePath
-get_rpath l = case readP_to_S rpath_parser l of
-                [(rpath, "")] -> Just rpath
-                _ -> Nothing
-
-
-rpath_parser :: ReadP FilePath
-rpath_parser = do
-  skipSpaces
-  void $ string "path"
-  void $ many1 (satisfy isSpace)
-  rpath <- many get
-  void $ many1 (satisfy isSpace)
-  void $ string "(offset "
-  void $ munch1 isDigit
-  void $ Parser.char ')'
-  skipSpaces
-  return rpath
-
-
-getUnitFrameworkOpts :: UnitEnv -> [UnitId] -> IO [String]
-getUnitFrameworkOpts unit_env dep_packages
-  | platformUsesFrameworks (ue_platform unit_env) = do
-        ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages)
-        let pkg_framework_path_opts = map ("-F" ++) (collectFrameworksDirs ps)
-            pkg_framework_opts      = concat [ ["-framework", fw]
-                                             | fw <- collectFrameworks ps
-                                             ]
-        return (pkg_framework_path_opts ++ pkg_framework_opts)
-
-  | otherwise = return []
-
-getFrameworkOpts :: DynFlags -> Platform -> [String]
-getFrameworkOpts dflags platform
-  | platformUsesFrameworks platform = framework_path_opts ++ framework_opts
-  | otherwise = []
-  where
-    framework_paths     = frameworkPaths dflags
-    framework_path_opts = map ("-F" ++) framework_paths
-
-    frameworks     = cmdlineFrameworks dflags
-    -- reverse because they're added in reverse order from the cmd line:
-    framework_opts = concat [ ["-framework", fw]
-                            | fw <- reverse frameworks ]
-
-
-{-
-Note [macOS Big Sur dynamic libraries]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-macOS Big Sur makes the following change to how frameworks are shipped
-with the OS:
-
-> New in macOS Big Sur 11 beta, the system ships with a built-in
-> dynamic linker cache of all system-provided libraries.  As part of
-> this change, copies of dynamic libraries are no longer present on
-> the filesystem.  Code that attempts to check for dynamic library
-> presence by looking for a file at a path or enumerating a directory
-> will fail.  Instead, check for library presence by attempting to
-> dlopen() the path, which will correctly check for the library in the
-> cache. (62986286)
-
-(https://developer.apple.com/documentation/macos-release-notes/macos-big-sur-11-beta-release-notes/)
-
-Therefore, the previous method of checking whether a library exists
-before attempting to load it makes GHC.Linker.MacOS.loadFramework
-fail to find frameworks installed at /System/Library/Frameworks.
-Instead, any attempt to load a framework at runtime, such as by
-passing -framework OpenGL to runghc or running code loading such a
-framework with GHCi, fails with a 'not found' message.
-
-GHC.Linker.MacOS.loadFramework now opportunistically loads the
-framework libraries without checking for their existence first,
-failing only if all attempts to load a given framework from any of the
-various possible locations fail.  See also #18446, which this change
-addresses.
--}
-
--- 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 :: Interp -> [FilePath] -> FilePath -> IO (Maybe String)
-loadFramework interp extraPaths rootname
-   = do { either_dir <- tryIO getHomeDirectory
-        ; let homeFrameworkPath = case either_dir of
-                                  Left _ -> []
-                                  Right dir -> [dir </> "Library/Frameworks"]
-              ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
-        ; errs <- findLoadDLL ps []
-        ; return $ fmap (intercalate ", ") errs
-        }
-   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"]
-
-     -- Try to call loadDLL for each candidate path.
-     --
-     -- See Note [macOS Big Sur dynamic libraries]
-     findLoadDLL [] errs =
-       -- Tried all our known library paths, but dlopen()
-       -- has no built-in paths for frameworks: give up
-       return $ Just errs
-     findLoadDLL (p:ps) errs =
-       do { dll <- loadDLL interp (p </> fwk_file)
-          ; case dll of
-              Nothing  -> return Nothing
-              Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs)
-          }
diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs
deleted file mode 100644
--- a/compiler/GHC/Linker/Static.hs
+++ /dev/null
@@ -1,305 +0,0 @@
-module GHC.Linker.Static
-   ( linkBinary
-   , linkStaticLib
-   )
-where
-
-import GHC.Prelude
-import GHC.Platform
-import GHC.Platform.Ways
-import GHC.Settings
-
-import GHC.SysTools
-import GHC.SysTools.Ar
-
-import GHC.Unit.Env
-import GHC.Unit.Types
-import GHC.Unit.Info
-import GHC.Unit.State
-
-import GHC.Utils.Logger
-import GHC.Utils.Monad
-import GHC.Utils.Misc
-import GHC.Utils.TmpFs
-
-import GHC.Linker.MacOS
-import GHC.Linker.Unit
-import GHC.Linker.Dynamic
-import GHC.Linker.ExtraObj
-import GHC.Linker.Windows
-import GHC.Linker.Static.Utils
-
-import GHC.Driver.Session
-
-import System.FilePath
-import System.Directory
-import Control.Monad
-import Data.Maybe
-
------------------------------------------------------------------------------
--- Static linking, of .o files
-
--- The list of packages passed to link is the list of packages on
--- which this program depends, as discovered by the compilation
--- manager.  It is combined with the list of packages that the user
--- specifies on the command line with -package flags.
---
--- In one-shot linking mode, we can't discover the package
--- dependencies (because we haven't actually done any compilation or
--- read any interface files), so the user must explicitly specify all
--- the packages.
-
-{-
-Note [-Xlinker -rpath vs -Wl,-rpath]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
--Wl takes a comma-separated list of options which in the case of
--Wl,-rpath -Wl,some,path,with,commas parses the path with commas
-as separate options.
-Buck, the build system, produces paths with commas in them.
-
--Xlinker doesn't have this disadvantage and as far as I can tell
-it is supported by both gcc and clang. Anecdotally nvcc supports
--Xlinker, but not -Wl.
--}
-
-linkBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
-linkBinary = linkBinary' False
-
-linkBinary' :: Bool -> Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()
-linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do
-    let platform   = ue_platform unit_env
-        unit_state = ue_units unit_env
-        toolSettings' = toolSettings dflags
-        verbFlags = getVerbFlags dflags
-        arch_os   = platformArchOS platform
-        output_fn = exeFileName arch_os staticLink (outputFile_ dflags)
-        namever   = ghcNameVersion dflags
-        ways_     = ways dflags
-
-    full_output_fn <- if isAbsolute output_fn
-                      then return output_fn
-                      else do d <- getCurrentDirectory
-                              return $ normalise (d </> output_fn)
-
-    -- get the full list of packages to link with, by combining the
-    -- explicit packages with the auto packages and all of their
-    -- dependencies, and eliminating duplicates.
-    pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units)
-    let pkg_lib_paths     = collectLibraryDirs ways_ pkgs
-    let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
-        get_pkg_lib_path_opts l
-         | osElfTarget (platformOS platform) &&
-           dynLibLoader dflags == SystemDependent &&
-           ways_ `hasWay` WayDyn
-            = let libpath = if gopt Opt_RelativeDynlibPaths dflags
-                            then "$ORIGIN" </>
-                                 (l `makeRelativeTo` full_output_fn)
-                            else l
-                  -- See Note [-Xlinker -rpath vs -Wl,-rpath]
-                  rpath = if useXLinkerRPath dflags (platformOS platform)
-                          then ["-Xlinker", "-rpath", "-Xlinker", libpath]
-                          else []
-                  -- Solaris 11's linker does not support -rpath-link option. It silently
-                  -- ignores it and then complains about next option which is -l<some
-                  -- dir> as being a directory and not expected object file, E.g
-                  -- ld: elf error: file
-                  -- /tmp/ghc-src/libraries/base/dist-install/build:
-                  -- elf_begin: I/O error: region read: Is a directory
-                  rpathlink = if (platformOS platform) == OSSolaris2
-                              then []
-                              else ["-Xlinker", "-rpath-link", "-Xlinker", l]
-              in ["-L" ++ l] ++ rpathlink ++ rpath
-         | osMachOTarget (platformOS platform) &&
-           dynLibLoader dflags == SystemDependent &&
-           ways_ `hasWay` WayDyn &&
-           useXLinkerRPath dflags (platformOS platform)
-            = let libpath = if gopt Opt_RelativeDynlibPaths dflags
-                            then "@loader_path" </>
-                                 (l `makeRelativeTo` full_output_fn)
-                            else l
-              in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]
-         | otherwise = ["-L" ++ l]
-
-    pkg_lib_path_opts <-
-      if gopt Opt_SingleLibFolder dflags
-      then do
-        libs <- getLibs namever ways_ unit_env dep_units
-        tmpDir <- newTempDir logger tmpfs (tmpDir dflags)
-        sequence_ [ copyFile lib (tmpDir </> basename)
-                  | (lib, basename) <- libs]
-        return [ "-L" ++ tmpDir ]
-      else pure pkg_lib_path_opts
-
-    let
-      dead_strip
-        | gopt Opt_WholeArchiveHsLibs dflags = []
-        | otherwise = if osSubsectionsViaSymbols (platformOS platform)
-                        then ["-Wl,-dead_strip"]
-                        else []
-    let lib_paths = libraryPaths dflags
-    let lib_path_opts = map ("-L"++) lib_paths
-
-    extraLinkObj <- maybeToList <$> mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state
-    noteLinkObjs <- mkNoteObjsToLinkIntoBinary logger tmpfs dflags unit_env dep_units
-
-    let
-      (pre_hs_libs, post_hs_libs)
-        | gopt Opt_WholeArchiveHsLibs dflags
-        = if platformOS platform == OSDarwin
-            then (["-Wl,-all_load"], [])
-              -- OS X does not have a flag to turn off -all_load
-            else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])
-        | otherwise
-        = ([],[])
-
-    pkg_link_opts <- do
-        (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts namever ways_ unit_env dep_units
-        return $ other_flags ++ dead_strip
-                  ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs
-                  ++ extra_libs
-                 -- -Wl,-u,<sym> contained in other_flags
-                 -- needs to be put before -l<package>,
-                 -- otherwise Solaris linker fails linking
-                 -- a binary with unresolved symbols in RTS
-                 -- which are defined in base package
-                 -- the reason for this is a note in ld(1) about
-                 -- '-u' option: "The placement of this option
-                 -- on the command line is significant.
-                 -- This option must be placed before the library
-                 -- that defines the symbol."
-
-    -- frameworks
-    pkg_framework_opts <- getUnitFrameworkOpts unit_env dep_units
-    let framework_opts = getFrameworkOpts dflags platform
-
-        -- probably _stub.o files
-    let extra_ld_inputs = ldInputs dflags
-
-    rc_objs <- case platformOS platform of
-      OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest logger tmpfs dflags output_fn
-      _                                       -> return []
-
-    let link dflags args | platformOS platform == OSDarwin
-                            = do
-                                 GHC.SysTools.runLink logger tmpfs dflags args
-                                 GHC.Linker.MacOS.runInjectRPaths logger dflags pkg_lib_paths output_fn
-                         | otherwise
-                            = GHC.SysTools.runLink logger tmpfs dflags args
-
-    link dflags (
-                       map GHC.SysTools.Option verbFlags
-                      ++ [ GHC.SysTools.Option "-o"
-                         , GHC.SysTools.FileOption "" output_fn
-                         ]
-                      ++ libmLinkOpts platform
-                      ++ map GHC.SysTools.Option (
-                         []
-
-                      -- See Note [No PIE when linking]
-                      ++ pieCCLDOpts dflags
-
-                      -- Permit the linker to auto link _symbol to _imp_symbol.
-                      -- This lets us link against DLLs without needing an "import library".
-                      ++ (if platformOS platform == OSMinGW32
-                          then ["-Wl,--enable-auto-import"]
-                          else [])
-
-                      -- '-no_compact_unwind'
-                      -- C++/Objective-C exceptions cannot use optimised
-                      -- stack unwinding code. The optimised form is the
-                      -- default in Xcode 4 on at least x86_64, and
-                      -- without this flag we're also seeing warnings
-                      -- like
-                      --     ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog
-                      -- on x86.
-                      ++ (if not (gopt Opt_CompactUnwind dflags) &&
-                             toolSettings_ldSupportsCompactUnwind toolSettings' &&
-                             (platformOS platform == OSDarwin) &&
-                             case platformArch platform of
-                               ArchX86     -> True
-                               ArchX86_64  -> True
-                               ArchARM {}  -> True
-                               ArchAArch64 -> True
-                               _ -> False
-                          then ["-Wl,-no_compact_unwind"]
-                          else [])
-
-                      -- '-Wl,-read_only_relocs,suppress'
-                      -- ld gives loads of warnings like:
-                      --     ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure
-                      -- when linking any program. We're not sure
-                      -- whether this is something we ought to fix, but
-                      -- for now this flags silences them.
-                      ++ (if platformOS   platform == OSDarwin &&
-                             platformArch platform == ArchX86
-                          then ["-Wl,-read_only_relocs,suppress"]
-                          else [])
-
-                      ++ (if toolSettings_ldIsGnuLd toolSettings' &&
-                             not (gopt Opt_WholeArchiveHsLibs dflags)
-                          then ["-Wl,--gc-sections"]
-                          else [])
-
-                      ++ o_files
-                      ++ lib_path_opts)
-                      ++ extra_ld_inputs
-                      ++ map GHC.SysTools.Option (
-                         rc_objs
-                      ++ framework_opts
-                      ++ pkg_lib_path_opts
-                      ++ extraLinkObj
-                      ++ noteLinkObjs
-                      ++ pkg_link_opts
-                      ++ pkg_framework_opts
-                      ++ (if platformOS platform == OSDarwin
-                          --  dead_strip_dylibs, will remove unused dylibs, and thus save
-                          --  space in the load commands. The -headerpad is necessary so
-                          --  that we can inject more @rpath's later for the left over
-                          --  libraries during runInjectRpaths phase.
-                          --
-                          --  See Note [Dynamic linking on macOS].
-                          then [ "-Wl,-dead_strip_dylibs", "-Wl,-headerpad,8000" ]
-                          else [])
-                    ))
-
--- | Linking a static lib will not really link anything. It will merely produce
--- a static archive of all dependent static libraries. The resulting library
--- will still need to be linked with any remaining link flags.
-linkStaticLib :: Logger -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()
-linkStaticLib logger dflags unit_env o_files dep_units = do
-  let platform  = ue_platform unit_env
-      extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
-      modules = o_files ++ extra_ld_inputs
-      arch_os = platformArchOS platform
-      output_fn = exeFileName arch_os True (outputFile_ dflags)
-      namever = ghcNameVersion dflags
-      ways_   = ways dflags
-
-  full_output_fn <- if isAbsolute output_fn
-                    then return output_fn
-                    else do d <- getCurrentDirectory
-                            return $ normalise (d </> output_fn)
-  output_exists <- doesFileExist full_output_fn
-  (when output_exists) $ removeFile full_output_fn
-
-  pkg_cfgs_init <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units)
-
-  let pkg_cfgs
-        | gopt Opt_LinkRts dflags
-        = pkg_cfgs_init
-        | otherwise
-        = filter ((/= rtsUnitId) . unitId) pkg_cfgs_init
-
-  archives <- concatMapM (collectArchives namever ways_) pkg_cfgs
-
-  ar <- foldl mappend
-        <$> (Archive <$> mapM loadObj modules)
-        <*> mapM loadAr archives
-
-  if toolSettings_ldIsGnuLd (toolSettings dflags)
-    then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar
-    else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar
-
-  -- run ranlib over the archive. write*Ar does *not* create the symbol index.
-  runRanlib logger dflags [GHC.SysTools.FileOption "" output_fn]
diff --git a/compiler/GHC/Linker/Unit.hs b/compiler/GHC/Linker/Unit.hs
deleted file mode 100644
--- a/compiler/GHC/Linker/Unit.hs
+++ /dev/null
@@ -1,63 +0,0 @@
-
--- | Linking Haskell units
-module GHC.Linker.Unit
-   ( collectLinkOpts
-   , collectArchives
-   , getUnitLinkOpts
-   , getLibs
-   )
-where
-
-import GHC.Prelude
-import GHC.Platform.Ways
-import GHC.Unit.Types
-import GHC.Unit.Info
-import GHC.Unit.State
-import GHC.Unit.Env
-import GHC.Utils.Misc
-
-import qualified GHC.Data.ShortText as ST
-
-import GHC.Settings
-
-import Control.Monad
-import System.Directory
-import System.FilePath
-
--- | Find all the link options in these and the preload packages,
--- returning (package hs lib options, extra library options, other flags)
-getUnitLinkOpts :: GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO ([String], [String], [String])
-getUnitLinkOpts namever ways unit_env pkgs = do
-    ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs
-    return (collectLinkOpts namever ways ps)
-
-collectLinkOpts :: GhcNameVersion -> Ways -> [UnitInfo] -> ([String], [String], [String])
-collectLinkOpts namever ways ps =
-    (
-        concatMap (map ("-l" ++) . unitHsLibs namever ways) ps,
-        concatMap (map ("-l" ++) . map ST.unpack . unitExtDepLibsSys) ps,
-        concatMap (map ST.unpack . unitLinkerOptions) ps
-    )
-
-collectArchives :: GhcNameVersion -> Ways -> UnitInfo -> IO [FilePath]
-collectArchives namever ways pc =
-  filterM doesFileExist [ searchPath </> ("lib" ++ lib ++ ".a")
-                        | searchPath <- searchPaths
-                        , lib <- libs ]
-  where searchPaths = ordNub . filter notNull . libraryDirsForWay ways $ pc
-        libs        = unitHsLibs namever ways pc ++ map ST.unpack (unitExtDepLibsSys pc)
-
--- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way.
-libraryDirsForWay :: Ways -> UnitInfo -> [String]
-libraryDirsForWay ws
-  | hasWay ws WayDyn = map ST.unpack . unitLibraryDynDirs
-  | otherwise        = map ST.unpack . unitLibraryDirs
-
-getLibs :: GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO [(String,String)]
-getLibs namever ways unit_env pkgs = do
-  ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs
-  fmap concat . forM ps $ \p -> do
-    let candidates = [ (l </> f, f) | l <- collectLibraryDirs ways [p]
-                                    , f <- (\n -> "lib" ++ n ++ ".a") <$> unitHsLibs namever ways p ]
-    filterM (doesFileExist . fst) candidates
-
diff --git a/compiler/GHC/Linker/Windows.hs b/compiler/GHC/Linker/Windows.hs
deleted file mode 100644
--- a/compiler/GHC/Linker/Windows.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-module GHC.Linker.Windows
-   ( maybeCreateManifest
-   )
-where
-
-import GHC.Prelude
-import GHC.SysTools
-import GHC.Driver.Session
-import GHC.Utils.TmpFs
-import GHC.Utils.Logger
-
-import System.FilePath
-import System.Directory
-
-maybeCreateManifest
-   :: Logger
-   -> TmpFs
-   -> DynFlags
-   -> FilePath      -- ^ filename of executable
-   -> IO [FilePath] -- ^ extra objects to embed, maybe
-maybeCreateManifest logger tmpfs dflags exe_filename = do
-   let manifest_filename = exe_filename <.> "manifest"
-       manifest =
-         "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n\
-         \  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n\
-         \  <assemblyIdentity version=\"1.0.0.0\"\n\
-         \     processorArchitecture=\"X86\"\n\
-         \     name=\"" ++ dropExtension exe_filename ++ "\"\n\
-         \     type=\"win32\"/>\n\n\
-         \  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n\
-         \    <security>\n\
-         \      <requestedPrivileges>\n\
-         \        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n\
-         \        </requestedPrivileges>\n\
-         \       </security>\n\
-         \  </trustInfo>\n\
-         \</assembly>\n"
-
-   writeFile manifest_filename manifest
-
-   -- Windows will find the manifest file if it is named
-   -- foo.exe.manifest. However, for extra robustness, and so that
-   -- we can move the binary around, we can embed the manifest in
-   -- the binary itself using windres:
-   if not (gopt Opt_EmbedManifest dflags)
-      then return []
-      else do
-         rc_filename <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rc"
-         rc_obj_filename <-
-           newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession (objectSuf dflags)
-
-         writeFile rc_filename $
-             "1 24 MOVEABLE PURE \"" ++ manifest_filename ++ "\"\n"
-               -- magic numbers :-)
-
-         runWindres logger dflags $ map GHC.SysTools.Option $
-               ["--input="++rc_filename,
-                "--output="++rc_obj_filename,
-                "--output-format=coff"]
-               -- no FileOptions here: windres doesn't like seeing
-               -- backslashes, apparently
-
-         removeFile manifest_filename
-
-         return [rc_obj_filename]
diff --git a/compiler/GHC/Llvm.hs b/compiler/GHC/Llvm.hs
deleted file mode 100644
--- a/compiler/GHC/Llvm.hs
+++ /dev/null
@@ -1,63 +0,0 @@
--- ----------------------------------------------------------------------------
--- | This module supplies bindings to generate Llvm IR from Haskell
--- (<http://www.llvm.org/docs/LangRef.html>).
---
--- Note: this module is developed in a demand driven way. It is no complete
--- LLVM binding library in Haskell, but enough to generate code for GHC.
---
--- This code is derived from code taken from the Essential Haskell Compiler
--- (EHC) project.
---
-
-module GHC.Llvm (
-        -- * Modules, Functions and Blocks
-        LlvmModule(..),
-
-        LlvmFunction(..), LlvmFunctionDecl(..),
-        LlvmFunctions, LlvmFunctionDecls,
-        LlvmStatement(..), LlvmExpression(..),
-        LlvmBlocks, LlvmBlock(..), LlvmBlockId,
-        LlvmParamAttr(..), LlvmParameter,
-
-        -- * Atomic operations
-        LlvmAtomicOp(..),
-
-        -- * Fence synchronization
-        LlvmSyncOrdering(..),
-
-        -- * Call Handling
-        LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..),
-        LlvmLinkageType(..), LlvmFuncAttr(..),
-
-        -- * Operations and Comparisons
-        LlvmCmpOp(..), LlvmMachOp(..), LlvmCastOp(..),
-
-        -- * Variables and Type System
-        LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..),
-        LlvmAlias, LMGlobal(..), LMString, LMSection, LMAlign,
-        LMConst(..),
-
-        -- ** Some basic types
-        i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr,
-
-        -- ** Metadata types
-        MetaExpr(..), MetaAnnot(..), MetaDecl(..), MetaId(..),
-
-        -- ** Operations on the type system.
-        isGlobal, getLitType, getVarType,
-        getLink, getStatType, pVarLift, pVarLower,
-        pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits,
-
-        -- * Pretty Printing
-        ppVar, ppLit, ppTypeLit, ppName, ppPlainName,
-        ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
-        ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,
-        ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,
-
-    ) where
-
-import GHC.Llvm.Syntax
-import GHC.Llvm.MetaData
-import GHC.Llvm.Ppr
-import GHC.Llvm.Types
-
diff --git a/compiler/GHC/Llvm/MetaData.hs b/compiler/GHC/Llvm/MetaData.hs
deleted file mode 100644
--- a/compiler/GHC/Llvm/MetaData.hs
+++ /dev/null
@@ -1,88 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-
-module GHC.Llvm.MetaData where
-
-import GHC.Prelude
-
-import GHC.Llvm.Types
-import GHC.Utils.Outputable
-
--- The LLVM Metadata System.
---
--- The LLVM metadata feature is poorly documented but roughly follows the
--- following design:
--- - Metadata can be constructed in a few different ways (See below).
--- - After which it can either be attached to LLVM statements to pass along
--- extra information to the optimizer and code generator OR specifically named
--- metadata has an affect on the whole module (i.e., linking behaviour).
---
---
--- # Constructing metadata
--- Metadata comes largely in three forms:
---
--- - Metadata expressions -- these are the raw metadata values that encode
---   information. They consist of metadata strings, metadata nodes, regular
---   LLVM values (both literals and references to global variables) and
---   metadata expressions (i.e., recursive data type). Some examples:
---     !{ !"hello", !0, i32 0 }
---     !{ !1, !{ i32 0 } }
---
--- - Metadata nodes -- global metadata variables that attach a metadata
---   expression to a number. For example:
---     !0 = !{ [<metadata expressions>] !}
---
--- - Named metadata -- global metadata variables that attach a metadata nodes
---   to a name. Used ONLY to communicated module level information to LLVM
---   through a meaningful name. For example:
---     !llvm.module.linkage = !{ !0, !1 }
---
---
--- # Using Metadata
--- Using metadata depends on the form it is in:
---
--- - Attach to instructions -- metadata can be attached to LLVM instructions
---   using a specific reference as follows:
---     %l = load i32* @glob, !nontemporal !10
---     %m = load i32* @glob, !nontemporal !{ i32 0, !{ i32 0 } }
---   Only metadata nodes or expressions can be attached, named metadata cannot.
---   Refer to LLVM documentation for which instructions take metadata and its
---   meaning.
---
--- - As arguments -- llvm functions can take metadata as arguments, for
---   example:
---     call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1)
---   As with instructions, only metadata nodes or expressions can be attached.
---
--- - As a named metadata -- Here the metadata is simply declared in global
---   scope using a specific name to communicate module level information to LLVM.
---   For example:
---     !llvm.module.linkage = !{ !0, !1 }
---
-
--- | A reference to an un-named metadata node.
-newtype MetaId = MetaId Int
-               deriving (Eq, Ord, Enum)
-
-instance Outputable MetaId where
-    ppr (MetaId n) = char '!' <> int n
-
--- | LLVM metadata expressions
-data MetaExpr = MetaStr !LMString
-              | MetaNode !MetaId
-              | MetaVar !LlvmVar
-              | MetaStruct [MetaExpr]
-              deriving (Eq)
-
--- | Associates some metadata with a specific label for attaching to an
--- instruction.
-data MetaAnnot = MetaAnnot LMString MetaExpr
-               deriving (Eq)
-
--- | Metadata declarations. Metadata can only be declared in global scope.
-data MetaDecl
-    -- | Named metadata. Only used for communicating module information to
-    -- LLVM. ('!name = !{ [!\<n>] }' form).
-    = MetaNamed !LMString [MetaId]
-    -- | Metadata node declaration.
-    -- ('!0 = metadata !{ \<metadata expression> }' form).
-    | MetaUnnamed !MetaId !MetaExpr
diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs
deleted file mode 100644
--- a/compiler/GHC/Llvm/Ppr.hs
+++ /dev/null
@@ -1,614 +0,0 @@
-
-{-# LANGUAGE LambdaCase #-}
-
---------------------------------------------------------------------------------
--- | Pretty print LLVM IR Code.
---
-
-module GHC.Llvm.Ppr (
-
-    -- * Top level LLVM objects.
-    ppLlvmModule,
-    ppLlvmComments,
-    ppLlvmComment,
-    ppLlvmGlobals,
-    ppLlvmGlobal,
-    ppLlvmAliases,
-    ppLlvmAlias,
-    ppLlvmMetas,
-    ppLlvmMeta,
-    ppLlvmFunctionDecls,
-    ppLlvmFunctionDecl,
-    ppLlvmFunctions,
-    ppLlvmFunction,
-
-    ppVar,
-    ppLit,
-    ppTypeLit,
-    ppName,
-    ppPlainName
-
-    ) where
-
-import GHC.Prelude
-
-import GHC.Llvm.Syntax
-import GHC.Llvm.MetaData
-import GHC.Llvm.Types
-
-import Data.Int
-import Data.List ( intersperse )
-import GHC.Utils.Outputable
-
-import GHC.CmmToLlvm.Config
-import GHC.Utils.Panic
-import GHC.Types.Unique
-
---------------------------------------------------------------------------------
--- * Top Level Print functions
---------------------------------------------------------------------------------
-
--- | Print out a whole LLVM module.
-ppLlvmModule :: LlvmCgConfig -> LlvmModule -> SDoc
-ppLlvmModule opts (LlvmModule comments aliases meta globals decls funcs)
-  = ppLlvmComments comments $+$ newLine
-    $+$ ppLlvmAliases aliases $+$ newLine
-    $+$ ppLlvmMetas opts meta $+$ newLine
-    $+$ ppLlvmGlobals opts globals $+$ newLine
-    $+$ ppLlvmFunctionDecls decls $+$ newLine
-    $+$ ppLlvmFunctions opts funcs
-
--- | Print out a multi-line comment, can be inside a function or on its own
-ppLlvmComments :: [LMString] -> SDoc
-ppLlvmComments comments = vcat $ map ppLlvmComment comments
-
--- | Print out a comment, can be inside a function or on its own
-ppLlvmComment :: LMString -> SDoc
-ppLlvmComment com = semi <+> ftext com
-
-
--- | Print out a list of global mutable variable definitions
-ppLlvmGlobals :: LlvmCgConfig -> [LMGlobal] -> SDoc
-ppLlvmGlobals opts ls = vcat $ map (ppLlvmGlobal opts) ls
-
--- | Print out a global mutable variable definition
-ppLlvmGlobal :: LlvmCgConfig -> LMGlobal -> SDoc
-ppLlvmGlobal opts (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
-    let sect = case x of
-            Just x' -> text ", section" <+> doubleQuotes (ftext x')
-            Nothing -> empty
-
-        align = case a of
-            Just a' -> text ", align" <+> int a'
-            Nothing -> empty
-
-        rhs = case dat of
-            Just stat -> pprSpecialStatic opts stat
-            Nothing   -> ppr (pLower $ getVarType var)
-
-        -- Position of linkage is different for aliases.
-        const = case c of
-          Global   -> "global"
-          Constant -> "constant"
-          Alias    -> "alias"
-
-    in ppAssignment opts var $ ppr link <+> text const <+> rhs <> sect <> align
-       $+$ newLine
-
-ppLlvmGlobal opts (LMGlobal var val) = pprPanic "ppLlvmGlobal" $
-  text "Non Global var ppr as global! " <> ppVar opts var <> text "=" <> ppr (fmap (ppStatic opts) val)
-
-
--- | Print out a list of LLVM type aliases.
-ppLlvmAliases :: [LlvmAlias] -> SDoc
-ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
-
--- | Print out an LLVM type alias.
-ppLlvmAlias :: LlvmAlias -> SDoc
-ppLlvmAlias (name, ty)
-  = char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty
-
-
--- | Print out a list of LLVM metadata.
-ppLlvmMetas :: LlvmCgConfig -> [MetaDecl] -> SDoc
-ppLlvmMetas opts metas = vcat $ map (ppLlvmMeta opts) metas
-
--- | Print out an LLVM metadata definition.
-ppLlvmMeta :: LlvmCgConfig -> MetaDecl -> SDoc
-ppLlvmMeta opts (MetaUnnamed n m)
-  = ppr n <+> equals <+> ppMetaExpr opts m
-
-ppLlvmMeta _opts (MetaNamed n m)
-  = exclamation <> ftext n <+> equals <+> exclamation <> braces nodes
-  where
-    nodes = hcat $ intersperse comma $ map ppr m
-
-
--- | Print out a list of function definitions.
-ppLlvmFunctions :: LlvmCgConfig -> LlvmFunctions -> SDoc
-ppLlvmFunctions opts funcs = vcat $ map (ppLlvmFunction opts) funcs
-
--- | Print out a function definition.
-ppLlvmFunction :: LlvmCgConfig -> LlvmFunction -> SDoc
-ppLlvmFunction opts fun =
-    let attrDoc = ppSpaceJoin (funcAttrs fun)
-        secDoc = case funcSect fun of
-                      Just s' -> text "section" <+> (doubleQuotes $ ftext s')
-                      Nothing -> empty
-        prefixDoc = case funcPrefix fun of
-                        Just v  -> text "prefix" <+> ppStatic opts v
-                        Nothing -> empty
-    in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun)
-        <+> attrDoc <+> secDoc <+> prefixDoc
-        $+$ lbrace
-        $+$ ppLlvmBlocks opts (funcBody fun)
-        $+$ rbrace
-        $+$ newLine
-        $+$ newLine
-
--- | Print out a function definition header.
-ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc
-ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
-  = let varg' = case varg of
-                      VarArgs | null p    -> text "..."
-                              | otherwise -> text ", ..."
-                      _otherwise          -> text ""
-        align = case a of
-                     Just a' -> text " align " <> ppr a'
-                     Nothing -> empty
-        args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%'
-                                    <> ftext n)
-                    (zip p args)
-    in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <>
-        (hsep $ punctuate comma args') <> varg' <> rparen <> align
-
--- | Print out a list of function declaration.
-ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
-ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
-
--- | Print out a function declaration.
--- Declarations define the function type but don't define the actual body of
--- the function.
-ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc
-ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
-  = let varg' = case varg of
-                      VarArgs | null p    -> text "..."
-                              | otherwise -> text ", ..."
-                      _otherwise          -> text ""
-        align = case a of
-                     Just a' -> text " align" <+> ppr a'
-                     Nothing -> empty
-        args = hcat $ intersperse (comma <> space) $
-                  map (\(t,a) -> ppr t <+> ppSpaceJoin a) p
-    in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <>
-        ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine
-
-
--- | Print out a list of LLVM blocks.
-ppLlvmBlocks :: LlvmCgConfig -> LlvmBlocks -> SDoc
-ppLlvmBlocks opts blocks = vcat $ map (ppLlvmBlock opts) blocks
-
--- | Print out an LLVM block.
--- It must be part of a function definition.
-ppLlvmBlock :: LlvmCgConfig -> LlvmBlock -> SDoc
-ppLlvmBlock opts (LlvmBlock blockId stmts) =
-  let isLabel (MkLabel _) = True
-      isLabel _           = False
-      (block, rest)       = break isLabel stmts
-      ppRest = case rest of
-        MkLabel id:xs -> ppLlvmBlock opts (LlvmBlock id xs)
-        _             -> empty
-  in ppLlvmBlockLabel blockId
-           $+$ (vcat $ map (ppLlvmStatement opts) block)
-           $+$ newLine
-           $+$ ppRest
-
--- | Print out an LLVM block label.
-ppLlvmBlockLabel :: LlvmBlockId -> SDoc
-ppLlvmBlockLabel id = pprUniqueAlways id <> colon
-
-
--- | Print out an LLVM statement.
-ppLlvmStatement :: LlvmCgConfig -> LlvmStatement -> SDoc
-ppLlvmStatement opts stmt =
-  let ind = (text "  " <>)
-  in case stmt of
-        Assignment  dst expr      -> ind $ ppAssignment opts dst (ppLlvmExpression opts expr)
-        Fence       st ord        -> ind $ ppFence st ord
-        Branch      target        -> ind $ ppBranch opts target
-        BranchIf    cond ifT ifF  -> ind $ ppBranchIf opts cond ifT ifF
-        Comment     comments      -> ind $ ppLlvmComments comments
-        MkLabel     label         -> ppLlvmBlockLabel label
-        Store       value ptr align
-                                  -> ind $ ppStore opts value ptr align
-        Switch      scrut def tgs -> ind $ ppSwitch opts scrut def tgs
-        Return      result        -> ind $ ppReturn opts result
-        Expr        expr          -> ind $ ppLlvmExpression opts expr
-        Unreachable               -> ind $ text "unreachable"
-        Nop                       -> empty
-        MetaStmt    meta s        -> ppMetaStatement opts meta s
-
-
--- | Print out an LLVM expression.
-ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> SDoc
-ppLlvmExpression opts expr
-  = case expr of
-        Alloca     tp amount        -> ppAlloca opts tp amount
-        LlvmOp     op left right    -> ppMachOp opts op left right
-        Call       tp fp args attrs -> ppCall opts tp fp (map MetaVar args) attrs
-        CallM      tp fp args attrs -> ppCall opts tp fp args attrs
-        Cast       op from to       -> ppCast opts op from to
-        Compare    op left right    -> ppCmpOp opts op left right
-        Extract    vec idx          -> ppExtract opts vec idx
-        ExtractV   struct idx       -> ppExtractV opts struct idx
-        Insert     vec elt idx      -> ppInsert opts vec elt idx
-        GetElemPtr inb ptr indexes  -> ppGetElementPtr opts inb ptr indexes
-        Load       ptr align        -> ppLoad opts ptr align
-        ALoad      ord st ptr       -> ppALoad opts ord st ptr
-        Malloc     tp amount        -> ppMalloc opts tp amount
-        AtomicRMW  aop tgt src ordering -> ppAtomicRMW opts aop tgt src ordering
-        CmpXChg    addr old new s_ord f_ord -> ppCmpXChg opts addr old new s_ord f_ord
-        Phi        tp predecessors  -> ppPhi opts tp predecessors
-        Asm        asm c ty v se sk -> ppAsm opts asm c ty v se sk
-        MExpr      meta expr        -> ppMetaAnnotExpr opts meta expr
-
-ppMetaExpr :: LlvmCgConfig -> MetaExpr -> SDoc
-ppMetaExpr opts = \case
-  MetaVar (LMLitVar (LMNullLit _)) -> text "null"
-  MetaStr    s                     -> char '!' <> doubleQuotes (ftext s)
-  MetaNode   n                     -> ppr n
-  MetaVar    v                     -> ppVar opts v
-  MetaStruct es                    -> char '!' <> braces (ppCommaJoin (map (ppMetaExpr opts) es))
-
-
---------------------------------------------------------------------------------
--- * Individual print functions
---------------------------------------------------------------------------------
-
--- | Should always be a function pointer. So a global var of function type
--- (since globals are always pointers) or a local var of pointer function type.
-ppCall :: LlvmCgConfig -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
-ppCall opts ct fptr args attrs = case fptr of
-                           --
-    -- if local var function pointer, unwrap
-    LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
-
-    -- should be function type otherwise
-    LMGlobalVar _ (LMFunction d) _ _ _ _    -> ppCall' d
-
-    -- not pointer or function, so error
-    _other -> error $ "ppCall called with non LMFunction type!\nMust be "
-                ++ " called with either global var of function type or "
-                ++ "local var of pointer function type."
-
-    where
-        ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
-            let tc = if ct == TailCall then text "tail " else empty
-                ppValues = ppCallParams opts (map snd params) args
-                ppArgTy  = (ppCommaJoin $ map (ppr . fst) params) <>
-                           (case argTy of
-                               VarArgs   -> text ", ..."
-                               FixedArgs -> empty)
-                fnty = space <> lparen <> ppArgTy <> rparen
-                attrDoc = ppSpaceJoin attrs
-            in  tc <> text "call" <+> ppr cc <+> ppr ret
-                    <> fnty <+> ppName opts fptr <> lparen <+> ppValues
-                    <+> rparen <+> attrDoc
-
-        ppCallParams :: LlvmCgConfig -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc
-        ppCallParams opts attrs args = hsep $ punctuate comma $ zipWith ppCallMetaExpr attrs args
-         where
-          -- Metadata needs to be marked as having the `metadata` type when used
-          -- in a call argument
-          ppCallMetaExpr attrs (MetaVar v) = ppVar' attrs opts v
-          ppCallMetaExpr _ v             = text "metadata" <+> ppMetaExpr opts v
-
-
-ppMachOp :: LlvmCgConfig -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
-ppMachOp opts op left right =
-  (ppr op) <+> (ppr (getVarType left)) <+> ppName opts left
-        <> comma <+> ppName opts right
-
-
-ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
-ppCmpOp opts op left right =
-  let cmpOp
-        | isInt (getVarType left) && isInt (getVarType right) = text "icmp"
-        | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"
-        | otherwise = text "icmp" -- Just continue as its much easier to debug
-        {-
-        | otherwise = error ("can't compare different types, left = "
-                ++ (show $ getVarType left) ++ ", right = "
-                ++ (show $ getVarType right))
-        -}
-  in cmpOp <+> ppr op <+> ppr (getVarType left)
-        <+> ppName opts left <> comma <+> ppName opts right
-
-
-ppAssignment :: LlvmCgConfig -> LlvmVar -> SDoc -> SDoc
-ppAssignment opts var expr = ppName opts var <+> equals <+> expr
-
-ppFence :: Bool -> LlvmSyncOrdering -> SDoc
-ppFence st ord =
-  let singleThread = case st of True  -> text "singlethread"
-                                False -> empty
-  in text "fence" <+> singleThread <+> ppSyncOrdering ord
-
-ppSyncOrdering :: LlvmSyncOrdering -> SDoc
-ppSyncOrdering SyncUnord     = text "unordered"
-ppSyncOrdering SyncMonotonic = text "monotonic"
-ppSyncOrdering SyncAcquire   = text "acquire"
-ppSyncOrdering SyncRelease   = text "release"
-ppSyncOrdering SyncAcqRel    = text "acq_rel"
-ppSyncOrdering SyncSeqCst    = text "seq_cst"
-
-ppAtomicOp :: LlvmAtomicOp -> SDoc
-ppAtomicOp LAO_Xchg = text "xchg"
-ppAtomicOp LAO_Add  = text "add"
-ppAtomicOp LAO_Sub  = text "sub"
-ppAtomicOp LAO_And  = text "and"
-ppAtomicOp LAO_Nand = text "nand"
-ppAtomicOp LAO_Or   = text "or"
-ppAtomicOp LAO_Xor  = text "xor"
-ppAtomicOp LAO_Max  = text "max"
-ppAtomicOp LAO_Min  = text "min"
-ppAtomicOp LAO_Umax = text "umax"
-ppAtomicOp LAO_Umin = text "umin"
-
-ppAtomicRMW :: LlvmCgConfig -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
-ppAtomicRMW opts aop tgt src ordering =
-  text "atomicrmw" <+> ppAtomicOp aop <+> ppVar opts tgt <> comma
-  <+> ppVar opts src <+> ppSyncOrdering ordering
-
-ppCmpXChg :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar
-          -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc
-ppCmpXChg opts addr old new s_ord f_ord =
-  text "cmpxchg" <+> ppVar opts addr <> comma <+> ppVar opts old <> comma <+> ppVar opts new
-  <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord
-
-
-ppLoad :: LlvmCgConfig -> LlvmVar -> LMAlign -> SDoc
-ppLoad opts var alignment =
-  text "load" <+> ppr derefType <> comma <+> ppVar opts var <> align
-  where
-    derefType = pLower $ getVarType var
-    align =
-      case alignment of
-        Just n  -> text ", align" <+> ppr n
-        Nothing -> empty
-
-ppALoad :: LlvmCgConfig -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc
-ppALoad opts ord st var =
-  let alignment = llvmWidthInBits (llvmCgPlatform opts) (getVarType var) `quot` 8
-      align     = text ", align" <+> ppr alignment
-      sThreaded | st        = text " singlethread"
-                | otherwise = empty
-      derefType = pLower $ getVarType var
-  in text "load atomic" <+> ppr derefType <> comma <+> ppVar opts var <> sThreaded
-            <+> ppSyncOrdering ord <> align
-
-ppStore :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LMAlign -> SDoc
-ppStore opts val dst alignment =
-    text "store" <+> ppVar opts val <> comma <+> ppVar opts dst <> align
-  where
-    align =
-      case alignment of
-        Just n  -> text ", align" <+> ppr n
-        Nothing -> empty
-
-
-ppCast :: LlvmCgConfig -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
-ppCast opts op from to
-    =   ppr op
-    <+> ppr (getVarType from) <+> ppName opts from
-    <+> text "to"
-    <+> ppr to
-
-
-ppMalloc :: LlvmCgConfig -> LlvmType -> Int -> SDoc
-ppMalloc opts tp amount =
-  let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
-  in text "malloc" <+> ppr tp <> comma <+> ppVar opts amount'
-
-
-ppAlloca :: LlvmCgConfig -> LlvmType -> Int -> SDoc
-ppAlloca opts tp amount =
-  let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
-  in text "alloca" <+> ppr tp <> comma <+> ppVar opts amount'
-
-
-ppGetElementPtr :: LlvmCgConfig -> Bool -> LlvmVar -> [LlvmVar] -> SDoc
-ppGetElementPtr opts inb ptr idx =
-  let indexes = comma <+> ppCommaJoin (map (ppVar opts) idx)
-      inbound = if inb then text "inbounds" else empty
-      derefType = pLower $ getVarType ptr
-  in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppVar opts ptr
-                            <> indexes
-
-
-ppReturn :: LlvmCgConfig -> Maybe LlvmVar -> SDoc
-ppReturn opts (Just var) = text "ret" <+> ppVar opts var
-ppReturn _    Nothing    = text "ret" <+> ppr LMVoid
-
-
-ppBranch :: LlvmCgConfig -> LlvmVar -> SDoc
-ppBranch opts var = text "br" <+> ppVar opts var
-
-
-ppBranchIf :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
-ppBranchIf opts cond trueT falseT
-  = text "br" <+> ppVar opts cond <> comma <+> ppVar opts trueT <> comma <+> ppVar opts falseT
-
-
-ppPhi :: LlvmCgConfig -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
-ppPhi opts tp preds =
-  let ppPreds (val, label) = brackets $ ppName opts val <> comma <+> ppName opts label
-  in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds)
-
-
-ppSwitch :: LlvmCgConfig -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
-ppSwitch opts scrut dflt targets =
-  let ppTarget  (val, lab) = ppVar opts val <> comma <+> ppVar opts lab
-      ppTargets  xs        = brackets $ vcat (map ppTarget xs)
-  in text "switch" <+> ppVar opts scrut <> comma <+> ppVar opts dflt
-        <+> ppTargets targets
-
-
-ppAsm :: LlvmCgConfig -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
-ppAsm opts asm constraints rty vars sideeffect alignstack =
-  let asm'  = doubleQuotes $ ftext asm
-      cons  = doubleQuotes $ ftext constraints
-      rty'  = ppr rty
-      vars' = lparen <+> ppCommaJoin (map (ppVar opts) vars) <+> rparen
-      side  = if sideeffect then text "sideeffect" else empty
-      align = if alignstack then text "alignstack" else empty
-  in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma
-        <+> cons <> vars'
-
-ppExtract :: LlvmCgConfig -> LlvmVar -> LlvmVar -> SDoc
-ppExtract opts vec idx =
-    text "extractelement"
-    <+> ppr (getVarType vec) <+> ppName opts vec <> comma
-    <+> ppVar opts idx
-
-ppExtractV :: LlvmCgConfig -> LlvmVar -> Int -> SDoc
-ppExtractV opts struct idx =
-    text "extractvalue"
-    <+> ppr (getVarType struct) <+> ppName opts struct <> comma
-    <+> ppr idx
-
-ppInsert :: LlvmCgConfig -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
-ppInsert opts vec elt idx =
-    text "insertelement"
-    <+> ppr (getVarType vec) <+> ppName opts vec <> comma
-    <+> ppr (getVarType elt) <+> ppName opts elt <> comma
-    <+> ppVar opts idx
-
-
-ppMetaStatement :: LlvmCgConfig -> [MetaAnnot] -> LlvmStatement -> SDoc
-ppMetaStatement opts meta stmt =
-   ppLlvmStatement opts stmt <> ppMetaAnnots opts meta
-
-ppMetaAnnotExpr :: LlvmCgConfig -> [MetaAnnot] -> LlvmExpression -> SDoc
-ppMetaAnnotExpr opts meta expr =
-   ppLlvmExpression opts expr <> ppMetaAnnots opts meta
-
-ppMetaAnnots :: LlvmCgConfig -> [MetaAnnot] -> SDoc
-ppMetaAnnots opts meta = hcat $ map ppMeta meta
-  where
-    ppMeta (MetaAnnot name e)
-        = comma <+> exclamation <> ftext name <+>
-          case e of
-            MetaNode n    -> ppr n
-            MetaStruct ms -> exclamation <> braces (ppCommaJoin (map (ppMetaExpr opts) ms))
-            other         -> exclamation <> braces (ppMetaExpr opts other) -- possible?
-
--- | Return the variable name or value of the 'LlvmVar'
--- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).
-ppName :: LlvmCgConfig -> LlvmVar -> SDoc
-ppName opts v = case v of
-   LMGlobalVar {} -> char '@' <> ppPlainName opts v
-   LMLocalVar  {} -> char '%' <> ppPlainName opts v
-   LMNLocalVar {} -> char '%' <> ppPlainName opts v
-   LMLitVar    {} ->             ppPlainName opts v
-
--- | Return the variable name or value of the 'LlvmVar'
--- in a plain textual representation (e.g. @x@, @y@ or @42@).
-ppPlainName :: LlvmCgConfig -> LlvmVar -> SDoc
-ppPlainName opts v = case v of
-   (LMGlobalVar x _ _ _ _ _) -> ftext x
-   (LMLocalVar  x LMLabel  ) -> pprUniqueAlways x
-   (LMLocalVar  x _        ) -> char 'l' <> pprUniqueAlways x
-   (LMNLocalVar x _        ) -> ftext x
-   (LMLitVar    x          ) -> ppLit opts x
-
--- | Print a literal value. No type.
-ppLit :: LlvmCgConfig -> LlvmLit -> SDoc
-ppLit opts l = case l of
-   (LMIntLit i (LMInt 32))  -> ppr (fromInteger i :: Int32)
-   (LMIntLit i (LMInt 64))  -> ppr (fromInteger i :: Int64)
-   (LMIntLit   i _       )  -> ppr ((fromInteger i)::Int)
-   (LMFloatLit r LMFloat )  -> ppFloat (llvmCgPlatform opts) $ narrowFp r
-   (LMFloatLit r LMDouble)  -> ppDouble (llvmCgPlatform opts) r
-   f@(LMFloatLit _ _)       -> pprPanic "ppLit" (text "Can't print this float literal: " <> ppTypeLit opts f)
-   (LMVectorLit ls  )       -> char '<' <+> ppCommaJoin (map (ppTypeLit opts) ls) <+> char '>'
-   (LMNullLit _     )       -> text "null"
-   -- #11487 was an issue where we passed undef for some arguments
-   -- that were actually live. By chance the registers holding those
-   -- arguments usually happened to have the right values anyways, but
-   -- that was not guaranteed. To find such bugs reliably, we set the
-   -- flag below when validating, which replaces undef literals (at
-   -- common types) with values that are likely to cause a crash or test
-   -- failure.
-   (LMUndefLit t    )
-      | llvmCgFillUndefWithGarbage opts
-      , Just lit <- garbageLit t   -> ppLit opts lit
-      | otherwise                  -> text "undef"
-
-ppVar :: LlvmCgConfig -> LlvmVar -> SDoc
-ppVar = ppVar' []
-
-ppVar' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmVar -> SDoc
-ppVar' attrs opts v = case v of
-  LMLitVar x -> ppTypeLit' attrs opts x
-  x          -> ppr (getVarType x) <+> ppSpaceJoin attrs <+> ppName opts x
-
-ppTypeLit :: LlvmCgConfig -> LlvmLit -> SDoc
-ppTypeLit = ppTypeLit' []
-
-ppTypeLit' :: [LlvmParamAttr] -> LlvmCgConfig -> LlvmLit -> SDoc
-ppTypeLit' attrs opts l = case l of
-  LMVectorLit {} -> ppLit opts l
-  _              -> ppr (getLitType l) <+> ppSpaceJoin attrs <+> ppLit opts l
-
-ppStatic :: LlvmCgConfig -> LlvmStatic -> SDoc
-ppStatic opts st = case st of
-  LMComment       s -> text "; " <> ftext s
-  LMStaticLit   l   -> ppTypeLit opts l
-  LMUninitType    t -> ppr t <> text " undef"
-  LMStaticStr   s t -> ppr t <> text " c\"" <> ftext s <> text "\\00\""
-  LMStaticArray d t -> ppr t <> text " [" <> ppCommaJoin (map (ppStatic opts) d) <> char ']'
-  LMStaticStruc d t -> ppr t <> text "<{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}>"
-  LMStaticStrucU d t -> ppr t <> text "{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}"
-  LMStaticPointer v -> ppVar opts v
-  LMTrunc v t       -> ppr t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'
-  LMBitc v t        -> ppr t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'
-  LMPtoI v t        -> ppr t <> text " ptrtoint (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'
-  LMAdd s1 s2       -> pprStaticArith opts s1 s2 (text "add") (text "fadd") (text "LMAdd")
-  LMSub s1 s2       -> pprStaticArith opts s1 s2 (text "sub") (text "fsub") (text "LMSub")
-
-
-pprSpecialStatic :: LlvmCgConfig -> LlvmStatic -> SDoc
-pprSpecialStatic opts stat = case stat of
-   LMBitc v t        -> ppr (pLower t)
-                        <> text ", bitcast ("
-                        <> ppStatic opts v <> text " to " <> ppr t
-                        <> char ')'
-   LMStaticPointer x -> ppr (pLower $ getVarType x)
-                        <> comma <+> ppStatic opts stat
-   _                 -> ppStatic opts stat
-
-
-pprStaticArith :: LlvmCgConfig -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc
-                  -> SDoc -> SDoc
-pprStaticArith opts s1 s2 int_op float_op op_name =
-  let ty1 = getStatType s1
-      op  = if isFloat ty1 then float_op else int_op
-  in if ty1 == getStatType s2
-     then ppr ty1 <+> op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen
-     else pprPanic "pprStaticArith" $
-                 op_name <> text " with different types! s1: " <> ppStatic opts s1
-                         <> text", s2: " <> ppStatic opts s2
-
-
---------------------------------------------------------------------------------
--- * Misc functions
---------------------------------------------------------------------------------
-
--- | Blank line.
-newLine :: SDoc
-newLine = empty
-
--- | Exclamation point.
-exclamation :: SDoc
-exclamation = char '!'
diff --git a/compiler/GHC/Llvm/Syntax.hs b/compiler/GHC/Llvm/Syntax.hs
deleted file mode 100644
--- a/compiler/GHC/Llvm/Syntax.hs
+++ /dev/null
@@ -1,352 +0,0 @@
---------------------------------------------------------------------------------
--- | The LLVM abstract syntax.
---
-
-module GHC.Llvm.Syntax where
-
-import GHC.Prelude
-
-import GHC.Llvm.MetaData
-import GHC.Llvm.Types
-
-import GHC.Types.Unique
-
--- | Block labels
-type LlvmBlockId = Unique
-
--- | A block of LLVM code.
-data LlvmBlock = LlvmBlock {
-    -- | The code label for this block
-    blockLabel :: LlvmBlockId,
-
-    -- | A list of LlvmStatement's representing the code for this block.
-    -- This list must end with a control flow statement.
-    blockStmts :: [LlvmStatement]
-  }
-
-type LlvmBlocks = [LlvmBlock]
-
--- | An LLVM Module. This is a top level container in LLVM.
-data LlvmModule = LlvmModule  {
-    -- | Comments to include at the start of the module.
-    modComments  :: [LMString],
-
-    -- | LLVM Alias type definitions.
-    modAliases   :: [LlvmAlias],
-
-    -- | LLVM meta data.
-    modMeta      :: [MetaDecl],
-
-    -- | Global variables to include in the module.
-    modGlobals   :: [LMGlobal],
-
-    -- | LLVM Functions used in this module but defined in other modules.
-    modFwdDecls  :: LlvmFunctionDecls,
-
-    -- | LLVM Functions defined in this module.
-    modFuncs     :: LlvmFunctions
-  }
-
--- | An LLVM Function
-data LlvmFunction = LlvmFunction {
-    -- | The signature of this declared function.
-    funcDecl      :: LlvmFunctionDecl,
-
-    -- | The functions arguments
-    funcArgs      :: [LMString],
-
-    -- | The function attributes.
-    funcAttrs     :: [LlvmFuncAttr],
-
-    -- | The section to put the function into,
-    funcSect      :: LMSection,
-
-    -- | Prefix data
-    funcPrefix    :: Maybe LlvmStatic,
-
-    -- | The body of the functions.
-    funcBody      :: LlvmBlocks
-  }
-
-type LlvmFunctions = [LlvmFunction]
-
-type SingleThreaded = Bool
-
--- | LLVM ordering types for synchronization purposes. (Introduced in LLVM
--- 3.0). Please see the LLVM documentation for a better description.
-data LlvmSyncOrdering
-  -- | Some partial order of operations exists.
-  = SyncUnord
-  -- | A single total order for operations at a single address exists.
-  | SyncMonotonic
-  -- | Acquire synchronization operation.
-  | SyncAcquire
-  -- | Release synchronization operation.
-  | SyncRelease
-  -- | Acquire + Release synchronization operation.
-  | SyncAcqRel
-  -- | Full sequential Consistency operation.
-  | SyncSeqCst
-  deriving (Show, Eq)
-
--- | LLVM atomic operations. Please see the @atomicrmw@ instruction in
--- the LLVM documentation for a complete description.
-data LlvmAtomicOp
-  = LAO_Xchg
-  | LAO_Add
-  | LAO_Sub
-  | LAO_And
-  | LAO_Nand
-  | LAO_Or
-  | LAO_Xor
-  | LAO_Max
-  | LAO_Min
-  | LAO_Umax
-  | LAO_Umin
-  deriving (Show, Eq)
-
--- | Llvm Statements
-data LlvmStatement
-  {- |
-    Assign an expression to a variable:
-      * dest:   Variable to assign to
-      * source: Source expression
-  -}
-  = Assignment LlvmVar LlvmExpression
-
-  {- |
-    Memory fence operation
-  -}
-  | Fence Bool LlvmSyncOrdering
-
-  {- |
-    Always branch to the target label
-  -}
-  | Branch LlvmVar
-
-  {- |
-    Branch to label targetTrue if cond is true otherwise to label targetFalse
-      * cond:        condition that will be tested, must be of type i1
-      * targetTrue:  label to branch to if cond is true
-      * targetFalse: label to branch to if cond is false
-  -}
-  | BranchIf LlvmVar LlvmVar LlvmVar
-
-  {- |
-    Comment
-    Plain comment.
-  -}
-  | Comment [LMString]
-
-  {- |
-    Set a label on this position.
-      * name: Identifier of this label, unique for this module
-  -}
-  | MkLabel LlvmBlockId
-
-  {- |
-    Store variable value in pointer ptr. If value is of type t then ptr must
-    be of type t*.
-      * value: Variable/Constant to store.
-      * ptr:   Location to store the value in
-  -}
-  | Store LlvmVar LlvmVar LMAlign
-
-  {- |
-    Multiway branch
-      * scrutinee: Variable or constant which must be of integer type that is
-                   determines which arm is chosen.
-      * def:       The default label if there is no match in target.
-      * target:    A list of (value,label) where the value is an integer
-                   constant and label the corresponding label to jump to if the
-                   scrutinee matches the value.
-  -}
-  | Switch LlvmVar LlvmVar [(LlvmVar, LlvmVar)]
-
-  {- |
-    Return a result.
-      * result: The variable or constant to return
-  -}
-  | Return (Maybe LlvmVar)
-
-  {- |
-    An instruction for the optimizer that the code following is not reachable
-  -}
-  | Unreachable
-
-  {- |
-    Raise an expression to a statement (if don't want result or want to use
-    Llvm unnamed values.
-  -}
-  | Expr LlvmExpression
-
-  {- |
-    A nop LLVM statement. Useful as its often more efficient to use this
-    then to wrap LLvmStatement in a Just or [].
-  -}
-  | Nop
-
-  {- |
-    A LLVM statement with metadata attached to it.
-  -}
-  | MetaStmt [MetaAnnot] LlvmStatement
-
-  deriving (Eq)
-
-
--- | Llvm Expressions
-data LlvmExpression
-  {- |
-    Allocate amount * sizeof(tp) bytes on the stack
-      * tp:     LlvmType to reserve room for
-      * amount: The nr of tp's which must be allocated
-  -}
-  = Alloca LlvmType Int
-
-  {- |
-    Perform the machine operator op on the operands left and right
-      * op:    operator
-      * left:  left operand
-      * right: right operand
-  -}
-  | LlvmOp LlvmMachOp LlvmVar LlvmVar
-
-  {- |
-    Perform a compare operation on the operands left and right
-      * op:    operator
-      * left:  left operand
-      * right: right operand
-  -}
-  | Compare LlvmCmpOp LlvmVar LlvmVar
-
-  {- |
-    Extract a scalar element from a vector
-      * val: The vector
-      * idx: The index of the scalar within the vector
-  -}
-  | Extract LlvmVar LlvmVar
-
-  {- |
-    Extract a scalar element from a structure
-      * val: The structure
-      * idx: The index of the scalar within the structure
-    Corresponds to "extractvalue" instruction.
-  -}
-  | ExtractV LlvmVar Int
-
-  {- |
-    Insert a scalar element into a vector
-      * val:   The source vector
-      * elt:   The scalar to insert
-      * index: The index at which to insert the scalar
-  -}
-  | Insert LlvmVar LlvmVar LlvmVar
-
-  {- |
-    Allocate amount * sizeof(tp) bytes on the heap
-      * tp:     LlvmType to reserve room for
-      * amount: The nr of tp's which must be allocated
-  -}
-  | Malloc LlvmType Int
-
-  {- |
-    Load the value at location ptr
-  -}
-  | Load LlvmVar LMAlign
-
-  {- |
-    Atomic load of the value at location ptr
-  -}
-  | ALoad LlvmSyncOrdering SingleThreaded LlvmVar
-
-  {- |
-    Navigate in a structure, selecting elements
-      * inbound: Is the pointer inbounds? (computed pointer doesn't overflow)
-      * ptr:     Location of the structure
-      * indexes: A list of indexes to select the correct value.
-  -}
-  | GetElemPtr Bool LlvmVar [LlvmVar]
-
-  {- |
-    Cast the variable from to the to type. This is an abstraction of three
-    cast operators in Llvm, inttoptr, ptrtoint and bitcast.
-       * cast: Cast type
-       * from: Variable to cast
-       * to:   type to cast to
-  -}
-  | Cast LlvmCastOp LlvmVar LlvmType
-
-  {- |
-    Atomic read-modify-write operation
-       * op:       Atomic operation
-       * addr:     Address to modify
-       * operand:  Operand to operation
-       * ordering: Ordering requirement
-  -}
-  | AtomicRMW LlvmAtomicOp LlvmVar LlvmVar LlvmSyncOrdering
-
-  {- |
-    Compare-and-exchange operation
-       * addr:     Address to modify
-       * old:      Expected value
-       * new:      New value
-       * suc_ord:  Ordering required in success case
-       * fail_ord: Ordering required in failure case, can be no stronger than
-                   suc_ord
-
-    Result is an @i1@, true if store was successful.
-  -}
-  | CmpXChg LlvmVar LlvmVar LlvmVar LlvmSyncOrdering LlvmSyncOrdering
-
-  {- |
-    Call a function. The result is the value of the expression.
-      * tailJumps: CallType to signal if the function should be tail called
-      * fnptrval:  An LLVM value containing a pointer to a function to be
-                   invoked. Can be indirect. Should be LMFunction type.
-      * args:      Concrete arguments for the parameters
-      * attrs:     A list of function attributes for the call. Only NoReturn,
-                   NoUnwind, ReadOnly and ReadNone are valid here.
-  -}
-  | Call LlvmCallType LlvmVar [LlvmVar] [LlvmFuncAttr]
-
-  {- |
-    Call a function as above but potentially taking metadata as arguments.
-      * tailJumps: CallType to signal if the function should be tail called
-      * fnptrval:  An LLVM value containing a pointer to a function to be
-                   invoked. Can be indirect. Should be LMFunction type.
-      * args:      Arguments that may include metadata.
-      * attrs:     A list of function attributes for the call. Only NoReturn,
-                   NoUnwind, ReadOnly and ReadNone are valid here.
-  -}
-  | CallM LlvmCallType LlvmVar [MetaExpr] [LlvmFuncAttr]
-
-  {- |
-    Merge variables from different basic blocks which are predecessors of this
-    basic block in a new variable of type tp.
-      * tp:         type of the merged variable, must match the types of the
-                    predecessor variables.
-      * predecessors: A list of variables and the basic block that they originate
-                      from.
-  -}
-  | Phi LlvmType [(LlvmVar,LlvmVar)]
-
-  {- |
-    Inline assembly expression. Syntax is very similar to the style used by GCC.
-      * assembly:    Actual inline assembly code.
-      * constraints: Operand constraints.
-      * return ty:   Return type of function.
-      * vars:        Any variables involved in the assembly code.
-      * sideeffect:  Does the expression have side effects not visible from the
-                     constraints list.
-      * alignstack:  Should the stack be conservatively aligned before this
-                     expression is executed.
-  -}
-  | Asm LMString LMString LlvmType [LlvmVar] Bool Bool
-
-  {- |
-    A LLVM expression with metadata attached to it.
-  -}
-  | MExpr [MetaAnnot] LlvmExpression
-
-  deriving (Eq)
-
diff --git a/compiler/GHC/Llvm/Types.hs b/compiler/GHC/Llvm/Types.hs
deleted file mode 100644
--- a/compiler/GHC/Llvm/Types.hs
+++ /dev/null
@@ -1,802 +0,0 @@
-
-{-# LANGUAGE LambdaCase #-}
-
---------------------------------------------------------------------------------
--- | The LLVM Type System.
---
-
-module GHC.Llvm.Types where
-
-import GHC.Prelude
-
-import Data.Char
-import Numeric
-
-import GHC.Platform
-import GHC.Data.FastString
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Types.Unique
-
--- from NCG
-import GHC.CmmToAsm.Ppr
-
-import GHC.Float
-
--- -----------------------------------------------------------------------------
--- * LLVM Basic Types and Variables
---
-
--- | A global mutable variable. Maybe defined or external
-data LMGlobal = LMGlobal {
-  getGlobalVar :: LlvmVar,          -- ^ Returns the variable of the 'LMGlobal'
-  getGlobalValue :: Maybe LlvmStatic -- ^ Return the value of the 'LMGlobal'
-  }
-
--- | A String in LLVM
-type LMString = FastString
-
--- | A type alias
-type LlvmAlias = (LMString, LlvmType)
-
--- | Llvm Types
-data LlvmType
-  = LMInt Int             -- ^ An integer with a given width in bits.
-  | LMFloat               -- ^ 32 bit floating point
-  | LMDouble              -- ^ 64 bit floating point
-  | LMFloat80             -- ^ 80 bit (x86 only) floating point
-  | LMFloat128            -- ^ 128 bit floating point
-  | LMPointer LlvmType    -- ^ A pointer to a 'LlvmType'
-  | LMArray Int LlvmType  -- ^ An array of 'LlvmType'
-  | LMVector Int LlvmType -- ^ A vector of 'LlvmType'
-  | LMLabel               -- ^ A 'LlvmVar' can represent a label (address)
-  | LMVoid                -- ^ Void type
-  | LMStruct [LlvmType]   -- ^ Packed structure type
-  | LMStructU [LlvmType]  -- ^ Unpacked structure type
-  | LMAlias LlvmAlias     -- ^ A type alias
-  | LMMetadata            -- ^ LLVM Metadata
-
-  -- | Function type, used to create pointers to functions
-  | LMFunction LlvmFunctionDecl
-  deriving (Eq)
-
-instance Outputable LlvmType where
-  ppr = ppType
-
-ppType :: LlvmType -> SDoc
-ppType t = case t of
-  LMInt size     -> char 'i' <> ppr size
-  LMFloat        -> text "float"
-  LMDouble       -> text "double"
-  LMFloat80      -> text "x86_fp80"
-  LMFloat128     -> text "fp128"
-  LMPointer x    -> ppr x <> char '*'
-  LMArray nr tp  -> char '[' <> ppr nr <> text " x " <> ppr tp <> char ']'
-  LMVector nr tp -> char '<' <> ppr nr <> text " x " <> ppr tp <> char '>'
-  LMLabel        -> text "label"
-  LMVoid         -> text "void"
-  LMStruct tys   -> text "<{" <> ppCommaJoin tys <> text "}>"
-  LMStructU tys  -> text "{" <> ppCommaJoin tys <> text "}"
-  LMMetadata     -> text "metadata"
-  LMAlias (s,_)  -> char '%' <> ftext s
-  LMFunction (LlvmFunctionDecl _ _ _ r varg p _)
-    -> ppr r <+> lparen <> ppParams varg p <> rparen
-
-ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc
-ppParams varg p
-  = let varg' = case varg of
-          VarArgs | null args -> text "..."
-                  | otherwise -> text ", ..."
-          _otherwise          -> text ""
-        -- by default we don't print param attributes
-        args = map fst p
-    in ppCommaJoin args <> varg'
-
--- | An LLVM section definition. If Nothing then let LLVM decide the section
-type LMSection = Maybe LMString
-type LMAlign = Maybe Int
-
-data LMConst = Global      -- ^ Mutable global variable
-             | Constant    -- ^ Constant global variable
-             | Alias       -- ^ Alias of another variable
-             deriving (Eq)
-
--- | LLVM Variables
-data LlvmVar
-  -- | Variables with a global scope.
-  = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst
-  -- | Variables local to a function or parameters.
-  | LMLocalVar Unique LlvmType
-  -- | Named local variables. Sometimes we need to be able to explicitly name
-  -- variables (e.g for function arguments).
-  | LMNLocalVar LMString LlvmType
-  -- | A constant variable
-  | LMLitVar LlvmLit
-  deriving (Eq)
-
--- | Llvm Literal Data.
---
--- These can be used inline in expressions.
-data LlvmLit
-  -- | Refers to an integer constant (i64 42).
-  = LMIntLit Integer LlvmType
-  -- | Floating point literal
-  | LMFloatLit Double LlvmType
-  -- | Literal NULL, only applicable to pointer types
-  | LMNullLit LlvmType
-  -- | Vector literal
-  | LMVectorLit [LlvmLit]
-  -- | Undefined value, random bit pattern. Useful for optimisations.
-  | LMUndefLit LlvmType
-  deriving (Eq)
-
--- | Llvm Static Data.
---
--- These represent the possible global level variables and constants.
-data LlvmStatic
-  = LMComment LMString                  -- ^ A comment in a static section
-  | LMStaticLit LlvmLit                 -- ^ A static variant of a literal value
-  | LMUninitType LlvmType               -- ^ For uninitialised data
-  | LMStaticStr LMString LlvmType       -- ^ Defines a static 'LMString'
-  | LMStaticArray [LlvmStatic] LlvmType -- ^ A static array
-  | LMStaticStruc [LlvmStatic] LlvmType -- ^ A static structure type
-  | LMStaticStrucU [LlvmStatic] LlvmType -- ^ A static structure type
-  | LMStaticPointer LlvmVar             -- ^ A pointer to other data
-
-  -- static expressions, could split out but leave
-  -- for moment for ease of use. Not many of them.
-
-  | LMTrunc LlvmStatic LlvmType        -- ^ Truncate
-  | LMBitc LlvmStatic LlvmType         -- ^ Pointer to Pointer conversion
-  | LMPtoI LlvmStatic LlvmType         -- ^ Pointer to Integer conversion
-  | LMAdd LlvmStatic LlvmStatic        -- ^ Constant addition operation
-  | LMSub LlvmStatic LlvmStatic        -- ^ Constant subtraction operation
-
--- -----------------------------------------------------------------------------
--- ** Operations on LLVM Basic Types and Variables
---
-
-garbageLit :: LlvmType -> Maybe LlvmLit
-garbageLit t@(LMInt w)     = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t)
-  -- Use a value that looks like an untagged pointer, so we are more
-  -- likely to try to enter it
-garbageLit t
-  | isFloat t              = Just (LMFloatLit 12345678.9 t)
-garbageLit t@(LMPointer _) = Just (LMNullLit t)
-  -- Using null isn't totally ideal, since some functions may check for null.
-  -- But producing another value is inconvenient since it needs a cast,
-  -- and the knowledge for how to format casts is in PpLlvm.
-garbageLit _               = Nothing
-  -- More cases could be added, but this should do for now.
-
--- | Return the 'LlvmType' of the 'LlvmVar'
-getVarType :: LlvmVar -> LlvmType
-getVarType (LMGlobalVar _ y _ _ _ _) = y
-getVarType (LMLocalVar  _ y        ) = y
-getVarType (LMNLocalVar _ y        ) = y
-getVarType (LMLitVar    l          ) = getLitType l
-
--- | Return the 'LlvmType' of a 'LlvmLit'
-getLitType :: LlvmLit -> LlvmType
-getLitType (LMIntLit   _ t) = t
-getLitType (LMFloatLit _ t) = t
-getLitType (LMVectorLit [])  = panic "getLitType"
-getLitType (LMVectorLit ls@(l:_))  = LMVector (length ls) (getLitType l)
-getLitType (LMNullLit    t) = t
-getLitType (LMUndefLit   t) = t
-
--- | Return the 'LlvmType' of the 'LlvmStatic'
-getStatType :: LlvmStatic -> LlvmType
-getStatType (LMStaticLit   l  ) = getLitType l
-getStatType (LMUninitType    t) = t
-getStatType (LMStaticStr   _ t) = t
-getStatType (LMStaticArray _ t) = t
-getStatType (LMStaticStruc _ t) = t
-getStatType (LMStaticStrucU _ t) = t
-getStatType (LMStaticPointer v) = getVarType v
-getStatType (LMTrunc       _ t) = t
-getStatType (LMBitc        _ t) = t
-getStatType (LMPtoI        _ t) = t
-getStatType (LMAdd         t _) = getStatType t
-getStatType (LMSub         t _) = getStatType t
-getStatType (LMComment       _) = error "Can't call getStatType on LMComment!"
-
--- | Return the 'LlvmLinkageType' for a 'LlvmVar'
-getLink :: LlvmVar -> LlvmLinkageType
-getLink (LMGlobalVar _ _ l _ _ _) = l
-getLink _                         = Internal
-
--- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid'
--- cannot be lifted.
-pLift :: LlvmType -> LlvmType
-pLift LMLabel    = error "Labels are unliftable"
-pLift LMVoid     = error "Voids are unliftable"
-pLift LMMetadata = error "Metadatas are unliftable"
-pLift x          = LMPointer x
-
--- | Lift a variable to 'LMPointer' type.
-pVarLift :: LlvmVar -> LlvmVar
-pVarLift (LMGlobalVar s t l x a c) = LMGlobalVar s (pLift t) l x a c
-pVarLift (LMLocalVar  s t        ) = LMLocalVar  s (pLift t)
-pVarLift (LMNLocalVar s t        ) = LMNLocalVar s (pLift t)
-pVarLift (LMLitVar    _          ) = error $ "Can't lower a literal type!"
-
--- | Remove the pointer indirection of the supplied type. Only 'LMPointer'
--- constructors can be lowered.
-pLower :: LlvmType -> LlvmType
-pLower (LMPointer x) = x
-pLower x  = pprPanic "llvmGen(pLower)"
-            $ ppr x <+> text " is a unlowerable type, need a pointer"
-
--- | Lower a variable of 'LMPointer' type.
-pVarLower :: LlvmVar -> LlvmVar
-pVarLower (LMGlobalVar s t l x a c) = LMGlobalVar s (pLower t) l x a c
-pVarLower (LMLocalVar  s t        ) = LMLocalVar  s (pLower t)
-pVarLower (LMNLocalVar s t        ) = LMNLocalVar s (pLower t)
-pVarLower (LMLitVar    _          ) = error $ "Can't lower a literal type!"
-
--- | Test if the given 'LlvmType' is an integer
-isInt :: LlvmType -> Bool
-isInt (LMInt _) = True
-isInt _         = False
-
--- | Test if the given 'LlvmType' is a floating point type
-isFloat :: LlvmType -> Bool
-isFloat LMFloat    = True
-isFloat LMDouble   = True
-isFloat LMFloat80  = True
-isFloat LMFloat128 = True
-isFloat _          = False
-
--- | Test if the given 'LlvmType' is an 'LMPointer' construct
-isPointer :: LlvmType -> Bool
-isPointer (LMPointer _) = True
-isPointer _             = False
-
--- | Test if the given 'LlvmType' is an 'LMVector' construct
-isVector :: LlvmType -> Bool
-isVector (LMVector {}) = True
-isVector _             = False
-
--- | Test if a 'LlvmVar' is global.
-isGlobal :: LlvmVar -> Bool
-isGlobal (LMGlobalVar _ _ _ _ _ _) = True
-isGlobal _                         = False
-
--- | Width in bits of an 'LlvmType', returns 0 if not applicable
-llvmWidthInBits :: Platform -> LlvmType -> Int
-llvmWidthInBits platform = \case
-   (LMInt n)       -> n
-   (LMFloat)       -> 32
-   (LMDouble)      -> 64
-   (LMFloat80)     -> 80
-   (LMFloat128)    -> 128
-   -- Could return either a pointer width here or the width of what
-   -- it points to. We will go with the former for now.
-   -- PMW: At least judging by the way LLVM outputs constants, pointers
-   --      should use the former, but arrays the latter.
-   (LMPointer _)   -> llvmWidthInBits platform (llvmWord platform)
-   (LMArray n t)   -> n * llvmWidthInBits platform t
-   (LMVector n ty) -> n * llvmWidthInBits platform ty
-   LMLabel         -> 0
-   LMVoid          -> 0
-   (LMStruct tys)  -> sum $ map (llvmWidthInBits platform) tys
-   (LMStructU _)   ->
-    -- It's not trivial to calculate the bit width of the unpacked structs,
-    -- since they will be aligned depending on the specified datalayout (
-    -- http://llvm.org/docs/LangRef.html#data-layout ). One way we could support
-    -- this could be to make the GHC.CmmToLlvm.Ppr.moduleLayout be a data type
-    -- that exposes the alignment information. However, currently the only place
-    -- we use unpacked structs is LLVM intrinsics that return them (e.g.,
-    -- llvm.sadd.with.overflow.*), so we don't actually need to compute their
-    -- bit width.
-    panic "llvmWidthInBits: not implemented for LMStructU"
-   (LMFunction  _) -> 0
-   (LMAlias (_,t)) -> llvmWidthInBits platform t
-   LMMetadata      -> panic "llvmWidthInBits: Meta-data has no runtime representation!"
-
-
--- -----------------------------------------------------------------------------
--- ** Shortcut for Common Types
---
-
-i128, i64, i32, i16, i8, i1, i8Ptr :: LlvmType
-i128  = LMInt 128
-i64   = LMInt  64
-i32   = LMInt  32
-i16   = LMInt  16
-i8    = LMInt   8
-i1    = LMInt   1
-i8Ptr = pLift i8
-
--- | The target architectures word size
-llvmWord, llvmWordPtr :: Platform -> LlvmType
-llvmWord    platform = LMInt (platformWordSizeInBytes platform * 8)
-llvmWordPtr platform = pLift (llvmWord platform)
-
--- -----------------------------------------------------------------------------
--- * LLVM Function Types
---
-
--- | An LLVM Function
-data LlvmFunctionDecl = LlvmFunctionDecl {
-        -- | Unique identifier of the function
-        decName       :: LMString,
-        -- | LinkageType of the function
-        funcLinkage   :: LlvmLinkageType,
-        -- | The calling convention of the function
-        funcCc        :: LlvmCallConvention,
-        -- | Type of the returned value
-        decReturnType :: LlvmType,
-        -- | Indicates if this function uses varargs
-        decVarargs    :: LlvmParameterListType,
-        -- | Parameter types and attributes
-        decParams     :: [LlvmParameter],
-        -- | Function align value, must be power of 2
-        funcAlign     :: LMAlign
-  }
-  deriving (Eq)
-
-instance Outputable LlvmFunctionDecl where
-  ppr (LlvmFunctionDecl n l c r varg p a)
-    = let align = case a of
-                       Just a' -> text " align " <> ppr a'
-                       Nothing -> empty
-      in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <>
-             lparen <> ppParams varg p <> rparen <> align
-
-type LlvmFunctionDecls = [LlvmFunctionDecl]
-
-type LlvmParameter = (LlvmType, [LlvmParamAttr])
-
--- | LLVM Parameter Attributes.
---
--- Parameter attributes are used to communicate additional information about
--- the result or parameters of a function
-data LlvmParamAttr
-  -- | This indicates to the code generator that the parameter or return value
-  -- should be zero-extended to a 32-bit value by the caller (for a parameter)
-  -- or the callee (for a return value).
-  = ZeroExt
-  -- | This indicates to the code generator that the parameter or return value
-  -- should be sign-extended to a 32-bit value by the caller (for a parameter)
-  -- or the callee (for a return value).
-  | SignExt
-  -- | This indicates that this parameter or return value should be treated in
-  -- a special target-dependent fashion during while emitting code for a
-  -- function call or return (usually, by putting it in a register as opposed
-  -- to memory).
-  | InReg
-  -- | This indicates that the pointer parameter should really be passed by
-  -- value to the function.
-  | ByVal
-  -- | This indicates that the pointer parameter specifies the address of a
-  -- structure that is the return value of the function in the source program.
-  | SRet
-  -- | This indicates that the pointer does not alias any global or any other
-  -- parameter.
-  | NoAlias
-  -- | This indicates that the callee does not make any copies of the pointer
-  -- that outlive the callee itself
-  | NoCapture
-  -- | This indicates that the pointer parameter can be excised using the
-  -- trampoline intrinsics.
-  | Nest
-  deriving (Eq)
-
-instance Outputable LlvmParamAttr where
-  ppr ZeroExt   = text "zeroext"
-  ppr SignExt   = text "signext"
-  ppr InReg     = text "inreg"
-  ppr ByVal     = text "byval"
-  ppr SRet      = text "sret"
-  ppr NoAlias   = text "noalias"
-  ppr NoCapture = text "nocapture"
-  ppr Nest      = text "nest"
-
--- | Llvm Function Attributes.
---
--- Function attributes are set to communicate additional information about a
--- function. Function attributes are considered to be part of the function,
--- not of the function type, so functions with different parameter attributes
--- can have the same function type. Functions can have multiple attributes.
---
--- Descriptions taken from <http://llvm.org/docs/LangRef.html#fnattrs>
-data LlvmFuncAttr
-  -- | This attribute indicates that the inliner should attempt to inline this
-  -- function into callers whenever possible, ignoring any active inlining
-  -- size threshold for this caller.
-  = AlwaysInline
-  -- | This attribute indicates that the source code contained a hint that
-  -- inlining this function is desirable (such as the \"inline\" keyword in
-  -- C/C++). It is just a hint; it imposes no requirements on the inliner.
-  | InlineHint
-  -- | This attribute indicates that the inliner should never inline this
-  -- function in any situation. This attribute may not be used together
-  -- with the alwaysinline attribute.
-  | NoInline
-  -- | This attribute suggests that optimization passes and code generator
-  -- passes make choices that keep the code size of this function low, and
-  -- otherwise do optimizations specifically to reduce code size.
-  | OptSize
-  -- | This function attribute indicates that the function never returns
-  -- normally. This produces undefined behavior at runtime if the function
-  -- ever does dynamically return.
-  | NoReturn
-  -- | This function attribute indicates that the function never returns with
-  -- an unwind or exceptional control flow. If the function does unwind, its
-  -- runtime behavior is undefined.
-  | NoUnwind
-  -- | This attribute indicates that the function computes its result (or
-  -- decides to unwind an exception) based strictly on its arguments, without
-  -- dereferencing any pointer arguments or otherwise accessing any mutable
-  -- state (e.g. memory, control registers, etc) visible to caller functions.
-  -- It does not write through any pointer arguments (including byval
-  -- arguments) and never changes any state visible to callers. This means
-  -- that it cannot unwind exceptions by calling the C++ exception throwing
-  -- methods, but could use the unwind instruction.
-  | ReadNone
-  -- | This attribute indicates that the function does not write through any
-  -- pointer arguments (including byval arguments) or otherwise modify any
-  -- state (e.g. memory, control registers, etc) visible to caller functions.
-  -- It may dereference pointer arguments and read state that may be set in
-  -- the caller. A readonly function always returns the same value (or unwinds
-  -- an exception identically) when called with the same set of arguments and
-  -- global state. It cannot unwind an exception by calling the C++ exception
-  -- throwing methods, but may use the unwind instruction.
-  | ReadOnly
-  -- | This attribute indicates that the function should emit a stack smashing
-  -- protector. It is in the form of a \"canary\"—a random value placed on the
-  -- stack before the local variables that's checked upon return from the
-  -- function to see if it has been overwritten. A heuristic is used to
-  -- determine if a function needs stack protectors or not.
-  --
-  -- If a function that has an ssp attribute is inlined into a function that
-  -- doesn't have an ssp attribute, then the resulting function will have an
-  -- ssp attribute.
-  | Ssp
-  -- | This attribute indicates that the function should always emit a stack
-  -- smashing protector. This overrides the ssp function attribute.
-  --
-  -- If a function that has an sspreq attribute is inlined into a function
-  -- that doesn't have an sspreq attribute or which has an ssp attribute,
-  -- then the resulting function will have an sspreq attribute.
-  | SspReq
-  -- | This attribute indicates that the code generator should not use a red
-  -- zone, even if the target-specific ABI normally permits it.
-  | NoRedZone
-  -- | This attributes disables implicit floating point instructions.
-  | NoImplicitFloat
-  -- | This attribute disables prologue / epilogue emission for the function.
-  -- This can have very system-specific consequences.
-  | Naked
-  deriving (Eq)
-
-instance Outputable LlvmFuncAttr where
-  ppr AlwaysInline       = text "alwaysinline"
-  ppr InlineHint         = text "inlinehint"
-  ppr NoInline           = text "noinline"
-  ppr OptSize            = text "optsize"
-  ppr NoReturn           = text "noreturn"
-  ppr NoUnwind           = text "nounwind"
-  ppr ReadNone           = text "readnone"
-  ppr ReadOnly           = text "readonly"
-  ppr Ssp                = text "ssp"
-  ppr SspReq             = text "ssqreq"
-  ppr NoRedZone          = text "noredzone"
-  ppr NoImplicitFloat    = text "noimplicitfloat"
-  ppr Naked              = text "naked"
-
-
--- | Different types to call a function.
-data LlvmCallType
-  -- | Normal call, allocate a new stack frame.
-  = StdCall
-  -- | Tail call, perform the call in the current stack frame.
-  | TailCall
-  deriving (Eq,Show)
-
--- | Different calling conventions a function can use.
-data LlvmCallConvention
-  -- | The C calling convention.
-  -- This calling convention (the default if no other calling convention is
-  -- specified) matches the target C calling conventions. This calling
-  -- convention supports varargs function calls and tolerates some mismatch in
-  -- the declared prototype and implemented declaration of the function (as
-  -- does normal C).
-  = CC_Ccc
-  -- | This calling convention attempts to make calls as fast as possible
-  -- (e.g. by passing things in registers). This calling convention allows
-  -- the target to use whatever tricks it wants to produce fast code for the
-  -- target, without having to conform to an externally specified ABI
-  -- (Application Binary Interface). Implementations of this convention should
-  -- allow arbitrary tail call optimization to be supported. This calling
-  -- convention does not support varargs and requires the prototype of al
-  -- callees to exactly match the prototype of the function definition.
-  | CC_Fastcc
-  -- | This calling convention attempts to make code in the caller as efficient
-  -- as possible under the assumption that the call is not commonly executed.
-  -- As such, these calls often preserve all registers so that the call does
-  -- not break any live ranges in the caller side. This calling convention
-  -- does not support varargs and requires the prototype of all callees to
-  -- exactly match the prototype of the function definition.
-  | CC_Coldcc
-  -- | The GHC-specific 'registerised' calling convention.
-  | CC_Ghc
-  -- | Any calling convention may be specified by number, allowing
-  -- target-specific calling conventions to be used. Target specific calling
-  -- conventions start at 64.
-  | CC_Ncc Int
-  -- | X86 Specific 'StdCall' convention. LLVM includes a specific alias for it
-  -- rather than just using CC_Ncc.
-  | CC_X86_Stdcc
-  deriving (Eq)
-
-instance Outputable LlvmCallConvention where
-  ppr CC_Ccc       = text "ccc"
-  ppr CC_Fastcc    = text "fastcc"
-  ppr CC_Coldcc    = text "coldcc"
-  ppr CC_Ghc       = text "ghccc"
-  ppr (CC_Ncc i)   = text "cc " <> ppr i
-  ppr CC_X86_Stdcc = text "x86_stdcallcc"
-
-
--- | Functions can have a fixed amount of parameters, or a variable amount.
-data LlvmParameterListType
-  -- Fixed amount of arguments.
-  = FixedArgs
-  -- Variable amount of arguments.
-  | VarArgs
-  deriving (Eq,Show)
-
-
--- | Linkage type of a symbol.
---
--- The description of the constructors is copied from the Llvm Assembly Language
--- Reference Manual <http://www.llvm.org/docs/LangRef.html#linkage>, because
--- they correspond to the Llvm linkage types.
-data LlvmLinkageType
-  -- | Global values with internal linkage are only directly accessible by
-  -- objects in the current module. In particular, linking code into a module
-  -- with an internal global value may cause the internal to be renamed as
-  -- necessary to avoid collisions. Because the symbol is internal to the
-  -- module, all references can be updated. This corresponds to the notion
-  -- of the @static@ keyword in C.
-  = Internal
-  -- | Globals with @linkonce@ linkage are merged with other globals of the
-  -- same name when linkage occurs. This is typically used to implement
-  -- inline functions, templates, or other code which must be generated
-  -- in each translation unit that uses it. Unreferenced linkonce globals are
-  -- allowed to be discarded.
-  | LinkOnce
-  -- | @weak@ linkage is exactly the same as linkonce linkage, except that
-  -- unreferenced weak globals may not be discarded. This is used for globals
-  -- that may be emitted in multiple translation units, but that are not
-  -- guaranteed to be emitted into every translation unit that uses them. One
-  -- example of this are common globals in C, such as @int X;@ at global
-  -- scope.
-  | Weak
-  -- | @appending@ linkage may only be applied to global variables of pointer
-  -- to array type. When two global variables with appending linkage are
-  -- linked together, the two global arrays are appended together. This is
-  -- the Llvm, typesafe, equivalent of having the system linker append
-  -- together @sections@ with identical names when .o files are linked.
-  | Appending
-  -- | The semantics of this linkage follow the ELF model: the symbol is weak
-  -- until linked, if not linked, the symbol becomes null instead of being an
-  -- undefined reference.
-  | ExternWeak
-  -- | The symbol participates in linkage and can be used to resolve external
-  --  symbol references.
-  | ExternallyVisible
-  -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM
-  --  assembly.
-  | External
-  -- | Symbol is private to the module and should not appear in the symbol table
-  | Private
-  deriving (Eq)
-
-instance Outputable LlvmLinkageType where
-  ppr Internal          = text "internal"
-  ppr LinkOnce          = text "linkonce"
-  ppr Weak              = text "weak"
-  ppr Appending         = text "appending"
-  ppr ExternWeak        = text "extern_weak"
-  -- ExternallyVisible does not have a textual representation, it is
-  -- the linkage type a function resolves to if no other is specified
-  -- in Llvm.
-  ppr ExternallyVisible = empty
-  ppr External          = text "external"
-  ppr Private           = text "private"
-
--- -----------------------------------------------------------------------------
--- * LLVM Operations
---
-
--- | Llvm binary operators machine operations.
-data LlvmMachOp
-  = LM_MO_Add  -- ^ add two integer, floating point or vector values.
-  | LM_MO_Sub  -- ^ subtract two ...
-  | LM_MO_Mul  -- ^ multiply ..
-  | LM_MO_UDiv -- ^ unsigned integer or vector division.
-  | LM_MO_SDiv -- ^ signed integer ..
-  | LM_MO_URem -- ^ unsigned integer or vector remainder (mod)
-  | LM_MO_SRem -- ^ signed ...
-
-  | LM_MO_FAdd -- ^ add two floating point or vector values.
-  | LM_MO_FSub -- ^ subtract two ...
-  | LM_MO_FMul -- ^ multiply ...
-  | LM_MO_FDiv -- ^ divide ...
-  | LM_MO_FRem -- ^ remainder ...
-
-  -- | Left shift
-  | LM_MO_Shl
-  -- | Logical shift right
-  -- Shift right, filling with zero
-  | LM_MO_LShr
-  -- | Arithmetic shift right
-  -- The most significant bits of the result will be equal to the sign bit of
-  -- the left operand.
-  | LM_MO_AShr
-
-  | LM_MO_And -- ^ AND bitwise logical operation.
-  | LM_MO_Or  -- ^ OR bitwise logical operation.
-  | LM_MO_Xor -- ^ XOR bitwise logical operation.
-  deriving (Eq)
-
-instance Outputable LlvmMachOp where
-  ppr LM_MO_Add  = text "add"
-  ppr LM_MO_Sub  = text "sub"
-  ppr LM_MO_Mul  = text "mul"
-  ppr LM_MO_UDiv = text "udiv"
-  ppr LM_MO_SDiv = text "sdiv"
-  ppr LM_MO_URem = text "urem"
-  ppr LM_MO_SRem = text "srem"
-  ppr LM_MO_FAdd = text "fadd"
-  ppr LM_MO_FSub = text "fsub"
-  ppr LM_MO_FMul = text "fmul"
-  ppr LM_MO_FDiv = text "fdiv"
-  ppr LM_MO_FRem = text "frem"
-  ppr LM_MO_Shl  = text "shl"
-  ppr LM_MO_LShr = text "lshr"
-  ppr LM_MO_AShr = text "ashr"
-  ppr LM_MO_And  = text "and"
-  ppr LM_MO_Or   = text "or"
-  ppr LM_MO_Xor  = text "xor"
-
-
--- | Llvm compare operations.
-data LlvmCmpOp
-  = LM_CMP_Eq  -- ^ Equal (Signed and Unsigned)
-  | LM_CMP_Ne  -- ^ Not equal (Signed and Unsigned)
-  | LM_CMP_Ugt -- ^ Unsigned greater than
-  | LM_CMP_Uge -- ^ Unsigned greater than or equal
-  | LM_CMP_Ult -- ^ Unsigned less than
-  | LM_CMP_Ule -- ^ Unsigned less than or equal
-  | LM_CMP_Sgt -- ^ Signed greater than
-  | LM_CMP_Sge -- ^ Signed greater than or equal
-  | LM_CMP_Slt -- ^ Signed less than
-  | LM_CMP_Sle -- ^ Signed less than or equal
-
-  -- Float comparisons. GHC uses a mix of ordered and unordered float
-  -- comparisons.
-  | LM_CMP_Feq -- ^ Float equal
-  | LM_CMP_Fne -- ^ Float not equal
-  | LM_CMP_Fgt -- ^ Float greater than
-  | LM_CMP_Fge -- ^ Float greater than or equal
-  | LM_CMP_Flt -- ^ Float less than
-  | LM_CMP_Fle -- ^ Float less than or equal
-  deriving (Eq)
-
-instance Outputable LlvmCmpOp where
-  ppr LM_CMP_Eq  = text "eq"
-  ppr LM_CMP_Ne  = text "ne"
-  ppr LM_CMP_Ugt = text "ugt"
-  ppr LM_CMP_Uge = text "uge"
-  ppr LM_CMP_Ult = text "ult"
-  ppr LM_CMP_Ule = text "ule"
-  ppr LM_CMP_Sgt = text "sgt"
-  ppr LM_CMP_Sge = text "sge"
-  ppr LM_CMP_Slt = text "slt"
-  ppr LM_CMP_Sle = text "sle"
-  ppr LM_CMP_Feq = text "oeq"
-  ppr LM_CMP_Fne = text "une"
-  ppr LM_CMP_Fgt = text "ogt"
-  ppr LM_CMP_Fge = text "oge"
-  ppr LM_CMP_Flt = text "olt"
-  ppr LM_CMP_Fle = text "ole"
-
-
--- | Llvm cast operations.
-data LlvmCastOp
-  = LM_Trunc    -- ^ Integer truncate
-  | LM_Zext     -- ^ Integer extend (zero fill)
-  | LM_Sext     -- ^ Integer extend (sign fill)
-  | LM_Fptrunc  -- ^ Float truncate
-  | LM_Fpext    -- ^ Float extend
-  | LM_Fptoui   -- ^ Float to unsigned Integer
-  | LM_Fptosi   -- ^ Float to signed Integer
-  | LM_Uitofp   -- ^ Unsigned Integer to Float
-  | LM_Sitofp   -- ^ Signed Int to Float
-  | LM_Ptrtoint -- ^ Pointer to Integer
-  | LM_Inttoptr -- ^ Integer to Pointer
-  | LM_Bitcast  -- ^ Cast between types where no bit manipulation is needed
-  deriving (Eq)
-
-instance Outputable LlvmCastOp where
-  ppr LM_Trunc    = text "trunc"
-  ppr LM_Zext     = text "zext"
-  ppr LM_Sext     = text "sext"
-  ppr LM_Fptrunc  = text "fptrunc"
-  ppr LM_Fpext    = text "fpext"
-  ppr LM_Fptoui   = text "fptoui"
-  ppr LM_Fptosi   = text "fptosi"
-  ppr LM_Uitofp   = text "uitofp"
-  ppr LM_Sitofp   = text "sitofp"
-  ppr LM_Ptrtoint = text "ptrtoint"
-  ppr LM_Inttoptr = text "inttoptr"
-  ppr LM_Bitcast  = text "bitcast"
-
-
--- -----------------------------------------------------------------------------
--- * Floating point conversion
---
-
--- | Convert a Haskell Double to an LLVM hex encoded floating point form. In
--- Llvm float literals can be printed in a big-endian hexadecimal format,
--- regardless of underlying architecture.
---
--- See Note [LLVM Float Types].
-ppDouble :: Platform -> Double -> SDoc
-ppDouble platform d
-  = let bs     = doubleToBytes d
-        hex d' = case showHex d' "" of
-            []    -> error "ppDouble: too few hex digits for float"
-            [x]   -> ['0',x]
-            [x,y] -> [x,y]
-            _     -> error "ppDouble: too many hex digits for float"
-
-        fixEndian = case platformByteOrder platform of
-            BigEndian    -> id
-            LittleEndian -> reverse
-        str       = map toUpper $ concat $ fixEndian $ map hex bs
-    in text "0x" <> text str
-
--- Note [LLVM Float Types]
--- ~~~~~~~~~~~~~~~~~~~~~~~
--- We use 'ppDouble' for both printing Float and Double floating point types. This is
--- as LLVM expects all floating point constants (single & double) to be in IEEE
--- 754 Double precision format. However, for single precision numbers (Float)
--- they should be *representable* in IEEE 754 Single precision format. So the
--- easiest way to do this is to narrow and widen again.
--- (i.e., Double -> Float -> Double). We must be careful doing this that GHC
--- doesn't optimize that away.
-
--- Note [narrowFp & widenFp]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~
--- NOTE: we use float2Double & co directly as GHC likes to optimize away
--- successive calls of 'realToFrac', defeating the narrowing. (Bug #7600).
--- 'realToFrac' has inconsistent behaviour with optimisation as well that can
--- also cause issues, these methods don't.
-
-narrowFp :: Double -> Float
-{-# NOINLINE narrowFp #-}
-narrowFp = double2Float
-
-widenFp :: Float -> Double
-{-# NOINLINE widenFp #-}
-widenFp = float2Double
-
-ppFloat :: Platform -> Float -> SDoc
-ppFloat platform = ppDouble platform . widenFp
-
-
---------------------------------------------------------------------------------
--- * Misc functions
---------------------------------------------------------------------------------
-
-ppCommaJoin :: (Outputable a) => [a] -> SDoc
-ppCommaJoin strs = hsep $ punctuate comma (map ppr strs)
-
-ppSpaceJoin :: (Outputable a) => [a] -> SDoc
-ppSpaceJoin strs = hsep (map ppr strs)
diff --git a/compiler/GHC/Parser/Utils.hs b/compiler/GHC/Parser/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/Parser/Utils.hs
+++ /dev/null
@@ -1,58 +0,0 @@
-module GHC.Parser.Utils
-    ( isStmt
-    , hasImport
-    , isImport
-    , isDecl
-    )
-where
-
-import GHC.Prelude
-import GHC.Hs
-import GHC.Data.StringBuffer
-import GHC.Data.FastString
-import GHC.Types.SrcLoc
-
-import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, initParserState)
-import GHC.Parser.Lexer (ParserOpts)
-import qualified GHC.Parser       as Parser (parseStmt, parseModule, parseDeclaration, parseImport)
-
-
--- | Returns @True@ if passed string is a statement.
-isStmt :: ParserOpts -> String -> Bool
-isStmt pflags stmt =
-  case parseThing Parser.parseStmt pflags stmt of
-    Lexer.POk _ _ -> True
-    Lexer.PFailed _ -> False
-
--- | Returns @True@ if passed string has an import declaration.
-hasImport :: ParserOpts -> String -> Bool
-hasImport pflags stmt =
-  case parseThing Parser.parseModule pflags stmt of
-    Lexer.POk _ thing -> hasImports thing
-    Lexer.PFailed _ -> False
-  where
-    hasImports = not . null . hsmodImports . unLoc
-
--- | Returns @True@ if passed string is an import declaration.
-isImport :: ParserOpts -> String -> Bool
-isImport pflags stmt =
-  case parseThing Parser.parseImport pflags stmt of
-    Lexer.POk _ _ -> True
-    Lexer.PFailed _ -> False
-
--- | Returns @True@ if passed string is a declaration but __/not a splice/__.
-isDecl :: ParserOpts -> String -> Bool
-isDecl pflags stmt =
-  case parseThing Parser.parseDeclaration pflags stmt of
-    Lexer.POk _ thing ->
-      case unLoc thing of
-        SpliceD _ _ -> False
-        _ -> True
-    Lexer.PFailed _ -> False
-
-parseThing :: Lexer.P thing -> ParserOpts -> String -> Lexer.ParseResult thing
-parseThing parser opts stmt = do
-  let buf = stringToStringBuffer stmt
-      loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
-
-  Lexer.unP parser (Lexer.initParserState opts buf loc)
diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs
deleted file mode 100644
--- a/compiler/GHC/Plugins.hs
+++ /dev/null
@@ -1,214 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-duplicate-exports -fno-warn-orphans #-}
-
--- | This module is not used by GHC itself.  Rather, it exports all of
--- the functions and types you are likely to need when writing a
--- plugin for GHC. So authors of plugins can probably get away simply
--- with saying "import GHC.Plugins".
---
--- Particularly interesting modules for plugin writers include
--- "GHC.Core" and "GHC.Core.Opt.Monad".
-module GHC.Plugins
-   ( module GHC.Driver.Plugins
-   , module GHC.Types.Name.Reader
-   , module GHC.Types.Name.Occurrence
-   , module GHC.Types.Name
-   , module GHC.Types.Var
-   , module GHC.Types.Id
-   , module GHC.Types.Id.Info
-   , module GHC.Types.PkgQual
-   , module GHC.Core.Opt.Monad
-   , module GHC.Core.Opt.Pipeline.Types
-   , module GHC.Core.Opt.Stats
-   , module GHC.Core
-   , module GHC.Types.Literal
-   , module GHC.Core.DataCon
-   , module GHC.Core.Utils
-   , module GHC.Core.Make
-   , module GHC.Core.FVs
-   , module GHC.Core.Subst
-   , module GHC.Core.Rules
-   , module GHC.Types.Annotations
-   , module GHC.Driver.Session
-   , module GHC.Driver.Ppr
-   , module GHC.Unit.State
-   , module GHC.Unit.Module
-   , module GHC.Unit.Home
-   , module GHC.Core.Type
-   , module GHC.Core.TyCon
-   , module GHC.Core.Coercion
-   , module GHC.Builtin.Types
-   , module GHC.Driver.Env
-   , module GHC.Types.Basic
-   , module GHC.Types.Var.Set
-   , module GHC.Types.Var.Env
-   , module GHC.Types.Name.Set
-   , module GHC.Types.Name.Env
-   , module GHC.Types.Unique
-   , module GHC.Types.Unique.Set
-   , module GHC.Types.Unique.FM
-   , module GHC.Data.FiniteMap
-   , module GHC.Utils.Misc
-   , module GHC.Serialized
-   , module GHC.Types.SrcLoc
-   , module GHC.Utils.Outputable
-   , module GHC.Utils.Panic
-   , module GHC.Types.Unique.Supply
-   , module GHC.Data.FastString
-   , module GHC.Tc.Errors.Hole.FitTypes   -- for hole-fit plugins
-   , module GHC.Unit.Module.ModGuts
-   , module GHC.Unit.Module.ModSummary
-   , module GHC.Unit.Module.ModIface
-   , module GHC.Types.Meta
-   , module GHC.Types.SourceError
-   , module GHC.Parser.Errors.Types
-   , module GHC.Types.Error
-   , module GHC.Hs
-   , -- * Getting 'Name's
-     thNameToGhcName
-   , thNameToGhcNameIO
-   )
-where
-
--- Plugin stuff itself
-import GHC.Driver.Plugins
-
--- Variable naming
-import GHC.Types.TyThing
-import GHC.Types.PkgQual
-import GHC.Types.SourceError
-import GHC.Types.Name.Reader
-import GHC.Types.Name.Occurrence  hiding  ( varName {- conflicts with Var.varName -} )
-import GHC.Types.Name     hiding  ( varName {- reexport from OccName, conflicts with Var.varName -} )
-import GHC.Types.Var
-import GHC.Types.Id       hiding  ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} )
-import GHC.Types.Id.Info
-
--- Core
-import GHC.Core.Opt.Monad
-import GHC.Core.Opt.Pipeline.Types
-import GHC.Core.Opt.Stats
-import GHC.Core
-import GHC.Types.Literal
-import GHC.Core.DataCon
-import GHC.Core.Utils
-import GHC.Core.Make
-import GHC.Core.FVs
-import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst, extendSubstInScopeSet )
-       -- These names are also exported by Type
-
-import GHC.Core.Rules
-import GHC.Types.Annotations
-import GHC.Types.Meta
-
-import GHC.Driver.Session
-import GHC.Unit.State
-
-import GHC.Unit.Home
-import GHC.Unit.Module
-import GHC.Unit.Module.ModGuts
-import GHC.Unit.Module.ModSummary
-import GHC.Unit.Module.ModIface
-import GHC.Core.Type hiding {- conflict with GHC.Core.Subst -}
-                ( substTy, extendTvSubst, extendTvSubstList, isInScope )
-import GHC.Core.Coercion hiding {- conflict with GHC.Core.Subst -}
-                ( substCo )
-import GHC.Core.TyCon
-import GHC.Builtin.Types
-import GHC.Driver.Env
-import GHC.Types.Basic
-
--- Collections and maps
-import GHC.Types.Var.Set
-import GHC.Types.Var.Env
-import GHC.Types.Name.Set
-import GHC.Types.Name.Env
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.FM
--- Conflicts with UniqFM:
---import LazyUniqFM
-import GHC.Data.FiniteMap
-
--- Common utilities
-import GHC.Utils.Misc
-import GHC.Serialized
-import GHC.Types.SrcLoc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Driver.Ppr
-import GHC.Types.Unique.Supply
-import GHC.Types.Unique ( Unique, Uniquable(..) )
-import GHC.Data.FastString
-import Data.Maybe
-
-import GHC.Iface.Env    ( lookupNameCache )
-import GHC.Prelude
-import GHC.Utils.Monad  ( mapMaybeM )
-import GHC.ThToHs       ( thRdrNameGuesses )
-import GHC.Tc.Utils.Env ( lookupGlobal )
-import GHC.Types.Name.Cache ( NameCache )
-
-import GHC.Tc.Errors.Hole.FitTypes
-
--- For parse result plugins
-import GHC.Parser.Errors.Types ( PsWarning, PsError )
-import GHC.Types.Error         ( Messages )
-import GHC.Hs                  ( HsParsedModule )
-
-import qualified Language.Haskell.TH as TH
-
-{- This instance is defined outside GHC.Core.Opt.Monad so that
-   GHC.Core.Opt.Monad does not depend on GHC.Tc.Utils.Env -}
-instance MonadThings CoreM where
-    lookupThing name = do { hsc_env <- getHscEnv
-                          ; liftIO $ lookupGlobal hsc_env name }
-
-{-
-************************************************************************
-*                                                                      *
-               Template Haskell interoperability
-*                                                                      *
-************************************************************************
--}
-
--- | Attempt to convert a Template Haskell name to one that GHC can
--- understand. Original TH names such as those you get when you use
--- the @'foo@ syntax will be translated to their equivalent GHC name
--- exactly. Qualified or unqualified TH names will be dynamically bound
--- to names in the module being compiled, if possible. Exact TH names
--- will be bound to the name they represent, exactly.
-thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
-thNameToGhcName th_name = do
-  hsc_env <- getHscEnv
-  liftIO $ thNameToGhcNameIO (hsc_NC hsc_env) th_name
-
--- | Attempt to convert a Template Haskell name to one that GHC can
--- understand. Original TH names such as those you get when you use
--- the @'foo@ syntax will be translated to their equivalent GHC name
--- exactly. Qualified or unqualified TH names will be dynamically bound
--- to names in the module being compiled, if possible. Exact TH names
--- will be bound to the name they represent, exactly.
---
--- One must be careful to consistently use the same 'NameCache' to
--- create identifier that might be compared. (C.f. how the
--- 'Control.Monad.ST.ST' Monad enforces that variables from separate
--- 'Control.Monad.ST.runST' invocations are never intermingled; it would
--- be valid to use the same tricks for 'Name's and 'NameCache's.)
---
--- For now, the easiest and recommended way to ensure a consistent
--- 'NameCache' is used it to retrieve the preexisting one from an active
--- 'HscEnv'. A single 'HscEnv' is created per GHC "session", and this
--- ensures everything in that session will get the same name cache.
-thNameToGhcNameIO :: NameCache -> TH.Name -> IO (Maybe Name)
-thNameToGhcNameIO cache th_name
-  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
-          -- Pick the first that works
-          -- E.g. reify (mkName "A") will pick the class A in preference
-          -- to the data constructor A
-        ; return (listToMaybe names) }
-  where
-    lookup rdr_name
-      | Just n <- isExact_maybe rdr_name   -- This happens in derived code
-      = return $ if isExternalName n then Just n else Nothing
-      | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-      = Just <$> lookupNameCache cache rdr_mod rdr_occ
-      | otherwise = return Nothing
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
deleted file mode 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ /dev/null
@@ -1,1433 +0,0 @@
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
-{-# LANGUAGE TypeFamilies #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
-
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-Renaming and dependency analysis of bindings
-
-This module does renaming and dependency analysis on value bindings in
-the abstract syntax.  It does {\em not} do cycle-checks on class or
-type-synonym declarations; those cannot be done at this stage because
-they may be affected by renaming (which isn't fully worked out yet).
--}
-
-module GHC.Rename.Bind (
-   -- Renaming top-level bindings
-   rnTopBindsLHS, rnTopBindsLHSBoot, rnTopBindsBoot, rnValBindsRHS,
-
-   -- Renaming local bindings
-   rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
-
-   -- Other bindings
-   rnMethodBinds, renameSigs,
-   rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl,
-   makeMiniFixityEnv, MiniFixityEnv,
-   HsSigCtxt(..)
-   ) where
-
-import GHC.Prelude
-
-import {-# SOURCE #-} GHC.Rename.Expr( rnExpr, rnLExpr, rnStmts )
-
-import GHC.Hs
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-import GHC.Rename.HsType
-import GHC.Rename.Pat
-import GHC.Rename.Names
-import GHC.Rename.Env
-import GHC.Rename.Fixity
-import GHC.Rename.Utils ( mapFvRn
-                        , checkDupRdrNames, checkDupRdrNamesN
-                        , warnUnusedLocalBinds
-                        , warnForallIdentifier
-                        , checkUnusedRecordWildcard
-                        , checkDupAndShadowedNames, bindLocalNamesFV
-                        , addNoNestedForallsContextsErr, checkInferredVars )
-import GHC.Driver.Session
-import GHC.Unit.Module
-import GHC.Types.Error
-import GHC.Types.FieldLabel
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.Name.Set
-import GHC.Types.Name.Reader ( RdrName, rdrNameOcc )
-import GHC.Types.SrcLoc as SrcLoc
-import GHC.Data.List.SetOps    ( findDupsEq )
-import GHC.Types.Basic         ( RecFlag(..), TypeOrKind(..) )
-import GHC.Data.Graph.Directed ( SCC(..) )
-import GHC.Data.Bag
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Types.Unique.Set
-import GHC.Data.Maybe          ( orElse )
-import GHC.Data.OrdList
-import qualified GHC.LanguageExtensions as LangExt
-
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-import Control.Monad
-import Data.Foldable      ( toList )
-import Data.List          ( partition, sortBy )
-import Data.List.NonEmpty ( NonEmpty(..) )
-
-{-
--- ToDo: Put the annotations into the monad, so that they arrive in the proper
--- place and can be used when complaining.
-
-The code tree received by the function @rnBinds@ contains definitions
-in where-clauses which are all apparently mutually recursive, but which may
-not really depend upon each other. For example, in the top level program
-\begin{verbatim}
-f x = y where a = x
-              y = x
-\end{verbatim}
-the definitions of @a@ and @y@ do not depend on each other at all.
-Unfortunately, the typechecker cannot always check such definitions.
-\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
-definitions. In Proceedings of the International Symposium on Programming,
-Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
-However, the typechecker usually can check definitions in which only the
-strongly connected components have been collected into recursive bindings.
-This is precisely what the function @rnBinds@ does.
-
-ToDo: deal with case where a single monobinds binds the same variable
-twice.
-
-The vertag tag is a unique @Int@; the tags only need to be unique
-within one @MonoBinds@, so that unique-Int plumbing is done explicitly
-(heavy monad machinery not needed).
-
-
-************************************************************************
-*                                                                      *
-* naming conventions                                                   *
-*                                                                      *
-************************************************************************
-
-\subsection[name-conventions]{Name conventions}
-
-The basic algorithm involves walking over the tree and returning a tuple
-containing the new tree plus its free variables. Some functions, such
-as those walking polymorphic bindings (HsBinds) and qualifier lists in
-list comprehensions (@Quals@), return the variables bound in local
-environments. These are then used to calculate the free variables of the
-expression evaluated in these environments.
-
-Conventions for variable names are as follows:
-\begin{itemize}
-\item
-new code is given a prime to distinguish it from the old.
-
-\item
-a set of variables defined in @Exp@ is written @dvExp@
-
-\item
-a set of variables free in @Exp@ is written @fvExp@
-\end{itemize}
-
-************************************************************************
-*                                                                      *
-* analysing polymorphic bindings (HsBindGroup, HsBind)
-*                                                                      *
-************************************************************************
-
-\subsubsection[dep-HsBinds]{Polymorphic bindings}
-
-Non-recursive expressions are reconstructed without any changes at top
-level, although their component expressions may have to be altered.
-However, non-recursive expressions are currently not expected as
-\Haskell{} programs, and this code should not be executed.
-
-Monomorphic bindings contain information that is returned in a tuple
-(a @FlatMonoBinds@) containing:
-
-\begin{enumerate}
-\item
-a unique @Int@ that serves as the ``vertex tag'' for this binding.
-
-\item
-the name of a function or the names in a pattern. These are a set
-referred to as @dvLhs@, the defined variables of the left hand side.
-
-\item
-the free variables of the body. These are referred to as @fvBody@.
-
-\item
-the definition's actual code. This is referred to as just @code@.
-\end{enumerate}
-
-The function @nonRecDvFv@ returns two sets of variables. The first is
-the set of variables defined in the set of monomorphic bindings, while the
-second is the set of free variables in those bindings.
-
-The set of variables defined in a non-recursive binding is just the
-union of all of them, as @union@ removes duplicates. However, the
-free variables in each successive set of cumulative bindings is the
-union of those in the previous set plus those of the newest binding after
-the defined variables of the previous set have been removed.
-
-@rnMethodBinds@ deals only with the declarations in class and
-instance declarations.  It expects only to see @FunMonoBind@s, and
-it expects the global environment to contain bindings for the binders
-(which are all class operations).
-
-************************************************************************
-*                                                                      *
-\subsubsection{ Top-level bindings}
-*                                                                      *
-************************************************************************
--}
-
--- for top-level bindings, we need to make top-level names,
--- so we have a different entry point than for local bindings
-rnTopBindsLHS :: MiniFixityEnv
-              -> HsValBinds GhcPs
-              -> RnM (HsValBindsLR GhcRn GhcPs)
-rnTopBindsLHS fix_env binds
-  = rnValBindsLHS (topRecNameMaker fix_env) binds
-
--- Ensure that a hs-boot file has no top-level bindings.
-rnTopBindsLHSBoot :: MiniFixityEnv
-                  -> HsValBinds GhcPs
-                  -> RnM (HsValBindsLR GhcRn GhcPs)
-rnTopBindsLHSBoot fix_env binds
-  = do  { topBinds <- rnTopBindsLHS fix_env binds
-        ; case topBinds of
-            ValBinds x mbinds sigs ->
-              do  { mapM_ bindInHsBootFileErr mbinds
-                  ; pure (ValBinds x emptyBag sigs) }
-            _ -> pprPanic "rnTopBindsLHSBoot" (ppr topBinds) }
-
-rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs
-               -> RnM (HsValBinds GhcRn, DefUses)
--- A hs-boot file has no bindings.
--- Return a single HsBindGroup with empty binds and renamed signatures
-rnTopBindsBoot bound_names (ValBinds _ _ sigs)
-  = do  { (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs
-        ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) }
-rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)
-
-{-
-*********************************************************
-*                                                      *
-                HsLocalBinds
-*                                                      *
-*********************************************************
--}
-
-rnLocalBindsAndThen :: HsLocalBinds GhcPs
-                   -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-                   -> RnM (result, FreeVars)
--- This version (a) assumes that the binding vars are *not* already in scope
---               (b) removes the binders from the free vars of the thing inside
--- The parser doesn't produce ThenBinds
-rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside =
-  thing_inside (EmptyLocalBinds x) emptyNameSet
-
-rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside
-  = rnLocalValBindsAndThen val_binds $ \ val_binds' ->
-      thing_inside (HsValBinds x val_binds')
-
-rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do
-    (binds',fv_binds) <- rnIPBinds binds
-    (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds
-    return (thing, fvs_thing `plusFV` fv_binds)
-
-rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars)
-rnIPBinds (IPBinds _ ip_binds ) = do
-    (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstMA rnIPBind) ip_binds
-    return (IPBinds noExtField ip_binds', plusFVs fvs_s)
-
-rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)
-rnIPBind (IPBind _ n expr) = do
-    (expr',fvExpr) <- rnLExpr expr
-    return (IPBind noExtField n expr', fvExpr)
-
-{-
-************************************************************************
-*                                                                      *
-                ValBinds
-*                                                                      *
-************************************************************************
--}
-
--- Renaming local binding groups
--- Does duplicate/shadow check
-rnLocalValBindsLHS :: MiniFixityEnv
-                   -> HsValBinds GhcPs
-                   -> RnM ([Name], HsValBindsLR GhcRn GhcPs)
-rnLocalValBindsLHS fix_env binds
-  = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds
-
-         -- Check for duplicates and shadowing
-         -- Must do this *after* renaming the patterns
-         -- See Note [Collect binders only after renaming] in GHC.Hs.Utils
-
-         -- We need to check for dups here because we
-         -- don't don't bind all of the variables from the ValBinds at once
-         -- with bindLocatedLocals any more.
-         --
-         -- Note that we don't want to do this at the top level, since
-         -- sorting out duplicates and shadowing there happens elsewhere.
-         -- The behavior is even different. For example,
-         --   import A(f)
-         --   f = ...
-         -- should not produce a shadowing warning (but it will produce
-         -- an ambiguity warning if you use f), but
-         --   import A(f)
-         --   g = let f = ... in f
-         -- should.
-       ; let bound_names = collectHsValBinders CollNoDictBinders binds'
-             -- There should be only Ids, but if there are any bogus
-             -- pattern synonyms, we'll collect them anyway, so that
-             -- we don't generate subsequent out-of-scope messages
-       ; envs <- getRdrEnvs
-       ; checkDupAndShadowedNames envs bound_names
-
-       ; return (bound_names, binds') }
-
--- renames the left-hand sides
--- generic version used both at the top level and for local binds
--- does some error checking, but not what gets done elsewhere at the top level
-rnValBindsLHS :: NameMaker
-              -> HsValBinds GhcPs
-              -> RnM (HsValBindsLR GhcRn GhcPs)
-rnValBindsLHS topP (ValBinds x mbinds sigs)
-  = do { mbinds' <- mapBagM (wrapLocMA (rnBindLHS topP doc)) mbinds
-       ; return $ ValBinds x mbinds' sigs }
-  where
-    bndrs = collectHsBindsBinders CollNoDictBinders mbinds
-    doc   = text "In the binding group for:" <+> pprWithCommas ppr bndrs
-
-rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
-
--- General version used both from the top-level and for local things
--- Assumes the LHS vars are in scope
---
--- Does not bind the local fixity declarations
-rnValBindsRHS :: HsSigCtxt
-              -> HsValBindsLR GhcRn GhcPs
-              -> RnM (HsValBinds GhcRn, DefUses)
-
-rnValBindsRHS ctxt (ValBinds _ mbinds sigs)
-  = do { (sigs', sig_fvs) <- renameSigs ctxt sigs
-       ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds
-       ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus
-
-       ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $
-                          getPatSynBinds anal_binds
-                -- The uses in binds_w_dus for PatSynBinds do not include
-                -- variables used in the patsyn builders; see
-                -- Note [Pattern synonym builders don't yield dependencies]
-                -- But psb_fvs /does/ include those builder fvs.  So we
-                -- add them back in here to avoid bogus warnings about
-                -- unused variables (#12548)
-
-             valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs
-                                     `plusDU` usesOnly patsyn_fvs
-                            -- Put the sig uses *after* the bindings
-                            -- so that the binders are removed from
-                            -- the uses in the sigs
-
-        ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) }
-
-rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)
-
--- Wrapper for local binds
---
--- The *client* of this function is responsible for checking for unused binders;
--- it doesn't (and can't: we don't have the thing inside the binds) happen here
---
--- The client is also responsible for bringing the fixities into scope
-rnLocalValBindsRHS :: NameSet  -- names bound by the LHSes
-                   -> HsValBindsLR GhcRn GhcPs
-                   -> RnM (HsValBinds GhcRn, DefUses)
-rnLocalValBindsRHS bound_names binds
-  = rnValBindsRHS (LocalBindCtxt bound_names) binds
-
--- for local binds
--- wrapper that does both the left- and right-hand sides
---
--- here there are no local fixity decls passed in;
--- the local fixity decls come from the ValBinds sigs
-rnLocalValBindsAndThen
-  :: HsValBinds GhcPs
-  -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
-  -> RnM (result, FreeVars)
-rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside
- = do   {     -- (A) Create the local fixity environment
-          new_fixities <- makeMiniFixityEnv [ L loc sig
-                                            | L loc (FixSig _ sig) <- sigs]
-
-              -- (B) Rename the LHSes
-        ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds
-
-              --     ...and bring them (and their fixities) into scope
-        ; bindLocalNamesFV bound_names              $
-          addLocalFixities new_fixities bound_names $ do
-
-        {      -- (C) Do the RHS and thing inside
-          (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs
-        ; (result, result_fvs) <- thing_inside binds' (allUses dus)
-
-                -- Report unused bindings based on the (accurate)
-                -- findUses.  E.g.
-                --      let x = x in 3
-                -- should report 'x' unused
-        ; let real_uses = findUses dus result_fvs
-              -- Insert fake uses for variables introduced implicitly by
-              -- wildcards (#4404)
-              rec_uses = hsValBindsImplicits binds'
-              implicit_uses = mkNameSet $ concatMap snd
-                                        $ rec_uses
-        ; mapM_ (\(loc, ns) ->
-                    checkUnusedRecordWildcard loc real_uses (Just ns))
-                rec_uses
-        ; warnUnusedLocalBinds bound_names
-                                      (real_uses `unionNameSet` implicit_uses)
-
-        ; let
-            -- The variables "used" in the val binds are:
-            --   (1) the uses of the binds (allUses)
-            --   (2) the FVs of the thing-inside
-            all_uses = allUses dus `plusFV` result_fvs
-                -- Note [Unused binding hack]
-                -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
-                -- Note that *in contrast* to the above reporting of
-                -- unused bindings, (1) above uses duUses to return *all*
-                -- the uses, even if the binding is unused.  Otherwise consider:
-                --      x = 3
-                --      y = let p = x in 'x'    -- NB: p not used
-                -- If we don't "see" the dependency of 'y' on 'x', we may put the
-                -- bindings in the wrong order, and the type checker will complain
-                -- that x isn't in scope
-                --
-                -- But note that this means we won't report 'x' as unused,
-                -- whereas we would if we had { x = 3; p = x; y = 'x' }
-
-        ; return (result, all_uses) }}
-                -- The bound names are pruned out of all_uses
-                -- by the bindLocalNamesFV call above
-
-rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)
-
-
----------------------
-
--- renaming a single bind
-
-rnBindLHS :: NameMaker
-          -> SDoc
-          -> HsBind GhcPs
-          -- returns the renamed left-hand side,
-          -- and the FreeVars *of the LHS*
-          -- (i.e., any free variables of the pattern)
-          -> RnM (HsBindLR GhcRn GhcPs)
-
-rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })
-  = do
-      -- we don't actually use the FV processing of rnPatsAndThen here
-      (pat',pat'_fvs) <- rnBindPat name_maker pat
-      return (bind { pat_lhs = pat', pat_ext = pat'_fvs })
-                -- We temporarily store the pat's FVs in bind_fvs;
-                -- gets updated to the FVs of the whole bind
-                -- when doing the RHS below
-
-rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
-  = do { name <- applyNameMaker name_maker rdr_name
-       ; return (bind { fun_id = name
-                      , fun_ext = noExtField }) }
-
-rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })
-  | isTopRecNameMaker name_maker
-  = do { addLocMA checkConName rdrname
-       ; name <-
-           lookupLocatedTopConstructorRnN rdrname -- Should be in scope already
-       ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }
-
-  | otherwise  -- Pattern synonym, not at top level
-  = do { addErr localPatternSynonymErr  -- Complain, but make up a fake
-                                        -- name so that we can carry on
-       ; name <- applyNameMaker name_maker rdrname
-       ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }
-  where
-    localPatternSynonymErr :: TcRnMessage
-    localPatternSynonymErr = TcRnIllegalPatSynDecl rdrname
-
-rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
-
-rnLBind :: (Name -> [Name])      -- Signature tyvar function
-        -> LHsBindLR GhcRn GhcPs
-        -> RnM (LHsBind GhcRn, [Name], Uses)
-rnLBind sig_fn (L loc bind)
-  = setSrcSpanA loc $
-    do { (bind', bndrs, dus) <- rnBind sig_fn bind
-       ; return (L loc bind', bndrs, dus) }
-
--- assumes the left-hands-side vars are in scope
-rnBind :: (Name -> [Name])        -- Signature tyvar function
-       -> HsBindLR GhcRn GhcPs
-       -> RnM (HsBind GhcRn, [Name], Uses)
-rnBind _ bind@(PatBind { pat_lhs = pat
-                       , pat_rhs = grhss
-                                   -- pat fvs were stored in bind_fvs
-                                   -- after processing the LHS
-                       , pat_ext = pat_fvs })
-  = do  { mod <- getModule
-        ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss
-
-                -- No scoped type variables for pattern bindings
-        ; let all_fvs = pat_fvs `plusFV` rhs_fvs
-              fvs'    = filterNameSet (nameIsLocalOrFrom mod) all_fvs
-                -- Keep locally-defined Names
-                -- As well as dependency analysis, we need these for the
-                -- MonoLocalBinds test in GHC.Tc.Gen.Bind.decideGeneralisationPlan
-              bndrs = collectPatBinders CollNoDictBinders pat
-              bind' = bind { pat_rhs  = grhss'
-                           , pat_ext = fvs' }
-
-        -- Warn if the pattern binds no variables
-        -- See Note [Pattern bindings that bind no variables]
-        ; whenWOptM Opt_WarnUnusedPatternBinds $
-          when (null bndrs && not (isOkNoBindPattern pat)) $
-          addTcRnDiagnostic (TcRnUnusedPatternBinds bind')
-
-        ; fvs' `seq` -- See Note [Free-variable space leak]
-          return (bind', bndrs, all_fvs) }
-
-rnBind sig_fn bind@(FunBind { fun_id = name
-                            , fun_matches = matches })
-       -- invariant: no free vars here when it's a FunBind
-  = do  { let plain_name = unLoc name
-
-        ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
-                                -- bindSigTyVars tests for LangExt.ScopedTyVars
-                                 rnMatchGroup (mkPrefixFunRhs name)
-                                              rnLExpr matches
-        ; let is_infix = isInfixFunBind bind
-        ; when is_infix $ checkPrecMatch plain_name matches'
-
-        ; mod <- getModule
-        ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs
-                -- Keep locally-defined Names
-                -- As well as dependency analysis, we need these for the
-                -- MonoLocalBinds test in GHC.Tc.Gen.Bind.decideGeneralisationPlan
-
-        ; fvs' `seq` -- See Note [Free-variable space leak]
-          return (bind { fun_matches = matches'
-                       , fun_ext     = fvs' },
-                  [plain_name], rhs_fvs)
-      }
-
-rnBind sig_fn (PatSynBind x bind)
-  = do  { (bind', name, fvs) <- rnPatSynBind sig_fn bind
-        ; return (PatSynBind x bind', name, fvs) }
-
-rnBind _ b = pprPanic "rnBind" (ppr b)
-
- -- See Note [Pattern bindings that bind no variables]
-isOkNoBindPattern :: LPat GhcRn -> Bool
-isOkNoBindPattern (L _ pat) =
-  case pat of
-    WildPat{}       -> True -- Exception (1)
-    BangPat {}      -> True -- Exception (2) #9127, #13646
-    p -> patternContainsSplice p -- Exception (3)
-
-    where
-      lpatternContainsSplice :: LPat GhcRn -> Bool
-      lpatternContainsSplice (L _ p) = patternContainsSplice p
-      patternContainsSplice :: Pat GhcRn -> Bool
-      patternContainsSplice p =
-        case p of
-          -- A top-level splice has been evaluated by this point, so we know the pattern it is evaluated to
-          SplicePat (HsUntypedSpliceTop _ p) _ -> patternContainsSplice p
-          -- A nested splice isn't evaluated so we can't guess what it will expand to
-          SplicePat (HsUntypedSpliceNested {}) _ -> True
-          -- The base cases
-          VarPat {} -> False
-          WildPat {} -> False
-          LitPat {} -> False
-          NPat {} -> False
-          NPlusKPat {} -> False
-          -- Recursive cases
-          BangPat _ lp -> lpatternContainsSplice lp
-          LazyPat _ lp -> lpatternContainsSplice lp
-          AsPat _ _ _ lp  -> lpatternContainsSplice lp
-          ParPat _ _ lp _ -> lpatternContainsSplice lp
-          ViewPat _ _ lp -> lpatternContainsSplice lp
-          SigPat _ lp _  -> lpatternContainsSplice lp
-          ListPat _ lps  -> any lpatternContainsSplice lps
-          TuplePat _ lps _ -> any lpatternContainsSplice lps
-          SumPat _ lp _ _ -> lpatternContainsSplice lp
-          ConPat _ _ cpd  -> any lpatternContainsSplice (hsConPatArgs cpd)
-          XPat (HsPatExpanded _orig new) -> patternContainsSplice new
-
-{- Note [Pattern bindings that bind no variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Generally, we want to warn about pattern bindings like
-  Just _ = e
-because they don't do anything!  But we have three exceptions:
-
-(1) A wildcard pattern
-       _ = rhs
-  which (a) is not that different from  _v = rhs
-        (b) is sometimes used to give a type sig for,
-            or an occurrence of, a variable on the RHS
-
-(2) A strict pattern binding; that is, one with an outermost bang
-     !Just _ = e
-  This can fail, so unlike the lazy variant, it is not a no-op.
-  Moreover, #13646 argues that even for single constructor
-  types, you might want to write the constructor.  See also #9127.
-
-(3) A splice pattern
-      $(th-lhs) = rhs
-   It is impossible to determine whether or not th-lhs really
-   binds any variable. You have to recurse all the way into the pattern to check
-   it doesn't contain any splices like this. See #22057.
-
-Note [Free-variable space leak]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We have
-    fvs' = trim fvs
-and we seq fvs' before turning it as part of a record.
-
-The reason is that trim is sometimes something like
-    \xs -> intersectNameSet (mkNameSet bound_names) xs
-and we don't want to retain the list bound_names. This showed up in
-trac ticket #1136.
--}
-
-{- *********************************************************************
-*                                                                      *
-          Dependency analysis and other support functions
-*                                                                      *
-********************************************************************* -}
-
-depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses)
-             -> ([(RecFlag, LHsBinds GhcRn)], DefUses)
--- Dependency analysis; this is important so that
--- unused-binding reporting is accurate
-depAnalBinds binds_w_dus
-  = (map get_binds sccs, toOL $ map get_du sccs)
-  where
-    sccs = depAnal (\(_, defs, _) -> defs)
-                   (\(_, _, uses) -> nonDetEltsUniqSet uses)
-                   -- It's OK to use nonDetEltsUniqSet here as explained in
-                   -- Note [depAnal determinism] in GHC.Types.Name.Env.
-                   (bagToList binds_w_dus)
-
-    get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)
-    get_binds (CyclicSCC  binds_w_dus)  = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus])
-
-    get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)
-    get_du (CyclicSCC  binds_w_dus)      = (Just defs, uses)
-        where
-          defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]
-          uses = unionNameSets [u | (_,_,u) <- binds_w_dus]
-
----------------------
--- Bind the top-level forall'd type variables in the sigs.
--- E.g  f :: forall a. a -> a
---      f = rhs
---      The 'a' scopes over the rhs
---
--- NB: there'll usually be just one (for a function binding)
---     but if there are many, one may shadow the rest; too bad!
---      e.g  x :: forall a. [a] -> [a]
---           y :: forall a. [(a,a)] -> a
---           (x,y) = e
---      In e, 'a' will be in scope, and it'll be the one from 'y'!
-
-mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name])
--- Return a lookup function that maps an Id Name to the names
--- of the type variables that should scope over its body.
-mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` []
-  where
-    env = mkHsSigEnv get_scoped_tvs sigs
-
-    get_scoped_tvs :: LSig GhcRn -> Maybe ([LocatedN Name], [Name])
-    -- Returns (binders, scoped tvs for those binders)
-    get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty))
-      = Just (names, hsScopedTvs sig_ty)
-    get_scoped_tvs (L _ (TypeSig _ names sig_ty))
-      = Just (names, hsWcScopedTvs sig_ty)
-    get_scoped_tvs (L _ (PatSynSig _ names sig_ty))
-      = Just (names, hsScopedTvs sig_ty)
-    get_scoped_tvs _ = Nothing
-
--- Process the fixity declarations, making a FastString -> (Located Fixity) map
--- (We keep the location around for reporting duplicate fixity declarations.)
---
--- Checks for duplicates, but not that only locally defined things are fixed.
--- Note: for local fixity declarations, duplicates would also be checked in
---       check_sigs below.  But we also use this function at the top level.
-
-makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv
-
-makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
- where
-   add_one_sig :: MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv
-   add_one_sig env (L loc (FixitySig _ names fixity)) =
-     foldlM add_one env [ (locA loc,locA name_loc,name,fixity)
-                        | L name_loc name <- names ]
-
-   add_one env (loc, name_loc, name,fixity) = do
-     { -- this fixity decl is a duplicate iff
-       -- the ReaderName's OccName's FastString is already in the env
-       -- (we only need to check the local fix_env because
-       --  definitions of non-local will be caught elsewhere)
-       let { fs = occNameFS (rdrNameOcc name)
-           ; fix_item = L loc fixity };
-
-       case lookupFsEnv env fs of
-         Nothing -> return $ extendFsEnv env fs fix_item
-         Just (L loc' _) -> do
-           { setSrcSpan loc $
-             addErrAt name_loc (dupFixityDecl loc' name)
-           ; return env}
-     }
-
-dupFixityDecl :: SrcSpan -> RdrName -> TcRnMessage
-dupFixityDecl loc rdr_name
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),
-          text "also at " <+> ppr loc]
-
-
-{- *********************************************************************
-*                                                                      *
-                Pattern synonym bindings
-*                                                                      *
-********************************************************************* -}
-
-rnPatSynBind :: (Name -> [Name])           -- Signature tyvar function
-             -> PatSynBind GhcRn GhcPs
-             -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses)
-rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
-                              , psb_args = details
-                              , psb_def = pat
-                              , psb_dir = dir })
-       -- invariant: no free vars here when it's a FunBind
-  = do  { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms
-        ; unless pattern_synonym_ok (addErr patternSynonymErr)
-        ; let scoped_tvs = sig_fn name
-
-        ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $
-                                      rnPat PatSyn pat $ \pat' ->
-         -- We check the 'RdrName's instead of the 'Name's
-         -- so that the binding locations are reported
-         -- from the left-hand side
-            case details of
-               PrefixCon _ vars ->
-                   do { checkDupRdrNamesN vars
-                      ; names <- mapM lookupPatSynBndr vars
-                      ; return ( (pat', PrefixCon noTypeArgs names)
-                               , mkFVs (map unLoc names)) }
-               InfixCon var1 var2 ->
-                   do { checkDupRdrNames [var1, var2]
-                      ; name1 <- lookupPatSynBndr var1
-                      ; name2 <- lookupPatSynBndr var2
-                      -- ; checkPrecMatch -- TODO
-                      ; return ( (pat', InfixCon name1 name2)
-                               , mkFVs (map unLoc [name1, name2])) }
-               RecCon vars ->
-                   do { checkDupRdrNames (map (foLabel . recordPatSynField) vars)
-                      ; fls <- lookupConstructorFields name
-                      ; let fld_env = mkFsEnv [ (field_label $ flLabel fl, fl) | fl <- fls ]
-                      ; let rnRecordPatSynField
-                              (RecordPatSynField { recordPatSynField  = visible
-                                                 , recordPatSynPatVar = hidden })
-                              = do { let visible' = lookupField fld_env visible
-                                   ; hidden'  <- lookupPatSynBndr hidden
-                                   ; return $ RecordPatSynField { recordPatSynField  = visible'
-                                                                , recordPatSynPatVar = hidden' } }
-                      ; names <- mapM rnRecordPatSynField  vars
-                      ; return ( (pat', RecCon names)
-                               , mkFVs (map (unLoc . recordPatSynPatVar) names)) }
-
-        ; (dir', fvs2) <- case dir of
-            Unidirectional -> return (Unidirectional, emptyFVs)
-            ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)
-            ExplicitBidirectional mg ->
-                do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $
-                                   rnMatchGroup (mkPrefixFunRhs (L l name))
-                                                rnLExpr mg
-                   ; return (ExplicitBidirectional mg', fvs) }
-
-        ; mod <- getModule
-        ; let fvs = fvs1 `plusFV` fvs2
-              fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs
-                -- Keep locally-defined Names
-                -- As well as dependency analysis, we need these for the
-                -- MonoLocalBinds test in GHC.Tc.Gen.Bind.decideGeneralisationPlan
-
-              bind' = bind{ psb_args = details'
-                          , psb_def = pat'
-                          , psb_dir = dir'
-                          , psb_ext = fvs' }
-              selector_names = case details' of
-                                 RecCon names ->
-                                  map (foExt . recordPatSynField) names
-                                 _ -> []
-
-        ; fvs' `seq` -- See Note [Free-variable space leak]
-          return (bind', name : selector_names , fvs1)
-          -- Why fvs1?  See Note [Pattern synonym builders don't yield dependencies]
-      }
-  where
-    -- See Note [Renaming pattern synonym variables]
-    lookupPatSynBndr = wrapLocMA lookupLocalOccRn
-
-    patternSynonymErr :: TcRnMessage
-    patternSynonymErr
-      = mkTcRnUnknownMessage $ mkPlainError noHints $
-        hang (text "Illegal pattern synonym declaration")
-           2 (text "Use -XPatternSynonyms to enable this extension")
-
-{-
-Note [Renaming pattern synonym variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-We rename pattern synonym declarations backwards to normal to reuse
-the logic already implemented for renaming patterns.
-
-We first rename the RHS of a declaration which brings into
-scope the variables bound by the pattern (as they would be
-in normal function definitions). We then lookup the variables
-which we want to bind in this local environment.
-
-It is crucial that we then only lookup in the *local* environment which
-only contains the variables brought into scope by the pattern and nothing
-else. Amazingly no-one encountered this bug for 3 GHC versions but
-it was possible to define a pattern synonym which referenced global
-identifiers and worked correctly.
-
-```
-x = 5
-
-pattern P :: Int -> ()
-pattern P x <- _
-
-f (P x) = x
-
-> f () = 5
-```
-
-See #13470 for the original report.
-
-Note [Pattern synonym builders don't yield dependencies]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When renaming a pattern synonym that has an explicit builder,
-references in the builder definition should not be used when
-calculating dependencies. For example, consider the following pattern
-synonym definition:
-
-pattern P x <- C1 x where
-  P x = f (C1 x)
-
-f (P x) = C2 x
-
-In this case, 'P' needs to be typechecked in two passes:
-
-1. Typecheck the pattern definition of 'P', which fully determines the
-   type of 'P'. This step doesn't require knowing anything about 'f',
-   since the builder definition is not looked at.
-
-2. Typecheck the builder definition, which needs the typechecked
-   definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind
-   in GHC.Tc.Gen.Bind.tcValBinds.
-
-This behaviour is implemented in 'tcValBinds', but it crucially
-depends on 'P' not being put in a recursive group with 'f' (which
-would make it look like a recursive pattern synonym a la 'pattern P =
-P' which is unsound and rejected).
-
-So:
- * We do not include builder fvs in the Uses returned by rnPatSynBind
-   (which is then used for dependency analysis)
- * But we /do/ include them in the psb_fvs for the PatSynBind
- * In rnValBinds we record these builder uses, to avoid bogus
-   unused-variable warnings (#12548)
--}
-
-{- *********************************************************************
-*                                                                      *
-                Class/instance method bindings
-*                                                                      *
-********************************************************************* -}
-
-{- @rnMethodBinds@ is used for the method bindings of a class and an instance
-declaration.   Like @rnBinds@ but without dependency analysis.
-
-NOTA BENE: we record each {\em binder} of a method-bind group as a free variable.
-That's crucial when dealing with an instance decl:
-\begin{verbatim}
-        instance Foo (T a) where
-           op x = ...
-\end{verbatim}
-This might be the {\em sole} occurrence of @op@ for an imported class @Foo@,
-and unless @op@ occurs we won't treat the type signature of @op@ in the class
-decl for @Foo@ as a source of instance-decl gates.  But we should!  Indeed,
-in many ways the @op@ in an instance decl is just like an occurrence, not
-a binder.
--}
-
-rnMethodBinds :: Bool                   -- True <=> is a class declaration
-              -> Name                   -- Class name
-              -> [Name]                 -- Type variables from the class/instance header
-              -> LHsBinds GhcPs         -- Binds
-              -> [LSig GhcPs]           -- and signatures/pragmas
-              -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars)
--- Used for
---   * the default method bindings in a class decl
---   * the method bindings in an instance decl
-rnMethodBinds is_cls_decl cls ktv_names binds sigs
-  = do { checkDupRdrNamesN (collectMethodBinders binds)
-             -- Check that the same method is not given twice in the
-             -- same instance decl      instance C T where
-             --                       f x = ...
-             --                       g y = ...
-             --                       f x = ...
-             -- We must use checkDupRdrNames because the Name of the
-             -- method is the Name of the class selector, whose SrcSpan
-             -- points to the class declaration; and we use rnMethodBinds
-             -- for instance decls too
-
-       -- Rename the bindings LHSs
-       ; binds' <- foldrM (rnMethodBindLHS is_cls_decl cls) emptyBag binds
-
-       -- Rename the pragmas and signatures
-       -- Annoyingly the type variables /are/ in scope for signatures, but
-       -- /are not/ in scope in the SPECIALISE instance pramas; e.g.
-       --    instance Eq a => Eq (T a) where
-       --       (==) :: a -> a -> a
-       --       {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
-       ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs
-             bound_nms = mkNameSet (collectHsBindsBinders CollNoDictBinders binds')
-             sig_ctxt | is_cls_decl = ClsDeclCtxt cls
-                      | otherwise   = InstDeclCtxt bound_nms
-       ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags
-       ; (other_sigs',      sig_fvs) <- bindLocalNamesFV ktv_names $
-                                        renameSigs sig_ctxt other_sigs
-
-       -- Rename the bindings RHSs.  Again there's an issue about whether the
-       -- type variables from the class/instance head are in scope.
-       -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables
-       ; (binds'', bind_fvs) <- bindSigTyVarsFV ktv_names $
-              do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds'
-                 ; let bind_fvs = foldr (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)
-                                           emptyFVs binds_w_dus
-                 ; return (mapBag fstOf3 binds_w_dus, bind_fvs) }
-
-       ; return ( binds'', spec_inst_prags' ++ other_sigs'
-                , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) }
-
-rnMethodBindLHS :: Bool -> Name
-                -> LHsBindLR GhcPs GhcPs
-                -> LHsBindsLR GhcRn GhcPs
-                -> RnM (LHsBindsLR GhcRn GhcPs)
-rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest
-  = setSrcSpanA loc $ do
-    do { sel_name <- wrapLocMA (lookupInstDeclBndr cls (text "method")) name
-                     -- We use the selector name as the binder
-       ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField }
-       ; return (L loc bind' `consBag` rest ) }
-
--- Report error for all other forms of bindings
--- This is why we use a fold rather than map
-rnMethodBindLHS is_cls_decl _ (L loc bind) rest
-  = do { addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-         vcat [ what <+> text "not allowed in" <+> decl_sort
-              , nest 2 (ppr bind) ]
-       ; return rest }
-  where
-    decl_sort | is_cls_decl = text "class declaration:"
-              | otherwise   = text "instance declaration:"
-    what = case bind of
-              PatBind {}    -> text "Pattern bindings (except simple variables)"
-              PatSynBind {} -> text "Pattern synonyms"
-                               -- Associated pattern synonyms are not implemented yet
-              _ -> pprPanic "rnMethodBind" (ppr bind)
-
-{-
-************************************************************************
-*                                                                      *
-\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
-*                                                                      *
-************************************************************************
-
-@renameSigs@ checks for:
-\begin{enumerate}
-\item more than one sig for one thing;
-\item signatures given for things not bound here;
-\end{enumerate}
-
-At the moment we don't gather free-var info from the types in
-signatures.  We'd only need this if we wanted to report unused tyvars.
--}
-
-renameSigs :: HsSigCtxt
-           -> [LSig GhcPs]
-           -> RnM ([LSig GhcRn], FreeVars)
--- Renames the signatures and performs error checks
-renameSigs ctxt sigs
-  = do  { mapM_ dupSigDeclErr (findDupSigs sigs)
-
-        ; checkDupMinimalSigs sigs
-
-        ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstMA (renameSig ctxt)) sigs
-
-        ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
-        ; mapM_ misplacedSigErr bad_sigs                 -- Misplaced
-
-        ; return (good_sigs, sig_fvs) }
-
-----------------------
--- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
--- because this won't work for:
---      instance Foo T where
---        {-# INLINE op #-}
---        Baz.op = ...
--- We'll just rename the INLINE prag to refer to whatever other 'op'
--- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)
--- Doesn't seem worth much trouble to sort this.
-
-renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)
-renameSig ctxt sig@(TypeSig _ vs ty)
-  = do  { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs
-        ; let doc = TypeSigCtx (ppr_sig_bndrs vs)
-        ; (new_ty, fvs) <- rnHsSigWcType doc ty
-        ; return (TypeSig noAnn new_vs new_ty, fvs) }
-
-renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
-  = do  { defaultSigs_on <- xoptM LangExt.DefaultSignatures
-        ; when (is_deflt && not defaultSigs_on) $
-          addErr (defaultSigErr sig)
-        ; mapM_ warnForallIdentifier vs
-        ; new_v <- mapM (lookupSigOccRnN ctxt sig) vs
-        ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty
-        ; return (ClassOpSig noAnn is_deflt new_v new_ty, fvs) }
-  where
-    (v1:_) = vs
-    ty_ctxt = GenericCtx (text "a class method signature for"
-                          <+> quotes (ppr v1))
-
-renameSig _ (SpecInstSig (_, src) ty)
-  = do  { checkInferredVars doc inf_msg ty
-        ; (new_ty, fvs) <- rnHsSigType doc TypeLevel ty
-          -- Check if there are any nested `forall`s or contexts, which are
-          -- illegal in the type of an instance declaration (see
-          -- Note [No nested foralls or contexts in instance types] in
-          -- GHC.Hs.Type).
-        ; addNoNestedForallsContextsErr doc (text "SPECIALISE instance type")
-            (getLHsInstDeclHead new_ty)
-        ; return (SpecInstSig (noAnn, src) new_ty,fvs) }
-  where
-    doc = SpecInstSigCtx
-    inf_msg = Just (text "Inferred type variables are not allowed")
-
--- {-# SPECIALISE #-} pragmas can refer to imported Ids
--- so, in the top-level case (when mb_names is Nothing)
--- we use lookupOccRn.  If there's both an imported and a local 'f'
--- then the SPECIALISE pragma is ambiguous, unlike all other signatures
-renameSig ctxt sig@(SpecSig _ v tys inl)
-  = do  { new_v <- case ctxt of
-                     TopSigCtxt {} -> lookupLocatedOccRn v
-                     _             -> lookupSigOccRnN ctxt sig v
-        ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys
-        ; return (SpecSig noAnn new_v new_ty inl, fvs) }
-  where
-    ty_ctxt = GenericCtx (text "a SPECIALISE signature for"
-                          <+> quotes (ppr v))
-    do_one (tys,fvs) ty
-      = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty
-           ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
-
-renameSig ctxt sig@(InlineSig _ v s)
-  = do  { new_v <- lookupSigOccRnN ctxt sig v
-        ; return (InlineSig noAnn new_v s, emptyFVs) }
-
-renameSig ctxt (FixSig _ fsig)
-  = do  { new_fsig <- rnSrcFixityDecl ctxt fsig
-        ; return (FixSig noAnn new_fsig, emptyFVs) }
-
-renameSig ctxt sig@(MinimalSig (_, s) (L l bf))
-  = do new_bf <- traverse (lookupSigOccRnN ctxt sig) bf
-       return (MinimalSig (noAnn, s) (L l new_bf), emptyFVs)
-
-renameSig ctxt sig@(PatSynSig _ vs ty)
-  = do  { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs
-        ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty
-        ; return (PatSynSig noAnn new_vs ty', fvs) }
-  where
-    ty_ctxt = GenericCtx (text "a pattern synonym signature for"
-                          <+> ppr_sig_bndrs vs)
-
-renameSig ctxt sig@(SCCFunSig (_, st) v s)
-  = do  { new_v <- lookupSigOccRnN ctxt sig v
-        ; return (SCCFunSig (noAnn, st) new_v s, emptyFVs) }
-
--- COMPLETE Sigs can refer to imported IDs which is why we use
--- lookupLocatedOccRn rather than lookupSigOccRn
-renameSig _ctxt sig@(CompleteMatchSig (_, s) (L l bf) mty)
-  = do new_bf <- traverse lookupLocatedOccRn bf
-       new_mty  <- traverse lookupLocatedOccRn mty
-
-       this_mod <- fmap tcg_mod getGblEnv
-       unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $
-         -- Why 'any'? See Note [Orphan COMPLETE pragmas]
-         addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError
-
-       return (CompleteMatchSig (noAnn, s) (L l new_bf) new_mty, emptyFVs)
-  where
-    orphanError :: TcRnMessage
-    orphanError = mkTcRnUnknownMessage $ mkPlainError noHints $
-      text "Orphan COMPLETE pragmas not supported" $$
-      text "A COMPLETE pragma must mention at least one data constructor" $$
-      text "or pattern synonym defined in the same module."
-
-{-
-Note [Orphan COMPLETE pragmas]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We define a COMPLETE pragma to be a non-orphan if it includes at least
-one conlike defined in the current module. Why is this sufficient?
-Well if you have a pattern match
-
-  case expr of
-    P1 -> ...
-    P2 -> ...
-    P3 -> ...
-
-any COMPLETE pragma which mentions a conlike other than P1, P2 or P3
-will not be of any use in verifying that the pattern match is
-exhaustive. So as we have certainly read the interface files that
-define P1, P2 and P3, we will have loaded all non-orphan COMPLETE
-pragmas that could be relevant to this pattern match.
-
-For now we simply disallow orphan COMPLETE pragmas, as the added
-complexity of supporting them properly doesn't seem worthwhile.
--}
-
-ppr_sig_bndrs :: [LocatedN RdrName] -> SDoc
-ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
-
-okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool
-okHsSig ctxt (L _ sig)
-  = case (sig, ctxt) of
-     (ClassOpSig {}, ClsDeclCtxt {})  -> True
-     (ClassOpSig {}, InstDeclCtxt {}) -> True
-     (ClassOpSig {}, _)               -> False
-
-     (TypeSig {}, ClsDeclCtxt {})  -> False
-     (TypeSig {}, InstDeclCtxt {}) -> False
-     (TypeSig {}, _)               -> True
-
-     (PatSynSig {}, TopSigCtxt{}) -> True
-     (PatSynSig {}, _)            -> False
-
-     (FixSig {}, InstDeclCtxt {}) -> False
-     (FixSig {}, _)               -> True
-
-     (InlineSig {}, HsBootCtxt {}) -> False
-     (InlineSig {}, _)             -> True
-
-     (SpecSig {}, TopSigCtxt {})    -> True
-     (SpecSig {}, LocalBindCtxt {}) -> True
-     (SpecSig {}, InstDeclCtxt {})  -> True
-     (SpecSig {}, _)                -> False
-
-     (SpecInstSig {}, InstDeclCtxt {}) -> True
-     (SpecInstSig {}, _)               -> False
-
-     (MinimalSig {}, ClsDeclCtxt {}) -> True
-     (MinimalSig {}, _)              -> False
-
-     (SCCFunSig {}, HsBootCtxt {}) -> False
-     (SCCFunSig {}, _)             -> True
-
-     (CompleteMatchSig {}, TopSigCtxt {} ) -> True
-     (CompleteMatchSig {}, _)              -> False
-
-     (XSig {}, TopSigCtxt {})   -> True
-     (XSig {}, InstDeclCtxt {}) -> True
-     (XSig {}, _)               -> False
-
-
--------------------
-findDupSigs :: [LSig GhcPs] -> [NonEmpty (LocatedN RdrName, Sig GhcPs)]
--- Check for duplicates on RdrName version,
--- because renamed version has unboundName for
--- not-in-scope binders, which gives bogus dup-sig errors
--- NB: in a class decl, a 'generic' sig is not considered
---     equal to an ordinary sig, so we allow, say
---           class C a where
---             op :: a -> a
---             default op :: Eq a => a -> a
-findDupSigs sigs
-  = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)
-  where
-    expand_sig :: Sig GhcPs -> [(LocatedN RdrName, Sig GhcPs)] -- AZ
-    expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig)
-    expand_sig sig@(InlineSig _ n _)             = [(n,sig)]
-    expand_sig sig@(TypeSig _ ns _)              = [(n,sig) | n <- ns]
-    expand_sig sig@(ClassOpSig _ _ ns _)         = [(n,sig) | n <- ns]
-    expand_sig sig@(PatSynSig _ ns  _ )          = [(n,sig) | n <- ns]
-    expand_sig sig@(SCCFunSig (_, _) n _)           = [(n,sig)]
-    expand_sig _ = []
-
-    matching_sig :: (LocatedN RdrName, Sig GhcPs) -> (LocatedN RdrName, Sig GhcPs) -> Bool --AZ
-    matching_sig (L _ n1,sig1) (L _ n2,sig2)       = n1 == n2 && mtch sig1 sig2
-    mtch (FixSig {})           (FixSig {})         = True
-    mtch (InlineSig {})        (InlineSig {})      = True
-    mtch (TypeSig {})          (TypeSig {})        = True
-    mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2
-    mtch (PatSynSig _ _ _)     (PatSynSig _ _ _)   = True
-    mtch (SCCFunSig{})         (SCCFunSig{})       = True
-    mtch _ _ = False
-
--- Warn about multiple MINIMAL signatures
-checkDupMinimalSigs :: [LSig GhcPs] -> RnM ()
-checkDupMinimalSigs sigs
-  = case filter isMinimalLSig sigs of
-      minSigs@(_:_:_) -> dupMinimalSigErr minSigs
-      _ -> return ()
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Match}
-*                                                                      *
-************************************************************************
--}
-
-type AnnoBody body
-  = ( Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL
-    , Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL
-    , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
-    , Anno (Match GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
-    , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns
-    , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcAnn NoEpAnns
-    , Outputable (body GhcPs)
-    )
-
--- Note [Empty MatchGroups]
--- ~~~~~~~~~~~~~~~~~~~~~~~~
--- In some cases, MatchGroups are allowed to be empty. Firstly, the
--- prerequisite is that -XEmptyCase is enabled. Then you have an empty
--- MatchGroup resulting either from a case-expression:
---
---     case e of {}
---
--- or from a \case-expression:
---
---     \case {}
---
--- NB: \cases {} is not allowed, since it's not clear how many patterns this
--- should match on.
---
--- The same applies in arrow notation commands: With -XEmptyCases, it is
--- allowed in case- and \case-commands, but not \cases.
---
--- Since the lambda expressions and empty function definitions are already
--- disallowed elsewhere, here, we only need to make sure we don't accept empty
--- \cases expressions or commands. In that case, or if we encounter an empty
--- MatchGroup but -XEmptyCases is disabled, we add an error.
-
-rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContext GhcRn
-             -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-             -> MatchGroup GhcPs (LocatedA (body GhcPs))
-             -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)
-rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_ext = origin })
-         -- see Note [Empty MatchGroups]
-  = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (emptyCaseErr ctxt))
-       ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
-       ; return (mkMatchGroup origin (L lm new_ms), ms_fvs) }
-  where
-    mustn't_be_empty = case ctxt of
-      LamCaseAlt LamCases -> return True
-      ArrowMatchCtxt (ArrowLamCaseAlt LamCases) -> return True
-      _ -> not <$> xoptM LangExt.EmptyCase
-
-rnMatch :: AnnoBody body
-        => HsMatchContext GhcRn
-        -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-        -> LMatch GhcPs (LocatedA (body GhcPs))
-        -> RnM (LMatch GhcRn (LocatedA (body GhcRn)), FreeVars)
-rnMatch ctxt rnBody = wrapLocFstMA (rnMatch' ctxt rnBody)
-
-rnMatch' :: (AnnoBody body)
-         => HsMatchContext GhcRn
-         -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-         -> Match GhcPs (LocatedA (body GhcPs))
-         -> RnM (Match GhcRn (LocatedA (body GhcRn)), FreeVars)
-rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
-  = rnPats ctxt pats $ \ pats' -> do
-        { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
-        ; let mf' = case (ctxt, mf) of
-                      (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })
-                                            -> mf { mc_fun = L lf funid }
-                      _                     -> ctxt
-        ; return (Match { m_ext = noAnn, m_ctxt = mf', m_pats = pats'
-                        , m_grhss = grhss'}, grhss_fvs ) }
-
-emptyCaseErr :: HsMatchContext GhcRn -> TcRnMessage
-emptyCaseErr ctxt = mkTcRnUnknownMessage $ mkPlainError noHints $ message ctxt
-  where
-    pp_ctxt :: HsMatchContext GhcRn -> SDoc
-    pp_ctxt c = case c of
-      CaseAlt                                  -> text "case expression"
-      LamCaseAlt LamCase                       -> text "\\case expression"
-      ArrowMatchCtxt (ArrowLamCaseAlt LamCase) -> text "\\case command"
-      ArrowMatchCtxt ArrowCaseAlt              -> text "case command"
-      ArrowMatchCtxt KappaExpr                 -> text "kappa abstraction"
-      _                                        -> text "(unexpected)"
-                                                  <+> pprMatchContextNoun c
-
-    message :: HsMatchContext GhcRn -> SDoc
-    message (LamCaseAlt LamCases) = lcases_msg <+> text "expression"
-    message (ArrowMatchCtxt (ArrowLamCaseAlt LamCases)) =
-      lcases_msg <+> text "command"
-    message ctxt =
-      hang (text "Empty list of alternatives in" <+> pp_ctxt ctxt)
-           2 (text "Use EmptyCase to allow this")
-
-    lcases_msg =
-      text "Empty list of alternatives is not allowed in \\cases"
-
-{-
-************************************************************************
-*                                                                      *
-\subsubsection{Guarded right-hand sides (GRHSs)}
-*                                                                      *
-************************************************************************
--}
-
-rnGRHSs :: AnnoBody body
-        => HsMatchContext GhcRn
-        -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-        -> GRHSs GhcPs (LocatedA (body GhcPs))
-        -> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), FreeVars)
-rnGRHSs ctxt rnBody (GRHSs _ grhss binds)
-  = rnLocalBindsAndThen binds   $ \ binds' _ -> do
-    (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss
-    return (GRHSs emptyComments grhss' binds', fvGRHSs)
-
-rnGRHS :: AnnoBody body
-       => HsMatchContext GhcRn
-       -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-       -> LGRHS GhcPs (LocatedA (body GhcPs))
-       -> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars)
-rnGRHS ctxt rnBody = wrapLocFstMA (rnGRHS' ctxt rnBody)
-
-rnGRHS' :: HsMatchContext GhcRn
-        -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))
-        -> GRHS GhcPs (LocatedA (body GhcPs))
-        -> RnM (GRHS GhcRn (LocatedA (body GhcRn)), FreeVars)
-rnGRHS' ctxt rnBody (GRHS _ guards rhs)
-  = do  { pattern_guards_allowed <- xoptM LangExt.PatternGuards
-        ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnExpr guards $ \ _ ->
-                                    rnBody rhs
-
-        ; unless (pattern_guards_allowed || is_standard_guard guards') $
-            let diag = mkTcRnUnknownMessage $
-                  mkPlainDiagnostic WarningWithoutFlag noHints (nonStdGuardErr guards')
-            in addDiagnostic diag
-
-        ; return (GRHS noAnn guards' rhs', fvs) }
-  where
-        -- Standard Haskell 1.4 guards are just a single boolean
-        -- expression, rather than a list of qualifiers as in the
-        -- Glasgow extension
-    is_standard_guard []                  = True
-    is_standard_guard [L _ (BodyStmt {})] = True
-    is_standard_guard _                   = False
-
-{-
-*********************************************************
-*                                                       *
-        Source-code fixity declarations
-*                                                       *
-*********************************************************
--}
-
-rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn)
--- Rename a fixity decl, so we can put
--- the renamed decl in the renamed syntax tree
--- Errors if the thing being fixed is not defined locally.
-rnSrcFixityDecl sig_ctxt = rn_decl
-  where
-    rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn)
-        -- GHC extension: look up both the tycon and data con
-        -- for con-like things; hence returning a list
-        -- If neither are in scope, report an error; otherwise
-        -- return a fixity sig for each (slightly odd)
-    rn_decl (FixitySig _ fnames fixity)
-      = do names <- concatMapM lookup_one fnames
-           return (FixitySig noExtField names fixity)
-
-    lookup_one :: LocatedN RdrName -> RnM [LocatedN Name]
-    lookup_one (L name_loc rdr_name)
-      = setSrcSpanA name_loc $
-                    -- This lookup will fail if the name is not defined in the
-                    -- same binding group as this fixity declaration.
-        do names <- lookupLocalTcNames sig_ctxt what rdr_name
-           return [ L name_loc name | (_, name) <- names ]
-    what = text "fixity signature"
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Error messages}
-*                                                                      *
-************************************************************************
--}
-
-dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> RnM ()
-dupSigDeclErr pairs@((L loc name, sig) :| _)
-  = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [ text "Duplicate" <+> what_it_is
-           <> text "s for" <+> quotes (ppr name)
-         , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest
-                                       $ map (getLocA . fst)
-                                       $ toList pairs)
-         ]
-  where
-    what_it_is = hsSigDoc sig
-
-misplacedSigErr :: LSig GhcRn -> RnM ()
-misplacedSigErr (L loc sig)
-  = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig]
-
-defaultSigErr :: Sig GhcPs -> TcRnMessage
-defaultSigErr sig = mkTcRnUnknownMessage $ mkPlainError noHints $
-  vcat [ hang (text "Unexpected default signature:")
-         2 (ppr sig)
-       , text "Use DefaultSignatures to enable default signatures" ]
-
-bindInHsBootFileErr :: LHsBindLR GhcRn GhcPs -> RnM ()
-bindInHsBootFileErr (L loc _)
-  = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-      vcat [ text "Bindings in hs-boot files are not allowed" ]
-
-nonStdGuardErr :: (Outputable body,
-                   Anno (Stmt GhcRn body) ~ SrcSpanAnnA)
-               => [LStmtLR GhcRn GhcRn body] -> SDoc
-nonStdGuardErr guards
-  = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)")
-       4 (interpp'SP guards)
-
-dupMinimalSigErr :: [LSig GhcPs] -> RnM ()
-dupMinimalSigErr sigs@(L loc _ : _)
-  = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [ text "Multiple minimal complete definitions"
-         , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLocA sigs)
-         , text "Combine alternative minimal complete definitions with `|'" ]
-dupMinimalSigErr [] = panic "dupMinimalSigErr"
diff --git a/compiler/GHC/Rename/Doc.hs b/compiler/GHC/Rename/Doc.hs
deleted file mode 100644
--- a/compiler/GHC/Rename/Doc.hs
+++ /dev/null
@@ -1,46 +0,0 @@
-module GHC.Rename.Doc ( rnHsDoc, rnLHsDoc, rnLDocDecl, rnDocDecl ) where
-
-import GHC.Prelude
-
-import GHC.Tc.Types
-import GHC.Hs
-import GHC.Types.Name.Reader
-import GHC.Types.Name
-import GHC.Types.SrcLoc
-import GHC.Tc.Utils.Monad (getGblEnv)
-import GHC.Types.Avail
-import GHC.Rename.Env
-
-rnLHsDoc :: LHsDoc GhcPs -> RnM (LHsDoc GhcRn)
-rnLHsDoc = traverse rnHsDoc
-
-rnLDocDecl :: LDocDecl GhcPs -> RnM (LDocDecl GhcRn)
-rnLDocDecl = traverse rnDocDecl
-
-rnDocDecl :: DocDecl GhcPs -> RnM (DocDecl GhcRn)
-rnDocDecl (DocCommentNext doc) = do
-  doc' <- rnLHsDoc doc
-  pure $ (DocCommentNext doc')
-rnDocDecl (DocCommentPrev doc) = do
-  doc' <- rnLHsDoc doc
-  pure $ (DocCommentPrev doc')
-rnDocDecl (DocCommentNamed n doc) = do
-  doc' <- rnLHsDoc doc
-  pure $ (DocCommentNamed n doc')
-rnDocDecl (DocGroup i doc) = do
-  doc' <- rnLHsDoc doc
-  pure $ (DocGroup i doc')
-
-rnHsDoc :: WithHsDocIdentifiers a GhcPs -> RnM (WithHsDocIdentifiers a GhcRn)
-rnHsDoc (WithHsDocIdentifiers s ids) = do
-  gre <- tcg_rdr_env <$> getGblEnv
-  pure (WithHsDocIdentifiers s (rnHsDocIdentifiers gre ids))
-
-rnHsDocIdentifiers :: GlobalRdrEnv
-                  -> [Located RdrName]
-                  -> [Located Name]
-rnHsDocIdentifiers gre ns = concat
-  [ map (L l . greNamePrintableName . gre_name) (lookupGRE_RdrName c gre)
-  | L l rdr_name <- ns
-  , c <- dataTcOccs rdr_name
-  ]
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
deleted file mode 100644
--- a/compiler/GHC/Rename/Env.hs
+++ /dev/null
@@ -1,2090 +0,0 @@
-
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE TypeApplications #-}
-
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-2006
-
-GHC.Rename.Env contains functions which convert RdrNames into Names.
-
--}
-
-module GHC.Rename.Env (
-        newTopSrcBinder,
-
-        lookupLocatedTopBndrRn, lookupLocatedTopBndrRnN, lookupTopBndrRn,
-        lookupLocatedTopConstructorRn, lookupLocatedTopConstructorRnN,
-
-        lookupLocatedOccRn, lookupLocatedOccRnConstr, lookupLocatedOccRnRecField,
-        lookupLocatedOccRnNone,
-        lookupOccRn, lookupOccRn_maybe,
-        lookupLocalOccRn_maybe, lookupInfoOccRn,
-        lookupLocalOccThLvl_maybe, lookupLocalOccRn,
-        lookupTypeOccRn,
-        lookupGlobalOccRn, lookupGlobalOccRn_maybe,
-
-        AmbiguousResult(..),
-        lookupExprOccRn,
-        lookupRecFieldOcc,
-        lookupRecFieldOcc_update,
-
-        ChildLookupResult(..),
-        lookupSubBndrOcc_helper,
-        combineChildLookupResult, -- Called by lookupChildrenExport
-
-        HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupSigOccRnN,
-        lookupSigCtxtOccRn, lookupSigCtxtOccRnN,
-
-        lookupInstDeclBndr, lookupFamInstName,
-        lookupConstructorFields,
-
-        lookupGreAvailRn,
-
-        -- Rebindable Syntax
-        lookupSyntax, lookupSyntaxExpr, lookupSyntaxNames,
-        lookupSyntaxName,
-        lookupIfThenElse,
-
-        -- QualifiedDo
-        lookupQualifiedDoExpr, lookupQualifiedDo,
-        lookupQualifiedDoName, lookupNameWithQualifier,
-
-        -- Constructing usage information
-        addUsedGRE, addUsedGREs, addUsedDataCons,
-
-
-
-        dataTcOccs, --TODO: Move this somewhere, into utils?
-
-    ) where
-
-import GHC.Prelude
-
-import GHC.Iface.Load   ( loadInterfaceForName, loadSrcInterface_maybe )
-import GHC.Iface.Env
-import GHC.Hs
-import GHC.Types.Name.Reader
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.Monad
-import GHC.Parser.PostProcess ( setRdrNameSpace )
-import GHC.Builtin.Types
-import GHC.Types.Name
-import GHC.Types.Name.Set
-import GHC.Types.Name.Env
-import GHC.Types.Avail
-import GHC.Types.Hint
-import GHC.Types.Error
-import GHC.Unit.Module
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.Warnings  ( WarningTxt )
-import GHC.Core.ConLike
-import GHC.Core.DataCon
-import GHC.Core.TyCon
-import GHC.Builtin.Names( rOOT_MAIN )
-import GHC.Types.Basic  ( TopLevelFlag(..), TupleSort(..) )
-import GHC.Types.SrcLoc as SrcLoc
-import GHC.Utils.Outputable as Outputable
-import GHC.Types.Unique.Set ( uniqSetAny )
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Data.Maybe
-import GHC.Driver.Session
-import GHC.Data.FastString
-import Control.Monad
-import GHC.Data.List.SetOps ( minusList )
-import qualified GHC.LanguageExtensions as LangExt
-import GHC.Rename.Unbound
-import GHC.Rename.Utils
-import qualified Data.Semigroup as Semi
-import Data.Either      ( partitionEithers )
-import Data.List        ( find )
-import qualified Data.List.NonEmpty as NE
-import Control.Arrow    ( first )
-import GHC.Types.FieldLabel
-import GHC.Data.Bag
-import GHC.Types.PkgQual
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-{-
-*********************************************************
-*                                                      *
-                Source-code binders
-*                                                      *
-*********************************************************
-
-Note [Signature lazy interface loading]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-GHC's lazy interface loading can be a bit confusing, so this Note is an
-empirical description of what happens in one interesting case. When
-compiling a signature module against an its implementation, we do NOT
-load interface files associated with its names until after the type
-checking phase.  For example:
-
-    module ASig where
-        data T
-        f :: T -> T
-
-Suppose we compile this with -sig-of "A is ASig":
-
-    module B where
-        data T = T
-        f T = T
-
-    module A(module B) where
-        import B
-
-During type checking, we'll load A.hi because we need to know what the
-RdrEnv for the module is, but we DO NOT load the interface for B.hi!
-It's wholly unnecessary: our local definition 'data T' in ASig is all
-the information we need to finish type checking.  This is contrast to
-type checking of ordinary Haskell files, in which we would not have the
-local definition "data T" and would need to consult B.hi immediately.
-(Also, this situation never occurs for hs-boot files, since you're not
-allowed to reexport from another module.)
-
-After type checking, we then check that the types we provided are
-consistent with the backing implementation (in checkHiBootOrHsigIface).
-At this point, B.hi is loaded, because we need something to compare
-against.
-
-I discovered this behavior when trying to figure out why type class
-instances for Data.Map weren't in the EPS when I was type checking a
-test very much like ASig (sigof02dm): the associated interface hadn't
-been loaded yet!  (The larger issue is a moot point, since an instance
-declared in a signature can never be a duplicate.)
-
-This behavior might change in the future.  Consider this
-alternate module B:
-
-    module B where
-        {-# DEPRECATED T, f "Don't use" #-}
-        data T = T
-        f T = T
-
-One might conceivably want to report deprecation warnings when compiling
-ASig with -sig-of B, in which case we need to look at B.hi to find the
-deprecation warnings during renaming.  At the moment, you don't get any
-warning until you use the identifier further downstream.  This would
-require adjusting addUsedGRE so that during signature compilation,
-we do not report deprecation warnings for LocalDef.  See also
-Note [Handling of deprecations]
--}
-
-newTopSrcBinder :: LocatedN RdrName -> RnM Name
-newTopSrcBinder (L loc rdr_name)
-  | Just name <- isExact_maybe rdr_name
-  =     -- This is here to catch
-        --   (a) Exact-name binders created by Template Haskell
-        --   (b) The PrelBase defn of (say) [] and similar, for which
-        --       the parser reads the special syntax and returns an Exact RdrName
-        -- We are at a binding site for the name, so check first that it
-        -- the current module is the correct one; otherwise GHC can get
-        -- very confused indeed. This test rejects code like
-        --      data T = (,) Int Int
-        -- unless we are in GHC.Tup
-    if isExternalName name then
-      do { this_mod <- getModule
-         ; unless (this_mod == nameModule name)
-                  (addErrAt (locA loc) (badOrigBinding rdr_name))
-         ; return name }
-    else   -- See Note [Binders in Template Haskell] in "GHC.ThToHs"
-      do { this_mod <- getModule
-         ; externaliseName this_mod name }
-
-  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-  = do  { this_mod <- getModule
-        ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
-                 (addErrAt (locA loc) (badOrigBinding rdr_name))
-        -- When reading External Core we get Orig names as binders,
-        -- but they should agree with the module gotten from the monad
-        --
-        -- We can get built-in syntax showing up here too, sadly.  If you type
-        --      data T = (,,,)
-        -- the constructor is parsed as a type, and then GHC.Parser.PostProcess.tyConToDataCon
-        -- uses setRdrNameSpace to make it into a data constructors.  At that point
-        -- the nice Exact name for the TyCon gets swizzled to an Orig name.
-        -- Hence the badOrigBinding error message.
-        --
-        -- Except for the ":Main.main = ..." definition inserted into
-        -- the Main module; ugh!
-
-        -- Because of this latter case, we call newGlobalBinder with a module from
-        -- the RdrName, not from the environment.  In principle, it'd be fine to
-        -- have an arbitrary mixture of external core definitions in a single module,
-        -- (apart from module-initialisation issues, perhaps).
-        ; newGlobalBinder rdr_mod rdr_occ (locA loc) }
-
-  | otherwise
-  = do  { when (isQual rdr_name)
-                 (addErrAt (locA loc) (badQualBndrErr rdr_name))
-                -- Binders should not be qualified; if they are, and with a different
-                -- module name, we get a confusing "M.T is not in scope" error later
-
-        ; stage <- getStage
-        ; if isBrackStage stage then
-                -- We are inside a TH bracket, so make an *Internal* name
-                -- See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names
-             do { uniq <- newUnique
-                ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) }
-          else
-             do { this_mod <- getModule
-                ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr (locA loc))
-                ; newGlobalBinder this_mod (rdrNameOcc rdr_name) (locA loc) }
-        }
-
-{-
-*********************************************************
-*                                                      *
-        Source code occurrences
-*                                                      *
-*********************************************************
-
-Looking up a name in the GHC.Rename.Env.
-
-Note [Type and class operator definitions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We want to reject all of these unless we have -XTypeOperators (#3265)
-   data a :*: b  = ...
-   class a :*: b where ...
-   data (:*:) a b  = ....
-   class (:*:) a b where ...
-The latter two mean that we are not just looking for a
-*syntactically-infix* declaration, but one that uses an operator
-OccName.  We use OccName.isSymOcc to detect that case, which isn't
-terribly efficient, but there seems to be no better way.
--}
-
--- Can be made to not be exposed
--- Only used unwrapped in rnAnnProvenance
-lookupTopBndrRn :: WhatLooking -> RdrName -> RnM Name
--- Look up a top-level source-code binder.   We may be looking up an unqualified 'f',
--- and there may be several imported 'f's too, which must not confuse us.
--- For example, this is OK:
---      import Foo( f )
---      infix 9 f       -- The 'f' here does not need to be qualified
---      f x = x         -- Nor here, of course
--- So we have to filter out the non-local ones.
---
--- A separate function (importsFromLocalDecls) reports duplicate top level
--- decls, so here it's safe just to choose an arbitrary one.
-lookupTopBndrRn which_suggest rdr_name =
-  lookupExactOrOrig rdr_name id $
-    do  {  -- Check for operators in type or class declarations
-           -- See Note [Type and class operator definitions]
-          let occ = rdrNameOcc rdr_name
-        ; when (isTcOcc occ && isSymOcc occ)
-               (do { op_ok <- xoptM LangExt.TypeOperators
-                   ; unless op_ok (addErr (TcRnIllegalTypeOperatorDecl rdr_name)) })
-
-        ; env <- getGlobalRdrEnv
-        ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of
-            [gre] -> return (greMangledName gre)
-            _     -> do -- Ambiguous (can't happen) or unbound
-                        traceRn "lookupTopBndrRN fail" (ppr rdr_name)
-                        unboundName (LF which_suggest WL_LocalTop) rdr_name
-    }
-
-lookupLocatedTopConstructorRn :: Located RdrName -> RnM (Located Name)
-lookupLocatedTopConstructorRn = wrapLocM (lookupTopBndrRn WL_Constructor)
-
-lookupLocatedTopConstructorRnN :: LocatedN RdrName -> RnM (LocatedN Name)
-lookupLocatedTopConstructorRnN = wrapLocMA (lookupTopBndrRn WL_Constructor)
-
-lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)
-lookupLocatedTopBndrRn = wrapLocM (lookupTopBndrRn WL_Anything)
-
-lookupLocatedTopBndrRnN :: LocatedN RdrName -> RnM (LocatedN Name)
-lookupLocatedTopBndrRnN = wrapLocMA (lookupTopBndrRn WL_Anything)
-
--- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].
--- This never adds an error, but it may return one, see
--- Note [Errors in lookup functions]
-lookupExactOcc_either :: Name -> RnM (Either NotInScopeError Name)
-lookupExactOcc_either name
-  | Just thing <- wiredInNameTyThing_maybe name
-  , Just tycon <- case thing of
-                    ATyCon tc                 -> Just tc
-                    AConLike (RealDataCon dc) -> Just (dataConTyCon dc)
-                    _                         -> Nothing
-  , Just tupleSort <- tyConTuple_maybe tycon
-  = do { let tupArity = case tupleSort of
-               -- Unboxed tuples have twice as many arguments because of the
-               -- 'RuntimeRep's (#17837)
-               UnboxedTuple -> tyConArity tycon `div` 2
-               _ -> tyConArity tycon
-       ; checkTupSize tupArity
-       ; return (Right name) }
-
-  | isExternalName name
-  = return (Right name)
-
-  | otherwise
-  = do { env <- getGlobalRdrEnv
-       ; let -- See Note [Splicing Exact names]
-             main_occ =  nameOccName name
-             demoted_occs = case demoteOccName main_occ of
-                              Just occ -> [occ]
-                              Nothing  -> []
-             gres = [ gre | occ <- main_occ : demoted_occs
-                          , gre <- lookupGlobalRdrEnv env occ
-                          , greMangledName gre == name ]
-       ; case gres of
-           [gre] -> return (Right (greMangledName gre))
-
-           []    -> -- See Note [Splicing Exact names]
-                    do { lcl_env <- getLocalRdrEnv
-                       ; if name `inLocalRdrEnvScope` lcl_env
-                         then return (Right name)
-                         else
-                         do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
-                            ; th_topnames <- readTcRef th_topnames_var
-                            ; if name `elemNameSet` th_topnames
-                              then return (Right name)
-                              else return (Left (NoExactName name))
-                            }
-                       }
-
-           gres -> return (Left (SameName gres)) -- Ugh!  See Note [Template Haskell ambiguity]
-       }
-
------------------------------------------------
-lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name
--- This is called on the method name on the left-hand side of an
--- instance declaration binding. eg.  instance Functor T where
---                                       fmap = ...
---                                       ^^^^ called on this
--- Regardless of how many unqualified fmaps are in scope, we want
--- the one that comes from the Functor class.
---
--- Furthermore, note that we take no account of whether the
--- name is only in scope qualified.  I.e. even if method op is
--- in scope as M.op, we still allow plain 'op' on the LHS of
--- an instance decl
---
--- The "what" parameter says "method" or "associated type",
--- depending on what we are looking up
-lookupInstDeclBndr cls what rdr
-  = do { when (isQual rdr)
-              (addErr (badQualBndrErr rdr))
-                -- In an instance decl you aren't allowed
-                -- to use a qualified name for the method
-                -- (Although it'd make perfect sense.)
-       ; mb_name <- lookupSubBndrOcc
-                          False -- False => we don't give deprecated
-                                -- warnings when a deprecated class
-                                -- method is defined. We only warn
-                                -- when it's used
-                          cls doc rdr
-       ; case mb_name of
-           Left err -> do { addErr (mkTcRnNotInScope rdr err)
-                          ; return (mkUnboundNameRdr rdr) }
-           Right nm -> return nm }
-  where
-    doc = what <+> text "of class" <+> quotes (ppr cls)
-
------------------------------------------------
-lookupFamInstName :: Maybe Name -> LocatedN RdrName
-                  -> RnM (LocatedN Name)
--- Used for TyData and TySynonym family instances only,
--- See Note [Family instance binders]
-lookupFamInstName (Just cls) tc_rdr  -- Associated type; c.f GHC.Rename.Bind.rnMethodBind
-  = wrapLocMA (lookupInstDeclBndr cls (text "associated type")) tc_rdr
-lookupFamInstName Nothing tc_rdr     -- Family instance; tc_rdr is an *occurrence*
-  = lookupLocatedOccRnConstr tc_rdr
-
------------------------------------------------
-lookupConstructorFields :: Name -> RnM [FieldLabel]
--- Look up the fields of a given constructor
---   *  For constructors from this module, use the record field env,
---      which is itself gathered from the (as yet un-typechecked)
---      data type decls
---
---    * For constructors from imported modules, use the *type* environment
---      since imported modules are already compiled, the info is conveniently
---      right there
-
-lookupConstructorFields con_name
-  = do  { this_mod <- getModule
-        ; if nameIsLocalOrFrom this_mod con_name then
-          do { field_env <- getRecFieldEnv
-             ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env)
-             ; return (lookupNameEnv field_env con_name `orElse` []) }
-          else
-          do { con <- tcLookupConLike con_name
-             ; traceTc "lookupCF 2" (ppr con)
-             ; return (conLikeFieldLabels con) } }
-
-
--- In CPS style as `RnM r` is monadic
--- Reports an error if the name is an Exact or Orig and it can't find the name
--- Otherwise if it is not an Exact or Orig, returns k
-lookupExactOrOrig :: RdrName -> (Name -> r) -> RnM r -> RnM r
-lookupExactOrOrig rdr_name res k
-  = do { men <- lookupExactOrOrig_base rdr_name
-       ; case men of
-          FoundExactOrOrig n -> return (res n)
-          ExactOrOrigError e ->
-            do { addErr (mkTcRnNotInScope rdr_name e)
-               ; return (res (mkUnboundNameRdr rdr_name)) }
-          NotExactOrOrig     -> k }
-
--- Variant of 'lookupExactOrOrig' that does not report an error
--- See Note [Errors in lookup functions]
--- Calls k if the name is neither an Exact nor Orig
-lookupExactOrOrig_maybe :: RdrName -> (Maybe Name -> r) -> RnM r -> RnM r
-lookupExactOrOrig_maybe rdr_name res k
-  = do { men <- lookupExactOrOrig_base rdr_name
-       ; case men of
-           FoundExactOrOrig n -> return (res (Just n))
-           ExactOrOrigError _ -> return (res Nothing)
-           NotExactOrOrig     -> k }
-
-data ExactOrOrigResult = FoundExactOrOrig Name -- ^ Found an Exact Or Orig Name
-                       | ExactOrOrigError NotInScopeError -- ^ The RdrName was an Exact
-                                                          -- or Orig, but there was an
-                                                          -- error looking up the Name
-                       | NotExactOrOrig -- ^ The RdrName is neither an Exact nor
-                                        -- Orig
-
--- Does the actual looking up an Exact or Orig name, see 'ExactOrOrigResult'
-lookupExactOrOrig_base :: RdrName -> RnM ExactOrOrigResult
-lookupExactOrOrig_base rdr_name
-  | Just n <- isExact_maybe rdr_name   -- This happens in derived code
-  = cvtEither <$> lookupExactOcc_either n
-  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-  = FoundExactOrOrig <$> lookupOrig rdr_mod rdr_occ
-  | otherwise = return NotExactOrOrig
-  where
-    cvtEither (Left e)  = ExactOrOrigError e
-    cvtEither (Right n) = FoundExactOrOrig n
-
-
-{- Note [Errors in lookup functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Many of these lookup functions will attach an error if it can't find the Name it
-is trying to lookup. However there are also _maybe and _either variants for many
-of these functions.
-
-These variants should *not* attach any errors, as there are
-places where we want to attempt looking up a name, but it's not the end of the
-world if we don't find it.
-
-For example, see lookupThName_maybe: It calls lookupOccRn_maybe multiple
-times for varying names in different namespaces. lookupOccRn_maybe should
-therefore never attach an error, instead just return a Nothing.
-
-For these _maybe/_either variant functions then, avoid calling further lookup
-functions that can attach errors and instead call their _maybe/_either
-counterparts.
--}
-
------------------------------------------------
--- | Look up an occurrence of a field in record construction or pattern
--- matching (but not update).  When the -XDisambiguateRecordFields
--- flag is on, take account of the data constructor name to
--- disambiguate which field to use.
---
--- See Note [DisambiguateRecordFields] and Note [NoFieldSelectors].
-lookupRecFieldOcc :: Maybe Name -- Nothing  => just look it up as usual
-                                -- Just con => use data con to disambiguate
-                  -> RdrName
-                  -> RnM Name
-lookupRecFieldOcc mb_con rdr_name
-  | Just con <- mb_con
-  , isUnboundName con  -- Avoid error cascade
-  = return (mkUnboundNameRdr rdr_name)
-  | Just con <- mb_con
-  = lookupExactOrOrig rdr_name id $  -- See Note [Record field names and Template Haskell]
-    do { flds <- lookupConstructorFields con
-       ; env <- getGlobalRdrEnv
-       ; let lbl      = FieldLabelString $ occNameFS (rdrNameOcc rdr_name)
-             mb_field = do fl <- find ((== lbl) . flLabel) flds
-                           -- We have the label, now check it is in scope.  If
-                           -- there is a qualifier, use pickGREs to check that
-                           -- the qualifier is correct, and return the filtered
-                           -- GRE so we get import usage right (see #17853).
-                           gre <- lookupGRE_FieldLabel env fl
-                           if isQual rdr_name
-                             then do gre' <- listToMaybe (pickGREs rdr_name [gre])
-                                     return (fl, gre')
-                              else return (fl, gre)
-       ; case mb_field of
-           Just (fl, gre) -> do { addUsedGRE True gre
-                                ; return (flSelector fl) }
-           Nothing        -> do { addErr (badFieldConErr con lbl)
-                                ; return (mkUnboundNameRdr rdr_name) } }
-
-  | otherwise  -- Can't use the data constructor to disambiguate
-  = lookupGlobalOccRn' WantBoth rdr_name
-    -- This use of Global is right as we are looking up a selector,
-    -- which can only be defined at the top level.
-
--- | Look up an occurrence of a field in a record update, returning the selector
--- name.
---
--- Unlike construction and pattern matching with @-XDisambiguateRecordFields@
--- (see 'lookupRecFieldOcc'), there is no data constructor to help disambiguate,
--- so this may be ambiguous if the field is in scope multiple times.  However we
--- ignore non-fields in scope with the same name if @-XDisambiguateRecordFields@
--- is on (see Note [DisambiguateRecordFields for updates]).
---
--- Here a field is in scope even if @NoFieldSelectors@ was enabled at its
--- definition site (see Note [NoFieldSelectors]).
-lookupRecFieldOcc_update
-  :: DuplicateRecordFields
-  -> RdrName
-  -> RnM AmbiguousResult
-lookupRecFieldOcc_update dup_fields_ok rdr_name = do
-    disambig_ok <- xoptM LangExt.DisambiguateRecordFields
-    let want | disambig_ok = WantField
-             | otherwise   = WantBoth
-    mr <- lookupGlobalOccRn_overloaded dup_fields_ok want rdr_name
-    case mr of
-        Just r  -> return r
-        Nothing  -- Try again if we previously looked only for fields, see
-                 -- Note [DisambiguateRecordFields for updates]
-          | disambig_ok -> do mr' <- lookupGlobalOccRn_overloaded dup_fields_ok WantBoth rdr_name
-                              case mr' of
-                                  Just r -> return r
-                                  Nothing -> unbound
-          | otherwise   -> unbound
-  where
-    unbound = UnambiguousGre . NormalGreName
-          <$> unboundName (LF WL_RecField WL_Global) rdr_name
-
-
-{- Note [DisambiguateRecordFields]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we are looking up record fields in record construction or pattern
-matching, we can take advantage of the data constructor name to
-resolve fields that would otherwise be ambiguous (provided the
--XDisambiguateRecordFields flag is on).
-
-For example, consider:
-
-   data S = MkS { x :: Int }
-   data T = MkT { x :: Int }
-
-   e = MkS { x = 3 }
-
-When we are renaming the occurrence of `x` in `e`, instead of looking
-`x` up directly (and finding both fields), lookupRecFieldOcc will
-search the fields of `MkS` to find the only possible `x` the user can
-mean.
-
-Of course, we still have to check the field is in scope, using
-lookupGRE_FieldLabel.  The handling of qualified imports is slightly
-subtle: the occurrence may be unqualified even if the field is
-imported only qualified (but if the occurrence is qualified, the
-qualifier must be correct). For example:
-
-   module A where
-     data S = MkS { x :: Int }
-     data T = MkT { x :: Int }
-
-   module B where
-     import qualified A (S(..))
-     import A (T(MkT))
-
-     e1 = MkT   { x = 3 }   -- x not in scope, so fail
-     e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail
-     e3 = A.MkS { x = 3 }   -- x in scope (lack of module qualifier permitted)
-
-In case `e1`, lookupGRE_FieldLabel will return Nothing.  In case `e2`,
-lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard
-will fail because the field RdrName `B.x` is qualified and pickGREs
-rejects the GRE.  In case `e3`, lookupGRE_FieldLabel will return the
-GRE for `A.x` and the guard will succeed because the field RdrName `x`
-is unqualified.
-
-
-Note [DisambiguateRecordFields for updates]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we are looking up record fields in record update, we can take advantage of
-the fact that we know we are looking for a field, even though we do not know the
-data constructor name (as in Note [DisambiguateRecordFields]), provided the
--XDisambiguateRecordFields flag is on.
-
-For example, consider:
-
-   module N where
-     f = ()
-
-   {-# LANGUAGE DisambiguateRecordFields #-}
-   module M where
-     import N (f)
-     data T = MkT { f :: Int }
-     t = MkT { f = 1 }  -- unambiguous because MkT determines which field we mean
-     u = t { f = 2 }    -- unambiguous because we ignore the non-field 'f'
-
-This works by lookupRecFieldOcc_update using 'WantField :: FieldsOrSelectors'
-when looking up the field name, so that 'filterFieldGREs' will later ignore any
-non-fields in scope.  Of course, if a record update has two fields in scope with
-the same name, it is still ambiguous.
-
-If we do not find anything when looking only for fields, we try again allowing
-fields or non-fields.  This leads to a better error message if the user
-mistakenly tries to use a non-field name in a record update:
-
-    f = ()
-    e x = x { f = () }
-
-Unlike with constructors or pattern-matching, we do not allow the module
-qualifier to be omitted, because we do not have a data constructor from which to
-determine it.
-
-Note [Record field names and Template Haskell]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#12130):
-
-   module Foo where
-     import M
-     b = $(funny)
-
-   module M(funny) where
-     data T = MkT { x :: Int }
-     funny :: Q Exp
-     funny = [| MkT { x = 3 } |]
-
-When we splice, `MkT` is not lexically in scope, so
-lookupGRE_FieldLabel will fail.  But there is no need for
-disambiguation anyway, because `x` is an original name, and
-lookupGlobalOccRn will find it.
--}
-
-
--- | Used in export lists to lookup the children.
-lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName
-                        -> RnM ChildLookupResult
-lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name
-  | isUnboundName parent
-    -- Avoid an error cascade
-  = return (FoundChild NoParent (NormalGreName (mkUnboundNameRdr rdr_name)))
-
-  | otherwise = do
-  gre_env <- getGlobalRdrEnv
-
-  let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name)
-  -- Disambiguate the lookup based on the parent information.
-  -- The remaining GREs are things that we *could* export here, note that
-  -- this includes things which have `NoParent`. Those are sorted in
-  -- `checkPatSynParent`.
-  traceRn "parent" (ppr parent)
-  traceRn "lookupExportChild original_gres:" (ppr original_gres)
-  traceRn "lookupExportChild picked_gres:" (ppr (picked_gres original_gres) $$ ppr must_have_parent)
-  case picked_gres original_gres of
-    NoOccurrence ->
-      noMatchingParentErr original_gres
-    UniqueOccurrence g ->
-      if must_have_parent then noMatchingParentErr original_gres
-                          else checkFld g
-    DisambiguatedOccurrence g ->
-      checkFld g
-    AmbiguousOccurrence gres ->
-      mkNameClashErr gres
-    where
-        -- Convert into FieldLabel if necessary
-        checkFld :: GlobalRdrElt -> RnM ChildLookupResult
-        checkFld g@GRE{gre_name,gre_par} = do
-          addUsedGRE warn_if_deprec g
-          return $ FoundChild gre_par gre_name
-
-        -- Called when we find no matching GREs after disambiguation but
-        -- there are three situations where this happens.
-        -- 1. There were none to begin with.
-        -- 2. None of the matching ones were the parent but
-        --  a. They were from an overloaded record field so we can report
-        --     a better error
-        --  b. The original lookup was actually ambiguous.
-        --     For example, the case where overloading is off and two
-        --     record fields are in scope from different record
-        --     constructors, neither of which is the parent.
-        noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult
-        noMatchingParentErr original_gres = do
-          traceRn "npe" (ppr original_gres)
-          dup_fields_ok <- xoptM LangExt.DuplicateRecordFields
-          case original_gres of
-            [] ->  return NameNotFound
-            [g] -> return $ IncorrectParent parent
-                              (gre_name g)
-                              [p | Just p <- [getParent g]]
-            gss@(g:gss'@(_:_)) ->
-              if all isRecFldGRE gss && dup_fields_ok
-                then return $
-                      IncorrectParent parent
-                        (gre_name g)
-                        [p | x <- gss, Just p <- [getParent x]]
-                else mkNameClashErr $ g NE.:| gss'
-
-        mkNameClashErr :: NE.NonEmpty GlobalRdrElt -> RnM ChildLookupResult
-        mkNameClashErr gres = do
-          addNameClashErrRn rdr_name gres
-          return (FoundChild (gre_par (NE.head gres)) (gre_name (NE.head gres)))
-
-        getParent :: GlobalRdrElt -> Maybe Name
-        getParent (GRE { gre_par = p } ) =
-          case p of
-            ParentIs cur_parent -> Just cur_parent
-            NoParent -> Nothing
-
-        picked_gres :: [GlobalRdrElt] -> DisambigInfo
-        -- For Unqual, find GREs that are in scope qualified or unqualified
-        -- For Qual,   find GREs that are in scope with that qualification
-        picked_gres gres
-          | isUnqual rdr_name
-          = mconcat (map right_parent gres)
-          | otherwise
-          = mconcat (map right_parent (pickGREs rdr_name gres))
-
-        right_parent :: GlobalRdrElt -> DisambigInfo
-        right_parent p
-          = case getParent p of
-               Just cur_parent
-                  | parent == cur_parent -> DisambiguatedOccurrence p
-                  | otherwise            -> NoOccurrence
-               Nothing                   -> UniqueOccurrence p
-
-
--- This domain specific datatype is used to record why we decided it was
--- possible that a GRE could be exported with a parent.
-data DisambigInfo
-       = NoOccurrence
-          -- The GRE could never be exported. It has the wrong parent.
-       | UniqueOccurrence GlobalRdrElt
-          -- The GRE has no parent. It could be a pattern synonym.
-       | DisambiguatedOccurrence GlobalRdrElt
-          -- The parent of the GRE is the correct parent
-       | AmbiguousOccurrence (NE.NonEmpty GlobalRdrElt)
-          -- For example, two normal identifiers with the same name are in
-          -- scope. They will both be resolved to "UniqueOccurrence" and the
-          -- monoid will combine them to this failing case.
-
-instance Outputable DisambigInfo where
-  ppr NoOccurrence = text "NoOccurrence"
-  ppr (UniqueOccurrence gre) = text "UniqueOccurrence:" <+> ppr gre
-  ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre
-  ppr (AmbiguousOccurrence gres)    = text "Ambiguous:" <+> ppr gres
-
-instance Semi.Semigroup DisambigInfo where
-  -- This is the key line: We prefer disambiguated occurrences to other
-  -- names.
-  _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g'
-  DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g'
-
-  NoOccurrence <> m = m
-  m <> NoOccurrence = m
-  UniqueOccurrence g <> UniqueOccurrence g'
-    = AmbiguousOccurrence $ g NE.:| [g']
-  UniqueOccurrence g <> AmbiguousOccurrence gs
-    = AmbiguousOccurrence (g `NE.cons` gs)
-  AmbiguousOccurrence gs <> UniqueOccurrence g'
-    = AmbiguousOccurrence (g' `NE.cons` gs)
-  AmbiguousOccurrence gs <> AmbiguousOccurrence gs'
-    = AmbiguousOccurrence (gs Semi.<> gs')
-
-instance Monoid DisambigInfo where
-  mempty = NoOccurrence
-  mappend = (Semi.<>)
-
--- Lookup SubBndrOcc can never be ambiguous
---
--- Records the result of looking up a child.
-data ChildLookupResult
-      = NameNotFound                --  We couldn't find a suitable name
-      | IncorrectParent Name        -- Parent
-                        GreName     -- Child we were looking for
-                        [Name]      -- List of possible parents
-      | FoundChild Parent GreName   --  We resolved to a child
-
--- | Specialised version of msum for RnM ChildLookupResult
-combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult
-combineChildLookupResult [] = return NameNotFound
-combineChildLookupResult (x:xs) = do
-  res <- x
-  case res of
-    NameNotFound -> combineChildLookupResult xs
-    _ -> return res
-
-instance Outputable ChildLookupResult where
-  ppr NameNotFound = text "NameNotFound"
-  ppr (FoundChild p n) = text "Found:" <+> ppr p <+> ppr n
-  ppr (IncorrectParent p n ns) = text "IncorrectParent"
-                                  <+> hsep [ppr p, ppr n, ppr ns]
-
-lookupSubBndrOcc :: Bool
-                 -> Name     -- Parent
-                 -> SDoc
-                 -> RdrName
-                 -> RnM (Either NotInScopeError Name)
--- Find all the things the rdr-name maps to
--- and pick the one with the right parent name
-lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do
-  res <-
-    lookupExactOrOrig rdr_name (FoundChild NoParent . NormalGreName) $
-      -- This happens for built-in classes, see mod052 for example
-      lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name
-  case res of
-    NameNotFound -> return (Left (UnknownSubordinate doc))
-    FoundChild _p child -> return (Right (greNameMangledName child))
-    IncorrectParent {}
-         -- See [Mismatched class methods and associated type families]
-         -- in TcInstDecls.
-      -> return $ Left (UnknownSubordinate doc)
-
-{-
-Note [Family instance binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  data family F a
-  data instance F T = X1 | X2
-
-The 'data instance' decl has an *occurrence* of F (and T), and *binds*
-X1 and X2.  (This is unlike a normal data type declaration which would
-bind F too.)  So we want an AvailTC F [X1,X2].
-
-Now consider a similar pair:
-  class C a where
-    data G a
-  instance C S where
-    data G S = Y1 | Y2
-
-The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G.
-
-But there is a small complication: in an instance decl, we don't use
-qualified names on the LHS; instead we use the class to disambiguate.
-Thus:
-  module M where
-    import Blib( G )
-    class C a where
-      data G a
-    instance C S where
-      data G S = Y1 | Y2
-Even though there are two G's in scope (M.G and Blib.G), the occurrence
-of 'G' in the 'instance C S' decl is unambiguous, because C has only
-one associated type called G. This is exactly what happens for methods,
-and it is only consistent to do the same thing for types. That's the
-role of the function lookupTcdName; the (Maybe Name) give the class of
-the enclosing instance decl, if any.
-
-Note [Looking up Exact RdrNames]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Exact RdrNames are generated by:
-
-* Template Haskell (See Note [Binders in Template Haskell] in GHC.ThToHs)
-* Derived instances (See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate)
-
-For data types and classes have Exact system Names in the binding
-positions for constructors, TyCons etc.  For example
-    [d| data T = MkT Int |]
-when we splice in and convert to HsSyn RdrName, we'll get
-    data (Exact (system Name "T")) = (Exact (system Name "MkT")) ...
-These System names are generated by GHC.ThToHs.thRdrName
-
-But, constructors and the like need External Names, not System Names!
-So we do the following
-
- * In GHC.Rename.Env.newTopSrcBinder we spot Exact RdrNames that wrap a
-   non-External Name, and make an External name for it. This is
-   the name that goes in the GlobalRdrEnv
-
- * When looking up an occurrence of an Exact name, done in
-   GHC.Rename.Env.lookupExactOcc, we find the Name with the right unique in the
-   GlobalRdrEnv, and use the one from the envt -- it will be an
-   External Name in the case of the data type/constructor above.
-
- * Exact names are also use for purely local binders generated
-   by TH, such as    \x_33. x_33
-   Both binder and occurrence are Exact RdrNames.  The occurrence
-   gets looked up in the LocalRdrEnv by GHC.Rename.Env.lookupOccRn, and
-   misses, because lookupLocalRdrEnv always returns Nothing for
-   an Exact Name.  Now we fall through to lookupExactOcc, which
-   will find the Name is not in the GlobalRdrEnv, so we just use
-   the Exact supplied Name.
-
-Note [Splicing Exact names]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider the splice $(do { x <- newName "x"; return (VarE x) })
-This will generate a (HsExpr RdrName) term that mentions the
-Exact RdrName "x_56" (or whatever), but does not bind it.  So
-when looking such Exact names we want to check that it's in scope,
-otherwise the type checker will get confused.  To do this we need to
-keep track of all the Names in scope, and the LocalRdrEnv does just that;
-we consult it with RdrName.inLocalRdrEnvScope.
-
-There is another wrinkle.  With TH and -XDataKinds, consider
-   $( [d| data Nat = Zero
-          data T = MkT (Proxy 'Zero)  |] )
-After splicing, but before renaming we get this:
-   data Nat_77{tc} = Zero_78{d}
-   data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc})  |] )
-The occurrence of 'Zero in the data type for T has the right unique,
-but it has a TcClsName name-space in its OccName.  (This is set by
-the ctxt_ns argument of Convert.thRdrName.)  When we check that is
-in scope in the GlobalRdrEnv, we need to look up the DataName namespace
-too.  (An alternative would be to make the GlobalRdrEnv also have
-a Name -> GRE mapping.)
-
-Note [Template Haskell ambiguity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The GlobalRdrEnv invariant says that if
-  occ -> [gre1, ..., gren]
-then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv).
-This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre).
-
-So how can we get multiple gres in lookupExactOcc_maybe?  Because in
-TH we might use the same TH NameU in two different name spaces.
-eg (#7241):
-   $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]])
-Here we generate a type constructor and data constructor with the same
-unique, but different name spaces.
-
-It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would
-mean looking up the OccName in every name-space, just in case, and that
-seems a bit brutal.  So it's just done here on lookup.  But we might
-need to revisit that choice.
-
-Note [Usage for sub-bndrs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-If you have this
-   import qualified M( C( f ) )
-   instance M.C T where
-     f x = x
-then is the qualified import M.f used?  Obviously yes.
-But the RdrName used in the instance decl is unqualified.  In effect,
-we fill in the qualification by looking for f's whose class is M.C
-But when adding to the UsedRdrNames we must make that qualification
-explicit (saying "used  M.f"), otherwise we get "Redundant import of M.f".
-
-So we make up a suitable (fake) RdrName.  But be careful
-   import qualified M
-   import M( C(f) )
-   instance C T where
-     f x = x
-Here we want to record a use of 'f', not of 'M.f', otherwise
-we'll miss the fact that the qualified import is redundant.
-
---------------------------------------------------
---              Occurrences
---------------------------------------------------
--}
-
-
-lookupLocatedOccRn :: GenLocated (SrcSpanAnn' ann) RdrName
-                   -> TcRn (GenLocated (SrcSpanAnn' ann) Name)
-lookupLocatedOccRn = wrapLocMA lookupOccRn
-
-lookupLocatedOccRnConstr :: GenLocated (SrcSpanAnn' ann) RdrName
-                         -> TcRn (GenLocated (SrcSpanAnn' ann) Name)
-lookupLocatedOccRnConstr = wrapLocMA lookupOccRnConstr
-
-lookupLocatedOccRnRecField :: GenLocated (SrcSpanAnn' ann) RdrName
-                           -> TcRn (GenLocated (SrcSpanAnn' ann) Name)
-lookupLocatedOccRnRecField = wrapLocMA lookupOccRnRecField
-
-lookupLocatedOccRnNone :: GenLocated (SrcSpanAnn' ann) RdrName
-                       -> TcRn (GenLocated (SrcSpanAnn' ann) Name)
-lookupLocatedOccRnNone = wrapLocMA lookupOccRnNone
-
-lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name)
--- Just look in the local environment
-lookupLocalOccRn_maybe rdr_name
-  = do { local_env <- getLocalRdrEnv
-       ; return (lookupLocalRdrEnv local_env rdr_name) }
-
-lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel))
--- Just look in the local environment
-lookupLocalOccThLvl_maybe name
-  = do { lcl_env <- getLclEnv
-       ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) }
-
--- lookupOccRn' looks up an occurrence of a RdrName, and uses its argument to
--- determine what kind of suggestions should be displayed if it is not in scope
-lookupOccRn' :: WhatLooking -> RdrName -> RnM Name
-lookupOccRn' which_suggest rdr_name
-  = do { mb_name <- lookupOccRn_maybe rdr_name
-       ; case mb_name of
-           Just name -> return name
-           Nothing   -> reportUnboundName' which_suggest rdr_name }
-
--- lookupOccRn looks up an occurrence of a RdrName and displays suggestions if
--- it is not in scope
-lookupOccRn :: RdrName -> RnM Name
-lookupOccRn = lookupOccRn' WL_Anything
-
--- lookupOccRnConstr looks up an occurrence of a RdrName and displays
--- constructors and pattern synonyms as suggestions if it is not in scope
-lookupOccRnConstr :: RdrName -> RnM Name
-lookupOccRnConstr = lookupOccRn' WL_Constructor
-
--- lookupOccRnRecField looks up an occurrence of a RdrName and displays
--- record fields as suggestions if it is not in scope
-lookupOccRnRecField :: RdrName -> RnM Name
-lookupOccRnRecField = lookupOccRn' WL_RecField
-
--- lookupOccRnRecField looks up an occurrence of a RdrName and displays
--- no suggestions if it is not in scope
-lookupOccRnNone :: RdrName -> RnM Name
-lookupOccRnNone = lookupOccRn' WL_None
-
--- Only used in one place, to rename pattern synonym binders.
--- See Note [Renaming pattern synonym variables] in GHC.Rename.Bind
-lookupLocalOccRn :: RdrName -> RnM Name
-lookupLocalOccRn rdr_name
-  = do { mb_name <- lookupLocalOccRn_maybe rdr_name
-       ; case mb_name of
-           Just name -> return name
-           Nothing   -> unboundName (LF WL_Anything WL_LocalOnly) rdr_name }
-
--- lookupTypeOccRn looks up an optionally promoted RdrName.
--- Used for looking up type variables.
-lookupTypeOccRn :: RdrName -> RnM Name
--- see Note [Demotion]
-lookupTypeOccRn rdr_name
-  | isVarOcc (rdrNameOcc rdr_name)  -- See Note [Promoted variables in types]
-  = badVarInType rdr_name
-  | otherwise
-  = do { mb_name <- lookupOccRn_maybe rdr_name
-       ; case mb_name of
-             Just name -> return name
-             Nothing   ->
-               if occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback]
-               then eqTyConName <$ addDiagnostic TcRnTypeEqualityOutOfScope
-               else lookup_demoted rdr_name }
-
-{- Note [eqTyCon (~) compatibility fallback]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Before GHC Proposal #371, the (~) type operator used in type equality
-constraints (a~b) was considered built-in syntax.
-
-This had two implications:
-
-1. Users could use it without importing it from Data.Type.Equality or Prelude.
-2. TypeOperators were not required to use it (it was guarded behind TypeFamilies/GADTs instead)
-
-To ease migration and minimize breakage, we continue to support those usages
-but emit appropriate warnings.
--}
-
-lookup_demoted :: RdrName -> RnM Name
-lookup_demoted rdr_name
-  | Just demoted_rdr <- demoteRdrName rdr_name
-    -- Maybe it's the name of a *data* constructor
-  = do { data_kinds <- xoptM LangExt.DataKinds
-       ; star_is_type <- xoptM LangExt.StarIsType
-       ; let is_star_type = if star_is_type then StarIsType else StarIsNotType
-             star_is_type_hints = noStarIsTypeHints is_star_type rdr_name
-       ; if data_kinds
-            then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr
-                    ; case mb_demoted_name of
-                        Nothing -> unboundNameX looking_for rdr_name star_is_type_hints
-                        Just demoted_name -> return demoted_name }
-            else do { -- We need to check if a data constructor of this name is
-                      -- in scope to give good error messages. However, we do
-                      -- not want to give an additional error if the data
-                      -- constructor happens to be out of scope! See #13947.
-                      mb_demoted_name <- discardErrs $
-                                         lookupOccRn_maybe demoted_rdr
-                    ; let suggestion | isJust mb_demoted_name
-                                     , let additional = text "to refer to the data constructor of that name?"
-                                     = [SuggestExtension $ SuggestSingleExtension additional LangExt.DataKinds]
-                                     | otherwise
-                                     = star_is_type_hints
-                    ; unboundNameX looking_for rdr_name suggestion } }
-
-  | otherwise
-  = reportUnboundName' (lf_which looking_for) rdr_name
-
-  where
-    looking_for = LF WL_Constructor WL_Anywhere
-
--- If the given RdrName can be promoted to the type level and its promoted variant is in scope,
--- lookup_promoted returns the corresponding type-level Name.
--- Otherwise, the function returns Nothing.
--- See Note [Promotion] below.
-lookup_promoted :: RdrName -> RnM (Maybe Name)
-lookup_promoted rdr_name
-  | Just promoted_rdr <- promoteRdrName rdr_name
-  = lookupOccRn_maybe promoted_rdr
-  | otherwise
-  = return Nothing
-
-badVarInType :: RdrName -> RnM Name
-badVarInType rdr_name
-  = do { addErr (TcRnUnpromotableThing name TermVariablePE)
-       ; return name }
-      where
-        name = mkUnboundNameRdr rdr_name
-
-{- Note [Promoted variables in types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this (#12686):
-   x = True
-   data Bad = Bad 'x
-
-The parser treats the quote in 'x as saying "use the term
-namespace", so we'll get (Bad x{v}), with 'x' in the
-VarName namespace.  If we don't test for this, the renamer
-will happily rename it to the x bound at top level, and then
-the typecheck falls over because it doesn't have 'x' in scope
-when kind-checking.
-
-Note [Demotion]
-~~~~~~~~~~~~~~~
-When the user writes:
-  data Nat = Zero | Succ Nat
-  foo :: f Zero -> Int
-
-'Zero' in the type signature of 'foo' is parsed as:
-  HsTyVar ("Zero", TcClsName)
-
-When the renamer hits this occurrence of 'Zero' it's going to realise
-that it's not in scope. But because it is renaming a type, it knows
-that 'Zero' might be a promoted data constructor, so it will demote
-its namespace to DataName and do a second lookup.
-
-The final result (after the renamer) will be:
-  HsTyVar ("Zero", DataName)
-
-Note [Promotion]
-~~~~~~~~~~~~~~~
-When the user mentions a type constructor or a type variable in a
-term-level context, then we report that a value identifier was expected
-instead of a type-level one. That makes error messages more precise.
-Previously, such errors contained only the info that a given value was out of scope (#18740).
-We promote the namespace of RdrName and look up after that
-(see the functions promotedRdrName and lookup_promoted).
-
-In particular, we have the following error message
-  • Illegal term-level use of the type constructor ‘Int’
-      imported from ‘Prelude’ (and originally defined in ‘GHC.Types’)
-  • In the first argument of ‘id’, namely ‘Int’
-    In the expression: id Int
-    In an equation for ‘x’: x = id Int
-
-when the user writes the following declaration
-
-  x = id Int
--}
-
-lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (Name -> r) -> RdrName
-                   -> RnM (Maybe r)
-lookupOccRnX_maybe globalLookup wrapper rdr_name
-  = runMaybeT . msum . map MaybeT $
-      [ fmap wrapper <$> lookupLocalOccRn_maybe rdr_name
-      , globalLookup rdr_name ]
-
--- Used outside this module only by TH name reification (lookupName, lookupThName_maybe)
-lookupOccRn_maybe :: RdrName -> RnM (Maybe Name)
-lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id
-
--- | Look up a 'RdrName' used as a variable in an expression.
---
--- This may be a local variable, global variable, or one or more record selector
--- functions.  It will not return record fields created with the
--- @NoFieldSelectors@ extension (see Note [NoFieldSelectors]).
---
--- If the name is not in scope at the term level, but its promoted equivalent is
--- in scope at the type level, the lookup will succeed (so that the type-checker
--- can report a more informative error later).  See Note [Promotion].
---
-lookupExprOccRn :: RdrName -> RnM (Maybe GreName)
-lookupExprOccRn rdr_name
-  = do { mb_name <- lookupOccRnX_maybe global_lookup NormalGreName rdr_name
-       ; case mb_name of
-           Nothing   -> fmap @Maybe NormalGreName <$> lookup_promoted rdr_name
-                        -- See Note [Promotion].
-                        -- We try looking up the name as a
-                        -- type constructor or type variable, if
-                        -- we failed to look up the name at the term level.
-           p         -> return p }
-
-  where
-    global_lookup :: RdrName -> RnM (Maybe GreName)
-    global_lookup  rdr_name =
-      do { mb_name <- lookupGlobalOccRn_overloaded NoDuplicateRecordFields WantNormal rdr_name
-         ; case mb_name of
-             Just (UnambiguousGre name) -> return (Just name)
-             Just _ -> panic "GHC.Rename.Env.global_lookup: The impossible happened!"
-             Nothing -> return Nothing
-         }
-
-lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)
--- Looks up a RdrName occurrence in the top-level
--- environment, including using lookupQualifiedNameGHCi
--- for the GHCi case, but first tries to find an Exact or Orig name.
--- No filter function; does not report an error on failure
--- See Note [Errors in lookup functions]
--- Uses addUsedRdrName to record use and deprecations
---
--- Used directly only by getLocalNonValBinders (new_assoc).
-lookupGlobalOccRn_maybe rdr_name =
-  lookupExactOrOrig_maybe rdr_name id (lookupGlobalOccRn_base WantNormal rdr_name)
-
-lookupGlobalOccRn :: RdrName -> RnM Name
--- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
--- environment.  Adds an error message if the RdrName is not in scope.
--- You usually want to use "lookupOccRn" which also looks in the local
--- environment.
---
--- Used by exports_from_avail
-lookupGlobalOccRn = lookupGlobalOccRn' WantNormal
-
-lookupGlobalOccRn' :: FieldsOrSelectors -> RdrName -> RnM Name
-lookupGlobalOccRn' fos rdr_name =
-  lookupExactOrOrig rdr_name id $ do
-    mn <- lookupGlobalOccRn_base fos rdr_name
-    case mn of
-      Just n -> return n
-      Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)
-                    ; unboundName (LF which_suggest WL_Global) rdr_name }
-        where which_suggest = case fos of
-                WantNormal -> WL_Anything
-                WantBoth   -> WL_RecField
-                WantField  -> WL_RecField
-
--- Looks up a RdrName occurrence in the GlobalRdrEnv and with
--- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first.
--- lookupQualifiedNameGHCi here is used when we're in GHCi and a name like
--- 'Data.Map.elems' is typed, even if you didn't import Data.Map
-lookupGlobalOccRn_base :: FieldsOrSelectors -> RdrName -> RnM (Maybe Name)
-lookupGlobalOccRn_base fos rdr_name =
-  runMaybeT . msum . map MaybeT $
-    [ fmap greMangledName <$> lookupGreRn_maybe fos rdr_name
-    , fmap greNameMangledName <$> lookupOneQualifiedNameGHCi fos rdr_name ]
-                      -- This test is not expensive,
-                      -- and only happens for failed lookups
-
-lookupInfoOccRn :: RdrName -> RnM [Name]
--- lookupInfoOccRn is intended for use in GHCi's ":info" command
--- It finds all the GREs that RdrName could mean, not complaining
--- about ambiguity, but rather returning them all
--- C.f. #9881
--- lookupInfoOccRn is also used in situations where we check for
--- at least one definition of the RdrName, not complaining about
--- multiple definitions. (See #17832)
-lookupInfoOccRn rdr_name =
-  lookupExactOrOrig rdr_name (:[]) $
-    do { rdr_env <- getGlobalRdrEnv
-       ; let ns = map greMangledName (lookupGRE_RdrName' rdr_name rdr_env)
-       ; qual_ns <- map greNameMangledName <$> lookupQualifiedNameGHCi WantBoth rdr_name
-       ; return (ns ++ (qual_ns `minusList` ns)) }
-
--- | Like 'lookupOccRn_maybe', but with a more informative result if
--- the 'RdrName' happens to be a record selector:
---
---   * Nothing                 -> name not in scope (no error reported)
---   * Just (UnambiguousGre x) -> name uniquely refers to x,
---                                or there is a name clash (reported)
---   * Just AmbiguousFields    -> name refers to two or more record fields
---                                (no error reported)
---
--- See Note [ Unbound vs Ambiguous Names ].
-lookupGlobalOccRn_overloaded :: DuplicateRecordFields -> FieldsOrSelectors -> RdrName
-                             -> RnM (Maybe AmbiguousResult)
-lookupGlobalOccRn_overloaded dup_fields_ok fos rdr_name =
-  lookupExactOrOrig_maybe rdr_name (fmap (UnambiguousGre . NormalGreName)) $
-    do { res <- lookupGreRn_helper fos rdr_name
-       ; case res of
-           GreNotFound -> fmap UnambiguousGre <$> lookupOneQualifiedNameGHCi fos rdr_name
-           OneNameMatch gre -> return $ Just (UnambiguousGre (gre_name gre))
-           MultipleNames gres
-             | all isRecFldGRE gres
-             , dup_fields_ok == DuplicateRecordFields -> return $ Just AmbiguousFields
-             | otherwise -> do
-                  addNameClashErrRn rdr_name gres
-                  return (Just (UnambiguousGre (gre_name (NE.head gres)))) }
-
-
--- | Result of looking up an occurrence that might be an ambiguous field.
-data AmbiguousResult
-    = UnambiguousGre GreName
-    -- ^ Occurrence picked out a single name, which may or may not belong to a
-    -- field (or might be unbound, if an error has been reported already, per
-    -- Note [ Unbound vs Ambiguous Names ]).
-    | AmbiguousFields
-    -- ^ Occurrence picked out two or more fields, and no non-fields.  For now
-    -- this is allowed by DuplicateRecordFields in certain circumstances, as the
-    -- type-checker may be able to disambiguate later.
-
-
-{-
-Note [NoFieldSelectors]
-~~~~~~~~~~~~~~~~~~~~~~~
-The NoFieldSelectors extension allows record fields to be defined without
-bringing the corresponding selector functions into scope.  However, such fields
-may still be used in contexts such as record construction, pattern matching or
-update. This requires us to distinguish contexts in which selectors are required
-from those in which any field may be used.  For example:
-
-  {-# LANGUAGE NoFieldSelectors #-}
-  module M (T(foo), foo) where  -- T(foo) refers to the field,
-                                -- unadorned foo to the value binding
-    data T = MkT { foo :: Int }
-    foo = ()
-
-    bar = foo -- refers to the value binding, field ignored
-
-  module N where
-    import M (T(..))
-    baz = MkT { foo = 3 } -- refers to the field
-    oops = foo -- an error: the field is in scope but the value binding is not
-
-Each 'FieldLabel' indicates (in the 'flHasFieldSelector' field) whether the
-FieldSelectors extension was enabled in the defining module.  This allows them
-to be filtered out by 'filterFieldGREs'.
-
-Even when NoFieldSelectors is in use, we still generate selector functions
-internally. For example, the expression
-   getField @"foo" t
-or (with dot-notation)
-   t.foo
-extracts the `foo` field of t::T, and hence needs the selector function
-(see Note [HasField instances] in GHC.Tc.Instance.Class).  In order to avoid
-name clashes with normal bindings reusing the names, selector names for such
-fields are mangled just as for DuplicateRecordFields (see Note [FieldLabel] in
-GHC.Types.FieldLabel).
-
-
-In many of the name lookup functions in this module we pass a FieldsOrSelectors
-value, indicating what we are looking for:
-
- * WantNormal: fields are in scope only if they have an accompanying selector
-   function, e.g. we are looking up a variable in an expression
-   (lookupExprOccRn).
-
- * WantBoth: any name or field will do, regardless of whether the selector
-   function is available, e.g. record updates (lookupRecFieldOcc_update) with
-   NoDisambiguateRecordFields.
-
- * WantField: any field will do, regardless of whether the selector function is
-   available, but ignoring any non-field names, e.g. record updates
-   (lookupRecFieldOcc_update) with DisambiguateRecordFields.
-
------------------------------------------------------------------------------------
-  Context                                  FieldsOrSelectors
------------------------------------------------------------------------------------
-  Record construction/pattern match        WantBoth if NoDisambiguateRecordFields
-  e.g. MkT { foo = 3 }                     (DisambiguateRecordFields is separate)
-
-  Record update                            WantBoth if NoDisambiguateRecordFields
-  e.g. e { foo = 3 }                       WantField if DisambiguateRecordFields
-
-  :info in GHCi                            WantBoth
-
-  Variable occurrence in expression        WantNormal
-  Type variable, data constructor
-  Pretty much everything else
------------------------------------------------------------------------------------
--}
-
--- | When looking up GREs, we may or may not want to include fields that were
--- defined in modules with @NoFieldSelectors@ enabled.  See Note
--- [NoFieldSelectors].
-data FieldsOrSelectors
-    = WantNormal -- ^ Include normal names, and fields with selectors, but
-                 -- ignore fields without selectors.
-    | WantBoth   -- ^ Include normal names and all fields (regardless of whether
-                 -- they have selectors).
-    | WantField  -- ^ Include only fields, with or without selectors, ignoring
-                 -- any non-fields in scope.
-  deriving Eq
-
-filterFieldGREs :: FieldsOrSelectors -> [GlobalRdrElt] -> [GlobalRdrElt]
-filterFieldGREs fos = filter (allowGreName fos . gre_name)
-
-allowGreName :: FieldsOrSelectors -> GreName -> Bool
-allowGreName WantBoth   _                 = True
-allowGreName WantNormal (FieldGreName fl) = flHasFieldSelector fl == FieldSelectors
-allowGreName WantNormal (NormalGreName _) = True
-allowGreName WantField  (FieldGreName  _) = True
-allowGreName WantField  (NormalGreName _) = False
-
-
---------------------------------------------------
---      Lookup in the Global RdrEnv of the module
---------------------------------------------------
-
-data GreLookupResult = GreNotFound
-                     | OneNameMatch GlobalRdrElt
-                     | MultipleNames (NE.NonEmpty GlobalRdrElt)
-
-lookupGreRn_maybe :: FieldsOrSelectors -> RdrName -> RnM (Maybe GlobalRdrElt)
--- Look up the RdrName in the GlobalRdrEnv
---   Exactly one binding: records it as "used", return (Just gre)
---   No bindings:         return Nothing
---   Many bindings:       report "ambiguous", return an arbitrary (Just gre)
--- Uses addUsedRdrName to record use and deprecations
-lookupGreRn_maybe fos rdr_name
-  = do
-      res <- lookupGreRn_helper fos rdr_name
-      case res of
-        OneNameMatch gre ->  return $ Just gre
-        MultipleNames gres -> do
-          traceRn "lookupGreRn_maybe:NameClash" (ppr gres)
-          addNameClashErrRn rdr_name gres
-          return $ Just (NE.head gres)
-        GreNotFound -> return Nothing
-
-{-
-
-Note [ Unbound vs Ambiguous Names ]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-lookupGreRn_maybe deals with failures in two different ways. If a name
-is unbound then we return a `Nothing` but if the name is ambiguous
-then we raise an error and return a dummy name.
-
-The reason for this is that when we call `lookupGreRn_maybe` we are
-speculatively looking for whatever we are looking up. If we don't find it,
-then we might have been looking for the wrong thing and can keep trying.
-On the other hand, if we find a clash then there is no way to recover as
-we found the thing we were looking for but can no longer resolve which
-the correct one is.
-
-One example of this is in `lookupTypeOccRn` which first looks in the type
-constructor namespace before looking in the data constructor namespace to
-deal with `DataKinds`.
-
-There is however, as always, one exception to this scheme. If we find
-an ambiguous occurrence of a record selector and DuplicateRecordFields
-is enabled then we defer the selection until the typechecker.
-
--}
-
-
-
-
--- Internal Function
-lookupGreRn_helper :: FieldsOrSelectors -> RdrName -> RnM GreLookupResult
-lookupGreRn_helper fos rdr_name
-  = do  { env <- getGlobalRdrEnv
-        ; case filterFieldGREs fos (lookupGRE_RdrName' rdr_name env) of
-            []    -> return GreNotFound
-            [gre] -> do { addUsedGRE True gre
-                        ; return (OneNameMatch gre) }
-            -- Don't record usage for ambiguous names
-            -- until we know which is meant
-            (gre:gres) -> return (MultipleNames (gre NE.:| gres)) }
-
-lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo)
--- Used in export lists
--- If not found or ambiguous, add error message, and fake with UnboundName
--- Uses addUsedRdrName to record use and deprecations
-lookupGreAvailRn rdr_name
-  = do
-      mb_gre <- lookupGreRn_helper WantNormal rdr_name
-      case mb_gre of
-        GreNotFound ->
-          do
-            traceRn "lookupGreAvailRn" (ppr rdr_name)
-            name <- unboundName (LF WL_Anything WL_Global) rdr_name
-            return (name, avail name)
-        MultipleNames gres ->
-          do
-            addNameClashErrRn rdr_name gres
-            let unbound_name = mkUnboundNameRdr rdr_name
-            return (unbound_name, avail unbound_name)
-                        -- Returning an unbound name here prevents an error
-                        -- cascade
-        OneNameMatch gre ->
-          return (greMangledName gre, availFromGRE gre)
-
-
-{-
-*********************************************************
-*                                                      *
-                Deprecations
-*                                                      *
-*********************************************************
-
-Note [Handling of deprecations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* We report deprecations at each *occurrence* of the deprecated thing
-  (see #5867)
-
-* We do not report deprecations for locally-defined names. For a
-  start, we may be exporting a deprecated thing. Also we may use a
-  deprecated thing in the defn of another deprecated things.  We may
-  even use a deprecated thing in the defn of a non-deprecated thing,
-  when changing a module's interface.
-
-* addUsedGREs: we do not report deprecations for sub-binders:
-     - the ".." completion for records
-     - the ".." in an export item 'T(..)'
-     - the things exported by a module export 'module M'
--}
-
-addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM ()
--- Remember use of in-scope data constructors (#7969)
-addUsedDataCons rdr_env tycon
-  = addUsedGREs [ gre
-                | dc <- tyConDataCons tycon
-                , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ]
-
-addUsedGRE :: Bool -> GlobalRdrElt -> RnM ()
--- Called for both local and imported things
--- Add usage *and* warn if deprecated
-addUsedGRE warn_if_deprec gre
-  = do { when warn_if_deprec (warnIfDeprecated gre)
-       ; unless (isLocalGRE gre) $
-         do { env <- getGblEnv
-            ; traceRn "addUsedGRE" (ppr gre)
-            ; updMutVar (tcg_used_gres env) (gre :) } }
-
-addUsedGREs :: [GlobalRdrElt] -> RnM ()
--- Record uses of any *imported* GREs
--- Used for recording used sub-bndrs
--- NB: no call to warnIfDeprecated; see Note [Handling of deprecations]
-addUsedGREs gres
-  | null imp_gres = return ()
-  | otherwise     = do { env <- getGblEnv
-                       ; traceRn "addUsedGREs" (ppr imp_gres)
-                       ; updMutVar (tcg_used_gres env) (imp_gres ++) }
-  where
-    imp_gres = filterOut isLocalGRE gres
-
-warnIfDeprecated :: GlobalRdrElt -> RnM ()
-warnIfDeprecated gre@(GRE { gre_imp = iss })
-  | Just imp_spec <- headMaybe iss
-  = do { dflags <- getDynFlags
-       ; this_mod <- getModule
-       ; when (wopt Opt_WarnWarningsDeprecations dflags &&
-               not (nameIsLocalOrFrom this_mod name)) $
-                   -- See Note [Handling of deprecations]
-         do { iface <- loadInterfaceForName doc name
-            ; case lookupImpDeprec iface gre of
-                Just deprText -> addDiagnostic $
-                  TcRnPragmaWarning {
-                    pragma_warning_occ = occ,
-                    pragma_warning_msg = deprText,
-                    pragma_warning_import_mod = importSpecModule imp_spec,
-                    pragma_warning_defined_mod = definedMod
-                  }
-                Nothing  -> return () } }
-  | otherwise
-  = return ()
-  where
-    occ = greOccName gre
-    name = greMangledName gre
-    definedMod = moduleName $ assertPpr (isExternalName name) (ppr name) (nameModule name)
-    doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly"
-
-lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn)
-lookupImpDeprec iface gre
-  = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus`  -- Bleat if the thing,
-    case gre_par gre of                      -- or its parent, is warn'd
-       ParentIs  p              -> mi_warn_fn (mi_final_exts iface) (nameOccName p)
-       NoParent                 -> Nothing
-
-{-
-Note [Used names with interface not loaded]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's (just) possible to find a used
-Name whose interface hasn't been loaded:
-
-a) It might be a WiredInName; in that case we may not load
-   its interface (although we could).
-
-b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger
-   These are seen as "used" by the renamer (if -XRebindableSyntax)
-   is on), but the typechecker may discard their uses
-   if in fact the in-scope fromRational is GHC.Read.fromRational,
-   (see tcPat.tcOverloadedLit), and the typechecker sees that the type
-   is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst).
-   In that obscure case it won't force the interface in.
-
-In both cases we simply don't permit deprecations;
-this is, after all, wired-in stuff.
-
-
-*********************************************************
-*                                                      *
-                GHCi support
-*                                                      *
-*********************************************************
-
-A qualified name on the command line can refer to any module at
-all: we try to load the interface if we don't already have it, just
-as if there was an "import qualified M" declaration for every
-module.
-
-For example, writing `Data.List.sort` will load the interface file for
-`Data.List` as if the user had written `import qualified Data.List`.
-
-If we fail we just return Nothing, rather than bleating
-about "attempting to use module ‘D’ (./D.hs) which is not loaded"
-which is what loadSrcInterface does.
-
-It is enabled by default and disabled by the flag
-`-fno-implicit-import-qualified`.
-
-Note [Safe Haskell and GHCi]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We DON'T do this Safe Haskell as we need to check imports. We can
-and should instead check the qualified import but at the moment
-this requires some refactoring so leave as a TODO
-
-Note [DuplicateRecordFields and -fimplicit-import-qualified]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When DuplicateRecordFields is used, a single module can export the same OccName
-multiple times, for example:
-
-  module M where
-    data S = MkS { foo :: Int }
-    data T = MkT { foo :: Int }
-
-Now if we refer to M.foo via -fimplicit-import-qualified, we need to report an
-ambiguity error.
-
--}
-
-
--- | Like 'lookupQualifiedNameGHCi' but returning at most one name, reporting an
--- ambiguity error if there are more than one.
-lookupOneQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM (Maybe GreName)
-lookupOneQualifiedNameGHCi fos rdr_name = do
-    gnames <- lookupQualifiedNameGHCi fos rdr_name
-    case gnames of
-      []              -> return Nothing
-      [gname]         -> return (Just gname)
-      (gname:gnames') -> do addNameClashErrRn rdr_name (toGRE gname NE.:| map toGRE gnames')
-                            return (Just (NormalGreName (mkUnboundNameRdr rdr_name)))
-  where
-    -- Fake a GRE so we can report a sensible name clash error if
-    -- -fimplicit-import-qualified is used with a module that exports the same
-    -- field name multiple times (see
-    -- Note [DuplicateRecordFields and -fimplicit-import-qualified]).
-    toGRE gname = GRE { gre_name = gname, gre_par = NoParent, gre_lcl = False, gre_imp = unitBag is }
-    is = ImpSpec { is_decl = ImpDeclSpec { is_mod = mod, is_as = mod, is_qual = True, is_dloc = noSrcSpan }
-                 , is_item = ImpAll }
-    -- If -fimplicit-import-qualified succeeded, the name must be qualified.
-    (mod, _) = fromMaybe (pprPanic "lookupOneQualifiedNameGHCi" (ppr rdr_name)) (isQual_maybe rdr_name)
-
-
--- | Look up *all* the names to which the 'RdrName' may refer in GHCi (using
--- @-fimplicit-import-qualified@).  This will normally be zero or one, but may
--- be more in the presence of @DuplicateRecordFields@.
-lookupQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM [GreName]
-lookupQualifiedNameGHCi fos rdr_name
-  = -- We want to behave as we would for a source file import here,
-    -- and respect hiddenness of modules/packages, hence loadSrcInterface.
-    do { dflags  <- getDynFlags
-       ; is_ghci <- getIsGHCi
-       ; go_for_it dflags is_ghci }
-
-  where
-    go_for_it dflags is_ghci
-      | Just (mod,occ) <- isQual_maybe rdr_name
-      , is_ghci
-      , gopt Opt_ImplicitImportQualified dflags   -- Enables this GHCi behaviour
-      , not (safeDirectImpsReq dflags)            -- See Note [Safe Haskell and GHCi]
-      = do { res <- loadSrcInterface_maybe doc mod NotBoot NoPkgQual
-           ; case res of
-                Succeeded iface
-                  -> return [ gname
-                            | avail <- mi_exports iface
-                            , gname <- availGreNames avail
-                            , occName gname == occ
-                            -- Include a field if it has a selector or we are looking for all fields;
-                            -- see Note [NoFieldSelectors].
-                            , allowGreName fos gname
-                            ]
-
-                _ -> -- Either we couldn't load the interface, or
-                     -- we could but we didn't find the name in it
-                     do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name)
-                        ; return [] } }
-
-      | otherwise
-      = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name)
-           ; return [] }
-
-    doc = text "Need to find" <+> ppr rdr_name
-
-{-
-Note [Looking up signature names]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-lookupSigOccRn is used for type signatures and pragmas
-Is this valid?
-  module A
-        import M( f )
-        f :: Int -> Int
-        f x = x
-It's clear that the 'f' in the signature must refer to A.f
-The Haskell98 report does not stipulate this, but it will!
-So we must treat the 'f' in the signature in the same way
-as the binding occurrence of 'f', using lookupBndrRn
-
-However, consider this case:
-        import M( f )
-        f :: Int -> Int
-        g x = x
-We don't want to say 'f' is out of scope; instead, we want to
-return the imported 'f', so that later on the renamer will
-correctly report "misplaced type sig".
-
-Note [Signatures for top level things]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-data HsSigCtxt = ... | TopSigCtxt NameSet | ....
-
-* The NameSet says what is bound in this group of bindings.
-  We can't use isLocalGRE from the GlobalRdrEnv, because of this:
-       f x = x
-       $( ...some TH splice... )
-       f :: Int -> Int
-  When we encounter the signature for 'f', the binding for 'f'
-  will be in the GlobalRdrEnv, and will be a LocalDef. Yet the
-  signature is mis-placed
-
-* For type signatures the NameSet should be the names bound by the
-  value bindings; for fixity declarations, the NameSet should also
-  include class sigs and record selectors
-
-      infix 3 `f`          -- Yes, ok
-      f :: C a => a -> a   -- No, not ok
-      class C a where
-        f :: a -> a
--}
-
-data HsSigCtxt
-  = TopSigCtxt NameSet       -- At top level, binding these names
-                             -- See Note [Signatures for top level things]
-  | LocalBindCtxt NameSet    -- In a local binding, binding these names
-  | ClsDeclCtxt   Name       -- Class decl for this class
-  | InstDeclCtxt  NameSet    -- Instance decl whose user-written method
-                             -- bindings are for these methods
-  | HsBootCtxt NameSet       -- Top level of a hs-boot file, binding these names
-  | RoleAnnotCtxt NameSet    -- A role annotation, with the names of all types
-                             -- in the group
-
-instance Outputable HsSigCtxt where
-    ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns
-    ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns
-    ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n
-    ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns
-    ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns
-    ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns
-
-lookupSigOccRn :: HsSigCtxt
-               -> Sig GhcPs
-               -> LocatedA RdrName -> RnM (LocatedA Name)
-lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig)
-
-lookupSigOccRnN :: HsSigCtxt
-               -> Sig GhcPs
-               -> LocatedN RdrName -> RnM (LocatedN Name)
-lookupSigOccRnN ctxt sig = lookupSigCtxtOccRnN ctxt (hsSigDoc sig)
-
-
--- | Lookup a name in relation to the names in a 'HsSigCtxt'
-lookupSigCtxtOccRnN :: HsSigCtxt
-                    -> SDoc         -- ^ description of thing we're looking up,
-                                   -- like "type family"
-                    -> LocatedN RdrName -> RnM (LocatedN Name)
-lookupSigCtxtOccRnN ctxt what
-  = wrapLocMA $ \ rdr_name ->
-    do { mb_name <- lookupBindGroupOcc ctxt what rdr_name
-       ; case mb_name of
-           Left err   -> do { addErr (mkTcRnNotInScope rdr_name err)
-                            ; return (mkUnboundNameRdr rdr_name) }
-           Right name -> return name }
-
--- | Lookup a name in relation to the names in a 'HsSigCtxt'
-lookupSigCtxtOccRn :: HsSigCtxt
-                   -> SDoc         -- ^ description of thing we're looking up,
-                                   -- like "type family"
-                   -> LocatedA RdrName -> RnM (LocatedA Name)
-lookupSigCtxtOccRn ctxt what
-  = wrapLocMA $ \ rdr_name ->
-    do { mb_name <- lookupBindGroupOcc ctxt what rdr_name
-       ; case mb_name of
-           Left err   -> do { addErr (mkTcRnNotInScope rdr_name err)
-                            ; return (mkUnboundNameRdr rdr_name) }
-           Right name -> return name }
-
-lookupBindGroupOcc :: HsSigCtxt
-                   -> SDoc
-                   -> RdrName -> RnM (Either NotInScopeError Name)
--- Looks up the RdrName, expecting it to resolve to one of the
--- bound names passed in.  If not, return an appropriate error message
---
--- See Note [Looking up signature names]
-lookupBindGroupOcc ctxt what rdr_name
-  | Just n <- isExact_maybe rdr_name
-  = lookupExactOcc_either n   -- allow for the possibility of missing Exacts;
-                              -- see Note [dataTcOccs and Exact Names]
-      -- Maybe we should check the side conditions
-      -- but it's a pain, and Exact things only show
-      -- up when you know what you are doing
-
-  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-  = do { n' <- lookupOrig rdr_mod rdr_occ
-       ; return (Right n') }
-
-  | otherwise
-  = case ctxt of
-      HsBootCtxt ns    -> lookup_top (`elemNameSet` ns)
-      TopSigCtxt ns    -> lookup_top (`elemNameSet` ns)
-      RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns)
-      LocalBindCtxt ns -> lookup_group ns
-      ClsDeclCtxt  cls -> lookup_cls_op cls
-      InstDeclCtxt ns  -> if uniqSetAny isUnboundName ns -- #16610
-                          then return (Right $ mkUnboundNameRdr rdr_name)
-                          else lookup_top (`elemNameSet` ns)
-  where
-    lookup_cls_op cls
-      = lookupSubBndrOcc True cls doc rdr_name
-      where
-        doc = text "method of class" <+> quotes (ppr cls)
-
-    lookup_top keep_me
-      = do { env <- getGlobalRdrEnv
-           ; dflags <- getDynFlags
-           ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
-                 names_in_scope = -- If rdr_name lacks a binding, only
-                                  -- recommend alternatives from related
-                                  -- namespaces. See #17593.
-                                  filter (\n -> nameSpacesRelated dflags WL_Anything
-                                                  (rdrNameSpace rdr_name)
-                                                  (nameNameSpace n))
-                                $ map greMangledName
-                                $ filter isLocalGRE
-                                $ globalRdrEnvElts env
-                 candidates_msg = candidates names_in_scope
-           ; case filter (keep_me . greMangledName) all_gres of
-               [] | null all_gres -> bale_out_with candidates_msg
-                  | otherwise     -> bale_out_with local_msg
-               (gre:_)            -> return (Right (greMangledName gre)) }
-
-    lookup_group bound_names  -- Look in the local envt (not top level)
-      = do { mname <- lookupLocalOccRn_maybe rdr_name
-           ; env <- getLocalRdrEnv
-           ; let candidates_msg = candidates $ localRdrEnvElts env
-           ; case mname of
-               Just n
-                 | n `elemNameSet` bound_names -> return (Right n)
-                 | otherwise                   -> bale_out_with local_msg
-               Nothing                         -> bale_out_with candidates_msg }
-
-    bale_out_with hints = return (Left $ MissingBinding what hints)
-
-    local_msg = [SuggestMoveToDeclarationSite what rdr_name]
-
-    -- Identify all similar names and produce a message listing them
-    candidates :: [Name] -> [GhcHint]
-    candidates names_in_scope
-      | (nm : nms) <- map SimilarName similar_names
-      = [SuggestSimilarNames rdr_name (nm NE.:| nms)]
-      | otherwise
-      = []
-      where
-        similar_names
-          = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name)
-                        $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x))
-                              names_in_scope
-
-
----------------
-lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)]
--- GHC extension: look up both the tycon and data con or variable.
--- Used for top-level fixity signatures and deprecations.
--- Complain if neither is in scope.
--- See Note [Fixity signature lookup]
-lookupLocalTcNames ctxt what rdr_name
-  = do { mb_gres <- mapM lookup (dataTcOccs rdr_name)
-       ; let (errs, names) = partitionEithers mb_gres
-       ; when (null names) $
-          addErr (head errs) -- Bleat about one only
-       ; return names }
-  where
-    lookup rdr = do { this_mod <- getModule
-                    ; nameEither <- lookupBindGroupOcc ctxt what rdr
-                    ; return (guard_builtin_syntax this_mod rdr nameEither) }
-
-    -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233
-    guard_builtin_syntax this_mod rdr (Right name)
-      | Just _ <- isBuiltInOcc_maybe (occName rdr)
-      , this_mod /= nameModule name
-      = Left $ TcRnIllegalBuiltinSyntax what rdr
-      | otherwise
-      = Right (rdr, name)
-    guard_builtin_syntax _ _ (Left err)
-      = Left $ mkTcRnNotInScope rdr_name err
-
-dataTcOccs :: RdrName -> [RdrName]
--- Return both the given name and the same name promoted to the TcClsName
--- namespace.  This is useful when we aren't sure which we are looking at.
--- See also Note [dataTcOccs and Exact Names]
-dataTcOccs rdr_name
-  | isDataOcc occ || isVarOcc occ
-  = [rdr_name, rdr_name_tc]
-  | otherwise
-  = [rdr_name]
-  where
-    occ = rdrNameOcc rdr_name
-    rdr_name_tc = setRdrNameSpace rdr_name tcName
-
-{-
-Note [dataTcOccs and Exact Names]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Exact RdrNames can occur in code generated by Template Haskell, and generally
-those references are, well, exact. However, the TH `Name` type isn't expressive
-enough to always track the correct namespace information, so we sometimes get
-the right Unique but wrong namespace. Thus, we still have to do the double-lookup
-for Exact RdrNames.
-
-There is also an awkward situation for built-in syntax. Example in GHCi
-   :info []
-This parses as the Exact RdrName for nilDataCon, but we also want
-the list type constructor.
-
-Note that setRdrNameSpace on an Exact name requires the Name to be External,
-which it always is for built in syntax.
--}
-
-
-
-{-
-************************************************************************
-*                                                                      *
-                        Rebindable names
-        Dealing with rebindable syntax is driven by the
-        Opt_RebindableSyntax dynamic flag.
-
-        In "deriving" code we don't want to use rebindable syntax
-        so we switch off the flag locally
-
-*                                                                      *
-************************************************************************
-
-Haskell 98 says that when you say "3" you get the "fromInteger" from the
-Standard Prelude, regardless of what is in scope.   However, to experiment
-with having a language that is less coupled to the standard prelude, we're
-trying a non-standard extension that instead gives you whatever "Prelude.fromInteger"
-happens to be in scope.  Then you can
-        import Prelude ()
-        import MyPrelude as Prelude
-to get the desired effect.
-
-At the moment this just happens for
-  * fromInteger, fromRational on literals (in expressions and patterns)
-  * negate (in expressions)
-  * minus  (arising from n+k patterns)
-  * "do" notation
-
-We store the relevant Name in the HsSyn tree, in
-  * HsIntegral/HsFractional/HsIsString
-  * NegApp
-  * NPlusKPat
-  * HsDo
-respectively.  Initially, we just store the "standard" name (GHC.Builtin.Names.fromIntegralName,
-fromRationalName etc), but the renamer changes this to the appropriate user
-name if Opt_NoImplicitPrelude is on.  That is what lookupSyntax does.
-
-We treat the original (standard) names as free-vars too, because the type checker
-checks the type of the user thing against the type of the standard thing.
--}
-
-lookupIfThenElse :: RnM (Maybe Name)
--- Looks up "ifThenElse" if rebindable syntax is on
-lookupIfThenElse
-  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
-       ; if not rebindable_on
-         then return Nothing
-         else do { ite <- lookupOccRnNone (mkVarUnqual (fsLit "ifThenElse"))
-                 ; return (Just ite) } }
-
-lookupSyntaxName :: Name                 -- ^ The standard name
-                 -> RnM (Name, FreeVars) -- ^ Possibly a non-standard name
--- Lookup a Name that may be subject to Rebindable Syntax (RS).
---
--- - When RS is off, just return the supplied (standard) Name
---
--- - When RS is on, look up the OccName of the supplied Name; return
---   what we find, or the supplied Name if there is nothing in scope
-lookupSyntaxName std_name
-  = do { rebind <- xoptM LangExt.RebindableSyntax
-       ; if not rebind
-         then return (std_name, emptyFVs)
-         else do { nm <- lookupOccRnNone (mkRdrUnqual (nameOccName std_name))
-                 ; return (nm, unitFV nm) } }
-
-lookupSyntaxExpr :: Name                          -- ^ The standard name
-                 -> RnM (HsExpr GhcRn, FreeVars)  -- ^ Possibly a non-standard name
-lookupSyntaxExpr std_name
-  = do { (name, fvs) <- lookupSyntaxName std_name
-       ; return (nl_HsVar name, fvs) }
-
-lookupSyntax :: Name                             -- The standard name
-             -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard
-                                                 -- name
-lookupSyntax std_name
-  = do { (expr, fvs) <- lookupSyntaxExpr std_name
-       ; return (mkSyntaxExpr expr, fvs) }
-
-lookupSyntaxNames :: [Name]                         -- Standard names
-     -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames
-   -- this works with CmdTop, which wants HsExprs, not SyntaxExprs
-lookupSyntaxNames std_names
-  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
-       ; if not rebindable_on then
-             return (map (HsVar noExtField . noLocA) std_names, emptyFVs)
-        else
-          do { usr_names <-
-                 mapM (lookupOccRnNone . mkRdrUnqual . nameOccName) std_names
-             ; return (map (HsVar noExtField . noLocA) usr_names, mkFVs usr_names) } }
-
-
-{-
-Note [QualifiedDo]
-~~~~~~~~~~~~~~~~~~
-QualifiedDo is implemented using the same placeholders for operation names in
-the AST that were devised for RebindableSyntax. Whenever the renamer checks
-which names to use for do syntax, it first checks if the do block is qualified
-(e.g. M.do { stmts }), in which case it searches for qualified names. If the
-qualified names are not in scope, an error is produced. If the do block is not
-qualified, the renamer does the usual search of the names which considers
-whether RebindableSyntax is enabled or not. Dealing with QualifiedDo is driven
-by the Opt_QualifiedDo dynamic flag.
--}
-
--- Lookup operations for a qualified do. If the context is not a qualified
--- do, then use lookupSyntaxExpr. See Note [QualifiedDo].
-lookupQualifiedDoExpr :: HsStmtContext p -> Name -> RnM (HsExpr GhcRn, FreeVars)
-lookupQualifiedDoExpr ctxt std_name
-  = first nl_HsVar <$> lookupQualifiedDoName ctxt std_name
-
--- Like lookupQualifiedDoExpr but for producing SyntaxExpr.
--- See Note [QualifiedDo].
-lookupQualifiedDo
-  :: HsStmtContext p
-  -> Name
-  -> RnM (SyntaxExpr GhcRn, FreeVars)
-lookupQualifiedDo ctxt std_name
-  = first mkSyntaxExpr <$> lookupQualifiedDoExpr ctxt std_name
-
-lookupNameWithQualifier :: Name -> ModuleName -> RnM (Name, FreeVars)
-lookupNameWithQualifier std_name modName
-  = do { qname <- lookupOccRnNone (mkRdrQual modName (nameOccName std_name))
-       ; return (qname, unitFV qname) }
-
--- See Note [QualifiedDo].
-lookupQualifiedDoName
-  :: HsStmtContext p
-  -> Name
-  -> RnM (Name, FreeVars)
-lookupQualifiedDoName ctxt std_name
-  = case qualifiedDoModuleName_maybe ctxt of
-      Nothing -> lookupSyntaxName std_name
-      Just modName -> lookupNameWithQualifier std_name modName
-
-
--- Error messages
-
-badOrigBinding :: RdrName -> TcRnMessage
-badOrigBinding name
-  | Just _ <- isBuiltInOcc_maybe occ = TcRnIllegalBindingOfBuiltIn occ
-  | otherwise = TcRnNameByTemplateHaskellQuote name
-  where
-    occ = rdrNameOcc $ filterCTuple name
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
deleted file mode 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ /dev/null
@@ -1,2757 +0,0 @@
-
-{-# LANGUAGE ConstraintKinds     #-}
-{-# LANGUAGE CPP                 #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE MultiWayIf          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications    #-}
-{-# LANGUAGE TypeFamilies        #-}
-{-# LANGUAGE ViewPatterns        #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
-
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-Renaming of expressions
-
-Basically dependency analysis.
-
-Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
-general, all of these functions return a renamed thing, and a set of
-free variables.
--}
-
-module GHC.Rename.Expr (
-        rnLExpr, rnExpr, rnStmts, mkExpandedExpr,
-        AnnoBody, UnexpectedStatement(..)
-   ) where
-
-import GHC.Prelude
-import GHC.Data.FastString
-
-import GHC.Rename.Bind ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS
-                        , rnMatchGroup, rnGRHS, makeMiniFixityEnv)
-import GHC.Hs
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Env ( isBrackStage )
-import GHC.Tc.Utils.Monad
-import GHC.Unit.Module ( getModule, isInteractiveModule )
-import GHC.Rename.Env
-import GHC.Rename.Fixity
-import GHC.Rename.Utils ( bindLocalNamesFV, checkDupNames
-                        , bindLocalNames
-                        , mapMaybeFvRn, mapFvRn
-                        , warnUnusedLocalBinds, typeAppErr
-                        , checkUnusedRecordWildcard
-                        , wrapGenSpan, genHsIntegralLit, genHsTyLit
-                        , genHsVar, genLHsVar, genHsApp, genHsApps
-                        , genAppType )
-import GHC.Rename.Unbound ( reportUnboundName )
-import GHC.Rename.Splice  ( rnTypedBracket, rnUntypedBracket, rnTypedSplice, rnUntypedSpliceExpr, checkThLocalName )
-import GHC.Rename.HsType
-import GHC.Rename.Pat
-import GHC.Driver.Session
-import GHC.Builtin.Names
-
-import GHC.Types.FieldLabel
-import GHC.Types.Fixity
-import GHC.Types.Id.Make
-import GHC.Types.Name
-import GHC.Types.Name.Set
-import GHC.Types.Name.Reader
-import GHC.Types.Unique.Set
-import GHC.Types.SourceText
-import GHC.Utils.Misc
-import GHC.Data.List.SetOps ( removeDups )
-import GHC.Utils.Error
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Outputable as Outputable
-import GHC.Types.SrcLoc
-import Control.Monad
-import GHC.Builtin.Types ( nilDataConName )
-import qualified GHC.LanguageExtensions as LangExt
-
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-import Data.List (unzip4, minimumBy)
-import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )
-import Data.Maybe (isJust, isNothing)
-import Control.Arrow (first)
-import Data.Ord
-import Data.Array
-import qualified Data.List.NonEmpty as NE
-
-{- Note [Handling overloaded and rebindable constructs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For overloaded constructs (overloaded literals, lists, strings), and
-rebindable constructs (e.g. if-then-else), our general plan is this,
-using overloaded labels #foo as an example:
-
-* In the RENAMER: transform
-      HsOverLabel "foo"
-      ==> XExpr (HsExpansion (HsOverLabel #foo)
-                             (fromLabel `HsAppType` "foo"))
-  We write this more compactly in concrete-syntax form like this
-      #foo  ==>  fromLabel @"foo"
-
-  Recall that in (HsExpansion orig expanded), 'orig' is the original term
-  the user wrote, and 'expanded' is the expanded or desugared version
-  to be typechecked.
-
-* In the TYPECHECKER: typecheck the expansion, in this case
-      fromLabel @"foo"
-  The typechecker (and desugarer) will never see HsOverLabel
-
-In effect, the renamer does a bit of desugaring. Recall GHC.Hs.Expr
-Note [Rebindable syntax and HsExpansion], which describes the use of HsExpansion.
-
-RebindableSyntax:
-  If RebindableSyntax is off we use the built-in 'fromLabel', defined in
-     GHC.Builtin.Names.fromLabelClassOpName
-  If RebindableSyntax if ON, we look up "fromLabel" in the environment
-     to get whichever one is in scope.
-This is accomplished by lookupSyntaxName, and it applies to all the
-constructs below.
-
-See also Note [Handling overloaded and rebindable patterns] in GHC.Rename.Pat
-for the story with patterns.
-
-Here are the expressions that we transform in this way. Some are uniform,
-but several have a little bit of special treatment:
-
-* HsIf (if-the-else)
-     if b then e1 else e2  ==>  ifThenElse b e1 e2
-  We do this /only/ if rebindable syntax is on, because the coverage
-  checker looks for HsIf (see GHC.HsToCore.Ticks.addTickHsExpr)
-  That means the typechecker and desugarer need to understand HsIf
-  for the non-rebindable-syntax case.
-
-* OverLabel (overloaded labels, #lbl)
-     #lbl  ==>  fromLabel @"lbl"
-  As ever, we use lookupSyntaxName to look up 'fromLabel'
-  See Note [Overloaded labels]
-
-* ExplicitList (explicit lists [a,b,c])
-  When (and only when) OverloadedLists is on
-     [e1,e2]  ==>  fromListN 2 [e1,e2]
-  NB: the type checker and desugarer still see ExplicitList,
-      but to them it always means the built-in lists.
-
-* SectionL and SectionR (left and right sections)
-     (`op` e) ==> rightSection op e
-     (e `op`) ==> leftSection  (op e)
-  where `leftSection` and `rightSection` are representation-polymorphic
-  wired-in Ids. See Note [Left and right sections]
-
-* It's a bit painful to transform `OpApp e1 op e2` to a `HsExpansion`
-  form, because the renamer does precedence rearrangement after name
-  resolution.  So the renamer leaves an OpApp as an OpApp.
-
-  The typechecker turns `OpApp` into a use of `HsExpansion`
-  on the fly, in GHC.Tc.Gen.Head.splitHsApps.  RebindableSyntax
-  does not affect this.
-
-* RecordUpd: we desugar record updates into case expressions,
-  in GHC.Tc.Gen.Expr.tcExpr.
-
-  Example:
-
-    data T p q = T1 { x :: Int, y :: Bool, z :: Char }
-               | T2 { v :: Char }
-               | T3 { x :: Int }
-               | T4 { p :: Float, y :: Bool, x :: Int }
-               | T5
-
-    e { x=e1, y=e2 }
-      ===>
-    let { x' = e1; y' = e2 } in
-    case e of
-       T1 _ _ z -> T1 x' y' z
-       T4 p _ _ -> T4 p y' x'
-
-  See Note [Record Updates] in GHC.Tc.Gen.Expr for more details.
-
-  This is done in the typechecker, not the renamer, for two reasons:
-
-    - (Until we implement GHC proposal #366)
-      We need to know the type of the record to disambiguate its fields.
-
-    - We use the type signature of the data constructor to provide IdSigs
-      to the let-bound variables (x', y' in the example above). This is
-      needed to accept programs such as
-
-        data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int }
-        foo r = r { f = \ k -> (k 3, k 'x') }
-
-      in which an updated field has a higher-rank type.
-      See Wrinkle [Using IdSig] in Note [Record Updates] in GHC.Tc.Gen.Expr.
-
-Note [Overloaded labels]
-~~~~~~~~~~~~~~~~~~~~~~~~
-For overloaded labels, note that we /only/ apply `fromLabel` to the
-Symbol argument, so the resulting expression has type
-    fromLabel @"foo" :: forall a. IsLabel "foo" a => a
-Now ordinary Visible Type Application can be used to instantiate the 'a':
-the user may have written (#foo @Int).
-
-Notice that this all works fine in a kind-polymorphic setting (#19154).
-Suppose we have
-    fromLabel :: forall {k1} {k2} (a:k1). blah
-
-Then we want to instantiate those inferred quantifiers k1,k2, before
-type-applying to "foo", so we get
-    fromLabel @Symbol @blah @"foo" ...
-
-And those inferred kind quantifiers will indeed be instantiated when we
-typecheck the renamed-syntax call (fromLabel @"foo").
--}
-
-{-
-************************************************************************
-*                                                                      *
-\subsubsection{Expressions}
-*                                                                      *
-************************************************************************
--}
-
-rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars)
-rnExprs ls = rnExprs' ls emptyUniqSet
- where
-  rnExprs' [] acc = return ([], acc)
-  rnExprs' (expr:exprs) acc =
-   do { (expr', fvExpr) <- rnLExpr expr
-        -- Now we do a "seq" on the free vars because typically it's small
-        -- or empty, especially in very long lists of constants
-      ; let  acc' = acc `plusFV` fvExpr
-      ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'
-      ; return (expr':exprs', fvExprs) }
-
--- Variables. We look up the variable and return the resulting name.
-
-rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
-rnLExpr = wrapLocFstMA rnExpr
-
-rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
-
-finishHsVar :: LocatedA Name -> RnM (HsExpr GhcRn, FreeVars)
--- Separated from rnExpr because it's also used
--- when renaming infix expressions
-finishHsVar (L l name)
- = do { this_mod <- getModule
-      ; when (nameIsLocalOrFrom this_mod name) $
-        checkThLocalName name
-      ; return (HsVar noExtField (L (la2na l) name), unitFV name) }
-
-rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
-rnUnboundVar v = do
-  deferOutofScopeVariables <- goptM Opt_DeferOutOfScopeVariables
-  unless (isUnqual v || deferOutofScopeVariables) (reportUnboundName v >> return ())
-  return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)
-
-rnExpr (HsVar _ (L l v))
-  = do { dflags <- getDynFlags
-       ; mb_name <- lookupExprOccRn v
-
-       ; case mb_name of {
-           Nothing -> rnUnboundVar v ;
-           Just (NormalGreName name)
-              | name == nilDataConName -- Treat [] as an ExplicitList, so that
-                                       -- OverloadedLists works correctly
-                                       -- Note [Empty lists] in GHC.Hs.Expr
-              , xopt LangExt.OverloadedLists dflags
-              -> rnExpr (ExplicitList noAnn [])
-
-              | otherwise
-              -> finishHsVar (L (na2la l) name) ;
-            Just (FieldGreName fl)
-              -> do { let sel_name = flSelector fl
-                    ; this_mod <- getModule
-                    ; when (nameIsLocalOrFrom this_mod sel_name) $
-                        checkThLocalName sel_name
-                    ; return ( HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name)
-                    }
-         }
-       }
-
-rnExpr (HsIPVar x v)
-  = return (HsIPVar x v, emptyFVs)
-
-rnExpr (HsUnboundVar _ v)
-  = return (HsUnboundVar noExtField v, emptyFVs)
-
--- HsOverLabel: see Note [Handling overloaded and rebindable constructs]
-rnExpr (HsOverLabel _ v)
-  = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName
-       ; return ( mkExpandedExpr (HsOverLabel noAnn v) $
-                  HsAppType noExtField (genLHsVar from_label) noHsTok hs_ty_arg
-                , fvs ) }
-  where
-    hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $
-                HsTyLit noExtField (HsStrTy NoSourceText v)
-
-rnExpr (HsLit x lit@(HsString src s))
-  = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
-       ; if opt_OverloadedStrings then
-            rnExpr (HsOverLit x (mkHsIsString src s))
-         else do {
-            ; rnLit lit
-            ; return (HsLit x (convertLit lit), emptyFVs) } }
-
-rnExpr (HsLit x lit)
-  = do { rnLit lit
-       ; return (HsLit x(convertLit lit), emptyFVs) }
-
-rnExpr (HsOverLit x lit)
-  = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]
-       ; case mb_neg of
-              Nothing -> return (HsOverLit x lit', fvs)
-              Just neg ->
-                 return (HsApp noComments (noLocA neg) (noLocA (HsOverLit x lit'))
-                        , fvs ) }
-
-rnExpr (HsApp x fun arg)
-  = do { (fun',fvFun) <- rnLExpr fun
-       ; (arg',fvArg) <- rnLExpr arg
-       ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }
-
-rnExpr (HsAppType _ fun at arg)
-  = do { type_app <- xoptM LangExt.TypeApplications
-       ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg
-       ; (fun',fvFun) <- rnLExpr fun
-       ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
-       ; return (HsAppType NoExtField fun' at arg', fvFun `plusFV` fvArg) }
-
-rnExpr (OpApp _ e1 op e2)
-  = do  { (e1', fv_e1) <- rnLExpr e1
-        ; (e2', fv_e2) <- rnLExpr e2
-        ; (op', fv_op) <- rnLExpr op
-
-        -- Deal with fixity
-        -- When renaming code synthesised from "deriving" declarations
-        -- we used to avoid fixity stuff, but we can't easily tell any
-        -- more, so I've removed the test.  Adding HsPars in GHC.Tc.Deriv.Generate
-        -- should prevent bad things happening.
-        ; fixity <- case op' of
-              L _ (HsVar _ (L _ n)) -> lookupFixityRn n
-              L _ (HsRecSel _ f)    -> lookupFieldFixityRn f
-              _ -> return (Fixity NoSourceText minPrecedence InfixL)
-                   -- c.f. lookupFixity for unbound
-
-        ; lexical_negation <- xoptM LangExt.LexicalNegation
-        ; let negation_handling | lexical_negation = KeepNegationIntact
-                                | otherwise = ReassociateNegation
-        ; final_e <- mkOpAppRn negation_handling e1' op' fixity e2'
-        ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
-
-rnExpr (NegApp _ e _)
-  = do { (e', fv_e)         <- rnLExpr e
-       ; (neg_name, fv_neg) <- lookupSyntax negateName
-       ; final_e            <- mkNegAppRn e' neg_name
-       ; return (final_e, fv_e `plusFV` fv_neg) }
-
-------------------------------------------
--- Record dot syntax
-
-rnExpr (HsGetField _ e f)
- = do { (getField, fv_getField) <- lookupSyntaxName getFieldName
-      ; (e, fv_e) <- rnLExpr e
-      ; let f' = rnDotFieldOcc f
-      ; return ( mkExpandedExpr
-                   (HsGetField noExtField e f')
-                   (mkGetField getField e (fmap (unLoc . dfoLabel) f'))
-               , fv_e `plusFV` fv_getField ) }
-
-rnExpr (HsProjection _ fs)
-  = do { (getField, fv_getField) <- lookupSyntaxName getFieldName
-       ; circ <- lookupOccRn compose_RDR
-       ; let fs' = fmap rnDotFieldOcc fs
-       ; return ( mkExpandedExpr
-                    (HsProjection noExtField fs')
-                    (mkProjection getField circ (fmap (fmap (unLoc . dfoLabel)) fs'))
-                , unitFV circ `plusFV` fv_getField) }
-
-------------------------------------------
--- Template Haskell extensions
-rnExpr e@(HsTypedBracket _ br_body)   = rnTypedBracket e br_body
-rnExpr e@(HsUntypedBracket _ br_body) = rnUntypedBracket e br_body
-
-rnExpr (HsTypedSplice   _ splice) = rnTypedSplice splice
-rnExpr (HsUntypedSplice _ splice) = rnUntypedSpliceExpr splice
-
----------------------------------------------
---      Sections
--- See Note [Parsing sections] in GHC.Parser
-rnExpr (HsPar x lpar (L loc (section@(SectionL {}))) rpar)
-  = do  { (section', fvs) <- rnSection section
-        ; return (HsPar x lpar (L loc section') rpar, fvs) }
-
-rnExpr (HsPar x lpar (L loc (section@(SectionR {}))) rpar)
-  = do  { (section', fvs) <- rnSection section
-        ; return (HsPar x lpar (L loc section') rpar, fvs) }
-
-rnExpr (HsPar x lpar e rpar)
-  = do  { (e', fvs_e) <- rnLExpr e
-        ; return (HsPar x lpar e' rpar, fvs_e) }
-
-rnExpr expr@(SectionL {})
-  = do  { addErr (sectionErr expr); rnSection expr }
-rnExpr expr@(SectionR {})
-  = do  { addErr (sectionErr expr); rnSection expr }
-
----------------------------------------------
-rnExpr (HsPragE x prag expr)
-  = do { (expr', fvs_expr) <- rnLExpr expr
-       ; return (HsPragE x (rn_prag prag) expr', fvs_expr) }
-  where
-    rn_prag :: HsPragE GhcPs -> HsPragE GhcRn
-    rn_prag (HsPragSCC x ann) = HsPragSCC x ann
-
-rnExpr (HsLam x matches)
-  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
-       ; return (HsLam x matches', fvMatch) }
-
-rnExpr (HsLamCase x lc_variant matches)
-  = do { (matches', fvs_ms) <- rnMatchGroup (LamCaseAlt lc_variant) rnLExpr matches
-       ; return (HsLamCase x lc_variant matches', fvs_ms) }
-
-rnExpr (HsCase _ expr matches)
-  = do { (new_expr, e_fvs) <- rnLExpr expr
-       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
-       ; return (HsCase noExtField new_expr new_matches, e_fvs `plusFV` ms_fvs) }
-
-rnExpr (HsLet _ tkLet binds tkIn expr)
-  = rnLocalBindsAndThen binds $ \binds' _ -> do
-      { (expr',fvExpr) <- rnLExpr expr
-      ; return (HsLet noExtField tkLet binds' tkIn expr', fvExpr) }
-
-rnExpr (HsDo _ do_or_lc (L l stmts))
- = do { ((stmts1, _), fvs1) <-
-          rnStmtsWithFreeVars (HsDoStmt do_or_lc) rnExpr stmts
-            (\ _ -> return ((), emptyFVs))
-      ; (pp_stmts, fvs2) <- postProcessStmtsForApplicativeDo do_or_lc stmts1
-      ; return ( HsDo noExtField do_or_lc (L l pp_stmts), fvs1 `plusFV` fvs2 ) }
-
--- ExplicitList: see Note [Handling overloaded and rebindable constructs]
-rnExpr (ExplicitList _ exps)
-  = do  { (exps', fvs) <- rnExprs exps
-        ; opt_OverloadedLists <- xoptM LangExt.OverloadedLists
-        ; if not opt_OverloadedLists
-          then return  (ExplicitList noExtField exps', fvs)
-          else
-    do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
-       ; let rn_list  = ExplicitList noExtField exps'
-             lit_n    = mkIntegralLit (length exps)
-             hs_lit   = genHsIntegralLit lit_n
-             exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list]
-       ; return ( mkExpandedExpr rn_list exp_list
-                , fvs `plusFV` fvs') } }
-
-rnExpr (ExplicitTuple _ tup_args boxity)
-  = do { checkTupleSection tup_args
-       ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
-       ; return (ExplicitTuple noExtField tup_args' boxity, plusFVs fvs) }
-  where
-    rnTupArg (Present x e) = do { (e',fvs) <- rnLExpr e
-                                ; return (Present x e', fvs) }
-    rnTupArg (Missing _) = return (Missing noExtField, emptyFVs)
-
-rnExpr (ExplicitSum _ alt arity expr)
-  = do { (expr', fvs) <- rnLExpr expr
-       ; return (ExplicitSum noExtField alt arity expr', fvs) }
-
-rnExpr (RecordCon { rcon_con = con_id
-                  , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
-  = do { con_lname@(L _ con_name) <- lookupLocatedOccRnConstr con_id
-       ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
-       ; (flds', fvss) <- mapAndUnzipM rn_field flds
-       ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
-       ; return (RecordCon { rcon_ext = noExtField
-                           , rcon_con = con_lname, rcon_flds = rec_binds' }
-                , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
-  where
-    mk_hs_var l n = HsVar noExtField (L (noAnnSrcSpan l) n)
-    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hfbRHS fld)
-                            ; return (L l (fld { hfbRHS = arg' }), fvs) }
-
-rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
-  = case rbinds of
-      Left flds -> -- 'OverloadedRecordUpdate' is not in effect. Regular record update.
-        do  { ; (e, fv_e) <- rnLExpr expr
-              ; (rs, fv_rs) <- rnHsRecUpdFields flds
-              ; return ( RecordUpd noExtField e (Left rs), fv_e `plusFV` fv_rs )
-            }
-      Right flds ->  -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring.
-        do { ; unlessXOptM LangExt.RebindableSyntax $
-                 addErr TcRnNoRebindableSyntaxRecordDot
-             ; let punnedFields = [fld | (L _ fld) <- flds, hfbPun fld]
-             ; punsEnabled <-xoptM LangExt.NamedFieldPuns
-             ; unless (null punnedFields || punsEnabled) $
-                 addErr TcRnNoFieldPunsRecordDot
-             ; (getField, fv_getField) <- lookupSyntaxName getFieldName
-             ; (setField, fv_setField) <- lookupSyntaxName setFieldName
-             ; (e, fv_e) <- rnLExpr expr
-             ; (us, fv_us) <- rnHsUpdProjs flds
-             ; return ( mkExpandedExpr
-                          (RecordUpd noExtField e (Right us))
-                          (mkRecordDotUpd getField setField e us)
-                         , plusFVs [fv_getField, fv_setField, fv_e, fv_us] )
-             }
-
-rnExpr (ExprWithTySig _ expr pty)
-  = do  { (pty', fvTy)    <- rnHsSigWcType ExprWithTySigCtx pty
-        ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
-                             rnLExpr expr
-        ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) }
-
--- HsIf: see Note [Handling overloaded and rebindable constructs]
--- Because of the coverage checker it is most convenient /not/ to
--- expand HsIf; unless we are in rebindable syntax.
-rnExpr (HsIf _ p b1 b2)
-  = do { (p',  fvP)  <- rnLExpr p
-       ; (b1', fvB1) <- rnLExpr b1
-       ; (b2', fvB2) <- rnLExpr b2
-       ; let fvs_if = plusFVs [fvP, fvB1, fvB2]
-             rn_if  = HsIf noExtField  p' b1' b2'
-
-       -- Deal with rebindable syntax
-       -- See Note [Handling overloaded and rebindable constructs]
-       ; mb_ite <- lookupIfThenElse
-       ; case mb_ite of
-            Nothing  -- Non rebindable-syntax case
-              -> return (rn_if, fvs_if)
-
-            Just ite_name   -- Rebindable-syntax case
-              -> do { let ds_if = genHsApps ite_name [p', b1', b2']
-                          fvs   = plusFVs [fvs_if, unitFV ite_name]
-                    ; return (mkExpandedExpr rn_if ds_if, fvs) } }
-
-rnExpr (HsMultiIf _ alts)
-  = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
-       ; return (HsMultiIf noExtField alts', fvs) }
-
-rnExpr (ArithSeq _ _ seq)
-  = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
-       ; (new_seq, fvs) <- rnArithSeq seq
-       ; if opt_OverloadedLists
-           then do {
-            ; (from_list_name, fvs') <- lookupSyntax fromListName
-            ; return (ArithSeq noExtField (Just from_list_name) new_seq
-                     , fvs `plusFV` fvs') }
-           else
-            return (ArithSeq noExtField Nothing new_seq, fvs) }
-
-{-
-************************************************************************
-*                                                                      *
-        Static values
-*                                                                      *
-************************************************************************
-
-For the static form we check that it is not used in splices.
-We also collect the free variables of the term which come from
-this module. See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
--}
-
-rnExpr e@(HsStatic _ expr) = do
-    -- Normally, you wouldn't be able to construct a static expression without
-    -- first enabling -XStaticPointers in the first place, since that extension
-    -- is what makes the parser treat `static` as a keyword. But this is not a
-    -- sufficient safeguard, as one can construct static expressions by another
-    -- mechanism: Template Haskell (see #14204). To ensure that GHC is
-    -- absolutely prepared to cope with static forms, we check for
-    -- -XStaticPointers here as well.
-    unlessXOptM LangExt.StaticPointers $
-      addErr $ TcRnIllegalStaticExpression e
-    (expr',fvExpr) <- rnLExpr expr
-    stage <- getStage
-    case stage of
-      Splice _ -> addErr $ TcRnIllegalStaticFormInSplice e
-      _ -> return ()
-    mod <- getModule
-    let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr
-    return (HsStatic fvExpr' expr', fvExpr)
-
-{-
-************************************************************************
-*                                                                      *
-        Arrow notation
-*                                                                      *
-********************************************************************* -}
-
-rnExpr (HsProc x pat body)
-  = newArrowScope $
-    rnPat (ArrowMatchCtxt ProcExpr) pat $ \ pat' -> do
-      { (body',fvBody) <- rnCmdTop body
-      ; return (HsProc x pat' body', fvBody) }
-
-rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
-        -- HsWrap
-
-{-
-************************************************************************
-*                                                                      *
-        Operator sections
-*                                                                      *
-********************************************************************* -}
-
-
-rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
--- See Note [Parsing sections] in GHC.Parser
--- Also see Note [Handling overloaded and rebindable constructs]
-
-rnSection section@(SectionR x op expr)
-  -- See Note [Left and right sections]
-  = do  { (op', fvs_op)     <- rnLExpr op
-        ; (expr', fvs_expr) <- rnLExpr expr
-        ; checkSectionPrec InfixR section op' expr'
-        ; let rn_section = SectionR x op' expr'
-              ds_section = genHsApps rightSectionName [op',expr']
-        ; return ( mkExpandedExpr rn_section ds_section
-                 , fvs_op `plusFV` fvs_expr) }
-
-rnSection section@(SectionL x expr op)
-  -- See Note [Left and right sections]
-  = do  { (expr', fvs_expr) <- rnLExpr expr
-        ; (op', fvs_op)     <- rnLExpr op
-        ; checkSectionPrec InfixL section op' expr'
-        ; postfix_ops <- xoptM LangExt.PostfixOperators
-                        -- Note [Left and right sections]
-        ; let rn_section = SectionL x expr' op'
-              ds_section
-                | postfix_ops = HsApp noAnn op' expr'
-                | otherwise   = genHsApps leftSectionName
-                                   [wrapGenSpan $ HsApp noAnn op' expr']
-        ; return ( mkExpandedExpr rn_section ds_section
-                 , fvs_op `plusFV` fvs_expr) }
-
-rnSection other = pprPanic "rnSection" (ppr other)
-
-{- Note [Left and right sections]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Dealing with left sections (x *) and right sections (* x) is
-surprisingly fiddly.  We expand like this
-     (`op` e) ==> rightSection op e
-     (e `op`) ==> leftSection  (op e)
-
-Using an auxiliary function in this way avoids the awkwardness of
-generating a lambda, esp if `e` is a redex, so we *don't* want
-to generate `(\x -> op x e)`. See Historical
-Note [Desugaring operator sections]
-
-Here are their definitions:
-   leftSection :: forall r1 r2 n (a::TYPE r1) (b::TYPE r2).
-                  (a %n-> b) -> a %n-> b
-   leftSection f x = f x
-
-   rightSection :: forall r1 r2 r3 n1 n2 (a::TYPE r1) (b::TYPE r2) (c::TYPE r3).
-                   (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c
-   rightSection f y x = f x y
-
-Note the wrinkles:
-
-* We do /not/ use lookupSyntaxName, which would make left and right
-  section fall under RebindableSyntax.  Reason: it would be a user-
-  facing change, and there are some tricky design choices (#19354).
-  Plus, infix operator applications would be trickier to make
-  rebindable, so it'd be inconsistent to do so for sections.
-
-  TL;DR: we still use the renamer-expansion mechanism for operator
-  sections, but only to eliminate special-purpose code paths in the
-  renamer and desugarer.
-
-* leftSection and rightSection must be representation-polymorphic, to allow
-  (+# 4#) and (4# +#) to work. See
-  Note [Wired-in Ids for rebindable syntax] in GHC.Types.Id.Make.
-
-* leftSection and rightSection must be multiplicity-polymorphic.
-  (Test linear/should_compile/OldList showed this up.)
-
-* Because they are representation-polymorphic, we have to define them
-  as wired-in Ids, with compulsory inlining.  See
-  GHC.Types.Id.Make.leftSectionId, rightSectionId.
-
-* leftSection is just ($) really; but unlike ($) it is
-  representation-polymorphic in the result type, so we can write
-  `(x +#)`, say.
-
-* The type of leftSection must have an arrow in its first argument,
-  because (x `ord`) should be rejected, because ord does not take two
-  arguments
-
-* It's important that we define leftSection in an eta-expanded way,
-  (i.e. not leftSection f = f), so that
-      (True `undefined`) `seq` ()
-      = (leftSection (undefined True) `seq` ())
-  evaluates to () and not undefined
-
-* If PostfixOperators is ON, then we expand a left section like this:
-      (e `op`)  ==>   op e
-  with no auxiliary function at all.  Simple!
-
-* leftSection and rightSection switch on ImpredicativeTypes locally,
-  during Quick Look; see GHC.Tc.Gen.App.wantQuickLook. Consider
-  test DeepSubsumption08:
-     type Setter st t a b = forall f. Identical f => blah
-     (.~) :: Setter s t a b -> b -> s -> t
-     clear :: Setter a a' b (Maybe b') -> a -> a'
-     clear = (.~ Nothing)
-   The expansion look like (rightSection (.~) Nothing).  So we must
-   instantiate `rightSection` first type argument to a polytype!
-   Hence the special magic in App.wantQuickLook.
-
-Historical Note [Desugaring operator sections]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This Note explains some historical trickiness in desugaring left and
-right sections.  That trickiness has completely disappeared now that
-we desugar to calls to 'leftSection` and `rightSection`, but I'm
-leaving it here to remind us how nice the new story is.
-
-Desugaring left sections with -XPostfixOperators is straightforward: convert
-(expr `op`) to (op expr).
-
-Without -XPostfixOperators it's a bit more tricky. At first it looks as if we
-can convert
-
-    (expr `op`)
-
-naively to
-
-    \x -> op expr x
-
-But no!  expr might be a redex, and we can lose laziness badly this
-way.  Consider
-
-    map (expr `op`) xs
-
-for example. If expr were a redex then eta-expanding naively would
-result in multiple evaluations where the user might only have expected one.
-
-So we convert instead to
-
-    let y = expr in \x -> op y x
-
-Also, note that we must do this for both right and (perhaps surprisingly) left
-sections. Why are left sections necessary? Consider the program (found in #18151),
-
-    seq (True `undefined`) ()
-
-according to the Haskell Report this should reduce to () (as it specifies
-desugaring via eta expansion). However, if we fail to eta expand we will rather
-bottom. Consequently, we must eta expand even in the case of a left section.
-
-If `expr` is actually just a variable, say, then the simplifier
-will inline `y`, eliminating the redundant `let`.
-
-Note that this works even in the case that `expr` is unlifted. In this case
-bindNonRec will automatically do the right thing, giving us:
-
-    case expr of y -> (\x -> op y x)
-
-See #18151.
--}
-
-{-
-************************************************************************
-*                                                                      *
-        Field Labels
-*                                                                      *
-************************************************************************
--}
-
-rnDotFieldOcc :: LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> LocatedAn NoEpAnns (DotFieldOcc GhcRn)
-rnDotFieldOcc (L l (DotFieldOcc x label)) = L l (DotFieldOcc x label)
-
-rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn
-rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnDotFieldOcc fls)
-
-{-
-************************************************************************
-*                                                                      *
-        Arrow commands
-*                                                                      *
-************************************************************************
--}
-
-rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
-rnCmdArgs [] = return ([], emptyFVs)
-rnCmdArgs (arg:args)
-  = do { (arg',fvArg) <- rnCmdTop arg
-       ; (args',fvArgs) <- rnCmdArgs args
-       ; return (arg':args', fvArg `plusFV` fvArgs) }
-
-rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
-rnCmdTop = wrapLocFstMA rnCmdTop'
- where
-  rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars)
-  rnCmdTop' (HsCmdTop _ cmd)
-   = do { (cmd', fvCmd) <- rnLCmd cmd
-        ; let cmd_names = [arrAName, composeAName, firstAName] ++
-                          nameSetElemsStable (methodNamesCmd (unLoc cmd'))
-        -- Generate the rebindable syntax for the monad
-        ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
-
-        ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd',
-                  fvCmd `plusFV` cmd_fvs) }
-
-rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
-rnLCmd = wrapLocFstMA rnCmd
-
-rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
-
-rnCmd (HsCmdArrApp _ arrow arg ho rtl)
-  = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
-       ; (arg',fvArg) <- rnLExpr arg
-       ; return (HsCmdArrApp noExtField arrow' arg' ho rtl,
-                 fvArrow `plusFV` fvArg) }
-  where
-    select_arrow_scope tc = case ho of
-        HsHigherOrderApp -> tc
-        HsFirstOrderApp  -> escapeArrowScope tc
-        -- See Note [Escaping the arrow scope] in GHC.Tc.Types
-        -- Before renaming 'arrow', use the environment of the enclosing
-        -- proc for the (-<) case.
-        -- Local bindings, inside the enclosing proc, are not in scope
-        -- inside 'arrow'.  In the higher-order case (-<<), they are.
-
--- infix form
-rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2])
-  = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
-       ; let L _ (HsVar _ (L _ op_name)) = op'
-       ; (arg1',fv_arg1) <- rnCmdTop arg1
-       ; (arg2',fv_arg2) <- rnCmdTop arg2
-        -- Deal with fixity
-       ; fixity <- lookupFixityRn op_name
-       ; final_e <- mkOpFormRn arg1' op' fixity arg2'
-       ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
-
-rnCmd (HsCmdArrForm _ op f fixity cmds)
-  = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
-       ; (cmds',fvCmds) <- rnCmdArgs cmds
-       ; return ( HsCmdArrForm noExtField op' f fixity cmds'
-                , fvOp `plusFV` fvCmds) }
-
-rnCmd (HsCmdApp x fun arg)
-  = do { (fun',fvFun) <- rnLCmd  fun
-       ; (arg',fvArg) <- rnLExpr arg
-       ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) }
-
-rnCmd (HsCmdLam _ matches)
-  = do { (matches', fvMatch) <- rnMatchGroup (ArrowMatchCtxt KappaExpr) rnLCmd matches
-       ; return (HsCmdLam noExtField matches', fvMatch) }
-
-rnCmd (HsCmdPar x lpar e rpar)
-  = do  { (e', fvs_e) <- rnLCmd e
-        ; return (HsCmdPar x lpar e' rpar, fvs_e) }
-
-rnCmd (HsCmdCase _ expr matches)
-  = do { (new_expr, e_fvs) <- rnLExpr expr
-       ; (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches
-       ; return (HsCmdCase noExtField new_expr new_matches
-                , e_fvs `plusFV` ms_fvs) }
-
-rnCmd (HsCmdLamCase x lc_variant matches)
-  = do { (new_matches, ms_fvs) <-
-           rnMatchGroup (ArrowMatchCtxt $ ArrowLamCaseAlt lc_variant) rnLCmd matches
-       ; return (HsCmdLamCase x lc_variant new_matches, ms_fvs) }
-
-rnCmd (HsCmdIf _ _ p b1 b2)
-  = do { (p', fvP) <- rnLExpr p
-       ; (b1', fvB1) <- rnLCmd b1
-       ; (b2', fvB2) <- rnLCmd b2
-
-       ; mb_ite <- lookupIfThenElse
-       ; let (ite, fvITE) = case mb_ite of
-                Just ite_name -> (mkRnSyntaxExpr ite_name, unitFV ite_name)
-                Nothing       -> (NoSyntaxExprRn,          emptyFVs)
-
-       ; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
-
-rnCmd (HsCmdLet _ tkLet binds tkIn cmd)
-  = rnLocalBindsAndThen binds $ \ binds' _ -> do
-      { (cmd',fvExpr) <- rnLCmd cmd
-      ; return (HsCmdLet noExtField tkLet binds' tkIn cmd', fvExpr) }
-
-rnCmd (HsCmdDo _ (L l stmts))
-  = do  { ((stmts', _), fvs) <-
-            rnStmts ArrowExpr rnCmd stmts (\ _ -> return ((), emptyFVs))
-        ; return ( HsCmdDo noExtField (L l stmts'), fvs ) }
-
----------------------------------------------------
-type CmdNeeds = FreeVars        -- Only inhabitants are
-                                --      appAName, choiceAName, loopAName
-
--- find what methods the Cmd needs (loop, choice, apply)
-methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds
-methodNamesLCmd = methodNamesCmd . unLoc
-
-methodNamesCmd :: HsCmd GhcRn -> CmdNeeds
-
-methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl)
-  = emptyFVs
-methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl)
-  = unitFV appAName
-methodNamesCmd (HsCmdArrForm {}) = emptyFVs
-
-methodNamesCmd (HsCmdPar _ _ c _) = methodNamesLCmd c
-
-methodNamesCmd (HsCmdIf _ _ _ c1 c2)
-  = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
-
-methodNamesCmd (HsCmdLet _ _ _ _ c)      = methodNamesLCmd c
-methodNamesCmd (HsCmdDo _ (L _ stmts))   = methodNamesStmts stmts
-methodNamesCmd (HsCmdApp _ c _)          = methodNamesLCmd c
-methodNamesCmd (HsCmdLam _ match)        = methodNamesMatch match
-
-methodNamesCmd (HsCmdCase _ _ matches)
-  = methodNamesMatch matches `addOneFV` choiceAName
-methodNamesCmd (HsCmdLamCase _ _ matches)
-  = methodNamesMatch matches `addOneFV` choiceAName
-
---methodNamesCmd _ = emptyFVs
-   -- Other forms can't occur in commands, but it's not convenient
-   -- to error here so we just do what's convenient.
-   -- The type checker will complain later
-
----------------------------------------------------
-methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
-methodNamesMatch (MG { mg_alts = L _ ms })
-  = plusFVs (map do_one ms)
- where
-    do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss
-
--------------------------------------------------
--- gaw 2004
-methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
-methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)
-
--------------------------------------------------
-
-methodNamesGRHS :: LocatedAn NoEpAnns (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
-methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs
-
----------------------------------------------------
-methodNamesStmts :: [LStmtLR GhcRn GhcRn (LHsCmd GhcRn)] -> FreeVars
-methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
-
----------------------------------------------------
-methodNamesLStmt :: LStmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
-methodNamesLStmt = methodNamesStmt . unLoc
-
-methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
-methodNamesStmt (LastStmt _ cmd _ _)           = methodNamesLCmd cmd
-methodNamesStmt (BodyStmt _ cmd _ _)           = methodNamesLCmd cmd
-methodNamesStmt (BindStmt _ _ cmd)             = methodNamesLCmd cmd
-methodNamesStmt (RecStmt { recS_stmts = L _ stmts }) =
-  methodNamesStmts stmts `addOneFV` loopAName
-methodNamesStmt (LetStmt {})                   = emptyFVs
-methodNamesStmt (ParStmt {})                   = emptyFVs
-methodNamesStmt (TransStmt {})                 = emptyFVs
-methodNamesStmt ApplicativeStmt{}              = emptyFVs
-   -- ParStmt and TransStmt can't occur in commands, but it's not
-   -- convenient to error here so we just do what's convenient
-
-{-
-************************************************************************
-*                                                                      *
-        Arithmetic sequences
-*                                                                      *
-************************************************************************
--}
-
-rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)
-rnArithSeq (From expr)
- = do { (expr', fvExpr) <- rnLExpr expr
-      ; return (From expr', fvExpr) }
-
-rnArithSeq (FromThen expr1 expr2)
- = do { (expr1', fvExpr1) <- rnLExpr expr1
-      ; (expr2', fvExpr2) <- rnLExpr expr2
-      ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
-
-rnArithSeq (FromTo expr1 expr2)
- = do { (expr1', fvExpr1) <- rnLExpr expr1
-      ; (expr2', fvExpr2) <- rnLExpr expr2
-      ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
-
-rnArithSeq (FromThenTo expr1 expr2 expr3)
- = do { (expr1', fvExpr1) <- rnLExpr expr1
-      ; (expr2', fvExpr2) <- rnLExpr expr2
-      ; (expr3', fvExpr3) <- rnLExpr expr3
-      ; return (FromThenTo expr1' expr2' expr3',
-                plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
-
-{-
-************************************************************************
-*                                                                      *
-\subsubsection{@Stmt@s: in @do@ expressions}
-*                                                                      *
-************************************************************************
--}
-
-{-
-Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Both ApplicativeDo and RecursiveDo need to create tuples not
-present in the source text.
-
-For ApplicativeDo we create:
-
-  (a,b,c) <- (\c b a -> (a,b,c)) <$>
-
-For RecursiveDo we create:
-
-  mfix (\ ~(a,b,c) -> do ...; return (a',b',c'))
-
-The order of the components in those tuples needs to be stable
-across recompilations, otherwise they can get optimized differently
-and we end up with incompatible binaries.
-To get a stable order we use nameSetElemsStable.
-See Note [Deterministic UniqFM] to learn more about nondeterminism.
--}
-
-type AnnoBody body
-  = ( Outputable (body GhcPs)
-    )
-
--- | Rename some Stmts
-rnStmts :: AnnoBody body
-        => HsStmtContext GhcRn
-        -> (body GhcPs -> RnM (body GhcRn, FreeVars))
-           -- ^ How to rename the body of each statement (e.g. rnLExpr)
-        -> [LStmt GhcPs (LocatedA (body GhcPs))]
-           -- ^ Statements
-        -> ([Name] -> RnM (thing, FreeVars))
-           -- ^ if these statements scope over something, this renames it
-           -- and returns the result.
-        -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
-rnStmts ctxt rnBody stmts thing_inside
- = do { ((stmts', thing), fvs) <- rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
-      ; return ((map fst stmts', thing), fvs) }
-
--- | maybe rearrange statements according to the ApplicativeDo transformation
-postProcessStmtsForApplicativeDo
-  :: HsDoFlavour
-  -> [(ExprLStmt GhcRn, FreeVars)]
-  -> RnM ([ExprLStmt GhcRn], FreeVars)
-postProcessStmtsForApplicativeDo ctxt stmts
-  = do {
-       -- rearrange the statements using ApplicativeStmt if
-       -- -XApplicativeDo is on.  Also strip out the FreeVars attached
-       -- to each Stmt body.
-         ado_is_on <- xoptM LangExt.ApplicativeDo
-       ; let is_do_expr | DoExpr{} <- ctxt = True
-                        | otherwise = False
-       -- don't apply the transformation inside TH brackets, because
-       -- GHC.HsToCore.Quote does not handle ApplicativeDo.
-       ; in_th_bracket <- isBrackStage <$> getStage
-       ; if ado_is_on && is_do_expr && not in_th_bracket
-            then do { traceRn "ppsfa" (ppr stmts)
-                    ; rearrangeForApplicativeDo ctxt stmts }
-            else noPostProcessStmts (HsDoStmt ctxt) stmts }
-
--- | strip the FreeVars annotations from statements
-noPostProcessStmts
-  :: HsStmtContext GhcRn
-  -> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-  -> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
-noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
-
-
-rnStmtsWithFreeVars :: AnnoBody body
-        => HsStmtContext GhcRn
-        -> ((body GhcPs) -> RnM ((body GhcRn), FreeVars))
-        -> [LStmt GhcPs (LocatedA (body GhcPs))]
-        -> ([Name] -> RnM (thing, FreeVars))
-        -> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing)
-               , FreeVars)
--- Each Stmt body is annotated with its FreeVars, so that
--- we can rearrange statements for ApplicativeDo.
---
--- Variables bound by the Stmts, and mentioned in thing_inside,
--- do not appear in the result FreeVars
-
-rnStmtsWithFreeVars ctxt _ [] thing_inside
-  = do { checkEmptyStmts ctxt
-       ; (thing, fvs) <- thing_inside []
-       ; return (([], thing), fvs) }
-
-rnStmtsWithFreeVars mDoExpr@(HsDoStmt MDoExpr{}) rnBody (nonEmpty -> Just stmts) thing_inside    -- Deal with mdo
-  = -- Behave like do { rec { ...all but last... }; last }
-    do { ((stmts1, (stmts2, thing)), fvs)
-           <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA (NE.init stmts))) $ \ _ ->
-              do { last_stmt' <- checkLastStmt mDoExpr (NE.last stmts)
-                 ; rnStmt mDoExpr rnBody last_stmt' thing_inside }
-        ; return (((stmts1 ++ stmts2), thing), fvs) }
-
-rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
-  | null lstmts
-  = setSrcSpanA loc $
-    do { lstmt' <- checkLastStmt ctxt lstmt
-       ; rnStmt ctxt rnBody lstmt' thing_inside }
-
-  | otherwise
-  = do { ((stmts1, (stmts2, thing)), fvs)
-            <- setSrcSpanA loc                  $
-               do { checkStmt ctxt lstmt
-                  ; rnStmt ctxt rnBody lstmt $ \ bndrs1 ->
-                    rnStmtsWithFreeVars ctxt rnBody lstmts  $ \ bndrs2 ->
-                    thing_inside (bndrs1 ++ bndrs2) }
-        ; return (((stmts1 ++ stmts2), thing), fvs) }
-
-----------------------
-
-{-
-Note [Failing pattern matches in Stmts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Many things desugar to HsStmts including monadic things like `do` and `mdo`
-statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an
-exhaustive list). How we deal with pattern match failure is context-dependent.
-
- * In the case of list comprehensions and pattern guards we don't need any
-   'fail' function; the desugarer ignores the fail function of 'BindStmt'
-   entirely. So, for list comprehensions, the fail function is set to 'Nothing'
-   for clarity.
-
-* In the case of monadic contexts (e.g. monad comprehensions, do, and mdo
-   expressions) we want pattern match failure to be desugared to the
-   'fail' function (from MonadFail type class).
-
-At one point we failed to make this distinction, leading to #11216.
--}
-
-rnStmt :: AnnoBody body
-       => HsStmtContext GhcRn
-       -> (body GhcPs -> RnM (body GhcRn, FreeVars))
-          -- ^ How to rename the body of the statement
-       -> LStmt GhcPs (LocatedA (body GhcPs))
-          -- ^ The statement
-       -> ([Name] -> RnM (thing, FreeVars))
-          -- ^ Rename the stuff that this statement scopes over
-       -> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing)
-              , FreeVars)
--- Variables bound by the Stmt, and mentioned in thing_inside,
--- do not appear in the result FreeVars
-
-rnStmt ctxt rnBody (L loc (LastStmt _ (L lb body) noret _)) thing_inside
-  = do  { (body', fv_expr) <- rnBody body
-        ; (ret_op, fvs1) <- if isMonadCompContext ctxt
-                            then lookupStmtName ctxt returnMName
-                            else return (noSyntaxExpr, emptyFVs)
-                            -- The 'return' in a LastStmt is used only
-                            -- for MonadComp; and we don't want to report
-                            -- "non in scope: return" in other cases
-                            -- #15607
-
-        ; (thing,  fvs3) <- thing_inside []
-        ; return (([(L loc (LastStmt noExtField (L lb body') noret ret_op), fv_expr)]
-                  , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) }
-
-rnStmt ctxt rnBody (L loc (BodyStmt _ (L lb body) _ _)) thing_inside
-  = do  { (body', fv_expr) <- rnBody body
-        ; (then_op, fvs1)  <- lookupQualifiedDoStmtName ctxt thenMName
-
-        ; (guard_op, fvs2) <- if isComprehensionContext ctxt
-                              then lookupStmtName ctxt guardMName
-                              else return (noSyntaxExpr, emptyFVs)
-                              -- Only list/monad comprehensions use 'guard'
-                              -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
-                              -- Here "gd" is a guard
-
-        ; (thing, fvs3)    <- thing_inside []
-        ; return ( ([(L loc (BodyStmt noExtField (L lb body') then_op guard_op), fv_expr)]
-                  , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
-
-rnStmt ctxt rnBody (L loc (BindStmt _ pat (L lb body))) thing_inside
-  = do  { (body', fv_expr) <- rnBody body
-                -- The binders do not scope over the expression
-        ; (bind_op, fvs1) <- lookupQualifiedDoStmtName ctxt bindMName
-
-        ; (fail_op, fvs2) <- monadFailOp pat ctxt
-
-        ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
-        { (thing, fvs3) <- thing_inside (collectPatBinders CollNoDictBinders pat')
-        ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op }
-        ; return (( [( L loc (BindStmt xbsrn pat' (L lb body')), fv_expr )]
-                  , thing),
-                  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
-       -- fv_expr shouldn't really be filtered by the rnPatsAndThen
-        -- but it does not matter because the names are unique
-
-rnStmt _ _ (L loc (LetStmt _ binds)) thing_inside
-  =     rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
-        { (thing, fvs) <- thing_inside (collectLocalBinders CollNoDictBinders binds')
-        ; return ( ([(L loc (LetStmt noAnn binds'), bind_fvs)], thing)
-                 , fvs) }
-
-rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = L _ rec_stmts })) thing_inside
-  = do  { (return_op, fvs1)  <- lookupQualifiedDoStmtName ctxt returnMName
-        ; (mfix_op,   fvs2)  <- lookupQualifiedDoStmtName ctxt mfixName
-        ; (bind_op,   fvs3)  <- lookupQualifiedDoStmtName ctxt bindMName
-        ; let empty_rec_stmt = (emptyRecStmtName :: StmtLR GhcRn GhcRn (LocatedA (body GhcRn)))
-                                { recS_ret_fn  = return_op
-                                , recS_mfix_fn = mfix_op
-                                , recS_bind_fn = bind_op }
-
-        -- Step1: Bring all the binders of the mdo into scope
-        -- (Remember that this also removes the binders from the
-        -- finally-returned free-vars.)
-        -- And rename each individual stmt, making a
-        -- singleton segment.  At this stage the FwdRefs field
-        -- isn't finished: it's empty for all except a BindStmt
-        -- for which it's the fwd refs within the bind itself
-        -- (This set may not be empty, because we're in a recursive
-        -- context.)
-        ; rnRecStmtsAndThen ctxt rnBody rec_stmts   $ \ segs -> do
-        { let bndrs = nameSetElemsStable $
-                        foldr (unionNameSet . (\(ds,_,_,_) -> ds))
-                              emptyNameSet
-                              segs
-          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
-        ; (thing, fvs_later) <- thing_inside bndrs
-        -- In interactive mode, all variables could be used later. So we pass whether
-        -- we are in GHCi along to segmentRecStmts. See Note [What is "used later" in a rec stmt]
-        ; is_interactive <- isInteractiveModule . tcg_mod <$> getGblEnv
-        ; let
-             (rec_stmts', fvs) = segmentRecStmts (locA loc) ctxt empty_rec_stmt segs (fvs_later, is_interactive)
-        -- We aren't going to try to group RecStmts with
-        -- ApplicativeDo, so attaching empty FVs is fine.
-        ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)
-                 , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
-
-rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside
-  = do  { (mzip_op, fvs1)   <- lookupStmtNamePoly ctxt mzipName
-        ; (bind_op, fvs2)   <- lookupStmtName ctxt bindMName
-        ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
-        ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
-        ; return (([(L loc (ParStmt noExtField segs' mzip_op bind_op), fvs4)], thing)
-                 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
-
-rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
-                              , trS_using = using })) thing_inside
-  = do { -- Rename the 'using' expression in the context before the transform is begun
-         (using', fvs1) <- rnLExpr using
-
-         -- Rename the stmts and the 'by' expression
-         -- Keep track of the variables mentioned in the 'by' expression
-       ; ((stmts', (by', used_bndrs, thing)), fvs2)
-             <- rnStmts (TransStmtCtxt ctxt) rnExpr stmts $ \ bndrs ->
-                do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by
-                   ; (thing, fvs_thing) <- thing_inside bndrs
-                   ; let fvs = fvs_by `plusFV` fvs_thing
-                         used_bndrs = filter (`elemNameSet` fvs) bndrs
-                         -- The paper (Fig 5) has a bug here; we must treat any free variable
-                         -- of the "thing inside", **or of the by-expression**, as used
-                   ; return ((by', used_bndrs, thing), fvs) }
-
-       -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
-       ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
-       ; (bind_op,   fvs4) <- lookupStmtName ctxt bindMName
-       ; (fmap_op,   fvs5) <- case form of
-                                ThenForm -> return (noExpr, emptyFVs)
-                                _        -> lookupStmtNamePoly ctxt fmapName
-
-       ; let all_fvs  = fvs1 `plusFV` fvs2 `plusFV` fvs3
-                             `plusFV` fvs4 `plusFV` fvs5
-             bndr_map = used_bndrs `zip` used_bndrs
-             -- See Note [TransStmt binder map] in GHC.Hs.Expr
-
-       ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)
-       ; return (([(L loc (TransStmt { trS_ext = noExtField
-                                    , trS_stmts = stmts', trS_bndrs = bndr_map
-                                    , trS_by = by', trS_using = using', trS_form = form
-                                    , trS_ret = return_op, trS_bind = bind_op
-                                    , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
-
-rnStmt _ _ (L _ ApplicativeStmt{}) _ =
-  panic "rnStmt: ApplicativeStmt"
-
-rnParallelStmts :: forall thing. HsStmtContext GhcRn
-                -> SyntaxExpr GhcRn
-                -> [ParStmtBlock GhcPs GhcPs]
-                -> ([Name] -> RnM (thing, FreeVars))
-                -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
--- Note [Renaming parallel Stmts]
-rnParallelStmts ctxt return_op segs thing_inside
-  = do { orig_lcl_env <- getLocalRdrEnv
-       ; rn_segs orig_lcl_env [] segs }
-  where
-    rn_segs :: LocalRdrEnv
-            -> [Name] -> [ParStmtBlock GhcPs GhcPs]
-            -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
-    rn_segs _ bndrs_so_far []
-      = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
-           ; mapM_ dupErr dups
-           ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
-           ; return (([], thing), fvs) }
-
-    rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs)
-      = do { ((stmts', (used_bndrs, segs', thing)), fvs)
-                    <- rnStmts ctxt rnExpr stmts $ \ bndrs ->
-                       setLocalRdrEnv env       $ do
-                       { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
-                       ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
-                       ; return ((used_bndrs, segs', thing), fvs) }
-
-           ; let seg' = ParStmtBlock x stmts' used_bndrs return_op
-           ; return ((seg':segs', thing), fvs) }
-
-    cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
-    dupErr vs = addErr $ TcRnListComprehensionDuplicateBinding (NE.head vs)
-
-lookupQualifiedDoStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
--- Like lookupStmtName, but respects QualifiedDo
-lookupQualifiedDoStmtName ctxt n
-  = case qualifiedDoModuleName_maybe ctxt of
-      Nothing -> lookupStmtName ctxt n
-      Just modName ->
-        first (mkSyntaxExpr . nl_HsVar) <$> lookupNameWithQualifier n modName
-
-lookupStmtName :: HsStmtContext GhcRn -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
--- Like lookupSyntax, but respects contexts
-lookupStmtName ctxt n
-  | rebindableContext ctxt
-  = lookupSyntax n
-  | otherwise
-  = return (mkRnSyntaxExpr n, emptyFVs)
-
-lookupStmtNamePoly :: HsStmtContext GhcRn -> Name -> RnM (HsExpr GhcRn, FreeVars)
-lookupStmtNamePoly ctxt name
-  | rebindableContext ctxt
-  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
-       ; if rebindable_on
-         then do { fm <- lookupOccRn (nameRdrName name)
-                 ; return (HsVar noExtField (noLocA fm), unitFV fm) }
-         else not_rebindable }
-  | otherwise
-  = not_rebindable
-  where
-    not_rebindable = return (HsVar noExtField (noLocA name), emptyFVs)
-
--- | Is this a context where we respect RebindableSyntax?
--- but ListComp are never rebindable
--- Neither is ArrowExpr, which has its own desugarer in GHC.HsToCore.Arrows
-rebindableContext :: HsStmtContext GhcRn -> Bool
-rebindableContext ctxt = case ctxt of
-  HsDoStmt flavour -> rebindableDoStmtContext flavour
-  ArrowExpr -> False
-  PatGuard {} -> False
-
-
-  ParStmtCtxt   c -> rebindableContext c     -- Look inside to
-  TransStmtCtxt c -> rebindableContext c     -- the parent context
-
-rebindableDoStmtContext :: HsDoFlavour -> Bool
-rebindableDoStmtContext flavour = case flavour of
-  ListComp -> False
-  DoExpr m -> isNothing m
-  MDoExpr m -> isNothing m
-  MonadComp -> True
-  GhciStmtCtxt -> True   -- I suppose?
-
-{-
-Note [Renaming parallel Stmts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Renaming parallel statements is painful.  Given, say
-     [ a+c | a <- as, bs <- bss
-           | c <- bs, a <- ds ]
-Note that
-  (a) In order to report "Defined but not used" about 'bs', we must
-      rename each group of Stmts with a thing_inside whose FreeVars
-      include at least {a,c}
-
-  (b) We want to report that 'a' is illegally bound in both branches
-
-  (c) The 'bs' in the second group must obviously not be captured by
-      the binding in the first group
-
-To satisfy (a) we nest the segments.
-To satisfy (b) we check for duplicates just before thing_inside.
-To satisfy (c) we reset the LocalRdrEnv each time.
-
-************************************************************************
-*                                                                      *
-\subsubsection{mdo expressions}
-*                                                                      *
-************************************************************************
--}
-
-type FwdRefs = NameSet
-type Segment stmts = (Defs,
-                      Uses,     -- May include defs
-                      FwdRefs,  -- A subset of uses that are
-                                --   (a) used before they are bound in this segment, or
-                                --   (b) used here, and bound in subsequent segments
-                      stmts)    -- Either Stmt or [Stmt]
-
-
--- wrapper that does both the left- and right-hand sides
-rnRecStmtsAndThen :: AnnoBody body
-                  => HsStmtContext GhcRn
-                  -> (body GhcPs -> RnM (body GhcRn, FreeVars))
-                  -> [LStmt GhcPs (LocatedA (body GhcPs))]
-                         -- assumes that the FreeVars returned includes
-                         -- the FreeVars of the Segments
-                  -> ([Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-                      -> RnM (a, FreeVars))
-                  -> RnM (a, FreeVars)
-rnRecStmtsAndThen ctxt rnBody s cont
-  = do  { -- (A) Make the mini fixity env for all of the stmts
-          fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
-
-          -- (B) Do the LHSes
-        ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
-
-          --    ...bring them and their fixities into scope
-        ; let bound_names = collectLStmtsBinders CollNoDictBinders (map fst new_lhs_and_fv)
-              -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
-              rec_uses = lStmtsImplicits (map fst new_lhs_and_fv)
-              implicit_uses = mkNameSet $ concatMap snd $ rec_uses
-        ; bindLocalNamesFV bound_names $
-          addLocalFixities fix_env bound_names $ do
-
-          -- (C) do the right-hand-sides and thing-inside
-        { segs <- rn_rec_stmts ctxt rnBody bound_names new_lhs_and_fv
-        ; (res, fvs) <- cont segs
-        ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns))
-                rec_uses
-        ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)
-        ; return (res, fvs) }}
-
--- get all the fixity decls in any Let stmt
-collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
-collectRecStmtsFixities l =
-    foldr (\ s -> \acc -> case s of
-            (L _ (LetStmt _ (HsValBinds _ (ValBinds _ _ sigs)))) ->
-              foldr (\ sig -> \ acc -> case sig of
-                                         (L loc (FixSig _ s)) -> (L loc s) : acc
-                                         _ -> acc) acc sigs
-            _ -> acc) [] l
-
--- left-hand sides
-
-rn_rec_stmt_lhs :: AnnoBody body => MiniFixityEnv
-                -> LStmt GhcPs (LocatedA (body GhcPs))
-                   -- rename LHS, and return its FVs
-                   -- Warning: we will only need the FreeVars below in the case of a BindStmt,
-                   -- so we don't bother to compute it accurately in the other cases
-                -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
-
-rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))
-  = return [(L loc (BodyStmt noExtField body a b), emptyFVs)]
-
-rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))
-  = return [(L loc (LastStmt noExtField body noret a), emptyFVs)]
-
-rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body))
-  = do
-      -- should the ctxt be MDo instead?
-      (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
-      return [(L loc (BindStmt noAnn pat' body), fv_pat)]
-
-rn_rec_stmt_lhs _ (L _ (LetStmt _ binds@(HsIPBinds {})))
-  = failWith (badIpBinds (Left binds))
-
-
-rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (HsValBinds x binds)))
-    = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
-         return [(L loc (LetStmt noAnn (HsValBinds x binds')),
-                 -- Warning: this is bogus; see function invariant
-                 emptyFVs
-                 )]
-
--- XXX Do we need to do something with the return and mfix names?
-rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = L _ stmts }))  -- Flatten Rec inside Rec
-    = rn_rec_stmts_lhs fix_env stmts
-
-rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {}))       -- Syntactically illegal in mdo
-  = pprPanic "rn_rec_stmt" (ppr stmt)
-
-rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))     -- Syntactically illegal in mdo
-  = pprPanic "rn_rec_stmt" (ppr stmt)
-
-rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
-  = pprPanic "rn_rec_stmt" (ppr stmt)
-
-rn_rec_stmt_lhs _ (L _ (LetStmt _ (EmptyLocalBinds _)))
-  = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
-
-rn_rec_stmts_lhs :: AnnoBody body => MiniFixityEnv
-                 -> [LStmt GhcPs (LocatedA (body GhcPs))]
-                 -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
-rn_rec_stmts_lhs fix_env stmts
-  = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
-       ; let boundNames = collectLStmtsBinders CollNoDictBinders (map fst ls)
-            -- First do error checking: we need to check for dups here because we
-            -- don't bind all of the variables from the Stmt at once
-            -- with bindLocatedLocals.
-       ; checkDupNames boundNames
-       ; return ls }
-
-
--- right-hand-sides
-
-rn_rec_stmt :: AnnoBody body =>
-               HsStmtContext GhcRn
-            -> (body GhcPs -> RnM (body GhcRn, FreeVars))
-            -> [Name]
-            -> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)
-            -> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-        -- Rename a Stmt that is inside a RecStmt (or mdo)
-        -- Assumes all binders are already in scope
-        -- Turns each stmt into a singleton Stmt
-rn_rec_stmt ctxt rnBody _ (L loc (LastStmt _ (L lb body) noret _), _)
-  = do  { (body', fv_expr) <- rnBody body
-        ; (ret_op, fvs1)   <- lookupQualifiedDo ctxt returnMName
-        ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
-                   L loc (LastStmt noExtField (L lb body') noret ret_op))] }
-
-rn_rec_stmt ctxt rnBody _ (L loc (BodyStmt _ (L lb body) _ _), _)
-  = do { (body', fvs) <- rnBody body
-       ; (then_op, fvs1) <- lookupQualifiedDo ctxt thenMName
-       ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
-                 L loc (BodyStmt noExtField (L lb body') then_op noSyntaxExpr))] }
-
-rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' (L lb body)), fv_pat)
-  = do { (body', fv_expr) <- rnBody body
-       ; (bind_op, fvs1) <- lookupQualifiedDo ctxt bindMName
-
-       ; (fail_op, fvs2) <- getMonadFailOp ctxt
-
-       ; let bndrs = mkNameSet (collectPatBinders CollNoDictBinders pat')
-             fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
-       ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op }
-       ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
-                  L loc (BindStmt xbsrn pat' (L lb body')))] }
-
-rn_rec_stmt _ _ _ (L _ (LetStmt _ binds@(HsIPBinds {})), _)
-  = failWith (badIpBinds (Right binds))
-
-rn_rec_stmt _ _ all_bndrs (L loc (LetStmt _ (HsValBinds x binds')), _)
-  = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
-           -- fixities and unused are handled above in rnRecStmtsAndThen
-       ; let fvs = allUses du_binds
-       ; return [(duDefs du_binds, fvs, emptyNameSet,
-                 L loc (LetStmt noAnn (HsValBinds x binds')))] }
-
--- no RecStmt case because they get flattened above when doing the LHSes
-rn_rec_stmt _ _ _ stmt@(L _ (RecStmt {}), _)
-  = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
-
-rn_rec_stmt _ _ _ stmt@(L _ (ParStmt {}), _)       -- Syntactically illegal in mdo
-  = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
-
-rn_rec_stmt _ _ _ stmt@(L _ (TransStmt {}), _)     -- Syntactically illegal in mdo
-  = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
-
-rn_rec_stmt _ _ _ (L _ (LetStmt _ (EmptyLocalBinds _)), _)
-  = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
-
-rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _)
-  = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
-
-rn_rec_stmts :: AnnoBody body
-             => HsStmtContext GhcRn
-             -> (body GhcPs -> RnM (body GhcRn, FreeVars))
-             -> [Name]
-             -> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]
-             -> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-rn_rec_stmts ctxt rnBody bndrs stmts
-  = do { segs_s <- mapM (rn_rec_stmt ctxt rnBody bndrs) stmts
-       ; return (concat segs_s) }
-
----------------------------------------------
-segmentRecStmts :: SrcSpan -> HsStmtContext GhcRn
-                -> Stmt GhcRn (LocatedA (body GhcRn))
-                -> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]
-                -> (FreeVars, Bool)
-                    -- ^ The free variables used in later statements.
-                    -- If the boolean is 'True', this might be an underestimate
-                    -- because we are in GHCi, and might thus be missing some "used later"
-                    -- FVs. See Note [What is "used later" in a rec stmt]
-                -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
-
-segmentRecStmts loc ctxt empty_rec_stmt segs (fvs_later, might_be_more_fvs_later)
-  | null segs
-  = ([], final_fv_uses)
-
-  | HsDoStmt (MDoExpr _) <- ctxt
-  = segsToStmts empty_rec_stmt grouped_segs fvs_later
-               -- Step 4: Turn the segments into Stmts
-                --         Use RecStmt when and only when there are fwd refs
-                --         Also gather up the uses from the end towards the
-                --         start, so we can tell the RecStmt which things are
-                --         used 'after' the RecStmt
-
-  | otherwise
-  = ([ L (noAnnSrcSpan loc) $
-       empty_rec_stmt { recS_stmts = noLocA ss
-                      , recS_later_ids = nameSetElemsStable final_fvs_later
-                      , recS_rec_ids   = nameSetElemsStable
-                                           (defs `intersectNameSet` uses) }]
-          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
-    , uses `plusFV` final_fv_uses)
-
-  where
-    (final_fv_uses, final_fvs_later)
-      | might_be_more_fvs_later
-      = (defs, defs)
-        -- If there might be more uses later (e.g. we are in GHCi and have not
-        -- yet seen the whole rec statement), conservatively assume that everything
-        -- will be used later (as is possible).
-      | otherwise
-      = ( uses `plusFV` fvs_later
-        , defs `intersectNameSet` fvs_later )
-
-    (defs_s, uses_s, _, ss) = unzip4 segs
-    defs = plusFVs defs_s
-    uses = plusFVs uses_s
-
-                -- Step 2: Fill in the fwd refs.
-                --         The segments are all singletons, but their fwd-ref
-                --         field mentions all the things used by the segment
-                --         that are bound after their use
-    segs_w_fwd_refs = addFwdRefs segs
-
-                -- Step 3: Group together the segments to make bigger segments
-                --         Invariant: in the result, no segment uses a variable
-                --                    bound in a later segment
-    grouped_segs = glomSegments ctxt segs_w_fwd_refs
-
-----------------------------
-addFwdRefs :: [Segment a] -> [Segment a]
--- So far the segments only have forward refs *within* the Stmt
---      (which happens for bind:  x <- ...x...)
--- This function adds the cross-seg fwd ref info
-
-addFwdRefs segs
-  = fst (foldr mk_seg ([], emptyNameSet) segs)
-  where
-    mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
-        = (new_seg : segs, all_defs)
-        where
-          new_seg = (defs, uses, new_fwds, stmts)
-          all_defs = later_defs `unionNameSet` defs
-          new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)
-                -- Add the downstream fwd refs here
-
-{-
-Note [Segmenting mdo]
-~~~~~~~~~~~~~~~~~~~~~
-NB. June 7 2012: We only glom segments that appear in an explicit mdo;
-and leave those found in "do rec"'s intact.  See
-https://gitlab.haskell.org/ghc/ghc/issues/4148 for the discussion
-leading to this design choice.  Hence the test in segmentRecStmts.
-
-Note [Glomming segments]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Glomming the singleton segments of an mdo into minimal recursive groups.
-
-At first I thought this was just strongly connected components, but
-there's an important constraint: the order of the stmts must not change.
-
-Consider
-     mdo { x <- ...y...
-           p <- z
-           y <- ...x...
-           q <- x
-           z <- y
-           r <- x }
-
-Here, the first stmt mention 'y', which is bound in the third.
-But that means that the innocent second stmt (p <- z) gets caught
-up in the recursion.  And that in turn means that the binding for
-'z' has to be included... and so on.
-
-Start at the tail { r <- x }
-Now add the next one { z <- y ; r <- x }
-Now add one more     { q <- x ; z <- y ; r <- x }
-Now one more... but this time we have to group a bunch into rec
-     { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
-Now one more, which we can add on without a rec
-     { p <- z ;
-       rec { y <- ...x... ; q <- x ; z <- y } ;
-       r <- x }
-Finally we add the last one; since it mentions y we have to
-glom it together with the first two groups
-     { rec { x <- ...y...; p <- z ; y <- ...x... ;
-             q <- x ; z <- y } ;
-       r <- x }
-
-Note [What is "used later" in a rec stmt]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We desugar a recursive Stmt to something like
-
-  (a,_,c) <- mfix (\(a,b,_) -> do { ... ; return (a,b,c) })
-  ...stuff after the rec...
-
-The knot-tied tuple must contain
-* All the variables that are used before they are bound in the `rec` block
-* All the variables that are used after the entire `rec` block
-
-In the case of GHCi, however, we don't know what variables will be used
-after the `rec` (#20206).  For example, we might have
-    ghci>  rec { x <- e1; y <- e2 }
-    ghci>  print x
-    ghci>  print y
-
-So we have to assume that *all* the variables bound in the `rec` are used
-afterwards.  We pass a Boolean to segmentRecStmts to signal such a situation,
-in which case that function conservatively assumes that everything might well
-be used later.
--}
-
-glomSegments :: HsStmtContext GhcRn
-             -> [Segment (LStmt GhcRn body)]
-             -> [Segment [LStmt GhcRn body]]
-                                  -- Each segment has a non-empty list of Stmts
--- See Note [Glomming segments]
-
-glomSegments _ [] = []
-glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
-        -- Actually stmts will always be a singleton
-  = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
-  where
-    segs'            = glomSegments ctxt segs
-    (extras, others) = grab uses segs'
-    (ds, us, fs, ss) = unzip4 extras
-
-    seg_defs  = plusFVs ds `plusFV` defs
-    seg_uses  = plusFVs us `plusFV` uses
-    seg_fwds  = plusFVs fs `plusFV` fwds
-    seg_stmts = stmt : concat ss
-
-    grab :: NameSet             -- The client
-         -> [Segment a]
-         -> ([Segment a],       -- Needed by the 'client'
-             [Segment a])       -- Not needed by the client
-        -- The result is simply a split of the input
-    grab uses dus
-        = (reverse yeses, reverse noes)
-        where
-          (noes, yeses)           = span not_needed (reverse dus)
-          not_needed (defs,_,_,_) = disjointNameSet defs uses
-
-----------------------------------------------------
-segsToStmts :: Stmt GhcRn (LocatedA (body GhcRn))
-                                  -- A RecStmt with the SyntaxOps filled in
-            -> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]
-                                  -- Each Segment has a non-empty list of Stmts
-            -> FreeVars           -- Free vars used 'later'
-            -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)
-
-segsToStmts _ [] fvs_later = ([], fvs_later)
-segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
-  = assert (not (null ss))
-    (new_stmt : later_stmts, later_uses `plusFV` uses)
-  where
-    (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
-    new_stmt | non_rec   = head ss
-             | otherwise = L (getLoc (head ss)) rec_stmt
-    rec_stmt = empty_rec_stmt { recS_stmts     = noLocA ss
-                              , recS_later_ids = nameSetElemsStable used_later
-                              , recS_rec_ids   = nameSetElemsStable fwds }
-          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
-    non_rec    = isSingleton ss && isEmptyNameSet fwds
-    used_later = defs `intersectNameSet` later_uses
-                                -- The ones needed after the RecStmt
-
-{-
-************************************************************************
-*                                                                      *
-ApplicativeDo
-*                                                                      *
-************************************************************************
-
-Note [ApplicativeDo]
-~~~~~~~~~~~~~~~~~~~~
-= Example =
-
-For a sequence of statements
-
- do
-     x <- A
-     y <- B x
-     z <- C
-     return (f x y z)
-
-We want to transform this to
-
-  (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C
-
-It would be easy to notice that "y <- B x" and "z <- C" are
-independent and do something like this:
-
- do
-     x <- A
-     (y,z) <- (,) <$> B x <*> C
-     return (f x y z)
-
-But this isn't enough! A and C were also independent, and this
-transformation loses the ability to do A and C in parallel.
-
-The algorithm works by first splitting the sequence of statements into
-independent "segments", and a separate "tail" (the final statement). In
-our example above, the segments would be
-
-     [ x <- A
-     , y <- B x ]
-
-     [ z <- C ]
-
-and the tail is:
-
-     return (f x y z)
-
-Then we take these segments and make an Applicative expression from them:
-
-     (\(x,y) z -> return (f x y z))
-       <$> do { x <- A; y <- B x; return (x,y) }
-       <*> C
-
-Finally, we recursively apply the transformation to each segment, to
-discover any nested parallelism.
-
-= Syntax & spec =
-
-  expr ::= ... | do {stmt_1; ..; stmt_n} expr | ...
-
-  stmt ::= pat <- expr
-         | (arg_1 | ... | arg_n)  -- applicative composition, n>=1
-         | ...                    -- other kinds of statement (e.g. let)
-
-  arg ::= pat <- expr
-        | {stmt_1; ..; stmt_n} {var_1..var_n}
-
-(note that in the actual implementation,the expr in a do statement is
-represented by a LastStmt as the final stmt, this is just a
-representational issue and may change later.)
-
-== Transformation to introduce applicative stmts ==
-
-ado {} tail = tail
-ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr'
-ado {one} tail = one : tail
-ado stmts tail
-  | n == 1 = ado before (ado after tail)
-    where (before,after) = split(stmts_1)
-  | n > 1  = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail
-  where
-    {stmts_1 .. stmts_n} = segments(stmts)
-
-segments(stmts) =
-  -- divide stmts into segments with no interdependencies
-
-mkArg({pat <- expr}) = (pat <- expr)
-mkArg({stmt_1; ...; stmt_n}) =
-  {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)}
-
-split({stmt_1; ..; stmt_n) =
-  ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n})
-  -- 1 <= i <= n
-  -- i is a good place to insert a bind
-
-== Desugaring for do ==
-
-dsDo {} expr = expr
-
-dsDo {pat <- rhs; stmts} expr =
-   rhs >>= \pat -> dsDo stmts expr
-
-dsDo {(arg_1 | ... | arg_n)} (return expr) =
-  (\argpat (arg_1) .. argpat(arg_n) -> expr)
-     <$> argexpr(arg_1)
-     <*> ...
-     <*> argexpr(arg_n)
-
-dsDo {(arg_1 | ... | arg_n); stmts} expr =
-  join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr)
-     <$> argexpr(arg_1)
-     <*> ...
-     <*> argexpr(arg_n)
-
-== Special cases ==
-
-If a do-expression contains only "return E" or "return $ E" plus
-zero or more let-statements, we replace the "return" with "pure".
-See Section 3.6 of the paper.
-
-= Relevant modules in the rest of the compiler =
-
-ApplicativeDo touches a few phases in the compiler:
-
-* Renamer: The journey begins here in the renamer, where do-blocks are
-  scheduled as outlined above and transformed into applicative
-  combinators.  However, the code is still represented as a do-block
-  with special forms of applicative statements. This allows us to
-  recover the original do-block when e.g. printing type errors, where
-  we don't want to show any of the applicative combinators since they
-  don't exist in the source code.
-  See ApplicativeStmt and ApplicativeArg in HsExpr.
-
-* Typechecker: ApplicativeDo passes through the typechecker much like any
-  other form of expression. The only crux is that the typechecker has to
-  be aware of the special ApplicativeDo statements in the do-notation, and
-  typecheck them appropriately.
-  Relevant module: GHC.Tc.Gen.Match
-
-* Desugarer: Any do-block which contains applicative statements is desugared
-  as outlined above, to use the Applicative combinators.
-  Relevant module: GHC.HsToCore.Expr
-
--}
-
--- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and
--- 'pureName' due to @QualifiedDo@ or @RebindableSyntax@.
-data MonadNames = MonadNames { return_name, pure_name :: Name }
-
-instance Outputable MonadNames where
-  ppr (MonadNames {return_name=return_name,pure_name=pure_name}) =
-    hcat
-    [text "MonadNames { return_name = "
-    ,ppr return_name
-    ,text ", pure_name = "
-    ,ppr pure_name
-    ,text "}"
-    ]
-
--- | rearrange a list of statements using ApplicativeDoStmt.  See
--- Note [ApplicativeDo].
-rearrangeForApplicativeDo
-  :: HsDoFlavour
-  -> [(ExprLStmt GhcRn, FreeVars)]
-  -> RnM ([ExprLStmt GhcRn], FreeVars)
-
-rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)
--- If the do-block contains a single @return@ statement, change it to
--- @pure@ if ApplicativeDo is turned on. See Note [ApplicativeDo].
-rearrangeForApplicativeDo ctxt [(one,_)] = do
-  (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName
-  (pure_name, _)   <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
-  let pure_expr = nl_HsVar pure_name
-  let monad_names = MonadNames { return_name = return_name
-                               , pure_name   = pure_name }
-  return $ case needJoin monad_names [one] (Just pure_expr) of
-    (False, one') -> (one', emptyNameSet)
-    (True, _) -> ([one], emptyNameSet)
-rearrangeForApplicativeDo ctxt stmts0 = do
-  optimal_ado <- goptM Opt_OptimalApplicativeDo
-  let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
-                | otherwise = mkStmtTreeHeuristic stmts
-  traceRn "rearrangeForADo" (ppr stmt_tree)
-  (return_name, _) <- lookupQualifiedDoName (HsDoStmt ctxt) returnMName
-  (pure_name, _)   <- lookupQualifiedDoName (HsDoStmt ctxt) pureAName
-  let monad_names = MonadNames { return_name = return_name
-                               , pure_name   = pure_name }
-  stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs
-  where
-    (stmts,(last,last_fvs)) = findLast stmts0
-    findLast [] = error "findLast"
-    findLast [last] = ([],last)
-    findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs
-
--- | A tree of statements using a mixture of applicative and bind constructs.
-data StmtTree a
-  = StmtTreeOne a
-  | StmtTreeBind (StmtTree a) (StmtTree a)
-  | StmtTreeApplicative [StmtTree a]
-
-instance Outputable a => Outputable (StmtTree a) where
-  ppr (StmtTreeOne x)          = parens (text "StmtTreeOne" <+> ppr x)
-  ppr (StmtTreeBind x y)       = parens (hang (text "StmtTreeBind")
-                                            2 (sep [ppr x, ppr y]))
-  ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative")
-                                            2 (vcat (map ppr xs)))
-
-flattenStmtTree :: StmtTree a -> [a]
-flattenStmtTree t = go t []
- where
-  go (StmtTreeOne a) as = a : as
-  go (StmtTreeBind l r) as = go l (go r as)
-  go (StmtTreeApplicative ts) as = foldr go as ts
-
-type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars)
-type Cost = Int
-
--- | Turn a sequence of statements into an ExprStmtTree using a
--- heuristic algorithm.  /O(n^2)/
-mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
-mkStmtTreeHeuristic [one] = StmtTreeOne one
-mkStmtTreeHeuristic stmts =
-  case segments stmts of
-    [one] -> split one
-    segs -> StmtTreeApplicative (map split segs)
- where
-  split [one] = StmtTreeOne one
-  split stmts =
-    StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after)
-    where (before, after) = splitSegment stmts
-
--- | Turn a sequence of statements into an ExprStmtTree optimally,
--- using dynamic programming.  /O(n^3)/
-mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
-mkStmtTreeOptimal stmts =
-  assert (not (null stmts)) $ -- the empty case is handled by the caller;
-                              -- we don't support empty StmtTrees.
-  fst (arr ! (0,n))
-  where
-    n = length stmts - 1
-    stmt_arr = listArray (0,n) stmts
-
-    -- lazy cache of optimal trees for subsequences of the input
-    arr :: Array (Int,Int) (ExprStmtTree, Cost)
-    arr = array ((0,0),(n,n))
-             [ ((lo,hi), tree lo hi)
-             | lo <- [0..n]
-             , hi <- [lo..n] ]
-
-    -- compute the optimal tree for the sequence [lo..hi]
-    tree lo hi
-      | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
-      | otherwise =
-         case segments [ stmt_arr ! i | i <- [lo..hi] ] of
-           [] -> panic "mkStmtTree"
-           [_one] -> split lo hi
-           segs -> (StmtTreeApplicative trees, maximum costs)
-             where
-               bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs
-               (trees,costs) = unzip (map (uncurry split) (tail bounds))
-
-    -- find the best place to split the segment [lo..hi]
-    split :: Int -> Int -> (ExprStmtTree, Cost)
-    split lo hi
-      | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
-      | otherwise = (StmtTreeBind before after, c1+c2)
-        where
-         -- As per the paper, for a sequence s1...sn, we want to find
-         -- the split with the minimum cost, where the cost is the
-         -- sum of the cost of the left and right subsequences.
-         --
-         -- As an optimisation (also in the paper) if the cost of
-         -- s1..s(n-1) is different from the cost of s2..sn, we know
-         -- that the optimal solution is the lower of the two.  Only
-         -- in the case that these two have the same cost do we need
-         -- to do the exhaustive search.
-         --
-         ((before,c1),(after,c2))
-           | hi - lo == 1
-           = ((StmtTreeOne (stmt_arr ! lo), 1),
-              (StmtTreeOne (stmt_arr ! hi), 1))
-           | left_cost < right_cost
-           = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))
-           | left_cost > right_cost
-           = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))
-           | otherwise = minimumBy (comparing cost) alternatives
-           where
-             (left, left_cost) = arr ! (lo,hi-1)
-             (right, right_cost) = arr ! (lo+1,hi)
-             cost ((_,c1),(_,c2)) = c1 + c2
-             alternatives = [ (arr ! (lo,k), arr ! (k+1,hi))
-                            | k <- [lo .. hi-1] ]
-
-
--- | Turn the ExprStmtTree back into a sequence of statements, using
--- ApplicativeStmt where necessary.
-stmtTreeToStmts
-  :: MonadNames
-  -> HsDoFlavour
-  -> ExprStmtTree
-  -> [ExprLStmt GhcRn]             -- ^ the "tail"
-  -> FreeVars                     -- ^ free variables of the tail
-  -> RnM ( [ExprLStmt GhcRn]       -- ( output statements,
-         , FreeVars )             -- , things we needed
-
--- If we have a single bind, and we can do it without a join, transform
--- to an ApplicativeStmt.  This corresponds to the rule
---   dsBlock [pat <- rhs] (return expr) = expr <$> rhs
--- In the spec, but we do it here rather than in the desugarer,
--- because we need the typechecker to typecheck the <$> form rather than
--- the bind form, which would give rise to a Monad constraint.
---
--- If we have a single let, and the last statement is @return E@ or @return $ E@,
--- change the @return@ to @pure@.
-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt xbs pat rhs), _))
-                tail _tail_fvs
-  | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail Nothing
-  -- See Note [ApplicativeDo and strict patterns]
-  = mkApplicativeStmt ctxt [ApplicativeArgOne
-                            { xarg_app_arg_one = xbsrn_failOp xbs
-                            , app_arg_pattern  = pat
-                            , arg_expr         = rhs
-                            , is_body_stmt     = False
-                            }]
-                      False tail'
-stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
-                tail _tail_fvs
-  | (False,tail') <- needJoin monad_names tail Nothing
-  = mkApplicativeStmt ctxt
-      [ApplicativeArgOne
-       { xarg_app_arg_one = Nothing
-       , app_arg_pattern  = nlWildPatName
-       , arg_expr         = rhs
-       , is_body_stmt     = True
-       }] False tail'
-stmtTreeToStmts monad_names ctxt (StmtTreeOne (let_stmt@(L _ LetStmt{}),_))
-                tail _tail_fvs = do
-  (pure_expr, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName
-  return $ case needJoin monad_names tail (Just pure_expr) of
-    (False, tail') -> (let_stmt : tail', emptyNameSet)
-    (True, _) -> (let_stmt : tail, emptyNameSet)
-
-stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
-  return (s : tail, emptyNameSet)
-
-stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do
-  (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs
-  let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after))
-  (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs
-  return (stmts2, fvs1 `plusFV` fvs2)
-
-stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
-   pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
-   dflags <- getDynFlags
-   let (stmts', fvss) = unzip pairs
-   let (need_join, tail') =
-     -- See Note [ApplicativeDo and refutable patterns]
-         if any (hasRefutablePattern dflags) stmts'
-         then (True, tail)
-         else needJoin monad_names tail Nothing
-
-   (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
-   return (stmts, unionNameSets (fvs:fvss))
- where
-   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt xbs pat exp), _))
-     = return (ApplicativeArgOne
-               { xarg_app_arg_one = xbsrn_failOp xbs
-               , app_arg_pattern  = pat
-               , arg_expr         = exp
-               , is_body_stmt     = False
-               }, emptyFVs)
-   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
-     return (ApplicativeArgOne
-             { xarg_app_arg_one = Nothing
-             , app_arg_pattern  = nlWildPatName
-             , arg_expr         = exp
-             , is_body_stmt     = True
-             }, emptyFVs)
-   stmtTreeArg ctxt tail_fvs tree = do
-     let stmts = flattenStmtTree tree
-         pvarset = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts)
-                     `intersectNameSet` tail_fvs
-         pvars = nameSetElemsStable pvarset
-           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
-         pat = mkBigLHsVarPatTup pvars
-         tup = mkBigLHsVarTup pvars noExtField
-     (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset
-     (mb_ret, fvs1) <-
-        if | L _ ApplicativeStmt{} <- last stmts' ->
-             return (unLoc tup, emptyNameSet)
-           | otherwise -> do
-             -- Need 'pureAName' and not 'returnMName' here, so that it requires
-             -- 'Applicative' and not 'Monad' whenever possible (until #20540 is fixed).
-             (ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName
-             let expr = HsApp noComments (noLocA ret) tup
-             return (expr, emptyFVs)
-     return ( ApplicativeArgMany
-              { xarg_app_arg_many = noExtField
-              , app_stmts         = stmts'
-              , final_expr        = mb_ret
-              , bv_pattern        = pat
-              , stmt_context      = ctxt
-              }
-            , fvs1 `plusFV` fvs2)
-
-
--- | Divide a sequence of statements into segments, where no segment
--- depends on any variables defined by a statement in another segment.
-segments
-  :: [(ExprLStmt GhcRn, FreeVars)]
-  -> [[(ExprLStmt GhcRn, FreeVars)]]
-segments stmts = merge $ reverse $ map reverse $ walk (reverse stmts)
-  where
-    allvars = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts)
-
-    -- We would rather not have a segment that just has LetStmts in
-    -- it, so combine those with the next segment where possible.
-    -- We don't merge it with the previous segment because the merged segment
-    -- would require 'Monad' while it may otherwise only require 'Applicative'.
-    merge [] = []
-    merge (seg : segs)
-       = case rest of
-          s:ss | all_lets -> (seg ++ s) : ss
-          _otherwise -> seg : rest
-      where
-        rest = merge segs
-        all_lets = all (isLetStmt . fst) seg
-
-    -- walk splits the statement sequence into segments, traversing
-    -- the sequence from the back to the front, and keeping track of
-    -- the set of free variables of the current segment.  Whenever
-    -- this set of free variables is empty, we have a complete segment.
-    walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
-    walk [] = []
-    walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest
-      where (seg,rest) = chunter fvs' stmts
-            (_, fvs') = stmtRefs stmt fvs
-
-    chunter _ [] = ([], [])
-    chunter vars ((stmt,fvs) : rest)
-       | not (isEmptyNameSet vars)
-       || isStrictPatternBind stmt
-           -- See Note [ApplicativeDo and strict patterns]
-       = ((stmt,fvs) : chunk, rest')
-       where (chunk,rest') = chunter vars' rest
-             (pvars, evars) = stmtRefs stmt fvs
-             vars' = (vars `minusNameSet` pvars) `unionNameSet` evars
-    chunter _ rest = ([], rest)
-
-    stmtRefs stmt fvs
-      | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)
-      | otherwise      = (pvars, fvs')
-      where fvs' = fvs `intersectNameSet` allvars
-            pvars = mkNameSet (collectStmtBinders CollNoDictBinders (unLoc stmt))
-
-    isStrictPatternBind :: ExprLStmt GhcRn -> Bool
-    isStrictPatternBind (L _ (BindStmt _ pat _)) = isStrictPattern pat
-    isStrictPatternBind _ = False
-
-{-
-Note [ApplicativeDo and strict patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A strict pattern match is really a dependency.  For example,
-
-do
-  (x,y) <- A
-  z <- B
-  return C
-
-The pattern (_,_) must be matched strictly before we do B.  If we
-allowed this to be transformed into
-
-  (\(x,y) -> \z -> C) <$> A <*> B
-
-then it could be lazier than the standard desugaring using >>=.  See #13875
-for more examples.
-
-Thus, whenever we have a strict pattern match, we treat it as a
-dependency between that statement and the following one.  The
-dependency prevents those two statements from being performed "in
-parallel" in an ApplicativeStmt, but doesn't otherwise affect what we
-can do with the rest of the statements in the same "do" expression.
--}
-
-isStrictPattern :: forall p. IsPass p => LPat (GhcPass p) -> Bool
-isStrictPattern (L loc pat) =
-  case pat of
-    WildPat{}       -> False
-    VarPat{}        -> False
-    LazyPat{}       -> False
-    AsPat _ _ _ p   -> isStrictPattern p
-    ParPat _ _ p _  -> isStrictPattern p
-    ViewPat _ _ p   -> isStrictPattern p
-    SigPat _ p _    -> isStrictPattern p
-    BangPat{}       -> True
-    ListPat{}       -> True
-    TuplePat{}      -> True
-    SumPat{}        -> True
-    ConPat{}        -> True
-    LitPat{}        -> True
-    NPat{}          -> True
-    NPlusKPat{}     -> True
-    SplicePat{}     -> True
-    XPat ext        -> case ghcPass @p of
-#if __GLASGOW_HASKELL__ < 811
-      GhcPs -> dataConCantHappen ext
-#endif
-      GhcRn
-        | HsPatExpanded _ p <- ext
-        -> isStrictPattern (L loc p)
-      GhcTc -> case ext of
-        ExpansionPat _ p -> isStrictPattern (L loc p)
-        CoPat {} -> panic "isStrictPattern: CoPat"
-
-{-
-Note [ApplicativeDo and refutable patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Refutable patterns in do blocks are desugared to use the monadic 'fail' operation.
-This means that sometimes an applicative block needs to be wrapped in 'join' simply because
-of a refutable pattern, in order for the types to work out.
-
--}
-
-hasRefutablePattern :: DynFlags -> ApplicativeArg GhcRn -> Bool
-hasRefutablePattern dflags (ApplicativeArgOne { app_arg_pattern = pat
-                                              , is_body_stmt = False}) =
-                                         not (isIrrefutableHsPat dflags pat)
-hasRefutablePattern _ _ = False
-
-isLetStmt :: LStmt (GhcPass a) b -> Bool
-isLetStmt (L _ LetStmt{}) = True
-isLetStmt _ = False
-
--- | Find a "good" place to insert a bind in an indivisible segment.
--- This is the only place where we use heuristics.  The current
--- heuristic is to peel off the first group of independent statements
--- and put the bind after those.
-splitSegment
-  :: [(ExprLStmt GhcRn, FreeVars)]
-  -> ( [(ExprLStmt GhcRn, FreeVars)]
-     , [(ExprLStmt GhcRn, FreeVars)] )
-splitSegment [one,two] = ([one],[two])
-  -- there is no choice when there are only two statements; this just saves
-  -- some work in a common case.
-splitSegment stmts
-  | Just (lets,binds,rest) <- slurpIndependentStmts stmts
-  =  if not (null lets)
-       then (lets, binds++rest)
-       else (lets++binds, rest)
-  | otherwise
-  = case stmts of
-      (x:xs) -> ([x],xs)
-      _other -> (stmts,[])
-
-slurpIndependentStmts
-   :: [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]
-   -> Maybe ( [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] -- LetStmts
-            , [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] -- BindStmts
-            , [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] )
-slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
- where
-  -- If we encounter a BindStmt that doesn't depend on a previous BindStmt
-  -- in this group, then add it to the group. We have to be careful about
-  -- strict patterns though; splitSegments expects that if we return Just
-  -- then we have actually done some splitting. Otherwise it will go into
-  -- an infinite loop (#14163).
-  go lets indep bndrs ((L loc (BindStmt xbs pat body), fvs): rest)
-    | disjointNameSet bndrs fvs && not (isStrictPattern pat)
-    = go lets ((L loc (BindStmt xbs pat body), fvs) : indep)
-         bndrs' rest
-    where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders CollNoDictBinders pat)
-  -- If we encounter a LetStmt that doesn't depend on a BindStmt in this
-  -- group, then move it to the beginning, so that it doesn't interfere with
-  -- grouping more BindStmts.
-  -- TODO: perhaps we shouldn't do this if there are any strict bindings,
-  -- because we might be moving evaluation earlier.
-  go lets indep bndrs ((L loc (LetStmt noExtField binds), fvs) : rest)
-    | disjointNameSet bndrs fvs
-    = go ((L loc (LetStmt noExtField binds), fvs) : lets) indep bndrs rest
-  go _ []  _ _ = Nothing
-  go _ [_] _ _ = Nothing
-  go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
-
--- | Build an ApplicativeStmt, and strip the "return" from the tail
--- if necessary.
---
--- For example, if we start with
---   do x <- E1; y <- E2; return (f x y)
--- then we get
---   do (E1[x] | E2[y]); f x y
---
--- the LastStmt in this case has the return removed, but we set the
--- flag on the LastStmt to indicate this, so that we can print out the
--- original statement correctly in error messages.  It is easier to do
--- it this way rather than try to ignore the return later in both the
--- typechecker and the desugarer (I tried it that way first!).
-mkApplicativeStmt
-  :: HsDoFlavour
-  -> [ApplicativeArg GhcRn]             -- ^ The args
-  -> Bool                               -- ^ True <=> need a join
-  -> [ExprLStmt GhcRn]        -- ^ The body statements
-  -> RnM ([ExprLStmt GhcRn], FreeVars)
-mkApplicativeStmt ctxt args need_join body_stmts
-  = do { (fmap_op, fvs1) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) fmapName
-       ; (ap_op, fvs2) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) apAName
-       ; (mb_join, fvs3) <-
-           if need_join then
-             do { (join_op, fvs) <- lookupQualifiedDoStmtName (HsDoStmt ctxt) joinMName
-                ; return (Just join_op, fvs) }
-           else
-             return (Nothing, emptyNameSet)
-       ; let applicative_stmt = noLocA $ ApplicativeStmt noExtField
-               (zip (fmap_op : repeat ap_op) args)
-               mb_join
-       ; return ( applicative_stmt : body_stmts
-                , fvs1 `plusFV` fvs2 `plusFV` fvs3) }
-
--- | Given the statements following an ApplicativeStmt, determine whether
--- we need a @join@ or not, and remove the @return@ if necessary.
---
--- We don't need @join@ if there's a single @LastStmt@ in the form of
--- @return E@, @return $ E@, @pure E@ or @pure $ E@.
-needJoin :: MonadNames
-         -> [ExprLStmt GhcRn]
-            -- If this is @Just pure@, replace return by pure
-            -- If this is @Nothing@, strip the return/pure
-         -> Maybe (HsExpr GhcRn)
-         -> (Bool, [ExprLStmt GhcRn])
-needJoin _monad_names [] _mb_pure = (False, [])  -- we're in an ApplicativeArg
-needJoin monad_names  [L loc (LastStmt _ e _ t)] mb_pure
- | Just (arg, noret) <- isReturnApp monad_names e mb_pure =
-       (False, [L loc (LastStmt noExtField arg noret t)])
-needJoin _monad_names stmts _mb_pure = (True, stmts)
-
--- | @(Just e, Just False)@, if the expression is @return/pure e@,
---     and the third argument is Nothing,
---   @(Just e, Just True)@ if the expression is @return/pure $ e@,
---     and the third argument is Nothing,
---   @(Just (pure e), Nothing)@ if the expression is @return/pure e@,
---     and the third argument is @Just pure_expr@,
---   @(Just (pure $ e), Nothing)@ if the expression is @return/pure $ e@,
---     and the third argument is @Just pure_expr@,
---   otherwise @Nothing@.
-isReturnApp :: MonadNames
-            -> LHsExpr GhcRn
-            -- If this is @Just pure@, replace return by pure
-            -- If this is @Nothing@, strip the return/pure
-            -> Maybe (HsExpr GhcRn)
-            -> Maybe (LHsExpr GhcRn, Maybe Bool)
-isReturnApp monad_names (L _ (HsPar _ _ expr _)) mb_pure =
-  isReturnApp monad_names expr mb_pure
-isReturnApp monad_names (L loc e) mb_pure = case e of
-  OpApp x l op r
-    | Just pure_expr <- mb_pure, is_return l, is_dollar op ->
-        Just (L loc (OpApp x (to_pure l pure_expr) op r), Nothing)
-    | is_return l, is_dollar op -> Just (r, Just True)
-  HsApp x f arg
-    | Just pure_expr <- mb_pure, is_return f ->
-        Just (L loc (HsApp x (to_pure f pure_expr) arg), Nothing)
-    | is_return f -> Just (arg, Just False)
-  _otherwise -> Nothing
- where
-  is_var f (L _ (HsPar _ _ e _)) = is_var f e
-  is_var f (L _ (HsAppType _ e _ _)) = is_var f e
-  is_var f (L _ (HsVar _ (L _ r))) = f r
-       -- TODO: I don't know how to get this right for rebindable syntax
-  is_var _ _ = False
-
-  is_return = is_var (\n -> n == return_name monad_names
-                         || n == pure_name monad_names)
-  to_pure (L loc _) pure_expr = L loc pure_expr
-  is_dollar = is_var (`hasKey` dollarIdKey)
-
-{-
-************************************************************************
-*                                                                      *
-\subsubsection{Errors}
-*                                                                      *
-************************************************************************
--}
-
-checkEmptyStmts :: HsStmtContext GhcRn -> RnM ()
--- We've seen an empty sequence of Stmts... is that ok?
-checkEmptyStmts ctxt
-  = mapM_ (addErr . TcRnEmptyStmtsGroup) mb_err
-  where
-    mb_err = case ctxt of
-      PatGuard {}      -> Nothing -- Pattern guards can be empty
-      ParStmtCtxt {}   -> Just EmptyStmtsGroupInParallelComp
-      TransStmtCtxt {} -> Just EmptyStmtsGroupInTransformListComp
-      HsDoStmt flav    -> Just $ EmptyStmtsGroupInDoNotation flav
-      ArrowExpr        -> Just EmptyStmtsGroupInArrowNotation
-
-----------------------
-checkLastStmt :: AnnoBody body
-              => HsStmtContext GhcRn
-              -> LStmt GhcPs (LocatedA (body GhcPs))
-              -> RnM (LStmt GhcPs (LocatedA (body GhcPs)))
-checkLastStmt ctxt lstmt@(L loc stmt)
-  = case ctxt of
-      HsDoStmt ListComp  -> check_comp
-      HsDoStmt MonadComp -> check_comp
-      HsDoStmt DoExpr{}  -> check_do
-      HsDoStmt MDoExpr{} -> check_do
-      ArrowExpr -> check_do
-      _         -> check_other
-  where
-    check_do    -- Expect BodyStmt, and change it to LastStmt
-      = case stmt of
-          BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))
-          LastStmt {}      -> return lstmt   -- "Deriving" clauses may generate a
-                                             -- LastStmt directly (unlike the parser)
-          _                -> do { addErr $ TcRnLastStmtNotExpr ctxt
-                                          $ UnexpectedStatement stmt
-                                 ; return lstmt }
-
-
-    check_comp  -- Expect LastStmt; this should be enforced by the parser!
-      = case stmt of
-          LastStmt {} -> return lstmt
-          _           -> pprPanic "checkLastStmt" (ppr lstmt)
-
-    check_other -- Behave just as if this wasn't the last stmt
-      = do { checkStmt ctxt lstmt; return lstmt }
-
--- Checking when a particular Stmt is ok
-checkStmt :: AnnoBody body
-          => HsStmtContext GhcRn
-          -> LStmt GhcPs (LocatedA (body GhcPs))
-          -> RnM ()
-checkStmt ctxt (L _ stmt)
-  = do { dflags <- getDynFlags
-       ; case okStmt dflags ctxt stmt of
-           IsValid      -> return ()
-           NotValid ext -> addErr $
-              TcRnUnexpectedStatementInContext
-                ctxt (UnexpectedStatement stmt) ext }
-
-------------
-emptyInvalid :: Validity' (Maybe LangExt.Extension)
-emptyInvalid = NotValid Nothing -- Invalid, and no extension to suggest
-
-okStmt, okDoStmt, okCompStmt, okParStmt
-   :: DynFlags -> HsStmtContext GhcRn
-   -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension)
--- Return Nothing if OK, (Just extra) if not ok
--- The "extra" is an SDoc that is appended to a generic error message
-
-okStmt dflags ctxt stmt
-  = case ctxt of
-      PatGuard {}        -> okPatGuardStmt stmt
-      ParStmtCtxt ctxt   -> okParStmt  dflags ctxt stmt
-      HsDoStmt flavour   -> okDoFlavourStmt dflags flavour ctxt stmt
-      ArrowExpr          -> okDoStmt   dflags ctxt stmt
-      TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
-
-okDoFlavourStmt
-  :: DynFlags -> HsDoFlavour -> HsStmtContext GhcRn
-  -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension)
-okDoFlavourStmt dflags flavour ctxt stmt = case flavour of
-      DoExpr{}     -> okDoStmt   dflags ctxt stmt
-      MDoExpr{}    -> okDoStmt   dflags ctxt stmt
-      GhciStmtCtxt -> okDoStmt   dflags ctxt stmt
-      ListComp     -> okCompStmt dflags ctxt stmt
-      MonadComp    -> okCompStmt dflags ctxt stmt
-
--------------
-okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity' (Maybe LangExt.Extension)
-okPatGuardStmt stmt
-  = case stmt of
-      BodyStmt {} -> IsValid
-      BindStmt {} -> IsValid
-      LetStmt {}  -> IsValid
-      _           -> emptyInvalid
-
--------------
-okParStmt dflags ctxt stmt
-  = case stmt of
-      LetStmt _ (HsIPBinds {}) -> emptyInvalid
-      _                        -> okStmt dflags ctxt stmt
-
-----------------
-okDoStmt dflags ctxt stmt
-  = case stmt of
-       RecStmt {}
-         | LangExt.RecursiveDo `xopt` dflags -> IsValid
-         | ArrowExpr <- ctxt -> IsValid    -- Arrows allows 'rec'
-         | otherwise         -> NotValid (Just LangExt.RecursiveDo)
-       BindStmt {} -> IsValid
-       LetStmt {}  -> IsValid
-       BodyStmt {} -> IsValid
-       _           -> emptyInvalid
-
-----------------
-okCompStmt dflags _ stmt
-  = case stmt of
-       BindStmt {} -> IsValid
-       LetStmt {}  -> IsValid
-       BodyStmt {} -> IsValid
-       ParStmt {}
-         | LangExt.ParallelListComp `xopt` dflags -> IsValid
-         | otherwise -> NotValid (Just LangExt.ParallelListComp)
-       TransStmt {}
-         | LangExt.TransformListComp `xopt` dflags -> IsValid
-         | otherwise -> NotValid (Just LangExt.TransformListComp)
-       RecStmt {}  -> emptyInvalid
-       LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)
-       ApplicativeStmt {} -> emptyInvalid
-
----------
-checkTupleSection :: [HsTupArg GhcPs] -> RnM ()
-checkTupleSection args
-  = do  { tuple_section <- xoptM LangExt.TupleSections
-        ; checkErr (all tupArgPresent args || tuple_section) msg }
-  where
-    msg :: TcRnMessage
-    msg = TcRnIllegalTupleSection
-
----------
-sectionErr :: HsExpr GhcPs -> TcRnMessage
-sectionErr = TcRnSectionWithoutParentheses
-
-badIpBinds :: Either (HsLocalBindsLR GhcPs GhcPs) (HsLocalBindsLR GhcRn GhcPs) -> TcRnMessage
-badIpBinds = TcRnIllegalImplicitParameterBindings
-
----------
-
-monadFailOp :: LPat GhcPs
-            -> HsStmtContext GhcRn
-            -> RnM (FailOperator GhcRn, FreeVars)
-monadFailOp pat ctxt = do
-    dflags <- getDynFlags
-        -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
-        -- we should not need to fail.
-    if | isIrrefutableHsPat dflags pat -> return (Nothing, emptyFVs)
-
-        -- For non-monadic contexts (e.g. guard patterns, list
-        -- comprehensions, etc.) we should not need to fail, or failure is handled in
-        -- a different way. See Note [Failing pattern matches in Stmts].
-       | not (isMonadStmtContext ctxt) -> return (Nothing, emptyFVs)
-
-       | otherwise -> getMonadFailOp ctxt
-
-{-
-Note [Monad fail : Rebindable syntax, overloaded strings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Given the code
-  foo x = do { Just y <- x; return y }
-
-we expect it to desugar as
-  foo x = x >>= \r -> case r of
-                        Just y  -> return y
-                        Nothing -> fail "Pattern match error"
-
-But with RebindableSyntax and OverloadedStrings, we really want
-it to desugar thus:
-  foo x = x >>= \r -> case r of
-                        Just y  -> return y
-                        Nothing -> fail (fromString "Patterm match error")
-
-So, in this case, we synthesize the function
-  \x -> fail (fromString x)
-
-(rather than plain 'fail') for the 'fail' operation. This is done in
-'getMonadFailOp'.
-
-Similarly with QualifiedDo and OverloadedStrings, we also want to desugar
-using fromString:
-
-  foo x = M.do { Just y <- x; return y }
-
-  ===>
-
-  foo x = x M.>>= \r -> case r of
-                        Just y  -> return y
-                        Nothing -> M.fail (fromString "Pattern match error")
-
--}
-getMonadFailOp :: HsStmtContext p -> RnM (FailOperator GhcRn, FreeVars) -- Syntax expr fail op
-getMonadFailOp ctxt
- = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
-      ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
-      ; (fail, fvs) <- reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
-      ; return (Just fail, fvs)
-      }
-  where
-    isQualifiedDo = isJust (qualifiedDoModuleName_maybe ctxt)
-
-    reallyGetMonadFailOp rebindableSyntax overloadedStrings
-      | (isQualifiedDo || rebindableSyntax) && overloadedStrings = do
-        (failExpr, failFvs) <- lookupQualifiedDoExpr ctxt failMName
-        (fromStringExpr, fromStringFvs) <- lookupSyntaxExpr fromStringName
-        let arg_lit = mkVarOccFS (fsLit "arg")
-        arg_name <- newSysName arg_lit
-        let arg_syn_expr = nlHsVar arg_name
-            body :: LHsExpr GhcRn =
-              nlHsApp (noLocA failExpr)
-                      (nlHsApp (noLocA $ fromStringExpr) arg_syn_expr)
-        let failAfterFromStringExpr :: HsExpr GhcRn =
-              unLoc $ mkHsLam [noLocA $ VarPat noExtField $ noLocA arg_name] body
-        let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
-              mkSyntaxExpr failAfterFromStringExpr
-        return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
-      | otherwise = lookupQualifiedDo ctxt failMName
-
-
-{- *********************************************************************
-*                                                                      *
-              Generating code for HsExpanded
-      See Note [Handling overloaded and rebindable constructs]
-*                                                                      *
-********************************************************************* -}
-
--- | Build a 'HsExpansion' out of an extension constructor,
---   and the two components of the expansion: original and
---   desugared expressions.
-mkExpandedExpr
-  :: HsExpr GhcRn           -- ^ source expression
-  -> HsExpr GhcRn           -- ^ expanded expression
-  -> HsExpr GhcRn           -- ^ suitably wrapped 'HsExpansion'
-mkExpandedExpr a b = XExpr (HsExpanded a b)
-
------------------------------------------
--- Bits and pieces for RecordDotSyntax.
---
--- See Note [Overview of record dot syntax] in GHC.Hs.Expr.
-
--- mkGetField arg field calculates a get_field @field arg expression.
--- e.g. z.x = mkGetField z x = get_field @x z
-mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
-mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field)
-
--- mkSetField a field b calculates a set_field @field expression.
--- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' on a to b").
-mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn
-mkSetField set_field a (L _ (FieldLabelString field)) b =
-  genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field)  a) b
-
-mkGet :: Name -> [LHsExpr GhcRn] -> LocatedAn NoEpAnns FieldLabelString -> [LHsExpr GhcRn]
-mkGet get_field l@(r : _) (L _ (FieldLabelString field)) =
-  wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l
-mkGet _ [] _ = panic "mkGet : The impossible has happened!"
-
-mkSet :: Name -> LHsExpr GhcRn -> (LocatedAn NoEpAnns FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn
-mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc)
-
--- mkProjection fields calculates a projection.
--- e.g. .x = mkProjection [x] = getField @"x"
---      .x.y = mkProjection [.x, .y] = (.y) . (.x) = getField @"y" . getField @"x"
-mkProjection :: Name -> Name -> NonEmpty (LocatedAn NoEpAnns FieldLabelString) -> HsExpr GhcRn
-mkProjection getFieldName circName (field :| fields) = foldl' f (proj field) fields
-  where
-    f :: HsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
-    f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc]
-
-    proj :: LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn
-    proj (L _ (FieldLabelString f)) = genHsVar getFieldName `genAppType` genHsTyLit f
-
--- mkProjUpdateSetField calculates functions representing dot notation record updates.
--- e.g. Suppose an update like foo.bar = 1.
---      We calculate the function \a -> setField @"foo" a (setField @"bar" (getField @"foo" a) 1).
-mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn)
-mkProjUpdateSetField get_field set_field (L _ (HsFieldBind { hfbLHS = (L _ (FieldLabelStrings flds')), hfbRHS = arg } ))
-  = let {
-      ; flds = map (fmap (unLoc . dfoLabel)) flds'
-      ; final = last flds  -- quux
-      ; fields = init flds   -- [foo, bar, baz]
-      ; getters = \a -> foldl' (mkGet get_field) [a] fields  -- Ordered from deep to shallow.
-          -- [getField@"baz"(getField@"bar"(getField@"foo" a), getField@"bar"(getField@"foo" a), getField@"foo" a, a]
-      ; zips = \a -> (final, head (getters a)) : zip (reverse fields) (tail (getters a)) -- Ordered from deep to shallow.
-          -- [("quux", getField@"baz"(getField@"bar"(getField@"foo" a)), ("baz", getField@"bar"(getField@"foo" a)), ("bar", getField@"foo" a), ("foo", a)]
-      }
-    in (\a -> foldl' (mkSet set_field) arg (zips a))
-          -- setField@"foo" (a) (setField@"bar" (getField @"foo" (a))(setField@"baz" (getField @"bar" (getField @"foo" (a)))(setField@"quux" (getField @"baz" (getField @"bar" (getField @"foo" (a))))(quux))))
-
-mkRecordDotUpd :: Name -> Name -> LHsExpr GhcRn -> [LHsRecUpdProj GhcRn] -> HsExpr GhcRn
-mkRecordDotUpd get_field set_field exp updates = foldl' fieldUpdate (unLoc exp) updates
-  where
-    fieldUpdate :: HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn
-    fieldUpdate acc lpu =  unLoc $ (mkProjUpdateSetField get_field set_field lpu) (wrapGenSpan acc)
-
-rnHsUpdProjs :: [LHsRecUpdProj GhcPs] -> RnM ([LHsRecUpdProj GhcRn], FreeVars)
-rnHsUpdProjs us = do
-  (u, fvs) <- unzip <$> mapM rnRecUpdProj us
-  pure (u, plusFVs fvs)
-  where
-    rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)
-    rnRecUpdProj (L l (HsFieldBind _ fs arg pun))
-      = do { (arg, fv) <- rnLExpr arg
-           ; return $
-               (L l (HsFieldBind {
-                         hfbAnn = noAnn
-                       , hfbLHS = fmap rnFieldLabelStrings fs
-                       , hfbRHS = arg
-                       , hfbPun = pun}), fv ) }
diff --git a/compiler/GHC/Rename/Expr.hs-boot b/compiler/GHC/Rename/Expr.hs-boot
deleted file mode 100644
--- a/compiler/GHC/Rename/Expr.hs-boot
+++ /dev/null
@@ -1,25 +0,0 @@
-{-# LANGUAGE ConstraintKinds #-}
-module GHC.Rename.Expr where
-
-import GHC.Types.Name
-import GHC.Hs
-import GHC.Types.Name.Set ( FreeVars )
-import GHC.Tc.Types
-import GHC.Utils.Outputable  ( Outputable )
-
-rnExpr :: HsExpr GhcPs
-        -> RnM (HsExpr GhcRn, FreeVars)
-
-rnLExpr :: LHsExpr GhcPs
-        -> RnM (LHsExpr GhcRn, FreeVars)
-
-type AnnoBody body
-  = ( Outputable (body GhcPs)
-    )
-
-rnStmts :: --forall thing body.
-           AnnoBody body => HsStmtContext GhcRn
-        -> (body GhcPs -> RnM (body GhcRn, FreeVars))
-        -> [LStmt GhcPs (LocatedA (body GhcPs))]
-        -> ([Name] -> RnM (thing, FreeVars))
-        -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)
diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs
deleted file mode 100644
--- a/compiler/GHC/Rename/Fixity.hs
+++ /dev/null
@@ -1,189 +0,0 @@
-{-
-This module contains code which maintains and manipulates the
-fixity environment during renaming.
--}
-
-module GHC.Rename.Fixity
-   ( MiniFixityEnv
-   , addLocalFixities
-   , lookupFixityRn
-   , lookupFixityRn_help
-   , lookupFieldFixityRn
-   , lookupTyFixityRn
-   ) where
-
-import GHC.Prelude
-
-import GHC.Iface.Load
-import GHC.Hs
-import GHC.Tc.Utils.Monad
-
-import GHC.Unit.Module
-import GHC.Unit.Module.ModIface
-
-import GHC.Types.Fixity.Env
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.Name.Reader
-import GHC.Types.Fixity
-import GHC.Types.SourceText
-import GHC.Types.SrcLoc
-
-import GHC.Utils.Outputable
-
-import GHC.Data.Maybe
-
-import GHC.Rename.Unbound
-
-{-
-*********************************************************
-*                                                      *
-                Fixities
-*                                                      *
-*********************************************************
-
-Note [Fixity signature lookup]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A fixity declaration like
-
-    infixr 2 ?
-
-can refer to a value-level operator, e.g.:
-
-    (?) :: String -> String -> String
-
-or a type-level operator, like:
-
-    data (?) a b = A a | B b
-
-so we extend the lookup of the reader name '?' to the TcClsName namespace, as
-well as the original namespace.
-
-The extended lookup is also used in other places, like resolution of
-deprecation declarations, and lookup of names in GHCi.
--}
-
---------------------------------
-type MiniFixityEnv = FastStringEnv (Located Fixity)
-        -- Mini fixity env for the names we're about
-        -- to bind, in a single binding group
-        --
-        -- It is keyed by the *FastString*, not the *OccName*, because
-        -- the single fixity decl       infix 3 T
-        -- affects both the data constructor T and the type constructor T
-        --
-        -- We keep the location so that if we find
-        -- a duplicate, we can report it sensibly
-
---------------------------------
--- Used for nested fixity decls to bind names along with their fixities.
--- the fixities are given as a UFM from an OccName's FastString to a fixity decl
-
-addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a
-addLocalFixities mini_fix_env names thing_inside
-  = extendFixityEnv (mapMaybe find_fixity names) thing_inside
-  where
-    find_fixity name
-      = case lookupFsEnv mini_fix_env (occNameFS occ) of
-          Just lfix -> Just (name, FixItem occ (unLoc lfix))
-          Nothing   -> Nothing
-      where
-        occ = nameOccName name
-
-{-
---------------------------------
-lookupFixity is a bit strange.
-
-* Nested local fixity decls are put in the local fixity env, which we
-  find with getFixtyEnv
-
-* Imported fixities are found in the PIT
-
-* Top-level fixity decls in this module may be for Names that are
-    either  Global         (constructors, class operations)
-    or      Local/Exported (everything else)
-  (See notes with GHC.Rename.Names.getLocalDeclBinders for why we have this split.)
-  We put them all in the local fixity environment
--}
-
-lookupFixityRn :: Name -> RnM Fixity
-lookupFixityRn name = lookupFixityRn' name (nameOccName name)
-
-lookupFixityRn' :: Name -> OccName -> RnM Fixity
-lookupFixityRn' name = fmap snd . lookupFixityRn_help' name
-
--- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity'
--- in a local environment or from an interface file. Otherwise, it returns
--- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without
--- user-supplied fixity declarations).
-lookupFixityRn_help :: Name
-                    -> RnM (Bool, Fixity)
-lookupFixityRn_help name =
-    lookupFixityRn_help' name (nameOccName name)
-
-lookupFixityRn_help' :: Name
-                     -> OccName
-                     -> RnM (Bool, Fixity)
-lookupFixityRn_help' name occ
-  | isUnboundName name
-  = return (False, Fixity NoSourceText minPrecedence InfixL)
-    -- Minimise errors from unbound names; eg
-    --    a>0 `foo` b>0
-    -- where 'foo' is not in scope, should not give an error (#7937)
-
-  | otherwise
-  = do { local_fix_env <- getFixityEnv
-       ; case lookupNameEnv local_fix_env name of {
-           Just (FixItem _ fix) -> return (True, fix) ;
-           Nothing ->
-
-    do { this_mod <- getModule
-       ; if nameIsLocalOrFrom this_mod name
-               -- Local (and interactive) names are all in the
-               -- fixity env, and don't have entries in the HPT
-         then return (False, defaultFixity)
-         else lookup_imported } } }
-  where
-    lookup_imported
-      -- For imported names, we have to get their fixities by doing a
-      -- loadInterfaceForName, and consulting the Ifaces that comes back
-      -- from that, because the interface file for the Name might not
-      -- have been loaded yet.  Why not?  Suppose you import module A,
-      -- which exports a function 'f', thus;
-      --        module CurrentModule where
-      --          import A( f )
-      --        module A( f ) where
-      --          import B( f )
-      -- Then B isn't loaded right away (after all, it's possible that
-      -- nothing from B will be used).  When we come across a use of
-      -- 'f', we need to know its fixity, and it's then, and only
-      -- then, that we load B.hi.  That is what's happening here.
-      --
-      -- loadInterfaceForName will find B.hi even if B is a hidden module,
-      -- and that's what we want.
-      = do { iface <- loadInterfaceForName doc name
-           ; let mb_fix = mi_fix_fn (mi_final_exts iface) occ
-           ; let msg = case mb_fix of
-                            Nothing ->
-                                  text "looking up name" <+> ppr name
-                              <+> text "in iface, but found no fixity for it."
-                              <+> text "Using default fixity instead."
-                            Just f ->
-                                  text "looking up name in iface and found:"
-                              <+> vcat [ppr name, ppr f]
-           ; traceRn "lookupFixityRn_either:" msg
-           ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix)  }
-
-    doc = text "Checking fixity for" <+> ppr name
-
----------------
-lookupTyFixityRn :: LocatedN Name -> RnM Fixity
-lookupTyFixityRn = lookupFixityRn . unLoc
-
--- | Look up the fixity of an occurrence of a record field selector.
--- We use 'lookupFixityRn'' so that we can specify the 'OccName' as
--- the field label, which might be different to the 'OccName' of the
--- selector 'Name' if @DuplicateRecordFields@ is in use (#1173).
-lookupFieldFixityRn :: FieldOcc GhcRn -> RnM Fixity
-lookupFieldFixityRn (FieldOcc n lrdr)
-  = lookupFixityRn' n (rdrNameOcc (unLoc lrdr))
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
deleted file mode 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ /dev/null
@@ -1,2087 +0,0 @@
-
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE LambdaCase          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies        #-}
-
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
-module GHC.Rename.HsType (
-        -- Type related stuff
-        rnHsType, rnLHsType, rnLHsTypes, rnContext, rnMaybeContext,
-        rnHsKind, rnLHsKind, rnLHsTypeArgs,
-        rnHsSigType, rnHsWcType, rnHsPatSigTypeBindingVars,
-        HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType,
-        newTyVarNameRn,
-        rnConDeclFields,
-        lookupField,
-        rnLTyVar,
-
-        rnScaledLHsType,
-
-        -- Precence related stuff
-        NegationHandling(..),
-        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
-        checkPrecMatch, checkSectionPrec,
-
-        -- Binding related stuff
-        bindHsOuterTyVarBndrs, bindHsForAllTelescope,
-        bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),
-        rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars,
-        FreeKiTyVars, filterInScopeM,
-        extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
-        extractHsTysRdrTyVars, extractRdrKindSigVars,
-        extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,
-        extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars,
-        nubL, nubN
-  ) where
-
-import GHC.Prelude
-
-import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType )
-
-import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
-import GHC.Driver.Session
-import GHC.Hs
-import GHC.Rename.Env
-import GHC.Rename.Doc
-import GHC.Rename.Utils  ( mapFvRn, bindLocalNamesFV
-                         , typeAppErr, newLocalBndrRn, checkDupRdrNamesN
-                         , checkShadowedRdrNames, warnForallIdentifier )
-import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn
-                         , lookupTyFixityRn )
-import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) )
-import GHC.Tc.Errors.Types
-import GHC.Tc.Errors.Ppr ( pprScopeError
-                         , inHsDocContext, pprHsDocContext )
-import GHC.Tc.Utils.Monad
-import GHC.Types.Name.Reader
-import GHC.Builtin.Names
-import GHC.Types.Hint ( UntickedPromotedThing(..) )
-import GHC.Types.Name
-import GHC.Types.SrcLoc
-import GHC.Types.Name.Set
-import GHC.Types.FieldLabel
-import GHC.Types.Error
-
-import GHC.Utils.Misc
-import GHC.Types.Fixity ( compareFixity, negateFixity
-                        , Fixity(..), FixityDirection(..), LexicalFixity(..) )
-import GHC.Types.Basic  ( TypeOrKind(..) )
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Data.Maybe
-import qualified GHC.LanguageExtensions as LangExt
-
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-import Data.List (nubBy, partition)
-import qualified Data.List.NonEmpty as NE
-import Data.List.NonEmpty (NonEmpty(..))
-import Control.Monad
-
-{-
-These type renamers are in a separate module, rather than in (say) GHC.Rename.Module,
-to break several loops.
-
-*********************************************************
-*                                                       *
-    HsSigWcType and HsPatSigType (i.e with wildcards)
-*                                                       *
-*********************************************************
--}
-
-data HsPatSigTypeScoping
-  = AlwaysBind
-    -- ^ Always bind any free tyvars of the given type, regardless of whether we
-    -- have a forall at the top.
-    --
-    -- For pattern type sigs, we /do/ want to bring those type
-    -- variables into scope, even if there's a forall at the top which usually
-    -- stops that happening, e.g:
-    --
-    -- > \ (x :: forall a. a -> b) -> e
-    --
-    -- Here we do bring 'b' into scope.
-    --
-    -- RULES can also use 'AlwaysBind', such as in the following example:
-    --
-    -- > {-# RULES \"f\" forall (x :: forall a. a -> b). f x = ... b ... #-}
-    --
-    -- This only applies to RULES that do not explicitly bind their type
-    -- variables. If a RULE explicitly quantifies its type variables, then
-    -- 'NeverBind' is used instead. See also
-    -- @Note [Pattern signature binders and scoping]@ in "GHC.Hs.Type".
-  | NeverBind
-    -- ^ Never bind any free tyvars. This is used for RULES that have both
-    -- explicit type and term variable binders, e.g.:
-    --
-    -- > {-# RULES \"const\" forall a. forall (x :: a) y. const x y = x #-}
-    --
-    -- The presence of the type variable binder @forall a.@ implies that the
-    -- free variables in the types of the term variable binders @x@ and @y@
-    -- are /not/ bound. In the example above, there are no such free variables,
-    -- but if the user had written @(y :: b)@ instead of @y@ in the term
-    -- variable binders, then @b@ would be rejected for being out of scope.
-    -- See also @Note [Pattern signature binders and scoping]@ in
-    -- "GHC.Hs.Type".
-
-rnHsSigWcType :: HsDocContext
-              -> LHsSigWcType GhcPs
-              -> RnM (LHsSigWcType GhcRn, FreeVars)
-rnHsSigWcType doc (HsWC { hswc_body =
-    sig_ty@(L loc (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty })) })
-  = do { free_vars <- filterInScopeM (extract_lhs_sig_ty sig_ty)
-       ; (nwc_rdrs', imp_tv_nms) <- partition_nwcs free_vars
-       ; let nwc_rdrs = nubL nwc_rdrs'
-       ; bindHsOuterTyVarBndrs doc Nothing imp_tv_nms outer_bndrs $ \outer_bndrs' ->
-    do { (wcs, body_ty', fvs) <- rnWcBody doc nwc_rdrs body_ty
-       ; pure ( HsWC  { hswc_ext = wcs, hswc_body = L loc $
-                HsSig { sig_ext = noExtField
-                      , sig_bndrs = outer_bndrs', sig_body = body_ty' }}
-              , fvs) } }
-
-rnHsPatSigType :: HsPatSigTypeScoping
-               -> HsDocContext
-               -> HsPatSigType GhcPs
-               -> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-               -> RnM (a, FreeVars)
--- Used for
---   - Pattern type signatures, which are only allowed with ScopedTypeVariables
---   - Signatures on binders in a RULE, which are allowed even if
---     ScopedTypeVariables isn't enabled
--- Wildcards are allowed
---
--- See Note [Pattern signature binders and scoping] in GHC.Hs.Type
-rnHsPatSigType scoping ctx sig_ty thing_inside
-  = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
-       ; checkErr ty_sig_okay (unexpectedPatSigTypeErr sig_ty)
-       ; free_vars <- filterInScopeM (extractHsTyRdrTyVars pat_sig_ty)
-       ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars
-       ; let nwc_rdrs = nubN nwc_rdrs'
-             implicit_bndrs = case scoping of
-               AlwaysBind -> tv_rdrs
-               NeverBind  -> []
-       ; rnImplicitTvOccs Nothing implicit_bndrs $ \ imp_tvs ->
-    do { (nwcs, pat_sig_ty', fvs1) <- rnWcBody ctx nwc_rdrs pat_sig_ty
-       ; let sig_names = HsPSRn { hsps_nwcs = nwcs, hsps_imp_tvs = imp_tvs }
-             sig_ty'   = HsPS { hsps_ext = sig_names, hsps_body = pat_sig_ty' }
-       ; (res, fvs2) <- thing_inside sig_ty'
-       ; return (res, fvs1 `plusFV` fvs2) } }
-  where
-    pat_sig_ty = hsPatSigType sig_ty
-
-rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
-rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
-  = do { free_vars <- filterInScopeM (extractHsTyRdrTyVars hs_ty)
-       ; (nwc_rdrs', _) <- partition_nwcs free_vars
-       ; let nwc_rdrs = nubL nwc_rdrs'
-       ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty
-       ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }
-       ; return (sig_ty', fvs) }
-
--- Similar to rnHsWcType, but rather than requiring free variables in the type to
--- already be in scope, we are going to require them not to be in scope,
--- and we bind them.
-rnHsPatSigTypeBindingVars :: HsDocContext
-                          -> HsPatSigType GhcPs
-                          -> (HsPatSigType GhcRn -> RnM (r, FreeVars))
-                          -> RnM (r, FreeVars)
-rnHsPatSigTypeBindingVars ctxt sigType thing_inside = case sigType of
-  (HsPS { hsps_body = hs_ty }) -> do
-    rdr_env <- getLocalRdrEnv
-    let (varsInScope, varsNotInScope) =
-          partition (inScope rdr_env . unLoc) (extractHsTyRdrTyVars hs_ty)
-    -- TODO: Resolve and remove this comment.
-    -- This next bit is in some contention. The original proposal #126
-    -- (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0126-type-applications-in-patterns.rst)
-    -- says that in-scope variables are fine here: don't bind them, just use
-    -- the existing vars, like in type signatures. An amendment #291
-    -- (https://github.com/ghc-proposals/ghc-proposals/pull/291) says that the
-    -- use of an in-scope variable should *shadow* an in-scope tyvar, like in
-    -- terms. In an effort to make forward progress, the current implementation
-    -- just rejects any use of an in-scope variable, meaning GHC will accept
-    -- a subset of programs common to both variants. If this comment still exists
-    -- in mid-to-late 2021 or thereafter, we have done a poor job on following
-    -- up on this point.
-    -- Example:
-    --   f :: forall a. ...
-    --   f (MkT @a ...) = ...
-    -- Should the inner `a` refer to the outer one? shadow it? We are, as yet, undecided,
-    -- so we currently reject.
-    when (not (null varsInScope)) $
-      addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-        vcat
-          [ text "Type variable" <> plural varsInScope
-            <+> hcat (punctuate (text ",") (map (quotes . ppr) varsInScope))
-            <+> isOrAre varsInScope
-            <+> text "already in scope."
-          , text "Type applications in patterns must bind fresh variables, without shadowing."
-          ]
-    (wcVars, ibVars) <- partition_nwcs varsNotInScope
-    rnImplicitTvBndrs ctxt Nothing ibVars $ \ ibVars' -> do
-      (wcVars', hs_ty', fvs) <- rnWcBody ctxt wcVars hs_ty
-      let sig_ty = HsPS
-            { hsps_body = hs_ty'
-            , hsps_ext = HsPSRn
-              { hsps_nwcs    = wcVars'
-              , hsps_imp_tvs = ibVars'
-              }
-            }
-      (res, fvs') <- thing_inside sig_ty
-      return (res, fvs `plusFV` fvs')
-
-rnWcBody :: HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs
-         -> RnM ([Name], LHsType GhcRn, FreeVars)
-rnWcBody ctxt nwc_rdrs hs_ty
-  = do { nwcs <- mapM newLocalBndrRn nwc_rdrs
-       ; let env = RTKE { rtke_level = TypeLevel
-                        , rtke_what  = RnTypeBody
-                        , rtke_nwcs  = mkNameSet nwcs
-                        , rtke_ctxt  = ctxt }
-       ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $
-                          rn_lty env hs_ty
-       ; return (nwcs, hs_ty', fvs) }
-  where
-    rn_lty env (L loc hs_ty)
-      = setSrcSpanA loc $
-        do { (hs_ty', fvs) <- rn_ty env hs_ty
-           ; return (L loc hs_ty', fvs) }
-
-    rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
-    -- A lot of faff just to allow the extra-constraints wildcard to appear
-    rn_ty env (HsForAllTy { hst_tele = tele, hst_body = hs_body })
-      = bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' ->
-        do { (hs_body', fvs) <- rn_lty env hs_body
-           ; return (HsForAllTy { hst_xforall = noExtField
-                                , hst_tele = tele', hst_body = hs_body' }
-                    , fvs) }
-
-    rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt
-                        , hst_body = hs_ty })
-      | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
-      , L lx (HsWildCardTy _)  <- ignoreParens hs_ctxt_last
-      = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
-           ; setSrcSpanA lx $ checkExtraConstraintWildCard env hs_ctxt1
-           ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)]
-           ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
-           ; return (HsQualTy { hst_xqual = noExtField
-                              , hst_ctxt = L cx hs_ctxt'
-                              , hst_body = hs_ty' }
-                    , fvs1 `plusFV` fvs2) }
-
-      | otherwise
-      = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt
-           ; (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty
-           ; return (HsQualTy { hst_xqual = noExtField
-                              , hst_ctxt = L cx hs_ctxt'
-                              , hst_body = hs_ty' }
-                    , fvs1 `plusFV` fvs2) }
-
-
-    rn_ty env hs_ty = rnHsTyKi env hs_ty
-
-    rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })
-
-
-checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()
--- Rename the extra-constraint spot in a type signature
---    (blah, _) => type
--- Check that extra-constraints are allowed at all, and
--- if so that it's an anonymous wildcard
-checkExtraConstraintWildCard env hs_ctxt
-  = checkWildCard env Nothing mb_bad
-  where
-    mb_bad | not (extraConstraintWildCardsAllowed env)
-           = Just $ ExtraConstraintWildcardNotAllowed
-                      SoleExtraConstraintWildcardNotAllowed
-             -- Currently, we do not allow wildcards in their full glory in
-             -- standalone deriving declarations. We only allow a single
-             -- extra-constraints wildcard à la:
-             --
-             --   deriving instance _ => Eq (Foo a)
-             --
-             -- i.e., we don't support things like
-             --
-             --   deriving instance (Eq a, _) => Eq (Foo a)
-           | DerivDeclCtx {} <- rtke_ctxt env
-           , not (null hs_ctxt)
-           = Just $ ExtraConstraintWildcardNotAllowed
-                      SoleExtraConstraintWildcardAllowed
-           | otherwise
-           = Nothing
-
-extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
-extraConstraintWildCardsAllowed env
-  = case rtke_ctxt env of
-      TypeSigCtx {}       -> True
-      ExprWithTySigCtx {} -> True
-      DerivDeclCtx {}     -> True
-      StandaloneKindSigCtx {} -> False  -- See Note [Wildcards in standalone kind signatures] in "GHC.Hs.Decls"
-      _                   -> False
-
--- | When the NamedWildCards extension is enabled, partition_nwcs
--- removes type variables that start with an underscore from the
--- FreeKiTyVars in the argument and returns them in a separate list.
--- When the extension is disabled, the function returns the argument
--- and empty list.  See Note [Renaming named wild cards]
-partition_nwcs :: FreeKiTyVars -> RnM ([LocatedN RdrName], FreeKiTyVars)
-partition_nwcs free_vars
-  = do { wildcards_enabled <- xoptM LangExt.NamedWildCards
-       ; return $
-           if wildcards_enabled
-           then partition is_wildcard free_vars
-           else ([], free_vars) }
-  where
-     is_wildcard :: LocatedN RdrName -> Bool
-     is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))
-
-{- Note [Renaming named wild cards]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Identifiers starting with an underscore are always parsed as type variables.
-It is only here in the renamer that we give the special treatment.
-See Note [The wildcard story for types] in GHC.Hs.Type.
-
-It's easy!  When we collect the implicitly bound type variables, ready
-to bring them into scope, and NamedWildCards is on, we partition the
-variables into the ones that start with an underscore (the named
-wildcards) and the rest. Then we just add them to the hswc_wcs field
-of the HsWildCardBndrs structure, and we are done.
-
-
-*********************************************************
-*                                                       *
-           HsSigType (i.e. no wildcards)
-*                                                       *
-****************************************************** -}
-
-rnHsSigType :: HsDocContext
-            -> TypeOrKind
-            -> LHsSigType GhcPs
-            -> RnM (LHsSigType GhcRn, FreeVars)
--- Used for source-language type signatures
--- that cannot have wildcards
-rnHsSigType ctx level
-    (L loc sig_ty@(HsSig { sig_bndrs = outer_bndrs, sig_body = body }))
-  = setSrcSpanA loc $
-    do { traceRn "rnHsSigType" (ppr sig_ty)
-       ; case outer_bndrs of
-           HsOuterExplicit{} -> checkPolyKinds env sig_ty
-           HsOuterImplicit{} -> pure ()
-       ; imp_vars <- filterInScopeM $ extractHsTyRdrTyVars body
-       ; bindHsOuterTyVarBndrs ctx Nothing imp_vars outer_bndrs $ \outer_bndrs' ->
-    do { (body', fvs) <- rnLHsTyKi env body
-
-       ; return ( L loc $ HsSig { sig_ext = noExtField
-                                , sig_bndrs = outer_bndrs', sig_body = body' }
-                , fvs ) } }
-  where
-    env = mkTyKiEnv ctx level RnTypeBody
-
--- | Create new renamed type variables corresponding to source-level ones.
--- Duplicates are permitted, but will be removed. This is intended especially for
--- the case of handling the implicitly bound free variables of a type signature.
-rnImplicitTvOccs :: Maybe assoc
-                 -- ^ @'Just' _@ => an associated type decl
-                 -> FreeKiTyVars
-                 -- ^ Surface-syntax free vars that we will implicitly bind.
-                 -- May have duplicates, which are removed here.
-                 -> ([Name] -> RnM (a, FreeVars))
-                 -> RnM (a, FreeVars)
-rnImplicitTvOccs mb_assoc implicit_vs_with_dups thing_inside
-  = do { let implicit_vs = nubN implicit_vs_with_dups
-
-       ; traceRn "rnImplicitTvOccs" $
-         vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ]
-
-         -- Use the currently set SrcSpan as the new source location for each Name.
-         -- See Note [Source locations for implicitly bound type variables].
-       ; loc <- getSrcSpanM
-       ; let loc' = noAnnSrcSpan loc
-       ; vars <- mapM (newTyVarNameRn mb_assoc . L loc' . unLoc) implicit_vs
-
-       ; bindLocalNamesFV vars $
-         thing_inside vars }
-
-{-
-Note [Source locations for implicitly bound type variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When bringing implicitly bound type variables into scope (in rnImplicitTvOccs),
-we do something peculiar: we drop the original SrcSpan attached to each
-variable and replace it with the currently set SrcSpan. Moreover, this new
-SrcSpan is usually /less/ precise than the original one, and that's OK. To see
-why this is done, consider the following example:
-
-  f :: a -> b -> a
-
-Suppose that a warning or error message needs to point to the SrcSpans of the
-binding sites for `a` and `b`. But where /are/ they bound, anyway? Technically,
-they're bound by an unwritten `forall` at the front of the type signature, but
-there is no SrcSpan for that. We could point to the first occurrence of `a` as
-the binding site for `a`, but that would make the first occurrence of `a`
-special. Moreover, we don't want IDEs to confuse binding sites and occurrences.
-
-As a result, we make the `SrcSpan`s for `a` and `b` span the entirety of the
-type signature, since the type signature implicitly carries their binding
-sites. This is less precise, but more accurate.
--}
-
--- | Create fresh type variables for binders, disallowing multiple occurrences of the same variable. Similar to `rnImplicitTvOccs` except that duplicate occurrences will
--- result in an error, and the source locations of the variables are not adjusted, as these variable occurrences are themselves the binding sites for the type variables,
--- rather than the variables being implicitly bound by a signature.
-rnImplicitTvBndrs :: HsDocContext
-                  -> Maybe assoc
-                  -- ^ @'Just' _@ => an associated type decl
-                  -> FreeKiTyVars
-                  -- ^ Surface-syntax free vars that we will implicitly bind.
-                  -- Duplicate variables will cause a compile-time error regarding repeated bindings.
-                  -> ([Name] -> RnM (a, FreeVars))
-                  -> RnM (a, FreeVars)
-rnImplicitTvBndrs ctx mb_assoc implicit_vs_with_dups thing_inside
-  = do { implicit_vs <- forM (NE.groupAllWith unLoc $ implicit_vs_with_dups) $ \case
-           (x :| []) -> return x
-           (x :| _) -> do
-             let msg = mkTcRnUnknownMessage $ mkPlainError noHints $
-                   text "Variable" <+> text "`" <> ppr x <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "."
-             addErr msg
-             return x
-
-       ; traceRn "rnImplicitTvBndrs" $
-         vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ]
-
-       ; vars <- mapM (newTyVarNameRn mb_assoc) implicit_vs
-
-       ; bindLocalNamesFV vars $
-         thing_inside vars }
-
-{- ******************************************************
-*                                                       *
-           LHsType and HsType
-*                                                       *
-****************************************************** -}
-
-{-
-rnHsType is here because we call it from loadInstDecl, and I didn't
-want a gratuitous knot.
-
-Note [HsQualTy in kinds]
-~~~~~~~~~~~~~~~~~~~~~~
-I was wondering whether HsQualTy could occur only at TypeLevel.  But no,
-we can have a qualified type in a kind too. Here is an example:
-
-  type family F a where
-    F Bool = Nat
-    F Nat  = Type
-
-  type family G a where
-    G Type = Type -> Type
-    G ()   = Nat
-
-  data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where
-    MkX :: X 'True '()
-
-See that k1 becomes Bool and k2 becomes (), so the equality is
-satisfied. If I write MkX :: X 'True 'False, compilation fails with a
-suitable message:
-
-  MkX :: X 'True '()
-    • Couldn't match kind ‘G Bool’ with ‘Nat’
-      Expected kind: G Bool
-        Actual kind: F Bool
-
-However: in a kind, the constraints in the HsQualTy must all be
-equalities; or at least, any kinds with a class constraint are
-uninhabited. See Note [Constraints in kinds] in GHC.Core.TyCo.Rep.
--}
-
-data RnTyKiEnv
-  = RTKE { rtke_ctxt  :: HsDocContext
-         , rtke_level :: TypeOrKind  -- Am I renaming a type or a kind?
-         , rtke_what  :: RnTyKiWhat  -- And within that what am I renaming?
-         , rtke_nwcs  :: NameSet     -- These are the in-scope named wildcards
-    }
-
-data RnTyKiWhat = RnTypeBody
-                | RnTopConstraint   -- Top-level context of HsSigWcTypes
-                | RnConstraint      -- All other constraints
-
-instance Outputable RnTyKiEnv where
-  ppr (RTKE { rtke_level = lev, rtke_what = what
-            , rtke_nwcs = wcs, rtke_ctxt = ctxt })
-    = text "RTKE"
-      <+> braces (sep [ ppr lev, ppr what, ppr wcs
-                      , pprHsDocContext ctxt ])
-
-instance Outputable RnTyKiWhat where
-  ppr RnTypeBody      = text "RnTypeBody"
-  ppr RnTopConstraint = text "RnTopConstraint"
-  ppr RnConstraint    = text "RnConstraint"
-
-mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
-mkTyKiEnv cxt level what
- = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet
-        , rtke_what = what, rtke_ctxt = cxt }
-
-isRnKindLevel :: RnTyKiEnv -> Bool
-isRnKindLevel (RTKE { rtke_level = KindLevel }) = True
-isRnKindLevel _                                 = False
-
---------------
-rnLHsType  :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
-rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
-
-rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
-rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
-
-rnScaledLHsType :: HsDocContext -> HsScaled GhcPs (LHsType GhcPs)
-                                  -> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
-rnScaledLHsType doc (HsScaled w ty) = do
-  (w' , fvs_w) <- rnHsArrow (mkTyKiEnv doc TypeLevel RnTypeBody) w
-  (ty', fvs) <- rnLHsType doc ty
-  return (HsScaled w' ty', fvs `plusFV` fvs_w)
-
-
-rnHsType  :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
-rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
-
-rnLHsKind  :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars)
-rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
-
-rnHsKind  :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars)
-rnHsKind ctxt kind = rnHsTyKi  (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
-
--- renaming a type only, not a kind
-rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs
-                -> RnM (LHsTypeArg GhcRn, FreeVars)
-rnLHsTypeArg ctxt (HsValArg ty)
-   = do { (tys_rn, fvs) <- rnLHsType ctxt ty
-        ; return (HsValArg tys_rn, fvs) }
-rnLHsTypeArg ctxt (HsTypeArg l ki)
-   = do { (kis_rn, fvs) <- rnLHsKind ctxt ki
-        ; return (HsTypeArg l kis_rn, fvs) }
-rnLHsTypeArg _ (HsArgPar sp)
-   = return (HsArgPar sp, emptyFVs)
-
-rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs]
-                 -> RnM ([LHsTypeArg GhcRn], FreeVars)
-rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args
-
---------------
-rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs
-              -> RnM (LHsContext GhcRn, FreeVars)
-rnTyKiContext env (L loc cxt)
-  = do { traceRn "rncontext" (ppr cxt)
-       ; let env' = env { rtke_what = RnConstraint }
-       ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt
-       ; return (L loc cxt', fvs) }
-
-rnContext :: HsDocContext -> LHsContext GhcPs
-          -> RnM (LHsContext GhcRn, FreeVars)
-rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta
-
-rnMaybeContext :: HsDocContext -> Maybe (LHsContext GhcPs)
-          -> RnM (Maybe (LHsContext GhcRn), FreeVars)
-rnMaybeContext _ Nothing = return (Nothing, emptyFVs)
-rnMaybeContext doc (Just theta)
-  = do { (theta', fvs) <- rnContext doc theta
-       ; return (Just theta', fvs)
-       }
-
-
---------------
-rnLHsTyKi  :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
-rnLHsTyKi env (L loc ty)
-  = setSrcSpanA loc $
-    do { (ty', fvs) <- rnHsTyKi env ty
-       ; return (L loc ty', fvs) }
-
-rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
-
-rnHsTyKi env ty@(HsForAllTy { hst_tele = tele, hst_body = tau })
-  = do { checkPolyKinds env ty
-       ; bindHsForAllTelescope (rtke_ctxt env) tele $ \ tele' ->
-    do { (tau',  fvs) <- rnLHsTyKi env tau
-       ; return ( HsForAllTy { hst_xforall = noExtField
-                             , hst_tele = tele' , hst_body =  tau' }
-                , fvs) } }
-
-rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
-  = do { data_kinds <- xoptM LangExt.DataKinds -- See Note [HsQualTy in kinds]
-       ; when (not data_kinds && isRnKindLevel env)
-              (addErr (dataKindsErr env ty))
-       ; (ctxt', fvs1) <- rnTyKiContext env lctxt
-       ; (tau',  fvs2) <- rnLHsTyKi env tau
-       ; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt'
-                          , hst_body =  tau' }
-                , fvs1 `plusFV` fvs2) }
-
-rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))
-  = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $
-         unlessXOptM LangExt.PolyKinds $ addErr $
-         TcRnWithHsDocContext (rtke_ctxt env) $
-         mkTcRnUnknownMessage $ mkPlainError noHints $
-         vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name)
-              , text "Perhaps you intended to use PolyKinds" ]
-           -- Any type variable at the kind level is illegal without the use
-           -- of PolyKinds (see #14710)
-       ; name <- rnTyVar env rdr_name
-       ; when (isDataConName name && not (isPromoted ip)) $
-         -- NB: a prefix symbolic operator such as (:) is represented as HsTyVar.
-            addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name)
-       ; return (HsTyVar noAnn ip (L loc name), unitFV name) }
-
-rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2)
-  = setSrcSpan (getLocA l_op) $
-    do  { (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op
-        ; let op_name = unLoc l_op'
-        ; fix   <- lookupTyFixityRn l_op'
-        ; (ty1', fvs2) <- rnLHsTyKi env ty1
-        ; (ty2', fvs3) <- rnLHsTyKi env ty2
-        ; res_ty <- mkHsOpTyRn prom l_op' fix ty1' ty2'
-        ; when (isDataConName op_name && not (isPromoted prom)) $
-            addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name)
-        ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
-
-rnHsTyKi env (HsParTy _ ty)
-  = do { (ty', fvs) <- rnLHsTyKi env ty
-       ; return (HsParTy noAnn ty', fvs) }
-
-rnHsTyKi env (HsBangTy x b ty)
-  = do { (ty', fvs) <- rnLHsTyKi env ty
-       ; return (HsBangTy x b ty', fvs) }
-
-rnHsTyKi env ty@(HsRecTy _ flds)
-  = do { let ctxt = rtke_ctxt env
-       ; fls          <- get_fields ctxt
-       ; (flds', fvs) <- rnConDeclFields ctxt fls flds
-       ; return (HsRecTy noExtField flds', fvs) }
-  where
-    get_fields (ConDeclCtx names)
-      = concatMapM (lookupConstructorFields . unLoc) names
-    get_fields _
-      = do { addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-               (hang (text "Record syntax is illegal here:") 2 (ppr ty))
-           ; return [] }
-
-rnHsTyKi env (HsFunTy u mult ty1 ty2)
-  = do { (ty1', fvs1) <- rnLHsTyKi env ty1
-       ; (ty2', fvs2) <- rnLHsTyKi env ty2
-       ; (mult', w_fvs) <- rnHsArrow env mult
-       ; return (HsFunTy u mult' ty1' ty2'
-                , plusFVs [fvs1, fvs2, w_fvs]) }
-
-rnHsTyKi env listTy@(HsListTy x ty)
-  = do { data_kinds <- xoptM LangExt.DataKinds
-       ; when (not data_kinds && isRnKindLevel env)
-              (addErr (dataKindsErr env listTy))
-       ; (ty', fvs) <- rnLHsTyKi env ty
-       ; return (HsListTy x ty', fvs) }
-
-rnHsTyKi env (HsKindSig x ty k)
-  = do { kind_sigs_ok <- xoptM LangExt.KindSignatures
-       ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)
-       ; (ty', lhs_fvs) <- rnLHsTyKi env ty
-       ; (k', sig_fvs)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k
-       ; return (HsKindSig x ty' k', lhs_fvs `plusFV` sig_fvs) }
-
--- Unboxed tuples are allowed to have poly-typed arguments.  These
--- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsTyKi env tupleTy@(HsTupleTy x tup_con tys)
-  = do { data_kinds <- xoptM LangExt.DataKinds
-       ; when (not data_kinds && isRnKindLevel env)
-              (addErr (dataKindsErr env tupleTy))
-       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
-       ; return (HsTupleTy x tup_con tys', fvs) }
-
-rnHsTyKi env sumTy@(HsSumTy x tys)
-  = do { data_kinds <- xoptM LangExt.DataKinds
-       ; when (not data_kinds && isRnKindLevel env)
-              (addErr (dataKindsErr env sumTy))
-       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
-       ; return (HsSumTy x tys', fvs) }
-
--- Ensure that a type-level integer is nonnegative (#8306, #8412)
-rnHsTyKi env tyLit@(HsTyLit src t)
-  = do { data_kinds <- xoptM LangExt.DataKinds
-       ; unless data_kinds (addErr (dataKindsErr env tyLit))
-       ; when (negLit t) (addErr negLitErr)
-       ; return (HsTyLit src (rnHsTyLit t), emptyFVs) }
-  where
-    negLit :: HsTyLit (GhcPass p) -> Bool
-    negLit (HsStrTy _ _) = False
-    negLit (HsNumTy _ i) = i < 0
-    negLit (HsCharTy _ _) = False
-    negLitErr :: TcRnMessage
-    negLitErr = mkTcRnUnknownMessage $ mkPlainError noHints $
-      text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit
-
-rnHsTyKi env (HsAppTy _ ty1 ty2)
-  = do { (ty1', fvs1) <- rnLHsTyKi env ty1
-       ; (ty2', fvs2) <- rnLHsTyKi env ty2
-       ; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) }
-
-rnHsTyKi env (HsAppKindTy l ty k)
-  = do { kind_app <- xoptM LangExt.TypeApplications
-       ; unless kind_app (addErr (typeAppErr "kind" k))
-       ; (ty', fvs1) <- rnLHsTyKi env ty
-       ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k
-       ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) }
-
-rnHsTyKi env t@(HsIParamTy x n ty)
-  = do { notInKinds env t
-       ; (ty', fvs) <- rnLHsTyKi env ty
-       ; return (HsIParamTy x n ty', fvs) }
-
-rnHsTyKi _ (HsStarTy _ isUni)
-  = return (HsStarTy noExtField isUni, emptyFVs)
-
-rnHsTyKi _ (HsSpliceTy _ sp)
-  = rnSpliceType sp
-
-rnHsTyKi env (HsDocTy x ty haddock_doc)
-  = do { (ty', fvs) <- rnLHsTyKi env ty
-       ; haddock_doc' <- rnLHsDoc haddock_doc
-       ; return (HsDocTy x ty' haddock_doc', fvs) }
-
--- See Note [Renaming HsCoreTys]
-rnHsTyKi env (XHsType ty)
-  = do mapM_ (check_in_scope . nameRdrName) fvs_list
-       return (XHsType ty, fvs)
-  where
-    fvs_list = map getName $ tyCoVarsOfTypeList ty
-    fvs = mkFVs fvs_list
-
-    check_in_scope :: RdrName -> RnM ()
-    check_in_scope rdr_name = do
-      mb_name <- lookupLocalOccRn_maybe rdr_name
-      -- TODO: refactor this to avoid mkTcRnUnknownMessage
-      when (isNothing mb_name) $
-        addErr $
-          TcRnWithHsDocContext (rtke_ctxt env) $
-          mkTcRnUnknownMessage $ mkPlainError noHints $
-          pprScopeError rdr_name (notInScopeErr WL_LocalOnly rdr_name)
-
-rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
-  = do { data_kinds <- xoptM LangExt.DataKinds
-       ; unless data_kinds (addErr (dataKindsErr env ty))
-       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
-       ; unless (isPromoted ip) $
-           addDiagnostic (TcRnUntickedPromotedThing $ UntickedExplicitList)
-       ; return (HsExplicitListTy noExtField ip tys', fvs) }
-
-rnHsTyKi env ty@(HsExplicitTupleTy _ tys)
-  = do { data_kinds <- xoptM LangExt.DataKinds
-       ; unless data_kinds (addErr (dataKindsErr env ty))
-       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
-       ; return (HsExplicitTupleTy noExtField tys', fvs) }
-
-rnHsTyKi env (HsWildCardTy _)
-  = do { checkAnonWildCard env
-       ; return (HsWildCardTy noExtField, emptyFVs) }
-
-
-rnHsTyLit :: HsTyLit GhcPs -> HsTyLit GhcRn
-rnHsTyLit (HsStrTy x s) = HsStrTy x s
-rnHsTyLit (HsNumTy x i) = HsNumTy x i
-rnHsTyLit (HsCharTy x c) = HsCharTy x c
-
-
-rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
-rnHsArrow _env (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr, emptyFVs)
-rnHsArrow _env (HsLinearArrow (HsPct1 pct1 arr)) = return (HsLinearArrow (HsPct1 pct1 arr), emptyFVs)
-rnHsArrow _env (HsLinearArrow (HsLolly arr)) = return (HsLinearArrow (HsLolly arr), emptyFVs)
-rnHsArrow env (HsExplicitMult pct p arr)
-  = (\(mult, fvs) -> (HsExplicitMult pct mult arr, fvs)) <$> rnLHsTyKi env p
-
-{-
-Note [Renaming HsCoreTys]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-HsCoreTy is an escape hatch that allows embedding Core Types in HsTypes.
-As such, there's not much to be done in order to rename an HsCoreTy,
-since it's already been renamed to some extent. However, in an attempt to
-detect ill-formed HsCoreTys, the renamer checks to see if all free type
-variables in an HsCoreTy are in scope. To see why this can matter, consider
-this example from #18914:
-
-  type T f = forall a. f a
-
-  class C f where
-    m :: T f
-
-  newtype N f a = MkN (f a)
-    deriving C
-
-Because of #18914, a previous GHC would generate the following code:
-
-  instance C f => C (N f) where
-    m :: T (N f)
-    m = coerce @(f a)   -- The type within @(...) is an HsCoreTy
-               @(N f a) -- So is this
-               (m @f)
-
-There are two HsCoreTys in play—(f a) and (N f a)—both of which have
-`f` and `a` as free type variables. The `f` is in scope from the instance head,
-but `a` is completely unbound, which is what led to #18914. To avoid this sort
-of mistake going forward, the renamer will now detect that `a` is unbound and
-throw an error accordingly.
--}
-
---------------
-rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
-rnTyVar env rdr_name
-  = do { name <- lookupTypeOccRn rdr_name
-       ; checkNamedWildCard env name
-       ; return name }
-
-rnLTyVar :: LocatedN RdrName -> RnM (LocatedN Name)
--- Called externally; does not deal with wildcards
-rnLTyVar (L loc rdr_name)
-  = do { tyvar <- lookupTypeOccRn rdr_name
-       ; return (L loc tyvar) }
-
---------------
-rnHsTyOp :: RnTyKiEnv -> SDoc -> LocatedN RdrName
-         -> RnM (LocatedN Name, FreeVars)
-rnHsTyOp env overall_ty (L loc op)
-  = do { op' <- rnTyVar env op
-       ; unlessXOptM LangExt.TypeOperators $
-           if (op' `hasKey` eqTyConKey) -- See [eqTyCon (~) compatibility fallback] in GHC.Rename.Env
-           then addDiagnostic TcRnTypeEqualityRequiresOperators
-           else addErr $ TcRnIllegalTypeOperator overall_ty op
-       ; return (L loc op', unitFV op') }
-
---------------
-checkWildCard :: RnTyKiEnv
-              -> Maybe Name -- ^ name of the wildcard,
-                            -- or 'Nothing' for an anonymous wildcard
-              -> Maybe BadAnonWildcardContext
-              -> RnM ()
-checkWildCard env mb_name (Just bad)
-  = addErr $ TcRnWithHsDocContext (rtke_ctxt env) $
-             TcRnIllegalWildcardInType mb_name bad
-checkWildCard _ _ Nothing
-  = return ()
-
-checkAnonWildCard :: RnTyKiEnv -> RnM ()
--- Report an error if an anonymous wildcard is illegal here
-checkAnonWildCard env
-  = checkWildCard env Nothing mb_bad
-  where
-    mb_bad :: Maybe BadAnonWildcardContext
-    mb_bad | not (wildCardsAllowed env)
-           = Just WildcardsNotAllowedAtAll
-           | otherwise
-           = case rtke_what env of
-               RnTypeBody      -> Nothing
-               RnTopConstraint -> Just WildcardNotLastInConstraint
-               RnConstraint    -> Just WildcardNotLastInConstraint
-
-checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()
--- Report an error if a named wildcard is illegal here
-checkNamedWildCard env name
-  = checkWildCard env (Just name) mb_bad
-  where
-    mb_bad | not (name `elemNameSet` rtke_nwcs env)
-           = Nothing  -- Not a wildcard
-           | not (wildCardsAllowed env)
-           = Just WildcardsNotAllowedAtAll
-           | otherwise
-           = case rtke_what env of
-               RnTypeBody      -> Nothing   -- Allowed
-               RnTopConstraint -> Nothing   -- Allowed; e.g.
-                  -- f :: (Eq _a) => _a -> Int
-                  -- g :: (_a, _b) => T _a _b -> Int
-                  -- The named tyvars get filled in from elsewhere
-               RnConstraint    -> Just WildcardNotLastInConstraint
-
-wildCardsAllowed :: RnTyKiEnv -> Bool
--- ^ In what contexts are wildcards permitted
-wildCardsAllowed env
-   = case rtke_ctxt env of
-       TypeSigCtx {}       -> True
-       TypBrCtx {}         -> True   -- Template Haskell quoted type
-       SpliceTypeCtx {}    -> True   -- Result of a Template Haskell splice
-       ExprWithTySigCtx {} -> True
-       PatCtx {}           -> True
-       RuleCtx {}          -> True
-       FamPatCtx {}        -> True   -- Not named wildcards though
-       GHCiCtx {}          -> True
-       HsTypeCtx {}        -> True
-       StandaloneKindSigCtx {} -> False  -- See Note [Wildcards in standalone kind signatures] in "GHC.Hs.Decls"
-       _                   -> False
-
-
-
----------------
--- | Ensures either that we're in a type or that -XPolyKinds is set
-checkPolyKinds :: Outputable ty
-                => RnTyKiEnv
-                -> ty      -- ^ type
-                -> RnM ()
-checkPolyKinds env ty
-  | isRnKindLevel env
-  = do { polykinds <- xoptM LangExt.PolyKinds
-       ; unless polykinds $
-         addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-           (text "Illegal kind:" <+> ppr ty $$
-            text "Did you mean to enable PolyKinds?") }
-checkPolyKinds _ _ = return ()
-
-notInKinds :: Outputable ty
-           => RnTyKiEnv
-           -> ty
-           -> RnM ()
-notInKinds env ty
-  | isRnKindLevel env
-  = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-     text "Illegal kind:" <+> ppr ty
-notInKinds _ _ = return ()
-
-{- *****************************************************
-*                                                      *
-          Binding type variables
-*                                                      *
-***************************************************** -}
-
-bindSigTyVarsFV :: [Name]
-                -> RnM (a, FreeVars)
-                -> RnM (a, FreeVars)
--- Used just before renaming the defn of a function
--- with a separate type signature, to bring its tyvars into scope
--- With no -XScopedTypeVariables, this is a no-op
-bindSigTyVarsFV tvs thing_inside
-  = do  { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables
-        ; if not scoped_tyvars then
-                thing_inside
-          else
-                bindLocalNamesFV tvs thing_inside }
-
----------------
-bindHsQTyVars :: forall a b.
-                 HsDocContext
-              -> Maybe a            -- Just _  => an associated type decl
-              -> FreeKiTyVars       -- Kind variables from scope
-              -> LHsQTyVars GhcPs
-              -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-                  -- The Bool is True <=> all kind variables used in the
-                  -- kind signature are bound on the left.  Reason:
-                  -- the last clause of Note [CUSKs: complete user-supplied kind signatures]
-                  -- in GHC.Hs.Decls
-              -> RnM (b, FreeVars)
-
--- See Note [bindHsQTyVars examples]
--- (a) Bring kind variables into scope
---     both (i)  passed in body_kv_occs
---     and  (ii) mentioned in the kinds of hsq_bndrs
--- (b) Bring type variables into scope
---
-bindHsQTyVars doc mb_assoc body_kv_occs hsq_bndrs thing_inside
-  = do { let bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs
-
-       ; let -- See Note [bindHsQTyVars examples] for what
-             -- all these various things are doing
-             bndrs, implicit_kvs :: [LocatedN RdrName]
-             bndrs        = map hsLTyVarLocName hs_tv_bndrs
-             implicit_kvs = filterFreeVarsToBind bndrs $
-               bndr_kv_occs ++ body_kv_occs
-             body_remaining = filterFreeVarsToBind bndr_kv_occs $
-              filterFreeVarsToBind bndrs body_kv_occs
-             all_bound_on_lhs = null body_remaining
-
-       ; traceRn "checkMixedVars3" $
-           vcat [ text "bndrs"   <+> ppr hs_tv_bndrs
-                , text "bndr_kv_occs"   <+> ppr bndr_kv_occs
-                , text "body_kv_occs"   <+> ppr body_kv_occs
-                , text "implicit_kvs"   <+> ppr implicit_kvs
-                , text "body_remaining" <+> ppr body_remaining
-                ]
-
-       ; rnImplicitTvOccs mb_assoc implicit_kvs $ \ implicit_kv_nms' ->
-         bindLHsTyVarBndrs doc NoWarnUnusedForalls mb_assoc hs_tv_bndrs $ \ rn_bndrs ->
-           -- This is the only call site for bindLHsTyVarBndrs where we pass
-           -- NoWarnUnusedForalls, which suppresses -Wunused-foralls warnings.
-           -- See Note [Suppress -Wunused-foralls when binding LHsQTyVars].
-    do { let -- The SrcSpan that rnImplicitTvOccs will attach to each Name will
-             -- span the entire declaration to which the LHsQTyVars belongs,
-             -- which will be reflected in warning and error messages. We can
-             -- be a little more precise than that by pointing to the location
-             -- of the LHsQTyVars instead, which is what bndrs_loc
-             -- corresponds to.
-             implicit_kv_nms = map (`setNameLoc` bndrs_loc) implicit_kv_nms'
-
-       ; traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)
-       ; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms
-                              , hsq_explicit  = rn_bndrs })
-                      all_bound_on_lhs } }
-  where
-    hs_tv_bndrs = hsQTvExplicit hsq_bndrs
-
-    -- The SrcSpan of the LHsQTyVars. For example, bndrs_loc would be the
-    -- highlighted part in the class below:
-    --
-    --   class C (a :: j) (b :: k) where
-    --            ^^^^^^^^^^^^^^^
-    bndrs_loc = case map get_bndr_loc hs_tv_bndrs ++ map getLocA body_kv_occs of
-      []         -> panic "bindHsQTyVars.bndrs_loc"
-      [loc]      -> loc
-      (loc:locs) -> loc `combineSrcSpans` last locs
-
-    -- The in-tree API annotations extend the LHsTyVarBndr location to
-    -- include surrounding parens. for error messages to be
-    -- compatible, we recreate the location from the contents
-    get_bndr_loc :: LHsTyVarBndr () GhcPs -> SrcSpan
-    get_bndr_loc (L _ (UserTyVar   _ _ ln)) = getLocA ln
-    get_bndr_loc (L _ (KindedTyVar _ _ ln lk))
-      = combineSrcSpans (getLocA ln) (getLocA lk)
-
-{- Note [bindHsQTyVars examples]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-   data T k (a::k1) (b::k) :: k2 -> k1 -> *
-
-Then:
-  hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables
-  bndrs       = [k,a,b]
-
-  bndr_kv_occs = [k,k1], kind variables free in kind signatures
-                         of hs_tv_bndrs
-
-  body_kv_occs = [k2,k1], kind variables free in the
-                          result kind signature
-
-  implicit_kvs = [k1,k2,k1], kind variables free in kind signatures
-                             of hs_tv_bndrs, and not bound by bndrs
-
-* We want to quantify add implicit bindings for implicit_kvs
-
-* If body_kv_occs is non-empty, then there is a kind variable
-  mentioned in the kind signature that is not bound "on the left".
-  That's one of the rules for a CUSK, so we pass that info on
-  as the second argument to thing_inside.
-
-* Order is not important in these lists.  All we are doing is
-  bring Names into scope.
-
-* bndr_kv_occs, body_kv_occs, and implicit_kvs can contain duplicates. All
-  duplicate occurrences are removed when we bind them with rnImplicitTvOccs.
-
-Finally, you may wonder why filterFreeVarsToBind removes in-scope variables
-from bndr/body_kv_occs.  How can anything be in scope?  Answer:
-HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax
-ConDecls
-   data T a = forall (b::k). MkT a b
-The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire
-ConDecl.  Hence the local RdrEnv may be non-empty and we must filter
-out 'a' from the free vars.  (Mind you, in this situation all the
-implicit kind variables are bound at the data type level, so there
-are none to bind in the ConDecl, so there are no implicitly bound
-variables at all.
-
-Note [Kind variable scoping]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we have
-  data T (a :: k) k = ...
-we report "k is out of scope" for (a::k).  Reason: k is not brought
-into scope until the explicit k-binding that follows.  It would be
-terribly confusing to bring into scope an /implicit/ k for a's kind
-and a distinct, shadowing explicit k that follows, something like
-  data T {k1} (a :: k1) k = ...
-
-So the rule is:
-
-   the implicit binders never include any
-   of the explicit binders in the group
-
-Note that in the denerate case
-  data T (a :: a) = blah
-we get a complaint the second 'a' is not in scope.
-
-That applies to foralls too: e.g.
-   forall (a :: k) k . blah
-
-But if the foralls are split, we treat the two groups separately:
-   forall (a :: k). forall k. blah
-Here we bring into scope an implicit k, which is later shadowed
-by the explicit k.
-
-In implementation terms
-
-* In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete
-  the binders {a,k}, and so end with no implicit binders.  Then we
-  rename the binders left-to-right, and hence see that 'k' is out of
-  scope in the kind of 'a'.
-
-* Similarly in extract_hs_tv_bndrs
-
-Note [Variables used as both types and kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We bind the type variables tvs, and kvs is the set of free variables of the
-kinds in the scope of the binding. Here is one typical example:
-
-   forall a b. a -> (b::k) -> (c::a)
-
-Here, tvs will be {a,b}, and kvs {k,a}.
-
-We must make sure that kvs includes all of variables in the kinds of type
-variable bindings. For instance:
-
-   forall k (a :: k). Proxy a
-
-If we only look in the body of the `forall` type, we will mistakenly conclude
-that kvs is {}. But in fact, the type variable `k` is also used as a kind
-variable in (a :: k), later in the binding. (This mistake lead to #14710.)
-So tvs is {k,a} and kvs is {k}.
-
-NB: we do this only at the binding site of 'tvs'.
-
-Note [Suppress -Wunused-foralls when binding LHsQTyVars]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The WarnUnusedForalls flag controls whether bindLHsTyVarBndrs should warn about
-explicit type variable binders that go unused (e.g., the `a` in
-`forall a. Int`). We almost always want to warn about these, since unused type
-variables can usually be deleted without any repercussions. There is one
-exception to this rule, however: binding LHsQTyVars. Consider this example:
-
-  data Proxy a = Proxy
-
-The `a` in `Proxy a` is bound by an LHsQTyVars, and the code which brings it
-into scope, bindHsQTyVars, will invoke bindLHsTyVarBndrs in turn. As such, it
-has a choice to make about whether to emit -Wunused-foralls warnings or not.
-If it /did/ emit warnings, then the `a` would be flagged as unused. However,
-this is not what we want! Removing the `a` in `Proxy a` would change its kind
-entirely, which is a huge price to pay for fixing a warning.
-
-Unlike other forms of type variable binders, dropping "unused" variables in
-an LHsQTyVars can be semantically significant. As a result, we suppress
--Wunused-foralls warnings in exactly one place: in bindHsQTyVars.
--}
-
-bindHsOuterTyVarBndrs :: OutputableBndrFlag flag 'Renamed
-                      => HsDocContext
-                      -> Maybe assoc
-                         -- ^ @'Just' _@ => an associated type decl
-                      -> FreeKiTyVars
-                      -> HsOuterTyVarBndrs flag GhcPs
-                      -> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))
-                      -> RnM (a, FreeVars)
-bindHsOuterTyVarBndrs doc mb_cls implicit_vars outer_bndrs thing_inside =
-  case outer_bndrs of
-    HsOuterImplicit{} ->
-      rnImplicitTvOccs mb_cls implicit_vars $ \implicit_vars' ->
-        thing_inside $ HsOuterImplicit { hso_ximplicit = implicit_vars' }
-    HsOuterExplicit{hso_bndrs = exp_bndrs} ->
-      -- Note: If we pass mb_cls instead of Nothing below, bindLHsTyVarBndrs
-      -- will use class variables for any names the user meant to bring in
-      -- scope here. This is an explicit forall, so we want fresh names, not
-      -- class variables. Thus: always pass Nothing.
-      bindLHsTyVarBndrs doc WarnUnusedForalls Nothing exp_bndrs $ \exp_bndrs' ->
-        thing_inside $ HsOuterExplicit { hso_xexplicit = noExtField
-                                       , hso_bndrs     = exp_bndrs' }
-
-bindHsForAllTelescope :: HsDocContext
-                      -> HsForAllTelescope GhcPs
-                      -> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-                      -> RnM (a, FreeVars)
-bindHsForAllTelescope doc tele thing_inside =
-  case tele of
-    HsForAllVis { hsf_vis_bndrs = bndrs } ->
-      bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' ->
-        thing_inside $ mkHsForAllVisTele noAnn bndrs'
-    HsForAllInvis { hsf_invis_bndrs = bndrs } ->
-      bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' ->
-        thing_inside $ mkHsForAllInvisTele noAnn bndrs'
-
--- | Should GHC warn if a quantified type variable goes unused? Usually, the
--- answer is \"yes\", but in the particular case of binding 'LHsQTyVars', we
--- avoid emitting warnings.
--- See @Note [Suppress -Wunused-foralls when binding LHsQTyVars]@.
-data WarnUnusedForalls
-  = WarnUnusedForalls
-  | NoWarnUnusedForalls
-
-instance Outputable WarnUnusedForalls where
-  ppr wuf = text $ case wuf of
-    WarnUnusedForalls   -> "WarnUnusedForalls"
-    NoWarnUnusedForalls -> "NoWarnUnusedForalls"
-
-bindLHsTyVarBndrs :: (OutputableBndrFlag flag 'Renamed)
-                  => HsDocContext
-                  -> WarnUnusedForalls
-                  -> Maybe a               -- Just _  => an associated type decl
-                  -> [LHsTyVarBndr flag GhcPs]  -- User-written tyvars
-                  -> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-                  -> RnM (b, FreeVars)
-bindLHsTyVarBndrs doc wuf mb_assoc tv_bndrs thing_inside
-  = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
-       ; checkDupRdrNamesN tv_names_w_loc
-       ; go tv_bndrs thing_inside }
-  where
-    tv_names_w_loc = map hsLTyVarLocName tv_bndrs
-
-    go []     thing_inside = thing_inside []
-    go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' ->
-                             do { (res, fvs) <- go bs $ \ bs' ->
-                                                thing_inside (b' : bs')
-                                ; warn_unused b' fvs
-                                ; return (res, fvs) }
-
-    warn_unused tv_bndr fvs = case wuf of
-      WarnUnusedForalls   -> warnUnusedForAll doc tv_bndr fvs
-      NoWarnUnusedForalls -> return ()
-
-bindLHsTyVarBndr :: HsDocContext
-                 -> Maybe a   -- associated class
-                 -> LHsTyVarBndr flag GhcPs
-                 -> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-                 -> RnM (b, FreeVars)
-bindLHsTyVarBndr _doc mb_assoc (L loc
-                                 (UserTyVar x fl
-                                    lrdr@(L lv _))) thing_inside
-  = do { nm <- newTyVarNameRn mb_assoc lrdr
-       ; bindLocalNamesFV [nm] $
-         thing_inside (L loc (UserTyVar x fl (L lv nm))) }
-
-bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x fl lrdr@(L lv _) kind))
-                 thing_inside
-  = do { sig_ok <- xoptM LangExt.KindSignatures
-           ; unless sig_ok (badKindSigErr doc kind)
-           ; (kind', fvs1) <- rnLHsKind doc kind
-           ; tv_nm  <- newTyVarNameRn mb_assoc lrdr
-           ; (b, fvs2) <- bindLocalNamesFV [tv_nm]
-               $ thing_inside (L loc (KindedTyVar x fl (L lv tv_nm) kind'))
-           ; return (b, fvs1 `plusFV` fvs2) }
-
-newTyVarNameRn :: Maybe a -- associated class
-               -> LocatedN RdrName -> RnM Name
-newTyVarNameRn mb_assoc lrdr@(L _ rdr)
-  = do { rdr_env <- getLocalRdrEnv
-       ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of
-           (Just _, Just n) -> return n
-              -- Use the same Name as the parent class decl
-
-           _                -> newLocalBndrRn lrdr }
-{-
-*********************************************************
-*                                                       *
-        ConDeclField
-*                                                       *
-*********************************************************
-
-When renaming a ConDeclField, we have to find the FieldLabel
-associated with each field.  But we already have all the FieldLabels
-available (since they were brought into scope by
-GHC.Rename.Names.getLocalNonValBinders), so we just take the list as an
-argument, build a map and look them up.
--}
-
-rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs]
-                -> RnM ([LConDeclField GhcRn], FreeVars)
--- Also called from GHC.Rename.Module
--- No wildcards can appear in record fields
-rnConDeclFields ctxt fls fields
-   = mapFvRn (rnField fl_env env) fields
-  where
-    env    = mkTyKiEnv ctxt TypeLevel RnTypeBody
-    fl_env = mkFsEnv [ (field_label $ flLabel fl, fl) | fl <- fls ]
-
-rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
-        -> RnM (LConDeclField GhcRn, FreeVars)
-rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))
-  = do { mapM_ (\(L _ (FieldOcc _ rdr_name)) -> warnForallIdentifier rdr_name) names
-       ; let new_names = map (fmap (lookupField fl_env)) names
-       ; (new_ty, fvs) <- rnLHsTyKi env ty
-       ; haddock_doc' <- traverse rnLHsDoc haddock_doc
-       ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc')
-                , fvs) }
-
-lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn
-lookupField fl_env (FieldOcc _ (L lr rdr)) =
-    FieldOcc (flSelector fl) (L lr rdr)
-  where
-    lbl = occNameFS $ rdrNameOcc rdr
-    fl  = expectJust "lookupField" $ lookupFsEnv fl_env lbl
-
-{-
-************************************************************************
-*                                                                      *
-        Fixities and precedence parsing
-*                                                                      *
-************************************************************************
-
-@mkOpAppRn@ deals with operator fixities.  The argument expressions
-are assumed to be already correctly arranged.  It needs the fixities
-recorded in the OpApp nodes, because fixity info applies to the things
-the programmer actually wrote, so you can't find it out from the Name.
-
-Furthermore, the second argument is guaranteed not to be another
-operator application.  Why? Because the parser parses all
-operator applications left-associatively, EXCEPT negation, which
-we need to handle specially.
-Infix types are read in a *right-associative* way, so that
-        a `op` b `op` c
-is always read in as
-        a `op` (b `op` c)
-
-mkHsOpTyRn rearranges where necessary.  The two arguments
-have already been renamed and rearranged.
-
-In the past, mkHsOpTyRn used to handle (->), but this was unnecessary. In the
-syntax tree produced by the parser, the arrow already has the least possible
-precedence and does not require rearrangement.
--}
-
----------------
--- Building (ty1 `op1` (ty2a `op2` ty2b))
-mkHsOpTyRn :: PromotionFlag
-           -> LocatedN Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
-           -> RnM (HsType GhcRn)
-
-mkHsOpTyRn prom1 op1 fix1 ty1 (L loc2 (HsOpTy _ prom2 ty2a op2 ty2b))
-  = do  { fix2 <- lookupTyFixityRn op2
-        ; mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 }
-
-mkHsOpTyRn prom1 op1 _ ty1 ty2              -- Default case, no rearrangement
-  = return (HsOpTy noAnn prom1 ty1 op1 ty2)
-
----------------
-mk_hs_op_ty :: PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn
-            -> PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn
-            -> LHsType GhcRn -> SrcSpanAnnA
-            -> RnM (HsType GhcRn)
-mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2
-  | nofix_error     = do { precParseErr (NormalOp (unLoc op1),fix1)
-                                        (NormalOp (unLoc op2),fix2)
-                         ; return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b))) }
-  | associate_right = return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b)))
-  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty2a) `op2` ty2b)
-                           new_ty <- mkHsOpTyRn prom1 op1 fix1 ty1 ty2a
-                         ; return (noLocA new_ty `op2ty` ty2b) }
-  where
-    lhs `op1ty` rhs = HsOpTy noAnn prom1 lhs op1 rhs
-    lhs `op2ty` rhs = HsOpTy noAnn prom2 lhs op2 rhs
-    (nofix_error, associate_right) = compareFixity fix1 fix2
-
-
----------------------------
-mkOpAppRn :: NegationHandling
-          -> LHsExpr GhcRn             -- Left operand; already rearranged
-          -> LHsExpr GhcRn -> Fixity   -- Operator and fixity
-          -> LHsExpr GhcRn             -- Right operand (not an OpApp, but might
-                                       -- be a NegApp)
-          -> RnM (HsExpr GhcRn)
-
--- (e1a `op1` e1b) `op2` e2
-mkOpAppRn negation_handling e1@(L _ (OpApp fix1 e1a op1 e1b)) op2 fix2 e2
-  | nofix_error
-  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
-       return (OpApp fix2 e1 op2 e2)
-
-  | associate_right = do
-    new_e <- mkOpAppRn negation_handling e1b op2 fix2 e2
-    return (OpApp fix1 e1a op1 (L loc' new_e))
-  where
-    loc'= combineLocsA e1b e2
-    (nofix_error, associate_right) = compareFixity fix1 fix2
-
----------------------------
---      (- neg_arg) `op` e2
-mkOpAppRn ReassociateNegation e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2
-  | nofix_error
-  = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)
-       return (OpApp fix2 e1 op2 e2)
-
-  | associate_right
-  = do new_e <- mkOpAppRn ReassociateNegation neg_arg op2 fix2 e2
-       return (NegApp noExtField (L loc' new_e) neg_name)
-  where
-    loc' = combineLocsA neg_arg e2
-    (nofix_error, associate_right) = compareFixity negateFixity fix2
-
----------------------------
---      e1 `op` - neg_arg
-mkOpAppRn ReassociateNegation e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right
-  | not associate_right                        -- We *want* right association
-  = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)
-       return (OpApp fix1 e1 op1 e2)
-  where
-    (_, associate_right) = compareFixity fix1 negateFixity
-
----------------------------
---      Default case
-mkOpAppRn _ e1 op fix e2                  -- Default case, no rearrangement
-  = assertPpr (right_op_ok fix (unLoc e2))
-              (ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2) $
-    return (OpApp fix e1 op e2)
-
-data NegationHandling = ReassociateNegation | KeepNegationIntact
-
-----------------------------
-
--- | Name of an operator in an operator application or section
-data OpName = NormalOp Name             -- ^ A normal identifier
-            | NegateOp                  -- ^ Prefix negation
-            | UnboundOp OccName         -- ^ An unbound identifier
-            | RecFldOp (FieldOcc GhcRn) -- ^ A record field occurrence
-
-instance Outputable OpName where
-  ppr (NormalOp n)   = ppr n
-  ppr NegateOp       = ppr negateName
-  ppr (UnboundOp uv) = ppr uv
-  ppr (RecFldOp fld) = ppr fld
-
-get_op :: LHsExpr GhcRn -> OpName
--- An unbound name could be either HsVar or HsUnboundVar
--- See GHC.Rename.Expr.rnUnboundVar
-get_op (L _ (HsVar _ n))         = NormalOp (unLoc n)
-get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv
-get_op (L _ (HsRecSel _ fld))    = RecFldOp fld
-get_op other                     = pprPanic "get_op" (ppr other)
-
--- Parser left-associates everything, but
--- derived instances may have correctly-associated things to
--- in the right operand.  So we just check that the right operand is OK
-right_op_ok :: Fixity -> HsExpr GhcRn -> Bool
-right_op_ok fix1 (OpApp fix2 _ _ _)
-  = not error_please && associate_right
-  where
-    (error_please, associate_right) = compareFixity fix1 fix2
-right_op_ok _ _
-  = True
-
--- Parser initially makes negation bind more tightly than any other operator
--- And "deriving" code should respect this (use HsPar if not)
-mkNegAppRn :: LHsExpr GhcRn -> SyntaxExpr GhcRn -> RnM (HsExpr GhcRn)
-mkNegAppRn neg_arg neg_name
-  = assert (not_op_app (unLoc neg_arg)) $
-    return (NegApp noExtField neg_arg neg_name)
-
-not_op_app :: HsExpr id -> Bool
-not_op_app (OpApp {}) = False
-not_op_app _          = True
-
----------------------------
-mkOpFormRn :: LHsCmdTop GhcRn            -- Left operand; already rearranged
-          -> LHsExpr GhcRn -> Fixity     -- Operator and fixity
-          -> LHsCmdTop GhcRn             -- Right operand (not an infix)
-          -> RnM (HsCmd GhcRn)
-
--- (e1a `op1` e1b) `op2` e2
-mkOpFormRn e1@(L loc
-                    (HsCmdTop _
-                     (L _ (HsCmdArrForm x op1 f (Just fix1)
-                        [e1a,e1b]))))
-        op2 fix2 e2
-  | nofix_error
-  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
-       return (HsCmdArrForm x op2 f (Just fix2) [e1, e2])
-
-  | associate_right
-  = do new_c <- mkOpFormRn e1a op2 fix2 e2
-       return (HsCmdArrForm noExtField op1 f (Just fix1)
-               [e1b, L loc (HsCmdTop [] (L (l2l loc) new_c))])
-        -- TODO: locs are wrong
-  where
-    (nofix_error, associate_right) = compareFixity fix1 fix2
-
---      Default case
-mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangement
-  = return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2])
-
-
---------------------------------------
-mkConOpPatRn :: LocatedN Name -> Fixity -> LPat GhcRn -> LPat GhcRn
-             -> RnM (Pat GhcRn)
-
-mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p1a p1b))) p2
-  = do  { fix1 <- lookupFixityRn (unLoc op1)
-        ; let (nofix_error, associate_right) = compareFixity fix1 fix2
-
-        ; if nofix_error then do
-                { precParseErr (NormalOp (unLoc op1),fix1)
-                               (NormalOp (unLoc op2),fix2)
-                ; return $ ConPat
-                    { pat_con_ext = noExtField
-                    , pat_con = op2
-                    , pat_args = InfixCon p1 p2
-                    }
-                }
-
-          else if associate_right then do
-                { new_p <- mkConOpPatRn op2 fix2 p1b p2
-                ; return $ ConPat
-                    { pat_con_ext = noExtField
-                    , pat_con = op1
-                    , pat_args = InfixCon p1a (L loc new_p)
-                    }
-                }
-                -- XXX loc right?
-          else return $ ConPat
-                 { pat_con_ext = noExtField
-                 , pat_con = op2
-                 , pat_args = InfixCon p1 p2
-                 }
-        }
-
-mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangement
-  = assert (not_op_pat (unLoc p2)) $
-    return $ ConPat
-      { pat_con_ext = noExtField
-      , pat_con = op
-      , pat_args = InfixCon p1 p2
-      }
-
-not_op_pat :: Pat GhcRn -> Bool
-not_op_pat (ConPat NoExtField _ (InfixCon _ _)) = False
-not_op_pat _                                    = True
-
---------------------------------------
-checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()
-  -- Check precedence of a function binding written infix
-  --   eg  a `op` b `C` c = ...
-  -- See comments with rnExpr (OpApp ...) about "deriving"
-
-checkPrecMatch op (MG { mg_alts = (L _ ms) })
-  = mapM_ check ms
-  where
-    check (L _ (Match { m_pats = (L l1 p1)
-                               : (L l2 p2)
-                               : _ }))
-      = setSrcSpan (locA $ combineSrcSpansA l1 l2) $
-        do checkPrec op p1 False
-           checkPrec op p2 True
-
-    check _ = return ()
-        -- This can happen.  Consider
-        --      a `op` True = ...
-        --      op          = ...
-        -- The infix flag comes from the first binding of the group
-        -- but the second eqn has no args (an error, but not discovered
-        -- until the type checker).  So we don't want to crash on the
-        -- second eqn.
-
-checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
-checkPrec op (ConPat NoExtField op1 (InfixCon _ _)) right = do
-    op_fix@(Fixity _ op_prec  op_dir) <- lookupFixityRn op
-    op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
-    let
-        inf_ok = op1_prec > op_prec ||
-                 (op1_prec == op_prec &&
-                  (op1_dir == InfixR && op_dir == InfixR && right ||
-                   op1_dir == InfixL && op_dir == InfixL && not right))
-
-        info  = (NormalOp op,          op_fix)
-        info1 = (NormalOp (unLoc op1), op1_fix)
-        (infol, infor) = if right then (info, info1) else (info1, info)
-    unless inf_ok (precParseErr infol infor)
-
-checkPrec _ _ _
-  = return ()
-
--- Check precedence of (arg op) or (op arg) respectively
--- If arg is itself an operator application, then either
---   (a) its precedence must be higher than that of op
---   (b) its precedency & associativity must be the same as that of op
-checkSectionPrec :: FixityDirection -> HsExpr GhcPs
-        -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM ()
-checkSectionPrec direction section op arg
-  = case unLoc arg of
-        OpApp fix _ op' _ -> go_for_it (get_op op') fix
-        NegApp _ _ _      -> go_for_it NegateOp     negateFixity
-        _                 -> return ()
-  where
-    op_name = get_op op
-    go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do
-          op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name
-          unless (op_prec < arg_prec
-                  || (op_prec == arg_prec && direction == assoc))
-                 (sectionPrecErr (get_op op, op_fix)
-                                 (arg_op, arg_fix) section)
-
--- | Look up the fixity for an operator name.  Be careful to use
--- 'lookupFieldFixityRn' for record fields (see #13132).
-lookupFixityOp :: OpName -> RnM Fixity
-lookupFixityOp (NormalOp n)  = lookupFixityRn n
-lookupFixityOp NegateOp      = lookupFixityRn negateName
-lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName u)
-lookupFixityOp (RecFldOp f)  = lookupFieldFixityRn f
-
-
--- Precedence-related error messages
-
-precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()
-precParseErr op1@(n1,_) op2@(n2,_)
-  | is_unbound n1 || is_unbound n2
-  = return ()     -- Avoid error cascade
-  | otherwise
-  = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-      hang (text "Precedence parsing error")
-      4 (hsep [text "cannot mix", ppr_opfix op1, text "and",
-               ppr_opfix op2,
-               text "in the same infix expression"])
-
-sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM ()
-sectionPrecErr op@(n1,_) arg_op@(n2,_) section
-  | is_unbound n1 || is_unbound n2
-  = return ()     -- Avoid error cascade
-  | otherwise
-  = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-      vcat [text "The operator" <+> ppr_opfix op <+> text "of a section",
-         nest 4 (sep [text "must have lower precedence than that of the operand,",
-                      nest 2 (text "namely" <+> ppr_opfix arg_op)]),
-         nest 4 (text "in the section:" <+> quotes (ppr section))]
-
-is_unbound :: OpName -> Bool
-is_unbound (NormalOp n) = isUnboundName n
-is_unbound UnboundOp{}  = True
-is_unbound _            = False
-
-ppr_opfix :: (OpName, Fixity) -> SDoc
-ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
-   where
-     pp_op | NegateOp <- op = text "prefix `-'"
-           | otherwise      = quotes (ppr op)
-
-
-{- *****************************************************
-*                                                      *
-                 Errors
-*                                                      *
-***************************************************** -}
-
-unexpectedPatSigTypeErr :: HsPatSigType GhcPs -> TcRnMessage
-unexpectedPatSigTypeErr ty
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (text "Illegal type signature:" <+> quotes (ppr ty))
-       2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")
-
-badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()
-badKindSigErr doc (L loc ty)
-  = setSrcSpanA loc $ addErr $
-    TcRnWithHsDocContext doc $
-    mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (text "Illegal kind signature:" <+> quotes (ppr ty))
-       2 (text "Perhaps you intended to use KindSignatures")
-
-dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> TcRnMessage
-dataKindsErr env thing
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))
-       2 (text "Perhaps you intended to use DataKinds")
-  where
-    pp_what | isRnKindLevel env = text "kind"
-            | otherwise          = text "type"
-
-warnUnusedForAll :: OutputableBndrFlag flag 'Renamed
-                 => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()
-warnUnusedForAll doc (L loc tv) used_names
-  = unless (hsTyVarName tv `elemNameSet` used_names) $ do
-      let msg = mkTcRnUnknownMessage $
-            mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedForalls) noHints $
-              vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)
-                   , inHsDocContext doc ]
-      addDiagnosticAt (locA loc) msg
-
-{-
-************************************************************************
-*                                                                      *
-      Finding the free type variables of a (HsType RdrName)
-*                                                                      *
-************************************************************************
-
-
-Note [Kind and type-variable binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In a type signature we may implicitly bind type/kind variables. For example:
-  *   f :: a -> a
-      f = ...
-    Here we need to find the free type variables of (a -> a),
-    so that we know what to quantify
-
-  *   class C (a :: k) where ...
-    This binds 'k' in ..., as well as 'a'
-
-  *   f (x :: a -> [a]) = ....
-    Here we bind 'a' in ....
-
-  *   f (x :: T a -> T (b :: k)) = ...
-    Here we bind both 'a' and the kind variable 'k'
-
-  *   type instance F (T (a :: Maybe k)) = ...a...k...
-    Here we want to constrain the kind of 'a', and bind 'k'.
-
-To do that, we need to walk over a type and find its free type/kind variables.
-We preserve the left-to-right order of each variable occurrence.
-See Note [Ordering of implicit variables].
-
-It is common for lists of free type variables to contain duplicates. For
-example, in `f :: a -> a`, the free type variable list is [a, a]. When these
-implicitly bound variables are brought into scope (with rnImplicitTvOccs),
-duplicates are removed with nubL.
-
-Note [Ordering of implicit variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Since the advent of -XTypeApplications, GHC makes promises about the ordering
-of implicit variable quantification. Specifically, we offer that implicitly
-quantified variables (such as those in const :: a -> b -> a, without a `forall`)
-will occur in left-to-right order of first occurrence. Here are a few examples:
-
-  const :: a -> b -> a       -- forall a b. ...
-  f :: Eq a => b -> a -> a   -- forall a b. ...  contexts are included
-
-  type a <-< b = b -> a
-  g :: a <-< b               -- forall a b. ...  type synonyms matter
-
-  class Functor f where
-    fmap :: (a -> b) -> f a -> f b   -- forall f a b. ...
-    -- The f is quantified by the class, so only a and b are considered in fmap
-
-This simple story is complicated by the possibility of dependency: all variables
-must come after any variables mentioned in their kinds.
-
-  typeRep :: Typeable a => TypeRep (a :: k)   -- forall k a. ...
-
-The k comes first because a depends on k, even though the k appears later than
-the a in the code. Thus, GHC does ScopedSort on the variables.
-See Note [ScopedSort] in GHC.Core.Type.
-
-Implicitly bound variables are collected by any function which returns a
-FreeKiTyVars, which notably includes the `extract-` family of functions
-(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.).
-These functions thus promise to keep left-to-right ordering.
-
-Note [Implicit quantification in type synonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We typically bind type/kind variables implicitly when they are in a kind
-annotation on the LHS, for example:
-
-  data Proxy (a :: k) = Proxy
-  type KindOf (a :: k) = k
-
-Here 'k' is in the kind annotation of a type variable binding, KindedTyVar, and
-we want to implicitly quantify over it.  This is easy: just extract all free
-variables from the kind signature. That's what we do in extract_hs_tv_bndrs_kvs
-
-By contrast, on the RHS we can't simply collect *all* free variables. Which of
-the following are allowed?
-
-  type TySyn1 = a :: Type
-  type TySyn2 = 'Nothing :: Maybe a
-  type TySyn3 = 'Just ('Nothing :: Maybe a)
-  type TySyn4 = 'Left a :: Either Type a
-
-After some design deliberations (see non-taken alternatives below), the answer
-is to reject TySyn1 and TySyn3, but allow TySyn2 and TySyn4, at least for now.
-We implicitly quantify over free variables of the outermost kind signature, if
-one exists:
-
-  * In TySyn1, the outermost kind signature is (:: Type), and it does not have
-    any free variables.
-  * In TySyn2, the outermost kind signature is (:: Maybe a), it contains a
-    free variable 'a', which we implicitly quantify over.
-  * In TySyn3, there is no outermost kind signature. The (:: Maybe a) signature
-    is hidden inside 'Just.
-  * In TySyn4, the outermost kind signature is (:: Either Type a), it contains
-    a free variable 'a', which we implicitly quantify over. That is why we can
-    also use it to the left of the double colon: 'Left a
-
-The logic resides in extractHsTyRdrTyVarsKindVars. We use it both for type
-synonyms and type family instances.
-
-This is something of a stopgap solution until we can explicitly bind invisible
-type/kind variables:
-
-  type TySyn3 :: forall a. Maybe a
-  type TySyn3 @a = 'Just ('Nothing :: Maybe a)
-
-Note [Implicit quantification in type synonyms: non-taken alternatives]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Alternative I: No quantification
---------------------------------
-We could offer no implicit quantification on the RHS, accepting none of the
-TySyn<N> examples. The user would have to bind the variables explicitly:
-
-  type TySyn1 a = a :: Type
-  type TySyn2 a = 'Nothing :: Maybe a
-  type TySyn3 a = 'Just ('Nothing :: Maybe a)
-  type TySyn4 a = 'Left a :: Either Type a
-
-However, this would mean that one would have to specify 'a' at call sites every
-time, which could be undesired.
-
-Alternative II: Indiscriminate quantification
----------------------------------------------
-We could implicitly quantify over all free variables on the RHS just like we do
-on the LHS. Then we would infer the following kinds:
-
-  TySyn1 :: forall {a}. Type
-  TySyn2 :: forall {a}. Maybe a
-  TySyn3 :: forall {a}. Maybe (Maybe a)
-  TySyn4 :: forall {a}. Either Type a
-
-This would work fine for TySyn<2,3,4>, but TySyn1 is clearly bogus: the variable
-is free-floating, not fixed by anything.
-
-Alternative III: reportFloatingKvs
-----------------------------------
-We could augment Alternative II by hunting down free-floating variables during
-type checking. While viable, this would mean we'd end up accepting this:
-
-  data Prox k (a :: k)
-  type T = Prox k
-
--}
-
--- A list of free type/kind variables, which can contain duplicates.
--- See Note [Kind and type-variable binders]
--- These lists are guaranteed to preserve left-to-right ordering of
--- the types the variables were extracted from. See also
--- Note [Ordering of implicit variables].
-type FreeKiTyVars = [LocatedN RdrName]
-
--- | Filter out any type and kind variables that are already in scope in the
--- the supplied LocalRdrEnv. Note that this includes named wildcards, which
--- look like perfectly ordinary type variables at this point.
-filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
-filterInScope rdr_env = filterOut (inScope rdr_env . unLoc)
-
--- | Filter out any type and kind variables that are already in scope in the
--- the environment's LocalRdrEnv. Note that this includes named wildcards,
--- which look like perfectly ordinary type variables at this point.
-filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars
-filterInScopeM vars
-  = do { rdr_env <- getLocalRdrEnv
-       ; return (filterInScope rdr_env vars) }
-
-inScope :: LocalRdrEnv -> RdrName -> Bool
-inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
-
-extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVars -> FreeKiTyVars
-extract_tyarg (HsValArg ty) acc = extract_lty ty acc
-extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc
-extract_tyarg (HsArgPar _) acc = acc
-
-extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVars -> FreeKiTyVars
-extract_tyargs args acc = foldr extract_tyarg acc args
-
-extractHsTyArgRdrKiTyVars :: [LHsTypeArg GhcPs] -> FreeKiTyVars
-extractHsTyArgRdrKiTyVars args
-  = extract_tyargs args []
-
--- | 'extractHsTyRdrTyVars' finds the type/kind variables
---                          of a HsType/HsKind.
--- It's used when making the @forall@s explicit.
--- See Note [Kind and type-variable binders]
-extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVars
-extractHsTyRdrTyVars ty = extract_lty ty []
-
--- | Extracts the free type/kind variables from the kind signature of a HsType.
---   This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@.
--- The left-to-right order of variables is preserved.
--- See Note [Kind and type-variable binders] and
---     Note [Ordering of implicit variables] and
---     Note [Implicit quantification in type synonyms].
-extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVars
-extractHsTyRdrTyVarsKindVars (L _ ty) =
-  case ty of
-    HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty
-    HsKindSig _ _ ki -> extractHsTyRdrTyVars ki
-    _ -> []
-
--- | Extracts free type and kind variables from types in a list.
--- When the same name occurs multiple times in the types, all occurrences
--- are returned.
-extractHsTysRdrTyVars :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars
-extractHsTysRdrTyVars tys = extract_ltys tys
-
--- Returns the free kind variables of any explicitly-kinded binders, returning
--- variable occurrences in left-to-right order.
--- See Note [Ordering of implicit variables].
--- NB: Does /not/ delete the binders themselves.
---     E.g. given  [k1, a:k1, b:k2]
---          the function returns [k1,k2], even though k1 is bound here
-extractHsTyVarBndrsKVs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
-extractHsTyVarBndrsKVs tv_bndrs = extract_hs_tv_bndrs_kvs tv_bndrs
-
--- Returns the free kind variables in a type family result signature, returning
--- variable occurrences in left-to-right order.
--- See Note [Ordering of implicit variables].
-extractRdrKindSigVars :: LFamilyResultSig GhcPs -> FreeKiTyVars
-extractRdrKindSigVars (L _ resultSig) = case resultSig of
-  KindSig _ k                            -> extractHsTyRdrTyVars k
-  TyVarSig _ (L _ (KindedTyVar _ _ _ k)) -> extractHsTyRdrTyVars k
-  _ -> []
-
--- | Extracts free type and kind variables from an argument in a GADT
--- constructor, returning variable occurrences in left-to-right order.
--- See @Note [Ordering of implicit variables]@.
-extractConDeclGADTDetailsTyVars ::
-  HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars
-extractConDeclGADTDetailsTyVars con_args = case con_args of
-  PrefixConGADT args      -> extract_scaled_ltys args
-  RecConGADT (L _ flds) _ -> extract_ltys $ map (cd_fld_type . unLoc) $ flds
-
--- | Get type/kind variables mentioned in the kind signature, preserving
--- left-to-right order:
---
---  * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type   -- result: [k2,k1]
---  * data T a (b :: k1)                             -- result: []
---
--- See Note [Ordering of implicit variables].
-extractDataDefnKindVars :: HsDataDefn GhcPs ->  FreeKiTyVars
-extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })
-  = maybe [] extractHsTyRdrTyVars ksig
-
-extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
-extract_lctxt ctxt = extract_ltys (unLoc ctxt)
-
-extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)]
-                    -> FreeKiTyVars -> FreeKiTyVars
-extract_scaled_ltys args acc = foldr extract_scaled_lty acc args
-
-extract_scaled_lty :: HsScaled GhcPs (LHsType GhcPs)
-                   -> FreeKiTyVars -> FreeKiTyVars
-extract_scaled_lty (HsScaled m ty) acc = extract_lty ty $ extract_hs_arrow m acc
-
-extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars
-extract_ltys tys acc = foldr extract_lty acc tys
-
-extract_lty :: LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
-extract_lty (L _ ty) acc
-  = case ty of
-      HsTyVar _ _  ltv            -> extract_tv ltv acc
-      HsBangTy _ _ ty             -> extract_lty ty acc
-      HsRecTy _ flds              -> foldr (extract_lty
-                                            . cd_fld_type . unLoc) acc
-                                           flds
-      HsAppTy _ ty1 ty2           -> extract_lty ty1 $
-                                     extract_lty ty2 acc
-      HsAppKindTy _ ty k          -> extract_lty ty $
-                                     extract_lty k acc
-      HsListTy _ ty               -> extract_lty ty acc
-      HsTupleTy _ _ tys           -> extract_ltys tys acc
-      HsSumTy _ tys               -> extract_ltys tys acc
-      HsFunTy _ w ty1 ty2         -> extract_lty ty1 $
-                                     extract_lty ty2 $
-                                     extract_hs_arrow w acc
-      HsIParamTy _ _ ty           -> extract_lty ty acc
-      HsOpTy _ _ ty1 tv ty2       -> extract_tv tv $
-                                     extract_lty ty1 $
-                                     extract_lty ty2 acc
-      HsParTy _ ty                -> extract_lty ty acc
-      HsSpliceTy {}               -> acc  -- Type splices mention no tvs
-      HsDocTy _ ty _              -> extract_lty ty acc
-      HsExplicitListTy _ _ tys    -> extract_ltys tys acc
-      HsExplicitTupleTy _ tys     -> extract_ltys tys acc
-      HsTyLit _ _                 -> acc
-      HsStarTy _ _                -> acc
-      HsKindSig _ ty ki           -> extract_lty ty $
-                                     extract_lty ki acc
-      HsForAllTy { hst_tele = tele, hst_body = ty }
-                                  -> extract_hs_for_all_telescope tele acc $
-                                     extract_lty ty []
-      HsQualTy { hst_ctxt = ctxt, hst_body = ty }
-                                  -> extract_lctxt ctxt $
-                                     extract_lty ty acc
-      XHsType {}                  -> acc
-      -- We deal with these separately in rnLHsTypeWithWildCards
-      HsWildCardTy {}             -> acc
-
-extract_lhs_sig_ty :: LHsSigType GhcPs -> FreeKiTyVars
-extract_lhs_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) =
-  extractHsOuterTvBndrs outer_bndrs $ extract_lty body []
-
-extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars ->
-                   FreeKiTyVars
-extract_hs_arrow (HsExplicitMult _ p _) acc = extract_lty p acc
-extract_hs_arrow _ acc = acc
-
-extract_hs_for_all_telescope :: HsForAllTelescope GhcPs
-                             -> FreeKiTyVars -- Accumulator
-                             -> FreeKiTyVars -- Free in body
-                             -> FreeKiTyVars
-extract_hs_for_all_telescope tele acc_vars body_fvs =
-  case tele of
-    HsForAllVis { hsf_vis_bndrs = bndrs } ->
-      extract_hs_tv_bndrs bndrs acc_vars body_fvs
-    HsForAllInvis { hsf_invis_bndrs = bndrs } ->
-      extract_hs_tv_bndrs bndrs acc_vars body_fvs
-
-extractHsOuterTvBndrs :: HsOuterTyVarBndrs flag GhcPs
-                      -> FreeKiTyVars -- Free in body
-                      -> FreeKiTyVars -- Free in result
-extractHsOuterTvBndrs outer_bndrs body_fvs =
-  case outer_bndrs of
-    HsOuterImplicit{}                  -> body_fvs
-    HsOuterExplicit{hso_bndrs = bndrs} -> extract_hs_tv_bndrs bndrs [] body_fvs
-
-extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs]
-                    -> FreeKiTyVars  -- Accumulator
-                    -> FreeKiTyVars  -- Free in body
-                    -> FreeKiTyVars
--- In (forall (a :: Maybe e). a -> b) we have
---     'a' is bound by the forall
---     'b' is a free type variable
---     'e' is a free kind variable
-extract_hs_tv_bndrs tv_bndrs acc_vars body_vars = new_vars ++ acc_vars
-  where
-    new_vars
-      | null tv_bndrs = body_vars
-      | otherwise = filterFreeVarsToBind tv_bndr_rdrs $ bndr_vars ++ body_vars
-    -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars.
-    -- See Note [Kind variable scoping]
-    bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs
-    tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs
-
-extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
--- Returns the free kind variables of any explicitly-kinded binders, returning
--- variable occurrences in left-to-right order.
--- See Note [Ordering of implicit variables].
--- NB: Does /not/ delete the binders themselves.
---     E.g. given  [k1, a:k1, b:k2]
---          the function returns [k1,k2], even though k1 is bound here
-extract_hs_tv_bndrs_kvs tv_bndrs =
-    foldr extract_lty []
-          [k | L _ (KindedTyVar _ _ _ k) <- tv_bndrs]
-
-extract_tv :: LocatedN RdrName -> FreeKiTyVars -> FreeKiTyVars
-extract_tv tv acc =
-  if isRdrTyVar (unLoc tv) then tv:acc else acc
-
--- Deletes duplicates in a list of Located things. This is used to:
---
--- * Delete duplicate occurrences of implicitly bound type/kind variables when
---   bringing them into scope (in rnImplicitTvOccs).
---
--- * Delete duplicate occurrences of named wildcards (in rn_hs_sig_wc_type and
---   rnHsWcType).
---
--- Importantly, this function is stable with respect to the original ordering
--- of things in the list. This is important, as it is a property that GHC
--- relies on to maintain the left-to-right ordering of implicitly quantified
--- type variables.
--- See Note [Ordering of implicit variables].
-nubL :: Eq a => [GenLocated l a] -> [GenLocated l a]
-nubL = nubBy eqLocated
-
-nubN :: Eq a => [LocatedN a] -> [LocatedN a]
-nubN = nubBy eqLocated
-
--- | Filter out any potential implicit binders that are either
--- already in scope, or are explicitly bound in the binder.
-filterFreeVarsToBind :: FreeKiTyVars
-                     -- ^ Explicitly bound here
-                     -> FreeKiTyVars
-                     -- ^ Potential implicit binders
-                     -> FreeKiTyVars
-                     -- ^ Final implicit binders
-filterFreeVarsToBind bndrs = filterOut is_in_scope
-    -- Make sure to list the binder kvs before the body kvs, as mandated by
-    -- Note [Ordering of implicit variables]
-  where
-    is_in_scope locc = any (eqLocated locc) bndrs
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
deleted file mode 100644
--- a/compiler/GHC/Rename/Module.hs
+++ /dev/null
@@ -1,2810 +0,0 @@
-
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies        #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
-
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-Main pass of renamer
--}
-
-module GHC.Rename.Module (
-        rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt
-    ) where
-
-import GHC.Prelude hiding ( head )
-
-import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr )
-import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls )
-
-import GHC.Hs
-import GHC.Types.Error
-import GHC.Types.FieldLabel
-import GHC.Types.Name.Reader
-import GHC.Rename.HsType
-import GHC.Rename.Bind
-import GHC.Rename.Doc
-import GHC.Rename.Env
-import GHC.Rename.Utils ( mapFvRn, bindLocalNames
-                        , checkDupRdrNamesN, bindLocalNamesFV
-                        , checkShadowedRdrNames, warnUnusedTypePatterns
-                        , newLocalBndrsRn
-                        , noNestedForallsContextsErr
-                        , addNoNestedForallsContextsErr, checkInferredVars, warnForallIdentifier )
-import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) )
-import GHC.Rename.Names
-import GHC.Tc.Errors.Types
-import GHC.Tc.Errors.Ppr (pprScopeError)
-import GHC.Tc.Gen.Annotation ( annCtxt )
-import GHC.Tc.Utils.Monad
-
-import GHC.Types.ForeignCall ( CCallTarget(..) )
-import GHC.Unit
-import GHC.Unit.Module.Warnings
-import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName
-                        , monadClassName, returnMName, thenMName
-                        , semigroupClassName, sappendName
-                        , monoidClassName, mappendName
-                        )
-import GHC.Types.Name
-import GHC.Types.Name.Set
-import GHC.Types.Name.Env
-import GHC.Types.Avail
-import GHC.Utils.Outputable
-import GHC.Data.Bag
-import GHC.Types.Basic  ( pprRuleName, TypeOrKind(..) )
-import GHC.Data.FastString
-import GHC.Types.SrcLoc as SrcLoc
-import GHC.Driver.Session
-import GHC.Utils.Misc   ( lengthExceeds, partitionWith )
-import GHC.Utils.Panic
-import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)
-import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses )
-import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..)
-                               , stronglyConnCompFromEdgedVerticesUniq )
-import GHC.Types.Unique.Set
-import GHC.Data.OrdList
-import qualified GHC.LanguageExtensions as LangExt
-import GHC.Core.DataCon ( isSrcStrict )
-
-import Control.Monad
-import Control.Arrow ( first )
-import Data.Foldable ( toList )
-import Data.List ( mapAccumL )
-import qualified Data.List.NonEmpty as NE
-import Data.List.NonEmpty ( NonEmpty(..), head )
-import Data.Maybe ( isNothing, fromMaybe, mapMaybe )
-import qualified Data.Set as Set ( difference, fromList, toList, null )
-import Data.Function ( on )
-
-{- | @rnSourceDecl@ "renames" declarations.
-It simultaneously performs dependency analysis and precedence parsing.
-It also does the following error checks:
-
-* Checks that tyvars are used properly. This includes checking
-  for undefined tyvars, and tyvars in contexts that are ambiguous.
-  (Some of this checking has now been moved to module @TcMonoType@,
-  since we don't have functional dependency information at this point.)
-
-* Checks that all variable occurrences are defined.
-
-* Checks the @(..)@ etc constraints in the export list.
-
-Brings the binders of the group into scope in the appropriate places;
-does NOT assume that anything is in scope already
--}
-rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn)
--- Rename a top-level HsGroup; used for normal source files *and* hs-boot files
-rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
-                            hs_splcds  = splice_decls,
-                            hs_tyclds  = tycl_decls,
-                            hs_derivds = deriv_decls,
-                            hs_fixds   = fix_decls,
-                            hs_warnds  = warn_decls,
-                            hs_annds   = ann_decls,
-                            hs_fords   = foreign_decls,
-                            hs_defds   = default_decls,
-                            hs_ruleds  = rule_decls,
-                            hs_docs    = docs })
- = do {
-   -- (A) Process the top-level fixity declarations, creating a mapping from
-   --     FastStrings to FixItems. Also checks for duplicates.
-   --     See Note [Top-level fixity signatures in an HsGroup] in GHC.Hs.Decls
-   local_fix_env <- makeMiniFixityEnv $ hsGroupTopLevelFixitySigs group ;
-
-   -- (B) Bring top level binders (and their fixities) into scope,
-   --     *except* for the value bindings, which get done in step (D)
-   --     with collectHsIdBinders. However *do* include
-   --
-   --        * Class ops, data constructors, and record fields,
-   --          because they do not have value declarations.
-   --
-   --        * For hs-boot files, include the value signatures
-   --          Again, they have no value declarations
-   --
-   (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
-
-
-   restoreEnvs tc_envs $ do {
-
-   failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
-
-   -- (D1) Bring pattern synonyms into scope.
-   --      Need to do this before (D2) because rnTopBindsLHS
-   --      looks up those pattern synonyms (#9889)
-
-   dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags ;
-   has_sel <- xopt_FieldSelectors <$> getDynFlags ;
-   extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env $ \pat_syn_bndrs -> do {
-
-   -- (D2) Rename the left-hand sides of the value bindings.
-   --     This depends on everything from (B) being in scope.
-   --     It uses the fixity env from (A) to bind fixities for view patterns.
-
-   -- We need to throw an error on such value bindings when in a boot file.
-   is_boot <- tcIsHsBootOrSig ;
-   new_lhs <- if is_boot
-    then rnTopBindsLHSBoot local_fix_env val_decls
-    else rnTopBindsLHS     local_fix_env val_decls ;
-
-   -- Bind the LHSes (and their fixities) in the global rdr environment
-   let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ;
-                    -- Excludes pattern-synonym binders
-                    -- They are already in scope
-   traceRn "rnSrcDecls" (ppr id_bndrs) ;
-   tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
-   restoreEnvs tc_envs $ do {
-
-   --  Now everything is in scope, as the remaining renaming assumes.
-
-   -- (E) Rename type and class decls
-   --     (note that value LHSes need to be in scope for default methods)
-   --
-   -- You might think that we could build proper def/use information
-   -- for type and class declarations, but they can be involved
-   -- in mutual recursion across modules, and we only do the SCC
-   -- analysis for them in the type checker.
-   -- So we content ourselves with gathering uses only; that
-   -- means we'll only report a declaration as unused if it isn't
-   -- mentioned at all.  Ah well.
-   traceRn "Start rnTyClDecls" (ppr tycl_decls) ;
-   (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
-
-   -- (F) Rename Value declarations right-hand sides
-   traceRn "Start rnmono" empty ;
-   let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
-   (rn_val_decls, bind_dus) <- if is_boot
-    -- For an hs-boot, use tc_bndrs (which collects how we're renamed
-    -- signatures), since val_bndr_set is empty (there are no x = ...
-    -- bindings in an hs-boot.)
-    then rnTopBindsBoot tc_bndrs new_lhs
-    else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ;
-   traceRn "finish rnmono" (ppr rn_val_decls) ;
-
-   -- (G) Rename Fixity and deprecations
-
-   -- Rename fixity declarations and error if we try to
-   -- fix something from another module (duplicates were checked in (A))
-   let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;
-   rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs)))
-                        fix_decls ;
-
-   -- Rename deprec decls;
-   -- check for duplicates and ensure that deprecated things are defined locally
-   -- at the moment, we don't keep these around past renaming
-   rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
-
-   -- (H) Rename Everything else
-
-   (rn_rule_decls,    src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $
-                                   rnList rnHsRuleDecls rule_decls ;
-                           -- Inside RULES, scoped type variables are on
-   (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ;
-   (rn_ann_decls,     src_fvs4) <- rnList rnAnnDecl       ann_decls ;
-   (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl   default_decls ;
-   (rn_deriv_decls,   src_fvs6) <- rnList rnSrcDerivDecl  deriv_decls ;
-   (rn_splice_decls,  src_fvs7) <- rnList rnSpliceDecl    splice_decls ;
-   rn_docs <- traverse rnLDocDecl docs ;
-
-   last_tcg_env <- getGblEnv ;
-   -- (I) Compute the results and return
-   let {rn_group = HsGroup { hs_ext     = noExtField,
-                             hs_valds   = rn_val_decls,
-                             hs_splcds  = rn_splice_decls,
-                             hs_tyclds  = rn_tycl_decls,
-                             hs_derivds = rn_deriv_decls,
-                             hs_fixds   = rn_fix_decls,
-                             hs_warnds  = [], -- warns are returned in the tcg_env
-                                             -- (see below) not in the HsGroup
-                             hs_fords  = rn_foreign_decls,
-                             hs_annds  = rn_ann_decls,
-                             hs_defds  = rn_default_decls,
-                             hs_ruleds = rn_rule_decls,
-                             hs_docs   = rn_docs } ;
-
-        tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;
-        other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
-        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
-                              src_fvs5, src_fvs6, src_fvs7] ;
-                -- It is tiresome to gather the binders from type and class decls
-
-        src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
-                -- Instance decls may have occurrences of things bound in bind_dus
-                -- so we must put other_fvs last
-
-        final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
-                        in -- we return the deprecs in the env, not in the HsGroup above
-                        tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
-       } ;
-   traceRn "finish rnSrc" (ppr rn_group) ;
-   traceRn "finish Dus" (ppr src_dus ) ;
-   return (final_tcg_env, rn_group)
-                    }}}}
-
-addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
--- This function could be defined lower down in the module hierarchy,
--- but there doesn't seem anywhere very logical to put it.
-addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
-
-rnList :: (a -> RnM (b, FreeVars)) -> [LocatedA a] -> RnM ([LocatedA b], FreeVars)
-rnList f xs = mapFvRn (wrapLocFstMA f) xs
-
-{-
-*********************************************************
-*                                                       *
-        Source-code deprecations declarations
-*                                                       *
-*********************************************************
-
-Check that the deprecated names are defined, are defined locally, and
-that there are no duplicate deprecations.
-
-It's only imported deprecations, dealt with in RnIfaces, that we
-gather them together.
--}
-
--- checks that the deprecations are defined locally, and that there are no duplicates
-rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM (Warnings GhcRn)
-rnSrcWarnDecls _ []
-  = return NoWarnings
-
-rnSrcWarnDecls bndr_set decls'
-  = do { -- check for duplicates
-       ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups
-                          in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr))
-               warn_rdr_dups
-       ; pairs_s <- mapM (addLocMA rn_deprec) decls
-       ; return (WarnSome ((concat pairs_s))) }
- where
-   decls = concatMap (wd_warnings . unLoc) decls'
-
-   sig_ctxt = TopSigCtxt bndr_set
-
-   rn_deprec (Warning _ rdr_names txt)
-       -- ensures that the names are defined locally
-     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
-                                rdr_names
-          ; txt' <- rnWarningTxt txt
-          ; return [(rdrNameOcc rdr, txt') | (rdr, _) <- names] }
-
-   what = text "deprecation"
-
-   warn_rdr_dups = findDupRdrNames
-                   $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls
-
-rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn)
-rnWarningTxt (WarningTxt st wst) = do
-  wst' <- traverse (traverse rnHsDoc) wst
-  pure (WarningTxt st wst')
-rnWarningTxt (DeprecatedTxt st wst) = do
-  wst' <- traverse (traverse rnHsDoc) wst
-  pure (DeprecatedTxt st wst')
-
-
-findDupRdrNames :: [LocatedN RdrName] -> [NonEmpty (LocatedN RdrName)]
-findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
-
--- look for duplicates among the OccNames;
--- we check that the names are defined above
--- invt: the lists returned by findDupsEq always have at least two elements
-
-{-
-*********************************************************
-*                                                      *
-\subsection{Annotation declarations}
-*                                                      *
-*********************************************************
--}
-
-rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
-rnAnnDecl ann@(HsAnnotation (_, s) provenance expr)
-  = addErrCtxt (annCtxt ann) $
-    do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
-       ; (expr', expr_fvs) <- setStage (Splice Untyped) $
-                              rnLExpr expr
-       ; return (HsAnnotation (noAnn, s) provenance' expr',
-                 provenance_fvs `plusFV` expr_fvs) }
-
-rnAnnProvenance :: AnnProvenance GhcPs
-                -> RnM (AnnProvenance GhcRn, FreeVars)
-rnAnnProvenance provenance = do
-    provenance' <- case provenance of
-      ValueAnnProvenance n -> ValueAnnProvenance
-                          <$> lookupLocatedTopBndrRnN n
-      TypeAnnProvenance n  -> TypeAnnProvenance
-                          <$> lookupLocatedTopConstructorRnN n
-      ModuleAnnProvenance  -> return ModuleAnnProvenance
-    return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
-
-{-
-*********************************************************
-*                                                      *
-\subsection{Default declarations}
-*                                                      *
-*********************************************************
--}
-
-rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
-rnDefaultDecl (DefaultDecl _ tys)
-  = do { (tys', fvs) <- rnLHsTypes doc_str tys
-       ; return (DefaultDecl noExtField tys', fvs) }
-  where
-    doc_str = DefaultDeclCtx
-
-{-
-*********************************************************
-*                                                      *
-\subsection{Foreign declarations}
-*                                                      *
-*********************************************************
--}
-
-rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
-rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
-  = do { topEnv :: HscEnv <- getTopEnv
-       ; warnForallIdentifier name
-       ; name' <- lookupLocatedTopBndrRnN name
-       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty
-
-        -- Mark any PackageTarget style imports as coming from the current package
-       ; let home_unit = hsc_home_unit topEnv
-             spec'  = patchForeignImport (homeUnitAsUnit home_unit) spec
-
-       ; return (ForeignImport { fd_i_ext = noExtField
-                               , fd_name = name', fd_sig_ty = ty'
-                               , fd_fi = spec' }, fvs) }
-
-rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
-  = do { name' <- lookupLocatedOccRn name
-       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty
-       ; return (ForeignExport { fd_e_ext = noExtField
-                               , fd_name = name', fd_sig_ty = ty'
-                               , fd_fe = (\(CExport x c) -> CExport x c) spec }
-                , fvs `addOneFV` unLoc name') }
-        -- NB: a foreign export is an *occurrence site* for name, so
-        --     we add it to the free-variable list.  It might, for example,
-        --     be imported from another module
-
--- | For Windows DLLs we need to know what packages imported symbols are from
---      to generate correct calls. Imported symbols are tagged with the current
---      package, so if they get inlined across a package boundary we'll still
---      know where they're from.
---
-patchForeignImport :: Unit -> (ForeignImport GhcPs) -> (ForeignImport GhcRn)
-patchForeignImport unit (CImport ext cconv safety fs spec)
-        = CImport ext cconv safety fs (patchCImportSpec unit spec)
-
-patchCImportSpec :: Unit -> CImportSpec -> CImportSpec
-patchCImportSpec unit spec
- = case spec of
-        CFunction callTarget    -> CFunction $ patchCCallTarget unit callTarget
-        _                       -> spec
-
-patchCCallTarget :: Unit -> CCallTarget -> CCallTarget
-patchCCallTarget unit callTarget =
-  case callTarget of
-  StaticTarget src label Nothing isFun
-                              -> StaticTarget src label (Just unit) isFun
-  _                           -> callTarget
-
-{-
-*********************************************************
-*                                                      *
-\subsection{Instance declarations}
-*                                                      *
-*********************************************************
--}
-
-rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
-rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
-  = do { (tfi', fvs) <- rnTyFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) tfi
-       ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) }
-
-rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
-  = do { (dfi', fvs) <- rnDataFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) dfi
-       ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) }
-
-rnSrcInstDecl (ClsInstD { cid_inst = cid })
-  = do { traceRn "rnSrcIstDecl {" (ppr cid)
-       ; (cid', fvs) <- rnClsInstDecl cid
-       ; traceRn "rnSrcIstDecl end }" empty
-       ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) }
-
--- | Warn about non-canonical typeclass instance declarations
---
--- A "non-canonical" instance definition can occur for instances of a
--- class which redundantly defines an operation its superclass
--- provides as well (c.f. `return`/`pure`). In such cases, a canonical
--- instance is one where the subclass inherits its method
--- implementation from its superclass instance (usually the subclass
--- has a default method implementation to that effect). Consequently,
--- a non-canonical instance occurs when this is not the case.
---
--- See also descriptions of 'checkCanonicalMonadInstances' and
--- 'checkCanonicalMonoidInstances'
-checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()
-checkCanonicalInstances cls poly_ty mbinds = do
-    whenWOptM Opt_WarnNonCanonicalMonadInstances
-        $ checkCanonicalMonadInstances
-        "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return"
-
-    whenWOptM Opt_WarnNonCanonicalMonoidInstances
-        $ checkCanonicalMonoidInstances
-        "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"
-
-  where
-    -- Warn about unsound/non-canonical 'Applicative'/'Monad' instance
-    -- declarations. Specifically, the following conditions are verified:
-    --
-    -- In 'Monad' instances declarations:
-    --
-    --  * If 'return' is overridden it must be canonical (i.e. @return = pure@)
-    --  * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@)
-    --
-    -- In 'Applicative' instance declarations:
-    --
-    --  * Warn if 'pure' is defined backwards (i.e. @pure = return@).
-    --  * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
-    --
-    checkCanonicalMonadInstances refURL
-      | cls == applicativeClassName =
-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $
-              case mbind of
-                  FunBind { fun_id = L _ name
-                          , fun_matches = mg }
-                      | name == pureAName, isAliasMG mg == Just returnMName
-                      -> addWarnNonCanonicalMethod1 refURL
-                            Opt_WarnNonCanonicalMonadInstances "pure" "return"
-
-                      | name == thenAName, isAliasMG mg == Just thenMName
-                      -> addWarnNonCanonicalMethod1 refURL
-                            Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"
-
-                  _ -> return ()
-
-      | cls == monadClassName =
-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $
-              case mbind of
-                  FunBind { fun_id = L _ name
-                          , fun_matches = mg }
-                      | name == returnMName, isAliasMG mg /= Just pureAName
-                      -> addWarnNonCanonicalMethod2 refURL
-                            Opt_WarnNonCanonicalMonadInstances "return" "pure"
-
-                      | name == thenMName, isAliasMG mg /= Just thenAName
-                      -> addWarnNonCanonicalMethod2 refURL
-                            Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"
-
-                  _ -> return ()
-
-      | otherwise = return ()
-
-    -- Check whether Monoid(mappend) is defined in terms of
-    -- Semigroup((<>)) (and not the other way round). Specifically,
-    -- the following conditions are verified:
-    --
-    -- In 'Monoid' instances declarations:
-    --
-    --  * If 'mappend' is overridden it must be canonical
-    --    (i.e. @mappend = (<>)@)
-    --
-    -- In 'Semigroup' instance declarations:
-    --
-    --  * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).
-    --
-    checkCanonicalMonoidInstances refURL
-      | cls == semigroupClassName =
-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $
-              case mbind of
-                  FunBind { fun_id      = L _ name
-                          , fun_matches = mg }
-                      | name == sappendName, isAliasMG mg == Just mappendName
-                      -> addWarnNonCanonicalMethod1 refURL
-                            Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"
-
-                  _ -> return ()
-
-      | cls == monoidClassName =
-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $
-              case mbind of
-                  FunBind { fun_id = L _ name
-                          , fun_matches = mg }
-                      | name == mappendName, isAliasMG mg /= Just sappendName
-                      -> addWarnNonCanonicalMethod2 refURL
-                            Opt_WarnNonCanonicalMonoidInstances
-                            "mappend" "(<>)"
-
-                  _ -> return ()
-
-      | otherwise = return ()
-
-    -- test whether MatchGroup represents a trivial \"lhsName = rhsName\"
-    -- binding, and return @Just rhsName@ if this is the case
-    isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
-    isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = []
-                                             , m_grhss = grhss })])}
-        | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss
-        , EmptyLocalBinds _ <- lbinds
-        , HsVar _ lrhsName  <- unLoc body  = Just (unLoc lrhsName)
-    isAliasMG _ = Nothing
-
-    -- got "lhs = rhs" but expected something different
-    addWarnNonCanonicalMethod1 refURL flag lhs rhs = do
-        let dia = mkTcRnUnknownMessage $
-              mkPlainDiagnostic (WarningWithFlag flag) noHints $
-                vcat [ text "Noncanonical" <+>
-                       quotes (text (lhs ++ " = " ++ rhs)) <+>
-                       text "definition detected"
-                     , instDeclCtxt1 poly_ty
-                     , text "Move definition from" <+>
-                       quotes (text rhs) <+>
-                       text "to" <+> quotes (text lhs)
-                     , text "See also:" <+>
-                       text refURL
-                     ]
-        addDiagnostic dia
-
-    -- expected "lhs = rhs" but got something else
-    addWarnNonCanonicalMethod2 refURL flag lhs rhs = do
-        let dia = mkTcRnUnknownMessage $
-              mkPlainDiagnostic (WarningWithFlag flag) noHints $
-                vcat [ text "Noncanonical" <+>
-                       quotes (text lhs) <+>
-                       text "definition detected"
-                     , instDeclCtxt1 poly_ty
-                     , quotes (text lhs) <+>
-                       text "will eventually be removed in favour of" <+>
-                       quotes (text rhs)
-                     , text "Either remove definition for" <+>
-                       quotes (text lhs) <+> text "(recommended)" <+>
-                       text "or define as" <+>
-                       quotes (text (lhs ++ " = " ++ rhs))
-                     , text "See also:" <+>
-                       text refURL
-                     ]
-        addDiagnostic dia
-
-    -- stolen from GHC.Tc.TyCl.Instance
-    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
-    instDeclCtxt1 hs_inst_ty
-      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
-
-    inst_decl_ctxt :: SDoc -> SDoc
-    inst_decl_ctxt doc = hang (text "in the instance declaration for")
-                         2 (quotes doc <> text ".")
-
-
-rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
-rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
-                           , cid_sigs = uprags, cid_tyfam_insts = ats
-                           , cid_overlap_mode = oflag
-                           , cid_datafam_insts = adts })
-  = do { checkInferredVars ctxt inf_err inst_ty
-       ; (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inst_ty
-       ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
-             -- Check if there are any nested `forall`s or contexts, which are
-             -- illegal in the type of an instance declaration (see
-             -- Note [No nested foralls or contexts in instance types] in
-             -- GHC.Hs.Type)...
-             mb_nested_msg = noNestedForallsContextsErr
-                               (text "Instance head") head_ty'
-             -- ...then check if the instance head is actually headed by a
-             -- class type constructor...
-             eith_cls = case hsTyGetAppHead_maybe head_ty' of
-               Just (L _ cls) -> Right cls
-               Nothing        -> Left
-                 ( getLocA head_ty'
-                 , mkTcRnUnknownMessage $ mkPlainError noHints $
-                   hang (text "Illegal head of an instance declaration:"
-                           <+> quotes (ppr head_ty'))
-                      2 (vcat [ text "Instance heads must be of the form"
-                              , nest 2 $ text "C ty_1 ... ty_n"
-                              , text "where" <+> quotes (char 'C')
-                                <+> text "is a class"
-                              ])
-                 )
-         -- ...finally, attempt to retrieve the class type constructor, failing
-         -- with an error message if there isn't one. To avoid excessive
-         -- amounts of error messages, we will only report one of the errors
-         -- from mb_nested_msg or eith_cls at a time.
-       ; cls <- case (mb_nested_msg, eith_cls) of
-           (Nothing,   Right cls) -> pure cls
-           (Just err1, _)         -> bail_out err1
-           (_,         Left err2) -> bail_out err2
-
-          -- Rename the bindings
-          -- The typechecker (not the renamer) checks that all
-          -- the bindings are for the right class
-          -- (Slightly strangely) when scoped type variables are on, the
-          -- forall-d tyvars scope over the method bindings too
-       ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags
-
-       ; checkCanonicalInstances cls inst_ty' mbinds'
-
-       -- Rename the associated types, and type signatures
-       -- Both need to have the instance type variables in scope
-       ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)
-       ; ((ats', adts'), more_fvs)
-             <- bindLocalNamesFV ktv_names $
-                do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats
-                   ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts
-                   ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }
-
-       ; let all_fvs = meth_fvs `plusFV` more_fvs
-                                `plusFV` inst_fvs
-       ; return (ClsInstDecl { cid_ext = noExtField
-                             , cid_poly_ty = inst_ty', cid_binds = mbinds'
-                             , cid_sigs = uprags', cid_tyfam_insts = ats'
-                             , cid_overlap_mode = oflag
-                             , cid_datafam_insts = adts' },
-                 all_fvs) }
-             -- We return the renamed associated data type declarations so
-             -- that they can be entered into the list of type declarations
-             -- for the binding group, but we also keep a copy in the instance.
-             -- The latter is needed for well-formedness checks in the type
-             -- checker (eg, to ensure that all ATs of the instance actually
-             -- receive a declaration).
-             -- NB: Even the copies in the instance declaration carry copies of
-             --     the instance context after renaming.  This is a bit
-             --     strange, but should not matter (and it would be more work
-             --     to remove the context).
-  where
-    ctxt    = GenericCtx $ text "an instance declaration"
-    inf_err = Just (text "Inferred type variables are not allowed")
-
-    -- The instance is malformed. We'd still like to make *some* progress
-    -- (rather than failing outright), so we report an error and continue for
-    -- as long as we can. Importantly, this error should be thrown before we
-    -- reach the typechecker, lest we encounter different errors that are
-    -- hopelessly confusing (such as the one in #16114).
-    bail_out (l, err_msg) = do
-      addErrAt l $ TcRnWithHsDocContext ctxt err_msg
-      pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))
-
-rnFamEqn :: HsDocContext
-         -> AssocTyFamInfo
-         -> FreeKiTyVars
-         -- ^ Additional kind variables to implicitly bind if there is no
-         --   explicit forall. (See the comments on @all_imp_vars@ below for a
-         --   more detailed explanation.)
-         -> FamEqn GhcPs rhs
-         -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
-         -> RnM (FamEqn GhcRn rhs', FreeVars)
-rnFamEqn doc atfi extra_kvars
-    (FamEqn { feqn_tycon  = tycon
-            , feqn_bndrs  = outer_bndrs
-            , feqn_pats   = pats
-            , feqn_fixity = fixity
-            , feqn_rhs    = payload }) rn_payload
-  = do { tycon' <- lookupFamInstName mb_cls tycon
-
-         -- all_imp_vars represent the implicitly bound type variables. This is
-         -- empty if we have an explicit `forall` (see
-         -- Note [forall-or-nothing rule] in GHC.Hs.Type), which means
-         -- ignoring:
-         --
-         -- - pat_kity_vars, the free variables mentioned in the type patterns
-         --   on the LHS of the equation, and
-         -- - extra_kvars, which is one of the following:
-         --   * For type family instances, extra_kvars are the free kind
-         --     variables mentioned in an outermost kind signature on the RHS
-         --     of the equation.
-         --     (See Note [Implicit quantification in type synonyms] in
-         --     GHC.Rename.HsType.)
-         --   * For data family instances, extra_kvars are the free kind
-         --     variables mentioned in the explicit return kind, if one is
-         --     provided. (e.g., the `k` in `data instance T :: k -> Type`).
-         --
-         -- Some examples:
-         --
-         -- @
-         -- type family F a b
-         -- type instance forall a b c. F [(a, b)] c = a -> b -> c
-         --   -- all_imp_vars = []
-         -- type instance F [(a, b)] c = a -> b -> c
-         --   -- all_imp_vars = [a, b, c]
-         --
-         -- type family G :: Maybe a
-         -- type instance forall a. G = (Nothing :: Maybe a)
-         --   -- all_imp_vars = []
-         -- type instance G = (Nothing :: Maybe a)
-         --   -- all_imp_vars = [a]
-         --
-         -- data family H :: k -> Type
-         -- data instance forall k. H :: k -> Type where ...
-         --   -- all_imp_vars = []
-         -- data instance H :: k -> Type where ...
-         --   -- all_imp_vars = [k]
-         -- @
-         --
-         -- For associated type family instances, exclude the type variables
-         -- bound by the instance head with filterInScopeM (#19649).
-       ; all_imp_vars <- filterInScopeM $ pat_kity_vars ++ extra_kvars
-
-       ; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs ->
-    do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
-       ; (payload', rhs_fvs) <- rn_payload doc payload
-
-          -- Report unused binders on the LHS
-          -- See Note [Unused type variables in family instances]
-       ; let -- The SrcSpan that bindHsOuterFamEqnTyVarBndrs will attach to each
-             -- implicitly bound type variable Name in outer_bndrs' will
-             -- span the entire type family instance, which will be reflected in
-             -- -Wunused-type-patterns warnings. We can be a little more precise
-             -- than that by pointing to the LHS of the instance instead, which
-             -- is what lhs_loc corresponds to.
-             rn_outer_bndrs' = mapHsOuterImplicit (map (`setNameLoc` lhs_loc))
-                                                  rn_outer_bndrs
-
-             groups :: [NonEmpty (LocatedN RdrName)]
-             groups = equivClasses cmpLocated pat_kity_vars
-       ; nms_dups <- mapM (lookupOccRn . unLoc) $
-                        [ tv | (tv :| (_:_)) <- groups ]
-             -- Add to the used variables
-             --  a) any variables that appear *more than once* on the LHS
-             --     e.g.   F a Int a = Bool
-             --  b) for associated instances, the variables
-             --     of the instance decl.  See
-             --     Note [Unused type variables in family instances]
-       ; let nms_used = extendNameSetList rhs_fvs $
-                           nms_dups {- (a) -} ++ inst_head_tvs {- (b) -}
-             all_nms = hsOuterTyVarNames rn_outer_bndrs'
-       ; warnUnusedTypePatterns all_nms nms_used
-
-         -- For associated family instances, if a type variable from the
-         -- parent instance declaration is mentioned on the RHS of the
-         -- associated family instance but not bound on the LHS, then reject
-         -- that type variable as being out of scope.
-         -- See Note [Renaming associated types].
-         -- Per that Note, the LHS type variables consist of:
-         --
-         -- - The variables mentioned in the instance's type patterns
-         --   (pat_fvs), and
-         --
-         -- - The variables mentioned in an outermost kind signature on the
-         --   RHS. This is a subset of `rhs_fvs`. To compute it, we look up
-         --   each RdrName in `extra_kvars` to find its corresponding Name in
-         --   the LocalRdrEnv.
-       ; extra_kvar_nms <- mapMaybeM (lookupLocalOccRn_maybe . unLoc) extra_kvars
-       ; let lhs_bound_vars = pat_fvs `extendNameSetList` extra_kvar_nms
-             improperly_scoped cls_tkv =
-                  cls_tkv `elemNameSet` rhs_fvs
-                    -- Mentioned on the RHS...
-               && not (cls_tkv `elemNameSet` lhs_bound_vars)
-                    -- ...but not bound on the LHS.
-             bad_tvs = filter improperly_scoped inst_head_tvs
-       ; unless (null bad_tvs) (badAssocRhs bad_tvs)
-
-       ; let eqn_fvs = rhs_fvs `plusFV` pat_fvs
-             -- See Note [Type family equations and occurrences]
-             all_fvs = case atfi of
-                         NonAssocTyFamEqn ClosedTyFam
-                           -> eqn_fvs
-                         _ -> eqn_fvs `addOneFV` unLoc tycon'
-
-       ; return (FamEqn { feqn_ext    = noAnn
-                        , feqn_tycon  = tycon'
-                          -- Note [Wildcards in family instances]
-                        , feqn_bndrs  = rn_outer_bndrs'
-                        , feqn_pats   = pats'
-                        , feqn_fixity = fixity
-                        , feqn_rhs    = payload' },
-                 all_fvs) } }
-  where
-    -- The parent class, if we are dealing with an associated type family
-    -- instance.
-    mb_cls = case atfi of
-      NonAssocTyFamEqn _   -> Nothing
-      AssocTyFamDeflt cls  -> Just cls
-      AssocTyFamInst cls _ -> Just cls
-
-    -- The type variables from the instance head, if we are dealing with an
-    -- associated type family instance.
-    inst_head_tvs = case atfi of
-      NonAssocTyFamEqn _             -> []
-      AssocTyFamDeflt _              -> []
-      AssocTyFamInst _ inst_head_tvs -> inst_head_tvs
-
-    pat_kity_vars = extractHsTyArgRdrKiTyVars pats
-             -- It is crucial that extractHsTyArgRdrKiTyVars return
-             -- duplicate occurrences, since they're needed to help
-             -- determine unused binders on the LHS.
-
-    -- The SrcSpan of the LHS of the instance. For example, lhs_loc would be
-    -- the highlighted part in the example below:
-    --
-    --   type instance F a b c = Either a b
-    --                   ^^^^^
-    lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLocA extra_kvars of
-      []         -> panic "rnFamEqn.lhs_loc"
-      [loc]      -> loc
-      (loc:locs) -> loc `combineSrcSpans` last locs
-
-    badAssocRhs :: [Name] -> RnM ()
-    badAssocRhs ns
-      = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-           (hang (text "The RHS of an associated type declaration mentions"
-                      <+> text "out-of-scope variable" <> plural ns
-                      <+> pprWithCommas (quotes . ppr) ns)
-                   2 (text "All such variables must be bound on the LHS"))
-
-rnTyFamInstDecl :: AssocTyFamInfo
-                -> TyFamInstDecl GhcPs
-                -> RnM (TyFamInstDecl GhcRn, FreeVars)
-rnTyFamInstDecl atfi (TyFamInstDecl { tfid_xtn = x, tfid_eqn = eqn })
-  = do { (eqn', fvs) <- rnTyFamInstEqn atfi eqn
-       ; return (TyFamInstDecl { tfid_xtn = x, tfid_eqn = eqn' }, fvs) }
-
--- | Tracks whether we are renaming:
---
--- 1. A type family equation that is not associated
---    with a parent type class ('NonAssocTyFamEqn'). Examples:
---
---    @
---    type family F a
---    type instance F Int = Bool  -- NonAssocTyFamEqn NotClosed
---
---    type family G a where
---       G Int = Bool             -- NonAssocTyFamEqn Closed
---    @
---
--- 2. An associated type family default declaration ('AssocTyFamDeflt').
---    Example:
---
---    @
---    class C a where
---      type A a
---      type instance A a = a -> a  -- AssocTyFamDeflt C
---    @
---
--- 3. An associated type family instance declaration ('AssocTyFamInst').
---    Example:
---
---    @
---    instance C a => C [a] where
---      type A [a] = Bool  -- AssocTyFamInst C [a]
---    @
-data AssocTyFamInfo
-  = NonAssocTyFamEqn
-      ClosedTyFamInfo -- Is this a closed type family?
-  | AssocTyFamDeflt
-      Name            -- Name of the parent class
-  | AssocTyFamInst
-      Name            -- Name of the parent class
-      [Name]          -- Names of the tyvars of the parent instance decl
-
--- | Tracks whether we are renaming an equation in a closed type family
--- equation ('ClosedTyFam') or not ('NotClosedTyFam').
-data ClosedTyFamInfo
-  = NotClosedTyFam
-  | ClosedTyFam
-
-rnTyFamInstEqn :: AssocTyFamInfo
-               -> TyFamInstEqn GhcPs
-               -> RnM (TyFamInstEqn GhcRn, FreeVars)
-rnTyFamInstEqn atfi eqn@(FamEqn { feqn_tycon = tycon, feqn_rhs = rhs })
-  = rnFamEqn (TySynCtx tycon) atfi extra_kvs eqn rnTySyn
-  where
-    extra_kvs = extractHsTyRdrTyVarsKindVars rhs
-
-rnTyFamDefltDecl :: Name
-                 -> TyFamDefltDecl GhcPs
-                 -> RnM (TyFamDefltDecl GhcRn, FreeVars)
-rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls)
-
-rnDataFamInstDecl :: AssocTyFamInfo
-                  -> DataFamInstDecl GhcPs
-                  -> RnM (DataFamInstDecl GhcRn, FreeVars)
-rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn =
-                    eqn@(FamEqn { feqn_tycon = tycon
-                                , feqn_rhs   = rhs })})
-  = do { let extra_kvs = extractDataDefnKindVars rhs
-       ; (eqn', fvs) <-
-           rnFamEqn (TyDataCtx tycon) atfi extra_kvs eqn rnDataDefn
-       ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
-
--- Renaming of the associated types in instances.
-
--- Rename associated type family decl in class
-rnATDecls :: Name      -- Class
-          -> [LFamilyDecl GhcPs]
-          -> RnM ([LFamilyDecl GhcRn], FreeVars)
-rnATDecls cls at_decls
-  = rnList (rnFamDecl (Just cls)) at_decls
-
-rnATInstDecls :: (AssocTyFamInfo ->           -- The function that renames
-                  decl GhcPs ->               -- an instance. rnTyFamInstDecl
-                  RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl
-              -> Name      -- Class
-              -> [Name]
-              -> [LocatedA (decl GhcPs)]
-              -> RnM ([LocatedA (decl GhcRn)], FreeVars)
--- Used for data and type family defaults in a class decl
--- and the family instance declarations in an instance
---
--- NB: We allow duplicate associated-type decls;
---     See Note [Associated type instances] in GHC.Tc.TyCl.Instance
-rnATInstDecls rnFun cls tv_ns at_insts
-  = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts
-    -- See Note [Renaming associated types]
-
-{- Note [Wildcards in family instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Wild cards can be used in type/data family instance declarations to indicate
-that the name of a type variable doesn't matter. Each wild card will be
-replaced with a new unique type variable. For instance:
-
-    type family F a b :: *
-    type instance F Int _ = Int
-
-is the same as
-
-    type family F a b :: *
-    type instance F Int b = Int
-
-This is implemented as follows: Unnamed wildcards remain unchanged after
-the renamer, and then given fresh meta-variables during typechecking, and
-it is handled pretty much the same way as the ones in partial type signatures.
-We however don't want to emit hole constraints on wildcards in family
-instances, so we turn on PartialTypeSignatures and turn off warning flag to
-let typechecker know this.
-See related Note [Wildcards in visible kind application] in GHC.Tc.Gen.HsType
-
-Note [Unused type variables in family instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When the flag -fwarn-unused-type-patterns is on, the compiler reports
-warnings about unused type variables in type-family instances. A
-tpye variable is considered used (i.e. cannot be turned into a wildcard)
-when
-
- * it occurs on the RHS of the family instance
-   e.g.   type instance F a b = a    -- a is used on the RHS
-
- * it occurs multiple times in the patterns on the LHS
-   e.g.   type instance F a a = Int  -- a appears more than once on LHS
-
- * it is one of the instance-decl variables, for associated types
-   e.g.   instance C (a,b) where
-            type T (a,b) = a
-   Here the type pattern in the type instance must be the same as that
-   for the class instance, so
-            type T (a,_) = a
-   would be rejected.  So we should not complain about an unused variable b
-
-As usual, the warnings are not reported for type variables with names
-beginning with an underscore.
-
-Extra-constraints wild cards are not supported in type/data family
-instance declarations.
-
-Relevant tickets: #3699, #10586, #10982 and #11451.
-
-Note [Renaming associated types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When renaming a type/data family instance, be it top-level or associated with
-a class, we must check that all of the type variables mentioned on the RHS are
-properly scoped. Specifically, the rule is this:
-
-  Every variable mentioned on the RHS of a type instance declaration
-  (whether associated or not) must be either
-  * Mentioned on the LHS, or
-  * Mentioned in an outermost kind signature on the RHS
-    (see Note [Implicit quantification in type synonyms])
-
-Here is a simple example of something we should reject:
-
-  class C a b where
-    type F a x
-  instance C Int Bool where
-    type F Int x = z
-
-Here, `z` is mentioned on the RHS of the associated instance without being
-mentioned on the LHS, nor is `z` mentioned in an outermost kind signature. The
-renamer will reject `z` as being out of scope without much fuss.
-
-Things get slightly trickier when the instance header itself binds type
-variables. Consider this example (adapted from #5515):
-
-   instance C (p,q) z where
-      type F (p,q) x = (x, z)
-
-According to the rule above, this instance is improperly scoped. However, due
-to the way GHC's renamer works, `z` is /technically/ in scope, as GHC will
-always bring type variables from an instance header into scope over the
-associated type family instances. As a result, the renamer won't simply reject
-the `z` as being out of scope (like it would for the `type F Int x = z`
-example) unless further action is taken. It is important to reject this sort of
-thing in the renamer, because if it is allowed to make it through to the
-typechecker, unexpected shenanigans can occur (see #18021 for examples).
-
-To prevent these sorts of shenanigans, we reject programs like the one above
-with an extra validity check in rnFamEqn. For each type variable bound in the
-parent instance head, we check if it is mentioned on the RHS of the associated
-family instance but not bound on the LHS. If any of the instance-head-bound
-variables meet these criteria, we throw an error.
-(See rnFamEqn.improperly_scoped for how this is implemented.)
-
-Some additional wrinkles:
-
-* This Note only applies to *instance* declarations.  In *class* declarations
-  there is no RHS to worry about, and the class variables can all be in scope
-  (#5862):
-
-    class Category (x :: k -> k -> *) where
-      type Ob x :: k -> Constraint
-      id :: Ob x a => x a a
-      (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
-
-  Here 'k' is in scope in the kind signature, just like 'x'.
-
-* Although type family equations can bind type variables with explicit foralls,
-  it need not be the case that all variables that appear on the RHS must be
-  bound by a forall. For instance, the following is acceptable:
-
-    class C4 a where
-      type T4 a b
-    instance C4 (Maybe a) where
-      type forall b. T4 (Maybe a) b = Either a b
-
-  Even though `a` is not bound by the forall, this is still accepted because `a`
-  was previously bound by the `instance C4 (Maybe a)` part. (see #16116).
-
-* In addition to the validity check in rnFamEqn.improperly_scoped, there is an
-  additional check in GHC.Tc.Validity.checkFamPatBinders that checks each family
-  instance equation for type variables used on the RHS but not bound on the
-  LHS. This is not made redundant by rmFamEqn.improperly_scoped, as there are
-  programs that each check will reject that the other check will not catch:
-
-  - checkValidFamPats is used on all forms of family instances, whereas
-    rmFamEqn.improperly_scoped only checks associated family instances. Since
-    checkFamPatBinders occurs after typechecking, it can catch programs that
-    introduce dodgy scoping by way of type synonyms (see #7536), which is
-    impractical to accomplish in the renamer.
-  - rnFamEqn.improperly_scoped catches some programs that, if allowed to escape
-    the renamer, would accidentally be accepted by the typechecker. Here is one
-    such program (#18021):
-
-      class C5 a where
-        data family D a
-
-      instance forall a. C5 Int where
-        data instance D Int = MkD a
-
-    If this is not rejected in the renamer, the typechecker would treat this
-    program as though the `a` were existentially quantified, like so:
-
-      data instance D Int = forall a. MkD a
-
-    This is likely not what the user intended!
-
-    Here is another such program (#9574):
-
-      class Funct f where
-        type Codomain f
-      instance Funct ('KProxy :: KProxy o) where
-        type Codomain 'KProxy = NatTr (Proxy :: o -> Type)
-
-    Where:
-
-      data Proxy (a :: k) = Proxy
-      data KProxy (t :: Type) = KProxy
-      data NatTr (c :: o -> Type)
-
-    Note that the `o` in the `Codomain 'KProxy` instance should be considered
-    improperly scoped. It does not meet the criteria for being explicitly
-    quantified, as it is not mentioned by name on the LHS, nor does it meet the
-    criteria for being implicitly quantified, as it is used in a RHS kind
-    signature that is not outermost (see Note [Implicit quantification in type
-    synonyms]). However, `o` /is/ bound by the instance header, so if this
-    program is not rejected by the renamer, the typechecker would treat it as
-    though you had written this:
-
-      instance Funct ('KProxy :: KProxy o) where
-        type Codomain ('KProxy @o) = NatTr (Proxy :: o -> Type)
-
-    Although this is a valid program, it's probably a stretch too far to turn
-    `type Codomain 'KProxy = ...` into `type Codomain ('KProxy @o) = ...` here.
-    If the user really wants the latter, it is simple enough to communicate
-    their intent by mentioning `o` on the LHS by name.
-
-Note [Type family equations and occurrences]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In most data/type family equations, the type family name used in the equation
-is treated as an occurrence. For example:
-
-  module A where
-    type family F a
-
-  module B () where
-    import B (F)
-    type instance F Int = Bool
-
-We do not want to warn about `F` being unused in the module `B`, as the
-instance constitutes a use site for `F`. The exception to this rule is closed
-type families, whose equations constitute a definition, not occurrences. For
-example:
-
-  module C () where
-    type family CF a where
-      CF Char = Float
-
-Here, we /do/ want to warn that `CF` is unused in the module `C`, as it is
-defined but not used (#18470).
-
-GHC accomplishes this in rnFamEqn when determining the set of free
-variables to return at the end. If renaming a data family or open type family
-equation, we add the name of the type family constructor to the set of returned
-free variables to ensure that the name is marked as an occurrence. If renaming
-a closed type family equation, we avoid adding the type family constructor name
-to the free variables. This is quite simple, but it is not a perfect solution.
-Consider this example:
-
-  module X () where
-    type family F a where
-      F Int = Bool
-      F Double = F Int
-
-At present, GHC will treat any use of a type family constructor on the RHS of a
-type family equation as an occurrence. Since `F` is used on the RHS of the
-second equation of `F`, it is treated as an occurrence, causing `F` not to be
-warned about. This is not ideal, since `F` isn't exported—it really /should/
-cause a warning to be emitted. There is some discussion in #10089/#12920 about
-how this limitation might be overcome, but until then, we stick to the
-simplistic solution above, as it fixes the egregious bug in #18470.
--}
-
-
-{-
-*********************************************************
-*                                                      *
-\subsection{Stand-alone deriving declarations}
-*                                                      *
-*********************************************************
--}
-
-rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
-rnSrcDerivDecl (DerivDecl _ ty mds overlap)
-  = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
-       ; unless standalone_deriv_ok (addErr standaloneDerivErr)
-       ; checkInferredVars ctxt inf_err nowc_ty
-       ; (mds', ty', fvs) <- rnLDerivStrategy ctxt mds $ rnHsSigWcType ctxt ty
-         -- Check if there are any nested `forall`s or contexts, which are
-         -- illegal in the type of an instance declaration (see
-         -- Note [No nested foralls or contexts in instance types] in
-         -- GHC.Hs.Type).
-       ; addNoNestedForallsContextsErr ctxt
-           (text "Standalone-derived instance head")
-           (getLHsInstDeclHead $ dropWildCards ty')
-       ; warnNoDerivStrat mds' loc
-       ; return (DerivDecl noAnn ty' mds' overlap, fvs) }
-  where
-    ctxt    = DerivDeclCtx
-    inf_err = Just (text "Inferred type variables are not allowed")
-    loc = getLocA nowc_ty
-    nowc_ty = dropWildCards ty
-
-standaloneDerivErr :: TcRnMessage
-standaloneDerivErr
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (text "Illegal standalone deriving declaration")
-       2 (text "Use StandaloneDeriving to enable this extension")
-
-{-
-*********************************************************
-*                                                      *
-\subsection{Rules}
-*                                                      *
-*********************************************************
--}
-
-rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
-rnHsRuleDecls (HsRules { rds_ext = (_, src)
-                       , rds_rules = rules })
-  = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
-       ; return (HsRules { rds_ext = src
-                         , rds_rules = rn_rules }, fvs) }
-
-rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
-rnHsRuleDecl (HsRule { rd_ext  = (_, st)
-                     , rd_name = rule_name
-                     , rd_act  = act
-                     , rd_tyvs = tyvs
-                     , rd_tmvs = tmvs
-                     , rd_lhs  = lhs
-                     , rd_rhs  = rhs })
-  = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs
-       ; mapM_ warnForallIdentifier rdr_names_w_loc
-       ; checkDupRdrNamesN rdr_names_w_loc
-       ; checkShadowedRdrNames rdr_names_w_loc
-       ; names <- newLocalBndrsRn rdr_names_w_loc
-       ; let doc = RuleCtx (unLoc rule_name)
-       ; bindRuleTyVars doc tyvs $ \ tyvs' ->
-         bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->
-    do { (lhs', fv_lhs') <- rnLExpr lhs
-       ; (rhs', fv_rhs') <- rnLExpr rhs
-       ; checkValidRule (unLoc rule_name) names lhs' fv_lhs'
-       ; return (HsRule { rd_ext  = (HsRuleRn fv_lhs' fv_rhs', st)
-                        , rd_name = rule_name
-                        , rd_act  = act
-                        , rd_tyvs = tyvs'
-                        , rd_tmvs = tmvs'
-                        , rd_lhs  = lhs'
-                        , rd_rhs  = rhs' }, fv_lhs' `plusFV` fv_rhs') } }
-  where
-    get_var :: RuleBndr GhcPs -> LocatedN RdrName
-    get_var (RuleBndrSig _ v _) = v
-    get_var (RuleBndr _ v)      = v
-
-bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs
-               -> [LRuleBndr GhcPs] -> [Name]
-               -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
-               -> RnM (a, FreeVars)
-bindRuleTmVars doc tyvs vars names thing_inside
-  = go vars names $ \ vars' ->
-    bindLocalNamesFV names (thing_inside vars')
-  where
-    go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside
-      = go vars ns $ \ vars' ->
-        thing_inside (L l (RuleBndr noAnn (L loc n)) : vars')
-
-    go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars)
-       (n : ns) thing_inside
-      = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' ->
-        go vars ns $ \ vars' ->
-        thing_inside (L l (RuleBndrSig noAnn (L loc n) bsig') : vars')
-
-    go [] [] thing_inside = thing_inside []
-    go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
-
-    bind_free_tvs = case tyvs of Nothing -> AlwaysBind
-                                 Just _  -> NeverBind
-
-bindRuleTyVars :: HsDocContext -> Maybe [LHsTyVarBndr () GhcPs]
-               -> (Maybe [LHsTyVarBndr () GhcRn]  -> RnM (b, FreeVars))
-               -> RnM (b, FreeVars)
-bindRuleTyVars doc (Just bndrs) thing_inside
-  = bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs (thing_inside . Just)
-bindRuleTyVars _ _ thing_inside = thing_inside Nothing
-
-{-
-Note [Rule LHS validity checking]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Check the shape of a rewrite rule LHS.  Currently we only allow
-LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
-@forall@'d variables.
-
-We used restrict the form of the 'ei' to prevent you writing rules
-with LHSs with a complicated desugaring (and hence unlikely to match);
-(e.g. a case expression is not allowed: too elaborate.)
-
-But there are legitimate non-trivial args ei, like sections and
-lambdas.  So it seems simpler not to check at all, and that is why
-check_e is commented out.
--}
-
-checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()
-checkValidRule rule_name ids lhs' fv_lhs'
-  = do  {       -- Check for the form of the LHS
-          case (validRuleLhs ids lhs') of
-                Nothing  -> return ()
-                Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
-
-                -- Check that LHS vars are all bound
-        ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
-        ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
-
-validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
--- Nothing => OK
--- Just e  => Not ok, and e is the offending sub-expression
-validRuleLhs foralls lhs
-  = checkl lhs
-  where
-    checkl = check . unLoc
-
-    check (OpApp _ e1 op e2)              = checkl op `mplus` checkl_e e1
-                                                      `mplus` checkl_e e2
-    check (HsApp _ e1 e2)                 = checkl e1 `mplus` checkl_e e2
-    check (HsAppType _ e _ _)             = checkl e
-    check (HsVar _ lv)
-      | (unLoc lv) `notElem` foralls      = Nothing
-    check other                           = Just other  -- Failure
-
-        -- Check an argument
-    checkl_e _ = Nothing
-    -- Was (check_e e); see Note [Rule LHS validity checking]
-
-{-      Commented out; see Note [Rule LHS validity checking] above
-    check_e (HsVar v)     = Nothing
-    check_e (HsPar e)     = checkl_e e
-    check_e (HsLit e)     = Nothing
-    check_e (HsOverLit e) = Nothing
-
-    check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
-    check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2
-    check_e (NegApp e _)         = checkl_e e
-    check_e (ExplicitList _ es)  = checkl_es es
-    check_e other                = Just other   -- Fails
-
-    checkl_es es = foldr (mplus . checkl_e) Nothing es
--}
-
-badRuleVar :: FastString -> Name -> TcRnMessage
-badRuleVar name var
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,
-         text "Forall'd variable" <+> quotes (ppr var) <+>
-                text "does not appear on left hand side"]
-
-badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> TcRnMessage
-badRuleLhsErr name lhs bad_e
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    sep [text "Rule" <+> pprRuleName name <> colon,
-         nest 2 (vcat [err,
-                       text "in left-hand side:" <+> ppr lhs])]
-    $$
-    text "LHS must be of form (f e1 .. en) where f is not forall'd"
-  where
-    err =
-      case bad_e of
-        HsUnboundVar _ uv ->
-          let rdr = mkRdrUnqual uv
-          in  pprScopeError rdr $ notInScopeErr WL_Global (mkRdrUnqual uv)
-        _ -> text "Illegal expression:" <+> ppr bad_e
-
-{- **************************************************************
-         *                                                      *
-      Renaming type, class, instance and role declarations
-*                                                               *
-*****************************************************************
-
-@rnTyDecl@ uses the `global name function' to create a new type
-declaration in which local names have been replaced by their original
-names, reporting any unknown names.
-
-Renaming type variables is a pain. Because they now contain uniques,
-it is necessary to pass in an association list which maps a parsed
-tyvar to its @Name@ representation.
-In some cases (type signatures of values),
-it is even necessary to go over the type first
-in order to get the set of tyvars used by it, make an assoc list,
-and then go over it again to rename the tyvars!
-However, we can also do some scoping checks at the same time.
-
-Note [Dependency analysis of type, class, and instance decls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A TyClGroup represents a strongly connected components of
-type/class/instance decls, together with the role annotations for the
-type/class declarations.  The renamer uses strongly connected
-component analysis to build these groups.  We do this for a number of
-reasons:
-
-* Improve kind error messages. Consider
-
-     data T f a = MkT f a
-     data S f a = MkS f (T f a)
-
-  This has a kind error, but the error message is better if you
-  check T first, (fixing its kind) and *then* S.  If you do kind
-  inference together, you might get an error reported in S, which
-  is jolly confusing.  See #4875
-
-
-* Increase kind polymorphism.  See GHC.Tc.TyCl
-  Note [Grouping of type and class declarations]
-
-Why do the instance declarations participate?  At least two reasons
-
-* Consider (#11348)
-
-     type family F a
-     type instance F Int = Bool
-
-     data R = MkR (F Int)
-
-     type Foo = 'MkR 'True
-
-  For Foo to kind-check we need to know that (F Int) ~ Bool.  But we won't
-  know that unless we've looked at the type instance declaration for F
-  before kind-checking Foo.
-
-* Another example is this (#3990).
-
-     data family Complex a
-     data instance Complex Double = CD {-# UNPACK #-} !Double
-                                       {-# UNPACK #-} !Double
-
-     data T = T {-# UNPACK #-} !(Complex Double)
-
-  Here, to generate the right kind of unpacked implementation for T,
-  we must have access to the 'data instance' declaration.
-
-* Things become more complicated when we introduce transitive
-  dependencies through imported definitions, like in this scenario:
-
-      A.hs
-        type family Closed (t :: Type) :: Type where
-          Closed t = Open t
-
-        type family Open (t :: Type) :: Type
-
-      B.hs
-        data Q where
-          Q :: Closed Bool -> Q
-
-        type instance Open Int = Bool
-
-        type S = 'Q 'True
-
-  Somehow, we must ensure that the instance Open Int = Bool is checked before
-  the type synonym S. While we know that S depends upon 'Q depends upon Closed,
-  we have no idea that Closed depends upon Open!
-
-  To accommodate for these situations, we ensure that an instance is checked
-  before every @TyClDecl@ on which it does not depend. That's to say, instances
-  are checked as early as possible in @tcTyAndClassDecls@.
-
-------------------------------------
-So much for WHY.  What about HOW?  It's pretty easy:
-
-(1) Rename the type/class, instance, and role declarations
-    individually
-
-(2) Do strongly-connected component analysis of the type/class decls,
-    We'll make a TyClGroup for each SCC
-
-    In this step we treat a reference to a (promoted) data constructor
-    K as a dependency on its parent type.  Thus
-        data T = K1 | K2
-        data S = MkS (Proxy 'K1)
-    Here S depends on 'K1 and hence on its parent T.
-
-    In this step we ignore instances; see
-    Note [No dependencies on data instances]
-
-(3) Attach roles to the appropriate SCC
-
-(4) Attach instances to the appropriate SCC.
-    We add an instance decl to SCC when:
-      all its free types/classes are bound in this SCC or earlier ones
-
-(5) We make an initial TyClGroup, with empty group_tyclds, for any
-    (orphan) instances that affect only imported types/classes
-
-Steps (3) and (4) are done by the (mapAccumL mk_group) call.
-
-Note [No dependencies on data instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this
-   data family D a
-   data instance D Int = D1
-   data S = MkS (Proxy 'D1)
-
-Here the declaration of S depends on the /data instance/ declaration
-for 'D Int'.  That makes things a lot more complicated, especially
-if the data instance is an associated type of an enclosing class instance.
-(And the class instance might have several associated type instances
-with different dependency structure!)
-
-Ugh.  For now we simply don't allow promotion of data constructors for
-data instances.  See Note [AFamDataCon: not promoting data family
-constructors] in GHC.Tc.Utils.Env
--}
-
-
-rnTyClDecls :: [TyClGroup GhcPs]
-            -> RnM ([TyClGroup GhcRn], FreeVars)
--- Rename the declarations and do dependency analysis on them
-rnTyClDecls tycl_ds
-  = do { -- Rename the type/class, instance, and role declarations
-       ; tycls_w_fvs <- mapM (wrapLocFstMA rnTyClDecl) (tyClGroupTyClDecls tycl_ds)
-       ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)
-       ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds)
-       ; instds_w_fvs <- mapM (wrapLocFstMA rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
-       ; role_annots  <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
-
-       -- Do SCC analysis on the type/class decls
-       ; rdr_env <- getGlobalRdrEnv
-       ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs
-             role_annot_env = mkRoleAnnotEnv role_annots
-             (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs
-
-             inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs
-             (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map
-
-             first_group
-               | null init_inst_ds = []
-               | otherwise = [TyClGroup { group_ext    = noExtField
-                                        , group_tyclds = []
-                                        , group_kisigs = []
-                                        , group_roles  = []
-                                        , group_instds = init_inst_ds }]
-
-             (final_inst_ds, groups)
-                = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs
-
-             all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs  `plusFV`
-                       foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV`
-                       foldr (plusFV . snd) emptyFVs kisigs_w_fvs
-
-             all_groups = first_group ++ groups
-
-       ; massertPpr (null final_inst_ds)
-                    (ppr instds_w_fvs
-                     $$ ppr inst_ds_map
-                     $$ ppr (flattenSCCs tycl_sccs)
-                     $$ ppr final_inst_ds)
-
-       ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)
-       ; return (all_groups, all_fvs) }
-  where
-    mk_group :: RoleAnnotEnv
-             -> KindSigEnv
-             -> InstDeclFreeVarsMap
-             -> SCC (LTyClDecl GhcRn)
-             -> (InstDeclFreeVarsMap, TyClGroup GhcRn)
-    mk_group role_env kisig_env inst_map scc
-      = (inst_map', group)
-      where
-        tycl_ds              = flattenSCC scc
-        bndrs                = map (tcdName . unLoc) tycl_ds
-        roles                = getRoleAnnots bndrs role_env
-        kisigs               = getKindSigs   bndrs kisig_env
-        (inst_ds, inst_map') = getInsts      bndrs inst_map
-        group = TyClGroup { group_ext    = noExtField
-                          , group_tyclds = tycl_ds
-                          , group_kisigs = kisigs
-                          , group_roles  = roles
-                          , group_instds = inst_ds }
-
--- | Free variables of standalone kind signatures.
-newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars)
-
-lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars
-lookupKindSig_FV_Env (KindSig_FV_Env e) name
-  = fromMaybe emptyFVs (lookupNameEnv e name)
-
--- | Standalone kind signatures.
-type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn)
-
-mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env)
-mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env)
-  where
-    kisig_env = mapNameEnv fst compound_env
-    kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env)
-    compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars)
-      = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs
-
-getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
-getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs
-
-rnStandaloneKindSignatures
-  :: NameSet  -- names of types and classes in the current TyClGroup
-  -> [LStandaloneKindSig GhcPs]
-  -> RnM [(LStandaloneKindSig GhcRn, FreeVars)]
-rnStandaloneKindSignatures tc_names kisigs
-  = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs
-             get_name = standaloneKindSigName . unLoc
-       ; mapM_ dupKindSig_Err dup_kisigs
-       ; mapM (wrapLocFstMA (rnStandaloneKindSignature tc_names)) no_dups
-       }
-
-rnStandaloneKindSignature
-  :: NameSet  -- names of types and classes in the current TyClGroup
-  -> StandaloneKindSig GhcPs
-  -> RnM (StandaloneKindSig GhcRn, FreeVars)
-rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki)
-  = do  { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures
-        ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr
-        ; new_v <- lookupSigCtxtOccRnN (TopSigCtxt tc_names) (text "standalone kind signature") v
-        ; let doc = StandaloneKindSigCtx (ppr v)
-        ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki
-        ; return (StandaloneKindSig noExtField new_v new_ki, fvs)
-        }
-  where
-    standaloneKiSigErr :: TcRnMessage
-    standaloneKiSigErr = mkTcRnUnknownMessage $ mkPlainError noHints $
-      hang (text "Illegal standalone kind signature")
-         2 (text "Did you mean to enable StandaloneKindSignatures?")
-
-depAnalTyClDecls :: GlobalRdrEnv
-                 -> KindSig_FV_Env
-                 -> [(LTyClDecl GhcRn, FreeVars)]
-                 -> [SCC (LTyClDecl GhcRn)]
--- See Note [Dependency analysis of type, class, and instance decls]
-depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs
-  = stronglyConnCompFromEdgedVerticesUniq edges
-  where
-    edges :: [ Node Name (LTyClDecl GhcRn) ]
-    edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps))
-            | (d, fvs) <- ds_w_fvs,
-              let { name = tcdName (unLoc d)
-                  ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name
-                  ; deps = fvs `plusFV` kisig_fvs
-                  }
-            ]
-            -- It's OK to use nonDetEltsUFM here as
-            -- stronglyConnCompFromEdgedVertices is still deterministic
-            -- even if the edges are in nondeterministic order as explained
-            -- in Note [Deterministic SCC] in GHC.Data.Graph.Directed.
-
-toParents :: GlobalRdrEnv -> NameSet -> NameSet
-toParents rdr_env ns
-  = nonDetStrictFoldUniqSet add emptyNameSet ns
-  -- It's OK to use a non-deterministic fold because we immediately forget the
-  -- ordering by creating a set
-  where
-    add n s = extendNameSet s (getParent rdr_env n)
-
-getParent :: GlobalRdrEnv -> Name -> Name
-getParent rdr_env n
-  = case lookupGRE_Name rdr_env n of
-      Just gre -> case gre_par gre of
-                    ParentIs  { par_is = p } -> p
-                    _                        -> n
-      Nothing -> n
-
-
-{- ******************************************************
-*                                                       *
-       Role annotations
-*                                                       *
-****************************************************** -}
-
--- | Renames role annotations, returning them as the values in a NameEnv
--- and checks for duplicate role annotations.
--- It is quite convenient to do both of these in the same place.
--- See also Note [Role annotations in the renamer]
-rnRoleAnnots :: NameSet
-             -> [LRoleAnnotDecl GhcPs]
-             -> RnM [LRoleAnnotDecl GhcRn]
-rnRoleAnnots tc_names role_annots
-  = do {  -- Check for duplicates *before* renaming, to avoid
-          -- lumping together all the unboundNames
-         let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots
-             get_name = roleAnnotDeclName . unLoc
-       ; mapM_ dupRoleAnnotErr dup_annots
-       ; mapM (wrapLocMA rn_role_annot1) no_dups }
-  where
-    rn_role_annot1 (RoleAnnotDecl _ tycon roles)
-      = do {  -- the name is an *occurrence*, but look it up only in the
-              -- decls defined in this group (see #10263)
-             tycon' <- lookupSigCtxtOccRnN (RoleAnnotCtxt tc_names)
-                                           (text "role annotation")
-                                           tycon
-           ; return $ RoleAnnotDecl noExtField tycon' roles }
-
-dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
-dupRoleAnnotErr list
-  = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (text "Duplicate role annotations for" <+>
-          quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
-       2 (vcat $ map pp_role_annot $ NE.toList sorted_list)
-    where
-      sorted_list = NE.sortBy cmp_loc list
-      ((L loc first_decl) :| _) = sorted_list
-
-      pp_role_annot (L loc decl) = hang (ppr decl)
-                                      4 (text "-- written at" <+> ppr (locA loc))
-
-      cmp_loc = SrcLoc.leftmost_smallest `on` getLocA
-
-dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM ()
-dupKindSig_Err list
-  = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (text "Duplicate standalone kind signatures for" <+>
-          quotes (ppr $ standaloneKindSigName first_decl) <> colon)
-       2 (vcat $ map pp_kisig $ NE.toList sorted_list)
-    where
-      sorted_list = NE.sortBy cmp_loc list
-      ((L loc first_decl) :| _) = sorted_list
-
-      pp_kisig (L loc decl) =
-        hang (ppr decl) 4 (text "-- written at" <+> ppr (locA loc))
-
-      cmp_loc = SrcLoc.leftmost_smallest `on` getLocA
-
-{- Note [Role annotations in the renamer]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must ensure that a type's role annotation is put in the same group as the
-proper type declaration. This is because role annotations are needed during
-type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
-NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
-type, if any. Then, this map can be used to add the role annotations to the
-groups after dependency analysis.
-
-This process checks for duplicate role annotations, where we must be careful
-to do the check *before* renaming to avoid calling all unbound names duplicates
-of one another.
-
-The renaming process, as usual, might identify and report errors for unbound
-names. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using
-lookupGlobalOccRn led to #8485).
--}
-
-
-{- ******************************************************
-*                                                       *
-       Dependency info for instances
-*                                                       *
-****************************************************** -}
-
-----------------------------------------------------------
--- | 'InstDeclFreeVarsMap is an association of an
---   @InstDecl@ with @FreeVars@. The @FreeVars@ are
---   the tycon names that are both
---     a) free in the instance declaration
---     b) bound by this group of type/class/instance decls
-type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)]
-
--- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the
---   @FreeVars@ which are *not* the binders of a @TyClDecl@.
-mkInstDeclFreeVarsMap :: GlobalRdrEnv
-                      -> NameSet
-                      -> [(LInstDecl GhcRn, FreeVars)]
-                      -> InstDeclFreeVarsMap
-mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs
-  = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs)
-    | (inst_decl, fvs) <- inst_ds_fvs ]
-
--- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the
---   @InstDeclFreeVarsMap@ with these entries removed.
--- We call (getInsts tcs instd_map) when we've completed the declarations
--- for 'tcs'.  The call returns (inst_decls, instd_map'), where
---   inst_decls are the instance declarations all of
---              whose free vars are now defined
---   instd_map' is the inst-decl map with 'tcs' removed from
---               the free-var set
-getInsts :: [Name] -> InstDeclFreeVarsMap
-         -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
-getInsts bndrs inst_decl_map
-  = partitionWith pick_me inst_decl_map
-  where
-    pick_me :: (LInstDecl GhcRn, FreeVars)
-            -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
-    pick_me (decl, fvs)
-      | isEmptyNameSet depleted_fvs = Left decl
-      | otherwise                   = Right (decl, depleted_fvs)
-      where
-        depleted_fvs = delFVs bndrs fvs
-
-{- ******************************************************
-*                                                       *
-         Renaming a type or class declaration
-*                                                       *
-****************************************************** -}
-
-rnTyClDecl :: TyClDecl GhcPs
-           -> RnM (TyClDecl GhcRn, FreeVars)
-
--- All flavours of top-level type family declarations ("type family", "newtype
--- family", and "data family")
-rnTyClDecl (FamDecl { tcdFam = fam })
-  = do { (fam', fvs) <- rnFamDecl Nothing fam
-       ; return (FamDecl noExtField fam', fvs) }
-
-rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
-                      tcdFixity = fixity, tcdRhs = rhs })
-  = do { tycon' <- lookupLocatedTopConstructorRnN tycon
-       ; let kvs = extractHsTyRdrTyVarsKindVars rhs
-             doc = TySynCtx tycon
-       ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)
-       ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' _ ->
-    do { (rhs', fvs) <- rnTySyn doc rhs
-       ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
-                         , tcdFixity = fixity
-                         , tcdRhs = rhs', tcdSExt = fvs }, fvs) } }
-
--- "data", "newtype" declarations
-rnTyClDecl (DataDecl
-    { tcdLName = tycon, tcdTyVars = tyvars,
-      tcdFixity = fixity,
-      tcdDataDefn = defn@HsDataDefn{ dd_cons = cons, dd_kindSig = kind_sig} })
-  = do { tycon' <- lookupLocatedTopConstructorRnN tycon
-       ; let kvs = extractDataDefnKindVars defn
-             doc = TyDataCtx tycon
-             new_or_data = dataDefnConsNewOrData cons
-       ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
-       ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
-    do { (defn', fvs) <- rnDataDefn doc defn
-       ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig
-       ; let rn_info = DataDeclRn { tcdDataCusk = cusk
-                                  , tcdFVs      = fvs }
-       ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
-       ; return (DataDecl { tcdLName    = tycon'
-                          , tcdTyVars   = tyvars'
-                          , tcdFixity   = fixity
-                          , tcdDataDefn = defn'
-                          , tcdDExt     = rn_info }, fvs) } }
-
-rnTyClDecl (ClassDecl { tcdLayout = layout,
-                        tcdCtxt = context, tcdLName = lcls,
-                        tcdTyVars = tyvars, tcdFixity = fixity,
-                        tcdFDs = fds, tcdSigs = sigs,
-                        tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
-                        tcdDocs = docs})
-  = do  { lcls' <- lookupLocatedTopConstructorRnN lcls
-        ; let cls' = unLoc lcls'
-              kvs = []  -- No scoped kind vars except those in
-                        -- kind signatures on the tyvars
-
-        -- Tyvars scope over superclass context and method signatures
-        ; ((tyvars', context', fds', ats'), stuff_fvs)
-            <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' _ -> do
-                  -- Checks for distinct tyvars
-             { (context', cxt_fvs) <- rnMaybeContext cls_doc context
-             ; fds'  <- rnFds fds
-                         -- The fundeps have no free variables
-             ; (ats', fv_ats) <- rnATDecls cls' ats
-             ; let fvs = cxt_fvs     `plusFV`
-                         fv_ats
-             ; return ((tyvars', context', fds', ats'), fvs) }
-
-        ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs
-
-        -- No need to check for duplicate associated type decls
-        -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn
-
-        -- Check the signatures
-        -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
-        ; let sig_rdr_names_w_locs =
-                [op | L _ (ClassOpSig _ False ops _) <- sigs
-                    , op <- ops]
-        ; checkDupRdrNamesN sig_rdr_names_w_locs
-                -- Typechecker is responsible for checking that we only
-                -- give default-method bindings for things in this class.
-                -- The renamer *could* check this for class decls, but can't
-                -- for instance decls.
-
-        -- The newLocals call is tiresome: given a generic class decl
-        --      class C a where
-        --        op :: a -> a
-        --        op {| x+y |} (Inl a) = ...
-        --        op {| x+y |} (Inr b) = ...
-        --        op {| a*b |} (a*b)   = ...
-        -- we want to name both "x" tyvars with the same unique, so that they are
-        -- easy to group together in the typechecker.
-        ; (mbinds', sigs', meth_fvs)
-            <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs
-                -- No need to check for duplicate method signatures
-                -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn
-                -- and the methods are already in scope
-
-        ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
-        ; docs' <- traverse rnLDocDecl docs
-        ; return (ClassDecl { tcdLayout = rnLayoutInfo layout,
-                              tcdCtxt = context', tcdLName = lcls',
-                              tcdTyVars = tyvars', tcdFixity = fixity,
-                              tcdFDs = fds', tcdSigs = sigs',
-                              tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
-                              tcdDocs = docs', tcdCExt = all_fvs },
-                  all_fvs ) }
-  where
-    cls_doc  = ClassDeclCtx lcls
-
-rnLayoutInfo :: LayoutInfo GhcPs -> LayoutInfo GhcRn
-rnLayoutInfo (ExplicitBraces ob cb) = ExplicitBraces ob cb
-rnLayoutInfo (VirtualBraces n) = VirtualBraces n
-rnLayoutInfo NoLayoutInfo = NoLayoutInfo
-
--- Does the data type declaration include a CUSK?
-data_decl_has_cusk :: LHsQTyVars (GhcPass p) -> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> RnM Bool
-data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do
-  { -- See Note [Unlifted Newtypes and CUSKs], and for a broader
-    -- picture, see Note [Implementation of UnliftedNewtypes].
-  ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes
-  ; let non_cusk_newtype
-          | NewType <- new_or_data =
-              unlifted_newtypes && isNothing kind_sig
-          | otherwise = False
-    -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls
-  ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype
-  }
-
-{- Note [Unlifted Newtypes and CUSKs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When unlifted newtypes are enabled, a newtype must have a kind signature
-in order to be considered have a CUSK. This is because the flow of
-kind inference works differently. Consider:
-
-  newtype Foo = FooC Int
-
-When UnliftedNewtypes is disabled, we decide that Foo has kind
-`TYPE 'LiftedRep` without looking inside the data constructor. So, we
-can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled,
-we fill in the kind of Foo as a metavar that gets solved by unification
-with the kind of the field inside FooC (that is, Int, whose kind is
-`TYPE 'LiftedRep`). But since we have to look inside the data constructors
-to figure out the kind signature of Foo, it does not have a CUSK.
-
-See Note [Implementation of UnliftedNewtypes] for where this fits in to
-the broader picture of UnliftedNewtypes.
--}
-
--- "type" and "type instance" declarations
-rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
-rnTySyn doc rhs = rnLHsType doc rhs
-
-rnDataDefn :: HsDocContext -> HsDataDefn GhcPs
-           -> RnM (HsDataDefn GhcRn, FreeVars)
-rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = condecls
-                           , dd_kindSig = m_sig, dd_derivs = derivs })
-  = do  { -- DatatypeContexts (i.e., stupid contexts) can't be combined with
-          -- GADT syntax. See Note [The stupid context] in GHC.Core.DataCon.
-          checkTc (h98_style || null (fromMaybeContext context))
-                  (badGadtStupidTheta doc)
-
-        -- Check restrictions on "type data" declarations.
-        -- See Note [Type data declarations].
-        ; when (isTypeDataDefnCons condecls) check_type_data
-
-        ; (m_sig', sig_fvs) <- case m_sig of
-             Just sig -> first Just <$> rnLHsKind doc sig
-             Nothing  -> return (Nothing, emptyFVs)
-        ; (context', fvs1) <- rnMaybeContext doc context
-        ; (derivs',  fvs3) <- rn_derivs derivs
-
-        -- For the constructor declarations, drop the LocalRdrEnv
-        -- in the GADT case, where the type variables in the declaration
-        -- do not scope over the constructor signatures
-        -- data T a where { T1 :: forall b. b-> b }
-        ; let { zap_lcl_env | h98_style = \ thing -> thing
-                            | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
-        ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
-           -- No need to check for duplicate constructor decls
-           -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn
-
-        ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
-                        con_fvs `plusFV` sig_fvs
-        ; return ( HsDataDefn { dd_ext = noExtField, dd_cType = cType
-                              , dd_ctxt = context', dd_kindSig = m_sig'
-                              , dd_cons = condecls'
-                              , dd_derivs = derivs' }
-                 , all_fvs )
-        }
-  where
-    h98_style = not $ anyLConIsGadt condecls  -- Note [Stupid theta]
-
-    rn_derivs ds
-      = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies
-           ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)
-               multipleDerivClausesErr
-           ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds
-           ; return (ds', fvs) }
-
-    -- Given a "type data" declaration, check that the TypeData extension
-    -- is enabled and check restrictions (R1), (R2), (R3) and (R5)
-    -- on the declaration.  See Note [Type data declarations].
-    check_type_data
-      = do { unlessXOptM LangExt.TypeData $ failWith TcRnIllegalTypeData
-           ; unless (null (fromMaybeContext context)) $
-               failWith $ TcRnTypeDataForbids TypeDataForbidsDatatypeContexts
-           ; mapM_ (addLocMA check_type_data_condecl) condecls
-           ; unless (null derivs) $
-               failWith $ TcRnTypeDataForbids TypeDataForbidsDerivingClauses
-           }
-
-    -- Check restrictions (R2) and (R3) on a "type data" constructor.
-    -- See Note [Type data declarations].
-    check_type_data_condecl :: ConDecl GhcPs -> RnM ()
-    check_type_data_condecl condecl
-      = do {
-           ; when (has_labelled_fields condecl) $
-               failWith $ TcRnTypeDataForbids TypeDataForbidsLabelledFields
-           ; when (has_strictness_flags condecl) $
-               failWith $ TcRnTypeDataForbids TypeDataForbidsStrictnessAnnotations
-           }
-
-    has_labelled_fields (ConDeclGADT { con_g_args = RecConGADT _ _ }) = True
-    has_labelled_fields (ConDeclH98 { con_args = RecCon rec })
-      = not (null (unLoc rec))
-    has_labelled_fields _ = False
-
-    has_strictness_flags condecl
-      = any (is_strict . getBangStrictness . hsScaledThing) (con_args condecl)
-
-    is_strict (HsSrcBang _ _ s) = isSrcStrict s
-
-    con_args (ConDeclGADT { con_g_args = PrefixConGADT args }) = args
-    con_args (ConDeclH98 { con_args = PrefixCon _ args }) = args
-    con_args (ConDeclH98 { con_args = InfixCon arg1 arg2 }) = [arg1, arg2]
-    con_args _ = []
-
-{-
-Note [Type data declarations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-With the TypeData extension (GHC proposal #106), one can write `type data`
-declarations, like
-
-    type data Nat = Zero | Succ Nat
-
-or equivalently in GADT style:
-
-    type data Nat where
-        Zero :: Nat
-        Succ :: Nat -> Nat
-
-This defines the constructors `Zero` and `Succ` in the TcCls namespace
-(type constructors and classes) instead of the Data namespace (data
-constructors).  This contrasts with the DataKinds extension, which
-allows constructors defined in the Data namespace to be promoted to the
-TcCls namespace at the point of use in a type.
-
-Type data declarations have the syntax of `data` declarations (but not
-`newtype` declarations), either ordinary algebraic data types or GADTs,
-preceded by `type`, with the following restrictions:
-
-(R1) There are no data type contexts (even with the DatatypeContexts
-     extension).
-
-(R2) There are no labelled fields.  Perhaps these could be supported
-     using type families, but they are omitted for now.
-
-(R3) There are no strictness flags, because they don't make sense at
-     the type level.
-
-(R4) The types of the constructors contain no constraints other than
-     equality constraints.  (This is the same restriction imposed
-     on constructors to be promoted with the DataKinds extension in
-     dc_theta_illegal_constraint called from GHC.Tc.Gen.HsType.tcTyVar,
-     but in that case the restriction is imposed if and when a data
-     constructor is used in a type, whereas here it is imposed at
-     the point of definition.  See also Note [Constraints in kinds]
-     in GHC.Core.TyCo.Rep.)
-
-(R5) There are no deriving clauses.
-
-The main parts of the implementation are:
-
-* The parser recognizes `type data` (but not `type newtype`).
-
-* During the initial construction of the AST,
-  GHC.Parser.PostProcess.checkNewOrData sets the `Bool` argument of the
-  `DataTypeCons` inside a `HsDataDefn` to mark a `type data` declaration.
-  It also puts the the constructor names (`Zero` and `Succ` in our
-  example) in the TcCls namespace.
-
-* GHC.Rename.Module.rnDataDefn calls `check_type_data` on these
-  declarations, which checks that the TypeData extension is enabled and
-  checks restrictions (R1), (R2), (R3) and (R5).  They could equally
-  well be checked in the typechecker, but we err on the side of catching
-  imposters early.
-
-* GHC.Tc.TyCl.checkValidDataCon checks restriction (R4) on these declarations.
-
-* When beginning to type check a mutually recursive group of declarations,
-  the `type data` constructors (`Zero` and `Succ` in our example) are
-  added to the type-checker environment as `APromotionErr TyConPE` by
-  GHC.Tc.TyCl.mkPromotionErrorEnv, so they cannot be used within the
-  recursive group.  This mirrors the DataKinds behaviour described
-  at Note [Recursion and promoting data constructors] in GHC.Tc.TyCl.
-  For example, this is rejected:
-
-    type data T f = K (f (K Int)) -- illegal: tycon K is recursively defined
-
-* The `type data` data type, such as `Nat` in our example, is represented
-  by a `TyCon` that is an `AlgTyCon`, but its `AlgTyConRhs` has the
-  `is_type_data` field set.
-
-* The constructors of the data type, `Zero` and `Succ` in our example,
-  are each represented by a `DataCon` as usual.  That `DataCon`'s
-  `dcPromotedField` is a `TyCon` (for `Zero`, say) that you can use
-  in a type.
-
-* After a `type data` declaration has been type-checked, the type-checker
-  environment entry for each constructor (`Zero` and `Succ` in our
-  example) is just the promoted type constructor, not the bundle required
-  for a data constructor.  (GHC.Types.TyThing.implicitTyConThings)
-
-* GHC.Core.TyCon.isDataKindsPromotedDataCon ignores promoted constructors
-  from `type data`, which do not use the distinguishing quote mark added
-  to constructors promoted by DataKinds.
-
-* GHC.Core.TyCon.isDataTyCon ignores types coming from a `type data`
-  declaration (by checking the `is_type_data` field), so that these do
-  not contribute executable code such as constructor wrappers.
-
-* The `is_type_data` field is copied into a Boolean argument
-  of the `IfDataTyCon` constructor of `IfaceConDecls` by
-  GHC.Iface.Make.tyConToIfaceDecl.
-
--}
-
-warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)
-                 -> SrcSpan
-                 -> RnM ()
-warnNoDerivStrat mds loc
-  = do { dyn_flags <- getDynFlags
-       ; case mds of
-           Nothing ->
-             let dia = mkTcRnUnknownMessage $
-                   mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingDerivingStrategies) noHints $
-                     (if xopt LangExt.DerivingStrategies dyn_flags
-                       then no_strat_warning
-                       else no_strat_warning $+$ deriv_strat_nenabled
-                     )
-             in addDiagnosticAt loc dia
-           _ -> pure ()
-       }
-  where
-    no_strat_warning :: SDoc
-    no_strat_warning = text "No deriving strategy specified. Did you want stock"
-                       <> text ", newtype, or anyclass?"
-    deriv_strat_nenabled :: SDoc
-    deriv_strat_nenabled = text "Use DerivingStrategies to specify a strategy."
-
-rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs
-                    -> RnM (LHsDerivingClause GhcRn, FreeVars)
-rnLHsDerivingClause doc
-                (L loc (HsDerivingClause
-                              { deriv_clause_ext = noExtField
-                              , deriv_clause_strategy = dcs
-                              , deriv_clause_tys = dct }))
-  = do { (dcs', dct', fvs)
-           <- rnLDerivStrategy doc dcs $ rn_deriv_clause_tys dct
-       ; warnNoDerivStrat dcs' (locA loc)
-       ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField
-                                        , deriv_clause_strategy = dcs'
-                                        , deriv_clause_tys = dct' })
-              , fvs ) }
-  where
-    rn_deriv_clause_tys :: LDerivClauseTys GhcPs
-                        -> RnM (LDerivClauseTys GhcRn, FreeVars)
-    rn_deriv_clause_tys (L l dct) = case dct of
-      DctSingle x ty -> do
-        (ty', fvs) <- rn_clause_pred ty
-        pure (L l (DctSingle x ty'), fvs)
-      DctMulti x tys -> do
-        (tys', fvs) <- mapFvRn rn_clause_pred tys
-        pure (L l (DctMulti x tys'), fvs)
-
-    rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
-    rn_clause_pred pred_ty = do
-      let inf_err = Just (text "Inferred type variables are not allowed")
-      checkInferredVars doc inf_err pred_ty
-      ret@(pred_ty', _) <- rnHsSigType doc TypeLevel pred_ty
-      -- Check if there are any nested `forall`s, which are illegal in a
-      -- `deriving` clause.
-      -- See Note [No nested foralls or contexts in instance types]
-      -- (Wrinkle: Derived instances) in GHC.Hs.Type.
-      addNoNestedForallsContextsErr doc (text "Derived class type")
-        (getLHsInstDeclHead pred_ty')
-      pure ret
-
-rnLDerivStrategy :: forall a.
-                    HsDocContext
-                 -> Maybe (LDerivStrategy GhcPs)
-                 -> RnM (a, FreeVars)
-                 -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
-rnLDerivStrategy doc mds thing_inside
-  = case mds of
-      Nothing -> boring_case Nothing
-      Just (L loc ds) ->
-        setSrcSpanA loc $ do
-          (ds', thing, fvs) <- rn_deriv_strat ds
-          pure (Just (L loc ds'), thing, fvs)
-  where
-    rn_deriv_strat :: DerivStrategy GhcPs
-                   -> RnM (DerivStrategy GhcRn, a, FreeVars)
-    rn_deriv_strat ds = do
-      let extNeeded :: LangExt.Extension
-          extNeeded
-            | ViaStrategy{} <- ds
-            = LangExt.DerivingVia
-            | otherwise
-            = LangExt.DerivingStrategies
-
-      unlessXOptM extNeeded $
-        failWith $ illegalDerivStrategyErr ds
-
-      case ds of
-        StockStrategy    _ -> boring_case (StockStrategy noExtField)
-        AnyclassStrategy _ -> boring_case (AnyclassStrategy noExtField)
-        NewtypeStrategy  _ -> boring_case (NewtypeStrategy noExtField)
-        ViaStrategy (XViaStrategyPs _ via_ty) ->
-          do checkInferredVars doc inf_err via_ty
-             (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty
-             let HsSig { sig_bndrs = via_outer_bndrs
-                       , sig_body  = via_body } = unLoc via_ty'
-                 via_tvs = hsOuterTyVarNames via_outer_bndrs
-             -- Check if there are any nested `forall`s, which are illegal in a
-             -- `via` type.
-             -- See Note [No nested foralls or contexts in instance types]
-             -- (Wrinkle: Derived instances) in GHC.Hs.Type.
-             addNoNestedForallsContextsErr doc
-               (quotes (text "via") <+> text "type") via_body
-             (thing, fvs2) <- bindLocalNamesFV via_tvs thing_inside
-             pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2)
-
-    inf_err = Just (text "Inferred type variables are not allowed")
-
-    boring_case :: ds -> RnM (ds, a, FreeVars)
-    boring_case ds = do
-      (thing, fvs) <- thing_inside
-      pure (ds, thing, fvs)
-
-badGadtStupidTheta :: HsDocContext -> TcRnMessage
-badGadtStupidTheta _
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [text "No context is allowed on a GADT-style data declaration",
-          text "(You can put a context on each constructor, though.)"]
-
-illegalDerivStrategyErr :: DerivStrategy GhcPs -> TcRnMessage
-illegalDerivStrategyErr ds
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds
-         , text enableStrategy ]
-
-  where
-    enableStrategy :: String
-    enableStrategy
-      | ViaStrategy{} <- ds
-      = "Use DerivingVia to enable this extension"
-      | otherwise
-      = "Use DerivingStrategies to enable this extension"
-
-multipleDerivClausesErr :: TcRnMessage
-multipleDerivClausesErr
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [ text "Illegal use of multiple, consecutive deriving clauses"
-         , text "Use DerivingStrategies to allow this" ]
-
-rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
-                        --             inside an *class decl* for cls
-                        --             used for associated types
-          -> FamilyDecl GhcPs
-          -> RnM (FamilyDecl GhcRn, FreeVars)
-rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
-                             , fdTopLevel = toplevel
-                             , fdFixity = fixity
-                             , fdInfo = info, fdResultSig = res_sig
-                             , fdInjectivityAnn = injectivity })
-  = do { tycon' <- lookupLocatedTopConstructorRnN tycon
-       ; ((tyvars', res_sig', injectivity'), fv1) <-
-            bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ ->
-            do { let rn_sig = rnFamResultSig doc
-               ; (res_sig', fv_kind) <- wrapLocFstMA rn_sig res_sig
-               ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
-                                          injectivity
-               ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
-       ; (info', fv2) <- rn_info info
-       ; return (FamilyDecl { fdExt = noAnn
-                            , fdLName = tycon', fdTyVars = tyvars'
-                            , fdTopLevel = toplevel
-                            , fdFixity = fixity
-                            , fdInfo = info', fdResultSig = res_sig'
-                            , fdInjectivityAnn = injectivity' }
-                , fv1 `plusFV` fv2) }
-  where
-     doc = TyFamilyCtx tycon
-     kvs = extractRdrKindSigVars res_sig
-
-     ----------------------
-     rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
-     rn_info (ClosedTypeFamily (Just eqns))
-       = do { (eqns', fvs)
-                <- rnList (rnTyFamInstEqn (NonAssocTyFamEqn ClosedTyFam)) eqns
-                                          -- no class context
-            ; return (ClosedTypeFamily (Just eqns'), fvs) }
-     rn_info (ClosedTypeFamily Nothing)
-       = return (ClosedTypeFamily Nothing, emptyFVs)
-     rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
-     rn_info DataFamily     = return (DataFamily, emptyFVs)
-
-rnFamResultSig :: HsDocContext
-               -> FamilyResultSig GhcPs
-               -> RnM (FamilyResultSig GhcRn, FreeVars)
-rnFamResultSig _ (NoSig _)
-   = return (NoSig noExtField, emptyFVs)
-rnFamResultSig doc (KindSig _ kind)
-   = do { (rndKind, ftvs) <- rnLHsKind doc kind
-        ;  return (KindSig noExtField rndKind, ftvs) }
-rnFamResultSig doc (TyVarSig _ tvbndr)
-   = do { -- `TyVarSig` tells us that user named the result of a type family by
-          -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
-          -- be sure that the supplied result name is not identical to an
-          -- already in-scope type variable from an enclosing class.
-          --
-          --  Example of disallowed declaration:
-          --         class C a b where
-          --            type F b = a | a -> b
-          rdr_env <- getLocalRdrEnv
-       ;  let resName = hsLTyVarName tvbndr
-       ;  when (resName `elemLocalRdrEnv` rdr_env) $
-          addErrAt (getLocA tvbndr) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-                     (hsep [ text "Type variable", quotes (ppr resName) <> comma
-                           , text "naming a type family result,"
-                           ] $$
-                      text "shadows an already bound type variable")
-
-       ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for
-                                      -- scoping checks that are irrelevant here
-                          tvbndr $ \ tvbndr' ->
-         return (TyVarSig noExtField tvbndr', unitFV (hsLTyVarName tvbndr')) }
-
--- Note [Renaming injectivity annotation]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- During renaming of injectivity annotation we have to make several checks to
--- make sure that it is well-formed.  At the moment injectivity annotation
--- consists of a single injectivity condition, so the terms "injectivity
--- annotation" and "injectivity condition" might be used interchangeably.  See
--- Note [Injectivity annotation] for a detailed discussion of currently allowed
--- injectivity annotations.
---
--- Checking LHS is simple because the only type variable allowed on the LHS of
--- injectivity condition is the variable naming the result in type family head.
--- Example of disallowed annotation:
---
---     type family Foo a b = r | b -> a
---
--- Verifying RHS of injectivity consists of checking that:
---
---  1. only variables defined in type family head appear on the RHS (kind
---     variables are also allowed).  Example of disallowed annotation:
---
---        type family Foo a = r | r -> b
---
---  2. for associated types the result variable does not shadow any of type
---     class variables. Example of disallowed annotation:
---
---        class Foo a b where
---           type F a = b | b -> a
---
--- Breaking any of these assumptions results in an error.
-
--- | Rename injectivity annotation. Note that injectivity annotation is just the
--- part after the "|".  Everything that appears before it is renamed in
--- rnFamDecl.
-rnInjectivityAnn :: LHsQTyVars GhcRn           -- ^ Type variables declared in
-                                               --   type family head
-                 -> LFamilyResultSig GhcRn     -- ^ Result signature
-                 -> LInjectivityAnn GhcPs      -- ^ Injectivity annotation
-                 -> RnM (LInjectivityAnn GhcRn)
-rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
-                 (L srcSpan (InjectivityAnn x injFrom injTo))
- = do
-   { (injDecl'@(L _ (InjectivityAnn _ injFrom' injTo')), noRnErrors)
-          <- askNoErrs $
-             bindLocalNames [hsLTyVarName resTv] $
-             -- The return type variable scopes over the injectivity annotation
-             -- e.g.   type family F a = (r::*) | r -> a
-             do { injFrom' <- rnLTyVar injFrom
-                ; injTo'   <- mapM rnLTyVar injTo
-                -- Note: srcSpan is unchanged, but typechecker gets
-                -- confused, l2l call makes it happy
-                ; return $ L (l2l srcSpan) (InjectivityAnn x injFrom' injTo') }
-
-   ; let tvNames  = Set.fromList $ hsAllLTyVarNames tvBndrs
-         resName  = hsLTyVarName resTv
-         -- See Note [Renaming injectivity annotation]
-         lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))
-         rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames
-
-   -- if renaming of type variables ended with errors (eg. there were
-   -- not-in-scope variables) don't check the validity of injectivity
-   -- annotation. This gives better error messages.
-   ; when (noRnErrors && not lhsValid) $
-        addErrAt (getLocA injFrom) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-              ( vcat [ text $ "Incorrect type variable on the LHS of "
-                           ++ "injectivity condition"
-              , nest 5
-              ( vcat [ text "Expected :" <+> ppr resName
-                     , text "Actual   :" <+> ppr injFrom ])])
-
-   ; when (noRnErrors && not (Set.null rhsValid)) $
-      do { let errorVars = Set.toList rhsValid
-         ; addErrAt (locA srcSpan) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-                        ( hsep
-                        [ text "Unknown type variable" <> plural errorVars
-                        , text "on the RHS of injectivity condition:"
-                        , interpp'SP errorVars ] ) }
-
-   ; return injDecl' }
-
--- We can only hit this case when the user writes injectivity annotation without
--- naming the result:
---
---   type family F a | result -> a
---   type family F a :: * | result -> a
---
--- So we rename injectivity annotation like we normally would except that
--- this time we expect "result" to be reported not in scope by rnLTyVar.
-rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) =
-   setSrcSpanA srcSpan $ do
-   (injDecl', _) <- askNoErrs $ do
-     injFrom' <- rnLTyVar injFrom
-     injTo'   <- mapM rnLTyVar injTo
-     return $ L srcSpan (InjectivityAnn x injFrom' injTo')
-   return $ injDecl'
-
-{-
-Note [Stupid theta]
-~~~~~~~~~~~~~~~~~~~
-#3850 complains about a regression wrt 6.10 for
-     data Show a => T a
-There is no reason not to allow the stupid theta if there are no data
-constructors.  It's still stupid, but does no harm, and I don't want
-to cause programs to break unnecessarily (notably HList).  So if there
-are no data constructors we allow h98_style = True
--}
-
-
-{- *****************************************************
-*                                                      *
-     Support code for type/data declarations
-*                                                      *
-***************************************************** -}
-
------------------
-rnConDecls :: DataDefnCons (LConDecl GhcPs) -> RnM (DataDefnCons (LConDecl GhcRn), FreeVars)
-rnConDecls = mapFvRn (wrapLocFstMA rnConDecl)
-
-rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
-rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
-                           , con_mb_cxt = mcxt, con_args = args
-                           , con_doc = mb_doc, con_forall = forall_ })
-  = do  { _        <- addLocMA checkConName name
-        ; new_name <- lookupLocatedTopConstructorRnN name
-
-        -- We bind no implicit binders here; this is just like
-        -- a nested HsForAllTy.  E.g. consider
-        --         data T a = forall (b::k). MkT (...)
-        -- The 'k' will already be in scope from the bindHsQTyVars
-        -- for the data decl itself. So we'll get
-        --         data T {k} a = ...
-        -- And indeed we may later discover (a::k).  But that's the
-        -- scoping we get.  So no implicit binders at the existential forall
-
-        ; let ctxt = ConDeclCtx [new_name]
-        ; bindLHsTyVarBndrs ctxt WarnUnusedForalls
-                            Nothing ex_tvs $ \ new_ex_tvs ->
-    do  { (new_context, fvs1) <- rnMbContext ctxt mcxt
-        ; (new_args,    fvs2) <- rnConDeclH98Details (unLoc new_name) ctxt args
-        ; let all_fvs  = fvs1 `plusFV` fvs2
-        ; traceRn "rnConDecl (ConDeclH98)" (ppr name <+> vcat
-             [ text "ex_tvs:" <+> ppr ex_tvs
-             , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ])
-
-        ; mb_doc' <- traverse rnLHsDoc mb_doc
-        ; return (decl { con_ext = noAnn
-                       , con_name = new_name, con_ex_tvs = new_ex_tvs
-                       , con_mb_cxt = new_context, con_args = new_args
-                       , con_doc = mb_doc'
-                       , con_forall = forall_ }, -- Remove when #18311 is fixed
-                  all_fvs) }}
-
-rnConDecl (ConDeclGADT { con_names   = names
-                       , con_dcolon  = dcol
-                       , con_bndrs   = L l outer_bndrs
-                       , con_mb_cxt  = mcxt
-                       , con_g_args  = args
-                       , con_res_ty  = res_ty
-                       , con_doc     = mb_doc })
-  = do  { mapM_ (addLocMA checkConName) names
-        ; new_names <- mapM (lookupLocatedTopConstructorRnN) names
-
-        ; let -- We must ensure that we extract the free tkvs in left-to-right
-              -- order of their appearance in the constructor type.
-              -- That order governs the order the implicitly-quantified type
-              -- variable, and hence the order needed for visible type application
-              -- See #14808.
-              implicit_bndrs =
-                extractHsOuterTvBndrs outer_bndrs           $
-                extractHsTysRdrTyVars (hsConDeclTheta mcxt) $
-                extractConDeclGADTDetailsTyVars args        $
-                extractHsTysRdrTyVars [res_ty] []
-
-        ; let ctxt = ConDeclCtx (toList new_names)
-
-        ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' ->
-    do  { (new_cxt, fvs1)    <- rnMbContext ctxt mcxt
-        ; (new_args, fvs2)   <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args
-        ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
-
-         -- Ensure that there are no nested `forall`s or contexts, per
-         -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)
-         -- in GHC.Hs.Type.
-       ; addNoNestedForallsContextsErr ctxt
-           (text "GADT constructor type signature") new_res_ty
-
-        ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
-
-        ; traceRn "rnConDecl (ConDeclGADT)"
-            (ppr names $$ ppr outer_bndrs')
-        ; new_mb_doc <- traverse rnLHsDoc mb_doc
-        ; return (ConDeclGADT { con_g_ext = noAnn, con_names = new_names
-                              , con_dcolon = dcol
-                              , con_bndrs = L l outer_bndrs', con_mb_cxt = new_cxt
-                              , con_g_args = new_args, con_res_ty = new_res_ty
-                              , con_doc = new_mb_doc },
-                  all_fvs) } }
-
-rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
-            -> RnM (Maybe (LHsContext GhcRn), FreeVars)
-rnMbContext _    Nothing    = return (Nothing, emptyFVs)
-rnMbContext doc cxt = do { (ctx',fvs) <- rnMaybeContext doc cxt
-                         ; return (ctx',fvs) }
-
-rnConDeclH98Details ::
-      Name
-   -> HsDocContext
-   -> HsConDeclH98Details GhcPs
-   -> RnM (HsConDeclH98Details GhcRn, FreeVars)
-rnConDeclH98Details _ doc (PrefixCon _ tys)
-  = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys
-       ; return (PrefixCon noTypeArgs new_tys, fvs) }
-rnConDeclH98Details _ doc (InfixCon ty1 ty2)
-  = do { (new_ty1, fvs1) <- rnScaledLHsType doc ty1
-       ; (new_ty2, fvs2) <- rnScaledLHsType doc ty2
-       ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
-rnConDeclH98Details con doc (RecCon flds)
-  = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds
-       ; return (RecCon new_flds, fvs) }
-
-rnConDeclGADTDetails ::
-      Name
-   -> HsDocContext
-   -> HsConDeclGADTDetails GhcPs
-   -> RnM (HsConDeclGADTDetails GhcRn, FreeVars)
-rnConDeclGADTDetails _ doc (PrefixConGADT tys)
-  = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys
-       ; return (PrefixConGADT new_tys, fvs) }
-rnConDeclGADTDetails con doc (RecConGADT flds arr)
-  = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds
-       ; return (RecConGADT new_flds arr, fvs) }
-
-rnRecConDeclFields ::
-     Name
-  -> HsDocContext
-  -> LocatedL [LConDeclField GhcPs]
-  -> RnM (LocatedL [LConDeclField GhcRn], FreeVars)
-rnRecConDeclFields con doc (L l fields)
-  = do  { fls <- lookupConstructorFields con
-        ; (new_fields, fvs) <- rnConDeclFields doc fls fields
-                -- No need to check for duplicate fields
-                -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn
-        ; pure (L l new_fields, fvs) }
-
--------------------------------------------------
-
--- | Brings pattern synonym names and also pattern synonym selectors
--- from record pattern synonyms into scope.
-extendPatSynEnv :: DuplicateRecordFields -> FieldSelectors -> HsValBinds GhcPs -> MiniFixityEnv
-                -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
-extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do {
-     names_with_fls <- new_ps val_decls
-   ; let pat_syn_bndrs = concat [ name: map flSelector fields
-                                | (name, fields) <- names_with_fls ]
-   ; let avails = map avail (map fst names_with_fls)
-               ++ map availField (concatMap snd names_with_fls)
-   ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env
-
-   ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
-         final_gbl_env = gbl_env { tcg_field_env = field_env' }
-   ; restoreEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
-  where
-    new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
-    new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds
-    new_ps _ = panic "new_ps"
-
-    new_ps' :: LHsBindLR GhcPs GhcPs
-            -> [(Name, [FieldLabel])]
-            -> TcM [(Name, [FieldLabel])]
-    new_ps' bind names
-      | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n
-                                       , psb_args = RecCon as }))) <- bind
-      = do
-          bnd_name <- newTopSrcBinder (L (l2l bind_loc) n)
-          let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocA (foLabel f)) f) . recordPatSynField) as
-          flds <- mapM (newRecordSelector dup_fields_ok has_sel [bnd_name]) field_occs
-          return ((bnd_name, flds): names)
-      | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind
-      = do
-        bnd_name <- newTopSrcBinder (L (la2na bind_loc) n)
-        return ((bnd_name, []): names)
-      | otherwise
-      = return names
-
-{-
-*********************************************************
-*                                                      *
-\subsection{Support code to rename types}
-*                                                      *
-*********************************************************
--}
-
-rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
-rnFds fds
-  = mapM (wrapLocMA rn_fds) fds
-  where
-    rn_fds :: FunDep GhcPs -> RnM (FunDep GhcRn)
-    rn_fds (FunDep x tys1 tys2)
-      = do { tys1' <- rnHsTyVars tys1
-           ; tys2' <- rnHsTyVars tys2
-           ; return (FunDep x tys1' tys2') }
-
-rnHsTyVars :: [LocatedN RdrName] -> RnM [LocatedN Name]
-rnHsTyVars tvs  = mapM rnHsTyVar tvs
-
-rnHsTyVar :: LocatedN RdrName -> RnM (LocatedN Name)
-rnHsTyVar (L l tyvar) = do
-  tyvar' <- lookupOccRn tyvar
-  return (L l tyvar')
-
-{-
-*********************************************************
-*                                                      *
-        findSplice
-*                                                      *
-*********************************************************
-
-This code marches down the declarations, looking for the first
-Template Haskell splice.  As it does so it
-        a) groups the declarations into a HsGroup
-        b) runs any top-level quasi-quotes
--}
-
-findSplice :: [LHsDecl GhcPs]
-           -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
-findSplice ds = addl emptyRdrGroup ds
-
-addl :: HsGroup GhcPs -> [LHsDecl GhcPs]
-     -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
--- This stuff reverses the declarations (again) but it doesn't matter
-addl gp []           = return (gp, Nothing)
-addl gp (L l d : ds) = add gp l d ds
-
-
-add :: HsGroup GhcPs -> SrcSpanAnnA -> HsDecl GhcPs -> [LHsDecl GhcPs]
-    -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
-
--- #10047: Declaration QuasiQuoters are expanded immediately, without
---         causing a group split
-add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds
-  = do { (ds', _) <- rnTopSpliceDecls qq
-       ; addl gp (ds' ++ ds)
-       }
-
-add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds
-  = do { -- We've found a top-level splice.  If it is an *implicit* one
-         -- (i.e. a naked top level expression)
-         case flag of
-           DollarSplice -> return ()
-           BareSplice -> do { th_on <- xoptM LangExt.TemplateHaskell
-                                ; unless th_on $ setSrcSpan (locA loc) $
-                                  failWith badImplicitSplice }
-
-       ; return (gp, Just (splice, ds)) }
-  where
-    badImplicitSplice :: TcRnMessage
-    badImplicitSplice = mkTcRnUnknownMessage $ mkPlainError noHints $
-                        text "Parse error: module header, import declaration"
-                     $$ text "or top-level declaration expected."
-                     -- The compiler should suggest the above, and not using
-                     -- TemplateHaskell since the former suggestion is more
-                     -- relevant to the larger base of users.
-                     -- See #12146 for discussion.
-
--- Class declarations: added to the TyClGroup
-add gp@(HsGroup {hs_tyclds = ts}) l (TyClD _ d) ds
-  = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
-
--- Signatures: fixity sigs go a different place than all others
-add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds
-  = addl (gp {hs_fixds = L l f : ts}) ds
-
--- Standalone kind signatures: added to the TyClGroup
-add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds
-  = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds
-
-add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds
-  = addl (gp {hs_valds = add_sig (L l d) ts}) ds
-
--- Value declarations: use add_bind
-add gp@(HsGroup {hs_valds  = ts}) l (ValD _ d) ds
-  = addl (gp { hs_valds = add_bind (L l d) ts }) ds
-
--- Role annotations: added to the TyClGroup
-add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds
-  = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
-
--- NB instance declarations go into TyClGroups. We throw them into the first
--- group, just as we do for the TyClD case. The renamer will go on to group
--- and order them later.
-add gp@(HsGroup {hs_tyclds = ts})  l (InstD _ d) ds
-  = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds
-
--- The rest are routine
-add gp@(HsGroup {hs_derivds = ts})  l (DerivD _ d) ds
-  = addl (gp { hs_derivds = L l d : ts }) ds
-add gp@(HsGroup {hs_defds  = ts})  l (DefD _ d) ds
-  = addl (gp { hs_defds = L l d : ts }) ds
-add gp@(HsGroup {hs_fords  = ts}) l (ForD _ d) ds
-  = addl (gp { hs_fords = L l d : ts }) ds
-add gp@(HsGroup {hs_warnds  = ts})  l (WarningD _ d) ds
-  = addl (gp { hs_warnds = L l d : ts }) ds
-add gp@(HsGroup {hs_annds  = ts}) l (AnnD _ d) ds
-  = addl (gp { hs_annds = L l d : ts }) ds
-add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD _ d) ds
-  = addl (gp { hs_ruleds = L l d : ts }) ds
-add gp l (DocD _ d) ds
-  = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
-
-add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
-          -> [TyClGroup (GhcPass p)]
-add_tycld d []       = [TyClGroup { group_ext    = noExtField
-                                  , group_tyclds = [d]
-                                  , group_kisigs = []
-                                  , group_roles  = []
-                                  , group_instds = []
-                                  }
-                       ]
-add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
-  = ds { group_tyclds = d : tyclds } : dss
-
-add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
-          -> [TyClGroup (GhcPass p)]
-add_instd d []       = [TyClGroup { group_ext    = noExtField
-                                  , group_tyclds = []
-                                  , group_kisigs = []
-                                  , group_roles  = []
-                                  , group_instds = [d]
-                                  }
-                       ]
-add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
-  = ds { group_instds = d : instds } : dss
-
-add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
-               -> [TyClGroup (GhcPass p)]
-add_role_annot d [] = [TyClGroup { group_ext    = noExtField
-                                 , group_tyclds = []
-                                 , group_kisigs = []
-                                 , group_roles  = [d]
-                                 , group_instds = []
-                                 }
-                      ]
-add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
-  = tycls { group_roles = d : roles } : rest
-
-add_kisig :: LStandaloneKindSig (GhcPass p)
-         -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
-add_kisig d [] = [TyClGroup { group_ext    = noExtField
-                            , group_tyclds = []
-                            , group_kisigs = [d]
-                            , group_roles  = []
-                            , group_instds = []
-                            }
-                 ]
-add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest)
-  = tycls { group_kisigs = d : kisigs } : rest
-
-add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
-add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs
-add_bind _ (XValBindsLR {})     = panic "GHC.Rename.Module.add_bind"
-
-add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
-add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs)
-add_sig _ (XValBindsLR {})     = panic "GHC.Rename.Module.add_sig"
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
deleted file mode 100644
--- a/compiler/GHC/Rename/Names.hs
+++ /dev/null
@@ -1,2208 +0,0 @@
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-Extracting imported and top-level names in scope
--}
-
-{-# LANGUAGE NondecreasingIndentation #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE LambdaCase #-}
-
-module GHC.Rename.Names (
-        rnImports, getLocalNonValBinders, newRecordSelector,
-        extendGlobalRdrEnvRn,
-        gresFromAvails,
-        calculateAvails,
-        reportUnusedNames,
-        checkConName,
-        mkChildEnv,
-        findChildren,
-        findImportUsage,
-        getMinimalImports,
-        printMinimalImports,
-        renamePkgQual, renameRawPkgQual,
-        ImportDeclUsage
-    ) where
-
-import GHC.Prelude hiding ( head, init, last, tail )
-
-import GHC.Driver.Env
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-
-import GHC.Rename.Env
-import GHC.Rename.Fixity
-import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv )
-
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.Monad
-
-import GHC.Hs
-import GHC.Iface.Load   ( loadSrcInterface )
-import GHC.Builtin.Names
-import GHC.Parser.PostProcess ( setRdrNameSpace )
-import GHC.Core.Type
-import GHC.Core.PatSyn
-import GHC.Core.TyCon ( TyCon, tyConName )
-import qualified GHC.LanguageExtensions as LangExt
-
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Misc as Utils
-import GHC.Utils.Panic
-
-import GHC.Types.Fixity.Env
-import GHC.Types.SafeHaskell
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.Name.Set
-import GHC.Types.Name.Reader
-import GHC.Types.Avail
-import GHC.Types.FieldLabel
-import GHC.Types.SourceFile
-import GHC.Types.SrcLoc as SrcLoc
-import GHC.Types.Basic  ( TopLevelFlag(..) )
-import GHC.Types.SourceText
-import GHC.Types.Id
-import GHC.Types.HpcInfo
-import GHC.Types.Error
-import GHC.Types.PkgQual
-
-import GHC.Unit
-import GHC.Unit.Module.Warnings
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.Imported
-import GHC.Unit.Module.Deps
-import GHC.Unit.Env
-
-import GHC.Data.Maybe
-import GHC.Data.FastString
-import GHC.Data.FastString.Env
-
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-import Control.Monad
-import Data.Either      ( partitionEithers )
-import Data.Map         ( Map )
-import qualified Data.Map as Map
-import Data.Ord         ( comparing )
-import Data.List        ( partition, (\\), find, sortBy )
-import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NE
-import Data.Function    ( on )
-import qualified Data.Set as S
-import Data.Foldable    ( toList )
-import System.FilePath  ((</>))
-
-import System.IO
-import GHC.Data.Bag
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{rnImports}
-*                                                                      *
-************************************************************************
-
-Note [Tracking Trust Transitively]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we import a package as well as checking that the direct imports are safe
-according to the rules outlined in the Note [Safe Haskell Trust Check] in GHC.Driver.Main
-we must also check that these rules hold transitively for all dependent modules
-and packages. Doing this without caching any trust information would be very
-slow as we would need to touch all packages and interface files a module depends
-on. To avoid this we make use of the property that if a modules Safe Haskell
-mode changes, this triggers a recompilation from that module in the dependency
-graph. So we can just worry mostly about direct imports.
-
-There is one trust property that can change for a package though without
-recompilation being triggered: package trust. So we must check that all
-packages a module transitively depends on to be trusted are still trusted when
-we are compiling this module (as due to recompilation avoidance some modules
-below may not be considered trusted any more without recompilation being
-triggered).
-
-We handle this by augmenting the existing transitive list of packages a module M
-depends on with a bool for each package that says if it must be trusted when the
-module M is being checked for trust. This list of trust required packages for a
-single import is gathered in the rnImportDecl function and stored in an
-ImportAvails data structure. The union of these trust required packages for all
-imports is done by the rnImports function using the combine function which calls
-the plusImportAvails function that is a union operation for the ImportAvails
-type. This gives us in an ImportAvails structure all packages required to be
-trusted for the module we are currently compiling. Checking that these packages
-are still trusted (and that direct imports are trusted) is done in
-GHC.Driver.Main.checkSafeImports.
-
-See the note below, [Trust Own Package] for a corner case in this method and
-how its handled.
-
-
-Note [Trust Own Package]
-~~~~~~~~~~~~~~~~~~~~~~~~
-There is a corner case of package trust checking that the usual transitive check
-doesn't cover. (For how the usual check operates see the Note [Tracking Trust
-Transitively] below). The case is when you import a -XSafe module M and M
-imports a -XTrustworthy module N. If N resides in a different package than M,
-then the usual check works as M will record a package dependency on N's package
-and mark it as required to be trusted. If N resides in the same package as M
-though, then importing M should require its own package be trusted due to N
-(since M is -XSafe so doesn't create this requirement by itself). The usual
-check fails as a module doesn't record a package dependency of its own package.
-So instead we now have a bool field in a modules interface file that simply
-states if the module requires its own package to be trusted. This field avoids
-us having to load all interface files that the module depends on to see if one
-is trustworthy.
-
-
-Note [Trust Transitive Property]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-So there is an interesting design question in regards to transitive trust
-checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch
-of modules and packages, some packages it requires to be trusted as its using
--XTrustworthy modules from them. Now if I have a module A that doesn't use safe
-haskell at all and simply imports B, should A inherit all the trust
-requirements from B? Should A now also require that a package p is trusted since
-B required it?
-
-We currently say no but saying yes also makes sense. The difference is, if a
-module M that doesn't use Safe Haskell imports a module N that does, should all
-the trusted package requirements be dropped since M didn't declare that it cares
-about Safe Haskell (so -XSafe is more strongly associated with the module doing
-the importing) or should it be done still since the author of the module N that
-uses Safe Haskell said they cared (so -XSafe is more strongly associated with
-the module that was compiled that used it).
-
-Going with yes is a simpler semantics we think and harder for the user to stuff
-up but it does mean that Safe Haskell will affect users who don't care about
-Safe Haskell as they might grab a package from Cabal which uses safe haskell (say
-network) and that packages imports -XTrustworthy modules from another package
-(say bytestring), so requires that package is trusted. The user may now get
-compilation errors in code that doesn't do anything with Safe Haskell simply
-because they are using the network package. They will have to call 'ghc-pkg
-trust network' to get everything working. Due to this invasive nature of going
-with yes we have gone with no for now.
--}
-
--- | Process Import Decls.  See 'rnImportDecl' for a description of what
--- the return types represent.
--- Note: Do the non SOURCE ones first, so that we get a helpful warning
--- for SOURCE ones that are unnecessary
-rnImports :: [(LImportDecl GhcPs, SDoc)]
-          -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
-rnImports imports = do
-    tcg_env <- getGblEnv
-    -- NB: want an identity module here, because it's OK for a signature
-    -- module to import from its implementor
-    let this_mod = tcg_mod tcg_env
-    let (source, ordinary) = partition (is_source_import . fst) imports
-        is_source_import d = ideclSource (unLoc d) == IsBoot
-    stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary
-    stuff2 <- mapAndReportM (rnImportDecl this_mod) source
-    -- Safe Haskell: See Note [Tracking Trust Transitively]
-    let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2)
-    -- Update imp_boot_mods if imp_direct_mods mentions any of them
-    let merged_import_avail = clobberSourceImports imp_avails
-    dflags <- getDynFlags
-    let final_import_avail  =
-          merged_import_avail { imp_dep_direct_pkgs = S.fromList (implicitPackageDeps dflags)
-                                                        `S.union` imp_dep_direct_pkgs merged_import_avail}
-    return (decls, rdr_env, final_import_avail, hpc_usage)
-
-  where
-    clobberSourceImports imp_avails =
-      imp_avails { imp_boot_mods = imp_boot_mods' }
-      where
-        imp_boot_mods' = mergeInstalledModuleEnv combJ id (const emptyInstalledModuleEnv)
-                            (imp_boot_mods imp_avails)
-                            (imp_direct_dep_mods imp_avails)
-
-        combJ (GWIB _ IsBoot) x = Just x
-        combJ r _               = Just r
-    -- See Note [Combining ImportAvails]
-    combine :: [(LImportDecl GhcRn,  GlobalRdrEnv, ImportAvails, AnyHpcUsage)]
-            -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
-    combine ss =
-      let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr
-            plus
-            ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet)
-            ss
-      in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts },
-            hpc_usage)
-
-    plus (decl,  gbl_env1, imp_avails1, hpc_usage1)
-         (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set)
-      = ( decl:decls,
-          gbl_env1 `plusGlobalRdrEnv` gbl_env2,
-          imp_avails1' `plusImportAvails` imp_avails2,
-          hpc_usage1 || hpc_usage2,
-          extendModuleSetList finsts_set new_finsts )
-      where
-      imp_avails1' = imp_avails1 { imp_finsts = [] }
-      new_finsts = imp_finsts imp_avails1
-
-{-
-Note [Combining ImportAvails]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-imp_finsts in ImportAvails is a list of family instance modules
-transitively depended on by an import. imp_finsts for a currently
-compiled module is a union of all the imp_finsts of imports.
-Computing the union of two lists of size N is O(N^2) and if we
-do it to M imports we end up with O(M*N^2). That can get very
-expensive for bigger module hierarchies.
-
-Union can be optimized to O(N log N) if we use a Set.
-imp_finsts is converted back and forth between dep_finsts, so
-changing a type of imp_finsts means either paying for the conversions
-or changing the type of dep_finsts as well.
-
-I've measured that the conversions would cost 20% of allocations on my
-test case, so that can be ruled out.
-
-Changing the type of dep_finsts forces checkFamInsts to
-get the module lists in non-deterministic order. If we wanted to restore
-the deterministic order, we'd have to sort there, which is an additional
-cost. As far as I can tell, using a non-deterministic order is fine there,
-but that's a brittle nonlocal property which I'd like to avoid.
-
-Additionally, dep_finsts is read from an interface file, so its "natural"
-type is a list. Which makes it a natural type for imp_finsts.
-
-Since rnImports.combine is really the only place that would benefit from
-it being a Set, it makes sense to optimize the hot loop in rnImports.combine
-without changing the representation.
-
-So here's what we do: instead of naively merging ImportAvails with
-plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts
-and compute the union on the side using Sets. When we're done, we can
-convert it back to a list. One nice side effect of this approach is that
-if there's a lot of overlap in the imp_finsts of imports, the
-Set doesn't really need to grow and we don't need to allocate.
-
-Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in
-23s before, and 11s after.
--}
-
-
-
--- | Given a located import declaration @decl@ from @this_mod@,
--- calculate the following pieces of information:
---
---  1. An updated 'LImportDecl', where all unresolved 'RdrName' in
---     the entity lists have been resolved into 'Name's,
---
---  2. A 'GlobalRdrEnv' representing the new identifiers that were
---     brought into scope (taking into account module qualification
---     and hiding),
---
---  3. 'ImportAvails' summarizing the identifiers that were imported
---     by this declaration, and
---
---  4. A boolean 'AnyHpcUsage' which is true if the imported module
---     used HPC.
-rnImportDecl  :: Module -> (LImportDecl GhcPs, SDoc)
-             -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)
-rnImportDecl this_mod
-             (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name
-                                     , ideclPkgQual = raw_pkg_qual
-                                     , ideclSource = want_boot, ideclSafe = mod_safe
-                                     , ideclQualified = qual_style
-                                     , ideclExt = XImportDeclPass { ideclImplicit = implicit }
-                                     , ideclAs = as_mod, ideclImportList = imp_details }), import_reason)
-  = setSrcSpanA loc $ do
-
-    case raw_pkg_qual of
-      NoRawPkgQual -> pure ()
-      RawPkgQual _ -> do
-        pkg_imports <- xoptM LangExt.PackageImports
-        when (not pkg_imports) $ addErr packageImportErr
-
-    let qual_only = isImportDeclQualified qual_style
-
-    -- If there's an error in loadInterface, (e.g. interface
-    -- file not found) we get lots of spurious errors from 'filterImports'
-    let imp_mod_name = unLoc loc_imp_mod_name
-        doc = ppr imp_mod_name <+> import_reason
-
-    hsc_env <- getTopEnv
-    unit_env <- hsc_unit_env <$> getTopEnv
-    let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual
-
-    -- Check for self-import, which confuses the typechecker (#9032)
-    -- ghc --make rejects self-import cycles already, but batch-mode may not
-    -- at least not until GHC.IfaceToCore.tcHiBootIface, which is too late to avoid
-    -- typechecker crashes.  (Indirect self imports are not caught until
-    -- GHC.IfaceToCore, see #10337 tracking how to make this error better.)
-    --
-    -- Originally, we also allowed 'import {-# SOURCE #-} M', but this
-    -- caused bug #10182: in one-shot mode, we should never load an hs-boot
-    -- file for the module we are compiling into the EPS.  In principle,
-    -- it should be possible to support this mode of use, but we would have to
-    -- extend Provenance to support a local definition in a qualified location.
-    -- For now, we don't support it, but see #10336
-    when (imp_mod_name == moduleName this_mod &&
-          (case pkg_qual of -- If we have import "<pkg>" M, then we should
-                            -- check that "<pkg>" is "this" (which is magic)
-                            -- or the name of this_mod's package.  Yurgh!
-                            -- c.f. GHC.findModule, and #9997
-             NoPkgQual         -> True
-             ThisPkg uid       -> uid == homeUnitId_ (hsc_dflags hsc_env)
-             OtherPkg _        -> False))
-         (addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-           (text "A module cannot import itself:" <+> ppr imp_mod_name))
-
-    -- Check for a missing import list (Opt_WarnMissingImportList also
-    -- checks for T(..) items but that is done in checkDodgyImport below)
-    case imp_details of
-        Just (Exactly, _) -> return () -- Explicit import list
-        _  | implicit   -> return () -- Do not bleat for implicit imports
-           | qual_only  -> return ()
-           | otherwise  -> whenWOptM Opt_WarnMissingImportList $ do
-                             let msg = mkTcRnUnknownMessage $
-                                   mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingImportList)
-                                                     noHints
-                                                     (missingImportListWarn imp_mod_name)
-                             addDiagnostic msg
-
-
-    iface <- loadSrcInterface doc imp_mod_name want_boot pkg_qual
-
-    -- Compiler sanity check: if the import didn't say
-    -- {-# SOURCE #-} we should not get a hi-boot file
-    warnPprTrace ((want_boot == NotBoot) && (mi_boot iface == IsBoot)) "rnImportDecl" (ppr imp_mod_name) $ do
-
-    -- Issue a user warning for a redundant {- SOURCE -} import
-    -- NB that we arrange to read all the ordinary imports before
-    -- any of the {- SOURCE -} imports.
-    --
-    -- in --make and GHCi, the compilation manager checks for this,
-    -- and indeed we shouldn't do it here because the existence of
-    -- the non-boot module depends on the compilation order, which
-    -- is not deterministic.  The hs-boot test can show this up.
-    dflags <- getDynFlags
-    warnIf ((want_boot == IsBoot) && (mi_boot iface == NotBoot) && isOneShot (ghcMode dflags))
-           (warnRedundantSourceImport imp_mod_name)
-    when (mod_safe && not (safeImportsOn dflags)) $
-        addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-          (text "safe import can't be used as Safe Haskell isn't on!"
-                $+$ text ("please enable Safe Haskell through either Safe, Trustworthy or Unsafe"))
-
-    let
-        qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name
-        imp_spec  = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only,
-                                  is_dloc = locA loc, is_as = qual_mod_name }
-
-    -- filter the imports according to the import declaration
-    (new_imp_details, gres) <- filterImports iface imp_spec imp_details
-
-    -- for certain error messages, we’d like to know what could be imported
-    -- here, if everything were imported
-    potential_gres <- mkGlobalRdrEnv . snd <$> filterImports iface imp_spec Nothing
-
-    let gbl_env = mkGlobalRdrEnv gres
-
-        is_hiding | Just (EverythingBut,_) <- imp_details = True
-                  | otherwise                             = False
-
-        -- should the import be safe?
-        mod_safe' = mod_safe
-                    || (not implicit && safeDirectImpsReq dflags)
-                    || (implicit && safeImplicitImpsReq dflags)
-
-    hsc_env <- getTopEnv
-    let home_unit = hsc_home_unit hsc_env
-        other_home_units = hsc_all_home_unit_ids hsc_env
-        imv = ImportedModsVal
-            { imv_name        = qual_mod_name
-            , imv_span        = locA loc
-            , imv_is_safe     = mod_safe'
-            , imv_is_hiding   = is_hiding
-            , imv_all_exports = potential_gres
-            , imv_qualified   = qual_only
-            }
-        imports = calculateAvails home_unit other_home_units iface mod_safe' want_boot (ImportedByUser imv)
-
-    -- Complain if we import a deprecated module
-    case mi_warns iface of
-       WarnAll txt -> do
-         let msg = mkTcRnUnknownMessage $
-               mkPlainDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations)
-                                 noHints
-                                 (moduleWarn imp_mod_name txt)
-         addDiagnostic msg
-       _           -> return ()
-
-    -- Complain about -Wcompat-unqualified-imports violations.
-    warnUnqualifiedImport decl iface
-
-    let new_imp_decl = ImportDecl
-          { ideclExt       = ideclExt decl
-          , ideclName      = ideclName decl
-          , ideclPkgQual   = pkg_qual
-          , ideclSource    = ideclSource decl
-          , ideclSafe      = mod_safe'
-          , ideclQualified = ideclQualified decl
-          , ideclAs        = ideclAs decl
-          , ideclImportList = new_imp_details
-          }
-
-    return (L loc new_imp_decl, gbl_env, imports, mi_hpc iface)
-
-
--- | Rename raw package imports
-renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
-renameRawPkgQual unit_env mn = \case
-  NoRawPkgQual -> NoPkgQual
-  RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p))
-
--- | Rename raw package imports
-renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
-renamePkgQual unit_env mn mb_pkg = case mb_pkg of
-  Nothing -> NoPkgQual
-  Just pkg_fs
-    | Just uid <- homeUnitId <$> ue_homeUnit unit_env
-    , pkg_fs == fsLit "this"
-    -> ThisPkg uid
-
-    | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names
-    -> ThisPkg uid
-
-    | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)
-    -> OtherPkg uid
-
-    | otherwise
-    -> OtherPkg (UnitId pkg_fs)
-       -- not really correct as pkg_fs is unlikely to be a valid unit-id but
-       -- we will report the failure later...
-  where
-    home_names  = map (\uid -> (uid, mkFastString <$> thisPackageName (homeUnitEnv_dflags (ue_findHomeUnitEnv uid unit_env)))) hpt_deps
-
-    units = ue_units unit_env
-
-    hpt_deps :: [UnitId]
-    hpt_deps  = homeUnitDepends units
-
-
--- | Calculate the 'ImportAvails' induced by an import of a particular
--- interface, but without 'imp_mods'.
-calculateAvails :: HomeUnit
-                -> S.Set UnitId
-                -> ModIface
-                -> IsSafeImport
-                -> IsBootInterface
-                -> ImportedBy
-                -> ImportAvails
-calculateAvails home_unit other_home_units iface mod_safe' want_boot imported_by =
-  let imp_mod    = mi_module iface
-      imp_sem_mod= mi_semantic_module iface
-      orph_iface = mi_orphan (mi_final_exts iface)
-      has_finsts = mi_finsts (mi_final_exts iface)
-      deps       = mi_deps iface
-      trust      = getSafeMode $ mi_trust iface
-      trust_pkg  = mi_trust_pkg iface
-      is_sig     = mi_hsc_src iface == HsigFile
-
-      -- If the module exports anything defined in this module, just
-      -- ignore it.  Reason: otherwise it looks as if there are two
-      -- local definition sites for the thing, and an error gets
-      -- reported.  Easiest thing is just to filter them out up
-      -- front. This situation only arises if a module imports
-      -- itself, or another module that imported it.  (Necessarily,
-      -- this involves a loop.)
-      --
-      -- We do this *after* filterImports, so that if you say
-      --      module A where
-      --         import B( AType )
-      --         type AType = ...
-      --
-      --      module B( AType ) where
-      --         import {-# SOURCE #-} A( AType )
-      --
-      -- then you won't get a 'B does not export AType' message.
-
-
-      -- Compute new transitive dependencies
-      --
-      -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module
-      -- itself, but we DO need to include this module in 'imp_orphs' and
-      -- 'imp_finsts' if it defines an orphan or instance family; thus the
-      -- orph_iface/has_iface tests.
-
-      deporphs  = dep_orphs deps
-      depfinsts = dep_finsts deps
-
-      orphans | orph_iface = assertPpr (not (imp_sem_mod `elem` deporphs)) (ppr imp_sem_mod <+> ppr deporphs) $
-                             imp_sem_mod : deporphs
-              | otherwise  = deporphs
-
-      finsts | has_finsts = assertPpr (not (imp_sem_mod `elem` depfinsts)) (ppr imp_sem_mod <+> ppr depfinsts) $
-                            imp_sem_mod : depfinsts
-             | otherwise  = depfinsts
-
-      -- Trusted packages are a lot like orphans.
-      trusted_pkgs | mod_safe' = dep_trusted_pkgs deps
-                   | otherwise = S.empty
-
-
-      pkg = moduleUnit (mi_module iface)
-      ipkg = toUnitId pkg
-
-      -- Does this import mean we now require our own pkg
-      -- to be trusted? See Note [Trust Own Package]
-      ptrust = trust == Sf_Trustworthy || trust_pkg
-      pkg_trust_req
-        | isHomeUnit home_unit pkg = ptrust
-        | otherwise = False
-
-      dependent_pkgs = if toUnitId pkg `S.member` other_home_units
-                        then S.empty
-                        else S.singleton ipkg
-
-      direct_mods = mkModDeps $ if toUnitId pkg `S.member` other_home_units
-                      then S.singleton (moduleUnitId imp_mod, (GWIB (moduleName imp_mod) want_boot))
-                      else S.empty
-
-      dep_boot_mods_map = mkModDeps (dep_boot_mods deps)
-
-      boot_mods
-        -- If we are looking for a boot module, it must be HPT
-        | IsBoot <- want_boot = extendInstalledModuleEnv dep_boot_mods_map (toUnitId <$> imp_mod) (GWIB (moduleName imp_mod) IsBoot)
-        -- Now we are importing A properly, so don't go looking for
-        -- A.hs-boot
-        | isHomeUnit home_unit pkg = dep_boot_mods_map
-        -- There's no boot files to find in external imports
-        | otherwise = emptyInstalledModuleEnv
-
-      sig_mods =
-        if is_sig
-          then moduleName imp_mod : dep_sig_mods deps
-          else dep_sig_mods deps
-
-
-  in ImportAvails {
-          imp_mods       = unitModuleEnv (mi_module iface) [imported_by],
-          imp_orphs      = orphans,
-          imp_finsts     = finsts,
-          imp_sig_mods   = sig_mods,
-          imp_direct_dep_mods = direct_mods,
-          imp_dep_direct_pkgs = dependent_pkgs,
-          imp_boot_mods = boot_mods,
-
-          -- Add in the imported modules trusted package
-          -- requirements. ONLY do this though if we import the
-          -- module as a safe import.
-          -- See Note [Tracking Trust Transitively]
-          -- and Note [Trust Transitive Property]
-          imp_trust_pkgs = trusted_pkgs,
-          -- Do we require our own pkg to be trusted?
-          -- See Note [Trust Own Package]
-          imp_trust_own_pkg = pkg_trust_req
-     }
-
-
--- | Issue a warning if the user imports Data.List without either an import
--- list or `qualified`. This is part of the migration plan for the
--- `Data.List.singleton` proposal. See #17244.
-warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM ()
-warnUnqualifiedImport decl iface =
-    when bad_import $ do
-      let msg = mkTcRnUnknownMessage $
-            mkPlainDiagnostic (WarningWithFlag Opt_WarnCompatUnqualifiedImports)
-                              noHints
-                              warning
-      addDiagnosticAt loc msg
-  where
-    mod = mi_module iface
-    loc = getLocA $ ideclName decl
-
-    is_qual = isImportDeclQualified (ideclQualified decl)
-    has_import_list =
-      -- We treat a `hiding` clause as not having an import list although
-      -- it's not entirely clear this is the right choice.
-      case ideclImportList decl of
-        Just (Exactly, _) -> True
-        _               -> False
-    bad_import =
-         not is_qual
-      && not has_import_list
-      && mod `elemModuleSet` qualifiedMods
-
-    warning = vcat
-      [ text "To ensure compatibility with future core libraries changes"
-      , text "imports to" <+> ppr (ideclName decl) <+> text "should be"
-      , text "either qualified or have an explicit import list."
-      ]
-
-    -- Modules for which we warn if we see unqualified imports
-    qualifiedMods = mkModuleSet [ dATA_LIST ]
-
-
-warnRedundantSourceImport :: ModuleName -> TcRnMessage
-warnRedundantSourceImport mod_name
-  = mkTcRnUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag noHints $
-      text "Unnecessary {-# SOURCE #-} in the import of module" <+> quotes (ppr mod_name)
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{importsFromLocalDecls}
-*                                                                      *
-************************************************************************
-
-From the top-level declarations of this module produce
-        * the lexical environment
-        * the ImportAvails
-created by its bindings.
-
-Note [Top-level Names in Template Haskell decl quotes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See also: Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env
-          Note [Looking up Exact RdrNames] in GHC.Rename.Env
-
-Consider a Template Haskell declaration quotation like this:
-      module M where
-        f x = h [d| f = 3 |]
-When renaming the declarations inside [d| ...|], we treat the
-top level binders specially in two ways
-
-1.  We give them an Internal Name, not (as usual) an External one.
-    This is done by GHC.Rename.Env.newTopSrcBinder.
-
-2.  We make them *shadow* the outer bindings.
-    See Note [GlobalRdrEnv shadowing]
-
-3. We find out whether we are inside a [d| ... |] by testing the TH
-   stage. This is a slight hack, because the stage field was really
-   meant for the type checker, and here we are not interested in the
-   fields of Brack, hence the error thunks in thRnBrack.
--}
-
-extendGlobalRdrEnvRn :: [AvailInfo]
-                     -> MiniFixityEnv
-                     -> RnM (TcGblEnv, TcLclEnv)
--- Updates both the GlobalRdrEnv and the FixityEnv
--- We return a new TcLclEnv only because we might have to
--- delete some bindings from it;
--- see Note [Top-level Names in Template Haskell decl quotes]
-
-extendGlobalRdrEnvRn avails new_fixities
-  = checkNoErrs $  -- See Note [Fail fast on duplicate definitions]
-    do  { (gbl_env, lcl_env) <- getEnvs
-        ; stage <- getStage
-        ; isGHCi <- getIsGHCi
-        ; let rdr_env  = tcg_rdr_env gbl_env
-              fix_env  = tcg_fix_env gbl_env
-              th_bndrs = tcl_th_bndrs lcl_env
-              th_lvl   = thLevel stage
-
-              -- Delete new_occs from global and local envs
-              -- If we are in a TemplateHaskell decl bracket,
-              --    we are going to shadow them
-              -- See Note [GlobalRdrEnv shadowing]
-              inBracket = isBrackStage stage
-
-              lcl_env_TH = lcl_env { tcl_rdr = minusLocalRdrEnv (tcl_rdr lcl_env) new_occs }
-                           -- See Note [GlobalRdrEnv shadowing]
-
-              lcl_env2 | inBracket = lcl_env_TH
-                       | otherwise = lcl_env
-
-              -- Deal with shadowing: see Note [GlobalRdrEnv shadowing]
-              want_shadowing = isGHCi || inBracket
-              rdr_env1 | want_shadowing = shadowNames rdr_env new_occs
-                       | otherwise      = rdr_env
-
-              lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs
-                                                       [ ( greNameMangledName n
-                                                         , (TopLevel, th_lvl) )
-                                                       | n <- new_names ] }
-
-        ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres
-
-        ; let fix_env' = foldl' extend_fix_env fix_env new_gres
-              gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }
-
-        ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2)
-        ; return (gbl_env', lcl_env3) }
-  where
-    new_names = concatMap availGreNames avails
-    new_occs  = occSetToEnv (mkOccSet (map occName new_names))
-
-    -- If there is a fixity decl for the gre, add it to the fixity env
-    extend_fix_env fix_env gre
-      | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ)
-      = extendNameEnv fix_env name (FixItem occ fi)
-      | otherwise
-      = fix_env
-      where
-        name = greMangledName gre
-        occ  = greOccName gre
-
-    new_gres :: [GlobalRdrElt]  -- New LocalDef GREs, derived from avails
-    new_gres = concatMap localGREsFromAvail avails
-
-    add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv
-    -- Extend the GlobalRdrEnv with a LocalDef GRE
-    -- If there is already a LocalDef GRE with the same OccName,
-    --    report an error and discard the new GRE
-    -- This establishes INVARIANT 1 of GlobalRdrEnvs
-    add_gre env gre
-      | not (null dups)    -- Same OccName defined twice
-      = do { addDupDeclErr (gre :| dups); return env }
-
-      | otherwise
-      = return (extendGlobalRdrEnv env gre)
-      where
-        -- See Note [Reporting duplicate local declarations]
-        dups = filter isDupGRE (lookupGlobalRdrEnv env (greOccName gre))
-        isDupGRE gre' = isLocalGRE gre' && not (isAllowedDup gre')
-        isAllowedDup gre' =
-            case (isRecFldGRE gre, isRecFldGRE gre') of
-              (True,  True)  -> gre_name gre /= gre_name gre'
-                                  && isDuplicateRecFldGRE gre'
-              (True,  False) -> isNoFieldSelectorGRE gre
-              (False, True)  -> isNoFieldSelectorGRE gre'
-              (False, False) -> False
-
-{- Note [Fail fast on duplicate definitions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If there are duplicate bindings for the same thing, we want to fail
-fast. Having two bindings for the same thing can cause follow-on errors.
-Example (test T9975a):
-   data Test = Test { x :: Int }
-   pattern Test wat = Test { x = wat }
-This defines 'Test' twice.  The second defn has no field-names; and then
-we get an error from Test { x=wat }, saying "Test has no field 'x'".
-
-Easiest thing is to bale out fast on duplicate definitions, which
-we do via `checkNoErrs` on `extendGlobalRdrEnvRn`.
-
-Note [Reporting duplicate local declarations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In general, a single module may not define the same OccName multiple times. This
-is checked in extendGlobalRdrEnvRn: when adding a new locally-defined GRE to the
-GlobalRdrEnv we report an error if there are already duplicates in the
-environment.  This establishes INVARIANT 1 (see comments on GlobalRdrEnv in
-GHC.Types.Name.Reader), which says that for a given OccName, all the
-GlobalRdrElts to which it maps must have distinct 'gre_name's.
-
-For example, the following will be rejected:
-
-  f x = x
-  g x = x
-  f x = x  -- Duplicate!
-
-Two GREs with the same OccName are OK iff:
--------------------------------------------------------------------
-  Existing GRE     |          Newly-defined GRE
-                   |  NormalGre            FieldGre
--------------------------------------------------------------------
-  Imported         |  Always               Always
-                   |
-  Local NormalGre  |  Never                NoFieldSelectors
-                   |
-  Local FieldGre   |  NoFieldSelectors     DuplicateRecordFields
-                   |                       and not in same record
--------------------------------------------------------------------            -
-In this table "NoFieldSelectors" means "NoFieldSelectors was enabled at the
-definition site of the fields; ditto "DuplicateRecordFields".  These facts are
-recorded in the 'FieldLabel' (but where both GREs are local, both will
-necessarily have the same extensions enabled).
-
-More precisely:
-
-* The programmer is allowed to make a new local definition that clashes with an
-  imported one (although attempting to refer to either may lead to ambiguity
-  errors at use sites).  For example, the following definition is allowed:
-
-    import M (f)
-    f x = x
-
-  Thus isDupGRE reports errors only if the existing GRE is a LocalDef.
-
-* When DuplicateRecordFields is enabled, the same field label may be defined in
-  multiple records. For example, this is allowed:
-
-    {-# LANGUAGE DuplicateRecordFields #-}
-    data S1 = MkS1 { f :: Int }
-    data S2 = MkS2 { f :: Int }
-
-  Even though both fields have the same OccName, this does not violate INVARIANT
-  1 of the GlobalRdrEnv, because the fields have distinct selector names, which
-  form part of the gre_name (see Note [GreNames] in GHC.Types.Name.Reader).
-
-* However, we must be careful to reject the following (#9156):
-
-    {-# LANGUAGE DuplicateRecordFields #-}
-    data T = MkT { f :: Int, f :: Int }  -- Duplicate!
-
-  In this case, both 'gre_name's are the same (because the fields belong to the
-  same type), and adding them both to the environment would be a violation of
-  INVARIANT 1. Thus isAllowedDup checks both GREs have distinct 'gre_name's
-  if they are both record fields.
-
-* With DuplicateRecordFields, we reject attempts to define a field and a
-  non-field with the same OccName (#17965):
-
-    {-# LANGUAGE DuplicateRecordFields #-}
-    f x = x
-    data T = MkT { f :: Int}
-
-  In principle this could be supported, but the current "specification" of
-  DuplicateRecordFields does not allow it. Thus isAllowedDup checks for
-  DuplicateRecordFields only if *both* GREs being compared are record fields.
-
-* However, with NoFieldSelectors, it is possible by design to define a field and
-  a non-field with the same OccName:
-
-    {-# LANGUAGE NoFieldSelectors #-}
-    f x = x
-    data T = MkT { f :: Int}
-
-  Thus isAllowedDup checks for NoFieldSelectors if either the existing or the
-  new GRE are record fields.  See Note [NoFieldSelectors] in GHC.Rename.Env.
-
-See also Note [Skipping ambiguity errors at use sites of local declarations] in
-GHC.Rename.Utils.
--}
-
-
-{- *********************************************************************
-*                                                                      *
-    getLocalDeclBindersd@ returns the names for an HsDecl
-             It's used for source code.
-
-        *** See Note [The Naming story] in GHC.Hs.Decls ****
-*                                                                      *
-********************************************************************* -}
-
-getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs
-    -> RnM ((TcGblEnv, TcLclEnv), NameSet)
--- Get all the top-level binders bound the group *except*
--- for value bindings, which are treated separately
--- Specifically we return AvailInfo for
---      * type decls (incl constructors and record selectors)
---      * class decls (including class ops)
---      * associated types
---      * foreign imports
---      * value signatures (in hs-boot files only)
-
-getLocalNonValBinders fixity_env
-     (HsGroup { hs_valds  = binds,
-                hs_tyclds = tycl_decls,
-                hs_fords  = foreign_decls })
-  = do  { -- Process all type/class decls *except* family instances
-        ; let inst_decls = tycl_decls >>= group_instds
-        ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags
-        ; has_sel <- xopt_FieldSelectors <$> getDynFlags
-        ; (tc_avails, tc_fldss)
-            <- fmap unzip $ mapM (new_tc dup_fields_ok has_sel)
-                                 (tyClGroupTyClDecls tycl_decls)
-        ; traceRn "getLocalNonValBinders 1" (ppr tc_avails)
-        ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
-        ; restoreEnvs envs $ do {
-            -- Bring these things into scope first
-            -- See Note [Looking up family names in family instances]
-
-          -- Process all family instances
-          -- to bring new data constructors into scope
-        ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc dup_fields_ok has_sel)
-                                                   inst_decls
-
-          -- Finish off with value binders:
-          --    foreign decls and pattern synonyms for an ordinary module
-          --    type sigs in case of a hs-boot file only
-        ; is_boot <- tcIsHsBootOrSig
-        ; let val_bndrs
-                | is_boot = case binds of
-                      ValBinds _ _val_binds val_sigs ->
-                          -- In a hs-boot file, the value binders come from the
-                          --  *signatures*, and there should be no foreign binders
-                          [ L (l2l decl_loc) (unLoc n)
-                          | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns]
-                      _ -> panic "Non-ValBinds in hs-boot group"
-                | otherwise = for_hs_bndrs
-        ; val_avails <- mapM new_simple val_bndrs
-
-        ; let avails    = concat nti_availss ++ val_avails
-              new_bndrs = availsToNameSetWithSelectors avails `unionNameSet`
-                          availsToNameSetWithSelectors tc_avails
-              flds      = concat nti_fldss ++ concat tc_fldss
-        ; traceRn "getLocalNonValBinders 2" (ppr avails)
-        ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env
-
-        -- Force the field access so that tcg_env is not retained. The
-        -- selector thunk optimisation doesn't kick-in, see #20139
-        ; let !old_field_env = tcg_field_env tcg_env
-        -- Extend tcg_field_env with new fields (this used to be the
-        -- work of extendRecordFieldEnv)
-              field_env = extendNameEnvList old_field_env flds
-              envs      = (tcg_env { tcg_field_env = field_env }, tcl_env)
-
-        ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])
-        ; return (envs, new_bndrs) } }
-  where
-    for_hs_bndrs :: [LocatedN RdrName]
-    for_hs_bndrs = hsForeignDeclsBinders foreign_decls
-
-      -- the SrcSpan attached to the input should be the span of the
-      -- declaration, not just the name
-    new_simple :: LocatedN RdrName -> RnM AvailInfo
-    new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name
-                            ; return (avail nm) }
-
-    new_tc :: DuplicateRecordFields -> FieldSelectors -> LTyClDecl GhcPs
-           -> RnM (AvailInfo, [(Name, [FieldLabel])])
-    new_tc dup_fields_ok has_sel tc_decl -- NOT for type/data instances
-        = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl
-             ; names@(main_name : sub_names) <- mapM (newTopSrcBinder . l2n) bndrs
-             ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds
-             ; let fld_env = case unLoc tc_decl of
-                     DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'
-                     _                            -> []
-             ; return (availTC main_name names flds', fld_env) }
-
-
-    -- Calculate the mapping from constructor names to fields, which
-    -- will go in tcg_field_env. It's convenient to do this here where
-    -- we are working with a single datatype definition.
-    mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel]
-               -> [(Name, [FieldLabel])]
-    mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)
-      where
-        find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr
-                                       , con_args = RecCon cdflds }))
-            = [( find_con_name rdr
-               , concatMap find_con_decl_flds (unLoc cdflds) )]
-        find_con_flds (L _ (ConDeclGADT { con_names = rdrs
-                                        , con_g_args = RecConGADT flds _ }))
-            = [ ( find_con_name rdr
-                 , concatMap find_con_decl_flds (unLoc flds))
-              | L _ rdr <- toList rdrs ]
-
-        find_con_flds _ = []
-
-        find_con_name rdr
-          = expectJust "getLocalNonValBinders/find_con_name" $
-              find (\ n -> nameOccName n == rdrNameOcc rdr) names
-        find_con_decl_flds (L _ x)
-          = map find_con_decl_fld (cd_fld_names x)
-
-        find_con_decl_fld  (L _ (FieldOcc _ (L _ rdr)))
-          = expectJust "getLocalNonValBinders/find_con_decl_fld" $
-              find (\ fl -> flLabel fl == lbl) flds
-          where lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr)
-
-    new_assoc :: DuplicateRecordFields -> FieldSelectors -> LInstDecl GhcPs
-              -> RnM ([AvailInfo], [(Name, [FieldLabel])])
-    new_assoc _ _ (L _ (TyFamInstD {})) = return ([], [])
-      -- type instances don't bind new names
-
-    new_assoc dup_fields_ok has_sel (L _ (DataFamInstD _ d))
-      = do { (avail, flds) <- new_di dup_fields_ok has_sel Nothing d
-           ; return ([avail], flds) }
-    new_assoc dup_fields_ok has_sel (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty
-                                                      , cid_datafam_insts = adts })))
-      = do -- First, attempt to grab the name of the class from the instance.
-           -- This step could fail if the instance is not headed by a class,
-           -- such as in the following examples:
-           --
-           -- (1) The class is headed by a bang pattern, such as in
-           --     `instance !Show Int` (#3811c)
-           -- (2) The class is headed by a type variable, such as in
-           --     `instance c` (#16385)
-           --
-           -- If looking up the class name fails, then mb_cls_nm will
-           -- be Nothing.
-           mb_cls_nm <- runMaybeT $ do
-             -- See (1) above
-             L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty
-             -- See (2) above
-             MaybeT $ setSrcSpan (locA loc) $ lookupGlobalOccRn_maybe cls_rdr
-           -- Assuming the previous step succeeded, process any associated data
-           -- family instances. If the previous step failed, bail out.
-           case mb_cls_nm of
-             Nothing -> pure ([], [])
-             Just cls_nm -> do
-               (avails, fldss)
-                 <- mapAndUnzipM (new_loc_di dup_fields_ok has_sel (Just cls_nm)) adts
-               pure (avails, concat fldss)
-
-    new_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> DataFamInstDecl GhcPs
-                   -> RnM (AvailInfo, [(Name, [FieldLabel])])
-    new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl })
-        = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl)
-             ; let (bndrs, flds) = hsDataFamInstBinders dfid
-             ; sub_names <- mapM (newTopSrcBinder .l2n) bndrs
-             ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds
-             ; let avail    = availTC (unLoc main_name) sub_names flds'
-                                  -- main_name is not bound here!
-                   fld_env  = mk_fld_env (feqn_rhs ti_decl) sub_names flds'
-             ; return (avail, fld_env) }
-
-    new_loc_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> LDataFamInstDecl GhcPs
-                   -> RnM (AvailInfo, [(Name, [FieldLabel])])
-    new_loc_di dup_fields_ok has_sel mb_cls (L _ d) = new_di dup_fields_ok has_sel mb_cls d
-
-newRecordSelector :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel
-newRecordSelector _ _ [] _ = error "newRecordSelector: datatype has no constructors!"
-newRecordSelector dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld)))
-  = do { selName <- newTopSrcBinder $ L (l2l loc) $ field
-       ; return $ FieldLabel { flLabel = fieldLabelString
-                             , flHasDuplicateRecordFields = dup_fields_ok
-                             , flHasFieldSelector = has_sel
-                             , flSelector = selName } }
-  where
-    fieldLabelString = FieldLabelString $ occNameFS $ rdrNameOcc fld
-    selOccName = fieldSelectorOccName fieldLabelString (nameOccName dc) dup_fields_ok has_sel
-    field | isExact fld = fld
-              -- use an Exact RdrName as is to preserve the bindings
-              -- of an already renamer-resolved field and its use
-              -- sites. This is needed to correctly support record
-              -- selectors in Template Haskell. See Note [Binders in
-              -- Template Haskell] in "GHC.ThToHs" and Note [Looking up
-              -- Exact RdrNames] in "GHC.Rename.Env".
-          | otherwise   = mkRdrUnqual selOccName
-
-{-
-Note [Looking up family names in family instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-  module M where
-    type family T a :: *
-    type instance M.T Int = Bool
-
-We might think that we can simply use 'lookupOccRn' when processing the type
-instance to look up 'M.T'.  Alas, we can't!  The type family declaration is in
-the *same* HsGroup as the type instance declaration.  Hence, as we are
-currently collecting the binders declared in that HsGroup, these binders will
-not have been added to the global environment yet.
-
-Solution is simple: process the type family declarations first, extend
-the environment, and then process the type instances.
-
-
-************************************************************************
-*                                                                      *
-\subsection{Filtering imports}
-*                                                                      *
-************************************************************************
-
-@filterImports@ takes the @ExportEnv@ telling what the imported module makes
-available, and filters it through the import spec (if any).
-
-Note [Dealing with imports]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For import M( ies ), we take the mi_exports of M, and make
-   imp_occ_env :: OccEnv (NameEnv (GreName, AvailInfo, Maybe Name))
-One entry for each OccName that M exports, mapping each corresponding Name to
-its GreName, the AvailInfo exported from M that exports that Name, and
-optionally a Name for an associated type's parent class. (Typically there will
-be a single Name in the NameEnv, but see Note [Importing DuplicateRecordFields]
-for why we may need more than one.)
-
-The situation is made more complicated by associated types. E.g.
-   module M where
-     class    C a    where { data T a }
-     instance C Int  where { data T Int = T1 | T2 }
-     instance C Bool where { data T Int = T3 }
-Then M's export_avails are (recall the AvailTC invariant from Avails.hs)
-  C(C,T), T(T,T1,T2,T3)
-Notice that T appears *twice*, once as a child and once as a parent. From
-this list we construct a raw list including
-   T -> (T, T( T1, T2, T3 ), Nothing)
-   T -> (T, C( C, T ),       Nothing)
-and we combine these (in function 'combine' in 'imp_occ_env' in
-'filterImports') to get
-   T  -> (T,  T(T,T1,T2,T3), Just C)
-
-So the overall imp_occ_env is
-   C  -> (C,  C(C,T),        Nothing)
-   T  -> (T,  T(T,T1,T2,T3), Just C)
-   T1 -> (T1, T(T,T1,T2,T3), Nothing)   -- similarly T2,T3
-
-If we say
-   import M( T(T1,T2) )
-then we get *two* Avails:  C(T), T(T1,T2)
-
-Note that the imp_occ_env will have entries for data constructors too,
-although we never look up data constructors.
-
-Note [Importing PatternSynonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As described in Note [Dealing with imports], associated types can lead to the
-same Name appearing twice, both as a child and once as a parent, when
-constructing the imp_occ_env.  The same thing can happen with pattern synonyms
-if they are exported bundled with a type.
-
-A simplified example, based on #11959:
-
-  {-# LANGUAGE PatternSynonyms #-}
-  module M (T(P), pattern P) where  -- Duplicate export warning, but allowed
-    data T = MkT
-    pattern P = MkT
-
-Here we have T(P) and P in export_avails, and construct both
-  P -> (P, P, Nothing)
-  P -> (P, T(P), Nothing)
-which are 'combine'd to leave
-  P -> (P, T(P), Nothing)
-i.e. we simply discard the non-bundled Avail.
-
-Note [Importing DuplicateRecordFields]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In filterImports, another complicating factor is DuplicateRecordFields.
-Suppose we have:
-
-  {-# LANGUAGE DuplicateRecordFields #-}
-  module M (S(foo), T(foo)) where
-    data S = MkS { foo :: Int }
-    data T = mkT { foo :: Int }
-
-  module N where
-    import M (foo)    -- this is allowed (A)
-    import M (S(foo)) -- this is allowed (B)
-
-Here M exports the OccName 'foo' twice, so we get an imp_occ_env where 'foo'
-maps to a NameEnv containing an entry for each of the two mangled field selector
-names (see Note [FieldLabel] in GHC.Types.FieldLabel).
-
-  foo -> [ $sel:foo:MkS -> (foo, S(foo), Nothing)
-         , $sel:foo:MKT -> (foo, T(foo), Nothing)
-         ]
-
-Then when we look up 'foo' in lookup_names for case (A) we get both entries and
-hence two Avails.  Whereas in case (B) we reach the lookup_ie
-case for IEThingWith, which looks up 'S' and then finds the unique 'foo' amongst
-its children.
-
-See T16745 for a test of this.
-
--}
-
-filterImports
-    :: ModIface
-    -> ImpDeclSpec                     -- The span for the entire import decl
-    -> Maybe (ImportListInterpretation, LocatedL [LIE GhcPs])    -- Import spec; True => hiding
-    -> RnM (Maybe (ImportListInterpretation, LocatedL [LIE GhcRn]), -- Import spec w/ Names
-            [GlobalRdrElt])                   -- Same again, but in GRE form
-filterImports iface decl_spec Nothing
-  = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface))
-  where
-    imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }
-
-
-filterImports iface decl_spec (Just (want_hiding, L l import_items))
-  = do  -- check for errors, convert RdrNames to Names
-        items1 <- mapM lookup_lie import_items
-
-        let items2 :: [(LIE GhcRn, AvailInfo)]
-            items2 = concat items1
-                -- NB the AvailInfo may have duplicates, and several items
-                --    for the same parent; e.g N(x) and N(y)
-
-            names  = availsToNameSetWithSelectors (map snd items2)
-            keep n = not (n `elemNameSet` names)
-            pruned_avails = filterAvails keep all_avails
-            hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }
-
-            gres | want_hiding == EverythingBut = gresFromAvails (Just hiding_spec) pruned_avails
-                 | otherwise = concatMap (gresFromIE decl_spec) items2
-
-        return (Just (want_hiding, L l (map fst items2)), gres)
-  where
-    all_avails = mi_exports iface
-
-        -- See Note [Dealing with imports]
-    imp_occ_env :: OccEnv (NameEnv (GreName,    -- the name or field
-                           AvailInfo,   -- the export item providing it
-                           Maybe Name))   -- the parent of associated types
-    imp_occ_env = mkOccEnv_C (plusNameEnv_C combine)
-                             [ (occName c, mkNameEnv [(greNameMangledName c, (c, a, Nothing))])
-                                     | a <- all_avails
-                                     , c <- availGreNames a]
-    -- See Note [Dealing with imports]
-    -- 'combine' may be called for associated data types which appear
-    -- twice in the all_avails. In the example, we combine
-    --    T(T,T1,T2,T3) and C(C,T)  to give   (T, T(T,T1,T2,T3), Just C)
-    -- NB: the AvailTC can have fields as well as data constructors (#12127)
-    combine :: (GreName, AvailInfo, Maybe Name)
-            -> (GreName, AvailInfo, Maybe Name)
-            -> (GreName, AvailInfo, Maybe Name)
-    combine (NormalGreName name1, a1@(AvailTC p1 _), mb1)
-            (NormalGreName name2, a2@(AvailTC p2 _), mb2)
-      = assertPpr (name1 == name2 && isNothing mb1 && isNothing mb2)
-                  (ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2) $
-        if p1 == name1 then (NormalGreName name1, a1, Just p2)
-                       else (NormalGreName name1, a2, Just p1)
-    -- 'combine' may also be called for pattern synonyms which appear both
-    -- unassociated and associated (see Note [Importing PatternSynonyms]).
-    combine (c1, a1, mb1) (c2, a2, mb2)
-      = assertPpr (c1 == c2 && isNothing mb1 && isNothing mb2
-                          && (isAvailTC a1 || isAvailTC a2))
-                  (ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2) $
-        if isAvailTC a1 then (c1, a1, Nothing)
-                        else (c1, a2, Nothing)
-
-    isAvailTC AvailTC{} = True
-    isAvailTC _ = False
-
-    -- Look up a RdrName used in an import, failing if it is ambiguous
-    -- (e.g. because it refers to multiple record fields)
-    lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name)
-    lookup_name ie rdr = do
-        xs <- lookup_names ie rdr
-        case xs of
-          [cax] -> return cax
-          _     -> failLookupWith (AmbiguousImport rdr (map sndOf3 xs))
-
-    -- Look up a RdrName used in an import, returning multiple values if there
-    -- are several fields with the same name exposed by the module
-    lookup_names :: IE GhcPs -> RdrName -> IELookupM [(Name, AvailInfo, Maybe Name)]
-    lookup_names ie rdr
-       | isQual rdr              = failLookupWith (QualImportError rdr)
-       | Just succ <- mb_success = return $ map (\ (c,a,x) -> (greNameMangledName c, a, x)) (nonDetNameEnvElts succ)
-       | otherwise               = failLookupWith (BadImport ie)
-      where
-        mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr)
-
-    lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)]
-    lookup_lie (L loc ieRdr)
-        = do (stuff, warns) <- setSrcSpanA loc $
-                               liftM (fromMaybe ([],[])) $
-                               run_lookup (lookup_ie ieRdr)
-             mapM_ emit_warning warns
-             return [ (L loc ie, avail) | (ie,avail) <- stuff ]
-        where
-            -- Warn when importing T(..) if T was exported abstractly
-            emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $
-              addTcRnDiagnostic (TcRnDodgyImports n)
-            emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $
-              addTcRnDiagnostic (TcRnMissingImportList ieRdr)
-            emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $ do
-              let msg = mkTcRnUnknownMessage $
-                    mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyImports)
-                                      noHints
-                                      (lookup_err_msg (BadImport ie))
-              addDiagnostic msg
-
-            run_lookup :: IELookupM a -> TcRn (Maybe a)
-            run_lookup m = case m of
-              Failed err -> do
-                addErr $ mkTcRnUnknownMessage $ mkPlainError noHints (lookup_err_msg err)
-                return Nothing
-              Succeeded a -> return (Just a)
-
-            lookup_err_msg err = case err of
-              BadImport ie  -> badImportItemErr iface decl_spec ie all_avails
-              IllegalImport -> illegalImportItemErr
-              QualImportError rdr -> qualImportItemErr rdr
-              AmbiguousImport rdr xs -> ambiguousImportItemErr rdr xs
-
-        -- For each import item, we convert its RdrNames to Names,
-        -- and at the same time construct an AvailInfo corresponding
-        -- to what is actually imported by this item.
-        -- Returns Nothing on error.
-        -- We return a list here, because in the case of an import
-        -- item like C, if we are hiding, then C refers to *both* a
-        -- type/class and a data constructor.  Moreover, when we import
-        -- data constructors of an associated family, we need separate
-        -- AvailInfos for the data constructors and the family (as they have
-        -- different parents).  See Note [Dealing with imports]
-    lookup_ie :: IE GhcPs
-              -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning])
-    lookup_ie ie = handle_bad_import $
-      case ie of
-        IEVar _ (L l n) -> do
-            -- See Note [Importing DuplicateRecordFields]
-            xs <- lookup_names ie (ieWrappedName n)
-            return ([(IEVar noExtField (L l (replaceWrappedName n name)),
-                                                  trimAvail avail name)
-                    | (name, avail, _) <- xs ], [])
-
-        IEThingAll _ (L l tc) -> do
-            (name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc
-            let warns = case avail of
-                          Avail {}                     -- e.g. f(..)
-                            -> [DodgyImport $ ieWrappedName tc]
-
-                          AvailTC _ subs
-                            | null (drop 1 subs) -- e.g. T(..) where T is a synonym
-                            -> [DodgyImport $ ieWrappedName tc]
-
-                            | not (is_qual decl_spec)  -- e.g. import M( T(..) )
-                            -> [MissingImportList]
-
-                            | otherwise
-                            -> []
-
-                renamed_ie = IEThingAll noAnn (L l (replaceWrappedName tc name))
-                sub_avails = case avail of
-                               Avail {}           -> []
-                               AvailTC name2 subs -> [(renamed_ie, AvailTC name2 (subs \\ [NormalGreName name]))]
-            case mb_parent of
-              Nothing     -> return ([(renamed_ie, avail)], warns)
-                             -- non-associated ty/cls
-              Just parent -> return ((renamed_ie, AvailTC parent [NormalGreName name]) : sub_avails, warns)
-                             -- associated type
-
-        IEThingAbs _ (L l tc')
-            | want_hiding == EverythingBut   -- hiding ( C )
-                       -- Here the 'C' can be a data constructor
-                       --  *or* a type/class, or even both
-            -> let tc = ieWrappedName tc'
-                   tc_name = lookup_name ie tc
-                   dc_name = lookup_name ie (setRdrNameSpace tc srcDataName)
-               in
-               case catIELookupM [ tc_name, dc_name ] of
-                 []    -> failLookupWith (BadImport ie)
-                 names -> return ([mkIEThingAbs tc' l name | name <- names], [])
-            | otherwise
-            -> do nameAvail <- lookup_name ie (ieWrappedName tc')
-                  return ([mkIEThingAbs tc' l nameAvail]
-                         , [])
-
-        IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns -> do
-           (name, avail, mb_parent)
-               <- lookup_name (IEThingAbs noAnn ltc) (ieWrappedName rdr_tc)
-
-           -- Look up the children in the sub-names of the parent
-           -- See Note [Importing DuplicateRecordFields]
-           let subnames = availSubordinateGreNames avail
-           case lookupChildren subnames rdr_ns of
-
-             Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs))
-                                -- We are trying to import T( a,b,c,d ), and failed
-                                -- to find 'b' and 'd'.  So we make up an import item
-                                -- to report as failing, namely T( b, d ).
-                                -- c.f. #15412
-
-             Succeeded (childnames, childflds) ->
-               case mb_parent of
-                 -- non-associated ty/cls
-                 Nothing
-                   -> return ([(IEThingWith childflds (L l name') wc childnames',
-                               availTC name (name:map unLoc childnames) (map unLoc childflds))],
-                              [])
-                   where name' = replaceWrappedName rdr_tc name
-                         childnames' = map to_ie_post_rn childnames
-                         -- childnames' = postrn_ies childnames
-                 -- associated ty
-                 Just parent
-                   -> return ([(IEThingWith childflds (L l name') wc childnames',
-                                availTC name (map unLoc childnames) (map unLoc childflds)),
-                               (IEThingWith childflds (L l name') wc childnames',
-                                availTC parent [name] [])],
-                              [])
-                   where name' = replaceWrappedName rdr_tc name
-                         childnames' = map to_ie_post_rn childnames
-
-        _other -> failLookupWith IllegalImport
-        -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed
-        -- all errors.
-
-      where
-        mkIEThingAbs tc l (n, av, Nothing    )
-          = (IEThingAbs noAnn (L l (replaceWrappedName tc n)), trimAvail av n)
-        mkIEThingAbs tc l (n, _,  Just parent)
-          = (IEThingAbs noAnn (L l (replaceWrappedName tc n))
-             , availTC parent [n] [])
-
-        handle_bad_import m = catchIELookup m $ \err -> case err of
-          BadImport ie | want_hiding == EverythingBut -> return ([], [BadImportW ie])
-          _ -> failLookupWith err
-
-type IELookupM = MaybeErr IELookupError
-
-data IELookupWarning
-  = BadImportW (IE GhcPs)
-  | MissingImportList
-  | DodgyImport RdrName
-  -- NB. use the RdrName for reporting a "dodgy" import
-
-data IELookupError
-  = QualImportError RdrName
-  | BadImport (IE GhcPs)
-  | IllegalImport
-  | AmbiguousImport RdrName [AvailInfo] -- e.g. a duplicated field name as a top-level import
-
-failLookupWith :: IELookupError -> IELookupM a
-failLookupWith err = Failed err
-
-catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a
-catchIELookup m h = case m of
-  Succeeded r -> return r
-  Failed err  -> h err
-
-catIELookupM :: [IELookupM a] -> [a]
-catIELookupM ms = [ a | Succeeded a <- ms ]
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Import/Export Utils}
-*                                                                      *
-************************************************************************
--}
-
--- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's.
-gresFromIE :: ImpDeclSpec -> (LIE GhcRn, AvailInfo) -> [GlobalRdrElt]
-gresFromIE decl_spec (L loc ie, avail)
-  = gresFromAvail prov_fn avail
-  where
-    is_explicit = case ie of
-                    IEThingAll _ name -> \n -> n == lieWrappedName name
-                    _                 -> \_ -> True
-    prov_fn name
-      = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec })
-      where
-        item_spec = ImpSome { is_explicit = is_explicit name
-                            , is_iloc = locA loc }
-
-
-{-
-Note [Children for duplicate record fields]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider the module
-
-    {-# LANGUAGE DuplicateRecordFields #-}
-    module M (F(foo, MkFInt, MkFBool)) where
-      data family F a
-      data instance F Int = MkFInt { foo :: Int }
-      data instance F Bool = MkFBool { foo :: Bool }
-
-The `foo` in the export list refers to *both* selectors! For this
-reason, lookupChildren builds an environment that maps the FastString
-to a list of items, rather than a single item.
--}
-
-mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt]
-mkChildEnv gres = foldr add emptyNameEnv gres
-  where
-    add gre env = case gre_par gre of
-        ParentIs  p -> extendNameEnv_Acc (:) Utils.singleton env p gre
-        NoParent    -> env
-
-findChildren :: NameEnv [a] -> Name -> [a]
-findChildren env n = lookupNameEnv env n `orElse` []
-
-lookupChildren :: [GreName] -> [LIEWrappedName GhcPs]
-               -> MaybeErr [LIEWrappedName GhcPs]   -- The ones for which the lookup failed
-                           ([LocatedA Name], [Located FieldLabel])
--- (lookupChildren all_kids rdr_items) maps each rdr_item to its
--- corresponding Name all_kids, if the former exists
--- The matching is done by FastString, not OccName, so that
---    Cls( meth, AssocTy )
--- will correctly find AssocTy among the all_kids of Cls, even though
--- the RdrName for AssocTy may have a (bogus) DataName namespace
--- (Really the rdr_items should be FastStrings in the first place.)
-lookupChildren all_kids rdr_items
-  | null fails
-  = Succeeded (fmap concat (partitionEithers oks))
-       -- This 'fmap concat' trickily applies concat to the /second/ component
-       -- of the pair, whose type is ([LocatedA Name], [[Located FieldLabel]])
-  | otherwise
-  = Failed fails
-  where
-    mb_xs = map doOne rdr_items
-    fails = [ bad_rdr | Failed bad_rdr <- mb_xs ]
-    oks   = [ ok      | Succeeded ok   <- mb_xs ]
-    oks :: [Either (LocatedA Name) [Located FieldLabel]]
-
-    doOne item@(L l r)
-       = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of
-           Just [NormalGreName n]                             -> Succeeded (Left (L l n))
-           Just rs | Just fs <- traverse greNameFieldLabel rs -> Succeeded (Right (map (L (locA l)) fs))
-           _                                                  -> Failed    item
-
-    -- See Note [Children for duplicate record fields]
-    kid_env = extendFsEnvList_C (++) emptyFsEnv
-              [(occNameFS (occName x), [x]) | x <- all_kids]
-
-
-
--------------------------------
-
-{-
-*********************************************************
-*                                                       *
-\subsection{Unused names}
-*                                                       *
-*********************************************************
--}
-
-reportUnusedNames :: TcGblEnv -> HscSource -> RnM ()
-reportUnusedNames gbl_env hsc_src
-  = do  { keep <- readTcRef (tcg_keep gbl_env)
-        ; traceRn "RUN" (ppr (tcg_dus gbl_env))
-        ; warnUnusedImportDecls gbl_env hsc_src
-        ; warnUnusedTopBinds $ unused_locals keep
-        ; warnMissingSignatures gbl_env
-        ; warnMissingKindSignatures gbl_env }
-  where
-    used_names :: NameSet -> NameSet
-    used_names keep = findUses (tcg_dus gbl_env) emptyNameSet `unionNameSet` keep
-    -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used
-    -- Hence findUses
-
-    -- Collect the defined names from the in-scope environment
-    defined_names :: [GlobalRdrElt]
-    defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env)
-
-    kids_env = mkChildEnv defined_names
-    -- This is done in mkExports too; duplicated work
-
-    gre_is_used :: NameSet -> GlobalRdrElt -> Bool
-    gre_is_used used_names gre0
-        = name `elemNameSet` used_names
-          || any (\ gre -> greMangledName gre `elemNameSet` used_names) (findChildren kids_env name)
-                -- A use of C implies a use of T,
-                -- if C was brought into scope by T(..) or T(C)
-      where
-        name = greMangledName gre0
-
-    -- Filter out the ones that are
-    --  (a) defined in this module, and
-    --  (b) not defined by a 'deriving' clause
-    -- The latter have an Internal Name, so we can filter them out easily
-    unused_locals :: NameSet -> [GlobalRdrElt]
-    unused_locals keep =
-      let -- Note that defined_and_used, defined_but_not_used
-          -- are both [GRE]; that's why we need defined_and_used
-          -- rather than just used_names
-          _defined_and_used, defined_but_not_used :: [GlobalRdrElt]
-          (_defined_and_used, defined_but_not_used)
-              = partition (gre_is_used (used_names keep)) defined_names
-
-      in filter is_unused_local defined_but_not_used
-    is_unused_local :: GlobalRdrElt -> Bool
-    is_unused_local gre = isLocalGRE gre && isExternalName (greMangledName gre)
-
-{- *********************************************************************
-*                                                                      *
-              Missing signatures
-*                                                                      *
-********************************************************************* -}
-
-{-
-Note [Missing signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-There are four warning flags in play:
-
-  * -Wmissing-exported-signatures
-    Warn about any exported top-level function/value without a type signature.
-    Does not include pattern synonyms.
-
-  * -Wmissing-signatures
-    Warn about any top-level function/value without a type signature. Does not
-    include pattern synonyms. Takes priority over -Wmissing-exported-signatures.
-
-  * -Wmissing-exported-pattern-synonym-signatures
-    Warn about any exported pattern synonym without a type signature.
-
-  * -Wmissing-pattern-synonym-signatures
-    Warn about any pattern synonym without a type signature. Takes priority over
-    -Wmissing-exported-pattern-synonym-signatures.
-
--}
-
--- | Warn the user about top level binders that lack type signatures.
--- Called /after/ type inference, so that we can report the
--- inferred type of the function
-warnMissingSignatures :: TcGblEnv -> RnM ()
-warnMissingSignatures gbl_env
-  = do { warn_binds    <- woptM Opt_WarnMissingSignatures
-       ; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures
-       ; let exports = availsToNameSet (tcg_exports gbl_env)
-             sig_ns  = tcg_sigs gbl_env
-               -- We use sig_ns to exclude top-level bindings that are generated by GHC
-             binds    = collectHsBindsBinders CollNoDictBinders $ tcg_binds gbl_env
-             pat_syns = tcg_patsyns gbl_env
-
-             not_ghc_generated :: Name -> Bool
-             not_ghc_generated name = name `elemNameSet` sig_ns
-
-             add_binding_warn :: Id -> RnM ()
-             add_binding_warn id =
-               when (not_ghc_generated name) $
-               do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv?
-                  ; let (_, ty) = tidyOpenType env (idType id)
-                        missing = MissingTopLevelBindingSig name ty
-                        diag = TcRnMissingSignature missing exported warn_binds
-                  ; addDiagnosticAt (getSrcSpan name) diag }
-               where
-                 name = idName id
-                 exported = if name `elemNameSet` exports
-                            then IsExported
-                            else IsNotExported
-
-             add_patsyn_warn :: PatSyn -> RnM ()
-             add_patsyn_warn ps =
-               when (not_ghc_generated name) $
-                 addDiagnosticAt (getSrcSpan name)
-                  (TcRnMissingSignature missing exported warn_pat_syns)
-               where
-                 name = patSynName ps
-                 missing = MissingPatSynSig ps
-                 exported = if name `elemNameSet` exports
-                            then IsExported
-                            else IsNotExported
-
-         -- Warn about missing signatures
-         -- Do this only when we have a type to offer
-         -- See Note [Missing signatures]
-       ; mapM_ add_binding_warn binds
-       ; mapM_ add_patsyn_warn  pat_syns
-       }
-
--- | Warn the user about tycons that lack kind signatures.
--- Called /after/ type (and kind) inference, so that we can report the
--- inferred kinds.
-warnMissingKindSignatures :: TcGblEnv -> RnM ()
-warnMissingKindSignatures gbl_env
-  = do { cusks_enabled <- xoptM LangExt.CUSKs
-       ; mapM_ (add_ty_warn cusks_enabled) tcs
-       }
-  where
-    tcs = tcg_tcs gbl_env
-    ksig_ns = tcg_ksigs gbl_env
-    exports = availsToNameSet (tcg_exports gbl_env)
-    not_ghc_generated :: Name -> Bool
-    not_ghc_generated name = name `elemNameSet` ksig_ns
-
-    add_ty_warn :: Bool -> TyCon -> RnM ()
-    add_ty_warn cusks_enabled tyCon =
-      when (not_ghc_generated name) $
-        addDiagnosticAt (getSrcSpan name) diag
-      where
-        name = tyConName tyCon
-        diag = TcRnMissingSignature missing exported False
-        missing = MissingTyConKindSig tyCon cusks_enabled
-        exported = if name `elemNameSet` exports
-                   then IsExported
-                   else IsNotExported
-
-{-
-*********************************************************
-*                                                       *
-\subsection{Unused imports}
-*                                                       *
-*********************************************************
-
-This code finds which import declarations are unused.  The
-specification and implementation notes are here:
-  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports
-
-See also Note [Choosing the best import declaration] in GHC.Types.Name.Reader
--}
-
-type ImportDeclUsage
-   = ( LImportDecl GhcRn   -- The import declaration
-     , [GlobalRdrElt]      -- What *is* used (normalised)
-     , [Name] )            -- What is imported but *not* used
-
-warnUnusedImportDecls :: TcGblEnv -> HscSource -> RnM ()
-warnUnusedImportDecls gbl_env hsc_src
-  = do { uses <- readMutVar (tcg_used_gres gbl_env)
-       ; let user_imports = filterOut
-                              (ideclImplicit . ideclExt . unLoc)
-                              (tcg_rn_imports gbl_env)
-                -- This whole function deals only with *user* imports
-                -- both for warning about unnecessary ones, and for
-                -- deciding the minimal ones
-             rdr_env = tcg_rdr_env gbl_env
-             fld_env = mkFieldEnv rdr_env
-
-       ; let usage :: [ImportDeclUsage]
-             usage = findImportUsage user_imports uses
-
-       ; traceRn "warnUnusedImportDecls" $
-                       (vcat [ text "Uses:" <+> ppr uses
-                             , text "Import usage" <+> ppr usage])
-
-       ; whenWOptM Opt_WarnUnusedImports $
-         mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage
-
-       ; whenGOptM Opt_D_dump_minimal_imports $
-         printMinimalImports hsc_src usage }
-
-findImportUsage :: [LImportDecl GhcRn]
-                -> [GlobalRdrElt]
-                -> [ImportDeclUsage]
-
-findImportUsage imports used_gres
-  = map unused_decl imports
-  where
-    import_usage :: ImportMap
-    import_usage = mkImportMap used_gres
-
-    unused_decl :: LImportDecl GhcRn -> (LImportDecl GhcRn, [GlobalRdrElt], [Name])
-    unused_decl decl@(L loc (ImportDecl { ideclImportList = imps }))
-      = (decl, used_gres, nameSetElemsStable unused_imps)
-      where
-        used_gres = lookupSrcLoc (srcSpanEnd $ locA loc) import_usage
-                               -- srcSpanEnd: see Note [The ImportMap]
-                    `orElse` []
-
-        used_names   = mkNameSet (map      greMangledName        used_gres)
-        used_parents = mkNameSet (mapMaybe greParent_maybe used_gres)
-
-        unused_imps   -- Not trivial; see eg #7454
-          = case imps of
-              Just (Exactly, L _ imp_ies) ->
-                                 foldr (add_unused . unLoc) emptyNameSet imp_ies
-              _other -> emptyNameSet -- No explicit import list => no unused-name list
-
-        add_unused :: IE GhcRn -> NameSet -> NameSet
-        add_unused (IEVar _ n)      acc = add_unused_name (lieWrappedName n) acc
-        add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc
-        add_unused (IEThingAll _ n) acc = add_unused_all  (lieWrappedName n) acc
-        add_unused (IEThingWith fs p wc ns) acc =
-          add_wc_all (add_unused_with pn xs acc)
-          where pn = lieWrappedName p
-                xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs
-                add_wc_all = case wc of
-                            NoIEWildcard -> id
-                            IEWildcard _ -> add_unused_all pn
-        add_unused _ acc = acc
-
-        add_unused_name n acc
-          | n `elemNameSet` used_names = acc
-          | otherwise                  = acc `extendNameSet` n
-        add_unused_all n acc
-          | n `elemNameSet` used_names   = acc
-          | n `elemNameSet` used_parents = acc
-          | otherwise                    = acc `extendNameSet` n
-        add_unused_with p ns acc
-          | all (`elemNameSet` acc1) ns = add_unused_name p acc1
-          | otherwise = acc1
-          where
-            acc1 = foldr add_unused_name acc ns
-       -- If you use 'signum' from Num, then the user may well have
-       -- imported Num(signum).  We don't want to complain that
-       -- Num is not itself mentioned.  Hence the two cases in add_unused_with.
-
-
-{- Note [The ImportMap]
-~~~~~~~~~~~~~~~~~~~~~~~
-The ImportMap is a short-lived intermediate data structure records, for
-each import declaration, what stuff brought into scope by that
-declaration is actually used in the module.
-
-The SrcLoc is the location of the END of a particular 'import'
-declaration.  Why *END*?  Because we don't want to get confused
-by the implicit Prelude import. Consider (#7476) the module
-    import Foo( foo )
-    main = print foo
-There is an implicit 'import Prelude(print)', and it gets a SrcSpan
-of line 1:1 (just the point, not a span). If we use the *START* of
-the SrcSpan to identify the import decl, we'll confuse the implicit
-import Prelude with the explicit 'import Foo'.  So we use the END.
-It's just a cheap hack; we could equally well use the Span too.
-
-The [GlobalRdrElt] are the things imported from that decl.
--}
-
-type ImportMap = Map RealSrcLoc [GlobalRdrElt]  -- See [The ImportMap]
-     -- If loc :-> gres, then
-     --   'loc' = the end loc of the bestImport of each GRE in 'gres'
-
-mkImportMap :: [GlobalRdrElt] -> ImportMap
--- For each of a list of used GREs, find all the import decls that brought
--- it into scope; choose one of them (bestImport), and record
--- the RdrName in that import decl's entry in the ImportMap
-mkImportMap gres
-  = foldr add_one Map.empty gres
-  where
-    add_one gre@(GRE { gre_imp = imp_specs }) imp_map =
-      case srcSpanEnd (is_dloc (is_decl best_imp_spec)) of
-                              -- For srcSpanEnd see Note [The ImportMap]
-       RealSrcLoc decl_loc _ -> Map.insertWith add decl_loc [gre] imp_map
-       UnhelpfulLoc _ -> imp_map
-       where
-          best_imp_spec = bestImport (bagToList imp_specs)
-          add _ gres = gre : gres
-
-warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Parent)
-                 -> ImportDeclUsage -> RnM ()
-warnUnusedImport flag fld_env (L loc decl, used, unused)
-
-  -- Do not warn for 'import M()'
-  | Just (Exactly, L _ []) <- ideclImportList decl
-  = return ()
-
-  -- Note [Do not warn about Prelude hiding]
-  | Just (EverythingBut, L _ hides) <- ideclImportList decl
-  , not (null hides)
-  , pRELUDE_NAME == unLoc (ideclName decl)
-  = return ()
-
-  -- Nothing used; drop entire declaration
-  | null used
-  = let dia = mkTcRnUnknownMessage $
-          mkPlainDiagnostic (WarningWithFlag flag) noHints msg1
-    in addDiagnosticAt (locA loc) dia
-
-  -- Everything imported is used; nop
-  | null unused
-  = return ()
-
-  -- Only one import is unused, with `SrcSpan` covering only the unused item instead of
-  -- the whole import statement
-  | Just (_, L _ imports) <- ideclImportList decl
-  , length unused == 1
-  , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports
-  = let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2
-    in addDiagnosticAt (locA loc) dia
-
-  -- Some imports are unused
-  | otherwise
-  = let dia = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2
-    in addDiagnosticAt (locA loc) dia
-
-  where
-    msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant
-                , nest 2 (text "except perhaps to import instances from"
-                                   <+> quotes pp_mod)
-                , text "To import instances alone, use:"
-                                   <+> text "import" <+> pp_mod <> parens Outputable.empty ]
-    msg2 = sep [ pp_herald <+> quotes sort_unused
-               , text "from module" <+> quotes pp_mod <+> is_redundant]
-    pp_herald  = text "The" <+> pp_qual <+> text "import of"
-    pp_qual
-      | isImportDeclQualified (ideclQualified decl)= text "qualified"
-      | otherwise                                  = Outputable.empty
-    pp_mod       = ppr (unLoc (ideclName decl))
-    is_redundant = text "is redundant"
-
-    -- In warning message, pretty-print identifiers unqualified unconditionally
-    -- to improve the consistent for ambiguous/unambiguous identifiers.
-    -- See trac#14881.
-    ppr_possible_field n = case lookupNameEnv fld_env n of
-                               Just (fld, ParentIs p) -> pprNameUnqualified p <> parens (ppr fld)
-                               Just (fld, NoParent)   -> ppr fld
-                               Nothing                -> pprNameUnqualified n
-
-    -- Print unused names in a deterministic (lexicographic) order
-    sort_unused :: SDoc
-    sort_unused = pprWithCommas ppr_possible_field $
-                  sortBy (comparing nameOccName) unused
-
-{-
-Note [Do not warn about Prelude hiding]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not warn about
-   import Prelude hiding( x, y )
-because even if nothing else from Prelude is used, it may be essential to hide
-x,y to avoid name-shadowing warnings.  Example (#9061)
-   import Prelude hiding( log )
-   f x = log where log = ()
-
-
-
-Note [Printing minimal imports]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-To print the minimal imports we walk over the user-supplied import
-decls, and simply trim their import lists.  NB that
-
-  * We do *not* change the 'qualified' or 'as' parts!
-
-  * We do not discard a decl altogether; we might need instances
-    from it.  Instead we just trim to an empty import list
--}
-
-getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn]
-getMinimalImports = fmap combine . mapM mk_minimal
-  where
-    mk_minimal (L l decl, used_gres, unused)
-      | null unused
-      , Just (Exactly, _) <- ideclImportList decl
-      = return (L l decl)
-      | otherwise
-      = do { let ImportDecl { ideclName    = L _ mod_name
-                            , ideclSource  = is_boot
-                            , ideclPkgQual = pkg_qual } = decl
-           ; iface <- loadSrcInterface doc mod_name is_boot pkg_qual
-           ; let used_avails = gresToAvailInfo used_gres
-                 lies = map (L l) (concatMap (to_ie iface) used_avails)
-           ; return (L l (decl { ideclImportList = Just (Exactly, L (l2l l) lies) })) }
-      where
-        doc = text "Compute minimal imports for" <+> ppr decl
-
-    to_ie :: ModIface -> AvailInfo -> [IE GhcRn]
-    -- The main trick here is that if we're importing all the constructors
-    -- we want to say "T(..)", but if we're importing only a subset we want
-    -- to say "T(A,B,C)".  So we have to find out what the module exports.
-    to_ie _ (Avail c)  -- Note [Overloaded field import]
-       = [IEVar noExtField (to_ie_post_rn $ noLocA (greNamePrintableName c))]
-    to_ie _ avail@(AvailTC n [_])  -- Exporting the main decl and nothing else
-       | availExportsDecl avail = [IEThingAbs noAnn (to_ie_post_rn $ noLocA n)]
-    to_ie iface (AvailTC n cs)
-      = case [xs | avail@(AvailTC x xs) <- mi_exports iface
-                 , x == n
-                 , availExportsDecl avail  -- Note [Partial export]
-                 ] of
-           [xs] | all_used xs ->
-                   [IEThingAll noAnn (to_ie_post_rn $ noLocA n)]
-                | otherwise   ->
-                   [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLocA n) NoIEWildcard
-                                (map (to_ie_post_rn . noLocA) (filter (/= n) ns))]
-                                          -- Note [Overloaded field import]
-           _other | all_non_overloaded fs
-                           -> map (IEVar noExtField . to_ie_post_rn_var . noLocA) $ ns
-                                 ++ map flSelector fs
-                  | otherwise ->
-                      [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLocA n) NoIEWildcard
-                                (map (to_ie_post_rn . noLocA) (filter (/= n) ns))]
-        where
-          (ns, fs) = partitionGreNames cs
-
-          all_used avail_cs = all (`elem` cs) avail_cs
-
-          all_non_overloaded = all (not . flIsOverloaded)
-
-    combine :: [LImportDecl GhcRn] -> [LImportDecl GhcRn]
-    combine = map merge . NE.groupAllWith getKey
-
-    getKey :: LImportDecl GhcRn -> (Bool, Maybe ModuleName, ModuleName)
-    getKey decl =
-      ( isImportDeclQualified . ideclQualified $ idecl -- is this qualified? (important that this be first)
-      , unLoc <$> ideclAs idecl -- what is the qualifier (inside Maybe monad)
-      , unLoc . ideclName $ idecl -- Module Name
-      )
-      where
-        idecl :: ImportDecl GhcRn
-        idecl = unLoc decl
-
-    merge :: NonEmpty (LImportDecl GhcRn) -> LImportDecl GhcRn
-    merge decls@((L l decl) :| _) = L l (decl { ideclImportList = Just (Exactly, L (noAnnSrcSpan (locA l)) lies) })
-      where lies = concatMap (unLoc . snd) $ mapMaybe (ideclImportList . unLoc) $ NE.toList decls
-
-
-printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM ()
--- See Note [Printing minimal imports]
-printMinimalImports hsc_src imports_w_usage
-  = do { imports' <- getMinimalImports imports_w_usage
-       ; this_mod <- getModule
-       ; dflags   <- getDynFlags
-       ; liftIO $ withFile (mkFilename dflags this_mod) WriteMode $ \h ->
-          printForUser dflags h neverQualify AllTheWay (vcat (map ppr imports'))
-              -- The neverQualify is important.  We are printing Names
-              -- but they are in the context of an 'import' decl, and
-              -- we never qualify things inside there
-              -- E.g.   import Blag( f, b )
-              -- not    import Blag( Blag.f, Blag.g )!
-       }
-  where
-    mkFilename dflags this_mod
-      | Just d <- dumpDir dflags = d </> basefn
-      | otherwise                = basefn
-      where
-        suffix = case hsc_src of
-                     HsBootFile -> ".imports-boot"
-                     HsSrcFile  -> ".imports"
-                     HsigFile   -> ".imports"
-        basefn = moduleNameString (moduleName this_mod) ++ suffix
-
-
-to_ie_post_rn_var :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn
-to_ie_post_rn_var (L l n)
-  | isDataOcc $ occName n = L l (IEPattern (EpaSpan $ la2r l) (L (la2na l) n))
-  | otherwise             = L l (IEName    noExtField         (L (la2na l) n))
-
-
-to_ie_post_rn :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn
-to_ie_post_rn (L l n)
-  | isTcOcc occ && isSymOcc occ = L l (IEType (EpaSpan $ la2r l) (L (la2na l) n))
-  | otherwise                   = L l (IEName noExtField         (L (la2na l) n))
-  where occ = occName n
-
-{-
-Note [Partial export]
-~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-
-   module A( op ) where
-     class C a where
-       op :: a -> a
-
-   module B where
-   import A
-   f = ..op...
-
-Then the minimal import for module B is
-   import A( op )
-not
-   import A( C( op ) )
-which we would usually generate if C was exported from B.  Hence
-the availExportsDecl test when deciding what to generate.
-
-
-Note [Overloaded field import]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-On the other hand, if we have
-
-    {-# LANGUAGE DuplicateRecordFields #-}
-    module A where
-      data T = MkT { foo :: Int }
-
-    module B where
-      import A
-      f = ...foo...
-
-then the minimal import for module B must be
-    import A ( T(foo) )
-because when DuplicateRecordFields is enabled, field selectors are
-not in scope without their enclosing datatype.
-
-On the third hand, if we have
-
-    {-# LANGUAGE DuplicateRecordFields #-}
-    module A where
-      pattern MkT { foo } = Just foo
-
-    module B where
-      import A
-      f = ...foo...
-
-then the minimal import for module B must be
-    import A ( foo )
-because foo doesn't have a parent.  This might actually be ambiguous if A
-exports another field called foo, but there is no good answer to return and this
-is a very obscure corner, so it seems to be the best we can do.  See
-DRFPatSynExport for a test of this.
-
-
-************************************************************************
-*                                                                      *
-\subsection{Errors}
-*                                                                      *
-************************************************************************
--}
-
-qualImportItemErr :: RdrName -> SDoc
-qualImportItemErr rdr
-  = hang (text "Illegal qualified name in import item:")
-       2 (ppr rdr)
-
-ambiguousImportItemErr :: RdrName -> [AvailInfo] -> SDoc
-ambiguousImportItemErr rdr avails
-  = hang (text "Ambiguous name" <+> quotes (ppr rdr) <+> text "in import item. It could refer to:")
-       2 (vcat (map ppr_avail avails))
-  where
-    ppr_avail (AvailTC parent _) = ppr parent <> parens (ppr rdr)
-    ppr_avail (Avail name)       = ppr name
-
-pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc
-pprImpDeclSpec iface decl_spec =
-  quotes (ppr (is_mod decl_spec)) <+> case mi_boot iface of
-    IsBoot -> text "(hi-boot interface)"
-    NotBoot -> Outputable.empty
-
-badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc
-badImportItemErrStd iface decl_spec ie
-  = sep [text "Module", pprImpDeclSpec iface decl_spec,
-         text "does not export", quotes (ppr ie)]
-
-badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs
-                        -> SDoc
-badImportItemErrDataCon dataType_occ iface decl_spec ie
-  = vcat [ text "In module"
-             <+> pprImpDeclSpec iface decl_spec
-             <> colon
-         , nest 2 $ quotes datacon
-             <+> text "is a data constructor of"
-             <+> quotes dataType
-         , text "To import it use"
-         , nest 2 $ text "import"
-             <+> ppr (is_mod decl_spec)
-             <> parens_sp (dataType <> parens_sp datacon)
-         , text "or"
-         , nest 2 $ text "import"
-             <+> ppr (is_mod decl_spec)
-             <> parens_sp (dataType <> text "(..)")
-         ]
-  where
-    datacon_occ = rdrNameOcc $ ieName ie
-    datacon = parenSymOcc datacon_occ (ppr datacon_occ)
-    dataType = parenSymOcc dataType_occ (ppr dataType_occ)
-    parens_sp d = parens (space <> d <> space)  -- T( f,g )
-
-badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc
-badImportItemErr iface decl_spec ie avails
-  = case find checkIfDataCon avails of
-      Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie
-      Nothing  -> badImportItemErrStd iface decl_spec ie
-  where
-    checkIfDataCon (AvailTC _ ns) =
-      case find (\n -> importedFS == occNameFS (occName n)) ns of
-        Just n  -> isDataConName (greNameMangledName n)
-        Nothing -> False
-    checkIfDataCon _ = False
-    availOccName = occName . availGreName
-    importedFS = occNameFS . rdrNameOcc $ ieName ie
-
-illegalImportItemErr :: SDoc
-illegalImportItemErr = text "Illegal import item"
-
-addDupDeclErr :: NonEmpty GlobalRdrElt -> TcRn ()
-addDupDeclErr gres@(gre :| _)
-  = addErrAt (getSrcSpan (NE.last sorted_names)) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    -- Report the error at the later location
-    vcat [text "Multiple declarations of" <+>
-             quotes (ppr (greOccName gre)),
-             -- NB. print the OccName, not the Name, because the
-             -- latter might not be in scope in the RdrEnv and so will
-             -- be printed qualified.
-          text "Declared at:" <+>
-                   vcat (toList $ ppr . nameSrcLoc <$> sorted_names)]
-  where
-    sorted_names =
-      NE.sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan)
-             (fmap greMangledName gres)
-
-
-
-missingImportListWarn :: ModuleName -> SDoc
-missingImportListWarn mod
-  = text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list"
-
-moduleWarn :: ModuleName -> WarningTxt GhcRn -> SDoc
-moduleWarn mod (WarningTxt _ txt)
-  = sep [ text "Module" <+> quotes (ppr mod) <> colon,
-          nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ]
-moduleWarn mod (DeprecatedTxt _ txt)
-  = sep [ text "Module" <+> quotes (ppr mod)
-                                <+> text "is deprecated:",
-          nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ]
-
-packageImportErr :: TcRnMessage
-packageImportErr
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-  text "Package-qualified imports are not enabled; use PackageImports"
-
--- This data decl will parse OK
---      data T = a Int
--- treating "a" as the constructor.
--- It is really hard to make the parser spot this malformation.
--- So the renamer has to check that the constructor is legal
---
--- We can get an operator as the constructor, even in the prefix form:
---      data T = :% Int Int
--- from interface files, which always print in prefix form
---
--- We also allow type constructor names, which are defined by "type data"
--- declarations.  See Note [Type data declarations] in GHC.Rename.Module.
-
-checkConName :: RdrName -> TcRn ()
-checkConName name
-  = checkErr (isRdrDataCon name || isRdrTc name) (badDataCon name)
-
-badDataCon :: RdrName -> TcRnMessage
-badDataCon name
-   = mkTcRnUnknownMessage $ mkPlainError noHints $
-   hsep [text "Illegal data constructor name", quotes (ppr name)]
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
deleted file mode 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ /dev/null
@@ -1,1007 +0,0 @@
-{-# LANGUAGE TypeApplications    #-}
-{-# LANGUAGE DeriveFunctor       #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies        #-}
-{-# LANGUAGE ViewPatterns        #-}
-{-# LANGUAGE DisambiguateRecordFields #-}
-
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-Renaming of patterns
-
-Basically dependency analysis.
-
-Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
-general, all of these functions return a renamed thing, and a set of
-free variables.
--}
-module GHC.Rename.Pat (-- main entry points
-              rnPat, rnPats, rnBindPat,
-
-              NameMaker, applyNameMaker,     -- a utility for making names:
-              localRecNameMaker, topRecNameMaker,  --   sometimes we want to make local names,
-                                             --   sometimes we want to make top (qualified) names.
-              isTopRecNameMaker,
-
-              rnHsRecFields, HsRecFieldContext(..),
-              rnHsRecUpdFields,
-
-              -- CpsRn monad
-              CpsRn, liftCps, liftCpsWithCont,
-
-              -- Literals
-              rnLit, rnOverLit,
-             ) where
-
--- ENH: thin imports to only what is necessary for patterns
-
-import GHC.Prelude
-
-import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr )
-import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat )
-
-import GHC.Hs
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Zonk   ( hsOverLitName )
-import GHC.Rename.Env
-import GHC.Rename.Fixity
-import GHC.Rename.Utils    ( newLocalBndrRn, bindLocalNames
-                           , warnUnusedMatches, newLocalBndrRn
-                           , checkUnusedRecordWildcard
-                           , checkDupNames, checkDupAndShadowedNames
-                           , wrapGenSpan, genHsApps, genLHsVar, genHsIntegralLit, warnForallIdentifier )
-import GHC.Rename.HsType
-import GHC.Builtin.Names
-import GHC.Types.Avail ( greNameMangledName )
-import GHC.Types.Error
-import GHC.Types.Name
-import GHC.Types.Name.Set
-import GHC.Types.Name.Reader
-import GHC.Types.Basic
-import GHC.Types.SourceText
-import GHC.Utils.Misc
-import GHC.Data.List.SetOps( removeDups )
-import GHC.Utils.Outputable
-import GHC.Utils.Panic.Plain
-import GHC.Types.SrcLoc
-import GHC.Types.Literal   ( inCharRange )
-import GHC.Builtin.Types   ( nilDataCon )
-import GHC.Core.DataCon
-import GHC.Driver.Session ( getDynFlags, xopt_DuplicateRecordFields )
-import qualified GHC.LanguageExtensions as LangExt
-
-import Control.Monad       ( when, ap, guard, unless )
-import Data.Foldable
-import Data.Functor.Identity ( Identity (..) )
-import qualified Data.List.NonEmpty as NE
-import Data.Maybe
-import Data.Ratio
-import GHC.Types.FieldLabel (DuplicateRecordFields(..))
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-{-
-*********************************************************
-*                                                      *
-        The CpsRn Monad
-*                                                      *
-*********************************************************
-
-Note [CpsRn monad]
-~~~~~~~~~~~~~~~~~~
-The CpsRn monad uses continuation-passing style to support this
-style of programming:
-
-        do { ...
-           ; ns <- bindNames rs
-           ; ...blah... }
-
-   where rs::[RdrName], ns::[Name]
-
-The idea is that '...blah...'
-  a) sees the bindings of ns
-  b) returns the free variables it mentions
-     so that bindNames can report unused ones
-
-In particular,
-    mapM rnPatAndThen [p1, p2, p3]
-has a *left-to-right* scoping: it makes the binders in
-p1 scope over p2,p3.
--}
-
-newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))
-                                            -> RnM (r, FreeVars) }
-        deriving (Functor)
-        -- See Note [CpsRn monad]
-
-instance Applicative CpsRn where
-    pure x = CpsRn (\k -> k x)
-    (<*>) = ap
-
-instance Monad CpsRn where
-  (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))
-
-runCps :: CpsRn a -> RnM (a, FreeVars)
-runCps (CpsRn m) = m (\r -> return (r, emptyFVs))
-
-liftCps :: RnM a -> CpsRn a
-liftCps rn_thing = CpsRn (\k -> rn_thing >>= k)
-
-liftCpsFV :: RnM (a, FreeVars) -> CpsRn a
-liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing
-                                     ; (r,fvs2) <- k v
-                                     ; return (r, fvs1 `plusFV` fvs2) })
-
-liftCpsWithCont :: (forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)) -> CpsRn b
-liftCpsWithCont = CpsRn
-
-wrapSrcSpanCps :: (a -> CpsRn b) -> LocatedA a -> CpsRn (LocatedA b)
--- Set the location, and also wrap it around the value returned
-wrapSrcSpanCps fn (L loc a)
-  = CpsRn (\k -> setSrcSpanA loc $
-                 unCpsRn (fn a) $ \v ->
-                 k (L loc v))
-
-lookupConCps :: LocatedN RdrName -> CpsRn (LocatedN Name)
-lookupConCps con_rdr
-  = CpsRn (\k -> do { con_name <- lookupLocatedOccRnConstr con_rdr
-                    ; (r, fvs) <- k con_name
-                    ; return (r, addOneFV fvs (unLoc con_name)) })
-    -- We add the constructor name to the free vars
-    -- See Note [Patterns are uses]
-
-{-
-Note [Patterns are uses]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  module Foo( f, g ) where
-  data T = T1 | T2
-
-  f T1 = True
-  f T2 = False
-
-  g _ = T1
-
-Arguably we should report T2 as unused, even though it appears in a
-pattern, because it never occurs in a constructed position.
-See #7336.
-However, implementing this in the face of pattern synonyms would be
-less straightforward, since given two pattern synonyms
-
-  pattern P1 <- P2
-  pattern P2 <- ()
-
-we need to observe the dependency between P1 and P2 so that type
-checking can be done in the correct order (just like for value
-bindings). Dependencies between bindings is analyzed in the renamer,
-where we don't know yet whether P2 is a constructor or a pattern
-synonym. So for now, we do report conid occurrences in patterns as
-uses.
-
-*********************************************************
-*                                                      *
-        Name makers
-*                                                      *
-*********************************************************
-
-Externally abstract type of name makers,
-which is how you go from a RdrName to a Name
--}
-
-data NameMaker
-  = LamMk       -- Lambdas
-      Bool      -- True <=> report unused bindings
-                --   (even if True, the warning only comes out
-                --    if -Wunused-matches is on)
-
-  | LetMk       -- Let bindings, incl top level
-                -- Do *not* check for unused bindings
-      TopLevelFlag
-      MiniFixityEnv
-
-topRecNameMaker :: MiniFixityEnv -> NameMaker
-topRecNameMaker fix_env = LetMk TopLevel fix_env
-
-isTopRecNameMaker :: NameMaker -> Bool
-isTopRecNameMaker (LetMk TopLevel _) = True
-isTopRecNameMaker _ = False
-
-localRecNameMaker :: MiniFixityEnv -> NameMaker
-localRecNameMaker fix_env = LetMk NotTopLevel fix_env
-
-matchNameMaker :: HsMatchContext a -> NameMaker
-matchNameMaker ctxt = LamMk report_unused
-  where
-    -- Do not report unused names in interactive contexts
-    -- i.e. when you type 'x <- e' at the GHCi prompt
-    report_unused = case ctxt of
-                      StmtCtxt (HsDoStmt GhciStmtCtxt) -> False
-                      -- also, don't warn in pattern quotes, as there
-                      -- is no RHS where the variables can be used!
-                      ThPatQuote            -> False
-                      _                     -> True
-
-newPatLName :: NameMaker -> LocatedN RdrName -> CpsRn (LocatedN Name)
-newPatLName name_maker rdr_name@(L loc _)
-  = do { name <- newPatName name_maker rdr_name
-       ; return (L loc name) }
-
-newPatName :: NameMaker -> LocatedN RdrName -> CpsRn Name
-newPatName (LamMk report_unused) rdr_name
-  = CpsRn (\ thing_inside ->
-        do { warnForallIdentifier rdr_name
-           ; name <- newLocalBndrRn rdr_name
-           ; (res, fvs) <- bindLocalNames [name] (thing_inside name)
-           ; when report_unused $ warnUnusedMatches [name] fvs
-           ; return (res, name `delFV` fvs) })
-
-newPatName (LetMk is_top fix_env) rdr_name
-  = CpsRn (\ thing_inside ->
-        do { warnForallIdentifier rdr_name
-           ; name <- case is_top of
-                       NotTopLevel -> newLocalBndrRn rdr_name
-                       TopLevel    -> newTopSrcBinder rdr_name
-           ; bindLocalNames [name] $
-                 -- Do *not* use bindLocalNameFV here;
-                 --   see Note [View pattern usage]
-                 -- For the TopLevel case
-                 --   see Note [bindLocalNames for an External name]
-             addLocalFixities fix_env [name] $
-             thing_inside name })
-
-{- Note [bindLocalNames for an External name]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In the TopLevel case, the use of bindLocalNames here is somewhat
-suspicious because it binds a top-level External name in the
-LocalRdrEnv.  c.f. Note [LocalRdrEnv] in GHC.Types.Name.Reader.
-
-However, this only happens when renaming the LHS (only) of a top-level
-pattern binding.  Even though this only the LHS, we need to bring the
-binder into scope in the pattern itself in case the binder is used in
-subsequent view patterns.  A bit bizarre, something like
-  (x, Just y <- f x) = e
-
-Anyway, bindLocalNames does work, and the binding only exists for the
-duration of the pattern; then the top-level name is added to the
-global env before going on to the RHSes (see GHC.Rename.Module).
-
-Note [View pattern usage]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  let (r, (r -> x)) = x in ...
-Here the pattern binds 'r', and then uses it *only* in the view pattern.
-We want to "see" this use, and in let-bindings we collect all uses and
-report unused variables at the binding level. So we must use bindLocalNames
-here, *not* bindLocalNameFV.  #3943.
-
-
-Note [Don't report shadowing for pattern synonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There is one special context where a pattern doesn't introduce any new binders -
-pattern synonym declarations. Therefore we don't check to see if pattern
-variables shadow existing identifiers as they are never bound to anything
-and have no scope.
-
-Without this check, there would be quite a cryptic warning that the `x`
-in the RHS of the pattern synonym declaration shadowed the top level `x`.
-
-```
-x :: ()
-x = ()
-
-pattern P x = Just x
-```
-
-See #12615 for some more examples.
-
-Note [Handling overloaded and rebindable patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Overloaded paterns and rebindable patterns are desugared in the renamer
-using the HsPatExpansion mechanism detailed in:
-Note [Rebindable syntax and HsExpansion]
-The approach is similar to that of expressions, which is further detailed
-in Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr.
-
-Here are the patterns that are currently desugared in this way:
-
-* ListPat (list patterns [p1,p2,p3])
-  When (and only when) OverloadedLists is on, desugar to a view pattern:
-    [p1, p2, p3]
-  ==>
-    toList -> [p1, p2, p3]
-              ^^^^^^^^^^^^ built-in (non-overloaded) list pattern
-  NB: the type checker and desugarer still see ListPat,
-      but to them it always means the built-in list pattern.
-  See Note [Desugaring overloaded list patterns] below for more details.
-
-We expect to add to this list as we deal with more patterns via the expansion
-mechanism.
-
-Note [Desugaring overloaded list patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If OverloadedLists is enabled, we desugar a list pattern to a view pattern:
-
-  [p1, p2, p3]
-==>
-  toList -> [p1, p2, p3]
-
-This happens directly in the renamer, using the HsPatExpansion mechanism
-detailed in Note [Rebindable syntax and HsExpansion].
-
-Note that we emit a special view pattern: we additionally keep track of an
-inverse to the pattern.
-See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn for details.
-
-== Wrinkle ==
-
-This is all fine, except in one very specific case:
-  - when RebindableSyntax is off,
-  - and the type being matched on is already a list type.
-
-In this case, it is undesirable to desugar an overloaded list pattern into
-a view pattern. To illustrate, consider the following program:
-
-> {-# LANGUAGE OverloadedLists #-}
->
-> f []    = True
-> f (_:_) = False
-
-Without any special logic, the pattern `[]` is desugared to `(toList -> [])`,
-whereas `(_:_)` remains a constructor pattern. This implies that the argument
-of `f` is necessarily a list (even though `OverloadedLists` is enabled).
-After desugaring the overloaded list pattern `[]`, and type-checking, we obtain:
-
-> f :: [a] -> Bool
-> f (toList -> []) = True
-> f (_:_)          = False
-
-The pattern match checker then warns that the pattern `[]` is not covered,
-as it isn't able to look through view patterns.
-We can see that this is silly: as we are matching on a list, `toList` doesn't
-actually do anything. So we ignore it, and desugar the pattern to an explicit
-list pattern, instead of a view pattern.
-
-Note however that this is not necessarily sound, because it is possible to have
-a list `l` such that `toList l` is not the same as `l`.
-This can happen with an overlapping instance, such as the following:
-
-instance {-# OVERLAPPING #-} IsList [Int] where
-  type Item [Int] = Int
-  toList = reverse
-  fromList = reverse
-
-We make the assumption that no such instance exists, in order to avoid worsening
-pattern-match warnings (see #14547).
-
-*********************************************************
-*                                                      *
-        External entry points
-*                                                      *
-*********************************************************
-
-There are various entry points to renaming patterns, depending on
- (1) whether the names created should be top-level names or local names
- (2) whether the scope of the names is entirely given in a continuation
-     (e.g., in a case or lambda, but not in a let or at the top-level,
-      because of the way mutually recursive bindings are handled)
- (3) whether the a type signature in the pattern can bind
-        lexically-scoped type variables (for unpacking existential
-        type vars in data constructors)
- (4) whether we do duplicate and unused variable checking
- (5) whether there are fixity declarations associated with the names
-     bound by the patterns that need to be brought into scope with them.
-
- Rather than burdening the clients of this module with all of these choices,
- we export the three points in this design space that we actually need:
--}
-
--- ----------- Entry point 1: rnPats -------------------
--- Binds local names; the scope of the bindings is entirely in the thing_inside
---   * allows type sigs to bind type vars
---   * local namemaker
---   * unused and duplicate checking
---   * no fixities
-rnPats :: Traversable f
-       => HsMatchContext GhcRn -- for error messages
-       -> f (LPat GhcPs)
-       -> (f (LPat GhcRn) -> RnM (a, FreeVars))
-       -> RnM (a, FreeVars)
-rnPats ctxt pats thing_inside
-  = do  { envs_before <- getRdrEnvs
-
-          -- (1) rename the patterns, bringing into scope all of the term variables
-          -- (2) then do the thing inside.
-        ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do
-        { -- Check for duplicated and shadowed names
-          -- Must do this *after* renaming the patterns
-          -- See Note [Collect binders only after renaming] in GHC.Hs.Utils
-          -- Because we don't bind the vars all at once, we can't
-          --    check incrementally for duplicates;
-          -- Nor can we check incrementally for shadowing, else we'll
-          --    complain *twice* about duplicates e.g. f (x,x) = ...
-          --
-          -- See Note [Don't report shadowing for pattern synonyms]
-        ; let bndrs = collectPatsBinders CollNoDictBinders (toList pats')
-        ; addErrCtxt doc_pat $
-          if isPatSynCtxt ctxt
-             then checkDupNames bndrs
-             else checkDupAndShadowedNames envs_before bndrs
-        ; thing_inside pats' } }
-  where
-    doc_pat = text "In" <+> pprMatchContext ctxt
-{-# SPECIALIZE rnPats :: HsMatchContext GhcRn -> [LPat GhcPs] -> ([LPat GhcRn] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-}
-{-# SPECIALIZE rnPats :: HsMatchContext GhcRn -> Identity (LPat GhcPs) -> (Identity (LPat GhcRn) -> RnM (a, FreeVars)) -> RnM (a, FreeVars) #-}
-
-rnPat :: HsMatchContext GhcRn -- for error messages
-      -> LPat GhcPs
-      -> (LPat GhcRn -> RnM (a, FreeVars))
-      -> RnM (a, FreeVars)     -- Variables bound by pattern do not
-                               -- appear in the result FreeVars
-rnPat ctxt pat thing_inside
-  = rnPats ctxt (Identity pat) (thing_inside . runIdentity)
-
-applyNameMaker :: NameMaker -> LocatedN RdrName -> RnM (LocatedN Name)
-applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr)
-                           ; return n }
-
--- ----------- Entry point 2: rnBindPat -------------------
--- Binds local names; in a recursive scope that involves other bound vars
---      e.g let { (x, Just y) = e1; ... } in ...
---   * does NOT allows type sig to bind type vars
---   * local namemaker
---   * no unused and duplicate checking
---   * fixities might be coming in
-rnBindPat :: NameMaker
-          -> LPat GhcPs
-          -> RnM (LPat GhcRn, FreeVars)
-   -- Returned FreeVars are the free variables of the pattern,
-   -- of course excluding variables bound by this pattern
-
-rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat)
-
-{-
-*********************************************************
-*                                                      *
-        The main event
-*                                                      *
-*********************************************************
--}
-
--- ----------- Entry point 3: rnLPatAndThen -------------------
--- General version: parameterized by how you make new names
-
-rnLPatsAndThen :: Traversable f => NameMaker -> f (LPat GhcPs) -> CpsRn (f (LPat GhcRn))
-rnLPatsAndThen mk = mapM (rnLPatAndThen mk)
-  -- Despite the map, the monad ensures that each pattern binds
-  -- variables that may be mentioned in subsequent patterns in the list
-
---------------------
--- The workhorse
-rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
-rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat
-
-rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)
-rnPatAndThen _  (WildPat _)   = return (WildPat noExtField)
-rnPatAndThen mk (ParPat x lpar pat rpar) =
-  do { pat' <- rnLPatAndThen mk pat
-     ; return (ParPat x lpar pat' rpar) }
-rnPatAndThen mk (LazyPat _ pat) = do { pat' <- rnLPatAndThen mk pat
-                                     ; return (LazyPat noExtField pat') }
-rnPatAndThen mk (BangPat _ pat) = do { pat' <- rnLPatAndThen mk pat
-                                     ; return (BangPat noExtField pat') }
-rnPatAndThen mk (VarPat x (L l rdr))
-    = do { loc <- liftCps getSrcSpanM
-         ; name <- newPatName mk (L (noAnnSrcSpan loc) rdr)
-         ; return (VarPat x (L l name)) }
-     -- we need to bind pattern variables for view pattern expressions
-     -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
-
-rnPatAndThen mk (SigPat _ pat sig)
-  -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is
-  -- important to rename its type signature _before_ renaming the rest of the
-  -- pattern, so that type variables are first bound by the _outermost_ pattern
-  -- type signature they occur in. This keeps the type checker happy when
-  -- pattern type signatures happen to be nested (#7827)
-  --
-  -- f ((Just (x :: a) :: Maybe a)
-  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^       `a' is first bound here
-  -- ~~~~~~~~~~~~~~~^                   the same `a' then used here
-  = do { sig' <- rnHsPatSigTypeAndThen sig
-       ; pat' <- rnLPatAndThen mk pat
-       ; return (SigPat noExtField pat' sig' ) }
-  where
-    rnHsPatSigTypeAndThen :: HsPatSigType GhcPs -> CpsRn (HsPatSigType GhcRn)
-    rnHsPatSigTypeAndThen sig = liftCpsWithCont (rnHsPatSigType AlwaysBind PatCtx sig)
-
-rnPatAndThen mk (LitPat x lit)
-  | HsString src s <- lit
-  = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
-       ; if ovlStr
-         then rnPatAndThen mk
-                           (mkNPat (noLocA (mkHsIsString src s))
-                                      Nothing noAnn)
-         else normal_lit }
-  | otherwise = normal_lit
-  where
-    normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }
-
-rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)
-  = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit
-       ; mb_neg' -- See Note [Negative zero]
-           <- let negative = do { (neg, fvs) <- lookupSyntax negateName
-                                ; return (Just neg, fvs) }
-                  positive = return (Nothing, emptyFVs)
-              in liftCpsFV $ case (mb_neg , mb_neg') of
-                                  (Nothing, Just _ ) -> negative
-                                  (Just _ , Nothing) -> negative
-                                  (Nothing, Nothing) -> positive
-                                  (Just _ , Just _ ) -> positive
-       ; eq' <- liftCpsFV $ lookupSyntax eqName
-       ; return (NPat x (L l lit') mb_neg' eq') }
-
-rnPatAndThen mk (NPlusKPat _ rdr (L l lit) _ _ _ )
-  = do { new_name <- newPatName mk (l2n rdr)
-       ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]
-                                                -- We skip negateName as
-                                                -- negative zero doesn't make
-                                                -- sense in n + k patterns
-       ; minus <- liftCpsFV $ lookupSyntax minusName
-       ; ge    <- liftCpsFV $ lookupSyntax geName
-       ; return (NPlusKPat noExtField (L (noAnnSrcSpan $ nameSrcSpan new_name) new_name)
-                                      (L l lit') lit' ge minus) }
-                -- The Report says that n+k patterns must be in Integral
-
-rnPatAndThen mk (AsPat _ rdr at pat)
-  = do { new_name <- newPatLName mk rdr
-       ; pat' <- rnLPatAndThen mk pat
-       ; return (AsPat noExtField new_name at pat') }
-
-rnPatAndThen mk p@(ViewPat _ expr pat)
-  = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns
-                      ; checkErr vp_flag (TcRnIllegalViewPattern p) }
-         -- Because of the way we're arranging the recursive calls,
-         -- this will be in the right context
-       ; expr' <- liftCpsFV $ rnLExpr expr
-       ; pat' <- rnLPatAndThen mk pat
-       -- Note: at this point the PreTcType in ty can only be a placeHolder
-       -- ; return (ViewPat expr' pat' ty) }
-
-       -- Note: we can't cook up an inverse for an arbitrary view pattern,
-       -- so we pass 'Nothing'.
-       ; return (ViewPat Nothing expr' pat') }
-
-rnPatAndThen mk (ConPat _ con args)
-   -- rnConPatAndThen takes care of reconstructing the pattern
-   -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.
-  = case unLoc con == nameRdrName (dataConName nilDataCon) of
-      True    -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists
-                    ; if ol_flag then rnPatAndThen mk (ListPat noAnn [])
-                                 else rnConPatAndThen mk con args}
-      False   -> rnConPatAndThen mk con args
-
-rnPatAndThen mk (ListPat _ pats)
-  = do { opt_OverloadedLists  <- liftCps $ xoptM LangExt.OverloadedLists
-       ; pats' <- rnLPatsAndThen mk pats
-       ; if not opt_OverloadedLists
-         then return (ListPat noExtField pats')
-         else
-    -- If OverloadedLists is enabled, desugar to a view pattern.
-    -- See Note [Desugaring overloaded list patterns]
-    do { (to_list_name,_)     <- liftCps $ lookupSyntaxName toListName
-       -- Use 'fromList' as proof of invertibility of the view pattern.
-       -- See Note [Invertible view patterns] in GHC.Tc.TyCl.PatSyn
-       ; (from_list_n_name,_) <- liftCps $ lookupSyntaxName fromListNName
-       ; let
-           lit_n   = mkIntegralLit (length pats)
-           hs_lit  = genHsIntegralLit lit_n
-           inverse = genHsApps from_list_n_name [hs_lit]
-           rn_list_pat  = ListPat noExtField pats'
-           exp_expr     = genLHsVar to_list_name
-           exp_list_pat = ViewPat (Just inverse) exp_expr (wrapGenSpan rn_list_pat)
-       ; return $ mkExpandedPat rn_list_pat exp_list_pat }}
-
-rnPatAndThen mk (TuplePat _ pats boxed)
-  = do { pats' <- rnLPatsAndThen mk pats
-       ; return (TuplePat noExtField pats' boxed) }
-
-rnPatAndThen mk (SumPat _ pat alt arity)
-  = do { pat <- rnLPatAndThen mk pat
-       ; return (SumPat noExtField pat alt arity)
-       }
-
-rnPatAndThen mk (SplicePat _ splice)
-  = do { eith <- liftCpsFV $ rnSplicePat splice
-       ; case eith of   -- See Note [rnSplicePat] in GHC.Rename.Splice
-           (rn_splice, HsUntypedSpliceTop mfs pat) -> -- Splice was top-level and thus run, creating Pat GhcPs
-               gParPat . (fmap (flip SplicePat rn_splice . HsUntypedSpliceTop mfs)) <$> rnLPatAndThen mk pat
-           (rn_splice, HsUntypedSpliceNested splice_name) -> return (SplicePat (HsUntypedSpliceNested splice_name) rn_splice) -- Splice was nested and thus already renamed
-       }
-
---------------------
-rnConPatAndThen :: NameMaker
-                -> LocatedN RdrName    -- the constructor
-                -> HsConPatDetails GhcPs
-                -> CpsRn (Pat GhcRn)
-
-rnConPatAndThen mk con (PrefixCon tyargs pats)
-  = do  { con' <- lookupConCps con
-        ; liftCps check_lang_exts
-        ; tyargs' <- mapM rnConPatTyArg tyargs
-        ; pats' <- rnLPatsAndThen mk pats
-        ; return $ ConPat
-            { pat_con_ext = noExtField
-            , pat_con = con'
-            , pat_args = PrefixCon tyargs' pats'
-            }
-        }
-  where
-    check_lang_exts :: RnM ()
-    check_lang_exts = do
-      scoped_tyvars <- xoptM LangExt.ScopedTypeVariables
-      type_app      <- xoptM LangExt.TypeApplications
-      unless (scoped_tyvars && type_app) $
-        case listToMaybe tyargs of
-          Nothing -> pure ()
-          Just tyarg -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-            hang (text "Illegal visible type application in a pattern:"
-                    <+> quotes (ppr tyarg))
-               2 (text "Both ScopedTypeVariables and TypeApplications are"
-                    <+> text "required to use this feature")
-    rnConPatTyArg (HsConPatTyArg at t) = do
-      t' <- liftCpsWithCont $ rnHsPatSigTypeBindingVars HsTypeCtx t
-      return (HsConPatTyArg at t')
-
-rnConPatAndThen mk con (InfixCon pat1 pat2)
-  = do  { con' <- lookupConCps con
-        ; pat1' <- rnLPatAndThen mk pat1
-        ; pat2' <- rnLPatAndThen mk pat2
-        ; fixity <- liftCps $ lookupFixityRn (unLoc con')
-        ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }
-
-rnConPatAndThen mk con (RecCon rpats)
-  = do  { con' <- lookupConCps con
-        ; rpats' <- rnHsRecPatsAndThen mk con' rpats
-        ; return $ ConPat
-            { pat_con_ext = noExtField
-            , pat_con = con'
-            , pat_args = RecCon rpats'
-            }
-        }
-
-checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()
-checkUnusedRecordWildcardCps loc dotdot_names =
-  CpsRn (\thing -> do
-                    (r, fvs) <- thing ()
-                    checkUnusedRecordWildcard loc fvs dotdot_names
-                    return (r, fvs) )
---------------------
-rnHsRecPatsAndThen :: NameMaker
-                   -> LocatedN Name      -- Constructor
-                   -> HsRecFields GhcPs (LPat GhcPs)
-                   -> CpsRn (HsRecFields GhcRn (LPat GhcRn))
-rnHsRecPatsAndThen mk (L _ con)
-     hs_rec_fields@(HsRecFields { rec_dotdot = dd })
-  = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat
-                                            hs_rec_fields
-       ; flds' <- mapM rn_field (flds `zip` [1..])
-       ; check_unused_wildcard (implicit_binders flds' <$> dd)
-       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
-  where
-    mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n)
-    rn_field (L l fld, n') =
-      do { arg' <- rnLPatAndThen (nested_mk dd mk (RecFieldsDotDot n')) (hfbRHS fld)
-         ; return (L l (fld { hfbRHS = arg' })) }
-
-    loc = maybe noSrcSpan getLoc dd
-
-    -- Get the arguments of the implicit binders
-    implicit_binders fs (unLoc -> RecFieldsDotDot n) = collectPatsBinders CollNoDictBinders implicit_pats
-      where
-        implicit_pats = map (hfbRHS . unLoc) (drop n fs)
-
-    -- Don't warn for let P{..} = ... in ...
-    check_unused_wildcard = case mk of
-                              LetMk{} -> const (return ())
-                              LamMk{} -> checkUnusedRecordWildcardCps loc
-
-        -- Suppress unused-match reporting for fields introduced by ".."
-    nested_mk Nothing  mk                    _  = mk
-    nested_mk (Just _) mk@(LetMk {})         _  = mk
-    nested_mk (Just (unLoc -> n)) (LamMk report_unused) n'
-      = LamMk (report_unused && (n' <= n))
-
-
-{- *********************************************************************
-*                                                                      *
-              Generating code for HsPatExpanded
-      See Note [Handling overloaded and rebindable constructs]
-*                                                                      *
-********************************************************************* -}
-
--- | Build a 'HsPatExpansion' out of an extension constructor,
---   and the two components of the expansion: original and
---   desugared patterns
-mkExpandedPat
-  :: Pat GhcRn -- ^ source pattern
-  -> Pat GhcRn -- ^ expanded pattern
-  -> Pat GhcRn -- ^ suitably wrapped 'HsPatExpansion'
-mkExpandedPat a b = XPat (HsPatExpanded a b)
-
-{-
-************************************************************************
-*                                                                      *
-        Record fields
-*                                                                      *
-************************************************************************
--}
-
-data HsRecFieldContext
-  = HsRecFieldCon Name
-  | HsRecFieldPat Name
-  | HsRecFieldUpd
-
-rnHsRecFields
-    :: forall arg.
-       HsRecFieldContext
-    -> (SrcSpan -> RdrName -> arg)
-         -- When punning, use this to build a new field
-    -> HsRecFields GhcPs (LocatedA arg)
-    -> RnM ([LHsRecField GhcRn (LocatedA arg)], FreeVars)
-
--- This surprisingly complicated pass
---   a) looks up the field name (possibly using disambiguation)
---   b) fills in puns and dot-dot stuff
--- When we've finished, we've renamed the LHS, but not the RHS,
--- of each x=e binding
---
--- This is used for record construction and pattern-matching, but not updates.
-
-rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
-  = do { pun_ok      <- xoptM LangExt.NamedFieldPuns
-       ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields
-       ; let parent = guard disambig_ok >> mb_con
-       ; flds1  <- mapM (rn_fld pun_ok parent) flds
-       ; mapM_ (addErr . dupFieldErr ctxt) dup_flds
-       ; dotdot_flds <- rn_dotdot dotdot mb_con flds1
-       ; let all_flds | null dotdot_flds = flds1
-                      | otherwise        = flds1 ++ dotdot_flds
-       ; return (all_flds, mkFVs (getFieldIds all_flds)) }
-  where
-    mb_con = case ctxt of
-                HsRecFieldCon con  -> Just con
-                HsRecFieldPat con  -> Just con
-                _ {- update -}     -> Nothing
-
-    rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (LocatedA arg)
-           -> RnM (LHsRecField GhcRn (LocatedA arg))
-    rn_fld pun_ok parent (L l
-                           (HsFieldBind
-                              { hfbLHS =
-                                  (L loc (FieldOcc _ (L ll lbl)))
-                              , hfbRHS = arg
-                              , hfbPun      = pun }))
-      = do { sel <- setSrcSpanA loc $ lookupRecFieldOcc parent lbl
-           ; arg' <- if pun
-                     then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))
-                               -- Discard any module qualifier (#11662)
-                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
-                             ; return (L (l2l loc) (mk_arg (locA loc) arg_rdr)) }
-                     else return arg
-           ; return (L l (HsFieldBind
-                             { hfbAnn = noAnn
-                             , hfbLHS = (L loc (FieldOcc sel (L ll lbl)))
-                             , hfbRHS = arg'
-                             , hfbPun      = pun })) }
-
-
-    rn_dotdot :: Maybe (Located RecFieldsDotDot)      -- See Note [DotDot fields] in GHC.Hs.Pat
-              -> Maybe Name -- The constructor (Nothing for an
-                                --    out of scope constructor)
-              -> [LHsRecField GhcRn (LocatedA arg)] -- Explicit fields
-              -> RnM ([LHsRecField GhcRn (LocatedA arg)])   -- Field Labels we need to fill in
-    rn_dotdot (Just (L loc (RecFieldsDotDot n))) (Just con) flds -- ".." on record construction / pat match
-      | not (isUnboundName con) -- This test is because if the constructor
-                                -- isn't in scope the constructor lookup will add
-                                -- an error but still return an unbound name. We
-                                -- don't want that to screw up the dot-dot fill-in stuff.
-      = assert (flds `lengthIs` n) $
-        do { dd_flag <- xoptM LangExt.RecordWildCards
-           ; checkErr dd_flag (needFlagDotDot ctxt)
-           ; (rdr_env, lcl_env) <- getRdrEnvs
-           ; con_fields <- lookupConstructorFields con
-           ; when (null con_fields) (addErr (TcRnIllegalWildcardsInConstructor con))
-           ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)
-
-                   -- For constructor uses (but not patterns)
-                   -- the arg should be in scope locally;
-                   -- i.e. not top level or imported
-                   -- Eg.  data R = R { x,y :: Int }
-                   --      f x = R { .. }   -- Should expand to R {x=x}, not R{x=x,y=y}
-                 arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env
-
-                 (dot_dot_fields, dot_dot_gres)
-                        = unzip [ (fl, gre)
-                                | fl <- con_fields
-                                , let lbl = mkVarOccFS (field_label $ flLabel fl)
-                                , not (lbl `elemOccSet` present_flds)
-                                , Just gre <- [lookupGRE_FieldLabel rdr_env fl]
-                                              -- Check selector is in scope
-                                , case ctxt of
-                                    HsRecFieldCon {} -> arg_in_scope lbl
-                                    _other           -> True ]
-
-           ; addUsedGREs dot_dot_gres
-           ; let locn = noAnnSrcSpan loc
-           ; return [ L (noAnnSrcSpan loc) (HsFieldBind
-                        { hfbAnn = noAnn
-                        , hfbLHS
-                           = L (noAnnSrcSpan loc) (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))
-                        , hfbRHS = L locn (mk_arg loc arg_rdr)
-                        , hfbPun      = False })
-                    | fl <- dot_dot_fields
-                    , let sel     = flSelector fl
-                    , let arg_rdr = mkVarUnqual (field_label $ flLabel fl) ] }
-
-    rn_dotdot _dotdot _mb_con _flds
-      = return []
-      -- _dotdot = Nothing => No ".." at all
-      -- _mb_con = Nothing => Record update
-      -- _mb_con = Just unbound => Out of scope data constructor
-
-    dup_flds :: [NE.NonEmpty RdrName]
-        -- Each list represents a RdrName that occurred more than once
-        -- (the list contains all occurrences)
-        -- Each list in dup_fields is non-empty
-    (_, dup_flds) = removeDups compare (getFieldLbls flds)
-
-
--- NB: Consider this:
---      module Foo where { data R = R { fld :: Int } }
---      module Odd where { import Foo; fld x = x { fld = 3 } }
--- Arguably this should work, because the reference to 'fld' is
--- unambiguous because there is only one field id 'fld' in scope.
--- But currently it's rejected.
-
-rnHsRecUpdFields
-    :: [LHsRecUpdField GhcPs]
-    -> RnM ([LHsRecUpdField GhcRn], FreeVars)
-rnHsRecUpdFields flds
-  = do { pun_ok        <- xoptM LangExt.NamedFieldPuns
-       ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags
-       ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok dup_fields_ok) flds
-       ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds
-
-       -- Check for an empty record update  e {}
-       -- NB: don't complain about e { .. }, because rn_dotdot has done that already
-       ; when (null flds) $ addErr TcRnEmptyRecordUpdate
-
-       ; return (flds1, plusFVs fvss) }
-  where
-    rn_fld :: Bool -> DuplicateRecordFields -> LHsRecUpdField GhcPs
-           -> RnM (LHsRecUpdField GhcRn, FreeVars)
-    rn_fld pun_ok dup_fields_ok (L l (HsFieldBind { hfbLHS = L loc f
-                                                  , hfbRHS = arg
-                                                  , hfbPun      = pun }))
-      = do { let lbl = rdrNameAmbiguousFieldOcc f
-           ; mb_sel <- setSrcSpanA loc $
-                      -- Defer renaming of overloaded fields to the typechecker
-                      -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head
-                      lookupRecFieldOcc_update dup_fields_ok lbl
-           ; arg' <- if pun
-                     then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl))
-                               -- Discard any module qualifier (#11662)
-                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
-                             ; return (L (l2l loc) (HsVar noExtField
-                                              (L (l2l loc) arg_rdr))) }
-                     else return arg
-           ; (arg'', fvs) <- rnLExpr arg'
-
-           ; let (lbl', fvs') = case mb_sel of
-                   UnambiguousGre gname -> let sel_name = greNameMangledName gname
-                                           in (Unambiguous sel_name (L (l2l loc) lbl), fvs `addOneFV` sel_name)
-                   AmbiguousFields       -> (Ambiguous   noExtField (L (l2l loc) lbl), fvs)
-
-           ; return (L l (HsFieldBind { hfbAnn = noAnn
-                                      , hfbLHS = L loc lbl'
-                                      , hfbRHS = arg''
-                                      , hfbPun = pun }), fvs') }
-
-    dup_flds :: [NE.NonEmpty RdrName]
-        -- Each list represents a RdrName that occurred more than once
-        -- (the list contains all occurrences)
-        -- Each list in dup_fields is non-empty
-    (_, dup_flds) = removeDups compare (getFieldUpdLbls flds)
-
-
-
-getFieldIds :: [LHsRecField GhcRn arg] -> [Name]
-getFieldIds flds = map (hsRecFieldSel . unLoc) flds
-
-getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName]
-getFieldLbls flds
-  = map (unXRec @p . foLabel . unXRec @p . hfbLHS . unXRec @p) flds
-
-getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]
-getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) flds
-
-needFlagDotDot :: HsRecFieldContext -> TcRnMessage
-needFlagDotDot = TcRnIllegalWildcardsInRecord . toRecordFieldPart
-
-dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> TcRnMessage
-dupFieldErr ctxt = TcRnDuplicateFieldName (toRecordFieldPart ctxt)
-
-toRecordFieldPart :: HsRecFieldContext -> RecordFieldPart
-toRecordFieldPart (HsRecFieldCon n)  = RecordFieldConstructor n
-toRecordFieldPart (HsRecFieldPat n)  = RecordFieldPattern     n
-toRecordFieldPart (HsRecFieldUpd {}) = RecordFieldUpdate
-
-{-
-************************************************************************
-*                                                                      *
-\subsubsection{Literals}
-*                                                                      *
-************************************************************************
-
-When literals occur we have to make sure
-that the types and classes they involve
-are made available.
--}
-
-rnLit :: HsLit p -> RnM ()
-rnLit (HsChar _ c) = checkErr (inCharRange c) (TcRnCharLiteralOutOfRange c)
-rnLit _ = return ()
-
--- | Turn a Fractional-looking literal which happens to be an integer into an
--- Integer-looking literal.
--- We only convert numbers where the exponent is between 0 and 100 to avoid
--- converting huge numbers and incurring long compilation times. See #15646.
-generalizeOverLitVal :: OverLitVal -> OverLitVal
-generalizeOverLitVal (HsFractional fl@(FL {fl_text=src,fl_neg=neg,fl_exp=e}))
-    | e >= -100 && e <= 100
-    , let val = rationalFromFractionalLit fl
-    , denominator val == 1 = HsIntegral (IL {il_text=src,il_neg=neg,il_value=numerator val})
-generalizeOverLitVal lit = lit
-
-isNegativeZeroOverLit :: (XXOverLit t ~ DataConCantHappen) => HsOverLit t -> Bool
-isNegativeZeroOverLit lit
- = case ol_val lit of
-        HsIntegral i    -> 0 == il_value i && il_neg i
-        -- For HsFractional, the value of fl is n * (b ^^ e) so it is sufficient
-        -- to check if n = 0. b is equal to either 2 or 10. We don't call
-        -- rationalFromFractionalLit here as it is expensive when e is big.
-        HsFractional fl -> 0 == fl_signi fl && fl_neg fl
-        _               -> False
-
-{-
-Note [Negative zero]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-There were problems with negative zero in conjunction with Negative Literals
-extension. Numeric literal value is contained in Integer and Rational types
-inside IntegralLit and FractionalLit. These types cannot represent negative
-zero value. So we had to add explicit field 'neg' which would hold information
-about literal sign. Here in rnOverLit we use it to detect negative zeroes and
-in this case return not only literal itself but also negateName so that users
-can apply it explicitly. In this case it stays negative zero.  #13211
--}
-
-rnOverLit :: (XXOverLit t ~ DataConCantHappen) => HsOverLit t ->
-             RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
-rnOverLit origLit
-  = do  { opt_NumDecimals <- xoptM LangExt.NumDecimals
-        ; let { lit@(OverLit {ol_val=val})
-            | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)}
-            | otherwise       = origLit
-          }
-        ; let std_name = hsOverLitName val
-        ; (from_thing_name, fvs1) <- lookupSyntaxName std_name
-        ; let rebindable = from_thing_name /= std_name
-              lit' = lit { ol_ext = OverLitRn { ol_rebindable = rebindable
-                                              , ol_from_fun = noLocA from_thing_name } }
-        ; if isNegativeZeroOverLit lit'
-          then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName
-                  ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
-                                  , fvs1 `plusFV` fvs2) }
-          else return ((lit', Nothing), fvs1) }
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
deleted file mode 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ /dev/null
@@ -1,1038 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module GHC.Rename.Splice (
-        rnTopSpliceDecls,
-
-        -- Typed splices
-        rnTypedSplice,
-        -- Untyped splices
-        rnSpliceType, rnUntypedSpliceExpr, rnSplicePat, rnSpliceDecl,
-
-        -- Brackets
-        rnTypedBracket, rnUntypedBracket,
-
-        checkThLocalName, traceSplice, SpliceInfo(..)
-  ) where
-
-import GHC.Prelude
-
-import GHC.Types.Name
-import GHC.Types.Name.Set
-import GHC.Hs
-import GHC.Types.Name.Reader
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-import GHC.Driver.Env.Types
-
-import GHC.Rename.Env
-import GHC.Rename.Utils   ( newLocalBndrRn )
-import GHC.Rename.Unbound ( isUnboundName )
-import GHC.Rename.Module  ( rnSrcDecls, findSplice )
-import GHC.Rename.Pat     ( rnPat )
-import GHC.Types.Error
-import GHC.Types.Basic    ( TopLevelFlag, isTopLevel, maxPrec )
-import GHC.Types.SourceText ( SourceText(..) )
-import GHC.Utils.Outputable
-import GHC.Unit.Module
-import GHC.Types.SrcLoc
-import GHC.Rename.HsType ( rnLHsType )
-
-import Control.Monad    ( unless, when )
-
-import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr )
-
-import GHC.Tc.Utils.Env     ( checkWellStaged, tcMetaTy )
-
-import GHC.Driver.Session
-import GHC.Data.FastString
-import GHC.Utils.Logger
-import GHC.Utils.Panic
-import GHC.Driver.Hooks
-import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName
-                            , patQTyConName, quoteDecName, quoteExpName
-                            , quotePatName, quoteTypeName, typeQTyConName)
-
-import {-# SOURCE #-} GHC.Tc.Gen.Expr   ( tcCheckPolyExpr )
-import {-# SOURCE #-} GHC.Tc.Gen.Splice
-    ( runMetaD
-    , runMetaE
-    , runMetaP
-    , runMetaT
-    , tcTopSpliceExpr
-    )
-
-import GHC.Tc.Utils.Zonk
-
-import GHCi.RemoteTypes ( ForeignRef )
-import qualified Language.Haskell.TH as TH (Q)
-
-import qualified GHC.LanguageExtensions as LangExt
-
-{-
-************************************************************************
-*                                                                      *
-        Template Haskell brackets
-*                                                                      *
-************************************************************************
--}
-
--- Check that -XTemplateHaskellQuotes is enabled and available
-checkForTemplateHaskellQuotes :: HsExpr GhcPs ->  RnM ()
-checkForTemplateHaskellQuotes e =
-    do { thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes
-       ; unless thQuotesEnabled $
-           failWith ( mkTcRnUnknownMessage $ mkPlainError noHints $ vcat
-                      [ text "Syntax error on" <+> ppr e
-                      , text ("Perhaps you intended to use TemplateHaskell"
-                              ++ " or TemplateHaskellQuotes") ] )
-       }
-
-rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
-rnTypedBracket e br_body
-  = addErrCtxt (typedQuotationCtxtDoc br_body) $
-    do { checkForTemplateHaskellQuotes e
-
-         -- Check for nested brackets
-       ; cur_stage <- getStage
-       ; case cur_stage of
-           { Splice Typed   -> return ()
-           ; Splice Untyped -> failWithTc illegalTypedBracket
-           ; RunSplice _    ->
-               -- See Note [RunSplice ThLevel] in GHC.Tc.Types.
-               pprPanic "rnTypedBracket: Renaming typed bracket when running a splice"
-                        (ppr e)
-           ; Comp           -> return ()
-           ; Brack {}       -> failWithTc illegalBracket
-           }
-
-         -- Brackets are desugared to code that mentions the TH package
-       ; recordThUse
-
-       ; traceRn "Renaming typed TH bracket" empty
-       ; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rnLExpr br_body
-
-       ; return (HsTypedBracket noExtField body', fvs_e)
-
-       }
-
-rnUntypedBracket :: HsExpr GhcPs -> HsQuote GhcPs -> RnM (HsExpr GhcRn, FreeVars)
-rnUntypedBracket e br_body
-  = addErrCtxt (untypedQuotationCtxtDoc br_body) $
-    do { checkForTemplateHaskellQuotes e
-
-         -- Check for nested brackets
-       ; cur_stage <- getStage
-       ; case cur_stage of
-           { Splice Typed   -> failWithTc illegalUntypedBracket
-           ; Splice Untyped -> return ()
-           ; RunSplice _    ->
-               -- See Note [RunSplice ThLevel] in GHC.Tc.Types.
-               pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice"
-                        (ppr e)
-           ; Comp           -> return ()
-           ; Brack {}       -> failWithTc illegalBracket
-           }
-
-         -- Brackets are desugared to code that mentions the TH package
-       ; recordThUse
-
-       ; traceRn "Renaming untyped TH bracket" empty
-       ; ps_var <- newMutVar []
-       ; (body', fvs_e) <-
-         -- See Note [Rebindable syntax and Template Haskell]
-         unsetXOptM LangExt.RebindableSyntax $
-         setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
-                  rn_utbracket cur_stage br_body
-       ; pendings <- readMutVar ps_var
-       ; return (HsUntypedBracket pendings body', fvs_e)
-
-       }
-
-rn_utbracket :: ThStage -> HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)
-rn_utbracket outer_stage br@(VarBr x flg rdr_name)
-  = do { name <- lookupOccRn (unLoc rdr_name)
-       ; check_namespace flg name
-       ; this_mod <- getModule
-
-       ; when (flg && nameIsLocalOrFrom this_mod name) $
-             -- Type variables can be quoted in TH. See #5721.
-                 do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name
-                    ; case mb_bind_lvl of
-                        { Nothing -> return ()      -- Can happen for data constructors,
-                                                    -- but nothing needs to be done for them
-
-                        ; Just (top_lvl, bind_lvl)  -- See Note [Quoting names]
-                             | isTopLevel top_lvl
-                             -> when (isExternalName name) (keepAlive name)
-                             | otherwise
-                             -> do { traceRn "rn_utbracket VarBr"
-                                      (ppr name <+> ppr bind_lvl
-                                                <+> ppr outer_stage)
-                                   ; checkTc (thLevel outer_stage + 1 == bind_lvl)
-                                             (quotedNameStageErr br) }
-                        }
-                    }
-       ; return (VarBr x flg (noLocA name), unitFV name) }
-
-rn_utbracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e
-                                ; return (ExpBr x e', fvs) }
-
-rn_utbracket _ (PatBr x p)
-  = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs)
-
-rn_utbracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t
-                                ; return (TypBr x t', fvs) }
-
-rn_utbracket _ (DecBrL x decls)
-  = do { group <- groupDecls decls
-       ; gbl_env  <- getGblEnv
-       ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
-                          -- The emptyDUs is so that we just collect uses for this
-                          -- group alone in the call to rnSrcDecls below
-       ; (tcg_env, group') <- setGblEnv new_gbl_env $
-                              rnSrcDecls group
-
-              -- Discard the tcg_env; it contains only extra info about fixity
-        ; traceRn "rn_utbracket dec" (ppr (tcg_dus tcg_env) $$
-                   ppr (duUses (tcg_dus tcg_env)))
-        ; return (DecBrG x group', duUses (tcg_dus tcg_env)) }
-  where
-    groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
-    groupDecls decls
-      = do { (group, mb_splice) <- findSplice decls
-           ; case mb_splice of
-           { Nothing -> return group
-           ; Just (splice, rest) ->
-               do { group' <- groupDecls rest
-                  ; let group'' = appendGroups group group'
-                  ; return group'' { hs_splcds = noLocA splice : hs_splcds group' }
-                  }
-           }}
-
-rn_utbracket _ (DecBrG {}) = panic "rn_ut_bracket: unexpected DecBrG"
-
-
--- | Ensure that we are not using a term-level name in a type-level namespace
--- or vice-versa. Throws a 'TcRnIncorrectNameSpace' error if there is a problem.
-check_namespace :: Bool -> Name -> RnM ()
-check_namespace is_single_tick nm
-  = unless (isValNameSpace ns == is_single_tick) $
-      failWithTc $ (TcRnIncorrectNameSpace nm True)
-  where
-    ns = nameNameSpace nm
-
-typedQuotationCtxtDoc :: LHsExpr GhcPs -> SDoc
-typedQuotationCtxtDoc br_body
-  = hang (text "In the Template Haskell typed quotation")
-         2 (thTyBrackets . ppr $ br_body)
-
-untypedQuotationCtxtDoc :: HsQuote GhcPs -> SDoc
-untypedQuotationCtxtDoc br_body
-  = hang (text "In the Template Haskell quotation")
-         2 (ppr br_body)
-
-illegalBracket :: TcRnMessage
-illegalBracket = mkTcRnUnknownMessage $ mkPlainError noHints $
-    text "Template Haskell brackets cannot be nested" <+>
-    text "(without intervening splices)"
-
-illegalTypedBracket :: TcRnMessage
-illegalTypedBracket = mkTcRnUnknownMessage $ mkPlainError noHints $
-    text "Typed brackets may only appear in typed splices."
-
-illegalUntypedBracket :: TcRnMessage
-illegalUntypedBracket = mkTcRnUnknownMessage $ mkPlainError noHints $
-    text "Untyped brackets may only appear in untyped splices."
-
-quotedNameStageErr :: HsQuote GhcPs -> TcRnMessage
-quotedNameStageErr br
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    sep [ text "Stage error: the non-top-level quoted name" <+> ppr br
-        , text "must be used at the same stage at which it is bound" ]
-
-
-{-
-*********************************************************
-*                                                      *
-                Splices
-*                                                      *
-*********************************************************
-
-Note [Free variables of typed splices]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider renaming this:
-        f = ...
-        h = ...$(thing "f")...
-
-where the splice is a *typed* splice.  The splice can expand into
-literally anything, so when we do dependency analysis we must assume
-that it might mention 'f'.  So we simply treat all locally-defined
-names as mentioned by any splice.  This is terribly brutal, but I
-don't see what else to do.  For example, it'll mean that every
-locally-defined thing will appear to be used, so no unused-binding
-warnings.  But if we miss the dependency, then we might typecheck 'h'
-before 'f', and that will crash the type checker because 'f' isn't in
-scope.
-
-Currently, I'm not treating a splice as also mentioning every import,
-which is a bit inconsistent -- but there are a lot of them.  We might
-thereby get some bogus unused-import warnings, but we won't crash the
-type checker.  Not very satisfactory really.
-
-Note [Renamer errors]
-~~~~~~~~~~~~~~~~~~~~~
-It's important to wrap renamer calls in checkNoErrs, because the
-renamer does not fail for out of scope variables etc. Instead it
-returns a bogus term/type, so that it can report more than one error.
-We don't want the type checker to see these bogus unbound variables.
--}
-
-rnUntypedSpliceGen :: (HsUntypedSplice GhcRn -> RnM (a, FreeVars))
-                                                    -- Outside brackets, run splice
-                   -> (Name -> HsUntypedSplice GhcRn -> (PendingRnSplice, a))
-                                                   -- Inside brackets, make it pending
-                   -> HsUntypedSplice GhcPs
-                   -> RnM (a, FreeVars)
-rnUntypedSpliceGen run_splice pend_splice splice
-  = addErrCtxt (spliceCtxt splice) $ do
-    { stage <- getStage
-    ; case stage of
-        Brack _ RnPendingTyped
-          -> failWithTc illegalUntypedSplice
-
-        Brack pop_stage (RnPendingUntyped ps_var)
-          -> do { (splice', fvs) <- setStage pop_stage $
-                                    rnUntypedSplice splice
-                ; loc  <- getSrcSpanM
-                ; splice_name <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)
-                ; let (pending_splice, result) = pend_splice splice_name splice'
-                ; ps <- readMutVar ps_var
-                ; writeMutVar ps_var (pending_splice : ps)
-                ; return (result, fvs) }
-
-        _ ->  do { checkTopSpliceAllowed splice
-                 ; (splice', fvs1) <- checkNoErrs $
-                                      setStage (Splice Untyped) $
-                                      rnUntypedSplice splice
-                   -- checkNoErrs: don't attempt to run the splice if
-                   -- renaming it failed; otherwise we get a cascade of
-                   -- errors from e.g. unbound variables
-                 ; (result, fvs2) <- run_splice splice'
-                 ; return (result, fvs1 `plusFV` fvs2) } }
-
-
--- Nested splices are fine without TemplateHaskell because they
--- are not executed until the top-level splice is run.
-checkTopSpliceAllowed :: HsUntypedSplice GhcPs -> RnM ()
-checkTopSpliceAllowed splice = do
-  let (herald, ext) = spliceExtension splice
-  extEnabled <- xoptM ext
-  unless extEnabled
-    (failWith $ mkTcRnUnknownMessage $ mkPlainError noHints $
-       text herald <+> text "are not permitted without" <+> ppr ext)
-  where
-     spliceExtension :: HsUntypedSplice GhcPs -> (String, LangExt.Extension)
-     spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes)
-     spliceExtension (HsUntypedSpliceExpr {}) = ("Top-level splices", LangExt.TemplateHaskell)
-
-------------------
-
--- | Returns the result of running a splice and the modFinalizers collected
--- during the execution.
---
--- See Note [Delaying modFinalizers in untyped splices].
-runRnSplice :: UntypedSpliceFlavour
-            -> (LHsExpr GhcTc -> TcRn res)
-            -> (res -> SDoc)    -- How to pretty-print res
-                                -- Usually just ppr, but not for [Decl]
-            -> HsUntypedSplice GhcRn
-            -> TcRn (res, [ForeignRef (TH.Q ())])
-runRnSplice flavour run_meta ppr_res splice
-  = do { hooks <- hsc_hooks <$> getTopEnv
-       ; splice' <- case runRnSpliceHook hooks of
-            Nothing -> return splice
-            Just h  -> h splice
-
-       ; let the_expr = case splice' of
-                HsUntypedSpliceExpr _ e ->  e
-                HsQuasiQuote _ q str -> mkQuasiQuoteExpr flavour q str
-
-             -- Typecheck the expression
-       ; meta_exp_ty   <- tcMetaTy meta_ty_name
-       ; zonked_q_expr <- zonkTopLExpr =<<
-                            tcTopSpliceExpr Untyped
-                              (tcCheckPolyExpr the_expr meta_exp_ty)
-
-             -- Run the expression
-       ; mod_finalizers_ref <- newTcRef []
-       ; result <- setStage (RunSplice mod_finalizers_ref) $
-                     run_meta zonked_q_expr
-       ; mod_finalizers <- readTcRef mod_finalizers_ref
-       ; traceSplice (SpliceInfo { spliceDescription = what
-                                 , spliceIsDecl      = is_decl
-                                 , spliceSource      = Just the_expr
-                                 , spliceGenerated   = ppr_res result })
-
-       ; return (result, mod_finalizers) }
-
-  where
-    meta_ty_name = case flavour of
-                       UntypedExpSplice  -> expQTyConName
-                       UntypedPatSplice  -> patQTyConName
-                       UntypedTypeSplice -> typeQTyConName
-                       UntypedDeclSplice -> decsQTyConName
-    what = case flavour of
-                  UntypedExpSplice  -> "expression"
-                  UntypedPatSplice  -> "pattern"
-                  UntypedTypeSplice -> "type"
-                  UntypedDeclSplice -> "declarations"
-    is_decl = case flavour of
-                 UntypedDeclSplice -> True
-                 _                 -> False
-
-------------------
-makePending :: UntypedSpliceFlavour
-            -> Name
-            -> HsUntypedSplice GhcRn
-            -> PendingRnSplice
-makePending flavour n (HsUntypedSpliceExpr _ e)
-  = PendingRnSplice flavour n e
-makePending flavour n (HsQuasiQuote _ quoter quote)
-  = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter quote)
-
-------------------
-mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name
-                 -> XRec GhcPs FastString
-                 -> LHsExpr GhcRn
--- Return the expression (quoter "...quote...")
--- which is what we must run in a quasi-quote
-mkQuasiQuoteExpr flavour quoter (L q_span' quote)
-  = L q_span $ HsApp noComments (L q_span
-             $ HsApp noComments (L q_span
-                    (HsVar noExtField (L (la2na q_span) quote_selector)))
-                                quoterExpr)
-                    quoteExpr
-  where
-    q_span = noAnnSrcSpan (locA q_span')
-    quoterExpr = L q_span $! HsVar noExtField $! (L (la2na q_span) quoter)
-    quoteExpr  = L q_span $! HsLit noComments $! HsString NoSourceText quote
-    quote_selector = case flavour of
-                       UntypedExpSplice  -> quoteExpName
-                       UntypedPatSplice  -> quotePatName
-                       UntypedTypeSplice -> quoteTypeName
-                       UntypedDeclSplice -> quoteDecName
-
----------------------
-unqualSplice :: RdrName
--- The RdrName for a SplicePointName.  See GHC.Hs.Expr
--- Note [Lifecycle of an untyped splice, and PendingRnSplice]
--- We use "spn" (which is arbitrary) because it is brief but grepable-for.
-unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "spn"))
-
-rnUntypedSplice :: HsUntypedSplice GhcPs -> RnM (HsUntypedSplice GhcRn, FreeVars)
--- Not exported...used for all
-rnUntypedSplice (HsUntypedSpliceExpr annCo expr)
-  = do  { (expr', fvs) <- rnLExpr expr
-        ; return (HsUntypedSpliceExpr annCo expr', fvs) }
-
-rnUntypedSplice (HsQuasiQuote ext quoter quote)
-  = do  { -- Rename the quoter; akin to the HsVar case of rnExpr
-        ; quoter' <- lookupOccRn quoter
-        ; this_mod <- getModule
-        ; when (nameIsLocalOrFrom this_mod quoter') $
-          checkThLocalName quoter'
-
-        ; return (HsQuasiQuote ext quoter' quote, unitFV quoter') }
-
----------------------
-rnTypedSplice :: LHsExpr GhcPs -- Typed splice expression
-              -> RnM (HsExpr GhcRn, FreeVars)
-rnTypedSplice expr
-  = addErrCtxt (hang (text "In the typed splice:") 2 (pprTypedSplice Nothing expr)) $ do
-    { stage <- getStage
-    ; case stage of
-        Brack pop_stage RnPendingTyped
-          -> setStage pop_stage rn_splice
-
-        Brack _ (RnPendingUntyped _)
-          -> failWithTc illegalTypedSplice
-
-        _ -> do { extEnabled <- xoptM LangExt.TemplateHaskell
-                ; unless extEnabled
-                    (failWith $ mkTcRnUnknownMessage $ mkPlainError noHints $
-                       text "Top-level splices are not permitted without"
-                         <+> ppr LangExt.TemplateHaskell)
-
-                ; (result, fvs1) <- checkNoErrs $ setStage (Splice Typed) rn_splice
-                  -- checkNoErrs: don't attempt to run the splice if
-                  -- renaming it failed; otherwise we get a cascade of
-                  -- errors from e.g. unbound variables
-
-                  -- Run typed splice later, in the type checker
-                  -- Ugh!  See Note [Free variables of typed splices] above
-                ; traceRn "rnTypedSplice: typed expression splice" empty
-                ; lcl_rdr <- getLocalRdrEnv
-                ; gbl_rdr <- getGlobalRdrEnv
-                ; let gbl_names = mkNameSet [greMangledName gre | gre <- globalRdrEnvElts gbl_rdr
-                                                          , isLocalGRE gre]
-                      lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
-                      fvs2      = lcl_names `plusFV` gbl_names
-
-                ; return (result, fvs1 `plusFV` fvs2) } }
-  where
-    rn_splice :: RnM (HsExpr GhcRn, FreeVars)
-    rn_splice =
-      do { loc <- getSrcSpanM
-         -- The renamer allocates a splice-point name to every typed splice
-         -- (incl the top level ones for which it will not ultimately be used)
-         ; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)
-         ; (expr', fvs) <- rnLExpr expr
-         ; return (HsTypedSplice n' expr', fvs) }
-
-rnUntypedSpliceExpr :: HsUntypedSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)
-rnUntypedSpliceExpr splice
-  = rnUntypedSpliceGen run_expr_splice pend_expr_splice splice
-  where
-    pend_expr_splice :: Name -> HsUntypedSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)
-    pend_expr_splice name rn_splice
-        = (makePending UntypedExpSplice name rn_splice, HsUntypedSplice (HsUntypedSpliceNested name) rn_splice)
-
-    run_expr_splice :: HsUntypedSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)
-    run_expr_splice rn_splice
-      = do { traceRn "rnUntypedSpliceExpr: untyped expression splice" empty
-             -- Run it here, see Note [Running splices in the Renamer]
-           ; (rn_expr, mod_finalizers) <-
-                runRnSplice UntypedExpSplice runMetaE ppr rn_splice
-           ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
-             -- See Note [Delaying modFinalizers in untyped splices].
-           ; let e =  flip HsUntypedSplice rn_splice
-                    . HsUntypedSpliceTop (ThModFinalizers mod_finalizers)
-                        <$> lexpr3
-           ; return (gHsPar e, fvs)
-           }
-
-{- Note [Running splices in the Renamer]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Splices used to be run in the typechecker, which led to (#4364). Since the
-renamer must decide which expressions depend on which others, and it cannot
-reliably do this for arbitrary splices, we used to conservatively say that
-splices depend on all other expressions in scope. Unfortunately, this led to
-the problem of cyclic type declarations seen in (#4364). Instead, by
-running splices in the renamer, we side-step the problem of determining
-dependencies: by the time the dependency analysis happens, any splices have
-already been run, and expression dependencies can be determined as usual.
-
-However, see (#9813), for an example where we would like to run splices
-*after* performing dependency analysis (that is, after renaming). It would be
-desirable to typecheck "non-splicy" expressions (those expressions that do not
-contain splices directly or via dependence on an expression that does) before
-"splicy" expressions, such that types/expressions within the same declaration
-group would be available to `reify` calls, for example consider the following:
-
-> module M where
->   data D = C
->   f = 1
->   g = $(mapM reify ['f, 'D, ''C] ...)
-
-Compilation of this example fails since D/C/f are not in the type environment
-and thus cannot be reified as they have not been typechecked by the time the
-splice is renamed and thus run.
-
-These requirements are at odds: we do not want to run splices in the renamer as
-we wish to first determine dependencies and typecheck certain expressions,
-making them available to reify, but cannot accurately determine dependencies
-without running splices in the renamer!
-
-Indeed, the conclusion of (#9813) was that it is not worth the complexity
-to try and
- a) implement and maintain the code for renaming/typechecking non-splicy
-    expressions before splicy expressions,
- b) explain to TH users which expressions are/not available to reify at any
-    given point.
-
--}
-
-{- Note [Rebindable syntax and Template Haskell]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When processing Template Haskell quotes with Rebindable Syntax (RS) enabled,
-there are two possibilities: apply the RS rules to the quotes or don't.
-
-One might expect that with {-# LANGUAGE RebindableSyntax #-} at the top of a
-module, any 'if' expression would end up being turned into a call to whatever
-'ifThenElse' function is in scope, regardless of whether the said if expression
-appears in "normal" Haskell code or in a TH quote. This however comes with its
-problems. Consider the following code:
-
-  {-# LANGUAGE TemplateHaskell, RebindableSyntax #-}
-
-  module X where
-
-  import Prelude ( Monad(..), Bool(..), print, ($) )
-  import Language.Haskell.TH.Syntax
-
-  $( do stuff <- [| if True then 10 else 15 |]
-        runIO $ print stuff
-        return [] )
-
-If we apply the RS rules, then GHC would complain about not having suitable
-fromInteger/ifThenElse functions in scope. But this quote is just a bit of
-Haskell syntax that has yet to be used, or, to put it differently, placed
-(spliced) in some context where the said functions might be available. More
-generally, untyped TH quotes are meant to work with yet-unbound identifiers.
-This tends to show that untyped TH and Rebindable Syntax overall don't play
-well together. Users still have the option to splice "normal" if expressions
-into modules where RS is enabled, to turn them into applications of
-an 'ifThenElse' function of their choice.
-
-Typed TH (TTH) quotes, on the other hand, come with different constraints. They
-don't quite have this "delayed" nature: we typecheck them while processing
-them, and TTH users expect RS to Just Work in their quotes, exactly like it does
-outside of the quotes. There, we do not have to accept unbound identifiers and
-we can apply the RS rules both in the typechecking and desugaring of the quotes
-without triggering surprising/bad behaviour for users. For instance, the
-following code is expected to be rejected (because of the lack of suitable
-'fromInteger'/'ifThenElse' functions in scope):
-
-  {-# LANGUAGE TemplateHaskell, RebindableSyntax #-}
-
-  module X where
-
-  import Prelude ( Monad(..), Bool(..), print, ($) )
-  import Language.Haskell.TH.Syntax
-
-  $$( do stuff <- [|| if True then 10 else 15 ||]
-         runIO $ print stuff
-         return [] )
-
-The conclusion is that even if RS is enabled for a given module, GHC disables it
-when processing untyped TH quotes from that module, to avoid the aforementioned
-problems, but keeps it on while processing typed TH quotes.
-
-This note and approach originated in #18102.
-
--}
-
-{- Note [Delaying modFinalizers in untyped splices]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-When splices run in the renamer, 'reify' does not have access to the local
-type environment (#11832, [1]).
-
-For instance, in
-
-> let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |])
-
-'reify' cannot find @x@, because the local type environment is not yet
-populated. To address this, we allow 'reify' execution to be deferred with
-'addModFinalizer'.
-
-> let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print)
-                    [| return () |]
-                )
-
-The finalizer is run with the local type environment when type checking is
-complete.
-
-Since the local type environment is not available in the renamer, we annotate
-the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where
-@e@ is the result of splicing and @finalizers@ are the finalizers that have been
-collected during evaluation of the splice [3]. In our example,
-
-> HsLet
->   (x = e)
->   (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print]
->                          (HsSplicedExpr $ return ())
->   )
-
-When the typechecker finds the annotation, it inserts the finalizers in the
-global environment and exposes the current local environment to them [4, 5, 6].
-
-> addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print]
-
-References:
-
-[1] https://gitlab.haskell.org/ghc/ghc/wikis/template-haskell/reify
-[2] 'rnSpliceExpr'
-[3] 'GHC.Tc.Gen.Splice.qAddModFinalizer'
-[4] 'GHC.Tc.Gen.Expr.tcExpr' ('HsSpliceE' ('HsSpliced' ...))
-[5] 'GHC.Tc.Gen.HsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...))
-[6] 'GHC.Tc.Gen.Pat.tc_pat' ('SplicePat' ('HsSpliced' ...))
-
--}
-
-----------------------
-rnSpliceType :: HsUntypedSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
-rnSpliceType splice
-  = rnUntypedSpliceGen run_type_splice pend_type_splice splice
-  where
-    pend_type_splice name rn_splice
-       = ( makePending UntypedTypeSplice name rn_splice
-         , HsSpliceTy (HsUntypedSpliceNested name) rn_splice)
-
-    run_type_splice :: HsUntypedSplice GhcRn -> RnM (HsType GhcRn, FreeVars)
-    run_type_splice rn_splice
-      = do { traceRn "rnSpliceType: untyped type splice" empty
-           ; (hs_ty2, mod_finalizers) <-
-                runRnSplice UntypedTypeSplice runMetaT ppr rn_splice
-           ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2
-                                 ; checkNoErrs $ rnLHsType doc hs_ty2 }
-                                         -- checkNoErrs: see Note [Renamer errors]
-
-             -- See Note [Delaying modFinalizers in untyped splices].
-           ; return ( HsSpliceTy (HsUntypedSpliceTop (ThModFinalizers mod_finalizers)
-                                                     (mb_paren hs_ty3))
-                                 rn_splice
-                    , fvs
-                    ) }
-              -- Wrap the result of the splice in parens so that we don't
-              -- lose the outermost location set by runQuasiQuote (#7918)
-
-    -- Wrap a non-atomic result in HsParTy parens;
-    -- but not if it's atomic to avoid double parens for operators
-    -- This is to account for, say  foo :: $(blah) -> Int
-    -- when we want $(blah) to expand to (this -> that), with parens.
-    -- Sadly, it's awkward add precisely the correct parens, because
-    -- that depends on the context.
-    mb_paren :: LHsType GhcRn -> LHsType GhcRn
-    mb_paren lhs_ty@(L loc hs_ty)
-      | hsTypeNeedsParens maxPrec hs_ty = L loc (HsParTy noAnn lhs_ty)
-      | otherwise                       = lhs_ty
-
-{- Note [Partial Type Splices]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Partial Type Signatures are partially supported in TH type splices: only
-anonymous wild cards are allowed.
-
-  -- ToDo: SLPJ says: I don't understand all this
-
-Normally, named wild cards are collected before renaming a (partial) type
-signature. However, TH type splices are run during renaming, i.e. after the
-initial traversal, leading to out of scope errors for named wild cards. We
-can't just extend the initial traversal to collect the named wild cards in TH
-type splices, as we'd need to expand them, which is supposed to happen only
-once, during renaming.
-
-Similarly, the extra-constraints wild card is handled right before renaming
-too, and is therefore also not supported in a TH type splice. Another reason
-to forbid extra-constraints wild cards in TH type splices is that a single
-signature can contain many TH type splices, whereas it mustn't contain more
-than one extra-constraints wild card. Enforcing would this be hard the way
-things are currently organised.
-
-Anonymous wild cards pose no problem, because they start out without names and
-are given names during renaming. These names are collected right after
-renaming. The names generated for anonymous wild cards in TH type splices will
-thus be collected as well.
-
-For more details about renaming wild cards, see GHC.Rename.HsType.rnHsSigWcType
-
-Note that partial type signatures are fully supported in TH declaration
-splices, e.g.:
-
-     [d| foo :: _ => _
-         foo x y = x == y |]
-
-This is because in this case, the partial type signature can be treated as a
-whole signature, instead of as an arbitrary type.
-
--}
-
-
-----------------------
--- | Rename a splice pattern. See Note [rnSplicePat]
-rnSplicePat :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs))
-                                            , FreeVars)
-rnSplicePat splice
-  = rnUntypedSpliceGen run_pat_splice pend_pat_splice splice
-  where
-    pend_pat_splice name rn_splice
-      = (makePending UntypedPatSplice name rn_splice
-        , (rn_splice, HsUntypedSpliceNested name)) -- Pat splice is nested and thus simply renamed
-
-    run_pat_splice rn_splice
-      = do { traceRn "rnSplicePat: untyped pattern splice" empty
-           ; (pat, mod_finalizers) <-
-                runRnSplice UntypedPatSplice runMetaP ppr rn_splice
-             -- See Note [Delaying modFinalizers in untyped splices].
-           ; let p = HsUntypedSpliceTop (ThModFinalizers mod_finalizers) pat
-           ; return ((rn_splice, p), emptyFVs) }
-              -- Wrap the result of the quasi-quoter in parens so that we don't
-              -- lose the outermost location set by runQuasiQuote (#7918)
-
-----------------------
-rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
-rnSpliceDecl (SpliceDecl _ (L loc splice) flg)
-  = rnUntypedSpliceGen run_decl_splice pend_decl_splice splice
-  where
-    pend_decl_splice name rn_splice
-       = ( makePending UntypedDeclSplice name rn_splice
-         , SpliceDecl noExtField (L loc rn_splice) flg)
-
-    run_decl_splice rn_splice  = pprPanic "rnSpliceDecl" (pprUntypedSplice True Nothing rn_splice)
-
-rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
--- Declaration splice at the very top level of the module
-rnTopSpliceDecls splice
-   =  do { checkTopSpliceAllowed splice
-         ; (rn_splice, fvs) <- checkNoErrs $
-                               setStage (Splice Untyped) $
-                               rnUntypedSplice splice
-           -- As always, be sure to checkNoErrs above lest we end up with
-           -- holes making it to typechecking, hence #12584.
-           --
-           -- Note that we cannot call checkNoErrs for the whole duration
-           -- of rnTopSpliceDecls. The reason is that checkNoErrs changes
-           -- the local environment to temporarily contain a new
-           -- reference to store errors, and add_mod_finalizers would
-           -- cause this reference to be stored after checkNoErrs finishes.
-           -- This is checked by test TH_finalizer.
-         ; traceRn "rnTopSpliceDecls: untyped declaration splice" empty
-         ; (decls, mod_finalizers) <- checkNoErrs $
-               runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice
-         ; add_mod_finalizers_now mod_finalizers
-         ; return (decls,fvs) }
-   where
-     ppr_decls :: [LHsDecl GhcPs] -> SDoc
-     ppr_decls ds = vcat (map ppr ds)
-
-     -- Adds finalizers to the global environment instead of delaying them
-     -- to the type checker.
-     --
-     -- Declaration splices do not have an interesting local environment so
-     -- there is no point in delaying them.
-     --
-     -- See Note [Delaying modFinalizers in untyped splices].
-     add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn ()
-     add_mod_finalizers_now []             = return ()
-     add_mod_finalizers_now mod_finalizers = do
-       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
-       env <- getLclEnv
-       updTcRef th_modfinalizers_var $ \fins ->
-         (env, ThModFinalizers mod_finalizers) : fins
-
-
-{-
-Note [rnSplicePat]
-~~~~~~~~~~~~~~~~~~
-Renaming a pattern splice is a bit tricky, because we need the variables
-bound in the pattern to be in scope in the RHS of the pattern. This scope
-management is effectively done by using continuation-passing style in
-GHC.Rename.Pat, through the CpsRn monad. We don't wish to be in that monad here
-(it would create import cycles and generally conflict with renaming other
-splices), so we really want to return a (Pat GhcPs) -- the result of
-running the splice -- which can then be further renamed in GHC.Rename.Pat, in
-the CpsRn monad.
-
-The problem is that if we're renaming a splice within a bracket, we
-*don't* want to run the splice now. We really do just want to rename
-it to an HsUntypedSplice Name. Of course, then we can't know what variables
-are bound within the splice. So we accept any unbound variables and
-rename them again when the bracket is spliced in.  If a variable is brought
-into scope by a pattern splice all is fine.  If it is not then an error is
-reported.
-
-In any case, when we're done in rnSplicePat, we'll have both the renamed
-splice, and either a Pat RdrName and ThModFinalizers (the result of running a
-top-level splice) or a splice point name. Thus, rnSplicePat returns both
-HsUntypedSplice GhcRn, and HsUntypedSpliceResult (Pat GhcPs) -- which models
-the existence of either the result of running the splice (HsUntypedSpliceTop),
-or its splice point name if nested (HsUntypedSpliceNested)
--}
-
-spliceCtxt :: HsUntypedSplice GhcPs -> SDoc
-spliceCtxt splice
-  = hang (text "In the" <+> what) 2 (pprUntypedSplice True Nothing splice)
-  where
-    what = case splice of
-             HsUntypedSpliceExpr {} -> text "untyped splice:"
-             HsQuasiQuote        {} -> text "quasi-quotation:"
-
--- | The splice data to be logged
-data SpliceInfo
-  = SpliceInfo
-    { spliceDescription  :: String
-    , spliceSource       :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls
-                                                  --        added by addTopDecls
-    , spliceIsDecl       :: Bool    -- True <=> put the generate code in a file
-                                    --          when -dth-dec-file is on
-    , spliceGenerated    :: SDoc
-    }
-        -- Note that 'spliceSource' is *renamed* but not *typechecked*
-        -- Reason (a) less typechecking crap
-        --        (b) data constructors after type checking have been
-        --            changed to their *wrappers*, and that makes them
-        --            print always fully qualified
-
--- | outputs splice information for 2 flags which have different output formats:
--- `-ddump-splices` and `-dth-dec-file`
-traceSplice :: SpliceInfo -> TcM ()
-traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src
-                        , spliceGenerated = gen, spliceIsDecl = is_decl })
-  = do loc <- case mb_src of
-                 Nothing        -> getSrcSpanM
-                 Just (L loc _) -> return (locA loc)
-       traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)
-
-       when is_decl $ do -- Raw material for -dth-dec-file
-        logger <- getLogger
-        liftIO $ putDumpFileMaybe logger Opt_D_th_dec_file "" FormatHaskell (spliceCodeDoc loc)
-  where
-    -- `-ddump-splices`
-    spliceDebugDoc :: SrcSpan -> SDoc
-    spliceDebugDoc loc
-      = let code = case mb_src of
-                     Nothing -> ending
-                     Just e  -> nest 2 (ppr (stripParensLHsExpr e)) : ending
-            ending = [ text "======>", nest 2 gen ]
-        in  hang (ppr loc <> colon <+> text "Splicing" <+> text sd)
-               2 (sep code)
-
-    -- `-dth-dec-file`
-    spliceCodeDoc :: SrcSpan -> SDoc
-    spliceCodeDoc loc
-      = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd
-             , gen ]
-
-illegalTypedSplice :: TcRnMessage
-illegalTypedSplice = mkTcRnUnknownMessage $ mkPlainError noHints $
-  text "Typed splices may not appear in untyped brackets"
-
-illegalUntypedSplice :: TcRnMessage
-illegalUntypedSplice = mkTcRnUnknownMessage $ mkPlainError noHints $
-  text "Untyped splices may not appear in typed brackets"
-
-checkThLocalName :: Name -> RnM ()
-checkThLocalName name
-  | isUnboundName name   -- Do not report two errors for
-  = return ()            --   $(not_in_scope args)
-
-  | otherwise
-  = do  { traceRn "checkThLocalName" (ppr name)
-        ; mb_local_use <- getStageAndBindLevel name
-        ; case mb_local_use of {
-             Nothing -> return () ;  -- Not a locally-bound thing
-             Just (top_lvl, bind_lvl, use_stage) ->
-    do  { let use_lvl = thLevel use_stage
-        ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl
-        ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl
-                                               <+> ppr use_stage
-                                               <+> ppr use_lvl)
-        ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } }
-
---------------------------------------
-checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel
-                       -> Name -> TcM ()
--- We are inside brackets, and (use_lvl > bind_lvl)
--- Now we must check whether there's a cross-stage lift to do
--- Examples   \x -> [| x |]
---            [| map |]
---
--- This code is similar to checkCrossStageLifting in GHC.Tc.Gen.Expr, but
--- this is only run on *untyped* brackets.
-
-checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name
-  | Brack _ (RnPendingUntyped ps_var) <- use_stage   -- Only for untyped brackets
-  , use_lvl > bind_lvl                               -- Cross-stage condition
-  = check_cross_stage_lifting top_lvl name ps_var
-  | otherwise
-  = return ()
-
-check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()
-check_cross_stage_lifting top_lvl name ps_var
-  | isTopLevel top_lvl
-        -- Top-level identifiers in this module,
-        -- (which have External Names)
-        -- are just like the imported case:
-        -- no need for the 'lifting' treatment
-        -- E.g.  this is fine:
-        --   f x = x
-        --   g y = [| f 3 |]
-  = when (isExternalName name) (keepAlive name)
-    -- See Note [Keeping things alive for Template Haskell]
-
-  | otherwise
-  =     -- Nested identifiers, such as 'x' in
-        -- E.g. \x -> [| h x |]
-        -- We must behave as if the reference to x was
-        --      h $(lift x)
-        -- We use 'x' itself as the SplicePointName, used by
-        -- the desugarer to stitch it all back together.
-        -- If 'x' occurs many times we may get many identical
-        -- bindings of the same SplicePointName, but that doesn't
-        -- matter, although it's a mite untidy.
-    do  { traceRn "checkCrossStageLifting" (ppr name)
-
-          -- Construct the (lift x) expression
-        ; let lift_expr   = nlHsApp (nlHsVar liftName) (nlHsVar name)
-              pend_splice = PendingRnSplice UntypedExpSplice name lift_expr
-
-          -- Warning for implicit lift (#17804)
-        ; addDetailedDiagnostic (TcRnImplicitLift name)
-
-          -- Update the pending splices
-        ; ps <- readMutVar ps_var
-        ; writeMutVar ps_var (pend_splice : ps) }
-
-{-
-Note [Keeping things alive for Template Haskell]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  f x = x+1
-  g y = [| f 3 |]
-
-Here 'f' is referred to from inside the bracket, which turns into data
-and mentions only f's *name*, not 'f' itself. So we need some other
-way to keep 'f' alive, lest it get dropped as dead code.  That's what
-keepAlive does. It puts it in the keep-alive set, which subsequently
-ensures that 'f' stays as a top level binding.
-
-This must be done by the renamer, not the type checker (as of old),
-because the type checker doesn't typecheck the body of untyped
-brackets (#8540).
-
-A thing can have a bind_lvl of outerLevel, but have an internal name:
-   foo = [d| op = 3
-             bop = op + 1 |]
-Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is
-bound inside a bracket.  That is because we don't even record
-binding levels for top-level things; the binding levels are in the
-LocalRdrEnv.
-
-So the occurrence of 'op' in the rhs of 'bop' looks a bit like a
-cross-stage thing, but it isn't really.  And in fact we never need
-to do anything here for top-level bound things, so all is fine, if
-a bit hacky.
-
-For these chaps (which have Internal Names) we don't want to put
-them in the keep-alive set.
-
-Note [Quoting names]
-~~~~~~~~~~~~~~~~~~~~
-A quoted name 'n is a bit like a quoted expression [| n |], except that we
-have no cross-stage lifting (c.f. GHC.Tc.Gen.Expr.thBrackId).  So, after incrementing
-the use-level to account for the brackets, the cases are:
-
-        bind > use                      Error
-        bind = use+1                    OK
-        bind < use
-                Imported things         OK
-                Top-level things        OK
-                Non-top-level           Error
-
-where 'use' is the binding level of the 'n quote. (So inside the implied
-bracket the level would be use+1.)
-
-Examples:
-
-  f 'map        -- OK; also for top-level defns of this module
-
-  \x. f 'x      -- Not ok (bind = 1, use = 1)
-                -- (whereas \x. f [| x |] might have been ok, by
-                --                               cross-stage lifting
-
-  \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1)
-
-  [| \x. $(f 'x) |]     -- OK (bind = 2, use = 1)
--}
diff --git a/compiler/GHC/Rename/Splice.hs-boot b/compiler/GHC/Rename/Splice.hs-boot
deleted file mode 100644
--- a/compiler/GHC/Rename/Splice.hs-boot
+++ /dev/null
@@ -1,13 +0,0 @@
-module GHC.Rename.Splice where
-
-import GHC.Hs
-import GHC.Tc.Utils.Monad
-import GHC.Types.Name.Set
-
-
-rnSpliceType :: HsUntypedSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
-rnSplicePat  :: HsUntypedSplice GhcPs -> RnM ( (HsUntypedSplice GhcRn, HsUntypedSpliceResult (LPat GhcPs))
-                                             , FreeVars)
-rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
-
-rnTopSpliceDecls :: HsUntypedSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs
deleted file mode 100644
--- a/compiler/GHC/Rename/Unbound.hs
+++ /dev/null
@@ -1,438 +0,0 @@
-{-# LANGUAGE PatternSynonyms #-}
-
-{-
-
-This module contains helper functions for reporting and creating
-unbound variables.
-
--}
-module GHC.Rename.Unbound
-   ( mkUnboundName
-   , mkUnboundNameRdr
-   , isUnboundName
-   , reportUnboundName
-   , reportUnboundName'
-   , unknownNameSuggestions
-   , WhatLooking(..)
-   , WhereLooking(..)
-   , LookingFor(..)
-   , unboundName
-   , unboundNameX
-   , notInScopeErr
-   , nameSpacesRelated
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique)
-import GHC.Utils.Misc
-
-import GHC.Data.Maybe
-import GHC.Data.FastString
-
-import qualified GHC.LanguageExtensions as LangExt
-
-import GHC.Types.Hint
-  ( GhcHint (SuggestExtension, RemindFieldSelectorSuppressed, ImportSuggestion, SuggestSimilarNames)
-  , LanguageExtensionHint (SuggestSingleExtension)
-  , ImportSuggestion(..), SimilarName(..), HowInScope(..) )
-import GHC.Types.SrcLoc as SrcLoc
-import GHC.Types.Name
-import GHC.Types.Name.Reader
-import GHC.Types.Unique.DFM (udfmToList)
-
-import GHC.Unit.Module
-import GHC.Unit.Module.Imported
-import GHC.Unit.Home.ModInfo
-
-import GHC.Data.Bag
-import GHC.Utils.Outputable (empty)
-
-import Data.List (sortBy, partition, nub)
-import Data.List.NonEmpty ( pattern (:|), NonEmpty )
-import Data.Function ( on )
-import qualified Data.Semigroup as S
-
-{-
-************************************************************************
-*                                                                      *
-               What to do when a lookup fails
-*                                                                      *
-************************************************************************
--}
-
--- What kind of suggestion are we looking for? #19843
-data WhatLooking = WL_Anything    -- Any binding
-                 | WL_Constructor -- Constructors and pattern synonyms
-                        -- E.g. in K { f1 = True }, if K is not in scope,
-                        -- suggest only constructors
-                 | WL_RecField    -- Record fields
-                        -- E.g. in K { f1 = True, f2 = False }, if f2 is not in
-                        -- scope, suggest only constructor fields
-                 | WL_None        -- No suggestions
-                        -- WS_None is used for rebindable syntax, where there
-                        -- is no point in suggesting alternative spellings
-                 deriving Eq
-
-data WhereLooking = WL_Anywhere   -- Any binding
-                  | WL_Global     -- Any top-level binding (local or imported)
-                  | WL_LocalTop   -- Any top-level binding in this module
-                  | WL_LocalOnly
-                        -- Only local bindings
-                        -- (pattern synonyms declarations,
-                        -- see Note [Renaming pattern synonym variables]
-                        -- in GHC.Rename.Bind)
-
-data LookingFor = LF { lf_which :: WhatLooking
-                     , lf_where :: WhereLooking
-                     }
-
-mkUnboundNameRdr :: RdrName -> Name
-mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)
-
-reportUnboundName' :: WhatLooking -> RdrName -> RnM Name
-reportUnboundName' what_look rdr = unboundName (LF what_look WL_Anywhere) rdr
-
-reportUnboundName :: RdrName -> RnM Name
-reportUnboundName = reportUnboundName' WL_Anything
-
-unboundName :: LookingFor -> RdrName -> RnM Name
-unboundName lf rdr = unboundNameX lf rdr []
-
-unboundNameX :: LookingFor -> RdrName -> [GhcHint] -> RnM Name
-unboundNameX looking_for rdr_name hints
-  = do  { dflags <- getDynFlags
-        ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags
-              err = notInScopeErr (lf_where looking_for) rdr_name
-        ; if not show_helpful_errors
-          then addErr $ TcRnNotInScope err rdr_name [] hints
-          else do { local_env  <- getLocalRdrEnv
-                  ; global_env <- getGlobalRdrEnv
-                  ; impInfo <- getImports
-                  ; currmod <- getModule
-                  ; hpt <- getHpt
-                  ; let (imp_errs, suggs) =
-                          unknownNameSuggestions_ looking_for
-                            dflags hpt currmod global_env local_env impInfo
-                            rdr_name
-                  ; addErr $
-                      TcRnNotInScope err rdr_name imp_errs (hints ++ suggs) }
-        ; return (mkUnboundNameRdr rdr_name) }
-
-
-notInScopeErr :: WhereLooking -> RdrName -> NotInScopeError
-notInScopeErr where_look rdr_name
-  | Just name <- isExact_maybe rdr_name
-  = NoExactName name
-  | WL_LocalTop <- where_look
-  = NoTopLevelBinding
-  | otherwise
-  = NotInScope
-
--- | Called from the typechecker ("GHC.Tc.Errors") when we find an unbound variable
-unknownNameSuggestions :: WhatLooking -> DynFlags
-                       -> HomePackageTable -> Module
-                       -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails
-                       -> RdrName -> ([ImportError], [GhcHint])
-unknownNameSuggestions what_look = unknownNameSuggestions_ (LF what_look WL_Anywhere)
-
-unknownNameSuggestions_ :: LookingFor -> DynFlags
-                       -> HomePackageTable -> Module
-                       -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails
-                       -> RdrName -> ([ImportError], [GhcHint])
-unknownNameSuggestions_ looking_for dflags hpt curr_mod global_env local_env
-                          imports tried_rdr_name = (imp_errs, suggs)
-  where
-    suggs = mconcat
-      [ if_ne (SuggestSimilarNames tried_rdr_name) $
-          similarNameSuggestions looking_for dflags global_env local_env tried_rdr_name
-      , map ImportSuggestion imp_suggs
-      , extensionSuggestions tried_rdr_name
-      , fieldSelectorSuggestions global_env tried_rdr_name ]
-    (imp_errs, imp_suggs) = importSuggestions looking_for global_env hpt curr_mod imports tried_rdr_name
-
-    if_ne :: (NonEmpty a -> b) -> [a] -> [b]
-    if_ne _ []       = []
-    if_ne f (a : as) = [f (a :| as)]
-
--- | When the name is in scope as field whose selector has been suppressed by
--- NoFieldSelectors, display a helpful message explaining this.
-fieldSelectorSuggestions :: GlobalRdrEnv -> RdrName -> [GhcHint]
-fieldSelectorSuggestions global_env tried_rdr_name
-  | null gres = []
-  | otherwise = [RemindFieldSelectorSuppressed tried_rdr_name parents]
-  where
-    gres = filter isNoFieldSelectorGRE $
-               lookupGRE_RdrName' tried_rdr_name global_env
-    parents = [ parent | ParentIs parent <- map gre_par gres ]
-
-similarNameSuggestions :: LookingFor -> DynFlags
-                       -> GlobalRdrEnv -> LocalRdrEnv
-                       -> RdrName -> [SimilarName]
-similarNameSuggestions looking_for@(LF what_look where_look) dflags global_env
-                       local_env tried_rdr_name
-  = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities
-  where
-    all_possibilities :: [(String, SimilarName)]
-    all_possibilities = case what_look of
-      WL_None -> []
-      _ -> [ (showPpr dflags r, SimilarRdrName r (LocallyBoundAt loc))
-           | (r,loc) <- local_possibilities local_env ]
-        ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]
-
-    tried_occ     = rdrNameOcc tried_rdr_name
-    tried_is_sym  = isSymOcc tried_occ
-    tried_ns      = occNameSpace tried_occ
-    tried_is_qual = isQual tried_rdr_name
-
-    correct_name_space occ =
-      (nameSpacesRelated dflags what_look tried_ns (occNameSpace occ))
-      && isSymOcc occ == tried_is_sym
-        -- Treat operator and non-operators as non-matching
-        -- This heuristic avoids things like
-        --      Not in scope 'f'; perhaps you meant '+' (from Prelude)
-
-    local_ok = case where_look of { WL_Anywhere  -> True
-                                  ; WL_LocalOnly -> True
-                                  ; _            -> False }
-
-    local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)]
-    local_possibilities env
-      | tried_is_qual = []
-      | not local_ok  = []
-      | otherwise     = [ (mkRdrUnqual occ, nameSrcSpan name)
-                        | name <- localRdrEnvElts env
-                        , let occ = nameOccName name
-                        , correct_name_space occ]
-
-    global_possibilities :: GlobalRdrEnv -> [(RdrName, SimilarName)]
-    global_possibilities global_env
-      | tried_is_qual = [ (rdr_qual, SimilarRdrName rdr_qual how)
-                        | gre <- globalRdrEnvElts global_env
-                        , isGreOk looking_for gre
-                        , let occ = greOccName gre
-                        , correct_name_space occ
-                        , (mod, how) <- qualsInScope gre
-                        , let rdr_qual = mkRdrQual mod occ ]
-
-      | otherwise = [ (rdr_unqual, sim)
-                    | gre <- globalRdrEnvElts global_env
-                    , isGreOk looking_for gre
-                    , let occ = greOccName gre
-                          rdr_unqual = mkRdrUnqual occ
-                    , correct_name_space occ
-                    , sim <- case (unquals_in_scope gre, quals_only gre) of
-                                (how:_, _)    -> [ SimilarRdrName rdr_unqual how ]
-                                ([],    pr:_) -> [ pr ]  -- See Note [Only-quals]
-                                ([],    [])   -> [] ]
-
-              -- Note [Only-quals]
-              -- ~~~~~~~~~~~~~~~~~
-              -- The second alternative returns those names with the same
-              -- OccName as the one we tried, but live in *qualified* imports
-              -- e.g. if you have:
-              --
-              -- > import qualified Data.Map as Map
-              -- > foo :: Map
-              --
-              -- then we suggest @Map.Map@.
-
-    --------------------
-    unquals_in_scope :: GlobalRdrElt -> [HowInScope]
-    unquals_in_scope (gre@GRE { gre_lcl = lcl, gre_imp = is })
-      | lcl       = [ LocallyBoundAt (greDefinitionSrcSpan gre) ]
-      | otherwise = [ ImportedBy ispec
-                    | i <- bagToList is, let ispec = is_decl i
-                    , not (is_qual ispec) ]
-
-
-    --------------------
-    quals_only :: GlobalRdrElt -> [SimilarName]
-    -- Ones for which *only* the qualified version is in scope
-    quals_only (gre@GRE { gre_imp = is })
-      = [ (SimilarRdrName (mkRdrQual (is_as ispec) (greOccName gre)) (ImportedBy ispec))
-        | i <- bagToList is, let ispec = is_decl i, is_qual ispec ]
-
-
--- | Generate errors and helpful suggestions if a qualified name Mod.foo is not in scope.
-importSuggestions :: LookingFor
-                  -> GlobalRdrEnv
-                  -> HomePackageTable -> Module
-                  -> ImportAvails -> RdrName -> ([ImportError], [ImportSuggestion])
-importSuggestions looking_for global_env hpt currMod imports rdr_name
-  | WL_LocalOnly <- lf_where looking_for       = ([], [])
-  | WL_LocalTop  <- lf_where looking_for       = ([], [])
-  | not (isQual rdr_name || isUnqual rdr_name) = ([], [])
-  | null interesting_imports
-  , Just name <- mod_name
-  , show_not_imported_line name
-  = ([MissingModule name], [])
-  | is_qualified
-  , null helpful_imports
-  , (mod : mods) <- map fst interesting_imports
-  = ([ModulesDoNotExport (mod :| mods) occ_name], [])
-  | mod : mods <- helpful_imports_non_hiding
-  = ([], [CouldImportFrom (mod :| mods) occ_name])
-  | mod : mods <- helpful_imports_hiding
-  = ([], [CouldUnhideFrom (mod :| mods) occ_name])
-  | otherwise
-  = ([], [])
- where
-  is_qualified = isQual rdr_name
-  (mod_name, occ_name) = case rdr_name of
-    Unqual occ_name        -> (Nothing, occ_name)
-    Qual mod_name occ_name -> (Just mod_name, occ_name)
-    _                      -> error "importSuggestions: dead code"
-
-
-  -- What import statements provide "Mod" at all
-  -- or, if this is an unqualified name, are not qualified imports
-  interesting_imports = [ (mod, imp)
-    | (mod, mod_imports) <- moduleEnvToList (imp_mods imports)
-    , Just imp <- return $ pick (importedByUser mod_imports)
-    ]
-
-  -- We want to keep only one for each original module; preferably one with an
-  -- explicit import list (for no particularly good reason)
-  pick :: [ImportedModsVal] -> Maybe ImportedModsVal
-  pick = listToMaybe . sortBy cmp . filter select
-    where select imv = case mod_name of Just name -> imv_name imv == name
-                                        Nothing   -> not (imv_qualified imv)
-          cmp = on compare imv_is_hiding S.<> on SrcLoc.leftmost_smallest imv_span
-
-  -- Which of these would export a 'foo'
-  -- (all of these are restricted imports, because if they were not, we
-  -- wouldn't have an out-of-scope error in the first place)
-  helpful_imports = filter helpful interesting_imports
-    where helpful (_,imv)
-            = any (isGreOk looking_for) $
-              lookupGlobalRdrEnv (imv_all_exports imv) occ_name
-
-  -- Which of these do that because of an explicit hiding list resp. an
-  -- explicit import list
-  (helpful_imports_hiding, helpful_imports_non_hiding)
-    = partition (imv_is_hiding . snd) helpful_imports
-
-  -- See Note [When to show/hide the module-not-imported line]
-  show_not_imported_line :: ModuleName -> Bool                    -- #15611
-  show_not_imported_line modnam
-      | modnam `elem` glob_mods               = False    -- #14225     -- 1
-      | moduleName currMod == modnam          = False                  -- 2.1
-      | is_last_loaded_mod modnam hpt_uniques = False                  -- 2.2
-      | otherwise                             = True
-    where
-      hpt_uniques = map fst (udfmToList hpt)
-      is_last_loaded_mod modnam uniqs = lastMaybe uniqs == Just (getUnique modnam)
-      glob_mods = nub [ mod
-                     | gre <- globalRdrEnvElts global_env
-                     , (mod, _) <- qualsInScope gre
-                     ]
-
-extensionSuggestions :: RdrName -> [GhcHint]
-extensionSuggestions rdrName
-  | rdrName == mkUnqual varName (fsLit "mdo") ||
-    rdrName == mkUnqual varName (fsLit "rec")
-  = [SuggestExtension $ SuggestSingleExtension empty LangExt.RecursiveDo]
-  | otherwise
-  = []
-
-qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)]
--- Ones for which the qualified version is in scope
-qualsInScope gre@GRE { gre_lcl = lcl, gre_imp = is }
-      | lcl = case greDefinitionModule gre of
-                Nothing -> []
-                Just m  -> [(moduleName m, LocallyBoundAt (greDefinitionSrcSpan gre))]
-      | otherwise = [ (is_as ispec, ImportedBy ispec)
-                    | i <- bagToList is, let ispec = is_decl i ]
-
-isGreOk :: LookingFor -> GlobalRdrElt -> Bool
-isGreOk (LF what_look where_look) gre = what_ok && where_ok
-  where
-    -- when looking for record fields, what_ok checks whether the GRE is a
-    -- record field. Otherwise, it checks whether the GRE is a record field
-    -- defined in a module with -XNoFieldSelectors - it wouldn't be a useful
-    -- suggestion in that case.
-    what_ok  = case what_look of
-                 WL_RecField -> isRecFldGRE gre
-                 _           -> not (isNoFieldSelectorGRE gre)
-
-    where_ok = case where_look of
-                 WL_LocalTop  -> isLocalGRE gre
-                 WL_LocalOnly -> False
-                 _            -> True
-
--- see Note [Related name spaces]
-nameSpacesRelated :: DynFlags    -- ^ to find out whether -XDataKinds is enabled
-                  -> WhatLooking -- ^ What kind of name are we looking for
-                  -> NameSpace   -- ^ Name space of the original name
-                  -> NameSpace   -- ^ Name space of a name that might have been meant
-                  -> Bool
-nameSpacesRelated dflags what_looking ns ns'
-  = ns' `elem` ns : [ other_ns
-                    | (orig_ns, others) <- other_namespaces
-                    , ns == orig_ns
-                    , (other_ns, wls) <- others
-                    , what_looking `elem` WL_Anything : wls
-                    ]
-  where
-    -- explanation:
-    -- [(orig_ns, [(other_ns, what_looking_possibilities)])]
-    -- A particular other_ns is related if the original namespace is orig_ns
-    -- and what_looking is either WL_Anything or is one of
-    -- what_looking_possibilities
-    other_namespaces =
-      [ (varName  , [(dataName, [WL_Constructor])])
-      , (dataName , [(varName , [WL_RecField])])
-      , (tvName   , (tcClsName, [WL_Constructor]) : promoted_datacons)
-      , (tcClsName, (tvName   , []) : promoted_datacons)
-      ]
-    -- If -XDataKinds is enabled, the data constructor name space is also
-    -- related to the type-level name spaces
-    data_kinds = xopt LangExt.DataKinds dflags
-    promoted_datacons = [(dataName, [WL_Constructor]) | data_kinds]
-
-{-
-Note [Related name spaces]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Name spaces are related if there is a chance to mean the one when one writes
-the other, i.e. variables <-> data constructors and type variables <-> type
-constructors.
-
-In most contexts, this mistake can happen in both directions. Not so in
-patterns:
-
-When a user writes
-        foo (just a) = ...
-It is possible that they meant to use `Just` instead. However, when they write
-        foo (Map a) = ...
-It is unlikely that they mean to use `map`, since variables cannot be used here.
-
-Similarly, when we look for record fields, data constructors are not in a
-related namespace.
-
-Furthermore, with -XDataKinds, the data constructor name space is related to
-the type variable and type constructor name spaces.
-
-Note [When to show/hide the module-not-imported line]           -- #15611
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For the error message:
-    Not in scope X.Y
-    Module X does not export Y
-    No module named ‘X’ is imported:
-there are 2 cases, where we hide the last "no module is imported" line:
-1. If the module X has been imported.
-2. If the module X is the current module. There are 2 subcases:
-   2.1 If the unknown module name is in a input source file,
-       then we can use the getModule function to get the current module name.
-       (See test T15611a)
-   2.2 If the unknown module name has been entered by the user in GHCi,
-       then the getModule function returns something like "interactive:Ghci1",
-       and we have to check the current module in the last added entry of
-       the HomePackageTable. (See test T15611b)
--}
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ /dev/null
@@ -1,721 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies     #-}
-{-# LANGUAGE GADTs            #-}
-
-{-
-
-This module contains miscellaneous functions related to renaming.
-
--}
-
-module GHC.Rename.Utils (
-        checkDupRdrNames, checkDupRdrNamesN, checkShadowedRdrNames,
-        checkDupNames, checkDupAndShadowedNames, dupNamesErr,
-        checkTupSize, checkCTupSize,
-        addFvRn, mapFvRn, mapMaybeFvRn,
-        warnUnusedMatches, warnUnusedTypePatterns,
-        warnUnusedTopBinds, warnUnusedLocalBinds,
-        warnForallIdentifier,
-        checkUnusedRecordWildcard,
-        mkFieldEnv,
-        badQualBndrErr, typeAppErr, badFieldConErr,
-        wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType,
-        genHsIntegralLit, genHsTyLit, genSimpleConPat,
-        genVarPat, genWildPat,
-        genSimpleFunBind, genFunBind,
-
-        newLocalBndrRn, newLocalBndrsRn,
-
-        bindLocalNames, bindLocalNamesFV,
-
-        addNameClashErrRn,
-
-        checkInferredVars,
-        noNestedForallsContextsErr, addNoNestedForallsContextsErr
-)
-
-where
-
-
-import GHC.Prelude hiding (unzip)
-
-import GHC.Core.Type
-import GHC.Hs
-import GHC.Types.Name.Reader
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.Monad
-import GHC.Types.Error
-import GHC.Types.Name
-import GHC.Types.Name.Set
-import GHC.Types.Name.Env
-import GHC.Core.DataCon
-import GHC.Types.SrcLoc as SrcLoc
-import GHC.Types.SourceFile
-import GHC.Types.SourceText ( SourceText(..), IntegralLit )
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Misc
-import GHC.Types.Basic  ( TopLevelFlag(..), Origin(Generated) )
-import GHC.Data.List.SetOps ( removeDups )
-import GHC.Data.Maybe ( whenIsJust )
-import GHC.Driver.Session
-import GHC.Data.FastString
-import Control.Monad
-import Data.List (find, sortBy)
-import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE )
-import qualified Data.List.NonEmpty as NE
-import qualified GHC.LanguageExtensions as LangExt
-import GHC.Data.Bag
-import qualified Data.List as List
-
-{-
-*********************************************************
-*                                                      *
-\subsection{Binding}
-*                                                      *
-*********************************************************
--}
-
-newLocalBndrRn :: LocatedN RdrName -> RnM Name
--- Used for non-top-level binders.  These should
--- never be qualified.
-newLocalBndrRn (L loc rdr_name)
-  | Just name <- isExact_maybe rdr_name
-  = return name -- This happens in code generated by Template Haskell
-                -- See Note [Binders in Template Haskell] in "GHC.ThToHs"
-  | otherwise
-  = do { unless (isUnqual rdr_name)
-                (addErrAt (locA loc) (badQualBndrErr rdr_name))
-       ; uniq <- newUnique
-       ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) }
-
-newLocalBndrsRn :: [LocatedN RdrName] -> RnM [Name]
-newLocalBndrsRn = mapM newLocalBndrRn
-
-bindLocalNames :: [Name] -> RnM a -> RnM a
-bindLocalNames names
-  = updLclEnv $ \ lcl_env ->
-    let th_level  = thLevel (tcl_th_ctxt lcl_env)
-        th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)
-                    [ (n, (NotTopLevel, th_level)) | n <- names ]
-        rdr_env'  = extendLocalRdrEnvList (tcl_rdr lcl_env) names
-    in lcl_env { tcl_th_bndrs = th_bndrs'
-               , tcl_rdr      = rdr_env' }
-
-bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
-bindLocalNamesFV names enclosed_scope
-  = do  { (result, fvs) <- bindLocalNames names enclosed_scope
-        ; return (result, delFVs names fvs) }
-
--------------------------------------
-checkDupRdrNames :: [LocatedN RdrName] -> RnM ()
--- Check for duplicated names in a binding group
-checkDupRdrNames rdr_names_w_loc
-  = mapM_ (dupNamesErr getLocA) dups
-  where
-    (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
-
-checkDupRdrNamesN :: [LocatedN RdrName] -> RnM ()
--- Check for duplicated names in a binding group
-checkDupRdrNamesN rdr_names_w_loc
-  = mapM_ (dupNamesErr getLocA) dups
-  where
-    (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
-
-checkDupNames :: [Name] -> RnM ()
--- Check for duplicated names in a binding group
-checkDupNames names = check_dup_names (filterOut isSystemName names)
-                -- See Note [Binders in Template Haskell] in "GHC.ThToHs"
-
-check_dup_names :: [Name] -> RnM ()
-check_dup_names names
-  = mapM_ (dupNamesErr nameSrcSpan) dups
-  where
-    (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names
-
----------------------
-checkShadowedRdrNames :: [LocatedN RdrName] -> RnM ()
-checkShadowedRdrNames loc_rdr_names
-  = do { envs <- getRdrEnvs
-       ; checkShadowedOccs envs get_loc_occ filtered_rdrs }
-  where
-    filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names
-                -- See Note [Binders in Template Haskell] in "GHC.ThToHs"
-    get_loc_occ (L loc rdr) = (locA loc,rdrNameOcc rdr)
-
-checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
-checkDupAndShadowedNames envs names
-  = do { check_dup_names filtered_names
-       ; checkShadowedOccs envs get_loc_occ filtered_names }
-  where
-    filtered_names = filterOut isSystemName names
-                -- See Note [Binders in Template Haskell] in "GHC.ThToHs"
-    get_loc_occ name = (nameSrcSpan name, nameOccName name)
-
--------------------------------------
-checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)
-                  -> (a -> (SrcSpan, OccName))
-                  -> [a] -> RnM ()
-checkShadowedOccs (global_env,local_env) get_loc_occ ns
-  = whenWOptM Opt_WarnNameShadowing $
-    do  { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns))
-        ; mapM_ check_shadow ns }
-  where
-    check_shadow n
-        | startsWithUnderscore occ = return ()  -- Do not report shadowing for "_x"
-                                                -- See #3262
-        | Just n <- mb_local = complain (ShadowedNameProvenanceLocal (nameSrcLoc n))
-        | otherwise = do { gres' <- filterM is_shadowed_gre gres
-                         ; when (not . null $ gres') $ complain (ShadowedNameProvenanceGlobal gres') }
-        where
-          (loc,occ) = get_loc_occ n
-          mb_local  = lookupLocalRdrOcc local_env occ
-          gres      = lookupGRE_RdrName (mkRdrUnqual occ) global_env
-                -- Make an Unqualified RdrName and look that up, so that
-                -- we don't find any GREs that are in scope qualified-only
-
-          complain provenance = addDiagnosticAt loc (TcRnShadowedName occ provenance)
-
-    is_shadowed_gre :: GlobalRdrElt -> RnM Bool
-        -- Returns False for record selectors that are shadowed, when
-        -- punning or wild-cards are on (cf #2723)
-    is_shadowed_gre gre | isRecFldGRE gre
-        = do { dflags <- getDynFlags
-             ; return $ not (xopt LangExt.NamedFieldPuns dflags
-                             || xopt LangExt.RecordWildCards dflags) }
-    is_shadowed_gre _other = return True
-
--------------------------------------
--- | Throw an error message if a user attempts to quantify an inferred type
--- variable in a place where specificity cannot be observed. For example,
--- @forall {a}. [a] -> [a]@ would be rejected to the inferred type variable
--- @{a}@, but @forall a. [a] -> [a]@ would be accepted.
--- See @Note [Unobservably inferred type variables]@.
-checkInferredVars :: HsDocContext
-                  -> Maybe SDoc
-                  -- ^ The error msg if the signature is not allowed to contain
-                  --   manually written inferred variables.
-                  -> LHsSigType GhcPs
-                  -> RnM ()
-checkInferredVars _    Nothing    _  = return ()
-checkInferredVars ctxt (Just msg) ty =
-  let bndrs = sig_ty_bndrs ty
-  in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of
-    Nothing -> return ()
-    Just _  -> addErr $
-      TcRnWithHsDocContext ctxt $
-      mkTcRnUnknownMessage $ mkPlainError noHints msg
-  where
-    sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs]
-    sig_ty_bndrs (L _ (HsSig{sig_bndrs = outer_bndrs}))
-      = map unLoc (hsOuterExplicitBndrs outer_bndrs)
-
-{-
-Note [Unobservably inferred type variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-While GHC's parser allows the use of inferred type variables
-(e.g., `forall {a}. <...>`) just about anywhere that type variable binders can
-appear, there are some situations where the distinction between inferred and
-specified type variables cannot be observed. For example, consider this
-instance declaration:
-
-  instance forall {a}. Eq (T a) where ...
-
-Making {a} inferred is pointless, as there is no way for user code to
-"apply" an instance declaration in a way where the inferred/specified
-distinction would make a difference. (Notably, there is no opportunity
-for visible type application of an instance declaration.) Anyone who
-writes such code is likely confused, so in an attempt to be helpful,
-we emit an error message if a user writes code like this. The
-checkInferredVars function is responsible for implementing this
-restriction.
-
-It turns out to be somewhat cumbersome to enforce this restriction in
-certain cases.  Specifically:
-
-* Quantified constraints. In the type `f :: (forall {a}. C a) => Proxy Int`,
-  there is no way to observe that {a} is inferred. Nevertheless, actually
-  rejecting this code would be tricky, as we would need to reject
-  `forall {a}. <...>` as a constraint but *accept* other uses of
-  `forall {a}. <...>` as a type (e.g., `g :: (forall {a}. a -> a) -> b -> b`).
-  This is quite tedious to do in practice, so we don't bother.
-
-* Default method type signatures (#18432). These are tricky because inferred
-  type variables can appear nested, e.g.,
-
-    class C a where
-      m         :: forall b. a -> b -> forall c.   c -> c
-      default m :: forall b. a -> b -> forall {c}. c -> c
-      m _ _ = id
-
-  Robustly checking for nested, inferred type variables ends up being a pain,
-  so we don't try to do this.
-
-For now, we simply allow inferred quantifiers to be specified here,
-even though doing so is pointless. All we lose is a warning.
-
-Aside from the places where we already use checkInferredVars, most of
-the other places where inferred vars don't make sense are in any case
-already prohibited from having foralls /at all/.  For example:
-
-  instance forall a. forall {b}. Eq (Either a b) where ...
-
-Here the nested `forall {b}` is already prohibited. (See
-Note [No nested foralls or contexts in instance types] in GHC.Hs.Type).
--}
-
--- | Examines a non-outermost type for @forall@s or contexts, which are assumed
--- to be nested. For example, in the following declaration:
---
--- @
--- instance forall a. forall b. C (Either a b)
--- @
---
--- The outermost @forall a@ is fine, but the nested @forall b@ is not. We
--- invoke 'noNestedForallsContextsErr' on the type @forall b. C (Either a b)@
--- to catch the nested @forall@ and create a suitable error message.
--- 'noNestedForallsContextsErr' returns @'Just' err_msg@ if such a @forall@ or
--- context is found, and returns @Nothing@ otherwise.
---
--- This is currently used in the following places:
---
--- * In GADT constructor types (in 'rnConDecl').
---   See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@
---   in "GHC.Hs.Type".
---
--- * In instance declaration types (in 'rnClsIntDecl' and 'rnSrcDerivDecl' in
---   "GHC.Rename.Module" and 'renameSig' in "GHC.Rename.Bind").
---   See @Note [No nested foralls or contexts in instance types]@ in
---   "GHC.Hs.Type".
-noNestedForallsContextsErr :: SDoc -> LHsType GhcRn -> Maybe (SrcSpan, TcRnMessage)
-noNestedForallsContextsErr what lty =
-  case ignoreParens lty of
-    L l (HsForAllTy { hst_tele = tele })
-      |  HsForAllVis{} <- tele
-         -- The only two places where this function is called correspond to
-         -- types of terms, so we give a slightly more descriptive error
-         -- message in the event that they contain visible dependent
-         -- quantification (currently only allowed in kinds).
-      -> Just (locA l, TcRnVDQInTermType Nothing)
-      |  HsForAllInvis{} <- tele
-      -> Just (locA l, nested_foralls_contexts_err)
-    L l (HsQualTy {})
-      -> Just (locA l, nested_foralls_contexts_err)
-    _ -> Nothing
-  where
-    nested_foralls_contexts_err =
-      mkTcRnUnknownMessage $ mkPlainError noHints $
-      what <+> text "cannot contain nested"
-      <+> quotes forAllLit <> text "s or contexts"
-
--- | A common way to invoke 'noNestedForallsContextsErr'.
-addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM ()
-addNoNestedForallsContextsErr ctxt what lty =
-  whenIsJust (noNestedForallsContextsErr what lty) $ \(l, err_msg) ->
-    addErrAt l $ TcRnWithHsDocContext ctxt err_msg
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Free variable manipulation}
-*                                                                      *
-************************************************************************
--}
-
--- A useful utility
-addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
-addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside
-                               ; return (res, fvs1 `plusFV` fvs2) }
-
-mapFvRn :: Traversable f => (a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars)
-mapFvRn f xs = do
-    stuff <- mapM f xs
-    case unzip stuff of
-        (ys, fvs_s) -> return (ys, foldl' (flip plusFV) emptyFVs fvs_s)
-{-# SPECIALIZE mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) #-}
-
-unzip :: Functor f => f (a, b) -> (f a, f b)
-unzip = \ xs -> (fmap fst xs, fmap snd xs)
-{-# NOINLINE [1] unzip #-}
-{-# RULES "unzip/List" unzip = List.unzip #-}
-
-mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
-mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)
-mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Envt utility functions}
-*                                                                      *
-************************************************************************
--}
-
-warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
-warnUnusedTopBinds gres
-    = whenWOptM Opt_WarnUnusedTopBinds
-    $ do env <- getGblEnv
-         let isBoot = tcg_src env == HsBootFile
-         let noParent gre = case gre_par gre of
-                            NoParent -> True
-                            _        -> False
-             -- Don't warn about unused bindings with parents in
-             -- .hs-boot files, as you are sometimes required to give
-             -- unused bindings (trac #3449).
-             -- HOWEVER, in a signature file, you are never obligated to put a
-             -- definition in the main text.  Thus, if you define something
-             -- and forget to export it, we really DO want to warn.
-             gres' = if isBoot then filter noParent gres
-                               else                 gres
-         warnUnusedGREs gres'
-
-
--- | Checks to see if we need to warn for -Wunused-record-wildcards or
--- -Wredundant-record-wildcards
-checkUnusedRecordWildcard :: SrcSpan
-                          -> FreeVars
-                          -> Maybe [Name]
-                          -> RnM ()
-checkUnusedRecordWildcard _ _ Nothing     = return ()
-checkUnusedRecordWildcard loc _ (Just []) =
-  -- Add a new warning if the .. pattern binds no variables
-  setSrcSpan loc $ warnRedundantRecordWildcard
-checkUnusedRecordWildcard loc fvs (Just dotdot_names) =
-  setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs
-
-
--- | Produce a warning when the `..` pattern binds no new
--- variables.
---
--- @
---   data P = P { x :: Int }
---
---   foo (P{x, ..}) = x
--- @
---
--- The `..` here doesn't bind any variables as `x` is already bound.
-warnRedundantRecordWildcard :: RnM ()
-warnRedundantRecordWildcard =
-  whenWOptM Opt_WarnRedundantRecordWildcards $
-    let msg = mkTcRnUnknownMessage $
-                mkPlainDiagnostic (WarningWithFlag Opt_WarnRedundantRecordWildcards)
-                                  noHints
-                                  redundantWildcardWarning
-    in addDiagnostic msg
-
-
--- | Produce a warning when no variables bound by a `..` pattern are used.
---
--- @
---   data P = P { x :: Int }
---
---   foo (P{..}) = ()
--- @
---
--- The `..` pattern binds `x` but it is not used in the RHS so we issue
--- a warning.
-warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM ()
-warnUnusedRecordWildcard ns used_names = do
-  let used = filter (`elemNameSet` used_names) ns
-  traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used)
-  warnIf (null used)
-    unusedRecordWildcardWarning
-
-
-
-warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns
-  :: [Name] -> FreeVars -> RnM ()
-warnUnusedLocalBinds   = check_unused Opt_WarnUnusedLocalBinds
-warnUnusedMatches      = check_unused Opt_WarnUnusedMatches
-warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns
-
-check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()
-check_unused flag bound_names used_names
-  = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names)
-                                               bound_names))
-
-warnForallIdentifier :: LocatedN RdrName -> RnM ()
-warnForallIdentifier (L l rdr_name@(Unqual occ))
-  | isKw (fsLit "forall") || isKw (fsLit "∀")
-  = addDiagnosticAt (locA l) (TcRnForallIdentifier rdr_name)
-  where isKw = (occNameFS occ ==)
-warnForallIdentifier _ = return ()
-
--------------------------
---      Helpers
-warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
-warnUnusedGREs gres = mapM_ warnUnusedGRE gres
-
--- NB the Names must not be the names of record fields!
-warnUnused :: WarningFlag -> [Name] -> RnM ()
-warnUnused flag names =
-    mapM_ (warnUnused1 flag . NormalGreName) names
-
-warnUnused1 :: WarningFlag -> GreName -> RnM ()
-warnUnused1 flag child
-  = when (reportable child) $
-    addUnusedWarning flag
-                     (occName child) (greNameSrcSpan child)
-                     (text $ "Defined but not used" ++ opt_str)
-  where
-    opt_str = case flag of
-                Opt_WarnUnusedTypePatterns -> " on the right hand side"
-                _ -> ""
-
-warnUnusedGRE :: GlobalRdrElt -> RnM ()
-warnUnusedGRE gre@(GRE { gre_lcl = lcl, gre_imp = is })
-  | lcl       = warnUnused1 Opt_WarnUnusedTopBinds (gre_name gre)
-  | otherwise = when (reportable (gre_name gre)) (mapM_ warn is)
-  where
-    occ = greOccName gre
-    warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg
-        where
-           span = importSpecLoc spec
-           pp_mod = quotes (ppr (importSpecModule spec))
-           msg = text "Imported from" <+> pp_mod <+> text "but not used"
-
--- | Make a map from selector names to field labels and parent tycon
--- names, to be used when reporting unused record fields.
-mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Parent)
-mkFieldEnv rdr_env = mkNameEnv [ (greMangledName gre, (flLabel fl, gre_par gre))
-                               | gres <- nonDetOccEnvElts rdr_env
-                               , gre <- gres
-                               , Just fl <- [greFieldLabel gre]
-                               ]
-
--- | Should we report the fact that this 'Name' is unused? The
--- 'OccName' may differ from 'nameOccName' due to
--- DuplicateRecordFields.
-reportable :: GreName -> Bool
-reportable child
-  | NormalGreName name <- child
-  , isWiredInName name = False    -- Don't report unused wired-in names
-                                  -- Otherwise we get a zillion warnings
-                                  -- from Data.Tuple
-  | otherwise = not (startsWithUnderscore (occName child))
-
-addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()
-addUnusedWarning flag occ span msg = do
-  let diag = mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints $
-        sep [msg <> colon,
-             nest 2 $ pprNonVarNameSpace (occNameSpace occ)
-                            <+> quotes (ppr occ)]
-  addDiagnosticAt span diag
-
-unusedRecordWildcardWarning :: TcRnMessage
-unusedRecordWildcardWarning =
-  mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedRecordWildcards) noHints $
-    wildcardDoc $ text "No variables bound in the record wildcard match are used"
-
-redundantWildcardWarning :: SDoc
-redundantWildcardWarning =
-  wildcardDoc $ text "Record wildcard does not bind any new variables"
-
-wildcardDoc :: SDoc -> SDoc
-wildcardDoc herald =
-  herald
-    $$ nest 2 (text "Possible fix" <> colon <+> text "omit the"
-                                            <+> quotes (text ".."))
-
-{-
-Note [Skipping ambiguity errors at use sites of local declarations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In general, we do not report ambiguous occurrences at use sites where all the
-clashing names are defined locally, because the error will have been reported at
-the definition site, and we want to avoid an error cascade.
-
-However, when DuplicateRecordFields is enabled, it is possible to define the
-same field name multiple times, so we *do* need to report an error at the use
-site when there is ambiguity between multiple fields. Moreover, when
-NoFieldSelectors is enabled, it is possible to define a field with the same name
-as a non-field, so again we need to report ambiguity at the use site.
-
-We can skip reporting an ambiguity error whenever defining the GREs must have
-yielded a duplicate declarations error.  More precisely, we can skip if:
-
- * there are at least two non-fields amongst the GREs; or
-
- * there are at least two fields amongst the GREs, and DuplicateRecordFields is
-   *disabled*; or
-
- * there is at least one non-field, at least one field, and NoFieldSelectors is
-   *disabled*.
-
-These conditions ensure that a duplicate local declaration will have been
-reported.  See also Note [Reporting duplicate local declarations] in
-GHC.Rename.Names).
-
--}
-
-addNameClashErrRn :: RdrName -> NE.NonEmpty GlobalRdrElt -> RnM ()
-addNameClashErrRn rdr_name gres
-  | all isLocalGRE gres && can_skip
-  -- If there are two or more *local* defns, we'll usually have reported that
-  -- already, and we don't want an error cascade.
-  = return ()
-  | otherwise
-  = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)
-                 , text "It could refer to"
-                 , nest 3 (vcat (msg1 : msgs)) ])
-  where
-    np1 NE.:| nps = gres
-    msg1 =  text "either" <+> ppr_gre np1
-    msgs = [text "    or" <+> ppr_gre np | np <- nps]
-    ppr_gre gre = sep [ pp_greMangledName gre <> comma
-                      , pprNameProvenance gre]
-
-    -- When printing the name, take care to qualify it in the same
-    -- way as the provenance reported by pprNameProvenance, namely
-    -- the head of 'gre_imp'.  Otherwise we get confusing reports like
-    --   Ambiguous occurrence ‘null’
-    --   It could refer to either ‘T15487a.null’,
-    --                            imported from ‘Prelude’ at T15487.hs:1:8-13
-    --                     or ...
-    -- See #15487
-    pp_greMangledName gre@(GRE { gre_name = child, gre_par = par
-                         , gre_lcl = lcl, gre_imp = iss }) =
-      case child of
-        FieldGreName fl  -> text "the field" <+> quotes (ppr fl) <+> parent_info
-        NormalGreName name -> quotes (pp_qual name <> dot <> ppr (nameOccName name))
-      where
-        parent_info = case par of
-          NoParent -> empty
-          ParentIs { par_is = par_name } -> text "of record" <+> quotes (ppr par_name)
-        pp_qual name
-                | lcl
-                = ppr (nameModule name)
-                | Just imp  <- headMaybe iss  -- This 'imp' is the one that
-                                  -- pprNameProvenance chooses
-                , ImpDeclSpec { is_as = mod } <- is_decl imp
-                = ppr mod
-                | otherwise
-                = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss)
-                  -- Invariant: either 'lcl' is True or 'iss' is non-empty
-
-    -- If all the GREs are defined locally, can we skip reporting an ambiguity
-    -- error at use sites, because it will have been reported already? See
-    -- Note [Skipping ambiguity errors at use sites of local declarations]
-    can_skip = num_non_flds >= 2
-            || (num_flds >= 2 && not (isDuplicateRecFldGRE (head flds)))
-            || (num_non_flds >= 1 && num_flds >= 1
-                                  && not (isNoFieldSelectorGRE (head flds)))
-    (flds, non_flds) = NE.partition isRecFldGRE gres
-    num_flds     = length flds
-    num_non_flds = length non_flds
-
-
-dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM ()
-dupNamesErr get_loc names
-  = addErrAt big_loc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)),
-          locations]
-  where
-    locs      = map get_loc (NE.toList names)
-    big_loc   = foldr1 combineSrcSpans locs
-    locations = text "Bound at:" <+> vcat (map ppr (sortBy SrcLoc.leftmost_smallest locs))
-
-badQualBndrErr :: RdrName -> TcRnMessage
-badQualBndrErr rdr_name
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-  text "Qualified name in binding position:" <+> ppr rdr_name
-
-typeAppErr :: String -> LHsType GhcPs -> TcRnMessage
-typeAppErr what (L _ k)
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (text "Illegal visible" <+> text what <+> text "application"
-            <+> quotes (char '@' <> ppr k))
-       2 (text "Perhaps you intended to use TypeApplications")
-
-badFieldConErr :: Name -> FieldLabelString -> TcRnMessage
-badFieldConErr con field
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    hsep [text "Constructor" <+> quotes (ppr con),
-          text "does not have field", quotes (ppr field)]
-
--- | Ensure that a boxed or unboxed tuple has arity no larger than
--- 'mAX_TUPLE_SIZE'.
-checkTupSize :: Int -> TcM ()
-checkTupSize tup_size
-  | tup_size <= mAX_TUPLE_SIZE
-  = return ()
-  | otherwise
-  = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC",
-                 nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),
-                 nest 2 (text "Workaround: use nested tuples or define a data type")]
-
--- | Ensure that a constraint tuple has arity no larger than 'mAX_CTUPLE_SIZE'.
-checkCTupSize :: Int -> TcM ()
-checkCTupSize tup_size
-  | tup_size <= mAX_CTUPLE_SIZE
-  = return ()
-  | otherwise
-  = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (text "Constraint tuple arity too large:" <+> int tup_size
-                  <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))
-               2 (text "Instead, use a nested tuple")
-
-{- *********************************************************************
-*                                                                      *
-              Generating code for HsExpanded
-      See Note [Handling overloaded and rebindable constructs]
-*                                                                      *
-********************************************************************* -}
-
-wrapGenSpan :: a -> LocatedAn an a
--- Wrap something in a "generatedSrcSpan"
--- See Note [Rebindable syntax and HsExpansion]
-wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x
-
-genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
-genHsApps fun args = foldl genHsApp (genHsVar fun) args
-
-genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
-genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg
-
-genLHsVar :: Name -> LHsExpr GhcRn
-genLHsVar nm = wrapGenSpan $ genHsVar nm
-
-genHsVar :: Name -> HsExpr GhcRn
-genHsVar nm = HsVar noExtField $ wrapGenSpan nm
-
-genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
-genAppType expr ty = HsAppType noExtField (wrapGenSpan expr) noHsTok (mkEmptyWildCardBndrs (wrapGenSpan ty))
-
-genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn)
-genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit)
-
-genHsTyLit :: FastString -> HsType GhcRn
-genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText
-
-genSimpleConPat :: Name -> [LPat GhcRn] -> LPat GhcRn
--- The pattern (C p1 .. pn)
-genSimpleConPat con pats
-  = wrapGenSpan $ ConPat { pat_con_ext = noExtField
-                         , pat_con     = wrapGenSpan con
-                         , pat_args    = PrefixCon [] pats }
-
-genVarPat :: Name -> LPat GhcRn
-genVarPat n = wrapGenSpan $ VarPat noExtField (wrapGenSpan n)
-
-genWildPat :: LPat GhcRn
-genWildPat = wrapGenSpan $ WildPat noExtField
-
-genSimpleFunBind :: Name -> [LPat GhcRn]
-                 -> LHsExpr GhcRn -> LHsBind GhcRn
-genSimpleFunBind fun pats expr
-  = L gen $ genFunBind (L gen fun)
-        [mkMatch (mkPrefixFunRhs (L gen fun)) pats expr
-                 emptyLocalBinds]
-  where
-    gen = noAnnSrcSpan generatedSrcSpan
-
-genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]
-           -> HsBind GhcRn
-genFunBind fn ms
-  = FunBind { fun_id = fn
-            , fun_matches = mkMatchGroup Generated (wrapGenSpan ms)
-            , fun_ext = emptyNameSet
-            }
diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs
deleted file mode 100644
--- a/compiler/GHC/Runtime/Debugger.hs
+++ /dev/null
@@ -1,270 +0,0 @@
------------------------------------------------------------------------------
---
--- 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 GHC.Runtime.Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
-
-import GHC.Prelude
-
-import GHC
-
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Driver.Monad
-import GHC.Driver.Env
-
-import GHC.Linker.Loader
-
-import GHC.Runtime.Heap.Inspect
-import GHC.Runtime.Interpreter
-import GHC.Runtime.Context
-
-import GHC.Iface.Syntax ( showToHeader )
-import GHC.Iface.Env    ( newInteractiveBinder )
-import GHC.Core.Type
-
-import GHC.Utils.Outputable
-import GHC.Utils.Error
-import GHC.Utils.Monad
-import GHC.Utils.Exception
-import GHC.Utils.Logger
-
-import GHC.Types.Id
-import GHC.Types.Id.Make (ghcPrimIds)
-import GHC.Types.Name
-import GHC.Types.Var hiding ( varName )
-import GHC.Types.Var.Set
-import GHC.Types.Unique.Set
-import GHC.Types.TyThing.Ppr
-import GHC.Types.TyThing
-
-import Control.Monad
-import Control.Monad.Catch as MC
-import Data.List ( (\\), partition )
-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)
-
-  -- Sort out good and bad tythings for :print and friends
-  let (pprintables, unpprintables) = partition can_pprint tythings
-
-  -- Obtain the terms and the recovered type information
-  let ids = [id | AnId id <- pprintables]
-  (subst, terms) <- mapAccumLM go emptySubst 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 Results
-  docterms <- mapM showTerm terms
-  let sdocTerms = zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
-                          ids
-                          docterms
-  printSDocs $ (no_pprint <$> unpprintables) ++ sdocTerms
- where
-   -- Check whether a TyThing can be processed by :print and friends.
-   -- Take only Ids, exclude pseudoops, they don't have any HValues.
-   can_pprint :: TyThing -> Bool                              -- #19394
-   can_pprint (AnId x)
-       | x `notElem` ghcPrimIds = True
-       | otherwise              = False
-   can_pprint _                 = False
-
-   -- Create a short message for a TyThing, that cannot processed by :print
-   no_pprint :: TyThing -> SDoc
-   no_pprint tything = ppr tything <+>
-          text "is not eligible for the :print, :sprint or :force commands."
-
-   -- Helper to print out the results of :print and friends
-   printSDocs :: GhcMonad m => [SDoc] -> m ()
-   printSDocs sdocs = do
-      logger <- getLogger
-      name_ppr_ctx <- GHC.getNamePprCtx
-      liftIO $ printOutputForUser logger name_ppr_ctx $ vcat sdocs
-
-   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
-   go :: GhcMonad m => Subst -> Id -> m (Subst, Term)
-   go subst id = do
-       let id' = updateIdTypeAndMult (substTy subst) id
-           id_ty' = idType id'
-       term_    <- GHC.obtainTermFromId maxBound force id'
-       term     <- tidyTermTyVars term_
-       term'    <- if bindThings
-                     then bindSuspensions term
-                     else return term
-     -- Before leaving, we compare the type obtained to see if it's more specific
-     --  Then, we extract a substitution,
-     --  mapping the old tyvars to the reconstructed types.
-       let reconstructed_type = termType term
-       hsc_env <- getSession
-       case (improveRTTIType hsc_env id_ty' reconstructed_type) of
-         Nothing     -> return (subst, term')
-         Just subst' -> do { logger <- getLogger
-                           ; liftIO $
-                               putDumpFileMaybe logger 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 `unionSubst` 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
-          interp = hscInterp hsc_env
-      liftIO $ extendLoadedEnv interp (zip names fhvs)
-      setSession hsc_env {hsc_IC = new_ic }
-      return t'
-     where
-
---    Processing suspensions. Give names and collect 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
-        let set_session = do
-                hsc_env <- getSession
-                (new_env, bname) <- bindToFreshName hsc_env ty "showme"
-                setSession new_env
-
-                -- this disables logging of errors
-                let noop_log _ _ _ _ = return ()
-                pushLogHookM (const noop_log)
-
-                return (hsc_env, bname)
-
-            reset_session (old_env,_) = setSession old_env
-
-        MC.bracket set_session reset_session $ \(_,bname) -> do
-           hsc_env <- getSession
-           dflags  <- GHC.getSessionDynFlags
-           let expr = "Prelude.return (Prelude.show " ++
-                         showPpr dflags bname ++
-                      ") :: Prelude.IO Prelude.String"
-               interp = hscInterp hsc_env
-           txt_ <- withExtendedLoadedEnv interp
-                                       [(bname, fhv)]
-                                       (GHC.compileExprRemote expr)
-           let myprec = 10 -- application precedence. TODO Infix constructors
-           txt <- liftIO $ evalString interp txt_
-           if not (null txt) then
-             return $ Just $ cparen (prec >= myprec && needsParens txt)
-                                    (text txt)
-            else return Nothing
-
-  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 <- MC.try $ 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/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
deleted file mode 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ /dev/null
@@ -1,1287 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE RecordWildCards #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
--- -----------------------------------------------------------------------------
---
--- (c) The University of Glasgow, 2005-2007
---
--- Running statements interactively
---
--- -----------------------------------------------------------------------------
-
-module GHC.Runtime.Eval (
-        Resume(..), History(..),
-        execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), resumeExec,
-        runDecls, runDeclsWithLocation, runParsedDecls,
-        parseImportDecl, SingleStep(..),
-        abandon, abandonAll,
-        getResumeContext,
-        getHistorySpan,
-        getModBreaks,
-        getHistoryModule,
-        setupBreakpoint,
-        back, forward,
-        setContext, getContext,
-        getNamesInScope,
-        getRdrNamesInScope,
-        moduleIsInterpreted,
-        getInfo,
-        exprType,
-        typeKind,
-        parseName,
-        parseInstanceHead,
-        getInstancesForType,
-        getDocs,
-        GetDocsFailure(..),
-        showModule,
-        moduleIsBootOrNotObjectLinkable,
-        parseExpr, compileParsedExpr,
-        compileExpr, dynCompileExpr,
-        compileExprRemote, compileParsedExprRemote,
-        Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
-        ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Monad
-import GHC.Driver.Main
-import GHC.Driver.Errors.Types ( hoistTcRnMessage )
-import GHC.Driver.Env
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Driver.Config
-
-import GHC.Runtime.Eval.Types
-import GHC.Runtime.Interpreter as GHCi
-import GHC.Runtime.Heap.Inspect
-import GHC.Runtime.Context
-import GHCi.Message
-import GHCi.RemoteTypes
-import GHC.ByteCode.Types
-
-import GHC.Linker.Loader as Loader
-
-import GHC.Hs
-
-import GHC.Core.Predicate
-import GHC.Core.InstEnv
-import GHC.Core.FamInstEnv ( FamInst )
-import GHC.Core.FVs        ( orphNamesOfFamInst )
-import GHC.Core.TyCon
-import GHC.Core.Type       hiding( typeKind )
-import GHC.Core.TyCo.Ppr
-import qualified GHC.Core.Type as Type
-
-import GHC.Iface.Env       ( newInteractiveBinder )
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Origin
-
-import GHC.Builtin.Names ( toDynName, pretendNameIsInScope )
-
-import GHC.Data.Maybe
-import GHC.Data.FastString
-import GHC.Data.Bag
-
-import GHC.Utils.Monad
-import GHC.Utils.Panic
-import GHC.Utils.Error
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Logger
-
-import GHC.Types.RepType
-import GHC.Types.Fixity.Env
-import GHC.Types.Var
-import GHC.Types.Id as Id
-import GHC.Types.Name      hiding ( varName )
-import GHC.Types.Name.Set
-import GHC.Types.Name.Reader
-import GHC.Types.Var.Env
-import GHC.Types.SrcLoc
-import GHC.Types.Unique
-import GHC.Types.Unique.Supply
-import GHC.Types.Unique.DSet
-import GHC.Types.TyThing
-import GHC.Types.BreakInfo
-import GHC.Types.Unique.Map
-
-import GHC.Unit
-import GHC.Unit.Module.Graph
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.ModSummary
-import GHC.Unit.Home.ModInfo
-
-import System.Directory
-import Data.Dynamic
-import Data.Either
-import Data.IntMap (IntMap)
-import qualified Data.IntMap as IntMap
-import Data.List (find,intercalate)
-import Control.Monad
-import Control.Monad.Catch as MC
-import Data.Array
-import GHC.Utils.Exception
-import Unsafe.Coerce ( unsafeCoerce )
-
-import GHC.Tc.Module ( runTcInteractive, tcRnType, loadUnqualIfaces )
-import GHC.Tc.Utils.Zonk ( ZonkFlexi (SkolemiseFlexi) )
-import GHC.Tc.Utils.Env (tcGetInstEnvs)
-import GHC.Tc.Utils.Instantiate (instDFunType)
-import GHC.Tc.Solver (simplifyWantedsTcM)
-import GHC.Tc.Utils.Monad
-import GHC.Core.Class (classTyCon)
-import GHC.Unit.Env
-
--- -----------------------------------------------------------------------------
--- running a statement interactively
-
-getResumeContext :: GhcMonad m => m [Resume]
-getResumeContext = withSession (return . ic_resume . hsc_IC)
-
-mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
-mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi)
-
-getHistoryModule :: History -> Module
-getHistoryModule = breakInfo_module . historyBreakInfo
-
-getHistorySpan :: HscEnv -> History -> SrcSpan
-getHistorySpan hsc_env History{..} =
-  let BreakInfo{..} = historyBreakInfo in
-  case lookupHugByModule breakInfo_module (hsc_HUG hsc_env) of
-    Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number
-    _ -> panic "getHistorySpan"
-
-{- | Finds the enclosing top level function name -}
--- ToDo: a better way to do this would be to keep hold of the decl_path computed
--- by the coverage pass, which gives the list of lexically-enclosing bindings
--- for each tick.
-findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
-findEnclosingDecls hsc_env (BreakInfo modl ix) =
-   let hmi = expectJust "findEnclosingDecls" $
-             lookupHugByModule modl (hsc_HUG hsc_env)
-       mb = getModBreaks hmi
-   in modBreaks_decls mb ! ix
-
--- | Update fixity environment in the current interactive context.
-updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
-updateFixityEnv fix_env = do
-  hsc_env <- getSession
-  let ic = hsc_IC hsc_env
-  setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } }
-
--- -----------------------------------------------------------------------------
--- execStmt
-
--- | default ExecOptions
-execOptions :: ExecOptions
-execOptions = ExecOptions
-  { execSingleStep = RunToCompletion
-  , execSourceFile = "<interactive>"
-  , execLineNumber = 1
-  , execWrap = EvalThis -- just run the statement, don't wrap it in anything
-  }
-
--- | Run a statement in the current interactive context.
-execStmt
-  :: GhcMonad m
-  => String             -- ^ a statement (bind or expression)
-  -> ExecOptions
-  -> m ExecResult
-execStmt input exec_opts@ExecOptions{..} = do
-    hsc_env <- getSession
-
-    mb_stmt <-
-      liftIO $
-      runInteractiveHsc hsc_env $
-      hscParseStmtWithLocation execSourceFile execLineNumber input
-
-    case mb_stmt of
-      -- empty statement / comment
-      Nothing -> return (ExecComplete (Right []) 0)
-      Just stmt -> execStmt' stmt input exec_opts
-
--- | Like `execStmt`, but takes a parsed statement as argument. Useful when
--- doing preprocessing on the AST before execution, e.g. in GHCi (see
--- GHCi.UI.runStmt).
-execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
-execStmt' stmt stmt_text ExecOptions{..} = do
-    hsc_env <- getSession
-    let interp = hscInterp hsc_env
-
-    -- Turn off -fwarn-unused-local-binds when running a statement, to hide
-    -- warnings about the implicit bindings we introduce.
-    let ic       = hsc_IC hsc_env -- use the interactive dflags
-        idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds
-        hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' }})
-
-    r <- liftIO $ hscParsedStmt hsc_env' stmt
-
-    case r of
-      Nothing ->
-        -- empty statement / comment
-        return (ExecComplete (Right []) 0)
-      Just (ids, hval, fix_env) -> do
-        updateFixityEnv fix_env
-
-        status <-
-          withVirtualCWD $
-            liftIO $ do
-              let eval_opts = initEvalOpts idflags' (isStep execSingleStep)
-              evalStmt interp eval_opts (execWrap hval)
-
-        let ic = hsc_IC hsc_env
-            bindings = (ic_tythings ic, ic_gre_cache ic)
-
-            size = ghciHistSize idflags'
-
-        handleRunStatus execSingleStep stmt_text bindings ids
-                        status (emptyHistory size)
-
-runDecls :: GhcMonad m => String -> m [Name]
-runDecls = runDeclsWithLocation "<interactive>" 1
-
--- | Run some declarations and return any user-visible names that were brought
--- into scope.
-runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
-runDeclsWithLocation source line_num input = do
-    hsc_env <- getSession
-    decls <- liftIO (hscParseDeclsWithLocation hsc_env source line_num input)
-    runParsedDecls decls
-
--- | Like `runDeclsWithLocation`, but takes parsed declarations as argument.
--- Useful when doing preprocessing on the AST before execution, e.g. in GHCi
--- (see GHCi.UI.runStmt).
-runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [Name]
-runParsedDecls decls = do
-    hsc_env <- getSession
-    (tyThings, ic) <- liftIO (hscParsedDecls hsc_env decls)
-
-    setSession $ hsc_env { hsc_IC = ic }
-    hsc_env <- getSession
-    hsc_env' <- liftIO $ rttiEnvironment hsc_env
-    setSession hsc_env'
-    return $ filter (not . isDerivedOccName . nameOccName)
-             -- For this filter, see Note [What to show to users]
-           $ map getName tyThings
-
-{- Note [What to show to users]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We don't want to display internally-generated bindings to users.
-Things like the coercion axiom for newtypes. These bindings all get
-OccNames that users can't write, to avoid the possibility of name
-clashes (in linker symbols).  That gives a convenient way to suppress
-them. The relevant predicate is OccName.isDerivedOccName.
-See #11051 for more background and examples.
--}
-
-withVirtualCWD :: GhcMonad m => m a -> m a
-withVirtualCWD m = do
-  hsc_env <- getSession
-
-    -- a virtual CWD is only necessary when we're running interpreted code in
-    -- the same process as the compiler.
-  case interpInstance <$> hsc_interp hsc_env of
-    Just (ExternalInterp {}) -> m
-    _ -> do
-      let ic = hsc_IC hsc_env
-      let set_cwd = do
-            dir <- liftIO $ getCurrentDirectory
-            case ic_cwd ic of
-               Just dir -> liftIO $ setCurrentDirectory dir
-               Nothing  -> return ()
-            return dir
-
-          reset_cwd orig_dir = do
-            virt_dir <- liftIO $ getCurrentDirectory
-            hsc_env <- getSession
-            let old_IC = hsc_IC hsc_env
-            setSession hsc_env{  hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
-            liftIO $ setCurrentDirectory orig_dir
-
-      MC.bracket set_cwd reset_cwd $ \_ -> m
-
-parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs)
-parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
-
-emptyHistory :: Int -> BoundedList History
-emptyHistory size = nilBL size
-
-handleRunStatus :: GhcMonad m
-                => SingleStep -> String
-                -> ResumeBindings
-                -> [Id]
-                -> EvalStatus_ [ForeignHValue] [HValueRef]
-                -> BoundedList History
-                -> m ExecResult
-
-handleRunStatus step expr bindings final_ids status history
-  | RunAndLogSteps <- step = tracing
-  | otherwise              = not_tracing
- where
-  tracing
-    | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status
-    , not is_exception
-    = do
-       hsc_env <- getSession
-       let interp = hscInterp hsc_env
-       let dflags = hsc_dflags hsc_env
-       let hmi = expectJust "handleRunStatus" $
-                   lookupHptDirectly (hsc_HPT hsc_env)
-                                     (mkUniqueGrimily mod_uniq)
-           modl = mi_module (hm_iface hmi)
-           breaks = getModBreaks hmi
-
-       b <- liftIO $
-              breakpointStatus interp (modBreaks_flags breaks) ix
-       if b
-         then not_tracing
-           -- This breakpoint is explicitly enabled; we want to stop
-           -- instead of just logging it.
-         else do
-           apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
-           let bi = BreakInfo modl ix
-               !history' = mkHistory hsc_env apStack_fhv bi `consBL` history
-                 -- history is strict, otherwise our BoundedList is pointless.
-           fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
-           let eval_opts = initEvalOpts dflags True
-           status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv
-           handleRunStatus RunAndLogSteps expr bindings final_ids
-                           status history'
-    | otherwise
-    = not_tracing
-
-  not_tracing
-    -- Hit a breakpoint
-    | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status
-    = do
-         hsc_env <- getSession
-         let interp = hscInterp hsc_env
-         resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt
-         apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref
-         let hmi = expectJust "handleRunStatus" $
-                     lookupHptDirectly (hsc_HPT hsc_env)
-                                       (mkUniqueGrimily mod_uniq)
-             modl = mi_module (hm_iface hmi)
-             bp | is_exception = Nothing
-                | otherwise = Just (BreakInfo modl ix)
-         (hsc_env1, names, span, decl) <- liftIO $
-           bindLocalsAtBreakpoint hsc_env apStack_fhv bp
-         let
-           resume = Resume
-             { resumeStmt = expr, resumeContext = resume_ctxt_fhv
-             , resumeBindings = bindings, resumeFinalIds = final_ids
-             , resumeApStack = apStack_fhv
-             , resumeBreakInfo = bp
-             , resumeSpan = span, resumeHistory = toListBL history
-             , resumeDecl = decl
-             , resumeCCS = ccs
-             , resumeHistoryIx = 0 }
-           hsc_env2 = pushResume hsc_env1 resume
-
-         setSession hsc_env2
-         return (ExecBreak names bp)
-
-    -- Completed successfully
-    | EvalComplete allocs (EvalSuccess hvals) <- status
-    = do hsc_env <- getSession
-         let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
-             final_names = map getName final_ids
-             interp = hscInterp hsc_env
-         liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals)
-         hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
-         setSession hsc_env'
-         return (ExecComplete (Right final_names) allocs)
-
-    -- Completed with an exception
-    | EvalComplete alloc (EvalException e) <- status
-    = return (ExecComplete (Left (fromSerializableException e)) alloc)
-
-#if __GLASGOW_HASKELL__ <= 810
-    | otherwise
-    = panic "not_tracing" -- actually exhaustive, but GHC can't tell
-#endif
-
-
-resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> Maybe Int
-           -> m ExecResult
-resumeExec canLogSpan step mbCnt
- = do
-   hsc_env <- getSession
-   let ic = hsc_IC hsc_env
-       resume = ic_resume ic
-
-   case resume of
-     [] -> liftIO $
-           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
-     (r:rs) -> do
-        -- unbind the temporary locals by restoring the TypeEnv from
-        -- before the breakpoint, and drop this Resume from the
-        -- InteractiveContext.
-        let (resume_tmp_te,resume_gre_cache) = resumeBindings r
-            ic' = ic { ic_tythings = resume_tmp_te,
-                       ic_gre_cache = resume_gre_cache,
-                       ic_resume   = rs }
-        setSession hsc_env{ hsc_IC = ic' }
-
-        -- remove any bindings created since the breakpoint from the
-        -- linker's environment
-        let old_names = map getName resume_tmp_te
-            new_names = [ n | thing <- ic_tythings ic
-                            , let n = getName thing
-                            , not (n `elem` old_names) ]
-            interp    = hscInterp hsc_env
-            dflags    = hsc_dflags hsc_env
-        liftIO $ Loader.deleteFromLoadedEnv interp new_names
-
-        case r of
-          Resume { resumeStmt = expr, resumeContext = fhv
-                 , resumeBindings = bindings, resumeFinalIds = final_ids
-                 , resumeApStack = apStack, resumeBreakInfo = mb_brkpt
-                 , resumeSpan = span
-                 , resumeHistory = hist } ->
-               withVirtualCWD $ do
-                when (isJust mb_brkpt && isJust mbCnt) $ do
-                  setupBreakpoint hsc_env (fromJust mb_brkpt) (fromJust mbCnt)
-                    -- When the user specified a break ignore count, set it
-                    -- in the interpreter
-                let eval_opts = initEvalOpts dflags (isStep step)
-                status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv
-                let prevHistoryLst = fromListBL 50 hist
-                    hist' = case mb_brkpt of
-                       Nothing -> prevHistoryLst
-                       Just bi
-                         | not $ canLogSpan span -> prevHistoryLst
-                         | otherwise -> mkHistory hsc_env apStack bi `consBL`
-                                                        fromListBL 50 hist
-                handleRunStatus step expr bindings final_ids status hist'
-
-setupBreakpoint :: GhcMonad m => HscEnv -> BreakInfo -> Int -> m ()   -- #19157
-setupBreakpoint hsc_env brkInfo cnt = do
-  let modl :: Module = breakInfo_module brkInfo
-      breaks hsc_env modl = getModBreaks $ expectJust "setupBreakpoint" $
-         lookupHpt (hsc_HPT hsc_env) (moduleName modl)
-      ix = breakInfo_number brkInfo
-      modBreaks  = breaks hsc_env modl
-      breakarray = modBreaks_flags modBreaks
-      interp = hscInterp hsc_env
-  _ <- liftIO $ GHCi.storeBreakpoint interp breakarray ix cnt
-  pure ()
-
-back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
-back n = moveHist (+n)
-
-forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
-forward n = moveHist (subtract n)
-
-moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)
-moveHist fn = do
-  hsc_env <- getSession
-  case ic_resume (hsc_IC hsc_env) of
-     [] -> liftIO $
-           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
-     (r:rs) -> do
-        let ix = resumeHistoryIx r
-            history = resumeHistory r
-            new_ix = fn ix
-        --
-        when (history `lengthLessThan` new_ix) $ liftIO $
-           throwGhcExceptionIO (ProgramError "no more logged breakpoints")
-        when (new_ix < 0) $ liftIO $
-           throwGhcExceptionIO (ProgramError "already at the beginning of the history")
-
-        let
-          update_ic apStack mb_info = do
-            (hsc_env1, names, span, decl) <-
-              liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info
-            let ic = hsc_IC hsc_env1
-                r' = r { resumeHistoryIx = new_ix }
-                ic' = ic { ic_resume = r':rs }
-
-            setSession hsc_env1{ hsc_IC = ic' }
-
-            return (names, new_ix, span, decl)
-
-        -- careful: we want apStack to be the AP_STACK itself, not a thunk
-        -- around it, hence the cases are carefully constructed below to
-        -- make this the case.  ToDo: this is v. fragile, do something better.
-        if new_ix == 0
-           then case r of
-                   Resume { resumeApStack = apStack,
-                            resumeBreakInfo = mb_brkpt } ->
-                          update_ic apStack mb_brkpt
-           else case history !! (new_ix - 1) of
-                   History{..} ->
-                     update_ic historyApStack (Just historyBreakInfo)
-
-
--- -----------------------------------------------------------------------------
--- After stopping at a breakpoint, add free variables to the environment
-
-result_fs :: FastString
-result_fs = fsLit "_result"
-
-bindLocalsAtBreakpoint
-        :: HscEnv
-        -> ForeignHValue
-        -> Maybe BreakInfo
-        -> IO (HscEnv, [Name], SrcSpan, String)
-
--- Nothing case: we stopped when an exception was raised, not at a
--- breakpoint.  We have no location information or local variables to
--- bind, all we can do is bind a local variable to the exception
--- value.
-bindLocalsAtBreakpoint hsc_env apStack Nothing = do
-   let exn_occ = mkVarOccFS (fsLit "_exception")
-       span    = mkGeneralSrcSpan (fsLit "<unknown>")
-   exn_name <- newInteractiveBinder hsc_env exn_occ span
-
-   let e_fs    = fsLit "e"
-       e_name  = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
-       e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind
-       exn_id  = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
-
-       ictxt0 = hsc_IC hsc_env
-       ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
-       interp = hscInterp hsc_env
-   --
-   Loader.extendLoadedEnv interp [(exn_name, apStack)]
-   return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
-
--- Just case: we stopped at a breakpoint, we have information about the location
--- of the breakpoint and the free variables of the expression.
-bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
-   let
-       hmi       = expectJust "bindLocalsAtBreakpoint" $
-                     lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module)
-       interp    = hscInterp hsc_env
-       breaks    = getModBreaks hmi
-       info      = expectJust "bindLocalsAtBreakpoint2" $
-                     IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)
-       mbVars    = cgb_vars info
-       result_ty = cgb_resty info
-       occs      = modBreaks_vars breaks ! breakInfo_number
-       span      = modBreaks_locs breaks ! breakInfo_number
-       decl      = intercalate "." $ modBreaks_decls breaks ! breakInfo_number
-
-           -- Filter out any unboxed ids by changing them to Nothings;
-           -- we can't bind these at the prompt
-       mbPointers = nullUnboxed <$> mbVars
-
-       (ids, offsets, occs') = syncOccs mbPointers occs
-
-       free_tvs = tyCoVarsOfTypesWellScoped (result_ty:map idType ids)
-
-   -- It might be that getIdValFromApStack fails, because the AP_STACK
-   -- has been accidentally evaluated, or something else has gone wrong.
-   -- So that we don't fall over in a heap when this happens, just don't
-   -- bind any free variables instead, and we emit a warning.
-   mb_hValues <-
-      mapM (getBreakpointVar interp apStack_fhv . fromIntegral) offsets
-   when (any isNothing mb_hValues) $
-      debugTraceMsg (hsc_logger hsc_env) 1 $
-          text "Warning: _result has been evaluated, some bindings have been lost"
-
-   us <- mkSplitUniqSupply 'I'   -- Dodgy; will give the same uniques every time
-   let tv_subst     = newTyVars us free_tvs
-       (filtered_ids, occs'') = unzip         -- again, sync the occ-names
-          [ (id, occ) | (id, Just _hv, occ) <- zip3 ids mb_hValues occs' ]
-       (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $
-                      map (substTy tv_subst . idType) filtered_ids
-
-   new_ids     <- zipWith3M mkNewId occs'' tidy_tys filtered_ids
-   result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span
-
-   let result_id = Id.mkVanillaGlobal result_name
-                     (substTy tv_subst result_ty)
-       result_ok = isPointer result_id
-
-       final_ids | result_ok = result_id : new_ids
-                 | otherwise = new_ids
-       ictxt0 = hsc_IC hsc_env
-       ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
-       names  = map idName new_ids
-
-   let fhvs = catMaybes mb_hValues
-   Loader.extendLoadedEnv interp (zip names fhvs)
-   when result_ok $ Loader.extendLoadedEnv interp [(result_name, apStack_fhv)]
-   hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
-   return (hsc_env1, if result_ok then result_name:names else names, span, decl)
-  where
-        -- We need a fresh Unique for each Id we bind, because the linker
-        -- state is single-threaded and otherwise we'd spam old bindings
-        -- whenever we stop at a breakpoint.  The InteractveContext is properly
-        -- saved/restored, but not the linker state.  See #1743, test break026.
-   mkNewId :: OccName -> Type -> Id -> IO Id
-   mkNewId occ ty old_id
-     = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)
-          ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }
-
-   newTyVars :: UniqSupply -> [TcTyVar] -> Subst
-     -- Similarly, clone the type variables mentioned in the types
-     -- we have here, *and* make them all RuntimeUnk tyvars
-   newTyVars us tvs = foldl' new_tv emptySubst (tvs `zip` uniqsFromSupply us)
-   new_tv subst (tv,uniq) = extendTCvSubstWithClone subst tv new_tv
-    where
-     new_tv = mkRuntimeUnkTyVar (setNameUnique (tyVarName tv) uniq)
-                                (substTy subst (tyVarKind tv))
-
-   isPointer id | [rep] <- typePrimRep (idType id)
-                , isGcPtrRep rep                   = True
-                | otherwise                        = False
-
-   -- Convert unboxed Id's to Nothings
-   nullUnboxed (Just (fv@(id, _)))
-     | isPointer id          = Just fv
-     | otherwise             = Nothing
-   nullUnboxed Nothing       = Nothing
-
-   -- See Note [Syncing breakpoint info]
-   syncOccs :: [Maybe (a,b)] -> [c] -> ([a], [b], [c])
-   syncOccs mbVs ocs = unzip3 $ catMaybes $ joinOccs mbVs ocs
-     where
-       joinOccs :: [Maybe (a,b)] -> [c] -> [Maybe (a,b,c)]
-       joinOccs = zipWithEqual "bindLocalsAtBreakpoint" joinOcc
-       joinOcc mbV oc = (\(a,b) c -> (a,b,c)) <$> mbV <*> pure oc
-
-rttiEnvironment :: HscEnv -> IO HscEnv
-rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
-   let tmp_ids = [id | AnId id <- ic_tythings ic]
-       incompletelyTypedIds =
-           [id | id <- tmp_ids
-               , not $ noSkolems id
-               , (occNameFS.nameOccName.idName) id /= result_fs]
-   foldM improveTypes hsc_env (map idName incompletelyTypedIds)
-    where
-     noSkolems = noFreeVarsOfType . idType
-     improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
-      let tmp_ids = [id | AnId id <- ic_tythings ic]
-          Just id = find (\i -> idName i == name) tmp_ids
-      if noSkolems id
-         then return hsc_env
-         else do
-           mb_new_ty <- reconstructType hsc_env 10 id
-           let old_ty = idType id
-           case mb_new_ty of
-             Nothing -> return hsc_env
-             Just new_ty -> do
-              case improveRTTIType hsc_env old_ty new_ty of
-               Nothing -> warnPprTrace True (":print failed to calculate the "
-                                             ++ "improvement for a type")
-                              (vcat [ text "id" <+> ppr id
-                                    , text "old_ty" <+> debugPprType old_ty
-                                    , text "new_ty" <+> debugPprType new_ty ]) $
-                          return hsc_env
-               Just subst -> do
-                 let logger = hsc_logger hsc_env
-                 putDumpFileMaybe logger Opt_D_dump_rtti "RTTI"
-                   FormatText
-                   (fsep [text "RTTI Improvement for", ppr id, equals,
-                          ppr subst])
-
-                 let ic' = substInteractiveContext ic subst
-                 return hsc_env{hsc_IC=ic'}
-
-pushResume :: HscEnv -> Resume -> HscEnv
-pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
-  where
-        ictxt0 = hsc_IC hsc_env
-        ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
-
-
-  {-
-  Note [Syncing breakpoint info]
-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  To display the values of the free variables for a single breakpoint, the
-  function `GHC.Runtime.Eval.bindLocalsAtBreakpoint` pulls
-  out the information from the fields `modBreaks_breakInfo` and
-  `modBreaks_vars` of the `ModBreaks` data structure.
-  For a specific breakpoint this gives 2 lists of type `Id` (or `Var`)
-  and `OccName`.
-  They are used to create the Id's for the free variables and must be kept
-  in sync!
-
-  There are 3 situations where items are removed from the Id list
-  (or replaced with `Nothing`):
-  1.) If function `GHC.StgToByteCode.schemeER_wrk` (which creates
-      the Id list) doesn't find an Id in the ByteCode environment.
-  2.) If function `GHC.Runtime.Eval.bindLocalsAtBreakpoint`
-      filters out unboxed elements from the Id list, because GHCi cannot
-      yet handle them.
-  3.) If the GHCi interpreter doesn't find the reference to a free variable
-      of our breakpoint. This also happens in the function
-      bindLocalsAtBreakpoint.
-
-  If an element is removed from the Id list, then the corresponding element
-  must also be removed from the Occ list. Otherwise GHCi will confuse
-  variable names as in #8487.
-  -}
-
--- -----------------------------------------------------------------------------
--- Abandoning a resume context
-
-abandon :: GhcMonad m => m Bool
-abandon = do
-   hsc_env <- getSession
-   let ic = hsc_IC hsc_env
-       resume = ic_resume ic
-       interp = hscInterp hsc_env
-   case resume of
-      []    -> return False
-      r:rs  -> do
-         setSession hsc_env{ hsc_IC = ic { ic_resume = rs } }
-         liftIO $ abandonStmt interp (resumeContext r)
-         return True
-
-abandonAll :: GhcMonad m => m Bool
-abandonAll = do
-   hsc_env <- getSession
-   let ic = hsc_IC hsc_env
-       resume = ic_resume ic
-       interp = hscInterp hsc_env
-   case resume of
-      []  -> return False
-      rs  -> do
-         setSession hsc_env{ hsc_IC = ic { ic_resume = [] } }
-         liftIO $ mapM_ (abandonStmt interp. resumeContext) rs
-         return True
-
--- -----------------------------------------------------------------------------
--- Bounded list, optimised for repeated cons
-
-data BoundedList a = BL
-                        {-# UNPACK #-} !Int  -- length
-                        {-# UNPACK #-} !Int  -- bound
-                        [a] -- left
-                        [a] -- right,  list is (left ++ reverse right)
-
-nilBL :: Int -> BoundedList a
-nilBL bound = BL 0 bound [] []
-
-consBL :: a -> BoundedList a -> BoundedList a
-consBL a (BL len bound left right)
-  | len < bound = BL (len+1) bound (a:left) right
-  | null right  = BL len     bound [a]      $! tail (reverse left)
-  | otherwise   = BL len     bound (a:left) $! tail right
-
-toListBL :: BoundedList a -> [a]
-toListBL (BL _ _ left right) = left ++ reverse right
-
-fromListBL :: Int -> [a] -> BoundedList a
-fromListBL bound l = BL (length l) bound l []
-
--- lenBL (BL len _ _ _) = len
-
--- -----------------------------------------------------------------------------
--- | Set the interactive evaluation context.
---
--- (setContext imports) sets the ic_imports field (which in turn
--- determines what is in scope at the prompt) to 'imports', and
--- updates the icReaderEnv environment to reflect it.
---
--- We retain in scope all the things defined at the prompt, and kept
--- in ic_tythings.  (Indeed, they shadow stuff from ic_imports.)
-
-setContext :: GhcMonad m => [InteractiveImport] -> m ()
-setContext imports
-  = do { hsc_env <- getSession
-       ; let dflags = hsc_dflags hsc_env
-       ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
-       ; case all_env_err of
-           Left (mod, err) ->
-               liftIO $ throwGhcExceptionIO (formatError dflags mod err)
-           Right all_env -> do {
-       ; let old_ic         = hsc_IC hsc_env
-             !final_gre_cache = ic_gre_cache old_ic `replaceImportEnv` all_env
-       ; setSession
-         hsc_env{ hsc_IC = old_ic { ic_imports   = imports
-                                  , ic_gre_cache = final_gre_cache }}}}
-  where
-    formatError dflags mod err = ProgramError . showSDoc dflags $
-      text "Cannot add module" <+> ppr mod <+>
-      text "to context:" <+> text err
-
-findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
-                 -> IO (Either (ModuleName, String) GlobalRdrEnv)
--- Compute the GlobalRdrEnv for the interactive context
-findGlobalRdrEnv hsc_env imports
-  = do { idecls_env <- hscRnImportDecls hsc_env idecls
-                    -- This call also loads any orphan modules
-       ; return $ case partitionEithers (map mkEnv imods) of
-           ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env)
-           (err : _, _)    -> Left err }
-  where
-    idecls :: [LImportDecl GhcPs]
-    idecls = [noLocA d | IIDecl d <- imports]
-
-    imods :: [ModuleName]
-    imods = [m | IIModule m <- imports]
-
-    mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of
-      Left err -> Left (mod, err)
-      Right env -> Right env
-
-mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
-mkTopLevEnv hpt modl
-  = case lookupHpt hpt modl of
-      Nothing -> Left "not a home module"
-      Just details ->
-         case mi_globals (hm_iface details) of
-                Nothing  -> Left "not interpreted"
-                Just env -> Right env
-
--- | Get the interactive evaluation context, consisting of a pair of the
--- set of modules from which we take the full top-level scope, and the set
--- of modules from which we take just the exports respectively.
-getContext :: GhcMonad m => m [InteractiveImport]
-getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
-             return (ic_imports ic)
-
--- | Returns @True@ if the specified module is interpreted, and hence has
--- its full top-level scope available.
-moduleIsInterpreted :: GhcMonad m => Module -> m Bool
-moduleIsInterpreted modl = withSession $ \h ->
- if notHomeModule (hsc_home_unit h) modl
-        then return False
-        else case lookupHpt (hsc_HPT h) (moduleName modl) of
-                Just details       -> return (isJust (mi_globals (hm_iface details)))
-                _not_a_home_module -> return False
-
--- | Looks up an identifier in the current interactive context (for :info)
--- Filter the instances by the ones whose tycons (or classes resp)
--- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
--- The exact choice of which ones to show, and which to hide, is a judgement call.
---      (see #1581)
-getInfo :: GhcMonad m => Bool -> Name
-        -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst], SDoc))
-getInfo allInfo name
-  = withSession $ \hsc_env ->
-    do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
-       case mb_stuff of
-         Nothing -> return Nothing
-         Just (thing, fixity, cls_insts, fam_insts, docs) -> do
-           let rdr_env = icReaderEnv (hsc_IC hsc_env)
-
-           -- Filter the instances based on whether the constituent names of their
-           -- instance heads are all in scope.
-           let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts
-               fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts
-           return (Just (thing, fixity, cls_insts', fam_insts', docs))
-  where
-    plausible rdr_env names
-          -- Dfun involving only names that are in icReaderEnv
-        = allInfo
-       || nameSetAll ok names
-        where   -- A name is ok if it's in the rdr_env,
-                -- whether qualified or not
-          ok n | n == name              = True
-                       -- The one we looked for in the first place!
-               | pretendNameIsInScope n = True
-                   -- See Note [pretendNameIsInScope] in GHC.Builtin.Names
-               | isExternalName n       = isJust (lookupGRE_Name rdr_env n)
-               | otherwise              = True
-
--- | Returns all names in scope in the current interactive context
-getNamesInScope :: GhcMonad m => m [Name]
-getNamesInScope = withSession $ \hsc_env ->
-  return (map greMangledName (globalRdrEnvElts (icReaderEnv (hsc_IC hsc_env))))
-
--- | Returns all 'RdrName's in scope in the current interactive
--- context, excluding any that are internally-generated.
-getRdrNamesInScope :: GhcMonad m => m [RdrName]
-getRdrNamesInScope = withSession $ \hsc_env -> do
-  let
-      ic = hsc_IC hsc_env
-      gbl_rdrenv = icReaderEnv ic
-      gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv
-  -- Exclude internally generated names; see e.g. #11328
-  return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names)
-
-
--- | Parses a string as an identifier, and returns the list of 'Name's that
--- the identifier can refer to in the current interactive context.
-parseName :: GhcMonad m => String -> m [Name]
-parseName str = withSession $ \hsc_env -> liftIO $
-   do { lrdr_name <- hscParseIdentifier hsc_env str
-      ; hscTcRnLookupRdrName hsc_env lrdr_name }
-
-
-getDocs :: GhcMonad m
-        => Name
-        -> m (Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))
-           -- TODO: What about docs for constructors etc.?
-getDocs name =
-  withSession $ \hsc_env -> do
-     case nameModule_maybe name of
-       Nothing -> pure (Left (NameHasNoModule name))
-       Just mod -> do
-         if isInteractiveModule mod
-           then pure (Left InteractiveName)
-           else do
-             iface <- liftIO $ hscGetModuleInterface hsc_env mod
-             case mi_docs iface of
-               Nothing -> pure (Left (NoDocsInIface mod compiled))
-               Just Docs { docs_decls = decls
-                         , docs_args = args
-                         } ->
-                 pure (Right ( lookupUniqMap decls name
-                             , fromMaybe mempty $ lookupUniqMap args name))
-  where
-    compiled =
-      -- TODO: Find a more direct indicator.
-      case nameSrcLoc name of
-        RealSrcLoc {} -> False
-        UnhelpfulLoc {} -> True
-
--- | Failure modes for 'getDocs'.
-data GetDocsFailure
-
-    -- | 'nameModule_maybe' returned 'Nothing'.
-  = NameHasNoModule Name
-
-    -- | The module was loaded without @-haddock@,
-  | NoDocsInIface
-      Module
-      Bool -- ^ 'True': The module was compiled.
-           -- 'False': The module was :loaded.
-
-    -- | The 'Name' was defined interactively.
-  | InteractiveName
-
-instance Outputable GetDocsFailure where
-  ppr (NameHasNoModule name) =
-    quotes (ppr name) <+> text "has no module where we could look for docs."
-  ppr (NoDocsInIface mod compiled) = vcat
-    [ text "Can't find any documentation for" <+> ppr mod <> char '.'
-    , if compiled
-        then text "Try re-compiling with '-haddock'."
-        else text "Try running ':set -haddock' and :load the file again."
-        -- TODO: Figure out why :reload doesn't load the docs and maybe fix it.
-    ]
-  ppr InteractiveName =
-    text "Docs are unavailable for interactive declarations."
-
--- -----------------------------------------------------------------------------
--- Getting the type of an expression
-
--- | Get the type of an expression
--- Returns the type as described by 'TcRnExprMode'
-exprType :: GhcMonad m => TcRnExprMode -> String -> m Type
-exprType mode expr = withSession $ \hsc_env -> do
-   ty <- liftIO $ hscTcExpr hsc_env mode expr
-   return $ tidyType emptyTidyEnv ty
-
--- -----------------------------------------------------------------------------
--- Getting the kind of a type
-
--- | Get the kind of a  type
-typeKind  :: GhcMonad m => Bool -> String -> m (Type, Kind)
-typeKind normalise str = withSession $ \hsc_env ->
-   liftIO $ hscKcType hsc_env normalise str
-
--- ----------------------------------------------------------------------------
--- Getting the class instances for a type
-
-{-
-  Note [Querying instances for a type]
-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  Here is the implementation of GHC proposal 41.
-  (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0041-ghci-instances.rst)
-
-  The objective is to take a query string representing a (partial) type, and
-  report all the class single-parameter class instances available to that type.
-  Extending this feature to multi-parameter typeclasses is left as future work.
-
-  The general outline of how we solve this is:
-
-  1. Parse the type, leaving skolems in the place of type-holes.
-  2. For every class, get a list of all instances that match with the query type.
-  3. For every matching instance, ask GHC for the context the instance dictionary needs.
-  4. Format and present the results, substituting our query into the instance
-     and simplifying the context.
-
-  For example, given the query "Maybe Int", we want to return:
-
-  instance Show (Maybe Int)
-  instance Read (Maybe Int)
-  instance Eq   (Maybe Int)
-  ....
-
-  [Holes in queries]
-
-  Often times we want to know what instances are available for a polymorphic type,
-  like `Maybe a`, and we'd like to return instances such as:
-
-  instance Show a => Show (Maybe a)
-  ....
-
-  These queries are expressed using type holes, so instead of `Maybe a` the user writes
-  `Maybe _`, we parse the type and during zonking, we skolemise it, replacing the holes
-  with (un-named) type variables.
-
-  When zonking the type holes we have two real choices: replace them with Any or replace
-  them with skolem typevars. Using skolem type variables ensures that the output is more
-  intuitive to end users, and there is no difference in the results between Any and skolems.
-
--}
-
--- Find all instances that match a provided type
-getInstancesForType :: GhcMonad m => Type -> m [ClsInst]
-getInstancesForType ty = withSession $ \hsc_env ->
-  liftIO $ runInteractiveHsc hsc_env $
-    ioMsgMaybe $ hoistTcRnMessage $ runTcInteractive hsc_env $ do
-      -- Bring class and instances from unqualified modules into scope, this fixes #16793.
-      loadUnqualIfaces hsc_env (hsc_IC hsc_env)
-      matches <- findMatchingInstances ty
-
-      fmap catMaybes . forM matches $ uncurry checkForExistence
-
--- Parse a type string and turn any holes into skolems
-parseInstanceHead :: GhcMonad m => String -> m Type
-parseInstanceHead str = withSession $ \hsc_env0 -> do
-  (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do
-    hsc_env <- getHscEnv
-    ty <- hscParseType str
-    ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env SkolemiseFlexi True ty
-
-  return ty
-
--- Get all the constraints required of a dictionary binding
-getDictionaryBindings :: PredType -> TcM CtEvidence
-getDictionaryBindings theta = do
-  dictName <- newName (mkDictOcc (mkVarOccFS (fsLit "magic")))
-  let dict_var = mkVanillaGlobal dictName theta
-  loc <- getCtLocM (GivenOrigin (getSkolemInfo unkSkol)) Nothing
-
-  return CtWanted {
-    ctev_pred = varType dict_var,
-    ctev_dest = EvVarDest dict_var,
-    ctev_loc = loc,
-    ctev_rewriters = emptyRewriterSet
-  }
-
--- Find instances where the head unifies with the provided type
-findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])]
-findMatchingInstances ty = do
-  ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs
-  let allClasses = uniqDSetToList $ instEnvClasses ie_global `unionUniqDSets` instEnvClasses ie_local
-  return $ concatMap (try_cls ies) allClasses
-  where
-  {- Check that a class instance is well-kinded.
-    Since `:instances` only works for unary classes, we're looking for instances of kind
-    k -> Constraint where k is the type of the queried type.
-  -}
-  try_cls ies cls
-    | Just (_, _, arg_kind, res_kind) <- splitFunTy_maybe (tyConKind $ classTyCon cls)
-    , isConstraintKind res_kind
-    , Type.typeKind ty `eqType` arg_kind
-    , (matches, _, _) <- lookupInstEnv True ies cls [ty]
-    = matches
-    | otherwise
-    = []
-
-
-{-
-  When we've found an instance that a query matches against, we still need to
-  check that all the instance's constraints are satisfiable. checkForExistence
-  creates an instance dictionary and verifies that any unsolved constraints
-  mention a type-hole, meaning it is blocked on an unknown.
-
-  If the instance satisfies this condition, then we return it with the query
-  substituted into the instance and all constraints simplified, for example given:
-
-  instance D a => C (MyType a b) where
-
-  and the query `MyType _ String`
-
-  the unsolved constraints will be [D _] so we apply the substitution:
-
-  { a -> _; b -> String}
-
-  and return the instance:
-
-  instance D _ => C (MyType _ String)
-
--}
-
-checkForExistence :: ClsInst -> [DFunInstType] -> TcM (Maybe ClsInst)
-checkForExistence clsInst mb_inst_tys = do
-  -- We want to force the solver to attempt to solve the constraints for clsInst.
-  -- Usually, this isn't a problem since there should only be a single instance
-  -- for a type. However, when we have overlapping instances, the solver will give up
-  -- since it can't decide which instance to use. To get around this restriction, instead
-  -- of asking the solver to solve a constraint for clsInst, we ask it to solve the
-  -- thetas of clsInst.
-  (tys, thetas) <- instDFunType (is_dfun clsInst) mb_inst_tys
-  wanteds <- mapM getDictionaryBindings thetas
-  -- It's important to zonk constraints after solving in order to expose things like TypeErrors
-  -- which otherwise appear as opaque type variables. (See #18262).
-  WC { wc_simple = simples, wc_impl = impls } <- simplifyWantedsTcM wanteds
-
-  -- The simples might contain superclasses. This clutters up the output
-  -- (we want e.g. instance Ord a => Ord (Maybe a), not
-  -- instance (Ord a, Eq a) => Ord (Maybe a)). So we use mkMinimalBySCs
-  let simple_preds = map ctPred (bagToList simples)
-  let minimal_simples = mkMinimalBySCs id simple_preds
-
-  if all allowedSimple minimal_simples && solvedImplics impls
-  then return . Just $ substInstArgs tys minimal_simples clsInst
-  else return Nothing
-
-  where
-  allowedSimple :: PredType -> Bool
-  allowedSimple pred = isSatisfiablePred pred
-
-  solvedImplics :: Bag Implication -> Bool
-  solvedImplics impls = allBag (isSolvedStatus . ic_status) impls
-
-  -- Stricter version of isTyVarClassPred that requires all TyConApps to have at least
-  -- one argument or for the head to be a TyVar. The reason is that we want to ensure
-  -- that all residual constraints mention a type-hole somewhere in the constraint,
-  -- meaning that with the correct choice of a concrete type it could be possible for
-  -- the constraint to be discharged.
-  isSatisfiablePred :: PredType -> Bool
-  isSatisfiablePred ty = case getClassPredTys_maybe ty of
-      Just (_, tys@(_:_)) -> all isTyVarTy tys
-      _                   -> isTyVarTy ty
-
-  empty_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun clsInst)))
-
-  {- Create a ClsInst with instantiated arguments and constraints.
-
-     The thetas are the list of constraints that couldn't be solved because
-     they mention a type-hole.
-  -}
-  substInstArgs ::  [Type] -> [PredType] -> ClsInst -> ClsInst
-  substInstArgs tys thetas inst = let
-      subst = foldl' (\a b -> uncurry (extendTvSubstAndInScope a) b) empty_subst (zip dfun_tvs tys)
-      -- Build instance head with arguments substituted in
-      tau   = mkClassPred cls (substTheta subst args)
-      -- Constrain the instance with any residual constraints
-      phi   = mkPhiTy thetas tau
-      sigma = mkForAllTys (map (\v -> Bndr v Inferred) dfun_tvs) phi
-
-    in inst { is_dfun = (is_dfun inst) { varType = sigma }}
-    where
-    (dfun_tvs, _, cls, args) = instanceSig inst
-
------------------------------------------------------------------------------
--- Compile an expression, run it, and deliver the result
-
--- | Parse an expression, the parsed expression can be further processed and
--- passed to compileParsedExpr.
-parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs)
-parseExpr expr = withSession $ \hsc_env ->
-  liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr
-
--- | Compile an expression, run it, and deliver the resulting HValue.
-compileExpr :: GhcMonad m => String -> m HValue
-compileExpr expr = do
-  parsed_expr <- parseExpr expr
-  compileParsedExpr parsed_expr
-
--- | Compile an expression, run it, and deliver the resulting HValue.
-compileExprRemote :: GhcMonad m => String -> m ForeignHValue
-compileExprRemote expr = do
-  parsed_expr <- parseExpr expr
-  compileParsedExprRemote parsed_expr
-
--- | Compile a parsed expression (before renaming), run it, and deliver
--- the resulting HValue.
-compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue
-compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
-  let dflags = hsc_dflags hsc_env
-  let interp = hscInterp hsc_env
-
-  -- > let _compileParsedExpr = expr
-  -- Create let stmt from expr to make hscParsedStmt happy.
-  -- We will ignore the returned [Id], namely [expr_id], and not really
-  -- create a new binding.
-  let expr_fs = fsLit "_compileParsedExpr"
-      loc' = locA loc
-      expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc'
-      let_stmt = L loc . LetStmt noAnn . (HsValBinds noAnn) $
-        ValBinds NoAnnSortKey
-                     (unitBag $ mkHsVarBind loc' (getRdrName expr_name) expr) []
-
-  pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt
-  let (hvals_io, fix_env) = case pstmt of
-        Just ([_id], hvals_io', fix_env') -> (hvals_io', fix_env')
-        _ -> panic "compileParsedExprRemote"
-
-  updateFixityEnv fix_env
-  let eval_opts = initEvalOpts dflags False
-  status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io)
-  case status of
-    EvalComplete _ (EvalSuccess [hval]) -> return hval
-    EvalComplete _ (EvalException e) ->
-      liftIO $ throwIO (fromSerializableException e)
-    _ -> panic "compileParsedExpr"
-
-compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue
-compileParsedExpr expr = do
-   fhv <- compileParsedExprRemote expr
-   interp <- hscInterp <$> getSession
-   liftIO $ wormhole interp fhv
-
--- | Compile an expression, run it and return the result as a Dynamic.
-dynCompileExpr :: GhcMonad m => String -> m Dynamic
-dynCompileExpr expr = do
-  parsed_expr <- parseExpr expr
-  -- > Data.Dynamic.toDyn expr
-  let loc = getLoc parsed_expr
-      to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L (la2na loc) $ getRdrName toDynName)
-                            parsed_expr
-  hval <- compileParsedExpr to_dyn_expr
-  return (unsafeCoerce hval :: Dynamic)
-
------------------------------------------------------------------------------
--- show a module and it's source/object filenames
-
-showModule :: GhcMonad m => ModSummary -> m String
-showModule mod_summary =
-    withSession $ \hsc_env -> do
-        let dflags = hsc_dflags hsc_env
-        let interpreted =
-              case lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) of
-               Nothing       -> panic "missing linkable"
-               Just mod_info -> isJust (homeModInfoByteCode mod_info)  && isNothing (homeModInfoObject mod_info)
-        return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mod_summary))
-
-moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
-moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
-  case lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) of
-        Nothing       -> panic "missing linkable"
-        Just mod_info -> return . isNothing $ homeModInfoByteCode mod_info
-
-----------------------------------------------------------------------------
--- RTTI primitives
-
-obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
-#if defined(HAVE_INTERNAL_INTERPRETER)
-obtainTermFromVal hsc_env bound force ty x = case interpInstance interp of
-  InternalInterp    -> cvObtainTerm hsc_env bound force ty (unsafeCoerce x)
-#else
-obtainTermFromVal hsc_env _bound _force _ty _x = case interpInstance interp of
-#endif
-  ExternalInterp {} -> throwIO (InstallationError
-                        "this operation requires -fno-external-interpreter")
-  where
-    interp = hscInterp hsc_env
-
-obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
-obtainTermFromId hsc_env bound force id =  do
-  (hv, _, _) <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id)
-  cvObtainTerm hsc_env bound force (idType id) hv
-
--- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
-reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
-reconstructType hsc_env bound id = do
-  (hv, _, _) <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id)
-  cvReconstructType hsc_env bound (idType id) hv
-
-mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
-mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk
diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs
deleted file mode 100644
--- a/compiler/GHC/Runtime/Heap/Inspect.hs
+++ /dev/null
@@ -1,1446 +0,0 @@
-{-# LANGUAGE BangPatterns, ScopedTypeVariables, MagicHash #-}
-
------------------------------------------------------------------------------
---
--- GHC Interactive support for inspecting arbitrary closures at runtime
---
--- Pepe Iborra (supported by Google SoC) 2006
---
------------------------------------------------------------------------------
-module GHC.Runtime.Heap.Inspect(
-     -- * 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
-
-import GHC.Prelude hiding (head, init, last, tail)
-import GHC.Platform
-
-import GHC.Runtime.Interpreter as GHCi
-import GHCi.RemoteTypes
-import GHC.Driver.Env
-import GHCi.Message ( fromSerializableException )
-
-import GHC.Core.DataCon
-import GHC.Core.Type
-import GHC.Types.RepType
-import GHC.Core.Multiplicity
-import qualified GHC.Core.Unify as U
-import GHC.Core.TyCon
-
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.Zonk ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) )
-import GHC.Tc.Utils.Unify
-import GHC.Tc.Utils.Env
-
-import GHC.Types.Var
-import GHC.Types.Name
-import GHC.Types.Name.Occurrence as OccName
-import GHC.Unit.Module
-import GHC.Iface.Env
-import GHC.Utils.Misc
-import GHC.Types.Var.Set
-import GHC.Types.Basic ( Boxity(..) )
-import GHC.Builtin.Types.Prim
-import GHC.Builtin.Types
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Utils.Outputable as Ppr
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Char
-import GHC.Exts.Heap
-import GHC.Runtime.Heap.Layout ( roundUpTo )
-import GHC.IO (throwIO)
-
-import Control.Monad
-import Data.Maybe
-import Data.List ((\\))
-import Data.List.NonEmpty (NonEmpty (..))
-import qualified Data.List.NonEmpty as NE
-import GHC.Exts
-import qualified Data.Sequence as Seq
-import Data.Sequence (viewl, ViewL(..))
-import Foreign hiding (shiftL, shiftR)
-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 (stringToUnit pkg) (mkModuleName mod)
-   Right `fmap` lookupNameCache (hsc_NC 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 (dcolon <> pprSigmaType ty))
-ppr_termM1 Suspension{ty=ty, bound_to=Just n}
-  | otherwise = return$ parens$ ppr n <> dcolon <> pprSigmaType 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' (isTyCon integerTyCon . ty) ppr_integer
-  , ifTerm' (isTyCon naturalTyCon . ty) ppr_natural
-  ]
- 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)
-
-   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 Platform 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_bignat :: Bool -> Precedence -> [Word] -> m (Maybe SDoc)
-   ppr_bignat sign _ ws = do
-      let
-         wordSize = finiteBitSize (0 :: Word) -- does the word size depend on the target?
-         makeInteger n _ []     = n
-         makeInteger n s (x:xs) = makeInteger (n + (fromIntegral x `shiftL` s)) (s + wordSize) xs
-         signf = case sign of
-                  False -> 1
-                  True  -> -1
-      return $ Just $ Ppr.integer $ signf * (makeInteger 0 0 ws)
-
-   -- Reconstructing Bignums is a bit of a pain. This depends deeply on their
-   -- 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
-   --     = IS !Int#
-   --     | IP !BigNat
-   --     | IN !BigNat
-   --
-   --   data Natural
-   --     = NS !Word#
-   --     | NB !BigNat
-   --
-   --   type BigNat = ByteArray#
-
-   ppr_integer :: Precedence -> Term -> m (Maybe SDoc)
-   ppr_integer _ Term{dc=Right con, subTerms=[Prim{valRaw=ws}]}
-      | con == integerISDataCon
-      , [W# w] <- ws
-      = return (Just (Ppr.integer (fromIntegral (I# (word2Int# w)))))
-   ppr_integer p Term{dc=Right con, subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]}
-      | con == integerIPDataCon = ppr_bignat False p ws
-      | con == integerINDataCon = ppr_bignat True  p ws
-      | otherwise = panic "Unexpected Integer constructor"
-   ppr_integer _ _ = return Nothing
-
-   ppr_natural :: Precedence -> Term -> m (Maybe SDoc)
-   ppr_natural _ Term{dc=Right con, subTerms=[Prim{valRaw=ws}]}
-      | con == naturalNSDataCon
-      , [w] <- ws
-      = return (Just (Ppr.integer (fromIntegral w)))
-   ppr_natural p Term{dc=Right con, subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]}
-      | con == naturalNBDataCon = ppr_bignat False p ws
-      | otherwise = panic "Unexpected Natural constructor"
-   ppr_natural _ _ = 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
-           elemList   = toList elems
-           isConsLast = not (termType (NE.last elems) `eqType` termType h)
-           is_string  = all (isCharTy . ty) elems
-           chars = [ chr (fromIntegral w)
-                   | Term{subTerms=[Prim{valRaw=[w]}]} <- elemList ]
-
-       print_elems <- mapM (y cons_prec) elemList
-       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 == int8PrimTyCon             = text $ show (build x :: Int8)
-    | t == word8PrimTyCon            = text $ show (build x :: Word8)
-    | t == int16PrimTyCon            = text $ show (build x :: Int16)
-    | t == word16PrimTyCon           = text $ show (build x :: Word16)
-    | 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)
--}
-
-
--- See Note [RttiType]
-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 GHC.Tc.Utils.Monad
--- 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
-
--- When we make new unification variables in the GHCi debugger,
--- we use RuntimeUnkTvs.   See Note [RuntimeUnkTv].
-newVar :: Kind -> TR TcType
-newVar kind = liftTcM (do { tv <- newAnonMetaTyVar RuntimeUnkTv kind
-                          ; return (mkTyVarTy tv) })
-
-newOpenVar :: TR TcType
-newOpenVar = liftTcM (do { kind <- newOpenTypeKind
-                         ; newVar kind })
-
-{- Note [RttiType]
-~~~~~~~~~~~~~~~~~~
-The type synonym `type RttiType = Type` is the type synonym used
-by the debugger for the types of the data type `Term`.
-
-For a long time the `RttiType` carried the following comment:
-
->     A (non-mutable) tau type containing
->     existentially quantified tyvars.
->          (since GHC type language currently does not support
->          existentials, we leave these variables unquantified)
-
-The tau type part is only correct for terms representing the results
-of fully saturated functions that return non-function (data) values
-and not functions.
-
-For non-function values, the GHC runtime always works with concrete
-types eg `[Maybe Int]`, but never with polymorphic types like eg
-`(Traversable t, Monad m) => t (m a)`. The concrete types, don't
-need a quantification. They are always tau types.
-
-The debugger binds the terms of :print commands and of the free
-variables at a breakpoint to names. These newly bound names can
-be used in new GHCi expressions. If these names represent functions,
-then the type checker expects that the types of these functions are
-fully-fledged. They must contain the necessary `forall`s and type
-constraints. Hence the types of terms that represent functions must
-be sigmas and not taus.
-(See #12449)
--}
-
-{- Note [RuntimeUnkTv]
-~~~~~~~~~~~~~~~~~~~~~~
-In the GHCi debugger we use unification variables whose MetaInfo is
-RuntimeUnkTv.  The special property of a RuntimeUnkTv is that it can
-unify with a polytype (see GHC.Tc.Utils.Unify.checkTypeEq).
-If we don't do this `:print <term>` will fail if the type of <term>
-has nested `forall`s or `=>`s.
-
-This is because the GHCi debugger's internals will attempt to unify a
-metavariable with the type of <term> and then display the result, but
-if the type has nested `forall`s or `=>`s, then unification will fail
-unless we do something special.  As a result, `:print` will bail out
-and the unhelpful result will be `<term> = (_t1::t1)` (where `t1` is a
-metavariable).
-
-Beware: <term> can have nested `forall`s even if its definition doesn't use
-RankNTypes! Here is an example from #14828:
-
-  class Functor f where
-    fmap :: (a -> b) -> f a -> f b
-
-Somewhat surprisingly, `:print fmap` considers the type of fmap to have
-nested foralls. This is because the GHCi debugger sees the type
-`fmap :: forall f. Functor f => forall a b. (a -> b) -> f a -> f b`.
-We could envision deeply instantiating this type to get the type
-`forall f a b. Functor f => (a -> b) -> f a -> f b`,
-but this trick wouldn't work for higher-rank types.
-
-Instead, we adopt a simpler fix: allow RuntimeUnkTv to unify with a
-polytype (specifically, see ghci_tv in GHC.Tc.Utils.Unify.preCheck).
-This allows metavariables to unify with types that have
-nested (or higher-rank) `forall`s/`=>`s, which makes `:print fmap`
-display as
-`fmap = (_t1::forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b)`,
-as expected.
--}
-
-
-instTyVars :: [TyVar] -> TR (Subst, [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
-   --
-   -- July 20: I'm not convinced that the little dance from
-   -- RuntimeUnkTv unification variables to RuntimeUnk skolems
-   -- is buying us anything.  ToDo: get rid of it.
-
--- | 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]
-       ; traceTR (text "instScheme" <+> (ppr tvs $$ ppr ty $$ ppr 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 getTyVar_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, _) = quantifyType old_ty
-   traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
-   term <-
-     if null old_tvs
-      then do
-        term  <- go max_depth old_ty 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 old_tvs) (traceTR (text "check1 passed") >>
-                                          addConstraint my_ty old_ty')
-              term  <- go max_depth my_ty old_ty hval
-              new_ty <- zonkTcType (termType term)
-              if isMonomorphic new_ty || check2 new_ty 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 splitTyConApp_maybe ty of
-                                           -- SPJ: I have no idea why we are
-                                           --      matching on (:) here, nor
-                                           --      what the isFunTy is for
-                                           Just (_tc, _ : _) | not (isFunTy ty)
-                                                             -> 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
-  interp = hscInterp hsc_env
-  unit_env = hsc_unit_env hsc_env
-
-  go :: Int -> Type -> Type -> ForeignHValue -> TcM Term
-   -- [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 interp 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 interp a
-    case clos of
--- Thunks we may want to force
-      t | isThunk t && force -> do
-         traceTR (text "Forcing a " <> text (show (fmap (const ()) t)))
-         evalRslt <- liftIO $ GHCi.seqHValue interp unit_env a
-         case evalRslt of                                            -- #2950
-           EvalSuccess _ -> go (pred max_depth) my_ty old_ty a
-           EvalException ex -> do
-              -- Report the exception to the UI
-              traceTR $ text "Exception occurred:" <+> text (show ex)
-              liftIO $ throwIO $ fromSerializableException ex
--- 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 interp 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,[lev,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
-         massert (tycon == mutVarPrimTyCon)
-         massert (isUnliftedType my_ty)
-         traceTR (text "Following a MutVar")
-         let contents_kind = mkTYPEapp (mkTyConApp boxedRepDataConTyCon [lev])
-         contents_tv <- newVar contents_kind
-         (mutvar_ty,_) <- instScheme $ quantifyType $ mkVisFunTyMany
-                            contents_ty (mkTyConApp tycon [lev, world,contents_ty])
-         addConstraint (mkVisFunTyMany 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 pointed ones
-                        -- This preserves laziness, and should be safe.
-                       traceTR (text "Not constructor" <+> ppr dcname)
-                       let dflags = hsc_dflags hsc_env
-                           tag = showPpr dflags dcname
-                       vars     <- mapM (const (newVar liftedTypeKind)) pArgs
-                       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 GHC.Core.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
-          platform <- getPlatform
-          let word_size = platformWordSizeInBytes platform
-              endian = platformByteOrder platform
-              size_b = primRepSizeB platform 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 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
-    -- A sub word is aligned to the left-most part of a word on big-endian
-    -- platforms, and to the right-most part of a word on little-endian
-    -- platforms.  This allows to write and read it back from memory
-    -- independent of endianness.  Bits not belonging to a sub word are zeroed
-    -- out, although, this is strictly speaking not necessary since a sub word
-    -- is read back from memory by appropriately casted pointers (see e.g.
-    -- ppr_float of cPprTermBase).
-    index size_b aligned_idx word_size endian = case endian of
-      BigEndian    -> (word `shiftL` moveBits) `shiftR` zeroOutBits `shiftL` zeroOutBits
-      LittleEndian -> (word `shiftR` moveBits) `shiftL` zeroOutBits `shiftR` zeroOutBits
-     where
-      (q, r) = aligned_idx `quotRem` word_size
-      word = array!!q
-      moveBits = r * 8
-      zeroOutBits = (word_size - size_b) * 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 old_tvs) (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 new_ty 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
-  interp = hscInterp hsc_env
-
---  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 interp a
-    case clos of
-      BlackholeClosure{indirectee=ind} -> go my_ty ind
-      IndClosure{indirectee=ind} -> go my_ty ind
-      MutVarClosure{var=contents}
-        | Just (_tycon,[lev,_world,_contents_ty]) <- tcSplitTyConApp_maybe my_ty
-        -> do
-        massert (_tycon == mutVarPrimTyCon)
-        tv'   <- newVar $ mkTYPEapp (mkTyConApp boxedRepDataConTyCon [lev])
-        world <- newVar liftedTypeKind
-        addConstraint my_ty $ mkMutVarPrimTy world tv'
-        return [(tv', contents)]
-      APClosure {payload=pLoad} -> do                -- #19559 (incr)
-        mapM_ (go my_ty) pLoad
-        return []
-      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->
-            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 Subst
-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
-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 (map scaledThing $ 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 auxiliary 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 :: [TyVar] -> Bool
-check1 tvs = not $ any isHigherKind (map tyVarKind tvs)
- where
-   isHigherKind = not . null . fst . splitPiTys
-
-check2 :: Type -> Type -> Bool
-check2 rtti_ty old_ty = check2' (tauPart rtti_ty) (tauPart old_ty)
-  -- The function `tcSplitTyConApp_maybe` doesn't split foralls or types
-  -- headed with (=>). Hence here we need only the tau part of a type.
-  -- See Note [Missing test case].
-  where
-    check2' rtti_ty old_ty
-      | Just (_, rttis) <- tcSplitTyConApp_maybe rtti_ty
-      = case () of
-          _ | Just (_,olds) <- tcSplitTyConApp_maybe old_ty
-            -> and$ zipWith check2 rttis olds
-          _ | Just _ <- splitAppTy_maybe old_ty
-            -> isMonomorphicOnNonPhantomArgs rtti_ty
-          _ -> True
-      | otherwise = True
-    tauPart ty = tau
-      where
-        (_, _, tau) = tcSplitNestedSigmaTys ty
-{-
-Note [Missing test case]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Her we miss a test case. It should be a term, with a function `f`
-with a non-empty sigma part and an unsound type. The result of
-`check2 f` should be different if we omit or do the calls to `tauPart`.
-I (R.Senn) was unable to find such a term, and I'm in doubt, whether it exists.
--}
-
--- 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 (af1,w1,l1,l2) <- splitFunTy_maybe l
-    , Just (af2,w2,r1,r2) <- splitFunTy_maybe r
-    , af1==af2
-    , w1 `eqType` w2
-    = do r2' <- go l2 r2
-         r1' <- go l1 r1
-         return (mkFunTy af1 w1 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
-
-quantifyType :: Type -> QuantifiedType
--- Find all free and forall'd tyvars and return them
--- together with the unmodified input type.
-quantifyType ty = ( filter isTyVar $
-                    tyCoVarsOfTypeWellScoped rho
-                  , ty)
-  where
-    (_tvs, _, rho) = tcSplitNestedSigmaTys ty
diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs
deleted file mode 100644
--- a/compiler/GHC/Runtime/Loader.hs
+++ /dev/null
@@ -1,345 +0,0 @@
-
-
--- | Dynamically lookup up values from modules and loading them.
-module GHC.Runtime.Loader (
-        initializePlugins,
-        -- * Loading plugins
-        loadFrontendPlugin,
-
-        -- * Force loading information
-        forceLoadModuleInterfaces,
-        forceLoadNameModuleInterface,
-        forceLoadTyCon,
-
-        -- * Finding names
-        lookupRdrNameInModuleForPlugins,
-
-        -- * Loading values
-        getValueSafely,
-        getHValueSafely,
-        lessUnsafeCoerce
-    ) where
-
-import GHC.Prelude
-import GHC.Data.FastString
-
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Driver.Hooks
-import GHC.Driver.Plugins
-import GHC.Driver.Plugins.External
-
-import GHC.Linker.Loader       ( loadModule, loadName )
-import GHC.Runtime.Interpreter ( wormhole )
-import GHC.Runtime.Interpreter.Types
-
-import GHC.Tc.Utils.Monad      ( initTcInteractive, initIfaceTcRn )
-import GHC.Iface.Load          ( loadPluginInterface, cannotFindModule )
-import GHC.Rename.Names ( gresFromAvails )
-import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName )
-
-import GHC.Driver.Env
-import GHCi.RemoteTypes     ( HValue )
-import GHC.Core.Type        ( Type, mkTyConTy )
-import GHC.Core.TyCo.Compare( eqType )
-import GHC.Core.TyCon       ( TyCon )
-
-import GHC.Types.SrcLoc        ( noSrcSpan )
-import GHC.Types.Name    ( Name, nameModule_maybe )
-import GHC.Types.Id      ( idType )
-import GHC.Types.TyThing
-import GHC.Types.Name.Occurrence ( OccName, mkVarOccFS )
-import GHC.Types.Name.Reader   ( RdrName, ImportSpec(..), ImpDeclSpec(..)
-                               , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName
-                               , greMangledName, mkRdrQual )
-
-import GHC.Unit.Finder         ( findPluginModule, FindResult(..) )
-import GHC.Driver.Config.Finder ( initFinderOpts )
-import GHC.Unit.Module   ( Module, ModuleName )
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Env
-
-import GHC.Utils.Panic
-import GHC.Utils.Logger
-import GHC.Utils.Error
-import GHC.Utils.Outputable
-import GHC.Utils.Exception
-
-import Control.Monad     ( unless )
-import Data.Maybe        ( mapMaybe )
-import Unsafe.Coerce     ( unsafeCoerce )
-import GHC.Linker.Types
-import GHC.Types.Unique.DFM
-import Data.List (unzip4)
-
--- | Loads the plugins specified in the pluginModNames field of the dynamic
--- flags. Should be called after command line arguments are parsed, but before
--- actual compilation starts. Idempotent operation. Should be re-called if
--- pluginModNames or pluginModNameOpts changes.
-initializePlugins :: HscEnv -> IO HscEnv
-initializePlugins hsc_env
-    -- check that plugin specifications didn't change
-
-    -- dynamic plugins
-  | loaded_plugins <- loadedPlugins (hsc_plugins hsc_env)
-  , map lpModuleName loaded_plugins == reverse (pluginModNames dflags)
-  , all same_args loaded_plugins
-
-    -- external plugins
-  , external_plugins <- externalPlugins (hsc_plugins hsc_env)
-  , check_external_plugins external_plugins (externalPluginSpecs dflags)
-
-    -- FIXME: we should check static plugins too
-
-  = return hsc_env -- no change, no need to reload plugins
-
-  | otherwise
-  = do (loaded_plugins, links, pkgs) <- loadPlugins hsc_env
-       external_plugins <- loadExternalPlugins (externalPluginSpecs dflags)
-       let plugins' = (hsc_plugins hsc_env) { staticPlugins    = staticPlugins (hsc_plugins hsc_env)
-                                            , externalPlugins  = external_plugins
-                                            , loadedPlugins    = loaded_plugins
-                                            , loadedPluginDeps = (links, pkgs)
-                                            }
-       let hsc_env' = hsc_env { hsc_plugins = plugins' }
-       withPlugins (hsc_plugins hsc_env') driverPlugin hsc_env'
-  where
-    dflags = hsc_dflags hsc_env
-    -- dynamic plugins
-    plugin_args = pluginModNameOpts dflags
-    same_args p = paArguments (lpPlugin p) == argumentsForPlugin p plugin_args
-    argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)
-    -- external plugins
-    check_external_plugin p spec = and
-      [ epUnit                p  == esp_unit_id spec
-      , epModule              p  == esp_module spec
-      , paArguments (epPlugin p) == esp_args spec
-      ]
-    check_external_plugins eps specs = case (eps,specs) of
-      ([]  , [])  -> True
-      (_   , [])  -> False -- some external plugin removed
-      ([]  , _ )  -> False -- some external plugin added
-      (p:ps,s:ss) -> check_external_plugin p s && check_external_plugins ps ss
-
-loadPlugins :: HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded)
-loadPlugins hsc_env
-  = do { unless (null to_load) $
-           checkExternalInterpreter hsc_env
-       ; plugins_with_deps <- mapM loadPlugin to_load
-       ; let (plugins, ifaces, links, pkgs) = unzip4 plugins_with_deps
-       ; return (zipWith attachOptions to_load (zip plugins ifaces), concat links, foldl' plusUDFM emptyUDFM pkgs)
-       }
-  where
-    dflags  = hsc_dflags hsc_env
-    to_load = reverse $ pluginModNames dflags
-
-    attachOptions mod_nm (plug, mod) =
-        LoadedPlugin (PluginWithArgs plug (reverse options)) mod
-      where
-        options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
-                            , opt_mod_nm == mod_nm ]
-    loadPlugin = loadPlugin' (mkVarOccFS (fsLit "plugin")) pluginTyConName hsc_env
-
-
-loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded)
-loadFrontendPlugin hsc_env mod_name = do
-    checkExternalInterpreter hsc_env
-    (plugin, _iface, links, pkgs)
-      <- loadPlugin' (mkVarOccFS (fsLit "frontendPlugin")) frontendPluginTyConName
-           hsc_env mod_name
-    return (plugin, links, pkgs)
-
--- #14335
-checkExternalInterpreter :: HscEnv -> IO ()
-checkExternalInterpreter hsc_env = case interpInstance <$> hsc_interp hsc_env of
-  Just (ExternalInterp {})
-    -> throwIO (InstallationError "Plugins require -fno-external-interpreter")
-  _ -> pure ()
-
-loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [Linkable], PkgsLoaded)
-loadPlugin' occ_name plugin_name hsc_env mod_name
-  = do { let plugin_rdr_name = mkRdrQual mod_name occ_name
-             dflags = hsc_dflags hsc_env
-       ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name
-                        plugin_rdr_name
-       ; case mb_name of {
-            Nothing ->
-                throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
-                          [ text "The module", ppr mod_name
-                          , text "did not export the plugin name"
-                          , ppr plugin_rdr_name ]) ;
-            Just (name, mod_iface) ->
-
-     do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name
-        ; eith_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
-        ; case eith_plugin of
-            Left actual_type ->
-                throwGhcExceptionIO (CmdLineError $
-                    showSDocForUser dflags (ue_units (hsc_unit_env hsc_env))
-                      alwaysQualify $ hsep
-                          [ text "The value", ppr name
-                          , text "with type", ppr actual_type
-                          , text "did not have the type"
-                          , text "GHC.Plugins.Plugin"
-                          , text "as required"])
-            Right (plugin, links, pkgs) -> return (plugin, mod_iface, links, pkgs) } } }
-
-
--- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used
--- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
-forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO ()
-forceLoadModuleInterfaces hsc_env doc modules
-    = (initTcInteractive hsc_env $
-       initIfaceTcRn $
-       mapM_ (loadPluginInterface doc) modules)
-      >> return ()
-
--- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used
--- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
-forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO ()
-forceLoadNameModuleInterface hsc_env reason name = do
-    let name_modules = mapMaybe nameModule_maybe [name]
-    forceLoadModuleInterfaces hsc_env reason name_modules
-
--- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if:
---
--- * The interface could not be loaded
--- * The name is not that of a 'TyCon'
--- * The name did not exist in the loaded module
-forceLoadTyCon :: HscEnv -> Name -> IO TyCon
-forceLoadTyCon hsc_env con_name = do
-    forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name
-
-    mb_con_thing <- lookupType hsc_env con_name
-    case mb_con_thing of
-        Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name
-        Just (ATyCon tycon) -> return tycon
-        Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing
-  where dflags = hsc_dflags hsc_env
-
--- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety
--- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at!
---
--- If the value found was not of the correct type, returns @Left <actual_type>@. Any other condition results in an exception:
---
--- * If we could not load the names module
--- * If the thing being loaded is not a value
--- * If the Name does not exist in the module
--- * If the link failed
-
-getValueSafely :: HscEnv -> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded))
-getValueSafely hsc_env val_name expected_type = do
-  eith_hval <- case getValueSafelyHook hooks of
-    Nothing -> getHValueSafely interp hsc_env val_name expected_type
-    Just h  -> h                      hsc_env val_name expected_type
-  case eith_hval of
-    Left actual_type -> return (Left actual_type)
-    Right (hval, links, pkgs) -> do
-      value <- lessUnsafeCoerce logger "getValueSafely" hval
-      return (Right (value, links, pkgs))
-  where
-    interp = hscInterp hsc_env
-    logger = hsc_logger hsc_env
-    hooks  = hsc_hooks hsc_env
-
-getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Either Type (HValue, [Linkable], PkgsLoaded))
-getHValueSafely interp hsc_env val_name expected_type = do
-    forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name
-    -- Now look up the names for the value and type constructor in the type environment
-    mb_val_thing <- lookupType hsc_env val_name
-    case mb_val_thing of
-        Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name
-        Just (AnId id) -> do
-            -- Check the value type in the interface against the type recovered from the type constructor
-            -- before finally casting the value to the type we assume corresponds to that constructor
-            if expected_type `eqType` idType id
-             then do
-                -- Link in the module that contains the value, if it has such a module
-                case nameModule_maybe val_name of
-                    Just mod -> do loadModule interp hsc_env mod
-                                   return ()
-                    Nothing ->  return ()
-                -- Find the value that we just linked in and cast it given that we have proved it's type
-                hval <- do
-                  (v, links, pkgs) <- loadName interp hsc_env val_name
-                  hv <- wormhole interp v
-                  return (hv, links, pkgs)
-                return (Right hval)
-             else return (Left (idType id))
-        Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
-   where dflags = hsc_dflags hsc_env
-
--- | Coerce a value as usual, but:
---
--- 1) Evaluate it immediately to get a segfault early if the coercion was wrong
---
--- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened
---    if it /does/ segfault
-lessUnsafeCoerce :: Logger -> String -> a -> IO b
-lessUnsafeCoerce logger context what = do
-    debugTraceMsg logger 3 $
-        (text "Coercing a value in") <+> (text context) <> (text "...")
-    output <- evaluate (unsafeCoerce what)
-    debugTraceMsg logger 3 (text "Successfully evaluated coercion")
-    return output
-
-
--- | Finds the 'Name' corresponding to the given 'RdrName' in the
--- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name'
--- could be found. Any other condition results in an exception:
---
--- * If the module could not be found
--- * If we could not determine the imports of the module
---
--- Can only be used for looking up names while loading plugins (and is
--- *not* suitable for use within plugins).  The interface file is
--- loaded very partially: just enough that it can be used, without its
--- rules and instances affecting (and being linked from!) the module
--- being compiled.  This was introduced by 57d6798.
---
--- Need the module as well to record information in the interface file
-lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName
-                                -> IO (Maybe (Name, ModIface))
-lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
-    let dflags     = hsc_dflags hsc_env
-    let fopts      = initFinderOpts dflags
-    let fc         = hsc_FC hsc_env
-    let unit_env   = hsc_unit_env hsc_env
-    let unit_state = ue_units unit_env
-    let mhome_unit = hsc_home_unit_maybe hsc_env
-    -- First find the unit the module resides in by searching exposed units and home modules
-    found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name
-    case found_module of
-        Found _ mod -> do
-            -- Find the exports of the module
-            (_, mb_iface) <- initTcInteractive hsc_env $
-                             initIfaceTcRn $
-                             loadPluginInterface doc mod
-            case mb_iface of
-                Just iface -> do
-                    -- Try and find the required name in the exports
-                    let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name
-                                                , is_qual = False, is_dloc = noSrcSpan }
-                        imp_spec = ImpSpec decl_spec ImpAll
-                        env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface))
-                    case lookupGRE_RdrName rdr_name env of
-                        [gre] -> return (Just (greMangledName gre, iface))
-                        []    -> return Nothing
-                        _     -> panic "lookupRdrNameInModule"
-
-                Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name]
-        err -> throwCmdLineErrorS dflags $ cannotFindModule hsc_env mod_name err
-  where
-    doc = text "contains a name used in an invocation of lookupRdrNameInModule"
-
-wrongTyThingError :: Name -> TyThing -> SDoc
-wrongTyThingError name got_thing = hsep [text "The name", ppr name, text "is not that of a value but rather a", pprTyThingCategory got_thing]
-
-missingTyThingError :: Name -> SDoc
-missingTyThingError name = hsep [text "The name", ppr name, text "is not in the type environment: are you sure it exists?"]
-
-throwCmdLineErrorS :: DynFlags -> SDoc -> IO a
-throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags
-
-throwCmdLineError :: String -> IO a
-throwCmdLineError = throwGhcExceptionIO . CmdLineError
diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs
deleted file mode 100644
--- a/compiler/GHC/Settings/IO.hs
+++ /dev/null
@@ -1,254 +0,0 @@
-
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module GHC.Settings.IO
- ( SettingsError (..)
- , initSettings
- ) where
-
-import GHC.Prelude
-
-import GHC.Settings.Utils
-
-import GHC.Settings.Config
-import GHC.Utils.CliOption
-import GHC.Utils.Fingerprint
-import GHC.Platform
-import GHC.Utils.Panic
-import GHC.Settings
-import GHC.SysTools.BaseDir
-
-import Control.Monad.Trans.Except
-import Control.Monad.IO.Class
-import qualified Data.Map as Map
-import System.FilePath
-import System.Directory
-
-data SettingsError
-  = SettingsError_MissingData String
-  | SettingsError_BadData String
-
-initSettings
-  :: forall m
-  .  MonadIO m
-  => String -- ^ TopDir path
-  -> ExceptT SettingsError m Settings
-initSettings top_dir = do
-  let installed :: FilePath -> FilePath
-      installed file = top_dir </> file
-      libexec :: FilePath -> FilePath
-      libexec file = top_dir </> "bin" </> file
-      settingsFile = installed "settings"
-
-      readFileSafe :: FilePath -> ExceptT SettingsError m String
-      readFileSafe path = liftIO (doesFileExist path) >>= \case
-        True -> liftIO $ readFile path
-        False -> throwE $ SettingsError_MissingData $ "Missing file: " ++ path
-
-  settingsStr <- readFileSafe settingsFile
-  settingsList <- case maybeReadFuzzy settingsStr of
-    Just s -> pure s
-    Nothing -> throwE $ SettingsError_BadData $
-      "Can't parse " ++ show settingsFile
-  let mySettings = Map.fromList settingsList
-      getBooleanSetting :: String -> ExceptT SettingsError m Bool
-      getBooleanSetting key = either pgmError pure $
-        getRawBooleanSetting settingsFile mySettings key
-
-  -- On Windows, by mingw is often distributed with GHC,
-  -- so we look in TopDir/../mingw/bin,
-  -- as well as TopDir/../../mingw/bin for hadrian.
-  -- But we might be disabled, in which we we don't do that.
-  useInplaceMinGW <- getBooleanSetting "Use inplace MinGW toolchain"
-
-  -- see Note [topdir: How GHC finds its files]
-  -- NB: top_dir is assumed to be in standard Unix
-  -- format, '/' separated
-  mtool_dir <- liftIO $ findToolDir useInplaceMinGW top_dir
-        -- see Note [tooldir: How GHC finds mingw on Windows]
-
-  -- See Note [Settings file] for a little more about this file. We're
-  -- just partially applying those functions and throwing 'Left's; they're
-  -- written in a very portable style to keep ghc-boot light.
-  let getSetting key = either pgmError pure $
-        getRawFilePathSetting top_dir settingsFile mySettings key
-      getToolSetting :: String -> ExceptT SettingsError m String
-      getToolSetting key = expandToolDir useInplaceMinGW mtool_dir <$> getSetting key
-  targetPlatformString <- getSetting "target platform string"
-  myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
-  cc_prog <- getToolSetting "C compiler command"
-  cxx_prog <- getToolSetting "C++ compiler command"
-  cc_args_str <- getSetting "C compiler flags"
-  cxx_args_str <- getSetting "C++ compiler flags"
-  gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"
-  cpp_prog <- getToolSetting "Haskell CPP command"
-  cpp_args_str <- getSetting "Haskell CPP flags"
-
-  platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings
-
-  let unreg_cc_args = if platformUnregisterised platform
-                      then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
-                      else []
-      cpp_args = map Option (words cpp_args_str)
-      cc_args  = words cc_args_str ++ unreg_cc_args
-      cxx_args = words cxx_args_str
-  ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
-  ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"
-  ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"
-  arSupportsDashL         <- getBooleanSetting "ar supports -L"
-
-  let globalpkgdb_path = installed "package.conf.d"
-      ghc_usage_msg_path  = installed "ghc-usage.txt"
-      ghci_usage_msg_path = installed "ghci-usage.txt"
-
-  -- For all systems, unlit, split, mangle are GHC utilities
-  -- architecture-specific stuff is done when building Config.hs
-  unlit_path <- getToolSetting "unlit command"
-
-  windres_path <- getToolSetting "windres command"
-  ar_path <- getToolSetting "ar command"
-  otool_path <- getToolSetting "otool command"
-  install_name_tool_path <- getToolSetting "install_name_tool command"
-  ranlib_path <- getToolSetting "ranlib command"
-
-  touch_path <- getToolSetting "touch command"
-
-  mkdll_prog <- getToolSetting "dllwrap command"
-  let mkdll_args = []
-
-  -- cpp is derived from gcc on all platforms
-  -- HACK, see setPgmP below. We keep 'words' here to remember to fix
-  -- Config.hs one day.
-
-
-  -- Other things being equal, as and ld are simply gcc
-  cc_link_args_str <- getSetting "C compiler link flags"
-  let   as_prog  = cc_prog
-        as_args  = map Option cc_args
-        ld_prog  = cc_prog
-        ld_args  = map Option (cc_args ++ words cc_link_args_str)
-  ld_r_prog <- getToolSetting "Merge objects command"
-  ld_r_args <- getSetting "Merge objects flags"
-  let ld_r
-        | null ld_r_prog = Nothing
-        | otherwise      = Just (ld_r_prog, map Option $ words ld_r_args)
-
-  llvmTarget <- getSetting "LLVM target"
-
-  -- We just assume on command line
-  lc_prog <- getSetting "LLVM llc command"
-  lo_prog <- getSetting "LLVM opt command"
-  lcc_prog <- getSetting "LLVM clang command"
-
-  let iserv_prog = libexec "ghc-iserv"
-
-  ghcWithInterpreter <- getBooleanSetting "Use interpreter"
-  useLibFFI <- getBooleanSetting "Use LibFFI"
-
-  return $ Settings
-    { sGhcNameVersion = GhcNameVersion
-      { ghcNameVersion_programName = "ghc"
-      , ghcNameVersion_projectVersion = cProjectVersion
-      }
-
-    , sFileSettings = FileSettings
-      { fileSettings_ghcUsagePath   = ghc_usage_msg_path
-      , fileSettings_ghciUsagePath  = ghci_usage_msg_path
-      , fileSettings_toolDir        = mtool_dir
-      , fileSettings_topDir         = top_dir
-      , fileSettings_globalPackageDatabase = globalpkgdb_path
-      }
-
-    , sToolSettings = ToolSettings
-      { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind
-      , toolSettings_ldSupportsFilelist      = ldSupportsFilelist
-      , toolSettings_ldIsGnuLd               = ldIsGnuLd
-      , toolSettings_ccSupportsNoPie         = gccSupportsNoPie
-      , toolSettings_useInplaceMinGW         = useInplaceMinGW
-      , toolSettings_arSupportsDashL         = arSupportsDashL
-
-      , toolSettings_pgm_L   = unlit_path
-      , toolSettings_pgm_P   = (cpp_prog, cpp_args)
-      , toolSettings_pgm_F   = ""
-      , toolSettings_pgm_c   = cc_prog
-      , toolSettings_pgm_cxx = cxx_prog
-      , toolSettings_pgm_a   = (as_prog, as_args)
-      , toolSettings_pgm_l   = (ld_prog, ld_args)
-      , toolSettings_pgm_lm  = ld_r
-      , toolSettings_pgm_dll = (mkdll_prog,mkdll_args)
-      , toolSettings_pgm_T   = touch_path
-      , toolSettings_pgm_windres = windres_path
-      , toolSettings_pgm_ar = ar_path
-      , toolSettings_pgm_otool = otool_path
-      , toolSettings_pgm_install_name_tool = install_name_tool_path
-      , toolSettings_pgm_ranlib = ranlib_path
-      , toolSettings_pgm_lo  = (lo_prog,[])
-      , toolSettings_pgm_lc  = (lc_prog,[])
-      , toolSettings_pgm_lcc = (lcc_prog,[])
-      , toolSettings_pgm_i   = iserv_prog
-      , toolSettings_opt_L       = []
-      , toolSettings_opt_P       = []
-      , toolSettings_opt_P_fingerprint = fingerprint0
-      , toolSettings_opt_F       = []
-      , toolSettings_opt_c       = cc_args
-      , toolSettings_opt_cxx     = cxx_args
-      , toolSettings_opt_a       = []
-      , toolSettings_opt_l       = []
-      , toolSettings_opt_lm      = []
-      , toolSettings_opt_windres = []
-      , toolSettings_opt_lcc     = []
-      , toolSettings_opt_lo      = []
-      , toolSettings_opt_lc      = []
-      , toolSettings_opt_i       = []
-
-      , toolSettings_extraGccViaCFlags = words myExtraGccViaCFlags
-      }
-
-    , sTargetPlatform = platform
-    , sPlatformMisc = PlatformMisc
-      { platformMisc_targetPlatformString = targetPlatformString
-      , platformMisc_ghcWithInterpreter = ghcWithInterpreter
-      , platformMisc_libFFI = useLibFFI
-      , platformMisc_llvmTarget = llvmTarget
-      }
-
-    , sRawSettings    = settingsList
-    }
-
-getTargetPlatform
-  :: FilePath     -- ^ Settings filepath (for error messages)
-  -> RawSettings  -- ^ Raw settings file contents
-  -> Either String Platform
-getTargetPlatform settingsFile settings = do
-  let
-    getBooleanSetting = getRawBooleanSetting settingsFile settings
-    readSetting :: (Show a, Read a) => String -> Either String a
-    readSetting = readRawSetting settingsFile settings
-
-  targetArchOS <- getTargetArchOS settingsFile settings
-  targetWordSize <- readSetting "target word size"
-  targetWordBigEndian <- getBooleanSetting "target word big endian"
-  targetLeadingUnderscore <- getBooleanSetting "Leading underscore"
-  targetUnregisterised <- getBooleanSetting "Unregisterised"
-  targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack"
-  targetHasIdentDirective <- getBooleanSetting "target has .ident directive"
-  targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols"
-  targetHasLibm <- getBooleanSetting "target has libm"
-  crossCompiling <- getBooleanSetting "cross compiling"
-  tablesNextToCode <- getBooleanSetting "Tables next to code"
-
-  pure $ Platform
-    { platformArchOS    = targetArchOS
-    , platformWordSize  = targetWordSize
-    , platformByteOrder = if targetWordBigEndian then BigEndian else LittleEndian
-    , platformUnregisterised = targetUnregisterised
-    , platformHasGnuNonexecStack = targetHasGnuNonexecStack
-    , platformHasIdentDirective = targetHasIdentDirective
-    , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols
-    , platformIsCrossCompiling = crossCompiling
-    , platformLeadingUnderscore = targetLeadingUnderscore
-    , platformTablesNextToCode  = tablesNextToCode
-    , platformHasLibm = targetHasLibm
-    , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit
-    }
diff --git a/compiler/GHC/Stg/BcPrep.hs b/compiler/GHC/Stg/BcPrep.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/BcPrep.hs
+++ /dev/null
@@ -1,214 +0,0 @@
-{-|
-  Prepare the STG for bytecode generation:
-
-   - Ensure that all breakpoints are directly under
-        a let-binding, introducing a new binding for
-        those that aren't already.
-
-   - Protect Not-necessarily lifted join points, see
-        Note [Not-necessarily-lifted join points]
-
- -}
-
-module GHC.Stg.BcPrep ( bcPrep ) where
-
-import GHC.Prelude
-
-import GHC.Types.Id.Make
-import GHC.Types.Id
-import GHC.Core.Type
-import GHC.Builtin.Types ( unboxedUnitTy )
-import GHC.Builtin.Types.Prim
-import GHC.Types.Unique
-import GHC.Data.FastString
-import GHC.Utils.Panic.Plain
-import GHC.Types.Tickish
-import GHC.Types.Unique.Supply
-import qualified GHC.Types.CostCentre as CC
-import GHC.Stg.Syntax
-import GHC.Utils.Monad.State.Strict
-
-data BcPrepM_State
-   = BcPrepM_State
-        { prepUniqSupply :: !UniqSupply      -- for generating fresh variable names
-        }
-
-type BcPrepM a = State BcPrepM_State a
-
-bcPrepRHS :: StgRhs -> BcPrepM StgRhs
--- explicitly match all constructors so we get a warning if we miss any
-bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr)) = do
-  {- If we have a breakpoint directly under an StgRhsClosure we don't
-     need to introduce a new binding for it.
-   -}
-  expr' <- bcPrepExpr expr
-  pure (StgRhsClosure fvs cc upd args (StgTick bp expr'))
-bcPrepRHS (StgRhsClosure fvs cc upd args expr) =
-  StgRhsClosure fvs cc upd args <$> bcPrepExpr expr
-bcPrepRHS con@StgRhsCon{} = pure con
-
-bcPrepExpr :: StgExpr -> BcPrepM StgExpr
--- explicitly match all constructors so we get a warning if we miss any
-bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)
-  | isLiftedTypeKind (typeKind tick_ty) = do
-      id <- newId tick_ty
-      rhs' <- bcPrepExpr rhs
-      let expr' = StgTick bp rhs'
-          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent
-                                            CC.dontCareCCS
-                                            ReEntrant
-                                            []
-                                            expr'
-                             )
-          letExp = StgLet noExtFieldSilent bnd (StgApp id [])
-      pure letExp
-  | otherwise = do
-      id <- newId (mkVisFunTyMany realWorldStatePrimTy tick_ty)
-      rhs' <- bcPrepExpr rhs
-      let expr' = StgTick bp rhs'
-          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent
-                                            CC.dontCareCCS
-                                            ReEntrant
-                                            [voidArgId]
-                                            expr'
-                             )
-      pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg realWorldPrimId])
-bcPrepExpr (StgTick tick rhs) =
-  StgTick tick <$> bcPrepExpr rhs
-bcPrepExpr (StgLet xlet bnds expr) =
-  StgLet xlet <$> bcPrepBind bnds
-              <*> bcPrepExpr expr
-bcPrepExpr (StgLetNoEscape xlne bnds expr) =
-  StgLet xlne <$> bcPrepBind bnds
-              <*> bcPrepExpr expr
-bcPrepExpr (StgCase expr bndr alt_type alts) =
-  StgCase <$> bcPrepExpr expr
-          <*> pure bndr
-          <*> pure alt_type
-          <*> mapM bcPrepAlt alts
-bcPrepExpr lit@StgLit{} = pure lit
--- See Note [Not-necessarily-lifted join points], step 3.
-bcPrepExpr (StgApp x [])
-  | isNNLJoinPoint x = pure $
-      StgApp (protectNNLJoinPointId x) [StgVarArg voidPrimId]
-bcPrepExpr app@StgApp{} = pure app
-bcPrepExpr app@StgConApp{} = pure app
-bcPrepExpr app@StgOpApp{} = pure app
-
-bcPrepAlt :: StgAlt -> BcPrepM StgAlt
-bcPrepAlt (GenStgAlt con bndrs rhs) = GenStgAlt con bndrs <$> bcPrepExpr rhs
-
-bcPrepBind :: StgBinding -> BcPrepM StgBinding
--- explicitly match all constructors so we get a warning if we miss any
-bcPrepBind (StgNonRec bndr rhs) =
-  let (bndr', rhs') = bcPrepSingleBind (bndr, rhs)
-  in  StgNonRec bndr' <$> bcPrepRHS rhs'
-bcPrepBind (StgRec bnds) =
-  StgRec <$> mapM ((\(b,r) -> (,) b <$> bcPrepRHS r) . bcPrepSingleBind)
-                  bnds
-
-bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)
--- If necessary, modify this Id and body to protect not-necessarily-lifted join points.
--- See Note [Not-necessarily-lifted join points], step 2.
-bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body)
-  | isNNLJoinPoint x
-  = ( protectNNLJoinPointId x
-    , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body)
-bcPrepSingleBind bnd = bnd
-
-bcPrepTopLvl :: StgTopBinding -> BcPrepM StgTopBinding
-bcPrepTopLvl lit@StgTopStringLit{} = pure lit
-bcPrepTopLvl (StgTopLifted bnd) = StgTopLifted <$> bcPrepBind bnd
-
-bcPrep :: UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]
-bcPrep us bnds = evalState (mapM bcPrepTopLvl bnds) (BcPrepM_State us)
-
--- 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 && mightBeUnliftedType (idType x)
-
--- 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 )
-    updateIdTypeButNotMult (unboxedUnitTy `mkVisFunTyMany`) x
-
-newUnique :: BcPrepM Unique
-newUnique = state $
-  \st -> case takeUniqFromSupply (prepUniqSupply st) of
-            (uniq, us) -> (uniq, st { prepUniqSupply = us })
-
-newId :: Type -> BcPrepM Id
-newId ty = do
-    uniq <- newUnique
-    return $ mkSysLocal prepFS uniq ManyTy ty
-
-prepFS :: FastString
-prepFS = fsLit "bcprep"
-
-{-
-
-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 GHC.Core. Because join points do not compile to true, red-blooded
-variables (with, e.g., registers allocated to them), they are allowed
-to be representation-polymorphic.
-(See invariant #6 in Note [Invariants on join points] in GHC.Core.)
-
-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 representation-polymorphic
-and unlifted join points. Representation-polymorphic variables are generally
-not allowed (though representation -polymorphic join points *are*; see
-Note [Invariants on join points] in GHC.Core, 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 `\ (_ :: (# #)) ->` to its RHS, and modify the
-   type to tack on a `(# #) ->`.
-   Note that functions are never representation-polymorphic, so this
-   transformation changes an NNLJP to a non-representation-polymorphic
-   join point. This is done in bcPrepSingleBind.
-
-3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),
-   being careful to note the new type of the NNLJP. This is done in the AnnVar
-   case of schemeE, with help from protectNNLJoinPointId.
-
-Here is an example. Suppose we have
-
-  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
-      join j :: a
-           j = error @r @a "bloop"
-      in case x of
-           A -> j
-           B -> j
-           C -> error @r @a "blurp"
-
-Our plan is to behave is if the code was
-
-  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).
-      let j :: (Void# -> a)
-          j = \ _ -> error @r @a "bloop"
-      in case x of
-           A -> j void#
-           B -> j void#
-           C -> error @r @a "blurp"
-
-It's a bit hacky, but it works well in practice and is local. I suspect the
-Right Fix is to take advantage of join points as goto-labels.
-
--}
-
diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/CSE.hs
+++ /dev/null
@@ -1,583 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-
-{-|
-Note [CSE for Stg]
-~~~~~~~~~~~~~~~~~~
-
-This module implements a simple common subexpression elimination pass for STG.
-This is useful because there are expressions that we want to common up (because
-they are operationally equivalent), but that we cannot common up in Core, because
-their types differ.
-This was originally reported as #9291.
-
-There are two types of common code occurrences that we aim for, see
-Note [Case 1: CSEing allocated closures] and
-Note [Case 2: CSEing case binders] below.
-
-
-Note [Case 1: CSEing allocated closures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The first kind of CSE opportunity we aim for is generated by this Haskell code:
-
-    bar :: a -> (Either Int a, Either Bool a)
-    bar x = (Right x, Right x)
-
-which produces this Core:
-
-    bar :: forall a. a -> (Either Int a, Either Bool a)
-    bar @a x = (Right @Int @a x, Right @Bool @a x)
-
-where the two components of the tuple are different terms, and cannot be
-commoned up (easily). On the STG level we have
-
-    bar [x] = let c1 = Right [x]
-                  c2 = Right [x]
-              in (c1,c2)
-
-and now it is obvious that we can write
-
-    bar [x] = let c1 = Right [x]
-              in (c1,c1)
-
-instead.
-
-
-Note [Case 2: CSEing case binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The second kind of CSE opportunity we aim for is more interesting, and
-came up in #9291 and #5344: The Haskell code
-
-    foo :: Either Int a -> Either Bool a
-    foo (Right x) = Right x
-    foo _         = Left False
-
-produces this Core
-
-    foo :: forall a. Either Int a -> Either Bool a
-    foo @a e = case e of b { Left n -> …
-                           , Right x -> Right @Bool @a x }
-
-where we cannot CSE `Right @Bool @a x` with the case binder `b` as they have
-different types. But in STG we have
-
-    foo [e] = case e of b { Left [n] -> …
-                          , Right [x] -> Right [x] }
-
-and nothing stops us from transforming that to
-
-    foo [e] = case e of b { Left [n] -> …
-                          , Right [x] -> b}
-
-
-Note [StgCse after unarisation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Consider two unboxed sum terms:
-
-    (# 1 | #) :: (# Int | Int# #)
-    (# 1 | #) :: (# Int | Int  #)
-
-These two terms are not equal as they unarise to different unboxed
-tuples. However if we run StgCse before Unarise, it'll think the two
-terms (# 1 | #) are equal, and replace one of these with a binder to
-the other. That's bad -- #15300.
-
-Solution: do unarise first.
-
--}
-
-module GHC.Stg.CSE (stgCse) where
-
-import GHC.Prelude
-
-import GHC.Core.DataCon
-import GHC.Types.Id
-import GHC.Stg.Syntax
-import GHC.Types.Basic (isWeakLoopBreaker)
-import GHC.Types.Var.Env
-import GHC.Core (AltCon(..))
-import Data.List (mapAccumL)
-import Data.Maybe (fromMaybe)
-import GHC.Core.Map.Expr
-import GHC.Data.TrieMap
-import GHC.Types.Name.Env
-import Control.Monad( (>=>) )
-
---------------
--- The Trie --
---------------
-
--- A lookup trie for data constructor applications, i.e.
--- keys of type `(DataCon, [StgArg])`, following the patterns in GHC.Data.TrieMap.
-
-data StgArgMap a = SAM
-    { sam_var :: DVarEnv a
-    , sam_lit :: LiteralMap a
-    }
-
--- TODO(22292): derive
-instance Functor StgArgMap where
-    fmap f SAM { sam_var = varm, sam_lit = litm } = SAM
-      { sam_var = fmap f varm, sam_lit = fmap f litm }
-
-instance TrieMap StgArgMap where
-    type Key StgArgMap = StgArg
-    emptyTM  = SAM { sam_var = emptyTM
-                   , sam_lit = emptyTM }
-    lookupTM (StgVarArg var) = sam_var >.> lkDFreeVar var
-    lookupTM (StgLitArg lit) = sam_lit >.> lookupTM lit
-    alterTM  (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f }
-    alterTM  (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f }
-    foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)
-    filterTM f (SAM {sam_var = varm, sam_lit = litm}) =
-        SAM { sam_var = filterTM f varm, sam_lit = filterTM f litm }
-
-newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) }
-
--- TODO(22292): derive
-instance Functor ConAppMap where
-    fmap f = CAM . fmap (fmap f) . un_cam
-    {-# INLINE fmap #-}
-
-instance TrieMap ConAppMap where
-    type Key ConAppMap = (DataCon, [StgArg])
-    emptyTM  = CAM emptyTM
-    lookupTM (dataCon, args) = un_cam >.> lkDNamed dataCon >=> lookupTM args
-    alterTM  (dataCon, args) f m =
-        m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }
-    foldTM k = un_cam >.> foldTM (foldTM k)
-    filterTM f = un_cam >.> fmap (filterTM f) >.> CAM
-
------------------
--- The CSE Env --
------------------
-
--- | The CSE environment. See Note [CseEnv Example]
-data CseEnv = CseEnv
-    { ce_conAppMap :: ConAppMap OutId
-        -- ^ The main component of the environment is the trie that maps
-        --   data constructor applications (with their `OutId` arguments)
-        --   to an in-scope name that can be used instead.
-        --   This name is always either a let-bound variable or a case binder.
-    , ce_subst     :: IdEnv OutId
-        -- ^ This substitution is applied to the code as we traverse it.
-        --   Entries have one of two reasons:
-        --
-        --   * The input might have shadowing (see Note [Shadowing]), so we have
-        --     to rename some binders as we traverse the tree.
-        --   * If we remove `let x = Con z` because  `let y = Con z` is in scope,
-        --     we note this here as x ↦ y.
-    , ce_bndrMap     :: IdEnv OutId
-        -- ^ If we come across a case expression case x as b of … with a trivial
-        --   binder, we add b ↦ x to this.
-        --   This map is *only* used when looking something up in the ce_conAppMap.
-        --   See Note [Trivial case scrutinee]
-    , ce_in_scope  :: InScopeSet
-        -- ^ The third component is an in-scope set, to rename away any
-        --   shadowing binders
-    }
-
-{-|
-Note [CseEnv Example]
-~~~~~~~~~~~~~~~~~~~~~
-The following tables shows how the CseEnvironment changes as code is traversed,
-as well as the changes to that code.
-
-  InExpr                         OutExpr
-     conAppMap                   subst          in_scope
-  ───────────────────────────────────────────────────────────
-  -- empty                       {}             {}
-  case … as a of {Con x y ->     case … as a of {Con x y ->
-  -- Con x y ↦ a                 {}             {a,x,y}
-  let b = Con x y                (removed)
-  -- Con x y ↦ a                 b↦a            {a,x,y,b}
-  let c = Bar a                  let c = Bar a
-  -- Con x y ↦ a, Bar a ↦ c      b↦a            {a,x,y,b,c}
-  let c = some expression        let c' = some expression
-  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c',     {a,x,y,b,c,c'}
-  let d = Bar b                  (removed)
-  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c', d↦c {a,x,y,b,c,c',d}
-  (a, b, c d)                    (a, a, c' c)
--}
-
-initEnv :: InScopeSet -> CseEnv
-initEnv in_scope = CseEnv
-    { ce_conAppMap = emptyTM
-    , ce_subst     = emptyVarEnv
-    , ce_bndrMap   = emptyVarEnv
-    , ce_in_scope  = in_scope
-    }
-
--------------------
-normaliseConArgs :: CseEnv -> [OutStgArg] -> [OutStgArg]
--- See Note [Trivial case scrutinee]
-normaliseConArgs env args
-  = map go args
-  where
-    bndr_map = ce_bndrMap env
-    go (StgVarArg v  ) = StgVarArg (normaliseId bndr_map v)
-    go (StgLitArg lit) = StgLitArg lit
-
-normaliseId :: IdEnv OutId -> OutId -> OutId
-normaliseId bndr_map v = case lookupVarEnv bndr_map v of
-                           Just v' -> v'
-                           Nothing -> v
-
-addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv
--- See Note [Trivial case scrutinee]
-addTrivCaseBndr from to env
-    = env { ce_bndrMap = extendVarEnv bndr_map from norm_to }
-    where
-      bndr_map = ce_bndrMap env
-      norm_to = normaliseId bndr_map to
-
-envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId
-envLookup dataCon args env
-  = lookupTM (dataCon, normaliseConArgs env args)
-             (ce_conAppMap env)
-    -- normaliseConArgs: See Note [Trivial case scrutinee]
-
-addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv
--- Do not bother with nullary data constructors; they are static anyway
-addDataCon _ _ [] env = env
-addDataCon bndr dataCon args env
-  = env { ce_conAppMap = new_env }
-  where
-    new_env = insertTM (dataCon, normaliseConArgs env args)
-                       bndr (ce_conAppMap env)
-    -- normaliseConArgs: See Note [Trivial case scrutinee]
-
--------------------
-forgetCse :: CseEnv -> CseEnv
-forgetCse env = env { ce_conAppMap = emptyTM }
-    -- See Note [Free variables of an StgClosure]
-
-addSubst :: OutId -> OutId -> CseEnv -> CseEnv
-addSubst from to env
-    = env { ce_subst = extendVarEnv (ce_subst env) from to }
-
-substArgs :: CseEnv -> [InStgArg] -> [OutStgArg]
-substArgs env = map (substArg env)
-
-substArg :: CseEnv -> InStgArg -> OutStgArg
-substArg env (StgVarArg from) = StgVarArg (substVar env from)
-substArg _   (StgLitArg lit)  = StgLitArg lit
-
-substVar :: CseEnv -> InId -> OutId
-substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id
-
--- Functions to enter binders
-
--- This is much simpler than the equivalent code in GHC.Core.Subst:
---  * We do not substitute type variables, and
---  * There is nothing relevant in GHC.Types.Id.Info at this stage
---    that needs substitutions.
--- Therefore, no special treatment for a recursive group is required.
-
-substBndr :: CseEnv -> InId -> (CseEnv, OutId)
-substBndr env old_id
-  = (new_env, new_id)
-  where
-    new_id = uniqAway (ce_in_scope env) old_id
-    no_change = new_id == old_id
-    env' = env { ce_in_scope = ce_in_scope env `extendInScopeSet` new_id }
-    new_env | no_change = env'
-            | otherwise = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id }
-
-substBndrs :: CseEnv -> [InVar] -> (CseEnv, [OutVar])
-substBndrs env bndrs = mapAccumL substBndr env bndrs
-
-substPairs :: CseEnv -> [(InVar, a)] -> (CseEnv, [(OutVar, a)])
-substPairs env bndrs = mapAccumL go env bndrs
-  where go env (id, x) = let (env', id') = substBndr env id
-                         in (env', (id', x))
-
--- Main entry point
-
-stgCse :: [InStgTopBinding] -> [OutStgTopBinding]
-stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds
-
--- Top level bindings.
---
--- We do not CSE these, as top-level closures are allocated statically anyways.
--- Also, they might be exported.
--- But we still have to collect the set of in-scope variables, otherwise
--- uniqAway might shadow a top-level closure.
-
-stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, OutStgTopBinding)
-stgCseTopLvl in_scope t@(StgTopStringLit _ _) = (in_scope, t)
-stgCseTopLvl in_scope (StgTopLifted (StgNonRec bndr rhs))
-    = (in_scope'
-      , StgTopLifted (StgNonRec bndr (stgCseTopLvlRhs in_scope rhs)))
-  where in_scope' = in_scope `extendInScopeSet` bndr
-
-stgCseTopLvl in_scope (StgTopLifted (StgRec eqs))
-    = ( in_scope'
-      , StgTopLifted (StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ]))
-  where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ]
-
-stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs
-stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body)
-    = let body' = stgCseExpr (initEnv in_scope) body
-      in  StgRhsClosure ext ccs upd args body'
-stgCseTopLvlRhs _ (StgRhsCon ccs dataCon mu ticks args)
-    = StgRhsCon ccs dataCon mu ticks args
-
-------------------------------
--- The actual AST traversal --
-------------------------------
-
--- Trivial cases
-stgCseExpr :: CseEnv -> InStgExpr -> OutStgExpr
-stgCseExpr env (StgApp fun args)
-    = StgApp fun' args'
-  where fun' = substVar env fun
-        args' = substArgs env args
-stgCseExpr _ (StgLit lit)
-    = StgLit lit
-stgCseExpr env (StgOpApp op args tys)
-    = StgOpApp op args' tys
-  where args' = substArgs env args
-stgCseExpr env (StgTick tick body)
-    = let body' = stgCseExpr env body
-      in StgTick tick body'
-stgCseExpr env (StgCase scrut bndr ty alts)
-    = mkStgCase scrut' bndr' ty alts'
-  where
-    scrut' = stgCseExpr env scrut
-    (env1, bndr') = substBndr env bndr
-    env2 | StgApp trivial_scrut [] <- scrut'
-         = addTrivCaseBndr bndr trivial_scrut env1
-                 -- See Note [Trivial case scrutinee]
-         | otherwise
-         = env1
-    alts' = map (stgCseAlt env2 ty bndr') alts
-
-
--- A constructor application.
--- To be removed by a variable use when found in the CSE environment
-stgCseExpr env (StgConApp dataCon n args tys)
-    | Just bndr' <- envLookup dataCon args' env
-    = StgApp bndr' []
-    | otherwise
-    = StgConApp dataCon n args' tys
-  where args' = substArgs env args
-
--- Let bindings
--- The binding might be removed due to CSE (we do not want trivial bindings on
--- the STG level), so use the smart constructor `mkStgLet` to remove the binding
--- if empty.
-stgCseExpr env (StgLet ext binds body)
-    = let (binds', env') = stgCseBind env binds
-          body' = stgCseExpr env' body
-      in mkStgLet (StgLet ext) binds' body'
-stgCseExpr env (StgLetNoEscape ext binds body)
-    = let (binds', env') = stgCseBind env binds
-          body' = stgCseExpr env' body
-      in mkStgLet (StgLetNoEscape ext) binds' body'
-
--- Case alternatives
--- Extend the CSE environment
-stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt
-stgCseAlt env ty case_bndr GenStgAlt{alt_con=DataAlt dataCon, alt_bndrs=args, alt_rhs=rhs}
-    = let (env1, args') = substBndrs env args
-          env2
-            -- To avoid dealing with unboxed sums StgCse runs after unarise and
-            -- should maintain invariants listed in Note [Post-unarisation
-            -- invariants]. One of the invariants is that some binders are not
-            -- used (unboxed tuple case binders) which is what we check with
-            -- `stgCaseBndrInScope` here. If the case binder is not in scope we
-            -- don't add it to the CSE env. See also #15300.
-            | stgCaseBndrInScope ty True -- CSE runs after unarise
-            = addDataCon case_bndr dataCon (map StgVarArg args') env1
-            | otherwise
-            = env1
-            -- see Note [Case 2: CSEing case binders]
-          rhs' = stgCseExpr env2 rhs
-      in GenStgAlt (DataAlt dataCon) args' rhs'
-stgCseAlt env _ _ g@GenStgAlt{alt_con=_, alt_bndrs=args, alt_rhs=rhs}
-    = let (env1, args') = substBndrs env args
-          rhs' = stgCseExpr env1 rhs
-      in g {alt_bndrs=args', alt_rhs=rhs'}
-
--- Bindings
-stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv)
-stgCseBind env (StgNonRec b e)
-    = let (env1, b') = substBndr env b
-      in case stgCseRhs env1 b' e of
-        (Nothing,      env2) -> (Nothing,                env2)
-        (Just (b2,e'), env2) -> (Just (StgNonRec b2 e'), env2)
-stgCseBind env (StgRec pairs)
-    = let (env1, pairs1) = substPairs env pairs
-      in case stgCsePairs env1 pairs1 of
-        ([],     env2) -> (Nothing, env2)
-        (pairs2, env2) -> (Just (StgRec pairs2), env2)
-
-stgCsePairs :: CseEnv -> [(OutId, InStgRhs)] -> ([(OutId, OutStgRhs)], CseEnv)
-stgCsePairs env [] = ([], env)
-stgCsePairs env0 ((b,e):pairs)
-  = let (pairMB, env1) = stgCseRhs env0 b e
-        (pairs', env2) = stgCsePairs env1 pairs
-    in (pairMB `mbCons` pairs', env2)
-  where
-    mbCons = maybe id (:)
-
--- The RHS of a binding.
--- If it is a constructor application, either short-cut it or extend the environment
-stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv)
-stgCseRhs env bndr (StgRhsCon ccs dataCon mu ticks args)
-    | Just other_bndr <- envLookup dataCon args' env
-    , not (isWeakLoopBreaker (idOccInfo bndr)) -- See Note [Care with loop breakers]
-    = let env' = addSubst bndr other_bndr env
-      in (Nothing, env')
-    | otherwise
-    = let env' = addDataCon bndr dataCon args' env
-            -- see Note [Case 1: CSEing allocated closures]
-          pair = (bndr, StgRhsCon ccs dataCon mu ticks args')
-      in (Just pair, env')
-  where args' = substArgs env args
-
-stgCseRhs env bndr (StgRhsClosure ext ccs upd args body)
-    = let (env1, args') = substBndrs env args
-          env2 = forgetCse env1 -- See Note [Free variables of an StgClosure]
-          body' = stgCseExpr env2 body
-      in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env)
-
-
-mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr
-mkStgCase scrut bndr ty alts | all isBndr alts = scrut
-                             | otherwise       = StgCase scrut bndr ty alts
-
-  where
-    -- see Note [All alternatives are the binder]
-    isBndr GenStgAlt{alt_con=_,alt_bndrs=_,alt_rhs=StgApp f []} = f == bndr
-    isBndr _                                                    = False
-
-
-{- Note [Care with loop breakers]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When doing CSE on a letrec we must be careful about loop
-breakers.  Consider
-  rec { y = K z
-      ; z = K z }
-Now if, somehow (and wrongly)), y and z are both marked as
-loop-breakers, we do *not* want to drop the (z = K z) binding
-in favour of a substitution (z :-> y).
-
-I think this bug will only show up if the loop-breaker-ness is done
-wrongly (itself a bug), but it still seems better to do the right
-thing regardless.
--}
-
--- Utilities
-
--- | This function short-cuts let-bindings that are now obsolete
-mkStgLet :: (a -> b -> b) -> Maybe a -> b -> b
-mkStgLet _      Nothing      body = body
-mkStgLet stgLet (Just binds) body = stgLet binds body
-
-
-{-
-Note [All alternatives are the binder]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-When all alternatives simply refer to the case binder, then we do not have
-to bother with the case expression at all (#13588). CoreSTG does this as well,
-but sometimes, types get into the way:
-
-    newtype T = MkT Int
-    f :: (Int, Int) -> (T, Int)
-    f (x, y) = (MkT x, y)
-
-Core cannot just turn this into
-
-    f p = p
-
-as this would not be well-typed. But to STG, where MkT is no longer in the way,
-we can.
-
-Note [Trivial case scrutinee]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We want to be able to CSE nested reconstruction of constructors as in
-
-    nested :: Either Int (Either Int a) -> Either Bool (Either Bool a)
-    nested (Right (Right v)) = Right (Right v)
-    nested _                 = Left True
-
-We want the RHS of the first branch to be just the original argument.
-The RHS of 'nested' will look like
-    case x of r1
-      Right a -> case a of r2
-              Right b -> let v = Right b
-                         in Right v
-Then:
-* We create the ce_conAppMap [Right a :-> r1, Right b :-> r2].
-* When we encounter v = Right b, we'll drop the binding and extend
-  the substitution with [v :-> r2]
-* But now when we see (Right v), we'll substitute to get (Right r2)...and
-  fail to find that in the ce_conAppMap!
-
-Solution:
-
-* When passing (case x of bndr { alts }), where 'x' is a variable, we
-  add [bndr :-> x] to the ce_bndrMap.  In our example the ce_bndrMap will
-  be [r1 :-> x, r2 :-> a]. This is done in addTrivCaseBndr.
-
-* Before doing the /lookup/ in ce_conAppMap, we "normalise" the
-  arguments with the ce_bndrMap.  In our example, we normalise
-  (Right r2) to (Right a), and then find it in the map.  Normalisation
-  is done by normaliseConArgs.
-
-* Similarly before /inserting/ in ce_conAppMap, we normalise the arguments.
-  This is a bit more subtle. Suppose we have
-       case x of y
-         DEFAULT -> let a = Just y
-                    let b = Just y
-                    in ...
-  We'll have [y :-> x] in the ce_bndrMap.  When looking up (Just y) in
-  the map, we'll normalise it to (Just x).  So we'd better normalise
-  the (Just y) in the defn of 'a', before inserting it!
-
-* When inserting into cs_bndrMap, we must normalise that too!
-      case x of y
-        DEFAULT -> case y of z
-                      DEFAULT -> ...
-  We want the cs_bndrMap to be [y :-> x, z :-> x]!
-  Hence the call to normaliseId in addTrivCaseBinder.
-
-All this is a bit tricky.  Why does it not occur for the Core version
-of CSE?  See Note [CSE for bindings] in GHC.Core.Opt.CSE.  The reason
-is this: in Core CSE we augment the /main substitution/ with [y :-> x]
-etc, so as a side consequence we transform
-    case x of y       ===>    case x of y
-      pat -> ...y...             pat -> ...x...
-That is, the /exact reverse/ of the binder-swap transformation done by
-the occurrence analyser.  However, it's easy for CSE to do on-the-fly,
-and it completely solves the above tricky problem, using only two maps:
-the main reverse-map, and the substitution.  The occurrence analyser
-puts it back the way it should be, the next time it runs.
-
-However in STG there is no occurrence analyser, and we don't want to
-require another pass.  So the ce_bndrMap is a little swizzle that we
-apply just when manipulating the ce_conAppMap, but that does not
-affect the output program.
-
-
-Note [Free variables of an StgClosure]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-StgClosures (function and thunks) have an explicit list of free variables:
-
-foo [x] =
-    let not_a_free_var = Left [x]
-    let a_free_var = Right [x]
-    let closure = \[x a_free_var] -> \[y] -> bar y (Left [x]) a_free_var
-    in closure
-
-If we were to CSE `Left [x]` in the body of `closure` with `not_a_free_var`,
-then the list of free variables would be wrong, so for now, we do not CSE
-across such a closure, simply because I (Joachim) was not sure about possible
-knock-on effects. If deemed safe and worth the slight code complication of
-re-calculating this list during or after this pass, this can surely be done.
--}
diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/Debug.hs
+++ /dev/null
@@ -1,261 +0,0 @@
-{-# LANGUAGE TupleSections #-}
-
--- This module contains functions which implement
--- the -finfo-table-map and -fdistinct-constructor-tables flags
-module GHC.Stg.Debug
-  ( StgDebugOpts(..)
-  , collectDebugInformation
-  ) where
-
-import GHC.Prelude
-
-import GHC.Stg.Syntax
-
-import GHC.Types.Id
-import GHC.Types.Tickish
-import GHC.Core.DataCon
-import GHC.Types.IPE
-import GHC.Unit.Module
-import GHC.Types.Name   ( getName, getOccName, occNameString, nameSrcSpan)
-import GHC.Data.FastString
-
-import Control.Monad (when)
-import Control.Monad.Trans.Reader
-import GHC.Utils.Monad.State.Strict
-import Control.Monad.Trans.Class
-import GHC.Types.Unique.Map
-import GHC.Types.SrcLoc
-import Control.Applicative
-import qualified Data.List.NonEmpty as NE
-import Data.List.NonEmpty (NonEmpty(..))
-
-data SpanWithLabel = SpanWithLabel RealSrcSpan String
-
-data StgDebugOpts = StgDebugOpts
-  { stgDebug_infoTableMap              :: !Bool
-  , stgDebug_distinctConstructorTables :: !Bool
-  }
-
-data R = R { rOpts :: StgDebugOpts, rModLocation :: ModLocation, rSpan :: Maybe SpanWithLabel }
-
-type M a = ReaderT R (State InfoTableProvMap) a
-
-withSpan :: IpeSourceLocation -> M a -> M a
-withSpan (new_s, new_l) act = local maybe_replace act
-  where
-    maybe_replace r@R{ rModLocation = cur_mod, rSpan = Just (SpanWithLabel old_s _old_l) }
-      -- prefer spans from the current module
-      | Just (unpackFS $ srcSpanFile old_s) == ml_hs_file cur_mod
-      , Just (unpackFS $ srcSpanFile new_s) /= ml_hs_file cur_mod
-      = r
-    maybe_replace r
-      = r { rSpan = Just (SpanWithLabel new_s new_l) }
-
-collectDebugInformation :: StgDebugOpts -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap)
-collectDebugInformation opts ml bs =
-    runState (runReaderT (mapM collectTop bs) (R opts ml Nothing)) emptyInfoTableProvMap
-
-collectTop :: StgTopBinding -> M StgTopBinding
-collectTop (StgTopLifted t) = StgTopLifted <$> collectStgBind t
-collectTop tb = return tb
-
-collectStgBind :: StgBinding -> M StgBinding
-collectStgBind  (StgNonRec bndr rhs) = do
-    rhs' <- collectStgRhs bndr rhs
-    return (StgNonRec bndr rhs')
-collectStgBind (StgRec pairs) = do
-    es <- mapM (\(b, e) -> (b,) <$> collectStgRhs b e) pairs
-    return (StgRec es)
-
-collectStgRhs :: Id -> StgRhs -> M StgRhs
-collectStgRhs bndr (StgRhsClosure ext cc us bs e)= do
-  let
-    name = idName bndr
-    -- If the name has a span, use that initially as the source position in-case
-    -- we don't get anything better.
-    with_span = case nameSrcSpan name of
-                  RealSrcSpan pos _ -> withSpan (pos, occNameString (getOccName name))
-                  _ -> id
-  e' <- with_span $ collectExpr e
-  recordInfo bndr e'
-  return $ StgRhsClosure ext cc us bs e'
-collectStgRhs _bndr (StgRhsCon cc dc _mn ticks args) = do
-  n' <- numberDataCon dc ticks
-  return (StgRhsCon cc dc n' ticks args)
-
-
-recordInfo :: Id -> StgExpr -> M ()
-recordInfo bndr new_rhs = do
-  modLoc <- asks rModLocation
-  let
-    thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc
-    -- A span from the ticks surrounding the new_rhs
-    best_span = quickSourcePos thisFile new_rhs
-    -- A back-up span if the bndr had a source position, many do not (think internally generated ids)
-    bndr_span = (\s -> SpanWithLabel s (occNameString (getOccName bndr)))
-                  <$> srcSpanToRealSrcSpan (nameSrcSpan (getName bndr))
-  recordStgIdPosition bndr best_span bndr_span
-
-collectExpr :: StgExpr -> M StgExpr
-collectExpr = go
-  where
-    go (StgApp occ as) = return $ StgApp occ as
-    go (StgLit lit) = return $ StgLit lit
-    go (StgConApp dc _mn as tys) = do
-      n' <- numberDataCon dc []
-      return (StgConApp dc n' as tys)
-    go (StgOpApp op as ty) = return (StgOpApp op as ty)
-    go (StgCase scrut bndr ty alts) =
-      StgCase <$> collectExpr scrut <*> pure bndr <*> pure ty <*> mapM collectAlt alts
-    go (StgLet ext bind body) = do
-        bind' <- collectStgBind bind
-        body' <- go body
-        return (StgLet ext bind' body')
-    go (StgLetNoEscape ext bind body) = do
-        bind' <- collectStgBind bind
-        body' <- go body
-        return (StgLetNoEscape ext bind' body')
-
-    go (StgTick tick e) = do
-       let k = case tick of
-                SourceNote ss fp -> withSpan (ss, fp)
-                _ -> id
-       e' <- k (go e)
-       return (StgTick tick e')
-
-collectAlt :: StgAlt -> M StgAlt
-collectAlt alt = do e' <- collectExpr $ alt_rhs alt
-                    return $! alt { alt_rhs = e' }
-
--- | Try to find the best source position surrounding a 'StgExpr'. The
--- heuristic strips ticks from the current expression until it finds one which
--- is from the module currently being compiled. This is the same method that
--- the DWARF information uses to give locations to info tables.
---
--- It is usually a better alternative than using the 'RealSrcSpan' which is carefully
--- propagated downwards by 'withSpan'. It's "quick" because it works only using immediate context rather
--- than looking at the parent context like 'withSpan'
-quickSourcePos :: FastString -> StgExpr -> Maybe SpanWithLabel
-quickSourcePos cur_mod (StgTick (SourceNote ss m) e)
-  | srcSpanFile ss == cur_mod = Just (SpanWithLabel ss m)
-  | otherwise = quickSourcePos cur_mod e
-quickSourcePos _ _ = Nothing
-
-recordStgIdPosition :: Id -> Maybe SpanWithLabel -> Maybe SpanWithLabel -> M ()
-recordStgIdPosition id best_span ss = do
-  opts <- asks rOpts
-  when (stgDebug_infoTableMap opts) $ do
-    cc <- asks rSpan
-    --Useful for debugging why a certain Id gets given a certain span
-    --pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr best_span $$ ppr ss)
-    let mbspan = (\(SpanWithLabel rss d) -> (rss, d)) <$> (best_span <|> cc <|> ss)
-    lift $ modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) (idType id, mbspan) })
-
-numberDataCon :: DataCon -> [StgTickish] -> M ConstructorNumber
--- Unboxed tuples and sums do not allocate so they
--- have no info tables.
-numberDataCon dc _ | isUnboxedTupleDataCon dc = return NoNumber
-numberDataCon dc _ | isUnboxedSumDataCon dc = return NoNumber
-numberDataCon dc ts = do
-  opts <- asks rOpts
-  if not (stgDebug_distinctConstructorTables opts) then return NoNumber else do
-    env <- lift get
-    mcc <- asks rSpan
-    let !mbest_span = (\(SpanWithLabel rss l) -> (rss, l)) <$> (selectTick ts <|> mcc)
-    let !dcMap' = alterUniqMap (maybe (Just ((0, mbest_span) :| [] ))
-                        (\xs@((k, _):|_) -> Just $! ((k + 1, mbest_span) `NE.cons` xs))) (provDC env) dc
-    lift $ put (env { provDC = dcMap' })
-    let r = lookupUniqMap dcMap' dc
-    return $ case r of
-      Nothing -> NoNumber
-      Just res -> Numbered (fst (NE.head res))
-
-selectTick :: [StgTickish] -> Maybe SpanWithLabel
-selectTick [] = Nothing
-selectTick (SourceNote rss d : ts ) = selectTick ts <|> Just (SpanWithLabel rss d)
-selectTick (_:ts) = selectTick ts
-
-{-
-Note [Mapping Info Tables to Source Positions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-This note describes what the `-finfo-table-map` flag achieves.
-
-When debugging memory issues it is very useful to be able to map a specific closure
-to a position in the source. The prime example is being able to map a THUNK to
-a specific place in the source program, the mapping is usually quite precise because
-a fresh info table is created for each distinct THUNK.
-
-The info table map is also used to generate stacktraces.
-See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]
-for details.
-
-There are three parts to the implementation
-
-1. In GHC.Stg.Debug, the SourceNote information is used in order to give a source location
-   to some specific closures.
-2. In GHC.Driver.GenerateCgIPEStub, the actually used info tables are collected after the
-   Cmm pipeline. This is important as it's hard to predict beforehand what code generation
-   will do and which ids will end up in the generated program. Additionally, info tables of
-   return frames (used to create stacktraces) are generated in the Cmm pipeline and aren't
-   available before.
-3. During code generation, a mapping from the info table to the statically determined location
-   is emitted which can then be queried at runtime by various tools.
-
--- Giving Source Locations to Closures
-
-At the moment thunk and constructor closures are added to the map. This information
-is collected in the `InfoTableProvMap` which provides a mapping from:
-
-1. Data constructors to a list of where they are used.
-2. `Name`s and where they originate from.
-3. Stack represented info tables (return frames) to an approximated source location
-   of the call that pushed a contiunation on the stacks.
-
-During the CoreToStg phase, this map is populated whenever something is turned into
-a StgRhsClosure or an StgConApp. The current source position is recorded
-depending on the location indicated by the surrounding SourceNote.
-
-The functions which add information to the map are `recordStgIdPosition` and
-`numberDataCon`.
-
-When the `-fdistinct-constructor-tables` flag is turned on then every
-usage of a data constructor gets its own distinct info table. This is orchestrated
-in `collectExpr` where an incrementing number is used to distinguish each
-occurrence of a data constructor.
-
--- GenerateCgIPEStub
-
-The info tables which are actually used in the generated program are collected after
-the Cmm pipeline. `initInfoTableProv` is used to create a CStub, that initializes the
-map in C code.
-
-This step has to be done after the Cmm pipeline to make sure that all info tables are
-really used and, even more importantly, return frame info tables are generated by the
-pipeline.
-
--- Code Generation
-
-The output of these two phases is combined together during code generation.
-A C stub is generated which creates the static map from info table pointer to the
-information about where that info table was created from. This is created by
-`ipInitCode` in the same manner as a C stub is generated for cost centres.
-
-This information can be consumed in two ways.
-
-1. The complete mapping is emitted into the eventlog so that external tools such
-as eventlog2html can use the information with the heap profile by info table mode.
-2. The `lookupIPE` function can be used via the `whereFrom#` primop to introspect
-information about a closure in a running Haskell program.
-
-Note [Distinct Info Tables for Constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-In the old times, each usage of a data constructor used the same info table.
-This made it impossible to distinguish which actual usage of a data constructor was
-contributing primarily to the allocation in a program. Using the `-fdistinct-info-tables` flag you
-can cause code generation to generate a distinct info table for each usage of
-a constructor. Then, when inspecting the heap you can see precisely which usage of a constructor
-was responsible for each allocation.
-
--}
diff --git a/compiler/GHC/Stg/FVs.hs b/compiler/GHC/Stg/FVs.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/FVs.hs
+++ /dev/null
@@ -1,277 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-
-{- |
-Non-global free variable analysis on STG terms. This pass annotates
-non-top-level closure bindings with captured variables. Global variables are not
-captured. For example, in a top-level binding like (pseudo-STG)
-
-    f = \[x,y] .
-      let g = \[p] . reverse (x ++ p)
-      in g y
-
-In g, `reverse` and `(++)` are global variables so they're not considered free.
-`p` is an argument, so `x` is the only actual free variable here. The annotated
-version is thus:
-
-    f = \[x,y] .
-      let g = [x] \[p] . reverse (x ++ p)
-      in g y
-
-Note that non-top-level recursive bindings are also considered free within the
-group:
-
-    map = {} \r [f xs0]
-      let {
-        Rec {
-          go = {f, go} \r [xs1]
-            case xs1 of {
-              [] -> [] [];
-              : x xs2 ->
-                  let { xs' = {go, xs2} \u [] go xs2; } in
-                  let { x' = {f, x} \u [] f x; } in
-                  : [x' xs'];
-            };
-        end Rec }
-      } in go xs0;
-
-Here go is free in its RHS.
-
-Top-level closure bindings never capture variables as all of their free
-variables are global.
--}
-module GHC.Stg.FVs (
-    depSortWithAnnotStgPgm,
-    annBindingFreeVars
-  ) where
-
-import GHC.Prelude hiding (mod)
-
-import GHC.Stg.Syntax
-import GHC.Stg.Utils (bindersOf)
-import GHC.Types.Id
-import GHC.Types.Name (Name, nameIsLocalOrFrom)
-import GHC.Types.Tickish ( GenTickish(Breakpoint) )
-import GHC.Types.Unique.Set (nonDetEltsUniqSet)
-import GHC.Types.Var.Set
-import GHC.Unit.Module (Module)
-import GHC.Utils.Misc
-
-import Data.Graph (SCC (..))
-import GHC.Data.Graph.Directed( Node(..), stronglyConnCompFromEdgedVerticesUniq )
-
-{- Note [Why do we need dependency analysis?]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The program needs to be in dependency order for the SRT algorithm to
-work (see CmmBuildInfoTables, which also includes a detailed
-description of the algorithm).
-
-But isn't it in correct dependency order already?  No:
-
-* The simplifier does not guarantee to produce programs in dependency
-  order (see #16192 and Note [Glomming] in GHC.Core.Opt.OccurAnal).
-  This could be solved by a final run of the occurrence analyser, but
-  that's more work
-
-* We also don't guarantee that StgLiftLams will preserve the order or
-  only create minimal recursive groups.
--}
-
---------------------------------------------------------------------------------
--- | Dependency sort a STG program, and annotate it with free variables
--- The returned bindings:
---   * Are in dependency order
---   * Each StgRhsClosure is correctly annotated (in its extension field)
---     with the free variables needed in the closure
---   * Each StgCase is correctly annotated (in its extension field) with
---     the variables that must be saved across the case
-depSortWithAnnotStgPgm :: Module -> [StgTopBinding] -> [CgStgTopBinding]
-depSortWithAnnotStgPgm this_mod binds
-  = {-# SCC "STG.depSortWithAnnotStgPgm" #-}
-    lit_binds ++ map from_scc sccs
-  where
-    lit_binds :: [CgStgTopBinding]
-    pairs     :: [(Id, StgRhs)]
-    (lit_binds, pairs) = flattenTopStgBindings binds
-
-    nodes :: [Node Name (Id, CgStgRhs)]
-    nodes = map (annotateTopPair env0) pairs
-    env0 = Env { locals = emptyVarSet, mod = this_mod }
-
-    -- Do strongly connected component analysis.  Why?
-    -- See Note [Why do we need dependency analysis?]
-    sccs :: [SCC (Id,CgStgRhs)]
-    sccs  = stronglyConnCompFromEdgedVerticesUniq nodes
-
-    from_scc (CyclicSCC pairs)       = StgTopLifted (StgRec pairs)
-    from_scc (AcyclicSCC (bndr,rhs)) = StgTopLifted (StgNonRec bndr rhs)
-
-
-flattenTopStgBindings :: [StgTopBinding] -> ([CgStgTopBinding], [(Id,StgRhs)])
-flattenTopStgBindings binds
-  = go [] [] binds
-  where
-    go lits pairs [] = (lits, pairs)
-    go lits pairs (bind:binds)
-      = case bind of
-          StgTopStringLit bndr rhs -> go (StgTopStringLit bndr rhs:lits) pairs binds
-          StgTopLifted stg_bind -> go lits (flatten_one stg_bind ++ pairs) binds
-
-    flatten_one (StgNonRec b r) = [(b,r)]
-    flatten_one (StgRec pairs)  = pairs
-
-annotateTopPair :: Env -> (Id, StgRhs) -> Node Name (Id, CgStgRhs)
-annotateTopPair env0 (bndr, rhs)
-  = DigraphNode { node_key          = idName bndr
-                , node_payload      = (bndr, rhs')
-                , node_dependencies = map idName (nonDetEltsUniqSet top_fvs) }
-  where
-    (rhs', top_fvs, _) = rhsFVs env0 rhs
-
---------------------------------------------------------------------------------
--- * Non-global free variable analysis
-
-data Env
-  = Env
-  { -- | Set of locally-bound, not-top-level binders in scope.
-    -- That is, variables bound by a let (but not let-no-escape), a lambda
-    -- (in a StgRhsClsoure), a case binder, or a case alternative.  These
-    -- are the variables that must be captured in a function closure, if they
-    -- are free in the RHS. Example
-    --   f = \x. let g = \y. x+1
-    --           let h = \z. g z + 1
-    --           in h x
-    -- In the body of h we have locals = {x, g, z}.  Note that f is top level
-    -- and does not appear in locals.
-    locals :: IdSet
-  , mod    :: Module
-  }
-
-addLocals :: [Id] -> Env -> Env
-addLocals bndrs env
-  = env { locals = extendVarSetList (locals env) bndrs }
-
---------------------------------------------------------------------------------
--- | TopFVs: set of variables that are:
---    (a) bound at the top level of this module, and
---    (b) appear free in the expression
--- It is a /non-deterministic/ set because we use it only to perform dependency
--- analysis on the top-level bindings.
-type TopFVs   = IdSet
-
--- | LocalFVs: set of variable that are:
---     (a) bound locally (by a lambda, non-top-level let, or case); that is,
---         it appears in the 'locals' field of 'Env'
---     (b) appear free in the expression
--- It is a /deterministic/ set because it is used to annotate closures with
--- their free variables, and we want closure layout to be deterministic.
---
--- Invariant: the LocalFVs returned is a subset of the 'locals' field of Env
-type LocalFVs = DIdSet
-
--- | Dependency analysis on STG terms.
---
--- Dependencies of a binding are just free variables in the binding. This
--- includes imported ids and ids in the current module. For recursive groups we
--- just return one set of free variables which is just the union of dependencies
--- of all bindings in the group.
---
--- Implementation: pass bound variables (NestedIds) to recursive calls, get free
--- variables (TopFVs) back. We ignore imported TopFVs as they do not change the
--- ordering but it improves performance (see `nameIsExternalFrom` call in `vars_fvs`).
---
-
-annBindingFreeVars :: Module -> StgBinding -> CgStgBinding
-annBindingFreeVars this_mod = fstOf3 . bindingFVs (Env emptyVarSet this_mod) emptyDVarSet
-
-bindingFVs :: Env -> LocalFVs -> StgBinding -> (CgStgBinding, TopFVs, LocalFVs)
-bindingFVs env body_fv b =
-  case b of
-    StgNonRec bndr r -> (StgNonRec bndr r', fvs, lcl_fvs)
-      where
-        (r', fvs, rhs_lcl_fvs) = rhsFVs env r
-        lcl_fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_lcl_fvs
-
-    StgRec pairs -> (StgRec pairs', fvs, lcl_fvss)
-      where
-        bndrs = map fst pairs
-        env' = addLocals bndrs env
-        (rhss, rhs_fvss, rhs_lcl_fvss) = mapAndUnzip3 (rhsFVs env' . snd) pairs
-        fvs = unionVarSets rhs_fvss
-        pairs' = zip bndrs rhss
-        lcl_fvss = delDVarSetList (unionDVarSets (body_fv:rhs_lcl_fvss)) bndrs
-
-varFVs :: Env -> Id -> (TopFVs, LocalFVs) -> (TopFVs, LocalFVs)
-varFVs env v (top_fvs, lcl_fvs)
-  | v `elemVarSet` locals env                -- v is locally bound
-  = (top_fvs, lcl_fvs `extendDVarSet` v)
-  | nameIsLocalOrFrom (mod env) (idName v)   -- v is bound at top level
-  = (top_fvs `extendVarSet` v, lcl_fvs)
-  | otherwise                                -- v is imported
-  = (top_fvs, lcl_fvs)
-
-exprFVs :: Env -> StgExpr -> (CgStgExpr, TopFVs, LocalFVs)
-exprFVs env = go
-  where
-    go (StgApp f as)
-      | (top_fvs, lcl_fvs) <- varFVs env f (argsFVs env as)
-      = (StgApp f as, top_fvs, lcl_fvs)
-
-    go (StgLit lit) = (StgLit lit, emptyVarSet, emptyDVarSet)
-
-    go (StgConApp dc n as tys)
-      | (top_fvs, lcl_fvs) <- argsFVs env as
-      = (StgConApp dc n as tys, top_fvs, lcl_fvs)
-
-    go (StgOpApp op as ty)
-      | (top_fvs, lcl_fvs) <- argsFVs env as
-      = (StgOpApp op as ty, top_fvs, lcl_fvs)
-
-    go (StgCase scrut bndr ty alts)
-      | (scrut',scrut_top_fvs,scrut_lcl_fvs) <- exprFVs env scrut
-      , (alts',alts_top_fvss,alts_lcl_fvss)
-          <- mapAndUnzip3 (altFVs (addLocals [bndr] env)) alts
-      , let top_fvs = scrut_top_fvs `unionVarSet` unionVarSets alts_top_fvss
-            alts_lcl_fvs = unionDVarSets alts_lcl_fvss
-            lcl_fvs = delDVarSet (unionDVarSet scrut_lcl_fvs alts_lcl_fvs) bndr
-      = (StgCase scrut' bndr ty alts', top_fvs,lcl_fvs)
-
-    go (StgLet ext         bind body) = go_bind (StgLet ext) bind body
-    go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body
-
-    go (StgTick tick e)
-      | (e', top_fvs, lcl_fvs) <- exprFVs env e
-      , let lcl_fvs' = unionDVarSet (tickish tick) lcl_fvs
-      = (StgTick tick e', top_fvs, lcl_fvs')
-        where
-          tickish (Breakpoint _ _ ids) = mkDVarSet ids
-          tickish _                    = emptyDVarSet
-
-    go_bind dc bind body = (dc bind' body', top_fvs, lcl_fvs)
-      where
-        env' = addLocals (bindersOf bind) env
-        (body', body_top_fvs, body_lcl_fvs) = exprFVs env' body
-        (bind', bind_top_fvs, lcl_fvs)      = bindingFVs env' body_lcl_fvs bind
-        top_fvs = bind_top_fvs `unionVarSet` body_top_fvs
-
-
-rhsFVs :: Env -> StgRhs -> (CgStgRhs, TopFVs, LocalFVs)
-rhsFVs env (StgRhsClosure _ ccs uf bs body)
-  | (body', top_fvs, lcl_fvs) <- exprFVs (addLocals bs env) body
-  , let lcl_fvs' = delDVarSetList lcl_fvs bs
-  = (StgRhsClosure lcl_fvs' ccs uf bs body', top_fvs, lcl_fvs')
-rhsFVs env (StgRhsCon ccs dc mu ts bs)
-  | (top_fvs, lcl_fvs) <- argsFVs env bs
-  = (StgRhsCon ccs dc mu ts bs, top_fvs, lcl_fvs)
-
-argsFVs :: Env -> [StgArg] -> (TopFVs, LocalFVs)
-argsFVs env = foldl' f (emptyVarSet, emptyDVarSet)
-  where
-    f (fvs,ids) StgLitArg{}   = (fvs, ids)
-    f (fvs,ids) (StgVarArg v) = varFVs env v (fvs, ids)
-
-altFVs :: Env -> StgAlt -> (CgStgAlt, TopFVs, LocalFVs)
-altFVs env GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=e}
-  | (e', top_fvs, lcl_fvs) <- exprFVs (addLocals bndrs env) e
-  , let lcl_fvs' = delDVarSetList lcl_fvs bndrs
-  , let newAlt   = GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=e'}
-  = (newAlt, top_fvs, lcl_fvs')
diff --git a/compiler/GHC/Stg/InferTags.hs b/compiler/GHC/Stg/InferTags.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/InferTags.hs
+++ /dev/null
@@ -1,642 +0,0 @@
-{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE UndecidableInstances #-}
- -- To permit: type instance XLet 'InferTaggedBinders = XLet 'SomePass
-
-{-# OPTIONS_GHC -Wname-shadowing #-}
-module GHC.Stg.InferTags ( inferTags ) where
-
-import GHC.Prelude hiding (id)
-
-import GHC.Core.DataCon
-import GHC.Core.Type
-import GHC.Types.Id
-import GHC.Types.Id.Info (tagSigInfo)
-import GHC.Types.Name
-import GHC.Stg.Syntax
-import GHC.Types.Basic ( CbvMark (..) )
-import GHC.Types.Unique.Supply (mkSplitUniqSupply)
-import GHC.Types.RepType (dataConRuntimeRepStrictness)
-import GHC.Core (AltCon(..))
-import Data.List (mapAccumL)
-import GHC.Utils.Outputable
-import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull )
-
-import GHC.Stg.InferTags.Types
-import GHC.Stg.InferTags.Rewrite (rewriteTopBinds)
-import Data.Maybe
-import GHC.Types.Name.Env (mkNameEnv, NameEnv)
-import GHC.Driver.Session
-import GHC.Utils.Logger
-import qualified GHC.Unit.Types
-
-{- Note [Tag Inference]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The purpose of this pass is to attach to every binder a flag
-to indicate whether or not it is "properly tagged".  A binder
-is properly tagged if it is guaranteed:
- - to point to a heap-allocated *value*
- - and to have the tag of the value encoded in the pointer
-
-For example
-  let x = Just y in ...
-
-Here x will be properly tagged: it will point to the heap-allocated
-values for (Just y), and the tag-bits of the pointer will encode
-the tag for Just so there is no need to re-enter the closure or even
-check for the presence of tag bits. The impacts of this can be very large.
-
-For containers the reduction in runtimes with this optimization was as follows:
-
-intmap-benchmarks:    89.30%
-intset-benchmarks:    90.87%
-map-benchmarks:       88.00%
-sequence-benchmarks:  99.84%
-set-benchmarks:       85.00%
-set-operations-intmap:88.64%
-set-operations-map:   74.23%
-set-operations-set:   76.50%
-lookupge-intmap:      89.57%
-lookupge-map:         70.95%
-
-With nofib being ~0.3% faster as well.
-
-See Note [Tag inference passes] for how we proceed to generate and use this information.
-
-Note [Strict Field Invariant]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As part of tag inference we introduce the Strict Field Invariant.
-Which consists of us saying that:
-
-* Pointers in strict fields must (a) point directly to the value, and
-  (b) must be properly tagged.
-
-For example, given
-  data T = MkT ![Int]
-
-the Strict Field Invariant guarantees that the first field of any `MkT` constructor
-will either point directly to nil, or directly to a cons cell;
-and will be tagged with `001` or `010` respectively.
-It will never point to a thunk, nor will it be tagged `000` (meaning "might be a thunk").
-NB: Note that the proper tag for some objects is indeed `000`. Currently this is the case for PAPs.
-
-This works analogous to how `WorkerLikeId`s work. See also Note [CBV Function Ids].
-
-Why do we care? Because if we have code like:
-
-case strictPair of
-  SP x y ->
-    case x of ...
-
-It allows us to safely omit the code to enter x and the check
-for the presence of a tag that goes along with it.
-However we might still branch on the tag as usual.
-See Note [Tag Inference] for how much impact this can have for
-some code.
-
-This is enforced by the code GHC.Stg.InferTags.Rewrite
-where we:
-
-* Look at all constructor allocations.
-* Check if arguments to their strict fields are known to be properly tagged
-* If not we convert `StrictJust x` into `case x of x' -> StrictJust x'`
-
-This is usually very beneficial but can cause regressions in rare edge cases where
-we fail to proof that x is properly tagged, or where it simply isn't.
-See Note [How untagged pointers can end up in strict fields] for how the second case
-can arise.
-
-For a full example of the worst case consider this code:
-
-foo ... = ...
-  let c = StrictJust x
-  in ...
-
-Here we would rewrite `let c = StrictJust x` into `let c = case x of x' -> StrictJust x'`
-However that is horrible! We end up allocating a thunk for `c` first, which only when
-evaluated will allocate the constructor.
-
-So we do our best to establish that `x` is already tagged (which it almost always is)
-to avoid this cost. In my benchmarks I haven't seen any cases where this causes regressions.
-
-Note that there are similar constraints around Note [CBV Function Ids].
-
-Note [How untagged pointers can end up in strict fields]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  data Set a = Tip | Bin !a (Set a) (Set a)
-
-We make a wrapper for Bin that evaluates its arguments
-  $WBin x a b = case x of xv -> Bin xv a b
-Here `xv` will always be evaluated and properly tagged, just as the
-Strict Field Invariant requires.
-
-But alas the Simplifier can destroy the invariant: see #15696.
-We start with
-  thk = f ()
-  g x = ...(case thk of xv -> Bin xv Tip Tip)...
-
-So far so good; the argument to Bin (which is strict) is evaluated.
-Now we do float-out. And in doing so we do a reverse binder-swap (see
-Note [Binder-swap during float-out] in SetLevels) thus
-
-  g x = ...(case thk of xv -> Bin thk Nil Nil)...
-
-The goal of the reverse binder-swap is to allow more floating -- and
-indeed it does! We float the Bin to top level:
-
-  lvl = Bin thk Tip Tip
-  g x = ...(case thk of xv -> lvl)...
-
-Now you can see that the argument of Bin, namely thk, points to the
-thunk, not to the value as it did before.
-
-In short, although it may be rare, the output of optimisation passes
-cannot guarantee to obey the Strict Field Invariant. For this reason
-we run tag inference. See Note [Tag inference passes].
-
-Note [Tag inference passes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Tag inference proceeds in two passes:
-* The first pass is an analysis to compute which binders are properly tagged.
-  The result is then attached to /binders/.
-  This is implemented by `inferTagsAnal` in GHC.Stg.InferTags
-* The second pass walks over the AST checking if the Strict Field Invariant is upheld.
-  See Note [Strict Field Invariant].
-  If required this pass modifies the program to uphold this invariant.
-  Tag information is also moved from /binders/ to /occurrences/ during this pass.
-  This is done by `GHC.Stg.InferTags.Rewrite (rewriteTopBinds)`.
-* Finally the code generation uses this information to skip the thunk check when branching on
-  values. This is done by `cgExpr`/`cgCase` in the backend.
-
-Last but not least we also export the tag sigs of top level bindings to allow this optimization
- to work across module boundaries.
-
-Note [TagInfo of functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The purpose of tag inference is really to figure out when we don't have to enter
-value closures. There the meaning of the tag is fairly obvious.
-For functions we never make use of the tag info so we have two choices:
-* Treat them as TagDunno
-* Treat them as TagProper (as they *are* tagged with their arity) and be really
-  careful to make sure we still enter them when needed.
-As it makes little difference for runtime performance I've treated functions as TagDunno in a few places where
-it made the code simpler. But besides implementation complexity there isn't any reason
-why we couldn't be more rigorous in dealing with functions.
-
-NB: It turned in #21193 that PAPs get tag zero, so the tag check can't be omitted for functions.
-So option two isn't really an option without reworking this anyway.
-
-Note [Tag inference debugging]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There is a flag -dtag-inference-checks which inserts various
-compile/runtime checks in order to ensure the Strict Field Invariant
-holds. It should cover all places
-where tags matter and disable optimizations which interfere with checking
-the invariant like generation of AP-Thunks.
-
-Note [Polymorphic StgPass for inferTagExpr]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In order to reach a fixpoint we sometimes have to re-analyse an expression
-multiple times. But after the initial run the Ast will be parameterized by
-a different StgPass! To handle this a large part of the analysis is polymorphic
-over the exact StgPass we are using. Which allows us to run the analysis on
-the output of itself.
-
--}
-
-{- *********************************************************************
-*                                                                      *
-                         Tag inference pass
-*                                                                      *
-********************************************************************* -}
-
--- doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
---           -> CollectedCCs
---           -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs
---           -> HpcInfo
---           -> IO (Stream IO CmmGroupSRTs CmmCgInfos)
---          -- Note we produce a 'Stream' of CmmGroups, so that the
---          -- backend can be run incrementally.  Otherwise it generates all
---          -- the C-- up front, which has a significant space cost.
-inferTags :: StgPprOpts -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)
-inferTags ppr_opts logger this_mod stg_binds = do
-
-    -- Annotate binders with tag information.
-    let (!stg_binds_w_tags) = {-# SCC "StgTagFields" #-}
-                                        inferTagsAnal stg_binds
-    putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings ppr_opts stg_binds_w_tags)
-
-    let export_tag_info = collectExportInfo stg_binds_w_tags
-
-    -- Rewrite STG to uphold the strict field invariant
-    us_t <- mkSplitUniqSupply 't'
-    let rewritten_binds = {-# SCC "StgTagRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding]
-
-    return (rewritten_binds,export_tag_info)
-
-{- *********************************************************************
-*                                                                      *
-                         Main inference algorithm
-*                                                                      *
-********************************************************************* -}
-
-type OutputableInferPass p = (Outputable (TagEnv p)
-                              , Outputable (GenStgExpr p)
-                              , Outputable (BinderP p)
-                              , Outputable (GenStgRhs p))
-
--- | This constraint encodes the fact that no matter what pass
--- we use the Let/Closure extension points are the same as these for
--- 'InferTaggedBinders.
-type InferExtEq i = ( XLet i ~ XLet 'InferTaggedBinders
-                    , XLetNoEscape i ~ XLetNoEscape 'InferTaggedBinders
-                    , XRhsClosure i ~ XRhsClosure 'InferTaggedBinders)
-
-inferTagsAnal :: [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders]
-inferTagsAnal binds =
-  -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $
-  snd (mapAccumL inferTagTopBind initEnv binds)
-
------------------------
-inferTagTopBind :: TagEnv 'CodeGen -> GenStgTopBinding 'CodeGen
-                -> (TagEnv 'CodeGen, GenStgTopBinding 'InferTaggedBinders)
-inferTagTopBind env (StgTopStringLit id bs)
-  = (env, StgTopStringLit id bs)
-inferTagTopBind env (StgTopLifted bind)
-  = (env', StgTopLifted bind')
-  where
-    (env', bind') = inferTagBind env bind
-
-
--- Why is this polymorphic over the StgPass? See Note [Polymorphic StgPass for inferTagExpr]
------------------------
-inferTagExpr :: forall p. (OutputableInferPass p, InferExtEq p)
-  => TagEnv p -> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders)
-inferTagExpr env (StgApp fun args)
-  =  --pprTrace "inferTagExpr1"
-      -- (ppr fun <+> ppr args $$ ppr info $$
-      --  text "deadEndInfo:" <> ppr (isDeadEndId fun, idArity fun, length args)
-      -- )
-    (info, StgApp fun args)
-  where
-    !fun_arity = idArity fun
-    info | fun_arity == 0 -- Unknown arity => Thunk or unknown call
-         = TagDunno
-
-         | isDeadEndId fun
-         , fun_arity == length args -- Implies we will simply call the function.
-         = TagTagged -- See Note [Bottom functions are TagTagged]
-
-         | Just (TagSig res_info) <- tagSigInfo (idInfo fun)
-         , fun_arity == length args  -- Saturated
-         = res_info
-
-         | Just (TagSig res_info) <- lookupSig env fun
-         , fun_arity == length args  -- Saturated
-         = res_info
-
-         | otherwise
-         = --pprTrace "inferAppUnknown" (ppr fun) $
-           TagDunno
--- TODO:
--- If we have something like:
---   let x = thunk in
---   f g = case g of g' -> (# x, g' #)
--- then we *do* know that g' will be properly tagged,
--- so we should return TagTagged [TagDunno,TagProper] but currently we infer
--- TagTagged [TagDunno,TagDunno] because of the unknown arity case in inferTagExpr.
--- Seems not to matter much but should be changed eventually.
-
-inferTagExpr env (StgConApp con cn args tys)
-  = (inferConTag env con args, StgConApp con cn args tys)
-
-inferTagExpr _ (StgLit l)
-  = (TagTagged, StgLit l)
-
-inferTagExpr env (StgTick tick body)
-  = (info, StgTick tick body')
-  where
-    (info, body') = inferTagExpr env body
-
-inferTagExpr _ (StgOpApp op args ty)
-  = -- Do any primops guarantee to return a properly tagged value?
-    -- I think not.  Ditto foreign calls.
-    (TagDunno, StgOpApp op args ty)
-
-inferTagExpr env (StgLet ext bind body)
-  = (info, StgLet ext bind' body')
-  where
-    (env', bind') = inferTagBind env bind
-    (info, body') = inferTagExpr env' body
-
-inferTagExpr env (StgLetNoEscape ext bind body)
-  = (info, StgLetNoEscape ext bind' body')
-  where
-    (env', bind') = inferTagBind env bind
-    (info, body') = inferTagExpr env' body
-
-inferTagExpr in_env (StgCase scrut bndr ty alts)
-  -- Unboxed tuples get their info from the expression we scrutinise if any
-  | [GenStgAlt{alt_con=DataAlt con, alt_bndrs=bndrs, alt_rhs=rhs}] <- alts
-  , isUnboxedTupleDataCon con
-  , Just infos <- scrut_infos bndrs
-  , let bndrs' = zipWithEqual "inferTagExpr" mk_bndr bndrs infos
-        mk_bndr :: BinderP p -> TagInfo -> (Id, TagSig)
-        mk_bndr tup_bndr tup_info =
-            --  pprTrace "mk_ubx_bndr_info" ( ppr bndr <+> ppr info ) $
-            (getBinderId in_env tup_bndr, TagSig tup_info)
-        -- no case binder in alt_env here, unboxed tuple binders are dead after unarise
-        alt_env = extendSigEnv in_env bndrs'
-        (info, rhs') = inferTagExpr alt_env rhs
-  =
-    -- pprTrace "inferCase1" (
-    --   text "scrut:" <> ppr scrut $$
-    --   text "bndr:" <> ppr bndr $$
-    --   text "infos" <> ppr infos $$
-    --   text "out_bndrs" <> ppr bndrs') $
-    (info, StgCase scrut' (noSig in_env bndr) ty [GenStgAlt{ alt_con=DataAlt con
-                                                           , alt_bndrs=bndrs'
-                                                           , alt_rhs=rhs'}])
-
-  | null alts -- Empty case, but I might just be paranoid.
-  = -- pprTrace "inferCase2" empty $
-    (TagDunno, StgCase scrut' bndr' ty [])
-  -- More than one alternative OR non-TagTuple single alternative.
-  | otherwise
-  =
-    let
-        case_env = extendSigEnv in_env [bndr']
-
-        (infos, alts')
-          = unzip [ (info, g {alt_bndrs=bndrs', alt_rhs=rhs'})
-                  | g@GenStgAlt{ alt_con = con
-                               , alt_bndrs = bndrs
-                               , alt_rhs   = rhs
-                               } <- alts
-                  , let (alt_env,bndrs') = addAltBndrInfo case_env con bndrs
-                        (info, rhs') = inferTagExpr alt_env rhs
-                  ]
-        alt_info = foldr combineAltInfo TagTagged infos
-    in ( alt_info, StgCase scrut' bndr' ty alts')
-  where
-    -- Single unboxed tuple alternative
-    scrut_infos bndrs = case scrut_info of
-      TagTagged -> Just $ replicate (length bndrs) TagProper
-      TagTuple infos -> Just infos
-      _ -> Nothing
-    (scrut_info, scrut') = inferTagExpr in_env scrut
-    bndr' = (getBinderId in_env bndr, TagSig TagProper)
-
--- Compute binder sigs based on the constructors strict fields.
--- NB: Not used if we have tuple info from the scrutinee.
-addAltBndrInfo :: forall p. TagEnv p -> AltCon -> [BinderP p] -> (TagEnv p, [BinderP 'InferTaggedBinders])
-addAltBndrInfo env (DataAlt con) bndrs
-  | not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)
-  = (out_env, out_bndrs)
-  where
-    marks = dataConRuntimeRepStrictness con :: [StrictnessMark]
-    out_bndrs = zipWith mk_bndr bndrs marks
-    out_env = extendSigEnv env out_bndrs
-
-    mk_bndr :: (BinderP p -> StrictnessMark -> (Id, TagSig))
-    mk_bndr bndr mark
-      | isUnliftedType (idType id) || isMarkedStrict mark
-      = (id, TagSig TagProper)
-      | otherwise
-      = noSig env bndr
-        where
-          id = getBinderId env bndr
-
-addAltBndrInfo env _ bndrs = (env, map (noSig env) bndrs)
-
------------------------------
-inferTagBind :: (OutputableInferPass p, InferExtEq p)
-  => TagEnv p -> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders)
-inferTagBind in_env (StgNonRec bndr rhs)
-  =
-    -- pprTrace "inferBindNonRec" (
-    --   ppr bndr $$
-    --   ppr (isDeadEndId id) $$
-    --   ppr sig)
-    (env', StgNonRec (id, sig) rhs')
-  where
-    id   = getBinderId in_env bndr
-    env' = extendSigEnv in_env [(id, sig)]
-    (sig,rhs') = inferTagRhs id in_env rhs
-
-inferTagBind in_env (StgRec pairs)
-  = -- pprTrace "rec" (ppr (map fst pairs) $$ ppr (in_env { te_env = out_env }, StgRec pairs')) $
-    (in_env { te_env = out_env }, StgRec pairs')
-  where
-    (bndrs, rhss)     = unzip pairs
-    in_ids            = map (getBinderId in_env) bndrs
-    init_sigs         = map (initSig) $ zip in_ids rhss
-    (out_env, pairs') = go in_env init_sigs rhss
-
-    go :: forall q. (OutputableInferPass q , InferExtEq q) => TagEnv q -> [TagSig] -> [GenStgRhs q]
-                 -> (TagSigEnv, [((Id,TagSig), GenStgRhs 'InferTaggedBinders)])
-    go go_env in_sigs go_rhss
-      --   | pprTrace "go" (ppr in_ids $$ ppr in_sigs $$ ppr out_sigs $$ ppr rhss') False
-      --  = undefined
-       | in_sigs == out_sigs = (te_env rhs_env, out_bndrs `zip` rhss')
-       | otherwise     = go env' out_sigs rhss'
-       where
-         out_bndrs = map updateBndr in_bndrs -- TODO: Keeps in_ids alive
-         in_bndrs = in_ids `zip` in_sigs
-         rhs_env = extendSigEnv go_env in_bndrs
-         (out_sigs, rhss') = unzip (zipWithEqual "inferTagBind" anaRhs in_ids go_rhss)
-         env' = makeTagged go_env
-
-         anaRhs :: Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders)
-         anaRhs bnd rhs = inferTagRhs bnd rhs_env rhs
-
-         updateBndr :: (Id,TagSig) -> (Id,TagSig)
-         updateBndr (v,sig) = (setIdTagSig v sig, sig)
-
-initSig :: forall p. (Id, GenStgRhs p) -> TagSig
--- Initial signature for the fixpoint loop
-initSig (_bndr, StgRhsCon {})               = TagSig TagTagged
-initSig (bndr, StgRhsClosure _ _ _ _ _) =
-  fromMaybe defaultSig (idTagSig_maybe bndr)
-  where defaultSig = (TagSig TagTagged)
-
-{- Note [Bottom functions are TagTagged]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we have a function with two branches with one
-being bottom, and the other returning a tagged
-unboxed tuple what is the result? We give it TagTagged!
-To answer why consider this function:
-
-foo :: Bool -> (# Bool, Bool #)
-foo x = case x of
-    True -> (# True,True #)
-    False -> undefined
-
-The true branch is obviously tagged. The other branch isn't.
-We want to treat the *result* of foo as tagged as well so that
-the combination of the branches also is tagged if all non-bottom
-branches are tagged.
-This is safe because the function is still always called/entered as long
-as it's applied to arguments. Since the function will never return we can give
-it safely any tag sig we like.
-So we give it TagTagged, as it allows the combined tag sig of the case expression
-to be the combination of all non-bottoming branches.
-
--}
-
------------------------------
-inferTagRhs :: forall p.
-     (OutputableInferPass p, InferExtEq p)
-  => Id -- ^ Id we are binding to.
-  -> TagEnv p -- ^
-  -> GenStgRhs p -- ^
-  -> (TagSig, GenStgRhs 'InferTaggedBinders)
-inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body)
-  | isDeadEndId bnd_id && (notNull) bndrs
-  -- See Note [Bottom functions are TagTagged]
-  = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body')
-  | otherwise
-  = --pprTrace "inferTagRhsClosure" (ppr (_top, _grp_ids, env,info')) $
-    (TagSig info', StgRhsClosure ext cc upd out_bndrs body')
-  where
-    out_bndrs
-      | Just marks <- idCbvMarks_maybe bnd_id
-      -- Sometimes an we eta-expand foo with additional arguments after ww, and we also trim
-      -- the list of marks to the last strict entry. So we can conservatively
-      -- assume these are not strict
-      = zipWith (mkArgSig) bndrs (marks ++ repeat NotMarkedCbv)
-      | otherwise = map (noSig env') bndrs :: [(Id,TagSig)]
-
-    env' = extendSigEnv in_env out_bndrs
-    (info, body') = inferTagExpr env' body
-    info'
-      -- It's a thunk
-      | null bndrs
-      = TagDunno
-      -- TODO: We could preserve tuple fields for thunks
-      -- as well. But likely not worth the complexity.
-
-      | otherwise  = info
-
-    mkArgSig :: BinderP p -> CbvMark -> (Id,TagSig)
-    mkArgSig bndp mark =
-      let id = getBinderId in_env bndp
-          tag = case mark of
-            MarkedCbv -> TagProper
-            _
-              | isUnliftedType (idType id) -> TagProper
-              | otherwise -> TagDunno
-      in (id, TagSig tag)
-
-inferTagRhs _ env _rhs@(StgRhsCon cc con cn ticks args)
--- Constructors, which have untagged arguments to strict fields
--- become thunks. We encode this by giving changing RhsCon nodes the info TagDunno
-  = --pprTrace "inferTagRhsCon" (ppr grp_ids) $
-    (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args)
-
-{- Note [Constructor TagSigs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-@inferConTag@ will infer the proper tag signature for a binding who's RHS is a constructor
-or a StgConApp expression.
-Usually these will simply be TagProper. But there are exceptions.
-If any of the fields in the constructor are strict, but any argument to these
-fields is not tagged then we will have to case on the argument before storing
-in the constructor. Which means for let bindings the RHS turns into a thunk
-which obviously is no longer properly tagged.
-For example we might start with:
-
-    let x<TagDunno> = f ...
-    let c<TagProper> = StrictPair x True
-
-But we know during the rewrite stage x will need to be evaluated in the RHS
-of `c` so we will infer:
-
-    let x<TagDunno> = f ...
-    let c<TagDunno> = StrictPair x True
-
-Which in the rewrite stage will then be rewritten into:
-
-    let x<TagDunno> = f ...
-    let c<TagDunno> = case x of x' -> StrictPair x' True
-
-The other exception is unboxed tuples. These will get a TagTuple
-signature with a list of TagInfo about their individual binders
-as argument. As example:
-
-    let c<TagProper> = True
-    let x<TagDunno> = ...
-    let f<?> z = case z of z'<TagProper> -> (# c, x #)
-
-Here we will infer for f the Signature <TagTuple[TagProper,TagDunno]>.
-This information will be used if we scrutinize a saturated application of
-`f` in order to determine the taggedness of the result.
-That is for `case f x of (# r1,r2 #) -> rhs` we can infer
-r1<TagProper> and r2<TagDunno> which allows us to skip all tag checks on `r1`
-in `rhs`.
-
-Things get a bit more complicated with nesting:
-
-    let closeFd<TagTuple[...]> = ...
-    let f x = ...
-        case x of
-          _ -> Solo# closeFd
-
-The "natural" signature for the Solo# branch in `f` would be <TagTuple[TagTuple[...]]>.
-But we flatten this out to <TagTuple[TagDunno]> for the time being as it improves compile
-time and there doesn't seem to huge benefit to doing differently.
-
-  -}
-
--- See Note [Constructor TagSigs]
-inferConTag :: TagEnv p -> DataCon -> [StgArg] -> TagInfo
-inferConTag env con args
-  | isUnboxedTupleDataCon con
-  = TagTuple $ map (flatten_arg_tag . lookupInfo env) args
-  | otherwise =
-    -- pprTrace "inferConTag"
-    --   ( text "con:" <> ppr con $$
-    --     text "args:" <> ppr args $$
-    --     text "marks:" <> ppr (dataConRuntimeRepStrictness con) $$
-    --     text "arg_info:" <> ppr (map (lookupInfo env) args) $$
-    --     text "info:" <> ppr info) $
-    info
-  where
-    info = if any arg_needs_eval strictArgs then TagDunno else TagProper
-    strictArgs = zipEqual "inferTagRhs" args (dataConRuntimeRepStrictness con) :: ([(StgArg, StrictnessMark)])
-    arg_needs_eval (arg,strict)
-      -- lazy args
-      | not (isMarkedStrict strict) = False
-      | tag <- (lookupInfo env arg)
-      -- banged args need to be tagged, or require eval
-      = not (isTaggedInfo tag)
-
-    flatten_arg_tag (TagTagged) = TagProper
-    flatten_arg_tag (TagProper ) = TagProper
-    flatten_arg_tag (TagTuple _) = TagDunno -- See Note [Constructor TagSigs]
-    flatten_arg_tag (TagDunno) = TagDunno
-
-
-collectExportInfo :: [GenStgTopBinding 'InferTaggedBinders] -> NameEnv TagSig
-collectExportInfo binds =
-  mkNameEnv bndr_info
-  where
-    bndr_info = concatMap collect binds :: [(Name,TagSig)]
-
-    collect (StgTopStringLit {}) = []
-    collect (StgTopLifted bnd) =
-      case bnd of
-        StgNonRec (id,sig) _rhs
-          | TagSig TagDunno <- sig -> []
-          | otherwise -> [(idName id,sig)]
-        StgRec bnds -> collectRec bnds
-
-    collectRec :: [(BinderP 'InferTaggedBinders, rhs)] -> [(Name,TagSig)]
-    collectRec [] = []
-    collectRec (bnd:bnds)
-      | (p,_rhs)  <- bnd
-      , (id,sig) <- p
-      , TagSig TagDunno <- sig
-      = (idName id,sig) : collectRec bnds
-      | otherwise = collectRec bnds
diff --git a/compiler/GHC/Stg/InferTags/Rewrite.hs b/compiler/GHC/Stg/InferTags/Rewrite.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/InferTags/Rewrite.hs
+++ /dev/null
@@ -1,547 +0,0 @@
---
--- Copyright (c) 2019 Andreas Klebinger
---
-
-{-# LANGUAGE BangPatterns               #-}
-{-# LANGUAGE CPP                        #-}
-{-# LANGUAGE DataKinds                  #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GADTs                      #-}
-{-# LANGUAGE GeneralisedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE RankNTypes                 #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE TupleSections              #-}
-{-# LANGUAGE TypeFamilies               #-}
-
-module GHC.Stg.InferTags.Rewrite (rewriteTopBinds)
-where
-
-import GHC.Prelude
-
-import GHC.Builtin.PrimOps ( PrimOp(..) )
-import GHC.Types.Basic     ( CbvMark (..), isMarkedCbv
-                           , TopLevelFlag(..), isTopLevel
-                           , Levity(..) )
-import GHC.Types.Id
-import GHC.Types.Name
-import GHC.Types.Unique.Supply
-import GHC.Types.Unique.FM
-import GHC.Types.RepType
-import GHC.Types.Var.Set
-import GHC.Unit.Types
-
-import GHC.Core.DataCon
-import GHC.Core            ( AltCon(..) )
-import GHC.Core.Type
-
-import GHC.StgToCmm.Types
-
-import GHC.Stg.Utils
-import GHC.Stg.Syntax as StgSyn
-
-import GHC.Data.Maybe
-import GHC.Utils.Panic
-
-import GHC.Utils.Outputable
-import GHC.Utils.Monad.State.Strict
-import GHC.Utils.Misc
-
-import GHC.Stg.InferTags.Types
-
-import Control.Monad
-
-newtype RM a = RM { unRM :: (State (UniqFM Id TagSig, UniqSupply, Module, IdSet) a) }
-    deriving (Functor, Monad, Applicative)
-
-------------------------------------------------------------
--- Add cases around strict fields where required.
-------------------------------------------------------------
-{-
-The work of this pass is simple:
-* We traverse the STG AST looking for constructor allocations.
-* For all allocations we check if there are strict fields in the constructor.
-* For any strict field we check if the argument is known to be properly tagged.
-* If it's not known to be properly tagged, we wrap the whole thing in a case,
-  which will force the argument before allocation.
-This is described in detail in Note [Strict Field Invariant].
-
-The only slight complication is that we have to make sure not to invalidate free
-variable analysis in the process.
-
-Note [Partially applied workers]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Sometimes we will get a function f of the form
-    -- Arity 1
-    f :: Dict a -> a -> b -> (c -> d)
-    f dict a b = case dict of
-        C m1 m2 -> m1 a b
-
-Which will result in a W/W split along the lines of
-    -- Arity 1
-    f :: Dict a -> a -> b -> (c -> d)
-    f dict a = case dict of
-        C m1 m2 -> $wf m1 a b
-
-    -- Arity 4
-    $wf :: (a -> b -> d -> c) -> a -> b -> c -> d
-    $wf m1 a b c = m1 a b c
-
-It's notable that the worker is called *undersaturated* in the wrapper.
-At runtime what happens is that the wrapper will allocate a PAP which
-once fully applied will call the worker. And all is fine.
-
-But what about a call by value function! Well the function returned by `f` would
-be a unknown call, so we lose the ability to enforce the invariant that
-cbv marked arguments from StictWorkerId's are actually properly tagged
-as the annotations would be unavailable at the (unknown) call site.
-
-The fix is easy. We eta-expand all calls to functions taking call-by-value
-arguments during CorePrep just like we do with constructor allocations.
-
-Note [Upholding free variable annotations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The code generator requires us to maintain exact information
-about free variables about closures. Since we convert some
-RHSs from constructor allocations to closures we have to provide
-fvs of these closures. Not all constructor arguments will become
-free variables. Only these which are not bound at the top level
-have to be captured.
-To facilitate this we keep track of a set of locally bound variables in
-the current context which we then use to filter constructor arguments
-when building the free variable list.
--}
-
---------------------------------
--- Utilities
---------------------------------
-
-instance MonadUnique RM where
-    getUniqueSupplyM = RM $ do
-        (m, us, mod,lcls) <- get
-        let (us1, us2) = splitUniqSupply us
-        (put) (m,us2,mod,lcls)
-        return us1
-
-getMap :: RM (UniqFM Id TagSig)
-getMap = RM $ ((\(fst,_,_,_) -> fst) <$> get)
-
-setMap :: (UniqFM Id TagSig) -> RM ()
-setMap !m = RM $ do
-    (_,us,mod,lcls) <- get
-    put (m, us,mod,lcls)
-
-getMod :: RM Module
-getMod = RM $ ( (\(_,_,thrd,_) -> thrd) <$> get)
-
-getFVs :: RM IdSet
-getFVs = RM $ ((\(_,_,_,lcls) -> lcls) <$> get)
-
-setFVs :: IdSet -> RM ()
-setFVs !fvs = RM $ do
-    (tag_map,us,mod,_lcls) <- get
-    put (tag_map, us,mod,fvs)
-
--- Rewrite the RHS(s) while making the id and it's sig available
--- to determine if things are tagged/need to be captured as FV.
-withBind :: TopLevelFlag -> GenStgBinding 'InferTaggedBinders -> RM a -> RM a
-withBind top_flag (StgNonRec bnd _) cont = withBinder top_flag bnd cont
-withBind top_flag (StgRec binds) cont = do
-    let (bnds,_rhss) = unzip binds :: ([(Id, TagSig)], [GenStgRhs 'InferTaggedBinders])
-    withBinders top_flag bnds cont
-
-addTopBind :: GenStgBinding 'InferTaggedBinders -> RM ()
-addTopBind (StgNonRec (id, tag) _) = do
-    s <- getMap
-    -- pprTraceM "AddBind" (ppr id)
-    setMap $ addToUFM s id tag
-    return ()
-addTopBind (StgRec binds) = do
-    let (bnds,_rhss) = unzip binds
-    !s <- getMap
-    -- pprTraceM "AddBinds" (ppr $ map fst bnds)
-    setMap $! addListToUFM s bnds
-
-withBinder :: TopLevelFlag ->  (Id, TagSig) -> RM a -> RM a
-withBinder top_flag (id,sig) cont = do
-    oldMap <- getMap
-    setMap $ addToUFM oldMap id sig
-    a <- if isTopLevel top_flag
-            then cont
-            else withLcl id cont
-    setMap oldMap
-    return a
-
-withBinders :: TopLevelFlag -> [(Id, TagSig)] -> RM a -> RM a
-withBinders TopLevel sigs cont = do
-    oldMap <- getMap
-    setMap $ addListToUFM oldMap sigs
-    a <- cont
-    setMap oldMap
-    return a
-withBinders NotTopLevel sigs cont = do
-    oldMap <- getMap
-    oldFvs <- getFVs
-    setMap $ addListToUFM oldMap sigs
-    setFVs $ extendVarSetList oldFvs (map fst sigs)
-    a <- cont
-    setMap oldMap
-    setFVs oldFvs
-    return a
-
--- | Compute the argument with the given set of ids treated as requiring capture
--- as free variables.
-withClosureLcls :: DIdSet -> RM a -> RM a
-withClosureLcls fvs act = do
-    old_fvs <- getFVs
-    let !fvs' = nonDetStrictFoldDVarSet (flip extendVarSet) old_fvs fvs
-    setFVs fvs'
-    !r <- act
-    setFVs old_fvs
-    return r
-
--- | Compute the argument with the given id treated as requiring capture
--- as free variables in closures.
-withLcl :: Id -> RM a -> RM a
-withLcl fv act = do
-    old_fvs <- getFVs
-    let !fvs' = extendVarSet old_fvs fv
-    setFVs fvs'
-    !r <- act
-    setFVs old_fvs
-    return r
-
-{- Note [Tag inference for interactive contexts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When compiling bytecode we call myCoreToStg to get STG code first.
-myCoreToStg in turn calls out to stg2stg which runs the STG to STG
-passes followed by free variables analysis and the tag inference pass including
-it's rewriting phase at the end.
-Running tag inference is important as it upholds Note [Strict Field Invariant].
-While code executed by GHCi doesn't take advantage of the SFI it can call into
-compiled code which does. So it must still make sure that the SFI is upheld.
-See also #21083 and #22042.
-
-However there one important difference in code generation for GHCi and regular
-compilation. When compiling an entire module (not a GHCi expression), we call
-`stg2stg` on the entire module which allows us to build up a map which is guaranteed
-to have an entry for every binder in the current module.
-For non-interactive compilation the tag inference rewrite pass takes advantage
-of this by building up a map from binders to their tag signatures.
-
-When compiling a GHCi expression on the other hand we invoke stg2stg separately
-for each expression on the prompt. This means in GHCi for a sequence of:
-    > let x = True
-    > let y = StrictJust x
-We first run stg2stg for `[x = True]`. And then again for [y = StrictJust x]`.
-
-While computing the tag signature for `y` during tag inference inferConTag will check
-if `x` is already tagged by looking up the tagsig of `x` in the binder->signature mapping.
-However since this mapping isn't persistent between stg2stg
-invocations the lookup will fail. This isn't a correctness issue since it's always
-safe to assume a binding isn't tagged and that's what we do in such cases.
-
-However for non-interactive mode we *don't* want to do this. Since in non-interactive mode
-we have all binders of the module available for each invocation we can expect the binder->signature
-mapping to be complete and all lookups to succeed. This means in non-interactive contexts a failed lookup
-indicates a bug in the tag inference implementation.
-For this reason we assert that we are running in interactive mode if a lookup fails.
--}
-isTagged :: Id -> RM Bool
-isTagged v = do
-    this_mod <- getMod
-    -- See Note [Tag inference for interactive contexts]
-    let lookupDefault v = assertPpr (isInteractiveModule this_mod)
-                                    (text "unknown Id:" <> ppr this_mod <+> ppr v)
-                                    (TagSig TagDunno)
-    case nameIsLocalOrFrom this_mod (idName v) of
-        True
-            | Just Unlifted <- typeLevity_maybe (idType v)
-              -- NB: v might be the Id of a representation-polymorphic join point,
-              -- so we shouldn't use isUnliftedType here. See T22212.
-            -> return True
-            | otherwise -> do -- Local binding
-                !s <- getMap
-                let !sig = lookupWithDefaultUFM s (lookupDefault v) v
-                return $ case sig of
-                    TagSig info ->
-                        case info of
-                            TagDunno -> False
-                            TagProper -> True
-                            TagTagged -> True
-                            TagTuple _ -> True -- Consider unboxed tuples tagged.
-        False -- Imported
-            | Just con <- (isDataConWorkId_maybe v)
-            , isNullaryRepDataCon con
-            -> return True
-            | Just lf_info <- idLFInfo_maybe v
-            -> return $!
-                -- Can we treat the thing as tagged based on it's LFInfo?
-                case lf_info of
-                    -- Function, applied not entered.
-                    LFReEntrant {}
-                        -> True
-                    -- Thunks need to be entered.
-                    LFThunk {}
-                        -> False
-                    -- LFCon means we already know the tag, and it's tagged.
-                    LFCon {}
-                        -> True
-                    LFUnknown {}
-                        -> False
-                    LFUnlifted {}
-                        -> True
-                    LFLetNoEscape {}
-                    -- Shouldn't be possible. I don't think we can export letNoEscapes
-                        -> True
-
-            | otherwise
-            -> return False
-
-
-isArgTagged :: StgArg -> RM Bool
-isArgTagged (StgLitArg _) = return True
-isArgTagged (StgVarArg v) = isTagged v
-
-mkLocalArgId :: Id -> RM Id
-mkLocalArgId id = do
-    !u <- getUniqueM
-    return $! setIdUnique (localiseId id) u
-
----------------------------
--- Actual rewrite pass
----------------------------
-
-
-rewriteTopBinds :: Module -> UniqSupply -> [GenStgTopBinding 'InferTaggedBinders] -> [TgStgTopBinding]
-rewriteTopBinds mod us binds =
-    let doBinds = mapM rewriteTop binds
-
-    in evalState (unRM doBinds) (mempty, us, mod, mempty)
-
-rewriteTop :: InferStgTopBinding -> RM TgStgTopBinding
-rewriteTop (StgTopStringLit v s) = return $! (StgTopStringLit v s)
-rewriteTop (StgTopLifted bind)   = do
-    -- Top level bindings can, and must remain in scope
-    addTopBind bind
-    (StgTopLifted) <$!> (rewriteBinds TopLevel bind)
-
--- For top level binds, the wrapper is guaranteed to be `id`
-rewriteBinds :: TopLevelFlag -> InferStgBinding -> RM (TgStgBinding)
-rewriteBinds _top_flag (StgNonRec v rhs) = do
-        (!rhs) <-  rewriteRhs v rhs
-        return $! (StgNonRec (fst v) rhs)
-rewriteBinds top_flag b@(StgRec binds) =
-    -- Bring sigs of binds into scope for all rhss
-    withBind top_flag b $ do
-        (rhss) <- mapM (uncurry rewriteRhs) binds
-        return $! (mkRec rhss)
-        where
-            mkRec :: [TgStgRhs] -> TgStgBinding
-            mkRec rhss = StgRec (zip (map (fst . fst) binds) rhss)
-
--- Rewrite a RHS
-rewriteRhs :: (Id,TagSig) -> InferStgRhs
-           -> RM (TgStgRhs)
-rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args) = {-# SCC rewriteRhs_ #-} do
-    -- pprTraceM "rewriteRhs" (ppr _id)
-
-    -- Look up the nodes representing the constructor arguments.
-    fieldInfos <- mapM isArgTagged args
-
-    -- Filter out non-strict fields.
-    let strictFields =
-            getStrictConArgs con (zip args fieldInfos) :: [(StgArg,Bool)] -- (nth-argument, tagInfo)
-    -- Filter out already tagged arguments.
-    let needsEval = map fst . --get the actual argument
-                        filter (not . snd) $ -- Keep untagged (False) elements.
-                        strictFields :: [StgArg]
-    let evalArgs = [v | StgVarArg v <- needsEval] :: [Id]
-
-    if (null evalArgs)
-        then return $! (StgRhsCon ccs con cn ticks args)
-        else do
-            --assert not (isTaggedSig tagSig)
-            -- pprTraceM "CreatingSeqs for " $ ppr _id <+> ppr node_id
-
-            -- At this point iff we have  possibly untagged arguments to strict fields
-            -- we convert the RHS into a RhsClosure which will evaluate the arguments
-            -- before allocating the constructor.
-            let ty_stub = panic "mkSeqs shouldn't use the type arg"
-            conExpr <- mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs ty_stub)
-
-            fvs <- fvArgs args
-            -- lcls <- getFVs
-            -- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls)
-            return $! (StgRhsClosure fvs ccs ReEntrant [] $! conExpr)
-rewriteRhs _binding (StgRhsClosure fvs ccs flag args body) = do
-    withBinders NotTopLevel args $
-        withClosureLcls fvs $
-            StgRhsClosure fvs ccs flag (map fst args) <$> rewriteExpr body
-        -- return (closure)
-
-fvArgs :: [StgArg] -> RM DVarSet
-fvArgs args = do
-    fv_lcls <- getFVs
-    -- pprTraceM "fvArgs" (text "args:" <> ppr args $$ text "lcls:" <> pprVarSet (fv_lcls) (braces . fsep . map ppr) )
-    return $ mkDVarSet [ v | StgVarArg v <- args, elemVarSet v fv_lcls]
-
-rewriteArgs :: [StgArg] -> RM [StgArg]
-rewriteArgs = mapM rewriteArg
-rewriteArg :: StgArg -> RM StgArg
-rewriteArg (StgVarArg v) = StgVarArg <$!> rewriteId v
-rewriteArg  (lit@StgLitArg{}) = return lit
-
-rewriteId :: Id -> RM Id
-rewriteId v = do
-    !is_tagged <- isTagged v
-    if is_tagged then return $! setIdTagSig v (TagSig TagProper)
-                 else return v
-
-rewriteExpr :: InferStgExpr -> RM TgStgExpr
-rewriteExpr (e@StgCase {})          = rewriteCase e
-rewriteExpr (e@StgLet {})           = rewriteLet e
-rewriteExpr (e@StgLetNoEscape {})   = rewriteLetNoEscape e
-rewriteExpr (StgTick t e)     = StgTick t <$!> rewriteExpr e
-rewriteExpr e@(StgConApp {})        = rewriteConApp e
-rewriteExpr e@(StgApp {})     = rewriteApp e
-rewriteExpr (StgLit lit)           = return $! (StgLit lit)
-rewriteExpr (StgOpApp op@(StgPrimOp DataToTagOp) args res_ty) = do
-        (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty
-rewriteExpr (StgOpApp op args res_ty) = return $! (StgOpApp op args res_ty)
-
-
-rewriteCase :: InferStgExpr -> RM TgStgExpr
-rewriteCase (StgCase scrut bndr alt_type alts) =
-    withBinder NotTopLevel bndr $
-        pure StgCase <*>
-            rewriteExpr scrut <*>
-            pure (fst bndr) <*>
-            pure alt_type <*>
-            mapM rewriteAlt alts
-
-rewriteCase _ = panic "Impossible: nodeCase"
-
-rewriteAlt :: InferStgAlt -> RM TgStgAlt
-rewriteAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs} =
-    withBinders NotTopLevel bndrs $ do
-        !rhs' <- rewriteExpr rhs
-        return $! alt {alt_bndrs = map fst bndrs, alt_rhs = rhs'}
-
-rewriteLet :: InferStgExpr -> RM TgStgExpr
-rewriteLet (StgLet xt bind expr) = do
-    (!bind') <- rewriteBinds NotTopLevel bind
-    withBind NotTopLevel bind $ do
-        -- pprTraceM "withBindLet" (ppr $ bindersOfX bind)
-        !expr' <- rewriteExpr expr
-        return $! (StgLet xt bind' expr')
-rewriteLet _ = panic "Impossible"
-
-rewriteLetNoEscape :: InferStgExpr -> RM TgStgExpr
-rewriteLetNoEscape (StgLetNoEscape xt bind expr) = do
-    (!bind') <- rewriteBinds NotTopLevel bind
-    withBind NotTopLevel bind $ do
-        !expr' <- rewriteExpr expr
-        return $! (StgLetNoEscape xt bind' expr')
-rewriteLetNoEscape _ = panic "Impossible"
-
-rewriteConApp :: InferStgExpr -> RM TgStgExpr
-rewriteConApp (StgConApp con cn args tys) = do
-    -- We check if the strict field arguments are already known to be tagged.
-    -- If not we evaluate them first.
-    fieldInfos <- mapM isArgTagged args
-    let strictIndices = getStrictConArgs con (zip fieldInfos args) :: [(Bool, StgArg)]
-    let needsEval = map snd . filter (not . fst) $ strictIndices :: [StgArg]
-    let evalArgs = [v | StgVarArg v <- needsEval] :: [Id]
-    if (not $ null evalArgs)
-        then do
-            -- pprTraceM "Creating conAppSeqs for " $ ppr nodeId <+> parens ( ppr evalArgs ) -- <+> parens ( ppr fieldInfos )
-            mkSeqs args evalArgs (\taggedArgs -> StgConApp con cn taggedArgs tys)
-        else return $! (StgConApp con cn args tys)
-
-rewriteConApp _ = panic "Impossible"
-
--- Special case: Atomic binders, usually in a case context like `case f of ...`.
-rewriteApp :: InferStgExpr -> RM TgStgExpr
-rewriteApp (StgApp f []) = do
-    f' <- rewriteId f
-    return $! StgApp f' []
-rewriteApp (StgApp f args)
-    -- pprTrace "rewriteAppOther" (ppr f <+> ppr args) False
-    -- = undefined
-    | Just marks <- idCbvMarks_maybe f
-    , relevant_marks <- dropWhileEndLE (not . isMarkedCbv) marks
-    , any isMarkedCbv relevant_marks
-    = assertPpr (length relevant_marks <= length args) (ppr f $$ ppr args $$ ppr relevant_marks)
-      unliftArg relevant_marks
-
-    where
-      -- If the function expects any argument to be call-by-value ensure the argument is already
-      -- evaluated.
-      unliftArg relevant_marks = do
-        argTags <- mapM isArgTagged args
-        let argInfo = zipWith3 ((,,)) args (relevant_marks++repeat NotMarkedCbv)  argTags :: [(StgArg, CbvMark, Bool)]
-
-            -- untagged cbv argument positions
-            cbvArgInfo = filter (\x -> sndOf3 x == MarkedCbv && thdOf3 x == False) argInfo
-            cbvArgIds = [x | StgVarArg x <- map fstOf3 cbvArgInfo] :: [Id]
-        mkSeqs args cbvArgIds (\cbv_args -> StgApp f cbv_args)
-
-rewriteApp (StgApp f args) = return $ StgApp f args
-rewriteApp _ = panic "Impossible"
-
--- `mkSeq` x x' e generates `case x of x' -> e`
--- We could also substitute x' for x in e but that's so rarely beneficial
--- that we don't bother.
-mkSeq :: Id -> Id -> TgStgExpr -> TgStgExpr
-mkSeq id bndr !expr =
-    -- pprTrace "mkSeq" (ppr (id,bndr)) $
-    let altTy = mkStgAltTypeFromStgAlts bndr alt
-        alt   = [GenStgAlt {alt_con = DEFAULT, alt_bndrs = [], alt_rhs = expr}]
-    in StgCase (StgApp id []) bndr altTy alt
-
--- `mkSeqs args vs mkExpr` will force all vs, and construct
--- an argument list args' where each v is replaced by it's evaluated
--- counterpart v'.
--- That is if we call `mkSeqs [StgVar x, StgLit l] [x] mkExpr` then
--- the result will be (case x of x' { _DEFAULT -> <mkExpr [StgVar x', StgLit l]>}
-{-# INLINE mkSeqs #-} -- We inline to avoid allocating mkExpr
-mkSeqs  :: [StgArg] -- ^ Original arguments
-        -> [Id]     -- ^ var args to be evaluated ahead of time
-        -> ([StgArg] -> TgStgExpr)
-                    -- ^ Function that reconstructs the expressions when passed
-                    -- the list of evaluated arguments.
-        -> RM TgStgExpr
-mkSeqs args untaggedIds mkExpr = do
-    argMap <- mapM (\arg -> (arg,) <$> mkLocalArgId arg ) untaggedIds :: RM [(InId, OutId)]
-    -- mapM_ (pprTraceM "Forcing strict args before allocation:" . ppr) argMap
-    let taggedArgs :: [StgArg]
-            = map   (\v -> case v of
-                        StgVarArg v' -> StgVarArg $ fromMaybe v' $ lookup v' argMap
-                        lit -> lit)
-                    args
-
-    let conBody = mkExpr taggedArgs
-    let body = foldr (\(v,bndr) expr -> mkSeq v bndr expr) conBody argMap
-    return $! body
-
--- Out of all arguments passed at runtime only return these ending up in a
--- strict field
-getStrictConArgs :: Outputable a => DataCon -> [a] -> [a]
-getStrictConArgs con args
-    -- These are always lazy in their arguments.
-    | isUnboxedTupleDataCon con = []
-    | isUnboxedSumDataCon con = []
-    -- For proper data cons we have to check.
-    | otherwise =
-        assertPpr   (length args == length (dataConRuntimeRepStrictness con))
-                    (text "Mismatched con arg and con rep strictness lengths:" $$
-                     text "Con" <> ppr con <+> text "is applied to" <+> ppr args $$
-                     text "But seems to have arity" <> ppr (length repStrictness)) $
-        [ arg | (arg,MarkedStrict)
-                    <- zipEqual "getStrictConArgs"
-                                args
-                                repStrictness]
-        where
-            repStrictness = (dataConRuntimeRepStrictness con)
diff --git a/compiler/GHC/Stg/InferTags/Types.hs b/compiler/GHC/Stg/InferTags/Types.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/InferTags/Types.hs
+++ /dev/null
@@ -1,137 +0,0 @@
-{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ConstraintKinds #-}
-
-{-# LANGUAGE UndecidableInstances #-}
- -- To permit: type instance XLet 'InferTaggedBinders = XLet 'CodeGen
-
-module GHC.Stg.InferTags.Types
-    ( module GHC.Stg.InferTags.Types
-    , module TagSig)
-where
-
-import GHC.Prelude
-
-import GHC.Core.DataCon
-import GHC.Core.Type (isUnliftedType)
-import GHC.Types.Id
-import GHC.Stg.Syntax
-import GHC.Stg.InferTags.TagSig as TagSig
-import GHC.Types.Var.Env
-import GHC.Utils.Outputable
-import GHC.Utils.Misc( zipWithEqual )
-import GHC.Utils.Panic
-
-import GHC.StgToCmm.Types
-
-{- *********************************************************************
-*                                                                      *
-                         Supporting data types
-*                                                                      *
-********************************************************************* -}
-
-type instance BinderP      'InferTaggedBinders = (Id, TagSig)
-type instance XLet         'InferTaggedBinders = XLet         'CodeGen
-type instance XLetNoEscape 'InferTaggedBinders = XLetNoEscape 'CodeGen
-type instance XRhsClosure  'InferTaggedBinders = XRhsClosure  'CodeGen
-
-type InferStgTopBinding = GenStgTopBinding 'InferTaggedBinders
-type InferStgBinding    = GenStgBinding    'InferTaggedBinders
-type InferStgExpr       = GenStgExpr       'InferTaggedBinders
-type InferStgRhs        = GenStgRhs        'InferTaggedBinders
-type InferStgAlt        = GenStgAlt        'InferTaggedBinders
-
-combineAltInfo :: TagInfo -> TagInfo -> TagInfo
-combineAltInfo TagDunno         _              = TagDunno
-combineAltInfo _                TagDunno       = TagDunno
-combineAltInfo (TagTuple {})    TagProper      = panic "Combining unboxed tuple with non-tuple result"
-combineAltInfo TagProper       (TagTuple {})   = panic "Combining unboxed tuple with non-tuple result"
-combineAltInfo TagProper        TagProper      = TagProper
-combineAltInfo (TagTuple is1)  (TagTuple is2)  = TagTuple (zipWithEqual "combineAltInfo" combineAltInfo is1 is2)
-combineAltInfo (TagTagged)      ti             = ti
-combineAltInfo ti               TagTagged      = ti
-
-type TagSigEnv = IdEnv TagSig
-data TagEnv p = TE { te_env :: TagSigEnv
-                   , te_get :: BinderP p -> Id
-                   }
-
-instance Outputable (TagEnv p) where
-    ppr te = ppr (te_env te)
-
-
-getBinderId :: TagEnv p -> BinderP p -> Id
-getBinderId = te_get
-
-initEnv :: TagEnv 'CodeGen
-initEnv = TE { te_env = emptyVarEnv
-             , te_get = \x -> x}
-
--- | Simple convert env to a env of the 'InferTaggedBinders pass
--- with no other changes.
-makeTagged :: TagEnv p -> TagEnv 'InferTaggedBinders
-makeTagged env = TE { te_env = te_env env
-                    , te_get = fst }
-
-noSig :: TagEnv p -> BinderP p -> (Id, TagSig)
-noSig env bndr
-  | isUnliftedType (idType var) = (var, TagSig TagProper)
-  | otherwise = (var, TagSig TagDunno)
-  where
-    var = getBinderId env bndr
-
-lookupSig :: TagEnv p -> Id -> Maybe TagSig
-lookupSig env fun = lookupVarEnv (te_env env) fun
-
-lookupInfo :: TagEnv p -> StgArg -> TagInfo
-lookupInfo env (StgVarArg var)
-  -- Nullary data constructors like True, False
-  | Just dc <- isDataConWorkId_maybe var
-  , isNullaryRepDataCon dc
-  = TagProper
-
-  | isUnliftedType (idType var)
-  = TagProper
-
-  -- Variables in the environment.
-  | Just (TagSig info) <- lookupVarEnv (te_env env) var
-  = info
-
-  | Just lf_info <- idLFInfo_maybe var
-  =   case lf_info of
-          -- Function, tagged (with arity)
-          LFReEntrant {}
-              -> TagProper
-          -- Thunks need to be entered.
-          LFThunk {}
-              -> TagDunno
-          -- Constructors, already tagged.
-          LFCon {}
-              -> TagProper
-          LFUnknown {}
-              -> TagDunno
-          LFUnlifted {}
-              -> TagProper
-          -- Shouldn't be possible. I don't think we can export letNoEscapes
-          LFLetNoEscape {} -> panic "LFLetNoEscape exported"
-
-  | otherwise
-  = TagDunno
-
-lookupInfo _ (StgLitArg {})
-  = TagProper
-
-isDunnoSig :: TagSig -> Bool
-isDunnoSig (TagSig TagDunno) = True
-isDunnoSig (TagSig TagProper) = False
-isDunnoSig (TagSig TagTuple{}) = False
-isDunnoSig (TagSig TagTagged{}) = False
-
-isTaggedInfo :: TagInfo -> Bool
-isTaggedInfo TagProper = True
-isTaggedInfo TagTagged = True
-isTaggedInfo _         = False
-
-extendSigEnv :: TagEnv p -> [(Id,TagSig)] -> TagEnv p
-extendSigEnv env@(TE { te_env = sig_env }) bndrs
-  = env { te_env = extendVarEnvList sig_env bndrs }
diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/Lift.hs
+++ /dev/null
@@ -1,255 +0,0 @@
-
-
--- | Implements a selective lambda lifter, running late in the optimisation
--- pipeline.
---
--- If you are interested in the cost model that is employed to decide whether
--- to lift a binding or not, look at "GHC.Stg.Lift.Analysis".
--- "GHC.Stg.Lift.Monad" contains the transformation monad that hides away some
--- plumbing of the transformation.
-module GHC.Stg.Lift
-   (
-    -- * Late lambda lifting in STG
-    -- $note
-   StgLiftConfig (..),
-   stgLiftLams
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Types.Basic
-import GHC.Types.Id
-import GHC.Stg.FVs ( annBindingFreeVars )
-import GHC.Stg.Lift.Config
-import GHC.Stg.Lift.Analysis
-import GHC.Stg.Lift.Monad
-import GHC.Stg.Syntax
-import GHC.Unit.Module (Module)
-import GHC.Types.Unique.Supply
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Types.Var.Set
-import Control.Monad ( when )
-import Data.Maybe ( isNothing )
-
--- Note [Late lambda lifting in STG]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- $note
--- See also the <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>
--- and #9476.
---
--- The basic idea behind lambda lifting is to turn locally defined functions
--- into top-level functions. Free variables are then passed as additional
--- arguments at *call sites* instead of having a closure allocated for them at
--- *definition site*. Example:
---
--- @
---    let x = ...; y = ... in
---    let f = {x y} \a -> a + x + y in
---    let g = {f x} \b -> f b + x in
---    g 5
--- @
---
--- Lambda lifting @f@ would
---
---   1. Turn @f@'s free variables into formal parameters
---   2. Update @f@'s call site within @g@ to @f x y b@
---   3. Update @g@'s closure: Add @y@ as an additional free variable, while
---      removing @f@, because @f@ no longer allocates and can be floated to
---      top-level.
---   4. Actually float the binding of @f@ to top-level, eliminating the @let@
---      in the process.
---
--- This results in the following program (with free var annotations):
---
--- @
---    f x y a = a + x + y;
---    let x = ...; y = ... in
---    let g = {x y} \b -> f x y b + x in
---    g 5
--- @
---
--- This optimisation is all about lifting only when it is beneficial to do so.
--- The above seems like a worthwhile lift, judging from heap allocation:
--- We eliminate @f@'s closure, saving to allocate a closure with 2 words, while
--- not changing the size of @g@'s closure.
---
--- You can probably sense that there's some kind of cost model at play here.
--- And you are right! But we also employ a couple of other heuristics for the
--- lifting decision which are outlined in "GHC.Stg.Lift.Analysis#when".
---
--- The transformation is done in "GHC.Stg.Lift", which calls out to
--- 'GHC.Stg.Lift.Analysis.goodToLift' for its lifting decision.  It relies on
--- "GHC.Stg.Lift.Monad", which abstracts some subtle STG invariants into a
--- monadic substrate.
---
--- Suffice to say: We trade heap allocation for stack allocation.
--- The additional arguments have to passed on the stack (or in registers,
--- depending on architecture) every time we call the function to save a single
--- heap allocation when entering the let binding. Nofib suggests a mean
--- improvement of about 1% for this pass, so it seems like a worthwhile thing to
--- do. Compile-times went up by 0.6%, so all in all a very modest change.
---
--- For a concrete example, look at @spectral/atom@. There's a call to 'zipWith'
--- that is ultimately compiled to something like this
--- (module desugaring/lowering to actual STG):
---
--- @
---    propagate dt = ...;
---    runExperiment ... =
---      let xs = ... in
---      let ys = ... in
---      let go = {dt go} \xs ys -> case (xs, ys) of
---            ([], []) -> []
---            (x:xs', y:ys') -> propagate dt x y : go xs' ys'
---      in go xs ys
--- @
---
--- This will lambda lift @go@ to top-level, speeding up the resulting program
--- by roughly one percent:
---
--- @
---    propagate dt = ...;
---    go dt xs ys = case (xs, ys) of
---      ([], []) -> []
---      (x:xs', y:ys') -> propagate dt x y : go dt xs' ys'
---    runExperiment ... =
---      let xs = ... in
---      let ys = ... in
---      in go dt xs ys
--- @
-
-
-
--- | Lambda lifts bindings to top-level deemed worth lifting (see 'goodToLift').
---
--- (Mostly) textbook instance of the lambda lifting transformation, selecting
--- which bindings to lambda lift by consulting 'goodToLift'.
-stgLiftLams :: Module -> StgLiftConfig -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]
-stgLiftLams this_mod cfg us = runLiftM cfg us . foldr (liftTopLvl this_mod) (pure ())
-
-liftTopLvl :: Module -> InStgTopBinding -> LiftM () -> LiftM ()
-liftTopLvl _ (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do
-  addTopStringLit bndr' lit
-  rest
-liftTopLvl this_mod (StgTopLifted bind) rest = do
-  let is_rec = isRec $ fst $ decomposeStgBinding bind
-  when is_rec startBindingGroup
-  let bind_w_fvs = annBindingFreeVars this_mod bind
-  withLiftedBind TopLevel (tagSkeletonTopBind bind_w_fvs) NilSk $ \mb_bind' -> do
-    -- We signal lifting of a binding through returning Nothing.
-    -- Should never happen for a top-level binding, though, since we are already
-    -- at top-level.
-    case mb_bind' of
-      Nothing -> pprPanic "StgLiftLams" (text "Lifted top-level binding")
-      Just bind' -> addLiftedBinding bind'
-    when is_rec endBindingGroup
-    rest
-
-withLiftedBind
-  :: TopLevelFlag
-  -> LlStgBinding
-  -> Skeleton
-  -> (Maybe OutStgBinding -> LiftM a)
-  -> LiftM a
-withLiftedBind top_lvl bind scope k
-  = withLiftedBindPairs top_lvl rec pairs scope (k . fmap (mkStgBinding rec))
-  where
-    (rec, pairs) = decomposeStgBinding bind
-
-withLiftedBindPairs
-  :: TopLevelFlag
-  -> RecFlag
-  -> [(BinderInfo, LlStgRhs)]
-  -> Skeleton
-  -> (Maybe [(Id, OutStgRhs)] -> LiftM a)
-  -> LiftM a
-withLiftedBindPairs top rec pairs scope k = do
-  let (infos, rhss) = unzip pairs
-  let bndrs = map binderInfoBndr infos
-  expander <- liftedIdsExpander
-  cfg <- getConfig
-  case goodToLift cfg top rec expander pairs scope of
-    -- @abs_ids@ is the set of all variables that need to become parameters.
-    Just abs_ids -> withLiftedBndrs abs_ids bndrs $ \bndrs' -> do
-      -- Within this block, all binders in @bndrs@ will be noted as lifted, so
-      -- that the return value of @liftedIdsExpander@ in this context will also
-      -- expand the bindings in @bndrs@ to their free variables.
-      -- Now we can recurse into the RHSs and see if we can lift any further
-      -- bindings. We pass the set of expanded free variables (thus OutIds) on
-      -- to @liftRhs@ so that it can add them as parameter binders.
-      when (isRec rec) startBindingGroup
-      rhss' <- traverse (liftRhs (Just abs_ids)) rhss
-      let pairs' = zip bndrs' rhss'
-      addLiftedBinding (mkStgBinding rec pairs')
-      when (isRec rec) endBindingGroup
-      k Nothing
-    Nothing -> withSubstBndrs bndrs $ \bndrs' -> do
-      -- Don't lift the current binding, but possibly some bindings in their
-      -- RHSs.
-      rhss' <- traverse (liftRhs Nothing) rhss
-      let pairs' = zip bndrs' rhss'
-      k (Just pairs')
-
-liftRhs
-  :: Maybe (DIdSet)
-  -- ^ @Just former_fvs@ <=> this RHS was lifted and we have to add @former_fvs@
-  -- as lambda binders, discarding all free vars.
-  -> LlStgRhs
-  -> LiftM OutStgRhs
-liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args)
-  = assertPpr (isNothing mb_former_fvs)
-              (text "Should never lift a constructor"
-               $$ pprStgRhs panicStgPprOpts rhs) $
-    StgRhsCon ccs con mn ts <$> traverse liftArgs args
-liftRhs Nothing (StgRhsClosure _ ccs upd infos body) =
-  -- This RHS wasn't lifted.
-  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
-    StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body
-liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) =
-  -- This RHS was lifted. Insert extra binders for @former_fvs@.
-  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do
-    let bndrs'' = dVarSetElems former_fvs ++ bndrs'
-    StgRhsClosure noExtFieldSilent ccs upd bndrs'' <$> liftExpr body
-
-liftArgs :: InStgArg -> LiftM OutStgArg
-liftArgs a@(StgLitArg _) = pure a
-liftArgs (StgVarArg occ) = do
-  assertPprM (not <$> isLifted occ) (text "StgArgs should never be lifted" $$ ppr occ)
-  StgVarArg <$> substOcc occ
-
-liftExpr :: LlStgExpr -> LiftM OutStgExpr
-liftExpr (StgLit lit) = pure (StgLit lit)
-liftExpr (StgTick t e) = StgTick t <$> liftExpr e
-liftExpr (StgApp f args) = do
-  f' <- substOcc f
-  args' <- traverse liftArgs args
-  fvs' <- formerFreeVars f
-  let top_lvl_args = map StgVarArg fvs' ++ args'
-  pure (StgApp f' top_lvl_args)
-liftExpr (StgConApp con mn args tys) = StgConApp con mn <$> traverse liftArgs args <*> pure tys
-liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty
-liftExpr (StgCase scrut info ty alts) = do
-  scrut' <- liftExpr scrut
-  withSubstBndr (binderInfoBndr info) $ \bndr' -> do
-    alts' <- traverse liftAlt alts
-    pure (StgCase scrut' bndr' ty alts')
-liftExpr (StgLet scope bind body)
-  = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do
-      body' <- liftExpr body
-      case mb_bind' of
-        Nothing -> pure body' -- withLiftedBindPairs decided to lift it and already added floats
-        Just bind' -> pure (StgLet noExtFieldSilent bind' body')
-liftExpr (StgLetNoEscape scope bind body)
-  = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do
-      body' <- liftExpr body
-      case mb_bind' of
-        Nothing -> pprPanic "stgLiftLams" (text "Should never decide to lift LNEs")
-        Just bind' -> pure (StgLetNoEscape noExtFieldSilent bind' body')
-
-liftAlt :: LlStgAlt -> LiftM OutStgAlt
-liftAlt alt@GenStgAlt{alt_con=_, alt_bndrs=infos, alt_rhs=rhs} =
-  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
-    do !rhs' <- liftExpr rhs
-       return $! alt {alt_bndrs = bndrs', alt_rhs = rhs'}
diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/Lift/Analysis.hs
+++ /dev/null
@@ -1,556 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DataKinds #-}
-
--- | Provides the heuristics for when it's beneficial to lambda lift bindings.
--- Most significantly, this employs a cost model to estimate impact on heap
--- allocations, by looking at an STG expression's 'Skeleton'.
-module GHC.Stg.Lift.Analysis (
-    -- * #when# When to lift
-    -- $when
-
-    -- * #clogro# Estimating closure growth
-    -- $clogro
-
-    -- * AST annotation
-    Skeleton(..), BinderInfo(..), binderInfoBndr,
-    LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, tagSkeletonTopBind,
-    -- * Lifting decision
-    goodToLift,
-    closureGrowth -- Exported just for the docs
-  ) where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Platform.Profile
-
-import GHC.Types.Basic
-import GHC.Types.Demand
-import GHC.Types.Id
-import GHC.Runtime.Heap.Layout ( WordOff )
-import GHC.Stg.Lift.Config
-import GHC.Stg.Syntax
-import qualified GHC.StgToCmm.ArgRep  as StgToCmm.ArgRep
-import qualified GHC.StgToCmm.Closure as StgToCmm.Closure
-import qualified GHC.StgToCmm.Layout  as StgToCmm.Layout
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Types.Var.Set
-
-import Data.Maybe ( mapMaybe )
-
--- Note [When to lift]
--- ~~~~~~~~~~~~~~~~~~~
--- $when
--- The analysis proceeds in two steps:
---
---   1. It tags the syntax tree with analysis information in the form of
---      'BinderInfo' at each binder and 'Skeleton's at each let-binding
---      by 'tagSkeletonTopBind' and friends.
---   2. The resulting syntax tree is treated by the "GHC.Stg.Lift"
---      module, calling out to 'goodToLift' to decide if a binding is worthwhile
---      to lift.
---      'goodToLift' consults argument occurrence information in 'BinderInfo'
---      and estimates 'closureGrowth', for which it needs the 'Skeleton'.
---
--- So the annotations from 'tagSkeletonTopBind' ultimately fuel 'goodToLift',
--- which employs a number of heuristics to identify and exclude lambda lifting
--- opportunities deemed non-beneficial:
---
---  [Top-level bindings] can't be lifted.
---  [Thunks] and data constructors shouldn't be lifted in order not to destroy
---    sharing.
---  [Argument occurrences] #arg_occs# of binders prohibit them to be lifted.
---    Doing the lift would re-introduce the very allocation at call sites that
---    we tried to get rid off in the first place. We capture analysis
---    information in 'BinderInfo'. Note that we also consider a nullary
---    application as argument occurrence, because it would turn into an n-ary
---    partial application created by a generic apply function. This occurs in
---    CPS-heavy code like the CS benchmark.
---  [Join points] should not be lifted, simply because there's no reduction in
---    allocation to be had.
---  [Abstracting over join points] destroys join points, because they end up as
---    arguments to the lifted function.
---  [Abstracting over known local functions] turns a known call into an unknown
---    call (e.g. some @stg_ap_*@), which is generally slower. Can be turned off
---    with @-fstg-lift-lams-known@.
---  [Calling convention] Don't lift when the resulting function would have a
---    higher arity than available argument registers for the calling convention.
---    Can be influenced with @-fstg-lift-(non)rec-args(-any)@.
---  [Closure growth] introduced when former free variables have to be available
---    at call sites may actually lead to an increase in overall allocations
---  resulting from a lift. Estimating closure growth is described in
---  "GHC.Stg.Lift.Analysis#clogro" and is what most of this module is ultimately
---  concerned with.
---
--- There's a <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page> with
--- some more background and history.
-
--- Note [Estimating closure growth]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- $clogro
--- We estimate closure growth by abstracting the syntax tree into a 'Skeleton',
--- capturing only syntactic details relevant to 'closureGrowth', such as
---
---   * 'ClosureSk', representing closure allocation.
---   * 'RhsSk', representing a RHS of a binding and how many times it's called
---     by an appropriate 'Card'.
---   * 'AltSk', 'BothSk' and 'NilSk' for choice, sequence and empty element.
---
--- This abstraction is mostly so that the main analysis function 'closureGrowth'
--- can stay simple and focused. Also, skeletons tend to be much smaller than
--- the syntax tree they abstract, so it makes sense to construct them once and
--- and operate on them instead of the actual syntax tree.
---
--- A more detailed treatment of computing closure growth, including examples,
--- can be found in the paper referenced from the
--- <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>.
-
-llTrace :: String -> SDoc -> a -> a
-llTrace _ _ c = c
--- llTrace a b c = pprTrace a b c
-
-type instance BinderP      'LiftLams = BinderInfo
-type instance XRhsClosure  'LiftLams = DIdSet
-type instance XLet         'LiftLams = Skeleton
-type instance XLetNoEscape 'LiftLams = Skeleton
-
-
--- | Captures details of the syntax tree relevant to the cost model, such as
--- closures, multi-shot lambdas and case expressions.
-data Skeleton
-  = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton
-  | RhsSk !Card {- ^ how often the RHS was entered -} !Skeleton
-  | AltSk !Skeleton !Skeleton
-  | BothSk !Skeleton !Skeleton
-  | NilSk
-
-bothSk :: Skeleton -> Skeleton -> Skeleton
-bothSk NilSk b = b
-bothSk a NilSk = a
-bothSk a b     = BothSk a b
-
-altSk :: Skeleton -> Skeleton -> Skeleton
-altSk NilSk b = b
-altSk a NilSk = a
-altSk a b     = AltSk a b
-
-rhsSk :: Card -> Skeleton -> Skeleton
-rhsSk _        NilSk = NilSk
-rhsSk body_dmd skel  = RhsSk body_dmd skel
-
--- | The type used in binder positions in 'GenStgExpr's.
-data BinderInfo
-  = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag
-                           --   indicating whether it occurs as an argument
-                           --   or in a nullary application
-                           --   (see "GHC.Stg.Lift.Analysis#arg_occs").
-  | BoringBinder !Id       -- ^ Every other kind of binder
-
--- | Gets the bound 'Id' out a 'BinderInfo'.
-binderInfoBndr :: BinderInfo -> Id
-binderInfoBndr (BoringBinder bndr)   = bndr
-binderInfoBndr (BindsClosure bndr _) = bndr
-
--- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating
--- occurrences as argument or in a nullary applications otherwise.
-binderInfoOccursAsArg :: BinderInfo -> Maybe Bool
-binderInfoOccursAsArg BoringBinder{}     = Nothing
-binderInfoOccursAsArg (BindsClosure _ b) = Just b
-
-instance Outputable Skeleton where
-  ppr NilSk = text ""
-  ppr (AltSk l r) = vcat
-    [ text "{ " <+> ppr l
-    , text "ALT"
-    , text "  " <+> ppr r
-    , text "}"
-    ]
-  ppr (BothSk l r) = ppr l $$ ppr r
-  ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body)
-  ppr (RhsSk card body) = hcat
-    [ lambda
-    , ppr card
-    , dot
-    , ppr body
-    ]
-
-instance Outputable BinderInfo where
-  ppr = ppr . binderInfoBndr
-
-instance OutputableBndr BinderInfo where
-  pprBndr b = pprBndr b . binderInfoBndr
-  pprPrefixOcc = pprPrefixOcc . binderInfoBndr
-  pprInfixOcc = pprInfixOcc . binderInfoBndr
-  bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr
-
-mkArgOccs :: [StgArg] -> IdSet
-mkArgOccs = mkVarSet . mapMaybe stg_arg_var
-  where
-    stg_arg_var (StgVarArg occ) = Just occ
-    stg_arg_var _               = Nothing
-
--- | Tags every binder with its 'BinderInfo' and let bindings with their
--- 'Skeleton's.
-tagSkeletonTopBind :: CgStgBinding -> LlStgBinding
--- NilSk is OK when tagging top-level bindings. Also, top-level things are never
--- lambda-lifted, so no need to track their argument occurrences. They can also
--- never be let-no-escapes (thus we pass False).
-tagSkeletonTopBind bind = bind'
-  where
-    (_, _, _, bind') = tagSkeletonBinding False NilSk emptyVarSet bind
-
--- | Tags binders of an 'StgExpr' with its 'BinderInfo' and let bindings with
--- their 'Skeleton's. Additionally, returns its 'Skeleton' and the set of binder
--- occurrences in argument and nullary application position
--- (cf. "GHC.Stg.Lift.Analysis#arg_occs").
-tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr)
-tagSkeletonExpr (StgLit lit)
-  = (NilSk, emptyVarSet, StgLit lit)
-tagSkeletonExpr (StgConApp con mn args tys)
-  = (NilSk, mkArgOccs args, StgConApp con mn args tys)
-tagSkeletonExpr (StgOpApp op args ty)
-  = (NilSk, mkArgOccs args, StgOpApp op args ty)
-tagSkeletonExpr (StgApp f args)
-  = (NilSk, arg_occs, StgApp f args)
-  where
-    arg_occs
-      -- This checks for nullary applications, which we treat the same as
-      -- argument occurrences, see "GHC.Stg.Lift.Analysis#arg_occs".
-      | null args = unitVarSet f
-      | otherwise = mkArgOccs args
-tagSkeletonExpr (StgCase scrut bndr ty alts)
-  = (skel, arg_occs, StgCase scrut' bndr' ty alts')
-  where
-    (scrut_skel, scrut_arg_occs, scrut') = tagSkeletonExpr scrut
-    (alt_skels, alt_arg_occss, alts') = mapAndUnzip3 tagSkeletonAlt alts
-    skel = bothSk scrut_skel (foldr altSk NilSk alt_skels)
-    arg_occs = unionVarSets (scrut_arg_occs:alt_arg_occss) `delVarSet` bndr
-    bndr' = BoringBinder bndr
-tagSkeletonExpr (StgTick t e)
-  = (skel, arg_occs, StgTick t e')
-  where
-    (skel, arg_occs, e') = tagSkeletonExpr e
-tagSkeletonExpr (StgLet _ bind body) = tagSkeletonLet False body bind
-tagSkeletonExpr (StgLetNoEscape _ bind body) = tagSkeletonLet True body bind
-
-mkLet :: Bool -> Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr
-mkLet True = StgLetNoEscape
-mkLet _    = StgLet
-
-tagSkeletonLet
-  :: Bool
-  -- ^ Is the binding a let-no-escape?
-  -> CgStgExpr
-  -- ^ Let body
-  -> CgStgBinding
-  -- ^ Binding group
-  -> (Skeleton, IdSet, LlStgExpr)
-  -- ^ RHS skeletons, argument occurrences and annotated binding
-tagSkeletonLet is_lne body bind
-  = (let_skel, arg_occs, mkLet is_lne scope bind' body')
-  where
-    (body_skel, body_arg_occs, body') = tagSkeletonExpr body
-    (let_skel, arg_occs, scope, bind')
-      = tagSkeletonBinding is_lne body_skel body_arg_occs bind
-
-tagSkeletonBinding
-  :: Bool
-  -- ^ Is the binding a let-no-escape?
-  -> Skeleton
-  -- ^ Let body skeleton
-  -> IdSet
-  -- ^ Argument occurrences in the body
-  -> CgStgBinding
-  -- ^ Binding group
-  -> (Skeleton, IdSet, Skeleton, LlStgBinding)
-  -- ^ Let skeleton, argument occurrences, scope skeleton of binding and
-  --   the annotated binding
-tagSkeletonBinding is_lne body_skel body_arg_occs (StgNonRec bndr rhs)
-  = (let_skel, arg_occs, scope, bind')
-  where
-    (rhs_skel, rhs_arg_occs, rhs') = tagSkeletonRhs bndr rhs
-    arg_occs = (body_arg_occs `unionVarSet` rhs_arg_occs) `delVarSet` bndr
-    bind_skel
-      | is_lne    = rhs_skel -- no closure is allocated for let-no-escapes
-      | otherwise = ClosureSk bndr (freeVarsOfRhs rhs) rhs_skel
-    let_skel = bothSk body_skel bind_skel
-    occurs_as_arg = bndr `elemVarSet` body_arg_occs
-    -- Compared to the recursive case, this exploits the fact that @bndr@ is
-    -- never free in @rhs@.
-    scope = body_skel
-    bind' = StgNonRec (BindsClosure bndr occurs_as_arg) rhs'
-tagSkeletonBinding is_lne body_skel body_arg_occs (StgRec pairs)
-  = (let_skel, arg_occs, scope, StgRec pairs')
-  where
-    (bndrs, _) = unzip pairs
-    -- Local recursive STG bindings also regard the defined binders as free
-    -- vars. We want to delete those for our cost model, as these are known
-    -- calls anyway when we add them to the same top-level recursive group as
-    -- the top-level binding currently being analysed.
-    skel_occs_rhss' = map (uncurry tagSkeletonRhs) pairs
-    rhss_arg_occs = map sndOf3 skel_occs_rhss'
-    scope_occs = unionVarSets (body_arg_occs:rhss_arg_occs)
-    arg_occs = scope_occs `delVarSetList` bndrs
-    -- @skel_rhss@ aren't yet wrapped in closures. We'll do that in a moment,
-    -- but we also need the un-wrapped skeletons for calculating the @scope@
-    -- of the group, as the outer closures don't contribute to closure growth
-    -- when we lift this specific binding.
-    scope = foldr (bothSk . fstOf3) body_skel skel_occs_rhss'
-    -- Now we can build the actual Skeleton for the expression just by
-    -- iterating over each bind pair.
-    (bind_skels, pairs') = unzip (zipWith single_bind bndrs skel_occs_rhss')
-    let_skel = foldr bothSk body_skel bind_skels
-    single_bind bndr (skel_rhs, _, rhs') = (bind_skel, (bndr', rhs'))
-      where
-        -- Here, we finally add the closure around each @skel_rhs@.
-        bind_skel
-          | is_lne    = skel_rhs -- no closure is allocated for let-no-escapes
-          | otherwise = ClosureSk bndr fvs skel_rhs
-        fvs = freeVarsOfRhs rhs' `dVarSetMinusVarSet` mkVarSet bndrs
-        bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs)
-
-tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs)
-tagSkeletonRhs _ (StgRhsCon ccs dc mn ts args)
-  = (NilSk, mkArgOccs args, StgRhsCon ccs dc mn ts args)
-tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body)
-  = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body')
-  where
-    bndrs' = map BoringBinder bndrs
-    (body_skel, body_arg_occs, body') = tagSkeletonExpr body
-    rhs_skel = rhsSk (rhsCard bndr) body_skel
-
--- | How many times will the lambda body of the RHS bound to the given
--- identifier be evaluated, relative to its defining context? This function
--- computes the answer in form of a 'Card'.
-rhsCard :: Id -> Card
-rhsCard bndr
-  | is_thunk  = oneifyCard n
-  | otherwise = n `multCard` (fst $ peelManyCalls (idArity bndr) cd)
-  where
-    is_thunk = idArity bndr == 0
-    -- Let's pray idDemandInfo is still OK after unarise...
-    n :* cd = idDemandInfo bndr
-
-tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt)
-tagSkeletonAlt old@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs}
-  = (alt_skel, arg_occs, old {alt_bndrs=fmap BoringBinder bndrs, alt_rhs=rhs'})
-  where
-    (alt_skel, alt_arg_occs, rhs') = tagSkeletonExpr rhs
-    arg_occs = alt_arg_occs `delVarSetList` bndrs
-
--- | Combines several heuristics to decide whether to lambda-lift a given
--- @let@-binding to top-level. See "GHC.Stg.Lift.Analysis#when" for details.
-goodToLift
-  :: StgLiftConfig
-  -> TopLevelFlag
-  -> RecFlag
-  -> (DIdSet -> DIdSet) -- ^ An expander function, turning 'InId's into
-                        -- 'OutId's. See 'GHC.Stg.Lift.Monad.liftedIdsExpander'.
-  -> [(BinderInfo, LlStgRhs)]
-  -> Skeleton
-  -> Maybe DIdSet       -- ^ @Just abs_ids@ <=> This binding is beneficial to
-                        -- lift and @abs_ids@ are the variables it would
-                        -- abstract over
-goodToLift cfg top_lvl rec_flag expander pairs scope = decide
-  [ ("top-level", isTopLevel top_lvl) -- keep in sync with Note [When to lift]
-  , ("memoized", any_memoized)
-  , ("argument occurrences", arg_occs)
-  , ("join point", is_join_point)
-  , ("abstracts join points", abstracts_join_ids)
-  , ("abstracts known local function", abstracts_known_local_fun)
-  , ("args spill on stack", args_spill_on_stack)
-  , ("increases allocation", inc_allocs)
-  ] where
-      profile  = c_targetProfile cfg
-      platform = profilePlatform profile
-      decide deciders
-        | not (fancy_or deciders)
-        = llTrace "stgLiftLams:lifting"
-                  (ppr bndrs <+> ppr abs_ids $$
-                   ppr allocs $$
-                   ppr scope) $
-          Just abs_ids
-        | otherwise
-        = Nothing
-      ppr_deciders = vcat . map (text . fst) . filter snd
-      fancy_or deciders
-        = llTrace "stgLiftLams:goodToLift" (ppr bndrs $$ ppr_deciders deciders) $
-          any snd deciders
-
-      bndrs = map (binderInfoBndr . fst) pairs
-      bndrs_set = mkVarSet bndrs
-      rhss = map snd pairs
-
-      -- First objective: Calculate @abs_ids@, e.g. the former free variables
-      -- the lifted binding would abstract over. We have to merge the free
-      -- variables of all RHS to get the set of variables that will have to be
-      -- passed through parameters.
-      fvs = unionDVarSets (map freeVarsOfRhs rhss)
-      -- To lift the binding to top-level, we want to delete the lifted binders
-      -- themselves from the free var set. Local let bindings track recursive
-      -- occurrences in their free variable set. We neither want to apply our
-      -- cost model to them (see 'tagSkeletonRhs'), nor pass them as parameters
-      -- when lifted, as these are known calls. We call the resulting set the
-      -- identifiers we abstract over, thus @abs_ids@. These are all 'OutId's.
-      -- We will save the set in 'LiftM.e_expansions' for each of the variables
-      -- if we perform the lift.
-      abs_ids = expander (delDVarSetList fvs bndrs)
-
-      -- We don't lift updatable thunks or constructors
-      any_memoized = any is_memoized_rhs rhss
-      is_memoized_rhs StgRhsCon{} = True
-      is_memoized_rhs (StgRhsClosure _ _ upd _ _) = isUpdatable upd
-
-      -- Don't lift binders occurring as arguments. This would result in complex
-      -- argument expressions which would have to be given a name, reintroducing
-      -- the very allocation at each call site that we wanted to get rid off in
-      -- the first place.
-      arg_occs = or (mapMaybe (binderInfoOccursAsArg . fst) pairs)
-
-      -- These don't allocate anyway.
-      is_join_point = any isJoinId bndrs
-
-      -- Abstracting over join points/let-no-escapes spoils them.
-      abstracts_join_ids = any isJoinId (dVarSetElems abs_ids)
-
-      -- Abstracting over known local functions that aren't floated themselves
-      -- turns a known, fast call into an unknown, slow call:
-      --
-      --    let f x = ...
-      --        g y = ... f x ... -- this was a known call
-      --    in g 4
-      --
-      -- After lifting @g@, but not @f@:
-      --
-      --    l_g f y = ... f y ... -- this is now an unknown call
-      --    let f x = ...
-      --    in l_g f 4
-      --
-      -- We can abuse the results of arity analysis for this:
-      -- idArity f > 0 ==> known
-      known_fun id = idArity id > 0
-      abstracts_known_local_fun
-        = not (c_liftLamsKnown cfg) && any known_fun (dVarSetElems abs_ids)
-
-      -- Number of arguments of a RHS in the current binding group if we decide
-      -- to lift it
-      n_args
-        = length
-        . StgToCmm.Closure.nonVoidIds -- void parameters don't appear in Cmm
-        . (dVarSetElems abs_ids ++)
-        . rhsLambdaBndrs
-      max_n_args
-        | isRec rec_flag = c_liftLamsRecArgs cfg
-        | otherwise      = c_liftLamsNonRecArgs cfg
-      -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess
-      -- args are passed on the stack, which means slow memory accesses
-      args_spill_on_stack
-        | Just n <- max_n_args = maximum (map n_args rhss) > n
-        | otherwise = False
-
-      -- We only perform the lift if allocations didn't increase.
-      -- Note that @clo_growth@ will be 'infinity' if there was positive growth
-      -- under a multi-shot lambda.
-      -- Also, abstracting over LNEs is unacceptable. LNEs might return
-      -- unlifted tuples, which idClosureFootprint can't cope with.
-      inc_allocs = abstracts_join_ids || allocs > 0
-      allocs = clo_growth + mkIntWithInf (negate closuresSize)
-      -- We calculate and then add up the size of each binding's closure.
-      -- GHC does not currently share closure environments, and we either lift
-      -- the entire recursive binding group or none of it.
-      closuresSize = sum $ flip map rhss $ \rhs ->
-        closureSize profile
-        . dVarSetElems
-        . expander
-        . flip dVarSetMinusVarSet bndrs_set
-        $ freeVarsOfRhs rhs
-      clo_growth = closureGrowth expander (idClosureFootprint platform) bndrs_set abs_ids scope
-
-rhsLambdaBndrs :: LlStgRhs -> [Id]
-rhsLambdaBndrs StgRhsCon{} = []
-rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _) = map binderInfoBndr bndrs
-
--- | The size in words of a function closure closing over the given 'Id's,
--- including the header.
-closureSize :: Profile -> [Id] -> WordOff
-closureSize profile ids = words + pc_STD_HDR_SIZE (platformConstants (profilePlatform profile))
-  -- We go through sTD_HDR_SIZE rather than fixedHdrSizeW so that we don't
-  -- optimise differently when profiling is enabled.
-  where
-    (words, _, _)
-      -- Functions have a StdHeader (as opposed to ThunkHeader).
-      = StgToCmm.Layout.mkVirtHeapOffsets profile StgToCmm.Layout.StdHeader
-      . StgToCmm.Closure.addIdReps
-      . StgToCmm.Closure.nonVoidIds
-      $ ids
-
--- | The number of words a single 'Id' adds to a closure's size.
--- Note that this can't handle unboxed tuples (which may still be present in
--- let-no-escapes, even after Unarise), in which case
--- @'GHC.StgToCmm.Closure.idPrimRep'@ will crash.
-idClosureFootprint:: Platform -> Id -> WordOff
-idClosureFootprint platform
-  = StgToCmm.ArgRep.argRepSizeW platform
-  . StgToCmm.ArgRep.idArgRep platform
-
--- | @closureGrowth expander sizer f fvs@ computes the closure growth in words
--- as a result of lifting @f@ to top-level. If there was any growing closure
--- under a multi-shot lambda, the result will be 'infinity'.
--- Also see "GHC.Stg.Lift.Analysis#clogro".
-closureGrowth
-  :: (DIdSet -> DIdSet)
-  -- ^ Expands outer free ids that were lifted to their free vars
-  -> (Id -> Int)
-  -- ^ Computes the closure footprint of an identifier
-  -> IdSet
-  -- ^ Binding group for which lifting is to be decided
-  -> DIdSet
-  -- ^ Free vars of the whole binding group prior to lifting it. These must be
-  --   available at call sites if we decide to lift the binding group.
-  -> Skeleton
-  -- ^ Abstraction of the scope of the function
-  -> IntWithInf
-  -- ^ Closure growth. 'infinity' indicates there was growth under a
-  --   (multi-shot) lambda.
-closureGrowth expander sizer group abs_ids = go
-  where
-    go NilSk = 0
-    go (BothSk a b) = go a + go b
-    go (AltSk a b) = max (go a) (go b)
-    go (ClosureSk _ clo_fvs rhs)
-      -- If no binder of the @group@ occurs free in the closure, the lifting
-      -- won't have any effect on it and we can omit the recursive call.
-      | n_occs == 0 = 0
-      -- Otherwise, we account the cost of allocating the closure and add it to
-      -- the closure growth of its RHS.
-      | otherwise   = mkIntWithInf cost + go rhs
-      where
-        n_occs = sizeDVarSet (clo_fvs' `dVarSetIntersectVarSet` group)
-        -- What we close over considering prior lifting decisions
-        clo_fvs' = expander clo_fvs
-        -- Variables that would additionally occur free in the closure body if
-        -- we lift @f@
-        newbies = abs_ids `minusDVarSet` clo_fvs'
-        -- Lifting @f@ removes @f@ from the closure but adds all @newbies@
-        cost = nonDetStrictFoldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs
-        -- Using a non-deterministic fold is OK here because addition is commutative.
-    go (RhsSk n body)
-      -- The conservative assumption would be that
-      --   1. Every RHS with positive growth would be called multiple times,
-      --      modulo thunks.
-      --   2. Every RHS with negative growth wouldn't be called at all.
-      --
-      -- In the first case, we'd have to return 'infinity', while in the
-      -- second case, we'd have to return 0. But we can do far better
-      -- considering information from the demand analyser, which provides us
-      -- with conservative estimates on minimum and maximum evaluation
-      -- cardinality. The @body_dmd@ part of 'RhsSk' is the result of
-      -- 'rhsCard' and accurately captures the cardinality of the RHSs body
-      -- relative to its defining context.
-      | isAbs n      = 0
-      | cg <= 0      = if isStrict n then cg else 0
-      | isUsedOnce n = cg
-      | otherwise    = infinity
-      where
-        cg = go body
diff --git a/compiler/GHC/Stg/Lift/Config.hs b/compiler/GHC/Stg/Lift/Config.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/Lift/Config.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-
--- | Configuration options for Lift the lambda lifter.
-module GHC.Stg.Lift.Config (
-    StgLiftConfig (..),
-  ) where
-
-import GHC.Prelude
-
-import GHC.Platform.Profile
-
-data StgLiftConfig = StgLiftConfig
-  { c_targetProfile         :: !Profile
-  , c_liftLamsRecArgs       :: !(Maybe Int)
-  -- ^ Maximum number of arguments after lambda lifting a recursive function.
-  , c_liftLamsNonRecArgs    :: !(Maybe Int)
-  -- ^ Maximum number of arguments after lambda lifting non-recursive function.
-  , c_liftLamsKnown         :: !Bool
-  -- ^ Lambda lift even when this turns a known call into an unknown call.
-  }
-  deriving (Show, Read, Eq, Ord)
diff --git a/compiler/GHC/Stg/Lift/Monad.hs b/compiler/GHC/Stg/Lift/Monad.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/Lift/Monad.hs
+++ /dev/null
@@ -1,334 +0,0 @@
-
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TypeFamilies #-}
-
--- | Hides away distracting bookkeeping while lambda lifting into a 'LiftM'
--- monad.
-module GHC.Stg.Lift.Monad (
-    decomposeStgBinding, mkStgBinding,
-    Env (..),
-    -- * #floats# Handling floats
-    -- $floats
-    FloatLang (..), collectFloats, -- Exported just for the docs
-    -- * Transformation monad
-    LiftM, runLiftM,
-    -- ** Get config
-    getConfig,
-    -- ** Adding bindings
-    startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding,
-    -- ** Substitution and binders
-    withSubstBndr, withSubstBndrs, withLiftedBndr, withLiftedBndrs,
-    -- ** Occurrences
-    substOcc, isLifted, formerFreeVars, liftedIdsExpander
-  ) where
-
-import GHC.Prelude
-
-import GHC.Types.Basic
-import GHC.Types.CostCentre ( isCurrentCCS, dontCareCCS )
-import GHC.Data.FastString
-import GHC.Types.Id
-import GHC.Types.Name
-import GHC.Utils.Outputable
-import GHC.Data.OrdList
-
-import GHC.Stg.Lift.Config
-import GHC.Stg.Subst
-import GHC.Stg.Syntax
-
-import GHC.Core.Utils
-import GHC.Types.Unique.Supply
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
-import GHC.Core.Multiplicity
-
-import Control.Arrow ( second )
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.RWS.Strict ( RWST, runRWST )
-import qualified Control.Monad.Trans.RWS.Strict as RWS
-import Control.Monad.Trans.Cont ( ContT (..) )
-import Data.ByteString ( ByteString )
-
--- | @uncurry 'mkStgBinding' . 'decomposeStgBinding' = id@
-decomposeStgBinding :: GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)])
-decomposeStgBinding (StgRec pairs) = (Recursive, pairs)
-decomposeStgBinding (StgNonRec bndr rhs) = (NonRecursive, [(bndr, rhs)])
-
-mkStgBinding :: RecFlag -> [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
-mkStgBinding Recursive = StgRec
-mkStgBinding NonRecursive = uncurry StgNonRec . head
-
--- | Environment threaded around in a scoped, @Reader@-like fashion.
-data Env
-  = Env
-  { e_config     :: StgLiftConfig
-  -- ^ Read-only.
-  , e_subst      :: !Subst
-  -- ^ We need to track the renamings of local 'InId's to their lifted 'OutId',
-  -- because shadowing might make a closure's free variables unavailable at its
-  -- call sites. Consider:
-  -- @
-  --    let f y = x + y in let x = 4 in f x
-  -- @
-  -- Here, @f@ can't be lifted to top-level, because its free variable @x@ isn't
-  -- available at its call site.
-  , e_expansions :: !(IdEnv DIdSet)
-  -- ^ Lifted 'Id's don't occur as free variables in any closure anymore, because
-  -- they are bound at the top-level. Every occurrence must supply the formerly
-  -- free variables of the lifted 'Id', so they in turn become free variables of
-  -- the call sites. This environment tracks this expansion from lifted 'Id's to
-  -- their free variables.
-  --
-  -- 'InId's to 'OutId's.
-  --
-  -- Invariant: 'Id's not present in this map won't be substituted.
-  }
-
-emptyEnv :: StgLiftConfig -> Env
-emptyEnv cfg = Env
-  { e_config = cfg
-  , e_subst = emptySubst
-  , e_expansions = emptyVarEnv
-  }
-
-
--- Note [Handling floats]
--- ~~~~~~~~~~~~~~~~~~~~~~
--- $floats
--- Consider the following expression:
---
--- @
---     f x =
---       let g y = ... f y ...
---       in g x
--- @
---
--- What happens when we want to lift @g@? Normally, we'd put the lifted @l_g@
--- binding above the binding for @f@:
---
--- @
---     g f y = ... f y ...
---     f x = g f x
--- @
---
--- But this very unnecessarily turns a known call to @f@ into an unknown one, in
--- addition to complicating matters for the analysis.
--- Instead, we'd really like to put both functions in the same recursive group,
--- thereby preserving the known call:
---
--- @
---     Rec {
---       g y = ... f y ...
---       f x = g x
---     }
--- @
---
--- But we don't want this to happen for just /any/ binding. That would create
--- possibly huge recursive groups in the process, calling for an occurrence
--- analyser on STG.
--- So, we need to track when we lift a binding out of a recursive RHS and add
--- the binding to the same recursive group as the enclosing recursive binding
--- (which must have either already been at the top-level or decided to be
--- lifted itself in order to preserve the known call).
---
--- This is done by expressing this kind of nesting structure as a 'Writer' over
--- @['FloatLang']@ and flattening this expression in 'runLiftM' by a call to
--- 'collectFloats'.
--- API-wise, the analysis will not need to know about the whole 'FloatLang'
--- business and will just manipulate it indirectly through actions in 'LiftM'.
-
--- | We need to detect when we are lifting something out of the RHS of a
--- recursive binding (c.f. "GHC.Stg.Lift.Monad#floats"), in which case that
--- binding needs to be added to the same top-level recursive group. This
--- requires we detect a certain nesting structure, which is encoded by
--- 'StartBindingGroup' and 'EndBindingGroup'.
---
--- Although 'collectFloats' will only ever care if the current binding to be
--- lifted (through 'LiftedBinding') will occur inside such a binding group or
--- not, e.g. doesn't care about the nesting level as long as its greater than 0.
-data FloatLang
-  = StartBindingGroup
-  | EndBindingGroup
-  | PlainTopBinding OutStgTopBinding
-  | LiftedBinding OutStgBinding
-
-instance Outputable FloatLang where
-  ppr StartBindingGroup = char '('
-  ppr EndBindingGroup = char ')'
-  ppr (PlainTopBinding StgTopStringLit{}) = text "<str>"
-  ppr (PlainTopBinding (StgTopLifted b)) = ppr (LiftedBinding b)
-  ppr (LiftedBinding bind) = (if isRec rec then char 'r' else char 'n') <+> ppr (map fst pairs)
-    where
-      (rec, pairs) = decomposeStgBinding bind
-
--- | Flattens an expression in @['FloatLang']@ into an STG program, see "GHC.Stg.Lift.Monad#floats".
--- Important pre-conditions: The nesting of opening 'StartBindinGroup's and
--- closing 'EndBindinGroup's is balanced. Also, it is crucial that every binding
--- group has at least one recursive binding inside. Otherwise there's no point
--- in announcing the binding group in the first place and an @ASSERT@ will
--- trigger.
-collectFloats :: [FloatLang] -> [OutStgTopBinding]
-collectFloats = go (0 :: Int) []
-  where
-    go 0 [] [] = []
-    go _ _ [] = pprPanic "collectFloats" (text "unterminated group")
-    go n binds (f:rest) = case f of
-      StartBindingGroup -> go (n+1) binds rest
-      EndBindingGroup
-        | n == 0 -> pprPanic "collectFloats" (text "no group to end")
-        | n == 1 -> StgTopLifted (merge_binds binds) : go 0 [] rest
-        | otherwise -> go (n-1) binds rest
-      PlainTopBinding top_bind
-        | n == 0 -> top_bind : go n binds rest
-        | otherwise -> pprPanic "collectFloats" (text "plain top binding inside group")
-      LiftedBinding bind
-        | n == 0 -> StgTopLifted (rm_cccs bind) : go n binds rest
-        | otherwise -> go n (bind:binds) rest
-
-    map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding
-    rm_cccs = map_rhss removeRhsCCCS
-    merge_binds binds = assert (any is_rec binds) $
-                        StgRec (concatMap (snd . decomposeStgBinding . rm_cccs) binds)
-    is_rec StgRec{} = True
-    is_rec _ = False
-
--- | Omitting this makes for strange closure allocation schemes that crash the
--- GC.
-removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass
-removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body)
-  | isCurrentCCS ccs
-  = StgRhsClosure ext dontCareCCS upd bndrs body
-removeRhsCCCS (StgRhsCon ccs con mu ts args)
-  | isCurrentCCS ccs
-  = StgRhsCon dontCareCCS con mu ts args
-removeRhsCCCS rhs = rhs
-
--- | The analysis monad consists of the following 'RWST' components:
---
---     * 'Env': Reader-like context. Contains a substitution, info about how
---       how lifted identifiers are to be expanded into applications and
---       configuration options.
---
---     * @'OrdList' 'FloatLang'@: Writer output for the resulting STG program.
---
---     * No pure state component
---
---     * But wrapping around 'UniqSM' for generating fresh lifted binders.
---       (The @uniqAway@ approach could give the same name to two different
---       lifted binders, so this is necessary.)
-newtype LiftM a
-  = LiftM { unwrapLiftM :: RWST Env (OrdList FloatLang) () UniqSM a }
-  deriving (Functor, Applicative, Monad)
-
-instance MonadUnique LiftM where
-  getUniqueSupplyM = LiftM (lift getUniqueSupplyM)
-  getUniqueM = LiftM (lift getUniqueM)
-  getUniquesM = LiftM (lift getUniquesM)
-
-runLiftM :: StgLiftConfig -> UniqSupply -> LiftM () -> [OutStgTopBinding]
-runLiftM cfg us (LiftM m) = collectFloats (fromOL floats)
-  where
-    (_, _, floats) = initUs_ us (runRWST m (emptyEnv cfg) ())
-
-getConfig :: LiftM StgLiftConfig
-getConfig = LiftM $ e_config <$> RWS.ask
-
--- | Writes a plain 'StgTopStringLit' to the output.
-addTopStringLit :: OutId -> ByteString -> LiftM ()
-addTopStringLit id = LiftM . RWS.tell . unitOL . PlainTopBinding . StgTopStringLit id
-
--- | Starts a recursive binding group. See "GHC.Stg.Lift.Monad#floats" and 'collectFloats'.
-startBindingGroup :: LiftM ()
-startBindingGroup = LiftM $ RWS.tell $ unitOL $ StartBindingGroup
-
--- | Ends a recursive binding group. See "GHC.Stg.Lift.Monad#floats" and 'collectFloats'.
-endBindingGroup :: LiftM ()
-endBindingGroup = LiftM $ RWS.tell $ unitOL $ EndBindingGroup
-
--- | Lifts a binding to top-level. Depending on whether it's declared inside
--- a recursive RHS (see "GHC.Stg.Lift.Monad#floats" and 'collectFloats'), this might be added to
--- an existing recursive top-level binding group.
-addLiftedBinding :: OutStgBinding -> LiftM ()
-addLiftedBinding = LiftM . RWS.tell . unitOL . LiftedBinding
-
--- | Takes a binder and a continuation which is called with the substituted
--- binder. The continuation will be evaluated in a 'LiftM' context in which that
--- binder is deemed in scope. Think of it as a 'RWS.local' computation: After
--- the continuation finishes, the new binding won't be in scope anymore.
-withSubstBndr :: Id -> (Id -> LiftM a) -> LiftM a
-withSubstBndr bndr inner = LiftM $ do
-  subst <- RWS.asks e_subst
-  let (bndr', subst') = substBndr bndr subst
-  RWS.local (\e -> e { e_subst = subst' }) (unwrapLiftM (inner bndr'))
-
--- | See 'withSubstBndr'.
-withSubstBndrs :: Traversable f => f Id -> (f Id -> LiftM a) -> LiftM a
-withSubstBndrs = runContT . traverse (ContT . withSubstBndr)
-
--- | Similarly to 'withSubstBndr', this function takes a set of variables to
--- abstract over, the binder to lift (and generate a fresh, substituted name
--- for) and a continuation in which that fresh, lifted binder is in scope.
---
--- It takes care of all the details involved with copying and adjusting the
--- binder and fresh name generation.
-withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a
-withLiftedBndr abs_ids bndr inner = do
-  uniq <- getUniqueM
-  let str = fsLit "$l" `appendFS` occNameFS (getOccName bndr)
-  let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr)
-  let bndr'
-        -- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least
-        -- for arity information.
-        = transferPolyIdInfo bndr (dVarSetElems abs_ids)
-        . mkSysLocal str uniq ManyTy
-        $ ty
-  LiftM $ RWS.local
-    (\e -> e
-      { e_subst = extendSubst bndr bndr' $ extendInScope bndr' $ e_subst e
-      , e_expansions = extendVarEnv (e_expansions e) bndr abs_ids
-      })
-    (unwrapLiftM (inner bndr'))
-
--- | See 'withLiftedBndr'.
-withLiftedBndrs :: Traversable f => DIdSet -> f Id -> (f Id -> LiftM a) -> LiftM a
-withLiftedBndrs abs_ids = runContT . traverse (ContT . withLiftedBndr abs_ids)
-
--- | Substitutes a binder /occurrence/, which was brought in scope earlier by
--- 'withSubstBndr' \/ 'withLiftedBndr'.
-substOcc :: Id -> LiftM Id
-substOcc id = LiftM (RWS.asks (lookupIdSubst id . e_subst))
-
--- | Whether the given binding was decided to be lambda lifted.
-isLifted :: InId -> LiftM Bool
-isLifted bndr = LiftM (RWS.asks (elemVarEnv bndr . e_expansions))
-
--- | Returns an empty list for a binding that was not lifted and the list of all
--- local variables the binding abstracts over (so, exactly the additional
--- arguments at adjusted call sites) otherwise.
-formerFreeVars :: InId -> LiftM [OutId]
-formerFreeVars f = LiftM $ do
-  expansions <- RWS.asks e_expansions
-  pure $ case lookupVarEnv expansions f of
-    Nothing -> []
-    Just fvs -> dVarSetElems fvs
-
--- | Creates an /expander function/ for the current set of lifted binders.
--- This expander function will replace any 'InId' by their corresponding 'OutId'
--- and, in addition, will expand any lifted binders by the former free variables
--- it abstracts over.
-liftedIdsExpander :: LiftM (DIdSet -> DIdSet)
-liftedIdsExpander = LiftM $ do
-  expansions <- RWS.asks e_expansions
-  subst <- RWS.asks e_subst
-  -- We use @noWarnLookupIdSubst@ here in order to suppress "not in scope"
-  -- warnings generated by 'lookupIdSubst' due to local bindings within RHS.
-  -- These are not in the InScopeSet of @subst@ and extending the InScopeSet in
-  -- @goodToLift@/@closureGrowth@ before passing it on to @expander@ is too much
-  -- trouble.
-  let go set fv = case lookupVarEnv expansions fv of
-        Nothing -> extendDVarSet set (noWarnLookupIdSubst fv subst) -- Not lifted
-        Just fvs' -> unionDVarSet set fvs'
-  let expander fvs = foldl' go emptyDVarSet (dVarSetElems fvs)
-  pure expander
diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/Lint.hs
+++ /dev/null
@@ -1,576 +0,0 @@
-{- |
-(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-
-A lint pass to check basic STG invariants:
-
-- Variables should be defined before used.
-
-- Let bindings should not have unboxed types (unboxed bindings should only
-  appear in case), except when they're join points (see Note [Core let-can-float
-  invariant] and #14117).
-
-- If linting after unarisation, invariants listed in Note [Post-unarisation
-  invariants].
-
-Because we don't have types and coercions in STG we can't really check types
-here.
-
-Some history:
-
-StgLint used to check types, but it never worked and so it was disabled in 2000
-with this note:
-
-    WARNING:
-    ~~~~~~~~
-
-    This module has suffered bit-rot; it is likely to yield lint errors
-    for Stg code that is currently perfectly acceptable for code
-    generation.  Solution: don't use it!  (KSW 2000-05).
-
-Since then there were some attempts at enabling it again, as summarised in #14787.
-It's finally decided that we remove all type checking and only look for
-basic properties listed above.
-
-Note [Linting StgApp]
-~~~~~~~~~~~~~~~~~~~~~
-To lint an application of the form `f a_1 ... a_n`, we check that
-the representations of the arguments `a_1`, ..., `a_n` match those
-that the function expects.
-
-More precisely, suppose the types in the application `f a_1 ... a_n`
-are as follows:
-
-  f :: t_1 -> ... -> t_n -> res
-  a_1 :: s_1, ..., a_n :: s_n
-
-  t_1 :: TYPE r_1, ..., t_n :: TYPE r_n
-  s_1 :: TYPE p_1, ..., a_n :: TYPE p_n
-
-Before unarisation, we must check that each r_i is compatible with s_i.
-Compatibility is weaker than on-the-nose equality: for example,
-IntRep and WordRep are compatible. See Note [Bad unsafe coercion] in GHC.Core.Lint.
-
-After unarisation, a single type might correspond to multiple arguments, e.g.
-
-  (# Int# | Bool #) :: TYPE (SumRep '[ IntRep, LiftedRep ])
-
-will result in two arguments: [Int# :: TYPE 'IntRep, Bool :: TYPE LiftedRep]
-This means post unarise we potentially have to match up multiple arguments with
-the reps of a single argument in the type's definition, because the type of the function
-is *not* in unarised form.
-
-Wrinkle: it can sometimes happen that an argument type in the type of
-the function does not have a fixed runtime representation, i.e.
-there is an r_i such that runtimeRepPrimRep r_i crashes.
-See https://gitlab.haskell.org/ghc/ghc/-/issues/21399 for an example.
-Fixing this issue would require significant changes to the type system
-of STG, so for now we simply skip the Lint check when we detect such
-representation-polymorphic situations.
-
-Note [Typing the STG language]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In Core, programs must be /well-typed/.  So if f :: ty1 -> ty2,
-then in the application (f e), we must have  e :: ty1
-
-STG is still a statically typed language, but the type system
-is much coarser. In particular, STG programs must be /well-kinded/.
-More precisely, if f :: ty1 -> ty2, then in the application (f e)
-where e :: ty1', we must have kind(ty1) = kind(ty1').
-
-So the STG type system does not distinguish between Int and Bool,
-but it /does/ distinguish between Int and Int#, because they have
-different kinds.  Actually, since all terms have kind (TYPE rep),
-we might say that the STG language is well-runtime-rep'd.
-
-This coarser type system makes fewer distinctions, and that allows
-many nonsensical programs (such as ('x' && "foo")) -- but all type
-systems accept buggy programs!  But the coarseness also permits
-some optimisations that are ill-typed in Core.  For example, see
-the module STG.CSE, which is all about doing CSE in STG that would
-be ill-typed in Core.  But it must still be well-kinded!
-
--}
-
-{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,
-  DeriveFunctor #-}
-
-module GHC.Stg.Lint ( lintStgTopBindings ) where
-
-import GHC.Prelude
-
-import GHC.Stg.Syntax
-import GHC.Stg.Utils
-
-import GHC.Core.DataCon
-import GHC.Core             ( AltCon(..) )
-import GHC.Core.Type
-
-import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel, isMarkedCbv )
-import GHC.Types.CostCentre ( isCurrentCCS )
-import GHC.Types.Error      ( DiagnosticReason(WarningWithoutFlag) )
-import GHC.Types.Id
-import GHC.Types.Var.Set
-import GHC.Types.Name       ( getSrcLoc, nameIsLocalOrFrom )
-import GHC.Types.RepType
-import GHC.Types.SrcLoc
-
-import GHC.Utils.Logger
-import GHC.Utils.Outputable
-import GHC.Utils.Error      ( mkLocMessage, DiagOpts )
-import qualified GHC.Utils.Error as Err
-
-import GHC.Unit.Module            ( Module )
-
-import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
-
-import Control.Monad
-import Data.Maybe
-import GHC.Utils.Misc
-import GHC.Core.Multiplicity (scaledThing)
-import GHC.Settings (Platform)
-import GHC.Core.TyCon (primRepCompatible, primRepsCompatible)
-import GHC.Utils.Panic.Plain (panic)
-
-lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
-                   => Platform
-                   -> Logger
-                   -> DiagOpts
-                   -> StgPprOpts
-                   -> [Var]  -- ^ extra vars in scope from GHCi
-                   -> Module -- ^ module being compiled
-                   -> Bool   -- ^ have we run Unarise yet?
-                   -> String -- ^ who produced the STG?
-                   -> [GenStgTopBinding a]
-                   -> IO ()
-
-lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised whodunit binds
-  = {-# SCC "StgLint" #-}
-    case initL platform diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of
-      Nothing  ->
-        return ()
-      Just msg -> do
-        logMsg logger Err.MCDump noSrcSpan
-          $ withPprStyle defaultDumpStyle
-          (vcat [ text "*** Stg Lint ErrMsgs: in" <+>
-                        text whodunit <+> text "***",
-                  msg,
-                  text "*** Offending Program ***",
-                  pprGenStgTopBindings opts binds,
-                  text "*** End of Offense ***"])
-        Err.ghcExit logger 1
-  where
-    -- Bring all top-level binds into scope because CoreToStg does not generate
-    -- bindings in dependency order (so we may see a use before its definition).
-    top_level_binds = extendVarSetList (mkVarSet (bindersOfTopBinds binds))
-                                       extra_vars
-
-    lint_binds :: [GenStgTopBinding a] -> LintM ()
-
-    lint_binds [] = return ()
-    lint_binds (bind:binds) = do
-        binders <- lint_bind bind
-        addInScopeVars binders $
-            lint_binds binds
-
-    lint_bind (StgTopLifted bind) = lintStgBinds TopLevel bind
-    lint_bind (StgTopStringLit v _) = return [v]
-
-lintStgArg :: StgArg -> LintM ()
-lintStgArg (StgLitArg _) = return ()
-lintStgArg (StgVarArg v) = lintStgVar v
-
-lintStgVar :: Id -> LintM ()
-lintStgVar id = checkInScope id
-
-lintStgBinds
-    :: (OutputablePass a, BinderP a ~ Id)
-    => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders
-lintStgBinds top_lvl (StgNonRec binder rhs) = do
-    lint_binds_help top_lvl (binder,rhs)
-    return [binder]
-
-lintStgBinds top_lvl (StgRec pairs)
-  = addInScopeVars binders $ do
-        mapM_ (lint_binds_help top_lvl) pairs
-        return binders
-  where
-    binders = [b | (b,_) <- pairs]
-
-lint_binds_help
-    :: (OutputablePass a, BinderP a ~ Id)
-    => TopLevelFlag
-    -> (Id, GenStgRhs a)
-    -> LintM ()
-lint_binds_help top_lvl (binder, rhs)
-  = addLoc (RhsOf binder) $ do
-        when (isTopLevel top_lvl) (checkNoCurrentCCS rhs)
-        lintStgRhs rhs
-        opts <- getStgPprOpts
-        -- Check binder doesn't have unlifted type or it's a join point
-        checkL ( isJoinId binder
-              || not (isUnliftedType (idType binder))
-              || isDataConWorkId binder || isDataConWrapId binder) -- until #17521 is fixed
-          (mkUnliftedTyMsg opts binder rhs)
-
--- | Top-level bindings can't inherit the cost centre stack from their
--- (static) allocation site.
-checkNoCurrentCCS
-    :: (OutputablePass a, BinderP a ~ Id)
-    => GenStgRhs a
-    -> LintM ()
-checkNoCurrentCCS rhs = do
-   opts <- getStgPprOpts
-   let rhs' = pprStgRhs opts rhs
-   case rhs of
-      StgRhsClosure _ ccs _ _ _
-         | isCurrentCCS ccs
-         -> addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ rhs')
-      StgRhsCon ccs _ _ _ _
-         | isCurrentCCS ccs
-         -> addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ rhs')
-      _ -> return ()
-
-lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()
-
-lintStgRhs (StgRhsClosure _ _ _ [] expr)
-  = lintStgExpr expr
-
-lintStgRhs (StgRhsClosure _ _ _ binders expr)
-  = addLoc (LambdaBodyOf binders) $
-      addInScopeVars binders $
-        lintStgExpr expr
-
-lintStgRhs rhs@(StgRhsCon _ con _ _ args) = do
-    opts <- getStgPprOpts
-    when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do
-      addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
-               pprStgRhs opts rhs)
-
-    lintConApp con args (pprStgRhs opts rhs)
-
-    mapM_ lintStgArg args
-    mapM_ checkPostUnariseConArg args
-
-lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()
-
-lintStgExpr (StgLit _) = return ()
-
-lintStgExpr e@(StgApp fun args) = do
-  lintStgVar fun
-  mapM_ lintStgArg args
-  lintAppCbvMarks e
-  lintStgAppReps fun args
-
-
-
-lintStgExpr app@(StgConApp con _n args _arg_tys) = do
-    -- unboxed sums should vanish during unarise
-    lf <- getLintFlags
-    let !unarised = lf_unarised lf
-    when (unarised && isUnboxedSumDataCon con) $ do
-      opts <- getStgPprOpts
-      addErrL (text "Unboxed sum after unarise:" $$
-               pprStgExpr opts app)
-
-    opts <- getStgPprOpts
-    lintConApp con args (pprStgExpr opts app)
-
-    mapM_ lintStgArg args
-    mapM_ checkPostUnariseConArg args
-
-lintStgExpr (StgOpApp _ args _) =
-    mapM_ lintStgArg args
-
-lintStgExpr (StgLet _ binds body) = do
-    binders <- lintStgBinds NotTopLevel binds
-    addLoc (BodyOfLetRec binders) $
-      addInScopeVars binders $
-        lintStgExpr body
-
-lintStgExpr (StgLetNoEscape _ binds body) = do
-    binders <- lintStgBinds NotTopLevel binds
-    addLoc (BodyOfLetRec binders) $
-      addInScopeVars binders $
-        lintStgExpr body
-
-lintStgExpr (StgTick _ expr) = lintStgExpr expr
-
-lintStgExpr (StgCase scrut bndr alts_type alts) = do
-    lintStgExpr scrut
-
-    lf <- getLintFlags
-    let in_scope = stgCaseBndrInScope alts_type (lf_unarised lf)
-
-    addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts)
-
-lintAlt
-    :: (OutputablePass a, BinderP a ~ Id)
-    => GenStgAlt a -> LintM ()
-
-lintAlt GenStgAlt{ alt_con   = DEFAULT
-                 , alt_bndrs = _
-                 , alt_rhs   = rhs} = lintStgExpr rhs
-
-lintAlt GenStgAlt{ alt_con   = LitAlt _
-                 , alt_bndrs = _
-                 , alt_rhs   = rhs} = lintStgExpr rhs
-
-lintAlt GenStgAlt{ alt_con   = DataAlt _
-                 , alt_bndrs = bndrs
-                 , alt_rhs   = rhs} =
-  do
-    mapM_ checkPostUnariseBndr bndrs
-    addInScopeVars bndrs (lintStgExpr rhs)
-
--- Post unarise check we apply constructors to the right number of args.
--- This can be violated by invalid use of unsafeCoerce as showcased by test
--- T9208
-lintConApp :: Foldable t => DataCon -> t a -> SDoc -> LintM ()
-lintConApp con args app = do
-    unarised <- lf_unarised <$> getLintFlags
-    when (unarised &&
-          not (isUnboxedTupleDataCon con) &&
-          length (dataConRuntimeRepStrictness con) /= length args) $ do
-      addErrL (text "Constructor applied to incorrect number of arguments:" $$
-               text "Application:" <> app)
-
--- See Note [Linting StgApp]
--- See Note [Typing the STG language]
-lintStgAppReps :: Id -> [StgArg] -> LintM ()
-lintStgAppReps _fun [] = return ()
-lintStgAppReps fun args = do
-  lf <- getLintFlags
-  let platform = lf_platform lf
-
-      (fun_arg_tys, _res) = splitFunTys (idType fun)
-      fun_arg_tys' = map scaledThing fun_arg_tys :: [Type]
-
-      -- Might be "wrongly" typed as polymorphic. See #21399
-      -- In these cases typePrimRep_maybe will return Nothing
-      -- and we abort kind checking.
-      fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]]
-      fun_arg_tys_reps = map typePrimRep_maybe fun_arg_tys'
-      actual_arg_reps = map (typePrimRep_maybe . stgArgType) args
-
-      match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()
-      match_args (Nothing:_) _   = return ()
-      match_args (_) (Nothing:_) = return ()
-      match_args (Just actual_rep:actual_reps_left) (Just expected_rep:expected_reps_left)
-        -- Common case, reps are exactly the same
-        | actual_rep == expected_rep
-        = match_args actual_reps_left expected_reps_left
-
-        -- Check for void rep which can be either an empty list *or* [VoidRep]
-        | isVoidRep actual_rep && isVoidRep expected_rep
-        = match_args actual_reps_left expected_reps_left
-
-        -- Some reps are compatible *even* if they are not the same. E.g. IntRep and WordRep.
-        -- We check for that here with primRepCompatible
-        | primRepsCompatible platform actual_rep expected_rep
-        = match_args actual_reps_left expected_reps_left
-
-        -- We might distribute args from within one unboxed sum over multiple
-        -- single rep args. This means we might need to match up things like:
-        -- [Just [WordRep, LiftedRep]] with [Just [WordRep],Just [LiftedRep]]
-        -- which happens here.
-        -- See Note [Linting StgApp].
-        | Just (actual,actuals) <- getOneRep actual_rep actual_reps_left
-        , Just (expected,expecteds) <- getOneRep expected_rep expected_reps_left
-        , primRepCompatible platform actual expected
-        = match_args actuals expecteds
-
-        | otherwise = addErrL $ hang (text "Function type reps and function argument reps mismatched") 2 $
-            (text "In application " <> ppr fun <+> ppr args $$
-              text "argument rep:" <> ppr actual_arg_reps $$
-              text "expected rep:" <> ppr fun_arg_tys_reps $$
-              -- text "expected reps:" <> ppr arg_ty_reps $$
-              text "unarised?:" <> ppr (lf_unarised lf))
-        where
-          isVoidRep [] = True
-          isVoidRep [VoidRep] = True
-          isVoidRep _ = False
-          -- Try to strip one non-void arg rep from the current argument type returning
-          -- the remaining list of arguments. We return Nothing for invalid input which
-          -- will result in a lint failure in match_args.
-          getOneRep :: [PrimRep] -> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])
-          getOneRep [] _rest = Nothing -- Void rep args are invalid at this point.
-          getOneRep [rep] rest = Just (rep,rest) -- A single arg rep arg
-          getOneRep (rep:reps) rest = Just (rep,Just reps:rest) -- Multi rep arg.
-
-      match_args _ _ = return () -- Functions are allowed to be over/under applied.
-
-  match_args actual_arg_reps fun_arg_tys_reps
-
-lintAppCbvMarks :: OutputablePass pass
-                => GenStgExpr pass -> LintM ()
-lintAppCbvMarks e@(StgApp fun args) = do
-  lf <- getLintFlags
-  when (lf_unarised lf) $ do
-    -- A function which expects a unlifted argument as n'th argument
-    -- always needs to be applied to n arguments.
-    -- See Note [CBV Function Ids].
-    let marks = fromMaybe [] $ idCbvMarks_maybe fun
-    when (length (dropWhileEndLE (not . isMarkedCbv) marks) > length args) $ do
-      addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr e ) 2 $
-        (text "marks" <> ppr marks $$
-        text "args" <> ppr args $$
-        text "arity" <> ppr (idArity fun) $$
-        text "join_arity" <> ppr (isJoinId_maybe fun))
-lintAppCbvMarks _ = panic "impossible - lintAppCbvMarks"
-
-{-
-************************************************************************
-*                                                                      *
-The Lint monad
-*                                                                      *
-************************************************************************
--}
-
-newtype LintM a = LintM
-    { unLintM :: Module
-              -> LintFlags
-              -> DiagOpts          -- Diagnostic options
-              -> StgPprOpts        -- Pretty-printing options
-              -> [LintLocInfo]     -- Locations
-              -> IdSet             -- Local vars in scope
-              -> Bag SDoc        -- Error messages so far
-              -> (a, Bag SDoc)   -- Result and error messages (if any)
-    }
-    deriving (Functor)
-
-data LintFlags = LintFlags { lf_unarised :: !Bool
-                           , lf_platform :: !Platform
-                             -- ^ have we run the unariser yet?
-                           }
-
-data LintLocInfo
-  = RhsOf Id            -- The variable bound
-  | LambdaBodyOf [Id]   -- The lambda-binder
-  | BodyOfLetRec [Id]   -- One of the binders
-
-dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
-dumpLoc (RhsOf v) =
-  (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' )
-dumpLoc (LambdaBodyOf bs) =
-  (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' )
-
-dumpLoc (BodyOfLetRec bs) =
-  (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' )
-
-
-pp_binders :: [Id] -> SDoc
-pp_binders bs
-  = sep (punctuate comma (map pp_binder bs))
-  where
-    pp_binder b
-      = hsep [ppr b, dcolon, ppr (idType b)]
-
-initL :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc
-initL platform diag_opts this_mod unarised opts locals (LintM m) = do
-  let (_, errs) = m this_mod (LintFlags unarised platform) diag_opts opts [] locals emptyBag
-  if isEmptyBag errs then
-      Nothing
-  else
-      Just (vcat (punctuate blankLine (bagToList errs)))
-
-instance Applicative LintM where
-      pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs)
-      (<*>) = ap
-      (*>)  = thenL_
-
-instance Monad LintM where
-    (>>=) = thenL
-    (>>)  = (*>)
-
-thenL :: LintM a -> (a -> LintM b) -> LintM b
-thenL m k = LintM $ \mod lf diag_opts opts loc scope errs
-  -> case unLintM m mod lf diag_opts opts loc scope errs of
-      (r, errs') -> unLintM (k r) mod lf diag_opts opts loc scope errs'
-
-thenL_ :: LintM a -> LintM b -> LintM b
-thenL_ m k = LintM $ \mod lf diag_opts opts loc scope errs
-  -> case unLintM m mod lf diag_opts opts loc scope errs of
-      (_, errs') -> unLintM k mod lf diag_opts opts loc scope errs'
-
-checkL :: Bool -> SDoc -> LintM ()
-checkL True  _   = return ()
-checkL False msg = addErrL msg
-
--- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders.
-checkPostUnariseBndr :: Id -> LintM ()
-checkPostUnariseBndr bndr = do
-    lf <- getLintFlags
-    when (lf_unarised lf) $
-      forM_ (checkPostUnariseId bndr) $ \unexpected ->
-        addErrL $
-          text "After unarisation, binder " <>
-          ppr bndr <> text " has " <> text unexpected <> text " type " <>
-          ppr (idType bndr)
-
--- Arguments shouldn't have sum, tuple, or void types.
-checkPostUnariseConArg :: StgArg -> LintM ()
-checkPostUnariseConArg arg = case arg of
-    StgLitArg _ ->
-      return ()
-    StgVarArg id -> do
-      lf <- getLintFlags
-      when (lf_unarised lf) $
-        forM_ (checkPostUnariseId id) $ \unexpected ->
-          addErrL $
-            text "After unarisation, arg " <>
-            ppr id <> text " has " <> text unexpected <> text " type " <>
-            ppr (idType id)
-
--- Post-unarisation args and case alt binders should not have unboxed tuple,
--- unboxed sum, or void types. Return what the binder is if it is one of these.
-checkPostUnariseId :: Id -> Maybe String
-checkPostUnariseId id
-  | isUnboxedSumType id_ty   = Just "unboxed sum"
-  | isUnboxedTupleType id_ty = Just "unboxed tuple"
-  | isZeroBitTy id_ty        = Just "void"
-  | otherwise                = Nothing
-  where
-    id_ty = idType id
-
-addErrL :: SDoc -> LintM ()
-addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc)
-
-addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc
-addErr diag_opts errs_so_far msg locs
-  = errs_so_far `snocBag` mk_msg locs
-  where
-    mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
-                     in  mkLocMessage (Err.mkMCDiagnostic diag_opts WarningWithoutFlag Nothing)
-                                      l (hdr $$ msg)
-    mk_msg []      = msg
-
-addLoc :: LintLocInfo -> LintM a -> LintM a
-addLoc extra_loc m = LintM $ \mod lf diag_opts opts loc scope errs
-   -> unLintM m mod lf diag_opts opts (extra_loc:loc) scope errs
-
-addInScopeVars :: [Id] -> LintM a -> LintM a
-addInScopeVars ids m = LintM $ \mod lf diag_opts opts loc scope errs
- -> let
-        new_set = mkVarSet ids
-    in unLintM m mod lf diag_opts opts loc (scope `unionVarSet` new_set) errs
-
-getLintFlags :: LintM LintFlags
-getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs)
-
-getStgPprOpts :: LintM StgPprOpts
-getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs)
-
-checkInScope :: Id -> LintM ()
-checkInScope id = LintM $ \mod _lf diag_opts _opts loc scope errs
- -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
-        ((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id),
-                                    text "is out of scope"]) loc)
-    else
-        ((), errs)
-
-mkUnliftedTyMsg :: OutputablePass a => StgPprOpts -> Id -> GenStgRhs a -> SDoc
-mkUnliftedTyMsg opts binder rhs
-  = (text "Let(rec) binder" <+> quotes (ppr binder) <+>
-     text "has unlifted type" <+> quotes (ppr (idType binder)))
-    $$
-    (text "RHS:" <+> pprStgRhs opts rhs)
diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/Pipeline.hs
+++ /dev/null
@@ -1,171 +0,0 @@
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
-
-\section[SimplStg]{Driver for simplifying @STG@ programs}
--}
-
-
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module GHC.Stg.Pipeline
-  ( StgPipelineOpts (..)
-  , StgToDo (..)
-  , stg2stg
-  , StgCgInfos
-  ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Flags
-
-import GHC.Stg.Syntax
-
-import GHC.Stg.Lint     ( lintStgTopBindings )
-import GHC.Stg.Stats    ( showStgStats )
-import GHC.Stg.FVs      ( depSortWithAnnotStgPgm )
-import GHC.Stg.Unarise  ( unarise )
-import GHC.Stg.BcPrep   ( bcPrep )
-import GHC.Stg.CSE      ( stgCse )
-import GHC.Stg.Lift     ( StgLiftConfig, stgLiftLams )
-import GHC.Unit.Module ( Module )
-
-import GHC.Utils.Error
-import GHC.Types.Var
-import GHC.Types.Unique.Supply
-import GHC.Utils.Outputable
-import GHC.Utils.Logger
-import Control.Monad
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Reader
-import GHC.Settings (Platform)
-import GHC.Stg.InferTags (inferTags)
-import GHC.Types.Name.Env (NameEnv)
-import GHC.Stg.InferTags.TagSig (TagSig)
-
-data StgPipelineOpts = StgPipelineOpts
-  { stgPipeline_phases      :: ![StgToDo]
-  -- ^ Spec of what stg-to-stg passes to do
-  , stgPipeline_lint        :: !(Maybe DiagOpts)
-  -- ^ Should we lint the STG at various stages of the pipeline?
-  , stgPipeline_pprOpts     :: !StgPprOpts
-  , stgPlatform             :: !Platform
-  }
-
-newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
-  deriving (Functor, Applicative, Monad, MonadIO)
-
--- | Information to be exposed in interface files which is produced
--- by the stg2stg passes.
-type StgCgInfos = NameEnv TagSig
-
-instance MonadUnique StgM where
-  getUniqueSupplyM = StgM $ do { mask <- ask
-                               ; liftIO $! mkSplitUniqSupply mask}
-  getUniqueM = StgM $ do { mask <- ask
-                         ; liftIO $! uniqFromMask mask}
-
-runStgM :: Char -> StgM a -> IO a
-runStgM mask (StgM m) = runReaderT m mask
-
-stg2stg :: Logger
-        -> [Var]                     -- ^ extra vars in scope from GHCi
-        -> StgPipelineOpts
-        -> Module                    -- ^ module being compiled
-        -> [StgTopBinding]           -- ^ input program
-        -> IO ([CgStgTopBinding], StgCgInfos) -- output program
-stg2stg logger extra_vars opts this_mod binds
-  = do  { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds
-        ; showPass logger "Stg2Stg"
-        -- Do the main business!
-        ; binds' <- runStgM 'g' $
-            foldM (do_stg_pass this_mod) binds (stgPipeline_phases opts)
-
-          -- Dependency sort the program as last thing. The program needs to be
-          -- in dependency order for the SRT algorithm to work (see
-          -- CmmBuildInfoTables, which also includes a detailed description of
-          -- the algorithm), and we don't guarantee that the program is already
-          -- sorted at this point. #16192 is for simplifier not preserving
-          -- dependency order. We also don't guarantee that StgLiftLams will
-          -- preserve the order or only create minimal recursive groups, so a
-          -- sorting pass is necessary.
-          -- This pass will also augment each closure with non-global free variables
-          -- annotations (which is used by code generator to compute offsets into closures)
-        ; let binds_sorted_with_fvs = depSortWithAnnotStgPgm this_mod binds'
-        -- See Note [Tag inference for interactive contexts]
-        ; inferTags (stgPipeline_pprOpts opts) logger this_mod binds_sorted_with_fvs
-   }
-
-  where
-    stg_linter unarised
-      | Just diag_opts <- stgPipeline_lint opts
-      = lintStgTopBindings
-          (stgPlatform opts) logger
-          diag_opts ppr_opts
-          extra_vars this_mod unarised
-      | otherwise
-      = \ _whodunit _binds -> return ()
-
-    -------------------------------------------
-    do_stg_pass :: Module -> [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]
-    do_stg_pass this_mod binds to_do
-      = case to_do of
-          StgDoNothing ->
-            return binds
-
-          StgStats ->
-            logTraceMsg logger "STG stats" (text (showStgStats binds)) (return binds)
-
-          StgCSE -> do
-            let binds' = {-# SCC "StgCse" #-} stgCse binds
-            end_pass "StgCse" binds'
-
-          StgLiftLams cfg -> do
-            us <- getUniqueSupplyM
-            --
-            let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams this_mod cfg us binds
-            end_pass "StgLiftLams" binds'
-
-          StgBcPrep -> do
-            us <- getUniqueSupplyM
-            let binds' = {-# SCC "StgBcPrep" #-} bcPrep us binds
-            end_pass "StgBcPrep" binds'
-
-          StgUnarise -> do
-            us <- getUniqueSupplyM
-            liftIO (stg_linter False "Pre-unarise" binds)
-            let binds' = {-# SCC "StgUnarise" #-} unarise us binds
-            liftIO (dump_when Opt_D_dump_stg_unarised "Unarised STG:" binds')
-            liftIO (stg_linter True "Unarise" binds')
-            return binds'
-
-    ppr_opts = stgPipeline_pprOpts opts
-    dump_when flag header binds
-      = putDumpFileMaybe logger flag header FormatSTG (pprStgTopBindings ppr_opts binds)
-
-    end_pass what binds2
-      = liftIO $ do -- report verbosely, if required
-          putDumpFileMaybe logger Opt_D_verbose_stg2stg what
-            FormatSTG (vcat (map (pprStgTopBinding ppr_opts) binds2))
-          stg_linter False what binds2
-          return binds2
-
--- -----------------------------------------------------------------------------
--- StgToDo:  abstraction of stg-to-stg passes to run.
-
--- | Optional Stg-to-Stg passes.
-data StgToDo
-  = StgCSE
-  -- ^ Common subexpression elimination
-  | StgLiftLams StgLiftConfig
-  -- ^ Lambda lifting closure variables, trading stack/register allocation for
-  -- heap allocation
-  | StgStats
-  | StgUnarise
-  -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders
-  | StgBcPrep
-  -- ^ Mandatory when compiling to bytecode
-  | StgDoNothing
-  -- ^ Useful for building up 'getStgToDo'
-  deriving (Show, Read, Eq, Ord)
diff --git a/compiler/GHC/Stg/Stats.hs b/compiler/GHC/Stg/Stats.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/Stats.hs
+++ /dev/null
@@ -1,167 +0,0 @@
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-\section[StgStats]{Gathers statistical information about programs}
-
-
-The program gather statistics about
-\begin{enumerate}
-\item number of boxed cases
-\item number of unboxed cases
-\item number of let-no-escapes
-\item number of non-updatable lets
-\item number of updatable lets
-\item number of applications
-\item number of primitive applications
-\item number of closures (does not include lets bound to constructors)
-\item number of free variables in closures
-%\item number of top-level functions
-%\item number of top-level CAFs
-\item number of constructors
-\end{enumerate}
--}
-
-
-
-module GHC.Stg.Stats ( showStgStats ) where
-
-import GHC.Prelude
-
-import GHC.Stg.Syntax
-
-import GHC.Types.Id (Id)
-
-import Data.Map (Map)
-import qualified Data.Map as Map
-
-data CounterType
-  = Literals
-  | Applications
-  | ConstructorApps
-  | PrimitiveApps
-  | LetNoEscapes
-  | StgCases
-  | FreeVariables
-  | ConstructorBinds Bool{-True<=>top-level-}
-  | ReEntrantBinds   Bool{-ditto-}
-  | SingleEntryBinds Bool{-ditto-}
-  | UpdatableBinds   Bool{-ditto-}
-  deriving (Eq, Ord)
-
-type Count      = Int
-type StatEnv    = Map CounterType Count
-
-emptySE :: StatEnv
-emptySE = Map.empty
-
-combineSE :: StatEnv -> StatEnv -> StatEnv
-combineSE = Map.unionWith (+)
-
-combineSEs :: [StatEnv] -> StatEnv
-combineSEs = foldr combineSE emptySE
-
-countOne :: CounterType -> StatEnv
-countOne c = Map.singleton c 1
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Top-level list of bindings (a ``program'')}
-*                                                                      *
-************************************************************************
--}
-
-showStgStats :: [StgTopBinding] -> String
-
-showStgStats prog
-  = "STG Statistics:\n\n"
-    ++ concatMap showc (Map.toList (gatherStgStats prog))
-  where
-    showc (x,n) = (showString (s x) . shows n) "\n"
-
-    s Literals                = "Literals                   "
-    s Applications            = "Applications               "
-    s ConstructorApps         = "ConstructorApps            "
-    s PrimitiveApps           = "PrimitiveApps              "
-    s LetNoEscapes            = "LetNoEscapes               "
-    s StgCases                = "StgCases                   "
-    s FreeVariables           = "FreeVariables              "
-    s (ConstructorBinds True) = "ConstructorBinds_Top       "
-    s (ReEntrantBinds True)   = "ReEntrantBinds_Top         "
-    s (SingleEntryBinds True) = "SingleEntryBinds_Top       "
-    s (UpdatableBinds True)   = "UpdatableBinds_Top         "
-    s (ConstructorBinds _)    = "ConstructorBinds_Nested    "
-    s (ReEntrantBinds _)      = "ReEntrantBindsBinds_Nested "
-    s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "
-    s (UpdatableBinds _)      = "UpdatableBinds_Nested      "
-
-gatherStgStats :: [StgTopBinding] -> StatEnv
-gatherStgStats binds = combineSEs (map statTopBinding binds)
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Bindings}
-*                                                                      *
-************************************************************************
--}
-
-statTopBinding :: StgTopBinding -> StatEnv
-statTopBinding (StgTopStringLit _ _) = countOne Literals
-statTopBinding (StgTopLifted bind) = statBinding True bind
-
-statBinding :: Bool -- True <=> top-level; False <=> nested
-            -> StgBinding
-            -> StatEnv
-
-statBinding top (StgNonRec b rhs)
-  = statRhs top (b, rhs)
-
-statBinding top (StgRec pairs)
-  = combineSEs (map (statRhs top) pairs)
-
-statRhs :: Bool -> (Id, StgRhs) -> StatEnv
-
-statRhs top (_, StgRhsCon _ _ _ _ _)
-  = countOne (ConstructorBinds top)
-
-statRhs top (_, StgRhsClosure _ _ u _ body)
-  = statExpr body `combineSE`
-    countOne (
-      case u of
-        ReEntrant   -> ReEntrantBinds   top
-        Updatable   -> UpdatableBinds   top
-        SingleEntry -> SingleEntryBinds top
-    )
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Expressions}
-*                                                                      *
-************************************************************************
--}
-
-statExpr :: StgExpr -> StatEnv
-
-statExpr (StgApp _ _)     = countOne Applications
-statExpr (StgLit _)       = countOne Literals
-statExpr (StgConApp {})   = countOne ConstructorApps
-statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
-statExpr (StgTick _ e)    = statExpr e
-
-statExpr (StgLetNoEscape _ binds body)
-  = statBinding False{-not top-level-} binds    `combineSE`
-    statExpr body                               `combineSE`
-    countOne LetNoEscapes
-
-statExpr (StgLet _ binds body)
-  = statBinding False{-not top-level-} binds    `combineSE`
-    statExpr body
-
-statExpr (StgCase expr _ _ alts)
-  = statExpr expr       `combineSE`
-    stat_alts alts      `combineSE`
-    countOne StgCases
-  where
-    stat_alts = combineSEs . fmap (statExpr . alt_rhs)
diff --git a/compiler/GHC/Stg/Subst.hs b/compiler/GHC/Stg/Subst.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/Subst.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-
-
-module GHC.Stg.Subst where
-
-import GHC.Prelude
-
-import GHC.Types.Id
-import GHC.Types.Var.Env
-import GHC.Utils.Monad.State.Strict
-
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-
--- TODO: This code might make folly of the work done in CorePrep where
--- we clone local ids in order to ensure *all* local binders are unique.
--- It's my understanding that here we use "the rapier"/uniqAway which makes up
--- uniques based on the ids in scope. Which can give the same unique to different
--- binders as long as they are in different scopes. A guarantee which isn't
--- strong enough for code generation in general. See Note [CorePrep Overview].
-
--- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not
--- maintaining pairs of substitutions. Like 'GHC.Core.Subst.Subst', but
--- with the domain being 'Id's instead of entire 'CoreExpr'.
-data Subst = Subst InScopeSet IdSubstEnv
-
-type IdSubstEnv = IdEnv Id
-
--- | @emptySubst = 'mkEmptySubst' 'emptyInScopeSet'@
-emptySubst :: Subst
-emptySubst = mkEmptySubst emptyInScopeSet
-
--- | Constructs a new 'Subst' assuming the variables in the given 'InScopeSet'
--- are in scope.
-mkEmptySubst :: InScopeSet -> Subst
-mkEmptySubst in_scope = Subst in_scope emptyVarEnv
-
--- | Substitutes an 'Id' for another one according to the 'Subst' given in a way
--- that avoids shadowing the 'InScopeSet', returning the result and an updated
--- 'Subst' that should be used by subsequent substitutions.
-substBndr :: Id -> Subst -> (Id, Subst)
-substBndr id (Subst in_scope env)
-  = (new_id, Subst new_in_scope new_env)
-  where
-    new_id = uniqAway in_scope id
-    no_change = new_id == id -- in case nothing shadowed
-    new_in_scope = in_scope `extendInScopeSet` new_id
-    new_env
-      | no_change = delVarEnv env id
-      | otherwise = extendVarEnv env id new_id
-
--- | @substBndrs = runState . traverse (state . substBndr)@
-substBndrs :: Traversable f => f Id -> Subst -> (f Id, Subst)
-substBndrs = runState . traverse (state . substBndr)
-
--- | Substitutes an occurrence of an identifier for its counterpart recorded
--- in the 'Subst'.
-lookupIdSubst :: HasCallStack => Id -> Subst -> Id
-lookupIdSubst id (Subst in_scope env)
-  | not (isLocalId id) = id
-  | Just id' <- lookupVarEnv env id = id'
-  | Just id' <- lookupInScope in_scope id = id'
-  | otherwise = warnPprTrace True "StgSubst.lookupIdSubst" (ppr id $$ ppr in_scope) id
-
--- | Substitutes an occurrence of an identifier for its counterpart recorded
--- in the 'Subst'. Does not generate a debug warning if the identifier to
--- to substitute wasn't in scope.
-noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id
-noWarnLookupIdSubst id (Subst in_scope env)
-  | not (isLocalId id) = id
-  | Just id' <- lookupVarEnv env id = id'
-  | Just id' <- lookupInScope in_scope id = id'
-  | otherwise = id
-
--- | Add the 'Id' to the in-scope set and remove any existing substitutions for
--- it.
-extendInScope :: Id -> Subst -> Subst
-extendInScope id (Subst in_scope env) = Subst (in_scope `extendInScopeSet` id) env
-
--- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the
--- in-scope set is such that TyCoSubst Note [The substitution invariant]
--- holds after extending the substitution like this.
-extendSubst :: Id -> Id -> Subst -> Subst
-extendSubst id new_id (Subst in_scope env)
-  = assertPpr (new_id `elemInScopeSet` in_scope) (ppr id <+> ppr new_id $$ ppr in_scope) $
-    Subst in_scope (extendVarEnv env id new_id)
diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/Unarise.hs
+++ /dev/null
@@ -1,1144 +0,0 @@
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TupleSections    #-}
-
-{-
-(c) The GRASP/AQUA Project, Glasgow University, 1992-2012
-
-Note [Unarisation]
-~~~~~~~~~~~~~~~~~~
-The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum
-binders. So for example:
-
-  f (x :: (# Int, Bool #)) = f x + f (# 1, True #)
-
-  ==>
-
-  f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True
-
-It is important that we do this at the STG level and NOT at the Core level
-because it would be very hard to make this pass Core-type-preserving. In this
-example the type of 'f' changes, for example.
-
-STG fed to the code generators *must* be unarised because the code generators do
-not support unboxed tuple and unboxed sum binders natively.
-
-In more detail: (see next note for unboxed sums)
-
-Suppose that a variable x : (# t1, t2 #).
-
-  * At the binding site for x, make up fresh vars  x1:t1, x2:t2
-
-  * Extend the UnariseEnv   x :-> MultiVal [x1,x2]
-
-  * Replace the binding with a curried binding for x1,x2
-
-       Lambda:   \x.e                ==>   \x1 x2. e
-       Case alt: MkT a b x c d -> e  ==>   MkT a b x1 x2 c d -> e
-
-  * Replace argument occurrences with a sequence of args via a lookup in
-    UnariseEnv
-
-       f a b x c d   ==>   f a b x1 x2 c d
-
-  * Replace tail-call occurrences with an unboxed tuple via a lookup in
-    UnariseEnv
-
-       x  ==>  (# x1, x2 #)
-
-    So, for example
-
-       f x = x    ==>   f x1 x2 = (# x1, x2 #)
-
-  * We /always/ eliminate a case expression when
-
-       - It scrutinises an unboxed tuple or unboxed sum
-
-       - The scrutinee is a variable (or when it is an explicit tuple, but the
-         simplifier eliminates those)
-
-    The case alternative (there can be only one) can be one of these two
-    things:
-
-      - An unboxed tuple pattern. e.g.
-
-          case v of x { (# x1, x2, x3 #) -> ... }
-
-        Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the
-        environment with
-
-          x :-> MultiVal [t1,t2,t3]
-          x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3
-
-      - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3
-
-By the end of this pass, we only have unboxed tuples in return positions.
-Unboxed sums are completely eliminated, see next note.
-
-Note [Translating unboxed sums to unboxed tuples]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Unarise also eliminates unboxed sum binders, and translates unboxed sums in
-return positions to unboxed tuples. We want to overlap fields of a sum when
-translating it to a tuple to have efficient memory layout. When translating a
-sum pattern to a tuple pattern, we need to translate it so that binders of sum
-alternatives will be mapped to right arguments after the term translation. So
-translation of sum DataCon applications to tuple DataCon applications and
-translation of sum patterns to tuple patterns need to be in sync.
-
-These translations work like this. Suppose we have
-
-  (# x1 | | ... #) :: (# t1 | t2 | ... #)
-
-remember that t1, t2 ... can be sums and tuples too. So we first generate
-layouts of those. Then we "merge" layouts of each alternative, which gives us a
-sum layout with best overlapping possible.
-
-Layout of a flat type 'ty1' is just [ty1].
-Layout of a tuple is just concatenation of layouts of its fields.
-
-For layout of a sum type,
-
-  - We first get layouts of all alternatives.
-  - We sort these layouts based on their "slot types".
-  - We merge all the alternatives.
-
-For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #)
-
-  - Layouts of alternatives: [ [Word, LiftedPtr], [Word, Word], [Word] ]
-  - Sorted: [ [LiftedPtr, Word], [Word, Word], [Word] ]
-  - Merge all alternatives together: [ LiftedPtr, Word, Word ]
-
-We add a slot for the tag to the first position. So our tuple type is
-
-  (# Tag#, Any, Word#, Word# #)
-  (we use Any for pointer slots)
-
-Now, any term of this sum type needs to generate a tuple of this type instead.
-The translation works by simply putting arguments to first slots that they fit
-in. Suppose we had
-
-  (# (# 42#, 'c' #) | | #)
-
-42# fits in Word#, 'c' fits in Any, so we generate this application:
-
-  (# 1#, 'c', 42#, rubbish #)
-
-Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#,
-3# fits in Word #, so we get:
-
-  (# 2#, rubbish, 2#, 3# #).
-
-
-Note [Don't merge lifted and unlifted slots]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When merging slots, one might be tempted to collapse lifted and unlifted
-pointers. However, as seen in #19645, this is wrong. Imagine that you have
-the program:
-
-  test :: (# Char | ByteArray# #) -> ByteArray#
-  test (# c | #) = doSomething c
-  test (# | ba #) = ba
-
-Collapsing the Char and ByteArray# slots would produce STG like:
-
-  test :: forall {t}. (# t | GHC.Prim.ByteArray# #) -> GHC.Prim.ByteArray#
-    = {} \r [ (tag :: Int#) (slot0 :: (Any :: Type)) ]
-          case tag of tag'
-            1# -> doSomething slot0
-            2# -> slot0;
-
-Note how `slot0` has a lifted type, despite being bound to an unlifted
-ByteArray# in the 2# alternative. This liftedness would cause the code generator to
-attempt to enter it upon returning. As unlifted objects do not have entry code,
-this causes a runtime crash.
-
-For this reason, Unarise treats unlifted and lifted things as distinct slot
-types, despite both being GC pointers. This approach is a slight pessimisation
-(since we need to pass more arguments) but appears to be the simplest way to
-avoid #19645. Other alternatives considered include:
-
- a. Giving unlifted objects "trivial" entry code. However, we ultimately
-    concluded that the value of the "unlifted things are never entered" invariant
-    outweighed the simplicity of this approach.
-
- b. Annotating occurrences with calling convention information instead of
-    relying on the binder's type. This seemed like a very complicated
-    way to fix what is ultimately a corner-case.
-
-
-Note [Types in StgConApp]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have this unboxed sum term:
-
-  (# 123 | #)
-
-What will be the unboxed tuple representation? We can't tell without knowing the
-type of this term. For example, these are all valid tuples for this:
-
-  (# 1#, 123 #)          -- when type is (# Int | String #)
-  (# 1#, 123, rubbish #) -- when type is (# Int | Float# #)
-  (# 1#, 123, rubbish, rubbish #)
-                         -- when type is (# Int | (# Int, Int, Int #) #)
-
-So we pass type arguments of the DataCon's TyCon in StgConApp to decide what
-layout to use. Note that unlifted values can't be let-bound, so we don't need
-types in StgRhsCon.
-
-Note [Casting slot arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this function which selects between Int32# and Int64# from a unboxed sum.
-
-    foo ::  (# Int32# | Int64#  #) -> FD
-    foo x = case x of
-        (# x1 | #) -> F x1
-        (# | x2 #) -> D x2
-
-Naturally we would expect x1 to have a PrimRep of Int32Rep and x2 of DoubleRep.
-However we used to generate this (bogus) code after Unarise giving rise to #22208:
-
-    M.foo :: (# GHC.Prim.Int32# | GHC.Prim.Int64# #) -> M.FD
-    [GblId, Arity=1, Unf=OtherCon []] =
-        {} \r [sum_tag sum_field]
-            case sum_tag of tag_gsc {
-              __DEFAULT -> M.F [sum_field];
-              2# -> M.D [sum_field];
-            };
-
-Where sum_field is used both as Int32# and Int64# depending on the branch
-because they share the same SlotTy.
-This usually works out since we put all int's in the same sort of register.
-So even if the reps where wrong (x :: bits32) = (y :: bits64) would produce
-correct code in the most cases.
-However there are cases where this goes wrong, causing lint errors,in the case of #22208
-compiler panics or in some cases incorrect results in the C backend.
-For now our solution is to construct proper casts between the PrimRep of the slot and
-the variables we want to store in, or read out of these slots.
-
-This means when we have a sum (# Int32# | Int64# #) if we want to store a Int32
-we convert it to a Int64 on construction of the tuple value, and convert it back
-to a Int32 once when want to use the field. On most backends these coversions should
-be no-ops at runtime so this seems reasonable.
-
-Conversion for values coming out of a strict field happen in mapSumIdBinders. While
-conversion during the construction of sums happen inside mkUbxSum.
-
-------------- A full example of casting during sum construction ----------------
-
-To compile a constructor application of a unboxed sum of type (# Int32# | Int64# )
-in an expression like  `let sum = (# x | #)` we will call mkUbxSum to determine
-which binders we have to replace sum with at use sites during unarise.
-See also Note [Translating unboxed sums to unboxed tuples].
-
-Int32# and Int64# in this case will share the same slot in the unboxed sum. This means
-the sum after unarise will be represented by two binders. One for the tag and one for
-the field. The later having Int64Rep.
-However our input for the field is of Int32Rep. So in order to soundly construct
-`(# x | #) :: (# Int32# | Int64# )` we must upcast `x` to Int64#.
-To do this mkUbxSum will produce an expression with a hole for constructor application
-to go into. That is the call to mkUbxSum and it's result will look something like:
-
-  >>> mkUbxSum (#|#) [Int32#, Int64#] (x::Int32#) us (x')
-  ([1#::Int#, x'::Int64#], \rhs -> case int32ToInt# x of x' -> rhs )
-
-We will use the returned arguments to construct an application to an unboxed tuple:
-
-  >>> mkTuple [tag::Int#, x'::Int64#]
-  (# tag, x' #)
-
-Which we will then use as the rhs to pass into the casting wrapper to
-construct an expression that casts `x` to the right type before constructing the
-tuple
-
-  >>> (\rhs -> case int32ToInt# x of x' -> rhs ) (# tag, x' #)
-  case int32ToInt# x of x' -> (# #) 1# x'
-
-Which results in the this definition for `sum` after all is said and done:
-
-  let sum = case int32ToInt# x of { x' -> (# #) 1# x' }
-
-Not that the renaming is not optional. Cmm requires binders of different uniques
-to have at least different types. See Note [CorePrep Overview]: 6. Clone all local Ids
-
-------------- A full example of casting during sum matching --------------------
-
-When matching on an unboxed sum constructor we start out with
-something like this the pre-unarise:
-
-    f :: (# Int32 | Int64# ) -> ...
-    f sum = case sum of
-        (# x |#) -> alt_rhs
-        ...
-
-We unarise the function arguments and get:
-
-    f sum_tag sum_slot1 = case sum_tag of
-        1# -> ???
-
-Now we need to match up the original alternative binders with the sum slots passed
-to the function. This is done by mapSumIdBinders which we we call for our
-example alternative like this:
-
-    >>> mapSumIdBinders [x] [sum_slot1] alt_rhs env
-    (env', alt_rhs')
-
-mapSumIdBinders first matches up the list of binders with the slots passed to
-the function which is trivial in this case. Then we check if the slot and the
-variable residing inside it agree on their Rep. If alternative binders and
-the function arguments agree in their slot reps we we just extend the environment
-with a mapping from `x` to `sum_slot1` and we return the rhs as is.
-
-If the reps of the sum_slots do not agree with alternative binders they represent
-then we need to wrap the whole RHS in nested cases which cast the sum_slot<n>
-variables to the correct rep. Here `x` is of Int32Rep while `sum_slot1` will be
-of Int64Rep. This means instead of retuning the original alt_rhs we will return:
-
-  >>> mapSumIdBinders [x] [sum_slot1] alt_rhs env
-  ( env'[x=x']
-  , case int64ToInt32# (sum_slot1 :: Int64#) of
-      (x' :: Int32#) -> alt_rhs
-  )
-
-We then run unarise on alt_rhs within that expression, which will replace the first occurence
-of `x` with sum_slot_arg_1 giving us post-unarise:
-
-    f sum_tag sum_slot1 =
-      case sum_tag of
-        1# -> case int64ToInt32# sum_slot1 of
-          x' -> ... x' ...
-        ...
-
-Note [UnariseEnv]
-~~~~~~~~~~~~~~~~~~
-At any variable occurrence 'v',
-* If the UnariseEnv has a binding for 'v', the binding says what 'v' is bound to
-* If not, 'v' stands just for itself.
-
-Most variables are unaffected by unarisation, and (for efficiency) we don't put
-them in the UnariseEnv at all.  But NB: when we go under a binding for 'v' we must
-remember to delete 'v' from the UnariseEnv, lest occurrences of 'v' see the outer
-binding for the variable (#21396).
-
-
-Note [UnariseEnv can map to literals]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-To avoid redundant case expressions when unarising unboxed sums, UnariseEnv
-needs to map variables to literals too. Suppose we have this Core:
-
-  f (# x | #)
-
-  ==> (CorePrep)
-
-  case (# x | #) of y {
-    _ -> f y
-  }
-
-  ==> (MultiVal)
-
-  case (# 1#, x #) of [x1, x2] {
-    _ -> f x1 x2
-  }
-
-To eliminate this case expression we need to map x1 to 1# in UnariseEnv:
-
-  x1 :-> UnaryVal 1#, x2 :-> UnaryVal x
-
-so that `f x1 x2` becomes `f 1# x`.
-
-Note [Unarisation and arity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Because of unarisation, the arity that will be recorded in the generated info
-table for an Id may be larger than the idArity. Instead we record what we call
-the RepArity, which is the Arity taking into account any expanded arguments, and
-corresponds to the number of (possibly-void) *registers* arguments will arrive
-in.
-
-Note [Post-unarisation invariants]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-STG programs after unarisation have these invariants:
-
-  * No unboxed sums at all.
-
-  * No unboxed tuple binders. Tuples only appear in return position.
-
-  * DataCon applications (StgRhsCon and StgConApp) don't have void arguments.
-    This means that it's safe to wrap `StgArg`s of DataCon applications with
-    `GHC.StgToCmm.Env.NonVoid`, for example.
-
-  * Similar to unboxed tuples, Note [Rubbish literals] of TupleRep may only
-    appear in return position.
-
-  * Alt binders (binders in patterns) are always non-void.
-
-  * Binders always have zero (for void arguments) or one PrimRep.
--}
-
-module GHC.Stg.Unarise (unarise) where
-
-import GHC.Prelude
-
-import GHC.Types.Basic
-import GHC.Core
-import GHC.Core.DataCon
-import GHC.Core.TyCon
-import GHC.Data.FastString (FastString, mkFastString, fsLit)
-import GHC.Types.Id
-import GHC.Types.Literal
-import GHC.Core.Make (aBSENT_SUM_FIELD_ERROR_ID)
-import GHC.Types.Id.Make (voidPrimId, voidArgId)
-import GHC.Utils.Monad (mapAccumLM)
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Types.RepType
-import GHC.Stg.Syntax
-import GHC.Stg.Utils
-import GHC.Core.Type
-import GHC.Builtin.Types.Prim (intPrimTy)
-import GHC.Builtin.Types
-import GHC.Types.Unique.Supply
-import GHC.Types.Unique
-import GHC.Utils.Misc
-import GHC.Types.Var.Env
-
-import Data.Bifunctor (second)
-import Data.List.NonEmpty (NonEmpty (..))
-import Data.Maybe (mapMaybe)
-import qualified Data.IntMap as IM
-import GHC.Builtin.PrimOps
-import GHC.Builtin.PrimOps.Casts
-import Data.List (mapAccumL)
-
--- import GHC.Utils.Trace
---------------------------------------------------------------------------------
-
--- | A mapping from binders to the Ids they were expanded/renamed to.
---
---   x :-> MultiVal [a,b,c] in rho
---
--- iff  x's typePrimRep is not a singleton, or equivalently
---      x's type is an unboxed tuple, sum or void.
---
---    x :-> UnaryVal x'
---
--- iff x's RepType is UnaryRep or equivalently
---     x's type is not unboxed tuple, sum or void.
---
--- So
---     x :-> MultiVal [a] in rho
--- means x is represented by singleton tuple.
---
---     x :-> MultiVal [] in rho
--- means x is void.
---
--- INVARIANT: OutStgArgs in the range only have NvUnaryTypes
---            (i.e. no unboxed tuples, sums or voids)
---
-newtype UnariseEnv = UnariseEnv  { ue_rho :: (VarEnv UnariseVal) }
-
-initUnariseEnv :: VarEnv UnariseVal -> UnariseEnv
-initUnariseEnv = UnariseEnv
-data UnariseVal
-  = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).
-  | UnaryVal OutStgArg   -- See Note [Renaming during unarisation].
-
-instance Outputable UnariseVal where
-  ppr (MultiVal args) = text "MultiVal" <+> ppr args
-  ppr (UnaryVal arg)   = text "UnaryVal" <+> ppr arg
-
--- | Extend the environment, checking the UnariseEnv invariant.
--- The id is mapped to one or more things.
--- See Note [UnariseEnv]
-extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
-extendRho env x (MultiVal args)
-  = assert (all (isNvUnaryType . stgArgType) args)
-    env { ue_rho = extendVarEnv (ue_rho env) x (MultiVal args) }
-extendRho env x (UnaryVal val)
-  = assert (isNvUnaryType (stgArgType val))
-    env { ue_rho = extendVarEnv (ue_rho env) x (UnaryVal val) }
--- Properly shadow things from an outer scope.
--- See Note [UnariseEnv]
-
--- The id stands for itself so we don't record a mapping.
--- See Note [UnariseEnv]
-extendRhoWithoutValue :: UnariseEnv -> Id -> UnariseEnv
-extendRhoWithoutValue env x = env { ue_rho = delVarEnv (ue_rho env) x }
-
-lookupRho :: UnariseEnv -> Id -> Maybe UnariseVal
-lookupRho env v = lookupVarEnv (ue_rho env) v
-
---------------------------------------------------------------------------------
-
-unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
-unarise us binds = initUs_ us (mapM (unariseTopBinding (initUnariseEnv emptyVarEnv)) binds)
-
-unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
-unariseTopBinding rho (StgTopLifted bind)
-  = StgTopLifted <$> unariseBinding rho bind
-unariseTopBinding _ bind@StgTopStringLit{} = return bind
-
-unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding
-unariseBinding rho (StgNonRec x rhs)
-  = StgNonRec x <$> unariseRhs rho rhs
-unariseBinding rho (StgRec xrhss)
-  = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss
-
-unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
-unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)
-  = do (rho', args1) <- unariseFunArgBinders rho args
-       expr' <- unariseExpr rho' expr
-       return (StgRhsClosure ext ccs update_flag args1 expr')
-
-unariseRhs rho (StgRhsCon ccs con mu ts args)
-  = assert (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))
-    return (StgRhsCon ccs con mu ts (unariseConArgs rho args))
-
---------------------------------------------------------------------------------
-
-unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr
-
-unariseExpr rho e@(StgApp f [])
-  = case lookupRho rho f of
-      Just (MultiVal args)  -- Including empty tuples
-        -> return (mkTuple args)
-      Just (UnaryVal (StgVarArg f'))
-        -> return (StgApp f' [])
-      Just (UnaryVal (StgLitArg f'))
-        -> return (StgLit f')
-      Nothing
-        -> return e
-
-unariseExpr rho e@(StgApp f args)
-  = return (StgApp f' (unariseFunArgs rho args))
-  where
-    f' = case lookupRho rho f of
-           Just (UnaryVal (StgVarArg f')) -> f'
-           Nothing -> f
-           err -> pprPanic "unariseExpr - app2" (pprStgExpr panicStgPprOpts e $$ ppr err)
-               -- Can't happen because 'args' is non-empty, and
-               -- a tuple or sum cannot be applied to anything
-
-unariseExpr _ (StgLit l)
-  = return (StgLit l)
-
-unariseExpr rho (StgConApp dc n args ty_args)
-  | isUnboxedSumDataCon dc || isUnboxedTupleDataCon dc
-  = do
-      us <- getUniqueSupplyM
-      case unariseUbxSumOrTupleArgs rho us dc args ty_args of
-        (args', Just cast_wrapper)
-          -> return $ cast_wrapper (mkTuple args')
-        (args', Nothing)
-          -> return $ (mkTuple args')
-  | otherwise =
-      let args' = unariseConArgs rho args in
-      return $ (StgConApp dc n args' (map stgArgType args'))
-
-unariseExpr rho (StgOpApp op args ty)
-  = return (StgOpApp op (unariseFunArgs rho args) ty)
-
-unariseExpr rho (StgCase scrut bndr alt_ty alts)
-  -- tuple/sum binders in the scrutinee can always be eliminated
-  | StgApp v [] <- scrut
-  , Just (MultiVal xs) <- lookupRho rho v
-  = elimCase rho xs bndr alt_ty alts
-
-  -- Handle strict lets for tuples and sums:
-  --   case (# a,b #) of r -> rhs
-  -- and analogously for sums
-  | StgConApp dc _n args ty_args <- scrut
-  , isUnboxedSumDataCon dc || isUnboxedTupleDataCon dc
-  = do
-    us <- getUniqueSupplyM
-    case unariseUbxSumOrTupleArgs rho us dc args ty_args of
-      (args',Just wrapper) -> wrapper <$> elimCase rho args' bndr alt_ty alts
-      (args',Nothing) -> elimCase rho args' bndr alt_ty alts
-
-  -- See (3) of Note [Rubbish literals] in GHC.Types.Literal
-  | StgLit lit <- scrut
-  , Just args' <- unariseRubbish_maybe lit
-  = elimCase rho args' bndr alt_ty alts
-
-  -- general case
-  | otherwise
-  = do scrut' <- unariseExpr rho scrut
-       alts'  <- unariseAlts rho alt_ty bndr alts
-       return (StgCase scrut' bndr alt_ty alts')
-                       -- bndr may have a unboxed sum/tuple type but it will be
-                       -- dead after unarise (checked in GHC.Stg.Lint)
-
-unariseExpr rho (StgLet ext bind e)
-  = StgLet ext <$> unariseBinding rho bind <*> unariseExpr rho e
-
-unariseExpr rho (StgLetNoEscape ext bind e)
-  = StgLetNoEscape ext <$> unariseBinding rho bind <*> unariseExpr rho e
-
-unariseExpr rho (StgTick tick e)
-  = StgTick tick <$> unariseExpr rho e
-
--- Doesn't return void args.
-unariseUbxSumOrTupleArgs :: UnariseEnv -> UniqSupply -> DataCon -> [InStgArg] -> [Type]
-                   -> ( [OutStgArg]           -- Arguments representing the unboxed sum
-                      , Maybe (StgExpr -> StgExpr)) -- Transformation to apply to the arguments, to bring them
-                                                    -- into the right Rep
-unariseUbxSumOrTupleArgs rho us dc args ty_args
-  | isUnboxedTupleDataCon dc
-  = (unariseConArgs rho args, Nothing)
-
-  | isUnboxedSumDataCon dc
-  , let args1 = assert (isSingleton args) (unariseConArgs rho args)
-  = let (args2, cast_wrapper) = mkUbxSum dc ty_args args1 us
-    in (args2, Just cast_wrapper)
-
-  | otherwise
-  = panic "unariseUbxSumOrTupleArgs: Constructor not a unboxed sum or tuple"
-
--- Doesn't return void args.
-unariseRubbish_maybe :: Literal -> Maybe [OutStgArg]
-unariseRubbish_maybe (LitRubbish torc rep)
-  | [prep] <- preps
-  , not (isVoidRep prep)
-  = Nothing   -- Single, non-void PrimRep. Nothing to do!
-
-  | otherwise -- Multiple reps, possibly with VoidRep. Eliminate via elimCase
-  = Just [ StgLitArg (LitRubbish torc (primRepToRuntimeRep prep))
-         | prep <- preps, not (isVoidRep prep) ]
-  where
-    preps = runtimeRepPrimRep (text "unariseRubbish_maybe") rep
-
-unariseRubbish_maybe _ = Nothing
-
---------------------------------------------------------------------------------
-
-elimCase :: UnariseEnv
-         -> [OutStgArg] -- non-void args
-         -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr
-
-elimCase rho args bndr (MultiValAlt _) [GenStgAlt{ alt_con   = _
-                                                 , alt_bndrs = bndrs
-                                                 , alt_rhs   = rhs}]
-  = do let rho1 = extendRho rho bndr (MultiVal args)
-       (rho2, rhs') <- case () of
-           _
-             | isUnboxedTupleBndr bndr
-             -> return (mapTupleIdBinders bndrs args rho1, rhs)
-             | otherwise
-             -> assert (isUnboxedSumBndr bndr) $
-               case bndrs of
-                -- Sum with a void-type binder?
-                [] -> return (rho1, rhs)
-                [alt_bndr] -> mapSumIdBinders alt_bndr args rhs rho1
-                _ -> pprPanic "mapSumIdBinders" (ppr bndrs $$ ppr args)
-
-       unariseExpr rho2 rhs'
-
-elimCase rho args@(tag_arg : real_args) bndr (MultiValAlt _) alts
-  | isUnboxedSumBndr bndr
-  = do tag_bndr <- mkId (mkFastString "tag") tagTy
-          -- this won't be used but we need a binder anyway
-       let rho1 = extendRho rho bndr (MultiVal args)
-           scrut' = case tag_arg of
-                      StgVarArg v     -> StgApp v []
-                      StgLitArg l     -> StgLit l
-
-       alts' <- unariseSumAlts rho1 real_args alts
-       return (StgCase scrut' tag_bndr tagAltTy alts')
-
-elimCase _ args bndr alt_ty alts
-  = pprPanic "elimCase - unhandled case"
-      (ppr args <+> ppr bndr <+> ppr alt_ty $$ pprPanicAlts alts)
-
---------------------------------------------------------------------------------
-
-unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]
-unariseAlts rho (MultiValAlt n) bndr [GenStgAlt{ alt_con   = DEFAULT
-                                               , alt_bndrs = []
-                                               , alt_rhs   = e}]
-  | isUnboxedTupleBndr bndr
-  = do (rho', ys) <- unariseConArgBinder rho bndr
-       !e' <- unariseExpr rho' e
-       return [GenStgAlt (DataAlt (tupleDataCon Unboxed n)) ys e']
-
-unariseAlts rho (MultiValAlt n) bndr [GenStgAlt{ alt_con   = DataAlt _
-                                               , alt_bndrs = ys
-                                               , alt_rhs   = e}]
-  | isUnboxedTupleBndr bndr
-  = do (rho', ys1) <- unariseConArgBinders rho ys
-       massert (ys1 `lengthIs` n)
-       let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))
-       !e' <- unariseExpr rho'' e
-       return [GenStgAlt (DataAlt (tupleDataCon Unboxed n)) ys1 e']
-
-unariseAlts _ (MultiValAlt _) bndr alts
-  | isUnboxedTupleBndr bndr
-  = pprPanic "unariseExpr: strange multi val alts" (pprPanicAlts alts)
-
--- In this case we don't need to scrutinize the tag bit
-unariseAlts rho (MultiValAlt _) bndr [GenStgAlt{ alt_con    = DEFAULT
-                                               , alt_bndrs = []
-                                               , alt_rhs   = rhs}]
-  | isUnboxedSumBndr bndr
-  = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr
-       rhs' <- unariseExpr rho_sum_bndrs rhs
-       return [GenStgAlt (DataAlt (tupleDataCon Unboxed (length sum_bndrs))) sum_bndrs rhs']
-
-unariseAlts rho (MultiValAlt _) bndr alts
-  | isUnboxedSumBndr bndr
-  = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr
-       alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts
-       let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'
-       return [GenStgAlt{ alt_con   = DataAlt (tupleDataCon Unboxed (length scrt_bndrs))
-                        , alt_bndrs = scrt_bndrs
-                        , alt_rhs   = inner_case
-                        }]
-
-unariseAlts rho _ _ alts
-  = mapM (\alt -> unariseAlt rho alt) alts
-
-unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt
-unariseAlt rho alt@GenStgAlt{alt_con=_,alt_bndrs=xs,alt_rhs=e}
-  = do (rho', xs') <- unariseConArgBinders rho xs
-       !e' <- unariseExpr rho' e
-       return $! alt {alt_bndrs = xs', alt_rhs = e'}
-
---------------------------------------------------------------------------------
-
--- | Make alternatives that match on the tag of a sum
--- (i.e. generate LitAlts for the tag)
-unariseSumAlts :: UnariseEnv
-               -> [StgArg] -- sum components _excluding_ the tag bit.
-               -> [StgAlt] -- original alternative with sum LHS
-               -> UniqSM [StgAlt]
-unariseSumAlts env args alts
-  = do alts' <- mapM (unariseSumAlt env args) alts
-       return (mkDefaultLitAlt alts')
-
-unariseSumAlt :: UnariseEnv
-              -> [StgArg] -- sum components _excluding_ the tag bit.
-              -> StgAlt   -- original alternative with sum LHS
-              -> UniqSM StgAlt
-unariseSumAlt rho _ GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=e}
-  = GenStgAlt DEFAULT mempty <$> unariseExpr rho e
-
-unariseSumAlt rho args alt@GenStgAlt{ alt_con   = DataAlt sumCon
-                                , alt_bndrs = bs
-                                , alt_rhs   = e
-                                }
-
-  = do (rho',e') <- case bs of
-              [b] -> mapSumIdBinders b args e rho
-              -- Sums must have one binder
-              _ -> pprPanic "unariseSumAlt2" (ppr args $$ pprPanicAlt alt)
-       let lit_case   = LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)))
-       GenStgAlt lit_case mempty <$> unariseExpr rho' e'
-
-unariseSumAlt _ scrt alt
-  = pprPanic "unariseSumAlt3" (ppr scrt $$ pprPanicAlt alt)
-
---------------------------------------------------------------------------------
--- Mapping binders when matching und a unboxed sum/tuple
-
-mapTupleIdBinders
-  :: [InId]       -- Un-processed binders of a tuple alternative.
-                  -- Can have void binders.
-  -> [OutStgArg]  -- Arguments that form the tuple (after unarisation).
-                  -- Can't have void args.
-  -> UnariseEnv
-  -> UnariseEnv
-mapTupleIdBinders ids args0 rho0
-  = assert (not (any (isZeroBitTy . stgArgType) args0)) $
-    let
-      ids_unarised :: [(Id, [PrimRep])]
-      ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids
-
-      map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
-      map_ids rho [] _  = rho
-      map_ids rho ((x, x_reps) : xs) args =
-        let
-          x_arity = length x_reps
-          (x_args, args') =
-            assert (args `lengthAtLeast` x_arity)
-            splitAt x_arity args
-
-          rho'
-            | x_arity == 1
-            = assert (x_args `lengthIs` 1)
-              extendRho rho x (UnaryVal (head x_args))
-            | otherwise
-            = extendRho rho x (MultiVal x_args)
-        in
-          map_ids rho' xs args'
-    in
-      map_ids rho0 ids_unarised args0
-
-mapSumIdBinders
-  :: InId        -- Binder (in the case alternative).
-  -> [OutStgArg] -- Arguments that form the sum (NOT including the tag).
-                 -- Can't have void args.
-  -> InStgExpr
-  -> UnariseEnv
-  -> UniqSM (UnariseEnv, OutStgExpr)
-
-mapSumIdBinders alt_bndr args rhs rho0
-  = assert (not (any (isZeroBitTy . stgArgType) args)) $ do
-    uss <- listSplitUniqSupply <$> getUniqueSupplyM
-    let
-      fld_reps = typePrimRep (idType alt_bndr)
-
-      -- Slots representing the whole sum
-      arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args
-      -- The slots representing the field of the sum we bind.
-      id_slots  = map primRepSlot $ fld_reps
-      layout1   = layoutUbxSum arg_slots id_slots
-
-      -- See Note [Casting slot arguments]
-      -- Most of the code here is just to make sure our binders are of the
-      -- right type.
-      -- Select only the args which contain parts of the current field.
-      id_arg_exprs   = [ args !! i | i <- layout1 ]
-      id_vars   = [v | StgVarArg v <- id_arg_exprs]
-      -- Output types for the field binders based on their rep
-      id_tys    = map primRepToType fld_reps
-
-      typed_id_arg_input = assert (equalLength id_vars id_tys) $
-                           zip3 id_vars id_tys uss
-
-      mkCastInput :: (Id,Type,UniqSupply) -> ([(PrimOp,Type,Unique)],Id,Id)
-      mkCastInput (id,tar_type,bndr_us) =
-        let (ops,types) = unzip $ getCasts (typePrimRep1 $ idType id) (typePrimRep1 tar_type)
-            cst_opts = zip3 ops types $ uniqsFromSupply bndr_us
-            out_id = case cst_opts of
-              [] -> id
-              _ ->  let (_,ty,uq) = last cst_opts
-                    in mkCastVar uq ty
-        in (cst_opts,id,out_id)
-
-      cast_inputs = map mkCastInput typed_id_arg_input
-      (rhs_with_casts,typed_ids) = mapAccumL cast_arg (\x->x) cast_inputs
-        where
-          cast_arg rhs_in (cast_ops,in_id,out_id) =
-            let rhs_out = castArgRename cast_ops (StgVarArg in_id)
-            in (rhs_in . rhs_out, out_id)
-
-      typed_id_args = map StgVarArg typed_ids
-
-      -- pprTrace "mapSumIdBinders"
-      --           (text "id_tys" <+> ppr id_tys $$
-      --           text "id_args" <+> ppr id_arg_exprs $$
-      --           text "rhs" <+> ppr rhs $$
-      --           text "rhs_with_casts" <+> ppr rhs_with_casts
-      --           ) $
-    if isMultiValBndr alt_bndr
-      then return (extendRho rho0 alt_bndr (MultiVal typed_id_args), rhs_with_casts rhs)
-      else assert (typed_id_args `lengthIs` 1) $
-            return (extendRho rho0 alt_bndr (UnaryVal (head typed_id_args)), rhs_with_casts rhs)
-
--- Convert the argument to the given type, and wrap the conversion
--- around the given expression. Use the given Id as a name for the
--- converted value.
-castArgRename :: [(PrimOp,Type,Unique)] -> StgArg -> StgExpr -> StgExpr
-castArgRename ops in_arg rhs =
-  case ops of
-    [] -> rhs
-    ((op,ty,uq):rest_ops) ->
-      let out_id' = mkCastVar uq ty -- out_name `setIdUnique` uq `setIdType` ty
-          sub_cast = castArgRename rest_ops (StgVarArg out_id')
-      in mkCast in_arg op out_id' ty $ sub_cast rhs
-
--- Construct a case binder used when casting sums, of a given type and unique.
-mkCastVar :: Unique -> Type -> Id
-mkCastVar uq ty = mkSysLocal (fsLit "cst_sum") uq ManyTy ty
-
-mkCast :: StgArg -> PrimOp -> OutId -> Type -> StgExpr -> StgExpr
-mkCast arg_in cast_op out_id out_ty in_rhs =
-  let r2 = typePrimRep1 out_ty
-      scrut = StgOpApp (StgPrimOp cast_op) [arg_in] out_ty
-      alt = GenStgAlt { alt_con = DEFAULT, alt_bndrs = [], alt_rhs = in_rhs}
-      alt_ty = PrimAlt r2
-  in (StgCase scrut out_id alt_ty [alt])
-
--- | Build a unboxed sum term from arguments of an alternative.
---
--- Example, for (# x | #) :: (# (# #) | Int #) we call
---
---   mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ]
---
--- which returns
---
---   [ 1#, rubbish ]
---
-mkUbxSum
-  :: HasDebugCallStack
-  => DataCon      -- Sum data con
-  -> [Type]       -- Type arguments of the sum data con
-  -> [OutStgArg]  -- Actual arguments of the alternative.
-  -> UniqSupply
-  -> ([OutStgArg] -- Final tuple arguments
-     ,(StgExpr->StgExpr) -- We might need to cast the args first
-     )
-mkUbxSum dc ty_args args0 us
-  = let
-      _ :| sum_slots = ubxSumRepType (map typePrimRep ty_args)
-      -- drop tag slot
-      field_slots = (mapMaybe (typeSlotTy . stgArgType) args0)
-      tag = dataConTag dc
-      layout'  = layoutUbxSum sum_slots field_slots
-
-      tag_arg  = StgLitArg (LitNumber LitNumInt (fromIntegral tag))
-      arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)
-
-      ((_idx,_idx_map,_us,wrapper),slot_args)
-        = assert (length arg_idxs <= length sum_slots ) $
-          mapAccumL mkTupArg (0,arg_idxs,us,id) sum_slots
-
-      mkTupArg  :: (Int, IM.IntMap StgArg,UniqSupply,StgExpr->StgExpr)
-                -> SlotTy
-                -> ((Int,IM.IntMap StgArg,UniqSupply,StgExpr->StgExpr), StgArg)
-      mkTupArg (arg_idx, arg_map, us, wrapper) slot
-         | Just stg_arg <- IM.lookup arg_idx arg_map
-         =  case castArg us slot stg_arg of
-              -- Slot and arg type missmatched, do a cast
-              Just (casted_arg,us',wrapper') ->
-                ( (arg_idx+1, arg_map, us', wrapper . wrapper')
-                , casted_arg)
-              -- Use the arg as-is
-              Nothing ->
-                ( (arg_idx+1, arg_map, us, wrapper)
-                , stg_arg)
-         -- Garbage slot, fill with rubbish
-         | otherwise
-         =  ( (arg_idx+1, arg_map, us, wrapper)
-            , ubxSumRubbishArg slot)
-
-      castArg :: UniqSupply -> SlotTy -> StgArg -> Maybe (StgArg,UniqSupply,StgExpr -> StgExpr)
-      castArg us slot_ty arg
-        -- Cast the argument to the type of the slot if required
-        | slotPrimRep slot_ty /= typePrimRep1 (stgArgType arg)
-        , out_ty <- primRepToType $ slotPrimRep slot_ty
-        , (ops,types) <- unzip $ getCasts (typePrimRep1 $ stgArgType arg) $ typePrimRep1 out_ty
-        , not . null $ ops
-        = let (us1,us2) = splitUniqSupply us
-              cast_uqs = uniqsFromSupply us1
-              cast_opts = zip3 ops types cast_uqs
-              (_op,out_ty,out_uq) = last cast_opts
-              casts = castArgRename cast_opts arg :: StgExpr -> StgExpr
-          in Just (StgVarArg (mkCastVar out_uq out_ty),us2,casts)
-        -- No need for casting
-        | otherwise = Nothing
-
-      tup_args = tag_arg : slot_args
-    in
-      -- pprTrace "mkUbxSum" (
-      --   text "ty_args (slots)" <+> ppr ty_args $$
-      --   text "args0" <+> ppr args0 $$
-      --   text "wrapper" <+>
-      --       (ppr $ wrapper $ StgLit $ LitChar '_'))
-      (tup_args, wrapper)
-
-
--- | Return a rubbish value for the given slot type.
---
--- We use the following rubbish values:
---    * Literals: 0 or 0.0
---    * Pointers: `ghc-prim:GHC.Prim.Panic.absentSumFieldError`
---
--- See Note [aBSENT_SUM_FIELD_ERROR_ID] in "GHC.Core.Make"
---
-ubxSumRubbishArg :: SlotTy -> StgArg
-ubxSumRubbishArg PtrLiftedSlot   = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
-ubxSumRubbishArg PtrUnliftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
-ubxSumRubbishArg WordSlot        = StgLitArg (LitNumber LitNumWord 0)
-ubxSumRubbishArg Word64Slot      = StgLitArg (LitNumber LitNumWord64 0)
-ubxSumRubbishArg FloatSlot       = StgLitArg (LitFloat 0)
-ubxSumRubbishArg DoubleSlot      = StgLitArg (LitDouble 0)
-ubxSumRubbishArg (VecSlot n e)   = StgLitArg (LitRubbish TypeLike vec_rep)
-  where vec_rep = primRepToRuntimeRep (VecRep n e)
-
---------------------------------------------------------------------------------
-
-{-
-For arguments (StgArg) and binders (Id) we have two kind of unarisation:
-
-  - When unarising function arg binders and arguments, we don't want to remove
-    void binders and arguments. For example,
-
-      f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ...
-      f x y z = <body>
-
-    Here after unarise we should still get a function with arity 3. Similarly
-    in the call site we shouldn't remove void arguments:
-
-      f (# (# #), (# #) #) void# rw
-
-    When unarising <body>, we extend the environment with these binders:
-
-      x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal []
-
-    Because their rep types are `MultiRep []` (aka. void). This means that when
-    we see `x` in a function argument position, we actually replace it with a
-    void argument. When we see it in a DataCon argument position, we just get
-    rid of it, because DataCon applications in STG are always saturated.
-
-  - When unarising case alternative binders we remove void binders, but we
-    still update the environment the same way, because those binders may be
-    used in the RHS. Example:
-
-      case x of y {
-        (# x1, x2, x3 #) -> <RHS>
-      }
-
-    We know that y can't be void, because we don't scrutinize voids, so x will
-    be unarised to some number of arguments, and those arguments will have at
-    least one non-void thing. So in the rho we will have something like:
-
-      x :-> MultiVal [xu1, xu2]
-
-    Now, after we eliminate void binders in the pattern, we get exactly the same
-    number of binders, and extend rho again with these:
-
-      x1 :-> UnaryVal xu1
-      x2 :-> MultiVal [] -- x2 is void
-      x3 :-> UnaryVal xu2
-
-    Now when we see x2 in a function argument position or in return position, we
-    generate void#. In constructor argument position, we just remove it.
-
-So in short, when we have a void id,
-
-  - We keep it if it's a lambda argument binder or
-                       in argument position of an application.
-
-  - We remove it if it's a DataCon field binder or
-                         in argument position of a DataCon application.
--}
-
-unariseArgBinder
-    :: Bool -- data con arg?
-    -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
-unariseArgBinder is_con_arg rho x =
-  case typePrimRep (idType x) of
-    []
-      | is_con_arg
-      -> return (extendRho rho x (MultiVal []), [])
-      | otherwise -- fun arg, do not remove void binders
-      -> return (extendRho rho x (MultiVal []), [voidArgId])
-
-    [rep]
-      -- Arg represented as single variable, but original type may still be an
-      -- unboxed sum/tuple, e.g. (# Void# | Void# #).
-      --
-      -- While not unarising the binder in this case does not break any programs
-      -- (because it unarises to a single variable), it triggers StgLint as we
-      -- break the post-unarisation invariant that says unboxed tuple/sum
-      -- binders should vanish. See Note [Post-unarisation invariants].
-      | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x)
-      -> do x' <- mkId (mkFastString "us") (primRepToType rep)
-            return (extendRho rho x (MultiVal [StgVarArg x']), [x'])
-      | otherwise
-      -> return (extendRhoWithoutValue rho x, [x])
-
-    reps -> do
-      xs <- mkIds (mkFastString "us") (map primRepToType reps)
-      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
-
---------------------------------------------------------------------------------
-
--- | MultiVal a function argument. Never returns an empty list.
-unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
-unariseFunArg rho (StgVarArg x) =
-  case lookupRho rho x of
-    Just (MultiVal [])  -> [voidArg]   -- NB: do not remove void args
-    Just (MultiVal as)  -> as
-    Just (UnaryVal arg) -> [arg]
-    Nothing             -> [StgVarArg x]
-unariseFunArg _ arg = [arg]
-
-unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
-unariseFunArgs = concatMap . unariseFunArg
-
-unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
-unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs
-
--- Result list of binders is never empty
-unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
-unariseFunArgBinder = unariseArgBinder False
-
---------------------------------------------------------------------------------
-
--- | MultiVal a DataCon argument. Returns an empty list when argument is void.
-unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]
-unariseConArg rho (StgVarArg x) =
-  case lookupRho rho x of
-    Just (UnaryVal arg) -> [arg]
-    Just (MultiVal as) -> as      -- 'as' can be empty
-    Nothing
-      | isZeroBitTy (idType x) -> [] -- e.g. C realWorld#
-                                     -- Here realWorld# is not in the envt, but
-                                     -- is a void, and so should be eliminated
-      | otherwise -> [StgVarArg x]
-unariseConArg _ arg@(StgLitArg lit)
-  | Just as <- unariseRubbish_maybe lit
-  = as
-  | otherwise
-  = assert (not (isZeroBitTy (literalType lit))) -- We have no non-rubbish void literals
-    [arg]
-
-unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
-unariseConArgs = concatMap . unariseConArg
-
-unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
-unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs
-
--- Different from `unariseFunArgBinder`: result list of binders may be empty.
--- See DataCon applications case in Note [Post-unarisation invariants].
-unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
-unariseConArgBinder = unariseArgBinder True
-
---------------------------------------------------------------------------------
-
-mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
-mkIds fs tys = mkUnarisedIds fs tys
-
-mkId :: FastString -> UnaryType -> UniqSM Id
-mkId s t = mkUnarisedId s t
-
-isMultiValBndr :: Id -> Bool
-isMultiValBndr id
-  | [_] <- typePrimRep (idType id)
-  = False
-  | otherwise
-  = True
-
-isUnboxedSumBndr :: Id -> Bool
-isUnboxedSumBndr = isUnboxedSumType . idType
-
-isUnboxedTupleBndr :: Id -> Bool
-isUnboxedTupleBndr = isUnboxedTupleType . idType
-
-mkTuple :: [StgArg] -> StgExpr
-mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args (map stgArgType args)
-
-tagAltTy :: AltType
-tagAltTy = PrimAlt IntRep
-
-tagTy :: Type
-tagTy = intPrimTy
-
-voidArg :: StgArg
-voidArg = StgVarArg voidPrimId
-
-mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
--- We have an exhauseive list of literal alternatives
---    1# -> e1
---    2# -> e2
--- Since they are exhaustive, we can replace one with DEFAULT, to avoid
--- generating a final test. Remember, the DEFAULT comes first if it exists.
-mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")
-mkDefaultLitAlt alts@(GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=_} : _)   = alts
-mkDefaultLitAlt (alt@GenStgAlt{alt_con=LitAlt{}, alt_bndrs=[]} : alts) = alt {alt_con = DEFAULT} : alts
-mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> pprPanicAlts alts)
-
-pprPanicAlts :: OutputablePass pass => [GenStgAlt pass] -> SDoc
-pprPanicAlts alts = ppr (map pprPanicAlt alts)
-
-pprPanicAlt :: OutputablePass pass => GenStgAlt pass -> SDoc
-pprPanicAlt GenStgAlt{alt_con=c,alt_bndrs=b,alt_rhs=e} = ppr (c,b,pprStgExpr panicStgPprOpts e)
diff --git a/compiler/GHC/Stg/Utils.hs b/compiler/GHC/Stg/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/Stg/Utils.hs
+++ /dev/null
@@ -1,125 +0,0 @@
-{-# LANGUAGE CPP, ScopedTypeVariables, TypeFamilies #-}
-{-# LANGUAGE DataKinds #-}
-
-module GHC.Stg.Utils
-    ( mkStgAltTypeFromStgAlts
-    , bindersOf, bindersOfX, bindersOfTop, bindersOfTopBinds
-
-    , stripStgTicksTop, stripStgTicksTopE
-    , idArgs
-
-    , mkUnarisedId, mkUnarisedIds
-    ) where
-
-import GHC.Prelude
-
-import GHC.Types.Id
-import GHC.Core.Type
-import GHC.Core.TyCon
-import GHC.Core.DataCon
-import GHC.Core ( AltCon(..) )
-import GHC.Types.Tickish
-import GHC.Types.Unique.Supply
-
-import GHC.Types.RepType
-import GHC.Stg.Syntax
-
-import GHC.Utils.Outputable
-
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Panic
-
-import GHC.Data.FastString
-
-mkUnarisedIds :: MonadUnique m => FastString -> [UnaryType] -> m [Id]
-mkUnarisedIds fs tys = mapM (mkUnarisedId fs) tys
-
-mkUnarisedId :: MonadUnique m => FastString -> UnaryType -> m Id
-mkUnarisedId s t = mkSysLocalM s ManyTy t
-
--- Checks if id is a top level error application.
--- isErrorAp_maybe :: Id ->
-
--- | Extract the default case alternative
--- findDefaultStg :: [Alt b] -> ([Alt b], Maybe (Expr b))
-findDefaultStg
-  :: [GenStgAlt p]
-  -> ([GenStgAlt p], Maybe (GenStgExpr p))
-findDefaultStg (GenStgAlt{ alt_con    = DEFAULT
-                         , alt_bndrs  = args
-                         , alt_rhs    = rhs} : alts) = assert( null args ) (alts, Just rhs)
-findDefaultStg alts                                  = (alts, Nothing)
-
-mkStgAltTypeFromStgAlts :: forall p. Id -> [GenStgAlt p] -> AltType
-mkStgAltTypeFromStgAlts bndr alts
-  | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty
-  = MultiValAlt (length prim_reps)  -- always use MultiValAlt for unboxed tuples
-
-  | otherwise
-  = case prim_reps of
-      [rep] | isGcPtrRep rep ->
-        case tyConAppTyCon_maybe (unwrapType bndr_ty) of
-          Just tc
-            | isAbstractTyCon tc -> look_for_better_tycon
-            | isAlgTyCon tc      -> AlgAlt tc
-            | otherwise          -> assertPpr ( _is_poly_alt_tycon tc) (ppr tc)
-                                    PolyAlt
-          Nothing                -> PolyAlt
-      [non_gcd] -> PrimAlt non_gcd
-      not_unary -> MultiValAlt (length not_unary)
-  where
-   bndr_ty   = idType bndr
-   prim_reps = typePrimRep bndr_ty
-
-   _is_poly_alt_tycon tc
-        =  isPrimTyCon tc   -- "Any" is lifted but primitive
-        || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict
-                            -- function application where argument has a
-                            -- type-family type
-
-   -- Sometimes, the TyCon is a AbstractTyCon which may not have any
-   -- constructors inside it.  Then we may get a better TyCon by
-   -- grabbing the one from a constructor alternative
-   -- if one exists.
-   look_for_better_tycon
-        | (DataAlt con : _) <- alt_con <$> data_alts =
-                AlgAlt (dataConTyCon con)
-        | otherwise =
-                assert(null data_alts)
-                PolyAlt
-        where
-                (data_alts, _deflt) = findDefaultStg alts
-
-bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id]
-bindersOf (StgNonRec binder _) = [binder]
-bindersOf (StgRec pairs)       = [binder | (binder, _) <- pairs]
-
-bindersOfX :: GenStgBinding a -> [BinderP a]
-bindersOfX (StgNonRec binder _) = [binder]
-bindersOfX (StgRec pairs)       = [binder | (binder, _) <- pairs]
-
-bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]
-bindersOfTop (StgTopLifted bind) = bindersOf bind
-bindersOfTop (StgTopStringLit binder _) = [binder]
-
--- All ids we bind something to on the top level.
-bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id]
--- bindersOfTopBinds binds = mapUnionVarSet (mkVarSet . bindersOfTop) binds
-bindersOfTopBinds binds = foldr ((++) . bindersOfTop) [] binds
-
-idArgs :: [StgArg] -> [Id]
-idArgs args = [v | StgVarArg v <- args]
-
--- | Strip ticks of a given type from an STG expression.
-stripStgTicksTop :: (StgTickish -> Bool) -> GenStgExpr p -> ([StgTickish], GenStgExpr p)
-stripStgTicksTop p = go []
-   where go ts (StgTick t e) | p t = go (t:ts) e
-         -- This special case avoid building a thunk for "reverse ts" when there are no ticks
-         go [] other               = ([], other)
-         go ts other               = (reverse ts, other)
-
--- | Strip ticks of a given type from an STG expression returning only the expression.
-stripStgTicksTopE :: (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p
-stripStgTicksTopE p = go
-   where go (StgTick t e) | p t = go e
-         go other               = other
diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
deleted file mode 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ /dev/null
@@ -1,2104 +0,0 @@
-
-{-# LANGUAGE DeriveFunctor              #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE RecordWildCards            #-}
-{-# LANGUAGE FlexibleContexts           #-}
-
-{-# OPTIONS_GHC -fprof-auto-top #-}
-
---
---  (c) The University of Glasgow 2002-2006
---
-
--- | GHC.StgToByteCode: Generate bytecode from STG
-module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-import GHC.Driver.Env
-
-import GHC.ByteCode.Instr
-import GHC.ByteCode.Asm
-import GHC.ByteCode.Types
-
-import GHC.Cmm.CallConv
-import GHC.Cmm.Expr
-import GHC.Cmm.Node
-import GHC.Cmm.Utils
-
-import GHC.Platform
-import GHC.Platform.Profile
-
-import GHC.Runtime.Interpreter
-import GHCi.FFI
-import GHCi.RemoteTypes
-import GHC.Types.Basic
-import GHC.Utils.Outputable
-import GHC.Types.Name
-import GHC.Types.Id
-import GHC.Types.ForeignCall
-import GHC.Core
-import GHC.Types.Literal
-import GHC.Builtin.PrimOps
-import GHC.Builtin.PrimOps.Ids (primOpId)
-import GHC.Core.Type
-import GHC.Types.RepType
-import GHC.Core.DataCon
-import GHC.Core.TyCon
-import GHC.Utils.Misc
-import GHC.Utils.Logger
-import GHC.Types.Var.Set
-import GHC.Builtin.Types.Prim
-import GHC.Core.TyCo.Ppr ( pprType )
-import GHC.Utils.Error
-import GHC.Types.Unique
-import GHC.Builtin.Uniques
-import GHC.Data.FastString
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Exception (evaluate)
-import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )
-import GHC.StgToCmm.Layout
-import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)
-import GHC.Data.Bitmap
-import GHC.Data.OrdList
-import GHC.Data.Maybe
-import GHC.Types.Var.Env
-import GHC.Types.Tickish
-
-import Data.List ( genericReplicate, genericLength, intersperse
-                 , partition, scanl', sortBy, zip4, zip6 )
-import Foreign hiding (shiftL, shiftR)
-import Control.Monad
-import Data.Char
-
-import GHC.Unit.Module
-
-import Data.Array
-import Data.Coerce (coerce)
-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 GHC.Data.FiniteMap as Map
-import Data.Ord
-import GHC.Stack.CCS
-import Data.Either ( partitionEithers )
-
-import GHC.Stg.Syntax
-import qualified Data.IntSet as IntSet
-
--- -----------------------------------------------------------------------------
--- Generating byte code for a complete module
-
-byteCodeGen :: HscEnv
-            -> Module
-            -> [CgStgTopBinding]
-            -> [TyCon]
-            -> Maybe ModBreaks
-            -> IO CompiledByteCode
-byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
-   = withTiming logger
-                (text "GHC.StgToByteCode"<+>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, lifted_binds) = partitionEithers $ do  -- list monad
-                bnd <- binds
-                case bnd of
-                  StgTopLifted bnd      -> [Right bnd]
-                  StgTopStringLit b str -> [Left (b, str)]
-            flattenBind (StgNonRec b e) = [(b,e)]
-            flattenBind (StgRec bs)     = bs
-        stringPtrs <- allocateTopStrings interp strings
-
-        (BcM_State{..}, proto_bcos) <-
-           runBc hsc_env this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do
-             let flattened_binds = concatMap flattenBind (reverse lifted_binds)
-             mapM schemeTopBind flattened_binds
-
-        when (notNull ffis)
-             (panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?")
-
-        putDumpFileMaybe logger Opt_D_dump_BCOs
-           "Proto-BCOs" FormatByteCode
-           (vcat (intersperse (char ' ') (map ppr proto_bcos)))
-
-        cbc <- assembleBCOs interp profile 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
-        logger  = hsc_logger hsc_env
-        interp  = hscInterp hsc_env
-        profile = targetProfile dflags
-
-allocateTopStrings
-  :: Interp
-  -> [(Id, ByteString)]
-  -> IO [(Var, RemotePtr ())]
-allocateTopStrings interp topStrings = do
-  let !(bndrs, strings) = unzip topStrings
-  ptrs <- interpCmd interp $ 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 interpCmd, in allocateTopStrings
-
-3. The mapping from binders to allocated strings (topStrings) are maintained in
-   BcM and used when generating code for variable references.
--}
-
--- -----------------------------------------------------------------------------
--- Compilation schema for the bytecode generator
-
-type BCInstrList = OrdList BCInstr
-
-wordsToBytes :: Platform -> WordOff -> ByteOff
-wordsToBytes platform = fromIntegral . (* platformWordSizeInBytes platform) . fromIntegral
-
--- Used when we know we have a whole number of words
-bytesToWords :: Platform -> ByteOff -> WordOff
-bytesToWords platform (ByteOff bytes) =
-    let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform)
-    in if r == 0
-           then fromIntegral q
-           else pprPanic "GHC.StgToByteCode.bytesToWords"
-                         (text "bytes=" <> ppr bytes)
-
-wordSize :: Platform -> ByteOff
-wordSize platform = ByteOff (platformWordSizeInBytes platform)
-
-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, ByteOff offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgReps 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
-   :: Platform
-   -> name
-   -> BCInstrList
-   -> Either  [CgStgAlt] (CgStgRhs)
-                -- ^ original expression; for debugging only
-   -> Int       -- ^ arity
-   -> Word16    -- ^ bitmap size
-   -> [StgWord] -- ^ bitmap
-   -> Bool      -- ^ True <=> is a return point, rather than a function
-   -> [FFIInfo]
-   -> ProtoBCO name
-mkProtoBCO platform 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 (pc_AP_STACK_SPLIM (platformConstants platform)) = 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 :: Platform -> [ArgRep] -> [Bool]
-argBits _        [] = []
-argBits platform (rep : args)
-  | isFollowableArg rep  = False : argBits platform args
-  | otherwise = take (argRepSizeW platform rep) (repeat True) ++ argBits platform args
-
-non_void :: [ArgRep] -> [ArgRep]
-non_void = filter nv
-  where nv V = False
-        nv _ = True
-
--- -----------------------------------------------------------------------------
--- schemeTopBind
-
--- Compile code for the right-hand side of a top-level binding
-
-schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name)
-schemeTopBind (id, rhs)
-  | Just data_con <- isDataConWorkId_maybe id,
-    isNullaryRepDataCon data_con = do
-    platform <- profilePlatform <$> getProfile
-        -- 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 platform (getName id) (toOL [PACK data_con 0, RETURN])
-                       (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, CgStgRhs)
-        -> BcM (ProtoBCO Name)
-schemeR fvs (nm, rhs)
-   = schemeR_wrk fvs nm rhs (collect rhs)
-
--- If an expression is a lambda, return the
--- list of arguments to the lambda (in R-to-L order) and the
--- underlying expression
-
-collect :: CgStgRhs -> ([Var], CgStgExpr)
-collect (StgRhsClosure _ _ _ args body) = (args, body)
-collect (StgRhsCon _cc dc cnum _ticks args) = ([], StgConApp dc cnum args [])
-
-schemeR_wrk
-    :: [Id]
-    -> Name
-    -> CgStgRhs            -- expression e, for debugging only
-    -> ([Var], CgStgExpr)  -- result of collect on e
-    -> BcM (ProtoBCO Name)
-schemeR_wrk fvs nm original_body (args, body)
-   = do
-     profile <- getProfile
-     let
-         platform  = profilePlatform profile
-         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 platform . idSizeW platform) 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 platform (reverse (map (bcIdArgRep platform) all_args))
-         bitmap_size = genericLength bits
-         bitmap = mkBitmap platform bits
-     body_code <- schemeER_wrk sum_szsb_args p_init body
-
-     emitBc (mkProtoBCO platform nm body_code (Right original_body)
-                 arity bitmap_size bitmap False{-not alts-})
-
--- introduce break instructions for ticked expressions
-schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList
-schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs) rhs)
-  = do  code <- schemeE d 0 p rhs
-        cc_arr <- getCCArray
-        this_mod <- moduleName <$> getCurrentModule
-        platform <- profilePlatform <$> getProfile
-        let idOffSets = getVarOffSets platform d p fvs
-        let breakInfo = CgBreakInfo
-                        { cgb_vars = idOffSets
-                        , cgb_resty = tick_ty
-                        }
-        newBreakInfo tick_no breakInfo
-        hsc_env <- getHscEnv
-        let cc | Just interp <- hsc_interp hsc_env
-               , interpreterProfiled interp
-               = cc_arr ! tick_no
-               | otherwise = toRemotePtr nullPtr
-        let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
-        return $ breakInstr `consOL` code
-schemeER_wrk d p rhs = schemeE d 0 p rhs
-
-getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]
-getVarOffSets platform 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 platform (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 -> CgStgRhs -> [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 rhs =  [v | v <- dVarSetElems $ freeVarsOfRhs rhs,
-                       v `Map.member` p]
-
--- -----------------------------------------------------------------------------
--- schemeE
-
--- Returning an unlifted value.
--- Heave it on the stack, SLIDE, and RETURN.
-returnUnliftedAtom
-    :: StackDepth
-    -> Sequel
-    -> BCEnv
-    -> StgArg
-    -> BcM BCInstrList
-returnUnliftedAtom d s p e = do
-    let reps = case e of
-                 StgLitArg lit -> typePrimRepArgs (literalType lit)
-                 StgVarArg i   -> bcIdPrimReps i
-    (push, szb) <- pushAtom d p e
-    ret <- returnUnliftedReps d s szb reps
-    return (push `appOL` ret)
-
--- return an unlifted value from the top of the stack
-returnUnliftedReps
-    :: StackDepth
-    -> Sequel
-    -> ByteOff    -- size of the thing we're returning
-    -> [PrimRep]  -- representations
-    -> BcM BCInstrList
-returnUnliftedReps d s szb reps = do
-    profile <- getProfile
-    let platform = profilePlatform profile
-        non_void VoidRep = False
-        non_void _ = True
-    ret <- case filter non_void reps of
-             -- use RETURN_UBX for unary representations
-             []    -> return (unitOL $ RETURN_UNLIFTED V)
-             [rep] -> return (unitOL $ RETURN_UNLIFTED (toArgRep platform rep))
-             -- otherwise use RETURN_TUPLE with a tuple descriptor
-             nv_reps -> do
-               let (tuple_info, args_offsets) = layoutTuple profile 0 (primRepCmmType platform) nv_reps
-                   args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off)) args_offsets
-               tuple_bco <- emitBc (tupleBCO platform tuple_info args_ptrs)
-               return $ PUSH_UBX (mkTupleInfoLit platform tuple_info) 1 `consOL`
-                        PUSH_BCO tuple_bco `consOL`
-                        unitOL RETURN_TUPLE
-    return ( mkSlideB platform szb (d - s) -- clear to sequel
-             `appOL`  ret)                 -- go
-
--- construct and return an unboxed tuple
-returnUnboxedTuple
-    :: StackDepth
-    -> Sequel
-    -> BCEnv
-    -> [StgArg]
-    -> BcM BCInstrList
-returnUnboxedTuple d s p es = do
-    profile <- getProfile
-    let platform = profilePlatform profile
-        arg_ty e = primRepCmmType platform (atomPrimRep e)
-        (tuple_info, tuple_components) = layoutTuple profile d arg_ty es
-        go _   pushes [] = return (reverse pushes)
-        go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a
-                                         massert (off == dd + szb)
-                                         go (dd + szb) (push:pushes) cs
-    pushes <- go d [] tuple_components
-    ret <- returnUnliftedReps d
-                              s
-                              (wordsToBytes platform $ tupleSize tuple_info)
-                              (map atomPrimRep es)
-    return (mconcat pushes `appOL` ret)
-
--- Compile code to apply the given expression to the remaining args
--- on the stack, returning a HNF.
-schemeE
-    :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList
-schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit)
-schemeE d s p (StgApp x [])
-   | not (usePlainReturn (idType x)) = returnUnliftedAtom d s p (StgVarArg x)
--- Delegate tail-calls to schemeT.
-schemeE d s p e@(StgApp {}) = schemeT d s p e
-schemeE d s p e@(StgConApp {}) = schemeT d s p e
-schemeE d s p e@(StgOpApp {}) = schemeT d s p e
-schemeE d s p (StgLetNoEscape xlet bnd body)
-   = schemeE d s p (StgLet xlet bnd body)
-schemeE d s p (StgLet _xlet
-                      (StgNonRec x (StgRhsCon _cc data_con _cnum _ticks args))
-                      body)
-   = 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
-        platform <- targetPlatform <$> getDynFlags
-        let !d2 = d + wordSize platform
-        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 (StgLet _ext binds body) = do
-     platform <- targetPlatform <$> getDynFlags
-     let (xs,rhss) = case binds of StgNonRec x rhs  -> ([x],[rhs])
-                                   StgRec xs_n_rhss -> unzip xs_n_rhss
-         n_binds = genericLength xs
-
-         fvss  = map (fvsToEnv p') rhss
-
-         -- Sizes of free vars
-         size_w = trunc16W . idSizeW platform
-         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 platform))
-         p' = Map.insertList (zipE xs offsets) p
-         d' = d + wordsToBytes platform 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' (StgVarArg 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
-                     StgNonRec id _ -> occNameFS (getOccName id) == tickFS
-                     _other -> False
-
-         compile_bind d' fvs x (rhs::CgStgRhs) 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)
-
-schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs)
-   = panic ("schemeE: Breakpoint without let binding: " ++
-            show bp_id ++
-            " forgot to run bcPrep?")
-
--- ignore other kinds of tick
-schemeE d s p (StgTick _ rhs) = schemeE d s p rhs
-
--- no alts: scrut is guaranteed to diverge
-schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut
-
-schemeE d s p (StgCase scrut bndr _ alts)
-   = doCase d s p scrut bndr alts
-
-
-{-
-   Ticked Expressions
-   ------------------
-
-  The idea is that the "breakpoint<n,fvs> E" is really just an annotation on
-  the code. When we find such a thing, we pull out the useful information,
-  and then compile the code as if it was just the expression E.
--}
-
--- Compile code to do a tail call.  Specifically, push the fn,
--- slide the on-stack app back down to the sequel depth,
--- and enter.  Four cases:
---
--- 0.  (Nasty hack).
---     An application "GHC.Prim.tagToEnum# <type> unboxed-int".
---     The int will be on the stack.  Generate a code sequence
---     to convert it to the relevant constructor, SLIDE and ENTER.
---
--- 1.  The fn denotes a ccall.  Defer to generateCCall.
---
--- 2.  An unboxed tuple: push the components on the top of
---     the stack and return.
---
--- 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
-        -> CgStgExpr
-        -> BcM BCInstrList
-
-   -- Case 0
-schemeT d s p app
-   | Just (arg, constr_names) <- maybe_is_tagToEnum_call app
-   = implement_tagToId d s p arg constr_names
-
-   -- Case 1
-schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _ty) args result_ty)
-   = if isSupportedCConv ccall_spec
-      then generateCCall d s p ccall_spec result_ty (reverse args)
-      else unsupportedCConvException
-
-schemeT d s p (StgOpApp (StgPrimOp op) args _ty)
-   = doTailCall d s p (primOpId op) (reverse args)
-
-schemeT _d _s _p (StgOpApp StgPrimCallOp{} _args _ty)
-   = unsupportedCConvException
-
-   -- Case 2: Unboxed tuple
-schemeT d s p (StgConApp con _cn args _tys)
-   | isUnboxedTupleDataCon con || isUnboxedSumDataCon con
-   = returnUnboxedTuple d s p args
-
-   -- Case 3: Ordinary data constructor
-   | otherwise
-   = do alloc_con <- mkConAppCode d s p con args
-        platform <- profilePlatform <$> getProfile
-        return (alloc_con         `appOL`
-                mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN)
-
-   -- Case 4: Tail call of function
-schemeT d s p (StgApp fn args)
-   = doTailCall d s p fn (reverse args)
-
-schemeT _ _ _ e = pprPanic "GHC.StgToByteCode.schemeT"
-                           (pprStgExpr shortStgPprOpts e)
-
--- -----------------------------------------------------------------------------
--- Generate code to build a constructor application,
--- leaving it on top of the stack
-
-mkConAppCode
-    :: StackDepth
-    -> Sequel
-    -> BCEnv
-    -> DataCon                  -- The data constructor
-    -> [StgArg]                 -- Args, in *reverse* order
-    -> BcM BCInstrList
-mkConAppCode orig_d _ p con args = app_code
-  where
-    app_code = do
-        profile <- getProfile
-        let platform = profilePlatform profile
-
-            non_voids =
-                [ NonVoid (prim_rep, arg)
-                | arg <- args
-                , let prim_rep = atomPrimRep arg
-                , not (isVoidRep prim_rep)
-                ]
-            (_, _, args_offsets) =
-                mkVirtHeapOffsetsWithPadding profile StdHeader non_voids
-
-            do_pushery !d (arg : args) = do
-                (push, arg_bytes) <- case arg of
-                    (Padding l _) -> return $! pushPadding (ByteOff 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 platform (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)
-
--- -----------------------------------------------------------------------------
--- Generate code for a tail-call
-
-doTailCall
-    :: StackDepth
-    -> Sequel
-    -> BCEnv
-    -> Id
-    -> [StgArg]
-    -> BcM BCInstrList
-doTailCall init_d s p fn args = do
-   platform <- profilePlatform <$> getProfile
-   do_pushes init_d args (map (atomRep platform) args)
-  where
-  do_pushes !d [] reps = do
-        assert (null reps) return ()
-        (push_fn, sz) <- pushAtom d p (StgVarArg fn)
-        platform <- profilePlatform <$> getProfile
-        assert (sz == wordSize platform) return ()
-        let slide = mkSlideB platform (d - init_d + wordSize platform) (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
-      platform <- profilePlatform <$> getProfile
-      instrs <- do_pushes (next_d + wordSize platform) 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 argReps
-  | any (`elem` [V16, V32, V64]) argReps
-  = sorry "SIMD vector operations are not available in GHCi"
-findPushSeq _
-  = panic "GHC.StgToByteCode.findPushSeq"
-
--- -----------------------------------------------------------------------------
--- Case expressions
-
-doCase
-    :: StackDepth
-    -> Sequel
-    -> BCEnv
-    -> CgStgExpr
-    -> Id
-    -> [CgStgAlt]
-    -> BcM BCInstrList
-doCase d s p scrut bndr alts
-  = do
-     profile <- getProfile
-     hsc_env <- getHscEnv
-     let
-        platform = profilePlatform profile
-
-        -- Are we dealing with an unboxed tuple with a tuple return frame?
-        --
-        -- 'Simple' tuples with at most one non-void component,
-        -- like (# Word# #) or (# Int#, State# RealWorld# #) do not have a
-        -- tuple return frame. This is because (# foo #) and (# foo, Void# #)
-        -- have the same runtime rep. We have more efficient specialized
-        -- return frames for the situations with one non-void element.
-
-        ubx_tuple_frame =
-          (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) &&
-          length non_void_arg_reps > 1
-
-        ubx_frame = not ubx_tuple_frame && not (usePlainReturn bndr_ty)
-
-        non_void_arg_reps = non_void (typeArgReps platform bndr_ty)
-
-        profiling
-          | Just interp <- hsc_interp hsc_env
-          = interpreterProfiled interp
-          | otherwise = False
-
-        -- 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 | ubx_tuple_frame =
-                             (if profiling then 5 else 4) * wordSize platform
-                         | otherwise = 2 * wordSize platform
-
-        -- The stack space used to save/restore the CCCS when profiling
-        save_ccs_size_b | profiling &&
-                          not ubx_tuple_frame = 2 * wordSize platform
-                        | otherwise = 0
-
-        -- The size of the return frame info table pointer if one exists
-        unlifted_itbl_size_b :: StackDepth
-        unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform
-                             | ubx_frame       = wordSize platform
-                             | otherwise       = 0
-
-        (bndr_size, tuple_info, args_offsets)
-           | ubx_tuple_frame =
-               let bndr_ty = primRepCmmType platform
-                   bndr_reps = filter (not.isVoidRep) (bcIdPrimReps bndr)
-                   (tuple_info, args_offsets) =
-                       layoutTuple profile 0 bndr_ty bndr_reps
-               in ( wordsToBytes platform (tupleSize tuple_info)
-                  , tuple_info
-                  , args_offsets
-                  )
-           | otherwise = ( wordsToBytes platform (idSizeW platform bndr)
-                         , voidTupleInfo
-                         , []
-                         )
-
-        -- depth of stack after the return value has been pushed
-        d_bndr =
-            d + ret_frame_size_b + bndr_size
-
-        -- depth of stack after the extra info table for an unlifted return
-        -- has been pushed, if any.  This is the stack depth at the
-        -- continuation.
-        d_alts = d + ret_frame_size_b + bndr_size + unlifted_itbl_size_b
-
-        -- Env in which to compile the alts, not including
-        -- any vars bound by the alts themselves
-        p_alts = Map.insert bndr d_bndr p
-
-        bndr_ty = idType bndr
-        isAlgCase = isAlgType bndr_ty
-
-        -- given an alt, return a discr and code for it.
-        codeAlt :: CgStgAlt -> BcM (Discr, BCInstrList)
-        codeAlt GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=rhs}
-           = do rhs_code <- schemeE d_alts s p_alts rhs
-                return (NoDiscr, rhs_code)
-
-        codeAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=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)
-           | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty =
-             let bndr_ty = primRepCmmType platform . bcIdPrimRep
-                 tuple_start = d_bndr
-                 (tuple_info, args_offsets) =
-                   layoutTuple profile
-                               0
-                               bndr_ty
-                               bndrs
-
-                 stack_bot = d_alts
-
-                 p' = Map.insertList
-                        [ (arg, tuple_start -
-                                wordsToBytes platform (tupleSize tuple_info) +
-                                offset)
-                        | (arg, offset) <- args_offsets
-                        , not (isVoidRep $ bcIdPrimRep arg)]
-                        p_alts
-             in do
-               rhs_code <- schemeE stack_bot s p' rhs
-               return (NoDiscr, rhs_code)
-           -- algebraic alt with some binders
-           | otherwise =
-             let (tot_wds, _ptrs_wds, args_offsets) =
-                     mkVirtHeapOffsets profile NoHeader
-                         [ NonVoid (bcIdPrimRep id, id)
-                         | NonVoid id <- nonVoidIds real_bndrs
-                         ]
-                 size = WordOff tot_wds
-
-                 stack_bot = d_alts + wordsToBytes platform 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 alt = case alt_con alt of
-            DEFAULT    -> NoDiscr {-shouldn't really happen-}
-            DataAlt dc
-              | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc
-              -> NoDiscr
-              | otherwise
-              -> DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
-            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(StgCase).my_discr" (ppr l)
-
-        maybe_ncons
-           | not isAlgCase = Nothing
-           | otherwise
-           = case [dc | DataAlt dc <- alt_con <$> 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.
-
-        -- unboxed tuples get two more words, the second is a pointer (tuple_bco)
-        (extra_pointers, extra_slots)
-           | ubx_tuple_frame && profiling = ([1], 3) -- tuple_info, tuple_BCO, CCCS
-           | ubx_tuple_frame              = ([1], 2) -- tuple_info, tuple_BCO
-           | otherwise                    = ([], 0)
-
-        bitmap_size = trunc16W $ fromIntegral extra_slots +
-                                 bytesToWords platform (d - s)
-
-        bitmap_size' :: Int
-        bitmap_size' = fromIntegral bitmap_size
-
-
-        pointers =
-          extra_pointers ++
-          filter (< bitmap_size') (map (+extra_slots) rel_slots)
-          where
-          -- 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:
-          -- 'toAscList' takes care of sorting the result, which was previously done after the application of 'filter'.
-          rel_slots = IntSet.toAscList $ IntSet.fromList $ Map.elems $ Map.mapMaybeWithKey spread p
-          spread id offset | isUnboxedTupleType (idType id) ||
-                             isUnboxedSumType (idType id) = Nothing
-                           | isFollowableArg (bcIdArgRep platform id) = Just (fromIntegral rel_offset)
-                           | otherwise                      = Nothing
-                where rel_offset = trunc16W $ bytesToWords platform (d - offset)
-
-        bitmap = intsToReverseBitmap platform bitmap_size'{-size-} pointers
-
-     alt_stuff <- mapM codeAlt alts
-     alt_final0 <- mkMultiBranch maybe_ncons alt_stuff
-
-     let alt_final
-           | ubx_tuple_frame    = mkSlideW 0 2 `mappend` alt_final0
-           | otherwise          = alt_final0
-
-     let
-         alt_bco_name = getName bndr
-         alt_bco = mkProtoBCO platform alt_bco_name alt_final (Left alts)
-                       0{-no arity-} bitmap_size bitmap True{-is alts-}
-     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
-     if ubx_tuple_frame
-       then do
-              let args_ptrs =
-                    map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off))
-                        args_offsets
-              tuple_bco <- emitBc (tupleBCO platform tuple_info args_ptrs)
-              return (PUSH_ALTS_TUPLE alt_bco' tuple_info tuple_bco
-                      `consOL` scrut_code)
-       else let push_alts
-                  | not ubx_frame
-                  = PUSH_ALTS alt_bco'
-                  | otherwise
-                  = let unlifted_rep =
-                          case non_void_arg_reps of
-                            []    -> V
-                            [rep] -> rep
-                            _     -> panic "schemeE(StgCase).push_alts"
-                    in PUSH_ALTS_UNLIFTED alt_bco' unlifted_rep
-            in return (push_alts `consOL` scrut_code)
-
-
--- -----------------------------------------------------------------------------
--- Deal with tuples
-
--- The native calling convention uses registers for tuples, but in the
--- bytecode interpreter, all values live on the stack.
-
-layoutTuple :: Profile
-            -> ByteOff
-            -> (a -> CmmType)
-            -> [a]
-            -> ( TupleInfo      -- See Note [GHCi TupleInfo]
-               , [(a, ByteOff)] -- argument, offset on stack
-               )
-layoutTuple profile start_off arg_ty reps =
-  let platform = profilePlatform profile
-      (orig_stk_bytes, pos) = assignArgumentsPos profile
-                                                 0
-                                                 NativeReturn
-                                                 arg_ty
-                                                 reps
-
-      -- keep the stack parameters in the same place
-      orig_stk_params = [(x, fromIntegral off) | (x, StackParam off) <- pos]
-
-      -- sort the register parameters by register and add them to the stack
-      regs_order :: Map.Map GlobalReg Int
-      regs_order = Map.fromList $ zip (tupleRegsCover platform) [0..]
-
-      reg_order :: GlobalReg -> (Int, GlobalReg)
-      reg_order reg | Just n <- Map.lookup reg regs_order = (n, reg)
-      -- a VanillaReg goes to the same place regardless of whether it
-      -- contains a pointer
-      reg_order (VanillaReg n VNonGcPtr) = reg_order (VanillaReg n VGcPtr)
-      -- if we don't have a position for a FloatReg then they must be passed
-      -- in the equivalent DoubleReg
-      reg_order (FloatReg n) = reg_order (DoubleReg n)
-      -- one-tuples can be passed in other registers, but then we don't need
-      -- to care about the order
-      reg_order reg          = (0, reg)
-
-      (regs, reg_params)
-          = unzip $ sortBy (comparing fst)
-                           [(reg_order reg, x) | (x, RegisterParam reg) <- pos]
-
-      (new_stk_bytes, new_stk_params) = assignStack platform
-                                                    orig_stk_bytes
-                                                    arg_ty
-                                                    reg_params
-
-      regs_set = mkRegSet (map snd regs)
-
-      get_byte_off (x, StackParam y) = (x, fromIntegral y)
-      get_byte_off _                 =
-          panic "GHC.StgToByteCode.layoutTuple get_byte_off"
-
-  in ( TupleInfo
-         { tupleSize        = bytesToWords platform (ByteOff new_stk_bytes)
-         , tupleRegs        = regs_set
-         , tupleNativeStackSize = bytesToWords platform
-                                               (ByteOff orig_stk_bytes)
-         }
-     , sortBy (comparing snd) $
-              map (\(x, o) -> (x, o + start_off))
-                  (orig_stk_params ++ map get_byte_off new_stk_params)
-     )
-
-{-
-  We use the plain return convention (ENTER/PUSH_ALTS) for
-  lifted types and unlifted algebraic types.
-
-  Other types use PUSH_ALTS_UNLIFTED/PUSH_ALTS_TUPLE which expect
-  additional data on the stack.
- -}
-usePlainReturn :: Type -> Bool
-usePlainReturn t
-  | isUnboxedTupleType t || isUnboxedSumType t = False
-  | otherwise = typePrimRep t == [LiftedRep] ||
-                (typePrimRep t == [UnliftedRep] && isAlgType t)
-
-{- Note [unboxed tuple bytecodes and tuple_BCO]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to
-  return and receive arbitrary unboxed tuples, respectively. These
-  instructions use the helper data tuple_BCO and tuple_info.
-
-  The helper data is used to convert tuples between GHCs native calling
-  convention (object code), which uses stack and registers, and the bytecode
-  calling convention, which only uses the stack. See Note [GHCi TupleInfo]
-  for more details.
-
-
-  Returning a tuple
-  =================
-
-  Bytecode that returns a tuple first pushes all the tuple fields followed
-  by the appropriate tuple_info and tuple_BCO onto the stack. It then
-  executes the RETURN_TUPLE instruction, which causes the interpreter
-  to push stg_ret_t_info to the top of the stack. The stack (growing down)
-  then looks as follows:
-
-      ...
-      next_frame
-      tuple_field_1
-      tuple_field_2
-      ...
-      tuple_field_n
-      tuple_info
-      tuple_BCO
-      stg_ret_t_info <- Sp
-
-  If next_frame is bytecode, the interpreter will start executing it. If
-  it's object code, the interpreter jumps back to the scheduler, which in
-  turn jumps to stg_ret_t. stg_ret_t converts the tuple to the native
-  calling convention using the description in tuple_info, and then jumps
-  to next_frame.
-
-
-  Receiving a tuple
-  =================
-
-  Bytecode that receives a tuple uses the PUSH_ALTS_TUPLE instruction to
-  push a continuation, followed by jumping to the code that produces the
-  tuple. The PUSH_ALTS_TUPLE instuction contains three pieces of data:
-
-     * cont_BCO: the continuation that receives the tuple
-     * tuple_info: see below
-     * tuple_BCO: see below
-
-  The interpreter pushes these onto the stack when the PUSH_ALTS_TUPLE
-  instruction is executed, followed by stg_ctoi_tN_info, with N depending
-  on the number of stack words used by the tuple in the GHC native calling
-  convention. N is derived from tuple_info.
-
-  For example if we expect a tuple with three words on the stack, the stack
-  looks as follows after PUSH_ALTS_TUPLE:
-
-      ...
-      next_frame
-      cont_free_var_1
-      cont_free_var_2
-      ...
-      cont_free_var_n
-      tuple_info
-      tuple_BCO
-      cont_BCO
-      stg_ctoi_t3_info <- Sp
-
-  If the tuple is returned by object code, stg_ctoi_t3 will deal with
-  adjusting the stack pointer and converting the tuple to the bytecode
-  calling convention. See Note [GHCi unboxed tuples stack spills] for more
-  details.
-
-
-  The tuple_BCO
-  =============
-
-  The tuple_BCO is a helper bytecode object. Its main purpose is describing
-  the contents of the stack frame containing the tuple for the storage
-  manager. It contains only instructions to immediately return the tuple
-  that is already on the stack.
-
-
-  The tuple_info word
-  ===================
-
-  The tuple_info word describes the stack and STG register (e.g. R1..R6,
-  D1..D6) usage for the tuple. tuple_info contains enough information to
-  convert the tuple between the stack-only bytecode and stack+registers
-  GHC native calling conventions.
-
-  See Note [GHCi tuple layout] for more details of how the data is packed
-  in a single word.
-
- -}
-
-tupleBCO :: Platform -> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
-tupleBCO platform info pointers =
-  mkProtoBCO platform invented_name body_code (Left [])
-             0{-no arity-} bitmap_size bitmap False{-is alts-}
-
-  where
-    {-
-      The tuple BCO is never referred to by name, so we can get away
-      with using a fake name here. We will need to change this if we want
-      to save some memory by sharing the BCO between places that have
-      the same tuple shape
-    -}
-    invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "tuple")
-
-    -- the first word in the frame is the tuple_info word,
-    -- which is not a pointer
-    bitmap_size = trunc16W $ 1 + tupleSize info
-    bitmap      = intsToReverseBitmap platform (fromIntegral bitmap_size) $
-                  map ((+1) . fromIntegral . bytesToWords platform . snd)
-                      (filter fst pointers)
-    body_code = mkSlideW 0 1          -- pop frame header
-                `snocOL` RETURN_TUPLE -- and add it again
-
--- -----------------------------------------------------------------------------
--- 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
-    -> Type
-    -> [StgArg]              -- args (atoms)
-    -> BcM BCInstrList
-generateCCall d0 s p (CCallSpec target cconv safety) result_ty args_r_to_l
- = do
-     profile <- getProfile
-
-     let
-         platform = profilePlatform profile
-         -- useful constants
-         addr_size_b :: ByteOff
-         addr_size_b = wordSize platform
-
-         arrayish_rep_hdr_size :: TyCon -> Maybe Int
-         arrayish_rep_hdr_size t
-           | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
-              = Just (arrPtrsHdrSize profile)
-           | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
-              = Just (smallArrPtrsHdrSize profile)
-           | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
-              = Just (arrWordsHdrSize profile)
-           | otherwise
-              = Nothing
-
-         -- 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 -> [StgArg] -> BcM [(BCInstrList, PrimRep)]
-         pargs _ [] = return []
-         pargs d (aa@(StgVarArg a):az)
-            | Just t      <- tyConAppTyCon_maybe (idType a)
-            , Just hdr_sz <- arrayish_rep_hdr_size t
-            -- 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.
-            = do rest <- pargs (d + addr_size_b) az
-                 (push_fo, _) <- pushAtom d p aa
-                 -- The ptr points at the header.  Advance it over the
-                 -- header and then pretend this is an Addr#.
-                 let code = push_fo `snocOL` SWIZZLE 0 (fromIntegral hdr_sz)
-                 return ((code, AddrRep) : rest)
-         pargs d (aa:az) =  do (code_a, sz_a) <- pushAtom d p aa
-                               rest <- pargs (d + sz_a) az
-                               return ((code_a, atomPrimRep aa) : rest)
-
-     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 platform) a_reps_pushed_r_to_l)
-
-         push_args    = concatOL pushs_arg
-         !d_after_args = d0 + wordsToBytes platform a_reps_sizeW
-         a_reps_pushed_RAW
-            | x:xs <- a_reps_pushed_r_to_l
-            , isVoidRep x
-            = reverse xs
-            | otherwise
-            = panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?"
-
-         -- 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 result_ty 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 marshal 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 marshal_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 platform
-                          , StdCallConv <- cconv
-                          = Just (fromIntegral a_reps_sizeW * platformWordSizeInBytes platform)
-                          | 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
-                | _:xs <- a_reps_pushed_RAW = xs
-                | otherwise = panic "GHC.StgToByteCode.generateCCall: dyn with no args"
-
-         -- 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 platform r_rep
-         d_after_r = d_after_Addr + wordsToBytes platform r_sizeW
-         push_r =
-             if returns_void
-                then nilOL
-                else unitOL (PUSH_UBX (mkDummyLiteral platform 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 platform (d_after_r - s)
-
-         conv = case cconv of
-           CCallConv -> FFICCall
-           CApiConv  -> FFICCall
-           StdCallConv -> FFIStdCall
-           _ -> panic "GHC.StgToByteCode: 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 platform r_rep
-         ffiargs = map (primRepToFFIType platform) a_reps
-     interp <- hscInterp <$> getHscEnv
-     token <- ioToBc $ interpCmd interp (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 platform (d_after_r - s)
-         wrapup       = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)
-                        `snocOL` RETURN_UNLIFTED (toArgRep platform 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 :: Platform -> PrimRep -> FFIType
-primRepToFFIType platform r
-  = case r of
-     VoidRep     -> FFIVoid
-     IntRep      -> signed_word
-     WordRep     -> unsigned_word
-     Int8Rep     -> FFISInt8
-     Word8Rep    -> FFIUInt8
-     Int16Rep    -> FFISInt16
-     Word16Rep   -> FFIUInt16
-     Int32Rep    -> FFISInt32
-     Word32Rep   -> FFIUInt32
-     Int64Rep    -> FFISInt64
-     Word64Rep   -> FFIUInt64
-     AddrRep     -> FFIPointer
-     FloatRep    -> FFIFloat
-     DoubleRep   -> FFIDouble
-     LiftedRep   -> FFIPointer
-     UnliftedRep -> FFIPointer
-     _           -> pprPanic "primRepToFFIType" (ppr r)
-  where
-    (signed_word, unsigned_word) = case platformWordSize platform of
-       PW4 -> (FFISInt32, FFIUInt32)
-       PW8 -> (FFISInt64, FFIUInt64)
-
--- Make a dummy literal, to be used as a placeholder for FFI return
--- values on the stack.
-mkDummyLiteral :: Platform -> PrimRep -> Literal
-mkDummyLiteral platform pr
-   = case pr of
-        IntRep      -> mkLitInt  platform 0
-        WordRep     -> mkLitWord platform 0
-        Int8Rep     -> mkLitInt8 0
-        Word8Rep    -> mkLitWord8 0
-        Int16Rep    -> mkLitInt16 0
-        Word16Rep   -> mkLitWord16 0
-        Int32Rep    -> mkLitInt32 0
-        Word32Rep   -> mkLitWord32 0
-        Int64Rep    -> mkLitInt64 0
-        Word64Rep   -> mkLitWord64 0
-        AddrRep     -> LitNullAddr
-        DoubleRep   -> LitDouble 0
-        FloatRep    -> LitFloat 0
-        LiftedRep   -> LitNullAddr
-        UnliftedRep -> LitNullAddr
-        _         -> 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]         -> Just rep
-
-                 -- if it was, it would be impossible to create a
-                 -- valid return value placeholder on the stack
-         _             -> blargh
-
-maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name])
--- Detect and extract relevant info for the tagToEnum kludge.
-maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) [StgVarArg v] t)
-  = Just (v, extract_constr_Names t)
-  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 "GHC.Core.DataCon" for details.
-           | otherwise
-           = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
-maybe_is_tagToEnum_call _ = Nothing
-
-{- -----------------------------------------------------------------------------
-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
-    -> Id
-    -> [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 (StgVarArg arg)
-       labels <- getLabelsBc (genericLength names)
-       label_fail <- getLabelBc
-       label_exit <- getLabelBc
-       dflags <- getDynFlags
-       let infos = zip4 labels (tail labels ++ [label_fail])
-                               [0 ..] names
-           platform = targetPlatform dflags
-           steps = map (mkStep label_exit) infos
-           slide_ws = bytesToWords platform (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 -> StgArg -> BcM (BCInstrList, ByteOff)
-
--- See Note [Empty case alternatives] in GHC.Core
--- and Note [Bottoming expressions] in GHC.Core.Utils:
--- The scrutinee of an empty case evaluates to bottom
-pushAtom d p (StgVarArg 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
-       platform <- targetPlatform <$> getDynFlags
-       return (unitOL (PUSH_PRIMOP primop), wordSize platform)
-
-   | Just d_v <- lookupBCEnv_maybe var p  -- var is a local variable
-   = do platform <- targetPlatform <$> getDynFlags
-
-        let !szb = idSizeCon platform var
-            with_instr instr = do
-                let !off_b = trunc16B $ d - d_v
-                return (unitOL (instr off_b), wordSize platform)
-
-        case szb of
-            1 -> with_instr PUSH8_W
-            2 -> with_instr PUSH16_W
-            4 -> with_instr PUSH32_W
-            _ -> do
-                let !szw = bytesToWords platform szb
-                    !off_w = trunc16W $ bytesToWords platform (d - d_v) + szw - 1
-                return (toOL (genericReplicate szw (PUSH_L off_w)),
-                              wordsToBytes platform szw)
-        -- 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
-        platform <- targetPlatform <$> getDynFlags
-        case lookupVarEnv topStrings var of
-            Just ptr -> pushAtom d p $ StgLitArg $ mkLitWord platform $
-              fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
-            Nothing
-              -- PUSH_G doesn't tag constructors. So we use PACK here
-              -- if we are dealing with nullary constructor.
-              | Just con <- isDataConWorkId_maybe var
-              -> do
-                  massert (sz == wordSize platform)
-                  massert (isNullaryRepDataCon con)
-                  return (unitOL (PACK con 0), sz)
-              | otherwise
-              -> do
-                  let
-                  massert (sz == wordSize platform)
-                  return (unitOL (PUSH_G (getName var)), sz)
-              where
-                !sz = idSizeCon platform var
-
-
-pushAtom _ _ (StgLitArg lit) = pushLiteral True lit
-
-pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff)
-pushLiteral padded lit =
-  do
-     platform <- targetPlatform <$> getDynFlags
-     let code :: PrimRep -> BcM (BCInstrList, ByteOff)
-         code rep =
-            return (padding_instr `snocOL` instr, size_bytes + padding_bytes)
-          where
-            size_bytes = ByteOff $ primRepSizeB platform rep
-
-            -- Here we handle the non-word-width cases specifically since we
-            -- must emit different bytecode for them.
-
-            round_to_words (ByteOff bytes) =
-              ByteOff (roundUpToWords platform bytes)
-
-            padding_bytes
-                | padded    = round_to_words size_bytes - size_bytes
-                | otherwise = 0
-
-            (padding_instr, _) = pushPadding padding_bytes
-
-            instr =
-              case size_bytes of
-                1  -> PUSH_UBX8 lit
-                2  -> PUSH_UBX16 lit
-                4  -> PUSH_UBX32 lit
-                _  -> PUSH_UBX lit (trunc16W $ bytesToWords platform size_bytes)
-
-     case lit of
-        LitLabel {}     -> code AddrRep
-        LitFloat {}     -> code FloatRep
-        LitDouble {}    -> code DoubleRep
-        LitChar {}      -> code WordRep
-        LitNullAddr     -> code AddrRep
-        LitString {}    -> code AddrRep
-        LitRubbish _ rep-> case runtimeRepPrimRep (text "pushLiteral") rep of
-                             [pr] -> code pr
-                             _    -> pprPanic "pushLiteral" (ppr lit)
-        LitNumber nt _  -> case nt of
-          LitNumInt     -> code IntRep
-          LitNumWord    -> code WordRep
-          LitNumInt8    -> code Int8Rep
-          LitNumWord8   -> code Word8Rep
-          LitNumInt16   -> code Int16Rep
-          LitNumWord16  -> code Word16Rep
-          LitNumInt32   -> code Int32Rep
-          LitNumWord32  -> code Word32Rep
-          LitNumInt64   -> code Int64Rep
-          LitNumWord64  -> code Word64Rep
-          -- No LitNumBigNat should be left by the time this is called. CorePrep
-          -- should have converted them all to a real core representation.
-          LitNumBigNat  -> panic "pushAtom: LitNumBigNat"
-
--- | 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 -> StgArg -> BcM (BCInstrList, ByteOff)
-pushConstrAtom _ _ (StgLitArg lit) = pushLiteral False lit
-
-pushConstrAtom d p va@(StgVarArg v)
-    | Just d_v <- lookupBCEnv_maybe v p = do  -- v is a local variable
-        platform <- targetPlatform <$> getDynFlags
-        let !szb = idSizeCon platform 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 va
-
-pushConstrAtom d p expr = pushAtom d p expr
-
-pushPadding :: ByteOff -> (BCInstrList, ByteOff)
-pushPadding (ByteOff 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) = case notd_ways of
-            [] -> panic "mkMultiBranch: awesome foursome"
-            (discr, _):_ -> case discr 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 :: Platform -> Id -> WordOff
-idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform
-
-idSizeCon :: Platform -> Id -> ByteOff
-idSizeCon platform var
-  -- unboxed tuple components are padded to word size
-  | isUnboxedTupleType (idType var) ||
-    isUnboxedSumType (idType var) =
-    wordsToBytes platform .
-    WordOff . sum . map (argRepSizeW platform . toArgRep platform) .
-    bcIdPrimReps $ var
-  | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var))
-
-bcIdArgRep :: Platform -> Id -> ArgRep
-bcIdArgRep platform = toArgRep platform . bcIdPrimRep
-
-bcIdPrimRep :: Id -> PrimRep
-bcIdPrimRep id
-  | [rep] <- typePrimRepArgs (idType id)
-  = rep
-  | otherwise
-  = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
-
-
-bcIdPrimReps :: Id -> [PrimRep]
-bcIdPrimReps id = typePrimRepArgs (idType id)
-
-repSizeWords :: Platform -> PrimRep -> WordOff
-repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep)
-
-isFollowableArg :: ArgRep -> Bool
-isFollowableArg P = True
-isFollowableArg _ = False
-
--- | 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             -> True
-
--- 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 :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr
-mkSlideB platform !nb !db = mkSlideW n d
-  where
-    !n = trunc16W $ bytesToWords platform nb
-    !d = bytesToWords platform 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
-
-atomPrimRep :: StgArg -> PrimRep
-atomPrimRep (StgVarArg v) = bcIdPrimRep v
-atomPrimRep (StgLitArg l) = typePrimRep1 (literalType l)
-
-atomRep :: Platform -> StgArg -> ArgRep
-atomRep platform e = toArgRep platform (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)
-
-typeArgReps :: Platform -> Type -> [ArgRep]
-typeArgReps platform = map (toArgRep platform) . typePrimRepArgs
-
--- -----------------------------------------------------------------------------
--- The bytecode generator's monad
-
-data BcM_State
-   = BcM_State
-        { bcm_hsc_env :: HscEnv
-        , thisModule  :: Module          -- current module (for breakpoints)
-        , nextlabel   :: Word32          -- 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 -> Module -> Maybe ModBreaks
-      -> IdEnv (RemotePtr ())
-      -> BcM r
-      -> IO (BcM_State, r)
-runBc hsc_env this_mod modBreaks topStrings (BcM m)
-   = m (BcM_State hsc_env 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)
-
-getProfile :: BcM Profile
-getProfile = targetProfile <$> getDynFlags
-
-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 LocalLabel
-getLabelBc
-  = BcM $ \st -> do let nl = nextlabel st
-                    when (nl == maxBound) $
-                        panic "getLabelBc: Ran out of labels"
-                    return (st{nextlabel = nl + 1}, LocalLabel nl)
-
-getLabelsBc :: Word32 -> BcM [LocalLabel]
-getLabelsBc n
-  = BcM $ \st -> let ctr = nextlabel st
-                 in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1])
-
-getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
-getCCArray = BcM $ \st ->
-  let breaks = expectJust "GHC.StgToByteCode.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)}, ())
-
-getCurrentModule :: BcM Module
-getCurrentModule = BcM $ \st -> return (st, thisModule st)
-
-getTopStrings :: BcM (IdEnv (RemotePtr ()))
-getTopStrings = BcM $ \st -> return (st, topStrings st)
-
-tickFS :: FastString
-tickFS = fsLit "ticked"
diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm.hs
+++ /dev/null
@@ -1,280 +0,0 @@
-
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE LambdaCase #-}
-
------------------------------------------------------------------------------
---
--- Stg to C-- code generation
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm ( codeGen ) where
-
-import GHC.Prelude as Prelude
-
-import GHC.StgToCmm.Prof (initCostCentres, ldvEnter)
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Env
-import GHC.StgToCmm.Bind
-import GHC.StgToCmm.DataCon
-import GHC.StgToCmm.Layout
-import GHC.StgToCmm.Utils
-import GHC.StgToCmm.Closure
-import GHC.StgToCmm.Config
-import GHC.StgToCmm.Hpc
-import GHC.StgToCmm.Ticky
-import GHC.StgToCmm.Types (ModuleLFInfos)
-
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Cmm.CLabel
-import GHC.Cmm.Graph
-
-import GHC.Stg.Syntax
-
-import GHC.Types.CostCentre
-import GHC.Types.IPE
-import GHC.Types.HpcInfo
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.RepType
-import GHC.Types.Basic
-import GHC.Types.Var.Set ( isEmptyDVarSet )
-import GHC.Types.Unique.FM
-import GHC.Types.Name.Env
-
-import GHC.Core.DataCon
-import GHC.Core.TyCon
-import GHC.Core.Multiplicity
-
-import GHC.Unit.Module
-
-import GHC.Utils.Error
-import GHC.Utils.Outputable
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Logger
-
-import GHC.Utils.TmpFs
-
-import GHC.Data.Stream
-import GHC.Data.OrdList
-import GHC.Types.Unique.Map
-
-import Control.Monad (when,void, forM_)
-import GHC.Utils.Misc
-import System.IO.Unsafe
-import qualified Data.ByteString as BS
-import Data.IORef
-import GHC.Utils.Panic (assertPpr)
-
-codeGen :: Logger
-        -> TmpFs
-        -> StgToCmmConfig
-        -> InfoTableProvMap
-        -> [TyCon]
-        -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
-        -> [CgStgTopBinding]           -- Bindings to convert
-        -> HpcInfo
-        -> Stream IO CmmGroup ModuleLFInfos       -- Output as a stream, so codegen can
-                                       -- be interleaved with output
-
-codeGen logger tmpfs cfg (InfoTableProvMap (UniqMap denv) _ _) data_tycons
-        cost_centre_info stg_binds hpc_info
-  = do  {     -- cg: run the code generator, and yield the resulting CmmGroup
-              -- Using an IORef to store the state is a bit crude, but otherwise
-              -- we would need to add a state monad layer which regresses
-              -- allocations by 0.5-2%.
-        ; cgref <- liftIO $ initC >>= \s -> newIORef s
-        ; let cg :: FCode a -> Stream IO CmmGroup a
-              cg fcode = do
-                (a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do
-                         st <- readIORef cgref
-                         let fstate = initFCodeState $ stgToCmmPlatform cfg
-                         let (a,st') = runC cfg fstate st (getCmm fcode)
-
-                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes
-                         -- a big space leak.  DO NOT REMOVE!
-                         -- This is observed by the #3294 test
-                         writeIORef cgref $! (st'{ cgs_tops = nilOL, cgs_stmts = mkNop })
-                         return a
-                yield cmm
-                return a
-
-               -- Note [codegen-split-init] the cmm_init block must come
-               -- FIRST.  This is because when -split-objs is on we need to
-               -- combine this block with its initialisation routines; see
-               -- Note [pipeline-split-init].
-        ; cg (mkModuleInit cost_centre_info (stgToCmmThisModule cfg) hpc_info)
-
-        ; mapM_ (cg . cgTopBinding logger tmpfs cfg) stg_binds
-                -- Put datatype_stuff after code_stuff, because the
-                -- datatype closure table (for enumeration types) to
-                -- (say) PrelBase_True_closure, which is defined in
-                -- code_stuff
-        ; let do_tycon tycon = do
-                -- Generate a table of static closures for an
-                -- enumeration type Note that the closure pointers are
-                -- tagged.
-                 when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
-                 -- Emit normal info_tables, for data constructors defined in this module.
-                 mapM_ (cg . cgDataCon DefinitionSite) (tyConDataCons tycon)
-
-        ; mapM_ do_tycon data_tycons
-
-        -- Emit special info tables for everything used in this module
-        -- This will only do something if  `-fdistinct-info-tables` is turned on.
-        ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite (stgToCmmThisModule cfg) k) dc)) (nonDetEltsUFM denv)
-
-        ; final_state <- liftIO (readIORef cgref)
-        ; let cg_id_infos = cgs_binds final_state
-
-          -- See Note [Conveying CAF-info and LFInfo between modules] in
-          -- GHC.StgToCmm.Types
-        ; let extractInfo info = (name, lf)
-                where
-                  !name = idName (cg_id info)
-                  !lf = cg_lf info
-
-              !generatedInfo
-                | stgToCmmOmitIfPragmas cfg
-                = emptyNameEnv
-                | otherwise
-                = mkNameEnv (Prelude.map extractInfo (nonDetEltsUFM cg_id_infos))
-
-        ; return generatedInfo
-        }
-
----------------------------------------------------------------
---      Top-level bindings
----------------------------------------------------------------
-
-{- 'cgTopBinding' is only used for top-level bindings, since they need
-to be allocated statically (not in the heap) and need to be labelled.
-No unboxed bindings can happen at top level.
-
-In the code below, the static bindings are accumulated in the
-@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
-This is so that we can write the top level processing in a compositional
-style, with the increasing static environment being plumbed as a state
-variable. -}
-
-cgTopBinding :: Logger -> TmpFs -> StgToCmmConfig -> CgStgTopBinding -> FCode ()
-cgTopBinding logger tmpfs cfg = \case
-    StgTopLifted (StgNonRec id rhs) -> do
-        let (info, fcode) = cgTopRhs cfg NonRecursive id rhs
-        fcode
-        addBindC info
-
-    StgTopLifted (StgRec pairs) -> do
-        let (bndrs, rhss) = unzip pairs
-        let pairs' = zip bndrs rhss
-            r = unzipWith (cgTopRhs cfg Recursive) pairs'
-            (infos, fcodes) = unzip r
-        addBindsC infos
-        sequence_ fcodes
-
-    StgTopStringLit id str -> do
-        let label = mkBytesLabel (idName id)
-        -- emit either a CmmString literal or dump the string in a file and emit a
-        -- CmmFileEmbed literal.  If binary blobs aren't supported,
-        -- the threshold in `cfg` will be 0.
-        -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr
-        let asString = case stgToCmmBinBlobThresh cfg of
-              Just bin_blob_threshold -> fromIntegral (BS.length str) <= bin_blob_threshold
-              Nothing                -> True
-
-            (lit,decl) = if asString
-              then mkByteStringCLit label str
-              else unsafePerformIO $ do
-                     bFile <- newTempName logger tmpfs (stgToCmmTmpDir cfg) TFL_CurrentModule ".dat"
-                     BS.writeFile bFile str
-                     return $ mkFileEmbedLit label bFile (BS.length str)
-        emitDecl decl
-        addBindC (litIdInfo (stgToCmmPlatform cfg) id mkLFStringLit lit)
-
-
-cgTopRhs :: StgToCmmConfig -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
-        -- The Id is passed along for setting up a binding...
-
-cgTopRhs cfg _rec bndr (StgRhsCon _cc con mn _ts args)
-  = cgTopRhsCon cfg bndr con mn (assertNonVoidStgArgs args)
-      -- con args are always non-void,
-      -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
-
-cgTopRhs cfg rec bndr (StgRhsClosure fvs cc upd_flag args body)
-  = assertPpr (isEmptyDVarSet fvs) (text "fvs:" <> ppr fvs) $   -- There should be no free variables
-    cgTopRhsClosure (stgToCmmPlatform cfg) rec bndr cc upd_flag args body
-
-
----------------------------------------------------------------
---      Module initialisation code
----------------------------------------------------------------
-
-mkModuleInit
-        :: CollectedCCs         -- cost centre info
-        -> Module
-        -> HpcInfo
-        -> FCode ()
-
-mkModuleInit cost_centre_info this_mod hpc_info
-  = do  { initHpc this_mod hpc_info
-        ; initCostCentres cost_centre_info
-        }
-
-
----------------------------------------------------------------
---      Generating static stuff for algebraic data types
----------------------------------------------------------------
-
-
-cgEnumerationTyCon :: TyCon -> FCode ()
-cgEnumerationTyCon tycon
-  = do platform <- getPlatform
-       emitRODataLits (mkClosureTableLabel (tyConName tycon) NoCafRefs)
-             [ CmmLabelOff (mkClosureLabel (dataConName con) NoCafRefs)
-                           (tagForCon platform con)
-             | con <- tyConDataCons tycon]
-
-
-cgDataCon :: ConInfoTableLocation -> DataCon -> FCode ()
--- Generate the entry code, info tables, and (for niladic constructor)
--- the static closure, for a constructor.
-cgDataCon mn data_con
-  = do  { massert (not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con))
-        ; profile <- getProfile
-        ; platform <- getPlatform
-        ; let
-            (tot_wds, --  #ptr_wds + #nonptr_wds
-             ptr_wds) --  #ptr_wds
-              = mkVirtConstrSizes profile arg_reps
-
-            nonptr_wds   = tot_wds - ptr_wds
-
-            dyn_info_tbl =
-              mkDataConInfoTable profile data_con mn False ptr_wds nonptr_wds
-
-            -- We're generating info tables, so we don't know and care about
-            -- what the actual arguments are. Using () here as the place holder.
-            arg_reps :: [NonVoid PrimRep]
-            arg_reps = [ NonVoid rep_ty
-                       | ty <- dataConRepArgTys data_con
-                       , rep_ty <- typePrimRep (scaledThing ty)
-                       , not (isVoidRep rep_ty) ]
-
-        ; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $
-            -- NB: the closure pointer is assumed *untagged* on
-            -- entry to a constructor.  If the pointer is tagged,
-            -- then we should not be entering it.  This assumption
-            -- is used in ldvEnter and when tagging the pointer to
-            -- return it.
-            -- NB 2: We don't set CC when entering data (WDP 94/06)
-            do { tickyEnterDynCon
-               ; ldvEnter (CmmReg nodeReg)
-               ; tickyReturnOldCon (length arg_reps)
-               ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon platform data_con)]
-               }
-                    -- The case continuation code expects a tagged pointer
-        }
diff --git a/compiler/GHC/StgToCmm/ArgRep.hs b/compiler/GHC/StgToCmm/ArgRep.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/ArgRep.hs
+++ /dev/null
@@ -1,170 +0,0 @@
------------------------------------------------------------------------------
---
--- Argument representations used in GHC.StgToCmm.Layout.
---
--- (c) The University of Glasgow 2013
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE LambdaCase #-}
-
-module GHC.StgToCmm.ArgRep (
-        ArgRep(..), toArgRep, argRepSizeW,
-
-        argRepString, isNonV, idArgRep,
-
-        slowCallPattern,
-
-        ) where
-
-import GHC.Prelude
-import GHC.Platform
-
-import GHC.StgToCmm.Closure    ( idPrimRep )
-import GHC.Runtime.Heap.Layout ( WordOff )
-import GHC.Types.Id            ( Id )
-import GHC.Core.TyCon          ( PrimRep(..), primElemRepSizeB )
-import GHC.Types.Basic         ( RepArity )
-import GHC.Settings.Constants  ( wORD64_SIZE, dOUBLE_SIZE )
-
-import GHC.Utils.Outputable
-import GHC.Data.FastString
-
--- I extricated this code as this new module in order to avoid a
--- cyclic dependency between GHC.StgToCmm.Layout and GHC.StgToCmm.Ticky.
---
--- NSF 18 Feb 2013
-
--------------------------------------------------------------------------
---      Classifying arguments: ArgRep
--------------------------------------------------------------------------
-
--- ArgRep is re-exported by GHC.StgToCmm.Layout, but only for use in the
--- byte-code generator which also needs to know about the
--- classification of arguments.
-
-data ArgRep = P   -- GC Ptr
-            | N   -- Word-sized non-ptr
-            | L   -- 64-bit non-ptr (long)
-            | V   -- Void
-            | F   -- Float
-            | D   -- Double
-            | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc.
-            | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc.
-            | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc.
-            deriving Eq
-instance Outputable ArgRep where ppr = text . argRepString
-
-argRepString :: ArgRep -> String
-argRepString P = "P"
-argRepString N = "N"
-argRepString L = "L"
-argRepString V = "V"
-argRepString F = "F"
-argRepString D = "D"
-argRepString V16 = "V16"
-argRepString V32 = "V32"
-argRepString V64 = "V64"
-
-toArgRep :: Platform -> PrimRep -> ArgRep
-toArgRep platform rep = case rep of
-   VoidRep           -> V
-   LiftedRep         -> P
-   UnliftedRep       -> P
-   IntRep            -> N
-   WordRep           -> N
-   Int8Rep           -> N  -- Gets widened to native word width for calls
-   Word8Rep          -> N  -- Gets widened to native word width for calls
-   Int16Rep          -> N  -- Gets widened to native word width for calls
-   Word16Rep         -> N  -- Gets widened to native word width for calls
-   Int32Rep          -> N  -- Gets widened to native word width for calls
-   Word32Rep         -> N  -- Gets widened to native word width for calls
-   AddrRep           -> N
-   Int64Rep          -> case platformWordSize platform of
-                           PW4 -> L
-                           PW8 -> N
-   Word64Rep         -> case platformWordSize platform of
-                           PW4 -> L
-                           PW8 -> N
-   FloatRep          -> F
-   DoubleRep         -> D
-   (VecRep len elem) -> case len*primElemRepSizeB platform elem of
-                           16 -> V16
-                           32 -> V32
-                           64 -> V64
-                           _  -> error "toArgRep: bad vector primrep"
-
-isNonV :: ArgRep -> Bool
-isNonV V = False
-isNonV _ = True
-
-argRepSizeW :: Platform -> ArgRep -> WordOff -- Size in words
-argRepSizeW platform = \case
-   N   -> 1
-   P   -> 1
-   F   -> 1
-   L   -> wORD64_SIZE `quot` ws
-   D   -> dOUBLE_SIZE `quot` ws
-   V   -> 0
-   V16 -> 16          `quot` ws
-   V32 -> 32          `quot` ws
-   V64 -> 64          `quot` ws
-  where
-   ws       = platformWordSizeInBytes platform
-
-idArgRep :: Platform -> Id -> ArgRep
-idArgRep platform = toArgRep platform . idPrimRep
-
--- This list of argument patterns should be kept in sync with at least
--- the following:
---
---  * GHC.StgToCmm.Layout.stdPattern maybe to some degree?
---
---  * the RTS_RET(stg_ap_*) and RTS_FUN_DECL(stg_ap_*_fast)
---  declarations in rts/include/stg/MiscClosures.h
---
---  * the SLOW_CALL_*_ctr declarations in rts/include/stg/Ticky.h,
---
---  * the TICK_SLOW_CALL_*() #defines in rts/include/Cmm.h,
---
---  * the PR_CTR(SLOW_CALL_*_ctr) calls in rts/Ticky.c,
---
---  * and the SymI_HasProto(stg_ap_*_{ret,info,fast}) calls and
---  SymI_HasProto(SLOW_CALL_*_ctr) calls in rts/Linker.c
---
--- There may be more places that I haven't found; I merely igrep'd for
--- pppppp and excluded things that seemed ghci-specific.
---
--- Also, it seems at the moment that ticky counters with void
--- arguments will never be bumped, but I'm still declaring those
--- counters, defensively.
---
--- NSF 6 Mar 2013
-
-slowCallPattern :: [ArgRep] -> (FastString, RepArity)
--- Returns the generic apply function and arity
---
--- The first batch of cases match (some) specialised entries
--- The last group deals exhaustively with the cases for the first argument
---   (and the zero-argument case)
---
--- In 99% of cases this function will match *all* the arguments in one batch
-
-slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)
-slowCallPattern (P: P: P: P: P: _)    = (fsLit "stg_ap_ppppp", 5)
-slowCallPattern (P: P: P: P: _)       = (fsLit "stg_ap_pppp", 4)
-slowCallPattern (P: P: P: V: _)       = (fsLit "stg_ap_pppv", 4)
-slowCallPattern (P: P: P: _)          = (fsLit "stg_ap_ppp", 3)
-slowCallPattern (P: P: V: _)          = (fsLit "stg_ap_ppv", 3)
-slowCallPattern (P: P: _)             = (fsLit "stg_ap_pp", 2)
-slowCallPattern (P: V: _)             = (fsLit "stg_ap_pv", 2)
-slowCallPattern (P: _)                = (fsLit "stg_ap_p", 1)
-slowCallPattern (V: _)                = (fsLit "stg_ap_v", 1)
-slowCallPattern (N: _)                = (fsLit "stg_ap_n", 1)
-slowCallPattern (F: _)                = (fsLit "stg_ap_f", 1)
-slowCallPattern (D: _)                = (fsLit "stg_ap_d", 1)
-slowCallPattern (L: _)                = (fsLit "stg_ap_l", 1)
-slowCallPattern (V16: _)              = (fsLit "stg_ap_v16", 1)
-slowCallPattern (V32: _)              = (fsLit "stg_ap_v32", 1)
-slowCallPattern (V64: _)              = (fsLit "stg_ap_v64", 1)
-slowCallPattern []                    = (fsLit "stg_ap_0", 0)
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Bind.hs
+++ /dev/null
@@ -1,825 +0,0 @@
------------------------------------------------------------------------------
---
--- Stg to C-- code generation: bindings
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.Bind (
-        cgTopRhsClosure,
-        cgBind,
-        emitBlackHoleCode,
-        pushUpdateFrame, emitUpdateFrame
-  ) where
-
-import GHC.Prelude hiding ((<*>))
-
-import GHC.Core          ( AltCon(..) )
-import GHC.Core.Opt.Arity( isOneShotBndr )
-import GHC.Runtime.Heap.Layout
-import GHC.Unit.Module
-
-import GHC.Stg.Syntax
-
-import GHC.Platform
-import GHC.Platform.Profile
-
-import GHC.Builtin.Names (unpackCStringName, unpackCStringUtf8Name)
-
-import GHC.StgToCmm.Config
-import GHC.StgToCmm.Expr
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Env
-import GHC.StgToCmm.DataCon
-import GHC.StgToCmm.Heap
-import GHC.StgToCmm.Prof (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,
-                   initUpdFrameProf)
-import GHC.StgToCmm.TagCheck
-import GHC.StgToCmm.Ticky
-import GHC.StgToCmm.Layout
-import GHC.StgToCmm.Utils
-import GHC.StgToCmm.Closure
-import GHC.StgToCmm.Foreign    (emitPrimCall)
-
-import GHC.Cmm.Graph
-import GHC.Cmm.BlockId
-import GHC.Cmm
-import GHC.Cmm.Info
-import GHC.Cmm.Utils
-import GHC.Cmm.CLabel
-
-import GHC.Stg.Utils
-import GHC.Types.CostCentre
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.Name
-import GHC.Types.Var.Set
-import GHC.Types.Basic
-import GHC.Types.Tickish ( tickishIsCode )
-
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import GHC.Data.FastString
-import GHC.Data.List.SetOps
-
-import Control.Monad
-
-------------------------------------------------------------------------
---              Top-level bindings
-------------------------------------------------------------------------
-
--- For closures bound at top level, allocate in static space.
--- They should have no free variables.
-
-cgTopRhsClosure :: Platform
-                -> RecFlag              -- member of a recursive group?
-                -> Id
-                -> CostCentreStack      -- Optional cost centre annotation
-                -> UpdateFlag
-                -> [Id]                 -- Args
-                -> CgStgExpr
-                -> (CgIdInfo, FCode ())
-
-cgTopRhsClosure platform rec id ccs upd_flag args body =
-  let closure_label = mkClosureLabel (idName id) (idCafInfo id)
-      cg_id_info    = litIdInfo platform id lf_info (CmmLabel closure_label)
-      lf_info       = mkClosureLFInfo platform id TopLevel [] upd_flag args
-  in (cg_id_info, gen_code lf_info closure_label)
-  where
-
-  gen_code :: LambdaFormInfo -> CLabel -> FCode ()
-
-  -- special case for a indirection (f = g).  We create an IND_STATIC
-  -- closure pointing directly to the indirectee.  This is exactly
-  -- what the CAF will eventually evaluate to anyway, we're just
-  -- shortcutting the whole process, and generating a lot less code
-  -- (#7308). Eventually the IND_STATIC closure will be eliminated
-  -- by assembly '.equiv' directives, where possible (#15155).
-  -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
-  --
-  -- Note: we omit the optimisation when this binding is part of a
-  -- recursive group, because the optimisation would inhibit the black
-  -- hole detection from working in that case.  Test
-  -- concurrent/should_run/4030 fails, for instance.
-  --
-  gen_code _ closure_label
-    | StgApp f [] <- body
-    , null args
-    , isNonRec rec
-    = do
-         cg_info <- getCgIdInfo f
-         emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)]
-
-  -- Emit standard stg_unpack_cstring closures for top-level unpackCString# thunks.
-  --
-  -- Note that we do not do this for thunks enclosured in code ticks (e.g. hpc
-  -- ticks) since we want to ensure that these ticks are not lost (e.g.
-  -- resulting in Strings being reported by hpc as uncovered). However, we
-  -- don't worry about standard profiling ticks since unpackCString tends not
-  -- be terribly interesting in profiles. See Note [unpack_cstring closures] in
-  -- StgStdThunks.cmm.
-  gen_code _ closure_label
-    | null args
-    , StgApp f [arg] <- stripStgTicksTopE (not . tickishIsCode) body
-    , Just unpack <- is_string_unpack_op f
-    = do arg' <- getArgAmode (NonVoid arg)
-         case arg' of
-           CmmLit lit -> do
-             let info = CmmInfoTable
-                   { cit_lbl = unpack
-                   , cit_rep = HeapRep True 0 1 Thunk
-                   , cit_prof = NoProfilingInfo
-                   , cit_srt = Nothing
-                   , cit_clo = Nothing
-                   }
-             emitDecl $ CmmData (Section Data closure_label) $
-                 CmmStatics closure_label info ccs [] [lit]
-           _ -> panic "cgTopRhsClosure.gen_code"
-    where
-      is_string_unpack_op f
-        | idName f == unpackCStringName     = Just mkRtsUnpackCStringLabel
-        | idName f == unpackCStringUtf8Name = Just mkRtsUnpackCStringUtf8Label
-        | otherwise                         = Nothing
-
-  gen_code lf_info _closure_label
-   = do { profile <- getProfile
-        ; let name = idName id
-        ; mod_name <- getModuleName
-        ; let descr         = closureDescription mod_name name
-              closure_info  = mkClosureInfo profile True id lf_info 0 0 descr
-
-        -- We don't generate the static closure here, because we might
-        -- want to add references to static closures to it later.  The
-        -- static closure is generated by GHC.Cmm.Info.Build.updInfoSRTs,
-        -- See Note [SRTs], specifically the [FUN] optimisation.
-
-        ; let fv_details :: [(NonVoid Id, ByteOff)]
-              header = if isLFThunk lf_info then ThunkHeader else StdHeader
-              (_, _, fv_details) = mkVirtHeapOffsets profile header []
-        -- Don't drop the non-void args until the closure info has been made
-        ; forkClosureBody (closureCodeBody True id closure_info ccs
-                                args body fv_details)
-
-        ; return () }
-
-  unLit (CmmLit l) = l
-  unLit _ = panic "unLit"
-
-------------------------------------------------------------------------
---              Non-top-level bindings
-------------------------------------------------------------------------
-
-cgBind :: CgStgBinding -> FCode ()
-cgBind (StgNonRec name rhs)
-  = do  { (info, fcode) <- cgRhs name rhs
-        ; addBindC info
-        ; init <- fcode
-        ; emit init }
-        -- init cannot be used in body, so slightly better to sink it eagerly
-
-cgBind (StgRec pairs)
-  = do  {  r <- sequence $ unzipWith cgRhs pairs
-        ;  let (id_infos, fcodes) = unzip r
-        ;  addBindsC id_infos
-        ;  (inits, body) <- getCodeR $ sequence fcodes
-        ;  emit (catAGraphs inits <*> body) }
-
-{- Note [cgBind rec]
-   ~~~~~~~~~~~~~~~~~
-   Recursive let-bindings are tricky.
-   Consider the following pseudocode:
-
-     let x = \_ ->  ... y ...
-         y = \_ ->  ... z ...
-         z = \_ ->  ... x ...
-     in ...
-
-   For each binding, we need to allocate a closure, and each closure must
-   capture the address of the other closures.
-   We want to generate the following C-- code:
-     // Initialization Code
-     x = hp - 24; // heap address of x's closure
-     y = hp - 40; // heap address of x's closure
-     z = hp - 64; // heap address of x's closure
-     // allocate and initialize x
-     m[hp-8]   = ...
-     m[hp-16]  = y       // the closure for x captures y
-     m[hp-24] = x_info;
-     // allocate and initialize y
-     m[hp-32] = z;       // the closure for y captures z
-     m[hp-40] = y_info;
-     // allocate and initialize z
-     ...
-
-   For each closure, we must generate not only the code to allocate and
-   initialize the closure itself, but also some initialization Code that
-   sets a variable holding the closure pointer.
-
-   We could generate a pair of the (init code, body code), but since
-   the bindings are recursive we also have to initialise the
-   environment with the CgIdInfo for all the bindings before compiling
-   anything.  So we do this in 3 stages:
-
-     1. collect all the CgIdInfos and initialise the environment
-     2. compile each binding into (init, body) code
-     3. emit all the inits, and then all the bodies
-
-   We'd rather not have separate functions to do steps 1 and 2 for
-   each binding, since in practice they share a lot of code.  So we
-   have just one function, cgRhs, that returns a pair of the CgIdInfo
-   for step 1, and a monadic computation to generate the code in step
-   2.
-
-   The alternative to separating things in this way is to use a
-   fixpoint.  That's what we used to do, but it introduces a
-   maintenance nightmare because there is a subtle dependency on not
-   being too strict everywhere.  Doing things this way means that the
-   FCode monad can be strict, for example.
- -}
-
-cgRhs :: Id
-      -> CgStgRhs
-      -> FCode (
-                 CgIdInfo         -- The info for this binding
-               , FCode CmmAGraph  -- A computation which will generate the
-                                  -- code for the binding, and return an
-                                  -- assignment of the form "x = Hp - n"
-                                  -- (see above)
-               )
-
-cgRhs id (StgRhsCon cc con mn _ts args)
-  = withNewTickyCounterCon id con mn $
-    buildDynCon id mn True cc con (assertNonVoidStgArgs args)
-      -- con args are always non-void,
-      -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
-
-{- See Note [GC recovery] in "GHC.StgToCmm.Closure" -}
-cgRhs id (StgRhsClosure fvs cc upd_flag args body)
-  = do
-    profile <- getProfile
-    check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig
-    use_std_ap_thunk <- stgToCmmTickyAP <$> getStgToCmmConfig
-    mkRhsClosure profile use_std_ap_thunk check_tags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body
-
-------------------------------------------------------------------------
---              Non-constructor right hand sides
-------------------------------------------------------------------------
-
-mkRhsClosure :: Profile
-             -> Bool                            -- Omit AP Thunks to improve profiling
-             -> Bool                            -- Lint tag inference checks
-             -> Id -> CostCentreStack
-             -> [NonVoid Id]                    -- Free vars
-             -> UpdateFlag
-             -> [Id]                            -- Args
-             -> CgStgExpr
-             -> FCode (CgIdInfo, FCode CmmAGraph)
-
-{- mkRhsClosure looks for two special forms of the right-hand side:
-        a) selector thunks
-        b) AP thunks
-
-If neither happens, it just calls mkClosureLFInfo.  You might think
-that mkClosureLFInfo should do all this, but it seems wrong for the
-latter to look at the structure of an expression
-
-Note [Selectors]
-~~~~~~~~~~~~~~~~
-We look at the body of the closure to see if it's a selector---turgid,
-but nothing deep.  We are looking for a closure of {\em exactly} the
-form:
-
-...  = [the_fv] \ u [] ->
-         case the_fv of
-           con a_1 ... a_n -> a_i
-
-Note [Ap thunks]
-~~~~~~~~~~~~~~~~
-A more generic AP thunk of the form
-
-        x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
-
-A set of these is compiled statically into the RTS, so we just use
-those.  We could extend the idea to thunks where some of the x_i are
-global ids (and hence not free variables), but this would entail
-generating a larger thunk.  It might be an option for non-optimising
-compilation, though.
-
-We only generate an Ap thunk if all the free variables are pointers,
-for semi-obvious reasons.
-
--}
-
----------- See Note [Selectors] ------------------
-mkRhsClosure    profile _ _check_tags bndr _cc
-                [NonVoid the_fv]                -- Just one free var
-                upd_flag                -- Updatable thunk
-                []                      -- A thunk
-                expr
-  | let strip = stripStgTicksTopE (not . tickishIsCode)
-  , StgCase (StgApp scrutinee [{-no args-}])
-         _   -- ignore bndr
-         (AlgAlt _)
-         [GenStgAlt{ alt_con   = DataAlt _
-                   , alt_bndrs = params
-                   , alt_rhs   = sel_expr}] <- strip expr
-  , StgApp selectee [{-no args-}] <- strip sel_expr
-  , the_fv == scrutinee                -- Scrutinee is the only free variable
-
-  , let (_, _, params_w_offsets) = mkVirtConstrOffsets profile (addIdReps (assertNonVoidIds params))
-                                   -- pattern binders are always non-void,
-                                   -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
-  , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee)
-
-  , let offset_into_int = bytesToWordsRoundUp (profilePlatform profile) the_offset
-                          - fixedHdrSizeW profile
-  , offset_into_int <= pc_MAX_SPEC_SELECTEE_SIZE (profileConstants profile) -- Offset is small enough
-  = -- NOT TRUE: assert (is_single_constructor)
-    -- The simplifier may have statically determined that the single alternative
-    -- is the only possible case and eliminated the others, even if there are
-    -- other constructors in the datatype.  It's still ok to make a selector
-    -- thunk in this case, because we *know* which constructor the scrutinee
-    -- will evaluate to.
-    --
-    -- srt is discarded; it must be empty
-    let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
-    in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
-
----------- See Note [Ap thunks] ------------------
-mkRhsClosure    profile use_std_ap check_tags bndr _cc
-                fvs
-                upd_flag
-                []                      -- No args; a thunk
-                (StgApp fun_id args)
-
-  -- We are looking for an "ApThunk"; see data con ApThunk in GHC.StgToCmm.Closure
-  -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)
-  -- So the xi will all be free variables
-  | use_std_ap
-  , args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and
-                               -- args are all distinct local variables
-                               -- The "-1" is for fun_id
-    -- Missed opportunity:   (f x x) is not detected
-  , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs
-  , isUpdatable upd_flag
-  , n_fvs <= pc_MAX_SPEC_AP_SIZE (profileConstants profile)
-  , not (profileIsProfiling profile)
-                         -- not when profiling: we don't want to
-                         -- lose information about this particular
-                         -- thunk (e.g. its type) (#949)
-  , idArity fun_id == unknownArity -- don't spoil a known call
-          -- Ha! an Ap thunk
-  , not check_tags -- See Note [Tag inference debugging]
-  = cgRhsStdThunk bndr lf_info payload
-
-  where
-    n_fvs   = length fvs
-    lf_info = mkApLFInfo bndr upd_flag n_fvs
-    -- the payload has to be in the correct order, hence we can't
-    -- just use the fvs.
-    payload = StgVarArg fun_id : args
-
----------- Default case ------------------
-mkRhsClosure profile _use_ap _check_tags bndr cc fvs upd_flag args body
-  = do  { let lf_info = mkClosureLFInfo (profilePlatform profile) bndr NotTopLevel fvs upd_flag args
-        ; (id_info, reg) <- rhsIdInfo bndr lf_info
-        ; return (id_info, gen_code lf_info reg) }
- where
- gen_code lf_info reg
-  = do  {       -- LAY OUT THE OBJECT
-        -- If the binder is itself a free variable, then don't store
-        -- it in the closure.  Instead, just bind it to Node on entry.
-        -- NB we can be sure that Node will point to it, because we
-        -- haven't told mkClosureLFInfo about this; so if the binder
-        -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
-        -- stored in the closure itself, so it will make sure that
-        -- Node points to it...
-        ; let   reduced_fvs = filter (NonVoid bndr /=) fvs
-
-        ; profile <- getProfile
-        ; let platform = profilePlatform profile
-
-        -- MAKE CLOSURE INFO FOR THIS CLOSURE
-        ; mod_name <- getModuleName
-        ; let   name  = idName bndr
-                descr = closureDescription mod_name name
-                fv_details :: [(NonVoid Id, ByteOff)]
-                header = if isLFThunk lf_info then ThunkHeader else StdHeader
-                (tot_wds, ptr_wds, fv_details)
-                   = mkVirtHeapOffsets profile header (addIdReps reduced_fvs)
-                closure_info = mkClosureInfo profile False       -- Not static
-                                             bndr lf_info tot_wds ptr_wds
-                                             descr
-
-        -- BUILD ITS INFO TABLE AND CODE
-        ; forkClosureBody $
-                -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
-                --                  (b) ignore Sequel from context; use empty Sequel
-                -- And compile the body
-                closureCodeBody False bndr closure_info cc args
-                                body fv_details
-
-        -- BUILD THE OBJECT
---      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
-        ; let use_cc = cccsExpr; blame_cc = cccsExpr
-        ; emit (mkComment $ mkFastString "calling allocDynClosure")
-        ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
-        ; let info_tbl = mkCmmInfo closure_info bndr currentCCS
-        ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc
-                                         (map toVarArg fv_details)
-
-        -- RETURN
-        ; return (mkRhsInit platform reg lf_info hp_plus_n) }
-
--------------------------
-cgRhsStdThunk
-        :: Id
-        -> LambdaFormInfo
-        -> [StgArg]             -- payload
-        -> FCode (CgIdInfo, FCode CmmAGraph)
-
-cgRhsStdThunk bndr lf_info payload
- = do  { (id_info, reg) <- rhsIdInfo bndr lf_info
-       ; return (id_info, gen_code reg)
-       }
- where
- gen_code reg  -- AHA!  A STANDARD-FORM THUNK
-  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (bndr) payload $
-    do
-  {     -- LAY OUT THE OBJECT
-    mod_name <- getModuleName
-  ; profile  <- getProfile
-  ; platform <- getPlatform
-  ; let
-        header = if isLFThunk lf_info then ThunkHeader else StdHeader
-        (tot_wds, ptr_wds, payload_w_offsets)
-            = mkVirtHeapOffsets profile header
-                (addArgReps (nonVoidStgArgs payload))
-
-        descr = closureDescription mod_name (idName bndr)
-        closure_info = mkClosureInfo profile False       -- Not static
-                                     bndr lf_info tot_wds ptr_wds
-                                     descr
-
---  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
-  ; let use_cc = cccsExpr; blame_cc = cccsExpr
-
-
-        -- BUILD THE OBJECT
-  ; let info_tbl = mkCmmInfo closure_info bndr currentCCS
-  ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info
-                                   use_cc blame_cc payload_w_offsets
-
-        -- RETURN
-  ; return (mkRhsInit platform reg lf_info hp_plus_n) }
-
-
-mkClosureLFInfo :: Platform
-                -> Id           -- The binder
-                -> TopLevelFlag -- True of top level
-                -> [NonVoid Id] -- Free vars
-                -> UpdateFlag   -- Update flag
-                -> [Id]         -- Args
-                -> LambdaFormInfo
-mkClosureLFInfo platform bndr top fvs upd_flag args
-  | null args =
-        mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag
-  | otherwise =
-        mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr platform args)
-
-
-------------------------------------------------------------------------
---              The code for closures
-------------------------------------------------------------------------
-
-closureCodeBody :: Bool            -- whether this is a top-level binding
-                -> Id              -- the closure's name
-                -> ClosureInfo     -- Lots of information about this closure
-                -> CostCentreStack -- Optional cost centre attached to closure
-                -> [Id]            -- incoming args to the closure
-                -> CgStgExpr
-                -> [(NonVoid Id, ByteOff)] -- the closure's free vars
-                -> FCode ()
-
-{- There are two main cases for the code for closures.
-
-* If there are *no arguments*, then the closure is a thunk, and not in
-  normal form. So it should set up an update frame (if it is
-  shared). NB: Thunks cannot have a primitive type!
-
-* If there is *at least one* argument, then this closure is in
-  normal form, so there is no need to set up an update frame.
--}
-
--- No args i.e. thunk
-closureCodeBody top_lvl bndr cl_info cc [] body fv_details
-  = withNewTickyCounterThunk
-        (isStaticClosure cl_info)
-        (closureUpdReqd cl_info)
-        (closureName cl_info)
-        (map fst fv_details) $
-    emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
-      \(_, node, _) -> thunkCode cl_info fv_details cc node body
-   where
-     lf_info  = closureLFInfo cl_info
-     info_tbl = mkCmmInfo cl_info bndr cc
-
--- Functions
-closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details
-  = let nv_args = nonVoidIds args
-        arity = length args
-    in
-    -- See Note [OneShotInfo overview] in GHC.Types.Basic.
-    withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info) (map fst fv_details)
-        nv_args $ do {
-
-        ; let
-             lf_info  = closureLFInfo cl_info
-             info_tbl = mkCmmInfo cl_info bndr cc
-
-        -- Emit the main entry code
-        ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl nv_args $
-            \(_offset, node, arg_regs) -> do
-                -- Emit slow-entry code (for entering a closure through a PAP)
-                { mkSlowEntryCode bndr cl_info arg_regs
-                ; profile <- getProfile
-                ; platform <- getPlatform
-                ; let node_points = nodeMustPointToIt profile lf_info
-                      node' = if node_points then Just node else Nothing
-                ; loop_header_id <- newBlockId
-                -- Extend reader monad with information that
-                -- self-recursive tail calls can be optimized into local
-                -- jumps. See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr.
-                ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do
-                {
-                -- Main payload
-                ; entryHeapCheck cl_info node' arity arg_regs $ do
-                { -- emit LDV code when profiling
-                  when node_points (ldvEnterClosure cl_info (CmmLocal node))
-                -- ticky after heap check to avoid double counting
-                ; tickyEnterFun cl_info
-                ; enterCostCentreFun cc
-                    (CmmMachOp (mo_wordSub platform)
-                         [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
-                         , mkIntExpr platform (funTag platform cl_info) ])
-                ; fv_bindings <- mapM bind_fv fv_details
-                -- Load free vars out of closure *after*
-                -- heap check, to reduce live vars over check
-                ; when node_points $ load_fvs node lf_info fv_bindings
-                ; checkFunctionArgTags (text "TagCheck failed - Argument to local function:" <> ppr bndr) bndr args
-                ; void $ cgExpr body
-                }}}
-
-  }
-
--- Note [NodeReg clobbered with loopification]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Previously we used to pass nodeReg (aka R1) here. With profiling, upon
--- entering a closure, enterFunCCS was called with R1 passed to it. But since R1
--- may get clobbered inside the body of a closure, and since a self-recursive
--- tail call does not restore R1, a subsequent call to enterFunCCS received a
--- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to
--- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores
--- the original value of R1. This way R1 may get modified but loopification will
--- not care.
-
--- A function closure pointer may be tagged, so we
--- must take it into account when accessing the free variables.
-bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
-bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
-
-load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
-load_fvs node lf_info = mapM_ (\ (reg, off) ->
-   do platform <- getPlatform
-      let tag = lfDynTag platform lf_info
-      emit $ mkTaggedObjectLoad platform reg node off tag)
-
------------------------------------------
--- The "slow entry" code for a function.  This entry point takes its
--- arguments on the stack.  It loads the arguments into registers
--- according to the calling convention, and jumps to the function's
--- normal entry point.  The function's closure is assumed to be in
--- R1/node.
---
--- The slow entry point is used for unknown calls: eg. stg_PAP_entry
-
-mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
--- If this function doesn't have a specialised ArgDescr, we need
--- to generate the function's arg bitmap and slow-entry code.
--- Here, we emit the slow-entry code.
-mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
-  | Just (_, ArgGen _) <- closureFunInfo cl_info
-  = do cfg       <- getStgToCmmConfig
-       upd_frame <- getUpdFrameOff
-       let node = idToReg platform (NonVoid bndr)
-           profile  = stgToCmmProfile  cfg
-           platform = stgToCmmPlatform cfg
-           slow_lbl = closureSlowEntryLabel  platform cl_info
-           fast_lbl = closureLocalEntryLabel platform cl_info
-           -- mkDirectJump does not clobber `Node' containing function closure
-           jump = mkJump profile NativeNodeCall
-                                (mkLblExpr fast_lbl)
-                                (map (CmmReg . CmmLocal) (node : arg_regs))
-                                upd_frame
-       tscope <- getTickScope
-       emitProcWithConvention Slow Nothing slow_lbl
-         (node : arg_regs) (jump, tscope)
-  | otherwise = return ()
-
------------------------------------------
-thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
-          -> LocalReg -> CgStgExpr -> FCode ()
-thunkCode cl_info fv_details _cc node body
-  = do { profile <- getProfile
-       ; let node_points = nodeMustPointToIt profile (closureLFInfo cl_info)
-             node'       = if node_points then Just node else Nothing
-        ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling
-
-        -- Heap overflow check
-        ; entryHeapCheck cl_info node' 0 [] $ do
-        { -- Overwrite with black hole if necessary
-          -- but *after* the heap-overflow check
-        ; tickyEnterThunk cl_info
-        ; when (blackHoleOnEntry cl_info && node_points)
-                (blackHoleIt node)
-
-          -- Push update frame
-        ; setupUpdate cl_info node $
-            -- We only enter cc after setting up update so
-            -- that cc of enclosing scope will be recorded
-            -- in update frame CAF/DICT functions will be
-            -- subsumed by this enclosing cc
-            do { enterCostCentreThunk (CmmReg nodeReg)
-               ; let lf_info = closureLFInfo cl_info
-               ; fv_bindings <- mapM bind_fv fv_details
-               ; load_fvs node lf_info fv_bindings
-               ; void $ cgExpr body }}}
-
-
-------------------------------------------------------------------------
---              Update and black-hole wrappers
-------------------------------------------------------------------------
-
-blackHoleIt :: LocalReg -> FCode ()
--- Only called for closures with no args
--- Node points to the closure
-blackHoleIt node_reg
-  = emitBlackHoleCode (CmmReg (CmmLocal node_reg))
-
-emitBlackHoleCode :: CmmExpr -> FCode ()
-emitBlackHoleCode node = do
-  cfg <- getStgToCmmConfig
-  let profile     = stgToCmmProfile  cfg
-      platform    = stgToCmmPlatform cfg
-      is_eager_bh = stgToCmmEagerBlackHole cfg
-
-  -- Eager blackholing is normally disabled, but can be turned on with
-  -- -feager-blackholing.  When it is on, we replace the info pointer
-  -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.
-
-  -- If we wanted to do eager blackholing with slop filling, we'd need
-  -- to do it at the *end* of a basic block, otherwise we overwrite
-  -- the free variables in the thunk that we still need.  We have a
-  -- patch for this from Andy Cheadle, but not incorporated yet. --SDM
-  -- [6/2004]
-  --
-  -- Previously, eager blackholing was enabled when ticky-ticky was
-  -- on. But it didn't work, and it wasn't strictly necessary to bring
-  -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is
-  -- unconditionally disabled. -- krc 1/2007
-
-  -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,
-  -- because emitBlackHoleCode is called from GHC.Cmm.Parser.
-
-  let  eager_blackholing =  not (profileIsProfiling profile) && is_eager_bh
-             -- Profiling needs slop filling (to support LDV
-             -- profiling), so currently eager blackholing doesn't
-             -- work with profiling.
-
-  when eager_blackholing $ do
-    whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node
-    emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) currentTSOExpr
-    -- See Note [Heap memory barriers] in SMP.h.
-    emitPrimCall [] MO_WriteBarrier []
-    emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))
-
-setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
-        -- Nota Bene: this function does not change Node (even if it's a CAF),
-        -- so that the cost centre in the original closure can still be
-        -- extracted by a subsequent enterCostCentre
-setupUpdate closure_info node body
-  | not (lfUpdatable (closureLFInfo closure_info))
-  = body
-
-  | not (isStaticClosure closure_info)
-  = if not (closureUpdReqd closure_info)
-      then do tickyUpdateFrameOmitted; body
-      else do
-          tickyPushUpdateFrame
-          cfg <- getStgToCmmConfig
-          let
-              bh = blackHoleOnEntry closure_info
-                && not (stgToCmmSCCProfiling cfg)
-                && stgToCmmEagerBlackHole cfg
-
-              lbl | bh        = mkBHUpdInfoLabel
-                  | otherwise = mkUpdInfoLabel
-
-          pushUpdateFrame lbl (CmmReg (CmmLocal node)) body
-
-  | otherwise   -- A static closure
-  = do  { tickyUpdateBhCaf closure_info
-
-        ; if closureUpdReqd closure_info
-          then do       -- Blackhole the (updatable) CAF:
-                { upd_closure <- link_caf node
-                ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }
-          else do {tickyUpdateFrameOmitted; body}
-    }
-
------------------------------------------------------------------------------
--- Setting up update frames
-
--- Push the update frame on the stack in the Entry area,
--- leaving room for the return address that is already
--- at the old end of the area.
---
-pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()
-pushUpdateFrame lbl updatee body
-  = do
-       updfr  <- getUpdFrameOff
-       profile <- getProfile
-       let
-           hdr         = fixedHdrSize profile
-           frame       = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile)
-       --
-       emitUpdateFrame (CmmStackSlot Old frame) lbl updatee
-       withUpdFrameOff frame body
-
-emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode ()
-emitUpdateFrame frame lbl updatee = do
-  profile <- getProfile
-  let
-           hdr         = fixedHdrSize profile
-           off_updatee = hdr + pc_OFFSET_StgUpdateFrame_updatee (platformConstants platform)
-           platform    = profilePlatform profile
-  --
-  emitStore frame (mkLblExpr lbl)
-  emitStore (cmmOffset platform frame off_updatee) updatee
-  initUpdFrameProf frame
-
------------------------------------------------------------------------------
--- Entering a CAF
---
--- See Note [CAF management] in rts/sm/Storage.c
-
-link_caf :: LocalReg           -- pointer to the closure
-         -> FCode CmmExpr      -- Returns amode for closure to be updated
--- This function returns the address of the black hole, so it can be
--- updated with the new value when available.
-link_caf node = do
-  { cfg <- getStgToCmmConfig
-        -- Call the RTS function newCAF, returning the newly-allocated
-        -- blackhole indirection closure
-  ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing
-                                    ForeignLabelInExternalPackage IsFunction
-  ; let profile  = stgToCmmProfile cfg
-  ; let platform = profilePlatform profile
-  ; bh <- newTemp (bWord platform)
-  ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl
-      [ (baseExpr,  AddrHint),
-        (CmmReg (CmmLocal node), AddrHint) ]
-      False
-
-  -- see Note [atomic CAF entry] in rts/sm/Storage.c
-  ; updfr  <- getUpdFrameOff
-  ; let align_check = stgToCmmAlignCheck cfg
-  ; let target      = entryCode platform
-                        (closureInfoPtr platform align_check (CmmReg (CmmLocal node)))
-  ; emit =<< mkCmmIfThen
-      (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform))
-        -- re-enter the CAF
-       (mkJump profile NativeNodeCall target [] updfr)
-
-  ; return (CmmReg (CmmLocal bh)) }
-
-------------------------------------------------------------------------
---              Profiling
-------------------------------------------------------------------------
-
--- For "global" data constructors the description is simply occurrence
--- name of the data constructor itself.  Otherwise it is determined by
--- @closureDescription@ from the let binding information.
-
-closureDescription
-   :: Module            -- Module
-   -> Name              -- Id of closure binding
-   -> String
-        -- Not called for StgRhsCon which have global info tables built in
-        -- CgConTbls.hs with a description generated from the data constructor
-closureDescription mod_name name
-  = showSDocOneLine defaultSDocContext
-    (char '<' <> pprFullName mod_name name <> char '>')
diff --git a/compiler/GHC/StgToCmm/Bind.hs-boot b/compiler/GHC/StgToCmm/Bind.hs-boot
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Bind.hs-boot
+++ /dev/null
@@ -1,6 +0,0 @@
-module GHC.StgToCmm.Bind where
-
-import GHC.StgToCmm.Monad( FCode )
-import GHC.Stg.Syntax( CgStgBinding )
-
-cgBind :: CgStgBinding -> FCode ()
diff --git a/compiler/GHC/StgToCmm/CgUtils.hs b/compiler/GHC/StgToCmm/CgUtils.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/CgUtils.hs
+++ /dev/null
@@ -1,187 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE BangPatterns #-}
-
------------------------------------------------------------------------------
---
--- Code generator utilities; mostly monadic
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.CgUtils (
-        fixStgRegisters,
-        baseRegOffset,
-        get_Regtable_addr_from_offset,
-        regTableOffset,
-        get_GlobalReg_addr,
-  ) where
-
-import GHC.Prelude
-
-import GHC.Platform.Regs
-import GHC.Platform
-import GHC.Cmm
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Utils
-import GHC.Cmm.CLabel
-import GHC.Utils.Panic
-
--- -----------------------------------------------------------------------------
--- Information about global registers
-
-baseRegOffset :: Platform -> GlobalReg -> Int
-baseRegOffset platform reg = case reg of
-   VanillaReg 1 _       -> pc_OFFSET_StgRegTable_rR1  constants
-   VanillaReg 2 _       -> pc_OFFSET_StgRegTable_rR2  constants
-   VanillaReg 3 _       -> pc_OFFSET_StgRegTable_rR3  constants
-   VanillaReg 4 _       -> pc_OFFSET_StgRegTable_rR4  constants
-   VanillaReg 5 _       -> pc_OFFSET_StgRegTable_rR5  constants
-   VanillaReg 6 _       -> pc_OFFSET_StgRegTable_rR6  constants
-   VanillaReg 7 _       -> pc_OFFSET_StgRegTable_rR7  constants
-   VanillaReg 8 _       -> pc_OFFSET_StgRegTable_rR8  constants
-   VanillaReg 9 _       -> pc_OFFSET_StgRegTable_rR9  constants
-   VanillaReg 10 _      -> pc_OFFSET_StgRegTable_rR10 constants
-   VanillaReg n _       -> panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")
-   FloatReg  1          -> pc_OFFSET_StgRegTable_rF1 constants
-   FloatReg  2          -> pc_OFFSET_StgRegTable_rF2 constants
-   FloatReg  3          -> pc_OFFSET_StgRegTable_rF3 constants
-   FloatReg  4          -> pc_OFFSET_StgRegTable_rF4 constants
-   FloatReg  5          -> pc_OFFSET_StgRegTable_rF5 constants
-   FloatReg  6          -> pc_OFFSET_StgRegTable_rF6 constants
-   FloatReg  n          -> panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")
-   DoubleReg 1          -> pc_OFFSET_StgRegTable_rD1 constants
-   DoubleReg 2          -> pc_OFFSET_StgRegTable_rD2 constants
-   DoubleReg 3          -> pc_OFFSET_StgRegTable_rD3 constants
-   DoubleReg 4          -> pc_OFFSET_StgRegTable_rD4 constants
-   DoubleReg 5          -> pc_OFFSET_StgRegTable_rD5 constants
-   DoubleReg 6          -> pc_OFFSET_StgRegTable_rD6 constants
-   DoubleReg n          -> panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")
-   XmmReg 1             -> pc_OFFSET_StgRegTable_rXMM1 constants
-   XmmReg 2             -> pc_OFFSET_StgRegTable_rXMM2 constants
-   XmmReg 3             -> pc_OFFSET_StgRegTable_rXMM3 constants
-   XmmReg 4             -> pc_OFFSET_StgRegTable_rXMM4 constants
-   XmmReg 5             -> pc_OFFSET_StgRegTable_rXMM5 constants
-   XmmReg 6             -> pc_OFFSET_StgRegTable_rXMM6 constants
-   XmmReg n             -> panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")
-   YmmReg 1             -> pc_OFFSET_StgRegTable_rYMM1 constants
-   YmmReg 2             -> pc_OFFSET_StgRegTable_rYMM2 constants
-   YmmReg 3             -> pc_OFFSET_StgRegTable_rYMM3 constants
-   YmmReg 4             -> pc_OFFSET_StgRegTable_rYMM4 constants
-   YmmReg 5             -> pc_OFFSET_StgRegTable_rYMM5 constants
-   YmmReg 6             -> pc_OFFSET_StgRegTable_rYMM6 constants
-   YmmReg n             -> panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")
-   ZmmReg 1             -> pc_OFFSET_StgRegTable_rZMM1 constants
-   ZmmReg 2             -> pc_OFFSET_StgRegTable_rZMM2 constants
-   ZmmReg 3             -> pc_OFFSET_StgRegTable_rZMM3 constants
-   ZmmReg 4             -> pc_OFFSET_StgRegTable_rZMM4 constants
-   ZmmReg 5             -> pc_OFFSET_StgRegTable_rZMM5 constants
-   ZmmReg 6             -> pc_OFFSET_StgRegTable_rZMM6 constants
-   ZmmReg n             -> panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")
-   Sp                   -> pc_OFFSET_StgRegTable_rSp    constants
-   SpLim                -> pc_OFFSET_StgRegTable_rSpLim constants
-   LongReg 1            -> pc_OFFSET_StgRegTable_rL1    constants
-   LongReg n            -> panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")
-   Hp                   -> pc_OFFSET_StgRegTable_rHp             constants
-   HpLim                -> pc_OFFSET_StgRegTable_rHpLim          constants
-   CCCS                 -> pc_OFFSET_StgRegTable_rCCCS           constants
-   CurrentTSO           -> pc_OFFSET_StgRegTable_rCurrentTSO     constants
-   CurrentNursery       -> pc_OFFSET_StgRegTable_rCurrentNursery constants
-   HpAlloc              -> pc_OFFSET_StgRegTable_rHpAlloc        constants
-   EagerBlackholeInfo   -> pc_OFFSET_stgEagerBlackholeInfo       constants
-   GCEnter1             -> pc_OFFSET_stgGCEnter1                 constants
-   GCFun                -> pc_OFFSET_stgGCFun                    constants
-   BaseReg              -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:BaseReg"
-   PicBaseReg           -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:PicBaseReg"
-   MachSp               -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:MachSp"
-   UnwindReturnReg      -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:UnwindReturnReg"
- where
-   !constants = platformConstants platform
-
-
--- -----------------------------------------------------------------------------
---
--- STG/Cmm GlobalReg
---
--- -----------------------------------------------------------------------------
-
--- | We map STG registers onto appropriate CmmExprs.  Either they map
--- to real machine registers or stored as offsets from BaseReg.  Given
--- a GlobalReg, get_GlobalReg_addr always produces the
--- register table address for it.
-get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr
-get_GlobalReg_addr platform BaseReg = regTableOffset platform 0
-get_GlobalReg_addr platform mid
-    = get_Regtable_addr_from_offset platform (baseRegOffset platform mid)
-
--- Calculate a literal representing an offset into the register table.
--- Used when we don't have an actual BaseReg to offset from.
-regTableOffset :: Platform -> Int -> CmmExpr
-regTableOffset platform n =
-  CmmLit (CmmLabelOff mkMainCapabilityLabel (pc_OFFSET_Capability_r (platformConstants platform) + n))
-
-get_Regtable_addr_from_offset :: Platform -> Int -> CmmExpr
-get_Regtable_addr_from_offset platform offset =
-    if haveRegBase platform
-    then cmmRegOff baseReg offset
-    else regTableOffset platform offset
-
--- | Fixup global registers so that they assign to locations within the
--- RegTable if they aren't pinned for the current target.
-fixStgRegisters :: Platform -> RawCmmDecl -> RawCmmDecl
-fixStgRegisters _ top@(CmmData _ _) = top
-
-fixStgRegisters platform (CmmProc info lbl live graph) =
-  let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock platform)) graph
-  in CmmProc info lbl live graph'
-
-fixStgRegBlock :: Platform -> Block CmmNode e x -> Block CmmNode e x
-fixStgRegBlock platform block = mapBlock (fixStgRegStmt platform) block
-
-fixStgRegStmt :: Platform -> CmmNode e x -> CmmNode e x
-fixStgRegStmt platform stmt = fixAssign $ mapExpDeep fixExpr stmt
-  where
-    fixAssign stmt =
-      case stmt of
-        CmmAssign (CmmGlobal reg) src
-          -- MachSp isn't an STG register; it's merely here for tracking unwind
-          -- information
-          | reg == MachSp -> stmt
-          | otherwise ->
-            let baseAddr = get_GlobalReg_addr platform reg
-            in case reg `elem` activeStgRegs platform of
-                True  -> CmmAssign (CmmGlobal reg) src
-                False -> CmmStore baseAddr src NaturallyAligned
-        other_stmt -> other_stmt
-
-    fixExpr expr = case expr of
-        -- MachSp isn't an STG; it's merely here for tracking unwind information
-        CmmReg (CmmGlobal MachSp) -> expr
-        CmmReg (CmmGlobal reg) ->
-            -- Replace register leaves with appropriate StixTrees for
-            -- the given target.  MagicIds which map to a reg on this
-            -- arch are left unchanged.  For the rest, BaseReg is taken
-            -- to mean the address of the reg table in MainCapability,
-            -- and for all others we generate an indirection to its
-            -- location in the register table.
-            case reg `elem` activeStgRegs platform of
-                True  -> expr
-                False ->
-                    let baseAddr = get_GlobalReg_addr platform reg
-                    in case reg of
-                        BaseReg -> baseAddr
-                        _other  -> CmmLoad baseAddr (globalRegType platform reg) NaturallyAligned
-
-        CmmRegOff (CmmGlobal reg) offset ->
-            -- RegOf leaves are just a shorthand form. If the reg maps
-            -- to a real reg, we keep the shorthand, otherwise, we just
-            -- expand it and defer to the above code.
-            case reg `elem` activeStgRegs platform of
-                True  -> expr
-                False -> CmmMachOp (MO_Add (wordWidth platform)) [
-                                    fixExpr (CmmReg (CmmGlobal reg)),
-                                    CmmLit (CmmInt (fromIntegral offset)
-                                                   (wordWidth platform))]
-
-        other_expr -> other_expr
diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Closure.hs
+++ /dev/null
@@ -1,969 +0,0 @@
-
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-
------------------------------------------------------------------------------
---
--- Stg to C-- code generation:
---
--- The types   LambdaFormInfo
---             ClosureInfo
---
--- Nothing monadic in here!
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.Closure (
-        DynTag,  tagForCon, isSmallFamily,
-
-        idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,
-        argPrimRep,
-
-        NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,
-        assertNonVoidIds, assertNonVoidStgArgs,
-
-        -- * LambdaFormInfo
-        LambdaFormInfo,         -- Abstract
-        StandardFormInfo,        -- ...ditto...
-        mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
-        mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
-        mkLFStringLit,
-        lfDynTag,
-        isLFThunk, isLFReEntrant, lfUpdatable,
-
-        -- * Used by other modules
-        CgLoc(..), CallMethod(..),
-        nodeMustPointToIt, isKnownFun, funTag, tagForArity,
-        getCallMethod,
-
-        -- * ClosureInfo
-        ClosureInfo,
-        mkClosureInfo,
-        mkCmmInfo,
-
-        -- ** Inspection
-        closureLFInfo, closureName,
-
-        -- ** Labels
-        -- These just need the info table label
-        closureInfoLabel, staticClosureLabel,
-        closureSlowEntryLabel, closureLocalEntryLabel,
-
-        -- ** Predicates
-        -- These are really just functions on LambdaFormInfo
-        closureUpdReqd,
-        closureReEntrant, closureFunInfo,
-        isToplevClosure,
-
-        blackHoleOnEntry,  -- Needs LambdaFormInfo and SMRep
-        isStaticClosure,   -- Needs SMPre
-
-        -- * InfoTables
-        mkDataConInfoTable,
-        cafBlackHoleInfoTable,
-        indStaticInfoTable,
-        staticClosureNeedsLink,
-        mkClosureInfoTableLabel
-    ) where
-
-import GHC.Prelude
-import GHC.Platform
-import GHC.Platform.Profile
-
-import GHC.Stg.Syntax
-import GHC.Runtime.Heap.Layout
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.StgToCmm.Types
-import GHC.StgToCmm.Sequel
-
-import GHC.Types.CostCentre
-import GHC.Cmm.BlockId
-import GHC.Cmm.CLabel
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Core.DataCon
-import GHC.Types.Name
-import GHC.Core.Type
-import GHC.Core.TyCo.Rep
-import GHC.Tc.Utils.TcType
-import GHC.Core.TyCon
-import GHC.Types.RepType
-import GHC.Types.Basic
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Misc
-
-import Data.Coerce (coerce)
-import qualified Data.ByteString.Char8 as BS8
-import GHC.StgToCmm.Config
-import GHC.Stg.InferTags.TagSig (isTaggedSig)
-
------------------------------------------------------------------------------
---                Data types and synonyms
------------------------------------------------------------------------------
-
--- These data types are mostly used by other modules, especially
--- GHC.StgToCmm.Monad, but we define them here because some functions in this
--- module need to have access to them as well
-
-data CgLoc
-  = CmmLoc CmmExpr      -- A stable CmmExpr; that is, one not mentioning
-                        -- Hp, so that it remains valid across calls
-
-  | LneLoc BlockId [LocalReg]             -- A join point
-        -- A join point (= let-no-escape) should only
-        -- be tail-called, and in a saturated way.
-        -- To tail-call it, assign to these locals,
-        -- and branch to the block id
-
-instance OutputableP Platform CgLoc where
-   pdoc = pprCgLoc
-
-pprCgLoc :: Platform -> CgLoc -> SDoc
-pprCgLoc platform = \case
-   CmmLoc e    -> text "cmm" <+> pdoc platform e
-   LneLoc b rs -> text "lne" <+> ppr b <+> ppr rs
-
--- used by ticky profiling
-isKnownFun :: LambdaFormInfo -> Bool
-isKnownFun LFReEntrant{} = True
-isKnownFun LFLetNoEscape = True
-isKnownFun _             = False
-
-
--------------------------------------
---        Non-void types
--------------------------------------
--- We frequently need the invariant that an Id or a an argument
--- is of a non-void type. This type is a witness to the invariant.
-
-newtype NonVoid a = NonVoid a
-  deriving (Eq, Show)
-
-fromNonVoid :: NonVoid a -> a
-fromNonVoid (NonVoid a) = a
-
-instance (Outputable a) => Outputable (NonVoid a) where
-  ppr (NonVoid a) = ppr a
-
-nonVoidIds :: [Id] -> [NonVoid Id]
-nonVoidIds ids = [NonVoid id | id <- ids, not (isZeroBitTy (idType id))]
-
--- | Used in places where some invariant ensures that all these Ids are
--- non-void; e.g. constructor field binders in case expressions.
--- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise".
-assertNonVoidIds :: [Id] -> [NonVoid Id]
-assertNonVoidIds ids = assert (not (any (isZeroBitTy . idType) ids)) $
-                       coerce ids
-
-nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
-nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isZeroBitTy (stgArgType arg))]
-
--- | Used in places where some invariant ensures that all these arguments are
--- non-void; e.g. constructor arguments.
--- See Note [Post-unarisation invariants] in "GHC.Stg.Unarise".
-assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
-assertNonVoidStgArgs args = assert (not (any (isZeroBitTy . stgArgType) args)) $
-                            coerce args
-
-
------------------------------------------------------------------------------
---                Representations
------------------------------------------------------------------------------
-
--- Why are these here?
-
--- | Assumes that there is precisely one 'PrimRep' of the type. This assumption
--- holds after unarise.
--- See Note [Post-unarisation invariants]
-idPrimRep :: Id -> PrimRep
-idPrimRep id = typePrimRep1 (idType id)
-    -- See also Note [VoidRep] in GHC.Types.RepType
-
--- | Assumes that Ids have one PrimRep, which holds after unarisation.
--- See Note [Post-unarisation invariants]
-addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]
-addIdReps = map (\id -> let id' = fromNonVoid id
-                         in NonVoid (idPrimRep id', id'))
-
--- | Assumes that arguments have one PrimRep, which holds after unarisation.
--- See Note [Post-unarisation invariants]
-addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
-addArgReps = map (\arg -> let arg' = fromNonVoid arg
-                           in NonVoid (argPrimRep arg', arg'))
-
--- | Assumes that the argument has one PrimRep, which holds after unarisation.
--- See Note [Post-unarisation invariants]
-argPrimRep :: StgArg -> PrimRep
-argPrimRep arg = typePrimRep1 (stgArgType arg)
-
-------------------------------------------------------
---                Building LambdaFormInfo
-------------------------------------------------------
-
-mkLFArgument :: Id -> LambdaFormInfo
-mkLFArgument id
-  | isUnliftedType ty      = LFUnlifted
-  | mightBeFunTy ty = LFUnknown True
-  | otherwise              = LFUnknown False
-  where
-    ty = idType id
-
--------------
-mkLFLetNoEscape :: LambdaFormInfo
-mkLFLetNoEscape = LFLetNoEscape
-
--------------
-mkLFReEntrant :: TopLevelFlag    -- True of top level
-              -> [Id]            -- Free vars
-              -> [Id]            -- Args
-              -> ArgDescr        -- Argument descriptor
-              -> LambdaFormInfo
-
-mkLFReEntrant _ _ [] _
-  = pprPanic "mkLFReEntrant" empty
-mkLFReEntrant top fvs args arg_descr
-  = LFReEntrant top (length args) (null fvs) arg_descr
-
--------------
-mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
-mkLFThunk thunk_ty top fvs upd_flag
-  = assert (not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty)) $
-    LFThunk top (null fvs)
-            (isUpdatable upd_flag)
-            NonStandardThunk
-            (mightBeFunTy thunk_ty)
-
--------------
-mkConLFInfo :: DataCon -> LambdaFormInfo
-mkConLFInfo con = LFCon con
-
--------------
-mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
-mkSelectorLFInfo id offset updatable
-  = LFThunk NotTopLevel False updatable (SelectorThunk offset)
-        (mightBeFunTy (idType id))
-
--------------
-mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
-mkApLFInfo id upd_flag arity
-  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
-        (mightBeFunTy (idType id))
-
--------------
-mkLFImported :: Id -> LambdaFormInfo
-mkLFImported id =
-    -- See Note [Conveying CAF-info and LFInfo between modules] in
-    -- GHC.StgToCmm.Types
-    case idLFInfo_maybe id of
-      Just lf_info ->
-        -- Use the LambdaFormInfo from the interface
-        lf_info
-      Nothing
-        -- Interface doesn't have a LambdaFormInfo, make a conservative one from
-        -- the type.
-        | Just con <- isDataConWorkId_maybe id
-        , isNullaryRepDataCon con
-        -> LFCon con   -- An imported nullary constructor
-                       -- We assume that the constructor is evaluated so that
-                       -- the id really does point directly to the constructor
-
-        | arity > 0
-        -> LFReEntrant TopLevel arity True ArgUnknown
-
-        | otherwise
-        -> mkLFArgument id -- Not sure of exact arity
-  where
-    arity = idFunRepArity id
-
--------------
-mkLFStringLit :: LambdaFormInfo
-mkLFStringLit = LFUnlifted
-
------------------------------------------------------
---                Dynamic pointer tagging
------------------------------------------------------
-
-type DynTag = Int       -- The tag on a *pointer*
-                        -- (from the dynamic-tagging paper)
-
--- Note [Data constructor dynamic tags]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- The family size of a data type (the number of constructors
--- or the arity of a function) can be either:
---    * small, if the family size < 2**tag_bits
---    * big, otherwise.
---
--- Small families can have the constructor tag in the tag bits.
--- Big families always use the tag values 1..mAX_PTR_TAG to represent
--- evaluatedness, the last one lumping together all overflowing ones.
--- We don't have very many tag bits: for example, we have 2 bits on
--- x86-32 and 3 bits on x86-64.
---
--- Also see Note [Tagging big families] in GHC.StgToCmm.Expr
---
--- The interpreter also needs to be updated if we change the
--- tagging strategy. See Note [Data constructor dynamic tags] in
--- rts/Interpreter.c
-
-isSmallFamily :: Platform -> Int -> Bool
-isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform
-
-tagForCon :: Platform -> DataCon -> DynTag
-tagForCon platform con = min (dataConTag con) (mAX_PTR_TAG platform)
--- NB: 1-indexed
-
-tagForArity :: Platform -> RepArity -> DynTag
-tagForArity platform arity
- | isSmallFamily platform arity = arity
- | otherwise                    = 0
-
--- | Return the tag in the low order bits of a variable bound
--- to this LambdaForm
-lfDynTag :: Platform -> LambdaFormInfo -> DynTag
-lfDynTag platform lf = case lf of
-   LFCon con               -> tagForCon   platform con
-   LFReEntrant _ arity _ _ -> tagForArity platform arity
-   _other                  -> 0
-
-
------------------------------------------------------------------------------
---                Observing LambdaFormInfo
------------------------------------------------------------------------------
-
-------------
-isLFThunk :: LambdaFormInfo -> Bool
-isLFThunk (LFThunk {})  = True
-isLFThunk _ = False
-
-isLFReEntrant :: LambdaFormInfo -> Bool
-isLFReEntrant (LFReEntrant {}) = True
-isLFReEntrant _                = False
-
------------------------------------------------------------------------------
---                Choosing SM reps
------------------------------------------------------------------------------
-
-lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
-lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd
-lfClosureType (LFCon con)                  = Constr (dataConTagZ con)
-                                                    (dataConIdentity con)
-lfClosureType (LFThunk _ _ _ is_sel _)     = thunkClosureType is_sel
-lfClosureType _                            = panic "lfClosureType"
-
-thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
-thunkClosureType (SelectorThunk off) = ThunkSelector off
-thunkClosureType _                   = Thunk
-
--- We *do* get non-updatable top-level thunks sometimes.  eg. f = g
--- gets compiled to a jump to g (if g has non-zero arity), instead of
--- messing around with update frames and PAPs.  We set the closure type
--- to FUN_STATIC in this case.
-
------------------------------------------------------------------------------
---                nodeMustPointToIt
------------------------------------------------------------------------------
-
-nodeMustPointToIt :: Profile -> LambdaFormInfo -> Bool
--- If nodeMustPointToIt is true, then the entry convention for
--- this closure has R1 (the "Node" register) pointing to the
--- closure itself --- the "self" argument
-
-nodeMustPointToIt _ (LFReEntrant top _ no_fvs _)
-  =  not no_fvs          -- Certainly if it has fvs we need to point to it
-  || isNotTopLevel top   -- See Note [GC recovery]
-        -- For lex_profiling we also access the cost centre for a
-        -- non-inherited (i.e. non-top-level) function.
-        -- The isNotTopLevel test above ensures this is ok.
-
-nodeMustPointToIt profile (LFThunk top no_fvs updatable NonStandardThunk _)
-  =  not no_fvs            -- Self parameter
-  || isNotTopLevel top     -- Note [GC recovery]
-  || updatable             -- Need to push update frame
-  || profileIsProfiling profile
-          -- For the non-updatable (single-entry case):
-          --
-          -- True if has fvs (in which case we need access to them, and we
-          --                    should black-hole it)
-          -- or profiling (in which case we need to recover the cost centre
-          --                 from inside it)  ToDo: do we need this even for
-          --                                    top-level thunks? If not,
-          --                                    isNotTopLevel subsumes this
-
-nodeMustPointToIt _ (LFThunk {})        -- Node must point to a standard-form thunk
-  = True
-
-nodeMustPointToIt _ (LFCon _) = True
-
-        -- Strictly speaking, the above two don't need Node to point
-        -- to it if the arity = 0.  But this is a *really* unlikely
-        -- situation.  If we know it's nil (say) and we are entering
-        -- it. Eg: let x = [] in x then we will certainly have inlined
-        -- x, since nil is a simple atom.  So we gain little by not
-        -- having Node point to known zero-arity things.  On the other
-        -- hand, we do lose something; Patrick's code for figuring out
-        -- when something has been updated but not entered relies on
-        -- having Node point to the result of an update.  SLPJ
-        -- 27/11/92.
-
-nodeMustPointToIt _ (LFUnknown _)   = True
-nodeMustPointToIt _ LFUnlifted      = False
-nodeMustPointToIt _ LFLetNoEscape   = False
-
-{- Note [GC recovery]
-~~~~~~~~~~~~~~~~~~~~~
-If we a have a local let-binding (function or thunk)
-   let f = <body> in ...
-AND <body> allocates, then the heap-overflow check needs to know how
-to re-start the evaluation.  It uses the "self" pointer to do this.
-So even if there are no free variables in <body>, we still make
-nodeMustPointToIt be True for non-top-level bindings.
-
-Why do any such bindings exist?  After all, let-floating should have
-floated them out.  Well, a clever optimiser might leave one there to
-avoid a space leak, deliberately recomputing a thunk.  Also (and this
-really does happen occasionally) let-floating may make a function f smaller
-so it can be inlined, so now (f True) may generate a local no-fv closure.
-This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind
-in GHC.Tc.Deriv.Generate.) -}
-
------------------------------------------------------------------------------
---                getCallMethod
------------------------------------------------------------------------------
-
-{- The entry conventions depend on the type of closure being entered,
-whether or not it has free variables, and whether we're running
-sequentially or in parallel.
-
-Closure                           Node   Argument   Enter
-Characteristics              Par   Req'd  Passing    Via
----------------------------------------------------------------------------
-Unknown                     & no  & yes & stack     & node
-Known fun (>1 arg), no fvs  & no  & no  & registers & fast entry (enough args)
-                                                    & slow entry (otherwise)
-Known fun (>1 arg), fvs     & no  & yes & registers & fast entry (enough args)
-0 arg, no fvs \r,\s         & no  & no  & n/a       & direct entry
-0 arg, no fvs \u            & no  & yes & n/a       & node
-0 arg, fvs \r,\s,selector   & no  & yes & n/a       & node
-0 arg, fvs \r,\s            & no  & yes & n/a       & direct entry
-0 arg, fvs \u               & no  & yes & n/a       & node
-Unknown                     & yes & yes & stack     & node
-Known fun (>1 arg), no fvs  & yes & no  & registers & fast entry (enough args)
-                                                    & slow entry (otherwise)
-Known fun (>1 arg), fvs     & yes & yes & registers & node
-0 arg, fvs \r,\s,selector   & yes & yes & n/a       & node
-0 arg, no fvs \r,\s         & yes & no  & n/a       & direct entry
-0 arg, no fvs \u            & yes & yes & n/a       & node
-0 arg, fvs \r,\s            & yes & yes & n/a       & node
-0 arg, fvs \u               & yes & yes & n/a       & node
-
-When black-holing, single-entry closures could also be entered via node
-(rather than directly) to catch double-entry. -}
-
-data CallMethod
-  = EnterIt             -- ^ No args, not a function
-
-  | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop
-
-  | ReturnIt            -- It's a value (function, unboxed value,
-                        -- or constructor), so just return it.
-
-  | InferedReturnIt     -- A properly tagged value, as determined by tag inference.
-                        -- See Note [Tag Inference] and Note [Tag inference passes] in
-                        -- GHC.Stg.InferTags.
-                        -- It behaves /precisely/ like `ReturnIt`, except that when debugging is
-                        -- enabled we emit an extra assertion to check that the returned value is
-                        -- properly tagged.  We can use this as a check that tag inference is working
-                        -- correctly.
-                        -- TODO: SPJ suggested we could combine this with EnterIt, but for now I decided
-                        -- not to do so.
-
-  | SlowCall            -- Unknown fun, or known fun with
-                        -- too few args.
-
-  | DirectEntry         -- Jump directly, with args in regs
-        CLabel          --   The code label
-        RepArity        --   Its arity
-
-instance Outputable CallMethod where
-  ppr (EnterIt) = text "Enter"
-  ppr (JumpToIt {}) = text "JumpToIt"
-  ppr (ReturnIt ) = text "ReturnIt"
-  ppr (InferedReturnIt) = text "InferedReturnIt"
-  ppr (SlowCall ) = text "SlowCall"
-  ppr (DirectEntry {}) = text "DirectEntry"
-
-getCallMethod :: StgToCmmConfig
-              -> Name           -- Function being applied
-              -> Id             -- Function Id used to chech if it can refer to
-                                -- CAF's and whether the function is tail-calling
-                                -- itself
-              -> LambdaFormInfo -- Its info
-              -> RepArity       -- Number of available arguments
-              -> RepArity       -- Number of them being void arguments
-              -> CgLoc          -- Passed in from cgIdApp so that we can
-                                -- handle let-no-escape bindings and self-recursive
-                                -- tail calls using the same data constructor,
-                                -- JumpToIt. This saves us one case branch in
-                                -- cgIdApp
-              -> Maybe SelfLoopInfo -- can we perform a self-recursive tail-call
-              -> CallMethod
-
-getCallMethod cfg _ id _  n_args v_args _cg_loc (Just (self_loop_id, block_id, args))
-  | stgToCmmLoopification cfg
-  , id == self_loop_id
-  , args `lengthIs` (n_args - v_args)
-  -- If these patterns match then we know that:
-  --   * loopification optimisation is turned on
-  --   * function is performing a self-recursive call in a tail position
-  --   * number of non-void parameters of the function matches functions arity.
-  -- See Note [Self-recursive tail calls] and Note [Void arguments in
-  -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details
-  = JumpToIt block_id args
-
-getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info
-  | n_args == 0 -- No args at all
-  && not (profileIsProfiling (stgToCmmProfile cfg))
-     -- See Note [Evaluating functions with profiling] in rts/Apply.cmm
-  = assert (arity /= 0) ReturnIt
-  | n_args < arity = SlowCall        -- Not enough args
-  | otherwise      = DirectEntry (enterIdLabel (stgToCmmPlatform cfg) name (idCafInfo id)) arity
-
-getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info
-  = assert (n_args == 0) ReturnIt
-
-getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info
-  = assert (n_args == 0) ReturnIt
-    -- n_args=0 because it'd be ill-typed to apply a saturated
-    --          constructor application to anything
-
-getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun)
-              n_args _v_args _cg_loc _self_loop_info
-
-  | Just sig <- idTagSig_maybe id
-  , isTaggedSig sig -- Infered to be already evaluated by Tag Inference
-  , n_args == 0     -- See Note [Tag Inference]
-  = InferedReturnIt
-
-  | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)
-  = SlowCall    -- We cannot just enter it [in eval/apply, the entry code
-                -- is the fast-entry code]
-
-  -- Since is_fun is False, we are *definitely* looking at a data value
-  | updatable || stgToCmmDoTicky cfg -- to catch double entry
-      {- OLD: || opt_SMP
-         I decided to remove this, because in SMP mode it doesn't matter
-         if we enter the same thunk multiple times, so the optimisation
-         of jumping directly to the entry code is still valid.  --SDM
-        -}
-  = EnterIt
-
-  -- even a non-updatable selector thunk can be updated by the garbage
-  -- collector, so we must enter it. (#8817)
-  | SelectorThunk{} <- std_form_info
-  = EnterIt
-
-    -- We used to have assert (n_args == 0 ), but actually it is
-    -- possible for the optimiser to generate
-    --   let bot :: Int = error Int "urk"
-    --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
-    -- This happens as a result of the case-of-error transformation
-    -- So the right thing to do is just to enter the thing
-
-  | otherwise        -- Jump direct to code for single-entry thunks
-  = assert (n_args == 0) $
-    DirectEntry (thunkEntryLabel (stgToCmmPlatform cfg) name (idCafInfo id) std_form_info
-                updatable) 0
-
--- Imported(Unknown) Ids
-getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _v_args _cg_locs _self_loop_info
-  | n_args == 0
-  , Just sig <- idTagSig_maybe id
-  , isTaggedSig sig -- Infered to be already evaluated by Tag Inference
-  -- When profiling we must enter all potential functions to make sure we update the SCC
-  -- even if the function itself is already evaluated.
-  -- See Note [Evaluating functions with profiling] in rts/Apply.cmm
-  , not (profileIsProfiling (stgToCmmProfile cfg) && might_be_a_function)
-  = InferedReturnIt -- See Note [Tag Inference]
-
-  | might_be_a_function = SlowCall
-
-  | otherwise =
-      assertPpr ( n_args == 0) ( ppr name <+> ppr n_args )
-      EnterIt   -- Not a function
-
--- TODO: Redundant with above match?
--- getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info
---   = assertPpr (n_args == 0) (ppr name <+> ppr n_args)
---     EnterIt -- Not a function
-
-getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs) _self_loop_info
-  = JumpToIt blk_id lne_regs
-
-getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"
-
------------------------------------------------------------------------------
---              Data types for closure information
------------------------------------------------------------------------------
-
-
-{- ClosureInfo: information about a binding
-
-   We make a ClosureInfo for each let binding (both top level and not),
-   but not bindings for data constructors: for those we build a CmmInfoTable
-   directly (see mkDataConInfoTable).
-
-   To a first approximation:
-       ClosureInfo = (LambdaFormInfo, CmmInfoTable)
-
-   A ClosureInfo has enough information
-     a) to construct the info table itself, and build other things
-        related to the binding (e.g. slow entry points for a function)
-     b) to allocate a closure containing that info pointer (i.e.
-           it knows the info table label)
--}
-
-data ClosureInfo
-  = ClosureInfo {
-        closureName :: !Id,           -- The thing bound to this closure
-           -- we don't really need this field: it's only used in generating
-           -- code for ticky and profiling, and we could pass the information
-           -- around separately, but it doesn't do much harm to keep it here.
-
-        closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon
-          -- this tells us about what the closure contains: it's right-hand-side.
-
-          -- the rest is just an unpacked CmmInfoTable.
-        closureInfoLabel :: !CLabel,
-        closureSMRep     :: !SMRep,          -- representation used by storage mgr
-        closureProf      :: !ProfilingInfo
-    }
-
--- | Convert from 'ClosureInfo' to 'CmmInfoTable'.
-mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
-mkCmmInfo ClosureInfo {..} id ccs
-  = CmmInfoTable { cit_lbl  = closureInfoLabel
-                 , cit_rep  = closureSMRep
-                 , cit_prof = closureProf
-                 , cit_srt  = Nothing
-                 , cit_clo  = if isStaticRep closureSMRep
-                                then Just (id,ccs)
-                                else Nothing }
-
---------------------------------------
---        Building ClosureInfos
---------------------------------------
-
-mkClosureInfo :: Profile
-              -> Bool                -- Is static
-              -> Id
-              -> LambdaFormInfo
-              -> Int -> Int        -- Total and pointer words
-              -> String         -- String descriptor
-              -> ClosureInfo
-mkClosureInfo profile is_static id lf_info tot_wds ptr_wds val_descr
-  = ClosureInfo { closureName      = id
-                , closureLFInfo    = lf_info
-                , closureInfoLabel = info_lbl   -- These three fields are
-                , closureSMRep     = sm_rep     -- (almost) an info table
-                , closureProf      = prof }     -- (we don't have an SRT yet)
-  where
-    sm_rep     = mkHeapRep profile is_static ptr_wds nonptr_wds (lfClosureType lf_info)
-    prof       = mkProfilingInfo profile id val_descr
-    nonptr_wds = tot_wds - ptr_wds
-
-    info_lbl = mkClosureInfoTableLabel (profilePlatform profile) id lf_info
-
---------------------------------------
---   Other functions over ClosureInfo
---------------------------------------
-
--- Eager blackholing is normally disabled, but can be turned on with
--- -feager-blackholing.  When it is on, we replace the info pointer of
--- the thunk with stg_EAGER_BLACKHOLE_info on entry.
-
--- If we wanted to do eager blackholing with slop filling,
--- we'd need to do it at the *end* of a basic block, otherwise
--- we overwrite the free variables in the thunk that we still
--- need.  We have a patch for this from Andy Cheadle, but not
--- incorporated yet. --SDM [6/2004]
---
--- Previously, eager blackholing was enabled when ticky-ticky
--- was on. But it didn't work, and it wasn't strictly necessary
--- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
--- is unconditionally disabled. -- krc 1/2007
---
--- Static closures are never themselves black-holed.
-
-blackHoleOnEntry :: ClosureInfo -> Bool
-blackHoleOnEntry cl_info
-  | isStaticRep (closureSMRep cl_info)
-  = False        -- Never black-hole a static closure
-
-  | otherwise
-  = case closureLFInfo cl_info of
-      LFReEntrant {}            -> False
-      LFLetNoEscape             -> False
-      LFThunk _ _no_fvs upd _ _ -> upd   -- See Note [Black-holing non-updatable thunks]
-      _other -> panic "blackHoleOnEntry"
-
-{- Note [Black-holing non-updatable thunks]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must not black-hole non-updatable (single-entry) thunks otherwise
-we run into issues like #10414. Specifically:
-
-  * There is no reason to black-hole a non-updatable thunk: it should
-    not be competed for by multiple threads
-
-  * It could, conceivably, cause a space leak if we don't black-hole
-    it, if there was a live but never-followed pointer pointing to it.
-    Let's hope that doesn't happen.
-
-  * It is dangerous to black-hole a non-updatable thunk because
-     - is not updated (of course)
-     - hence, if it is black-holed and another thread tries to evaluate
-       it, that thread will block forever
-    This actually happened in #10414.  So we do not black-hole
-    non-updatable thunks.
-
-  * How could two threads evaluate the same non-updatable (single-entry)
-    thunk?  See Reid Barton's example below.
-
-  * Only eager blackholing could possibly black-hole a non-updatable
-    thunk, because lazy black-holing only affects thunks with an
-    update frame on the stack.
-
-Here is and example due to Reid Barton (#10414):
-    x = \u []  concat [[1], []]
-with the following definitions,
-
-    concat x = case x of
-        []       -> []
-        (:) x xs -> (++) x (concat xs)
-
-    (++) xs ys = case xs of
-        []         -> ys
-        (:) x rest -> (:) x ((++) rest ys)
-
-Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to
-denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@
-to WHNF and calls @(++)@ the heap will contain the following thunks,
-
-    x = 1 : y
-    y = \u []  (++) [] z
-    z = \s []  concat []
-
-Now that the stage is set, consider the follow evaluations by two racing threads
-A and B,
-
-  1. Both threads enter @y@ before either is able to replace it with an
-     indirection
-
-  2. Thread A does the case analysis in @(++)@ and consequently enters @z@,
-     replacing it with a black-hole
-
-  3. At some later point thread B does the same case analysis and also attempts
-     to enter @z@. However, it finds that it has been replaced with a black-hole
-     so it blocks.
-
-  4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@
-     accordingly. It does *not* update @z@, however, as it is single-entry. This
-     leaves Thread B blocked forever on a black-hole which will never be
-     updated.
-
-To avoid this sort of condition we never black-hole non-updatable thunks.
--}
-
-isStaticClosure :: ClosureInfo -> Bool
-isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
-
-closureUpdReqd :: ClosureInfo -> Bool
-closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
-
-lfUpdatable :: LambdaFormInfo -> Bool
-lfUpdatable (LFThunk _ _ upd _ _)  = upd
-lfUpdatable _ = False
-
-closureReEntrant :: ClosureInfo -> Bool
-closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True
-closureReEntrant _ = False
-
-closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
-closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
-
-lfFunInfo :: LambdaFormInfo ->  Maybe (RepArity, ArgDescr)
-lfFunInfo (LFReEntrant _ arity _ arg_desc)  = Just (arity, arg_desc)
-lfFunInfo _                                 = Nothing
-
-funTag :: Platform -> ClosureInfo -> DynTag
-funTag platform (ClosureInfo { closureLFInfo = lf_info })
-    = lfDynTag platform lf_info
-
-isToplevClosure :: ClosureInfo -> Bool
-isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
-  = case lf_info of
-      LFReEntrant TopLevel _ _ _ -> True
-      LFThunk TopLevel _ _ _ _   -> True
-      _other                     -> False
-
---------------------------------------
---   Label generation
---------------------------------------
-
-staticClosureLabel :: Platform -> ClosureInfo -> CLabel
-staticClosureLabel platform = toClosureLbl platform .  closureInfoLabel
-
-closureSlowEntryLabel :: Platform -> ClosureInfo -> CLabel
-closureSlowEntryLabel platform = toSlowEntryLbl platform . closureInfoLabel
-
-closureLocalEntryLabel :: Platform -> ClosureInfo -> CLabel
-closureLocalEntryLabel platform
-  | platformTablesNextToCode platform = toInfoLbl  platform . closureInfoLabel
-  | otherwise                         = toEntryLbl platform . closureInfoLabel
-
--- | Get the info table label for a *thunk*.
-mkClosureInfoTableLabel :: Platform -> Id -> LambdaFormInfo -> CLabel
-mkClosureInfoTableLabel platform id lf_info
-  = case lf_info of
-        LFThunk _ _ upd_flag (SelectorThunk offset) _
-                      -> mkSelectorInfoLabel platform upd_flag offset
-
-        LFThunk _ _ upd_flag (ApThunk arity) _
-                      -> mkApInfoTableLabel platform upd_flag arity
-
-        LFThunk{}     -> mkInfoTableLabel name cafs
-        LFReEntrant{} -> mkInfoTableLabel name cafs
-        _other        -> panic "closureInfoTableLabel"
-
-  where
-    name = idName id
-
-    cafs     = idCafInfo id
-
--- | thunkEntryLabel is a local help function, not exported.  It's used from
--- getCallMethod.
-thunkEntryLabel :: Platform -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
-thunkEntryLabel platform thunk_id caf_info sfi upd_flag = case sfi of
-   ApThunk arity        -> enterApLabel       platform upd_flag arity
-   SelectorThunk offset -> enterSelectorLabel platform upd_flag offset
-   _                    -> enterIdLabel       platform thunk_id caf_info
-
-enterApLabel :: Platform -> Bool -> Arity -> CLabel
-enterApLabel platform is_updatable arity
-  | platformTablesNextToCode platform = mkApInfoTableLabel platform is_updatable arity
-  | otherwise                         = mkApEntryLabel     platform is_updatable arity
-
-enterSelectorLabel :: Platform -> Bool -> WordOff -> CLabel
-enterSelectorLabel platform upd_flag offset
-  | platformTablesNextToCode platform = mkSelectorInfoLabel  platform upd_flag offset
-  | otherwise                         = mkSelectorEntryLabel platform upd_flag offset
-
-enterIdLabel :: Platform -> Name -> CafInfo -> CLabel
-enterIdLabel platform id c
-  | platformTablesNextToCode platform = mkInfoTableLabel id c
-  | otherwise                         = mkEntryLabel id c
-
-
---------------------------------------
---   Profiling
---------------------------------------
-
--- Profiling requires two pieces of information to be determined for
--- each closure's info table --- description and type.
-
--- The description is stored directly in the @CClosureInfoTable@ when the
--- info table is built.
-
--- The type is determined from the type information stored with the @Id@
--- in the closure info using @closureTypeDescr@.
-
-mkProfilingInfo :: Profile -> Id -> String -> ProfilingInfo
-mkProfilingInfo profile id val_descr
-  | not (profileIsProfiling profile) = NoProfilingInfo
-  | otherwise                        = ProfilingInfo ty_descr_w8 (BS8.pack val_descr)
-  where
-    ty_descr_w8  = BS8.pack (getTyDescription (idType id))
-
-getTyDescription :: Type -> String
-getTyDescription ty
-  = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
-    case tau_ty of
-      TyVarTy _              -> "*"
-      AppTy fun _            -> getTyDescription fun
-      TyConApp tycon _       -> getOccString tycon
-      FunTy {}              -> '-' : fun_result tau_ty
-      ForAllTy _  ty         -> getTyDescription ty
-      LitTy n                -> getTyLitDescription n
-      CastTy ty _            -> getTyDescription ty
-      CoercionTy co          -> pprPanic "getTyDescription" (ppr co)
-    }
-  where
-    fun_result (FunTy { ft_res = res }) = '>' : fun_result res
-    fun_result other                    = getTyDescription other
-
-getTyLitDescription :: TyLit -> String
-getTyLitDescription l =
-  case l of
-    NumTyLit n -> show n
-    StrTyLit n -> show n
-    CharTyLit n -> show n
-
---------------------------------------
---   CmmInfoTable-related things
---------------------------------------
-
-mkDataConInfoTable :: Profile -> DataCon -> ConInfoTableLocation -> Bool -> Int -> Int -> CmmInfoTable
-mkDataConInfoTable profile data_con mn is_static ptr_wds nonptr_wds
- = CmmInfoTable { cit_lbl  = info_lbl
-                , cit_rep  = sm_rep
-                , cit_prof = prof
-                , cit_srt  = Nothing
-                , cit_clo  = Nothing }
- where
-   name = dataConName data_con
-   info_lbl = mkConInfoTableLabel name mn -- NoCAFRefs
-   sm_rep = mkHeapRep profile is_static ptr_wds nonptr_wds cl_type
-   cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)
-                  -- We keep the *zero-indexed* tag in the srt_len field
-                  -- of the info table of a data constructor.
-
-   prof | not (profileIsProfiling profile) = NoProfilingInfo
-        | otherwise                        = ProfilingInfo ty_descr val_descr
-
-   ty_descr  = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con
-   val_descr = BS8.pack $ occNameString $ getOccName data_con
-
--- We need a black-hole closure info to pass to @allocDynClosure@ when we
--- want to allocate the black hole on entry to a CAF.
-
-cafBlackHoleInfoTable :: CmmInfoTable
-cafBlackHoleInfoTable
-  = CmmInfoTable { cit_lbl  = mkCAFBlackHoleInfoTableLabel
-                 , cit_rep  = blackHoleRep
-                 , cit_prof = NoProfilingInfo
-                 , cit_srt  = Nothing
-                 , cit_clo  = Nothing }
-
-indStaticInfoTable :: CmmInfoTable
-indStaticInfoTable
-  = CmmInfoTable { cit_lbl  = mkIndStaticInfoLabel
-                 , cit_rep  = indStaticRep
-                 , cit_prof = NoProfilingInfo
-                 , cit_srt  = Nothing
-                 , cit_clo  = Nothing }
-
-staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
--- A static closure needs a link field to aid the GC when traversing
--- the static closure graph.  But it only needs such a field if either
---        a) it has an SRT
---        b) it's a constructor with one or more pointer fields
--- In case (b), the constructor's fields themselves play the role
--- of the SRT.
-staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }
-  | isConRep smrep         = not (isStaticNoCafCon smrep)
-  | otherwise              = has_srt
diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/DataCon.hs
+++ /dev/null
@@ -1,405 +0,0 @@
-
-
------------------------------------------------------------------------------
---
--- Stg to C--: code generation for constructors
---
--- This module provides the support code for StgToCmm to deal with
--- constructors on the RHSs of let(rec)s.
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.DataCon (
-        cgTopRhsCon, buildDynCon, bindConArgs
-    ) where
-
-import GHC.Prelude
-
-import GHC.Platform
-
-import GHC.Stg.Syntax
-import GHC.Core  ( AltCon(..) )
-
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Env
-import GHC.StgToCmm.Heap
-import GHC.StgToCmm.Layout
-import GHC.StgToCmm.Utils
-import GHC.StgToCmm.Closure
-
-import GHC.Cmm.Expr
-import GHC.Cmm.Utils
-import GHC.Cmm.CLabel
-import GHC.Cmm.Graph
-import GHC.Runtime.Heap.Layout
-import GHC.Types.CostCentre
-import GHC.Unit
-import GHC.Core.DataCon
-import GHC.Data.FastString
-import GHC.Types.Id
-import GHC.Types.Id.Info( CafInfo( NoCafRefs ) )
-import GHC.Types.Name (isInternalName)
-import GHC.Types.RepType (countConRepArgs)
-import GHC.Types.Literal
-import GHC.Builtin.Utils
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Misc
-import GHC.Utils.Monad (mapMaybeM)
-
-import Control.Monad
-import Data.Char
-import GHC.StgToCmm.Config (stgToCmmPlatform)
-import GHC.StgToCmm.TagCheck (checkConArgsStatic, checkConArgsDyn)
-import GHC.Utils.Outputable
-
----------------------------------------------------------------
---      Top-level constructors
----------------------------------------------------------------
-
-cgTopRhsCon :: StgToCmmConfig
-            -> Id               -- Name of thing bound to this RHS
-            -> DataCon          -- Id
-            -> ConstructorNumber
-            -> [NonVoid StgArg] -- Args
-            -> (CgIdInfo, FCode ())
-cgTopRhsCon cfg id con mn args
-  | Just static_info <- precomputedStaticConInfo_maybe cfg id con args
-  , let static_code | isInternalName name = pure ()
-                    | otherwise           = gen_code
-  = -- There is a pre-allocated static closure available; use it
-    -- See Note [Precomputed static closures].
-    -- For External bindings we must keep the binding,
-    -- since importing modules will refer to it by name;
-    -- but for Internal ones we can drop it altogether
-    -- See Note [About the NameSorts] in "GHC.Types.Name" for Internal/External
-    (static_info, static_code)
-
-  -- Otherwise generate a closure for the constructor.
-  | otherwise
-  = (id_Info, gen_code)
-
-  where
-   platform      = stgToCmmPlatform cfg
-   id_Info       = litIdInfo platform id (mkConLFInfo con) (CmmLabel closure_label)
-   name          = idName id
-   caffy         = idCafInfo id -- any stgArgHasCafRefs args
-   closure_label = mkClosureLabel name caffy
-
-   gen_code =
-     do { profile <- getProfile
-        ; this_mod <- getModuleName
-        ; when (platformOS platform == OSMinGW32) $
-              -- Windows DLLs have a problem with static cross-DLL refs.
-              massert (not (isDllConApp platform (stgToCmmExtDynRefs cfg) this_mod con (map fromNonVoid args)))
-        ; assert (args `lengthIs` countConRepArgs con ) return ()
-        ; checkConArgsStatic (text "TagCheck failed - Top level con") con (map fromNonVoid args)
-        -- LAY IT OUT
-        ; let
-            (tot_wds, --  #ptr_wds + #nonptr_wds
-             ptr_wds, --  #ptr_wds
-             nv_args_w_offsets) =
-                 mkVirtHeapOffsetsWithPadding profile StdHeader (addArgReps args)
-
-        ; let
-            -- Decompose padding into units of length 8, 4, 2, or 1 bytes to
-            -- allow the implementation of mk_payload to use widthFromBytes,
-            -- which only handles these cases.
-            fix_padding (x@(Padding n off) : rest)
-              | n == 0                 = fix_padding rest
-              | n `elem` [1,2,4,8]     = x : fix_padding rest
-              | n > 8                  = add_pad 8
-              | n > 4                  = add_pad 4
-              | n > 2                  = add_pad 2
-              | otherwise              = add_pad 1
-              where add_pad m = Padding m off : fix_padding (Padding (n-m) (off+m) : rest)
-            fix_padding (x : rest)     = x : fix_padding rest
-            fix_padding []             = []
-
-            mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
-            mk_payload (FieldOff arg _) = do
-                amode <- getArgAmode arg
-                case amode of
-                  CmmLit lit -> return lit
-                  _          -> panic "GHC.StgToCmm.DataCon.cgTopRhsCon"
-
-            nonptr_wds = tot_wds - ptr_wds
-
-             -- we're not really going to emit an info table, so having
-             -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields
-             -- needs to poke around inside it.
-            info_tbl = mkDataConInfoTable profile con (addModuleLoc this_mod mn) True ptr_wds nonptr_wds
-
-
-        ; payload <- mapM mk_payload (fix_padding nv_args_w_offsets)
-                -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
-                -- NB2: all the amodes should be Lits!
-                --      TODO (osa): Why?
-
-                -- BUILD THE OBJECT
-                --
-            -- We're generating info tables, so we don't know and care about
-            -- what the actual arguments are. Using () here as the place holder.
-
-        ; emitDataCon closure_label info_tbl dontCareCCS payload }
-
-addModuleLoc :: Module -> ConstructorNumber -> ConInfoTableLocation
-addModuleLoc this_mod mn = do
-  case mn of
-    NoNumber -> DefinitionSite
-    Numbered n -> UsageSite this_mod n
-
----------------------------------------------------------------
---      Lay out and allocate non-top-level constructors
----------------------------------------------------------------
-
-buildDynCon :: Id                 -- Name of the thing to which this constr will
-                                  -- be bound
-            -> ConstructorNumber
-            -> Bool               -- is it genuinely bound to that name, or just
-                                  -- for profiling?
-            -> CostCentreStack    -- Where to grab cost centre from;
-                                  -- current CCS if currentOrSubsumedCCS
-            -> DataCon            -- The data constructor
-            -> [NonVoid StgArg]   -- Its args
-            -> FCode (CgIdInfo, FCode CmmAGraph)
-               -- Return details about how to find it and initialization code
-buildDynCon binder mn actually_bound cc con args
-    = do cfg <- getStgToCmmConfig
-         --   pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True
-         case precomputedStaticConInfo_maybe cfg binder con args of
-           Just cgInfo -> return (cgInfo, return mkNop)
-           Nothing     -> buildDynCon' binder mn actually_bound cc con args
-
-
-buildDynCon' :: Id
-             -> ConstructorNumber
-             -> Bool
-             -> CostCentreStack
-             -> DataCon
-             -> [NonVoid StgArg]
-             -> FCode (CgIdInfo, FCode CmmAGraph)
-{- We used to pass a boolean indicating whether all the
-args were of size zero, so we could use a static
-constructor; but I concluded that it just isn't worth it.
-Now I/O uses unboxed tuples there just aren't any constructors
-with all size-zero args.
-
-The reason for having a separate argument, rather than looking at
-the addr modes of the args is that we may be in a "knot", and
-premature looking at the args will cause the compiler to black-hole!
--}
--------- buildDynCon': the general case -----------
-buildDynCon' binder mn actually_bound ccs con args
-  = do  { (id_info, reg) <- rhsIdInfo binder lf_info
-        ; return (id_info, gen_code reg)
-        }
- where
-  lf_info = mkConLFInfo con
-
-  gen_code reg
-    = do  { modu <- getModuleName
-          ; cfg  <- getStgToCmmConfig
-          ; let platform = stgToCmmPlatform cfg
-                profile  = stgToCmmProfile  cfg
-                (tot_wds, ptr_wds, args_w_offsets)
-                   = mkVirtConstrOffsets profile (addArgReps args)
-                nonptr_wds = tot_wds - ptr_wds
-                info_tbl = mkDataConInfoTable profile con (addModuleLoc modu mn) False
-                                ptr_wds nonptr_wds
-          ; let ticky_name | actually_bound = Just binder
-                           | otherwise = Nothing
-
-          ; checkConArgsDyn (hang (text "TagCheck failed on constructor application.") 4 $
-                                   text "On binder:" <> ppr binder $$ text "Constructor:" <> ppr con) con (map fromNonVoid args)
-          ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info
-                                          use_cc blame_cc args_w_offsets
-          ; return (mkRhsInit platform reg lf_info hp_plus_n) }
-    where
-      use_cc      -- cost-centre to stick in the object
-        | isCurrentCCS ccs = cccsExpr
-        | otherwise        = panic "buildDynCon: non-current CCS not implemented"
-
-      blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
-
-
-{- Note [Precomputed static closures]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-For Char/Int closures there are some value closures
-built into the RTS. This is the case for all values in
-the range mINT_INTLIKE .. mAX_INTLIKE (or CHARLIKE).
-See Note [CHARLIKE and INTLIKE closures] in the RTS code.
-
-Similarly zero-arity constructors have a closure
-in their defining Module we can use.
-
-If possible we prefer to refer to those existing
-closure instead of building new ones.
-
-This is true at compile time where we do this replacement
-in this module.
-But also at runtime where the GC does the same (but only for
-INT/CHAR closures).
-
-`precomputedStaticConInfo_maybe` checks if a given constructor application
-can be replaced with a reference to a existing static closure.
-
-If so the code will reference the existing closure when accessing
-the binding.
-Unless the binding is visible to other modules we also generate
-no code for the binding itself. We can do this since then we can
-always reference the existing closure.
-
-See Note [About the NameSorts] for the definition of external names.
-For external bindings we must still generate a closure,
-but won't use it inside this module.
-This can sometimes reduce cache pressure. Since:
-* If somebody uses the exported binding:
-  + This module will reference the existing closure.
-  + GC will reference the existing closure.
-  + The importing module will reference the built closure.
-* If nobody uses the exported binding:
-  + This module will reference the RTS closures.
-  + GC references the RTS closures
-
-In the later case we avoided loading the built closure into the cache which
-is what we optimize for here.
-
-Consider this example using Ints.
-
-    module M(externalInt, foo, bar) where
-
-    externalInt = 1 :: Int
-    internalInt = 1 :: Int
-    { -# NOINLINE foo #- }
-    foo = Just internalInt :: Maybe Int
-    bar = Just externalInt
-
-    ==================== STG: ====================
-    externalInt = I#! [1#];
-
-    bar = Just! [externalInt];
-
-    internalInt_rc = I#! [2#];
-
-    foo = Just! [internalInt_rc];
-
-For externally visible bindings we must generate closures
-since those may be referenced by their symbol `<name>_closure`
-when imported.
-
-`externalInt` is visible to other modules so we generate a closure:
-
-    [section ""data" . M.externalInt_closure" {
-        M.externalInt_closure:
-            const GHC.Types.I#_con_info;
-            const 1;
-    }]
-
-It will be referenced inside this module via `M.externalInt_closure+1`
-
-`internalInt` is however a internal name. As such we generate no code for
-it. References to it are replaced with references to the static closure as
-we can see in the closure built for `foo`:
-
-    [section ""data" . M.foo_closure" {
-        M.foo_closure:
-            const GHC.Maybe.Just_con_info;
-            const stg_INTLIKE_closure+289; // == I# 2
-            const 3;
-    }]
-
-This holds for both local and top level bindings.
-
-We don't support this optimization when compiling into Windows DLLs yet
-because they don't support cross package data references well.
--}
-
--- (precomputedStaticConInfo_maybe cfg id con args)
---     returns (Just cg_id_info)
--- if there is a precomputed static closure for (con args).
--- In that case, cg_id_info addresses it.
--- See Note [Precomputed static closures]
-precomputedStaticConInfo_maybe :: StgToCmmConfig -> Id -> DataCon -> [NonVoid StgArg] -> Maybe CgIdInfo
-precomputedStaticConInfo_maybe cfg binder con []
--- Nullary constructors
-  | isNullaryRepDataCon con
-  = Just $ litIdInfo (stgToCmmPlatform cfg) binder (mkConLFInfo con)
-                (CmmLabel (mkClosureLabel (dataConName con) NoCafRefs))
-precomputedStaticConInfo_maybe cfg binder con [arg]
-  -- Int/Char values with existing closures in the RTS
-  | intClosure || charClosure
-  , platformOS platform /= OSMinGW32 || not (stgToCmmPIE cfg || stgToCmmPIC cfg)
-  , Just val <- getClosurePayload arg
-  , inRange val
-  = let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit label)
-        val_int = fromIntegral val :: Int
-        offsetW = (val_int - fromIntegral min_static_range) * (fixedHdrSizeW profile + 1)
-                -- INTLIKE/CHARLIKE closures consist of a header and one word payload
-        static_amode = cmmLabelOffW platform intlike_lbl offsetW
-    in Just $ litIdInfo platform binder (mkConLFInfo con) static_amode
-  where
-    profile     = stgToCmmProfile  cfg
-    platform    = stgToCmmPlatform cfg
-    intClosure  = maybeIntLikeCon  con
-    charClosure = maybeCharLikeCon con
-    getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val))) = Just val
-    getClosurePayload (NonVoid (StgLitArg (LitChar val))) = Just (fromIntegral . ord $ val)
-    getClosurePayload _ = Nothing
-    -- Avoid over/underflow by comparisons at type Integer!
-    inRange :: Integer -> Bool
-    inRange val
-      = val >= min_static_range && val <= max_static_range
-
-    constants = platformConstants platform
-
-    min_static_range :: Integer
-    min_static_range
-      | intClosure = fromIntegral (pc_MIN_INTLIKE constants)
-      | charClosure = fromIntegral (pc_MIN_CHARLIKE constants)
-      | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type"
-    max_static_range
-      | intClosure = fromIntegral (pc_MAX_INTLIKE constants)
-      | charClosure = fromIntegral (pc_MAX_CHARLIKE constants)
-      | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type"
-    label
-      | intClosure = "stg_INTLIKE"
-      | charClosure =  "stg_CHARLIKE"
-      | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type"
-
-precomputedStaticConInfo_maybe _ _ _ _ = Nothing
-
----------------------------------------------------------------
---      Binding constructor arguments
----------------------------------------------------------------
-
-bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
--- bindConArgs is called from cgAlt of a case
--- (bindConArgs con args) augments the environment with bindings for the
--- binders args, assuming that we have just returned from a 'case' which
--- found a con
-bindConArgs (DataAlt con) base args
-  = assert (not (isUnboxedTupleDataCon con)) $
-    do profile <- getProfile
-       platform <- getPlatform
-       let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args)
-           tag = tagForCon platform con
-
-           -- The binding below forces the masking out of the tag bits
-           -- when accessing the constructor field.
-           bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)
-           bind_arg (arg@(NonVoid b), offset)
-             | isDeadBinder b  -- See Note [Dead-binder optimisation] in GHC.StgToCmm.Expr
-             = return Nothing
-             | otherwise
-             = do { emit $ mkTaggedObjectLoad platform (idToReg platform arg)
-                                              base offset tag
-                  ; Just <$> bindArgToReg arg }
-
-       mapMaybeM bind_arg args_w_offsets
-
-bindConArgs _other_con _base args
-  = assert (null args ) return []
diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Env.hs
+++ /dev/null
@@ -1,209 +0,0 @@
-
-
------------------------------------------------------------------------------
---
--- Stg to C-- code generation: the binding environment
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-module GHC.StgToCmm.Env (
-        CgIdInfo,
-
-        litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
-        idInfoToAmode,
-
-        addBindC, addBindsC,
-
-        bindArgsToRegs, bindToReg, rebindToReg,
-        bindArgToReg, idToReg,
-        getCgIdInfo, getCgInfo_maybe,
-        maybeLetNoEscape,
-        ) where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Closure
-
-import GHC.Cmm.CLabel
-
-import GHC.Cmm.BlockId
-import GHC.Cmm.Expr
-import GHC.Cmm.Utils
-import GHC.Types.Id
-import GHC.Cmm.Graph
-import GHC.Types.Name
-import GHC.Core.Type
-import GHC.Core.TyCo.Compare( eqType )
-import GHC.Builtin.Types.Prim
-import GHC.Types.Unique.FM
-import GHC.Types.Var.Env
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-import GHC.Builtin.Names (getUnique)
-
-
--------------------------------------
---        Manipulating CgIdInfo
--------------------------------------
-
-mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
-mkCgIdInfo id lf expr
-  = CgIdInfo { cg_id = id, cg_lf = lf
-             , cg_loc = CmmLoc expr }
-
-litIdInfo :: Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
-litIdInfo platform id lf lit
-  = CgIdInfo { cg_id = id, cg_lf = lf
-             , cg_loc = CmmLoc (addDynTag platform (CmmLit lit) tag) }
-  where
-    tag = lfDynTag platform lf
-
-lneIdInfo :: Platform -> Id -> [NonVoid Id] -> CgIdInfo
-lneIdInfo platform id regs
-  = CgIdInfo { cg_id = id, cg_lf = lf
-             , cg_loc = LneLoc blk_id (map (idToReg platform) regs) }
-  where
-    lf     = mkLFLetNoEscape
-    blk_id = mkBlockId (idUnique id)
-
-
-rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
-rhsIdInfo id lf_info
-  = do platform <- getPlatform
-       reg <- newTemp (gcWord platform)
-       return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
-
-mkRhsInit :: Platform -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
-mkRhsInit platform reg lf_info expr
-  = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag platform lf_info))
-
-idInfoToAmode :: CgIdInfo -> CmmExpr
--- Returns a CmmExpr for the *tagged* pointer
-idInfoToAmode CgIdInfo { cg_loc = CmmLoc e } = e
-idInfoToAmode cg_info
-  = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc
-
--- | A tag adds a byte offset to the pointer
-addDynTag :: Platform -> CmmExpr -> DynTag -> CmmExpr
-addDynTag = cmmOffsetB
-
-maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
-maybeLetNoEscape CgIdInfo { cg_loc = LneLoc blk_id args} = Just (blk_id, args)
-maybeLetNoEscape _other                                      = Nothing
-
-
-
----------------------------------------------------------
---        The binding environment
---
--- There are three basic routines, for adding (addBindC),
--- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
----------------------------------------------------------
-
-addBindC :: CgIdInfo -> FCode ()
-addBindC stuff_to_bind = do
-        binds <- getBinds
-        setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
-
-addBindsC :: [CgIdInfo] -> FCode ()
-addBindsC new_bindings = do
-        binds <- getBinds
-        let new_binds = foldl' (\ binds info -> extendVarEnv binds (cg_id info) info)
-                               binds
-                               new_bindings
-        setBinds new_binds
-
--- Inside GHC the average module creates 385 external references
--- with notable cgIdInfo (so not generated by mkLFArgument).
--- On average 200 of these are covered by True/False/[]
--- and nullary constructors make up ~80.
--- One would think it would be worthwhile to cache these.
--- Sadly it's not. See #16937
-
-getCgIdInfo :: Id -> FCode CgIdInfo
-getCgIdInfo id
-  = do  { platform <- getPlatform
-        ; local_binds <- getBinds -- Try local bindings first
-        ; case lookupVarEnv local_binds id of {
-            Just info -> -- pprTrace "getCgIdInfoLocal" (ppr id) $
-              return info ;
-            Nothing   -> do {
-
-                -- Should be imported; make up a CgIdInfo for it
-          let name = idName id
-        ; if isExternalName name then
-              let ext_lbl
-                      | isBoxedType (idType id)
-                      = mkClosureLabel name $ idCafInfo id
-                      | isUnliftedType (idType id)
-                          -- An unlifted external Id must refer to a top-level
-                          -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel".
-                      = assert (idType id `eqType` addrPrimTy) $
-                        mkBytesLabel name
-                      | otherwise
-                      = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id))
-              in return $
-                  litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl)
-          else
-              cgLookupPanic id -- Bug
-        }}}
-
--- | Retrieve cg info for a name if it already exists.
-getCgInfo_maybe :: Name -> FCode (Maybe CgIdInfo)
-getCgInfo_maybe name
-  = do  { local_binds <- getBinds -- Try local bindings first
-        ; return $ lookupVarEnv_Directly local_binds (getUnique name) }
-
-cgLookupPanic :: Id -> FCode a
-cgLookupPanic id
-  = do  local_binds <- getBinds
-        pprPanic "GHC.StgToCmm.Env: variable not found"
-                (vcat [ppr id,
-                text "local binds for:",
-                pprUFM local_binds $ \infos ->
-                  vcat [ ppr (cg_id info) | info <- infos ]
-              ])
-
-
-------------------------------------------------------------------------
---        Interface functions for binding and re-binding names
-------------------------------------------------------------------------
-
-bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
--- Bind an Id to a fresh LocalReg
-bindToReg nvid@(NonVoid id) lf_info
-  = do platform <- getPlatform
-       let reg = idToReg platform nvid
-       addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
-       return reg
-
-rebindToReg :: NonVoid Id -> FCode LocalReg
--- Like bindToReg, but the Id is already in scope, so
--- get its LF info from the envt
-rebindToReg nvid@(NonVoid id)
-  = do  { info <- getCgIdInfo id
-        ; bindToReg nvid (cg_lf info) }
-
-bindArgToReg :: NonVoid Id -> FCode LocalReg
-bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
-
-bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
-bindArgsToRegs = mapM bindArgToReg
-
-idToReg :: Platform -> NonVoid Id -> LocalReg
--- Make a register from an Id, typically a function argument,
--- free variable, or case binder
---
--- We re-use the Unique from the Id to make it easier to see what is going on
---
--- By now the Ids should be uniquely named; else one would worry
--- about accidental collision
-idToReg platform (NonVoid id)
-             = LocalReg (idUnique id)
-                        (primRepCmmType platform (idPrimRep id))
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ /dev/null
@@ -1,1254 +0,0 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeFamilies #-}
-
------------------------------------------------------------------------------
---
--- Stg to C-- code generation: expressions
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.Expr ( cgExpr, cgLit ) where
-
-import GHC.Prelude hiding ((<*>))
-
-import {-# SOURCE #-} GHC.StgToCmm.Bind ( cgBind )
-
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Heap
-import GHC.StgToCmm.Env
-import GHC.StgToCmm.DataCon
-import GHC.StgToCmm.Prof (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC)
-import GHC.StgToCmm.Layout
-import GHC.StgToCmm.Lit
-import GHC.StgToCmm.Prim
-import GHC.StgToCmm.Hpc
-import GHC.StgToCmm.TagCheck
-import GHC.StgToCmm.Ticky
-import GHC.StgToCmm.Utils
-import GHC.StgToCmm.Closure
-
-import GHC.Stg.Syntax
-
-import GHC.Cmm.Graph
-import GHC.Cmm.BlockId
-import GHC.Cmm hiding ( succ )
-import GHC.Cmm.Info
-import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG )
-import GHC.Core
-import GHC.Core.DataCon
-import GHC.Types.ForeignCall
-import GHC.Types.Id
-import GHC.Builtin.PrimOps
-import GHC.Core.TyCon
-import GHC.Core.Type        ( isUnliftedType )
-import GHC.Types.RepType    ( isZeroBitTy, countConRepArgs, mightBeFunTy )
-import GHC.Types.CostCentre ( CostCentreStack, currentCCS )
-import GHC.Types.Tickish
-import GHC.Data.Maybe
-import GHC.Utils.Misc
-import GHC.Data.FastString
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-import Control.Monad ( unless, void )
-import Control.Arrow ( first )
-import Data.List     ( partition )
-import GHC.Stg.InferTags.TagSig (isTaggedSig)
-import GHC.Platform.Profile (profileIsProfiling)
-
-------------------------------------------------------------------------
---              cgExpr: the main function
-------------------------------------------------------------------------
-
-cgExpr  :: CgStgExpr -> FCode ReturnKind
-
-cgExpr (StgApp fun args)     = cgIdApp fun args
-
--- seq# a s ==> a
--- See Note [seq# magic] in GHC.Core.Opt.ConstantFold
-cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
-  cgIdApp a []
-
--- dataToTag# :: a -> Int#
--- See Note [dataToTag# magic] in GHC.Core.Opt.ConstantFold
--- TODO: There are some more optimization ideas for this code path
--- in #21710
-cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do
-  platform <- getPlatform
-  emitComment (mkFastString "dataToTag#")
-  info <- getCgIdInfo a
-  let amode = idInfoToAmode info
-  tag_reg <- assignTemp $ cmmConstrTag1 platform amode
-  result_reg <- newTemp (bWord platform)
-  let tag = CmmReg $ CmmLocal tag_reg
-      is_tagged = cmmNeWord platform tag (zeroExpr platform)
-      is_too_big_tag = cmmEqWord platform tag (cmmTagMask platform)
-  -- Here we will first check the tag bits of the pointer we were given;
-  -- if this doesn't work then enter the closure and use the info table
-  -- to determine the constructor. Note that all tag bits set means that
-  -- the constructor index is too large to fit in the pointer and therefore
-  -- we must look in the info table. See Note [Tagging big families].
-
-  (fast_path :: CmmAGraph) <- getCode $ do
-      -- Return the constructor index from the pointer tag
-      return_ptr_tag <- getCode $ do
-          emitAssign (CmmLocal result_reg)
-            $ cmmSubWord platform tag (CmmLit $ mkWordCLit platform 1)
-      -- Return the constructor index recorded in the info table
-      return_info_tag <- getCode $ do
-          profile     <- getProfile
-          align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
-          emitAssign (CmmLocal result_reg)
-            $ getConstrTag profile align_check (cmmUntag platform amode)
-
-      emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False)
-  -- If we know the argument is already tagged there is no need to generate code to evaluate it
-  -- so we skip straight to the fast path. If we don't know if there is a tag we take the slow
-  -- path which evaluates the argument before fetching the tag.
-  case (idTagSig_maybe a) of
-    Just sig
-      | isTaggedSig sig
-      -> emit fast_path
-    _ -> do
-          slow_path <- getCode $ do
-              tmp <- newTemp (bWord platform)
-              _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])
-              profile     <- getProfile
-              align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
-              emitAssign (CmmLocal result_reg)
-                $ getConstrTag profile align_check (cmmUntag platform (CmmReg (CmmLocal tmp)))
-          emit =<< mkCmmIfThenElse' is_tagged fast_path slow_path (Just True)
-  emitReturn [CmmReg $ CmmLocal result_reg]
-
-
-cgExpr (StgOpApp op args ty) = cgOpApp op args ty
-cgExpr (StgConApp con mn args _) = cgConApp con mn args
-cgExpr (StgTick t e)         = cgTick t >> cgExpr e
-cgExpr (StgLit lit)          = do cmm_expr <- cgLit lit
-                                  emitReturn [cmm_expr]
-
-cgExpr (StgLet _ binds expr) = do { cgBind binds;     cgExpr expr }
-cgExpr (StgLetNoEscape _ binds expr) =
-  do { u <- newUnique
-     ; let join_id = mkBlockId u
-     ; cgLneBinds join_id binds
-     ; r <- cgExpr expr
-     ; emitLabel join_id
-     ; return r }
-
-cgExpr (StgCase expr bndr alt_type alts) =
-  cgCase expr bndr alt_type alts
-
-------------------------------------------------------------------------
---              Let no escape
-------------------------------------------------------------------------
-
-{- Generating code for a let-no-escape binding, aka join point is very
-very similar to what we do for a case expression.  The duality is
-between
-        let-no-escape x = b
-        in e
-and
-        case e of ... -> b
-
-That is, the RHS of 'x' (ie 'b') will execute *later*, just like
-the alternative of the case; it needs to be compiled in an environment
-in which all volatile bindings are forgotten, and the free vars are
-bound only to stable things like stack locations..  The 'e' part will
-execute *next*, just like the scrutinee of a case. -}
-
--------------------------
-cgLneBinds :: BlockId -> CgStgBinding -> FCode ()
-cgLneBinds join_id (StgNonRec bndr rhs)
-  = do  { local_cc <- saveCurrentCostCentre
-                -- See Note [Saving the current cost centre]
-        ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs
-        ; fcode
-        ; addBindC info }
-
-cgLneBinds join_id (StgRec pairs)
-  = do  { local_cc <- saveCurrentCostCentre
-        ; r <- sequence $ unzipWith (cgLetNoEscapeRhs join_id local_cc) pairs
-        ; let (infos, fcodes) = unzip r
-        ; addBindsC infos
-        ; sequence_ fcodes
-        }
-
--------------------------
-cgLetNoEscapeRhs
-    :: BlockId          -- join point for successor of let-no-escape
-    -> Maybe LocalReg   -- Saved cost centre
-    -> Id
-    -> CgStgRhs
-    -> FCode (CgIdInfo, FCode ())
-
-cgLetNoEscapeRhs join_id local_cc bndr rhs =
-  do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs
-     ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
-     ; let code = do { (_, body) <- getCodeScoped rhs_code
-                     ; emitOutOfLine bid (first (<*> mkBranch join_id) body) }
-     ; return (info, code)
-     }
-
-cgLetNoEscapeRhsBody
-    :: Maybe LocalReg   -- Saved cost centre
-    -> Id
-    -> CgStgRhs
-    -> FCode (CgIdInfo, FCode ())
-cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body)
-  = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
-cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con mn _ts args)
-  = cgLetNoEscapeClosure bndr local_cc cc []
-      (StgConApp con mn args (pprPanic "cgLetNoEscapeRhsBody" $
-                           text "StgRhsCon doesn't have type args"))
-        -- For a constructor RHS we want to generate a single chunk of
-        -- code which can be jumped to from many places, which will
-        -- return the constructor. It's easy; just behave as if it
-        -- was an StgRhsClosure with a ConApp inside!
-
--------------------------
-cgLetNoEscapeClosure
-        :: Id                   -- binder
-        -> Maybe LocalReg       -- Slot for saved current cost centre
-        -> CostCentreStack      -- XXX: *** NOT USED *** why not?
-        -> [NonVoid Id]         -- Args (as in \ args -> body)
-        -> CgStgExpr            -- Body (as in above)
-        -> FCode (CgIdInfo, FCode ())
-
-cgLetNoEscapeClosure bndr cc_slot _unused_cc args body
-  = do platform <- getPlatform
-       return ( lneIdInfo platform bndr args, code )
-  where
-   code = forkLneBody $ withNewTickyCounterLNE bndr args $ do
-            { restoreCurrentCostCentre cc_slot
-            ; arg_regs <- bindArgsToRegs args
-            ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) }
-
-
-------------------------------------------------------------------------
---              Case expressions
-------------------------------------------------------------------------
-
-{- Note [Compiling case expressions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It is quite interesting to decide whether to put a heap-check at the
-start of each alternative.  Of course we certainly have to do so if
-the case forces an evaluation, or if there is a primitive op which can
-trigger GC.
-
-A more interesting situation is this (a Plan-B situation)
-
-        !P!;
-        ...P...
-        case x# of
-          0#      -> !Q!; ...Q...
-          default -> !R!; ...R...
-
-where !x! indicates a possible heap-check point. The heap checks
-in the alternatives *can* be omitted, in which case the topmost
-heapcheck will take their worst case into account.
-
-In favour of omitting !Q!, !R!:
-
- - *May* save a heap overflow test,
-   if ...P... allocates anything.
-
- - We can use relative addressing from a single Hp to
-   get at all the closures so allocated.
-
- - No need to save volatile vars etc across heap checks
-   in !Q!, !R!
-
-Against omitting !Q!, !R!
-
-  - May put a heap-check into the inner loop.  Suppose
-        the main loop is P -> R -> P -> R...
-        Q is the loop exit, and only it does allocation.
-    This only hurts us if P does no allocation.  If P allocates,
-    then there is a heap check in the inner loop anyway.
-
-  - May do more allocation than reqd.  This sometimes bites us
-    badly.  For example, nfib (ha!) allocates about 30\% more space if the
-    worst-casing is done, because many many calls to nfib are leaf calls
-    which don't need to allocate anything.
-
-    We can un-allocate, but that costs an instruction
-
-Neither problem hurts us if there is only one alternative.
-
-Suppose the inner loop is P->R->P->R etc.  Then here is
-how many heap checks we get in the *inner loop* under various
-conditions
-
-  Alloc   Heap check in branches (!Q!, !R!)?
-  P Q R      yes     no (absorb to !P!)
---------------------------------------
-  n n n      0          0
-  n y n      0          1
-  n . y      1          1
-  y . y      2          1
-  y . n      1          1
-
-Best choices: absorb heap checks from Q and R into !P! iff
-  a) P itself does some allocation
-or
-  b) P does allocation, or there is exactly one alternative
-
-We adopt (b) because that is more likely to put the heap check at the
-entry to a function, when not many things are live.  After a bunch of
-single-branch cases, we may have lots of things live
-
-Hence: Two basic plans for
-
-        case e of r { alts }
-
------- Plan A: the general case ---------
-
-        ...save current cost centre...
-
-        ...code for e,
-           with sequel (SetLocals r)
-
-        ...restore current cost centre...
-        ...code for alts...
-        ...alts do their own heap checks
-
-   When using GcInAlts the return point for heap checks and evaluating
-   the scrutinee is shared. This does mean we might execute the actual
-   branching code twice but it's rare enough to not matter.
-   The huge advantage of this pattern is that we do not require multiple
-   info tables for returning from gc as they can be shared between all
-   cases. Reducing code size nicely.
-
------- Plan B: special case when ---------
-  (i)  e does not allocate or call GC
-  (ii) either upstream code performs allocation
-       or there is just one alternative
-
-  Then heap allocation in the (single) case branch
-  is absorbed by the upstream check.
-  Very common example: primops on unboxed values
-
-        ...code for e,
-           with sequel (SetLocals r)...
-
-        ...code for alts...
-        ...no heap check...
-
-   There is a variant B.2 which we use if:
-
-  (i)   e is already evaluated+tagged
-  (ii)  We have multiple alternatives
-  (iii) and there is no upstream allocation.
-
-  Here we also place one heap check before the `case` which
-  branches on `e`. Hopefully to be absorbed by an already existing
-  heap check further up. However the big difference in this case is that
-  there is no code for e. So we are not guaranteed that the heap
-  checks of the alts will be combined with an heap check further up.
-
-  Very common example: Casing on strict fields.
-
-        ...heap check...
-        ...assign bindings...
-
-        ...code for alts...
-        ...no heap check...
-
-  -- Reasoning for Plan B.2:
-   Since the scrutinee is already evaluated there is no evaluation
-   call which would force a info table that we can use as a shared
-   return point.
-   This means currently if we were to do GcInAlts like in Plan A then
-   we would end up with one info table per alternative.
-
-   To avoid this we unconditionally do gc outside of the alts with all
-   the pros and cons described in Note [Compiling case expressions].
-   Rewriting the logic to generate a shared return point before the case
-   expression while keeping the heap checks in the alternatives would be
-   possible. But it's unclear to me that this would actually be an improvement.
-
-   This means if we have code along these lines:
-
-      g x y = case x of
-         True -> Left $ (y + 1,y,y-1)
-         False -> Right $! y - (2 :: Int)
-
-   We get these potential heap check placements:
-
-   f = ...
-      !max(L,R)!; -- Might be absorbed upstream.
-      case x of
-         True  -> !L!; ...L...
-         False -> !R!; ...R...
-
-   And we place a heap check at !max(L,R)!
-
-   The downsides of using !max(L,R)! are:
-
-   * If f is recursive, and the hot loop wouldn't allocate, but the exit branch does then we do
-   a redundant heap check.
-   * We use one more instruction to de-allocate the unused heap in the branch using less heap. (Negligible)
-   * A small risk of running gc slightly more often than needed especially if one branch allocates a lot.
-
-   The upsides are:
-   * May save a heap overflow test if there is an upstream check already.
-   * If the heap check is absorbed upstream we can also eliminate its info table.
-   * We generate at most one heap check (versus one per alt otherwise).
-   * No need to save volatile vars etc across heap checks in !L!, !R!
-   * We can use relative addressing from a single Hp to get at all the closures so allocated. (seems neglible)
-   * It fits neatly in the logic we already have for handling A/B
-
-   For containers:Data/Sequence/Internal/Sorting.o the difference is
-   about 10% in terms of code size compared to using Plan A for this case.
-   The main downside is we might put heap checks into loops, even if we
-   could avoid it (See Note [Compiling case expressions]).
-
-   Potential improvement: Investigate if heap checks in alts would be an
-   improvement if we generate and use a shared return point that is placed
-   in the common path for all alts.
-
--}
-
-
-
--------------------------------------
-data GcPlan
-  = GcInAlts            -- Put a GC check at the start the case alternatives,
-        [LocalReg]      -- which binds these registers
-  | NoGcInAlts          -- The scrutinee is a primitive value, or a call to a
-                        -- primitive op which does no GC.  Absorb the allocation
-                        -- of the case alternative(s) into the upstream check
-
--------------------------------------
-cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind
-
-{-
-Note [Scrutinising VoidRep]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have this STG code:
-   f = \[s : State# RealWorld] ->
-       case s of _ -> blah
-This is very odd.  Why are we scrutinising a state token?  But it
-can arise with bizarre NOINLINE pragmas (#9964)
-    crash :: IO ()
-    crash = IO (\s -> let {-# NOINLINE s' #-}
-                          s' = s
-                      in (# s', () #))
-
-Now the trouble is that 's' has VoidRep, and we do not bind void
-arguments in the environment; they don't live anywhere.  See the
-calls to nonVoidIds in various places.  So we must not look up
-'s' in the environment.  Instead, just evaluate the RHS!  Simple.
-
-Note [Dead-binder optimisation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A case-binder, or data-constructor argument, may be marked as dead,
-because we preserve occurrence-info on binders in GHC.Core.Tidy (see
-GHC.Core.Tidy.tidyIdBndr).
-
-If the binder is dead, we can sometimes eliminate a load.  While
-CmmSink will eliminate that load, it's very easy to kill it at source
-(giving CmmSink less work to do), and in any case CmmSink only runs
-with -O. Since the majority of case binders are dead, this
-optimisation probably still has a great benefit-cost ratio and we want
-to keep it for -O0. See also Phab:D5358.
-
-This probably also was the reason for occurrence hack in Phab:D5339 to
-exist, perhaps because the occurrence information preserved by
-'GHC.Core.Tidy.tidyIdBndr' was insufficient.  But now that CmmSink does the
-job we deleted the hacks.
--}
-
-cgCase (StgApp v []) _ (PrimAlt _) alts
-  | isVoidRep (idPrimRep v)  -- See Note [Scrutinising VoidRep]
-  , [GenStgAlt{alt_con=DEFAULT, alt_bndrs=_, alt_rhs=rhs}] <- alts
-  = cgExpr rhs
-
-{- Note [Dodgy unsafeCoerce 1]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-    case (x :: HValue) |> co of (y :: MutVar# Int)
-        DEFAULT -> ...
-We want to generate an assignment
-     y := x
-We want to allow this assignment to be generated in the case when the
-types are compatible, because this allows some slightly-dodgy but
-occasionally-useful casts to be used, such as in GHC.Runtime.Heap.Inspect
-where we cast an HValue to a MutVar# so we can print out the contents
-of the MutVar#.  If instead we generate code that enters the HValue,
-then we'll get a runtime panic, because the HValue really is a
-MutVar#.  The types are compatible though, so we can just generate an
-assignment.
--}
-cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
-  | isUnliftedType (idType v)  -- Note [Dodgy unsafeCoerce 1]
-  = -- assignment suffices for unlifted types
-    do { platform <- getPlatform
-       ; unless (reps_compatible platform) $
-           pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
-                    (pp_bndr v $$ pp_bndr bndr)
-       ; v_info <- getCgIdInfo v
-       ; emitAssign (CmmLocal (idToReg platform (NonVoid bndr)))
-                    (idInfoToAmode v_info)
-       -- Add bndr to the environment
-       ; _ <- bindArgToReg (NonVoid bndr)
-       ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }
-  where
-    reps_compatible platform = primRepCompatible platform (idPrimRep v) (idPrimRep bndr)
-
-    pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id))
-
-{- Note [Dodgy unsafeCoerce 2, #3132]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In all other cases of a lifted Id being cast to an unlifted type, the
-Id should be bound to bottom, otherwise this is an unsafe use of
-unsafeCoerce.  We can generate code to enter the Id and assume that
-it will never return.  Hence, we emit the usual enter/return code, and
-because bottom must be untagged, it will be entered.  The Sequel is a
-type-correct assignment, albeit bogus.  The (dead) continuation loops;
-it would be better to invoke some kind of panic function here.
--}
-cgCase scrut@(StgApp v []) _ (PrimAlt _) _
-  = do { platform <- getPlatform
-       ; mb_cc <- maybeSaveCostCentre True
-       ; _ <- withSequel
-                  (AssignTo [idToReg platform (NonVoid v)] False) (cgExpr scrut)
-       ; restoreCurrentCostCentre mb_cc
-       ; emitComment $ mkFastString "should be unreachable code"
-       ; l <- newBlockId
-       ; emitLabel l
-       ; emit (mkBranch l)  -- an infinite loop
-       ; return AssignedDirectly
-       }
-
-{- Note [Handle seq#]
-~~~~~~~~~~~~~~~~~~~~~
-See Note [seq# magic] in GHC.Core.Opt.ConstantFold.
-The special case for seq# in cgCase does this:
-
-  case seq# a s of v
-    (# s', a' #) -> e
-==>
-  case a of v
-    (# s', a' #) -> e
-
-(taking advantage of the fact that the return convention for (# State#, a #)
-is the same as the return convention for just 'a')
--}
-
-cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts
-  = -- Note [Handle seq#]
-    -- And see Note [seq# magic] in GHC.Core.Opt.ConstantFold
-    -- Use the same return convention as vanilla 'a'.
-    cgCase (StgApp a []) bndr alt_type alts
-
-cgCase scrut bndr alt_type alts
-  = -- the general case
-    do { platform <- getPlatform
-       ; up_hp_usg <- getVirtHp        -- Upstream heap usage
-       ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts
-             alt_regs  = map (idToReg platform) ret_bndrs
-
-       ; simple_scrut <- isSimpleScrut scrut alt_type
-       ; let do_gc  | is_cmp_op scrut  = False  -- See Note [GC for conditionals]
-                    | not simple_scrut = True
-                    | isSingleton alts = False
-                    | up_hp_usg > 0    = False
-                    | otherwise        = True
-               -- cf Note [Compiling case expressions]
-             gc_plan = if do_gc then GcInAlts alt_regs else NoGcInAlts
-
-       ; mb_cc <- maybeSaveCostCentre simple_scrut
-
-       ; let sequel = AssignTo alt_regs do_gc{- Note [scrut sequel] -}
-       ; ret_kind <- withSequel sequel (cgExpr scrut)
-       ; restoreCurrentCostCentre mb_cc
-       ; _ <- bindArgsToRegs ret_bndrs
-       ; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts
-       }
-  where
-    is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op
-    is_cmp_op _                             = False
-
-
-{- Note [GC for conditionals]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For boolean conditionals it seems that we have always done NoGcInAlts.
-That is, we have always done the GC check before the conditional.
-This is enshrined in the special case for
-   case tagToEnum# (a>b) of ...
-See Note [case on bool]
-
-It's odd, and it's flagrantly inconsistent with the rules described
-Note [Compiling case expressions].  However, after eliminating the
-tagToEnum# (#13397) we will have:
-   case (a>b) of ...
-Rather than make it behave quite differently, I am testing for a
-comparison operator here in the general case as well.
-
-ToDo: figure out what the Right Rule should be.
-
-Note [scrut sequel]
-~~~~~~~~~~~~~~~~~~~
-The job of the scrutinee is to assign its value(s) to alt_regs.
-Additionally, if we plan to do a heap-check in the alternatives (see
-Note [Compiling case expressions]), then we *must* retreat Hp to
-recover any unused heap before passing control to the sequel.  If we
-don't do this, then any unused heap will become slop because the heap
-check will reset the heap usage. Slop in the heap breaks LDV profiling
-(+RTS -hb) which needs to do a linear sweep through the nursery.
-
-
-Note [Inlining out-of-line primops and heap checks]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If shouldInlinePrimOp returns True when called from GHC.StgToCmm.Expr for the
-purpose of heap check placement, we *must* inline the primop later in
-GHC.StgToCmm.Prim. If we don't things will go wrong.
--}
-
------------------
-maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)
-maybeSaveCostCentre simple_scrut
-  | simple_scrut = return Nothing
-  | otherwise    = saveCurrentCostCentre
-
-
------------------
-isSimpleScrut :: CgStgExpr -> AltType -> FCode Bool
--- Simple scrutinee, does not block or allocate; hence safe to amalgamate
--- heap usage from alternatives into the stuff before the case
--- NB: if you get this wrong, and claim that the expression doesn't allocate
---     when it does, you'll deeply mess up allocation
-isSimpleScrut (StgOpApp op args _) _         = isSimpleOp op args
-isSimpleScrut (StgLit _)           _         = return True       -- case 1# of { 0# -> ..; ... }
-isSimpleScrut (StgApp _ [])    (PrimAlt _)   = return True       -- case x# of { 0# -> ..; ... }
-isSimpleScrut (StgApp f [])   _
-  | Just sig <- idTagSig_maybe f
-  , isTaggedSig sig  -- case !x of { ... }
-  = if mightBeFunTy (idType f)
-      -- See Note [Evaluating functions with profiling] in rts/Apply.cmm
-      then not . profileIsProfiling <$> getProfile
-      else pure True
-isSimpleScrut _                    _         = return False
-
-isSimpleOp :: StgOp -> [StgArg] -> FCode Bool
--- True iff the op cannot block or allocate
-isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)
--- dataToTag# evaluates its argument, see Note [dataToTag# magic] in GHC.Core.Opt.ConstantFold
-isSimpleOp (StgPrimOp DataToTagOp) _ = return False
-isSimpleOp (StgPrimOp op) stg_args                  = do
-    arg_exprs <- getNonVoidArgAmodes stg_args
-    cfg       <- getStgToCmmConfig
-    -- See Note [Inlining out-of-line primops and heap checks]
-    return $! shouldInlinePrimOp cfg op arg_exprs
-isSimpleOp (StgPrimCallOp _) _                           = return False
-
------------------
-chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id]
--- These are the binders of a case that are assigned by the evaluation of the
--- scrutinee.
--- They're non-void, see Note [Post-unarisation invariants] in GHC.Stg.Unarise.
-chooseReturnBndrs bndr (PrimAlt _) _alts
-  = assertNonVoidIds [bndr]
-
-chooseReturnBndrs _bndr (MultiValAlt n) [alt]
-  = assertPpr (ids `lengthIs` n) (ppr n $$ ppr ids $$ ppr _bndr) $
-    assertNonVoidIds ids     -- 'bndr' is not assigned!
-    where ids = alt_bndrs alt
-
-chooseReturnBndrs bndr (AlgAlt _) _alts
-  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned
-
-chooseReturnBndrs bndr PolyAlt _alts
-  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned
-
-chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"
-                             -- MultiValAlt has only one alternative
-
--------------------------------------
-cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]
-       -> FCode ReturnKind
--- At this point the result of the case are in the binders
-cgAlts gc_plan _bndr PolyAlt [alt]
-  = maybeAltHeapCheck gc_plan (cgExpr $ alt_rhs alt)
-
-cgAlts gc_plan _bndr (MultiValAlt _) [alt]
-  = maybeAltHeapCheck gc_plan (cgExpr $ alt_rhs alt)
-        -- Here bndrs are *already* in scope, so don't rebind them
-
-cgAlts gc_plan bndr (PrimAlt _) alts
-  = do  { platform <- getPlatform
-
-        ; tagged_cmms <- cgAltRhss gc_plan bndr alts
-
-        ; let bndr_reg = CmmLocal (idToReg platform bndr)
-              (DEFAULT,deflt) = head tagged_cmms
-                -- PrimAlts always have a DEFAULT case
-                -- and it always comes first
-
-              tagged_cmms' = [(lit,code)
-                             | (LitAlt lit, code) <- tagged_cmms]
-        ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt
-        ; return AssignedDirectly }
-
-cgAlts gc_plan bndr (AlgAlt tycon) alts
-  = do  { platform <- getPlatform
-
-        ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts
-
-        ; let !fam_sz   = tyConFamilySize tycon
-              !bndr_reg = CmmLocal (idToReg platform bndr)
-              !ptag_expr = cmmConstrTag1 platform (CmmReg bndr_reg)
-              !branches' = first succ <$> branches
-              !maxpt = mAX_PTR_TAG platform
-              (!via_ptr, !via_info) = partition ((< maxpt) . fst) branches'
-              !small = isSmallFamily platform fam_sz
-
-                -- Is the constructor tag in the node reg?
-                -- See Note [Tagging big families]
-        ; if small || null via_info
-           then -- Yes, bndr_reg has constructor tag in ls bits
-               emitSwitch ptag_expr branches' mb_deflt 1
-                 (if small then fam_sz else maxpt)
-
-           else -- No, the get exact tag from info table when mAX_PTR_TAG
-                -- See Note [Double switching for big families]
-              do
-                profile     <- getProfile
-                align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
-                let !untagged_ptr = cmmUntag platform (CmmReg bndr_reg)
-                    !itag_expr = getConstrTag profile align_check untagged_ptr
-                    !info0 = first pred <$> via_info
-                if null via_ptr then
-                  emitSwitch itag_expr info0 mb_deflt 0 (fam_sz - 1)
-                else do
-                  infos_lbl <- newBlockId
-                  infos_scp <- getTickScope
-
-                  let spillover = (maxpt, (mkBranch infos_lbl, infos_scp))
-
-                  (mb_shared_deflt, mb_shared_branch) <- case mb_deflt of
-                      (Just (stmts, scp)) ->
-                          do lbl <- newBlockId
-                             return ( Just (mkLabel lbl scp <*> stmts, scp)
-                                    , Just (mkBranch lbl, scp))
-                      _ -> return (Nothing, Nothing)
-                  -- Switch on pointer tag
-                  emitSwitch ptag_expr (spillover : via_ptr) mb_shared_deflt 1 maxpt
-                  join_lbl <- newBlockId
-                  emit (mkBranch join_lbl)
-                  -- Switch on info table tag
-                  emitLabel infos_lbl
-                  emitSwitch itag_expr info0 mb_shared_branch
-                    (maxpt - 1) (fam_sz - 1)
-                  emitLabel join_lbl
-
-        ; return AssignedDirectly }
-
-cgAlts _ _ _ _ = panic "cgAlts"
-        -- UbxTupAlt and PolyAlt have only one alternative
-
--- Note [Double switching for big families]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- An algebraic data type can have a n >= 0 summands
--- (or alternatives), which are identified (labeled) by
--- constructors. In memory they are kept apart by tags
--- (see Note [Data constructor dynamic tags] in GHC.StgToCmm.Closure).
--- Due to the characteristics of the platform that
--- contribute to the alignment of memory objects, there
--- is a natural limit of information about constructors
--- that can be encoded in the pointer tag. When the mapping
--- of constructors to the pointer tag range 1..mAX_PTR_TAG
--- is not injective, then we have a "big data type", also
--- called a "big (constructor) family" in the literature.
--- Constructor tags residing in the info table are injective,
--- but considerably more expensive to obtain, due to additional
--- memory access(es).
---
--- When doing case analysis on a value of a "big data type"
--- we need two nested switch statements to make up for the lack
--- of injectivity of pointer tagging, also taking the info
--- table tag into account. The exact mechanism is described next.
---
--- In the general case, switching on big family alternatives
--- is done by two nested switch statements. According to
--- Note [Tagging big families], the outer switch
--- looks at the pointer tag and the inner dereferences the
--- pointer and switches on the info table tag.
---
--- We can handle a simple case first, namely when none
--- of the case alternatives mention a constructor having
--- a pointer tag of 1..mAX_PTR_TAG-1. In this case we
--- simply emit a switch on the info table tag.
--- Note that the other simple case is when all mentioned
--- alternatives lie in 1..mAX_PTR_TAG-1, in which case we can
--- switch on the ptr tag only, just like in the small family case.
---
--- There is a single intricacy with a nested switch:
--- Both should branch to the same default alternative, and as such
--- avoid duplicate codegen of potentially heavy code. The outer
--- switch generates the actual code with a prepended fresh label,
--- while the inner one only generates a jump to that label.
---
--- For example, let's assume a 64-bit architecture, so that all
--- heap objects are 8-byte aligned, and hence the address of a
--- heap object ends in `000` (three zero bits).
---
--- Then consider the following data type
---
---   > data Big = T0 | T1 | T2 | T3 | T4 | T5 | T6 | T7 | T8
---   Ptr tag:      1    2    3    4    5    6    7    7    7
---   As bits:    001  010  011  100  101  110  111  111  111
---   Info pointer tag (zero based):
---                 0    1    2    3    4    5    6    7    8
---
--- Then     \case T2 -> True; T8 -> True; _ -> False
--- will result in following code (slightly cleaned-up and
--- commented -ddump-cmm-from-stg):
-{-
-           R1 = _sqI::P64;  -- scrutinee
-           if (R1 & 7 != 0) goto cqO; else goto cqP;
-       cqP: // global       -- enter
-           call (I64[R1])(R1) returns to cqO, args: 8, res: 8, upd: 8;
-       cqO: // global       -- already WHNF
-           _sqJ::P64 = R1;
-           _cqX::P64 = _sqJ::P64 & 7;  -- extract pointer tag
-           switch [1 .. 7] _cqX::P64 {
-               case 3 : goto cqW;
-               case 7 : goto cqR;
-               default: {goto cqS;}
-           }
-       cqR: // global
-           _cr2 = I32[I64[_sqJ::P64 & (-8)] - 4]; -- tag from info pointer
-           switch [6 .. 8] _cr2::I64 {
-               case 8 : goto cr1;
-               default: {goto cr0;}
-           }
-       cr1: // global
-           R1 = GHC.Types.True_closure+2;
-           call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
-       cr0: // global     -- technically necessary label
-           goto cqS;
-       cqW: // global
-           R1 = GHC.Types.True_closure+2;
-           call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
-       cqS: // global
-           R1 = GHC.Types.False_closure+1;
-           call (P64[(old + 8)])(R1) args: 8, res: 0, upd: 8;
--}
---
--- For 32-bit systems we only have 2 tag bits in the pointers at our disposal,
--- so the performance win is dubious, especially in face of the increased code
--- size due to double switching. But we can take the viewpoint that 32-bit
--- architectures are not relevant for performance any more, so this can be
--- considered as moot.
-
-
--- Note [alg-alt heap check]
---
--- In an algebraic case with more than one alternative, we will have
--- code like
---
--- L0:
---   x = R1
---   goto L1
--- L1:
---   if (x & 7 >= 2) then goto L2 else goto L3
--- L2:
---   Hp = Hp + 16
---   if (Hp > HpLim) then goto L4
---   ...
--- L4:
---   call gc() returns to L5
--- L5:
---   x = R1
---   goto L1
-
-
--- Note [Tagging big families]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- Both the big and the small constructor families are tagged,
--- that is, greater unions which overflow the tag space of TAG_BITS
--- (i.e. 3 on 32 resp. 7 constructors on 64 bit archs).
---
--- For example, let's assume a 64-bit architecture, so that all
--- heap objects are 8-byte aligned, and hence the address of a
--- heap object ends in `000` (three zero bits).  Then consider
--- > data Maybe a = Nothing | Just a
--- > data Day a = Mon | Tue | Wed | Thu | Fri | Sat | Sun
--- > data Grade = G1 | G2 | G3 | G4 | G5 | G6 | G7 | G8 | G9 | G10
---
--- Since `Grade` has more than 7 constructors, it counts as a
--- "big data type" (also referred to as "big constructor family" in papers).
--- On the other hand, `Maybe` and `Day` have 7 constructors or fewer, so they
--- are "small data types".
---
--- Then
---   * A pointer to an unevaluated thunk of type `Maybe Int`, `Day` or `Grade` will end in `000`
---   * A tagged pointer to a `Nothing`, `Mon` or `G1` will end in `001`
---   * A tagged pointer to a `Just x`, `Tue` or `G2`  will end in `010`
---   * A tagged pointer to `Wed` or `G3` will end in `011`
---       ...
---   * A tagged pointer to `Sat` or `G6` will end in `110`
---   * A tagged pointer to `Sun` or `G7` or `G8` or `G9` or `G10` will end in `111`
---
--- For big families we employ a mildly clever way of combining pointer and
--- info-table tagging. We use 1..MAX_PTR_TAG-1 as pointer-resident tags where
--- the tags in the pointer and the info table are in a one-to-one
--- relation, whereas tag MAX_PTR_TAG is used as "spill over", signifying
--- we have to fall back and get the precise constructor tag from the
--- info-table.
---
--- Consequently we now cascade switches, because we have to check
--- the pointer tag first, and when it is MAX_PTR_TAG, fetch the precise
--- tag from the info table, and switch on that. The only technically
--- tricky part is that the default case needs (logical) duplication.
--- To do this we emit an extra label for it and branch to that from
--- the second switch. This avoids duplicated codegen. See #14373.
--- See Note [Double switching for big families] for the mechanics
--- involved.
---
--- Also see Note [Data constructor dynamic tags]
--- and the wiki https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/haskell-execution/pointer-tagging
---
-
--------------------
-cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
-             -> FCode ( Maybe CmmAGraphScoped
-                      , [(ConTagZ, CmmAGraphScoped)] )
-cgAlgAltRhss gc_plan bndr alts
-  = do { tagged_cmms <- cgAltRhss gc_plan bndr alts
-
-       ; let { mb_deflt = case tagged_cmms of
-                           ((DEFAULT,rhs) : _) -> Just rhs
-                           _other              -> Nothing
-                            -- DEFAULT is always first, if present
-
-              ; branches = [ (dataConTagZ con, cmm)
-                           | (DataAlt con, cmm) <- tagged_cmms ]
-              }
-
-       ; return (mb_deflt, branches)
-       }
-
-
--------------------
-cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
-          -> FCode [(AltCon, CmmAGraphScoped)]
-cgAltRhss gc_plan bndr alts = do
-  platform <- getPlatform
-  let
-    base_reg = idToReg platform bndr
-    cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)
-    cg_alt GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=rhs}
-      = getCodeScoped             $
-        maybeAltHeapCheck gc_plan $
-        do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs)
-                    -- alt binders are always non-void,
-                    -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
-           ; _ <- cgExpr rhs
-           ; return con }
-  forkAlts (map cg_alt alts)
-
-maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a
-maybeAltHeapCheck (NoGcInAlts,_)  code = code
-maybeAltHeapCheck (GcInAlts regs, AssignedDirectly) code =
-  altHeapCheck regs code
-maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code =
-  altHeapCheckReturnsTo regs lret off code
-
------------------------------------------------------------------------------
---      Tail calls
------------------------------------------------------------------------------
-
-cgConApp :: DataCon -> ConstructorNumber -> [StgArg] -> FCode ReturnKind
-cgConApp con mn stg_args
-  | isUnboxedTupleDataCon con       -- Unboxed tuple: assign and return
-  = do { arg_exprs <- getNonVoidArgAmodes stg_args
-       ; tickyUnboxedTupleReturn (length arg_exprs)
-       ; emitReturn arg_exprs }
-
-  | otherwise   --  Boxed constructors; allocate and return
-  = assertPpr (stg_args `lengthIs` countConRepArgs con)
-              (ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args) $
-    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) mn False
-                                     currentCCS con (assertNonVoidStgArgs stg_args)
-                                     -- con args are always non-void,
-                                     -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
-                -- The first "con" says that the name bound to this
-                -- closure is "con", which is a bit of a fudge, but
-                -- it only affects profiling (hence the False)
-
-        ; emit =<< fcode_init
-        ; tickyReturnNewCon (length stg_args)
-        ; emitReturn [idInfoToAmode idinfo] }
-
-cgIdApp :: Id -> [StgArg] -> FCode ReturnKind
-cgIdApp fun_id args = do
-    platform       <- getPlatform
-    fun_info       <- getCgIdInfo fun_id
-    cfg            <- getStgToCmmConfig
-    self_loop      <- getSelfLoop
-    let profile        = stgToCmmProfile  cfg
-        fun_arg        = StgVarArg fun_id
-        fun_name       = idName    fun_id
-        fun            = idInfoToAmode fun_info
-        lf_info        = cg_lf         fun_info
-        n_args         = length args
-        v_args         = length $ filter (isZeroBitTy . stgArgType) args
-    case getCallMethod cfg fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop of
-            -- A value in WHNF, so we can just return it.
-        ReturnIt
-          | isZeroBitTy (idType fun_id) -> emitReturn []
-          | otherwise                -> emitReturn [fun]
-
-        -- A value infered to be in WHNF, so we can just return it.
-        InferedReturnIt
-          | isZeroBitTy (idType fun_id) -> trace >> emitReturn []
-          | otherwise                   -> trace >> assertTag >>
-                                                    emitReturn [fun]
-            where
-              trace = do
-                tickyTagged
-                use_id <- newUnique
-                _lbl <- emitTickyCounterTag use_id (NonVoid fun_id)
-                tickyTagSkip use_id fun_id
-
-                -- pprTraceM "WHNF:" (ppr fun_id <+> ppr args )
-              assertTag = whenCheckTags $ do
-                  mod <- getModuleName
-                  emitTagAssertion (showPprUnsafe
-                      (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pdoc platform fun))
-                      fun
-
-        EnterIt -> assert (null args) $  -- Discarding arguments
-                   emitEnter fun
-
-        SlowCall -> do      -- A slow function call via the RTS apply routines
-                { tickySlowCall lf_info args
-                ; emitComment $ mkFastString "slowCall"
-                ; slowCall fun args }
-
-        -- A direct function call (possibly with some left-over arguments)
-        DirectEntry lbl arity -> do
-                { tickyDirectCall arity args
-                ; if nodeMustPointToIt profile lf_info
-                     then directCall NativeNodeCall   lbl arity (fun_arg:args)
-                     else directCall NativeDirectCall lbl arity args }
-
-        -- Let-no-escape call or self-recursive tail-call
-        JumpToIt blk_id lne_regs -> do
-          { adjustHpBackwards -- always do this before a tail-call
-          ; cmm_args <- getNonVoidArgAmodes args
-          ; emitMultiAssign lne_regs cmm_args
-          ; emit (mkBranch blk_id)
-          ; return AssignedDirectly }
-
--- Note [Self-recursive tail calls]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- Self-recursive tail calls can be optimized into a local jump in the same
--- way as let-no-escape bindings (see Note [What is a non-escaping let] in
--- "GHC.CoreToStg"). Consider this:
---
--- foo.info:
---     a = R1  // calling convention
---     b = R2
---     goto L1
--- L1: ...
---     ...
--- ...
--- L2: R1 = x
---     R2 = y
---     call foo(R1,R2)
---
--- Instead of putting x and y into registers (or other locations required by the
--- calling convention) and performing a call we can put them into local
--- variables a and b and perform jump to L1:
---
--- foo.info:
---     a = R1
---     b = R2
---     goto L1
--- L1: ...
---     ...
--- ...
--- L2: a = x
---     b = y
---     goto L1
---
--- This can be done only when function is calling itself in a tail position
--- and only if the call passes number of parameters equal to function's arity.
--- Note that this cannot be performed if a function calls itself with a
--- continuation.
---
--- This in fact implements optimization known as "loopification". It was
--- described in "Low-level code optimizations in the Glasgow Haskell Compiler"
--- by Krzysztof Woś, though we use different approach. Krzysztof performed his
--- optimization at the Cmm level, whereas we perform ours during code generation
--- (Stg-to-Cmm pass) essentially making sure that optimized Cmm code is
--- generated in the first place.
---
--- Implementation is spread across a couple of places in the code:
---
---   * FCode monad stores additional information in its reader environment
---     (stgToCmmSelfLoop field). This information tells us which function can
---     tail call itself in an optimized way (it is the function currently
---     being compiled), what is the label of a loop header (L1 in example above)
---     and information about local registers in which we should arguments
---     before making a call (this would be a and b in example above).
---
---   * Whenever we are compiling a function, we set that information to reflect
---     the fact that function currently being compiled can be jumped to, instead
---     of called. This is done in closureCodyBody in GHC.StgToCmm.Bind.
---
---   * We also have to emit a label to which we will be jumping. We make sure
---     that the label is placed after a stack check but before the heap
---     check. The reason is that making a recursive tail-call does not increase
---     the stack so we only need to check once. But it may grow the heap, so we
---     have to repeat the heap check in every self-call. This is done in
---     do_checks in GHC.StgToCmm.Heap.
---
---   * When we begin compilation of another closure we remove the additional
---     information from the environment. This is done by forkClosureBody
---     in GHC.StgToCmm.Monad. Other functions that duplicate the environment -
---     forkLneBody, forkAlts, codeOnly - duplicate that information. In other
---     words, we only need to clean the environment of the self-loop information
---     when compiling right hand side of a closure (binding).
---
---   * When compiling a call (cgIdApp) we use getCallMethod to decide what kind
---     of call will be generated. getCallMethod decides to generate a self
---     recursive tail call when (a) environment stores information about
---     possible self tail-call; (b) that tail call is to a function currently
---     being compiled; (c) number of passed non-void arguments is equal to
---     function's arity. (d) loopification is turned on via -floopification
---     command-line option.
---
---   * Command line option to turn loopification on and off is implemented in
---     DynFlags, then passed to StgToCmmConfig for this phase.
---
---
--- Note [Void arguments in self-recursive tail calls]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- State# tokens can get in the way of the loopification optimization as seen in
--- #11372. Consider this:
---
--- foo :: [a]
---     -> (a -> State# s -> (# State s, Bool #))
---     -> State# s
---     -> (# State# s, Maybe a #)
--- foo [] f s = (# s, Nothing #)
--- foo (x:xs) f s = case f x s of
---      (# s', b #) -> case b of
---          True -> (# s', Just x #)
---          False -> foo xs f s'
---
--- We would like to compile the call to foo as a local jump instead of a call
--- (see Note [Self-recursive tail calls]). However, the generated function has
--- an arity of 2 while we apply it to 3 arguments, one of them being of void
--- type. Thus, we mustn't count arguments of void type when checking whether
--- we can turn a call into a self-recursive jump.
---
-
-emitEnter :: CmmExpr -> FCode ReturnKind
-emitEnter fun = do
-  { platform <- getPlatform
-  ; profile  <- getProfile
-  ; adjustHpBackwards
-  ; sequel      <- getSequel
-  ; updfr_off   <- getUpdFrameOff
-  ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
-  ; case sequel of
-      -- For a return, we have the option of generating a tag-test or
-      -- not.  If the value is tagged, we can return directly, which
-      -- is quicker than entering the value.  This is a code
-      -- size/speed trade-off: when optimising for speed rather than
-      -- size we could generate the tag test.
-      --
-      -- Right now, we do what the old codegen did, and omit the tag
-      -- test, just generating an enter.
-      Return -> do
-        { let entry = entryCode platform
-                $ closureInfoPtr platform align_check
-                $ CmmReg nodeReg
-        ; emit $ mkJump profile NativeNodeCall entry
-                        [cmmUntag platform fun] updfr_off
-        ; return AssignedDirectly
-        }
-
-      -- The result will be scrutinised in the sequel.  This is where
-      -- we generate a tag-test to avoid entering the closure if
-      -- possible.
-      --
-      -- The generated code will be something like this:
-      --
-      --    R1 = fun  -- copyout
-      --    if (fun & 7 != 0) goto Lret else goto Lcall
-      --  Lcall:
-      --    call [fun] returns to Lret
-      --  Lret:
-      --    fun' = R1  -- copyin
-      --    ...
-      --
-      -- Note in particular that the label Lret is used as a
-      -- destination by both the tag-test and the call.  This is
-      -- because Lret will necessarily be a proc-point, and we want to
-      -- ensure that we generate only one proc-point for this
-      -- sequence.
-      --
-      -- Furthermore, we tell the caller that we generated a native
-      -- return continuation by returning (ReturnedTo Lret off), so
-      -- that the continuation can be reused by the heap-check failure
-      -- code in the enclosing case expression.
-      --
-      AssignTo res_regs _ -> do
-       { lret  <- newBlockId
-       ; lcall <- newBlockId
-       ; updfr_off   <- getUpdFrameOff
-       ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
-       ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs []
-       ; let area = Young lret
-       ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area
-                                          [fun] updfr_off []
-         -- refer to fun via nodeReg after the copyout, to avoid having
-         -- both live simultaneously; this sometimes enables fun to be
-         -- inlined in the RHS of the R1 assignment.
-       ; let entry = entryCode platform (closureInfoPtr platform align_check (CmmReg nodeReg))
-             the_call = toCall entry (Just lret) updfr_off off outArgs regs
-       ; tscope <- getTickScope
-       ; emit $
-           copyout <*>
-           mkCbranch (cmmIsTagged platform (CmmReg nodeReg))
-                     lret lcall Nothing <*>
-           outOfLine lcall (the_call,tscope) <*>
-           mkLabel lret tscope <*>
-           copyin
-       ; return (ReturnedTo lret off)
-       }
-  }
-
-------------------------------------------------------------------------
---              Ticks
-------------------------------------------------------------------------
-
--- | Generate Cmm code for a tick. Depending on the type of Tickish,
--- this will either generate actual Cmm instrumentation code, or
--- simply pass on the annotation as a @CmmTickish@.
-cgTick :: StgTickish -> FCode ()
-cgTick tick
-  = do { platform <- getPlatform
-       ; case tick of
-           ProfNote   cc t p -> emitSetCCC cc t p
-           HpcTick    m n    -> emit (mkTickBox platform m n)
-           SourceNote s n    -> emitTick $ SourceNote s n
-           _other            -> return () -- ignore
-       }
diff --git a/compiler/GHC/StgToCmm/ExtCode.hs b/compiler/GHC/StgToCmm/ExtCode.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/ExtCode.hs
+++ /dev/null
@@ -1,260 +0,0 @@
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE TupleSections #-}
--- | Our extended FCode monad.
-
--- We add a mapping from names to CmmExpr, to support local variable names in
--- the concrete C-- code.  The unique supply of the underlying FCode monad
--- is used to grab a new unique for each local variable.
-
--- In C--, a local variable can be declared anywhere within a proc,
--- and it scopes from the beginning of the proc to the end.  Hence, we have
--- to collect declarations as we parse the proc, and feed the environment
--- back in circularly (to avoid a two-pass algorithm).
-
-module GHC.StgToCmm.ExtCode (
-        CmmParse, unEC,
-        Named(..), Env,
-
-        loopDecls,
-        getEnv,
-
-        withName,
-        getName,
-
-        newLocal,
-        newLabel,
-        newBlockId,
-        newFunctionName,
-        newImport,
-        lookupLabel,
-        lookupName,
-
-        code,
-        emit, emitLabel, emitAssign, emitStore,
-        getCode, getCodeR, getCodeScoped,
-        emitOutOfLine,
-        withUpdFrameOff, getUpdFrameOff,
-        getProfile, getPlatform, getContext
-)
-
-where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Platform.Profile
-
-import qualified GHC.StgToCmm.Monad as F
-import GHC.StgToCmm.Monad (FCode, newUnique)
-
-import GHC.Cmm
-import GHC.Cmm.CLabel
-import GHC.Cmm.Graph
-
-import GHC.Cmm.BlockId
-import GHC.Data.FastString
-import GHC.Unit.Module
-import GHC.Types.Unique.FM
-import GHC.Types.Unique
-import GHC.Types.Unique.Supply
-
-import Control.Monad (ap)
-import GHC.Utils.Outputable (SDocContext)
-
--- | The environment contains variable definitions or blockids.
-data Named
-        = VarN CmmExpr          -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,
-                                --      eg, RtsLabel, ForeignLabel, CmmLabel etc.
-
-        | FunN   UnitId         -- ^ A function name from this unit
-        | LabelN BlockId        -- ^ A blockid of some code or data.
-
--- | An environment of named things.
-type Env        = UniqFM FastString Named
-
--- | Local declarations that are in scope during code generation.
-type Decls      = [(FastString,Named)]
-
--- | Does a computation in the FCode monad, with a current environment
---      and a list of local declarations. Returns the resulting list of declarations.
-newtype CmmParse a
-        = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }
-    deriving (Functor)
-
-type ExtCode = CmmParse ()
-
-returnExtFC :: a -> CmmParse a
-returnExtFC a   = EC $ \_ _ s -> return (s, a)
-
-thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
-thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'
-
-instance Applicative CmmParse where
-      pure = returnExtFC
-      (<*>) = ap
-
-instance Monad CmmParse where
-  (>>=) = thenExtFC
-
-instance MonadUnique CmmParse where
-  getUniqueSupplyM = code getUniqueSupplyM
-  getUniqueM = EC $ \_ _ decls -> do
-    u <- getUniqueM
-    return (decls, u)
-
-getProfile :: CmmParse Profile
-getProfile = EC (\_ _ d -> (d,) <$> F.getProfile)
-
-getPlatform :: CmmParse Platform
-getPlatform = EC (\_ _ d -> (d,) <$> F.getPlatform)
-
-getContext :: CmmParse SDocContext
-getContext = EC (\_ _ d -> (d,) <$> F.getContext)
-
--- | Takes the variable declarations and imports from the monad
---      and makes an environment, which is looped back into the computation.
---      In this way, we can have embedded declarations that scope over the whole
---      procedure, and imports that scope over the entire module.
---      Discards the local declaration contained within decl'
---
-loopDecls :: CmmParse a -> CmmParse a
-loopDecls (EC fcode) =
-      EC $ \c e globalDecls -> do
-        (_, a) <- F.fixC $ \ ~(decls, _) ->
-          fcode c (addListToUFM e decls) globalDecls
-        return (globalDecls, a)
-
--- | Get the current environment from the monad.
-getEnv :: CmmParse Env
-getEnv  = EC $ \_ e s -> return (s, e)
-
--- | Get the current context name from the monad
-getName :: CmmParse String
-getName  = EC $ \c _ s -> return (s, c)
-
--- | Set context name for a sub-parse
-withName :: String -> CmmParse a -> CmmParse a
-withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s
-
-addDecl :: FastString -> Named -> ExtCode
-addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ())
-
-
--- | Add a new variable to the list of local declarations.
---      The CmmExpr says where the value is stored.
-addVarDecl :: FastString -> CmmExpr -> ExtCode
-addVarDecl var expr = addDecl var (VarN expr)
-
--- | Add a new label to the list of local declarations.
-addLabel :: FastString -> BlockId -> ExtCode
-addLabel name block_id = addDecl name (LabelN block_id)
-
-
--- | Create a fresh local variable of a given type.
-newLocal
-        :: CmmType              -- ^ data type
-        -> FastString           -- ^ name of variable
-        -> CmmParse LocalReg    -- ^ register holding the value
-
-newLocal ty name = do
-   u <- code newUnique
-   let reg = LocalReg u ty
-   addVarDecl name (CmmReg (CmmLocal reg))
-   return reg
-
-
--- | Allocate a fresh label.
-newLabel :: FastString -> CmmParse BlockId
-newLabel name = do
-   u <- code newUnique
-   addLabel name (mkBlockId u)
-   return (mkBlockId u)
-
--- | Add a local function to the environment.
-newFunctionName
-        :: FastString   -- ^ name of the function
-        -> UnitId       -- ^ package of the current module
-        -> ExtCode
-
-newFunctionName name pkg = addDecl name (FunN pkg)
-
-
--- | Add an imported foreign label to the list of local declarations.
---      If this is done at the start of the module the declaration will scope
---      over the whole module.
-newImport
-        :: (FastString, CLabel)
-        -> CmmParse ()
-
-newImport (name, cmmLabel)
-   = addVarDecl name (CmmLit (CmmLabel cmmLabel))
-
-
--- | Lookup the BlockId bound to the label with this name.
---      If one hasn't been bound yet, create a fresh one based on the
---      Unique of the name.
-lookupLabel :: FastString -> CmmParse BlockId
-lookupLabel name = do
-  env <- getEnv
-  return $
-     case lookupUFM env name of
-        Just (LabelN l) -> l
-        _other          -> mkBlockId (newTagUnique (getUnique name) 'L')
-
-
--- | Lookup the location of a named variable.
---      Unknown names are treated as if they had been 'import'ed from the runtime system.
---      This saves us a lot of bother in the RTS sources, at the expense of
---      deferring some errors to link time.
-lookupName :: FastString -> CmmParse CmmExpr
-lookupName name = do
-  env    <- getEnv
-  return $
-     case lookupUFM env name of
-        Just (VarN e)   -> e
-        Just (FunN uid) -> CmmLit (CmmLabel (mkCmmCodeLabel uid       name))
-        _other          -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))
-
-
--- | Lift an FCode computation into the CmmParse monad
-code :: FCode a -> CmmParse a
-code fc = EC $ \_ _ s -> do
-                r <- fc
-                return (s, r)
-
-emit :: CmmAGraph -> CmmParse ()
-emit = code . F.emit
-
-emitLabel :: BlockId -> CmmParse ()
-emitLabel = code . F.emitLabel
-
-emitAssign :: CmmReg  -> CmmExpr -> CmmParse ()
-emitAssign l r = code (F.emitAssign l r)
-
-emitStore :: CmmExpr  -> CmmExpr -> CmmParse ()
-emitStore l r = code (F.emitStore l r)
-
-getCode :: CmmParse a -> CmmParse CmmAGraph
-getCode (EC ec) = EC $ \c e s -> do
-  ((s',_), gr) <- F.getCodeR (ec c e s)
-  return (s', gr)
-
-getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
-getCodeR (EC ec) = EC $ \c e s -> do
-  ((s', r), gr) <- F.getCodeR (ec c e s)
-  return (s', (r,gr))
-
-getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)
-getCodeScoped (EC ec) = EC $ \c e s -> do
-  ((s', r), gr) <- F.getCodeScoped (ec c e s)
-  return (s', (r,gr))
-
-emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()
-emitOutOfLine l g = code (F.emitOutOfLine l g)
-
-withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
-withUpdFrameOff size inner
-  = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s
-
-getUpdFrameOff :: CmmParse UpdFrameOffset
-getUpdFrameOff = code $ F.getUpdFrameOff
diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Foreign.hs
+++ /dev/null
@@ -1,726 +0,0 @@
------------------------------------------------------------------------------
---
--- Code generation for foreign calls.
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.Foreign (
-  cgForeignCall,
-  emitPrimCall, emitCCall,
-  emitForeignCall,
-  emitSaveThreadState,
-  saveThreadState,
-  emitLoadThreadState,
-  emitSaveRegs,
-  emitRestoreRegs,
-  emitPushTupleRegs,
-  emitPopTupleRegs,
-  loadThreadState,
-  emitOpenNursery,
-  emitCloseNursery,
- ) where
-
-import GHC.Prelude hiding( succ, (<*>) )
-
-import GHC.Platform
-import GHC.Platform.Profile
-
-import GHC.Stg.Syntax
-import GHC.StgToCmm.Prof (storeCurCCS, ccsType)
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Utils
-import GHC.StgToCmm.Closure
-import GHC.StgToCmm.Layout
-
-import GHC.Cmm.BlockId (newBlockId)
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Cmm.Graph
-import GHC.Cmm.CallConv
-import GHC.Core.Type
-import GHC.Types.RepType
-import GHC.Cmm.CLabel
-import GHC.Runtime.Heap.Layout
-import GHC.Types.ForeignCall
-import GHC.Data.Maybe
-import GHC.Utils.Panic
-import GHC.Types.Unique.Supply
-import GHC.Types.Basic
-import GHC.Unit.Types
-
-import GHC.Core.TyCo.Rep
-import GHC.Builtin.Types.Prim
-import GHC.Utils.Misc (zipEqual)
-
-import Control.Monad
-
------------------------------------------------------------------------------
--- Code generation for Foreign Calls
------------------------------------------------------------------------------
-
--- | Emit code for a foreign call, and return the results to the sequel.
--- Precondition: the length of the arguments list is the same as the
--- arity of the foreign function.
-cgForeignCall :: ForeignCall            -- the op
-              -> Type                   -- type of foreign function
-              -> [StgArg]               -- x,y    arguments
-              -> Type                   -- result type
-              -> FCode ReturnKind
-
-cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
-  = do  { platform <- getPlatform
-        ; let -- in the stdcall calling convention, the symbol needs @size appended
-              -- to it, where size is the total number of bytes of arguments.  We
-              -- attach this info to the CLabel here, and the CLabel pretty printer
-              -- will generate the suffix when the label is printed.
-            call_size args
-              | StdCallConv <- cconv = Just (sum (map arg_size args))
-              | otherwise            = Nothing
-
-              -- ToDo: this might not be correct for 64-bit API
-              -- This is correct for the PowerPC ELF ABI version 1 and 2.
-            arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType platform arg)
-                                     (platformWordSizeInBytes platform)
-        ; cmm_args <- getFCallArgs stg_args typ
-        -- ; traceM $ show cmm_args
-        ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
-        ; let ((call_args, arg_hints), cmm_target)
-                = case target of
-                   StaticTarget _ _   _      False ->
-                       panic "cgForeignCall: unexpected FFI value import"
-                   StaticTarget _ lbl mPkgId True
-                     -> let labelSource
-                                = case mPkgId of
-                                        Nothing         -> ForeignLabelInThisPackage
-                                        Just pkgId      -> ForeignLabelInPackage (toUnitId pkgId)
-                            size = call_size cmm_args
-                        in  ( unzip cmm_args
-                            , CmmLit (CmmLabel
-                                        (mkForeignLabel lbl size labelSource IsFunction)))
-
-                   DynamicTarget    ->  case cmm_args of
-                                           (fn,_):rest -> (unzip rest, fn)
-                                           [] -> panic "cgForeignCall []"
-              fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn
-              call_target = ForeignTarget cmm_target fc
-
-        -- we want to emit code for the call, and then emitReturn.
-        -- However, if the sequel is AssignTo, we shortcut a little
-        -- and generate a foreign call that assigns the results
-        -- directly.  Otherwise we end up generating a bunch of
-        -- useless "r = r" assignments, which are not merely annoying:
-        -- they prevent the common block elimination from working correctly
-        -- in the case of a safe foreign call.
-        -- See Note [safe foreign call convention]
-        --
-        ; sequel <- getSequel
-        ; case sequel of
-            AssignTo assign_to_these _ ->
-                emitForeignCall safety assign_to_these call_target call_args
-
-            _something_else ->
-                do { _ <- emitForeignCall safety res_regs call_target call_args
-                   ; emitReturn (map (CmmReg . CmmLocal) res_regs)
-                   }
-         }
-
-{- Note [safe foreign call convention]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The simple thing to do for a safe foreign call would be the same as an
-unsafe one: just
-
-    emitForeignCall ...
-    emitReturn ...
-
-but consider what happens in this case
-
-   case foo x y z of
-     (# s, r #) -> ...
-
-The sequel is AssignTo [r].  The call to newUnboxedTupleRegs picks [r]
-as the result reg, and we generate
-
-  r = foo(x,y,z) returns to L1  -- emitForeignCall
- L1:
-  r = r  -- emitReturn
-  goto L2
-L2:
-  ...
-
-Now L1 is a proc point (by definition, it is the continuation of the
-safe foreign call).  If L2 does a heap check, then L2 will also be a
-proc point.
-
-Furthermore, the stack layout algorithm has to arrange to save r
-somewhere between the call and the jump to L1, which is annoying: we
-would have to treat r differently from the other live variables, which
-have to be saved *before* the call.
-
-So we adopt a special convention for safe foreign calls: the results
-are copied out according to the NativeReturn convention by the call,
-and the continuation of the call should copyIn the results.  (The
-copyOut code is actually inserted when the safe foreign call is
-lowered later).  The result regs attached to the safe foreign call are
-only used temporarily to hold the results before they are copied out.
-
-We will now generate this:
-
-  r = foo(x,y,z) returns to L1
- L1:
-  r = R1  -- copyIn, inserted by mkSafeCall
-  goto L2
- L2:
-  ... r ...
-
-And when the safe foreign call is lowered later (see Note [Lower safe
-foreign calls]) we get this:
-
-  suspendThread()
-  r = foo(x,y,z)
-  resumeThread()
-  R1 = r  -- copyOut, inserted by lowerSafeForeignCall
-  jump L1
- L1:
-  r = R1  -- copyIn, inserted by mkSafeCall
-  goto L2
- L2:
-  ... r ...
-
-Now consider what happens if L2 does a heap check: the Adams
-optimisation kicks in and commons up L1 with the heap-check
-continuation, resulting in just one proc point instead of two. Yay!
--}
-
-
-emitCCall :: [(CmmFormal,ForeignHint)]
-          -> CmmExpr
-          -> [(CmmActual,ForeignHint)]
-          -> FCode ()
-emitCCall hinted_results fn hinted_args
-  = void $ emitForeignCall PlayRisky results target args
-  where
-    (args, arg_hints) = unzip hinted_args
-    (results, result_hints) = unzip hinted_results
-    target = ForeignTarget fn fc
-    fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn
-
-
-emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
-emitPrimCall res op args
-  = void $ emitForeignCall PlayRisky res (PrimTarget op) args
-
--- alternative entry point, used by GHC.Cmm.Parser
-emitForeignCall
-        :: Safety
-        -> [CmmFormal]          -- where to put the results
-        -> ForeignTarget        -- the op
-        -> [CmmActual]          -- arguments
-        -> FCode ReturnKind
-emitForeignCall safety results target args
-  | not (playSafe safety) = do
-    platform <- getPlatform
-    let (caller_save, caller_load) = callerSaveVolatileRegs platform
-    emit caller_save
-    target' <- load_target_into_temp target
-    args' <- mapM maybe_assign_temp args
-    emit $ mkUnsafeCall target' results args'
-    emit caller_load
-    return AssignedDirectly
-
-  | otherwise = do
-    profile <- getProfile
-    platform <- getPlatform
-    updfr_off <- getUpdFrameOff
-    target' <- load_target_into_temp target
-    args' <- mapM maybe_assign_temp args
-    k <- newBlockId
-    let (off, _, copyout) = copyInOflow profile NativeReturn (Young k) results []
-       -- see Note [safe foreign call convention]
-    tscope <- getTickScope
-    emit $
-           (    mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth platform)))
-                        (CmmLit (CmmBlock k))
-            <*> mkLast (CmmForeignCall { tgt  = target'
-                                       , res  = results
-                                       , args = args'
-                                       , succ = k
-                                       , ret_args = off
-                                       , ret_off = updfr_off
-                                       , intrbl = playInterruptible safety })
-            <*> mkLabel k tscope
-            <*> copyout
-           )
-    return (ReturnedTo k off)
-
-load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
-load_target_into_temp (ForeignTarget expr conv) = do
-  tmp <- maybe_assign_temp expr
-  return (ForeignTarget tmp conv)
-load_target_into_temp other_target@(PrimTarget _) =
-  return other_target
-
--- What we want to do here is create a new temporary for the foreign
--- call argument if it is not safe to use the expression directly,
--- because the expression mentions caller-saves GlobalRegs (see
--- Note [Register parameter passing]).
---
--- However, we can't pattern-match on the expression here, because
--- this is used in a loop by GHC.Cmm.Parser, and testing the expression
--- results in a black hole.  So we always create a temporary, and rely
--- on GHC.Cmm.Sink to clean it up later.  (Yuck, ToDo).  The generated code
--- ends up being the same, at least for the RTS .cmm code.
---
-maybe_assign_temp :: CmmExpr -> FCode CmmExpr
-maybe_assign_temp e = do
-  platform <- getPlatform
-  reg <- newTemp (cmmExprType platform e)
-  emitAssign (CmmLocal reg) e
-  return (CmmReg (CmmLocal reg))
-
--- -----------------------------------------------------------------------------
--- Save/restore the thread state in the TSO
-
--- This stuff can't be done in suspendThread/resumeThread, because it
--- refers to global registers which aren't available in the C world.
-
-emitSaveThreadState :: FCode ()
-emitSaveThreadState = do
-  profile <- getProfile
-  code <- saveThreadState profile
-  emit code
-
--- | Produce code to save the current thread state to @CurrentTSO@
-saveThreadState :: MonadUnique m => Profile -> m CmmAGraph
-saveThreadState profile = do
-  let platform = profilePlatform profile
-  tso <- newTemp (gcWord platform)
-  close_nursery <- closeNursery profile tso
-  pure $ catAGraphs
-   [ -- tso = CurrentTSO;
-     mkAssign (CmmLocal tso) currentTSOExpr
-
-   , -- tso->stackobj->sp = Sp;
-     mkStore (cmmOffset platform
-                        (cmmLoadBWord platform (cmmOffset platform
-                                            (CmmReg (CmmLocal tso))
-                                            (tso_stackobj profile)))
-                        (stack_SP profile))
-             spExpr
-
-    , close_nursery
-
-    , -- and save the current cost centre stack in the TSO when profiling:
-      if profileIsProfiling profile
-         then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile)) cccsExpr
-         else mkNop
-    ]
-
-
-
--- | Save STG registers
---
--- STG registers must be saved around a C call, just in case the STG
--- register is mapped to a caller-saves machine register.  Normally we
--- don't need to worry about this the code generator has already
--- loaded any live STG registers into variables for us, but in
--- hand-written low-level Cmm code where we don't know which registers
--- are live, we might have to save them all.
-emitSaveRegs :: FCode ()
-emitSaveRegs = do
-   platform <- getPlatform
-   let regs = realArgRegsCover platform
-       save = catAGraphs (map (callerSaveGlobalReg platform) regs)
-   emit save
-
--- | Restore STG registers (see 'emitSaveRegs')
-emitRestoreRegs :: FCode ()
-emitRestoreRegs = do
-   platform <- getPlatform
-   let regs    = realArgRegsCover platform
-       restore = catAGraphs (map (callerRestoreGlobalReg platform) regs)
-   emit restore
-
--- | Push a subset of STG registers onto the stack, specified by the bitmap
---
--- Sometimes, a "live" subset of the STG registers needs to be saved on the
--- stack, for example when storing an unboxed tuple to be used in the GHCi
--- bytecode interpreter.
---
--- The "live registers" bitmap corresponds to the list of registers given by
--- 'tupleRegsCover', with the least significant bit indicating liveness of
--- the first register in the list.
---
--- Each register is saved to a stack slot of one or more machine words, even
--- if the register size itself is smaller.
---
--- The resulting Cmm code looks like this, with a line for each real or
--- virtual register used for returning tuples:
---
---    ...
---    if((mask & 2) != 0) { Sp_adj(-1); Sp(0) = R2; }
---    if((mask & 1) != 0) { Sp_adj(-1); Sp(0) = R1; }
---
--- See Note [GHCi tuple layout]
-
-emitPushTupleRegs :: CmmExpr -> FCode ()
-emitPushTupleRegs regs_live = do
-  platform <- getPlatform
-  let regs = zip (tupleRegsCover platform) [0..]
-      save_arg (reg, n) =
-        let mask     = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform))
-            live     = cmmAndWord platform regs_live mask
-            cond     = cmmNeWord platform live (zeroExpr platform)
-            reg_ty   = cmmRegType platform (CmmGlobal reg)
-            width    = roundUpToWords platform
-                                      (widthInBytes $ typeWidth reg_ty)
-            adj_sp   = mkAssign spReg
-                                (cmmOffset platform spExpr (negate width))
-            save_reg = mkStore spExpr (CmmReg $ CmmGlobal reg)
-        in mkCmmIfThen cond $ catAGraphs [adj_sp, save_reg]
-  emit . catAGraphs =<< mapM save_arg (reverse regs)
-
--- | Pop a subset of STG registers from the stack (see 'emitPushTupleRegs')
-emitPopTupleRegs :: CmmExpr -> FCode ()
-emitPopTupleRegs regs_live = do
-  platform <- getPlatform
-  let regs = zip (tupleRegsCover platform) [0..]
-      save_arg (reg, n) =
-        let mask     = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform))
-            live     = cmmAndWord platform regs_live mask
-            cond     = cmmNeWord platform live (zeroExpr platform)
-            reg_ty   = cmmRegType platform (CmmGlobal reg)
-            width    = roundUpToWords platform
-                                      (widthInBytes $ typeWidth reg_ty)
-            adj_sp   = mkAssign spReg
-                                (cmmOffset platform spExpr width)
-            restore_reg = mkAssign (CmmGlobal reg) (CmmLoad spExpr reg_ty NaturallyAligned)
-        in mkCmmIfThen cond $ catAGraphs [restore_reg, adj_sp]
-  emit . catAGraphs =<< mapM save_arg regs
-
-
-emitCloseNursery :: FCode ()
-emitCloseNursery = do
-  profile <- getProfile
-  let platform = profilePlatform profile
-  tso <- newTemp (bWord platform)
-  code <- closeNursery profile tso
-  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code
-
-{- |
-@closeNursery dflags tso@ produces code to close the nursery.
-A local register holding the value of @CurrentTSO@ is expected for
-efficiency.
-
-Closing the nursery corresponds to the following code:
-
-@
-  tso = CurrentTSO;
-  cn = CurrentNuresry;
-
-  // Update the allocation limit for the current thread.  We don't
-  // check to see whether it has overflowed at this point, that check is
-  // made when we run out of space in the current heap block (stg_gc_noregs)
-  // and in the scheduler when context switching (schedulePostRunThread).
-  tso->alloc_limit -= Hp + WDS(1) - cn->start;
-
-  // Set cn->free to the next unoccupied word in the block
-  cn->free = Hp + WDS(1);
-@
--}
-closeNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph
-closeNursery profile tso = do
-  let tsoreg   = CmmLocal tso
-      platform = profilePlatform profile
-  cnreg      <- CmmLocal <$> newTemp (bWord platform)
-  pure $ catAGraphs [
-    mkAssign cnreg currentNurseryExpr,
-
-    -- CurrentNursery->free = Hp+1;
-    mkStore (nursery_bdescr_free platform cnreg) (cmmOffsetW platform hpExpr 1),
-
-    let alloc =
-           CmmMachOp (mo_wordSub platform)
-              [ cmmOffsetW platform hpExpr 1
-              , cmmLoadBWord platform (nursery_bdescr_start platform cnreg)
-              ]
-
-        alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit profile)
-    in
-
-    -- tso->alloc_limit += alloc
-    mkStore alloc_limit (CmmMachOp (MO_Sub W64)
-                               [ CmmLoad alloc_limit b64 NaturallyAligned
-                               , CmmMachOp (mo_WordTo64 platform) [alloc] ])
-   ]
-
-emitLoadThreadState :: FCode ()
-emitLoadThreadState = do
-  profile <- getProfile
-  code <- loadThreadState profile
-  emit code
-
--- | Produce code to load the current thread state from @CurrentTSO@
-loadThreadState :: MonadUnique m => Profile -> m CmmAGraph
-loadThreadState profile = do
-  let platform = profilePlatform profile
-  tso <- newTemp (gcWord platform)
-  stack <- newTemp (gcWord platform)
-  open_nursery <- openNursery profile tso
-  pure $ catAGraphs [
-    -- tso = CurrentTSO;
-    mkAssign (CmmLocal tso) currentTSOExpr,
-    -- stack = tso->stackobj;
-    mkAssign (CmmLocal stack) (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj profile))),
-    -- Sp = stack->sp;
-    mkAssign spReg (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile))),
-    -- SpLim = stack->stack + RESERVED_STACK_WORDS;
-    mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK profile))
-                                (pc_RESERVED_STACK_WORDS (platformConstants platform))),
-    -- HpAlloc = 0;
-    --   HpAlloc is assumed to be set to non-zero only by a failed
-    --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
-    mkAssign hpAllocReg (zeroExpr platform),
-    open_nursery,
-    -- and load the current cost centre stack from the TSO when profiling:
-    if profileIsProfiling profile
-       then let ccs_ptr = cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile)
-            in storeCurCCS (CmmLoad ccs_ptr (ccsType platform) NaturallyAligned)
-       else mkNop
-   ]
-
-
-emitOpenNursery :: FCode ()
-emitOpenNursery = do
-  profile <- getProfile
-  let platform = profilePlatform profile
-  tso <- newTemp (bWord platform)
-  code <- openNursery profile tso
-  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code
-
-{- |
-@openNursery profile tso@ produces code to open the nursery. A local register
-holding the value of @CurrentTSO@ is expected for efficiency.
-
-Opening the nursery corresponds to the following code:
-
-@
-   tso = CurrentTSO;
-   cn = CurrentNursery;
-   bdfree = CurrentNursery->free;
-   bdstart = CurrentNursery->start;
-
-   // We *add* the currently occupied portion of the nursery block to
-   // the allocation limit, because we will subtract it again in
-   // closeNursery.
-   tso->alloc_limit += bdfree - bdstart;
-
-   // Set Hp to the last occupied word of the heap block.  Why not the
-   // next unoccupied word?  Doing it this way means that we get to use
-   // an offset of zero more often, which might lead to slightly smaller
-   // code on some architectures.
-   Hp = bdfree - WDS(1);
-
-   // Set HpLim to the end of the current nursery block (note that this block
-   // might be a block group, consisting of several adjacent blocks.
-   HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1;
-@
--}
-openNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph
-openNursery profile tso = do
-  let tsoreg   = CmmLocal tso
-      platform = profilePlatform profile
-  cnreg      <- CmmLocal <$> newTemp (bWord platform)
-  bdfreereg  <- CmmLocal <$> newTemp (bWord platform)
-  bdstartreg <- CmmLocal <$> newTemp (bWord platform)
-
-  -- These assignments are carefully ordered to reduce register
-  -- pressure and generate not completely awful code on x86.  To see
-  -- what code we generate, look at the assembly for
-  -- stg_returnToStackTop in rts/StgStartup.cmm.
-  pure $ catAGraphs [
-     mkAssign cnreg currentNurseryExpr,
-     mkAssign bdfreereg  (cmmLoadBWord platform (nursery_bdescr_free platform cnreg)),
-
-     -- Hp = CurrentNursery->free - 1;
-     mkAssign hpReg (cmmOffsetW platform (CmmReg bdfreereg) (-1)),
-
-     mkAssign bdstartreg (cmmLoadBWord platform (nursery_bdescr_start platform cnreg)),
-
-     -- HpLim = CurrentNursery->start +
-     --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
-     mkAssign hpLimReg
-         (cmmOffsetExpr platform
-             (CmmReg bdstartreg)
-             (cmmOffset platform
-               (CmmMachOp (mo_wordMul platform)
-                 [ CmmMachOp (MO_SS_Conv W32 (wordWidth platform))
-                     [CmmLoad (nursery_bdescr_blocks platform cnreg) b32 NaturallyAligned]
-                 , mkIntExpr platform (pc_BLOCK_SIZE (platformConstants platform))
-                 ])
-               (-1)
-             )
-         ),
-
-     -- alloc = bd->free - bd->start
-     let alloc =
-           CmmMachOp (mo_wordSub platform) [CmmReg bdfreereg, CmmReg bdstartreg]
-
-         alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit profile)
-     in
-
-     -- tso->alloc_limit += alloc
-     mkStore alloc_limit (CmmMachOp (MO_Add W64)
-                               [ CmmLoad alloc_limit b64 NaturallyAligned
-                               , CmmMachOp (mo_WordTo64 platform) [alloc] ])
-
-   ]
-
-nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks
-  :: Platform -> CmmReg -> CmmExpr
-nursery_bdescr_free   platform cn =
-  cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_free (platformConstants platform))
-nursery_bdescr_start  platform cn =
-  cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_start (platformConstants platform))
-nursery_bdescr_blocks platform cn =
-  cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_blocks (platformConstants platform))
-
-tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: Profile -> ByteOff
-tso_stackobj    profile = closureField profile (pc_OFFSET_StgTSO_stackobj    (profileConstants profile))
-tso_alloc_limit profile = closureField profile (pc_OFFSET_StgTSO_alloc_limit (profileConstants profile))
-tso_CCCS        profile = closureField profile (pc_OFFSET_StgTSO_cccs        (profileConstants profile))
-stack_STACK     profile = closureField profile (pc_OFFSET_StgStack_stack     (profileConstants profile))
-stack_SP        profile = closureField profile (pc_OFFSET_StgStack_sp        (profileConstants profile))
-
-
-closureField :: Profile -> ByteOff -> ByteOff
-closureField profile off = off + fixedHdrSize profile
-
--- Note [Unlifted boxed arguments to foreign calls]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- For certain types passed to foreign calls, we adjust the actual
--- value passed to the call.  For ByteArray#, Array# and SmallArray#,
--- we pass the address of the array's payload, not the address of
--- the heap object. For example, consider:
---   foreign import "c_foo" foo :: ByteArray# -> Int# -> IO ()
--- At a Haskell call like `foo x y`, we'll generate a C call that
--- is more like
---   c_foo( x+8, y )
--- where the "+8" takes the heap pointer (x :: ByteArray#) and moves
--- it past the header words of the ByteArray object to point directly
--- to the data inside the ByteArray#. (The exact offset depends
--- on the target architecture and on profiling) By contrast, (y :: Int#)
--- requires no such adjustment.
---
--- This adjustment is performed by 'add_shim'. The size of the
--- adjustment depends on the type of heap object. But
--- how can we determine that type? There are two available options.
--- We could use the types of the actual values that the foreign call
--- has been applied to, or we could use the types present in the
--- foreign function's type. Prior to GHC 8.10, we used the former
--- strategy since it's a little more simple. However, in issue #16650
--- and more compellingly in the comments of
--- https://gitlab.haskell.org/ghc/ghc/merge_requests/939, it was
--- demonstrated that this leads to bad behavior in the presence
--- of unsafeCoerce#. Returning to the above example, suppose the
--- Haskell call looked like
---   foo (unsafeCoerce# p)
--- where the types of expressions comprising the arguments are
---   p :: (Any :: TYPE 'UnliftedRep)
---   i :: Int#
--- so that the unsafe-coerce is between Any and ByteArray#.
--- These two types have the same kind (they are both represented by
--- a heap pointer) so no GC errors will occur if we do this unsafe coerce.
--- By the time this gets to the code generator the cast has been
--- discarded so we have
---   foo p y
--- But we *must* adjust the pointer to p by a ByteArray# shim,
--- *not* by an Any shim (the Any shim involves no offset at all).
---
--- To avoid this bad behavior, we adopt the second strategy: use
--- the types present in the foreign function's type.
--- In collectStgFArgTypes, we convert the foreign function's
--- type to a list of StgFArgType. Then, in add_shim, we interpret
--- these as numeric offsets.
-
-getFCallArgs ::
-     [StgArg]
-  -> Type -- the type of the foreign function
-  -> FCode [(CmmExpr, ForeignHint)]
--- (a) Drop void args
--- (b) Add foreign-call shim code
--- It's (b) that makes this differ from getNonVoidArgAmodes
--- Precondition: args and typs have the same length
--- See Note [Unlifted boxed arguments to foreign calls]
-getFCallArgs args typ
-  = do  { mb_cmms <- mapM get (zipEqual "getFCallArgs" args (collectStgFArgTypes typ))
-        ; return (catMaybes mb_cmms) }
-  where
-    get (arg,typ)
-      | null arg_reps
-      = return Nothing
-      | otherwise
-      = do { cmm <- getArgAmode (NonVoid arg)
-           ; profile <- getProfile
-           ; return (Just (add_shim profile typ cmm, hint)) }
-      where
-        arg_ty   = stgArgType arg
-        arg_reps = typePrimRep arg_ty
-        hint     = typeForeignHint arg_ty
-
--- The minimum amount of information needed to determine
--- the offset to apply to an argument to a foreign call.
--- See Note [Unlifted boxed arguments to foreign calls]
-data StgFArgType
-  = StgPlainType
-  | StgArrayType
-  | StgSmallArrayType
-  | StgByteArrayType
-
--- See Note [Unlifted boxed arguments to foreign calls]
-add_shim :: Profile -> StgFArgType -> CmmExpr -> CmmExpr
-add_shim profile ty expr = case ty of
-  StgPlainType      -> expr
-  StgArrayType      -> cmmOffsetB platform expr (arrPtrsHdrSize profile)
-  StgSmallArrayType -> cmmOffsetB platform expr (smallArrPtrsHdrSize profile)
-  StgByteArrayType  -> cmmOffsetB platform expr (arrWordsHdrSize profile)
-  where
-    platform = profilePlatform profile
-
--- From a function, extract information needed to determine
--- the offset of each argument when used as a C FFI argument.
--- See Note [Unlifted boxed arguments to foreign calls]
-collectStgFArgTypes :: Type -> [StgFArgType]
-collectStgFArgTypes = go []
-  where
-    -- Skip foralls
-    go bs (ForAllTy _ res) = go bs res
-    go bs (AppTy{}) = reverse bs
-    go bs (TyConApp{}) = reverse bs
-    go bs (LitTy{}) = reverse bs
-    go bs (TyVarTy{}) = reverse bs
-    go  _ (CastTy{}) = panic "myCollectTypeArgs: CastTy"
-    go  _ (CoercionTy{}) = panic "myCollectTypeArgs: CoercionTy"
-    go bs (FunTy {ft_arg = arg, ft_res=res}) =
-      go (typeToStgFArgType arg:bs) res
-
--- Choose the offset based on the type. For anything other
--- than an unlifted boxed type, there is no offset.
--- See Note [Unlifted boxed arguments to foreign calls]
-typeToStgFArgType :: Type -> StgFArgType
-typeToStgFArgType typ
-  | tycon == arrayPrimTyCon = StgArrayType
-  | tycon == mutableArrayPrimTyCon = StgArrayType
-  | tycon == smallArrayPrimTyCon = StgSmallArrayType
-  | tycon == smallMutableArrayPrimTyCon = StgSmallArrayType
-  | tycon == byteArrayPrimTyCon = StgByteArrayType
-  | tycon == mutableByteArrayPrimTyCon = StgByteArrayType
-  | otherwise = StgPlainType
-  where
-  -- Should be a tycon app, since this is a foreign call. We look
-  -- through newtypes so the offset does not change if a user replaces
-  -- a type in a foreign function signature with a representationally
-  -- equivalent newtype.
-  tycon = tyConAppTyCon (unwrapType typ)
diff --git a/compiler/GHC/StgToCmm/Foreign.hs-boot b/compiler/GHC/StgToCmm/Foreign.hs-boot
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Foreign.hs-boot
+++ /dev/null
@@ -1,6 +0,0 @@
-module GHC.StgToCmm.Foreign where
-
-import GHC.Cmm
-import GHC.StgToCmm.Monad
-
-emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Heap.hs
+++ /dev/null
@@ -1,688 +0,0 @@
------------------------------------------------------------------------------
---
--- Stg to C--: heap management functions
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.Heap (
-        getVirtHp, setVirtHp, setRealHp,
-        getHpRelOffset,
-
-        entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,
-        heapStackCheckGen,
-        entryHeapCheck',
-
-        mkStaticClosureFields, mkStaticClosure,
-
-        allocDynClosure, allocDynClosureCmm, allocHeapClosure,
-        emitSetDynHdr
-    ) where
-
-import GHC.Prelude hiding ((<*>))
-
-import GHC.Stg.Syntax
-import GHC.Cmm.CLabel
-import GHC.StgToCmm.Layout
-import GHC.StgToCmm.Utils
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Prof (profDynAlloc, dynProfHdr, staticProfHdr)
-import GHC.StgToCmm.Ticky
-import GHC.StgToCmm.Closure
-
-import GHC.Cmm.Graph
-
-import GHC.Cmm.Dataflow.Label
-import GHC.Runtime.Heap.Layout
-import GHC.Cmm.BlockId
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Types.CostCentre
-import GHC.Types.Id.Info( CafInfo(..), mayHaveCafRefs )
-import GHC.Types.Id ( Id )
-import GHC.Unit
-import GHC.Platform
-import GHC.Platform.Profile
-import GHC.Data.FastString( mkFastString, fsLit )
-import GHC.Utils.Panic( sorry )
-
-import Control.Monad (when)
-import Data.Maybe (isJust)
-
------------------------------------------------------------
---              Initialise dynamic heap objects
------------------------------------------------------------
-
-allocDynClosure
-        :: Maybe Id
-        -> CmmInfoTable
-        -> LambdaFormInfo
-        -> CmmExpr              -- Cost Centre to stick in the object
-        -> CmmExpr              -- Cost Centre to blame for this alloc
-                                -- (usually the same; sometimes "OVERHEAD")
-
-        -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of object
-                                                -- ie Info ptr has offset zero.
-                                                -- No void args in here
-        -> FCode CmmExpr -- returns Hp+n
-
-allocDynClosureCmm
-        :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
-        -> [(CmmExpr, ByteOff)]
-        -> FCode CmmExpr -- returns Hp+n
-
--- allocDynClosure allocates the thing in the heap,
--- and modifies the virtual Hp to account for this.
--- The second return value is the graph that sets the value of the
--- returned LocalReg, which should point to the closure after executing
--- the graph.
-
--- allocDynClosure returns an (Hp+8) CmmExpr, and hence the result is
--- only valid until Hp is changed.  The caller should assign the
--- result to a LocalReg if it is required to remain live.
---
--- The reason we don't assign it to a LocalReg here is that the caller
--- is often about to call regIdInfo, which immediately assigns the
--- result of allocDynClosure to a new temp in order to add the tag.
--- So by not generating a LocalReg here we avoid a common source of
--- new temporaries and save some compile time.  This can be quite
--- significant - see test T4801.
-
-
-allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets = do
-  let (args, offsets) = unzip args_w_offsets
-  cmm_args <- mapM getArgAmode args     -- No void args
-  allocDynClosureCmm mb_id info_tbl lf_info
-                     use_cc _blame_cc (zip cmm_args offsets)
-
-
-allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do
-  -- SAY WHAT WE ARE ABOUT TO DO
-  let rep = cit_rep info_tbl
-  tickyDynAlloc mb_id rep lf_info
-  let info_ptr = CmmLit (CmmLabel (cit_lbl info_tbl))
-  allocHeapClosure rep info_ptr use_cc amodes_w_offsets
-
-
--- | Low-level heap object allocation.
-allocHeapClosure
-  :: SMRep                            -- ^ representation of the object
-  -> CmmExpr                          -- ^ info pointer
-  -> CmmExpr                          -- ^ cost centre
-  -> [(CmmExpr,ByteOff)]              -- ^ payload
-  -> FCode CmmExpr                    -- ^ returns the address of the object
-allocHeapClosure rep info_ptr use_cc payload = do
-  profDynAlloc rep use_cc
-
-  virt_hp <- getVirtHp
-
-  -- Find the offset of the info-ptr word
-  let info_offset = virt_hp + 1
-            -- info_offset is the VirtualHpOffset of the first
-            -- word of the new object
-            -- Remember, virtHp points to last allocated word,
-            -- ie 1 *before* the info-ptr word of new object.
-
-  base <- getHpRelOffset info_offset
-  emitComment $ mkFastString "allocHeapClosure"
-  emitSetDynHdr base info_ptr use_cc
-
-  -- Fill in the fields
-  hpStore base payload
-
-  -- Bump the virtual heap pointer
-  profile <- getProfile
-  setVirtHp (virt_hp + heapClosureSizeW profile rep)
-
-  return base
-
-
-emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
-emitSetDynHdr base info_ptr ccs
-  = do profile <- getProfile
-       hpStore base (zip (header profile) [0, profileWordSizeInBytes profile ..])
-  where
-    header :: Profile -> [CmmExpr]
-    header profile = [info_ptr] ++ dynProfHdr profile ccs
-        -- ToDo: Parallel stuff
-        -- No ticky header
-
--- Store the item (expr,off) in base[off]
-hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode ()
-hpStore base vals = do
-  platform <- getPlatform
-  sequence_ $
-    [ emitStore (cmmOffsetB platform base off) val | (val,off) <- vals ]
-
------------------------------------------------------------
---              Layout of static closures
------------------------------------------------------------
-
--- | Make a static closure, adding on any extra padding needed for CAFs, and
--- adding a static link field if necessary.
-mkStaticClosureFields
-        :: Profile
-        -> CmmInfoTable
-        -> CostCentreStack
-        -> CafInfo
-        -> [CmmLit]             -- ^ Payload
-        -> [CmmLit]             -- ^ Extra non-pointers that go to the end of the closure.
-                                -- See Note [unpack_cstring closures] in StgStdThunks.cmm.
-        -> [CmmLit]             -- The full closure
-mkStaticClosureFields profile info_tbl ccs caf_refs payload extras
-  = mkStaticClosure profile info_lbl ccs payload padding
-        static_link_field saved_info_field extras
-  where
-    platform = profilePlatform profile
-    info_lbl = cit_lbl info_tbl
-
-    -- CAFs must have consistent layout, regardless of whether they
-    -- are actually updatable or not.  The layout of a CAF is:
-    --
-    --        3 saved_info
-    --        2 static_link
-    --        1 indirectee
-    --        0 info ptr
-    --
-    -- the static_link and saved_info fields must always be in the
-    -- same place.  So we use isThunkRep rather than closureUpdReqd
-    -- here:
-
-    is_caf = isThunkRep (cit_rep info_tbl)
-
-    padding
-        | is_caf && null payload = [mkIntCLit platform 0]
-        | otherwise = []
-
-    static_link_field
-        | is_caf
-        = [mkIntCLit platform 0]
-        | staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl
-        = [static_link_value]
-        | otherwise
-        = []
-
-    saved_info_field
-        | is_caf     = [mkIntCLit platform 0]
-        | otherwise  = []
-
-        -- For a static constructor which has NoCafRefs, we set the
-        -- static link field to a non-zero value so the garbage
-        -- collector will ignore it.
-    static_link_value
-        | mayHaveCafRefs caf_refs  = mkIntCLit platform 0
-        | otherwise                = mkIntCLit platform 3  -- No CAF refs
-                                      -- See Note [STATIC_LINK fields]
-                                      -- in rts/sm/Storage.h
-
-mkStaticClosure :: Profile -> CLabel -> CostCentreStack -> [CmmLit]
-  -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
-mkStaticClosure profile info_lbl ccs payload padding static_link_field saved_info_field extras
-  =  [CmmLabel info_lbl]
-  ++ staticProfHdr profile ccs
-  ++ payload
-  ++ padding
-  ++ static_link_field
-  ++ saved_info_field
-  ++ extras
-
------------------------------------------------------------
---              Heap overflow checking
------------------------------------------------------------
-
-{- Note [Heap checks]
-   ~~~~~~~~~~~~~~~~~~
-Heap checks come in various forms.  We provide the following entry
-points to the runtime system, all of which use the native C-- entry
-convention.
-
-  * gc() performs garbage collection and returns
-    nothing to its caller
-
-  * A series of canned entry points like
-        r = gc_1p( r )
-    where r is a pointer.  This performs gc, and
-    then returns its argument r to its caller.
-
-  * A series of canned entry points like
-        gcfun_2p( f, x, y )
-    where f is a function closure of arity 2
-    This performs garbage collection, keeping alive the
-    three argument ptrs, and then tail-calls f(x,y)
-
-These are used in the following circumstances
-
-* entryHeapCheck: Function entry
-    (a) With a canned GC entry sequence
-        f( f_clo, x:ptr, y:ptr ) {
-             Hp = Hp+8
-             if Hp > HpLim goto L
-             ...
-          L: HpAlloc = 8
-             jump gcfun_2p( f_clo, x, y ) }
-     Note the tail call to the garbage collector;
-     it should do no register shuffling
-
-    (b) No canned sequence
-        f( f_clo, x:ptr, y:ptr, ...etc... ) {
-          T: Hp = Hp+8
-             if Hp > HpLim goto L
-             ...
-          L: HpAlloc = 8
-             call gc()  -- Needs an info table
-             goto T }
-
-* altHeapCheck: Immediately following an eval
-  Started as
-        case f x y of r { (p,q) -> rhs }
-  (a) With a canned sequence for the results of f
-       (which is the very common case since
-       all boxed cases return just one pointer
-           ...
-           r = f( x, y )
-        K:      -- K needs an info table
-           Hp = Hp+8
-           if Hp > HpLim goto L
-           ...code for rhs...
-
-        L: r = gc_1p( r )
-           goto K }
-
-        Here, the info table needed by the call
-        to gc_1p should be the *same* as the
-        one for the call to f; the C-- optimiser
-        spots this sharing opportunity)
-
-   (b) No canned sequence for results of f
-       Note second info table
-           ...
-           (r1,r2,r3) = call f( x, y )
-        K:
-           Hp = Hp+8
-           if Hp > HpLim goto L
-           ...code for rhs...
-
-        L: call gc()    -- Extra info table here
-           goto K
-
-* generalHeapCheck: Anywhere else
-  e.g. entry to thunk
-       case branch *not* following eval,
-       or let-no-escape
-  Exactly the same as the previous case:
-
-        K:      -- K needs an info table
-           Hp = Hp+8
-           if Hp > HpLim goto L
-           ...
-
-        L: call gc()
-           goto K
--}
-
---------------------------------------------------------------
--- A heap/stack check at a function or thunk entry point.
-
-entryHeapCheck :: ClosureInfo
-               -> Maybe LocalReg -- Function (closure environment)
-               -> Int            -- Arity -- not same as len args b/c of voids
-               -> [LocalReg]     -- Non-void args (empty for thunk)
-               -> FCode ()
-               -> FCode ()
-
-entryHeapCheck cl_info nodeSet arity args code = do
-  platform <- getPlatform
-  let
-    node = case nodeSet of
-              Just r  -> CmmReg (CmmLocal r)
-              Nothing -> CmmLit (CmmLabel $ staticClosureLabel platform cl_info)
-
-    is_fastf = case closureFunInfo cl_info of
-                 Just (_, ArgGen _) -> False
-                 _otherwise         -> True
-
-  entryHeapCheck' is_fastf node arity args code
-
--- | lower-level version for "GHC.Cmm.Parser"
-entryHeapCheck' :: Bool           -- is a known function pattern
-                -> CmmExpr        -- expression for the closure pointer
-                -> Int            -- Arity -- not same as len args b/c of voids
-                -> [LocalReg]     -- Non-void args (empty for thunk)
-                -> FCode ()
-                -> FCode ()
-entryHeapCheck' is_fastf node arity args code
-  = do profile <- getProfile
-       let is_thunk = arity == 0
-
-           args' = map (CmmReg . CmmLocal) args
-           stg_gc_fun    = CmmReg (CmmGlobal GCFun)
-           stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
-
-           {- Thunks:          jump stg_gc_enter_1
-
-              Function (fast): call (NativeNode) stg_gc_fun(fun, args)
-
-              Function (slow): call (slow) stg_gc_fun(fun, args)
-           -}
-           gc_call upd
-               | is_thunk
-                 = mkJump profile NativeNodeCall stg_gc_enter1 [node] upd
-
-               | is_fastf
-                 = mkJump profile NativeNodeCall stg_gc_fun (node : args') upd
-
-               | otherwise
-                 = mkJump profile Slow stg_gc_fun (node : args') upd
-
-       updfr_sz <- getUpdFrameOff
-
-       loop_id <- newBlockId
-       emitLabel loop_id
-       heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code
-
--- ------------------------------------------------------------
--- A heap/stack check in a case alternative
-
-
--- If there are multiple alts and we need to GC, but don't have a
--- continuation already (the scrut was simple), then we should
--- pre-generate the continuation.  (if there are multiple alts it is
--- always a canned GC point).
-
--- altHeapCheck:
--- If we have a return continuation,
---   then if it is a canned GC pattern,
---           then we do mkJumpReturnsTo
---           else we do a normal call to stg_gc_noregs
---   else if it is a canned GC pattern,
---           then generate the continuation and do mkCallReturnsTo
---           else we do a normal call to stg_gc_noregs
-
-altHeapCheck :: [LocalReg] -> FCode a -> FCode a
-altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code
-
-altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a
-altOrNoEscapeHeapCheck checkYield regs code = do
-    profile <- getProfile
-    platform <- getPlatform
-    case cannedGCEntryPoint platform regs of
-      Nothing -> genericGC checkYield code
-      Just gc -> do
-        lret <- newBlockId
-        let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) regs []
-        lcont <- newBlockId
-        tscope <- getTickScope
-        emitOutOfLine lret (copyin <*> mkBranch lcont, tscope)
-        emitLabel lcont
-        cannedGCReturnsTo checkYield False gc regs lret off code
-
-altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a
-altHeapCheckReturnsTo regs lret off code
-  = do platform <- getPlatform
-       case cannedGCEntryPoint platform regs of
-           Nothing -> genericGC False code
-           Just gc -> cannedGCReturnsTo False True gc regs lret off code
-
--- noEscapeHeapCheck is implemented identically to altHeapCheck (which
--- is more efficient), but cannot be optimized away in the non-allocating
--- case because it may occur in a loop
-noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a
-noEscapeHeapCheck = altOrNoEscapeHeapCheck True
-
-cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff
-                  -> FCode a
-                  -> FCode a
-cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code
-  = do profile <- getProfile
-       updfr_sz <- getUpdFrameOff
-       heapCheck False checkYield (gc_call profile gc updfr_sz) code
-  where
-    reg_exprs = map (CmmReg . CmmLocal) regs
-      -- Note [stg_gc arguments]
-
-      -- NB. we use the NativeReturn convention for passing arguments
-      -- to the canned heap-check routines, because we are in a case
-      -- alternative and hence the [LocalReg] was passed to us in the
-      -- NativeReturn convention.
-    gc_call profile label sp
-      | cont_on_stack
-      = mkJumpReturnsTo profile label NativeReturn reg_exprs lret off sp
-      | otherwise
-      = mkCallReturnsTo profile label NativeReturn reg_exprs lret off sp []
-
-genericGC :: Bool -> FCode a -> FCode a
-genericGC checkYield code
-  = do updfr_sz <- getUpdFrameOff
-       lretry <- newBlockId
-       emitLabel lretry
-       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
-       heapCheck False checkYield (call <*> mkBranch lretry) code
-
-cannedGCEntryPoint :: Platform -> [LocalReg] -> Maybe CmmExpr
-cannedGCEntryPoint platform regs
-  = case map localRegType regs of
-      []  -> Just (mkGcLabel "stg_gc_noregs")
-      [ty]
-          | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1")
-          | isFloatType ty -> case width of
-                                  W32       -> Just (mkGcLabel "stg_gc_f1")
-                                  W64       -> Just (mkGcLabel "stg_gc_d1")
-                                  _         -> Nothing
-
-          | width == wordWidth platform -> Just (mkGcLabel "stg_gc_unbx_r1")
-          | width == W64                -> Just (mkGcLabel "stg_gc_l1")
-          | otherwise                   -> Nothing
-          where
-              width = typeWidth ty
-      [ty1,ty2]
-          |  isGcPtrType ty1
-          && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp")
-      [ty1,ty2,ty3]
-          |  isGcPtrType ty1
-          && isGcPtrType ty2
-          && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp")
-      [ty1,ty2,ty3,ty4]
-          |  isGcPtrType ty1
-          && isGcPtrType ty2
-          && isGcPtrType ty3
-          && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp")
-      _otherwise -> Nothing
-
--- Note [stg_gc arguments]
--- ~~~~~~~~~~~~~~~~~~~~~~~
--- It might seem that we could avoid passing the arguments to the
--- stg_gc function, because they are already in the right registers.
--- While this is usually the case, it isn't always.  Sometimes the
--- code generator has cleverly avoided the eval in a case, e.g. in
--- ffi/should_run/4221.hs we found
---
---   case a_r1mb of z
---     FunPtr x y -> ...
---
--- where a_r1mb is bound a top-level constructor, and is known to be
--- evaluated.  The codegen just assigns x, y and z, and continues;
--- R1 is never assigned.
---
--- So we'll have to rely on optimisations to eliminatethese
--- assignments where possible.
-
-
--- | The generic GC procedure; no params, no results
-generic_gc :: CmmExpr
-generic_gc = mkGcLabel "stg_gc_noregs"
-
--- | Create a CLabel for calling a garbage collector entry point
-mkGcLabel :: String -> CmmExpr
-mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit s)))
-
--------------------------------
-heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
-heapCheck checkStack checkYield do_gc code
-  = getHeapUsage $ \ hpHw ->
-    -- Emit heap checks, but be sure to do it lazily so
-    -- that the conditionals on hpHw don't cause a black hole
-    do  { platform <- getPlatform
-        ; let mb_alloc_bytes
-                 | hpHw > mBLOCK_SIZE = sorry $ unlines
-                    [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.",
-                     "",
-                     "This is currently not possible due to a limitation of GHC's code generator.",
-                     "See https://gitlab.haskell.org/ghc/ghc/issues/4505 for details.",
-                     "Suggestion: read data from a file instead of having large static data",
-                     "structures in code."]
-                 | hpHw > 0  = Just (mkIntExpr platform (hpHw * (platformWordSizeInBytes platform)))
-                 | otherwise = Nothing
-                 where
-                  constants = platformConstants platform
-                  bLOCK_SIZE_W = pc_BLOCK_SIZE (platformConstants platform) `quot` platformWordSizeInBytes platform
-                  mBLOCK_SIZE = pc_BLOCKS_PER_MBLOCK constants * bLOCK_SIZE_W
-              stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)
-                      | otherwise  = Nothing
-        ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc
-        ; tickyAllocHeap True hpHw
-        ; setRealHp hpHw
-        ; code }
-
-heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()
-heapStackCheckGen stk_hwm mb_bytes
-  = do updfr_sz <- getUpdFrameOff
-       lretry <- newBlockId
-       emitLabel lretry
-       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
-       do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry)
-
--- Note [Single stack check]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~
--- When compiling a function we can determine how much stack space it
--- will use. We therefore need to perform only a single stack check at
--- the beginning of a function to see if we have enough stack space.
---
--- The check boils down to comparing Sp-N with SpLim, where N is the
--- amount of stack space needed (see Note [Stack usage] below).  *BUT*
--- at this stage of the pipeline we are not supposed to refer to Sp
--- itself, because the stack is not yet manifest, so we don't quite
--- know where Sp pointing.
-
--- So instead of referring directly to Sp - as we used to do in the
--- past - the code generator uses (old + 0) in the stack check. That
--- is the address of the first word of the old area, so if we add N
--- we'll get the address of highest used word.
---
--- This makes the check robust.  For example, while we need to perform
--- only one stack check for each function, we could in theory place
--- more stack checks later in the function. They would be redundant,
--- but not incorrect (in a sense that they should not change program
--- behaviour). We need to make sure however that a stack check
--- inserted after incrementing the stack pointer checks for a
--- respectively smaller stack space. This would not be the case if the
--- code generator produced direct references to Sp. By referencing
--- (old + 0) we make sure that we always check for a correct amount of
--- stack: when converting (old + 0) to Sp the stack layout phase takes
--- into account changes already made to stack pointer. The idea for
--- this change came from observations made while debugging #8275.
-
--- Note [Stack usage]
--- ~~~~~~~~~~~~~~~~~~
--- At the moment we convert from STG to Cmm we don't know N, the
--- number of bytes of stack that the function will use, so we use a
--- special late-bound CmmLit, namely
---       CmmHighStackMark
--- to stand for the number of bytes needed. When the stack is made
--- manifest, the number of bytes needed is calculated, and used to
--- replace occurrences of CmmHighStackMark
---
--- The (Maybe CmmExpr) passed to do_checks is usually
---     Just (CmmLit CmmHighStackMark)
--- but can also (in certain hand-written RTS functions)
---     Just (CmmLit 8)  or some other fixed valuet
--- If it is Nothing, we don't generate a stack check at all.
-
-do_checks :: Maybe CmmExpr    -- Should we check the stack?
-                              -- See Note [Stack usage]
-          -> Bool             -- Should we check for preemption?
-          -> Maybe CmmExpr    -- Heap headroom (bytes)
-          -> CmmAGraph        -- What to do on failure
-          -> FCode ()
-do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
-  omit_yields <- stgToCmmOmitYields <$> getStgToCmmConfig
-  platform    <- getPlatform
-  gc_id       <- newBlockId
-
-  let
-    -- Sp overflow if ((old + 0) - CmmHighStack < SpLim)
-    -- At the beginning of a function old + 0 = Sp
-    -- See Note [Single stack check]
-    sp_oflo sp_hwm =
-         CmmMachOp (mo_wordULt platform)
-                  [CmmMachOp (MO_Sub (typeWidth (cmmRegType platform spReg)))
-                             [CmmStackSlot Old 0, sp_hwm],
-                   CmmReg spLimReg]
-
-    -- Hp overflow if (Hp > HpLim)
-    -- (Hp has been incremented by now)
-    -- HpLim points to the LAST WORD of valid allocation space.
-    hp_oflo = CmmMachOp (mo_wordUGt platform) [hpExpr, hpLimExpr]
-
-  case mb_stk_hwm of
-    Nothing -> return ()
-    Just stk_hwm -> tickyStackCheck
-      >> (emit =<< mkCmmIfGoto' (sp_oflo stk_hwm) gc_id (Just False) )
-
-  -- Emit new label that might potentially be a header
-  -- of a self-recursive tail call.
-  -- See Note [Self-recursive loop header].
-  self_loop_info <- getSelfLoop
-  case self_loop_info of
-    Just (_, loop_header_id, _)
-        | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id
-    _otherwise -> return ()
-
-  case mb_alloc_lit of
-    Just alloc_lit -> do
-     let bump_hp   = cmmOffsetExprB platform hpExpr alloc_lit
-         alloc_n = mkAssign hpAllocReg alloc_lit
-     tickyHeapCheck
-     emitAssign hpReg bump_hp
-     emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False)
-    Nothing ->
-      when (checkYield && not omit_yields) $ do
-         -- Yielding if HpLim == 0
-         let yielding = CmmMachOp (mo_wordEq platform)
-                                  [CmmReg hpLimReg,
-                                   CmmLit (zeroCLit platform)]
-         emit =<< mkCmmIfGoto' yielding gc_id (Just False)
-
-  tscope <- getTickScope
-  emitOutOfLine gc_id
-   (do_gc, tscope) -- this is expected to jump back somewhere
-
-                -- Test for stack pointer exhaustion, then
-                -- bump heap pointer, and test for heap exhaustion
-                -- Note that we don't move the heap pointer unless the
-                -- stack check succeeds.  Otherwise we might end up
-                -- with slop at the end of the current block, which can
-                -- confuse the LDV profiler.
-
--- Note [Self-recursive loop header]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Self-recursive loop header is required by loopification optimization (See
--- Note [Self-recursive tail calls] in GHC.StgToCmm.Expr). We emit it if:
---
---  1. There is information about self-loop in the FCode environment. We don't
---     check the binder (first component of the self_loop_info) because we are
---     certain that if the self-loop info is present then we are compiling the
---     binder body. Reason: the only possible way to get here with the
---     self_loop_info present is from closureCodeBody.
---
---  2. checkYield && isJust mb_stk_hwm. checkYield tells us that it is possible
---     to preempt the heap check (see #367 for motivation behind this check). It
---     is True for heap checks placed at the entry to a function and
---     let-no-escape heap checks but false for other heap checks (eg. in case
---     alternatives or created from hand-written high-level Cmm). The second
---     check (isJust mb_stk_hwm) is true for heap checks at the entry to a
---     function and some heap checks created in hand-written Cmm. Otherwise it
---     is Nothing. In other words the only situation when both conditions are
---     true is when compiling stack and heap checks at the entry to a
---     function. This is the only situation when we want to emit a self-loop
---     label.
diff --git a/compiler/GHC/StgToCmm/Hpc.hs b/compiler/GHC/StgToCmm/Hpc.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Hpc.hs
+++ /dev/null
@@ -1,49 +0,0 @@
------------------------------------------------------------------------------
---
--- Code generation for coverage
---
--- (c) Galois Connections, Inc. 2006
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.Hpc ( initHpc, mkTickBox ) where
-
-import GHC.Prelude
-import GHC.Platform
-
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Utils
-
-import GHC.Cmm.Graph
-import GHC.Cmm.Expr
-import GHC.Cmm.CLabel
-import GHC.Cmm.Utils
-
-import GHC.Unit.Module
-import GHC.Types.HpcInfo
-
-import Control.Monad
-
-mkTickBox :: Platform -> Module -> Int -> CmmAGraph
-mkTickBox platform mod n
-  = mkStore tick_box (CmmMachOp (MO_Add W64)
-                                [ CmmLoad tick_box b64 NaturallyAligned
-                                , CmmLit (CmmInt 1 W64)
-                                ])
-  where
-    tick_box = cmmIndex platform W64
-                        (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
-                        n
-
--- | Emit top-level tables for HPC and return code to initialise
-initHpc :: Module -> HpcInfo -> FCode ()
-initHpc _ NoHpcInfo{}
-  = return ()
-initHpc this_mod (HpcInfo tickCount _hashNo)
-  = do do_hpc <- stgToCmmOptHpc <$> getStgToCmmConfig
-       when do_hpc $
-           emitDataLits (mkHpcTicksLabel this_mod)
-                        [ CmmInt 0 W64
-                        | _ <- take tickCount [0 :: Int ..]
-                        ]
-
diff --git a/compiler/GHC/StgToCmm/InfoTableProv.hs b/compiler/GHC/StgToCmm/InfoTableProv.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/InfoTableProv.hs
+++ /dev/null
@@ -1,144 +0,0 @@
-module GHC.StgToCmm.InfoTableProv (emitIpeBufferListNode) where
-
-import GHC.Prelude
-import GHC.Platform
-import GHC.Unit.Module
-import GHC.Utils.Outputable
-import GHC.Types.SrcLoc (pprUserRealSpan, srcSpanFile)
-import GHC.Data.FastString (unpackFS)
-
-import GHC.Cmm.CLabel
-import GHC.Cmm.Expr
-import GHC.Cmm.Utils
-import GHC.StgToCmm.Config
-import GHC.StgToCmm.Lit (newByteStringCLit)
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Utils
-
-import GHC.Data.ShortText (ShortText)
-import qualified GHC.Data.ShortText as ST
-
-import qualified Data.Map.Strict as M
-import Control.Monad.Trans.State.Strict
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Builder as BSB
-import qualified Data.ByteString.Lazy as BSL
-
-emitIpeBufferListNode :: Module
-                      -> [InfoProvEnt]
-                      -> FCode ()
-emitIpeBufferListNode _ [] = return ()
-emitIpeBufferListNode this_mod ents = do
-    cfg <- getStgToCmmConfig
-    let ctx      = stgToCmmContext  cfg
-        platform = stgToCmmPlatform cfg
-
-    let (cg_ipes, strtab) = flip runState emptyStringTable $ do
-            module_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr this_mod)
-            mapM (toCgIPE platform ctx module_name) ents
-
-    let -- Emit the fields of an IpeBufferEntry struct.
-        toIpeBufferEntry :: CgInfoProvEnt -> [CmmLit]
-        toIpeBufferEntry cg_ipe =
-            [ CmmLabel (ipeInfoTablePtr cg_ipe)
-            , strtab_offset (ipeTableName cg_ipe)
-            , strtab_offset (ipeClosureDesc cg_ipe)
-            , strtab_offset (ipeTypeDesc cg_ipe)
-            , strtab_offset (ipeLabel cg_ipe)
-            , strtab_offset (ipeModuleName cg_ipe)
-            , strtab_offset (ipeSrcFile cg_ipe)
-            , strtab_offset (ipeSrcSpan cg_ipe)
-            , int32 0
-            ]
-
-        int n = mkIntCLit platform n
-        int32 n = CmmInt n W32
-        strtab_offset (StrTabOffset n) = int32 (fromIntegral n)
-
-    strings <- newByteStringCLit (getStringTableStrings strtab)
-    let lits = [ zeroCLit platform     -- 'next' field
-               , strings               -- 'strings' field
-               , int $ length cg_ipes  -- 'count' field
-               ] ++ concatMap toIpeBufferEntry cg_ipes
-    emitDataLits (mkIPELabel this_mod) lits
-
-toCgIPE :: Platform -> SDocContext -> StrTabOffset -> InfoProvEnt -> State StringTable CgInfoProvEnt
-toCgIPE platform ctx module_name ipe = do
-    table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform (infoTablePtr ipe))
-    closure_desc <- lookupStringTable $ ST.pack $ show (infoProvEntClosureType ipe)
-    type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe
-    let label_str = maybe "" snd (infoTableProv ipe)
-    let (src_loc_file, src_loc_span) =
-            case infoTableProv ipe of
-              Nothing -> ("", "")
-              Just (span, _) ->
-                  let file = unpackFS $ srcSpanFile span
-                      coords = renderWithContext ctx (pprUserRealSpan False span)
-                  in (file, coords)
-    label <- lookupStringTable $ ST.pack label_str
-    src_file <- lookupStringTable $ ST.pack src_loc_file
-    src_span <- lookupStringTable $ ST.pack src_loc_span
-    return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe
-                           , ipeTableName = table_name
-                           , ipeClosureDesc = closure_desc
-                           , ipeTypeDesc = type_desc
-                           , ipeLabel = label
-                           , ipeModuleName = module_name
-                           , ipeSrcFile = src_file
-                           , ipeSrcSpan = src_span
-                           }
-
-data CgInfoProvEnt = CgInfoProvEnt
-                               { ipeInfoTablePtr :: !CLabel
-                               , ipeTableName :: !StrTabOffset
-                               , ipeClosureDesc :: !StrTabOffset
-                               , ipeTypeDesc :: !StrTabOffset
-                               , ipeLabel :: !StrTabOffset
-                               , ipeModuleName :: !StrTabOffset
-                               , ipeSrcFile :: !StrTabOffset
-                               , ipeSrcSpan :: !StrTabOffset
-                               }
-
-data StringTable = StringTable { stStrings :: DList ShortText
-                               , stLength :: !Int
-                               , stLookup :: !(M.Map ShortText StrTabOffset)
-                               }
-
-newtype StrTabOffset = StrTabOffset Int
-
-emptyStringTable :: StringTable
-emptyStringTable =
-    StringTable { stStrings = emptyDList
-                , stLength = 0
-                , stLookup = M.empty
-                }
-
-getStringTableStrings :: StringTable -> BS.ByteString
-getStringTableStrings st =
-    BSL.toStrict $ BSB.toLazyByteString
-    $ foldMap f $ dlistToList (stStrings st)
-  where
-    f x = BSB.shortByteString (ST.contents x) `mappend` BSB.word8 0
-
-lookupStringTable :: ShortText -> State StringTable StrTabOffset
-lookupStringTable str = state $ \st ->
-    case M.lookup str (stLookup st) of
-      Just off -> (off, st)
-      Nothing ->
-          let !st' = st { stStrings = stStrings st `snoc` str
-                        , stLength  = stLength st + ST.byteLength str + 1
-                        , stLookup  = M.insert str res (stLookup st)
-                        }
-              res = StrTabOffset (stLength st)
-          in (res, st')
-
-newtype DList a = DList ([a] -> [a])
-
-emptyDList :: DList a
-emptyDList = DList id
-
-snoc :: DList a -> a -> DList a
-snoc (DList f) x = DList (f . (x:))
-
-dlistToList :: DList a -> [a]
-dlistToList (DList f) = f []
diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Layout.hs
+++ /dev/null
@@ -1,656 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
-
------------------------------------------------------------------------------
---
--- Building info tables.
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.Layout (
-        mkArgDescr,
-        emitCall, emitReturn, adjustHpBackwards,
-
-        emitClosureProcAndInfoTable,
-        emitClosureAndInfoTable,
-
-        slowCall, directCall,
-
-        FieldOffOrPadding(..),
-        ClosureHeader(..),
-        mkVirtHeapOffsets,
-        mkVirtHeapOffsetsWithPadding,
-        mkVirtConstrOffsets,
-        mkVirtConstrSizes,
-        getHpRelOffset,
-
-        ArgRep(..), toArgRep, argRepSizeW, -- re-exported from GHC.StgToCmm.ArgRep
-        getArgAmode, getNonVoidArgAmodes
-  ) where
-
-
-import GHC.Prelude hiding ((<*>))
-
-import GHC.StgToCmm.Closure
-import GHC.StgToCmm.Env
-import GHC.StgToCmm.ArgRep -- notably: ( slowCallPattern )
-import GHC.StgToCmm.Ticky
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Lit
-import GHC.StgToCmm.Utils
-
-import GHC.Cmm.Graph
-import GHC.Runtime.Heap.Layout
-import GHC.Cmm.BlockId
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Cmm.Info
-import GHC.Cmm.CLabel
-import GHC.Stg.Syntax
-import GHC.Types.Id
-import GHC.Core.TyCon    ( PrimRep(..), primRepSizeB )
-import GHC.Types.Basic   ( RepArity )
-import GHC.Platform
-import GHC.Platform.Profile
-import GHC.Unit
-
-import GHC.Utils.Misc
-import Data.List (mapAccumL, partition)
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Constants (debugIsOn)
-import GHC.Data.FastString
-import Control.Monad
-import GHC.StgToCmm.Config (stgToCmmPlatform)
-import GHC.StgToCmm.Types
-
-------------------------------------------------------------------------
---                Call and return sequences
-------------------------------------------------------------------------
-
--- | Return multiple values to the sequel
---
--- If the sequel is @Return@
---
--- >     return (x,y)
---
--- If the sequel is @AssignTo [p,q]@
---
--- >    p=x; q=y;
---
-emitReturn :: [CmmExpr] -> FCode ReturnKind
-emitReturn results
-  = do { profile   <- getProfile
-       ; platform  <- getPlatform
-       ; sequel    <- getSequel
-       ; updfr_off <- getUpdFrameOff
-       ; case sequel of
-           Return ->
-             do { adjustHpBackwards
-                ; let e = cmmLoadGCWord platform (CmmStackSlot Old updfr_off)
-                ; emit (mkReturn profile (entryCode platform e) results updfr_off)
-                }
-           AssignTo regs adjust ->
-             do { when adjust adjustHpBackwards
-                ; emitMultiAssign  regs results }
-       ; return AssignedDirectly
-       }
-
-
--- | @emitCall conv fun args@ makes a call to the entry-code of @fun@,
--- using the call/return convention @conv@, passing @args@, and
--- returning the results to the current sequel.
---
-emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind
-emitCall convs fun args
-  = emitCallWithExtraStack convs fun args noExtraStack
-
-
--- | @emitCallWithExtraStack conv fun args stack@ makes a call to the
--- entry-code of @fun@, using the call/return convention @conv@,
--- passing @args@, pushing some extra stack frames described by
--- @stack@, and returning the results to the current sequel.
---
-emitCallWithExtraStack
-   :: (Convention, Convention) -> CmmExpr -> [CmmExpr]
-   -> [CmmExpr] -> FCode ReturnKind
-emitCallWithExtraStack (callConv, retConv) fun args extra_stack
-  = do  { profile <- getProfile
-        ; adjustHpBackwards
-        ; sequel <- getSequel
-        ; updfr_off <- getUpdFrameOff
-        ; case sequel of
-            Return -> do
-              emit $ mkJumpExtra profile callConv fun args updfr_off extra_stack
-              return AssignedDirectly
-            AssignTo res_regs _ -> do
-              k <- newBlockId
-              let area = Young k
-                  (off, _, copyin) = copyInOflow profile retConv area res_regs []
-                  copyout = mkCallReturnsTo profile fun callConv args k off updfr_off
-                                   extra_stack
-              tscope <- getTickScope
-              emit (copyout <*> mkLabel k tscope <*> copyin)
-              return (ReturnedTo k off)
-      }
-
-
-adjustHpBackwards :: FCode ()
--- This function adjusts the heap pointer just before a tail call or
--- return.  At a call or return, the virtual heap pointer may be less
--- than the real Hp, because the latter was advanced to deal with
--- the worst-case branch of the code, and we may be in a better-case
--- branch.  In that case, move the real Hp *back* and retract some
--- ticky allocation count.
---
--- It *does not* deal with high-water-mark adjustment.  That's done by
--- functions which allocate heap.
-adjustHpBackwards
-  = do  { hp_usg <- getHpUsage
-        ; let rHp = realHp hp_usg
-              vHp = virtHp hp_usg
-              adjust_words = vHp -rHp
-        ; new_hp <- getHpRelOffset vHp
-
-        ; emit (if adjust_words == 0
-                then mkNop
-                else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp
-
-        ; tickyAllocHeap False adjust_words -- ...ditto
-
-        ; setRealHp vHp
-        }
-
-
--------------------------------------------------------------------------
---        Making calls: directCall and slowCall
--------------------------------------------------------------------------
-
--- General plan is:
---   - we'll make *one* fast call, either to the function itself
---     (directCall) or to stg_ap_<pat>_fast (slowCall)
---     Any left-over arguments will be pushed on the stack,
---
---     e.g. Sp[old+8]  = arg1
---          Sp[old+16] = arg2
---          Sp[old+32] = stg_ap_pp_info
---          R2 = arg3
---          R3 = arg4
---          call f() return to Nothing updfr_off: 32
-
-
-directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind
--- (directCall f n args)
--- calls f(arg1, ..., argn), and applies the result to the remaining args
--- The function f has arity n, and there are guaranteed at least n args
--- Both arity and args include void args
-directCall conv lbl arity stg_args
-  = do  { argreps <- getArgRepsAmodes stg_args
-        ; direct_call "directCall" conv lbl arity argreps }
-
-
-slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
--- (slowCall fun args) applies fun to args, returning the results to Sequel
-slowCall fun stg_args
-  = do  cfg <- getStgToCmmConfig
-        let profile   = stgToCmmProfile      cfg
-            platform  = stgToCmmPlatform     cfg
-            ctx       = stgToCmmContext      cfg
-            fast_pap  = stgToCmmFastPAPCalls cfg
-            align_sat = stgToCmmAlignCheck   cfg
-        argsreps <- getArgRepsAmodes stg_args
-        let (rts_fun, arity) = slowCallPattern (map fst argsreps)
-
-        (r, slow_code) <- getCodeR $ do
-           r <- direct_call "slow_call" NativeNodeCall
-                 (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)
-           emitComment $ mkFastString ("slow_call for " ++
-                                      showSDocOneLine ctx (pdoc platform fun) ++
-                                      " with pat " ++ unpackFS rts_fun)
-           return r
-
-        -- See Note [avoid intermediate PAPs]
-        let n_args = length stg_args
-        if n_args > arity && fast_pap
-           then do
-             funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun
-             fun_iptr <- (CmmReg . CmmLocal) `fmap`
-               assignTemp (closureInfoPtr platform align_sat (cmmUntag platform funv))
-
-             -- ToDo: we could do slightly better here by reusing the
-             -- continuation from the slow call, which we have in r.
-             -- Also we'd like to push the continuation on the stack
-             -- before the branch, so that we only get one copy of the
-             -- code that saves all the live variables across the
-             -- call, but that might need some improvements to the
-             -- special case in the stack layout code to handle this
-             -- (see Note [diamond proc point]).
-
-             fast_code <- getCode $
-                emitCall (NativeNodeCall, NativeReturn)
-                  (entryCode platform fun_iptr)
-                  (nonVArgs ((P,Just funv):argsreps))
-
-             slow_lbl <- newBlockId
-             fast_lbl <- newBlockId
-             is_tagged_lbl <- newBlockId
-             end_lbl <- newBlockId
-
-             let correct_arity = cmmEqWord platform (funInfoArity profile fun_iptr)
-                                                    (mkIntExpr platform n_args)
-
-             tscope <- getTickScope
-             emit (mkCbranch (cmmIsTagged platform funv)
-                             is_tagged_lbl slow_lbl (Just True)
-                   <*> mkLabel is_tagged_lbl tscope
-                   <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True)
-                   <*> mkLabel fast_lbl tscope
-                   <*> fast_code
-                   <*> mkBranch end_lbl
-                   <*> mkLabel slow_lbl tscope
-                   <*> slow_code
-                   <*> mkLabel end_lbl tscope)
-             return r
-
-           else do
-             emit slow_code
-             return r
-
-
--- Note [avoid intermediate PAPs]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- A slow call which needs multiple generic apply patterns will be
--- almost guaranteed to create one or more intermediate PAPs when
--- applied to a function that takes the correct number of arguments.
--- We try to avoid this situation by generating code to test whether
--- we are calling a function with the correct number of arguments
--- first, i.e.:
---
---   if (TAG(f) != 0} {  // f is not a thunk
---      if (f->info.arity == n) {
---         ... make a fast call to f ...
---      }
---   }
---   ... otherwise make the slow call ...
---
--- We *only* do this when the call requires multiple generic apply
--- functions, which requires pushing extra stack frames and probably
--- results in intermediate PAPs.  (I say probably, because it might be
--- that we're over-applying a function, but that seems even less
--- likely).
---
--- This very rarely applies, but if it does happen in an inner loop it
--- can have a severe impact on performance (#6084).
-
-
---------------
-direct_call :: String
-            -> Convention     -- e.g. NativeNodeCall or NativeDirectCall
-            -> CLabel -> RepArity
-            -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind
-direct_call caller call_conv lbl arity args
-  | debugIsOn && args `lengthLessThan` real_arity  -- Too few args
-  = do -- Caller should ensure that there enough args!
-       platform <- getPlatform
-       pprPanic "direct_call" $
-            text caller <+> ppr arity <+>
-            pprDebugCLabel platform lbl <+> ppr (length args) <+>
-            pdoc platform (map snd args) <+> ppr (map fst args)
-
-  | null rest_args  -- Precisely the right number of arguments
-  = emitCall (call_conv, NativeReturn) target (nonVArgs args)
-
-  | otherwise       -- Note [over-saturated calls]
-  = do do_scc_prof <- stgToCmmSCCProfiling <$> getStgToCmmConfig
-       emitCallWithExtraStack (call_conv, NativeReturn)
-                              target
-                              (nonVArgs fast_args)
-                              (nonVArgs (slowArgs rest_args do_scc_prof))
-  where
-    target = CmmLit (CmmLabel lbl)
-    (fast_args, rest_args) = splitAt real_arity args
-    real_arity = case call_conv of
-                   NativeNodeCall -> arity+1
-                   _              -> arity
-
-
--- When constructing calls, it is easier to keep the ArgReps and the
--- CmmExprs zipped together.  However, a void argument has no
--- representation, so we need to use Maybe CmmExpr (the alternative of
--- using zeroCLit or even undefined would work, but would be ugly).
---
-getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
-getArgRepsAmodes args = do
-   platform <- profilePlatform <$> getProfile
-   mapM (getArgRepAmode platform) args
-  where getArgRepAmode platform arg
-           | V <- rep  = return (V, Nothing)
-           | otherwise = do expr <- getArgAmode (NonVoid arg)
-                            return (rep, Just expr)
-           where rep = toArgRep platform (argPrimRep arg)
-
-nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
-nonVArgs [] = []
-nonVArgs ((_,Nothing)  : args) = nonVArgs args
-nonVArgs ((_,Just arg) : args) = arg : nonVArgs args
-
-{-
-Note [over-saturated calls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The natural thing to do for an over-saturated call would be to call
-the function with the correct number of arguments, and then apply the
-remaining arguments to the value returned, e.g.
-
-  f a b c d   (where f has arity 2)
-  -->
-  r = call f(a,b)
-  call r(c,d)
-
-but this entails
-  - saving c and d on the stack
-  - making a continuation info table
-  - at the continuation, loading c and d off the stack into regs
-  - finally, call r
-
-Note that since there are a fixed number of different r's
-(e.g.  stg_ap_pp_fast), we can also pre-compile continuations
-that correspond to each of them, rather than generating a fresh
-one for each over-saturated call.
-
-Not only does this generate much less code, it is faster too.  We will
-generate something like:
-
-Sp[old+16] = c
-Sp[old+24] = d
-Sp[old+32] = stg_ap_pp_info
-call f(a,b) -- usual calling convention
-
-For the purposes of the CmmCall node, we count this extra stack as
-just more arguments that we are passing on the stack (cml_args).
--}
-
--- | 'slowArgs' takes a list of function arguments and prepares them for
--- pushing on the stack for "extra" arguments to a function which requires
--- fewer arguments than we currently have.
-slowArgs :: [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)]
-slowArgs []   _                    = mempty
-slowArgs args sccProfilingEnabled  -- careful: reps contains voids (V), but args does not
-  | sccProfilingEnabled = save_cccs ++ this_pat ++ slowArgs rest_args sccProfilingEnabled
-  | otherwise           =              this_pat ++ slowArgs rest_args sccProfilingEnabled
-  where
-    (arg_pat, n)            = slowCallPattern (map fst args)
-    (call_args, rest_args)  = splitAt n args
-
-    stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat
-    this_pat   = (N, Just (mkLblExpr stg_ap_pat)) : call_args
-    save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)]
-    save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")
-
--------------------------------------------------------------------------
-----        Laying out objects on the heap and stack
--------------------------------------------------------------------------
-
--- The heap always grows upwards, so hpRel is easy to compute
-hpRel :: VirtualHpOffset         -- virtual offset of Hp
-      -> VirtualHpOffset         -- virtual offset of The Thing
-      -> WordOff                -- integer word offset
-hpRel hp off = off - hp
-
-getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
--- See Note [Virtual and real heap pointers] in GHC.StgToCmm.Monad
-getHpRelOffset virtual_offset
-  = do platform <- getPlatform
-       hp_usg <- getHpUsage
-       return (cmmRegOffW platform hpReg (hpRel (realHp hp_usg) virtual_offset))
-
-data FieldOffOrPadding a
-    = FieldOff (NonVoid a) -- Something that needs an offset.
-               ByteOff     -- Offset in bytes.
-    | Padding ByteOff  -- Length of padding in bytes.
-              ByteOff  -- Offset in bytes.
-
--- | Used to tell the various @mkVirtHeapOffsets@ functions what kind
--- of header the object has.  This will be accounted for in the
--- offsets of the fields returned.
-data ClosureHeader
-  = NoHeader
-  | StdHeader
-  | ThunkHeader
-
-mkVirtHeapOffsetsWithPadding
-  :: Profile
-  -> ClosureHeader            -- What kind of header to account for
-  -> [NonVoid (PrimRep, a)]   -- Things to make offsets for
-  -> ( WordOff                -- Total number of words allocated
-     , WordOff                -- Number of words allocated for *pointers*
-     , [FieldOffOrPadding a]  -- Either an offset or padding.
-     )
-
--- Things with their offsets from start of object in order of
--- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
--- First in list gets lowest offset, which is initial offset + 1.
---
--- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets
--- than the unboxed things
-
-mkVirtHeapOffsetsWithPadding profile header things =
-    assert (not (any (isVoidRep . fst . fromNonVoid) things))
-    ( tot_wds
-    , bytesToWordsRoundUp platform bytes_of_ptrs
-    , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad
-    )
-  where
-    platform = profilePlatform profile
-    hdr_words = case header of
-      NoHeader -> 0
-      StdHeader -> fixedHdrSizeW profile
-      ThunkHeader -> thunkHdrSize profile
-    hdr_bytes = wordsToBytes platform hdr_words
-
-    (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things
-
-    (bytes_of_ptrs, ptrs_w_offsets) =
-       mapAccumL computeOffset 0 ptrs
-    (tot_bytes, non_ptrs_w_offsets) =
-       mapAccumL computeOffset bytes_of_ptrs non_ptrs
-
-    tot_wds = bytesToWordsRoundUp platform tot_bytes
-
-    final_pad_size = tot_wds * word_size - tot_bytes
-    final_pad
-        | final_pad_size > 0 = [(Padding final_pad_size
-                                         (hdr_bytes + tot_bytes))]
-        | otherwise          = []
-
-    word_size = platformWordSizeInBytes platform
-
-    computeOffset bytes_so_far nv_thing =
-        (new_bytes_so_far, with_padding field_off)
-      where
-        (rep, thing) = fromNonVoid nv_thing
-
-        -- Size of the field in bytes.
-        !sizeB = primRepSizeB platform rep
-
-        -- Align the start offset (eg, 2-byte value should be 2-byte aligned).
-        -- But not more than to a word.
-        !align = min word_size sizeB
-        !start = roundUpTo bytes_so_far align
-        !padding = start - bytes_so_far
-
-        -- Final offset is:
-        --   size of header + bytes_so_far + padding
-        !final_offset = hdr_bytes + bytes_so_far + padding
-        !new_bytes_so_far = start + sizeB
-        field_off = FieldOff (NonVoid thing) final_offset
-
-        with_padding field_off
-            | padding == 0 = [field_off]
-            | otherwise    = [ Padding padding (hdr_bytes + bytes_so_far)
-                             , field_off
-                             ]
-
-
-mkVirtHeapOffsets
-  :: Profile
-  -> ClosureHeader            -- What kind of header to account for
-  -> [NonVoid (PrimRep,a)]    -- Things to make offsets for
-  -> (WordOff,                -- _Total_ number of words allocated
-      WordOff,                -- Number of words allocated for *pointers*
-      [(NonVoid a, ByteOff)])
-mkVirtHeapOffsets profile header things =
-    ( tot_wds
-    , ptr_wds
-    , [ (field, offset) | (FieldOff field offset) <- things_offsets ]
-    )
-  where
-   (tot_wds, ptr_wds, things_offsets) =
-       mkVirtHeapOffsetsWithPadding profile header things
-
--- | Just like mkVirtHeapOffsets, but for constructors
-mkVirtConstrOffsets
-  :: Profile -> [NonVoid (PrimRep, a)]
-  -> (WordOff, WordOff, [(NonVoid a, ByteOff)])
-mkVirtConstrOffsets profile = mkVirtHeapOffsets profile StdHeader
-
--- | Just like mkVirtConstrOffsets, but used when we don't have the actual
--- arguments. Useful when e.g. generating info tables; we just need to know
--- sizes of pointer and non-pointer fields.
-mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff)
-mkVirtConstrSizes profile field_reps
-  = (tot_wds, ptr_wds)
-  where
-    (tot_wds, ptr_wds, _) =
-       mkVirtConstrOffsets profile
-         (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps)
-
--------------------------------------------------------------------------
---
---        Making argument descriptors
---
---  An argument descriptor describes the layout of args on the stack,
---  both for         * GC (stack-layout) purposes, and
---                * saving/restoring registers when a heap-check fails
---
--- Void arguments aren't important, therefore (contrast constructSlowCall)
---
--------------------------------------------------------------------------
-
--- bring in ARG_P, ARG_N, etc.
-#include "FunTypes.h"
-
-mkArgDescr :: Platform -> [Id] -> ArgDescr
-mkArgDescr platform args
-  = let arg_bits = argBits platform arg_reps
-        arg_reps = filter isNonV (map (idArgRep platform) args)
-           -- Getting rid of voids eases matching of standard patterns
-    in case stdPattern arg_reps of
-         Just spec_id -> ArgSpec spec_id
-         Nothing      -> ArgGen  arg_bits
-
-argBits :: Platform -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr
-argBits _         []           = []
-argBits platform (P   : args) = False : argBits platform args
-argBits platform (arg : args) = take (argRepSizeW platform arg) (repeat True)
-                                 ++ argBits platform args
-
-----------------------
-stdPattern :: [ArgRep] -> Maybe Int
-stdPattern reps
-  = case reps of
-        []    -> Just ARG_NONE        -- just void args, probably
-        [N]   -> Just ARG_N
-        [P]   -> Just ARG_P
-        [F]   -> Just ARG_F
-        [D]   -> Just ARG_D
-        [L]   -> Just ARG_L
-        [V16] -> Just ARG_V16
-        [V32] -> Just ARG_V32
-        [V64] -> Just ARG_V64
-
-        [N,N] -> Just ARG_NN
-        [N,P] -> Just ARG_NP
-        [P,N] -> Just ARG_PN
-        [P,P] -> Just ARG_PP
-
-        [N,N,N] -> Just ARG_NNN
-        [N,N,P] -> Just ARG_NNP
-        [N,P,N] -> Just ARG_NPN
-        [N,P,P] -> Just ARG_NPP
-        [P,N,N] -> Just ARG_PNN
-        [P,N,P] -> Just ARG_PNP
-        [P,P,N] -> Just ARG_PPN
-        [P,P,P] -> Just ARG_PPP
-
-        [P,P,P,P]     -> Just ARG_PPPP
-        [P,P,P,P,P]   -> Just ARG_PPPPP
-        [P,P,P,P,P,P] -> Just ARG_PPPPPP
-
-        _ -> Nothing
-
--------------------------------------------------------------------------
---        Amodes for arguments
--------------------------------------------------------------------------
-
-getArgAmode :: NonVoid StgArg -> FCode CmmExpr
-getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var
-getArgAmode (NonVoid (StgLitArg lit)) = cgLit lit
-
-getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
--- NB: Filters out void args,
---     so the result list may be shorter than the argument list
-getNonVoidArgAmodes [] = return []
-getNonVoidArgAmodes (arg:args)
-  | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
-  | otherwise = do { amode  <- getArgAmode (NonVoid arg)
-                   ; amodes <- getNonVoidArgAmodes args
-                   ; return ( amode : amodes ) }
-
--------------------------------------------------------------------------
---
---        Generating the info table and code for a closure
---
--------------------------------------------------------------------------
-
--- Here we make an info table of type 'CmmInfo'.  The concrete
--- representation as a list of 'CmmAddr' is handled later
--- in the pipeline by 'cmmToRawCmm'.
--- When loading the free variables, a function closure pointer may be tagged,
--- so we must take it into account.
-
-emitClosureProcAndInfoTable :: Bool                    -- top-level?
-                            -> Id                      -- name of the closure
-                            -> LambdaFormInfo
-                            -> CmmInfoTable
-                            -> [NonVoid Id]            -- incoming arguments
-                            -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body
-                            -> FCode ()
-emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
- = do   { profile <- getProfile
-        ; platform <- getPlatform
-        -- Bind the binder itself, but only if it's not a top-level
-        -- binding. We need non-top let-bindings to refer to the
-        -- top-level binding, which this binding would incorrectly shadow.
-        ; node <- if top_lvl then return $ idToReg platform (NonVoid bndr)
-                  else bindToReg (NonVoid bndr) lf_info
-        ; let node_points = nodeMustPointToIt profile lf_info
-        ; arg_regs <- bindArgsToRegs args
-        ; let args' = if node_points then (node : arg_regs) else arg_regs
-              conv  = if nodeMustPointToIt profile lf_info then NativeNodeCall
-                                                          else NativeDirectCall
-              (offset, _, _) = mkCallEntry profile conv args' []
-        ; emitClosureAndInfoTable (profilePlatform profile) info_tbl conv args' $ body (offset, node, arg_regs)
-        }
-
--- Data constructors need closures, but not with all the argument handling
--- needed for functions. The shared part goes here.
-emitClosureAndInfoTable
-   :: Platform -> CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
-emitClosureAndInfoTable platform info_tbl conv args body
-  = do { (_, blks) <- getCodeScoped body
-       ; let entry_lbl = toEntryLbl platform (cit_lbl info_tbl)
-       ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
-       }
diff --git a/compiler/GHC/StgToCmm/Lit.hs b/compiler/GHC/StgToCmm/Lit.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Lit.hs
+++ /dev/null
@@ -1,107 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
------------------------------------------------------------------------------
---
--- Stg to C-- code generation: literals
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.Lit (
-    cgLit, mkSimpleLit,
-    newStringCLit, newByteStringCLit
-  ) where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Env
-import GHC.Cmm
-import GHC.Cmm.CLabel
-import GHC.Cmm.Utils
-
-import GHC.Types.Literal
-import GHC.Types.RepType( runtimeRepPrimRep )
-import GHC.Builtin.Types ( unitDataConId )
-import GHC.Core.TyCon
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as BS8
-import Data.Char (ord)
-
-newStringCLit :: String -> FCode CmmLit
--- ^ Make a global definition for the string,
--- and return its label
-newStringCLit str = newByteStringCLit (BS8.pack str)
-
-newByteStringCLit :: ByteString -> FCode CmmLit
-newByteStringCLit bytes
-  = do  { uniq <- newUnique
-        ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes
-        ; emitDecl decl
-        ; return lit }
-
-cgLit :: Literal -> FCode CmmExpr
-cgLit (LitString s) =
-  CmmLit <$> newByteStringCLit s
- -- not unpackFS; we want the UTF-8 byte stream.
-cgLit (LitRubbish _ rep) =
-  case expectOnly "cgLit" prim_reps of -- Note [Post-unarisation invariants]
-    VoidRep     -> panic "cgLit:VoidRep"   -- ditto
-    LiftedRep   -> idInfoToAmode <$> getCgIdInfo unitDataConId
-    UnliftedRep -> idInfoToAmode <$> getCgIdInfo unitDataConId
-    AddrRep     -> cgLit LitNullAddr
-    VecRep n elem -> do
-      platform <- getPlatform
-      let elem_lit = mkSimpleLit platform (num_rep_lit (primElemRepToPrimRep elem))
-      pure (CmmLit (CmmVec (replicate n elem_lit)))
-    prep        -> cgLit (num_rep_lit prep)
-  where
-      prim_reps = runtimeRepPrimRep (text "cgLit") rep
-
-      num_rep_lit IntRep    = mkLitIntUnchecked 0
-      num_rep_lit Int8Rep   = mkLitInt8Unchecked 0
-      num_rep_lit Int16Rep  = mkLitInt16Unchecked 0
-      num_rep_lit Int32Rep  = mkLitInt32Unchecked 0
-      num_rep_lit Int64Rep  = mkLitInt64Unchecked 0
-      num_rep_lit WordRep   = mkLitWordUnchecked 0
-      num_rep_lit Word8Rep  = mkLitWord8Unchecked 0
-      num_rep_lit Word16Rep = mkLitWord16Unchecked 0
-      num_rep_lit Word32Rep = mkLitWord32Unchecked 0
-      num_rep_lit Word64Rep = mkLitWord64Unchecked 0
-      num_rep_lit FloatRep  = LitFloat 0
-      num_rep_lit DoubleRep = LitDouble 0
-      num_rep_lit other     = pprPanic "num_rep_lit: Not a num lit" (ppr other)
-
-cgLit other_lit = do
-  platform <- getPlatform
-  pure (CmmLit (mkSimpleLit platform other_lit))
-
-mkSimpleLit :: Platform -> Literal -> CmmLit
-mkSimpleLit platform = \case
-   (LitChar   c)                -> CmmInt (fromIntegral (ord c))
-                                          (wordWidth platform)
-   LitNullAddr                  -> zeroCLit platform
-   (LitNumber LitNumInt i)      -> CmmInt i (wordWidth platform)
-   (LitNumber LitNumInt8 i)     -> CmmInt i W8
-   (LitNumber LitNumInt16 i)    -> CmmInt i W16
-   (LitNumber LitNumInt32 i)    -> CmmInt i W32
-   (LitNumber LitNumInt64 i)    -> CmmInt i W64
-   (LitNumber LitNumWord i)     -> CmmInt i (wordWidth platform)
-   (LitNumber LitNumWord8 i)    -> CmmInt i W8
-   (LitNumber LitNumWord16 i)   -> CmmInt i W16
-   (LitNumber LitNumWord32 i)   -> CmmInt i W32
-   (LitNumber LitNumWord64 i)   -> CmmInt i W64
-   (LitFloat r)                 -> CmmFloat r W32
-   (LitDouble r)                -> CmmFloat r W64
-   (LitLabel fs ms fod)
-     -> let -- TODO: Literal labels might not actually be in the current package...
-            labelSrc = ForeignLabelInThisPackage
-        in CmmLabel (mkForeignLabel fs ms labelSrc fod)
-   other -> pprPanic "mkSimpleLit" (ppr other)
-
diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Monad.hs
+++ /dev/null
@@ -1,878 +0,0 @@
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternSynonyms #-}
-
------------------------------------------------------------------------------
---
--- Monad for Stg to C-- code generation
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.Monad (
-        FCode,        -- type
-
-        initC, initFCodeState, runC, fixC,
-        newUnique,
-
-        emitLabel,
-
-        emit, emitDecl,
-        emitProcWithConvention, emitProcWithStackFrame,
-        emitOutOfLine, emitAssign, emitStore, emitStore',
-        emitComment, emitTick, emitUnwind,
-
-        newTemp,
-
-        getCmm, aGraphToGraph, getPlatform, getProfile,
-        getCodeR, getCode, getCodeScoped, getHeapUsage,
-        getContext,
-
-        mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
-        mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',
-
-        mkCall, mkCmmCall,
-
-        forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,
-
-        ConTagZ,
-
-        Sequel(..), ReturnKind(..),
-        withSequel, getSequel,
-
-        setTickyCtrLabel, getTickyCtrLabel,
-        tickScope, getTickScope,
-
-        withUpdFrameOff, getUpdFrameOff,
-
-        HeapUsage(..), VirtualHpOffset,        initHpUsage,
-        getHpUsage,  setHpUsage, heapHWM,
-        setVirtHp, getVirtHp, setRealHp,
-
-        getModuleName,
-
-        -- ideally we wouldn't export these, but some other modules access internal state
-        getState, setState, getSelfLoop, withSelfLoop, getStgToCmmConfig,
-
-        -- more localised access to monad state
-        CgIdInfo(..),
-        getBinds, setBinds,
-        -- out of general friendliness, we also export ...
-        StgToCmmConfig(..), CgState(..) -- non-abstract
-    ) where
-
-import GHC.Prelude hiding( sequence, succ )
-
-import GHC.Platform
-import GHC.Platform.Profile
-import GHC.Cmm
-import GHC.StgToCmm.Config
-import GHC.StgToCmm.Closure
-import GHC.StgToCmm.Sequel
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Graph as CmmGraph
-import GHC.Cmm.BlockId
-import GHC.Cmm.CLabel
-import GHC.Runtime.Heap.Layout
-import GHC.Unit
-import GHC.Types.Id
-import GHC.Types.Var.Env
-import GHC.Data.OrdList
-import GHC.Types.Basic( ConTagZ )
-import GHC.Types.Unique
-import GHC.Types.Unique.Supply
-import GHC.Data.FastString
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Constants (debugIsOn)
-import GHC.Exts (oneShot)
-
-import Control.Monad
-import Data.List (mapAccumL)
-
-
---------------------------------------------------------
--- The FCode monad and its types
---
--- FCode is the monad plumbed through the Stg->Cmm code generator, and
--- the Cmm parser.  It contains the following things:
---
---  - A writer monad, collecting:
---    - code for the current function, in the form of a CmmAGraph.
---      The function "emit" appends more code to this.
---    - the top-level CmmDecls accumulated so far
---
---  - A state monad with:
---    - the local bindings in scope
---    - the current heap usage
---    - a UniqSupply
---
---  - A reader monad, for StgToCmmConfig, containing
---    - the profile,
---    - the current Module
---    - the debug level
---    - a bunch of flags see StgToCmm.Config for full details
-
---  - A second reader monad with:
---    - the update-frame offset
---    - the ticky counter label
---    - the Sequel (the continuation to return to)
---    - the self-recursive tail call information
---    - The tick scope for new blocks and ticks
---
-
---------------------------------------------------------
-
-newtype FCode a = FCode' { doFCode :: StgToCmmConfig -> FCodeState -> CgState -> (a, CgState) }
-
--- Not derived because of #18202.
--- See Note [The one-shot state monad trick] in GHC.Utils.Monad
-instance Functor FCode where
-  fmap f (FCode m) =
-    FCode $ \cfg fst state ->
-      case m cfg fst state of
-        (x, state') -> (f x, state')
-
--- This pattern synonym makes the simplifier monad eta-expand,
--- which as a very beneficial effect on compiler performance
--- See #18202.
--- See Note [The one-shot state monad trick] in GHC.Utils.Monad
-{-# COMPLETE FCode #-}
-pattern FCode :: (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-              -> FCode a
-pattern FCode m <- FCode' m
-  where
-    FCode m = FCode' $ oneShot (\cfg -> oneShot
-                                 (\fstate -> oneShot
-                                   (\state -> m cfg fstate state)))
-
-instance Applicative FCode where
-    pure val = FCode (\_cfg _fstate state -> (val, state))
-    {-# INLINE pure #-}
-    (<*>) = ap
-
-instance Monad FCode where
-    FCode m >>= k = FCode $
-        \cfg fstate state ->
-            case m cfg fstate state of
-              (m_result, new_state) ->
-                 case k m_result of
-                   FCode kcode -> kcode cfg fstate new_state
-    {-# INLINE (>>=) #-}
-
-instance MonadUnique FCode where
-  getUniqueSupplyM = cgs_uniqs <$> getState
-  getUniqueM = FCode $ \_ _ st ->
-    let (u, us') = takeUniqFromSupply (cgs_uniqs st)
-    in (u, st { cgs_uniqs = us' })
-
-initC :: IO CgState
-initC  = do { uniqs <- mkSplitUniqSupply 'c'
-            ; return (initCgState uniqs) }
-
-runC :: StgToCmmConfig -> FCodeState -> CgState -> FCode a -> (a, CgState)
-runC cfg fst st fcode = doFCode fcode cfg fst st
-
-fixC :: (a -> FCode a) -> FCode a
-fixC fcode = FCode $
-    \cfg fstate state ->
-      let (v, s) = doFCode (fcode v) cfg fstate state
-      in (v, s)
-
---------------------------------------------------------
---        The code generator environment
---------------------------------------------------------
-type CgBindings = IdEnv CgIdInfo
-
-data CgIdInfo
-  = CgIdInfo
-        { cg_id :: Id   -- Id that this is the info for
-        , cg_lf  :: LambdaFormInfo
-        , cg_loc :: CgLoc                     -- CmmExpr for the *tagged* value
-        }
-
-instance OutputableP Platform CgIdInfo where
-  pdoc env (CgIdInfo { cg_id = id, cg_loc = loc })
-    = ppr id <+> text "-->" <+> pdoc env loc
-
--- See Note [sharing continuations] below
-data ReturnKind
-  = AssignedDirectly
-  | ReturnedTo BlockId ByteOff
-
--- Note [sharing continuations]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- ReturnKind says how the expression being compiled returned its
--- results: either by assigning directly to the registers specified
--- by the Sequel, or by returning to a continuation that does the
--- assignments.  The point of this is we might be able to re-use the
--- continuation in a subsequent heap-check.  Consider:
---
---    case f x of z
---      True  -> <True code>
---      False -> <False code>
---
--- Naively we would generate
---
---    R2 = x   -- argument to f
---    Sp[young(L1)] = L1
---    call f returns to L1
---  L1:
---    z = R1
---    if (z & 1) then Ltrue else Lfalse
---  Ltrue:
---    Hp = Hp + 24
---    if (Hp > HpLim) then L4 else L7
---  L4:
---    HpAlloc = 24
---    goto L5
---  L5:
---    R1 = z
---    Sp[young(L6)] = L6
---    call stg_gc_unpt_r1 returns to L6
---  L6:
---    z = R1
---    goto L1
---  L7:
---    <True code>
---  Lfalse:
---    <False code>
---
--- We want the gc call in L4 to return to L1, and discard L6.  Note
--- that not only can we share L1 and L6, but the assignment of the
--- return address in L4 is unnecessary because the return address for
--- L1 is already on the stack.  We used to catch the sharing of L1 and
--- L6 in the common-block-eliminator, but not the unnecessary return
--- address assignment.
---
--- Since this case is so common I decided to make it more explicit and
--- robust by programming the sharing directly, rather than relying on
--- the common-block eliminator to catch it.  This makes
--- common-block-elimination an optional optimisation, and furthermore
--- generates less code in the first place that we have to subsequently
--- clean up.
---
--- There are some rarer cases of common blocks that we don't catch
--- this way, but that's ok.  Common-block-elimination is still available
--- to catch them when optimisation is enabled.  Some examples are:
---
---   - when both the True and False branches do a heap check, we
---     can share the heap-check failure code L4a and maybe L4
---
---   - in a case-of-case, there might be multiple continuations that
---     we can common up.
---
--- It is always safe to use AssignedDirectly.  Expressions that jump
--- to the continuation from multiple places (e.g. case expressions)
--- fall back to AssignedDirectly.
---
-
---------------------------------------------------------
---        The code generator state
---------------------------------------------------------
-
-data CgState
-  = MkCgState {
-     cgs_stmts :: CmmAGraph,          -- Current procedure
-
-     cgs_tops  :: OrdList CmmDecl,
-        -- Other procedures and data blocks in this compilation unit
-        -- Both are ordered only so that we can
-        -- reduce forward references, when it's easy to do so
-
-     cgs_binds :: CgBindings,
-
-     cgs_hp_usg  :: HeapUsage,
-
-     cgs_uniqs :: UniqSupply }
--- If you are wondering why you have to be careful forcing CgState then
--- the reason is the knot-tying in 'getHeapUsage'. This problem is tracked
--- in #19245
-
-data FCodeState =
-  MkFCodeState { fcs_upframeoffset :: UpdFrameOffset     -- ^ Size of current update frame UpdFrameOffset must be kept lazy or
-                                                         -- else the RTS will deadlock _and_ also experience a severe
-                                                         -- performance degradation
-              , fcs_sequel        :: !Sequel             -- ^ What to do at end of basic block
-              , fcs_selfloop      :: Maybe SelfLoopInfo  -- ^ Which tail calls can be compiled as local jumps?
-                                                         --   See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr
-              , fcs_ticky         :: !CLabel             -- ^ Destination for ticky counts
-              , fcs_tickscope     :: !CmmTickScope       -- ^ Tick scope for new blocks & ticks
-              }
-
-data HeapUsage   -- See Note [Virtual and real heap pointers]
-  = HeapUsage {
-        virtHp :: VirtualHpOffset,       -- Virtual offset of highest-allocated word
-                                         --   Incremented whenever we allocate
-        realHp :: VirtualHpOffset        -- realHp: Virtual offset of real heap ptr
-                                         --   Used in instruction addressing modes
-    }
-
-type VirtualHpOffset = WordOff
-
-
-{- Note [Virtual and real heap pointers]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The code generator can allocate one or more objects contiguously, performing
-one heap check to cover allocation of all the objects at once.  Let's call
-this little chunk of heap space an "allocation chunk".  The code generator
-will emit code to
-  * Perform a heap-exhaustion check
-  * Move the heap pointer to the end of the allocation chunk
-  * Allocate multiple objects within the chunk
-
-The code generator uses VirtualHpOffsets to address words within a
-single allocation chunk; these start at one and increase positively.
-The first word of the chunk has VirtualHpOffset=1, the second has
-VirtualHpOffset=2, and so on.
-
- * The field realHp tracks (the VirtualHpOffset) where the real Hp
-   register is pointing.  Typically it'll be pointing to the end of the
-   allocation chunk.
-
- * The field virtHp gives the VirtualHpOffset of the highest-allocated
-   word so far.  It starts at zero (meaning no word has been allocated),
-   and increases whenever an object is allocated.
-
-The difference between realHp and virtHp gives the offset from the
-real Hp register of a particular word in the allocation chunk. This
-is what getHpRelOffset does.  Since the returned offset is relative
-to the real Hp register, it is valid only until you change the real
-Hp register.  (Changing virtHp doesn't matter.)
--}
-
-
-initCgState :: UniqSupply -> CgState
-initCgState uniqs
-  = MkCgState { cgs_stmts  = mkNop
-              , cgs_tops   = nilOL
-              , cgs_binds  = emptyVarEnv
-              , cgs_hp_usg = initHpUsage
-              , cgs_uniqs  = uniqs }
-
-stateIncUsage :: CgState -> CgState -> CgState
--- stateIncUsage@ e1 e2 incorporates in e1
--- the heap high water mark found in e2.
-stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })
-     = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg }
-       `addCodeBlocksFrom` s2
-
-addCodeBlocksFrom :: CgState -> CgState -> CgState
--- Add code blocks from the latter to the former
--- (The cgs_stmts will often be empty, but not always; see codeOnly)
-s1 `addCodeBlocksFrom` s2
-  = s1 { cgs_stmts = cgs_stmts s1 CmmGraph.<*> cgs_stmts s2,
-         cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }
-
--- The heap high water mark is the larger of virtHp and hwHp.  The latter is
--- only records the high water marks of forked-off branches, so to find the
--- heap high water mark you have to take the max of virtHp and hwHp.  Remember,
--- virtHp never retreats!
---
--- Note Jan 04: ok, so why do we only look at the virtual Hp??
-
-heapHWM :: HeapUsage -> VirtualHpOffset
-heapHWM = virtHp
-
-initHpUsage :: HeapUsage
-initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }
-
-maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
-hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
-
---------------------------------------------------------
--- Operators for getting and setting the state and "stgToCmmConfig".
---------------------------------------------------------
-
-getState :: FCode CgState
-getState = FCode $ \_cfg _fstate state -> (state, state)
-
-setState :: CgState -> FCode ()
-setState state = FCode $ \_cfg _fstate _ -> ((), state)
-
-getHpUsage :: FCode HeapUsage
-getHpUsage = do
-        state <- getState
-        return $ cgs_hp_usg state
-
-setHpUsage :: HeapUsage -> FCode ()
-setHpUsage new_hp_usg = do
-        state <- getState
-        setState $ state {cgs_hp_usg = new_hp_usg}
-
-setVirtHp :: VirtualHpOffset -> FCode ()
-setVirtHp new_virtHp
-  = do  { hp_usage <- getHpUsage
-        ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
-
-getVirtHp :: FCode VirtualHpOffset
-getVirtHp
-  = do  { hp_usage <- getHpUsage
-        ; return (virtHp hp_usage) }
-
-setRealHp ::  VirtualHpOffset -> FCode ()
-setRealHp new_realHp
-  = do  { hp_usage <- getHpUsage
-        ; setHpUsage (hp_usage {realHp = new_realHp}) }
-
-getBinds :: FCode CgBindings
-getBinds = do
-        state <- getState
-        return $ cgs_binds state
-
-setBinds :: CgBindings -> FCode ()
-setBinds new_binds = do
-        state <- getState
-        setState $ state {cgs_binds = new_binds}
-
-withCgState :: FCode a -> CgState -> FCode (a,CgState)
-withCgState (FCode fcode) newstate = FCode $ \cfg fstate state ->
-  case fcode cfg fstate newstate of
-    (retval, state2) -> ((retval,state2), state)
-
-newUniqSupply :: FCode UniqSupply
-newUniqSupply = do
-        state <- getState
-        let (us1, us2) = splitUniqSupply (cgs_uniqs state)
-        setState $ state { cgs_uniqs = us1 }
-        return us2
-
-newUnique :: FCode Unique
-newUnique = do
-        state <- getState
-        let (u,us') = takeUniqFromSupply (cgs_uniqs state)
-        setState $ state { cgs_uniqs = us' }
-        return u
-
-newTemp :: MonadUnique m => CmmType -> m LocalReg
-newTemp rep = do { uniq <- getUniqueM
-                 ; return (LocalReg uniq rep) }
-
-------------------
-initFCodeState :: Platform -> FCodeState
-initFCodeState p =
-  MkFCodeState { fcs_upframeoffset = platformWordSizeInBytes p
-               , fcs_sequel        = Return
-               , fcs_selfloop      = Nothing
-               , fcs_ticky         = mkTopTickyCtrLabel
-               , fcs_tickscope     = GlobalScope
-               }
-
-getFCodeState :: FCode FCodeState
-getFCodeState = FCode $ \_ fstate state -> (fstate,state)
-
--- basically local for the reader monad
-withFCodeState :: FCode a -> FCodeState -> FCode a
-withFCodeState (FCode fcode) fst = FCode $ \cfg _ state -> fcode cfg fst state
-
-getSelfLoop :: FCode (Maybe SelfLoopInfo)
-getSelfLoop = fcs_selfloop <$> getFCodeState
-
-withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a
-withSelfLoop self_loop code = do
-        fstate <- getFCodeState
-        withFCodeState code (fstate {fcs_selfloop = Just self_loop})
-
--- ----------------------------------------------------------------------------
--- Get/set the end-of-block info
-
-withSequel :: Sequel -> FCode a -> FCode a
-withSequel sequel code
-  = do  { fstate <- getFCodeState
-        ; withFCodeState code (fstate { fcs_sequel = sequel
-                                      , fcs_selfloop = Nothing }) }
-
-getSequel :: FCode Sequel
-getSequel = fcs_sequel <$> getFCodeState
-
--- ----------------------------------------------------------------------------
--- Get/set the size of the update frame
-
--- We keep track of the size of the update frame so that we
--- can set the stack pointer to the proper address on return
--- (or tail call) from the closure.
--- There should be at most one update frame for each closure.
--- Note: I'm including the size of the original return address
--- in the size of the update frame -- hence the default case on `get'.
-
-withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a
-withUpdFrameOff size code
-  = do  { fstate <- getFCodeState
-        ; withFCodeState code (fstate {fcs_upframeoffset = size }) }
-
-getUpdFrameOff :: FCode UpdFrameOffset
-getUpdFrameOff = fcs_upframeoffset <$> getFCodeState
-
--- ----------------------------------------------------------------------------
--- Get/set the current ticky counter label
-
-getTickyCtrLabel :: FCode CLabel
-getTickyCtrLabel = fcs_ticky <$> getFCodeState
-
-setTickyCtrLabel :: CLabel -> FCode a -> FCode a
-setTickyCtrLabel ticky code = do
-        fstate <- getFCodeState
-        withFCodeState code (fstate {fcs_ticky = ticky})
-
--- ----------------------------------------------------------------------------
--- Manage tick scopes
-
--- | The current tick scope. We will assign this to generated blocks.
-getTickScope :: FCode CmmTickScope
-getTickScope = fcs_tickscope <$> getFCodeState
-
--- | Places blocks generated by the given code into a fresh
--- (sub-)scope. This will make sure that Cmm annotations in our scope
--- will apply to the Cmm blocks generated therein - but not the other
--- way around.
-tickScope :: FCode a -> FCode a
-tickScope code = do
-        cfg <- getStgToCmmConfig
-        fstate <- getFCodeState
-        if not $ stgToCmmEmitDebugInfo cfg then code else do
-          u <- newUnique
-          let scope' = SubScope u (fcs_tickscope fstate)
-          withFCodeState code fstate{ fcs_tickscope = scope' }
-
--- ----------------------------------------------------------------------------
--- Config related helpers
-
-getStgToCmmConfig :: FCode StgToCmmConfig
-getStgToCmmConfig = FCode $ \cfg _ state -> (cfg,state)
-
-getProfile :: FCode Profile
-getProfile = stgToCmmProfile <$> getStgToCmmConfig
-
-getPlatform :: FCode Platform
-getPlatform = profilePlatform <$> getProfile
-
-getContext :: FCode SDocContext
-getContext = stgToCmmContext <$> getStgToCmmConfig
-
--- ----------------------------------------------------------------------------
--- Get the current module name
-
-getModuleName :: FCode Module
-getModuleName = stgToCmmThisModule <$> getStgToCmmConfig
-
-
---------------------------------------------------------
---                 Forking
---------------------------------------------------------
-
-forkClosureBody :: FCode () -> FCode ()
--- forkClosureBody compiles body_code in environment where:
---   - sequel, update stack frame and self loop info are
---     set to fresh values
---   - state is set to a fresh value, except for local bindings
---     that are passed in unchanged. It's up to the enclosed code to
---     re-bind the free variables to a field of the closure.
-
-forkClosureBody body_code
-  = do  { platform <- getPlatform
-        ; cfg      <- getStgToCmmConfig
-        ; fstate   <- getFCodeState
-        ; us       <- newUniqSupply
-        ; state    <- getState
-        ; let fcs = fstate { fcs_sequel        = Return
-                           , fcs_upframeoffset = platformWordSizeInBytes platform
-                           , fcs_selfloop      = Nothing
-                           }
-              fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
-              ((),fork_state_out) = doFCode body_code cfg fcs fork_state_in
-        ; setState $ state `addCodeBlocksFrom` fork_state_out }
-
-forkLneBody :: FCode a -> FCode a
--- 'forkLneBody' takes a body of let-no-escape binding and compiles
--- it in the *current* environment, returning the graph thus constructed.
---
--- The current environment is passed on completely unchanged to
--- the successor.  In particular, any heap usage from the enclosed
--- code is discarded; it should deal with its own heap consumption.
-forkLneBody body_code
-  = do  { cfg   <- getStgToCmmConfig
-        ; us    <- newUniqSupply
-        ; state <- getState
-        ; fstate <- getFCodeState
-        ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
-              (result, fork_state_out) = doFCode body_code cfg fstate fork_state_in
-        ; setState $ state `addCodeBlocksFrom` fork_state_out
-        ; return result }
-
-codeOnly :: FCode () -> FCode ()
--- Emit any code from the inner thing into the outer thing
--- Do not affect anything else in the outer state
--- Used in almost-circular code to prevent false loop dependencies
-codeOnly body_code
-  = do  { cfg   <- getStgToCmmConfig
-        ; us    <- newUniqSupply
-        ; state <- getState
-        ; fstate <- getFCodeState
-        ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state
-                                                 , cgs_hp_usg  = cgs_hp_usg state }
-                ((), fork_state_out) = doFCode body_code cfg fstate fork_state_in
-        ; setState $ state `addCodeBlocksFrom` fork_state_out }
-
-forkAlts :: [FCode a] -> FCode [a]
--- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and
--- an fcode for the default case 'd', and compiles each in the current
--- environment.  The current environment is passed on unmodified, except
--- that the virtual Hp is moved on to the worst virtual Hp for the branches
-
-forkAlts branch_fcodes
-  = do  { cfg   <- getStgToCmmConfig
-        ; us    <- newUniqSupply
-        ; state <- getState
-        ; fstate <- getFCodeState
-        ; let compile us branch
-                = (us2, doFCode branch cfg fstate branch_state)
-                where
-                  (us1,us2) = splitUniqSupply us
-                  branch_state = (initCgState us1) {
-                                        cgs_binds  = cgs_binds state
-                                      , cgs_hp_usg = cgs_hp_usg state }
-              (_us, results) = mapAccumL compile us branch_fcodes
-              (branch_results, branch_out_states) = unzip results
-        ; setState $ foldl' stateIncUsage state branch_out_states
-                -- NB foldl.  state is the *left* argument to stateIncUsage
-        ; return branch_results }
-
-forkAltPair :: FCode a -> FCode a -> FCode (a,a)
--- Most common use of 'forkAlts'; having this helper function avoids
--- accidental use of failible pattern-matches in @do@-notation
-forkAltPair x y = do
-  xy' <- forkAlts [x,y]
-  case xy' of
-    [x',y'] -> return (x',y')
-    _ -> panic "forkAltPair"
-
--- collect the code emitted by an FCode computation
-getCodeR :: FCode a -> FCode (a, CmmAGraph)
-getCodeR fcode
-  = do  { state1 <- getState
-        ; (a, state2) <- withCgState fcode (state1 { cgs_stmts = mkNop })
-        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
-        ; return (a, cgs_stmts state2) }
-
-getCode :: FCode a -> FCode CmmAGraph
-getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }
-
--- | Generate code into a fresh tick (sub-)scope and gather generated code
-getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped)
-getCodeScoped fcode
-  = do  { state1 <- getState
-        ; ((a, tscope), state2) <-
-            tickScope $
-            flip withCgState state1 { cgs_stmts = mkNop } $
-            do { a   <- fcode
-               ; scp <- getTickScope
-               ; return (a, scp) }
-        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
-        ; return (a, (cgs_stmts state2, tscope)) }
-
-
--- 'getHeapUsage' applies a function to the amount of heap that it uses.
--- It initialises the heap usage to zeros, and passes on an unchanged
--- heap usage.
---
--- It is usually a prelude to performing a GC check, so everything must
--- be in a tidy and consistent state.
---
--- Note the slightly subtle fixed point behaviour needed here
-
-getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a
-getHeapUsage fcode
-  = do  { cfg <- getStgToCmmConfig
-        ; state <- getState
-        ; fcstate <- getFCodeState
-        ; let   fstate_in = state { cgs_hp_usg  = initHpUsage }
-                (r, fstate_out) = doFCode (fcode hp_hw) cfg fcstate fstate_in
-                hp_hw = heapHWM (cgs_hp_usg fstate_out)        -- Loop here!
-
-        ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
-        ; return r }
-
--- ----------------------------------------------------------------------------
--- Combinators for emitting code
-
-emitCgStmt :: CgStmt -> FCode ()
-emitCgStmt stmt
-  = do  { state <- getState
-        ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
-        }
-
-emitLabel :: BlockId -> FCode ()
-emitLabel id = do tscope <- getTickScope
-                  emitCgStmt (CgLabel id tscope)
-
-emitComment :: FastString -> FCode ()
-emitComment s
-  | debugIsOn = emitCgStmt (CgStmt (CmmComment s))
-  | otherwise = return ()
-
-emitTick :: CmmTickish -> FCode ()
-emitTick = emitCgStmt . CgStmt . CmmTick
-
-emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode ()
-emitUnwind regs = do
-  debug <- stgToCmmEmitDebugInfo <$> getStgToCmmConfig
-  when debug $
-     emitCgStmt $ CgStmt $ CmmUnwind regs
-
-emitAssign :: CmmReg  -> CmmExpr -> FCode ()
-emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
-
--- | Assumes natural alignment.
-emitStore :: CmmExpr -> CmmExpr -> FCode ()
-emitStore = emitStore' NaturallyAligned
-
-emitStore' :: AlignmentSpec -> CmmExpr -> CmmExpr -> FCode ()
-emitStore' alignment l r = emitCgStmt (CgStmt (CmmStore l r alignment))
-
-emit :: CmmAGraph -> FCode ()
-emit ag
-  = do  { state <- getState
-        ; setState $ state { cgs_stmts = cgs_stmts state CmmGraph.<*> ag } }
-
-emitDecl :: CmmDecl -> FCode ()
-emitDecl decl
-  = do  { state <- getState
-        ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
-
-emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()
-emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope)
-
-emitProcWithStackFrame
-   :: Convention                        -- entry convention
-   -> Maybe CmmInfoTable                -- info table?
-   -> CLabel                            -- label for the proc
-   -> [CmmFormal]                       -- stack frame
-   -> [CmmFormal]                       -- arguments
-   -> CmmAGraphScoped                   -- code
-   -> Bool                              -- do stack layout?
-   -> FCode ()
-
-emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
-  = do  { platform <- getPlatform
-        ; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth platform)) False
-        }
-emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True
-        -- do layout
-  = do  { profile <- getProfile
-        ; let (offset, live, entry) = mkCallEntry profile conv args stk_args
-              graph' = entry CmmGraph.<*> graph
-        ; emitProc mb_info lbl live (graph', tscope) offset True
-        }
-emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"
-
-emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
-                       -> [CmmFormal]
-                       -> CmmAGraphScoped
-                       -> FCode ()
-emitProcWithConvention conv mb_info lbl args blocks
-  = emitProcWithStackFrame conv mb_info lbl [] args blocks True
-
-emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
-         -> Int -> Bool -> FCode ()
-emitProc mb_info lbl live blocks offset do_layout
-  = do  { l <- newBlockId
-        ; let
-              blks :: CmmGraph
-              blks = labelAGraph l blocks
-
-              infos | Just info <- mb_info = mapSingleton (g_entry blks) info
-                    | otherwise            = mapEmpty
-
-              sinfo = StackInfo { arg_space = offset
-                                , do_layout = do_layout }
-
-              tinfo = TopInfo { info_tbls = infos
-                              , stack_info=sinfo}
-
-              proc_block = CmmProc tinfo lbl live blks
-
-        ; state <- getState
-        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
-
-getCmm :: FCode a -> FCode (a, CmmGroup)
--- Get all the CmmTops (there should be no stmts)
--- Return a single Cmm which may be split from other Cmms by
--- object splitting (at a later stage)
-getCmm code
-  = do  { state1 <- getState
-        ; (a, state2) <- withCgState code (state1 { cgs_tops  = nilOL })
-        ; setState $ state2 { cgs_tops = cgs_tops state1 }
-        ; return (a, fromOL (cgs_tops state2)) }
-
-
-mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
-mkCmmIfThenElse e tbranch fbranch = mkCmmIfThenElse' e tbranch fbranch Nothing
-
-mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph
-                 -> Maybe Bool -> FCode CmmAGraph
-mkCmmIfThenElse' e tbranch fbranch likely = do
-  tscp  <- getTickScope
-  endif <- newBlockId
-  tid   <- newBlockId
-  fid   <- newBlockId
-
-  let
-    (test, then_, else_, likely') = case likely of
-      Just False | Just e' <- maybeInvertCmmExpr e
-        -- currently NCG doesn't know about likely
-        -- annotations. We manually switch then and
-        -- else branch so the likely false branch
-        -- becomes a fallthrough.
-        -> (e', fbranch, tbranch, Just True)
-      _ -> (e, tbranch, fbranch, likely)
-
-  return $ catAGraphs [ mkCbranch test tid fid likely'
-                      , mkLabel tid tscp, then_, mkBranch endif
-                      , mkLabel fid tscp, else_, mkLabel endif tscp ]
-
-mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph
-mkCmmIfGoto e tid = mkCmmIfGoto' e tid Nothing
-
-mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph
-mkCmmIfGoto' e tid l = do
-  endif <- newBlockId
-  tscp  <- getTickScope
-  return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ]
-
-mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph
-mkCmmIfThen e tbranch = mkCmmIfThen' e tbranch Nothing
-
-mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
-mkCmmIfThen' e tbranch l = do
-  endif <- newBlockId
-  tid   <- newBlockId
-  tscp  <- getTickScope
-  return $ catAGraphs [ mkCbranch e tid endif l
-                      , mkLabel tid tscp, tbranch, mkLabel endif tscp ]
-
-mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr]
-       -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph
-mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
-  profile <- getProfile
-  k       <- newBlockId
-  tscp    <- getTickScope
-  let area = Young k
-      (off, _, copyin) = copyInOflow profile retConv area results []
-      copyout = mkCallReturnsTo profile f callConv actuals k off updfr_off extra_stack
-  return $ catAGraphs [copyout, mkLabel k tscp, copyin]
-
-mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset
-          -> FCode CmmAGraph
-mkCmmCall f results actuals updfr_off
-   = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []
-
-
--- ----------------------------------------------------------------------------
--- turn CmmAGraph into CmmGraph, for making a new proc.
-
-aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph
-aGraphToGraph stmts
-  = do  { l <- newBlockId
-        ; return (labelAGraph l stmts) }
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ /dev/null
@@ -1,3260 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-----------------------------------------------------------------------------
---
--- Stg to C--: primitive operations
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.Prim (
-   cgOpApp,
-   shouldInlinePrimOp
- ) where
-
-import GHC.Prelude hiding ((<*>))
-
-import GHC.Platform
-import GHC.Platform.Profile
-
-import GHC.StgToCmm.Config
-import GHC.StgToCmm.Layout
-import GHC.StgToCmm.Foreign
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Utils
-import GHC.StgToCmm.Ticky
-import GHC.StgToCmm.Heap
-import GHC.StgToCmm.Prof ( costCentreFrom )
-
-import GHC.Types.Basic
-import GHC.Cmm.BlockId
-import GHC.Cmm.Graph
-import GHC.Stg.Syntax
-import GHC.Cmm
-import GHC.Unit         ( rtsUnit )
-import GHC.Core.Type    ( Type, tyConAppTyCon_maybe )
-import GHC.Core.TyCon
-import GHC.Cmm.CLabel
-import GHC.Cmm.Info     ( closureInfoPtr )
-import GHC.Cmm.Utils
-import GHC.Builtin.PrimOps
-import GHC.Runtime.Heap.Layout
-import GHC.Data.FastString
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import Data.Maybe
-
-import Control.Monad (liftM, when, unless)
-import GHC.Utils.Outputable
-
-------------------------------------------------------------------------
---      Primitive operations and foreign calls
-------------------------------------------------------------------------
-
-{- Note [Foreign call results]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A foreign call always returns an unboxed tuple of results, one
-of which is the state token.  This seems to happen even for pure
-calls.
-
-Even if we returned a single result for pure calls, it'd still be
-right to wrap it in a singleton unboxed tuple, because the result
-might be a Haskell closure pointer, we don't want to evaluate it. -}
-
-----------------------------------
-cgOpApp :: StgOp        -- The op
-        -> [StgArg]     -- Arguments
-        -> Type         -- Result type (always an unboxed tuple)
-        -> FCode ReturnKind
-
--- Foreign calls
-cgOpApp (StgFCallOp fcall ty) stg_args res_ty
-  = cgForeignCall fcall ty stg_args res_ty
-      -- See Note [Foreign call results]
-
-cgOpApp (StgPrimOp primop) args res_ty = do
-    cfg <- getStgToCmmConfig
-    cmm_args <- getNonVoidArgAmodes args
-    cmmPrimOpApp cfg primop cmm_args (Just res_ty)
-
-cgOpApp (StgPrimCallOp primcall) args _res_ty
-  = do  { cmm_args <- getNonVoidArgAmodes args
-        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))
-        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }
-
-cmmPrimOpApp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind
-cmmPrimOpApp cfg primop cmm_args mres_ty =
-  case emitPrimOp cfg primop cmm_args of
-    PrimopCmmEmit_Internal f ->
-      let
-         -- if the result type isn't explicitly given, we directly use the
-         -- result type of the primop.
-         res_ty = fromMaybe (primOpResultType primop) mres_ty
-      in emitReturn =<< f res_ty
-    PrimopCmmEmit_External -> do
-      let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
-      emitCall (NativeNodeCall, NativeReturn) fun cmm_args
-
-
--- | Interpret the argument as an unsigned value, assuming the value
--- is given in two-complement form in the given width.
---
--- Example: @asUnsigned W64 (-1)@ is 18446744073709551615.
---
--- This function is used to work around the fact that many array
--- primops take Int# arguments, but we interpret them as unsigned
--- quantities in the code gen. This means that we have to be careful
--- every time we work on e.g. a CmmInt literal that corresponds to the
--- array size, as it might contain a negative Integer value if the
--- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#
--- literal.
-asUnsigned :: Width -> Integer -> Integer
-asUnsigned w n = n .&. (bit (widthInBits w) - 1)
-
-------------------------------------------------------------------------
---      Emitting code for a primop
-------------------------------------------------------------------------
-
-shouldInlinePrimOp :: StgToCmmConfig -> PrimOp -> [CmmExpr] -> Bool
-shouldInlinePrimOp cfg op args = case emitPrimOp cfg op args of
-  PrimopCmmEmit_External -> False
-  PrimopCmmEmit_Internal _ -> True
-
--- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use
--- ByteOff (or some other fixed width signed type) to represent
--- array sizes or indices. This means that these will overflow for
--- large enough sizes.
-
--- TODO: Several primops, such as 'copyArray#', only have an inline
--- implementation (below) but could possibly have both an inline
--- implementation and an out-of-line implementation, just like
--- 'newArray#'. This would lower the amount of code generated,
--- hopefully without a performance impact (needs to be measured).
-
--- | The big function handling all the primops.
---
--- In the simple case, there is just one implementation, and we emit that.
---
--- In more complex cases, there is a foreign call (out of line) fallback. This
--- might happen e.g. if there's enough static information, such as statically
--- know arguments.
-emitPrimOp
-  :: StgToCmmConfig
-  -> PrimOp            -- ^ The primop
-  -> [CmmExpr]         -- ^ The primop arguments
-  -> PrimopCmmEmit
-emitPrimOp cfg primop =
-  let max_inl_alloc_size = fromIntegral (stgToCmmMaxInlAllocSize cfg)
-  in case primop of
-  NewByteArrayOp_Char -> \case
-    [(CmmLit (CmmInt n w))]
-      | asUnsigned w n <= max_inl_alloc_size
-      -> opIntoRegs  $ \ [res] -> doNewByteArrayOp res (fromInteger n)
-    _ -> PrimopCmmEmit_External
-
-  NewArrayOp -> \case
-    [(CmmLit (CmmInt n w)), init]
-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size
-      -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel
-        [ (mkIntExpr platform (fromInteger n),
-           fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))
-        , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep platform (fromInteger n))),
-           fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_size (platformConstants platform))
-        ]
-        (fromInteger n) init
-    _ -> PrimopCmmEmit_External
-
-  CopyArrayOp -> \case
-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->
-      opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)
-    _ -> PrimopCmmEmit_External
-
-  CopyMutableArrayOp -> \case
-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->
-      opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)
-    _ -> PrimopCmmEmit_External
-
-  CloneArrayOp -> \case
-    [src, src_off, (CmmLit (CmmInt n w))]
-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size
-      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
-    _ -> PrimopCmmEmit_External
-
-  CloneMutableArrayOp -> \case
-    [src, src_off, (CmmLit (CmmInt n w))]
-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size
-      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
-    _ -> PrimopCmmEmit_External
-
-  FreezeArrayOp -> \case
-    [src, src_off, (CmmLit (CmmInt n w))]
-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size
-      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
-    _ -> PrimopCmmEmit_External
-
-  ThawArrayOp -> \case
-    [src, src_off, (CmmLit (CmmInt n w))]
-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size
-      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
-    _ -> PrimopCmmEmit_External
-
-  NewSmallArrayOp -> \case
-    [(CmmLit (CmmInt n w)), init]
-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size
-      -> opIntoRegs $ \ [res] ->
-        doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel
-        [ (mkIntExpr platform (fromInteger n),
-           fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform))
-        ]
-        (fromInteger n) init
-    _ -> PrimopCmmEmit_External
-
-  CopySmallArrayOp -> \case
-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->
-      opIntoRegs $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)
-    _ -> PrimopCmmEmit_External
-
-  CopySmallMutableArrayOp -> \case
-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->
-      opIntoRegs $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)
-    _ -> PrimopCmmEmit_External
-
-  CloneSmallArrayOp -> \case
-    [src, src_off, (CmmLit (CmmInt n w))]
-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size
-      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
-    _ -> PrimopCmmEmit_External
-
-  CloneSmallMutableArrayOp -> \case
-    [src, src_off, (CmmLit (CmmInt n w))]
-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size
-      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
-    _ -> PrimopCmmEmit_External
-
-  FreezeSmallArrayOp -> \case
-    [src, src_off, (CmmLit (CmmInt n w))]
-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size
-      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
-    _ -> PrimopCmmEmit_External
-
-  ThawSmallArrayOp -> \case
-    [src, src_off, (CmmLit (CmmInt n w))]
-      | wordsToBytes platform (asUnsigned w n) <= max_inl_alloc_size
-      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
-    _ -> PrimopCmmEmit_External
-
--- First we handle various awkward cases specially.
-
-  ParOp -> \[arg] -> opIntoRegs $ \[res] ->
-    -- for now, just implement this in a C function
-    -- later, we might want to inline it.
-    emitCCall
-        [(res,NoHint)]
-        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
-        [(baseExpr, AddrHint), (arg,AddrHint)]
-
-  SparkOp -> \[arg] -> opIntoRegs $ \[res] -> do
-    -- returns the value of arg in res.  We're going to therefore
-    -- refer to arg twice (once to pass to newSpark(), and once to
-    -- assign to res), so put it in a temporary.
-    tmp <- assignTemp arg
-    tmp2 <- newTemp (bWord platform)
-    emitCCall
-        [(tmp2,NoHint)]
-        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
-        [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
-    emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))
-
-  GetCCSOfOp -> \[arg] -> opIntoRegs $ \[res] -> do
-    let
-      val
-       | profileIsProfiling profile = costCentreFrom platform (cmmUntag platform arg)
-       | otherwise                  = CmmLit (zeroCLit platform)
-    emitAssign (CmmLocal res) val
-
-  GetCurrentCCSOp -> \[_] -> opIntoRegs $ \[res] ->
-    emitAssign (CmmLocal res) cccsExpr
-
-  MyThreadIdOp -> \[] -> opIntoRegs $ \[res] ->
-    emitAssign (CmmLocal res) currentTSOExpr
-
-  ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] ->
-    emitAssign (CmmLocal res) (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform))
-
-  WriteMutVarOp -> \[mutv, var] -> opIntoRegs $ \res@[] -> do
-    old_val <- CmmLocal <$> newTemp (cmmExprType platform var)
-    emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform))
-
-    -- Without this write barrier, other CPUs may see this pointer before
-    -- the writes for the closure it points to have occurred.
-    -- Note that this also must come after we read the old value to ensure
-    -- that the read of old_val comes before another core's write to the
-    -- MutVar's value.
-    emitPrimCall res MO_WriteBarrier []
-    emitStore (cmmOffsetW platform mutv (fixedHdrSizeW profile)) var
-
-    platform <- getPlatform
-    mkdirtyMutVarCCall <- getCode $! emitCCall
-      [{-no results-}]
-      (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
-      [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)]
-    emit =<< mkCmmIfThen
-      (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel)
-       (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutv))
-      mkdirtyMutVarCCall
-
---  #define sizzeofByteArrayzh(r,a) \
---     r = ((StgArrBytes *)(a))->bytes
-  SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->
-    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform))
-
---  #define sizzeofMutableByteArrayzh(r,a) \
---      r = ((StgArrBytes *)(a))->bytes
-  SizeofMutableByteArrayOp -> emitPrimOp cfg SizeofByteArrayOp
-
---  #define getSizzeofMutableByteArrayzh(r,a) \
---      r = ((StgArrBytes *)(a))->bytes
-  GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->
-    emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform))
-
-
---  #define touchzh(o)                  /* nothing */
-  TouchOp -> \args@[_] -> opIntoRegs $ \res@[] ->
-    emitPrimCall res MO_Touch args
-
---  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
-  ByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] ->
-    emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile))
-
---  #define mutableByteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
-  MutableByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] ->
-    emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile))
-
---  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
-  StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] ->
-    emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform))
-
-  EqStablePtrOp -> \args -> opTranslate args (mo_wordEq platform)
-
-  ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] ->
-    emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2])
-
---  #define addrToHValuezh(r,a) r=(P_)a
-  AddrToAnyOp -> \[arg] -> opIntoRegs $ \[res] ->
-    emitAssign (CmmLocal res) arg
-
---  #define hvalueToAddrzh(r, a) r=(W_)a
-  AnyToAddrOp -> \[arg] -> opIntoRegs $ \[res] ->
-    emitAssign (CmmLocal res) arg
-
-{- Freezing arrays-of-ptrs requires changing an info table, for the
-   benefit of the generational collector.  It needs to scavenge mutable
-   objects, even if they are in old space.  When they become immutable,
-   they can be removed from this scavenge list.  -}
-
---  #define unsafeFreezzeArrayzh(r,a)
---      {
---        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);
---        r = a;
---      }
-  UnsafeFreezeArrayOp -> \[arg] -> opIntoRegs $ \[res] ->
-    emit $ catAGraphs
-      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),
-        mkAssign (CmmLocal res) arg ]
-  UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] ->
-    emit $ catAGraphs
-      [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),
-        mkAssign (CmmLocal res) arg ]
-
---  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)
-  UnsafeFreezeByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->
-    emitAssign (CmmLocal res) arg
-
--- Reading/writing pointer arrays
-
-  ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->
-    doReadPtrArrayOp res obj ix
-  IndexArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->
-    doReadPtrArrayOp res obj ix
-  WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] ->
-    doWritePtrArrayOp obj ix v
-
-  ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->
-    doReadSmallPtrArrayOp res obj ix
-  IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->
-    doReadSmallPtrArrayOp res obj ix
-  WriteSmallArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] ->
-    doWriteSmallPtrArrayOp obj ix v
-
--- Getting the size of pointer arrays
-
-  SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] ->
-    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg
-      (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)))
-        (bWord platform))
-  SizeofMutableArrayOp      -> emitPrimOp cfg SizeofArrayOp
-  SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] ->
-    emit $ mkAssign (CmmLocal res)
-     (cmmLoadIndexW platform arg
-     (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)))
-        (bWord platform))
-
-  SizeofSmallMutableArrayOp    -> emitPrimOp cfg SizeofSmallArrayOp
-  GetSizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp
-
--- IndexXXXoffAddr
-
-  IndexOffAddrOp_Char -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8 res args
-  IndexOffAddrOp_WideChar -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args
-  IndexOffAddrOp_Int -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing (bWord platform) res args
-  IndexOffAddrOp_Word -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing (bWord platform) res args
-  IndexOffAddrOp_Addr -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing (bWord platform) res args
-  IndexOffAddrOp_Float -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing f32 res args
-  IndexOffAddrOp_Double -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing f64 res args
-  IndexOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing (bWord platform) res args
-  IndexOffAddrOp_Int8 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b8  res args
-  IndexOffAddrOp_Int16 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b16 res args
-  IndexOffAddrOp_Int32 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b32 res args
-  IndexOffAddrOp_Int64 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b64 res args
-  IndexOffAddrOp_Word8 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b8  res args
-  IndexOffAddrOp_Word16 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b16 res args
-  IndexOffAddrOp_Word32 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b32 res args
-  IndexOffAddrOp_Word64 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b64 res args
-
--- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
-
-  ReadOffAddrOp_Char -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8 res args
-  ReadOffAddrOp_WideChar -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args
-  ReadOffAddrOp_Int -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing (bWord platform) res args
-  ReadOffAddrOp_Word -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing (bWord platform) res args
-  ReadOffAddrOp_Addr -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing (bWord platform) res args
-  ReadOffAddrOp_Float -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing f32 res args
-  ReadOffAddrOp_Double -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing f64 res args
-  ReadOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing (bWord platform) res args
-  ReadOffAddrOp_Int8 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b8  res args
-  ReadOffAddrOp_Int16 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b16 res args
-  ReadOffAddrOp_Int32 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b32 res args
-  ReadOffAddrOp_Int64 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b64 res args
-  ReadOffAddrOp_Word8 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b8  res args
-  ReadOffAddrOp_Word16 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b16 res args
-  ReadOffAddrOp_Word32 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b32 res args
-  ReadOffAddrOp_Word64 -> \args -> opIntoRegs $ \res ->
-    doIndexOffAddrOp   Nothing b64 res args
-
--- IndexXXXArray
-
-  IndexByteArrayOp_Char -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8 res args
-  IndexByteArrayOp_WideChar -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32 res args
-  IndexByteArrayOp_Int -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing (bWord platform) res args
-  IndexByteArrayOp_Word -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing (bWord platform) res args
-  IndexByteArrayOp_Addr -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing (bWord platform) res args
-  IndexByteArrayOp_Float -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing f32 res args
-  IndexByteArrayOp_Double -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing f64 res args
-  IndexByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing (bWord platform) res args
-  IndexByteArrayOp_Int8 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b8  res args
-  IndexByteArrayOp_Int16 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b16  res args
-  IndexByteArrayOp_Int32 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b32  res args
-  IndexByteArrayOp_Int64 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b64  res args
-  IndexByteArrayOp_Word8 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b8  res args
-  IndexByteArrayOp_Word16 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b16  res args
-  IndexByteArrayOp_Word32 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b32  res args
-  IndexByteArrayOp_Word64 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b64  res args
-
--- ReadXXXArray, identical to IndexXXXArray.
-
-  ReadByteArrayOp_Char -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8 res args
-  ReadByteArrayOp_WideChar -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32 res args
-  ReadByteArrayOp_Int -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing (bWord platform) res args
-  ReadByteArrayOp_Word -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing (bWord platform) res args
-  ReadByteArrayOp_Addr -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing (bWord platform) res args
-  ReadByteArrayOp_Float -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing f32 res args
-  ReadByteArrayOp_Double -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing f64 res args
-  ReadByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing (bWord platform) res args
-  ReadByteArrayOp_Int8 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b8  res args
-  ReadByteArrayOp_Int16 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b16  res args
-  ReadByteArrayOp_Int32 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b32  res args
-  ReadByteArrayOp_Int64 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b64  res args
-  ReadByteArrayOp_Word8 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b8  res args
-  ReadByteArrayOp_Word16 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b16  res args
-  ReadByteArrayOp_Word32 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b32  res args
-  ReadByteArrayOp_Word64 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOp   Nothing b64  res args
-
--- IndexWord8ArrayAsXXX
-
-  IndexByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args
-  IndexByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args
-  IndexByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args
-  IndexByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args
-  IndexByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args
-  IndexByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing f32 b8 res args
-  IndexByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing f64 b8 res args
-  IndexByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args
-  IndexByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing b16 b8 res args
-  IndexByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing b32 b8 res args
-  IndexByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing b64 b8 res args
-  IndexByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing b16 b8 res args
-  IndexByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing b32 b8 res args
-  IndexByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing b64 b8 res args
-
--- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX
-
-  ReadByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args
-  ReadByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args
-  ReadByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args
-  ReadByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args
-  ReadByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args
-  ReadByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing f32 b8 res args
-  ReadByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing f64 b8 res args
-  ReadByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args
-  ReadByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing b16 b8 res args
-  ReadByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing b32 b8 res args
-  ReadByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing b64 b8 res args
-  ReadByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing b16 b8 res args
-  ReadByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing b32 b8 res args
-  ReadByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->
-    doIndexByteArrayOpAs   Nothing b64 b8 res args
-
--- WriteXXXoffAddr
-
-  WriteOffAddrOp_Char -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp (Just (mo_WordTo8 platform))  b8 res args
-  WriteOffAddrOp_WideChar -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args
-  WriteOffAddrOp_Int -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp Nothing (bWord platform) res args
-  WriteOffAddrOp_Word -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp Nothing (bWord platform) res args
-  WriteOffAddrOp_Addr -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp Nothing (bWord platform) res args
-  WriteOffAddrOp_Float -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp Nothing f32 res args
-  WriteOffAddrOp_Double -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp Nothing f64 res args
-  WriteOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp Nothing (bWord platform) res args
-  WriteOffAddrOp_Int8 -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp Nothing b8 res args
-  WriteOffAddrOp_Int16 -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp Nothing b16 res args
-  WriteOffAddrOp_Int32 -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp Nothing b32 res args
-  WriteOffAddrOp_Int64 -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp Nothing b64 res args
-  WriteOffAddrOp_Word8 -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp Nothing b8 res args
-  WriteOffAddrOp_Word16 -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp Nothing b16 res args
-  WriteOffAddrOp_Word32 -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp Nothing b32 res args
-  WriteOffAddrOp_Word64 -> \args -> opIntoRegs $ \res ->
-    doWriteOffAddrOp Nothing b64 res args
-
--- WriteXXXArray
-
-  WriteByteArrayOp_Char -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8 res args
-  WriteByteArrayOp_WideChar -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args
-  WriteByteArrayOp_Int -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing (bWord platform) res args
-  WriteByteArrayOp_Word -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing (bWord platform) res args
-  WriteByteArrayOp_Addr -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing (bWord platform) res args
-  WriteByteArrayOp_Float -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing f32 res args
-  WriteByteArrayOp_Double -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing f64 res args
-  WriteByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing (bWord platform) res args
-  WriteByteArrayOp_Int8 -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Int16 -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b16 res args
-  WriteByteArrayOp_Int32 -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b32 res args
-  WriteByteArrayOp_Int64 -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b64 res args
-  WriteByteArrayOp_Word8 -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b8  res args
-  WriteByteArrayOp_Word16 -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b16 res args
-  WriteByteArrayOp_Word32 -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b32 res args
-  WriteByteArrayOp_Word64 -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b64 res args
-
--- WriteInt8ArrayAsXXX
-
-  WriteByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8 res args
-  WriteByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args
-  WriteByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b8 res args
-  WriteByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->
-    doWriteByteArrayOp Nothing b8 res args
-
--- Copying and setting byte arrays
-  CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] ->
-    doCopyByteArrayOp src src_off dst dst_off n
-  CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] ->
-    doCopyMutableByteArrayOp src src_off dst dst_off n
-  CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] ->
-    doCopyByteArrayToAddrOp src src_off dst n
-  CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] ->
-    doCopyMutableByteArrayToAddrOp src src_off dst n
-  CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opIntoRegs $ \[] ->
-    doCopyAddrToByteArrayOp src dst dst_off n
-  SetByteArrayOp -> \[ba,off,len,c] -> opIntoRegs $ \[] ->
-    doSetByteArrayOp ba off len c
-
--- Comparing byte arrays
-  CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opIntoRegs $ \[res] ->
-    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n
-
-  BSwap16Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitBSwapCall res w W16
-  BSwap32Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitBSwapCall res w W32
-  BSwap64Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitBSwapCall res w W64
-  BSwapOp -> \[w] -> opIntoRegs $ \[res] ->
-    emitBSwapCall res w (wordWidth platform)
-
-  BRev8Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitBRevCall res w W8
-  BRev16Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitBRevCall res w W16
-  BRev32Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitBRevCall res w W32
-  BRev64Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitBRevCall res w W64
-  BRevOp -> \[w] -> opIntoRegs $ \[res] ->
-    emitBRevCall res w (wordWidth platform)
-
--- Population count
-  PopCnt8Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitPopCntCall res w W8
-  PopCnt16Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitPopCntCall res w W16
-  PopCnt32Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitPopCntCall res w W32
-  PopCnt64Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitPopCntCall res w W64
-  PopCntOp -> \[w] -> opIntoRegs $ \[res] ->
-    emitPopCntCall res w (wordWidth platform)
-
--- Parallel bit deposit
-  Pdep8Op -> \[src, mask] -> opIntoRegs $ \[res] ->
-    emitPdepCall res src mask W8
-  Pdep16Op -> \[src, mask] -> opIntoRegs $ \[res] ->
-    emitPdepCall res src mask W16
-  Pdep32Op -> \[src, mask] -> opIntoRegs $ \[res] ->
-    emitPdepCall res src mask W32
-  Pdep64Op -> \[src, mask] -> opIntoRegs $ \[res] ->
-    emitPdepCall res src mask W64
-  PdepOp -> \[src, mask] -> opIntoRegs $ \[res] ->
-    emitPdepCall res src mask (wordWidth platform)
-
--- Parallel bit extract
-  Pext8Op -> \[src, mask] -> opIntoRegs $ \[res] ->
-    emitPextCall res src mask W8
-  Pext16Op -> \[src, mask] -> opIntoRegs $ \[res] ->
-    emitPextCall res src mask W16
-  Pext32Op -> \[src, mask] -> opIntoRegs $ \[res] ->
-    emitPextCall res src mask W32
-  Pext64Op -> \[src, mask] -> opIntoRegs $ \[res] ->
-    emitPextCall res src mask W64
-  PextOp -> \[src, mask] -> opIntoRegs $ \[res] ->
-    emitPextCall res src mask (wordWidth platform)
-
--- count leading zeros
-  Clz8Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitClzCall res w W8
-  Clz16Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitClzCall res w W16
-  Clz32Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitClzCall res w W32
-  Clz64Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitClzCall res w W64
-  ClzOp -> \[w] -> opIntoRegs $ \[res] ->
-    emitClzCall res w (wordWidth platform)
-
--- count trailing zeros
-  Ctz8Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitCtzCall res w W8
-  Ctz16Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitCtzCall res w W16
-  Ctz32Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitCtzCall res w W32
-  Ctz64Op -> \[w] -> opIntoRegs $ \[res] ->
-    emitCtzCall res w W64
-  CtzOp -> \[w] -> opIntoRegs $ \[res] ->
-    emitCtzCall res w (wordWidth platform)
-
--- Unsigned int to floating point conversions
-  WordToFloatOp -> \[w] -> opIntoRegs $ \[res] ->
-    emitPrimCall [res] (MO_UF_Conv W32) [w]
-  WordToDoubleOp -> \[w] -> opIntoRegs $ \[res] ->
-    emitPrimCall [res] (MO_UF_Conv W64) [w]
-
--- Atomic operations
-  InterlockedExchange_Addr -> \[src, value] -> opIntoRegs $ \[res] ->
-    emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]
-  InterlockedExchange_Word -> \[src, value] -> opIntoRegs $ \[res] ->
-    emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]
-
-  FetchAddAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->
-    doAtomicAddrRMW res AMO_Add addr (bWord platform) n
-  FetchSubAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->
-    doAtomicAddrRMW res AMO_Sub addr (bWord platform) n
-  FetchAndAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->
-    doAtomicAddrRMW res AMO_And addr (bWord platform) n
-  FetchNandAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->
-    doAtomicAddrRMW res AMO_Nand addr (bWord platform) n
-  FetchOrAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->
-    doAtomicAddrRMW res AMO_Or addr (bWord platform) n
-  FetchXorAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->
-    doAtomicAddrRMW res AMO_Xor addr (bWord platform) n
-
-  AtomicReadAddrOp_Word -> \[addr] -> opIntoRegs $ \[res] ->
-    doAtomicReadAddr res addr (bWord platform)
-  AtomicWriteAddrOp_Word -> \[addr, val] -> opIntoRegs $ \[] ->
-    doAtomicWriteAddr addr (bWord platform) val
-
-  CasAddrOp_Addr -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
-    emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]
-  CasAddrOp_Word -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
-    emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]
-  CasAddrOp_Word8 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
-    emitPrimCall [res] (MO_Cmpxchg W8) [dst, expected, new]
-  CasAddrOp_Word16 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
-    emitPrimCall [res] (MO_Cmpxchg W16) [dst, expected, new]
-  CasAddrOp_Word32 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
-    emitPrimCall [res] (MO_Cmpxchg W32) [dst, expected, new]
-  CasAddrOp_Word64 -> \[dst, expected, new] -> opIntoRegs $ \[res] ->
-    emitPrimCall [res] (MO_Cmpxchg W64) [dst, expected, new]
-
--- SIMD primops
-  (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do
-    checkVecCompatibility cfg vcat n w
-    doVecPackOp ty zeros (replicate n e) res
-   where
-    zeros :: CmmExpr
-    zeros = CmmLit $ CmmVec (replicate n zero)
-
-    zero :: CmmLit
-    zero = case vcat of
-             IntVec   -> CmmInt 0 w
-             WordVec  -> CmmInt 0 w
-             FloatVec -> CmmFloat 0 w
-
-    ty :: CmmType
-    ty = vecVmmType vcat n w
-
-  (VecPackOp vcat n w) -> \es -> opIntoRegs $ \[res] -> do
-    checkVecCompatibility cfg vcat n w
-    when (es `lengthIsNot` n) $
-        panic "emitPrimOp: VecPackOp has wrong number of arguments"
-    doVecPackOp ty zeros es res
-   where
-    zeros :: CmmExpr
-    zeros = CmmLit $ CmmVec (replicate n zero)
-
-    zero :: CmmLit
-    zero = case vcat of
-             IntVec   -> CmmInt 0 w
-             WordVec  -> CmmInt 0 w
-             FloatVec -> CmmFloat 0 w
-
-    ty :: CmmType
-    ty = vecVmmType vcat n w
-
-  (VecUnpackOp vcat n w) -> \[arg] -> opIntoRegs $ \res -> do
-    checkVecCompatibility cfg vcat n w
-    when (res `lengthIsNot` n) $
-        panic "emitPrimOp: VecUnpackOp has wrong number of results"
-    doVecUnpackOp ty arg res
-   where
-    ty :: CmmType
-    ty = vecVmmType vcat n w
-
-  (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do
-    checkVecCompatibility cfg vcat n w
-    doVecInsertOp ty v e i res
-   where
-    ty :: CmmType
-    ty = vecVmmType vcat n w
-
-  (VecIndexByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do
-    checkVecCompatibility cfg vcat n w
-    doIndexByteArrayOp Nothing ty res0 args
-   where
-    ty :: CmmType
-    ty = vecVmmType vcat n w
-
-  (VecReadByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do
-    checkVecCompatibility cfg vcat n w
-    doIndexByteArrayOp Nothing ty res0 args
-   where
-    ty :: CmmType
-    ty = vecVmmType vcat n w
-
-  (VecWriteByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do
-    checkVecCompatibility cfg vcat n w
-    doWriteByteArrayOp Nothing ty res0 args
-   where
-    ty :: CmmType
-    ty = vecVmmType vcat n w
-
-  (VecIndexOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do
-    checkVecCompatibility cfg vcat n w
-    doIndexOffAddrOp Nothing ty res0 args
-   where
-    ty :: CmmType
-    ty = vecVmmType vcat n w
-
-  (VecReadOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do
-    checkVecCompatibility cfg vcat n w
-    doIndexOffAddrOp Nothing ty res0 args
-   where
-    ty :: CmmType
-    ty = vecVmmType vcat n w
-
-  (VecWriteOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do
-    checkVecCompatibility cfg vcat n w
-    doWriteOffAddrOp Nothing ty res0 args
-   where
-    ty :: CmmType
-    ty = vecVmmType vcat n w
-
-  (VecIndexScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do
-    checkVecCompatibility cfg vcat n w
-    doIndexByteArrayOpAs Nothing vecty ty res0 args
-   where
-    vecty :: CmmType
-    vecty = vecVmmType vcat n w
-
-    ty :: CmmType
-    ty = vecCmmCat vcat w
-
-  (VecReadScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do
-    checkVecCompatibility cfg vcat n w
-    doIndexByteArrayOpAs Nothing vecty ty res0 args
-   where
-    vecty :: CmmType
-    vecty = vecVmmType vcat n w
-
-    ty :: CmmType
-    ty = vecCmmCat vcat w
-
-  (VecWriteScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do
-    checkVecCompatibility cfg vcat n w
-    doWriteByteArrayOp Nothing ty res0 args
-   where
-    ty :: CmmType
-    ty = vecCmmCat vcat w
-
-  (VecIndexScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do
-    checkVecCompatibility cfg vcat n w
-    doIndexOffAddrOpAs Nothing vecty ty res0 args
-   where
-    vecty :: CmmType
-    vecty = vecVmmType vcat n w
-
-    ty :: CmmType
-    ty = vecCmmCat vcat w
-
-  (VecReadScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do
-    checkVecCompatibility cfg vcat n w
-    doIndexOffAddrOpAs Nothing vecty ty res0 args
-   where
-    vecty :: CmmType
-    vecty = vecVmmType vcat n w
-
-    ty :: CmmType
-    ty = vecCmmCat vcat w
-
-  (VecWriteScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do
-    checkVecCompatibility cfg vcat n w
-    doWriteOffAddrOp Nothing ty res0 args
-   where
-    ty :: CmmType
-    ty = vecCmmCat vcat w
-
--- Prefetch
-  PrefetchByteArrayOp3         -> \args -> opIntoRegs $ \[] ->
-    doPrefetchByteArrayOp 3  args
-  PrefetchMutableByteArrayOp3  -> \args -> opIntoRegs $ \[] ->
-    doPrefetchMutableByteArrayOp 3  args
-  PrefetchAddrOp3              -> \args -> opIntoRegs $ \[] ->
-    doPrefetchAddrOp  3  args
-  PrefetchValueOp3             -> \args -> opIntoRegs $ \[] ->
-    doPrefetchValueOp 3 args
-
-  PrefetchByteArrayOp2         -> \args -> opIntoRegs $ \[] ->
-    doPrefetchByteArrayOp 2  args
-  PrefetchMutableByteArrayOp2  -> \args -> opIntoRegs $ \[] ->
-    doPrefetchMutableByteArrayOp 2  args
-  PrefetchAddrOp2              -> \args -> opIntoRegs $ \[] ->
-    doPrefetchAddrOp 2  args
-  PrefetchValueOp2             -> \args -> opIntoRegs $ \[] ->
-    doPrefetchValueOp 2 args
-  PrefetchByteArrayOp1         -> \args -> opIntoRegs $ \[] ->
-    doPrefetchByteArrayOp 1  args
-  PrefetchMutableByteArrayOp1  -> \args -> opIntoRegs $ \[] ->
-    doPrefetchMutableByteArrayOp 1  args
-  PrefetchAddrOp1              -> \args -> opIntoRegs $ \[] ->
-    doPrefetchAddrOp 1  args
-  PrefetchValueOp1             -> \args -> opIntoRegs $ \[] ->
-    doPrefetchValueOp 1 args
-
-  PrefetchByteArrayOp0         -> \args -> opIntoRegs $ \[] ->
-    doPrefetchByteArrayOp 0  args
-  PrefetchMutableByteArrayOp0  -> \args -> opIntoRegs $ \[] ->
-    doPrefetchMutableByteArrayOp 0  args
-  PrefetchAddrOp0              -> \args -> opIntoRegs $ \[] ->
-    doPrefetchAddrOp 0  args
-  PrefetchValueOp0             -> \args -> opIntoRegs $ \[] ->
-    doPrefetchValueOp 0 args
-
--- Atomic read-modify-write
-  FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->
-    doAtomicByteArrayRMW res AMO_Add mba ix (bWord platform) n
-  FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->
-    doAtomicByteArrayRMW res AMO_Sub mba ix (bWord platform) n
-  FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->
-    doAtomicByteArrayRMW res AMO_And mba ix (bWord platform) n
-  FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->
-    doAtomicByteArrayRMW res AMO_Nand mba ix (bWord platform) n
-  FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->
-    doAtomicByteArrayRMW res AMO_Or mba ix (bWord platform) n
-  FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->
-    doAtomicByteArrayRMW res AMO_Xor mba ix (bWord platform) n
-  AtomicReadByteArrayOp_Int -> \[mba, ix] -> opIntoRegs $ \[res] ->
-    doAtomicReadByteArray res mba ix (bWord platform)
-  AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opIntoRegs $ \[] ->
-    doAtomicWriteByteArray mba ix (bWord platform) val
-  CasByteArrayOp_Int -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->
-    doCasByteArray res mba ix (bWord platform) old new
-  CasByteArrayOp_Int8 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->
-    doCasByteArray res mba ix b8 old new
-  CasByteArrayOp_Int16 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->
-    doCasByteArray res mba ix b16 old new
-  CasByteArrayOp_Int32 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->
-    doCasByteArray res mba ix b32 old new
-  CasByteArrayOp_Int64 -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->
-    doCasByteArray res mba ix b64 old new
-
--- The rest just translate straightforwardly
-
-  Int8ToWord8Op   -> \args -> opNop args
-  Word8ToInt8Op   -> \args -> opNop args
-  Int16ToWord16Op -> \args -> opNop args
-  Word16ToInt16Op -> \args -> opNop args
-  Int32ToWord32Op -> \args -> opNop args
-  Word32ToInt32Op -> \args -> opNop args
-  Int64ToWord64Op -> \args -> opNop args
-  Word64ToInt64Op -> \args -> opNop args
-  IntToWordOp     -> \args -> opNop args
-  WordToIntOp     -> \args -> opNop args
-  IntToAddrOp     -> \args -> opNop args
-  AddrToIntOp     -> \args -> opNop args
-  ChrOp           -> \args -> opNop args  -- Int# and Char# are rep'd the same
-  OrdOp           -> \args -> opNop args
-
-  Narrow8IntOp   -> \args -> opNarrow args (MO_SS_Conv, W8)
-  Narrow16IntOp  -> \args -> opNarrow args (MO_SS_Conv, W16)
-  Narrow32IntOp  -> \args -> opNarrow args (MO_SS_Conv, W32)
-  Narrow8WordOp  -> \args -> opNarrow args (MO_UU_Conv, W8)
-  Narrow16WordOp -> \args -> opNarrow args (MO_UU_Conv, W16)
-  Narrow32WordOp -> \args -> opNarrow args (MO_UU_Conv, W32)
-
-  DoublePowerOp  -> \args -> opCallish args MO_F64_Pwr
-  DoubleSinOp    -> \args -> opCallish args MO_F64_Sin
-  DoubleCosOp    -> \args -> opCallish args MO_F64_Cos
-  DoubleTanOp    -> \args -> opCallish args MO_F64_Tan
-  DoubleSinhOp   -> \args -> opCallish args MO_F64_Sinh
-  DoubleCoshOp   -> \args -> opCallish args MO_F64_Cosh
-  DoubleTanhOp   -> \args -> opCallish args MO_F64_Tanh
-  DoubleAsinOp   -> \args -> opCallish args MO_F64_Asin
-  DoubleAcosOp   -> \args -> opCallish args MO_F64_Acos
-  DoubleAtanOp   -> \args -> opCallish args MO_F64_Atan
-  DoubleAsinhOp  -> \args -> opCallish args MO_F64_Asinh
-  DoubleAcoshOp  -> \args -> opCallish args MO_F64_Acosh
-  DoubleAtanhOp  -> \args -> opCallish args MO_F64_Atanh
-  DoubleLogOp    -> \args -> opCallish args MO_F64_Log
-  DoubleLog1POp  -> \args -> opCallish args MO_F64_Log1P
-  DoubleExpOp    -> \args -> opCallish args MO_F64_Exp
-  DoubleExpM1Op  -> \args -> opCallish args MO_F64_ExpM1
-  DoubleSqrtOp   -> \args -> opCallish args MO_F64_Sqrt
-  DoubleFabsOp   -> \args -> opCallish args MO_F64_Fabs
-
-  FloatPowerOp   -> \args -> opCallish args MO_F32_Pwr
-  FloatSinOp     -> \args -> opCallish args MO_F32_Sin
-  FloatCosOp     -> \args -> opCallish args MO_F32_Cos
-  FloatTanOp     -> \args -> opCallish args MO_F32_Tan
-  FloatSinhOp    -> \args -> opCallish args MO_F32_Sinh
-  FloatCoshOp    -> \args -> opCallish args MO_F32_Cosh
-  FloatTanhOp    -> \args -> opCallish args MO_F32_Tanh
-  FloatAsinOp    -> \args -> opCallish args MO_F32_Asin
-  FloatAcosOp    -> \args -> opCallish args MO_F32_Acos
-  FloatAtanOp    -> \args -> opCallish args MO_F32_Atan
-  FloatAsinhOp   -> \args -> opCallish args MO_F32_Asinh
-  FloatAcoshOp   -> \args -> opCallish args MO_F32_Acosh
-  FloatAtanhOp   -> \args -> opCallish args MO_F32_Atanh
-  FloatLogOp     -> \args -> opCallish args MO_F32_Log
-  FloatLog1POp   -> \args -> opCallish args MO_F32_Log1P
-  FloatExpOp     -> \args -> opCallish args MO_F32_Exp
-  FloatExpM1Op   -> \args -> opCallish args MO_F32_ExpM1
-  FloatSqrtOp    -> \args -> opCallish args MO_F32_Sqrt
-  FloatFabsOp    -> \args -> opCallish args MO_F32_Fabs
-
--- Native word signless ops
-
-  IntAddOp       -> \args -> opTranslate args (mo_wordAdd platform)
-  IntSubOp       -> \args -> opTranslate args (mo_wordSub platform)
-  WordAddOp      -> \args -> opTranslate args (mo_wordAdd platform)
-  WordSubOp      -> \args -> opTranslate args (mo_wordSub platform)
-  AddrAddOp      -> \args -> opTranslate args (mo_wordAdd platform)
-  AddrSubOp      -> \args -> opTranslate args (mo_wordSub platform)
-
-  IntEqOp        -> \args -> opTranslate args (mo_wordEq platform)
-  IntNeOp        -> \args -> opTranslate args (mo_wordNe platform)
-  WordEqOp       -> \args -> opTranslate args (mo_wordEq platform)
-  WordNeOp       -> \args -> opTranslate args (mo_wordNe platform)
-  AddrEqOp       -> \args -> opTranslate args (mo_wordEq platform)
-  AddrNeOp       -> \args -> opTranslate args (mo_wordNe platform)
-
-  WordAndOp      -> \args -> opTranslate args (mo_wordAnd platform)
-  WordOrOp       -> \args -> opTranslate args (mo_wordOr platform)
-  WordXorOp      -> \args -> opTranslate args (mo_wordXor platform)
-  WordNotOp      -> \args -> opTranslate args (mo_wordNot platform)
-  WordSllOp      -> \args -> opTranslate args (mo_wordShl platform)
-  WordSrlOp      -> \args -> opTranslate args (mo_wordUShr platform)
-
-  AddrRemOp      -> \args -> opTranslate args (mo_wordURem platform)
-
--- Native word signed ops
-
-  IntMulOp        -> \args -> opTranslate args (mo_wordMul platform)
-  IntMulMayOfloOp -> \args -> opTranslate args (MO_S_MulMayOflo (wordWidth platform))
-  IntQuotOp       -> \args -> opTranslate args (mo_wordSQuot platform)
-  IntRemOp        -> \args -> opTranslate args (mo_wordSRem platform)
-  IntNegOp        -> \args -> opTranslate args (mo_wordSNeg platform)
-
-  IntGeOp        -> \args -> opTranslate args (mo_wordSGe platform)
-  IntLeOp        -> \args -> opTranslate args (mo_wordSLe platform)
-  IntGtOp        -> \args -> opTranslate args (mo_wordSGt platform)
-  IntLtOp        -> \args -> opTranslate args (mo_wordSLt platform)
-
-  IntAndOp       -> \args -> opTranslate args (mo_wordAnd platform)
-  IntOrOp        -> \args -> opTranslate args (mo_wordOr platform)
-  IntXorOp       -> \args -> opTranslate args (mo_wordXor platform)
-  IntNotOp       -> \args -> opTranslate args (mo_wordNot platform)
-  IntSllOp       -> \args -> opTranslate args (mo_wordShl platform)
-  IntSraOp       -> \args -> opTranslate args (mo_wordSShr platform)
-  IntSrlOp       -> \args -> opTranslate args (mo_wordUShr platform)
-
--- Native word unsigned ops
-
-  WordGeOp       -> \args -> opTranslate args (mo_wordUGe platform)
-  WordLeOp       -> \args -> opTranslate args (mo_wordULe platform)
-  WordGtOp       -> \args -> opTranslate args (mo_wordUGt platform)
-  WordLtOp       -> \args -> opTranslate args (mo_wordULt platform)
-
-  WordMulOp      -> \args -> opTranslate args (mo_wordMul platform)
-  WordQuotOp     -> \args -> opTranslate args (mo_wordUQuot platform)
-  WordRemOp      -> \args -> opTranslate args (mo_wordURem platform)
-
-  AddrGeOp       -> \args -> opTranslate args (mo_wordUGe platform)
-  AddrLeOp       -> \args -> opTranslate args (mo_wordULe platform)
-  AddrGtOp       -> \args -> opTranslate args (mo_wordUGt platform)
-  AddrLtOp       -> \args -> opTranslate args (mo_wordULt platform)
-
--- Int8# signed ops
-
-  Int8ToIntOp    -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth platform))
-  IntToInt8Op    -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W8)
-  Int8NegOp      -> \args -> opTranslate args (MO_S_Neg W8)
-  Int8AddOp      -> \args -> opTranslate args (MO_Add W8)
-  Int8SubOp      -> \args -> opTranslate args (MO_Sub W8)
-  Int8MulOp      -> \args -> opTranslate args (MO_Mul W8)
-  Int8QuotOp     -> \args -> opTranslate args (MO_S_Quot W8)
-  Int8RemOp      -> \args -> opTranslate args (MO_S_Rem W8)
-
-  Int8SllOp     -> \args -> opTranslate args (MO_Shl W8)
-  Int8SraOp     -> \args -> opTranslate args (MO_S_Shr W8)
-  Int8SrlOp     -> \args -> opTranslate args (MO_U_Shr W8)
-
-  Int8EqOp       -> \args -> opTranslate args (MO_Eq W8)
-  Int8GeOp       -> \args -> opTranslate args (MO_S_Ge W8)
-  Int8GtOp       -> \args -> opTranslate args (MO_S_Gt W8)
-  Int8LeOp       -> \args -> opTranslate args (MO_S_Le W8)
-  Int8LtOp       -> \args -> opTranslate args (MO_S_Lt W8)
-  Int8NeOp       -> \args -> opTranslate args (MO_Ne W8)
-
--- Word8# unsigned ops
-
-  Word8ToWordOp  -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth platform))
-  WordToWord8Op  -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W8)
-  Word8AddOp     -> \args -> opTranslate args (MO_Add W8)
-  Word8SubOp     -> \args -> opTranslate args (MO_Sub W8)
-  Word8MulOp     -> \args -> opTranslate args (MO_Mul W8)
-  Word8QuotOp    -> \args -> opTranslate args (MO_U_Quot W8)
-  Word8RemOp     -> \args -> opTranslate args (MO_U_Rem W8)
-
-  Word8AndOp    -> \args -> opTranslate args (MO_And W8)
-  Word8OrOp     -> \args -> opTranslate args (MO_Or W8)
-  Word8XorOp    -> \args -> opTranslate args (MO_Xor W8)
-  Word8NotOp    -> \args -> opTranslate args (MO_Not W8)
-  Word8SllOp    -> \args -> opTranslate args (MO_Shl W8)
-  Word8SrlOp    -> \args -> opTranslate args (MO_U_Shr W8)
-
-  Word8EqOp      -> \args -> opTranslate args (MO_Eq W8)
-  Word8GeOp      -> \args -> opTranslate args (MO_U_Ge W8)
-  Word8GtOp      -> \args -> opTranslate args (MO_U_Gt W8)
-  Word8LeOp      -> \args -> opTranslate args (MO_U_Le W8)
-  Word8LtOp      -> \args -> opTranslate args (MO_U_Lt W8)
-  Word8NeOp      -> \args -> opTranslate args (MO_Ne W8)
-
--- Int16# signed ops
-
-  Int16ToIntOp   -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth platform))
-  IntToInt16Op   -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W16)
-  Int16NegOp     -> \args -> opTranslate args (MO_S_Neg W16)
-  Int16AddOp     -> \args -> opTranslate args (MO_Add W16)
-  Int16SubOp     -> \args -> opTranslate args (MO_Sub W16)
-  Int16MulOp     -> \args -> opTranslate args (MO_Mul W16)
-  Int16QuotOp    -> \args -> opTranslate args (MO_S_Quot W16)
-  Int16RemOp     -> \args -> opTranslate args (MO_S_Rem W16)
-
-  Int16SllOp     -> \args -> opTranslate args (MO_Shl W16)
-  Int16SraOp     -> \args -> opTranslate args (MO_S_Shr W16)
-  Int16SrlOp     -> \args -> opTranslate args (MO_U_Shr W16)
-
-  Int16EqOp      -> \args -> opTranslate args (MO_Eq W16)
-  Int16GeOp      -> \args -> opTranslate args (MO_S_Ge W16)
-  Int16GtOp      -> \args -> opTranslate args (MO_S_Gt W16)
-  Int16LeOp      -> \args -> opTranslate args (MO_S_Le W16)
-  Int16LtOp      -> \args -> opTranslate args (MO_S_Lt W16)
-  Int16NeOp      -> \args -> opTranslate args (MO_Ne W16)
-
--- Word16# unsigned ops
-
-  Word16ToWordOp -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth platform))
-  WordToWord16Op -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W16)
-  Word16AddOp    -> \args -> opTranslate args (MO_Add W16)
-  Word16SubOp    -> \args -> opTranslate args (MO_Sub W16)
-  Word16MulOp    -> \args -> opTranslate args (MO_Mul W16)
-  Word16QuotOp   -> \args -> opTranslate args (MO_U_Quot W16)
-  Word16RemOp    -> \args -> opTranslate args (MO_U_Rem W16)
-
-  Word16AndOp    -> \args -> opTranslate args (MO_And W16)
-  Word16OrOp     -> \args -> opTranslate args (MO_Or W16)
-  Word16XorOp    -> \args -> opTranslate args (MO_Xor W16)
-  Word16NotOp    -> \args -> opTranslate args (MO_Not W16)
-  Word16SllOp    -> \args -> opTranslate args (MO_Shl W16)
-  Word16SrlOp    -> \args -> opTranslate args (MO_U_Shr W16)
-
-  Word16EqOp     -> \args -> opTranslate args (MO_Eq W16)
-  Word16GeOp     -> \args -> opTranslate args (MO_U_Ge W16)
-  Word16GtOp     -> \args -> opTranslate args (MO_U_Gt W16)
-  Word16LeOp     -> \args -> opTranslate args (MO_U_Le W16)
-  Word16LtOp     -> \args -> opTranslate args (MO_U_Lt W16)
-  Word16NeOp     -> \args -> opTranslate args (MO_Ne W16)
-
--- Int32# signed ops
-
-  Int32ToIntOp   -> \args -> opTranslate args (MO_SS_Conv W32 (wordWidth platform))
-  IntToInt32Op   -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W32)
-  Int32NegOp     -> \args -> opTranslate args (MO_S_Neg W32)
-  Int32AddOp     -> \args -> opTranslate args (MO_Add W32)
-  Int32SubOp     -> \args -> opTranslate args (MO_Sub W32)
-  Int32MulOp     -> \args -> opTranslate args (MO_Mul W32)
-  Int32QuotOp    -> \args -> opTranslate args (MO_S_Quot W32)
-  Int32RemOp     -> \args -> opTranslate args (MO_S_Rem W32)
-
-  Int32SllOp     -> \args -> opTranslate args (MO_Shl W32)
-  Int32SraOp     -> \args -> opTranslate args (MO_S_Shr W32)
-  Int32SrlOp     -> \args -> opTranslate args (MO_U_Shr W32)
-
-  Int32EqOp      -> \args -> opTranslate args (MO_Eq W32)
-  Int32GeOp      -> \args -> opTranslate args (MO_S_Ge W32)
-  Int32GtOp      -> \args -> opTranslate args (MO_S_Gt W32)
-  Int32LeOp      -> \args -> opTranslate args (MO_S_Le W32)
-  Int32LtOp      -> \args -> opTranslate args (MO_S_Lt W32)
-  Int32NeOp      -> \args -> opTranslate args (MO_Ne W32)
-
--- Word32# unsigned ops
-
-  Word32ToWordOp -> \args -> opTranslate args (MO_UU_Conv W32 (wordWidth platform))
-  WordToWord32Op -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W32)
-  Word32AddOp    -> \args -> opTranslate args (MO_Add W32)
-  Word32SubOp    -> \args -> opTranslate args (MO_Sub W32)
-  Word32MulOp    -> \args -> opTranslate args (MO_Mul W32)
-  Word32QuotOp   -> \args -> opTranslate args (MO_U_Quot W32)
-  Word32RemOp    -> \args -> opTranslate args (MO_U_Rem W32)
-
-  Word32AndOp    -> \args -> opTranslate args (MO_And W32)
-  Word32OrOp     -> \args -> opTranslate args (MO_Or W32)
-  Word32XorOp    -> \args -> opTranslate args (MO_Xor W32)
-  Word32NotOp    -> \args -> opTranslate args (MO_Not W32)
-  Word32SllOp    -> \args -> opTranslate args (MO_Shl W32)
-  Word32SrlOp    -> \args -> opTranslate args (MO_U_Shr W32)
-
-  Word32EqOp     -> \args -> opTranslate args (MO_Eq W32)
-  Word32GeOp     -> \args -> opTranslate args (MO_U_Ge W32)
-  Word32GtOp     -> \args -> opTranslate args (MO_U_Gt W32)
-  Word32LeOp     -> \args -> opTranslate args (MO_U_Le W32)
-  Word32LtOp     -> \args -> opTranslate args (MO_U_Lt W32)
-  Word32NeOp     -> \args -> opTranslate args (MO_Ne W32)
-
--- Int64# signed ops
-
-  Int64ToIntOp   -> \args -> opTranslate64 args (\w -> MO_SS_Conv w (wordWidth platform)) MO_I64_ToI
-  IntToInt64Op   -> \args -> opTranslate64 args (\w -> MO_SS_Conv (wordWidth platform) w) MO_I64_FromI
-  Int64NegOp     -> \args -> opTranslate64 args MO_S_Neg  MO_x64_Neg
-  Int64AddOp     -> \args -> opTranslate64 args MO_Add    MO_x64_Add
-  Int64SubOp     -> \args -> opTranslate64 args MO_Sub    MO_x64_Sub
-  Int64MulOp     -> \args -> opTranslate64 args MO_Mul    MO_x64_Mul
-  Int64QuotOp    -> \args -> opTranslate64 args MO_S_Quot MO_I64_Quot
-  Int64RemOp     -> \args -> opTranslate64 args MO_S_Rem  MO_I64_Rem
-
-  Int64SllOp     -> \args -> opTranslate64 args MO_Shl    MO_x64_Shl
-  Int64SraOp     -> \args -> opTranslate64 args MO_S_Shr  MO_I64_Shr
-  Int64SrlOp     -> \args -> opTranslate64 args MO_U_Shr  MO_W64_Shr
-
-  Int64EqOp      -> \args -> opTranslate64 args MO_Eq     MO_x64_Eq
-  Int64GeOp      -> \args -> opTranslate64 args MO_S_Ge   MO_I64_Ge
-  Int64GtOp      -> \args -> opTranslate64 args MO_S_Gt   MO_I64_Gt
-  Int64LeOp      -> \args -> opTranslate64 args MO_S_Le   MO_I64_Le
-  Int64LtOp      -> \args -> opTranslate64 args MO_S_Lt   MO_I64_Lt
-  Int64NeOp      -> \args -> opTranslate64 args MO_Ne     MO_x64_Ne
-
--- Word64# unsigned ops
-
-  Word64ToWordOp -> \args -> opTranslate64 args (\w -> MO_UU_Conv w (wordWidth platform)) MO_W64_ToW
-  WordToWord64Op -> \args -> opTranslate64 args (\w -> MO_UU_Conv (wordWidth platform) w) MO_W64_FromW
-  Word64AddOp    -> \args -> opTranslate64 args MO_Add    MO_x64_Add
-  Word64SubOp    -> \args -> opTranslate64 args MO_Sub    MO_x64_Sub
-  Word64MulOp    -> \args -> opTranslate64 args MO_Mul    MO_x64_Mul
-  Word64QuotOp   -> \args -> opTranslate64 args MO_U_Quot MO_W64_Quot
-  Word64RemOp    -> \args -> opTranslate64 args MO_U_Rem  MO_W64_Rem
-
-  Word64AndOp    -> \args -> opTranslate64 args MO_And    MO_x64_And
-  Word64OrOp     -> \args -> opTranslate64 args MO_Or     MO_x64_Or
-  Word64XorOp    -> \args -> opTranslate64 args MO_Xor    MO_x64_Xor
-  Word64NotOp    -> \args -> opTranslate64 args MO_Not    MO_x64_Not
-  Word64SllOp    -> \args -> opTranslate64 args MO_Shl    MO_x64_Shl
-  Word64SrlOp    -> \args -> opTranslate64 args MO_U_Shr  MO_W64_Shr
-
-  Word64EqOp     -> \args -> opTranslate64 args MO_Eq     MO_x64_Eq
-  Word64GeOp     -> \args -> opTranslate64 args MO_U_Ge   MO_W64_Ge
-  Word64GtOp     -> \args -> opTranslate64 args MO_U_Gt   MO_W64_Gt
-  Word64LeOp     -> \args -> opTranslate64 args MO_U_Le   MO_W64_Le
-  Word64LtOp     -> \args -> opTranslate64 args MO_U_Lt   MO_W64_Lt
-  Word64NeOp     -> \args -> opTranslate64 args MO_Ne     MO_x64_Ne
-
--- Char# ops
-
-  CharEqOp       -> \args -> opTranslate args (MO_Eq (wordWidth platform))
-  CharNeOp       -> \args -> opTranslate args (MO_Ne (wordWidth platform))
-  CharGeOp       -> \args -> opTranslate args (MO_U_Ge (wordWidth platform))
-  CharLeOp       -> \args -> opTranslate args (MO_U_Le (wordWidth platform))
-  CharGtOp       -> \args -> opTranslate args (MO_U_Gt (wordWidth platform))
-  CharLtOp       -> \args -> opTranslate args (MO_U_Lt (wordWidth platform))
-
--- Double ops
-
-  DoubleEqOp     -> \args -> opTranslate args (MO_F_Eq W64)
-  DoubleNeOp     -> \args -> opTranslate args (MO_F_Ne W64)
-  DoubleGeOp     -> \args -> opTranslate args (MO_F_Ge W64)
-  DoubleLeOp     -> \args -> opTranslate args (MO_F_Le W64)
-  DoubleGtOp     -> \args -> opTranslate args (MO_F_Gt W64)
-  DoubleLtOp     -> \args -> opTranslate args (MO_F_Lt W64)
-
-  DoubleAddOp    -> \args -> opTranslate args (MO_F_Add W64)
-  DoubleSubOp    -> \args -> opTranslate args (MO_F_Sub W64)
-  DoubleMulOp    -> \args -> opTranslate args (MO_F_Mul W64)
-  DoubleDivOp    -> \args -> opTranslate args (MO_F_Quot W64)
-  DoubleNegOp    -> \args -> opTranslate args (MO_F_Neg W64)
-
--- Float ops
-
-  FloatEqOp     -> \args -> opTranslate args (MO_F_Eq W32)
-  FloatNeOp     -> \args -> opTranslate args (MO_F_Ne W32)
-  FloatGeOp     -> \args -> opTranslate args (MO_F_Ge W32)
-  FloatLeOp     -> \args -> opTranslate args (MO_F_Le W32)
-  FloatGtOp     -> \args -> opTranslate args (MO_F_Gt W32)
-  FloatLtOp     -> \args -> opTranslate args (MO_F_Lt W32)
-
-  FloatAddOp    -> \args -> opTranslate args (MO_F_Add  W32)
-  FloatSubOp    -> \args -> opTranslate args (MO_F_Sub  W32)
-  FloatMulOp    -> \args -> opTranslate args (MO_F_Mul  W32)
-  FloatDivOp    -> \args -> opTranslate args (MO_F_Quot W32)
-  FloatNegOp    -> \args -> opTranslate args (MO_F_Neg  W32)
-
--- Vector ops
-
-  (VecAddOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Add  n w)
-  (VecSubOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Sub  n w)
-  (VecMulOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Mul  n w)
-  (VecDivOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Quot n w)
-  (VecQuotOp FloatVec _ _) -> \_ -> panic "unsupported primop"
-  (VecRemOp  FloatVec _ _) -> \_ -> panic "unsupported primop"
-  (VecNegOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Neg  n w)
-
-  (VecAddOp  IntVec n w) -> \args -> opTranslate args (MO_V_Add   n w)
-  (VecSubOp  IntVec n w) -> \args -> opTranslate args (MO_V_Sub   n w)
-  (VecMulOp  IntVec n w) -> \args -> opTranslate args (MO_V_Mul   n w)
-  (VecDivOp  IntVec _ _) -> \_ -> panic "unsupported primop"
-  (VecQuotOp IntVec n w) -> \args -> opTranslate args (MO_VS_Quot n w)
-  (VecRemOp  IntVec n w) -> \args -> opTranslate args (MO_VS_Rem  n w)
-  (VecNegOp  IntVec n w) -> \args -> opTranslate args (MO_VS_Neg  n w)
-
-  (VecAddOp  WordVec n w) -> \args -> opTranslate args (MO_V_Add   n w)
-  (VecSubOp  WordVec n w) -> \args -> opTranslate args (MO_V_Sub   n w)
-  (VecMulOp  WordVec n w) -> \args -> opTranslate args (MO_V_Mul   n w)
-  (VecDivOp  WordVec _ _) -> \_ -> panic "unsupported primop"
-  (VecQuotOp WordVec n w) -> \args -> opTranslate args (MO_VU_Quot n w)
-  (VecRemOp  WordVec n w) -> \args -> opTranslate args (MO_VU_Rem  n w)
-  (VecNegOp  WordVec _ _) -> \_ -> panic "unsupported primop"
-
--- Conversions
-
-  IntToDoubleOp   -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W64)
-  DoubleToIntOp   -> \args -> opTranslate args (MO_FS_Conv W64 (wordWidth platform))
-
-  IntToFloatOp    -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W32)
-  FloatToIntOp    -> \args -> opTranslate args (MO_FS_Conv W32 (wordWidth platform))
-
-  FloatToDoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64)
-  DoubleToFloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32)
-
-  IntQuotRemOp -> \args -> opCallishHandledLater args $
-    if allowQuotRem && not (quotRemCanBeOptimized args)
-    then Left (MO_S_QuotRem  (wordWidth platform))
-    else Right (genericIntQuotRemOp (wordWidth platform))
-
-  Int8QuotRemOp -> \args -> opCallishHandledLater args $
-    if allowQuotRem && not (quotRemCanBeOptimized args)
-    then Left (MO_S_QuotRem W8)
-    else Right (genericIntQuotRemOp W8)
-
-  Int16QuotRemOp -> \args -> opCallishHandledLater args $
-    if allowQuotRem && not (quotRemCanBeOptimized args)
-    then Left (MO_S_QuotRem W16)
-    else Right (genericIntQuotRemOp W16)
-
-  Int32QuotRemOp -> \args -> opCallishHandledLater args $
-    if allowQuotRem && not (quotRemCanBeOptimized args)
-    then Left (MO_S_QuotRem W32)
-    else Right (genericIntQuotRemOp W32)
-
-  WordQuotRemOp -> \args -> opCallishHandledLater args $
-    if allowQuotRem && not (quotRemCanBeOptimized args)
-    then Left (MO_U_QuotRem  (wordWidth platform))
-    else Right (genericWordQuotRemOp (wordWidth platform))
-
-  WordQuotRem2Op -> \args -> opCallishHandledLater args $
-    if allowQuotRem2
-    then Left (MO_U_QuotRem2 (wordWidth platform))
-    else Right (genericWordQuotRem2Op platform)
-
-  Word8QuotRemOp -> \args -> opCallishHandledLater args $
-    if allowQuotRem && not (quotRemCanBeOptimized args)
-    then Left (MO_U_QuotRem W8)
-    else Right (genericWordQuotRemOp W8)
-
-  Word16QuotRemOp -> \args -> opCallishHandledLater args $
-    if allowQuotRem && not (quotRemCanBeOptimized args)
-    then Left (MO_U_QuotRem W16)
-    else Right (genericWordQuotRemOp W16)
-
-  Word32QuotRemOp -> \args -> opCallishHandledLater args $
-    if allowQuotRem && not (quotRemCanBeOptimized args)
-    then Left (MO_U_QuotRem W32)
-    else Right (genericWordQuotRemOp W32)
-
-  WordAdd2Op -> \args -> opCallishHandledLater args $
-    if allowExtAdd
-    then Left (MO_Add2       (wordWidth platform))
-    else Right genericWordAdd2Op
-
-  WordAddCOp -> \args -> opCallishHandledLater args $
-    if allowExtAdd
-    then Left (MO_AddWordC   (wordWidth platform))
-    else Right genericWordAddCOp
-
-  WordSubCOp -> \args -> opCallishHandledLater args $
-    if allowExtAdd
-    then Left (MO_SubWordC   (wordWidth platform))
-    else Right genericWordSubCOp
-
-  IntAddCOp -> \args -> opCallishHandledLater args $
-    if allowExtAdd
-    then Left (MO_AddIntC    (wordWidth platform))
-    else Right genericIntAddCOp
-
-  IntSubCOp -> \args -> opCallishHandledLater args $
-    if allowExtAdd
-    then Left (MO_SubIntC    (wordWidth platform))
-    else Right genericIntSubCOp
-
-  WordMul2Op -> \args -> opCallishHandledLater args $
-    if allowExtAdd
-    then Left (MO_U_Mul2     (wordWidth platform))
-    else Right genericWordMul2Op
-
-  IntMul2Op  -> \args -> opCallishHandledLater args $
-    if allowInt2Mul
-    then Left (MO_S_Mul2     (wordWidth platform))
-    else Right genericIntMul2Op
-
-  -- tagToEnum# is special: we need to pull the constructor
-  -- out of the table, and perform an appropriate return.
-  TagToEnumOp -> \[amode] -> PrimopCmmEmit_Internal $ \res_ty -> do
-    -- If you're reading this code in the attempt to figure
-    -- out why the compiler panic'ed here, it is probably because
-    -- you used tagToEnum# in a non-monomorphic setting, e.g.,
-    --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
-    -- That won't work.
-    let tycon = fromMaybe (pprPanic "tagToEnum#: Applied to non-concrete type" (ppr res_ty)) (tyConAppTyCon_maybe res_ty)
-    massert (isEnumerationTyCon tycon)
-    platform <- getPlatform
-    pure [tagToClosure platform tycon amode]
-
--- Out of line primops.
--- TODO compiler need not know about these
-
-  UnsafeThawArrayOp -> alwaysExternal
-  CasArrayOp -> alwaysExternal
-  UnsafeThawSmallArrayOp -> alwaysExternal
-  CasSmallArrayOp -> alwaysExternal
-  NewPinnedByteArrayOp_Char -> alwaysExternal
-  NewAlignedPinnedByteArrayOp_Char -> alwaysExternal
-  MutableByteArrayIsPinnedOp -> alwaysExternal
-  DoubleDecode_2IntOp -> alwaysExternal
-  DoubleDecode_Int64Op -> alwaysExternal
-  FloatDecode_IntOp -> alwaysExternal
-  ByteArrayIsPinnedOp -> alwaysExternal
-  ShrinkMutableByteArrayOp_Char -> alwaysExternal
-  ResizeMutableByteArrayOp_Char -> alwaysExternal
-  ShrinkSmallMutableArrayOp_Char -> alwaysExternal
-  NewMutVarOp -> alwaysExternal
-  AtomicModifyMutVar2Op -> alwaysExternal
-  AtomicModifyMutVar_Op -> alwaysExternal
-  CasMutVarOp -> alwaysExternal
-  CatchOp -> alwaysExternal
-  RaiseOp -> alwaysExternal
-  RaiseUnderflowOp -> alwaysExternal
-  RaiseOverflowOp -> alwaysExternal
-  RaiseDivZeroOp -> alwaysExternal
-  RaiseIOOp -> alwaysExternal
-  MaskAsyncExceptionsOp -> alwaysExternal
-  MaskUninterruptibleOp -> alwaysExternal
-  UnmaskAsyncExceptionsOp -> alwaysExternal
-  MaskStatus -> alwaysExternal
-  NewPromptTagOp -> alwaysExternal
-  PromptOp -> alwaysExternal
-  Control0Op -> alwaysExternal
-  AtomicallyOp -> alwaysExternal
-  RetryOp -> alwaysExternal
-  CatchRetryOp -> alwaysExternal
-  CatchSTMOp -> alwaysExternal
-  NewTVarOp -> alwaysExternal
-  ReadTVarOp -> alwaysExternal
-  ReadTVarIOOp -> alwaysExternal
-  WriteTVarOp -> alwaysExternal
-  NewMVarOp -> alwaysExternal
-  TakeMVarOp -> alwaysExternal
-  TryTakeMVarOp -> alwaysExternal
-  PutMVarOp -> alwaysExternal
-  TryPutMVarOp -> alwaysExternal
-  ReadMVarOp -> alwaysExternal
-  TryReadMVarOp -> alwaysExternal
-  IsEmptyMVarOp -> alwaysExternal
-  NewIOPortOp -> alwaysExternal
-  ReadIOPortOp -> alwaysExternal
-  WriteIOPortOp -> alwaysExternal
-  DelayOp -> alwaysExternal
-  WaitReadOp -> alwaysExternal
-  WaitWriteOp -> alwaysExternal
-  ForkOp -> alwaysExternal
-  ForkOnOp -> alwaysExternal
-  KillThreadOp -> alwaysExternal
-  YieldOp -> alwaysExternal
-  LabelThreadOp -> alwaysExternal
-  IsCurrentThreadBoundOp -> alwaysExternal
-  NoDuplicateOp -> alwaysExternal
-  GetThreadLabelOp -> alwaysExternal
-  ThreadStatusOp -> alwaysExternal
-  MkWeakOp -> alwaysExternal
-  MkWeakNoFinalizerOp -> alwaysExternal
-  AddCFinalizerToWeakOp -> alwaysExternal
-  DeRefWeakOp -> alwaysExternal
-  FinalizeWeakOp -> alwaysExternal
-  MakeStablePtrOp -> alwaysExternal
-  DeRefStablePtrOp -> alwaysExternal
-  MakeStableNameOp -> alwaysExternal
-  CompactNewOp -> alwaysExternal
-  CompactResizeOp -> alwaysExternal
-  CompactContainsOp -> alwaysExternal
-  CompactContainsAnyOp -> alwaysExternal
-  CompactGetFirstBlockOp -> alwaysExternal
-  CompactGetNextBlockOp -> alwaysExternal
-  CompactAllocateBlockOp -> alwaysExternal
-  CompactFixupPointersOp -> alwaysExternal
-  CompactAdd -> alwaysExternal
-  CompactAddWithSharing -> alwaysExternal
-  CompactSize -> alwaysExternal
-  SeqOp -> alwaysExternal
-  GetSparkOp -> alwaysExternal
-  NumSparks -> alwaysExternal
-  DataToTagOp -> alwaysExternal
-  MkApUpd0_Op -> alwaysExternal
-  NewBCOOp -> alwaysExternal
-  UnpackClosureOp -> alwaysExternal
-  ListThreadsOp -> alwaysExternal
-  ClosureSizeOp -> alwaysExternal
-  WhereFromOp   -> alwaysExternal
-  GetApStackValOp -> alwaysExternal
-  ClearCCSOp -> alwaysExternal
-  TraceEventOp -> alwaysExternal
-  TraceEventBinaryOp -> alwaysExternal
-  TraceMarkerOp -> alwaysExternal
-  SetThreadAllocationCounter -> alwaysExternal
-  KeepAliveOp -> alwaysExternal
-
- where
-  profile  = stgToCmmProfile  cfg
-  platform = stgToCmmPlatform cfg
-  result_info = getPrimOpResultInfo primop
-
-  opNop :: [CmmExpr] -> PrimopCmmEmit
-  opNop args = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) arg
-    where [arg] = args
-
-  opNarrow
-    :: [CmmExpr]
-    -> (Width -> Width -> MachOp, Width)
-    -> PrimopCmmEmit
-  opNarrow args (mop, rep) = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) $
-    CmmMachOp (mop rep (wordWidth platform)) [CmmMachOp (mop (wordWidth platform) rep) [arg]]
-    where [arg] = args
-
-  -- These primops are implemented by CallishMachOps, because they sometimes
-  -- turn into foreign calls depending on the backend.
-  opCallish :: [CmmExpr] -> CallishMachOp -> PrimopCmmEmit
-  opCallish args prim = opIntoRegs $ \[res] -> emitPrimCall [res] prim args
-
-  opTranslate :: [CmmExpr] -> MachOp -> PrimopCmmEmit
-  opTranslate args mop = opIntoRegs $ \[res] -> do
-    let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args)
-    emit stmt
-
-  opTranslate64
-    :: [CmmExpr]
-    -> (Width -> MachOp)
-    -> CallishMachOp
-    -> PrimopCmmEmit
-  opTranslate64 args mkMop callish =
-    case platformWordSize platform of
-      -- LLVM and C `can handle larger than native size arithmetic natively.
-      _ | stgToCmmAllowBigArith cfg -> opTranslate args $ mkMop W64
-      PW4 -> opCallish args callish
-      PW8 -> opTranslate args $ mkMop W64
-
-  -- Basically a "manual" case, rather than one of the common repetitive forms
-  -- above. The results are a parameter to the returned function so we know the
-  -- choice of variant never depends on them.
-  opCallishHandledLater
-    :: [CmmExpr]
-    -> Either CallishMachOp GenericOp
-    -> PrimopCmmEmit
-  opCallishHandledLater args callOrNot = opIntoRegs $ \res0 -> case callOrNot of
-    Left op   -> emit $ mkUnsafeCall (PrimTarget op) res0 args
-    Right gen -> gen res0 args
-
-  opIntoRegs
-    :: ([LocalReg] -- where to put the results
-        -> FCode ())
-    -> PrimopCmmEmit
-  opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do
-    regs <- case result_info of
-      ReturnsPrim VoidRep -> pure []
-      ReturnsPrim rep
-        -> do reg <- newTemp (primRepCmmType platform rep)
-              pure [reg]
-
-      ReturnsAlg tycon | isUnboxedTupleTyCon tycon
-        -> do (regs, _hints) <- newUnboxedTupleRegs res_ty
-              pure regs
-
-      _ -> panic "cgOpApp"
-    f regs
-    pure $ map (CmmReg . CmmLocal) regs
-
-  alwaysExternal = \_ -> PrimopCmmEmit_External
-  -- Note [QuotRem optimization]
-  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops
-  -- (shift, .&.).
-  --
-  -- Currently we only support optimization (performed in GHC.Cmm.Opt) when the
-  -- constant is a power of 2. #9041 tracks the implementation of the general
-  -- optimization.
-  --
-  -- `quotRem` can be optimized in the same way. However as it returns two values,
-  -- it is implemented as a "callish" primop which is harder to match and
-  -- to transform later on. For simplicity, the current implementation detects cases
-  -- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem
-  -- primop into two CMM quot and rem primops.
-  quotRemCanBeOptimized = \case
-    [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n)
-    _                         -> False
-
-  allowQuotRem  = stgToCmmAllowQuotRemInstr         cfg
-  allowQuotRem2 = stgToCmmAllowQuotRem2             cfg
-  allowExtAdd   = stgToCmmAllowExtendedAddSubInstrs cfg
-  allowInt2Mul  = stgToCmmAllowIntMul2Instr         cfg
-
-data PrimopCmmEmit
-  -- | Out of line fake primop that's actually just a foreign call to other
-  -- (presumably) C--.
-  = PrimopCmmEmit_External
-  -- | Real primop turned into inline C--.
-  | PrimopCmmEmit_Internal (Type -- the return type, some primops are specialized to it
-                            -> FCode [CmmExpr]) -- just for TagToEnum for now
-
-type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()
-
-genericIntQuotRemOp :: Width -> GenericOp
-genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]
-   = emit $ mkAssign (CmmLocal res_q)
-              (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>
-            mkAssign (CmmLocal res_r)
-              (CmmMachOp (MO_S_Rem  width) [arg_x, arg_y])
-genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"
-
-genericWordQuotRemOp :: Width -> GenericOp
-genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]
-    = emit $ mkAssign (CmmLocal res_q)
-               (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>
-             mkAssign (CmmLocal res_r)
-               (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y])
-genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"
-
-genericWordQuotRem2Op :: Platform -> GenericOp
-genericWordQuotRem2Op platform [res_q, res_r] [arg_x_high, arg_x_low, arg_y]
-    = emit =<< f (widthInBits (wordWidth platform)) zero arg_x_high arg_x_low
-    where    ty = cmmExprType platform arg_x_high
-             shl   x i = CmmMachOp (MO_Shl   (wordWidth platform)) [x, i]
-             shr   x i = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, i]
-             or    x y = CmmMachOp (MO_Or    (wordWidth platform)) [x, y]
-             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth platform)) [x, y]
-             ne    x y = CmmMachOp (MO_Ne    (wordWidth platform)) [x, y]
-             minus x y = CmmMachOp (MO_Sub   (wordWidth platform)) [x, y]
-             times x y = CmmMachOp (MO_Mul   (wordWidth platform)) [x, y]
-             zero   = lit 0
-             one    = lit 1
-             negone = lit (fromIntegral (platformWordSizeInBits platform) - 1)
-             lit i = CmmLit (CmmInt i (wordWidth platform))
-
-             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph
-             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>
-                                      mkAssign (CmmLocal res_r) high)
-             f i acc high low =
-                 do roverflowedBit <- newTemp ty
-                    rhigh'         <- newTemp ty
-                    rhigh''        <- newTemp ty
-                    rlow'          <- newTemp ty
-                    risge          <- newTemp ty
-                    racc'          <- newTemp ty
-                    let high'         = CmmReg (CmmLocal rhigh')
-                        isge          = CmmReg (CmmLocal risge)
-                        overflowedBit = CmmReg (CmmLocal roverflowedBit)
-                    let this = catAGraphs
-                               [mkAssign (CmmLocal roverflowedBit)
-                                          (shr high negone),
-                                mkAssign (CmmLocal rhigh')
-                                          (or (shl high one) (shr low negone)),
-                                mkAssign (CmmLocal rlow')
-                                          (shl low one),
-                                mkAssign (CmmLocal risge)
-                                          (or (overflowedBit `ne` zero)
-                                              (high' `ge` arg_y)),
-                                mkAssign (CmmLocal rhigh'')
-                                          (high' `minus` (arg_y `times` isge)),
-                                mkAssign (CmmLocal racc')
-                                          (or (shl acc one) isge)]
-                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))
-                                      (CmmReg (CmmLocal rhigh''))
-                                      (CmmReg (CmmLocal rlow'))
-                    return (this <*> rest)
-genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"
-
-genericWordAdd2Op :: GenericOp
-genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]
-  = do platform <- getPlatform
-       r1 <- newTemp (cmmExprType platform arg_x)
-       r2 <- newTemp (cmmExprType platform arg_x)
-       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww]
-           toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww]
-           bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm]
-           add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y]
-           or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]
-           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform)))
-                                (wordWidth platform))
-           hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform))
-       emit $ catAGraphs
-          [mkAssign (CmmLocal r1)
-               (add (bottomHalf arg_x) (bottomHalf arg_y)),
-           mkAssign (CmmLocal r2)
-               (add (topHalf (CmmReg (CmmLocal r1)))
-                    (add (topHalf arg_x) (topHalf arg_y))),
-           mkAssign (CmmLocal res_h)
-               (topHalf (CmmReg (CmmLocal r2))),
-           mkAssign (CmmLocal res_l)
-               (or (toTopHalf (CmmReg (CmmLocal r2)))
-                   (bottomHalf (CmmReg (CmmLocal r1))))]
-genericWordAdd2Op _ _ = panic "genericWordAdd2Op"
-
--- | Implements branchless recovery of the carry flag @c@ by checking the
--- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@:
---
--- @
---    c = a&b | (a|b)&~r
--- @
---
--- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/
-genericWordAddCOp :: GenericOp
-genericWordAddCOp [res_r, res_c] [aa, bb]
- = do platform <- getPlatform
-      emit $ catAGraphs [
-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]),
-        mkAssign (CmmLocal res_c) $
-          CmmMachOp (mo_wordUShr platform) [
-            CmmMachOp (mo_wordOr platform) [
-              CmmMachOp (mo_wordAnd platform) [aa,bb],
-              CmmMachOp (mo_wordAnd platform) [
-                CmmMachOp (mo_wordOr platform) [aa,bb],
-                CmmMachOp (mo_wordNot platform) [CmmReg (CmmLocal res_r)]
-              ]
-            ],
-            mkIntExpr platform (platformWordSizeInBits platform - 1)
-          ]
-        ]
-genericWordAddCOp _ _ = panic "genericWordAddCOp"
-
--- | Implements branchless recovery of the carry flag @c@ by checking the
--- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@:
---
--- @
---    c = ~a&b | (~a|b)&r
--- @
---
--- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/
-genericWordSubCOp :: GenericOp
-genericWordSubCOp [res_r, res_c] [aa, bb]
- = do platform <- getPlatform
-      emit $ catAGraphs [
-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]),
-        mkAssign (CmmLocal res_c) $
-          CmmMachOp (mo_wordUShr platform) [
-            CmmMachOp (mo_wordOr platform) [
-              CmmMachOp (mo_wordAnd platform) [
-                CmmMachOp (mo_wordNot platform) [aa],
-                bb
-              ],
-              CmmMachOp (mo_wordAnd platform) [
-                CmmMachOp (mo_wordOr platform) [
-                  CmmMachOp (mo_wordNot platform) [aa],
-                  bb
-                ],
-                CmmReg (CmmLocal res_r)
-              ]
-            ],
-            mkIntExpr platform (platformWordSizeInBits platform - 1)
-          ]
-        ]
-genericWordSubCOp _ _ = panic "genericWordSubCOp"
-
-genericIntAddCOp :: GenericOp
-genericIntAddCOp [res_r, res_c] [aa, bb]
-{-
-   With some bit-twiddling, we can define int{Add,Sub}Czh portably in
-   C, and without needing any comparisons.  This may not be the
-   fastest way to do it - if you have better code, please send it! --SDM
-
-   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
-
-   We currently don't make use of the r value if c is != 0 (i.e.
-   overflow), we just convert to big integers and try again.  This
-   could be improved by making r and c the correct values for
-   plugging into a new J#.
-
-   { r = ((I_)(a)) + ((I_)(b));                                 \
-     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \
-         >> (BITS_IN (I_) - 1);                                 \
-   }
-   Wading through the mass of bracketry, it seems to reduce to:
-   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
-
--}
- = do platform <- getPlatform
-      emit $ catAGraphs [
-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]),
-        mkAssign (CmmLocal res_c) $
-          CmmMachOp (mo_wordUShr platform) [
-                CmmMachOp (mo_wordAnd platform) [
-                    CmmMachOp (mo_wordNot platform) [CmmMachOp (mo_wordXor platform) [aa,bb]],
-                    CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]
-                ],
-                mkIntExpr platform (platformWordSizeInBits platform - 1)
-          ]
-        ]
-genericIntAddCOp _ _ = panic "genericIntAddCOp"
-
-genericIntSubCOp :: GenericOp
-genericIntSubCOp [res_r, res_c] [aa, bb]
-{- Similarly:
-   #define subIntCzh(r,c,a,b)                                   \
-   { r = ((I_)(a)) - ((I_)(b));                                 \
-     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \
-         >> (BITS_IN (I_) - 1);                                 \
-   }
-
-   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
--}
- = do platform <- getPlatform
-      emit $ catAGraphs [
-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]),
-        mkAssign (CmmLocal res_c) $
-          CmmMachOp (mo_wordUShr platform) [
-                CmmMachOp (mo_wordAnd platform) [
-                    CmmMachOp (mo_wordXor platform) [aa,bb],
-                    CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]
-                ],
-                mkIntExpr platform (platformWordSizeInBits platform - 1)
-          ]
-        ]
-genericIntSubCOp _ _ = panic "genericIntSubCOp"
-
-genericWordMul2Op :: GenericOp
-genericWordMul2Op [res_h, res_l] [arg_x, arg_y]
- = do platform <- getPlatform
-      let t = cmmExprType platform arg_x
-      xlyl <- liftM CmmLocal $ newTemp t
-      xlyh <- liftM CmmLocal $ newTemp t
-      xhyl <- liftM CmmLocal $ newTemp t
-      r    <- liftM CmmLocal $ newTemp t
-      -- This generic implementation is very simple and slow. We might
-      -- well be able to do better, but for now this at least works.
-      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww]
-          toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww]
-          bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm]
-          add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y]
-          sum = foldl1 add
-          mul x y = CmmMachOp (MO_Mul (wordWidth platform)) [x, y]
-          or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]
-          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform)))
-                               (wordWidth platform))
-          hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform))
-      emit $ catAGraphs
-             [mkAssign xlyl
-                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),
-              mkAssign xlyh
-                  (mul (bottomHalf arg_x) (topHalf arg_y)),
-              mkAssign xhyl
-                  (mul (topHalf arg_x) (bottomHalf arg_y)),
-              mkAssign r
-                  (sum [topHalf    (CmmReg xlyl),
-                        bottomHalf (CmmReg xhyl),
-                        bottomHalf (CmmReg xlyh)]),
-              mkAssign (CmmLocal res_l)
-                  (or (bottomHalf (CmmReg xlyl))
-                      (toTopHalf (CmmReg r))),
-              mkAssign (CmmLocal res_h)
-                  (sum [mul (topHalf arg_x) (topHalf arg_y),
-                        topHalf (CmmReg xhyl),
-                        topHalf (CmmReg xlyh),
-                        topHalf (CmmReg r)])]
-genericWordMul2Op _ _ = panic "genericWordMul2Op"
-
-genericIntMul2Op :: GenericOp
-genericIntMul2Op [res_c, res_h, res_l] both_args@[arg_x, arg_y]
- = do cfg <- getStgToCmmConfig
-      -- Implement algorithm from Hacker's Delight, 2nd edition, p.174
-      let t        = cmmExprType platform arg_x
-          platform = stgToCmmPlatform cfg
-      p   <- newTemp t
-      -- 1) compute the multiplication as if numbers were unsigned
-      _ <- withSequel (AssignTo [p, res_l] False) $
-             cmmPrimOpApp cfg WordMul2Op both_args Nothing
-      -- 2) correct the high bits of the unsigned result
-      let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1]
-          sub x y     = CmmMachOp (MO_Sub   ww) [x, y]
-          and x y     = CmmMachOp (MO_And   ww) [x, y]
-          neq x y     = CmmMachOp (MO_Ne    ww) [x, y]
-          f   x y     = (carryFill x) `and` y
-          wwm1        = CmmLit (CmmInt (fromIntegral (widthInBits ww - 1)) ww)
-          rl x        = CmmReg (CmmLocal x)
-          ww          = wordWidth platform
-      emit $ catAGraphs
-             [ mkAssign (CmmLocal res_h) (rl p `sub` f arg_x arg_y `sub` f arg_y arg_x)
-             , mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l))
-             ]
-genericIntMul2Op _ _ = panic "genericIntMul2Op"
-
-------------------------------------------------------------------------------
--- Helpers for translating various minor variants of array indexing.
-
-alignmentFromTypes :: CmmType  -- ^ element type
-                   -> CmmType  -- ^ index type
-                   -> AlignmentSpec
-alignmentFromTypes ty idx_ty
-  | typeWidth ty < typeWidth idx_ty = NaturallyAligned
-  | otherwise                       = Unaligned
-
-doIndexOffAddrOp :: Maybe MachOp
-                 -> CmmType
-                 -> [LocalReg]
-                 -> [CmmExpr]
-                 -> FCode ()
-doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
-   = mkBasicIndexedRead NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx
-doIndexOffAddrOp _ _ _ _
-   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp"
-
-doIndexOffAddrOpAs :: Maybe MachOp
-                   -> CmmType
-                   -> CmmType
-                   -> [LocalReg]
-                   -> [CmmExpr]
-                   -> FCode ()
-doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]
-   = let alignment = alignmentFromTypes rep idx_rep
-     in mkBasicIndexedRead alignment 0 maybe_post_read_cast rep res addr idx_rep idx
-doIndexOffAddrOpAs _ _ _ _ _
-   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs"
-
-doIndexByteArrayOp :: Maybe MachOp
-                   -> CmmType
-                   -> [LocalReg]
-                   -> [CmmExpr]
-                   -> FCode ()
-doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
-   = do profile <- getProfile
-        doByteArrayBoundsCheck idx addr rep rep
-        mkBasicIndexedRead NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx
-doIndexByteArrayOp _ _ _ _
-   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp"
-
-doIndexByteArrayOpAs :: Maybe MachOp
-                    -> CmmType
-                    -> CmmType
-                    -> [LocalReg]
-                    -> [CmmExpr]
-                    -> FCode ()
-doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]
-   = do profile <- getProfile
-        doByteArrayBoundsCheck idx addr idx_rep rep
-        let alignment = alignmentFromTypes rep idx_rep
-        mkBasicIndexedRead alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx
-doIndexByteArrayOpAs _ _ _ _ _
-   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs"
-
-doReadPtrArrayOp :: LocalReg
-                 -> CmmExpr
-                 -> CmmExpr
-                 -> FCode ()
-doReadPtrArrayOp res addr idx
-   = do profile <- getProfile
-        platform <- getPlatform
-        doPtrArrayBoundsCheck idx addr
-        mkBasicIndexedRead NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx
-
-doWriteOffAddrOp :: Maybe MachOp
-                 -> CmmType
-                 -> [LocalReg]
-                 -> [CmmExpr]
-                 -> FCode ()
-doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]
-   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val
-doWriteOffAddrOp _ _ _ _
-   = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp"
-
-doWriteByteArrayOp :: Maybe MachOp
-                   -> CmmType
-                   -> [LocalReg]
-                   -> [CmmExpr]
-                   -> FCode ()
-doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]
-   = do profile <- getProfile
-        platform <- getPlatform
-        doByteArrayBoundsCheck idx addr idx_ty (cmmExprType platform val)
-        mkBasicIndexedWrite (arrWordsHdrSize profile) maybe_pre_write_cast addr idx_ty idx val
-doWriteByteArrayOp _ _ _ _
-   = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp"
-
-doWritePtrArrayOp :: CmmExpr
-                  -> CmmExpr
-                  -> CmmExpr
-                  -> FCode ()
-doWritePtrArrayOp addr idx val
-  = do profile  <- getProfile
-       platform <- getPlatform
-       let ty = cmmExprType platform val
-           hdr_size = arrPtrsHdrSize profile
-
-       doPtrArrayBoundsCheck idx addr
-
-       -- Update remembered set for non-moving collector
-       whenUpdRemSetEnabled
-           $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform NaturallyAligned hdr_size ty addr ty idx)
-       -- This write barrier is to ensure that the heap writes to the object
-       -- referred to by val have happened before we write val into the array.
-       -- See #12469 for details.
-       emitPrimCall [] MO_WriteBarrier []
-       mkBasicIndexedWrite hdr_size Nothing addr ty idx val
-
-       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
-       -- the write barrier.  We must write a byte into the mark table:
-       -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
-       emit $ mkStore (
-         cmmOffsetExpr platform
-          (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size)
-                         (loadArrPtrsSize profile addr))
-          (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))])
-         ) (CmmLit (CmmInt 1 W8))
-
-loadArrPtrsSize :: Profile -> CmmExpr -> CmmExpr
-loadArrPtrsSize profile addr = cmmLoadBWord platform (cmmOffsetB platform addr off)
- where off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (profileConstants profile)
-       platform = profilePlatform profile
-
-mkBasicIndexedRead :: AlignmentSpec
-                   -> ByteOff      -- Initial offset in bytes
-                   -> Maybe MachOp -- Optional result cast
-                   -> CmmType      -- Type of element we are accessing
-                   -> LocalReg     -- Destination
-                   -> CmmExpr      -- Base address
-                   -> CmmType      -- Type of element by which we are indexing
-                   -> CmmExpr      -- Index
-                   -> FCode ()
-mkBasicIndexedRead alignment off Nothing ty res base idx_ty idx
-   = do platform <- getPlatform
-        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx)
-mkBasicIndexedRead alignment off (Just cast) ty res base idx_ty idx
-   = do platform <- getPlatform
-        emitAssign (CmmLocal res) (CmmMachOp cast [
-                                   cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx])
-
-mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes
-                    -> Maybe MachOp -- Optional value cast
-                    -> CmmExpr      -- Base address
-                    -> CmmType      -- Type of element by which we are indexing
-                    -> CmmExpr      -- Index
-                    -> CmmExpr      -- Value to write
-                    -> FCode ()
-mkBasicIndexedWrite off Nothing base idx_ty idx val
-   = do platform <- getPlatform
-        let alignment = alignmentFromTypes (cmmExprType platform val) idx_ty
-        emitStore' alignment (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val
-mkBasicIndexedWrite off (Just cast) base idx_ty idx val
-   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])
-
--- ----------------------------------------------------------------------------
--- Misc utils
-
-cmmIndexOffExpr :: Platform
-                -> ByteOff  -- Initial offset in bytes
-                -> Width    -- Width of element by which we are indexing
-                -> CmmExpr  -- Base address
-                -> CmmExpr  -- Index
-                -> CmmExpr
-cmmIndexOffExpr platform off width base idx
-   = cmmIndexExpr platform width (cmmOffsetB platform base off) idx
-
-cmmLoadIndexOffExpr :: Platform
-                    -> AlignmentSpec
-                    -> ByteOff  -- Initial offset in bytes
-                    -> CmmType  -- Type of element we are accessing
-                    -> CmmExpr  -- Base address
-                    -> CmmType  -- Type of element by which we are indexing
-                    -> CmmExpr  -- Index
-                    -> CmmExpr
-cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx
-   = CmmLoad (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) ty alignment
-
-setInfo :: CmmExpr -> CmmExpr -> CmmAGraph
-setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr
-
-------------------------------------------------------------------------------
--- Helpers for translating vector primops.
-
-vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType
-vecVmmType pocat n w = vec n (vecCmmCat pocat w)
-
-vecCmmCat :: PrimOpVecCat -> Width -> CmmType
-vecCmmCat IntVec   = cmmBits
-vecCmmCat WordVec  = cmmBits
-vecCmmCat FloatVec = cmmFloat
-
--- Note [SIMD Design for the future]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Check to make sure that we can generate code for the specified vector type
--- given the current set of dynamic flags.
--- Currently these checks are specific to x86 and x86_64 architecture.
--- This should be fixed!
--- In particular,
--- 1) Add better support for other architectures! (this may require a redesign)
--- 2) Decouple design choices from LLVM's pseudo SIMD model!
---   The high level LLVM naive rep makes per CPU family SIMD generation is own
---   optimization problem, and hides important differences in eg ARM vs x86_64 simd
--- 3) Depending on the architecture, the SIMD registers may also support general
---    computations on Float/Double/Word/Int scalars, but currently on
---    for example x86_64, we always put Word/Int (or sized) in GPR
---    (general purpose) registers. Would relaxing that allow for
---    useful optimization opportunities?
---      Phrased differently, it is worth experimenting with supporting
---    different register mapping strategies than we currently have, especially if
---    someday we want SIMD to be a first class denizen in GHC along with scalar
---    values!
---      The current design with respect to register mapping of scalars could
---    very well be the best,but exploring the  design space and doing careful
---    measurements is the only way to validate that.
---      In some next generation CPU ISAs, notably RISC V, the SIMD extension
---    includes  support for a sort of run time CPU dependent vectorization parameter,
---    where a loop may act upon a single scalar each iteration OR some 2,4,8 ...
---    element chunk! Time will tell if that direction sees wide adoption,
---    but it is from that context that unifying our handling of simd and scalars
---    may benefit. It is not likely to benefit current architectures, though
---    it may very well be a design perspective that helps guide improving the NCG.
-
-
-checkVecCompatibility :: StgToCmmConfig -> PrimOpVecCat -> Length -> Width -> FCode ()
-checkVecCompatibility cfg vcat l w =
-  case stgToCmmVecInstrsErr cfg of
-    Nothing  -> check vecWidth vcat l w  -- We are in a compatible backend
-    Just err -> sorry err                -- incompatible backend, do panic
-  where
-    platform = stgToCmmPlatform cfg
-    check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()
-    check W128 FloatVec 4 W32 | not (isSseEnabled platform) =
-        sorry $ "128-bit wide single-precision floating point " ++
-                "SIMD vector instructions require at least -msse."
-    check W128 _ _ _ | not (isSse2Enabled platform) =
-        sorry $ "128-bit wide integer and double precision " ++
-                "SIMD vector instructions require at least -msse2."
-    check W256 FloatVec _ _ | not (stgToCmmAvx cfg) =
-        sorry $ "256-bit wide floating point " ++
-                "SIMD vector instructions require at least -mavx."
-    check W256 _ _ _ | not (stgToCmmAvx2 cfg) =
-        sorry $ "256-bit wide integer " ++
-                "SIMD vector instructions require at least -mavx2."
-    check W512 _ _ _ | not (stgToCmmAvx512f cfg) =
-        sorry $ "512-bit wide " ++
-                "SIMD vector instructions require -mavx512f."
-    check _ _ _ _ = return ()
-
-    vecWidth = typeWidth (vecVmmType vcat l w)
-
-------------------------------------------------------------------------------
--- Helpers for translating vector packing and unpacking.
-
-doVecPackOp :: CmmType       -- Type of vector
-            -> CmmExpr       -- Initial vector
-            -> [CmmExpr]     -- Elements
-            -> CmmFormal     -- Destination for result
-            -> FCode ()
-doVecPackOp ty z es res = do
-    dst <- newTemp ty
-    emitAssign (CmmLocal dst) z
-    vecPack dst es 0
-  where
-    vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode ()
-    vecPack src [] _ =
-        emitAssign (CmmLocal res) (CmmReg (CmmLocal src))
-
-    vecPack src (e : es) i = do
-        dst <- newTemp ty
-        if isFloatType (vecElemType ty)
-          then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)
-                                                    [CmmReg (CmmLocal src), e, iLit])
-          else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)
-                                                    [CmmReg (CmmLocal src), e, iLit])
-        vecPack dst es (i + 1)
-      where
-        -- vector indices are always 32-bits
-        iLit = CmmLit (CmmInt (toInteger i) W32)
-
-    len :: Length
-    len = vecLength ty
-
-    wid :: Width
-    wid = typeWidth (vecElemType ty)
-
-doVecUnpackOp :: CmmType       -- Type of vector
-              -> CmmExpr       -- Vector
-              -> [CmmFormal]   -- Element results
-              -> FCode ()
-doVecUnpackOp ty e res =
-    vecUnpack res 0
-  where
-    vecUnpack :: [CmmFormal] -> Int -> FCode ()
-    vecUnpack [] _ =
-        return ()
-
-    vecUnpack (r : rs) i = do
-        if isFloatType (vecElemType ty)
-          then emitAssign (CmmLocal r) (CmmMachOp (MO_VF_Extract len wid)
-                                             [e, iLit])
-          else emitAssign (CmmLocal r) (CmmMachOp (MO_V_Extract len wid)
-                                             [e, iLit])
-        vecUnpack rs (i + 1)
-      where
-        -- vector indices are always 32-bits
-        iLit = CmmLit (CmmInt (toInteger i) W32)
-
-    len :: Length
-    len = vecLength ty
-
-    wid :: Width
-    wid = typeWidth (vecElemType ty)
-
-doVecInsertOp :: CmmType       -- Vector type
-              -> CmmExpr       -- Source vector
-              -> CmmExpr       -- Element
-              -> CmmExpr       -- Index at which to insert element
-              -> CmmFormal     -- Destination for result
-              -> FCode ()
-doVecInsertOp ty src e idx res = do
-    platform <- getPlatform
-    -- vector indices are always 32-bits
-    let idx' :: CmmExpr
-        idx' = CmmMachOp (MO_SS_Conv (wordWidth platform) W32) [idx]
-    if isFloatType (vecElemType ty)
-      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, e, idx'])
-      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, e, idx'])
-  where
-
-    len :: Length
-    len = vecLength ty
-
-    wid :: Width
-    wid = typeWidth (vecElemType ty)
-
-------------------------------------------------------------------------------
--- Helpers for translating prefetching.
-
-
--- | Translate byte array prefetch operations into proper primcalls.
-doPrefetchByteArrayOp :: Int
-                      -> [CmmExpr]
-                      -> FCode ()
-doPrefetchByteArrayOp locality  [addr,idx]
-   = do profile <- getProfile
-        mkBasicPrefetch locality (arrWordsHdrSize profile)  addr idx
-doPrefetchByteArrayOp _ _
-   = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp"
-
--- | Translate mutable byte array prefetch operations into proper primcalls.
-doPrefetchMutableByteArrayOp :: Int
-                      -> [CmmExpr]
-                      -> FCode ()
-doPrefetchMutableByteArrayOp locality  [addr,idx]
-   = do profile <- getProfile
-        mkBasicPrefetch locality (arrWordsHdrSize profile)  addr idx
-doPrefetchMutableByteArrayOp _ _
-   = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp"
-
--- | Translate address prefetch operations into proper primcalls.
-doPrefetchAddrOp ::Int
-                 -> [CmmExpr]
-                 -> FCode ()
-doPrefetchAddrOp locality   [addr,idx]
-   = mkBasicPrefetch locality 0  addr idx
-doPrefetchAddrOp _ _
-   = panic "GHC.StgToCmm.Prim: doPrefetchAddrOp"
-
--- | Translate value prefetch operations into proper primcalls.
-doPrefetchValueOp :: Int
-                 -> [CmmExpr]
-                 -> FCode ()
-doPrefetchValueOp  locality   [addr]
-  =  do platform <- getPlatform
-        mkBasicPrefetch locality 0 addr  (CmmLit (CmmInt 0 (wordWidth platform)))
-doPrefetchValueOp _ _
-  = panic "GHC.StgToCmm.Prim: doPrefetchValueOp"
-
--- | helper to generate prefetch primcalls
-mkBasicPrefetch :: Int          -- Locality level 0-3
-                -> ByteOff      -- Initial offset in bytes
-                -> CmmExpr      -- Base address
-                -> CmmExpr      -- Index
-                -> FCode ()
-mkBasicPrefetch locality off base idx
-   = do platform <- getPlatform
-        emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr platform W8 (cmmOffsetB platform base off) idx]
-        return ()
-
--- ----------------------------------------------------------------------------
--- Allocating byte arrays
-
--- | Takes a register to return the newly allocated array in and the
--- size of the new array in bytes. Allocates a new
--- 'MutableByteArray#'.
-doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode ()
-doNewByteArrayOp res_r n = do
-    profile <- getProfile
-    platform <- getPlatform
-
-    let info_ptr = mkLblExpr mkArrWords_infoLabel
-        rep = arrWordsRep platform n
-
-    tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize profile))
-        (mkIntExpr platform (nonHdrSize platform rep))
-        (zeroExpr platform)
-
-    let hdr_size = fixedHdrSize profile
-
-    base <- allocHeapClosure rep info_ptr cccsExpr
-                     [ (mkIntExpr platform n,
-                        hdr_size + pc_OFFSET_StgArrBytes_bytes (platformConstants platform))
-                     ]
-
-    emit $ mkAssign (CmmLocal res_r) base
-
--- ----------------------------------------------------------------------------
--- Comparing byte arrays
-
-doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-                     -> FCode ()
-doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do
-    profile <- getProfile
-    platform <- getPlatform
-
-    ifNonZero n $ do
-        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1)
-        doByteArrayBoundsCheck (last_touched_idx ba1_off) ba1 b8 b8
-        doByteArrayBoundsCheck (last_touched_idx ba2_off) ba2 b8 b8
-
-    ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off
-    ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off
-
-    -- short-cut in case of equal pointers avoiding a costly
-    -- subroutine call to the memcmp(3) routine; the Cmm logic below
-    -- results in assembly code being generated for
-    --
-    --   cmpPrefix10 :: ByteArray# -> ByteArray# -> Int#
-    --   cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10#
-    --
-    -- that looks like
-    --
-    --          leaq 16(%r14),%rax
-    --          leaq 16(%rsi),%rbx
-    --          xorl %ecx,%ecx
-    --          cmpq %rbx,%rax
-    --          je l_ptr_eq
-    --
-    --          ; NB: the common case (unequal pointers) falls-through
-    --          ; the conditional jump, and therefore matches the
-    --          ; usual static branch prediction convention of modern cpus
-    --
-    --          subq $8,%rsp
-    --          movq %rbx,%rsi
-    --          movq %rax,%rdi
-    --          movl $10,%edx
-    --          xorl %eax,%eax
-    --          call memcmp
-    --          addq $8,%rsp
-    --          movslq %eax,%rax
-    --          movq %rax,%rcx
-    --  l_ptr_eq:
-    --          movq %rcx,%rbx
-    --          jmp *(%rbp)
-
-    l_ptr_eq <- newBlockId
-    l_ptr_ne <- newBlockId
-
-    emit (mkAssign (CmmLocal res) (zeroExpr platform))
-    emit (mkCbranch (cmmEqWord platform ba1_p ba2_p)
-                    l_ptr_eq l_ptr_ne (Just False))
-
-    emitLabel l_ptr_ne
-    emitMemcmpCall res ba1_p ba2_p n 1
-
-    emitLabel l_ptr_eq
-
--- ----------------------------------------------------------------------------
--- Copying byte arrays
-
--- | Takes a source 'ByteArray#', an offset in the source array, a
--- destination 'MutableByteArray#', an offset into the destination
--- array, and the number of bytes to copy.  Copies the given number of
--- bytes from the source array to the destination array.
-doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-                  -> FCode ()
-doCopyByteArrayOp = emitCopyByteArray copy
-  where
-    -- Copy data (we assume the arrays aren't overlapping since
-    -- they're of different types)
-    copy _src _dst dst_p src_p bytes align =
-        emitMemcpyCall dst_p src_p bytes align
-
--- | Takes a source 'MutableByteArray#', an offset in the source
--- array, a destination 'MutableByteArray#', an offset into the
--- destination array, and the number of bytes to copy.  Copies the
--- given number of bytes from the source array to the destination
--- array.
-doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-                         -> FCode ()
-doCopyMutableByteArrayOp = emitCopyByteArray copy
-  where
-    -- The only time the memory might overlap is when the two arrays
-    -- we were provided are the same array!
-    -- TODO: Optimize branch for common case of no aliasing.
-    copy src dst dst_p src_p bytes align = do
-        platform <- getPlatform
-        (moveCall, cpyCall) <- forkAltPair
-            (getCode $ emitMemmoveCall dst_p src_p bytes align)
-            (getCode $ emitMemcpyCall  dst_p src_p bytes align)
-        emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall
-
-emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-                      -> Alignment -> FCode ())
-                  -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-                  -> FCode ()
-emitCopyByteArray copy src src_off dst dst_off n = do
-    profile <- getProfile
-    platform <- getPlatform
-
-    ifNonZero n $ do
-        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1)
-        doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8
-        doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8
-
-    let byteArrayAlignment = wordAlignment platform
-        srcOffAlignment = cmmExprAlignment src_off
-        dstOffAlignment = cmmExprAlignment dst_off
-        align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment]
-    dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off
-    src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off
-    copy src dst dst_p src_p n align
-
--- | Takes a source 'ByteArray#', an offset in the source array, a
--- destination 'Addr#', and the number of bytes to copy.  Copies the given
--- number of bytes from the source array to the destination memory region.
-doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
-doCopyByteArrayToAddrOp src src_off dst_p bytes = do
-    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)
-    profile <- getProfile
-    platform <- getPlatform
-    ifNonZero bytes $ do
-        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1)
-        doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8
-    src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off
-    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)
-
--- | Takes a source 'MutableByteArray#', an offset in the source array, a
--- destination 'Addr#', and the number of bytes to copy.  Copies the given
--- number of bytes from the source array to the destination memory region.
-doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-                               -> FCode ()
-doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp
-
--- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into
--- the destination array, and the number of bytes to copy.  Copies the given
--- number of bytes from the source memory region to the destination array.
-doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
-doCopyAddrToByteArrayOp src_p dst dst_off bytes = do
-    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)
-    profile <- getProfile
-    platform <- getPlatform
-    ifNonZero bytes $ do
-        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1)
-        doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8
-    dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off
-    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)
-
-ifNonZero :: CmmExpr -> FCode () -> FCode ()
-ifNonZero e it = do
-    platform <- getPlatform
-    let pred = cmmNeWord platform e (zeroExpr platform)
-    code <- getCode it
-    emit =<< mkCmmIfThen' pred code (Just False)
-
--- ----------------------------------------------------------------------------
--- Setting byte arrays
-
--- | Takes a 'MutableByteArray#', an offset into the array, a length,
--- and a byte, and sets each of the selected bytes in the array to the
--- character.
-doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
-                 -> FCode ()
-doSetByteArrayOp ba off len c = do
-    profile <- getProfile
-    platform <- getPlatform
-
-    doByteArrayBoundsCheck off ba b8 b8
-    doByteArrayBoundsCheck (cmmOffset platform (cmmAddWord platform off len) (-1)) ba b8 b8
-
-    let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap
-        offsetAlignment = cmmExprAlignment off
-        align = min byteArrayAlignment offsetAlignment
-
-    p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize profile)) off
-    emitMemsetCall p c len align
-
--- ----------------------------------------------------------------------------
--- Allocating arrays
-
--- | Allocate a new array.
-doNewArrayOp :: CmmFormal             -- ^ return register
-             -> SMRep                 -- ^ representation of the array
-             -> CLabel                -- ^ info pointer
-             -> [(CmmExpr, ByteOff)]  -- ^ header payload
-             -> WordOff               -- ^ array size
-             -> CmmExpr               -- ^ initial element
-             -> FCode ()
-doNewArrayOp res_r rep info payload n init = do
-    profile <- getProfile
-    platform <- getPlatform
-
-    let info_ptr = mkLblExpr info
-
-    tickyAllocPrim (mkIntExpr platform (hdrSize profile rep))
-        (mkIntExpr platform (nonHdrSize platform rep))
-        (zeroExpr platform)
-
-    base <- allocHeapClosure rep info_ptr cccsExpr payload
-
-    arr <- CmmLocal `fmap` newTemp (bWord platform)
-    emit $ mkAssign arr base
-
-    -- Initialise all elements of the array
-    let mkOff off = cmmOffsetW platform (CmmReg arr) (hdrSizeW profile rep + off)
-        initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ]
-    emit (catAGraphs initialization)
-
-    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
-
--- ----------------------------------------------------------------------------
--- Copying pointer arrays
-
--- EZY: This code has an unusually high amount of assignTemp calls, seen
--- nowhere else in the code generator.  This is mostly because these
--- "primitive" ops result in a surprisingly large amount of code.  It
--- will likely be worthwhile to optimize what is emitted here, so that
--- our optimization passes don't waste time repeatedly optimizing the
--- same bits of code.
-
--- More closely imitates 'assignTemp' from the old code generator, which
--- returns a CmmExpr rather than a LocalReg.
-assignTempE :: CmmExpr -> FCode CmmExpr
-assignTempE e = do
-    t <- assignTemp e
-    return (CmmReg (CmmLocal t))
-
--- | Takes a source 'Array#', an offset in the source array, a
--- destination 'MutableArray#', an offset into the destination array,
--- and the number of elements to copy.  Copies the given number of
--- elements from the source array to the destination array.
-doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff
-              -> FCode ()
-doCopyArrayOp = emitCopyArray copy
-  where
-    -- Copy data (we assume the arrays aren't overlapping since
-    -- they're of different types)
-    copy _src _dst dst_p src_p bytes =
-        do platform <- getPlatform
-           emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)
-               (wordAlignment platform)
-
-
--- | Takes a source 'MutableArray#', an offset in the source array, a
--- destination 'MutableArray#', an offset into the destination array,
--- and the number of elements to copy.  Copies the given number of
--- elements from the source array to the destination array.
-doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff
-                     -> FCode ()
-doCopyMutableArrayOp = emitCopyArray copy
-  where
-    -- The only time the memory might overlap is when the two arrays
-    -- we were provided are the same array!
-    -- TODO: Optimize branch for common case of no aliasing.
-    copy src dst dst_p src_p bytes = do
-        platform <- getPlatform
-        (moveCall, cpyCall) <- forkAltPair
-            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes)
-             (wordAlignment platform))
-            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr platform bytes)
-             (wordAlignment platform))
-        emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall
-
-emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
-                  -> FCode ())  -- ^ copy function
-              -> CmmExpr        -- ^ source array
-              -> CmmExpr        -- ^ offset in source array
-              -> CmmExpr        -- ^ destination array
-              -> CmmExpr        -- ^ offset in destination array
-              -> WordOff        -- ^ number of elements to copy
-              -> FCode ()
-emitCopyArray copy src0 src_off dst0 dst_off0 n =
-    when (n /= 0) $ do
-        profile <- getProfile
-        platform <- getPlatform
-
-        -- Passed as arguments (be careful)
-        src     <- assignTempE src0
-        dst     <- assignTempE dst0
-        dst_off <- assignTempE dst_off0
-
-        doPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src
-        doPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst
-
-        -- Nonmoving collector write barrier
-        emitCopyUpdRemSetPush platform (arrPtrsHdrSize profile) dst dst_off n
-
-        -- Set the dirty bit in the header.
-        emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
-
-        dst_elems_p <- assignTempE $ cmmOffsetB platform dst
-                       (arrPtrsHdrSize profile)
-        dst_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p dst_off
-        src_p <- assignTempE $ cmmOffsetExprW platform
-                 (cmmOffsetB platform src (arrPtrsHdrSize profile)) src_off
-        let bytes = wordsToBytes platform n
-
-        copy src dst dst_p src_p bytes
-
-        -- The base address of the destination card table
-        dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p
-                       (loadArrPtrsSize profile dst)
-
-        emitSetCards dst_off dst_cards_p n
-
-doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff
-                   -> FCode ()
-doCopySmallArrayOp = emitCopySmallArray copy
-  where
-    -- Copy data (we assume the arrays aren't overlapping since
-    -- they're of different types)
-    copy _src _dst dst_p src_p bytes =
-        do platform <- getPlatform
-           emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)
-               (wordAlignment platform)
-
-
-doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff
-                          -> FCode ()
-doCopySmallMutableArrayOp = emitCopySmallArray copy
-  where
-    -- The only time the memory might overlap is when the two arrays
-    -- we were provided are the same array!
-    -- TODO: Optimize branch for common case of no aliasing.
-    copy src dst dst_p src_p bytes = do
-        platform <- getPlatform
-        (moveCall, cpyCall) <- forkAltPair
-            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes)
-             (wordAlignment platform))
-            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr platform bytes)
-             (wordAlignment platform))
-        emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall
-
-emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
-                       -> FCode ())  -- ^ copy function
-                   -> CmmExpr        -- ^ source array
-                   -> CmmExpr        -- ^ offset in source array
-                   -> CmmExpr        -- ^ destination array
-                   -> CmmExpr        -- ^ offset in destination array
-                   -> WordOff        -- ^ number of elements to copy
-                   -> FCode ()
-emitCopySmallArray copy src0 src_off dst0 dst_off n =
-    when (n /= 0) $ do
-        profile <- getProfile
-        platform <- getPlatform
-
-        -- Passed as arguments (be careful)
-        src     <- assignTempE src0
-        dst     <- assignTempE dst0
-
-        when (n /= 0) $ do
-            doSmallPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src
-            doSmallPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst
-
-        -- Nonmoving collector write barrier
-        emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize profile) dst dst_off n
-
-        -- Set the dirty bit in the header.
-        emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))
-
-        dst_p <- assignTempE $ cmmOffsetExprW platform
-                 (cmmOffsetB platform dst (smallArrPtrsHdrSize profile)) dst_off
-        src_p <- assignTempE $ cmmOffsetExprW platform
-                 (cmmOffsetB platform src (smallArrPtrsHdrSize profile)) src_off
-        let bytes = wordsToBytes platform n
-
-        copy src dst dst_p src_p bytes
-
--- | Takes an info table label, a register to return the newly
--- allocated array in, a source array, an offset in the source array,
--- and the number of elements to copy. Allocates a new array and
--- initializes it from the source array.
-emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff
-               -> FCode ()
-emitCloneArray info_p res_r src src_off n = do
-    profile <- getProfile
-    platform <- getPlatform
-
-    let info_ptr = mkLblExpr info_p
-        rep = arrPtrsRep platform n
-
-    tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize profile))
-        (mkIntExpr platform (nonHdrSize platform rep))
-        (zeroExpr platform)
-
-    let hdr_size = fixedHdrSize profile
-        constants = platformConstants platform
-
-    base <- allocHeapClosure rep info_ptr cccsExpr
-                     [ (mkIntExpr platform n,
-                        hdr_size + pc_OFFSET_StgMutArrPtrs_ptrs constants)
-                     , (mkIntExpr platform (nonHdrSizeW rep),
-                        hdr_size + pc_OFFSET_StgMutArrPtrs_size constants)
-                     ]
-
-    arr <- CmmLocal `fmap` newTemp (bWord platform)
-    emit $ mkAssign arr base
-
-    dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr)
-             (arrPtrsHdrSize profile)
-    src_p <- assignTempE $ cmmOffsetExprW platform src
-             (cmmAddWord platform
-              (mkIntExpr platform (arrPtrsHdrSizeW profile)) src_off)
-
-    emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n))
-        (wordAlignment platform)
-
-    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
-
--- | Takes an info table label, a register to return the newly
--- allocated array in, a source array, an offset in the source array,
--- and the number of elements to copy. Allocates a new array and
--- initializes it from the source array.
-emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff
-                    -> FCode ()
-emitCloneSmallArray info_p res_r src src_off n = do
-    profile  <- getProfile
-    platform <- getPlatform
-
-    let info_ptr = mkLblExpr info_p
-        rep = smallArrPtrsRep n
-
-    tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize profile))
-        (mkIntExpr platform (nonHdrSize platform rep))
-        (zeroExpr platform)
-
-    let hdr_size = fixedHdrSize profile
-
-    base <- allocHeapClosure rep info_ptr cccsExpr
-                     [ (mkIntExpr platform n,
-                        hdr_size + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform))
-                     ]
-
-    arr <- CmmLocal `fmap` newTemp (bWord platform)
-    emit $ mkAssign arr base
-
-    dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr)
-             (smallArrPtrsHdrSize profile)
-    src_p <- assignTempE $ cmmOffsetExprW platform src
-             (cmmAddWord platform
-              (mkIntExpr platform (smallArrPtrsHdrSizeW profile)) src_off)
-
-    emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n))
-        (wordAlignment platform)
-
-    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
-
--- | Takes and offset in the destination array, the base address of
--- the card table, and the number of elements affected (*not* the
--- number of cards). The number of elements may not be zero.
--- Marks the relevant cards as dirty.
-emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode ()
-emitSetCards dst_start dst_cards_start n = do
-    platform <- getPlatform
-    start_card <- assignTempE $ cardCmm platform dst_start
-    let end_card = cardCmm platform
-                   (cmmSubWord platform
-                    (cmmAddWord platform dst_start (mkIntExpr platform n))
-                    (mkIntExpr platform 1))
-    emitMemsetCall (cmmAddWord platform dst_cards_start start_card)
-        (mkIntExpr platform 1)
-        (cmmAddWord platform (cmmSubWord platform end_card start_card) (mkIntExpr platform 1))
-        (mkAlignment 1) -- no alignment (1 byte)
-
--- Convert an element index to a card index
-cardCmm :: Platform -> CmmExpr -> CmmExpr
-cardCmm platform i =
-    cmmUShrWord platform i (mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform)))
-
-------------------------------------------------------------------------------
--- SmallArray PrimOp implementations
-
-doReadSmallPtrArrayOp :: LocalReg
-                      -> CmmExpr
-                      -> CmmExpr
-                      -> FCode ()
-doReadSmallPtrArrayOp res addr idx = do
-    profile <- getProfile
-    platform <- getPlatform
-    doSmallPtrArrayBoundsCheck idx addr
-    mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr
-        (gcWord platform) idx
-
-doWriteSmallPtrArrayOp :: CmmExpr
-                       -> CmmExpr
-                       -> CmmExpr
-                       -> FCode ()
-doWriteSmallPtrArrayOp addr idx val = do
-    profile <- getProfile
-    platform <- getPlatform
-    let ty = cmmExprType platform val
-
-    doSmallPtrArrayBoundsCheck idx addr
-
-    -- Update remembered set for non-moving collector
-    tmp <- newTemp ty
-    mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx
-    whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp))
-
-    emitPrimCall [] MO_WriteBarrier [] -- #12469
-    mkBasicIndexedWrite (smallArrPtrsHdrSize profile) Nothing addr ty idx val
-    emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))
-
-------------------------------------------------------------------------------
--- Atomic read-modify-write
-
--- | Emit an atomic modification to a byte array element. The result
--- reg contains that previous value of the element. Implies a full
--- memory barrier.
-doAtomicByteArrayRMW
-            :: LocalReg      -- ^ Result reg
-            -> AtomicMachOp  -- ^ Atomic op (e.g. add)
-            -> CmmExpr       -- ^ MutableByteArray#
-            -> CmmExpr       -- ^ Index
-            -> CmmType       -- ^ Type of element by which we are indexing
-            -> CmmExpr       -- ^ Op argument (e.g. amount to add)
-            -> FCode ()
-doAtomicByteArrayRMW res amop mba idx idx_ty n = do
-    profile <- getProfile
-    platform <- getPlatform
-    doByteArrayBoundsCheck idx mba idx_ty idx_ty
-    let width = typeWidth idx_ty
-        addr  = cmmIndexOffExpr platform (arrWordsHdrSize profile)
-                width mba idx
-    doAtomicAddrRMW res amop addr idx_ty n
-
-doAtomicAddrRMW
-            :: LocalReg      -- ^ Result reg
-            -> AtomicMachOp  -- ^ Atomic op (e.g. add)
-            -> CmmExpr       -- ^ Addr#
-            -> CmmType       -- ^ Pointed value type
-            -> CmmExpr       -- ^ Op argument (e.g. amount to add)
-            -> FCode ()
-doAtomicAddrRMW res amop addr ty n =
-    emitPrimCall
-        [ res ]
-        (MO_AtomicRMW (typeWidth ty) amop)
-        [ addr, n ]
-
--- | Emit an atomic read to a byte array that acts as a memory barrier.
-doAtomicReadByteArray
-    :: LocalReg  -- ^ Result reg
-    -> CmmExpr   -- ^ MutableByteArray#
-    -> CmmExpr   -- ^ Index
-    -> CmmType   -- ^ Type of element by which we are indexing
-    -> FCode ()
-doAtomicReadByteArray res mba idx idx_ty = do
-    profile <- getProfile
-    platform <- getPlatform
-    doByteArrayBoundsCheck idx mba idx_ty idx_ty
-    let width = typeWidth idx_ty
-        addr  = cmmIndexOffExpr platform (arrWordsHdrSize profile)
-                width mba idx
-    doAtomicReadAddr res addr idx_ty
-
--- | Emit an atomic read to an address that acts as a memory barrier.
-doAtomicReadAddr
-    :: LocalReg  -- ^ Result reg
-    -> CmmExpr   -- ^ Addr#
-    -> CmmType   -- ^ Type of element by which we are indexing
-    -> FCode ()
-doAtomicReadAddr res addr ty =
-    emitPrimCall
-        [ res ]
-        (MO_AtomicRead (typeWidth ty))
-        [ addr ]
-
--- | Emit an atomic write to a byte array that acts as a memory barrier.
-doAtomicWriteByteArray
-    :: CmmExpr   -- ^ MutableByteArray#
-    -> CmmExpr   -- ^ Index
-    -> CmmType   -- ^ Type of element by which we are indexing
-    -> CmmExpr   -- ^ Value to write
-    -> FCode ()
-doAtomicWriteByteArray mba idx idx_ty val = do
-    profile <- getProfile
-    platform <- getPlatform
-    doByteArrayBoundsCheck idx mba idx_ty idx_ty
-    let width = typeWidth idx_ty
-        addr  = cmmIndexOffExpr platform (arrWordsHdrSize profile)
-                width mba idx
-    doAtomicWriteAddr addr idx_ty val
-
--- | Emit an atomic write to an address that acts as a memory barrier.
-doAtomicWriteAddr
-    :: CmmExpr   -- ^ Addr#
-    -> CmmType   -- ^ Type of element by which we are indexing
-    -> CmmExpr   -- ^ Value to write
-    -> FCode ()
-doAtomicWriteAddr addr ty val =
-    emitPrimCall
-        [ {- no results -} ]
-        (MO_AtomicWrite (typeWidth ty))
-        [ addr, val ]
-
-doCasByteArray
-    :: LocalReg  -- ^ Result reg
-    -> CmmExpr   -- ^ MutableByteArray#
-    -> CmmExpr   -- ^ Index
-    -> CmmType   -- ^ Type of element by which we are indexing
-    -> CmmExpr   -- ^ Old value
-    -> CmmExpr   -- ^ New value
-    -> FCode ()
-doCasByteArray res mba idx idx_ty old new = do
-    profile <- getProfile
-    platform <- getPlatform
-    doByteArrayBoundsCheck idx mba idx_ty idx_ty
-    let width = typeWidth idx_ty
-        addr = cmmIndexOffExpr platform (arrWordsHdrSize profile)
-               width mba idx
-    emitPrimCall
-        [ res ]
-        (MO_Cmpxchg width)
-        [ addr, old, new ]
-
-------------------------------------------------------------------------------
--- Helpers for emitting function calls
-
--- | Emit a call to @memcpy@.
-emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()
-emitMemcpyCall dst src n align =
-    emitPrimCall
-        [ {-no results-} ]
-        (MO_Memcpy (alignmentBytes align))
-        [ dst, src, n ]
-
--- | Emit a call to @memmove@.
-emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()
-emitMemmoveCall dst src n align =
-    emitPrimCall
-        [ {- no results -} ]
-        (MO_Memmove (alignmentBytes align))
-        [ dst, src, n ]
-
--- | Emit a call to @memset@.  The second argument must fit inside an
--- unsigned char.
-emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()
-emitMemsetCall dst c n align =
-    emitPrimCall
-        [ {- no results -} ]
-        (MO_Memset (alignmentBytes align))
-        [ dst, c, n ]
-
-emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()
-emitMemcmpCall res ptr1 ptr2 n align = do
-    -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all
-    -- code-gens currently call out to the @memcmp(3)@ C function.
-    -- This was easier than moving the sign-extensions into
-    -- all the code-gens.
-    platform <- getPlatform
-    let is32Bit = typeWidth (localRegType res) == W32
-
-    cres <- if is32Bit
-              then return res
-              else newTemp b32
-
-    emitPrimCall
-        [ cres ]
-        (MO_Memcmp align)
-        [ ptr1, ptr2, n ]
-
-    unless is32Bit $
-      emit $ mkAssign (CmmLocal res)
-                      (CmmMachOp
-                         (mo_s_32ToWord platform)
-                         [(CmmReg (CmmLocal cres))])
-
-emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode ()
-emitBSwapCall res x width =
-    emitPrimCall
-        [ res ]
-        (MO_BSwap width)
-        [ x ]
-
-emitBRevCall :: LocalReg -> CmmExpr -> Width -> FCode ()
-emitBRevCall res x width =
-    emitPrimCall
-        [ res ]
-        (MO_BRev width)
-        [ x ]
-
-emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode ()
-emitPopCntCall res x width =
-    emitPrimCall
-        [ res ]
-        (MO_PopCnt width)
-        [ x ]
-
-emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()
-emitPdepCall res x y width =
-    emitPrimCall
-        [ res ]
-        (MO_Pdep width)
-        [ x, y ]
-
-emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()
-emitPextCall res x y width =
-    emitPrimCall
-        [ res ]
-        (MO_Pext width)
-        [ x, y ]
-
-emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode ()
-emitClzCall res x width =
-    emitPrimCall
-        [ res ]
-        (MO_Clz width)
-        [ x ]
-
-emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode ()
-emitCtzCall res x width =
-    emitPrimCall
-        [ res ]
-        (MO_Ctz width)
-        [ x ]
-
----------------------------------------------------------------------------
--- Array bounds checking
----------------------------------------------------------------------------
-
-doBoundsCheck :: CmmExpr  -- ^ accessed index
-              -> CmmExpr  -- ^ array size (in elements)
-              -> FCode ()
-doBoundsCheck idx sz = do
-    do_bounds_check <- stgToCmmDoBoundsCheck <$> getStgToCmmConfig
-    platform        <- getPlatform
-    when do_bounds_check (doCheck platform)
-  where
-    doCheck platform = do
-        boundsCheckFailed <- getCode $ emitCCall [] (mkLblExpr mkOutOfBoundsAccessLabel) []
-        emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False)
-      where
-        uGE = cmmUGeWord platform
-        and = cmmAndWord platform
-        zero = zeroExpr platform
-        ne  = cmmNeWord platform
-        isOutOfBounds = ((idx `uGE` sz) `and` (idx `ne` zero)) `ne` zero
-
--- We want to make sure that the array size computation is pushed into the
--- Opt_DoBoundsChecking check to avoid regregressing compiler performance when
--- it's disabled.
-{-# INLINE doBoundsCheck #-}
-
-doPtrArrayBoundsCheck
-    :: CmmExpr  -- ^ accessed index (in bytes)
-    -> CmmExpr  -- ^ pointer to @StgMutArrPtrs@
-    -> FCode ()
-doPtrArrayBoundsCheck idx arr = do
-    profile <- getProfile
-    platform <- getPlatform
-    let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off)
-        sz_off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)
-    doBoundsCheck idx sz
-
-doSmallPtrArrayBoundsCheck
-    :: CmmExpr  -- ^ accessed index (in bytes)
-    -> CmmExpr  -- ^ pointer to @StgMutArrPtrs@
-    -> FCode ()
-doSmallPtrArrayBoundsCheck idx arr = do
-    profile <- getProfile
-    platform <- getPlatform
-    let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off)
-        sz_off = fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)
-    doBoundsCheck idx sz
-
-doByteArrayBoundsCheck
-    :: CmmExpr  -- ^ accessed index (in elements)
-    -> CmmExpr  -- ^ pointer to @StgArrBytes@
-    -> CmmType  -- ^ indexing type
-    -> CmmType  -- ^ element type
-    -> FCode ()
-doByteArrayBoundsCheck idx arr idx_ty elem_ty = do
-    profile <- getProfile
-    platform <- getPlatform
-    let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off)
-        sz_off = fixedHdrSize profile + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)
-        elem_sz = widthInBytes $ typeWidth elem_ty
-        idx_sz = widthInBytes $ typeWidth idx_ty
-        -- Ensure that the last byte of the access is within the array
-        idx_bytes = cmmOffsetB platform
-          (cmmMulWord platform idx (mkIntExpr platform idx_sz))
-          (elem_sz - 1)
-    doBoundsCheck idx_bytes sz
-
----------------------------------------------------------------------------
--- Pushing to the update remembered set
----------------------------------------------------------------------------
-
--- | Push a range of pointer-array elements that are about to be copied over to
--- the update remembered set.
-emitCopyUpdRemSetPush :: Platform
-                      -> ByteOff    -- ^ array header size (in bytes)
-                      -> CmmExpr    -- ^ destination array
-                      -> CmmExpr    -- ^ offset in destination array (in words)
-                      -> Int        -- ^ number of elements to copy
-                      -> FCode ()
-emitCopyUpdRemSetPush _platform _hdr_size _dst _dst_off 0 = return ()
-emitCopyUpdRemSetPush platform hdr_size dst dst_off n =
-    whenUpdRemSetEnabled $ do
-        updfr_off <- getUpdFrameOff
-        graph <- mkCall lbl (NativeNodeCall,NativeReturn) [] args updfr_off []
-        emit graph
-  where
-    lbl = mkLblExpr $ mkPrimCallLabel
-          $ PrimCall (fsLit "stg_copyArray_barrier") rtsUnit
-    args =
-      [ mkIntExpr platform hdr_size
-      , dst
-      , dst_off
-      , mkIntExpr platform n
-      ]
diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Prof.hs
+++ /dev/null
@@ -1,391 +0,0 @@
------------------------------------------------------------------------------
---
--- Code generation for profiling
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.Prof (
-        initCostCentres, ccType, ccsType,
-        mkCCostCentre, mkCCostCentreStack,
-
-        -- infoTablePRov
-        initInfoTableProv,
-
-        -- Cost-centre Profiling
-        dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
-        enterCostCentreThunk, enterCostCentreFun,
-        costCentreFrom,
-        storeCurCCS,
-        emitSetCCC,
-
-        saveCurrentCostCentre, restoreCurrentCostCentre,
-
-        -- Lag/drag/void stuff
-        ldvEnter, ldvEnterClosure, ldvRecordCreate
-  ) where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Platform.Profile
-import GHC.StgToCmm.Closure
-import GHC.StgToCmm.Config
-import GHC.StgToCmm.InfoTableProv
-import GHC.StgToCmm.Utils
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Lit
-import GHC.Runtime.Heap.Layout
-
-import GHC.Cmm.Graph
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Cmm.CLabel
-
-import GHC.Types.CostCentre
-import GHC.Types.IPE
-import GHC.Types.ForeignStubs
-import GHC.Data.FastString
-import GHC.Unit.Module as Module
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Driver.CodeOutput ( ipInitCode )
-
-import GHC.Utils.Encoding
-
-import Control.Monad
-import Data.Char       (ord)
-import GHC.Utils.Monad (whenM)
-
------------------------------------------------------------------------------
---
--- Cost-centre-stack Profiling
---
------------------------------------------------------------------------------
-
--- Expression representing the current cost centre stack
-ccsType :: Platform -> CmmType -- Type of a cost-centre stack
-ccsType = bWord
-
-ccType :: Platform -> CmmType -- Type of a cost centre
-ccType = bWord
-
-storeCurCCS :: CmmExpr -> CmmAGraph
-storeCurCCS = mkAssign cccsReg
-
-mkCCostCentre :: CostCentre -> CmmLit
-mkCCostCentre cc = CmmLabel (mkCCLabel cc)
-
-mkCCostCentreStack :: CostCentreStack -> CmmLit
-mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
-
-costCentreFrom :: Platform
-               -> CmmExpr        -- A closure pointer
-               -> CmmExpr        -- The cost centre from that closure
-costCentreFrom platform cl = CmmLoad (cmmOffsetB platform cl (pc_OFFSET_StgHeader_ccs (platformConstants platform))) (ccsType platform) NaturallyAligned
-
--- | The profiling header words in a static closure
-staticProfHdr :: Profile -> CostCentreStack -> [CmmLit]
-staticProfHdr profile ccs
-  | profileIsProfiling profile = [mkCCostCentreStack ccs, staticLdvInit platform]
-  | otherwise                  = []
-  where platform = profilePlatform profile
-
--- | Profiling header words in a dynamic closure
-dynProfHdr :: Profile -> CmmExpr -> [CmmExpr]
-dynProfHdr profile ccs
-  | profileIsProfiling profile = [ccs, dynLdvInit (profilePlatform profile)]
-  | otherwise                  = []
-
--- | Initialise the profiling field of an update frame
-initUpdFrameProf :: CmmExpr -> FCode ()
-initUpdFrameProf frame
-  = ifProfiling $        -- frame->header.prof.ccs = CCCS
-    do platform <- getPlatform
-       emitStore (cmmOffset platform frame (pc_OFFSET_StgHeader_ccs (platformConstants platform))) cccsExpr
-        -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
-        -- is unnecessary because it is not used anyhow.
-
----------------------------------------------------------------------------
---         Saving and restoring the current cost centre
----------------------------------------------------------------------------
-
-{-        Note [Saving the current cost centre]
-        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The current cost centre is like a global register.  Like other
-global registers, it's a caller-saves one.  But consider
-        case (f x) of (p,q) -> rhs
-Since 'f' may set the cost centre, we must restore it
-before resuming rhs.  So we want code like this:
-        local_cc = CCC  -- save
-        r = f( x )
-        CCC = local_cc  -- restore
-That is, we explicitly "save" the current cost centre in
-a LocalReg, local_cc; and restore it after the call. The
-C-- infrastructure will arrange to save local_cc across the
-call.
-
-The same goes for join points;
-        let j x = join-stuff
-        in blah-blah
-We want this kind of code:
-        local_cc = CCC  -- save
-        blah-blah
-     J:
-        CCC = local_cc  -- restore
--}
-
-saveCurrentCostCentre :: FCode (Maybe LocalReg)
-        -- Returns Nothing if profiling is off
-saveCurrentCostCentre
-  = do sccProfilingEnabled <- stgToCmmSCCProfiling <$> getStgToCmmConfig
-       platform            <- getPlatform
-       if not sccProfilingEnabled
-           then return Nothing
-           else do local_cc <- newTemp (ccType platform)
-                   emitAssign (CmmLocal local_cc) cccsExpr
-                   return (Just local_cc)
-
-restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
-restoreCurrentCostCentre Nothing
-  = return ()
-restoreCurrentCostCentre (Just local_cc)
-  = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))
-
-
--------------------------------------------------------------------------------
--- Recording allocation in a cost centre
--------------------------------------------------------------------------------
-
--- | Record the allocation of a closure.  The CmmExpr is the cost
--- centre stack to which to attribute the allocation.
-profDynAlloc :: SMRep -> CmmExpr -> FCode ()
-profDynAlloc rep ccs
-  = ifProfiling $
-    do profile <- getProfile
-       let platform = profilePlatform profile
-       profAlloc (mkIntExpr platform (heapClosureSizeW profile rep)) ccs
-
--- | Record the allocation of a closure (size is given by a CmmExpr)
--- The size must be in words, because the allocation counter in a CCS counts
--- in words.
-profAlloc :: CmmExpr -> CmmExpr -> FCode ()
-profAlloc words ccs
-  = ifProfiling $
-        do profile <- getProfile
-           let platform = profilePlatform profile
-           let alloc_rep = rEP_CostCentreStack_mem_alloc platform
-           emit $ addToMemE alloc_rep
-                       (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_mem_alloc (platformConstants platform)))
-                       (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep))
-                           -- subtract the "profiling overhead", which is the
-                           -- profiling header in a closure.
-                           [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (profHdrSize profile)]]
-                       )
-
--- -----------------------------------------------------------------------
--- Setting the current cost centre on entry to a closure
-
-enterCostCentreThunk :: CmmExpr -> FCode ()
-enterCostCentreThunk closure =
-  ifProfiling $ do
-      platform <- getPlatform
-      emit $ storeCurCCS (costCentreFrom platform closure)
-
-enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()
-enterCostCentreFun ccs closure = ifProfiling $
-    when (isCurrentCCS ccs) $
-    do platform <- getPlatform
-       emitRtsCall
-         rtsUnitId
-         (fsLit "enterFunCCS")
-         [(baseExpr, AddrHint), (costCentreFrom platform closure, AddrHint)]
-         False
-       -- otherwise we have a top-level function, nothing to do
-
-ifProfiling :: FCode () -> FCode ()
-ifProfiling = whenM (stgToCmmSCCProfiling <$> getStgToCmmConfig)
-
----------------------------------------------------------------
---        Initialising Cost Centres & CCSs
----------------------------------------------------------------
-
-initCostCentres :: CollectedCCs -> FCode ()
--- Emit the declarations
-initCostCentres (local_CCs, singleton_CCSs)
-  = ifProfiling $ do
-      mapM_ emitCostCentreDecl local_CCs
-      mapM_ emitCostCentreStackDecl singleton_CCSs
-
-
-emitCostCentreDecl :: CostCentre -> FCode ()
-emitCostCentreDecl cc = do
-  { ctx      <- stgToCmmContext <$> getStgToCmmConfig
-  ; platform <- getPlatform
-  ; let is_caf | isCafCC cc = mkIntCLit platform (ord 'c') -- 'c' == is a CAF
-               | otherwise  = zero platform
-                        -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
-  ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
-  ; modl  <- newByteStringCLit (bytesFS $ moduleNameFS
-                                        $ moduleName
-                                        $ cc_mod cc)
-  ; loc <- newByteStringCLit $ utf8EncodeByteString $
-                   renderWithContext ctx (ppr $! costCentreSrcSpan cc)
-  ; let
-     lits = [ zero platform,  -- StgInt ccID,
-              label,          -- char *label,
-              modl,           -- char *module,
-              loc,            -- char *srcloc,
-              zero64,         -- StgWord64 mem_alloc
-              zero platform,  -- StgWord time_ticks
-              is_caf,         -- StgInt is_caf
-              zero platform   -- struct _CostCentre *link
-            ]
-  ; emitDataLits (mkCCLabel cc) lits
-  }
-
-emitCostCentreStackDecl :: CostCentreStack -> FCode ()
-emitCostCentreStackDecl ccs
-  = case maybeSingletonCCS ccs of
-    Just cc ->
-        do platform <- getPlatform
-           let mk_lits cc = zero platform :
-                            mkCCostCentre cc :
-                            replicate (sizeof_ccs_words platform - 2) (zero platform)
-                -- Note: to avoid making any assumptions about how the
-                -- C compiler (that compiles the RTS, in particular) does
-                -- layouts of structs containing long-longs, simply
-                -- pad out the struct with zero words until we hit the
-                -- size of the overall struct (which we get via GhclibDerivedConstants.h)
-           emitDataLits (mkCCSLabel ccs) (mk_lits cc)
-    Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
-
-zero :: Platform -> CmmLit
-zero platform = mkIntCLit platform 0
-zero64 :: CmmLit
-zero64 = CmmInt 0 W64
-
-sizeof_ccs_words :: Platform -> Int
-sizeof_ccs_words platform
-    -- round up to the next word.
-  | ms == 0   = ws
-  | otherwise = ws + 1
-  where
-   (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform
-
--- | Emit info-table provenance declarations
-initInfoTableProv ::  [CmmInfoTable] -> InfoTableProvMap -> FCode CStub
-initInfoTableProv infos itmap
-  = do
-       cfg <- getStgToCmmConfig
-       let ents       = convertInfoProvMap infos this_mod itmap
-           info_table = stgToCmmInfoTableMap cfg
-           platform   = stgToCmmPlatform     cfg
-           this_mod   = stgToCmmThisModule   cfg
-
-       case ents of
-         [] -> return mempty
-         _  -> do
-           -- Emit IPE buffer
-           emitIpeBufferListNode this_mod ents
-
-           -- Create the C stub which initialises the IPE map
-           return (ipInitCode info_table platform this_mod)
-
--- ---------------------------------------------------------------------------
--- Set the current cost centre stack
-
-emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
-emitSetCCC cc tick push = ifProfiling $
-  do platform <- getPlatform
-     tmp      <- newTemp (ccsType platform)
-     pushCostCentre tmp cccsExpr cc
-     when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp)))
-     when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
-
-pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
-pushCostCentre result ccs cc
-  = emitRtsCallWithResult result AddrHint
-        rtsUnitId
-        (fsLit "pushCostCentre") [(ccs,AddrHint),
-                                (CmmLit (mkCCostCentre cc), AddrHint)]
-        False
-
-bumpSccCount :: Platform -> CmmExpr -> CmmAGraph
-bumpSccCount platform ccs
-  = addToMem (rEP_CostCentreStack_scc_count platform)
-         (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_scc_count (platformConstants platform))) 1
-
------------------------------------------------------------------------------
---
---                Lag/drag/void stuff
---
------------------------------------------------------------------------------
-
---
--- Initial value for the LDV field in a static closure
---
-staticLdvInit :: Platform -> CmmLit
-staticLdvInit = zeroCLit
-
---
--- Initial value of the LDV field in a dynamic closure
---
-dynLdvInit :: Platform -> CmmExpr
-dynLdvInit platform =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
-  CmmMachOp (mo_wordOr platform) [
-      CmmMachOp (mo_wordShl platform) [loadEra platform, mkIntExpr platform (pc_LDV_SHIFT (platformConstants platform))],
-      CmmLit (mkWordCLit platform (pc_ILDV_STATE_CREATE (platformConstants platform)))
-  ]
-
---
--- Initialise the LDV word of a new closure
---
-ldvRecordCreate :: CmmExpr -> FCode ()
-ldvRecordCreate closure = do
-  platform <- getPlatform
-  emit $ mkStore (ldvWord platform closure) (dynLdvInit platform)
-
---
--- | Called when a closure is entered, marks the closure as having
--- been "used".  The closure is not an "inherently used" one.  The
--- closure is not @IND@ because that is not considered for LDV profiling.
---
-ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()
-ldvEnterClosure closure_info node_reg = do
-    platform <- getPlatform
-    let tag = funTag platform closure_info
-    -- don't forget to subtract node's tag
-    ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-tag))
-
-ldvEnter :: CmmExpr -> FCode ()
--- Argument is a closure pointer
-ldvEnter cl_ptr = do
-    platform <- getPlatform
-    let constants = platformConstants platform
-        -- don't forget to subtract node's tag
-        ldv_wd = ldvWord platform cl_ptr
-        new_ldv_wd = cmmOrWord platform
-                        (cmmAndWord platform (cmmLoadBWord platform ldv_wd)
-                                             (CmmLit (mkWordCLit platform (pc_ILDV_CREATE_MASK constants))))
-                        (cmmOrWord platform (loadEra platform) (CmmLit (mkWordCLit platform (pc_ILDV_STATE_USE constants))))
-    ifProfiling $
-         -- if (era > 0) {
-         --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
-         --                era | LDV_STATE_USE }
-        emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra platform, CmmLit (zeroCLit platform)])
-                     (mkStore ldv_wd new_ldv_wd)
-                     mkNop
-
-loadEra :: Platform -> CmmExpr
-loadEra platform = CmmMachOp (MO_UU_Conv (cIntWidth platform) (wordWidth platform))
-    [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era")))
-             (cInt platform)
-             NaturallyAligned]
-
--- | Takes the address of a closure, and returns
--- the address of the LDV word in the closure
-ldvWord :: Platform -> CmmExpr -> CmmExpr
-ldvWord platform closure_ptr
-    = cmmOffsetB platform closure_ptr (pc_OFFSET_StgHeader_ldvw (platformConstants platform))
diff --git a/compiler/GHC/StgToCmm/Sequel.hs b/compiler/GHC/StgToCmm/Sequel.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Sequel.hs
+++ /dev/null
@@ -1,45 +0,0 @@
------------------------------------------------------------------------------
---
--- Sequel type for Stg to C-- code generation
---
--- (c) The University of Glasgow 2004-2006
---
--- This module is just a bucket of types used in StgToCmm.Monad and
--- StgToCmm.Closure. Its sole purpose is to break a cyclic dependency between
--- StgToCmm.Monad and StgToCmm.Closure which derives from coupling around
--- the BlockId and LocalReg types
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.Sequel
-  ( Sequel(..)
-  , SelfLoopInfo
-  ) where
-
-import GHC.Cmm.BlockId
-import GHC.Cmm
-
-import GHC.Types.Id
-import GHC.Utils.Outputable
-
-import GHC.Prelude
-
---------------------------------------------------------------------------------
--- | A Sequel tells what to do with the result of this expression
-data Sequel
-  = Return              -- ^ Return result(s) to continuation found on the stack.
-
-  | AssignTo
-        [LocalReg]      -- ^ Put result(s) in these regs and fall through
-                        -- NB: no void arguments here
-                        --
-        Bool            -- ^ Should we adjust the heap pointer back to recover
-                        -- space that's unused on this path? We need to do this
-                        -- only if the expression may allocate (e.g. it's a
-                        -- foreign call or allocating primOp)
-
-instance Outputable Sequel where
-    ppr Return = text "Return"
-    ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b
-
-type SelfLoopInfo = (Id, BlockId, [LocalReg])
---------------------------------------------------------------------------------
diff --git a/compiler/GHC/StgToCmm/TagCheck.hs b/compiler/GHC/StgToCmm/TagCheck.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/TagCheck.hs
+++ /dev/null
@@ -1,179 +0,0 @@
-{-# LANGUAGE CPP #-}
-
------------------------------------------------------------------------------
---
--- Code generator utilities; mostly monadic
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.TagCheck
-  ( emitTagAssertion, emitArgTagCheck, checkArg, whenCheckTags,
-    checkArgStatic, checkFunctionArgTags,checkConArgsStatic,checkConArgsDyn) where
-
-#include "ClosureTypes.h"
-
-import GHC.Prelude
-
-import GHC.StgToCmm.Env
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Utils
-import GHC.Cmm
-import GHC.Cmm.BlockId
-import GHC.Cmm.Graph as CmmGraph
-
-import GHC.Core.Type
-import GHC.Types.Id
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-
-import GHC.Core.DataCon
-import Control.Monad
-import GHC.StgToCmm.Types
-import GHC.Utils.Panic (pprPanic)
-import GHC.Utils.Panic.Plain (panic)
-import GHC.Stg.Syntax
-import GHC.StgToCmm.Closure
-import GHC.Cmm.Switch (mkSwitchTargets)
-import GHC.Cmm.Info (cmmGetClosureType)
-import GHC.Types.RepType (dataConRuntimeRepStrictness)
-import GHC.Types.Basic
-import GHC.Data.FastString (mkFastString)
-
-import qualified Data.Map as M
-
--- | Check all arguments marked as cbv for the presence of a tag *at runtime*.
-checkFunctionArgTags :: SDoc -> Id -> [Id] -> FCode ()
-checkFunctionArgTags msg f args = whenCheckTags $ do
-  onJust (return ()) (idCbvMarks_maybe f) $ \marks -> do
-    -- Only check args marked as strict, and only lifted ones.
-    let cbv_args = filter (isBoxedType . idType) $ filterByList (map isMarkedCbv marks) args
-    -- Get their (cmm) address
-    arg_infos <- mapM getCgIdInfo cbv_args
-    let arg_cmms = map idInfoToAmode arg_infos
-    mapM_ (\(cmm,arg) -> emitTagAssertion (showPprUnsafe $ msg <+> ppr arg) cmm)  (zip arg_cmms cbv_args)
-
--- | Check all required-tagged arguments of a constructor are tagged *at compile time*.
-checkConArgsStatic :: SDoc -> DataCon -> [StgArg] -> FCode ()
-checkConArgsStatic msg con args = whenCheckTags $ do
-  let marks = dataConRuntimeRepStrictness con
-  zipWithM_ (checkArgStatic msg) marks args
-
--- Check all required arguments of a constructor are tagged.
--- Possible by emitting checks at runtime.
-checkConArgsDyn :: SDoc -> DataCon -> [StgArg] -> FCode ()
-checkConArgsDyn msg con args = whenCheckTags $ do
-  let marks = dataConRuntimeRepStrictness con
-  zipWithM_ (checkArg msg) (map cbvFromStrictMark marks) args
-
-whenCheckTags :: FCode () -> FCode ()
-whenCheckTags act = do
-  check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig
-  when check_tags act
-
--- | Call barf if we failed to predict a tag correctly.
--- This is immensely useful when debugging issues in tag inference
--- as it will result in a program abort when we encounter an invalid
--- call/heap object, rather than leaving it be and segfaulting arbitrary
--- or producing invalid results.
--- We check if either:
--- * A tag is present
--- * Or the object is a PAP (for which zero is the proper tag)
-emitTagAssertion :: String -> CmmExpr -> FCode ()
-emitTagAssertion onWhat fun = do
-  { platform <- getPlatform
-  ; lret <- newBlockId
-  ; lno_tag <- newBlockId
-  ; lbarf <- newBlockId
-  -- Check for presence of any tag.
-  ; emit $ mkCbranch (cmmIsTagged platform fun)
-                     lret lno_tag (Just True)
-  -- If there is no tag check if we are dealing with a PAP
-  ; emitLabel lno_tag
-  ; emitComment (mkFastString "closereTypeCheck")
-  ; needsArgTag fun lbarf lret
-
-  ; emitLabel lbarf
-  ; emitBarf ("Tag inference failed on:" ++ onWhat)
-  ; emitLabel lret
-  }
-
--- | Jump to the first block if the argument closure is subject
---   to tagging requirements. Otherwise jump to the 2nd one.
-needsArgTag :: CmmExpr -> BlockId -> BlockId -> FCode ()
-needsArgTag closure fail lpass = do
-  profile <- getProfile
-  align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
-  let clo_ty_e = cmmGetClosureType profile align_check closure
-  -- The ENTER macro doesn't evaluate FUN/PAP/BCO objects. So we
-  -- have to accept them not being tagged. See #21193
-  -- See Note [TagInfo of functions]
-  let targets = mkSwitchTargets
-        False
-        (INVALID_OBJECT, N_CLOSURE_TYPES)
-        (Just fail)
-        (M.fromList [(PAP,lpass)
-                    ,(BCO,lpass)
-                    ,(FUN,lpass)
-                    ,(FUN_1_0,lpass)
-                    ,(FUN_0_1,lpass)
-                    ,(FUN_2_0,lpass)
-                    ,(FUN_1_1,lpass)
-                    ,(FUN_0_2,lpass)
-                    ,(FUN_STATIC,lpass)
-                    ])
-
-  emit $ mkSwitch clo_ty_e targets
-
-  emit $ mkBranch lpass
-
-
-emitArgTagCheck :: SDoc -> [CbvMark] -> [Id] -> FCode ()
-emitArgTagCheck info marks args = whenCheckTags $ do
-  mod <- getModuleName
-  let cbv_args = filter (isBoxedType . idType) $ filterByList (map isMarkedCbv marks) args
-  arg_infos <- mapM getCgIdInfo cbv_args
-  let arg_cmms = map idInfoToAmode arg_infos
-      mk_msg arg = showPprUnsafe (text "Untagged arg:" <> (ppr mod) <> char ':' <> info <+> ppr arg)
-  zipWithM_ emitTagAssertion (map mk_msg args) (arg_cmms)
-
-taggedCgInfo :: CgIdInfo -> Bool
-taggedCgInfo cg_info
-  = case lf of
-      LFCon {} -> True
-      LFReEntrant {} -> True
-      LFUnlifted {} -> True
-      LFThunk {} -> False
-      LFUnknown {} -> False
-      LFLetNoEscape -> panic "Let no escape binding passed to top level con"
-  where
-    lf = cg_lf cg_info
-
--- Check that one argument is properly tagged.
-checkArg :: SDoc -> CbvMark -> StgArg -> FCode ()
-checkArg _ NotMarkedCbv _ = return ()
-checkArg msg MarkedCbv arg = whenCheckTags $
-  case arg of
-    StgLitArg _ -> return ()
-    StgVarArg v -> do
-      info <- getCgIdInfo v
-      if taggedCgInfo info
-          then return ()
-          else case (cg_loc info) of
-            CmmLoc loc -> emitTagAssertion (showPprUnsafe $ msg <+> text "arg:" <> ppr arg) loc
-            LneLoc {} -> panic "LNE-arg"
-
--- Check that argument is properly tagged.
-checkArgStatic :: SDoc -> StrictnessMark  -> StgArg -> FCode ()
-checkArgStatic _   NotMarkedStrict _ = return ()
-checkArgStatic msg MarkedStrict arg = whenCheckTags $
-  case arg of
-    StgLitArg _ -> return ()
-    StgVarArg v -> do
-      info <- getCgIdInfo v
-      if taggedCgInfo info
-          then return ()
-          else pprPanic "Arg not tagged as expected" (ppr msg <+> ppr arg)
-
-
diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Ticky.hs
+++ /dev/null
@@ -1,906 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE MultiWayIf #-}
-
------------------------------------------------------------------------------
---
--- Code generation for ticky-ticky profiling
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-{- OVERVIEW: ticky ticky profiling
-
-Please see
-https://gitlab.haskell.org/ghc/ghc/wikis/debugging/ticky-ticky and also
-edit it and the rest of this comment to keep them up-to-date if you
-change ticky-ticky. Thanks!
-
- *** All allocation ticky numbers are in bytes. ***
-
-Some of the relevant source files:
-
-       ***not necessarily an exhaustive list***
-
-  * some codeGen/ modules import this one
-
-  * this module imports GHC.Cmm.CLabel to manage labels
-
-  * GHC.Cmm.Parser expands some macros using generators defined in
-    this module
-
-  * rts/include/stg/Ticky.h declares all of the global counters
-
-  * rts/include/rts/Ticky.h declares the C data type for an
-    STG-declaration's counters
-
-  * some macros defined in rts/include/Cmm.h (and used within the RTS's
-    CMM code) update the global ticky counters
-
-  * at the end of execution rts/Ticky.c generates the final report
-    +RTS -r<report-file> -RTS
-
-The rts/Ticky.c function that generates the report includes an
-STG-declaration's ticky counters if
-
-  * that declaration was entered, or
-
-  * it was allocated (if -ticky-allocd)
-
-On either of those events, the counter is "registered" by adding it to
-a linked list; cf the CMM generated by registerTickyCtr.
-
-Ticky-ticky profiling has evolved over many years. Many of the
-counters from its most sophisticated days are no longer
-active/accurate. As the RTS has changed, sometimes the ticky code for
-relevant counters was not accordingly updated. Unfortunately, neither
-were the comments.
-
-As of March 2013, there still exist deprecated code and comments in
-the code generator as well as the RTS because:
-
-  * I don't know what is out-of-date versus merely commented out for
-    momentary convenience, and
-
-  * someone else might know how to repair it!
-
-
-Note [Ticky counters are static]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Currently GHC only supports static ticky events. That is -ticky emits
-code containing labels containing counters which then get bumped at runtime.
-
-There are currently only *static* ticky counters. Either we bump one of the
-static counters included in the RTS. Or we emit StgEntCounter structures in
-the object code and bump these.
--}
-
-module GHC.StgToCmm.Ticky (
-  withNewTickyCounterFun,
-  withNewTickyCounterLNE,
-  withNewTickyCounterThunk,
-  withNewTickyCounterStdThunk,
-  withNewTickyCounterCon,
-  emitTickyCounterTag,
-
-  tickyDynAlloc,
-  tickyAllocHeap,
-
-  tickyAllocPrim,
-  tickyAllocThunk,
-  tickyAllocPAP,
-  tickyHeapCheck,
-  tickyStackCheck,
-
-  tickyDirectCall,
-
-  tickyPushUpdateFrame,
-  tickyUpdateFrameOmitted,
-
-  tickyEnterDynCon,
-
-  tickyEnterFun,
-  tickyEnterThunk,
-  tickyEnterLNE,
-
-  tickyUpdateBhCaf,
-  tickyUnboxedTupleReturn,
-  tickyReturnOldCon, tickyReturnNewCon,
-
-  tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
-  tickySlowCall, tickySlowCallPat,
-
-  tickyTagged, tickyUntagged, tickyTagSkip
-  ) where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Platform.Profile
-
-import GHC.StgToCmm.ArgRep    ( slowCallPattern , toArgRep , argRepString )
-import GHC.StgToCmm.Closure
-import GHC.StgToCmm.Config
-import {-# SOURCE #-} GHC.StgToCmm.Foreign   ( emitPrimCall )
-import GHC.StgToCmm.Lit       ( newStringCLit )
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Utils
-
-import GHC.Stg.Syntax
-import GHC.Cmm.Expr
-import GHC.Cmm.Graph
-import GHC.Cmm.Utils
-import GHC.Cmm.CLabel
-import GHC.Runtime.Heap.Layout
-
-
-import GHC.Types.Name
-import GHC.Types.Id
-import GHC.Types.Basic
-import GHC.Data.FastString
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Misc
-import GHC.Utils.Monad (whenM)
-
--- Turgid imports for showTypeCategory
-import GHC.Builtin.Names
-import GHC.Tc.Utils.TcType
-import GHC.Core.DataCon
-import GHC.Core.TyCon
-import GHC.Core.Predicate
-
-import Data.Maybe
-import qualified Data.Char
-import Control.Monad ( when, unless )
-import GHC.Types.Id.Info
-import GHC.StgToCmm.Env (getCgInfo_maybe)
-import Data.Coerce (coerce)
-import GHC.Utils.Json
-
------------------------------------------------------------------------------
---
--- Ticky-ticky profiling
---
------------------------------------------------------------------------------
-
--- | Number of arguments for a ticky counter.
---
--- Ticky currently treats args to constructor allocations differently than those for functions/LNE bindings.
-tickyArgArity :: TickyClosureType -> Int
-tickyArgArity (TickyFun _ _fvs args) = length args
-tickyArgArity (TickyLNE args) = length args
-tickyArgArity (TickyCon{}) = 0
-tickyArgArity (TickyThunk{}) = 0
-
-tickyArgDesc :: TickyClosureType -> String
-tickyArgDesc arg_info =
-  case arg_info of
-    TickyFun _ _fvs args -> map (showTypeCategory . idType . fromNonVoid) args
-    TickyLNE args -> map (showTypeCategory . idType . fromNonVoid) args
-    TickyThunk{} -> ""
-    TickyCon{} -> ""
-
-tickyFvDesc :: TickyClosureType -> String
-tickyFvDesc arg_info =
-  case arg_info of
-    TickyFun _ fvs _args -> map (showTypeCategory . idType . fromNonVoid) fvs
-    TickyLNE{} -> ""
-    TickyThunk _ _ fvs -> map (showTypeCategory . stgArgType) fvs
-    TickyCon{} -> ""
-
-instance ToJson TickyClosureType where
-    json info = case info of
-      (TickyFun {})   -> mkInfo (tickyFvDesc info) (tickyArgDesc info) "fun"
-      (TickyLNE {})   -> mkInfo []                 (tickyArgDesc info) "lne"
-      (TickyThunk uf _ _) -> mkInfo (tickyFvDesc info) []              ("thk" ++ if uf then "_u" else "")
-      (TickyCon{})    -> mkInfo []                 []                  "con"
-      where
-        mkInfo :: String -> String -> String -> JsonDoc
-        mkInfo fvs args ty =
-          JSObject
-              [("type", json "entCntr")
-              ,("subTy", json ty)
-              ,("fvs_c", json (length fvs))
-              ,("fvs" , json fvs)
-              ,("args", json args)
-              ]
-
-tickyEntryDescJson :: (SDocContext -> TickyClosureType -> String)
-tickyEntryDescJson ctxt = renderWithContext ctxt . renderJSON . json
-
-data TickyClosureType
-    = TickyFun
-        Bool -- True <-> single entry
-        [NonVoid Id] -- ^ FVs
-        [NonVoid Id] -- ^ Args
-    | TickyCon
-        DataCon -- the allocated constructor
-        ConstructorNumber
-    | TickyThunk
-        Bool -- True <-> updateable
-        Bool -- True <-> standard thunk (AP or selector), has no entry counter
-        [StgArg] -- ^ FVS, StgArg because for thunks these can also be literals.
-    | TickyLNE
-        [NonVoid Id] -- ^ Args
-
-withNewTickyCounterFun :: Bool -> Id -> [NonVoid Id] -> [NonVoid Id] -> FCode a -> FCode a
-withNewTickyCounterFun single_entry f fvs args = withNewTickyCounter (TickyFun single_entry fvs args) f
-
-withNewTickyCounterLNE :: Id  ->  [NonVoid Id] -> FCode a -> FCode a
-withNewTickyCounterLNE nm args code = do
-  b <- isEnabled stgToCmmTickyLNE
-  if not b then code else withNewTickyCounter (TickyLNE args) nm code
-
-thunkHasCounter :: Bool -> FCode Bool
-thunkHasCounter isStatic = (not isStatic &&) <$> isEnabled stgToCmmTickyDynThunk
-
-withNewTickyCounterThunk
-  :: Bool -- ^ static
-  -> Bool -- ^ updateable
-  -> Id
-  -> [NonVoid Id] -- ^ Free vars
-  -> FCode a
-  -> FCode a
-withNewTickyCounterThunk isStatic isUpdatable name fvs code = do
-    has_ctr <- thunkHasCounter isStatic
-    if not has_ctr
-      then code
-      else withNewTickyCounter (TickyThunk isUpdatable False (map StgVarArg $ coerce fvs)) name code
-
-withNewTickyCounterStdThunk
-  :: Bool -- ^ updateable
-  -> Id
-  -> [StgArg] -- ^ Free vars + function
-  -> FCode a
-  -> FCode a
-withNewTickyCounterStdThunk isUpdatable name fvs code = do
-    has_ctr <- thunkHasCounter False
-    if not has_ctr
-      then code
-      else withNewTickyCounter (TickyThunk isUpdatable True fvs) name code
-
-withNewTickyCounterCon
-  :: Id
-  -> DataCon
-  -> ConstructorNumber
-  -> FCode a
-  -> FCode a
-withNewTickyCounterCon name datacon info code = do
-    has_ctr <- thunkHasCounter False
-    if not has_ctr
-      then code
-      else withNewTickyCounter (TickyCon datacon info) name code
-
--- args does not include the void arguments
-withNewTickyCounter :: TickyClosureType -> Id -> FCode a -> FCode a
-withNewTickyCounter cloType name m = do
-  lbl <- emitTickyCounter cloType name
-  setTickyCtrLabel lbl m
-
-emitTickyData :: Platform
-              -> CLabel -- ^ lbl for the counter
-              -> Arity -- ^ arity
-              -> CmmLit -- ^ fun desc
-              -> CmmLit -- ^ arg desc
-              -> CmmLit -- ^ json desc
-              -> CmmLit -- ^ info table lbl
-              -> FCode ()
-emitTickyData platform ctr_lbl arity fun_desc arg_desc json_desc info_tbl =
-  emitDataLits ctr_lbl
-    -- Must match layout of rts/include/rts/Ticky.h's StgEntCounter
-    --
-    -- krc: note that all the fields are I32 now; some were I16
-    -- before, but the code generator wasn't handling that
-    -- properly and it led to chaos, panic and disorder.
-        [ zeroCLit platform,               -- registered?
-          mkIntCLit platform arity,   -- Arity
-          zeroCLit platform,               -- Heap allocated for this thing
-          fun_desc,
-          arg_desc,
-          json_desc,
-          info_tbl,
-          zeroCLit platform,          -- Entries into this thing
-          zeroCLit platform,          -- Heap allocated by this thing
-          zeroCLit platform           -- Link to next StgEntCounter
-        ]
-
-
-emitTickyCounter :: TickyClosureType -> Id -> FCode CLabel
-emitTickyCounter cloType tickee
-  = let name = idName tickee in
-    let ctr_lbl = mkRednCountsLabel name in
-    (>> return ctr_lbl) $
-    ifTicky $ do
-        { cfg    <- getStgToCmmConfig
-        ; parent <- getTickyCtrLabel
-        ; mod_name <- getModuleName
-
-          -- When printing the name of a thing in a ticky file, we
-          -- want to give the module name even for *local* things.  We
-          -- print just "x (M)" rather that "M.x" to distinguish them
-          -- from the global kind by calling to @pprTickyName@
-        ; let platform = stgToCmmPlatform cfg
-              ppr_for_ticky_name :: SDoc
-              ppr_for_ticky_name =
-                let ext = case cloType of
-                              TickyFun single_entry _ _-> parens $ hcat $ punctuate comma $
-                                  [text "fun"] ++ [text "se"|single_entry]
-                              TickyCon datacon _cn -> parens (text "con:" <+> ppr (dataConName datacon))
-                              TickyThunk upd std _-> parens $ hcat $ punctuate comma $
-                                  [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]
-                              TickyLNE _ | isInternalName name -> parens (text "LNE")
-                                         | otherwise -> panic "emitTickyCounter: how is this an external LNE?"
-                    p = case hasHaskellName parent of
-                            -- NB the default "top" ticky ctr does not
-                            -- have a Haskell name
-                          Just pname -> text "in" <+> ppr (nameUnique pname)
-                          _ -> empty
-                in pprTickyName mod_name name <+> ext <+> p
-        ; this_mod <- getModuleName
-        ; let t = case cloType of
-                    TickyCon {} -> "C"
-                    TickyFun {} -> "F"
-                    TickyThunk {} -> "T"
-                    TickyLNE {} -> "L"
-        ; info_lbl <- case cloType of
-                            TickyCon dc mn -> case mn of
-                                               NoNumber -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) DefinitionSite
-                                               (Numbered n) -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) (UsageSite this_mod n)
-                            TickyFun {} ->
-                              return $! CmmLabel $ mkInfoTableLabel name NoCafRefs
-
-                            TickyThunk _ std_thunk _fvs
-                              | not std_thunk
-                              -> return $! CmmLabel $ mkInfoTableLabel name NoCafRefs
-                              -- IPE Maps have no entry for std thunks.
-                              | otherwise
-                              -> do
-                                    lf_info <- getCgInfo_maybe name
-                                    profile <- getProfile
-                                    case lf_info of
-                                      Just (CgIdInfo { cg_lf = cg_lf })
-                                          | isLFThunk cg_lf
-                                          -> return $! CmmLabel $ mkClosureInfoTableLabel (profilePlatform profile) tickee cg_lf
-                                      _   -> pprTraceDebug "tickyThunkUnknown" (text t <> colon <> ppr name <+> pprDebugCLabel (profilePlatform profile) (mkInfoTableLabel name NoCafRefs))
-                                            return $! zeroCLit platform
-
-                            TickyLNE {} -> return $! zeroCLit platform
-
-        ; let ctx = defaultSDocContext {sdocPprDebug = True}
-        ; fun_descr_lit <- newStringCLit $ renderWithContext ctx ppr_for_ticky_name
-        ; arg_descr_lit <- newStringCLit $ tickyArgDesc cloType
-        ; json_descr_lit <- newStringCLit $ tickyEntryDescJson ctx cloType
-        ; emitTickyData platform ctr_lbl (tickyArgArity cloType) fun_descr_lit arg_descr_lit json_descr_lit info_lbl
-        }
-
-{- Note [TagSkip ticky counters]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-These counters keep track how often we execute code where we
-would have performed a tag check if we hadn't run tag inference.
-
-If we have some code of the form:
-    case v[tagged] of ...
-and we want to record how often we avoid a tag check on v
-through tag inference we have to emit a new StgEntCounter for
-each such case statement in order to record how often it's executed.
-
-In theory we could emit one per *binding*. But then we
-would have to either keep track of the bindings which
-already have a StgEntCounter associated with them in the
-code gen state or preallocate such a structure for each binding
-in the code unconditionally (since ticky-code can call non-ticky code)
-
-The first makes the compiler slower, even when ticky is not
-used (a big no no). The later is fairly complex but increases code size
-unconditionally. See also Note [Ticky counters are static].
-
-So instead we emit a new StgEntCounter for each use site of a binding
-where we infered a tag to be present. And increment the counter whenever
-this use site is executed.
-
-We use the fields as follows:
-
-entry_count: Entries avoided.
-str:       : Name of the id.
-
-We use emitTickyCounterTag to emit the counter.
-
-Unlike the closure counters each *use* site of v has it's own
-counter. So there is no need to keep track of the closure/case we are
-in.
-
-We also have to pass a unique for the counter. An Id might be
-scrutinized in more than one place, so the ID alone isn't enough
-to distinguish between use sites.
--}
-
-emitTickyCounterTag :: Unique -> NonVoid Id -> FCode CLabel
-emitTickyCounterTag unique (NonVoid id) =
-  let name = idName id
-      ctr_lbl = mkTagHitLabel name unique in
-    (>> return ctr_lbl) $
-    ifTickyTag $ do
-        { platform <- getPlatform
-        ; parent <- getTickyCtrLabel
-        ; mod_name <- getModuleName
-
-          -- When printing the name of a thing in a ticky file, we
-          -- want to give the module name even for *local* things.  We
-          -- print just "x (M)" rather that "M.x" to distinguish them
-          -- from the global kind.
-        ; let ppr_for_ticky_name :: SDoc
-              ppr_for_ticky_name =
-                let n = ppr name
-                    ext = empty -- parens (text "tagged")
-                    p = case hasHaskellName parent of
-                            -- NB the default "top" ticky ctr does not
-                            -- have a Haskell name
-                          Just pname -> text "at" <+> ppr (nameSrcLoc pname) <+>
-                                          text "in" <+> pprNameUnqualified name
-                          _ -> empty
-                in if isInternalName name
-                   then n <+> parens (ppr mod_name) <+> ext <+> p
-                   else n <+> ext <+> p
-        ; sdoc_context <- stgToCmmContext <$> getStgToCmmConfig
-        ; fun_descr_lit <- newStringCLit $ renderWithContext sdoc_context ppr_for_ticky_name
-        ; arg_descr_lit <- newStringCLit $ "infer"
-        ; json_descr_lit <- newStringCLit $ "infer"
-        ; emitTickyData platform ctr_lbl 0 fun_descr_lit arg_descr_lit json_descr_lit (zeroCLit platform)
-        }
--- -----------------------------------------------------------------------------
--- Ticky stack frames
-
-tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()
-tickyPushUpdateFrame    = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
-tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
-
--- -----------------------------------------------------------------------------
--- Ticky entries
-
--- NB the name-specific entries are only available for names that have
--- dedicated Cmm code. As far as I know, this just rules out
--- constructor thunks. For them, there is no CMM code block to put the
--- bump of name-specific ticky counter into. On the other hand, we can
--- still track allocation their allocation.
-
-tickyEnterDynCon :: FCode ()
-tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
-
-tickyEnterThunk :: ClosureInfo -> FCode ()
-tickyEnterThunk cl_info
-  = ifTicky $ do
-    { bumpTickyCounter ctr
-    ; has_ctr <- thunkHasCounter static
-    ; when has_ctr $ do
-      ticky_ctr_lbl <- getTickyCtrLabel
-      registerTickyCtrAtEntryDyn ticky_ctr_lbl
-      bumpTickyEntryCount ticky_ctr_lbl }
-  where
-    updatable = not (closureUpdReqd cl_info)
-    static    = isStaticClosure cl_info
-
-    ctr | static    = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr"
-                                   else fsLit "ENT_STATIC_THK_MANY_ctr"
-        | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr"
-                                   else fsLit "ENT_DYN_THK_MANY_ctr"
-
-tickyUpdateBhCaf :: ClosureInfo -> FCode ()
-tickyUpdateBhCaf cl_info
-  = ifTicky (bumpTickyCounter ctr)
-  where
-    ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")
-        | otherwise              = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")
-
-tickyEnterFun :: ClosureInfo -> FCode ()
-tickyEnterFun cl_info = ifTicky $ do
-  ctr_lbl <- getTickyCtrLabel
-
-  if isStaticClosure cl_info
-    then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr")
-            registerTickyCtr ctr_lbl
-    else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr")
-            registerTickyCtrAtEntryDyn ctr_lbl
-
-  bumpTickyEntryCount ctr_lbl
-
-tickyEnterLNE :: FCode ()
-tickyEnterLNE = ifTicky $ do
-  bumpTickyCounter (fsLit "ENT_LNE_ctr")
-  ifTickyLNE $ do
-    ctr_lbl <- getTickyCtrLabel
-    registerTickyCtr ctr_lbl
-    bumpTickyEntryCount ctr_lbl
-
--- needn't register a counter upon entry if
---
--- 1) it's for a dynamic closure, and
---
--- 2) -ticky-allocd is on
---
--- since the counter was registered already upon being alloc'd
-registerTickyCtrAtEntryDyn :: CLabel -> FCode ()
-registerTickyCtrAtEntryDyn ctr_lbl = do
-  already_registered <- isEnabled stgToCmmTickyAllocd
-  unless already_registered $ registerTickyCtr ctr_lbl
-
--- | Register a ticky counter.
---
--- It's important that this does not race with other entries of the same
--- closure, lest the ticky_entry_ctrs list may become cyclic. However, we also
--- need to make sure that this is reasonably efficient. Consequently, we first
--- perform a normal load of the counter's "registered" flag to check whether
--- registration is necessary. If so, then we do a compare-and-swap to lock the
--- counter for registration and use an atomic-exchange to add the counter to the list.
---
--- @
--- if ( f_ct.registeredp == 0 ) {
---    if (cas(f_ct.registeredp, 0, 1) == 0) {
---        old_head = xchg(ticky_entry_ctrs,  f_ct);
---        f_ct.link = old_head;
---    }
--- }
--- @
-registerTickyCtr :: CLabel -> FCode ()
-registerTickyCtr ctr_lbl = do
-  platform <- getPlatform
-  let constants = platformConstants platform
-      word_width = wordWidth platform
-      registeredp = CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_registeredp constants))
-
-  register_stmts <- getCode $ do
-    old_head <- newTemp (bWord platform)
-    let ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs"))
-        link = CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_link constants))
-    emitPrimCall [old_head] (MO_Xchg word_width) [ticky_entry_ctrs, mkLblExpr ctr_lbl]
-    emitStore link (CmmReg $ CmmLocal old_head)
-
-  cas_test <- getCode $ do
-    old <- newTemp (bWord platform)
-    emitPrimCall [old] (MO_Cmpxchg word_width)
-        [registeredp, zeroExpr platform, mkIntExpr platform 1]
-    let locked = cmmEqWord platform (CmmReg $ CmmLocal old) (zeroExpr platform)
-    emit =<< mkCmmIfThen locked register_stmts
-
-  let test = cmmEqWord platform (cmmLoadBWord platform registeredp) (zeroExpr platform)
-  emit =<< mkCmmIfThen test cas_test
-
-tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()
-tickyReturnOldCon arity
-  = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")
-                 ; bumpHistogram    (fsLit "RET_OLD_hst") arity }
-tickyReturnNewCon arity
-  = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")
-                 ; bumpHistogram    (fsLit "RET_NEW_hst") arity }
-
-tickyUnboxedTupleReturn :: RepArity -> FCode ()
-tickyUnboxedTupleReturn arity
-  = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
-                 ; bumpHistogram    (fsLit "RET_UNBOXED_TUP_hst") arity }
-
--- -----------------------------------------------------------------------------
--- Ticky calls
-
--- Ticks at a *call site*:
-tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
-tickyDirectCall arity args
-  | args `lengthIs` arity = tickyKnownCallExact
-  | otherwise = do tickyKnownCallExtraArgs
-                   tickySlowCallPat (map argPrimRep (drop arity args))
-
-tickyKnownCallTooFewArgs :: FCode ()
-tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
-
-tickyKnownCallExact :: FCode ()
-tickyKnownCallExact      = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")
-
-tickyKnownCallExtraArgs :: FCode ()
-tickyKnownCallExtraArgs  = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")
-
-tickyUnknownCall :: FCode ()
-tickyUnknownCall         = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")
-
--- Tick for the call pattern at slow call site (i.e. in addition to
--- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
-tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
-tickySlowCall _ [] = return ()
-tickySlowCall lf_info args = do
- -- see Note [Ticky for slow calls]
- if isKnownFun lf_info
-   then tickyKnownCallTooFewArgs
-   else tickyUnknownCall
- tickySlowCallPat (map argPrimRep args)
-
-tickySlowCallPat :: [PrimRep] -> FCode ()
-tickySlowCallPat args = ifTicky $ do
-  platform <- profilePlatform <$> getProfile
-  let argReps = map (toArgRep platform) args
-      (_, n_matched) = slowCallPattern argReps
-  if n_matched > 0 && args `lengthIs` n_matched
-     then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps
-     else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"
-
-{-
-
-Note [Ticky for slow calls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Terminology is unfortunately a bit mixed up for these calls. codeGen
-uses "slow call" to refer to unknown calls and under-saturated known
-calls.
-
-Nowadays, though (ie as of the eval/apply paper), the significantly
-slower calls are actually just a subset of these: the ones with no
-built-in argument pattern (cf GHC.StgToCmm.ArgRep.slowCallPattern)
-
-So for ticky profiling, we split slow calls into
-"SLOW_CALL_fast_<pattern>_ctr" (those matching a built-in pattern) and
-VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very
-bad for both space and time).
-
--}
-
--- -----------------------------------------------------------------------------
--- Ticky allocation
-
-tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
--- Called when doing a dynamic heap allocation; the LambdaFormInfo
--- used to distinguish between closure types
---
--- TODO what else to count while we're here?
-tickyDynAlloc mb_id rep lf = ifTicky $ do
-  profile <- getProfile
-  let platform = profilePlatform profile
-      bytes = platformWordSizeInBytes platform * heapClosureSizeW profile rep
-
-      countGlobal tot ctr = do
-        bumpTickyCounterBy tot bytes
-        bumpTickyCounter   ctr
-      countSpecific = ifTickyAllocd $ case mb_id of
-        Nothing -> return ()
-        Just id -> do
-          let ctr_lbl = mkRednCountsLabel (idName id)
-          registerTickyCtr ctr_lbl
-          bumpTickyAllocd ctr_lbl bytes
-
-  -- TODO are we still tracking "good stuff" (_gds) versus
-  -- administrative (_adm) versus slop (_slp)? I'm going with all _gds
-  -- for now, since I don't currently know neither if we do nor how to
-  -- distinguish. NSF Mar 2013
-
-  if | isConRep rep   ->
-         ifTickyDynThunk countSpecific >>
-         countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")
-     | isThunkRep rep ->
-         ifTickyDynThunk countSpecific >>
-         if lfUpdatable lf
-         then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr")
-         else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr")
-     | isFunRep   rep ->
-         countSpecific >>
-         countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr")
-     | otherwise      -> panic "How is this heap object not a con, thunk, or fun?"
-
-
-
-tickyAllocHeap ::
-  Bool -> -- is this a genuine allocation? As opposed to
-          -- GHC.StgToCmm.Layout.adjustHpBackwards
-  VirtualHpOffset -> FCode ()
--- Called when doing a heap check [TICK_ALLOC_HEAP]
--- Must be lazy in the amount of allocation!
-tickyAllocHeap genuine hp
-  = ifTicky $
-    do  { platform <- getPlatform
-        ; ticky_ctr <- getTickyCtrLabel
-        ; emit $ catAGraphs $
-            -- only test hp from within the emit so that the monadic
-            -- computation itself is not strict in hp (cf knot in
-            -- GHC.StgToCmm.Monad.getHeapUsage)
-          if hp == 0 then []
-          else let !bytes = platformWordSizeInBytes platform * hp in [
-            -- Bump the allocation total in the closure's StgEntCounter
-            addToMem (rEP_StgEntCounter_allocs platform)
-                     (CmmLit (cmmLabelOffB ticky_ctr (pc_OFFSET_StgEntCounter_allocs (platformConstants platform))))
-                     bytes,
-            -- Bump the global allocation total ALLOC_HEAP_tot
-            addToMemLbl (bWord platform)
-                        (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_tot"))
-                        bytes,
-            -- Bump the global allocation counter ALLOC_HEAP_ctr
-            if not genuine then mkNop
-            else addToMemLbl (bWord platform)
-                             (mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_ctr"))
-                             1
-            ]}
-
-
---------------------------------------------------------------------------------
--- these three are only called from GHC.Cmm.Parser (ie ultimately from the RTS)
-
--- the units are bytes
-
-tickyAllocPrim :: CmmExpr  -- ^ size of the full header, in bytes
-               -> CmmExpr  -- ^ size of the payload, in bytes
-               -> CmmExpr -> FCode ()
-tickyAllocPrim _hdr _goods _slop = ifTicky $ do
-  bumpTickyCounter    (fsLit "ALLOC_PRIM_ctr")
-  bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr
-  bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods
-  bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop
-
-tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
-tickyAllocThunk _goods _slop = ifTicky $ do
-    -- TODO is it ever called with a Single-Entry thunk?
-  bumpTickyCounter    (fsLit "ALLOC_UP_THK_ctr")
-  bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods
-  bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop
-
-tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
-tickyAllocPAP _goods _slop = ifTicky $ do
-  bumpTickyCounter    (fsLit "ALLOC_PAP_ctr")
-  bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods
-  bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop
-
-tickyHeapCheck :: FCode ()
-tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr")
-
-tickyStackCheck :: FCode ()
-tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr")
-
--- -----------------------------------------------------------------------------
--- Ticky for tag inference characterisation
-
--- | Predicted a pointer would be tagged correctly (GHC will crash if not so no miss case)
-tickyTagged :: FCode ()
-tickyTagged         = ifTickyTag $ bumpTickyCounter (fsLit "TAG_TAGGED_pred")
-
--- | Pass a boolean expr indicating if tag was present.
-tickyUntagged :: CmmExpr -> FCode ()
-tickyUntagged e     = do
-    ifTickyTag $ bumpTickyCounter (fsLit "TAG_UNTAGGED_pred")
-    ifTickyTag $ bumpTickyCounterByE (fsLit "TAG_UNTAGGED_miss") e
-
--- | Called when for `case v of ...` we can avoid entering v based on
--- tag inference information.
-tickyTagSkip :: Unique -> Id -> FCode ()
-tickyTagSkip unique id = ifTickyTag $ do
-  let ctr_lbl = mkTagHitLabel (idName id) unique
-  registerTickyCtr ctr_lbl
-  bumpTickyTagSkip ctr_lbl
-
--- -----------------------------------------------------------------------------
--- Ticky utils
-
-isEnabled :: (StgToCmmConfig -> Bool) -> FCode Bool
-isEnabled = flip fmap getStgToCmmConfig
-
-runIfFlag :: (StgToCmmConfig -> Bool) -> FCode () -> FCode ()
-runIfFlag f = whenM (f <$> getStgToCmmConfig)
-
-ifTicky :: FCode () -> FCode ()
-ifTicky = runIfFlag stgToCmmDoTicky
-
-ifTickyTag :: FCode () -> FCode ()
-ifTickyTag = runIfFlag stgToCmmTickyTag
-
-ifTickyAllocd :: FCode () -> FCode ()
-ifTickyAllocd = runIfFlag stgToCmmTickyAllocd
-
-ifTickyLNE :: FCode () -> FCode ()
-ifTickyLNE = runIfFlag stgToCmmTickyLNE
-
-ifTickyDynThunk :: FCode () -> FCode ()
-ifTickyDynThunk = runIfFlag stgToCmmTickyDynThunk
-
-bumpTickyCounter :: FastString -> FCode ()
-bumpTickyCounter = bumpTickyLbl . mkRtsCmmDataLabel
-
-bumpTickyCounterBy :: FastString -> Int -> FCode ()
-bumpTickyCounterBy = bumpTickyLblBy . mkRtsCmmDataLabel
-
-bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
-bumpTickyCounterByE lbl = bumpTickyLblByE (mkRtsCmmDataLabel lbl)
-
-bumpTickyEntryCount :: CLabel -> FCode ()
-bumpTickyEntryCount lbl = do
-  platform <- getPlatform
-  bumpTickyLit (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform)))
-
-bumpTickyAllocd :: CLabel -> Int -> FCode ()
-bumpTickyAllocd lbl bytes = do
-  platform <- getPlatform
-  bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) bytes
-
-bumpTickyTagSkip :: CLabel -> FCode ()
-bumpTickyTagSkip lbl = do
-  platform <- getPlatform
-  bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) 1
-
-bumpTickyLbl :: CLabel -> FCode ()
-bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1
-
-bumpTickyLblBy :: CLabel -> Int -> FCode ()
-bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0)
-
-bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()
-bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0)
-
-bumpTickyLit :: CmmLit -> FCode ()
-bumpTickyLit lhs = bumpTickyLitBy lhs 1
-
-bumpTickyLitBy :: CmmLit -> Int -> FCode ()
-bumpTickyLitBy lhs n = do
-  platform <- getPlatform
-  emit (addToMem (bWord platform) (CmmLit lhs) n)
-
-bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
-bumpTickyLitByE lhs e = do
-  platform <- getPlatform
-  emit (addToMemE (bWord platform) (CmmLit lhs) e)
-
-bumpHistogram :: FastString -> Int -> FCode ()
-bumpHistogram lbl n = do
-    platform <- getPlatform
-    let offset = n `min` (pc_TICKY_BIN_COUNT (platformConstants platform) - 1)
-    emit (addToMem (bWord platform)
-           (cmmIndexExpr platform
-                (wordWidth platform)
-                (CmmLit (CmmLabel (mkRtsCmmDataLabel lbl)))
-                (CmmLit (CmmInt (fromIntegral offset) (wordWidth platform))))
-           1)
-
-------------------------------------------------------------------
--- Showing the "type category" for ticky-ticky profiling
-
-showTypeCategory :: Type -> Char
-  {-
-        +           dictionary
-
-        >           function
-
-        {C,I,F,D,W} char, int, float, double, word
-        {c,i,f,d,w} unboxed ditto
-
-        T           tuple
-
-        P           other primitive type
-        p           unboxed ditto
-
-        L           list
-        E           enumeration type
-        S           other single-constructor type
-        M           other multi-constructor data-con type
-
-        .           other type
-
-        -           reserved for others to mark as "uninteresting"
-
-  Accurate as of Mar 2013, but I eliminated the Array category instead
-  of updating it, for simplicity. It's in P/p, I think --NSF
-
-    -}
-showTypeCategory ty
-  | isDictTy ty = '+'
-  | otherwise = case tcSplitTyConApp_maybe ty of
-  Nothing -> '.'
-  Just (tycon, _) ->
-    let anyOf us = getUnique tycon `elem` us in
-    case () of
-      _ | anyOf [fUNTyConKey] -> '>'
-        | anyOf [charTyConKey] -> 'C'
-        | anyOf [charPrimTyConKey] -> 'c'
-        | anyOf [doubleTyConKey] -> 'D'
-        | anyOf [doublePrimTyConKey] -> 'd'
-        | anyOf [floatTyConKey] -> 'F'
-        | anyOf [floatPrimTyConKey] -> 'f'
-        | anyOf [intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey] -> 'I'
-        | anyOf [intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey] -> 'i'
-        | anyOf [wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey] -> 'W'
-        | anyOf [wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey] -> 'w'
-        | anyOf [listTyConKey] -> 'L'
-        | isUnboxedTupleTyCon tycon -> 't'
-        | isTupleTyCon tycon       -> 'T'
-        | isPrimTyCon tycon        -> 'P'
-        | isEnumerationTyCon tycon -> 'E'
-        | isJust (tyConSingleDataCon_maybe tycon) -> 'S'
-        | otherwise -> 'M' -- oh, well...
diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/StgToCmm/Utils.hs
+++ /dev/null
@@ -1,641 +0,0 @@
-
-
------------------------------------------------------------------------------
---
--- Code generator utilities; mostly monadic
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module GHC.StgToCmm.Utils (
-        emitDataLits, emitRODataLits,
-        emitDataCon,
-        emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
-        emitBarf,
-        assignTemp, newTemp,
-
-        newUnboxedTupleRegs,
-
-        emitMultiAssign, emitCmmLitSwitch, emitSwitch,
-
-        tagToClosure, mkTaggedObjectLoad,
-
-        callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
-        callerSaveGlobalReg, callerRestoreGlobalReg,
-
-        cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
-        cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
-        cmmOffsetExprW, cmmOffsetExprB,
-        cmmRegOffW, cmmRegOffB,
-        cmmLabelOffW, cmmLabelOffB,
-        cmmOffsetW, cmmOffsetB,
-        cmmOffsetLitW, cmmOffsetLitB,
-        cmmLoadIndexW,
-        cmmConstrTag1,
-
-        cmmUntag, cmmIsTagged,
-
-        addToMem, addToMemE, addToMemLblE, addToMemLbl,
-
-        -- * Update remembered set operations
-        whenUpdRemSetEnabled,
-        emitUpdRemSetPush,
-        emitUpdRemSetPushThunk,
-
-        convertInfoProvMap, cmmInfoTableToInfoProvEnt
-  ) where
-
-import GHC.Prelude hiding ( head, init, last, tail )
-
-import GHC.Platform
-import GHC.StgToCmm.Monad
-import GHC.StgToCmm.Closure
-import GHC.StgToCmm.Lit (mkSimpleLit, newStringCLit)
-import GHC.Cmm
-import GHC.Cmm.BlockId
-import GHC.Cmm.Graph as CmmGraph
-import GHC.Platform.Regs
-import GHC.Cmm.CLabel
-import GHC.Cmm.Utils
-import GHC.Cmm.Switch
-import GHC.StgToCmm.CgUtils
-
-import GHC.Types.ForeignCall
-import GHC.Types.Id.Info
-import GHC.Core.Type
-import GHC.Core.TyCon
-import GHC.Runtime.Heap.Layout
-import GHC.Unit
-import GHC.Types.Literal
-import GHC.Data.Graph.Directed
-import GHC.Utils.Misc
-import GHC.Types.Unique
-import GHC.Data.FastString
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Types.RepType
-import GHC.Types.CostCentre
-import GHC.Types.IPE
-
-import qualified Data.Map as M
-import Data.List (sortBy)
-import Data.Ord
-import GHC.Types.Unique.Map
-import Data.Maybe
-import qualified Data.List.NonEmpty as NE
-import GHC.Core.DataCon
-import GHC.Types.Unique.FM
-import GHC.Data.Maybe
-import Control.Monad
-import qualified Data.Map.Strict as Map
-
---------------------------------------------------------------------------
---
--- Incrementing a memory location
---
---------------------------------------------------------------------------
-
-addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
-addToMemLbl rep lbl = addToMem rep (CmmLit (CmmLabel lbl))
-
-addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
-addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))
-
--- | @addToMem rep ptr n@ adds @n@ to the integer pointed-to by @ptr@.
-addToMem :: CmmType     -- rep of the counter
-         -> CmmExpr     -- Naturally-aligned address
-         -> Int         -- What to add (a word)
-         -> CmmAGraph
-addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))
-
--- | @addToMemE rep ptr n@ adds @n@ to the integer pointed-to by @ptr@.
-addToMemE :: CmmType    -- rep of the counter
-          -> CmmExpr    -- Naturally-aligned address
-          -> CmmExpr    -- What to add (a word-typed expression)
-          -> CmmAGraph
-addToMemE rep ptr n
-  = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep NaturallyAligned, n])
-
-
--------------------------------------------------------------------------
---
---      Loading a field from an object,
---      where the object pointer is itself tagged
---
--------------------------------------------------------------------------
-
-mkTaggedObjectLoad
-  :: Platform -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
--- (loadTaggedObjectField reg base off tag) generates assignment
---      reg = bitsK[ base + off - tag ]
--- where K is fixed by 'reg'
-mkTaggedObjectLoad platform reg base offset tag
-  = mkAssign (CmmLocal reg)
-             (CmmLoad (cmmOffsetB platform
-                                  (CmmReg (CmmLocal base))
-                                  (offset - tag))
-                      (localRegType reg)
-                      NaturallyAligned)
-
--------------------------------------------------------------------------
---
---      Converting a closure tag to a closure for enumeration types
---      (this is the implementation of tagToEnum#).
---
--------------------------------------------------------------------------
-
-tagToClosure :: Platform -> TyCon -> CmmExpr -> CmmExpr
-tagToClosure platform tycon tag
-  = cmmLoadBWord platform (cmmOffsetExprW platform closure_tbl tag)
-  where closure_tbl = CmmLit (CmmLabel lbl)
-        lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
-
--------------------------------------------------------------------------
---
---      Conditionals and rts calls
---
--------------------------------------------------------------------------
-
-emitBarf :: String -> FCode ()
-emitBarf msg = do
-  strLbl <- newStringCLit msg
-  emitRtsCall rtsUnitId (fsLit "barf") [(CmmLit strLbl,AddrHint)] False
-
-emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
-emitRtsCall pkg fun = emitRtsCallGen [] (mkCmmCodeLabel pkg fun)
-
-emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString
-        -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
-emitRtsCallWithResult res hint pkg = emitRtsCallGen [(res,hint)] . mkCmmCodeLabel pkg
-
--- Make a call to an RTS C procedure
-emitRtsCallGen
-   :: [(LocalReg,ForeignHint)]
-   -> CLabel
-   -> [(CmmExpr,ForeignHint)]
-   -> Bool -- True <=> CmmSafe call
-   -> FCode ()
-emitRtsCallGen res lbl args safe
-  = do { platform <- getPlatform
-       ; updfr_off <- getUpdFrameOff
-       ; let (caller_save, caller_load) = callerSaveVolatileRegs platform
-       ; emit caller_save
-       ; call updfr_off
-       ; emit caller_load }
-  where
-    call updfr_off =
-      if safe then
-        emit =<< mkCmmCall fun_expr res' args' updfr_off
-      else do
-        let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
-        emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
-    (args', arg_hints) = unzip args
-    (res',  res_hints) = unzip res
-    fun_expr = mkLblExpr lbl
-
-
------------------------------------------------------------------------------
---
---      Caller-Save Registers
---
------------------------------------------------------------------------------
-
--- Here we generate the sequence of saves/restores required around a
--- foreign call instruction.
-
--- TODO: reconcile with rts/include/Regs.h
---  * Regs.h claims that BaseReg should be saved last and loaded first
---    * This might not have been tickled before since BaseReg is callee save
---  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
---
--- This code isn't actually used right now, because callerSaves
--- only ever returns true in the current universe for registers NOT in
--- system_regs (just do a grep for CALLER_SAVES in
--- rts/include/stg/MachRegs.h).  It's all one giant no-op, and for
--- good reason: having to save system registers on every foreign call
--- would be very expensive, so we avoid assigning them to those
--- registers when we add support for an architecture.
---
--- Note that the old code generator actually does more work here: it
--- also saves other global registers.  We can't (nor want) to do that
--- here, as we don't have liveness information.  And really, we
--- shouldn't be doing the workaround at this point in the pipeline, see
--- Note [Register parameter passing] and the ToDo on CmmCall in
--- "GHC.Cmm.Node".  Right now the workaround is to avoid inlining across
--- unsafe foreign calls in GHC.Cmm.Sink, but this is strictly
--- temporary.
-callerSaveVolatileRegs :: Platform -> (CmmAGraph, CmmAGraph)
-callerSaveVolatileRegs platform = (caller_save, caller_load)
-  where
-    caller_save = catAGraphs (map (callerSaveGlobalReg    platform) regs_to_save)
-    caller_load = catAGraphs (map (callerRestoreGlobalReg platform) regs_to_save)
-
-    system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
-                    {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
-                  , BaseReg ]
-
-    regs_to_save = filter (callerSaves platform) system_regs
-
-callerSaveGlobalReg :: Platform -> GlobalReg -> CmmAGraph
-callerSaveGlobalReg platform reg
-    = mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal reg))
-
-callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph
-callerRestoreGlobalReg platform reg
-    = mkAssign (CmmGlobal reg)
-               (CmmLoad (get_GlobalReg_addr platform reg)
-                        (globalRegType platform reg)
-                        NaturallyAligned)
-
-
--------------------------------------------------------------------------
---
---      Strings generate a top-level data block
---
--------------------------------------------------------------------------
-
--- | Emit a data-segment data block
-emitDataLits :: CLabel -> [CmmLit] -> FCode ()
-emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)
-
--- | Emit a read-only data block
-emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
-emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
-
-emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()
-emitDataCon lbl itbl ccs payload =
-  emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload []))
-
--------------------------------------------------------------------------
---
---      Assigning expressions to temporaries
---
--------------------------------------------------------------------------
-
-assignTemp :: CmmExpr -> FCode LocalReg
--- Make sure the argument is in a local register.
--- We don't bother being particularly aggressive with avoiding
--- unnecessary local registers, since we can rely on a later
--- optimization pass to inline as necessary (and skipping out
--- on things like global registers can be a little dangerous
--- due to them being trashed on foreign calls--though it means
--- the optimization pass doesn't have to do as much work)
-assignTemp (CmmReg (CmmLocal reg)) = return reg
-assignTemp e = do { platform <- getPlatform
-                  ; reg <- newTemp (cmmExprType platform e)
-                  ; emitAssign (CmmLocal reg) e
-                  ; return reg }
-
-newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
--- Choose suitable local regs to use for the components
--- of an unboxed tuple that we are about to return to
--- the Sequel.  If the Sequel is a join point, using the
--- regs it wants will save later assignments.
-newUnboxedTupleRegs res_ty
-  = assert (isUnboxedTupleType res_ty) $
-    do  { platform <- getPlatform
-        ; sequel <- getSequel
-        ; regs <- choose_regs platform sequel
-        ; massert (regs `equalLength` reps)
-        ; return (regs, map primRepForeignHint reps) }
-  where
-    reps = typePrimRep res_ty
-    choose_regs _ (AssignTo regs _) = return regs
-    choose_regs platform _          = mapM (newTemp . primRepCmmType platform) reps
-
--------------------------------------------------------------------------
---      emitMultiAssign
--------------------------------------------------------------------------
-
-emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
--- Emit code to perform the assignments in the
--- input simultaneously, using temporary variables when necessary.
-
-type Key  = Int
-type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
-                        -- for fast comparison
-type Stmt = (LocalReg, CmmExpr) -- r := e
-
--- We use the strongly-connected component algorithm, in which
---      * the vertices are the statements
---      * an edge goes from s1 to s2 iff
---              s1 assigns to something s2 uses
---        that is, if s1 should *follow* s2 in the final order
-
-emitMultiAssign []    []    = return ()
-emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs
-emitMultiAssign regs rhss   = do
-  platform <- getPlatform
-  assertPpr (equalLength regs rhss) (ppr regs $$ pdoc platform rhss) $
-    unscramble platform ([1..] `zip` (regs `zip` rhss))
-
-unscramble :: Platform -> [Vrtx] -> FCode ()
-unscramble platform vertices = mapM_ do_component components
-  where
-        edges :: [ Node Key Vrtx ]
-        edges = [ DigraphNode vertex key1 (edges_from stmt1)
-                | vertex@(key1, stmt1) <- vertices ]
-
-        edges_from :: Stmt -> [Key]
-        edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
-                                    stmt1 `mustFollow` stmt2 ]
-
-        components :: [SCC Vrtx]
-        components = stronglyConnCompFromEdgedVerticesUniq edges
-
-        -- do_components deal with one strongly-connected component
-        -- Not cyclic, or singleton?  Just do it
-        do_component :: SCC Vrtx -> FCode ()
-        do_component (AcyclicSCC (_,stmt))  = mk_graph stmt
-        do_component (CyclicSCC [])         = panic "do_component"
-        do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt
-
-                -- Cyclic?  Then go via temporaries.  Pick one to
-                -- break the loop and try again with the rest.
-        do_component (CyclicSCC ((_,first_stmt) : rest)) = do
-            u <- newUnique
-            let (to_tmp, from_tmp) = split u first_stmt
-            mk_graph to_tmp
-            unscramble platform rest
-            mk_graph from_tmp
-
-        split :: Unique -> Stmt -> (Stmt, Stmt)
-        split uniq (reg, rhs)
-          = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
-          where
-            rep = cmmExprType platform rhs
-            tmp = LocalReg uniq rep
-
-        mk_graph :: Stmt -> FCode ()
-        mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs
-
-        mustFollow :: Stmt -> Stmt -> Bool
-        (reg, _) `mustFollow` (_, rhs) = regUsedIn platform (CmmLocal reg) rhs
-
--------------------------------------------------------------------------
---      mkSwitch
--------------------------------------------------------------------------
-
-
-emitSwitch :: CmmExpr                      -- Tag to switch on
-           -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches
-           -> Maybe CmmAGraphScoped        -- Default branch (if any)
-           -> ConTagZ -> ConTagZ           -- Min and Max possible values;
-                                           -- behaviour outside this range is
-                                           -- undefined
-           -> FCode ()
-
--- First, two rather common cases in which there is no work to do
-emitSwitch _ []         (Just code) _ _ = emit (fst code)
-emitSwitch _ [(_,code)] Nothing     _ _ = emit (fst code)
-
--- Right, off we go
-emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do
-    join_lbl      <- newBlockId
-    mb_deflt_lbl  <- label_default join_lbl mb_deflt
-    branches_lbls <- label_branches join_lbl branches
-    tag_expr'     <- assignTemp' tag_expr
-
-    -- Sort the branches before calling mk_discrete_switch
-    let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]
-    let range = (fromIntegral lo_tag, fromIntegral hi_tag)
-
-    emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range
-
-    emitLabel join_lbl
-
-mk_discrete_switch :: Bool -- ^ Use signed comparisons
-          -> CmmExpr
-          -> [(Integer, BlockId)]
-          -> Maybe BlockId
-          -> (Integer, Integer)
-          -> CmmAGraph
-
--- SINGLETON TAG RANGE: no case analysis to do
-mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)
-  | lo_tag == hi_tag
-  = assert (tag == lo_tag) $
-    mkBranch lbl
-
--- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
-mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _
-  = mkBranch lbl
-        -- The simplifier might have eliminated a case
-        --       so we may have e.g. case xs of
-        --                               [] -> e
-        -- In that situation we can be sure the (:) case
-        -- can't happen, so no need to test
-
--- SOMETHING MORE COMPLICATED: defer to GHC.Cmm.Switch.Implement
--- See Note [Cmm Switches, the general plan] in GHC.Cmm.Switch
-mk_discrete_switch signed tag_expr branches mb_deflt range
-  = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)
-
-divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])
-divideBranches branches = (lo_branches, mid, hi_branches)
-  where
-    -- 2 branches => n_branches `div` 2 = 1
-    --            => branches !! 1 give the *second* tag
-    -- There are always at least 2 branches here
-    (mid,_) = branches !! (length branches `div` 2)
-    (lo_branches, hi_branches) = span is_lo branches
-    is_lo (t,_) = t < mid
-
---------------
-emitCmmLitSwitch :: CmmExpr                    -- Tag to switch on
-               -> [(Literal, CmmAGraphScoped)] -- Tagged branches
-               -> CmmAGraphScoped              -- Default branch (always)
-               -> FCode ()                     -- Emit the code
-emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt
-emitCmmLitSwitch scrut branches@(branch:_) deflt = do
-    scrut' <- assignTemp' scrut
-    join_lbl <- newBlockId
-    deflt_lbl <- label_code join_lbl deflt
-    branches_lbls <- label_branches join_lbl branches
-
-    platform <- getPlatform
-    let cmm_ty = cmmExprType platform scrut
-        rep = typeWidth cmm_ty
-
-    -- We find the necessary type information in the literals in the branches
-    let (signed,range) = case branch of
-          (LitNumber nt _, _) -> (signed,range)
-            where
-              signed = litNumIsSigned nt
-              range  = case litNumRange platform nt of
-                        (Just mi, Just ma) -> (mi,ma)
-                                              -- unbounded literals (Natural and
-                                              -- Integer) must have been
-                                              -- lowered at this point
-                        partial_bounds     -> pprPanic "Unexpected unbounded literal range"
-                                                       (ppr partial_bounds)
-               -- assuming native word range
-          _ -> (False, (0, platformMaxWord platform))
-
-    if isFloatType cmm_ty
-    then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls
-    else emit $ mk_discrete_switch
-        signed
-        scrut'
-        [(litValue lit,l) | (lit,l) <- branches_lbls]
-        (Just deflt_lbl)
-        range
-    emitLabel join_lbl
-
--- | lower bound (inclusive), upper bound (exclusive)
-type LitBound = (Maybe Literal, Maybe Literal)
-
-noBound :: LitBound
-noBound = (Nothing, Nothing)
-
-mk_float_switch :: Width -> CmmExpr -> BlockId
-              -> LitBound
-              -> [(Literal,BlockId)]
-              -> FCode CmmAGraph
-mk_float_switch rep scrut deflt _bounds [(lit,blk)]
-  = do platform <- getPlatform
-       return $ mkCbranch (cond platform) deflt blk Nothing
-  where
-    cond platform = CmmMachOp ne [scrut, CmmLit cmm_lit]
-      where
-        cmm_lit = mkSimpleLit platform lit
-        ne      = MO_F_Ne rep
-
-mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches
-  = do platform <- getPlatform
-       lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches
-       hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches
-       mkCmmIfThenElse (cond platform) lo_blk hi_blk
-  where
-    (lo_branches, mid_lit, hi_branches) = divideBranches branches
-
-    bounds_lo = (lo_bound, Just mid_lit)
-    bounds_hi = (Just mid_lit, hi_bound)
-
-    cond platform = CmmMachOp lt [scrut, CmmLit cmm_lit]
-      where
-        cmm_lit = mkSimpleLit platform mid_lit
-        lt      = MO_F_Lt rep
-
-
---------------
-label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
-label_default _ Nothing
-  = return Nothing
-label_default join_lbl (Just code)
-  = do lbl <- label_code join_lbl code
-       return (Just lbl)
-
---------------
-label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
-label_branches _join_lbl []
-  = return []
-label_branches join_lbl ((tag,code):branches)
-  = do lbl <- label_code join_lbl code
-       branches' <- label_branches join_lbl branches
-       return ((tag,lbl):branches')
-
---------------
-label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
---  label_code J code
---      generates
---  [L: code; goto J]
--- and returns L
-label_code join_lbl (code,tsc) = do
-    lbl <- newBlockId
-    emitOutOfLine lbl (code CmmGraph.<*> mkBranch join_lbl, tsc)
-    return lbl
-
---------------
-assignTemp' :: CmmExpr -> FCode CmmExpr
-assignTemp' e
-  | isTrivialCmmExpr e = return e
-  | otherwise = do
-       platform <- getPlatform
-       lreg <- newTemp (cmmExprType platform e)
-       let reg = CmmLocal lreg
-       emitAssign reg e
-       return (CmmReg reg)
-
----------------------------------------------------------------------------
--- Pushing to the update remembered set
----------------------------------------------------------------------------
-
-whenUpdRemSetEnabled :: FCode a -> FCode ()
-whenUpdRemSetEnabled code = do
-    platform <- getPlatform
-    do_it <- getCode code
-    let
-      enabled = cmmLoadBWord platform (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel)
-      zero = zeroExpr platform
-      is_enabled = cmmNeWord platform enabled zero
-    the_if <- mkCmmIfThenElse' is_enabled do_it mkNop (Just False)
-    emit the_if
-
--- | Emit code to add an entry to a now-overwritten pointer to the update
--- remembered set.
-emitUpdRemSetPush :: CmmExpr   -- ^ value of pointer which was overwritten
-                  -> FCode ()
-emitUpdRemSetPush ptr =
-    emitRtsCall
-      rtsUnitId
-      (fsLit "updateRemembSetPushClosure_")
-      [(CmmReg (CmmGlobal BaseReg), AddrHint),
-       (ptr, AddrHint)]
-      False
-
-emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk
-                       -> FCode ()
-emitUpdRemSetPushThunk ptr =
-    emitRtsCall
-      rtsUnitId
-      (fsLit "updateRemembSetPushThunk_")
-      [(CmmReg (CmmGlobal BaseReg), AddrHint),
-       (ptr, AddrHint)]
-      False
-
--- | A bare bones InfoProvEnt for things which don't have a good source location
-cmmInfoTableToInfoProvEnt :: Module -> CmmInfoTable -> InfoProvEnt
-cmmInfoTableToInfoProvEnt this_mod cmit =
-    let cl = cit_lbl cmit
-        cn  = rtsClosureType (cit_rep cmit)
-    in InfoProvEnt cl cn "" this_mod Nothing
-
--- | Convert source information collected about identifiers in 'GHC.STG.Debug'
--- to entries suitable for placing into the info table provenance table.
-convertInfoProvMap :: [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt]
-convertInfoProvMap defns this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) =
-  map (\cmit ->
-    let cl = cit_lbl cmit
-        cn  = rtsClosureType (cit_rep cmit)
-
-        tyString :: Outputable a => a -> String
-        tyString = renderWithContext defaultSDocContext . ppr
-
-        lookupClosureMap :: Maybe InfoProvEnt
-        lookupClosureMap = case hasHaskellName cl >>= lookupUniqMap denv of
-                                Just (ty, mbspan) -> Just (InfoProvEnt cl cn (tyString ty) this_mod mbspan)
-                                Nothing -> Nothing
-
-        lookupDataConMap = do
-            UsageSite _ n <- hasIdLabelInfo cl >>= getConInfoTableLocation
-            -- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do
-            (dc, ns) <- hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique
-            -- Lookup is linear but lists will be small (< 100)
-            return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns))
-
-        lookupInfoTableToSourceLocation = do
-            sourceNote <- Map.lookup (cit_lbl cmit) infoTableToSourceLocationMap
-            return $ InfoProvEnt cl cn "" this_mod sourceNote
-
-        -- This catches things like prim closure types and anything else which doesn't have a
-        -- source location
-        simpleFallback = cmmInfoTableToInfoProvEnt this_mod cmit
-
-  in
-    if (isStackRep . cit_rep) cmit then
-      fromMaybe simpleFallback lookupInfoTableToSourceLocation
-    else
-      fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns
diff --git a/compiler/GHC/StgToJS.hs b/compiler/GHC/StgToJS.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS.hs
+++ /dev/null
@@ -1,216 +0,0 @@
-module GHC.StgToJS
-  ( stgToJS
-  )
-where
-
-import GHC.StgToJS.CodeGen
-
-
--- Note [StgToJS design]
--- ~~~~~~~~~~~~~~~~~~~~~
---
--- StgToJS ("JS backend") is adapted from GHCJS [GHCJS2013].
---
--- Haskell to JavaScript
--- ~~~~~~~~~~~~~~~~~~~~~
--- StgToJS converts STG into a JavaScript AST (in GHC.JS) that has been adapted
--- from JMacro [JMacro].
---
--- Tail calls: translated code is tail call optimized through a trampoline,
--- since JavaScript implementations don't always support tail calls.
---
--- JavaScript ASTs are then optimized. A dataflow analysis is performed and then
--- dead code and redundant assignments are removed.
---
--- Primitives
--- ~~~~~~~~~~
--- Haskell primitives have to be represented as JavaScript values. This is done
--- as follows:
---
---  - Int#/Int32#     -> number in Int32 range
---  - Int16#          -> number in Int16 range
---  - Int8#           -> number in Int8 range
---  - Word#/Word32#   -> number in Word32 range
---  - Word16#         -> number in Word16 range
---  - Word8#          -> number in Word8 range
---
---  - Float#/Double#  -> both represented as Javascript Double (no Float!)
---
---  - Int64#          -> represented with two fields:
---                          high -> number in Int32 range
---                          low  -> number in Word32 range
---  - Word64#         -> represented with two fields: high, low
---                          high -> number in Word32 range
---                          low  -> number in Word32 range
---
---  - Addr#           -> represented with two fields: array (used as a namespace) and index
---  - StablePtr#      -> similar to Addr# with array fixed to h$stablePtrBuf
---
---  - JSVal#          -> any Javascript object (used to pass JS objects via FFI)
---
---  - TVar#, MVar#, etc. are represented with JS objects
---
--- Foreign JavaScript imports
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--- StgToJS supports inline JavaScript code. Example:
---
---    > foreign import javascript unsafe
---    >   "((x,y) => x + y)"
---    >   plus :: Int -> Int -> Int
---
--- Currently the JS backend only supports functions as JS imports.
---
--- In comparison, GHCJS supports JavaScript snippets with $1, $2... variables
--- as placeholders for the arguments. It requires a JavaScript parser that the
--- JS backend lacks. In GHCJS, the parser is inherited from JMacro and supports
--- local variable declarations, loops, etc. Local variables are converted to
--- hygienic names to avoid capture.
---
--- Primitives that are represented as multiple values (Int64#, Word64#, Addr#)
--- are passed to FFI functions with multiple arguments.
---
--- Interruptible convention: FFI imports with the "interruptible" calling
--- convention are passed an extra argument (usually named "$c") that is a
--- continuation function. The FFI function must call this function to return to
--- Haskell code.
---
--- Unboxed tuples: returning an unboxed tuple can be done with the predefined
--- macros RETURN_UBX_TUPn where n is the size of the tuples. Internally it uses
--- predefined "h$retN" global variables to pass additional values; the first
--- element of the tuple is returned normally.
---
--- Memory management
--- ~~~~~~~~~~~~~~~~~
--- Heap objects are represented as JavaScript values.
---
--- Most heap objects are represented generically as JavaScript "objects" (hash
--- maps). However, some Haskell heap objects can use use a more memory efficient
--- JavaScript representation: number, string... An example of a consequence of
--- this is that both Int# and Int are represented the same as a JavaScript
--- number. JavaScript introspection (e.g. typeof) is used to differentiate
--- heap object representations when necessary.
---
--- Generic representation: objects on the heap ("closures") are represented as
--- JavaScript objects with the following fields:
---
---  { f   -- (function) entry function + info table
---  , d1  -- two fields of payload
---  , d2
---  , m   -- GC mark
---  , cc  -- optional cost-center
---  }
---
--- Payload: payload only consists of two fields (d1, d2). When more than two
--- fields of payload are required, the second field is itself an object.
---    payload []         ==> { d1 = null, d2 = null                   }
---    payload [a]        ==> { d1 = a   , d2 = null                   }
---    payload [a,b]      ==> { d1 = a   , d2 = b                      }
---    payload [a,b,c]    ==> { d1 = a   , d2 = { d1 = b, d2 = c}      }
---    payload [a,b,c...] ==> { d1 = a   , d2 = { d1 = b, d2 = c, ...} }
---
--- Entry function/ info tables: JavaScript functions are JavaScript objects. If
--- "f" is a function, we can:
---    - call it, e.g. "f(arg0,arg1...)"
---    - get/set its fields, e.g. "f.xyz = abc"
--- This is used to implement the equivalent of tables-next-to-code in
--- JavaScript: every heap object has an entry function "f" that also contains
--- some metadata (info table) about the Haskell object:
---    { t     -- object type
---    , size  -- number of fields in the payload (-1 if variable layout)
---    , i     -- (array) fields layout (empty if variable layout)
---    , n     -- (string) object name for easier dubugging
---    , a     -- constructor tag / fun arity
---    , r     -- ??
---    , s     -- static references?
---    , m     -- GC mark?
---    }
---
--- Payloads for each kind of heap object:
---
--- THUNK =
---  { f  = returns the object reduced to WHNF
---  , m  = ?
---  , d1 = ?
---  , d2 = ?
---  }
---
--- FUN =
---  { f  = function itself
---  , m  = ?
---  , d1 = free variable 1
---  , d2 = free variable 2
---  }
---
--- There are two different kinds of partial application:
---  - pap_r   : pre-generated PAP that contains r registers
---  - pap_gen : generic PAP, contains any number of registers
---
--- PAP =
---  { f  = ?
---  , m  = ?
---  , d1 = function
---  , d2 =
---    { d1 & 0xff = number of args (PAP arity)
---    , d1 >> 8   = number of registers (r for h$pap_r)
---    , d2, d3... = args (r)
---    }
---  }
---
--- CON =
---  { f  = entry function of the datacon worker
---  , m  = 0
---  , d1 = first arg
---  , d2 = arity = 2: second arg
---         arity > 2: { d1, d2, ...} object with remaining args (starts with "d1 = x2"!)
---  }
---
--- BLACKHOLE =
---  { f  = h$blackhole
---  , m  = ?
---  , d1 = owning TSO
---  , d2 = waiters array
---  }
---
--- StackFrame closures are *not* represented as JS objects. Instead they are
--- "unpacked" in the stack, i.e. a stack frame occupies a few slots in the JS
--- array representing the stack ("h$stack").
---
--- When a shared thunk is entered, it is overriden with a black hole ("eager
--- blackholing") and an update frame is pushed on the stack.
---
--- Stack: the Haskell stack is implemented with a dynamically growing JavaScript
--- array ("h$stack").
---  TODO: does it shrink sometimes?
---  TODO: what are the elements of the stack? one JS object per stack frame?
---
---
--- Interaction with JavaScript's garbage collector
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Using JS objects to represent Haskell heap objects means that JS's GC does
--- most of the memory management work.
---
--- However, GHC extends Haskell with features that rely on GC layer violation
--- (weak references, finalizers, etc.). To support these features, a heap scan
--- is can be performed (using TSOs, StablePtr, etc. as roots) to mark reachable
--- objects. Scanning the heap is an expensive operation, but fortunately it
--- doesn't need to happen too often and it can be disabled.
---
--- TODO: importance of eager blackholing
---
--- Concurrency
--- ~~~~~~~~~~~
--- The scheduler is implemented in JS and runs in a single JavaScript thread
--- (similarly to the C RTS not using `-threaded`).
---
--- The scheduler relies on callbacks/continuations to interact with other JS
--- codes (user interface, etc.). In particular, safe foreign import can use "$c"
--- as a continuation function to return to Haskell code.
---
--- TODO: is this still true since 2013 or are we using more recent JS features now?
--- TODO: synchronous threads
---
---
--- REFERENCES
---  * [GHCJS2013] "Demo Proposal: GHCJS, Concurrent Haskell in the Browser", Luite Stegeman,
---    2013 (https://www.haskell.org/haskell-symposium/2013/ghcjs.pdf)
---  * [JMacro] https://hackage.haskell.org/package/jmacro
diff --git a/compiler/GHC/StgToJS/Apply.hs b/compiler/GHC/StgToJS/Apply.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Apply.hs
+++ /dev/null
@@ -1,1152 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE BlockArguments #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.StgToJS.Apply
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
---
--- Module that deals with expression application in JavaScript. In some cases we
--- rely on pre-generated functions that are bundled with the RTS (see rtsApply).
------------------------------------------------------------------------------
-
-module GHC.StgToJS.Apply
-  ( genApp
-  , rtsApply
-  )
-where
-
-import GHC.Prelude hiding ((.|.))
-
-import GHC.JS.Syntax
-import GHC.JS.Make
-
-import GHC.StgToJS.Arg
-import GHC.StgToJS.Closure
-import GHC.StgToJS.DataCon
-import GHC.StgToJS.ExprCtx
-import GHC.StgToJS.Heap
-import GHC.StgToJS.Monad
-import GHC.StgToJS.Types
-import GHC.StgToJS.Profiling
-import GHC.StgToJS.Regs
-import GHC.StgToJS.CoreUtils
-import GHC.StgToJS.Utils
-import GHC.StgToJS.Rts.Types
-import GHC.StgToJS.Stack
-import GHC.StgToJS.Ids
-
-import GHC.Types.Literal
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.CostCentre
-
-import GHC.Stg.Syntax
-
-import GHC.Builtin.Names
-
-import GHC.Core.TyCon
-import GHC.Core.DataCon
-import GHC.Core.Type hiding (typeSize)
-
-import GHC.Utils.Encoding
-import GHC.Utils.Misc
-import GHC.Utils.Monad
-import GHC.Utils.Panic
-import GHC.Utils.Outputable (vcat, ppr)
-import GHC.Data.FastString
-
-import qualified Data.Bits as Bits
-import Data.Monoid
-import Data.Array
-
--- | Pre-generated functions for fast Apply.
--- These are bundled with the RTS.
-rtsApply :: StgToJSConfig -> JStat
-rtsApply cfg = BlockStat $
-  map (specApply cfg) applySpec
-  ++ map (pap cfg) specPap
-  ++ [ mkApplyArr
-     , genericStackApply cfg
-     , genericFastApply  cfg
-     , zeroApply cfg
-     , updates   cfg
-     , papGen    cfg
-     , moveRegs2
-     , selectors cfg
-     ]
-
-
--- | Generate an application of some args to an Id.
---
--- The case where args is null is common as it's used to generate the evaluation
--- code for an Id.
-genApp
-  :: HasDebugCallStack
-  => ExprCtx
-  -> Id
-  -> [StgArg]
-  -> G (JStat, ExprResult)
-genApp ctx i args
-
-    -- Case: unpackCStringAppend# "some string"# str
-    --
-    -- Generates h$appendToHsStringA(str, "some string"), which has a faster
-    -- decoding loop.
-    | [StgLitArg (LitString bs), x] <- args
-    , [top] <- concatMap typex_expr (ctxTarget ctx)
-    , getUnique i == unpackCStringAppendIdKey
-    , d <- utf8DecodeByteString bs
-    = do
-        prof <- csProf <$> getSettings
-        let profArg = if prof then [jCafCCS] else []
-        a <- genArg x
-        return ( top |= app "h$appendToHsStringA" ([toJExpr d, toJExpr a] ++ profArg)
-               , ExprInline Nothing
-               )
-
-    -- let-no-escape
-    | Just n <- ctxLneBindingStackSize ctx i
-    = do
-      as'      <- concatMapM genArg args
-      ei       <- varForEntryId i
-      let ra = mconcat . reverse $
-                 zipWith (\r a -> toJExpr r |= a) [R1 ..] as'
-      p <- pushLneFrame n ctx
-      a <- adjSp 1 -- for the header (which will only be written when the thread is suspended)
-      return (ra <> p <> a <> returnS ei, ExprCont)
-
-    -- proxy#
-    | [] <- args
-    , getUnique i == proxyHashKey
-    , [top] <- concatMap typex_expr (ctxTarget ctx)
-    = return (top |= null_, ExprInline Nothing)
-
-    -- unboxed tuple or strict type: return fields individually
-    | [] <- args
-    , isUnboxedTupleType (idType i) || isStrictType (idType i)
-    = do
-      a <- storeIdFields i (ctxTarget ctx)
-      return (a, ExprInline Nothing)
-
-    -- Handle alternative heap object representation: in some cases, a heap
-    -- object is not represented as a JS object but directly as a number or a
-    -- string. I.e. only the payload is stored because the box isn't useful.
-    -- It happens for "Int Int#" for example: no need to box the Int# in JS.
-    --
-    -- We must check that:
-    --  - the object is subject to the optimization (cf isUnboxable predicate)
-    --  - we know that it is already evaluated (cf ctxIsEvaluated), otherwise we
-    --  need to evaluate it properly first.
-    --
-    -- In which case we generate a dynamic check (using isObject) that either:
-    --  - returns the payload of the heap object, if it uses the generic heap
-    --  object representation
-    --  - returns the object directly, otherwise
-    | [] <- args
-    , [vt] <- idVt i
-    , isUnboxable vt
-    , ctxIsEvaluated ctx i
-    = do
-      let c = head (concatMap typex_expr $ ctxTarget ctx)
-      is <- varsForId i
-      case is of
-        [i'] ->
-          return ( c |= if_ (isObject i') (closureField1 i') i'
-                 , ExprInline Nothing
-                 )
-        _ -> panic "genApp: invalid size"
-
-    -- case of Id without args and known to be already evaluated: return fields
-    -- individually
-    | [] <- args
-    , ctxIsEvaluated ctx i || isStrictType (idType i)
-    = do
-      a <- storeIdFields i (ctxTarget ctx)
-      -- optional runtime assert for detecting unexpected thunks (unevaluated)
-      settings <- getSettings
-      let ww = case concatMap typex_expr (ctxTarget ctx) of
-                 [t] | csAssertRts settings ->
-                         ifS (isObject t .&&. isThunk t)
-                             (appS "throw" [String "unexpected thunk"]) -- yuck
-                             mempty
-                 _   -> mempty
-      return (a `mappend` ww, ExprInline Nothing)
-
-
-    -- Case: "newtype" datacon wrapper
-    --
-    -- If the wrapped argument is known to be already evaluated, then we don't
-    -- need to enter it.
-    | DataConWrapId dc <- idDetails i
-    , isNewTyCon (dataConTyCon dc)
-    = do
-      as <- concatMapM genArg args
-      case as of
-        [ai] -> do
-          let t = head (concatMap typex_expr (ctxTarget ctx))
-              a' = case args of
-                [StgVarArg a'] -> a'
-                _              -> panic "genApp: unexpected arg"
-          if isStrictId a' || ctxIsEvaluated ctx a'
-            then return (t |= ai, ExprInline Nothing)
-            else return (returnS (app "h$e" [ai]), ExprCont)
-        _ -> panic "genApp: invalid size"
-
-    -- no args and Id can't be a function: just enter it
-    | [] <- args
-    , idFunRepArity i == 0
-    , not (might_be_a_function (idType i))
-    = do
-      enter_id <- genIdArg i >>=
-                    \case
-                       [x] -> return x
-                       xs  -> pprPanic "genApp: unexpected multi-var argument"
-                                (vcat [ppr (length xs), ppr i])
-      return (returnS (app "h$e" [enter_id]), ExprCont)
-
-    -- fully saturated global function:
-    --  - deals with arguments
-    --  - jumps into the function
-    | n <- length args
-    , n /= 0
-    , idFunRepArity i == n
-    , not (isLocalId i)
-    , isStrictId i
-    = do
-      as' <- concatMapM genArg args
-      is  <- assignAll jsRegsFromR1 <$> varsForId i
-      jmp <- jumpToII i as' is
-      return (jmp, ExprCont)
-
-    -- oversaturated function:
-    --  - push continuation with extra args
-    --  - deals with arguments
-    --  - jumps into the function
-    | idFunRepArity i < length args
-    , isStrictId i
-    , idFunRepArity i > 0
-    = do
-      let (reg,over) = splitAt (idFunRepArity i) args
-      reg' <- concatMapM genArg reg
-      pc   <- pushCont over
-      is   <- assignAll jsRegsFromR1 <$> varsForId i
-      jmp  <- jumpToII i reg' is
-      return (pc <> jmp, ExprCont)
-
-    -- generic apply:
-    --  - try to find a pre-generated apply function that matches
-    --  - use it if any
-    --  - otherwise use generic apply function h$ap_gen_fast
-    | otherwise
-    = do
-      is  <- assignAll jsRegsFromR1 <$> varsForId i
-      jmp <- jumpToFast args is
-      return (jmp, ExprCont)
-
--- avoid one indirection for global ids
--- fixme in many cases we can also jump directly to the entry for local?
-jumpToII :: Id -> [JExpr] -> JStat -> G JStat
-jumpToII i vars load_app_in_r1
-  | isLocalId i = do
-     ii <- varForId i
-     return $ mconcat
-      [ assignAllReverseOrder jsRegsFromR2 vars
-      , load_app_in_r1
-      , returnS (closureEntry ii)
-      ]
-  | otherwise   = do
-     ei <- varForEntryId i
-     return $ mconcat
-      [ assignAllReverseOrder jsRegsFromR2 vars
-      , load_app_in_r1
-      , returnS ei
-      ]
-
--- | Try to use a specialized pre-generated application function.
--- If there is none, use h$ap_gen_fast instead
-jumpToFast :: HasDebugCallStack => [StgArg] -> JStat -> G JStat
-jumpToFast args load_app_in_r1 = do
-  -- get JS expressions for every argument
-  -- Arguments may have more than one expression (e.g. Word64#)
-  vars <- concatMapM genArg args
-  -- try to find a specialized apply function
-  let spec = mkApplySpec RegsConv args vars
-  ap_fun <- selectApply spec
-  pure $ mconcat
-    [ assignAllReverseOrder jsRegsFromR2 vars
-    , load_app_in_r1
-    , case ap_fun of
-        -- specialized apply: no tag
-        Right fun -> returnS (ApplExpr fun [])
-        -- generic apply: pass a tag indicating number of args/slots
-        Left  fun -> returnS (ApplExpr fun [specTagExpr spec])
-    ]
-
--- | Calling convention for an apply function
-data ApplyConv
-  = RegsConv  -- ^ Fast calling convention: use registers
-  | StackConv -- ^ Slow calling convention: use the stack
-  deriving (Show,Eq,Ord)
-
--- | Name of the generic apply function
-genericApplyName :: ApplyConv -> FastString
-genericApplyName = \case
-  RegsConv  -> "h$ap_gen_fast"
-  StackConv -> "h$ap_gen"
-
--- | Expr of the generic apply function
-genericApplyExpr :: ApplyConv -> JExpr
-genericApplyExpr conv = var (genericApplyName conv)
-
-
--- | Return the name of the specialized apply function for the given number of
--- args, number of arg variables, and calling convention.
-specApplyName :: ApplySpec -> FastString
-specApplyName = \case
-  -- specialize a few for compiler performance (avoid building FastStrings over
-  -- and over for common cases)
-  ApplySpec RegsConv  0 0    -> "h$ap_0_0_fast"
-  ApplySpec StackConv 0 0    -> "h$ap_0_0"
-  ApplySpec RegsConv  1 0    -> "h$ap_1_0_fast"
-  ApplySpec StackConv 1 0    -> "h$ap_1_0"
-  ApplySpec RegsConv  1 1    -> "h$ap_1_1_fast"
-  ApplySpec StackConv 1 1    -> "h$ap_1_1"
-  ApplySpec RegsConv  1 2    -> "h$ap_1_2_fast"
-  ApplySpec StackConv 1 2    -> "h$ap_1_2"
-  ApplySpec RegsConv  2 1    -> "h$ap_2_1_fast"
-  ApplySpec StackConv 2 1    -> "h$ap_2_1"
-  ApplySpec RegsConv  2 2    -> "h$ap_2_2_fast"
-  ApplySpec StackConv 2 2    -> "h$ap_2_2"
-  ApplySpec RegsConv  2 3    -> "h$ap_2_3_fast"
-  ApplySpec StackConv 2 3    -> "h$ap_2_3"
-  ApplySpec conv nargs nvars -> mkFastString $ mconcat
-                                  [ "h$ap_", show nargs
-                                  , "_"    , show nvars
-                                  , case conv of
-                                      RegsConv  -> "_fast"
-                                      StackConv -> ""
-                                  ]
-
--- | Return the expression of the specialized apply function for the given
--- number of args, number of arg variables, and calling convention.
---
--- Warning: the returned function may not be generated! Use specApplyExprMaybe
--- if you want to ensure that it exists.
-specApplyExpr :: ApplySpec -> JExpr
-specApplyExpr spec = var (specApplyName spec)
-
--- | Return the expression of the specialized apply function for the given
--- number of args, number of arg variables, and calling convention.
--- Return Nothing if it isn't generated.
-specApplyExprMaybe :: ApplySpec -> Maybe JExpr
-specApplyExprMaybe spec =
-  if spec `elem` applySpec
-    then Just (specApplyExpr spec)
-    else Nothing
-
--- | Make an ApplySpec from a calling convention, a list of Haskell args, and a
--- list of corresponding JS variables
-mkApplySpec :: ApplyConv -> [StgArg] -> [JExpr] -> ApplySpec
-mkApplySpec conv args vars = ApplySpec
-  { specConv = conv
-  , specArgs = length args
-  , specVars = length vars
-  }
-
--- | Find a specialized application function if there is one
-selectApply
-  :: ApplySpec
-  -> G (Either JExpr JExpr) -- ^ the function to call (Left for generic, Right for specialized)
-selectApply spec =
-  case specApplyExprMaybe spec of
-    Just e  -> return (Right e)
-    Nothing -> return (Left (genericApplyExpr (specConv spec)))
-
-
--- | Apply specification
-data ApplySpec = ApplySpec
-  { specConv :: !ApplyConv -- ^ Calling convention
-  , specArgs :: !Int       -- ^ number of Haskell arguments
-  , specVars :: !Int       -- ^ number of JavaScript variables for the arguments
-  }
-  deriving (Show,Eq,Ord)
-
--- | List of specialized apply function templates
-applySpec :: [ApplySpec]
-applySpec = [ ApplySpec conv nargs nvars
-            | conv  <- [RegsConv, StackConv]
-            , nargs <- [0..4]
-            , nvars <- [max 0 (nargs-1)..(nargs*2)]
-            ]
-
--- | Generate a tag for the given ApplySpec
---
--- Warning: tag doesn't take into account the calling convention
-specTag :: ApplySpec -> Int
-specTag spec = Bits.shiftL (specVars spec) 8 Bits..|. (specArgs spec)
-
--- | Generate a tag expression for the given ApplySpec
-specTagExpr :: ApplySpec -> JExpr
-specTagExpr = toJExpr . specTag
-
--- | Build arrays to quickly lookup apply functions
---
---  h$apply[r << 8 | n] = function application for r regs, n args
---  h$paps[r]           = partial application for r registers (number of args is in the object)
-mkApplyArr :: JStat
-mkApplyArr = mconcat
-  [ TxtI "h$apply" ||= toJExpr (JList [])
-  , TxtI "h$paps"  ||= toJExpr (JList [])
-  , ApplStat (var "h$initStatic" .^ "push")
-    [ ValExpr $ JFunc [] $ jVar \i -> mconcat
-        [ i |= zero_
-        , WhileStat False (i .<. Int 65536) $ mconcat
-            [ var "h$apply" .! i |= var "h$ap_gen"
-            , preIncrS i
-            ]
-        , i |= zero_
-        , WhileStat False (i .<. Int 128) $ mconcat
-            [ var "h$paps" .! i |= var "h$pap_gen"
-            , preIncrS i
-            ]
-        , mconcat (map assignSpec applySpec)
-        , mconcat (map assignPap specPap)
-        ]
-    ]
-  ]
-  where
-    assignSpec :: ApplySpec -> JStat
-    assignSpec spec = case specConv spec of
-      -- both fast/slow (regs/stack) specialized apply functions have the same
-      -- tags. We store the stack ones in the array because they are used as
-      -- continuation stack frames.
-      StackConv -> var "h$apply" .! specTagExpr spec |= specApplyExpr spec
-      RegsConv  -> mempty
-
-    assignPap :: Int -> JStat
-    assignPap p = var "h$paps" .! toJExpr p |=
-                      (var (mkFastString $ ("h$pap_" ++ show p)))
-
--- | Push a continuation on the stack
---
--- First push the given args, then push an apply function (specialized if
--- possible, otherwise the generic h$ap_gen function).
-pushCont :: HasDebugCallStack
-         => [StgArg]
-         -> G JStat
-pushCont args = do
-  vars <- concatMapM genArg args
-  let spec = mkApplySpec StackConv args vars
-  selectApply spec >>= \case
-    Right app -> push $ reverse $ app : vars
-    Left  app -> push $ reverse $ app : specTagExpr spec : vars
-
--- | Generic stack apply function (h$ap_gen) that can do everything, but less
--- efficiently than other more specialized functions.
---
--- Stack layout:
---  -3: ...
---  -2: args
---  -1: tag (number of arg slots << 8 | number of args)
---
--- Regs:
---  R1 = applied closure
---
-genericStackApply :: StgToJSConfig -> JStat
-genericStackApply cfg = closure info body
-  where
-    -- h$ap_gen body
-    body = jVar \cf ->
-      [ traceRts cfg (jString "h$ap_gen")
-      , cf |= closureEntry r1
-        -- switch on closure type
-      , SwitchStat (entryClosureType cf)
-        [ (toJExpr Thunk    , thunk_case cfg cf)
-        , (toJExpr Fun      , fun_case cf (funArity' cf))
-        , (toJExpr Pap      , fun_case cf (papArity r1))
-        , (toJExpr Blackhole, blackhole_case cfg)
-        ]
-        (default_case cf)
-      ]
-
-    -- info table for h$ap_gen
-    info = ClosureInfo
-      { ciVar     = TxtI "h$ap_gen"
-      , ciRegs    = CIRegs 0 [PtrV] -- closure to apply to
-      , ciName    = "h$ap_gen"
-      , ciLayout  = CILayoutVariable
-      , ciType    = CIStackFrame
-      , ciStatic  = mempty
-      }
-
-    default_case cf = appS "throw" [jString "h$ap_gen: unexpected closure type "
-                                    + (entryClosureType cf)]
-
-    thunk_case cfg cf = mconcat
-      [ profStat cfg pushRestoreCCS
-      , returnS cf
-      ]
-
-    blackhole_case cfg = mconcat
-      [ push' cfg [r1, var "h$return"]
-      , returnS (app "h$blockOnBlackhole" [r1])
-      ]
-
-    fun_case c arity = jVar \tag needed_args needed_regs given_args given_regs newTag newAp p dat ->
-      [ tag         |= stack .! (sp - 1) -- tag on the stack
-      , given_args  |= mask8 tag         -- indicates the number of passed args
-      , given_regs  |= tag .>>. 8        -- and the number of passed values for registers
-      , needed_args |= mask8 arity
-      , needed_regs |= arity .>>. 8
-      , traceRts cfg (jString "h$ap_gen: args: " + given_args
-                    + jString " regs: " + given_regs)
-      , ifBlockS (given_args .===. needed_args)
-        --------------------------------
-        -- exactly saturated application
-        --------------------------------
-        [ traceRts cfg (jString "h$ap_gen: exact")
-        -- Set registers to register values on the stack
-        , loop 0 (.<. given_regs) \i -> mconcat
-            [ appS "h$setReg" [i+2, stack .! (sp-2-i)]
-            , postIncrS i
-            ]
-        -- drop register values from the stack
-        , sp |= sp - given_regs - 2
-        -- enter closure in R1
-        , returnS c
-        ]
-        [ ifBlockS (given_args .>. needed_args)
-            ----------------------------
-            -- oversaturated application
-            ----------------------------
-            [ traceRts cfg (jString "h$ap_gen: oversat: arity: " + needed_args
-                          + jString " regs: " + needed_regs)
-            -- load needed register values
-            , loop 0 (.<. needed_regs) \i -> mconcat
-                [ traceRts cfg (jString "h$ap_gen: loading register: " + i)
-                , appS "h$setReg" [i+2, stack .! (sp-2-i)]
-                , postIncrS i
-                ]
-            -- compute new tag with consumed register values and args removed
-            , newTag |= ((given_regs-needed_regs).<<.8) .|. (given_args - needed_args)
-            -- find application function for the remaining regs/args
-            , newAp |= var "h$apply" .! newTag
-            , traceRts cfg (jString "h$ap_gen: next: " + (newAp .^ "n"))
-
-            -- Drop used registers from the stack.
-            -- Test if the application function needs a tag and push it.
-            , ifS (newAp .===. var "h$ap_gen")
-                   ((sp |= sp - needed_regs) <> (stack .! (sp - 1) |= newTag))
-                   (sp |= sp - needed_regs - 1)
-
-            -- Push generic application function as continuation
-            , stack .! sp |= newAp
-
-            -- Push "current thread CCS restore" function as continuation
-            , profStat cfg pushRestoreCCS
-
-            -- enter closure in R1
-            , returnS c
-            ]
-
-            -----------------------------
-            -- undersaturated application
-            -----------------------------
-            [ traceRts cfg (jString "h$ap_gen: undersat")
-            -- find PAP entry function corresponding to given_regs count
-            , p      |= var "h$paps" .! given_regs
-
-            -- build PAP payload: R1 + tag + given register values
-            , newTag |= ((needed_regs-given_regs) .<<. 8) .|. (needed_args-given_args)
-            , dat    |= toJExpr [r1, newTag]
-            , loop 0 (.<. given_regs) \i -> mconcat
-                [ (dat .^ "push") `ApplStat` [stack .! (sp - i - 2)]
-                , postIncrS i
-                ]
-
-            -- remove register values from the stack.
-            , sp  |= sp - given_regs - 2
-
-            -- alloc PAP closure, store reference to it in R1.
-            , r1  |= initClosure cfg p dat jCurrentCCS
-
-            -- return to the continuation on the stack
-            , returnStack
-            ]
-        ]
-      ]
-
--- | Generic fast apply function (h$ap_gen_fast) that can do everything, but less
--- efficiently than other more specialized functions.
---
--- Signature tag in argument. Tag: (regs << 8 | arity)
---
--- Regs:
---  R1 = closure to apply to
---
-genericFastApply :: StgToJSConfig -> JStat
-genericFastApply s =
-   TxtI "h$ap_gen_fast" ||= jLam \tag -> jVar \c ->
-      [traceRts s (jString "h$ap_gen_fast: " + tag)
-      , c |= closureEntry r1
-      , SwitchStat (entryClosureType c)
-        [ (toJExpr Thunk, traceRts s (jString "h$ap_gen_fast: thunk")
-           <> pushStackApply c tag
-           <> returnS c)
-        , (toJExpr Fun, jVar \farity ->
-                               [ farity |= funArity' c
-                               , traceRts s (jString "h$ap_gen_fast: fun " + farity)
-                               , funCase c tag farity
-                               ])
-        , (toJExpr Pap, jVar \parity ->
-                               [ parity |= papArity r1
-                               , traceRts s (jString "h$ap_gen_fast: pap " + parity)
-                               , funCase c tag parity
-                               ])
-        , (toJExpr Con, traceRts s (jString "h$ap_gen_fast: con")
-            <> jwhenS (tag .!=. 0)
-                (appS "throw" [jString "h$ap_gen_fast: invalid apply"])
-                        <> returnS c)
-        , (toJExpr Blackhole, traceRts s (jString "h$ap_gen_fast: blackhole")
-            <> pushStackApply c tag
-            <> push' s [r1, var "h$return"]
-            <> returnS (app "h$blockOnBlackhole" [r1]))
-        ] $ appS "throw" [jString "h$ap_gen_fast: unexpected closure type: " + entryClosureType c]
-      ]
-
-  where
-     -- thunk: push everything to stack frame, enter thunk first
-    pushStackApply :: JExpr -> JExpr -> JStat
-    pushStackApply _c tag =
-      jVar \ap ->
-        [ pushAllRegs tag
-        , ap |= var "h$apply" .! tag
-        , ifS (ap .===. var "h$ap_gen")
-                ((sp |= sp + 2) <> (stack .! (sp-1) |= tag))
-                (sp |= sp + 1)
-        , stack .! sp |= ap
-        , profStat s pushRestoreCCS
-        ]
-
-    funCase :: JExpr -> JExpr -> JExpr -> JStat
-    funCase c tag arity =
-      jVar \ar myAr myRegs regsStart newTag newAp dat p ->
-        [ ar     |= mask8 arity
-        , myAr   |= mask8 tag
-        , myRegs |= tag .>>. 8
-        , traceRts s (jString "h$ap_gen_fast: args: " + myAr
-                      + jString " regs: "             + myRegs)
-        , ifS (myAr .===. ar)
-        -- call the function directly
-          (traceRts s (jString "h$ap_gen_fast: exact") <> returnS c)
-          (ifBlockS (myAr .>. ar)
-          -- push stack frame with remaining args, then call fun
-           [ traceRts s (jString "h$ap_gen_fast: oversat " + sp)
-           , regsStart |= (arity .>>. 8) + 1
-           , sp |= sp + myRegs - regsStart + 1
-           , traceRts s (jString "h$ap_gen_fast: oversat " + sp)
-           , pushArgs regsStart myRegs
-           , newTag |= ((myRegs-( arity.>>.8)).<<.8).|.myAr-ar
-           , newAp |= var "h$apply" .! newTag
-           , ifS (newAp .===. var "h$ap_gen")
-                 ((sp |= sp + 2) <> (stack .! (sp - 1) |= newTag))
-                 (sp |= sp + 1)
-           , stack .! sp |= newAp
-           , profStat s pushRestoreCCS
-           , returnS c
-           ]
-          -- else
-           [traceRts s (jString "h$ap_gen_fast: undersat: " + myRegs + jString " " + tag)
-           , jwhenS (tag .!=. 0) $ mconcat
-               [ p |= var "h$paps" .! myRegs
-               , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr]
-               , loop 0 (.<. myRegs)
-                 (\i -> (dat .^ "push")
-                   `ApplStat` [app "h$getReg" [i+2]] <> postIncrS i)
-               , r1 |= initClosure s p dat jCurrentCCS
-               ]
-           , returnStack
-           ])
-        ]
-
-
-    pushAllRegs :: JExpr -> JStat
-    pushAllRegs tag =
-      jVar \regs ->
-        [ regs |= tag .>>. 8
-        , sp |= sp + regs
-        , SwitchStat regs (map pushReg [65,64..2]) mempty
-        ]
-      where
-        pushReg :: Int -> (JExpr, JStat)
-        pushReg r = (toJExpr (r-1),  stack .! (sp - toJExpr (r - 2)) |= jsReg r)
-
-    pushArgs :: JExpr -> JExpr -> JStat
-    pushArgs start end =
-      loop end (.>=.start) (\i -> traceRts s (jString "pushing register: " + i)
-                             <> (stack .! (sp + start - i) |= app "h$getReg" [i+1])
-                             <> postDecrS i
-                           )
-
--- | Make specialized apply function for the given ApplySpec
-specApply :: StgToJSConfig -> ApplySpec -> JStat
-specApply cfg spec@(ApplySpec conv nargs nvars) =
-  let fun_name = specApplyName spec
-  in case conv of
-    RegsConv  -> fastApply  cfg fun_name nargs nvars
-    StackConv -> stackApply cfg fun_name nargs nvars
-
--- | Make specialized apply function with Stack calling convention
-stackApply
-  :: StgToJSConfig
-  -> FastString
-  -> Int
-  -> Int
-  -> JStat
-stackApply s fun_name nargs nvars =
-  -- special case for h$ap_0_0
-  if nargs == 0 && nvars == 0
-    then closure info0 body0
-    else closure info body
-  where
-    info  = ClosureInfo (TxtI fun_name) (CIRegs 0 [PtrV]) fun_name (CILayoutUnknown nvars) CIStackFrame mempty
-    info0 = ClosureInfo (TxtI fun_name) (CIRegs 0 [PtrV]) fun_name (CILayoutFixed 0 [])    CIStackFrame mempty
-
-    body0 = adjSpN' 1 <> enter s r1
-
-    body = jVar \c ->
-             [ c |= closureEntry r1
-             , traceRts s (toJExpr fun_name
-                           + jString " "
-                           + (c .^ "n")
-                           + jString " sp: " + sp
-                           + jString " a: "  + (c .^ "a"))
-             , SwitchStat (entryClosureType c)
-               [ (toJExpr Thunk, traceRts s (toJExpr $ fun_name <> ": thunk") <> profStat s pushRestoreCCS <> returnS c)
-               , (toJExpr Fun, traceRts s (toJExpr $ fun_name <> ": fun") <> funCase c)
-               , (toJExpr Pap, traceRts s (toJExpr $ fun_name <> ": pap") <> papCase c)
-               , (toJExpr Blackhole, push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))
-               ] (appS "throw" [toJExpr ("panic: " <> fun_name <> ", unexpected closure type: ") + (entryClosureType c)])
-             ]
-
-    funExact c = popSkip 1 (reverse $ take nvars jsRegsFromR2) <> returnS c
-    stackArgs = map (\x -> stack .! (sp - toJExpr x)) [1..nvars]
-
-    papCase :: JExpr -> JStat
-    papCase c = jVar \expr arity0 arity ->
-      case expr of
-        ValExpr (JVar pap) -> [ arity0 |= papArity r1
-                              , arity |= mask8 arity0
-                              , traceRts s (toJExpr (fun_name <> ": found pap, arity: ") + arity)
-                              , ifS (toJExpr nargs .===. arity)
-                              --then
-                                (traceRts s (toJExpr (fun_name <> ": exact")) <> funExact c)
-                              -- else
-                                (ifS (toJExpr nargs .>. arity)
-                                  (traceRts s (toJExpr (fun_name <> ": oversat")) <> oversatCase c arity0 arity)
-                                  (traceRts s (toJExpr (fun_name <> ": undersat"))
-                                   <> mkPap s pap r1 (toJExpr nargs) stackArgs
-                                   <> (sp |= sp - toJExpr (nvars + 1))
-                                   <> (r1 |= toJExpr pap)
-                                   <> returnStack))
-                              ]
-        _                   -> mempty
-
-
-    funCase :: JExpr -> JStat
-    funCase c = jVar \expr ar0 ar ->
-      case expr of
-        ValExpr (JVar pap) -> [ ar0 |= funArity' c
-                              , ar |= mask8 ar0
-                              , ifS (toJExpr nargs .===. ar)
-                                (traceRts s (toJExpr (fun_name <> ": exact")) <> funExact c)
-                                (ifS (toJExpr nargs .>. ar)
-                                 (traceRts s (toJExpr (fun_name <> ": oversat"))
-                                  <> oversatCase c ar0 ar)
-                                 (traceRts s (toJExpr (fun_name <> ": undersat"))
-                                  <> mkPap s pap (toJExpr R1) (toJExpr nargs) stackArgs
-                                  <> (sp |= sp - toJExpr (nvars+1))
-                                  <> (r1 |= toJExpr pap)
-                                  <> returnStack))
-                              ]
-        _                  -> mempty
-
-
-    -- oversat: call the function but keep enough on the stack for the next
-    oversatCase :: JExpr -- function
-                -> JExpr -- the arity tag
-                -> JExpr -- real arity (arity & 0xff)
-                -> JStat
-    oversatCase c arity arity0 =
-      jVar \rs newAp ->
-        [ rs |= (arity .>>. 8)
-        , loadRegs rs
-        , sp |= sp - rs
-        , newAp |= (var "h$apply" .! ((toJExpr nargs-arity0).|.((toJExpr nvars-rs).<<.8)))
-        , stack .! sp |= newAp
-        , profStat s pushRestoreCCS
-        , traceRts s (toJExpr (fun_name <> ": new stack frame: ") + (newAp .^ "n"))
-        , returnS c
-        ]
-      where
-        loadRegs rs = SwitchStat rs switchAlts mempty
-          where
-            switchAlts = map (\x -> (toJExpr x, jsReg (x+1) |= stack .! (sp - toJExpr x))) [nvars,nvars-1..1]
-
--- | Make specialized apply function with Regs calling convention
---
--- h$ap_n_r_fast is entered if a function of unknown arity is called, n
--- arguments are already in r registers
-fastApply :: StgToJSConfig -> FastString -> Int -> Int -> JStat
-fastApply s fun_name nargs nvars = func ||= body0
-  where
-      -- special case for h$ap_0_0_fast
-      body0 = if nargs == 0 && nvars == 0
-        then jLam (enter s r1)
-        else toJExpr (JFunc myFunArgs body)
-
-      func    = TxtI fun_name
-
-      myFunArgs = []
-
-      regArgs = take nvars jsRegsFromR2
-
-      mkAp :: Int -> Int -> [JExpr]
-      mkAp n' r' = [ specApplyExpr (ApplySpec StackConv n' r') ]
-
-      body =
-        jVar \c farity arity ->
-          [ c |= closureEntry r1
-          , traceRts s (toJExpr (fun_name <> ": sp ") + sp)
-          , SwitchStat (entryClosureType c)
-             [(toJExpr Fun, traceRts s (toJExpr (fun_name <> ": ")
-                                        + clName c
-                                        + jString " (arity: " + (c .^ "a") + jString ")")
-                            <> (farity |= funArity' c)
-                            <> funCase c farity)
-             ,(toJExpr Pap, traceRts s (toJExpr (fun_name <> ": pap")) <> (arity |= papArity r1) <> funCase c arity)
-             ,(toJExpr Thunk, traceRts s (toJExpr (fun_name <> ": thunk")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> profStat s pushRestoreCCS <> returnS c)
-             ,(toJExpr Blackhole, traceRts s (toJExpr (fun_name <> ": blackhole")) <> push' s (reverse regArgs ++ mkAp nargs nvars) <> push' s [r1, var "h$return"] <> returnS (app "h$blockOnBlackhole" [r1]))]
-             (appS "throw" [toJExpr (fun_name <> ": unexpected closure type: ") + entryClosureType c])
-          ]
-
-      funCase :: JExpr -> JExpr -> JStat
-      funCase c arity = jVar \arg ar -> case arg of
-          ValExpr (JVar pap) -> [ ar |= mask8 arity
-                                ,  ifS (toJExpr nargs .===. ar)
-                                  -- then
-                                  (traceRts s (toJExpr (fun_name <> ": exact")) <> returnS c)
-                                  -- else
-                                  (ifS (toJExpr nargs .>. ar)
-                                    --then
-                                    (traceRts s (toJExpr (fun_name <> ": oversat")) <> oversatCase c arity)
-                                    -- else
-                                    (traceRts s (toJExpr (fun_name <> ": undersat"))
-                                     <> mkPap s pap r1 (toJExpr nargs) regArgs
-                                     <> (r1 |= toJExpr pap)
-                                     <> returnStack))
-                                ]
-          _             -> mempty
-
-      oversatCase :: JExpr -> JExpr -> JStat
-      oversatCase c arity =
-         jVar \rs rsRemain ->
-           [ rs |= arity .>>. 8
-           , rsRemain |= toJExpr nvars - rs
-           , traceRts s (toJExpr
-                         (fun_name <> " regs oversat ")
-                          + rs
-                          + jString " remain: "
-                          + rsRemain)
-           , saveRegs rs
-           , sp |= sp + rsRemain + 1
-           , stack .! sp |= var "h$apply" .! ((rsRemain.<<.8).|. (toJExpr nargs - mask8 arity))
-           , profStat s pushRestoreCCS
-           , returnS c
-           ]
-          where
-            saveRegs n = SwitchStat n switchAlts mempty
-              where
-                switchAlts = map (\x -> (toJExpr x, stack .! (sp + toJExpr (nvars-x)) |= jsReg (x+2))) [0..nvars-1]
-
-zeroApply :: StgToJSConfig -> JStat
-zeroApply s = mconcat
-  [ TxtI "h$e" ||= jLam (\c -> (r1 |= c) <> enter s c)
-  ]
-
--- carefully enter a closure that might be a thunk or a function
-
--- ex may be a local var, but must've been copied to R1 before calling this
-enter :: StgToJSConfig -> JExpr -> JStat
-enter s ex = jVar \c ->
-  [ jwhenS (app "typeof" [ex] .!==. jTyObject) returnStack
-  , c |= closureEntry ex
-  , jwhenS (c .===. var "h$unbox_e") ((r1 |= closureField1 ex) <> returnStack)
-  , SwitchStat (entryClosureType c)
-    [ (toJExpr Con, mempty)
-    , (toJExpr Fun, mempty)
-    , (toJExpr Pap, returnStack)
-    , (toJExpr Blackhole, push' s [var "h$ap_0_0", ex, var "h$return"]
-        <> returnS (app "h$blockOnBlackhole" [ex]))
-    ] (returnS c)
-  ]
-
-updates :: StgToJSConfig -> JStat
-updates s = BlockStat
-  [ closure
-      (ClosureInfo (TxtI "h$upd_frame") (CIRegs 0 [PtrV]) "h$upd_frame" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
-      $ jVar \updatee waiters ss si sir ->
-            let unbox_closure = Closure
-                  { clEntry  = var "h$unbox_e"
-                  , clField1 = sir
-                  , clField2 = null_
-                  , clMeta   = 0
-                  , clCC     = Nothing
-                  }
-                updateCC updatee = closureCC updatee |= jCurrentCCS
-            in [ updatee |= stack .! (sp - 1)
-               , traceRts s (jString "h$upd_frame updatee alloc: " + updatee .^ "alloc")
-               , -- wake up threads blocked on blackhole
-                 waiters |= closureField2 updatee
-               , jwhenS (waiters .!==. null_)
-                           (loop 0 (.<. waiters .^ "length")
-                              (\i -> appS "h$wakeupThread" [waiters .! i] <> postIncrS i))
-               , -- update selectors
-                 jwhenS ((app "typeof" [closureMeta updatee] .===. jTyObject) .&&. (closureMeta updatee .^ "sel"))
-                 ((ss |= closureMeta updatee .^ "sel")
-                   <> loop 0 (.<. ss .^ "length") \i -> mconcat
-                        [ si |= ss .! i
-                        , sir |= (closureField2 si) `ApplExpr` [r1]
-                        , ifS (app "typeof" [sir] .===. jTyObject)
-                            (copyClosure DontCopyCC si sir)
-                            (assignClosure si unbox_closure)
-                        , postIncrS i
-                        ])
-               , -- overwrite the object
-                 ifS (app "typeof" [r1] .===. jTyObject)
-                     (mconcat [ traceRts s (jString "$upd_frame: boxed: " + ((closureEntry r1) .^ "n"))
-                              , copyClosure DontCopyCC updatee r1
-                              ])
-                     -- the heap object is represented by another type of value
-                     -- (e.g. a JS number or string) so the unboxing closure
-                     -- will simply return it.
-                     (assignClosure updatee (unbox_closure { clField1 = r1 }))
-               , profStat s (updateCC updatee)
-               , adjSpN' 2
-               , traceRts s (jString "h$upd_frame: updating: "
-                             + updatee
-                             + jString " -> "
-                             + r1)
-               , returnStack
-               ]
-
-   , closure
-      (ClosureInfo (TxtI "h$upd_frame_lne") (CIRegs 0 [PtrV]) "h$upd_frame_lne" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
-      $ jVar \updateePos ->
-          [ updateePos |= stack .! (sp - 1)
-          , (stack .! updateePos |= r1)
-          , adjSpN' 2
-          , traceRts s (jString "h$upd_frame_lne: updating: "
-                         + updateePos
-                         + jString " -> "
-                         + r1)
-          , returnStack
-          ]
-  ]
-
-selectors :: StgToJSConfig -> JStat
-selectors s =
-  mkSel "1"      closureField1
-  <> mkSel "2a"  closureField2
-  <> mkSel "2b"  (closureField1 . closureField2)
-  <> mconcat (map mkSelN [3..16])
-   where
-    mkSelN :: Int -> JStat
-    mkSelN x = mkSel (mkFastString $ show x)
-                     (\e -> SelExpr (closureField2 (toJExpr e))
-                            (TxtI $ mkFastString ("d" ++ show (x-1))))
-
-
-    mkSel :: FastString -> (JExpr -> JExpr) -> JStat
-    mkSel name sel = mconcat
-      [TxtI createName ||= jLam \r -> mconcat
-          [ traceRts s (toJExpr ("selector create: " <> name <> " for ") + (r .^ "alloc"))
-          , ifS (isThunk r .||. isBlackhole r)
-              (returnS (app "h$mkSelThunk" [r, toJExpr (v entryName), toJExpr (v resName)]))
-              (returnS (sel r))
-          ]
-      , TxtI resName ||= jLam \r -> mconcat
-          [ traceRts s (toJExpr ("selector result: " <> name <> " for ") + (r .^ "alloc"))
-          , returnS (sel r)
-          ]
-      , closure
-        (ClosureInfo (TxtI entryName) (CIRegs 0 [PtrV]) ("select " <> name) (CILayoutFixed 1 [PtrV]) CIThunk mempty)
-        (jVar \tgt ->
-          [ tgt |= closureField1 r1
-          , traceRts s (toJExpr ("selector entry: " <> name <> " for ") + (tgt .^ "alloc"))
-          , ifS (isThunk tgt .||. isBlackhole tgt)
-              (preIncrS sp
-               <> (stack .! sp |= var frameName)
-               <> returnS (app "h$e" [tgt]))
-              (returnS (app "h$e" [sel tgt]))
-          ])
-      , closure
-        (ClosureInfo (TxtI frameName) (CIRegs 0 [PtrV]) ("select " <> name <> " frame") (CILayoutFixed 0 []) CIStackFrame mempty)
-        $ mconcat [ traceRts s (toJExpr ("selector frame: " <> name))
-                  , postDecrS sp
-                  , returnS (app "h$e" [sel r1])
-                  ]
-      ]
-
-      where
-         v x   = JVar (TxtI x)
-         n ext =  "h$c_sel_" <> name <> ext
-         createName = n ""
-         resName    = n "_res"
-         entryName  = n "_e"
-         frameName  = n "_frame_e"
-
-
--- arity is the remaining arity after our supplied arguments are applied
-mkPap :: StgToJSConfig
-      -> Ident   -- ^ id of the pap object
-      -> JExpr   -- ^ the function that's called (can be a second pap)
-      -> JExpr   -- ^ number of arguments in pap
-      -> [JExpr] -- ^ values for the supplied arguments
-      -> JStat
-mkPap s tgt fun n values =
-      traceRts s (toJExpr $ "making pap with: " ++ show (length values) ++ " items")
-      `mappend`
-      allocDynamic s True tgt (toJExpr entry) (fun:papAr:map toJExpr values')
-        (if csProf s then Just jCurrentCCS else Nothing)
-  where
-    papAr = funOrPapArity fun Nothing - toJExpr (length values * 256) - n
-
-    values' | GHC.Prelude.null values = [null_]
-            | otherwise   = values
-    entry | length values > numSpecPap = TxtI "h$pap_gen"
-          | otherwise                  = specPapIdents ! length values
-
--- | Number of specialized PAPs (pre-generated for a given number of args)
-numSpecPap :: Int
-numSpecPap = 6
-
--- specialized (faster) pap generated for [0..numSpecPap]
--- others use h$pap_gen
-specPap :: [Int]
-specPap = [0..numSpecPap]
-
--- | Cache of specialized PAP idents
-specPapIdents :: Array Int Ident
-specPapIdents = listArray (0,numSpecPap) $ map (TxtI . mkFastString . ("h$pap_"++) . show) specPap
-
-pap :: StgToJSConfig
-    -> Int
-    -> JStat
-pap s r = closure (ClosureInfo funcIdent CIRegsUnknown funcName (CILayoutUnknown (r+2)) CIPap mempty) body
-  where
-    funcIdent = TxtI funcName
-    funcName = mkFastString ("h$pap_" ++ show r)
-
-    body = jVar \c d f extra ->
-             [ c |= closureField1 r1
-             , d |= closureField2 r1
-             , f |= closureEntry  c
-             , assertRts s (isFun' f .||. isPap' f) (funcName <> ": expected function or pap")
-             , profStat s (enterCostCentreFun currentCCS)
-             , extra |= (funOrPapArity c (Just f) .>>. 8) - toJExpr r
-             , traceRts s (toJExpr (funcName <> ": pap extra args moving: ") + extra)
-             , moveBy extra
-             , loadOwnArgs d
-             , r1 |= c
-             , returnS f
-             ]
-    moveBy extra = SwitchStat extra
-                   (reverse $ map moveCase [1..maxReg-r-1]) mempty
-    moveCase m = (toJExpr m, jsReg (m+r+1) |= jsReg (m+1))
-    loadOwnArgs d = mconcat $ map (\r ->
-        jsReg (r+1) |= dField d (r+2)) [1..r]
-    dField d n = SelExpr d (TxtI . mkFastString $ ('d':show (n-1)))
-
--- Construct a generic PAP
-papGen :: StgToJSConfig -> JStat
-papGen cfg =
-   closure (ClosureInfo funcIdent CIRegsUnknown funcName CILayoutVariable CIPap mempty)
-           (jVar \c f d pr or r ->
-              [ c |= closureField1 r1
-              , d |= closureField2 r1
-              , f |= closureEntry  c
-              , pr |= funOrPapArity c (Just f) .>>. 8
-              , or |= papArity r1 .>>. 8
-              , r |= pr - or
-              , assertRts cfg
-                (isFun' f .||. isPap' f)
-                (jString "h$pap_gen: expected function or pap")
-              , profStat cfg (enterCostCentreFun currentCCS)
-              , traceRts cfg (jString "h$pap_gen: generic pap extra args moving: " + or)
-              , appS "h$moveRegs2" [or, r]
-              , loadOwnArgs d r
-              , r1 |= c
-              , returnS f
-              ])
-
-
-  where
-    funcIdent = TxtI funcName
-    funcName = "h$pap_gen"
-    loadOwnArgs d r =
-      let prop n = d .^ ("d" <> mkFastString (show $ n+1))
-          loadOwnArg n = (toJExpr n, jsReg (n+1) |= prop n)
-      in  SwitchStat r (map loadOwnArg [127,126..1]) mempty
-
--- general utilities
--- move the first n registers, starting at R2, m places up (do not use with negative m)
-moveRegs2 :: JStat
-moveRegs2 = TxtI "h$moveRegs2" ||= jLam moveSwitch
-  where
-    moveSwitch n m = SwitchStat ((n .<<. 8) .|. m) switchCases (defaultCase n m)
-    -- fast cases
-    switchCases = [switchCase n m | n <- [1..5], m <- [1..4]]
-    switchCase :: Int -> Int -> (JExpr, JStat)
-    switchCase n m = (toJExpr $
-                      (n `Bits.shiftL` 8) Bits..|. m
-                     , mconcat (map (`moveRegFast` m) [n+1,n..2])
-                       <> BreakStat Nothing {-[j| break; |]-})
-    moveRegFast n m = jsReg (n+m) |= jsReg n
-    -- fallback
-    defaultCase n m =
-      loop n (.>.0) (\i -> appS "h$setReg" [i+1+m, app "h$getReg" [i+1]] `mappend` postDecrS i)
-
-
--- Initalize a variable sized object from an array of values
-initClosure :: StgToJSConfig -> JExpr -> JExpr -> JExpr -> JExpr
-initClosure cfg entry values ccs = app "h$init_closure"
-  [ newClosure $ Closure
-      { clEntry  = entry
-      , clField1 = null_
-      , clField2 = null_
-      , clMeta   = 0
-      , clCC     = if csProf cfg then Just ccs else Nothing
-      }
-  , values
-  ]
-
--- | Return an expression for every field of the given Id
-getIdFields :: Id -> G [TypedExpr]
-getIdFields i = assocIdExprs i <$> varsForId i
-
--- | Store fields of Id into the given target expressions
-storeIdFields :: Id -> [TypedExpr] -> G JStat
-storeIdFields i dst = do
-  fields <- getIdFields i
-  pure (assignCoerce1 dst fields)
diff --git a/compiler/GHC/StgToJS/Arg.hs b/compiler/GHC/StgToJS/Arg.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Arg.hs
+++ /dev/null
@@ -1,285 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.StgToJS.Args
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
---  Code generation of application arguments
------------------------------------------------------------------------------
-
-module GHC.StgToJS.Arg
-  ( genArg
-  , genIdArg
-  , genIdArgI
-  , genIdStackArgI
-  , allocConStatic
-  , allocUnboxedConStatic
-  , allocateStaticList
-  , jsStaticArg
-  , jsStaticArgs
-  )
-where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax
-import GHC.JS.Make
-
-import GHC.StgToJS.DataCon
-import GHC.StgToJS.Types
-import GHC.StgToJS.Monad
-import GHC.StgToJS.Literal
-import GHC.StgToJS.CoreUtils
-import GHC.StgToJS.Profiling
-import GHC.StgToJS.Ids
-
-import GHC.Builtin.Types
-import GHC.Stg.Syntax
-import GHC.Core.DataCon
-
-import GHC.Types.CostCentre
-import GHC.Types.Unique.FM
-import GHC.Types.Id
-
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import qualified Control.Monad.Trans.State.Strict as State
-
-{-
-Note [ Unboxable Literals Optimization ]
-~~~~~~~~~~~~~~~~~~
-
-Boxable types in the JS backend are represented as heap objects. See Note
-[StgToJS design] in GHC.StgToJS.hs for more details. Some types, such as Int8
-do not benefit from not being wrapped in an object in the JS runtime. This optimization
-detects such types and changes the code generator to generate a more efficient
-representation. The change is minor and saves one level on indirection. Instead
-of generating a wrapper object with a field for the value's payload, such as:
-
-// a JS object for an Int8
-var anInt8 = { d1 = <Int8# payload>
-             , f  : entry function which would scrutinize the payload
-             }
-
-we instead generate:
-
-// notice, no wrapper object. This representation is essentially an Int8# in the JS backend
-var anInt8 = <Int8# payload>
-
-This optimization fires when the follow invariants hold:
-  1. The value in question has a Type which has a single data constructor
-  2. The data constructor holds a single field that is monomorphic
-  3. The value in question is distinguishable from a THUNK using the JavaScript typeof operator.
-
-From the haskell perspective this means that:
-  1. An Int8# is always a JavaScript 'number', never a JavaScript object.
-  2. An Int8 is either a JavaScript 'number' _or_ a JavaScript object depending on
-     its use case and this optimization.
-
-How is this sound?
-~~~~~~~~~~~~~~~~~~
-
-Normally this optimization would violate the guarantees of call-by-need, however
-we are able to statically detect whether the type in question will be a THUNK or
-not during code gen because the JS backend is consuming STG and we can check
-during runtime with the typeof operator. Similarly we can check at runtime using
-JavaScript's introspection operator `typeof`. Thus, when we know the value in
-question will not be a THUNK we can safely elide the wrapping object, which
-unboxes the value in the JS runtime. For example, an Int8 contains an Int8#
-which has the JavaScript type 'number'. A THUNK of type Int8 would have a
-JavaScript type 'object', so using 'typeof' allows us to check if we have
-something that is definitely evaluated (i.e., a 'number') or something else. If
-it is an 'object' then we may need to enter it to begin its evaluation. Consider
-a type which has a 'ThreadId#' field; such as type would not be subject to this
-optimization because it has to be represented as a JavaScript 'object' and thus
-cannot be unboxed in this way. Another (edge) case is Int64#. Int64# is
-similarly not unboxable in this way because Int64# does not fit in one
-JavaScript variable and thus requires an 'object' for its representation in the
-JavaScript runtime.
-
--}
-
--- | Generate JS code for static arguments
-genStaticArg :: HasDebugCallStack => StgArg -> G [StaticArg]
-genStaticArg a = case a of
-  StgLitArg l -> map StaticLitArg <$> genStaticLit l
-  StgVarArg i -> do
-    unFloat <- State.gets gsUnfloated
-    case lookupUFM unFloat i of
-      Nothing -> reg
-      Just expr -> unfloated expr
-     where
-       r = uTypeVt . stgArgType $ a
-       reg
-         | isVoid r            =
-             return []
-         | i == trueDataConId  =
-             return [StaticLitArg (BoolLit True)]
-         | i == falseDataConId =
-             return [StaticLitArg (BoolLit False)]
-         | isMultiVar r        =
-             map (\(TxtI t) -> StaticObjArg t) <$> mapM (identForIdN i) [1..varSize r] -- this seems wrong, not an obj?
-         | otherwise           = (\(TxtI it) -> [StaticObjArg it]) <$> identForId i
-
-       unfloated :: CgStgExpr -> G [StaticArg]
-       unfloated (StgLit l) = map StaticLitArg <$> genStaticLit l
-       unfloated (StgConApp dc _n args _)
-         | isBoolDataCon dc || isUnboxableCon dc =
-             (:[]) . allocUnboxedConStatic dc . concat <$> mapM genStaticArg args -- fixme what is allocunboxedcon?
-         | null args = (\(TxtI t) -> [StaticObjArg t]) <$> identForId (dataConWorkId dc)
-         | otherwise = do
-             as       <- concat <$> mapM genStaticArg args
-             (TxtI e) <- identForDataConWorker dc
-             return [StaticConArg e as]
-       unfloated x = pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x)
-
--- | Generate JS code for an StgArg
-genArg :: HasDebugCallStack => StgArg -> G [JExpr]
-genArg a = case a of
-  StgLitArg l -> genLit l
-  StgVarArg i -> do
-    unFloat <- State.gets gsUnfloated
-    case lookupUFM unFloat i of
-      Just expr -> unfloated expr
-      Nothing
-       | isVoid r            -> return []
-       | i == trueDataConId  -> return [true_]
-       | i == falseDataConId -> return [false_]
-       | isMultiVar r        -> mapM (varForIdN i) [1..varSize r]
-       | otherwise           -> (:[]) <$> varForId i
-
-   where
-     -- if our argument is a joinid, it can be an unboxed tuple
-     r :: HasDebugCallStack => VarType
-     r = uTypeVt . stgArgType $ a
-
-     unfloated :: HasDebugCallStack => CgStgExpr -> G [JExpr]
-     unfloated = \case
-      StgLit l -> genLit l
-      StgConApp dc _n args _
-       | isBoolDataCon dc || isUnboxableCon dc
-       -> (:[]) . allocUnboxedCon dc . concat <$> mapM genArg args
-       | null args -> (:[]) <$> varForId (dataConWorkId dc)
-       | otherwise -> do
-           as <- concat <$> mapM genArg args
-           e  <- varForDataConWorker dc
-           inl_alloc <- csInlineAlloc <$> getSettings
-           return [allocDynamicE inl_alloc e as Nothing]
-      x -> pprPanic "genArg: unexpected unfloated expression" (pprStgExpr panicStgPprOpts x)
-
--- | Generate a Var as JExpr
-genIdArg :: HasDebugCallStack => Id -> G [JExpr]
-genIdArg i = genArg (StgVarArg i)
-
--- | Generate an Id as an Ident
-genIdArgI :: HasDebugCallStack => Id -> G [Ident]
-genIdArgI i
-  | isVoid r     = return []
-  | isMultiVar r = mapM (identForIdN i) [1..varSize r]
-  | otherwise    = (:[]) <$> identForId i
-  where
-    r = uTypeVt . idType $ i
-
--- | Generate IDs for stack arguments. See 'StgToJS.Expr.loadRetArgs' for use case
-genIdStackArgI :: HasDebugCallStack => Id -> G [(Ident,StackSlot)]
-genIdStackArgI i = zipWith f [1..] <$> genIdArgI i
-  where
-    f :: Int -> Ident -> (Ident,StackSlot)
-    f n ident = (ident, SlotId i n)
-
--- | Allocate Static Constructors
-allocConStatic :: HasDebugCallStack => Ident -> CostCentreStack -> DataCon -> [StgArg] -> G ()
-allocConStatic (TxtI to) cc con args = do
-  as <- mapM genStaticArg args
-  cc' <- costCentreStackLbl cc
-  allocConStatic' cc' (concat as)
-  where
-    -- see Note [ Unboxable Literals Optimization ] for the purpose of these
-    -- checks
-    allocConStatic' :: HasDebugCallStack => Maybe Ident -> [StaticArg] -> G ()
-    allocConStatic' cc' []
-      | isBoolDataCon con && dataConTag con == 1 =
-           emitStatic to (StaticUnboxed $ StaticUnboxedBool False) cc'
-      | isBoolDataCon con && dataConTag con == 2 =
-           emitStatic to (StaticUnboxed $ StaticUnboxedBool True) cc'
-      | otherwise = do
-           (TxtI e) <- identForDataConWorker con
-           emitStatic to (StaticData e []) cc'
-    allocConStatic' cc' [x]
-      | isUnboxableCon con =
-        case x of
-          StaticLitArg (IntLit i)    ->
-            emitStatic to (StaticUnboxed $ StaticUnboxedInt i) cc'
-          StaticLitArg (BoolLit b)   ->
-            emitStatic to (StaticUnboxed $ StaticUnboxedBool b) cc'
-          StaticLitArg (DoubleLit d) ->
-            emitStatic to (StaticUnboxed $ StaticUnboxedDouble d) cc'
-          _                          ->
-            pprPanic "allocConStatic: invalid unboxed literal" (ppr x)
-    allocConStatic' cc' xs =
-           if con == consDataCon
-              then case args of
-                (a0:a1:_) -> flip (emitStatic to) cc' =<< allocateStaticList [a0] a1
-                _         -> panic "allocConStatic: invalid args for consDataCon"
-              else do
-                (TxtI e) <- identForDataConWorker con
-                emitStatic to (StaticData e xs) cc'
-
--- | Allocate unboxed constructors
-allocUnboxedConStatic :: DataCon -> [StaticArg] -> StaticArg
-allocUnboxedConStatic con = \case
-  []
-    | isBoolDataCon con && dataConTag con == 1
-    -> StaticLitArg (BoolLit False)
-    | isBoolDataCon con && dataConTag con == 2
-    -> StaticLitArg (BoolLit True)
-  [a@(StaticLitArg (IntLit _i))]    -> a
-  [a@(StaticLitArg (DoubleLit _d))] -> a
-  _ -> pprPanic "allocUnboxedConStatic: not an unboxed constructor" (ppr con)
-
-
--- | Allocate Static list
-allocateStaticList :: [StgArg] -> StgArg -> G StaticVal
-allocateStaticList xs a@(StgVarArg i)
-  | isDataConId_maybe i == Just nilDataCon = listAlloc xs Nothing
-  | otherwise = do
-      unFloat <- State.gets gsUnfloated
-      case lookupUFM unFloat i of
-        Just (StgConApp dc _n [h,t] _)
-          | dc == consDataCon -> allocateStaticList (h:xs) t
-        _ -> listAlloc xs (Just a)
-  where
-    listAlloc :: [StgArg] -> Maybe StgArg -> G StaticVal
-    listAlloc xs Nothing  = do
-      as <- concat . reverse <$> mapM genStaticArg xs
-      return (StaticList as Nothing)
-    listAlloc xs (Just r) = do
-      as <- concat . reverse <$> mapM genStaticArg xs
-      r' <- genStaticArg r
-      case r' of
-        [StaticObjArg ri] -> return (StaticList as (Just ri))
-        _                 ->
-          pprPanic "allocateStaticList: invalid argument (tail)" (ppr (xs, r))
-allocateStaticList _ _ = panic "allocateStaticList: unexpected literal in list"
-
--- | Generate JS code corresponding to a static arg
-jsStaticArg :: StaticArg -> JExpr
-jsStaticArg = \case
-  StaticLitArg l      -> toJExpr l
-  StaticObjArg t      -> ValExpr (JVar (TxtI t))
-  StaticConArg c args ->
-    allocDynamicE False (ValExpr . JVar . TxtI $ c) (map jsStaticArg args) Nothing
-
--- | Generate JS code corresponding to a list of static args
-jsStaticArgs :: [StaticArg] -> JExpr
-jsStaticArgs = ValExpr . JList . map jsStaticArg
-
diff --git a/compiler/GHC/StgToJS/Closure.hs b/compiler/GHC/StgToJS/Closure.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Closure.hs
+++ /dev/null
@@ -1,156 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-
-module GHC.StgToJS.Closure
-  ( closureInfoStat
-  , closure
-  , conClosure
-  , Closure (..)
-  , newClosure
-  , assignClosure
-  , CopyCC (..)
-  , copyClosure
-  )
-where
-
-import GHC.Prelude
-import GHC.Data.FastString
-
-import GHC.StgToJS.Heap
-import GHC.StgToJS.Types
-import GHC.StgToJS.CoreUtils
-import GHC.StgToJS.Regs (stack,sp)
-
-import GHC.JS.Make
-import GHC.JS.Syntax
-
-import Data.Monoid
-import qualified Data.Bits as Bits
-
-closureInfoStat :: Bool -> ClosureInfo -> JStat
-closureInfoStat debug (ClosureInfo obj rs name layout ctype srefs)
-  = setObjInfoL debug obj rs layout ty name tag srefs
-      where
-        !ty = case ctype of
-          CIThunk      -> Thunk
-          CIFun {}     -> Fun
-          CICon {}     -> Con
-          CIBlackhole  -> Blackhole
-          CIPap        -> Pap
-          CIStackFrame -> StackFrame
-        !tag = case ctype of
-          CIThunk           -> 0
-          CIFun arity nregs -> mkArityTag arity nregs
-          CICon con         -> con
-          CIBlackhole       -> 0
-          CIPap             -> 0
-          CIStackFrame      -> 0
-
-
-setObjInfoL :: Bool        -- ^ debug: output symbol names
-            -> Ident       -- ^ the object name
-            -> CIRegs      -- ^ things in registers
-            -> CILayout    -- ^ layout of the object
-            -> ClosureType -- ^ closure type
-            -> FastString  -- ^ object name, for printing
-            -> Int         -- ^ `a' argument, depends on type (arity, conid)
-            -> CIStatic    -- ^ static refs
-            -> JStat
-setObjInfoL debug obj rs layout t n a
-  = setObjInfo debug obj t n field_types a size rs
-      where
-        size = case layout of
-          CILayoutVariable   -> (-1)
-          CILayoutUnknown sz -> sz
-          CILayoutFixed sz _ -> sz
-        field_types = case layout of
-          CILayoutVariable     -> []
-          CILayoutUnknown size -> toTypeList (replicate size ObjV)
-          CILayoutFixed _ fs   -> toTypeList fs
-
-setObjInfo :: Bool        -- ^ debug: output all symbol names
-           -> Ident       -- ^ the thing to modify
-           -> ClosureType -- ^ closure type
-           -> FastString  -- ^ object name, for printing
-           -> [Int]       -- ^ list of item types in the object, if known (free variables, datacon fields)
-           -> Int         -- ^ extra 'a' parameter, for constructor tag or arity
-           -> Int         -- ^ object size, -1 (number of vars) for unknown
-           -> CIRegs      -- ^ things in registers
-           -> CIStatic    -- ^ static refs
-           -> JStat
-setObjInfo debug obj t name fields a size regs static
-   | debug     = appS "h$setObjInfo" [ toJExpr obj
-                                     , toJExpr t
-                                     , toJExpr name
-                                     , toJExpr fields
-                                     , toJExpr a
-                                     , toJExpr size
-                                     , toJExpr (regTag regs)
-                                     , toJExpr static
-                                     ]
-   | otherwise = appS "h$o" [ toJExpr obj
-                            , toJExpr t
-                            , toJExpr a
-                            , toJExpr size
-                            , toJExpr (regTag regs)
-                            , toJExpr static
-                            ]
-  where
-    regTag CIRegsUnknown       = -1
-    regTag (CIRegs skip types) =
-      let nregs = sum $ map varSize types
-      in  skip + (nregs `Bits.shiftL` 8)
-
-closure :: ClosureInfo -- ^ object being info'd see @ciVar@ in @ClosureInfo@
-        -> JStat       -- ^ rhs
-        -> JStat
-closure ci body = (ciVar ci ||= jLam body) `mappend` closureInfoStat False ci
-
-conClosure :: Ident -> FastString -> CILayout -> Int -> JStat
-conClosure symbol name layout constr =
-  closure (ClosureInfo symbol (CIRegs 0 [PtrV]) name layout (CICon constr) mempty)
-          (returnS (stack .! sp))
-
--- | Used to pass arguments to newClosure with some safety
-data Closure = Closure
-  { clEntry  :: JExpr
-  , clField1 :: JExpr
-  , clField2 :: JExpr
-  , clMeta   :: JExpr
-  , clCC     :: Maybe JExpr
-  }
-
-newClosure :: Closure -> JExpr
-newClosure Closure{..} =
-  let xs = [ (closureEntry_ , clEntry)
-           , (closureField1_, clField1)
-           , (closureField2_, clField2)
-           , (closureMeta_  , clMeta)
-           ]
-  in case clCC of
-    -- CC field is optional (probably to minimize code size as we could assign
-    -- null_, but we get the same effect implicitly)
-    Nothing -> ValExpr (jhFromList xs)
-    Just cc -> ValExpr (jhFromList $ (closureCC_,cc) : xs)
-
-assignClosure :: JExpr -> Closure -> JStat
-assignClosure t Closure{..} = BlockStat
-  [ closureEntry  t |= clEntry
-  , closureField1 t |= clField1
-  , closureField2 t |= clField2
-  , closureMeta   t |= clMeta
-  ] <> case clCC of
-      Nothing -> mempty
-      Just cc -> closureCC t |= cc
-
-data CopyCC = CopyCC | DontCopyCC
-
-copyClosure :: CopyCC -> JExpr -> JExpr -> JStat
-copyClosure copy_cc t s = BlockStat
-  [ closureEntry  t |= closureEntry  s
-  , closureField1 t |= closureField1 s
-  , closureField2 t |= closureField2 s
-  , closureMeta   t |= closureMeta   s
-  ] <> case copy_cc of
-      DontCopyCC -> mempty
-      CopyCC     -> closureCC t |= closureCC s
diff --git a/compiler/GHC/StgToJS/CodeGen.hs b/compiler/GHC/StgToJS/CodeGen.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/CodeGen.hs
+++ /dev/null
@@ -1,367 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE LambdaCase #-}
-
--- | JavaScript code generator
-module GHC.StgToJS.CodeGen
-  ( stgToJS
-  )
-where
-
-import GHC.Prelude
-
-import GHC.Driver.Flags (DumpFlag (Opt_D_dump_js))
-
-import GHC.JS.Ppr
-import GHC.JS.Syntax
-import GHC.JS.Make
-import GHC.JS.Transform
-
-import GHC.StgToJS.Arg
-import GHC.StgToJS.Sinker
-import GHC.StgToJS.Types
-import qualified GHC.StgToJS.Object as Object
-import GHC.StgToJS.StgUtils
-import GHC.StgToJS.CoreUtils
-import GHC.StgToJS.Deps
-import GHC.StgToJS.Expr
-import GHC.StgToJS.ExprCtx
-import GHC.StgToJS.Monad
-import GHC.StgToJS.Profiling
-import GHC.StgToJS.Regs
-import GHC.StgToJS.StaticPtr
-import GHC.StgToJS.Symbols
-import GHC.StgToJS.Stack
-import GHC.StgToJS.Ids
-
-import GHC.Stg.Syntax
-import GHC.Core.DataCon
-import GHC.Core.TyCo.Rep (scaledThing)
-
-import GHC.Unit.Module
-import GHC.Linker.Types (SptEntry (..))
-
-import GHC.Types.CostCentre
-import GHC.Types.ForeignStubs (ForeignStubs (..), getCHeader, getCStub)
-import GHC.Types.RepType
-import GHC.Types.Id
-import GHC.Types.Unique
-
-import GHC.Data.FastString
-import GHC.Utils.Encoding
-import GHC.Utils.Logger
-import GHC.Utils.Panic
-import GHC.Utils.Misc
-import GHC.Utils.Binary
-import qualified Control.Monad.Trans.State.Strict as State
-import GHC.Utils.Outputable hiding ((<>))
-
-import qualified Data.Set as S
-import Data.Monoid
-import Control.Monad
-import System.Directory
-import System.FilePath
-
--- | Code generator for JavaScript
-stgToJS
-  :: Logger
-  -> StgToJSConfig
-  -> [CgStgTopBinding]
-  -> Module
-  -> [SptEntry]
-  -> ForeignStubs
-  -> CollectedCCs
-  -> FilePath -- ^ Output file name
-  -> IO ()
-stgToJS logger config stg_binds0 this_mod spt_entries foreign_stubs cccs output_fn = do
-
-  let (unfloated_binds, stg_binds) = sinkPgm this_mod stg_binds0
-    -- TODO: avoid top level lifting in core-2-core when the JS backend is
-    -- enabled instead of undoing it here
-
-    -- TODO: add dump pass for optimized STG ast for JS
-
-  (deps,lus) <- runG config this_mod unfloated_binds $ do
-    ifProfilingM $ initCostCentres cccs
-    lus  <- genUnits this_mod stg_binds spt_entries foreign_stubs
-    deps <- genDependencyData this_mod lus
-    pure (deps,lus)
-
-  -- Doc to dump when -ddump-js is enabled
-  when (logHasDumpFlag logger Opt_D_dump_js) $ do
-    putDumpFileMaybe logger Opt_D_dump_js "JavaScript code" FormatJS
-      $ vcat (fmap (docToSDoc . jsToDoc . oiStat . luObjUnit) lus)
-
-  -- Write the object file
-  bh <- openBinMem (4 * 1024 * 1000) -- a bit less than 4kB
-  Object.putObject bh (moduleName this_mod) deps (map luObjUnit lus)
-
-  createDirectoryIfMissing True (takeDirectory output_fn)
-  writeBinMem bh output_fn
-
-
-
--- | Generate the ingredients for the linkable units for this module
-genUnits :: HasDebugCallStack
-         => Module
-         -> [CgStgTopBinding]
-         -> [SptEntry]
-         -> ForeignStubs
-         -> G [LinkableUnit] -- ^ the linkable units
-genUnits m ss spt_entries foreign_stubs = do
-    gbl     <- generateGlobalBlock
-    exports <- generateExportsBlock
-    others  <- go 2 ss
-    pure (gbl:exports:others)
-    where
-      go :: HasDebugCallStack
-         => Int                 -- the block we're generating (block 0 is the global unit for the module)
-         -> [CgStgTopBinding]
-         -> G [LinkableUnit]
-      go !n = \case
-        []     -> pure []
-        (x:xs) -> do
-          mlu <- generateBlock x n
-          lus <- go (n+1) xs
-          return (maybe lus (:lus) mlu)
-
-      --   Generate the global unit that all other blocks in the module depend on
-      --   used for cost centres and static initializers
-      --   the global unit has no dependencies, exports the moduleGlobalSymbol
-      generateGlobalBlock :: HasDebugCallStack => G LinkableUnit
-      generateGlobalBlock = do
-        glbl <- State.gets gsGlobal
-        staticInit <-
-          initStaticPtrs spt_entries
-        let stat = ( -- O.optimize .
-                     jsSaturate (Just $ modulePrefix m 1)
-                   $ mconcat (reverse glbl) <> staticInit)
-        let syms = [moduleGlobalSymbol m]
-        let oi = ObjUnit
-                  { oiSymbols  = syms
-                  , oiClInfo   = []
-                  , oiStatic   = []
-                  , oiStat     = stat
-                  , oiRaw      = mempty
-                  , oiFExports = []
-                  , oiFImports = []
-                  }
-        let lu = LinkableUnit
-                  { luObjUnit      = oi
-                  , luIdExports    = []
-                  , luOtherExports = syms
-                  , luIdDeps       = []
-                  , luPseudoIdDeps = []
-                  , luOtherDeps    = []
-                  , luRequired     = False
-                  , luForeignRefs  = []
-                  }
-        pure lu
-
-      generateExportsBlock :: HasDebugCallStack => G LinkableUnit
-      generateExportsBlock = do
-        let (f_hdr, f_c) = case foreign_stubs of
-                                  NoStubs            -> (empty, empty)
-                                  ForeignStubs hdr c -> (getCHeader hdr, getCStub c)
-            unique_deps = map mkUniqueDep (lines $ renderWithContext defaultSDocContext f_hdr)
-            mkUniqueDep (tag:xs) = mkUnique tag (read xs)
-            mkUniqueDep []       = panic "mkUniqueDep"
-
-        let syms = [moduleExportsSymbol m]
-        let raw  = utf8EncodeByteString $ renderWithContext defaultSDocContext f_c
-        let oi = ObjUnit
-                  { oiSymbols  = syms
-                  , oiClInfo   = []
-                  , oiStatic   = []
-                  , oiStat     = mempty
-                  , oiRaw      = raw
-                  , oiFExports = []
-                  , oiFImports = []
-                  }
-        let lu = LinkableUnit
-                  { luObjUnit      = oi
-                  , luIdExports    = []
-                  , luOtherExports = syms
-                  , luIdDeps       = []
-                  , luPseudoIdDeps = unique_deps
-                  , luOtherDeps    = []
-                  , luRequired     = True
-                  , luForeignRefs  = []
-                  }
-        pure lu
-
-      --   Generate the linkable unit for one binding or group of
-      --   mutually recursive bindings
-      generateBlock :: HasDebugCallStack
-                    => CgStgTopBinding
-                    -> Int
-                    -> G (Maybe LinkableUnit)
-      generateBlock top_bind n = case top_bind of
-        StgTopStringLit bnd str -> do
-          bids <- identsForId bnd
-          case bids of
-            [(TxtI b1t),(TxtI b2t)] -> do
-              -- [e1,e2] <- genLit (MachStr str)
-              emitStatic b1t (StaticUnboxed (StaticUnboxedString str)) Nothing
-              emitStatic b2t (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing
-              _extraTl   <- State.gets (ggsToplevelStats . gsGroup)
-              si        <- State.gets (ggsStatic . gsGroup)
-              let body = mempty -- mconcat (reverse extraTl) <> b1 ||= e1 <> b2 ||= e2
-              let stat = jsSaturate (Just $ modulePrefix m n) body
-              let ids = [bnd]
-              syms <- (\(TxtI i) -> [i]) <$> identForId bnd
-              let oi = ObjUnit
-                        { oiSymbols  = syms
-                        , oiClInfo   = []
-                        , oiStatic   = si
-                        , oiStat     = stat
-                        , oiRaw      = ""
-                        , oiFExports = []
-                        , oiFImports = []
-                        }
-              let lu = LinkableUnit
-                        { luObjUnit      = oi
-                        , luIdExports    = ids
-                        , luOtherExports = []
-                        , luIdDeps       = []
-                        , luPseudoIdDeps = []
-                        , luOtherDeps    = []
-                        , luRequired     = False
-                        , luForeignRefs  = []
-                        }
-              pure (Just lu)
-            _ -> panic "generateBlock: invalid size"
-
-        StgTopLifted decl -> do
-          tl        <- genToplevel decl
-          extraTl   <- State.gets (ggsToplevelStats . gsGroup)
-          ci        <- State.gets (ggsClosureInfo . gsGroup)
-          si        <- State.gets (ggsStatic . gsGroup)
-          unf       <- State.gets gsUnfloated
-          extraDeps <- State.gets (ggsExtraDeps . gsGroup)
-          fRefs     <- State.gets (ggsForeignRefs . gsGroup)
-          resetGroup
-          let allDeps  = collectIds unf decl
-              topDeps  = collectTopIds decl
-              required = hasExport decl
-              stat     = -- Opt.optimize .
-                         jsSaturate (Just $ modulePrefix m n)
-                       $ mconcat (reverse extraTl) <> tl
-          syms <- mapM (fmap (\(TxtI i) -> i) . identForId) topDeps
-          let oi = ObjUnit
-                    { oiSymbols  = syms
-                    , oiClInfo   = ci
-                    , oiStatic   = si
-                    , oiStat     = stat
-                    , oiRaw      = ""
-                    , oiFExports = []
-                    , oiFImports = fRefs
-                    }
-          let lu = LinkableUnit
-                    { luObjUnit      = oi
-                    , luIdExports    = topDeps
-                    , luOtherExports = []
-                    , luIdDeps       = allDeps
-                    , luPseudoIdDeps = []
-                    , luOtherDeps    = S.toList extraDeps
-                    , luRequired     = required
-                    , luForeignRefs  = fRefs
-                    }
-          pure $! seqList topDeps `seq` seqList allDeps `seq` Just lu
-
--- | variable prefix for the nth block in module
-modulePrefix :: Module -> Int -> FastString
-modulePrefix m n =
-  let encMod = zEncodeString . moduleNameString . moduleName $ m
-  in  mkFastString $ "h$" ++ encMod ++ "_id_" ++ show n
-
-genToplevel :: CgStgBinding -> G JStat
-genToplevel (StgNonRec bndr rhs) = genToplevelDecl bndr rhs
-genToplevel (StgRec bs)          =
-  mconcat <$> mapM (\(bndr, rhs) -> genToplevelDecl bndr rhs) bs
-
-genToplevelDecl :: Id -> CgStgRhs -> G JStat
-genToplevelDecl i rhs = do
-  s1 <- resetSlots (genToplevelConEntry i rhs)
-  s2 <- resetSlots (genToplevelRhs i rhs)
-  return (s1 <> s2)
-
-genToplevelConEntry :: Id -> CgStgRhs -> G JStat
-genToplevelConEntry i rhs = case rhs of
-   StgRhsCon _cc con _mu _ts _args
-     | isDataConWorkId i
-       -> genSetConInfo i con (stgRhsLive rhs) -- NoSRT
-   StgRhsClosure _ _cc _upd_flag _args _body
-     | Just dc <- isDataConWorkId_maybe i
-       -> genSetConInfo i dc (stgRhsLive rhs) -- srt
-   _ -> pure mempty
-
-genSetConInfo :: HasDebugCallStack => Id -> DataCon -> LiveVars -> G JStat
-genSetConInfo i d l {- srt -} = do
-  ei <- identForDataConEntryId i
-  sr <- genStaticRefs l
-  emitClosureInfo $ ClosureInfo ei
-                                (CIRegs 0 [PtrV])
-                                (mkFastString $ renderWithContext defaultSDocContext (ppr d))
-                                (fixedLayout $ map uTypeVt fields)
-                                (CICon $ dataConTag d)
-                                sr
-  return (ei ||= mkDataEntry)
-    where
-      -- dataConRepArgTys sometimes returns unboxed tuples. is that a bug?
-      fields = concatMap (map primRepToType . typePrimRep . unwrapType . scaledThing)
-                         (dataConRepArgTys d)
-        -- concatMap (map slotTyToType . repTypeSlots . repType) (dataConRepArgTys d)
-
-mkDataEntry :: JExpr
-mkDataEntry = ValExpr $ JFunc [] returnStack
-
-genToplevelRhs :: Id -> CgStgRhs -> G JStat
--- general cases:
-genToplevelRhs i rhs = case rhs of
-  StgRhsCon cc con _mu _tys args -> do
-    ii <- identForId i
-    allocConStatic ii cc con args
-    return mempty
-  StgRhsClosure _ext cc _upd_flag {- srt -} args body -> do
-    {-
-      algorithm:
-       - collect all Id refs that are in the global id cache
-       - count usage in body for each ref
-       - order by increasing use
-       - prepend loading lives var to body: body can stay the same
-    -}
-    eid@(TxtI eidt) <- identForEntryId i
-    (TxtI idt)   <- identForId i
-    body <- genBody (initExprCtx i) i R2 args body
-    global_occs <- globalOccs (jsSaturate (Just "ghcjs_tmp_sat_") body)
-    let lidents = map global_ident global_occs
-    let lids    = map global_id    global_occs
-    let lidents' = map identFS lidents
-    CIStaticRefs sr0 <- genStaticRefsRhs rhs
-    let sri = filter (`notElem` lidents') sr0
-        sr   = CIStaticRefs sri
-    et <- genEntryType args
-    ll <- loadLiveFun lids
-    (static, regs, upd) <-
-      if et == CIThunk
-        then do
-          r <- updateThunk
-          pure (StaticThunk (Just (eidt, map StaticObjArg lidents')), CIRegs 0 [PtrV],r)
-        else return (StaticFun eidt (map StaticObjArg lidents'),
-                    (if null lidents then CIRegs 1 (concatMap idVt args)
-                                     else CIRegs 0 (PtrV : concatMap idVt args))
-                      , mempty)
-    setcc <- ifProfiling $
-               if et == CIThunk
-                 then enterCostCentreThunk
-                 else enterCostCentreFun cc
-    emitClosureInfo (ClosureInfo eid
-                                 regs
-                                 idt
-                                 (fixedLayout $ map (uTypeVt . idType) lids)
-                                 et
-                                 sr)
-    ccId <- costCentreStackLbl cc
-    emitStatic idt static ccId
-    return $ (eid ||= toJExpr (JFunc [] (ll <> upd <> setcc <> body)))
diff --git a/compiler/GHC/StgToJS/CoreUtils.hs b/compiler/GHC/StgToJS/CoreUtils.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/CoreUtils.hs
+++ /dev/null
@@ -1,282 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings    #-}
-
--- | Core utils
-module GHC.StgToJS.CoreUtils where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax
-
-import GHC.StgToJS.Types
-
-import GHC.Stg.Syntax
-
-import GHC.Tc.Utils.TcType
-
-import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim
-
-import GHC.Core.DataCon
-import GHC.Core.TyCo.Rep
-import GHC.Core.TyCon
-import GHC.Core.Type
-
-import GHC.Types.RepType
-import GHC.Types.Var
-import GHC.Types.Id
-
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import qualified Data.Bits as Bits
-
--- | can we unbox C x to x, only if x is represented as a Number
-isUnboxableCon :: DataCon -> Bool
-isUnboxableCon dc
-  | [t] <- dataConRepArgTys dc
-  , [t1] <- typeVt (scaledThing t)
-  = isUnboxable t1 &&
-    dataConTag dc == 1 &&
-    length (tyConDataCons $ dataConTyCon dc) == 1
-  | otherwise = False
-
--- | one-constructor types with one primitive field represented as a JS Number
--- can be unboxed
-isUnboxable :: VarType -> Bool
-isUnboxable DoubleV = True
-isUnboxable IntV    = True -- includes Char#
-isUnboxable _       = False
-
--- | Number of slots occupied by a PrimRep
-data SlotCount
-  = NoSlot
-  | OneSlot
-  | TwoSlots
-  deriving (Show,Eq,Ord)
-
-instance Outputable SlotCount where
-  ppr = text . show
-
--- | Return SlotCount as an Int
-slotCount :: SlotCount -> Int
-slotCount = \case
-  NoSlot   -> 0
-  OneSlot  -> 1
-  TwoSlots -> 2
-
-
--- | Number of slots occupied by a value with the given VarType
-varSize :: VarType -> Int
-varSize = slotCount . varSlotCount
-
-varSlotCount :: VarType -> SlotCount
-varSlotCount VoidV = NoSlot
-varSlotCount LongV = TwoSlots -- hi, low
-varSlotCount AddrV = TwoSlots -- obj/array, offset
-varSlotCount _     = OneSlot
-
-typeSize :: Type -> Int
-typeSize t = sum . map varSize . typeVt $ t
-
-isVoid :: VarType -> Bool
-isVoid VoidV = True
-isVoid _     = False
-
-isPtr :: VarType -> Bool
-isPtr PtrV = True
-isPtr _    = False
-
-isSingleVar :: VarType -> Bool
-isSingleVar v = varSlotCount v == OneSlot
-
-isMultiVar :: VarType -> Bool
-isMultiVar v = case varSlotCount v of
-  NoSlot   -> False
-  OneSlot  -> False
-  TwoSlots -> True
-
--- | can we pattern match on these values in a case?
-isMatchable :: [VarType] -> Bool
-isMatchable [DoubleV] = True
-isMatchable [IntV]    = True
-isMatchable _         = False
-
-tyConVt :: HasDebugCallStack => TyCon -> [VarType]
-tyConVt = typeVt . mkTyConTy
-
-idVt :: HasDebugCallStack => Id -> [VarType]
-idVt = typeVt . idType
-
-typeVt :: HasDebugCallStack => Type -> [VarType]
-typeVt t | isRuntimeRepKindedTy t = []
-typeVt t = map primRepVt (typePrimRep t)-- map uTypeVt (repTypeArgs t)
-
--- only use if you know it's not an unboxed tuple
-uTypeVt :: HasDebugCallStack => UnaryType -> VarType
-uTypeVt ut
-  | isRuntimeRepKindedTy ut = VoidV
---  | isRuntimeRepTy ut = VoidV
-  -- GHC panics on this otherwise
-  | Just (tc, ty_args) <- splitTyConApp_maybe ut
-  , length ty_args /= tyConArity tc = PtrV
-  | isPrimitiveType ut = (primTypeVt ut)
-  | otherwise          =
-    case typePrimRep' ut of
-      []   -> VoidV
-      [pt] -> primRepVt pt
-      _    -> pprPanic "uTypeVt: not unary" (ppr ut)
-
-primRepVt :: HasDebugCallStack => PrimRep -> VarType
-primRepVt VoidRep     = VoidV
-primRepVt LiftedRep   = PtrV -- fixme does ByteArray# ever map to this?
-primRepVt UnliftedRep = RtsObjV
-primRepVt IntRep      = IntV
-primRepVt Int8Rep     = IntV
-primRepVt Int16Rep    = IntV
-primRepVt Int32Rep    = IntV
-primRepVt WordRep     = IntV
-primRepVt Word8Rep    = IntV
-primRepVt Word16Rep   = IntV
-primRepVt Word32Rep   = IntV
-primRepVt Int64Rep    = LongV
-primRepVt Word64Rep   = LongV
-primRepVt AddrRep     = AddrV
-primRepVt FloatRep    = DoubleV
-primRepVt DoubleRep   = DoubleV
-primRepVt (VecRep{})  = error "uTypeVt: vector types are unsupported"
-
-typePrimRep' :: HasDebugCallStack => UnaryType -> [PrimRep]
-typePrimRep' ty = kindPrimRep' empty (typeKind ty)
-
--- | Find the primitive representation of a 'TyCon'. Defined here to
--- avoid module loops. Call this only on unlifted tycons.
-tyConPrimRep' :: HasDebugCallStack => TyCon -> [PrimRep]
-tyConPrimRep' tc = kindPrimRep' empty res_kind
-  where
-    res_kind = tyConResKind tc
-
--- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's
--- of values of types of this kind.
-kindPrimRep' :: HasDebugCallStack => SDoc -> Kind -> [PrimRep]
-kindPrimRep' doc ki
-  | Just ki' <- coreView ki
-  = kindPrimRep' doc ki'
-kindPrimRep' doc (TyConApp _typ [runtime_rep])
-  = -- ASSERT( typ `hasKey` tYPETyConKey )
-    runtimeRepPrimRep doc runtime_rep
-kindPrimRep' doc ki
-  = pprPanic "kindPrimRep'" (ppr ki $$ doc)
-
-primTypeVt :: HasDebugCallStack => Type -> VarType
-primTypeVt t = case tyConAppTyCon_maybe (unwrapType t) of
-  Nothing -> error "primTypeVt: not a TyCon"
-  Just tc
-    | tc == charPrimTyCon              -> IntV
-    | tc == intPrimTyCon               -> IntV
-    | tc == wordPrimTyCon              -> IntV
-    | tc == floatPrimTyCon             -> DoubleV
-    | tc == doublePrimTyCon            -> DoubleV
-    | tc == int8PrimTyCon              -> IntV
-    | tc == word8PrimTyCon             -> IntV
-    | tc == int16PrimTyCon             -> IntV
-    | tc == word16PrimTyCon            -> IntV
-    | tc == int32PrimTyCon             -> IntV
-    | tc == word32PrimTyCon            -> IntV
-    | tc == int64PrimTyCon             -> LongV
-    | tc == word64PrimTyCon            -> LongV
-    | tc == addrPrimTyCon              -> AddrV
-    | tc == stablePtrPrimTyCon         -> AddrV
-    | tc == stableNamePrimTyCon        -> RtsObjV
-    | tc == statePrimTyCon             -> VoidV
-    | tc == proxyPrimTyCon             -> VoidV
-    | tc == realWorldTyCon             -> VoidV
-    | tc == threadIdPrimTyCon          -> RtsObjV
-    | tc == weakPrimTyCon              -> RtsObjV
-    | tc == arrayPrimTyCon             -> ArrV
-    | tc == smallArrayPrimTyCon        -> ArrV
-    | tc == byteArrayPrimTyCon         -> ObjV -- can contain any JS reference, used for JSVal
-    | tc == mutableArrayPrimTyCon      -> ArrV
-    | tc == smallMutableArrayPrimTyCon -> ArrV
-    | tc == mutableByteArrayPrimTyCon  -> ObjV -- can contain any JS reference, used for JSVal
-    | tc == mutVarPrimTyCon            -> RtsObjV
-    | tc == mVarPrimTyCon              -> RtsObjV
-    | tc == tVarPrimTyCon              -> RtsObjV
-    | tc == bcoPrimTyCon               -> RtsObjV -- unsupported?
-    | tc == stackSnapshotPrimTyCon     -> RtsObjV
-    | tc == ioPortPrimTyCon            -> RtsObjV -- unsupported?
-    | tc == anyTyCon                   -> PtrV
-    | tc == compactPrimTyCon           -> ObjV -- unsupported?
-    | tc == eqPrimTyCon                -> VoidV -- coercion token?
-    | tc == eqReprPrimTyCon            -> VoidV -- role
-    | tc == unboxedUnitTyCon           -> VoidV -- Void#
-    | otherwise                        -> PtrV  -- anything else must be some boxed thing
-
-argVt :: StgArg -> VarType
-argVt a = uTypeVt . stgArgType $ a
-
-dataConType :: DataCon -> Type
-dataConType dc = idType (dataConWrapId dc)
-
-isBoolDataCon :: DataCon -> Bool
-isBoolDataCon dc = isBoolTy (dataConType dc)
-
--- standard fixed layout: payload types
--- payload starts at .d1 for heap objects, entry closest to Sp for stack frames
-fixedLayout :: [VarType] -> CILayout
-fixedLayout vts = CILayoutFixed (sum (map varSize vts)) vts
-
--- 2-var values might have been moved around separately, use DoubleV as substitute
--- ObjV is 1 var, so this is no problem for implicit metadata
-stackSlotType :: Id -> VarType
-stackSlotType i
-  | OneSlot <- varSlotCount otype = otype
-  | otherwise                     = DoubleV
-  where otype = uTypeVt (idType i)
-
-idPrimReps :: Id -> [PrimRep]
-idPrimReps = typePrimReps . idType
-
-typePrimReps :: Type -> [PrimRep]
-typePrimReps = typePrimRep . unwrapType
-
-primRepSize :: PrimRep -> SlotCount
-primRepSize p = varSlotCount (primRepVt p)
-
--- | Associate the given values to each RrimRep in the given order, taking into
--- account the number of slots per PrimRep
-assocPrimReps :: Outputable a => [PrimRep] -> [a] -> [(PrimRep, [a])]
-assocPrimReps []     _  = []
-assocPrimReps (r:rs) vs = case (primRepSize r,vs) of
-  (NoSlot,   xs)     -> (r,[])    : assocPrimReps rs xs
-  (OneSlot,  x:xs)   -> (r,[x])   : assocPrimReps rs xs
-  (TwoSlots, x:y:xs) -> (r,[x,y]) : assocPrimReps rs xs
-  err                -> pprPanic "assocPrimReps" (ppr err)
-
--- | Associate the given values to the Id's PrimReps, taking into account the
--- number of slots per PrimRep
-assocIdPrimReps :: Outputable a => Id -> [a] -> [(PrimRep, [a])]
-assocIdPrimReps i = assocPrimReps (idPrimReps i)
-
--- | Associate the given JExpr to the Id's PrimReps, taking into account the
--- number of slots per PrimRep
-assocIdExprs :: Id -> [JExpr] -> [TypedExpr]
-assocIdExprs i es = fmap (uncurry TypedExpr) (assocIdPrimReps i es)
-
--- | Return False only if we are *sure* it's a data type
--- Look through newtypes etc as much as possible
-might_be_a_function :: HasDebugCallStack => Type -> Bool
-might_be_a_function ty
-  | [LiftedRep] <- typePrimRep ty
-  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)
-  , isDataTyCon tc
-  = False
-  | otherwise
-  = True
-
-mkArityTag :: Int -> Int -> Int
-mkArityTag arity registers = arity Bits..|. (registers `Bits.shiftL` 8)
-
-toTypeList :: [VarType] -> [Int]
-toTypeList = concatMap (\x -> replicate (varSize x) (fromEnum x))
diff --git a/compiler/GHC/StgToJS/DataCon.hs b/compiler/GHC/StgToJS/DataCon.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/DataCon.hs
+++ /dev/null
@@ -1,124 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.StgToJS.DataCon
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
---  Code generation of data constructors
------------------------------------------------------------------------------
-
-module GHC.StgToJS.DataCon
-  ( genCon
-  , allocCon
-  , allocUnboxedCon
-  , allocDynamicE
-  , allocDynamic
-  )
-where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax
-import GHC.JS.Make
-
-import GHC.StgToJS.Closure
-import GHC.StgToJS.ExprCtx
-import GHC.StgToJS.Types
-import GHC.StgToJS.Monad
-import GHC.StgToJS.CoreUtils
-import GHC.StgToJS.Profiling
-import GHC.StgToJS.Utils
-import GHC.StgToJS.Ids
-
-import GHC.Core.DataCon
-
-import GHC.Types.CostCentre
-import GHC.Types.Unique.Map
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Data.FastString
-
-import Data.Maybe
-
--- | Generate a data constructor. Special handling for unboxed tuples
-genCon :: ExprCtx -> DataCon -> [JExpr] -> G JStat
-genCon ctx con args
-  | isUnboxedTupleDataCon con
-  = return $ assignToExprCtx ctx args
-
-  | [ValExpr (JVar ctxi)] <- concatMap typex_expr (ctxTarget ctx)
-  = allocCon ctxi con currentCCS args
-
-  | xs <- concatMap typex_expr (ctxTarget ctx)
-  = pprPanic "genCon: unhandled DataCon" (ppr (con, args, xs))
-
--- | Allocate a data constructor. Allocate in this context means bind the data
--- constructor to 'to'
-allocCon :: Ident -> DataCon -> CostCentreStack -> [JExpr] -> G JStat
-allocCon to con cc xs
-  | isBoolDataCon con || isUnboxableCon con =
-      return (toJExpr to |= allocUnboxedCon con xs)
-{-  | null xs = do
-      i <- varForId (dataConWorkId con)
-      return (assignj to i) -}
-  | otherwise = do
-      e <- varForDataConWorker con
-      cs <- getSettings
-      prof <- profiling
-      ccsJ <- if prof then ccsVarJ cc else return Nothing
-      return $ allocDynamic cs False to e xs ccsJ
-
--- | Allocate an unboxed data constructor. If we have a bool we calculate the
--- right value. If not then we expect a singleton list and unbox by converting
--- ''C x' to 'x'. NB. This function may panic.
-allocUnboxedCon :: DataCon -> [JExpr] -> JExpr
-allocUnboxedCon con = \case
-  []
-    | isBoolDataCon con && dataConTag con == 1 -> false_
-    | isBoolDataCon con && dataConTag con == 2 -> true_
-  [x]
-    | isUnboxableCon con -> x
-  xs -> pprPanic "allocUnboxedCon: not an unboxed constructor" (ppr (con,xs))
-
--- | Allocate an entry function. See 'GHC.StgToJS.hs' for the object layout.
-allocDynamicE :: Bool          -- ^ csInlineAlloc from StgToJSConfig
-              -> JExpr
-              -> [JExpr]
-              -> Maybe JExpr
-              -> JExpr
-allocDynamicE  inline_alloc entry free cc
-  | inline_alloc || length free > 24 = newClosure $ Closure
-      { clEntry  = entry
-      , clField1 = fillObj1
-      , clField2 = fillObj2
-      , clMeta   = ValExpr (JInt 0)
-      , clCC     = cc
-      }
-  | otherwise = ApplExpr allocFun (toJExpr entry : free ++ maybeToList cc)
-  where
-    allocFun = allocClsA (length free)
-    (fillObj1,fillObj2)
-       = case free of
-                []  -> (null_, null_)
-                [x] -> (x,null_)
-                [x,y] -> (x,y)
-                (x:xs) -> (x,toJExpr (JHash $ listToUniqMap (zip dataFields xs)))
-    dataFields = map (mkFastString . ('d':) . show) [(1::Int)..]
-
--- | Allocate a dynamic object
-allocDynamic :: StgToJSConfig -> Bool -> Ident -> JExpr -> [JExpr] -> Maybe JExpr -> JStat
-allocDynamic s need_decl to entry free cc
-  | need_decl = DeclStat to (Just value)
-  | otherwise = toJExpr to |= value
-    where
-      value = allocDynamicE (csInlineAlloc s) entry free cc
diff --git a/compiler/GHC/StgToJS/Deps.hs b/compiler/GHC/StgToJS/Deps.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Deps.hs
+++ /dev/null
@@ -1,191 +0,0 @@
-{-# LANGUAGE TupleSections #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.StgToJS.Deps
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
--- Module to calculate the transitive dependencies of a module
------------------------------------------------------------------------------
-
-module GHC.StgToJS.Deps
-  ( genDependencyData
-  )
-where
-
-import GHC.Prelude
-
-import GHC.StgToJS.Object as Object
-import GHC.StgToJS.Types
-import GHC.StgToJS.Ids
-
-import GHC.JS.Syntax
-
-import GHC.Types.Id
-import GHC.Types.Unique
-import GHC.Types.Unique.FM
-import GHC.Types.Name
-
-import GHC.Unit.Module
-
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import GHC.Data.FastString
-
-import Data.Map (Map)
-import qualified Data.Map as M
-import qualified Data.Set as S
-import qualified Data.IntSet as IS
-import qualified Data.IntMap as IM
-import Data.IntMap (IntMap)
-import Data.Array
-import Data.Either
-import Control.Monad
-
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.State
-
-data DependencyDataCache = DDC
-  { ddcModule :: !(IntMap Unit)               -- ^ Unique Module -> Unit
-  , ddcId     :: !(IntMap Object.ExportedFun) -- ^ Unique Id     -> Object.ExportedFun (only to other modules)
-  , ddcOther  :: !(Map OtherSymb Object.ExportedFun)
-  }
-
--- | Generate module dependency data
---
--- Generate the object's dependency data, taking care that package and module names
--- are only stored once
-genDependencyData
-  :: HasDebugCallStack
-  => Module
-  -> [LinkableUnit]
-  -> G Object.Deps
-genDependencyData mod units = do
-    -- [(blockindex, blockdeps, required, exported)]
-    ds <- evalStateT (mapM (uncurry oneDep) blocks)
-                     (DDC IM.empty IM.empty M.empty)
-    return $ Object.Deps
-      { depsModule          = mod
-      , depsRequired        = IS.fromList [ n | (n, _, True, _) <- ds ]
-      , depsHaskellExported = M.fromList $ (\(n,_,_,es) -> map (,n) es) =<< ds
-      , depsBlocks          = listArray (0, length blocks-1) (map (\(_,deps,_,_) -> deps) ds)
-      }
-  where
-      -- Id -> Block
-      unitIdExports :: UniqFM Id Int
-      unitIdExports = listToUFM $
-                      concatMap (\(u,n) -> map (,n) (luIdExports u)) blocks
-
-      -- OtherSymb -> Block
-      unitOtherExports :: Map OtherSymb Int
-      unitOtherExports = M.fromList $
-                         concatMap (\(u,n) -> map (,n)
-                                                  (map (OtherSymb mod)
-                                                       (luOtherExports u)))
-                                   blocks
-
-      blocks :: [(LinkableUnit, Int)]
-      blocks = zip units [0..]
-
-      -- generate the list of exports and set of dependencies for one unit
-      oneDep :: LinkableUnit
-             -> Int
-             -> StateT DependencyDataCache G (Int, Object.BlockDeps, Bool, [Object.ExportedFun])
-      oneDep (LinkableUnit _ idExports otherExports idDeps pseudoIdDeps otherDeps req _frefs) n = do
-        (edi, bdi) <- partitionEithers <$> mapM (lookupIdFun n) idDeps
-        (edo, bdo) <- partitionEithers <$> mapM lookupOtherFun otherDeps
-        (edp, bdp) <- partitionEithers <$> mapM (lookupPseudoIdFun n) pseudoIdDeps
-        expi <- mapM lookupExportedId (filter isExportedId idExports)
-        expo <- mapM lookupExportedOther otherExports
-        -- fixme thin deps, remove all transitive dependencies!
-        let bdeps = Object.BlockDeps
-                      (IS.toList . IS.fromList . filter (/=n) $ bdi++bdo++bdp)
-                      (S.toList . S.fromList $ edi++edo++edp)
-        return (n, bdeps, req, expi++expo)
-
-      idModule :: Id -> Maybe Module
-      idModule i = nameModule_maybe (getName i) >>= \m ->
-                   guard (m /= mod) >> return m
-
-      lookupPseudoIdFun :: Int -> Unique
-                        -> StateT DependencyDataCache G (Either Object.ExportedFun Int)
-      lookupPseudoIdFun _n u =
-        case lookupUFM_Directly unitIdExports u of
-          Just k -> return (Right k)
-          _      -> panic "lookupPseudoIdFun"
-
-      -- get the function for an Id from the cache, add it if necessary
-      -- result: Left Object.ExportedFun   if function refers to another module
-      --         Right blockNumber if function refers to current module
-      --
-      --         assumes function is internal to the current block if it's
-      --         from teh current module and not in the unitIdExports map.
-      lookupIdFun :: Int -> Id
-                  -> StateT DependencyDataCache G (Either Object.ExportedFun Int)
-      lookupIdFun n i = case lookupUFM unitIdExports i of
-        Just k  -> return (Right k)
-        Nothing -> case idModule i of
-          Nothing -> return (Right n)
-          Just m ->
-            let k = getKey . getUnique $ i
-                addEntry :: StateT DependencyDataCache G Object.ExportedFun
-                addEntry = do
-                  (TxtI idTxt) <- lift (identForId i)
-                  lookupExternalFun (Just k) (OtherSymb m idTxt)
-            in  if m == mod
-                   then pprPanic "local id not found" (ppr m)
-                    else Left <$> do
-                            mr <- gets (IM.lookup k . ddcId)
-                            maybe addEntry return mr
-
-      -- get the function for an OtherSymb from the cache, add it if necessary
-      lookupOtherFun :: OtherSymb
-                     -> StateT DependencyDataCache G (Either Object.ExportedFun Int)
-      lookupOtherFun od@(OtherSymb m idTxt) =
-        case M.lookup od unitOtherExports of
-          Just n  -> return (Right n)
-          Nothing | m == mod -> panic ("genDependencyData.lookupOtherFun: unknown local other id: " ++ unpackFS idTxt)
-          Nothing ->  Left <$> (maybe (lookupExternalFun Nothing od) return =<<
-                        gets (M.lookup od . ddcOther))
-
-      lookupExportedId :: Id -> StateT DependencyDataCache G Object.ExportedFun
-      lookupExportedId i = do
-        (TxtI idTxt) <- lift (identForId i)
-        lookupExternalFun (Just . getKey . getUnique $ i) (OtherSymb mod idTxt)
-
-      lookupExportedOther :: FastString -> StateT DependencyDataCache G Object.ExportedFun
-      lookupExportedOther = lookupExternalFun Nothing . OtherSymb mod
-
-      -- lookup a dependency to another module, add to the id cache if there's
-      -- an id key, otherwise add to other cache
-      lookupExternalFun :: Maybe Int
-                        -> OtherSymb -> StateT DependencyDataCache G Object.ExportedFun
-      lookupExternalFun mbIdKey od@(OtherSymb m idTxt) = do
-        let mk        = getKey . getUnique $ m
-            mpk       = moduleUnit m
-            exp_fun   = Object.ExportedFun m (LexicalFastString idTxt)
-            addCache  = do
-              ms <- gets ddcModule
-              let !cache' = IM.insert mk mpk ms
-              modify (\s -> s { ddcModule = cache'})
-              pure exp_fun
-        f <- do
-          mbm <- gets (IM.member mk . ddcModule)
-          case mbm of
-            False -> addCache
-            True  -> pure exp_fun
-
-        case mbIdKey of
-          Nothing -> modify (\s -> s { ddcOther = M.insert od f (ddcOther s) })
-          Just k  -> modify (\s -> s { ddcId    = IM.insert k f (ddcId s) })
-
-        return f
diff --git a/compiler/GHC/StgToJS/Expr.hs b/compiler/GHC/StgToJS/Expr.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Expr.hs
+++ /dev/null
@@ -1,1045 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveFunctor #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.StgToJS.Expr
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
---  Code generation of Expressions
------------------------------------------------------------------------------
-
-module GHC.StgToJS.Expr
-  ( genExpr
-  , genEntryType
-  , loadLiveFun
-  , genStaticRefsRhs
-  , genStaticRefs
-  , genBody
-  )
-where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax
-import GHC.JS.Make
-
-import GHC.StgToJS.Apply
-import GHC.StgToJS.Arg
-import GHC.StgToJS.ExprCtx
-import GHC.StgToJS.FFI
-import GHC.StgToJS.Heap
-import GHC.StgToJS.Monad
-import GHC.StgToJS.DataCon
-import GHC.StgToJS.Types
-import GHC.StgToJS.Literal
-import GHC.StgToJS.Prim
-import GHC.StgToJS.Profiling
-import GHC.StgToJS.Regs
-import GHC.StgToJS.StgUtils
-import GHC.StgToJS.CoreUtils
-import GHC.StgToJS.Utils
-import GHC.StgToJS.Stack
-import GHC.StgToJS.Ids
-
-import GHC.Types.Basic
-import GHC.Types.CostCentre
-import GHC.Types.Tickish
-import GHC.Types.Var.Set
-import GHC.Types.Id
-import GHC.Types.Unique.FM
-import GHC.Types.RepType
-
-import GHC.Stg.Syntax
-import GHC.Stg.Utils
-
-import GHC.Builtin.PrimOps
-
-import GHC.Core
-import GHC.Core.TyCon
-import GHC.Core.DataCon
-import GHC.Core.Opt.Arity (isOneShotBndr)
-import GHC.Core.Type hiding (typeSize)
-
-import GHC.Utils.Misc
-import GHC.Utils.Monad
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext)
-import qualified Control.Monad.Trans.State.Strict as State
-import GHC.Data.FastString
-import qualified GHC.Data.List.SetOps as ListSetOps
-
-import Data.Monoid
-import Data.Maybe
-import Data.Function
-import Data.Either
-import qualified Data.List as L
-import qualified Data.Set as S
-import qualified Data.Map as M
-import Control.Monad
-import Control.Arrow ((&&&))
-
--- | Evaluate an expression in the given expression context (continuation)
-genExpr :: HasDebugCallStack => ExprCtx -> CgStgExpr -> G (JStat, ExprResult)
-genExpr ctx stg = case stg of
-  StgApp f args -> genApp ctx f args
-  StgLit l      -> do
-    ls <- genLit l
-    let r = assignToExprCtx ctx ls
-    pure (r,ExprInline Nothing)
-  StgConApp con _n args _ -> do
-    as <- concatMapM genArg args
-    c <- genCon ctx con as
-    return (c, ExprInline (Just as))
-  StgOpApp (StgFCallOp f _) args t
-    -> genForeignCall ctx f t (concatMap typex_expr $ ctxTarget ctx) args
-  StgOpApp (StgPrimOp op) args t
-    -> genPrimOp ctx op args t
-  StgOpApp (StgPrimCallOp c) args t
-    -> genPrimCall ctx c args t
-  StgCase e b at alts
-    -> genCase ctx b e at alts (liveVars $ stgExprLive False stg)
-  StgLet _ b e -> do
-    (b',ctx') <- genBind ctx b
-    (s,r)     <- genExpr ctx' e
-    return (b' <> s, r)
-  StgLetNoEscape _ b e -> do
-    (b', ctx') <- genBindLne ctx b
-    (s, r)     <- genExpr ctx' e
-    return (b' <> s, r)
-  StgTick (ProfNote cc count scope) e -> do
-    setSCCstats <- ifProfilingM $ setCC cc count scope
-    (stats, result) <- genExpr ctx e
-    return (setSCCstats <> stats, result)
-  StgTick (SourceNote span _sname) e
-    -> genExpr (ctxSetSrcSpan span ctx) e
-  StgTick _m e
-    -> genExpr ctx e
-
--- | regular let binding: allocate heap object
-genBind :: HasDebugCallStack
-        => ExprCtx
-        -> CgStgBinding
-        -> G (JStat, ExprCtx)
-genBind ctx bndr =
-  case bndr of
-    StgNonRec b r -> do
-       j <- assign b r >>= \case
-         Just ja -> return ja
-         Nothing -> allocCls Nothing [(b,r)]
-       return (j, addEvalRhs ctx [(b,r)])
-    StgRec bs     -> do
-       jas <- mapM (uncurry assign) bs -- fixme these might depend on parts initialized by allocCls
-       let m = if null jas then Nothing else Just (mconcat $ catMaybes jas)
-       j <- allocCls m . map snd . filter (isNothing . fst) $ zip jas bs
-       return (j, addEvalRhs ctx bs)
-   where
-     ctx' = ctxClearLneFrame ctx
-
-     assign :: Id -> CgStgRhs -> G (Maybe JStat)
-     assign b (StgRhsClosure _ _ccs {-[the_fv]-} _upd [] expr)
-       | let strip = snd . stripStgTicksTop (not . tickishIsCode)
-       , StgCase (StgApp scrutinee []) _ (AlgAlt _) [GenStgAlt (DataAlt _) params sel_expr] <- strip expr
-       , StgApp selectee [] <- strip sel_expr
-       , let params_w_offsets = zip params (L.scanl' (+) 1 $ map (typeSize . idType) params)
-       , let total_size = sum (map (typeSize . idType) params)
-       -- , the_fv == scrutinee -- fixme check
-       , Just the_offset <- ListSetOps.assocMaybe params_w_offsets selectee
-       , the_offset <= 16 -- fixme make this some configurable constant
-       = do
-           let the_fv = scrutinee -- error "the_fv" -- fixme
-           let sel_tag | the_offset == 2 = if total_size == 2 then "2a"
-                                                              else "2b"
-                       | otherwise       = show the_offset
-           tgts <- identsForId b
-           the_fvjs <- varsForId the_fv
-           case (tgts, the_fvjs) of
-             ([tgt], [the_fvj]) -> return $ Just
-               (tgt ||= ApplExpr (var ("h$c_sel_" <> mkFastString sel_tag)) [the_fvj])
-             _ -> panic "genBind.assign: invalid size"
-     assign b (StgRhsClosure _ext _ccs _upd [] expr)
-       | snd (isInlineExpr (ctxEvaluatedIds ctx) expr) = do
-           d   <- declVarsForId b
-           tgt <- varsForId b
-           let ctx' = ctx { ctxTarget = assocIdExprs b tgt }
-           (j, _) <- genExpr ctx' expr
-           return (Just (d <> j))
-     assign _b StgRhsCon{} = return Nothing
-     assign  b r           = genEntry ctx' b r >> return Nothing
-
-     addEvalRhs c [] = c
-     addEvalRhs c ((b,r):xs)
-       | StgRhsCon{} <- r                       = addEvalRhs (ctxAssertEvaluated b c) xs
-       | (StgRhsClosure _ _ ReEntrant _ _) <- r = addEvalRhs (ctxAssertEvaluated b c) xs
-       | otherwise                              = addEvalRhs c xs
-
-genBindLne :: HasDebugCallStack
-           => ExprCtx
-           -> CgStgBinding
-           -> G (JStat, ExprCtx)
-genBindLne ctx bndr = do
-  -- compute live variables and the offsets where they will be stored in the
-  -- stack
-  vis  <- map (\(x,y,_) -> (x,y)) <$>
-            optimizeFree oldFrameSize (newLvs++map fst updBinds)
-  -- initialize updatable bindings to null_
-  declUpds <- mconcat <$> mapM (fmap (||= null_) . identForId . fst) updBinds
-  -- update expression context to include the updated LNE frame
-  let ctx' = ctxUpdateLneFrame vis bound ctx
-  mapM_ (uncurry $ genEntryLne ctx') binds
-  return (declUpds, ctx')
-  where
-    oldFrameSize = ctxLneFrameSize ctx
-    isOldLv i    = ctxIsLneBinding ctx i ||
-                   ctxIsLneLiveVar ctx i
-    live         = liveVars $ mkDVarSet $ stgLneLive' bndr
-    newLvs       = filter (not . isOldLv) (dVarSetElems live)
-    binds = case bndr of
-              StgNonRec b e -> [(b,e)]
-              StgRec    bs  -> bs
-    bound = map fst binds
-    (updBinds, _nonUpdBinds) = L.partition (isUpdatableRhs . snd) binds
-
--- | Generate let-no-escape entry
---
--- Let-no-escape entries live on the stack. There is no heap object associated with them.
---
--- A let-no-escape entry is called like a normal stack frame, although as an optimization,
--- `Stack`[`Sp`] is not set when making the call. This is done later if the
--- thread needs to be suspended.
---
--- Updatable let-no-escape binders have one 'private' slot in the stack frame. This slot
--- is initially set to null, changed to h$blackhole when the thunk is being evaluated.
---
-genEntryLne :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G ()
-genEntryLne ctx i rhs@(StgRhsClosure _ext _cc update args body) =
-  resetSlots $ do
-  let payloadSize = ctxLneFrameSize ctx
-      vars        = ctxLneFrameVars ctx
-      myOffset    =
-        maybe (panic "genEntryLne: updatable binder not found in let-no-escape frame")
-              ((payloadSize-) . fst)
-              (L.find ((==i) . fst . snd) (zip [0..] vars))
-      bh | isUpdatable update =
-             jVar (\x -> mconcat
-              [ x |= ApplExpr (var "h$bh_lne") [Sub sp (toJExpr myOffset), toJExpr (payloadSize+1)]
-              , IfStat x (ReturnStat x) mempty
-              ])
-         | otherwise = mempty
-  lvs  <- popLneFrame True payloadSize ctx
-  body <- genBody ctx i R1 args body
-  ei@(TxtI eii) <- identForEntryId i
-  sr   <- genStaticRefsRhs rhs
-  let f = JFunc [] (bh <> lvs <> body)
-  emitClosureInfo $
-    ClosureInfo ei
-                (CIRegs 0 $ concatMap idVt args)
-                (eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i)))
-                (fixedLayout . reverse $
-                    map (stackSlotType . fst) (ctxLneFrameVars ctx))
-                CIStackFrame
-                sr
-  emitToplevel (ei ||= toJExpr f)
-genEntryLne ctx i (StgRhsCon cc con _mu _ticks args) = resetSlots $ do
-  let payloadSize = ctxLneFrameSize ctx
-  ei@(TxtI _eii) <- identForEntryId i
-  -- di <- varForDataConWorker con
-  ii <- freshIdent
-  p  <- popLneFrame True payloadSize ctx
-  args' <- concatMapM genArg args
-  ac    <- allocCon ii con cc args'
-  emitToplevel (ei ||= toJExpr (JFunc []
-    (mconcat [decl ii, p, ac, r1 |= toJExpr ii, returnStack])))
-
--- | Generate the entry function for a local closure
-genEntry :: HasDebugCallStack => ExprCtx -> Id -> CgStgRhs -> G ()
-genEntry _ _i StgRhsCon {} = return ()
-genEntry ctx i rhs@(StgRhsClosure _ext cc {-_bi live-} upd_flag args body) = resetSlots $ do
-  let live = stgLneLiveExpr rhs -- error "fixme" -- probably find live vars in body
-  ll    <- loadLiveFun live
-  llv   <- verifyRuntimeReps live
-  upd   <- genUpdFrame upd_flag i
-  body  <- genBody entryCtx i R2 args body
-  ei@(TxtI eii) <- identForEntryId i
-  et    <- genEntryType args
-  setcc <- ifProfiling $
-             if et == CIThunk
-               then enterCostCentreThunk
-               else enterCostCentreFun cc
-  sr <- genStaticRefsRhs rhs
-  emitClosureInfo $ ClosureInfo ei
-                                (CIRegs 0 $ PtrV : concatMap idVt args)
-                                (eii <> ", " <> mkFastString (renderWithContext defaultSDocContext (ppr i)))
-                                (fixedLayout $ map (uTypeVt . idType) live)
-                                et
-                                sr
-  emitToplevel (ei ||= toJExpr (JFunc [] (mconcat [ll, llv, upd, setcc, body])))
-  where
-    entryCtx = ctxSetTarget [] (ctxClearLneFrame ctx)
-
--- | Generate the entry function types for identifiers. Note that this only
--- returns either 'CIThunk' or 'CIFun'. Everything else (PAP Blackhole etc.) is
--- filtered as not a RuntimeRepKinded type.
-genEntryType :: HasDebugCallStack => [Id] -> G CIType
-genEntryType []   = return CIThunk
-genEntryType args0 = do
-  args' <- mapM genIdArg args
-  return $ CIFun (length args) (length $ concat args')
-  where
-    args = filter (not . isRuntimeRepKindedTy . idType) args0
-
--- | Generate the body of an object
-genBody :: HasDebugCallStack
-         => ExprCtx
-         -> Id
-         -> StgReg
-         -> [Id]
-         -> CgStgExpr
-         -> G JStat
-genBody ctx i startReg args e = do
-  -- load arguments into local variables
-  la <- do
-    args' <- concatMapM genIdArgI args
-    return (declAssignAll args' (fmap toJExpr [startReg..]))
-
-  -- assert that arguments have valid runtime reps
-  lav <- verifyRuntimeReps args
-
-  -- compute PrimReps and their number of slots required to return the result of
-  -- i applied to args.
-  let res_vars = resultSize args i
-
-  -- compute typed expressions for each slot and assign registers
-  let go_var regs = \case
-        []              -> []
-        ((rep,size):rs) ->
-          let !(regs0,regs1) = splitAt size regs
-              !ts = go_var regs1 rs
-          in TypedExpr rep regs0 : ts
-
-  let tgt  = go_var jsRegsFromR1 res_vars
-  let !ctx' = ctx { ctxTarget = tgt }
-
-  -- generate code for the expression
-  (e, _r) <- genExpr ctx' e
-
-  return $ la <> lav <> e <> returnStack
-
--- | Find the result type after applying the function to the arguments
---
--- It's trickier than it looks because:
---
--- 1. we don't have the Arity of the Id. The following functions return
--- different values in some cases:
---    - idArity
---    - typeArity . idType
---    - idFunRepArity
---    - typeArity . unwrapType . idType
--- Moreover the number of args may be different than all of these arities
---
--- 2. sometimes the type is Any, perhaps after some unwrapping. For example
--- HappyAbsSyn is a newtype around HappyAny which is Any or (forall a. a).
---
--- Se we're left to use the applied arguments to peel the type (unwrapped) one
--- arg at a time. But passed args are args after unarisation so we need to
--- unarise every argument type that we peel (using typePrimRepArgs) to get the
--- number of passed args consumed by each type arg.
---
--- In case of failure to determine the type, we default to LiftedRep as it's
--- probably what it is.
---
-resultSize :: HasDebugCallStack => [Id] -> Id -> [(PrimRep, Int)]
-resultSize args i = result
-  where
-    result       = result_reps `zip` result_slots
-    result_slots = fmap (slotCount . primRepSize) result_reps
-    result_reps  = trim_args (unwrapType (idType i)) (length args)
-
-    trim_args t 0 = typePrimRep t
-    trim_args t n
-      | Just (_af, _mult, arg, res) <- splitFunTy_maybe t
-      , nargs <- length (typePrimRepArgs arg)
-      , assert (n >= nargs) True
-      = trim_args (unwrapType res) (n - nargs)
-      | otherwise
-      = pprTrace "result_type: not a function type, assume LiftedRep" (ppr t)
-          [LiftedRep]
-
--- | Ensure that the set of identifiers has valid 'RuntimeRep's. This function
--- returns a no-op when 'csRuntimeAssert' in 'StgToJSConfig' is False.
-verifyRuntimeReps :: HasDebugCallStack => [Id] -> G JStat
-verifyRuntimeReps xs = do
-  runtime_assert <- csRuntimeAssert <$> getSettings
-  if not runtime_assert
-    then pure mempty
-    else mconcat <$> mapM verifyRuntimeRep xs
-  where
-    verifyRuntimeRep i = do
-      i' <- varsForId i
-      pure $ go i' (idVt i)
-    go js         (VoidV:vs) = go js vs
-    go (j1:j2:js) (LongV:vs) = v "h$verify_rep_long" [j1,j2] <> go js vs
-    go (j1:j2:js) (AddrV:vs) = v "h$verify_rep_addr" [j1,j2] <> go js vs
-    go (j:js)     (v:vs)     = ver j v                       <> go js vs
-    go []         []         = mempty
-    go _          _          = pprPanic "verifyRuntimeReps: inconsistent sizes" (ppr xs)
-    ver j PtrV    = v "h$verify_rep_heapobj" [j]
-    ver j IntV    = v "h$verify_rep_int"     [j]
-    ver j RtsObjV = v "h$verify_rep_rtsobj"  [j]
-    ver j DoubleV = v "h$verify_rep_double"  [j]
-    ver j ArrV    = v "h$verify_rep_arr"     [j]
-    ver _ _       = mempty
-    v f as = ApplStat (var f) as
-
--- | Given a set of 'Id's, bind each 'Id' to the appropriate data fields in N
--- registers. This assumes these data fields have already been populated in the
--- registers. For the empty, singleton, and binary case use register 1, for any
--- more use as many registers as necessary.
-loadLiveFun :: [Id] -> G JStat
-loadLiveFun l = do
-   l' <- concat <$> mapM identsForId l
-   case l' of
-     []  -> return mempty
-     -- set the ident to d1 field of register 1
-     [v] -> return (v ||= r1 .^ closureField1_)
-     -- set the idents to d1 and d2 fields of register 1
-     [v1,v2] -> return $ mconcat
-                        [ v1 ||= r1 .^ closureField1_
-                        , v2 ||= r1 .^ closureField2_
-                        ]
-     -- and so on
-     (v:vs)  -> do
-       d <- freshIdent
-       let l'' = mconcat . zipWith (loadLiveVar $ toJExpr d) [(1::Int)..] $ vs
-       return $ mconcat
-               [ v ||= r1 .^ closureField1_
-               , d ||= r1 .^ closureField2_
-               , l''
-               ]
-  where
-        loadLiveVar d n v = let ident = TxtI (dataFieldName n)
-                            in  v ||= SelExpr d ident
-
--- | Pop a let-no-escape frame off the stack
-popLneFrame :: Bool -> Int -> ExprCtx -> G JStat
-popLneFrame inEntry size ctx = do
-  -- calculate the new stack size
-  let ctx' = ctxLneShrinkStack ctx size
-
-  let gen_id_slot (i,n) = do
-        ids <- identsForId i
-        let !id_n = ids !! (n-1)
-        pure (id_n, SlotId i n)
-
-  is <- mapM gen_id_slot (ctxLneFrameVars ctx')
-
-  let skip = if inEntry then 1 else 0 -- pop the frame header
-  popSkipI skip is
-
--- | Generate an updated given an 'Id'
-genUpdFrame :: UpdateFlag -> Id -> G JStat
-genUpdFrame u i
-  | isReEntrant u   = pure mempty
-  | isOneShotBndr i = maybeBh
-  | isUpdatable u   = updateThunk
-  | otherwise       = maybeBh
-  where
-    isReEntrant ReEntrant = True
-    isReEntrant _         = False
-    maybeBh = do
-      settings <- getSettings
-      assertRtsStat (return $ bhSingleEntry settings)
-
--- | Blackhole single entry
---
--- Overwrite a single entry object with a special thunk that behaves like a
--- black hole (throws a JS exception when entered) but pretends to be a thunk.
--- Useful for making sure that the object is not accidentally entered multiple
--- times
---
-bhSingleEntry :: StgToJSConfig -> JStat
-bhSingleEntry _settings = mconcat
-  [ r1 .^ closureEntry_  |= var "h$blackholeTrap"
-  , r1 .^ closureField1_ |= undefined_
-  , r1 .^ closureField2_ |= undefined_
-  ]
-
-genStaticRefsRhs :: CgStgRhs -> G CIStatic
-genStaticRefsRhs lv = genStaticRefs (stgRhsLive lv)
-
--- fixme, update to new way to compute static refs dynamically
-genStaticRefs :: LiveVars -> G CIStatic
-genStaticRefs lv
-  | isEmptyDVarSet sv = return (CIStaticRefs [])
-  | otherwise         = do
-      unfloated <- State.gets gsUnfloated
-      let xs = filter (\x -> not (elemUFM x unfloated ||
-                                  typeLevity_maybe (idType x) == Just Unlifted))
-                      (dVarSetElems sv)
-      CIStaticRefs . catMaybes <$> mapM getStaticRef xs
-  where
-    sv = liveStatic lv
-
-    getStaticRef :: Id -> G (Maybe FastString)
-    getStaticRef = fmap (fmap itxt . listToMaybe) . identsForId
-
--- | Reorder the things we need to push to reuse existing stack values as much
--- as possible True if already on the stack at that location
-optimizeFree
-  :: HasDebugCallStack
-  => Int
-  -> [Id]
-  -> G [(Id,Int,Bool)] -- ^ A list of stack slots.
-                       -- -- Id: stored on the slot
-                       -- -- Int: the part of the value that is stored
-                       -- -- Bool: True when the slot already contains a value
-optimizeFree offset ids = do
-  -- this line goes wrong                               vvvvvvv
-  let -- ids' = concat $ map (\i -> map (i,) [1..varSize . uTypeVt . idType $ i]) ids
-      idSize :: Id -> Int
-      idSize i = sum $ map varSize (typeVt . idType $ i)
-      ids' = concatMap (\i -> map (i,) [1..idSize i]) ids
-      -- 1..varSize] . uTypeVt . idType $ i]) (typeVt ids)
-      l    = length ids'
-  slots <- drop offset . take l . (++repeat SlotUnknown) <$> getSlots
-  let slm                = M.fromList (zip slots [0..])
-      (remaining, fixed) = partitionEithers $
-         map (\inp@(i,n) -> maybe (Left inp) (\j -> Right (i,n,j,True))
-            (M.lookup (SlotId i n) slm)) ids'
-      takenSlots         = S.fromList (fmap (\(_,_,x,_) -> x) fixed)
-      freeSlots          = filter (`S.notMember` takenSlots) [0..l-1]
-      remaining'         = zipWith (\(i,n) j -> (i,n,j,False)) remaining freeSlots
-      allSlots           = L.sortBy (compare `on` \(_,_,x,_) -> x) (fixed ++ remaining')
-  return $ map (\(i,n,_,b) -> (i,n,b)) allSlots
-
--- | Allocate local closures
-allocCls :: Maybe JStat -> [(Id, CgStgRhs)] -> G JStat
-allocCls dynMiddle xs = do
-   (stat, dyn) <- partitionEithers <$> mapM toCl xs
-   ac <- allocDynAll True dynMiddle dyn
-   pure (mconcat stat <> ac)
-  where
-    -- left = static, right = dynamic
-    toCl :: (Id, CgStgRhs)
-         -> G (Either JStat (Ident,JExpr,[JExpr],CostCentreStack))
-    -- statics
-    {- making zero-arg constructors static is problematic, see #646
-       proper candidates for this optimization should have been floated
-       already
-      toCl (i, StgRhsCon cc con []) = do
-      ii <- identForId i
-      Left <$> (return (decl ii) <> allocCon ii con cc []) -}
-    toCl (i, StgRhsCon cc con _mui _ticjs [a]) | isUnboxableCon con = do
-      ii <- identForId i
-      ac <- allocCon ii con cc =<< genArg a
-      pure (Left (decl ii <> ac))
-
-    -- dynamics
-    toCl (i, StgRhsCon cc con _mu _ticks ar) =
-      -- fixme do we need to handle unboxed?
-      Right <$> ((,,,) <$> identForId i
-                       <*> varForDataConWorker con
-                       <*> concatMapM genArg ar
-                       <*> pure cc)
-    toCl (i, cl@(StgRhsClosure _ext cc _upd_flag _args _body)) =
-      let live = stgLneLiveExpr cl
-      in  Right <$> ((,,,) <$> identForId i
-                       <*> varForEntryId i
-                       <*> concatMapM varsForId live
-                       <*> pure cc)
-
--- fixme CgCase has a reps_compatible check here
--- | Consume Stg case statement and generate a case statement. See also
--- 'genAlts'
-genCase :: HasDebugCallStack
-        => ExprCtx
-        -> Id
-        -> CgStgExpr
-        -> AltType
-        -> [CgStgAlt]
-        -> LiveVars
-        -> G (JStat, ExprResult)
-genCase ctx bnd e at alts l
-  | snd (isInlineExpr (ctxEvaluatedIds ctx) e) = do
-      bndi <- identsForId bnd
-      let ctx' = ctxSetTop bnd
-                  $ ctxSetTarget (assocIdExprs bnd (map toJExpr bndi))
-                  $ ctx
-      (ej, r) <- genExpr ctx' e
-      let d = case r of
-                ExprInline d0 -> d0
-                ExprCont -> pprPanic "genCase: expression was not inline"
-                                     (pprStgExpr panicStgPprOpts e)
-
-      (aj, ar) <- genAlts (ctxAssertEvaluated bnd ctx) bnd at d alts
-      (saveCCS,restoreCCS) <- ifProfilingM $ do
-        ccsVar <- freshIdent
-        pure ( ccsVar ||= toJExpr jCurrentCCS
-             , toJExpr jCurrentCCS |= toJExpr ccsVar
-             )
-      return ( mconcat
-          [ mconcat (map decl bndi)
-          , saveCCS
-          , ej
-          , restoreCCS
-          , aj
-          ]
-        , ar
-         )
-  | otherwise = do
-      rj       <- genRet (ctxAssertEvaluated bnd ctx) bnd at alts l
-      let ctx' = ctxSetTop bnd
-                  $ ctxSetTarget (assocIdExprs bnd (map toJExpr [R1 ..]))
-                  $ ctx
-      (ej, _r) <- genExpr ctx' e
-      return (rj <> ej, ExprCont)
-
-genRet :: HasDebugCallStack
-       => ExprCtx
-       -> Id
-       -> AltType
-       -> [CgStgAlt]
-       -> LiveVars
-       -> G JStat
-genRet ctx e at as l = freshIdent >>= f
-  where
-    allRefs :: [Id]
-    allRefs =  S.toList . S.unions $ fmap (exprRefs emptyUFM . alt_rhs) as
-    lneLive :: Int
-    lneLive    = maximum $ 0 : catMaybes (map (ctxLneBindingStackSize ctx) allRefs)
-    ctx'       = ctxLneShrinkStack ctx lneLive
-    lneVars    = map fst $ ctxLneFrameVars ctx'
-    isLne i    = ctxIsLneBinding ctx i || ctxIsLneLiveVar ctx' i
-    nonLne     = filter (not . isLne) (dVarSetElems l)
-
-    f :: Ident -> G JStat
-    f r@(TxtI ri)    =  do
-      pushLne  <- pushLneFrame lneLive ctx
-      saveCCS  <- ifProfilingM $ push [jCurrentCCS]
-      free     <- optimizeFree 0 nonLne
-      pushRet  <- pushRetArgs free (toJExpr r)
-      fun'     <- fun free
-      sr       <- genStaticRefs l -- srt
-      prof     <- profiling
-      emitClosureInfo $
-        ClosureInfo r
-                    (CIRegs 0 altRegs)
-                    ri
-                    (fixedLayout . reverse $
-                       map (stackSlotType . fst3) free
-                       ++ if prof then [ObjV] else map stackSlotType lneVars)
-                    CIStackFrame
-                    sr
-      emitToplevel $ r ||= toJExpr (JFunc [] fun')
-      return (pushLne <> saveCCS <> pushRet)
-    fst3 ~(x,_,_)  = x
-
-    altRegs :: HasDebugCallStack => [VarType]
-    altRegs = case at of
-      PrimAlt ptc    -> [primRepVt ptc]
-      MultiValAlt _n -> idVt e
-      _              -> [PtrV]
-
-    -- special case for popping CCS but preserving stack size
-    pop_handle_CCS :: [(JExpr, StackSlot)] -> G JStat
-    pop_handle_CCS [] = return mempty
-    pop_handle_CCS xs = do
-      -- grab the slots from 'xs' and push
-      addSlots (map snd xs)
-      -- move the stack pointer into the stack by ''length xs + n'
-      a <- adjSpN (length xs)
-      -- now load from the top of the stack
-      return (loadSkip 0 (map fst xs) <> a)
-
-    fun free = resetSlots $ do
-      decs          <- declVarsForId e
-      load          <- flip assignAll (map toJExpr [R1 ..]) . map toJExpr <$> identsForId e
-      loadv         <- verifyRuntimeReps [e]
-      ras           <- loadRetArgs free
-      rasv          <- verifyRuntimeReps (map (\(x,_,_)->x) free)
-      restoreCCS    <- ifProfilingM . pop_handle_CCS $ pure (jCurrentCCS, SlotUnknown)
-      rlne          <- popLneFrame False lneLive ctx'
-      rlnev         <- verifyRuntimeReps lneVars
-      (alts, _altr) <- genAlts ctx' e at Nothing as
-      return $ decs <> load <> loadv <> ras <> rasv <> restoreCCS <> rlne <> rlnev <> alts <>
-               returnStack
-
--- | Consume an Stg case alternative and generate the corresponding alternative
--- in JS land. If one alternative is a continuation then we must normalize the
--- other alternatives. See 'Branch' and 'normalizeBranches'.
-genAlts :: HasDebugCallStack
-        => ExprCtx        -- ^ lhs to assign expression result to
-        -> Id             -- ^ id being matched
-        -> AltType        -- ^ type
-        -> Maybe [JExpr]  -- ^ if known, fields in datacon from earlier expression
-        -> [CgStgAlt]     -- ^ the alternatives
-        -> G (JStat, ExprResult)
-genAlts ctx e at me alts = do
-  (st, er) <- case at of
-
-    PolyAlt -> case alts of
-      [alt] -> (branch_stat &&& branch_result) <$> mkAlgBranch ctx e alt
-      _     -> panic "genAlts: multiple polyalt"
-
-    PrimAlt _tc
-      | [GenStgAlt _ bs expr] <- alts
-      -> do
-        ie       <- varsForId e
-        dids     <- mconcat <$> mapM declVarsForId bs
-        bss      <- concatMapM varsForId bs
-        (ej, er) <- genExpr ctx expr
-        return (dids <> assignAll bss ie <> ej, er)
-
-    PrimAlt tc
-      -> do
-        ie <- varsForId e
-        (r, bss) <- normalizeBranches ctx <$>
-           mapM (isolateSlots . mkPrimIfBranch ctx [primRepVt tc]) alts
-        setSlots []
-        return (mkSw ie bss, r)
-
-    MultiValAlt n
-      | [GenStgAlt _ bs expr] <- alts
-      -> do
-        eids     <- varsForId e
-        l        <- loadUbxTup eids bs n
-        (ej, er) <- genExpr ctx expr
-        return (l <> ej, er)
-
-    AlgAlt tc
-      | [_alt] <- alts
-      , isUnboxedTupleTyCon tc
-      -> panic "genAlts: unexpected unboxed tuple"
-
-    AlgAlt _tc
-      | Just es <- me
-      , [GenStgAlt (DataAlt dc) bs expr] <- alts
-      , not (isUnboxableCon dc)
-      -> do
-        bsi <- mapM identsForId bs
-        (ej, er) <- genExpr ctx expr
-        return (declAssignAll (concat bsi) es <> ej, er)
-
-    AlgAlt _tc
-      | [alt] <- alts
-      -> do
-        Branch _ s r <- mkAlgBranch ctx e alt
-        return (s, r)
-
-    AlgAlt _tc
-      | [alt,_] <- alts
-      , DataAlt dc <- alt_con alt
-      , isBoolDataCon dc
-      -> do
-        i <- varForId e
-        nbs <- normalizeBranches ctx <$>
-            mapM (isolateSlots . mkAlgBranch ctx e) alts
-        case nbs of
-          (r, [Branch _ s1 _, Branch _ s2 _]) -> do
-            let s = if   dataConTag dc == 2
-                    then IfStat i s1 s2
-                    else IfStat i s2 s1
-            setSlots []
-            return (s, r)
-          _ -> error "genAlts: invalid branches for Bool"
-
-    AlgAlt _tc -> do
-        ei <- varForId e
-        (r, brs) <- normalizeBranches ctx <$>
-            mapM (isolateSlots . mkAlgBranch ctx e) alts
-        setSlots []
-        return (mkSwitch (ei .^ "f" .^ "a") brs, r)
-
-    _ -> pprPanic "genAlts: unhandled case variant" (ppr (at, length alts))
-
-  ver <- verifyMatchRep e at
-  pure (ver <> st, er)
-
--- | If 'StgToJSConfig.csRuntimeAssert' is set, then generate an assertion that
--- asserts the pattern match is valid, e.g., the match is attempted on a
--- Boolean, a Data Constructor, or some number.
-verifyMatchRep :: HasDebugCallStack => Id -> AltType -> G JStat
-verifyMatchRep x alt = do
-  runtime_assert <- csRuntimeAssert <$> getSettings
-  if not runtime_assert
-    then pure mempty
-    else case alt of
-      AlgAlt tc -> do
-        ix <- varsForId x
-        pure $ ApplStat (var "h$verify_match_alg") (ValExpr(JStr(mkFastString (renderWithContext defaultSDocContext (ppr tc)))):ix)
-      _ -> pure mempty
-
--- | A 'Branch' represents a possible branching path of an Stg case statement,
--- i.e., a possible code path from an 'StgAlt'
-data Branch a = Branch
-  { branch_expr   :: a
-  , branch_stat   :: JStat
-  , branch_result :: ExprResult
-  }
-  deriving (Eq,Functor)
-
--- | If one branch ends in a continuation but another is inline, we need to
--- adjust the inline branch to use the continuation convention
-normalizeBranches :: ExprCtx
-                  -> [Branch a]
-                  -> (ExprResult, [Branch a])
-normalizeBranches ctx brs
-    | all (==ExprCont) (fmap branch_result brs) =
-        (ExprCont, brs)
-    | branchResult (fmap branch_result brs) == ExprCont =
-        (ExprCont, map mkCont brs)
-    | otherwise =
-        (ExprInline Nothing, brs)
-  where
-    mkCont b = case branch_result b of
-      ExprInline{} -> b { branch_stat   = branch_stat b <> assignAll jsRegsFromR1
-                                                                     (concatMap typex_expr $ ctxTarget ctx)
-                        , branch_result = ExprCont
-                        }
-      _ -> b
-
--- | Load an unboxed tuple. "Loading" means getting all 'Idents' from the input
--- ID's, declaring them as variables in JS land and binding them, in order, to
--- 'es'.
-loadUbxTup :: [JExpr] -> [Id] -> Int -> G JStat
-loadUbxTup es bs _n = do
-  bs' <- concatMapM identsForId bs
-  return $ declAssignAll bs' es
-
-mkSw :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat
-mkSw [e] cases = mkSwitch e (fmap (fmap (fmap head)) cases)
-mkSw es cases  = mkIfElse es cases
-
--- | Switch for pattern matching on constructors or prims
-mkSwitch :: JExpr -> [Branch (Maybe JExpr)] -> JStat
-mkSwitch e cases
-  | [Branch (Just c1) s1 _] <- n
-  , [Branch _ s2 _] <- d
-  = IfStat (InfixExpr StrictEqOp e c1) s1 s2
-
-  | [Branch (Just c1) s1 _, Branch _ s2 _] <- n
-  , null d
-  = IfStat (InfixExpr StrictEqOp e c1) s1 s2
-
-  | null d
-  = SwitchStat e (map addBreak (init n)) (branch_stat (last n))
-
-  | [Branch _ d0 _] <- d
-  = SwitchStat e (map addBreak n) d0
-
-  | otherwise = panic "mkSwitch: multiple default cases"
-  where
-    addBreak (Branch (Just c) s _) = (c, mconcat [s, BreakStat Nothing])
-    addBreak _                     = panic "mkSwitch: addBreak"
-    (n,d) = L.partition (isJust . branch_expr) cases
-
--- | if/else for pattern matching on things that js cannot switch on
--- the list of branches is expected to have the default alternative
--- first, if it exists
-mkIfElse :: [JExpr] -> [Branch (Maybe [JExpr])] -> JStat
-mkIfElse e s = go (L.reverse s)
-    where
-      go = \case
-        [Branch _ s _]              -> s -- only one 'nothing' allowed
-        (Branch (Just e0) s _ : xs) -> IfStat (mkEq e e0) s (go xs)
-        [] -> panic "mkIfElse: empty expression list"
-        _  -> panic "mkIfElse: multiple DEFAULT cases"
-
--- | Wrapper to contruct sequences of (===), e.g.,
---
--- > mkEq [l0,l1,l2] [r0,r1,r2] = (l0 === r0) && (l1 === r1) && (l2 === r2)
---
-mkEq :: [JExpr] -> [JExpr] -> JExpr
-mkEq es1 es2
-  | length es1 == length es2 = foldl1 (InfixExpr LAndOp) (zipWith (InfixExpr StrictEqOp) es1 es2)
-  | otherwise                = panic "mkEq: incompatible expressions"
-
-mkAlgBranch :: ExprCtx   -- ^ toplevel id for the result
-            -> Id        -- ^ datacon to match
-            -> CgStgAlt  -- ^ match alternative with binders
-            -> G (Branch (Maybe JExpr))
-mkAlgBranch top d alt
-  | DataAlt dc <- alt_con alt
-  , isUnboxableCon dc
-  , [b] <- alt_bndrs alt
-  = do
-    idd  <- varForId d
-    fldx <- identsForId b
-    case fldx of
-      [fld] -> do
-        (ej, er) <- genExpr top (alt_rhs alt)
-        return (Branch Nothing (mconcat [fld ||= idd, ej]) er)
-      _ -> panic "mkAlgBranch: invalid size"
-
-  | otherwise
-  = do
-    cc       <- caseCond (alt_con alt)
-    idd      <- varForId d
-    b        <- loadParams idd (alt_bndrs alt)
-    (ej, er) <- genExpr top (alt_rhs alt)
-    return (Branch cc (b <> ej) er)
-
--- | Generate a primitive If-expression
-mkPrimIfBranch :: ExprCtx
-               -> [VarType]
-               -> CgStgAlt
-               -> G (Branch (Maybe [JExpr]))
-mkPrimIfBranch top _vt alt =
-  (\ic (ej,er) -> Branch ic ej er) <$> ifCond (alt_con alt) <*> genExpr top (alt_rhs alt)
-
--- fixme are bool things always checked correctly here?
-ifCond :: AltCon -> G (Maybe [JExpr])
-ifCond = \case
-  DataAlt da -> return $ Just [toJExpr (dataConTag da)]
-  LitAlt l   -> Just <$> genLit l
-  DEFAULT    -> return Nothing
-
-caseCond :: AltCon -> G (Maybe JExpr)
-caseCond = \case
-  DEFAULT    -> return Nothing
-  DataAlt da -> return $ Just (toJExpr $ dataConTag da)
-  LitAlt l   -> genLit l >>= \case
-    [e] -> pure (Just e)
-    es  -> pprPanic "caseCond: expected single-variable literal" (ppr es)
-
--- fixme use single tmp var for all branches
--- | Load parameters from constructor
-loadParams :: JExpr -> [Id] -> G JStat
-loadParams from args = do
-  as <- concat <$> zipWithM (\a u -> map (,u) <$> identsForId a) args use
-  return $ case as of
-    []                 -> mempty
-    [(x,u)]            -> loadIfUsed (from .^ closureField1_) x  u
-    [(x1,u1),(x2,u2)]  -> mconcat
-                            [ loadIfUsed (from .^ closureField1_) x1 u1
-                            , loadIfUsed (from .^ closureField2_) x2 u2
-                            ]
-    ((x,u):xs)         -> mconcat
-                            [ loadIfUsed (from .^ closureField1_) x u
-                            , jVar (\d -> mconcat [ d |= from .^ closureField2_
-                                                  , loadConVarsIfUsed d xs
-                                                  ])
-                            ]
-  where
-    use = repeat True -- fixme clean up
-    loadIfUsed fr tgt True = tgt ||= fr
-    loadIfUsed  _ _   _    = mempty
-
-    loadConVarsIfUsed fr cs = mconcat $ zipWith f cs [(1::Int)..]
-      where f (x,u) n = loadIfUsed (SelExpr fr (TxtI (dataFieldName n))) x u
-
--- | Determine if a branch will end in a continuation or not. If not the inline
--- branch must be normalized. See 'normalizeBranches'
--- NB. not a Monoid
-branchResult :: HasDebugCallStack => [ExprResult] -> ExprResult
-branchResult = \case
-  []                   -> panic "branchResult: empty list"
-  [e]                  -> e
-  (ExprCont:_)         -> ExprCont
-  (_:es)
-    | elem ExprCont es -> ExprCont
-    | otherwise        -> ExprInline Nothing
-
--- | Push return arguments onto the stack. The 'Bool' tracks whether the value
--- is already on the stack or not, used in 'StgToJS.Stack.pushOptimized'.
-pushRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> JExpr -> G JStat
-pushRetArgs free fun = do
-  rs <- mapM (\(i,n,b) -> (\es->(es!!(n-1),b)) <$> genIdArg i) free
-  pushOptimized (rs++[(fun,False)])
-
--- | Load the return arguments then pop the stack frame
-loadRetArgs :: HasDebugCallStack => [(Id,Int,Bool)] -> G JStat
-loadRetArgs free = do
-  ids <- mapM (\(i,n,_b) -> (!! (n-1)) <$> genIdStackArgI i) free
-  popSkipI 1 ids
-
--- | allocate multiple, possibly mutually recursive, closures
-allocDynAll :: Bool -> Maybe JStat -> [(Ident,JExpr,[JExpr],CostCentreStack)] -> G JStat
-{-
-XXX remove use of template and enable in-place init again
-allocDynAll haveDecl middle [(to,entry,free,cc)]
-  | isNothing middle && to `notElem` (free ^.. template) = do
-      ccs <- ccsVarJ cc
-      return $ allocDynamic s haveDecl to entry free ccs -}
-allocDynAll haveDecl middle cls = do
-  settings <- getSettings
-  let
-    middle' = fromMaybe mempty middle
-
-    decl_maybe i e
-      | haveDecl  = toJExpr i |= e
-      | otherwise = i ||= e
-
-    makeObjs :: G JStat
-    makeObjs =
-      fmap mconcat $ forM cls $ \(i,f,_,cc) -> do
-      ccs <- maybeToList <$> costCentreStackLbl cc
-      pure $ mconcat
-        [ decl_maybe i $ if csInlineAlloc settings
-            then ValExpr (jhFromList $ [ (closureEntry_ , f)
-                                       , (closureField1_, null_)
-                                       , (closureField2_, null_)
-                                       , (closureMeta_  , zero_)
-                                       ]
-                             ++ fmap (\cid -> ("cc", ValExpr (JVar cid))) ccs)
-            else ApplExpr (var "h$c") (f : fmap (ValExpr . JVar) ccs)
-        ]
-
-    fillObjs = mconcat $ map fillObj cls
-    fillObj (i,_,es,_)
-      | csInlineAlloc settings || length es > 24 =
-          case es of
-            []      -> mempty
-            [ex]    -> toJExpr i .^ closureField1_ |= toJExpr ex
-            [e1,e2] -> mconcat
-                        [ toJExpr i .^ closureField1_ |= toJExpr e1
-                        , toJExpr i .^ closureField2_ |= toJExpr e2
-                        ]
-            (ex:es)  -> mconcat
-                        [ toJExpr i .^ closureField1_ |= toJExpr ex
-                        , toJExpr i .^ closureField2_ |= toJExpr (jhFromList (zip dataFieldNames es))
-                        ]
-      | otherwise = case es of
-            []      -> mempty
-            [ex]    -> toJExpr i .^ closureField1_ |= ex
-            [e1,e2] -> mconcat
-                        [ toJExpr i .^ closureField1_ |= e1
-                        , toJExpr i .^ closureField2_ |= e2
-                        ]
-            (ex:es)  -> mconcat
-                        [ toJExpr i .^ closureField1_ |= ex
-                        , toJExpr i .^ closureField2_ |= fillFun es
-                        ]
-
-    fillFun [] = null_
-    fillFun es = ApplExpr (allocData (length es)) es
-
-    checkObjs | csAssertRts settings  = mconcat $
-                map (\(i,_,_,_) -> ApplStat (ValExpr (JVar (TxtI "h$checkObj"))) [toJExpr i]) cls
-              | otherwise = mempty
-
-  objs <- makeObjs
-  pure $ mconcat [objs, middle', fillObjs, checkObjs]
-
--- | Generate a primop. This function wraps around the real generator
--- 'GHC.StgToJS.genPrim', handling the 'ExprCtx' and all arguments before
--- generating the primop.
-genPrimOp :: ExprCtx -> PrimOp -> [StgArg] -> Type -> G (JStat, ExprResult)
-genPrimOp ctx op args t = do
-  as <- concatMapM genArg args
-  prof <- csProf <$> getSettings
-  bound <- csBoundsCheck <$> getSettings
-  -- fixme: should we preserve/check the primreps?
-  return $ case genPrim prof bound t op (concatMap typex_expr $ ctxTarget ctx) as of
-             PrimInline s -> (s, ExprInline Nothing)
-             PRPrimCall s -> (s, ExprCont)
diff --git a/compiler/GHC/StgToJS/ExprCtx.hs b/compiler/GHC/StgToJS/ExprCtx.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/ExprCtx.hs
+++ /dev/null
@@ -1,172 +0,0 @@
-{-# LANGUAGE TupleSections #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.StgToJS.ExprCtx
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
--- TODO: Write my description!
------------------------------------------------------------------------------
-
-module GHC.StgToJS.ExprCtx
-  ( ExprCtx
-  , initExprCtx
-  , ctxAssertEvaluated
-  , ctxIsEvaluated
-  , ctxSetSrcSpan
-  , ctxSrcSpan
-  , ctxSetTop
-  , ctxTarget
-  , ctxSetTarget
-  , ctxEvaluatedIds
-  -- * Let-no-escape
-  , ctxClearLneFrame
-  , ctxUpdateLneFrame
-  , ctxLneFrameVars
-  , ctxLneFrameSize
-  , ctxIsLneBinding
-  , ctxIsLneLiveVar
-  , ctxLneBindingStackSize
-  , ctxLneShrinkStack
-  )
-where
-
-import GHC.Prelude
-
-import GHC.StgToJS.Types
-
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Set
-import GHC.Types.Var
-import GHC.Types.SrcLoc
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import Data.Maybe
-
-
--- | Context into which an expression is evaluated
-data ExprCtx = ExprCtx
-  { ctxTop        :: Id
-    -- ^ Top-level binding Id
-
-  , ctxTarget     :: [TypedExpr]
-    -- ^ Target variables for the evaluated expression
-
-  , ctxEvaluatedIds :: UniqSet Id
-    -- ^ Ids that we know to be evaluated (e.g. case binders when the expression
-    -- to evaluate is in an alternative)
-
-  , ctxSrcSpan    :: Maybe RealSrcSpan
-    -- ^ Source location
-
-  ----------------------------
-  -- Handling of let-no-escape
-
-  , ctxLneFrameBs :: UniqFM Id Int
-    -- ^ LNE bindings with their expected stack size.
-    --
-    -- The Int is the size of the stack when the LNE binding was defined.
-    -- We need to shrink the stack back to this size when we enter one of the
-    -- associated binder rhs: it expects its free variables at certain offsets
-    -- in the stack.
-
-  , ctxLneFrameVars :: [(Id,Int)]
-    -- ^ Contents of current LNE frame
-    --
-    -- Variables and their index on the stack
-
-  , ctxLneFrameSize :: {-# UNPACK #-} !Int
-    -- ^ Cache the length of `ctxLneFrameVars`
-
-  }
-
--- | Initialize an expression context in the context of the given top-level
--- binding Id
-initExprCtx :: Id -> ExprCtx
-initExprCtx i = ExprCtx
-  { ctxTop          = i
-  , ctxTarget       = []
-  , ctxEvaluatedIds = emptyUniqSet
-  , ctxLneFrameBs   = emptyUFM
-  , ctxLneFrameVars = []
-  , ctxLneFrameSize = 0
-  , ctxSrcSpan      = Nothing
-  }
-
--- | Set target
-ctxSetTarget :: [TypedExpr] -> ExprCtx -> ExprCtx
-ctxSetTarget t ctx = ctx { ctxTarget = t }
-
--- | Set top-level binding Id
-ctxSetTop :: Id -> ExprCtx -> ExprCtx
-ctxSetTop i ctx = ctx { ctxTop = i }
-
--- | Add an Id to the known-evaluated set
-ctxAssertEvaluated :: Id -> ExprCtx -> ExprCtx
-ctxAssertEvaluated i ctx = ctx { ctxEvaluatedIds = addOneToUniqSet (ctxEvaluatedIds ctx) i }
-
--- | Set source location
-ctxSetSrcSpan :: RealSrcSpan -> ExprCtx -> ExprCtx
-ctxSetSrcSpan span ctx = ctx { ctxSrcSpan = Just span }
-
--- | Update let-no-escape frame
-ctxUpdateLneFrame :: [(Id,Int)] -> [Id] -> ExprCtx -> ExprCtx
-ctxUpdateLneFrame new_spilled_vars new_lne_ids ctx =
-  let old_frame_size = ctxLneFrameSize ctx
-      new_frame_size = old_frame_size + length new_spilled_vars
-  in ctx
-    { ctxLneFrameBs   = addListToUFM (ctxLneFrameBs ctx) (map (,new_frame_size) new_lne_ids)
-    , ctxLneFrameSize = new_frame_size
-    , ctxLneFrameVars = ctxLneFrameVars ctx ++ new_spilled_vars
-    }
-
--- | Remove information about the current LNE frame
-ctxClearLneFrame :: ExprCtx -> ExprCtx
-ctxClearLneFrame ctx =
-  ctx
-    { ctxLneFrameBs   = emptyUFM
-    , ctxLneFrameVars = []
-    , ctxLneFrameSize = 0
-    }
-
--- | Predicate: do we know for sure that the given Id is evaluated?
-ctxIsEvaluated :: ExprCtx -> Id -> Bool
-ctxIsEvaluated ctx i = i `elementOfUniqSet` ctxEvaluatedIds ctx
-
--- | Does the given Id correspond to a LNE binding
-ctxIsLneBinding :: ExprCtx -> Id -> Bool
-ctxIsLneBinding ctx i = isJust (ctxLneBindingStackSize ctx i)
-
--- | Does the given Id correspond to a LNE live var on the stack
-ctxIsLneLiveVar :: ExprCtx -> Id -> Bool
-ctxIsLneLiveVar ctx i = i `elem` map fst (ctxLneFrameVars ctx)
-
--- | Return the LNE stack size associated to the given Id.
--- Return Nothing when the Id doesn't correspond to a LNE binding.
-ctxLneBindingStackSize :: ExprCtx -> Id -> Maybe Int
-ctxLneBindingStackSize ctx i = lookupUFM (ctxLneFrameBs ctx) i
-
--- | Shrink the LNE stack to the given size
-ctxLneShrinkStack :: ExprCtx -> Int -> ExprCtx
-ctxLneShrinkStack ctx n =
-  let l = ctxLneFrameSize ctx
-  in assertPpr
-      (l >= n)
-      (vcat [ text "ctxLneShrinkStack: let-no-escape stack too short:"
-            , ppr l
-            , text " < "
-            , ppr n
-            ])
-      (ctx { ctxLneFrameVars = take n (ctxLneFrameVars ctx)
-           , ctxLneFrameSize = n
-           }
-      )
diff --git a/compiler/GHC/StgToJS/FFI.hs b/compiler/GHC/StgToJS/FFI.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/FFI.hs
+++ /dev/null
@@ -1,352 +0,0 @@
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module GHC.StgToJS.FFI
-  ( genPrimCall
-  , genForeignCall
-  , saturateFFI
-  )
-where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax
-import GHC.JS.Make
-import GHC.JS.Transform
-
-import GHC.StgToJS.Arg
-import GHC.StgToJS.ExprCtx
-import GHC.StgToJS.Monad
-import GHC.StgToJS.Types
-import GHC.StgToJS.Literal
-import GHC.StgToJS.Regs
-import GHC.StgToJS.CoreUtils
-import GHC.StgToJS.Ids
-
-import GHC.Types.RepType
-import GHC.Types.ForeignCall
-import GHC.Types.Unique.Map
-import GHC.Types.Unique.FM
-
-import GHC.Stg.Syntax
-
-import GHC.Builtin.PrimOps
-import GHC.Builtin.Types.Prim
-
-import GHC.Core.Type hiding (typeSize)
-
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr, vcat, text)
-import GHC.Data.FastString
-
-import Data.Char
-import Data.Monoid
-import Data.Maybe
-import qualified Data.List as L
-import Control.Monad
-import Control.Applicative
-import qualified Text.ParserCombinators.ReadP as P
-
-genPrimCall :: ExprCtx -> PrimCall -> [StgArg] -> Type -> G (JStat, ExprResult)
-genPrimCall ctx (PrimCall lbl _) args t = do
-  j <- parseFFIPattern False False False ("h$" ++ unpackFS lbl) t (concatMap typex_expr $ ctxTarget ctx) args
-  return (j, ExprInline Nothing)
-
--- | generate the actual call
-{-
-  parse FFI patterns:
-   "&value         -> value
-  1. "function"      -> ret = function(...)
-  2. "$r = $1.f($2)  -> r1 = a1.f(a2)
-
-  arguments, $1, $2, $3 unary arguments
-     $1_1, $1_2, for a binary argument
-
-  return type examples
-  1. $r                      unary return
-  2. $r1, $r2                binary return
-  3. $r1, $r2, $r3_1, $r3_2  unboxed tuple return
- -}
-parseFFIPattern :: Bool  -- ^ catch exception and convert them to haskell exceptions
-                -> Bool  -- ^ async (only valid with javascript calling conv)
-                -> Bool  -- ^ using javascript calling convention
-                -> String
-                -> Type
-                -> [JExpr]
-                -> [StgArg]
-                -> G JStat
-parseFFIPattern catchExcep async jscc pat t es as
-  | catchExcep = do
-      c <- parseFFIPatternA async jscc pat t es as
-      -- Generate:
-      --  try {
-      --    `c`;
-      --  } catch(except) {
-      --    return h$throwJSException(except);
-      --  }
-      let ex = TxtI "except"
-      return (TryStat c ex (ReturnStat (ApplExpr (var "h$throwJSException") [toJExpr ex])) mempty)
-  | otherwise  = parseFFIPatternA async jscc pat t es as
-
-parseFFIPatternA :: Bool  -- ^ async
-                 -> Bool  -- ^ using JavaScript calling conv
-                 -> String
-                 -> Type
-                 -> [JExpr]
-                 -> [StgArg]
-                 -> G JStat
--- async calls get an extra callback argument
--- call it with the result
-parseFFIPatternA True True pat t es as  = do
-  cb <- freshIdent
-  x  <- freshIdent
-  d  <- freshIdent
-  stat <- parseFFIPattern' (Just (toJExpr cb)) True pat t es as
-  return $ mconcat
-    [ x  ||= (toJExpr (jhFromList [("mv", null_)]))
-    , cb ||= ApplExpr (var "h$mkForeignCallback") [toJExpr x]
-    , stat
-    , IfStat (InfixExpr StrictEqOp (toJExpr x .^ "mv") null_)
-          (mconcat
-            [ toJExpr x .^ "mv" |= UOpExpr NewOp (ApplExpr (var "h$MVar") [])
-            , sp |= Add sp one_
-            , (IdxExpr stack sp) |= var "h$unboxFFIResult"
-            , ReturnStat $ ApplExpr (var "h$takeMVar") [toJExpr x .^ "mv"]
-            ])
-          (mconcat
-            [ d ||= toJExpr x .^ "mv"
-            , copyResult (toJExpr d)
-            ])
-    ]
-    where nrst = typeSize t
-          copyResult d = assignAllEqual es (map (IdxExpr d . toJExpr) [0..nrst-1])
-parseFFIPatternA _async javascriptCc pat t es as =
-  parseFFIPattern' Nothing javascriptCc pat t es as
-
--- parseFFIPatternA _ _ _ _ _ _ = error "parseFFIPattern: non-JavaScript pattern must be synchronous"
-
-parseFFIPattern' :: Maybe JExpr -- ^ Nothing for sync, Just callback for async
-                 -> Bool        -- ^ javascript calling convention used
-                 -> String      -- ^ pattern called
-                 -> Type        -- ^ return type
-                 -> [JExpr]     -- ^ expressions to return in (may be more than necessary)
-                 -> [StgArg]    -- ^ arguments
-                 -> G JStat
-parseFFIPattern' callback javascriptCc pat t ret args
-  | not javascriptCc = mkApply pat
-  | otherwise =
-   if True
-     then mkApply pat
-     else do
-      u <- freshUnique
-      case parseFfiJME pat u of
-        Right (ValExpr (JVar (TxtI _ident))) -> mkApply pat
-        Right expr | not async && length tgt < 2 -> do
-          (statPre, ap) <- argPlaceholders javascriptCc args
-          let rp  = resultPlaceholders async t ret
-              env = addListToUFM emptyUFM (rp ++ ap)
-          if length tgt == 1
-            then return $ statPre <> (mapStatIdent (replaceIdent env) (var "$r" |= expr))
-            else return $ statPre <> (mapStatIdent (replaceIdent env) (toStat expr))
-        Right _ -> p $ "invalid expression FFI pattern. Expression FFI patterns can only be used for synchronous FFI " ++
-                       " imports with result size 0 or 1.\n" ++ pat
-        Left _ -> case parseFfiJM pat u of
-          Left err -> p (show err)
-          Right stat -> do
-            let rp = resultPlaceholders async t ret
-            let cp = callbackPlaceholders callback
-            (statPre, ap) <- argPlaceholders javascriptCc args
-            let env = addListToUFM emptyUFM (rp ++ ap ++ cp)
-            return $ statPre <> (mapStatIdent (replaceIdent env) stat) -- fixme trace?
-  where
-    async = isJust callback
-    tgt = take (typeSize t) ret
-    -- automatic apply, build call and result copy
-    mkApply f
-      | Just cb <- callback = do
-         (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args
-         cs <- getSettings
-         return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as++[cb])
-      | {-ts@-}
-        (t:ts') <- tgt = do
-         (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args
-         cs <- getSettings
-         return $ traceCall cs as
-                <> mconcat stats
-                <> (t |= ApplExpr f' (concat as) )
-                <> copyResult ts'
-           -- _ -> error "mkApply: empty list"
-      | otherwise = do
-         (stats, as) <- unzip <$> mapM (genFFIArg javascriptCc) args
-         cs <- getSettings
-         return $ traceCall cs as <> mconcat stats <> ApplStat f' (concat as)
-        where f' = toJExpr (TxtI $ mkFastString f)
-    copyResult rs = mconcat $ zipWith (\t r -> toJExpr r |= toJExpr t) (enumFrom Ret1) rs
-    p e = error ("Parse error in FFI pattern: " ++ pat ++ "\n" ++ e)
-
-    replaceIdent :: UniqFM Ident JExpr -> Ident -> JExpr
-    replaceIdent env i
-      | isFFIPlaceholder i = fromMaybe err (lookupUFM env i)
-      | otherwise = ValExpr (JVar i)
-        where
-          (TxtI i') = i
-          err = pprPanic "parseFFIPattern': invalid placeholder, check function type"
-                  (vcat [text pat, ppr i', ppr args, ppr t])
-    traceCall cs as
-        | csTraceForeign cs = ApplStat (var "h$traceForeign") [toJExpr pat, toJExpr as]
-        | otherwise         = mempty
-
--- ident is $N, $N_R, $rN, $rN_R or $r or $c
-isFFIPlaceholder :: Ident -> Bool
-isFFIPlaceholder (TxtI x) = not (null (P.readP_to_S parser (unpackFS x)))
-  where
-    digit = P.satisfy (`elem` ("0123456789" :: String))
-    parser = void (P.string "$r" >> P.eof) <|>
-             void (P.string "$c" >> P.eof) <|> do
-      _ <- P.char '$'
-      P.optional (P.char 'r')
-      _ <- P.many1 digit
-      P.optional (P.char '_' >> P.many1 digit)
-      P.eof
-
--- generate arg to be passed to FFI call, with marshalling JStat to be run
--- before the call
-genFFIArg :: Bool -> StgArg -> G (JStat, [JExpr])
-genFFIArg _isJavaScriptCc (StgLitArg l) = (mempty,) <$> genLit l
-genFFIArg isJavaScriptCc a@(StgVarArg i)
-    | not isJavaScriptCc &&
-      (tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon) =
-        (\x -> (mempty,[x, zero_])) <$> varForId i
-    | isVoid r                  = return (mempty, [])
---    | Just x <- marshalFFIArg a = x
-    | isMultiVar r              = (mempty,) <$> mapM (varForIdN i) [1..varSize r]
-    | otherwise                 = (\x -> (mempty,[x])) <$> varForId i
-   where
-     tycon  = tyConAppTyCon (unwrapType arg_ty)
-     arg_ty = stgArgType a
-     r      = uTypeVt arg_ty
-
--- $1, $2, $3 for single, $1_1, $1_2 etc for dual
--- void args not counted
-argPlaceholders :: Bool -> [StgArg] -> G (JStat, [(Ident,JExpr)])
-argPlaceholders isJavaScriptCc args = do
-  (stats, idents0) <- unzip <$> mapM (genFFIArg isJavaScriptCc) args
-  let idents = filter (not . null) idents0
-  return $ (mconcat stats, concat
-    (zipWith (\is n -> mkPlaceholder True ("$"++show n) is) idents [(1::Int)..]))
-
-mkPlaceholder :: Bool -> String -> [JExpr] -> [(Ident, JExpr)]
-mkPlaceholder undersc prefix aids =
-      case aids of
-             []       -> []
-             [x]      -> [(TxtI . mkFastString $ prefix, x)]
-             xs@(x:_) -> (TxtI . mkFastString $ prefix, x) :
-                zipWith (\x m -> (TxtI . mkFastString $ prefix ++ u ++ show m,x)) xs [(1::Int)..]
-   where u = if undersc then "_" else ""
-
--- $r for single, $r1,$r2 for dual
--- $r1, $r2, etc for ubx tup, void args not counted
-resultPlaceholders :: Bool -> Type -> [JExpr] -> [(Ident,JExpr)] -- ident, replacement
-resultPlaceholders True _ _ = [] -- async has no direct resuls, use callback
-resultPlaceholders False t rs =
-  case typeVt (unwrapType t) of
-    [t'] -> mkUnary (varSize t')
-    uts ->
-      let sizes = filter (>0) (map varSize uts)
-          f _ 0 = []
-          f n 1 = [["$r" ++ show n]]
-          f n k = ["$r" ++ sn, "$r" ++ sn ++ "_1"] : map (\x -> ["$r" ++ sn ++ "_" ++ show x]) [2..k]
-            where sn = show n
-          phs   = zipWith (\size n -> f n size) sizes [(1::Int)..]
-      in case sizes of
-           [n] -> mkUnary n
-           _   -> concat $ zipWith (\phs' r -> map (\i -> (TxtI (mkFastString i), r)) phs') (concat phs) rs
-  where
-    mkUnary 0 = []
-    mkUnary 1 = [(TxtI "$r",head rs)] -- single
-    mkUnary n = [(TxtI "$r",head rs),(TxtI "$r1", head rs)] ++
-       zipWith (\n r -> (TxtI . mkFastString $ "$r" ++ show n, toJExpr r)) [2..n] (tail rs)
-
-callbackPlaceholders :: Maybe JExpr -> [(Ident,JExpr)]
-callbackPlaceholders Nothing  = []
-callbackPlaceholders (Just e) = [((TxtI "$c"), e)]
-
-parseFfiJME :: String -> Int -> Either String JExpr
-parseFfiJME _xs _u =  Left "parseFfiJME not yet implemented"
-
-parseFfiJM :: String -> Int -> Either String JStat
-parseFfiJM _xs _u = Left "parseFfiJM not yet implemented"
-
-saturateFFI :: JMacro a => Int -> a -> a
-saturateFFI u = jsSaturate (Just . mkFastString $ "ghcjs_ffi_sat_" ++ show u)
-
-genForeignCall :: HasDebugCallStack
-               => ExprCtx
-               -> ForeignCall
-               -> Type
-               -> [JExpr]
-               -> [StgArg]
-               -> G (JStat, ExprResult)
-genForeignCall _ctx
-               (CCall (CCallSpec (StaticTarget _ tgt Nothing True)
-                                   JavaScriptCallConv
-                                   PlayRisky))
-               _t
-               [obj]
-               args
-  | tgt == fsLit "h$buildObject"
-  , Just pairs <- getObjectKeyValuePairs args = do
-      pairs' <- mapM (\(k,v) -> genArg v >>= \vs -> return (k, head vs)) pairs
-      return ( (|=) obj (ValExpr (JHash $ listToUniqMap pairs'))
-             , ExprInline Nothing
-             )
-
-genForeignCall ctx (CCall (CCallSpec ccTarget cconv safety)) t tgt args = do
-  emitForeign (ctxSrcSpan ctx) (mkFastString lbl) safety cconv (map showArgType args) (showType t)
-  (,exprResult) <$> parseFFIPattern catchExcep async isJsCc lbl t tgt' args
-  where
-    isJsCc = cconv == JavaScriptCallConv
-
-    lbl | (StaticTarget _ clbl _mpkg _isFunPtr) <- ccTarget
-            = let clbl' = unpackFS clbl
-              in  if | isJsCc -> clbl'
-                     | wrapperPrefix `L.isPrefixOf` clbl' ->
-                         ("h$" ++ (drop 2 $ dropWhile isDigit $ drop (length wrapperPrefix) clbl'))
-                     | otherwise -> "h$" ++ clbl'
-        | otherwise = "h$callDynamic"
-
-    exprResult | async     = ExprCont
-               | otherwise = ExprInline Nothing
-
-    catchExcep = (cconv == JavaScriptCallConv) &&
-                 playSafe safety || playInterruptible safety
-
-    async | isJsCc    = playInterruptible safety
-          | otherwise = playInterruptible safety || playSafe safety
-
-    tgt'  | async     = take (length tgt) jsRegsFromR1
-          | otherwise = tgt
-
-    wrapperPrefix = "ghczuwrapperZC"
-
-getObjectKeyValuePairs :: [StgArg] -> Maybe [(FastString, StgArg)]
-getObjectKeyValuePairs [] = Just []
-getObjectKeyValuePairs (k:v:xs)
-  | Just t <- argJSStringLitUnfolding k =
-      fmap ((t,v):) (getObjectKeyValuePairs xs)
-getObjectKeyValuePairs _ = Nothing
-
-argJSStringLitUnfolding :: StgArg -> Maybe FastString
-argJSStringLitUnfolding (StgVarArg _v) = Nothing -- fixme
-argJSStringLitUnfolding _              = Nothing
-
-showArgType :: StgArg -> FastString
-showArgType a = showType (stgArgType a)
-
-showType :: Type -> FastString
-showType t
-  | Just tc <- tyConAppTyCon_maybe (unwrapType t) =
-      mkFastString (renderWithContext defaultSDocContext (ppr tc))
-  | otherwise = "<unknown>"
diff --git a/compiler/GHC/StgToJS/Heap.hs b/compiler/GHC/StgToJS/Heap.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Heap.hs
+++ /dev/null
@@ -1,155 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
-
-module GHC.StgToJS.Heap
-  ( closureType
-  , entryClosureType
-  , isObject
-  , isThunk
-  , isThunk'
-  , isBlackhole
-  , isFun
-  , isFun'
-  , isPap
-  , isPap'
-  , isCon
-  , isCon'
-  , conTag
-  , conTag'
-  , closureEntry
-  , closureMeta
-  , closureField1
-  , closureField2
-  , closureCC
-  , funArity
-  , funArity'
-  , papArity
-  , funOrPapArity
-  -- * Field names
-  , closureEntry_
-  , closureMeta_
-  , closureCC_
-  , closureField1_
-  , closureField2_
-  -- * Javascript Type literals
-  , jTyObject
-  )
-where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax
-import GHC.JS.Make
-import GHC.StgToJS.Types
-import GHC.Data.FastString
-
-closureEntry_ :: FastString
-closureEntry_ = "f"
-
-closureField1_ :: FastString
-closureField1_ = "d1"
-
-closureField2_ :: FastString
-closureField2_ = "d2"
-
-closureMeta_ :: FastString
-closureMeta_ = "m"
-
-closureCC_ :: FastString
-closureCC_ = "cc"
-
-entryClosureType_ :: FastString
-entryClosureType_ = "t"
-
-entryConTag_ :: FastString
-entryConTag_ = "a"
-
-entryFunArity_ :: FastString
-entryFunArity_ = "a"
-
-jTyObject :: JExpr
-jTyObject = jString "object"
-
-closureType :: JExpr -> JExpr
-closureType = entryClosureType . closureEntry
-
-entryClosureType :: JExpr -> JExpr
-entryClosureType f = f .^ entryClosureType_
-
-isObject :: JExpr -> JExpr
-isObject c = typeof c .===. String "object"
-
-isThunk :: JExpr -> JExpr
-isThunk c = closureType c .===. toJExpr Thunk
-
-isThunk' :: JExpr -> JExpr
-isThunk' f = entryClosureType f .===. toJExpr Thunk
-
-isBlackhole :: JExpr -> JExpr
-isBlackhole c = closureType c .===. toJExpr Blackhole
-
-isFun :: JExpr -> JExpr
-isFun c = closureType c .===. toJExpr Fun
-
-isFun' :: JExpr -> JExpr
-isFun' f = entryClosureType f .===. toJExpr Fun
-
-isPap :: JExpr -> JExpr
-isPap c = closureType c .===. toJExpr Pap
-
-isPap' :: JExpr -> JExpr
-isPap' f = entryClosureType f .===. toJExpr Pap
-
-isCon :: JExpr -> JExpr
-isCon c = closureType c .===. toJExpr Con
-
-isCon' :: JExpr -> JExpr
-isCon' f = entryClosureType f .===. toJExpr Con
-
-conTag :: JExpr -> JExpr
-conTag = conTag' . closureEntry
-
-conTag' :: JExpr -> JExpr
-conTag' f = f .^ entryConTag_
-
--- | Get closure entry function
-closureEntry :: JExpr -> JExpr
-closureEntry p = p .^ closureEntry_
-
--- | Get closure metadata
-closureMeta :: JExpr -> JExpr
-closureMeta p = p .^ closureMeta_
-
--- | Get closure cost-center
-closureCC :: JExpr -> JExpr
-closureCC p = p .^ closureCC_
-
--- | Get closure extra field 1
-closureField1 :: JExpr -> JExpr
-closureField1 p = p .^ closureField1_
-
--- | Get closure extra field 2
-closureField2 :: JExpr -> JExpr
-closureField2 p = p .^ closureField2_
-
--- number of  arguments (arity & 0xff = arguments, arity >> 8 = number of registers)
-funArity :: JExpr -> JExpr
-funArity = funArity' . closureEntry
-
--- function arity with raw reference to the entry
-funArity' :: JExpr -> JExpr
-funArity' f = f .^ entryFunArity_
-
--- arity of a partial application
-papArity :: JExpr -> JExpr
-papArity cp = closureField1 (closureField2 cp)
-
-funOrPapArity
-  :: JExpr       -- ^ heap object
-  -> Maybe JExpr -- ^ reference to entry, if you have one already (saves a c.f lookup twice)
-  -> JExpr       -- ^ arity tag (tag >> 8 = registers, tag & 0xff = arguments)
-funOrPapArity c = \case
-  Nothing -> ((IfExpr (toJExpr (isFun c))) (toJExpr (funArity c)))
-             (toJExpr (papArity c))
-  Just f  -> ((IfExpr (toJExpr (isFun' f))) (toJExpr (funArity' f)))
-             (toJExpr (papArity c))
diff --git a/compiler/GHC/StgToJS/Ids.hs b/compiler/GHC/StgToJS/Ids.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Ids.hs
+++ /dev/null
@@ -1,238 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.StgToJS.Ids
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
---  Module to deal with JS identifiers
------------------------------------------------------------------------------
-
-module GHC.StgToJS.Ids
-  ( freshUnique
-  , freshIdent
-  , makeIdentForId
-  , cachedIdentForId
-  -- * Helpers for Idents
-  , identForId
-  , identForIdN
-  , identsForId
-  , identForEntryId
-  , identForDataConEntryId
-  , identForDataConWorker
-  -- * Helpers for variables
-  , varForId
-  , varForIdN
-  , varsForId
-  , varForEntryId
-  , varForDataConEntryId
-  , varForDataConWorker
-  , declVarsForId
-  )
-where
-
-import GHC.Prelude
-
-import GHC.StgToJS.Types
-import GHC.StgToJS.Monad
-import GHC.StgToJS.CoreUtils
-import GHC.StgToJS.Symbols
-
-import GHC.JS.Syntax
-import GHC.JS.Make
-
-import GHC.Core.DataCon
-import GHC.Types.Id
-import GHC.Types.Unique
-import GHC.Types.Unique.FM
-import GHC.Types.Name
-import GHC.Unit.Module
-import GHC.Data.FastString
-import GHC.Data.FastMutInt
-
-import Control.Monad
-import Control.Monad.IO.Class
-import qualified Control.Monad.Trans.State.Strict as State
-import qualified Data.Map  as M
-import Data.Maybe
-import qualified Data.ByteString.Char8 as BSC
-
--- | Get fresh unique number
-freshUnique :: G Int
-freshUnique = do
-  id_gen <- State.gets gsId
-  liftIO $ do
-    -- no need for atomicFetchAdd as we don't use threads in G
-    v <- readFastMutInt id_gen
-    writeFastMutInt id_gen (v+1)
-    pure v
-
--- | Get fresh local Ident of the form: h$$unit:module_uniq
-freshIdent :: G Ident
-freshIdent = do
-  i <- freshUnique
-  mod <- State.gets gsModule
-  let !name = mkFreshJsSymbol mod i
-  return (TxtI name)
-
-
--- | Generate unique Ident for the given ID (uncached!)
---
--- The ident has the following forms:
---
---    global Id: h$unit:module.name[_num][_type_suffix]
---    local Id: h$$unit:module.name[_num][_type_suffix]_uniq
---
--- Note that the string is z-encoded except for "_" delimiters.
---
--- Optional "_type_suffix" can be:
---  - "_e" for IdEntry
---  - "_con_e" for IdConEntry
---
--- Optional "_num" is passed as an argument to this function. It is used for
--- Haskell Ids that require several JS variables: e.g. 64-bit numbers (Word64#,
--- Int64#), Addr#, StablePtr#, unboxed tuples, etc.
---
-makeIdentForId :: Id -> Maybe Int -> IdType -> Module -> Ident
-makeIdentForId i num id_type current_module = TxtI ident
-  where
-    exported = isExportedId i
-    name     = getName i
-    mod
-      | exported
-      , Just m <- nameModule_maybe name
-      = m
-      | otherwise
-      = current_module
-
-    !ident   = mkFastStringByteString $ mconcat
-      [ mkJsSymbolBS exported mod (occNameFS (nameOccName name))
-
-        -------------
-        -- suffixes
-
-        -- suffix for Ids represented with more than one JS var ("_0", "_1", etc.)
-      , case num of
-          Nothing -> mempty
-          Just v  -> mconcat [BSC.pack "_", intBS v]
-
-        -- suffix for entry and constructor entry
-      , case id_type of
-          IdPlain    -> mempty
-          IdEntry    -> BSC.pack "_e"
-          IdConEntry -> BSC.pack "_con_e"
-
-        -- unique suffix for non-exported Ids
-      , if exported
-          then mempty
-          else let (c,u) = unpkUnique (getUnique i)
-               in mconcat [BSC.pack ['_',c,'_'], intBS u]
-      ]
-
--- | Retrieve the cached Ident for the given Id if there is one. Otherwise make
--- a new one with 'makeIdentForId' and cache it.
-cachedIdentForId :: Id -> Maybe Int -> IdType -> G Ident
-cachedIdentForId i mi id_type = do
-
-  -- compute key
-  let !key = IdKey (getKey . getUnique $ i) (fromMaybe 0 mi) id_type
-
-  -- lookup Ident in the Ident cache
-  IdCache cache <- State.gets gsIdents
-  ident <- case M.lookup key cache of
-    Just ident -> pure ident
-    Nothing -> do
-      mod <- State.gets gsModule
-      let !ident  = makeIdentForId i mi id_type mod
-      let !cache' = IdCache (M.insert key ident cache)
-      State.modify (\s -> s { gsIdents = cache' })
-      pure ident
-
-  -- Now update the GlobalId cache, if required
-
-  let update_global_cache = isGlobalId i && isNothing mi && id_type == IdPlain
-      -- fixme also allow caching entries for lifting?
-
-  when (update_global_cache) $ do
-    GlobalIdCache gidc <- getGlobalIdCache
-    case elemUFM ident gidc of
-      False -> setGlobalIdCache $ GlobalIdCache (addToUFM gidc ident (key, i))
-      True  -> pure ()
-
-  pure ident
-
--- | Retrieve default Ident for the given Id
-identForId :: Id -> G Ident
-identForId i = cachedIdentForId i Nothing IdPlain
-
--- | Retrieve default Ident for the given Id with sub index
---
--- Some types, Word64, Addr#, unboxed tuple have more than one corresponding JS
--- var, hence we use the sub index to identify each subpart / JS variable.
-identForIdN :: Id -> Int -> G Ident
-identForIdN i n = cachedIdentForId i (Just n) IdPlain
-
--- | Retrieve all the idents for the given Id.
-identsForId :: Id -> G [Ident]
-identsForId i = case typeSize (idType i) of
-  0 -> pure mempty
-  1 -> (:[]) <$> identForId i
-  s -> mapM (identForIdN i) [1..s]
-
-
--- | Retrieve entry Ident for the given Id
-identForEntryId :: Id -> G Ident
-identForEntryId i = cachedIdentForId i Nothing IdEntry
-
--- | Retrieve datacon entry Ident for the given Id
---
--- Different name than the datacon wrapper.
-identForDataConEntryId :: Id -> G Ident
-identForDataConEntryId i = cachedIdentForId i Nothing IdConEntry
-
-
--- | Retrieve default variable name for the given Id
-varForId :: Id -> G JExpr
-varForId i = toJExpr <$> identForId i
-
--- | Retrieve default variable name for the given Id with sub index
-varForIdN :: Id -> Int -> G JExpr
-varForIdN i n = toJExpr <$> identForIdN i n
-
--- | Retrieve all the JS vars for the given Id
-varsForId :: Id -> G [JExpr]
-varsForId i = case typeSize (idType i) of
-  0 -> pure mempty
-  1 -> (:[]) <$> varForId i
-  s -> mapM (varForIdN i) [1..s]
-
-
--- | Retrieve entry variable name for the given Id
-varForEntryId :: Id -> G JExpr
-varForEntryId i = toJExpr <$> identForEntryId i
-
--- | Retrieve datacon entry variable name for the given Id
-varForDataConEntryId :: Id -> G JExpr
-varForDataConEntryId i = ValExpr . JVar <$> identForDataConEntryId i
-
-
--- | Retrieve datacon worker entry variable name for the given datacon
-identForDataConWorker :: DataCon -> G Ident
-identForDataConWorker d = identForDataConEntryId (dataConWorkId d)
-
--- | Retrieve datacon worker entry variable name for the given datacon
-varForDataConWorker :: DataCon -> G JExpr
-varForDataConWorker d = varForDataConEntryId (dataConWorkId d)
-
--- | Declare all js vars for the id
-declVarsForId :: Id -> G JStat
-declVarsForId  i = case typeSize (idType i) of
-  0 -> return mempty
-  1 -> decl <$> identForId i
-  s -> mconcat <$> mapM (\n -> decl <$> identForIdN i n) [1..s]
-
diff --git a/compiler/GHC/StgToJS/Linker/Linker.hs b/compiler/GHC/StgToJS/Linker/Linker.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Linker/Linker.hs
+++ /dev/null
@@ -1,953 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections     #-}
-{-# LANGUAGE LambdaCase        #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.StgToJS.Linker.Linker
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
--- GHCJS linker, collects dependencies from the object files
--- which contain linkable units with dependency information
---
------------------------------------------------------------------------------
-
-module GHC.StgToJS.Linker.Linker
-  ( jsLinkBinary
-  , embedJsFile
-  )
-where
-
-import Prelude
-
-import GHC.Platform.Host (hostPlatformArchOS)
-
-import GHC.JS.Make
-import GHC.JS.Syntax
-
-import GHC.Driver.Session (DynFlags(..))
-import Language.Haskell.Syntax.Module.Name
-import GHC.SysTools.Cpp
-import GHC.SysTools
-
-import GHC.Linker.Static.Utils (exeFileName)
-
-import GHC.StgToJS.Linker.Types
-import GHC.StgToJS.Linker.Utils
-import GHC.StgToJS.Rts.Rts
-import GHC.StgToJS.Object
-import GHC.StgToJS.Types hiding (LinkableUnit)
-import GHC.StgToJS.Symbols
-import GHC.StgToJS.Printer
-import GHC.StgToJS.Arg
-import GHC.StgToJS.Closure
-
-import GHC.Unit.State
-import GHC.Unit.Env
-import GHC.Unit.Home
-import GHC.Unit.Types
-import GHC.Unit.Module (moduleStableString)
-
-import GHC.Utils.Outputable hiding ((<>))
-import GHC.Utils.Panic
-import GHC.Utils.Error
-import GHC.Utils.Logger (Logger, logVerbAtLeast)
-import GHC.Utils.Binary
-import qualified GHC.Utils.Ppr as Ppr
-import GHC.Utils.Monad
-import GHC.Utils.TmpFs
-
-import GHC.Types.Unique.Set
-
-import qualified GHC.SysTools.Ar          as Ar
-
-import qualified GHC.Data.ShortText as ST
-import GHC.Data.FastString
-
-import Control.Concurrent.MVar
-import Control.Monad
-
-import Data.Array
-import qualified Data.ByteString          as B
-import qualified Data.ByteString.Char8    as BC
-import qualified Data.ByteString.Lazy.Char8 as BLC
-import qualified Data.ByteString.Lazy     as BL
-import qualified Data.ByteString          as BS
-import Data.Function            (on)
-import Data.IntSet              (IntSet)
-import qualified Data.IntSet              as IS
-import Data.IORef
-import Data.List  ( partition, nub, intercalate, group, sort
-                  , groupBy, intersperse,
-                  )
-import Data.Map.Strict          (Map)
-import qualified Data.Map.Strict          as M
-import Data.Maybe
-import Data.Set                 (Set)
-import qualified Data.Set                 as S
-import Data.Word
-
-import System.IO
-import System.FilePath ((<.>), (</>), dropExtension, takeDirectory)
-import System.Directory ( createDirectoryIfMissing
-                        , doesFileExist
-                        , getCurrentDirectory
-                        , Permissions(..)
-                        , setPermissions
-                        , getPermissions
-                        )
-
-data LinkerStats = LinkerStats
-  { bytesPerModule     :: !(Map Module Word64) -- ^ number of bytes linked per module
-  , packedMetaDataSize :: !Word64              -- ^ number of bytes for metadata
-  }
-
-newtype ArchiveState = ArchiveState { loadedArchives :: IORef (Map FilePath Ar.Archive) }
-
-emptyArchiveState :: IO ArchiveState
-emptyArchiveState = ArchiveState <$> newIORef M.empty
-
-jsLinkBinary
-  :: JSLinkConfig
-  -> StgToJSConfig
-  -> [FilePath]
-  -> Logger
-  -> DynFlags
-  -> UnitEnv
-  -> [FilePath]
-  -> [UnitId]
-  -> IO ()
-jsLinkBinary lc_cfg cfg js_srcs logger dflags u_env objs dep_pkgs
-  | lcNoJSExecutables lc_cfg = return ()
-  | otherwise = do
-    -- additional objects to link are passed as FileOption ldInputs...
-    let cmdline_objs = [ f | FileOption _ f <- ldInputs dflags ]
-    -- discriminate JavaScript sources from real object files.
-    (cmdline_js_srcs, cmdline_js_objs) <- partitionM isJsFile cmdline_objs
-    let
-        objs'    = map ObjFile (objs ++ cmdline_js_objs)
-        js_srcs' = js_srcs ++ cmdline_js_srcs
-        isRoot _ = True
-        exe      = jsExeFileName dflags
-
-    void $ link lc_cfg cfg logger u_env exe mempty dep_pkgs objs' js_srcs' isRoot mempty
-
--- | link and write result to disk (jsexe directory)
-link :: JSLinkConfig
-     -> StgToJSConfig
-     -> Logger
-     -> UnitEnv
-     -> FilePath               -- ^ output file/directory
-     -> [FilePath]             -- ^ include path for home package
-     -> [UnitId]               -- ^ packages to link
-     -> [LinkedObj]            -- ^ the object files we're linking
-     -> [FilePath]             -- ^ extra js files to include
-     -> (ExportedFun -> Bool)  -- ^ functions from the objects to use as roots (include all their deps)
-     -> Set ExportedFun        -- ^ extra symbols to link in
-     -> IO ()
-link lc_cfg cfg logger unit_env out _include units objFiles jsFiles isRootFun extraStaticDeps = do
-
-      -- create output directory
-      createDirectoryIfMissing False out
-
-      -------------------------------------------------------------
-      -- link all Haskell code (program + dependencies) into out.js
-
-      -- compute dependencies
-      (dep_map, dep_units, all_deps, _rts_wired_functions, dep_archives)
-        <- computeLinkDependencies cfg logger out unit_env units objFiles extraStaticDeps isRootFun
-
-      -- retrieve code for dependencies
-      mods <- collectDeps dep_map dep_units all_deps
-
-      -- LTO + rendering of JS code
-      link_stats <- withBinaryFile (out </> "out.js") WriteMode $ \h ->
-        renderLinker h mods jsFiles
-
-      -------------------------------------------------------------
-
-      -- dump foreign references file (.frefs)
-      unless (lcOnlyOut lc_cfg) $ do
-        let frefsFile  = "out.frefs"
-            -- frefs      = concatMap mc_frefs mods
-            jsonFrefs  = mempty -- FIXME: toJson frefs
-
-        BL.writeFile (out </> frefsFile <.> "json") jsonFrefs
-        BL.writeFile (out </> frefsFile <.> "js")
-                     ("h$checkForeignRefs(" <> jsonFrefs <> ");")
-
-      -- dump stats
-      unless (lcNoStats lc_cfg) $ do
-        let statsFile = "out.stats"
-        writeFile (out </> statsFile) (renderLinkerStats link_stats)
-
-      -- link generated RTS parts into rts.js
-      unless (lcNoRts lc_cfg) $ do
-        BL.writeFile (out </> "rts.js") ( BLC.pack rtsDeclsText
-                                         <> BLC.pack (rtsText cfg))
-
-      -- link dependencies' JS files into lib.js
-      withBinaryFile (out </> "lib.js") WriteMode $ \h -> do
-        forM_ dep_archives $ \archive_file -> do
-          Ar.Archive entries <- Ar.loadAr archive_file
-          forM_ entries $ \entry -> do
-            case getJsArchiveEntry entry of
-              Nothing -> return ()
-              Just bs -> do
-                B.hPut   h bs
-                hPutChar h '\n'
-
-      -- link everything together into all.js
-      when (generateAllJs lc_cfg) $ do
-        _ <- combineFiles lc_cfg out
-        writeHtml    out
-        writeRunMain out
-        writeRunner lc_cfg out
-        writeExterns out
-
-
-computeLinkDependencies
-  :: StgToJSConfig
-  -> Logger
-  -> String
-  -> UnitEnv
-  -> [UnitId]
-  -> [LinkedObj]
-  -> Set ExportedFun
-  -> (ExportedFun -> Bool)
-  -> IO (Map Module (Deps, DepsLocation), [UnitId], Set LinkableUnit, Set ExportedFun, [FilePath])
-computeLinkDependencies cfg logger target unit_env units objFiles extraStaticDeps isRootFun = do
-
-  (objDepsMap, objRequiredUnits) <- loadObjDeps objFiles
-
-  let roots    = S.fromList . filter isRootFun $ concatMap (M.keys . depsHaskellExported . fst) (M.elems objDepsMap)
-      rootMods = map (moduleNameString . moduleName . head) . group . sort . map funModule . S.toList $ roots
-      objPkgs  = map moduleUnitId $ nub (M.keys objDepsMap)
-
-  when (logVerbAtLeast logger 2) $ void $ do
-    compilationProgressMsg logger $ hcat
-      [ text "Linking ", text target, text " (", text (intercalate "," rootMods), char ')' ]
-    compilationProgressMsg logger $ hcat
-      [ text "objDepsMap ", ppr objDepsMap ]
-    compilationProgressMsg logger $ hcat
-      [ text "objFiles ", ppr objFiles ]
-
-  let (rts_wired_units, rts_wired_functions) = rtsDeps units
-
-  -- all the units we want to link together, without their dependencies
-  let root_units = filter (/= mainUnitId)
-                   $ nub
-                   $ rts_wired_units ++ reverse objPkgs ++ reverse units
-
-  -- all the units we want to link together, including their dependencies,
-  -- preload units, and backpack instantiations
-  all_units_infos <- mayThrowUnitErr (preloadUnitsInfo' unit_env root_units)
-
-  let all_units = fmap unitId all_units_infos
-
-  dep_archives <- getPackageArchives cfg unit_env all_units
-  env <- newGhcjsEnv
-  (archsDepsMap, archsRequiredUnits) <- loadArchiveDeps env dep_archives
-
-  when (logVerbAtLeast logger 2) $
-    logInfo logger $ hang (text "Linking with archives:") 2 (vcat (fmap text dep_archives))
-
-  -- compute dependencies
-  let dep_units      = all_units ++ [homeUnitId (ue_unsafeHomeUnit $ unit_env)]
-      dep_map        = objDepsMap `M.union` archsDepsMap
-      excluded_units = S.empty
-      dep_fun_roots  = roots `S.union` rts_wired_functions `S.union` extraStaticDeps
-      dep_unit_roots = archsRequiredUnits ++ objRequiredUnits
-
-  all_deps <- getDeps (fmap fst dep_map) excluded_units dep_fun_roots dep_unit_roots
-
-  when (logVerbAtLeast logger 2) $
-    logInfo logger $ hang (text "Units to link:") 2 (vcat (fmap ppr dep_units))
-    -- logInfo logger $ hang (text "All deps:") 2 (vcat (fmap ppr (S.toList all_deps)))
-
-  return (dep_map, dep_units, all_deps, rts_wired_functions, dep_archives)
-
-
--- | Compiled module
-data ModuleCode = ModuleCode
-  { mc_module   :: !Module
-  , mc_js_code  :: !JStat
-  , mc_exports  :: !B.ByteString        -- ^ rendered exports
-  , mc_closures :: ![ClosureInfo]
-  , mc_statics  :: ![StaticInfo]
-  , mc_frefs    :: ![ForeignJSRef]
-  }
-
--- | ModuleCode after link with other modules.
---
--- It contains less information than ModuleCode because they have been commoned
--- up into global "metadata" for the whole link.
-data CompactedModuleCode = CompactedModuleCode
-  { cmc_module  :: !Module
-  , cmc_js_code :: !JStat
-  , cmc_exports :: !B.ByteString        -- ^ rendered exports
-  }
-
--- | Link modules and pretty-print them into the given Handle
-renderLinker
-  :: Handle
-  -> [ModuleCode] -- ^ linked code per module
-  -> [FilePath]   -- ^ additional JS files
-  -> IO LinkerStats
-renderLinker h mods jsFiles = do
-
-  -- link modules
-  let (compacted_mods, meta) = linkModules mods
-
-  let
-    putBS   = B.hPut h
-    putJS x = do
-      before <- hTell h
-      Ppr.printLeftRender h (pretty x)
-      hPutChar h '\n'
-      after <- hTell h
-      pure $! (after - before)
-
-  ---------------------------------------------------------
-  -- Pretty-print JavaScript code for all the dependencies.
-  --
-  -- We have to pretty-print at link time because we want to be able to perform
-  -- global link-time optimisations (e.g. renamings) on the whole generated JS
-  -- file.
-
-  -- modules themselves
-  mod_sizes <- forM compacted_mods $ \m -> do
-    !mod_size <- fromIntegral <$> putJS (cmc_js_code m)
-    let !mod_mod  = cmc_module m
-    pure (mod_mod, mod_size)
-
-  -- commoned up metadata
-  !meta_length <- fromIntegral <$> putJS meta
-
-  -- module exports
-  mapM_ (putBS . cmc_exports) compacted_mods
-
-  -- explicit additional JS files
-  mapM_ (\i -> B.readFile i >>= putBS) jsFiles
-
-  -- stats
-  let link_stats = LinkerStats
-        { bytesPerModule     = M.fromList mod_sizes
-        , packedMetaDataSize = meta_length
-        }
-
-  pure link_stats
-
--- | Render linker stats
-renderLinkerStats :: LinkerStats -> String
-renderLinkerStats s =
-  intercalate "\n\n" [meta_stats, package_stats, module_stats] <> "\n\n"
-  where
-    meta = packedMetaDataSize s
-    meta_stats = "number of modules: " <> show (length bytes_per_mod)
-                 <> "\npacked metadata:   " <> show meta
-
-    bytes_per_mod = M.toList $ bytesPerModule s
-
-    show_unit (UnitId fs) = unpackFS fs
-
-    ps :: Map UnitId Word64
-    ps = M.fromListWith (+) . map (\(m,s) -> (moduleUnitId m,s)) $ bytes_per_mod
-
-    pad :: Int -> String -> String
-    pad n t = let l = length t
-              in  if l < n then t <> replicate (n-l) ' ' else t
-
-    pkgMods :: [[(Module,Word64)]]
-    pkgMods = groupBy ((==) `on` (moduleUnitId . fst)) bytes_per_mod
-
-    showMod :: (Module, Word64) -> String
-    showMod (m,s) = pad 40 ("    " <> moduleStableString m <> ":") <> show s <> "\n"
-
-    package_stats :: String
-    package_stats = "code size summary per package (in bytes):\n\n"
-                     <> concatMap (\(p,s) -> pad 25 (show_unit p <> ":") <> show s <> "\n") (M.toList ps)
-
-    module_stats :: String
-    module_stats = "code size per module (in bytes):\n\n" <> unlines (map (concatMap showMod) pkgMods)
-
-
-getPackageArchives :: StgToJSConfig -> UnitEnv -> [UnitId] -> IO [FilePath]
-getPackageArchives cfg unit_env units =
-  filterM doesFileExist [ ST.unpack p </> "lib" ++ ST.unpack l ++ profSuff <.> "a"
-                        | u <- units
-                        , p <- getInstalledPackageLibDirs ue_state u
-                        , l <- getInstalledPackageHsLibs  ue_state u
-                        ]
-  where
-    ue_state = ue_units unit_env
-
-    -- XXX the profiling library name is probably wrong now
-    profSuff | csProf cfg = "_p"
-             | otherwise  = ""
-
-
--- | Combine rts.js, lib.js, out.js to all.js that can be run
--- directly with node.js or SpiderMonkey jsshell
-combineFiles :: JSLinkConfig
-             -> FilePath
-             -> IO ()
-combineFiles cfg fp = do
-  let files = map (fp </>) ["rts.js", "lib.js", "out.js"]
-  withBinaryFile (fp </> "all.js") WriteMode $ \h -> do
-    let cpy i = B.readFile i >>= B.hPut h
-    mapM_ cpy files
-    unless (lcNoHsMain cfg) $ do
-      B.hPut h runMainJS
-
--- | write the index.html file that loads the program if it does not exit
-writeHtml
-  :: FilePath -- ^ output directory
-  -> IO ()
-writeHtml out = do
-  let htmlFile = out </> "index.html"
-  e <- doesFileExist htmlFile
-  unless e $
-    B.writeFile htmlFile templateHtml
-
-
-templateHtml :: B.ByteString
-templateHtml =
-  "<!DOCTYPE html>\n\
-  \<html>\n\
-  \  <head>\n\
-  \  </head>\n\
-  \  <body>\n\
-  \  </body>\n\
-  \  <script language=\"javascript\" src=\"all.js\" defer></script>\n\
-  \</html>"
-
--- | write the runmain.js file that will be run with defer so that it runs after
--- index.html is loaded
-writeRunMain
-  :: FilePath -- ^ output directory
-  -> IO ()
-writeRunMain out = do
-  let runMainFile = out </> "runmain.js"
-  e <- doesFileExist runMainFile
-  unless e $
-    B.writeFile runMainFile runMainJS
-
-runMainJS :: B.ByteString
-runMainJS = "h$main(h$mainZCZCMainzimain);\n"
-
-writeRunner :: JSLinkConfig -- ^ Settings
-            -> FilePath     -- ^ Output directory
-            -> IO ()
-writeRunner _settings out = do
-  cd    <- getCurrentDirectory
-  let arch_os = hostPlatformArchOS
-  let runner  = cd </> exeFileName arch_os False (Just (dropExtension out))
-      srcFile = out </> "all" <.> "js"
-      nodePgm :: B.ByteString
-      nodePgm = "node"
-  src <- B.readFile (cd </> srcFile)
-  B.writeFile runner ("#!/usr/bin/env " <> nodePgm <> "\n" <> src)
-  perms <- getPermissions runner
-  setPermissions runner (perms {executable = True})
-
-rtsExterns :: FastString
-rtsExterns =
-  "// GHCJS RTS externs for closure compiler ADVANCED_OPTIMIZATIONS\n\n" <>
-  mconcat (map (\x -> "/** @type {*} */\nObject.d" <> mkFastString (show x) <> ";\n")
-               [(7::Int)..16384])
-
-writeExterns :: FilePath -> IO ()
-writeExterns out = writeFile (out </> "all.js.externs")
-  $ unpackFS rtsExterns
-
--- | get all dependencies for a given set of roots
-getDeps :: Map Module Deps  -- ^ loaded deps
-        -> Set LinkableUnit -- ^ don't link these blocks
-        -> Set ExportedFun  -- ^ start here
-        -> [LinkableUnit]   -- ^ and also link these
-        -> IO (Set LinkableUnit)
-getDeps loaded_deps base fun startlu = go' S.empty (S.fromList startlu) (S.toList fun)
-  where
-    go :: Set LinkableUnit
-       -> Set LinkableUnit
-       -> IO (Set LinkableUnit)
-    go result open = case S.minView open of
-      Nothing -> return result
-      Just (lu@(lmod,n), open') ->
-          case M.lookup lmod loaded_deps of
-            Nothing -> pprPanic "getDeps.go: object file not loaded for:  " (pprModule lmod)
-            Just (Deps _ _ _ b) ->
-              let block = b!n
-                  result' = S.insert lu result
-              in go' result'
-                 (addOpen result' open' $
-                   map (lmod,) (blockBlockDeps block)) (blockFunDeps block)
-
-    go' :: Set LinkableUnit
-        -> Set LinkableUnit
-        -> [ExportedFun]
-        -> IO (Set LinkableUnit)
-    go' result open [] = go result open
-    go' result open (f:fs) =
-        let key = funModule f
-        in  case M.lookup key loaded_deps of
-              Nothing -> pprPanic "getDeps.go': object file not loaded for:  " $ pprModule key
-              Just (Deps _m _r e _b) ->
-                 let lun :: Int
-                     lun = fromMaybe (pprPanic "exported function not found: " $ ppr f)
-                                     (M.lookup f e)
-                     lu  = (key, lun)
-                 in  go' result (addOpen result open [lu]) fs
-
-    addOpen :: Set LinkableUnit -> Set LinkableUnit -> [LinkableUnit]
-            -> Set LinkableUnit
-    addOpen result open newUnits =
-      let alreadyLinked s = S.member s result ||
-                            S.member s open   ||
-                            S.member s base
-      in  open `S.union` S.fromList (filter (not . alreadyLinked) newUnits)
-
--- | collect dependencies for a set of roots
-collectDeps :: Map Module (Deps, DepsLocation) -- ^ Dependency map
-            -> [UnitId]                        -- ^ packages, code linked in this order
-            -> Set LinkableUnit                -- ^ All dependencides
-            -> IO [ModuleCode]
-collectDeps mod_deps packages all_deps = do
-
-  -- read ghc-prim first, since we depend on that for static initialization
-  let packages' = uncurry (++) $ partition (== primUnitId) (nub packages)
-
-      units_by_module :: Map Module IntSet
-      units_by_module = M.fromListWith IS.union $
-                      map (\(m,n) -> (m, IS.singleton n)) (S.toList all_deps)
-
-      mod_deps_bypkg :: Map UnitId [(Deps, DepsLocation)]
-      mod_deps_bypkg = M.fromListWith (++)
-                        (map (\(m,v) -> (moduleUnitId m,[v])) (M.toList mod_deps))
-
-  ar_state <- emptyArchiveState
-  fmap (catMaybes . concat) . forM packages' $ \pkg ->
-    mapM (uncurry $ extractDeps ar_state units_by_module)
-         (fromMaybe [] $ M.lookup pkg mod_deps_bypkg)
-
-extractDeps :: ArchiveState
-            -> Map Module IntSet
-            -> Deps
-            -> DepsLocation
-            -> IO (Maybe ModuleCode)
-extractDeps ar_state units deps loc =
-  case M.lookup mod units of
-    Nothing       -> return Nothing
-    Just mod_units -> Just <$> do
-      let selector n _  = fromIntegral n `IS.member` mod_units || isGlobalUnit (fromIntegral n)
-      case loc of
-        ObjectFile fp -> do
-          us <- readObjectUnits fp selector
-          pure (collectCode us)
-        ArchiveFile a -> do
-          obj <- readArObject ar_state mod a
-          us <- getObjectUnits obj selector
-          pure (collectCode us)
-        InMemory _n obj -> do
-          us <- getObjectUnits obj selector
-          pure (collectCode us)
-  where
-    mod           = depsModule deps
-    newline       = BC.pack "\n"
-    mk_exports    = mconcat . intersperse newline . filter (not . BS.null) . map oiRaw
-    mk_js_code    = mconcat . map oiStat
-    collectCode l = ModuleCode
-                      { mc_module   = mod
-                      , mc_js_code  = mk_js_code l
-                      , mc_exports  = mk_exports l
-                      , mc_closures = concatMap oiClInfo l
-                      , mc_statics  = concatMap oiStatic l
-                      , mc_frefs    = concatMap oiFImports l
-                      }
-
-readArObject :: ArchiveState -> Module -> FilePath -> IO Object
-readArObject ar_state mod ar_file = do
-  loaded_ars <- readIORef (loadedArchives ar_state)
-  (Ar.Archive entries) <- case M.lookup ar_file loaded_ars of
-    Just a -> pure a
-    Nothing -> do
-      a <- Ar.loadAr ar_file
-      modifyIORef (loadedArchives ar_state) (M.insert ar_file a)
-      pure a
-
-  -- look for the right object in archive
-  let go_entries = \case
-        -- XXX this shouldn't be an exception probably
-        [] -> panic $ "could not find object for module "
-                      ++ moduleNameString (moduleName mod)
-                      ++ " in "
-                      ++ ar_file
-
-        (e:es) -> do
-          let bs = Ar.filedata e
-          bh <- unsafeUnpackBinBuffer bs
-          getObjectHeader bh >>= \case
-            Left _         -> go_entries es -- not a valid object entry
-            Right mod_name
-              | mod_name /= moduleName mod
-              -> go_entries es -- not the module we're looking for
-              | otherwise
-              -> getObjectBody bh mod_name -- found it
-
-  go_entries entries
-
-
--- | A helper function to read system dependencies that are hardcoded
-diffDeps
-  :: [UnitId]                    -- ^ Packages that are already Linked
-  -> ([UnitId], Set ExportedFun) -- ^ New units and functions to link
-  -> ([UnitId], Set ExportedFun) -- ^ Diff
-diffDeps pkgs (deps_pkgs,deps_funs) =
-  ( filter   linked_pkg deps_pkgs
-  , S.filter linked_fun deps_funs
-  )
-  where
-    linked_fun f = moduleUnitId (funModule f) `S.member` linked_pkgs
-    linked_pkg p = S.member p linked_pkgs
-    linked_pkgs  = S.fromList pkgs
-
--- | dependencies for the RTS, these need to be always linked
-rtsDeps :: [UnitId] -> ([UnitId], Set ExportedFun)
-rtsDeps pkgs = diffDeps pkgs $
-  ( [baseUnitId, primUnitId]
-  , S.fromList $ concat
-      [ mkBaseFuns "GHC.Conc.Sync"
-          ["reportError"]
-      , mkBaseFuns "Control.Exception.Base"
-          ["nonTermination"]
-      , mkBaseFuns "GHC.Exception.Type"
-          [ "SomeException"
-          , "underflowException"
-          , "overflowException"
-          , "divZeroException"
-          ]
-      , mkBaseFuns "GHC.TopHandler"
-          [ "runMainIO"
-          , "topHandler"
-          ]
-      , mkBaseFuns "GHC.Base"
-          ["$fMonadIO"]
-      , mkBaseFuns "GHC.Maybe"
-          [ "Nothing"
-          , "Just"
-          ]
-      , mkBaseFuns "GHC.Ptr"
-          ["Ptr"]
-      , mkBaseFuns "GHC.JS.Prim"
-          [ "JSVal"
-          , "JSException"
-          , "$fShowJSException"
-          , "$fExceptionJSException"
-          , "resolve"
-          , "resolveIO"
-          , "toIO"
-          ]
-      , mkBaseFuns "GHC.JS.Prim.Internal"
-          [ "wouldBlock"
-          , "blockedIndefinitelyOnMVar"
-          , "blockedIndefinitelyOnSTM"
-          , "ignoreException"
-          , "setCurrentThreadResultException"
-          , "setCurrentThreadResultValue"
-          ]
-      , mkPrimFuns "GHC.Types"
-          [ ":"
-          , "[]"
-          ]
-      , mkPrimFuns "GHC.Tuple.Prim"
-          [ "(,)"
-          , "(,,)"
-          , "(,,,)"
-          , "(,,,,)"
-          , "(,,,,,)"
-          , "(,,,,,,)"
-          , "(,,,,,,,)"
-          , "(,,,,,,,,)"
-          , "(,,,,,,,,,)"
-          ]
-      ]
-  )
-
--- | Export the functions in base
-mkBaseFuns :: FastString -> [FastString] -> [ExportedFun]
-mkBaseFuns = mkExportedFuns baseUnitId
-
--- | Export the Prim functions
-mkPrimFuns :: FastString -> [FastString] -> [ExportedFun]
-mkPrimFuns = mkExportedFuns primUnitId
-
--- | Given a @UnitId@, a module name, and a set of symbols in the module,
--- package these into an @ExportedFun@.
-mkExportedFuns :: UnitId -> FastString -> [FastString] -> [ExportedFun]
-mkExportedFuns uid mod_name symbols = map mk_fun symbols
-  where
-    mod        = mkModule (RealUnit (Definite uid)) (mkModuleNameFS mod_name)
-    mk_fun sym = ExportedFun mod (LexicalFastString (mkJsSymbol True mod sym))
-
--- | read all dependency data from the to-be-linked files
-loadObjDeps :: [LinkedObj] -- ^ object files to link
-            -> IO (Map Module (Deps, DepsLocation), [LinkableUnit])
-loadObjDeps objs = (prepareLoadedDeps . catMaybes) <$> mapM readDepsFromObj objs
-
--- | Load dependencies for the Linker from Ar
-loadArchiveDeps :: GhcjsEnv
-                -> [FilePath]
-                -> IO ( Map Module (Deps, DepsLocation)
-                      , [LinkableUnit]
-                      )
-loadArchiveDeps env archives = modifyMVar (linkerArchiveDeps env) $ \m ->
-  case M.lookup archives' m of
-    Just r  -> return (m, r)
-    Nothing -> loadArchiveDeps' archives >>= \r -> return (M.insert archives' r m, r)
-  where
-     archives' = S.fromList archives
-
-loadArchiveDeps' :: [FilePath]
-                 -> IO ( Map Module (Deps, DepsLocation)
-                       , [LinkableUnit]
-                       )
-loadArchiveDeps' archives = do
-  archDeps <- forM archives $ \file -> do
-    (Ar.Archive entries) <- Ar.loadAr file
-    catMaybes <$> mapM (readEntry file) entries
-  return (prepareLoadedDeps $ concat archDeps)
-    where
-      readEntry :: FilePath -> Ar.ArchiveEntry -> IO (Maybe (Deps, DepsLocation))
-      readEntry ar_file ar_entry = do
-          let bs = Ar.filedata ar_entry
-          bh <- unsafeUnpackBinBuffer bs
-          getObjectHeader bh >>= \case
-            Left _         -> pure Nothing -- not a valid object entry
-            Right mod_name -> do
-              obj <- getObjectBody bh mod_name
-              let !deps = objDeps obj
-              pure $ Just (deps, ArchiveFile ar_file)
-
--- | Predicate to check that an entry in Ar is a JS source
--- and to return it without its header
-getJsArchiveEntry :: Ar.ArchiveEntry -> Maybe B.ByteString
-getJsArchiveEntry entry = getJsBS (Ar.filedata entry)
-
--- | Predicate to check that a file is a JS source
-isJsFile :: FilePath -> IO Bool
-isJsFile fp = withBinaryFile fp ReadMode $ \h -> do
-  bs <- B.hGet h jsHeaderLength
-  pure (isJsBS bs)
-
-isJsBS :: B.ByteString -> Bool
-isJsBS bs = isJust (getJsBS bs)
-
--- | Get JS source with its header (if it's one)
-getJsBS :: B.ByteString -> Maybe B.ByteString
-getJsBS bs = B.stripPrefix jsHeader bs
-
--- Header added to JS sources to discriminate them from other object files.
--- They all have .o extension but JS sources have this header.
-jsHeader :: B.ByteString
-jsHeader = "//JavaScript"
-
-jsHeaderLength :: Int
-jsHeaderLength = B.length jsHeader
-
-
-
-prepareLoadedDeps :: [(Deps, DepsLocation)]
-                  -> ( Map Module (Deps, DepsLocation)
-                     , [LinkableUnit]
-                     )
-prepareLoadedDeps deps =
-  let req     = concatMap (requiredUnits . fst) deps
-      depsMap = M.fromList $ map (\d -> (depsModule (fst d), d)) deps
-  in  (depsMap, req)
-
-requiredUnits :: Deps -> [LinkableUnit]
-requiredUnits d = map (depsModule d,) (IS.toList $ depsRequired d)
-
--- | read dependencies from an object that might have already been into memory
--- pulls in all Deps from an archive
-readDepsFromObj :: LinkedObj -> IO (Maybe (Deps, DepsLocation))
-readDepsFromObj = \case
-  ObjLoaded name obj -> do
-    let !deps = objDeps obj
-    pure $ Just (deps,InMemory name obj)
-  ObjFile file -> do
-    readObjectDeps file >>= \case
-      Nothing   -> pure Nothing
-      Just deps -> pure $ Just (deps,ObjectFile file)
-
-
--- | Embed a JS file into a .o file
---
--- The JS file is merely copied into a .o file with an additional header
--- ("//Javascript") in order to be recognized later on.
---
--- JS files may contain option pragmas of the form: //#OPTIONS:
--- For now, only the CPP option is supported. If the CPP option is set, we
--- append some common CPP definitions to the file and call cpp on it.
-embedJsFile :: Logger -> DynFlags -> TmpFs -> UnitEnv -> FilePath -> FilePath -> IO ()
-embedJsFile logger dflags tmpfs unit_env input_fn output_fn = do
-  let profiling  = False -- FIXME: add support for profiling way
-
-  createDirectoryIfMissing True (takeDirectory output_fn)
-
-  -- the header lets the linker recognize processed JavaScript files
-  -- But don't add JavaScript header to object files!
-
-  is_js_obj <- if True
-                then pure False
-                else isJsObjectFile input_fn
-                -- FIXME (Sylvain 2022-09): this call makes the
-                -- testsuite go into a loop, I don't know why yet!
-                -- Disabling it for now.
-
-  if is_js_obj
-    then copyWithHeader "" input_fn output_fn
-    else do
-      -- header appended to JS files stored as .o to recognize them.
-      let header = "//JavaScript\n"
-      jsFileNeedsCpp input_fn >>= \case
-        False -> copyWithHeader header input_fn output_fn
-        True  -> do
-
-          -- append common CPP definitions to the .js file.
-          -- They define macros that avoid directly wiring zencoded names
-          -- in RTS JS files
-          pp_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js"
-          payload <- B.readFile input_fn
-          B.writeFile pp_fn (commonCppDefs profiling <> payload)
-
-          -- run CPP on the input JS file
-          js_fn <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js"
-          let
-            cpp_opts = CppOpts
-              { cppUseCc       = True
-              , cppLinePragmas = False -- LINE pragmas aren't JS compatible
-              }
-          doCpp logger
-                  tmpfs
-                  dflags
-                  unit_env
-                  cpp_opts
-                  pp_fn
-                  js_fn
-          -- add header to recognize the object as a JS file
-          copyWithHeader header js_fn output_fn
-
-jsFileNeedsCpp :: FilePath -> IO Bool
-jsFileNeedsCpp fn = do
-  opts <- getOptionsFromJsFile fn
-  pure (CPP `elem` opts)
-
--- | Link module codes.
---
--- Performs link time optimizations and produces one JStat per module plus some
--- commoned up initialization code.
-linkModules :: [ModuleCode] -> ([CompactedModuleCode], JStat)
-linkModules mods = (compact_mods, meta)
-  where
-    compact_mods = map compact mods
-
-    -- here GHCJS used to:
-    --  - deduplicate declarations
-    --  - rename local variables into shorter ones
-    --  - compress initialization data
-    -- but we haven't ported it (yet).
-    compact m = CompactedModuleCode
-      { cmc_js_code = mc_js_code m
-      , cmc_module  = mc_module m
-      , cmc_exports = mc_exports m
-      }
-
-    -- common up statics: different bindings may reference the same statics, we
-    -- filter them here to initialize them once
-    statics = nubStaticInfo (concatMap mc_statics mods)
-
-    infos   = concatMap mc_closures mods
-    meta = mconcat
-            -- render metadata as individual statements
-            [ mconcat (map staticDeclStat statics)
-            , mconcat (map staticInitStat statics)
-            , mconcat (map (closureInfoStat True) infos)
-            ]
-
--- | Only keep a single StaticInfo with a given name
-nubStaticInfo :: [StaticInfo] -> [StaticInfo]
-nubStaticInfo = go emptyUniqSet
-  where
-    go us = \case
-      []     -> []
-      (x:xs) ->
-        -- only match on siVar. There is no reason for the initializing value to
-        -- be different for the same global name.
-        let name = siVar x
-        in if elementOfUniqSet name us
-          then go us xs
-          else x : go (addOneToUniqSet us name) xs
-
--- | Initialize a global object.
---
--- All global objects have to be declared (staticInfoDecl) first.
-staticInitStat :: StaticInfo -> JStat
-staticInitStat (StaticInfo i sv mcc) =
-  case sv of
-    StaticData con args         -> appS "h$sti" $ add_cc_arg
-                                    [ var i
-                                    , var con
-                                    , jsStaticArgs args
-                                    ]
-    StaticFun  f   args         -> appS "h$sti" $ add_cc_arg
-                                    [ var i
-                                    , var f
-                                    , jsStaticArgs args
-                                    ]
-    StaticList args mt          -> appS "h$stl" $ add_cc_arg
-                                    [ var i
-                                    , jsStaticArgs args
-                                    , toJExpr $ maybe null_ (toJExpr . TxtI) mt
-                                    ]
-    StaticThunk (Just (f,args)) -> appS "h$stc" $ add_cc_arg
-                                    [ var i
-                                    , var f
-                                    , jsStaticArgs args
-                                    ]
-    _                           -> mempty
-  where
-    -- add optional cost-center argument
-    add_cc_arg as = case mcc of
-      Nothing -> as
-      Just cc -> as ++ [toJExpr cc]
-
--- | declare and do first-pass init of a global object (create JS object for heap objects)
-staticDeclStat :: StaticInfo -> JStat
-staticDeclStat (StaticInfo global_name static_value _) = decl
-  where
-    global_ident = TxtI global_name
-    decl_init v  = global_ident ||= v
-    decl_no_init = appS "h$di" [toJExpr global_ident]
-
-    decl = case static_value of
-      StaticUnboxed u     -> decl_init (unboxed_expr u)
-      StaticThunk Nothing -> decl_no_init -- CAF initialized in an alternative way
-      _                   -> decl_init (app "h$d" [])
-
-    unboxed_expr = \case
-      StaticUnboxedBool b          -> app "h$p" [toJExpr b]
-      StaticUnboxedInt i           -> app "h$p" [toJExpr i]
-      StaticUnboxedDouble d        -> app "h$p" [toJExpr (unSaneDouble d)]
-      StaticUnboxedString str      -> app "h$rawStringData" [ValExpr (to_byte_list str)]
-      StaticUnboxedStringOffset {} -> 0
-
-    to_byte_list = JList . map (Int . fromIntegral) . BS.unpack
diff --git a/compiler/GHC/StgToJS/Linker/Types.hs b/compiler/GHC/StgToJS/Linker/Types.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Linker/Types.hs
+++ /dev/null
@@ -1,101 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PartialTypeSignatures #-}
-{-# LANGUAGE LambdaCase #-}
-
-{-# OPTIONS_GHC -Wno-orphans #-} -- for Ident's Binary instance
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.StgToJS.Linker.Types
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
------------------------------------------------------------------------------
-
-module GHC.StgToJS.Linker.Types
-  ( GhcjsEnv (..)
-  , newGhcjsEnv
-  , JSLinkConfig (..)
-  , defaultJSLinkConfig
-  , generateAllJs
-  , LinkedObj (..)
-  , LinkableUnit
-  )
-where
-
-import GHC.StgToJS.Object
-
-import GHC.Unit.Types
-import GHC.Utils.Outputable (hsep,Outputable(..),text,ppr)
-
-import Data.Map.Strict      (Map)
-import qualified Data.Map.Strict as M
-import Data.Set             (Set)
-
-import Control.Concurrent.MVar
-
-import System.IO
-
-import Prelude
-
---------------------------------------------------------------------------------
--- Linker Config
---------------------------------------------------------------------------------
-
-data JSLinkConfig = JSLinkConfig
-  { lcNoJSExecutables    :: Bool
-  , lcNoHsMain           :: Bool
-  , lcOnlyOut            :: Bool
-  , lcNoRts              :: Bool
-  , lcNoStats            :: Bool
-  }
-
--- | we generate a runnable all.js only if we link a complete application,
---   no incremental linking and no skipped parts
-generateAllJs :: JSLinkConfig -> Bool
-generateAllJs s = not (lcOnlyOut s) && not (lcNoRts s)
-
-defaultJSLinkConfig :: JSLinkConfig
-defaultJSLinkConfig = JSLinkConfig
-  { lcNoJSExecutables = False
-  , lcNoHsMain        = False
-  , lcOnlyOut         = False
-  , lcNoRts           = False
-  , lcNoStats         = False
-  }
-
---------------------------------------------------------------------------------
--- Linker Environment
---------------------------------------------------------------------------------
-
--- | A @LinkableUnit@ is a pair of a module and the index of the block in the
--- object file
-type LinkableUnit = (Module, Int)
-
--- | An object file that's either already in memory (with name) or on disk
-data LinkedObj
-  = ObjFile   FilePath      -- ^ load from this file
-  | ObjLoaded String Object -- ^ already loaded: description and payload
-
-instance Outputable LinkedObj where
-  ppr = \case
-    ObjFile fp    -> hsep [text "ObjFile", text fp]
-    ObjLoaded s o -> hsep [text "ObjLoaded", text s, ppr (objModuleName o)]
-
-data GhcjsEnv = GhcjsEnv
-  { linkerArchiveDeps :: MVar (Map (Set FilePath)
-                                   (Map Module (Deps, DepsLocation)
-                                   , [LinkableUnit]
-                                   )
-                              )
-  }
-
--- | return a fresh @GhcjsEnv@
-newGhcjsEnv :: IO GhcjsEnv
-newGhcjsEnv = GhcjsEnv <$> newMVar M.empty
diff --git a/compiler/GHC/StgToJS/Linker/Utils.hs b/compiler/GHC/StgToJS/Linker/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Linker/Utils.hs
+++ /dev/null
@@ -1,308 +0,0 @@
-{-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE MultiWayIf  #-}
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.StgToJS.Linker.Utils
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
--- Various utilies used in the JS Linker
---
------------------------------------------------------------------------------
-
-module GHC.StgToJS.Linker.Utils
-  ( getOptionsFromJsFile
-  , JSOption(..)
-  , jsExeFileName
-  , getInstalledPackageLibDirs
-  , getInstalledPackageHsLibs
-  , commonCppDefs
-  )
-where
-
-import           System.FilePath
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as Char8
-import           Data.ByteString (ByteString)
-
-import          GHC.Driver.Session
-
-import          GHC.Data.ShortText
-import          GHC.Unit.State
-import          GHC.Unit.Types
-
-import          GHC.StgToJS.Types
-
-import           Prelude
-import GHC.Platform
-import Data.List (isPrefixOf)
-import System.IO
-import Data.Char (isSpace)
-import qualified Control.Exception as Exception
-
--- | Retrieve library directories provided by the @UnitId@ in @UnitState@
-getInstalledPackageLibDirs :: UnitState -> UnitId -> [ShortText]
-getInstalledPackageLibDirs us = maybe mempty unitLibraryDirs . lookupUnitId us
-
--- | Retrieve the names of the libraries provided by @UnitId@
-getInstalledPackageHsLibs :: UnitState -> UnitId -> [ShortText]
-getInstalledPackageHsLibs us = maybe mempty unitLibraries . lookupUnitId us
-
--- | A constant holding the JavaScript executable Filename extension
-jsexeExtension :: String
-jsexeExtension = "jsexe"
-
--- | CPP definitions that are inserted into every .pp file
-commonCppDefs :: Bool -> ByteString
-commonCppDefs profiling = case profiling of
-  True  -> commonCppDefs_profiled
-  False -> commonCppDefs_vanilla
-
--- | CPP definitions for normal operation and profiling. Use CAFs for
--- commonCppDefs_* so that they are shared for every CPP file
-commonCppDefs_vanilla, commonCppDefs_profiled :: ByteString
-commonCppDefs_vanilla  = genCommonCppDefs False
-commonCppDefs_profiled = genCommonCppDefs True
-
--- | Generate CPP Definitions depending on a profiled or normal build. This
--- occurs at link time.
-genCommonCppDefs :: Bool -> ByteString
-genCommonCppDefs profiling = mconcat
-  [
-  -- constants
-    let mk_int_def n v   = "#define " <> Char8.pack n <> " (" <> Char8.pack (show v) <> ")\n"
-        -- generate "#define CLOSURE_TYPE_xyz (num)" defines
-        mk_closure_def t = mk_int_def (ctJsName t) (ctNum t)
-        closure_defs     = map mk_closure_def [minBound..maxBound]
-        -- generate "#define THREAD_xyz_xyz (num)" defines
-        mk_thread_def t  = mk_int_def (threadStatusJsName t) (threadStatusNum t)
-        thread_defs      = map mk_thread_def [minBound..maxBound]
-    in mconcat (closure_defs ++ thread_defs)
-
-  -- low-level heap object manipulation macros
-  , if profiling
-      then mconcat
-        [ "#define MK_TUP2(x1,x2)                           (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP3(x1,x2,x3)                        (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP4(x1,x2,x3,x4)                     (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP5(x1,x2,x3,x4,x5)                  (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP6(x1,x2,x3,x4,x5,x6)               (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7)            (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8)         (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9)      (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        , "#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"
-        ]
-      else mconcat
-        [ "#define MK_TUP2(x1,x2)                           (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2)))\n"
-        , "#define MK_TUP3(x1,x2,x3)                        (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3)))\n"
-        , "#define MK_TUP4(x1,x2,x3,x4)                     (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4)))\n"
-        , "#define MK_TUP5(x1,x2,x3,x4,x5)                  (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5)))\n"
-        , "#define MK_TUP6(x1,x2,x3,x4,x5,x6)               (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6)))\n"
-        , "#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7)            (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7)))\n"
-        , "#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8)         (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8)))\n"
-        , "#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9)      (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9)))\n"
-        , "#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10)))\n"
-        ]
-
-  , "#define TUP2_1(x) ((x).d1)\n"
-  , "#define TUP2_2(x) ((x).d2)\n"
-
-  -- GHCJS.Prim.JSVal
-  , if profiling
-      then "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x), h$CCS_SYSTEM)\n"
-      else "#define MK_JSVAL(x) (h$baseZCGHCziJSziPrimziJSVal_con_e, (x))\n"
-  ,  "#define JSVAL_VAL(x) ((x).d1)\n"
-
-  -- GHCJS.Prim.JSException
-  , if profiling
-      then "#define MK_JSEXCEPTION(msg,hsMsg) (h$c2(h$baseZCGHCziJSziPrimziJSException_con_e,(msg),(hsMsg),h$CCS_SYSTEM))\n"
-      else "#define MK_JSEXCEPTION(msg,hsMsg) (h$c2(h$baseZCGHCziJSziPrimziJSException_con_e,(msg),(hsMsg)))\n"
-
-  -- Exception dictionary for JSException
-  , "#define HS_JSEXCEPTION_EXCEPTION h$baseZCGHCziJSziPrimzizdfExceptionJSException\n"
-
-  -- SomeException
-  , if profiling
-      then "#define MK_SOMEEXCEPTION(dict,except) (h$c2(h$baseZCGHCziExceptionziTypeziSomeException_con_e,(dict),(except),h$CCS_SYSTEM))\n"
-      else "#define MK_SOMEEXCEPTION(dict,except) (h$c2(h$baseZCGHCziExceptionziTypeziSomeException_con_e,(dict),(except)))\n"
-
-  -- GHC.Ptr.Ptr
-  , if profiling
-      then "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset), h$CCS_SYSTEM))\n"
-      else "#define MK_PTR(val,offset) (h$c2(h$baseZCGHCziPtrziPtr_con_e, (val), (offset)))\n"
-
-  -- Data.Maybe.Maybe
-  , "#define HS_NOTHING h$baseZCGHCziMaybeziNothing\n"
-  , "#define IS_NOTHING(cl) ((cl).f === h$baseZCGHCziMaybeziNothing_con_e)\n"
-  , "#define IS_JUST(cl) ((cl).f === h$baseZCGHCziMaybeziJust_con_e)\n"
-  , "#define JUST_VAL(jj) ((jj).d1)\n"
-  -- "#define HS_NOTHING h$nothing\n"
-  , if profiling
-      then "#define MK_JUST(val) (h$c1(h$baseZCGHCziMaybeziJust_con_e, (val), h$CCS_SYSTEM))\n"
-      else "#define MK_JUST(val) (h$c1(h$baseZCGHCziMaybeziJust_con_e, (val)))\n"
-
-  -- Data.List
-  , "#define HS_NIL h$ghczmprimZCGHCziTypesziZMZN\n"
-  , "#define HS_NIL_CON h$ghczmprimZCGHCziTypesziZMZN_con_e\n"
-  , "#define IS_CONS(cl) ((cl).f === h$ghczmprimZCGHCziTypesziZC_con_e)\n"
-  , "#define IS_NIL(cl) ((cl).f === h$ghczmprimZCGHCziTypesziZMZN_con_e)\n"
-  , "#define CONS_HEAD(cl) ((cl).d1)\n"
-  , "#define CONS_TAIL(cl) ((cl).d2)\n"
-  , if profiling
-      then mconcat
-        [ "#define MK_CONS(head,tail) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail), h$CCS_SYSTEM))\n"
-        , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail), (cc)))\n"
-        ]
-      else mconcat
-        [ "#define MK_CONS(head,tail) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail)))\n"
-        , "#define MK_CONS_CC(head,tail,cc) (h$c2(h$ghczmprimZCGHCziTypesziZC_con_e, (head), (tail)))\n"
-        ]
-
-  -- Data.Text
-  , "#define DATA_TEXT_ARRAY(x) ((x).d1)\n"
-  , "#define DATA_TEXT_OFFSET(x) ((x).d2.d1)\n"
-  , "#define DATA_TEXT_LENGTH(x) ((x).d2.d2)\n"
-
-  -- Data.Text.Lazy
-  , "#define LAZY_TEXT_IS_CHUNK(x) ((x).f.a === 2)\n"
-  , "#define LAZY_TEXT_IS_NIL(x) ((x).f.a === 1)\n"
-  , "#define LAZY_TEXT_CHUNK_HEAD(x) ((x))\n"
-  , "#define LAZY_TEXT_CHUNK_TAIL(x) ((x).d2.d3)\n"
-
-  -- black holes
-  -- can we skip the indirection for black holes?
-  , "#define IS_BLACKHOLE(x) (typeof (x) === 'object' && (x) && (x).f && (x).f.t === CLOSURE_TYPE_BLACKHOLE)\n"
-  , "#define BLACKHOLE_TID(bh) ((bh).d1)\n"
-  , "#define SET_BLACKHOLE_TID(bh,tid) ((bh).d1 = (tid))\n"
-  , "#define BLACKHOLE_QUEUE(bh) ((bh).d2)\n"
-  , "#define SET_BLACKHOLE_QUEUE(bh,val) ((bh).d2 = (val))\n"
-
-  -- resumable thunks
-  , "#define MAKE_RESUMABLE(closure,stack) { (closure).f = h$resume_e; (closure).d1 = (stack), (closure).d2 = null; }\n"
-
-  -- general deconstruction
-  , "#define IS_THUNK(x) ((x).f.t === CLOSURE_TYPE_THUNK)\n"
-  , "#define CONSTR_TAG(x) ((x).f.a)\n"
-
-  -- retrieve a numeric value that's possibly stored as an indirection
-  , "#define IS_WRAPPED_NUMBER(val) ((typeof(val)==='object')&&(val).f === h$unbox_e)\n"
-  , "#define UNWRAP_NUMBER(val) ((typeof(val) === 'number')?(val):(val).d1)\n"
-
-  -- generic lazy values
-  , if profiling
-      then mconcat
-        [ "#define MK_LAZY(fun) (h$c1(h$lazy_e, (fun), h$CCS_SYSTEM))\n"
-        , "#define MK_LAZY_CC(fun,cc) (h$c1(h$lazy_e, (fun), (cc)))\n"
-        ]
-      else mconcat
-        [ "#define MK_LAZY(fun) (h$c1(h$lazy_e, (fun)))\n"
-        , "#define MK_LAZY_CC(fun,cc) (h$c1(h$lazy_e, (fun)))\n"
-        ]
-
-  -- generic data constructors and selectors
-  , if profiling
-      then mconcat
-        [ "#define MK_DATA1_1(val) (h$c1(h$data1_e, (val), h$CCS_SYSTEM))\n"
-        , "#define MK_DATA1_2(val1,val2) (h$c2(h$data1_e, (val1), (val2), h$CCS_SYSTEM))\n"
-        , "#define MK_DATA2_1(val) (h$c1(h$data2_e, (val), h$CCS_SYSTEM))\n"
-        , "#define MK_DATA2_2(val1,val2) (h$c2(h$data1_e, (val1), (val2), h$CCS_SYSTEM))\n"
-        , "#define MK_SELECT1(val) (h$c1(h$select1_e, (val), h$CCS_SYSTEM))\n"
-        , "#define MK_SELECT2(val) (h$c1(h$select2_e, (val), h$CCS_SYSTEM))\n"
-        , "#define MK_AP1(fun,val) (h$c2(h$ap1_e, (fun), (val), h$CCS_SYSTEM))\n"
-        , "#define MK_AP2(fun,val1,val2) (h$c3(h$ap2_e, (fun), (val1), (val2), h$CCS_SYSTEM))\n"
-        , "#define MK_AP3(fun,val1,val2,val3) (h$c4(h$ap3_e, (fun), (val1), (val2), (val3), h$CCS_SYSTEM))\n"
-        ]
-      else mconcat
-        [ "#define MK_DATA1_1(val) (h$c1(h$data1_e, (val)))\n"
-        , "#define MK_DATA1_2(val1,val2) (h$c2(h$data1_e, (val1), (val2)))\n"
-        , "#define MK_DATA2_1(val) (h$c1(h$data2_e, (val)))\n"
-        , "#define MK_DATA2_2(val1,val2) (h$c2(h$data2_e, (val1), (val2)))\n"
-        , "#define MK_SELECT1(val) (h$c1(h$select1_e, (val)))\n"
-        , "#define MK_SELECT2(val) (h$c1(h$select2_e, (val)))\n"
-        , "#define MK_AP1(fun,val) (h$c2(h$ap1_e,(fun),(val)))\n"
-        , "#define MK_AP2(fun,val1,val2) (h$c3(h$ap2_e,(fun),(val1),(val2)))\n"
-        , "#define MK_AP3(fun,val1,val2,val3) (h$c4(h$ap3_e, (fun), (val1), (val2), (val3)))\n"
-        ]
-
-  -- unboxed tuple returns
-  -- , "#define RETURN_UBX_TUP1(x) return x;\n"
-  , "#define RETURN_UBX_TUP2(x1,x2) { h$ret1 = (x2); return (x1); }\n"
-  , "#define RETURN_UBX_TUP3(x1,x2,x3) { h$ret1 = (x2); h$ret2 = (x3); return (x1); }\n"
-  , "#define RETURN_UBX_TUP4(x1,x2,x3,x4) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); return (x1); }\n"
-  , "#define RETURN_UBX_TUP5(x1,x2,x3,x4,x5) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); return (x1); }\n"
-  , "#define RETURN_UBX_TUP6(x1,x2,x3,x4,x5,x6) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); return (x1); }\n"
-  , "#define RETURN_UBX_TUP7(x1,x2,x3,x4,x5,x6,x7) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); return (x1); }\n"
-  , "#define RETURN_UBX_TUP8(x1,x2,x3,x4,x5,x6,x7,x8) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); return (x1); }\n"
-  , "#define RETURN_UBX_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); h$ret8 = (x9); return (x1); }\n"
-  , "#define RETURN_UBX_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) { h$ret1 = (x2); h$ret2 = (x3); h$ret3 = (x4); h$ret4 = (x5); h$ret5 = (x6); h$ret6 = (x7); h$ret7 = (x8); h$ret8 = (x9); h$ret9 = (x10); return (x1); }\n"
-
-  , "#define CALL_UBX_TUP2(r1,r2,c) { (r1) = (c); (r2) = h$ret1; }\n"
-  , "#define CALL_UBX_TUP3(r1,r2,r3,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; }\n"
-  , "#define CALL_UBX_TUP4(r1,r2,r3,r4,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; }\n"
-  , "#define CALL_UBX_TUP5(r1,r2,r3,r4,r5,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; }\n"
-  , "#define CALL_UBX_TUP6(r1,r2,r3,r4,r5,r6,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; }\n"
-  , "#define CALL_UBX_TUP7(r1,r2,r3,r4,r5,r6,r7,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; }\n"
-  , "#define CALL_UBX_TUP8(r1,r2,r3,r4,r5,r6,r7,r8,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; }\n"
-  , "#define CALL_UBX_TUP9(r1,r2,r3,r4,r5,r6,r7,r8,r9,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; (r9) = h$ret8; }\n"
-  , "#define CALL_UBX_TUP10(r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,c) { (r1) = (c); (r2) = h$ret1; (r3) = h$ret2; (r4) = h$ret3; (r5) = h$ret4; (r6) = h$ret5; (r7) = h$ret6; (r8) = h$ret7; (r9) = h$ret8; (r10) = h$ret9; }\n"
-  ]
-
--- | Construct the Filename for the "binary" of Haskell code compiled to
--- JavaScript.
-jsExeFileName :: DynFlags -> FilePath
-jsExeFileName dflags
-  | Just s <- outputFile_ dflags =
-      -- unmunge the extension
-      let s' = dropPrefix "js_" (drop 1 $ takeExtension s)
-      in if Prelude.null s'
-           then dropExtension s <.> jsexeExtension
-           else dropExtension s <.> s'
-  | otherwise =
-      if platformOS (targetPlatform dflags) == OSMinGW32
-           then "main.jsexe"
-           else "a.jsexe"
-  where
-    dropPrefix prefix xs
-      | prefix `isPrefixOf` xs = drop (length prefix) xs
-      | otherwise              = xs
-
-
--- | Parse option pragma in JS file
-getOptionsFromJsFile :: FilePath      -- ^ Input file
-                     -> IO [JSOption] -- ^ Parsed options, if any.
-getOptionsFromJsFile filename
-    = Exception.bracket
-              (openBinaryFile filename ReadMode)
-              hClose
-              getJsOptions
-
-data JSOption = CPP deriving (Eq, Ord)
-
-getJsOptions :: Handle -> IO [JSOption]
-getJsOptions handle = do
-  hSetEncoding handle utf8
-  prefix' <- B.hGet handle prefixLen
-  if prefix == prefix'
-  then parseJsOptions <$> hGetLine handle
-  else pure []
- where
-  prefix :: B.ByteString
-  prefix = "//#OPTIONS:"
-  prefixLen = B.length prefix
-
-parseJsOptions :: String -> [JSOption]
-parseJsOptions xs = go xs
-  where
-    trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
-    go [] = []
-    go xs = let (tok, rest) = break (== ',') xs
-                tok' = trim tok
-                rest' = drop 1 rest
-            in  if | tok' == "CPP" -> CPP : go rest'
-                   | otherwise     -> go rest'
diff --git a/compiler/GHC/StgToJS/Literal.hs b/compiler/GHC/StgToJS/Literal.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Literal.hs
+++ /dev/null
@@ -1,109 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module GHC.StgToJS.Literal
-  ( genLit
-  , genStaticLit
-  )
-where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax
-import GHC.JS.Make
-
-import GHC.StgToJS.Types
-import GHC.StgToJS.Monad
-import GHC.StgToJS.Ids
-import GHC.StgToJS.Symbols
-
-import GHC.Data.FastString
-import GHC.Types.Literal
-import GHC.Types.Basic
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Outputable
-import GHC.Float
-
-import Data.Bits as Bits
-import Data.Char (ord)
-
--- | Generate JS expressions for a Literal
---
--- Literals represented with 2 values:
---  * Addr# (Null and Strings): array and offset
---  * 64-bit values: high 32-bit, low 32-bit
---  * labels: call to h$mkFunctionPtr and 0, or function name and 0
-genLit :: HasDebugCallStack => Literal -> G [JExpr]
-genLit = \case
-  LitChar c     -> return [ toJExpr (ord c) ]
-  LitString str ->
-    freshIdent >>= \strLit@(TxtI strLitT) ->
-      freshIdent >>= \strOff@(TxtI strOffT) -> do
-        emitStatic strLitT (StaticUnboxed (StaticUnboxedString str)) Nothing
-        emitStatic strOffT (StaticUnboxed (StaticUnboxedStringOffset str)) Nothing
-        return [ ValExpr (JVar strLit), ValExpr (JVar strOff) ]
-  LitNullAddr              -> return [ null_, ValExpr (JInt 0) ]
-  LitNumber nt v           -> case nt of
-    LitNumInt     -> return [ toJExpr v ]
-    LitNumInt8    -> return [ toJExpr v ]
-    LitNumInt16   -> return [ toJExpr v ]
-    LitNumInt32   -> return [ toJExpr v ]
-    LitNumInt64   -> return [ toJExpr (Bits.shiftR v 32), toU32Expr v ]
-    LitNumWord    -> return [ toU32Expr v ]
-    LitNumWord8   -> return [ toU32Expr v ]
-    LitNumWord16  -> return [ toU32Expr v ]
-    LitNumWord32  -> return [ toU32Expr v ]
-    LitNumWord64  -> return [ toU32Expr (Bits.shiftR v 32), toU32Expr v ]
-    LitNumBigNat  -> panic "genLit: unexpected BigNat that should have been removed in CorePrep"
-  LitFloat r               -> return [ toJExpr (r2f r) ]
-  LitDouble r              -> return [ toJExpr (r2d r) ]
-  LitLabel name _size fod
-    | fod == IsFunction      -> return [ ApplExpr (var "h$mkFunctionPtr")
-                                                  [var (mkRawSymbol True name)]
-                                       , ValExpr (JInt 0)
-                                       ]
-    | otherwise              -> return [ toJExpr (TxtI (mkRawSymbol True name))
-                                       , ValExpr (JInt 0)
-                                       ]
-  LitRubbish {} -> return [ null_ ]
-
--- | generate a literal for the static init tables
-genStaticLit :: Literal -> G [StaticLit]
-genStaticLit = \case
-  LitChar c                -> return [ IntLit (fromIntegral $ ord c) ]
-  LitString str
-    | True                 -> return [ StringLit (mkFastStringByteString str), IntLit 0]
-    -- \|  invalid UTF8         -> return [ BinLit str, IntLit 0]
-  LitNullAddr              -> return [ NullLit, IntLit 0 ]
-  LitNumber nt v           -> case nt of
-    LitNumInt     -> return [ IntLit v ]
-    LitNumInt8    -> return [ IntLit v ]
-    LitNumInt16   -> return [ IntLit v ]
-    LitNumInt32   -> return [ IntLit v ]
-    LitNumInt64   -> return [ IntLit (v `Bits.shiftR` 32), toU32Lit v ]
-    LitNumWord    -> return [ toU32Lit v ]
-    LitNumWord8   -> return [ toU32Lit v ]
-    LitNumWord16  -> return [ toU32Lit v ]
-    LitNumWord32  -> return [ toU32Lit v ]
-    LitNumWord64  -> return [ toU32Lit (v `Bits.shiftR` 32), toU32Lit v ]
-    LitNumBigNat  -> panic "genStaticLit: unexpected BigNat that should have been removed in CorePrep"
-  LitFloat r               -> return [ DoubleLit . SaneDouble . r2f $ r ]
-  LitDouble r              -> return [ DoubleLit . SaneDouble . r2d $ r ]
-  LitLabel name _size fod  -> return [ LabelLit (fod == IsFunction) (mkRawSymbol True name)
-                                     , IntLit 0 ]
-  l -> pprPanic "genStaticLit" (ppr l)
-
--- make an unsigned 32 bit number from this unsigned one, lower 32 bits
-toU32Expr :: Integer -> JExpr
-toU32Expr i = Int (i Bits..&. 0xFFFFFFFF) .>>>. 0
-
--- make an unsigned 32 bit number from this unsigned one, lower 32 bits
-toU32Lit :: Integer -> StaticLit
-toU32Lit i = IntLit (i Bits..&. 0xFFFFFFFF)
-
-r2d :: Rational -> Double
-r2d = realToFrac
-
-r2f :: Rational -> Double
-r2f = float2Double . realToFrac
diff --git a/compiler/GHC/StgToJS/Monad.hs b/compiler/GHC/StgToJS/Monad.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Monad.hs
+++ /dev/null
@@ -1,183 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
-
--- | JS codegen state monad
-module GHC.StgToJS.Monad
-  ( runG
-  , emitGlobal
-  , addDependency
-  , emitToplevel
-  , emitStatic
-  , emitClosureInfo
-  , emitForeign
-  , assertRtsStat
-  , getSettings
-  , globalOccs
-  , setGlobalIdCache
-  , getGlobalIdCache
-  , GlobalOcc(..)
-  -- * Group
-  , modifyGroup
-  , resetGroup
-  )
-where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax
-import GHC.JS.Transform
-
-import GHC.StgToJS.Types
-
-import GHC.Unit.Module
-import GHC.Stg.Syntax
-
-import GHC.Types.SrcLoc
-import GHC.Types.Id
-import GHC.Types.Unique.FM
-import GHC.Types.ForeignCall
-
-import qualified Control.Monad.Trans.State.Strict as State
-import GHC.Data.FastString
-import GHC.Data.FastMutInt
-
-import qualified Data.Map  as M
-import qualified Data.Set  as S
-import qualified Data.List as L
-
-runG :: StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> G a -> IO a
-runG config m unfloat action = State.evalStateT action =<< initState config m unfloat
-
-initState :: StgToJSConfig -> Module -> UniqFM Id CgStgExpr -> IO GenState
-initState config m unfloat = do
-  id_gen <- newFastMutInt 1
-  pure $ GenState
-    { gsSettings  = config
-    , gsModule    = m
-    , gsId        = id_gen
-    , gsIdents    = emptyIdCache
-    , gsUnfloated = unfloat
-    , gsGroup     = defaultGenGroupState
-    , gsGlobal    = []
-    }
-
-
-modifyGroup :: (GenGroupState -> GenGroupState) -> G ()
-modifyGroup f = State.modify mod_state
-  where
-    mod_state s = s { gsGroup = f (gsGroup s) }
-
--- | emit a global (for the current module) toplevel statement
-emitGlobal :: JStat -> G ()
-emitGlobal stat = State.modify (\s -> s { gsGlobal = stat : gsGlobal s })
-
--- | add a dependency on a particular symbol to the current group
-addDependency :: OtherSymb -> G ()
-addDependency symbol = modifyGroup mod_group
-  where
-    mod_group g = g { ggsExtraDeps = S.insert symbol (ggsExtraDeps g) }
-
--- | emit a top-level statement for the current binding group
-emitToplevel :: JStat -> G ()
-emitToplevel s = modifyGroup mod_group
-  where
-    mod_group g = g { ggsToplevelStats = s : ggsToplevelStats g}
-
--- | emit static data for the binding group
-emitStatic :: FastString -> StaticVal -> Maybe Ident -> G ()
-emitStatic ident val cc = modifyGroup mod_group
-  where
-    mod_group  g = g { ggsStatic = mod_static (ggsStatic g) }
-    mod_static s = StaticInfo ident val cc : s
-
--- | add closure info in our binding group. all heap objects must have closure info
-emitClosureInfo :: ClosureInfo -> G ()
-emitClosureInfo ci = modifyGroup mod_group
-  where
-    mod_group g = g { ggsClosureInfo = ci : ggsClosureInfo g}
-
-emitForeign :: Maybe RealSrcSpan
-            -> FastString
-            -> Safety
-            -> CCallConv
-            -> [FastString]
-            -> FastString
-            -> G ()
-emitForeign mbSpan pat safety cconv arg_tys res_ty = modifyGroup mod_group
-  where
-    mod_group g = g { ggsForeignRefs = new_ref : ggsForeignRefs g }
-    new_ref = ForeignJSRef spanTxt pat safety cconv arg_tys res_ty
-    spanTxt = case mbSpan of
-                -- TODO: Is there a better way to concatenate FastStrings?
-                Just sp -> mkFastString $
-                  unpackFS (srcSpanFile sp) ++
-                  " " ++
-                  show (srcSpanStartLine sp, srcSpanStartCol sp) ++
-                  "-" ++
-                  show (srcSpanEndLine sp, srcSpanEndCol sp)
-                Nothing -> "<unknown>"
-
-
-
-
-
-
--- | start with a new binding group
-resetGroup :: G ()
-resetGroup = State.modify (\s -> s { gsGroup = defaultGenGroupState })
-
-defaultGenGroupState :: GenGroupState
-defaultGenGroupState = GenGroupState [] [] [] [] 0 S.empty emptyGlobalIdCache []
-
-emptyGlobalIdCache :: GlobalIdCache
-emptyGlobalIdCache = GlobalIdCache emptyUFM
-
-emptyIdCache :: IdCache
-emptyIdCache = IdCache M.empty
-
-
-
-assertRtsStat :: G JStat -> G JStat
-assertRtsStat stat = do
-  s <- State.gets gsSettings
-  if csAssertRts s then stat else pure mempty
-
-getSettings :: G StgToJSConfig
-getSettings = State.gets gsSettings
-
-getGlobalIdCache :: G GlobalIdCache
-getGlobalIdCache = State.gets (ggsGlobalIdCache . gsGroup)
-
-setGlobalIdCache :: GlobalIdCache -> G ()
-setGlobalIdCache v = State.modify (\s -> s { gsGroup = (gsGroup s) { ggsGlobalIdCache = v}})
-
-
-data GlobalOcc = GlobalOcc
-  { global_ident :: !Ident
-  , global_id    :: !Id
-  , global_count :: !Word
-  }
-
--- | Return number of occurrences of every global id used in the given JStat.
--- Sort by increasing occurrence count.
-globalOccs :: JStat -> G [GlobalOcc]
-globalOccs jst = do
-  GlobalIdCache gidc <- getGlobalIdCache
-  -- build a map form Ident Unique to (Ident, Id, Count)
-  let
-    cmp_cnt g1 g2 = compare (global_count g1) (global_count g2)
-    inc g1 g2 = g1 { global_count = global_count g1 + global_count g2 }
-    go gids = \case
-        []     -> -- return global Ids used locally sorted by increased use
-                  L.sortBy cmp_cnt $ nonDetEltsUFM gids
-        (i:is) ->
-          -- check if the Id is global
-          case lookupUFM gidc i of
-            Nothing       -> go gids is
-            Just (_k,gid) ->
-              -- add it to the list of already found global ids. Increasing
-              -- count by 1
-              let g = GlobalOcc i gid 1
-              in go (addToUFM_C inc gids i g) is
-
-  pure $ go emptyUFM (identsS jst)
diff --git a/compiler/GHC/StgToJS/Object.hs b/compiler/GHC/StgToJS/Object.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Object.hs
+++ /dev/null
@@ -1,622 +0,0 @@
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE LambdaCase                 #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE Rank2Types                 #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-
--- only for DB.Binary instances on Module
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.StgToJS.Object
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Sylvain Henry  <sylvain.henry@iohk.io>
---                Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
---  Serialization/deserialization of binary .o files for the JavaScript backend
---  The .o files contain dependency information and generated code.
---  All strings are mapped to a central string table, which helps reduce
---  file size and gives us efficient hash consing on read
---
---  Binary intermediate JavaScript object files:
---   serialized [Text] -> ([ClosureInfo], JStat) blocks
---
---  file layout:
---   - magic "GHCJSOBJ"
---   - compiler version tag
---   - module name
---   - offsets of string table
---   - dependencies
---   - offset of the index
---   - unit infos
---   - index
---   - string table
---
------------------------------------------------------------------------------
-
-module GHC.StgToJS.Object
-  ( putObject
-  , getObjectHeader
-  , getObjectBody
-  , getObject
-  , readObject
-  , getObjectUnits
-  , readObjectUnits
-  , readObjectDeps
-  , isGlobalUnit
-  , isJsObjectFile
-  , Object(..)
-  , IndexEntry(..)
-  , Deps (..), BlockDeps (..), DepsLocation (..)
-  , ExportedFun (..)
-  )
-where
-
-import GHC.Prelude
-
-import           Control.Monad
-
-import           Data.Array
-import           Data.Int
-import           Data.IntSet (IntSet)
-import qualified Data.IntSet as IS
-import           Data.List (sortOn)
-import           Data.Map (Map)
-import qualified Data.Map as M
-import           Data.Word
-import           Data.Char
-import Foreign.Storable
-import Foreign.Marshal.Array
-import System.IO
-
-import GHC.Settings.Constants (hiVersion)
-
-import GHC.JS.Syntax
-import GHC.StgToJS.Types
-
-import GHC.Unit.Module
-
-import GHC.Data.FastString
-
-import GHC.Types.Unique.Map
-import GHC.Float (castDoubleToWord64, castWord64ToDouble)
-
-import GHC.Utils.Binary hiding (SymbolTable)
-import GHC.Utils.Outputable (ppr, Outputable, hcat, vcat, text, hsep)
-import GHC.Utils.Monad (mapMaybeM)
-
--- | An object file
-data Object = Object
-  { objModuleName    :: !ModuleName
-    -- ^ name of the module
-  , objHandle        :: !BinHandle
-    -- ^ BinHandle that can be used to read the ObjUnits
-  , objPayloadOffset :: !(Bin ObjUnit)
-    -- ^ Offset of the payload (units)
-  , objDeps          :: !Deps
-    -- ^ Dependencies
-  , objIndex         :: !Index
-    -- ^ The Index, serialed unit indices and their linkable units
-  }
-
-type BlockId  = Int
-type BlockIds = IntSet
-
--- | dependencies for a single module
-data Deps = Deps
-  { depsModule          :: !Module
-      -- ^ module
-  , depsRequired        :: !BlockIds
-      -- ^ blocks that always need to be linked when this object is loaded (e.g.
-      -- everything that contains initializer code or foreign exports)
-  , depsHaskellExported :: !(Map ExportedFun BlockId)
-      -- ^ exported Haskell functions -> block
-  , depsBlocks          :: !(Array BlockId BlockDeps)
-      -- ^ info about each block
-  }
-
-instance Outputable Deps where
-  ppr d = vcat
-    [ hcat [ text "module: ", pprModule (depsModule d) ]
-    , hcat [ text "exports: ", ppr (M.keys (depsHaskellExported d)) ]
-    ]
-
--- | Where are the dependencies
-data DepsLocation
-  = ObjectFile  FilePath       -- ^ In an object file at path
-  | ArchiveFile FilePath       -- ^ In a Ar file at path
-  | InMemory    String Object  -- ^ In memory
-
-instance Outputable DepsLocation where
-  ppr = \case
-    ObjectFile fp  -> hsep [text "ObjectFile", text fp]
-    ArchiveFile fp -> hsep [text "ArchiveFile", text fp]
-    InMemory s o   -> hsep [text "InMemory", text s, ppr (objModuleName o)]
-
-data BlockDeps = BlockDeps
-  { blockBlockDeps       :: [Int]         -- ^ dependencies on blocks in this object
-  , blockFunDeps         :: [ExportedFun] -- ^ dependencies on exported symbols in other objects
-  -- , blockForeignExported :: [ExpFun]
-  -- , blockForeignImported :: [ForeignRef]
-  }
-
-{- | we use the convention that the first unit (0) is a module-global
-     unit that's always included when something from the module
-     is loaded. everything in a module implicitly depends on the
-     global block. the global unit itself can't have dependencies
- -}
-isGlobalUnit :: Int -> Bool
-isGlobalUnit n = n == 0
-
--- | Exported Functions
-data ExportedFun = ExportedFun
-  { funModule  :: !Module              -- ^ The module containing the function
-  , funSymbol  :: !LexicalFastString   -- ^ The function
-  } deriving (Eq, Ord)
-
-instance Outputable ExportedFun where
-  ppr (ExportedFun m f) = vcat
-    [ hcat [ text "module: ", pprModule m ]
-    , hcat [ text "symbol: ", ppr f ]
-    ]
-
--- | Write an ObjUnit, except for the top level symbols which are stored in the
--- index
-putObjUnit :: BinHandle -> ObjUnit -> IO ()
-putObjUnit bh (ObjUnit _syms b c d e f g) = do
-    put_ bh b
-    put_ bh c
-    lazyPut bh d
-    put_ bh e
-    put_ bh f
-    put_ bh g
-
--- | Read an ObjUnit and associate it to the given symbols (that must have been
--- read from the index)
-getObjUnit :: [FastString] -> BinHandle -> IO ObjUnit
-getObjUnit syms bh = do
-    b <- get bh
-    c <- get bh
-    d <- lazyGet bh
-    e <- get bh
-    f <- get bh
-    g <- get bh
-    pure $ ObjUnit
-      { oiSymbols  = syms
-      , oiClInfo   = b
-      , oiStatic   = c
-      , oiStat     = d
-      , oiRaw      = e
-      , oiFExports = f
-      , oiFImports = g
-      }
-
-
--- | A tag that determines the kind of payload in the .o file. See
--- @StgToJS.Linker.Arhive.magic@ for another kind of magic
-magic :: String
-magic = "GHCJSOBJ"
-
--- | Serialized unit indexes and their exported symbols
--- (the first unit is module-global)
-type Index = [IndexEntry]
-data IndexEntry = IndexEntry
-  { idxSymbols :: ![FastString]  -- ^ Symbols exported by a unit
-  , idxOffset  :: !(Bin ObjUnit) -- ^ Offset of the unit in the object file
-  }
-
-
---------------------------------------------------------------------------------
--- Essential oeprations on Objects
---------------------------------------------------------------------------------
-
--- | Given a handle to a Binary payload, add the module, 'mod_name', its
--- dependencies, 'deps', and its linkable units to the payload.
-putObject
-  :: BinHandle
-  -> ModuleName -- ^ module
-  -> Deps       -- ^ dependencies
-  -> [ObjUnit]  -- ^ linkable units and their symbols
-  -> IO ()
-putObject bh mod_name deps os = do
-  forM_ magic (putByte bh . fromIntegral . ord)
-  put_ bh (show hiVersion)
-
-  -- we store the module name as a String because we don't want to have to
-  -- decode the FastString table just to decode it when we're looking for an
-  -- object in an archive.
-  put_ bh (moduleNameString mod_name)
-
-  (bh_fs, _bin_dict, put_dict) <- initFSTable bh
-
-  forwardPut_ bh (const put_dict) $ do
-    put_ bh_fs deps
-
-    -- forward put the index
-    forwardPut_ bh_fs (put_ bh_fs) $ do
-      idx <- forM os $ \o -> do
-        p <- tellBin bh_fs
-        -- write units without their symbols
-        putObjUnit bh_fs o
-        -- return symbols and offset to store in the index
-        pure (oiSymbols o,p)
-      pure idx
-
--- | Test if the object file is a JS object
-isJsObjectFile :: FilePath -> IO Bool
-isJsObjectFile fp = do
-  let !n = length magic
-  withBinaryFile fp ReadMode $ \hdl -> do
-    allocaArray n $ \ptr -> do
-      n' <- hGetBuf hdl ptr n
-      if (n' /= n)
-        then pure False
-        else checkMagic (peekElemOff ptr)
-
--- | Check magic
-checkMagic :: (Int -> IO Word8) -> IO Bool
-checkMagic get_byte = do
-  let go_magic !i = \case
-        []     -> pure True
-        (e:es) -> get_byte i >>= \case
-          c | fromIntegral (ord e) == c -> go_magic (i+1) es
-            | otherwise                 -> pure False
-  go_magic 0 magic
-
--- | Parse object magic
-getCheckMagic :: BinHandle -> IO Bool
-getCheckMagic bh = checkMagic (const (getByte bh))
-
--- | Parse object header
-getObjectHeader :: BinHandle -> IO (Either String ModuleName)
-getObjectHeader bh = do
-  is_magic <- getCheckMagic bh
-  case is_magic of
-    False -> pure (Left "invalid magic header")
-    True  -> do
-      is_correct_version <- ((== hiVersion) . read) <$> get bh
-      case is_correct_version of
-        False -> pure (Left "invalid header version")
-        True  -> do
-          mod_name <- get bh
-          pure (Right (mkModuleName (mod_name)))
-
-
--- | Parse object body. Must be called after a sucessful getObjectHeader
-getObjectBody :: BinHandle -> ModuleName -> IO Object
-getObjectBody bh0 mod_name = do
-  -- Read the string table
-  dict <- forwardGet bh0 (getDictionary bh0)
-  let bh = setUserData bh0 $ noUserData { ud_get_fs = getDictFastString dict }
-
-  deps     <- get bh
-  idx      <- forwardGet bh (get bh)
-  payload_pos <- tellBin bh
-
-  pure $ Object
-    { objModuleName    = mod_name
-    , objHandle        = bh
-    , objPayloadOffset = payload_pos
-    , objDeps          = deps
-    , objIndex         = idx
-    }
-
--- | Parse object
-getObject :: BinHandle -> IO (Maybe Object)
-getObject bh = do
-  getObjectHeader bh >>= \case
-    Left _err      -> pure Nothing
-    Right mod_name -> Just <$> getObjectBody bh mod_name
-
--- | Read object from file
---
--- The object is still in memory after this (see objHandle).
-readObject :: FilePath -> IO (Maybe Object)
-readObject file = do
-  bh <- readBinMem file
-  getObject bh
-
--- | Reads only the part necessary to get the dependencies
-readObjectDeps :: FilePath -> IO (Maybe Deps)
-readObjectDeps file = do
-  bh <- readBinMem file
-  getObject bh >>= \case
-    Just obj -> pure $! Just $! objDeps obj
-    Nothing  -> pure Nothing
-
--- | Get units in the object file, using the given filtering function
-getObjectUnits :: Object -> (Word -> IndexEntry -> Bool) -> IO [ObjUnit]
-getObjectUnits obj pred = mapMaybeM read_entry (zip (objIndex obj) [0..])
-  where
-    bh = objHandle obj
-    read_entry (e@(IndexEntry syms offset),i)
-      | pred i e  = do
-          seekBin bh offset
-          Just <$> getObjUnit syms bh
-      | otherwise = pure Nothing
-
--- | Read units in the object file, using the given filtering function
-readObjectUnits :: FilePath -> (Word -> IndexEntry -> Bool) -> IO [ObjUnit]
-readObjectUnits file pred = do
-  readObject file >>= \case
-    Nothing  -> pure []
-    Just obj -> getObjectUnits obj pred
-
-
---------------------------------------------------------------------------------
--- Helper functions
---------------------------------------------------------------------------------
-
-putEnum :: Enum a => BinHandle -> a -> IO ()
-putEnum bh x | n > 65535 = error ("putEnum: out of range: " ++ show n)
-             | otherwise = put_ bh n
-  where n = fromIntegral $ fromEnum x :: Word16
-
-getEnum :: Enum a => BinHandle -> IO a
-getEnum bh = toEnum . fromIntegral <$> (get bh :: IO Word16)
-
--- | Helper to convert Int to Int32
-toI32 :: Int -> Int32
-toI32 = fromIntegral
-
--- | Helper to convert Int32 to Int
-fromI32 :: Int32 -> Int
-fromI32 = fromIntegral
-
-
---------------------------------------------------------------------------------
--- Binary Instances
---------------------------------------------------------------------------------
-
-instance Binary IndexEntry where
-  put_ bh (IndexEntry a b) = put_ bh a >> put_ bh b
-  get bh = IndexEntry <$> get bh <*> get bh
-
-instance Binary Deps where
-  put_ bh (Deps m r e b) = do
-      put_ bh m
-      put_ bh (map toI32 $ IS.toList r)
-      put_ bh (map (\(x,y) -> (x, toI32 y)) $ M.toList e)
-      put_ bh (elems b)
-  get bh = Deps <$> get bh
-             <*> (IS.fromList . map fromI32 <$> get bh)
-             <*> (M.fromList . map (\(x,y) -> (x, fromI32 y)) <$> get bh)
-             <*> ((\xs -> listArray (0, length xs - 1) xs) <$> get bh)
-
-instance Binary BlockDeps where
-  put_ bh (BlockDeps bbd bfd) = put_ bh bbd >> put_ bh bfd
-  get bh = BlockDeps <$> get bh <*> get bh
-
-instance Binary ForeignJSRef where
-  put_ bh (ForeignJSRef span pat safety cconv arg_tys res_ty) =
-    put_ bh span >> put_ bh pat >> putEnum bh safety >> putEnum bh cconv >> put_ bh arg_tys >> put_ bh res_ty
-  get bh = ForeignJSRef <$> get bh <*> get bh <*> getEnum bh <*> getEnum bh <*> get bh <*> get bh
-
-instance Binary ExpFun where
-  put_ bh (ExpFun isIO args res) = put_ bh isIO >> put_ bh args >> put_ bh res
-  get bh                        = ExpFun <$> get bh <*> get bh <*> get bh
-
-instance Binary JStat where
-  put_ bh (DeclStat i e)       = putByte bh 1  >> put_ bh i >> put_ bh e
-  put_ bh (ReturnStat e)       = putByte bh 2  >> put_ bh e
-  put_ bh (IfStat e s1 s2)     = putByte bh 3  >> put_ bh e  >> put_ bh s1 >> put_ bh s2
-  put_ bh (WhileStat b e s)    = putByte bh 4  >> put_ bh b  >> put_ bh e  >> put_ bh s
-  put_ bh (ForInStat b i e s)  = putByte bh 5  >> put_ bh b  >> put_ bh i  >> put_ bh e  >> put_ bh s
-  put_ bh (SwitchStat e ss s)  = putByte bh 6  >> put_ bh e  >> put_ bh ss >> put_ bh s
-  put_ bh (TryStat s1 i s2 s3) = putByte bh 7  >> put_ bh s1 >> put_ bh i  >> put_ bh s2 >> put_ bh s3
-  put_ bh (BlockStat xs)       = putByte bh 8  >> put_ bh xs
-  put_ bh (ApplStat e es)      = putByte bh 9  >> put_ bh e  >> put_ bh es
-  put_ bh (UOpStat o e)        = putByte bh 10 >> put_ bh o  >> put_ bh e
-  put_ bh (AssignStat e1 e2)   = putByte bh 11 >> put_ bh e1 >> put_ bh e2
-  put_ _  (UnsatBlock {})      = error "put_ bh JStat: UnsatBlock"
-  put_ bh (LabelStat l s)      = putByte bh 12 >> put_ bh l  >> put_ bh s
-  put_ bh (BreakStat ml)       = putByte bh 13 >> put_ bh ml
-  put_ bh (ContinueStat ml)    = putByte bh 14 >> put_ bh ml
-  get bh = getByte bh >>= \case
-    1  -> DeclStat     <$> get bh <*> get bh
-    2  -> ReturnStat   <$> get bh
-    3  -> IfStat       <$> get bh <*> get bh <*> get bh
-    4  -> WhileStat    <$> get bh <*> get bh <*> get bh
-    5  -> ForInStat    <$> get bh <*> get bh <*> get bh <*> get bh
-    6  -> SwitchStat   <$> get bh <*> get bh <*> get bh
-    7  -> TryStat      <$> get bh <*> get bh <*> get bh <*> get bh
-    8  -> BlockStat    <$> get bh
-    9  -> ApplStat     <$> get bh <*> get bh
-    10 -> UOpStat      <$> get bh <*> get bh
-    11 -> AssignStat   <$> get bh <*> get bh
-    12 -> LabelStat    <$> get bh <*> get bh
-    13 -> BreakStat    <$> get bh
-    14 -> ContinueStat <$> get bh
-    n -> error ("Binary get bh JStat: invalid tag: " ++ show n)
-
-instance Binary JExpr where
-  put_ bh (ValExpr v)          = putByte bh 1 >> put_ bh v
-  put_ bh (SelExpr e i)        = putByte bh 2 >> put_ bh e  >> put_ bh i
-  put_ bh (IdxExpr e1 e2)      = putByte bh 3 >> put_ bh e1 >> put_ bh e2
-  put_ bh (InfixExpr o e1 e2)  = putByte bh 4 >> put_ bh o  >> put_ bh e1 >> put_ bh e2
-  put_ bh (UOpExpr o e)        = putByte bh 5 >> put_ bh o  >> put_ bh e
-  put_ bh (IfExpr e1 e2 e3)    = putByte bh 6 >> put_ bh e1 >> put_ bh e2 >> put_ bh e3
-  put_ bh (ApplExpr e es)      = putByte bh 7 >> put_ bh e  >> put_ bh es
-  put_ _  (UnsatExpr {})       = error "put_ bh JExpr: UnsatExpr"
-  get bh = getByte bh >>= \case
-    1 -> ValExpr   <$> get bh
-    2 -> SelExpr   <$> get bh <*> get bh
-    3 -> IdxExpr   <$> get bh <*> get bh
-    4 -> InfixExpr <$> get bh <*> get bh <*> get bh
-    5 -> UOpExpr   <$> get bh <*> get bh
-    6 -> IfExpr    <$> get bh <*> get bh <*> get bh
-    7 -> ApplExpr  <$> get bh <*> get bh
-    n -> error ("Binary get bh JExpr: invalid tag: " ++ show n)
-
-instance Binary JVal where
-  put_ bh (JVar i)      = putByte bh 1 >> put_ bh i
-  put_ bh (JList es)    = putByte bh 2 >> put_ bh es
-  put_ bh (JDouble d)   = putByte bh 3 >> put_ bh d
-  put_ bh (JInt i)      = putByte bh 4 >> put_ bh i
-  put_ bh (JStr xs)     = putByte bh 5 >> put_ bh xs
-  put_ bh (JRegEx xs)   = putByte bh 6 >> put_ bh xs
-  put_ bh (JHash m)     = putByte bh 7 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m)
-  put_ bh (JFunc is s)  = putByte bh 8 >> put_ bh is >> put_ bh s
-  put_ _  (UnsatVal {}) = error "put_ bh JVal: UnsatVal"
-  get bh = getByte bh >>= \case
-    1 -> JVar    <$> get bh
-    2 -> JList   <$> get bh
-    3 -> JDouble <$> get bh
-    4 -> JInt    <$> get bh
-    5 -> JStr    <$> get bh
-    6 -> JRegEx  <$> get bh
-    7 -> JHash . listToUniqMap <$> get bh
-    8 -> JFunc   <$> get bh <*> get bh
-    n -> error ("Binary get bh JVal: invalid tag: " ++ show n)
-
-instance Binary Ident where
-  put_ bh (TxtI xs) = put_ bh xs
-  get bh = TxtI <$> get bh
-
--- we need to preserve NaN and infinities, unfortunately the Binary instance for Double does not do this
-instance Binary SaneDouble where
-  put_ bh (SaneDouble d)
-    | isNaN d               = putByte bh 1
-    | isInfinite d && d > 0 = putByte bh 2
-    | isInfinite d && d < 0 = putByte bh 3
-    | isNegativeZero d      = putByte bh 4
-    | otherwise             = putByte bh 5 >> put_ bh (castDoubleToWord64 d)
-  get bh = getByte bh >>= \case
-    1 -> pure $ SaneDouble (0    / 0)
-    2 -> pure $ SaneDouble (1    / 0)
-    3 -> pure $ SaneDouble ((-1) / 0)
-    4 -> pure $ SaneDouble (-0)
-    5 -> SaneDouble . castWord64ToDouble <$> get bh
-    n -> error ("Binary get bh SaneDouble: invalid tag: " ++ show n)
-
-instance Binary ClosureInfo where
-  put_ bh (ClosureInfo v regs name layo typ static) = do
-    put_ bh v >> put_ bh regs >> put_ bh name >> put_ bh layo >> put_ bh typ >> put_ bh static
-  get bh = ClosureInfo <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh <*> get bh
-
-instance Binary JSFFIType where
-  put_ bh = putEnum bh
-  get bh = getEnum bh
-
-instance Binary VarType where
-  put_ bh = putEnum bh
-  get bh = getEnum bh
-
-instance Binary CIRegs where
-  put_ bh CIRegsUnknown       = putByte bh 1
-  put_ bh (CIRegs skip types) = putByte bh 2 >> put_ bh skip >> put_ bh types
-  get bh = getByte bh >>= \case
-    1 -> pure CIRegsUnknown
-    2 -> CIRegs <$> get bh <*> get bh
-    n -> error ("Binary get bh CIRegs: invalid tag: " ++ show n)
-
-instance Binary JOp where
-  put_ bh = putEnum bh
-  get bh = getEnum bh
-
-instance Binary JUOp where
-  put_ bh = putEnum bh
-  get bh = getEnum bh
-
--- 16 bit sizes should be enough...
-instance Binary CILayout where
-  put_ bh CILayoutVariable           = putByte bh 1
-  put_ bh (CILayoutUnknown size)     = putByte bh 2 >> put_ bh size
-  put_ bh (CILayoutFixed size types) = putByte bh 3 >> put_ bh size >> put_ bh types
-  get bh = getByte bh >>= \case
-    1 -> pure CILayoutVariable
-    2 -> CILayoutUnknown <$> get bh
-    3 -> CILayoutFixed   <$> get bh <*> get bh
-    n -> error ("Binary get bh CILayout: invalid tag: " ++ show n)
-
-instance Binary CIStatic where
-  put_ bh (CIStaticRefs refs) = putByte bh 1 >> put_ bh refs
-  get bh = getByte bh >>= \case
-    1 -> CIStaticRefs <$> get bh
-    n -> error ("Binary get bh CIStatic: invalid tag: " ++ show n)
-
-instance Binary CIType where
-  put_ bh (CIFun arity regs) = putByte bh 1 >> put_ bh arity >> put_ bh regs
-  put_ bh CIThunk            = putByte bh 2
-  put_ bh (CICon conTag)     = putByte bh 3 >> put_ bh conTag
-  put_ bh CIPap              = putByte bh 4
-  put_ bh CIBlackhole        = putByte bh 5
-  put_ bh CIStackFrame       = putByte bh 6
-  get bh = getByte bh >>= \case
-    1 -> CIFun <$> get bh <*> get bh
-    2 -> pure CIThunk
-    3 -> CICon <$> get bh
-    4 -> pure CIPap
-    5 -> pure CIBlackhole
-    6 -> pure CIStackFrame
-    n -> error ("Binary get bh CIType: invalid tag: " ++ show n)
-
-instance Binary ExportedFun where
-  put_ bh (ExportedFun modu symb) = put_ bh modu >> put_ bh symb
-  get bh = ExportedFun <$> get bh <*> get bh
-
-instance Binary StaticInfo where
-  put_ bh (StaticInfo ident val cc) = put_ bh ident >> put_ bh val >> put_ bh cc
-  get bh = StaticInfo <$> get bh <*> get bh <*> get bh
-
-instance Binary StaticVal where
-  put_ bh (StaticFun f args)   = putByte bh 1 >> put_ bh f  >> put_ bh args
-  put_ bh (StaticThunk t)      = putByte bh 2 >> put_ bh t
-  put_ bh (StaticUnboxed u)    = putByte bh 3 >> put_ bh u
-  put_ bh (StaticData dc args) = putByte bh 4 >> put_ bh dc >> put_ bh args
-  put_ bh (StaticList xs t)    = putByte bh 5 >> put_ bh xs >> put_ bh t
-  get bh = getByte bh >>= \case
-    1 -> StaticFun     <$> get bh <*> get bh
-    2 -> StaticThunk   <$> get bh
-    3 -> StaticUnboxed <$> get bh
-    4 -> StaticData    <$> get bh <*> get bh
-    5 -> StaticList    <$> get bh <*> get bh
-    n -> error ("Binary get bh StaticVal: invalid tag " ++ show n)
-
-instance Binary StaticUnboxed where
-  put_ bh (StaticUnboxedBool b)           = putByte bh 1 >> put_ bh b
-  put_ bh (StaticUnboxedInt i)            = putByte bh 2 >> put_ bh i
-  put_ bh (StaticUnboxedDouble d)         = putByte bh 3 >> put_ bh d
-  put_ bh (StaticUnboxedString str)       = putByte bh 4 >> put_ bh str
-  put_ bh (StaticUnboxedStringOffset str) = putByte bh 5 >> put_ bh str
-  get bh = getByte bh >>= \case
-    1 -> StaticUnboxedBool         <$> get bh
-    2 -> StaticUnboxedInt          <$> get bh
-    3 -> StaticUnboxedDouble       <$> get bh
-    4 -> StaticUnboxedString       <$> get bh
-    5 -> StaticUnboxedStringOffset <$> get bh
-    n -> error ("Binary get bh StaticUnboxed: invalid tag " ++ show n)
-
-instance Binary StaticArg where
-  put_ bh (StaticObjArg i)      = putByte bh 1 >> put_ bh i
-  put_ bh (StaticLitArg p)      = putByte bh 2 >> put_ bh p
-  put_ bh (StaticConArg c args) = putByte bh 3 >> put_ bh c >> put_ bh args
-  get bh = getByte bh >>= \case
-    1 -> StaticObjArg <$> get bh
-    2 -> StaticLitArg <$> get bh
-    3 -> StaticConArg <$> get bh <*> get bh
-    n -> error ("Binary get bh StaticArg: invalid tag " ++ show n)
-
-instance Binary StaticLit where
-  put_ bh (BoolLit b)    = putByte bh 1 >> put_ bh b
-  put_ bh (IntLit i)     = putByte bh 2 >> put_ bh i
-  put_ bh NullLit        = putByte bh 3
-  put_ bh (DoubleLit d)  = putByte bh 4 >> put_ bh d
-  put_ bh (StringLit t)  = putByte bh 5 >> put_ bh t
-  put_ bh (BinLit b)     = putByte bh 6 >> put_ bh b
-  put_ bh (LabelLit b t) = putByte bh 7 >> put_ bh b >> put_ bh t
-  get bh = getByte bh >>= \case
-    1 -> BoolLit   <$> get bh
-    2 -> IntLit    <$> get bh
-    3 -> pure NullLit
-    4 -> DoubleLit <$> get bh
-    5 -> StringLit <$> get bh
-    6 -> BinLit    <$> get bh
-    7 -> LabelLit  <$> get bh <*> get bh
-    n -> error ("Binary get bh StaticLit: invalid tag " ++ show n)
diff --git a/compiler/GHC/StgToJS/Prim.hs b/compiler/GHC/StgToJS/Prim.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Prim.hs
+++ /dev/null
@@ -1,1509 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE BlockArguments #-}
-{-# LANGUAGE MultiWayIf #-}
-
--- disable this warning because of all the lambdas matching on primops'
--- arguments.
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module GHC.StgToJS.Prim
-  ( genPrim
-  )
-where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax hiding (JUOp (..))
-import GHC.JS.Make
-
-import GHC.StgToJS.Heap
-import GHC.StgToJS.Types
-import GHC.StgToJS.Profiling
-import GHC.StgToJS.Regs
-
-import GHC.Core.Type
-
-import GHC.Builtin.PrimOps
-import GHC.Tc.Utils.TcType (isBoolTy)
-import GHC.Utils.Encoding (zEncodeString)
-
-import GHC.Data.FastString
-import GHC.Utils.Outputable (renderWithContext, defaultSDocContext, ppr)
-import Data.Maybe
-
-
-genPrim :: Bool     -- ^ Profiling (cost-centres) enabled
-        -> Bool     -- ^ Array bounds-checking enabled
-        -> Type
-        -> PrimOp   -- ^ the primitive operation
-        -> [JExpr]  -- ^ where to store the result
-        -> [JExpr]  -- ^ arguments
-        -> PrimRes
-genPrim prof bound ty op = case op of
-  CharGtOp        -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y)
-  CharGeOp        -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y)
-  CharEqOp        -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y)
-  CharNeOp        -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y)
-  CharLtOp        -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y)
-  CharLeOp        -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y)
-  OrdOp           -> \[r] [x]   -> PrimInline $ r |= x
-
-  Int8ToWord8Op   -> \[r] [x]   -> PrimInline $ r |= mask8 x
-  Word8ToInt8Op   -> \[r] [x]   -> PrimInline $ r |= signExtend8 x
-  Int16ToWord16Op -> \[r] [x]   -> PrimInline $ r |= mask16 x
-  Word16ToInt16Op -> \[r] [x]   -> PrimInline $ r |= signExtend16 x
-  Int32ToWord32Op -> \[r] [x]   -> PrimInline $ r |= x .>>>. zero_
-  Word32ToInt32Op -> \[r] [x]   -> PrimInline $ r |= toI32 x
-
------------------------------- Int ----------------------------------------------
-
-  IntAddOp        -> \[r] [x,y] -> PrimInline $ r |= toI32 (Add x y)
-  IntSubOp        -> \[r] [x,y] -> PrimInline $ r |= toI32 (Sub x y)
-  IntMulOp        -> \[r] [x,y] -> PrimInline $ r |= app "h$mulInt32" [x, y]
-  IntMul2Op       -> \[c,hr,lr] [x,y] -> PrimInline $ appT [c,hr,lr] "h$hs_timesInt2" [x, y]
-  IntMulMayOfloOp -> \[r] [x,y] -> PrimInline $ jVar \tmp -> mconcat
-                                            [ tmp |= Mul x y
-                                            , r   |= if01 (tmp .===. toI32 tmp)
-                                            ]
-  IntQuotOp       -> \[r]   [x,y] -> PrimInline $ r |= toI32 (Div x y)
-  IntRemOp        -> \[r]   [x,y] -> PrimInline $ r |= Mod x y
-  IntQuotRemOp    -> \[q,r] [x,y] -> PrimInline $ mconcat
-                                            [ q |= toI32 (Div x y)
-                                            , r |= x `Sub` (Mul y q)
-                                            ]
-  IntAndOp        -> \[r] [x,y]   -> PrimInline $ r |= BAnd x y
-  IntOrOp         -> \[r] [x,y]   -> PrimInline $ r |= BOr  x y
-  IntXorOp        -> \[r] [x,y]   -> PrimInline $ r |= BXor x y
-  IntNotOp        -> \[r] [x]     -> PrimInline $ r |= BNot x
-
-  IntNegOp        -> \[r] [x]   -> PrimInline $ r |= toI32 (Negate x)
--- add with carry: overflow == 0 iff no overflow
-  IntAddCOp       -> \[r,overf] [x,y] ->
-      PrimInline $ jVar \rt -> mconcat
-        [ rt    |= Add x y
-        , r     |= toI32 rt
-        , overf |= if10 (r .!=. rt)
-        ]
-  IntSubCOp       -> \[r,overf] [x,y] ->
-      PrimInline $ jVar \rt -> mconcat
-        [ rt    |= Sub x y
-        , r     |= toI32 rt
-        , overf |= if10 (r .!=. rt)
-        ]
-  IntGtOp           -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y)
-  IntGeOp           -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y)
-  IntEqOp           -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y)
-  IntNeOp           -> \[r] [x,y] -> PrimInline $ r |= if10(x .!==. y)
-  IntLtOp           -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y)
-  IntLeOp           -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y)
-  ChrOp             -> \[r] [x]   -> PrimInline $ r |= x
-  IntToWordOp       -> \[r] [x]   -> PrimInline $ r |= x .>>>. 0
-  IntToFloatOp      -> \[r] [x]   -> PrimInline $ r |= x
-  IntToDoubleOp     -> \[r] [x]   -> PrimInline $ r |= x
-  IntSllOp          -> \[r] [x,y] -> PrimInline $ r |= x .<<. y
-  IntSraOp          -> \[r] [x,y] -> PrimInline $ r |= x .>>. y
-  IntSrlOp          -> \[r] [x,y] -> PrimInline $ r |= toI32 (x .>>>. y)
-
------------------------------- Int8 ---------------------------------------------
-
-  Int8ToIntOp       -> \[r] [x]       -> PrimInline $ r |= x
-  IntToInt8Op       -> \[r] [x]       -> PrimInline $ r |= signExtend8 x
-  Int8NegOp         -> \[r] [x]       -> PrimInline $ r |= signExtend8 (Negate x)
-  Int8AddOp         -> \[r] [x,y]     -> PrimInline $ r |= signExtend8 (Add x y)
-  Int8SubOp         -> \[r] [x,y]     -> PrimInline $ r |= signExtend8 (Sub x y)
-  Int8MulOp         -> \[r] [x,y]     -> PrimInline $ r |= signExtend8 (Mul x y)
-  Int8QuotOp        -> \[r] [x,y]     -> PrimInline $ r |= signExtend8 (quotShortInt 8 x y)
-  Int8RemOp         -> \[r] [x,y]     -> PrimInline $ r |= signExtend8 (remShortInt 8 x y)
-  Int8QuotRemOp     -> \[r1,r2] [x,y] -> PrimInline $ mconcat
-                                                [ r1 |= signExtend8 (quotShortInt 8 x y)
-                                                , r2 |= signExtend8 (remShortInt 8 x y)
-                                                ]
-  Int8EqOp          -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y)
-  Int8GeOp          -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .>=. (y .<<. (Int 24)))
-  Int8GtOp          -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .>.  (y .<<. (Int 24)))
-  Int8LeOp          -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .<=. (y .<<. (Int 24)))
-  Int8LtOp          -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 24)) .<.  (y .<<. (Int 24)))
-  Int8NeOp          -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y)
-
-  Int8SraOp         -> \[r] [x,i]   -> PrimInline $ r |= x .>>. i
-  Int8SrlOp         -> \[r] [x,i]   -> PrimInline $ r |= signExtend8 (mask8 x .>>>. i)
-  Int8SllOp         -> \[r] [x,i]   -> PrimInline $ r |= signExtend8 (mask8 (x .<<. i))
-
------------------------------- Word8 --------------------------------------------
-
-  Word8ToWordOp      -> \[r] [x]       -> PrimInline $ r |= mask8 x
-  WordToWord8Op      -> \[r] [x]       -> PrimInline $ r |= mask8 x
-
-  Word8AddOp         -> \[r] [x,y]     -> PrimInline $ r |= mask8 (Add x y)
-  Word8SubOp         -> \[r] [x,y]     -> PrimInline $ r |= mask8 (Sub x y)
-  Word8MulOp         -> \[r] [x,y]     -> PrimInline $ r |= mask8 (Mul x y)
-  Word8QuotOp        -> \[r] [x,y]     -> PrimInline $ r |= mask8 (Div x y)
-  Word8RemOp         -> \[r] [x,y]     -> PrimInline $ r |= Mod x y
-  Word8QuotRemOp     -> \[r1,r2] [x,y] -> PrimInline $ mconcat
-                                                  [ r1 |= toI32 (Div x y)
-                                                  , r2 |= Mod x y
-                                                  ]
-  Word8EqOp          -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y)
-  Word8GeOp          -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y)
-  Word8GtOp          -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y)
-  Word8LeOp          -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y)
-  Word8LtOp          -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y)
-  Word8NeOp          -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y)
-
-  Word8AndOp         -> \[r] [x,y]   -> PrimInline $ r |= BAnd x y
-  Word8OrOp          -> \[r] [x,y]   -> PrimInline $ r |= BOr  x y
-  Word8XorOp         -> \[r] [x,y]   -> PrimInline $ r |= BXor x y
-  Word8NotOp         -> \[r] [x]     -> PrimInline $ r |= BXor x (Int 0xff)
-
-  Word8SllOp         -> \[r] [x,i]   -> PrimInline $ r |= mask8 (x .<<. i)
-  Word8SrlOp         -> \[r] [x,i]   -> PrimInline $ r |= x .>>>. i
-
------------------------------- Int16 -------------------------------------------
-
-  Int16ToIntOp       -> \[r] [x]       -> PrimInline $ r |= x
-  IntToInt16Op       -> \[r] [x]       -> PrimInline $ r |= signExtend16 x
-
-  Int16NegOp         -> \[r] [x]       -> PrimInline $ r |= signExtend16 (Negate x)
-  Int16AddOp         -> \[r] [x,y]     -> PrimInline $ r |= signExtend16 (Add x y)
-  Int16SubOp         -> \[r] [x,y]     -> PrimInline $ r |= signExtend16 (Sub x y)
-  Int16MulOp         -> \[r] [x,y]     -> PrimInline $ r |= signExtend16 (Mul x y)
-  Int16QuotOp        -> \[r] [x,y]     -> PrimInline $ r |= signExtend16 (quotShortInt 16 x y)
-  Int16RemOp         -> \[r] [x,y]     -> PrimInline $ r |= signExtend16 (remShortInt 16 x y)
-  Int16QuotRemOp     -> \[r1,r2] [x,y] -> PrimInline $ mconcat
-                                                [ r1 |= signExtend16 (quotShortInt 16 x y)
-                                                , r2 |= signExtend16 (remShortInt 16 x y)
-                                                ]
-  Int16EqOp          -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y)
-  Int16GeOp          -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .>=. (y .<<. (Int 16)))
-  Int16GtOp          -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .>.  (y .<<. (Int 16)))
-  Int16LeOp          -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .<=. (y .<<. (Int 16)))
-  Int16LtOp          -> \[r] [x,y] -> PrimInline $ r |= if10 ((x .<<. (Int 16)) .<.  (y .<<. (Int 16)))
-  Int16NeOp          -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y)
-
-  Int16SraOp         -> \[r] [x,i]   -> PrimInline $ r |= x .>>. i
-  Int16SrlOp         -> \[r] [x,i]   -> PrimInline $ r |= signExtend16 (mask16 x .>>>. i)
-  Int16SllOp         -> \[r] [x,i]   -> PrimInline $ r |= signExtend16 (x .<<. i)
-
------------------------------- Word16 ------------------------------------------
-
-  Word16ToWordOp     -> \[r] [x]   -> PrimInline $ r |= x
-  WordToWord16Op     -> \[r] [x]   -> PrimInline $ r |= mask16 x
-
-  Word16AddOp        -> \[r] [x,y] -> PrimInline $ r |= mask16 (Add x y)
-  Word16SubOp        -> \[r] [x,y] -> PrimInline $ r |= mask16 (Sub x y)
-  Word16MulOp        -> \[r] [x,y] -> PrimInline $ r |= mask16 (Mul x y)
-  Word16QuotOp       -> \[r] [x,y] -> PrimInline $ r |= mask16 (Div x y)
-  Word16RemOp        -> \[r] [x,y] -> PrimInline $ r |= Mod x y
-  Word16QuotRemOp    -> \[r1,r2] [x,y] -> PrimInline $ mconcat
-                                                [ r1 |= toI32 (Div x y)
-                                                , r2 |= Mod x y
-                                                ]
-  Word16EqOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y)
-  Word16GeOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y)
-  Word16GtOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>. y)
-  Word16LeOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y)
-  Word16LtOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<. y)
-  Word16NeOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y)
-
-  Word16AndOp        -> \[r] [x,y]   -> PrimInline $ r |= BAnd x y
-  Word16OrOp         -> \[r] [x,y]   -> PrimInline $ r |= BOr  x y
-  Word16XorOp        -> \[r] [x,y]   -> PrimInline $ r |= BXor x y
-  Word16NotOp        -> \[r] [x]     -> PrimInline $ r |= BXor x (Int 0xffff)
-
-  Word16SllOp        -> \[r] [x,i]   -> PrimInline $ r |= mask16 (x .<<. i)
-  Word16SrlOp        -> \[r] [x,i]   -> PrimInline $ r |= x .>>>. i
-
------------------------------- Int32 --------------------------------------------
-
-  Int32ToIntOp       -> \[r] [x]   -> PrimInline $ r |= x
-  IntToInt32Op       -> \[r] [x]   -> PrimInline $ r |= x
-
-  Int32NegOp         -> \rs  xs    -> genPrim prof bound ty IntNegOp rs xs
-  Int32AddOp         -> \rs  xs    -> genPrim prof bound ty IntAddOp rs xs
-  Int32SubOp         -> \rs  xs    -> genPrim prof bound ty IntSubOp rs xs
-  Int32MulOp         -> \rs  xs    -> genPrim prof bound ty IntMulOp rs xs
-  Int32QuotOp        -> \rs  xs    -> genPrim prof bound ty IntQuotOp rs xs
-  Int32RemOp         -> \rs  xs    -> genPrim prof bound ty IntRemOp rs xs
-  Int32QuotRemOp     -> \rs  xs    -> genPrim prof bound ty IntQuotRemOp rs xs
-
-  Int32EqOp          -> \rs  xs    -> genPrim prof bound ty IntEqOp rs xs
-  Int32GeOp          -> \rs  xs    -> genPrim prof bound ty IntGeOp rs xs
-  Int32GtOp          -> \rs  xs    -> genPrim prof bound ty IntGtOp rs xs
-  Int32LeOp          -> \rs  xs    -> genPrim prof bound ty IntLeOp rs xs
-  Int32LtOp          -> \rs  xs    -> genPrim prof bound ty IntLtOp rs xs
-  Int32NeOp          -> \rs  xs    -> genPrim prof bound ty IntNeOp rs xs
-
-  Int32SraOp         -> \rs  xs    -> genPrim prof bound ty IntSraOp rs xs
-  Int32SrlOp         -> \rs  xs    -> genPrim prof bound ty IntSrlOp rs xs
-  Int32SllOp         -> \rs  xs    -> genPrim prof bound ty IntSllOp rs xs
-
------------------------------- Word32 -------------------------------------------
-
-  Word32ToWordOp     -> \[r] [x]   -> PrimInline $ r |= x
-  WordToWord32Op     -> \[r] [x]   -> PrimInline $ r |= x
-
-  Word32AddOp        -> \rs  xs    -> genPrim prof bound ty WordAddOp rs xs
-  Word32SubOp        -> \rs  xs    -> genPrim prof bound ty WordSubOp rs xs
-  Word32MulOp        -> \rs  xs    -> genPrim prof bound ty WordMulOp rs xs
-  Word32QuotOp       -> \rs  xs    -> genPrim prof bound ty WordQuotOp rs xs
-  Word32RemOp        -> \rs  xs    -> genPrim prof bound ty WordRemOp rs xs
-  Word32QuotRemOp    -> \rs  xs    -> genPrim prof bound ty WordQuotRemOp rs xs
-
-  Word32EqOp         -> \rs  xs    -> genPrim prof bound ty WordEqOp rs xs
-  Word32GeOp         -> \rs  xs    -> genPrim prof bound ty WordGeOp rs xs
-  Word32GtOp         -> \rs  xs    -> genPrim prof bound ty WordGtOp rs xs
-  Word32LeOp         -> \rs  xs    -> genPrim prof bound ty WordLeOp rs xs
-  Word32LtOp         -> \rs  xs    -> genPrim prof bound ty WordLtOp rs xs
-  Word32NeOp         -> \rs  xs    -> genPrim prof bound ty WordNeOp rs xs
-
-  Word32AndOp        -> \rs xs     -> genPrim prof bound ty WordAndOp rs xs
-  Word32OrOp         -> \rs xs     -> genPrim prof bound ty WordOrOp rs xs
-  Word32XorOp        -> \rs xs     -> genPrim prof bound ty WordXorOp rs xs
-  Word32NotOp        -> \rs xs     -> genPrim prof bound ty WordNotOp rs xs
-
-  Word32SllOp        -> \rs xs     -> genPrim prof bound ty WordSllOp rs xs
-  Word32SrlOp        -> \rs xs     -> genPrim prof bound ty WordSrlOp rs xs
-
------------------------------- Int64 --------------------------------------------
-
-  Int64ToIntOp      -> \[r] [_h,l] -> PrimInline $ r |= toI32 l
-
-  Int64NegOp        -> \[r_h,r_l] [h,l] ->
-      PrimInline $ mconcat
-        [ r_l |= toU32 (BNot l + 1)
-        , r_h |= toI32 (BNot h + Not r_l)
-        ]
-
-  Int64AddOp  -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_plusInt64"  [h0,l0,h1,l1]
-  Int64SubOp  -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_minusInt64" [h0,l0,h1,l1]
-  Int64MulOp  -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_timesInt64" [h0,l0,h1,l1]
-  Int64QuotOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_quotInt64"  [h0,l0,h1,l1]
-  Int64RemOp  -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_remInt64"   [h0,l0,h1,l1]
-
-  Int64SllOp  -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftLLInt64" [h,l,n]
-  Int64SraOp  -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftRAInt64" [h,l,n]
-  Int64SrlOp  -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftRLInt64" [h,l,n]
-
-  Int64ToWord64Op   -> \[r1,r2] [x1,x2] ->
-      PrimInline $ mconcat
-       [ r1 |= toU32 x1
-       , r2 |= x2
-       ]
-  IntToInt64Op      -> \[r1,r2] [x] ->
-      PrimInline $ mconcat
-       [ r1 |= if_ (x .<. 0) (-1) 0 -- sign-extension
-       , r2 |= toU32 x
-       ]
-
-  Int64EqOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LAnd (l0 .===. l1) (h0 .===. h1))
-  Int64NeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (l0 .!==. l1) (h0 .!==. h1))
-  Int64GeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>=. l1)))
-  Int64GtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>. l1)))
-  Int64LeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<=. l1)))
-  Int64LtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<. l1)))
-
------------------------------- Word64 -------------------------------------------
-
-  Word64ToWordOp    -> \[r] [_x1,x2] -> PrimInline $ r |= x2
-
-  WordToWord64Op    -> \[rh,rl] [x] ->
-    PrimInline $ mconcat
-     [ rh |= 0
-     , rl |= x
-     ]
-
-  Word64ToInt64Op   -> \[r1,r2] [x1,x2] ->
-    PrimInline $ mconcat
-     [ r1 |= toI32 x1
-     , r2 |= x2
-     ]
-
-  Word64EqOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LAnd (l0 .===. l1) (h0 .===. h1))
-  Word64NeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (l0 .!==. l1) (h0 .!==. h1))
-  Word64GeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>=. l1)))
-  Word64GtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .>. h1) (LAnd (h0 .===. h1) (l0 .>. l1)))
-  Word64LeOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<=. l1)))
-  Word64LtOp -> \[r] [h0,l0,h1,l1] -> PrimInline $ r |= if10 (LOr (h0 .<. h1) (LAnd (h0 .===. h1) (l0 .<. l1)))
-
-  Word64SllOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftLWord64" [h,l,n]
-  Word64SrlOp -> \[hr,lr] [h,l,n] -> PrimInline $ appT [hr,lr] "h$hs_uncheckedShiftRWord64" [h,l,n]
-
-  Word64OrOp  -> \[hr,hl] [h0, l0, h1, l1] ->
-      PrimInline $ mconcat
-        [ hr |= toU32 (BOr h0 h1)
-        , hl |= toU32 (BOr l0 l1)
-        ]
-
-  Word64AndOp -> \[hr,hl] [h0, l0, h1, l1] ->
-      PrimInline $ mconcat
-        [ hr |= toU32 (BAnd h0 h1)
-        , hl |= toU32 (BAnd l0 l1)
-        ]
-
-  Word64XorOp -> \[hr,hl] [h0, l0, h1, l1] ->
-      PrimInline $ mconcat
-        [ hr |= toU32 (BXor h0 h1)
-        , hl |= toU32 (BXor l0 l1)
-        ]
-
-  Word64NotOp -> \[hr,hl] [h, l] ->
-      PrimInline $ mconcat
-        [ hr |= toU32 (BNot h)
-        , hl |= toU32 (BNot l)
-        ]
-
-  Word64AddOp  -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_plusWord64"  [h0,l0,h1,l1]
-  Word64SubOp  -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_minusWord64" [h0,l0,h1,l1]
-  Word64MulOp  -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_timesWord64" [h0,l0,h1,l1]
-  Word64QuotOp -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_quotWord64"  [h0,l0,h1,l1]
-  Word64RemOp  -> \[hr,lr] [h0,l0,h1,l1] -> PrimInline $ appT [hr,lr] "h$hs_remWord64"   [h0,l0,h1,l1]
-
------------------------------- Word ---------------------------------------------
-
-  WordAddOp  -> \[r]   [x,y] -> PrimInline $ r |= (x `Add` y) .>>>. zero_
-  WordAddCOp -> \[r,c] [x,y] -> PrimInline $
-      jVar \t -> mconcat
-        [ t |= x `Add` y
-        , r |= toU32 t
-        , c |= if10 (t .!==. r)
-        ]
-  WordSubCOp  -> \[r,c] [x,y] ->
-      PrimInline $ mconcat
-        [ r |= toU32 (Sub x y)
-        , c |= if10 (y .>. x)
-        ]
-  WordAdd2Op    -> \[h,l] [x,y] -> PrimInline $ appT [h,l] "h$wordAdd2" [x,y]
-  WordSubOp     -> \  [r] [x,y] -> PrimInline $ r |= toU32 (Sub x y)
-  WordMulOp     -> \  [r] [x,y] -> PrimInline $ r |= app "h$mulWord32" [x, y]
-  WordMul2Op    -> \[h,l] [x,y] -> PrimInline $ appT [h,l] "h$mul2Word32" [x,y]
-  WordQuotOp    -> \  [q] [x,y] -> PrimInline $ q |= app "h$quotWord32" [x,y]
-  WordRemOp     -> \  [r] [x,y] -> PrimInline $ r |= app "h$remWord32" [x,y]
-  WordQuotRemOp -> \[q,r] [x,y] -> PrimInline $ appT [q,r] "h$quotRemWord32" [x,y]
-  WordQuotRem2Op   -> \[q,r] [xh,xl,y] -> PrimInline $ appT [q,r] "h$quotRem2Word32" [xh,xl,y]
-  WordAndOp        -> \[r] [x,y] -> PrimInline $ r |= toU32 (BAnd x y)
-  WordOrOp         -> \[r] [x,y] -> PrimInline $ r |= toU32 (BOr  x y)
-  WordXorOp        -> \[r] [x,y] -> PrimInline $ r |= toU32 (BXor x y)
-  WordNotOp        -> \[r] [x]   -> PrimInline $ r |= toU32 (BNot x)
-  WordSllOp        -> \[r] [x,y] -> PrimInline $ r |= toU32 (x .<<. y)
-  WordSrlOp        -> \[r] [x,y] -> PrimInline $ r |= x .>>>. y
-  WordToIntOp      -> \[r] [x]   -> PrimInline $ r |= toI32 x
-  WordGtOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>.  y)
-  WordGeOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=. y)
-  WordEqOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y)
-  WordNeOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y)
-  WordLtOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<.  y)
-  WordLeOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=. y)
-  WordToDoubleOp   -> \[r] [x]   -> PrimInline $ r |= x
-  WordToFloatOp    -> \[r] [x]   -> PrimInline $ r |= math_fround [x]
-  PopCnt8Op        -> \[r] [x]   -> PrimInline $ r |= var "h$popCntTab" .! (mask8 x)
-  PopCnt16Op       -> \[r] [x]   -> PrimInline $ r |= Add (var "h$popCntTab" .! (mask8 x))
-                                                      (var "h$popCntTab" .! (mask8 (x .>>>. Int 8)))
-
-  PopCnt32Op  -> \[r] [x]     -> PrimInline $ r |= app "h$popCnt32" [x]
-  PopCnt64Op  -> \[r] [x1,x2] -> PrimInline $ r |= app "h$popCnt64" [x1,x2]
-  PopCntOp    -> \[r] [x]     -> genPrim prof bound ty PopCnt32Op [r] [x]
-  Pdep8Op     -> \[r] [s,m]   -> PrimInline $ r |= app "h$pdep8"  [s,m]
-  Pdep16Op    -> \[r] [s,m]   -> PrimInline $ r |= app "h$pdep16" [s,m]
-  Pdep32Op    -> \[r] [s,m]   -> PrimInline $ r |= app "h$pdep32" [s,m]
-  Pdep64Op    -> \[ra,rb] [sa,sb,ma,mb] -> PrimInline $ appT [ra,rb] "h$pdep64" [sa,sb,ma,mb]
-  PdepOp      -> \rs xs                 -> genPrim prof bound ty Pdep32Op rs xs
-  Pext8Op     -> \[r] [s,m] -> PrimInline $ r |= app "h$pext8" [s,m]
-  Pext16Op    -> \[r] [s,m] -> PrimInline $ r |= app "h$pext16" [s,m]
-  Pext32Op    -> \[r] [s,m] -> PrimInline $ r |= app "h$pext32" [s,m]
-  Pext64Op    -> \[ra,rb] [sa,sb,ma,mb] -> PrimInline $ appT [ra,rb] "h$pext64" [sa,sb,ma,mb]
-  PextOp      -> \rs xs     -> genPrim prof bound ty Pext32Op rs xs
-
-  ClzOp       -> \[r]   [x]     -> PrimInline $ r |= app "h$clz32" [x]
-  Clz8Op      -> \[r]   [x]     -> PrimInline $ r |= app "h$clz8"  [x]
-  Clz16Op     -> \[r]   [x]     -> PrimInline $ r |= app "h$clz16" [x]
-  Clz32Op     -> \[r]   [x]     -> PrimInline $ r |= app "h$clz32" [x]
-  Clz64Op     -> \[r]   [x1,x2] -> PrimInline $ r |= app "h$clz64" [x1,x2]
-  CtzOp       -> \[r]   [x]     -> PrimInline $ r |= app "h$ctz32" [x]
-  Ctz8Op      -> \[r]   [x]     -> PrimInline $ r |= app "h$ctz8"  [x]
-  Ctz16Op     -> \[r]   [x]     -> PrimInline $ r |= app "h$ctz16" [x]
-  Ctz32Op     -> \[r]   [x]     -> PrimInline $ r |= app "h$ctz32" [x]
-  Ctz64Op     -> \[r]   [x1,x2] -> PrimInline $ r |= app "h$ctz64" [x1,x2]
-
-  BSwap16Op   -> \[r] [x]   -> PrimInline $
-      r |= BOr ((mask8 x) .<<. (Int 8))
-               (mask8 (x .>>>. (Int 8)))
-  BSwap32Op   -> \[r] [x]   -> PrimInline $
-      r |= toU32 ((x .<<. (Int 24))
-            `BOr` ((BAnd x (Int 0xFF00)) .<<. (Int 8))
-            `BOr` ((BAnd x (Int 0xFF0000)) .>>. (Int 8))
-            `BOr` (x .>>>. (Int 24)))
-  BSwap64Op   -> \[r1,r2] [x,y] -> PrimInline $ appT [r1,r2] "h$bswap64" [x,y]
-  BSwapOp     -> \[r] [x]       -> genPrim prof bound ty BSwap32Op [r] [x]
-
-  BRevOp      -> \[r] [w] -> genPrim prof bound ty BRev32Op [r] [w]
-  BRev8Op     -> \[r] [w] -> PrimInline $ r |= (app "h$reverseWord" [w] .>>>. 24)
-  BRev16Op    -> \[r] [w] -> PrimInline $ r |= (app "h$reverseWord" [w] .>>>. 16)
-  BRev32Op    -> \[r] [w] -> PrimInline $ r |= app "h$reverseWord" [w]
-  BRev64Op    -> \[rh,rl] [h,l] -> PrimInline $ mconcat [ rl |= app "h$reverseWord" [h]
-                                                        , rh |= app "h$reverseWord" [l]
-                                                        ]
-
------------------------------- Narrow -------------------------------------------
-
-  Narrow8IntOp    -> \[r] [x] -> PrimInline $ r |= signExtend8  x
-  Narrow16IntOp   -> \[r] [x] -> PrimInline $ r |= signExtend16 x
-  Narrow32IntOp   -> \[r] [x] -> PrimInline $ r |= toI32  x
-  Narrow8WordOp   -> \[r] [x] -> PrimInline $ r |= mask8  x
-  Narrow16WordOp  -> \[r] [x] -> PrimInline $ r |= mask16 x
-  Narrow32WordOp  -> \[r] [x] -> PrimInline $ r |= toU32  x
-
------------------------------- Double -------------------------------------------
-
-  DoubleGtOp        -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>.   y)
-  DoubleGeOp        -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=.  y)
-  DoubleEqOp        -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y)
-  DoubleNeOp        -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y)
-  DoubleLtOp        -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<.   y)
-  DoubleLeOp        -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=.  y)
-  DoubleAddOp       -> \[r] [x,y] -> PrimInline $ r |= Add x y
-  DoubleSubOp       -> \[r] [x,y] -> PrimInline $ r |= Sub x y
-  DoubleMulOp       -> \[r] [x,y] -> PrimInline $ r |= Mul x y
-  DoubleDivOp       -> \[r] [x,y] -> PrimInline $ r |= Div x y
-  DoubleNegOp       -> \[r] [x]   -> PrimInline $ r |= Negate x
-  DoubleFabsOp      -> \[r] [x]   -> PrimInline $ r |= math_abs [x]
-  DoubleToIntOp     -> \[r] [x]   -> PrimInline $ r |= toI32 x
-  DoubleToFloatOp   -> \[r] [x]   -> PrimInline $ r |= math_fround [x]
-  DoubleExpOp       -> \[r] [x]   -> PrimInline $ r |= math_exp  [x]
-  DoubleExpM1Op     -> \[r] [x]   -> PrimInline $ r |= math_expm1 [x]
-  DoubleLogOp       -> \[r] [x]   -> PrimInline $ r |= math_log  [x]
-  DoubleLog1POp     -> \[r] [x]   -> PrimInline $ r |= math_log1p [x]
-  DoubleSqrtOp      -> \[r] [x]   -> PrimInline $ r |= math_sqrt [x]
-  DoubleSinOp       -> \[r] [x]   -> PrimInline $ r |= math_sin  [x]
-  DoubleCosOp       -> \[r] [x]   -> PrimInline $ r |= math_cos  [x]
-  DoubleTanOp       -> \[r] [x]   -> PrimInline $ r |= math_tan  [x]
-  DoubleAsinOp      -> \[r] [x]   -> PrimInline $ r |= math_asin [x]
-  DoubleAcosOp      -> \[r] [x]   -> PrimInline $ r |= math_acos [x]
-  DoubleAtanOp      -> \[r] [x]   -> PrimInline $ r |= math_atan [x]
-  DoubleSinhOp      -> \[r] [x]   -> PrimInline $ r |= math_sinh [x]
-  DoubleCoshOp      -> \[r] [x]   -> PrimInline $ r |= math_cosh [x]
-  DoubleTanhOp      -> \[r] [x]   -> PrimInline $ r |= math_tanh [x]
-  DoubleAsinhOp     -> \[r] [x]   -> PrimInline $ r |= math_asinh [x]
-  DoubleAcoshOp     -> \[r] [x]   -> PrimInline $ r |= math_acosh [x]
-  DoubleAtanhOp     -> \[r] [x]   -> PrimInline $ r |= math_atanh [x]
-  DoublePowerOp     -> \[r] [x,y] -> PrimInline $ r |= math_pow [x,y]
-  DoubleDecode_2IntOp  -> \[s,h,l,e] [x] -> PrimInline $ appT [s,h,l,e] "h$decodeDouble2Int" [x]
-  DoubleDecode_Int64Op -> \[s1,s2,e] [d] -> PrimInline $ appT [e,s1,s2] "h$decodeDoubleInt64" [d]
-
------------------------------- Float --------------------------------------------
-
-  FloatGtOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>.   y)
-  FloatGeOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .>=.  y)
-  FloatEqOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .===. y)
-  FloatNeOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .!==. y)
-  FloatLtOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<.   y)
-  FloatLeOp         -> \[r] [x,y] -> PrimInline $ r |= if10 (x .<=.  y)
-  FloatAddOp        -> \[r] [x,y] -> PrimInline $ r |= math_fround [Add x y]
-  FloatSubOp        -> \[r] [x,y] -> PrimInline $ r |= math_fround [Sub x y]
-  FloatMulOp        -> \[r] [x,y] -> PrimInline $ r |= math_fround [Mul x y]
-  FloatDivOp        -> \[r] [x,y] -> PrimInline $ r |= math_fround [Div x y]
-  FloatNegOp        -> \[r] [x]   -> PrimInline $ r |= Negate x
-  FloatFabsOp       -> \[r] [x]   -> PrimInline $ r |= math_abs [x]
-  FloatToIntOp      -> \[r] [x]   -> PrimInline $ r |= toI32 x
-  FloatExpOp        -> \[r] [x]   -> PrimInline $ r |= math_fround [math_exp [x]]
-  FloatExpM1Op      -> \[r] [x]   -> PrimInline $ r |= math_fround [math_expm1 [x]]
-  FloatLogOp        -> \[r] [x]   -> PrimInline $ r |= math_fround [math_log [x]]
-  FloatLog1POp      -> \[r] [x]   -> PrimInline $ r |= math_fround [math_log1p [x]]
-  FloatSqrtOp       -> \[r] [x]   -> PrimInline $ r |= math_fround [math_sqrt [x]]
-  FloatSinOp        -> \[r] [x]   -> PrimInline $ r |= math_fround [math_sin [x]]
-  FloatCosOp        -> \[r] [x]   -> PrimInline $ r |= math_fround [math_cos [x]]
-  FloatTanOp        -> \[r] [x]   -> PrimInline $ r |= math_fround [math_tan [x]]
-  FloatAsinOp       -> \[r] [x]   -> PrimInline $ r |= math_fround [math_asin [x]]
-  FloatAcosOp       -> \[r] [x]   -> PrimInline $ r |= math_fround [math_acos [x]]
-  FloatAtanOp       -> \[r] [x]   -> PrimInline $ r |= math_fround [math_atan [x]]
-  FloatSinhOp       -> \[r] [x]   -> PrimInline $ r |= math_fround [math_sinh [x]]
-  FloatCoshOp       -> \[r] [x]   -> PrimInline $ r |= math_fround [math_cosh [x]]
-  FloatTanhOp       -> \[r] [x]   -> PrimInline $ r |= math_fround [math_tanh [x]]
-  FloatAsinhOp      -> \[r] [x]   -> PrimInline $ r |= math_fround [math_asinh [x]]
-  FloatAcoshOp      -> \[r] [x]   -> PrimInline $ r |= math_fround [math_acosh [x]]
-  FloatAtanhOp      -> \[r] [x]   -> PrimInline $ r |= math_fround [math_atanh [x]]
-  FloatPowerOp      -> \[r] [x,y] -> PrimInline $ r |= math_fround [math_pow [x,y]]
-  FloatToDoubleOp   -> \[r] [x]   -> PrimInline $ r |= x
-  FloatDecode_IntOp -> \[s,e] [x] -> PrimInline $ appT [s,e] "h$decodeFloatInt" [x]
-
------------------------------- Arrays -------------------------------------------
-
-  NewArrayOp           -> \[r] [l,e]   -> PrimInline (newArray r l e)
-  ReadArrayOp          -> \[r] [a,i]   -> PrimInline $ boundsChecked bound a i (r |= a .! i)
-  WriteArrayOp         -> \[]  [a,i,v] -> PrimInline $ boundsChecked bound a i (a .! i |= v)
-  SizeofArrayOp        -> \[r] [a]     -> PrimInline $ r |= a .^ "length"
-  SizeofMutableArrayOp -> \[r] [a]     -> PrimInline $ r |= a .^ "length"
-  IndexArrayOp         -> \[r] [a,i]   -> PrimInline $ boundsChecked bound a i (r |= a .! i)
-  UnsafeFreezeArrayOp  -> \[r] [a]     -> PrimInline $ r |= a
-  UnsafeThawArrayOp    -> \[r] [a]     -> PrimInline $ r |= a
-  CopyArrayOp          -> \[] [a,o1,ma,o2,n] ->
-      PrimInline $ loopBlockS (Int 0) (.<. n) \i ->
-        [ ma .! (Add i o2) |= a .! (Add i o1)
-        , preIncrS i
-        ]
-  CopyMutableArrayOp  -> \[]  [a1,o1,a2,o2,n] -> PrimInline $ appS "h$copyMutableArray" [a1,o1,a2,o2,n]
-  CloneArrayOp        -> \[r] [a,start,n]     -> PrimInline $ r |= app "h$sliceArray" [a,start,n]
-  CloneMutableArrayOp -> \[r] [a,start,n]     -> genPrim prof bound ty CloneArrayOp [r] [a,start,n]
-  FreezeArrayOp       -> \[r] [a,start,n]     -> PrimInline $ r |= app "h$sliceArray" [a,start,n]
-  ThawArrayOp         -> \[r] [a,start,n]     -> PrimInline $ r |= app "h$sliceArray" [a,start,n]
-  CasArrayOp          -> \[s,o] [a,i,old,new] -> PrimInline $
-      jVar \x -> mconcat
-        [ x |= a .! i
-        , ifBlockS (x .===. old)
-                   [ o |= new
-                   , a .! i |= new
-                   , s |= zero_
-                   ]
-                   [ s |= one_
-                   , o |= x
-                   ]
-        ]
-
------------------------------- Small Arrays -------------------------------------
-
-  NewSmallArrayOp            -> \[a]   [n,e]         -> PrimInline $ a |= app "h$newArray" [n,e]
-  ReadSmallArrayOp           -> \[r]   [a,i]         -> PrimInline $ boundsChecked bound a i (r |= a .! i)
-  WriteSmallArrayOp          -> \[]    [a,i,e]       -> PrimInline $ boundsChecked bound a i (a .! i |= e)
-  SizeofSmallArrayOp         -> \[r]   [a]           -> PrimInline $ r |= a .^ "length"
-  SizeofSmallMutableArrayOp  -> \[r]   [a]           -> PrimInline $ r |= a .^ "length"
-  IndexSmallArrayOp          -> \[r]   [a,i]         -> PrimInline $ boundsChecked bound a i (r |= a .! i)
-  UnsafeFreezeSmallArrayOp   -> \[r]   [a]           -> PrimInline $ r |= a
-  UnsafeThawSmallArrayOp     -> \[r]   [a]           -> PrimInline $ r |= a
-  CopySmallArrayOp           -> \[]    [s,si,d,di,n] -> PrimInline $
-      loopBlockS (Sub n one_) (.>=. zero_) \i ->
-        [ d .! (Add di i) |= s .! (Add si i)
-        , postDecrS i
-        ]
-  CopySmallMutableArrayOp    -> \[]    [s,si,d,di,n] -> PrimInline $
-      loopBlockS (Sub n one_) (.>=. zero_) \i ->
-        [ d .! (Add di i) |= s .! (Add si i)
-        , postDecrS i
-        ]
-  CloneSmallArrayOp          -> \[r]   [a,o,n]       -> PrimInline $ cloneArray r a (Just o) n
-  CloneSmallMutableArrayOp   -> \[r]   [a,o,n]       -> PrimInline $ cloneArray r a (Just o) n
-  FreezeSmallArrayOp         -> \[r]   [a,o,n]       -> PrimInline $ cloneArray r a (Just o) n
-  ThawSmallArrayOp           -> \[r]   [a,o,n]       -> PrimInline $ cloneArray r a (Just o) n
-  CasSmallArrayOp            -> \[s,o] [a,i,old,new] -> PrimInline $ jVar \x -> mconcat
-                                                                [ x |= a .! i
-                                                                , ifBlockS (x .===. old)
-                                                                    [ o |= new
-                                                                    , a .! i |= new
-                                                                    , s |= zero_
-                                                                    ]
-                                                                    [ s |= one_
-                                                                    , o |= x
-                                                                    ]
-                                                                ]
-
-------------------------------- Byte Arrays -------------------------------------
-
-  NewByteArrayOp_Char               -> \[r] [l]         -> PrimInline (newByteArray r l)
-  NewPinnedByteArrayOp_Char         -> \[r] [l]         -> PrimInline (newByteArray r l)
-  NewAlignedPinnedByteArrayOp_Char  -> \[r] [l,_align]  -> PrimInline (newByteArray r l)
-  MutableByteArrayIsPinnedOp        -> \[r] [_]         -> PrimInline $ r |= one_
-  ByteArrayIsPinnedOp               -> \[r] [_]         -> PrimInline $ r |= one_
-  ByteArrayContents_Char            -> \[a,o] [b]       -> PrimInline $ mconcat [a |= b, o |= zero_]
-  MutableByteArrayContents_Char     -> \[a,o] [b]       -> PrimInline $ mconcat [a |= b, o |= zero_]
-  ShrinkMutableByteArrayOp_Char     -> \[] [a,n]        -> PrimInline $ appS "h$shrinkMutableByteArray" [a,n]
-  ResizeMutableByteArrayOp_Char     -> \[r] [a,n]       -> PrimInline $ r |= app "h$resizeMutableByteArray" [a,n]
-  UnsafeFreezeByteArrayOp           -> \[a] [b]         -> PrimInline $ a |= b
-  SizeofByteArrayOp                 -> \[r] [a]         -> PrimInline $ r |= a .^ "len"
-  SizeofMutableByteArrayOp          -> \[r] [a]         -> PrimInline $ r |= a .^ "len"
-  GetSizeofMutableByteArrayOp       -> \[r] [a]         -> PrimInline $ r |= a .^ "len"
-  IndexByteArrayOp_Char             -> \[r] [a,i]       -> PrimInline . boundsChecked bound a i         $ r |= read_u8  a i
-  IndexByteArrayOp_WideChar         -> \[r] [a,i]       -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i
-  IndexByteArrayOp_Int              -> \[r] [a,i]       -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i
-  IndexByteArrayOp_Word             -> \[r] [a,i]       -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i
-  IndexByteArrayOp_Addr             -> \[r1,r2] [a,i]   ->
-    PrimInline . boundsChecked bound a i $ jVar \t -> mconcat
-      [ t |= a .^ "arr"
-      , ifBlockS (t .&&. t .! (i .<<. two_))
-          [ r1 |= t .! (i .<<. two_) .! zero_
-          , r2 |= t .! (i .<<. two_) .! one_
-          ]
-          [ r1 |= null_
-          , r2 |= zero_
-          ]
-      ]
-
-  IndexByteArrayOp_Float     -> \[r]     [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i
-  IndexByteArrayOp_Double    -> \[r]     [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i
-  IndexByteArrayOp_StablePtr -> \[r1,r2] [a,i] ->
-    PrimInline . boundsChecked bound a (Add i 3) $ mconcat
-      [ r1 |= var "h$stablePtrBuf"
-      , r2 |= read_i32 a i
-      ]
-  IndexByteArrayOp_Int8  -> \[r] [a,i]      -> PrimInline . boundsChecked bound a i         $ r |= read_i8  a i
-  IndexByteArrayOp_Int16 -> \[r] [a,i]      -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i
-  IndexByteArrayOp_Int32 -> \[r] [a,i]      -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i
-  IndexByteArrayOp_Int64 -> \[h,l] [a,i]    -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat
-                                                     [ h |= read_i32 a (Add (i .<<. one_) one_)
-                                                     , l |= read_u32 a (i .<<. one_)
-                                                     ]
-  IndexByteArrayOp_Word8  -> \[r] [a,i]     -> PrimInline . boundsChecked bound a i         $ r |= read_u8  a i
-  IndexByteArrayOp_Word16 -> \[r] [a,i]     -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i
-  IndexByteArrayOp_Word32 -> \[r] [a,i]     -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i
-  IndexByteArrayOp_Word64 -> \[h,l] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ mconcat
-                                                      [ h |= read_u32 a (Add (i .<<. one_) one_)
-                                                      , l |= read_u32 a (i .<<. one_)
-                                                      ]
-  ReadByteArrayOp_Char     -> \[r]     [a,i] -> PrimInline . boundsChecked bound a i         $ r |= read_u8  a i
-  ReadByteArrayOp_WideChar -> \[r]     [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i
-  ReadByteArrayOp_Int      -> \[r]     [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i
-  ReadByteArrayOp_Word     -> \[r]     [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i
-  ReadByteArrayOp_Addr     -> \[r1,r2] [a,i] ->
-      PrimInline $ jVar \x -> mconcat
-        [ x |= i .<<. two_
-        , ifS (a .^ "arr" .&&. a .^ "arr" .! x)
-               (mconcat [ r1 |= a .^ "arr" .! x .! zero_
-                        , r2 |= a .^ "arr" .! x .! one_
-                        ])
-               (mconcat [r1 |= null_, r2 |= one_])
-        ]
-  ReadByteArrayOp_Float     -> \[r]     [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_f32 a i
-  ReadByteArrayOp_Double    -> \[r]     [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_f64 a i
-  ReadByteArrayOp_StablePtr -> \[r1,r2] [a,i] ->
-      PrimInline . boundsChecked bound a (Add i 3) $ mconcat
-       [ r1 |= var "h$stablePtrBuf"
-       , r2 |= read_i32 a i
-       ]
-  ReadByteArrayOp_Int8  -> \[r]     [a,i] -> PrimInline . boundsChecked bound a i         $ r |= read_i8  a i
-  ReadByteArrayOp_Int16 -> \[r]     [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_i16 a i
-  ReadByteArrayOp_Int32 -> \[r]     [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i
-  ReadByteArrayOp_Int64 -> \[h,l]   [a,i] ->
-      PrimInline . boundsChecked bound a (Add i 7) $ mconcat
-        [ h |= read_i32 a (Add (i .<<. one_) one_)
-        , l |= read_u32 a (i .<<. one_)
-        ]
-  ReadByteArrayOp_Word8  -> \[r]     [a,i] -> PrimInline . boundsChecked bound a i         $ r |= read_u8  a i
-  ReadByteArrayOp_Word16 -> \[r]     [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_u16 a i
-  ReadByteArrayOp_Word32 -> \[r]     [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_u32 a i
-  ReadByteArrayOp_Word64 -> \[h,l]   [a,i] ->
-      PrimInline . boundsChecked bound a (Add i 7) $ mconcat
-        [ h |= read_u32 a (Add (i .<<. one_) one_)
-        , l |= read_u32 a (i .<<. one_)
-        ]
-  WriteByteArrayOp_Char     -> \[] [a,i,e]     -> PrimInline . boundsChecked bound a i         $ write_u8  a i e
-  WriteByteArrayOp_WideChar -> \[] [a,i,e]     -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e
-  WriteByteArrayOp_Int      -> \[] [a,i,e]     -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e
-  WriteByteArrayOp_Word     -> \[] [a,i,e]     -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e
-  WriteByteArrayOp_Addr     -> \[] [a,i,e1,e2] ->
-    PrimInline $ mconcat
-      [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty
-      , a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2])
-      ]
-  WriteByteArrayOp_Float     -> \[] [a,i,e]      -> PrimInline . boundsChecked bound a (Add i 3) $ write_f32 a i e
-  WriteByteArrayOp_Double    -> \[] [a,i,e]      -> PrimInline . boundsChecked bound a (Add i 7) $ write_f64 a i e
-  WriteByteArrayOp_StablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e2
-
-  WriteByteArrayOp_Int8  -> \[] [a,i,e]     -> PrimInline . boundsChecked bound a i         $ write_i8  a i e
-  WriteByteArrayOp_Int16 -> \[] [a,i,e]     -> PrimInline . boundsChecked bound a (Add i 1) $ write_i16 a i e
-  WriteByteArrayOp_Int32 -> \[] [a,i,e]     -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i e
-  WriteByteArrayOp_Int64 -> \[] [a,i,e1,e2] ->
-      PrimInline . boundsChecked bound a (Add i 7) $ mconcat
-        [ write_i32 a (Add (i .<<. one_) one_) e1
-        , write_u32 a (i .<<. one_)            e2
-        ]
-  WriteByteArrayOp_Word8  -> \[] [a,i,e]     -> PrimInline . boundsChecked bound a i         $ write_u8  a i e
-  WriteByteArrayOp_Word16 -> \[] [a,i,e]     -> PrimInline . boundsChecked bound a (Add i 1) $ write_u16 a i e
-  WriteByteArrayOp_Word32 -> \[] [a,i,e]     -> PrimInline . boundsChecked bound a (Add i 3) $ write_u32 a i e
-  WriteByteArrayOp_Word64 -> \[] [a,i,h,l] ->
-      PrimInline . boundsChecked bound a (Add i 7) $ mconcat
-        [ write_u32 a (Add (i .<<. one_) one_) h
-        , write_u32 a (i .<<. one_)            l
-        ]
-  CompareByteArraysOp -> \[r] [a1,o1,a2,o2,n] ->
-      PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1))
-                 . boundsChecked bound a2 (Add o2 (Sub n 1))
-                 $ r |= app "h$compareByteArrays" [a1,o1,a2,o2,n]
-
-  CopyByteArrayOp -> \[] [a1,o1,a2,o2,n] ->
-      PrimInline . boundsChecked bound a1 (Add o1 (Sub n 1))
-                 . boundsChecked bound a2 (Add o2 (Sub n 1))
-                $ loopBlockS (Sub n one_) (.>=. zero_) \i ->
-                    [ write_u8 a2 (Add i o2) (read_u8 a1 (Add i o1))
-                    , postDecrS i
-                    ]
-  CopyMutableByteArrayOp       -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs
-  CopyByteArrayToAddrOp        -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs
-  CopyMutableByteArrayToAddrOp -> \[] xs@[_a1,_o1,_a2,_o2,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs
-  CopyAddrToByteArrayOp        -> \[] xs@[_ba,_bo,_aa,_ao,_n] -> genPrim prof bound ty CopyByteArrayOp [] xs
-
-  SetByteArrayOp -> \[] [a,o,n,v] ->
-      PrimInline . boundsChecked bound a (Add o (Sub n 1)) $ loopBlockS zero_ (.<. n) \i ->
-        [ write_u8 a (Add o i) v
-        , postIncrS i
-        ]
-
-  AtomicReadByteArrayOp_Int  -> \[r]   [a,i]         -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_i32 a i
-  AtomicWriteByteArrayOp_Int -> \[]    [a,i,v]       -> PrimInline . boundsChecked bound a (Add i 3) $ write_i32 a i v
-  FetchAddByteArrayOp_Int    -> \[r]   [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Add  r a i v
-  FetchSubByteArrayOp_Int    -> \[r]   [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray Sub  r a i v
-  FetchAndByteArrayOp_Int    -> \[r]   [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BAnd r a i v
-  FetchOrByteArrayOp_Int     -> \[r]   [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BOr  r a i v
-  FetchNandByteArrayOp_Int   -> \[r]   [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray (\x y -> BNot (BAnd x y)) r a i v
-  FetchXorByteArrayOp_Int    -> \[r]   [a,i,v] -> PrimInline . boundsChecked bound a (Add i 3) $ fetchOpByteArray BXor r a i v
-
-------------------------------- Addr# ------------------------------------------
-
-  AddrAddOp   -> \[a',o'] [a,o,i]         -> PrimInline $ mconcat [a' |= a, o' |= Add o i]
-  AddrSubOp   -> \[i]     [_a1,o1,_a2,o2] -> PrimInline $ i |= Sub o1 o2
-  AddrRemOp   -> \[r]     [_a,o,i]        -> PrimInline $ r |= Mod o i
-  AddrToIntOp -> \[i]     [_a,o]          -> PrimInline $ i |= o -- only usable for comparisons within one range
-  IntToAddrOp -> \[a,o]   [i]             -> PrimInline $ mconcat [a |= null_, o |= i]
-  AddrGtOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .>. zero_)
-  AddrGeOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .>=. zero_)
-  AddrEqOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .===. zero_)
-  AddrNeOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .!==. zero_)
-  AddrLtOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .<. zero_)
-  AddrLeOp -> \[r] [a1,o1,a2,o2] -> PrimInline $ r |= if10 (app "h$comparePointer" [a1,o1,a2,o2] .<=. zero_)
-
-------------------------------- Addr Indexing: Unboxed Arrays -------------------
-
-  IndexOffAddrOp_Char     -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8  o i) $ c |= read_boff_u8  a (off8  o i)
-  IndexOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i)
-  IndexOffAddrOp_Int      -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i)
-  IndexOffAddrOp_Word     -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i)
-  IndexOffAddrOp_Addr     -> \[ca,co] [a,o,i] ->
-      PrimInline . boundsChecked bound (a .^ "arr") (off32 o i)
-                 $ ifBlockS (a .^ "arr " .&&. a .^ "arr" .! (i .<<. two_))
-                       [ ca |= a .^ "arr" .! (off32 o i) .! zero_
-                       , co |= a .^ "arr" .! (off32 o i) .! one_
-                       ]
-                       [ ca |= null_
-                       , co |= zero_
-                       ]
-  IndexOffAddrOp_Float     -> \[c]     [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i)
-  IndexOffAddrOp_Double    -> \[c]     [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i)
-  IndexOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat
-                                                          [ c1 |= var "h$stablePtrBuf"
-                                                          , c2 |= read_boff_i32 a (off32 o i)
-                                                          ]
-  IndexOffAddrOp_Int8  -> \[c]   [a,o,i] -> PrimInline . boundsChecked bound a (off8  o i) $ c |= read_boff_i8  a (off8  o i)
-  IndexOffAddrOp_Int16 -> \[c]   [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_i16 a (off16 o i)
-  IndexOffAddrOp_Int32 -> \[c]   [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i)
-  IndexOffAddrOp_Int64 -> \[h,l] [a,o,i] ->
-      PrimInline $ mconcat
-       [ h |= read_boff_i32 a (Add (off64 o i) (Int 4))
-       , l |= read_boff_u32 a (off64 o i)
-       ]
-  IndexOffAddrOp_Word8  -> \[c]   [a,o,i] -> PrimInline . boundsChecked bound a (off8  o i) $ c |= read_boff_u8  a (off8  o i)
-  IndexOffAddrOp_Word16 -> \[c]   [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ c |= read_boff_u16 a (off16 o i)
-  IndexOffAddrOp_Word32 -> \[c]   [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i)
-  IndexOffAddrOp_Word64 -> \[h,l] [a,o,i] ->
-      PrimInline $ mconcat
-       [ h |= read_boff_u32 a (Add (off64 o i) (Int 4))
-       , l |= read_boff_u32 a (off64 o i)
-       ]
-  ReadOffAddrOp_Char     -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off8  o i) $ c |= read_boff_u8  a (off8  o i)
-  ReadOffAddrOp_WideChar -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i)
-  ReadOffAddrOp_Int      -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_i32 a (off32 o i)
-  ReadOffAddrOp_Word     -> \[c] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_u32 a (off32 o i)
-  ReadOffAddrOp_Addr     -> \[c1,c2] [a,o,i] ->
-      PrimInline $ jVar \x -> mconcat
-        [ x |= i .<<. two_
-        , boundsChecked bound (a .^ "arr") (Add o x) $
-          ifBlockS  (a .^ "arr" .&&. a .^ "arr" .! (Add o x))
-              [ c1 |= a .^ "arr" .! (Add o x) .! zero_
-              , c2 |= a .^ "arr" .! (Add o x) .! one_
-              ]
-              [ c1 |= null_
-              , c2 |= zero_
-              ]
-        ]
-  ReadOffAddrOp_Float     -> \[c]     [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ c |= read_boff_f32 a (off32 o i)
-  ReadOffAddrOp_Double    -> \[c]     [a,o,i] -> PrimInline . boundsChecked bound a (off64 o i) $ c |= read_boff_f64 a (off64 o i)
-  ReadOffAddrOp_StablePtr -> \[c1,c2] [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ mconcat
-                                                        [ c1 |= var "h$stablePtrBuf"
-                                                        , c2 |= read_boff_u32 a (off32 o i)
-                                                        ]
-  ReadOffAddrOp_Int8   -> \[c]     [a,o,i] -> PrimInline . boundsChecked bound a (off8  o i) $ AssignStat c $ read_boff_i8  a (off8  o i)
-  ReadOffAddrOp_Int16  -> \[c]     [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_i16 a (off16 o i)
-  ReadOffAddrOp_Int32  -> \[c]     [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_i32 a (off32 o i)
-  ReadOffAddrOp_Int64  -> \[h,l] [a,o,i] ->
-      PrimInline $ mconcat
-        [ h |= read_i32 a (Add (off64 o i) (Int 4))
-        , l |= read_u32 a (off64 o i)
-        ]
-  ReadOffAddrOp_Word8  -> \[c]     [a,o,i] -> PrimInline . boundsChecked bound a (off8  o i) $ AssignStat c $ read_boff_u8  a (off8  o i)
-  ReadOffAddrOp_Word16 -> \[c]     [a,o,i] -> PrimInline . boundsChecked bound a (off16 o i) $ AssignStat c $ read_boff_u16 a (off16 o i)
-  ReadOffAddrOp_Word32 -> \[c]     [a,o,i] -> PrimInline . boundsChecked bound a (off32 o i) $ AssignStat c $ read_boff_u32 a (off32 o i)
-  ReadOffAddrOp_Word64 -> \[c1,c2] [a,o,i] ->
-      PrimInline $ mconcat
-       [ c1 |= read_boff_u32 a (Add (off64 o i) (Int 4))
-       , c2 |= read_boff_u32 a (off64 o i)
-       ]
-  WriteOffAddrOp_Char     -> \[] [a,o,i,v]     -> PrimInline . boundsChecked bound a (off8  o i) $ write_boff_u8  a (off8  o i) v
-  WriteOffAddrOp_WideChar -> \[] [a,o,i,v]     -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v
-  WriteOffAddrOp_Int      -> \[] [a,o,i,v]     -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v
-  WriteOffAddrOp_Word     -> \[] [a,o,i,v]     -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v
-  WriteOffAddrOp_Addr     -> \[] [a,o,i,va,vo] ->
-      PrimInline $ mconcat
-        [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty
-        , boundsChecked bound (a .^ "arr") (off32 o i) $
-            AssignStat (a .^ "arr" .! (off32 o i)) $ ValExpr (JList [va, vo])
-        ]
-  WriteOffAddrOp_Float     -> \[] [a,o,i,v]      -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_f32 a (off32 o i) v
-  WriteOffAddrOp_Double    -> \[] [a,o,i,v]      -> PrimInline . boundsChecked bound a (off64 o i) $ write_boff_f64 a (off64 o i) v
-  WriteOffAddrOp_StablePtr -> \[] [a,o,i,_v1,v2] -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v2
-  WriteOffAddrOp_Int8      -> \[] [a,o,i,v]      -> PrimInline . boundsChecked bound a (off8  o i) $ write_boff_i8  a (off8  o i) v
-  WriteOffAddrOp_Int16     -> \[] [a,o,i,v]      -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_i16 a (off16 o i) v
-  WriteOffAddrOp_Int32     -> \[] [a,o,i,v]      -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_i32 a (off32 o i) v
-  WriteOffAddrOp_Int64     -> \[] [a,o,i,v1,v2]  -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat
-                                                      [ write_boff_i32 a (Add (off64 o i) (Int 4)) v1
-                                                      , write_boff_u32 a (off64 o i) v2
-                                                      ]
-  WriteOffAddrOp_Word8     -> \[] [a,o,i,v]      -> PrimInline . boundsChecked bound a (off8  o i) $ write_boff_u8  a (off8  o i) v
-  WriteOffAddrOp_Word16    -> \[] [a,o,i,v]      -> PrimInline . boundsChecked bound a (off16 o i) $ write_boff_u16 a (off16 o i) v
-  WriteOffAddrOp_Word32    -> \[] [a,o,i,v]      -> PrimInline . boundsChecked bound a (off32 o i) $ write_boff_u32 a (off32 o i) v
-  WriteOffAddrOp_Word64    -> \[] [a,o,i,v1,v2]  -> PrimInline . boundsChecked bound a (off64 o i) $ mconcat
-                                                      [ write_boff_u32 a (Add (off64 o i) (Int 4)) v1
-                                                      , write_boff_u32 a (off64 o i) v2
-                                                      ]
--- Mutable variables
-  NewMutVarOp           -> \[r] [x]       -> PrimInline $ r |= New (app "h$MutVar" [x])
-  ReadMutVarOp          -> \[r] [m]       -> PrimInline $ r |= m .^ "val"
-  WriteMutVarOp         -> \[] [m,x]      -> PrimInline $ m .^ "val" |= x
-  AtomicModifyMutVar2Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar2" [m,f]
-  AtomicModifyMutVar_Op -> \[r1,r2] [m,f] -> PrimInline $ appT [r1,r2] "h$atomicModifyMutVar" [m,f]
-
-  CasMutVarOp -> \[status,r] [mv,o,n] -> PrimInline $ ifS (mv .^ "val" .===. o)
-                   (mconcat [status |= zero_, r |= n, mv .^ "val" |= n])
-                   (mconcat [status |= one_ , r |= mv .^ "val"])
-
-------------------------------- Exceptions --------------------------------------
-
-  CatchOp -> \[_r] [a,handler] -> PRPrimCall $ returnS (app "h$catch" [a, handler])
-
-                             -- fully ignore the result arity as it can use 1 or 2
-                             -- slots, depending on the return type.
-  RaiseOp                 -> \_r [a] -> PRPrimCall $ returnS (app "h$throw" [a, false_])
-  RaiseIOOp               -> \_r [a] -> PRPrimCall $ returnS (app "h$throw" [a, false_])
-  RaiseUnderflowOp        -> \_r []  -> PRPrimCall $ returnS (app "h$throw" [var "h$baseZCGHCziExceptionziTypeziunderflowException", false_])
-  RaiseOverflowOp         -> \_r []  -> PRPrimCall $ returnS (app "h$throw" [var "h$baseZCGHCziExceptionziTypezioverflowException", false_])
-  RaiseDivZeroOp          -> \_r []  -> PRPrimCall $ returnS (app "h$throw" [var "h$baseZCGHCziExceptionziTypezidivZZeroException", false_])
-  MaskAsyncExceptionsOp   -> \_r [a] -> PRPrimCall $ returnS (app "h$maskAsync" [a])
-  MaskUninterruptibleOp   -> \_r [a] -> PRPrimCall $ returnS (app "h$maskUnintAsync" [a])
-  UnmaskAsyncExceptionsOp -> \_r [a] -> PRPrimCall $ returnS (app "h$unmaskAsync" [a])
-
-  MaskStatus -> \[r] [] -> PrimInline $ r |= app "h$maskStatus" []
-
-------------------------------- STM-accessible Mutable Variables  --------------
-
-  AtomicallyOp -> \[_r] [a]   -> PRPrimCall $ returnS (app "h$atomically" [a])
-  RetryOp      -> \_r   []    -> PRPrimCall $ returnS (app "h$stmRetry" [])
-  CatchRetryOp -> \[_r] [a,b] -> PRPrimCall $ returnS (app "h$stmCatchRetry" [a,b])
-  CatchSTMOp   -> \[_r] [a,h] -> PRPrimCall $ returnS (app "h$catchStm" [a,h])
-  NewTVarOp    -> \[tv] [v]   -> PrimInline $ tv |= app "h$newTVar" [v]
-  ReadTVarOp   -> \[r] [tv]   -> PrimInline $ r |= app "h$readTVar" [tv]
-  ReadTVarIOOp -> \[r] [tv]   -> PrimInline $ r |= app "h$readTVarIO" [tv]
-  WriteTVarOp  -> \[] [tv,v]  -> PrimInline $ appS "h$writeTVar" [tv,v]
-
-------------------------------- Synchronized Mutable Variables ------------------
-
-  NewMVarOp     -> \[r]   []    -> PrimInline $ r |= New (app "h$MVar" [])
-  TakeMVarOp    -> \[_r]  [m]   -> PRPrimCall $ returnS (app "h$takeMVar" [m])
-  TryTakeMVarOp -> \[r,v] [m]   -> PrimInline $ appT [r,v] "h$tryTakeMVar" [m]
-  PutMVarOp     -> \[]    [m,v] -> PRPrimCall $ returnS (app "h$putMVar" [m,v])
-  TryPutMVarOp  -> \[r]   [m,v] -> PrimInline $ r |= app "h$tryPutMVar" [m,v]
-  ReadMVarOp    -> \[_r]  [m]   -> PRPrimCall $ returnS (app "h$readMVar" [m])
-  TryReadMVarOp -> \[r,v] [m]   -> PrimInline $ mconcat
-                                                    [ v |= m .^ "val"
-                                                    , r |= if01 (v .===. null_)
-                                                    ]
-  IsEmptyMVarOp -> \[r]   [m]   -> PrimInline $ r |= if10 (m .^ "val" .===. null_)
-
-------------------------------- Delay/Wait Ops ---------------------------------
-
-  DelayOp     -> \[] [t]  -> PRPrimCall $ returnS (app "h$delayThread" [t])
-  WaitReadOp  -> \[] [fd] -> PRPrimCall $ returnS (app "h$waidRead" [fd])
-  WaitWriteOp -> \[] [fd] -> PRPrimCall $ returnS (app "h$waitWrite" [fd])
-
-------------------------------- Concurrency Primitives -------------------------
-
-  ForkOp   -> \[_tid] [x]    -> PRPrimCall $ returnS (app "h$fork" [x, true_])
-  ForkOnOp -> \[_tid] [_p,x] -> PRPrimCall $ returnS (app "h$fork" [x, true_]) -- ignore processor argument
-  KillThreadOp  -> \[] [tid,ex]  -> PRPrimCall $ returnS (app "h$killThread" [tid,ex])
-  YieldOp       -> \[] []        -> PRPrimCall $ returnS (app "h$yield" [])
-  MyThreadIdOp  -> \[r] []       -> PrimInline $ r |= var "h$currentThread"
-  IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_
-  NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing
-  ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid]
-  ListThreadsOp  -> \[r] [] -> PrimInline $ r |= var "h$threads"
-  GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t]
-  LabelThreadOp    -> \[] [t,l] -> PrimInline $ t .^ "label" |= l
-
-------------------------------- Weak Pointers -----------------------------------
-
-  MkWeakOp              -> \[r] [o,b,c] -> PrimInline $ r |= app "h$makeWeak" [o,b,c]
-  MkWeakNoFinalizerOp   -> \[r] [o,b]   -> PrimInline $ r |= app "h$makeWeakNoFinalizer" [o,b]
-  AddCFinalizerToWeakOp -> \[r] [_a1,_a1o,_a2,_a2o,_i,_a3,_a3o,_w] -> PrimInline $ r |= one_
-  DeRefWeakOp           -> \[f,v] [w] -> PrimInline $ mconcat
-                                                        [ v |= w .^ "val"
-                                                        , f |= if01 (v .===. null_)
-                                                        ]
-  FinalizeWeakOp     -> \[fl,fin] [w] -> PrimInline $ appT [fin, fl] "h$finalizeWeak" [w]
-  TouchOp            -> \[] [_e]      -> PrimInline mempty
-  KeepAliveOp        -> \[_r] [x, f]  -> PRPrimCall $ ReturnStat (app "h$keepAlive" [x, f])
-
-
------------------------------- Stable pointers and names ------------------------
-
-  MakeStablePtrOp -> \[s1,s2] [a] -> PrimInline $ mconcat
-      [ s1 |= var "h$stablePtrBuf"
-      , s2 |= app "h$makeStablePtr" [a]
-      ]
-  DeRefStablePtrOp -> \[r] [_s1,s2]            -> PrimInline $ r |= app "h$deRefStablePtr" [s2]
-  EqStablePtrOp    -> \[r] [_sa1,sa2,_sb1,sb2] -> PrimInline $ r |= if10 (sa2 .===. sb2)
-
-  MakeStableNameOp  -> \[r] [a] -> PrimInline $ r |= app "h$makeStableName" [a]
-  StableNameToIntOp -> \[r] [s] -> PrimInline $ r |= app "h$stableNameInt" [s]
-
------------------------------- Compact normal form -----------------------------
-
-  CompactNewOp           -> \[c] [s]   -> PrimInline $ c |= app "h$compactNew" [s]
-  CompactResizeOp        -> \[]  [c,s] -> PrimInline $ appS "h$compactResize" [c,s]
-  CompactContainsOp      -> \[r] [c,v] -> PrimInline $ r |= app "h$compactContains" [c,v]
-  CompactContainsAnyOp   -> \[r] [v]   -> PrimInline $ r |= app "h$compactContainsAny" [v]
-  CompactGetFirstBlockOp -> \[ra,ro,s] [c] ->
-    PrimInline $ appT [ra,ro,s] "h$compactGetFirstBlock" [c]
-  CompactGetNextBlockOp -> \[ra,ro,s] [c,a,o] ->
-    PrimInline $ appT [ra,ro,s] "h$compactGetNextBlock" [c,a,o]
-  CompactAllocateBlockOp -> \[ra,ro] [size,sa,so] ->
-    PrimInline $ appT [ra,ro] "h$compactAllocateBlock" [size,sa,so]
-  CompactFixupPointersOp -> \[c,newroota, newrooto] [blocka,blocko,roota,rooto] ->
-    PrimInline $ appT [c,newroota,newrooto] "h$compactFixupPointers" [blocka,blocko,roota,rooto]
-  CompactAdd -> \[_r] [c,o] ->
-    PRPrimCall $ returnS (app "h$compactAdd" [c,o])
-  CompactAddWithSharing -> \[_r] [c,o] ->
-    PRPrimCall $ returnS (app "h$compactAddWithSharing" [c,o])
-  CompactSize -> \[s] [c] ->
-    PrimInline $ s |= app "h$compactSize" [c]
-
------------------------------- Unsafe pointer equality --------------------------
-
-  ReallyUnsafePtrEqualityOp -> \[r] [p1,p2] -> PrimInline $ r |= if10 (p1 .===. p2)
-
------------------------------- Parallelism --------------------------------------
-
-  ParOp     -> \[r] [_a] -> PrimInline $ r |= zero_
-  SparkOp   -> \[r] [a]  -> PrimInline $ r |= a
-  SeqOp     -> \[_r] [e] -> PRPrimCall $ returnS (app "h$e" [e])
-  NumSparks -> \[r] []   -> PrimInline $ r |= zero_
-
------------------------------- Tag to enum stuff --------------------------------
-
-  DataToTagOp -> \[_r] [d] -> PRPrimCall $ mconcat
-      [ stack .! PreInc sp |= var "h$dataToTag_e"
-      , returnS (app "h$e" [d])
-      ]
-  TagToEnumOp -> \[r] [tag] -> if
-    | isBoolTy ty -> PrimInline $ r |= IfExpr tag true_ false_
-    | otherwise   -> PrimInline $ r |= app "h$tagToEnum" [tag]
-
------------------------------- Bytecode operations ------------------------------
-
-  AddrToAnyOp -> \[r] [d,_o] -> PrimInline $ r |= d
-
------------------------------- Profiling (CCS)  ------------------------------
-
-  GetCCSOfOp -> \[a, o] [obj] -> if
-    | prof -> PrimInline $ mconcat
-        [ a |= if_ (isObject obj)
-                    (app "h$buildCCSPtr" [obj .^ "cc"])
-                    null_
-        , o |= zero_
-        ]
-    | otherwise -> PrimInline $ mconcat
-                    [ a |= null_
-                    , o |= zero_
-                    ]
-
-  GetCurrentCCSOp -> \[a, o] [_dummy_arg] ->
-    let ptr = if prof then app "h$buildCCSPtr" [jCurrentCCS]
-                      else null_
-    in PrimInline $ mconcat
-        [ a |= ptr
-        , o |= zero_
-        ]
-
-  ClearCCSOp -> \[_r] [x] -> PRPrimCall $ ReturnStat (app "h$clearCCS" [x])
-
------------------------------- Eventlog -------------------
-
-  TraceEventOp       -> \[] [ed,eo]     -> PrimInline $ appS "h$traceEvent" [ed,eo]
-  TraceEventBinaryOp -> \[] [ed,eo,len] -> PrimInline $ appS "h$traceEventBinary" [ed,eo,len]
-  TraceMarkerOp      -> \[] [ed,eo]     -> PrimInline $ appS "h$traceMarker" [ed,eo]
-
-  IndexByteArrayOp_Word8AsChar      -> \[r] [a,i] -> PrimInline . boundsChecked bound a i         $ r |= read_boff_u8  a i
-  IndexByteArrayOp_Word8AsWideChar  -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i
-  IndexByteArrayOp_Word8AsAddr      -> \[r1,r2] [a,i] ->
-      PrimInline $ jVar \x -> mconcat
-        [ x |= i .<<. two_
-        , boundsChecked bound (a .^ "arr") x $
-          ifS (a .^ "arr" .&&. a .^ "arr" .! x)
-               (mconcat [ r1 |= a .^ "arr" .! x .! zero_
-                        , r2 |= a .^ "arr" .! x .! one_
-                        ])
-               (mconcat [r1 |= null_, r2 |= one_])
-        ]
-  IndexByteArrayOp_Word8AsFloat     -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i
-  IndexByteArrayOp_Word8AsDouble    -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i
-  IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] ->
-    PrimInline $ mconcat
-    [ r1 |= var "h$stablePtrBuf"
-    , r2 |= read_boff_i32 a i
-    ]
-  IndexByteArrayOp_Word8AsInt16     -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i
-  IndexByteArrayOp_Word8AsInt32     -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i
-  IndexByteArrayOp_Word8AsInt64     -> \[h,l] [a,i] ->
-    PrimInline $ mconcat
-        [ h |= read_boff_i32 a (Add i (Int 4))
-        , l |= read_boff_u32 a i
-        ]
-  IndexByteArrayOp_Word8AsInt       -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32  a i
-  IndexByteArrayOp_Word8AsWord16    -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16  a i
-  IndexByteArrayOp_Word8AsWord32    -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32  a i
-  IndexByteArrayOp_Word8AsWord64    -> \[h,l] [a,i] ->
-    PrimInline . boundsChecked bound a (Add i 7) $ mconcat
-        [ h |= read_boff_u32 a (Add i (Int 4))
-        , l |= read_boff_u32 a i
-        ]
-  IndexByteArrayOp_Word8AsWord      -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32  a i
-
-  ReadByteArrayOp_Word8AsChar       -> \[r] [a,i] -> PrimInline . boundsChecked bound a i         $ r |= read_boff_u8  a i
-  ReadByteArrayOp_Word8AsWideChar   -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i
-  ReadByteArrayOp_Word8AsAddr       -> \[r1,r2] [a,i] ->
-      PrimInline $ jVar \x -> mconcat
-        [ x |= i .<<. two_
-        , boundsChecked bound (a .^ "arr") x $
-          ifS (a .^ "arr" .&&. a .^ "arr" .! x)
-               (mconcat [ r1 |= a .^ "arr" .! x .! zero_
-                        , r2 |= a .^ "arr" .! x .! one_
-                        ])
-               (mconcat [r1 |= null_, r2 |= one_])
-        ]
-  ReadByteArrayOp_Word8AsFloat      -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_f32 a i
-  ReadByteArrayOp_Word8AsDouble     -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 7) $ r |= read_boff_f64 a i
-  ReadByteArrayOp_Word8AsStablePtr  -> \[r1,r2] [a,i] ->
-    PrimInline $ mconcat
-    [ r1 |= var "h$stablePtrBuf"
-    , r2 |= read_boff_i32 a i
-    ]
-  ReadByteArrayOp_Word8AsInt16      -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_i16 a i
-  ReadByteArrayOp_Word8AsInt32      -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32 a i
-  ReadByteArrayOp_Word8AsInt64      -> \[h,l] [a,i] ->
-    PrimInline $ mconcat
-      [ h |= read_boff_i32 a (Add i (Int 4))
-      , l |= read_boff_u32 a i
-      ]
-  ReadByteArrayOp_Word8AsInt        -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_i32  a i
-  ReadByteArrayOp_Word8AsWord16     -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 1) $ r |= read_boff_u16  a i
-  ReadByteArrayOp_Word8AsWord32     -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32  a i
-  ReadByteArrayOp_Word8AsWord64     -> \[h,l] [a,i] ->
-    PrimInline . boundsChecked bound a (Add i 7) $ mconcat
-        [ h |= read_boff_u32 a (Add i (Int 4))
-        , l |= read_boff_u32 a i
-        ]
-  ReadByteArrayOp_Word8AsWord       -> \[r] [a,i] -> PrimInline . boundsChecked bound a (Add i 3) $ r |= read_boff_u32  a i
-
-  WriteByteArrayOp_Word8AsChar      -> \[] [a,i,e] -> PrimInline . boundsChecked bound a i         $ write_boff_i8  a i e
-  WriteByteArrayOp_Word8AsWideChar  -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e
-  WriteByteArrayOp_Word8AsAddr      -> \[] [a,i,e1,e2] ->
-    PrimInline $ mconcat
-      [ ifS (Not (a .^ "arr")) (a .^ "arr" |= ValExpr (JList [])) mempty
-      , boundsChecked bound (a .^ "arr") (i .<<. two_) $
-          a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2])
-      ]
-
-  WriteByteArrayOp_Word8AsFloat     -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_f32 a i e
-  WriteByteArrayOp_Word8AsDouble    -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 7) $ write_boff_f64 a i e
-  WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e2
-  WriteByteArrayOp_Word8AsInt16     -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_i16 a i e
-  WriteByteArrayOp_Word8AsInt32     -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e
-  WriteByteArrayOp_Word8AsInt64     -> \[] [a,i,h,l] ->
-    -- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i
-    -- then write the higher 4 bytes to i+4
-    PrimInline . boundsChecked bound a i
-               $ mconcat [ write_boff_i32 a (Add i (Int 4)) h
-                         , write_boff_u32 a i               l
-                         ]
-  WriteByteArrayOp_Word8AsInt       -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_i32 a i e
-  WriteByteArrayOp_Word8AsWord16    -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 1) $ write_boff_u16 a i e
-  WriteByteArrayOp_Word8AsWord32    -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e
-  WriteByteArrayOp_Word8AsWord64    -> \[] [a,i,h,l] ->
-    PrimInline . boundsChecked bound a (Add i 7)
-               $ mconcat [ write_boff_u32 a  (Add i (Int 4)) h
-                         , write_boff_u32 a  i               l
-                         ]
-  WriteByteArrayOp_Word8AsWord      -> \[] [a,i,e] -> PrimInline . boundsChecked bound a (Add i 3) $ write_boff_u32 a i e
-
-  CasByteArrayOp_Int                -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new
-  CasByteArrayOp_Int8               -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a i         $ casOp read_i8  write_i8  r a i old new
-  CasByteArrayOp_Int16              -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 1) $ casOp read_i16 write_i16 r a i old new
-  CasByteArrayOp_Int32              -> \[r] [a,i,old,new] -> PrimInline . boundsChecked bound a (Add i 3) $ casOp read_i32 write_i32 r a i old new
-
-  CasByteArrayOp_Int64              -> \[r_h,r_l] [a,i,old_h,old_l,new_h,new_l] -> PrimInline . boundsChecked bound a (Add (i .<<. one_) one_) $
-    jVar \t_h t_l -> mconcat [ t_h |= read_i32 a (Add (i .<<. one_) one_)
-                             , t_l |= read_u32 a (i .<<. one_)
-                             , r_h |= t_h
-                             , r_l |= t_l
-                             , ifS (t_l .===. old_l) -- small optimization, check low bits first, fail fast
-                                   (ifBlockS (t_h .===. old_h)
-                                            -- Pre-Condition is good, do the write
-                                             [ write_i32 a (Add (i .<<. one_) one_) new_h
-                                             , write_u32 a (i .<<. one_)            new_l
-                                             ]
-                                             -- no good, don't write
-                                             mempty)
-                                   mempty
-                             ]
-
-  CasAddrOp_Addr                    -> \[r_a,r_o] [a1,o1,a2,o2,a3,o3] -> PrimInline $
-                    mconcat [ ifS (app "h$comparePointer" [a1,o1,a2,o2])
-                                  (appS "h$memcpy" [a3,o3,a1,o1,8])
-                                  mempty
-                            , r_a |= a1
-                            , r_o |= o1
-                            ]
-  CasAddrOp_Word                    -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new
-  CasAddrOp_Word8                   -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u8  write_u8  r a o old new
-  CasAddrOp_Word16                  -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u16 write_u16 r a o old new
-  CasAddrOp_Word32                  -> \[r] [a,o,old,new] -> PrimInline $ casOp read_u32 write_u32 r a o old new
-  CasAddrOp_Word64                  -> \[r_h,r_l] [a,o,old_h,old_l,new_h,new_l] -> PrimInline $
-                     mconcat [ r_h |= read_u32 a (Add o (Int 4))
-                             , r_l |= read_u32 a o
-                             , ifS (r_l .===. old_l)
-                                   (ifBlockS (r_h .===. old_h)
-                                             [ write_u32 a (Add o (Int 4)) new_h
-                                             , write_u32 a o               new_l
-                                             ]
-                                             mempty)
-                               mempty
-                             ]
-
-  FetchAddAddrOp_Word               -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Add r a o v
-  FetchSubAddrOp_Word               -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr Sub  r a o v
-  FetchAndAddrOp_Word               -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BAnd  r a o v
-  FetchNandAddrOp_Word              -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr ((BNot .) . BAnd) r a o v
-  FetchOrAddrOp_Word                -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BOr   r a o v
-  FetchXorAddrOp_Word               -> \[r] [a,o,v] -> PrimInline $ fetchOpAddr BXor  r a o v
-
-  InterlockedExchange_Addr          -> \[r_a,r_o] [a1,o1,_a2,o2] -> PrimInline $
-                                          -- this primop can't be implemented
-                                          -- correctly because we don't store
-                                          -- the array reference part of an Addr#,
-                                          -- only the offset part.
-                                          --
-                                          -- So let's assume that all the array
-                                          -- references are the same...
-                                          --
-                                          -- Note: we could generate an assert
-                                          -- that checks that a1 === a2. However
-                                          -- we can't check that the Addr# read
-                                          -- at Addr# a2[o2] also comes from this
-                                          -- a1/a2 array.
-                                          mconcat [ r_a |= a1 -- might be wrong (see above)
-                                                  , r_o |= read_boff_u32 a1 o1
-                                                  -- TODO (see above)
-                                                  -- assert that a1 === a2
-                                                  , write_boff_u32 a1 o1 o2
-                                                  ]
-  InterlockedExchange_Word          -> \[r] [a,o,w] -> PrimInline $
-                                                       mconcat [ r |= read_boff_u32 a o
-                                                               , write_boff_u32 a o w
-                                                               ]
-
-  ShrinkSmallMutableArrayOp_Char    -> \[]  [a,n] -> PrimInline $ appS "h$shrinkMutableCharArray" [a,n]
-  GetSizeofSmallMutableArrayOp      -> \[r] [a]   -> PrimInline $ r |= a .^ "length"
-
-  AtomicReadAddrOp_Word             -> \[r] [a,o]   -> PrimInline $ r |= read_boff_u32 a o
-  AtomicWriteAddrOp_Word            -> \[]  [a,o,w] -> PrimInline $ write_boff_u32 a o w
-
-
------------------------------- Unhandled primops -------------------
-
-  NewPromptTagOp                    -> unhandledPrimop op
-  PromptOp                          -> unhandledPrimop op
-  Control0Op                        -> unhandledPrimop op
-
-  NewIOPortOp                       -> unhandledPrimop op
-  ReadIOPortOp                      -> unhandledPrimop op
-  WriteIOPortOp                     -> unhandledPrimop op
-
-  GetSparkOp                        -> unhandledPrimop op
-  AnyToAddrOp                       -> unhandledPrimop op
-  MkApUpd0_Op                       -> unhandledPrimop op
-  NewBCOOp                          -> unhandledPrimop op
-  UnpackClosureOp                   -> unhandledPrimop op
-  ClosureSizeOp                     -> unhandledPrimop op
-  GetApStackValOp                   -> unhandledPrimop op
-  WhereFromOp                       -> unhandledPrimop op -- should be easily implementable with o.f.n
-
-  SetThreadAllocationCounter        -> unhandledPrimop op
-
-------------------------------- Vector -----------------------------------------
--- For now, vectors are unsupported on the JS backend. Simply put, they do not
--- make much sense to support given support for arrays and lack of SIMD support
--- in JS. We could try to roll something special but we would not be able to
--- give any performance guarentees to the user and so we leave these has
--- unhandled for now.
-  VecBroadcastOp _ _ _              -> unhandledPrimop op
-  VecPackOp _ _ _                   -> unhandledPrimop op
-  VecUnpackOp _ _ _                 -> unhandledPrimop op
-  VecInsertOp _ _ _                 -> unhandledPrimop op
-  VecAddOp _ _ _                    -> unhandledPrimop op
-  VecSubOp _ _ _                    -> unhandledPrimop op
-  VecMulOp _ _ _                    -> unhandledPrimop op
-  VecDivOp _ _ _                    -> unhandledPrimop op
-  VecQuotOp _ _ _                   -> unhandledPrimop op
-  VecRemOp _ _ _                    -> unhandledPrimop op
-  VecNegOp _ _ _                    -> unhandledPrimop op
-  VecIndexByteArrayOp _ _ _         -> unhandledPrimop op
-  VecReadByteArrayOp _ _ _          -> unhandledPrimop op
-  VecWriteByteArrayOp _ _ _         -> unhandledPrimop op
-  VecIndexOffAddrOp _ _ _           -> unhandledPrimop op
-  VecReadOffAddrOp _ _ _            -> unhandledPrimop op
-  VecWriteOffAddrOp _ _ _           -> unhandledPrimop op
-
-  VecIndexScalarByteArrayOp _ _ _   -> unhandledPrimop op
-  VecReadScalarByteArrayOp _ _ _    -> unhandledPrimop op
-  VecWriteScalarByteArrayOp _ _ _   -> unhandledPrimop op
-  VecIndexScalarOffAddrOp _ _ _     -> unhandledPrimop op
-  VecReadScalarOffAddrOp _ _ _      -> unhandledPrimop op
-  VecWriteScalarOffAddrOp _ _ _     -> unhandledPrimop op
-
-  PrefetchByteArrayOp3              -> noOp
-  PrefetchMutableByteArrayOp3       -> noOp
-  PrefetchAddrOp3                   -> noOp
-  PrefetchValueOp3                  -> noOp
-  PrefetchByteArrayOp2              -> noOp
-  PrefetchMutableByteArrayOp2       -> noOp
-  PrefetchAddrOp2                   -> noOp
-  PrefetchValueOp2                  -> noOp
-  PrefetchByteArrayOp1              -> noOp
-  PrefetchMutableByteArrayOp1       -> noOp
-  PrefetchAddrOp1                   -> noOp
-  PrefetchValueOp1                  -> noOp
-  PrefetchByteArrayOp0              -> noOp
-  PrefetchMutableByteArrayOp0       -> noOp
-  PrefetchAddrOp0                   -> noOp
-  PrefetchValueOp0                  -> noOp
-
-unhandledPrimop :: PrimOp -> [JExpr] -> [JExpr] -> PrimRes
-unhandledPrimop op rs as = PrimInline $ mconcat
-  [ appS "h$log" [toJExpr $ mconcat
-      [ "warning, unhandled primop: "
-      , renderWithContext defaultSDocContext (ppr op)
-      , " "
-      , show (length rs, length as)
-      ]]
-  , appS (mkFastString $ "h$primop_" ++ zEncodeString (renderWithContext defaultSDocContext (ppr op))) as
-    -- copyRes
-  , mconcat $ zipWith (\r reg -> r |= toJExpr reg) rs (enumFrom Ret1)
-  ]
-
--- | A No Op, used for primops the JS platform cannot or do not support. For
--- example, the prefetching primops do not make sense on the JS platform because
--- we do not have enough control over memory to provide any kind of prefetching
--- mechanism. Hence, these are NoOps.
-noOp :: Foldable f => f a -> f a -> PrimRes
-noOp = const . const $ PrimInline mempty
-
--- tuple returns
-appT :: [JExpr] -> FastString -> [JExpr] -> JStat
-appT []     f xs = appS f xs
-appT (r:rs) f xs = mconcat
-  [ r |= app f xs
-  , mconcat (zipWith (\r ret -> r |= toJExpr ret) rs (enumFrom Ret1))
-  ]
-
---------------------------------------------
--- ByteArray indexing
---------------------------------------------
-
--- For every ByteArray, the RTS creates the following views:
---  i3: Int32 view
---  u8: Word8 view
---  u1: Word16 view
---  f3: Float32 view
---  f6: Float64 view
---  dv: generic DataView
--- It seems a bit weird to mix Int and Word views like this, but perhaps they
--- are the more common.
---
--- See 'h$newByteArray' in 'ghc/rts/js/mem.js' for details.
---
--- Note that *byte* indexing can only be done with the generic DataView. Use
--- read_boff_* and write_boff_* for this.
---
--- Other read_* and write_* helpers directly use the more specific views.
--- Prefer using them over idx_* to make your intent clearer.
-
-idx_i32, idx_u8, idx_u16, idx_f64, idx_f32 :: JExpr -> JExpr -> JExpr
-idx_i32 a i = IdxExpr (a .^ "i3") i
-idx_u8  a i = IdxExpr (a .^ "u8") i
-idx_u16 a i = IdxExpr (a .^ "u1") i
-idx_f64 a i = IdxExpr (a .^ "f6") i
-idx_f32 a i = IdxExpr (a .^ "f3") i
-
-read_u8 :: JExpr -> JExpr -> JExpr
-read_u8 a i = idx_u8 a i
-
-read_u16 :: JExpr -> JExpr -> JExpr
-read_u16 a i = idx_u16 a i
-
-read_u32 :: JExpr -> JExpr -> JExpr
-read_u32 a i = toU32 (idx_i32 a i)
-
-read_i8 :: JExpr -> JExpr -> JExpr
-read_i8 a i = signExtend8 (idx_u8 a i)
-
-read_i16 :: JExpr -> JExpr -> JExpr
-read_i16 a i = signExtend16 (idx_u16 a i)
-
-read_i32 :: JExpr -> JExpr -> JExpr
-read_i32 a i = idx_i32 a i
-
-read_f32 :: JExpr -> JExpr -> JExpr
-read_f32 a i = idx_f32 a i
-
-read_f64 :: JExpr -> JExpr -> JExpr
-read_f64 a i = idx_f64 a i
-
-write_u8 :: JExpr -> JExpr -> JExpr -> JStat
-write_u8 a i v = idx_u8 a i |= v
-
-write_u16 :: JExpr -> JExpr -> JExpr -> JStat
-write_u16 a i v = idx_u16 a i |= v
-
-write_u32 :: JExpr -> JExpr -> JExpr -> JStat
-write_u32 a i v = idx_i32 a i |= v
-
-write_i8 :: JExpr -> JExpr -> JExpr -> JStat
-write_i8 a i v = idx_u8 a i |= v
-
-write_i16 :: JExpr -> JExpr -> JExpr -> JStat
-write_i16 a i v = idx_u16 a i |= v
-
-write_i32 :: JExpr -> JExpr -> JExpr -> JStat
-write_i32 a i v = idx_i32 a i |= v
-
-write_f32 :: JExpr -> JExpr -> JExpr -> JStat
-write_f32 a i v = idx_f32 a i |= v
-
-write_f64 :: JExpr -> JExpr -> JExpr -> JStat
-write_f64 a i v = idx_f64 a i |= v
-
--- Data View helper functions: byte indexed!
---
--- The argument list consists of the array @a@, the index @i@, and the new value
--- to set (in the case of a setter) @v@.
-
-write_boff_i8, write_boff_u8, write_boff_i16, write_boff_u16, write_boff_i32, write_boff_u32, write_boff_f32, write_boff_f64 :: JExpr -> JExpr -> JExpr -> JStat
-write_boff_i8  a i v = write_i8 a i v
-write_boff_u8  a i v = write_u8 a i v
-write_boff_i16 a i v = ApplStat (a .^ "dv" .^ "setInt16"  ) [i, v, true_]
-write_boff_u16 a i v = ApplStat (a .^ "dv" .^ "setUint16" ) [i, v, true_]
-write_boff_i32 a i v = ApplStat (a .^ "dv" .^ "setInt32"  ) [i, v, true_]
-write_boff_u32 a i v = ApplStat (a .^ "dv" .^ "setUint32" ) [i, v, true_]
-write_boff_f32 a i v = ApplStat (a .^ "dv" .^ "setFloat32") [i, v, true_]
-write_boff_f64 a i v = ApplStat (a .^ "dv" .^ "setFloat64") [i, v, true_]
-
-read_boff_i8, read_boff_u8, read_boff_i16, read_boff_u16, read_boff_i32, read_boff_u32, read_boff_f32, read_boff_f64 :: JExpr -> JExpr -> JExpr
-read_boff_i8  a i = read_i8 a i
-read_boff_u8  a i = read_u8 a i
-read_boff_i16 a i = ApplExpr (a .^ "dv" .^ "getInt16"  ) [i, true_]
-read_boff_u16 a i = ApplExpr (a .^ "dv" .^ "getUint16" ) [i, true_]
-read_boff_i32 a i = ApplExpr (a .^ "dv" .^ "getInt32"  ) [i, true_]
-read_boff_u32 a i = ApplExpr (a .^ "dv" .^ "getUint32" ) [i, true_]
-read_boff_f32 a i = ApplExpr (a .^ "dv" .^ "getFloat32") [i, true_]
-read_boff_f64 a i = ApplExpr (a .^ "dv" .^ "getFloat64") [i, true_]
-
-fetchOpByteArray :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat
-fetchOpByteArray op tgt src i v = mconcat
-  [ tgt |= read_i32 src i
-  , write_i32 src i (op tgt v)
-  ]
-
-fetchOpAddr :: (JExpr -> JExpr -> JExpr) -> JExpr -> JExpr -> JExpr -> JExpr -> JStat
-fetchOpAddr op tgt src i v = mconcat
-  [ tgt |= read_boff_u32 src i
-  , write_boff_u32 src i (op tgt v)
-  ]
-
-casOp
-  :: (JExpr -> JExpr -> JExpr)          -- read
-  -> (JExpr -> JExpr -> JExpr -> JStat) -- write
-  -> JExpr                     -- target register  to store result
-  -> JExpr                     -- source arrays
-  -> JExpr                     -- index
-  -> JExpr                     -- old value to compare
-  -> JExpr                     -- new value to write
-  -> JStat
-casOp read write tgt src i old new = mconcat
-  [ tgt |= read src i
-  , ifS (tgt .===. old)
-        (write src i new)
-         mempty
-  ]
-
---------------------------------------------------------------------------------
---                            Lifted Arrays
---------------------------------------------------------------------------------
--- | lifted arrays
-cloneArray :: JExpr -> JExpr -> Maybe JExpr -> JExpr -> JStat
-cloneArray tgt src mb_offset len = mconcat
-  [ tgt |= ApplExpr (src .^ "slice") [start, end]
-  , tgt .^ closureMeta_   |= zero_
-  , tgt .^ "__ghcjsArray" |= true_
-  ]
-  where
-    start = fromMaybe zero_ mb_offset
-    end   = maybe len (Add len) mb_offset
-
-newArray :: JExpr -> JExpr -> JExpr -> JStat
-newArray tgt len elem =
-    tgt |= app "h$newArray" [len, elem]
-
-newByteArray :: JExpr -> JExpr -> JStat
-newByteArray tgt len =
-  tgt |= app "h$newByteArray" [len]
-
-boundsChecked :: Bool  -- ^ Should we do bounds checking?
-              -> JExpr -- ^ Array
-              -> JExpr -- ^ Index
-              -> JStat -- ^ Result
-              -> JStat
-boundsChecked False _ _ r = r
-boundsChecked True  xs i r =
-  ifS ((i .<. xs .^ "length") .&&. (i .>=. zero_))
-    r
-    (returnS $ app "h$exitProcess" [Int 134])
-
--- e|0 (32 bit signed integer truncation) required because of JS numbers. e|0
--- converts e to an Int32. Note that e|0 _is still a Double_ because JavaScript.
--- So (x|0) * (y|0) can still return values outside of the Int32 range. You have
--- been warned!
-toI32 :: JExpr -> JExpr
-toI32 e = BOr e zero_
-
--- e>>>0  (32 bit unsigned integer truncation)
--- required because of JS numbers. e>>>0 converts e to a Word32
--- so  (-2147483648)       >>> 0  = 2147483648
--- and ((-2147483648) >>>0) | 0   = -2147483648
-toU32 :: JExpr -> JExpr
-toU32 e = e .>>>. zero_
-
-quotShortInt :: Int -> JExpr -> JExpr -> JExpr
-quotShortInt bits x y = BAnd (signed x `Div` signed y) mask
-  where
-    signed z = (z .<<. shift) .>>. shift
-    shift    = toJExpr (32 - bits)
-    mask     = toJExpr (((2::Integer) ^ bits) - 1)
-
-remShortInt :: Int -> JExpr -> JExpr -> JExpr
-remShortInt bits x y = BAnd (signed x `Mod` signed y) mask
-  where
-    signed z = (z .<<. shift) .>>. shift
-    shift    = toJExpr (32 - bits)
-    mask     = toJExpr (((2::Integer) ^ bits) - 1)
diff --git a/compiler/GHC/StgToJS/Printer.hs b/compiler/GHC/StgToJS/Printer.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Printer.hs
+++ /dev/null
@@ -1,218 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MagicHash #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.StgToJS.Printer
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
--- Stability   :  experimental
---
--- Custom prettyprinter for JS AST uses the JS PPr module for most of
--- the work
---
---
------------------------------------------------------------------------------
-module GHC.StgToJS.Printer
-  ( pretty
-  , ghcjsRenderJs
-  , prettyBlock
-  )
-where
-
-import GHC.Prelude
-import GHC.Int
-import GHC.Exts
-
-import GHC.JS.Syntax
-import GHC.JS.Ppr
-
-import GHC.Utils.Ppr      as PP
-import GHC.Data.FastString
-import GHC.Types.Unique.Map
-
-import Data.List (sortOn)
-import Data.Char (isAlpha,isDigit,ord)
-import qualified Data.ByteString.Short as SBS
-
-pretty :: JStat -> Doc
-pretty = jsToDocR ghcjsRenderJs
-
-ghcjsRenderJs :: RenderJs
-ghcjsRenderJs = defaultRenderJs
-  { renderJsV = ghcjsRenderJsV
-  , renderJsS = ghcjsRenderJsS
-  , renderJsI = ghcjsRenderJsI
-  }
-
-hdd :: SBS.ShortByteString
-hdd = SBS.pack (map (fromIntegral . ord) "h$$")
-
-ghcjsRenderJsI :: RenderJs -> Ident -> Doc
-ghcjsRenderJsI _ (TxtI fs)
-  -- Fresh symbols are prefixed with "h$$". They aren't explicitly referred by
-  -- name in user code, only in compiled code. Hence we can rename them if we do
-  -- it consistently in all the linked code.
-  --
-  -- These symbols are usually very large because their name includes the
-  -- unit-id, the module name, and some unique number. So we rename these
-  -- symbols with a much shorter globally unique number.
-  --
-  -- Here we reuse their FastString unique for this purpose! Note that it only
-  -- works if we pretty-print all the JS code linked together at once, which we
-  -- currently do. GHCJS used to maintain a CompactorState to support
-  -- incremental linking: it contained the mapping between original symbols and
-  -- their renaming.
-  | hdd `SBS.isPrefixOf` fastStringToShortByteString fs
-  , u <- uniqueOfFS fs
-  = text "h$$" <> hexDoc (fromIntegral u)
-  | otherwise
-  = ftext fs
-
--- | Render as an hexadecimal number in reversed order (because it's faster and we
--- don't care about the actual value).
-hexDoc :: Word -> Doc
-hexDoc 0 = char '0'
-hexDoc v = text $ go v
-  where
-    sym (I# i) = C# (indexCharOffAddr# chars i)
-    chars = "0123456789abcdef"#
-    go = \case
-      0 -> []
-      n -> sym (fromIntegral (n .&. 0x0F))
-           : sym (fromIntegral ((n .&. 0xF0) `shiftR` 4))
-           : go (n `shiftR` 8)
-
-
-
-
--- attempt to resugar some of the common constructs
-ghcjsRenderJsS :: RenderJs -> JStat -> Doc
-ghcjsRenderJsS r (BlockStat xs) = prettyBlock r (flattenBlocks xs)
-ghcjsRenderJsS r s              = renderJsS defaultRenderJs r s
-
--- don't quote keys in our object literals, so closure compiler works
-ghcjsRenderJsV :: RenderJs -> JVal -> Doc
-ghcjsRenderJsV r (JHash m)
-  | isNullUniqMap m = text "{}"
-  | otherwise       = braceNest . PP.fsep . punctuate comma .
-                          map (\(x,y) -> quoteIfRequired x <> PP.colon <+> jsToDocR r y)
-                          -- nonDetEltsUniqMap doesn't introduce non-determinism here because
-                          -- we sort the elements lexically
-                          . sortOn (LexicalFastString . fst) $ nonDetEltsUniqMap m
-  where
-    quoteIfRequired :: FastString -> Doc
-    quoteIfRequired x
-      | isUnquotedKey x' = text x'
-      | otherwise        = PP.squotes (text x')
-      where x' = unpackFS x
-
-    isUnquotedKey :: String -> Bool
-    isUnquotedKey x | null x        = False
-                    | all isDigit x = True
-                    | otherwise     = validFirstIdent (head x)
-                                      && all validOtherIdent (tail x)
-
-
-    validFirstIdent c = c == '_' || c == '$' || isAlpha c
-    validOtherIdent c = isAlpha c || isDigit c
-ghcjsRenderJsV r v = renderJsV defaultRenderJs r v
-
-prettyBlock :: RenderJs -> [JStat] -> Doc
-prettyBlock r xs = vcat $ map addSemi (prettyBlock' r xs)
-
--- recognize common patterns in a block and convert them to more idiomatic/concise javascript
-prettyBlock' :: RenderJs -> [JStat] -> [Doc]
--- return/...
-prettyBlock' r ( x@(ReturnStat _)
-               : xs
-               )
-      | not (null xs)
-      = prettyBlock' r [x]
--- declare/assign
-prettyBlock' r ( (DeclStat i Nothing)
-               : (AssignStat (ValExpr (JVar i')) v)
-               : xs
-               )
-      | i == i'
-      = prettyBlock' r (DeclStat i (Just v) : xs)
-
--- resugar for loops with/without var declaration
-prettyBlock' r ( (DeclStat i (Just v0))
-               : (WhileStat False p (BlockStat bs))
-               : xs
-               )
-     | not (null flat) && isForUpdStat (last flat)
-     = mkFor r True i v0 p (last flat) (init flat) : prettyBlock' r xs
-        where
-          flat = flattenBlocks bs
-prettyBlock' r ( (AssignStat (ValExpr (JVar i)) v0)
-               : (WhileStat False p (BlockStat bs))
-               : xs
-               )
-     | not (null flat) && isForUpdStat (last flat)
-     = mkFor r False i v0 p (last flat) (init flat) : prettyBlock' r xs
-        where
-          flat = flattenBlocks bs
-
--- global function (does not preserve semantics but works for GHCJS)
-prettyBlock' r ( (DeclStat i (Just (ValExpr (JFunc is b))))
-               : xs
-               )
-      = (hangBrace (text "function" <+> jsToDocR r i <> parens (fsep . punctuate comma . map (jsToDocR r) $ is))
-                             (jsToDocR r b)
-                  ) : prettyBlock' r xs
--- modify/assign operators
-prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) (ValExpr (JInt 1))))
-               : xs
-               )
-      | i == i' = (text "++" <> jsToDocR r i) : prettyBlock' r xs
-prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) (ValExpr (JInt 1))))
-               : xs
-               )
-      | i == i' = (text "--" <> jsToDocR r i) : prettyBlock' r xs
-prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr AddOp (ValExpr (JVar i')) e))
-               : xs
-               )
-      | i == i' = (jsToDocR r i <+> text "+=" <+> jsToDocR r e) : prettyBlock' r xs
-prettyBlock' r ( (AssignStat (ValExpr (JVar i)) (InfixExpr SubOp (ValExpr (JVar i')) e))
-               : xs
-               )
-      | i == i' = (jsToDocR r i <+> text "-=" <+> jsToDocR r e) : prettyBlock' r xs
-
-
-prettyBlock' r (x:xs) = jsToDocR r x : prettyBlock' r xs
-prettyBlock' _ [] = []
-
--- build the for block
-mkFor :: RenderJs -> Bool -> Ident -> JExpr -> JExpr -> JStat -> [JStat] -> Doc
-mkFor r decl i v0 p s1 sb = hangBrace (text "for" <> forCond)
-                                      (jsToDocR r $ BlockStat sb)
-    where
-      c0 | decl      = text "var" <+> jsToDocR r i <+> char '=' <+> jsToDocR r v0
-         | otherwise =                jsToDocR r i <+> char '=' <+> jsToDocR r v0
-      forCond = parens $ hcat $ interSemi
-                            [ c0
-                            , jsToDocR r p
-                            , parens (jsToDocR r s1)
-                            ]
-
--- check if a statement is suitable to be converted to something in the for(;;x) position
-isForUpdStat :: JStat -> Bool
-isForUpdStat UOpStat {}    = True
-isForUpdStat AssignStat {} = True
-isForUpdStat ApplStat {}   = True
-isForUpdStat _             = False
-
-interSemi :: [Doc] -> [Doc]
-interSemi [] = [PP.empty]
-interSemi [s] = [s]
-interSemi (x:xs) = x <> text ";" : interSemi xs
-
-addSemi :: Doc -> Doc
-addSemi x = x <> text ";"
diff --git a/compiler/GHC/StgToJS/Profiling.hs b/compiler/GHC/StgToJS/Profiling.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Profiling.hs
+++ /dev/null
@@ -1,178 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module GHC.StgToJS.Profiling
-  ( initCostCentres
-  , emitCostCentreDecl
-  , emitCostCentreStackDecl
-  , enterCostCentreFun
-  , enterCostCentreThunk
-  , setCC
-  , pushRestoreCCS
-  , jCurrentCCS
-  , jCafCCS
-  , jSystemCCS
-  , costCentreLbl
-  , costCentreStackLbl
-  , singletonCCSLbl
-  , ccsVarJ
-  -- * Predicates
-  , profiling
-  , ifProfiling
-  , ifProfilingM
-  -- * helpers
-  , profStat
-  )
-where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax
-import GHC.JS.Make
-
-import GHC.StgToJS.Regs
-import GHC.StgToJS.Types
-import GHC.StgToJS.Symbols
-import GHC.StgToJS.Monad
-
-import GHC.Types.CostCentre
-
-import GHC.Data.FastString
-import GHC.Unit.Module
-import GHC.Utils.Encoding
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import qualified Control.Monad.Trans.State.Strict as State
-
---------------------------------------------------------------------------------
--- Initialization
-
-initCostCentres :: CollectedCCs -> G ()
-initCostCentres (local_CCs, singleton_CCSs) = do
-    mapM_ emitCostCentreDecl local_CCs
-    mapM_ emitCostCentreStackDecl singleton_CCSs
-
-emitCostCentreDecl :: CostCentre -> G ()
-emitCostCentreDecl cc = do
-  ccsLbl <- costCentreLbl cc
-  let is_caf = isCafCC cc
-      label  = costCentreUserName cc
-      modl   = moduleNameString $ moduleName $ cc_mod cc
-      loc    = renderWithContext defaultSDocContext (ppr (costCentreSrcSpan cc))
-      js     = ccsLbl ||= UOpExpr NewOp (ApplExpr (var "h$CC")
-                                                  [ toJExpr label
-                                                  , toJExpr modl
-                                                  , toJExpr loc
-                                                  , toJExpr is_caf
-                                                  ])
-  emitGlobal js
-
-emitCostCentreStackDecl :: CostCentreStack -> G ()
-emitCostCentreStackDecl ccs =
-    case maybeSingletonCCS ccs of
-      Just cc -> do
-        ccsLbl <- singletonCCSLbl cc
-        ccLbl  <- costCentreLbl cc
-        let js = ccsLbl ||= UOpExpr NewOp (ApplExpr (var "h$CCS") [null_, toJExpr ccLbl])
-        emitGlobal js
-      Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
-
---------------------------------------------------------------------------------
--- Entering to cost-centres
-
-enterCostCentreFun :: CostCentreStack -> JStat
-enterCostCentreFun ccs
-  | isCurrentCCS ccs = ApplStat (var "h$enterFunCCS") [jCurrentCCS, r1 .^ "cc"]
-  | otherwise = mempty -- top-level function, nothing to do
-
-enterCostCentreThunk :: JStat
-enterCostCentreThunk = ApplStat (var "h$enterThunkCCS") [r1 .^ "cc"]
-
-setCC :: CostCentre -> Bool -> Bool -> G JStat
-setCC cc _tick True = do
-  ccI@(TxtI _ccLbl) <- costCentreLbl cc
-  addDependency $ OtherSymb (cc_mod cc)
-                            (moduleGlobalSymbol $ cc_mod cc)
-  return $ jCurrentCCS |= ApplExpr (var "h$pushCostCentre") [jCurrentCCS, toJExpr ccI]
-setCC _cc _tick _push = return mempty
-
-pushRestoreCCS :: JStat
-pushRestoreCCS = ApplStat (var "h$pushRestoreCCS") []
-
---------------------------------------------------------------------------------
--- Some cost-centre stacks to be used in generator
-
-jCurrentCCS :: JExpr
-jCurrentCCS = var "h$currentThread" .^ "ccs"
-
-jCafCCS :: JExpr
-jCafCCS = var "h$CAF"
-
-jSystemCCS :: JExpr
-jSystemCCS = var "h$CCS_SYSTEM"
---------------------------------------------------------------------------------
--- Helpers for generating profiling related things
-
-profiling :: G Bool
-profiling = csProf <$> getSettings
-
-ifProfiling :: Monoid m => m -> G m
-ifProfiling m = do
-    prof <- profiling
-    return $ if prof then m else mempty
-
-ifProfilingM :: Monoid m => G m -> G m
-ifProfilingM m = do
-    prof <- profiling
-    if prof then m else return mempty
-
--- | If profiling is enabled, then use input JStat, else ignore
-profStat :: StgToJSConfig -> JStat -> JStat
-profStat cfg e = if csProf cfg then e else mempty
---------------------------------------------------------------------------------
--- Generating cost-centre and cost-centre stack variables
-
-costCentreLbl' :: CostCentre -> G String
-costCentreLbl' cc = do
-  curModl <- State.gets gsModule
-  let lbl = renderWithContext defaultSDocContext
-              $ withPprStyle PprCode (ppr cc)
-  return . ("h$"++) . zEncodeString $
-    moduleNameColons (moduleName curModl) ++ "_" ++ if isCafCC cc then "CAF_ccs" else lbl
-
-costCentreLbl :: CostCentre -> G Ident
-costCentreLbl cc = TxtI . mkFastString <$> costCentreLbl' cc
-
-costCentreStackLbl' :: CostCentreStack -> G (Maybe String)
-costCentreStackLbl' ccs = do
-  ifProfilingM f
-  where
-    f | isCurrentCCS ccs   = return $ Just "h$currentThread.ccs"
-      | dontCareCCS == ccs = return $ Just "h$CCS_DONT_CARE"
-      | otherwise          =
-          case maybeSingletonCCS ccs of
-            Just cc -> Just <$> singletonCCSLbl' cc
-            Nothing -> pure Nothing
-
-costCentreStackLbl :: CostCentreStack -> G (Maybe Ident)
-costCentreStackLbl ccs = fmap (TxtI . mkFastString) <$> costCentreStackLbl' ccs
-
-singletonCCSLbl' :: CostCentre -> G String
-singletonCCSLbl' cc = do
-    curModl <- State.gets gsModule
-    ccLbl   <- costCentreLbl' cc
-    let ccsLbl = ccLbl ++ "_ccs"
-    return . zEncodeString $ mconcat
-              [ moduleNameColons (moduleName curModl)
-              , "_"
-              , ccsLbl
-              ]
-
-singletonCCSLbl :: CostCentre -> G Ident
-singletonCCSLbl cc = TxtI . mkFastString <$> singletonCCSLbl' cc
-
-ccsVarJ :: CostCentreStack -> G (Maybe JExpr)
-ccsVarJ ccs = do
-  prof <- profiling
-  if prof
-    then fmap (ValExpr . JVar) <$> costCentreStackLbl ccs
-    else pure Nothing
diff --git a/compiler/GHC/StgToJS/Regs.hs b/compiler/GHC/StgToJS/Regs.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Regs.hs
+++ /dev/null
@@ -1,142 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module GHC.StgToJS.Regs
-  ( StgReg (..)
-  , Special(..)
-  , sp
-  , stack
-  , r1, r2, r3, r4
-  , regsFromR1
-  , regsFromR2
-  , jsRegsFromR1
-  , jsRegsFromR2
-  , StgRet (..)
-  , jsRegToInt
-  , intToJSReg
-  , jsReg
-  , maxReg
-  , minReg
-  )
-where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax
-import GHC.JS.Make
-
-import GHC.Data.FastString
-
-import Data.Array
-import Data.Char
-
--- | General purpose "registers"
---
--- The JS backend arbitrarily supports 128 registers
-data StgReg
-  = R1  | R2  | R3  | R4  | R5  | R6  | R7  | R8
-  | R9  | R10 | R11 | R12 | R13 | R14 | R15 | R16
-  | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24
-  | R25 | R26 | R27 | R28 | R29 | R30 | R31 | R32
-  | R33 | R34 | R35 | R36 | R37 | R38 | R39 | R40
-  | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48
-  | R49 | R50 | R51 | R52 | R53 | R54 | R55 | R56
-  | R57 | R58 | R59 | R60 | R61 | R62 | R63 | R64
-  | R65 | R66 | R67 | R68 | R69 | R70 | R71 | R72
-  | R73 | R74 | R75 | R76 | R77 | R78 | R79 | R80
-  | R81 | R82 | R83 | R84 | R85 | R86 | R87 | R88
-  | R89 | R90 | R91 | R92 | R93 | R94 | R95 | R96
-  | R97  | R98  | R99  | R100 | R101 | R102 | R103 | R104
-  | R105 | R106 | R107 | R108 | R109 | R110 | R111 | R112
-  | R113 | R114 | R115 | R116 | R117 | R118 | R119 | R120
-  | R121 | R122 | R123 | R124 | R125 | R126 | R127 | R128
-  deriving (Eq, Ord, Show, Enum, Bounded, Ix)
-
--- | Stack registers
-data Special
-  = Stack
-  | Sp
-  deriving (Show, Eq)
-
--- | Return registers
---
--- Extra results from foreign calls can be stored here (while first result is
--- directly returned)
-data StgRet = Ret1 | Ret2 | Ret3 | Ret4 | Ret5 | Ret6 | Ret7 | Ret8 | Ret9 | Ret10
-  deriving (Eq, Ord, Show, Enum, Bounded, Ix)
-
-instance ToJExpr Special where
-  toJExpr Stack  = var "h$stack"
-  toJExpr Sp     = var "h$sp"
-
-instance ToJExpr StgReg where
-  toJExpr r = registers ! r
-
-instance ToJExpr StgRet where
-  toJExpr r = rets ! r
-
----------------------------------------------------
--- helpers
----------------------------------------------------
-
-sp :: JExpr
-sp = toJExpr Sp
-
-stack :: JExpr
-stack = toJExpr Stack
-
-r1, r2, r3, r4 :: JExpr
-r1 = toJExpr R1
-r2 = toJExpr R2
-r3 = toJExpr R3
-r4 = toJExpr R4
-
-
-jsRegToInt :: StgReg -> Int
-jsRegToInt = (+1) . fromEnum
-
-intToJSReg :: Int -> StgReg
-intToJSReg r = toEnum (r - 1)
-
-jsReg :: Int -> JExpr
-jsReg r = toJExpr (intToJSReg r)
-
-maxReg :: Int
-maxReg = jsRegToInt maxBound
-
-minReg :: Int
-minReg = jsRegToInt minBound
-
--- | List of registers, starting from R1
-regsFromR1 :: [StgReg]
-regsFromR1 = enumFrom R1
-
--- | List of registers, starting from R2
-regsFromR2 :: [StgReg]
-regsFromR2 = tail regsFromR1
-
--- | List of registers, starting from R1 as JExpr
-jsRegsFromR1 :: [JExpr]
-jsRegsFromR1 = fmap toJExpr regsFromR1
-
--- | List of registers, starting from R2 as JExpr
-jsRegsFromR2 :: [JExpr]
-jsRegsFromR2 = tail jsRegsFromR1
-
----------------------------------------------------
--- caches
----------------------------------------------------
-
--- cache JExpr representing StgReg
-registers :: Array StgReg JExpr
-registers = listArray (minBound, maxBound) (map regN regsFromR1)
-  where
-    regN r
-      | fromEnum r < 32 = var . mkFastString . ("h$"++) . map toLower . show $ r
-      | otherwise       = IdxExpr (var "h$regs")
-                            (toJExpr ((fromEnum r) - 32))
-
--- cache JExpr representing StgRet
-rets :: Array StgRet JExpr
-rets = listArray (minBound, maxBound) (map retN (enumFrom Ret1))
-  where
-    retN = var . mkFastString . ("h$"++) . map toLower . show
diff --git a/compiler/GHC/StgToJS/Rts/Rts.hs b/compiler/GHC/StgToJS/Rts/Rts.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Rts/Rts.hs
+++ /dev/null
@@ -1,661 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-{-# OPTIONS_GHC -O0 #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.StgToJS.Rts.Rts
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
--- Top level driver of the JavaScript Backend RTS. This file is an
--- implementation of the JS RTS for the JS backend written as an EDSL in
--- Haskell. It assumes the existence of pre-generated JS functions, included as
--- js-sources in base. These functions are similarly assumed for non-inline
--- Primops, See 'GHC.StgToJS.Prim'. Most of the elements in this module are
--- constants in Haskell Land which define pieces of the JS RTS.
---
------------------------------------------------------------------------------
-
-module GHC.StgToJS.Rts.Rts where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax
-import GHC.JS.Make
-import GHC.JS.Transform
-
-import GHC.StgToJS.Apply
-import GHC.StgToJS.Closure
-import GHC.StgToJS.Heap
-import GHC.StgToJS.Printer
-import GHC.StgToJS.Profiling
-import GHC.StgToJS.Regs
-import GHC.StgToJS.Types
-import GHC.StgToJS.Stack
-
-import GHC.Data.FastString
-import GHC.Types.Unique.Map
-
-import Data.Array
-import Data.Monoid
-import Data.Char (toLower, toUpper)
-import qualified Data.Bits          as Bits
-
--- | The garbageCollector resets registers and result variables.
-garbageCollector :: JStat
-garbageCollector =
-  mconcat [ TxtI "h$resetRegisters"  ||= jLam (mconcat $ map resetRegister [minBound..maxBound])
-          , TxtI "h$resetResultVars" ||= jLam (mconcat $ map resetResultVar [minBound..maxBound])
-          ]
-
--- | Reset the register 'r' in JS Land. Note that this "resets" by setting the
--- register to a dummy variable called "null", /not/ by setting to JS's nil
--- value.
-resetRegister :: StgReg -> JStat
-resetRegister r = toJExpr r |= null_
-
--- | Reset the return variable 'r' in JS Land. Note that this "resets" by
--- setting the register to a dummy variable called "null", /not/ by setting to
--- JS's nil value.
-resetResultVar :: StgRet -> JStat
-resetResultVar r = toJExpr r |= null_
-
--- | Define closures based on size, these functions are syntactic sugar, e.g., a
--- Haskell function which generates some useful JS. Each Closure constructor
--- follows the naming convention h$cN, where N is a natural number. For example,
--- h$c (with the nat omitted) is a JS Land Constructor for a closure in JS land
--- which has a single entry function 'f', and no fields; identical to h$c0. h$c1
--- is a JS Land Constructor for a closure with an entry function 'f', and a
--- /single/ field 'x1', 'Just foo' is an example of this kind of closure. h$c2
--- is a JS Land Constructor for a closure with an entry function and two data
--- fields: 'x1' and 'x2'. And so on. Note that this has JIT performance
--- implications; you should use h$c1, h$c2, h$c3, ... h$c24 instead of making
--- objects manually so layouts and fields can be changed more easily and so the
--- JIT can optimize better.
-closureConstructors :: StgToJSConfig -> JStat
-closureConstructors s = BlockStat
-  [ declClsConstr "h$c" ["f"] $ Closure
-      { clEntry  = var "f"
-      , clField1 = null_
-      , clField2 = null_
-      , clMeta   = 0
-      , clCC     = ccVal
-      }
-  , declClsConstr "h$c0" ["f"] $ Closure
-      { clEntry  = var "f"
-      , clField1 = null_
-      , clField2 = null_
-      , clMeta   = 0
-      , clCC     = ccVal
-      }
-  , declClsConstr "h$c1" ["f", "x1"] $ Closure
-      { clEntry  = var "f"
-      , clField1 = var "x1"
-      , clField2 = null_
-      , clMeta   = 0
-      , clCC     = ccVal
-      }
-  , declClsConstr "h$c2" ["f", "x1", "x2"] $ Closure
-      { clEntry  = var "f"
-      , clField1 = var "x1"
-      , clField2 = var "x2"
-      , clMeta   = 0
-      , clCC     = ccVal
-      }
-  , mconcat (map mkClosureCon [3..24])
-  , mconcat (map mkDataFill [1..24])
-  ]
-  where
-    prof = csProf s
-    (ccArg,ccVal)
-      -- the cc argument happens to be named just like the cc field...
-      | prof      = ([TxtI closureCC_], Just (var closureCC_))
-      | otherwise = ([], Nothing)
-    addCCArg as = map TxtI as ++ ccArg
-    addCCArg' as = as ++ ccArg
-
-    declClsConstr i as cl = TxtI i ||= ValExpr (JFunc (addCCArg as)
-      ( jVar $ \x ->
-          [ checkC
-          , x |= newClosure cl
-          , notifyAlloc x
-          , traceAlloc x
-          , returnS x
-          ]
-         ))
-
-    traceAlloc x | csTraceRts s = appS "h$traceAlloc" [x]
-                 | otherwise    = mempty
-
-    notifyAlloc x | csDebugAlloc s = appS "h$debugAlloc_notifyAlloc" [x]
-                  | otherwise      = mempty
-
-    -- only JSVal can typically contain undefined or null
-    -- although it's possible (and legal) to make other Haskell types
-    -- to contain JS refs directly
-    -- this can cause false positives here
-    checkC :: JStat
-    checkC | csAssertRts s =
-      jVar $ \msg ->
-      jwhenS (var "arguments" .! 0 .!==. jString "h$baseZCGHCziJSziPrimziJSVal_con_e")
-                                  (loop 1 (.<. var "arguments" .^ "length")
-                                          (\i ->
-                                             mconcat [msg |= jString "warning: undefined or null in argument: "
-                                                       + i
-                                                       + jString " allocating closure: " + (var "arguments" .! 0 .^ "n")
-                                                     , appS "h$log" [msg]
-                                                     , jwhenS (var "console" .&&. (var "console" .^ "trace")) ((var "console" .^ "trace") `ApplStat` [msg])
-                                                     , postIncrS i
-                                                     ])
-
-                                  )
-           | otherwise = mempty
-
-    -- h$d is never used for JSVal (since it's only for constructors with
-    -- at least three fields, so we always warn here
-    checkD | csAssertRts s =
-                     loop 0 (.<. var "arguments" .^ "length")
-                     (\i -> jwhenS ((var "arguments" .! i .===. null_)
-                                    .||. (var "arguments" .! i .===. undefined_))
-                            (jVar $ \msg ->
-                                mconcat [ msg |= jString "warning: undefined or null in argument: " + i + jString " allocating fields"
-                                        , jwhenS (var "console" .&&. (var "console" .^ "trace"))
-                                                ((var "console" .^ "trace") `ApplStat` [msg])
-                                        ]))
-
-           | otherwise = mempty
-
-    mkClosureCon :: Int -> JStat
-    mkClosureCon n = funName ||= toJExpr fun
-      where
-        funName = TxtI $ mkFastString ("h$c" ++ show n)
-        -- args are: f x1 x2 .. xn [cc]
-        args   = TxtI "f" : addCCArg' (map (TxtI . mkFastString . ('x':) . show) [(1::Int)..n])
-        fun    = JFunc args funBod
-        -- x1 goes into closureField1. All the other args are bundled into an
-        -- object in closureField2: { d1 = x2, d2 = x3, ... }
-        --
-        extra_args = ValExpr . JHash . listToUniqMap $ zip
-                   (map (mkFastString . ('d':) . show) [(1::Int)..])
-                   (map (toJExpr . TxtI . mkFastString . ('x':) . show) [2..n])
-
-        funBod = jVar $ \x ->
-            [ checkC
-            , x |= newClosure Closure
-               { clEntry  = var "f"
-               , clField1 = var "x1"
-               , clField2 = extra_args
-               , clMeta   = 0
-               , clCC     = ccVal
-               }
-            , notifyAlloc x
-            , traceAlloc x
-            , returnS x
-            ]
-
-    mkDataFill :: Int -> JStat
-    mkDataFill n = funName ||= toJExpr fun
-      where
-        funName    = TxtI $ mkFastString ("h$d" ++ show n)
-        ds         = map (mkFastString . ('d':) . show) [(1::Int)..n]
-        extra_args = ValExpr . JHash . listToUniqMap . zip ds $ map (toJExpr . TxtI) ds
-        fun        = JFunc (map TxtI ds) (checkD <> returnS extra_args)
-
--- | JS Payload to perform stack manipulation in the RTS
-stackManip :: JStat
-stackManip = mconcat (map mkPush [1..32]) <>
-             mconcat (map mkPpush [1..255])
-  where
-    mkPush :: Int -> JStat
-    mkPush n = let funName = TxtI $ mkFastString ("h$p" ++ show n)
-                   as      = map (TxtI . mkFastString . ('x':) . show) [1..n]
-                   fun     = JFunc as ((sp |= sp + toJExpr n)
-                                       <> mconcat (zipWith (\i a -> stack .! (sp - toJExpr (n-i)) |= toJExpr a)
-                                                   [1..] as))
-               in funName ||= toJExpr fun
-
-    -- partial pushes, based on bitmap, increases Sp by highest bit
-    mkPpush :: Integer -> JStat
-    mkPpush sig | sig Bits..&. (sig+1) == 0 = mempty -- already handled by h$p
-    mkPpush sig = let funName = TxtI $ mkFastString ("h$pp" ++ show sig)
-                      bits    = bitsIdx sig
-                      n       = length bits
-                      h       = last bits
-                      args    = map (TxtI . mkFastString . ('x':) . show) [1..n]
-                      fun     = JFunc args $
-                        mconcat [ sp |= sp + toJExpr (h+1)
-                                , mconcat (zipWith (\b a -> stack .! (sp - toJExpr (h-b)) |= toJExpr a) bits args)
-                                ]
-                   in funName ||= toJExpr fun
-
-bitsIdx :: Integer -> [Int]
-bitsIdx n | n < 0 = error "bitsIdx: negative"
-          | otherwise = go n 0
-  where
-    go 0 _ = []
-    go m b | Bits.testBit m b = b : go (Bits.clearBit m b) (b+1)
-           | otherwise   = go (Bits.clearBit m b) (b+1)
-
-bhLneStats :: StgToJSConfig -> JExpr -> JExpr -> JStat
-bhLneStats _s p frameSize =
-   jVar $ \v ->
-            mconcat [ v |= stack .! p
-                    , ifS v
-                      ((sp |= sp - frameSize)
-                       <> ifS (v .===. var "h$blackhole")
-                                (returnS $ app "h$throw" [var "h$baseZCControlziExceptionziBasezinonTermination", false_])
-                                (mconcat [r1 |= v
-                                         , sp |= sp - frameSize
-                                         , returnStack
-                                         ]))
-                      ((stack .! p |= var "h$blackhole") <> returnS null_)
-                    ]
-
-
--- | JS payload to declare the registers
-declRegs :: JStat
-declRegs =
-  mconcat [ TxtI "h$regs" ||= toJExpr (JList [])
-          , mconcat (map declReg (enumFromTo R1 R32))
-          , regGettersSetters
-          , loadRegs
-          ]
-    where
-      declReg r = (decl . TxtI . mkFastString . ("h$"++) . map toLower . show) r
-                  <> BlockStat [AssignStat (toJExpr r) (ValExpr (JInt 0))] -- [j| `r` = 0; |]
-
--- | JS payload to define getters and setters on the registers.
-regGettersSetters :: JStat
-regGettersSetters =
-  mconcat [ TxtI "h$getReg" ||= jLam (\n   -> SwitchStat n getRegCases mempty)
-          , TxtI "h$setReg" ||= jLam (\n v -> SwitchStat n (setRegCases v) mempty)
-          ]
-  where
-    getRegCases =
-      map (\r -> (toJExpr (jsRegToInt r) , returnS (toJExpr r))) regsFromR1
-    setRegCases v =
-      map (\r -> (toJExpr (jsRegToInt r), (toJExpr r |= toJExpr v) <> returnS undefined_)) regsFromR1
-
--- | JS payload that defines the functions to load each register
-loadRegs :: JStat
-loadRegs = mconcat $ map mkLoad [1..32]
-  where
-    mkLoad :: Int -> JStat
-    mkLoad n = let args   = map (TxtI . mkFastString . ("x"++) . show) [1..n]
-                   assign = zipWith (\a r -> toJExpr r |= toJExpr a)
-                              args (reverse $ take n regsFromR1)
-                   fname  = TxtI $ mkFastString ("h$l" ++ show n)
-                   fun    = JFunc args (mconcat assign)
-               in fname ||= toJExpr fun
-
--- | Assign registers R1 ... Rn in descending order, that is assign Rn first.
--- This function uses the 'assignRegs'' array to construct functions which set
--- the registers.
-assignRegs :: StgToJSConfig -> [JExpr] -> JStat
-assignRegs _ [] = mempty
-assignRegs s xs
-  | l <= 32 && not (csInlineLoadRegs s)
-      = ApplStat (ValExpr (JVar $ assignRegs'!l)) (reverse xs)
-  | otherwise = mconcat . reverse $
-      zipWith (\r ex -> toJExpr r |= ex) (take l regsFromR1) xs
-  where
-    l = length xs
-
--- | JS payload which defines an array of function symbols that set N registers
--- from M parameters. For example, h$l2 compiles to:
--- @
---    function h$l4(x1, x2, x3, x4) {
---      h$r4 = x1;
---      h$r3 = x2;
---      h$r2 = x3;
---      h$r1 = x4;
---    };
--- @
-assignRegs' :: Array Int Ident
-assignRegs' = listArray (1,32) (map (TxtI . mkFastString . ("h$l"++) . show) [(1::Int)..32])
-
--- | JS payload to declare return variables.
-declRets :: JStat
-declRets = mconcat $ map (decl . TxtI . mkFastString . ("h$"++) . map toLower . show) (enumFrom Ret1)
-
--- | JS payload defining the types closures.
-closureTypes :: JStat
-closureTypes = mconcat (map mkClosureType (enumFromTo minBound maxBound)) <> closureTypeName
-  where
-    mkClosureType :: ClosureType -> JStat
-    mkClosureType c = let s = TxtI . mkFastString $ "h$" ++ map toUpper (show c) ++ "_CLOSURE"
-                      in  s ||= toJExpr c
-    closureTypeName :: JStat
-    closureTypeName =
-      TxtI "h$closureTypeName" ||= jLam (\c ->
-                                           mconcat (map (ifCT c) [minBound..maxBound])
-                                          <> returnS (jString "InvalidClosureType"))
-
-    ifCT :: JExpr -> ClosureType -> JStat
-    ifCT arg ct = jwhenS (arg .===. toJExpr ct) (returnS (toJExpr (show ct)))
-
--- | JS payload declaring the RTS functions.
-rtsDecls :: JStat
-rtsDecls = jsSaturate (Just "h$RTSD") $
-  mconcat [ TxtI "h$currentThread"   ||= null_                   -- thread state object for current thread
-          , TxtI "h$stack"           ||= null_                   -- stack for the current thread
-          , TxtI "h$sp"              ||= 0                       -- stack pointer for the current thread
-          , TxtI "h$initStatic"      ||= toJExpr (JList [])      -- we need delayed initialization for static objects, push functions here to be initialized just before haskell runs
-          , TxtI "h$staticThunks"    ||= toJExpr (jhFromList []) --  funcName -> heapidx map for srefs
-          , TxtI "h$staticThunksArr" ||= toJExpr (JList [])      -- indices of updatable thunks in static heap
-          , TxtI "h$CAFs"            ||= toJExpr (JList [])
-          , TxtI "h$CAFsReset"       ||= toJExpr (JList [])
-          -- stg registers
-          , declRegs
-          , declRets]
-
--- | print the embedded RTS to a String
-rtsText :: StgToJSConfig -> String
-rtsText = show . pretty . rts
-
--- | print the RTS declarations to a String.
-rtsDeclsText :: String
-rtsDeclsText = show . pretty $ rtsDecls
-
--- | Wrapper over the RTS to guarentee saturation, see 'GHC.JS.Transform'
-rts :: StgToJSConfig -> JStat
-rts = jsSaturate (Just "h$RTS") . rts'
-
--- | JS Payload which defines the embedded RTS.
-rts' :: StgToJSConfig -> JStat
-rts' s =
-  mconcat [ closureConstructors s
-          , garbageCollector
-          , stackManip
-          , TxtI "h$rts_traceForeign" ||= toJExpr (csTraceForeign s)
-          , TxtI "h$rts_profiling"    ||= toJExpr (csProf s)
-          , TxtI "h$ct_fun"        ||= toJExpr Fun
-          , TxtI "h$ct_con"        ||= toJExpr Con
-          , TxtI "h$ct_thunk"      ||= toJExpr Thunk
-          , TxtI "h$ct_pap"        ||= toJExpr Pap
-          , TxtI "h$ct_blackhole"  ||= toJExpr Blackhole
-          , TxtI "h$ct_stackframe" ||= toJExpr StackFrame
-          , TxtI "h$vt_ptr"    ||= toJExpr PtrV
-          , TxtI "h$vt_void"   ||= toJExpr VoidV
-          , TxtI "h$vt_double" ||= toJExpr IntV
-          , TxtI "h$vt_long"   ||= toJExpr LongV
-          , TxtI "h$vt_addr"   ||= toJExpr AddrV
-          , TxtI "h$vt_rtsobj" ||= toJExpr RtsObjV
-          , TxtI "h$vt_obj"    ||= toJExpr ObjV
-          , TxtI "h$vt_arr"    ||= toJExpr ArrV
-          , TxtI "h$bh"        ||= jLam (bhStats s True)
-          , TxtI "h$bh_lne"    ||= jLam (\x frameSize -> bhLneStats s x frameSize)
-          , closure (ClosureInfo (TxtI "h$blackhole") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIBlackhole mempty)
-               (appS "throw" [jString "oops: entered black hole"])
-          , closure (ClosureInfo (TxtI "h$blackholeTrap") (CIRegs 0 []) "blackhole" (CILayoutUnknown 2) CIThunk mempty)
-               (appS "throw" [jString "oops: entered multiple times"])
-          , closure (ClosureInfo (TxtI "h$done") (CIRegs 0 [PtrV]) "done" (CILayoutUnknown 0) CIStackFrame mempty)
-               (appS "h$finishThread" [var "h$currentThread"] <> returnS (var "h$reschedule"))
-          , closure (ClosureInfo (TxtI "h$doneMain_e") (CIRegs 0 [PtrV]) "doneMain" (CILayoutUnknown 0) CIStackFrame mempty)
-               (returnS (var "h$doneMain"))
-          , conClosure (TxtI "h$false_e") "GHC.Types.False" (CILayoutFixed 0 []) 1
-          , conClosure (TxtI "h$true_e" ) "GHC.Types.True"  (CILayoutFixed 0 []) 2
-          -- generic data constructor with 1 non-heapobj field
-          , conClosure (TxtI "h$data1_e") "data1" (CILayoutFixed 1 [ObjV]) 1
-          -- generic data constructor with 2 non-heapobj fields
-          , conClosure (TxtI "h$data2_e") "data2" (CILayoutFixed 2 [ObjV,ObjV]) 1
-          , closure (ClosureInfo (TxtI "h$noop_e") (CIRegs 1 [PtrV]) "no-op IO ()" (CILayoutFixed 0 []) (CIFun 1 0) mempty)
-               (returnS (stack .! sp))
-            <> (TxtI "h$noop" ||= ApplExpr (var "h$c0") (var "h$noop_e" : [jSystemCCS | csProf s]))
-          , closure (ClosureInfo (TxtI "h$catch_e") (CIRegs 0 [PtrV]) "exception handler" (CILayoutFixed 2 [PtrV,IntV]) CIStackFrame mempty)
-               (adjSpN' 3 <> returnS (stack .! sp))
-          , closure (ClosureInfo (TxtI "h$dataToTag_e") (CIRegs 0 [PtrV]) "data to tag" (CILayoutFixed 0 []) CIStackFrame mempty)
-                $ mconcat [ r1 |= if_ (r1 .===. true_) 1 (if_ (typeof r1 .===. jTyObject) (r1 .^ "f" .^ "a" - 1) 0)
-                          , adjSpN' 1
-                          , returnS (stack .! sp)
-                          ]
-          -- function application to one argument
-          , closure (ClosureInfo (TxtI "h$ap1_e") (CIRegs 0 [PtrV]) "apply1" (CILayoutFixed 2 [PtrV, PtrV]) CIThunk mempty)
-               (jVar $ \d1 d2 ->
-                   mconcat [ d1 |= closureField1 r1
-                           , d2 |= closureField2 r1
-                           , appS "h$bh" []
-                           , profStat s enterCostCentreThunk
-                           , r1 |= d1
-                           , r2 |= d2
-                           , returnS (app "h$ap_1_1_fast" [])
-                           ])
-          -- function application to two arguments
-          , closure (ClosureInfo (TxtI "h$ap2_e") (CIRegs 0 [PtrV]) "apply2" (CILayoutFixed 3 [PtrV, PtrV, PtrV]) CIThunk mempty)
-               (jVar $ \d1 d2 d3 ->
-                   mconcat [ d1 |= closureField1 r1
-                           , d2 |= closureField2 r1 .^ "d1"
-                           , d3 |= closureField2 r1 .^ "d2"
-                           , appS "h$bh" []
-                           , profStat s enterCostCentreThunk
-                           , r1 |= d1
-                           , r2 |= d2
-                           , r3 |= d3
-                           , returnS (app "h$ap_2_2_fast" [])
-                           ])
-          -- function application to three arguments
-          , closure (ClosureInfo (TxtI "h$ap3_e") (CIRegs 0 [PtrV]) "apply3" (CILayoutFixed 4 [PtrV, PtrV, PtrV, PtrV]) CIThunk mempty)
-               (jVar $ \d1 d2 d3 d4 ->
-                   mconcat [ d1 |= closureField1 r1
-                           , d2 |= closureField2 r1 .^ "d1"
-                           , d3 |= closureField2 r1 .^ "d2"
-                           , d4 |= closureField2 r1 .^ "d3"
-                           , appS "h$bh" []
-                           , r1 |= d1
-                           , r2 |= d2
-                           , r3 |= d3
-                           , r4 |= d4
-                           , returnS (app "h$ap_3_3_fast" [])
-                           ])
-          -- select first field
-          , closure (ClosureInfo (TxtI "h$select1_e") (CIRegs 0 [PtrV]) "select1" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
-               (jVar $ \t ->
-                   mconcat [ t |= closureField1 r1
-                           , adjSp' 3
-                           , stack .! (sp - 2) |= r1
-                           , stack .! (sp - 1) |= var "h$upd_frame"
-                           , stack .! sp |= var "h$select1_ret"
-                           , closureEntry  r1 |= var "h$blackhole"
-                           , closureField1 r1 |= var "h$currentThread"
-                           , closureField2 r1 |= null_
-                           , r1 |= t
-                           , returnS (app "h$ap_0_0_fast" [])
-                           ])
-          , closure (ClosureInfo (TxtI "h$select1_ret") (CIRegs 0 [PtrV]) "select1ret" (CILayoutFixed 0 []) CIStackFrame mempty)
-               ((r1 |= closureField1 r1)
-                <> adjSpN' 1
-                <> returnS (app "h$ap_0_0_fast" [])
-               )
-          -- select second field of a two-field constructor
-          , closure (ClosureInfo (TxtI "h$select2_e") (CIRegs 0 [PtrV]) "select2" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
-               (jVar $ \t ->
-                   mconcat [t |= closureField1 r1
-                           , adjSp' 3
-                           , stack .! (sp - 2) |= r1
-                           , stack .! (sp - 1) |= var "h$upd_frame"
-                           , stack .! sp |= var "h$select2_ret"
-                           , closureEntry  r1 |= var "h$blackhole"
-                           , closureField1 r1 |= var "h$currentThread"
-                           , closureField2 r1 |= null_
-                           , r1 |= t
-                           , returnS (app "h$ap_0_0_fast" [])
-                           ]
-                  )
-          , closure (ClosureInfo (TxtI "h$select2_ret") (CIRegs 0 [PtrV]) "select2ret" (CILayoutFixed 0 []) CIStackFrame mempty)
-                        $ mconcat [ r1 |= closureField2 r1
-                                  , adjSpN' 1
-                                  , returnS (app "h$ap_0_0_fast" [])
-                                  ]
-          , closure (ClosureInfo (TxtI "h$keepAlive_e") (CIRegs 0 [PtrV]) "keepAlive" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
-                    (mconcat [ adjSpN' 2
-                             , returnS (stack .! sp)
-                             ]
-                    )
-          -- a thunk that just raises a synchronous exception
-          , closure (ClosureInfo (TxtI "h$raise_e") (CIRegs 0 [PtrV]) "h$raise_e" (CILayoutFixed 0 []) CIThunk mempty)
-               (returnS (app "h$throw" [closureField1 r1, false_]))
-          , closure (ClosureInfo (TxtI "h$raiseAsync_e") (CIRegs 0 [PtrV]) "h$raiseAsync_e" (CILayoutFixed 0 []) CIThunk mempty)
-               (returnS  (app "h$throw" [closureField1 r1, true_]))
-          , closure (ClosureInfo (TxtI "h$raiseAsync_frame") (CIRegs 0 []) "h$raiseAsync_frame" (CILayoutFixed 1 []) CIStackFrame mempty)
-               (jVar $ \ex ->
-                   mconcat [ ex |= stack .! (sp - 1)
-                           , adjSpN' 2
-                           , returnS (app "h$throw" [ex, true_])
-                           ])
-          {- reduce result if it's a thunk, follow if it's an ind
-             add this to the stack if you want the outermost result
-             to always be reduced to whnf, and not an ind
-          -}
-          , closure (ClosureInfo (TxtI "h$reduce") (CIRegs 0 [PtrV]) "h$reduce" (CILayoutFixed 0 []) CIStackFrame mempty)
-               (ifS (isThunk r1)
-                    (returnS (r1 .^ "f"))
-                    (adjSpN' 1 <> returnS (stack .! sp))
-               )
-          , rtsApply s
-          , closureTypes
-          , closure (ClosureInfo (TxtI "h$runio_e") (CIRegs 0 [PtrV]) "runio" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
-                        $ mconcat [ r1 |= closureField1 r1
-                                  , stack .! PreInc sp |= var "h$ap_1_0"
-                                  , returnS (var "h$ap_1_0")
-                                  ]
-          , closure (ClosureInfo (TxtI "h$flushStdout_e") (CIRegs 0 []) "flushStdout" (CILayoutFixed 0 []) CIThunk mempty)
-                        $ mconcat [ r1 |= var "h$baseZCGHCziIOziHandlezihFlush"
-                                  , r2 |= var "h$baseZCGHCziIOziHandleziFDzistdout"
-                                  , returnS (app "h$ap_1_1_fast" [])
-                                  ]
-          , TxtI "h$flushStdout" ||= app "h$static_thunk" [var "h$flushStdout_e"]
-          -- the scheduler pushes this frame when suspending a thread that
-          -- has not called h$reschedule explicitly
-          , closure (ClosureInfo (TxtI "h$restoreThread") (CIRegs 0 []) "restoreThread" CILayoutVariable CIStackFrame mempty)
-                (jVar $ \f frameSize nregs ->
-                    mconcat [f |= stack .! (sp - 2)
-                            , frameSize |= stack .! (sp - 1)
-                            , nregs |= frameSize - 3
-                            , loop 1 (.<=. nregs)
-                                     (\i -> appS "h$setReg" [i, stack .! (sp - 2 - i)] <> postIncrS i)
-                            , sp |= sp - frameSize
-                            , returnS f
-                            ])
-          -- return a closure in the stack frame to the next thing on the stack
-          , closure (ClosureInfo (TxtI "h$return") (CIRegs 0 []) "return" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
-                ((r1 |= stack .! (sp - 1))
-                 <> adjSpN' 2
-                 <> returnS (stack .! sp))
-          --  return a function in the stack frame for the next call
-          , closure (ClosureInfo (TxtI "h$returnf") (CIRegs 0 [PtrV]) "returnf" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)
-                (jVar $ \r ->
-                    mconcat [ r |= stack .! (sp - 1)
-                            , adjSpN' 2
-                            , returnS r
-                            ])
-          -- return this function when the scheduler needs to come into action
-          -- (yield, delay etc), returning thread needs to push all relevant
-          -- registers to stack frame, thread will be resumed by calling the stack top
-          , closure (ClosureInfo (TxtI "h$reschedule") (CIRegs 0 []) "reschedule" (CILayoutFixed 0 []) CIThunk mempty)
-                (returnS $ var "h$reschedule")
-          -- debug thing, insert on stack to dump current result, should be boxed
-          , closure (ClosureInfo (TxtI "h$dumpRes") (CIRegs 0 [PtrV]) "dumpRes" (CILayoutFixed 1 [ObjV]) CIThunk mempty)
-                (jVar $ \re ->
-                    mconcat [ appS "h$log" [jString "h$dumpRes result: " + stack .! (sp-1)]
-                            , appS "h$log" [r1]
-                            , appS "h$log" [app "h$collectProps" [r1]]
-                            , jwhenS ((r1 .^ "f") .&&. (r1 .^ "f" .^ "n"))
-                                        (appS "h$log" [jString "name: " + r1 .^ "f" .^ "n"])
-                            , jwhenS (ApplExpr (r1 .^ "hasOwnProperty") [jString closureField1_])
-                                        (appS "h$log" [jString "d1: " + closureField1 r1])
-                            , jwhenS (ApplExpr (r1 .^ "hasOwnProperty") [jString closureField2_])
-                                        (appS "h$log" [jString "d2: " + closureField2 r1])
-                            , jwhenS (r1 .^ "f") $ mconcat
-                                [ re |= New (app "RegExp" [jString "([^\\n]+)\\n(.|\\n)*"])
-                                , appS "h$log" [jString "function"
-                                                + ApplExpr (ApplExpr ((jString "" + r1 .^ "f") .^ "substring") [0, 50] .^ "replace") [r1, jString "$1"]]
-                                ]
-                            , adjSpN' 2
-                            , r1 |= null_
-                            , returnS (stack .! sp)
-                            ])
-          , closure (ClosureInfo (TxtI "h$resume_e") (CIRegs 0 [PtrV]) "resume" (CILayoutFixed 0 []) CIThunk mempty)
-                  (jVar $ \ss ->
-                      mconcat [ss |= closureField1 r1
-                              , updateThunk' s
-                              , loop 0 (.<. ss .^ "length") (\i -> (stack .! (sp+1+i) |= ss .! i)
-                                                                   <> postIncrS i)
-                              , sp |= sp + ss .^ "length"
-                              , r1 |= null_
-                              , returnS (stack .! sp)
-                              ])
-          , closure (ClosureInfo (TxtI "h$unmaskFrame") (CIRegs 0 [PtrV]) "unmask" (CILayoutFixed 0 []) CIStackFrame mempty)
-               ((var "h$currentThread" .^ "mask" |= 0)
-                <> adjSpN' 1
-                -- back to scheduler to give us async exception if pending
-                <> ifS (var "h$currentThread" .^ "excep" .^ "length" .>. 0)
-                    (push' s [r1, var "h$return"] <> returnS (var "h$reschedule"))
-                    (returnS (stack .! sp)))
-          , closure (ClosureInfo (TxtI "h$maskFrame") (CIRegs 0 [PtrV]) "mask" (CILayoutFixed 0 []) CIStackFrame mempty)
-                ((var "h$currentThread" .^ "mask" |= 2)
-                 <> adjSpN' 1
-                 <> returnS (stack .! sp))
-          , closure (ClosureInfo (TxtI "h$maskUnintFrame") (CIRegs 0 [PtrV]) "maskUnint" (CILayoutFixed 0 []) CIStackFrame mempty)
-                ((var "h$currentThread" .^ "mask" |= 1)
-                 <> adjSpN' 1
-                 <> returnS (stack .! sp))
-          , closure (ClosureInfo (TxtI "h$unboxFFIResult") (CIRegs 0 [PtrV]) "unboxFFI" (CILayoutFixed 0 []) CIStackFrame mempty)
-               (jVar $ \d ->
-                   mconcat [d |= closureField1 r1
-                           , loop 0 (.<. d .^ "length") (\i -> appS "h$setReg" [i + 1, d .! i] <> postIncrS i)
-                           , adjSpN' 1
-                           , returnS (stack .! sp)
-                           ])
-          , closure (ClosureInfo (TxtI "h$unbox_e") (CIRegs 0 [PtrV]) "unboxed value" (CILayoutFixed 1 [DoubleV]) CIThunk mempty)
-               ((r1 |= closureField1 r1) <> returnS (stack .! sp))
-          , closure (ClosureInfo (TxtI "h$retryInterrupted") (CIRegs 0 [ObjV]) "retry interrupted operation" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)
-               (jVar $ \a ->
-                   mconcat [ a |= stack .! (sp - 1)
-                           , adjSpN' 2
-                           , returnS (ApplExpr (a .! 0 .^ "apply") [var "this", ApplExpr (a .^ "slice") [1]])
-                           ])
-          , closure (ClosureInfo (TxtI "h$atomically_e") (CIRegs 0 [PtrV]) "atomic operation" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
-               (ifS (app "h$stmValidateTransaction" [])
-                    (appS "h$stmCommitTransaction" []
-                     <> adjSpN' 2
-                     <> returnS (stack .! sp))
-                    (returnS (app "h$stmStartTransaction" [stack .! (sp - 1)])))
-
-          , closure (ClosureInfo (TxtI "h$stmCatchRetry_e") (CIRegs 0 [PtrV]) "catch retry" (CILayoutFixed 1 [PtrV]) CIStackFrame mempty)
-                        (adjSpN' 2
-                         <> appS "h$stmCommitTransaction" []
-                         <> returnS (stack .! sp))
-          , closure (ClosureInfo (TxtI "h$catchStm_e") (CIRegs 0 [PtrV]) "STM catch" (CILayoutFixed 3 [ObjV,PtrV,ObjV]) CIStackFrame mempty)
-                       (adjSpN' 4
-                       <> appS "h$stmCommitTransaction" []
-                       <> returnS (stack .! sp))
-          , closure (ClosureInfo (TxtI "h$stmResumeRetry_e") (CIRegs 0 [PtrV]) "resume retry" (CILayoutFixed 0 []) CIStackFrame mempty)
-                        (jVar $ \blocked ->
-                            mconcat [ jwhenS (stack .! (sp - 2) .!==. var "h$atomically_e")
-                                                 (appS "throw" [jString "h$stmResumeRetry_e: unexpected value on stack"])
-                                    , blocked |= stack .! (sp - 1)
-                                    , adjSpN' 2
-                                    , appS "h$stmRemoveBlockedThread" [blocked, var "h$currentThread"]
-                                    , returnS (app "h$stmStartTransaction" [stack .! (sp - 1)])
-                                    ])
-          , closure (ClosureInfo (TxtI "h$lazy_e") (CIRegs 0 [PtrV]) "generic lazy value" (CILayoutFixed 0 []) CIThunk mempty)
-                        (jVar $ \x ->
-                            mconcat [x |= ApplExpr (closureField1 r1) []
-                                    , appS "h$bh" []
-                                    , profStat s enterCostCentreThunk
-                                    , r1 |= x
-                                    , returnS (stack .! sp)
-                                    ])
-          -- Top-level statements to generate only in profiling mode
-          , profStat s (closure (ClosureInfo (TxtI "h$setCcs_e") (CIRegs 0 [PtrV]) "set cost centre stack" (CILayoutFixed 1 [ObjV]) CIStackFrame mempty)
-                        (appS "h$restoreCCS" [ stack .! (sp - 1)]
-                         <> adjSpN' 2
-                         <> returnS (stack .! sp)))
-          ]
diff --git a/compiler/GHC/StgToJS/Rts/Types.hs b/compiler/GHC/StgToJS/Rts/Types.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Rts/Types.hs
+++ /dev/null
@@ -1,78 +0,0 @@
-{-# LANGUAGE CPP,
-             FlexibleInstances,
-             OverloadedStrings #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.StgToJS.Rts.Apply
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
--- Types and utility functions used in the JS RTS.
------------------------------------------------------------------------------
-
-module GHC.StgToJS.Rts.Types where
-
-import GHC.Prelude
-
-import GHC.JS.Make
-import GHC.JS.Syntax
-import GHC.StgToJS.Regs
-import GHC.StgToJS.Types
-
---------------------------------------------------------------------------------
--- Syntactic Sugar for some Utilities we want in JS land
---------------------------------------------------------------------------------
-
--- | Syntactic sugar, i.e., a Haskell function which generates useful JS code.
--- Given a @JExpr@, 'ex', inject a trace statement on 'ex' in the compiled JS
--- program
-traceRts :: StgToJSConfig -> JExpr -> JStat
-traceRts s ex | (csTraceRts s)  = appS "h$log" [ex]
-              | otherwise       = mempty
-
--- | Syntactic sugar. Given a @JExpr@, 'ex' which is assumed to be a predicate,
--- and a message 'm', assert that 'not ex' is True, if not throw an exception in
--- JS land with message 'm'.
-assertRts :: ToJExpr a => StgToJSConfig -> JExpr -> a -> JStat
-assertRts s ex m | csAssertRts s = jwhenS (UOpExpr NotOp ex) (appS "throw" [toJExpr m])
-                 | otherwise     = mempty
-
--- | name of the closure 'c'
-clName :: JExpr -> JExpr
-clName c = c .^ "n"
-
--- | Type name of the closure 'c'
-clTypeName :: JExpr -> JExpr
-clTypeName c = app "h$closureTypeName" [c .^ "t"]
-
--- number of  arguments (arity & 0xff = arguments, arity >> 8 = number of registers)
-stackFrameSize :: JExpr -- ^ assign frame size to this
-               -> JExpr -- ^ stack frame header function
-               -> JStat -- ^ size of the frame, including header
-stackFrameSize tgt f =
-  ifS (f .===. var "h$ap_gen") -- h$ap_gen is special
-      (tgt |= (stack .! (sp - 1) .>>. 8) + 2)
-      (jVar (\tag ->
-               mconcat
-               [tag |= f .^ "size"
-               , ifS (tag .<. 0)              -- if tag is less than 0
-                 (tgt |= stack .! (sp - 1))   -- set target to stack pointer - 1
-                 (tgt |= mask8 tag + 1)       -- else set to mask'd tag + 1
-               ]
-        ))
-
---------------------------------------------------------------------------------
--- Register utilities
---------------------------------------------------------------------------------
-
--- | Perform the computation 'f', on the range of registers bounded by 'start'
--- and 'end'.
-withRegs :: StgReg -> StgReg -> (StgReg -> JStat) -> JStat
-withRegs start end f = mconcat $ fmap f [start..end]
diff --git a/compiler/GHC/StgToJS/Sinker.hs b/compiler/GHC/StgToJS/Sinker.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Sinker.hs
+++ /dev/null
@@ -1,180 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE LambdaCase #-}
-
-module GHC.StgToJS.Sinker (sinkPgm) where
-
-import GHC.Prelude
-import GHC.Types.Unique.Set
-import GHC.Types.Unique.FM
-import GHC.Types.Var.Set
-import GHC.Stg.Syntax
-import GHC.Types.Id
-import GHC.Types.Name
-import GHC.Unit.Module
-import GHC.Types.Literal
-import GHC.Data.Graph.Directed
-
-import GHC.StgToJS.CoreUtils
-
-import Data.Char
-import Data.Either
-import Data.List (partition)
-import Data.Maybe
-
-
--- | Unfloat some top-level unexported things
---
--- GHC floats constants to the top level. This is fine in native code, but with JS
--- they occupy some global variable name. We can unfloat some unexported things:
---
--- - global constructors, as long as they're referenced only once by another global
---      constructor and are not in a recursive binding group
--- - literals (small literals may also be sunk if they are used more than once)
-sinkPgm :: Module
-        -> [CgStgTopBinding]
-        -> (UniqFM Id CgStgExpr, [CgStgTopBinding])
-sinkPgm m pgm = (sunk, map StgTopLifted pgm'' ++ stringLits)
-  where
-    selectLifted (StgTopLifted b) = Left b
-    selectLifted x                = Right x
-    (pgm', stringLits) = partitionEithers (map selectLifted pgm)
-    (sunk, pgm'')      = sinkPgm' m pgm'
-
-sinkPgm'
-  :: Module
-       -- ^ the module, since we treat definitions from the current module
-       -- differently
-  -> [CgStgBinding]
-       -- ^ the bindings
-  -> (UniqFM Id CgStgExpr, [CgStgBinding])
-       -- ^ a map with sunken replacements for nodes, for where the replacement
-       -- does not fit in the 'StgBinding' AST and the new bindings
-sinkPgm' m pgm =
-  let usedOnce = collectUsedOnce pgm
-      sinkables = listToUFM $
-          concatMap alwaysSinkable pgm ++
-          filter ((`elementOfUniqSet` usedOnce) . fst) (concatMap (onceSinkable m) pgm)
-      isSunkBind (StgNonRec b _e) | elemUFM b sinkables = True
-      isSunkBind _                                      = False
-  in (sinkables, filter (not . isSunkBind) $ topSortDecls m pgm)
-
--- | always sinkable, values that may be duplicated in the generated code (e.g.
--- small literals)
-alwaysSinkable :: CgStgBinding -> [(Id, CgStgExpr)]
-alwaysSinkable (StgRec {})       = []
-alwaysSinkable (StgNonRec b rhs) = case rhs of
-  StgRhsClosure _ _ _ _ e@(StgLit l)
-    | isSmallSinkableLit l
-    , isLocal b
-    -> [(b,e)]
-  StgRhsCon _ccs dc cnum _ticks as@[StgLitArg l]
-    | isSmallSinkableLit l
-    , isLocal b
-    , isUnboxableCon dc
-    -> [(b,StgConApp dc cnum as [])]
-  _ -> []
-
-isSmallSinkableLit :: Literal -> Bool
-isSmallSinkableLit (LitChar c)     = ord c < 100000
-isSmallSinkableLit (LitNumber _ i) = abs i < 100000
-isSmallSinkableLit _               = False
-
-
--- | once sinkable: may be sunk, but duplication is not ok
-onceSinkable :: Module -> CgStgBinding -> [(Id, CgStgExpr)]
-onceSinkable _m (StgNonRec b rhs)
-  | Just e <- getSinkable rhs
-  , isLocal b = [(b,e)]
-  where
-    getSinkable = \case
-      StgRhsCon _ccs dc cnum _ticks args -> Just (StgConApp dc cnum args [])
-      StgRhsClosure _ _ _ _ e@(StgLit{}) -> Just e
-      _                                  -> Nothing
-onceSinkable _ _ = []
-
--- | collect all idents used only once in an argument at the top level
---   and never anywhere else
-collectUsedOnce :: [CgStgBinding] -> IdSet
-collectUsedOnce binds = intersectUniqSets (usedOnce args) (usedOnce top_args)
-  where
-    top_args = concatMap collectArgsTop binds
-    args     = concatMap collectArgs    binds
-    usedOnce = fst . foldr g (emptyUniqSet, emptyUniqSet)
-    g i t@(once, mult)
-      | i `elementOfUniqSet` mult = t
-      | i `elementOfUniqSet` once
-        = (delOneFromUniqSet once i, addOneToUniqSet mult i)
-      | otherwise = (addOneToUniqSet once i, mult)
-
--- | fold over all id in StgArg used at the top level in an StgRhsCon
-collectArgsTop :: CgStgBinding -> [Id]
-collectArgsTop = \case
-  StgNonRec _b r -> collectArgsTopRhs r
-  StgRec bs      -> concatMap (collectArgsTopRhs . snd) bs
-
-collectArgsTopRhs :: CgStgRhs -> [Id]
-collectArgsTopRhs = \case
-  StgRhsCon _ccs _dc _mu _ticks args -> concatMap collectArgsA args
-  StgRhsClosure {}                   -> []
-
--- | fold over all Id in StgArg in the AST
-collectArgs :: CgStgBinding -> [Id]
-collectArgs = \case
-  StgNonRec _b r -> collectArgsR r
-  StgRec bs      -> concatMap (collectArgsR . snd) bs
-
-collectArgsR :: CgStgRhs -> [Id]
-collectArgsR = \case
-  StgRhsClosure _x0 _x1 _x2 _x3 e     -> collectArgsE e
-  StgRhsCon _ccs _con _mu _ticks args -> concatMap collectArgsA args
-
-collectArgsAlt :: CgStgAlt -> [Id]
-collectArgsAlt alt = collectArgsE (alt_rhs alt)
-
-collectArgsE :: CgStgExpr -> [Id]
-collectArgsE = \case
-  StgApp x args
-    -> x : concatMap collectArgsA args
-  StgConApp _con _mn args _ts
-    -> concatMap collectArgsA args
-  StgOpApp _x args _t
-    -> concatMap collectArgsA args
-  StgCase e _b _a alts
-    -> collectArgsE e ++ concatMap collectArgsAlt alts
-  StgLet _x b e
-    -> collectArgs b ++ collectArgsE e
-  StgLetNoEscape _x b e
-    -> collectArgs b ++ collectArgsE e
-  StgTick _i e
-    -> collectArgsE e
-  StgLit _
-    -> []
-
-collectArgsA :: StgArg -> [Id]
-collectArgsA = \case
-  StgVarArg i -> [i]
-  StgLitArg _ -> []
-
-isLocal :: Id -> Bool
-isLocal i = isNothing (nameModule_maybe . idName $ i) && not (isExportedId i)
-
--- | since we have sequential initialization, topsort the non-recursive
--- constructor bindings
-topSortDecls :: Module -> [CgStgBinding] -> [CgStgBinding]
-topSortDecls _m binds = rest ++ nr'
-  where
-    (nr, rest) = partition isNonRec binds
-    isNonRec StgNonRec{} = True
-    isNonRec _           = False
-    vs   = map getV nr
-    keys = mkUniqSet (map node_key vs)
-    getV e@(StgNonRec b _) = DigraphNode e b []
-    getV _                 = error "topSortDecls: getV, unexpected binding"
-    collectDeps (StgNonRec b (StgRhsCon _cc _dc _cnum _ticks args)) =
-      [ (i, b) | StgVarArg i <- args, i `elementOfUniqSet` keys ]
-    collectDeps _ = []
-    g = graphFromVerticesAndAdjacency vs (concatMap collectDeps nr)
-    nr' | (not . null) [()| CyclicSCC _ <- stronglyConnCompG g]
-            = error "topSortDecls: unexpected cycle"
-        | otherwise = map node_payload (topologicalSortG g)
diff --git a/compiler/GHC/StgToJS/Stack.hs b/compiler/GHC/StgToJS/Stack.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Stack.hs
+++ /dev/null
@@ -1,373 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.JS.Stack
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
--- Utilities and wrappers for Stack manipulation in JS Land.
---
--- In general, functions suffixed with a tick do the actual work, functions
--- suffixed with an "I" are identical to the non-I versions but work on 'Ident's
---
--- The stack in JS land is held in the special JS array 'h$stack' and the stack
--- pointer is held in 'h$sp'. The top of the stack thus exists at
--- 'h$stack[h$sp]'. h$stack[h$sp + i] where i > 0, moves deeper into the stack
--- into older entries, whereas h$stack[h$sp - i] moves towards the top of the
--- stack.
---
--- The stack layout algorithm is slightly peculiar. It makes an effort to
--- remember recently popped things so that if these values need to be pushed
--- then they can be quickly. The implementation for this is storing these values
--- above the stack pointer, and the pushing will skip slots that we know we will
--- use and fill in slots marked as unknown. Thus, you may find that our push and
--- pop functions do some non-traditional stack manipulation such as adding slots
--- in pop or removing slots in push.
------------------------------------------------------------------------------
-
-module GHC.StgToJS.Stack
-  ( resetSlots
-  , isolateSlots
-  , setSlots
-  , getSlots
-  , addSlots
-  , dropSlots
-  , addUnknownSlots
-  , push
-  , push'
-  , adjSpN
-  , adjSpN'
-  , adjSp'
-  , adjSp
-  , pushNN
-  , pushNN'
-  , pushN'
-  , pushN
-  , pushOptimized'
-  , pushOptimized
-  , pushLneFrame
-  , popN
-  , popSkip
-  , popSkipI
-  , loadSkip
-  -- * Thunk update
-  , updateThunk
-  , updateThunk'
-  , bhStats
-  )
-where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax
-import GHC.JS.Make
-
-import GHC.StgToJS.Types
-import GHC.StgToJS.Monad
-import GHC.StgToJS.Ids
-import GHC.StgToJS.ExprCtx
-import GHC.StgToJS.Heap
-import GHC.StgToJS.Regs
-
-import GHC.Types.Id
-import GHC.Utils.Misc
-import GHC.Data.FastString
-
-import qualified Data.Bits as Bits
-import qualified Data.List as L
-import qualified Control.Monad.Trans.State.Strict as State
-import Data.Array
-import Data.Monoid
-import Control.Monad
-
--- | Run the action, 'm', with no stack info
-resetSlots :: G a -> G a
-resetSlots m = do
-  s <- getSlots
-  d <- getStackDepth
-  setSlots []
-  a <- m
-  setSlots s
-  setStackDepth d
-  return a
-
--- | run the action, 'm', with current stack info, but don't let modifications
--- propagate
-isolateSlots :: G a -> G a
-isolateSlots m = do
-  s <- getSlots
-  d <- getStackDepth
-  a <- m
-  setSlots s
-  setStackDepth d
-  pure a
-
--- | Set stack depth
-setStackDepth :: Int -> G ()
-setStackDepth d = modifyGroup (\s -> s { ggsStackDepth = d})
-
--- | Get stack depth
-getStackDepth :: G Int
-getStackDepth = State.gets (ggsStackDepth . gsGroup)
-
--- | Modify stack depth
-modifyStackDepth :: (Int -> Int) -> G ()
-modifyStackDepth f = modifyGroup (\s -> s { ggsStackDepth = f (ggsStackDepth s) })
-
--- | overwrite our stack knowledge
-setSlots :: [StackSlot] -> G ()
-setSlots xs = modifyGroup (\g -> g { ggsStack = xs})
-
--- | retrieve our current stack knowledge
-getSlots :: G [StackSlot]
-getSlots = State.gets (ggsStack . gsGroup)
-
--- | Modify stack slots
-modifySlots :: ([StackSlot] -> [StackSlot]) -> G ()
-modifySlots f = modifyGroup (\g -> g { ggsStack = f (ggsStack g)})
-
--- | add `n` unknown slots to our stack knowledge
-addUnknownSlots :: Int -> G ()
-addUnknownSlots n = addSlots (replicate n SlotUnknown)
-
--- | add knowledge about the stack slots
-addSlots :: [StackSlot] -> G ()
-addSlots xs = do
-  s <- getSlots
-  setSlots (xs ++ s)
-
--- | drop 'n' slots from our stack knowledge
-dropSlots :: Int -> G ()
-dropSlots n = modifySlots (drop n)
-
-push :: [JExpr] -> G JStat
-push xs = do
-  dropSlots (length xs)
-  modifyStackDepth (+ (length xs))
-  flip push' xs <$> getSettings
-
-push' :: StgToJSConfig -> [JExpr] -> JStat
-push' _ [] = mempty
-push' cs xs
-   | csInlinePush cs || l > 32 || l < 2 = adjSp' l <> mconcat items
-   | otherwise                          = ApplStat (toJExpr $ pushN ! l) xs
-  where
-    items = zipWith f [(1::Int)..] xs
-    offset i | i == l    = sp
-             | otherwise = InfixExpr SubOp sp (toJExpr (l - i))
-    l = length xs
-    f i e = AssignStat ((IdxExpr stack) (toJExpr (offset i))) (toJExpr e)
-
-
--- | Grow the stack pointer by 'n' without modifying the stack depth. The stack
--- is just a JS array so we add to grow (instead of the traditional subtract)
-adjSp' :: Int -> JStat
-adjSp' 0 = mempty
-adjSp' n = sp |= InfixExpr AddOp sp (toJExpr n)
-
--- | Shrink the stack pointer by 'n'. The stack grows downward so substract
-adjSpN' :: Int -> JStat
-adjSpN' 0 = mempty
-adjSpN' n = sp |= InfixExpr SubOp sp (toJExpr n)
-
--- | Wrapper which adjusts the stack pointer /and/ modifies the stack depth
--- tracked in 'G'. See also 'adjSp'' which actually does the stack pointer
--- manipulation.
-adjSp :: Int -> G JStat
-adjSp 0 = return mempty
-adjSp n = do
-  -- grow depth by n
-  modifyStackDepth (+n)
-  return (adjSp' n)
-
--- | Shrink the stack and stack pointer. NB: This function is unsafe when the
--- input 'n', is negative. This function wraps around 'adjSpN' which actually
--- performs the work.
-adjSpN :: Int -> G JStat
-adjSpN 0 = return mempty
-adjSpN n = do
-  modifyStackDepth (\x -> x - n)
-  return (adjSpN' n)
-
--- | A constant array that holds global function symbols which do N pushes onto
--- the stack. For example:
--- @
--- function h$p1(x1) {
---   ++h$sp;
---   h$stack[(h$sp - 0)] = x1;
--- };
--- function h$p2(x1, x2) {
---   h$sp += 2;
---   h$stack[(h$sp - 1)] = x1;
---   h$stack[(h$sp - 0)] = x2;
--- };
--- @
---
--- and so on up to 32.
-pushN :: Array Int Ident
-pushN = listArray (1,32) $ map (TxtI . mkFastString . ("h$p"++) . show) [(1::Int)..32]
-
--- | Convert all function symbols in 'pushN' to global top-level functions. This
--- is a hack which converts the function symbols to variables. This hack is
--- caught in 'GHC.StgToJS.Printer.prettyBlock'' to turn these into global
--- functions.
-pushN' :: Array Int JExpr
-pushN' = fmap (ValExpr . JVar) pushN
-
--- | Partial Push functions. Like 'pushN' except these push functions skip
--- slots. For example,
--- @
--- function h$pp33(x1, x2) {
---   h$sp += 6;
---   h$stack[(h$sp - 5)] = x1;
---   h$stack[(h$sp - 0)] = x2;
--- };
--- @
---
--- The 33rd entry skips slots 1-4 to bind the top of the stack and the 6th
--- slot. See 'pushOptimized' and 'pushOptimized'' for use cases.
-pushNN :: Array Integer Ident
-pushNN = listArray (1,255) $ map (TxtI . mkFastString . ("h$pp"++) . show) [(1::Int)..255]
-
--- | Like 'pushN'' but for the partial push functions
-pushNN' :: Array Integer JExpr
-pushNN' = fmap (ValExpr . JVar) pushNN
-
-pushOptimized' :: [(Id,Int)] -> G JStat
-pushOptimized' xs = do
-  slots  <- getSlots
-  pushOptimized =<< (zipWithM f xs (slots++repeat SlotUnknown))
-  where
-    f (i1,n1) xs2 = do
-      xs <- varsForId i1
-      let !id_n1 = xs !! (n1-1)
-
-      case xs2 of
-        SlotId i2 n2 -> pure (id_n1,i1==i2&&n1==n2)
-        _            -> pure (id_n1,False)
-
--- | optimized push that reuses existing values on stack automatically chooses
--- an optimized partial push (h$ppN) function when possible.
-pushOptimized :: [(JExpr,Bool)] -- ^ contents of the slots, True if same value is already there
-              -> G JStat
-pushOptimized [] = return mempty
-pushOptimized xs = do
-  dropSlots l
-  modifyStackDepth (+ length xs)
-  go .  csInlinePush <$> getSettings
-  where
-    go True = inlinePush
-    go _
-     | all snd xs                  = adjSp' l
-     | all (not.snd) xs && l <= 32 =
-        ApplStat (pushN' ! l) (map fst xs)
-     | l <= 8 && not (snd $ last xs) =
-        ApplStat (pushNN' ! sig) [ e | (e,False) <- xs ]
-     | otherwise = inlinePush
-    l   = length xs
-    sig :: Integer
-    sig = L.foldl1' (Bits..|.) $ zipWith (\(_e,b) i -> if not b then Bits.bit i else 0) xs [0..]
-    inlinePush = adjSp' l <> mconcat (zipWith pushSlot [1..] xs)
-    pushSlot i (ex, False) = IdxExpr stack (offset i) |= ex
-    pushSlot _ _           = mempty
-    offset i | i == l    = sp
-             | otherwise = InfixExpr SubOp sp (toJExpr (l - i))
-
--- | push a let-no-escape frame onto the stack
-pushLneFrame :: HasDebugCallStack => Int -> ExprCtx -> G JStat
-pushLneFrame size ctx =
-  let ctx' = ctxLneShrinkStack ctx size
-  in pushOptimized' (ctxLneFrameVars ctx')
-
--- | Pop things, don't update the stack knowledge in 'G'
-popSkip :: Int      -- ^ number of slots to skip
-         -> [JExpr] -- ^ assign stack slot values to these
-         -> JStat
-popSkip 0 []  = mempty
-popSkip n []  = adjSpN' n
-popSkip n tgt = loadSkip n tgt <> adjSpN' (length tgt + n)
-
--- | Load 'length (xs :: [JExpr])' things from the stack at offset 'n :: Int'.
--- This function does no stack pointer manipulation, it merely indexes into the
--- stack and loads payloads into 'xs'.
-loadSkip :: Int -> [JExpr] -> JStat
-loadSkip = loadSkipFrom sp
-  where
-    loadSkipFrom :: JExpr -> Int -> [JExpr] -> JStat
-    loadSkipFrom fr n xs = mconcat items
-      where
-        items = reverse $ zipWith f [(0::Int)..] (reverse xs)
-        -- helper to generate sp - n offset to index with
-        offset 0 = fr
-        offset n = InfixExpr SubOp fr  (toJExpr n)
-        -- helper to load stack .! i into ex, e.g., ex = stack[i]
-        f i ex   = ex |= IdxExpr stack (toJExpr (offset (i+n)))
-
-
--- | Pop but preserve the first N slots
-popSkipI :: Int -> [(Ident,StackSlot)] -> G JStat
-popSkipI 0 [] = pure mempty
-popSkipI n [] = popN n
-popSkipI n xs = do
-  -- add N unknown slots
-  addUnknownSlots n
-  -- now add the slots from xs, after this line the stack should look like
-  -- [xs] ++ [Unknown...] ++ old_stack
-  addSlots (map snd xs)
-  -- move stack pointer into the stack by (length xs + n), basically resetting
-  -- the stack pointer
-  a <- adjSpN (length xs + n)
-  -- now load skipping first N slots
-  return (loadSkipI n (map fst xs) <> a)
-
--- | Just like 'loadSkip' but operate on 'Ident's rather than 'JExpr'
-loadSkipI :: Int -> [Ident] -> JStat
-loadSkipI = loadSkipIFrom sp
-  where loadSkipIFrom :: JExpr -> Int -> [Ident] -> JStat
-        loadSkipIFrom fr n xs = mconcat items
-          where
-            items = reverse $ zipWith f [(0::Int)..] (reverse xs)
-            offset 0 = fr
-            offset n = InfixExpr SubOp fr (toJExpr n)
-            f i ex   = ex ||= IdxExpr stack (toJExpr (offset (i+n)))
-
--- | Blindly pop N slots
-popN :: Int -> G JStat
-popN n = addUnknownSlots n >> adjSpN n
-
--- | Generate statements to update the current node with a blackhole
-bhStats :: StgToJSConfig -> Bool -> JStat
-bhStats s pushUpd = mconcat
-  [ if pushUpd then push' s [r1, var "h$upd_frame"] else mempty
-  , toJExpr R1 .^ closureEntry_  |= var "h$blackhole"
-  , toJExpr R1 .^ closureField1_ |= var "h$currentThread"
-  , toJExpr R1 .^ closureField2_ |= null_ -- will be filled with waiters array
-  ]
-
--- | Wrapper around 'updateThunk'', performs the stack manipulation before
--- updating the Thunk.
-updateThunk :: G JStat
-updateThunk = do
-  settings <- getSettings
-  -- update frame size
-  let adjPushStack :: Int -> G ()
-      adjPushStack n = do modifyStackDepth (+n)
-                          dropSlots n
-  adjPushStack 2
-  return $ (updateThunk' settings)
-
--- | Update a thunk by checking 'StgToJSConfig'. If the config inlines black
--- holes then update inline, else make an explicit call to the black hole
--- handler.
-updateThunk' :: StgToJSConfig -> JStat
-updateThunk' settings =
-  if csInlineBlackhole settings
-    then bhStats settings True
-    else ApplStat (var "h$bh") []
diff --git a/compiler/GHC/StgToJS/StaticPtr.hs b/compiler/GHC/StgToJS/StaticPtr.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/StaticPtr.hs
+++ /dev/null
@@ -1,28 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module GHC.StgToJS.StaticPtr
-  ( initStaticPtrs
-  )
-where
-
-import GHC.Prelude
-import GHC.Linker.Types (SptEntry(..))
-import GHC.Fingerprint.Type
-import GHC.Types.Literal
-
-import GHC.JS.Syntax
-import GHC.JS.Make
-
-import GHC.StgToJS.Types
-import GHC.StgToJS.Literal
-import GHC.StgToJS.Ids
-
-initStaticPtrs :: [SptEntry] -> G JStat
-initStaticPtrs ptrs = mconcat <$> mapM initStatic ptrs
-  where
-    initStatic (SptEntry sp_id (Fingerprint w1 w2)) = do
-      i <- varForId sp_id
-      fpa <- concat <$> mapM (genLit . mkLitWord64 . fromIntegral) [w1,w2]
-      let sptInsert = ApplExpr (var "h$hs_spt_insert") (fpa ++ [i])
-      return $ (var "h$initStatic" .^ "push") `ApplStat` [jLam sptInsert]
-
diff --git a/compiler/GHC/StgToJS/StgUtils.hs b/compiler/GHC/StgToJS/StgUtils.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/StgUtils.hs
+++ /dev/null
@@ -1,266 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-
-module GHC.StgToJS.StgUtils
-  ( bindingRefs
-  , hasExport
-  , collectTopIds
-  , collectIds
-  , removeTick
-  , isUpdatableRhs
-  , isInlineExpr
-  , exprRefs
-  -- * Live vars
-  , LiveVars
-  , liveVars
-  , liveStatic
-  , stgRhsLive
-  , stgExprLive
-  , stgTopBindLive
-  , stgLetNoEscapeLive
-  , stgLneLiveExpr
-  , stgLneLive
-  , stgLneLive'
-  )
-where
-
-import GHC.Prelude
-
-import GHC.Stg.Syntax
-import GHC.Core.DataCon
-import GHC.Core.Type
-import GHC.Core.TyCon
-
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.Set
-import GHC.Types.Unique
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.ForeignCall
-import GHC.Types.TyThing
-import GHC.Types.Name
-import GHC.Types.Var.Set
-
-import GHC.Builtin.Names
-import GHC.Builtin.PrimOps (PrimOp(SeqOp), primOpIsReallyInline)
-import GHC.Utils.Misc (seqList)
-import GHC.Utils.Panic
-
-import qualified Data.Foldable as F
-import qualified Data.Set      as S
-import qualified Data.List     as L
-import Data.Set (Set)
-import Data.Monoid
-
-s :: a -> Set a
-s = S.singleton
-
-l :: (a -> Set Id) -> [a] -> Set Id
-l = F.foldMap
-
--- | collect Ids that this binding refers to
---   (does not include the bindees themselves)
--- first argument is Id -> StgExpr map for unfloated arguments
-bindingRefs :: UniqFM Id CgStgExpr -> CgStgBinding -> Set Id
-bindingRefs u = \case
-  StgNonRec _ rhs -> rhsRefs u rhs
-  StgRec bs       -> l (rhsRefs u . snd) bs
-
-rhsRefs :: UniqFM Id CgStgExpr -> CgStgRhs -> Set Id
-rhsRefs u = \case
-  StgRhsClosure _ _ _ _ body       -> exprRefs u body
-  StgRhsCon _ccs d _mu _ticks args -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args
-
-exprRefs :: UniqFM Id CgStgExpr -> CgStgExpr -> Set Id
-exprRefs u = \case
-  StgApp f args             -> s f <> l (argRefs u) args
-  StgConApp d _n args _     -> l s [ i | AnId i <- dataConImplicitTyThings d] <> l (argRefs u) args
-  StgOpApp _ args _         -> l (argRefs u) args
-  StgLit {}                 -> mempty
-  StgCase expr _ _ alts     -> exprRefs u expr <> mconcat (fmap (altRefs u) alts)
-  StgLet _ bnd expr         -> bindingRefs u bnd <> exprRefs u expr
-  StgLetNoEscape _ bnd expr -> bindingRefs u bnd <> exprRefs u expr
-  StgTick _ expr            -> exprRefs u expr
-
-altRefs :: UniqFM Id CgStgExpr -> CgStgAlt -> Set Id
-altRefs u alt = exprRefs u (alt_rhs alt)
-
-argRefs :: UniqFM Id CgStgExpr -> StgArg -> Set Id
-argRefs u = \case
-  StgVarArg id
-    | Just e <- lookupUFM u id -> exprRefs u e
-    | otherwise                -> s id
-  _ -> mempty
-
-hasExport :: CgStgBinding -> Bool
-hasExport bnd =
-  case bnd of
-    StgNonRec b e -> isExportedBind b e
-    StgRec bs     -> any (uncurry isExportedBind) bs
-  where
-    isExportedBind _i (StgRhsCon _cc con _ _ _) =
-      getUnique con == staticPtrDataConKey
-    isExportedBind _ _ = False
-
-collectTopIds :: CgStgBinding -> [Id]
-collectTopIds (StgNonRec b _) = [b]
-collectTopIds (StgRec bs) = let xs = map (zapFragileIdInfo . fst) bs
-                            in  seqList xs `seq` xs
-
-collectIds :: UniqFM Id CgStgExpr -> CgStgBinding -> [Id]
-collectIds unfloated b =
-  let xs = map zapFragileIdInfo .
-           filter acceptId $ S.toList (bindingRefs unfloated b)
-  in  seqList xs `seq` xs
-  where
-    acceptId i = all ($ i) [not . isForbidden] -- fixme test this: [isExported[isGlobalId, not.isForbidden]
-    -- the GHC.Prim module has no js source file
-    isForbidden i
-      | Just m <- nameModule_maybe (getName i) = m == gHC_PRIM
-      | otherwise = False
-
-removeTick :: CgStgExpr -> CgStgExpr
-removeTick (StgTick _ e) = e
-removeTick e             = e
-
------------------------------------------------------
--- Live vars
---
--- TODO: should probably be moved into GHC.Stg.LiveVars
-
-type LiveVars = DVarSet
-
-liveStatic :: LiveVars -> LiveVars
-liveStatic = filterDVarSet isGlobalId
-
-liveVars :: LiveVars -> LiveVars
-liveVars = filterDVarSet (not . isGlobalId)
-
-stgTopBindLive :: CgStgTopBinding -> [(Id, LiveVars)]
-stgTopBindLive = \case
-  StgTopLifted b     -> stgBindLive b
-  StgTopStringLit {} -> []
-
-stgBindLive :: CgStgBinding -> [(Id, LiveVars)]
-stgBindLive = \case
-  StgNonRec b rhs -> [(b, stgRhsLive rhs)]
-  StgRec bs       -> map (\(b,rhs) -> (b, stgRhsLive rhs)) bs
-
-stgBindRhsLive :: CgStgBinding -> LiveVars
-stgBindRhsLive b =
-  let (bs, ls) = unzip (stgBindLive b)
-  in  delDVarSetList (unionDVarSets ls) bs
-
-stgRhsLive :: CgStgRhs -> LiveVars
-stgRhsLive = \case
-  StgRhsClosure _ _ _ args e -> delDVarSetList (stgExprLive True e) args
-  StgRhsCon _ _ _ _ args     -> unionDVarSets (map stgArgLive args)
-
-stgArgLive :: StgArg -> LiveVars
-stgArgLive = \case
-  StgVarArg occ -> unitDVarSet occ
-  StgLitArg {}  -> emptyDVarSet
-
-stgExprLive :: Bool -> CgStgExpr -> LiveVars
-stgExprLive includeLHS = \case
-  StgApp occ args -> unionDVarSets (unitDVarSet occ : map stgArgLive args)
-  StgLit {}       -> emptyDVarSet
-  StgConApp _dc _n args _tys -> unionDVarSets (map stgArgLive args)
-  StgOpApp _op args _ty      -> unionDVarSets (map stgArgLive args)
-  StgCase e b _at alts
-    | includeLHS -> el `unionDVarSet` delDVarSet al b
-    | otherwise  -> delDVarSet al b
-    where
-      al = unionDVarSets (map stgAltLive alts)
-      el = stgExprLive True e
-  StgLet _ b e         -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b)
-  StgLetNoEscape _ b e -> delDVarSetList (stgBindRhsLive b `unionDVarSet` stgExprLive True e) (bindees b)
-  StgTick _ti e        -> stgExprLive True e
-
-stgAltLive :: CgStgAlt -> LiveVars
-stgAltLive alt =
-  delDVarSetList (stgExprLive True (alt_rhs alt)) (alt_bndrs alt)
-
-stgLetNoEscapeLive :: Bool -> StgBinding -> StgExpr -> LiveVars
-stgLetNoEscapeLive _someBool _b _e = panic "stgLetNoEscapeLive"
-
-bindees :: CgStgBinding -> [Id]
-bindees = \case
-  StgNonRec b _e -> [b]
-  StgRec bs      -> map fst bs
-
-isUpdatableRhs :: CgStgRhs -> Bool
-isUpdatableRhs (StgRhsClosure _ _ u _ _) = isUpdatable u
-isUpdatableRhs _                         = False
-
-stgLneLive' :: CgStgBinding -> [Id]
-stgLneLive' b = filter (`notElem` bindees b) (stgLneLive b)
-
-stgLneLive :: CgStgBinding -> [Id]
-stgLneLive (StgNonRec _b e) = stgLneLiveExpr e
-stgLneLive (StgRec bs)      = L.nub $ concatMap (stgLneLiveExpr . snd) bs
-
-stgLneLiveExpr :: CgStgRhs -> [Id]
-stgLneLiveExpr rhs = dVarSetElems (liveVars $ stgRhsLive rhs)
--- stgLneLiveExpr (StgRhsClosure _ _ _ _ e) = dVarSetElems (liveVars (stgExprLive e))
--- stgLneLiveExpr StgRhsCon {}              = []
-
--- | returns True if the expression is definitely inline
-isInlineExpr :: UniqSet Id -> CgStgExpr -> (UniqSet Id, Bool)
-isInlineExpr v = \case
-  StgApp i args
-    -> (emptyUniqSet, isInlineApp v i args)
-  StgLit{}
-    -> (emptyUniqSet, True)
-  StgConApp{}
-    -> (emptyUniqSet, True)
-  StgOpApp (StgFCallOp f _) _ _
-    -> (emptyUniqSet, isInlineForeignCall f)
-  StgOpApp (StgPrimOp SeqOp) [StgVarArg e] t
-    -> (emptyUniqSet, e `elementOfUniqSet` v || isStrictType t)
-  StgOpApp (StgPrimOp op) _ _
-    -> (emptyUniqSet, primOpIsReallyInline op)
-  StgOpApp (StgPrimCallOp _c) _ _
-    -> (emptyUniqSet, True)
-  StgCase e b _ alts
-    ->let (_ve, ie)   = isInlineExpr v e
-          v'          = addOneToUniqSet v b
-          (vas, ias)  = unzip $ map (isInlineExpr v') (fmap alt_rhs alts)
-          vr          = L.foldl1' intersectUniqSets vas
-      in (vr, (ie || b `elementOfUniqSet` v) && and ias)
-  StgLet _ b e
-    -> isInlineExpr (inspectInlineBinding v b) e
-  StgLetNoEscape _ _b e
-    -> isInlineExpr v e
-  StgTick  _ e
-    -> isInlineExpr v e
-
-inspectInlineBinding :: UniqSet Id -> CgStgBinding -> UniqSet Id
-inspectInlineBinding v = \case
-  StgNonRec i r -> inspectInlineRhs v i r
-  StgRec bs     -> foldl' (\v' (i,r) -> inspectInlineRhs v' i r) v bs
-
-inspectInlineRhs :: UniqSet Id -> Id -> CgStgRhs -> UniqSet Id
-inspectInlineRhs v i = \case
-  StgRhsCon{}                     -> addOneToUniqSet v i
-  StgRhsClosure _ _ ReEntrant _ _ -> addOneToUniqSet v i
-  _                               -> v
-
-isInlineForeignCall :: ForeignCall -> Bool
-isInlineForeignCall (CCall (CCallSpec _ cconv safety)) =
-  not (playInterruptible safety) &&
-  not (cconv /= JavaScriptCallConv && playSafe safety)
-
-isInlineApp :: UniqSet Id -> Id -> [StgArg] -> Bool
-isInlineApp v i = \case
-  _ | isJoinId i -> False
-  [] -> isUnboxedTupleType (idType i) ||
-                     isStrictType (idType i) ||
-                     i `elementOfUniqSet` v
-
-  [StgVarArg a]
-    | DataConWrapId dc <- idDetails i
-    , isNewTyCon (dataConTyCon dc)
-    , isStrictType (idType a) || a `elementOfUniqSet` v || isStrictId a
-    -> True
-  _ -> False
-
diff --git a/compiler/GHC/StgToJS/Symbols.hs b/compiler/GHC/StgToJS/Symbols.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Symbols.hs
+++ /dev/null
@@ -1,89 +0,0 @@
-
--- | JS symbol generation
-module GHC.StgToJS.Symbols
-  ( moduleGlobalSymbol
-  , moduleExportsSymbol
-  , mkJsSymbol
-  , mkJsSymbolBS
-  , mkFreshJsSymbol
-  , mkRawSymbol
-  , intBS
-  ) where
-
-import GHC.Prelude
-
-import GHC.Data.FastString
-import GHC.Unit.Module
-import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8   as BSC
-import qualified Data.ByteString.Builder as BSB
-import qualified Data.ByteString.Lazy    as BSL
-
--- | Hexadecimal representation of an int
---
--- Used for uniques. We could use base-62 as GHC usually does but this is likely
--- faster.
-intBS :: Int -> ByteString
-intBS = BSL.toStrict . BSB.toLazyByteString . BSB.wordHex . fromIntegral
-
--- | Return z-encoded unit:module
-unitModuleStringZ :: Module -> ByteString
-unitModuleStringZ mod = mconcat
-  [ fastZStringToByteString (zEncodeFS (unitIdFS (moduleUnitId mod)))
-  , BSC.pack "ZC" -- z-encoding for ":"
-  , fastZStringToByteString (zEncodeFS (moduleNameFS (moduleName mod)))
-  ]
-
--- | the global linkable unit of a module exports this symbol, depend on it to
---   include that unit (used for cost centres)
-moduleGlobalSymbol :: Module -> FastString
-moduleGlobalSymbol m = mkFastStringByteString $ mconcat
-  [ hd
-  , unitModuleStringZ m
-  , BSC.pack "_<global>"
-  ]
-
-moduleExportsSymbol :: Module -> FastString
-moduleExportsSymbol m = mkFastStringByteString $ mconcat
-  [ hd
-  , unitModuleStringZ m
-  , BSC.pack "_<exports>"
-  ]
-
--- | Make JS symbol corresponding to the given Haskell symbol in the given
--- module
-mkJsSymbolBS :: Bool -> Module -> FastString -> ByteString
-mkJsSymbolBS exported mod s = mconcat
-  [ if exported then hd else hdd
-  , unitModuleStringZ mod
-  , BSC.pack "zi" -- z-encoding of "."
-  , fastZStringToByteString (zEncodeFS s)
-  ]
-
--- | Make JS symbol corresponding to the given Haskell symbol in the given
--- module
-mkJsSymbol :: Bool -> Module -> FastString -> FastString
-mkJsSymbol exported mod s = mkFastStringByteString (mkJsSymbolBS exported mod s)
-
--- | Make JS symbol for given module and unique.
-mkFreshJsSymbol :: Module -> Int -> FastString
-mkFreshJsSymbol mod i = mkFastStringByteString $ mconcat
-  [ hdd
-  , unitModuleStringZ mod
-  , BSC.pack "_"
-  , intBS i
-  ]
-
--- | Make symbol "h$XYZ" or "h$$XYZ"
-mkRawSymbol :: Bool -> FastString -> FastString
-mkRawSymbol exported fs
-  | exported  = mkFastStringByteString $ mconcat [ hd,  bytesFS fs ]
-  | otherwise = mkFastStringByteString $ mconcat [ hdd, bytesFS fs ]
-
--- | "h$$" constant string
-hdd :: ByteString
-hdd = BSC.pack "h$$"
-
--- | "h$" constant string
-hd :: ByteString
-hd = BSC.take 2 hdd
diff --git a/compiler/GHC/StgToJS/Types.hs b/compiler/GHC/StgToJS/Types.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Types.hs
+++ /dev/null
@@ -1,430 +0,0 @@
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE DerivingStrategies         #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase                 #-}
-
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.StgToJS.Types
--- Copyright   :  (c) The University of Glasgow 2001
--- License     :  BSD-style (see the file LICENSE)
---
--- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>
---                Luite Stegeman <luite.stegeman@iohk.io>
---                Sylvain Henry  <sylvain.henry@iohk.io>
---                Josh Meredith  <josh.meredith@iohk.io>
--- Stability   :  experimental
---
---
--- Module that holds the Types required for the StgToJS pass
------------------------------------------------------------------------------
-
-module GHC.StgToJS.Types where
-
-import GHC.Prelude
-
-import GHC.JS.Syntax
-import GHC.JS.Make
-import GHC.JS.Ppr ()
-
-import GHC.Stg.Syntax
-import GHC.Core.TyCon
-
-import GHC.Types.Unique
-import GHC.Types.Unique.FM
-import GHC.Types.Var
-import GHC.Types.ForeignCall
-
-import Control.Monad.Trans.State.Strict
-import GHC.Utils.Outputable (Outputable (..), text, SDocContext, (<+>), ($$))
-
-import GHC.Data.FastString
-import GHC.Data.FastMutInt
-
-import GHC.Unit.Module
-
-import qualified Data.Map as M
-import           Data.Set (Set)
-import qualified Data.ByteString as BS
-import           Data.Monoid
-import           Data.Typeable (Typeable)
-import           GHC.Generics (Generic)
-import           Control.DeepSeq
-
--- | A State monad over IO holding the generator state.
-type G = StateT GenState IO
-
--- | The JS code generator state
-data GenState = GenState
-  { gsSettings  :: !StgToJSConfig         -- ^ codegen settings, read-only
-  , gsModule    :: !Module                -- ^ current module
-  , gsId        :: {-# UNPACK #-} !FastMutInt -- ^ unique number for the id generator
-  , gsIdents    :: !IdCache               -- ^ hash consing for identifiers from a Unique
-  , gsUnfloated :: !(UniqFM Id CgStgExpr) -- ^ unfloated arguments
-  , gsGroup     :: GenGroupState          -- ^ state for the current binding group
-  , gsGlobal    :: [JStat]                -- ^ global (per module) statements (gets included when anything else from the module is used)
-  }
-
--- | The JS code generator state relevant for the current binding group
-data GenGroupState = GenGroupState
-  { ggsToplevelStats :: [JStat]        -- ^ extra toplevel statements for the binding group
-  , ggsClosureInfo   :: [ClosureInfo]  -- ^ closure metadata (info tables) for the binding group
-  , ggsStatic        :: [StaticInfo]   -- ^ static (CAF) data in our binding group
-  , ggsStack         :: [StackSlot]    -- ^ stack info for the current expression
-  , ggsStackDepth    :: Int            -- ^ current stack depth
-  , ggsExtraDeps     :: Set OtherSymb  -- ^ extra dependencies for the linkable unit that contains this group
-  , ggsGlobalIdCache :: GlobalIdCache
-  , ggsForeignRefs   :: [ForeignJSRef]
-  }
-
--- | The Configuration record for the StgToJS pass
-data StgToJSConfig = StgToJSConfig
-  -- flags
-  { csInlinePush      :: !Bool
-  , csInlineBlackhole :: !Bool
-  , csInlineLoadRegs  :: !Bool
-  , csInlineEnter     :: !Bool
-  , csInlineAlloc     :: !Bool
-  , csTraceRts        :: !Bool
-  , csAssertRts       :: !Bool
-  , csBoundsCheck     :: !Bool
-  , csDebugAlloc      :: !Bool
-  , csTraceForeign    :: !Bool
-  , csProf            :: !Bool -- ^ Profiling enabled
-  , csRuntimeAssert   :: !Bool -- ^ Enable runtime assertions
-  -- settings
-  , csContext         :: !SDocContext
-  }
-
--- | Information relevenat to code generation for closures.
-data ClosureInfo = ClosureInfo
-  { ciVar     :: Ident      -- ^ object being infod
-  , ciRegs    :: CIRegs     -- ^ size of the payload (in number of JS values)
-  , ciName    :: FastString -- ^ friendly name for printing
-  , ciLayout  :: CILayout   -- ^ heap/stack layout of the object
-  , ciType    :: CIType     -- ^ type of the object, with extra info where required
-  , ciStatic  :: CIStatic   -- ^ static references of this object
-  }
-  deriving stock (Eq, Show, Generic)
-
--- | Closure information, 'ClosureInfo', registers
-data CIRegs
-  = CIRegsUnknown                     -- ^ A value witnessing a state of unknown registers
-  | CIRegs { ciRegsSkip  :: Int       -- ^ unused registers before actual args start
-           , ciRegsTypes :: [VarType] -- ^ args
-           }
-  deriving stock (Eq, Ord, Show, Generic)
-
-instance NFData CIRegs
-
--- | Closure Information, 'ClosureInfo', layout
-data CILayout
-  = CILayoutVariable            -- ^ layout stored in object itself, first position from the start
-  | CILayoutUnknown             -- ^ fixed size, but content unknown (for example stack apply frame)
-      { layoutSize :: !Int
-      }
-  | CILayoutFixed               -- ^ whole layout known
-      { layoutSize :: !Int      -- ^ closure size in array positions, including entry
-      , layout     :: [VarType] -- ^ The set of sized Types to layout
-      }
-  deriving stock (Eq, Ord, Show, Generic)
-
-instance NFData CILayout
-
--- | The type of 'ClosureInfo'
-data CIType
-  = CIFun { citArity :: !Int         -- ^ function arity
-          , citRegs  :: !Int         -- ^ number of registers for the args
-          }
-  | CIThunk                          -- ^ The closure is a THUNK
-  | CICon { citConstructor :: !Int } -- ^ The closure is a Constructor
-  | CIPap                            -- ^ The closure is a Partial Application
-  | CIBlackhole                      -- ^ The closure is a black hole
-  | CIStackFrame                     -- ^ The closure is a stack frame
-  deriving stock (Eq, Ord, Show, Generic)
-
-instance NFData CIType
-
--- | Static references that must be kept alive
-newtype CIStatic = CIStaticRefs { staticRefs :: [FastString] }
-  deriving stock   (Eq, Generic)
-  deriving newtype (Semigroup, Monoid, Show)
-
--- | static refs: array = references, null = nothing to report
---   note: only works after all top-level objects have been created
-instance ToJExpr CIStatic where
-  toJExpr (CIStaticRefs [])  = null_ -- [je| null |]
-  toJExpr (CIStaticRefs rs)  = toJExpr (map TxtI rs)
-
--- | Free variable types
-data VarType
-  = PtrV     -- ^ pointer = reference to heap object (closure object)
-  | VoidV    -- ^ no fields
-  | DoubleV  -- ^ A Double: one field
-  | IntV     -- ^ An Int (32bit because JS): one field
-  | LongV    -- ^ A Long: two fields one for the upper 32bits, one for the lower (NB: JS is little endian)
-  | AddrV    -- ^ a pointer not to the heap: two fields, array + index
-  | RtsObjV  -- ^ some RTS object from GHCJS (for example TVar#, MVar#, MutVar#, Weak#)
-  | ObjV     -- ^ some JS object, user supplied, be careful around these, can be anything
-  | ArrV     -- ^ boxed array
-  deriving stock (Eq, Ord, Enum, Bounded, Show, Generic)
-
-instance NFData VarType
-
-instance ToJExpr VarType where
-  toJExpr = toJExpr . fromEnum
-
--- | The type of identifiers. These determine the suffix of generated functions
--- in JS Land. For example, the entry function for the 'Just' constructor is a
--- 'IdConEntry' which compiles to:
--- @
--- function h$baseZCGHCziMaybeziJust_con_e() { return h$rs() };
--- @
--- which just returns whatever the stack point is pointing to. Whereas the entry
--- function to 'Just' is an 'IdEntry' and does the work. It compiles to:
--- @
--- function h$baseZCGHCziMaybeziJust_e() {
---    var h$$baseZCGHCziMaybezieta_8KXnScrCjF5 = h$r2;
---    h$r1 = h$c1(h$baseZCGHCziMaybeziJust_con_e, h$$baseZCGHCziMaybezieta_8KXnScrCjF5);
---    return h$rs();
---    };
--- @
--- Which loads some payload from register 2, and applies the Constructor Entry
--- function for the Just to the payload, returns the result in register 1 and
--- returns whatever is on top of the stack
-data IdType
-  = IdPlain     -- ^ A plain identifier for values, no suffix added
-  | IdEntry     -- ^ An entry function, suffix = "_e" in 'GHC.StgToJS.Ids.makeIdentForId'
-  | IdConEntry  -- ^ A Constructor entry function, suffix = "_con_e" in 'GHC.StgToJS.Ids.makeIdentForId'
-  deriving (Enum, Eq, Ord)
-
--- | Keys to differentiate Ident's in the ID Cache
-data IdKey
-  = IdKey !Int !Int !IdType
-  deriving (Eq, Ord)
-
--- | Some other symbol
-data OtherSymb
-  = OtherSymb !Module !FastString
-  deriving Eq
-
-instance Ord OtherSymb where
-  compare (OtherSymb m1 t1) (OtherSymb m2 t2)
-    = stableModuleCmp m1 m2 <> lexicalCompareFS t1 t2
-
--- | The identifier cache indexed on 'IdKey' local to a module
-newtype IdCache = IdCache (M.Map IdKey Ident)
-
--- | The global Identifier Cache
-newtype GlobalIdCache = GlobalIdCache (UniqFM Ident (IdKey, Id))
-
--- | A Stack Slot is either known or unknown. We avoid maybe here for more
--- strictness.
-data StackSlot
-  = SlotId !Id !Int
-  | SlotUnknown
-  deriving (Eq, Ord)
-
-data StaticInfo = StaticInfo
-  { siVar    :: !FastString    -- ^ global object
-  , siVal    :: !StaticVal     -- ^ static initialization
-  , siCC     :: !(Maybe Ident) -- ^ optional CCS name
-  } deriving stock (Eq, Show, Typeable, Generic)
-
-data StaticVal
-  = StaticFun     !FastString [StaticArg]
-    -- ^ heap object for function
-  | StaticThunk   !(Maybe (FastString,[StaticArg]))
-    -- ^ heap object for CAF (field is Nothing when thunk is initialized in an
-    -- alternative way, like string thunks through h$str)
-  | StaticUnboxed !StaticUnboxed
-    -- ^ unboxed constructor (Bool, Int, Double etc)
-  | StaticData    !FastString [StaticArg]
-    -- ^ regular datacon app
-  | StaticList    [StaticArg] (Maybe FastString)
-    -- ^ list initializer (with optional tail)
-  deriving stock (Eq, Show, Generic)
-
-data StaticUnboxed
-  = StaticUnboxedBool         !Bool
-  | StaticUnboxedInt          !Integer
-  | StaticUnboxedDouble       !SaneDouble
-  | StaticUnboxedString       !BS.ByteString
-  | StaticUnboxedStringOffset !BS.ByteString
-  deriving stock (Eq, Ord, Show, Generic)
-
-instance NFData StaticUnboxed
-
--- | Static Arguments. Static Arguments are things that are statically
--- allocated, i.e., they exist at program startup. These are static heap objects
--- or literals or things that have been floated to the top level binding by ghc.
-data StaticArg
-  = StaticObjArg !FastString             -- ^ reference to a heap object
-  | StaticLitArg !StaticLit              -- ^ literal
-  | StaticConArg !FastString [StaticArg] -- ^ unfloated constructor
-  deriving stock (Eq, Show, Generic)
-
-instance Outputable StaticArg where
-  ppr x = text (show x)
-
--- | A Static literal value
-data StaticLit
-  = BoolLit   !Bool
-  | IntLit    !Integer
-  | NullLit
-  | DoubleLit !SaneDouble -- should we actually use double here?
-  | StringLit !FastString
-  | BinLit    !BS.ByteString
-  | LabelLit  !Bool !FastString -- ^ is function pointer, label (also used for string / binary init)
-  deriving (Eq, Show, Generic)
-
-instance Outputable StaticLit where
-  ppr x = text (show x)
-
-
-instance ToJExpr StaticLit where
-  toJExpr (BoolLit b)           = toJExpr b
-  toJExpr (IntLit i)            = toJExpr i
-  toJExpr NullLit               = null_
-  toJExpr (DoubleLit d)         = toJExpr (unSaneDouble d)
-  toJExpr (StringLit t)         = app (mkFastString "h$str") [toJExpr t]
-  toJExpr (BinLit b)            = app (mkFastString "h$rstr") [toJExpr (map toInteger (BS.unpack b))]
-  toJExpr (LabelLit _isFun lbl) = var lbl
-
--- | A foreign reference to some JS code
-data ForeignJSRef = ForeignJSRef
-  { foreignRefSrcSpan  :: !FastString
-  , foreignRefPattern  :: !FastString
-  , foreignRefSafety   :: !Safety
-  , foreignRefCConv    :: !CCallConv
-  , foreignRefArgs     :: ![FastString]
-  , foreignRefResult   :: !FastString
-  } deriving stock (Generic)
-
--- | data used to generate one ObjUnit in our object file
-data LinkableUnit = LinkableUnit
-  { luObjUnit      :: ObjUnit       -- ^ serializable unit info
-  , luIdExports    :: [Id]          -- ^ exported names from haskell identifiers
-  , luOtherExports :: [FastString]  -- ^ other exports
-  , luIdDeps       :: [Id]          -- ^ identifiers this unit depends on
-  , luPseudoIdDeps :: [Unique]      -- ^ pseudo-id identifiers this unit depends on (fixme)
-  , luOtherDeps    :: [OtherSymb]   -- ^ symbols not from a haskell id that this unit depends on
-  , luRequired     :: Bool          -- ^ always link this unit
-  , luForeignRefs  :: [ForeignJSRef]
-  }
-
--- | one toplevel block in the object file
-data ObjUnit = ObjUnit
-  { oiSymbols  :: ![FastString]   -- ^ toplevel symbols (stored in index)
-  , oiClInfo   :: ![ClosureInfo]  -- ^ closure information of all closures in block
-  , oiStatic   :: ![StaticInfo]   -- ^ static closure data
-  , oiStat     :: JStat           -- ^ the code
-  , oiRaw      :: !BS.ByteString  -- ^ raw JS code
-  , oiFExports :: ![ExpFun]
-  , oiFImports :: ![ForeignJSRef]
-  }
-
-data ExpFun = ExpFun
-  { isIO   :: !Bool
-  , args   :: [JSFFIType]
-  , result :: !JSFFIType
-  } deriving (Eq, Ord, Show)
-
--- | Types of FFI values
-data JSFFIType
-  = Int8Type
-  | Int16Type
-  | Int32Type
-  | Int64Type
-  | Word8Type
-  | Word16Type
-  | Word32Type
-  | Word64Type
-  | DoubleType
-  | ByteArrayType
-  | PtrType
-  | RefType
-  deriving (Show, Ord, Eq, Enum)
-
-
--- | Typed expression
-data TypedExpr = TypedExpr
-  { typex_typ  :: !PrimRep
-  , typex_expr :: [JExpr]
-  }
-
-instance Outputable TypedExpr where
-  ppr x = text "TypedExpr: " <+> ppr (typex_expr x)
-          $$  text "PrimReps: " <+> ppr (typex_typ x)
-
--- | A Primop result is either an inlining of some JS payload, or a primitive
--- call to a JS function defined in Shim files in base.
-data PrimRes
-  = PrimInline JStat  -- ^ primop is inline, result is assigned directly
-  | PRPrimCall JStat  -- ^ primop is async call, primop returns the next
-                      --     function to run. result returned to stack top in registers
-
-data ExprResult
-  = ExprCont
-  | ExprInline (Maybe [JExpr])
-  deriving (Eq)
-
-newtype ExprValData = ExprValData [JExpr]
-  deriving newtype (Eq)
-
--- | A Closure is one of six types
-data ClosureType
-  = Thunk       -- ^ The closure is a THUNK
-  | Fun         -- ^ The closure is a Function
-  | Pap         -- ^ The closure is a Partial Application
-  | Con         -- ^ The closure is a Constructor
-  | Blackhole   -- ^ The closure is a Blackhole
-  | StackFrame  -- ^ The closure is a stack frame
-  deriving (Show, Eq, Ord, Enum, Bounded)
-
--- | Convert 'ClosureType' to an Int
-ctNum :: ClosureType -> Int
-ctNum Fun        = 1
-ctNum Con        = 2
-ctNum Thunk      = 0
-ctNum Pap        = 3
-ctNum Blackhole  = 5
-ctNum StackFrame = -1
-
--- | Convert 'ClosureType' to a String
-ctJsName :: ClosureType -> String
-ctJsName = \case
-  Thunk      -> "CLOSURE_TYPE_THUNK"
-  Fun        -> "CLOSURE_TYPE_FUN"
-  Pap        -> "CLOSURE_TYPE_PAP"
-  Con        -> "CLOSURE_TYPE_CON"
-  Blackhole  -> "CLOSURE_TYPE_BLACKHOLE"
-  StackFrame -> "CLOSURE_TYPE_STACKFRAME"
-
-instance ToJExpr ClosureType where
-  toJExpr e = toJExpr (ctNum e)
-
-
--- | A thread is in one of 4 states
-data ThreadStatus
-  = Running   -- ^ The thread is running
-  | Blocked   -- ^ The thread is blocked
-  | Finished  -- ^ The thread is done
-  | Died      -- ^ The thread has died
-  deriving (Show, Eq, Ord, Enum, Bounded)
-
--- | Convert the status of a thread in JS land to an Int
-threadStatusNum :: ThreadStatus -> Int
-threadStatusNum = \case
-  Running  -> 0
-  Blocked  -> 1
-  Finished -> 16
-  Died     -> 17
-
--- | convert the status of a thread in JS land to a string
-threadStatusJsName :: ThreadStatus -> String
-threadStatusJsName = \case
-  Running  -> "THREAD_RUNNING"
-  Blocked  -> "THREAD_BLOCKED"
-  Finished -> "THREAD_FINISHED"
-  Died     -> "THREAD_DIED"
diff --git a/compiler/GHC/StgToJS/Utils.hs b/compiler/GHC/StgToJS/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/StgToJS/Utils.hs
+++ /dev/null
@@ -1,57 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module GHC.StgToJS.Utils
-  ( assignToTypedExprs
-  , assignCoerce1
-  , assignToExprCtx
-  )
-where
-
-import GHC.Prelude
-
-import GHC.StgToJS.Types
-import GHC.StgToJS.ExprCtx
-
-import GHC.JS.Syntax
-import GHC.JS.Make
-
-import GHC.Core.TyCon
-
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Outputable
-
-assignToTypedExprs :: HasDebugCallStack => [TypedExpr] -> [JExpr] -> JStat
-assignToTypedExprs tes es =
-  assignAllEqual (concatMap typex_expr tes) es
-
-assignTypedExprs :: [TypedExpr] -> [TypedExpr] -> JStat
-assignTypedExprs tes es =
-  -- TODO: check primRep (typex_typ) here?
-  assignToTypedExprs tes (concatMap typex_expr es)
-
-assignToExprCtx :: HasDebugCallStack => ExprCtx -> [JExpr] -> JStat
-assignToExprCtx ctx es = assignToTypedExprs (ctxTarget ctx) es
-
--- | Assign first expr only (if it exists), performing coercions between some
--- PrimReps (e.g. StablePtr# and Addr#).
-assignCoerce1 :: HasDebugCallStack => [TypedExpr] -> [TypedExpr] -> JStat
-assignCoerce1 [x] [y] = assignCoerce x y
-assignCoerce1 []  []  = mempty
-assignCoerce1 x   y   = pprPanic "assignCoerce1"
-                          (vcat [ text "lengths do not match"
-                                , ppr x
-                                , ppr y
-                                ])
-
--- | Assign p2 to p1 with optional coercion
-assignCoerce :: TypedExpr -> TypedExpr -> JStat
--- Coercion between StablePtr# and Addr#
-assignCoerce (TypedExpr AddrRep [a_val, a_off]) (TypedExpr UnliftedRep [sptr]) = mconcat
-    [ a_val |= var "h$stablePtrBuf"
-    , a_off |= sptr
-    ]
-assignCoerce (TypedExpr UnliftedRep [sptr]) (TypedExpr AddrRep [_a_val, a_off]) =
-  sptr |= a_off
-assignCoerce p1 p2 = assignTypedExprs [p1] [p2]
-
diff --git a/compiler/GHC/SysTools.hs b/compiler/GHC/SysTools.hs
deleted file mode 100644
--- a/compiler/GHC/SysTools.hs
+++ /dev/null
@@ -1,166 +0,0 @@
-
-{-# LANGUAGE ScopedTypeVariables #-}
-
-{-
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow 2001-2003
---
--- Access to system tools: gcc, cp, rm etc
---
------------------------------------------------------------------------------
--}
-
-module GHC.SysTools (
-        -- * Initialisation
-        initSysTools,
-
-        -- * Interface to system tools
-        module GHC.SysTools.Tasks,
-        module GHC.SysTools.Info,
-
-        -- * Fast file copy
-        copyFile,
-        copyHandle,
-        copyWithHeader,
-
-        -- * General utilities
-        Option(..),
-        expandTopDir,
- ) where
-
-import GHC.Prelude
-
-
-import GHC.Utils.Panic
-import GHC.Driver.Session
-
-import GHC.Linker.ExtraObj
-import GHC.SysTools.Info
-import GHC.SysTools.Tasks
-import GHC.SysTools.BaseDir
-import GHC.Settings.IO
-
-import Control.Monad.Trans.Except (runExceptT)
-import System.IO
-import Foreign.Marshal.Alloc (allocaBytes)
-import System.Directory (copyFile)
-
-{-
-Note [How GHC finds toolchain utilities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-GHC.SysTools.initSysProgs figures out exactly where all the auxiliary programs
-are, and initialises mutable variables to make it easy to call them.
-To do this, it makes use of definitions in Config.hs, which is a Haskell
-file containing variables whose value is figured out by the build system.
-
-Config.hs contains two sorts of things
-
-  cGCC,         The *names* of the programs
-  cCPP            e.g.  cGCC = gcc
-  cUNLIT                cCPP = gcc -E
-  etc           They do *not* include paths
-
-
-  cUNLIT_DIR   The *path* to the directory containing unlit, split etc
-  cSPLIT_DIR   *relative* to the root of the build tree,
-                   for use when running *in-place* in a build tree (only)
-
-
----------------------------------------------
-NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
-
-Another hair-brained scheme for simplifying the current tool location
-nightmare in GHC: Simon originally suggested using another
-configuration file along the lines of GCC's specs file - which is fine
-except that it means adding code to read yet another configuration
-file.  What I didn't notice is that the current package.conf is
-general enough to do this:
-
-Package
-    {name = "tools",    import_dirs = [],  source_dirs = [],
-     library_dirs = [], hs_libraries = [], extra_libraries = [],
-     include_dirs = [], c_includes = [],   package_deps = [],
-     extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
-     extra_cc_opts = [], extra_ld_opts = []}
-
-Which would have the advantage that we get to collect together in one
-place the path-specific package stuff with the path-specific tool
-stuff.
-                End of NOTES
----------------------------------------------
-
-************************************************************************
-*                                                                      *
-\subsection{Initialisation}
-*                                                                      *
-************************************************************************
--}
-
-
-initSysTools :: String          -- TopDir path
-             -> IO Settings     -- Set all the mutable variables above, holding
-                                --      (a) the system programs
-                                --      (b) the package-config file
-                                --      (c) the GHC usage message
-initSysTools top_dir = do
-  res <- runExceptT $ initSettings top_dir
-  case res of
-    Right a -> pure a
-    Left (SettingsError_MissingData msg) -> pgmError msg
-    Left (SettingsError_BadData msg) -> pgmError msg
-
-{- Note [Windows stack allocations]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See: #8870 (and #8834 for related info) and #12186
-
-On Windows, occasionally we need to grow the stack. In order to do
-this, we would normally just bump the stack pointer - but there's a
-catch on Windows.
-
-If the stack pointer is bumped by more than a single page, then the
-pages between the initial pointer and the resulting location must be
-properly committed by the Windows virtual memory subsystem. This is
-only needed in the event we bump by more than one page (i.e 4097 bytes
-or more).
-
-Windows compilers solve this by emitting a call to a special function
-called _chkstk, which does this committing of the pages for you.
-
-The reason this was causing a segfault was because due to the fact the
-new code generator tends to generate larger functions, we needed more
-stack space in GHC itself. In the x86 codegen, we needed approximately
-~12kb of stack space in one go, which caused the process to segfault,
-as the intervening pages were not committed.
-
-GCC can emit such a check for us automatically but only when the flag
--fstack-check is used.
-
-See https://gcc.gnu.org/onlinedocs/gnat_ugn/Stack-Overflow-Checking.html
-for more information.
-
--}
-
--- | Copy remaining bytes from the first Handle to the second one
-copyHandle :: Handle -> Handle -> IO ()
-copyHandle hin hout = do
-  let buf_size = 8192
-  allocaBytes buf_size $ \ptr -> do
-    let go = do
-          c <- hGetBuf hin ptr buf_size
-          hPutBuf hout ptr c
-          if c == 0 then return () else go
-    go
-
--- | Copy file after printing the given header
-copyWithHeader :: String -> FilePath -> FilePath -> IO ()
-copyWithHeader header from to =
-  withBinaryFile to WriteMode $ \hout -> do
-    -- write the header string in UTF-8.  The header is something like
-    --   {-# LINE "foo.hs" #-}
-    -- and we want to make sure a Unicode filename isn't mangled.
-    hSetEncoding hout utf8
-    hPutStr hout header
-    withBinaryFile from ReadMode $ \hin ->
-      copyHandle hin hout
diff --git a/compiler/GHC/SysTools/Ar.hs b/compiler/GHC/SysTools/Ar.hs
deleted file mode 100644
--- a/compiler/GHC/SysTools/Ar.hs
+++ /dev/null
@@ -1,270 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}
-{- Note [The need for Ar.hs]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~
-Building `-staticlib` previously required the presence of libtool, and was a
-such restricted to mach-o only. As libtool on macOS and gnu libtool are very
-different, there was no simple portable way to support this.
-
-libtool for static archives does essentially: concatenate the input archives,
-add the input objects, and create a symbol index. Using `ar` for this task
-fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same
-features across platforms (e.g. index prefixed retrieval of objects with
-the same name.)
-
-As archives are rather simple structurally, we can just build the archives
-with Haskell directly and use ranlib on the final result to get the symbol
-index. This should allow us to work around with the differences/availability
-of libtool across different platforms.
--}
-module GHC.SysTools.Ar
-  (ArchiveEntry(..)
-  ,Archive(..)
-  ,afilter
-
-  ,parseAr
-
-  ,loadAr
-  ,loadObj
-  ,writeBSDAr
-  ,writeGNUAr
-
-  ,isBSDSymdef
-  ,isGNUSymdef
-  )
-   where
-
-import GHC.Prelude
-
-import Data.List (mapAccumL, isPrefixOf)
-import Data.Monoid ((<>))
-import Data.Binary.Get
-import Data.Binary.Put
-import Control.Monad
-import Control.Applicative
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as C
-import qualified Data.ByteString.Lazy as L
-#if !defined(mingw32_HOST_OS)
-import qualified System.Posix.Files as POSIX
-#endif
-import System.FilePath (takeFileName)
-
-data ArchiveEntry = ArchiveEntry
-    { filename :: String       -- ^ File name.
-    , filetime :: Int          -- ^ File modification time.
-    , fileown  :: Int          -- ^ File owner.
-    , filegrp  :: Int          -- ^ File group.
-    , filemode :: Int          -- ^ File mode.
-    , filesize :: Int          -- ^ File size.
-    , filedata :: B.ByteString -- ^ File bytes.
-    } deriving (Eq, Show)
-
-newtype Archive = Archive [ArchiveEntry]
-        deriving (Eq, Show, Semigroup, Monoid)
-
-afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive
-afilter f (Archive xs) = Archive (filter f xs)
-
-isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool
-isBSDSymdef a = "__.SYMDEF" `isPrefixOf` (filename a)
-isGNUSymdef a = "/" == (filename a)
-
--- | Archives have numeric values padded with '\x20' to the right.
-getPaddedInt :: B.ByteString -> Int
-getPaddedInt = read . C.unpack . C.takeWhile (/= '\x20')
-
-putPaddedInt :: Int -> Int -> Put
-putPaddedInt padding i = putPaddedString '\x20' padding (show i)
-
-putPaddedString :: Char -> Int -> String -> Put
-putPaddedString pad padding s = putByteString . C.pack . take padding $ s `mappend` (repeat pad)
-
-getBSDArchEntries :: Get [ArchiveEntry]
-getBSDArchEntries = do
-    empty <- isEmpty
-    if empty then
-        return []
-     else do
-        name    <- getByteString 16
-        when ('/' `C.elem` name && C.take 3 name /= "#1/") $
-          fail "Looks like GNU Archive"
-        time    <- getPaddedInt <$> getByteString 12
-        own     <- getPaddedInt <$> getByteString 6
-        grp     <- getPaddedInt <$> getByteString 6
-        mode    <- getPaddedInt <$> getByteString 8
-        st_size <- getPaddedInt <$> getByteString 10
-        end     <- getByteString 2
-        when (end /= "\x60\x0a") $
-          fail ("[BSD Archive] Invalid archive header end marker for name: " ++
-                C.unpack name)
-        off1    <- liftM fromIntegral bytesRead :: Get Int
-        -- BSD stores extended filenames, by writing #1/<length> into the
-        -- name field, the first @length@ bytes then represent the file name
-        -- thus the payload size is filesize + file name length.
-        name    <- if C.unpack (C.take 3 name) == "#1/" then
-                        liftM (C.unpack . C.takeWhile (/= '\0')) (getByteString $ read $ C.unpack $ C.drop 3 name)
-                    else
-                        return $ C.unpack $ C.takeWhile (/= ' ') name
-        off2    <- liftM fromIntegral bytesRead :: Get Int
-        file    <- getByteString (st_size - (off2 - off1))
-        -- data sections are two byte aligned (see #15396)
-        when (odd st_size) $
-          void (getByteString 1)
-
-        rest    <- getBSDArchEntries
-        return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest
-
--- | GNU Archives feature a special '//' entry that contains the
--- extended names. Those are referred to as /<num>, where num is the
--- offset into the '//' entry.
--- In addition, filenames are terminated with '/' in the archive.
-getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry]
-getGNUArchEntries extInfo = do
-  empty <- isEmpty
-  if empty
-    then return []
-    else
-    do
-      name    <- getByteString 16
-      time    <- getPaddedInt <$> getByteString 12
-      own     <- getPaddedInt <$> getByteString 6
-      grp     <- getPaddedInt <$> getByteString 6
-      mode    <- getPaddedInt <$> getByteString 8
-      st_size <- getPaddedInt <$> getByteString 10
-      end     <- getByteString 2
-      when (end /= "\x60\x0a") $
-        fail ("[BSD Archive] Invalid archive header end marker for name: " ++
-              C.unpack name)
-      file <- getByteString st_size
-      -- data sections are two byte aligned (see #15396)
-      when (odd st_size) $
-        void (getByteString 1)
-      name <- return . C.unpack $
-        if C.unpack (C.take 1 name) == "/"
-        then case C.takeWhile (/= ' ') name of
-               name@"/"  -> name               -- symbol table
-               name@"//" -> name               -- extended file names table
-               name      -> getExtName extInfo (read . C.unpack $ C.drop 1 name)
-        else C.takeWhile (/= '/') name
-      case name of
-        "/"  -> getGNUArchEntries extInfo
-        "//" -> getGNUArchEntries (Just (ArchiveEntry name time own grp mode st_size file))
-        _    -> (ArchiveEntry name time own grp mode st_size file :) <$> getGNUArchEntries extInfo
-
-  where
-   getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString
-   getExtName Nothing _ = error "Invalid extended filename reference."
-   getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info
-
--- | put an Archive Entry. This assumes that the entries
--- have been preprocessed to account for the extended file name
--- table section "//" e.g. for GNU Archives. Or that the names
--- have been move into the payload for BSD Archives.
-putArchEntry :: ArchiveEntry -> PutM ()
-putArchEntry (ArchiveEntry name time own grp mode st_size file) = do
-  putPaddedString ' '  16 name
-  putPaddedInt         12 time
-  putPaddedInt          6 own
-  putPaddedInt          6 grp
-  putPaddedInt          8 mode
-  putPaddedInt         10 (st_size + pad)
-  putByteString           "\x60\x0a"
-  putByteString           file
-  when (pad == 1) $
-    putWord8              0x0a
-  where
-    pad         = st_size `mod` 2
-
-getArchMagic :: Get ()
-getArchMagic = do
-  magic <- liftM C.unpack $ getByteString 8
-  if magic /= "!<arch>\n"
-    then fail $ "Invalid magic number " ++ show magic
-    else return ()
-
-putArchMagic :: Put
-putArchMagic = putByteString $ C.pack "!<arch>\n"
-
-getArch :: Get Archive
-getArch = Archive <$> do
-  getArchMagic
-  getBSDArchEntries <|> getGNUArchEntries Nothing
-
-putBSDArch :: Archive -> PutM ()
-putBSDArch (Archive as) = do
-  putArchMagic
-  mapM_ putArchEntry (processEntries as)
-
-  where
-    padStr pad size str = take size $ str <> repeat pad
-    nameSize name = case length name `divMod` 4 of
-      (n, 0) -> 4 * n
-      (n, _) -> 4 * (n + 1)
-    needExt name = length name > 16 || ' ' `elem` name
-    processEntry :: ArchiveEntry -> ArchiveEntry
-    processEntry archive@(ArchiveEntry name _ _ _ _ st_size _)
-      | needExt name = archive { filename = "#1/" <> show sz
-                               , filedata = C.pack (padStr '\0' sz name) <> filedata archive
-                               , filesize = st_size + sz }
-      | otherwise    = archive
-
-      where sz = nameSize name
-
-    processEntries = map processEntry
-
-putGNUArch :: Archive -> PutM ()
-putGNUArch (Archive as) = do
-  putArchMagic
-  mapM_ putArchEntry (processEntries as)
-
-  where
-    processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry)
-    processEntry extInfo archive@(ArchiveEntry name _ _ _ _ _ _)
-      | length name > 15 = ( extInfo { filesize = filesize extInfo + length name + 2
-                                    ,  filedata = filedata extInfo <>  C.pack name <> "/\n" }
-                           , archive { filename = "/" <> show (filesize extInfo) } )
-      | otherwise        = ( extInfo, archive { filename = name <> "/" } )
-
-    processEntries :: [ArchiveEntry] -> [ArchiveEntry]
-    processEntries =
-      uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty)
-
-parseAr :: B.ByteString -> Archive
-parseAr = runGet getArch . L.fromChunks . pure
-
-writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO ()
-writeBSDAr fp = L.writeFile fp . runPut . putBSDArch
-writeGNUAr fp = L.writeFile fp . runPut . putGNUArch
-
-loadAr :: FilePath -> IO Archive
-loadAr fp = parseAr <$> B.readFile fp
-
-loadObj :: FilePath -> IO ArchiveEntry
-loadObj fp = do
-  payload <- B.readFile fp
-  (modt, own, grp, mode) <- fileInfo fp
-  return $ ArchiveEntry
-    (takeFileName fp) modt own grp mode
-    (B.length payload) payload
-
--- | Take a filePath and return (mod time, own, grp, mode in decimal)
-fileInfo :: FilePath -> IO ( Int, Int, Int, Int) -- ^ mod time, own, grp, mode (in decimal)
-#if defined(mingw32_HOST_OS)
--- on windows mod time, owner group and mode are zero.
-fileInfo _ = pure (0,0,0,0)
-#else
-fileInfo fp = go <$> POSIX.getFileStatus fp
-  where go status = ( fromEnum $ POSIX.modificationTime status
-                    , fromIntegral $ POSIX.fileOwner status
-                    , fromIntegral $ POSIX.fileGroup status
-                    , oct2dec . fromIntegral $ POSIX.fileMode status
-                    )
-
-oct2dec :: Int -> Int
-oct2dec = foldl' (\a b -> a * 10 + b) 0 . reverse . dec 8
-  where dec _ 0 = []
-        dec b i = let (rest, last) = i `quotRem` b
-                  in last:dec b rest
-
-#endif
diff --git a/compiler/GHC/SysTools/Cpp.hs b/compiler/GHC/SysTools/Cpp.hs
deleted file mode 100644
--- a/compiler/GHC/SysTools/Cpp.hs
+++ /dev/null
@@ -1,233 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE LambdaCase #-}
-
-#include <ghcplatform.h>
-
-module GHC.SysTools.Cpp
-  ( doCpp
-  , CppOpts (..)
-  , getGhcVersionPathName
-  , applyCDefs
-  , offsetIncludePaths
-  )
-where
-
-import GHC.Prelude
-import GHC.Driver.Session
-import GHC.Driver.Backend
-import GHC.CmmToLlvm.Config
-import GHC.Platform
-import GHC.Platform.ArchOS
-
-import GHC.SysTools
-
-import GHC.Unit.Env
-import GHC.Unit.Info
-import GHC.Unit.State
-import GHC.Unit.Types
-
-import GHC.Utils.Logger
-import GHC.Utils.TmpFs
-import GHC.Utils.Panic
-
-import Data.Version
-import Data.List (intercalate)
-import Data.Maybe
-
-import Control.Monad
-
-import System.Directory
-import System.FilePath
-
-data CppOpts = CppOpts
-  { cppUseCc       :: !Bool -- ^ Use "cc -E" as preprocessor, otherwise use "cpp"
-  , cppLinePragmas :: !Bool -- ^ Enable generation of LINE pragmas
-  }
-
--- | Run CPP
---
--- UnitEnv is needed to compute MIN_VERSION macros
-doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> CppOpts -> FilePath -> FilePath -> IO ()
-doCpp logger tmpfs dflags unit_env opts input_fn output_fn = do
-    let hscpp_opts = picPOpts dflags
-    let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags)
-    let unit_state = ue_units unit_env
-    pkg_include_dirs <- mayThrowUnitErr
-                        (collectIncludeDirs <$> preloadUnitsInfo unit_env)
-    -- MP: This is not quite right, the headers which are supposed to be installed in
-    -- the package might not be the same as the provided include paths, but it's a close
-    -- enough approximation for things to work. A proper solution would be to have to declare which paths should
-    -- be propagated to dependent packages.
-    let home_pkg_deps =
-         [homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env]
-        dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps]
-
-    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
-          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs
-                                                    ++ concatMap includePathsGlobal dep_pkg_extra_inputs)
-    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
-          (includePathsQuote cmdline_include_paths ++
-           includePathsQuoteImplicit cmdline_include_paths)
-    let include_paths = include_paths_quote ++ include_paths_global
-
-    let verbFlags = getVerbFlags dflags
-
-    let cpp_prog args
-          | cppUseCc opts = GHC.SysTools.runCc Nothing logger tmpfs dflags
-                                               (GHC.SysTools.Option "-E" : args)
-          | otherwise     = GHC.SysTools.runCpp logger dflags args
-
-    let platform   = targetPlatform dflags
-        targetArch = stringEncodeArch $ platformArch platform
-        targetOS = stringEncodeOS $ platformOS platform
-        isWindows = platformOS platform == OSMinGW32
-    let target_defs =
-          [ "-D" ++ HOST_OS     ++ "_BUILD_OS",
-            "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",
-            "-D" ++ targetOS    ++ "_HOST_OS",
-            "-D" ++ targetArch  ++ "_HOST_ARCH" ]
-        -- remember, in code we *compile*, the HOST is the same our TARGET,
-        -- and BUILD is the same as our HOST.
-
-    let io_manager_defs =
-          [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++
-          [ "-D__IO_MANAGER_MIO__=1"               ]
-
-    let sse_defs =
-          [ "-D__SSE__"      | isSseEnabled      platform ] ++
-          [ "-D__SSE2__"     | isSse2Enabled     platform ] ++
-          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]
-
-    let avx_defs =
-          [ "-D__AVX__"      | isAvxEnabled      dflags ] ++
-          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] ++
-          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
-          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
-          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] ++
-          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
-
-    backend_defs <- applyCDefs (backendCDefs $ backend dflags) logger dflags
-
-    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
-    -- Default CPP defines in Haskell source
-    ghcVersionH <- getGhcVersionPathName dflags unit_env
-    let hsSourceCppOpts = [ "-include", ghcVersionH ]
-
-    -- MIN_VERSION macros
-    let uids = explicitUnits unit_state
-        pkgs = mapMaybe (lookupUnit unit_state . fst) uids
-    mb_macro_include <-
-        if not (null pkgs) && gopt Opt_VersionMacros dflags
-            then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h"
-                    writeFile macro_stub (generatePackageVersionMacros pkgs)
-                    -- Include version macros for every *exposed* package.
-                    -- Without -hide-all-packages and with a package database
-                    -- size of 1000 packages, it takes cpp an estimated 2
-                    -- milliseconds to process this file. See #10970
-                    -- comment 8.
-                    return [GHC.SysTools.FileOption "-include" macro_stub]
-            else return []
-
-    let line_pragmas
-          | cppLinePragmas opts = [] -- on by default
-          | otherwise           = [GHC.SysTools.Option "-P"] -- disable LINE markers
-
-    cpp_prog       (   map GHC.SysTools.Option verbFlags
-                    ++ map GHC.SysTools.Option include_paths
-                    ++ map GHC.SysTools.Option hsSourceCppOpts
-                    ++ map GHC.SysTools.Option target_defs
-                    ++ map GHC.SysTools.Option backend_defs
-                    ++ map GHC.SysTools.Option th_defs
-                    ++ map GHC.SysTools.Option hscpp_opts
-                    ++ map GHC.SysTools.Option sse_defs
-                    ++ map GHC.SysTools.Option avx_defs
-                    ++ map GHC.SysTools.Option io_manager_defs
-                    ++ mb_macro_include
-                    ++ line_pragmas
-        -- Set the language mode to assembler-with-cpp when preprocessing. This
-        -- alleviates some of the C99 macro rules relating to whitespace and the hash
-        -- operator, which we tend to abuse. Clang in particular is not very happy
-        -- about this.
-                    ++ [ GHC.SysTools.Option     "-x"
-                       , GHC.SysTools.Option     "assembler-with-cpp"
-                       , GHC.SysTools.Option     input_fn
-        -- We hackily use Option instead of FileOption here, so that the file
-        -- name is not back-slashed on Windows.  cpp is capable of
-        -- dealing with / in filenames, so it works fine.  Furthermore
-        -- if we put in backslashes, cpp outputs #line directives
-        -- with *double* backslashes.   And that in turn means that
-        -- our error messages get double backslashes in them.
-        -- In due course we should arrange that the lexer deals
-        -- with these \\ escapes properly.
-                       , GHC.SysTools.Option     "-o"
-                       , GHC.SysTools.FileOption "" output_fn
-                       ])
-
--- ---------------------------------------------------------------------------
--- Macros (cribbed from Cabal)
-
-generatePackageVersionMacros :: [UnitInfo] -> String
-generatePackageVersionMacros pkgs = concat
-  -- Do not add any C-style comments. See #3389.
-  [ generateMacros "" pkgname version
-  | pkg <- pkgs
-  , let version = unitPackageVersion pkg
-        pkgname = map fixchar (unitPackageNameString pkg)
-  ]
-
-fixchar :: Char -> Char
-fixchar '-' = '_'
-fixchar c   = c
-
-generateMacros :: String -> String -> Version -> String
-generateMacros prefix name version =
-  concat
-  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
-  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
-  ,"  (major1) <  ",major1," || \\\n"
-  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"
-  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
-  ,"\n\n"
-  ]
-  where
-    take3 = \case
-      (a:b:c:_) -> (a,b,c)
-      _         -> error "take3"
-    (major1,major2,minor) = take3 $ map show (versionBranch version) ++ repeat "0"
-
-
--- | Find out path to @ghcversion.h@ file
-getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath
-getGhcVersionPathName dflags unit_env = do
-  candidates <- case ghcVersionFile dflags of
-    Just path -> return [path]
-    Nothing -> do
-        ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])
-        return ((</> "ghcversion.h") <$> collectIncludeDirs ps)
-
-  found <- filterM doesFileExist candidates
-  case found of
-      []    -> throwGhcExceptionIO (InstallationError
-                                    ("ghcversion.h missing; tried: "
-                                      ++ intercalate ", " candidates))
-      (x:_) -> return x
-
-applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String]
-applyCDefs NoCDefs _ _ = return []
-applyCDefs LlvmCDefs logger dflags = do
-    llvmVer <- figureLlvmVersion logger dflags
-    return $ case fmap llvmVersionList llvmVer of
-               Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]
-               Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]
-               _ -> []
-  where
-    format (major, minor)
-      | minor >= 100 = error "backendCDefs: Unsupported minor version"
-      | otherwise = show (100 * major + minor :: Int) -- Contract is Int
-
-
--- Note [Filepaths and Multiple Home Units]
-offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs
-offsetIncludePaths dflags (IncludeSpecs incs quotes impl) =
-     let go = map (augmentByWorkingDirectory dflags)
-     in IncludeSpecs (go incs) (go quotes) (go impl)
diff --git a/compiler/GHC/SysTools/Elf.hs b/compiler/GHC/SysTools/Elf.hs
deleted file mode 100644
--- a/compiler/GHC/SysTools/Elf.hs
+++ /dev/null
@@ -1,460 +0,0 @@
-{-
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow 2015
---
--- ELF format tools
---
------------------------------------------------------------------------------
--}
-
-module GHC.SysTools.Elf (
-    readElfSectionByName,
-    readElfNoteAsString,
-    makeElfNote
-  ) where
-
-import GHC.Prelude
-
-import GHC.Utils.Asm
-import GHC.Utils.Exception
-import GHC.Platform
-import GHC.Utils.Error
-import GHC.Data.Maybe       (MaybeT(..),runMaybeT)
-import GHC.Utils.Misc       (charToC)
-import GHC.Utils.Outputable (text,hcat)
-import GHC.Utils.Logger
-
-import Control.Monad (when)
-import Data.Binary.Get
-import Data.Word
-import Data.Char (ord)
-import Data.ByteString.Lazy (ByteString)
-import qualified Data.ByteString.Lazy as LBS
-import qualified Data.ByteString.Lazy.Char8 as B8
-
-{- Note [ELF specification]
-   ~~~~~~~~~~~~~~~~~~~~~~~~
-
-   ELF (Executable and Linking Format) is described in the System V Application
-   Binary Interface (or ABI). The latter is composed of two parts: a generic
-   part and a processor specific part. The generic ABI describes the parts of
-   the interface that remain constant across all hardware implementations of
-   System V.
-
-   The latest release of the specification of the generic ABI is the version
-   4.1 from March 18, 1997:
-
-     - http://www.sco.com/developers/devspecs/gabi41.pdf
-
-   Since 1997, snapshots of the draft for the "next" version are published:
-
-     - http://www.sco.com/developers/gabi/
-
-   Quoting the notice on the website: "There is more than one instance of these
-   chapters to permit references to older instances to remain valid. All
-   modifications to these chapters are forward-compatible, so that correct use
-   of an older specification will not be invalidated by a newer instance.
-   Approximately on a yearly basis, a new instance will be saved, as it reaches
-   what appears to be a stable state."
-
-   Nevertheless we will see that since 1998 it is not true for Note sections.
-
-   Many ELF sections
-   -----------------
-
-   ELF-4.1: the normal section number fields in ELF are limited to 16 bits,
-   which runs out of bits when you try to cram in more sections than that. Two
-   fields are concerned: the one containing the number of the sections and the
-   one containing the index of the section that contains section's names. (The
-   same thing applies to the field containing the number of segments, but we
-   don't care about it here).
-
-   ELF-next: to solve this, these fields in the ELF header have an escape
-   value (different for each case), and the actual section number is stashed
-   into unused fields in the first section header.
-
-   We support this extension as it is forward-compatible with ELF-4.1.
-   Moreover, GHC may generate objects with a lot of sections with the
-   "function-sections" feature (one section per function).
-
-   Note sections
-   -------------
-
-   Sections with type "note" (SHT_NOTE in the specification) are used to add
-   arbitrary data into an ELF file. An entry in a note section is composed of a
-   name, a type and a value.
-
-   ELF-4.1: "The note information in sections and program header elements holds
-   any number of entries, each of which is an array of 4-byte words in the
-   format of the target processor." Each entry has the following format:
-         | namesz |   Word32: size of the name string (including the ending \0)
-         | descsz |   Word32: size of the value
-         |  type  |   Word32: type of the note
-         |  name  |   Name string (with \0 padding to ensure 4-byte alignment)
-         |  ...   |
-         |  desc  |   Value (with \0 padding to ensure 4-byte alignment)
-         |  ...   |
-
-   ELF-next: "The note information in sections and program header elements
-   holds a variable amount of entries. In 64-bit objects (files with
-   e_ident[EI_CLASS] equal to ELFCLASS64), each entry is an array of 8-byte
-   words in the format of the target processor. In 32-bit objects (files with
-   e_ident[EI_CLASS] equal to ELFCLASS32), each entry is an array of 4-byte
-   words in the format of the target processor." (from 1998-2015 snapshots)
-
-   This is not forward-compatible with ELF-4.1. In practice, for almost all
-   platforms namesz, descz and type fields are 4-byte words for both 32-bit and
-   64-bit objects (see elf.h and readelf source code).
-
-   The only exception in readelf source code is for IA_64 machines with OpenVMS
-   OS: "This OS has so many departures from the ELF standard that we test it at
-   many places" (comment for is_ia64_vms() in readelf.c). In this case, namesz,
-   descsz and type fields are 8-byte words and name and value fields are padded
-   to ensure 8-byte alignment.
-
-   We don't support this platform in the following code. Reading a note section
-   could be done easily (by testing Machine and OS fields in the ELF header).
-   Writing a note section, however, requires that we generate a different
-   assembly code for GAS depending on the target platform and this is a little
-   bit more involved.
-
--}
-
-
--- | ELF header
---
--- The ELF header indicates the native word size (32-bit or 64-bit) and the
--- endianness of the target machine. We directly store getters for words of
--- different sizes as it is more convenient to use. We also store the word size
--- as it is useful to skip some uninteresting fields.
---
--- Other information such as the target machine and OS are left out as we don't
--- use them yet. We could add them in the future if we ever need them.
-data ElfHeader = ElfHeader
-   { gw16     :: Get Word16   -- ^ Get a Word16 with the correct endianness
-   , gw32     :: Get Word32   -- ^ Get a Word32 with the correct endianness
-   , gwN      :: Get Word64   -- ^ Get a Word with the correct word size
-                              --   and endianness
-   , wordSize :: Int          -- ^ Word size in bytes
-   }
-
-
--- | Read the ELF header
-readElfHeader :: Logger -> ByteString -> IO (Maybe ElfHeader)
-readElfHeader logger bs = runGetOrThrow getHeader bs `catchIO` \_ -> do
-    debugTraceMsg logger 3 $
-      text ("Unable to read ELF header")
-    return Nothing
-  where
-    getHeader = do
-      magic    <- getWord32be
-      ws       <- getWord8
-      endian   <- getWord8
-      version  <- getWord8
-      skip 9  -- skip OSABI, ABI version and padding
-      when (magic /= 0x7F454C46 || version /= 1) $ fail "Invalid ELF header"
-
-      case (ws, endian) of
-          -- ELF 32, little endian
-          (1,1) -> return . Just $ ElfHeader
-                           getWord16le
-                           getWord32le
-                           (fmap fromIntegral getWord32le) 4
-          -- ELF 32, big endian
-          (1,2) -> return . Just $ ElfHeader
-                           getWord16be
-                           getWord32be
-                           (fmap fromIntegral getWord32be) 4
-          -- ELF 64, little endian
-          (2,1) -> return . Just $ ElfHeader
-                           getWord16le
-                           getWord32le
-                           (fmap fromIntegral getWord64le) 8
-          -- ELF 64, big endian
-          (2,2) -> return . Just $ ElfHeader
-                           getWord16be
-                           getWord32be
-                           (fmap fromIntegral getWord64be) 8
-          _     -> fail "Invalid ELF header"
-
-
-------------------
--- SECTIONS
-------------------
-
-
--- | Description of the section table
-data SectionTable = SectionTable
-  { sectionTableOffset :: Word64  -- ^ offset of the table describing sections
-  , sectionEntrySize   :: Word16  -- ^ size of an entry in the section table
-  , sectionEntryCount  :: Word64  -- ^ number of sections
-  , sectionNameIndex   :: Word32  -- ^ index of a special section which
-                                  --   contains section's names
-  }
-
--- | Read the ELF section table
-readElfSectionTable :: Logger
-                    -> ElfHeader
-                    -> ByteString
-                    -> IO (Maybe SectionTable)
-
-readElfSectionTable logger hdr bs = action `catchIO` \_ -> do
-    debugTraceMsg logger 3 $
-      text ("Unable to read ELF section table")
-    return Nothing
-  where
-    getSectionTable :: Get SectionTable
-    getSectionTable = do
-      skip (24 + 2*wordSize hdr) -- skip header and some other fields
-      secTableOffset <- gwN hdr
-      skip 10
-      entrySize      <- gw16 hdr
-      entryCount     <- gw16 hdr
-      secNameIndex   <- gw16 hdr
-      return (SectionTable secTableOffset entrySize
-                           (fromIntegral entryCount)
-                           (fromIntegral secNameIndex))
-
-    action = do
-      secTable <- runGetOrThrow getSectionTable bs
-      -- In some cases, the number of entries and the index of the section
-      -- containing section's names must be found in unused fields of the first
-      -- section entry (see Note [ELF specification])
-      let
-        offSize0 = fromIntegral $ sectionTableOffset secTable + 8
-                                  + 3 * fromIntegral (wordSize hdr)
-        offLink0 = fromIntegral $ offSize0 + fromIntegral (wordSize hdr)
-
-      entryCount'     <- if sectionEntryCount secTable /= 0
-                          then return (sectionEntryCount secTable)
-                          else runGetOrThrow (gwN hdr) (LBS.drop offSize0 bs)
-      entryNameIndex' <- if sectionNameIndex secTable /= 0xffff
-                          then return (sectionNameIndex secTable)
-                          else runGetOrThrow (gw32 hdr) (LBS.drop offLink0 bs)
-      return (Just $ secTable
-        { sectionEntryCount = entryCount'
-        , sectionNameIndex  = entryNameIndex'
-        })
-
-
--- | A section
-data Section = Section
-  { entryName :: ByteString   -- ^ Name of the section
-  , entryBS   :: ByteString   -- ^ Content of the section
-  }
-
--- | Read a ELF section
-readElfSectionByIndex :: Logger
-                      -> ElfHeader
-                      -> SectionTable
-                      -> Word64
-                      -> ByteString
-                      -> IO (Maybe Section)
-
-readElfSectionByIndex logger hdr secTable i bs = action `catchIO` \_ -> do
-    debugTraceMsg logger 3 $
-      text ("Unable to read ELF section")
-    return Nothing
-  where
-    -- read an entry from the section table
-    getEntry = do
-      nameIndex <- gw32 hdr
-      skip (4+2*wordSize hdr)
-      offset    <- fmap fromIntegral $ gwN hdr
-      size      <- fmap fromIntegral $ gwN hdr
-      let bs' = LBS.take size (LBS.drop offset bs)
-      return (nameIndex,bs')
-
-    -- read the entry with the given index in the section table
-    getEntryByIndex x = runGetOrThrow getEntry bs'
-      where
-        bs' = LBS.drop off bs
-        off = fromIntegral $ sectionTableOffset secTable +
-                             x * fromIntegral (sectionEntrySize secTable)
-
-    -- Get the name of a section
-    getEntryName nameIndex = do
-      let idx = fromIntegral (sectionNameIndex secTable)
-      (_,nameTable) <- getEntryByIndex idx
-      let bs' = LBS.drop nameIndex nameTable
-      runGetOrThrow getLazyByteStringNul bs'
-
-    action = do
-      (nameIndex,bs') <- getEntryByIndex (fromIntegral i)
-      name            <- getEntryName (fromIntegral nameIndex)
-      return (Just $ Section name bs')
-
-
--- | Find a section from its name. Return the section contents.
---
--- We do not perform any check on the section type.
-findSectionFromName :: Logger
-                    -> ElfHeader
-                    -> SectionTable
-                    -> String
-                    -> ByteString
-                    -> IO (Maybe ByteString)
-findSectionFromName logger hdr secTable name bs =
-    rec [0..sectionEntryCount secTable - 1]
-  where
-    -- convert the required section name into a ByteString to perform
-    -- ByteString comparison instead of String comparison
-    name' = B8.pack name
-
-    -- compare recursively each section name and return the contents of
-    -- the matching one, if any
-    rec []     = return Nothing
-    rec (x:xs) = do
-      me <- readElfSectionByIndex logger hdr secTable x bs
-      case me of
-        Just e | entryName e == name' -> return (Just (entryBS e))
-        _                             -> rec xs
-
-
--- | Given a section name, read its contents as a ByteString.
---
--- If the section isn't found or if there is any parsing error, we return
--- Nothing
-readElfSectionByName :: Logger
-                     -> ByteString
-                     -> String
-                     -> IO (Maybe LBS.ByteString)
-
-readElfSectionByName logger bs name = action `catchIO` \_ -> do
-    debugTraceMsg logger 3 $
-      text ("Unable to read ELF section \"" ++ name ++ "\"")
-    return Nothing
-  where
-    action = runMaybeT $ do
-      hdr      <- MaybeT $ readElfHeader logger bs
-      secTable <- MaybeT $ readElfSectionTable logger hdr bs
-      MaybeT $ findSectionFromName logger hdr secTable name bs
-
-------------------
--- NOTE SECTIONS
-------------------
-
--- | read a Note as a ByteString
---
--- If you try to read a note from a section which does not support the Note
--- format, the parsing is likely to fail and Nothing will be returned
-readElfNoteBS :: Logger
-              -> ByteString
-              -> String
-              -> String
-              -> IO (Maybe LBS.ByteString)
-
-readElfNoteBS logger bs sectionName noteId = action `catchIO`  \_ -> do
-    debugTraceMsg logger 3 $
-         text ("Unable to read ELF note \"" ++ noteId ++
-               "\" in section \"" ++ sectionName ++ "\"")
-    return Nothing
-  where
-    -- align the getter on n bytes
-    align n = do
-      m <- bytesRead
-      if m `mod` n == 0
-        then return ()
-        else skip 1 >> align n
-
-    -- noteId as a bytestring
-    noteId' = B8.pack noteId
-
-    -- read notes recursively until the one with a valid identifier is found
-    findNote hdr = do
-      align 4
-      namesz <- gw32 hdr
-      descsz <- gw32 hdr
-      _      <- gw32 hdr -- we don't use the note type
-      name   <- if namesz == 0
-                  then return LBS.empty
-                  else getLazyByteStringNul
-      align 4
-      desc  <- if descsz == 0
-                  then return LBS.empty
-                  else getLazyByteString (fromIntegral descsz)
-      if name == noteId'
-        then return $ Just desc
-        else findNote hdr
-
-
-    action = runMaybeT $ do
-      hdr  <- MaybeT $ readElfHeader logger bs
-      sec  <- MaybeT $ readElfSectionByName logger bs sectionName
-      MaybeT $ runGetOrThrow (findNote hdr) sec
-
--- | read a Note as a String
---
--- If you try to read a note from a section which does not support the Note
--- format, the parsing is likely to fail and Nothing will be returned
-readElfNoteAsString :: Logger
-                    -> FilePath
-                    -> String
-                    -> String
-                    -> IO (Maybe String)
-
-readElfNoteAsString logger path sectionName noteId = action `catchIO`  \_ -> do
-    debugTraceMsg logger 3 $
-         text ("Unable to read ELF note \"" ++ noteId ++
-               "\" in section \"" ++ sectionName ++ "\"")
-    return Nothing
-  where
-    action = do
-      bs   <- LBS.readFile path
-      note <- readElfNoteBS logger bs sectionName noteId
-      return (fmap B8.unpack note)
-
-
--- | Generate the GAS code to create a Note section
---
--- Header fields for notes are 32-bit long (see Note [ELF specification]).
-makeElfNote :: Platform -> String -> String -> Word32 -> String -> SDoc
-makeElfNote platform sectionName noteName typ contents = hcat [
-    text "\t.section ",
-    text sectionName,
-    text ",\"\",",
-    sectionType platform "note",
-    text "\n",
-    text "\t.balign 4\n",
-
-    -- note name length (+ 1 for ending \0)
-    asWord32 (length noteName + 1),
-
-    -- note contents size
-    asWord32 (length contents),
-
-    -- note type
-    asWord32 typ,
-
-    -- note name (.asciz for \0 ending string) + padding
-    text "\t.asciz \"",
-    text noteName,
-    text "\"\n",
-    text "\t.balign 4\n",
-
-    -- note contents (.ascii to avoid ending \0) + padding
-    text "\t.ascii \"",
-    text (escape contents),
-    text "\"\n",
-    text "\t.balign 4\n"]
-  where
-    escape :: String -> String
-    escape = concatMap (charToC.fromIntegral.ord)
-
-    asWord32 :: Show a => a -> SDoc
-    asWord32 x = hcat [
-      text "\t.4byte ",
-      text (show x),
-      text "\n"]
-
-
-------------------
--- Helpers
-------------------
-
--- | runGet in IO monad that throws an IOException on failure
-runGetOrThrow :: Get a -> LBS.ByteString -> IO a
-runGetOrThrow g bs = case runGetOrFail g bs of
-  Left _        -> fail "Error while reading file"
-  Right (_,_,a) -> return a
diff --git a/compiler/GHC/SysTools/Info.hs b/compiler/GHC/SysTools/Info.hs
deleted file mode 100644
--- a/compiler/GHC/SysTools/Info.hs
+++ /dev/null
@@ -1,238 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
------------------------------------------------------------------------------
---
--- Compiler information functions
---
--- (c) The GHC Team 2017
---
------------------------------------------------------------------------------
-module GHC.SysTools.Info where
-
-import GHC.Utils.Exception
-import GHC.Utils.Error
-import GHC.Driver.Session
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Logger
-
-import Data.List ( isInfixOf, isPrefixOf )
-import Data.IORef
-
-import System.IO
-
-import GHC.Platform
-import GHC.Prelude
-
-import GHC.SysTools.Process
-
-{- Note [Run-time linker info]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See also: #5240, #6063, #10110
-
-Before 'runLink', we need to be sure to get the relevant information
-about the linker we're using at runtime to see if we need any extra
-options.
-
-Generally, the linker changing from what was detected at ./configure
-time has always been possible using -pgml, but on Linux it can happen
-'transparently' by installing packages like binutils-gold, which
-change what /usr/bin/ld actually points to.
-
-Clang vs GCC notes:
-
-For gcc, 'gcc -Wl,--version' gives a bunch of output about how to
-invoke the linker before the version information string. For 'clang',
-the version information for 'ld' is all that's output. For this
-reason, we typically need to slurp up all of the standard error output
-and look through it.
-
-Other notes:
-
-We cache the LinkerInfo inside DynFlags, since clients may link
-multiple times. The definition of LinkerInfo is there to avoid a
-circular dependency.
-
--}
-
-{- Note [ELF needed shared libs]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Some distributions change the link editor's default handling of
-ELF DT_NEEDED tags to include only those shared objects that are
-needed to resolve undefined symbols. For Template Haskell we need
-the last temporary shared library also if it is not needed for the
-currently linked temporary shared library. We specify --no-as-needed
-to override the default. This flag exists in GNU ld and GNU gold.
-
-The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
-(Mach-O) the flag is not needed.
-
--}
-
-neededLinkArgs :: LinkerInfo -> [Option]
-neededLinkArgs (GnuLD o)     = o
-neededLinkArgs (GnuGold o)   = o
-neededLinkArgs (LlvmLLD o)   = o
-neededLinkArgs (DarwinLD o)  = o
-neededLinkArgs (SolarisLD o) = o
-neededLinkArgs (AixLD o)     = o
-neededLinkArgs UnknownLD     = []
-
--- Grab linker info and cache it in DynFlags.
-getLinkerInfo :: Logger -> DynFlags -> IO LinkerInfo
-getLinkerInfo logger dflags = do
-  info <- readIORef (rtldInfo dflags)
-  case info of
-    Just v  -> return v
-    Nothing -> do
-      v <- getLinkerInfo' logger dflags
-      writeIORef (rtldInfo dflags) (Just v)
-      return v
-
--- See Note [Run-time linker info].
-getLinkerInfo' :: Logger -> DynFlags -> IO LinkerInfo
-getLinkerInfo' logger dflags = do
-  let platform = targetPlatform dflags
-      os = platformOS platform
-      (pgm,args0) = pgm_l dflags
-      args1       = map Option (getOpts dflags opt_l)
-      args2       = args0 ++ args1
-      args3       = filter notNull (map showOpt args2)
-
-      -- Try to grab the info from the process output.
-      parseLinkerInfo stdo _stde _exitc
-        | any ("GNU ld" `isPrefixOf`) stdo =
-          -- Set DT_NEEDED for all shared libraries. #10110.
-          return (GnuLD $ map Option [-- ELF specific flag
-                                      -- see Note [ELF needed shared libs]
-                                      "-Wl,--no-as-needed"])
-
-        | any ("GNU gold" `isPrefixOf`) stdo =
-          -- GNU gold only needs --no-as-needed. #10110.
-          -- ELF specific flag, see Note [ELF needed shared libs]
-          return (GnuGold [Option "-Wl,--no-as-needed"])
-
-        | any (\line -> "LLD" `isPrefixOf` line || "LLD" `elem` words line) stdo =
-          return (LlvmLLD $ map Option [ --see Note [ELF needed shared libs]
-                                        "-Wl,--no-as-needed" | osElfTarget os || os == OSMinGW32 ])
-
-         -- Unknown linker.
-        | otherwise = fail "invalid --version output, or linker is unsupported"
-
-  -- Process the executable call
-  catchIO (
-    case os of
-      OSSolaris2 ->
-        -- Solaris uses its own Solaris linker. Even all
-        -- GNU C are recommended to configure with Solaris
-        -- linker instead of using GNU binutils linker. Also
-        -- all GCC distributed with Solaris follows this rule
-        -- precisely so we assume here, the Solaris linker is
-        -- used.
-        return $ SolarisLD []
-      OSAIX ->
-        -- IBM AIX uses its own non-binutils linker as well
-        return $ AixLD []
-      OSDarwin ->
-        -- Darwin has neither GNU Gold or GNU LD, but a strange linker
-        -- that doesn't support --version. We can just assume that's
-        -- what we're using.
-        return $ DarwinLD []
-      OSMinGW32 ->
-        -- GHC doesn't support anything but GNU ld on Windows anyway.
-        -- Process creation is also fairly expensive on win32, so
-        -- we short-circuit here.
-        return $ GnuLD $ map Option
-          [ -- Emit stack checks
-            -- See Note [Windows stack allocations]
-           "-fstack-check"
-          ]
-      _ -> do
-        -- In practice, we use the compiler as the linker here. Pass
-        -- -Wl,--version to get linker version info.
-        (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm
-                               (["-Wl,--version"] ++ args3)
-                               c_locale_env
-        -- Split the output by lines to make certain kinds
-        -- of processing easier. In particular, 'clang' and 'gcc'
-        -- have slightly different outputs for '-Wl,--version', but
-        -- it's still easy to figure out.
-        parseLinkerInfo (lines stdo) (lines stde) exitc
-    )
-    (\err -> do
-        debugTraceMsg logger 2
-            (text "Error (figuring out linker information):" <+>
-             text (show err))
-        errorMsg logger $ hang (text "Warning:") 9 $
-          text "Couldn't figure out linker information!" $$
-          text "Make sure you're using GNU ld, GNU gold" <+>
-          text "or the built in OS X linker, etc."
-        return UnknownLD
-    )
-
--- | Grab compiler info and cache it in DynFlags.
-getCompilerInfo :: Logger -> DynFlags -> IO CompilerInfo
-getCompilerInfo logger dflags = do
-  info <- readIORef (rtccInfo dflags)
-  case info of
-    Just v  -> return v
-    Nothing -> do
-      let pgm = pgm_c dflags
-      v <- getCompilerInfo' logger pgm
-      writeIORef (rtccInfo dflags) (Just v)
-      return v
-
--- | Grab assembler info and cache it in DynFlags.
-getAssemblerInfo :: Logger -> DynFlags -> IO CompilerInfo
-getAssemblerInfo logger dflags = do
-  info <- readIORef (rtasmInfo dflags)
-  case info of
-    Just v  -> return v
-    Nothing -> do
-      let (pgm, _) = pgm_a dflags
-      v <- getCompilerInfo' logger pgm
-      writeIORef (rtasmInfo dflags) (Just v)
-      return v
-
--- See Note [Run-time linker info].
-getCompilerInfo' :: Logger -> String -> IO CompilerInfo
-getCompilerInfo' logger pgm = do
-  let -- Try to grab the info from the process output.
-      parseCompilerInfo _stdo stde _exitc
-        -- Regular GCC
-        | any ("gcc version" `isInfixOf`) stde =
-          return GCC
-        -- Regular clang
-        | any ("clang version" `isInfixOf`) stde =
-          return Clang
-        -- FreeBSD clang
-        | any ("FreeBSD clang version" `isInfixOf`) stde =
-          return Clang
-        -- Xcode 5.1 clang
-        | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =
-          return AppleClang51
-        -- Xcode 5 clang
-        | any ("Apple LLVM version" `isPrefixOf`) stde =
-          return AppleClang
-        -- Xcode 4.1 clang
-        | any ("Apple clang version" `isPrefixOf`) stde =
-          return AppleClang
-         -- Unknown compiler.
-        | otherwise = fail $ "invalid -v output, or compiler is unsupported (" ++ pgm ++ "): " ++ unlines stde
-
-  -- Process the executable call
-  catchIO (do
-      (exitc, stdo, stde) <-
-          readProcessEnvWithExitCode pgm ["-v"] c_locale_env
-      -- Split the output by lines to make certain kinds
-      -- of processing easier.
-      parseCompilerInfo (lines stdo) (lines stde) exitc
-      )
-      (\err -> do
-          debugTraceMsg logger 2
-              (text "Error (figuring out C compiler information):" <+>
-               text (show err))
-          errorMsg logger $ hang (text "Warning:") 9 $
-            text "Couldn't figure out C compiler information!" $$
-            text "Make sure you're using GNU gcc, or clang"
-          return UnknownCC
-      )
diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs
deleted file mode 100644
--- a/compiler/GHC/SysTools/Process.hs
+++ /dev/null
@@ -1,405 +0,0 @@
-{-# LANGUAGE CPP #-}
------------------------------------------------------------------------------
---
--- Misc process handling code for SysTools
---
--- (c) The GHC Team 2017
---
------------------------------------------------------------------------------
-module GHC.SysTools.Process where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-
-import GHC.Utils.Exception
-import GHC.Utils.Error
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Misc
-import GHC.Utils.Logger
-
-import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan )
-import GHC.Data.FastString
-
-import Control.Concurrent
-import Data.Char
-
-import System.Exit
-import System.Environment
-import System.FilePath
-import System.IO
-import System.IO.Error as IO
-import System.Process
-
-import GHC.Utils.TmpFs
-
--- | Enable process jobs support on Windows if it can be expected to work (e.g.
--- @process >= 1.6.9.0@).
-enableProcessJobs :: CreateProcess -> CreateProcess
-#if defined(MIN_VERSION_process)
-enableProcessJobs opts = opts { use_process_jobs = True }
-#else
-enableProcessJobs opts = opts
-#endif
-
-#if !MIN_VERSION_base(4,15,0)
--- TODO: This can be dropped with GHC 8.16
-hGetContents' :: Handle -> IO String
-hGetContents' hdl = do
-  output  <- hGetContents hdl
-  _ <- evaluate $ length output
-  return output
-#endif
-
--- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
--- inherited from the parent process, and output to stderr is not captured.
-readCreateProcessWithExitCode'
-    :: CreateProcess
-    -> IO (ExitCode, String)    -- ^ stdout
-readCreateProcessWithExitCode' proc = do
-    (_, Just outh, _, pid) <-
-        createProcess $ enableProcessJobs $ proc{ std_out = CreatePipe }
-
-    -- fork off a thread to start consuming the output
-    outMVar <- newEmptyMVar
-    let onError :: SomeException -> IO ()
-        onError exc = putMVar outMVar (Left exc)
-    _ <- forkIO $ handle onError $ do
-      output <- hGetContents' outh
-      putMVar outMVar $ Right output
-
-    -- wait on the output
-    result <- takeMVar outMVar
-    hClose outh
-    output <- case result of
-      Left exc -> throwIO exc
-      Right output -> return output
-
-    -- wait on the process
-    ex <- waitForProcess pid
-
-    return (ex, output)
-
-replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
-replaceVar (var, value) env =
-    (var, value) : filter (\(var',_) -> var /= var') env
-
--- | Version of @System.Process.readProcessWithExitCode@ that takes a
--- key-value tuple to insert into the environment.
-readProcessEnvWithExitCode
-    :: String -- ^ program path
-    -> [String] -- ^ program args
-    -> (String, String) -- ^ addition to the environment
-    -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
-readProcessEnvWithExitCode prog args env_update = do
-    current_env <- getEnvironment
-    readCreateProcessWithExitCode (proc prog args) {
-        env = Just (replaceVar env_update current_env) } ""
-
--- Don't let gcc localize version info string, #8825
-c_locale_env :: (String, String)
-c_locale_env = ("LANGUAGE", "C")
-
--- If the -B<dir> option is set, add <dir> to PATH.  This works around
--- a bug in gcc on Windows Vista where it can't find its auxiliary
--- binaries (see bug #1110).
-getGccEnv :: [Option] -> IO (Maybe [(String,String)])
-getGccEnv opts =
-  if null b_dirs
-     then return Nothing
-     else do env <- getEnvironment
-             return (Just (mangle_paths env))
- where
-  (b_dirs, _) = partitionWith get_b_opt opts
-
-  get_b_opt (Option ('-':'B':dir)) = Left dir
-  get_b_opt other = Right other
-
-  -- Work around #1110 on Windows only (lest we stumble into #17266).
-#if defined(mingw32_HOST_OS)
-  mangle_paths = map mangle_path
-  mangle_path (path,paths) | map toUpper path == "PATH"
-        = (path, '\"' : head b_dirs ++ "\";" ++ paths)
-  mangle_path other = other
-#else
-  mangle_paths = id
-#endif
-
-
------------------------------------------------------------------------------
--- Running an external program
-
-runSomething :: Logger
-             -> String          -- For -v message
-             -> String          -- Command name (possibly a full path)
-                                --      assumed already dos-ified
-             -> [Option]        -- Arguments
-                                --      runSomething will dos-ify them
-             -> IO ()
-
-runSomething logger phase_name pgm args =
-  runSomethingFiltered logger id phase_name pgm args Nothing Nothing
-
--- | Run a command, placing the arguments in an external response file.
---
--- This command is used in order to avoid overlong command line arguments on
--- Windows. The command line arguments are first written to an external,
--- temporary response file, and then passed to the linker via @filepath.
--- response files for passing them in. See:
---
---     https://gcc.gnu.org/wiki/Response_Files
---     https://gitlab.haskell.org/ghc/ghc/issues/10777
-runSomethingResponseFile
-  :: Logger
-  -> TmpFs
-  -> DynFlags
-  -> (String->String)
-  -> String
-  -> String
-  -> [Option]
-  -> Maybe [(String,String)]
-  -> IO ()
-runSomethingResponseFile logger tmpfs dflags filter_fn phase_name pgm args mb_env =
-    runSomethingWith logger phase_name pgm args $ \real_args -> do
-        fp <- getResponseFile real_args
-        let args = ['@':fp]
-        r <- builderMainLoop logger filter_fn pgm args Nothing mb_env
-        return (r,())
-  where
-    getResponseFile args = do
-      fp <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rsp"
-      withFile fp WriteMode $ \h -> do
-          hSetEncoding h utf8
-          hPutStr h $ unlines $ map escape args
-      return fp
-
-    -- Note: Response files have backslash-escaping, double quoting, and are
-    -- whitespace separated (some implementations use newline, others any
-    -- whitespace character). Therefore, escape any backslashes, newlines, and
-    -- double quotes in the argument, and surround the content with double
-    -- quotes.
-    --
-    -- Another possibility that could be considered would be to convert
-    -- backslashes in the argument to forward slashes. This would generally do
-    -- the right thing, since backslashes in general only appear in arguments
-    -- as part of file paths on Windows, and the forward slash is accepted for
-    -- those. However, escaping is more reliable, in case somehow a backslash
-    -- appears in a non-file.
-    escape x = concat
-        [ "\""
-        , concatMap
-            (\c ->
-                case c of
-                    '\\' -> "\\\\"
-                    '\n' -> "\\n"
-                    '\"' -> "\\\""
-                    _    -> [c])
-            x
-        , "\""
-        ]
-
-runSomethingFiltered
-  :: Logger -> (String->String) -> String -> String -> [Option]
-  -> Maybe FilePath -> Maybe [(String,String)] -> IO ()
-
-runSomethingFiltered logger filter_fn phase_name pgm args mb_cwd mb_env =
-    runSomethingWith logger phase_name pgm args $ \real_args -> do
-        r <- builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env
-        return (r,())
-
-runSomethingWith
-  :: Logger -> String -> String -> [Option]
-  -> ([String] -> IO (ExitCode, a))
-  -> IO a
-
-runSomethingWith logger phase_name pgm args io = do
-  let real_args = filter notNull (map showOpt args)
-      cmdLine = showCommandForUser pgm real_args
-  traceCmd logger phase_name cmdLine $ handleProc pgm phase_name $ io real_args
-
-handleProc :: String -> String -> IO (ExitCode, r) -> IO r
-handleProc pgm phase_name proc = do
-    (rc, r) <- proc `catchIO` handler
-    case rc of
-      ExitSuccess{} -> return r
-      ExitFailure n -> throwGhcExceptionIO (
-            ProgramError ("`" ++ takeFileName pgm ++ "'" ++
-                          " failed in phase `" ++ phase_name ++ "'." ++
-                          " (Exit code: " ++ show n ++ ")"))
-  where
-    handler err =
-       if IO.isDoesNotExistError err
-          then does_not_exist
-          else throwGhcExceptionIO (ProgramError $ show err)
-
-    does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
-
-
-builderMainLoop :: Logger -> (String -> String) -> FilePath
-                -> [String] -> Maybe FilePath -> Maybe [(String, String)]
-                -> IO ExitCode
-builderMainLoop logger filter_fn pgm real_args mb_cwd mb_env = do
-  chan <- newChan
-
-  -- We use a mask here rather than a bracket because we want
-  -- to distinguish between cleaning up with and without an
-  -- exception. This is to avoid calling terminateProcess
-  -- unless an exception was raised.
-  let safely inner = mask $ \restore -> do
-        -- acquire
-        -- On Windows due to how exec is emulated the old process will exit and
-        -- a new process will be created. This means waiting for termination of
-        -- the parent process will get you in a race condition as the child may
-        -- not have finished yet.  This caused #16450.  To fix this use a
-        -- process job to track all child processes and wait for each one to
-        -- finish.
-        let procdata =
-              enableProcessJobs
-              $ (proc pgm real_args) { cwd = mb_cwd
-                                     , env = mb_env
-                                     , std_in  = CreatePipe
-                                     , std_out = CreatePipe
-                                     , std_err = CreatePipe
-                                     }
-        (Just hStdIn, Just hStdOut, Just hStdErr, hProcess) <- restore $
-          createProcess_ "builderMainLoop" procdata
-        let cleanup_handles = do
-              hClose hStdIn
-              hClose hStdOut
-              hClose hStdErr
-        r <- try $ restore $ do
-          hSetBuffering hStdOut LineBuffering
-          hSetBuffering hStdErr LineBuffering
-          let make_reader_proc h = forkIO $ readerProc chan h filter_fn
-          bracketOnError (make_reader_proc hStdOut) killThread $ \_ ->
-            bracketOnError (make_reader_proc hStdErr) killThread $ \_ ->
-            inner hProcess
-        case r of
-          -- onException
-          Left (SomeException e) -> do
-            terminateProcess hProcess
-            cleanup_handles
-            throw e
-          -- cleanup when there was no exception
-          Right s -> do
-            cleanup_handles
-            return s
-  safely $ \h -> do
-    -- we don't want to finish until 2 streams have been complete
-    -- (stdout and stderr)
-    log_loop chan (2 :: Integer)
-    -- after that, we wait for the process to finish and return the exit code.
-    waitForProcess h
-  where
-    -- t starts at the number of streams we're listening to (2) decrements each
-    -- time a reader process sends EOF. We are safe from looping forever if a
-    -- reader thread dies, because they send EOF in a finally handler.
-    log_loop _ 0 = return ()
-    log_loop chan t = do
-      msg <- readChan chan
-      case msg of
-        BuildMsg msg -> do
-          logInfo logger $ withPprStyle defaultUserStyle msg
-          log_loop chan t
-        BuildError loc msg -> do
-          logMsg logger errorDiagnostic (mkSrcSpan loc loc)
-              $ withPprStyle defaultUserStyle msg
-          log_loop chan t
-        EOF ->
-          log_loop chan  (t-1)
-
-readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
-readerProc chan hdl filter_fn =
-    (do str <- hGetContents hdl
-        loop (linesPlatform (filter_fn str)) Nothing)
-    `finally`
-       writeChan chan EOF
-        -- ToDo: check errors more carefully
-        -- ToDo: in the future, the filter should be implemented as
-        -- a stream transformer.
-    where
-        loop []     Nothing    = return ()
-        loop []     (Just err) = writeChan chan err
-        loop (l:ls) in_err     =
-                case in_err of
-                  Just err@(BuildError srcLoc msg)
-                    | leading_whitespace l ->
-                        loop ls (Just (BuildError srcLoc (msg $$ text l)))
-                    | otherwise -> do
-                        writeChan chan err
-                        checkError l ls
-                  Nothing ->
-                        checkError l ls
-                  _ -> panic "readerProc/loop"
-
-        checkError l ls
-           = case parseError l of
-                Nothing -> do
-                    writeChan chan (BuildMsg (text l))
-                    loop ls Nothing
-                Just (file, lineNum, colNum, msg) -> do
-                    let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
-                    loop ls (Just (BuildError srcLoc (text msg)))
-
-        leading_whitespace []    = False
-        leading_whitespace (x:_) = isSpace x
-
-parseError :: String -> Maybe (String, Int, Int, String)
-parseError s0 = case breakColon s0 of
-                Just (filename, s1) ->
-                    case breakIntColon s1 of
-                    Just (lineNum, s2) ->
-                        case breakIntColon s2 of
-                        Just (columnNum, s3) ->
-                            Just (filename, lineNum, columnNum, s3)
-                        Nothing ->
-                            Just (filename, lineNum, 0, s2)
-                    Nothing -> Nothing
-                Nothing -> Nothing
-
--- | Break a line of an error message into a filename and the rest of the line,
--- taking care to ignore colons in Windows drive letters (as noted in #17786).
--- For instance,
---
--- * @"hi.c: ABCD"@ is mapped to @Just ("hi.c", \"ABCD\")@
--- * @"C:\\hi.c: ABCD"@ is mapped to @Just ("C:\\hi.c", \"ABCD\")@
-breakColon :: String -> Maybe (String, String)
-breakColon = go []
-  where
-    -- Don't break on Windows drive letters (e.g. @C:\@ or @C:/@)
-    go accum  (':':'\\':rest) = go ('\\':':':accum) rest
-    go accum  (':':'/':rest)  = go ('/':':':accum) rest
-    go accum  (':':rest)      = Just (reverse accum, rest)
-    go accum  (c:rest)        = go (c:accum) rest
-    go _accum []              = Nothing
-
-breakIntColon :: String -> Maybe (Int, String)
-breakIntColon xs = case break (':' ==) xs of
-                       (ys, _:zs)
-                        | not (null ys) && all isAscii ys && all isDigit ys ->
-                           Just (read ys, zs)
-                       _ -> Nothing
-
-data BuildMessage
-  = BuildMsg   !SDoc
-  | BuildError !SrcLoc !SDoc
-  | EOF
-
--- Divvy up text stream into lines, taking platform dependent
--- line termination into account.
-linesPlatform :: String -> [String]
-#if !defined(mingw32_HOST_OS)
-linesPlatform ls = lines ls
-#else
-linesPlatform "" = []
-linesPlatform xs =
-  case lineBreak xs of
-    (as,xs1) -> as : linesPlatform xs1
-  where
-   lineBreak "" = ("","")
-   lineBreak ('\r':'\n':xs) = ([],xs)
-   lineBreak ('\n':xs) = ([],xs)
-   lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
-
-#endif
diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs
deleted file mode 100644
--- a/compiler/GHC/SysTools/Tasks.hs
+++ /dev/null
@@ -1,391 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
------------------------------------------------------------------------------
---
--- Tasks running external programs for SysTools
---
--- (c) The GHC Team 2017
---
------------------------------------------------------------------------------
-module GHC.SysTools.Tasks where
-
-import GHC.Prelude
-import GHC.Platform
-import GHC.ForeignSrcLang
-import GHC.IO (catchException)
-
-import GHC.CmmToLlvm.Config (LlvmVersion, llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound)
-
-import GHC.SysTools.Process
-import GHC.SysTools.Info
-
-import GHC.Driver.Session
-
-import GHC.Utils.Exception as Exception
-import GHC.Utils.Error
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Logger
-import GHC.Utils.TmpFs
-import GHC.Utils.Constants (isWindowsHost)
-import GHC.Utils.Panic
-
-import Data.List (tails, isPrefixOf)
-import Data.Maybe (fromMaybe)
-import System.IO
-import System.Process
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Running an external program}
-*                                                                      *
-************************************************************************
--}
-
-runUnlit :: Logger -> DynFlags -> [Option] -> IO ()
-runUnlit logger dflags args = traceSystoolCommand logger "unlit" $ do
-  let prog = pgm_L dflags
-      opts = getOpts dflags opt_L
-  runSomething logger "Literate pre-processor" prog
-               (map Option opts ++ args)
-
--- | Prepend the working directory to the search path.
--- Note [Filepaths and Multiple Home Units]
-augmentImports :: DynFlags  -> [FilePath] -> [FilePath]
-augmentImports dflags fps | Nothing <- workingDirectory dflags  = fps
-augmentImports _ [] = []
-augmentImports _ [x] = [x]
-augmentImports dflags ("-include":fp:fps) = "-include" : augmentByWorkingDirectory dflags fp  : augmentImports dflags fps
-augmentImports dflags (fp1: fp2: fps) = fp1 : augmentImports dflags (fp2:fps)
-
-runCpp :: Logger -> DynFlags -> [Option] -> IO ()
-runCpp logger dflags args = traceSystoolCommand logger "cpp" $ do
-  let opts = getOpts dflags opt_P
-      modified_imports = augmentImports dflags opts
-  let (p,args0) = pgm_P dflags
-      args1 = map Option modified_imports
-      args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]
-                ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]
-  mb_env <- getGccEnv args2
-  runSomethingFiltered logger id  "C pre-processor" p
-                       (args0 ++ args1 ++ args2 ++ args) Nothing mb_env
-
-runPp :: Logger -> DynFlags -> [Option] -> IO ()
-runPp logger dflags args = traceSystoolCommand logger "pp" $ do
-  let prog = pgm_F dflags
-      opts = map Option (getOpts dflags opt_F)
-  runSomething logger "Haskell pre-processor" prog (args ++ opts)
-
--- | Run compiler of C-like languages and raw objects (such as gcc or clang).
-runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
-runCc mLanguage logger tmpfs dflags args = traceSystoolCommand logger "cc" $ do
-  let args1 = map Option userOpts
-      args2 = languageOptions ++ args ++ args1
-      -- We take care to pass -optc flags in args1 last to ensure that the
-      -- user can override flags passed by GHC. See #14452.
-  mb_env <- getGccEnv args2
-  runSomethingResponseFile logger tmpfs dflags cc_filter dbgstring prog args2
-                           mb_env
- where
-  -- discard some harmless warnings from gcc that we can't turn off
-  cc_filter = unlines . doFilter . lines
-
-  {-
-  gcc gives warnings in chunks like so:
-      In file included from /foo/bar/baz.h:11,
-                       from /foo/bar/baz2.h:22,
-                       from wibble.c:33:
-      /foo/flibble:14: global register variable ...
-      /foo/flibble:15: warning: call-clobbered r...
-  We break it up into its chunks, remove any call-clobbered register
-  warnings from each chunk, and then delete any chunks that we have
-  emptied of warnings.
-  -}
-  doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
-  -- We can't assume that the output will start with an "In file inc..."
-  -- line, so we start off expecting a list of warnings rather than a
-  -- location stack.
-  chunkWarnings :: [String] -- The location stack to use for the next
-                            -- list of warnings
-                -> [String] -- The remaining lines to look at
-                -> [([String], [String])]
-  chunkWarnings loc_stack [] = [(loc_stack, [])]
-  chunkWarnings loc_stack xs
-      = case break loc_stack_start xs of
-        (warnings, lss:xs') ->
-            case span loc_start_continuation xs' of
-            (lsc, xs'') ->
-                (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
-        _ -> [(loc_stack, xs)]
-
-  filterWarnings :: [([String], [String])] -> [([String], [String])]
-  filterWarnings [] = []
-  -- If the warnings are already empty then we are probably doing
-  -- something wrong, so don't delete anything
-  filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
-  filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
-                                       [] -> filterWarnings zs
-                                       ys' -> (xs, ys') : filterWarnings zs
-
-  unChunkWarnings :: [([String], [String])] -> [String]
-  unChunkWarnings [] = []
-  unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
-
-  loc_stack_start        s = "In file included from " `isPrefixOf` s
-  loc_start_continuation s = "                 from " `isPrefixOf` s
-  wantedWarning w
-   | "warning: call-clobbered register used" `isContainedIn` w = False
-   | otherwise = True
-
-  -- force the C compiler to interpret this file as C when
-  -- compiling .hc files, by adding the -x c option.
-  -- Also useful for plain .c files, just in case GHC saw a
-  -- -x c option.
-  (languageOptions, userOpts, prog, dbgstring) = case mLanguage of
-    Nothing -> ([], userOpts_c, pgm_c dflags, "C Compiler")
-    Just language -> ([Option "-x", Option languageName], opts, prog, dbgstr)
-      where
-        (languageName, opts, prog, dbgstr) = case language of
-          LangC      -> ("c",             userOpts_c
-                        ,pgm_c dflags,    "C Compiler")
-          LangCxx    -> ("c++",           userOpts_cxx
-                        ,pgm_cxx dflags , "C++ Compiler")
-          LangObjc   -> ("objective-c",   userOpts_c
-                        ,pgm_c dflags   , "Objective C Compiler")
-          LangObjcxx -> ("objective-c++", userOpts_cxx
-                        ,pgm_cxx dflags,  "Objective C++ Compiler")
-          LangAsm    -> ("assembler",     []
-                        ,pgm_c dflags,    "Asm Compiler")
-          RawObject  -> ("c",             []
-                        ,pgm_c dflags,    "C Compiler") -- claim C for lack of a better idea
-          --JS backend shouldn't reach here, so we just pass
-          -- strings to satisfy the totality checker
-          LangJs     -> ("js",            []
-                        ,pgm_c dflags,    "JS Backend Compiler")
-  userOpts_c   = getOpts dflags opt_c
-  userOpts_cxx = getOpts dflags opt_cxx
-
-isContainedIn :: String -> String -> Bool
-xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
-
--- | Run the linker with some arguments and return the output
-askLd :: Logger -> DynFlags -> [Option] -> IO String
-askLd logger dflags args = traceSystoolCommand logger "linker" $ do
-  let (p,args0) = pgm_l dflags
-      args1     = map Option (getOpts dflags opt_l)
-      args2     = args0 ++ args1 ++ args
-  mb_env <- getGccEnv args2
-  runSomethingWith logger "gcc" p args2 $ \real_args ->
-    readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
-
-runAs :: Logger -> DynFlags -> [Option] -> IO ()
-runAs logger dflags args = traceSystoolCommand logger "as" $ do
-  let (p,args0) = pgm_a dflags
-      args1 = map Option (getOpts dflags opt_a)
-      args2 = args0 ++ args1 ++ args
-  mb_env <- getGccEnv args2
-  runSomethingFiltered logger id "Assembler" p args2 Nothing mb_env
-
--- | Run the LLVM Optimiser
-runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO ()
-runLlvmOpt logger dflags args = traceSystoolCommand logger "opt" $ do
-  let (p,args0) = pgm_lo dflags
-      args1 = map Option (getOpts dflags opt_lo)
-      -- We take care to pass -optlo flags (e.g. args0) last to ensure that the
-      -- user can override flags passed by GHC. See #14821.
-  runSomething logger "LLVM Optimiser" p (args1 ++ args ++ args0)
-
--- | Run the LLVM Compiler
-runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO ()
-runLlvmLlc logger dflags args = traceSystoolCommand logger "llc" $ do
-  let (p,args0) = pgm_lc dflags
-      args1 = map Option (getOpts dflags opt_lc)
-  runSomething logger "LLVM Compiler" p (args0 ++ args1 ++ args)
-
--- | Run the clang compiler (used as an assembler for the LLVM
--- backend on OS X as LLVM doesn't support the OS X system
--- assembler)
-runClang :: Logger -> DynFlags -> [Option] -> IO ()
-runClang logger dflags args = traceSystoolCommand logger "clang" $ do
-  let (clang,_) = pgm_lcc dflags
-      -- be careful what options we call clang with
-      -- see #5903 and #7617 for bugs caused by this.
-      (_,args0) = pgm_a dflags
-      args1 = map Option (getOpts dflags opt_a)
-      args2 = args0 ++ args1 ++ args
-  mb_env <- getGccEnv args2
-  catchException
-    (runSomethingFiltered logger id "Clang (Assembler)" clang args2 Nothing mb_env)
-    (\(err :: SomeException) -> do
-        errorMsg logger $
-            text ("Error running clang! you need clang installed to use the" ++
-                  " LLVM backend") $+$
-            text "(or GHC tried to execute clang incorrectly)"
-        throwIO err
-    )
-
-runEmscripten :: Logger -> DynFlags -> [Option] -> IO ()
-runEmscripten logger dflags args = traceSystoolCommand logger "emcc" $ do
-  let (p,args0) = pgm_a dflags
-      args1     = args0 ++ args
-  runSomething logger "Emscripten" p args1
-
--- | Figure out which version of LLVM we are running this session
-figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion)
-figureLlvmVersion logger dflags = traceSystoolCommand logger "llc" $ do
-  let (pgm,opts) = pgm_lc dflags
-      args = filter notNull (map showOpt opts)
-      -- we grab the args even though they should be useless just in
-      -- case the user is using a customised 'llc' that requires some
-      -- of the options they've specified. llc doesn't care what other
-      -- options are specified when '-version' is used.
-      args' = args ++ ["-version"]
-  catchIO (do
-              (pin, pout, perr, p) <- runInteractiveProcess pgm args'
-                                              Nothing Nothing
-              {- > llc -version
-                  LLVM (http://llvm.org/):
-                    LLVM version 3.5.2
-                    ...
-              -}
-              hSetBinaryMode pout False
-              _     <- hGetLine pout
-              vline <- hGetLine pout
-              let mb_ver = parseLlvmVersion vline
-              hClose pin
-              hClose pout
-              hClose perr
-              _ <- waitForProcess p
-              return mb_ver
-            )
-            (\err -> do
-                debugTraceMsg logger 2
-                    (text "Error (figuring out LLVM version):" <+>
-                      text (show err))
-                errorMsg logger $ vcat
-                    [ text "Warning:", nest 9 $
-                          text "Couldn't figure out LLVM version!" $$
-                          text ("Make sure you have installed LLVM between ["
-                                ++ llvmVersionStr supportedLlvmVersionLowerBound
-                                ++ " and "
-                                ++ llvmVersionStr supportedLlvmVersionUpperBound
-                                ++ ")") ]
-                return Nothing)
-
-
-
-runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
-runLink logger tmpfs dflags args = traceSystoolCommand logger "linker" $ do
-  -- See Note [Run-time linker info]
-  --
-  -- `-optl` args come at the end, so that later `-l` options
-  -- given there manually can fill in symbols needed by
-  -- Haskell libraries coming in via `args`.
-  linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags
-  let (p,args0) = pgm_l dflags
-      optl_args = map Option (getOpts dflags opt_l)
-      args2     = args0 ++ linkargs ++ args ++ optl_args
-  mb_env <- getGccEnv args2
-  runSomethingResponseFile logger tmpfs dflags ld_filter "Linker" p args2 mb_env
-  where
-    ld_filter = case (platformOS (targetPlatform dflags)) of
-                  OSSolaris2 -> sunos_ld_filter
-                  _ -> id
-{-
-  SunOS/Solaris ld emits harmless warning messages about unresolved
-  symbols in case of compiling into shared library when we do not
-  link against all the required libs. That is the case of GHC which
-  does not link against RTS library explicitly in order to be able to
-  choose the library later based on binary application linking
-  parameters. The warnings look like:
-
-Undefined                       first referenced
-  symbol                             in file
-stg_ap_n_fast                       ./T2386_Lib.o
-stg_upd_frame_info                  ./T2386_Lib.o
-templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
-templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
-templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
-templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
-newCAF                              ./T2386_Lib.o
-stg_bh_upd_frame_info               ./T2386_Lib.o
-stg_ap_ppp_fast                     ./T2386_Lib.o
-templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
-stg_ap_p_fast                       ./T2386_Lib.o
-stg_ap_pp_fast                      ./T2386_Lib.o
-ld: warning: symbol referencing errors
-
-  this is actually coming from T2386 testcase. The emitting of those
-  warnings is also a reason why so many TH testcases fail on Solaris.
-
-  Following filter code is SunOS/Solaris linker specific and should
-  filter out only linker warnings. Please note that the logic is a
-  little bit more complex due to the simple reason that we need to preserve
-  any other linker emitted messages. If there are any. Simply speaking
-  if we see "Undefined" and later "ld: warning:..." then we omit all
-  text between (including) the marks. Otherwise we copy the whole output.
--}
-    sunos_ld_filter :: String -> String
-    sunos_ld_filter = unlines . sunos_ld_filter' . lines
-    sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
-                          then (ld_prefix x) ++ (ld_postfix x)
-                          else x
-    breakStartsWith x y = break (isPrefixOf x) y
-    ld_prefix = fst . breakStartsWith "Undefined"
-    undefined_found = not . null . snd . breakStartsWith "Undefined"
-    ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
-    ld_postfix = tail . snd . ld_warn_break
-    ld_warning_found = not . null . snd . ld_warn_break
-
--- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline.
-runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()
-runMergeObjects logger tmpfs dflags args =
-  traceSystoolCommand logger "merge-objects" $ do
-    let (p,args0) = fromMaybe err (pgm_lm dflags)
-        err = throwGhcException $ UsageError $ unwords
-            [ "Attempted to merge object files but the configured linker"
-            , "does not support object merging." ]
-        optl_args = map Option (getOpts dflags opt_lm)
-        args2     = args0 ++ args ++ optl_args
-    -- N.B. Darwin's ld64 doesn't support response files. Consequently we only
-    -- use them on Windows where they are truly necessary.
-    if isWindowsHost
-      then do
-        mb_env <- getGccEnv args2
-        runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env
-      else do
-        runSomething logger "Merge objects" p args2
-
-runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO ()
-runAr logger dflags cwd args = traceSystoolCommand logger "ar" $ do
-  let ar = pgm_ar dflags
-  runSomethingFiltered logger id "Ar" ar args cwd Nothing
-
-askOtool :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO String
-askOtool logger dflags mb_cwd args = do
-  let otool = pgm_otool dflags
-  runSomethingWith logger "otool" otool args $ \real_args ->
-    readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd }
-
-runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO ()
-runInstallNameTool logger dflags args = do
-  let tool = pgm_install_name_tool dflags
-  runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing
-
-runRanlib :: Logger -> DynFlags -> [Option] -> IO ()
-runRanlib logger dflags args = traceSystoolCommand logger "ranlib" $ do
-  let ranlib = pgm_ranlib dflags
-  runSomethingFiltered logger id "Ranlib" ranlib args Nothing Nothing
-
-runWindres :: Logger -> DynFlags -> [Option] -> IO ()
-runWindres logger dflags args = traceSystoolCommand logger "windres" $ do
-  let cc_args = map Option (sOpt_c (settings dflags))
-      windres = pgm_windres dflags
-      opts = map Option (getOpts dflags opt_windres)
-  mb_env <- getGccEnv cc_args
-  runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env
-
-touch :: Logger -> DynFlags -> String -> String -> IO ()
-touch logger dflags purpose arg = traceSystoolCommand logger "touch" $
-  runSomething logger purpose (pgm_T dflags) [FileOption "" arg]
diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Deriv.hs
+++ /dev/null
@@ -1,2246 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
-
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE TypeFamilies #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
--- | Handles @deriving@ clauses on @data@ declarations.
-module GHC.Tc.Deriv ( tcDeriving, DerivInfo(..) ) where
-
-import GHC.Prelude
-
-import GHC.Hs
-import GHC.Driver.Session
-
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Instance.Family
-import GHC.Tc.Types.Origin
-import GHC.Tc.Deriv.Infer
-import GHC.Tc.Deriv.Utils
-import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault )
-import GHC.Tc.Utils.Env
-import GHC.Tc.Deriv.Generate
-import GHC.Tc.Validity( allDistinctTyVars, checkValidInstHead )
-import GHC.Core.InstEnv
-import GHC.Tc.Utils.Instantiate
-import GHC.Core.FamInstEnv
-import GHC.Tc.Gen.HsType
-import GHC.Core.TyCo.Rep
-import GHC.Core.TyCo.Ppr ( pprTyVars )
-
-import GHC.Rename.Bind
-import GHC.Rename.Env
-import GHC.Rename.Module ( addTcgDUs )
-import GHC.Rename.Utils
-
-import GHC.Core.Unify( tcUnifyTy )
-import GHC.Core.Class
-import GHC.Core.Type
-import GHC.Utils.Error
-import GHC.Core.DataCon
-import GHC.Data.Maybe
-import GHC.Types.Name.Reader
-import GHC.Types.Name
-import GHC.Types.Name.Set as NameSet
-import GHC.Core.TyCon
-import GHC.Tc.Utils.TcType
-import GHC.Types.Var as Var
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
-import GHC.Builtin.Names
-import GHC.Types.SrcLoc
-import GHC.Utils.Misc
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Logger
-import GHC.Data.Bag
-import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs)
-import qualified GHC.LanguageExtensions as LangExt
-
-import Control.Monad
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Reader
-import Data.List (partition, find)
-
-{-
-************************************************************************
-*                                                                      *
-                Overview
-*                                                                      *
-************************************************************************
-
-Overall plan
-~~~~~~~~~~~~
-1.  Convert the decls (i.e. data/newtype deriving clauses,
-    plus standalone deriving) to [EarlyDerivSpec]
-
-2.  Infer the missing contexts for the InferTheta's
-
-3.  Add the derived bindings, generating InstInfos
--}
-
-data EarlyDerivSpec = InferTheta (DerivSpec ThetaSpec)
-                    | GivenTheta (DerivSpec ThetaType)
-        -- InferTheta ds => the context for the instance should be inferred
-        --      In this case ds_theta is the list of all the sets of
-        --      constraints needed, such as (Eq [a], Eq a), together with a
-        --      suitable CtLoc to get good error messages.
-        --      The inference process is to reduce this to a
-        --      simpler form (e.g. Eq a)
-        --
-        -- GivenTheta ds => the exact context for the instance is supplied
-        --                  by the programmer; it is ds_theta
-        -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer
-
-splitEarlyDerivSpec :: [EarlyDerivSpec]
-                    -> ([DerivSpec ThetaSpec], [DerivSpec ThetaType])
-splitEarlyDerivSpec [] = ([],[])
-splitEarlyDerivSpec (InferTheta spec : specs) =
-    case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)
-splitEarlyDerivSpec (GivenTheta spec : specs) =
-    case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)
-
-instance Outputable EarlyDerivSpec where
-  ppr (InferTheta spec) = ppr spec <+> text "(Infer)"
-  ppr (GivenTheta spec) = ppr spec <+> text "(Given)"
-
-{-
-Note [Data decl contexts]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
-
-We will need an instance decl like:
-
-        instance (Read a, RealFloat a) => Read (Complex a) where
-          ...
-
-The RealFloat in the context is because the read method for Complex is bound
-to construct a Complex, and doing that requires that the argument type is
-in RealFloat.
-
-But this ain't true for Show, Eq, Ord, etc, since they don't construct
-a Complex; they only take them apart.
-
-Our approach: identify the offending classes, and add the data type
-context to the instance decl.  The "offending classes" are
-
-        Read, Enum?
-
-FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that
-pattern matching against a constructor from a data type with a context
-gives rise to the constraints for that context -- or at least the thinned
-version.  So now all classes are "offending".
-
-Note [Newtype deriving]
-~~~~~~~~~~~~~~~~~~~~~~~
-Consider this:
-    class C a b
-    instance C [a] Char
-    newtype T = T Char deriving( C [a] )
-
-Notice the free 'a' in the deriving.  We have to fill this out to
-    newtype T = T Char deriving( forall a. C [a] )
-
-And then translate it to:
-    instance C [a] Char => C [a] T where ...
-
-Note [Unused constructors and deriving clauses]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See #3221.  Consider
-   data T = T1 | T2 deriving( Show )
-Are T1 and T2 unused?  Well, no: the deriving clause expands to mention
-both of them.  So we gather defs/uses from deriving just like anything else.
-
--}
-
--- | Stuff needed to process a datatype's `deriving` clauses
-data DerivInfo = DerivInfo { di_rep_tc  :: TyCon
-                             -- ^ The data tycon for normal datatypes,
-                             -- or the *representation* tycon for data families
-                           , di_scoped_tvs :: ![(Name,TyVar)]
-                             -- ^ Variables that scope over the deriving clause.
-                             -- See @Note [Scoped tyvars in a TcTyCon]@ in
-                             -- "GHC.Core.TyCon".
-                           , di_clauses :: [LHsDerivingClause GhcRn]
-                           , di_ctxt    :: SDoc -- ^ error context
-                           }
-
-{-
-
-************************************************************************
-*                                                                      *
-Top-level function for \tr{derivings}
-*                                                                      *
-************************************************************************
--}
-
-tcDeriving  :: [DerivInfo]       -- All `deriving` clauses
-            -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations
-            -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
-tcDeriving deriv_infos deriv_decls
-  = recoverM (do { g <- getGblEnv
-                 ; return (g, emptyBag, emptyValBindsOut)}) $
-    do  { -- Fish the "deriving"-related information out of the GHC.Tc.Utils.Env
-          -- And make the necessary "equations".
-          early_specs <- makeDerivSpecs deriv_infos deriv_decls
-        ; traceTc "tcDeriving" (ppr early_specs)
-
-        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
-        ; famInsts1 <- concatMapM genFamInsts given_specs
-        ; famInsts2 <- concatMapM genFamInsts infer_specs
-        ; let famInsts = famInsts1 ++ famInsts2
-
-        ; logger <- getLogger
-
-          -- We must put all the derived type family instances (from both
-          -- infer_specs and given_specs) in the local instance environment
-          -- before proceeding, or else simplifyInstanceContexts might
-          -- get stuck if it has to reason about any of those family instances.
-          -- See Note [Staging of tcDeriving]
-        ; tcExtendLocalFamInstEnv famInsts $
-          -- NB: only call tcExtendLocalFamInstEnv once, as it performs
-          -- validity checking for all of the family instances you give it.
-          -- If the family instances have errors, calling it twice will result
-          -- in duplicate error messages!
-
-     do { given_inst_binds <- mapM genInstBinds given_specs
-
-        ; let given_inst_infos = map fstOf3 given_inst_binds
-
-        -- the stand-alone derived instances (@given_inst_infos@) are used when
-        -- inferring the contexts for "deriving" clauses' instances
-        -- (@infer_specs@)
-        ; final_infer_specs <-
-            extendLocalInstEnv (map iSpec given_inst_infos) $
-            simplifyInstanceContexts infer_specs
-        ; infer_inst_binds <- mapM genInstBinds final_infer_specs
-
-        ; let (_, aux_specs, fvs) = unzip3 (given_inst_binds ++ infer_inst_binds)
-        ; loc <- getSrcSpanM
-        ; let aux_binds = genAuxBinds loc (unionManyBags aux_specs)
-
-        ; let infer_inst_infos = map fstOf3 infer_inst_binds
-        ; let inst_infos = given_inst_infos ++ infer_inst_infos
-
-        ; (inst_info, rn_aux_binds, rn_dus) <- renameDeriv inst_infos aux_binds
-
-        ; unless (isEmptyBag inst_info) $
-             liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Derived instances"
-                        FormatHaskell
-                        (ddump_deriving inst_info rn_aux_binds famInsts))
-
-        ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))
-                                          getGblEnv
-        ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs)
-        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_aux_binds) } }
-  where
-    ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn
-                   -> [FamInst]               -- Associated type family instances
-                   -> SDoc
-    ddump_deriving inst_infos extra_binds famInsts
-      =    hang (text "Derived class instances:")
-              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
-                 $$ ppr extra_binds)
-        $$ hangP (text "Derived type family instances:")
-             (vcat (map pprRepTy famInsts))
-
-    hangP s x = text "" $$ hang s 2 x
-
--- Prints the representable type family instance
-pprRepTy :: FamInst -> SDoc
-pprRepTy fi@(FamInst { fi_tys = lhs })
-  = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
-      equals <+> ppr rhs
-  where rhs = famInstRHS fi
-
-renameDeriv :: [InstInfo GhcPs]
-            -> Bag (LHsBind GhcPs, LSig GhcPs)
-            -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
-renameDeriv inst_infos bagBinds
-  = discardWarnings $
-    -- Discard warnings about unused bindings etc
-    setXOptM LangExt.EmptyCase $
-    -- Derived decls (for empty types) can have
-    --    case x of {}
-    setXOptM LangExt.ScopedTypeVariables $
-    setXOptM LangExt.KindSignatures $
-    -- Derived decls (for newtype-deriving) can use ScopedTypeVariables &
-    -- KindSignatures
-    setXOptM LangExt.TypeApplications $
-    -- GND/DerivingVia uses TypeApplications in generated code
-    -- (See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate)
-    unsetXOptM LangExt.RebindableSyntax $
-    -- See Note [Avoid RebindableSyntax when deriving]
-    setXOptM LangExt.TemplateHaskellQuotes $
-    -- DeriveLift makes uses of quotes
-    do  {
-        -- Bring the extra deriving stuff into scope
-        -- before renaming the instances themselves
-        ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
-        ; let (aux_binds, aux_sigs) = unzipBag bagBinds
-              aux_val_binds = ValBinds NoAnnSortKey aux_binds (bagToList aux_sigs)
-        -- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename
-        -- auxiliary bindings as if they were defined locally.
-        -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
-        ; (bndrs, rn_aux_lhs) <- rnLocalValBindsLHS emptyFsEnv aux_val_binds
-        ; bindLocalNames bndrs $
-    do  { (rn_aux, dus_aux) <- rnLocalValBindsRHS (mkNameSet bndrs) rn_aux_lhs
-        ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
-        ; return (listToBag rn_inst_infos, rn_aux,
-                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
-
-  where
-    rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars)
-    rn_inst_info
-      inst_info@(InstInfo { iSpec = inst
-                          , iBinds = InstBindings
-                            { ib_binds = binds
-                            , ib_tyvars = tyvars
-                            , ib_pragmas = sigs
-                            , ib_extensions = exts -- Only for type-checking
-                            , ib_derived = sa } })
-        =  do { (rn_binds, rn_sigs, fvs) <- rnMethodBinds False (is_cls_nm inst)
-                                                          tyvars binds sigs
-              ; let binds' = InstBindings { ib_binds = rn_binds
-                                          , ib_tyvars = tyvars
-                                          , ib_pragmas = rn_sigs
-                                          , ib_extensions = exts
-                                          , ib_derived = sa }
-              ; return (inst_info { iBinds = binds' }, fvs) }
-
-{-
-Note [Staging of tcDeriving]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here's a tricky corner case for deriving (adapted from #2721):
-
-    class C a where
-      type T a
-      foo :: a -> T a
-
-    instance C Int where
-      type T Int = Int
-      foo = id
-
-    newtype N = N Int deriving C
-
-This will produce an instance something like this:
-
-    instance C N where
-      type T N = T Int
-      foo = coerce (foo :: Int -> T Int) :: N -> T N
-
-We must be careful in order to typecheck this code. When determining the
-context for the instance (in simplifyInstanceContexts), we need to determine
-that T N and T Int have the same representation, but to do that, the T N
-instance must be in the local family instance environment. Otherwise, GHC
-would be unable to conclude that T Int is representationally equivalent to
-T Int, and simplifyInstanceContexts would get stuck.
-
-Previously, tcDeriving would defer adding any derived type family instances to
-the instance environment until the very end, which meant that
-simplifyInstanceContexts would get called without all the type family instances
-it needed in the environment in order to properly simplify instance like
-the C N instance above.
-
-To avoid this scenario, we generate things in tcDeriving in a specific order:
-
-1. First, we generate all of the associated type family instances for derived
-   instances (using `genFamInsts`).
-2. Next, we extend the local instance environment with these type family
-   instances.
-3. Then, we generate the instance bindings for derived instances
-   (using `genInstBinds`).
-4. Finally, for instances generated with `deriving` clauses, we infer the
-   instance contexts (using `simplifyInstanceContexts`). At this point, we
-   already have the necessary type family instances in scope (from step (2)),
-   so this is safe to do.
-
-Note [Why we don't pass rep_tc into deriveTyData]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Down in the bowels of mk_deriv_inst_tys_maybe, we need to convert the fam_tc
-back into the rep_tc by means of a lookup. And yet we have the rep_tc right
-here! Why look it up again? Answer: it's just easier this way.
-We drop some number of arguments from the end of the datatype definition
-in deriveTyData. The arguments are dropped from the fam_tc.
-This action may drop a *different* number of arguments
-passed to the rep_tc, depending on how many free variables, etc., the
-dropped patterns have.
-
-Also, this technique carries over the kind substitution from deriveTyData
-nicely.
-
-Note [Avoid RebindableSyntax when deriving]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The RebindableSyntax extension interacts awkwardly with the derivation of
-any stock class whose methods require the use of string literals. The Show
-class is a simple example (see #12688):
-
-  {-# LANGUAGE RebindableSyntax, OverloadedStrings #-}
-  newtype Text = Text String
-  fromString :: String -> Text
-  fromString = Text
-
-  data Foo = Foo deriving Show
-
-This will generate code to the effect of:
-
-  instance Show Foo where
-    showsPrec _ Foo = showString "Foo"
-
-But because RebindableSyntax and OverloadedStrings are enabled, the "Foo"
-string literal is now of type Text, not String, which showString doesn't
-accept! This causes the generated Show instance to fail to typecheck.
-
-To avoid this kind of scenario, we simply turn off RebindableSyntax entirely
-in derived code.
-
-************************************************************************
-*                                                                      *
-                From HsSyn to DerivSpec
-*                                                                      *
-************************************************************************
-
-@makeDerivSpecs@ fishes around to find the info about needed derived instances.
--}
-
-makeDerivSpecs :: [DerivInfo]
-               -> [LDerivDecl GhcRn]
-               -> TcM [EarlyDerivSpec]
-makeDerivSpecs deriv_infos deriv_decls
-  = do  { eqns1 <- sequenceA
-                      -- MP: scoped_tvs here magically converts TyVar into TcTyVar
-                     [ deriveClause rep_tc scoped_tvs dcs (deriv_clause_preds dct) err_ctxt
-                     | DerivInfo { di_rep_tc = rep_tc
-                                 , di_scoped_tvs = scoped_tvs
-                                 , di_clauses = clauses
-                                 , di_ctxt = err_ctxt } <- deriv_infos
-                     , L _ (HsDerivingClause { deriv_clause_strategy = dcs
-                                             , deriv_clause_tys = dct })
-                         <- clauses
-                     ]
-        ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls
-        ; return $ concat eqns1 ++ catMaybes eqns2 }
-  where
-    deriv_clause_preds :: LDerivClauseTys GhcRn -> [LHsSigType GhcRn]
-    deriv_clause_preds (L _ dct) = case dct of
-      DctSingle _ ty -> [ty]
-      DctMulti _ tys -> tys
-
-------------------------------------------------------------------
--- | Process the derived classes in a single @deriving@ clause.
-deriveClause :: TyCon
-             -> [(Name, TcTyVar)]  -- Scoped type variables taken from tcTyConScopedTyVars
-                                   -- See Note [Scoped tyvars in a TcTyCon] in "GHC.Core.TyCon"
-             -> Maybe (LDerivStrategy GhcRn)
-             -> [LHsSigType GhcRn] -> SDoc
-             -> TcM [EarlyDerivSpec]
-deriveClause rep_tc scoped_tvs mb_lderiv_strat deriv_preds err_ctxt
-  = addErrCtxt err_ctxt $ do
-      traceTc "deriveClause" $ vcat
-        [ text "tvs"             <+> ppr tvs
-        , text "scoped_tvs"      <+> ppr scoped_tvs
-        , text "tc"              <+> ppr tc
-        , text "tys"             <+> ppr tys
-        , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat ]
-      tcExtendNameTyVarEnv scoped_tvs $ do
-        (mb_lderiv_strat', via_tvs) <- tcDerivStrategy mb_lderiv_strat
-        tcExtendTyVarEnv via_tvs $
-        -- Moreover, when using DerivingVia one can bind type variables in
-        -- the `via` type as well, so these type variables must also be
-        -- brought into scope.
-          mapMaybeM (derivePred tc tys mb_lderiv_strat' via_tvs) deriv_preds
-          -- After typechecking the `via` type once, we then typecheck all
-          -- of the classes associated with that `via` type in the
-          -- `deriving` clause.
-          -- See also Note [Don't typecheck too much in DerivingVia].
-  where
-    tvs = tyConTyVars rep_tc
-    (tc, tys) = case tyConFamInstSig_maybe rep_tc of
-                        -- data family:
-                  Just (fam_tc, pats, _) -> (fam_tc, pats)
-      -- NB: deriveTyData wants the *user-specified*
-      -- name. See Note [Why we don't pass rep_tc into deriveTyData]
-
-                  _ -> (rep_tc, mkTyVarTys tvs)     -- datatype
-
--- | Process a single predicate in a @deriving@ clause.
---
--- This returns a 'Maybe' because the user might try to derive 'Typeable',
--- which is a no-op nowadays.
-derivePred :: TyCon -> [Type] -> Maybe (LDerivStrategy GhcTc) -> [TyVar]
-           -> LHsSigType GhcRn -> TcM (Maybe EarlyDerivSpec)
-derivePred tc tys mb_lderiv_strat via_tvs deriv_pred =
-  -- We carefully set up uses of recoverM to minimize error message
-  -- cascades. See Note [Recovering from failures in deriving clauses].
-  recoverM (pure Nothing) $
-  setSrcSpan (getLocA deriv_pred) $ do
-    traceTc "derivePred" $ vcat
-      [ text "tc"              <+> ppr tc
-      , text "tys"             <+> ppr tys
-      , text "deriv_pred"      <+> ppr deriv_pred
-      , text "mb_lderiv_strat" <+> ppr mb_lderiv_strat
-      , text "via_tvs"         <+> ppr via_tvs ]
-    (cls_tvs, cls, cls_tys, cls_arg_kinds) <- tcHsDeriv deriv_pred
-    when (cls_arg_kinds `lengthIsNot` 1) $
-      failWithTc (TcRnNonUnaryTypeclassConstraint deriv_pred)
-    let [cls_arg_kind] = cls_arg_kinds
-        mb_deriv_strat = fmap unLoc mb_lderiv_strat
-    if (className cls == typeableClassName)
-    then do warnUselessTypeable
-            return Nothing
-    else let deriv_tvs = via_tvs ++ cls_tvs in
-         Just <$> deriveTyData tc tys mb_deriv_strat
-                               deriv_tvs cls cls_tys cls_arg_kind
-
-{-
-Note [Don't typecheck too much in DerivingVia]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider the following example:
-
-  data D = ...
-    deriving (A1 t, ..., A20 t) via T t
-
-GHC used to be engineered such that it would typecheck the `deriving`
-clause like so:
-
-1. Take the first class in the clause (`A1`).
-2. Typecheck the `via` type (`T t`) and bring its bound type variables
-   into scope (`t`).
-3. Typecheck the class (`A1`).
-4. Move on to the next class (`A2`) and repeat the process until all
-   classes have been typechecked.
-
-This algorithm gets the job done most of the time, but it has two notable
-flaws. One flaw is that it is wasteful: it requires that `T t` be typechecked
-20 different times, once for each class in the `deriving` clause. This is
-unnecessary because we only need to typecheck `T t` once in order to get
-access to its bound type variable.
-
-The other issue with this algorithm arises when there are no classes in the
-`deriving` clause, like in the following example:
-
-  data D2 = ...
-    deriving () via Maybe Maybe
-
-Because there are no classes, the algorithm above will simply do nothing.
-As a consequence, GHC will completely miss the fact that `Maybe Maybe`
-is ill-kinded nonsense (#16923).
-
-To address both of these problems, GHC now uses this algorithm instead:
-
-1. Typecheck the `via` type and bring its bound type variables into scope.
-2. Take the first class in the `deriving` clause.
-3. Typecheck the class.
-4. Move on to the next class and repeat the process until all classes have been
-   typechecked.
-
-This algorithm ensures that the `via` type is always typechecked, even if there
-are no classes in the `deriving` clause. Moreover, it typecheck the `via` type
-/exactly/ once and no more, even if there are multiple classes in the clause.
-
-Note [Recovering from failures in deriving clauses]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider what happens if you run this program (from #10684) without
-DeriveGeneric enabled:
-
-    data A = A deriving (Show, Generic)
-    data B = B A deriving (Show)
-
-Naturally, you'd expect GHC to give an error to the effect of:
-
-    Can't make a derived instance of `Generic A':
-      You need -XDeriveGeneric to derive an instance for this class
-
-And *only* that error, since the other two derived Show instances appear to be
-independent of this derived Generic instance. Yet GHC also used to give this
-additional error on the program above:
-
-    No instance for (Show A)
-      arising from the 'deriving' clause of a data type declaration
-    When deriving the instance for (Show B)
-
-This was happening because when GHC encountered any error within a single
-data type's set of deriving clauses, it would call recoverM and move on
-to the next data type's deriving clauses. One unfortunate consequence of
-this design is that if A's derived Generic instance failed, its derived
-Show instance would be skipped entirely, leading to the "No instance for
-(Show A)" error cascade.
-
-The solution to this problem is to push through uses of recoverM to the
-level of the individual derived classes in a particular data type's set of
-deriving clauses. That is, if you have:
-
-    newtype C = C D
-      deriving (E, F, G)
-
-Then instead of processing instances E through M under the scope of a single
-recoverM, as in the following pseudocode:
-
-  recoverM (pure Nothing) $ mapM derivePred [E, F, G]
-
-We instead use recoverM in each iteration of the loop:
-
-  mapM (recoverM (pure Nothing) . derivePred) [E, F, G]
-
-And then process each class individually, under its own recoverM scope. That
-way, failure to derive one class doesn't cancel out other classes in the
-same set of clause-derived classes.
--}
-
-------------------------------------------------------------------
-deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
--- Process a single standalone deriving declaration
---  e.g.   deriving instance Show a => Show (T a)
--- Rather like tcLocalInstDecl
---
--- This returns a Maybe because the user might try to derive Typeable, which is
--- a no-op nowadays.
-deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode))
-  = setSrcSpanA loc                       $
-    addErrCtxt (standaloneCtxt deriv_ty)  $
-    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
-       ; let ctxt = GHC.Tc.Types.Origin.InstDeclCtxt True
-       ; traceTc "Deriving strategy (standalone deriving)" $
-           vcat [ppr mb_lderiv_strat, ppr deriv_ty]
-       ; (mb_lderiv_strat, via_tvs) <- tcDerivStrategy mb_lderiv_strat
-       ; traceTc "Deriving strategy (standalone deriving) 2" $
-           vcat [ppr mb_lderiv_strat, ppr via_tvs]
-       ; (cls_tvs, deriv_ctxt, cls, inst_tys)
-           <- tcExtendTyVarEnv via_tvs $
-              tcStandaloneDerivInstType ctxt deriv_ty
-       ; let mb_deriv_strat = fmap unLoc mb_lderiv_strat
-             tvs            = via_tvs ++ cls_tvs
-         -- See Note [Unify kinds in deriving]
-       ; (tvs', deriv_ctxt', inst_tys', mb_deriv_strat') <-
-           case mb_deriv_strat of
-             -- Perform an additional unification with the kind of the `via`
-             -- type and the result of the previous kind unification.
-             Just (ViaStrategy via_ty)
-                  -- This unification must be performed on the last element of
-                  -- inst_tys, but we have not yet checked for this property.
-                  -- (This is done later in expectNonNullaryClsArgs). For now,
-                  -- simply do nothing if inst_tys is empty, since
-                  -- expectNonNullaryClsArgs will error later if this
-                  -- is the case.
-               |  Just inst_ty <- lastMaybe inst_tys
-               -> do
-               let via_kind     = typeKind via_ty
-                   inst_ty_kind = typeKind inst_ty
-                   mb_match     = tcUnifyTy inst_ty_kind via_kind
-
-               checkTc (isJust mb_match)
-                       (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $
-                          DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind)
-
-               let Just kind_subst = mb_match
-                   ki_subst_range  = getSubstRangeTyCoFVs kind_subst
-                   -- See Note [Unification of two kind variables in deriving]
-                   unmapped_tkvs = filter (\v -> v `notElemSubst` kind_subst
-                                        && not (v `elemVarSet` ki_subst_range))
-                                          tvs
-                   (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs
-                   (final_deriv_ctxt, final_deriv_ctxt_tys)
-                     = case deriv_ctxt of
-                         InferContext wc -> (InferContext wc, [])
-                         SupplyContext theta ->
-                           let final_theta = substTheta subst theta
-                           in (SupplyContext final_theta, final_theta)
-                   final_inst_tys   = substTys subst inst_tys
-                   final_via_ty     = substTy  subst via_ty
-                   -- See Note [Floating `via` type variables]
-                   final_tvs        = tyCoVarsOfTypesWellScoped $
-                                      final_deriv_ctxt_tys ++ final_inst_tys
-                                        ++ [final_via_ty]
-               pure ( final_tvs, final_deriv_ctxt, final_inst_tys
-                    , Just (ViaStrategy final_via_ty) )
-
-             _ -> pure (tvs, deriv_ctxt, inst_tys, mb_deriv_strat)
-       ; traceTc "Standalone deriving;" $ vcat
-              [ text "tvs':" <+> ppr tvs'
-              , text "mb_deriv_strat':" <+> ppr mb_deriv_strat'
-              , text "deriv_ctxt':" <+> ppr deriv_ctxt'
-              , text "cls:" <+> ppr cls
-              , text "inst_tys':" <+> ppr inst_tys' ]
-                -- C.f. GHC.Tc.TyCl.Instance.tcLocalInstDecl1
-
-       ; if className cls == typeableClassName
-         then do warnUselessTypeable
-                 return Nothing
-         else Just <$> mkEqnHelp (fmap unLoc overlap_mode)
-                                 tvs' cls inst_tys'
-                                 deriv_ctxt' mb_deriv_strat' }
-
--- Typecheck the type in a standalone deriving declaration.
---
--- This may appear dense, but it's mostly huffing and puffing to recognize
--- the special case of a type with an extra-constraints wildcard context, e.g.,
---
---   deriving instance _ => Eq (Foo a)
---
--- If there is such a wildcard, we typecheck this as if we had written
--- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@,
--- as the 'DerivContext', where loc is the location of the wildcard used for
--- error reporting. This indicates that we should infer the context as if we
--- were deriving Eq via a deriving clause
--- (see Note [Inferring the instance context] in GHC.Tc.Deriv.Infer).
---
--- If there is no wildcard, then proceed as normal, and instead return
--- @'SupplyContext' theta@, where theta is the typechecked context.
---
--- Note that this will never return @'InferContext' 'Nothing'@, as that can
--- only happen with @deriving@ clauses.
-tcStandaloneDerivInstType
-  :: UserTypeCtxt -> LHsSigWcType GhcRn
-  -> TcM ([TyVar], DerivContext, Class, [Type])
-tcStandaloneDerivInstType ctxt
-    (HsWC { hswc_body = deriv_ty@(L loc (HsSig { sig_bndrs = outer_bndrs
-                                               , sig_body = deriv_ty_body }))})
-  | (theta, rho) <- splitLHsQualTy deriv_ty_body
-  , [wc_pred] <- fromMaybeContext theta
-  , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred
-  = do dfun_ty <- tcHsClsInstType ctxt $ L loc $
-                  HsSig { sig_ext   = noExtField
-                        , sig_bndrs = outer_bndrs
-                        , sig_body  = rho }
-       let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
-       pure (tvs, InferContext (Just (locA wc_span)), cls, inst_tys)
-  | otherwise
-  = do dfun_ty <- tcHsClsInstType ctxt deriv_ty
-       let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
-       pure (tvs, SupplyContext theta, cls, inst_tys)
-
-warnUselessTypeable :: TcM ()
-warnUselessTypeable = addDiagnosticTc TcRnUselessTypeable
-
-------------------------------------------------------------------
-deriveTyData :: TyCon -> [Type] -- LHS of data or data instance
-                    -- Can be a data instance, hence [Type] args
-                    -- and in that case the TyCon is the /family/ tycon
-             -> Maybe (DerivStrategy GhcTc) -- The optional deriving strategy
-             -> [TyVar] -- The type variables bound by the derived class
-             -> Class   -- The derived class
-             -> [Type]  -- The derived class's arguments
-             -> Kind    -- The function argument in the derived class's kind.
-                        -- (e.g., if `deriving Functor`, this would be
-                        -- `Type -> Type` since
-                        -- `Functor :: (Type -> Type) -> Constraint`)
-             -> TcM EarlyDerivSpec
--- The deriving clause of a data or newtype declaration
--- I.e. not standalone deriving
-deriveTyData tc tc_args mb_deriv_strat deriv_tvs cls cls_tys cls_arg_kind
-   = do {  -- Given data T a b c = ... deriving( C d ),
-           -- we want to drop type variables from T so that (C d (T a)) is well-kinded
-          let (arg_kinds, _)  = splitFunTys cls_arg_kind
-              n_args_to_drop  = length arg_kinds
-              n_args_to_keep  = length tc_args - n_args_to_drop
-                                -- See Note [tc_args and tycon arity]
-              (tc_args_to_keep, args_to_drop)
-                              = splitAt n_args_to_keep tc_args
-              inst_ty_kind    = typeKind (mkTyConApp tc tc_args_to_keep)
-
-              -- Match up the kinds, and apply the resulting kind substitution
-              -- to the types.  See Note [Unify kinds in deriving]
-              -- We are assuming the tycon tyvars and the class tyvars are distinct
-              mb_match        = tcUnifyTy inst_ty_kind cls_arg_kind
-              enough_args     = n_args_to_keep >= 0
-
-        -- Check that the result really is well-kinded
-        ; traceTc "deriveTyData" $
-          vcat [ text "class:" <+> ppr cls <+> dcolon <+> ppr (tyConKind (classTyCon cls))
-               , text "cls_tys:" <+> ppr cls_tys
-               , text "tycon:" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc)
-               , text "cls_arg:" <+> ppr (mkTyConApp tc tc_args_to_keep) <+> dcolon <+> ppr inst_ty_kind
-               , text "cls_arg_kind:" <+> ppr cls_arg_kind ]
-        ; checkTc (enough_args && isJust mb_match)
-                  (TcRnCannotDeriveInstance cls cls_tys Nothing NoGeneralizedNewtypeDeriving $
-                     DerivErrNotWellKinded tc cls_arg_kind n_args_to_keep)
-
-        ; let -- Returns a singleton-element list if using ViaStrategy and an
-              -- empty list otherwise. Useful for free-variable calculations.
-              deriv_strat_tys :: Maybe (DerivStrategy GhcTc) -> [Type]
-              deriv_strat_tys = foldMap (foldDerivStrategy [] (:[]))
-
-              propagate_subst kind_subst tkvs' cls_tys' tc_args' mb_deriv_strat'
-                = (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat)
-                where
-                  ki_subst_range  = getSubstRangeTyCoFVs kind_subst
-                  -- See Note [Unification of two kind variables in deriving]
-                  unmapped_tkvs   = filter (\v -> v `notElemSubst` kind_subst
-                                         && not (v `elemVarSet` ki_subst_range))
-                                           tkvs'
-                  (subst, _)           = substTyVarBndrs kind_subst unmapped_tkvs
-                  final_tc_args        = substTys subst tc_args'
-                  final_cls_tys        = substTys subst cls_tys'
-                  final_mb_deriv_strat = fmap (mapDerivStrategy (substTy subst))
-                                              mb_deriv_strat'
-                  -- See Note [Floating `via` type variables]
-                  final_tkvs           = tyCoVarsOfTypesWellScoped $
-                                         final_cls_tys ++ final_tc_args
-                                           ++ deriv_strat_tys final_mb_deriv_strat
-
-        ; let tkvs = scopedSort $ fvVarList $
-                     unionFV (tyCoFVsOfTypes tc_args_to_keep)
-                             (FV.mkFVs deriv_tvs)
-              Just kind_subst = mb_match
-              (tkvs', cls_tys', tc_args', mb_deriv_strat')
-                = propagate_subst kind_subst tkvs cls_tys
-                                  tc_args_to_keep mb_deriv_strat
-
-          -- See Note [Unify kinds in deriving]
-        ; (final_tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <-
-            case mb_deriv_strat' of
-              -- Perform an additional unification with the kind of the `via`
-              -- type and the result of the previous kind unification.
-              Just (ViaStrategy via_ty) -> do
-                let via_kind = typeKind via_ty
-                    inst_ty_kind
-                              = typeKind (mkTyConApp tc tc_args')
-                    via_match = tcUnifyTy inst_ty_kind via_kind
-
-                checkTc (isJust via_match)
-                        (TcRnCannotDeriveInstance cls mempty Nothing NoGeneralizedNewtypeDeriving $
-                           DerivErrDerivingViaWrongKind inst_ty_kind via_ty via_kind)
-
-                let Just via_subst = via_match
-                pure $ propagate_subst via_subst tkvs' cls_tys'
-                                       tc_args' mb_deriv_strat'
-
-              _ -> pure (tkvs', cls_tys', tc_args', mb_deriv_strat')
-
-        ; traceTc "deriveTyData 1" $ vcat
-            [ ppr final_mb_deriv_strat, pprTyVars deriv_tvs, ppr tc, ppr tc_args
-            , pprTyVars (tyCoVarsOfTypesList tc_args)
-            , ppr n_args_to_keep, ppr n_args_to_drop
-            , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
-            , ppr final_tc_args, ppr final_cls_tys ]
-
-        ; traceTc "deriveTyData 2" $ vcat
-            [ ppr final_tkvs ]
-
-        ; let final_tc_app   = mkTyConApp tc final_tc_args
-              final_cls_args = final_cls_tys ++ [final_tc_app]
-        ; checkTc (allDistinctTyVars (mkVarSet final_tkvs) args_to_drop) -- (a, b, c)
-                  (TcRnCannotDeriveInstance cls final_cls_tys Nothing NoGeneralizedNewtypeDeriving $
-                     DerivErrNoEtaReduce final_tc_app)
-                -- Check that
-                --  (a) The args to drop are all type variables; eg reject:
-                --              data instance T a Int = .... deriving( Monad )
-                --  (b) The args to drop are all *distinct* type variables; eg reject:
-                --              class C (a :: * -> * -> *) where ...
-                --              data instance T a a = ... deriving( C )
-                --  (c) The type class args, or remaining tycon args,
-                --      do not mention any of the dropped type variables
-                --              newtype T a s = ... deriving( ST s )
-                --              newtype instance K a a = ... deriving( Monad )
-                --
-                -- It is vital that the implementation of allDistinctTyVars
-                -- expand any type synonyms.
-                -- See Note [Eta-reducing type synonyms]
-
-        ; checkValidInstHead DerivClauseCtxt cls final_cls_args
-                -- Check that we aren't deriving an instance of a magical
-                -- type like (~) or Coercible (#14916).
-
-        ; spec <- mkEqnHelp Nothing final_tkvs cls final_cls_args
-                            (InferContext Nothing) final_mb_deriv_strat
-        ; traceTc "deriveTyData 3" (ppr spec)
-        ; return spec }
-
-
-{- Note [tc_args and tycon arity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-You might wonder if we could use (tyConArity tc) at this point, rather
-than (length tc_args).  But for data families the two can differ!  The
-tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which
-in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them
-from DataFamInstTyCon:
-
-| DataFamInstTyCon          -- See Note [Data type families]
-      (CoAxiom Unbranched)
-      TyCon   -- The family TyCon
-      [Type]  -- Argument types (mentions the tyConTyVars of this TyCon)
-              -- No shorter in length than the tyConTyVars of the family TyCon
-              -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv
-
-Notice that the arg tys might not be the same as the family tycon arity
-(= length tyConTyVars).
-
-Note [Unify kinds in deriving]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#8534)
-    data T a b = MkT a deriving( Functor )
-    -- where Functor :: (*->*) -> Constraint
-
-So T :: forall k. * -> k -> *.   We want to get
-    instance Functor (T * (a:*)) where ...
-Notice the '*' argument to T.
-
-Moreover, as well as instantiating T's kind arguments, we may need to instantiate
-C's kind args.  Consider (#8865):
-  newtype T a b = MkT (Either a b) deriving( Category )
-where
-  Category :: forall k. (k -> k -> *) -> Constraint
-We need to generate the instance
-  instance Category * (Either a) where ...
-Notice the '*' argument to Category.
-
-So we need to
- * drop arguments from (T a b) to match the number of
-   arrows in the (last argument of the) class;
- * and then *unify* kind of the remaining type against the
-   expected kind, to figure out how to instantiate C's and T's
-   kind arguments.
-
-In the two examples,
- * we unify   kind-of( T k (a:k) ) ~ kind-of( Functor )
-         i.e.      (k -> *) ~ (* -> *)   to find k:=*.
-         yielding  k:=*
-
- * we unify   kind-of( Either ) ~ kind-of( Category )
-         i.e.      (* -> * -> *)  ~ (k -> k -> k)
-         yielding  k:=*
-
-Now we get a kind substitution.  We then need to:
-
-  1. Remove the substituted-out kind variables from the quantified kind vars
-
-  2. Apply the substitution to the kinds of quantified *type* vars
-     (and extend the substitution to reflect this change)
-
-  3. Apply that extended substitution to the non-dropped args (types and
-     kinds) of the type and class
-
-Forgetting step (2) caused #8893:
-  data V a = V [a] deriving Functor
-  data P (x::k->*) (a:k) = P (x a) deriving Functor
-  data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor
-
-When deriving Functor for P, we unify k to *, but we then want
-an instance   $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*))
-and similarly for C.  Notice the modified kind of x, both at binding
-and occurrence sites.
-
-This can lead to some surprising results when *visible* kind binder is
-unified (in contrast to the above examples, in which only non-visible kind
-binders were considered). Consider this example from #11732:
-
-    data T k (a :: k) = MkT deriving Functor
-
-Since unification yields k:=*, this results in a generated instance of:
-
-    instance Functor (T *) where ...
-
-which looks odd at first glance, since one might expect the instance head
-to be of the form Functor (T k). Indeed, one could envision an alternative
-generated instance of:
-
-    instance (k ~ *) => Functor (T k) where
-
-But this does not typecheck by design: kind equalities are not allowed to be
-bound in types, only terms. But in essence, the two instance declarations are
-entirely equivalent, since even though (T k) matches any kind k, the only
-possibly value for k is *, since anything else is ill-typed. As a result, we can
-just as comfortably use (T *).
-
-Another way of thinking about is: deriving clauses often infer constraints.
-For example:
-
-    data S a = S a deriving Eq
-
-infers an (Eq a) constraint in the derived instance. By analogy, when we
-are deriving Functor, we might infer an equality constraint (e.g., k ~ *).
-The only distinction is that GHC instantiates equality constraints directly
-during the deriving process.
-
-Another quirk of this design choice manifests when typeclasses have visible
-kind parameters. Consider this code (also from #11732):
-
-    class Cat k (cat :: k -> k -> *) where
-      catId   :: cat a a
-      catComp :: cat b c -> cat a b -> cat a c
-
-    instance Cat * (->) where
-      catId   = id
-      catComp = (.)
-
-    newtype Fun a b = Fun (a -> b) deriving (Cat k)
-
-Even though we requested a derived instance of the form (Cat k Fun), the
-kind unification will actually generate (Cat * Fun) (i.e., the same thing as if
-the user wrote deriving (Cat *)).
-
-What happens with DerivingVia, when you have yet another type? Consider:
-
-  newtype Foo (a :: Type) = MkFoo (Proxy a)
-    deriving Functor via Proxy
-
-As before, we unify the kind of Foo (* -> *) with the kind of the argument to
-Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind
-(k -> *), which is more general than what we want. So we must additionally
-unify (k -> *) with (* -> *).
-
-Currently, all of this unification is implemented kludgily with the pure
-unifier, which is rather tiresome. #14331 lays out a plan for how this
-might be made cleaner.
-
-Note [Unification of two kind variables in deriving]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As a special case of the Note above, it is possible to derive an instance of
-a poly-kinded typeclass for a poly-kinded datatype. For example:
-
-    class Category (cat :: k -> k -> *) where
-    newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category
-
-This case is surprisingly tricky. To see why, let's write out what instance GHC
-will attempt to derive (using -fprint-explicit-kinds syntax):
-
-    instance Category k1 (T k2 c) where ...
-
-GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst)
-that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to
-the type variable binder for c, since its kind is (k2 -> k2 -> *).
-
-We used to accomplish this by doing the following:
-
-    unmapped_tkvs = filter (`notElemSubst` kind_subst) all_tkvs
-    (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs
-
-Where all_tkvs contains all kind variables in the class and instance types (in
-this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping,
-this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped
-to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new].
-This is bad, because applying that substitution yields the following instance:
-
-   instance Category k_new (T k1 c) where ...
-
-In other words, keeping k1 in unmapped_tvks taints the substitution, resulting
-in an ill-kinded instance (this caused #11837).
-
-To prevent this, we need to filter out any variable from all_tkvs which either
-
-1. Appears in the domain of kind_subst. notElemSubst checks this.
-2. Appears in the range of kind_subst. To do this, we compute the free
-   variable set of the range of kind_subst with getSubstRangeTyCoFVs, and check
-   if a kind variable appears in that set.
-
-Note [Eta-reducing type synonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-One can instantiate a type in a data family instance with a type synonym that
-mentions other type variables:
-
-  type Const a b = a
-  data family Fam (f :: * -> *) (a :: *)
-  newtype instance Fam f (Const a f) = Fam (f a) deriving Functor
-
-It is also possible to define kind synonyms, and they can mention other types in
-a datatype declaration. For example,
-
-  type Const a b = a
-  newtype T f (a :: Const * f) = T (f a) deriving Functor
-
-When deriving, we need to perform eta-reduction analysis to ensure that none of
-the eta-reduced type variables are mentioned elsewhere in the declaration. But
-we need to be careful, because if we don't expand through the Const type
-synonym, we will mistakenly believe that f is an eta-reduced type variable and
-fail to derive Functor, even though the code above is correct (see #11416,
-where this was first noticed). For this reason, we expand the type synonyms in
-the eta-reduced types before doing any analysis.
-
-Note [Floating `via` type variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When generating a derived instance, it will be of the form:
-
-  instance forall ???. C c_args (D d_args) where ...
-
-To fill in ???, GHC computes the free variables of `c_args` and `d_args`.
-`DerivingVia` adds an extra wrinkle to this formula, since we must also
-include the variables bound by the `via` type when computing the binders
-used to fill in ???. This might seem strange, since if a `via` type binds
-any type variables, then in almost all scenarios it will appear free in
-`c_args` or `d_args`. There are certain corner cases where this does not hold,
-however, such as in the following example (adapted from #15831):
-
-  newtype Age = MkAge Int
-    deriving Eq via Const Int a
-
-In this example, the `via` type binds the type variable `a`, but `a` appears
-nowhere in `Eq Age`. Nevertheless, we include it in the generated instance:
-
-  instance forall a. Eq Age where
-    (==) = coerce @(Const Int a -> Const Int a -> Bool)
-                  @(Age         -> Age         -> Bool)
-                  (==)
-
-The use of `forall a` is certainly required here, since the `a` in
-`Const Int a` would not be in scope otherwise. This instance is somewhat
-strange in that nothing in the instance head `Eq Age` ever determines what `a`
-will be, so any code that uses this instance will invariably instantiate `a`
-to be `Any`. We refer to this property of `a` as being a "floating" `via`
-type variable. Programs with floating `via` type variables are the only known
-class of program in which the `via` type quantifies type variables that aren't
-mentioned in the instance head in the generated instance.
-
-Fortunately, the choice to instantiate floating `via` type variables to `Any`
-is one that is completely transparent to the user (since the instance will
-work as expected regardless of what `a` is instantiated to), so we decide to
-permit them. An alternative design would make programs with floating `via`
-variables illegal, by requiring that every variable mentioned in the `via` type
-is also mentioned in the data header or the derived class. That restriction
-would require the user to pick a particular type (the choice does not matter);
-for example:
-
-  newtype Age = MkAge Int
-    -- deriving Eq via Const Int a  -- Floating 'a'
-    deriving Eq via Const Int ()    -- Choose a=()
-    deriving Eq via Const Int Any   -- Choose a=Any
-
-No expressiveness would be lost thereby, but stylistically it seems preferable
-to allow a type variable to indicate "it doesn't matter".
-
-Note that by quantifying the `a` in `forall a. Eq Age`, we are deferring the
-work of instantiating `a` to `Any` at every use site of the instance. An
-alternative approach would be to generate an instance that directly defaulted
-to `Any`:
-
-  instance Eq Age where
-    (==) = coerce @(Const Int Any -> Const Int Any -> Bool)
-                  @(Age           -> Age           -> Bool)
-                  (==)
-
-We do not implement this approach since it would require a nontrivial amount
-of implementation effort to substitute `Any` for the floating `via` type
-variables, and since the end result isn't distinguishable from the former
-instance (at least from the user's perspective), the amount of engineering
-required to obtain the latter instance just isn't worth it.
--}
-
-mkEqnHelp :: Maybe OverlapMode
-          -> [TyVar]
-          -> Class -> [Type]
-          -> DerivContext
-               -- SupplyContext => context supplied (standalone deriving)
-               -- InferContext  => context inferred (deriving on data decl, or
-               --                  standalone deriving decl with a wildcard)
-          -> Maybe (DerivStrategy GhcTc)
-          -> TcRn EarlyDerivSpec
--- Make the EarlyDerivSpec for an instance
---      forall tvs. theta => cls (tys ++ [ty])
--- where the 'theta' is optional (that's the Maybe part)
--- Assumes that this declaration is well-kinded
-
-mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do
-  is_boot <- tcIsHsBootOrSig
-  when is_boot $ bale_out DerivErrBootFileFound
-
-  let pred = mkClassPred cls cls_args
-  skol_info <- mkSkolemInfo (DerivSkol pred)
-  (tvs', cls_args', deriv_strat') <-
-    skolemise_when_inferring_context skol_info deriv_ctxt
-  let deriv_env = DerivEnv
-                    { denv_overlap_mode = overlap_mode
-                    , denv_tvs          = tvs'
-                    , denv_cls          = cls
-                    , denv_inst_tys     = cls_args'
-                    , denv_ctxt         = deriv_ctxt
-                    , denv_skol_info    = skol_info
-                    , denv_strat        = deriv_strat' }
-  runReaderT mk_eqn deriv_env
-  where
-    skolemise_when_inferring_context ::
-         SkolemInfo -> DerivContext
-      -> TcM ([TcTyVar], [TcType], Maybe (DerivStrategy GhcTc))
-    skolemise_when_inferring_context skol_info deriv_ctxt =
-      case deriv_ctxt of
-        -- In order to infer an instance context, we must later make use of
-        -- the constraint solving machinery, which expects TcTyVars rather
-        -- than TyVars. We skolemise the type variables with non-overlappable
-        -- (vanilla) skolems.
-        -- See Note [Overlap and deriving] in GHC.Tc.Deriv.Infer.
-        InferContext{} -> do
-          (skol_subst, tvs') <- tcInstSkolTyVars skol_info tvs
-          let cls_args'    = substTys skol_subst cls_args
-              deriv_strat' = fmap (mapDerivStrategy (substTy skol_subst))
-                                  deriv_strat
-          pure (tvs', cls_args', deriv_strat')
-        -- If the instance context is supplied, we don't need to skolemise
-        -- at all.
-        SupplyContext{} -> pure (tvs, cls_args, deriv_strat)
-
-    bale_out =
-      failWithTc . TcRnCannotDeriveInstance cls cls_args deriv_strat NoGeneralizedNewtypeDeriving
-
-    mk_eqn :: DerivM EarlyDerivSpec
-    mk_eqn = do
-      DerivEnv { denv_inst_tys = cls_args
-               , denv_strat    = mb_strat } <- ask
-      case mb_strat of
-        Just (StockStrategy _) -> do
-          (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args
-          dit                <- expectAlgTyConApp cls_tys inst_ty
-          mk_eqn_stock dit
-
-        Just (AnyclassStrategy _) -> mk_eqn_anyclass
-
-        Just (ViaStrategy via_ty) -> do
-          (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args
-          mk_eqn_via cls_tys inst_ty via_ty
-
-        Just (NewtypeStrategy _) -> do
-          (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args
-          dit                <- expectAlgTyConApp cls_tys inst_ty
-          unless (isNewTyCon (dit_rep_tc dit)) $
-            derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrGNDUsedOnData
-          mkNewTypeEqn True dit
-
-        Nothing -> mk_eqn_no_strategy
-
--- @expectNonNullaryClsArgs inst_tys@ checks if @inst_tys@ is non-empty.
--- If so, return @(init inst_tys, last inst_tys)@.
--- Otherwise, throw an error message.
--- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this
--- property is important.
-expectNonNullaryClsArgs :: [Type] -> DerivM ([Type], Type)
-expectNonNullaryClsArgs inst_tys =
-  maybe (derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrNullaryClasses) pure $
-  snocView inst_tys
-
--- @expectAlgTyConApp cls_tys inst_ty@ checks if @inst_ty@ is an application
--- of an algebraic type constructor. If so, return a 'DerivInstTys' consisting
--- of @cls_tys@ and the constituent pars of @inst_ty@.
--- Otherwise, throw an error message.
--- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this
--- property is important.
-expectAlgTyConApp :: [Type] -- All but the last argument to the class in a
-                            -- derived instance
-                  -> Type   -- The last argument to the class in a
-                            -- derived instance
-                  -> DerivM DerivInstTys
-expectAlgTyConApp cls_tys inst_ty = do
-  fam_envs <- lift tcGetFamInstEnvs
-  case mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty of
-    Nothing -> derivingThingFailWith NoGeneralizedNewtypeDeriving DerivErrLastArgMustBeApp
-    Just dit -> do expectNonDataFamTyCon dit
-                   pure dit
-
--- @expectNonDataFamTyCon dit@ checks if @dit_rep_tc dit@ is a representation
--- type constructor for a data family instance, and if not,
--- throws an error message.
--- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for why this
--- property is important.
-expectNonDataFamTyCon :: DerivInstTys -> DerivM ()
-expectNonDataFamTyCon (DerivInstTys { dit_tc      = tc
-                                    , dit_tc_args = tc_args
-                                    , dit_rep_tc  = rep_tc }) =
-  -- If it's still a data family, the lookup failed; i.e no instance exists
-  when (isDataFamilyTyCon rep_tc) $
-    derivingThingFailWith NoGeneralizedNewtypeDeriving $
-      DerivErrNoFamilyInstance tc tc_args
-
-mk_deriv_inst_tys_maybe :: FamInstEnvs
-                        -> [Type] -> Type -> Maybe DerivInstTys
-mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty =
-  fmap lookup $ tcSplitTyConApp_maybe inst_ty
-  where
-    lookup :: (TyCon, [Type]) -> DerivInstTys
-    lookup (tc, tc_args) =
-      -- Find the instance of a data family
-      -- Note [Looking up family instances for deriving]
-      let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tc tc_args
-          dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args
-      in DerivInstTys { dit_cls_tys         = cls_tys
-                      , dit_tc              = tc
-                      , dit_tc_args         = tc_args
-                      , dit_rep_tc          = rep_tc
-                      , dit_rep_tc_args     = rep_tc_args
-                      , dit_dc_inst_arg_env = dc_inst_arg_env }
-
-{-
-Note [Looking up family instances for deriving]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-tcLookupFamInstExact is an auxiliary lookup wrapper which requires
-that looked-up family instances exist.  If called with a vanilla
-tycon, the old type application is simply returned.
-
-If we have
-  data instance F () = ... deriving Eq
-  data instance F () = ... deriving Eq
-then tcLookupFamInstExact will be confused by the two matches;
-but that can't happen because tcInstDecls1 doesn't call tcDeriving
-if there are any overlaps.
-
-There are two other things that might go wrong with the lookup.
-First, we might see a standalone deriving clause
-   deriving Eq (F ())
-when there is no data instance F () in scope.
-
-Note that it's OK to have
-  data instance F [a] = ...
-  deriving Eq (F [(a,b)])
-where the match is not exact; the same holds for ordinary data types
-with standalone deriving declarations.
-
-Note [Deriving, type families, and partial applications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When there are no type families, it's quite easy:
-
-    newtype S a = MkS [a]
-    -- :CoS :: S  ~ []  -- Eta-reduced
-
-    instance Eq [a] => Eq (S a)         -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
-    instance Monad [] => Monad S        -- by coercion sym (Monad :CoS)  : Monad [] ~ Monad S
-
-When type families are involved it's trickier:
-
-    data family T a b
-    newtype instance T Int a = MkT [a] deriving( Eq, Monad )
-    -- :RT is the representation type for (T Int a)
-    --  :Co:RT    :: :RT ~ []          -- Eta-reduced!
-    --  :CoF:RT a :: T Int a ~ :RT a   -- Also eta-reduced!
-
-    instance Eq [a] => Eq (T Int a)     -- easy by coercion
-       -- d1 :: Eq [a]
-       -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a))
-
-    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
-       -- d1 :: Monad []
-       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))
-
-Note the need for the eta-reduced rule axioms.  After all, we can
-write it out
-    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
-      return x = MkT [x]
-      ... etc ...
-
-See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom
-
-%************************************************************************
-%*                                                                      *
-                Deriving data types
-*                                                                      *
-************************************************************************
--}
-
--- Once the DerivSpecMechanism is known, we can finally produce an
--- EarlyDerivSpec from it.
-mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec
-mk_eqn_from_mechanism mechanism
-  = do DerivEnv { denv_overlap_mode = overlap_mode
-                , denv_tvs          = tvs
-                , denv_cls          = cls
-                , denv_inst_tys     = inst_tys
-                , denv_ctxt         = deriv_ctxt
-                , denv_skol_info    = skol_info } <- ask
-       user_ctxt <- askDerivUserTypeCtxt
-       doDerivInstErrorChecks1 mechanism
-       loc       <- lift getSrcSpanM
-       dfun_name <- lift $ newDFunName cls inst_tys loc
-       case deriv_ctxt of
-        InferContext wildcard ->
-          do { (inferred_constraints, tvs', inst_tys', mechanism')
-                 <- inferConstraints mechanism
-             ; return $ InferTheta $ DS
-                   { ds_loc = loc
-                   , ds_name = dfun_name, ds_tvs = tvs'
-                   , ds_cls = cls, ds_tys = inst_tys'
-                   , ds_theta = inferred_constraints
-                   , ds_skol_info = skol_info
-                   , ds_user_ctxt = user_ctxt
-                   , ds_overlap = overlap_mode
-                   , ds_standalone_wildcard = wildcard
-                   , ds_mechanism = mechanism' } }
-
-        SupplyContext theta ->
-            return $ GivenTheta $ DS
-                   { ds_loc = loc
-                   , ds_name = dfun_name, ds_tvs = tvs
-                   , ds_cls = cls, ds_tys = inst_tys
-                   , ds_theta = theta
-                   , ds_skol_info = skol_info
-                   , ds_user_ctxt = user_ctxt
-                   , ds_overlap = overlap_mode
-                   , ds_standalone_wildcard = Nothing
-                   , ds_mechanism = mechanism }
-
-mk_eqn_stock :: DerivInstTys -- Information about the arguments to the class
-             -> DerivM EarlyDerivSpec
-mk_eqn_stock dit
-  = do dflags <- getDynFlags
-       let isDeriveAnyClassEnabled =
-             deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)
-       checkOriginativeSideConditions dit >>= \case
-         CanDeriveStock gen_fns -> mk_eqn_from_mechanism $
-                                   DerivSpecStock { dsm_stock_dit     = dit
-                                                  , dsm_stock_gen_fns = gen_fns }
-         StockClassError why    -> derivingThingFailWith NoGeneralizedNewtypeDeriving why
-         CanDeriveAnyClass      -> derivingThingFailWith NoGeneralizedNewtypeDeriving
-                                     (DerivErrNotStockDeriveable isDeriveAnyClassEnabled)
-         -- In the 'NonDerivableClass' case we can't derive with either stock or anyclass
-         -- so we /don't want/ to suggest the user to enabled 'DeriveAnyClass', that's
-         -- why we pass 'YesDeriveAnyClassEnabled', so that GHC won't attempt to suggest it.
-         NonDerivableClass      -> derivingThingFailWith NoGeneralizedNewtypeDeriving
-                                     (DerivErrNotStockDeriveable YesDeriveAnyClassEnabled)
-
-mk_eqn_anyclass :: DerivM EarlyDerivSpec
-mk_eqn_anyclass
-  = do dflags <- getDynFlags
-       let isDeriveAnyClassEnabled =
-             deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)
-       case xopt LangExt.DeriveAnyClass dflags of
-         True  -> mk_eqn_from_mechanism DerivSpecAnyClass
-         False -> derivingThingFailWith NoGeneralizedNewtypeDeriving
-                                        (DerivErrNotDeriveable isDeriveAnyClassEnabled)
-
-mk_eqn_newtype :: DerivInstTys -- Information about the arguments to the class
-               -> Type         -- The newtype's representation type
-               -> DerivM EarlyDerivSpec
-mk_eqn_newtype dit rep_ty =
-  mk_eqn_from_mechanism $ DerivSpecNewtype { dsm_newtype_dit    = dit
-                                           , dsm_newtype_rep_ty = rep_ty }
-
-mk_eqn_via :: [Type] -- All arguments to the class besides the last
-           -> Type   -- The last argument to the class
-           -> Type   -- The @via@ type
-           -> DerivM EarlyDerivSpec
-mk_eqn_via cls_tys inst_ty via_ty =
-  mk_eqn_from_mechanism $ DerivSpecVia { dsm_via_cls_tys = cls_tys
-                                       , dsm_via_inst_ty = inst_ty
-                                       , dsm_via_ty      = via_ty }
-
--- Derive an instance without a user-requested deriving strategy. This uses
--- heuristics to determine which deriving strategy to use.
--- See Note [Deriving strategies].
-mk_eqn_no_strategy :: DerivM EarlyDerivSpec
-mk_eqn_no_strategy = do
-  DerivEnv { denv_cls      = cls
-           , denv_inst_tys = cls_args } <- ask
-  fam_envs <- lift tcGetFamInstEnvs
-
-  -- First, check if the last argument is an application of a type constructor.
-  -- If not, fall back to DeriveAnyClass.
-  if |  Just (cls_tys, inst_ty) <- snocView cls_args
-     ,  Just dit <- mk_deriv_inst_tys_maybe fam_envs cls_tys inst_ty
-     -> if |  isNewTyCon (dit_rep_tc dit)
-              -- We have a dedicated code path for newtypes (see the
-              -- documentation for mkNewTypeEqn as to why this is the case)
-           -> mkNewTypeEqn False dit
-
-           |  otherwise
-           -> do -- Otherwise, our only other options are stock or anyclass.
-                 -- If it is stock, we must confirm that the last argument's
-                 -- type constructor is algebraic.
-                 -- See Note [DerivEnv and DerivSpecMechanism] in GHC.Tc.Deriv.Utils
-                 whenIsJust (hasStockDeriving cls) $ \_ ->
-                   expectNonDataFamTyCon dit
-                 mk_eqn_originative dit
-
-     |  otherwise
-     -> mk_eqn_anyclass
-  where
-    -- Use heuristics (checkOriginativeSideConditions) to determine whether
-    -- stock or anyclass deriving should be used.
-    mk_eqn_originative :: DerivInstTys -> DerivM EarlyDerivSpec
-    mk_eqn_originative dit@(DerivInstTys { dit_tc     = tc
-                                         , dit_rep_tc = rep_tc }) = do
-      dflags <- getDynFlags
-      let isDeriveAnyClassEnabled =
-            deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)
-
-      -- See Note [Deriving instances for classes themselves]
-      let dac_error
-            | isClassTyCon rep_tc
-            = DerivErrOnlyAnyClassDeriveable tc isDeriveAnyClassEnabled
-            | otherwise
-            = DerivErrNotStockDeriveable isDeriveAnyClassEnabled
-
-      checkOriginativeSideConditions dit >>= \case
-        NonDerivableClass      -> derivingThingFailWith NoGeneralizedNewtypeDeriving dac_error
-        StockClassError why    -> derivingThingFailWith NoGeneralizedNewtypeDeriving why
-        CanDeriveStock gen_fns -> mk_eqn_from_mechanism $
-                                  DerivSpecStock { dsm_stock_dit     = dit
-                                                 , dsm_stock_gen_fns = gen_fns }
-        CanDeriveAnyClass      -> mk_eqn_from_mechanism DerivSpecAnyClass
-
-{-
-************************************************************************
-*                                                                      *
-            Deriving instances for newtypes
-*                                                                      *
-************************************************************************
--}
-
--- Derive an instance for a newtype. We put this logic into its own function
--- because
---
--- (a) When no explicit deriving strategy is requested, we have special
---     heuristics for newtypes to determine which deriving strategy should
---     actually be used. See Note [Deriving strategies].
--- (b) We make an effort to give error messages specifically tailored to
---     newtypes.
-mkNewTypeEqn :: Bool -- Was this instance derived using an explicit @newtype@
-                     -- deriving strategy?
-             -> DerivInstTys -> DerivM EarlyDerivSpec
-mkNewTypeEqn newtype_strat dit@(DerivInstTys { dit_cls_tys     = cls_tys
-                                             , dit_rep_tc      = rep_tycon
-                                             , dit_rep_tc_args = rep_tc_args })
--- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
-  = do DerivEnv{denv_cls = cls} <- ask
-       dflags <- getDynFlags
-
-       let newtype_deriving  = xopt LangExt.GeneralizedNewtypeDeriving dflags
-           deriveAnyClass    = xopt LangExt.DeriveAnyClass             dflags
-
-           bale_out = derivingThingFailWith (usingGeneralizedNewtypeDeriving newtype_deriving)
-
-           -- Here is the plan for newtype derivings.  We see
-           --        newtype T a1...an = MkT (t ak+1...an)
-           --          deriving (.., C s1 .. sm, ...)
-           -- where t is a type,
-           --       ak+1...an is a suffix of a1..an, and are all tyvars
-           --       ak+1...an do not occur free in t, nor in the s1..sm
-           --       (C s1 ... sm) is a  *partial applications* of class C
-           --                      with the last parameter missing
-           --       (T a1 .. ak) matches the kind of C's last argument
-           --              (and hence so does t)
-           -- The latter kind-check has been done by deriveTyData already,
-           -- and tc_args are already trimmed
-           --
-           -- We generate the instance
-           --       instance forall ({a1..ak} u fvs(s1..sm)).
-           --                C s1 .. sm t => C s1 .. sm (T a1...ak)
-           -- where T a1...ap is the partial application of
-           --       the LHS of the correct kind and p >= k
-           --
-           --      NB: the variables below are:
-           --              tc_tvs = [a1, ..., an]
-           --              tyvars_to_keep = [a1, ..., ak]
-           --              rep_ty = t ak .. an
-           --              deriv_tvs = fvs(s1..sm) \ tc_tvs
-           --              tys = [s1, ..., sm]
-           --              rep_fn' = t
-           --
-           -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
-           -- We generate the instance
-           --      instance Monad (ST s) => Monad (T s) where
-
-           nt_eta_arity = newTyConEtadArity rep_tycon
-                   -- For newtype T a b = MkT (S a a b), the TyCon
-                   -- machinery already eta-reduces the representation type, so
-                   -- we know that
-                   --      T a ~ S a a
-                   -- That's convenient here, because we may have to apply
-                   -- it to fewer than its original complement of arguments
-
-           -- Note [Newtype representation]
-           -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-           -- Need newTyConRhs (*not* a recursive representation finder)
-           -- to get the representation type. For example
-           --      newtype B = MkB Int
-           --      newtype A = MkA B deriving( Num )
-           -- We want the Num instance of B, *not* the Num instance of Int,
-           -- when making the Num instance of A!
-           rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
-
-           -------------------------------------------------------------------
-           --  Figuring out whether we can only do this newtype-deriving thing
-
-           -- See Note [Determining whether newtype-deriving is appropriate]
-           might_be_newtype_derivable
-              =  not (non_coercible_class cls)
-              && eta_ok
---            && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]
-
-           -- Check that eta reduction is OK
-           eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity
-             -- The newtype can be eta-reduced to match the number
-             --     of type argument actually supplied
-             --        newtype T a b = MkT (S [a] b) deriving( Monad )
-             --     Here the 'b' must be the same in the rep type (S [a] b)
-             --     And the [a] must not mention 'b'.  That's all handled
-             --     by nt_eta_rity.
-
-       massert (cls_tys `lengthIs` (classArity cls - 1))
-       if newtype_strat
-       then
-           -- Since the user explicitly asked for GeneralizedNewtypeDeriving,
-           -- we don't need to perform all of the checks we normally would,
-           -- such as if the class being derived is known to produce ill-roled
-           -- coercions (e.g., Traversable), since we can just derive the
-           -- instance and let it error if need be.
-           -- See Note [Determining whether newtype-deriving is appropriate]
-           if eta_ok && newtype_deriving
-             then mk_eqn_newtype dit rep_inst_ty
-             else bale_out (DerivErrCannotEtaReduceEnough eta_ok)
-       else
-         if might_be_newtype_derivable
-             && ((newtype_deriving && not deriveAnyClass)
-                  || std_class_via_coercible cls)
-         then mk_eqn_newtype dit rep_inst_ty
-         else checkOriginativeSideConditions dit >>= \case
-               StockClassError why
-                 -- There's a particular corner case where
-                 --
-                 -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are
-                 --    both enabled at the same time
-                 -- 2. We're deriving a particular stock derivable class
-                 --    (such as Functor)
-                 --
-                 -- and the previous cases won't catch it. This fixes the bug
-                 -- reported in #10598.
-                 | might_be_newtype_derivable && newtype_deriving
-                -> mk_eqn_newtype dit rep_inst_ty
-                 -- Otherwise, throw an error for a stock class
-                 | might_be_newtype_derivable && not newtype_deriving
-                -> bale_out why
-                 | otherwise
-                -> bale_out why
-
-               -- Must use newtype deriving or DeriveAnyClass
-               NonDerivableClass
-                 -- Too hard, even with newtype deriving
-                 | newtype_deriving           -> bale_out (DerivErrCannotEtaReduceEnough eta_ok)
-                 -- Try newtype deriving!
-                 -- Here we suggest GeneralizedNewtypeDeriving even in cases
-                 -- where it may not be applicable. See #9600.
-                 | otherwise                  -> bale_out DerivErrNewtypeNonDeriveableClass
-
-               -- DeriveAnyClass
-               CanDeriveAnyClass -> do
-                 -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are
-                 -- enabled, we take the diplomatic approach of defaulting to
-                 -- DeriveAnyClass, but emitting a warning about the choice.
-                 -- See Note [Deriving strategies]
-                 when (newtype_deriving && deriveAnyClass) $
-                   lift $ addDiagnosticTc
-                        $ TcRnDerivingDefaults cls
-                 mk_eqn_from_mechanism DerivSpecAnyClass
-               -- CanDeriveStock
-               CanDeriveStock gen_fns -> mk_eqn_from_mechanism $
-                                         DerivSpecStock { dsm_stock_dit     = dit
-                                                        , dsm_stock_gen_fns = gen_fns }
-
-{-
-Note [Recursive newtypes]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Newtype deriving works fine, even if the newtype is recursive.
-e.g.    newtype S1 = S1 [T1 ()]
-        newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
-Remember, too, that type families are currently (conservatively) given
-a recursive flag, so this also allows newtype deriving to work
-for type families.
-
-We used to exclude recursive types, because we had a rather simple
-minded way of generating the instance decl:
-   newtype A = MkA [A]
-   instance Eq [A] => Eq A      -- Makes typechecker loop!
-But now we require a simple context, so it's ok.
-
-Note [Determining whether newtype-deriving is appropriate]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we see
-  newtype NT = MkNT Foo
-    deriving C
-we have to decide how to perform the deriving. Do we do newtype deriving,
-or do we do normal deriving? In general, we prefer to do newtype deriving
-wherever possible. So, we try newtype deriving unless there's a glaring
-reason not to.
-
-"Glaring reasons not to" include trying to derive a class for which a
-coercion-based instance doesn't make sense. These classes are listed in
-the definition of non_coercible_class. They include Show (since it must
-show the name of the datatype) and Traversable (since a coercion-based
-Traversable instance is ill-roled).
-
-However, non_coercible_class is ignored if the user explicitly requests
-to derive an instance with GeneralizedNewtypeDeriving using the newtype
-deriving strategy. In such a scenario, GHC will unquestioningly try to
-derive the instance via coercions (even if the final generated code is
-ill-roled!). See Note [Deriving strategies].
-
-Note that newtype deriving might fail, even after we commit to it. This
-is because the derived instance uses `coerce`, which must satisfy its
-`Coercible` constraint. This is different than other deriving scenarios,
-where we're sure that the resulting instance will type-check.
-
-Note [GND and associated type families]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for
-classes with associated type families. A general recipe is:
-
-    class C x y z where
-      type T y z x
-      op :: x -> [y] -> z
-
-    newtype N a = MkN <rep-type> deriving( C )
-
-    =====>
-
-    instance C x y <rep-type> => C x y (N a) where
-      type T y (N a) x = T y <rep-type> x
-      op = coerce (op :: x -> [y] -> <rep-type>)
-
-However, we must watch out for three things:
-
-(a) The class must not contain any data families. If it did, we'd have to
-    generate a fresh data constructor name for the derived data family
-    instance, and it's not clear how to do this.
-
-(b) Each associated type family's type variables must mention the last type
-    variable of the class. As an example, you wouldn't be able to use GND to
-    derive an instance of this class:
-
-      class C a b where
-        type T a
-
-    But you would be able to derive an instance of this class:
-
-      class C a b where
-        type T b
-
-    The difference is that in the latter T mentions the last parameter of C
-    (i.e., it mentions b), but the former T does not. If you tried, e.g.,
-
-      newtype Foo x = Foo x deriving (C a)
-
-    with the former definition of C, you'd end up with something like this:
-
-      instance C a (Foo x) where
-        type T a = T ???
-
-    This T family instance doesn't mention the newtype (or its representation
-    type) at all, so we disallow such constructions with GND.
-
-(c) UndecidableInstances might need to be enabled. Here's a case where it is
-    most definitely necessary:
-
-      class C a where
-        type T a
-      newtype Loop = Loop MkLoop deriving C
-
-      =====>
-
-      instance C Loop where
-        type T Loop = T Loop
-
-    Obviously, T Loop would send the typechecker into a loop. Unfortunately,
-    you might even need UndecidableInstances even in cases where the
-    typechecker would be guaranteed to terminate. For example:
-
-      instance C Int where
-        type C Int = Int
-      newtype MyInt = MyInt Int deriving C
-
-      =====>
-
-      instance C MyInt where
-        type T MyInt = T Int
-
-    GHC's termination checker isn't sophisticated enough to conclude that the
-    definition of T MyInt terminates, so UndecidableInstances is required.
-
-(d) For the time being, we do not allow the last type variable of the class to
-    appear in a /kind/ of an associated type family definition. For instance:
-
-    class C a where
-      type T1 a        -- OK
-      type T2 (x :: a) -- Illegal: a appears in the kind of x
-      type T3 y :: a   -- Illegal: a appears in the kind of (T3 y)
-
-    The reason we disallow this is because our current approach to deriving
-    associated type family instances—i.e., by unwrapping the newtype's type
-    constructor as shown above—is ill-equipped to handle the scenario when
-    the last type variable appears as an implicit argument. In the worst case,
-    allowing the last variable to appear in a kind can result in improper Core
-    being generated (see #14728).
-
-    There is hope for this feature being added some day, as one could
-    conceivably take a newtype axiom (which witnesses a coercion between a
-    newtype and its representation type) at lift that through each associated
-    type at the Core level. See #14728, comment:3 for a sketch of how this
-    might work. Until then, we disallow this featurette wholesale.
-
-The same criteria apply to DerivingVia.
-
-************************************************************************
-*                                                                      *
-Bindings for the various classes
-*                                                                      *
-************************************************************************
-
-After all the trouble to figure out the required context for the
-derived instance declarations, all that's left is to chug along to
-produce them.  They will then be shoved into @tcInstDecls2@, which
-will do all its usual business.
-
-There are lots of possibilities for code to generate.  Here are
-various general remarks.
-
-PRINCIPLES:
-\begin{itemize}
-\item
-We want derived instances of @Eq@ and @Ord@ (both v common) to be
-``you-couldn't-do-better-by-hand'' efficient.
-
-\item
-Deriving @Show@---also pretty common--- should also be reasonable good code.
-
-\item
-Deriving for the other classes isn't that common or that big a deal.
-\end{itemize}
-
-PRAGMATICS:
-
-\begin{itemize}
-\item
-Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
-
-\item
-Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
-
-\item
-We {\em normally} generate code only for the non-defaulted methods;
-there are some exceptions for @Eq@ and (especially) @Ord@...
-
-\item
-Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
-constructor's numeric (@Int#@) tag.  These are generated by
-@gen_tag_n_con_binds@, and the heuristic for deciding if one of
-these is around is given by @hasCon2TagFun@.
-
-The examples under the different sections below will make this
-clearer.
-
-\item
-Much less often (really just for deriving @Ix@), we use a
-@_tag2con_<tycon>@ function.  See the examples.
-
-\item
-We use the renamer!!!  Reason: we're supposed to be
-producing @LHsBinds Name@ for the methods, but that means
-producing correctly-uniquified code on the fly.  This is entirely
-possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
-So, instead, we produce @MonoBinds RdrName@ then heave 'em through
-the renamer.  What a great hack!
-\end{itemize}
--}
-
--- | Generate the 'InstInfo' for the required instance,
--- plus any auxiliary bindings required (see @Note [Auxiliary binders]@ in
--- "GHC.Tc.Deriv.Generate") and any additional free variables
--- that should be marked (see @Note [Deriving and unused record selectors]@
--- in "GHC.Tc.Deriv.Utils").
-genInstBinds :: DerivSpec ThetaType
-             -> TcM (InstInfo GhcPs, Bag AuxBindSpec, [Name])
-genInstBinds spec@(DS { ds_tvs = tyvars, ds_mechanism = mechanism
-                      , ds_tys = inst_tys, ds_theta = theta, ds_cls = clas
-                      , ds_loc = loc, ds_standalone_wildcard = wildcard })
-  = set_spec_span_and_ctxt spec $
-    do (meth_binds, meth_sigs, aux_specs, unusedNames) <- gen_inst_binds
-       inst_spec <- newDerivClsInst spec
-       doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism
-       traceTc "newder" (ppr inst_spec)
-       let inst_info =
-             InstInfo
-               { iSpec   = inst_spec
-               , iBinds  = InstBindings
-                             { ib_binds = meth_binds
-                             , ib_tyvars = map Var.varName tyvars
-                             , ib_pragmas = meth_sigs
-                             , ib_extensions = extensions
-                             , ib_derived = True } }
-       return (inst_info, aux_specs, unusedNames)
-  where
-    extensions :: [LangExt.Extension]
-    extensions
-      | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism
-      = [
-          -- Both these flags are needed for higher-rank uses of coerce...
-          LangExt.ImpredicativeTypes, LangExt.RankNTypes
-          -- ...and this flag is needed to support the instance signatures
-          -- that bring type variables into scope.
-          -- See Note [Newtype-deriving instances] in GHC.Tc.Deriv.Generate
-        , LangExt.InstanceSigs
-          -- Skip unboxed tuples checking for derived instances when imported
-          -- in a different module, see #20524
-        , LangExt.UnboxedTuples
-        ]
-      | otherwise
-      = []
-
-    gen_inst_binds :: TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
-    gen_inst_binds
-      = case mechanism of
-          -- See Note [Bindings for Generalised Newtype Deriving]
-          DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}
-            -> gen_newtype_or_via rhs_ty
-
-          -- Try a stock deriver
-          DerivSpecStock { dsm_stock_dit = dit
-                         , dsm_stock_gen_fns =
-                             StockGenFns { stock_gen_binds = gen_fn } }
-            -> gen_fn loc dit
-
-          -- Try DeriveAnyClass
-          DerivSpecAnyClass
-            -> return (emptyBag, [], emptyBag, [])
-               -- No method bindings, signatures, auxiliary bindings or free
-               -- variable names are needed. The only interesting work happens when
-               -- defaulting associated type family instances (see the
-               -- DeriveSpecAnyClass case in genFamInsts below).
-
-          -- Try DerivingVia
-          DerivSpecVia{dsm_via_ty = via_ty}
-            -> gen_newtype_or_via via_ty
-
-    gen_newtype_or_via ty = do
-      let (binds, sigs) = gen_Newtype_binds loc clas tyvars inst_tys ty
-      return (binds, sigs, emptyBag, [])
-
--- | Generate the associated type family instances for a derived instance.
-genFamInsts :: DerivSpec theta -> TcM [FamInst]
-genFamInsts spec@(DS { ds_tvs = tyvars, ds_mechanism = mechanism
-                     , ds_tys = inst_tys, ds_cls = clas, ds_loc = loc })
-  = set_spec_span_and_ctxt spec $
-    case mechanism of
-      -- See Note [GND and associated type families]
-      DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}
-        -> gen_newtype_or_via rhs_ty
-
-      -- Try a stock deriver
-      DerivSpecStock { dsm_stock_dit = dit
-                     , dsm_stock_gen_fns =
-                         StockGenFns { stock_gen_fam_insts = gen_fn } }
-        -> gen_fn loc dit
-
-      -- See Note [DeriveAnyClass and default family instances]
-      DerivSpecAnyClass -> do
-        let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)
-            mini_subst = mkTvSubst (mkInScopeSetList tyvars) mini_env
-        dflags <- getDynFlags
-        tyfam_insts <-
-          -- canDeriveAnyClass should ensure that this code can't be reached
-          -- unless -XDeriveAnyClass is enabled.
-          assertPpr (xopt LangExt.DeriveAnyClass dflags)
-                    (text "genFamInsts: bad derived class" <+> ppr clas) $
-          mapM (tcATDefault loc mini_subst emptyNameSet)
-               (classATItems clas)
-        pure $ concat tyfam_insts
-
-      -- Try DerivingVia
-      DerivSpecVia{dsm_via_ty = via_ty}
-        -> gen_newtype_or_via via_ty
-  where
-    gen_newtype_or_via ty = gen_Newtype_fam_insts loc clas tyvars inst_tys ty
-
--- Set the SrcSpan and error context for an action that uses a DerivSpec.
-set_spec_span_and_ctxt :: DerivSpec theta -> TcM a -> TcM a
-set_spec_span_and_ctxt (DS{ ds_loc = loc, ds_cls = clas, ds_tys = tys }) =
-  setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)
-
--- Checks:
---
--- * All of the data constructors for a data type are in scope for a
---   standalone-derived instance (for `stock` and `newtype` deriving).
---
--- * All of the associated type families of a class are suitable for
---   GeneralizedNewtypeDeriving or DerivingVia (for `newtype` and `via`
---   deriving).
-doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
-doDerivInstErrorChecks1 mechanism =
-  case mechanism of
-    DerivSpecStock{dsm_stock_dit = dit}
-      -> data_cons_in_scope_check dit
-    DerivSpecNewtype{dsm_newtype_dit = dit}
-      -> do atf_coerce_based_error_checks
-            data_cons_in_scope_check dit
-    DerivSpecAnyClass{}
-      -> pure ()
-    DerivSpecVia{}
-      -> atf_coerce_based_error_checks
-  where
-    -- When processing a standalone deriving declaration, check that all of the
-    -- constructors for the data type are in scope. For instance:
-    --
-    --   import M (T)
-    --   deriving stock instance Eq T
-    --
-    -- This should be rejected, as the derived Eq instance would need to refer
-    -- to the constructors for T, which are not in scope.
-    --
-    -- Note that the only strategies that require this check are `stock` and
-    -- `newtype`. Neither `anyclass` nor `via` require it as the code that they
-    -- generate does not require using data constructors.
-    data_cons_in_scope_check :: DerivInstTys -> DerivM ()
-    data_cons_in_scope_check (DerivInstTys { dit_tc     = tc
-                                           , dit_rep_tc = rep_tc }) = do
-      standalone <- isStandaloneDeriv
-      when standalone $ do
-        let bale_out msg = do err <- derivingThingErrMechanism mechanism msg
-                              lift $ failWithTc err
-
-        rdr_env <- lift getGlobalRdrEnv
-        let data_con_names = map dataConName (tyConDataCons rep_tc)
-            hidden_data_cons = not (isWiredIn rep_tc) &&
-                               (isAbstractTyCon rep_tc ||
-                                any not_in_scope data_con_names)
-            not_in_scope dc  = isNothing (lookupGRE_Name rdr_env dc)
-
-        -- Make sure to also mark the data constructors as used so that GHC won't
-        -- mistakenly emit -Wunused-imports warnings about them.
-        lift $ addUsedDataCons rdr_env rep_tc
-
-        unless (not hidden_data_cons) $
-          bale_out $ DerivErrDataConsNotAllInScope tc
-
-    -- Ensure that a class's associated type variables are suitable for
-    -- GeneralizedNewtypeDeriving or DerivingVia. Unsurprisingly, this check is
-    -- only required for the `newtype` and `via` strategies.
-    --
-    -- See Note [GND and associated type families]
-    atf_coerce_based_error_checks :: DerivM ()
-    atf_coerce_based_error_checks = do
-      cls <- asks denv_cls
-      let bale_out msg = do err <- derivingThingErrMechanism mechanism msg
-                            lift $ failWithTc err
-
-          cls_tyvars = classTyVars cls
-
-          ats_look_sensible
-             =  -- Check (a) from Note [GND and associated type families]
-                no_adfs
-                -- Check (b) from Note [GND and associated type families]
-             && isNothing at_without_last_cls_tv
-                -- Check (d) from Note [GND and associated type families]
-             && isNothing at_last_cls_tv_in_kinds
-
-          (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs
-          no_adfs            = null adf_tcs
-                 -- We cannot newtype-derive data family instances
-
-          at_without_last_cls_tv
-            = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs
-          at_last_cls_tv_in_kinds
-            = find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind)
-                               (tyConTyVars tc)
-                        || at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs
-          at_last_cls_tv_in_kind kind
-            = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind
-          at_tcs = classATs cls
-          last_cls_tv = assert (notNull cls_tyvars )
-                        last cls_tyvars
-
-      unless ats_look_sensible $
-        bale_out (DerivErrHasAssociatedDatatypes
-                   (hasAssociatedDataFamInsts (not no_adfs))
-                   (associatedTyLastVarInKind at_last_cls_tv_in_kinds)
-                   (associatedTyNotParamOverLastTyVar at_without_last_cls_tv)
-                 )
-
-doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan
-                        -> DerivSpecMechanism -> TcM ()
-doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism
-  = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst)
-       ; dflags <- getDynFlags
-       ; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures
-       ; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures
-
-         -- Error if PartialTypeSignatures isn't enabled when a user tries
-         -- to write @deriving instance _ => Eq (Foo a)@. Or, if that
-         -- extension is enabled, give a warning if -Wpartial-type-signatures
-         -- is enabled.
-       ; case wildcard of
-           Nothing -> pure ()
-           Just span -> setSrcSpan span $ do
-             let suggParSigs = suggestPartialTypeSignatures xpartial_sigs
-             let dia = TcRnPartialTypeSignatures suggParSigs theta
-             checkTc xpartial_sigs dia
-             diagnosticTc wpartial_sigs dia
-
-         -- Check for Generic instances that are derived with an exotic
-         -- deriving strategy like DAC
-         -- See Note [Deriving strategies]
-       ; when (exotic_mechanism && className clas `elem` genericClassNames) $
-         do { failIfTc (safeLanguageOn dflags)
-                       (TcRnCannotDeriveInstance clas mempty Nothing NoGeneralizedNewtypeDeriving $
-                          DerivErrSafeHaskellGenericInst)
-            ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } }
-  where
-    exotic_mechanism = not $ isDerivSpecStock mechanism
-
-derivingThingFailWith :: UsingGeneralizedNewtypeDeriving
-                         -- ^ If 'YesGeneralizedNewtypeDeriving', add a snippet about
-                         -- how not even GeneralizedNewtypeDeriving would make this
-                         -- declaration work. This only kicks in when
-                         -- an explicit deriving strategy is not given.
-                      -> DeriveInstanceErrReason -- The reason the derivation failed
-                      -> DerivM a
-derivingThingFailWith newtype_deriving msg = do
-  err <- derivingThingErrM newtype_deriving msg
-  lift $ failWithTc err
-
-{-
-Note [Bindings for Generalised Newtype Deriving]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  class Eq a => C a where
-     f :: a -> a
-  newtype N a = MkN [a] deriving( C )
-  instance Eq (N a) where ...
-
-The 'deriving C' clause generates, in effect
-  instance (C [a], Eq a) => C (N a) where
-     f = coerce (f :: [a] -> [a])
-
-This generates a cast for each method, but allows the superclasses to
-be worked out in the usual way.  In this case the superclass (Eq (N
-a)) will be solved by the explicit Eq (N a) instance.  We do *not*
-create the superclasses by casting the superclass dictionaries for the
-representation type.
-
-See the paper "Safe zero-cost coercions for Haskell".
-
-Note [DeriveAnyClass and default family instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-When a class has a associated type family with a default instance, e.g.:
-
-  class C a where
-    type T a
-    type T a = Char
-
-then there are a couple of scenarios in which a user would expect T a to
-default to Char. One is when an instance declaration for C is given without
-an implementation for T:
-
-  instance C Int
-
-Another scenario in which this can occur is when the -XDeriveAnyClass extension
-is used:
-
-  data Example = Example deriving (C, Generic)
-
-In the latter case, we must take care to check if C has any associated type
-families with default instances, because -XDeriveAnyClass will never provide
-an implementation for them. We "fill in" the default instances using the
-tcATDefault function from GHC.Tc.TyCl.Class (which is also used in GHC.Tc.TyCl.Instance to
-handle the empty instance declaration case).
-
-Note [Deriving strategies]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-GHC has a notion of deriving strategies, which allow the user to explicitly
-request which approach to use when deriving an instance (enabled with the
--XDerivingStrategies language extension). For more information, refer to the
-original issue (#10598) or the associated wiki page:
-https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies
-
-A deriving strategy can be specified in a deriving clause:
-
-    newtype Foo = MkFoo Bar
-      deriving newtype C
-
-Or in a standalone deriving declaration:
-
-    deriving anyclass instance C Foo
-
--XDerivingStrategies also allows the use of multiple deriving clauses per data
-declaration so that a user can derive some instance with one deriving strategy
-and other instances with another deriving strategy. For example:
-
-    newtype Baz = Baz Quux
-      deriving          (Eq, Ord)
-      deriving stock    (Read, Show)
-      deriving newtype  (Num, Floating)
-      deriving anyclass C
-
-Currently, the deriving strategies are:
-
-* stock: Have GHC implement a "standard" instance for a data type, if possible
-  (e.g., Eq, Ord, Generic, Data, Functor, etc.)
-
-* anyclass: Use -XDeriveAnyClass
-
-* newtype: Use -XGeneralizedNewtypeDeriving
-
-* via: Use -XDerivingVia
-
-The latter two strategies (newtype and via) are referred to as the
-"coerce-based" strategies, since they generate code that relies on the `coerce`
-function. See, for instance, GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased.
-
-The former two strategies (stock and anyclass), in contrast, are
-referred to as the "originative" strategies, since they create "original"
-instances instead of "reusing" old instances (by way of `coerce`).
-See, for instance, GHC.Tc.Deriv.Utils.checkOriginativeSideConditions.
-
-If an explicit deriving strategy is not given, GHC has an algorithm it uses to
-determine which strategy it will actually use. The algorithm is quite long,
-so it lives in the Haskell wiki at
-https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies
-("The deriving strategy resolution algorithm" section).
-
-Internally, GHC uses the DerivStrategy datatype to denote a user-requested
-deriving strategy, and it uses the DerivSpecMechanism datatype to denote what
-GHC will use to derive the instance after taking the above steps. In other
-words, GHC will always settle on a DerivSpecMechnism, even if the user did not
-ask for a particular DerivStrategy (using the algorithm linked to above).
-
-Note [Deriving instances for classes themselves]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Much of the code in GHC.Tc.Deriv assumes that deriving only works on data types.
-But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly
-reasonable to do something like this:
-
-  {-# LANGUAGE DeriveAnyClass #-}
-  class C1 (a :: Constraint) where
-  class C2 where
-  deriving instance C1 C2
-    -- This is equivalent to `instance C1 C2`
-
-If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock
-deriving), we throw a special error message indicating that DeriveAnyClass is
-the only way to go. We don't bother throwing this error if an explicit 'stock'
-or 'newtype' keyword is used, since both options have their own perfectly
-sensible error messages in the case of the above code (as C1 isn't a stock
-derivable class, and C2 isn't a newtype).
-
-************************************************************************
-*                                                                      *
-What con2tag/tag2con functions are available?
-*                                                                      *
-************************************************************************
--}
-
-derivingThingErrM :: UsingGeneralizedNewtypeDeriving
-                  -> DeriveInstanceErrReason
-                  -> DerivM TcRnMessage
-derivingThingErrM newtype_deriving why
-  = do DerivEnv { denv_cls      = cls
-                , denv_inst_tys = cls_args
-                , denv_strat    = mb_strat } <- ask
-       pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why
-
-derivingThingErrMechanism :: DerivSpecMechanism -> DeriveInstanceErrReason -> DerivM TcRnMessage
-derivingThingErrMechanism mechanism why
-  = do DerivEnv { denv_cls      = cls
-                , denv_inst_tys = cls_args
-                , denv_strat    = mb_strat } <- ask
-       pure $ TcRnCannotDeriveInstance cls cls_args mb_strat newtype_deriving why
-  where
-    newtype_deriving :: UsingGeneralizedNewtypeDeriving
-    newtype_deriving
-      = if isDerivSpecNewtype mechanism then YesGeneralizedNewtypeDeriving
-                                        else NoGeneralizedNewtypeDeriving
-
-standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
-standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")
-                       2 (quotes (ppr ty))
diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Deriv/Functor.hs
+++ /dev/null
@@ -1,1475 +0,0 @@
-{-
-(c) The University of Glasgow 2011
-
--}
-
-
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-
--- | The deriving code for the Functor, Foldable, and Traversable classes
-module GHC.Tc.Deriv.Functor
-   ( FFoldType(..)
-   , functorLikeTraverse
-   , deepSubtypesContaining
-   , foldDataConArgs
-
-   , gen_Functor_binds
-   , gen_Foldable_binds
-   , gen_Traversable_binds
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Data.Bag
-import GHC.Core.DataCon
-import GHC.Data.FastString
-import GHC.Hs
-import GHC.Utils.Panic
-import GHC.Builtin.Names
-import GHC.Types.Name.Reader
-import GHC.Types.SrcLoc
-import GHC.Utils.Monad.State.Strict
-import GHC.Tc.Deriv.Generate
-import GHC.Tc.Utils.TcType
-import GHC.Core.TyCon
-import GHC.Core.TyCo.Rep
-import GHC.Core.Type
-import GHC.Utils.Misc
-import GHC.Types.Var
-import GHC.Types.Var.Set
-import GHC.Types.Id.Make (coerceId)
-import GHC.Builtin.Types (true_RDR, false_RDR)
-
-import Data.Maybe (catMaybes, isJust)
-
-{-
-************************************************************************
-*                                                                      *
-                        Functor instances
-
- see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
-
-*                                                                      *
-************************************************************************
-
-For the data type:
-
-  data T a = T1 Int a | T2 (T a)
-
-We generate the instance:
-
-  instance Functor T where
-      fmap f (T1 b1 a) = T1 b1 (f a)
-      fmap f (T2 ta)   = T2 (fmap f ta)
-
-Notice that we don't simply apply 'fmap' to the constructor arguments.
-Rather
-  - Do nothing to an argument whose type doesn't mention 'a'
-  - Apply 'f' to an argument of type 'a'
-  - Apply 'fmap f' to other arguments
-That's why we have to recurse deeply into the constructor argument types,
-rather than just one level, as we typically do.
-
-What about types with more than one type parameter?  In general, we only
-derive Functor for the last position:
-
-  data S a b = S1 [b] | S2 (a, T a b)
-  instance Functor (S a) where
-    fmap f (S1 bs)    = S1 (fmap f bs)
-    fmap f (S2 (p,q)) = S2 (a, fmap f q)
-
-However, we have special cases for
-         - tuples
-         - functions
-
-More formally, we write the derivation of fmap code over type variable
-'a for type 'b as ($fmap 'a 'b x).  In this general notation the derived
-instance for T is:
-
-  instance Functor T where
-      fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
-      fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)
-
-  $(fmap 'a 'b x)          = x     -- when b does not contain a
-  $(fmap 'a 'a x)          = f x
-  $(fmap 'a '(b1,b2) x)    = case x of (x1,x2) -> ($(fmap 'a 'b1 x1), $(fmap 'a 'b2 x2))
-  $(fmap 'a '(T b1 a) x)   = fmap f x -- when a only occurs directly as the last argument of T
-  $(fmap 'a '(T b1 b2) x)  = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
-  $(fmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(fmap 'a' 'tc' (x $(cofmap 'a 'tb y)))
-
-For functions, the type parameter 'a can occur in a contravariant position,
-which means we need to derive a function like:
-
-  cofmap :: (a -> b) -> (f b -> f a)
-
-This is pretty much the same as $fmap, only without the $(cofmap 'a 'a x) and
-$(cofmap 'a '(T b1 a) x) cases:
-
-  $(cofmap 'a 'b x)          = x     -- when b does not contain a
-  $(cofmap 'a 'a x)          = error "type variable in contravariant position"
-  $(cofmap 'a '(b1,b2) x)    = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
-  $(cofmap 'a '(T b1 a) x)   = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T
-  $(cofmap 'a '(T b1 b2) x)  = fmap (\y. $(cofmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
-  $(cofmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(cofmap 'a' 'tc' (x $(fmap 'a 'tb y)))
-
-Note that the code produced by $(fmap _ _ _) is always a higher order function,
-with type `(a -> b) -> (g a -> g b)` for some g.
-
-Note that there are two distinct cases in $fmap (and $cofmap) that match on an
-application of some type constructor T (where T is not a tuple type
-constructor):
-
-  $(fmap 'a '(T b1 a) x)  = fmap f x -- when a only occurs directly as the last argument of T
-  $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
-
-While the latter case technically subsumes the former case, it is important to
-give special treatment to the former case to avoid unnecessary eta expansion.
-See Note [Avoid unnecessary eta expansion in derived fmap implementations].
-
-We also generate code for (<$) in addition to fmap—see Note [Deriving <$] for
-an explanation of why this is important. Just like $fmap/$cofmap above, there
-is a similar algorithm for generating `p <$ x` (for some constant `p`):
-
-  $(replace 'a 'b x)          = x      -- when b does not contain a
-  $(replace 'a 'a x)          = p
-  $(replace 'a '(b1,b2) x)    = case x of (x1,x2) -> ($(replace 'a 'b1 x1), $(replace 'a 'b2 x2))
-  $(replace 'a '(T b1 a) x)   = p <$ x -- when a only occurs directly as the last argument of T
-  $(replace 'a '(T b1 b2) x)  = fmap (\y. $(replace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
-  $(replace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(replace 'a' 'tc' (x $(coreplace 'a 'tb y)))
-
-  $(coreplace 'a 'b x)          = x      -- when b does not contain a
-  $(coreplace 'a 'a x)          = error "type variable in contravariant position"
-  $(coreplace 'a '(b1,b2) x)    = case x of (x1,x2) -> ($(coreplace 'a 'b1 x1), $(coreplace 'a 'b2 x2))
-  $(coreplace 'a '(T b1 a) x)   = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T
-  $(coreplace 'a '(T b1 b2) x)  = fmap (\y. $(coreplace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
-  $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y)))
--}
-
-gen_Functor_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
--- When the argument is phantom, we can use  fmap _ = coerce
--- See Note [Phantom types with Functor, Foldable, and Traversable]
-gen_Functor_binds loc (DerivInstTys{dit_rep_tc = tycon})
-  | Phantom <- last (tyConRoles tycon)
-  = (unitBag fmap_bind, emptyBag)
-  where
-    fmap_name = L (noAnnSrcSpan loc) fmap_RDR
-    fmap_bind = mkRdrFunBind fmap_name fmap_eqns
-    fmap_eqns = [mkSimpleMatch fmap_match_ctxt
-                               [nlWildPat]
-                               coerce_Expr]
-    fmap_match_ctxt = mkPrefixFunRhs fmap_name
-
-gen_Functor_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
-                                       , dit_rep_tc_args = tycon_args })
-  = (listToBag [fmap_bind, replace_bind], emptyBag)
-  where
-    data_cons = getPossibleDataCons tycon tycon_args
-    fmap_name = L (noAnnSrcSpan loc) fmap_RDR
-
-    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
-    fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns
-    fmap_match_ctxt = mkPrefixFunRhs fmap_name
-
-    fmap_eqn con = flip evalState bs_RDRs $
-                     match_for_con fmap_match_ctxt [f_Pat] con parts
-      where
-        parts = foldDataConArgs ft_fmap con dit
-
-    fmap_eqns = map fmap_eqn data_cons
-
-    ft_fmap :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-    ft_fmap = FT { ft_triv = \x -> pure x
-                   -- fmap f x = x
-                 , ft_var  = \x -> pure $ nlHsApp f_Expr x
-                   -- fmap f x = f x
-                 , ft_fun  = \g h x -> mkSimpleLam $ \b -> do
-                     gg <- g b
-                     h $ nlHsApp x gg
-                   -- fmap f x = \b -> h (x (g b))
-                 , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt)
-                   -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
-                 , ft_ty_app = \_ arg_ty g x ->
-                     -- If the argument type is a bare occurrence of the
-                     -- data type's last type variable, then we can generate
-                     -- more efficient code.
-                     -- See Note [Avoid unnecessary eta expansion in derived fmap implementations]
-                     if tcIsTyVarTy arg_ty
-                       then pure $ nlHsApps fmap_RDR [f_Expr,x]
-                       else do gg <- mkSimpleLam g
-                               pure $ nlHsApps fmap_RDR [gg,x]
-                   -- fmap f x = fmap g x
-                 , ft_forall = \_ g x -> g x
-                 , ft_bad_app = panic "in other argument in ft_fmap"
-                 , ft_co_var = panic "contravariant in ft_fmap" }
-
-    -- See Note [Deriving <$]
-    replace_name = L (noAnnSrcSpan loc) replace_RDR
-
-    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
-    replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns
-    replace_match_ctxt = mkPrefixFunRhs replace_name
-
-    replace_eqn con = flip evalState bs_RDRs $
-        match_for_con replace_match_ctxt [z_Pat] con parts
-      where
-        parts = foldDataConArgs ft_replace con dit
-
-    replace_eqns = map replace_eqn data_cons
-
-    ft_replace :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-    ft_replace = FT { ft_triv = \x -> pure x
-                   -- p <$ x = x
-                 , ft_var  = \_ -> pure z_Expr
-                   -- p <$ _ = p
-                 , ft_fun  = \g h x -> mkSimpleLam $ \b -> do
-                     gg <- g b
-                     h $ nlHsApp x gg
-                   -- p <$ x = \b -> h (x (g b))
-                 , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt)
-                   -- p <$ x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
-                 , ft_ty_app = \_ arg_ty g x ->
-                       -- If the argument type is a bare occurrence of the
-                       -- data type's last type variable, then we can generate
-                       -- more efficient code.
-                       -- See [Deriving <$]
-                       if tcIsTyVarTy arg_ty
-                         then pure $ nlHsApps replace_RDR [z_Expr,x]
-                         else do gg <- mkSimpleLam g
-                                 pure $ nlHsApps fmap_RDR [gg,x]
-                   -- p <$ x = fmap (p <$) x
-                 , ft_forall = \_ g x -> g x
-                 , ft_bad_app = panic "in other argument in ft_replace"
-                 , ft_co_var = panic "contravariant in ft_replace" }
-
-    -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
-    match_for_con :: Monad m
-                  => HsMatchContext GhcPs
-                  -> [LPat GhcPs] -> DataCon
-                  -> [LHsExpr GhcPs -> m (LHsExpr GhcPs)]
-                  -> m (LMatch GhcPs (LHsExpr GhcPs))
-    match_for_con ctxt = mkSimpleConMatch ctxt $
-        \con_name xsM -> do xs <- sequence xsM
-                            pure $ nlHsApps con_name xs  -- Con x1 x2 ..
-
-{-
-Note [Avoid unnecessary eta expansion in derived fmap implementations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For the sake of simplicity, the algorithm that derived implementations of
-fmap used to have a single case that dealt with applications of some type
-constructor T (where T is not a tuple type constructor):
-
-  $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
-
-This generated less than optimal code in certain situations, however. Consider
-this example:
-
-  data List a = Nil | Cons a (List a) deriving Functor
-
-This would generate the following Functor instance:
-
-  instance Functor List where
-    fmap f Nil = Nil
-    fmap f (Cons x xs) = Cons (f x) (fmap (\y -> f y) xs)
-
-The code `fmap (\y -> f y) xs` is peculiar, since it eta expands an application
-of `f`. What's worse, this eta expansion actually degrades performance! To see
-why, we can trace an invocation of fmap on a small List:
-
-  fmap id     $ Cons 0 $ Cons 0 $ Cons 0 $ Cons 0 Nil
-
-  Cons (id 0) $ fmap (\y -> id y)
-              $ Cons 0 $ Cons 0 $ Cons 0 Nil
-
-  Cons (id 0) $ Cons ((\y -> id y) 0)
-              $ fmap (\y' -> (\y -> id y) y')
-              $ Cons 0 $ Cons 0 Nil
-
-  Cons (id 0) $ Cons ((\y -> id y) 0)
-              $ Cons ((\y' -> (\y -> id y) y') 0)
-              $ fmap (\y'' -> (\y' -> (\y -> id y) y') y'')
-              $ Cons 0 Nil
-
-  Cons (id 0) $ Cons ((\y -> id y) 0)
-              $ Cons ((\y' -> (\y -> id y) y') 0)
-              $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0)
-              $ fmap (\y''' -> (\y'' -> (\y' -> (\y -> id y) y') y'') y''')
-              $ Nil
-
-  Cons (id 0) $ Cons ((\y -> id y) 0)
-              $ Cons ((\y' -> (\y -> id y) y') 0)
-              $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0)
-              $ Nil
-
-Notice how the number of lambdas—and hence, the number of closures—one
-needs to evaluate grows very quickly. In general, a List with N cons cells will
-require (1 + 2 + ... (N-1)) beta reductions, which takes O(N^2) time! This is
-what caused the performance issues observed in #7436.
-
-But hold on a second: shouldn't GHC's optimizer be able to eta reduce
-`\y -> f y` to `f` and avoid these beta reductions? Unfortunately, this is not
-the case. In general, eta reduction can change the semantics of a program. For
-instance, (\x -> ⊥) `seq` () converges, but ⊥ `seq` () diverges. It just so
-happens that the fmap implementation above would have the same semantics
-regardless of whether or not `\y -> f y` or `f` is used, but GHC's optimizer is
-not yet smart enough to realize this (see #17881).
-
-To avoid this quadratic blowup, we add a special case to $fmap that applies
-`fmap f` directly:
-
-  $(fmap 'a '(T b1 a) x)  = fmap f x -- when a only occurs directly as the last argument of T
-  $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
-
-With this modified algorithm, the derived Functor List instance becomes:
-
-  instance Functor List where
-    fmap f Nil = Nil
-    fmap f (Cons x xs) = Cons (f x) (fmap f xs)
-
-No lambdas in sight, just the way we like it.
-
-This special case does not prevent all sources quadratic closure buildup,
-however. In this example:
-
-  data PolyList a = PLNil | PLCons a (PolyList (PolyList a))
-    deriving Functor
-
-We would derive the following code:
-
-  instance Functor PolyList where
-    fmap f PLNil = PLNil
-    fmap f (PLCons x xs) = PLCons (f x) (fmap (\y -> fmap f y) xs)
-
-The use of `fmap (\y -> fmap f y) xs` builds up closures in much the same way
-as `fmap (\y -> f y) xs`. The difference here is that even if we eta reduced
-to `fmap (fmap f) xs`, GHC would /still/ build up a closure, since we are
-recursively invoking fmap with a different argument (fmap f). Since we end up
-paying the price of building a closure either way, we do not extend the special
-case in $fmap any further, since it wouldn't buy us anything.
-
-The ft_ty_app field of FFoldType distinguishes between these two $fmap cases by
-inspecting the argument type. If the argument type is a bare type variable,
-then we can conclude the type variable /must/ be the same as the data type's
-last type parameter. We know that this must be the case since there is an
-invariant that the argument type in ft_ty_app will always contain the last
-type parameter somewhere (see Note [FFoldType and functorLikeTraverse]), so
-if the argument type is a bare variable, then that must be exactly the last
-type parameter.
-
-Note that the ft_ty_app case of ft_replace (which derives implementations of
-(<$)) also inspects the argument type to generate more efficient code.
-See Note [Deriving <$].
-
-Note [Deriving <$]
-~~~~~~~~~~~~~~~~~~
-
-We derive the definition of <$. Allowing this to take the default definition
-can lead to memory leaks: mapping over a structure with a constant function can
-fill the result structure with trivial thunks that retain the values from the
-original structure. The simplifier seems to handle this all right for simple
-types, but not for recursive ones. Consider
-
-data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor
-
--- fmap _ Tip = Tip
--- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r)
-
-Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that
-simplifies no further. Why is that? `fmap` is defined recursively, so GHC
-cannot inline it. The static argument transformation would turn the definition
-into a non-recursive one
-
--- fmap f = go where
---   go Tip = Tip
---   go (Bin l v r) = Bin (go l) (f v) (go r)
-
-which GHC could inline, producing an efficient definion of `<$`. But there are
-several problems. First, GHC does not perform the static argument transformation
-by default, even with -O2. Second, even when it does perform the static argument
-transformation, it does so only when there are at least two static arguments,
-which is not the case for fmap. Finally, when the type in question is
-non-regular, such as
-
-data Nesty a = Z a | S (Nesty a) (Nest (a, a))
-
-the function argument is no longer (entirely) static, so the static argument
-transformation will do nothing for us.
-
-Applying the default definition of `<$` will produce a tree full of thunks that
-look like ((\_ -> x) x0), which represents unnecessary thunk allocation and
-also retention of the previous value, potentially leaking memory. Instead, we
-derive <$ separately. Two aspects are different from fmap: the case of the
-sought type variable (ft_var) and the case of a type application (ft_ty_app).
-The interesting one is ft_ty_app. We have to distinguish two cases: the
-"immediate" case where the type argument *is* the sought type variable, and
-the "nested" case where the type argument *contains* the sought type variable.
-
-The immediate case:
-
-Suppose we have
-
-data Imm a = Imm (F ... a)
-
-Then we want to define
-
-x <$ Imm q = Imm (x <$ q)
-
-The nested case:
-
-Suppose we have
-
-data Nes a = Nes (F ... (G a))
-
-Then we want to define
-
-x <$ Nes q = Nes (fmap (x <$) q)
-
-We inspect the argument type in ft_ty_app
-(see Note [FFoldType and functorLikeTraverse]) to distinguish between these
-two cases. If the argument type is a bare type variable, then we know that it
-must be the same variable as the data type's last type parameter.
-This is very similar to a trick that derived fmap implementations
-use in their own ft_ty_app case.
-See Note [Avoid unnecessary eta expansion in derived fmap implementations],
-which explains why checking if the argument type is a bare variable is
-the right thing to do.
-
-We could, but do not, give tuples special treatment to improve efficiency
-in some cases. Suppose we have
-
-data Nest a = Z a | S (Nest (a,a))
-
-The optimal definition would be
-
-x <$ Z _ = Z x
-x <$ S t = S ((x, x) <$ t)
-
-which produces a result with maximal internal sharing. The reason we do not
-attempt to treat this case specially is that we have no way to give
-user-provided tuple-like types similar treatment. If the user changed the
-definition to
-
-data Pair a = Pair a a
-data Nest a = Z a | S (Nest (Pair a))
-
-they would experience a surprising degradation in performance. -}
-
-
-{-
-Utility functions related to Functor deriving.
-
-Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
-This function works like a fold: it makes a value of type 'a' in a bottom up way.
--}
-
--- Generic traversal for Functor deriving
--- See Note [FFoldType and functorLikeTraverse]
-data FFoldType a      -- Describes how to fold over a Type in a functor like way
-   = FT { ft_triv    :: a
-          -- ^ Does not contain variable
-        , ft_var     :: a
-          -- ^ The variable itself
-        , ft_co_var  :: a
-          -- ^ The variable itself, contravariantly
-        , ft_fun     :: a -> a -> a
-          -- ^ Function type
-        , ft_tup     :: TyCon -> [a] -> a
-          -- ^ Tuple type. The @[a]@ is the result of folding over the
-          --   arguments of the tuple.
-        , ft_ty_app  :: Type -> Type -> a -> a
-          -- ^ Type app, variable only in last argument. The two 'Type's are
-          --   the function and argument parts of @fun_ty arg_ty@,
-          --   respectively.
-        , ft_bad_app :: a
-          -- ^ Type app, variable other than in last argument
-        , ft_forall  :: TcTyVar -> a -> a
-          -- ^ Forall type
-     }
-
-functorLikeTraverse :: forall a.
-                       TyVar         -- ^ Variable to look for
-                    -> FFoldType a   -- ^ How to fold
-                    -> Type          -- ^ Type to process
-                    -> a
-functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar
-                            , ft_co_var = caseCoVar,     ft_fun = caseFun
-                            , ft_tup = caseTuple,        ft_ty_app = caseTyApp
-                            , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
-                    ty
-  = fst (go False ty)
-  where
-    go :: Bool        -- Covariant or contravariant context
-       -> Type
-       -> (a, Bool)   -- (result of type a, does type contain var)
-
-    go co ty | Just ty' <- coreView ty = go co ty'
-    go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)
-    go co (FunTy { ft_arg = x, ft_res = y, ft_af = af })
-       | isInvisibleFunArg af = go co y
-       | xc || yc             = (caseFun xr yr,True)
-       where (xr,xc) = go (not co) x
-             (yr,yc) = go co       y
-    go co (AppTy    x y) | xc = (caseWrongArg,   True)
-                         | yc = (caseTyApp x y yr, True)
-        where (_, xc) = go co x
-              (yr,yc) = go co y
-    go co ty@(TyConApp con args)
-       | not (or xcs)     = (caseTrivial, False)   -- Variable does not occur
-       -- At this point we know that xrs, xcs is not empty,
-       -- and at least one xr is True
-       | isTupleTyCon con = (caseTuple con xrs, True)
-       | or (init xcs)    = (caseWrongArg, True)         -- T (..var..)    ty
-       | Just (fun_ty, arg_ty) <- splitAppTy_maybe ty    -- T (..no var..) ty
-                          = (caseTyApp fun_ty arg_ty (last xrs), True)
-       | otherwise        = (caseWrongArg, True)   -- Non-decomposable (eg type function)
-       where
-         -- When folding over an unboxed tuple, we must explicitly drop the
-         -- runtime rep arguments, or else GHC will generate twice as many
-         -- variables in a unboxed tuple pattern match and expression as it
-         -- actually needs. See #12399
-         (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args))
-    go co (ForAllTy (Bndr v vis) x)
-       | isVisibleForAllTyFlag vis = panic "unexpected visible binder"
-       | v /= var && xc            = (caseForAll v xr,True)
-       where (xr,xc) = go co x
-
-    go _ _ = (caseTrivial,False)
-
--- | Return all syntactic subterms of a 'Type' that are applied to the 'TyVar'
--- argument. This determines what constraints should be inferred for derived
--- 'Functor', 'Foldable', and 'Traversable' instances in "GHC.Tc.Deriv.Infer".
--- For instance, if we have:
---
--- @
--- data Foo a = MkFoo Int a (Maybe a) (Either Int (Maybe a))
--- @
---
--- Then the following would hold:
---
--- * @'deepSubtypesContaining' a Int@ would return @[]@, since @Int@ does not
---   contain the type variable @a@ at all.
---
--- * @'deepSubtypesContaining' a a@ would return @[]@. Although the type @a@
---   contains the type variable @a@, it is not /applied/ to @a@, which is the
---   criterion that 'deepSubtypesContaining' checks for.
---
--- * @'deepSubtypesContaining' a (Maybe a)@ would return @[Maybe]@, as @Maybe@
---   is applied to @a@.
---
--- * @'deepSubtypesContaining' a (Either Int (Maybe a))@ would return
---   @[Either Int, Maybe]@. Both of these types are applied to @a@ through
---   composition.
---
--- As used in "GHC.Tc.Deriv.Infer", the 'Type' argument will always come from
--- 'derivDataConInstArgTys', so it is important that the 'TyVar' comes from
--- 'dataConUnivTyVars' to match. Make sure /not/ to take the 'TyVar' from
--- 'tyConTyVars', as these differ from the 'dataConUnivTyVars' when the data
--- type is a GADT. (See #22167 for what goes wrong if 'tyConTyVars' is used.)
-deepSubtypesContaining :: TyVar -> Type -> [TcType]
-deepSubtypesContaining tv
-  = functorLikeTraverse tv
-        (FT { ft_triv = []
-            , ft_var = []
-            , ft_fun = (++)
-            , ft_tup = \_ xs -> concat xs
-            , ft_ty_app = \t _ ts -> t:ts
-            , ft_bad_app = panic "in other argument in deepSubtypesContaining"
-            , ft_co_var = panic "contravariant in deepSubtypesContaining"
-            , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
-
-
-foldDataConArgs :: FFoldType a -> DataCon -> DerivInstTys -> [a]
--- Fold over the arguments of the datacon
-foldDataConArgs ft con dit
-  = map foldArg (derivDataConInstArgTys con dit)
-  where
-    foldArg
-      = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
-             Just tv -> functorLikeTraverse tv ft
-             Nothing -> const (ft_triv ft)
-    -- If we are deriving Foldable for a GADT, there is a chance that the last
-    -- type variable in the data type isn't actually a type variable at all.
-    -- (for example, this can happen if the last type variable is refined to
-    -- be a concrete type such as Int). If the last type variable is refined
-    -- to be a specific type, then getTyVar_maybe will return Nothing.
-    -- See Note [DeriveFoldable with ExistentialQuantification]
-    --
-    -- The kind checks have ensured the last type parameter is of kind *.
-
--- Make a HsLam using a fresh variable from a State monad
-mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
-            -> State [RdrName] (LHsExpr GhcPs)
--- (mkSimpleLam fn) returns (\x. fn(x))
-mkSimpleLam lam =
-    get >>= \case
-      n:names -> do
-        put names
-        body <- lam (nlHsVar n)
-        return (mkHsLam [nlVarPat n] body)
-      _ -> panic "mkSimpleLam"
-
-mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs
-             -> State [RdrName] (LHsExpr GhcPs))
-             -> State [RdrName] (LHsExpr GhcPs)
-mkSimpleLam2 lam =
-    get >>= \case
-      n1:n2:names -> do
-        put names
-        body <- lam (nlHsVar n1) (nlHsVar n2)
-        return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
-      _ -> panic "mkSimpleLam2"
-
--- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
---
--- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in
--- which the LHS pattern-matches on @extra_pats@, followed by a match on the
--- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
--- and its arguments, applying an expression (from @insides@) to each of the
--- respective arguments of @con@.
-mkSimpleConMatch :: Monad m => HsMatchContext GhcPs
-                 -> (RdrName -> [a] -> m (LHsExpr GhcPs))
-                 -> [LPat GhcPs]
-                 -> DataCon
-                 -> [LHsExpr GhcPs -> a]
-                 -> m (LMatch GhcPs (LHsExpr GhcPs))
-mkSimpleConMatch ctxt fold extra_pats con insides = do
-    let con_name = getRdrName con
-    let vars_needed = takeList insides as_RDRs
-    let bare_pat = nlConVarPat con_name vars_needed
-    let pat = if null vars_needed
-          then bare_pat
-          else nlParPat bare_pat
-    rhs <- fold con_name
-                (zipWith (\i v -> i $ nlHsVar v) insides vars_needed)
-    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs emptyLocalBinds
-
--- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
---
--- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to
--- 'mkSimpleConMatch', with two key differences:
---
--- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a
---    @[LHsExpr RdrName]@. This is because it filters out the expressions
---    corresponding to arguments whose types do not mention the last type
---    variable in a derived 'Foldable' or 'Traversable' instance (i.e., the
---    'Nothing' elements of @insides@).
---
--- 2. @fold@ takes an expression as its first argument instead of a
---    constructor name. This is because it uses a specialized
---    constructor function expression that only takes as many parameters as
---    there are argument types that mention the last type variable.
---
--- See Note [Generated code for DeriveFoldable and DeriveTraversable]
-mkSimpleConMatch2 :: Monad m
-                  => HsMatchContext GhcPs
-                  -> (LHsExpr GhcPs -> [LHsExpr GhcPs]
-                                      -> m (LHsExpr GhcPs))
-                  -> [LPat GhcPs]
-                  -> DataCon
-                  -> [Maybe (LHsExpr GhcPs)]
-                  -> m (LMatch GhcPs (LHsExpr GhcPs))
-mkSimpleConMatch2 ctxt fold extra_pats con insides = do
-    let con_name = getRdrName con
-        vars_needed = takeList insides as_RDRs
-        pat = nlConVarPat con_name vars_needed
-        -- Make sure to zip BEFORE invoking catMaybes. We want the variable
-        -- indices in each expression to match up with the argument indices
-        -- in con_expr (defined below).
-        exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i)
-                                   insides vars_needed
-        -- An element of argTysTyVarInfo is True if the constructor argument
-        -- with the same index has a type which mentions the last type
-        -- variable.
-        argTysTyVarInfo = map isJust insides
-        (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars
-
-        con_expr
-          | null asWithTyVar = nlHsApps con_name asWithoutTyVar
-          | otherwise =
-              let bs   = filterByList  argTysTyVarInfo bs_RDRs
-                  vars = filterByLists argTysTyVarInfo bs_Vars as_Vars
-              in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)
-
-    rhs <- fold con_expr exps
-    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs emptyLocalBinds
-
--- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
-mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a]
-                                 -> m (LMatch GhcPs (LHsExpr GhcPs)))
-                  -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
-mkSimpleTupleCase match_for_con tc insides x
-  = do { let data_con = tyConSingleDataCon tc
-       ; match <- match_for_con [] data_con insides
-       ; return $ nlHsCase x [match] }
-
-{-
-************************************************************************
-*                                                                      *
-                        Foldable instances
-
- see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
-
-*                                                                      *
-************************************************************************
-
-Deriving Foldable instances works the same way as Functor instances,
-only Foldable instances are not possible for function types at all.
-Given (data T a = T a a (T a) deriving Foldable), we get:
-
-  instance Foldable T where
-      foldr f z (T x1 x2 x3) =
-        $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) )
-
--XDeriveFoldable is different from -XDeriveFunctor in that it filters out
-arguments to the constructor that would produce useless code in a Foldable
-instance. For example, the following datatype:
-
-  data Foo a = Foo Int a Int deriving Foldable
-
-would have the following generated Foldable instance:
-
-  instance Foldable Foo where
-    foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2
-
-since neither of the two Int arguments are folded over.
-
-The cases are:
-
-  $(foldr 'a 'a)         =  f
-  $(foldr 'a '(b1,b2))   =  \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
-  $(foldr 'a '(T b1 b2)) =  \x z -> foldr $(foldr 'a 'b2) z x  -- when a only occurs in the last parameter, b2
-
-Note that the arguments to the real foldr function are the wrong way around,
-since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
-
-One can envision a case for types that don't contain the last type variable:
-
-  $(foldr 'a 'b)         =  \x z -> z     -- when b does not contain a
-
-But this case will never materialize, since the aforementioned filtering
-removes all such types from consideration.
-See Note [Generated code for DeriveFoldable and DeriveTraversable].
-
-Foldable instances differ from Functor and Traversable instances in that
-Foldable instances can be derived for data types in which the last type
-variable is existentially quantified. In particular, if the last type variable
-is refined to a more specific type in a GADT:
-
-  data GADT a where
-      G :: a ~ Int => a -> G Int
-
-then the deriving machinery does not attempt to check that the type a contains
-Int, since it is not syntactically equal to a type variable. That is, the
-derived Foldable instance for GADT is:
-
-  instance Foldable GADT where
-      foldr _ z (GADT _) = z
-
-See Note [DeriveFoldable with ExistentialQuantification].
-
-Note [Deriving null]
-~~~~~~~~~~~~~~~~~~~~
-
-In some cases, deriving the definition of 'null' can produce much better
-results than the default definition. For example, with
-
-  data SnocList a = Nil | Snoc (SnocList a) a
-
-the default definition of 'null' would walk the entire spine of a
-nonempty snoc-list before concluding that it is not null. But looking at
-the Snoc constructor, we can immediately see that it contains an 'a', and
-so 'null' can return False immediately if it matches on Snoc. When we
-derive 'null', we keep track of things that cannot be null. The interesting
-case is type application. Given
-
-  data Wrap a = Wrap (Foo (Bar a))
-
-we use
-
-  null (Wrap fba) = all null fba
-
-but if we see
-
-  data Wrap a = Wrap (Foo a)
-
-we can just use
-
-  null (Wrap fa) = null fa
-
-Indeed, we allow this to happen even for tuples:
-
-  data Wrap a = Wrap (Foo (a, Int))
-
-produces
-
-  null (Wrap fa) = null fa
-
-As explained in Note [Deriving <$], giving tuples special performance treatment
-could surprise users if they switch to other types, but Ryan Scott seems to
-think it's okay to do it for now.
--}
-
-gen_Foldable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
--- When the parameter is phantom, we can use foldMap _ _ = mempty
--- See Note [Phantom types with Functor, Foldable, and Traversable]
-gen_Foldable_binds loc (DerivInstTys{dit_rep_tc = tycon})
-  | Phantom <- last (tyConRoles tycon)
-  = (unitBag foldMap_bind, emptyBag)
-  where
-    foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR
-    foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns
-    foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt
-                                  [nlWildPat, nlWildPat]
-                                  mempty_Expr]
-    foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
-
-gen_Foldable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
-                                        , dit_rep_tc_args = tycon_args })
-  | null data_cons  -- There's no real point producing anything but
-                    -- foldMap for a type with no constructors.
-  = (unitBag foldMap_bind, emptyBag)
-
-  | otherwise
-  = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag)
-  where
-    data_cons = getPossibleDataCons tycon tycon_args
-
-    foldr_name = L (noAnnSrcSpan loc) foldable_foldr_RDR
-
-    foldr_bind = mkRdrFunBind (L (noAnnSrcSpan loc) foldable_foldr_RDR) eqns
-    eqns = map foldr_eqn data_cons
-    foldr_eqn con
-      = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
-      where
-        parts = sequence $ foldDataConArgs ft_foldr con dit
-    foldr_match_ctxt = mkPrefixFunRhs foldr_name
-
-    foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR
-
-    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
-    foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr)
-                      foldMap_name foldMap_eqns
-
-    foldMap_eqns = map foldMap_eqn data_cons
-
-    foldMap_eqn con
-      = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
-      where
-        parts = sequence $ foldDataConArgs ft_foldMap con dit
-    foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
-
-    -- Given a list of NullM results, produce Nothing if any of
-    -- them is NotNull, and otherwise produce a list of Maybes
-    -- with Justs representing unknowns and Nothings representing
-    -- things that are definitely null.
-    convert :: [NullM a] -> Maybe [Maybe a]
-    convert = traverse go where
-      go IsNull = Just Nothing
-      go NotNull = Nothing
-      go (NullM a) = Just (Just a)
-
-    null_name = L (noAnnSrcSpan loc) null_RDR
-    null_match_ctxt = mkPrefixFunRhs null_name
-    null_bind = mkRdrFunBind null_name null_eqns
-    null_eqns = map null_eqn data_cons
-    null_eqn con
-      = flip evalState bs_RDRs $ do
-          parts <- sequence $ foldDataConArgs ft_null con dit
-          case convert parts of
-            Nothing -> return $
-              mkMatch null_match_ctxt [nlParPat (nlWildConPat con)]
-                false_Expr emptyLocalBinds
-            Just cp -> match_null [] con cp
-
-    -- Yields 'Just' an expression if we're folding over a type that mentions
-    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
-    -- See Note [FFoldType and functorLikeTraverse]
-    ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
-    ft_foldr
-      = FT { ft_triv    = return Nothing
-             -- foldr f = \x z -> z
-           , ft_var     = return $ Just f_Expr
-             -- foldr f = f
-           , ft_tup     = \t g -> do
-               gg  <- sequence g
-               lam <- mkSimpleLam2 $ \x z ->
-                 mkSimpleTupleCase (match_foldr z) t gg x
-               return (Just lam)
-             -- foldr f = (\x z -> case x of ...)
-           , ft_ty_app  = \_ _ g -> do
-               gg <- g
-               mapM (\gg' -> mkSimpleLam2 $ \x z -> return $
-                 nlHsApps foldable_foldr_RDR [gg',z,x]) gg
-             -- foldr f = (\x z -> foldr g z x)
-           , ft_forall  = \_ g -> g
-           , ft_co_var  = panic "contravariant in ft_foldr"
-           , ft_fun     = panic "function in ft_foldr"
-           , ft_bad_app = panic "in other argument in ft_foldr" }
-
-    match_foldr :: Monad m
-                => LHsExpr GhcPs
-                -> [LPat GhcPs]
-                -> DataCon
-                -> [Maybe (LHsExpr GhcPs)]
-                -> m (LMatch GhcPs (LHsExpr GhcPs))
-    match_foldr z = mkSimpleConMatch2 foldr_match_ctxt $ \_ xs -> return (mkFoldr xs)
-      where
-        -- g1 v1 (g2 v2 (.. z))
-        mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
-        mkFoldr = foldr nlHsApp z
-
-    -- See Note [FFoldType and functorLikeTraverse]
-    ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
-    ft_foldMap
-      = FT { ft_triv = return Nothing
-             -- foldMap f = \x -> mempty
-           , ft_var  = return (Just f_Expr)
-             -- foldMap f = f
-           , ft_tup  = \t g -> do
-               gg  <- sequence g
-               lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
-               return (Just lam)
-             -- foldMap f = \x -> case x of (..,)
-           , ft_ty_app = \_ _ g -> fmap (nlHsApp foldMap_Expr) <$> g
-             -- foldMap f = foldMap g
-           , ft_forall = \_ g -> g
-           , ft_co_var = panic "contravariant in ft_foldMap"
-           , ft_fun = panic "function in ft_foldMap"
-           , ft_bad_app = panic "in other argument in ft_foldMap" }
-
-    match_foldMap :: Monad m
-                  => [LPat GhcPs]
-                  -> DataCon
-                  -> [Maybe (LHsExpr GhcPs)]
-                  -> m (LMatch GhcPs (LHsExpr GhcPs))
-    match_foldMap = mkSimpleConMatch2 foldMap_match_ctxt $ \_ xs -> return (mkFoldMap xs)
-      where
-        -- mappend v1 (mappend v2 ..)
-        mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs
-        mkFoldMap [] = mempty_Expr
-        mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
-
-    -- See Note [FFoldType and functorLikeTraverse]
-    -- Yields NullM an expression if we're folding over an expression
-    -- that may or may not be null. Yields IsNull if it's certainly
-    -- null, and yields NotNull if it's certainly not null.
-    -- See Note [Deriving null]
-    ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs)))
-    ft_null
-      = FT { ft_triv = return IsNull
-             -- null = \_ -> True
-           , ft_var  = return NotNull
-             -- null = \_ -> False
-           , ft_tup  = \t g -> do
-               gg  <- sequence g
-               case convert gg of
-                 Nothing -> pure NotNull
-                 Just ggg ->
-                   NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg)
-             -- null = \x -> case x of (..,)
-           , ft_ty_app = \_ _ g -> flip fmap g $ \nestedResult ->
-                              case nestedResult of
-                                -- If e definitely contains the parameter,
-                                -- then we can test if (G e) contains it by
-                                -- simply checking if (G e) is null
-                                NotNull -> NullM null_Expr
-                                -- This case is unreachable--it will actually be
-                                -- caught by ft_triv
-                                IsNull -> IsNull
-                                -- The general case uses (all null),
-                                -- (all (all null)), etc.
-                                NullM nestedTest -> NullM $
-                                                    nlHsApp all_Expr nestedTest
-             -- null fa = null fa, or null fa = all null fa, or null fa = True
-           , ft_forall = \_ g -> g
-           , ft_co_var = panic "contravariant in ft_null"
-           , ft_fun = panic "function in ft_null"
-           , ft_bad_app = panic "in other argument in ft_null" }
-
-    match_null :: Monad m
-               => [LPat GhcPs]
-               -> DataCon
-               -> [Maybe (LHsExpr GhcPs)]
-               -> m (LMatch GhcPs (LHsExpr GhcPs))
-    match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs)
-      where
-        -- v1 && v2 && ..
-        mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs
-        mkNull [] = true_Expr
-        mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs
-
-data NullM a =
-    IsNull   -- Definitely null
-  | NotNull  -- Definitely not null
-  | NullM a  -- Unknown
-
-{-
-************************************************************************
-*                                                                      *
-                        Traversable instances
-
- see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
-*                                                                      *
-************************************************************************
-
-Again, Traversable is much like Functor and Foldable.
-
-The cases are:
-
-  $(traverse 'a 'a)          =  f
-  $(traverse 'a '(b1,b2))    =  \x -> case x of (x1,x2) ->
-     liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2)
-  $(traverse 'a '(T b1 b2))  =  traverse $(traverse 'a 'b2)  -- when a only occurs in the last parameter, b2
-
-Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types
-do not mention the last type parameter. Therefore, the following datatype:
-
-  data Foo a = Foo Int a Int
-
-would have the following derived Traversable instance:
-
-  instance Traversable Foo where
-    traverse f (Foo x1 x2 x3) =
-      fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 )
-
-since the two Int arguments do not produce any effects in a traversal.
-
-One can envision a case for types that do not mention the last type parameter:
-
-  $(traverse 'a 'b)          =  pure     -- when b does not contain a
-
-But this case will never materialize, since the aforementioned filtering
-removes all such types from consideration.
-See Note [Generated code for DeriveFoldable and DeriveTraversable].
--}
-
-gen_Traversable_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
--- When the argument is phantom, we can use traverse = pure . coerce
--- See Note [Phantom types with Functor, Foldable, and Traversable]
-gen_Traversable_binds loc (DerivInstTys{dit_rep_tc = tycon})
-  | Phantom <- last (tyConRoles tycon)
-  = (unitBag traverse_bind, emptyBag)
-  where
-    traverse_name = L (noAnnSrcSpan loc) traverse_RDR
-    traverse_bind = mkRdrFunBind traverse_name traverse_eqns
-    traverse_eqns =
-        [mkSimpleMatch traverse_match_ctxt
-                       [nlWildPat, z_Pat]
-                       (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
-    traverse_match_ctxt = mkPrefixFunRhs traverse_name
-
-gen_Traversable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
-                                           , dit_rep_tc_args = tycon_args })
-  = (unitBag traverse_bind, emptyBag)
-  where
-    data_cons = getPossibleDataCons tycon tycon_args
-
-    traverse_name = L (noAnnSrcSpan loc) traverse_RDR
-
-    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
-    traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr)
-                                   traverse_name traverse_eqns
-    traverse_eqns = map traverse_eqn data_cons
-    traverse_eqn con
-      = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
-      where
-        parts = sequence $ foldDataConArgs ft_trav con dit
-    traverse_match_ctxt = mkPrefixFunRhs traverse_name
-
-    -- Yields 'Just' an expression if we're folding over a type that mentions
-    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
-    -- See Note [FFoldType and functorLikeTraverse]
-    ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
-    ft_trav
-      = FT { ft_triv    = return Nothing
-             -- traverse f = pure x
-           , ft_var     = return (Just f_Expr)
-             -- traverse f = f x
-           , ft_tup     = \t gs -> do
-               gg  <- sequence gs
-               lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
-               return (Just lam)
-             -- traverse f = \x -> case x of (a1,a2,..) ->
-             --                           liftA2 (,,) (g1 a1) (g2 a2) <*> ..
-           , ft_ty_app  = \_ _ g -> fmap (nlHsApp traverse_Expr) <$> g
-             -- traverse f = traverse g
-           , ft_forall  = \_ g -> g
-           , ft_co_var  = panic "contravariant in ft_trav"
-           , ft_fun     = panic "function in ft_trav"
-           , ft_bad_app = panic "in other argument in ft_trav" }
-
-    -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
-    --                    (g2 a2) <*> ...
-    match_for_con :: Monad m
-                  => [LPat GhcPs]
-                  -> DataCon
-                  -> [Maybe (LHsExpr GhcPs)]
-                  -> m (LMatch GhcPs (LHsExpr GhcPs))
-    match_for_con = mkSimpleConMatch2 traverse_match_ctxt $
-                                             \con xs -> return (mkApCon con xs)
-      where
-        -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
-        mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
-        mkApCon con [] = nlHsApps pure_RDR [con]
-        mkApCon con [x] = nlHsApps fmap_RDR [con,x]
-        mkApCon con (x1:x2:xs) =
-            foldl' appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs
-          where appAp x y = nlHsApps ap_RDR [x,y]
-
------------------------------------------------------------------------
-
-f_Expr, z_Expr, mempty_Expr, foldMap_Expr,
-    traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr,
-    all_Expr, null_Expr :: LHsExpr GhcPs
-f_Expr        = nlHsVar f_RDR
-z_Expr        = nlHsVar z_RDR
-mempty_Expr   = nlHsVar mempty_RDR
-foldMap_Expr  = nlHsVar foldMap_RDR
-traverse_Expr = nlHsVar traverse_RDR
-coerce_Expr   = nlHsVar (getRdrName coerceId)
-pure_Expr     = nlHsVar pure_RDR
-true_Expr     = nlHsVar true_RDR
-false_Expr    = nlHsVar false_RDR
-all_Expr      = nlHsVar all_RDR
-null_Expr     = nlHsVar null_RDR
-
-f_RDR, z_RDR :: RdrName
-f_RDR = mkVarUnqual (fsLit "f")
-z_RDR = mkVarUnqual (fsLit "z")
-
-as_RDRs, bs_RDRs :: [RdrName]
-as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
-bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
-
-as_Vars, bs_Vars :: [LHsExpr GhcPs]
-as_Vars = map nlHsVar as_RDRs
-bs_Vars = map nlHsVar bs_RDRs
-
-f_Pat, z_Pat :: LPat GhcPs
-f_Pat = nlVarPat f_RDR
-z_Pat = nlVarPat z_RDR
-
-{-
-Note [DeriveFoldable with ExistentialQuantification]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Functor and Traversable instances can only be derived for data types whose
-last type parameter is truly universally polymorphic. For example:
-
-  data T a b where
-    T1 ::                 b   -> T a b   -- YES, b is unconstrained
-    T2 :: Ord b   =>      b   -> T a b   -- NO, b is constrained by (Ord b)
-    T3 :: b ~ Int =>      b   -> T a b   -- NO, b is constrained by (b ~ Int)
-    T4 ::                 Int -> T a Int -- NO, this is just like T3
-    T5 :: Ord a   => a -> b   -> T a b   -- YES, b is unconstrained, even
-                                         -- though a is existential
-    T6 ::                 Int -> T Int b -- YES, b is unconstrained
-
-For Foldable instances, however, we can completely lift the constraint that
-the last type parameter be truly universally polymorphic. This means that T
-(as defined above) can have a derived Foldable instance:
-
-  instance Foldable (T a) where
-    foldr f z (T1 b)   = f b z
-    foldr f z (T2 b)   = f b z
-    foldr f z (T3 b)   = f b z
-    foldr f z (T4 b)   = z
-    foldr f z (T5 a b) = f b z
-    foldr f z (T6 a)   = z
-
-    foldMap f (T1 b)   = f b
-    foldMap f (T2 b)   = f b
-    foldMap f (T3 b)   = f b
-    foldMap f (T4 b)   = mempty
-    foldMap f (T5 a b) = f b
-    foldMap f (T6 a)   = mempty
-
-In a Foldable instance, it is safe to fold over an occurrence of the last type
-parameter that is not truly universally polymorphic. However, there is a bit
-of subtlety in determining what is actually an occurrence of a type parameter.
-T3 and T4, as defined above, provide one example:
-
-  data T a b where
-    ...
-    T3 :: b ~ Int => b   -> T a b
-    T4 ::            Int -> T a Int
-    ...
-
-  instance Foldable (T a) where
-    ...
-    foldr f z (T3 b) = f b z
-    foldr f z (T4 b) = z
-    ...
-    foldMap f (T3 b) = f b
-    foldMap f (T4 b) = mempty
-    ...
-
-Notice that the argument of T3 is folded over, whereas the argument of T4 is
-not. This is because we only fold over constructor arguments that
-syntactically mention the universally quantified type parameter of that
-particular data constructor. See foldDataConArgs for how this is implemented.
-
-As another example, consider the following data type. The argument of each
-constructor has the same type as the last type parameter:
-
-  data E a where
-    E1 :: (a ~ Int) => a   -> E a
-    E2 ::              Int -> E Int
-    E3 :: (a ~ Int) => a   -> E Int
-    E4 :: (a ~ Int) => Int -> E a
-
-Only E1's argument is an occurrence of a universally quantified type variable
-that is syntactically equivalent to the last type parameter, so only E1's
-argument will be folded over in a derived Foldable instance.
-
-See #10447 for the original discussion on this feature. Also see
-https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/derive-functor
-for a more in-depth explanation.
-
-Note [FFoldType and functorLikeTraverse]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Deriving Functor, Foldable, and Traversable all require generating expressions
-which perform an operation on each argument of a data constructor depending
-on the argument's type. In particular, a generated operation can be different
-depending on whether the type mentions the last type variable of the datatype
-(e.g., if you have data T a = MkT a Int, then a generated foldr expression would
-fold over the first argument of MkT, but not the second).
-
-This pattern is abstracted with the FFoldType datatype, which provides hooks
-for the user to specify how a constructor argument should be folded when it
-has a type with a particular "shape". The shapes are as follows (assume that
-a is the last type variable in a given datatype):
-
-* ft_triv:    The type does not mention the last type variable at all.
-              Examples: Int, b
-
-* ft_var:     The type is syntactically equal to the last type variable.
-              Moreover, the type appears in a covariant position (see
-              the Deriving Functor instances section of the user's guide
-              for an in-depth explanation of covariance vs. contravariance).
-              Example: a (covariantly)
-
-* ft_co_var:  The type is syntactically equal to the last type variable.
-              Moreover, the type appears in a contravariant position.
-              Example: a (contravariantly)
-
-* ft_fun:     A function type which mentions the last type variable in
-              the argument position, result position or both.
-              Examples: a -> Int, Int -> a, Maybe a -> [a]
-
-* ft_tup:     A tuple type which mentions the last type variable in at least
-              one of its fields. The TyCon argument of ft_tup represents the
-              particular tuple's type constructor.
-              Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #)
-
-* ft_ty_app:  A type is being applied to the last type parameter, where the
-              applied type does not mention the last type parameter (if it
-              did, it would fall under ft_bad_app) and the argument type
-              mentions the last type parameter (if it did not, it would fall
-              under ft_triv). The first two Type arguments to
-              ft_ty_app represent the applied type and argument type,
-              respectively.
-
-              Currently, only DeriveFunctor makes use of the argument type.
-              It inspects the argument type so that it can generate more
-              efficient implementations of fmap
-              (see Note [Avoid unnecessary eta expansion in derived fmap implementations])
-              and (<$) (see Note [Deriving <$]) in certain cases.
-
-              Note that functions, tuples, and foralls are distinct cases
-              and take precedence over ft_ty_app. (For example, (Int -> a) would
-              fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).
-              Examples: Maybe a, Either b a
-
-* ft_bad_app: A type application uses the last type parameter in a position
-              other than the last argument. This case is singled out because
-              Functor, Foldable, and Traversable instances cannot be derived
-              for datatypes containing arguments with such types.
-              Examples: Either a Int, Const a b
-
-* ft_forall:  A forall'd type mentions the last type parameter on its right-
-              hand side (and is not quantified on the left-hand side). This
-              case is present mostly for plumbing purposes.
-              Example: forall b. Either b a
-
-If FFoldType describes a strategy for folding subcomponents of a Type, then
-functorLikeTraverse is the function that applies that strategy to the entirety
-of a Type, returning the final folded-up result.
-
-foldDataConArgs applies functorLikeTraverse to every argument type of a
-constructor, returning a list of the fold results. This makes foldDataConArgs
-a natural way to generate the subexpressions in a generated fmap, foldr,
-foldMap, or traverse definition (the subexpressions must then be combined in
-a method-specific fashion to form the final generated expression).
-
-Deriving Generic1 also does validity checking by looking for the last type
-variable in certain positions of a constructor's argument types, so it also
-uses foldDataConArgs. See Note [degenerate use of FFoldType] in GHC.Tc.Deriv.Generics.
-
-Note [Generated code for DeriveFoldable and DeriveTraversable]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on
-that of -XDeriveFunctor. However, there an important difference between deriving
-the former two typeclasses and the latter one, which is best illustrated by the
-following scenario:
-
-  data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable)
-
-The generated code for the Functor instance is straightforward:
-
-  instance Functor WithInt where
-    fmap f (WithInt a i) = WithInt (f a) i
-
-But if we use too similar of a strategy for deriving the Foldable and
-Traversable instances, we end up with this code:
-
-  instance Foldable WithInt where
-    foldMap f (WithInt a i) = f a <> mempty
-
-  instance Traversable WithInt where
-    traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i
-
-This is unsatisfying for two reasons:
-
-1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure
-   expects an argument whose type is of kind *. This effectively prevents
-   Traversable from being derived for any datatype with an unlifted argument
-   type (#11174).
-
-2. The generated code contains superfluous expressions. By the Monoid laws,
-   we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can
-   reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)).
-
-We can fix both of these issues by incorporating a slight twist to the usual
-algorithm that we use for -XDeriveFunctor. The differences can be summarized
-as follows:
-
-1. In the generated expression, we only fold over arguments whose types
-   mention the last type parameter. Any other argument types will simply
-   produce useless 'mempty's or 'pure's, so they can be safely ignored.
-
-2. In the case of -XDeriveTraversable, instead of applying ConName,
-   we apply (\b_i ... b_k -> ConName a_1 ... a_n), where
-
-   * ConName has n arguments
-   * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond
-     to the arguments whose types mention the last type parameter. As a
-     consequence, taking the difference of {a_1, ..., a_n} and
-     {b_i, ..., b_k} yields the all the argument values of ConName whose types
-     do not mention the last type parameter. Note that [i, ..., k] is a
-     strictly increasing—but not necessarily consecutive—integer sequence.
-
-     For example, the datatype
-
-       data Foo a = Foo Int a Int a
-
-     would generate the following Traversable instance:
-
-       instance Traversable Foo where
-         traverse f (Foo a1 a2 a3 a4) =
-           fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4
-
-Technically, this approach would also work for -XDeriveFunctor as well, but we
-decide not to do so because:
-
-1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a))
-   instead of (WithInt (f a) i).
-
-2. There would be certain datatypes for which the above strategy would
-   generate Functor code that would fail to typecheck. For example:
-
-     data Bar f a = Bar (forall f. Functor f => f a) deriving Functor
-
-   With the conventional algorithm, it would generate something like:
-
-     fmap f (Bar a) = Bar (fmap f a)
-
-   which typechecks. But with the strategy mentioned above, it would generate:
-
-     fmap f (Bar a) = (\b -> Bar b) (fmap f a)
-
-   which does not typecheck, since GHC cannot unify the rank-2 type variables
-   in the types of b and (fmap f a).
-
-Note [Phantom types with Functor, Foldable, and Traversable]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Given a type F :: * -> * whose type argument has a phantom role, we can always
-produce lawful Functor and Traversable instances using
-
-    fmap _ = coerce
-    traverse _ = pure . coerce
-
-Indeed, these are equivalent to any *strictly lawful* instances one could
-write, except that this definition of 'traverse' may be lazier.  That is, if
-instances obey the laws under true equality (rather than up to some equivalence
-relation), then they will be essentially equivalent to these. These definitions
-are incredibly cheap, so we want to use them even if it means ignoring some
-non-strictly-lawful instance in an embedded type.
-
-Foldable has far fewer laws to work with, which leaves us unwelcome
-freedom in implementing it. At a minimum, we would like to ensure that
-a derived foldMap is always at least as good as foldMapDefault with a
-derived traverse. To accomplish that, we must define
-
-   foldMap _ _ = mempty
-
-in these cases.
-
-This may have different strictness properties from a standard derivation.
-Consider
-
-   data NotAList a = Nil | Cons (NotAList a) deriving Foldable
-
-The usual deriving mechanism would produce
-
-   foldMap _ Nil = mempty
-   foldMap f (Cons x) = foldMap f x
-
-which is strict in the entire spine of the NotAList.
-
-Final point: why do we even care about such types? Users will rarely if ever
-map, fold, or traverse over such things themselves, but other derived
-instances may:
-
-   data Hasn'tAList a = NotHere a (NotAList a) deriving Foldable
-
-Note [EmptyDataDecls with Functor, Foldable, and Traversable]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-There are some slightly tricky decisions to make about how to handle
-Functor, Foldable, and Traversable instances for types with no constructors.
-For fmap, the two basic options are
-
-   fmap _ _ = error "Sorry, no constructors"
-
-or
-
-   fmap _ z = case z of
-
-In most cases, the latter is more helpful: if the thunk passed to fmap
-throws an exception, we're generally going to be much more interested in
-that exception than in the fact that there aren't any constructors.
-
-In order to match the semantics for phantoms (see note above), we need to
-be a bit careful about 'traverse'. The obvious definition would be
-
-   traverse _ z = case z of
-
-but this is stricter than the one for phantoms. We instead use
-
-   traverse _ z = pure $ case z of
-
-For foldMap, the obvious choices are
-
-   foldMap _ _ = mempty
-
-or
-
-   foldMap _ z = case z of
-
-We choose the first one to be consistent with what foldMapDefault does for
-a derived Traversable instance.
--}
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ /dev/null
@@ -1,3148 +0,0 @@
-{-
-    %
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DataKinds #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
--- | Generating derived instance declarations
---
--- This module is nominally ``subordinate'' to "GHC.Tc.Deriv", which is the
--- ``official'' interface to deriving-related things.
---
--- This is where we do all the grimy bindings' generation.
-module GHC.Tc.Deriv.Generate (
-        AuxBindSpec(..),
-
-        gen_Eq_binds,
-        gen_Ord_binds,
-        gen_Enum_binds,
-        gen_Bounded_binds,
-        gen_Ix_binds,
-        gen_Show_binds,
-        gen_Read_binds,
-        gen_Data_binds,
-        gen_Lift_binds,
-        gen_Newtype_binds,
-        gen_Newtype_fam_insts,
-        mkCoerceClassMethEqn,
-        genAuxBinds,
-        ordOpTbl, boxConTbl, litConTbl,
-        mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr,
-
-        getPossibleDataCons,
-        DerivInstTys(..), buildDataConInstArgEnv,
-        derivDataConInstArgTys, substDerivInstTys, zonkDerivInstTys
-    ) where
-
-import GHC.Prelude
-
-import GHC.Tc.Utils.Monad
-import GHC.Hs
-import GHC.Types.FieldLabel
-import GHC.Types.Name.Reader
-import GHC.Types.Basic
-import GHC.Types.Fixity
-import GHC.Core.DataCon
-import GHC.Types.Name
-import GHC.Types.SourceText
-
-import GHC.Tc.Instance.Family
-import GHC.Core.FamInstEnv
-import GHC.Builtin.Names
-import GHC.Builtin.Names.TH
-import GHC.Types.Id.Make ( coerceId )
-import GHC.Builtin.PrimOps
-import GHC.Builtin.PrimOps.Ids (primOpId)
-import GHC.Types.SrcLoc
-import GHC.Core.TyCon
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.Zonk
-import GHC.Tc.Validity ( checkValidCoAxBranch )
-import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch )
-import GHC.Builtin.Types.Prim
-import GHC.Builtin.Types
-import GHC.Core.Type
-import GHC.Core.Class
-
-import GHC.Types.Unique.FM ( lookupUFM, listToUFM )
-import GHC.Types.Var.Env
-import GHC.Utils.Misc
-import GHC.Types.Var
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Lexeme
-import GHC.Data.FastString
-import GHC.Data.Pair
-import GHC.Data.Bag
-
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-import Data.List  ( find, partition, intersperse )
-import GHC.Data.Maybe ( expectJust )
-import GHC.Unit.Module
-
--- | A declarative description of an auxiliary binding that should be
--- generated. See @Note [Auxiliary binders]@ for a more detailed description
--- of how these are used.
-data AuxBindSpec
-  -- DerivTag2Con, and DerivMaxTag are used in derived Eq, Ord,
-  -- Enum, and Ix instances.
-  -- All these generate ZERO-BASED tag operations
-  -- I.e first constructor has tag 0
-
-    -- | @$tag2con@: Given a tag, computes the corresponding data constructor
-  = DerivTag2Con
-      TyCon   -- The type constructor of the data type to which the
-              -- constructors belong
-      RdrName -- The to-be-generated $tag2con binding's RdrName
-
-    -- | @$maxtag@: The maximum possible tag value among a data type's
-    -- constructors
-  | DerivMaxTag
-      TyCon   -- The type constructor of the data type to which the
-              -- constructors belong
-      RdrName -- The to-be-generated $maxtag binding's RdrName
-
-  -- DerivDataDataType and DerivDataConstr are only used in derived Data
-  -- instances
-
-    -- | @$t@: The @DataType@ representation for a @Data@ instance
-  | DerivDataDataType
-      TyCon     -- The type constructor of the data type to be represented
-      RdrName   -- The to-be-generated $t binding's RdrName
-      [RdrName] -- The RdrNames of the to-be-generated $c bindings for each
-                -- data constructor. These are only used on the RHS of the
-                -- to-be-generated $t binding.
-
-    -- | @$c@: The @Constr@ representation for a @Data@ instance
-  | DerivDataConstr
-      DataCon -- The data constructor to be represented
-      RdrName -- The to-be-generated $c binding's RdrName
-      RdrName -- The RdrName of the to-be-generated $t binding for the parent
-              -- data type. This is only used on the RHS of the
-              -- to-be-generated $c binding.
-
--- | Retrieve the 'RdrName' of the binding that the supplied 'AuxBindSpec'
--- describes.
-auxBindSpecRdrName :: AuxBindSpec -> RdrName
-auxBindSpecRdrName (DerivTag2Con      _ tag2con_RDR) = tag2con_RDR
-auxBindSpecRdrName (DerivMaxTag       _ maxtag_RDR)  = maxtag_RDR
-auxBindSpecRdrName (DerivDataDataType _ dataT_RDR _) = dataT_RDR
-auxBindSpecRdrName (DerivDataConstr   _ dataC_RDR _) = dataC_RDR
-
-{-
-************************************************************************
-*                                                                      *
-                Eq instances
-*                                                                      *
-************************************************************************
-
-Here are the heuristics for the code we generate for @Eq@. Let's
-assume we have a data type with some (possibly zero) nullary data
-constructors and some ordinary, non-nullary ones (the rest, also
-possibly zero of them).  Here's an example, with both \tr{N}ullary and
-\tr{O}rdinary data cons.
-
-  data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
-
-* We first attempt to compare the constructor tags. If tags don't
-  match - we immediately bail out. Otherwise, we then generate one
-  branch per constructor comparing only the fields as we already
-  know that the tags match. Note that it only makes sense to check
-  the tag if there is more than one data constructor.
-
-* For the ordinary constructors (if any), we emit clauses to do The
-  Usual Thing, e.g.,:
-
-    (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
-    (==) (O2 a1)       (O2 a2)       = a1 == a2
-    (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
-
-  Note: if we're comparing unlifted things, e.g., if 'a1' and
-  'a2' are Float#s, then we have to generate
-       case (a1 `eqFloat#` a2) of r -> r
-  for that particular test.
-
-* For nullary constructors, we emit a catch-all clause that always
-  returns True since we already know that the tags match.
-
-* So, given this data type:
-
-    data T = A | B Int | C Char
-
-  We roughly get:
-
-    (==) a b =
-      case dataToTag# a /= dataToTag# b of
-        True -> False
-        False -> case a of       -- Here we already know that tags match
-            B a1 -> case b of
-                B b1 -> a1 == b1 -- Only one branch
-            C a1 -> case b of
-                C b1 -> a1 == b1 -- Only one branch
-            _ -> True            -- catch-all to match all nullary ctors
-
-  An older approach preferred regular pattern matches in some cases
-  but with dataToTag# forcing it's argument, and work on improving
-  join points, this seems no longer necessary.
-
-* For the @(/=)@ method, we normally just use the default method.
-  If the type is an enumeration type, we could/may/should? generate
-  special code that calls @dataToTag#@, much like for @(==)@ shown
-  above.
-
-We thought about doing this: If we're also deriving 'Ord' for this
-tycon, we generate:
-  instance ... Eq (Foo ...) where
-    (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
-    (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
-However, that requires that (Ord <whatever>) was put in the context
-for the instance decl, which it probably wasn't, so the decls
-produced don't get through the typechecker.
--}
-
-gen_Eq_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
-gen_Eq_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
-                                  , dit_rep_tc_args = tycon_args }) = do
-    return (method_binds, emptyBag)
-  where
-    all_cons = getPossibleDataCons tycon tycon_args
-    non_nullary_cons = filter (not . isNullarySrcDataCon) all_cons
-
-    -- Generate tag check. See #17240
-    eq_expr_with_tag_check = nlHsCase
-      (nlHsPar (untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
-                    (nlHsOpApp (nlHsVar ah_RDR) neInt_RDR (nlHsVar bh_RDR))))
-      [ mkHsCaseAlt (nlLitPat (HsIntPrim NoSourceText 1)) false_Expr
-      , mkHsCaseAlt nlWildPat (
-          nlHsCase
-            (nlHsVar a_RDR)
-            -- Only one branch to match all nullary constructors
-            -- as we already know the tags match but do not emit
-            -- the branch if there are no nullary constructors
-            (let non_nullary_pats = map pats_etc non_nullary_cons
-             in if null non_nullary_cons
-                then non_nullary_pats
-                else non_nullary_pats ++ [mkHsCaseAlt nlWildPat true_Expr]))
-      ]
-
-    method_binds = unitBag eq_bind
-    eq_bind = mkFunBindEC 2 loc eq_RDR (const true_Expr) binds
-      where
-        binds
-          | null all_cons = []
-          -- Tag checking is redundant when there is only one data constructor
-          | [data_con] <- all_cons
-          , (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con
-          , data_con_RDR <- getRdrName data_con
-          , con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed
-          , con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed
-          , eq_expr <- nested_eq_expr tys_needed as_needed bs_needed
-          = [([con1_pat, con2_pat], eq_expr)]
-          -- This is an enum (all constructors are nullary) - just do a simple tag check
-          | all isNullarySrcDataCon all_cons
-          = [([a_Pat, b_Pat], untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
-                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
-          | otherwise
-          = [([a_Pat, b_Pat], eq_expr_with_tag_check)]
-
-    ------------------------------------------------------------------
-    nested_eq_expr []  [] [] = true_Expr
-    nested_eq_expr tys as bs
-      = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
-      -- Using 'foldr1' here ensures that the derived code is correctly
-      -- associated. See #10859.
-      where
-        nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b))
-
-    gen_con_fields_and_tys data_con
-      | tys_needed <- derivDataConInstArgTys data_con dit
-      , con_arity <- length tys_needed
-      , as_needed <- take con_arity as_RDRs
-      , bs_needed <- take con_arity bs_RDRs
-      = (as_needed, bs_needed, tys_needed)
-
-    pats_etc data_con
-      | (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con
-      , data_con_RDR <- getRdrName data_con
-      , con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed
-      , con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed
-      , fields_eq_expr <- nested_eq_expr tys_needed as_needed bs_needed
-      = mkHsCaseAlt con1_pat (nlHsCase (nlHsVar b_RDR) [mkHsCaseAlt con2_pat fields_eq_expr])
-
-{-
-************************************************************************
-*                                                                      *
-        Ord instances
-*                                                                      *
-************************************************************************
-
-Note [Generating Ord instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose constructors are K1..Kn, and some are nullary.
-The general form we generate is:
-
-* Do case on first argument
-        case a of
-          K1 ... -> rhs_1
-          K2 ... -> rhs_2
-          ...
-          Kn ... -> rhs_n
-          _ -> nullary_rhs
-
-* To make rhs_i
-     If i = 1, 2, n-1, n, generate a single case.
-        rhs_2    case b of
-                   K1 {}  -> LT
-                   K2 ... -> ...eq_rhs(K2)...
-                   _      -> GT
-
-     Otherwise do a tag compare against the bigger range
-     (because this is the one most likely to succeed)
-        rhs_3    case tag b of tb ->
-                 if 3 <# tg then GT
-                 else case b of
-                         K3 ... -> ...eq_rhs(K3)....
-                         _      -> LT
-
-* To make eq_rhs(K), which knows that
-    a = K a1 .. av
-    b = K b1 .. bv
-  we just want to compare (a1,b1) then (a2,b2) etc.
-  Take care on the last field to tail-call into comparing av,bv
-
-* To make nullary_rhs generate this
-     case dataToTag# a of a# ->
-     case dataToTag# b of ->
-     a# `compare` b#
-
-Several special cases:
-
-* Two or fewer nullary constructors: don't generate nullary_rhs
-
-* Be careful about unlifted comparisons.  When comparing unboxed
-  values we can't call the overloaded functions.
-  See function unliftedOrdOp
-
-Note [Game plan for deriving Ord]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's a bad idea to define only 'compare', and build the other binary
-comparisons on top of it; see #2130, #4019.  Reason: we don't
-want to laboriously make a three-way comparison, only to extract a
-binary result, something like this:
-     (>) (I# x) (I# y) = case <# x y of
-                            True -> False
-                            False -> case ==# x y of
-                                       True  -> False
-                                       False -> True
-
-This being said, we can get away with generating full code only for
-'compare' and '<' thus saving us generation of other three operators.
-Other operators can be cheaply expressed through '<':
-a <= b = not $ b < a
-a > b = b < a
-a >= b = not $ a < b
-
-So for sufficiently small types (few constructors, or all nullary)
-we generate all methods; for large ones we just use 'compare'.
-
--}
-
-data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
-
-------------
-ordMethRdr :: OrdOp -> RdrName
-ordMethRdr op
-  = case op of
-       OrdCompare -> compare_RDR
-       OrdLT      -> lt_RDR
-       OrdLE      -> le_RDR
-       OrdGE      -> ge_RDR
-       OrdGT      -> gt_RDR
-
-------------
-ltResult :: OrdOp -> LHsExpr GhcPs
--- Knowing a<b, what is the result for a `op` b?
-ltResult OrdCompare = ltTag_Expr
-ltResult OrdLT      = true_Expr
-ltResult OrdLE      = true_Expr
-ltResult OrdGE      = false_Expr
-ltResult OrdGT      = false_Expr
-
-------------
-eqResult :: OrdOp -> LHsExpr GhcPs
--- Knowing a=b, what is the result for a `op` b?
-eqResult OrdCompare = eqTag_Expr
-eqResult OrdLT      = false_Expr
-eqResult OrdLE      = true_Expr
-eqResult OrdGE      = true_Expr
-eqResult OrdGT      = false_Expr
-
-------------
-gtResult :: OrdOp -> LHsExpr GhcPs
--- Knowing a>b, what is the result for a `op` b?
-gtResult OrdCompare = gtTag_Expr
-gtResult OrdLT      = false_Expr
-gtResult OrdLE      = false_Expr
-gtResult OrdGE      = true_Expr
-gtResult OrdGT      = true_Expr
-
-------------
-gen_Ord_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
-gen_Ord_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
-                                   , dit_rep_tc_args = tycon_args }) = do
-    return $ if null tycon_data_cons -- No data-cons => invoke bale-out case
-      then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []
-           , emptyBag)
-      else ( unitBag (mkOrdOp OrdCompare)
-             `unionBags` other_ops
-           , aux_binds)
-  where
-    aux_binds = emptyBag
-
-        -- Note [Game plan for deriving Ord]
-    other_ops
-      | (last_tag - first_tag) <= 2     -- 1-3 constructors
-        || null non_nullary_cons        -- Or it's an enumeration
-      = listToBag [mkOrdOp OrdLT, lE, gT, gE]
-      | otherwise
-      = emptyBag
-
-    negate_expr = nlHsApp (nlHsVar not_RDR)
-    lE = mkSimpleGeneratedFunBind loc le_RDR [a_Pat, b_Pat] $
-        negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)
-    gT = mkSimpleGeneratedFunBind loc gt_RDR [a_Pat, b_Pat] $
-        nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr
-    gE = mkSimpleGeneratedFunBind loc ge_RDR [a_Pat, b_Pat] $
-        negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr)
-
-    get_tag con = dataConTag con - fIRST_TAG
-        -- We want *zero-based* tags, because that's what
-        -- con2Tag returns (generated by untag_Expr)!
-
-    tycon_data_cons = getPossibleDataCons tycon tycon_args
-    single_con_type = isSingleton tycon_data_cons
-    (first_con : _) = tycon_data_cons
-    (last_con : _)  = reverse tycon_data_cons
-    first_tag       = get_tag first_con
-    last_tag        = get_tag last_con
-
-    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
-
-
-    mkOrdOp :: OrdOp -> LHsBind GhcPs
-    -- Returns a binding   op a b = ... compares a and b according to op ....
-    mkOrdOp op
-      = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat]
-                        (mkOrdOpRhs op)
-
-    mkOrdOpRhs :: OrdOp -> LHsExpr GhcPs
-    mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op
-      | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases
-      = nlHsCase (nlHsVar a_RDR) $
-        map (mkOrdOpAlt op) tycon_data_cons
-        -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
-        --                   C2 x   -> case b of C2 x -> ....compare x.... }
-
-      | null non_nullary_cons    -- All nullary, so go straight to comparing tags
-      = mkTagCmp op
-
-      | otherwise                -- Mixed nullary and non-nullary
-      = nlHsCase (nlHsVar a_RDR) $
-        (map (mkOrdOpAlt op) non_nullary_cons
-         ++ [mkHsCaseAlt nlWildPat (mkTagCmp op)])
-
-
-    mkOrdOpAlt :: OrdOp -> DataCon
-               -> LMatch GhcPs (LHsExpr GhcPs)
-    -- Make the alternative  (Ki a1 a2 .. av ->
-    mkOrdOpAlt op data_con
-      = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
-                    (mkInnerRhs op data_con)
-      where
-        as_needed    = take (dataConSourceArity data_con) as_RDRs
-        data_con_RDR = getRdrName data_con
-
-    mkInnerRhs op data_con
-      | single_con_type
-      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]
-
-      | tag == first_tag
-      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
-                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
-      | tag == last_tag
-      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
-                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
-
-      | tag == first_tag + 1
-      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)
-                                             (gtResult op)
-                                 , mkInnerEqAlt op data_con
-                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
-      | tag == last_tag - 1
-      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)
-                                             (ltResult op)
-                                 , mkInnerEqAlt op data_con
-                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
-
-      | tag > last_tag `div` 2  -- lower range is larger
-      = untag_Expr [(b_RDR, bh_RDR)] $
-        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
-               (gtResult op) $  -- Definitely GT
-        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
-                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
-
-      | otherwise               -- upper range is larger
-      = untag_Expr [(b_RDR, bh_RDR)] $
-        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
-               (ltResult op) $  -- Definitely LT
-        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
-                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
-      where
-        tag     = get_tag data_con
-        tag_lit
-             = noLocA (HsLit noComments (HsIntPrim NoSourceText (toInteger tag)))
-
-    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
-    -- First argument 'a' known to be built with K
-    -- Returns a case alternative  Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
-    mkInnerEqAlt op data_con
-      = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
-        mkCompareFields op (derivDataConInstArgTys data_con dit)
-      where
-        data_con_RDR = getRdrName data_con
-        bs_needed    = take (dataConSourceArity data_con) bs_RDRs
-
-    mkTagCmp :: OrdOp -> LHsExpr GhcPs
-    -- Both constructors known to be nullary
-    -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
-    mkTagCmp op =
-      untag_Expr [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
-        unliftedOrdOp intPrimTy op ah_RDR bh_RDR
-
-mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs
--- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
--- where the ai,bi have the given types
-mkCompareFields op tys
-  = go tys as_RDRs bs_RDRs
-  where
-    go []   _      _          = eqResult op
-    go [ty] (a:_)  (b:_)
-      | isUnliftedType ty     = unliftedOrdOp ty op a b
-      | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
-    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
-                                  (ltResult op)
-                                  (go tys as bs)
-                                  (gtResult op)
-    go _ _ _ = panic "mkCompareFields"
-
-    -- (mk_compare ty a b) generates
-    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
-    -- but with suitable special cases for
-    mk_compare ty a b lt eq gt
-      | isUnliftedType ty
-      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
-      | otherwise
-      = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
-          [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,
-           mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,
-           mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]
-      where
-        a_expr = nlHsVar a
-        b_expr = nlHsVar b
-        (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty
-
-unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
-unliftedOrdOp ty op a b
-  = case op of
-       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
-                                     ltTag_Expr eqTag_Expr gtTag_Expr
-       OrdLT      -> wrap lt_op
-       OrdLE      -> wrap le_op
-       OrdGE      -> wrap ge_op
-       OrdGT      -> wrap gt_op
-  where
-   (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty
-   wrap prim_op = genPrimOpApp a_expr prim_op b_expr
-   a_expr = nlHsVar a
-   b_expr = nlHsVar b
-
-unliftedCompare :: RdrName -> RdrName
-                -> LHsExpr GhcPs -> LHsExpr GhcPs   -- What to compare
-                -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-                                                    -- Three results
-                -> LHsExpr GhcPs
--- Return (if a < b then lt else if a == b then eq else gt)
-unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
-  = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $
-                        -- Test (<) first, not (==), because the latter
-                        -- is true less often, so putting it first would
-                        -- mean more tests (dynamically)
-        nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt
-  where
-    ascribeBool e = noLocA $ ExprWithTySig noAnn e
-                           $ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType
-                           $ nlHsTyVar NotPromoted boolTyCon_RDR
-
-nlConWildPat :: DataCon -> LPat GhcPs
--- The pattern (K {})
-nlConWildPat con = noLocA $ ConPat
-  { pat_con_ext = noAnn
-  , pat_con = noLocA $ getRdrName con
-  , pat_args = RecCon $ HsRecFields
-      { rec_flds = []
-      , rec_dotdot = Nothing }
-  }
-
-{-
-************************************************************************
-*                                                                      *
-        Enum instances
-*                                                                      *
-************************************************************************
-
-@Enum@ can only be derived for enumeration types.  For a type
-\begin{verbatim}
-data Foo ... = N1 | N2 | ... | Nn
-\end{verbatim}
-
-we use both dataToTag# and @tag2con_Foo@ functions, as well as a
-@maxtag_Foo@ variable, the later generated by @gen_tag_n_con_binds.
-
-\begin{verbatim}
-instance ... Enum (Foo ...) where
-    succ x   = toEnum (1 + fromEnum x)
-    pred x   = toEnum (fromEnum x - 1)
-
-    toEnum i = tag2con_Foo i
-
-    enumFrom a = map tag2con_Foo [dataToTag# a .. maxtag_Foo]
-
-    -- or, really...
-    enumFrom a
-      = case dataToTag# a of
-          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
-
-   enumFromThen a b
-     = map tag2con_Foo [dataToTag# a, dataToTag# b .. maxtag_Foo]
-
-    -- or, really...
-    enumFromThen a b
-      = case dataToTag# a of { a# ->
-        case dataToTag# b of { b# ->
-        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
-        }}
-\end{verbatim}
-
-For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
--}
-
-gen_Enum_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
-gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do
-    -- See Note [Auxiliary binders]
-    tag2con_RDR <- new_tag2con_rdr_name loc tycon
-    maxtag_RDR  <- new_maxtag_rdr_name  loc tycon
-
-    return ( method_binds tag2con_RDR maxtag_RDR
-           , aux_binds    tag2con_RDR maxtag_RDR )
-  where
-    method_binds tag2con_RDR maxtag_RDR = listToBag
-      [ succ_enum      tag2con_RDR maxtag_RDR
-      , pred_enum      tag2con_RDR
-      , to_enum        tag2con_RDR maxtag_RDR
-      , enum_from      tag2con_RDR maxtag_RDR -- [0 ..]
-      , enum_from_then tag2con_RDR maxtag_RDR -- [0, 1 ..]
-      , from_enum
-      ]
-    aux_binds tag2con_RDR maxtag_RDR = listToBag
-      [ DerivTag2Con tycon tag2con_RDR
-      , DerivMaxTag  tycon maxtag_RDR
-      ]
-
-    occ_nm = getOccString tycon
-
-    succ_enum tag2con_RDR maxtag_RDR
-      = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $
-        untag_Expr [(a_RDR, ah_RDR)] $
-        nlHsIf (nlHsApps eq_RDR [nlHsVar maxtag_RDR,
-                               nlHsVarApps intDataCon_RDR [ah_RDR]])
-             (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
-             (nlHsApp (nlHsVar tag2con_RDR)
-                    (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
-                                        nlHsIntLit 1]))
-
-    pred_enum tag2con_RDR
-      = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $
-        untag_Expr [(a_RDR, ah_RDR)] $
-        nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
-                               nlHsVarApps intDataCon_RDR [ah_RDR]])
-             (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
-             (nlHsApp (nlHsVar tag2con_RDR)
-                      (nlHsApps plus_RDR
-                            [ nlHsVarApps intDataCon_RDR [ah_RDR]
-                            , nlHsLit (HsInt noExtField
-                                                (mkIntegralLit (-1 :: Int)))]))
-
-    to_enum tag2con_RDR maxtag_RDR
-      = mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $
-        nlHsIf (nlHsApps and_RDR
-                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
-                 nlHsApps le_RDR [ nlHsVar a_RDR
-                                 , nlHsVar maxtag_RDR]])
-             (nlHsVarApps tag2con_RDR [a_RDR])
-             (illegal_toEnum_tag occ_nm maxtag_RDR)
-
-    enum_from tag2con_RDR maxtag_RDR
-      = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $
-          untag_Expr [(a_RDR, ah_RDR)] $
-          nlHsApps map_RDR
-                [nlHsVar tag2con_RDR,
-                 nlHsPar (enum_from_to_Expr
-                            (nlHsVarApps intDataCon_RDR [ah_RDR])
-                            (nlHsVar maxtag_RDR))]
-
-    enum_from_then tag2con_RDR maxtag_RDR
-      = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
-          untag_Expr [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
-          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $
-            nlHsPar (enum_from_then_to_Expr
-                    (nlHsVarApps intDataCon_RDR [ah_RDR])
-                    (nlHsVarApps intDataCon_RDR [bh_RDR])
-                    (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
-                                               nlHsVarApps intDataCon_RDR [bh_RDR]])
-                           (nlHsIntLit 0)
-                           (nlHsVar maxtag_RDR)
-                           ))
-
-    from_enum
-      = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $
-          untag_Expr [(a_RDR, ah_RDR)] $
-          (nlHsVarApps intDataCon_RDR [ah_RDR])
-
-{-
-************************************************************************
-*                                                                      *
-        Bounded instances
-*                                                                      *
-************************************************************************
--}
-
-gen_Bounded_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
-gen_Bounded_binds loc (DerivInstTys{dit_rep_tc = tycon})
-  | isEnumerationTyCon tycon
-  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
-  | otherwise
-  = assert (isSingleton data_cons)
-    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
-  where
-    data_cons = tyConDataCons tycon
-
-    ----- enum-flavored: ---------------------------
-    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
-    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
-
-    data_con_1     = head data_cons
-    data_con_N     = last data_cons
-    data_con_1_RDR = getRdrName data_con_1
-    data_con_N_RDR = getRdrName data_con_N
-
-    ----- single-constructor-flavored: -------------
-    arity          = dataConSourceArity data_con_1
-
-    min_bound_1con = mkHsVarBind loc minBound_RDR $
-                     nlHsVarApps data_con_1_RDR (replicate arity minBound_RDR)
-    max_bound_1con = mkHsVarBind loc maxBound_RDR $
-                     nlHsVarApps data_con_1_RDR (replicate arity maxBound_RDR)
-
-{-
-************************************************************************
-*                                                                      *
-        Ix instances
-*                                                                      *
-************************************************************************
-
-Deriving @Ix@ is only possible for enumeration types and
-single-constructor types.  We deal with them in turn.
-
-For an enumeration type, e.g.,
-\begin{verbatim}
-    data Foo ... = N1 | N2 | ... | Nn
-\end{verbatim}
-things go not too differently from @Enum@:
-\begin{verbatim}
-instance ... Ix (Foo ...) where
-    range (a, b)
-      = map tag2con_Foo [dataToTag# a .. dataToTag# b]
-
-    -- or, really...
-    range (a, b)
-      = case (dataToTag# a) of { a# ->
-        case (dataToTag# b) of { b# ->
-        map tag2con_Foo (enumFromTo (I# a#) (I# b#))
-        }}
-
-    -- Generate code for unsafeIndex, because using index leads
-    -- to lots of redundant range tests
-    unsafeIndex c@(a, b) d
-      = case (dataToTag# d -# dataToTag# a) of
-               r# -> I# r#
-
-    inRange (a, b) c
-      = let
-            p_tag = dataToTag# c
-        in
-        p_tag >= dataToTag# a && p_tag <= dataToTag# b
-
-    -- or, really...
-    inRange (a, b) c
-      = case (dataToTag# a)   of { a_tag ->
-        case (dataToTag# b)   of { b_tag ->
-        case (dataToTag# c)   of { c_tag ->
-        if (c_tag >=# a_tag) then
-          c_tag <=# b_tag
-        else
-          False
-        }}}
-\end{verbatim}
-(modulo suitable case-ification to handle the unlifted tags)
-
-For a single-constructor type (NB: this includes all tuples), e.g.,
-\begin{verbatim}
-    data Foo ... = MkFoo a b Int Double c c
-\end{verbatim}
-we follow the scheme given in Figure~19 of the Haskell~1.2 report
-(p.~147).
--}
-
-gen_Ix_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
-
-gen_Ix_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do
-    -- See Note [Auxiliary binders]
-    tag2con_RDR <- new_tag2con_rdr_name loc tycon
-
-    return $ if isEnumerationTyCon tycon
-      then (enum_ixes tag2con_RDR, listToBag
-                   [ DerivTag2Con tycon tag2con_RDR
-                   ])
-      else (single_con_ixes, emptyBag)
-  where
-    --------------------------------------------------------------
-    enum_ixes tag2con_RDR = listToBag
-      [ enum_range   tag2con_RDR
-      , enum_index
-      , enum_inRange
-      ]
-
-    enum_range tag2con_RDR
-      = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
-          untag_Expr [(a_RDR, ah_RDR)] $
-          untag_Expr [(b_RDR, bh_RDR)] $
-          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $
-              nlHsPar (enum_from_to_Expr
-                        (nlHsVarApps intDataCon_RDR [ah_RDR])
-                        (nlHsVarApps intDataCon_RDR [bh_RDR]))
-
-    enum_index
-      = mkSimpleGeneratedFunBind loc unsafeIndex_RDR
-                [noLocA (AsPat noAnn (noLocA c_RDR) noHsTok
-                           (nlTuplePat [a_Pat, nlWildPat] Boxed)),
-                                d_Pat] (
-           untag_Expr [(a_RDR, ah_RDR)] (
-           untag_Expr [(d_RDR, dh_RDR)] (
-           let
-                rhs = nlHsVarApps intDataCon_RDR [c_RDR]
-           in
-           nlHsCase
-             (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
-             [mkHsCaseAlt (nlVarPat c_RDR) rhs]
-           ))
-        )
-
-    -- This produces something like `(ch >= ah) && (ch <= bh)`
-    enum_inRange
-      = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
-          untag_Expr [(a_RDR, ah_RDR)] (
-          untag_Expr [(b_RDR, bh_RDR)] (
-          untag_Expr [(c_RDR, ch_RDR)] (
-          -- This used to use `if`, which interacts badly with RebindableSyntax.
-          -- See #11396.
-          nlHsApps and_RDR
-              [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)
-              , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)
-              ]
-          )))
-
-    --------------------------------------------------------------
-    single_con_ixes
-      = listToBag [single_con_range, single_con_index, single_con_inRange]
-
-    data_con
-      = case tyConSingleDataCon_maybe tycon of -- just checking...
-          Nothing -> panic "get_Ix_binds"
-          Just dc -> dc
-
-    con_arity    = dataConSourceArity data_con
-    data_con_RDR = getRdrName data_con
-
-    as_needed = take con_arity as_RDRs
-    bs_needed = take con_arity bs_RDRs
-    cs_needed = take con_arity cs_RDRs
-
-    con_pat  xs  = nlConVarPat data_con_RDR xs
-    con_expr     = nlHsVarApps data_con_RDR cs_needed
-
-    --------------------------------------------------------------
-    single_con_range
-      = mkSimpleGeneratedFunBind loc range_RDR
-          [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
-        noLocA (mkHsComp ListComp stmts con_expr)
-      where
-        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
-
-        mk_qual a b c = noLocA $ mkPsBindStmt noAnn (nlVarPat c)
-                                 (nlHsApp (nlHsVar range_RDR)
-                                          (mkLHsVarTuple [a,b] noAnn))
-
-    ----------------
-    single_con_index
-      = mkSimpleGeneratedFunBind loc unsafeIndex_RDR
-                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
-                 con_pat cs_needed]
-        -- We need to reverse the order we consider the components in
-        -- so that
-        --     range (l,u) !! index (l,u) i == i   -- when i is in range
-        -- (from http://haskell.org/onlinereport/ix.html) holds.
-                (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
-      where
-        -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
-        mk_index []        = nlHsIntLit 0
-        mk_index [(l,u,i)] = mk_one l u i
-        mk_index ((l,u,i) : rest)
-          = genOpApp (
-                mk_one l u i
-            ) plus_RDR (
-                genOpApp (
-                    (nlHsApp (nlHsVar unsafeRangeSize_RDR)
-                             (mkLHsVarTuple [l,u] noAnn))
-                ) times_RDR (mk_index rest)
-           )
-        mk_one l u i
-          = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u] noAnn, nlHsVar i]
-
-    ------------------
-    single_con_inRange
-      = mkSimpleGeneratedFunBind loc inRange_RDR
-                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
-                 con_pat cs_needed] $
-          if con_arity == 0
-             -- If the product type has no fields, inRange is trivially true
-             -- (see #12853).
-             then true_Expr
-             else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range
-                    as_needed bs_needed cs_needed)
-      where
-        in_range a b c
-          = nlHsApps inRange_RDR [mkLHsVarTuple [a,b] noAnn, nlHsVar c]
-
-{-
-************************************************************************
-*                                                                      *
-        Read instances
-*                                                                      *
-************************************************************************
-
-Example
-
-  infix 4 %%
-  data T = Int %% Int
-         | T1 { f1 :: Int }
-         | T2 T
-
-instance Read T where
-  readPrec =
-    parens
-    ( prec 4 (
-        do x <- ReadP.step Read.readPrec
-           expectP (Symbol "%%")
-           y <- ReadP.step Read.readPrec
-           return (x %% y))
-      +++
-      prec (appPrec+1) (
-        -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
-        -- Record construction binds even more tightly than application
-        do expectP (Ident "T1")
-           expectP (Punc '{')
-           x          <- Read.readField "f1" (ReadP.reset readPrec)
-           expectP (Punc '}')
-           return (T1 { f1 = x }))
-      +++
-      prec appPrec (
-        do expectP (Ident "T2")
-           x <- ReadP.step Read.readPrec
-           return (T2 x))
-    )
-
-  readListPrec = readListPrecDefault
-  readList     = readListDefault
-
-
-Note [Use expectP]
-~~~~~~~~~~~~~~~~~~
-Note that we use
-   expectP (Ident "T1")
-rather than
-   Ident "T1" <- lexP
-The latter desugares to inline code for matching the Ident and the
-string, and this can be very voluminous. The former is much more
-compact.  Cf #7258, although that also concerned non-linearity in
-the occurrence analyser, a separate issue.
-
-Note [Read for empty data types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What should we get for this?  (#7931)
-   data Emp deriving( Read )   -- No data constructors
-
-Here we want
-  read "[]" :: [Emp]   to succeed, returning []
-So we do NOT want
-   instance Read Emp where
-     readPrec = error "urk"
-Rather we want
-   instance Read Emp where
-     readPred = pfail   -- Same as choose []
-
-Because 'pfail' allows the parser to backtrack, but 'error' doesn't.
-These instances are also useful for Read (Either Int Emp), where
-we want to be able to parse (Left 3) just fine.
--}
-
-gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys
-               -> (LHsBinds GhcPs, Bag AuxBindSpec)
-
-gen_Read_binds get_fixity loc dit@(DerivInstTys{dit_rep_tc = tycon})
-  = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
-  where
-    -----------------------------------------------------------------------
-    default_readlist
-        = mkHsVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
-
-    default_readlistprec
-        = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
-    -----------------------------------------------------------------------
-
-    data_cons = tyConDataCons tycon
-    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
-
-    read_prec = mkHsVarBind loc readPrec_RDR rhs
-      where
-        rhs | null data_cons -- See Note [Read for empty data types]
-            = nlHsVar pfail_RDR
-            | otherwise
-            = nlHsApp (nlHsVar parens_RDR)
-                      (foldr1 mk_alt (read_nullary_cons ++
-                                      read_non_nullary_cons))
-
-    read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
-
-    read_nullary_cons
-      = case nullary_cons of
-            []    -> []
-            [con] -> [nlHsDo (DoExpr Nothing) (match_con con ++ [noLocA $ mkLastStmt (result_expr con [])])]
-            _     -> [nlHsApp (nlHsVar choose_RDR)
-                              (nlList (map mk_pair nullary_cons))]
-        -- NB For operators the parens around (:=:) are matched by the
-        -- enclosing "parens" call, so here we must match the naked
-        -- data_con_str con
-
-    match_con con | isSym con_str = [symbol_pat con_str]
-                  | otherwise     = ident_h_pat  con_str
-                  where
-                    con_str = data_con_str con
-        -- For nullary constructors we must match Ident s for normal constrs
-        -- and   Symbol s   for operators
-
-    mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
-                                  result_expr con []] noAnn
-
-    read_non_nullary_con data_con
-      | is_infix  = mk_parser infix_prec  infix_stmts  body
-      | is_record = mk_parser record_prec record_stmts body
---              Using these two lines instead allows the derived
---              read for infix and record bindings to read the prefix form
---      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
---      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
-      | otherwise = prefix_parser
-      where
-        body = result_expr data_con as_needed
-        con_str = data_con_str data_con
-
-        prefix_parser = mk_parser prefix_prec prefix_stmts body
-
-        read_prefix_con
-            | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
-            | otherwise     = ident_h_pat con_str
-
-        read_infix_con
-            | isSym con_str = [symbol_pat con_str]
-            | otherwise     = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
-
-        prefix_stmts            -- T a b c
-          = read_prefix_con ++ read_args
-
-        infix_stmts             -- a %% b, or  a `T` b
-          = [read_a1]
-            ++ read_infix_con
-            ++ [read_a2]
-
-        record_stmts            -- T { f1 = a, f2 = b }
-          = read_prefix_con
-            ++ [read_punc "{"]
-            ++ concat (intersperse [read_punc ","] field_stmts)
-            ++ [read_punc "}"]
-
-        field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
-
-        con_arity    = dataConSourceArity data_con
-        labels       = map (field_label . flLabel) $ dataConFieldLabels data_con
-        dc_nm        = getName data_con
-        is_infix     = dataConIsInfix data_con
-        is_record    = labels `lengthExceeds` 0
-        as_needed    = take con_arity as_RDRs
-        read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (derivDataConInstArgTys data_con dit)
-        (read_a1:read_a2:_) = read_args
-
-        prefix_prec = appPrecedence
-        infix_prec  = getPrecedence get_fixity dc_nm
-        record_prec = appPrecedence + 1 -- Record construction binds even more tightly
-                                        -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
-
-    ------------------------------------------------------------------------
-    --          Helpers
-    ------------------------------------------------------------------------
-    mk_alt e1 e2       = genOpApp e1 alt_RDR e2                         -- e1 +++ e2
-    mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p                -- prec p (do { ss ; b })
-                                           , nlHsDo (DoExpr Nothing) (ss ++ [noLocA $ mkLastStmt b])]
-    con_app con as     = nlHsVarApps (getRdrName con) as                -- con as
-    result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
-
-    -- For constructors and field labels ending in '#', we hackily
-    -- let the lexer generate two tokens, and look for both in sequence
-    -- Thus [Ident "I"; Symbol "#"].  See #5041
-    ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
-                  | otherwise                    = [ ident_pat s ]
-
-    bindLex pat  = noLocA (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p
-                   -- See Note [Use expectP]
-    ident_pat  s = bindLex $ nlHsApps ident_RDR  [nlHsLit (mkHsString s)]  -- expectP (Ident "foo")
-    symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)]  -- expectP (Symbol ">>")
-    read_punc c  = bindLex $ nlHsApps punc_RDR   [nlHsLit (mkHsString c)]  -- expectP (Punc "<")
-
-    data_con_str con = occNameString (getOccName con)
-
-    read_arg a ty = assert (not (isUnliftedType ty)) $
-                    noLocA (mkPsBindStmt noAnn (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
-
-    -- When reading field labels we might encounter
-    --      a  = 3
-    --      _a = 3
-    -- or   (#) = 4
-    -- Note the parens!
-    read_field lbl a =
-        [noLocA
-          (mkPsBindStmt noAnn
-            (nlVarPat a)
-            (nlHsApp
-              read_field
-              (nlHsVarApps reset_RDR [readPrec_RDR])
-            )
-          )
-        ]
-        where
-          lbl_str = unpackFS lbl
-          mk_read_field read_field_rdr lbl
-              = nlHsApps read_field_rdr [nlHsLit (mkHsStringFS lbl)]
-          read_field
-              | isSym lbl_str
-              = mk_read_field readSymField_RDR lbl
-              | Just (ss, '#') <- snocView lbl_str -- #14918
-              = mk_read_field readFieldHash_RDR (mkFastString ss)
-              | otherwise
-              = mk_read_field readField_RDR lbl
-
-{-
-************************************************************************
-*                                                                      *
-        Show instances
-*                                                                      *
-************************************************************************
-
-Example
-
-    infixr 5 :^:
-
-    data Tree a =  Leaf a  |  Tree a :^: Tree a
-
-    instance (Show a) => Show (Tree a) where
-
-        showsPrec d (Leaf m) = showParen (d > app_prec) showStr
-          where
-             showStr = showString "Leaf " . showsPrec (app_prec+1) m
-
-        showsPrec d (u :^: v) = showParen (d > up_prec) showStr
-          where
-             showStr = showsPrec (up_prec+1) u .
-                       showString " :^: "      .
-                       showsPrec (up_prec+1) v
-                -- Note: right-associativity of :^: ignored
-
-    up_prec  = 5    -- Precedence of :^:
-    app_prec = 10   -- Application has precedence one more than
-                    -- the most tightly-binding operator
--}
-
-gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys
-               -> (LHsBinds GhcPs, Bag AuxBindSpec)
-
-gen_Show_binds get_fixity loc dit@(DerivInstTys{ dit_rep_tc = tycon
-                                               , dit_rep_tc_args = tycon_args })
-  = (unitBag shows_prec, emptyBag)
-  where
-    data_cons = getPossibleDataCons tycon tycon_args
-    shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)
-    comma_space = nlHsVar showCommaSpace_RDR
-
-    pats_etc data_con
-      | nullary_con =  -- skip the showParen junk...
-         assert (null bs_needed)
-         ([nlWildPat, con_pat], mk_showString_app op_con_str)
-      | otherwise   =
-         ([a_Pat, con_pat],
-          showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit
-                         (HsInt noExtField (mkIntegralLit con_prec_plus_one))))
-                         (nlHsPar (nested_compose_Expr show_thingies)))
-        where
-             data_con_RDR  = getRdrName data_con
-             con_arity     = dataConSourceArity data_con
-             bs_needed     = take con_arity bs_RDRs
-             arg_tys       = derivDataConInstArgTys data_con dit -- Correspond 1-1 with bs_needed
-             con_pat       = nlConVarPat data_con_RDR bs_needed
-             nullary_con   = con_arity == 0
-             labels        = map (field_label . flLabel) $ dataConFieldLabels data_con
-             lab_fields    = length labels
-             record_syntax = lab_fields > 0
-
-             dc_nm          = getName data_con
-             dc_occ_nm      = getOccName data_con
-             con_str        = occNameString dc_occ_nm
-             op_con_str     = wrapOpParens con_str
-             backquote_str  = wrapOpBackquotes con_str
-
-             show_thingies
-                | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
-                | record_syntax = mk_showString_app (op_con_str ++ " {") :
-                                  show_record_args ++ [mk_showString_app "}"]
-                | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
-
-             show_label l = mk_showString_app (nm ++ " = ")
-                        -- Note the spaces around the "=" sign.  If we
-                        -- don't have them then we get Foo { x=-1 } and
-                        -- the "=-" parses as a single lexeme.  Only the
-                        -- space after the '=' is necessary, but it
-                        -- seems tidier to have them both sides.
-                 where
-                   nm       = wrapOpParens (unpackFS l)
-
-             show_args               = zipWithEqual "gen_Show_binds" show_arg bs_needed arg_tys
-             (show_arg1:show_arg2:_) = show_args
-             show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
-
-                -- Assumption for record syntax: no of fields == no of
-                -- labelled fields (and in same order)
-             show_record_args = concat $
-                                intersperse [comma_space] $
-                                [ [show_label lbl, arg]
-                                | (lbl,arg) <- zipEqual "gen_Show_binds"
-                                                        labels show_args ]
-
-             show_arg :: RdrName -> Type -> LHsExpr GhcPs
-             show_arg b arg_ty
-                 | isUnliftedType arg_ty
-                 -- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer
-                 = with_conv $
-                    nlHsApps compose_RDR
-                        [mk_shows_app boxed_arg, mk_showString_app postfixMod]
-                 | otherwise
-                 = mk_showsPrec_app arg_prec arg
-               where
-                 arg        = nlHsVar b
-                 boxed_arg  = box "Show" arg arg_ty
-                 postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty
-                 with_conv expr
-                    | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty =
-                        nested_compose_Expr
-                            [ mk_showString_app ("(" ++ conv ++ " ")
-                            , expr
-                            , mk_showString_app ")"
-                            ]
-                    | otherwise = expr
-
-                -- Fixity stuff
-             is_infix = dataConIsInfix data_con
-             con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
-             arg_prec | record_syntax = 0  -- Record fields don't need parens
-                      | otherwise     = con_prec_plus_one
-
-wrapOpParens :: String -> String
-wrapOpParens s | isSym s   = '(' : s ++ ")"
-               | otherwise = s
-
-wrapOpBackquotes :: String -> String
-wrapOpBackquotes s | isSym s   = s
-                   | otherwise = '`' : s ++ "`"
-
-isSym :: String -> Bool
-isSym ""      = False
-isSym (c : _) = startsVarSym c || startsConSym c
-
--- | showString :: String -> ShowS
-mk_showString_app :: String -> LHsExpr GhcPs
-mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
-
--- | showsPrec :: Show a => Int -> a -> ShowS
-mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs
-mk_showsPrec_app p x
-  = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExtField (mkIntegralLit p)), x]
-
--- | shows :: Show a => a -> ShowS
-mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
-mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
-
-getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
-getPrec is_infix get_fixity nm
-  | not is_infix   = appPrecedence
-  | otherwise      = getPrecedence get_fixity nm
-
-appPrecedence :: Integer
-appPrecedence = fromIntegral maxPrecedence + 1
-  -- One more than the precedence of the most
-  -- tightly-binding operator
-
-getPrecedence :: (Name -> Fixity) -> Name -> Integer
-getPrecedence get_fixity nm
-   = case get_fixity nm of
-        Fixity _ x _assoc -> fromIntegral x
-          -- NB: the Report says that associativity is not taken
-          --     into account for either Read or Show; hence we
-          --     ignore associativity here
-
-{-
-************************************************************************
-*                                                                      *
-        Data instances
-*                                                                      *
-************************************************************************
-
-From the data type
-
-  data T a b = T1 a b | T2
-
-we generate
-
-  $cT1 = mkDataCon $dT "T1" Prefix
-  $cT2 = mkDataCon $dT "T2" Prefix
-  $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
-  -- the [] is for field labels.
-
-  instance (Data a, Data b) => Data (T a b) where
-    gfoldl k z (T1 a b) = z T `k` a `k` b
-    gfoldl k z T2           = z T2
-    -- ToDo: add gmapT,Q,M, gfoldr
-
-    gunfold k z c = case conIndex c of
-                        I# 1# -> k (k (z T1))
-                        I# 2# -> z T2
-
-    toConstr (T1 _ _) = $cT1
-    toConstr T2       = $cT2
-
-    dataTypeOf _ = $dT
-
-    dataCast1 = gcast1   -- If T :: * -> *
-    dataCast2 = gcast2   -- if T :: * -> * -> *
--}
-
-gen_Data_binds :: SrcSpan
-               -> DerivInstTys
-               -> TcM (LHsBinds GhcPs,  -- The method bindings
-                       Bag AuxBindSpec) -- Auxiliary bindings
-gen_Data_binds loc (DerivInstTys{dit_rep_tc = rep_tc})
-  = do { -- See Note [Auxiliary binders]
-         dataT_RDR  <- new_dataT_rdr_name loc rep_tc
-       ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons
-
-       ; pure ( listToBag [ gfoldl_bind, gunfold_bind
-                          , toCon_bind dataC_RDRs, dataTypeOf_bind dataT_RDR ]
-                `unionBags` gcast_binds
-                          -- Auxiliary definitions: the data type and constructors
-              , listToBag
-                  ( DerivDataDataType rep_tc dataT_RDR dataC_RDRs
-                  : zipWith (\data_con dataC_RDR ->
-                               DerivDataConstr data_con dataC_RDR dataT_RDR)
-                            data_cons dataC_RDRs )
-              ) }
-  where
-    data_cons  = tyConDataCons rep_tc
-    n_cons     = length data_cons
-
-        ------------ gfoldl
-    gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons)
-
-    gfoldl_eqn con
-      = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
-                   foldl' mk_k_app (z_Expr `nlHsApp` (eta_expand_data_con con)) as_needed)
-                   where
-                     con_name ::  RdrName
-                     con_name = getRdrName con
-                     as_needed = take (dataConSourceArity con) as_RDRs
-                     mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
-
-        ------------ gunfold
-    gunfold_bind = mkSimpleGeneratedFunBind loc
-                     gunfold_RDR
-                     [k_Pat, z_Pat, if n_cons == 1 then nlWildPat else c_Pat]
-                     gunfold_rhs
-
-    gunfold_rhs
-        | [con] <- data_cons = mk_unfold_rhs con   -- No need for case
-        | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
-                                (map gunfold_alt data_cons)
-
-    gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
-    mk_unfold_rhs dc = foldr nlHsApp
-                           (z_Expr `nlHsApp` (eta_expand_data_con dc))
-                           (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
-
-    eta_expand_data_con dc =
-        mkHsLam eta_expand_pats
-          (foldl nlHsApp (nlHsVar (getRdrName dc)) eta_expand_hsvars)
-      where
-        eta_expand_pats = map nlVarPat eta_expand_vars
-        eta_expand_hsvars = map nlHsVar eta_expand_vars
-        eta_expand_vars = take (dataConSourceArity dc) as_RDRs
-
-
-    mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
-                        -- redundant test, and annoying warning
-      | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
-      | otherwise = nlConPat intDataCon_RDR
-                             [nlLitPat (HsIntPrim NoSourceText (toInteger tag))]
-      where
-        tag = dataConTag dc
-
-        ------------ toConstr
-    toCon_bind dataC_RDRs
-      = mkFunBindEC 1 loc toConstr_RDR id
-            (zipWith to_con_eqn data_cons dataC_RDRs)
-    to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
-
-        ------------ dataTypeOf
-    dataTypeOf_bind dataT_RDR
-      = mkSimpleGeneratedFunBind
-          loc
-          dataTypeOf_RDR
-          [nlWildPat]
-          (nlHsVar dataT_RDR)
-
-        ------------ gcast1/2
-        -- Make the binding    dataCast1 x = gcast1 x  -- if T :: * -> *
-        --               or    dataCast2 x = gcast2 s  -- if T :: * -> * -> *
-        -- (or nothing if T has neither of these two types)
-
-        -- But care is needed for data families:
-        -- If we have   data family D a
-        --              data instance D (a,b,c) = A | B deriving( Data )
-        -- and we want  instance ... => Data (D [(a,b,c)]) where ...
-        -- then we need     dataCast1 x = gcast1 x
-        -- because D :: * -> *
-        -- even though rep_tc has kind * -> * -> * -> *
-        -- Hence looking for the kind of fam_tc not rep_tc
-        -- See #4896
-    tycon_kind = case tyConFamInst_maybe rep_tc of
-                    Just (fam_tc, _) -> tyConKind fam_tc
-                    Nothing          -> tyConKind rep_tc
-    gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
-                | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
-                | otherwise                 = emptyBag
-    mk_gcast dataCast_RDR gcast_RDR
-      = unitBag (mkSimpleGeneratedFunBind loc dataCast_RDR [nlVarPat f_RDR]
-                                 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
-
-
-kind1, kind2 :: Kind
-kind1 = typeToTypeKind
-kind2 = liftedTypeKind `mkVisFunTyMany` kind1
-
-gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstrTag_RDR,
-    mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
-    dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
-    constr_RDR, dataType_RDR,
-    eqChar_RDR  , ltChar_RDR  , geChar_RDR  , gtChar_RDR  , leChar_RDR  ,
-    eqInt_RDR   , ltInt_RDR   , geInt_RDR   , gtInt_RDR   , leInt_RDR   , neInt_RDR ,
-    eqInt8_RDR  , ltInt8_RDR  , geInt8_RDR  , gtInt8_RDR  , leInt8_RDR  ,
-    eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR ,
-    eqInt32_RDR , ltInt32_RDR , geInt32_RDR , gtInt32_RDR , leInt32_RDR ,
-    eqInt64_RDR , ltInt64_RDR , geInt64_RDR , gtInt64_RDR , leInt64_RDR ,
-    eqWord_RDR  , ltWord_RDR  , geWord_RDR  , gtWord_RDR  , leWord_RDR  ,
-    eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR ,
-    eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR,
-    eqWord32_RDR, ltWord32_RDR, geWord32_RDR, gtWord32_RDR, leWord32_RDR,
-    eqWord64_RDR, ltWord64_RDR, geWord64_RDR, gtWord64_RDR, leWord64_RDR,
-    eqAddr_RDR  , ltAddr_RDR  , geAddr_RDR  , gtAddr_RDR  , leAddr_RDR  ,
-    eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
-    eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,
-    word8ToWord_RDR , int8ToInt_RDR ,
-    word16ToWord_RDR, int16ToInt_RDR,
-    word32ToWord_RDR, int32ToInt_RDR
-    :: RdrName
-gfoldl_RDR     = varQual_RDR  gENERICS (fsLit "gfoldl")
-gunfold_RDR    = varQual_RDR  gENERICS (fsLit "gunfold")
-toConstr_RDR   = varQual_RDR  gENERICS (fsLit "toConstr")
-dataTypeOf_RDR = varQual_RDR  gENERICS (fsLit "dataTypeOf")
-dataCast1_RDR  = varQual_RDR  gENERICS (fsLit "dataCast1")
-dataCast2_RDR  = varQual_RDR  gENERICS (fsLit "dataCast2")
-gcast1_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast1")
-gcast2_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast2")
-mkConstrTag_RDR = varQual_RDR gENERICS (fsLit "mkConstrTag")
-constr_RDR     = tcQual_RDR   gENERICS (fsLit "Constr")
-mkDataType_RDR = varQual_RDR  gENERICS (fsLit "mkDataType")
-dataType_RDR   = tcQual_RDR   gENERICS (fsLit "DataType")
-conIndex_RDR   = varQual_RDR  gENERICS (fsLit "constrIndex")
-prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
-infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
-
-eqChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqChar#")
-ltChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltChar#")
-leChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "leChar#")
-gtChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtChar#")
-geChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "geChar#")
-
-eqInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "==#")
-neInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "/=#")
-ltInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<#" )
-leInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<=#")
-gtInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">#" )
-geInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">=#")
-
-eqInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqInt8#")
-ltInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltInt8#" )
-leInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "leInt8#")
-gtInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtInt8#" )
-geInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "geInt8#")
-
-eqInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqInt16#")
-ltInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltInt16#" )
-leInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "leInt16#")
-gtInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtInt16#" )
-geInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "geInt16#")
-
-eqInt32_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqInt32#")
-ltInt32_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltInt32#" )
-leInt32_RDR    = varQual_RDR  gHC_PRIM (fsLit "leInt32#")
-gtInt32_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtInt32#" )
-geInt32_RDR    = varQual_RDR  gHC_PRIM (fsLit "geInt32#")
-
-eqInt64_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqInt64#")
-ltInt64_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltInt64#" )
-leInt64_RDR    = varQual_RDR  gHC_PRIM (fsLit "leInt64#")
-gtInt64_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtInt64#" )
-geInt64_RDR    = varQual_RDR  gHC_PRIM (fsLit "geInt64#")
-
-eqWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqWord#")
-ltWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltWord#")
-leWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "leWord#")
-gtWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtWord#")
-geWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "geWord#")
-
-eqWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqWord8#")
-ltWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltWord8#" )
-leWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "leWord8#")
-gtWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtWord8#" )
-geWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "geWord8#")
-
-eqWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "eqWord16#")
-ltWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "ltWord16#" )
-leWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "leWord16#")
-gtWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "gtWord16#" )
-geWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "geWord16#")
-
-eqWord32_RDR   = varQual_RDR  gHC_PRIM (fsLit "eqWord32#")
-ltWord32_RDR   = varQual_RDR  gHC_PRIM (fsLit "ltWord32#" )
-leWord32_RDR   = varQual_RDR  gHC_PRIM (fsLit "leWord32#")
-gtWord32_RDR   = varQual_RDR  gHC_PRIM (fsLit "gtWord32#" )
-geWord32_RDR   = varQual_RDR  gHC_PRIM (fsLit "geWord32#")
-
-eqWord64_RDR   = varQual_RDR  gHC_PRIM (fsLit "eqWord64#")
-ltWord64_RDR   = varQual_RDR  gHC_PRIM (fsLit "ltWord64#" )
-leWord64_RDR   = varQual_RDR  gHC_PRIM (fsLit "leWord64#")
-gtWord64_RDR   = varQual_RDR  gHC_PRIM (fsLit "gtWord64#" )
-geWord64_RDR   = varQual_RDR  gHC_PRIM (fsLit "geWord64#")
-
-eqAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqAddr#")
-ltAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltAddr#")
-leAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "leAddr#")
-gtAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtAddr#")
-geAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "geAddr#")
-
-eqFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqFloat#")
-ltFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltFloat#")
-leFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "leFloat#")
-gtFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtFloat#")
-geFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "geFloat#")
-
-eqDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "==##")
-ltDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<##" )
-leDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<=##")
-gtDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">##" )
-geDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">=##")
-
-word8ToWord_RDR = varQual_RDR  gHC_PRIM (fsLit "word8ToWord#")
-int8ToInt_RDR   = varQual_RDR  gHC_PRIM (fsLit "int8ToInt#")
-
-word16ToWord_RDR = varQual_RDR  gHC_PRIM (fsLit "word16ToWord#")
-int16ToInt_RDR   = varQual_RDR  gHC_PRIM (fsLit "int16ToInt#")
-
-word32ToWord_RDR = varQual_RDR  gHC_PRIM (fsLit "word32ToWord#")
-int32ToInt_RDR   = varQual_RDR  gHC_PRIM (fsLit "int32ToInt#")
-
-{-
-************************************************************************
-*                                                                      *
-                        Lift instances
-*                                                                      *
-************************************************************************
-
-Example:
-
-    data Foo a = Foo a | a :^: a deriving Lift
-
-    ==>
-
-    instance (Lift a) => Lift (Foo a) where
-        lift (Foo a) = [| Foo $(lift a) |]
-        lift ((:^:) u v) = [| (:^:) $(lift u) $(lift v) |]
-
-        liftTyped (Foo a) = [|| Foo $$(liftTyped a) ||]
-        liftTyped ((:^:) u v) = [|| (:^:) $$(liftTyped u) $$(liftTyped v) ||]
-
-Note that we use explicit splices here in order to not trigger the implicit
-lifting warning in derived code. (See #20688)
--}
-
-
-gen_Lift_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
-gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon
-                                , dit_rep_tc_args = tycon_args }) =
-  (listToBag [lift_bind, liftTyped_bind], emptyBag)
-  where
-    lift_bind      = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
-                                 (map (pats_etc mk_untyped_bracket mk_usplice liftName) data_cons)
-    liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr)
-                                 (map (pats_etc mk_typed_bracket mk_tsplice liftTypedName) data_cons)
-
-    mk_untyped_bracket = HsUntypedBracket noAnn . ExpBr noExtField
-    mk_typed_bracket = HsTypedBracket noAnn
-
-    mk_tsplice = HsTypedSplice (EpAnnNotUsed, noAnn)
-    mk_usplice = HsUntypedSplice EpAnnNotUsed . HsUntypedSpliceExpr noAnn
-    data_cons = getPossibleDataCons tycon tycon_args
-
-    pats_etc mk_bracket mk_splice lift_name data_con
-      = ([con_pat], lift_Expr)
-       where
-            con_pat      = nlConVarPat data_con_RDR as_needed
-            data_con_RDR = getRdrName data_con
-            con_arity    = dataConSourceArity data_con
-            as_needed    = take con_arity as_RDRs
-            lift_Expr    = noLocA (mk_bracket br_body)
-            br_body      = nlHsApps (Exact (dataConName data_con))
-                                    (map lift_var as_needed)
-
-            lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed)
-            lift_var x   = noLocA (mk_splice (nlHsPar (mk_lift_expr x)))
-
-            mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed)
-            mk_lift_expr x = nlHsApps (Exact lift_name) [nlHsVar x]
-
-{-
-************************************************************************
-*                                                                      *
-                     Newtype-deriving instances
-*                                                                      *
-************************************************************************
-
-Note [Newtype-deriving instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We take every method in the original instance and `coerce` it to fit
-into the derived instance. We need type applications on the argument
-to `coerce` to make it obvious what instantiation of the method we're
-coercing from.  So from, say,
-
-  class C a b where
-    op :: forall c. a -> [b] -> c -> Int
-
-  newtype T x = MkT <rep-ty>
-
-  instance C a <rep-ty> => C a (T x) where
-    op :: forall c. a -> [T x] -> c -> Int
-    op = coerce @(a -> [<rep-ty>] -> c -> Int)
-                @(a -> [T x]      -> c -> Int)
-                op
-
-In addition to the type applications, we also have an explicit
-type signature on the entire RHS. This brings the method-bound variable
-`c` into scope over the two type applications.
-See Note [GND and QuantifiedConstraints] for more information on why this
-is important.
-
-Giving 'coerce' two explicitly-visible type arguments grants us finer control
-over how it should be instantiated. Recall
-
-  coerce :: Coercible a b => a -> b
-
-By giving it explicit type arguments we deal with the case where
-'op' has a higher rank type, and so we must instantiate 'coerce' with
-a polytype.  E.g.
-
-   class C a where op :: a -> forall b. b -> b
-   newtype T x = MkT <rep-ty>
-   instance C <rep-ty> => C (T x) where
-     op :: T x -> forall b. b -> b
-     op = coerce @(<rep-ty> -> forall b. b -> b)
-                 @(T x      -> forall b. b -> b)
-                op
-
-The use of type applications is crucial here. We have to instantiate
-both type args of (coerce :: Coercible a b => a -> b) to polytypes,
-and we can only do that with VTA or Quick Look. Here VTA seems more
-appropriate for machine generated code: it's simple and robust.
-
-However, to allow VTA with polytypes we must switch on
--XImpredicativeTypes locally in GHC.Tc.Deriv.genInst.
-See #8503 for more discussion.
-
-Note [Newtype-deriving trickiness]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#12768):
-  class C a where { op :: D a => a -> a }
-
-  instance C a  => C [a] where { op = opList }
-
-  opList :: (C a, D [a]) => [a] -> [a]
-  opList = ...
-
-Now suppose we try GND on this:
-  newtype N a = MkN [a] deriving( C )
-
-The GND is expecting to get an implementation of op for N by
-coercing opList, thus:
-
-  instance C a => C (N a) where { op = opN }
-
-  opN :: (C a, D (N a)) => N a -> N a
-  opN = coerce @([a]   -> [a])
-               @([N a] -> [N a]
-               opList :: D (N a) => [N a] -> [N a]
-
-But there is no reason to suppose that (D [a]) and (D (N a))
-are inter-coercible; these instances might completely different.
-So GHC rightly rejects this code.
-
-Note [GND and QuantifiedConstraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider the following example from #15290:
-
-  class C m where
-    join :: m (m a) -> m a
-
-  newtype T m a = MkT (m a)
-
-  deriving instance
-    (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
-    C (T m)
-
-The code that GHC used to generate for this was:
-
-  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
-      C (T m) where
-    join = coerce @(forall a.   m   (m a) ->   m a)
-                  @(forall a. T m (T m a) -> T m a)
-                  join
-
-This instantiates `coerce` at a polymorphic type, a form of impredicative
-polymorphism, so we're already on thin ice. And in fact the ice breaks,
-as we'll explain:
-
-The call to `coerce` gives rise to:
-
-  Coercible (forall a.   m   (m a) ->   m a)
-            (forall a. T m (T m a) -> T m a)
-
-And that simplified to the following implication constraint:
-
-  forall a <no-ev>. m (T m a) ~R# m (m a)
-
-But because this constraint is under a `forall`, inside a type, we have to
-prove it *without computing any term evidence* (hence the <no-ev>). Alas, we
-*must* generate a term-level evidence binding in order to instantiate the
-quantified constraint! In response, GHC currently chooses not to use such
-a quantified constraint.
-See Note [Instances in no-evidence implications] in GHC.Tc.Solver.Interact.
-
-But this isn't the death knell for combining QuantifiedConstraints with GND.
-On the contrary, if we generate GND bindings in a slightly different way, then
-we can avoid this situation altogether. Instead of applying `coerce` to two
-polymorphic types, we instead let an instance signature do the polymorphic
-instantiation, and omit the `forall`s in the type applications.
-More concretely, we generate the following code instead:
-
-  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
-      C (T m) where
-    join :: forall a. T m (T m a) -> T m a
-    join = coerce @(  m   (m a) ->   m a)
-                  @(T m (T m a) -> T m a)
-                  join
-
-Now the visible type arguments are both monotypes, so we don't need any of this
-funny quantified constraint instantiation business. While this particular
-example no longer uses impredicative instantiation, we still need to enable
-ImpredicativeTypes to typecheck GND-generated code for class methods with
-higher-rank types. See Note [Newtype-deriving instances].
-
-You might think that that second @(T m (T m a) -> T m a) argument is redundant
-in the presence of the instance signature, but in fact leaving it off will
-break this example (from the T15290d test case):
-
-  class C a where
-    c :: Int -> forall b. b -> a
-
-  instance C Int
-
-  instance C Age where
-    c :: Int -> forall b. b -> Age
-    c = coerce @(Int -> forall b. b -> Int)
-               c
-
-That is because we still need to instantiate the second argument of
-coerce with a polytype, and we can only do that with VTA or QuickLook.
-
-Be aware that the use of an instance signature doesn't /solve/ this
-problem; it just makes it less likely to occur. For example, if a class has
-a truly higher-rank type like so:
-
-  class CProblem m where
-    op :: (forall b. ... (m b) ...) -> Int
-
-Then the same situation will arise again. But at least it won't arise for the
-common case of methods with ordinary, prenex-quantified types.
-
------
--- Wrinkle: Use HsOuterExplicit
------
-
-One minor complication with the plan above is that we need to ensure that the
-type variables from a method's instance signature properly scope over the body
-of the method. For example, recall:
-
-  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
-      C (T m) where
-    join :: forall a. T m (T m a) -> T m a
-    join = coerce @(  m   (m a) ->   m a)
-                  @(T m (T m a) -> T m a)
-                  join
-
-In the example above, it is imperative that the `a` in the instance signature
-for `join` scope over the body of `join` by way of ScopedTypeVariables.
-This might sound obvious, but note that in gen_Newtype_binds, which is
-responsible for generating the code above, the type in `join`'s instance
-signature is given as a Core type, whereas gen_Newtype_binds will eventually
-produce HsBinds (i.e., source Haskell) that is renamed and typechecked. We
-must ensure that `a` is in scope over the body of `join` during renaming
-or else the generated code will be rejected.
-
-In short, we need to convert the instance signature from a Core type to an
-HsType (i.e., a source Haskell type). Two possible options are:
-
-1. Convert the Core type entirely to an HsType (i.e., a source Haskell type).
-2. Embed the entire Core type using HsCoreTy.
-
-Neither option is quite satisfactory:
-
-1. Converting a Core type to an HsType in full generality is surprisingly
-   complicated. Previous versions of GHCs did this, but it was the source of
-   numerous bugs (see #14579 and #16518, for instance).
-2. While HsCoreTy is much less complicated that option (1), it's not quite
-   what we want. In order for `a` to be in scope over the body of `join` during
-   renaming, the `forall` must be contained in an HsOuterExplicit.
-   (See Note [Lexically scoped type variables] in GHC.Hs.Type.) HsCoreTy
-   bypasses HsOuterExplicit, so this won't work either.
-
-As a compromise, we adopt a combination of the two options above:
-
-* Split apart the top-level ForAllTys in the instance signature's Core type,
-* Convert the top-level ForAllTys to an HsOuterExplicit, and
-* Embed the remainder of the Core type in an HsCoreTy.
-
-This retains most of the simplicity of option (2) while still ensuring that
-the type variables are correctly scoped.
-
-Note that splitting apart top-level ForAllTys will expand any type synonyms
-in the Core type itself. This ends up being important to fix a corner case
-observed in #18914. Consider this example:
-
-  type T f = forall a. f a
-
-  class C f where
-    m :: T f
-
-  newtype N f a = MkN (f a)
-    deriving C
-
-What code should `deriving C` generate? It will have roughly the following
-shape:
-
-  instance C f => C (N f) where
-    m :: T (N f)
-    m = coerce @(...) (...) (m @f)
-
-At a minimum, we must instantiate `coerce` with `@(T f)` and `@(T (N f))`, but
-with the `forall`s removed in order to make them monotypes. However, the
-`forall` is hidden underneath the `T` type synonym, so we must first expand `T`
-before we can strip of the `forall`. Expanding `T`, we get
-`coerce @(forall a. f a) @(forall a. N f a)`, and after omitting the `forall`s,
-we get `coerce @(f a) @(N f a)`.
-
-We can't stop there, however, or else we would end up with this code:
-
-  instance C f => C (N f) where
-    m :: T (N f)
-    m = coerce @(f a) @(N f a) (m @f)
-
-Notice that the type variable `a` is completely unbound. In order to make sure
-that `a` is in scope, we must /also/ expand the `T` in `m :: T (N f)` to get
-`m :: forall a. N f a`. Fortunately, we will do just that in the plan outlined
-above, since when we split off the top-level ForAllTys in the instance
-signature, we must first expand the T type synonym.
-
-Note [GND and ambiguity]
-~~~~~~~~~~~~~~~~~~~~~~~~
-We make an effort to make the code generated through GND be robust w.r.t.
-ambiguous type variables. As one example, consider the following example
-(from #15637):
-
-  class C a where f :: String
-  instance C () where f = "foo"
-  newtype T = T () deriving C
-
-A naïve attempt and generating a C T instance would be:
-
-  instance C T where
-    f :: String
-    f = coerce @String @String f
-
-This isn't going to typecheck, however, since GHC doesn't know what to
-instantiate the type variable `a` with in the call to `f` in the method body.
-(Note that `f :: forall a. String`!) To compensate for the possibility of
-ambiguity here, we explicitly instantiate `a` like so:
-
-  instance C T where
-    f :: String
-    f = coerce @String @String (f @())
-
-All better now.
--}
-
-gen_Newtype_binds :: SrcSpan
-                  -> Class   -- the class being derived
-                  -> [TyVar] -- the tvs in the instance head (this includes
-                             -- the tvs from both the class types and the
-                             -- newtype itself)
-                  -> [Type]  -- instance head parameters (incl. newtype)
-                  -> Type    -- the representation type
-                  -> (LHsBinds GhcPs, [LSig GhcPs])
--- See Note [Newtype-deriving instances]
-gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty
-  = (listToBag binds, sigs)
-  where
-    (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)
-
-    -- Same as inst_tys, but with the last argument type replaced by the
-    -- representation type.
-    underlying_inst_tys :: [Type]
-    underlying_inst_tys = changeLast inst_tys rhs_ty
-
-    locn = noAnnSrcSpan loc'
-    loca = noAnnSrcSpan loc'
-    -- For each class method, generate its derived binding and instance
-    -- signature. Using the first example from
-    -- Note [Newtype-deriving instances]:
-    --
-    --   class C a b where
-    --     op :: forall c. a -> [b] -> c -> Int
-    --
-    --   newtype T x = MkT <rep-ty>
-    --
-    -- Then we would generate <derived-op-impl> below:
-    --
-    --   instance C a <rep-ty> => C a (T x) where
-    --     <derived-op-impl>
-    mk_bind_and_sig :: Id -> (LHsBind GhcPs, LSig GhcPs)
-    mk_bind_and_sig meth_id
-      = ( -- The derived binding, e.g.,
-          --
-          --   op = coerce @(a -> [<rep-ty>] -> c -> Int)
-          --               @(a -> [T x]      -> c -> Int)
-          --               op
-          mkRdrFunBind loc_meth_RDR [mkSimpleMatch
-                                        (mkPrefixFunRhs loc_meth_RDR)
-                                        [] rhs_expr]
-        , -- The derived instance signature, e.g.,
-          --
-          --   op :: forall c. a -> [T x] -> c -> Int
-          --
-          -- Make sure that `forall c` is in an HsOuterExplicit so that it
-          -- scopes over the body of `op`. See "Wrinkle: Use HsOuterExplicit" in
-          -- Note [GND and QuantifiedConstraints].
-          L loca $ ClassOpSig noAnn False [loc_meth_RDR]
-                 $ L loca $ mkHsExplicitSigType noAnn
-                              (map mk_hs_tvb to_tvbs)
-                              (nlHsCoreTy to_rho)
-        )
-      where
-        Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
-        (_, _, from_tau)  = tcSplitSigmaTy from_ty
-        (to_tvbs, to_rho) = tcSplitForAllInvisTVBinders to_ty
-        (_, to_tau)       = tcSplitPhiTy to_rho
-        -- The use of tcSplitForAllInvisTVBinders above expands type synonyms,
-        -- which is important to ensure correct type variable scoping.
-        -- See "Wrinkle: Use HsOuterExplicit" in
-        -- Note [GND and QuantifiedConstraints].
-
-        mk_hs_tvb :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs
-        mk_hs_tvb (Bndr tv flag) = noLocA $ KindedTyVar noAnn
-                                                        flag
-                                                        (noLocA (getRdrName tv))
-                                                        (nlHsCoreTy (tyVarKind tv))
-
-        meth_RDR = getRdrName meth_id
-        loc_meth_RDR = L locn meth_RDR
-
-        rhs_expr = nlHsVar (getRdrName coerceId)
-                                      `nlHsAppType`     from_tau
-                                      `nlHsAppType`     to_tau
-                                      `nlHsApp`         meth_app
-
-        -- The class method, applied to all of the class instance types
-        -- (including the representation type) to avoid potential ambiguity.
-        -- See Note [GND and ambiguity]
-        meth_app = foldl' nlHsAppType (nlHsVar meth_RDR) $
-                   filterOutInferredTypes (classTyCon cls) underlying_inst_tys
-                     -- Filter out any inferred arguments, since they can't be
-                     -- applied with visible type application.
-
-gen_Newtype_fam_insts :: SrcSpan
-                      -> Class   -- the class being derived
-                      -> [TyVar] -- the tvs in the instance head (this includes
-                                 -- the tvs from both the class types and the
-                                 -- newtype itself)
-                      -> [Type]  -- instance head parameters (incl. newtype)
-                      -> Type    -- the representation type
-                      -> TcM [FamInst]
--- See Note [GND and associated type families] in GHC.Tc.Deriv
-gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty
-  = assert (all (not . isDataFamilyTyCon) ats) $
-    mapM mk_atf_inst ats
-  where
-    -- Same as inst_tys, but with the last argument type replaced by the
-    -- representation type.
-    underlying_inst_tys :: [Type]
-    underlying_inst_tys = changeLast inst_tys rhs_ty
-
-    ats       = classATs cls
-    locn      = noAnnSrcSpan loc'
-    cls_tvs   = classTyVars cls
-    in_scope  = mkInScopeSetList inst_tvs
-    lhs_env   = zipTyEnv cls_tvs inst_tys
-    lhs_subst = mkTvSubst in_scope lhs_env
-    rhs_env   = zipTyEnv cls_tvs underlying_inst_tys
-    rhs_subst = mkTvSubst in_scope rhs_env
-
-    mk_atf_inst :: TyCon -> TcM FamInst
-    mk_atf_inst fam_tc = do
-        rep_tc_name <- newFamInstTyConName (L locn (tyConName fam_tc))
-                                           rep_lhs_tys
-        let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs'
-                                    fam_tc rep_lhs_tys rep_rhs_ty
-        -- Check (c) from Note [GND and associated type families] in GHC.Tc.Deriv
-        checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom)
-        newFamInst SynFamilyInst axiom
-      where
-        fam_tvs     = tyConTyVars fam_tc
-        rep_lhs_tys = substTyVars lhs_subst fam_tvs
-        rep_rhs_tys = substTyVars rhs_subst fam_tvs
-        rep_rhs_ty  = mkTyConApp fam_tc rep_rhs_tys
-        rep_tcvs    = tyCoVarsOfTypesList rep_lhs_tys
-        (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs
-        rep_tvs'    = scopedSort rep_tvs
-        rep_cvs'    = scopedSort rep_cvs
-
-nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
-nlHsAppType e s = noLocA (HsAppType noExtField e noHsTok hs_ty)
-  where
-    hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s
-
-nlHsCoreTy :: HsCoreTy -> LHsType GhcPs
-nlHsCoreTy = noLocA . XHsType
-
-mkCoerceClassMethEqn :: Class   -- the class being derived
-                     -> [TyVar] -- the tvs in the instance head (this includes
-                                -- the tvs from both the class types and the
-                                -- newtype itself)
-                     -> [Type]  -- instance head parameters (incl. newtype)
-                     -> Type    -- the representation type
-                     -> Id      -- the method to look at
-                     -> Pair Type
--- See Note [Newtype-deriving instances]
--- See also Note [Newtype-deriving trickiness]
--- The pair is the (from_type, to_type), where to_type is
--- the type of the method we are trying to get
-mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id
-  = Pair (substTy rhs_subst user_meth_ty)
-         (substTy lhs_subst user_meth_ty)
-  where
-    cls_tvs = classTyVars cls
-    in_scope = mkInScopeSetList inst_tvs
-    lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys)
-    rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty))
-    (_class_tvs, _class_constraint, user_meth_ty)
-      = tcSplitMethodTy (varType id)
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Generating extra binds (@tag2con@, etc.)}
-*                                                                      *
-************************************************************************
-
-\begin{verbatim}
-data Foo ... = ...
-
-tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
-maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
-\end{verbatim}
-
-The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
-fiddling around.
--}
-
--- | Generate the full code for an auxiliary binding.
--- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@.
-genAuxBindSpecOriginal :: SrcSpan -> AuxBindSpec
-                       -> (LHsBind GhcPs, LSig GhcPs)
-genAuxBindSpecOriginal loc spec
-  = (gen_bind spec,
-     L loca (TypeSig noAnn [L locn (auxBindSpecRdrName spec)]
-           (genAuxBindSpecSig loc spec)))
-  where
-    loca = noAnnSrcSpan loc
-    locn = noAnnSrcSpan loc
-    gen_bind :: AuxBindSpec -> LHsBind GhcPs
-    gen_bind (DerivTag2Con _ tag2con_RDR)
-      = mkFunBindSE 0 loc tag2con_RDR
-           [([nlConVarPat intDataCon_RDR [a_RDR]],
-              nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)]
-
-    gen_bind (DerivMaxTag tycon maxtag_RDR)
-      = mkHsVarBind loc maxtag_RDR rhs
-      where
-        rhs = nlHsApp (nlHsVar intDataCon_RDR)
-                      (nlHsLit (HsIntPrim NoSourceText max_tag))
-        max_tag =  case (tyConDataCons tycon) of
-                     data_cons -> toInteger ((length data_cons) - fIRST_TAG)
-
-    gen_bind (DerivDataDataType tycon dataT_RDR dataC_RDRs)
-      = mkHsVarBind loc dataT_RDR rhs
-      where
-        tc_name = tyConName tycon
-        tc_name_string = occNameFS (getOccName tc_name)
-        definition_mod_name = moduleNameFS (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name))
-        rhs = nlHsVar mkDataType_RDR
-              `nlHsApp` nlHsLit (mkHsStringFS (concatFS [definition_mod_name, fsLit ".", tc_name_string]))
-              `nlHsApp` nlList (map nlHsVar dataC_RDRs)
-
-    gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR)
-      = mkHsVarBind loc dataC_RDR rhs
-      where
-        rhs = nlHsApps mkConstrTag_RDR constr_args
-
-        constr_args
-           = [ nlHsVar dataT_RDR                            -- DataType
-             , nlHsLit (mkHsStringFS (occNameFS dc_occ))    -- Constructor name
-             , nlHsIntLit (toInteger (dataConTag dc))       -- Constructor tag
-             , nlList  labels                               -- Field labels
-             , nlHsVar fixity ]                             -- Fixity
-
-        labels   = map (nlHsLit . mkHsStringFS . field_label . flLabel)
-                       (dataConFieldLabels dc)
-        dc_occ   = getOccName dc
-        is_infix = isDataSymOcc dc_occ
-        fixity | is_infix  = infix_RDR
-               | otherwise = prefix_RDR
-
--- | Generate the code for an auxiliary binding that is a duplicate of another
--- auxiliary binding.
--- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@.
-genAuxBindSpecDup :: SrcSpan -> RdrName -> AuxBindSpec
-                  -> (LHsBind GhcPs, LSig GhcPs)
-genAuxBindSpecDup loc original_rdr_name dup_spec
-  = (mkHsVarBind loc dup_rdr_name (nlHsVar original_rdr_name),
-     L loca (TypeSig noAnn [L locn dup_rdr_name]
-           (genAuxBindSpecSig loc dup_spec)))
-  where
-    loca = noAnnSrcSpan loc
-    locn = noAnnSrcSpan loc
-    dup_rdr_name = auxBindSpecRdrName dup_spec
-
--- | Generate the type signature of an auxiliary binding.
--- See @Note [Auxiliary binders]@.
-genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs
-genAuxBindSpecSig loc spec = case spec of
-  DerivTag2Con tycon _
-    -> mk_sig $ L (noAnnSrcSpan loc) $
-       XHsType $ mkSpecForAllTys (tyConTyVars tycon) $
-       intTy `mkVisFunTyMany` mkParentType tycon
-  DerivMaxTag _ _
-    -> mk_sig (L (noAnnSrcSpan loc) (XHsType intTy))
-  DerivDataDataType _ _ _
-    -> mk_sig (nlHsTyVar NotPromoted dataType_RDR)
-  DerivDataConstr _ _ _
-    -> mk_sig (nlHsTyVar NotPromoted constr_RDR)
-  where
-    mk_sig = mkHsWildCardBndrs . L (noAnnSrcSpan loc) . mkHsImplicitSigType
-
--- | Take a 'Bag' of 'AuxBindSpec's and generate the code for auxiliary
--- bindings based on the declarative descriptions in the supplied
--- 'AuxBindSpec's. See @Note [Auxiliary binders]@.
-genAuxBinds :: SrcSpan -> Bag AuxBindSpec
-            -> Bag (LHsBind GhcPs, LSig GhcPs)
-genAuxBinds loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)
- where
-  -- Perform a CSE-like pass over the generated auxiliary bindings to avoid
-  -- code duplication, as described in
-  -- Note [Auxiliary binders] (Wrinkle: Reducing code duplication).
-  -- The OccEnv remembers the first occurrence of each sort of auxiliary
-  -- binding and maps it to the unique RdrName for that binding.
-  gen_aux_bind_spec :: AuxBindSpec
-                    -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
-                    -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
-  gen_aux_bind_spec spec (original_rdr_name_env, spec_bag) =
-    case lookupOccEnv original_rdr_name_env spec_occ of
-      Nothing
-        -> ( extendOccEnv original_rdr_name_env spec_occ spec_rdr_name
-           , genAuxBindSpecOriginal loc spec `consBag` spec_bag )
-      Just original_rdr_name
-        -> ( original_rdr_name_env
-           , genAuxBindSpecDup loc original_rdr_name spec `consBag` spec_bag )
-    where
-      spec_rdr_name = auxBindSpecRdrName spec
-      spec_occ      = rdrNameOcc spec_rdr_name
-
-mkParentType :: TyCon -> Type
--- Turn the representation tycon of a family into
--- a use of its family constructor
-mkParentType tc
-  = case tyConFamInst_maybe tc of
-       Nothing  -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
-       Just (fam_tc,tys) -> mkTyConApp fam_tc tys
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Utility bits for generating bindings}
-*                                                                      *
-************************************************************************
--}
-
--- | Make a function binding. If no equations are given, produce a function
--- with the given arity that produces a stock error.
-mkFunBindSE :: Arity -> SrcSpan -> RdrName
-             -> [([LPat GhcPs], LHsExpr GhcPs)]
-             -> LHsBind GhcPs
-mkFunBindSE arity loc fun pats_and_exprs
-  = mkRdrFunBindSE arity (L (noAnnSrcSpan loc) fun) matches
-  where
-    matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))
-                               (map (parenthesizePat appPrec) p) e
-                               emptyLocalBinds
-              | (p,e) <-pats_and_exprs]
-
-mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-             -> LHsBind GhcPs
-mkRdrFunBind fun@(L loc _fun_rdr) matches
-  = L (na2la loc) (mkFunBind Generated fun matches)
-
--- | Make a function binding. If no equations are given, produce a function
--- with the given arity that uses an empty case expression for the last
--- argument that is passes to the given function to produce the right-hand
--- side.
-mkFunBindEC :: Arity -> SrcSpan -> RdrName
-            -> (LHsExpr GhcPs -> LHsExpr GhcPs)
-            -> [([LPat GhcPs], LHsExpr GhcPs)]
-            -> LHsBind GhcPs
-mkFunBindEC arity loc fun catch_all pats_and_exprs
-  = mkRdrFunBindEC arity catch_all (L (noAnnSrcSpan loc) fun) matches
-  where
-    matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))
-                                (map (parenthesizePat appPrec) p) e
-                                emptyLocalBinds
-              | (p,e) <- pats_and_exprs ]
-
--- | Produces a function binding. When no equations are given, it generates
--- a binding of the given arity and an empty case expression
--- for the last argument that it passes to the given function to produce
--- the right-hand side.
-mkRdrFunBindEC :: Arity
-               -> (LHsExpr GhcPs -> LHsExpr GhcPs)
-               -> LocatedN RdrName
-               -> [LMatch GhcPs (LHsExpr GhcPs)]
-               -> LHsBind GhcPs
-mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
-  = L (na2la loc) (mkFunBind Generated fun matches')
- where
-   -- Catch-all eqn looks like
-   --     fmap _ z = case z of {}
-   -- or
-   --     traverse _ z = pure (case z of)
-   -- or
-   --     foldMap _ z = mempty
-   -- It's needed if there no data cons at all,
-   -- which can happen with -XEmptyDataDecls
-   -- See #4302
-   matches' = if null matches
-              then [mkMatch (mkPrefixFunRhs fun)
-                            (replicate (arity - 1) nlWildPat ++ [z_Pat])
-                            (catch_all $ nlHsCase z_Expr [])
-                            emptyLocalBinds]
-              else matches
-
--- | Produces a function binding. When there are no equations, it generates
--- a binding with the given arity that produces an error based on the name of
--- the type of the last argument.
-mkRdrFunBindSE :: Arity -> LocatedN RdrName ->
-                    [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
-mkRdrFunBindSE arity fun@(L loc fun_rdr) matches
-  = L (na2la loc) (mkFunBind Generated fun matches')
- where
-   -- Catch-all eqn looks like
-   --     compare _ _ = error "Void compare"
-   -- It's needed if there no data cons at all,
-   -- which can happen with -XEmptyDataDecls
-   -- See #4302
-   matches' = if null matches
-              then [mkMatch (mkPrefixFunRhs fun)
-                            (replicate arity nlWildPat)
-                            (error_Expr str) emptyLocalBinds]
-              else matches
-   str = fsLit "Void " `appendFS` occNameFS (rdrNameOcc fun_rdr)
-
-
-box ::         String           -- The class involved
-            -> LHsExpr GhcPs    -- The argument
-            -> Type             -- The argument type
-            -> LHsExpr GhcPs    -- Boxed version of the arg
--- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer
-box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg
-
----------------------
-primOrdOps :: String    -- The class involved
-           -> Type      -- The type
-           -> (RdrName, RdrName, RdrName, RdrName, RdrName)  -- (lt,le,eq,ge,gt)
--- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer
-primOrdOps str ty = assoc_ty_id str ordOpTbl ty
-
-ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
-ordOpTbl
- =  [(charPrimTy  , (ltChar_RDR  , leChar_RDR
-     , eqChar_RDR  , geChar_RDR  , gtChar_RDR  ))
-    ,(intPrimTy   , (ltInt_RDR   , leInt_RDR
-     , eqInt_RDR   , geInt_RDR   , gtInt_RDR   ))
-    ,(int8PrimTy  , (ltInt8_RDR  , leInt8_RDR
-     , eqInt8_RDR  , geInt8_RDR  , gtInt8_RDR   ))
-    ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR
-     , eqInt16_RDR , geInt16_RDR , gtInt16_RDR   ))
-    ,(int32PrimTy , (ltInt32_RDR , leInt32_RDR
-     , eqInt32_RDR , geInt32_RDR , gtInt32_RDR   ))
-    ,(int64PrimTy , (ltInt64_RDR , leInt64_RDR
-     , eqInt64_RDR , geInt64_RDR , gtInt64_RDR   ))
-    ,(wordPrimTy  , (ltWord_RDR  , leWord_RDR
-     , eqWord_RDR  , geWord_RDR  , gtWord_RDR  ))
-    ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR
-     , eqWord8_RDR , geWord8_RDR , gtWord8_RDR   ))
-    ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR
-     , eqWord16_RDR, geWord16_RDR, gtWord16_RDR  ))
-    ,(word32PrimTy, (ltWord32_RDR, leWord32_RDR
-     , eqWord32_RDR, geWord32_RDR, gtWord32_RDR  ))
-    ,(word64PrimTy, (ltWord64_RDR, leWord64_RDR
-     , eqWord64_RDR, geWord64_RDR, gtWord64_RDR  ))
-    ,(addrPrimTy  , (ltAddr_RDR  , leAddr_RDR
-     , eqAddr_RDR  , geAddr_RDR  , gtAddr_RDR  ))
-    ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR
-     , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
-    ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR
-     , eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
-
--- A mapping from a primitive type to a function that constructs its boxed
--- version.
--- NOTE: Int8#/Word8# will become Int/Word.
-boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
-boxConTbl =
-    [ (charPrimTy  , nlHsApp (nlHsVar $ getRdrName charDataCon))
-    , (intPrimTy   , nlHsApp (nlHsVar $ getRdrName intDataCon))
-    , (wordPrimTy  , nlHsApp (nlHsVar $ getRdrName wordDataCon ))
-    , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon ))
-    , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon))
-    , (int8PrimTy,
-        nlHsApp (nlHsVar $ getRdrName intDataCon)
-        . nlHsApp (nlHsVar int8ToInt_RDR))
-    , (word8PrimTy,
-        nlHsApp (nlHsVar $ getRdrName wordDataCon)
-        . nlHsApp (nlHsVar word8ToWord_RDR))
-    , (int16PrimTy,
-        nlHsApp (nlHsVar $ getRdrName intDataCon)
-        . nlHsApp (nlHsVar int16ToInt_RDR))
-    , (word16PrimTy,
-        nlHsApp (nlHsVar $ getRdrName wordDataCon)
-        . nlHsApp (nlHsVar word16ToWord_RDR))
-    , (int32PrimTy,
-        nlHsApp (nlHsVar $ getRdrName intDataCon)
-        . nlHsApp (nlHsVar int32ToInt_RDR))
-    , (word32PrimTy,
-        nlHsApp (nlHsVar $ getRdrName wordDataCon)
-        . nlHsApp (nlHsVar word32ToWord_RDR))
-    ]
-
-
--- | A table of postfix modifiers for unboxed values.
-postfixModTbl :: [(Type, String)]
-postfixModTbl
-  = [(charPrimTy  , "#" )
-    ,(intPrimTy   , "#" )
-    ,(wordPrimTy  , "##")
-    ,(floatPrimTy , "#" )
-    ,(doublePrimTy, "##")
-    ,(int8PrimTy, "#")
-    ,(word8PrimTy, "##")
-    ,(int16PrimTy, "#")
-    ,(word16PrimTy, "##")
-    ,(int32PrimTy, "#")
-    ,(word32PrimTy, "##")
-    ]
-
-primConvTbl :: [(Type, String)]
-primConvTbl =
-    [ (int8PrimTy, "intToInt8#")
-    , (word8PrimTy, "wordToWord8#")
-    , (int16PrimTy, "intToInt16#")
-    , (word16PrimTy, "wordToWord16#")
-    , (int32PrimTy, "intToInt32#")
-    , (word32PrimTy, "wordToWord32#")
-    ]
-
-litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
-litConTbl
-  = [(charPrimTy  , nlHsApp (nlHsVar charPrimL_RDR))
-    ,(intPrimTy   , nlHsApp (nlHsVar intPrimL_RDR)
-                      . nlHsApp (nlHsVar toInteger_RDR))
-    ,(wordPrimTy  , nlHsApp (nlHsVar wordPrimL_RDR)
-                      . nlHsApp (nlHsVar toInteger_RDR))
-    ,(addrPrimTy  , nlHsApp (nlHsVar stringPrimL_RDR)
-                      . nlHsApp (nlHsApp
-                          (nlHsVar map_RDR)
-                          (compose_RDR `nlHsApps`
-                            [ nlHsVar fromIntegral_RDR
-                            , nlHsVar fromEnum_RDR
-                            ])))
-    ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
-                      . nlHsApp (nlHsVar toRational_RDR))
-    ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
-                      . nlHsApp (nlHsVar toRational_RDR))
-    ]
-
--- | Lookup `Type` in an association list.
-assoc_ty_id :: HasCallStack => String           -- The class involved
-            -> [(Type,a)]       -- The table
-            -> Type             -- The type
-            -> a                -- The result of the lookup
-assoc_ty_id cls_str tbl ty
-  | Just a <- assoc_ty_id_maybe tbl ty = a
-  | otherwise =
-      pprPanic "Error in deriving:"
-          (text "Can't derive" <+> text cls_str <+>
-           text "for primitive type" <+> ppr ty)
-
--- | Lookup `Type` in an association list.
-assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a
-assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl
-
------------------------------------------------------------------------
-
-and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-and_Expr a b = genOpApp a and_RDR    b
-
------------------------------------------------------------------------
-
-eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-eq_Expr ty a b
-    | not (isUnliftedType ty) = genOpApp a eq_RDR b
-    | otherwise               = genPrimOpApp a prim_eq b
- where
-   (_, _, prim_eq, _, _) = primOrdOps "Eq" ty
-
-untag_Expr :: [(RdrName, RdrName)]
-           -> LHsExpr GhcPs -> LHsExpr GhcPs
-untag_Expr [] expr = expr
-untag_Expr ((untag_this, put_tag_here) : more) expr
-  = nlHsCase (nlHsPar (nlHsVarApps dataToTag_RDR [untag_this])) {-of-}
-      [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr more expr)]
-
-enum_from_to_Expr
-        :: LHsExpr GhcPs -> LHsExpr GhcPs
-        -> LHsExpr GhcPs
-enum_from_then_to_Expr
-        :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-        -> LHsExpr GhcPs
-
-enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
-enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
-
-showParen_Expr
-        :: LHsExpr GhcPs -> LHsExpr GhcPs
-        -> LHsExpr GhcPs
-
-showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
-
-nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
-
-nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
-nested_compose_Expr [e] = parenify e
-nested_compose_Expr (e:es)
-  = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
-
--- impossible_Expr is used in case RHSs that should never happen.
--- We generate these to keep the desugarer from complaining that they *might* happen!
-error_Expr :: FastString -> LHsExpr GhcPs
-error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsStringFS string))
-
--- illegal_Expr is used when signalling error conditions in the RHS of a derived
--- method. It is currently only used by Enum.{succ,pred}
-illegal_Expr :: String -> String -> String -> LHsExpr GhcPs
-illegal_Expr meth tp msg =
-   nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
-
--- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
--- to include the value of a_RDR in the error string.
-illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs
-illegal_toEnum_tag tp maxtag =
-   nlHsApp (nlHsVar error_RDR)
-           (nlHsApp (nlHsApp (nlHsVar append_RDR)
-                       (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
-                    (nlHsApp (nlHsApp (nlHsApp
-                           (nlHsVar showsPrec_RDR)
-                           (nlHsIntLit 0))
-                           (nlHsVar a_RDR))
-                           (nlHsApp (nlHsApp
-                               (nlHsVar append_RDR)
-                               (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
-                               (nlHsApp (nlHsApp (nlHsApp
-                                        (nlHsVar showsPrec_RDR)
-                                        (nlHsIntLit 0))
-                                        (nlHsVar maxtag))
-                                        (nlHsLit (mkHsString ")"))))))
-
-parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
-parenify e@(L _ (HsVar _ _)) = e
-parenify e                   = mkHsPar e
-
--- genOpApp wraps brackets round the operator application, so that the
--- renamer won't subsequently try to re-associate it.
-genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
-genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
-
-genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
-genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
-
-a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
-    :: RdrName
-a_RDR           = mkVarUnqual (fsLit "a")
-b_RDR           = mkVarUnqual (fsLit "b")
-c_RDR           = mkVarUnqual (fsLit "c")
-d_RDR           = mkVarUnqual (fsLit "d")
-f_RDR           = mkVarUnqual (fsLit "f")
-k_RDR           = mkVarUnqual (fsLit "k")
-z_RDR           = mkVarUnqual (fsLit "z")
-ah_RDR          = mkVarUnqual (fsLit "a#")
-bh_RDR          = mkVarUnqual (fsLit "b#")
-ch_RDR          = mkVarUnqual (fsLit "c#")
-dh_RDR          = mkVarUnqual (fsLit "d#")
-
-as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
-as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
-bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
-cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
-
-a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
-    true_Expr, pure_Expr, unsafeCodeCoerce_Expr :: LHsExpr GhcPs
-a_Expr                = nlHsVar a_RDR
-b_Expr                = nlHsVar b_RDR
-c_Expr                = nlHsVar c_RDR
-z_Expr                = nlHsVar z_RDR
-ltTag_Expr            = nlHsVar ltTag_RDR
-eqTag_Expr            = nlHsVar eqTag_RDR
-gtTag_Expr            = nlHsVar gtTag_RDR
-false_Expr            = nlHsVar false_RDR
-true_Expr             = nlHsVar true_RDR
-pure_Expr             = nlHsVar pure_RDR
-unsafeCodeCoerce_Expr = nlHsVar unsafeCodeCoerce_RDR
-
-a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs
-a_Pat           = nlVarPat a_RDR
-b_Pat           = nlVarPat b_RDR
-c_Pat           = nlVarPat c_RDR
-d_Pat           = nlVarPat d_RDR
-k_Pat           = nlVarPat k_RDR
-z_Pat           = nlVarPat z_RDR
-
-minusInt_RDR, tagToEnum_RDR :: RdrName
-minusInt_RDR  = getRdrName (primOpId IntSubOp   )
-tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
-
-new_tag2con_rdr_name, new_maxtag_rdr_name
-  :: SrcSpan -> TyCon -> TcM RdrName
--- Generates Exact RdrNames, for the binding positions
-new_tag2con_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkTag2ConOcc
-new_maxtag_rdr_name  dflags tycon = new_tc_deriv_rdr_name dflags tycon mkMaxTagOcc
-
-new_dataT_rdr_name :: SrcSpan -> TyCon -> TcM RdrName
-new_dataT_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkDataTOcc
-
-new_dataC_rdr_name :: SrcSpan -> DataCon -> TcM RdrName
-new_dataC_rdr_name dflags dc = new_dc_deriv_rdr_name dflags dc mkDataCOcc
-
-new_tc_deriv_rdr_name :: SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName
-new_tc_deriv_rdr_name loc tycon occ_fun
-  = newAuxBinderRdrName loc (tyConName tycon) occ_fun
-
-new_dc_deriv_rdr_name :: SrcSpan -> DataCon -> (OccName -> OccName) -> TcM RdrName
-new_dc_deriv_rdr_name loc dc occ_fun
-  = newAuxBinderRdrName loc (dataConName dc) occ_fun
-
--- | Generate the name for an auxiliary binding, giving it a fresh 'Unique'.
--- Returns an 'Exact' 'RdrName' with an underlying 'System' 'Name'.
--- See @Note [Auxiliary binders]@.
-newAuxBinderRdrName :: SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName
-newAuxBinderRdrName loc parent occ_fun = do
-  uniq <- newUnique
-  pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc
-
--- | @getPossibleDataCons tycon tycon_args@ returns the constructors of @tycon@
--- whose return types match when checked against @tycon_args@.
---
--- See Note [Filter out impossible GADT data constructors]
-getPossibleDataCons :: TyCon -> [Type] -> [DataCon]
-getPossibleDataCons tycon tycon_args = filter isPossible $ tyConDataCons tycon
-  where
-    isPossible dc = not $ dataConCannotMatch (dataConInstUnivs dc tycon_args) dc
-
--- | Information about the arguments to the class in a stock- or
--- newtype-derived instance. For a @deriving@-generated instance declaration
--- such as this one:
---
--- @
--- instance Ctx => Cls cls_ty_1 ... cls_ty_m (TC tc_arg_1 ... tc_arg_n) where ...
--- @
---
--- * 'dit_cls_tys' corresponds to @cls_ty_1 ... cls_ty_m@.
---
--- * 'dit_tc' corresponds to @TC@.
---
--- * 'dit_tc_args' corresponds to @tc_arg_1 ... tc_arg_n@.
---
--- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for a
--- more in-depth explanation, including the relationship between
--- 'dit_tc'/'dit_rep_tc' and 'dit_tc_args'/'dit_rep_tc_args'.
---
--- A 'DerivInstTys' value can be seen as a more structured representation of
--- the 'denv_inst_tys' in a 'DerivEnv', as the 'denv_inst_tys' is equal to
--- @dit_cls_tys ++ ['mkTyConApp' dit_tc dit_tc_args]@. Other parts of the
--- instance declaration can be found in the 'DerivEnv'. For example, the @Cls@
--- in the example above corresponds to the 'denv_cls' field of 'DerivEnv'.
---
--- Similarly, the type variables that appear in a 'DerivInstTys' value are the
--- same type variables as the 'denv_tvs' in the parent 'DerivEnv'. Accordingly,
--- if we are inferring an instance context, the type variables will be 'TcTyVar'
--- skolems. Otherwise, they will be ordinary 'TyVar's.
--- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".
-data DerivInstTys = DerivInstTys
-  { dit_cls_tys     :: [Type]
-    -- ^ Other arguments to the class except the last
-  , dit_tc          :: TyCon
-    -- ^ Type constructor for which the instance is requested
-    --   (last arguments to the type class)
-  , dit_tc_args     :: [Type]
-    -- ^ Arguments to the type constructor
-  , dit_rep_tc      :: TyCon
-    -- ^ The representation tycon for 'dit_tc'
-    --   (for data family instances). Otherwise the same as 'dit_tc'.
-  , dit_rep_tc_args :: [Type]
-    -- ^ The representation types for 'dit_tc_args'
-    --   (for data family instances). Otherwise the same as 'dit_tc_args'.
-  , dit_dc_inst_arg_env :: DataConEnv [Type]
-    -- ^ The cached results of instantiating each data constructor's field
-    --   types using @'dataConInstUnivs' data_con 'dit_rep_tc_args'@.
-    --   See @Note [Instantiating field types in stock deriving]@.
-    --
-    --   This field is only used for stock-derived instances and goes unused
-    --   for newtype-derived instances. It is put here mainly for the sake of
-    --   convenience.
-  }
-
-instance Outputable DerivInstTys where
-  ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args
-                    , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args
-                    , dit_dc_inst_arg_env = dc_inst_arg_env })
-    = hang (text "DerivInstTys")
-         2 (vcat [ text "dit_cls_tys"         <+> ppr cls_tys
-                 , text "dit_tc"              <+> ppr tc
-                 , text "dit_tc_args"         <+> ppr tc_args
-                 , text "dit_rep_tc"          <+> ppr rep_tc
-                 , text "dit_rep_tc_args"     <+> ppr rep_tc_args
-                 , text "dit_dc_inst_arg_env" <+> ppr dc_inst_arg_env ])
-
--- | Look up a data constructor's instantiated field types in a 'DerivInstTys'.
--- See @Note [Instantiating field types in stock deriving]@.
-derivDataConInstArgTys :: DataCon -> DerivInstTys -> [Type]
-derivDataConInstArgTys dc dit =
-  case lookupUFM (dit_dc_inst_arg_env dit) dc of
-    Just inst_arg_tys -> inst_arg_tys
-    Nothing           -> pprPanic "derivDataConInstArgTys" (ppr dc)
-
--- | @'buildDataConInstArgEnv' tycon arg_tys@ constructs a cache that maps
--- each of @tycon@'s data constructors to their field types, with are to be
--- instantiated with @arg_tys@.
--- See @Note [Instantiating field types in stock deriving]@.
-buildDataConInstArgEnv :: TyCon -> [Type] -> DataConEnv [Type]
-buildDataConInstArgEnv rep_tc rep_tc_args =
-  listToUFM [ (dc, inst_arg_tys)
-            | dc <- tyConDataCons rep_tc
-            , let (_, _, inst_arg_tys) =
-                    dataConInstSig dc $ dataConInstUnivs dc rep_tc_args
-            ]
-
--- | Apply a substitution to all of the 'Type's contained in a 'DerivInstTys'.
--- See @Note [Instantiating field types in stock deriving]@ for why we need to
--- substitute into a 'DerivInstTys' in the first place.
-substDerivInstTys :: Subst -> DerivInstTys -> DerivInstTys
-substDerivInstTys subst
-  dit@(DerivInstTys { dit_cls_tys = cls_tys, dit_tc_args = tc_args
-                    , dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args })
-
-  | isEmptyTCvSubst subst
-  = dit
-  | otherwise
-  = dit{ dit_cls_tys         = cls_tys'
-       , dit_tc_args         = tc_args'
-       , dit_rep_tc_args     = rep_tc_args'
-       , dit_dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args'
-       }
-  where
-    cls_tys'     = substTys subst cls_tys
-    tc_args'     = substTys subst tc_args
-    rep_tc_args' = substTys subst rep_tc_args
-
--- | Zonk the 'TcTyVar's in a 'DerivInstTys' value to 'TyVar's.
--- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType".
---
--- This is only used in the final zonking step when inferring
--- the context for a derived instance.
--- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".
-zonkDerivInstTys :: ZonkEnv -> DerivInstTys -> TcM DerivInstTys
-zonkDerivInstTys ze dit@(DerivInstTys { dit_cls_tys = cls_tys
-                                      , dit_tc_args = tc_args
-                                      , dit_rep_tc = rep_tc
-                                      , dit_rep_tc_args = rep_tc_args }) = do
-  cls_tys'     <- zonkTcTypesToTypesX ze cls_tys
-  tc_args'     <- zonkTcTypesToTypesX ze tc_args
-  rep_tc_args' <- zonkTcTypesToTypesX ze rep_tc_args
-  pure dit{ dit_cls_tys         = cls_tys'
-          , dit_tc_args         = tc_args'
-          , dit_rep_tc_args     = rep_tc_args'
-          , dit_dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args'
-          }
-
-{-
-Note [Auxiliary binders]
-~~~~~~~~~~~~~~~~~~~~~~~~
-We often want to make top-level auxiliary bindings in derived instances.
-For example, derived Ix instances sometimes generate code like this:
-
-  data T = ...
-  deriving instance Ix T
-
-  ==>
-
-  instance Ix T where
-    range (a, b) = map tag2con_T [dataToTag# a .. dataToTag# b]
-
-  $tag2con_T :: Int -> T
-  $tag2con_T = ...code....
-
-Note that multiple instances of the same type might need to use the same sort
-of auxiliary binding. For example, $tag2con is used not only in derived Ix
-instances, but also in derived Enum instances:
-
-  deriving instance Enum T
-
-  ==>
-
-  instance Enum T where
-    toEnum i = tag2con_T i
-
-  $tag2con_T :: Int -> T
-  $tag2con_T = ...code....
-
-How do we ensure that the two usages of $tag2con_T do not conflict with each
-other? We do so by generating a separate $tag2con_T definition for each
-instance, giving each definition an Exact RdrName with a separate Unique to
-avoid name clashes:
-
-  instance Ix T where
-    range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b]
-
-  instance Enum T where
-    toEnum a = $tag2con_T{Uniq2} a
-
-   -- $tag2con_T{Uniq1} and $tag2con_T{Uniq2} are Exact RdrNames with
-   -- underlying System Names
-
-   $tag2con_T{Uniq1} :: Int -> T
-   $tag2con_T{Uniq1} = ...code....
-
-   $tag2con_T{Uniq2} :: Int -> T
-   $tag2con_T{Uniq2} = ...code....
-
-Note that:
-
-* This is /precisely/ the same mechanism that we use for
-  Template Haskell–generated code.
-  See Note [Binders in Template Haskell] in GHC.ThToHs.
-  There we explain why we use a 'System' flavour of the Name we generate.
-
-* See "Wrinkle: Reducing code duplication" for how we can avoid generating
-  lots of duplicated code in common situations.
-
-* See "Wrinkle: Why we sometimes do generated duplicate code" for why this
-  de-duplication mechanism isn't perfect, so we fall back to CSE
-  (which is very effective within a single module).
-
-* Note that the "_T" part of "$tag2con_T" is just for debug-printing
-  purposes. We could call them all "$tag2con", or even just "aux".
-  The Unique is enough to keep them separate.
-
-  This is important: we might be generating an Eq instance for two
-  completely-distinct imported type constructors T.
-
-At first glance, it might appear that this plan is infeasible, as it would
-require generating multiple top-level declarations with the same OccName. But
-what if auxiliary bindings /weren't/ top-level? Conceptually, we could imagine
-that auxiliary bindings are /local/ to the instance declarations in which they
-are used. Using some hypothetical Haskell syntax, it might look like this:
-
-  let {
-    $tag2con_T{Uniq1} :: Int -> T
-    $tag2con_T{Uniq1} = ...code....
-
-    $tag2con_T{Uniq2} :: Int -> T
-    $tag2con_T{Uniq2} = ...code....
-  } in {
-    instance Ix T where
-      range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b]
-
-    instance Enum T where
-      toEnum a = $tag2con_T{Uniq2} a
-  }
-
-Making auxiliary bindings local is key to making this work, since GHC will
-not reject local bindings with duplicate names provided that:
-
-* Each binding has a distinct unique, and
-* Each binding has an Exact RdrName with a System Name.
-
-Even though the hypothetical Haskell syntax above does not exist, we can
-accomplish the same end result through some sleight of hand in renameDeriv:
-we rename auxiliary bindings with rnLocalValBindsLHS. (If we had used
-rnTopBindsLHS instead, then GHC would spuriously reject auxiliary bindings
-with the same OccName as duplicates.) Luckily, no special treatment is needed
-to typecheck them; we can typecheck them as normal top-level bindings
-(using tcTopBinds) without danger.
-
------
--- Wrinkle: Reducing code duplication
------
-
-While the approach of generating copies of each sort of auxiliary binder per
-derived instance is simpler, it can lead to code bloat if done naïvely.
-Consider this example:
-
-  data T = ...
-  deriving instance Eq T
-  deriving instance Ord T
-
-  ==>
-
-  instance Ix T where
-    range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b]
-
-  instance Enum T where
-    toEnum a = $tag2con_T{Uniq2} a
-
-  $tag2con_T{Uniq1} :: Int -> T
-  $tag2con_T{Uniq1} = ...code....
-
-  $tag2con_T{Uniq2} :: Int -> T
-  $tag2con_T{Uniq2} = ...code....
-
-$tag2con_T{Uniq1} and $tag2con_T{Uniq2} are blatant duplicates of each other,
-which is not ideal. Surely GHC can do better than that at the very least! And
-indeed it does. Within the genAuxBinds function, GHC performs a small CSE-like
-pass to define duplicate auxiliary binders in terms of the original one. On
-the example above, that would look like this:
-
-  $tag2con_T{Uniq1} :: Int -> T
-  $tag2con_T{Uniq1} = ...code....
-
-  $tag2con_T{Uniq2} :: Int -> T
-  $tag2con_T{Uniq2} = $tag2con_T{Uniq1}
-
-(Note that this pass does not cover all possible forms of code duplication.
-See "Wrinkle: Why we sometimes do generate duplicate code" for situations
-where genAuxBinds does not deduplicate code.)
-
-To start, genAuxBinds is given a list of AuxBindSpecs, which describe the sort
-of auxiliary bindings that must be generates along with their RdrNames. As
-genAuxBinds processes this list, it marks the first occurrence of each sort of
-auxiliary binding as the "original". For example, if genAuxBinds sees a
-DerivCon2Tag for the first time (with the RdrName $tag2con_T{Uniq1}), then it
-will generate the full code for a $tag2con binding:
-
-  $tag2con_T{Uniq1} :: Int -> T
-  $tag2con_T{Uniq1} = ...code....
-
-Later, if genAuxBinds sees any additional DerivCon2Tag values, it will treat
-them as duplicates. For example, if genAuxBinds later sees a DerivCon2Tag with
-the RdrName $tag2con_T{Uniq2}, it will generate this code, which is much more
-compact:
-
-  $tag2con_T{Uniq2} :: Int -> T
-  $tag2con_T{Uniq2} = $tag2con_T{Uniq1}
-
-An alternative approach would be /not/ performing any kind of deduplication in
-genAuxBinds at all and simply relying on GHC's simplifier to perform this kind
-of CSE. But this is a more expensive analysis in general, while genAuxBinds can
-accomplish the same result with a simple check.
-
------
--- Wrinkle: Why we sometimes do generate duplicate code
------
-
-It is worth noting that deduplicating auxiliary binders is difficult in the
-general case. Here are two particular examples where GHC cannot easily remove
-duplicate copies of an auxiliary binding:
-
-1. When derived instances are contained in different modules, as in the
-   following example:
-
-     module A where
-       data T = ...
-     module B where
-       import A
-       deriving instance Ix T
-     module C where
-       import B
-       deriving instance Enum T
-
-   The derived Eq and Enum instances for T make use of $tag2con_T, and since
-   they are defined in separate modules, each module must produce its own copy
-   of $tag2con_T.
-
-2. When derived instances are separated by TH splices (#18321), as in the
-   following example:
-
-     module M where
-
-     data T = ...
-     deriving instance Ix T
-     $(pure [])
-     deriving instance Enum T
-
-   Due to the way that GHC typechecks TyClGroups, genAuxBinds will run twice
-   in this program: once for all the declarations before the TH splice, and
-   once again for all the declarations after the TH splice. As a result,
-   $tag2con_T will be generated twice, since genAuxBinds will be unable to
-   recognize the presence of duplicates.
-
-These situations are much rarer, so we do not spend any effort to deduplicate
-auxiliary bindings there. Instead, we focus on the common case of multiple
-derived instances within the same module, not separated by any TH splices.
-(This is the case described in "Wrinkle: Reducing code duplication".) In
-situation (1), we can at least fall back on GHC's simplifier to pick up
-genAuxBinds' slack.
-
-Note [Filter out impossible GADT data constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Some stock-derivable classes will filter out impossible GADT data constructors,
-to rule out problematic constructors when deriving instances. e.g.
-
-```
-data Foo a where
-  X :: Foo Int
-  Y :: (Bool -> Bool) -> Foo Bool
-```
-
-when deriving an instance on `Foo Int`, `Y` should be treated as if it didn't
-exist in the first place. For instance, if we write
-
-```
-deriving instance Eq (Foo Int)
-```
-
-it should generate:
-
-```
-instance Eq (Foo Int) where
-  X == X = True
-```
-
-Classes that filter constructors:
-
-* Eq
-* Ord
-* Show
-* Lift
-* Functor
-* Foldable
-* Traversable
-
-Classes that do not filter constructors:
-
-* Enum: doesn't make sense for GADTs in the first place
-* Bounded: only makes sense for GADTs with a single constructor
-* Ix: only makes sense for GADTs with a single constructor
-* Read: `Read a` returns `a` instead of consumes `a`, so filtering data
-  constructors would make this function _more_ partial instead of less
-* Data: derived implementations of gunfold rely on a constructor-indexing
-  scheme that wouldn't work if certain constructors were filtered out
-* Generic/Generic1: doesn't make sense for GADTs
-
-Classes that do not currently filter constructors may do so in the future, if
-there is a valid use-case and we have requirements for how they should work.
-
-See #16341 and the T16341.hs test case.
-
-Note [Instantiating field types in stock deriving]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Figuring out what the types of data constructor fields are in `deriving` can
-be surprisingly tricky. Here are some examples (adapted from #20375) to set
-the scene:
-
-  data Ta = MkTa Int#
-  data Tb (x :: TYPE IntRep) = MkTb x
-
-  deriving instance Eq Ta        -- 1.
-  deriving instance Eq (Tb a)    -- 2.
-  deriving instance Eq (Tb Int#) -- 3.
-
-Example (1) is accepted, as `deriving Eq` has a special case for fields of type
-Int#. Example (2) is rejected, however, as the special case for Int# does not
-extend to all types of kind (TYPE IntRep).
-
-Example (3) ought to typecheck. If you instantiate the field of type `x` in
-MkTb to be Int#, then `deriving Eq` is capable of handling that. We must be
-careful, however. If we naïvely use, say, `dataConOrigArgTys` to retrieve the
-field types, then we would get `b`, which `deriving Eq` would reject. In
-order to handle `deriving Eq` (and, more generally, any stock deriving
-strategy) correctly, we /must/ instantiate the field types as needed.
-Not doing so led to #20375 and #20387.
-
-In fact, we end up needing to instantiate the field types in quite a few
-places:
-
-* When performing validity checks for stock deriving strategies (e.g., in
-  GHC.Tc.Deriv.Utils.cond_stdOK)
-
-* When inferring the instance context in
-  GHC.Tc.Deriv.Infer.inferConstraintStock
-
-* When generating code for stock-derived instances in
-  GHC.Tc.Deriv.{Functor,Generate,Generics}
-
-Repeatedly performing these instantiations in multiple places would be
-wasteful, so we build a cache of data constructor field instantiations in
-the `dit_dc_inst_arg_env` field of DerivInstTys. Specifically:
-
-1. When beginning to generate code for a stock-derived instance
-   `T arg_1 ... arg_n`, the `dit_dc_inst_arg_env` field is created by taking
-   each data constructor `dc`, instantiating its field types with
-   `dataConInstUnivs dc [arg_1, ..., arg_n]`, and mapping `dc` to the
-   instantiated field types in the cache. The `buildDataConInstArgEnv` function
-   is responsible for orchestrating this.
-
-2. When a part of the code in GHC.Tc.Deriv.* needs to look up the field
-   types, we deliberately avoid using `dataConOrigArgTys`. Instead, we use
-   `derivDataConInstArgTys`, which looks up a DataCon's instantiated field
-   types in the cache.
-
-StandaloneDeriving is one way for the field types to become instantiated.
-Another way is by deriving Functor and related classes, as chronicled in
-Note [Inferring the instance context] in GHC.Tc.Deriv.Infer. Here is one such
-example:
-
-  newtype Compose (f :: k -> Type) (g :: j -> k) (a :: j) = Compose (f (g a))
-    deriving Generic1
-
-This ultimately generates the following instance:
-
-  instance forall (f :: Type -> Type) (g :: j -> Type).
-    Functor f => Generic1 (Compose f g) where ...
-
-Note that because of the inferred `Functor f` constraint, `k` was instantiated
-to be `Type`. GHC's deriving machinery doesn't realize this until it performs
-constraint inference (in GHC.Tc.Deriv.Infer.inferConstraintsStock), however,
-which is *after* the initial DerivInstTys has been created. As a result, the
-`dit_dc_inst_arg_env` field might need to be updated after constraint inference,
-as the inferred constraints might instantiate the field types further.
-
-This is accomplished by way of `substDerivInstTys`, which substitutes all of
-the fields in a `DerivInstTys`, including the `dit_dc_inst_arg_env`.
-It is important to do this in inferConstraintsStock, as the
-deriving/should_compile/T20387 test case will not compile otherwise.
--}
diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ /dev/null
@@ -1,1116 +0,0 @@
-
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies        #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-{-
-(c) The University of Glasgow 2011
-
--}
-
--- | The deriving code for the Generic class
-module GHC.Tc.Deriv.Generics
-   ( canDoGenerics
-   , canDoGenerics1
-   , GenericKind(..)
-   , gen_Generic_binds
-   , gen_Generic_fam_inst
-   , get_gen1_constrained_tys
-   )
-where
-
-import GHC.Prelude hiding (head, init, last, tail)
-
-import GHC.Hs
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Deriv.Generate
-import GHC.Tc.Deriv.Functor
-import GHC.Tc.Errors.Types
-import GHC.Tc.Instance.Family
-
-import GHC.Core.Type
-import GHC.Core.DataCon
-import GHC.Core.TyCon
-import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom )
-
-import GHC.Unit.Module ( moduleName, moduleUnit
-                       , unitFS, getModule )
-
-import GHC.Iface.Env    ( newGlobalBinder )
-
-import GHC.Types.Name hiding ( varName )
-import GHC.Types.Name.Reader
-import GHC.Types.SourceText
-import GHC.Types.Fixity
-import GHC.Types.Basic
-import GHC.Builtin.Types.Prim
-import GHC.Builtin.Types
-import GHC.Builtin.Names
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.Monad
-import GHC.Driver.Session
-import GHC.Utils.Error( Validity'(..), andValid )
-import GHC.Types.SrcLoc
-import GHC.Data.Bag
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set (elemVarSet)
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Data.FastString
-import GHC.Utils.Misc
-
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-import Control.Monad (mplus)
-import Data.List (zip4, partition)
-import qualified Data.List as Partial (last)
-import Data.List.NonEmpty (nonEmpty)
-import qualified Data.List.NonEmpty as NE
-import Data.Maybe (isJust)
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Bindings for the new generic deriving mechanism}
-*                                                                      *
-************************************************************************
-
-For the generic representation we need to generate:
-\begin{itemize}
-\item A Generic instance
-\item A Rep type instance
-\item Many auxiliary datatypes and instances for them (for the meta-information)
-\end{itemize}
--}
-
-gen_Generic_binds :: GenericKind -> SrcSpan -> DerivInstTys
-                  -> TcM (LHsBinds GhcPs, [LSig GhcPs])
-gen_Generic_binds gk loc dit = do
-  dflags <- getDynFlags
-  return $ mkBindsRep dflags gk loc dit
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Generating representation types}
-*                                                                      *
-************************************************************************
--}
-
--- | Called by 'GHC.Tc.Deriv.Infer.inferConstraints'; generates a list of
--- types, each of which must be a 'Functor' in order for the 'Generic1'
--- instance to work. For instance, if we have:
---
--- @
--- data Foo a = MkFoo Int a (Maybe a) (Either Int (Maybe a))
--- @
---
--- Then @'get_gen1_constrained_tys' a (f (g a))@ would return @[Either Int]@,
--- as a derived 'Generic1' instance would need to call 'fmap' at that type.
--- Invoking @'get_gen1_constrained_tys' a@ on any of the other fields would
--- return @[]@.
---
--- 'get_gen1_constrained_tys' is very similar in spirit to
--- 'deepSubtypesContaining' in "GHC.Tc.Deriv.Functor". Just like with
--- 'deepSubtypesContaining', it is important that the 'TyVar' argument come
--- from 'dataConUnivTyVars'. (See #22167 for what goes wrong if 'tyConTyVars'
--- is used.)
-get_gen1_constrained_tys :: TyVar -> Type -> [Type]
-get_gen1_constrained_tys argVar
-  = argTyFold argVar $ ArgTyAlg { ata_rec0 = const []
-                                , ata_par1 = [], ata_rec1 = const []
-                                , ata_comp = (:) }
-
-{-
-
-Note [Requirements for deriving Generic and Rep]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-In the following, T, Tfun, and Targ are "meta-variables" ranging over type
-expressions.
-
-(Generic T) and (Rep T) are derivable for some type expression T if the
-following constraints are satisfied.
-
-  (a) D is a type constructor *value*. In other words, D is either a type
-      constructor or it is equivalent to the head of a data family instance (up to
-      alpha-renaming).
-
-  (b) D cannot have a "stupid context".
-      See Note [The stupid context] in GHC.Core.DataCon.
-
-  (c) The right-hand side of D cannot include existential types, universally
-      quantified types, or "exotic" unlifted types. An exotic unlifted type
-      is one which is not listed in the definition of allowedUnliftedTy
-      (i.e., one for which we have no representation type).
-      See Note [Generics and unlifted types]
-
-  (d) T :: *.
-
-(Generic1 T) and (Rep1 T) are derivable for some type expression T if the
-following constraints are satisfied.
-
-  (a),(b),(c) As above.
-
-  (d) T must expect arguments, and its last parameter must have kind *.
-
-      We use `a' to denote the parameter of D that corresponds to the last
-      parameter of T.
-
-  (e) For any type-level application (Tfun Targ) in the right-hand side of D
-      where the head of Tfun is not a tuple constructor:
-
-      (b1) `a' must not occur in Tfun.
-
-      (b2) If `a' occurs in Targ, then Tfun :: * -> *.
-
--}
-
-canDoGenerics :: DerivInstTys -> Validity' [DeriveGenericsErrReason]
--- canDoGenerics determines if Generic/Rep can be derived.
---
--- Check (a) from Note [Requirements for deriving Generic and Rep] is taken
--- care of because canDoGenerics is applied to rep tycons.
---
--- It returns IsValid if deriving is possible. It returns (NotValid reason)
--- if not.
-canDoGenerics dit@(DerivInstTys{dit_rep_tc = tc})
-  = mergeErrors (
-          -- Check (b) from Note [Requirements for deriving Generic and Rep].
-              (if (not (null (tyConStupidTheta tc)))
-                then (NotValid $ DerivErrGenericsMustNotHaveDatatypeContext tc_name)
-                else IsValid)
-          -- See comment below
-            : (map bad_con (tyConDataCons tc)))
-  where
-    -- The tc can be a representation tycon. When we want to display it to the
-    -- user (in an error message) we should print its parent
-    tc_name = case tyConFamInst_maybe tc of
-        Just (ptc, _) -> ptc
-        _             -> tc
-
-        -- Check (c) from Note [Requirements for deriving Generic and Rep].
-        --
-        -- If any of the constructors has an exotic unlifted type as argument,
-        -- then we can't build the embedding-projection pair, because
-        -- it relies on instantiating *polymorphic* sum and product types
-        -- at the argument types of the constructors
-    bad_con :: DataCon -> Validity' DeriveGenericsErrReason
-    bad_con dc = if any bad_arg_type (derivDataConInstArgTys dc dit)
-                  then NotValid $ DerivErrGenericsMustNotHaveExoticArgs dc
-                  else if not (isVanillaDataCon dc)
-                          then NotValid $ DerivErrGenericsMustBeVanillaDataCon dc
-                          else IsValid
-
-        -- Nor can we do the job if it's an existential data constructor,
-        -- Nor if the args are polymorphic types (I don't think)
-    bad_arg_type ty = (mightBeUnliftedType ty && not (allowedUnliftedTy ty))
-                      || not (isTauTy ty)
-
--- Returns True the Type argument is an unlifted type which has a
--- corresponding generic representation type. For example,
--- (allowedUnliftedTy Int#) would return True since there is the UInt
--- representation type.
-allowedUnliftedTy :: Type -> Bool
-allowedUnliftedTy = isJust . unboxedRepRDRs
-
-mergeErrors :: [Validity' a] -> Validity' [a]
-mergeErrors []             = IsValid
-mergeErrors (NotValid s:t) = case mergeErrors t of
-  IsValid     -> NotValid [s]
-  NotValid s' -> NotValid (s : s')
-mergeErrors (IsValid : t) = mergeErrors t
-  -- NotValid s' -> NotValid (s <> text ", and" $$ s')
-
--- A datatype used only inside of canDoGenerics1. It's the result of analysing
--- a type term.
-data Check_for_CanDoGenerics1 = CCDG1
-  { _ccdg1_hasParam :: Bool       -- does the parameter of interest occurs in
-                                  -- this type?
-  , _ccdg1_errors   :: Validity' DeriveGenericsErrReason -- errors generated by this type
-  }
-
-{-
-
-Note [degenerate use of FFoldType]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-We use foldDataConArgs here only for its ability to treat tuples
-specially. foldDataConArgs also tracks covariance (though it assumes all
-higher-order type parameters are covariant) and has hooks for special handling
-of functions and polytypes, but we do *not* use those.
-
-The key issue is that Generic1 deriving currently offers no sophisticated
-support for functions. For example, we cannot handle
-
-  data F a = F ((a -> Int) -> Int)
-
-even though a is occurring covariantly.
-
-In fact, our rule is harsh: a is simply not allowed to occur within the first
-argument of (->). We treat (->) the same as any other non-tuple tycon.
-
-Unfortunately, this means we have to track "the parameter occurs in this type"
-explicitly, even though foldDataConArgs is also doing this internally.
-
--}
-
--- canDoGenerics1 determines if a Generic1/Rep1 can be derived.
---
--- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep]
--- are taken care of by the call to canDoGenerics.
---
--- It returns IsValid if deriving is possible. It returns (NotValid reason)
--- if not.
-canDoGenerics1 :: DerivInstTys -> Validity' [DeriveGenericsErrReason]
-canDoGenerics1 dit@(DerivInstTys{dit_rep_tc = rep_tc}) =
-  canDoGenerics dit `andValid` additionalChecks
-  where
-    additionalChecks
-        -- check (d) from Note [Requirements for deriving Generic and Rep]
-      | null (tyConTyVars rep_tc) = NotValid [
-          DerivErrGenericsMustHaveSomeTypeParams rep_tc]
-
-      | otherwise = mergeErrors $ concatMap check_con data_cons
-
-    data_cons = tyConDataCons rep_tc
-    check_con con = case check_vanilla con of
-      j@(NotValid {}) -> [j]
-      IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con dit
-
-    check_vanilla :: DataCon -> Validity' DeriveGenericsErrReason
-    check_vanilla con | isVanillaDataCon con = IsValid
-                      | otherwise            = NotValid $ DerivErrGenericsMustNotHaveExistentials con
-
-    bmzero    = CCDG1 False IsValid
-    bmbad con = CCDG1 True $ NotValid (DerivErrGenericsWrongArgKind con)
-    bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2)
-
-    -- check (e) from Note [Requirements for deriving Generic and Rep]
-    -- See also Note [degenerate use of FFoldType]
-    ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1
-    ft_check con = FT
-      { ft_triv = bmzero
-
-      , ft_var = caseVar, ft_co_var = caseVar
-
-      -- (component_0,component_1,...,component_n)
-      , ft_tup = \_ components -> case nonEmpty components of
-            Just components' | any _ccdg1_hasParam (NE.init components') -> bmbad con
-            _ -> foldr bmplus bmzero components
-
-      -- (dom -> rng), where the head of ty is not a tuple tycon
-      , ft_fun = \dom rng -> -- cf #8516
-          if _ccdg1_hasParam dom
-          then bmbad con
-          else bmplus dom rng
-
-      -- (ty arg), where head of ty is neither (->) nor a tuple constructor and
-      -- the parameter of interest does not occur in ty
-      , ft_ty_app = \_ _ arg -> arg
-
-      , ft_bad_app = bmbad con
-      , ft_forall  = \_ body -> body -- polytypes are handled elsewhere
-      }
-      where
-        caseVar = CCDG1 True IsValid
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Generating the RHS of a generic default method}
-*                                                                      *
-************************************************************************
--}
-
-type US = Int   -- Local unique supply, just a plain Int
-type Alt = (LPat GhcPs, LHsExpr GhcPs)
-
--- GenericKind serves to mark if a datatype derives Generic (Gen0) or
--- Generic1 (Gen1).
-data GenericKind = Gen0 | Gen1
-
--- Like 'GenericKind', but with a payload of a datacon's last universally
--- quantified 'TyVar' in the 'Generic1' case.
---
--- Note that for GADTs, the last TyVar's Name will be different in each data
--- constructor, so it is not correct to simply use the last TyVar in
--- 'tyConTyVars' in 'Gen1_DC'. (See #21185 for an example of what would happen
--- if you tried.)
-data GenericKind_DC = Gen0_DC | Gen1_DC TyVar
-
--- Construct a 'GenericKind_DC', retrieving the last universally quantified
--- type variable of a 'DataCon' in the 'Generic1' case.
-gk2gkDC :: GenericKind -> DataCon -> [Type] -> GenericKind_DC
-gk2gkDC Gen0 _  _       = Gen0_DC
-gk2gkDC Gen1 dc tc_args = Gen1_DC $ assert (isTyVarTy last_dc_inst_univ)
-                                  $ getTyVar last_dc_inst_univ
-  where
-    dc_inst_univs = dataConInstUnivs dc tc_args
-    last_dc_inst_univ = assert (not (null dc_inst_univs)) $
-                        Partial.last dc_inst_univs
-
-
--- Bindings for the Generic instance
-mkBindsRep :: DynFlags -> GenericKind -> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, [LSig GhcPs])
-mkBindsRep dflags gk loc dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs)
-      where
-        binds = unitBag (mkRdrFunBind (L loc' from01_RDR) [from_eqn])
-              `unionBags`
-                unitBag (mkRdrFunBind (L loc' to01_RDR) [to_eqn])
-
-        -- See Note [Generics performance tricks]
-        sigs = if     gopt Opt_InlineGenericsAggressively dflags
-                  || (gopt Opt_InlineGenerics dflags && inlining_useful)
-               then [inline1 from01_RDR, inline1 to01_RDR]
-               else []
-         where
-           inlining_useful
-             | cons <= 1  = True
-             | cons <= 4  = max_fields <= 5
-             | cons <= 8  = max_fields <= 2
-             | cons <= 16 = max_fields <= 1
-             | cons <= 24 = max_fields == 0
-             | otherwise  = False
-             where
-               cons       = length datacons
-               max_fields = maximum $ map dataConSourceArity datacons
-
-           inline1 f = L loc'' . InlineSig noAnn (L loc' f)
-                     $ alwaysInlinePragma { inl_act = ActiveAfter NoSourceText 1 }
-
-        -- The topmost M1 (the datatype metadata) has the exact same type
-        -- across all cases of a from/to definition, and can be factored out
-        -- to save some allocations during typechecking.
-        -- See Note [Generics compilation speed tricks]
-        from_eqn = mkHsCaseAlt x_Pat $ mkM1_E
-                                       $ nlHsPar $ nlHsCase x_Expr from_matches
-        to_eqn   = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches
-
-        from_matches  = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]
-        to_matches    = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts  ]
-        loc'          = noAnnSrcSpan loc
-        loc''         = noAnnSrcSpan loc
-        datacons      = tyConDataCons tycon
-
-        (from01_RDR, to01_RDR) = case gk of
-                                   Gen0 -> (from_RDR,  to_RDR)
-                                   Gen1 -> (from1_RDR, to1_RDR)
-
-        -- Recurse over the sum first
-        from_alts, to_alts :: [Alt]
-        (from_alts, to_alts) = mkSum gk (1 :: US) dit datacons
-
---------------------------------------------------------------------------------
--- The type synonym instance and synonym
---       type instance Rep (D a b) = Rep_D a b
---       type Rep_D a b = ...representation type for D ...
---------------------------------------------------------------------------------
-
-gen_Generic_fam_inst :: GenericKind      -- Gen0 or Gen1
-                     -> (Name -> Fixity) -- Get the Fixity for a data constructor Name
-                     -> SrcSpan          -- The current source location
-                     -> DerivInstTys     -- Information about the type(s) to which
-                                         -- Generic(1) is applied in the generated
-                                         -- instance, including the data type's TyCon
-                     -> TcM FamInst      -- Generated representation0 coercion
-gen_Generic_fam_inst gk get_fixity loc
-       dit@(DerivInstTys{ dit_cls_tys = cls_tys
-                        , dit_tc = tc, dit_tc_args = tc_args
-                        , dit_rep_tc = tycon }) =
-       -- Consider the example input tycon `D`, where data D a b = D_ a
-       -- Also consider `R:DInt`, where { data family D x y :: * -> *
-       --                               ; data instance D Int a b = D_ a }
-  do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family)
-       fam_tc <- case gk of
-         Gen0 -> tcLookupTyCon repTyConName
-         Gen1 -> tcLookupTyCon rep1TyConName
-
-     ; let -- If the derived instance is
-           --   instance Generic (Foo x)
-           -- then:
-           --   `arg_ki` = *, `inst_ty` = Foo x :: *
-           --
-           -- If the derived instance is
-           --   instance Generic1 (Bar x :: k -> *)
-           -- then:
-           --   `arg_k` = k, `inst_ty` = Bar x :: k -> *
-           arg_ki = case (gk, cls_tys) of
-             (Gen0, [])      -> liftedTypeKind
-             (Gen1, [arg_k]) -> arg_k
-             _ -> pprPanic "gen_Generic_fam_insts" (ppr cls_tys)
-           inst_ty = mkTyConApp tc tc_args
-           inst_tys = cls_tys ++ [inst_ty]
-
-       -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
-     ; repTy <- tc_mkRepTy gk get_fixity dit arg_ki
-
-       -- `rep_name` is a name we generate for the synonym
-     ; mod <- getModule
-     ; let tc_occ  = nameOccName (tyConName tycon)
-           rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ
-     ; rep_name <- newGlobalBinder mod rep_occ loc
-
-     ; let tcv      = tyCoVarsOfTypeList inst_ty
-           (tv, cv) = partition isTyVar tcv
-           tvs      = scopedSort tv
-           cvs      = scopedSort cv
-           axiom    = mkSingleCoAxiom Nominal rep_name tvs [] cvs
-                                      fam_tc inst_tys repTy
-
-     ; newFamInst SynFamilyInst axiom  }
-
---------------------------------------------------------------------------------
--- Type representation
---------------------------------------------------------------------------------
-
--- | See documentation of 'argTyFold'; that function uses the fields of this
--- type to interpret the structure of a type when that type is considered as an
--- argument to a constructor that is being represented with 'Rep1'.
-data ArgTyAlg a = ArgTyAlg
-  { ata_rec0 :: (Type -> a)
-  , ata_par1 :: a, ata_rec1 :: (Type -> a)
-  , ata_comp :: (Type -> a -> a)
-  }
-
--- | @argTyFold@ implements a generalised and safer variant of the @arg@
--- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@
--- is conceptually equivalent to:
---
--- > arg t = case t of
--- >   _ | isTyVar t         -> if (t == argVar) then Par1 else Par0 t
--- >   App f [t'] |
--- >     representable1 f &&
--- >     t' == argVar        -> Rec1 f
--- >   App f [t'] |
--- >     representable1 f &&
--- >     t' has tyvars       -> f :.: (arg t')
--- >   _                     -> Rec0 t
---
--- where @argVar@ is the last type variable in the data type declaration we are
--- finding the representation for.
---
--- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to
--- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and
--- @:.:@.
---
--- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for
--- some data types. The problematic case is when @t@ is an application of a
--- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the
--- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in
--- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some
--- representable1 checks have been relaxed, and others were moved to
--- @canDoGenerics1@.
-argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
-argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
-                            ata_par1 = mkPar1, ata_rec1 = mkRec1,
-                            ata_comp = mkComp}) =
-  -- mkRec0 is the default; use it if there is no interesting structure
-  -- (e.g. occurrences of parameters or recursive occurrences)
-  \t -> maybe (mkRec0 t) id $ go t where
-  go :: Type -> -- type to fold through
-        Maybe a -- the result (e.g. representation type), unless it's trivial
-  go t = isParam `mplus` isApp where
-
-    isParam = do -- handles parameters
-      t' <- getTyVar_maybe t
-      Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter
-             else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0
-
-    isApp = do -- handles applications
-      (phi, beta) <- tcSplitAppTy_maybe t
-
-      let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta
-
-      -- Does it have no interesting structure to represent?
-      if not interesting then Nothing
-        else -- Is the argument the parameter? Special case for mkRec1.
-          if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi
-            else mkComp phi `fmap` go beta -- It must be a composition.
-
-
-tc_mkRepTy ::  -- Gen0 or Gen1, for Rep or Rep1
-               GenericKind
-               -- Get the Fixity for a data constructor Name
-            -> (Name -> Fixity)
-               -- Information about the last type argument to Generic(1)
-            -> DerivInstTys
-               -- The kind of the representation type's argument
-               -- See Note [Handling kinds in a Rep instance]
-            -> Kind
-               -- Generated representation0 type
-            -> TcM Type
-tc_mkRepTy gk get_fixity dit@(DerivInstTys{ dit_rep_tc = tycon
-                                          , dit_rep_tc_args = tycon_args }) k =
-  do
-    d1      <- tcLookupTyCon d1TyConName
-    c1      <- tcLookupTyCon c1TyConName
-    s1      <- tcLookupTyCon s1TyConName
-    rec0    <- tcLookupTyCon rec0TyConName
-    rec1    <- tcLookupTyCon rec1TyConName
-    par1    <- tcLookupTyCon par1TyConName
-    u1      <- tcLookupTyCon u1TyConName
-    v1      <- tcLookupTyCon v1TyConName
-    plus    <- tcLookupTyCon sumTyConName
-    times   <- tcLookupTyCon prodTyConName
-    comp    <- tcLookupTyCon compTyConName
-    uAddr   <- tcLookupTyCon uAddrTyConName
-    uChar   <- tcLookupTyCon uCharTyConName
-    uDouble <- tcLookupTyCon uDoubleTyConName
-    uFloat  <- tcLookupTyCon uFloatTyConName
-    uInt    <- tcLookupTyCon uIntTyConName
-    uWord   <- tcLookupTyCon uWordTyConName
-
-    let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon
-
-    md         <- tcLookupPromDataCon metaDataDataConName
-    mc         <- tcLookupPromDataCon metaConsDataConName
-    ms         <- tcLookupPromDataCon metaSelDataConName
-    pPrefix    <- tcLookupPromDataCon prefixIDataConName
-    pInfix     <- tcLookupPromDataCon infixIDataConName
-    pLA        <- tcLookupPromDataCon leftAssociativeDataConName
-    pRA        <- tcLookupPromDataCon rightAssociativeDataConName
-    pNA        <- tcLookupPromDataCon notAssociativeDataConName
-    pSUpk      <- tcLookupPromDataCon sourceUnpackDataConName
-    pSNUpk     <- tcLookupPromDataCon sourceNoUnpackDataConName
-    pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName
-    pSLzy      <- tcLookupPromDataCon sourceLazyDataConName
-    pSStr      <- tcLookupPromDataCon sourceStrictDataConName
-    pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName
-    pDLzy      <- tcLookupPromDataCon decidedLazyDataConName
-    pDStr      <- tcLookupPromDataCon decidedStrictDataConName
-    pDUpk      <- tcLookupPromDataCon decidedUnpackDataConName
-
-    let mkSum' a b = mkTyConApp plus  [k,a,b]
-        mkProd a b = mkTyConApp times [k,a,b]
-        mkRec0 a   = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a
-        mkRec1 a   = mkTyConApp rec1  [k,a]
-        mkPar1     = mkTyConTy  par1
-        mkD    a   = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ]
-        mkC      a = mkTyConApp c1 [ k
-                                   , metaConsTy a
-                                   , prod (gk2gkDC gk a tycon_args)
-                                          (derivDataConInstArgTys a dit)
-                                          (dataConSrcBangs    a)
-                                          (dataConImplBangs   a)
-                                          (dataConFieldLabels a)]
-        mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a]
-
-        -- Sums and products are done in the same way for both Rep and Rep1
-        sumP l = foldBal mkSum' (mkTyConApp v1 [k]) . map mkC $ l
-        -- The Bool is True if this constructor has labelled fields
-        prod :: GenericKind_DC -> [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
-        prod gk_ l sb ib fl = foldBal mkProd (mkTyConApp u1 [k])
-                                  [ assert (null fl || lengthExceeds fl j) $
-                                    arg gk_ t sb' ib' (if null fl
-                                                       then Nothing
-                                                       else Just (fl !! j))
-                                  | (t,sb',ib',j) <- zip4 l sb ib [0..] ]
-
-        arg :: GenericKind_DC -> Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
-        arg gk_ t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of
-            -- Here we previously used Par0 if t was a type variable, but we
-            -- realized that we can't always guarantee that we are wrapping-up
-            -- all type variables in Par0. So we decided to stop using Par0
-            -- altogether, and use Rec0 all the time.
-                      Gen0_DC        -> mkRec0 t
-                      Gen1_DC argVar -> argPar argVar t
-          where
-            -- Builds argument representation for Rep1 (more complicated due to
-            -- the presence of composition).
-            argPar argVar =
-              let -- If deriving Generic1, make sure to substitute the last
-                  -- type variable with Any in the generated Rep1 instance.
-                  -- This avoids issues like what is documented in the
-                  -- "wrinkle" section of
-                  -- Note [Generating a correctly typed Rep instance].
-                  env      = zipTyEnv [argVar] [anyTypeOfKind (tyVarKind argVar)]
-                  in_scope = mkInScopeSet (tyCoVarsOfTypes tycon_args)
-                  subst    = mkTvSubst in_scope env in
-
-              substTy subst . argTyFold argVar (ArgTyAlg
-              {ata_rec0 = mkRec0, ata_par1 = mkPar1,
-               ata_rec1 = mkRec1, ata_comp = mkComp comp k})
-
-        tyConName_user = case tyConFamInst_maybe tycon of
-                           Just (ptycon, _) -> tyConName ptycon
-                           Nothing          -> tyConName tycon
-
-        dtName  = mkStrLitTy . occNameFS . nameOccName $ tyConName_user
-        mdName  = mkStrLitTy . moduleNameFS . moduleName
-                . nameModule . tyConName $ tycon
-        pkgName = mkStrLitTy . unitFS . moduleUnit
-                . nameModule . tyConName $ tycon
-        isNT    = mkTyConTy $ if isNewTyCon tycon
-                              then promotedTrueDataCon
-                              else promotedFalseDataCon
-
-        ctName = mkStrLitTy . occNameFS . nameOccName . dataConName
-        ctFix c
-            | dataConIsInfix c
-            = case get_fixity (dataConName c) of
-                   Fixity _ n InfixL -> buildFix n pLA
-                   Fixity _ n InfixR -> buildFix n pRA
-                   Fixity _ n InfixN -> buildFix n pNA
-            | otherwise = mkTyConTy pPrefix
-        buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc
-                                             , mkNumLitTy (fromIntegral n)]
-
-        isRec c = mkTyConTy $ if dataConFieldLabels c `lengthExceeds` 0
-                              then promotedTrueDataCon
-                              else promotedFalseDataCon
-
-        selName = mkStrLitTy . field_label . flLabel
-
-        mbSel Nothing  = mkTyConApp promotedNothingDataCon [typeSymbolKind]
-        mbSel (Just s) = mkTyConApp promotedJustDataCon
-                                    [typeSymbolKind, selName s]
-
-        metaDataTy   = mkTyConApp md [dtName, mdName, pkgName, isNT]
-        metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c]
-        metaSelTy mlbl su ss ib =
-            mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness]
-          where
-            pSUpkness = mkTyConTy $ case su of
-                                         SrcUnpack   -> pSUpk
-                                         SrcNoUnpack -> pSNUpk
-                                         NoSrcUnpack -> pNSUpkness
-
-            pSStrness = mkTyConTy $ case ss of
-                                         SrcLazy     -> pSLzy
-                                         SrcStrict   -> pSStr
-                                         NoSrcStrict -> pNSStrness
-
-            pDStrness = mkTyConTy $ case ib of
-                                         HsLazy      -> pDLzy
-                                         HsStrict    -> pDStr
-                                         HsUnpack{}  -> pDUpk
-
-    return (mkD tycon)
-
-mkComp :: TyCon -> Kind -> Type -> Type -> Type
-mkComp comp k f g
-  | k1_first  = mkTyConApp comp  [k,liftedTypeKind,f,g]
-  | otherwise = mkTyConApp comp  [liftedTypeKind,k,f,g]
-  where
-    -- Which of these is the case?
-    --     newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
-    -- or  newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
-    -- We want to instantiate with k1=k, and k2=*
-    --    Reason for k2=*: see Note [Handling kinds in a Rep instance]
-    -- But we need to know which way round!
-    k1_first = k_first == p_kind_var
-    [k_first,_,_,_,p] = tyConTyVars comp
-    Just p_kind_var = getTyVar_maybe (tyVarKind p)
-
--- Given the TyCons for each URec-related type synonym, check to see if the
--- given type is an unlifted type that generics understands. If so, return
--- its representation type. Otherwise, return Rec0.
--- See Note [Generics and unlifted types]
-mkBoxTy :: TyCon -- UAddr
-        -> TyCon -- UChar
-        -> TyCon -- UDouble
-        -> TyCon -- UFloat
-        -> TyCon -- UInt
-        -> TyCon -- UWord
-        -> TyCon -- Rec0
-        -> Kind  -- What to instantiate Rec0's kind variable with
-        -> Type
-        -> Type
-mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty
-  | ty `eqType` addrPrimTy   = mkTyConApp uAddr   [k]
-  | ty `eqType` charPrimTy   = mkTyConApp uChar   [k]
-  | ty `eqType` doublePrimTy = mkTyConApp uDouble [k]
-  | ty `eqType` floatPrimTy  = mkTyConApp uFloat  [k]
-  | ty `eqType` intPrimTy    = mkTyConApp uInt    [k]
-  | ty `eqType` wordPrimTy   = mkTyConApp uWord   [k]
-  | otherwise                = mkTyConApp rec0    [k,ty]
-
---------------------------------------------------------------------------------
--- Dealing with sums
---------------------------------------------------------------------------------
-
-mkSum :: GenericKind  -- Generic or Generic1?
-      -> US           -- Base for generating unique names
-      -> DerivInstTys -- Information about the last type argument to Generic(1)
-      -> [DataCon]    -- The data constructors
-      -> ([Alt],      -- Alternatives for the T->Trep "from" function
-          [Alt])      -- Alternatives for the Trep->T "to" function
-
--- Datatype without any constructors
-mkSum _ _ _ [] = ([from_alt], [to_alt])
-  where
-    from_alt = (x_Pat, nlHsCase x_Expr [])
-    to_alt   = (x_Pat, nlHsCase x_Expr [])
-               -- These M1s are meta-information for the datatype
-
--- Datatype with at least one constructor
-mkSum gk us dit datacons =
-  -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
- unzip [ mk1Sum gk us i (length datacons) dit d
-           | (d,i) <- zip datacons [1..] ]
-
--- Build the sum for a particular constructor
-mk1Sum :: GenericKind  -- Generic or Generic1?
-       -> US           -- Base for generating unique names
-       -> Int          -- The index of this constructor
-       -> Int          -- Total number of constructors
-       -> DerivInstTys -- Information about the last type argument to Generic(1)
-       -> DataCon      -- The data constructor
-       -> (Alt,        -- Alternative for the T->Trep "from" function
-           Alt)        -- Alternative for the Trep->T "to" function
-mk1Sum gk us i n dit@(DerivInstTys{dit_rep_tc_args = tc_args}) datacon
-  = (from_alt, to_alt)
-  where
-    gk_ = gk2gkDC gk datacon tc_args
-
-    -- Existentials already excluded
-    argTys = derivDataConInstArgTys datacon dit
-    n_args = dataConSourceArity datacon
-
-    datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys
-    datacon_vars = map fst datacon_varTys
-
-    datacon_rdr  = getRdrName datacon
-
-    from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
-    from_alt_rhs = genLR_E i n (mkProd_E gk_ datacon_varTys)
-
-    to_alt     = ( genLR_P i n (mkProd_P gk datacon_varTys)
-                 , to_alt_rhs
-                 ) -- These M1s are meta-information for the datatype
-    to_alt_rhs = case gk_ of
-      Gen0_DC        -> nlHsVarApps datacon_rdr datacon_vars
-      Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
-        where
-          argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
-            converter = argTyFold argVar $ ArgTyAlg
-              {ata_rec0 = nlHsVar . unboxRepRDR,
-               ata_par1 = nlHsVar unPar1_RDR,
-               ata_rec1 = const $ nlHsVar unRec1_RDR,
-               ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
-                                    `nlHsCompose` nlHsVar unComp1_RDR}
-
-
--- Generates the L1/R1 sum pattern
-genLR_P :: Int -> Int -> LPat GhcPs -> LPat GhcPs
-genLR_P i n p
-  | n == 0       = error "impossible"
-  | n == 1       = p
-  | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]
-  | otherwise    = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]
-                     where m = div n 2
-
--- Generates the L1/R1 sum expression
-genLR_E :: Int -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs
-genLR_E i n e
-  | n == 0       = error "impossible"
-  | n == 1       = e
-  | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp`
-                                            nlHsPar (genLR_E i     (div n 2) e)
-  | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp`
-                                            nlHsPar (genLR_E (i-m) (n-m)     e)
-                     where m = div n 2
-
---------------------------------------------------------------------------------
--- Dealing with products
---------------------------------------------------------------------------------
-
--- Build a product expression
-mkProd_E :: GenericKind_DC    -- Generic or Generic1?
-         -> [(RdrName, Type)]
-                       -- List of variables matched on the lhs and their types
-         -> LHsExpr GhcPs   -- Resulting product expression
-mkProd_E gk_ varTys = mkM1_E (foldBal prod (nlHsVar u1DataCon_RDR) appVars)
-                      -- These M1s are meta-information for the constructor
-  where
-    appVars = map (wrapArg_E gk_) varTys
-    prod a b = prodDataCon_RDR `nlHsApps` [a,b]
-
-wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs
-wrapArg_E Gen0_DC          (var, ty) = mkM1_E $
-                            boxRepRDR ty `nlHsVarApps` [var]
-                         -- This M1 is meta-information for the selector
-wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $
-                            converter ty `nlHsApp` nlHsVar var
-                         -- This M1 is meta-information for the selector
-  where converter = argTyFold argVar $ ArgTyAlg
-          {ata_rec0 = nlHsVar . boxRepRDR,
-           ata_par1 = nlHsVar par1DataCon_RDR,
-           ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
-           ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
-                                  (nlHsVar fmap_RDR `nlHsApp` cnv)}
-
-boxRepRDR :: Type -> RdrName
-boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs
-
-unboxRepRDR :: Type -> RdrName
-unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs
-
--- Retrieve the RDRs associated with each URec data family instance
--- constructor. See Note [Generics and unlifted types]
-unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
-unboxedRepRDRs ty
-  | ty `eqType` addrPrimTy   = Just (uAddrDataCon_RDR,   uAddrHash_RDR)
-  | ty `eqType` charPrimTy   = Just (uCharDataCon_RDR,   uCharHash_RDR)
-  | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR)
-  | ty `eqType` floatPrimTy  = Just (uFloatDataCon_RDR,  uFloatHash_RDR)
-  | ty `eqType` intPrimTy    = Just (uIntDataCon_RDR,    uIntHash_RDR)
-  | ty `eqType` wordPrimTy   = Just (uWordDataCon_RDR,   uWordHash_RDR)
-  | otherwise          = Nothing
-
--- Build a product pattern
-mkProd_P :: GenericKind       -- Gen0 or Gen1
-         -> [(RdrName, Type)] -- List of variables to match,
-                              --   along with their types
-         -> LPat GhcPs      -- Resulting product pattern
-mkProd_P gk varTys = mkM1_P (foldBal prod (nlNullaryConPat u1DataCon_RDR) appVars)
-                     -- These M1s are meta-information for the constructor
-  where
-    appVars = unzipWith (wrapArg_P gk) varTys
-    prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b]
-
-wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs
-wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v])
-                   -- This M1 is meta-information for the selector
-wrapArg_P Gen1 v _  = nlParPat $ m1DataCon_RDR `nlConVarPat` [v]
-
-mkGenericLocal :: US -> RdrName
-mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
-
-x_RDR :: RdrName
-x_RDR = mkVarUnqual (fsLit "x")
-
-x_Expr :: LHsExpr GhcPs
-x_Expr = nlHsVar x_RDR
-
-x_Pat :: LPat GhcPs
-x_Pat = nlVarPat x_RDR
-
-mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs
-mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
-
-mkM1_P :: LPat GhcPs -> LPat GhcPs
-mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p]
-
-nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-nlHsCompose x y = compose_RDR `nlHsApps` [x, y]
-
--- | Variant of foldr for producing balanced lists
-foldBal :: (a -> a -> a) -> a -> [a] -> a
-{-# INLINE foldBal #-} -- inlined to produce specialised code for each op
-foldBal op0 x0 xs0 = fold_bal op0 x0 (length xs0) xs0
-  where
-    fold_bal op x !n xs = case xs of
-      []  -> x
-      [a] -> a
-      _   -> let !nl = n `div` 2
-                 !nr = n - nl
-                 (l,r) = splitAt nl xs
-             in fold_bal op x nl l
-                `op` fold_bal op x nr r
-
-{-
-Note [Generics and unlifted types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Normally, all constants are marked with K1/Rec0. The exception to this rule is
-when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In
-that case, we must use a data family instance of URec (from GHC.Generics) to
-mark it. As a result, before we can generate K1 or unK1, we must first check
-to see if the type is actually one of the unlifted types for which URec has a
-data family instance; if so, we generate that instead.
-
-See wiki:commentary/compiler/generic-deriving#handling-unlifted-types for more
-details on why URec is implemented the way it is.
-
-Note [Generating a correctly typed Rep instance]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving
-Generic(1). For example, given the following data declaration:
-
-    data Foo a = MkFoo a
-      deriving stock Generic
-
-tc_mkRepTy would generate the `Rec0 a` portion of this instance:
-
-    instance Generic (Foo a) where
-      type Rep (Foo a) = Rec0 a
-      ...
-
-(The full `Rep` instance is more complicated than this, but we have simplified
-it for presentation purposes.)
-
-`tc_mkRepTy` figures out the field types to use in the RHS by inspecting a
-DerivInstTys, which contains the instantiated field types for each data
-constructor. (See Note [Instantiating field types in stock deriving] for a
-description of how this works.) As a result, `tc_mkRepTy` "just works" even
-when dealing with StandaloneDeriving, such as in this example:
-
-    deriving stock instance Generic (Foo Int)
-      ===>
-    instance Generic (Foo Int) where
-      type Rep (Foo Int) = Rec0 Int -- The `a` has been instantiated here
-
-A wrinkle in all of this: what happens when deriving a Generic1 instance where
-the last type variable appears in a type synonym that discards it? That is,
-what should happen in this example (taken from #15012)?
-
-    type FakeOut a = Int
-    data T a = MkT (FakeOut a)
-      deriving Generic1
-
-MkT is a particularly wily data constructor. Although the last type variable
-`a` technically appears in `FakeOut a`, it's just a smokescreen, as `FakeOut a`
-simply expands to `Int`. As a result, `MkT` doesn't really *use* the last type
-variable. Therefore, T's `Rep` instance would use Rec0 to represent MkT's
-field. But we must be careful not to produce code like this:
-
-   instance Generic1 T where
-     type Rep1 T = Rec0 (FakeOut a)
-     ...
-
-Oh no! Now we have `a` on the RHS, but it's completely unbound. This can cause
-issues like what was observed in #15012. To avoid this, we ensure that `a` is
-instantiated to Any:
-
-   instance Generic1 T where
-     type Rep1 T = Rec0 (FakeOut Any)
-     ...
-
-And now all is good.
-
-Alternatively, we could have avoided this problem by expanding all type
-synonyms on the RHSes of Rep1 instances. But we might blow up the size of
-these types even further by doing this, so we choose not to do so.
-
-Note [Handling kinds in a Rep instance]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Because Generic1 is poly-kinded, the representation types were generalized to
-be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply
-the kind of the instance being derived to all the representation type
-constructors. For instance, if you have
-
-    data Empty (a :: k) = Empty deriving Generic1
-
-Then the generated code is now approximately (with -fprint-explicit-kinds
-syntax):
-
-    instance Generic1 k (Empty k) where
-      type Rep1 k (Empty k) = U1 k
-
-Most representation types have only one kind variable, making them easy to deal
-with. The only non-trivial case is (:.:), which is only used in Generic1
-instances:
-
-    newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) =
-        Comp1 { unComp1 :: f (g p) }
-
-Here, we do something a bit counter-intuitive: we make k1 be the kind of the
-instance being derived, and we always make k2 be *. Why *? It's because
-the code that GHC generates using (:.:) is always of the form x :.: Rec1 y
-for some types x and y. In other words, the second type to which (:.:) is
-applied always has kind k -> *, for some kind k, so k2 cannot possibly be
-anything other than * in a generated Generic1 instance.
-
-Note [Generics compilation speed tricks]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Deriving Generic(1) is known to have a large constant factor during
-compilation, which contributes to noticeable compilation slowdowns when
-deriving Generic(1) for large datatypes (see #5642).
-
-To ease the pain, there is a trick one can play when generating definitions for
-to(1) and from(1). If you have a datatype like:
-
-  data Letter = A | B | C | D
-
-then a naïve Generic instance for Letter would be:
-
-  instance Generic Letter where
-    type Rep Letter = D1 ('MetaData ...) ...
-
-    to (M1 (L1 (L1 (M1 U1)))) = A
-    to (M1 (L1 (R1 (M1 U1)))) = B
-    to (M1 (R1 (L1 (M1 U1)))) = C
-    to (M1 (R1 (R1 (M1 U1)))) = D
-
-    from A = M1 (L1 (L1 (M1 U1)))
-    from B = M1 (L1 (R1 (M1 U1)))
-    from C = M1 (R1 (L1 (M1 U1)))
-    from D = M1 (R1 (R1 (M1 U1)))
-
-Notice that in every LHS pattern-match of the 'to' definition, and in every RHS
-expression in the 'from' definition, the topmost constructor is M1. This
-corresponds to the datatype-specific metadata (the D1 in the Rep Letter
-instance). But this is wasteful from a typechecking perspective, since this
-definition requires GHC to typecheck an application of M1 in every single case,
-leading to an O(n) increase in the number of coercions the typechecker has to
-solve, which in turn increases allocations and degrades compilation speed.
-
-Luckily, since the topmost M1 has the exact same type across every case, we can
-factor it out reduce the typechecker's burden:
-
-  instance Generic Letter where
-    type Rep Letter = D1 ('MetaData ...) ...
-
-    to (M1 x) = case x of
-      L1 (L1 (M1 U1)) -> A
-      L1 (R1 (M1 U1)) -> B
-      R1 (L1 (M1 U1)) -> C
-      R1 (R1 (M1 U1)) -> D
-
-    from x = M1 (case x of
-      A -> L1 (L1 (M1 U1))
-      B -> L1 (R1 (M1 U1))
-      C -> R1 (L1 (M1 U1))
-      D -> R1 (R1 (M1 U1)))
-
-A simple change, but one that pays off, since it goes turns an O(n) amount of
-coercions to an O(1) amount.
-
-Note [Generics performance tricks]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Generics-based algorithms tend to rely on GHC optimizing away the intermediate
-representation for optimal performance. However, the default unfolding threshold
-is usually too small for GHC to do that.
-
-The recommended approach thus far was to increase unfolding threshold, but this
-makes GHC inline more aggressively in general, whereas it should only be more
-aggressive with generics-based code.
-
-The solution is to use a heuristic that'll annotate Generic class methods with
-INLINE[1] pragmas (the explicit phase is used to give users phase control as
-they can annotate their functions with INLINE[2] or INLINE[0] if appropriate).
-
-The current heuristic was chosen by looking at how annotating Generic methods
-INLINE[1] helps with optimal code generation for several types of generic
-algorithms:
-
-* Round trip through the generic representation.
-
-* Generation of NFData instances.
-
-* Generation of field lenses.
-
-The experimentation was done by picking data types having N constructors with M
-fields each and using their derived Generic instances to generate code with the
-above algorithms.
-
-The results are threshold values for N and M (contained in
-`mkBindsRep.inlining_useful`) for which inlining is beneficial, i.e. it usually
-leads to performance improvements at both compile time (the simplifier has to do
-more work, but then there's much less code left for subsequent phases to work
-with) and run time (the generic representation of a data type is optimized
-away).
-
-The T11068 test case, which includes the algorithms mentioned above, tests that
-the generic representations of several data types optimize away using the
-threshold values in `mkBindsRep.inlining_useful`.
-
-If one uses threshold values higher what is found in
-`mkBindsRep.inlining_useful`, then annotating Generic class methods with INLINE
-pragmas tends to be at best useless and at worst lead to code size blowup
-without runtime performance improvements.
--}
diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Deriv/Infer.hs
+++ /dev/null
@@ -1,1098 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
-
-{-# LANGUAGE MultiWayIf #-}
-
--- | Functions for inferring (and simplifying) the context for derived instances.
-module GHC.Tc.Deriv.Infer
-   ( inferConstraints
-   , simplifyInstanceContexts
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Tc.Deriv.Utils
-import GHC.Tc.Utils.Env
-import GHC.Tc.Deriv.Generate
-import GHC.Tc.Deriv.Functor
-import GHC.Tc.Deriv.Generics
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Types.Origin
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Solver
-import GHC.Tc.Solver.Monad ( runTcS )
-import GHC.Tc.Validity (validDerivPred)
-import GHC.Tc.Utils.Unify (buildImplicationFor)
-
-import GHC.Core.Class
-import GHC.Core.DataCon
-import GHC.Core.TyCon
-import GHC.Core.TyCo.Ppr (pprTyVars)
-import GHC.Core.Type
-import GHC.Core.Predicate
-import GHC.Core.Unify (tcUnifyTy)
-
-import GHC.Data.Pair
-import GHC.Builtin.Names
-import GHC.Builtin.Types (typeToTypeKind)
-
-import GHC.Utils.Error
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Misc
-
-import GHC.Types.Basic
-import GHC.Types.Var
-import GHC.Types.Var.Set
-
-import GHC.Data.Bag
-
-import Control.Monad
-import Control.Monad.Trans.Class  (lift)
-import Control.Monad.Trans.Reader (ask)
-import Data.Function              (on)
-import Data.Functor.Classes       (liftEq)
-import Data.List                  (sortBy)
-import Data.Maybe
-
-----------------------
-
-inferConstraints :: DerivSpecMechanism
-                 -> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
--- inferConstraints figures out the constraints needed for the
--- instance declaration generated by a 'deriving' clause on a
--- data type declaration. It also returns the new in-scope type
--- variables and instance types, in case they were changed due to
--- the presence of functor-like constraints.
--- See Note [Inferring the instance context]
-
--- e.g. inferConstraints
---        C Int (T [a])    -- Class and inst_tys
---        :RTList a        -- Rep tycon and its arg tys
--- where T [a] ~R :RTList a
---
--- Generate a sufficiently large set of constraints that typechecking the
--- generated method definitions should succeed.   This set will be simplified
--- before being used in the instance declaration
-inferConstraints mechanism
-  = do { DerivEnv { denv_tvs      = tvs
-                  , denv_cls      = main_cls
-                  , denv_inst_tys = inst_tys } <- ask
-       ; wildcard <- isStandaloneWildcardDeriv
-       ; let infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
-             infer_constraints =
-               case mechanism of
-                 DerivSpecStock{dsm_stock_dit = dit}
-                   -> do (thetas, tvs, inst_tys, dit') <- inferConstraintsStock dit
-                         pure ( thetas, tvs, inst_tys
-                              , mechanism{dsm_stock_dit = dit'} )
-                 DerivSpecAnyClass
-                   -> infer_constraints_simple inferConstraintsAnyclass
-                 DerivSpecNewtype { dsm_newtype_dit =
-                                      DerivInstTys{dit_cls_tys = cls_tys}
-                                  , dsm_newtype_rep_ty = rep_ty }
-                   -> infer_constraints_simple $
-                      inferConstraintsCoerceBased cls_tys rep_ty
-                 DerivSpecVia { dsm_via_cls_tys = cls_tys
-                              , dsm_via_ty = via_ty }
-                   -> infer_constraints_simple $
-                      inferConstraintsCoerceBased cls_tys via_ty
-
-             -- Most deriving strategies do not need to do anything special to
-             -- the type variables and arguments to the class in the derived
-             -- instance, so they can pass through unchanged. The exception to
-             -- this rule is stock deriving. See
-             -- Note [Inferring the instance context].
-             infer_constraints_simple
-               :: DerivM ThetaSpec
-               -> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism)
-             infer_constraints_simple infer_thetas = do
-               thetas <- infer_thetas
-               pure (thetas, tvs, inst_tys, mechanism)
-
-             -- Constraints arising from superclasses
-             -- See Note [Superclasses of derived instance]
-             cls_tvs  = classTyVars main_cls
-             sc_constraints = assertPpr (equalLength cls_tvs inst_tys)
-                                        (ppr main_cls <+> ppr inst_tys) $
-                              mkDirectThetaSpec
-                                (mkDerivOrigin wildcard) TypeLevel
-                                (substTheta cls_subst (classSCTheta main_cls))
-             cls_subst = assert (equalLength cls_tvs inst_tys) $
-                         zipTvSubst cls_tvs inst_tys
-
-       ; (inferred_constraints, tvs', inst_tys', mechanism')
-           <- infer_constraints
-       ; lift $ traceTc "inferConstraints" $ vcat
-              [ ppr main_cls <+> ppr inst_tys'
-              , ppr inferred_constraints
-              ]
-       ; return ( sc_constraints ++ inferred_constraints
-                , tvs', inst_tys', mechanism' ) }
-
--- | Like 'inferConstraints', but used only in the case of the @stock@ deriving
--- strategy. The constraints are inferred by inspecting the fields of each data
--- constructor. In this example:
---
--- > data Foo = MkFoo Int Char deriving Show
---
--- We would infer the following constraints ('ThetaSpec's):
---
--- > (Show Int, Show Char)
---
--- Note that this function also returns the type variables ('TyVar's) and
--- class arguments ('TcType's) for the resulting instance. This is because
--- when deriving 'Functor'-like classes, we must sometimes perform kind
--- substitutions to ensure the resulting instance is well kinded, which may
--- affect the type variables and class arguments. In this example:
---
--- > newtype Compose (f :: k -> Type) (g :: Type -> k) (a :: Type) =
--- >   Compose (f (g a)) deriving stock Functor
---
--- We must unify @k@ with @Type@ in order for the resulting 'Functor' instance
--- to be well kinded, so we return @[]@/@[Type, f, g]@ for the
--- 'TyVar's/'TcType's, /not/ @[k]@/@[k, f, g]@.
--- See Note [Inferring the instance context].
-inferConstraintsStock :: DerivInstTys
-                      -> DerivM (ThetaSpec, [TyVar], [TcType], DerivInstTys)
-inferConstraintsStock dit@(DerivInstTys { dit_cls_tys     = cls_tys
-                                        , dit_tc          = tc
-                                        , dit_tc_args     = tc_args
-                                        , dit_rep_tc      = rep_tc
-                                        , dit_rep_tc_args = rep_tc_args })
-  = do DerivEnv { denv_tvs      = tvs
-                , denv_cls      = main_cls
-                , denv_inst_tys = inst_tys } <- ask
-       wildcard <- isStandaloneWildcardDeriv
-
-       let inst_ty    = mkTyConApp tc tc_args
-           tc_binders = tyConBinders rep_tc
-           choose_level bndr
-             | isNamedTyConBinder bndr = KindLevel
-             | otherwise               = TypeLevel
-           t_or_ks = map choose_level tc_binders ++ repeat TypeLevel
-              -- want to report *kind* errors when possible
-
-              -- Constraints arising from the arguments of each constructor
-           con_arg_constraints
-             :: ([TyVar] -> CtOrigin
-                         -> TypeOrKind
-                         -> Type
-                         -> [(ThetaSpec, Maybe Subst)])
-             -> (ThetaSpec, [TyVar], [TcType], DerivInstTys)
-           con_arg_constraints get_arg_constraints
-             = let -- Constraints from the fields of each data constructor.
-                   (predss, mbSubsts) = unzip
-                     [ preds_and_mbSubst
-                     | data_con <- tyConDataCons rep_tc
-                     , (arg_n, arg_t_or_k, arg_ty)
-                         <- zip3 [1..] t_or_ks $
-                            derivDataConInstArgTys data_con dit
-                       -- No constraints for unlifted types
-                       -- See Note [Deriving and unboxed types]
-                     , not (isUnliftedType arg_ty)
-                     , let orig = DerivOriginDC data_con arg_n wildcard
-                     , preds_and_mbSubst
-                         <- get_arg_constraints (dataConUnivTyVars data_con)
-                                                orig arg_t_or_k arg_ty
-                     ]
-                   -- Stupid constraints from DatatypeContexts. Note that we
-                   -- must gather these constraints from the data constructors,
-                   -- not from the parent type constructor, as the latter could
-                   -- lead to redundant constraints due to thinning.
-                   -- See Note [The stupid context] in GHC.Core.DataCon.
-                   stupid_theta =
-                     [ substTyWith (dataConUnivTyVars data_con)
-                                   (dataConInstUnivs data_con rep_tc_args)
-                                   stupid_pred
-                     | data_con <- tyConDataCons rep_tc
-                     , stupid_pred <- dataConStupidTheta data_con
-                     ]
-
-                   preds = concat predss
-                   -- If the constraints require a subtype to be of kind
-                   -- (* -> *) (which is the case for functor-like
-                   -- constraints), then we explicitly unify the subtype's
-                   -- kinds with (* -> *).
-                   -- See Note [Inferring the instance context]
-                   subst        = foldl' composeTCvSubst
-                                         emptySubst (catMaybes mbSubsts)
-                   unmapped_tvs = filter (\v -> v `notElemSubst` subst
-                                             && not (v `isInScope` subst)) tvs
-                   (subst', _)  = substTyVarBndrs subst unmapped_tvs
-                   stupid_theta_origin = mkDirectThetaSpec
-                                           deriv_origin TypeLevel
-                                           (substTheta subst' stupid_theta)
-                   preds'       = map (substPredSpec subst') preds
-                   inst_tys'    = substTys subst' inst_tys
-                   dit'         = substDerivInstTys subst' dit
-                   tvs'         = tyCoVarsOfTypesWellScoped inst_tys'
-               in ( stupid_theta_origin ++ preds'
-                  , tvs', inst_tys', dit' )
-
-           is_generic  = main_cls `hasKey` genClassKey
-           is_generic1 = main_cls `hasKey` gen1ClassKey
-           -- is_functor_like: see Note [Inferring the instance context]
-           is_functor_like = typeKind inst_ty `tcEqKind` typeToTypeKind
-                          || is_generic1
-
-           get_gen1_constraints ::
-                Class
-             -> [TyVar] -- The universally quantified type variables for the
-                        -- data constructor
-             -> CtOrigin -> TypeOrKind -> Type
-             -> [(ThetaSpec, Maybe Subst)]
-           get_gen1_constraints functor_cls dc_univs orig t_or_k ty
-              = mk_functor_like_constraints orig t_or_k functor_cls $
-                get_gen1_constrained_tys last_dc_univ ty
-             where
-               -- If we are deriving an instance of 'Generic1' and have made
-               -- it this far, then there should be at least one universal type
-               -- variable, making this use of 'last' safe.
-               last_dc_univ = assert (not (null dc_univs)) $
-                              last dc_univs
-
-           get_std_constrained_tys ::
-                [TyVar] -- The universally quantified type variables for the
-                        -- data constructor
-             -> CtOrigin -> TypeOrKind -> Type
-             -> [(ThetaSpec, Maybe Subst)]
-           get_std_constrained_tys dc_univs orig t_or_k ty
-               | is_functor_like
-               = mk_functor_like_constraints orig t_or_k main_cls $
-                 deepSubtypesContaining last_dc_univ ty
-               | otherwise
-               = [( [mk_cls_pred orig t_or_k main_cls ty]
-                  , Nothing )]
-             where
-               -- If 'is_functor_like' holds, then there should be at least one
-               -- universal type variable, making this use of 'last' safe.
-               last_dc_univ = assert (not (null dc_univs)) $
-                              last dc_univs
-
-           mk_functor_like_constraints :: CtOrigin -> TypeOrKind
-                                       -> Class -> [Type]
-                                       -> [(ThetaSpec, Maybe Subst)]
-           -- 'cls' is usually main_cls (Functor or Traversable etc), but if
-           -- main_cls = Generic1, then 'cls' can be Functor; see
-           -- get_gen1_constraints
-           --
-           -- For each type, generate two constraints,
-           -- [cls ty, kind(ty) ~ (*->*)], and a kind substitution that results
-           -- from unifying  kind(ty) with * -> *. If the unification is
-           -- successful, it will ensure that the resulting instance is well
-           -- kinded. If not, the second constraint will result in an error
-           -- message which points out the kind mismatch.
-           -- See Note [Inferring the instance context]
-           mk_functor_like_constraints orig t_or_k cls
-              = map $ \ty -> let ki = typeKind ty in
-                             ( [ mk_cls_pred orig t_or_k cls ty
-                               , SimplePredSpec
-                                   { sps_pred = mkPrimEqPred ki typeToTypeKind
-                                   , sps_origin = orig
-                                   , sps_type_or_kind = KindLevel
-                                   }
-                               ]
-                             , tcUnifyTy ki typeToTypeKind
-                             )
-
-           -- Extra Data constraints
-           -- The Data class (only) requires that for
-           --    instance (...) => Data (T t1 t2)
-           -- IF   t1:*, t2:*
-           -- THEN (Data t1, Data t2) are among the (...) constraints
-           -- Reason: when the IF holds, we generate a method
-           --             dataCast2 f = gcast2 f
-           --         and we need the Data constraints to typecheck the method
-           extra_constraints
-                 | main_cls `hasKey` dataClassKey
-                 , all (isLiftedTypeKind . typeKind) rep_tc_args
-                 = [ mk_cls_pred deriv_origin t_or_k main_cls ty
-                   | (t_or_k, ty) <- zip t_or_ks rep_tc_args]
-                 | otherwise
-                 = []
-
-           mk_cls_pred orig t_or_k cls ty
-                -- Don't forget to apply to cls_tys' too
-              = SimplePredSpec
-                  { sps_pred = mkClassPred cls (cls_tys' ++ [ty])
-                  , sps_origin = orig
-                  , sps_type_or_kind = t_or_k
-                  }
-           cls_tys' | is_generic1 = []
-                      -- In the awkward Generic1 case, cls_tys' should be
-                      -- empty, since we are applying the class Functor.
-
-                    | otherwise   = cls_tys
-
-           deriv_origin = mkDerivOrigin wildcard
-
-       if    -- Generic constraints are easy
-          |  is_generic
-           -> return ([], tvs, inst_tys, dit)
-
-             -- Generic1 needs Functor
-             -- See Note [Getting base classes]
-          |  is_generic1
-           -> assert (tyConTyVars rep_tc `lengthExceeds` 0) $
-              -- Generic1 has a single kind variable
-              assert (cls_tys `lengthIs` 1) $
-              do { functorClass <- lift $ tcLookupClass functorClassName
-                 ; pure $ con_arg_constraints
-                        $ get_gen1_constraints functorClass }
-
-             -- The others are a bit more complicated
-          |  otherwise
-           -> do { let (arg_constraints, tvs', inst_tys', dit')
-                         = con_arg_constraints get_std_constrained_tys
-                 ; lift $ traceTc "inferConstraintsStock" $ vcat
-                        [ ppr main_cls <+> ppr inst_tys'
-                        , ppr arg_constraints
-                        ]
-                 ; return ( extra_constraints ++ arg_constraints
-                          , tvs', inst_tys', dit' ) }
-
--- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@,
--- which gathers its constraints based on the type signatures of the class's
--- methods instead of the types of the data constructor's field.
---
--- See Note [Gathering and simplifying constraints for DeriveAnyClass]
--- for an explanation of how these constraints are used to determine the
--- derived instance context.
-inferConstraintsAnyclass :: DerivM ThetaSpec
-inferConstraintsAnyclass
-  = do { DerivEnv { denv_cls       = cls
-                  , denv_inst_tys  = inst_tys } <- ask
-       ; let gen_dms = [ (sel_id, dm_ty)
-                       | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]
-       ; wildcard <- isStandaloneWildcardDeriv
-
-       ; let meth_pred :: (Id, Type) -> PredSpec
-               -- (Id,Type) are the selector Id and the generic default method type
-               -- NB: the latter is /not/ quantified over the class variables
-               -- See Note [Gathering and simplifying constraints for DeriveAnyClass]
-             meth_pred (sel_id, gen_dm_ty)
-               = let (sel_tvs, _cls_pred, meth_ty) = tcSplitMethodTy (varType sel_id)
-                     meth_ty'   = substTyWith sel_tvs inst_tys meth_ty
-                     gen_dm_ty' = substTyWith sel_tvs inst_tys gen_dm_ty in
-                 -- This is the only place where a SubTypePredSpec is
-                 -- constructed instead of a SimplePredSpec. See
-                 -- Note [Gathering and simplifying constraints for DeriveAnyClass]
-                 -- for a more in-depth explanation.
-                 SubTypePredSpec { stps_ty_actual = gen_dm_ty'
-                                 , stps_ty_expected = meth_ty'
-                                 , stps_origin = mkDerivOrigin wildcard
-                                 }
-
-       ; pure $ map meth_pred gen_dms }
-
--- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and
--- @DerivingVia@. Since both strategies generate code involving 'coerce', the
--- inferred constraints set up the scaffolding needed to typecheck those uses
--- of 'coerce'. In this example:
---
--- > newtype Age = MkAge Int deriving newtype Num
---
--- We would infer the following constraints ('ThetaSpec'):
---
--- > (Num Int, Coercible Age Int)
-inferConstraintsCoerceBased :: [Type] -> Type
-                            -> DerivM ThetaSpec
-inferConstraintsCoerceBased cls_tys rep_ty = do
-  DerivEnv { denv_tvs      = tvs
-           , denv_cls      = cls
-           , denv_inst_tys = inst_tys } <- ask
-  sa_wildcard <- isStandaloneWildcardDeriv
-  let -- The following functions are polymorphic over the representation
-      -- type, since we might either give it the underlying type of a
-      -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type
-      -- (for DerivingVia).
-      rep_tys ty  = cls_tys ++ [ty]
-      rep_pred ty = mkClassPred cls (rep_tys ty)
-      rep_pred_o ty = SimplePredSpec { sps_pred = rep_pred ty
-                                     , sps_origin = deriv_origin
-                                     , sps_type_or_kind = TypeLevel
-                                     }
-              -- rep_pred is the representation dictionary, from where
-              -- we are going to get all the methods for the final
-              -- dictionary
-      deriv_origin = mkDerivOrigin sa_wildcard
-
-      -- Next we collect constraints for the class methods
-      -- If there are no methods, we don't need any constraints
-      -- Otherwise we need (C rep_ty), for the representation methods,
-      -- and constraints to coerce each individual method
-      meth_preds :: Type -> ThetaSpec
-      meth_preds ty
-        | null meths = [] -- No methods => no constraints
-                          -- (#12814)
-        | otherwise = rep_pred_o ty : coercible_constraints ty
-      meths = classMethods cls
-      coercible_constraints ty
-        = [ SimplePredSpec
-              { sps_pred = mkReprPrimEqPred t1 t2
-              , sps_origin = DerivOriginCoerce meth t1 t2 sa_wildcard
-              , sps_type_or_kind = TypeLevel
-              }
-          | meth <- meths
-          , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs
-                                       inst_tys ty meth ]
-
-  pure (meth_preds rep_ty)
-
-{- Note [Inferring the instance context]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are two sorts of 'deriving', as represented by the two constructors
-for DerivContext:
-
-  * InferContext mb_wildcard: This can either be:
-    - The deriving clause for a data type.
-        (e.g, data T a = T1 a deriving( Eq ))
-      In this case, mb_wildcard = Nothing.
-    - A standalone declaration with an extra-constraints wildcard
-        (e.g., deriving instance _ => Eq (Foo a))
-      In this case, mb_wildcard = Just loc, where loc is the location
-      of the extra-constraints wildcard.
-
-    Here we must infer an instance context,
-    and generate instance declaration
-      instance Eq a => Eq (T a) where ...
-
-  * SupplyContext theta: standalone deriving
-      deriving instance Eq a => Eq (T a)
-    Here we only need to fill in the bindings;
-    the instance context (theta) is user-supplied
-
-For the InferContext case, we must figure out the
-instance context (inferConstraintsStock). Suppose we are inferring
-the instance context for
-    C t1 .. tn (T s1 .. sm)
-There are two cases
-
-  * (T s1 .. sm) :: *         (the normal case)
-    Then we behave like Eq and guess (C t1 .. tn t)
-    for each data constructor arg of type t.  More
-    details below.
-
-  * (T s1 .. sm) :: * -> *    (the functor-like case)
-    Then we behave like Functor.
-
-In both cases we produce a bunch of un-simplified constraints
-and them simplify them in simplifyInstanceContexts; see
-Note [Simplifying the instance context].
-
-In the functor-like case, we may need to unify some kind variables with * in
-order for the generated instance to be well-kinded. An example from #10524:
-
-  newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)
-    = Compose (f (g a)) deriving Functor
-
-Earlier in the deriving pipeline, GHC unifies the kind of Compose f g
-(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this
-alone isn't enough, since k2 wasn't unified with *:
-
-  instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) =>
-    Functor (Compose f g) where ...
-
-The two Functor constraints are ill-kinded. To ensure this doesn't happen, we:
-
-  1. Collect all of a datatype's subtypes which require functor-like
-     constraints.
-  2. For each subtype, create a substitution by unifying the subtype's kind
-     with (* -> *).
-  3. Compose all the substitutions into one, then apply that substitution to
-     all of the in-scope type variables and the instance types.
-
-Note [Getting base classes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Functor and Typeable are defined in package 'base', and that is not available
-when compiling 'ghc-prim'.  So we must be careful that 'deriving' for stuff in
-ghc-prim does not use Functor or Typeable implicitly via these lookups.
-
-Note [Deriving and unboxed types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We have some special hacks to support things like
-   data T = MkT Int# deriving ( Show )
-
-Specifically, we use GHC.Tc.Deriv.Generate.box to box the Int# into an Int
-(which we know how to show), and append a '#'. Parentheses are not required
-for unboxed values (`MkT -3#` is a valid expression).
-
-Note [Superclasses of derived instance]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In general, a derived instance decl needs the superclasses of the derived
-class too.  So if we have
-        data T a = ...deriving( Ord )
-then the initial context for Ord (T a) should include Eq (T a).  Often this is
-redundant; we'll also generate an Ord constraint for each constructor argument,
-and that will probably generate enough constraints to make the Eq (T a) constraint
-be satisfied too.  But not always; consider:
-
- data S a = S
- instance Eq (S a)
- instance Ord (S a)
-
- data T a = MkT (S a) deriving( Ord )
- instance Num a => Eq (T a)
-
-The derived instance for (Ord (T a)) must have a (Num a) constraint!
-Similarly consider:
-        data T a = MkT deriving( Data )
-Here there *is* no argument field, but we must nevertheless generate
-a context for the Data instances:
-        instance Typeable a => Data (T a) where ...
-
-
-************************************************************************
-*                                                                      *
-         Finding the fixed point of deriving equations
-*                                                                      *
-************************************************************************
-
-Note [Simplifying the instance context]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-        data T a b = C1 (Foo a) (Bar b)
-                   | C2 Int (T b a)
-                   | C3 (T a a)
-                   deriving (Eq)
-
-We want to come up with an instance declaration of the form
-
-        instance (Ping a, Pong b, ...) => Eq (T a b) where
-                x == y = ...
-
-It is pretty easy, albeit tedious, to fill in the code "...".  The
-trick is to figure out what the context for the instance decl is,
-namely Ping, Pong and friends.
-
-Let's call the context reqd for the T instance of class C at types
-(a,b, ...)  C (T a b).  Thus:
-
-        Eq (T a b) = (Ping a, Pong b, ...)
-
-Now we can get a (recursive) equation from the data decl.  This part
-is done by inferConstraintsStock.
-
-        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
-                   u Eq (T b a) u Eq Int        -- From C2
-                   u Eq (T a a)                 -- From C3
-
-
-Foo and Bar may have explicit instances for Eq, in which case we can
-just substitute for them.  Alternatively, either or both may have
-their Eq instances given by deriving clauses, in which case they
-form part of the system of equations.
-
-Now all we need do is simplify and solve the equations, iterating to
-find the least fixpoint.  This is done by simplifyInstanceConstraints.
-Notice that the order of the arguments can
-switch around, as here in the recursive calls to T.
-
-Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
-
-We start with:
-
-        Eq (T a b) = {}         -- The empty set
-
-Next iteration:
-        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
-                   u Eq (T b a) u Eq Int        -- From C2
-                   u Eq (T a a)                 -- From C3
-
-        After simplification:
-                   = Eq a u Ping b u {} u {} u {}
-                   = Eq a u Ping b
-
-Next iteration:
-
-        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
-                   u Eq (T b a) u Eq Int        -- From C2
-                   u Eq (T a a)                 -- From C3
-
-        After simplification:
-                   = Eq a u Ping b
-                   u (Eq b u Ping a)
-                   u (Eq a u Ping a)
-
-                   = Eq a u Ping b u Eq b u Ping a
-
-The next iteration gives the same result, so this is the fixpoint.  We
-need to make a canonical form of the RHS to ensure convergence.  We do
-this by simplifying the RHS to a form in which
-
-        - the classes constrain only tyvars
-        - the list is sorted by tyvar (major key) and then class (minor key)
-        - no duplicates, of course
-
-Note [Deterministic simplifyInstanceContexts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Canonicalisation uses nonDetCmpType which is nondeterministic. Sorting
-with nonDetCmpType puts the returned lists in a nondeterministic order.
-If we were to return them, we'd get class constraints in
-nondeterministic order.
-
-Consider:
-
-  data ADT a b = Z a b deriving Eq
-
-The generated code could be either:
-
-  instance (Eq a, Eq b) => Eq (Z a b) where
-
-Or:
-
-  instance (Eq b, Eq a) => Eq (Z a b) where
-
-To prevent the order from being nondeterministic we only
-canonicalize when comparing and return them in the same order as
-simplifyDeriv returned them.
-See also Note [nonDetCmpType nondeterminism]
--}
-
-
-simplifyInstanceContexts :: [DerivSpec ThetaSpec]
-                         -> TcM [DerivSpec ThetaType]
--- Used only for deriving clauses or standalone deriving with an
--- extra-constraints wildcard (InferContext)
--- See Note [Simplifying the instance context]
-
-simplifyInstanceContexts [] = return []
-
-simplifyInstanceContexts infer_specs
-  = do  { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
-        ; final_specs <- iterate_deriv 1 initial_solutions
-          -- After simplification finishes, zonk the TcTyVars as described
-          -- in Note [Overlap and deriving].
-        ; traverse zonkDerivSpec final_specs }
-  where
-    ------------------------------------------------------------------
-        -- The initial solutions for the equations claim that each
-        -- instance has an empty context; this solution is certainly
-        -- in canonical form.
-    initial_solutions :: [ThetaType]
-    initial_solutions = [ [] | _ <- infer_specs ]
-
-    ------------------------------------------------------------------
-        -- iterate_deriv calculates the next batch of solutions,
-        -- compares it with the current one; finishes if they are the
-        -- same, otherwise recurses with the new solutions.
-        -- It fails if any iteration fails
-    iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType]
-    iterate_deriv n current_solns
-      | n > 20  -- Looks as if we are in an infinite loop
-                -- This can happen if we have -XUndecidableInstances
-                -- (See GHC.Tc.Solver.tcSimplifyDeriv.)
-      = pprPanic "solveDerivEqns: probable loop"
-                 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
-      | otherwise
-      = do {      -- Extend the inst info from the explicit instance decls
-                  -- with the current set of solutions, and simplify each RHS
-             inst_specs <- zipWithM (\soln -> newDerivClsInst . setDerivSpecTheta soln)
-                                    current_solns infer_specs
-           ; new_solns <- checkNoErrs $
-                          extendLocalInstEnv inst_specs $
-                          mapM gen_soln infer_specs
-
-           ; if (current_solns `eqSolution` new_solns) then
-                return [ setDerivSpecTheta soln spec
-                       | (spec, soln) <- zip infer_specs current_solns ]
-             else
-                iterate_deriv (n+1) new_solns }
-
-    eqSolution = (liftEq . liftEq) eqType `on` canSolution
-       -- Canonicalise for comparison
-       -- See Note [Deterministic simplifyInstanceContexts]
-    canSolution = map (sortBy nonDetCmpType)
-    ------------------------------------------------------------------
-    gen_soln :: DerivSpec ThetaSpec -> TcM ThetaType
-    gen_soln (DS { ds_loc = loc, ds_tvs = tyvars
-                 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs
-                 , ds_skol_info = skol_info, ds_user_ctxt = user_ctxt })
-      = setSrcSpan loc  $
-        addErrCtxt (derivInstCtxt the_pred) $
-        do { theta <- simplifyDeriv skol_info user_ctxt tyvars deriv_rhs
-                -- checkValidInstance tyvars theta clas inst_tys
-                -- Not necessary; see Note [Exotic derived instance contexts]
-
-           ; traceTc "GHC.Tc.Deriv" (ppr deriv_rhs $$ ppr theta)
-                -- Claim: the result instance declaration is guaranteed valid
-                -- Hence no need to call:
-                --   checkValidInstance tyvars theta clas inst_tys
-           ; return theta }
-      where
-        the_pred = mkClassPred clas inst_tys
-
-derivInstCtxt :: PredType -> SDoc
-derivInstCtxt pred
-  = text "When deriving the instance for" <+> parens (ppr pred)
-
-{-
-***********************************************************************************
-*                                                                                 *
-*            Simplify derived constraints
-*                                                                                 *
-***********************************************************************************
--}
-
--- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much
--- as possible. Fail if not possible.
-simplifyDeriv :: SkolemInfo -- ^ The 'SkolemInfo' used to skolemise the
-                            -- 'TcTyVar' arguments
-              -> UserTypeCtxt -- ^ Used to inform error messages as to whether
-                              -- we are in a @deriving@ clause or a standalone
-                              -- @deriving@ declaration
-              -> [TcTyVar]  -- ^ The tyvars bound by @inst_ty@.
-              -> ThetaSpec -- ^ The constraints to solve and simplify
-              -> TcM ThetaType -- ^ Needed constraints (after simplification),
-                               -- i.e. @['PredType']@.
-simplifyDeriv skol_info user_ctxt tvs theta
-  = do { let skol_set = mkVarSet tvs
-
-       -- See [STEP DAC BUILD]
-       -- Generate the implication constraints, one for each method, to solve
-       -- with the skolemized variables.  Start "one level down" because
-       -- we are going to wrap the result in an implication with tvs,
-       -- in step [DAC RESIDUAL]
-       ; (tc_lvl, wanteds) <- captureThetaSpecConstraints user_ctxt theta
-
-       ; traceTc "simplifyDeriv inputs" $
-         vcat [ pprTyVars tvs $$ ppr theta $$ ppr wanteds, ppr skol_info ]
-
-       -- See [STEP DAC SOLVE]
-       -- Simplify the constraints, starting at the same level at which
-       -- they are generated (c.f. the call to runTcSWithEvBinds in
-       -- simplifyInfer)
-       ; (solved_wanteds, _) <- setTcLevel tc_lvl $
-                                runTcS            $
-                                solveWanteds wanteds
-
-       -- It's not yet zonked!  Obviously zonk it before peering at it
-       ; solved_wanteds <- zonkWC solved_wanteds
-
-       -- See [STEP DAC HOIST]
-       -- From the simplified constraints extract a subset 'good' that will
-       -- become the context 'min_theta' for the derived instance.
-       ; let residual_simple = approximateWC True solved_wanteds
-             good = mapMaybeBag get_good residual_simple
-
-             -- Returns @Just p@ (where @p@ is the type of the Ct) if a Ct is
-             -- suitable to be inferred in the context of a derived instance.
-             -- Returns @Nothing@ if the Ct is too exotic.
-             -- See Note [Exotic derived instance contexts] for what
-             -- constitutes an exotic constraint.
-             get_good :: Ct -> Maybe PredType
-             get_good ct | validDerivPred skol_set p
-                         = Just p
-                         | otherwise
-                         = Nothing
-               where p = ctPred ct
-
-       ; traceTc "simplifyDeriv outputs" $
-         vcat [ ppr tvs, ppr residual_simple, ppr good ]
-
-       -- Return the good unsolved constraints (unskolemizing on the way out.)
-       ; let min_theta = mkMinimalBySCs id (bagToList good)
-             -- An important property of mkMinimalBySCs (used above) is that in
-             -- addition to removing constraints that are made redundant by
-             -- superclass relationships, it also removes _duplicate_
-             -- constraints.
-             -- See Note [Gathering and simplifying constraints for
-             --           DeriveAnyClass]
-
-       -- See [STEP DAC RESIDUAL]
-       -- Ensure that min_theta is enough to solve /all/ the constraints in
-       -- solved_wanteds, by solving the implication constraint
-       --
-       --    forall tvs. min_theta => solved_wanteds
-       ; min_theta_vars <- mapM newEvVar min_theta
-       ; (leftover_implic, _)
-           <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) tvs
-                                  min_theta_vars solved_wanteds
-       -- This call to simplifyTop is purely for error reporting
-       -- See Note [Error reporting for deriving clauses]
-       -- See also Note [Exotic derived instance contexts], which are caught
-       -- in this line of code.
-       ; simplifyTopImplic leftover_implic
-
-       ; return min_theta }
-
-{-
-Note [Overlap and deriving]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider some overlapping instances:
-  instance Show a => Show [a] where ..
-  instance Show [Char] where ...
-
-Now a data type with deriving:
-  data T a = MkT [a] deriving( Show )
-
-We want to get the derived instance
-  instance Show [a] => Show (T a) where...
-and NOT
-  instance Show a => Show (T a) where...
-so that the (Show (T Char)) instance does the Right Thing
-
-It's very like the situation when we're inferring the type
-of a function
-   f x = show [x]
-and we want to infer
-   f :: Show [a] => a -> String
-
-As a result, we use vanilla, non-overlappable skolems when inferring the
-context for the derived instances. Hence, we instantiate the type variables
-using tcInstSkolTyVars, not tcInstSuperSkolTyVars.
-
-We do this skolemisation in GHC.Tc.Deriv.mkEqnHelp, a function which occurs
-very early in the deriving pipeline, so that by the time GHC needs to infer the
-instance context, all of the types in the computed DerivSpec have been
-skolemised appropriately. After the instance context inference has completed,
-GHC zonks the TcTyVars in the DerivSpec to ensure that types like
-a[sk:1] do not appear in -ddump-deriv output.
-
-All of this is only needed when inferring an instance context, i.e., the
-InferContext case. For the SupplyContext case, we don't bother skolemising
-at all.
-
-Note [Gathering and simplifying constraints for DeriveAnyClass]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-DeriveAnyClass works quite differently from stock and newtype deriving in
-the way it gathers and simplifies constraints to be used in a derived
-instance's context. Stock and newtype deriving gather constraints by looking
-at the data constructors of the data type for which we are deriving an
-instance. But DeriveAnyClass doesn't need to know about a data type's
-definition at all!
-
-To see why, consider this example of DeriveAnyClass:
-
-  class Foo a where
-    bar :: forall b. Ix b => a -> b -> String
-    default bar :: (Show a, Ix c) => a -> c -> String
-    bar x y = show x ++ show (range (y,y))
-
-    baz :: Eq a => a -> a -> Bool
-    default baz :: (Ord a, Show a) => a -> a -> Bool
-    baz x y = compare x y == EQ
-
-Because 'bar' and 'baz' have default signatures, this generates a top-level
-definition for these generic default methods
-
-  $gdm_bar :: forall a. Foo a
-           => forall c. (Show a, Ix c)
-           => a -> c -> String
-  $gdm_bar x y = show x ++ show (range (y,y))
-
-(and similarly for baz).  Now consider a 'deriving' clause
-  data Maybe s = ... deriving anyclass Foo
-
-This derives an instance of the form:
-  instance (CX) => Foo (Maybe s) where
-    bar = $gdm_bar
-    baz = $gdm_baz
-
-Now it is GHC's job to fill in a suitable instance context (CX).  If
-GHC were typechecking the binding
-   bar = $gdm_bar
-it would
-   * skolemise the expected type of bar
-   * instantiate the type of $gdm_bar with meta-type variables
-   * build an implication constraint
-
-[STEP DAC BUILD]
-So that's what we do. Fortunately, there is already functionality within GHC
-to that does all of the above—namely, tcSubTypeSigma. In the example above,
-we want to use tcSubTypeSigma to check the following subtyping relation:
-
-     forall c. (Show a, Ix c) => Maybe s -> c -> String -- actual type
-  <= forall b.         (Ix b) => Maybe s -> b -> String -- expected type
-
-That is, we check that the type of $gdm_bar (the actual type) is more
-polymorphic than the type of bar (the expected type). We use SubTypePredSpec,
-a special form of PredSpec that is only used by DeriveAnyClass, to store
-the actual and expected types.
-
-(Aside: having a separate SubTypePredSpec is not strictly necessary, as we
-could theoretically construct this implication constraint by hand and store it
-in a SimplePredSpec. In fact, GHC used to do this. However, this is easier
-said than done, and there were numerous subtle bugs that resulted from getting
-this step wrong, such as #20719. Ultimately, we decided that special-casing a
-PredSpec specifically for DeriveAnyClass was worth it.)
-
-tcSubTypeSigma will ultimately spit out an implication constraint, which will
-look something like this (call it C1):
-
-   forall[2] b. Ix b => (Show (Maybe s), Ix cc,
-                        Maybe s -> b -> String
-                            ~ Maybe s -> cc -> String)
-
-Here:
-* The level of this forall constraint is forall[2], because we are later
-  going to wrap it in a forall[1] in [STEP DAC RESIDUAL]
-
-* The 'b' comes from the quantified type variable in the expected type
-  of bar. The 'cc' is a unification variable that comes from instantiating the
-  quantified type variable 'c' in $gdm_bar's type. The finer details of
-  skolemisation and metavariable instantiation are handled behind the scenes
-  by tcSubTypeSigma.
-
-* It is important that `b` be distinct from `cc`. In this example, this is
-  clearly the case, but it is not always so obvious when the type variables are
-  hidden behind type synonyms. Suppose the example were written like this,
-  for example:
-
-    type Method a = forall b. Ix b => a -> b -> String
-    class Foo a where
-      bar :: Method a
-      default bar :: Show a => Method a
-      bar = ...
-
-  Both method signatures quantify a `b` once the `Method` type synonym is
-  expanded. To ensure that GHC doesn't confuse the two `b`s during
-  typechecking, tcSubTypeSigma instantiates the `b` in the original signature
-  with a fresh skolem and the `b` in the default signature with a fresh
-  unification variable. Doing so prevents #20719 from happening.
-
-* The (Ix b) constraint comes from the context of bar's type. The
-  (Show (Maybe s)) and (Ix cc) constraints come from the context of $gdm_bar's
-  type.
-
-* The equality constraint (Maybe s -> b -> String) ~ (Maybe s -> cc -> String)
-  comes from marrying up the instantiated type of $gdm_bar with the specified
-  type of bar. Notice that the type variables from the instance, 's' in this
-  case, are global to this constraint.
-
-Note that it is vital that we instantiate the `c` in $gdm_bar's type with a new
-unification variable for each iteration of simplifyDeriv. If we re-use the same
-unification variable across multiple iterations, then bad things can happen,
-such as #14933.
-
-Similarly for 'baz', tcSubTypeSigma gives the constraint C2
-
-   forall[2]. Eq (Maybe s) => (Ord a, Show a,
-                              Maybe s -> Maybe s -> Bool
-                                ~ Maybe s -> Maybe s -> Bool)
-
-In this case baz has no local quantification, so the implication
-constraint has no local skolems and there are no unification
-variables.
-
-[STEP DAC SOLVE]
-We can combine these two implication constraints into a single
-constraint (C1, C2), and simplify, unifying cc:=b, to get:
-
-   forall[2] b. Ix b => Show a
-   /\
-   forall[2]. Eq (Maybe s) => (Ord a, Show a)
-
-[STEP DAC HOIST]
-Let's call that (C1', C2').  Now we need to hoist the unsolved
-constraints out of the implications to become our candidate for
-(CX). That is done by approximateWC, which will return:
-
-  (Show a, Ord a, Show a)
-
-Now we can use mkMinimalBySCs to remove superclasses and duplicates, giving
-
-  (Show a, Ord a)
-
-And that's what GHC uses for CX.
-
-[STEP DAC RESIDUAL]
-In this case we have solved all the leftover constraints, but what if
-we don't?  Simple!  We just form the final residual constraint
-
-   forall[1] s. CX => (C1',C2')
-
-and simplify that. In simple cases it'll succeed easily, because CX
-literally contains the constraints in C1', C2', but if there is anything
-more complicated it will be reported in a civilised way.
-
-Note [Error reporting for deriving clauses]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A surprisingly tricky aspect of deriving to get right is reporting sensible
-error messages. In particular, if simplifyDeriv reaches a constraint that it
-cannot solve, which might include:
-
-1. Insoluble constraints
-2. "Exotic" constraints (See Note [Exotic derived instance contexts])
-
-Then we report an error immediately in simplifyDeriv.
-
-Another possible choice is to punt and let another part of the typechecker
-(e.g., simplifyInstanceContexts) catch the errors. But this tends to lead
-to worse error messages, so we do it directly in simplifyDeriv.
-
-simplifyDeriv checks for errors in a clever way. If the deriving machinery
-infers the context (Foo a)--that is, if this instance is to be generated:
-
-  instance Foo a => ...
-
-Then we form an implication of the form:
-
-  forall a. Foo a => <residual_wanted_constraints>
-
-And pass it to the simplifier. If the context (Foo a) is enough to discharge
-all the constraints in <residual_wanted_constraints>, then everything is
-hunky-dory. But if <residual_wanted_constraints> contains, say, an insoluble
-constraint, then (Foo a) won't be able to solve it, causing GHC to error.
-
-Note [Exotic derived instance contexts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In a 'derived' instance declaration, we *infer* the context.  It's a
-bit unclear what rules we should apply for this; the Haskell report is
-silent.  Obviously, constraints like (Eq a) are fine, but what about
-        data T f a = MkT (f a) deriving( Eq )
-where we'd get an Eq (f a) constraint.  That's probably fine too.
-
-One could go further: consider
-        data T a b c = MkT (Foo a b c) deriving( Eq )
-        instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)
-
-Notice that this instance (just) satisfies the Paterson termination
-conditions.  Then we *could* derive an instance decl like this:
-
-        instance (C Int a, Eq b, Eq c) => Eq (T a b c)
-even though there is no instance for (C Int a), because there just
-*might* be an instance for, say, (C Int Bool) at a site where we
-need the equality instance for T's.
-
-However, this seems pretty exotic, and it's quite tricky to allow
-this, and yet give sensible error messages in the (much more common)
-case where we really want that instance decl for C.
-
-So for now we simply require that the derived instance context
-should have only type-variable constraints.
-
-Here is another example:
-        data Fix f = In (f (Fix f)) deriving( Eq )
-Here, if we are prepared to allow -XUndecidableInstances we
-could derive the instance
-        instance Eq (f (Fix f)) => Eq (Fix f)
-but this is so delicate that I don't think it should happen inside
-'deriving'. If you want this, write it yourself!
-
-NB: if you want to lift this condition, make sure you still meet the
-termination conditions!  If not, the deriving mechanism generates
-larger and larger constraints.  Example:
-  data Succ a = S a
-  data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show
-
-Note the lack of a Show instance for Succ.  First we'll generate
-  instance (Show (Succ a), Show a) => Show (Seq a)
-and then
-  instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)
-and so on.  Instead we want to complain of no instance for (Show (Succ a)).
-
-The bottom line
-~~~~~~~~~~~~~~~
-Allow constraints which consist only of type variables, with no repeats.
--}
diff --git a/compiler/GHC/Tc/Deriv/Utils.hs b/compiler/GHC/Tc/Deriv/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Deriv/Utils.hs
+++ /dev/null
@@ -1,1276 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE TypeFamilies #-}
-
--- | Error-checking and other utilities for @deriving@ clauses or declarations.
-module GHC.Tc.Deriv.Utils (
-        DerivM, DerivEnv(..),
-        DerivSpec(..), pprDerivSpec, setDerivSpecTheta, zonkDerivSpec,
-        DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,
-        isDerivSpecNewtype, isDerivSpecAnyClass,
-        isDerivSpecVia, zonkDerivSpecMechanism,
-        DerivContext(..), OriginativeDerivStatus(..), StockGenFns(..),
-        isStandaloneDeriv, isStandaloneWildcardDeriv,
-        askDerivUserTypeCtxt, mkDerivOrigin,
-        PredSpec(..), ThetaSpec,
-        mkDirectThetaSpec, substPredSpec, captureThetaSpecConstraints,
-        checkOriginativeSideConditions, hasStockDeriving,
-        std_class_via_coercible, non_coercible_class,
-        newDerivClsInst, extendLocalInstEnv
-    ) where
-
-import GHC.Prelude
-
-import GHC.Data.Bag
-import GHC.Types.Basic
-
-import GHC.Tc.Utils.Instantiate
-import GHC.Tc.Deriv.Generate
-import GHC.Tc.Deriv.Functor
-import GHC.Tc.Deriv.Generics
-import GHC.Tc.Errors.Types
-import GHC.Tc.Types.Constraint (WantedConstraints, mkNonCanonical)
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.Unify (tcSubTypeSigma)
-import GHC.Tc.Utils.Zonk
-
-import GHC.Core.Class
-import GHC.Core.DataCon
-import GHC.Core.FamInstEnv
-import GHC.Core.InstEnv
-import GHC.Core.TyCon
-import GHC.Core.Type
-
-import GHC.Hs
-import GHC.Driver.Session
-import GHC.Unit.Module (getModule)
-import GHC.Unit.Module.ModIface (mi_fix)
-
-import GHC.Types.Fixity.Env (lookupFixity)
-import GHC.Iface.Load   (loadInterfaceForName)
-import GHC.Types.Name
-import GHC.Types.SrcLoc
-import GHC.Utils.Misc
-import GHC.Types.Var.Set
-
-import GHC.Builtin.Names
-import GHC.Builtin.Names.TH (liftClassKey)
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Error
-
-import Control.Monad.Trans.Reader
-import Data.Foldable (traverse_)
-import Data.Maybe
-import qualified GHC.LanguageExtensions as LangExt
-import GHC.Data.List.SetOps (assocMaybe)
-
--- | To avoid having to manually plumb everything in 'DerivEnv' throughout
--- various functions in "GHC.Tc.Deriv" and "GHC.Tc.Deriv.Infer", we use 'DerivM', which
--- is a simple reader around 'TcRn'.
-type DerivM = ReaderT DerivEnv TcRn
-
--- | Is GHC processing a standalone deriving declaration?
-isStandaloneDeriv :: DerivM Bool
-isStandaloneDeriv = asks (go . denv_ctxt)
-  where
-    go :: DerivContext -> Bool
-    go (InferContext wildcard) = isJust wildcard
-    go (SupplyContext {})      = True
-
--- | Is GHC processing a standalone deriving declaration with an
--- extra-constraints wildcard as the context?
--- (e.g., @deriving instance _ => Eq (Foo a)@)
-isStandaloneWildcardDeriv :: DerivM Bool
-isStandaloneWildcardDeriv = asks (go . denv_ctxt)
-  where
-    go :: DerivContext -> Bool
-    go (InferContext wildcard) = isJust wildcard
-    go (SupplyContext {})      = False
-
--- | Return 'InstDeclCtxt' if processing with a standalone @deriving@
--- declaration or 'DerivClauseCtxt' if processing a @deriving@ clause.
-askDerivUserTypeCtxt :: DerivM UserTypeCtxt
-askDerivUserTypeCtxt = asks (go . denv_ctxt)
-  where
-    go :: DerivContext -> UserTypeCtxt
-    go (SupplyContext {})     = InstDeclCtxt True
-    go (InferContext Just{})  = InstDeclCtxt True
-    go (InferContext Nothing) = DerivClauseCtxt
-
--- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True',
--- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting.
-mkDerivOrigin :: Bool -> CtOrigin
-mkDerivOrigin standalone_wildcard
-  | standalone_wildcard = StandAloneDerivOrigin
-  | otherwise           = DerivClauseOrigin
-
--- | Contains all of the information known about a derived instance when
--- determining what its @EarlyDerivSpec@ should be.
--- See @Note [DerivEnv and DerivSpecMechanism]@.
-data DerivEnv = DerivEnv
-  { denv_overlap_mode :: Maybe OverlapMode
-    -- ^ Is this an overlapping instance?
-  , denv_tvs          :: [TyVar]
-    -- ^ Universally quantified type variables in the instance. If the
-    --   @denv_ctxt@ is 'InferContext', these will be 'TcTyVar' skolems.
-    --   If the @denv_ctxt@ is 'SupplyContext', these will be ordinary 'TyVar's.
-    --   See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".
-    --
-    --   All type variables that appear in the 'denv_inst_tys', 'denv_ctxt',
-    --   'denv_skol_info', and 'denv_strat' should come from 'denv_tvs'.
-  , denv_cls          :: Class
-    -- ^ Class for which we need to derive an instance
-  , denv_inst_tys     :: [Type]
-    -- ^ All arguments to 'denv_cls' in the derived instance.
-  , denv_ctxt         :: DerivContext
-    -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the
-    --   context of the instance).
-    --   'InferContext' for @deriving@ clauses, or for standalone deriving that
-    --   uses a wildcard constraint.
-    --   See @Note [Inferring the instance context]@.
-  , denv_skol_info    :: SkolemInfo
-    -- ^ The 'SkolemInfo' used to skolemise the @denv_tvs@ in the case where
-    --   the 'denv_ctxt' is 'InferContext'.
-  , denv_strat        :: Maybe (DerivStrategy GhcTc)
-    -- ^ 'Just' if user requests a particular deriving strategy.
-    --   Otherwise, 'Nothing'.
-  }
-
-instance Outputable DerivEnv where
-  ppr (DerivEnv { denv_overlap_mode = overlap_mode
-                , denv_tvs          = tvs
-                , denv_cls          = cls
-                , denv_inst_tys     = inst_tys
-                , denv_ctxt         = ctxt
-                , denv_skol_info    = skol_info
-                , denv_strat        = mb_strat })
-    = hang (text "DerivEnv")
-         2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode
-                 , text "denv_tvs"          <+> ppr tvs
-                 , text "denv_cls"          <+> ppr cls
-                 , text "denv_inst_tys"     <+> ppr inst_tys
-                 , text "denv_ctxt"         <+> ppr ctxt
-                 , text "denv_skol_info"    <+> ppr skol_info
-                 , text "denv_strat"        <+> ppr mb_strat ])
-
-data DerivSpec theta = DS { ds_loc                 :: SrcSpan
-                          , ds_name                :: Name         -- DFun name
-                          , ds_tvs                 :: [TyVar]
-                          , ds_theta               :: theta
-                          , ds_cls                 :: Class
-                          , ds_tys                 :: [Type]
-                          , ds_skol_info           :: SkolemInfo
-                          , ds_user_ctxt           :: UserTypeCtxt
-                          , ds_overlap             :: Maybe OverlapMode
-                          , ds_standalone_wildcard :: Maybe SrcSpan
-                              -- See Note [Inferring the instance context]
-                              -- in GHC.Tc.Deriv.Infer
-                          , ds_mechanism           :: DerivSpecMechanism }
-        -- This spec implies a dfun declaration of the form
-        --       df :: forall tvs. theta => C tys
-        -- The Name is the name for the DFun we'll build
-        -- The tyvars bind all the variables in the rest of the DerivSpec.
-        -- If we are inferring an instance context, the tyvars will be TcTyVar
-        -- skolems. After the instance context inference is over, the tyvars
-        -- will be zonked to TyVars. See
-        -- Note [Overlap and deriving] in GHC.Tc.Deriv.Infer.
-
-        -- the theta is either the given and final theta, in standalone deriving,
-        -- or the not-yet-simplified list of constraints together with their origin
-
-        -- The ds_skol_info is the SkolemInfo that was used to skolemise the
-        -- TcTyVars (if we are inferring an instance context). The ds_user_ctxt
-        -- is the UserTypeCtxt that allows error messages to know if we are in
-        -- a deriving clause or a standalone deriving declaration.
-
-        -- ds_mechanism specifies the means by which GHC derives the instance.
-        -- See Note [Deriving strategies] in GHC.Tc.Deriv
-
-{-
-Example:
-
-     newtype instance T [a] = MkT (Tree a) deriving( C s )
-==>
-     axiom T [a] = :RTList a
-     axiom :RTList a = Tree a
-
-     DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
-        , ds_mechanism = DerivSpecNewtype (Tree a) }
--}
-
-pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
-pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,
-                   ds_tys = tys, ds_theta = rhs, ds_skol_info = skol_info,
-                   ds_standalone_wildcard = wildcard, ds_mechanism = mech })
-  = hang (text "DerivSpec")
-       2 (vcat [ text "ds_loc                  =" <+> ppr l
-               , text "ds_name                 =" <+> ppr n
-               , text "ds_tvs                  =" <+> ppr tvs
-               , text "ds_cls                  =" <+> ppr c
-               , text "ds_tys                  =" <+> ppr tys
-               , text "ds_theta                =" <+> ppr rhs
-               , text "ds_skol_info            =" <+> ppr skol_info
-               , text "ds_standalone_wildcard  =" <+> ppr wildcard
-               , text "ds_mechanism            =" <+> ppr mech ])
-
-instance Outputable theta => Outputable (DerivSpec theta) where
-  ppr = pprDerivSpec
-
--- | Set the 'ds_theta' in a 'DerivSpec'.
-setDerivSpecTheta :: theta' -> DerivSpec theta -> DerivSpec theta'
-setDerivSpecTheta theta ds = ds{ds_theta = theta}
-
--- | Zonk the 'TcTyVar's in a 'DerivSpec' to 'TyVar's.
--- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType".
---
--- This is only used in the final zonking step when inferring
--- the context for a derived instance.
--- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".
-zonkDerivSpec :: DerivSpec ThetaType -> TcM (DerivSpec ThetaType)
-zonkDerivSpec ds@(DS { ds_tvs = tvs, ds_theta = theta
-                     , ds_tys = tys, ds_mechanism = mechanism
-                     }) = do
-  (ze, tvs') <- zonkTyBndrs tvs
-  theta'     <- zonkTcTypesToTypesX ze theta
-  tys'       <- zonkTcTypesToTypesX ze tys
-  mechanism' <- zonkDerivSpecMechanism ze mechanism
-  pure ds{ ds_tvs = tvs', ds_theta = theta'
-         , ds_tys = tys', ds_mechanism = mechanism'
-         }
-
--- | What action to take in order to derive a class instance.
--- See @Note [DerivEnv and DerivSpecMechanism]@, as well as
--- @Note [Deriving strategies]@ in "GHC.Tc.Deriv".
-data DerivSpecMechanism
-    -- | \"Standard\" classes
-  = DerivSpecStock
-    { dsm_stock_dit    :: DerivInstTys
-      -- ^ Information about the arguments to the class in the derived
-      -- instance, including what type constructor the last argument is
-      -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.
-    , dsm_stock_gen_fns :: StockGenFns
-      -- ^ How to generate the instance bindings and associated type family
-      -- instances.
-    }
-
-    -- | @GeneralizedNewtypeDeriving@
-  | DerivSpecNewtype
-    { dsm_newtype_dit    :: DerivInstTys
-      -- ^ Information about the arguments to the class in the derived
-      -- instance, including what type constructor the last argument is
-      -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.
-    , dsm_newtype_rep_ty :: Type
-      -- ^ The newtype rep type.
-    }
-
-    -- | @DeriveAnyClass@
-  | DerivSpecAnyClass
-
-    -- | @DerivingVia@
-  | DerivSpecVia
-    { dsm_via_cls_tys :: [Type]
-      -- ^ All arguments to the class besides the last one.
-    , dsm_via_inst_ty :: Type
-      -- ^ The last argument to the class.
-    , dsm_via_ty      :: Type
-      -- ^ The @via@ type
-    }
-
--- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'.
-derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc
-derivSpecMechanismToStrategy DerivSpecStock{}      = StockStrategy noExtField
-derivSpecMechanismToStrategy DerivSpecNewtype{}    = NewtypeStrategy noExtField
-derivSpecMechanismToStrategy DerivSpecAnyClass     = AnyclassStrategy noExtField
-derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty = t}) = ViaStrategy t
-
-isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia
-  :: DerivSpecMechanism -> Bool
-isDerivSpecStock (DerivSpecStock{}) = True
-isDerivSpecStock _                  = False
-
-isDerivSpecNewtype (DerivSpecNewtype{}) = True
-isDerivSpecNewtype _                    = False
-
-isDerivSpecAnyClass DerivSpecAnyClass = True
-isDerivSpecAnyClass _                 = False
-
-isDerivSpecVia (DerivSpecVia{}) = True
-isDerivSpecVia _                = False
-
--- | Zonk the 'TcTyVar's in a 'DerivSpecMechanism' to 'TyVar's.
--- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType".
---
--- This is only used in the final zonking step when inferring
--- the context for a derived instance.
--- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".
-zonkDerivSpecMechanism :: ZonkEnv -> DerivSpecMechanism -> TcM DerivSpecMechanism
-zonkDerivSpecMechanism ze mechanism =
-  case mechanism of
-    DerivSpecStock { dsm_stock_dit     = dit
-                   , dsm_stock_gen_fns = gen_fns
-                   } -> do
-      dit' <- zonkDerivInstTys ze dit
-      pure $ DerivSpecStock { dsm_stock_dit     = dit'
-                            , dsm_stock_gen_fns = gen_fns
-                            }
-    DerivSpecNewtype { dsm_newtype_dit    = dit
-                     , dsm_newtype_rep_ty = rep_ty
-                     } -> do
-      dit'    <- zonkDerivInstTys ze dit
-      rep_ty' <- zonkTcTypeToTypeX ze rep_ty
-      pure $ DerivSpecNewtype { dsm_newtype_dit    = dit'
-                              , dsm_newtype_rep_ty = rep_ty'
-                              }
-    DerivSpecAnyClass ->
-      pure DerivSpecAnyClass
-    DerivSpecVia { dsm_via_cls_tys = cls_tys
-                 , dsm_via_inst_ty = inst_ty
-                 , dsm_via_ty      = via_ty
-                 } -> do
-      cls_tys' <- zonkTcTypesToTypesX ze cls_tys
-      inst_ty' <- zonkTcTypeToTypeX ze inst_ty
-      via_ty'  <- zonkTcTypeToTypeX ze via_ty
-      pure $ DerivSpecVia { dsm_via_cls_tys = cls_tys'
-                          , dsm_via_inst_ty = inst_ty'
-                          , dsm_via_ty      = via_ty'
-                          }
-
-instance Outputable DerivSpecMechanism where
-  ppr (DerivSpecStock{dsm_stock_dit = dit})
-    = hang (text "DerivSpecStock")
-         2 (vcat [ text "dsm_stock_dit" <+> ppr dit ])
-  ppr (DerivSpecNewtype { dsm_newtype_dit = dit, dsm_newtype_rep_ty = rep_ty })
-    = hang (text "DerivSpecNewtype")
-         2 (vcat [ text "dsm_newtype_dit"    <+> ppr dit
-                 , text "dsm_newtype_rep_ty" <+> ppr rep_ty ])
-  ppr DerivSpecAnyClass = text "DerivSpecAnyClass"
-  ppr (DerivSpecVia { dsm_via_cls_tys = cls_tys, dsm_via_inst_ty = inst_ty
-                    , dsm_via_ty = via_ty })
-    = hang (text "DerivSpecVia")
-         2 (vcat [ text "dsm_via_cls_tys" <+> ppr cls_tys
-                 , text "dsm_via_inst_ty" <+> ppr inst_ty
-                 , text "dsm_via_ty"      <+> ppr via_ty ])
-
-{-
-Note [DerivEnv and DerivSpecMechanism]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-DerivEnv contains all of the bits and pieces that are common to every
-deriving strategy. (See Note [Deriving strategies] in GHC.Tc.Deriv.) Some deriving
-strategies impose stricter requirements on the types involved in the derived
-instance than others, and these differences are factored out into the
-DerivSpecMechanism type. Suppose that the derived instance looks like this:
-
-  instance ... => C arg_1 ... arg_n
-
-Each deriving strategy imposes restrictions on arg_1 through arg_n as follows:
-
-* stock (DerivSpecStock):
-
-  Stock deriving requires that:
-
-  - n must be a positive number. This is checked by
-    GHC.Tc.Deriv.expectNonNullaryClsArgs
-  - arg_n must be an application of an algebraic type constructor. Here,
-    "algebraic type constructor" means:
-
-    + An ordinary data type constructor, or
-    + A data family type constructor such that the arguments it is applied to
-      give rise to a data family instance.
-
-    This is checked by GHC.Tc.Deriv.expectAlgTyConApp.
-
-  This extra structure is witnessed by the DerivInstTys data type, which stores
-  arg_1 through arg_(n-1) (dit_cls_tys), the algebraic type constructor
-  (dit_tc), and its arguments (dit_tc_args). A DerivInstTys value can be seen
-  as a more structured representation of the denv_inst_tys field of DerivEnv.
-
-  If dit_tc is an ordinary data type constructor, then
-  dit_rep_tc/dit_rep_tc_args are the same as dit_tc/dit_tc_args. If dit_tc is a
-  data family type constructor, then dit_rep_tc is the representation type
-  constructor for the data family instance, and dit_rep_tc_args are the
-  arguments to the representation type constructor in the corresponding
-  instance.
-
-* newtype (DerivSpecNewtype):
-
-  Newtype deriving imposes the same DerivInstTys requirements as stock
-  deriving. This is necessary because we need to know what the underlying type
-  that the newtype wraps is, and this information can only be learned by
-  knowing dit_rep_tc.
-
-* anyclass (DerivSpecAnyclass):
-
-  DeriveAnyClass is the most permissive deriving strategy of all, as it
-  essentially imposes no requirements on the derived instance. This is because
-  DeriveAnyClass simply derives an empty instance, so it does not need any
-  particular knowledge about the types involved. It can do several things
-  that stock/newtype deriving cannot do (#13154):
-
-  - n can be 0. That is, one is allowed to anyclass-derive an instance with
-    no arguments to the class, such as in this example:
-
-      class C
-      deriving anyclass instance C
-
-  - One can derive an instance for a type that is not headed by a type
-    constructor, such as in the following example:
-
-      class C (n :: Nat)
-      deriving instance C 0
-      deriving instance C 1
-      ...
-
-  - One can derive an instance for a data family with no data family instances,
-    such as in the following example:
-
-      data family Foo a
-      class C a
-      deriving anyclass instance C (Foo a)
-
-* via (DerivSpecVia):
-
-  Like newtype deriving, DerivingVia requires that n must be a positive number.
-  This is because when one derives something like this:
-
-    deriving via Foo instance C Bar
-
-  Then the generated code must specifically mention Bar. However, in
-  contrast with newtype deriving, DerivingVia does *not* require Bar to be
-  an application of an algebraic type constructor. This is because the
-  generated code simply defers to invoking `coerce`, which does not need to
-  know anything in particular about Bar (besides that it is representationally
-  equal to Foo). This allows DerivingVia to do some things that are not
-  possible with newtype deriving, such as deriving instances for data families
-  without data instances (#13154):
-
-    data family Foo a
-    newtype ByBar a = ByBar a
-    class Baz a where ...
-    instance Baz (ByBar a) where ...
-    deriving via ByBar (Foo a) instance Baz (Foo a)
--}
-
--- | Whether GHC is processing a @deriving@ clause or a standalone deriving
--- declaration.
-data DerivContext
-  = InferContext (Maybe SrcSpan) -- ^ @'InferContext mb_wildcard@ is either:
-                                 --
-                                 -- * A @deriving@ clause (in which case
-                                 --   @mb_wildcard@ is 'Nothing').
-                                 --
-                                 -- * A standalone deriving declaration with
-                                 --   an extra-constraints wildcard as the
-                                 --   context (in which case @mb_wildcard@ is
-                                 --   @'Just' loc@, where @loc@ is the location
-                                 --   of the wildcard.
-                                 --
-                                 -- GHC should infer the context.
-
-  | SupplyContext ThetaType      -- ^ @'SupplyContext' theta@ is a standalone
-                                 -- deriving declaration, where @theta@ is the
-                                 -- context supplied by the user.
-
-instance Outputable DerivContext where
-  ppr (InferContext standalone) = text "InferContext"  <+> ppr standalone
-  ppr (SupplyContext theta)     = text "SupplyContext" <+> ppr theta
-
--- | Records whether a particular class can be derived by way of an
--- /originative/ deriving strategy (i.e., @stock@ or @anyclass@).
---
--- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv".
-data OriginativeDerivStatus
-  = CanDeriveStock StockGenFns -- Stock class, can derive
-  | StockClassError !DeriveInstanceErrReason -- Stock class, but can't do it
-  | CanDeriveAnyClass         -- See Note [Deriving any class]
-  | NonDerivableClass -- Cannot derive with either stock or anyclass
-
--- | Describes how to generate instance bindings ('stock_gen_binds') and
--- associated type family instances ('stock_gen_fam_insts') for a particular
--- stock-derived instance.
-data StockGenFns = StockGenFns
-  { stock_gen_binds ::
-         SrcSpan -> DerivInstTys
-      -> TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])
-    -- ^ Describes how to generate instance bindings for a stock-derived
-    -- instance.
-    --
-    -- This function takes two arguments:
-    --
-    -- 1. 'SrcSpan': the source location where the instance is being derived.
-    --    This will eventually be instantiated with the 'ds_loc' field of a
-    --    'DerivSpec'.
-    --
-    -- 2. 'DerivInstTys': information about the argument types to which a
-    --    class is applied in a derived instance. This will eventually be
-    --    instantiated with the 'dsm_stock_dit' field of a
-    --    'DerivSpecMechanism'.
-    --
-    -- This function returns four things:
-    --
-    -- 1. @'LHsBinds' 'GhcPs'@: The derived instance's function bindings
-    --    (e.g., @compare (T x) (T y) = compare x y@)
-    --
-    -- 2. @['LSig' 'GhcPs']@: A list of instance specific signatures/pragmas.
-    --    Most likely @INLINE@ pragmas for class methods.
-    --
-    -- 3. @'Bag' 'AuxBindSpec'@: Auxiliary bindings needed to support the
-    --    derived instance. As examples, derived 'Eq' and 'Ord' instances
-    --    sometimes require top-level @con2tag@ functions.
-    --    See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate".
-    --
-    -- 4. @['Name']@: A list of Names for which @-Wunused-binds@ should be
-    --    suppressed. This is used to suppress unused warnings for record
-    --    selectors when deriving 'Read', 'Show', or 'Generic'.
-    --    See @Note [Deriving and unused record selectors]@.
-  , stock_gen_fam_insts ::
-         SrcSpan -> DerivInstTys
-      -> TcM [FamInst]
-    -- ^ Describes how to generate associated type family instances for a
-    -- stock-derived instance. This function takes the same arguments as the
-    -- 'stock_gen_binds' function but returns a list of 'FamInst's instead.
-    -- Generating type family instances is done separately from
-    -- 'stock_gen_binds' since the type family instances must be generated
-    -- before the instance bindings can be typechecked. See
-    -- @Note [Staging of tcDeriving]@ in "GHC.Tc.Deriv".
-  }
-
--- A stock class is one either defined in the Haskell report or for which GHC
--- otherwise knows how to generate code for (possibly requiring the use of a
--- language extension), such as Eq, Ord, Ix, Data, Generic, etc.)
-
--- | A 'PredSpec' specifies a constraint to emitted when inferring the
--- instance context for a derived instance in 'GHC.Tc.Deriv.simplifyInfer'.
-data PredSpec
-  = -- | An ordinary 'PredSpec' that directly stores a 'PredType', which
-    -- will be emitted as a wanted constraint in the constraint solving
-    -- machinery. This is the simple case, as there are no skolems,
-    -- metavariables, or given constraints involved.
-    SimplePredSpec
-      { sps_pred :: TcPredType
-        -- ^ The constraint to emit as a wanted
-      , sps_origin :: CtOrigin
-        -- ^ The origin of the constraint
-      , sps_type_or_kind :: TypeOrKind
-        -- ^ Whether the constraint is a type or kind
-      }
-  | -- | A special 'PredSpec' that is only used by @DeriveAnyClass@. This
-    -- will check if @stps_ty_actual@ is a subtype of (i.e., more polymorphic
-    -- than) @stps_ty_expected@ in the constraint solving machinery, emitting an
-    -- implication constraint as a side effect. For more details on how this
-    -- works, see @Note [Gathering and simplifying constraints for DeriveAnyClass]@
-    -- in "GHC.Tc.Deriv.Infer".
-    SubTypePredSpec
-      { stps_ty_actual :: TcSigmaType
-        -- ^ The actual type. In the context of @DeriveAnyClass@, this is the
-        -- default method type signature.
-      , stps_ty_expected :: TcSigmaType
-        -- ^ The expected type. In the context of @DeriveAnyClass@, this is the
-        -- original method type signature.
-      , stps_origin :: CtOrigin
-        -- ^ The origin of the constraint
-      }
-
--- | A list of 'PredSpec' constraints to simplify when inferring a
--- derived instance's context. For the @stock@, @newtype@, and @via@ deriving
--- strategies, these will consist of 'SimplePredSpec's, and for
--- @DeriveAnyClass@, these will consist of 'SubTypePredSpec's. Here is an
--- example to illustrate the latter:
---
--- @
--- class Foo a where
---   bar :: forall b. Ix b => a -> b -> String
---   default bar :: forall y. (Show a, Ix y) => a -> y -> String
---   bar x y = show x ++ show (range (y, y))
---
---   baz :: Eq a => a -> a -> Bool
---   default baz :: Ord a => a -> a -> Bool
---   baz x y = compare x y == EQ
---
--- data Quux q = Quux deriving anyclass Foo
--- @
---
--- Then it would generate two 'SubTypePredSpec's, one for each method:
---
--- @
--- [ SubTypePredSpec
---     { stps_ty_actual   = forall y. (Show (Quux q), Ix y) => Quux q -> y -> String
---     , stps_ty_expected = forall b.                (Ix b) => Quux q -> b -> String
---     , stps_ty_origin   = DerivClauseCtxt
---     }
--- , SubTypePredSpec
---     { stps_ty_actual   = Ord (Quux q) => Quux q -> Quux q -> Bool
---     , stps_ty_expected = Eq  (Quux q) => Quux q -> Quux q -> Bool
---     , stps_ty_origin   = DerivClauseCtxt
---     }
--- ]
--- @
---
--- (Note that the type variable @q@ is bound by the data type @Quux@, and thus
--- appears free in the 'stps_ty_actual's and 'stps_ty_expected's.)
---
--- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@
--- in "GHC.Tc.Deriv.Infer" for an explanation of how these 'SubTypePredSpec's
--- are used to compute implication constraints.
-type ThetaSpec = [PredSpec]
-
-instance Outputable PredSpec where
-  ppr (SimplePredSpec{sps_pred = ty}) =
-    hang (text "SimplePredSpec")
-       2 (vcat [ text "sps_pred" <+> ppr ty ])
-  ppr (SubTypePredSpec { stps_ty_actual = ty_actual
-                       , stps_ty_expected = ty_expected }) =
-    hang (text "SubTypePredSpec")
-       2 (vcat [ text "stps_ty_actual"   <+> ppr ty_actual
-               , text "stps_ty_expected" <+> ppr ty_expected
-               ])
-
--- | Build a list of 'SimplePredSpec's, using the supplied 'CtOrigin' and
--- 'TypeOrKind' values for each 'PredType'.
-mkDirectThetaSpec :: CtOrigin -> TypeOrKind -> ThetaType -> ThetaSpec
-mkDirectThetaSpec origin t_or_k =
-  map (\p -> SimplePredSpec
-               { sps_pred = p
-               , sps_origin = origin
-               , sps_type_or_kind = t_or_k
-               })
-
-substPredSpec :: HasCallStack => Subst -> PredSpec -> PredSpec
-substPredSpec subst ps =
-  case ps of
-    SimplePredSpec { sps_pred = pred
-                   , sps_origin = origin
-                   , sps_type_or_kind = t_or_k
-                   }
-      -> SimplePredSpec { sps_pred = substTy subst pred
-                        , sps_origin = origin
-                        , sps_type_or_kind = t_or_k
-                        }
-
-    SubTypePredSpec { stps_ty_actual = ty_actual
-                    , stps_ty_expected = ty_expected
-                    , stps_origin = origin
-                    }
-      -> SubTypePredSpec { stps_ty_actual = substTy subst ty_actual
-                         , stps_ty_expected = substTy subst ty_expected
-                         , stps_origin = origin
-                         }
-
--- | Capture wanted constraints from a 'ThetaSpec'.
-captureThetaSpecConstraints ::
-     UserTypeCtxt -- ^ Used to inform error messages as to whether
-                  -- we are in a @deriving@ clause or a standalone
-                  -- @deriving@ declaration
-  -> ThetaSpec    -- ^ The specs from which constraints will be created
-  -> TcM (TcLevel, WantedConstraints)
-captureThetaSpecConstraints user_ctxt theta =
-  pushTcLevelM $ mk_wanteds theta
-  where
-    -- Create the constraints we need to solve. For stock and newtype
-    -- deriving, these constraints will be simple wanted constraints
-    -- like (C a, Ord b).
-    -- But with DeriveAnyClass, we make an implication constraint.
-    -- See Note [Gathering and simplifying constraints for DeriveAnyClass]
-    -- in GHC.Tc.Deriv.Infer.
-    mk_wanteds :: ThetaSpec -> TcM WantedConstraints
-    mk_wanteds preds
-      = do { (_, wanteds) <- captureConstraints $
-                             traverse_ emit_constraints preds
-           ; pure wanteds }
-
-    -- Emit the appropriate constraints depending on what sort of
-    -- PredSpec we are dealing with.
-    emit_constraints :: PredSpec -> TcM ()
-    emit_constraints ps =
-      case ps of
-        -- For constraints like (C a, Ord b), emit the
-        -- constraints directly as simple wanted constraints.
-        SimplePredSpec { sps_pred = wanted
-                       , sps_origin = orig
-                       , sps_type_or_kind = t_or_k
-                       } -> do
-          ev <- newWanted orig (Just t_or_k) wanted
-          emitSimple (mkNonCanonical ev)
-
-        -- For DeriveAnyClass, check if ty_actual is a subtype of
-        -- ty_expected, which emits an implication constraint as a
-        -- side effect. See
-        -- Note [Gathering and simplifying constraints for DeriveAnyClass].
-        -- in GHC.Tc.Deriv.Infer.
-        SubTypePredSpec { stps_ty_actual   = ty_actual
-                        , stps_ty_expected = ty_expected
-                        , stps_origin      = orig
-                        } -> do
-          _ <- tcSubTypeSigma orig user_ctxt ty_actual ty_expected
-          return ()
-
-{-
-************************************************************************
-*                                                                      *
-                Class deriving diagnostics
-*                                                                      *
-************************************************************************
-
-Only certain blessed classes can be used in a deriving clause (without the
-assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes
-are listed below in the definition of hasStockDeriving. The stockSideConditions
-function determines the criteria that needs to be met in order for a particular
-stock class to be able to be derived successfully.
-
-A class might be able to be used in a deriving clause if -XDeriveAnyClass
-is willing to support it.
--}
-
-hasStockDeriving
-  :: Class -> Maybe StockGenFns
-hasStockDeriving clas
-  = assocMaybe gen_list (getUnique clas)
-  where
-    gen_list :: [(Unique, StockGenFns)]
-    gen_list =
-      [ (eqClassKey,          mk (simple_bindsM gen_Eq_binds) no_fam_insts)
-      , (ordClassKey,         mk (simple_bindsM gen_Ord_binds) no_fam_insts)
-      , (enumClassKey,        mk (simple_bindsM gen_Enum_binds) no_fam_insts)
-      , (boundedClassKey,     mk (simple_binds gen_Bounded_binds) no_fam_insts)
-      , (ixClassKey,          mk (simple_bindsM gen_Ix_binds) no_fam_insts)
-      , (showClassKey,        mk (read_or_show_binds gen_Show_binds) no_fam_insts)
-      , (readClassKey,        mk (read_or_show_binds gen_Read_binds) no_fam_insts)
-      , (dataClassKey,        mk (simple_bindsM gen_Data_binds) no_fam_insts)
-      , (functorClassKey,     mk (simple_binds gen_Functor_binds) no_fam_insts)
-      , (foldableClassKey,    mk (simple_binds gen_Foldable_binds) no_fam_insts)
-      , (traversableClassKey, mk (simple_binds gen_Traversable_binds) no_fam_insts)
-      , (liftClassKey,        mk (simple_binds gen_Lift_binds) no_fam_insts)
-      , (genClassKey,         mk (generic_binds Gen0) (generic_fam_inst Gen0))
-      , (gen1ClassKey,        mk (generic_binds Gen1) (generic_fam_inst Gen1))
-      ]
-
-    mk gen_binds_fn gen_fam_insts_fn = StockGenFns
-      { stock_gen_binds     = gen_binds_fn
-      , stock_gen_fam_insts = gen_fam_insts_fn
-      }
-
-    simple_binds gen_fn loc dit
-      = let (binds, aux_specs) = gen_fn loc dit
-        in return (binds, [], aux_specs, [])
-
-    -- Like `simple`, but monadic. The only monadic thing that these functions
-    -- do is allocate new Uniques, which are used for generating the names of
-    -- auxiliary bindings.
-    -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
-    simple_bindsM gen_fn loc dit
-      = do { (binds, aux_specs) <- gen_fn loc dit
-           ; return (binds, [], aux_specs, []) }
-
-    read_or_show_binds gen_fn loc dit
-      = do { let tc = dit_rep_tc dit
-           ; fix_env <- getDataConFixityFun tc
-           ; let (binds, aux_specs) = gen_fn fix_env loc dit
-                 field_names        = all_field_names tc
-           ; return (binds, [], aux_specs, field_names) }
-
-    generic_binds gk loc dit
-      = do { let tc = dit_rep_tc dit
-           ; (binds, sigs) <- gen_Generic_binds gk loc dit
-           ; let field_names = all_field_names tc
-           ; return (binds, sigs, emptyBag, field_names) }
-
-    generic_fam_inst gk loc dit
-      = do { let tc = dit_rep_tc dit
-           ; fix_env <- getDataConFixityFun tc
-           ; faminst <- gen_Generic_fam_inst gk fix_env loc dit
-           ; return [faminst] }
-
-    no_fam_insts _ _ = pure []
-
-    -- See Note [Deriving and unused record selectors]
-    all_field_names = map flSelector . concatMap dataConFieldLabels
-                                     . tyConDataCons
-
-{-
-Note [Deriving and unused record selectors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this (see #13919):
-
-  module Main (main) where
-
-  data Foo = MkFoo {bar :: String} deriving Show
-
-  main :: IO ()
-  main = print (Foo "hello")
-
-Strictly speaking, the record selector `bar` is unused in this module, since
-neither `main` nor the derived `Show` instance for `Foo` mention `bar`.
-However, the behavior of `main` is affected by the presence of `bar`, since
-it will print different output depending on whether `MkFoo` is defined using
-record selectors or not. Therefore, we do not to issue a
-"Defined but not used: ‘bar’" warning for this module, since removing `bar`
-changes the program's behavior. This is the reason behind the [Name] part of
-the return type of `hasStockDeriving`—it tracks all of the record selector
-`Name`s for which -Wunused-binds should be suppressed.
-
-Currently, the only three stock derived classes that require this are Read,
-Show, and Generic, as their derived code all depend on the record selectors
-of the derived data type's constructors.
-
-See also Note [Unused constructors and deriving clauses] in GHC.Tc.Deriv for
-another example of a similar trick.
--}
-
-getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
--- If the TyCon is locally defined, we want the local fixity env;
--- but if it is imported (which happens for standalone deriving)
--- we need to get the fixity env from the interface file
--- c.f. GHC.Rename.Env.lookupFixity, #9830, and #20994
-getDataConFixityFun tc
-  = do { this_mod <- getModule
-       ; if nameIsLocalOrFrom this_mod name
-         then do { fix_env <- getFixityEnv
-                 ; return (lookupFixity fix_env) }
-         else do { iface <- loadInterfaceForName doc name
-                            -- Should already be loaded!
-                 ; return (mi_fix iface . nameOccName) } }
-  where
-    name = tyConName tc
-    doc = text "Data con fixities for" <+> ppr name
-
-------------------------------------------------------------------
--- Check side conditions that dis-allow derivability for the originative
--- deriving strategies (stock and anyclass).
--- See Note [Deriving strategies] in GHC.Tc.Deriv for an explanation of what
--- "originative" means.
---
--- This is *apart* from the coerce-based strategies, newtype and via.
---
--- Here we get the representation tycon in case of family instances as it has
--- the data constructors - but we need to be careful to fall back to the
--- family tycon (with indexes) in error messages.
-
-checkOriginativeSideConditions :: DerivInstTys -> DerivM OriginativeDerivStatus
-checkOriginativeSideConditions dit@(DerivInstTys{dit_cls_tys = cls_tys}) =
-  do DerivEnv { denv_cls  = cls
-              , denv_ctxt = deriv_ctxt } <- ask
-     dflags <- getDynFlags
-
-     if    -- First, check if stock deriving is possible...
-        |  Just cond <- stockSideConditions deriv_ctxt cls
-        -> case cond dflags dit of
-             NotValid err -> pure $ StockClassError err  -- Class-specific error
-             IsValid  |  null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
-                         -- All stock derivable classes are unary in the sense that
-                         -- there should be not types in cls_tys (i.e., no type args
-                         -- other than last). Note that cls_types can contain
-                         -- invisible types as well (e.g., for Generic1, which is
-                         -- poly-kinded), so make sure those are not counted.
-                      ,  Just gen_fn <- hasStockDeriving cls
-                      -> pure $ CanDeriveStock gen_fn
-                      |  otherwise
-                      -> pure $ StockClassError $ classArgsErr cls cls_tys
-                        -- e.g. deriving( Eq s )
-
-           -- ...if not, try falling back on DeriveAnyClass.
-        |  xopt LangExt.DeriveAnyClass dflags
-        -> pure CanDeriveAnyClass   -- DeriveAnyClass should work
-
-        |  otherwise
-        -> pure NonDerivableClass -- Neither anyclass nor stock work
-
-
-classArgsErr :: Class -> [Type] -> DeriveInstanceErrReason
-classArgsErr cls cls_tys = DerivErrNotAClass (mkClassPred cls cls_tys)
-
--- Side conditions (whether the datatype must have at least one constructor,
--- required language extensions, etc.) for using GHC's stock deriving
--- mechanism on certain classes (as opposed to classes that require
--- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a
--- class for which stock deriving isn't possible.
-stockSideConditions :: DerivContext -> Class -> Maybe Condition
-stockSideConditions deriv_ctxt cls
-  | cls_key == eqClassKey          = Just (cond_std `andCond` cond_args cls)
-  | cls_key == ordClassKey         = Just (cond_std `andCond` cond_args cls)
-  | cls_key == showClassKey        = Just (cond_std `andCond` cond_args cls)
-  | cls_key == readClassKey        = Just (cond_std `andCond` cond_args cls)
-  | cls_key == enumClassKey        = Just (cond_std `andCond` cond_isEnumeration)
-  | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct cls)
-  | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct cls)
-  | cls_key == dataClassKey        = Just (checkFlag LangExt.DeriveDataTypeable `andCond`
-                                           cond_vanilla `andCond`
-                                           cond_args cls)
-  | cls_key == functorClassKey     = Just (checkFlag LangExt.DeriveFunctor `andCond`
-                                           cond_vanilla `andCond`
-                                           cond_functorOK True False)
-  | cls_key == foldableClassKey    = Just (checkFlag LangExt.DeriveFoldable `andCond`
-                                           cond_vanilla `andCond`
-                                           cond_functorOK False True)
-                                           -- Functor/Fold/Trav works ok
-                                           -- for rank-n types
-  | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond`
-                                           cond_vanilla `andCond`
-                                           cond_functorOK False False)
-  | cls_key == genClassKey         = Just (checkFlag LangExt.DeriveGeneric `andCond`
-                                           cond_vanilla `andCond`
-                                           cond_RepresentableOk)
-  | cls_key == gen1ClassKey        = Just (checkFlag LangExt.DeriveGeneric `andCond`
-                                           cond_vanilla `andCond`
-                                           cond_Representable1Ok)
-  | cls_key == liftClassKey        = Just (checkFlag LangExt.DeriveLift `andCond`
-                                           cond_vanilla `andCond`
-                                           cond_args cls)
-  | otherwise                      = Nothing
-  where
-    cls_key = getUnique cls
-    cond_std     = cond_stdOK deriv_ctxt False
-      -- Vanilla data constructors, at least one, and monotype arguments
-    cond_vanilla = cond_stdOK deriv_ctxt True
-      -- Vanilla data constructors but allow no data cons or polytype arguments
-
-type Condition
-   = DynFlags
-
-  -> DerivInstTys -- ^ Information about the type arguments to the class.
-
-  -> Validity' DeriveInstanceErrReason
-     -- ^ 'IsValid' if deriving an instance for this type is
-     -- possible. Otherwise, it's @'NotValid' err@, where @err@
-     -- explains what went wrong.
-
-andCond :: Condition -> Condition -> Condition
-andCond c1 c2 dflags dit
-  = c1 dflags dit `andValid` c2 dflags dit
-
--- | Some common validity checks shared among stock derivable classes. One
--- check that absolutely must hold is that if an instance @C (T a)@ is being
--- derived, then @T@ must be a tycon for a data type or a newtype. The
--- remaining checks are only performed if using a @deriving@ clause (i.e.,
--- they're ignored if using @StandaloneDeriving@):
---
--- 1. The data type must have at least one constructor (this check is ignored
---    if using @EmptyDataDeriving@).
---
--- 2. The data type cannot have any GADT constructors.
---
--- 3. The data type cannot have any constructors with existentially quantified
---    type variables.
---
--- 4. The data type cannot have a context (e.g., @data Foo a = Eq a => MkFoo@).
---
--- 5. The data type cannot have fields with higher-rank types.
-cond_stdOK
-  :: DerivContext -- ^ 'SupplyContext' if this is standalone deriving with a
-                  -- user-supplied context, 'InferContext' if not.
-                  -- If it is the former, we relax some of the validity checks
-                  -- we would otherwise perform (i.e., "just go for it").
-
-  -> Bool         -- ^ 'True' <=> allow higher rank arguments and empty data
-                  -- types (with no data constructors) even in the absence of
-                  -- the -XEmptyDataDeriving extension.
-
-  -> Condition
-cond_stdOK deriv_ctxt permissive dflags
-           dit@(DerivInstTys{dit_tc = tc, dit_rep_tc = rep_tc})
-  = valid_ADT `andValid` valid_misc
-  where
-    valid_ADT, valid_misc :: Validity' DeriveInstanceErrReason
-    valid_ADT
-      | isAlgTyCon tc || isDataFamilyTyCon tc
-      = IsValid
-      | otherwise
-        -- Complain about functions, primitive types, and other tycons that
-        -- stock deriving can't handle.
-      = NotValid DerivErrLastArgMustBeApp
-
-    valid_misc
-      = case deriv_ctxt of
-         SupplyContext _ -> IsValid
-                -- Don't check these conservative conditions for
-                -- standalone deriving; just generate the code
-                -- and let the typechecker handle the result
-         InferContext wildcard
-           | null data_cons -- 1.
-           , not permissive
-           , not (xopt LangExt.EmptyDataDeriving dflags)
-           -> NotValid (no_cons_why rep_tc)
-           | not (null con_whys)
-           -> NotValid $ DerivErrBadConstructor (Just $ has_wildcard wildcard) con_whys
-           | otherwise
-           -> IsValid
-
-    has_wildcard wildcard
-      = case wildcard of
-          Just _  -> YesHasWildcard
-          Nothing -> NoHasWildcard
-    data_cons  = tyConDataCons rep_tc
-    con_whys   = getInvalids (map check_con data_cons)
-
-    check_con :: DataCon -> Validity' DeriveInstanceBadConstructor
-    check_con con
-      | not (null eq_spec) -- 2.
-      = bad DerivErrBadConIsGADT
-      | not (null ex_tvs) -- 3.
-      = bad DerivErrBadConHasExistentials
-      | not (null theta) -- 4.
-      = bad DerivErrBadConHasConstraints
-      | not (permissive || all isTauTy (derivDataConInstArgTys con dit)) -- 5.
-      = bad DerivErrBadConHasHigherRankType
-      | otherwise
-      = IsValid
-      where
-        (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con
-        bad mkErr = NotValid $ mkErr con
-
-no_cons_why :: TyCon -> DeriveInstanceErrReason
-no_cons_why = DerivErrNoConstructors
-
-cond_RepresentableOk :: Condition
-cond_RepresentableOk _ dit =
-  case canDoGenerics dit of
-    IsValid -> IsValid
-    NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs
-
-cond_Representable1Ok :: Condition
-cond_Representable1Ok _ dit =
-  case canDoGenerics1 dit of
-    IsValid -> IsValid
-    NotValid generic_errs -> NotValid $ DerivErrGenerics generic_errs
-
-cond_enumOrProduct :: Class -> Condition
-cond_enumOrProduct cls = cond_isEnumeration `orCond`
-                         (cond_isProduct `andCond` cond_args cls)
-  where
-    orCond :: Condition -> Condition -> Condition
-    orCond c1 c2 dflags dit
-      = case (c1 dflags dit, c2 dflags dit) of
-         (IsValid,    _)          -> IsValid    -- c1 succeeds
-         (_,          IsValid)    -> IsValid    -- c21 succeeds
-         (NotValid x, NotValid y) -> NotValid $ DerivErrEnumOrProduct x y
-                                                -- Both fail
-
-
-cond_args :: Class -> Condition
--- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types
--- by generating specialised code.  For others (eg 'Data') we don't.
--- For even others (eg 'Lift'), unlifted types aren't even a special
--- consideration!
-cond_args cls _ dit@(DerivInstTys{dit_rep_tc = rep_tc})
-  = case bad_args of
-      []     -> IsValid
-      (ty:_) -> NotValid $ DerivErrDunnoHowToDeriveForType ty
-  where
-    bad_args = [ arg_ty | con <- tyConDataCons rep_tc
-                        , arg_ty <- derivDataConInstArgTys con dit
-                        , mightBeUnliftedType arg_ty
-                        , not (ok_ty arg_ty) ]
-
-    cls_key = classKey cls
-    ok_ty arg_ty
-     | cls_key == eqClassKey   = check_in arg_ty ordOpTbl
-     | cls_key == ordClassKey  = check_in arg_ty ordOpTbl
-     | cls_key == showClassKey = check_in arg_ty boxConTbl
-     | cls_key == liftClassKey = True     -- Lift is representation-polymorphic
-     | otherwise               = False    -- Read, Ix etc
-
-    check_in :: Type -> [(Type,a)] -> Bool
-    check_in arg_ty tbl = any (eqType arg_ty . fst) tbl
-
-
-cond_isEnumeration :: Condition
-cond_isEnumeration _ (DerivInstTys{dit_rep_tc = rep_tc})
-  | isEnumerationTyCon rep_tc = IsValid
-  | otherwise                 = NotValid $ DerivErrMustBeEnumType rep_tc
-
-cond_isProduct :: Condition
-cond_isProduct _ (DerivInstTys{dit_rep_tc = rep_tc})
-  | Just _ <- tyConSingleDataCon_maybe rep_tc
-  = IsValid
-  | otherwise
-  = NotValid $ DerivErrMustHaveExactlyOneConstructor rep_tc
-
-cond_functorOK :: Bool -> Bool -> Condition
--- OK for Functor/Foldable/Traversable class
--- Currently: (a) at least one argument
---            (b) don't use argument contravariantly
---            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
---            (d) optionally: don't use function types
---            (e) no "stupid context" on data type
-cond_functorOK allowFunctions allowExQuantifiedLastTyVar _
-               dit@(DerivInstTys{dit_rep_tc = rep_tc})
-  | null tc_tvs
-  = NotValid $ DerivErrMustHaveSomeParameters rep_tc
-
-    -- We can't handle stupid contexts that mention the last type argument,
-    -- so error out if we encounter one.
-    -- See Note [The stupid context] in GHC.Core.DataCon.
-  | not (null bad_stupid_theta)
-  = NotValid $ DerivErrMustNotHaveClassContext rep_tc bad_stupid_theta
-
-  | otherwise
-  = allValid (map check_con data_cons)
-  where
-    tc_tvs            = tyConTyVars rep_tc
-    last_tv           = last tc_tvs
-    bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)
-    is_bad pred       = last_tv `elemVarSet` exactTyCoVarsOfType pred
-      -- See Note [Check that the type variable is truly universal]
-
-    data_cons = tyConDataCons rep_tc
-    check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con dit)
-
-    check_universal :: DataCon -> Validity' DeriveInstanceErrReason
-    check_universal con
-      | allowExQuantifiedLastTyVar
-      = IsValid -- See Note [DeriveFoldable with ExistentialQuantification]
-                -- in GHC.Tc.Deriv.Functor
-      | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))
-      , tv `elem` dataConUnivTyVars con
-      , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con))
-      = IsValid   -- See Note [Check that the type variable is truly universal]
-      | otherwise
-      = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConExistential con]
-
-    ft_check :: DataCon -> FFoldType (Validity' DeriveInstanceErrReason)
-    ft_check con = FT { ft_triv = IsValid, ft_var = IsValid
-                      , ft_co_var = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConCovariant con]
-                      , ft_fun = \x y -> if allowFunctions then x `andValid` y
-                                                           else NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConFunTypes con]
-                      , ft_tup = \_ xs  -> allValid xs
-                      , ft_ty_app = \_ _ x -> x
-                      , ft_bad_app = NotValid $ DerivErrBadConstructor Nothing [DerivErrBadConWrongArg con]
-                      , ft_forall = \_ x   -> x }
-
-
-checkFlag :: LangExt.Extension -> Condition
-checkFlag flag dflags _
-  | xopt flag dflags = IsValid
-  | otherwise        = NotValid why
-  where
-    why = DerivErrLangExtRequired the_flag
-    the_flag = case [ flagSpecFlag f | f <- xFlags , flagSpecFlag f == flag ] of
-                 [s]   -> s
-                 other -> pprPanic "checkFlag" (ppr other)
-
-std_class_via_coercible :: Class -> Bool
--- These standard classes can be derived for a newtype
--- using the coercible trick *even if no -XGeneralizedNewtypeDeriving
--- because giving so gives the same results as generating the boilerplate
-std_class_via_coercible clas
-  = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
-        -- Not Read/Show because they respect the type
-        -- Not Enum, because newtypes are never in Enum
-
-
-non_coercible_class :: Class -> Bool
--- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift
--- by Coercible, even with -XGeneralizedNewtypeDeriving
--- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived
--- instance behave differently if there's a non-lawful Applicative out there.
--- Besides, with roles, Coercible-deriving Traversable is ill-roled.
-non_coercible_class cls
-  = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
-                         , genClassKey, gen1ClassKey, typeableClassKey
-                         , traversableClassKey, liftClassKey ])
-
-------------------------------------------------------------------
-
-newDerivClsInst :: DerivSpec ThetaType -> TcM ClsInst
-newDerivClsInst (DS { ds_name = dfun_name, ds_overlap = overlap_mode
-                    , ds_tvs = tvs, ds_theta = theta
-                    , ds_cls = clas, ds_tys = tys })
-  = newClsInst overlap_mode dfun_name tvs theta clas tys
-
-extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
--- Add new locally-defined instances; don't bother to check
--- for functional dependency errors -- that'll happen in GHC.Tc.TyCl.Instance
-extendLocalInstEnv dfuns thing_inside
- = do { env <- getGblEnv
-      ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
-             env'      = env { tcg_inst_env = inst_env' }
-      ; setGblEnv env' thing_inside }
-
-{-
-Note [Deriving any class]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Classic uses of a deriving clause, or a standalone-deriving declaration, are
-for:
-  * a stock class like Eq or Show, for which GHC knows how to generate
-    the instance code
-  * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving
-
-The DeriveAnyClass extension adds a third way to derive instances, based on
-empty instance declarations.
-
-The canonical use case is in combination with GHC.Generics and default method
-signatures. These allow us to have instance declarations being empty, but still
-useful, e.g.
-
-  data T a = ...blah..blah... deriving( Generic )
-  instance C a => C (T a)  -- No 'where' clause
-
-where C is some "random" user-defined class.
-
-This boilerplate code can be replaced by the more compact
-
-  data T a = ...blah..blah... deriving( Generic, C )
-
-if DeriveAnyClass is enabled.
-
-This is not restricted to Generics; any class can be derived, simply giving
-rise to an empty instance.
-
-See Note [Gathering and simplifying constraints for DeriveAnyClass] in
-GHC.Tc.Deriv.Infer for an explanation hof how the instance context is inferred for
-DeriveAnyClass.
-
-Note [Check that the type variable is truly universal]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For Functor and Traversable instances, we must check that the *last argument*
-of the type constructor is used truly universally quantified.  Example
-
-   data T a b where
-     T1 :: a -> b -> T a b      -- Fine! Vanilla H-98
-     T2 :: b -> c -> T a b      -- Fine! Existential c, but we can still map over 'b'
-     T3 :: b -> T Int b         -- Fine! Constraint 'a', but 'b' is still polymorphic
-     T4 :: Ord b => b -> T a b  -- No!  'b' is constrained
-     T5 :: b -> T b b           -- No!  'b' is constrained
-     T6 :: T a (b,b)            -- No!  'b' is constrained
-
-Notice that only the first of these constructors is vanilla H-98. We only
-need to take care about the last argument (b in this case).  See #8678.
-Eg. for T1-T3 we can write
-
-     fmap f (T1 a b) = T1 a (f b)
-     fmap f (T2 b c) = T2 (f b) c
-     fmap f (T3 x)   = T3 (f x)
-
-We need not perform these checks for Foldable instances, however, since
-functions in Foldable can only consume existentially quantified type variables,
-rather than produce them (as is the case in Functor and Traversable functions.)
-As a result, T can have a derived Foldable instance:
-
-    foldr f z (T1 a b) = f b z
-    foldr f z (T2 b c) = f b z
-    foldr f z (T3 x)   = f x z
-    foldr f z (T4 x)   = f x z
-    foldr f z (T5 x)   = f x z
-    foldr _ z T6       = z
-
-See Note [DeriveFoldable with ExistentialQuantification] in GHC.Tc.Deriv.Functor.
-
-For Functor and Traversable, we must take care not to let type synonyms
-unfairly reject a type for not being truly universally quantified. An
-example of this is:
-
-    type C (a :: Constraint) b = a
-    data T a b = C (Show a) b => MkT b
-
-Here, the existential context (C (Show a) b) does technically mention the last
-type variable b. But this is OK, because expanding the type synonym C would give
-us the context (Show a), which doesn't mention b. Therefore, we must make sure
-to expand type synonyms before performing this check. Not doing so led to #13813.
--}
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ /dev/null
@@ -1,2524 +0,0 @@
-
-{-# LANGUAGE LambdaCase          #-}
-{-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE ParallelListComp    #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
-module GHC.Tc.Errors(
-       reportUnsolved, reportAllUnsolved, warnAllUnsolved,
-       warnDefaulting,
-
-       -- * GHC API helper functions
-       solverReportMsg_ExpectedActuals,
-  ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Env (hsc_units)
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Driver.Config.Diagnostic
-
-import GHC.Rename.Unbound
-
-import GHC.Tc.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Errors.Types
-import GHC.Tc.Errors.Ppr
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.Env( tcInitTidyEnv )
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.Unify ( checkTyVarEq )
-import GHC.Tc.Types.Origin
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.EvTerm
-import GHC.Tc.Instance.Family
-import GHC.Tc.Utils.Instantiate
-import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits, getHoleFitDispConfig, pprHoleFit )
-
-import GHC.Types.Name
-import GHC.Types.Name.Reader ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual
-                             , emptyLocalRdrEnv, lookupGlobalRdrEnv , lookupLocalRdrOcc )
-import GHC.Types.Id
-import GHC.Types.Var
-import GHC.Types.Var.Set
-import GHC.Types.Var.Env
-import GHC.Types.Name.Env
-import GHC.Types.SrcLoc
-import GHC.Types.Basic
-import GHC.Types.Error
-import qualified GHC.Types.Unique.Map as UM
-
---import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )
-import GHC.Unit.Module
-import qualified GHC.LanguageExtensions as LangExt
-
-import GHC.Core.Predicate
-import GHC.Core.Type
-import GHC.Core.Coercion
-import GHC.Core.TyCo.Ppr     ( pprTyVars )
-import GHC.Core.InstEnv
-import GHC.Core.TyCon
-import GHC.Core.DataCon
-
-import GHC.Utils.Error  (diagReasonSeverity,  pprLocMsgEnvelope )
-import GHC.Utils.Misc
-import GHC.Utils.Outputable as O
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.FV ( fvVarList, unionFV )
-
-import GHC.Data.Bag
-import GHC.Data.List.SetOps ( equivClasses, nubOrdBy )
-import GHC.Data.Maybe
-import qualified GHC.Data.Strict as Strict
-
-import Control.Monad      ( unless, when, foldM, forM_ )
-import Data.Foldable      ( toList )
-import Data.Function      ( on )
-import Data.List          ( partition, sort, sortBy )
-import Data.List.NonEmpty ( NonEmpty(..) )
-import qualified Data.List.NonEmpty as NE
-import Data.Ord           ( comparing )
-import qualified Data.Semigroup as S
-
-{-
-************************************************************************
-*                                                                      *
-\section{Errors and contexts}
-*                                                                      *
-************************************************************************
-
-ToDo: for these error messages, should we note the location as coming
-from the insts, or just whatever seems to be around in the monad just
-now?
-
-Note [Deferring coercion errors to runtime]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-While developing, sometimes it is desirable to allow compilation to succeed even
-if there are type errors in the code. Consider the following case:
-
-  module Main where
-
-  a :: Int
-  a = 'a'
-
-  main = print "b"
-
-Even though `a` is ill-typed, it is not used in the end, so if all that we're
-interested in is `main` it is handy to be able to ignore the problems in `a`.
-
-Since we treat type equalities as evidence, this is relatively simple. Whenever
-we run into a type mismatch in GHC.Tc.Utils.Unify, we normally just emit an error. But it
-is always safe to defer the mismatch to the main constraint solver. If we do
-that, `a` will get transformed into
-
-  co :: Int ~ Char
-  co = ...
-
-  a :: Int
-  a = 'a' `cast` co
-
-The constraint solver would realize that `co` is an insoluble constraint, and
-emit an error with `reportUnsolved`. But we can also replace the right-hand side
-of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program
-to compile, and it will run fine unless we evaluate `a`. This is what
-`deferErrorsToRuntime` does.
-
-It does this by keeping track of which errors correspond to which coercion
-in GHC.Tc.Errors. GHC.Tc.Errors.reportTidyWanteds does not print the errors
-and does not fail if -fdefer-type-errors is on, so that we can continue
-compilation. The errors are turned into warnings in `reportUnsolved`.
--}
-
--- | Report unsolved goals as errors or warnings. We may also turn some into
--- deferred run-time errors if `-fdefer-type-errors` is on.
-reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
-reportUnsolved wanted
-  = do { binds_var <- newTcEvBinds
-       ; defer_errors <- goptM Opt_DeferTypeErrors
-       ; let type_errors | not defer_errors = ErrorWithoutFlag
-                         | otherwise        = WarningWithFlag Opt_WarnDeferredTypeErrors
-
-       ; defer_holes <- goptM Opt_DeferTypedHoles
-       ; let expr_holes | not defer_holes = ErrorWithoutFlag
-                        | otherwise       = WarningWithFlag Opt_WarnTypedHoles
-
-       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures
-       ; let type_holes | not partial_sigs
-                        = ErrorWithoutFlag
-                        | otherwise
-                        = WarningWithFlag Opt_WarnPartialTypeSignatures
-
-       ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables
-       ; let out_of_scope_holes | not defer_out_of_scope
-                                = ErrorWithoutFlag
-                                | otherwise
-                                = WarningWithFlag Opt_WarnDeferredOutOfScopeVariables
-
-       ; report_unsolved type_errors expr_holes
-                         type_holes out_of_scope_holes
-                         binds_var wanted
-
-       ; ev_binds <- getTcEvBindsMap binds_var
-       ; return (evBindMapBinds ev_binds)}
-
--- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on
--- However, do not make any evidence bindings, because we don't
--- have any convenient place to put them.
--- NB: Type-level holes are OK, because there are no bindings.
--- See Note [Deferring coercion errors to runtime]
--- Used by solveEqualities for kind equalities
---      (see Note [Failure in local type signatures] in GHC.Tc.Solver)
-reportAllUnsolved :: WantedConstraints -> TcM ()
-reportAllUnsolved wanted
-  = do { ev_binds <- newNoTcEvBinds
-
-       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures
-       ; let type_holes | not partial_sigs  = ErrorWithoutFlag
-                        | otherwise         = WarningWithFlag Opt_WarnPartialTypeSignatures
-
-       ; report_unsolved ErrorWithoutFlag
-                         ErrorWithoutFlag type_holes ErrorWithoutFlag
-                         ev_binds wanted }
-
--- | Report all unsolved goals as warnings (but without deferring any errors to
--- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in
--- "GHC.Tc.Solver"
-warnAllUnsolved :: WantedConstraints -> TcM ()
-warnAllUnsolved wanted
-  = do { ev_binds <- newTcEvBinds
-       ; report_unsolved WarningWithoutFlag
-                         WarningWithoutFlag
-                         WarningWithoutFlag
-                         WarningWithoutFlag
-                         ev_binds wanted }
-
--- | Report unsolved goals as errors or warnings.
-report_unsolved :: DiagnosticReason -- Deferred type errors
-                -> DiagnosticReason -- Expression holes
-                -> DiagnosticReason -- Type holes
-                -> DiagnosticReason -- Out of scope holes
-                -> EvBindsVar        -- cec_binds
-                -> WantedConstraints -> TcM ()
-report_unsolved type_errors expr_holes
-    type_holes out_of_scope_holes binds_var wanted
-  | isEmptyWC wanted
-  = return ()
-  | otherwise
-  = do { traceTc "reportUnsolved {" $
-         vcat [ text "type errors:" <+> ppr type_errors
-              , text "expr holes:" <+> ppr expr_holes
-              , text "type holes:" <+> ppr type_holes
-              , text "scope holes:" <+> ppr out_of_scope_holes ]
-       ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)
-
-       ; wanted <- zonkWC wanted   -- Zonk to reveal all information
-
-       ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs
-             free_tvs = filterOut isCoVar $
-                        tyCoVarsOfWCList wanted
-                        -- tyCoVarsOfWC returns free coercion *holes*, even though
-                        -- they are "bound" by other wanted constraints. They in
-                        -- turn may mention variables bound further in, which makes
-                        -- no sense. Really we should not return those holes at all;
-                        -- for now we just filter them out.
-
-       ; traceTc "reportUnsolved (after zonking):" $
-         vcat [ text "Free tyvars:" <+> pprTyVars free_tvs
-              , text "Tidy env:" <+> ppr tidy_env
-              , text "Wanted:" <+> ppr wanted ]
-
-       ; warn_redundant <- woptM Opt_WarnRedundantConstraints
-       ; exp_syns <- goptM Opt_PrintExpandedSynonyms
-       ; let err_ctxt = CEC { cec_encl  = []
-                            , cec_tidy  = tidy_env
-                            , cec_defer_type_errors = type_errors
-                            , cec_expr_holes = expr_holes
-                            , cec_type_holes = type_holes
-                            , cec_out_of_scope_holes = out_of_scope_holes
-                            , cec_suppress = insolubleWC wanted
-                                 -- See Note [Suppressing error messages]
-                                 -- Suppress low-priority errors if there
-                                 -- are insoluble errors anywhere;
-                                 -- See #15539 and c.f. setting ic_status
-                                 -- in GHC.Tc.Solver.setImplicationStatus
-                            , cec_warn_redundant = warn_redundant
-                            , cec_expand_syns = exp_syns
-                            , cec_binds    = binds_var }
-
-       ; tc_lvl <- getTcLevel
-       ; reportWanteds err_ctxt tc_lvl wanted
-       ; traceTc "reportUnsolved }" empty }
-
---------------------------------------------
---      Internal functions
---------------------------------------------
-
--- | Make a report from a single 'TcSolverReportMsg'.
-important :: SolverReportErrCtxt -> TcSolverReportMsg -> SolverReport
-important ctxt doc
-  = SolverReport { sr_important_msg = SolverReportWithCtxt ctxt doc
-                 , sr_supplementary = []
-                 , sr_hints         = [] }
-
-add_relevant_bindings :: RelevantBindings -> SolverReport -> SolverReport
-add_relevant_bindings binds report@(SolverReport { sr_supplementary = supp })
-  = report { sr_supplementary = SupplementaryBindings binds : supp }
-
-add_report_hints :: [GhcHint] -> SolverReport -> SolverReport
-add_report_hints hints report@(SolverReport { sr_hints = prev_hints })
-  = report { sr_hints = prev_hints ++ hints }
-
--- | Returns True <=> the SolverReportErrCtxt indicates that something is deferred
-deferringAnyBindings :: SolverReportErrCtxt -> Bool
-  -- Don't check cec_type_holes, as these don't cause bindings to be deferred
-deferringAnyBindings (CEC { cec_defer_type_errors  = ErrorWithoutFlag
-                          , cec_expr_holes         = ErrorWithoutFlag
-                          , cec_out_of_scope_holes = ErrorWithoutFlag }) = False
-deferringAnyBindings _                                                   = True
-
-maybeSwitchOffDefer :: EvBindsVar -> SolverReportErrCtxt -> SolverReportErrCtxt
--- Switch off defer-type-errors inside CoEvBindsVar
--- See Note [Failing equalities with no evidence bindings]
-maybeSwitchOffDefer evb ctxt
- | CoEvBindsVar{} <- evb
- = ctxt { cec_defer_type_errors  = ErrorWithoutFlag
-        , cec_expr_holes         = ErrorWithoutFlag
-        , cec_out_of_scope_holes = ErrorWithoutFlag }
- | otherwise
- = ctxt
-
-{- Note [Failing equalities with no evidence bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we go inside an implication that has no term evidence
-(e.g. unifying under a forall), we can't defer type errors.  You could
-imagine using the /enclosing/ bindings (in cec_binds), but that may
-not have enough stuff in scope for the bindings to be well typed.  So
-we just switch off deferred type errors altogether.  See #14605.
-
-This is done by maybeSwitchOffDefer.  It's also useful in one other
-place: see Note [Wrapping failing kind equalities] in GHC.Tc.Solver.
-
-Note [Suppressing error messages]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The cec_suppress flag says "don't report any errors".  Instead, just create
-evidence bindings (as usual).  It's used when more important errors have occurred.
-
-Specifically (see reportWanteds)
-  * If there are insoluble Givens, then we are in unreachable code and all bets
-    are off.  So don't report any further errors.
-  * If there are any insolubles (eg Int~Bool), here or in a nested implication,
-    then suppress errors from the simple constraints here.  Sometimes the
-    simple-constraint errors are a knock-on effect of the insolubles.
-
-This suppression behaviour is controlled by the Bool flag in
-ReportErrorSpec, as used in reportWanteds.
-
-But we need to take care: flags can turn errors into warnings, and we
-don't want those warnings to suppress subsequent errors (including
-suppressing the essential addTcEvBind for them: #15152). So in
-tryReporter we use askNoErrs to see if any error messages were
-/actually/ produced; if not, we don't switch on suppression.
-
-A consequence is that warnings never suppress warnings, so turning an
-error into a warning may allow subsequent warnings to appear that were
-previously suppressed.   (e.g. partial-sigs/should_fail/T14584)
--}
-
-reportImplic :: SolverReportErrCtxt -> Implication -> TcM ()
-reportImplic ctxt implic@(Implic { ic_skols  = tvs
-                                 , ic_given  = given
-                                 , ic_wanted = wanted, ic_binds = evb
-                                 , ic_status = status, ic_info = info
-                                 , ic_env    = tcl_env
-                                 , ic_tclvl  = tc_lvl })
-  | BracketSkol <- info
-  , not insoluble
-  = return ()        -- For Template Haskell brackets report only
-                     -- definite errors. The whole thing will be re-checked
-                     -- later when we plug it in, and meanwhile there may
-                     -- certainly be un-satisfied constraints
-
-  | otherwise
-  = do { traceTc "reportImplic" $ vcat
-           [ text "tidy env:"   <+> ppr (cec_tidy ctxt)
-           , text "skols:     " <+> pprTyVars tvs
-           , text "tidy skols:" <+> pprTyVars tvs' ]
-
-       ; when bad_telescope $ reportBadTelescope ctxt tcl_env info tvs
-               -- Do /not/ use the tidied tvs because then are in the
-               -- wrong order, so tidying will rename things wrongly
-       ; reportWanteds ctxt' tc_lvl wanted
-       ; when (cec_warn_redundant ctxt) $
-         warnRedundantConstraints ctxt' tcl_env info' dead_givens }
-  where
-    insoluble    = isInsolubleStatus status
-    (env1, tvs') = tidyVarBndrs (cec_tidy ctxt) $
-                   scopedSort tvs
-        -- scopedSort: the ic_skols may not be in dependency order
-        -- (see Note [Skolems in an implication] in GHC.Tc.Types.Constraint)
-        -- but tidying goes wrong on out-of-order constraints;
-        -- so we sort them here before tidying
-    info'   = tidySkolemInfoAnon env1 info
-    implic' = implic { ic_skols = tvs'
-                     , ic_given = map (tidyEvVar env1) given
-                     , ic_info  = info' }
-
-    ctxt1 = maybeSwitchOffDefer evb ctxt
-    ctxt' = ctxt1 { cec_tidy     = env1
-                  , cec_encl     = implic' : cec_encl ctxt
-
-                  , cec_suppress = insoluble || cec_suppress ctxt
-                        -- Suppress inessential errors if there
-                        -- are insolubles anywhere in the
-                        -- tree rooted here, or we've come across
-                        -- a suppress-worthy constraint higher up (#11541)
-
-                  , cec_binds    = evb }
-
-    dead_givens = case status of
-                    IC_Solved { ics_dead = dead } -> dead
-                    _                             -> []
-
-    bad_telescope = case status of
-              IC_BadTelescope -> True
-              _               -> False
-
-warnRedundantConstraints :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [EvVar] -> TcM ()
--- See Note [Tracking redundant constraints] in GHC.Tc.Solver
-warnRedundantConstraints ctxt env info ev_vars
- | null redundant_evs
- = return ()
-
- | SigSkol user_ctxt _ _ <- info
- -- When dealing with a user-written type signature,
- -- we want to add "In the type signature for f".
- = restoreLclEnv env $
-   setSrcSpan (redundantConstraintsSpan user_ctxt) $
-   report_redundant_msg True
-                  --  ^^^^ add "In the type signature..."
-
- | otherwise
- -- But for InstSkol there already *is* a surrounding
- -- "In the instance declaration for Eq [a]" context
- -- and we don't want to say it twice. Seems a bit ad-hoc
- = restoreLclEnv env
- $ report_redundant_msg False
-                 --   ^^^^^ don't add "In the type signature..."
- where
-   report_redundant_msg :: Bool -- whether to add "In the type signature..." to the diagnostic
-                        -> TcRn ()
-   report_redundant_msg show_info
-     = do { lcl_env <- getLclEnv
-          ; msg <-
-              mkErrorReport
-                lcl_env
-                (TcRnRedundantConstraints redundant_evs (info, show_info))
-                (Just ctxt)
-                []
-          ; reportDiagnostic msg }
-
-   redundant_evs =
-       filterOut is_type_error $
-       case info of -- See Note [Redundant constraints in instance decls]
-         InstSkol -> filterOut (improving . idType) ev_vars
-         _        -> ev_vars
-
-   -- See #15232
-   is_type_error = isJust . userTypeError_maybe . idType
-
-   improving pred -- (transSuperClasses p) does not include p
-     = any isImprovementPred (pred : transSuperClasses pred)
-
-reportBadTelescope :: SolverReportErrCtxt -> TcLclEnv -> SkolemInfoAnon -> [TcTyVar] -> TcM ()
-reportBadTelescope ctxt env (ForAllSkol telescope) skols
-  = do { msg <- mkErrorReport
-                  env
-                  (TcRnSolverReport report ErrorWithoutFlag noHints)
-                  (Just ctxt)
-                  []
-       ; reportDiagnostic msg }
-  where
-    report = SolverReportWithCtxt ctxt $ BadTelescope telescope skols
-
-reportBadTelescope _ _ skol_info skols
-  = pprPanic "reportBadTelescope" (ppr skol_info $$ ppr skols)
-
-{- Note [Redundant constraints in instance decls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For instance declarations, we don't report unused givens if
-they can give rise to improvement.  Example (#10100):
-    class Add a b ab | a b -> ab, a ab -> b
-    instance Add Zero b b
-    instance Add a b ab => Add (Succ a) b (Succ ab)
-The context (Add a b ab) for the instance is clearly unused in terms
-of evidence, since the dictionary has no fields.  But it is still
-needed!  With the context, a wanted constraint
-   Add (Succ Zero) beta (Succ Zero)
-we will reduce to (Add Zero beta Zero), and thence we get beta := Zero.
-But without the context we won't find beta := Zero.
-
-This only matters in instance declarations..
--}
-
--- | Should we completely ignore this constraint in error reporting?
--- It *must* be the case that any constraint for which this returns True
--- somehow causes an error to be reported elsewhere.
--- See Note [Constraints to ignore].
-ignoreConstraint :: Ct -> Bool
-ignoreConstraint ct
-  | AssocFamPatOrigin <- ctOrigin ct
-  = True
-  | otherwise
-  = False
-
--- | Makes an error item from a constraint, calculating whether or not
--- the item should be suppressed. See Note [Wanteds rewrite Wanteds]
--- in GHC.Tc.Types.Constraint. Returns Nothing if we should just ignore
--- a constraint. See Note [Constraints to ignore].
-mkErrorItem :: Ct -> TcM (Maybe ErrorItem)
-mkErrorItem ct
-  | ignoreConstraint ct
-  = do { traceTc "Ignoring constraint:" (ppr ct)
-       ; return Nothing }   -- See Note [Constraints to ignore]
-
-  | otherwise
-  = do { let loc = ctLoc ct
-             flav = ctFlavour ct
-
-       ; (suppress, m_evdest) <- case ctEvidence ct of
-           CtGiven {} -> return (False, Nothing)
-           CtWanted { ctev_rewriters = rewriters, ctev_dest = dest }
-             -> do { supp <- anyUnfilledCoercionHoles rewriters
-                   ; return (supp, Just dest) }
-
-       ; let m_reason = case ct of CIrredCan { cc_reason = reason } -> Just reason
-                                   _                                -> Nothing
-
-       ; return $ Just $ EI { ei_pred     = ctPred ct
-                            , ei_evdest   = m_evdest
-                            , ei_flavour  = flav
-                            , ei_loc      = loc
-                            , ei_m_reason = m_reason
-                            , ei_suppress = suppress }}
-
-----------------------------------------------------------------
-reportWanteds :: SolverReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
-reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics
-                                 , wc_errors = errs })
-  | isEmptyWC wc = traceTc "reportWanteds empty WC" empty
-  | otherwise
-  = do { tidy_items <- mapMaybeM mkErrorItem tidy_cts
-       ; traceTc "reportWanteds 1" (vcat [ text "Simples =" <+> ppr simples
-                                         , text "Suppress =" <+> ppr (cec_suppress ctxt)
-                                         , text "tidy_cts   =" <+> ppr tidy_cts
-                                         , text "tidy_items =" <+> ppr tidy_items
-                                         , text "tidy_errs =" <+> ppr tidy_errs ])
-
-       -- This check makes sure that we aren't suppressing the only error that will
-       -- actually stop compilation
-       ; assertPprM
-           ( do { errs_already <- ifErrsM (return True) (return False)
-                ; return $
-                    errs_already ||                  -- we already reported an error (perhaps from an outer implication)
-                    null simples ||                  -- no errors to report here
-                    any ignoreConstraint simples ||  -- one error is ignorable (is reported elsewhere)
-                    not (all ei_suppress tidy_items) -- not all errors are suppressed
-                } )
-           (vcat [text "reportWanteds is suppressing all errors"])
-
-         -- First, deal with any out-of-scope errors:
-       ; let (out_of_scope, other_holes, not_conc_errs) = partition_errors tidy_errs
-               -- don't suppress out-of-scope errors
-             ctxt_for_scope_errs = ctxt { cec_suppress = False }
-       ; (_, no_out_of_scope) <- askNoErrs $
-                                 reportHoles tidy_items ctxt_for_scope_errs out_of_scope
-
-         -- Next, deal with things that are utterly wrong
-         -- Like Int ~ Bool (incl nullary TyCons)
-         -- or  Int ~ t a   (AppTy on one side)
-         -- These /ones/ are not suppressed by the incoming context
-         -- (but will be by out-of-scope errors)
-       ; let ctxt_for_insols = ctxt { cec_suppress = not no_out_of_scope }
-       ; reportHoles tidy_items ctxt_for_insols other_holes
-          -- holes never suppress
-
-       ; reportNotConcreteErrs ctxt_for_insols not_conc_errs
-
-          -- See Note [Suppressing confusing errors]
-       ; let (suppressed_items, items0) = partition suppress tidy_items
-       ; traceTc "reportWanteds suppressed:" (ppr suppressed_items)
-       ; (ctxt1, items1) <- tryReporters ctxt_for_insols report1 items0
-
-         -- Now all the other constraints.  We suppress errors here if
-         -- any of the first batch failed, or if the enclosing context
-         -- says to suppress
-       ; let ctxt2 = ctxt1 { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }
-       ; (ctxt3, leftovers) <- tryReporters ctxt2 report2 items1
-       ; massertPpr (null leftovers)
-           (text "The following unsolved Wanted constraints \
-                 \have not been reported to the user:"
-           $$ ppr leftovers)
-
-       ; mapBagM_ (reportImplic ctxt2) implics
-            -- NB ctxt2: don't suppress inner insolubles if there's only a
-            -- wanted insoluble here; but do suppress inner insolubles
-            -- if there's a *given* insoluble here (= inaccessible code)
-
-            -- Only now, if there are no errors, do we report suppressed ones
-            -- See Note [Suppressing confusing errors]
-            -- We don't need to update the context further because of the
-            -- whenNoErrs guard
-       ; whenNoErrs $
-         do { (_, more_leftovers) <- tryReporters ctxt3 report3 suppressed_items
-            ; massertPpr (null more_leftovers) (ppr more_leftovers) } }
- where
-    env       = cec_tidy ctxt
-    tidy_cts  = bagToList (mapBag (tidyCt env)   simples)
-    tidy_errs = bagToList (mapBag (tidyDelayedError env) errs)
-
-    partition_errors :: [DelayedError] -> ([Hole], [Hole], [NotConcreteError])
-    partition_errors = go [] [] []
-      where
-        go out_of_scope other_holes syn_eqs []
-          = (out_of_scope, other_holes, syn_eqs)
-        go es1 es2 es3 (err:errs)
-          | (es1, es2, es3) <- go es1 es2 es3 errs
-          = case err of
-              DE_Hole hole
-                | isOutOfScopeHole hole
-                -> (hole : es1, es2, es3)
-                | otherwise
-                -> (es1, hole : es2, es3)
-              DE_NotConcrete err
-                -> (es1, es2, err : es3)
-
-      -- See Note [Suppressing confusing errors]
-    suppress :: ErrorItem -> Bool
-    suppress item
-      | Wanted <- ei_flavour item
-      = is_ww_fundep_item item
-      | otherwise
-      = False
-
-    -- report1: ones that should *not* be suppressed by
-    --          an insoluble somewhere else in the tree
-    -- It's crucial that anything that is considered insoluble
-    -- (see GHC.Tc.Utils.insolublWantedCt) is caught here, otherwise
-    -- we might suppress its error message, and proceed on past
-    -- type checking to get a Lint error later
-    report1 = [ ("custom_error", is_user_type_error, True,  mkUserTypeErrorReporter)
-
-              , given_eq_spec
-              , ("insoluble2",      utterly_wrong,  True, mkGroupReporter mkEqErr)
-              , ("skolem eq1",      very_wrong,     True, mkSkolReporter)
-              , ("FixedRuntimeRep", is_FRR,         True, mkGroupReporter mkFRRErr)
-              , ("skolem eq2",      skolem_eq,      True, mkSkolReporter)
-              , ("non-tv eq",       non_tv_eq,      True, mkSkolReporter)
-
-                  -- The only remaining equalities are alpha ~ ty,
-                  -- where alpha is untouchable; and representational equalities
-                  -- Prefer homogeneous equalities over hetero, because the
-                  -- former might be holding up the latter.
-                  -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical
-              , ("Homo eqs",      is_homo_equality,  True,  mkGroupReporter mkEqErr)
-              , ("Other eqs",     is_equality,       True,  mkGroupReporter mkEqErr)
-              ]
-
-    -- report2: we suppress these if there are insolubles elsewhere in the tree
-    report2 = [ ("Implicit params", is_ip,           False, mkGroupReporter mkIPErr)
-              , ("Irreds",          is_irred,        False, mkGroupReporter mkIrredErr)
-              , ("Dicts",           is_dict,         False, mkGroupReporter mkDictErr) ]
-
-    -- report3: suppressed errors should be reported as categorized by either report1
-    -- or report2. Keep this in sync with the suppress function above
-    report3 = [ ("wanted/wanted fundeps", is_ww_fundep, True, mkGroupReporter mkEqErr)
-              ]
-
-    -- rigid_nom_eq, rigid_nom_tv_eq,
-    is_dict, is_equality, is_ip, is_FRR, is_irred :: ErrorItem -> Pred -> Bool
-
-    is_given_eq item pred
-       | Given <- ei_flavour item
-       , EqPred {} <- pred = True
-       | otherwise         = False
-       -- I think all given residuals are equalities
-
-    -- Things like (Int ~N Bool)
-    utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2
-    utterly_wrong _ _                      = False
-
-    -- Things like (a ~N Int)
-    very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2
-    very_wrong _ _                      = False
-
-    -- Representation-polymorphism errors, to be reported using mkFRRErr.
-    is_FRR item _ = isJust $ fixedRuntimeRepOrigin_maybe item
-
-    -- Things like (a ~N b) or (a  ~N  F Bool)
-    skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1
-    skolem_eq _ _                    = False
-
-    -- Things like (F a  ~N  Int)
-    non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1)
-    non_tv_eq _ _                    = False
-
-    is_user_type_error item _ = isUserTypeError (errorItemPred item)
-
-    is_homo_equality _ (EqPred _ ty1 ty2)
-      = typeKind ty1 `tcEqType` typeKind ty2
-    is_homo_equality _ _
-      = False
-
-    is_equality _(EqPred {}) = True
-    is_equality _ _          = False
-
-    is_dict _ (ClassPred {}) = True
-    is_dict _ _              = False
-
-    is_ip _ (ClassPred cls _) = isIPClass cls
-    is_ip _ _                 = False
-
-    is_irred _ (IrredPred {}) = True
-    is_irred _ _              = False
-
-     -- See situation (1) of Note [Suppressing confusing errors]
-    is_ww_fundep item _ = is_ww_fundep_item item
-    is_ww_fundep_item = isWantedWantedFunDepOrigin . errorItemOrigin
-
-    given_eq_spec  -- See Note [Given errors]
-      | has_gadt_match_here
-      = ("insoluble1a", is_given_eq, True,  mkGivenErrorReporter)
-      | otherwise
-      = ("insoluble1b", is_given_eq, False, ignoreErrorReporter)
-          -- False means don't suppress subsequent errors
-          -- Reason: we don't report all given errors
-          --         (see mkGivenErrorReporter), and we should only suppress
-          --         subsequent errors if we actually report this one!
-          --         #13446 is an example
-
-    -- See Note [Given errors]
-    has_gadt_match_here = has_gadt_match (cec_encl ctxt)
-    has_gadt_match [] = False
-    has_gadt_match (implic : implics)
-      | PatSkol {} <- ic_info implic
-      , ic_given_eqs implic /= NoGivenEqs
-      , ic_warn_inaccessible implic
-          -- Don't bother doing this if -Winaccessible-code isn't enabled.
-          -- See Note [Avoid -Winaccessible-code when deriving] in GHC.Tc.TyCl.Instance.
-      = True
-      | otherwise
-      = has_gadt_match implics
-
----------------
-isSkolemTy :: TcLevel -> Type -> Bool
--- The type is a skolem tyvar
-isSkolemTy tc_lvl ty
-  | Just tv <- getTyVar_maybe ty
-  =  isSkolemTyVar tv
-  || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv)
-     -- The last case is for touchable TyVarTvs
-     -- we postpone untouchables to a latter test (too obscure)
-
-  | otherwise
-  = False
-
-isTyFun_maybe :: Type -> Maybe TyCon
-isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
-                      Just (tc,_) | isTypeFamilyTyCon tc -> Just tc
-                      _ -> Nothing
-
-{- Note [Suppressing confusing errors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Certain errors we might encounter are potentially confusing to users.
-If there are any other errors to report, at all, we want to suppress these.
-
-Which errors (only 1 case right now):
-
-1) Errors which arise from the interaction of two Wanted fun-dep constraints.
-   Example:
-
-     class C a b | a -> b where
-       op :: a -> b -> b
-
-     foo _ = op True Nothing
-
-     bar _ = op False []
-
-   Here, we could infer
-     foo :: C Bool (Maybe a) => p -> Maybe a
-     bar :: C Bool [a]       => p -> [a]
-
-   (The unused arguments suppress the monomorphism restriction.) The problem
-   is that these types can't both be correct, as they violate the functional
-   dependency. Yet reporting an error here is awkward: we must
-   non-deterministically choose either foo or bar to reject. We thus want
-   to report this problem only when there is nothing else to report.
-   See typecheck/should_fail/T13506 for an example of when to suppress
-   the error. The case above is actually accepted, because foo and bar
-   are checked separately, and thus the two fundep constraints never
-   encounter each other. It is test case typecheck/should_compile/FunDepOrigin1.
-
-   This case applies only when both fundeps are *Wanted* fundeps; when
-   both are givens, the error represents unreachable code. For
-   a Given/Wanted case, see #9612.
-
-Mechanism:
-
-We use the `suppress` function within reportWanteds to filter out these two
-cases, then report all other errors. Lastly, we return to these suppressed
-ones and report them only if there have been no errors so far.
-
-Note [Constraints to ignore]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Some constraints are meant only to aid the solver by unification; a failure
-to solve them is not necessarily an error to report to the user. It is critical
-that compilation is aborted elsewhere if there are any ignored constraints here;
-they will remain unfilled, and might have been used to rewrite another constraint.
-
-Currently, the constraints to ignore are:
-
-1) Constraints generated in order to unify associated type instance parameters
-   with class parameters. Here are two illustrative examples:
-
-     class C (a :: k) where
-       type F (b :: k)
-
-     instance C True where
-       type F a = Int
-
-     instance C Left where
-       type F (Left :: a -> Either a b) = Bool
-
-   In the first instance, we want to infer that `a` has type Bool. So we emit
-   a constraint unifying kappa (the guessed type of `a`) with Bool. All is well.
-
-   In the second instance, we process the associated type instance only
-   after fixing the quantified type variables of the class instance. We thus
-   have skolems a1 and b1 such that the class instance is for (Left :: a1 -> Either a1 b1).
-   Unifying a1 and b1 with a and b in the type instance will fail, but harmlessly so.
-   checkConsistentFamInst checks for this, and will fail if anything has gone
-   awry. Really the equality constraints emitted are just meant as an aid, not
-   a requirement. This is test case T13972.
-
-   We detect this case by looking for an origin of AssocFamPatOrigin; constraints
-   with this origin are dropped entirely during error message reporting.
-
-   If there is any trouble, checkValidFamInst bleats, aborting compilation.
-
--}
-
-
-
---------------------------------------------
---      Reporters
---------------------------------------------
-
-type Reporter
-  = SolverReportErrCtxt -> [ErrorItem] -> TcM ()
-type ReporterSpec
-  = ( String                      -- Name
-    , ErrorItem -> Pred -> Bool  -- Pick these ones
-    , Bool                        -- True <=> suppress subsequent reporters
-    , Reporter)                   -- The reporter itself
-
-mkSkolReporter :: Reporter
--- Suppress duplicates with either the same LHS, or same location
--- Pre-condition: all items are equalities
-mkSkolReporter ctxt items
-  = mapM_ (reportGroup mkEqErr ctxt) (group items)
-  where
-     group [] = []
-     group (item:items) = (item : yeses) : group noes
-        where
-          (yeses, noes) = partition (group_with item) items
-
-     group_with item1 item2
-       | EQ <- cmp_loc item1 item2 = True
-       | eq_lhs_type   item1 item2 = True
-       | otherwise                 = False
-
-reportHoles :: [ErrorItem]  -- other (tidied) constraints
-            -> SolverReportErrCtxt -> [Hole] -> TcM ()
-reportHoles tidy_items ctxt holes
-  = do
-      diag_opts <- initDiagOpts <$> getDynFlags
-      let severity = diagReasonSeverity diag_opts (cec_type_holes ctxt)
-          holes'   = filter (keepThisHole severity) holes
-      -- Zonk and tidy all the TcLclEnvs before calling `mkHoleError`
-      -- because otherwise types will be zonked and tidied many times over.
-      (tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes')
-      let ctxt' = ctxt { cec_tidy = tidy_env' }
-      forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_items ctxt' hole
-                                 ; reportDiagnostic msg }
-
-keepThisHole :: Severity -> Hole -> Bool
--- See Note [Skip type holes rapidly]
-keepThisHole sev hole
-  = case hole_sort hole of
-       ExprHole {}    -> True
-       TypeHole       -> keep_type_hole
-       ConstraintHole -> keep_type_hole
-  where
-    keep_type_hole = case sev of
-                         SevIgnore -> False
-                         _         -> True
-
--- | zonkTidyTcLclEnvs takes a bunch of 'TcLclEnv's, each from a Hole.
--- It returns a ('Name' :-> 'Type') mapping which gives the zonked, tidied
--- type for each Id in any of the binder stacks in the  'TcLclEnv's.
--- Since there is a huge overlap between these stacks, is is much,
--- much faster to do them all at once, avoiding duplication.
-zonkTidyTcLclEnvs :: TidyEnv -> [TcLclEnv] -> TcM (TidyEnv, NameEnv Type)
-zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap tcl_bndrs lcls)
-  where
-    go envs tc_bndr = case tc_bndr of
-          TcTvBndr {} -> return envs
-          TcIdBndr id _top_lvl -> go_one (idName id) (idType id) envs
-          TcIdBndr_ExpType name et _top_lvl ->
-            do { mb_ty <- readExpType_maybe et
-                   -- et really should be filled in by now. But there's a chance
-                   -- it hasn't, if, say, we're reporting a kind error en route to
-                   -- checking a term. See test indexed-types/should_fail/T8129
-                   -- Or we are reporting errors from the ambiguity check on
-                   -- a local type signature
-               ; case mb_ty of
-                   Just ty -> go_one name ty envs
-                   Nothing -> return envs
-               }
-    go_one name ty (tidy_env, name_env) = do
-            if name `elemNameEnv` name_env
-              then return (tidy_env, name_env)
-              else do
-                (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty
-                return (tidy_env',  extendNameEnv name_env name tidy_ty)
-
-reportNotConcreteErrs :: SolverReportErrCtxt -> [NotConcreteError] -> TcM ()
-reportNotConcreteErrs _ [] = return ()
-reportNotConcreteErrs ctxt errs@(err0:_)
-  = do { msg <- mkErrorReport (ctLocEnv (nce_loc err0)) diag (Just ctxt) []
-       ; reportDiagnostic msg }
-
-  where
-
-    frr_origins = acc_errors errs
-    diag = TcRnSolverReport
-             (SolverReportWithCtxt ctxt (FixedRuntimeRepError frr_origins))
-             ErrorWithoutFlag noHints
-
-    -- Accumulate the different kind of errors arising from syntactic equality.
-    -- (Only SynEq_FRR origin for the moment.)
-    acc_errors = go []
-      where
-        go frr_errs [] = frr_errs
-        go frr_errs (err:errs)
-          | frr_errs <- go frr_errs errs
-          = case err of
-              NCE_FRR
-                { nce_frr_origin = frr_orig
-                , nce_reasons = _not_conc } ->
-                FRR_Info
-                  { frr_info_origin       = frr_orig
-                  , frr_info_not_concrete = Nothing }
-                : frr_errs
-
-{- Note [Skip type holes rapidly]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have module with a /lot/ of partial type signatures, and we
-compile it while suppressing partial-type-signature warnings.  Then
-we don't want to spend ages constructing error messages and lists of
-relevant bindings that we never display! This happened in #14766, in
-which partial type signatures in a Happy-generated parser cause a huge
-increase in compile time.
-
-The function ignoreThisHole short-circuits the error/warning generation
-machinery, in cases where it is definitely going to be a no-op.
--}
-
-mkUserTypeErrorReporter :: Reporter
-mkUserTypeErrorReporter ctxt
-  = mapM_ $ \item -> do { let err = important ctxt $ mkUserTypeError item
-                        ; maybeReportError ctxt [item] err
-                        ; addDeferredBinding ctxt err item }
-
-mkUserTypeError :: ErrorItem -> TcSolverReportMsg
-mkUserTypeError item =
-  case getUserTypeErrorMsg (errorItemPred item) of
-    Just msg -> UserTypeError msg
-    Nothing  -> pprPanic "mkUserTypeError" (ppr item)
-
-mkGivenErrorReporter :: Reporter
--- See Note [Given errors]
-mkGivenErrorReporter ctxt items
-  = do { (ctxt, relevant_binds, item) <- relevantBindings True ctxt item
-       ; let (implic:_) = cec_encl ctxt
-                 -- Always non-empty when mkGivenErrorReporter is called
-             loc'  = setCtLocEnv (ei_loc item) (ic_env implic)
-             item' = item { ei_loc = loc' }
-                   -- For given constraints we overwrite the env (and hence src-loc)
-                   -- with one from the immediately-enclosing implication.
-                   -- See Note [Inaccessible code]
-
-       ; (eq_err_msg, _hints) <- mkEqErr_help ctxt item' ty1 ty2
-       -- The hints wouldn't help in this situation, so we discard them.
-       ; let supplementary = [ SupplementaryBindings relevant_binds ]
-             msg = TcRnInaccessibleCode implic (SolverReportWithCtxt ctxt eq_err_msg)
-       ; msg <- mkErrorReport (ctLocEnv loc') msg (Just ctxt) supplementary
-       ; reportDiagnostic msg }
-  where
-    (item : _ )  = items    -- Never empty
-    (ty1, ty2)   = getEqPredTys (errorItemPred item)
-
-ignoreErrorReporter :: Reporter
--- Discard Given errors that don't come from
--- a pattern match; maybe we should warn instead?
-ignoreErrorReporter ctxt items
-  = do { traceTc "mkGivenErrorReporter no" (ppr items $$ ppr (cec_encl ctxt))
-       ; return () }
-
-
-{- Note [Given errors]
-~~~~~~~~~~~~~~~~~~~~~~
-Given constraints represent things for which we have (or will have)
-evidence, so they aren't errors.  But if a Given constraint is
-insoluble, this code is inaccessible, and we might want to at least
-warn about that.  A classic case is
-
-   data T a where
-     T1 :: T Int
-     T2 :: T a
-     T3 :: T Bool
-
-   f :: T Int -> Bool
-   f T1 = ...
-   f T2 = ...
-   f T3 = ...  -- We want to report this case as inaccessible
-
-We'd like to point out that the T3 match is inaccessible. It
-will have a Given constraint [G] Int ~ Bool.
-
-But we don't want to report ALL insoluble Given constraints.  See Trac
-#12466 for a long discussion.  For example, if we aren't careful
-we'll complain about
-   f :: ((Int ~ Bool) => a -> a) -> Int
-which arguably is OK.  It's more debatable for
-   g :: (Int ~ Bool) => Int -> Int
-but it's tricky to distinguish these cases so we don't report
-either.
-
-The bottom line is this: has_gadt_match looks for an enclosing
-pattern match which binds some equality constraints.  If we
-find one, we report the insoluble Given.
--}
-
-mkGroupReporter :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport)
-                             -- Make error message for a group
-                -> Reporter  -- Deal with lots of constraints
--- Group together errors from same location,
--- and report only the first (to avoid a cascade)
-mkGroupReporter mk_err ctxt items
-  = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc items)
-
-eq_lhs_type :: ErrorItem -> ErrorItem -> Bool
-eq_lhs_type item1 item2
-  = case (classifyPredType (errorItemPred item1), classifyPredType (errorItemPred item2)) of
-       (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->
-         (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2)
-       _ -> pprPanic "mkSkolReporter" (ppr item1 $$ ppr item2)
-
-cmp_loc :: ErrorItem -> ErrorItem -> Ordering
-cmp_loc item1 item2 = get item1 `compare` get item2
-  where
-    get ei = realSrcSpanStart (ctLocSpan (errorItemCtLoc ei))
-             -- Reduce duplication by reporting only one error from each
-             -- /starting/ location even if the end location differs
-
-reportGroup :: (SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport) -> Reporter
-reportGroup mk_err ctxt items
-  = do { err <- mk_err ctxt items
-       ; traceTc "About to maybeReportErr" $
-         vcat [ text "Constraint:"             <+> ppr items
-              , text "cec_suppress ="          <+> ppr (cec_suppress ctxt)
-              , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]
-       ; maybeReportError ctxt items err
-           -- But see Note [Always warn with -fdefer-type-errors]
-       ; traceTc "reportGroup" (ppr items)
-       ; mapM_ (addDeferredBinding ctxt err) items }
-           -- Add deferred bindings for all
-           -- Redundant if we are going to abort compilation,
-           -- but that's hard to know for sure, and if we don't
-           -- abort, we need bindings for all (e.g. #12156)
-
--- See Note [No deferring for multiplicity errors]
-nonDeferrableOrigin :: CtOrigin -> Bool
-nonDeferrableOrigin NonLinearPatternOrigin  = True
-nonDeferrableOrigin (UsageEnvironmentOf {}) = True
-nonDeferrableOrigin (FRROrigin {})          = True
-nonDeferrableOrigin _                       = False
-
-maybeReportError :: SolverReportErrCtxt
-                 -> [ErrorItem]     -- items covered by the Report
-                 -> SolverReport -> TcM ()
-maybeReportError ctxt items@(item1:_) (SolverReport { sr_important_msg = important
-                                                    , sr_supplementary = supp
-                                                    , sr_hints = hints })
-  = unless (cec_suppress ctxt  -- Some worse error has occurred, so suppress this diagnostic
-         || all ei_suppress items) $
-                           -- if they're all to be suppressed, report nothing
-                           -- if at least one is not suppressed, do report:
-                           -- the function that generates the error message
-                           -- should look for an unsuppressed error item
-    do let reason | any (nonDeferrableOrigin . errorItemOrigin) items = ErrorWithoutFlag
-                  | otherwise                                         = cec_defer_type_errors ctxt
-                  -- See Note [No deferring for multiplicity errors]
-           diag = TcRnSolverReport important reason hints
-       msg <- mkErrorReport (ctLocEnv (errorItemCtLoc item1)) diag (Just ctxt) supp
-       reportDiagnostic msg
-maybeReportError _ _ _ = panic "maybeReportError"
-
-addDeferredBinding :: SolverReportErrCtxt -> SolverReport -> ErrorItem -> TcM ()
--- See Note [Deferring coercion errors to runtime]
-addDeferredBinding ctxt err (EI { ei_evdest = Just dest, ei_pred = item_ty
-                                , ei_loc = loc })
-     -- if evdest is Just, then the constraint was from a wanted
-  | deferringAnyBindings ctxt
-  = do { err_tm <- mkErrorTerm ctxt loc item_ty err
-       ; let ev_binds_var = cec_binds ctxt
-
-       ; case dest of
-           EvVarDest evar
-             -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm
-           HoleDest hole
-             -> do { -- See Note [Deferred errors for coercion holes]
-                     let co_var = coHoleCoVar hole
-                   ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm
-                   ; fillCoercionHole hole (mkCoVarCo co_var) } }
-addDeferredBinding _ _ _ = return ()    -- Do not set any evidence for Given
-
-mkErrorTerm :: SolverReportErrCtxt -> CtLoc -> Type  -- of the error term
-            -> SolverReport -> TcM EvTerm
-mkErrorTerm ctxt ct_loc ty (SolverReport { sr_important_msg = important, sr_supplementary = supp })
-  = do { msg <- mkErrorReport
-                  (ctLocEnv ct_loc)
-                  (TcRnSolverReport important ErrorWithoutFlag noHints) (Just ctxt) supp
-         -- This will be reported at runtime, so we always want "error:" in the report, never "warning:"
-       ; dflags <- getDynFlags
-       ; let err_msg = pprLocMsgEnvelope (initTcMessageOpts dflags) msg
-             err_str = showSDoc dflags $
-                       err_msg $$ text "(deferred type error)"
-
-       ; return $ evDelayedError ty err_str }
-
-tryReporters :: SolverReportErrCtxt -> [ReporterSpec] -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem])
--- Use the first reporter in the list whose predicate says True
-tryReporters ctxt reporters items
-  = do { let (vis_items, invis_items)
-               = partition (isVisibleOrigin . errorItemOrigin) items
-       ; traceTc "tryReporters {" (ppr vis_items $$ ppr invis_items)
-       ; (ctxt', items') <- go ctxt reporters vis_items invis_items
-       ; traceTc "tryReporters }" (ppr items')
-       ; return (ctxt', items') }
-  where
-    go ctxt [] vis_items invis_items
-      = return (ctxt, vis_items ++ invis_items)
-
-    go ctxt (r : rs) vis_items invis_items
-       -- always look at *visible* Origins before invisible ones
-       -- this is the whole point of isVisibleOrigin
-      = do { (ctxt', vis_items') <- tryReporter ctxt r vis_items
-           ; (ctxt'', invis_items') <- tryReporter ctxt' r invis_items
-           ; go ctxt'' rs vis_items' invis_items' }
-                -- Carry on with the rest, because we must make
-                -- deferred bindings for them if we have -fdefer-type-errors
-                -- But suppress their error messages
-
-tryReporter :: SolverReportErrCtxt -> ReporterSpec -> [ErrorItem] -> TcM (SolverReportErrCtxt, [ErrorItem])
-tryReporter ctxt (str, keep_me,  suppress_after, reporter) items
-  | null yeses
-  = return (ctxt, items)
-  | otherwise
-  = do { traceTc "tryReporter{ " (text str <+> ppr yeses)
-       ; (_, no_errs) <- askNoErrs (reporter ctxt yeses)
-       ; let suppress_now   = not no_errs && suppress_after
-                            -- See Note [Suppressing error messages]
-             ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt }
-       ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after)
-       ; return (ctxt', nos) }
-  where
-    (yeses, nos) = partition keep items
-    keep item = keep_me item (classifyPredType (errorItemPred item))
-
--- | Wrap an input 'TcRnMessage' with additional contextual information,
--- such as relevant bindings or valid hole fits.
-mkErrorReport :: TcLclEnv
-              -> TcRnMessage
-                  -- ^ The main payload of the message.
-              -> Maybe SolverReportErrCtxt
-                  -- ^ The context to add, after the main diagnostic
-                  -- but before the supplementary information.
-                  -- Nothing <=> don't add any context.
-              -> [SolverReportSupplementary]
-                  -- ^ Supplementary information, to be added at the end of the message.
-              -> TcM (MsgEnvelope TcRnMessage)
-mkErrorReport tcl_env msg mb_ctxt supplementary
-  = do { mb_context <- traverse (\ ctxt -> mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)) mb_ctxt
-       ; unit_state <- hsc_units <$> getTopEnv
-       ; hfdc <- getHoleFitDispConfig
-       ; let
-           err_info =
-             ErrInfo
-               (fromMaybe empty mb_context)
-               (vcat $ map (pprSolverReportSupplementary hfdc) supplementary)
-       ; let detailed_msg = mkDetailedMessage err_info msg
-       ; mkTcRnMessage
-           (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing)
-           (TcRnMessageWithInfo unit_state $ detailed_msg) }
-
-
-
--- | Pretty-print supplementary information, to add to an error report.
-pprSolverReportSupplementary :: HoleFitDispConfig -> SolverReportSupplementary -> SDoc
--- This function should be in "GHC.Tc.Errors.Ppr",
--- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'.
-pprSolverReportSupplementary hfdc = \case
-  SupplementaryBindings binds -> pprRelevantBindings binds
-  SupplementaryHoleFits fits  -> pprValidHoleFits hfdc fits
-  SupplementaryCts      cts   -> pprConstraintsInclude cts
-
--- | Display a collection of valid hole fits.
-pprValidHoleFits :: HoleFitDispConfig -> ValidHoleFits -> SDoc
--- This function should be in "GHC.Tc.Errors.Ppr",
--- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'.
-pprValidHoleFits hfdc (ValidHoleFits (Fits fits discarded_fits) (Fits refs discarded_refs))
-  = fits_msg $$ refs_msg
-
-  where
-    fits_msg, refs_msg, fits_discard_msg, refs_discard_msg :: SDoc
-    fits_msg = ppUnless (null fits) $
-                    hang (text "Valid hole fits include") 2 $
-                    vcat (map (pprHoleFit hfdc) fits)
-                      $$ ppWhen  discarded_fits fits_discard_msg
-    refs_msg = ppUnless (null refs) $
-                  hang (text "Valid refinement hole fits include") 2 $
-                  vcat (map (pprHoleFit hfdc) refs)
-                    $$ ppWhen discarded_refs refs_discard_msg
-    fits_discard_msg =
-      text "(Some hole fits suppressed;" <+>
-      text "use -fmax-valid-hole-fits=N" <+>
-      text "or -fno-max-valid-hole-fits)"
-    refs_discard_msg =
-      text "(Some refinement hole fits suppressed;" <+>
-      text "use -fmax-refinement-hole-fits=N" <+>
-      text "or -fno-max-refinement-hole-fits)"
-
--- | Add a "Constraints include..." message.
---
--- See Note [Constraints include ...]
-pprConstraintsInclude :: [(PredType, RealSrcSpan)] -> SDoc
--- This function should be in "GHC.Tc.Errors.Ppr",
--- but we need it here because 'TcRnMessageDetails' needs an 'SDoc'.
-pprConstraintsInclude cts
-  = ppUnless (null cts) $
-     hang (text "Constraints include")
-        2 (vcat $ map pprConstraint cts)
-  where
-    pprConstraint (constraint, loc) =
-      ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))
-
-{- Note [Always warn with -fdefer-type-errors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When -fdefer-type-errors is on we warn about *all* type errors, even
-if cec_suppress is on.  This can lead to a lot more warnings than you
-would get errors without -fdefer-type-errors, but if we suppress any of
-them you might get a runtime error that wasn't warned about at compile
-time.
-
-To be consistent, we should also report multiple warnings from a single
-location in mkGroupReporter, when -fdefer-type-errors is on.  But that
-is perhaps a bit *over*-consistent!
-
-With #10283, you can now opt out of deferred type error warnings.
-
-Note [No deferring for multiplicity errors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As explained in Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify,
-linear types do not support casts and any nontrivial coercion will raise
-an error during desugaring.
-
-This means that even if we defer a multiplicity mismatch during typechecking,
-the desugarer will refuse to compile anyway. Worse: the error raised
-by the desugarer would shadow the type mismatch warnings (#20083).
-As a solution, we refuse to defer submultiplicity constraints. Test: T20083.
-
-To determine whether a constraint arose from a submultiplicity check, we
-look at the CtOrigin. All calls to tcSubMult use one of two origins,
-UsageEnvironmentOf and NonLinearPatternOrigin. Those origins are not
-used outside of linear types.
-
-In the future, we should compile 'WpMultCoercion' to a runtime error with
--fdefer-type-errors, but the current implementation does not always
-place the wrapper in the right place and the resulting program can fail Lint.
-This plan is tracked in #20083.
-
-Note [Deferred errors for coercion holes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we need to defer a type error where the destination for the evidence
-is a coercion hole. We can't just put the error in the hole, because we can't
-make an erroneous coercion. (Remember that coercions are erased for runtime.)
-Instead, we invent a new EvVar, bind it to an error and then make a coercion
-from that EvVar, filling the hole with that coercion. Because coercions'
-types are unlifted, the error is guaranteed to be hit before we get to the
-coercion.
-
-************************************************************************
-*                                                                      *
-                Irreducible predicate errors
-*                                                                      *
-************************************************************************
--}
-
-mkIrredErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport
-mkIrredErr ctxt items
-  = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1
-       ; let msg = important ctxt $ mkPlainMismatchMsg $
-                   CouldNotDeduce (getUserGivens ctxt) (item1 :| others) Nothing
-       ; return $ add_relevant_bindings binds msg  }
-  where
-    (item1:others) = final_items
-
-    filtered_items = filter (not . ei_suppress) items
-    final_items | null filtered_items = items
-                    -- they're all suppressed; must report *something*
-                    -- NB: even though reportWanteds asserts that not
-                    -- all items are suppressed, it's possible all the
-                    -- irreducibles are suppressed, and so this function
-                    -- might get all suppressed items
-                | otherwise           = filtered_items
-
-{- Note [Constructing Hole Errors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Whether or not 'mkHoleError' returns an error is not influenced by cec_suppress. In other terms,
-these "hole" errors are /not/ suppressed by cec_suppress. We want to see them!
-
-There are two cases to consider:
-
-1. For out-of-scope variables we always report an error, unless -fdefer-out-of-scope-variables is on,
-   in which case the messages are discarded. See also #12170 and #12406. If deferring, report a warning
-   only if -Wout-of-scope-variables is on.
-
-2. For the general case, when -XPartialTypeSignatures is on, warnings (instead of errors) are generated
-   for holes in partial type signatures, unless -Wpartial-type-signatures is not on, in which case
-   the messages are discarded. If deferring, report a warning only if -Wtyped-holes is on.
-
-The above can be summarised into the following table:
-
-| Hole Type    | Active Flags                                             | Outcome          |
-|--------------|----------------------------------------------------------|------------------|
-| out-of-scope | None                                                     | Error            |
-| out-of-scope | -fdefer-out-of-scope-variables, -Wout-of-scope-variables | Warning          |
-| out-of-scope | -fdefer-out-of-scope-variables                           | Ignore (discard) |
-| type         | None                                                     | Error            |
-| type         | -XPartialTypeSignatures, -Wpartial-type-signatures       | Warning          |
-| type         | -XPartialTypeSignatures                                  | Ignore (discard) |
-| expression   | None                                                     | Error            |
-| expression   | -Wdefer-typed-holes, -Wtyped-holes                       | Warning          |
-| expression   | -Wdefer-typed-holes                                      | Ignore (discard) |
-
-See also 'reportUnsolved'.
-
--}
-
-----------------
--- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors].
-mkHoleError :: NameEnv Type -> [ErrorItem] -> SolverReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage)
-mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ, hole_loc = ct_loc })
-  | isOutOfScopeHole hole
-  = do { dflags  <- getDynFlags
-       ; rdr_env <- getGlobalRdrEnv
-       ; imp_info <- getImports
-       ; curr_mod <- getModule
-       ; hpt <- getHpt
-       ; let (imp_errs, hints)
-                = unknownNameSuggestions WL_Anything
-                    dflags hpt curr_mod rdr_env
-                    (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)
-             err    = SolverReportWithCtxt ctxt (ReportHoleError hole $ OutOfScopeHole imp_errs)
-             report = SolverReport err [] hints
-
-       ; maybeAddDeferredBindings ctxt hole report
-       ; mkErrorReport lcl_env (TcRnSolverReport err (cec_out_of_scope_holes ctxt) hints) Nothing []
-          -- Pass the value 'Nothing' for the context, as it's generally not helpful
-          -- to include the context here.
-       }
-  where
-    lcl_env = ctLocEnv ct_loc
-
- -- general case: not an out-of-scope error
-mkHoleError lcl_name_cache tidy_simples ctxt
-  hole@(Hole { hole_ty = hole_ty
-             , hole_sort = sort
-             , hole_loc = ct_loc })
-  = do { rel_binds
-           <- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty)
-               -- The 'False' means "don't filter the bindings"; see #8191
-
-       ; show_hole_constraints <- goptM Opt_ShowHoleConstraints
-       ; let relevant_cts
-               | ExprHole _ <- sort, show_hole_constraints
-               = givenConstraints ctxt
-               | otherwise
-               = []
-
-       ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits
-       ; (ctxt, hole_fits) <- if show_valid_hole_fits
-                              then validHoleFits ctxt tidy_simples hole
-                              else return (ctxt, noValidHoleFits)
-       ; (grouped_skvs, other_tvs) <- zonkAndGroupSkolTvs hole_ty
-       ; let reason | ExprHole _ <- sort = cec_expr_holes ctxt
-                    | otherwise          = cec_type_holes ctxt
-             err  = SolverReportWithCtxt ctxt $ ReportHoleError hole $ HoleError sort other_tvs grouped_skvs
-             supp = [ SupplementaryBindings rel_binds
-                    , SupplementaryCts      relevant_cts
-                    , SupplementaryHoleFits hole_fits ]
-
-       ; maybeAddDeferredBindings ctxt hole (SolverReport err supp [])
-
-       ; mkErrorReport lcl_env (TcRnSolverReport err reason noHints) (Just ctxt) supp
-       }
-
-  where
-    lcl_env = ctLocEnv ct_loc
-
--- | For all the skolem type variables in a type, zonk the skolem info and group together
--- all the type variables with the same origin.
-zonkAndGroupSkolTvs :: Type -> TcM ([(SkolemInfoAnon, [TcTyVar])], [TcTyVar])
-zonkAndGroupSkolTvs hole_ty = do
-  zonked_info <- mapM (\(sk, tv) -> (,) <$> (zonkSkolemInfoAnon . getSkolemInfo $ sk) <*> pure (fst <$> tv)) skolem_list
-  return (zonked_info, other_tvs)
-  where
-    tvs = tyCoVarsOfTypeList hole_ty
-    (skol_tvs, other_tvs) = partition (\tv -> isTcTyVar tv && isSkolemTyVar tv) tvs
-
-    group_skolems :: UM.UniqMap SkolemInfo ([(TcTyVar, Int)])
-    group_skolems = bagToList <$> UM.listToUniqMap_C unionBags [(skolemSkolInfo tv, unitBag (tv, n)) | tv <- skol_tvs | n <- [0..]]
-
-    skolem_list = sortBy (comparing (sort . map snd . snd)) (UM.nonDetEltsUniqMap group_skolems)
-
-{- Note [Adding deferred bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-When working with typed holes we have to deal with the case where
-we want holes to be reported as warnings to users during compile time but
-as errors during runtime. Therefore, we have to call 'maybeAddDeferredBindings'
-so that the correct 'Severity' can be computed out of that later on.
-
--}
-
-
--- | Adds deferred bindings (as errors).
--- See Note [Adding deferred bindings].
-maybeAddDeferredBindings :: SolverReportErrCtxt
-                         -> Hole
-                         -> SolverReport
-                         -> TcM ()
-maybeAddDeferredBindings ctxt hole report = do
-  case hole_sort hole of
-    ExprHole (HER ref ref_ty _) -> do
-      -- Only add bindings for holes in expressions
-      -- not for holes in partial type signatures
-      -- cf. addDeferredBinding
-      when (deferringAnyBindings ctxt) $ do
-        err_tm <- mkErrorTerm ctxt (hole_loc hole) ref_ty report
-          -- NB: ref_ty, not hole_ty. hole_ty might be rewritten.
-          -- See Note [Holes] in GHC.Tc.Types.Constraint
-        writeMutVar ref err_tm
-    _ -> pure ()
-
--- We unwrap the SolverReportErrCtxt here, to avoid introducing a loop in module
--- imports
-validHoleFits :: SolverReportErrCtxt    -- ^ The context we're in, i.e. the
-                                        -- implications and the tidy environment
-              -> [ErrorItem]      -- ^ Unsolved simple constraints
-              -> Hole             -- ^ The hole
-              -> TcM (SolverReportErrCtxt, ValidHoleFits)
-                -- ^ We return the new context
-                -- with a possibly updated
-                -- tidy environment, and
-                -- the valid hole fits.
-validHoleFits ctxt@(CEC { cec_encl = implics
-                        , cec_tidy = lcl_env}) simps hole
-  = do { (tidy_env, fits) <- findValidHoleFits lcl_env implics (map mk_wanted simps) hole
-       ; return (ctxt {cec_tidy = tidy_env}, fits) }
-  where
-    mk_wanted :: ErrorItem -> CtEvidence
-    mk_wanted (EI { ei_pred = pred, ei_evdest = Just dest, ei_loc = loc })
-         = CtWanted { ctev_pred      = pred
-                    , ctev_dest      = dest
-                    , ctev_loc       = loc
-                    , ctev_rewriters = emptyRewriterSet }
-    mk_wanted item = pprPanic "validHoleFits no evdest" (ppr item)
-
--- See Note [Constraints include ...]
-givenConstraints :: SolverReportErrCtxt -> [(Type, RealSrcSpan)]
-givenConstraints ctxt
-  = do { implic@Implic{ ic_given = given } <- cec_encl ctxt
-       ; constraint <- given
-       ; return (varType constraint, tcl_loc (ic_env implic)) }
-
-----------------
-
-mkIPErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport
--- What would happen if an item is suppressed because of
--- Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint? Very unclear
--- what's best. Let's not worry about this.
-mkIPErr ctxt items
-  = do { (ctxt, binds, item1) <- relevantBindings True ctxt item1
-       ; let msg = important ctxt $ UnboundImplicitParams (item1 :| others)
-       ; return $ add_relevant_bindings binds msg }
-  where
-    item1:others = items
-
-----------------
-
--- | Report a representation-polymorphism error to the user:
--- a type is required to have a fixed runtime representation,
--- but doesn't.
---
--- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin.
-mkFRRErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport
-mkFRRErr ctxt items
-  = do { -- Process the error items.
-       ; (_tidy_env, frr_infos) <-
-          zonkTidyFRRInfos (cec_tidy ctxt) $
-            -- Zonk/tidy to show useful variable names.
-          nubOrdBy (nonDetCmpType `on` (frr_type . frr_info_origin)) $
-            -- Remove duplicates: only one representation-polymorphism error per type.
-          map (expectJust "mkFRRErr" . fixedRuntimeRepOrigin_maybe)
-          items
-       ; return $ important ctxt $ FixedRuntimeRepError frr_infos }
-
--- | Whether to report something using the @FixedRuntimeRep@ mechanism.
-fixedRuntimeRepOrigin_maybe :: HasDebugCallStack => ErrorItem -> Maybe FixedRuntimeRepErrorInfo
-fixedRuntimeRepOrigin_maybe item
-  -- An error that arose directly from a representation-polymorphism check.
-  | FRROrigin frr_orig <- errorItemOrigin item
-  = Just $ FRR_Info { frr_info_origin = frr_orig
-                    , frr_info_not_concrete = Nothing }
-  -- Unsolved nominal equalities involving a concrete type variable,
-  -- such as @alpha[conc] ~# rr[sk]@ or @beta[conc] ~# RR@ for a
-  -- type family application @RR@, are handled by 'mkTyVarEqErr''.
-  | otherwise
-  = Nothing
-
-{-
-Note [Constraints include ...]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-'givenConstraintsMsg' returns the "Constraints include ..." message enabled by
--fshow-hole-constraints. For example, the following hole:
-
-    foo :: (Eq a, Show a) => a -> String
-    foo x = _
-
-would generate the message:
-
-    Constraints include
-      Eq a (from foo.hs:1:1-36)
-      Show a (from foo.hs:1:1-36)
-
-Constraints are displayed in order from innermost (closest to the hole) to
-outermost. There's currently no filtering or elimination of duplicates.
-
-************************************************************************
-*                                                                      *
-                Equality errors
-*                                                                      *
-************************************************************************
-
-Note [Inaccessible code]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   data T a where
-     T1 :: T a
-     T2 :: T Bool
-
-   f :: (a ~ Int) => T a -> Int
-   f T1 = 3
-   f T2 = 4   -- Unreachable code
-
-Here the second equation is unreachable. The original constraint
-(a~Int) from the signature gets rewritten by the pattern-match to
-(Bool~Int), so the danger is that we report the error as coming from
-the *signature* (#7293).  So, for Given errors we replace the
-env (and hence src-loc) on its CtLoc with that from the immediately
-enclosing implication.
-
-Note [Error messages for untouchables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#9109)
-  data G a where { GBool :: G Bool }
-  foo x = case x of GBool -> True
-
-Here we can't solve (t ~ Bool), where t is the untouchable result
-meta-var 't', because of the (a ~ Bool) from the pattern match.
-So we infer the type
-   f :: forall a t. G a -> t
-making the meta-var 't' into a skolem.  So when we come to report
-the unsolved (t ~ Bool), t won't look like an untouchable meta-var
-any more.  So we don't assert that it is.
--}
-
--- Don't have multiple equality errors from the same location
--- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!
-mkEqErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport
-mkEqErr ctxt items
-  | item:_ <- filter (not . ei_suppress) items
-  = mkEqErr1 ctxt item
-
-  | item:_ <- items  -- they're all suppressed. still need an error message
-                     -- for -fdefer-type-errors though
-  = mkEqErr1 ctxt item
-
-  | otherwise
-  = panic "mkEqErr"  -- guaranteed to have at least one item
-
-mkEqErr1 :: SolverReportErrCtxt -> ErrorItem -> TcM SolverReport
-mkEqErr1 ctxt item   -- Wanted only
-                     -- givens handled in mkGivenErrorReporter
-  = do { (ctxt, binds, item) <- relevantBindings True ctxt item
-       ; traceTc "mkEqErr1" (ppr item $$ pprCtOrigin (errorItemOrigin item))
-       ; (err_msg, hints) <- mkEqErr_help ctxt item ty1 ty2
-       ; let
-           report = add_relevant_bindings binds
-                  $ add_report_hints hints
-                  $ important ctxt err_msg
-       ; return report }
-  where
-    (ty1, ty2) = getEqPredTys (errorItemPred item)
-
--- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint
--- is left over.
-mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs
-                       -> TcType -> TcType -> Maybe CoercibleMsg
-mkCoercibleExplanation rdr_env fam_envs ty1 ty2
-  | Just (tc, tys) <- tcSplitTyConApp_maybe ty1
-  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
-  , Just msg <- coercible_msg_for_tycon rep_tc
-  = Just msg
-  | Just (tc, tys) <- splitTyConApp_maybe ty2
-  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
-  , Just msg <- coercible_msg_for_tycon rep_tc
-  = Just msg
-  | Just (s1, _) <- tcSplitAppTy_maybe ty1
-  , Just (s2, _) <- tcSplitAppTy_maybe ty2
-  , s1 `eqType` s2
-  , has_unknown_roles s1
-  = Just $ UnknownRoles s1
-  | otherwise
-  = Nothing
-  where
-    coercible_msg_for_tycon tc
-        | isAbstractTyCon tc
-        = Just $ TyConIsAbstract tc
-        | isNewTyCon tc
-        , [data_con] <- tyConDataCons tc
-        , let dc_name = dataConName data_con
-        , isNothing (lookupGRE_Name rdr_env dc_name)
-        = Just $ OutOfScopeNewtypeConstructor tc data_con
-        | otherwise = Nothing
-
-    has_unknown_roles ty
-      | Just (tc, tys) <- tcSplitTyConApp_maybe ty
-      = tys `lengthAtLeast` tyConArity tc  -- oversaturated tycon
-      | Just (s, _) <- tcSplitAppTy_maybe ty
-      = has_unknown_roles s
-      | isTyVarTy ty
-      = True
-      | otherwise
-      = False
-
-mkEqErr_help :: SolverReportErrCtxt
-             -> ErrorItem
-             -> TcType -> TcType -> TcM (TcSolverReportMsg, [GhcHint])
-mkEqErr_help ctxt item ty1 ty2
-  | Just casted_tv1 <- getCastedTyVar_maybe ty1
-  = mkTyVarEqErr ctxt item casted_tv1 ty2
-  | Just casted_tv2 <- getCastedTyVar_maybe ty2
-  = mkTyVarEqErr ctxt item casted_tv2 ty1
-  | otherwise
-  = do
-    err <- reportEqErr ctxt item ty1 ty2
-    return (err, noHints)
-
-reportEqErr :: SolverReportErrCtxt
-            -> ErrorItem
-            -> TcType -> TcType
-            -> TcM TcSolverReportMsg
-reportEqErr ctxt item ty1 ty2
-  = do
-    mb_coercible_info <-
-      if errorItemEqRel item == ReprEq
-      then coercible_msg ty1 ty2
-      else return Nothing
-    return $
-      Mismatch
-       { mismatchMsg           = mismatch
-       , mismatchTyVarInfo     = Nothing
-       , mismatchAmbiguityInfo = eqInfos
-       , mismatchCoercibleInfo = mb_coercible_info }
-  where
-    mismatch = misMatchOrCND False ctxt item ty1 ty2
-    eqInfos  = eqInfoMsgs ty1 ty2
-
-coercible_msg :: TcType -> TcType -> TcM (Maybe CoercibleMsg)
-coercible_msg ty1 ty2
-  = do
-    rdr_env  <- getGlobalRdrEnv
-    fam_envs <- tcGetFamInstEnvs
-    return $ mkCoercibleExplanation rdr_env fam_envs ty1 ty2
-
-mkTyVarEqErr :: SolverReportErrCtxt -> ErrorItem
-             -> (TcTyVar, TcCoercionN) -> TcType -> TcM (TcSolverReportMsg, [GhcHint])
--- tv1 and ty2 are already tidied
-mkTyVarEqErr ctxt item casted_tv1 ty2
-  = do { traceTc "mkTyVarEqErr" (ppr item $$ ppr casted_tv1 $$ ppr ty2)
-       ; mkTyVarEqErr' ctxt item casted_tv1 ty2 }
-
-mkTyVarEqErr' :: SolverReportErrCtxt -> ErrorItem
-              -> (TcTyVar, TcCoercionN) -> TcType -> TcM (TcSolverReportMsg, [GhcHint])
-mkTyVarEqErr' ctxt item (tv1, co1) ty2
-
-  -- Is this a representation-polymorphism error, e.g.
-  -- alpha[conc] ~# rr[sk] ? If so, handle that first.
-  | Just frr_info <- mb_concrete_reason
-  = do
-      (_, infos) <- zonkTidyFRRInfos (cec_tidy ctxt) [frr_info]
-      return (FixedRuntimeRepError infos, [])
-
-  -- Impredicativity is a simple error to understand; try it before
-  -- anything more complicated.
-  | check_eq_result `cterHasProblem` cteImpredicative
-  = do
-    tyvar_eq_info <- extraTyVarEqInfo (tv1, Nothing) ty2
-    let
-        poly_msg = CannotUnifyWithPolytype item tv1 ty2 mb_tv_info
-        mb_tv_info
-          | isSkolemTyVar tv1
-          = Just tyvar_eq_info
-          | otherwise
-          = Nothing
-        main_msg =
-          CannotUnifyVariable
-            { mismatchMsg       = headline_msg
-            , cannotUnifyReason = poly_msg }
-        -- Unlike the other reports, this discards the old 'report_important'
-        -- instead of augmenting it.  This is because the details are not likely
-        -- to be helpful since this is just an unimplemented feature.
-    return (main_msg, [])
-
-  | isSkolemTyVar tv1  -- ty2 won't be a meta-tyvar; we would have
-                       -- swapped in Solver.Canonical.canEqTyVarHomo
-    || isTyVarTyVar tv1 && not (isTyVarTy ty2)
-    || errorItemEqRel item == ReprEq
-     -- The cases below don't really apply to ReprEq (except occurs check)
-  = do
-    tv_extra <- extraTyVarEqInfo (tv1, Nothing) ty2
-    reason <-
-      if errorItemEqRel item == ReprEq
-      then RepresentationalEq tv_extra <$> coercible_msg ty1 ty2
-      else return $ DifferentTyVars tv_extra
-    let main_msg =
-          CannotUnifyVariable
-            { mismatchMsg       = headline_msg
-            , cannotUnifyReason = reason }
-    return (main_msg, add_sig)
-
-  | cterHasOccursCheck check_eq_result
-    -- We report an "occurs check" even for  a ~ F t a, where F is a type
-    -- function; it's not insoluble (because in principle F could reduce)
-    -- but we have certainly been unable to solve it
-  = let ambiguity_infos = eqInfoMsgs ty1 ty2
-
-        interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
-                             filter isTyVar $
-                             fvVarList $
-                             tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
-
-        occurs_err =
-          OccursCheck
-            { occursCheckInterestingTyVars = interesting_tyvars
-            , occursCheckAmbiguityInfos    = ambiguity_infos }
-        main_msg =
-          CannotUnifyVariable
-            { mismatchMsg       = headline_msg
-            , cannotUnifyReason = occurs_err }
-
-    in return (main_msg, [])
-
-    -- This is wrinkle (4) in Note [Equalities with incompatible kinds] in
-    -- GHC.Tc.Solver.Canonical
-  | hasCoercionHoleCo co1 || hasCoercionHoleTy ty2
-  = return (mkBlockedEqErr item, [])
-
-  -- If the immediately-enclosing implication has 'tv' a skolem, and
-  -- we know by now its an InferSkol kind of skolem, then presumably
-  -- it started life as a TyVarTv, else it'd have been unified, given
-  -- that there's no occurs-check or forall problem
-  | (implic:_) <- cec_encl ctxt
-  , Implic { ic_skols = skols } <- implic
-  , tv1 `elem` skols
-  = do
-    tv_extra <- extraTyVarEqInfo (tv1, Nothing) ty2
-    let msg = Mismatch
-               { mismatchMsg           = mismatch_msg
-               , mismatchTyVarInfo     = Just tv_extra
-               , mismatchAmbiguityInfo = []
-               , mismatchCoercibleInfo = Nothing }
-    return (msg, [])
-
-  -- Check for skolem escape
-  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
-  , Implic { ic_skols = skols } <- implic
-  , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols
-  , not (null esc_skols)
-  = let main_msg =
-          CannotUnifyVariable
-            { mismatchMsg       = mismatch_msg
-            , cannotUnifyReason = SkolemEscape item implic esc_skols }
-
-  in return (main_msg, [])
-
-  -- Nastiest case: attempt to unify an untouchable variable
-  -- So tv is a meta tyvar (or started that way before we
-  -- generalised it).  So presumably it is an *untouchable*
-  -- meta tyvar or a TyVarTv, else it'd have been unified
-  -- See Note [Error messages for untouchables]
-  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
-  , Implic { ic_tclvl = lvl } <- implic
-  = assertPpr (not (isTouchableMetaTyVar lvl tv1))
-              (ppr tv1 $$ ppr lvl) $ do -- See Note [Error messages for untouchables]
-    tv_extra <- extraTyVarEqInfo (tv1, Just implic) ty2
-    let tv_extra' = tv_extra { thisTyVarIsUntouchable = Just implic }
-        msg = Mismatch
-               { mismatchMsg           = mismatch_msg
-               , mismatchTyVarInfo     = Just tv_extra'
-               , mismatchAmbiguityInfo = []
-               , mismatchCoercibleInfo = Nothing }
-    return (msg, add_sig)
-
-  | otherwise
-  = do
-    err <- reportEqErr ctxt item (mkTyVarTy tv1) ty2
-    return (err, [])
-        -- This *can* happen (#6123)
-        -- Consider an ambiguous top-level constraint (a ~ F a)
-        -- Not an occurs check, because F is a type function.
-  where
-    headline_msg = misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2
-    mismatch_msg = mkMismatchMsg item ty1 ty2
-    add_sig      = maybeToList $ suggestAddSig ctxt ty1 ty2
-
-    -- The following doesn't use the cterHasProblem mechanism because
-    -- we need to retrieve the ConcreteTvOrigin. Just knowing whether
-    -- there is an error is not sufficient. See #21430.
-    mb_concrete_reason
-      | Just frr_orig <- isConcreteTyVar_maybe tv1
-      , not (isConcrete ty2)
-      = Just $ frr_reason frr_orig tv1 ty2
-      | Just (tv2, frr_orig) <- isConcreteTyVarTy_maybe ty2
-      , not (isConcreteTyVar tv1)
-      = Just $ frr_reason frr_orig tv2 ty1
-      -- NB: if it's an unsolved equality in which both sides are concrete
-      -- (e.g. a concrete type variable on both sides), then it's not a
-      -- representation-polymorphism problem.
-      | otherwise
-      = Nothing
-    frr_reason (ConcreteFRR frr_orig) conc_tv not_conc
-      = FRR_Info { frr_info_origin = frr_orig
-                 , frr_info_not_concrete = Just (conc_tv, not_conc) }
-
-    ty1 = mkTyVarTy tv1
-
-    check_eq_result = case ei_m_reason item of
-      Just (NonCanonicalReason result) -> result
-      _ -> checkTyVarEq tv1 ty2
-        -- in T2627b, we report an error for F (F a0) ~ a0. Note that the type
-        -- variable is on the right, so we don't get useful info for the CIrredCan,
-        -- and have to compute the result of checkTyVarEq here.
-
-    insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs
-
-eqInfoMsgs :: TcType -> TcType -> [AmbiguityInfo]
--- Report (a) ambiguity if either side is a type function application
---            e.g. F a0 ~ Int
---        (b) warning about injectivity if both sides are the same
---            type function application   F a ~ F b
---            See Note [Non-injective type functions]
-eqInfoMsgs ty1 ty2
-  = catMaybes [tyfun_msg, ambig_msg]
-  where
-    mb_fun1 = isTyFun_maybe ty1
-    mb_fun2 = isTyFun_maybe ty2
-
-      -- if a type isn't headed by a type function, then any ambiguous
-      -- variables need not be reported as such. e.g.: F a ~ t0 -> t0, where a is a skolem
-    ambig_tkvs1 = maybe mempty (\_ -> ambigTkvsOfTy ty1) mb_fun1
-    ambig_tkvs2 = maybe mempty (\_ -> ambigTkvsOfTy ty2) mb_fun2
-
-    ambig_tkvs@(ambig_kvs, ambig_tvs) = ambig_tkvs1 S.<> ambig_tkvs2
-
-    ambig_msg | isJust mb_fun1 || isJust mb_fun2
-              , not (null ambig_kvs && null ambig_tvs)
-              = Just $ Ambiguity False ambig_tkvs
-              | otherwise
-              = Nothing
-
-    tyfun_msg | Just tc1 <- mb_fun1
-              , Just tc2 <- mb_fun2
-              , tc1 == tc2
-              , not (isInjectiveTyCon tc1 Nominal)
-              = Just $ NonInjectiveTyFam tc1
-              | otherwise
-              = Nothing
-
-misMatchOrCND :: Bool -> SolverReportErrCtxt -> ErrorItem
-              -> TcType -> TcType -> MismatchMsg
--- If oriented then ty1 is actual, ty2 is expected
-misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2
-  | insoluble_occurs_check  -- See Note [Insoluble occurs check]
-    || (isRigidTy ty1 && isRigidTy ty2)
-    || (ei_flavour item == Given)
-    || null givens
-  = -- If the equality is unconditionally insoluble
-    -- or there is no context, don't report the context
-    mkMismatchMsg item ty1 ty2
-
-  | otherwise
-  = CouldNotDeduce givens (item :| []) (Just $ CND_Extra level ty1 ty2)
-
-  where
-    level   = ctLocTypeOrKind_maybe (errorItemCtLoc item) `orElse` TypeLevel
-    givens  = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ]
-              -- Keep only UserGivens that have some equalities.
-              -- See Note [Suppress redundant givens during error reporting]
-
--- These are for the "blocked" equalities, as described in TcCanonical
--- Note [Equalities with incompatible kinds], wrinkle (2). There should
--- always be another unsolved wanted around, which will ordinarily suppress
--- this message. But this can still be printed out with -fdefer-type-errors
--- (sigh), so we must produce a message.
-mkBlockedEqErr :: ErrorItem -> TcSolverReportMsg
-mkBlockedEqErr item = BlockedEquality item
-
-{-
-Note [Suppress redundant givens during error reporting]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When GHC is unable to solve a constraint and prints out an error message, it
-will print out what given constraints are in scope to provide some context to
-the programmer. But we shouldn't print out /every/ given, since some of them
-are not terribly helpful to diagnose type errors. Consider this example:
-
-  foo :: Int :~: Int -> a :~: b -> a :~: c
-  foo Refl Refl = Refl
-
-When reporting that GHC can't solve (a ~ c), there are two givens in scope:
-(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e.,
-redundant), so it's not terribly useful to report it in an error message.
-To accomplish this, we discard any Implications that do not bind any
-equalities by filtering the `givens` selected in `misMatchOrCND` (based on
-the `ic_given_eqs` field of the Implication). Note that we discard givens
-that have no equalities whatsoever, but we want to keep ones with only *local*
-equalities, as these may be helpful to the user in understanding what went
-wrong.
-
-But this is not enough to avoid all redundant givens! Consider this example,
-from #15361:
-
-  goo :: forall (a :: Type) (b :: Type) (c :: Type).
-         a :~~: b -> a :~~: c
-  goo HRefl = HRefl
-
-Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope.
-The (* ~ *) part arises due the kinds of (:~~:) being unified. More
-importantly, (* ~ *) is redundant, so we'd like not to report it. However,
-the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its
-ic_given_eqs field), so the test above will keep it wholesale.
-
-To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b)
-part. This works because mkMinimalBySCs eliminates reflexive equalities in
-addition to superclasses (see Note [Remove redundant provided dicts]
-in GHC.Tc.TyCl.PatSyn).
--}
-
-extraTyVarEqInfo :: (TcTyVar, Maybe Implication) -> TcType -> TcM TyVarInfo
--- Add on extra info about skolem constants
--- NB: The types themselves are already tidied
-extraTyVarEqInfo (tv1, mb_implic) ty2
-  = do
-      tv1_info <- extraTyVarInfo tv1
-      ty2_info <- ty_extra ty2
-      return $
-        TyVarInfo
-          { thisTyVar              = tv1_info
-          , thisTyVarIsUntouchable = mb_implic
-          , otherTy                = ty2_info }
-  where
-    ty_extra ty = case getCastedTyVar_maybe ty of
-                    Just (tv, _) -> Just <$> extraTyVarInfo tv
-                    Nothing      -> return Nothing
-
-extraTyVarInfo :: TcTyVar -> TcM TyVar
-extraTyVarInfo tv = assertPpr (isTyVar tv) (ppr tv) $
-  case tcTyVarDetails tv of
-    SkolemTv skol_info lvl overlaps -> do
-      new_skol_info <- zonkSkolemInfo skol_info
-      return $ mkTcTyVar (tyVarName tv) (tyVarKind tv) (SkolemTv new_skol_info lvl overlaps)
-    _ -> return tv
-
-
-suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint
--- See Note [Suggest adding a type signature]
-suggestAddSig ctxt ty1 _ty2
-  | bndr : bndrs <- inferred_bndrs
-  = Just $ SuggestAddTypeSignatures $ NamedBindings (bndr :| bndrs)
-  | otherwise
-  = Nothing
-  where
-    inferred_bndrs =
-      case getTyVar_maybe ty1 of
-        Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv
-        _                          -> []
-
-    -- 'find' returns the binders of an InferSkol for 'tv',
-    -- provided there is an intervening implication with
-    -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match)
-    find [] _ _ = []
-    find (implic:implics) seen_eqs tv
-       | tv `elem` ic_skols implic
-       , InferSkol prs <- ic_info implic
-       , seen_eqs
-       = map fst prs
-       | otherwise
-       = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv
-
---------------------
-mkMismatchMsg :: ErrorItem -> Type -> Type -> MismatchMsg
-mkMismatchMsg item ty1 ty2 =
-  case orig of
-    TypeEqOrigin { uo_actual, uo_expected, uo_thing = mb_thing } ->
-      (TypeEqMismatch
-        { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds
-        , teq_mismatch_item = item
-        , teq_mismatch_ty1  = ty1
-        , teq_mismatch_ty2  = ty2
-        , teq_mismatch_actual   = uo_actual
-        , teq_mismatch_expected = uo_expected
-        , teq_mismatch_what     = mb_thing
-        , teq_mb_same_occ       = sameOccExtras ty2 ty1 })
-    KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k ->
-      (mkBasicMismatchMsg NoEA item ty1 ty2)
-        { mismatch_whenMatching = Just $ WhenMatching cty1 cty2 sub_o mb_sub_t_or_k
-        , mismatch_mb_same_occ  = mb_same_occ }
-    _ ->
-      (mkBasicMismatchMsg NoEA item ty1 ty2)
-        { mismatch_mb_same_occ  = mb_same_occ }
-  where
-    orig = errorItemOrigin item
-    mb_same_occ = sameOccExtras ty2 ty1
-    ppr_explicit_kinds = shouldPprWithExplicitKinds ty1 ty2 orig
-
--- | Whether to print explicit kinds (with @-fprint-explicit-kinds@)
--- in an 'SDoc' when a type mismatch occurs to due invisible kind arguments.
---
--- This function first checks to see if the 'CtOrigin' argument is a
--- 'TypeEqOrigin'. If so, it first checks whether the equality is a visible
--- equality; if it's not, definitely print the kinds. Even if the equality is
--- a visible equality, check the expected/actual types to see if the types
--- have equal visible components. If the 'CtOrigin' is
--- not a 'TypeEqOrigin', fall back on the actual mismatched types themselves.
-shouldPprWithExplicitKinds :: Type -> Type -> CtOrigin -> Bool
-shouldPprWithExplicitKinds _ty1 _ty2 (TypeEqOrigin { uo_actual = act
-                                                   , uo_expected = exp
-                                                   , uo_visible = vis })
-  | not vis   = True                  -- See tests T15870, T16204c
-  | otherwise = tcEqTypeVis act exp   -- See tests T9171, T9144.
-shouldPprWithExplicitKinds ty1 ty2 _ct
-  = tcEqTypeVis ty1 ty2
-
-{- Note [Insoluble occurs check]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider [G] a ~ [a],  [W] a ~ [a] (#13674).  The Given is insoluble
-so we don't use it for rewriting.  The Wanted is also insoluble, and
-we don't solve it from the Given.  It's very confusing to say
-    Cannot solve a ~ [a] from given constraints a ~ [a]
-
-And indeed even thinking about the Givens is silly; [W] a ~ [a] is
-just as insoluble as Int ~ Bool.
-
-Conclusion: if there's an insoluble occurs check (cteInsolubleOccurs)
-then report it directly, not in the "cannot deduce X from Y" form.
-This is done in misMatchOrCND (via the insoluble_occurs_check arg)
-
-(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't
-want to be as draconian with them.)
--}
-
-sameOccExtras :: TcType -> TcType -> Maybe SameOccInfo
--- See Note [Disambiguating (X ~ X) errors]
-sameOccExtras ty1 ty2
-  | Just (tc1, _) <- tcSplitTyConApp_maybe ty1
-  , Just (tc2, _) <- tcSplitTyConApp_maybe ty2
-  , let n1 = tyConName tc1
-        n2 = tyConName tc2
-        same_occ = nameOccName n1                   == nameOccName n2
-        same_pkg = moduleUnit (nameModule n1) == moduleUnit (nameModule n2)
-  , n1 /= n2   -- Different Names
-  , same_occ   -- but same OccName
-  = Just $ SameOcc same_pkg n1 n2
-  | otherwise
-  = Nothing
-
-{- Note [Suggest adding a type signature]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The OutsideIn algorithm rejects GADT programs that don't have a principal
-type, and indeed some that do.  Example:
-   data T a where
-     MkT :: Int -> T Int
-
-   f (MkT n) = n
-
-Does this have type f :: T a -> a, or f :: T a -> Int?
-The error that shows up tends to be an attempt to unify an
-untouchable type variable.  So suggestAddSig sees if the offending
-type variable is bound by an *inferred* signature, and suggests
-adding a declared signature instead.
-
-More specifically, we suggest adding a type sig if we have p ~ ty, and
-p is a skolem bound by an InferSkol.  Those skolems were created from
-unification variables in simplifyInfer.  Why didn't we unify?  It must
-have been because of an intervening GADT or existential, making it
-untouchable. Either way, a type signature would help.  For GADTs, it
-might make it typeable; for existentials the attempt to write a
-signature will fail -- or at least will produce a better error message
-next time
-
-This initially came up in #8968, concerning pattern synonyms.
-
-Note [Disambiguating (X ~ X) errors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See #8278
-
-Note [Reporting occurs-check errors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied
-type signature, then the best thing is to report that we can't unify
-a with [a], because a is a skolem variable.  That avoids the confusing
-"occur-check" error message.
-
-But nowadays when inferring the type of a function with no type signature,
-even if there are errors inside, we still generalise its signature and
-carry on. For example
-   f x = x:x
-Here we will infer something like
-   f :: forall a. a -> [a]
-with a deferred error of (a ~ [a]).  So in the deferred unsolved constraint
-'a' is now a skolem, but not one bound by the programmer in the context!
-Here we really should report an occurs check.
-
-So isUserSkolem distinguishes the two.
-
-Note [Non-injective type functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's very confusing to get a message like
-     Couldn't match expected type `Depend s'
-            against inferred type `Depend s1'
-so mkTyFunInfoMsg adds:
-       NB: `Depend' is type function, and hence may not be injective
-
-Warn of loopy local equalities that were dropped.
-
-
-************************************************************************
-*                                                                      *
-                 Type-class errors
-*                                                                      *
-************************************************************************
--}
-
-mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport
-mkDictErr ctxt orig_items
-  = assert (not (null items)) $
-    do { inst_envs <- tcGetInstEnvs
-       ; let min_items = elim_superclasses items
-             lookups = map (lookup_cls_inst inst_envs) min_items
-             (no_inst_items, overlap_items) = partition is_no_inst lookups
-
-       -- Report definite no-instance errors,
-       -- or (iff there are none) overlap errors
-       -- But we report only one of them (hence 'head') because they all
-       -- have the same source-location origin, to try avoid a cascade
-       -- of error from one location
-       ; err <- mk_dict_err ctxt (head (no_inst_items ++ overlap_items))
-       ; return $ important ctxt err }
-  where
-    filtered_items = filter (not . ei_suppress) orig_items
-    items | null filtered_items = orig_items  -- all suppressed, but must report
-                                              -- something for -fdefer-type-errors
-          | otherwise           = filtered_items  -- common case
-
-    no_givens = null (getUserGivens ctxt)
-
-    is_no_inst (item, (matches, unifiers, _))
-      =  no_givens
-      && null matches
-      && (nullUnifiers unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfTypeList (errorItemPred item)))
-
-    lookup_cls_inst inst_envs item
-      = (item, lookupInstEnv True inst_envs clas tys)
-      where
-        (clas, tys) = getClassPredTys (errorItemPred item)
-
-
-    -- When simplifying [W] Ord (Set a), we need
-    --    [W] Eq a, [W] Ord a
-    -- but we really only want to report the latter
-    elim_superclasses items = mkMinimalBySCs errorItemPred items
-
--- Note [mk_dict_err]
--- ~~~~~~~~~~~~~~~~~~~
--- Different dictionary error messages are reported depending on the number of
--- matches and unifiers:
---
---   - No matches, regardless of unifiers: report "No instance for ...".
---   - Two or more matches, regardless of unifiers: report "Overlapping instances for ...",
---     and show the matching and unifying instances.
---   - One match, one or more unifiers: report "Overlapping instances for", show the
---     matching and unifying instances, and say "The choice depends on the instantion of ...,
---     and the result of evaluating ...".
-mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (ErrorItem, ClsInstLookupResult)
-            -> TcM TcSolverReportMsg
-mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped)) = case (NE.nonEmpty matches, NE.nonEmpty unsafe_overlapped) of
-  (Nothing, _)  -> do -- No matches but perhaps several unifiers
-    { (_, rel_binds, item) <- relevantBindings True ctxt item
-    ; candidate_insts <- get_candidate_instances
-    ; (imp_errs, field_suggestions) <- record_field_suggestions
-    ; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) }
-
-  -- Some matches => overlap errors
-  (Just matchesNE, Nothing) -> return $
-    OverlappingInstances item (NE.map fst matchesNE) (getPotentialUnifiers unifiers)
-
-  (Just (match :| []), Just unsafe_overlappedNE) -> return $
-    UnsafeOverlap item (fst match) (NE.map fst unsafe_overlappedNE)
-  (Just matches@(_ :| _), Just overlaps) -> pprPanic "mk_dict_err: multiple matches with overlap" $ vcat [ text "matches:" <+> ppr matches, text "overlaps:" <+> ppr overlaps ]
-  where
-    orig          = errorItemOrigin item
-    pred          = errorItemPred item
-    (clas, tys)   = getClassPredTys pred
-
-    get_candidate_instances :: TcM [ClsInst]
-    -- See Note [Report candidate instances]
-    get_candidate_instances
-      | [ty] <- tys   -- Only try for single-parameter classes
-      = do { instEnvs <- tcGetInstEnvs
-           ; return (filter (is_candidate_inst ty)
-                            (classInstances instEnvs clas)) }
-      | otherwise = return []
-
-    is_candidate_inst ty inst -- See Note [Report candidate instances]
-      | [other_ty] <- is_tys inst
-      , Just (tc1, _) <- tcSplitTyConApp_maybe ty
-      , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty
-      = let n1 = tyConName tc1
-            n2 = tyConName tc2
-            different_names = n1 /= n2
-            same_occ_names = nameOccName n1 == nameOccName n2
-        in different_names && same_occ_names
-      | otherwise = False
-
-    -- See Note [Out-of-scope fields with -XOverloadedRecordDot]
-    record_field_suggestions :: TcM ([ImportError], [GhcHint])
-    record_field_suggestions = flip (maybe $ return ([], noHints)) record_field $ \name ->
-       do { glb_env <- getGlobalRdrEnv
-          ; lcl_env <- getLocalRdrEnv
-          ; if occ_name_in_scope glb_env lcl_env name
-            then return ([], noHints)
-            else do { dflags   <- getDynFlags
-                    ; imp_info <- getImports
-                    ; curr_mod <- getModule
-                    ; hpt      <- getHpt
-                    ; return (unknownNameSuggestions WL_RecField dflags hpt curr_mod
-                        glb_env emptyLocalRdrEnv imp_info (mkRdrUnqual name)) } }
-
-    occ_name_in_scope glb_env lcl_env occ_name = not $
-      null (lookupGlobalRdrEnv glb_env occ_name) &&
-      isNothing (lookupLocalRdrOcc lcl_env occ_name)
-
-    record_field = case orig of
-      HasFieldOrigin name -> Just (mkVarOccFS name)
-      _                   -> Nothing
-
-    cannot_resolve_msg :: ErrorItem -> [ClsInst] -> RelevantBindings
-                       -> [ImportError] -> [GhcHint] -> TcSolverReportMsg
-    cannot_resolve_msg item candidate_insts binds imp_errs field_suggestions
-      = CannotResolveInstance item (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds
-
-{- Note [Report candidate instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we have an unsolved (Num Int), where `Int` is not the Prelude Int,
-but comes from some other module, then it may be helpful to point out
-that there are some similarly named instances elsewhere.  So we get
-something like
-    No instance for (Num Int) arising from the literal ‘3’
-    There are instances for similar types:
-      instance Num GHC.Types.Int -- Defined in ‘GHC.Num’
-Discussion in #9611.
-
-Note [Highlighting ambiguous type variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we encounter ambiguous type variables (i.e. type variables
-that remain metavariables after type inference), we need a few more
-conditions before we can reason that *ambiguity* prevents constraints
-from being solved:
-  - We can't have any givens, as encountering a typeclass error
-    with given constraints just means we couldn't deduce
-    a solution satisfying those constraints and as such couldn't
-    bind the type variable to a known type.
-  - If we don't have any unifiers, we don't even have potential
-    instances from which an ambiguity could arise.
-  - Lastly, I don't want to mess with error reporting for
-    unknown runtime types so we just fall back to the old message there.
-Once these conditions are satisfied, we can safely say that ambiguity prevents
-the constraint from being solved.
-
-Note [Out-of-scope fields with -XOverloadedRecordDot]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-With -XOverloadedRecordDot, when a field isn't in scope, the error that appears
-is produces here, and it says
-    No instance for (GHC.Record.HasField "<fieldname>" ...).
-
-Additionally, though, we want to suggest similar field names that are in scope
-or could be in scope with different import lists.
-
-However, we can still get an error about a missing HasField instance when a
-field is in scope (if the types are wrong), and so it's important that we don't
-suggest similar names here if the record field is in scope, either qualified or
-unqualified, since qualification doesn't matter for -XOverloadedRecordDot.
-
-Example:
-
-    import Data.Monoid (Alt(..))
-
-    foo = undefined.getAll
-
-results in
-
-     No instance for (GHC.Records.HasField "getAll" r0 a0)
-        arising from selecting the field ‘getAll’
-      Perhaps you meant ‘getAlt’ (imported from Data.Monoid)
-      Perhaps you want to add ‘getAll’ to the import list
-      in the import of ‘Data.Monoid’
--}
-
-{-
-Note [Kind arguments in error messages]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It can be terribly confusing to get an error message like (#9171)
-
-    Couldn't match expected type ‘GetParam Base (GetParam Base Int)’
-                with actual type ‘GetParam Base (GetParam Base Int)’
-
-The reason may be that the kinds don't match up.  Typically you'll get
-more useful information, but not when it's as a result of ambiguity.
-
-To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag
-whenever any error message arises due to a kind mismatch. This means that
-the above error message would instead be displayed as:
-
-    Couldn't match expected type
-                  ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’
-                with actual type
-                  ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’
-
-Which makes it clearer that the culprit is the mismatch between `k2` and `k20`.
--}
-
------------------------
--- relevantBindings looks at the value environment and finds values whose
--- types mention any of the offending type variables.  It has to be
--- careful to zonk the Id's type first, so it has to be in the monad.
--- We must be careful to pass it a zonked type variable, too.
---
--- We always remove closed top-level bindings, though,
--- since they are never relevant (cf #8233)
-
-relevantBindings :: Bool  -- True <=> filter by tyvar; False <=> no filtering
-                          -- See #8191
-                 -> SolverReportErrCtxt -> ErrorItem
-                 -> TcM (SolverReportErrCtxt, RelevantBindings, ErrorItem)
--- Also returns the zonked and tidied CtOrigin of the constraint
-relevantBindings want_filtering ctxt item
-  = do { traceTc "relevantBindings" (ppr item)
-       ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
-
-             -- For *kind* errors, report the relevant bindings of the
-             -- enclosing *type* equality, because that's more useful for the programmer
-       ; let extra_tvs = case tidy_orig of
-                             KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2]
-                             _                      -> emptyVarSet
-             ct_fvs = tyCoVarsOfType (errorItemPred item) `unionVarSet` extra_tvs
-
-             -- Put a zonked, tidied CtOrigin into the ErrorItem
-             loc'   = setCtLocOrigin loc tidy_orig
-             item'  = item { ei_loc = loc' }
-
-       ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env]
-
-       ; relev_bds <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs
-       ; let ctxt'  = ctxt { cec_tidy = env2 }
-       ; return (ctxt', relev_bds, item') }
-  where
-    loc     = errorItemCtLoc item
-    lcl_env = ctLocEnv loc
-
--- slightly more general version, to work also with holes
-relevant_bindings :: Bool
-                  -> TcLclEnv
-                  -> NameEnv Type -- Cache of already zonked and tidied types
-                  -> TyCoVarSet
-                  -> TcM RelevantBindings
-relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs
-  = do { dflags <- getDynFlags
-       ; traceTc "relevant_bindings" $
-           vcat [ ppr ct_tvs
-                , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id)
-                                   | TcIdBndr id _ <- tcl_bndrs lcl_env ]
-                , pprWithCommas id
-                    [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ]
-
-       ; go dflags (maxRelevantBinds dflags)
-                    emptyVarSet (RelevantBindings [] False)
-                    (removeBindingShadowing $ tcl_bndrs lcl_env)
-         -- tcl_bndrs has the innermost bindings first,
-         -- which are probably the most relevant ones
-  }
-  where
-    run_out :: Maybe Int -> Bool
-    run_out Nothing = False
-    run_out (Just n) = n <= 0
-
-    dec_max :: Maybe Int -> Maybe Int
-    dec_max = fmap (\n -> n - 1)
-
-
-    go :: DynFlags -> Maybe Int -> TcTyVarSet
-       -> RelevantBindings
-       -> [TcBinder]
-       -> TcM RelevantBindings
-    go _ _ _ (RelevantBindings bds discards) []
-      = return $ RelevantBindings (reverse bds) discards
-    go dflags n_left tvs_seen rels@(RelevantBindings bds discards) (tc_bndr : tc_bndrs)
-      = case tc_bndr of
-          TcTvBndr {} -> discard_it
-          TcIdBndr id top_lvl -> go2 (idName id) top_lvl
-          TcIdBndr_ExpType name et top_lvl ->
-            do { mb_ty <- readExpType_maybe et
-                   -- et really should be filled in by now. But there's a chance
-                   -- it hasn't, if, say, we're reporting a kind error en route to
-                   -- checking a term. See test indexed-types/should_fail/T8129
-                   -- Or we are reporting errors from the ambiguity check on
-                   -- a local type signature
-               ; case mb_ty of
-                   Just _ty -> go2 name top_lvl
-                   Nothing -> discard_it  -- No info; discard
-               }
-      where
-        discard_it = go dflags n_left tvs_seen rels tc_bndrs
-        go2 id_name top_lvl
-          = do { let tidy_ty = case lookupNameEnv lcl_name_env id_name of
-                                  Just tty -> tty
-                                  Nothing -> pprPanic "relevant_bindings" (ppr id_name)
-               ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty)
-               ; let id_tvs = tyCoVarsOfType tidy_ty
-                     bd = (id_name, tidy_ty)
-                     new_seen = tvs_seen `unionVarSet` id_tvs
-
-               ; if (want_filtering && not (hasPprDebug dflags)
-                                    && id_tvs `disjointVarSet` ct_tvs)
-                          -- We want to filter out this binding anyway
-                          -- so discard it silently
-                 then discard_it
-
-                 else if isTopLevel top_lvl && not (isNothing n_left)
-                          -- It's a top-level binding and we have not specified
-                          -- -fno-max-relevant-bindings, so discard it silently
-                 then discard_it
-
-                 else if run_out n_left && id_tvs `subVarSet` tvs_seen
-                          -- We've run out of n_left fuel and this binding only
-                          -- mentions already-seen type variables, so discard it
-                 then go dflags n_left tvs_seen (RelevantBindings bds True) -- Record that we have now discarded something
-                         tc_bndrs
-
-                          -- Keep this binding, decrement fuel
-                 else go dflags (dec_max n_left) new_seen
-                         (RelevantBindings (bd:bds) discards) tc_bndrs }
-
------------------------
-warnDefaulting :: TcTyVar -> [Ct] -> Type -> TcM ()
-warnDefaulting _ [] _
-  = panic "warnDefaulting: empty Wanteds"
-warnDefaulting the_tv wanteds@(ct:_) default_ty
-  = do { warn_default <- woptM Opt_WarnTypeDefaults
-       ; env0 <- tcInitTidyEnv
-            -- don't want to report all the superclass constraints, which
-            -- add unhelpful clutter
-       ; let filtered = filter (not . isWantedSuperclassOrigin . ctOrigin) wanteds
-             tidy_env = tidyFreeTyCoVars env0 $
-                        tyCoVarsOfCtsList (listToBag filtered)
-             tidy_wanteds = map (tidyCt tidy_env) filtered
-             tidy_tv = lookupVarEnv (snd tidy_env) the_tv
-             diag = TcRnWarnDefaulting tidy_wanteds tidy_tv default_ty
-             loc = ctLoc ct
-       ; setCtLocM loc $ diagnosticTc warn_default diag }
-
-{-
-Note [Runtime skolems]
-~~~~~~~~~~~~~~~~~~~~~~
-We want to give a reasonably helpful error message for ambiguity
-arising from *runtime* skolems in the debugger.  These
-are created by in GHC.Runtime.Heap.Inspect.zonkRTTIType.
--}
-
-{-**********************************************************************
-*                                                                      *
-                      GHC API helper functions
-*                                                                      *
-**********************************************************************-}
-
--- | If the 'TcSolverReportMsg' is a type mismatch between
--- an actual and an expected type, return the actual and expected types
--- (in that order).
---
--- Prefer using this over manually inspecting the 'TcSolverReportMsg' datatype
--- if you just want this information, as the datatype itself is subject to change
--- across GHC versions.
-solverReportMsg_ExpectedActuals :: TcSolverReportMsg -> [(Type, Type)]
-solverReportMsg_ExpectedActuals
-  = \case
-    Mismatch { mismatchMsg = mismatch_msg } ->
-      case mismatch_msg of
-        BasicMismatch { mismatch_ty1 = exp, mismatch_ty2 = act } ->
-          [(exp, act)]
-        KindMismatch { kmismatch_expected = exp, kmismatch_actual = act } ->
-          [(exp, act)]
-        TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } ->
-          [(exp,act)]
-        CouldNotDeduce {} ->
-          []
-    _ -> []
diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Errors/Hole.hs
+++ /dev/null
@@ -1,1015 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ExistentialQuantification #-}
-
-module GHC.Tc.Errors.Hole
-   ( findValidHoleFits
-   , tcCheckHoleFit
-   , withoutUnification
-   , tcSubsumes
-   , isFlexiTyVar
-   , tcFilterHoleFits
-   , getLocalBindings
-   , pprHoleFit
-   , addHoleFitDocs
-   , getHoleFitSortingAlg
-   , getHoleFitDispConfig
-   , HoleFitDispConfig (..)
-   , HoleFitSortingAlg (..)
-   , relevantCtEvidence
-   , zonkSubs
-
-   , sortHoleFitsByGraph
-   , sortHoleFitsBySize
-
-
-   -- Re-exported from GHC.Tc.Errors.Hole.FitTypes
-   , HoleFitPlugin (..), HoleFitPluginR (..)
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Tc.Errors.Types ( HoleFitDispConfig(..), FitsMbSuppressed(..)
-                           , ValidHoleFits(..), noValidHoleFits )
-import GHC.Tc.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Utils.TcType
-import GHC.Core.Type
-import GHC.Core.DataCon
-import GHC.Types.Name
-import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..)
-                             , globalRdrEnvElts, greMangledName, grePrintableName )
-import GHC.Builtin.Names ( gHC_ERR )
-import GHC.Types.Id
-import GHC.Types.Var.Set
-import GHC.Types.Var.Env
-import GHC.Types.TyThing
-import GHC.Data.Bag
-import GHC.Core.ConLike ( ConLike(..) )
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Tc.Utils.Env (tcLookup)
-import GHC.Utils.Outputable
-import GHC.Driver.Session
-import GHC.Data.Maybe
-import GHC.Utils.FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV )
-
-import Control.Arrow ( (&&&) )
-
-import Control.Monad    ( filterM, replicateM, foldM )
-import Data.List        ( partition, sort, sortOn, nubBy )
-import Data.Graph       ( graphFromEdges, topSort )
-
-
-import GHC.Tc.Solver    ( simplifyTopWanteds )
-import GHC.Tc.Solver.Monad ( runTcSEarlyAbort )
-import GHC.Tc.Utils.Unify ( tcSubTypeSigma )
-
-import GHC.HsToCore.Docs ( extractDocs )
-import GHC.Hs.Doc
-import GHC.Unit.Module.ModIface ( ModIface_(..) )
-import GHC.Iface.Load  ( loadInterfaceForName )
-
-import GHC.Builtin.Utils (knownKeyNames)
-
-import GHC.Tc.Errors.Hole.FitTypes
-import qualified Data.Set as Set
-import GHC.Types.SrcLoc
-import GHC.Data.FastString (NonDetFastString(..))
-import GHC.Types.Unique.Map
-
-
-{-
-Note [Valid hole fits include ...]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-`findValidHoleFits` returns the "Valid hole fits include ..." message.
-For example, look at the following definitions in a file called test.hs:
-
-   import Data.List (inits)
-
-   f :: [String]
-   f = _ "hello, world"
-
-The hole in `f` would generate the message:
-
-  • Found hole: _ :: [Char] -> [String]
-  • In the expression: _
-    In the expression: _ "hello, world"
-    In an equation for ‘f’: f = _ "hello, world"
-  • Relevant bindings include f :: [String] (bound at test.hs:6:1)
-    Valid hole fits include
-      lines :: String -> [String]
-        (imported from ‘Prelude’ at mpt.hs:3:8-9
-          (and originally defined in ‘base-4.11.0.0:Data.OldList’))
-      words :: String -> [String]
-        (imported from ‘Prelude’ at mpt.hs:3:8-9
-          (and originally defined in ‘base-4.11.0.0:Data.OldList’))
-      inits :: forall a. [a] -> [[a]]
-        with inits @Char
-        (imported from ‘Data.List’ at mpt.hs:4:19-23
-          (and originally defined in ‘base-4.11.0.0:Data.OldList’))
-      repeat :: forall a. a -> [a]
-        with repeat @String
-        (imported from ‘Prelude’ at mpt.hs:3:8-9
-          (and originally defined in ‘GHC.List’))
-      fail :: forall (m :: * -> *). Monad m => forall a. String -> m a
-        with fail @[] @String
-        (imported from ‘Prelude’ at mpt.hs:3:8-9
-          (and originally defined in ‘GHC.Base’))
-      return :: forall (m :: * -> *). Monad m => forall a. a -> m a
-        with return @[] @String
-        (imported from ‘Prelude’ at mpt.hs:3:8-9
-          (and originally defined in ‘GHC.Base’))
-      pure :: forall (f :: * -> *). Applicative f => forall a. a -> f a
-        with pure @[] @String
-        (imported from ‘Prelude’ at mpt.hs:3:8-9
-          (and originally defined in ‘GHC.Base’))
-      read :: forall a. Read a => String -> a
-        with read @[String]
-        (imported from ‘Prelude’ at mpt.hs:3:8-9
-          (and originally defined in ‘Text.Read’))
-      mempty :: forall a. Monoid a => a
-        with mempty @([Char] -> [String])
-        (imported from ‘Prelude’ at mpt.hs:3:8-9
-          (and originally defined in ‘GHC.Base’))
-
-Valid hole fits are found by checking top level identifiers and local bindings
-in scope for whether their type can be instantiated to the type of the hole.
-Additionally, we also need to check whether all relevant constraints are solved
-by choosing an identifier of that type as well, see Note [Relevant constraints]
-
-Since checking for subsumption results in the side-effect of type variables
-being unified by the simplifier, we need to take care to restore them after
-to being flexible type variables after we've checked for subsumption.
-This is to avoid affecting the hole and later checks by prematurely having
-unified one of the free unification variables.
-
-When outputting, we sort the hole fits by the size of the types we'd need to
-apply by type application to the type of the fit to make it fit. This is done
-in order to display "more relevant" suggestions first. Another option is to
-sort by building a subsumption graph of fits, i.e. a graph of which fits subsume
-what other fits, and then outputting those fits which are subsumed by other
-fits (i.e. those more specific than other fits) first. This results in the ones
-"closest" to the type of the hole to be displayed first.
-
-To help users understand how the suggested fit works, we also display the values
-that the quantified type variables would take if that fit is used, like
-`mempty @([Char] -> [String])` and `pure @[] @String` in the example above.
-If -XTypeApplications is enabled, this can even be copied verbatim as a
-replacement for the hole.
-
-Note [Checking hole fits]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-If we have a hole of type hole_ty, we want to know whether a variable
-of type ty is a valid fit for the whole. This is a subsumption check:
-we wish to know whether ty <: hole_ty. But, of course, the check
-must take into account any givens and relevant constraints.
-(See also Note [Relevant constraints]).
-
-For the simplifier to be able to use any givens present in the enclosing
-implications to solve relevant constraints, we nest the wanted subsumption
-constraints and relevant constraints within the enclosing implications.
-
-As an example, let's look at the following code:
-
-  f :: Show a => a -> String
-  f x = show _
-
-Suppose the hole is assigned type a0_a1pd[tau:2].
-Here the nested implications are just one level deep, namely:
-
-  [Implic {
-      TcLevel = 2
-      Skolems = a_a1pa[sk:2]
-      No-eqs = True
-      Status = Unsolved
-      Given = $dShow_a1pc :: Show a_a1pa[sk:2]
-      Wanted =
-        WC {wc_simple =
-              [W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CDictCan(psc))}
-      Binds = EvBindsVar<a1pi>
-      Needed inner = []
-      Needed outer = []
-      the type signature for:
-        f :: forall a. Show a => a -> String }]
-
-As we can see, the givens say that the skolem
-`a_a1pa[sk:2]` fulfills the Show constraint, and that we must prove
-the [W] Show a0_a1pd[tau:2] constraint -- that is, whatever fills the
-hole must have a Show instance.
-
-When we now check whether `x :: a_a1pa[sk:2]` fits the hole in
-`tcCheckHoleFit`, the call to `tcSubType` will end up unifying the meta type
-variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted constraints
-needed by tcSubType_NC and the relevant constraints (see Note [Relevant
-constraints] for more details) in the nested implications, we can pass the
-information in the givens along to the simplifier. For our example, we end up
-needing to check whether the following constraints are soluble.
-
-  WC {wc_impl =
-        Implic {
-          TcLevel = 2
-          Skolems = a_a1pa[sk:2]
-          No-eqs = True
-          Status = Unsolved
-          Given = $dShow_a1pc :: Show a_a1pa[sk:2]
-          Wanted =
-            WC {wc_simple =
-                  [W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)}
-          Binds = EvBindsVar<a1pl>
-          Needed inner = []
-          Needed outer = []
-          the type signature for:
-            f :: forall a. Show a => a -> String }}
-
-But since `a0_a1pd[tau:2] := a_a1pa[sk:2]` and we have from the nested
-implications that Show a_a1pa[sk:2] is a given, this is trivial, and we end up
-with a final WC of WC {}, confirming x :: a0_a1pd[tau:2] as a match.
-
-To avoid side-effects on the nested implications, we create a new EvBindsVar so
-that any changes to the ev binds during a check remains localised to that check.
-In addition, we call withoutUnification to reset any unified metavariables; this
-call is actually done outside tcCheckHoleFit so that the results can be formatted
-for the user before resetting variables.
-
-Note [Valid refinement hole fits include ...]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When the `-frefinement-level-hole-fits=N` flag is given, we additionally look
-for "valid refinement hole fits"", i.e. valid hole fits with up to N
-additional holes in them.
-
-With `-frefinement-level-hole-fits=0` (the default), GHC will find all
-identifiers 'f' (top-level or nested) that will fit in the hole.
-
-With `-frefinement-level-hole-fits=1`, GHC will additionally find all
-applications 'f _' that will fit in the hole, where 'f' is an in-scope
-identifier, applied to single argument.  It will also report the type of the
-needed argument (a new hole).
-
-And similarly as the number of arguments increases
-
-As an example, let's look at the following code:
-
-  f :: [Integer] -> Integer
-  f = _
-
-with `-frefinement-level-hole-fits=1`, we'd get:
-
-  Valid refinement hole fits include
-
-    foldl1 (_ :: Integer -> Integer -> Integer)
-      with foldl1 @[] @Integer
-      where foldl1 :: forall (t :: * -> *).
-                      Foldable t =>
-                      forall a. (a -> a -> a) -> t a -> a
-    foldr1 (_ :: Integer -> Integer -> Integer)
-      with foldr1 @[] @Integer
-      where foldr1 :: forall (t :: * -> *).
-                      Foldable t =>
-                      forall a. (a -> a -> a) -> t a -> a
-    const (_ :: Integer)
-      with const @Integer @[Integer]
-      where const :: forall a b. a -> b -> a
-    ($) (_ :: [Integer] -> Integer)
-      with ($) @'GHC.Types.LiftedRep @[Integer] @Integer
-      where ($) :: forall a b. (a -> b) -> a -> b
-    fail (_ :: String)
-      with fail @((->) [Integer]) @Integer
-      where fail :: forall (m :: * -> *).
-                    Monad m =>
-                    forall a. String -> m a
-    return (_ :: Integer)
-      with return @((->) [Integer]) @Integer
-      where return :: forall (m :: * -> *). Monad m => forall a. a -> m a
-    (Some refinement hole fits suppressed;
-      use -fmax-refinement-hole-fits=N or -fno-max-refinement-hole-fits)
-
-Which are hole fits with holes in them. This allows e.g. beginners to
-discover the fold functions and similar, but also allows for advanced users
-to figure out the valid functions in the Free monad, e.g.
-
-  instance Functor f => Monad (Free f) where
-      Pure a >>= f = f a
-      Free f >>= g = Free (fmap _a f)
-
-Will output (with -frefinment-level-hole-fits=1):
-    Found hole: _a :: Free f a -> Free f b
-          Where: ‘a’, ‘b’ are rigid type variables bound by
-                  the type signature for:
-                    (>>=) :: forall a b. Free f a -> (a -> Free f b) -> Free f b
-                  at fms.hs:25:12-14
-                ‘f’ is a rigid type variable bound by
-    ...
-    Relevant bindings include
-      g :: a -> Free f b (bound at fms.hs:27:16)
-      f :: f (Free f a) (bound at fms.hs:27:10)
-      (>>=) :: Free f a -> (a -> Free f b) -> Free f b
-        (bound at fms.hs:25:12)
-    ...
-    Valid refinement hole fits include
-      ...
-      (=<<) (_ :: a -> Free f b)
-        with (=<<) @(Free f) @a @b
-        where (=<<) :: forall (m :: * -> *) a b.
-                      Monad m =>
-                      (a -> m b) -> m a -> m b
-        (imported from ‘Prelude’ at fms.hs:5:18-22
-        (and originally defined in ‘GHC.Base’))
-      ...
-
-Where `(=<<) _` is precisely the function we want (we ultimately want `>>= g`).
-
-We find these refinement suggestions by considering hole fits that don't
-fit the type of the hole, but ones that would fit if given an additional
-argument. We do this by creating a new type variable with `newOpenFlexiTyVar`
-(e.g. `t_a1/m[tau:1]`), and then considering hole fits of the type
-`t_a1/m[tau:1] -> v` where `v` is the type of the hole.
-
-Since the simplifier is free to unify this new type variable with any type, we
-can discover any identifiers that would fit if given another identifier of a
-suitable type. This is then generalized so that we can consider any number of
-additional arguments by setting the `-frefinement-level-hole-fits` flag to any
-number, and then considering hole fits like e.g. `foldl _ _` with two additional
-arguments.
-
-To make sure that the refinement hole fits are useful, we check that the types
-of the additional holes have a concrete value and not just an invented type
-variable. This eliminates suggestions such as `head (_ :: [t0 -> a]) (_ :: t0)`,
-and limits the number of less than useful refinement hole fits.
-
-Additionally, to further aid the user in their implementation, we show the
-types of the holes the binding would have to be applied to in order to work.
-In the free monad example above, this is demonstrated with
-`(=<<) (_ :: a -> Free f b)`, which tells the user that the `(=<<)` needs to
-be applied to an expression of type `a -> Free f b` in order to match.
-If -XScopedTypeVariables is enabled, this hole fit can even be copied verbatim.
-
-Note [Relevant constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As highlighted by #14273, we need to check any relevant constraints as well
-as checking for subsumption. Relevant constraints are the simple constraints
-whose free unification variables are mentioned in the type of the hole.
-
-In the simplest case, these are all non-hole constraints in the simples, such
-as is the case in
-
-  f :: String
-  f = show _
-
-Here, the hole is given type a0_a1kv[tau:1]. Then, the emitted constraint is:
-
-  [W] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)
-
-However, when there are multiple holes, we need to be more careful. As an
-example, Let's take a look at the following code:
-
-  f :: Show a => a -> String
-  f x = show (_b (show _a))
-
-Here there are two holes, `_a` and `_b`. Suppose _a :: a0_a1pd[tau:2] and
-_b :: a1_a1po[tau:2]. Then, the simple constraints passed to
-findValidHoleFits are:
-
-  [[W] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical),
-    [W] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)]
-
-When we are looking for a match for the hole `_a`, we filter the simple
-constraints to the "Relevant constraints", by throwing out any constraints
-which do not mention a variable mentioned in the type of the hole. For hole
-`_a`, we will then only require that the `$dShow_a1pe` constraint is solved,
-since that is the only constraint that mentions any free type variables
-mentioned in the hole constraint for `_a`, namely `a_a1pd[tau:2]`, and
-similarly for the hole `_b` we only require that the `$dShow_a1pe` constraint
-is solved.
-
-Note [Leaking errors]
-~~~~~~~~~~~~~~~~~~~~~
-When considering candidates, GHC believes that we're checking for validity in
-actual source. However, As evidenced by #15321, #15007 and #15202, this can
-cause bewildering error messages. The solution here is simple: if a candidate
-would cause the type checker to error, it is not a valid hole fit, and thus it
-is discarded.
-
-Note [Speeding up valid hole-fits]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-To fix #16875 we noted that a lot of time was being spent on unecessary work.
-
-When we'd call `tcCheckHoleFit hole hole_ty ty`, we would end up by generating
-a constraint to show that `hole_ty ~ ty`, including any constraints in `ty`. For
-example, if `hole_ty = Int` and `ty = Foldable t => (a -> Bool) -> t a -> Bool`,
-we'd have `(a_a1pa[sk:1] -> Bool) -> t_t2jk[sk:1] a_a1pa[sk:1] -> Bool ~# Int`
-from the coercion, as well as `Foldable t_t2jk[sk:1]`. By adding a flag to
-`TcSEnv` and adding a `runTcSEarlyAbort`, we can fail as soon as we hit
-an insoluble constraint. Since we don't need the result in the case that it
-fails, a boolean `False` (i.e. "it didn't work" from `runTcSEarlyAbort`)
-is sufficient.
-
-We also check whether the type of the hole is an immutable type variable (i.e.
-a skolem). In that case, the only possible fits are fits of exactly that type,
-which can only come from the locals. This speeds things up quite a bit when we
-don't know anything about the type of the hole. This also helps with degenerate
-fits like (`id (_ :: a)` and `head (_ :: [a])`) when looking for fits of type
-`a`, where `a` is a skolem.
--}
-
--- We read the various -no-show-*-of-hole-fits flags
--- and set the display config accordingly.
-getHoleFitDispConfig :: TcM HoleFitDispConfig
-getHoleFitDispConfig
-  = do { sWrap <- goptM Opt_ShowTypeAppOfHoleFits
-       ; sWrapVars <- goptM Opt_ShowTypeAppVarsOfHoleFits
-       ; sType <- goptM Opt_ShowTypeOfHoleFits
-       ; sProv <- goptM Opt_ShowProvOfHoleFits
-       ; sMatc <- goptM Opt_ShowMatchesOfHoleFits
-       ; return HFDC{ showWrap = sWrap, showWrapVars = sWrapVars
-                    , showProv = sProv, showType = sType
-                    , showMatches = sMatc } }
-
--- Which sorting algorithm to use
-data HoleFitSortingAlg = HFSNoSorting      -- Do not sort the fits at all
-                       | HFSBySize         -- Sort them by the size of the match
-                       | HFSBySubsumption  -- Sort by full subsumption
-                deriving (Eq, Ord)
-
-getHoleFitSortingAlg :: TcM HoleFitSortingAlg
-getHoleFitSortingAlg =
-    do { shouldSort <- goptM Opt_SortValidHoleFits
-       ; subsumSort <- goptM Opt_SortBySubsumHoleFits
-       ; sizeSort <- goptM Opt_SortBySizeHoleFits
-       -- We default to sizeSort unless it has been explicitly turned off
-       -- or subsumption sorting has been turned on.
-       ; return $ if not shouldSort
-                    then HFSNoSorting
-                    else if subsumSort
-                         then HFSBySubsumption
-                         else if sizeSort
-                              then HFSBySize
-                              else HFSNoSorting }
-
--- If enabled, we go through the fits and add any associated documentation,
--- by looking it up in the module or the environment (for local fits)
-addHoleFitDocs :: [HoleFit] -> TcM [HoleFit]
-addHoleFitDocs fits =
-  do { showDocs <- goptM Opt_ShowDocsOfHoleFits
-     ; if showDocs
-       then do { dflags <- getDynFlags
-               ; mb_local_docs <- extractDocs dflags =<< getGblEnv
-               ; (mods_without_docs, fits') <- mapAccumLM (upd mb_local_docs) Set.empty fits
-               ; report mods_without_docs
-               ; return fits' }
-       else return fits }
-  where
-   msg = text "GHC.Tc.Errors.Hole addHoleFitDocs"
-   upd mb_local_docs mods_without_docs fit@(HoleFit {hfCand = cand}) =
-     let name = getName cand in
-     do { mb_docs <- if hfIsLcl fit
-                     then pure mb_local_docs
-                     else mi_docs <$> loadInterfaceForName msg name
-        ; case mb_docs of
-            { Nothing -> return (Set.insert (nameOrigin name) mods_without_docs, fit)
-            ; Just docs -> do
-                { let doc = lookupUniqMap (docs_decls docs) name
-                ; return $ (mods_without_docs, fit {hfDoc = map hsDocString <$> doc}) }}}
-   upd _ mods_without_docs fit = pure (mods_without_docs, fit)
-   nameOrigin name = case nameModule_maybe name of
-     Just m  -> Right m
-     Nothing ->
-       Left $ case nameSrcLoc name of
-         -- Nondeterminism is fine, this is used only to display a warning
-         RealSrcLoc r _ -> NonDetFastString $ srcLocFile r
-         UnhelpfulLoc s -> NonDetFastString s
-   report mods = do
-     { let warning =
-             text "WARNING: Couldn't find any documentation for the following modules:" $+$
-             nest 2
-                  (pprWithCommas (either ppr ppr) (Set.toList mods) $+$
-                   text "Make sure the modules are compiled with '-haddock'.")
-     ; warnPprTrace (not $ Set.null mods) "addHoleFitDocs" warning (pure ())
-     }
-
--- For pretty printing hole fits, we display the name and type of the fit,
--- with added '_' to represent any extra arguments in case of a non-zero
--- refinement level.
-pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc
-pprHoleFit _ (RawHoleFit sd) = sd
-pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) =
- hang display 2 provenance
- where tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap
-         where pprArg b arg = case binderFlag b of
-                                Specified -> text "@" <> pprParendType arg
-                                  -- Do not print type application for inferred
-                                  -- variables (#16456)
-                                Inferred  -> empty
-                                Required  -> pprPanic "pprHoleFit: bad Required"
-                                                         (ppr b <+> ppr arg)
-       tyAppVars = sep $ punctuate comma $
-           zipWithEqual "pprHoleFit" (\v t -> ppr (binderVar v) <+>
-                                               text "~" <+> pprParendType t)
-           vars hfWrap
-
-       vars = unwrapTypeVars hfType
-         where
-           -- Attempts to get all the quantified type variables in a type,
-           -- e.g.
-           -- return :: forall (m :: * -> *) Monad m => (forall a . a -> m a)
-           -- into [m, a]
-           unwrapTypeVars :: Type -> [ForAllTyBinder]
-           unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of
-                               Just (_, _, _, unfunned) -> unwrapTypeVars unfunned
-                               _ -> []
-             where (vars, unforalled) = splitForAllForAllTyBinders t
-       holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches
-       holeDisp = if sMs then holeVs
-                  else sep $ replicate (length hfMatches) $ text "_"
-       occDisp = case hfCand of
-                   GreHFCand gre   -> pprPrefixOcc (grePrintableName gre)
-                   NameHFCand name -> pprPrefixOcc name
-                   IdHFCand id_    -> pprPrefixOcc id_
-       tyDisp = ppWhen sTy $ dcolon <+> ppr hfType
-       has = not . null
-       wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars))
-                   $ text "with" <+> if sWrp || not sTy
-                                     then occDisp <+> tyApp
-                                     else tyAppVars
-       docs = case hfDoc of
-                Just d -> pprHsDocStrings d
-                _ -> empty
-       funcInfo = ppWhen (has hfMatches && sTy) $
-                    text "where" <+> occDisp <+> tyDisp
-       subDisp = occDisp <+> if has hfMatches then holeDisp else tyDisp
-       display =  subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp)
-       provenance = ppWhen sProv $ parens $
-             case hfCand of
-                 GreHFCand gre -> pprNameProvenance gre
-                 NameHFCand name -> text "bound at" <+> ppr (getSrcLoc name)
-                 IdHFCand id_ -> text "bound at" <+> ppr (getSrcLoc id_)
-
-getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id]
-getLocalBindings tidy_orig ct_loc
- = do { (env1, _) <- zonkTidyOrigin tidy_orig (ctLocOrigin ct_loc)
-      ; go env1 [] (removeBindingShadowing $ tcl_bndrs lcl_env) }
-  where
-    lcl_env = ctLocEnv ct_loc
-
-    go :: TidyEnv -> [Id] -> [TcBinder] -> TcM [Id]
-    go _ sofar [] = return (reverse sofar)
-    go env sofar (tc_bndr : tc_bndrs) =
-        case tc_bndr of
-          TcIdBndr id _ -> keep_it id
-          _ -> discard_it
-     where
-        discard_it = go env sofar tc_bndrs
-        keep_it id = go env (id:sofar) tc_bndrs
-
-
-
--- See Note [Valid hole fits include ...]
-findValidHoleFits :: TidyEnv        -- ^ The tidy_env for zonking
-                  -> [Implication]  -- ^ Enclosing implications for givens
-                  -> [CtEvidence]
-                  -- ^ The  unsolved simple constraints in the implication for
-                  -- the hole.
-                  -> Hole
-                  -> TcM (TidyEnv, ValidHoleFits)
-findValidHoleFits tidy_env implics simples h@(Hole { hole_sort = ExprHole _
-                                                   , hole_loc  = ct_loc
-                                                   , hole_ty   = hole_ty }) =
-  do { rdr_env <- getGlobalRdrEnv
-     ; lclBinds <- getLocalBindings tidy_env ct_loc
-     ; maxVSubs <- maxValidHoleFits <$> getDynFlags
-     ; sortingAlg <- getHoleFitSortingAlg
-     ; dflags <- getDynFlags
-     ; hfPlugs <- tcg_hf_plugins <$> getGblEnv
-     ; let findVLimit = if sortingAlg > HFSNoSorting then Nothing else maxVSubs
-           refLevel = refLevelHoleFits dflags
-           hole = TypedHole { th_relevant_cts =
-                                listToBag (relevantCtEvidence hole_ty simples)
-                            , th_implics      = implics
-                            , th_hole         = Just h }
-           (candidatePlugins, fitPlugins) =
-             unzip $ map (\p-> ((candPlugin p) hole, (fitPlugin p) hole)) hfPlugs
-     ; traceTc "findingValidHoleFitsFor { " $ ppr hole
-     ; traceTc "hole_lvl is:" $ ppr hole_lvl
-     ; traceTc "simples are: " $ ppr simples
-     ; traceTc "locals are: " $ ppr lclBinds
-     ; let (lcl, gbl) = partition gre_lcl (globalRdrEnvElts rdr_env)
-           -- We remove binding shadowings here, but only for the local level.
-           -- this is so we e.g. suggest the global fmap from the Functor class
-           -- even though there is a local definition as well, such as in the
-           -- Free monad example.
-           locals = removeBindingShadowing $
-                      map IdHFCand lclBinds ++ map GreHFCand lcl
-           globals = map GreHFCand gbl
-           syntax = map NameHFCand builtIns
-           -- If the hole is a rigid type-variable, then we only check the
-           -- locals, since only they can match the type (in a meaningful way).
-           only_locals = any isImmutableTyVar $ getTyVar_maybe hole_ty
-           to_check = if only_locals then locals
-                      else locals ++ syntax ++ globals
-     ; cands <- foldM (flip ($)) to_check candidatePlugins
-     ; traceTc "numPlugins are:" $ ppr (length candidatePlugins)
-     ; (searchDiscards, subs) <-
-        tcFilterHoleFits findVLimit hole (hole_ty, []) cands
-     ; (tidy_env, tidy_subs) <- zonkSubs tidy_env subs
-     ; tidy_sorted_subs <- sortFits sortingAlg tidy_subs
-     ; plugin_handled_subs <- foldM (flip ($)) tidy_sorted_subs fitPlugins
-     ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs plugin_handled_subs
-           vDiscards = pVDisc || searchDiscards
-     ; subs_with_docs <- addHoleFitDocs limited_subs
-     ; let subs = Fits subs_with_docs vDiscards
-     -- Refinement hole fits. See Note [Valid refinement hole fits include ...]
-     ; (tidy_env, rsubs) <-
-       if refLevel >= Just 0
-       then
-         do { maxRSubs <- maxRefHoleFits <$> getDynFlags
-            -- We can use from just, since we know that Nothing >= _ is False.
-            ; let refLvls = [1..(fromJust refLevel)]
-            -- We make a new refinement type for each level of refinement, where
-            -- the level of refinement indicates number of additional arguments
-            -- to allow.
-            ; ref_tys <- mapM mkRefTy refLvls
-            ; traceTc "ref_tys are" $ ppr ref_tys
-            ; let findRLimit = if sortingAlg > HFSNoSorting then Nothing
-                                                            else maxRSubs
-            ; refDs <- mapM (flip (tcFilterHoleFits findRLimit hole)
-                              cands) ref_tys
-            ; (tidy_env, tidy_rsubs) <- zonkSubs tidy_env $ concatMap snd refDs
-            ; tidy_sorted_rsubs <- sortFits sortingAlg tidy_rsubs
-            -- For refinement substitutions we want matches
-            -- like id (_ :: t), head (_ :: [t]), asTypeOf (_ :: t),
-            -- and others in that vein to appear last, since these are
-            -- unlikely to be the most relevant fits.
-            ; (tidy_env, tidy_hole_ty) <- zonkTidyTcType tidy_env hole_ty
-            ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap
-                  (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs
-            ; plugin_handled_rsubs <- foldM (flip ($))
-                                        (not_exact ++ exact) fitPlugins
-            ; let (pRDisc, exact_last_rfits) =
-                    possiblyDiscard maxRSubs $ plugin_handled_rsubs
-                  rDiscards = pRDisc || any fst refDs
-            ; rsubs_with_docs <- addHoleFitDocs exact_last_rfits
-            ; return (tidy_env, Fits rsubs_with_docs rDiscards) }
-       else return (tidy_env, Fits [] False)
-     ; traceTc "findingValidHoleFitsFor }" empty
-     ; let hole_fits = ValidHoleFits subs rsubs
-     ; return (tidy_env, hole_fits) }
-  where
-    -- We extract the TcLevel from the constraint.
-    hole_lvl = ctLocLevel ct_loc
-
-    -- BuiltInSyntax names like (:) and []
-    builtIns :: [Name]
-    builtIns = filter isBuiltInSyntax knownKeyNames
-
-    -- We make a refinement type by adding a new type variable in front
-    -- of the type of t h hole, going from e.g. [Integer] -> Integer
-    -- to t_a1/m[tau:1] -> [Integer] -> Integer. This allows the simplifier
-    -- to unify the new type variable with any type, allowing us
-    -- to suggest a "refinement hole fit", like `(foldl1 _)` instead
-    -- of only concrete hole fits like `sum`.
-    mkRefTy :: Int -> TcM (TcType, [TcTyVar])
-    mkRefTy refLvl = (wrapWithVars &&& id) <$> newTyVars
-      where newTyVars = replicateM refLvl $ setLvl <$> newOpenFlexiTyVar
-            setLvl = flip setMetaTyVarTcLevel hole_lvl
-            wrapWithVars vars = mkVisFunTysMany (map mkTyVarTy vars) hole_ty
-
-    sortFits :: HoleFitSortingAlg    -- How we should sort the hole fits
-             -> [HoleFit]     -- The subs to sort
-             -> TcM [HoleFit]
-    sortFits HFSNoSorting subs = return subs
-    sortFits HFSBySize subs
-        = (++) <$> sortHoleFitsBySize (sort lclFits)
-               <*> sortHoleFitsBySize (sort gblFits)
-        where (lclFits, gblFits) = span hfIsLcl subs
-    -- To sort by subsumption, we invoke the sortByGraph function, which
-    -- builds the subsumption graph for the fits and then sorts them using a
-    -- graph sort.  Since we want locals to come first anyway, we can sort
-    -- them separately. The substitutions are already checked in local then
-    -- global order, so we can get away with using span here.
-    -- We use (<*>) to expose the parallelism, in case it becomes useful later.
-    sortFits HFSBySubsumption subs
-        = (++) <$> sortHoleFitsByGraph (sort lclFits)
-               <*> sortHoleFitsByGraph (sort gblFits)
-        where (lclFits, gblFits) = span hfIsLcl subs
-
-    -- Based on the flags, we might possibly discard some or all the
-    -- fits we've found.
-    possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit])
-    possiblyDiscard (Just max) fits = (fits `lengthExceeds` max, take max fits)
-    possiblyDiscard Nothing fits = (False, fits)
-
-
--- We don't (as of yet) handle holes in types, only in expressions.
-findValidHoleFits env _ _ _ = return (env, noValidHoleFits)
-
--- See Note [Relevant constraints]
-relevantCtEvidence :: Type -> [CtEvidence] -> [CtEvidence]
-relevantCtEvidence hole_ty simples
-  = if isEmptyVarSet (fvVarSet hole_fvs)
-    then []
-    else filter isRelevant simples
-  where hole_fvs = tyCoFVsOfType hole_ty
-        hole_fv_set = fvVarSet hole_fvs
-        -- We filter out those constraints that have no variables (since
-        -- they won't be solved by finding a type for the type variable
-        -- representing the hole) and also other holes, since we're not
-        -- trying to find hole fits for many holes at once.
-        isRelevant ctev = not (isEmptyVarSet fvs) &&
-                          (fvs `intersectsVarSet` hole_fv_set)
-          where fvs = tyCoVarsOfCtEv ctev
-
--- We zonk the hole fits so that the output aligns with the rest
--- of the typed hole error message output.
-zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])
-zonkSubs = zonkSubs' []
-  where zonkSubs' zs env [] = return (env, reverse zs)
-        zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf
-                                        ; zonkSubs' (z:zs) env' hfs }
-
-        zonkSub :: TidyEnv -> HoleFit -> TcM (TidyEnv, HoleFit)
-        zonkSub env hf@RawHoleFit{} = return (env, hf)
-        zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp}
-            = do { (env, ty') <- zonkTidyTcType env ty
-                ; (env, m') <- zonkTidyTcTypes env m
-                ; (env, wrp') <- zonkTidyTcTypes env wrp
-                ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'}
-                ; return (env, zFit ) }
-
--- | Sort by size uses as a measure for relevance the sizes of the different
--- types needed to instantiate the fit to the type of the hole.
--- This is much quicker than sorting by subsumption, and gives reasonable
--- results in most cases.
-sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit]
-sortHoleFitsBySize = return . sortOn sizeOfFit
-  where sizeOfFit :: HoleFit -> TypeSize
-        sizeOfFit = sizeTypes . nubBy tcEqType .  hfWrap
-
--- Based on a suggestion by phadej on #ghc, we can sort the found fits
--- by constructing a subsumption graph, and then do a topological sort of
--- the graph. This makes the most specific types appear first, which are
--- probably those most relevant. This takes a lot of work (but results in
--- much more useful output), and can be disabled by
--- '-fno-sort-valid-hole-fits'.
-sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit]
-sortHoleFitsByGraph fits = go [] fits
-  where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool
-        tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty)
-          where fvs = tyCoFVsOfTypes [ht,ty]
-        go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit]
-        go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar
-                         ; return $ uncurry (++) $ partition hfIsLcl topSorted }
-          where toV (hf, adjs) = (hf, hfId hf, map hfId adjs)
-                (graph, fromV, _) = graphFromEdges $ map toV sofar
-                topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph
-        go sofar (hf:hfs) =
-          do { adjs <- filterM (tcSubsumesWCloning (hfType hf) . hfType) fits
-             ; go ((hf, adjs):sofar) hfs }
-
--- | tcFilterHoleFits filters the candidates by whether, given the implications
--- and the relevant constraints, they can be made to match the type by
--- running the type checker. Stops after finding limit matches.
-tcFilterHoleFits :: Maybe Int
-               -- ^ How many we should output, if limited
-               -> TypedHole -- ^ The hole to filter against
-               -> (TcType, [TcTyVar])
-               -- ^ The type to check for fits and a list of refinement
-               -- variables (free type variables in the type) for emulating
-               -- additional holes.
-               -> [HoleFitCandidate]
-               -- ^ The candidates to check whether fit.
-               -> TcM (Bool, [HoleFit])
-               -- ^ We return whether or not we stopped due to hitting the limit
-               -- and the fits we found.
-tcFilterHoleFits (Just 0) _ _ _ = return (False, []) -- Stop right away on 0
-tcFilterHoleFits limit typed_hole ht@(hole_ty, _) candidates =
-  do { traceTc "checkingFitsFor {" $ ppr hole_ty
-     ; (discards, subs) <- go [] emptyVarSet limit ht candidates
-     ; traceTc "checkingFitsFor }" empty
-     ; return (discards, subs) }
-  where
-    hole_fvs :: FV
-    hole_fvs = tyCoFVsOfType hole_ty
-    -- Kickoff the checking of the elements.
-    -- We iterate over the elements, checking each one in turn for whether
-    -- it fits, and adding it to the results if it does.
-    go :: [HoleFit]           -- What we've found so far.
-       -> VarSet              -- Ids we've already checked
-       -> Maybe Int           -- How many we're allowed to find, if limited
-       -> (TcType, [TcTyVar]) -- The type, and its refinement variables.
-       -> [HoleFitCandidate]  -- The elements we've yet to check.
-       -> TcM (Bool, [HoleFit])
-    go subs _ _ _ [] = return (False, reverse subs)
-    go subs _ (Just 0) _ _ = return (True, reverse subs)
-    go subs seen maxleft ty (el:elts) =
-        -- See Note [Leaking errors]
-        tryTcDiscardingErrs discard_it $
-        do { traceTc "lookingUp" $ ppr el
-           ; maybeThing <- lookup el
-           ; case maybeThing of
-               Just (id, id_ty) | not_trivial id ->
-                       do { fits <- fitsHole ty id_ty
-                          ; case fits of
-                              Just (wrp, matches) -> keep_it id id_ty wrp matches
-                              _ -> discard_it }
-               _ -> discard_it }
-        where
-          -- We want to filter out undefined and the likes from GHC.Err
-          not_trivial id = nameModule_maybe (idName id) /= Just gHC_ERR
-
-          lookup :: HoleFitCandidate -> TcM (Maybe (Id, Type))
-          lookup (IdHFCand id) = return (Just (id, idType id))
-          lookup hfc = do { thing <- tcLookup name
-                          ; return $ case thing of
-                                       ATcId {tct_id = id} -> Just (id, idType id)
-                                       AGlobal (AnId id)   -> Just (id, idType id)
-                                       AGlobal (AConLike (RealDataCon con)) ->
-                                           Just (dataConWrapId con, dataConNonlinearType con)
-                                       _ -> Nothing }
-            where name = case hfc of
-#if __GLASGOW_HASKELL__ < 901
-                           IdHFCand id -> idName id
-#endif
-                           GreHFCand gre -> greMangledName gre
-                           NameHFCand name -> name
-          discard_it = go subs seen maxleft ty elts
-          keep_it eid eid_ty wrp ms = go (fit:subs) (extendVarSet seen eid)
-                                 ((\n -> n - 1) <$> maxleft) ty elts
-            where
-              fit = HoleFit { hfId = eid, hfCand = el, hfType = eid_ty
-                            , hfRefLvl = length (snd ty)
-                            , hfWrap = wrp, hfMatches = ms
-                            , hfDoc = Nothing }
-
-
-
-
-    unfoldWrapper :: HsWrapper -> [Type]
-    unfoldWrapper = reverse . unfWrp'
-      where unfWrp' (WpTyApp ty) = [ty]
-            unfWrp' (WpCompose w1 w2) = unfWrp' w1 ++ unfWrp' w2
-            unfWrp' _ = []
-
-
-    -- The real work happens here, where we invoke the type checker using
-    -- tcCheckHoleFit to see whether the given type fits the hole.
-    fitsHole :: (TcType, [TcTyVar]) -- The type of the hole wrapped with the
-                                    -- refinement variables created to simulate
-                                    -- additional holes (if any), and the list
-                                    -- of those variables (possibly empty).
-                                    -- As an example: If the actual type of the
-                                    -- hole (as specified by the hole
-                                    -- constraint CHoleExpr passed to
-                                    -- findValidHoleFits) is t and we want to
-                                    -- simulate N additional holes, h_ty will
-                                    -- be  r_1 -> ... -> r_N -> t, and
-                                    -- ref_vars will be [r_1, ... , r_N].
-                                    -- In the base case with no additional
-                                    -- holes, h_ty will just be t and ref_vars
-                                    -- will be [].
-             -> TcType -- The type we're checking to whether it can be
-                       -- instantiated to the type h_ty.
-             -> TcM (Maybe ([TcType], [TcType])) -- If it is not a match, we
-                                                 -- return Nothing. Otherwise,
-                                                 -- we Just return the list of
-                                                 -- types that quantified type
-                                                 -- variables in ty would take
-                                                 -- if used in place of h_ty,
-                                                 -- and the list types of any
-                                                 -- additional holes simulated
-                                                 -- with the refinement
-                                                 -- variables in ref_vars.
-    fitsHole (h_ty, ref_vars) ty =
-    -- We wrap this with the withoutUnification to avoid having side-effects
-    -- beyond the check, but we rely on the side-effects when looking for
-    -- refinement hole fits, so we can't wrap the side-effects deeper than this.
-      withoutUnification fvs $
-      do { traceTc "checkingFitOf {" $ ppr ty
-         ; (fits, wrp) <- tcCheckHoleFit hole h_ty ty
-         ; traceTc "Did it fit?" $ ppr fits
-         ; traceTc "wrap is: " $ ppr wrp
-         ; traceTc "checkingFitOf }" empty
-         -- We'd like to avoid refinement suggestions like `id _ _` or
-         -- `head _ _`, and only suggest refinements where our all phantom
-         -- variables got unified during the checking. This can be disabled
-         -- with the `-fabstract-refinement-hole-fits` flag.
-         -- Here we do the additional handling when there are refinement
-         -- variables, i.e. zonk them to read their final value to check for
-         -- abstract refinements, and to report what the type of the simulated
-         -- holes must be for this to be a match.
-         ; if fits then do {
-              -- Zonking is expensive, so we only do it if required.
-              z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp)
-            ; if null ref_vars
-              then return (Just (z_wrp_tys, []))
-              else do { let -- To be concrete matches, matches have to
-                            -- be more than just an invented type variable.
-                            fvSet = fvVarSet fvs
-                            notAbstract :: TcType -> Bool
-                            notAbstract t = case getTyVar_maybe t of
-                                              Just tv -> tv `elemVarSet` fvSet
-                                              _ -> True
-                            allConcrete = all notAbstract z_wrp_tys
-                      ; z_vars  <- zonkTcTyVars ref_vars
-                      ; let z_mtvs = mapMaybe getTyVar_maybe z_vars
-                      ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs
-                      ; allowAbstract <- goptM Opt_AbstractRefHoleFits
-                      ; if allowAbstract || (allFilled && allConcrete )
-                        then return $ Just (z_wrp_tys, z_vars)
-                        else return Nothing }}
-           else return Nothing }
-     where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty
-           hole = typed_hole { th_hole = Nothing }
-
-
-
--- | Checks whether a MetaTyVar is flexible or not.
-isFlexiTyVar :: TcTyVar -> TcM Bool
-isFlexiTyVar tv | isMetaTyVar tv = isFlexi <$> readMetaTyVar tv
-isFlexiTyVar _ = return False
-
--- | Takes a list of free variables and restores any Flexi type variables in
--- free_vars after the action is run.
-withoutUnification :: FV -> TcM a -> TcM a
-withoutUnification free_vars action =
-  do { flexis <- filterM isFlexiTyVar fuvs
-     ; result <- action
-          -- Reset any mutated free variables
-     ; mapM_ restore flexis
-     ; return result }
-  where restore tv = do { traceTc "withoutUnification: restore flexi" (ppr tv)
-                        ; writeTcRef (metaTyVarRef tv) Flexi }
-        fuvs = fvVarList free_vars
-
--- | Reports whether first type (ty_a) subsumes the second type (ty_b),
--- discarding any errors. Subsumption here means that the ty_b can fit into the
--- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a.
-tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool
-tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit dummyHole ty_a ty_b
-  where dummyHole = TypedHole { th_relevant_cts = emptyBag
-                              , th_implics      = []
-                              , th_hole         = Nothing }
-
--- | A tcSubsumes which takes into account relevant constraints, to fix trac
--- #14273. This makes sure that when checking whether a type fits the hole,
--- the type has to be subsumed by type of the hole as well as fulfill all
--- constraints on the type of the hole.
-tcCheckHoleFit :: TypedHole   -- ^ The hole to check against
-               -> TcSigmaType
-               -- ^ The type of the hole to check against (possibly modified,
-               -- e.g. refined with additional holes for refinement hole-fits.)
-               -> TcSigmaType -- ^ The type to check whether fits.
-               -> TcM (Bool, HsWrapper)
-               -- ^ Whether it was a match, and the wrapper from hole_ty to ty.
-tcCheckHoleFit _ hole_ty ty | hole_ty `eqType` ty
-    = return (True, idHsWrapper)
-tcCheckHoleFit (TypedHole {..}) hole_ty ty = discardErrs $
-  do { -- We wrap the subtype constraint in the implications to pass along the
-       -- givens, and so we must ensure that any nested implications and skolems
-       -- end up with the correct level. The implications are ordered so that
-       -- the innermost (the one with the highest level) is first, so it
-       -- suffices to get the level of the first one (or the current level, if
-       -- there are no implications involved).
-       innermost_lvl <- case th_implics of
-                          [] -> getTcLevel
-                          -- imp is the innermost implication
-                          (imp:_) -> return (ic_tclvl imp)
-     ; (wrap, wanted) <- setTcLevel innermost_lvl $ captureConstraints $
-                         tcSubTypeSigma orig (ExprSigCtxt NoRRC) ty hole_ty
-     ; traceTc "Checking hole fit {" empty
-     ; traceTc "wanteds are: " $ ppr wanted
-     ; if isEmptyWC wanted && isEmptyBag th_relevant_cts
-       then do { traceTc "}" empty
-               ; return (True, wrap) }
-       else do { fresh_binds <- newTcEvBinds
-                -- The relevant constraints may contain HoleDests, so we must
-                -- take care to clone them as well (to avoid #15370).
-               ; cloned_relevants <- mapBagM cloneWantedCtEv th_relevant_cts
-                 -- We wrap the WC in the nested implications, for details, see
-                 -- Note [Checking hole fits]
-               ; let wrapInImpls cts = foldl (flip (setWCAndBinds fresh_binds)) cts th_implics
-                     final_wc  = wrapInImpls $ addSimples wanted $
-                                                          mapBag mkNonCanonical cloned_relevants
-                 -- We add the cloned relevants to the wanteds generated
-                 -- by the call to tcSubType_NC, for details, see
-                 -- Note [Relevant constraints]. There's no need to clone
-                 -- the wanteds, because they are freshly generated by the
-                 -- call to`tcSubtype_NC`.
-               ; traceTc "final_wc is: " $ ppr final_wc
-                 -- See Note [Speeding up valid hole-fits]
-               ; (rem, _) <- tryTc $ runTcSEarlyAbort $ simplifyTopWanteds final_wc
-               ; traceTc "}" empty
-               ; return (any isSolvedWC rem, wrap) } }
-  where
-    orig = ExprHoleOrigin (hole_occ <$> th_hole)
-
-    setWCAndBinds :: EvBindsVar         -- Fresh ev binds var.
-                  -> Implication        -- The implication to put WC in.
-                  -> WantedConstraints  -- The WC constraints to put implic.
-                  -> WantedConstraints  -- The new constraints.
-    setWCAndBinds binds imp wc
-      = mkImplicWC $ unitBag $ imp { ic_wanted = wc , ic_binds = binds }
diff --git a/compiler/GHC/Tc/Errors/Hole.hs-boot b/compiler/GHC/Tc/Errors/Hole.hs-boot
deleted file mode 100644
--- a/compiler/GHC/Tc/Errors/Hole.hs-boot
+++ /dev/null
@@ -1,42 +0,0 @@
--- This boot file is in place to break the loop where:
--- + GHC.Tc.Solver calls 'GHC.Tc.Errors.reportUnsolved',
--- + which calls 'GHC.Tc.Errors.Hole.findValidHoleFits`
--- + which calls 'GHC.Tc.Solver.simpl_top'
-module GHC.Tc.Errors.Hole where
-
-import GHC.Types.Var ( Id )
-import GHC.Tc.Errors.Types ( HoleFitDispConfig, ValidHoleFits )
-import GHC.Tc.Types  ( TcM )
-import GHC.Tc.Types.Constraint ( CtEvidence, CtLoc, Hole, Implication )
-import GHC.Utils.Outputable ( SDoc )
-import GHC.Types.Var.Env ( TidyEnv )
-import GHC.Tc.Errors.Hole.FitTypes ( HoleFit, TypedHole, HoleFitCandidate )
-import GHC.Tc.Utils.TcType ( TcType, TcSigmaType, TcTyVar )
-import GHC.Tc.Types.Evidence ( HsWrapper )
-import GHC.Utils.FV ( FV )
-import Data.Bool ( Bool )
-import Data.Maybe ( Maybe )
-import Data.Int ( Int )
-
-findValidHoleFits :: TidyEnv -> [Implication] -> [CtEvidence] -> Hole
-                  -> TcM (TidyEnv, ValidHoleFits)
-
-tcCheckHoleFit :: TypedHole -> TcSigmaType -> TcSigmaType
-               -> TcM (Bool, HsWrapper)
-
-withoutUnification :: FV -> TcM a -> TcM a
-tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool
-tcFilterHoleFits :: Maybe Int -> TypedHole -> (TcType, [TcTyVar])
-                 -> [HoleFitCandidate] -> TcM (Bool, [HoleFit])
-getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id]
-addHoleFitDocs :: [HoleFit] -> TcM [HoleFit]
-
-data HoleFitSortingAlg
-
-pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc
-getHoleFitSortingAlg :: TcM HoleFitSortingAlg
-getHoleFitDispConfig :: TcM HoleFitDispConfig
-
-zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])
-sortHoleFitsBySize :: [HoleFit] -> TcM [HoleFit]
-sortHoleFitsByGraph :: [HoleFit] -> TcM [HoleFit]
diff --git a/compiler/GHC/Tc/Gen/Annotation.hs b/compiler/GHC/Tc/Gen/Annotation.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Annotation.hs
+++ /dev/null
@@ -1,71 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1993-1998
-
--}
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-
--- | Typechecking annotations
-module GHC.Tc.Gen.Annotation ( tcAnnotations, annCtxt ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-import GHC.Driver.Env
-
-import GHC.Tc.Errors.Types
-import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runAnnotation )
-import GHC.Tc.Utils.Monad
-
-import GHC.Unit.Module
-
-import GHC.Hs
-
-import GHC.Utils.Outputable
-
-import GHC.Types.Name
-import GHC.Types.Annotations
-import GHC.Types.SrcLoc
-
-import Control.Monad ( when )
-
--- Some platforms don't support the interpreter, and compilation on those
--- platforms shouldn't fail just due to annotations
-tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation]
-tcAnnotations anns = do
-  hsc_env <- getTopEnv
-  case hsc_interp hsc_env of
-    Just _  -> mapM tcAnnotation anns
-    Nothing -> warnAnns anns
-
-warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation]
---- No GHCI; emit a warning (not an error) and ignore. cf #4268
-warnAnns [] = return []
-warnAnns anns@(L loc _ : _)
-  = do { setSrcSpanA loc $ addDiagnosticTc (TcRnIgnoringAnnotations anns)
-       ; return [] }
-
-tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation
-tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do
-    -- Work out what the full target of this annotation was
-    mod <- getModule
-    let target = annProvenanceToTarget mod provenance
-
-    -- Run that annotation and construct the full Annotation data structure
-    setSrcSpanA loc $ addErrCtxt (annCtxt ann) $ do
-      -- See #10826 -- Annotations allow one to bypass Safe Haskell.
-      dflags <- getDynFlags
-      when (safeLanguageOn dflags) $ failWithTc TcRnAnnotationInSafeHaskell
-      runAnnotation target expr
-
-annProvenanceToTarget :: Module -> AnnProvenance GhcRn
-                      -> AnnTarget Name
-annProvenanceToTarget _   (ValueAnnProvenance (L _ name)) = NamedTarget name
-annProvenanceToTarget _   (TypeAnnProvenance (L _ name))  = NamedTarget name
-annProvenanceToTarget mod ModuleAnnProvenance             = ModuleTarget mod
-
-annCtxt :: (OutputableBndrId p) => AnnDecl (GhcPass p) -> SDoc
-annCtxt ann
-  = hang (text "In the annotation:") 2 (ppr ann)
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ /dev/null
@@ -1,1240 +0,0 @@
-
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies        #-}
-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-
-{-
-%
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
--}
-
-module GHC.Tc.Gen.App
-       ( tcApp
-       , tcInferSigma
-       , tcExprPrag ) where
-
-import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr )
-
-import GHC.Types.Var
-import GHC.Builtin.Types ( multiplicityTy )
-import GHC.Tc.Gen.Head
-import GHC.Hs
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Unify
-import GHC.Tc.Utils.Instantiate
-import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst_maybe )
-import GHC.Tc.Gen.HsType
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.TcType as TcType
-import GHC.Core.TyCon
-import GHC.Core.TyCo.Rep
-import GHC.Core.TyCo.Ppr
-import GHC.Core.TyCo.Subst (substTyWithInScope)
-import GHC.Core.TyCo.FVs( shallowTyCoVarsOfType )
-import GHC.Core.Type
-import GHC.Core.Coercion
-import GHC.Tc.Types.Evidence
-import GHC.Types.Var.Set
-import GHC.Builtin.PrimOps( tagToEnumKey )
-import GHC.Builtin.Names
-import GHC.Driver.Session
-import GHC.Types.SrcLoc
-import GHC.Types.Var.Env  ( emptyTidyEnv, mkInScopeSet )
-import GHC.Data.Maybe
-import GHC.Utils.Misc
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import qualified GHC.LanguageExtensions as LangExt
-
-import Control.Monad
-import Data.Function
-
-import GHC.Prelude
-
-{- *********************************************************************
-*                                                                      *
-                 Quick Look overview
-*                                                                      *
-********************************************************************* -}
-
-{- Note [Quick Look]
-~~~~~~~~~~~~~~~~~~~~
-The implementation of Quick Look closely follows the QL paper
-   A quick look at impredicativity, Serrano et al, ICFP 2020
-   https://www.microsoft.com/en-us/research/publication/a-quick-look-at-impredicativity/
-
-All the moving parts are in this module, GHC.Tc.Gen.App, so named
-because it deal with n-ary application.  The main workhorse is tcApp.
-
-Some notes relative to the paper
-
-* The "instantiation variables" of the paper are ordinary unification
-  variables.  We keep track of which variables are instantiation variables
-  by keeping a set Delta of instantiation variables.
-
-* When we learn what an instantiation variable must be, we simply unify
-  it with that type; this is done in qlUnify, which is the function mgu_ql(t1,t2)
-  of the paper.  This may fill in a (mutable) instantiation variable with
-  a polytype.
-
-* When QL is done, we don't need to turn the un-filled-in
-  instantiation variables into unification variables -- they
-  already /are/ unification variables!  See also
-  Note [Instantiation variables are short lived].
-
-* We cleverly avoid the quadratic cost of QL, alluded to in the paper.
-  See Note [Quick Look at value arguments]
-
-Note [Instantiation variables are short lived]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-By the time QL is done, all filled-in occurrences of instantiation
-variables have been zonked away (see "Crucial step" in tcValArgs),
-and so the constraint /generator/ never subsequently sees a meta-type
-variable filled in with a polytype -- a meta type variable stands
-(only) for a monotype.  See Section 4.3 "Applications and instantiation"
-of the paper.
-
-However, the constraint /solver/ can see a meta-type-variable filled
-in with a polytype (#18987). Suppose
-  f :: forall a. Dict a => [a] -> [a]
-  xs :: [forall b. b->b]
-and consider the call (f xs).  QL will
-* Instantiate f, with a := kappa, where kappa is an instantiation variable
-* Emit a constraint (Dict kappa), via instantiateSigma, called from tcInstFun
-* Do QL on the argument, to discover kappa := forall b. b->b
-
-But by the time the third step has happened, the constraint has been
-emitted into the monad.  The constraint solver will later find it, and
-rewrite it to (Dict (forall b. b->b)). That's fine -- the constraint
-solver does no implicit instantiation (which is what makes it so
-tricky to have foralls hiding inside unification variables), so there
-is no difficulty with allowing those filled-in kappa's to persist.
-(We could find them and zonk them away, but that would cost code and
-execution time, for no purpose.)
-
-Since the constraint solver does not do implicit instantiation (as the
-constraint generator does), the fact that a unification variable might
-stand for a polytype does not matter.
--}
-
-
-{- *********************************************************************
-*                                                                      *
-              tcInferSigma
-*                                                                      *
-********************************************************************* -}
-
-tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType
--- Used only to implement :type; see GHC.Tc.Module.tcRnExpr
--- True  <=> instantiate -- return a rho-type
--- False <=> don't instantiate -- return a sigma-type
-tcInferSigma inst (L loc rn_expr)
-  | (fun@(rn_fun,_), rn_args) <- splitHsApps rn_expr
-  = addExprCtxt rn_expr $
-    setSrcSpanA loc     $
-    do { do_ql <- wantQuickLook rn_fun
-       ; (_tc_fun, fun_sigma) <- tcInferAppHead fun rn_args
-       ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst fun fun_sigma rn_args
-       ; _tc_args <- tcValArgs do_ql inst_args
-       ; return app_res_sigma }
-
-{- *********************************************************************
-*                                                                      *
-              Typechecking n-ary applications
-*                                                                      *
-********************************************************************* -}
-
-{- Note [Application chains and heads]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Quick Look treats application chains specially.  What is an
-"application chain"?  See Fig 2, of the QL paper: "A quick look at
-impredicativity" (ICFP'20). Here's the syntax:
-
-app ::= head
-     |  app expr            -- HsApp: ordinary application
-     |  app @type           -- HsTypeApp: VTA
-     |  expr `head` expr    -- OpApp: infix applications
-     |  ( app )             -- HsPar: parens
-     |  {-# PRAGMA #-} app  -- HsPragE: pragmas
-
-head ::= f                -- HsVar:    variables
-      |  fld              -- HsRecSel: record field selectors
-      |  (expr :: ty)     -- ExprWithTySig: expr with user type sig
-      |  lit              -- HsOverLit: overloaded literals
-      |  $([| head |])    -- HsSpliceE+HsSpliced+HsSplicedExpr: untyped TH expression splices
-      |  other_expr       -- Other expressions
-
-When tcExpr sees something that starts an application chain (namely,
-any of the constructors in 'app' or 'head'), it invokes tcApp to
-typecheck it: see Note [tcApp: typechecking applications].  However,
-for HsPar and HsPragE, there is no tcWrapResult (which would
-instantiate types, bypassing Quick Look), so nothing is gained by
-using the application chain route, and we can just recurse to tcExpr.
-
-A "head" has three special cases (for which we can infer a polytype
-using tcInferAppHead_maybe); otherwise is just any old expression (for
-which we can infer a rho-type (via tcInfer).
-
-There is no special treatment for HsUnboundVar, HsOverLit etc, because
-we can't get a polytype from them.
-
-Left and right sections (e.g. (x +) and (+ x)) are not yet supported.
-Probably left sections (x +) would be easy to add, since x is the
-first arg of (+); but right sections are not so easy.  For symmetry
-reasons I've left both unchanged, in GHC.Tc.Gen.Expr.
-
-It may not be immediately obvious why ExprWithTySig (e::ty) should be
-dealt with by tcApp, even when it is not applied to anything. Consider
-   f :: [forall a. a->a] -> Int
-   ...(f (undefined :: forall b. b))...
-Clearly this should work!  But it will /only/ work because if we
-instantiate that (forall b. b) impredicatively!  And that only happens
-in tcApp.
-
-We also wish to typecheck application chains with untyped Template Haskell
-splices in the head, such as this example from #21038:
-    data Foo = MkFoo (forall a. a -> a)
-    f = $([| MkFoo |]) $ \x -> x
-This should typecheck just as if the TH splice was never in the way—that is,
-just as if the user had written `MkFoo $ \x -> x`. We could conceivably have
-a case for typed TH expression splices too, but it wouldn't be useful in
-practice, since the types of typed TH expressions aren't allowed to have
-polymorphic types, such as the type of MkFoo.
-
-Note [tcApp: typechecking applications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-tcApp implements the APP-Downarrow/Uparrow rule of
-Fig 3, plus the modification in Fig 5, of the QL paper:
-"A quick look at impredicativity" (ICFP'20).
-
-It treats application chains (f e1 @ty e2) specially:
-
-* So we can report errors like "in the third argument of a call of f"
-
-* So we can do Visible Type Application (VTA), for which we must not
-  eagerly instantiate the function part of the application.
-
-* So that we can do Quick Look impredicativity.
-
-tcApp works like this:
-
-1. Use splitHsApps, which peels off
-     HsApp, HsTypeApp, HsPrag, HsPar
-   returning the function in the corner and the arguments
-
-   splitHsApps can deal with infix as well as prefix application,
-   and returns a Rebuilder to re-assemble the application after
-   typechecking.
-
-   The "list of arguments" is [HsExprArg], described in Note [HsExprArg].
-   in GHC.Tc.Gen.Head
-
-2. Use tcInferAppHead to infer the type of the function,
-     as an (uninstantiated) TcSigmaType
-   There are special cases for
-     HsVar, HsRecSel, and ExprWithTySig
-   Otherwise, delegate back to tcExpr, which
-     infers an (instantiated) TcRhoType
-
-3. Use tcInstFun to instantiate the function, Quick-Looking as we go.
-   This implements the |-inst judgement in Fig 4, plus the
-   modification in Fig 5, of the QL paper:
-   "A quick look at impredicativity" (ICFP'20).
-
-   In tcInstFun we take a quick look at value arguments, using
-   quickLookArg.  See Note [Quick Look at value arguments].
-
-4. Use quickLookResultType to take a quick look at the result type,
-   when in checking mode.  This is the shaded part of APP-Downarrow
-   in Fig 5.
-
-5. Use unifyResultType to match up the result type of the call
-   with that expected by the context.  See Note [Unify with
-   expected type before typechecking arguments]
-
-6. Use tcValArgs to typecheck the value arguments
-
-7. After a gruesome special case for tagToEnum, rebuild the result.
-
-
-Some cases that /won't/ work:
-
-1. Consider this (which uses visible type application):
-
-    (let { f :: forall a. a -> a; f x = x } in f) @Int
-
-   Since 'let' is not among the special cases for tcInferAppHead,
-   we'll delegate back to tcExpr, which will instantiate f's type
-   and the type application to @Int will fail.  Too bad!
-
-Note [Quick Look for particular Ids]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We switch on Quick Look (regardless of -XImpredicativeTypes) for certain
-particular Ids:
-
-* ($): For a long time GHC has had a special typing rule for ($), that
-  allows it to type (runST $ foo), which requires impredicative instantiation
-  of ($), without language flags.  It's a bit ad-hoc, but it's been that
-  way for ages.  Using quickLookKeys is the only special treatment ($) needs
-  now, which is a lot better.
-
-* leftSection, rightSection: these are introduced by the expansion step in
-  the renamer (Note [Handling overloaded and rebindable constructs] in
-  GHC.Rename.Expr), and we want them to be instantiated impredicatively
-  so that (f `op`), say, will work OK even if `f` is higher rank.
-  See Note [Left and right sections] in GHC.Rename.Expr.
-
-Note [Unify with expected type before typechecking arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this (#19364)
-  data Pair a b = Pair a b
-  baz :: MkPair Int Bool
-  baz = MkPair "yes" "no"
-
-We instantiate MkPair with `alpha`, `beta`, and push its argument
-types (`alpha` and `beta`) into the arguments ("yes" and "no").
-But if we first unify the result type (Pair alpha beta) with the expected
-type (Pair Int Bool) we will push the much more informative types
-`Int` and `Bool` into the arguments.   This makes a difference:
-
-Unify result type /after/ typechecking the args
-    • Couldn't match type ‘[Char]’ with ‘Bool’
-      Expected type: Pair Foo Bar
-        Actual type: Pair [Char] [Char]
-    • In the expression: Pair "yes" "no"
-
-Unify result type /before/ typechecking the args
-    • Couldn't match type ‘[Char]’ with ‘Bool’
-      Expected: Foo
-        Actual: String
-    • In the first argument of ‘Pair’, namely ‘"yes"’
-
-The latter is much better. That is why we call unifyExpectedType
-before tcValArgs.
--}
-
-tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
--- See Note [tcApp: typechecking applications]
-tcApp rn_expr exp_res_ty
-  | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr
-  = do { traceTc "tcApp {" $
-           vcat [ text "rn_fun:" <+> ppr rn_fun
-                , text "rn_args:" <+> ppr rn_args ]
-
-       ; (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args
-
-       -- Instantiate
-       ; do_ql <- wantQuickLook rn_fun
-       ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True fun fun_sigma rn_args
-
-       -- Quick look at result
-       ; app_res_rho <- if do_ql
-                        then quickLookResultType delta app_res_rho exp_res_ty
-                        else return app_res_rho
-
-       -- Unify with expected type from the context
-       -- See Note [Unify with expected type before typechecking arguments]
-       --
-       -- perhaps_add_res_ty_ctxt: Inside an expansion, the addFunResCtxt stuff is
-       --    more confusing than helpful because the function at the head isn't in
-       --    the source program; it was added by the renamer.  See
-       --    Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr
-       ; let  perhaps_add_res_ty_ctxt thing_inside
-                 | insideExpansion fun_ctxt
-                 = thing_inside
-                 | otherwise
-                 = addFunResCtxt rn_fun rn_args app_res_rho exp_res_ty $
-                   thing_inside
-
-       -- Match up app_res_rho: the result type of rn_expr
-       --     with exp_res_ty:  the expected result type
-       ; do_ds <- xoptM LangExt.DeepSubsumption
-       ; res_wrap <- perhaps_add_res_ty_ctxt $
-            if not do_ds
-            then -- No deep subsumption
-                 -- app_res_rho and exp_res_ty are both rho-types,
-                 -- so with simple subsumption we can just unify them
-                 -- No need to zonk; the unifier does that
-                 do { co <- unifyExpectedType rn_expr app_res_rho exp_res_ty
-                    ; return (mkWpCastN co) }
-
-            else -- Deep subsumption
-                 -- Even though both app_res_rho and exp_res_ty are rho-types,
-                 -- they may have nested polymorphism, so if deep subsumption
-                 -- is on we must call tcSubType.
-                 -- Zonk app_res_rho first, because QL may have instantiated some
-                 -- delta variables to polytypes, and tcSubType doesn't expect that
-                 do { app_res_rho <- zonkQuickLook do_ql app_res_rho
-                    ; tcSubTypeDS rn_expr app_res_rho exp_res_ty }
-
-       -- Typecheck the value arguments
-       ; tc_args <- tcValArgs do_ql inst_args
-
-       -- Reconstruct, with a special case for tagToEnum#.
-       ; tc_expr <-
-          if isTagToEnum rn_fun
-          then tcTagToEnum tc_fun fun_ctxt tc_args app_res_rho
-          else do rebuildHsApps tc_fun fun_ctxt tc_args app_res_rho
-
-       ; whenDOptM Opt_D_dump_tc_trace $
-         do { inst_args <- mapM zonkArg inst_args  -- Only when tracing
-            ; traceTc "tcApp }" (vcat [ text "rn_fun:"      <+> ppr rn_fun
-                                      , text "rn_args:"     <+> ppr rn_args
-                                      , text "inst_args"    <+> brackets (pprWithCommas pprHsExprArgTc inst_args)
-                                      , text "do_ql:  "     <+> ppr do_ql
-                                      , text "fun_sigma:  " <+> ppr fun_sigma
-                                      , text "delta:      " <+> ppr delta
-                                      , text "app_res_rho:" <+> ppr app_res_rho
-                                      , text "exp_res_ty:"  <+> ppr exp_res_ty
-                                      , text "rn_expr:"     <+> ppr rn_expr
-                                      , text "tc_fun:"      <+> ppr tc_fun
-                                      , text "tc_args:"     <+> ppr tc_args
-                                      , text "tc_expr:"     <+> ppr tc_expr ]) }
-
-       -- Wrap the result
-       ; return (mkHsWrap res_wrap tc_expr) }
-
---------------------
-wantQuickLook :: HsExpr GhcRn -> TcM Bool
-wantQuickLook (HsVar _ (L _ f))
-  | getUnique f `elem` quickLookKeys = return True
-wantQuickLook _                      = xoptM LangExt.ImpredicativeTypes
-
-quickLookKeys :: [Unique]
--- See Note [Quick Look for particular Ids]
-quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey]
-
-zonkQuickLook :: Bool -> TcType -> TcM TcType
--- After all Quick Look unifications are done, zonk to ensure that all
--- instantiation variables are substituted away
---
--- So far as the paper is concerned, this step applies
--- the poly-substitution Theta, learned by QL, so that we
--- "see" the polymorphism in that type
---
--- In implementation terms this ensures that no unification variable
--- linger on that have been filled in with a polytype
-zonkQuickLook do_ql ty
-  | do_ql     = zonkTcType ty
-  | otherwise = return ty
-
--- zonkArg is used *only* during debug-tracing, to make it easier to
--- see what is going on.  For that reason, it is not a full zonk: add
--- more if you need it.
-zonkArg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpInst)
-zonkArg eva@(EValArg { eva_arg_ty = Scaled m ty })
-  = do { ty' <- zonkTcType ty
-       ; return (eva { eva_arg_ty = Scaled m ty' }) }
-zonkArg arg = return arg
-
-
-
-----------------
-
-tcValArgs :: Bool                    -- Quick-look on?
-          -> [HsExprArg 'TcpInst]    -- Actual argument
-          -> TcM [HsExprArg 'TcpTc]  -- Resulting argument
-tcValArgs do_ql args
-  = mapM tc_arg args
-  where
-    tc_arg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpTc)
-    tc_arg (EPrag l p) = return (EPrag l (tcExprPrag p))
-    tc_arg (EWrap w)   = return (EWrap w)
-    tc_arg (ETypeArg l at hs_ty ty) = return (ETypeArg l at hs_ty ty)
-
-    tc_arg eva@(EValArg { eva_arg = arg, eva_arg_ty = Scaled mult arg_ty
-                        , eva_ctxt = ctxt })
-      = do { -- Crucial step: expose QL results before checking arg_ty
-             -- So far as the paper is concerned, this step applies
-             -- the poly-substitution Theta, learned by QL, so that we
-             -- "see" the polymorphism in that argument type. E.g.
-             --    (:) e ids, where ids :: [forall a. a->a]
-             --                     (:) :: forall p. p->[p]->[p]
-             -- Then Theta = [p :-> forall a. a->a], and we want
-             -- to check 'e' with expected type (forall a. a->a)
-             -- See Note [Instantiation variables are short lived]
-             arg_ty <- zonkQuickLook do_ql arg_ty
-
-             -- Now check the argument
-           ; arg' <- tcScalingUsage mult $
-                     do { traceTc "tcEValArg" $
-                          vcat [ ppr ctxt
-                               , text "arg type:" <+> ppr arg_ty
-                               , text "arg:" <+> ppr arg ]
-                        ; tcEValArg ctxt arg arg_ty }
-
-           ; return (eva { eva_arg    = ValArg arg'
-                         , eva_arg_ty = Scaled mult arg_ty }) }
-
-tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcSigmaTypeFRR -> TcM (LHsExpr GhcTc)
--- Typecheck one value argument of a function call
-tcEValArg ctxt (ValArg larg@(L arg_loc arg)) exp_arg_sigma
-  = addArgCtxt ctxt larg $
-    do { arg' <- tcPolyExpr arg (mkCheckExpType exp_arg_sigma)
-       ; return (L arg_loc arg') }
-
-tcEValArg ctxt (ValArgQL { va_expr = larg@(L arg_loc _)
-                         , va_fun = (inner_fun, fun_ctxt)
-                         , va_args = inner_args
-                         , va_ty = app_res_rho }) exp_arg_sigma
-  = addArgCtxt ctxt larg $
-    do { traceTc "tcEValArgQL {" (vcat [ ppr inner_fun <+> ppr inner_args ])
-       ; tc_args <- tcValArgs True inner_args
-
-       ; co   <- unifyType Nothing app_res_rho exp_arg_sigma
-       ; arg' <- mkHsWrapCo co <$> rebuildHsApps inner_fun fun_ctxt tc_args app_res_rho
-       ; traceTc "tcEValArgQL }" $
-           vcat [ text "inner_fun:" <+> ppr inner_fun
-                , text "app_res_rho:" <+> ppr app_res_rho
-                , text "exp_arg_sigma:" <+> ppr exp_arg_sigma ]
-       ; return (L arg_loc arg') }
-
-{- *********************************************************************
-*                                                                      *
-              Instantiating the call
-*                                                                      *
-********************************************************************* -}
-
-type Delta = TcTyVarSet   -- Set of instantiation variables,
-                          --   written \kappa in the QL paper
-                          -- Just a set of ordinary unification variables,
-                          --   but ones that QL may fill in with polytypes
-
-tcInstFun :: Bool   -- True  <=> Do quick-look
-          -> Bool   -- False <=> Instantiate only /inferred/ variables at the end
-                    --           so may return a sigma-type
-                    -- True  <=> Instantiate all type variables at the end:
-                    --           return a rho-type
-                    -- The /only/ call site that passes in False is the one
-                    --    in tcInferSigma, which is used only to implement :type
-                    -- Otherwise we do eager instantiation; in Fig 5 of the paper
-                    --    |-inst returns a rho-type
-          -> (HsExpr GhcRn, AppCtxt)        -- Error messages only
-          -> TcSigmaType -> [HsExprArg 'TcpRn]
-          -> TcM ( Delta
-                 , [HsExprArg 'TcpInst]
-                 , TcSigmaType )
--- This function implements the |-inst judgement in Fig 4, plus the
--- modification in Fig 5, of the QL paper:
--- "A quick look at impredicativity" (ICFP'20).
-tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
-  = do { traceTc "tcInstFun" (vcat [ ppr rn_fun, ppr fun_sigma
-                                   , text "args:" <+> ppr rn_args
-                                   , text "do_ql" <+> ppr do_ql ])
-       ; go emptyVarSet [] [] fun_sigma rn_args }
-  where
-    fun_orig = exprCtOrigin (case fun_ctxt of
-                               VAExpansion e _ -> e
-                               VACall e _ _    -> e)
-
-    -- Count value args only when complaining about a function
-    -- applied to too many value args
-    -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify.
-    n_val_args = count isHsValArg rn_args
-
-    fun_is_out_of_scope  -- See Note [VTA for out-of-scope functions]
-      = case rn_fun of
-          HsUnboundVar {} -> True
-          _               -> False
-
-    inst_all, inst_inferred, inst_none :: ForAllTyFlag -> Bool
-    inst_all (Invisible {}) = True
-    inst_all Required       = False
-
-    inst_inferred (Invisible InferredSpec)  = True
-    inst_inferred (Invisible SpecifiedSpec) = False
-    inst_inferred Required                  = False
-
-    inst_none _ = False
-
-    inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool
-    inst_fun [] | inst_final  = inst_all
-                | otherwise   = inst_none
-                -- Using `inst_none` for `:type` avoids
-                -- `forall {r1} (a :: TYPE r1) {r2} (b :: TYPE r2). a -> b`
-                -- turning into `forall a {r2} (b :: TYPE r2). a -> b`.
-                -- See #21088.
-    inst_fun (EValArg {} : _) = inst_all
-    inst_fun _                = inst_inferred
-
-    -----------
-    go, go1 :: Delta
-            -> [HsExprArg 'TcpInst]     -- Accumulator, reversed
-            -> [Scaled TcSigmaTypeFRR]  -- Value args to which applied so far
-            -> TcSigmaType -> [HsExprArg 'TcpRn]
-            -> TcM (Delta, [HsExprArg 'TcpInst], TcSigmaType)
-
-    -- go: If fun_ty=kappa, look it up in Theta
-    go delta acc so_far fun_ty args
-      | Just kappa <- getTyVar_maybe fun_ty
-      , kappa `elemVarSet` delta
-      = do { cts <- readMetaTyVar kappa
-           ; case cts of
-                Indirect fun_ty' -> go  delta acc so_far fun_ty' args
-                Flexi            -> go1 delta acc so_far fun_ty  args }
-     | otherwise
-     = go1 delta acc so_far fun_ty args
-
-    -- go1: fun_ty is not filled-in instantiation variable
-    --      ('go' dealt with that case)
-
-    -- Rule IALL from Fig 4 of the QL paper
-    -- c.f. GHC.Tc.Utils.Instantiate.topInstantiate
-    go1 delta acc so_far fun_ty args
-      | (tvs,   body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty
-      , (theta, body2) <- tcSplitPhiTy body1
-      , not (null tvs && null theta)
-      = do { (inst_tvs, wrap, fun_rho) <- addHeadCtxt fun_ctxt $
-                                          instantiateSigma fun_orig tvs theta body2
-                 -- addHeadCtxt: important for the class constraints
-                 -- that may be emitted from instantiating fun_sigma
-           ; go (delta `extendVarSetList` inst_tvs)
-                (addArgWrap wrap acc) so_far fun_rho args }
-                -- Going around again means we deal easily with
-                -- nested  forall a. Eq a => forall b. Show b => blah
-
-    -- Rule IRESULT from Fig 4 of the QL paper
-    go1 delta acc _ fun_ty []
-       = do { traceTc "tcInstFun:ret" (ppr fun_ty)
-            ; return (delta, reverse acc, fun_ty) }
-
-    go1 delta acc so_far fun_ty (EWrap w : args)
-      = go1 delta (EWrap w : acc) so_far fun_ty args
-
-    go1 delta acc so_far fun_ty (EPrag sp prag : args)
-      = go1 delta (EPrag sp prag : acc) so_far fun_ty args
-
-    -- Rule ITYARG from Fig 4 of the QL paper
-    go1 delta acc so_far fun_ty ( ETypeArg { eva_ctxt = ctxt, eva_at = at, eva_hs_ty = hs_ty }
-                                : rest_args )
-      | fun_is_out_of_scope   -- See Note [VTA for out-of-scope functions]
-      = go delta acc so_far fun_ty rest_args
-
-      | otherwise
-      = do { (ty_arg, inst_ty) <- tcVTA fun_ty hs_ty
-           ; let arg' = ETypeArg { eva_ctxt = ctxt, eva_at = at, eva_hs_ty = hs_ty, eva_ty = ty_arg }
-           ; go delta (arg' : acc) so_far inst_ty rest_args }
-
-    -- Rule IVAR from Fig 4 of the QL paper:
-    go1 delta acc so_far fun_ty args@(EValArg {} : _)
-      | Just kappa <- getTyVar_maybe fun_ty
-      , kappa `elemVarSet` delta
-      = -- Function type was of form   f :: forall a b. t1 -> t2 -> b
-        -- with 'b', one of the quantified type variables, in the corner
-        -- but the call applies it to three or more value args.
-        -- Suppose b is instantiated by kappa.  Then we want to make fresh
-        -- instantiation variables nu1, nu2, and set kappa := nu1 -> nu2
-        --
-        -- In principle what is happening here is not unlike matchActualFunTysRho
-        -- but there are many small differences:
-        --   - We know that the function type in unfilled meta-tyvar
-        --     matchActualFunTysRho is much more general, has a loop, etc.
-        --   - We must be sure to actually update the variable right now,
-        --     not defer in any way, because this is a QL instantiation variable.
-        --   - We need the freshly allocated unification variables, to extend
-        --     delta with.
-        -- It's easier just to do the job directly here.
-        do { let valArgsCount = countLeadingValArgs args
-           ; arg_nus <- replicateM valArgsCount newOpenFlexiTyVar
-             -- We need variables for multiplicity (#18731)
-             -- Otherwise, 'undefined x' wouldn't be linear in x
-           ; mults   <- replicateM valArgsCount (newFlexiTyVarTy multiplicityTy)
-           ; res_nu  <- newOpenFlexiTyVar
-           ; kind_co <- unifyKind Nothing liftedTypeKind (tyVarKind kappa)
-           ; let delta'  = delta `extendVarSetList` (res_nu:arg_nus)
-                 arg_tys = mkTyVarTys arg_nus
-                 res_ty  = mkTyVarTy res_nu
-                 fun_ty' = mkScaledFunTys (zipWithEqual "tcInstFun" mkScaled mults arg_tys) res_ty
-                 co_wrap = mkWpCastN (mkGReflLeftCo Nominal fun_ty' kind_co)
-                 acc'    = addArgWrap co_wrap acc
-                 -- Suppose kappa :: kk
-                 -- Then fun_ty :: kk, fun_ty' :: Type, kind_co :: Type ~ kk
-                 --      co_wrap :: (fun_ty' |> kind_co) ~ fun_ty'
-           ; writeMetaTyVar kappa (mkCastTy fun_ty' kind_co)
-                 -- kappa is uninstantiated ('go' already checked that)
-           ; go delta' acc' so_far fun_ty' args }
-
-    -- Rule IARG from Fig 4 of the QL paper:
-    go1 delta acc so_far fun_ty
-        (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args)
-      = do { (wrap, arg_ty, res_ty) <-
-                matchActualFunTySigma
-                  (ExpectedFunTyArg (HsExprRnThing rn_fun) (unLoc arg))
-                  (Just $ HsExprRnThing rn_fun)
-                  (n_val_args, so_far) fun_ty
-          ; (delta', arg') <- if do_ql
-                              then addArgCtxt ctxt arg $
-                                   -- Context needed for constraints
-                                   -- generated by calls in arg
-                                   quickLookArg delta arg arg_ty
-                              else return (delta, ValArg arg)
-          ; let acc' = eva { eva_arg = arg', eva_arg_ty = arg_ty }
-                       : addArgWrap wrap acc
-          ; go delta' acc' (arg_ty:so_far) res_ty rest_args }
-
-
-addArgCtxt :: AppCtxt -> LHsExpr GhcRn
-           -> TcM a -> TcM a
--- There are two cases:
--- * In the normal case, we add an informative context
---      "In the third argument of f, namely blah"
--- * If we are deep inside generated code (isGeneratedCode)
---   or if all or part of this particular application is an expansion
---   (VAExpansion), just use the less-informative context
---       "In the expression: arg"
---   Unless the arg is also a generated thing, in which case do nothing.
----See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
-addArgCtxt ctxt (L arg_loc arg) thing_inside
-  = do { in_generated_code <- inGeneratedCode
-       ; case ctxt of
-           VACall fun arg_no _ | not in_generated_code
-             -> setSrcSpanA arg_loc                    $
-                addErrCtxt (funAppCtxt fun arg arg_no) $
-                thing_inside
-
-           _ -> setSrcSpanA arg_loc $
-                addExprCtxt arg     $  -- Auto-suppressed if arg_loc is generated
-                thing_inside }
-
-{- *********************************************************************
-*                                                                      *
-              Visible type application
-*                                                                      *
-********************************************************************* -}
-
-tcVTA :: TcType            -- Function type
-      -> LHsWcType GhcRn   -- Argument type
-      -> TcM (TcType, TcType)
--- Deal with a visible type application
--- The function type has already had its Inferred binders instantiated
-tcVTA fun_ty hs_ty
-  | Just (tvb, inner_ty) <- tcSplitForAllTyVarBinder_maybe fun_ty
-  , binderFlag tvb == Specified
-    -- It really can't be Inferred, because we've just
-    -- instantiated those. But, oddly, it might just be Required.
-    -- See Note [Required quantifiers in the type of a term]
-  = do { let tv   = binderVar tvb
-             kind = tyVarKind tv
-       ; ty_arg <- tcHsTypeApp hs_ty kind
-
-       ; inner_ty <- zonkTcType inner_ty
-             -- See Note [Visible type application zonk]
-
-       ; let in_scope  = mkInScopeSet (tyCoVarsOfTypes [fun_ty, ty_arg])
-             insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty
-                         -- NB: tv and ty_arg have the same kind, so this
-                         --     substitution is kind-respecting
-       ; traceTc "VTA" (vcat [ text "fun_ty" <+> ppr fun_ty
-                             , text "tv" <+> ppr tv <+> dcolon <+> debugPprType kind
-                             , text "ty_arg" <+> debugPprType ty_arg <+> dcolon
-                                             <+> debugPprType (typeKind ty_arg)
-                             , text "inner_ty" <+> debugPprType inner_ty
-                             , text "insted_ty" <+> debugPprType insted_ty ])
-       ; return (ty_arg, insted_ty) }
-
-  | otherwise
-  = do { (_, fun_ty) <- zonkTidyTcType emptyTidyEnv fun_ty
-       ; failWith $ TcRnInvalidTypeApplication fun_ty hs_ty }
-
-{- Note [Required quantifiers in the type of a term]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#15859)
-
-  data A k :: k -> Type      -- A      :: forall k -> k -> Type
-  type KindOf (a :: k) = k   -- KindOf :: forall k. k -> Type
-  a = (undefined :: KindOf A) @Int
-
-With ImpredicativeTypes (thin ice, I know), we instantiate
-KindOf at type (forall k -> k -> Type), so
-  KindOf A = forall k -> k -> Type
-whose first argument is Required
-
-We want to reject this type application to Int, but in earlier
-GHCs we had an ASSERT that Required could not occur here.
-
-The ice is thin; c.f. Note [No Required PiTyBinder in terms]
-in GHC.Core.TyCo.Rep.
-
-Note [VTA for out-of-scope functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose 'wurble' is not in scope, and we have
-   (wurble @Int @Bool True 'x')
-
-Then the renamer will make (HsUnboundVar "wurble") for 'wurble',
-and the typechecker will typecheck it with tcUnboundId, giving it
-a type 'alpha', and emitting a deferred Hole constraint, to
-be reported later.
-
-But then comes the visible type application. If we do nothing, we'll
-generate an immediate failure (in tc_app_err), saying that a function
-of type 'alpha' can't be applied to Bool.  That's insane!  And indeed
-users complain bitterly (#13834, #17150.)
-
-The right error is the Hole, which has /already/ been emitted by
-tcUnboundId.  It later reports 'wurble' as out of scope, and tries to
-give its type.
-
-Fortunately in tcInstFun we still have access to the function, so we
-can check if it is a HsUnboundVar.  We use this info to simply skip
-over any visible type arguments.  We've already inferred the type of
-the function (in tcInferAppHead), so we'll /already/ have emitted a
-Hole constraint; failing preserves that constraint.
-
-We do /not/ want to fail altogether in this case (via failM) because
-that may abandon an entire instance decl, which (in the presence of
--fdefer-type-errors) leads to leading to #17792.
-
-Downside: the typechecked term has lost its visible type arguments; we
-don't even kind-check them.  But let's jump that bridge if we come to
-it.  Meanwhile, let's not crash!
-
-
-Note [Visible type application zonk]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg).
-
-* tcHsTypeApp only guarantees that
-    - ty_arg is zonked
-    - kind(zonk(tv)) = kind(ty_arg)
-  (checkExpectedKind zonks as it goes).
-
-So we must zonk inner_ty as well, to guarantee consistency between zonk(tv)
-and inner_ty. Otherwise we can build an ill-kinded type. An example was #14158,
-where we had:
-   id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a
-and we had the visible type application
-  id @(->)
-
-* We instantiated k := kappa, yielding
-    forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a
-* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *).
-* That instantiated (->) as ((->) q1 q1), and unified kappa := q1,
-  Here q1 :: RuntimeRep
-* Now we substitute
-     cat  :->  (->) q1 q1 :: TYPE q1 -> TYPE q1 -> *
-  but we must first zonk the inner_ty to get
-      forall (a :: TYPE q1). cat a a
-  so that the result of substitution is well-kinded
-  Failing to do so led to #14158.
-
--}
-
-{- *********************************************************************
-*                                                                      *
-              Quick Look
-*                                                                      *
-********************************************************************* -}
-
-{- Note [Quick Look at value arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The function quickLookArg implements the "QL argument" judgement of
-the QL paper, in Fig 5 of "A quick look at impredicativity" (ICFP 2020),
-rather directly.
-
-Wrinkles:
-
-* We avoid zonking, so quickLookArg thereby sees the argument type /before/
-  the QL substitution Theta is applied to it. So we achieve argument-order
-  independence for free (see 5.7 in the paper).
-
-* When we quick-look at an argument, we save the work done, by returning
-  an EValArg with a ValArgQL inside it.  (It started life with a ValArg
-  inside.)  The ValArgQL remembers all the work that QL did (notably,
-  decomposing the argument and instantiating) so that tcValArgs does
-  not need to repeat it.  Rather neat, and remarkably easy.
--}
-
-----------------
-quickLookArg :: Delta
-             -> LHsExpr GhcRn          -- ^ Argument
-             -> Scaled TcSigmaTypeFRR  -- ^ Type expected by the function
-             -> TcM (Delta, EValArg 'TcpInst)
--- See Note [Quick Look at value arguments]
---
--- The returned Delta is a superset of the one passed in
--- with added instantiation variables from
---   (a) the call itself
---   (b) the arguments of the call
-quickLookArg delta larg (Scaled _ arg_ty)
-  | isEmptyVarSet delta  = skipQuickLook delta larg
-  | otherwise            = go arg_ty
-  where
-    guarded = isGuardedTy arg_ty
-      -- NB: guardedness is computed based on the original,
-      -- unzonked arg_ty, so we deliberately do not exploit
-      -- guardedness that emerges a result of QL on earlier args
-
-    go arg_ty | not (isRhoTy arg_ty)
-              = skipQuickLook delta larg
-
-              -- This top-level zonk step, which is the reason
-              -- we need a local 'go' loop, is subtle
-              -- See Section 9 of the QL paper
-              | Just kappa <- getTyVar_maybe arg_ty
-              , kappa `elemVarSet` delta
-              = do { info <- readMetaTyVar kappa
-                   ; case info of
-                       Indirect arg_ty' -> go arg_ty'
-                       Flexi            -> quickLookArg1 guarded delta larg arg_ty }
-
-              | otherwise
-              = quickLookArg1 guarded delta larg arg_ty
-
-isGuardedTy :: TcType -> Bool
-isGuardedTy ty
-  | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal
-  | Just {} <- tcSplitAppTy_maybe ty        = True
-  | otherwise                               = False
-
-quickLookArg1 :: Bool -> Delta -> LHsExpr GhcRn -> TcSigmaTypeFRR
-              -> TcM (Delta, EValArg 'TcpInst)
-quickLookArg1 guarded delta larg@(L _ arg) arg_ty
-  = do { let (fun@(rn_fun, fun_ctxt), rn_args) = splitHsApps arg
-       ; mb_fun_ty <- tcInferAppHead_maybe rn_fun rn_args
-       ; traceTc "quickLookArg 1" $
-         vcat [ text "arg:" <+> ppr arg
-              , text "head:" <+> ppr rn_fun <+> dcolon <+> ppr mb_fun_ty
-              , text "args:" <+> ppr rn_args ]
-
-       ; case mb_fun_ty of {
-           Nothing     -> -- fun is too complicated
-                          skipQuickLook delta larg ;
-           Just (tc_fun, fun_sigma) ->
-
-    do { let no_free_kappas = findNoQuantVars fun_sigma rn_args
-       ; traceTc "quickLookArg 2" $
-         vcat [ text "no_free_kappas:" <+> ppr no_free_kappas
-              , text "guarded:" <+> ppr guarded
-              , text "tc_fun:" <+> ppr tc_fun
-              , text "fun_sigma:" <+> ppr fun_sigma ]
-       ; if not (guarded || no_free_kappas)
-         then skipQuickLook delta larg
-         else
-    do { do_ql <- wantQuickLook rn_fun
-       ; (delta_app, inst_args, app_res_rho) <- tcInstFun do_ql True fun fun_sigma rn_args
-       ; traceTc "quickLookArg 3" $
-         vcat [ text "arg:" <+> ppr arg
-              , text "delta:" <+> ppr delta
-              , text "delta_app:" <+> ppr delta_app
-              , text "arg_ty:" <+> ppr arg_ty
-              , text "app_res_rho:" <+> ppr app_res_rho ]
-
-       -- Do quick-look unification
-       -- NB: arg_ty may not be zonked, but that's ok
-       ; let delta' = delta `unionVarSet` delta_app
-       ; qlUnify delta' arg_ty app_res_rho
-
-       ; let ql_arg = ValArgQL { va_expr  = larg
-                               , va_fun   = (tc_fun, fun_ctxt)
-                               , va_args  = inst_args
-                               , va_ty    = app_res_rho }
-       ; return (delta', ql_arg) } } } }
-
-skipQuickLook :: Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)
-skipQuickLook delta larg = return (delta, ValArg larg)
-
-----------------
-quickLookResultType :: Delta -> TcRhoType -> ExpRhoType -> TcM TcRhoType
--- This function implements the shaded bit of rule APP-Downarrow in
--- Fig 5 of the QL paper: "A quick look at impredicativity" (ICFP'20).
--- It returns its second argument, but with any variables in Delta
--- substituted out, so no variables in Delta escape
-
-quickLookResultType delta app_res_rho (Check exp_rho)
-  = -- In checking mode only, do qlUnify with the expected result type
-    do { unless (isEmptyVarSet delta)  $ -- Optimisation only
-         qlUnify delta app_res_rho exp_rho
-       ; return app_res_rho }
-
-quickLookResultType _ app_res_rho (Infer {})
-  = zonkTcType app_res_rho
-    -- Zonk the result type, to ensure that we substitute out any
-    -- filled-in instantiation variable before calling
-    -- unifyExpectedType. In the Check case, this isn't necessary,
-    -- because unifyExpectedType just drops to tcUnify; but in the
-    -- Infer case a filled-in instantiation variable (filled in by
-    -- tcInstFun) might perhaps escape into the constraint
-    -- generator. The safe thing to do is to zonk any instantiation
-    -- variables away.  See Note [Instantiation variables are short lived]
-
----------------------
-qlUnify :: Delta -> TcType -> TcType -> TcM ()
--- Unify ty1 with ty2, unifying only variables in delta
-qlUnify delta ty1 ty2
-  = do { traceTc "qlUnify" (ppr delta $$ ppr ty1 $$ ppr ty2)
-       ; go (emptyVarSet,emptyVarSet) ty1 ty2 }
-  where
-    go :: (TyVarSet, TcTyVarSet)
-       -> TcType -> TcType
-       -> TcM ()
-    -- The TyVarSets give the variables bound by enclosing foralls
-    -- for the corresponding type. Don't unify with these.
-    go bvs (TyVarTy tv) ty2
-      | tv `elemVarSet` delta = go_kappa bvs tv ty2
-
-    go (bvs1, bvs2) ty1 (TyVarTy tv)
-      | tv `elemVarSet` delta = go_kappa (bvs2,bvs1) tv ty1
-
-    go bvs (CastTy ty1 _) ty2 = go bvs ty1 ty2
-    go bvs ty1 (CastTy ty2 _) = go bvs ty1 ty2
-
-    go _ (TyConApp tc1 []) (TyConApp tc2 [])
-      | tc1 == tc2 -- See GHC.Tc.Utils.Unify
-      = return ()  -- Note [Expanding synonyms during unification]
-
-    -- Now, and only now, expand synonyms
-    go bvs rho1 rho2
-      | Just rho1 <- coreView rho1 = go bvs rho1 rho2
-      | Just rho2 <- coreView rho2 = go bvs rho1 rho2
-
-    go bvs (TyConApp tc1 tys1) (TyConApp tc2 tys2)
-      | tc1 == tc2
-      , not (isTypeFamilyTyCon tc1)
-      , tys1 `equalLength` tys2
-      = zipWithM_ (go bvs) tys1 tys2
-
-    -- Decompose (arg1 -> res1) ~ (arg2 -> res2)
-    -- and         (c1 => res1) ~   (c2 => res2)
-    -- But for the latter we only learn instantiation info from res1~res2
-    -- We look at the multiplicity too, although the chances of getting
-    -- impredicative instantiation info from there seems...remote.
-    go bvs (FunTy { ft_af = af1, ft_arg = arg1, ft_res = res1, ft_mult = mult1 })
-           (FunTy { ft_af = af2, ft_arg = arg2, ft_res = res2, ft_mult = mult2 })
-      | af1 == af2 -- Match the arrow TyCon
-      = do { when (isVisibleFunArg af1) (go bvs arg1 arg2)
-           ; when (isFUNArg af1)        (go bvs mult1 mult2)
-           ; go bvs res1 res2 }
-
-    -- ToDo: c.f. Tc.Utils.unify.uType,
-    -- which does not split FunTy here
-    -- Also NB tcSplitAppTyNoView here, which does not split (c => t)
-    go bvs (AppTy t1a t1b) ty2
-      | Just (t2a, t2b) <- tcSplitAppTyNoView_maybe ty2
-      = do { go bvs t1a t2a; go bvs t1b t2b }
-
-    go bvs ty1 (AppTy t2a t2b)
-      | Just (t1a, t1b) <- tcSplitAppTyNoView_maybe ty1
-      = do { go bvs t1a t2a; go bvs t1b t2b }
-
-    go (bvs1, bvs2) (ForAllTy bv1 ty1) (ForAllTy bv2 ty2)
-      = go (bvs1',bvs2') ty1 ty2
-      where
-       bvs1' = bvs1 `extendVarSet` binderVar bv1
-       bvs2' = bvs2 `extendVarSet` binderVar bv2
-
-    go _ _ _ = return ()
-
-
-    ----------------
-    go_kappa bvs kappa ty2
-      = assertPpr (isMetaTyVar kappa) (ppr kappa) $
-        do { info <- readMetaTyVar kappa
-           ; case info of
-               Indirect ty1 -> go bvs ty1 ty2
-               Flexi        -> do { ty2 <- zonkTcType ty2
-                                  ; go_flexi bvs kappa ty2 } }
-
-    ----------------
-    go_flexi (_,bvs2) kappa ty2  -- ty2 is zonked
-      | -- See Note [Actual unification in qlUnify]
-        let ty2_tvs = shallowTyCoVarsOfType ty2
-      , not (ty2_tvs `intersectsVarSet` bvs2)
-          -- Can't instantiate a delta-varto a forall-bound variable
-      , Just ty2 <- occCheckExpand [kappa] ty2
-          -- Passes the occurs check
-      = do { let ty2_kind   = typeKind ty2
-                 kappa_kind = tyVarKind kappa
-           ; co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind
-                   -- unifyKind: see Note [Actual unification in qlUnify]
-
-           ; traceTc "qlUnify:update" $
-             vcat [ hang (ppr kappa <+> dcolon <+> ppr kappa_kind)
-                       2 (text ":=" <+> ppr ty2 <+> dcolon <+> ppr ty2_kind)
-                 , text "co:" <+> ppr co ]
-           ; writeMetaTyVar kappa (mkCastTy ty2 co) }
-
-      | otherwise
-      = return ()   -- Occurs-check or forall-bound variable
-
-
-{- Note [Actual unification in qlUnify]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In qlUnify, if we find (kappa ~ ty), we are going to update kappa := ty.
-That is the entire point of qlUnify!   Wrinkles:
-
-* We must not unify with anything bound by an enclosing forall; e.g.
-    (forall a. kappa -> Int) ~ forall a. a -> Int)
-  That's tracked by the 'bvs' arg of 'go'.
-
-* We must not make an occurs-check; we use occCheckExpand for that.
-
-* checkTypeEq also checks for various other things, including
-  - foralls, and predicate types (which we want to allow here)
-  - type families (relates to a very specific and exotic performance
-    question, that is unlikely to bite here)
-  - blocking coercion holes
-  After some thought we believe that none of these are relevant
-  here
-
-* What if kappa and ty have different kinds?  We solve that problem by
-  calling unifyKind, producing a coercion perhaps emitting some deferred
-  equality constraints.  That is /different/ from the approach we use in
-  the main constraint solver for heterogeneous equalities; see Note
-  [Equalities with incompatible kinds] in Solver.Canonical
-
-  Why different? Because:
-  - We can't use qlUnify to solve the kind constraint because qlUnify
-    won't unify ordinary (non-instantiation) unification variables.
-    (It would have to worry about lots of things like untouchability
-    if it did.)
-  - qlUnify can't give up if the kinds look un-equal because that would
-    mean that it might succeed some times (when the eager unifier
-    has already unified those kinds) but not others -- order
-    dependence.
-  - We can't use the ordinary unifier/constraint solver instead,
-    because it doesn't unify polykinds, and has all kinds of other
-    magic.  qlUnify is very focused.
-
-  TL;DR Calling unifyKind seems like the lesser evil.
-  -}
-
-{- *********************************************************************
-*                                                                      *
-              Guardedness
-*                                                                      *
-********************************************************************* -}
-
-findNoQuantVars :: TcSigmaType -> [HsExprArg 'TcpRn] -> Bool
--- True <=> there are no free quantified variables
---          in the result of the call
--- E.g. in the call (f e1 e2), if
---   f :: forall a b. a -> b -> Int   return True
---   f :: forall a b. a -> b -> b     return False (b is free)
-findNoQuantVars fun_ty args
-  = go emptyVarSet fun_ty args
-  where
-    need_instantiation []               = True
-    need_instantiation (EValArg {} : _) = True
-    need_instantiation _                = False
-
-    go :: TyVarSet -> TcSigmaType -> [HsExprArg 'TcpRn] -> Bool
-    go bvs fun_ty args
-      | need_instantiation args
-      , (tvs, theta, rho) <- tcSplitSigmaTy fun_ty
-      , not (null tvs && null theta)
-      = go (bvs `extendVarSetList` tvs) rho args
-
-    go bvs fun_ty [] =  tyCoVarsOfType fun_ty `disjointVarSet` bvs
-
-    go bvs fun_ty (EWrap {} : args) = go bvs fun_ty args
-    go bvs fun_ty (EPrag {} : args) = go bvs fun_ty args
-
-    go bvs fun_ty args@(ETypeArg {} : rest_args)
-      | (tvs,  body1) <- tcSplitSomeForAllTyVars (== Inferred) fun_ty
-      , (theta, body2) <- tcSplitPhiTy body1
-      , not (null tvs && null theta)
-      = go (bvs `extendVarSetList` tvs) body2 args
-      | Just (_tv, res_ty) <- tcSplitForAllTyVarBinder_maybe fun_ty
-      = go bvs res_ty rest_args
-      | otherwise
-      = False  -- E.g. head ids @Int
-
-    go bvs fun_ty (EValArg {} : rest_args)
-      | Just (_, res_ty) <- tcSplitFunTy_maybe fun_ty
-      = go bvs res_ty rest_args
-      | otherwise
-      = False  -- E.g. head id 'x'
-
-
-{- *********************************************************************
-*                                                                      *
-                 tagToEnum#
-*                                                                      *
-********************************************************************* -}
-
-{- Note [tagToEnum#]
-~~~~~~~~~~~~~~~~~~~~
-Nasty check to ensure that tagToEnum# is applied to a type that is an
-enumeration TyCon.  It's crude, because it relies on our
-knowing *now* that the type is ok, which in turn relies on the
-eager-unification part of the type checker pushing enough information
-here.  In theory the Right Thing to do is to have a new form of
-constraint but I definitely cannot face that!  And it works ok as-is.
-
-Here's are two cases that should fail
-        f :: forall a. a
-        f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
-
-        g :: Int
-        g = tagToEnum# 0        -- Int is not an enumeration
-
-When data type families are involved it's a bit more complicated.
-     data family F a
-     data instance F [Int] = A | B | C
-Then we want to generate something like
-     tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
-Usually that coercion is hidden inside the wrappers for
-constructors of F [Int] but here we have to do it explicitly.
-
-It's all grotesquely complicated.
--}
-
-isTagToEnum :: HsExpr GhcRn -> Bool
-isTagToEnum (HsVar _ (L _ fun_id)) = fun_id `hasKey` tagToEnumKey
-isTagToEnum _ = False
-
-tcTagToEnum :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]
-            -> TcRhoType
-            -> TcM (HsExpr GhcTc)
--- tagToEnum# :: forall a. Int# -> a
--- See Note [tagToEnum#]   Urgh!
-tcTagToEnum tc_fun fun_ctxt tc_args res_ty
-  | [val_arg] <- dropWhile (not . isHsValArg) tc_args
-  = do { res_ty <- zonkTcType res_ty
-
-       -- Check that the type is algebraic
-       ; case tcSplitTyConApp_maybe res_ty of {
-           Nothing -> do { addErrTc (TcRnTagToEnumUnspecifiedResTy res_ty)
-                         ; vanilla_result } ;
-           Just (tc, tc_args) ->
-
-    do { -- Look through any type family
-       ; fam_envs <- tcGetFamInstEnvs
-       ; case tcLookupDataFamInst_maybe fam_envs tc tc_args of {
-           Nothing -> do { check_enumeration res_ty tc
-                         ; vanilla_result } ;
-           Just (rep_tc, rep_args, coi) ->
-
-    do { -- coi :: tc tc_args ~R rep_tc rep_args
-         check_enumeration res_ty rep_tc
-       ; let rep_ty  = mkTyConApp rep_tc rep_args
-             tc_fun' = mkHsWrap (WpTyApp rep_ty) tc_fun
-             df_wrap = mkWpCastR (mkSymCo coi)
-       ; tc_expr <- rebuildHsApps tc_fun' fun_ctxt [val_arg] res_ty
-       ; return (mkHsWrap df_wrap tc_expr) }}}}}
-
-  | otherwise
-  = failWithTc TcRnTagToEnumMissingValArg
-
-  where
-    vanilla_result = rebuildHsApps tc_fun fun_ctxt tc_args res_ty
-
-    check_enumeration ty' tc
-      | isEnumerationTyCon tc = return ()
-      | otherwise             = addErrTc (TcRnTagToEnumResTyNotAnEnum ty')
-
-
-{- *********************************************************************
-*                                                                      *
-             Pragmas on expressions
-*                                                                      *
-********************************************************************* -}
-
-tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc
-tcExprPrag (HsPragSCC x1 ann) = HsPragSCC x1 ann
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ /dev/null
@@ -1,493 +0,0 @@
-{-# LANGUAGE RankNTypes     #-}
-{-# LANGUAGE TypeFamilies   #-}
-{-# LANGUAGE BlockArguments #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
--- | Typecheck arrow notation
-module GHC.Tc.Gen.Arrow ( tcProc ) where
-
-import GHC.Prelude
-
-import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcCheckMonoExpr, tcInferRho, tcSyntaxOp
-                                       , tcCheckPolyExpr )
-
-import GHC.Hs
-import GHC.Tc.Errors.Types
-import GHC.Tc.Gen.Match
-import GHC.Tc.Gen.Head( tcCheckId )
-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Gen.Bind
-import GHC.Tc.Gen.Pat
-import GHC.Tc.Utils.Unify
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Env
-import GHC.Tc.Types.Origin
-import GHC.Tc.Types.Evidence
-import GHC.Core.Multiplicity
-import GHC.Core.Coercion
-import GHC.Types.Id( mkLocalId )
-import GHC.Tc.Utils.Instantiate
-import GHC.Builtin.Types
-import GHC.Types.Var.Set
-import GHC.Builtin.Types.Prim
-import GHC.Types.Basic( Arity )
-import GHC.Types.Error
-import GHC.Types.SrcLoc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Misc
-
-import Control.Monad
-
-{-
-Note [Arrow overview]
-~~~~~~~~~~~~~~~~~~~~~
-Here's a summary of arrows and how they typecheck.  First, here's
-a cut-down syntax:
-
-  expr ::= ....
-        |  proc pat cmd
-
-  cmd ::= cmd exp                    -- Arrow application
-       |  \pat -> cmd                -- Arrow abstraction
-       |  (| exp cmd1 ... cmdn |)    -- Arrow form, n>=0
-       |  ... -- If, case in the usual way
-
-  cmd_type ::= carg_type --> type
-
-  carg_type ::= ()
-             |  (type, carg_type)
-
-Note that
- * The 'exp' in an arrow form can mention only
-   "arrow-local" variables
-
- * An "arrow-local" variable is bound by an enclosing
-   cmd binding form (eg arrow abstraction)
-
- * A cmd_type is here written with a funny arrow "-->",
-   The bit on the left is a carg_type (command argument type)
-   which itself is a nested tuple, finishing with ()
-
- * The arrow-tail operator (e1 -< e2) means
-       (| e1 <<< arr snd |) e2
-
-
-************************************************************************
-*                                                                      *
-                Proc
-*                                                                      *
-************************************************************************
--}
-
-tcProc :: LPat GhcRn -> LHsCmdTop GhcRn         -- proc pat -> expr
-       -> ExpRhoType                            -- Expected type of whole proc expression
-       -> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercion)
-
-tcProc pat cmd@(L loc (HsCmdTop names _)) exp_ty
-  = do  { exp_ty <- expTypeToType exp_ty  -- no higher-rank stuff with arrows
-        ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
-        ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
-        -- start with the names as they are used to desugar the proc itself
-        -- See #17423
-        ; names' <- setSrcSpanA loc $
-            mapM (tcSyntaxName ProcOrigin arr_ty) names
-        ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
-        ; (pat', cmd') <- newArrowScope
-                          $ tcCheckPat (ArrowMatchCtxt ProcExpr) pat (unrestricted arg_ty)
-                          $ tcCmdTop cmd_env names' cmd (unitTy, res_ty)
-        ; let res_co = co `mkTransCo` mkAppCo co1 (mkNomReflCo res_ty)
-        ; return (pat', cmd', res_co) }
-
-{-
-************************************************************************
-*                                                                      *
-                Commands
-*                                                                      *
-************************************************************************
--}
-
--- See Note [Arrow overview]
-type CmdType    = (CmdArgType, TcTauType)    -- cmd_type
-type CmdArgType = TcTauType                  -- carg_type, a nested tuple
-
-data CmdEnv
-  = CmdEnv {
-        cmd_arr :: TcType -- ^ Arrow type constructor, of kind *->*->*
-    }
-
-mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
-mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
-
----------------------------------------
-tcCmdTop :: CmdEnv
-         -> CmdSyntaxTable GhcTc -- ^ Type-checked Arrow class methods (arr, (>>>), ...)
-         -> LHsCmdTop GhcRn
-         -> CmdType
-         -> TcM (LHsCmdTop GhcTc)
-
-tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty)
-  = setSrcSpanA loc $
-    do  { cmd' <- tcCmd env cmd cmd_ty
-        ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') }
-
-----------------------------------------
-tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc)
-        -- The main recursive function
-tcCmd env (L loc cmd) cmd_ty@(_, res_ty)
-  = setSrcSpan (locA loc) $ do
-        { cmd' <- tc_cmd env cmd cmd_ty
-        ; hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowCmdResTy cmd) res_ty
-        ; return (L loc cmd') }
-
-tc_cmd :: CmdEnv -> HsCmd GhcRn  -> CmdType -> TcM (HsCmd GhcTc)
-tc_cmd env (HsCmdPar x lpar cmd rpar) res_ty
-  = do  { cmd' <- tcCmd env cmd res_ty
-        ; return (HsCmdPar x lpar cmd' rpar) }
-
-tc_cmd env (HsCmdLet x tkLet binds tkIn (L body_loc body)) res_ty
-  = do  { (binds', body') <- tcLocalBinds binds         $
-                             setSrcSpan (locA body_loc) $
-                             tc_cmd env body res_ty
-        ; return (HsCmdLet x tkLet binds' tkIn (L body_loc body')) }
-
-tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)
-  = addErrCtxt (cmdCtxt in_cmd) $ do
-      (scrut', scrut_ty) <- tcInferRho scrut
-      hasFixedRuntimeRep_syntactic
-        (FRRArrow $ ArrowCmdCase)
-        scrut_ty
-      matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty)
-      return (HsCmdCase x scrut' matches')
-
-tc_cmd env cmd@(HsCmdLamCase x lc_variant match) cmd_ty
-  = addErrCtxt (cmdCtxt cmd)
-      do { let match_ctxt = ArrowLamCaseAlt lc_variant
-         ; checkPatCounts (ArrowMatchCtxt match_ctxt) match
-         ; (wrap, match') <-
-             tcCmdMatchLambda env match_ctxt match cmd_ty
-         ; return (mkHsCmdWrap wrap (HsCmdLamCase x lc_variant match')) }
-
-tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty    -- Ordinary 'if'
-  = do  { pred' <- tcCheckMonoExpr pred boolTy
-        ; b1'   <- tcCmd env b1 res_ty
-        ; b2'   <- tcCmd env b2 res_ty
-        ; return (HsCmdIf x NoSyntaxExprTc pred' b1' b2')
-    }
-
-tc_cmd env (HsCmdIf x fun@(SyntaxExprRn {}) pred b1 b2) res_ty -- Rebindable syntax for if
-  = do  { pred_ty <- newOpenFlexiTyVarTy
-        -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r
-        -- because we're going to apply it to the environment, not
-        -- the return value.
-        ; skol_info <- mkSkolemInfo ArrowReboundIfSkol
-        ; (_, [r_tv]) <- tcInstSkolTyVars skol_info [alphaTyVar]
-        ; let r_ty = mkTyVarTy r_tv
-        ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty))
-                  TcRnArrowIfThenElsePredDependsOnResultTy
-        ; (pred', fun') <- tcSyntaxOp IfThenElseOrigin fun
-                              (map synKnownType [pred_ty, r_ty, r_ty])
-                              (mkCheckExpType r_ty) $ \ _ _ ->
-                           tcCheckMonoExpr pred pred_ty
-
-        ; b1'   <- tcCmd env b1 res_ty
-        ; b2'   <- tcCmd env b2 res_ty
-        ; return (HsCmdIf x fun' pred' b1' b2')
-    }
-
--------------------------------------------
---              Arrow application
---          (f -< a)   or   (f -<< a)
---
---   D   |- fun :: a t1 t2
---   D,G |- arg :: t1
---  ------------------------
---   D;G |-a  fun -< arg :: stk --> t2
---
---   D,G |- fun :: a t1 t2
---   D,G |- arg :: t1
---  ------------------------
---   D;G |-a  fun -<< arg :: stk --> t2
---
--- (plus -<< requires ArrowApply)
-
-tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty)
-  = addErrCtxt (cmdCtxt cmd)    $
-    do  { arg_ty <- newOpenFlexiTyVarTy
-        ; let fun_ty = mkCmdArrTy env arg_ty res_ty
-        ; fun' <- select_arrow_scope (tcCheckMonoExpr fun fun_ty)
-
-        ; arg' <- tcCheckMonoExpr arg arg_ty
-
-        ; hasFixedRuntimeRep_syntactic
-            (FRRArrow $ ArrowCmdArrApp (unLoc fun) (unLoc arg) ho_app)
-            fun_ty
-
-        ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) }
-  where
-       -- Before type-checking f, use the environment of the enclosing
-       -- proc for the (-<) case.
-       -- Local bindings, inside the enclosing proc, are not in scope
-       -- inside f.  In the higher-order case (-<<), they are.
-       -- See Note [Escaping the arrow scope] in GHC.Tc.Types
-    select_arrow_scope tc = case ho_app of
-        HsHigherOrderApp -> tc
-        HsFirstOrderApp  -> escapeArrowScope tc
-
--------------------------------------------
---              Command application
---
--- D,G |-  exp : t
--- D;G |-a cmd : (t,stk) --> res
--- -----------------------------
--- D;G |-a cmd exp : stk --> res
-
-tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty)
-  = addErrCtxt (cmdCtxt cmd)    $
-    do  { arg_ty <- newOpenFlexiTyVarTy
-        ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)
-        ; arg'   <- tcCheckMonoExpr arg arg_ty
-        ; hasFixedRuntimeRep_syntactic
-            (FRRArrow $ ArrowCmdApp (unLoc fun) (unLoc arg))
-            arg_ty
-        ; return (HsCmdApp x fun' arg') }
-
--------------------------------------------
---              Lambda
---
--- D;G,x:t |-a cmd : stk --> res
--- ------------------------------
--- D;G |-a (\x.cmd) : (t,stk) --> res
-
-tc_cmd env (HsCmdLam x match) cmd_ty
-  = do { (wrap, match') <- tcCmdMatchLambda env KappaExpr match cmd_ty
-       ; return (mkHsCmdWrap wrap (HsCmdLam x match')) }
-
--------------------------------------------
---              Do notation
-
-tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty)
-  = do  { co <- unifyType Nothing unitTy cmd_stk  -- Expecting empty argument stack
-        ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty
-        ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) }
-
-
------------------------------------------------------------------
---      Arrow ``forms''       (| e c1 .. cn |)
---
---      D; G |-a1 c1 : stk1 --> r1
---      ...
---      D; G |-an cn : stkn --> rn
---      D |-  e :: forall e. a1 (e, stk1) t1
---                                ...
---                        -> an (e, stkn) tn
---                        -> a  (e, stk) t
---      e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn)
---      ----------------------------------------------
---      D; G |-a  (| e c1 ... cn |)  :  stk --> t
-
-tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
-  = addErrCtxt (cmdCtxt cmd)
-    do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args
-                              -- We use alphaTyVar for 'w'
-        ; let e_ty = mkInfForAllTy alphaTyVar $
-                     mkVisFunTysMany cmd_tys $
-                     mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty
-        ; expr' <- tcCheckPolyExpr expr e_ty
-        ; return (HsCmdArrForm x expr' f fixity cmd_args') }
-
-  where
-    tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType)
-    tc_cmd_arg cmd@(L loc (HsCmdTop names _))
-       = do { arr_ty <- newFlexiTyVarTy arrowTyConKind
-            ; stk_ty <- newFlexiTyVarTy liftedTypeKind
-            ; res_ty <- newFlexiTyVarTy liftedTypeKind
-            ; names' <- setSrcSpanA loc $
-                mapM (tcSyntaxName ArrowCmdOrigin arr_ty) names
-            ; let env' = env { cmd_arr = arr_ty }
-            ; cmd' <- tcCmdTop env' names' cmd (stk_ty, res_ty)
-            ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }
-
--- | Typechecking for case command alternatives. Used for 'HsCmdCase'.
-tcCmdMatches :: CmdEnv
-             -> TcTypeFRR -- ^ Type of the scrutinee.
-             -> MatchGroup GhcRn (LHsCmd GhcRn)  -- ^ case alternatives
-             -> CmdType
-             -> TcM (MatchGroup GhcTc (LHsCmd GhcTc))
-tcCmdMatches env scrut_ty matches (stk, res_ty)
-  = tcMatchesCase match_ctxt (unrestricted scrut_ty) matches (mkCheckExpType res_ty)
-  where
-    match_ctxt = MC { mc_what = ArrowMatchCtxt ArrowCaseAlt,
-                      mc_body = mc_body }
-    mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'
-                              ; tcCmd env body (stk, res_ty') }
-
--- | Typechecking for 'HsCmdLam' and 'HsCmdLamCase'.
-tcCmdMatchLambda :: CmdEnv
-                 -> HsArrowMatchContext
-                 -> MatchGroup GhcRn (LHsCmd GhcRn)
-                 -> CmdType
-                 -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc))
-tcCmdMatchLambda env
-                 ctxt
-                 mg@MG { mg_alts = L l matches, mg_ext = origin }
-                 (cmd_stk, res_ty)
-  = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk
-
-       ; let check_arg_tys = map (unrestricted . mkCheckExpType) arg_tys
-       ; matches' <- forM matches $
-           addErrCtxt . pprMatchInCtxt . unLoc <*> tc_match check_arg_tys cmd_stk'
-
-       ; let arg_tys' = map unrestricted arg_tys
-             mg' = mg { mg_alts = L l matches'
-                      , mg_ext = MatchGroupTc arg_tys' res_ty origin }
-
-       ; return (mkWpCastN co, mg') }
-  where
-    n_pats | isEmptyMatchGroup mg = 1   -- must be lambda-case
-           | otherwise            = matchGroupArity mg
-
-    -- Check the patterns, and the GRHSs inside
-    tc_match arg_tys cmd_stk' (L mtch_loc (Match { m_pats = pats, m_grhss = grhss }))
-      = do { (pats', grhss') <- setSrcSpanA mtch_loc           $
-                                tcPats match_ctxt pats arg_tys $
-                                tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)
-
-           ; return $ L mtch_loc (Match { m_ext = noAnn
-                                        , m_ctxt = match_ctxt
-                                        , m_pats = pats'
-                                        , m_grhss = grhss' }) }
-
-    match_ctxt = ArrowMatchCtxt ctxt
-    pg_ctxt    = PatGuard match_ctxt
-
-    tc_grhss (GRHSs x grhss binds) stk_ty res_ty
-        = do { (binds', grhss') <- tcLocalBinds binds $
-                                   mapM (wrapLocMA (tc_grhs stk_ty res_ty)) grhss
-             ; return (GRHSs x grhss' binds') }
-
-    tc_grhs stk_ty res_ty (GRHS x guards body)
-        = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
-                                  \ res_ty -> tcCmd env body
-                                                (stk_ty, checkingExpType "tc_grhs" res_ty)
-             ; return (GRHS x guards' rhs') }
-
-matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcTypeFRR], TcType)
-matchExpectedCmdArgs 0 ty
-  = return (mkNomReflCo ty, [], ty)
-matchExpectedCmdArgs n ty
-  = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty
-       ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2
-       ; return (mkTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) }
-
-{-
-************************************************************************
-*                                                                      *
-                Stmts
-*                                                                      *
-************************************************************************
--}
-
---------------------------------
---      Mdo-notation
--- The distinctive features here are
---      (a) RecStmts, and
---      (b) no rebindable syntax
-
-tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker
-tcArrDoStmt env _ (LastStmt x rhs noret _) res_ty thing_inside
-  = do  { rhs' <- tcCmd env rhs (unitTy, res_ty)
-        ; thing <- thing_inside (panic "tcArrDoStmt")
-        ; return (LastStmt x rhs' noret noSyntaxExpr, thing) }
-
-tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside
-  = do  { (rhs', elt_ty) <- tc_arr_rhs env rhs
-        ; thing          <- thing_inside res_ty
-        ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) }
-
-tcArrDoStmt env ctxt (BindStmt _ pat rhs) res_ty thing_inside
-  = do  { (rhs', pat_ty) <- tc_arr_rhs env rhs
-        ; (pat', thing)  <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
-                            thing_inside res_ty
-        ; return (mkTcBindStmt pat' rhs', thing) }
-
-tcArrDoStmt env ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names
-                            , recS_rec_ids = rec_names }) res_ty thing_inside
-  = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
-        ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
-        ; let tup_ids = zipWith (\n p -> mkLocalId n ManyTy p) tup_names tup_elt_tys
-                        -- Many because it's a recursive definition
-        ; tcExtendIdEnv tup_ids $ do
-        { (stmts', tup_rets)
-                <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty   $ \ _res_ty' ->
-                        -- ToDo: res_ty not really right
-                   zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys)
-
-        ; thing <- thing_inside res_ty
-                -- NB:  The rec_ids for the recursive things
-                --      already scope over this part. This binding may shadow
-                --      some of them with polymorphic things with the same Name
-                --      (see Note [How RecStmt works] in Language.Haskell.Syntax.Expr)
-
-        ; let rec_ids = takeList rec_names tup_ids
-        ; later_ids <- tcLookupLocalIds later_names
-
-        ; let rec_rets = takeList rec_names tup_rets
-        ; let ret_table = zip tup_ids tup_rets
-        ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j]
-
-        ; let
-            stmt :: Stmt GhcTc (LocatedA (HsCmd GhcTc))
-            stmt = emptyRecStmtId
-                                 { recS_stmts = L l stmts'
-                                 -- { recS_stmts = _ stmts'
-                                 , recS_later_ids = later_ids
-                                 , recS_rec_ids = rec_ids
-                                 , recS_ext = unitRecStmtTc
-                                     { recS_later_rets = later_rets
-                                     , recS_rec_rets = rec_rets
-                                     , recS_ret_ty = res_ty} }
-        ; return (stmt, thing)
-        }}
-
-tcArrDoStmt _ _ stmt _ _
-  = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt)
-
-tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTc, TcType)
-tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
-                        ; rhs' <- tcCmd env rhs (unitTy, ty)
-                        ; return (rhs', ty) }
-
-{-
-************************************************************************
-*                                                                      *
-                Helpers
-*                                                                      *
-************************************************************************
--}
-
-mkPairTy :: Type -> Type -> Type
-mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]
-
-arrowTyConKind :: Kind          --  *->*->*
-arrowTyConKind = mkVisFunTysMany [liftedTypeKind, liftedTypeKind] liftedTypeKind
-
-{-
-************************************************************************
-*                                                                      *
-                Errors
-*                                                                      *
-************************************************************************
--}
-
-cmdCtxt :: HsCmd GhcRn -> SDoc
-cmdCtxt cmd = text "In the command:" <+> ppr cmd
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ /dev/null
@@ -1,1843 +0,0 @@
-
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications    #-}
-{-# LANGUAGE TypeFamilies        #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
-module GHC.Tc.Gen.Bind
-   ( tcLocalBinds
-   , tcTopBinds
-   , tcValBinds
-   , tcHsBootSigs
-   , tcPolyCheck
-   , chooseInferredQuantifiers
-   )
-where
-
-import GHC.Prelude
-
-import {-# SOURCE #-} GHC.Tc.Gen.Match ( tcGRHSsPat, tcMatchesFun )
-import {-# SOURCE #-} GHC.Tc.Gen.Expr  ( tcCheckMonoExpr )
-import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind )
-
-import GHC.Types.Tickish (CoreTickish, GenTickish (..))
-import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC))
-import GHC.Driver.Session
-import GHC.Data.FastString
-import GHC.Hs
-
-import GHC.Tc.Errors.Types
-import GHC.Tc.Gen.Sig
-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.Unify
-import GHC.Tc.Solver
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.Constraint
-
-import GHC.Tc.Gen.HsType
-import GHC.Tc.Gen.Pat
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Instance.Family( tcGetFamInstEnvs )
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Validity (checkValidType)
-
-import GHC.Core.Predicate
-import GHC.Core.Reduction ( Reduction(..) )
-import GHC.Core.Multiplicity
-import GHC.Core.FamInstEnv( normaliseType )
-import GHC.Core.Class   ( Class )
-import GHC.Core.Coercion( mkSymCo )
-import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy)
-import GHC.Core.TyCo.Ppr( pprTyVars )
-
-import GHC.Builtin.Types ( mkConstraintTupleTy )
-import GHC.Builtin.Types.Prim
-import GHC.Unit.Module
-
-import GHC.Types.SourceText
-import GHC.Types.Id
-import GHC.Types.Var as Var
-import GHC.Types.Var.Set
-import GHC.Types.Var.Env( TidyEnv, TyVarEnv, mkVarEnv, lookupVarEnv )
-import GHC.Types.Name
-import GHC.Types.Name.Set
-import GHC.Types.Name.Env
-import GHC.Types.SrcLoc
-
-import GHC.Utils.Error
-import GHC.Utils.Misc
-import GHC.Types.Basic
-import GHC.Types.CompleteMatch
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import GHC.Builtin.Names( ipClassName )
-import GHC.Types.Unique.FM
-import GHC.Types.Unique.DSet
-import GHC.Types.Unique.Set
-import qualified GHC.LanguageExtensions as LangExt
-
-import GHC.Data.Bag
-import GHC.Data.Graph.Directed
-import GHC.Data.Maybe
-
-import Control.Monad
-import Data.Foldable (find)
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Type-checking bindings}
-*                                                                      *
-************************************************************************
-
-@tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
-it needs to know something about the {\em usage} of the things bound,
-so that it can create specialisations of them.  So @tcBindsAndThen@
-takes a function which, given an extended environment, E, typechecks
-the scope of the bindings returning a typechecked thing and (most
-important) an LIE.  It is this LIE which is then used as the basis for
-specialising the things bound.
-
-@tcBindsAndThen@ also takes a "combiner" which glues together the
-bindings and the "thing" to make a new "thing".
-
-The real work is done by @tcBindWithSigsAndThen@.
-
-Recursive and non-recursive binds are handled in essentially the same
-way: because of uniques there are no scoping issues left.  The only
-difference is that non-recursive bindings can bind primitive values.
-
-Even for non-recursive binding groups we add typings for each binder
-to the LVE for the following reason.  When each individual binding is
-checked the type of its LHS is unified with that of its RHS; and
-type-checking the LHS of course requires that the binder is in scope.
-
-At the top-level the LIE is sure to contain nothing but constant
-dictionaries, which we resolve at the module level.
-
-Note [Polymorphic recursion]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The game plan for polymorphic recursion in the code above is
-
-        * Bind any variable for which we have a type signature
-          to an Id with a polymorphic type.  Then when type-checking
-          the RHSs we'll make a full polymorphic call.
-
-This fine, but if you aren't a bit careful you end up with a horrendous
-amount of partial application and (worse) a huge space leak. For example:
-
-        f :: Eq a => [a] -> [a]
-        f xs = ...f...
-
-If we don't take care, after typechecking we get
-
-        f = /\a -> \d::Eq a -> let f' = f a d
-                               in
-                               \ys:[a] -> ...f'...
-
-Notice the stupid construction of (f a d), which is of course
-identical to the function we're executing.  In this case, the
-polymorphic recursion isn't being used (but that's a very common case).
-This can lead to a massive space leak, from the following top-level defn
-(post-typechecking)
-
-        ff :: [Int] -> [Int]
-        ff = f Int dEqInt
-
-Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
-f' is another thunk which evaluates to the same thing... and you end
-up with a chain of identical values all hung onto by the CAF ff.
-
-        ff = f Int dEqInt
-
-           = let f' = f Int dEqInt in \ys. ...f'...
-
-           = let f' = let f' = f Int dEqInt in \ys. ...f'...
-                      in \ys. ...f'...
-
-Etc.
-
-NOTE: a bit of arity analysis would push the (f a d) inside the (\ys...),
-which would make the space leak go away in this case
-
-Solution: when typechecking the RHSs we always have in hand the
-*monomorphic* Ids for each binding.  So we just need to make sure that
-if (Method f a d) shows up in the constraints emerging from (...f...)
-we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
-to the "givens" when simplifying constraints.  That's what the "lies_avail"
-is doing.
-
-Then we get
-
-        f = /\a -> \d::Eq a -> letrec
-                                 fm = \ys:[a] -> ...fm...
-                               in
-                               fm
--}
-
-tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-           -> TcM (TcGblEnv, TcLclEnv)
--- The TcGblEnv contains the new tcg_binds and tcg_spects
--- The TcLclEnv has an extended type envt for the new bindings
-tcTopBinds binds sigs
-  = do  { -- Pattern synonym bindings populate the global environment
-          (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs getEnvs
-        ; specs <- tcImpPrags sigs   -- SPECIALISE prags for imported Ids
-
-        ; complete_matches <- restoreEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs
-        ; traceTc "complete_matches" (ppr binds $$ ppr sigs)
-        ; traceTc "complete_matches" (ppr complete_matches)
-
-        ; let { tcg_env' = tcg_env { tcg_imp_specs
-                                      = specs ++ tcg_imp_specs tcg_env
-                                   , tcg_complete_matches
-                                      = complete_matches
-                                          ++ tcg_complete_matches tcg_env }
-                           `addTypecheckedBinds` map snd binds' }
-
-        ; return (tcg_env', tcl_env) }
-        -- The top level bindings are flattened into a giant
-        -- implicitly-mutually-recursive LHsBinds
-
-tcCompleteSigs  :: [LSig GhcRn] -> TcM [CompleteMatch]
-tcCompleteSigs sigs =
-  let
-      doOne :: LSig GhcRn -> TcM (Maybe CompleteMatch)
-      -- We don't need to "type-check" COMPLETE signatures anymore; if their
-      -- combinations are invalid it will be found so at match sites.
-      -- There it is also where we consider if the type of the pattern match is
-      -- compatible with the result type constructor 'mb_tc'.
-      doOne (L loc c@(CompleteMatchSig (_ext, _src_txt) (L _ ns) mb_tc_nm))
-        = fmap Just $ setSrcSpanA loc $ addErrCtxt (text "In" <+> ppr c) $ do
-            cls   <- mkUniqDSet <$> mapM (addLocMA tcLookupConLike) ns
-            mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm
-            pure CompleteMatch { cmConLikes = cls, cmResultTyCon = mb_tc }
-      doOne _ = return Nothing
-
-  -- For some reason I haven't investigated further, the signatures come in
-  -- backwards wrt. declaration order. So we reverse them here, because it makes
-  -- a difference for incomplete match suggestions.
-  in mapMaybeM doOne $ reverse sigs
-
-tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
--- A hs-boot file has only one BindGroup, and it only has type
--- signatures in it.  The renamer checked all this
-tcHsBootSigs binds sigs
-  = do  { checkTc (null binds) TcRnIllegalHsBootFileDecl
-        ; concatMapM (addLocMA tc_boot_sig) (filter isTypeLSig sigs) }
-  where
-    tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames
-      where
-        f (L _ name)
-          = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name NoRRC) hs_ty
-               ; return (mkVanillaGlobal name sigma_ty) }
-        -- Notice that we make GlobalIds, not LocalIds
-    tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
-
-------------------------
-tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing
-             -> TcM (HsLocalBinds GhcTc, thing)
-
-tcLocalBinds (EmptyLocalBinds x) thing_inside
-  = do  { thing <- thing_inside
-        ; return (EmptyLocalBinds x, thing) }
-
-tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside
-  = do  { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
-        ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) }
-tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds"
-
-tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
-  = do  { ipClass <- tcLookupClass ipClassName
-        ; (given_ips, ip_binds') <-
-            mapAndUnzipM (wrapLocSndMA (tc_ip_bind ipClass)) ip_binds
-
-        -- Add all the IP bindings as givens for the body of the 'let'
-        ; (ev_binds, result) <- checkConstraints (IPSkol ips)
-                                  [] given_ips thing_inside
-
-        ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) }
-  where
-    ips = [ip | (L _ (IPBind _ (L _ ip) _)) <- ip_binds]
-
-        -- I wonder if we should do these one at a time
-        -- Consider     ?x = 4
-        --              ?y = ?x + 1
-    tc_ip_bind :: Class -> IPBind GhcRn -> TcM (DictId, IPBind GhcTc)
-    tc_ip_bind ipClass (IPBind _ l_name@(L _ ip) expr)
-       = do { ty <- newOpenFlexiTyVarTy
-            ; let p = mkStrLitTy $ hsIPNameFS ip
-            ; ip_id <- newDict ipClass [ p, ty ]
-            ; expr' <- tcCheckMonoExpr expr ty
-            ; let d = fmap (toDict ipClass p ty) expr'
-            ; return (ip_id, (IPBind ip_id l_name d)) }
-
-    -- Coerces a `t` into a dictionary for `IP "x" t`.
-    -- co : t -> IP "x" t
-    toDict :: Class  -- IP class
-           -> Type   -- type-level string for name of IP
-           -> Type   -- type of IP
-           -> HsExpr GhcTc   -- def'n of IP variable
-           -> HsExpr GhcTc   -- dictionary for IP
-    toDict ipClass x ty = mkHsWrap $ mkWpCastR $
-                          wrapIP $ mkClassPred ipClass [x,ty]
-
-tcValBinds :: TopLevelFlag
-           -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
-           -> TcM thing
-           -> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
-
-tcValBinds top_lvl binds sigs thing_inside
-  = do  {   -- Typecheck the signatures
-            -- It's easier to do so now, once for all the SCCs together
-            -- because a single signature  f,g :: <type>
-            -- might relate to more than one SCC
-          (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
-                                tcTySigs sigs
-
-        -- Extend the envt right away with all the Ids
-        --   declared with complete type signatures
-        -- Do not extend the TcBinderStack; instead
-        --   we extend it on a per-rhs basis in tcExtendForRhs
-        --   See Note [Relevant bindings and the binder stack]
-        --
-        -- For the moment, let bindings and top-level bindings introduce
-        -- only unrestricted variables.
-        ; tcExtendSigIds top_lvl poly_ids $
-     do { (binds', (extra_binds', thing))
-              <- tcBindGroups top_lvl sig_fn prag_fn binds $
-                 do { thing <- thing_inside
-                       -- See Note [Pattern synonym builders don't yield dependencies]
-                       --     in GHC.Rename.Bind
-                    ; patsyn_builders <- mapM (tcPatSynBuilderBind prag_fn) patsyns
-                    ; let extra_binds = [ (NonRecursive, builder)
-                                        | builder <- patsyn_builders ]
-                    ; return (extra_binds, thing) }
-        ; return (binds' ++ extra_binds', thing) }}
-  where
-    patsyns = getPatSynBinds binds
-    prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)
-
-------------------------
-tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
-             -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing
-             -> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
--- Typecheck a whole lot of value bindings,
--- one strongly-connected component at a time
--- Here a "strongly connected component" has the straightforward
--- meaning of a group of bindings that mention each other,
--- ignoring type signatures (that part comes later)
-
-tcBindGroups _ _ _ [] thing_inside
-  = do  { thing <- thing_inside
-        ; return ([], thing) }
-
-tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
-  = do  { -- See Note [Closed binder groups]
-          type_env <- getLclTypeEnv
-        ; let closed = isClosedBndrGroup type_env (snd group)
-        ; (group', (groups', thing))
-                <- tc_group top_lvl sig_fn prag_fn group closed $
-                   tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
-        ; return (group' ++ groups', thing) }
-
--- Note [Closed binder groups]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
---  A mutually recursive group is "closed" if all of the free variables of
---  the bindings are closed. For example
---
--- >  h = \x -> let f = ...g...
--- >                g = ....f...x...
--- >             in ...
---
--- Here @g@ is not closed because it mentions @x@; and hence neither is @f@
--- closed.
---
--- So we need to compute closed-ness on each strongly connected components,
--- before we sub-divide it based on what type signatures it has.
---
-
-------------------------
-tc_group :: forall thing.
-            TopLevelFlag -> TcSigFun -> TcPragEnv
-         -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing
-         -> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
-
--- Typecheck one strongly-connected component of the original program.
--- We get a list of groups back, because there may
--- be specialisations etc as well
-
-tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside
-        -- A single non-recursive binding
-        -- We want to keep non-recursive things non-recursive
-        -- so that we desugar unlifted bindings correctly
-  = do { let bind = case bagToList binds of
-                 [bind] -> bind
-                 []     -> panic "tc_group: empty list of binds"
-                 _      -> panic "tc_group: NonRecursive binds is not a singleton bag"
-       ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed
-                                     thing_inside
-       ; return ( [(NonRecursive, bind')], thing) }
-
-tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
-  =     -- To maximise polymorphism, we do a new
-        -- strongly-connected-component analysis, this time omitting
-        -- any references to variables with type signatures.
-        -- (This used to be optional, but isn't now.)
-        -- See Note [Polymorphic recursion] in "GHC.Hs.Binds".
-    do  { traceTc "tc_group rec" (pprLHsBinds binds)
-        ; whenIsJust mbFirstPatSyn $ \lpat_syn ->
-            recursivePatSynErr (locA $ getLoc lpat_syn) binds
-        ; (binds1, thing) <- go sccs
-        ; return ([(Recursive, binds1)], thing) }
-                -- Rec them all together
-  where
-    mbFirstPatSyn = find (isPatSyn . unLoc) binds
-    isPatSyn PatSynBind{} = True
-    isPatSyn _ = False
-
-    sccs :: [SCC (LHsBind GhcRn)]
-    sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds)
-
-    go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTc, thing)
-    go (scc:sccs) = do  { (binds1, ids1) <- tc_scc scc
-                         -- recursive bindings must be unrestricted
-                         -- (the ids added to the environment here are the name of the recursive definitions).
-                        ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn closed ids1
-                                                            (go sccs)
-                        ; return (binds1 `unionBags` binds2, thing) }
-    go []         = do  { thing <- thing_inside; return (emptyBag, thing) }
-
-    tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
-    tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds
-
-    tc_sub_group rec_tc binds = tcPolyBinds top_lvl sig_fn prag_fn
-                                            Recursive rec_tc closed binds
-
-recursivePatSynErr
-  :: SrcSpan -- ^ The location of the first pattern synonym binding
-             --   (for error reporting)
-  -> LHsBinds GhcRn
-  -> TcM a
-recursivePatSynErr loc binds
-  = failAt loc $ TcRnRecursivePatternSynonym binds
-
-tc_single :: forall thing.
-            TopLevelFlag -> TcSigFun -> TcPragEnv
-          -> LHsBind GhcRn -> IsGroupClosed -> TcM thing
-          -> TcM (LHsBinds GhcTc, thing)
-tc_single _top_lvl sig_fn prag_fn
-          (L loc (PatSynBind _ psb))
-          _ thing_inside
-  = do { (aux_binds, tcg_env) <- tcPatSynDecl (L loc psb) sig_fn prag_fn
-       ; thing <- setGblEnv tcg_env thing_inside
-       ; return (aux_binds, thing)
-       }
-
-tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
-  = do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn
-                                      NonRecursive NonRecursive
-                                      closed
-                                      [lbind]
-         -- since we are defining a non-recursive binding, it is not necessary here
-         -- to define an unrestricted binding. But we do so until toplevel linear bindings are supported.
-       ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside
-       ; return (binds1, thing) }
-
-------------------------
-type BKey = Int -- Just number off the bindings
-
-mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]
--- See Note [Polymorphic recursion] in "GHC.Hs.Binds".
-mkEdges sig_fn binds
-  = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),
-                         Just key <- [lookupNameEnv key_map n], no_sig n ]
-    | (bind, key) <- keyd_binds
-    ]
-    -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices
-    -- is still deterministic even if the edges are in nondeterministic order
-    -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.
-  where
-    bind_fvs (FunBind { fun_ext = fvs }) = fvs
-    bind_fvs (PatBind { pat_ext = fvs }) = fvs
-    bind_fvs _                           = emptyNameSet
-
-    no_sig :: Name -> Bool
-    no_sig n = not (hasCompleteSig sig_fn n)
-
-    keyd_binds = bagToList binds `zip` [0::BKey ..]
-
-    key_map :: NameEnv BKey     -- Which binding it comes from
-    key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
-                                     , bndr <- collectHsBindBinders CollNoDictBinders bind ]
-
-------------------------
-tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragEnv
-            -> RecFlag         -- Whether the group is really recursive
-            -> RecFlag         -- Whether it's recursive after breaking
-                               -- dependencies based on type signatures
-            -> IsGroupClosed   -- Whether the group is closed
-            -> [LHsBind GhcRn]  -- None are PatSynBind
-            -> TcM (LHsBinds GhcTc, [TcId])
-
--- Typechecks a single bunch of values bindings all together,
--- and generalises them.  The bunch may be only part of a recursive
--- group, because we use type signatures to maximise polymorphism
---
--- Returns a list because the input may be a single non-recursive binding,
--- in which case the dependency order of the resulting bindings is
--- important.
---
--- Knows nothing about the scope of the bindings
--- None of the bindings are pattern synonyms
-
-tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list
-  = setSrcSpan loc                              $
-    recoverM (recoveryCode binder_names sig_fn) $ do
-        -- Set up main recover; take advantage of any type sigs
-
-    { traceTc "------------------------------------------------" Outputable.empty
-    ; traceTc "Bindings for {" (ppr binder_names)
-    ; dflags   <- getDynFlags
-    ; let plan = decideGeneralisationPlan dflags top_lvl closed sig_fn bind_list
-    ; traceTc "Generalisation plan" (ppr plan)
-    ; result@(_, poly_ids) <- case plan of
-         NoGen              -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
-         InferGen           -> tcPolyInfer rec_tc prag_fn sig_fn bind_list
-         CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind
-
-    ; mapM_ (\ poly_id ->
-        hasFixedRuntimeRep_syntactic (FRRBinder $ idName poly_id) (idType poly_id))
-        poly_ids
-
-    ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
-                                            , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
-                                          ])
-
-    ; return result }
-  where
-    binder_names = collectHsBindListBinders CollNoDictBinders bind_list
-    loc = foldr1 combineSrcSpans (map (locA . getLoc) bind_list)
-         -- The mbinds have been dependency analysed and
-         -- may no longer be adjacent; so find the narrowest
-         -- span that includes them all
-
---------------
--- If typechecking the binds fails, then return with each
--- signature-less binder given type (forall a.a), to minimise
--- subsequent error messages
-recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTc, [Id])
-recoveryCode binder_names sig_fn
-  = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
-        ; let poly_ids = map mk_dummy binder_names
-        ; return (emptyBag, poly_ids) }
-  where
-    mk_dummy name
-      | Just sig <- sig_fn name
-      , Just poly_id <- completeSigPolyId_maybe sig
-      = poly_id
-      | otherwise
-      = mkLocalId name ManyTy forall_a_a
-
-forall_a_a :: TcType
--- At one point I had (forall r (a :: TYPE r). a), but of course
--- that type is ill-formed: its mentions 'r' which escapes r's scope.
--- Another alternative would be (forall (a :: TYPE kappa). a), where
--- kappa is a unification variable. But I don't think we need that
--- complication here. I'm going to just use (forall (a::*). a).
--- See #15276
-forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy
-
-{- *********************************************************************
-*                                                                      *
-                         tcPolyNoGen
-*                                                                      *
-********************************************************************* -}
-
-tcPolyNoGen     -- No generalisation whatsoever
-  :: RecFlag       -- Whether it's recursive after breaking
-                   -- dependencies based on type signatures
-  -> TcPragEnv -> TcSigFun
-  -> [LHsBind GhcRn]
-  -> TcM (LHsBinds GhcTc, [TcId])
-
-tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
-  = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
-                                             (LetGblBndr prag_fn)
-                                             bind_list
-       ; mono_ids' <- mapM tc_mono_info mono_infos
-       ; return (binds', mono_ids') }
-  where
-    tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id })
-      = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name)
-           ; return mono_id }
-           -- NB: tcPrags generates error messages for
-           --     specialisation pragmas for non-overloaded sigs
-           -- Indeed that is why we call it here!
-           -- So we can safely ignore _specs
-
-
-{- *********************************************************************
-*                                                                      *
-                         tcPolyCheck
-*                                                                      *
-********************************************************************* -}
-
-tcPolyCheck :: TcPragEnv
-            -> TcIdSigInfo     -- Must be a complete signature
-            -> LHsBind GhcRn   -- Must be a FunBind
-            -> TcM (LHsBinds GhcTc, [TcId])
--- There is just one binding,
---   it is a FunBind
---   it has a complete type signature,
-tcPolyCheck prag_fn
-            (CompleteSig { sig_bndr  = poly_id
-                         , sig_ctxt  = ctxt
-                         , sig_loc   = sig_loc })
-            (L bind_loc (FunBind { fun_id = L nm_loc name
-                                 , fun_matches = matches }))
-  = do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
-
-       ; mono_name <- newNameAt (nameOccName name) (locA nm_loc)
-       ; (wrap_gen, (wrap_res, matches'))
-             <- setSrcSpan sig_loc $ -- Sets the binding location for the skolems
-                tcSkolemiseScoped ctxt (idType poly_id) $ \rho_ty ->
-                -- Unwraps multiple layers; e.g
-                --    f :: forall a. Eq a => forall b. Ord b => blah
-                -- NB: tcSkolemiseScoped makes fresh type variables
-                -- See Note [Instantiate sig with fresh variables]
-
-                let mono_id = mkLocalId mono_name (varMult poly_id) rho_ty in
-                tcExtendBinderStack [TcIdBndr mono_id NotTopLevel] $
-                -- Why mono_id in the BinderStack?
-                --    See Note [Relevant bindings and the binder stack]
-
-                setSrcSpanA bind_loc $
-                tcMatchesFun (L nm_loc mono_id) matches
-                             (mkCheckExpType rho_ty)
-
-       -- We make a funny AbsBinds, abstracting over nothing,
-       -- just so we have somewhere to put the SpecPrags.
-       -- Otherwise we could just use the FunBind
-       -- Hence poly_id2 is just a clone of poly_id;
-       -- We re-use mono-name, but we could equally well use a fresh one
-
-       ; let prag_sigs = lookupPragEnv prag_fn name
-             poly_id2  = mkLocalId mono_name (idMult poly_id) (idType poly_id)
-       ; spec_prags <- tcSpecPrags    poly_id prag_sigs
-       ; poly_id    <- addInlinePrags poly_id prag_sigs
-
-       ; mod <- getModule
-       ; tick <- funBindTicks (locA nm_loc) poly_id mod prag_sigs
-
-       ; let bind' = FunBind { fun_id      = L nm_loc poly_id2
-                             , fun_matches = matches'
-                             , fun_ext     = (wrap_gen <.> wrap_res, tick)
-                             }
-
-             export = ABE { abe_wrap  = idHsWrapper
-                          , abe_poly  = poly_id
-                          , abe_mono  = poly_id2
-                          , abe_prags = SpecPrags spec_prags }
-
-             abs_bind = L bind_loc $ XHsBindsLR $
-                        AbsBinds { abs_tvs      = []
-                                 , abs_ev_vars  = []
-                                 , abs_ev_binds = []
-                                 , abs_exports  = [export]
-                                 , abs_binds    = unitBag (L bind_loc bind')
-                                 , abs_sig      = True }
-
-       ; return (unitBag abs_bind, [poly_id]) }
-
-tcPolyCheck _prag_fn sig bind
-  = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)
-
-funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
-             -> TcM [CoreTickish]
-funBindTicks loc fun_id mod sigs
-  | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ]
-      -- this can only be a singleton list, as duplicate pragmas are rejected
-      -- by the renamer
-  , let cc_str
-          | Just cc_str <- mb_cc_str
-          = sl_fs $ unLoc cc_str
-          | otherwise
-          = getOccFS (Var.varName fun_id)
-        cc_name = concatFS [moduleNameFS (moduleName mod), fsLit ".", cc_str]
-  = do
-      flavour <- DeclCC <$> getCCIndexTcM cc_name
-      let cc = mkUserCC cc_name mod loc flavour
-      return [ProfNote cc True True]
-  | otherwise
-  = return []
-
-{- Note [Instantiate sig with fresh variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's vital to instantiate a type signature with fresh variables.
-For example:
-      type T = forall a. [a] -> [a]
-      f :: T;
-      f = g where { g :: T; g = <rhs> }
-
- We must not use the same 'a' from the defn of T at both places!!
-(Instantiation is only necessary because of type synonyms.  Otherwise,
-it's all cool; each signature has distinct type variables from the renamer.)
--}
-
-
-{- *********************************************************************
-*                                                                      *
-                         tcPolyInfer
-*                                                                      *
-********************************************************************* -}
-
-tcPolyInfer
-  :: RecFlag       -- Whether it's recursive after breaking
-                   -- dependencies based on type signatures
-  -> TcPragEnv -> TcSigFun
-  -> [LHsBind GhcRn]
-  -> TcM (LHsBinds GhcTc, [TcId])
-tcPolyInfer rec_tc prag_fn tc_sig_fn bind_list
-  = do { (tclvl, wanted, (binds', mono_infos))
-             <- pushLevelAndCaptureConstraints  $
-                tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
-
-       ; apply_mr <- checkMonomorphismRestriction mono_infos bind_list
-       ; traceTc "tcPolyInfer" (ppr apply_mr $$ ppr (map mbi_sig mono_infos))
-
-       ; let name_taus  = [ (mbi_poly_name info, idType (mbi_mono_id info))
-                          | info <- mono_infos ]
-             sigs       = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]
-             infer_mode = if apply_mr then ApplyMR else NoRestrictions
-
-       ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
-       ; ((qtvs, givens, ev_binds, insoluble), residual)
-            <- captureConstraints $ simplifyInfer tclvl infer_mode sigs name_taus wanted
-
-       ; let inferred_theta = map evVarPred givens
-       ; exports <- checkNoErrs $
-                    mapM (mkExport prag_fn residual insoluble qtvs inferred_theta) mono_infos
-
-         -- NB: *after* the checkNoErrs call above. This ensures that we don't get an error
-         -- cascade in case mkExport runs into trouble. In particular, this avoids duplicate
-         -- errors when a partial type signature cannot be quantified in chooseInferredQuantifiers.
-         -- See Note [Quantification and partial signatures] in GHC.Tc.Solver, Wrinkle 4.
-         -- Tested in partial-sigs/should_fail/NamedWilcardExplicitForall.
-       ; emitConstraints residual
-
-       ; loc <- getSrcSpanM
-       ; let poly_ids = map abe_poly exports
-             abs_bind = L (noAnnSrcSpan loc) $ XHsBindsLR $
-                        AbsBinds { abs_tvs = qtvs
-                                 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
-                                 , abs_exports = exports, abs_binds = binds'
-                                 , abs_sig = False }
-
-       ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
-       ; return (unitBag abs_bind, poly_ids) }
-         -- poly_ids are guaranteed zonked by mkExport
-
-checkMonomorphismRestriction :: [MonoBindInfo] -> [LHsBind GhcRn] -> TcM Bool
--- True <=> apply the MR
-checkMonomorphismRestriction mbis lbinds
-  | null partial_sigs  -- The normal case
-  = do { mr_on <- xoptM LangExt.MonomorphismRestriction
-       ; let mr_applies = mr_on && any (restricted . unLoc) lbinds
-       ; when mr_applies $ mapM_ checkOverloadedSig sigs
-       ; return mr_applies }
-
-  | otherwise    -- See Note [Partial type signatures and the monomorphism restriction]
-  = return (all is_mono_psig partial_sigs)
-
-  where
-    sigs, partial_sigs :: [TcIdSigInst]
-    sigs          = [sig | MBI { mbi_sig = Just sig } <- mbis]
-    partial_sigs  = [sig | sig@(TISI { sig_inst_sig = PartialSig {} }) <- sigs]
-
-    complete_sig_bndrs :: NameSet
-    complete_sig_bndrs
-      = mkNameSet [ idName bndr
-                  | TISI { sig_inst_sig = CompleteSig { sig_bndr = bndr }} <- sigs ]
-
-    is_mono_psig (TISI { sig_inst_theta = theta, sig_inst_wcx = mb_extra_constraints })
-       = null theta && isNothing mb_extra_constraints
-
-    -- The Haskell 98 monomorphism restriction
-    restricted (PatBind {})                              = True
-    restricted (VarBind { var_id = v })                  = no_sig v
-    restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
-                                                           && no_sig (unLoc v)
-    restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b)
-
-    restricted_match mg = matchGroupArity mg == 0
-        -- No args => like a pattern binding
-        -- Some args => a function binding
-
-    no_sig nm = not (nm `elemNameSet` complete_sig_bndrs)
-
-checkOverloadedSig :: TcIdSigInst -> TcM ()
--- Example:
---   f :: Eq a => a -> a
---   K f = e
--- The MR applies, but the signature is overloaded, and it's
--- best to complain about this directly
--- c.f #11339
-checkOverloadedSig sig
-  | not (null (sig_inst_theta sig))
-  , let orig_sig = sig_inst_sig sig
-  = setSrcSpan (sig_loc orig_sig) $
-    failWith $ TcRnOverloadedSig orig_sig
-  | otherwise
-  = return ()
-
---------------
-mkExport :: TcPragEnv
-         -> WantedConstraints  -- residual constraints, already emitted (for errors only)
-         -> Bool                        -- True <=> there was an insoluble type error
-                                        --          when typechecking the bindings
-         -> [TyVar] -> TcThetaType      -- Both already zonked
-         -> MonoBindInfo
-         -> TcM ABExport
--- Only called for generalisation plan InferGen, not by CheckGen or NoGen
---
--- mkExport generates exports with
---      zonked type variables,
---      zonked poly_ids
--- The former is just because no further unifications will change
--- the quantified type variables, so we can fix their final form
--- right now.
--- The latter is needed because the poly_ids are used to extend the
--- type environment; see the invariant on GHC.Tc.Utils.Env.tcExtendIdEnv
-
--- Pre-condition: the qtvs and theta are already zonked
-
-mkExport prag_fn residual insoluble qtvs theta
-         (MBI { mbi_poly_name = poly_name
-              , mbi_sig       = mb_sig
-              , mbi_mono_id   = mono_id })
-  = do  { mono_ty <- zonkTcType (idType mono_id)
-        ; poly_id <- mkInferredPolyId residual insoluble qtvs theta poly_name mb_sig mono_ty
-
-        -- NB: poly_id has a zonked type
-        ; poly_id <- addInlinePrags poly_id prag_sigs
-        ; spec_prags <- tcSpecPrags poly_id prag_sigs
-                -- tcPrags requires a zonked poly_id
-
-        -- See Note [Impedance matching]
-        -- NB: we have already done checkValidType, including an ambiguity check,
-        --     on the type; either when we checked the sig or in mkInferredPolyId
-        ; let poly_ty     = idType poly_id
-              sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty
-                -- This type is just going into tcSubType,
-                -- so Inferred vs. Specified doesn't matter
-
-        ; traceTc "mkExport" (vcat [ ppr poly_id <+> dcolon <+> ppr poly_ty
-                                   , ppr sel_poly_ty ])
-
-        ; wrap <- if sel_poly_ty `eqType` poly_ty  -- NB: eqType ignores visibility
-                  then return idHsWrapper  -- Fast path; also avoids complaint when we infer
-                                           -- an ambiguous type and have AllowAmbiguousType
-                                           -- e..g infer  x :: forall a. F a -> Int
-                  else tcSubTypeSigma GhcBug20076
-                                      sig_ctxt sel_poly_ty poly_ty
-                       -- as Note [Impedance matching] explains, this should never fail,
-                       -- and thus we'll never see an error message. It *may* do
-                       -- instantiation, but no message will ever be printed to the
-                       -- user, and so we use Shouldn'tHappenOrigin.
-                       -- Actually, there is a bug here: #20076. So we tell the user
-                       -- that they hit the bug. Once #20076 is fixed, change this
-                       -- back to Shouldn'tHappenOrigin.
-
-        ; localSigWarn poly_id mb_sig
-
-        ; return (ABE { abe_wrap = wrap
-                        -- abe_wrap :: (forall qtvs. theta => mono_ty) ~ idType poly_id
-                      , abe_poly  = poly_id
-                      , abe_mono  = mono_id
-                      , abe_prags = SpecPrags spec_prags }) }
-  where
-    prag_sigs = lookupPragEnv prag_fn poly_name
-    sig_ctxt  = InfSigCtxt poly_name
-
-mkInferredPolyId :: WantedConstraints   -- the residual constraints, already emitted
-                 -> Bool  -- True <=> there was an insoluble error when
-                          --          checking the binding group for this Id
-                 -> [TyVar] -> TcThetaType
-                 -> Name -> Maybe TcIdSigInst -> TcType
-                 -> TcM TcId
-mkInferredPolyId residual insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty
-  | Just (TISI { sig_inst_sig = sig })  <- mb_sig_inst
-  , CompleteSig { sig_bndr = poly_id } <- sig
-  = return poly_id
-
-  | otherwise  -- Either no type sig or partial type sig
-  = checkNoErrs $  -- The checkNoErrs ensures that if the type is ambiguous
-                   -- we don't carry on to the impedance matching, and generate
-                   -- a duplicate ambiguity error.  There is a similar
-                   -- checkNoErrs for complete type signatures too.
-    do { fam_envs <- tcGetFamInstEnvs
-       ; let mono_ty' = reductionReducedType $ normaliseType fam_envs Nominal mono_ty
-               -- Unification may not have normalised the type,
-               -- so do it here to make it as uncomplicated as possible.
-               -- Example: f :: [F Int] -> Bool
-               -- should be rewritten to f :: [Char] -> Bool, if possible
-               --
-               -- We can discard the coercion _co, because we'll reconstruct
-               -- it in the call to tcSubType below
-
-       ; (binders, theta') <- chooseInferredQuantifiers residual inferred_theta
-                                (tyCoVarsOfType mono_ty') qtvs mb_sig_inst
-
-       ; let inferred_poly_ty = mkInvisForAllTys binders (mkPhiTy theta' mono_ty')
-
-       ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta'
-                                          , ppr inferred_poly_ty])
-       ; unless insoluble $
-         addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
-         checkValidType (InfSigCtxt poly_name) inferred_poly_ty
-         -- See Note [Validity of inferred types]
-         -- If we found an insoluble error in the function definition, don't
-         -- do this check; otherwise (#14000) we may report an ambiguity
-         -- error for a rather bogus type.
-
-       ; return (mkLocalId poly_name ManyTy inferred_poly_ty) }
-
-
-chooseInferredQuantifiers :: WantedConstraints  -- residual constraints
-                          -> TcThetaType   -- inferred
-                          -> TcTyVarSet    -- tvs free in tau type
-                          -> [TcTyVar]     -- inferred quantified tvs
-                          -> Maybe TcIdSigInst
-                          -> TcM ([InvisTVBinder], TcThetaType)
-chooseInferredQuantifiers _residual inferred_theta tau_tvs qtvs Nothing
-  = -- No type signature (partial or complete) for this binder,
-    do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)
-                        -- See Note [growThetaTyVars vs closeWrtFunDeps] in GHC.Tc.Solver
-                        -- Include kind variables!  #7916
-             my_theta = pickCapturedPreds free_tvs inferred_theta
-             binders  = [ mkTyVarBinder InferredSpec tv
-                        | tv <- qtvs
-                        , tv `elemVarSet` free_tvs ]
-       ; return (binders, my_theta) }
-
-chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs
-  (Just (TISI { sig_inst_sig   = sig@(PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty })
-              , sig_inst_wcx   = wcx
-              , sig_inst_theta = annotated_theta
-              , sig_inst_skols = annotated_tvs }))
-  = -- Choose quantifiers for a partial type signature
-    do { let (psig_qtv_nms, psig_qtv_bndrs) = unzip annotated_tvs
-       ; psig_qtv_bndrs <- mapM zonkInvisTVBinder psig_qtv_bndrs
-       ; let psig_qtvs    = map binderVar psig_qtv_bndrs
-             psig_qtv_set = mkVarSet psig_qtvs
-             psig_qtv_prs = psig_qtv_nms `zip` psig_qtvs
-             psig_bndr_map :: TyVarEnv InvisTVBinder
-             psig_bndr_map = mkVarEnv [ (binderVar tvb, tvb) | tvb <- psig_qtv_bndrs ]
-
-            -- Check whether the quantified variables of the
-            -- partial signature have been unified together
-            -- See Note [Quantified variables in partial type signatures]
-       ; mapM_ report_dup_tyvar_tv_err  (findDupTyVarTvs psig_qtv_prs)
-
-            -- Check whether a quantified variable of the partial type
-            -- signature is not actually quantified.  How can that happen?
-            -- See Note [Quantification and partial signatures] Wrinkle 4
-            --     in GHC.Tc.Solver
-       ; mapM_ report_mono_sig_tv_err [ pr | pr@(_,tv) <- psig_qtv_prs
-                                           , not (tv `elem` qtvs) ]
-
-       ; annotated_theta      <- zonkTcTypes annotated_theta
-       ; (free_tvs, my_theta) <- choose_psig_context psig_qtv_set annotated_theta wcx
-                                 -- NB: free_tvs includes tau_tvs
-
-       ; let (_,final_qtvs) = foldr (choose_qtv psig_bndr_map) (free_tvs, []) qtvs
-                              -- Pulling from qtvs maintains original order
-                              -- NB: qtvs is already in dependency order
-
-       ; traceTc "chooseInferredQuantifiers" $
-         vcat [ text "qtvs" <+> pprTyVars qtvs
-              , text "psig_qtv_bndrs" <+> ppr psig_qtv_bndrs
-              , text "free_tvs" <+> ppr free_tvs
-              , text "final_tvs" <+> ppr final_qtvs ]
-
-       ; return (final_qtvs, my_theta) }
-  where
-    choose_qtv :: TyVarEnv InvisTVBinder -> TcTyVar
-             -> (TcTyVarSet, [InvisTVBinder]) -> (TcTyVarSet, [InvisTVBinder])
-    -- Pick which of the original qtvs should be retained
-    -- Keep it if (a) it is mentioned in the body of the type (free_tvs)
-    --            (b) it is a forall'd variable of the partial signature (psig_qtv_bndrs)
-    --            (c) it is mentioned in the kind of a retained qtv (#22065)
-    choose_qtv psig_bndr_map tv (free_tvs, qtvs)
-       | Just psig_bndr <- lookupVarEnv psig_bndr_map tv
-       = (free_tvs', psig_bndr : qtvs)
-       | tv `elemVarSet` free_tvs
-       = (free_tvs', mkTyVarBinder InferredSpec tv : qtvs)
-       | otherwise  -- Do not pick it
-       = (free_tvs, qtvs)
-       where
-         free_tvs' = free_tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv)
-
-    choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType
-                        -> TcM (VarSet, TcThetaType)
-    choose_psig_context _ annotated_theta Nothing
-      = do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
-                                            `unionVarSet` tau_tvs)
-           ; return (free_tvs, annotated_theta) }
-
-    choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty)
-      = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)
-                            -- growThetaTyVars just like the no-type-sig case
-                            -- See Note [growThetaTyVars vs closeWrtFunDeps] in GHC.Tc.Solver
-                            -- Omitting this caused #12844
-                 seed_tvs = tyCoVarsOfTypes annotated_theta  -- These are put there
-                            `unionVarSet` tau_tvs            --       by the user
-
-           ; let keep_me  = psig_qtvs `unionVarSet` free_tvs
-                 my_theta = pickCapturedPreds keep_me inferred_theta
-
-           -- Fill in the extra-constraints wildcard hole with inferred_theta,
-           -- so that the Hole constraint we have already emitted
-           -- (in tcHsPartialSigType) can report what filled it in.
-           -- NB: my_theta already includes all the annotated constraints
-           ; diff_theta <- findInferredDiff annotated_theta my_theta
-
-           ; case getCastedTyVar_maybe wc_var_ty of
-               -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it
-               -- comes from the checkExpectedKind in GHC.Tc.Gen.HsType.tcAnonWildCardOcc.
-               -- So, to make the kinds work out, we reverse the cast here.
-               Just (wc_var, wc_co) -> writeMetaTyVar wc_var (mkConstraintTupleTy diff_theta
-                                                              `mkCastTy` mkSymCo wc_co)
-               Nothing              -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty)
-
-           ; traceTc "completeTheta" $
-                vcat [ ppr sig
-                     , text "annotated_theta:" <+> ppr annotated_theta
-                     , text "inferred_theta:" <+> ppr inferred_theta
-                     , text "my_theta:" <+> ppr my_theta
-                     , text "diff_theta:" <+> ppr diff_theta ]
-           ; return (free_tvs, annotated_theta ++ diff_theta) }
-             -- Return (annotated_theta ++ diff_theta)
-             -- See Note [Extra-constraints wildcards]
-
-    report_dup_tyvar_tv_err (n1,n2)
-      = addErrTc (TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty)
-
-    report_mono_sig_tv_err (n,tv)
-      = addErrTc (TcRnPartialTypeSigBadQuantifier n fn_name m_unif_ty hs_ty)
-      where
-        m_unif_ty = listToMaybe
-                      [ rhs
-                      -- recall that residuals are always implications
-                      | residual_implic <- bagToList $ wc_impl residual
-                      , residual_ct <- bagToList $ wc_simple (ic_wanted residual_implic)
-                      , let residual_pred = ctPred residual_ct
-                      , Just (Nominal, lhs, rhs) <- [ getEqPredTys_maybe residual_pred ]
-                      , Just lhs_tv <- [ getTyVar_maybe lhs ]
-                      , lhs_tv == tv ]
-
-chooseInferredQuantifiers _ _ _ _ (Just (TISI { sig_inst_sig = sig@(CompleteSig {}) }))
-  = pprPanic "chooseInferredQuantifiers" (ppr sig)
-
-mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
-mk_inf_msg poly_name poly_ty tidy_env
- = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty
-      ; let msg = vcat [ text "When checking the inferred type"
-                       , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
-      ; return (tidy_env1, msg) }
-
--- | Warn the user about polymorphic local binders that lack type signatures.
-localSigWarn :: Id -> Maybe TcIdSigInst -> TcM ()
-localSigWarn id mb_sig
-  | Just _ <- mb_sig               = return ()
-  | not (isSigmaTy (idType id))    = return ()
-  | otherwise                      = warnMissingSignatures id
-
-warnMissingSignatures :: Id -> TcM ()
-warnMissingSignatures id
-  = do  { env0 <- tcInitTidyEnv
-        ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
-        ; let dia = TcRnPolymorphicBinderMissingSig (idName id) tidy_ty
-        ; addDiagnosticTcM (env1, dia) }
-
-{- Note [Partial type signatures and generalisation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If /any/ of the signatures in the group is a partial type signature
-   f :: _ -> Int
-then we *always* use the InferGen plan, and hence tcPolyInfer.
-We do this even for a local binding with -XMonoLocalBinds, when
-we normally use NoGen.
-
-Reasons:
-  * The TcSigInfo for 'f' has a unification variable for the '_',
-    whose TcLevel is one level deeper than the current level.
-    (See pushTcLevelM in tcTySig.)  But NoGen doesn't increase
-    the TcLevel like InferGen, so we lose the level invariant.
-
-  * The signature might be   f :: forall a. _ -> a
-    so it really is polymorphic.  It's not clear what it would
-    mean to use NoGen on this, and indeed the ASSERT in tcLhs,
-    in the (Just sig) case, checks that if there is a signature
-    then we are using LetLclBndr, and hence a nested AbsBinds with
-    increased TcLevel
-
-It might be possible to fix these difficulties somehow, but there
-doesn't seem much point.  Indeed, adding a partial type signature is a
-way to get per-binding inferred generalisation.
-
-Note [Partial type signatures and the monomorphism restriction]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We apply the MR if /none/ of the partial signatures has a context. e.g.
-   f :: _ -> Int
-   f x = rhs
-The partial type signature says, in effect, "there is no context", which
-amounts to appplying the MR. Indeed, saying
-   f :: _
-   f = rhs
-is a way for forcing the MR to apply.
-
-But we /don't/ want to apply the MR if the partial signatures do have
-a context  e.g. (#11016):
-   f2 :: (?loc :: Int) => _
-   f2 = ?loc
-It's stupid to apply the MR here.  This test includes an extra-constraints
-wildcard; that is, we don't apply the MR if you write
-   f3 :: _ => blah
-
-But watch out.  We don't want to apply the MR to
-   type Wombat a = forall b. Eq b => ...b...a...
-   f4 :: Wombat _
-Here f4 doesn't /look/ as if it has top-level overloading, but in fact it
-does, hidden under Wombat.  We can't "see" that because we only have access
-to the HsType at the moment.  That's why we do the check in
-checkMonomorphismRestriction.
-
-Note [Quantified variables in partial type signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  f :: forall a. a -> a -> _
-  f x y = g x y
-  g :: forall b. b -> b -> _
-  g x y = [x, y]
-
-Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b'
-together, which is fine.  So we bind 'a' and 'b' to TyVarTvs, which can then
-unify with each other.
-
-But now consider:
-  f :: forall a b. a -> b -> _
-  f x y = [x, y]
-
-We want to get an error from this, because 'a' and 'b' get unified.
-So we make a test, one per partial signature, to check that the
-explicitly-quantified type variables have not been unified together.
-#14449 showed this up.
-
-Note [Extra-constraints wildcards]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this from #18646
-    class Foo x where
-      foo :: x
-
-    bar :: (Foo (), _) => f ()
-    bar = pure foo
-
-We get [W] Foo (), [W] Applicative f.   When we do pickCapturedPreds in
-choose_psig_context, we'll discard Foo ()!  Usually would not quantify over
-such (closed) predicates.  So my_theta will be (Applicative f). But we really
-do want to quantify over (Foo ()) -- it was specified by the programmer.
-Solution: always return annotated_theta (user-specified) plus the extra piece
-diff_theta.
-
-Note [Validity of inferred types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We need to check inferred type for validity, in case it uses language
-extensions that are not turned on.  The principle is that if the user
-simply adds the inferred type to the program source, it'll compile fine.
-See #8883.
-
-Examples that might fail:
- - the type might be ambiguous
-
- - an inferred theta that requires type equalities e.g. (F a ~ G b)
-                                or multi-parameter type classes
- - an inferred type that includes unboxed tuples
-
-Note [Impedance matching]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   f 0 x = x
-   f n x = g [] (not x)
-
-   g [] y = f 10 y
-   g _  y = f 9  y
-
-After typechecking we'll get
-  f_mono_ty :: a -> Bool -> Bool
-  g_mono_ty :: [b] -> Bool -> Bool
-with constraints
-  (Eq a, Num a)
-
-Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
-The types we really want for f and g are
-   f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
-   g :: forall b. [b] -> Bool -> Bool
-
-We can get these by "impedance matching":
-   tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
-   tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
-
-   f a d1 d2 = case tuple a Any d1 d2 of (f_mono, g_mono) -> f_mono
-   g b = case tuple Integer b dEqInteger dNumInteger of (f_mono,g_mono) -> g_mono
-
-Suppose the shared quantified tyvars are qtvs and constraints theta.
-Then we want to check that
-     forall qtvs. theta => f_mono_ty   is more polymorphic than   f's polytype
-and the proof is the impedance matcher.
-
-Notice that the impedance matcher may do defaulting.  See #7173.
-
-If we've gotten the constraints right during inference (and we assume we have),
-this sub-type check should never fail. It's not really a check -- it's more of
-a procedure to produce the right wrapper.
-
-Note [SPECIALISE pragmas]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-There is no point in a SPECIALISE pragma for a non-overloaded function:
-   reverse :: [a] -> [a]
-   {-# SPECIALISE reverse :: [Int] -> [Int] #-}
-
-But SPECIALISE INLINE *can* make sense for GADTS:
-   data Arr e where
-     ArrInt :: !Int -> ByteArray# -> Arr Int
-     ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
-
-   (!:) :: Arr e -> Int -> e
-   {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
-   {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
-   (ArrInt _ ba)     !: (I# i) = I# (indexIntArray# ba i)
-   (ArrPair _ a1 a2) !: i      = (a1 !: i, a2 !: i)
-
-When (!:) is specialised it becomes non-recursive, and can usefully
-be inlined.  Scary!  So we only warn for SPECIALISE *without* INLINE
-for a non-overloaded function.
-
-************************************************************************
-*                                                                      *
-                         tcMonoBinds
-*                                                                      *
-************************************************************************
-
-@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
-The signatures have been dealt with already.
--}
-
-data MonoBindInfo = MBI { mbi_poly_name :: Name
-                        , mbi_sig       :: Maybe TcIdSigInst
-                        , mbi_mono_id   :: TcId }
-
-tcMonoBinds :: RecFlag  -- Whether the binding is recursive for typechecking purposes
-                        -- i.e. the binders are mentioned in their RHSs, and
-                        --      we are not rescued by a type signature
-            -> TcSigFun -> LetBndrSpec
-            -> [LHsBind GhcRn]
-            -> TcM (LHsBinds GhcTc, [MonoBindInfo])
-
--- SPECIAL CASE 1: see Note [Special case for non-recursive function bindings]
-tcMonoBinds is_rec sig_fn no_gen
-           [ L b_loc (FunBind { fun_id = L nm_loc name
-                              , fun_matches = matches })]
-                             -- Single function binding,
-  | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
-  , Nothing <- sig_fn name   -- ...with no type signature
-  = setSrcSpanA b_loc    $
-    do  { ((co_fn, matches'), mono_id, _) <- fixM $ \ ~(_, _, rhs_ty) ->
-                                          -- See Note [fixM for rhs_ty in tcMonoBinds]
-            do  { mono_id <- newLetBndr no_gen name ManyTy rhs_ty
-                ; (matches', rhs_ty')
-                    <- tcInfer $ \ exp_ty ->
-                       tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
-                          -- We extend the error context even for a non-recursive
-                          -- function so that in type error messages we show the
-                          -- type of the thing whose rhs we are type checking
-                       tcMatchesFun (L nm_loc mono_id) matches exp_ty
-                ; return (matches', mono_id, rhs_ty')
-                }
-
-        ; return (unitBag $ L b_loc $
-                     FunBind { fun_id = L nm_loc mono_id,
-                               fun_matches = matches',
-                               fun_ext = (co_fn, []) },
-                  [MBI { mbi_poly_name = name
-                       , mbi_sig       = Nothing
-                       , mbi_mono_id   = mono_id }]) }
-
--- SPECIAL CASE 2: see Note [Special case for non-recursive pattern bindings]
-tcMonoBinds is_rec sig_fn no_gen
-           [L b_loc (PatBind { pat_lhs = pat, pat_rhs = grhss })]
-  | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
-  , all (isNothing . sig_fn) bndrs
-  = addErrCtxt (patMonoBindsCtxt pat grhss) $
-    do { (grhss', pat_ty) <- tcInfer $ \ exp_ty ->
-                             tcGRHSsPat grhss exp_ty
-
-       ; let exp_pat_ty :: Scaled ExpSigmaTypeFRR
-             exp_pat_ty = unrestricted (mkCheckExpType pat_ty)
-       ; (pat', mbis) <- tcLetPat (const Nothing) no_gen pat exp_pat_ty $
-                         mapM lookupMBI bndrs
-
-       ; return ( unitBag $ L b_loc $
-                     PatBind { pat_lhs = pat', pat_rhs = grhss'
-                             , pat_ext = (pat_ty, ([],[])) }
-
-                , mbis ) }
-  where
-    bndrs = collectPatBinders CollNoDictBinders pat
-
--- GENERAL CASE
-tcMonoBinds _ sig_fn no_gen binds
-  = do  { tc_binds <- mapM (wrapLocMA (tcLhs sig_fn no_gen)) binds
-
-        -- Bring the monomorphic Ids, into scope for the RHSs
-        ; let mono_infos = getMonoBindInfo tc_binds
-              rhs_id_env = [ (name, mono_id)
-                           | MBI { mbi_poly_name = name
-                                 , mbi_sig       = mb_sig
-                                 , mbi_mono_id   = mono_id } <- mono_infos
-                           , case mb_sig of
-                               Just sig -> isPartialSig sig
-                               Nothing  -> True ]
-                -- A monomorphic binding for each term variable that lacks
-                -- a complete type sig.  (Ones with a sig are already in scope.)
-
-        ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
-                                       | (n,id) <- rhs_id_env]
-        ; binds' <- tcExtendRecIds rhs_id_env $
-                    mapM (wrapLocMA tcRhs) tc_binds
-
-        ; return (listToBag binds', mono_infos) }
-
-{- Note [Special case for non-recursive function bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In the special case of
-* A non-recursive FunBind
-* With no type signature
-we infer the type of the right hand side first (it may have a
-higher-rank type) and *then* make the monomorphic Id for the LHS e.g.
-   f = \(x::forall a. a->a) -> <body>
-
-We want to infer a higher-rank type for f
-
-Note [Special case for non-recursive pattern bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In the special case of
-* A pattern binding
-* With no type signature for any of the binders
-we can /infer/ the type of the RHS, and /check/ the pattern
-against that type.  For example (#18323)
-
-  ids :: [forall a. a -> a]
-  combine :: (forall a . [a] -> a) -> [forall a. a -> a]
-          -> ((forall a . [a] -> a), [forall a. a -> a])
-
-  (x,y) = combine head ids
-
-with -XImpredicativeTypes we can infer a good type for
-(combine head ids), and use that to tell us the polymorphic
-types of x and y.
-
-We don't need to check -XImpredicativeTypes because without it
-these types like [forall a. a->a] are illegal anyway, so this
-special case code only really has an effect if -XImpredicativeTypes
-is on.  Small exception:
-  (x) = e
-is currently treated as a pattern binding so, even absent
--XImpredicativeTypes, we will get a small improvement in behaviour.
-But I don't think it's worth an extension flag.
-
-Why do we require no type signatures on /any/ of the binders?
-Consider
-   x :: forall a. a->a
-   y :: forall a. a->a
-   (x,y) = (id,id)
-
-Here we should /check/ the RHS with expected type
-  (forall a. a->a, forall a. a->a).
-
-If we have no signatures, we can the approach of this Note
-to /infer/ the type of the RHS.
-
-But what if we have some signatures, but not all? Say this:
-  p :: forall a. a->a
-  (p,q) = (id,  (\(x::forall b. b->b). x True))
-
-Here we want to push p's signature inwards, i.e. /checking/, to
-correctly elaborate 'id'. But we want to /infer/ q's higher rank
-type.  There seems to be no way to do this.  So currently we only
-switch to inference when we have no signature for any of the binders.
-
-Note [fixM for rhs_ty in tcMonoBinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In order to create mono_id we need rhs_ty but we don't have it yet,
-we only get it from tcMatchesFun later (which needs mono_id to put
-into HsMatchContext for pretty printing). To solve this, create
-a thunk of rhs_ty with fixM that we fill in later.
-
-This is fine only because neither newLetBndr or tcMatchesFun look
-at the varType field of the Id. tcMatchesFun only looks at idName
-of mono_id.
-
-Also see #20415 for the bigger picture of why tcMatchesFun needs
-mono_id in the first place.
--}
-
-
-------------------------
--- tcLhs typechecks the LHS of the bindings, to construct the environment in which
--- we typecheck the RHSs.  Basically what we are doing is this: for each binder:
---      if there's a signature for it, use the instantiated signature type
---      otherwise invent a type variable
--- You see that quite directly in the FunBind case.
---
--- But there's a complication for pattern bindings:
---      data T = MkT (forall a. a->a)
---      MkT f = e
--- Here we can guess a type variable for the entire LHS (which will be refined to T)
--- but we want to get (f::forall a. a->a) as the RHS environment.
--- The simplest way to do this is to typecheck the pattern, and then look up the
--- bound mono-ids.  Then we want to retain the typechecked pattern to avoid re-doing
--- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
-
-data TcMonoBind         -- Half completed; LHS done, RHS not done
-  = TcFunBind  MonoBindInfo  SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn))
-  | TcPatBind [MonoBindInfo] (LPat GhcTc) (GRHSs GhcRn (LHsExpr GhcRn))
-              TcSigmaTypeFRR
-
-tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind
--- Only called with plan InferGen (LetBndrSpec = LetLclBndr)
---                    or NoGen    (LetBndrSpec = LetGblBndr)
--- CheckGen is used only for functions with a complete type signature,
---          and tcPolyCheck doesn't use tcMonoBinds at all
-
-tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name
-                             , fun_matches = matches })
-  | Just (TcIdSig sig) <- sig_fn name
-  = -- There is a type signature.
-    -- It must be partial; if complete we'd be in tcPolyCheck!
-    --    e.g.   f :: _ -> _
-    --           f x = ...g...
-    --           Just g = ...f...
-    -- Hence always typechecked with InferGen
-    do { mono_info <- tcLhsSigId no_gen (name, sig)
-       ; return (TcFunBind mono_info (locA nm_loc) matches) }
-
-  | otherwise  -- No type signature
-  = do { mono_ty <- newOpenFlexiTyVarTy
-       ; mono_id <- newLetBndr no_gen name ManyTy mono_ty
-          -- This ^ generates a binder with Many multiplicity because all
-          -- let/where-binders are unrestricted. When we introduce linear let
-          -- binders, we will need to retrieve the multiplicity information.
-       ; let mono_info = MBI { mbi_poly_name = name
-                             , mbi_sig       = Nothing
-                             , mbi_mono_id   = mono_id }
-       ; return (TcFunBind mono_info (locA nm_loc) matches) }
-
-tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
-  = -- See Note [Typechecking pattern bindings]
-    do  { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names
-
-        ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $
-                             [ (mbi_poly_name mbi, mbi_mono_id mbi)
-                             | mbi <- sig_mbis ]
-
-            -- See Note [Typechecking pattern bindings]
-        ; ((pat', nosig_mbis), pat_ty)
-            <- addErrCtxt (patMonoBindsCtxt pat grhss) $
-               tcInferFRR FRRPatBind $ \ exp_ty ->
-               tcLetPat inst_sig_fun no_gen pat (unrestricted exp_ty) $
-                 -- The above inferred type get an unrestricted multiplicity. It may be
-                 -- worth it to try and find a finer-grained multiplicity here
-                 -- if examples warrant it.
-               mapM lookupMBI nosig_names
-
-        ; let mbis = sig_mbis ++ nosig_mbis
-
-        ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id)
-                                | mbi <- mbis, let id = mbi_mono_id mbi ]
-                           $$ ppr no_gen)
-
-        ; return (TcPatBind mbis pat' grhss pat_ty) }
-  where
-    bndr_names = collectPatBinders CollNoDictBinders pat
-    (nosig_names, sig_names) = partitionWith find_sig bndr_names
-
-    find_sig :: Name -> Either Name (Name, TcIdSigInfo)
-    find_sig name = case sig_fn name of
-                      Just (TcIdSig sig) -> Right (name, sig)
-                      _                  -> Left name
-
-tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
-        -- AbsBind, VarBind impossible
-
-lookupMBI :: Name -> TcM MonoBindInfo
--- After typechecking the pattern, look up the binder
--- names that lack a signature, which the pattern has brought
--- into scope.
-lookupMBI name
-  = do { mono_id <- tcLookupId name
-       ; return (MBI { mbi_poly_name = name
-                     , mbi_sig       = Nothing
-                     , mbi_mono_id   = mono_id }) }
-
--------------------
-tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo
-tcLhsSigId no_gen (name, sig)
-  = do { inst_sig <- tcInstSig sig
-       ; mono_id <- newSigLetBndr no_gen name inst_sig
-       ; return (MBI { mbi_poly_name = name
-                     , mbi_sig       = Just inst_sig
-                     , mbi_mono_id   = mono_id }) }
-
-------------
-newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId
-newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig })
-  | CompleteSig { sig_bndr = poly_id } <- id_sig
-  = addInlinePrags poly_id (lookupPragEnv prags name)
-newSigLetBndr no_gen name (TISI { sig_inst_tau = tau })
-  = newLetBndr no_gen name ManyTy tau
-    -- Binders with a signature are currently always of multiplicity
-    -- Many. Because they come either from toplevel, let, or where
-    -- declarations. Which are all unrestricted currently.
-
--------------------
-tcRhs :: TcMonoBind -> TcM (HsBind GhcTc)
-tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
-                 loc matches)
-  = tcExtendIdBinderStackForRhs [info]  $
-    tcExtendTyVarEnvForRhs mb_sig       $
-    do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
-        ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) mono_id)
-                                 matches (mkCheckExpType $ idType mono_id)
-        ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id
-                           , fun_matches = matches'
-                           , fun_ext = (co_fn, [])
-                           } ) }
-
-tcRhs (TcPatBind infos pat' grhss pat_ty)
-  = -- When we are doing pattern bindings we *don't* bring any scoped
-    -- type variables into scope unlike function bindings
-    -- Wny not?  They are not completely rigid.
-    -- That's why we have the special case for a single FunBind in tcMonoBinds
-    tcExtendIdBinderStackForRhs infos        $
-    do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
-        ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
-                    tcGRHSsPat grhss (mkCheckExpType pat_ty)
-
-        ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
-                           , pat_ext = (pat_ty, ([],[])) } )}
-
-tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
-tcExtendTyVarEnvForRhs Nothing thing_inside
-  = thing_inside
-tcExtendTyVarEnvForRhs (Just sig) thing_inside
-  = tcExtendTyVarEnvFromSig sig thing_inside
-
-tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
-tcExtendTyVarEnvFromSig sig_inst thing_inside
-  | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst
-  = tcExtendNameTyVarEnv wcs $
-    tcExtendNameTyVarEnv (mapSnd binderVar skol_prs) $
-    thing_inside
-
-tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
--- See Note [Relevant bindings and the binder stack]
-tcExtendIdBinderStackForRhs infos thing_inside
-  = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
-                        | MBI { mbi_mono_id = mono_id } <- infos ]
-                        thing_inside
-    -- NotTopLevel: it's a monomorphic binding
-
----------------------
-getMonoBindInfo :: [LocatedA TcMonoBind] -> [MonoBindInfo]
-getMonoBindInfo tc_binds
-  = foldr (get_info . unLoc) [] tc_binds
-  where
-    get_info (TcFunBind info _ _)    rest = info : rest
-    get_info (TcPatBind infos _ _ _) rest = infos ++ rest
-
-
-{- Note [Relevant bindings and the binder stack]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When typecking a binding we extend the TcBinderStack for the RHS of
-the binding, with the /monomorphic/ Id.  That way, if we have, say
-    f = \x -> blah
-and something goes wrong in 'blah', we get a "relevant binding"
-looking like  f :: alpha -> beta
-This applies if 'f' has a type signature too:
-   f :: forall a. [a] -> [a]
-   f x = True
-We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
-If we had the *polymorphic* version of f in the TcBinderStack, it
-would not be reported as relevant, because its type is closed.
-(See TcErrors.relevantBindings.)
-
-Note [Typechecking pattern bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Look at:
-   - typecheck/should_compile/ExPat
-   - #12427, typecheck/should_compile/T12427{a,b}
-
-  data T where
-    MkT :: Integral a => a -> Int -> T
-
-and suppose t :: T.  Which of these pattern bindings are ok?
-
-  E1. let { MkT p _ = t } in <body>
-
-  E2. let { MkT _ q = t } in <body>
-
-  E3. let { MkT (toInteger -> r) _ = t } in <body>
-
-* (E1) is clearly wrong because the existential 'a' escapes.
-  What type could 'p' possibly have?
-
-* (E2) is fine, despite the existential pattern, because
-  q::Int, and nothing escapes.
-
-* Even (E3) is fine.  The existential pattern binds a dictionary
-  for (Integral a) which the view pattern can use to convert the
-  a-valued field to an Integer, so r :: Integer.
-
-An easy way to see all three is to imagine the desugaring.
-For (E2) it would look like
-    let q = case t of MkT _ q' -> q'
-    in <body>
-
-
-We typecheck pattern bindings as follows.  First tcLhs does this:
-
-  1. Take each type signature q :: ty, partial or complete, and
-     instantiate it (with tcLhsSigId) to get a MonoBindInfo.  This
-     gives us a fresh "mono_id" qm :: instantiate(ty), where qm has
-     a fresh name.
-
-     Any fresh unification variables in instantiate(ty) born here, not
-     deep under implications as would happen if we allocated them when
-     we encountered q during tcPat.
-
-  2. Build a little environment mapping "q" -> "qm" for those Ids
-     with signatures (inst_sig_fun)
-
-  3. Invoke tcLetPat to typecheck the pattern.
-
-     - We pass in the current TcLevel.  This is captured by
-       GHC.Tc.Gen.Pat.tcLetPat, and put into the pc_lvl field of PatCtxt, in
-       PatEnv.
-
-     - When tcPat finds an existential constructor, it binds fresh
-       type variables and dictionaries as usual, increments the TcLevel,
-       and emits an implication constraint.
-
-     - When we come to a binder (GHC.Tc.Gen.Pat.tcPatBndr), it looks it up
-       in the little environment (the pc_sig_fn field of PatCtxt).
-
-         Success => There was a type signature, so just use it,
-                    checking compatibility with the expected type.
-
-         Failure => No type signature.
-             Infer case: (happens only outside any constructor pattern)
-                         use a unification variable
-                         at the outer level pc_lvl
-
-             Check case: use promoteTcType to promote the type
-                         to the outer level pc_lvl.  This is the
-                         place where we emit a constraint that'll blow
-                         up if existential capture takes place
-
-       Result: the type of the binder is always at pc_lvl. This is
-       crucial.
-
-  4. Throughout, when we are making up an Id for the pattern-bound variables
-     (newLetBndr), we have two cases:
-
-     - If we are generalising (generalisation plan is InferGen or
-       CheckGen), then the let_bndr_spec will be LetLclBndr.  In that case
-       we want to bind a cloned, local version of the variable, with the
-       type given by the pattern context, *not* by the signature (even if
-       there is one; see #7268). The mkExport part of the
-       generalisation step will do the checking and impedance matching
-       against the signature.
-
-     - If for some reason we are not generalising (plan = NoGen), the
-       LetBndrSpec will be LetGblBndr.  In that case we must bind the
-       global version of the Id, and do so with precisely the type given
-       in the signature.  (Then we unify with the type from the pattern
-       context type.)
-
-
-And that's it!  The implication constraints check for the skolem
-escape.  It's quite simple and neat, and more expressive than before
-e.g. GHC 8.0 rejects (E2) and (E3).
-
-Example for (E1), starting at level 1.  We generate
-     p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta)
-The (a~beta) can't float (because of the 'a'), nor be solved (because
-beta is untouchable.)
-
-Example for (E2), we generate
-     q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta)
-The beta is untouchable, but floats out of the constraint and can
-be solved absolutely fine.
-
-
-************************************************************************
-*                                                                      *
-                Generalisation
-*                                                                      *
-********************************************************************* -}
-
-data GeneralisationPlan
-  = NoGen               -- No generalisation, no AbsBinds
-
-  | InferGen            -- Implicit generalisation; there is an AbsBinds
-
-  | CheckGen            -- One FunBind with a complete signature:
-       (LHsBind GhcRn)  --   do explicit generalisation
-       TcIdSigInfo      -- Always CompleteSig
-
--- A consequence of the no-AbsBinds choice (NoGen) is that there is
--- no "polymorphic Id" and "monmomorphic Id"; there is just the one
-
-instance Outputable GeneralisationPlan where
-  ppr NoGen          = text "NoGen"
-  ppr InferGen       = text "InferGen"
-  ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
-
-decideGeneralisationPlan
-   :: DynFlags -> TopLevelFlag -> IsGroupClosed -> TcSigFun
-   -> [LHsBind GhcRn] -> GeneralisationPlan
-decideGeneralisationPlan dflags top_lvl closed sig_fn lbinds
-  | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig
-  | generalise_binds                         = InferGen
-  | otherwise                                = NoGen
-  where
-    generalise_binds
-      | isTopLevel top_lvl             = True
-        -- See Note [Always generalise top-level bindings]
-
-      | IsGroupClosed _ True <- closed = True
-        -- The 'True' means that all of the group's
-        -- free vars have ClosedTypeId=True; so we can ignore
-        -- -XMonoLocalBinds, and generalise anyway
-
-      | has_partial_sigs = True
-        -- See Note [Partial type signatures and generalisation]
-
-      | otherwise = not (xopt LangExt.MonoLocalBinds dflags)
-
-    -- With OutsideIn, all nested bindings are monomorphic
-    -- except a single function binding with a complete signature
-    one_funbind_with_sig
-      | [lbind@(L _ (FunBind { fun_id = v }))] <- lbinds
-      , Just (TcIdSig sig@(CompleteSig {})) <- sig_fn (unLoc v)
-      = Just (lbind, sig)
-      | otherwise
-      = Nothing
-
-    binders          = collectHsBindListBinders CollNoDictBinders lbinds
-    has_partial_sigs = any has_partial_sig binders
-    has_partial_sig nm = case sig_fn nm of
-      Just (TcIdSig (PartialSig {})) -> True
-      _                              -> False
-
-isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed
-isClosedBndrGroup type_env binds
-  = IsGroupClosed fv_env type_closed
-  where
-    type_closed = allUFM (nameSetAll is_closed_type_id) fv_env
-
-    fv_env :: NameEnv NameSet
-    fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
-
-    bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
-    bindFvs (FunBind { fun_id = L _ f
-                     , fun_ext = fvs })
-       = let open_fvs = get_open_fvs fvs
-         in [(f, open_fvs)]
-    bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs })
-       = let open_fvs = get_open_fvs fvs
-         in [(b, open_fvs) | b <- collectPatBinders CollNoDictBinders pat]
-    bindFvs _
-       = []
-
-    get_open_fvs fvs = filterNameSet (not . is_closed) fvs
-
-    is_closed :: Name -> ClosedTypeId
-    is_closed name
-      | Just thing <- lookupNameEnv type_env name
-      = case thing of
-          AGlobal {}                     -> True
-          ATcId { tct_info = ClosedLet } -> True
-          _                              -> False
-
-      | otherwise
-      = True  -- The free-var set for a top level binding mentions
-
-
-    is_closed_type_id :: Name -> Bool
-    -- We're already removed Global and ClosedLet Ids
-    is_closed_type_id name
-      | Just thing <- lookupNameEnv type_env name
-      = case thing of
-          ATcId { tct_info = NonClosedLet _ cl } -> cl
-          ATcId { tct_info = NotLetBound }       -> False
-          ATyVar {}                              -> False
-               -- In-scope type variables are not closed!
-          _ -> pprPanic "is_closed_id" (ppr name)
-
-      | otherwise
-      = True   -- The free-var set for a top level binding mentions
-               -- imported things too, so that we can report unused imports
-               -- These won't be in the local type env.
-               -- Ditto class method etc from the current module
-
-{- Note [Always generalise top-level bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It is very confusing to apply NoGen to a top level binding. Consider (#20123):
-   module M where
-     x = 5
-     f y = (x, y)
-
-The MR means that x=5 is not generalise, so f's binding is no Closed.  So we'd
-be tempted to use NoGen. But that leads to f :: Any -> (Integer, Any), which
-is plain stupid.
-
-NoGen is good when we have call sites, but not at top level, where the
-function may be exported.  And it's easier to grok "MonoLocalBinds" as
-applying to, well, local bindings.
--}
-
-{- *********************************************************************
-*                                                                      *
-               Error contexts and messages
-*                                                                      *
-********************************************************************* -}
-
--- This one is called on LHS, when pat and grhss are both Name
--- and on RHS, when pat is TcId and grhss is still Name
-patMonoBindsCtxt :: (OutputableBndrId p)
-                 => LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc
-patMonoBindsCtxt pat grhss
-  = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
diff --git a/compiler/GHC/Tc/Gen/Default.hs b/compiler/GHC/Tc/Gen/Default.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Default.hs
+++ /dev/null
@@ -1,110 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1993-1998
-
--}
-{-# LANGUAGE TypeFamilies #-}
-
--- | Typechecking @default@ declarations
-module GHC.Tc.Gen.Default ( tcDefaults ) where
-
-import GHC.Prelude
-
-import GHC.Hs
-import GHC.Core.Class
-import GHC.Core.Type( typeKind )
-
-import GHC.Types.Var( tyVarKind )
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Env
-import GHC.Tc.Gen.HsType
-import GHC.Tc.Utils.Zonk
-import GHC.Tc.Solver
-import GHC.Tc.Validity
-import GHC.Tc.Utils.TcType
-import GHC.Builtin.Names
-import GHC.Types.Error
-import GHC.Types.SrcLoc
-import GHC.Utils.Outputable
-import qualified GHC.LanguageExtensions as LangExt
-
-import Data.List.NonEmpty ( NonEmpty (..) )
-
-tcDefaults :: [LDefaultDecl GhcRn]
-           -> TcM (Maybe [Type])    -- Defaulting types to heave
-                                    -- into Tc monad for later use
-                                    -- in Disambig.
-
-tcDefaults []
-  = getDeclaredDefaultTys       -- No default declaration, so get the
-                                -- default types from the envt;
-                                -- i.e. use the current ones
-                                -- (the caller will put them back there)
-        -- It's important not to return defaultDefaultTys here (which
-        -- we used to do) because in a TH program, tcDefaults [] is called
-        -- repeatedly, once for each group of declarations between top-level
-        -- splices.  We don't want to carefully set the default types in
-        -- one group, only for the next group to ignore them and install
-        -- defaultDefaultTys
-
-tcDefaults [L _ (DefaultDecl _ [])]
-  = return (Just [])            -- Default declaration specifying no types
-
-tcDefaults [L locn (DefaultDecl _ mono_tys)]
-  = setSrcSpan (locA locn)              $
-    addErrCtxt defaultDeclCtxt          $
-    do  { ovl_str   <- xoptM LangExt.OverloadedStrings
-        ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules
-        ; num_class    <- tcLookupClass numClassName
-        ; deflt_str <- if ovl_str
-                       then mapM tcLookupClass [isStringClassName]
-                       else return []
-        ; deflt_interactive <- if ext_deflt
-                               then mapM tcLookupClass interactiveClassNames
-                               else return []
-        ; let deflt_clss = num_class : deflt_str ++ deflt_interactive
-
-        ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys
-
-        ; return (Just tau_tys) }
-
-tcDefaults (decl@(L locn (DefaultDecl _ _)) : decls)
-  = setSrcSpan (locA locn) $
-    failWithTc (dupDefaultDeclErr (decl:|decls))
-
-
-tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type
-tc_default_ty deflt_clss hs_ty
- = do   { ty <- solveEqualities "tc_default_ty" $
-                tcInferLHsType hs_ty
-        ; ty <- zonkTcTypeToType ty   -- establish Type invariants
-        ; checkValidType DefaultDeclCtxt ty
-
-        -- Check that the type is an instance of at least one of the deflt_clss
-        ; oks <- mapM (check_instance ty) deflt_clss
-        ; checkTc (or oks) (TcRnBadDefaultType ty deflt_clss)
-        ; return ty }
-
-check_instance :: Type -> Class -> TcM Bool
--- Check that ty is an instance of cls
--- We only care about whether it worked or not; return a boolean
--- This checks that  cls :: k -> Constraint
--- with just one argument and no polymorphism; if we need to add
--- polymorphism we can make it more complicated.  For now we are
--- concerned with classes like
---    Num      :: Type -> Constraint
---    Foldable :: (Type->Type) -> Constraint
-check_instance ty cls
-  | [cls_tv] <- classTyVars cls
-  , tyVarKind cls_tv `tcEqType` typeKind ty
-  = simplifyDefault [mkClassPred cls [ty]]
-  | otherwise
-  = return False
-
-defaultDeclCtxt :: SDoc
-defaultDeclCtxt = text "When checking the types in a default declaration"
-
-dupDefaultDeclErr :: NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage
-dupDefaultDeclErr (L _ (DefaultDecl _ _) :| dup_things)
-  = TcRnMultipleDefaultDeclarations dup_things
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ /dev/null
@@ -1,761 +0,0 @@
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes        #-}
-{-# LANGUAGE TypeFamilies      #-}
-
-module GHC.Tc.Gen.Export (rnExports, exports_from_avail) where
-
-import GHC.Prelude
-
-import GHC.Hs
-import GHC.Types.FieldLabel
-import GHC.Builtin.Names
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.TcType
-import GHC.Rename.Names
-import GHC.Rename.Env
-import GHC.Rename.Unbound ( reportUnboundName )
-import GHC.Utils.Error
-import GHC.Unit.Module
-import GHC.Unit.Module.Imported
-import GHC.Core.TyCon
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Core.ConLike
-import GHC.Core.PatSyn
-import GHC.Data.Maybe
-import GHC.Data.FastString (fsLit)
-import GHC.Driver.Env
-
-import GHC.Types.Unique.Set
-import GHC.Types.SrcLoc as SrcLoc
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.Name.Set
-import GHC.Types.Avail
-import GHC.Types.SourceFile
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.Name.Reader
-
-import Control.Monad
-import GHC.Driver.Session
-import GHC.Parser.PostProcess ( setRdrNameSpace )
-import Data.Either            ( partitionEithers )
-import GHC.Rename.Doc
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Export list processing}
-*                                                                      *
-************************************************************************
-
-Processing the export list.
-
-You might think that we should record things that appear in the export
-list as ``occurrences'' (using @addOccurrenceName@), but you'd be
-wrong.  We do check (here) that they are in scope, but there is no
-need to slurp in their actual declaration (which is what
-@addOccurrenceName@ forces).
-
-Indeed, doing so would big trouble when compiling @PrelBase@, because
-it re-exports @GHC@, which includes @takeMVar#@, whose type includes
-@ConcBase.StateAndSynchVar#@, and so on...
-
-Note [Exports of data families]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose you see (#5306)
-        module M where
-          import X( F )
-          data instance F Int = FInt
-What does M export?  AvailTC F [FInt]
-                  or AvailTC F [F,FInt]?
-The former is strictly right because F isn't defined in this module.
-But then you can never do an explicit import of M, thus
-    import M( F( FInt ) )
-because F isn't exported by M.  Nor can you import FInt alone from here
-    import M( FInt )
-because we don't have syntax to support that.  (It looks like an import of
-the type FInt.)
-
-At one point I implemented a compromise:
-  * When constructing exports with no export list, or with module M(
-    module M ), we add the parent to the exports as well.
-  * But not when you see module M( f ), even if f is a
-    class method with a parent.
-  * Nor when you see module M( module N ), with N /= M.
-
-But the compromise seemed too much of a hack, so we backed it out.
-You just have to use an explicit export list:
-    module M( F(..) ) where ...
-
-Note [Avails of associated data families]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose you have (#16077)
-
-    {-# LANGUAGE TypeFamilies #-}
-    module A (module A) where
-
-    class    C a  where { data T a }
-    instance C () where { data T () = D }
-
-Because @A@ is exported explicitly, GHC tries to produce an export list
-from the @GlobalRdrEnv@. In this case, it pulls out the following:
-
-    [ C defined at A.hs:4:1
-    , T parent:C defined at A.hs:4:23
-    , D parent:T defined at A.hs:5:35 ]
-
-If map these directly into avails, (via 'availFromGRE'), we get
-@[C{C;}, C{T;}, T{D;}]@, which eventually gets merged into @[C{C, T;}, T{D;}]@.
-That's not right, because @T{D;}@ violates the AvailTC invariant: @T@ is
-exported, but it isn't the first entry in the avail!
-
-We work around this issue by expanding GREs where the parent and child
-are both type constructors into two GRES.
-
-    T parent:C defined at A.hs:4:23
-
-      =>
-
-    [ T parent:C defined at A.hs:4:23
-    , T defined at A.hs:4:23 ]
-
-Then, we get  @[C{C;}, C{T;}, T{T;}, T{D;}]@, which eventually gets merged
-into @[C{C, T;}, T{T, D;}]@ (which satisfies the AvailTC invariant).
--}
-
-data ExportAccum        -- The type of the accumulating parameter of
-                        -- the main worker function in rnExports
-     = ExportAccum
-        ExportOccMap           --  Tracks exported occurrence names
-        (UniqSet ModuleName)   --  Tracks (re-)exported module names
-
-emptyExportAccum :: ExportAccum
-emptyExportAccum = ExportAccum emptyOccEnv emptyUniqSet
-
-accumExports :: (ExportAccum -> x -> TcRn (Maybe (ExportAccum, y)))
-             -> [x]
-             -> TcRn [y]
-accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum
-  where f' acc x = do
-          m <- attemptM (f acc x)
-          pure $ case m of
-            Just (Just (acc', y)) -> (acc', Just y)
-            _                     -> (acc, Nothing)
-
-type ExportOccMap = OccEnv (GreName, IE GhcPs)
-        -- Tracks what a particular exported OccName
-        --   in an export list refers to, and which item
-        --   it came from.  It's illegal to export two distinct things
-        --   that have the same occurrence name
-
-rnExports :: Bool       -- False => no 'module M(..) where' header at all
-          -> Maybe (LocatedL [LIE GhcPs]) -- Nothing => no explicit export list
-          -> RnM TcGblEnv
-
-        -- Complains if two distinct exports have same OccName
-        -- Warns about identical exports.
-        -- Complains about exports items not in scope
-
-rnExports explicit_mod exports
- = checkNoErrs $   -- Fail if anything in rnExports finds
-                   -- an error fails, to avoid error cascade
-   unsetWOptM Opt_WarnWarningsDeprecations $
-       -- Do not report deprecations arising from the export
-       -- list, to avoid bleating about re-exporting a deprecated
-       -- thing (especially via 'module Foo' export item)
-   do   { hsc_env <- getTopEnv
-        ; tcg_env <- getGblEnv
-        ; let dflags = hsc_dflags hsc_env
-              TcGblEnv { tcg_mod     = this_mod
-                       , tcg_rdr_env = rdr_env
-                       , tcg_imports = imports
-                       , tcg_src     = hsc_src } = tcg_env
-              default_main | mainModIs (hsc_HUE hsc_env) == this_mod
-                           , Just main_fun <- mainFunIs dflags
-                           = mkUnqual varName (fsLit main_fun)
-                           | otherwise
-                           = main_RDR_Unqual
-        ; has_main <- (not . null) <$> lookupInfoOccRn default_main -- #17832
-
-        -- If a module has no explicit header, and it has one or more main
-        -- functions in scope, then add a header like
-        -- "module Main(main) where ..."                               #13839
-        -- See Note [Modules without a module header]
-        ; let real_exports
-                 | explicit_mod = exports
-                 | has_main
-                          = Just (noLocA [noLocA (IEVar noExtField
-                                     (noLocA (IEName noExtField $ noLocA default_main)))])
-                        -- ToDo: the 'noLoc' here is unhelpful if 'main'
-                        --       turns out to be out of scope
-                 | otherwise = Nothing
-
-        -- Rename the export list
-        ; let do_it = exports_from_avail real_exports rdr_env imports this_mod
-        ; (rn_exports, final_avails)
-            <- if hsc_src == HsigFile
-                then do (mb_r, msgs) <- tryTc do_it
-                        case mb_r of
-                            Just r  -> return r
-                            Nothing -> addMessages msgs >> failM
-                else checkNoErrs do_it
-
-        -- Final processing
-        ; let final_ns = availsToNameSetWithSelectors final_avails
-
-        ; traceRn "rnExports: Exports:" (ppr final_avails)
-
-        ; return (tcg_env { tcg_exports    = final_avails
-                          , tcg_rn_exports = case tcg_rn_exports tcg_env of
-                                                Nothing -> Nothing
-                                                Just _  -> rn_exports
-                          , tcg_dus = tcg_dus tcg_env `plusDU`
-                                      usesOnly final_ns }) }
-
-exports_from_avail :: Maybe (LocatedL [LIE GhcPs])
-                         -- ^ 'Nothing' means no explicit export list
-                   -> GlobalRdrEnv
-                   -> ImportAvails
-                         -- ^ Imported modules; this is used to test if a
-                         -- @module Foo@ export is valid (it's not valid
-                         -- if we didn't import @Foo@!)
-                   -> Module
-                   -> RnM (Maybe [(LIE GhcRn, Avails)], Avails)
-                         -- (Nothing, _) <=> no explicit export list
-                         -- if explicit export list is present it contains
-                         -- each renamed export item together with its exported
-                         -- names.
-
-exports_from_avail Nothing rdr_env _imports _this_mod
-   -- The same as (module M) where M is the current module name,
-   -- so that's how we handle it, except we also export the data family
-   -- when a data instance is exported.
-  = do {
-    ; addDiagnostic
-        (TcRnMissingExportList $ moduleName _this_mod)
-    ; let avails =
-            map fix_faminst . gresToAvailInfo
-              . filter isLocalGRE . globalRdrEnvElts $ rdr_env
-    ; return (Nothing, avails) }
-  where
-    -- #11164: when we define a data instance
-    -- but not data family, re-export the family
-    -- Even though we don't check whether this is actually a data family
-    -- only data families can locally define subordinate things (`ns` here)
-    -- without locally defining (and instead importing) the parent (`n`)
-    fix_faminst avail@(AvailTC n ns)
-      | availExportsDecl avail = avail
-      | otherwise = AvailTC n (NormalGreName n:ns)
-    fix_faminst avail = avail
-
-
-exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
-  = do ie_avails <- accumExports do_litem rdr_items
-       let final_exports = nubAvails (concatMap snd ie_avails) -- Combine families
-       return (Just ie_avails, final_exports)
-  where
-    do_litem :: ExportAccum -> LIE GhcPs
-             -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))
-    do_litem acc lie = setSrcSpan (getLocA lie) (exports_from_item acc lie)
-
-    -- Maps a parent to its in-scope children
-    kids_env :: NameEnv [GlobalRdrElt]
-    kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
-
-    -- See Note [Avails of associated data families]
-    expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt]
-    expand_tyty_gre (gre@GRE { gre_par = ParentIs p })
-      | isTyConName p, isTyConName (greMangledName gre) = [gre, gre{ gre_par = NoParent }]
-    expand_tyty_gre gre = [gre]
-
-    imported_modules = [ imv_name imv
-                       | xs <- moduleEnvElts $ imp_mods imports
-                       , imv <- importedByUser xs ]
-
-    exports_from_item :: ExportAccum -> LIE GhcPs
-                      -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))
-    exports_from_item (ExportAccum occs earlier_mods)
-                      (L loc ie@(IEModuleContents _ lmod@(L _ mod)))
-        | mod `elementOfUniqSet` earlier_mods    -- Duplicate export of M
-        = do { addDiagnostic (TcRnDupeModuleExport mod) ;
-               return Nothing }
-
-        | otherwise
-        = do { let { exportValid = (mod `elem` imported_modules)
-                                || (moduleName this_mod == mod)
-                   ; gre_prs     = pickGREsModExp mod (globalRdrEnvElts rdr_env)
-                   ; new_exports = [ availFromGRE gre'
-                                   | (gre, _) <- gre_prs
-                                   , gre' <- expand_tyty_gre gre ]
-                   ; all_gres    = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs
-                   ; mods        = addOneToUniqSet earlier_mods mod
-                   }
-
-             ; checkErr exportValid (TcRnExportedModNotImported mod)
-             ; warnIf (exportValid && null gre_prs) (TcRnNullExportedModule mod)
-
-             ; traceRn "efa" (ppr mod $$ ppr all_gres)
-             ; addUsedGREs all_gres
-
-             ; occs' <- check_occs ie occs new_exports
-                      -- This check_occs not only finds conflicts
-                      -- between this item and others, but also
-                      -- internally within this item.  That is, if
-                      -- 'M.x' is in scope in several ways, we'll have
-                      -- several members of mod_avails with the same
-                      -- OccName.
-             ; traceRn "export_mod"
-                       (vcat [ ppr mod
-                             , ppr new_exports ])
-
-             ; return (Just ( ExportAccum occs' mods
-                            , ( L loc (IEModuleContents noExtField lmod)
-                              , new_exports))) }
-
-    exports_from_item acc@(ExportAccum occs mods) (L loc ie) = do
-        m_new_ie <- lookup_doc_ie ie
-        case m_new_ie of
-          Just new_ie -> return (Just (acc, (L loc new_ie, [])))
-          Nothing -> do
-             (new_ie, avail) <- lookup_ie ie
-             if isUnboundName (ieName new_ie)
-                  then return Nothing    -- Avoid error cascade
-                  else do
-
-                    occs' <- check_occs ie occs [avail]
-
-                    return (Just ( ExportAccum occs' mods
-                                 , (L loc new_ie, [avail])))
-
-    -------------
-    lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo)
-    lookup_ie (IEVar _ (L l rdr))
-        = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
-             return (IEVar noExtField (L l (replaceWrappedName rdr name)), avail)
-
-    lookup_ie (IEThingAbs _ (L l rdr))
-        = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
-             return (IEThingAbs noAnn (L l (replaceWrappedName rdr name))
-                    , avail)
-
-    lookup_ie ie@(IEThingAll _ n')
-        = do
-            (n, avail, flds) <- lookup_ie_all ie n'
-            let name = unLoc n
-            return (IEThingAll noAnn (replaceLWrappedName n' (unLoc n))
-                   , availTC name (name:avail) flds)
-
-
-    lookup_ie ie@(IEThingWith _ l wc sub_rdrs)
-        = do
-            (lname, subs, avails, flds)
-              <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs
-            (_, all_avail, all_flds) <-
-              case wc of
-                NoIEWildcard -> return (lname, [], [])
-                IEWildcard _ -> lookup_ie_all ie l
-            let name = unLoc lname
-            let flds' = flds ++ (map noLoc all_flds)
-            return (IEThingWith flds' (replaceLWrappedName l name) wc subs,
-                    availTC name (name : avails ++ all_avail)
-                                 (map unLoc flds ++ all_flds))
-
-
-    lookup_ie _ = panic "lookup_ie"    -- Other cases covered earlier
-
-
-    lookup_ie_with :: LIEWrappedName GhcPs -> [LIEWrappedName GhcPs]
-                   -> RnM (Located Name, [LIEWrappedName GhcRn], [Name],
-                           [Located FieldLabel])
-    lookup_ie_with (L l rdr) sub_rdrs
-        = do name <- lookupGlobalOccRn $ ieWrappedName rdr
-             (non_flds, flds) <- lookupChildrenExport name sub_rdrs
-             if isUnboundName name
-                then return (L (locA l) name, [], [name], [])
-                else return (L (locA l) name, non_flds
-                            , map (ieWrappedName . unLoc) non_flds
-                            , flds)
-
-    lookup_ie_all :: IE GhcPs -> LIEWrappedName GhcPs
-                  -> RnM (Located Name, [Name], [FieldLabel])
-    lookup_ie_all ie (L l rdr) =
-          do name <- lookupGlobalOccRn $ ieWrappedName rdr
-             let gres = findChildren kids_env name
-                 (non_flds, flds) = classifyGREs gres
-             addUsedKids (ieWrappedName rdr) gres
-             when (null gres) $
-                  if isTyConName name
-                  then addTcRnDiagnostic (TcRnDodgyExports name)
-                  else -- This occurs when you export T(..), but
-                       -- only import T abstractly, or T is a synonym.
-                       addErr (TcRnExportHiddenComponents ie)
-             return (L (locA l) name, non_flds, flds)
-
-    -------------
-    lookup_doc_ie :: IE GhcPs -> RnM (Maybe (IE GhcRn))
-    lookup_doc_ie (IEGroup _ lev doc) = do
-      doc' <- rnLHsDoc doc
-      pure $ Just (IEGroup noExtField lev doc')
-    lookup_doc_ie (IEDoc _ doc)       = do
-      doc' <- rnLHsDoc doc
-      pure $ Just (IEDoc noExtField doc')
-    lookup_doc_ie (IEDocNamed _ str)  = pure $ Just (IEDocNamed noExtField str)
-    lookup_doc_ie _ = pure Nothing
-
-    -- In an export item M.T(A,B,C), we want to treat the uses of
-    -- A,B,C as if they were M.A, M.B, M.C
-    -- Happily pickGREs does just the right thing
-    addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM ()
-    addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres)
-
-classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])
-classifyGREs = partitionGreNames . map gre_name
-
--- Renaming and typechecking of exports happens after everything else has
--- been typechecked.
-
-{-
-Note [Modules without a module header]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The Haskell 2010 report says in section 5.1:
-
->> An abbreviated form of module, consisting only of the module body, is
->> permitted. If this is used, the header is assumed to be
->> ‘module Main(main) where’.
-
-For modules without a module header, this is implemented the
-following way:
-
-If the module has a main function in scope:
-   Then create a module header and export the main function,
-   as if a module header like ‘module Main(main) where...’ would exist.
-   This has the effect to mark the main function and all top level
-   functions called directly or indirectly via main as 'used',
-   and later on, unused top-level functions can be reported correctly.
-   There is no distinction between GHC and GHCi.
-If the module has several main functions in scope:
-   Then generate a header as above. The ambiguity is reported later in
-   module  `GHC.Tc.Module` function `check_main`.
-If the module has NO main function:
-   Then export all top-level functions. This marks all top level
-   functions as 'used'.
-   In GHCi this has the effect, that we don't get any 'non-used' warnings.
-   In GHC, however, the 'has-main-module' check in GHC.Tc.Module.checkMain
-   fires, and we get the error:
-      The IO action ‘main’ is not defined in module ‘Main’
--}
-
-
--- Renaming exports lists is a minefield. Five different things can appear in
--- children export lists ( T(A, B, C) ).
--- 1. Record selectors
--- 2. Type constructors
--- 3. Data constructors
--- 4. Pattern Synonyms
--- 5. Pattern Synonym Selectors
---
--- However, things get put into weird name spaces.
--- 1. Some type constructors are parsed as variables (-.->) for example.
--- 2. All data constructors are parsed as type constructors
--- 3. When there is ambiguity, we default type constructors to data
--- constructors and require the explicit `type` keyword for type
--- constructors.
---
--- This function first establishes the possible namespaces that an
--- identifier might be in (`choosePossibleNameSpaces`).
---
--- Then for each namespace in turn, tries to find the correct identifier
--- there returning the first positive result or the first terminating
--- error.
---
-
-
-
-lookupChildrenExport :: Name -> [LIEWrappedName GhcPs]
-                     -> RnM ([LIEWrappedName GhcRn], [Located FieldLabel])
-lookupChildrenExport spec_parent rdr_items =
-  do
-    xs <- mapAndReportM doOne rdr_items
-    return $ partitionEithers xs
-    where
-        -- Pick out the possible namespaces in order of priority
-        -- This is a consequence of how the parser parses all
-        -- data constructors as type constructors.
-        choosePossibleNamespaces :: NameSpace -> [NameSpace]
-        choosePossibleNamespaces ns
-          | ns == varName = [varName, tcName]
-          | ns == tcName  = [dataName, tcName]
-          | otherwise = [ns]
-        -- Process an individual child
-        doOne :: LIEWrappedName GhcPs
-              -> RnM (Either (LIEWrappedName GhcRn) (Located FieldLabel))
-        doOne n = do
-
-          let bareName = (ieWrappedName . unLoc) n
-              lkup v = lookupSubBndrOcc_helper False True
-                        spec_parent (setRdrNameSpace bareName v)
-
-          name <-  combineChildLookupResult $ map lkup $
-                   choosePossibleNamespaces (rdrNameSpace bareName)
-          traceRn "lookupChildrenExport" (ppr name)
-          -- Default to data constructors for slightly better error
-          -- messages
-          let unboundName :: RdrName
-              unboundName = if rdrNameSpace bareName == varName
-                                then bareName
-                                else setRdrNameSpace bareName dataName
-
-          case name of
-            NameNotFound -> do { ub <- reportUnboundName unboundName
-                               ; let l = getLoc n
-                               ; return (Left (L l (IEName noExtField (L (la2na l) ub))))}
-            FoundChild par child -> do { checkPatSynParent spec_parent par child
-                                       ; return $ case child of
-                                           FieldGreName fl   -> Right (L (getLocA n) fl)
-                                           NormalGreName  name -> Left (replaceLWrappedName n name)
-                                       }
-            IncorrectParent p c gs -> failWithDcErr p c gs
-
-
--- Note [Typing Pattern Synonym Exports]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- It proved quite a challenge to precisely specify which pattern synonyms
--- should be allowed to be bundled with which type constructors.
--- In the end it was decided to be quite liberal in what we allow. Below is
--- how Simon described the implementation.
---
--- "Personally I think we should Keep It Simple.  All this talk of
---  satisfiability makes me shiver.  I suggest this: allow T( P ) in all
---   situations except where `P`'s type is ''visibly incompatible'' with
---   `T`.
---
---    What does "visibly incompatible" mean?  `P` is visibly incompatible
---    with
---     `T` if
---       * `P`'s type is of form `... -> S t1 t2`
---       * `S` is a data/newtype constructor distinct from `T`
---
---  Nothing harmful happens if we allow `P` to be exported with
---  a type it can't possibly be useful for, but specifying a tighter
---  relationship is very awkward as you have discovered."
---
--- Note that this allows *any* pattern synonym to be bundled with any
--- datatype type constructor. For example, the following pattern `P` can be
--- bundled with any type.
---
--- ```
--- pattern P :: (A ~ f) => f
--- ```
---
--- So we provide basic type checking in order to help the user out, most
--- pattern synonyms are defined with definite type constructors, but don't
--- actually prevent a library author completely confusing their users if
--- they want to.
---
--- So, we check for exactly four things
--- 1. The name arises from a pattern synonym definition. (Either a pattern
---    synonym constructor or a pattern synonym selector)
--- 2. The pattern synonym is only bundled with a datatype or newtype.
--- 3. Check that the head of the result type constructor is an actual type
---    constructor and not a type variable. (See above example)
--- 4. Is so, check that this type constructor is the same as the parent
---    type constructor.
---
---
--- Note [Types of TyCon]
--- ~~~~~~~~~~~~~~~~~~~~~
--- This check appears to be overly complicated, Richard asked why it
--- is not simply just `isAlgTyCon`. The answer for this is that
--- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow.
--- (It is either a newtype or data depending on the number of methods)
---
-
--- | Given a resolved name in the children export list and a parent. Decide
--- whether we are allowed to export the child with the parent.
--- Invariant: gre_par == NoParent
--- See Note [Typing Pattern Synonym Exports]
-checkPatSynParent :: Name    -- ^ Alleged parent type constructor
-                             -- User wrote T( P, Q )
-                  -> Parent  -- The parent of P we discovered
-                  -> GreName   -- ^ Either a
-                             --   a) Pattern Synonym Constructor
-                             --   b) A pattern synonym selector
-                  -> TcM ()  -- Fails if wrong parent
-checkPatSynParent _ (ParentIs {}) _
-  = return ()
-
-checkPatSynParent parent NoParent gname
-  | isUnboundName parent -- Avoid an error cascade
-  = return ()
-
-  | otherwise
-  = do { parent_ty_con  <- tcLookupTyCon parent
-       ; mpat_syn_thing <- tcLookupGlobal (greNameMangledName gname)
-
-        -- 1. Check that the Id was actually from a thing associated with patsyns
-       ; case mpat_syn_thing of
-            AnId i | isId i
-                   , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i
-                   -> handle_pat_syn (selErr gname) parent_ty_con p
-
-            AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p
-
-            _ -> failWithDcErr parent gname [] }
-  where
-    psErr  = exportErrCtxt "pattern synonym"
-    selErr = exportErrCtxt "pattern synonym record selector"
-
-    handle_pat_syn :: SDoc
-                   -> TyCon      -- Parent TyCon
-                   -> PatSyn     -- Corresponding bundled PatSyn
-                                 -- and pretty printed origin
-                   -> TcM ()
-    handle_pat_syn doc ty_con pat_syn
-
-      -- 2. See Note [Types of TyCon]
-      | not $ isTyConWithSrcDataCons ty_con
-      = addErrCtxt doc $ failWithTc TcRnPatSynBundledWithNonDataCon
-
-      -- 3. Is the head a type variable?
-      | Nothing <- mtycon
-      = return ()
-      -- 4. Ok. Check they are actually the same type constructor.
-
-      | Just p_ty_con <- mtycon, p_ty_con /= ty_con
-      = addErrCtxt doc $ failWithTc
-          (TcRnPatSynBundledWithWrongType expected_res_ty res_ty)
-
-      -- 5. We passed!
-      | otherwise
-      = return ()
-
-      where
-        expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))
-        (_, _, _, _, _, res_ty) = patSynSig pat_syn
-        mtycon = fst <$> tcSplitTyConApp_maybe res_ty
-
-
-{-===========================================================================-}
-check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo]
-           -> RnM ExportOccMap
-check_occs ie occs avails
-  -- 'avails' are the entities specified by 'ie'
-  = foldlM check occs children
-  where
-    children = concatMap availGreNames avails
-
-    -- Check for distinct children exported with the same OccName (an error) or
-    -- for duplicate exports of the same child (a warning).
-    check :: ExportOccMap -> GreName -> RnM ExportOccMap
-    check occs child
-      = case try_insert occs child of
-          Right occs' -> return occs'
-
-          Left (child', ie')
-            | greNameMangledName child == greNameMangledName child'   -- Duplicate export
-            -- But we don't want to warn if the same thing is exported
-            -- by two different module exports. See ticket #4478.
-            -> do { warnIf (not (dupExport_ok child ie ie')) (TcRnDuplicateExport child ie ie')
-                  ; return occs }
-
-            | otherwise    -- Same occ name but different names: an error
-            ->  do { global_env <- getGlobalRdrEnv ;
-                     addErr (exportClashErr global_env child' child ie' ie) ;
-                     return occs }
-
-    -- Try to insert a child into the map, returning Left if there is something
-    -- already exported with the same OccName
-    try_insert :: ExportOccMap -> GreName -> Either (GreName, IE GhcPs) ExportOccMap
-    try_insert occs child
-      = case lookupOccEnv occs name_occ of
-          Nothing -> Right (extendOccEnv occs name_occ (child, ie))
-          Just x  -> Left x
-      where
-        -- For fields, we check for export clashes using the (OccName of the)
-        -- selector Name
-        name_occ = nameOccName (greNameMangledName child)
-
-
-dupExport_ok :: GreName -> IE GhcPs -> IE GhcPs -> Bool
--- The GreName is exported by both IEs. Is that ok?
--- "No"  iff the name is mentioned explicitly in both IEs
---        or one of the IEs mentions the name *alone*
--- "Yes" otherwise
---
--- Examples of "no":  module M( f, f )
---                    module M( fmap, Functor(..) )
---                    module M( module Data.List, head )
---
--- Example of "yes"
---    module M( module A, module B ) where
---        import A( f )
---        import B( f )
---
--- Example of "yes" (#2436)
---    module M( C(..), T(..) ) where
---         class C a where { data T a }
---         instance C Int where { data T Int = TInt }
---
--- Example of "yes" (#2436)
---    module Foo ( T ) where
---      data family T a
---    module Bar ( T(..), module Foo ) where
---        import Foo
---        data instance T Int = TInt
-
-dupExport_ok child ie1 ie2
-  = not (  single ie1 || single ie2
-        || (explicit_in ie1 && explicit_in ie2) )
-  where
-    explicit_in (IEModuleContents {}) = False                   -- module M
-    explicit_in (IEThingAll _ r)
-      = occName child == rdrNameOcc (ieWrappedName $ unLoc r)  -- T(..)
-    explicit_in _              = True
-
-    single IEVar {}      = True
-    single IEThingAbs {} = True
-    single _               = False
-
-
-exportErrCtxt :: Outputable o => String -> o -> SDoc
-exportErrCtxt herald exp =
-  text "In the" <+> text (herald ++ ":") <+> ppr exp
-
-
-addExportErrCtxt :: (OutputableBndrId p)
-                 => IE (GhcPass p) -> TcM a -> TcM a
-addExportErrCtxt ie = addErrCtxt exportCtxt
-  where
-    exportCtxt = text "In the export:" <+> ppr ie
-
-
-failWithDcErr :: Name -> GreName -> [Name] -> TcM a
-failWithDcErr parent child parents = do
-  ty_thing <- tcLookupGlobal (greNameMangledName child)
-  failWithTc $ TcRnExportedParentChildMismatch parent ty_thing child parents
-
-
-exportClashErr :: GlobalRdrEnv
-               -> GreName -> GreName
-               -> IE GhcPs -> IE GhcPs
-               -> TcRnMessage
-exportClashErr global_env child1 child2 ie1 ie2
-  = TcRnConflictingExports occ child1' gre1' ie1' child2' gre2' ie2'
-  where
-    occ = occName child1
-    -- get_gre finds a GRE for the Name, so that we can show its provenance
-    gre1 = get_gre child1
-    gre2 = get_gre child2
-    get_gre child
-        = fromMaybe (pprPanic "exportClashErr" (ppr child))
-                    (lookupGRE_GreName global_env child)
-    (child1', gre1', ie1', child2', gre2', ie2') =
-      case SrcLoc.leftmost_smallest (greSrcSpan gre1) (greSrcSpan gre2) of
-        LT -> (child1, gre1, ie1, child2, gre2, ie2)
-        GT -> (child2, gre2, ie2, child1, gre1, ie1)
-        EQ -> panic "exportClashErr: clashing exports have identical location"
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ /dev/null
@@ -1,1893 +0,0 @@
-
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections       #-}
-{-# LANGUAGE TypeFamilies        #-}
-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-                                      -- in module Language.Haskell.Syntax.Extension
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
-
-{-
-%
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
-module GHC.Tc.Gen.Expr
-       ( tcCheckPolyExpr, tcCheckPolyExprNC,
-         tcCheckMonoExpr, tcCheckMonoExprNC,
-         tcMonoExpr, tcMonoExprNC,
-         tcInferRho, tcInferRhoNC,
-         tcPolyExpr, tcExpr,
-         tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
-         tcCheckId,
-         ) where
-
-import GHC.Prelude
-
-import {-# SOURCE #-}   GHC.Tc.Gen.Splice( tcTypedSplice, tcTypedBracket, tcUntypedBracket )
-
-import GHC.Hs
-import GHC.Hs.Syn.Type
-import GHC.Rename.Utils
-import GHC.Tc.Utils.Zonk
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Unify
-import GHC.Types.Basic
-import GHC.Types.Error
-import GHC.Types.FieldLabel
-import GHC.Types.Unique.Map ( UniqMap, listToUniqMap, lookupUniqMap )
-import GHC.Core.Multiplicity
-import GHC.Core.UsageEnv
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic, hasFixedRuntimeRep )
-import GHC.Tc.Utils.Instantiate
-import GHC.Tc.Gen.App
-import GHC.Tc.Gen.Head
-import GHC.Tc.Gen.Bind        ( tcLocalBinds )
-import GHC.Tc.Instance.Family ( tcGetFamInstEnvs )
-import GHC.Core.FamInstEnv    ( FamInstEnvs )
-import GHC.Rename.Expr        ( mkExpandedExpr )
-import GHC.Rename.Env         ( addUsedGRE )
-import GHC.Tc.Utils.Env
-import GHC.Tc.Gen.Arrow
-import GHC.Tc.Gen.Match
-import GHC.Tc.Gen.HsType
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.TcType as TcType
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Core.ConLike
-import GHC.Core.DataCon
-import GHC.Core.PatSyn
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.Name.Set
-import GHC.Types.Name.Reader
-import GHC.Core.TyCon
-import GHC.Core.Type
-import GHC.Core.Coercion( mkSymCo )
-import GHC.Tc.Types.Evidence
-import GHC.Builtin.Types
-import GHC.Builtin.Names
-import GHC.Builtin.Uniques ( mkBuiltinUnique )
-import GHC.Driver.Session
-import GHC.Types.SrcLoc
-import GHC.Utils.Misc
-import GHC.Data.List.SetOps
-import GHC.Data.Maybe
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import Control.Monad
-import GHC.Core.Class(classTyCon)
-import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )
-
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-import Data.Function
-import Data.List (partition, sortBy, intersect)
-import qualified Data.List.NonEmpty as NE
-
-import GHC.Data.Bag ( unitBag )
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Main wrappers}
-*                                                                      *
-************************************************************************
--}
-
-
-tcCheckPolyExpr, tcCheckPolyExprNC
-  :: LHsExpr GhcRn         -- Expression to type check
-  -> TcSigmaType           -- Expected type (could be a polytype)
-  -> TcM (LHsExpr GhcTc) -- Generalised expr with expected type
-
--- tcCheckPolyExpr is a convenient place (frequent but not too frequent)
--- place to add context information.
--- The NC version does not do so, usually because the caller wants
--- to do so themselves.
-
-tcCheckPolyExpr   expr res_ty = tcPolyLExpr   expr (mkCheckExpType res_ty)
-tcCheckPolyExprNC expr res_ty = tcPolyLExprNC expr (mkCheckExpType res_ty)
-
--- These versions take an ExpType
-tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType
-                           -> TcM (LHsExpr GhcTc)
-
-tcPolyLExpr (L loc expr) res_ty
-  = setSrcSpanA loc   $  -- Set location /first/; see GHC.Tc.Utils.Monad
-    addExprCtxt expr $  -- Note [Error contexts in generated code]
-    do { expr' <- tcPolyExpr expr res_ty
-       ; return (L loc expr') }
-
-tcPolyLExprNC (L loc expr) res_ty
-  = setSrcSpanA loc    $
-    do { expr' <- tcPolyExpr expr res_ty
-       ; return (L loc expr') }
-
----------------
-tcCheckMonoExpr, tcCheckMonoExprNC
-    :: LHsExpr GhcRn     -- Expression to type check
-    -> TcRhoType         -- Expected type
-                         -- Definitely no foralls at the top
-    -> TcM (LHsExpr GhcTc)
-tcCheckMonoExpr   expr res_ty = tcMonoExpr   expr (mkCheckExpType res_ty)
-tcCheckMonoExprNC expr res_ty = tcMonoExprNC expr (mkCheckExpType res_ty)
-
-tcMonoExpr, tcMonoExprNC
-    :: LHsExpr GhcRn     -- Expression to type check
-    -> ExpRhoType        -- Expected type
-                         -- Definitely no foralls at the top
-    -> TcM (LHsExpr GhcTc)
-
-tcMonoExpr (L loc expr) res_ty
-  = setSrcSpanA loc   $  -- Set location /first/; see GHC.Tc.Utils.Monad
-    addExprCtxt expr $  -- Note [Error contexts in generated code]
-    do  { expr' <- tcExpr expr res_ty
-        ; return (L loc expr') }
-
-tcMonoExprNC (L loc expr) res_ty
-  = setSrcSpanA loc $
-    do  { expr' <- tcExpr expr res_ty
-        ; return (L loc expr') }
-
----------------
-tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
--- Infer a *rho*-type. The return type is always instantiated.
-tcInferRho (L loc expr)
-  = setSrcSpanA loc   $  -- Set location /first/; see GHC.Tc.Utils.Monad
-    addExprCtxt expr $  -- Note [Error contexts in generated code]
-    do { (expr', rho) <- tcInfer (tcExpr expr)
-       ; return (L loc expr', rho) }
-
-tcInferRhoNC (L loc expr)
-  = setSrcSpanA loc $
-    do { (expr', rho) <- tcInfer (tcExpr expr)
-       ; return (L loc expr', rho) }
-
-
-{- *********************************************************************
-*                                                                      *
-        tcExpr: the main expression typechecker
-*                                                                      *
-********************************************************************* -}
-
-tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
-tcPolyExpr expr res_ty
-  = do { traceTc "tcPolyExpr" (ppr res_ty)
-       ; (wrap, expr') <- tcSkolemiseExpType GenSigCtxt res_ty $ \ res_ty ->
-                          tcExpr expr res_ty
-       ; return $ mkHsWrap wrap expr' }
-
-tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-
--- Use tcApp to typecheck applications, which are treated specially
--- by Quick Look.  Specifically:
---   - HsVar         lone variables, to ensure that they can get an
---                     impredicative instantiation (via Quick Look
---                     driven by res_ty (in checking mode)).
---   - HsApp         value applications
---   - HsAppType     type applications
---   - ExprWithTySig (e :: type)
---   - HsRecSel      overloaded record fields
---   - HsExpanded    renamer expansions
---   - HsOpApp       operator applications
---   - HsOverLit     overloaded literals
--- These constructors are the union of
---   - ones taken apart by GHC.Tc.Gen.Head.splitHsApps
---   - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe
--- See Note [Application chains and heads] in GHC.Tc.Gen.App
-tcExpr e@(HsVar {})              res_ty = tcApp e res_ty
-tcExpr e@(HsApp {})              res_ty = tcApp e res_ty
-tcExpr e@(OpApp {})              res_ty = tcApp e res_ty
-tcExpr e@(HsAppType {})          res_ty = tcApp e res_ty
-tcExpr e@(ExprWithTySig {})      res_ty = tcApp e res_ty
-tcExpr e@(HsRecSel {})           res_ty = tcApp e res_ty
-tcExpr e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty
-
-tcExpr e@(HsOverLit _ lit) res_ty
-  = do { mb_res <- tcShortCutLit lit res_ty
-         -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.Zonk
-       ; case mb_res of
-           Just lit' -> return (HsOverLit noAnn lit')
-           Nothing   -> tcApp e res_ty }
-
--- Typecheck an occurrence of an unbound Id
---
--- Some of these started life as a true expression hole "_".
--- Others might simply be variables that accidentally have no binding site
-tcExpr (HsUnboundVar _ occ) res_ty
-  = do { ty <- expTypeToType res_ty    -- Allow Int# etc (#12531)
-       ; her <- emitNewExprHole occ ty
-       ; tcEmitBindingUsage bottomUE   -- Holes fit any usage environment
-                                       -- (#18491)
-       ; return (HsUnboundVar her occ) }
-
-tcExpr e@(HsLit x lit) res_ty
-  = do { let lit_ty = hsLitType lit
-       ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty }
-
-tcExpr (HsPar x lpar expr rpar) res_ty
-  = do { expr' <- tcMonoExprNC expr res_ty
-       ; return (HsPar x lpar expr' rpar) }
-
-tcExpr (HsPragE x prag expr) res_ty
-  = do { expr' <- tcMonoExpr expr res_ty
-       ; return (HsPragE x (tcExprPrag prag) expr') }
-
-tcExpr (NegApp x expr neg_expr) res_ty
-  = do  { (expr', neg_expr')
-            <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $
-               \[arg_ty] [arg_mult] ->
-               tcScalingUsage arg_mult $ tcCheckMonoExpr expr arg_ty
-        ; return (NegApp x expr' neg_expr') }
-
-tcExpr e@(HsIPVar _ x) res_ty
-  = do { ip_ty <- newFlexiTyVarTy liftedTypeKind
-          -- Create a unification type variable of kind 'Type'.
-          -- (The type of an implicit parameter must have kind 'Type'.)
-       ; let ip_name = mkStrLitTy (hsIPNameFS x)
-       ; ipClass <- tcLookupClass ipClassName
-       ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
-       ; tcWrapResult e
-                   (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLocA ip_var)))
-                   ip_ty res_ty }
-  where
-  -- Coerces a dictionary for `IP "x" t` into `t`.
-  fromDict ipClass x ty = mkHsWrap $ mkWpCastR $
-                          unwrapIP $ mkClassPred ipClass [x,ty]
-  origin = IPOccOrigin x
-
-tcExpr (HsLam _ match) res_ty
-  = do  { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty
-        ; return (mkHsWrap wrap (HsLam noExtField match')) }
-  where
-    match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
-    herald = ExpectedFunTyLam match
-
-tcExpr e@(HsLamCase x lc_variant matches) res_ty
-  = do { (wrap, matches')
-           <- tcMatchLambda herald match_ctxt matches res_ty
-       ; return (mkHsWrap wrap $ HsLamCase x lc_variant matches') }
-  where
-    match_ctxt = MC { mc_what = LamCaseAlt lc_variant, mc_body = tcBody }
-    herald = ExpectedFunTyLamCase lc_variant e
-
-
-
-{-
-************************************************************************
-*                                                                      *
-                Explicit lists
-*                                                                      *
-************************************************************************
--}
-
--- Explicit lists [e1,e2,e3] have been expanded already in the renamer
--- The expansion includes an ExplicitList, but it is always the built-in
--- list type, so that's all we need concern ourselves with here.  See
--- GHC.Rename.Expr. Note [Handling overloaded and rebindable constructs]
-tcExpr (ExplicitList _ exprs) res_ty
-  = do  { res_ty <- expTypeToType res_ty
-        ; (coi, elt_ty) <- matchExpectedListTy res_ty
-        ; let tc_elt expr = tcCheckPolyExpr expr elt_ty
-        ; exprs' <- mapM tc_elt exprs
-        ; return $ mkHsWrapCo coi $ ExplicitList elt_ty exprs' }
-
-tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty
-  | all tupArgPresent tup_args
-  = do { let arity  = length tup_args
-             tup_tc = tupleTyCon boxity arity
-               -- NB: tupleTyCon doesn't flatten 1-tuples
-               -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
-       ; res_ty <- expTypeToType res_ty
-       ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
-                           -- Unboxed tuples have RuntimeRep vars, which we
-                           -- don't care about here
-                           -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
-       ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys
-                                       Boxed   -> arg_tys
-       ; tup_args1 <- tcTupArgs tup_args arg_tys'
-       ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) }
-
-  | otherwise
-  = -- The tup_args are a mixture of Present and Missing (for tuple sections)
-    do { let arity = length tup_args
-
-       ; arg_tys <- case boxity of
-           { Boxed   -> newFlexiTyVarTys arity liftedTypeKind
-           ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }
-
-       -- Handle tuple sections where
-       ; tup_args1 <- tcTupArgs tup_args arg_tys
-
-       ; let expr'       = ExplicitTuple x tup_args1 boxity
-             missing_tys = [Scaled mult ty | (Missing (Scaled mult _), ty) <- zip tup_args1 arg_tys]
-
-             -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head
-             -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
-             act_res_ty = mkScaledFunTys missing_tys (mkTupleTy1 boxity arg_tys)
-
-       ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty)
-
-       ; tcWrapResultMono expr expr' act_res_ty res_ty }
-
-tcExpr (ExplicitSum _ alt arity expr) res_ty
-  = do { let sum_tc = sumTyCon arity
-       ; res_ty <- expTypeToType res_ty
-       ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty
-       ; -- Drop levity vars, we don't care about them here
-         let arg_tys' = drop arity arg_tys
-             arg_ty   = arg_tys' `getNth` (alt - 1)
-       ; expr' <- tcCheckPolyExpr expr arg_ty
-       -- Check the whole res_ty, not just the arg_ty, to avoid #20277.
-       -- Example:
-       --   a :: TYPE rep (representation-polymorphic)
-       --   (# 17# | #) :: (# Int# | a #)
-       -- This should cause an error, even though (17# :: Int#)
-       -- is not representation-polymorphic: we don't know how
-       -- wide the concrete representation of the sum type will be.
-       ; hasFixedRuntimeRep_syntactic FRRUnboxedSum res_ty
-       ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }
-
-
-{-
-************************************************************************
-*                                                                      *
-                Let, case, if, do
-*                                                                      *
-************************************************************************
--}
-
-tcExpr (HsLet x tkLet binds tkIn expr) res_ty
-  = do  { (binds', expr') <- tcLocalBinds binds $
-                             tcMonoExpr expr res_ty
-        ; return (HsLet x tkLet binds' tkIn expr') }
-
-tcExpr (HsCase x scrut matches) res_ty
-  = do  {  -- We used to typecheck the case alternatives first.
-           -- The case patterns tend to give good type info to use
-           -- when typechecking the scrutinee.  For example
-           --   case (map f) of
-           --     (x:xs) -> ...
-           -- will report that map is applied to too few arguments
-           --
-           -- But now, in the GADT world, we need to typecheck the scrutinee
-           -- first, to get type info that may be refined in the case alternatives
-          mult <- newFlexiTyVarTy multiplicityTy
-
-          -- Typecheck the scrutinee.  We use tcInferRho but tcInferSigma
-          -- would also be possible (tcMatchesCase accepts sigma-types)
-          -- Interesting litmus test: do these two behave the same?
-          --     case id        of {..}
-          --     case (\v -> v) of {..}
-          -- This design choice is discussed in #17790
-        ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut
-
-        ; traceTc "HsCase" (ppr scrut_ty)
-        ; hasFixedRuntimeRep_syntactic FRRCase scrut_ty
-        ; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty
-        ; return (HsCase x scrut' matches') }
- where
-    match_ctxt = MC { mc_what = CaseAlt,
-                      mc_body = tcBody }
-
-tcExpr (HsIf x pred b1 b2) res_ty
-  = do { pred'    <- tcCheckMonoExpr pred boolTy
-       ; (u1,b1') <- tcCollectingUsage $ tcMonoExpr b1 res_ty
-       ; (u2,b2') <- tcCollectingUsage $ tcMonoExpr b2 res_ty
-       ; tcEmitBindingUsage (supUE u1 u2)
-       ; return (HsIf x pred' b1' b2') }
-
-tcExpr (HsMultiIf _ alts) res_ty
-  = do { alts' <- mapM (wrapLocMA $ tcGRHS match_ctxt res_ty) alts
-       ; res_ty <- readExpType res_ty
-       ; return (HsMultiIf res_ty alts') }
-  where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
-
-tcExpr (HsDo _ do_or_lc stmts) res_ty
-  = tcDoStmts do_or_lc stmts res_ty
-
-tcExpr (HsProc x pat cmd) res_ty
-  = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
-        ; return $ mkHsWrapCo coi (HsProc x pat' cmd') }
-
--- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
--- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.
--- To type check
---      (static e) :: p a
--- we want to check (e :: a),
--- and wrap (static e) in a call to
---    fromStaticPtr :: IsStatic p => StaticPtr a -> p a
-
-tcExpr (HsStatic fvs expr) res_ty
-  = do  { res_ty          <- expTypeToType res_ty
-        ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty
-        ; (expr', lie)    <- captureConstraints $
-            addErrCtxt (hang (text "In the body of a static form:")
-                             2 (ppr expr)
-                       ) $
-            tcCheckPolyExprNC expr expr_ty
-
-        -- Check that the free variables of the static form are closed.
-        -- It's OK to use nonDetEltsUniqSet here as the only side effects of
-        -- checkClosedInStaticForm are error messages.
-        ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs
-
-        -- Require the type of the argument to be Typeable.
-        ; typeableClass <- tcLookupClass typeableClassName
-        ; typeable_ev <- emitWantedEvVar StaticOrigin $
-                  mkTyConApp (classTyCon typeableClass)
-                             [liftedTypeKind, expr_ty]
-
-        -- Insert the constraints of the static form in a global list for later
-        -- validation.
-        ; emitStaticConstraints lie
-
-        -- Wrap the static form with the 'fromStaticPtr' call.
-        ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName
-                                             [p_ty]
-        ; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty]
-        ; loc <- getSrcSpanM
-        ; static_ptr_ty_con <- tcLookupTyCon staticPtrTyConName
-        ; return $ mkHsWrapCo co $ HsApp noComments
-                            (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr)
-                            (L (noAnnSrcSpan loc) (HsStatic (fvs, mkTyConApp static_ptr_ty_con [expr_ty]) expr'))
-        }
-
-{-
-************************************************************************
-*                                                                      *
-                Record construction and update
-*                                                                      *
-************************************************************************
--}
-
-tcExpr expr@(RecordCon { rcon_con = L loc con_name
-                       , rcon_flds = rbinds }) res_ty
-  = do  { con_like <- tcLookupConLike con_name
-
-        ; (con_expr, con_sigma) <- tcInferId con_name
-        ; (con_wrap, con_tau)   <- topInstantiate orig con_sigma
-              -- a shallow instantiation should really be enough for
-              -- a data constructor.
-        ; let arity = conLikeArity con_like
-              Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau
-
-        ; checkTc (conLikeHasBuilder con_like) $
-          nonBidirectionalErr (conLikeName con_like)
-
-        ; rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds
-                   -- It is currently not possible for a record to have
-                   -- multiplicities. When they do, `tcRecordBinds` will take
-                   -- scaled types instead. Meanwhile, it's safe to take
-                   -- `scaledThing` above, as we know all the multiplicities are
-                   -- Many.
-
-        ; let rcon_tc = mkHsWrap con_wrap con_expr
-              expr' = RecordCon { rcon_ext = rcon_tc
-                                , rcon_con = L loc con_like
-                                , rcon_flds = rbinds' }
-
-        ; ret <- tcWrapResultMono expr expr' actual_res_ty res_ty
-
-        -- Check for missing fields.  We do this after type-checking to get
-        -- better types in error messages (cf #18869).  For example:
-        --     data T a = MkT { x :: a, y :: a }
-        --     r = MkT { y = True }
-        -- Then we'd like to warn about a missing field `x :: True`, rather than `x :: a0`.
-        --
-        -- NB: to do this really properly we should delay reporting until typechecking is complete,
-        -- via a new `HoleSort`.  But that seems too much work.
-        ; checkMissingFields con_like rbinds arg_tys
-
-        ; return ret }
-  where
-    orig = OccurrenceOf con_name
-
--- Record updates via dot syntax are replaced by desugared expressions
--- in the renamer. See Note [Overview of record dot syntax] in
--- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here
--- and panic otherwise.
-tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ty
-  = assert (notNull rbnds) $
-    do  { -- Desugar the record update. See Note [Record Updates].
-        ; (ds_expr, ds_res_ty, err_ctxt) <- desugarRecordUpd record_expr rbnds res_ty
-
-          -- Typecheck the desugared expression.
-        ; expr' <- addErrCtxt err_ctxt $
-                   tcExpr (mkExpandedExpr expr ds_expr) (Check ds_res_ty)
-            -- NB: it's important to use ds_res_ty and not res_ty here.
-            -- Test case: T18802b.
-
-        ; addErrCtxt err_ctxt $ tcWrapResultMono expr expr' ds_res_ty res_ty
-            -- We need to unify the result type of the desugared
-            -- expression with the expected result type.
-            --
-            -- See Note [Unifying result types in tcRecordUpd].
-            -- Test case: T10808.
-        }
-
-tcExpr (RecordUpd {}) _ = panic "tcExpr: unexpected overloaded-dot RecordUpd"
-
-{-
-************************************************************************
-*                                                                      *
-        Arithmetic sequences                    e.g. [a,b..]
-        and their parallel-array counterparts   e.g. [: a,b.. :]
-
-*                                                                      *
-************************************************************************
--}
-
-tcExpr (ArithSeq _ witness seq) res_ty
-  = tcArithSeq witness seq res_ty
-
-{-
-************************************************************************
-*                                                                      *
-                Record dot syntax
-*                                                                      *
-************************************************************************
--}
-
--- These terms have been replaced by desugaring in the renamer. See
--- Note [Overview of record dot syntax].
-tcExpr (HsGetField _ _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
-tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"
-
-{-
-************************************************************************
-*                                                                      *
-                Template Haskell
-*                                                                      *
-************************************************************************
--}
-
--- Here we get rid of it and add the finalizers to the global environment.
--- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
-tcExpr (HsTypedSplice ext splice)   res_ty = tcTypedSplice ext splice res_ty
-tcExpr e@(HsTypedBracket _ body)    res_ty = tcTypedBracket e body res_ty
-
-tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty
-tcExpr (HsUntypedSplice splice _)   res_ty
-  = case splice of
-      HsUntypedSpliceTop mod_finalizers expr
-        -> do { addModFinalizersWithLclEnv mod_finalizers
-              ; tcExpr expr res_ty }
-      HsUntypedSpliceNested {} -> panic "tcExpr: invalid nested splice"
-
-{-
-************************************************************************
-*                                                                      *
-                Catch-all
-*                                                                      *
-************************************************************************
--}
-
-tcExpr (HsOverLabel {})    ty = pprPanic "tcExpr:HsOverLabel"  (ppr ty)
-tcExpr (SectionL {})       ty = pprPanic "tcExpr:SectionL"    (ppr ty)
-tcExpr (SectionR {})       ty = pprPanic "tcExpr:SectionR"    (ppr ty)
-
-
-{-
-************************************************************************
-*                                                                      *
-                Arithmetic sequences [a..b] etc
-*                                                                      *
-************************************************************************
--}
-
-tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType
-           -> TcM (HsExpr GhcTc)
-
-tcArithSeq witness seq@(From expr) res_ty
-  = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
-       ; expr' <-tcScalingUsage elt_mult $ tcCheckPolyExpr expr elt_ty
-       ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
-                              enumFromName [elt_ty]
-       ; return $ mkHsWrap wrap $
-         ArithSeq enum_from wit' (From expr') }
-
-tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
-  = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
-       ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty
-       ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty
-       ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
-                              enumFromThenName [elt_ty]
-       ; return $ mkHsWrap wrap $
-         ArithSeq enum_from_then wit' (FromThen expr1' expr2') }
-
-tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
-  = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
-       ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty
-       ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty
-       ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
-                              enumFromToName [elt_ty]
-       ; return $ mkHsWrap wrap $
-         ArithSeq enum_from_to wit' (FromTo expr1' expr2') }
-
-tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
-  = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
-        ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty
-        ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty
-        ; expr3' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr3 elt_ty
-        ; eft <- newMethodFromName (ArithSeqOrigin seq)
-                              enumFromThenToName [elt_ty]
-        ; return $ mkHsWrap wrap $
-          ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }
-
------------------
-arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType
-                -> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc))
-arithSeqEltType Nothing res_ty
-  = do { res_ty <- expTypeToType res_ty
-       ; (coi, elt_ty) <- matchExpectedListTy res_ty
-       ; return (mkWpCastN coi, OneTy, elt_ty, Nothing) }
-arithSeqEltType (Just fl) res_ty
-  = do { ((elt_mult, elt_ty), fl')
-           <- tcSyntaxOp ListOrigin fl [SynList] res_ty $
-              \ [elt_ty] [elt_mult] -> return (elt_mult, elt_ty)
-       ; return (idHsWrapper, elt_mult, elt_ty, Just fl') }
-
-----------------
-tcTupArgs :: [HsTupArg GhcRn]
-          -> [TcSigmaType]
-              -- ^ Argument types.
-              -- This function ensures they all have
-              -- a fixed runtime representation.
-          -> TcM [HsTupArg GhcTc]
-tcTupArgs args tys
-  = do massert (equalLength args tys)
-       checkTupSize (length args)
-       zipWith3M go [1,2..] args tys
-  where
-    go :: Int -> HsTupArg GhcRn -> TcType -> TcM (HsTupArg GhcTc)
-    go i (Missing {})     arg_ty
-      = do { mult <- newFlexiTyVarTy multiplicityTy
-           ; hasFixedRuntimeRep_syntactic (FRRTupleSection i) arg_ty
-           ; return (Missing (Scaled mult arg_ty)) }
-    go i (Present x expr) arg_ty
-      = do { expr' <- tcCheckPolyExpr expr arg_ty
-           ; hasFixedRuntimeRep_syntactic (FRRTupleArg i) arg_ty
-           ; return (Present x expr') }
-
----------------------------
--- See TcType.SyntaxOpType also for commentary
-tcSyntaxOp :: CtOrigin
-           -> SyntaxExprRn
-           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments
-           -> ExpRhoType               -- ^ overall result type
-           -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments,
-                                                 -- takes a type per hole and a
-                                                 -- multiplicity per arrow in
-                                                 -- the shape.
-           -> TcM (a, SyntaxExprTc)
--- ^ Typecheck a syntax operator
--- The operator is a variable or a lambda at this stage (i.e. renamer
--- output)t
-tcSyntaxOp orig expr arg_tys res_ty
-  = tcSyntaxOpGen orig expr arg_tys (SynType res_ty)
-
--- | Slightly more general version of 'tcSyntaxOp' that allows the caller
--- to specify the shape of the result of the syntax operator
-tcSyntaxOpGen :: CtOrigin
-              -> SyntaxExprRn
-              -> [SyntaxOpType]
-              -> SyntaxOpType
-              -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-              -> TcM (a, SyntaxExprTc)
-tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside
-  = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) []
-             -- Ugh!! But all this code is scheduled for demolition anyway
-       ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)
-       ; (result, expr_wrap, arg_wraps, res_wrap)
-           <- tcSynArgA orig op sigma arg_tys res_ty $
-              thing_inside
-       ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma )
-       ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr
-                                      , syn_arg_wraps = arg_wraps
-                                      , syn_res_wrap  = res_wrap }) }
-tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen"
-
-{-
-Note [tcSynArg]
-~~~~~~~~~~~~~~~
-Because of the rich structure of SyntaxOpType, we must do the
-contra-/covariant thing when working down arrows, to get the
-instantiation vs. skolemisation decisions correct (and, more
-obviously, the orientation of the HsWrappers). We thus have
-two tcSynArgs.
--}
-
--- works on "expected" types, skolemising where necessary
--- See Note [tcSynArg]
-tcSynArgE :: CtOrigin
-          -> HsExpr GhcRn -- ^ the operator to check (for error messages only)
-          -> TcSigmaType
-          -> SyntaxOpType                -- ^ shape it is expected to have
-          -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments
-          -> TcM (a, HsWrapper)
-           -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
-tcSynArgE orig op sigma_ty syn_ty thing_inside
-  = do { (skol_wrap, (result, ty_wrapper))
-           <- tcTopSkolemise GenSigCtxt sigma_ty
-                (\ rho_ty -> go rho_ty syn_ty)
-       ; return (result, skol_wrap <.> ty_wrapper) }
-    where
-    go rho_ty SynAny
-      = do { result <- thing_inside [rho_ty] []
-           ; return (result, idHsWrapper) }
-
-    go rho_ty SynRho   -- same as SynAny, because we skolemise eagerly
-      = do { result <- thing_inside [rho_ty] []
-           ; return (result, idHsWrapper) }
-
-    go rho_ty SynList
-      = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty
-           ; result <- thing_inside [elt_ty] []
-           ; return (result, mkWpCastN list_co) }
-
-    go rho_ty (SynFun arg_shape res_shape)
-      = do { ( match_wrapper                         -- :: (arg_ty -> res_ty) "->" rho_ty
-             , ( ( (result, arg_ty, res_ty, op_mult)
-                 , res_wrapper )                     -- :: res_ty_out "->" res_ty
-               , arg_wrapper1, [], arg_wrapper2 ) )  -- :: arg_ty "->" arg_ty_out
-               <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $
-                  \ [arg_ty] res_ty ->
-                  do { arg_tc_ty <- expTypeToType (scaledThing arg_ty)
-                     ; res_tc_ty <- expTypeToType res_ty
-
-                         -- another nested arrow is too much for now,
-                         -- but I bet we'll never need this
-                     ; massertPpr (case arg_shape of
-                                   SynFun {} -> False;
-                                   _         -> True)
-                                  (text "Too many nested arrows in SyntaxOpType" $$
-                                   pprCtOrigin orig)
-
-                     ; let arg_mult = scaledMult arg_ty
-                     ; tcSynArgA orig op arg_tc_ty [] arg_shape $
-                       \ arg_results arg_res_mults ->
-                       tcSynArgE orig op res_tc_ty res_shape $
-                       \ res_results res_res_mults ->
-                       do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults)
-                          ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }}
-
-           ; let fun_wrap = mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper
-                              (Scaled op_mult arg_ty) res_ty
-               -- NB: arg_ty comes from matchExpectedFunTys, so it has a
-               -- fixed RuntimeRep, as needed to call mkWpFun.
-           ; return (result, match_wrapper <.> fun_wrap) }
-      where
-        herald = ExpectedFunTySyntaxOp orig op
-
-    go rho_ty (SynType the_ty)
-      = do { wrap   <- tcSubTypePat orig GenSigCtxt the_ty rho_ty
-           ; result <- thing_inside [] []
-           ; return (result, wrap) }
-
--- works on "actual" types, instantiating where necessary
--- See Note [tcSynArg]
-tcSynArgA :: CtOrigin
-          -> HsExpr GhcRn -- ^ the operator we are checking (for error messages)
-          -> TcSigmaType
-          -> [SyntaxOpType]              -- ^ argument shapes
-          -> SyntaxOpType                -- ^ result shape
-          -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ check the arguments
-          -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
-            -- ^ returns a wrapper to be applied to the original function,
-            -- wrappers to be applied to arguments
-            -- and a wrapper to be applied to the overall expression
-tcSynArgA orig op sigma_ty arg_shapes res_shape thing_inside
-  = do { (match_wrapper, arg_tys, res_ty)
-           <- matchActualFunTysRho herald orig Nothing
-                                   (length arg_shapes) sigma_ty
-              -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
-       ; ((result, res_wrapper), arg_wrappers)
-           <- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults ->
-              tc_syn_arg    res_ty  res_shape  $ \ res_results ->
-              thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults)
-       ; return (result, match_wrapper, arg_wrappers, res_wrapper) }
-  where
-    herald = ExpectedFunTySyntaxOp orig op
-
-    tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType]
-                  -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-                  -> TcM (a, [HsWrapper])
-                    -- the wrappers are for arguments
-    tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside
-      = do { ((result, arg_wraps), arg_wrap)
-               <- tcSynArgE     orig  op arg_ty  arg_shape  $ \ arg1_results arg1_mults ->
-                  tc_syn_args_e          arg_tys arg_shapes $ \ args_results args_mults ->
-                  thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults)
-           ; return (result, arg_wrap : arg_wraps) }
-    tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] []
-
-    tc_syn_arg :: TcSigmaTypeFRR -> SyntaxOpType
-               -> ([TcSigmaTypeFRR] -> TcM a)
-               -> TcM (a, HsWrapper)
-                  -- the wrapper applies to the overall result
-    tc_syn_arg res_ty SynAny thing_inside
-      = do { result <- thing_inside [res_ty]
-           ; return (result, idHsWrapper) }
-    tc_syn_arg res_ty SynRho thing_inside
-      = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
-               -- inst_wrap :: res_ty "->" rho_ty
-           ; result <- thing_inside [rho_ty]
-           ; return (result, inst_wrap) }
-    tc_syn_arg res_ty SynList thing_inside
-      = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
-               -- inst_wrap :: res_ty "->" rho_ty
-           ; (list_co, elt_ty)   <- matchExpectedListTy rho_ty
-               -- list_co :: [elt_ty] ~N rho_ty
-           ; result <- thing_inside [elt_ty]
-           ; return (result, mkWpCastN (mkSymCo list_co) <.> inst_wrap) }
-    tc_syn_arg _ (SynFun {}) _
-      = pprPanic "tcSynArgA hits a SynFun" (ppr orig)
-    tc_syn_arg res_ty (SynType the_ty) thing_inside
-      = do { wrap   <- tcSubType orig GenSigCtxt res_ty the_ty
-           ; result <- thing_inside []
-           ; return (result, wrap) }
-
-{-
-Note [Push result type in]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Unify with expected result before type-checking the args so that the
-info from res_ty percolates to args.  This is when we might detect a
-too-few args situation.  (One can think of cases when the opposite
-order would give a better error message.)
-experimenting with putting this first.
-
-Here's an example where it actually makes a real difference
-
-   class C t a b | t a -> b
-   instance C Char a Bool
-
-   data P t a = forall b. (C t a b) => MkP b
-   data Q t   = MkQ (forall a. P t a)
-
-   f1, f2 :: Q Char;
-   f1 = MkQ (MkP True)
-   f2 = MkQ (MkP True :: forall a. P Char a)
-
-With the change, f1 will type-check, because the 'Char' info from
-the signature is propagated into MkQ's argument. With the check
-in the other order, the extra signature in f2 is reqd.
--}
-
-{- *********************************************************************
-*                                                                      *
-                 Desugaring record update
-*                                                                      *
-********************************************************************* -}
-
-{-
-Note [Type of a record update]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The main complication with RecordUpd is that we need to explicitly
-handle the *non-updated* fields.  Consider:
-
-        data T a b c = MkT1 { fa :: a, fb :: (b,c) }
-                     | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
-                     | MkT3 { fd :: a }
-
-        upd :: T a b c -> (b',c) -> T a b' c
-        upd t x = t { fb = x}
-
-The result type should be (T a b' c)
-not (T a b c),   because 'b' *is not* mentioned in a non-updated field
-not (T a b' c'), because 'c' *is*     mentioned in a non-updated field
-NB that it's not good enough to look at just one constructor; we must
-look at them all; cf #3219
-
-After all, upd should be equivalent to:
-        upd t x = case t of
-                        MkT1 p q -> MkT1 p x
-                        MkT2 a b -> MkT2 p b
-                        MkT3 d   -> error ...
-
-So we need to give a completely fresh type to the result record,
-and then constrain it by the fields that are *not* updated ("p" above).
-We call these the "fixed" type variables, and compute them in getFixedTyVars.
-
-Note that because MkT3 doesn't contain all the fields being updated,
-its RHS is simply an error, so it doesn't impose any type constraints.
-Hence the use of 'relevant_cont'.
-
-Note [Implicit type sharing]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We also take into account any "implicit" non-update fields.  For example
-        data T a b where { MkT { f::a } :: T a a; ... }
-So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
-
-Then consider
-        upd t x = t { f=x }
-We infer the type
-        upd :: T a b -> a -> T a b
-        upd (t::T a b) (x::a)
-           = case t of { MkT (co:a~b) (_:a) -> MkT co x }
-We can't give it the more general type
-        upd :: T a b -> c -> T c b
-
-Note [Criteria for update]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-We want to allow update for existentials etc, provided the updated
-field isn't part of the existential. For example, this should be ok.
-  data T a where { MkT { f1::a, f2::b->b } :: T a }
-  f :: T a -> b -> T b
-  f t b = t { f1=b }
-
-The criterion we use is this:
-
-  The types of the updated fields
-  mention only the universally-quantified type variables
-  of the data constructor
-
-NB: this is not (quite) the same as being a "naughty" record selector
-(See Note [Naughty record selectors]) in GHC.Tc.TyCl), at least
-in the case of GADTs. Consider
-   data T a where { MkT :: { f :: a } :: T [a] }
-Then f is not "naughty" because it has a well-typed record selector.
-But we don't allow updates for 'f'.  (One could consider trying to
-allow this, but it makes my head hurt.  Badly.  And no one has asked
-for it.)
-
-In principle one could go further, and allow
-  g :: T a -> T a
-  g t = t { f2 = \x -> x }
-because the expression is polymorphic...but that seems a bridge too far.
-
-Note [Data family example]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-    data instance T (a,b) = MkT { x::a, y::b }
-  --->
-    data :TP a b = MkT { a::a, y::b }
-    coTP a b :: T (a,b) ~ :TP a b
-
-Suppose r :: T (t1,t2), e :: t3
-Then  r { x=e } :: T (t3,t1)
-  --->
-      case r |> co1 of
-        MkT x y -> MkT e y |> co2
-      where co1 :: T (t1,t2) ~ :TP t1 t2
-            co2 :: :TP t3 t2 ~ T (t3,t2)
-The wrapping with co2 is done by the constructor wrapper for MkT
-
-Outgoing invariants
-~~~~~~~~~~~~~~~~~~~
-In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
-
-  * cons are the data constructors to be updated
-
-  * in_inst_tys, out_inst_tys have same length, and instantiate the
-        *representation* tycon of the data cons.  In Note [Data
-        family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
-
-Note [Mixed Record Field Updates]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider the following pattern synonym.
-
-  data MyRec = MyRec { foo :: Int, qux :: String }
-
-  pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}
-
-This allows updates such as the following
-
-  updater :: MyRec -> MyRec
-  updater a = a {f1 = 1 }
-
-It would also make sense to allow the following update (which we reject).
-
-  updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"
-
-This leads to confusing behaviour when the selectors in fact refer the same
-field.
-
-  updater a = a {f1 = 1, foo = 2} ==? ???
-
-For this reason, we reject a mixture of pattern synonym and normal record
-selectors in the same update block. Although of course we still allow the
-following.
-
-  updater a = (a {f1 = 1}) {foo = 2}
-
-  > updater (MyRec 0 "str")
-  MyRec 2 "str"
-
-Note [Record Updates]
-~~~~~~~~~~~~~~~~~~~~~
-To typecheck a record update, we desugar it first.  Suppose we have
-    data T p q = T1 { x :: Int, y :: Bool, z :: Char }
-               | T2 { v :: Char }
-               | T3 { x :: Int }
-               | T4 { p :: Float, y :: Bool, x :: Int }
-               | T5
-Then the record update `e { x=e1, y=e2 }` desugars as follows
-
-       e { x=e1, y=e2 }
-    ===>
-       let { x' = e1; y' = e2 } in
-       case e of
-          T1 _ _ z -> T1 x' y' z
-          T4 p _ _ -> T4 p y' x'
-T2, T3 and T5 should not occur, so we omit them from the match.
-The critical part of desugaring is to identify T and then T1/T4.
-
-Wrinkle [Disambiguating fields]
-As outlined above, to typecheck a record update via desugaring, we first need
-to identify the parent record `TyCon` (`T` above). This can be tricky when several
-record types share the same field (with `-XDuplicateRecordFields`).
-
-Currently, we use the inferred type of the record to help disambiguate the record
-fields. For example, in
-
-  ( mempty :: T a b ) { x = 3 }
-
-the type signature on `mempty` allows us to disambiguate the record `TyCon` to `T`,
-when there might be other datatypes with field `x :: Int`.
-This complexity is scheduled for removal via the implementation of GHC proposal #366
-https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst
-
-However, for the time being, we still need to disambiguate record fields using the
-inferred types. This means that, when typechecking a record update via desugaring,
-we need to do the following:
-
-  D1. Perform a first typechecking pass on the record expression (`e` in the example above),
-      to infer the type of the record being updated.
-  D2. Desugar the record update as described above, using an HsExpansion.
-  D3. Typecheck the desugared code.
-
-In (D1), we call inferRho to infer the type of the record being updated. This returns the
-inferred type of the record, together with a typechecked expression (of type HsExpr GhcTc)
-and a collection of residual constraints.
-We have no need for the latter two, because we will typecheck again in (D3). So, for
-the time being (and until GHC proposal #366 is implemented), we simply drop them.
-
-Wrinkle [Using IdSig]
-As noted above, we want to let-bind the updated fields to avoid code duplication:
-
-  let { x' = e1; y' = e2 } in
-  case e of
-     T1 _ _ z -> T1 x' y' z
-     T4 p _ _ -> T4 p y' x'
-
-However, doing so in a naive way would cause difficulties for type inference.
-For example:
-
-  data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int }
-  foo r = r { f = \ k -> (k 3, k 'x') }
-
-If we desugar to:
-
-  ds_foo r =
-    let f' = \ k -> (k 3, k 'x')
-    in case r of
-      MkR _ b -> MkR f' b
-
-then we are unable to infer an appropriately polymorphic type for f', because we
-never infer higher-rank types. To circumvent this problem, we proceed as follows:
-
-  1. Obtain general field types by instantiating any of the constructors
-     that contain all the necessary fields. (Note that the field type must be
-     identical across different constructors of a given data constructor).
-  2. Let-bind an 'IdSig' with this type. This amounts to giving the let-bound
-     'Id's a partial type signature.
-
-In the above example, it's as if we wrote:
-
-  ds_foo r =
-    let f' :: (forall a. a -> a) -> (Int, _b)
-        f' = \ k -> (k 3, k 'x')
-    in case r of
-      MkR _ b -> MkR f' b
-
-This allows us to compute the right type for f', and thus accept this record update.
-
-Note [Unifying result types in tcRecordUpd]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-After desugaring and typechecking a record update in the way described in
-Note [Record Updates], we must take care to unify the result types.
-
-Example:
-
-  type family F (a :: Type) :: Type where {}
-  data D a = MkD { fld :: F a }
-
-  f :: F Int -> D Bool -> D Int
-  f i r = r { fld = i }
-
-This record update desugars to:
-
-  let x :: F alpha -- metavariable
-      x = i
-  in case r of
-    MkD _ -> MkD x
-
-Because the type family F is not injective, our only hope for unifying the
-metavariable alpha is through the result type of the record update, which tells
-us that we should unify alpha := Int.
-
-Test case: T10808.
-
-Wrinkle [GADT result type in tcRecordUpd]
-
-  When dealing with a GADT, we want to be careful about which result type we use.
-
-  Example:
-
-    data G a b where
-      MkG :: { bar :: F a } -> G a Int
-
-    g :: F Int -> G Float b -> G Int b
-    g i r = r { bar = i }
-
-    We **do not** want to use the result type from the constructor MkG, which would
-    leave us with a result type "G alpha Int". Instead, we should use the result type
-    from the GADT header, instantiating as above, to get "G alpha beta" which will get
-    unified withy "G Int b".
-
-    Test cases: T18809, HardRecordUpdate.
-
--}
-
--- | Desugars a record update @record_expr { fld1 = e1, fld2 = e2}@ into a case expression
--- that matches on the constructors of the record @r@, as described in
--- Note [Record Updates].
---
--- Returns a renamed but not-yet-typechecked expression, together with the
--- result type of this desugared record update.
-desugarRecordUpd :: LHsExpr GhcRn
-                      -- ^ @record_expr@: expression to which the record update is applied
-                 -> [LHsRecUpdField GhcRn]
-                      -- ^ the record update fields
-                 -> ExpRhoType
-                      -- ^ the expected result type of the record update
-                 -> TcM ( HsExpr GhcRn
-                           -- desugared record update expression
-                        , TcType
-                           -- result type of desugared record update
-                        , SDoc
-                           -- error context to push when typechecking
-                           -- the desugared code
-                        )
-desugarRecordUpd record_expr rbnds res_ty
-  = do {  -- STEP -2: typecheck the record_expr, the record to be updated
-          -- Until GHC proposal #366 is implemented, we still use the type of
-          -- the record to disambiguate its fields, so we must infer the record
-          -- type here before we can desugar. See Wrinkle [Disambiguating fields]
-          -- in Note [Record Updates].
-       ; ((_, record_rho), _lie) <- captureConstraints    $ -- see (1) below
-                                    tcScalingUsage ManyTy $ -- see (2) below
-                                    tcInferRho record_expr
-
-            -- (1)
-            -- Note that we capture, and then discard, the constraints.
-            -- This `tcInferRho` is used *only* to identify the data type,
-            -- so we can deal with field disambiguation.
-            -- Then we are going to generate a desugared record update, including `record_expr`,
-            -- and typecheck it from scratch.  We don't want to generate the constraints twice!
-
-            -- (2)
-            -- Record update drops some of the content of the record (namely the
-            -- content of the field being updated). As a consequence, unless the
-            -- field being updated is unrestricted in the record, we need an
-            -- unrestricted record. Currently, we simply always require an
-            -- unrestricted record.
-            --
-            -- Consider the following example:
-            --
-            -- data R a = R { self :: a }
-            -- bad :: a ⊸ ()
-            -- bad x = let r = R x in case r { self = () } of { R x' -> x' }
-            --
-            -- This should definitely *not* typecheck.
-
-       -- STEP -1  See Note [Disambiguating record fields] in GHC.Tc.Gen.Head
-       -- After this we know that rbinds is unambiguous
-       ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty
-       ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds
-             upd_fld_occs = map (FieldLabelString . occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds
-             sel_ids      = map selectorAmbiguousFieldOcc upd_flds
-             upd_fld_names = map idName sel_ids
-
-       -- STEP 0
-       -- Check that the field names are really field names
-       -- and they are all field names for proper records or
-       -- all field names for pattern synonyms.
-       ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
-                        | fld <- rbinds,
-                          -- Excludes class ops
-                          let L loc sel_id = hsRecUpdFieldId (unLoc fld),
-                          not (isRecordSelector sel_id),
-                          let fld_name = idName sel_id ]
-       ; unless (null bad_guys) (sequence bad_guys >> failM)
-       -- See Note [Mixed Record Field Updates]
-       ; let (data_sels, pat_syn_sels) =
-               partition isDataConRecordSelector sel_ids
-       ; massert (all isPatSynRecordSelector pat_syn_sels)
-       ; checkTc ( null data_sels || null pat_syn_sels )
-                 ( mixedSelectors data_sels pat_syn_sels )
-
-       -- STEP 1
-       -- Figure out the tycon and data cons from the first field name
-       ; let   -- It's OK to use the non-tc splitters here (for a selector)
-             sel_id : _  = sel_ids
-             con_likes :: [ConLike]
-             con_likes = case idDetails sel_id of
-                            RecSelId (RecSelData tc) _
-                               -> map RealDataCon (tyConDataCons tc)
-                            RecSelId (RecSelPatSyn ps) _
-                               -> [PatSynCon ps]
-                            _  -> panic "tcRecordUpd"
-               -- NB: for a data type family, the tycon is the instance tycon
-             relevant_cons = conLikesWithFields con_likes upd_fld_occs
-               -- A constructor is only relevant to this process if
-               -- it contains *all* the fields that are being updated
-               -- Other ones will cause a runtime error if they occur
-
-       -- STEP 2
-       -- Check that at least one constructor has all the named fields
-       -- i.e. has an empty set of bad fields returned by badFields
-       ; case relevant_cons of
-         { [] -> failWithTc (badFieldsUpd rbinds con_likes)
-         ; relevant_con : _ ->
-
-      -- STEP 3
-      -- Create new variables for the fields we are updating,
-      -- so that we can share them across constructors.
-      --
-      -- Example:
-      --
-      --   e { x=e1, y=e2 }
-      --
-      -- We want to let-bind variables to `e1` and `e2`:
-      --
-      --   let x' :: Int
-      --       x' = e1
-      --       y' :: Bool
-      --       y' = e2
-      --   in ...
-
-    do { -- Instantiate the type variables of any relevant constuctor
-         -- with metavariables to obtain a type for each 'Id'.
-         -- This will allow us to have 'Id's with polymorphic types
-         -- by using 'IdSig'. See Wrinkle [Using IdSig] in Note [Record Updates].
-       ; let (univ_tvs, ex_tvs, eq_spec, _, _, arg_tys, con_res_ty) = conLikeFullSig relevant_con
-       ; (subst, tc_tvs) <- newMetaTyVars (univ_tvs ++ ex_tvs)
-       ; let (actual_univ_tys, _actual_ex_tys) = splitAtList univ_tvs $ map mkTyVarTy tc_tvs
-
-             -- See Wrinkle [GADT result type in tcRecordUpd]
-             -- for an explanation of the following.
-             ds_res_ty = case relevant_con of
-               RealDataCon con
-                 | not (null eq_spec) -- We only need to do this if we have actual GADT equalities.
-                 -> mkFamilyTyConApp (dataConTyCon con) actual_univ_tys
-               _ -> substTy subst con_res_ty
-
-       -- Gather pairs of let-bound Ids and their right-hand sides,
-       -- e.g. (x', e1), (y', e2), ...
-       ; let mk_upd_id :: Name -> LHsFieldBind GhcTc fld (LHsExpr GhcRn) -> TcM (Name, (TcId, LHsExpr GhcRn))
-             mk_upd_id fld_nm (L _ rbind)
-               = do { let Scaled m arg_ty = lookupNameEnv_NF arg_ty_env fld_nm
-                          nm_occ = rdrNameOcc . nameRdrName $ fld_nm
-                          actual_arg_ty = substTy subst arg_ty
-                          rhs = hfbRHS rbind
-                    ; (_co, actual_arg_ty) <- hasFixedRuntimeRep (FRRRecordUpdate fld_nm (unLoc rhs)) actual_arg_ty
-                      -- We get a better error message by doing a (redundant) representation-polymorphism check here,
-                      -- rather than delaying until the typechecker typechecks the let-bindings,
-                      -- because the let-bound Ids have internal names.
-                      -- (As we will typecheck the let-bindings later, we can drop this coercion here.)
-                      -- See RepPolyRecordUpdate test.
-                    ; nm <- newNameAt nm_occ generatedSrcSpan
-                    ; let id = mkLocalId nm m actual_arg_ty
-                      -- NB: create fresh names to avoid any accidental shadowing
-                      -- occurring in the RHS expressions when creating the let bindings:
-                      --
-                      --  let x1 = e1; x2 = e2; ...
-                    ; return (fld_nm, (id, rhs))
-                    }
-             arg_ty_env = mkNameEnv
-                        $ zipWith (\ lbl arg_ty -> (flSelector lbl, arg_ty))
-                            (conLikeFieldLabels relevant_con)
-                            arg_tys
-
-       ; upd_ids <- zipWithM mk_upd_id upd_fld_names rbinds
-       ; let updEnv :: UniqMap Name (Id, LHsExpr GhcRn)
-             updEnv = listToUniqMap $ upd_ids
-
-             make_pat :: ConLike -> LMatch GhcRn (LHsExpr GhcRn)
-             -- As explained in Note [Record Updates], to desugar
-             --
-             --   e { x=e1, y=e2 }
-             --
-             -- we generate a case statement, with an equation for
-             -- each constructor of the record. For example, for
-             -- the constructor
-             --
-             --   T1 :: { x :: Int, y :: Bool, z :: Char } -> T p q
-             --
-             -- we let-bind x' = e1, y' = e2 and generate the equation:
-             --
-             --   T1 _ _ z -> T1 x' y' z
-             make_pat conLike = mkSimpleMatch CaseAlt [pat] rhs
-               where
-                 (lhs_con_pats, rhs_con_args)
-                    = zipWithAndUnzip mk_con_arg [1..] con_fields
-                 pat = genSimpleConPat con lhs_con_pats
-                 rhs = wrapGenSpan $ genHsApps con rhs_con_args
-                 con = conLikeName conLike
-                 con_fields = conLikeFieldLabels conLike
-
-             mk_con_arg :: Int
-                        -> FieldLabel
-                        -> ( LPat GhcRn
-                              -- LHS constructor pattern argument
-                           , LHsExpr GhcRn )
-                              -- RHS constructor argument
-             mk_con_arg i fld_lbl =
-               -- The following generates the pattern matches of the desugared `case` expression.
-               -- For fields being updated (for example `x`, `y` in T1 and T4 in Note [Record Updates]),
-               -- wildcards are used to avoid creating unused variables.
-               case lookupUniqMap updEnv $ flSelector fld_lbl of
-                 -- Field is being updated: LHS = wildcard pattern, RHS = appropriate let-bound Id.
-                 Just (upd_id, _) -> (genWildPat, genLHsVar (idName upd_id))
-                 -- Field is not being updated: LHS = variable pattern, RHS = that same variable.
-                 _  -> let fld_nm = mkInternalName (mkBuiltinUnique i)
-                                      (mkVarOccFS (field_label $ flLabel fld_lbl))
-                                      generatedSrcSpan
-                       in (genVarPat fld_nm, genLHsVar fld_nm)
-
-       -- STEP 4
-       -- Desugar to HsCase, as per note [Record Updates]
-       ; let ds_expr :: HsExpr GhcRn
-             ds_expr = HsLet noExtField noHsTok let_binds noHsTok (L gen case_expr)
-
-             case_expr :: HsExpr GhcRn
-             case_expr = HsCase noExtField record_expr (mkMatchGroup Generated (wrapGenSpan matches))
-             matches :: [LMatch GhcRn (LHsExpr GhcRn)]
-             matches = map make_pat relevant_cons
-
-             let_binds :: HsLocalBindsLR GhcRn GhcRn
-             let_binds = HsValBinds noAnn $ XValBindsLR
-                       $ NValBinds upd_ids_lhs (map mk_idSig upd_ids)
-             upd_ids_lhs :: [(RecFlag, LHsBindsLR GhcRn GhcRn)]
-             upd_ids_lhs = [ (NonRecursive, unitBag $ genSimpleFunBind (idName id) [] rhs)
-                           | (_, (id, rhs)) <- upd_ids ]
-             mk_idSig :: (Name, (Id, LHsExpr GhcRn)) -> LSig GhcRn
-             mk_idSig (_, (id, _)) = L gen $ XSig $ IdSig id
-               -- We let-bind variables using 'IdSig' in order to accept
-               -- record updates involving higher-rank types.
-               -- See Wrinkle [Using IdSig] in Note [Record Updates].
-             gen = noAnnSrcSpan generatedSrcSpan
-
-        ; traceTc "desugarRecordUpd" $
-            vcat [ text "relevant_con:" <+> ppr relevant_con
-                 , text "res_ty:" <+> ppr res_ty
-                 , text "ds_res_ty:" <+> ppr ds_res_ty
-                 ]
-
-        ; let cons = pprQuotedList relevant_cons
-              err_lines =
-                (text "In a record update at field" <> plural upd_fld_names <+> pprQuotedList upd_fld_names :)
-                $ case relevant_con of
-                     RealDataCon con ->
-                        [ text "with type constructor" <+> quotes (ppr (dataConTyCon con))
-                        , text "data constructor" <+> plural relevant_cons <+> cons ]
-                     PatSynCon {} ->
-                        [ text "with pattern synonym" <+> plural relevant_cons <+> cons ]
-                ++ if null ex_tvs
-                   then []
-                   else [ text "existential variable" <> plural ex_tvs <+> pprQuotedList ex_tvs ]
-              err_ctxt = make_lines_msg err_lines
-
-        ; return (ds_expr, ds_res_ty, err_ctxt) } } }
-
--- | Pretty-print a collection of lines, adding commas at the end of each line,
--- and adding "and" to the start of the last line.
-make_lines_msg :: [SDoc] -> SDoc
-make_lines_msg []      = empty
-make_lines_msg [last]  = ppr last <> dot
-make_lines_msg [l1,l2] = l1 $$ text "and" <+> l2 <> dot
-make_lines_msg (l:ls)  = l <> comma $$ make_lines_msg ls
-
-{- *********************************************************************
-*                                                                      *
-                 Record bindings
-*                                                                      *
-********************************************************************* -}
-
--- Disambiguate the fields in a record update.
--- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head
-disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType
-                 -> [LHsRecUpdField GhcRn] -> ExpRhoType
-                 -> TcM [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-disambiguateRecordBinds record_expr record_rho rbnds res_ty
-    -- Are all the fields unambiguous?
-  = case mapM isUnambiguous rbnds of
-                     -- If so, just skip to looking up the Ids
-                     -- Always the case if DuplicateRecordFields is off
-      Just rbnds' -> mapM lookupSelector rbnds'
-      Nothing     -> -- If not, try to identify a single parent
-        do { fam_inst_envs <- tcGetFamInstEnvs
-             -- Look up the possible parents for each field
-           ; rbnds_with_parents <- getUpdFieldsParents
-           ; let possible_parents = map (map fst . snd) rbnds_with_parents
-             -- Identify a single parent
-           ; p <- identifyParent fam_inst_envs possible_parents
-             -- Pick the right selector with that parent for each field
-           ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }
-  where
-    -- Extract the selector name of a field update if it is unambiguous
-    isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)
-    isUnambiguous x = case unLoc (hfbLHS (unLoc x)) of
-                        Unambiguous sel_name _ -> Just (x, sel_name)
-                        Ambiguous{}            -> Nothing
-
-    -- Look up the possible parents and selector GREs for each field
-    getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn
-                                , [(RecSelParent, GlobalRdrElt)])]
-    getUpdFieldsParents
-      = fmap (zip rbnds) $ mapM
-          (lookupParents False . unLoc . hsRecUpdFieldRdr . unLoc)
-          rbnds
-
-    -- Given a the lists of possible parents for each field,
-    -- identify a single parent
-    identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
-    identifyParent fam_inst_envs possible_parents
-      = case foldr1 intersect possible_parents of
-        -- No parents for all fields: record update is ill-typed
-        []  -> failWithTc (TcRnNoPossibleParentForFields rbnds)
-
-        -- Exactly one datatype with all the fields: use that
-        [p] -> return p
-
-        -- Multiple possible parents: try harder to disambiguate
-        -- Can we get a parent TyCon from the pushed-in type?
-        _:_ | Just p <- tyConOfET fam_inst_envs res_ty ->
-              do { reportAmbiguousField p
-                 ; return (RecSelData p) }
-
-        -- Does the expression being updated have a type signature?
-        -- If so, try to extract a parent TyCon from it
-            | Just {} <- obviousSig (unLoc record_expr)
-            , Just tc <- tyConOf fam_inst_envs record_rho
-            -> do { reportAmbiguousField tc
-                  ; return (RecSelData tc) }
-
-        -- Nothing else we can try...
-        _ -> failWithTc (TcRnBadOverloadedRecordUpdate rbnds)
-
-    -- Make a field unambiguous by choosing the given parent.
-    -- Emits an error if the field cannot have that parent,
-    -- e.g. if the user writes
-    --     r { x = e } :: T
-    -- where T does not have field x.
-    pickParent :: RecSelParent
-               -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
-               -> TcM (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
-    pickParent p (upd, xs)
-      = case lookup p xs of
-                      -- Phew! The parent is valid for this field.
-                      -- Previously ambiguous fields must be marked as
-                      -- used now that we know which one is meant, but
-                      -- unambiguous ones shouldn't be recorded again
-                      -- (giving duplicate deprecation warnings).
-          Just gre -> do { unless (null (tail xs)) $ do
-                             let L loc _ = hfbLHS (unLoc upd)
-                             setSrcSpanA loc $ addUsedGRE True gre
-                         ; lookupSelector (upd, greMangledName gre) }
-                      -- The field doesn't belong to this parent, so report
-                      -- an error but keep going through all the fields
-          Nothing  -> do { addErrTc (fieldNotInType p
-                                      (unLoc (hsRecUpdFieldRdr (unLoc upd))))
-                         ; lookupSelector (upd, greMangledName (snd (head xs))) }
-
-    -- Given a (field update, selector name) pair, look up the
-    -- selector to give a field update with an unambiguous Id
-    lookupSelector :: (LHsRecUpdField GhcRn, Name)
-                 -> TcM (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
-    lookupSelector (L l upd, n)
-      = do { i <- tcLookupId n
-           ; let L loc af = hfbLHS upd
-                 lbl      = rdrNameAmbiguousFieldOcc af
-           ; return $ L l HsFieldBind
-               { hfbAnn = hfbAnn upd
-               , hfbLHS
-                       = L (l2l loc) (Unambiguous i (L (l2l loc) lbl))
-               , hfbRHS = hfbRHS upd
-               , hfbPun = hfbPun upd
-               }
-           }
-
-    -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head
-    reportAmbiguousField :: TyCon -> TcM ()
-    reportAmbiguousField parent_type =
-        setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousField rupd parent_type
-      where
-        rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField }
-        loc  = getLocA (head rbnds)
-
-{-
-Game plan for record bindings
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-1. Find the TyCon for the bindings, from the first field label.
-
-2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
-
-For each binding field = value
-
-3. Instantiate the field type (from the field label) using the type
-   envt from step 2.
-
-4  Type check the value using tcCheckPolyExprNC (in tcRecordField),
-   passing the field type as the expected argument type.
-
-This extends OK when the field types are universally quantified.
--}
-
-tcRecordBinds
-        :: ConLike
-        -> [TcType]     -- Expected type for each field
-        -> HsRecordBinds GhcRn
-        -> TcM (HsRecordBinds GhcTc)
-
-tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)
-  = do  { mb_binds <- mapM do_bind rbinds
-        ; return (HsRecFields (catMaybes mb_binds) dd) }
-  where
-    fields = map flSelector $ conLikeFieldLabels con_like
-    flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys
-
-    do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
-            -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
-    do_bind (L l fld@(HsFieldBind { hfbLHS = f
-                                 , hfbRHS = rhs }))
-
-      = do { mb <- tcRecordField con_like flds_w_tys f rhs
-           ; case mb of
-               Nothing         -> return Nothing
-               -- Just (f', rhs') -> return (Just (L l (fld { hfbLHS = f'
-               --                                            , hfbRHS = rhs' }))) }
-               Just (f', rhs') -> return (Just (L l (HsFieldBind
-                                                     { hfbAnn = hfbAnn fld
-                                                     , hfbLHS = f'
-                                                     , hfbRHS = rhs'
-                                                     , hfbPun = hfbPun fld}))) }
-
-
-tcRecordField :: ConLike -> Assoc Name Type
-              -> LFieldOcc GhcRn -> LHsExpr GhcRn
-              -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
-tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
-  | Just field_ty <- assocMaybe flds_w_tys sel_name
-      = addErrCtxt (fieldCtxt field_lbl) $
-        do { rhs' <- tcCheckPolyExprNC rhs field_ty
-           ; hasFixedRuntimeRep_syntactic (FRRRecordCon (unLoc lbl) (unLoc rhs'))
-                field_ty
-           ; let field_id = mkUserLocal (nameOccName sel_name)
-                                        (nameUnique sel_name)
-                                        ManyTy field_ty (locA loc)
-                -- Yuk: the field_id has the *unique* of the selector Id
-                --          (so we can find it easily)
-                --      but is a LocalId with the appropriate type of the RHS
-                --          (so the desugarer knows the type of local binder to make)
-           ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }
-      | otherwise
-      = do { addErrTc (badFieldConErr (getName con_like) field_lbl)
-           ; return Nothing }
-  where
-        field_lbl = FieldLabelString $ occNameFS $ rdrNameOcc (unLoc lbl)
-
-
-checkMissingFields ::  ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
-checkMissingFields con_like rbinds arg_tys
-  | null field_labels   -- Not declared as a record;
-                        -- But C{} is still valid if no strict fields
-  = if any isBanged field_strs then
-        -- Illegal if any arg is strict
-        addErrTc (TcRnMissingStrictFields con_like [])
-    else do
-        when (notNull field_strs && null field_labels) $ do
-          let msg = TcRnMissingFields con_like []
-          (diagnosticTc True msg)
-
-  | otherwise = do              -- A record
-    unless (null missing_s_fields) $ do
-        fs <- zonk_fields missing_s_fields
-        -- It is an error to omit a strict field, because
-        -- we can't substitute it with (error "Missing field f")
-        addErrTc (TcRnMissingStrictFields con_like fs)
-
-    warn <- woptM Opt_WarnMissingFields
-    when (warn && notNull missing_ns_fields) $ do
-        fs <- zonk_fields missing_ns_fields
-        -- It is not an error (though we may want) to omit a
-        -- lazy field, because we can always use
-        -- (error "Missing field f") instead.
-        let msg = TcRnMissingFields con_like fs
-        diagnosticTc True msg
-
-  where
-    -- we zonk the fields to get better types in error messages (#18869)
-    zonk_fields fs = forM fs $ \(str,ty) -> do
-        ty' <- zonkTcType ty
-        return (str,ty')
-    missing_s_fields
-        = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info,
-                 isBanged str,
-                 not (fl `elemField` field_names_used)
-          ]
-    missing_ns_fields
-        = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info,
-                 not (isBanged str),
-                 not (fl `elemField` field_names_used)
-          ]
-
-    field_names_used = hsRecFields rbinds
-    field_labels     = conLikeFieldLabels con_like
-
-    field_info = zip3 field_labels field_strs arg_tys
-
-    field_strs = conLikeImplBangs con_like
-
-    fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Errors and contexts}
-*                                                                      *
-************************************************************************
-
-Boring and alphabetical:
--}
-
-fieldCtxt :: FieldLabelString -> SDoc
-fieldCtxt field_name
-  = text "In the" <+> quotes (ppr field_name) <+> text "field of a record"
-
-badFieldsUpd
-  :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
-               -- Field names that don't belong to a single datacon
-  -> [ConLike] -- Data cons of the type which the first field name belongs to
-  -> TcRnMessage
-badFieldsUpd rbinds data_cons
-  = TcRnNoConstructorHasAllFields conflictingFields
-          -- See Note [Finding the conflicting fields]
-  where
-    -- A (preferably small) set of fields such that no constructor contains
-    -- all of them.  See Note [Finding the conflicting fields]
-    conflictingFields = case nonMembers of
-        -- nonMember belongs to a different type.
-        (nonMember, _) : _ -> [aMember, nonMember]
-        [] -> let
-            -- All of rbinds belong to one type. In this case, repeatedly add
-            -- a field to the set until no constructor contains the set.
-
-            -- Each field, together with a list indicating which constructors
-            -- have all the fields so far.
-            growingSets :: [(FieldLabelString, [Bool])]
-            growingSets = scanl1 combine membership
-            combine (_, setMem) (field, fldMem)
-              = (field, zipWith (&&) setMem fldMem)
-            in
-            -- Fields that don't change the membership status of the set
-            -- are redundant and can be dropped.
-            map (fst . NE.head) $ NE.groupWith snd growingSets
-
-    aMember = assert (not (null members) ) fst (head members)
-    (members, nonMembers) = partition (or . snd) membership
-
-    -- For each field, which constructors contain the field?
-    membership :: [(FieldLabelString, [Bool])]
-    membership = sortMembership $
-        map (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) $
-          map (FieldLabelString . occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) rbinds
-
-    fieldLabelSets :: [UniqSet FieldLabelString]
-    fieldLabelSets = map (mkUniqSet . map flLabel . conLikeFieldLabels) data_cons
-
-    -- Sort in order of increasing number of True, so that a smaller
-    -- conflicting set can be found.
-    sortMembership =
-      map snd .
-      sortBy (compare `on` fst) .
-      map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))
-
-    countTrue = count id
-
-{-
-Note [Finding the conflicting fields]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-  data A = A {a0, a1 :: Int}
-         | B {b0, b1 :: Int}
-and we see a record update
-  x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }
-Then we'd like to find the smallest subset of fields that no
-constructor has all of.  Here, say, {a0,b0}, or {a0,b1}, etc.
-We don't really want to report that no constructor has all of
-{a0,a1,b0,b1}, because when there are hundreds of fields it's
-hard to see what was really wrong.
-
-We may need more than two fields, though; eg
-  data T = A { x,y :: Int, v::Int }
-          | B { y,z :: Int, v::Int }
-          | C { z,x :: Int, v::Int }
-with update
-   r { x=e1, y=e2, z=e3 }, we
-
-Finding the smallest subset is hard, so the code here makes
-a decent stab, no more.  See #7989.
--}
-
-mixedSelectors :: [Id] -> [Id] -> TcRnMessage
-mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)
-  = TcRnMixedSelectors (tyConName rep_dc) data_sels (patSynName rep_ps) pat_syn_sels
-  where
-    RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id
-    RecSelData rep_dc = recordSelectorTyCon dc_rep_id
-mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists"
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Static Pointers}
-*                                                                      *
-************************************************************************
--}
-
--- | Checks if the given name is closed and emits an error if not.
---
--- See Note [Not-closed error messages].
-checkClosedInStaticForm :: Name -> TcM ()
-checkClosedInStaticForm name = do
-    type_env <- getLclTypeEnv
-    case checkClosed type_env name of
-      Nothing -> return ()
-      Just reason -> addErrTc $ explain name reason
-  where
-    -- See Note [Checking closedness].
-    checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
-    checkClosed type_env n = checkLoop type_env (unitNameSet n) n
-
-    checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
-    checkLoop type_env visited n =
-      -- The @visited@ set is an accumulating parameter that contains the set of
-      -- visited nodes, so we avoid repeating cycles in the traversal.
-      case lookupNameEnv type_env n of
-        Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of
-          ClosedLet   -> Nothing
-          NotLetBound -> Just NotLetBoundReason
-          NonClosedLet fvs type_closed -> listToMaybe $
-            -- Look for a non-closed variable in fvs
-            [ NotClosed n' reason
-            | n' <- nameSetElemsStable fvs
-            , not (elemNameSet n' visited)
-            , Just reason <- [checkLoop type_env (extendNameSet visited n') n']
-            ] ++
-            if type_closed then
-              []
-            else
-              -- We consider non-let-bound variables easier to figure out than
-              -- non-closed types, so we report non-closed types to the user
-              -- only if we cannot spot the former.
-              [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ]
-        -- The binding is closed.
-        _ -> Nothing
-
-    -- Converts a reason into a human-readable sentence.
-    --
-    -- @explain name reason@ starts with
-    --
-    -- "<name> is used in a static form but it is not closed because it"
-    --
-    -- and then follows a list of causes. For each id in the path, the text
-    --
-    -- "uses <id> which"
-    --
-    -- is appended, yielding something like
-    --
-    -- "uses <id> which uses <id1> which uses <id2> which"
-    --
-    -- until the end of the path is reached, which is reported as either
-    --
-    -- "is not let-bound"
-    --
-    -- when the final node is not let-bound, or
-    --
-    -- "has a non-closed type because it contains the type variables:
-    -- v1, v2, v3"
-    --
-    -- when the final node has a non-closed type.
-    --
-    explain :: Name -> NotClosedReason -> TcRnMessage
-    explain = TcRnStaticFormNotClosed
-
--- Note [Not-closed error messages]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- When variables in a static form are not closed, we go through the trouble
--- of explaining why they aren't.
---
--- Thus, the following program
---
--- > {-# LANGUAGE StaticPointers #-}
--- > module M where
--- >
--- > f x = static g
--- >   where
--- >     g = h
--- >     h = x
---
--- produces the error
---
---    'g' is used in a static form but it is not closed because it
---    uses 'h' which uses 'x' which is not let-bound.
---
--- And a program like
---
--- > {-# LANGUAGE StaticPointers #-}
--- > module M where
--- >
--- > import Data.Typeable
--- > import GHC.StaticPtr
--- >
--- > f :: Typeable a => a -> StaticPtr TypeRep
--- > f x = const (static (g undefined)) (h x)
--- >   where
--- >     g = h
--- >     h = typeOf
---
--- produces the error
---
---    'g' is used in a static form but it is not closed because it
---    uses 'h' which has a non-closed type because it contains the
---    type variables: 'a'
---
-
--- Note [Checking closedness]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~
---
--- @checkClosed@ checks if a binding is closed and returns a reason if it is
--- not.
---
--- The bindings define a graph where the nodes are ids, and there is an edge
--- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free
--- variables.
---
--- When @n@ is not closed, it has to exist in the graph some node reachable
--- from @n@ that it is not a let-bound variable or that it has a non-closed
--- type. Thus, the "reason" is a path from @n@ to this offending node.
---
--- When @n@ is not closed, we traverse the graph reachable from @n@ to build
--- the reason.
---
diff --git a/compiler/GHC/Tc/Gen/Expr.hs-boot b/compiler/GHC/Tc/Gen/Expr.hs-boot
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs-boot
+++ /dev/null
@@ -1,45 +0,0 @@
-module GHC.Tc.Gen.Expr where
-import GHC.Hs              ( HsExpr, LHsExpr, SyntaxExprRn
-                           , SyntaxExprTc )
-import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, TcSigmaTypeFRR
-                           , SyntaxOpType
-                           , ExpType, ExpRhoType, ExpSigmaType )
-import GHC.Tc.Types        ( TcM )
-import GHC.Tc.Types.Origin ( CtOrigin )
-import GHC.Core.Type ( Mult )
-import GHC.Hs.Extension ( GhcRn, GhcTc )
-
-tcCheckPolyExpr, tcCheckPolyExprNC ::
-          LHsExpr GhcRn
-       -> TcSigmaType
-       -> TcM (LHsExpr GhcTc)
-
-tcMonoExpr, tcMonoExprNC ::
-          LHsExpr GhcRn
-       -> ExpRhoType
-       -> TcM (LHsExpr GhcTc)
-tcCheckMonoExpr, tcCheckMonoExprNC ::
-          LHsExpr GhcRn
-       -> TcRhoType
-       -> TcM (LHsExpr GhcTc)
-
-tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
-tcExpr     :: HsExpr GhcRn -> ExpRhoType   -> TcM (HsExpr GhcTc)
-
-tcInferRho, tcInferRhoNC ::
-          LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
-
-tcSyntaxOp :: CtOrigin
-           -> SyntaxExprRn
-           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments
-           -> ExpType                  -- ^ overall result type
-           -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a) -- ^ Type check any arguments
-           -> TcM (a, SyntaxExprTc)
-
-tcSyntaxOpGen :: CtOrigin
-              -> SyntaxExprRn
-              -> [SyntaxOpType]
-              -> SyntaxOpType
-              -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)
-              -> TcM (a, SyntaxExprTc)
-
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ /dev/null
@@ -1,568 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1998
-
--}
-
-
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ViewPatterns #-}
-
--- | Typechecking @foreign@ declarations
---
--- A foreign declaration is used to either give an externally
--- implemented function a Haskell type (and calling interface) or
--- give a Haskell function an external calling interface. Either way,
--- the range of argument and result types these functions can accommodate
--- is restricted to what the outside world understands (read C), and this
--- module checks to see if a foreign declaration has got a legal type.
-module GHC.Tc.Gen.Foreign
-        ( tcForeignImports
-        , tcForeignExports
-
-        -- Low-level exports for hooks
-        , isForeignImport, isForeignExport
-        , tcFImport, tcFExport
-        , tcForeignImports'
-        , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes
-        , normaliseFfiType
-        , nonIOok, mustBeIO
-        , checkSafe, noCheckSafe
-        , tcForeignExports'
-        , tcCheckFEType
-        ) where
-
-import GHC.Prelude
-
-import GHC.Hs
-
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Gen.HsType
-import GHC.Tc.Gen.Expr
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Instance.Family
-
-import GHC.Core.FamInstEnv
-import GHC.Core.Coercion
-import GHC.Core.Reduction
-import GHC.Core.Type
-import GHC.Core.Multiplicity
-import GHC.Core.DataCon
-import GHC.Core.TyCon
-import GHC.Core.TyCon.RecWalk
-
-import GHC.Types.ForeignCall
-import GHC.Types.Id
-import GHC.Types.Name
-import GHC.Types.Name.Reader
-import GHC.Types.SrcLoc
-
-import GHC.Builtin.Names
-import GHC.Builtin.Types.Prim( isArrowTyCon )
-
-import GHC.Driver.Session
-import GHC.Driver.Backend
-
-import GHC.Utils.Error
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import GHC.Platform
-
-import GHC.Data.Bag
-import GHC.Driver.Hooks
-import qualified GHC.LanguageExtensions as LangExt
-
-import Control.Monad ( zipWithM )
-import Control.Monad.Trans.Writer.CPS
-  ( WriterT, runWriterT, tell )
-import Control.Monad.Trans.Class
-  ( lift )
-
--- Defines a binding
-isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool
-isForeignImport (unXRec @name -> ForeignImport {}) = True
-isForeignImport _                        = False
-
--- Exports a binding
-isForeignExport :: forall name. UnXRec name => LForeignDecl name -> Bool
-isForeignExport (unXRec @name -> ForeignExport {}) = True
-isForeignExport _                        = False
-
-{-
-Note [Don't recur in normaliseFfiType']
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-normaliseFfiType' is the workhorse for normalising a type used in a foreign
-declaration. If we have
-
-newtype Age = MkAge Int
-
-we want to see that Age -> IO () is the same as Int -> IO (). But, we don't
-need to recur on any type parameters, because no parameterized types (with
-interesting parameters) are marshalable! The full list of marshalable types
-is in the body of boxedMarshalableTyCon in GHC.Tc.Utils.TcType. The only members of that
-list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled
-the same way regardless of type parameter. So, no need to recur into
-parameters.
-
-Similarly, we don't need to look in AppTy's, because nothing headed by
-an AppTy will be marshalable.
--}
-
--- normaliseFfiType takes the type from an FFI declaration, and
--- evaluates any type synonyms, type functions, and newtypes. However,
--- we are only allowed to look through newtypes if the constructor is
--- in scope.  We return a bag of all the newtype constructors thus found.
--- Always returns a Representational coercion
-normaliseFfiType :: Type -> TcM (Reduction, Bag GlobalRdrElt)
-normaliseFfiType ty
-    = do fam_envs <- tcGetFamInstEnvs
-         normaliseFfiType' fam_envs ty
-
-normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Reduction, Bag GlobalRdrElt)
-normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0
-  where
-    go :: Role -> RecTcChecker -> Type -> WriterT (Bag GlobalRdrElt) TcM Reduction
-    go role rec_nts ty
-      | Just ty' <- coreView ty     -- Expand synonyms
-      = go role rec_nts ty'
-
-      | Just (tc, tys) <- splitTyConApp_maybe ty
-      = go_tc_app role rec_nts tc tys
-
-      | (bndrs, inner_ty) <- splitForAllForAllTyBinders ty
-      , not (null bndrs)
-      = do redn <- go role rec_nts inner_ty
-           return $ mkHomoForAllRedn bndrs redn
-
-      | otherwise -- see Note [Don't recur in normaliseFfiType']
-      = return $ mkReflRedn role ty
-
-    go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type]
-              -> WriterT (Bag GlobalRdrElt) TcM Reduction
-    go_tc_app role rec_nts tc tys
-        | isArrowTyCon tc  -- Recurse through arrows, or at least the top
-        = children_only    -- level arrows.  Remember, the default case is
-                           -- "don't recurse" (see last eqn for go_tc_app)
-
-        | tc_key `elem` [ioTyConKey, funPtrTyConKey]
-        -- We don't want to look through the IO newtype, even if it is
-        -- in scope, so we have a special case for it:
-        = children_only
-
-        | isNewTyCon tc         -- Expand newtypes
-        , Just rec_nts' <- checkRecTc rec_nts tc
-                   -- See Note [Expanding newtypes and products] in GHC.Core.TyCon.RecWalk
-                   -- We can't just use isRecursiveTyCon; sometimes recursion is ok:
-                   --     newtype T = T (Ptr T)
-                   --   Here, we don't reject the type for being recursive.
-                   -- If this is a recursive newtype then it will normally
-                   -- be rejected later as not being a valid FFI type.
-        = do { rdr_env <- lift $ getGlobalRdrEnv
-             ; case checkNewtypeFFI rdr_env tc of
-                 Nothing  -> nothing
-                 Just gre ->
-                   do { redn <- go role rec_nts' nt_rhs
-                      ; tell (unitBag gre)
-                      ; return $ nt_co `mkTransRedn` redn } }
-
-        | isFamilyTyCon tc              -- Expand open tycons
-        , Reduction co ty <- normaliseTcApp env role tc tys
-        , not (isReflexiveCo co)
-        = do redn <- go role rec_nts ty
-             return $ co `mkTransRedn` redn
-
-        | otherwise
-        = nothing -- see Note [Don't recur in normaliseFfiType']
-        where
-          tc_key = getUnique tc
-          children_only
-            = do { args <- unzipRedns <$>
-                            zipWithM ( \ ty r -> go r rec_nts ty )
-                                     tys (tyConRoleListX role tc)
-                 ; return $ mkTyConAppRedn role tc args }
-          nt_co  = mkUnbranchedAxInstCo role (newTyConCo tc) tys []
-          nt_rhs = newTyConInstRhs tc tys
-
-          ty      = mkTyConApp tc tys
-          nothing = return $ mkReflRedn role ty
-
-checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
-checkNewtypeFFI rdr_env tc
-  | Just con <- tyConSingleDataCon_maybe tc
-  , Just gre <- lookupGRE_Name rdr_env (dataConName con)
-  = Just gre    -- See Note [Newtype constructor usage in foreign declarations]
-  | otherwise
-  = Nothing
-
-{-
-Note [Newtype constructor usage in foreign declarations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-GHC automatically "unwraps" newtype constructors in foreign import/export
-declarations.  In effect that means that a newtype data constructor is
-used even though it is not mentioned expclitly in the source, so we don't
-want to report it as "defined but not used" or "imported but not used".
-eg     newtype D = MkD Int
-       foreign import foo :: D -> IO ()
-Here 'MkD' is used.  See #7408.
-
-GHC also expands type functions during this process, so it's not enough
-just to look at the free variables of the declaration.
-eg     type instance F Bool = D
-       foreign import bar :: F Bool -> IO ()
-Here again 'MkD' is used.
-
-So we really have wait until the type checker to decide what is used.
-That's why tcForeignImports and tecForeignExports return a (Bag GRE)
-for the newtype constructors they see. Then GHC.Tc.Module can add them
-to the module's usages.
-
-
-************************************************************************
-*                                                                      *
-\subsection{Imports}
-*                                                                      *
-************************************************************************
--}
-
-tcForeignImports :: [LForeignDecl GhcRn]
-                 -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
-tcForeignImports decls = do
-    hooks <- getHooks
-    case tcForeignImportsHook hooks of
-        Nothing -> tcForeignImports' decls
-        Just h  -> h decls
-
-tcForeignImports' :: [LForeignDecl GhcRn]
-                  -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
--- For the (Bag GlobalRdrElt) result,
--- see Note [Newtype constructor usage in foreign declarations]
-tcForeignImports' decls
-  = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $
-                               filter isForeignImport decls
-       ; return (ids, decls, unionManyBags gres) }
-
-tcFImport :: LForeignDecl GhcRn
-          -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
-tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
-                                    , fd_fi = imp_decl }))
-  = setSrcSpanA dloc $ addErrCtxt (foreignDeclCtxt fo)  $
-    do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
-       ; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty
-       ; let
-             -- Drop the foralls before inspecting the
-             -- structure of the foreign type.
-             -- Use splitFunTys, which splits (=>) as well as (->)
-             -- so that for  foreign import foo :: Eq a => a -> blah
-             -- we get "unacceptable argument Eq a" rather than
-             --        "unacceptable result Eq a => a -> blah"
-             -- Not a big deal.  We could make a better error message specially
-             -- for overloaded functions, but doesn't seem worth it
-             (arg_tys, res_ty) = splitFunTys (dropForAlls norm_sig_ty)
-
-             id = mkLocalId nm ManyTy sig_ty
-                 -- Use a LocalId to obey the invariant that locally-defined
-                 -- things are LocalIds.  However, it does not need zonking,
-                 -- (so GHC.Tc.Utils.Zonk.zonkForeignExports ignores it).
-
-       ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl
-          -- Can't use sig_ty here because sig_ty :: Type and
-          -- we need HsType Id hence the undefined
-       ; let fi_decl = ForeignImport { fd_name = L nloc id
-                                     , fd_sig_ty = undefined
-                                     , fd_i_ext = mkSymCo norm_co
-                                     , fd_fi = imp_decl' }
-       ; return (id, L dloc fi_decl, gres) }
-tcFImport d = pprPanic "tcFImport" (ppr d)
-
--- ------------ Checking types for foreign import ----------------------
-
-tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport GhcRn -> TcM (ForeignImport GhcTc)
-
-tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh l@(CLabel _))
-  -- Foreign import label
-  = do checkCg (Right idecl) backendValidityOfCImport
-       -- NB check res_ty not sig_ty!
-       --    In case sig_ty is (forall a. ForeignPtr a)
-       check (isFFILabelTy (mkScaledFunTys arg_tys res_ty))
-             (TcRnIllegalForeignType Nothing)
-       cconv' <- checkCConv (Right idecl) cconv
-       return (CImport src (L lc cconv') safety mh l)
-
-tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh CWrapper) = do
-        -- Foreign wrapper (former f.e.d.)
-        -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid
-        -- foreign type.  For legacy reasons ft -> IO (Ptr ft) is accepted, too.
-        -- The use of the latter form is DEPRECATED, though.
-    checkCg (Right idecl) backendValidityOfCImport
-    cconv' <- checkCConv (Right idecl) cconv
-    case arg_tys of
-        [Scaled arg1_mult arg1_ty] -> do
-                        checkNoLinearFFI arg1_mult
-                        checkForeignArgs isFFIExternalTy arg1_tys
-                        checkForeignRes nonIOok  checkSafe isFFIExportResultTy res1_ty
-                        checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty
-                  where
-                     (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
-        _ -> addErrTc (TcRnIllegalForeignType Nothing OneArgExpected)
-    return (CImport src (L lc cconv') safety mh CWrapper)
-
-tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) (L ls safety) mh
-                                            (CFunction target))
-  | isDynamicTarget target = do -- Foreign import dynamic
-      checkCg (Right idecl) backendValidityOfCImport
-      cconv' <- checkCConv (Right idecl) cconv
-      case arg_tys of           -- The first arg must be Ptr or FunPtr
-        []                ->
-          addErrTc (TcRnIllegalForeignType Nothing AtLeastOneArgExpected)
-        (Scaled arg1_mult arg1_ty:arg_tys) -> do
-          dflags <- getDynFlags
-          let curried_res_ty = mkScaledFunTys arg_tys res_ty
-          checkNoLinearFFI arg1_mult
-          check (isFFIDynTy curried_res_ty arg1_ty)
-                (TcRnIllegalForeignType (Just Arg))
-          checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
-          checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
-      return $ CImport src (L lc cconv') (L ls safety) mh (CFunction target)
-  | cconv == PrimCallConv = do
-      dflags <- getDynFlags
-      checkTc (xopt LangExt.GHCForeignImportPrim dflags)
-              (TcRnForeignImportPrimExtNotSet idecl)
-      checkCg (Right idecl) backendValidityOfCImport
-      checkCTarget idecl target
-      checkTc (playSafe safety)
-              (TcRnForeignImportPrimSafeAnn idecl)
-      checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
-      -- prim import result is more liberal, allows (#,,#)
-      checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
-      return (CImport src (L lc cconv) (L ls safety) mh (CFunction target))
-  | cconv == JavaScriptCallConv = do
-      checkCg (Right idecl) backendValidityOfCImport
-      -- leave the rest to the JS backend (at least for now)
-      return (CImport src (L lc cconv) (L ls safety) mh (CFunction target))
-  | otherwise = do              -- Normal foreign import
-      checkCg (Right idecl) backendValidityOfCImport
-      cconv' <- checkCConv (Right idecl) cconv
-      checkCTarget idecl target
-      dflags <- getDynFlags
-      checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
-      checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
-      checkMissingAmpersand idecl (map scaledThing arg_tys) res_ty
-      case target of
-          StaticTarget _ _ _ False
-           | not (null arg_tys) ->
-              addErrTc (TcRnForeignFunctionImportAsValue idecl)
-          _ -> return ()
-      return $ CImport src (L lc cconv') (L ls safety) mh (CFunction target)
-
--- This makes a convenient place to check
--- that the C identifier is valid for C
-checkCTarget :: ForeignImport GhcRn -> CCallTarget -> TcM ()
-checkCTarget idecl (StaticTarget _ str _ _) = do
-    checkCg (Right idecl) backendValidityOfCImport
-    checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)
-
-checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget"
-
-checkMissingAmpersand :: ForeignImport GhcRn -> [Type] -> Type -> TcM ()
-checkMissingAmpersand idecl arg_tys res_ty
-  | null arg_tys && isFunPtrTy res_ty
-  = addDiagnosticTc $ TcRnFunPtrImportWithoutAmpersand idecl
-  | otherwise
-  = return ()
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Exports}
-*                                                                      *
-************************************************************************
--}
-
-tcForeignExports :: [LForeignDecl GhcRn]
-             -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
-tcForeignExports decls = do
-    hooks <- getHooks
-    case tcForeignExportsHook hooks of
-        Nothing -> tcForeignExports' decls
-        Just h  -> h decls
-
-tcForeignExports' :: [LForeignDecl GhcRn]
-             -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
--- For the (Bag GlobalRdrElt) result,
--- see Note [Newtype constructor usage in foreign declarations]
-tcForeignExports' decls
-  = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls)
-  where
-   combine (binds, fs, gres1) (L loc fe) = do
-       (b, f, gres2) <- setSrcSpanA loc (tcFExport fe)
-       return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)
-
-tcFExport :: ForeignDecl GhcRn
-          -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
-tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec })
-  = addErrCtxt (foreignDeclCtxt fo) $ do
-
-    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
-    rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty
-
-    (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty
-
-    spec' <- tcCheckFEType norm_sig_ty spec
-
-           -- we're exporting a function, but at a type possibly more
-           -- constrained than its declared/inferred type. Hence the need
-           -- to create a local binding which will call the exported function
-           -- at a particular type (and, maybe, overloading).
-
-
-    -- We need to give a name to the new top-level binding that
-    -- is *stable* (i.e. the compiler won't change it later),
-    -- because this name will be referred to by the C code stub.
-    id  <- mkStableIdFromName nm sig_ty (locA loc) mkForeignExportOcc
-    return ( mkVarBind id rhs
-           , ForeignExport { fd_name = L loc id
-                           , fd_sig_ty = undefined
-                           , fd_e_ext = norm_co
-                           , fd_fe = spec' }
-           , gres)
-tcFExport d = pprPanic "tcFExport" (ppr d)
-
--- ------------ Checking argument types for foreign export ----------------------
-
-tcCheckFEType :: Type -> ForeignExport GhcRn -> TcM (ForeignExport GhcTc)
-tcCheckFEType sig_ty edecl@(CExport src (L l (CExportStatic esrc str cconv))) = do
-    checkCg (Left edecl) backendValidityOfCExport
-    checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)
-    cconv' <- checkCConv (Left edecl) cconv
-    checkForeignArgs isFFIExternalTy arg_tys
-    checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
-    return (CExport src (L l (CExportStatic esrc str cconv')))
-  where
-      -- Drop the foralls before inspecting
-      -- the structure of the foreign type.
-    (arg_tys, res_ty) = tcSplitFunTys (dropForAlls sig_ty)
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Miscellaneous}
-*                                                                      *
-************************************************************************
--}
-
------------- Checking argument types for foreign import ----------------------
-checkForeignArgs :: (Type -> Validity' IllegalForeignTypeReason) -> [Scaled Type] -> TcM ()
-checkForeignArgs pred tys = mapM_ go tys
-  where
-    go (Scaled mult ty) = checkNoLinearFFI mult >>
-                          check (pred ty) (TcRnIllegalForeignType (Just Arg))
-
-checkNoLinearFFI :: Mult -> TcM ()  -- No linear types in FFI (#18472)
-checkNoLinearFFI ManyTy = return ()
-checkNoLinearFFI _      = addErrTc $ TcRnIllegalForeignType (Just Arg)
-                                   LinearTypesNotAllowed
-
------------- Checking result types for foreign calls ----------------------
--- | Check that the type has the form
---    (IO t) or (t) , and that t satisfies the given predicate.
--- When calling this function, any newtype wrappers (should) have been
--- already dealt with by normaliseFfiType.
---
--- We also check that the Safe Haskell condition of FFI imports having
--- results in the IO monad holds.
---
-checkForeignRes :: Bool -> Bool -> (Type -> Validity' IllegalForeignTypeReason) -> Type -> TcM ()
-checkForeignRes non_io_result_ok check_safe pred_res_ty ty
-  | Just (_, res_ty) <- tcSplitIOType_maybe ty
-  =     -- Got an IO result type, that's always fine!
-     check (pred_res_ty res_ty)
-           (TcRnIllegalForeignType (Just Result))
-
-  -- We disallow nested foralls in foreign types
-  -- (at least, for the time being). See #16702.
-  | isForAllTy ty
-  = addErrTc $ TcRnIllegalForeignType (Just Result) UnexpectedNestedForall
-
-  -- Case for non-IO result type with FFI Import
-  | not non_io_result_ok
-  = addErrTc $ TcRnIllegalForeignType (Just Result) IOResultExpected
-
-  | otherwise
-  = do { dflags <- getDynFlags
-       ; case pred_res_ty ty of
-                -- Handle normal typecheck fail, we want to handle this first and
-                -- only report safe haskell errors if the normal type check is OK.
-           NotValid msg -> addErrTc $ TcRnIllegalForeignType (Just Result) msg
-
-           -- handle safe infer fail
-           _ | check_safe && safeInferOn dflags
-               -> recordUnsafeInfer emptyMessages
-
-           -- handle safe language typecheck fail
-           _ | check_safe && safeLanguageOn dflags
-               -> addErrTc (TcRnIllegalForeignType (Just Result) SafeHaskellMustBeInIO)
-
-           -- success! non-IO return is fine
-           _ -> return () }
-
-nonIOok, mustBeIO :: Bool
-nonIOok  = True
-mustBeIO = False
-
-checkSafe, noCheckSafe :: Bool
-checkSafe   = True
-noCheckSafe = False
-
-checkCg :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-        -> (Backend -> Validity' ExpectedBackends) -> TcM ()
-checkCg decl check = do
-    dflags <- getDynFlags
-    let bcknd = backend dflags
-    case check bcknd of
-      IsValid -> return ()
-      NotValid expectedBcknds ->
-        addErrTc $ TcRnIllegalForeignDeclBackend decl bcknd expectedBcknds
-
--- Calling conventions
-
-checkCConv :: Either (ForeignExport GhcRn) (ForeignImport GhcRn)
-           -> CCallConv -> TcM CCallConv
-checkCConv _ CCallConv    = return CCallConv
-checkCConv _ CApiConv     = return CApiConv
-checkCConv decl StdCallConv = do
-  dflags <- getDynFlags
-  let platform = targetPlatform dflags
-  if platformArch platform == ArchX86
-      then return StdCallConv
-      else do -- This is a warning, not an error. see #3336
-              let msg = TcRnUnsupportedCallConv decl StdCallConvUnsupported
-              addDiagnosticTc msg
-              return CCallConv
-checkCConv decl PrimCallConv = do
-  addErrTc $ TcRnUnsupportedCallConv decl PrimCallConvUnsupported
-  return PrimCallConv
-checkCConv decl JavaScriptCallConv = do
-  dflags <- getDynFlags
-  if platformArch (targetPlatform dflags) == ArchJavaScript
-      then return JavaScriptCallConv
-      else do
-        addErrTc $ TcRnUnsupportedCallConv decl JavaScriptCallConvUnsupported
-        return JavaScriptCallConv
-
--- Warnings
-
-check :: Validity' IllegalForeignTypeReason
-      -> (IllegalForeignTypeReason -> TcRnMessage)
-      -> TcM ()
-check IsValid _                   = return ()
-check (NotValid reason) mkMessage = addErrTc (mkMessage reason)
-
-foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc
-foreignDeclCtxt fo
-  = hang (text "When checking declaration:")
-       2 (ppr fo)
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ /dev/null
@@ -1,1505 +0,0 @@
-
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections       #-}
-{-# LANGUAGE TypeFamilies        #-}
-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-{-# LANGUAGE ViewPatterns        #-}
-{-# LANGUAGE DisambiguateRecordFields #-}
-
-{-
-%
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
--}
-
-module GHC.Tc.Gen.Head
-       ( HsExprArg(..), EValArg(..), TcPass(..)
-       , AppCtxt(..), appCtxtLoc, insideExpansion
-       , splitHsApps, rebuildHsApps
-       , addArgWrap, isHsValArg
-       , countLeadingValArgs, isVisibleArg, pprHsExprArgTc
-       , countVisAndInvisValArgs, countHsWrapperInvisArgs
-
-       , tcInferAppHead, tcInferAppHead_maybe
-       , tcInferId, tcCheckId
-       , obviousSig
-       , tyConOf, tyConOfET, lookupParents, fieldNotInType
-       , notSelector, nonBidirectionalErr
-
-       , addHeadCtxt, addExprCtxt, addFunResCtxt ) where
-
-import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )
-
-import GHC.Prelude
-import GHC.Hs
-
-import GHC.Tc.Gen.HsType
-import GHC.Rename.Unbound     ( unknownNameSuggestions, WhatLooking(..) )
-
-import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )
-import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig, lhsSigWcTypeContextSpan )
-import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc )
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Unify
-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
-import GHC.Tc.Utils.Instantiate
-import GHC.Tc.Instance.Family ( tcLookupDataFamInst )
-import GHC.Unit.Module        ( getModule )
-import GHC.Tc.Errors.Types
-import GHC.Tc.Solver          ( InferMode(..), simplifyInfer )
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.TcType as TcType
-import GHC.Tc.Types.Evidence
-import GHC.Hs.Syn.Type
-
-import GHC.Core.FamInstEnv    ( FamInstEnvs )
-import GHC.Core.UsageEnv      ( unitUE )
-import GHC.Core.PatSyn( PatSyn )
-import GHC.Core.ConLike( ConLike(..) )
-import GHC.Core.DataCon
-import GHC.Core.TyCon
-import GHC.Core.TyCo.Rep
-import GHC.Core.Type
-
-import GHC.Types.Var( isInvisibleFunArg )
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.Name
-import GHC.Types.Name.Reader
-import GHC.Types.SrcLoc
-import GHC.Types.Basic
-import GHC.Types.Error
-
-import GHC.Builtin.Types( multiplicityTy )
-import GHC.Builtin.Names
-import GHC.Builtin.Names.TH( liftStringName, liftName )
-
-import GHC.Driver.Env
-import GHC.Driver.Session
-import GHC.Utils.Misc
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-import GHC.Data.Maybe
-import Control.Monad
-
-
-
-{- *********************************************************************
-*                                                                      *
-              HsExprArg: auxiliary data type
-*                                                                      *
-********************************************************************* -}
-
-{- Note [HsExprArg]
-~~~~~~~~~~~~~~~~~~~
-The data type HsExprArg :: TcPass -> Type
-is a very local type, used only within this module and GHC.Tc.Gen.App
-
-* It's really a zipper for an application chain
-  See Note [Application chains and heads] in GHC.Tc.Gen.App for
-  what an "application chain" is.
-
-* It's a GHC-specific type, so using TTG only where necessary
-
-* It is indexed by TcPass, meaning
-  - HsExprArg TcpRn:
-      The result of splitHsApps, which decomposes a HsExpr GhcRn
-
-  - HsExprArg TcpInst:
-      The result of tcInstFun, which instantiates the function type
-      Adds EWrap nodes, the argument type in EValArg,
-      and the kind-checked type in ETypeArg
-
-  - HsExprArg TcpTc:
-      The result of tcArg, which typechecks the value args
-      In EValArg we now have a (LHsExpr GhcTc)
-
-* rebuildPrefixApps is dual to splitHsApps, and zips an application
-  back into a HsExpr
-
-Note [EValArg]
-~~~~~~~~~~~~~~
-The data type EValArg is the payload of the EValArg constructor of
-HsExprArg; i.e. a value argument of the application.  EValArg has two
-forms:
-
-* ValArg: payload is just the expression itself. Simple.
-
-* ValArgQL: captures the results of applying quickLookArg to the
-  argument in a ValArg.  When we later want to typecheck that argument
-  we can just carry on from where quick-look left off.  The fields of
-  ValArgQL exactly capture what is needed to complete the job.
-
-Invariants:
-
-1. With QL switched off, all arguments are ValArg; no ValArgQL
-
-2. With QL switched on, tcInstFun converts some ValArgs to ValArgQL,
-   under the conditions when quick-look should happen (eg the argument
-   type is guarded) -- see quickLookArg
-
-Note [splitHsApps]
-~~~~~~~~~~~~~~~~~~
-The key function
-  splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, HsExpr GhcRn, [HsExprArg 'TcpRn])
-takes apart either an HsApp, or an infix OpApp, returning
-
-* The "head" of the application, an expression that is often a variable;
-  this is used for typechecking
-
-* The "user head" or "error head" of the application, to be reported to the
-  user in case of an error.  Example:
-         (`op` e)
-  expands (via HsExpanded) to
-         (rightSection op e)
-  but we don't want to see 'rightSection' in error messages. So we keep the
-  innermost un-expanded head as the "error head".
-
-* A list of HsExprArg, the arguments
--}
-
-data TcPass = TcpRn     -- Arguments decomposed
-            | TcpInst   -- Function instantiated
-            | TcpTc     -- Typechecked
-
-data HsExprArg (p :: TcPass)
-  = -- See Note [HsExprArg]
-    EValArg  { eva_ctxt   :: AppCtxt
-             , eva_arg    :: EValArg p
-             , eva_arg_ty :: !(XEVAType p) }
-
-  | ETypeArg { eva_ctxt  :: AppCtxt
-             , eva_at    :: !(LHsToken "@" GhcRn)
-             , eva_hs_ty :: LHsWcType GhcRn  -- The type arg
-             , eva_ty    :: !(XETAType p) }  -- Kind-checked type arg
-
-  | EPrag    AppCtxt
-             (HsPragE (GhcPass (XPass p)))
-
-  | EWrap    EWrap
-
-data EWrap = EPar    AppCtxt
-           | EExpand (HsExpr GhcRn)
-           | EHsWrap HsWrapper
-
-data EValArg (p :: TcPass) where  -- See Note [EValArg]
-  ValArg   :: LHsExpr (GhcPass (XPass p))
-           -> EValArg p
-
-  ValArgQL :: { va_expr :: LHsExpr GhcRn        -- Original application
-                                                -- For location and error msgs
-              , va_fun  :: (HsExpr GhcTc, AppCtxt) -- Function of the application,
-                                                   -- typechecked, plus its context
-              , va_args :: [HsExprArg 'TcpInst] -- Args, instantiated
-              , va_ty   :: TcRhoType }          -- Result type
-           -> EValArg 'TcpInst  -- Only exists in TcpInst phase
-
-data AppCtxt
-  = VAExpansion
-       (HsExpr GhcRn)    -- Inside an expansion of this expression
-       SrcSpan           -- The SrcSpan of the expression
-                         --    noSrcSpan if outermost; see Note [AppCtxt]
-
-  | VACall
-       (HsExpr GhcRn) Int  -- In the third argument of function f
-       SrcSpan             -- The SrcSpan of the application (f e1 e2 e3)
-                         --    noSrcSpan if outermost; see Note [AppCtxt]
-
-{- Note [AppCtxt]
-~~~~~~~~~~~~~~~~~
-In a call (f e1 ... en), we pair up each argument with an AppCtxt. For
-example, the AppCtxt for e3 allows us to say
-    "In the third argument of `f`"
-See splitHsApps.
-
-To do this we must take a quick look into the expression to find the
-function at the head (`f` in this case) and how many arguments it
-has. That is what the funcion top_ctxt does.
-
-If the function part is an expansion, we don't want to look further.
-For example, with rebindable syntax the expression
-    (if e1 then e2 else e3) e4 e5
-might expand to
-    (ifThenElse e1 e2 e3) e4 e5
-For e4 we an AppCtxt that says "In the first argument of (if ...)",
-not "In the fourth argument of ifThenElse".  So top_ctxt stops
-at expansions.
-
-The SrcSpan in an AppCtxt describes the whole call.  We initialise
-it to noSrcSpan, because splitHsApps deals in HsExpr not LHsExpr, so
-we don't have a span for the whole call; and we use that noSrcSpan in
-GHC.Tc.Gen.App.tcInstFun (set_fun_ctxt) to avoid pushing "In the expression `f`"
-a second time.
--}
-
-appCtxtLoc :: AppCtxt -> SrcSpan
-appCtxtLoc (VAExpansion _ l) = l
-appCtxtLoc (VACall _ _ l)    = l
-
-insideExpansion :: AppCtxt -> Bool
-insideExpansion (VAExpansion {}) = True
-insideExpansion (VACall {})      = False
-
-instance Outputable AppCtxt where
-  ppr (VAExpansion e _) = text "VAExpansion" <+> ppr e
-  ppr (VACall f n _)    = text "VACall" <+> int n <+> ppr f
-
-type family XPass p where
-  XPass 'TcpRn   = 'Renamed
-  XPass 'TcpInst = 'Renamed
-  XPass 'TcpTc   = 'Typechecked
-
-type family XETAType p where  -- Type arguments
-  XETAType 'TcpRn = NoExtField
-  XETAType _      = Type
-
-type family XEVAType p where  -- Value arguments
-  XEVAType 'TcpRn = NoExtField
-  XEVAType _      = Scaled Type
-
-mkEValArg :: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn
-mkEValArg ctxt e = EValArg { eva_arg = ValArg e, eva_ctxt = ctxt
-                           , eva_arg_ty = noExtField }
-
-mkETypeArg :: AppCtxt -> LHsToken "@" GhcRn -> LHsWcType GhcRn -> HsExprArg 'TcpRn
-mkETypeArg ctxt at hs_ty =
-  ETypeArg { eva_ctxt = ctxt
-           , eva_at = at, eva_hs_ty = hs_ty
-           , eva_ty = noExtField }
-
-addArgWrap :: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
-addArgWrap wrap args
- | isIdHsWrapper wrap = args
- | otherwise          = EWrap (EHsWrap wrap) : args
-
-splitHsApps :: HsExpr GhcRn
-            -> ( (HsExpr GhcRn, AppCtxt)  -- Head
-               , [HsExprArg 'TcpRn])      -- Args
--- See Note [splitHsApps]
-splitHsApps e = go e (top_ctxt 0 e) []
-  where
-    top_ctxt :: Int -> HsExpr GhcRn -> AppCtxt
-    -- Always returns VACall fun n_val_args noSrcSpan
-    -- to initialise the argument splitting in 'go'
-    -- See Note [AppCtxt]
-    top_ctxt n (HsPar _ _ fun _)           = top_lctxt n fun
-    top_ctxt n (HsPragE _ _ fun)           = top_lctxt n fun
-    top_ctxt n (HsAppType _ fun _ _)         = top_lctxt (n+1) fun
-    top_ctxt n (HsApp _ fun _)             = top_lctxt (n+1) fun
-    top_ctxt n (XExpr (HsExpanded orig _)) = VACall orig      n noSrcSpan
-    top_ctxt n other_fun                   = VACall other_fun n noSrcSpan
-
-    top_lctxt n (L _ fun) = top_ctxt n fun
-
-    go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]
-       -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
-    -- Modify the AppCtxt as we walk inwards, so it describes the next argument
-    go (HsPar _ _ (L l fun) _)       ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt)     : args)
-    go (HsPragE _ p (L l fun))       ctxt args = go fun (set l ctxt) (EPrag      ctxt p     : args)
-    go (HsAppType _ (L l fun) at ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt at ty : args)
-    go (HsApp _ (L l fun) arg)       ctxt args = go fun (dec l ctxt) (mkEValArg  ctxt arg   : args)
-
-    -- See Note [Looking through HsExpanded]
-    go (XExpr (HsExpanded orig fun)) ctxt args
-      = go fun (VAExpansion orig (appCtxtLoc ctxt))
-               (EWrap (EExpand orig) : args)
-
-    -- See Note [Desugar OpApp in the typechecker]
-    go e@(OpApp _ arg1 (L l op) arg2) _ args
-      = ( (op, VACall op 0 (locA l))
-        ,   mkEValArg (VACall op 1 generatedSrcSpan) arg1
-          : mkEValArg (VACall op 2 generatedSrcSpan) arg2
-          : EWrap (EExpand e)
-          : args )
-
-    go e ctxt args = ((e,ctxt), args)
-
-    set :: SrcSpanAnnA -> AppCtxt -> AppCtxt
-    set l (VACall f n _)        = VACall f n (locA l)
-    set _ ctxt@(VAExpansion {}) = ctxt
-
-    dec :: SrcSpanAnnA -> AppCtxt -> AppCtxt
-    dec l (VACall f n _)        = VACall f (n-1) (locA l)
-    dec _ ctxt@(VAExpansion {}) = ctxt
-
--- | Rebuild an application: takes a type-checked application head
--- expression together with arguments in the form of typechecked 'HsExprArg's
--- and returns a typechecked application of the head to the arguments.
---
--- This performs a representation-polymorphism check to ensure that the
--- remaining value arguments in an application have a fixed RuntimeRep.
---
--- See Note [Checking for representation-polymorphic built-ins].
-rebuildHsApps :: HsExpr GhcTc
-                      -- ^ the function being applied
-              -> AppCtxt
-              -> [HsExprArg 'TcpTc]
-                      -- ^ the arguments to the function
-              -> TcRhoType
-                      -- ^ result type of the application
-              -> TcM (HsExpr GhcTc)
-rebuildHsApps fun ctxt args app_res_rho
-  = do { tcRemainingValArgs args app_res_rho fun
-       ; return $ rebuild_hs_apps fun ctxt args }
-
--- | The worker function for 'rebuildHsApps': simply rebuilds
--- an application chain in which arguments are specified as
--- typechecked 'HsExprArg's.
-rebuild_hs_apps :: HsExpr GhcTc
-                      -- ^ the function being applied
-              -> AppCtxt
-              -> [HsExprArg 'TcpTc]
-                      -- ^ the arguments to the function
-              -> HsExpr GhcTc
-rebuild_hs_apps fun _ [] = fun
-rebuild_hs_apps fun ctxt (arg : args)
-  = case arg of
-      EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' }
-        -> rebuild_hs_apps (HsApp noAnn lfun arg) ctxt' args
-      ETypeArg { eva_hs_ty = hs_ty, eva_at = at, eva_ty = ty, eva_ctxt = ctxt' }
-        -> rebuild_hs_apps (HsAppType ty lfun at hs_ty) ctxt' args
-      EPrag ctxt' p
-        -> rebuild_hs_apps (HsPragE noExtField p lfun) ctxt' args
-      EWrap (EPar ctxt')
-        -> rebuild_hs_apps (gHsPar lfun) ctxt' args
-      EWrap (EExpand orig)
-        -> rebuild_hs_apps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args
-      EWrap (EHsWrap wrap)
-        -> rebuild_hs_apps (mkHsWrap wrap fun) ctxt args
-  where
-    lfun = L (noAnnSrcSpan $ appCtxtLoc ctxt) fun
-
-{- Note [Checking for representation-polymorphic built-ins]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We cannot have representation-polymorphic or levity-polymorphic
-function arguments. See Note [Representation polymorphism invariants]
-in GHC.Core.  That is checked by the calls to `hasFixedRuntimeRep` in
-`tcEValArg`.
-
-But some /built-in/ functions have representation-polymorphic argument
-types. Users can't define such Ids; they are all GHC built-ins or data
-constructors.  Specifically they are:
-
-1. A few wired-in Ids such as coerce and unsafeCoerce#,
-2. Primops, such as raise#.
-3. Newtype constructors with `UnliftedNewtypes` which have
-   a representation-polymorphic argument.
-4. Representation-polymorphic data constructors: unboxed tuples
-   and unboxed sums.
-
-For (1) consider
-  badId :: forall r (a :: TYPE r). a -> a
-  badId = unsafeCoerce# @r @r @a @a
-
-The wired-in function
-  unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
-                   (a :: TYPE r1) (b :: TYPE r2).
-                   a -> b
-has a convenient but representation-polymorphic type. It has no
-binding; instead it has a compulsory unfolding, after which we
-would have
-  badId = /\r /\(a :: TYPE r). \(x::a). ...body of unsafeCorece#...
-And this is no good because of that rep-poly \(x::a).  So we want
-to reject this.
-
-On the other hand
-  goodId :: forall (a :: Type). a -> a
-  goodId = unsafeCoerce# @LiftedRep @LiftedRep @a @a
-
-is absolutely fine, because after we inline the unfolding, the \(x::a)
-is representation-monomorphic.
-
-Test cases: T14561, RepPolyWrappedVar2.
-
-For primops (2) the situation is similar; they are eta-expanded in
-CorePrep to be saturated, and that eta-expansion must not add a
-representation-polymorphic lambda.
-
-Test cases: T14561b, RepPolyWrappedVar, UnliftedNewtypesCoerceFail.
-
-For (3), consider a representation-polymorphic newtype with
-UnliftedNewtypes:
-
-  type Id :: forall r. TYPE r -> TYPE r
-  newtype Id a where { MkId :: a }
-
-  bad :: forall r (a :: TYPE r). a -> Id a
-  bad = MkId @r @a             -- Want to reject
-
-  good :: forall (a :: Type). a -> Id a
-  good = MkId @LiftedRep @a   -- Want to accept
-
-Test cases: T18481, UnliftedNewtypesLevityBinder
-
-So these cases need special treatment. We add a special case
-in tcApp to check whether an application of an Id has any remaining
-representation-polymorphic arguments, after instantiation and application
-of previous arguments.  This is achieved by the tcRemainingValArgs
-function, which computes the types of the remaining value arguments, and checks
-that each of these have a fixed runtime representation.
-
-Note that this function also ensures that data constructors always
-appear saturated, by performing eta-expansion if necessary.
-See Note [Typechecking data constructors].
-
-Wrinkle [Arity]
-
-  We don't want to check for arguments past the arity of the function.
-
-  For example
-
-      raise# :: forall {r :: RuntimeRep} (a :: Type) (b :: TYPE r). a -> b
-
-  has arity 1, so an instantiation such as:
-
-      foo :: forall w r (z :: TYPE r). w -> z -> z
-      foo = raise# @w @(z -> z)
-
-  is unproblematic.  This means we must take care not to perform a
-  representation-polymorphism check on `z`.
-
-  To achieve this, we consult the arity of the 'Id' which is the head
-  of the application (or just use 1 for a newtype constructor),
-  and keep track of how many value-level arguments we have seen,
-  to ensure we stop checking once we reach the arity.
-  This is slightly complicated by the need to include both visible
-  and invisible arguments, as the arity counts both:
-  see GHC.Tc.Gen.Head.countVisAndInvisValArgs.
-
-  Test cases: T20330{a,b}
-
-Wrinkle [Syntactic check]
-
-  We only perform a syntactic check in tcRemainingValArgs. That is,
-  we will reject partial applications such as:
-
-    type RR :: RuntimeREp
-    type family RR where { RR = IntRep }
-    type T :: TYPE RR
-    type family T where { T = Int# }
-
-    (# , #) @LiftedRep @RR e1
-
-  Why do we reject? Wee would need to elaborate this partial application
-  of (# , #) as follows:
-
-    let x1 = e1
-    in
-      ( \ @(ty2 :: TYPE RR) (x2 :: ty2 |> TYPE RR[0])
-      -> ( ( (# , #) @LiftedRep @RR @Char @ty2 x1 ) |> co1 )
-           x2
-      ) |> co2
-
-  That is, we need to cast the partial application
-
-    (# , #) @LiftedRep @RR @Char @ty2 x1
-
-  so that the next argument we provide to it has a fixed RuntimeRep,
-  and then eta-expand it. This is quite tricky, and other parts
-  of the compiler aren't set up to handle this mix of applications
-  and casts (e.g. checkCanEtaExpand in GHC.Core.Lint).
-
-  So we refrain from doing so, and instead limit ourselves to a simple syntactic
-  check. See the wiki page https://gitlab.haskell.org/ghc/ghc/-/wikis/Remaining-ValArgs
-  for a more in-depth discussion.
--}
-
--- | Typecheck the remaining value arguments in a partial application,
--- ensuring they have a fixed RuntimeRep in the sense of Note [Fixed RuntimeRep]
--- in GHC.Tc.Utils.Concrete.
---
--- Example:
---
--- > repPolyId :: forall r (a :: TYPE r). a -> a
--- > repPolyId = coerce
---
--- This is an invalid instantiation of 'coerce', as we can't eta expand it
--- to
---
--- > \@r \@(a :: TYPE r) (x :: a) -> coerce @r @a @a x
---
--- because the binder `x` does not have a fixed runtime representation.
-tcRemainingValArgs :: HasDebugCallStack
-                   => [HsExprArg 'TcpTc]
-                   -> TcRhoType
-                   -> HsExpr GhcTc
-                   -> TcM ()
-tcRemainingValArgs applied_args app_res_rho fun = case fun of
-
-  HsVar _ (L _ fun_id)
-
-    -- (1): unsafeCoerce#
-    -- 'unsafeCoerce#' is peculiar: it is patched in manually as per
-    -- Note [Wiring in unsafeCoerce#] in GHC.HsToCore.
-    -- Unfortunately, even though its arity is set to 1 in GHC.HsToCore.mkUnsafeCoercePrimPair,
-    -- at this stage, if we query idArity, we get 0. This is because
-    -- we end up looking at the non-patched version of unsafeCoerce#
-    -- defined in Unsafe.Coerce, and that one indeed has arity 0.
-    --
-    -- We thus manually specify the correct arity of 1 here.
-    | idName fun_id == unsafeCoercePrimName
-    -> tc_remaining_args 1 (RepPolyWiredIn fun_id)
-
-    -- (2): primops and other wired-in representation-polymorphic functions,
-    -- such as 'rightSection', 'oneShot', etc; see bindings with Compulsory unfoldings
-    -- in GHC.Types.Id.Make
-    | isWiredInName (idName fun_id) && hasNoBinding fun_id
-    -> tc_remaining_args (idArity fun_id) (RepPolyWiredIn fun_id)
-       -- NB: idArity consults the IdInfo of the Id. This can be a problem
-       -- in the presence of hs-boot files, as we might not have finished
-       -- typechecking; inspecting the IdInfo at this point can cause
-       -- strange Core Lint errors (see #20447).
-       -- We avoid this entirely by only checking wired-in names,
-       -- as those are the only ones this check is applicable to anyway.
-
-  XExpr (ConLikeTc (RealDataCon con) _ _)
-    -- (3): Representation-polymorphic newtype constructors.
-    | isNewDataCon con
-    -- (4): Unboxed tuples and unboxed sums
-    || isUnboxedTupleDataCon con
-    || isUnboxedSumDataCon con
-    -> tc_remaining_args (dc_val_arity con) (RepPolyDataCon con)
-
-  _ -> return ()
-
-  where
-
-    dc_val_arity :: DataCon -> Arity
-    dc_val_arity con = count (not . isEqPrimPred) (dataConTheta con)
-                     + length (dataConStupidTheta con)
-                     + dataConSourceArity con
-      -- Count how many value-level arguments this data constructor expects:
-      --    - dictionary arguments from the context (including the stupid context),
-      --    - source value arguments.
-      -- Tests: EtaExpandDataCon, EtaExpandStupid{1,2}.
-
-    nb_applied_vis_val_args :: Int
-    nb_applied_vis_val_args = count isHsValArg applied_args
-
-    nb_applied_val_args :: Int
-    nb_applied_val_args = countVisAndInvisValArgs applied_args
-
-    tc_remaining_args :: Arity -> RepPolyFun -> TcM ()
-    tc_remaining_args arity rep_poly_fun =
-      tc_rem_args
-        (nb_applied_vis_val_args + 1)
-        (nb_applied_val_args + 1)
-        rem_arg_tys
-
-      where
-
-      rem_arg_tys :: [(Scaled Type, FunTyFlag)]
-      rem_arg_tys = getRuntimeArgTys app_res_rho
-        -- We do not need to zonk app_res_rho first, because the number of arrows
-        -- in the (possibly instantiated) inferred type of the function will
-        -- be at least the arity of the function.
-
-      -- The following function is essentially "mapM hasFixedRuntimeRep rem_arg_tys",
-      -- but we need to keep track of indices for error messages, hence the manual recursion.
-      tc_rem_args :: Int
-                     -- visible value argument index, starting from 1
-                     -- (only used to report the argument position in error messages)
-                  -> Int
-                     -- value argument index, starting from 1
-                     -- used to count up to the arity to ensure that
-                     -- we don't check too many argument types
-                  -> [(Scaled Type, FunTyFlag)]
-                     -- run-time argument types
-                  -> TcM ()
-      tc_rem_args _ i_val _
-        | i_val > arity
-        = return ()
-      tc_rem_args _ _ []
-        -- Should never happen: it would mean that the arity is higher
-        -- than the number of arguments apparent from the type.
-        = pprPanic "tcRemainingValArgs" debug_msg
-      tc_rem_args i_visval !i_val ((Scaled _ arg_ty, af) : tys)
-        = do { let (i_visval', arg_pos)
-                     | isInvisibleFunArg af = ( i_visval    , ArgPosInvis )
-                     | otherwise            = ( i_visval + 1, ArgPosVis i_visval )
-                   frr_ctxt = FRRNoBindingResArg rep_poly_fun arg_pos
-             ; hasFixedRuntimeRep_syntactic frr_ctxt arg_ty
-                 -- Why is this a syntactic check? See Wrinkle [Syntactic check] in
-                 -- Note [Checking for representation-polymorphic built-ins].
-             ; tc_rem_args i_visval' (i_val + 1) tys }
-
-      debug_msg :: SDoc
-      debug_msg =
-        vcat
-          [ text "app_head =" <+> ppr fun
-          , text "arity =" <+> ppr arity
-          , text "applied_args =" <+> ppr applied_args
-          , text "nb_applied_val_args =" <+> ppr nb_applied_val_args ]
-
-
-isHsValArg :: HsExprArg id -> Bool
-isHsValArg (EValArg {}) = True
-isHsValArg _            = False
-
-countLeadingValArgs :: [HsExprArg id] -> Int
-countLeadingValArgs []                   = 0
-countLeadingValArgs (EValArg {}  : args) = 1 + countLeadingValArgs args
-countLeadingValArgs (EWrap {}    : args) = countLeadingValArgs args
-countLeadingValArgs (EPrag {}    : args) = countLeadingValArgs args
-countLeadingValArgs (ETypeArg {} : _)    = 0
-
-isValArg :: HsExprArg id -> Bool
-isValArg (EValArg {}) = True
-isValArg _            = False
-
-isVisibleArg :: HsExprArg id -> Bool
-isVisibleArg (EValArg {})  = True
-isVisibleArg (ETypeArg {}) = True
-isVisibleArg _             = False
-
--- | Count visible and invisible value arguments in a list
--- of 'HsExprArg' arguments.
-countVisAndInvisValArgs :: [HsExprArg id] -> Arity
-countVisAndInvisValArgs []                  = 0
-countVisAndInvisValArgs (EValArg {} : args) = 1 + countVisAndInvisValArgs args
-countVisAndInvisValArgs (EWrap wrap : args) =
-  case wrap of { EHsWrap hsWrap            -> countHsWrapperInvisArgs hsWrap + countVisAndInvisValArgs args
-               ; EPar   {}                 -> countVisAndInvisValArgs args
-               ; EExpand {}                -> countVisAndInvisValArgs args }
-countVisAndInvisValArgs (EPrag {}   : args) = countVisAndInvisValArgs args
-countVisAndInvisValArgs (ETypeArg {}: args) = countVisAndInvisValArgs args
-
--- | Counts the number of invisible term-level arguments applied by an 'HsWrapper'.
--- Precondition: this wrapper contains no abstractions.
-countHsWrapperInvisArgs :: HsWrapper -> Arity
-countHsWrapperInvisArgs = go
-  where
-    go WpHole = 0
-    go (WpCompose wrap1 wrap2) = go wrap1 + go wrap2
-    go fun@(WpFun {}) = nope fun
-    go (WpCast {}) = 0
-    go evLam@(WpEvLam {}) = nope evLam
-    go (WpEvApp _) = 1
-    go tyLam@(WpTyLam {}) = nope tyLam
-    go (WpTyApp _) = 0
-    go (WpLet _) = 0
-    go (WpMultCoercion {}) = 0
-
-    nope x = pprPanic "countHsWrapperInvisApps" (ppr x)
-
-instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where
-  ppr (EValArg { eva_arg = arg })      = text "EValArg" <+> ppr arg
-  ppr (EPrag _ p)                      = text "EPrag" <+> ppr p
-  ppr (ETypeArg { eva_hs_ty = hs_ty }) = char '@' <> ppr hs_ty
-  ppr (EWrap wrap)                     = ppr wrap
-
-instance Outputable EWrap where
-  ppr (EPar _)       = text "EPar"
-  ppr (EHsWrap w)    = text "EHsWrap" <+> ppr w
-  ppr (EExpand orig) = text "EExpand" <+> ppr orig
-
-instance OutputableBndrId (XPass p) => Outputable (EValArg p) where
-  ppr (ValArg e) = ppr e
-  ppr (ValArgQL { va_fun = fun, va_args = args, va_ty = ty})
-    = hang (text "ValArgQL" <+> ppr fun)
-         2 (vcat [ ppr args, text "va_ty:" <+> ppr ty ])
-
-pprHsExprArgTc :: HsExprArg 'TcpInst -> SDoc
-pprHsExprArgTc (EValArg { eva_arg = tm, eva_arg_ty = ty })
-  = text "EValArg" <+> hang (ppr tm) 2 (dcolon <+> ppr ty)
-pprHsExprArgTc arg = ppr arg
-
-{- Note [Desugar OpApp in the typechecker]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Operator sections are desugared in the renamer; see GHC.Rename.Expr
-Note [Handling overloaded and rebindable constructs].
-But for reasons explained there, we rename OpApp to OpApp.  Then,
-here in the typechecker, we desugar it to a use of HsExpanded.
-That makes it possible to typecheck something like
-     e1 `f` e2
-where
-   f :: forall a. t1 -> forall b. t2 -> t3
-
-Note [Looking through HsExpanded]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When creating an application chain in splitHsApps, we must deal with
-     HsExpanded f1 (f `HsApp` e1) `HsApp` e2 `HsApp` e3
-
-as a single application chain `f e1 e2 e3`.  Otherwise stuff like overloaded
-labels (#19154) won't work.
-
-It's easy to achieve this: `splitHsApps` unwraps `HsExpanded`.
--}
-
-{- *********************************************************************
-*                                                                      *
-                 tcInferAppHead
-*                                                                      *
-********************************************************************* -}
-
-tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
-               -> [HsExprArg 'TcpRn]
-               -> TcM (HsExpr GhcTc, TcSigmaType)
--- Infer type of the head of an application
---   i.e. the 'f' in (f e1 ... en)
--- See Note [Application chains and heads] in GHC.Tc.Gen.App
--- We get back a /SigmaType/ because we have special cases for
---   * A bare identifier (just look it up)
---     This case also covers a record selector HsRecSel
---   * An expression with a type signature (e :: ty)
--- See Note [Application chains and heads] in GHC.Tc.Gen.App
---
--- Why do we need the arguments to infer the type of the head of the
--- application? Simply to inform add_head_ctxt about whether or not
--- to put push a new "In the expression..." context. (We don't push a
--- new one if there are no arguments, because we already have.)
---
--- Note that [] and (,,) are both HsVar:
---   see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr
---
--- NB: 'e' cannot be HsApp, HsTyApp, HsPrag, HsPar, because those
---     cases are dealt with by splitHsApps.
---
--- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App
-tcInferAppHead (fun,ctxt) args
-  = addHeadCtxt ctxt $
-    do { mb_tc_fun <- tcInferAppHead_maybe fun args
-       ; case mb_tc_fun of
-            Just (fun', fun_sigma) -> return (fun', fun_sigma)
-            Nothing -> tcInfer (tcExpr fun) }
-
-tcInferAppHead_maybe :: HsExpr GhcRn
-                     -> [HsExprArg 'TcpRn]
-                     -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
--- See Note [Application chains and heads] in GHC.Tc.Gen.App
--- Returns Nothing for a complicated head
-tcInferAppHead_maybe fun args
-  = case fun of
-      HsVar _ (L _ nm)          -> Just <$> tcInferId nm
-      HsRecSel _ f              -> Just <$> tcInferRecSelId f
-      ExprWithTySig _ e hs_ty   -> Just <$> tcExprWithSig e hs_ty
-      HsOverLit _ lit           -> Just <$> tcInferOverLit lit
-      HsUntypedSplice (HsUntypedSpliceTop _ e) _
-                                -> tcInferAppHead_maybe e args
-      _                         -> return Nothing
-
-addHeadCtxt :: AppCtxt -> TcM a -> TcM a
-addHeadCtxt fun_ctxt thing_inside
-  | not (isGoodSrcSpan fun_loc)   -- noSrcSpan => no arguments
-  = thing_inside                  -- => context is already set
-  | otherwise
-  = setSrcSpan fun_loc $
-    case fun_ctxt of
-      VAExpansion orig _ -> addExprCtxt orig thing_inside
-      VACall {}          -> thing_inside
-  where
-    fun_loc = appCtxtLoc fun_ctxt
-
-{- *********************************************************************
-*                                                                      *
-                 Record selectors
-*                                                                      *
-********************************************************************* -}
-
-tcInferRecSelId :: FieldOcc GhcRn
-                -> TcM (HsExpr GhcTc, TcSigmaType)
-tcInferRecSelId (FieldOcc sel_name lbl)
-   = do { sel_id <- tc_rec_sel_id
-        ; let expr = HsRecSel noExtField (FieldOcc sel_id lbl)
-        ; return (expr, idType sel_id)
-        }
-     where
-       occ :: OccName
-       occ = rdrNameOcc (unLoc lbl)
-
-       tc_rec_sel_id :: TcM TcId
-       -- Like tc_infer_id, but returns an Id not a HsExpr,
-       -- so we can wrap it back up into a HsRecSel
-       tc_rec_sel_id
-         = do { thing <- tcLookup sel_name
-              ; case thing of
-                    ATcId { tct_id = id }
-                      -> do { check_naughty occ id  -- See Note [Local record selectors]
-                            ; check_local_id id
-                            ; return id }
-
-                    AGlobal (AnId id)
-                      -> do { check_naughty occ id
-                            ; return id }
-                           -- A global cannot possibly be ill-staged
-                           -- nor does it need the 'lifting' treatment
-                           -- hence no checkTh stuff here
-
-                    _ -> failWithTc $ TcRnExpectedValueId thing }
-
-------------------------
-
--- A type signature on the argument of an ambiguous record selector or
--- the record expression in an update must be "obvious", i.e. the
--- outermost constructor ignoring parentheses.
-obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
-obviousSig (ExprWithTySig _ _ ty) = Just ty
-obviousSig (HsPar _ _ p _)        = obviousSig (unLoc p)
-obviousSig (HsPragE _ _ p)        = obviousSig (unLoc p)
-obviousSig _                      = Nothing
-
--- Extract the outermost TyCon of a type, if there is one; for
--- data families this is the representation tycon (because that's
--- where the fields live).
-tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
-tyConOf fam_inst_envs ty0
-  = case tcSplitTyConApp_maybe ty of
-      Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
-      Nothing        -> Nothing
-  where
-    (_, _, ty) = tcSplitSigmaTy ty0
-
--- Variant of tyConOf that works for ExpTypes
-tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
-tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0
-
-
--- For an ambiguous record field, find all the candidate record
--- selectors (as GlobalRdrElts) and their parents.
-lookupParents :: Bool -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
-lookupParents is_selector rdr
-  = do { env <- getGlobalRdrEnv
-        -- Filter by isRecFldGRE because otherwise a non-selector variable with
-        -- an overlapping name can get through when NoFieldSelectors is enabled.
-        -- See Note [NoFieldSelectors] in GHC.Rename.Env.
-       ; let all_gres = lookupGRE_RdrName' rdr env
-       ; let gres | is_selector = filter isFieldSelectorGRE all_gres
-                  | otherwise   = filter isRecFldGRE all_gres
-       ; mapM lookupParent gres }
-  where
-    lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
-    lookupParent gre = do { id <- tcLookupId (greMangledName gre)
-                          ; case recordSelectorTyCon_maybe id of
-                              Just rstc -> return (rstc, gre)
-                              Nothing -> failWithTc (notSelector (greMangledName gre)) }
-
-
-fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage
-fieldNotInType p rdr
-  = mkTcRnNotInScope rdr $
-    UnknownSubordinate (text "field of type" <+> quotes (ppr p))
-
-notSelector :: Name -> TcRnMessage
-notSelector = TcRnNotARecordSelector
-
-
-{- *********************************************************************
-*                                                                      *
-                Expressions with a type signature
-                        expr :: type
-*                                                                      *
-********************************************************************* -}
-
-tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn)
-              -> TcM (HsExpr GhcTc, TcSigmaType)
-tcExprWithSig expr hs_ty
-  = do { sig_info <- checkNoErrs $  -- Avoid error cascade
-                     tcUserTypeSig loc hs_ty Nothing
-       ; (expr', poly_ty) <- tcExprSig ctxt expr sig_info
-       ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) }
-  where
-    loc = getLocA (dropWildCards hs_ty)
-    ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty)
-
-tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)
-tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })
-  = setSrcSpan loc $   -- Sets the location for the implication constraint
-    do { let poly_ty = idType poly_id
-       ; (wrap, expr') <- tcSkolemiseScoped ctxt poly_ty $ \rho_ty ->
-                          tcCheckMonoExprNC expr rho_ty
-       ; return (mkLHsWrap wrap expr', poly_ty) }
-
-tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc })
-  = setSrcSpan loc $   -- Sets the location for the implication constraint
-    do { (tclvl, wanted, (expr', sig_inst))
-             <- pushLevelAndCaptureConstraints  $
-                do { sig_inst <- tcInstSig sig
-                   ; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $
-                              tcExtendNameTyVarEnv (sig_inst_wcs   sig_inst) $
-                              tcCheckPolyExprNC expr (sig_inst_tau sig_inst)
-                   ; return (expr', sig_inst) }
-       -- See Note [Partial expression signatures]
-       ; let tau = sig_inst_tau sig_inst
-             infer_mode | null (sig_inst_theta sig_inst)
-                        , isNothing (sig_inst_wcx sig_inst)
-                        = ApplyMR
-                        | otherwise
-                        = NoRestrictions
-       ; ((qtvs, givens, ev_binds, _), residual)
-           <- captureConstraints $ simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted
-       ; emitConstraints residual
-
-       ; tau <- zonkTcType tau
-       ; let inferred_theta = map evVarPred givens
-             tau_tvs        = tyCoVarsOfType tau
-       ; (binders, my_theta) <- chooseInferredQuantifiers residual inferred_theta
-                                   tau_tvs qtvs (Just sig_inst)
-       ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau
-             my_sigma       = mkInvisForAllTys binders (mkPhiTy  my_theta tau)
-       ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis.
-                 then return idHsWrapper  -- Fast path; also avoids complaint when we infer
-                                          -- an ambiguous type and have AllowAmbiguousType
-                                          -- e..g infer  x :: forall a. F a -> Int
-                 else tcSubTypeSigma ExprSigOrigin (ExprSigCtxt NoRRC) inferred_sigma my_sigma
-
-       ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)
-       ; let poly_wrap = wrap
-                         <.> mkWpTyLams qtvs
-                         <.> mkWpEvLams givens
-                         <.> mkWpLet  ev_binds
-       ; return (mkLHsWrap poly_wrap expr', my_sigma) }
-
-
-{- Note [Partial expression signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Partial type signatures on expressions are easy to get wrong.  But
-here is a guiding principle
-    e :: ty
-should behave like
-    let x :: ty
-        x = e
-    in x
-
-So for partial signatures we apply the MR if no context is given.  So
-   e :: IO _          apply the MR
-   e :: _ => IO _     do not apply the MR
-just like in GHC.Tc.Gen.Bind.decideGeneralisationPlan
-
-This makes a difference (#11670):
-   peek :: Ptr a -> IO CLong
-   peek ptr = peekElemOff undefined 0 :: _
-from (peekElemOff undefined 0) we get
-          type: IO w
-   constraints: Storable w
-
-We must NOT try to generalise over 'w' because the signature specifies
-no constraints so we'll complain about not being able to solve
-Storable w.  Instead, don't generalise; then _ gets instantiated to
-CLong, as it should.
--}
-
-
-{- *********************************************************************
-*                                                                      *
-                 Overloaded literals
-*                                                                      *
-********************************************************************* -}
-
-tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
-tcInferOverLit lit@(OverLit { ol_val = val
-                            , ol_ext = OverLitRn { ol_rebindable = rebindable
-                                                 , ol_from_fun = L loc from_name } })
-  = -- Desugar "3" to (fromInteger (3 :: Integer))
-    --   where fromInteger is gotten by looking up from_name, and
-    --   the (3 :: Integer) is returned by mkOverLit
-    -- Ditto the string literal "foo" to (fromString ("foo" :: String))
-    do { hs_lit <- mkOverLit val
-       ; from_id <- tcLookupId from_name
-       ; (wrap1, from_ty) <- topInstantiate (LiteralOrigin lit) (idType from_id)
-       ; let
-           thing    = NameThing from_name
-           mb_thing = Just thing
-           herald   = ExpectedFunTyArg thing (HsLit noAnn hs_lit)
-       ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_thing
-                                                           (1, []) from_ty
-
-       ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty)
-       ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $
-                        HsLit noAnn hs_lit
-             from_expr = mkHsWrap (wrap2 <.> wrap1) $
-                         HsVar noExtField (L loc from_id)
-             witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr
-             lit' = lit { ol_ext = OverLitTc { ol_rebindable = rebindable
-                                             , ol_witness = witness
-                                             , ol_type = res_ty } }
-       ; return (HsOverLit noAnn lit', res_ty) }
-
-{- *********************************************************************
-*                                                                      *
-                 tcInferId, tcCheckId
-*                                                                      *
-********************************************************************* -}
-
-tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
-tcCheckId name res_ty
-  = do { (expr, actual_res_ty) <- tcInferId name
-       ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
-       ; addFunResCtxt rn_fun [] actual_res_ty res_ty $
-         tcWrapResultO (OccurrenceOf name) rn_fun expr actual_res_ty res_ty }
-  where
-    rn_fun = HsVar noExtField (noLocA name)
-
-------------------------
-tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
--- Look up an occurrence of an Id
--- Do not instantiate its type
-tcInferId id_name
-  | id_name `hasKey` assertIdKey
-  = do { dflags <- getDynFlags
-       ; if gopt Opt_IgnoreAsserts dflags
-         then tc_infer_id id_name
-         else tc_infer_assert id_name }
-
-  | otherwise
-  = do { (expr, ty) <- tc_infer_id id_name
-       ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)
-       ; return (expr, ty) }
-
-tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
--- Deal with an occurrence of 'assert'
--- See Note [Adding the implicit parameter to 'assert']
-tc_infer_assert assert_name
-  = do { assert_error_id <- tcLookupId assertErrorName
-       ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
-                                          (idType assert_error_id)
-       ; return (mkHsWrap wrap (HsVar noExtField (noLocA assert_error_id)), id_rho)
-       }
-
-tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
-tc_infer_id id_name
- = do { thing <- tcLookup id_name
-      ; case thing of
-             ATcId { tct_id = id }
-               -> do { check_local_id id
-                     ; return_id id }
-
-             AGlobal (AnId id) -> return_id id
-               -- A global cannot possibly be ill-staged
-               -- nor does it need the 'lifting' treatment
-               -- Hence no checkTh stuff here
-
-             AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con
-             AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps
-             (tcTyThingTyCon_maybe -> Just tc) -> fail_tycon tc -- TyCon or TcTyCon
-             ATyVar name _ -> fail_tyvar name
-
-             _ -> failWithTc $ TcRnExpectedValueId thing }
-  where
-    fail_tycon tc = do
-      gre <- getGlobalRdrEnv
-      let nm = tyConName tc
-          pprov = case lookupGRE_Name gre nm of
-                      Just gre -> nest 2 (pprNameProvenance gre)
-                      Nothing  -> empty
-      fail_with_msg dataName nm pprov
-
-    fail_tyvar nm =
-      let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))
-      in fail_with_msg varName nm pprov
-
-    fail_with_msg whatName nm pprov = do
-      (import_errs, hints) <- get_suggestions whatName
-      unit_state <- hsc_units <$> getTopEnv
-      let
-        -- TODO: unfortunate to have to convert to SDoc here.
-        -- This should go away once we refactor ErrInfo.
-        hint_msg = vcat $ map ppr hints
-        import_err_msg = vcat $ map ppr import_errs
-        info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg }
-      failWithTc $ TcRnMessageWithInfo unit_state (
-              mkDetailedMessage info (TcRnIncorrectNameSpace nm False))
-
-    get_suggestions ns = do
-       let occ = mkOccNameFS ns (occNameFS (occName id_name))
-       dflags  <- getDynFlags
-       rdr_env <- getGlobalRdrEnv
-       lcl_env <- getLocalRdrEnv
-       imp_info <- getImports
-       curr_mod <- getModule
-       hpt <- getHpt
-       return $ unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env
-         lcl_env imp_info (mkRdrUnqual occ)
-
-    return_id id = return (HsVar noExtField (noLocA id), idType id)
-
-check_local_id :: Id -> TcM ()
-check_local_id id
-  = do { checkThLocalId id
-       ; tcEmitBindingUsage $ unitUE (idName id) OneTy }
-
-check_naughty :: OccName -> TcId -> TcM ()
-check_naughty lbl id
-  | isNaughtyRecordSelector id = failWithTc (TcRnRecSelectorEscapedTyVar lbl)
-  | otherwise                  = return ()
-
-tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
--- See Note [Typechecking data constructors]
-tcInferDataCon con
-  = do { let tvbs  = dataConUserTyVarBinders con
-             tvs   = binderVars tvbs
-             theta = dataConOtherTheta con
-             args  = dataConOrigArgTys con
-             res   = dataConOrigResTy con
-             stupid_theta = dataConStupidTheta con
-
-       ; scaled_arg_tys <- mapM linear_to_poly args
-
-       ; let full_theta  = stupid_theta ++ theta
-             all_arg_tys = map unrestricted full_theta ++ scaled_arg_tys
-                -- We are building the type of the data con wrapper, so the
-                -- type must precisely match the construction in
-                -- GHC.Core.DataCon.dataConWrapperType.
-                -- See Note [Instantiating stupid theta]
-                -- in GHC.Core.DataCon.
-
-       ; return ( XExpr (ConLikeTc (RealDataCon con) tvs all_arg_tys)
-                , mkInvisForAllTys tvbs $ mkPhiTy full_theta $
-                  mkScaledFunTys scaled_arg_tys res ) }
-  where
-    linear_to_poly :: Scaled Type -> TcM (Scaled Type)
-    -- linear_to_poly implements point (3,4)
-    -- of Note [Typechecking data constructors]
-    linear_to_poly (Scaled OneTy ty) = do { mul_var <- newFlexiTyVarTy multiplicityTy
-                                          ; return (Scaled mul_var ty) }
-    linear_to_poly scaled_ty         = return scaled_ty
-
-tcInferPatSyn :: Name -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)
-tcInferPatSyn id_name ps
-  = case patSynBuilderOcc ps of
-       Just (expr,ty) -> return (expr,ty)
-       Nothing        -> failWithTc (nonBidirectionalErr id_name)
-
-nonBidirectionalErr :: Name -> TcRnMessage
-nonBidirectionalErr = TcRnPatSynNotBidirectional
-
-{- Note [Adding the implicit parameter to 'assert']
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The typechecker transforms (assert e1 e2) to (assertError e1 e2).
-This isn't really the Right Thing because there's no way to "undo"
-if you want to see the original source code in the typechecker
-output.  We'll have fix this in due course, when we care more about
-being able to reconstruct the exact original program.
-
-Note [Typechecking data constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As per Note [Polymorphisation of linear fields] in
-GHC.Core.Multiplicity, linear fields of data constructors get a
-polymorphic multiplicity when the data constructor is used as a term:
-
-    Just :: forall {p} a. a %p -> Maybe a
-
-So at an occurrence of a data constructor we do the following:
-
-1. Typechecking, in tcInferDataCon.
-
-  a. Get the original type of the constructor, say
-     K :: forall (r :: RuntimeRep) (a :: TYPE r). a %1 -> T r a
-     Note the %1: it is linear
-
-  b. We are going to return a ConLikeTc, thus:
-     XExpr (ConLikeTc K [r,a] [Scaled p a])
-      :: forall (r :: RuntimeRep) (a :: TYPE r). a %p -> T r a
-   where 'p' is a fresh multiplicity unification variable.
-
-   To get the returned ConLikeTc, we allocate a fresh multiplicity
-   variable for each linear argument, and store the type, scaled by
-   the fresh multiplicity variable in the ConLikeTc; along with
-   the type of the ConLikeTc. This is done by linear_to_poly.
-
-   If the argument is not linear (perhaps explicitly declared as
-   non-linear by the user), don't bother with this.
-
-2. Desugaring, in dsConLike.
-
-  a. The (ConLikeTc K [r,a] [Scaled p a]) is desugared to
-     (/\r (a :: TYPE r). \(x %p :: a). K @r @a x)
-   which has the desired type given in the previous bullet.
-
-   The 'p' is the multiplicity unification variable, which
-   will by now have been unified to something, or defaulted in
-   `GHC.Tc.Utils.Zonk.commitFlexi`. So it won't just be an
-   (unbound) variable.
-
-   So a saturated application (K e), where e::Int will desugar to
-     (/\r (a :: TYPE r). ..etc..)
-        @LiftedRep @Int e
-   and all those lambdas will beta-reduce away in the simple optimiser
-   (see Wrinkle [Representation-polymorphic lambdas] below).
-
-   But for an /unsaturated/ application, such as `map (K @LiftedRep @Int) xs`,
-   beta reduction will leave (\x %Many :: Int. K x), which is the type `map`
-   expects whereas if we had just plain K, with its linear type, we'd
-   get a type mismatch. That's why we do this funky desugaring.
-
-Wrinkles
-
-  [ConLikeTc arguments]
-
-    Note that the [TcType] argument to ConLikeTc is strictly redundant; those are
-    the type variables from the dataConUserTyVarBinders of the data constructor.
-    Similarly in the [Scaled TcType] field of ConLikeTc, the types come directly
-    from the data constructor.  The only bit that /isn't/ redundant is the
-    fresh multiplicity variables!
-
-    So an alternative would be to define ConLikeTc like this:
-        | ConLikeTc [TcType]    -- Just the multiplicity variables
-    But then the desugarer would need to repeat some of the work done here.
-    So for now at least ConLikeTc records this strictly-redundant info.
-
-  [Representation-polymorphic lambdas]
-
-    The lambda expression we produce in (4) can have representation-polymorphic
-    arguments, as indeed in (/\r (a :: TYPE r). \(x %p :: a). K @r @a x),
-    we have a lambda-bound variable x :: (a :: TYPE r).
-    This goes against the representation polymorphism invariants given in
-    Note [Representation polymorphism invariants] in GHC.Core. The trick is that
-    this this lambda will always be instantiated in a way that upholds the invariants.
-    This is achieved as follows:
-
-      A. Any arguments to such lambda abstractions are guaranteed to have
-         a fixed runtime representation. This is enforced in 'tcApp' by
-         'matchActualFunTySigma'.
-
-      B. If there are fewer arguments than there are bound term variables,
-         hasFixedRuntimeRep_remainingValArgs will ensure that we are still
-         instantiating at a representation-monomorphic type, e.g.
-
-         ( /\r (a :: TYPE r). \ (x %p :: a). K @r @a x) @IntRep @Int#
-           :: Int# -> T IntRep Int#
-
-      C. In the output of the desugarer in (4) above, we have a representation
-         polymorphic lambda, which Lint would normally reject. So for that one
-         pass, we switch off Lint's representation-polymorphism checks; see
-         the `lf_check_fixed_rep` flag in `LintFlags`.
--}
-
-{-
-************************************************************************
-*                                                                      *
-                 Template Haskell checks
-*                                                                      *
-************************************************************************
--}
-
-checkThLocalId :: Id -> TcM ()
--- The renamer has already done checkWellStaged,
---   in RnSplice.checkThLocalName, so don't repeat that here.
--- Here we just add constraints for cross-stage lifting
-checkThLocalId id
-  = do  { mb_local_use <- getStageAndBindLevel (idName id)
-        ; case mb_local_use of
-             Just (top_lvl, bind_lvl, use_stage)
-                | thLevel use_stage > bind_lvl
-                -> checkCrossStageLifting top_lvl id use_stage
-             _  -> return ()   -- Not a locally-bound thing, or
-                               -- no cross-stage link
-    }
-
---------------------------------------
-checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
--- If we are inside typed brackets, and (use_lvl > bind_lvl)
--- we must check whether there's a cross-stage lift to do
--- Examples   \x -> [|| x ||]
---            [|| map ||]
---
--- This is similar to checkCrossStageLifting in GHC.Rename.Splice, but
--- this code is applied to *typed* brackets.
-
-checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))
-  | isTopLevel top_lvl
-  = when (isExternalName id_name) (keepAlive id_name)
-    -- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice
-
-  | otherwise
-  =     -- Nested identifiers, such as 'x' in
-        -- E.g. \x -> [|| h x ||]
-        -- We must behave as if the reference to x was
-        --      h $(lift x)
-        -- We use 'x' itself as the splice proxy, used by
-        -- the desugarer to stitch it all back together.
-        -- If 'x' occurs many times we may get many identical
-        -- bindings of the same splice proxy, but that doesn't
-        -- matter, although it's a mite untidy.
-    do  { let id_ty = idType id
-        ; checkTc (isTauTy id_ty) (TcRnSplicePolymorphicLocalVar id)
-               -- If x is polymorphic, its occurrence sites might
-               -- have different instantiations, so we can't use plain
-               -- 'x' as the splice proxy name.  I don't know how to
-               -- solve this, and it's probably unimportant, so I'm
-               -- just going to flag an error for now
-
-        ; lift <- if isStringTy id_ty then
-                     do { sid <- tcLookupId GHC.Builtin.Names.TH.liftStringName
-                                     -- See Note [Lifting strings]
-                        ; return (HsVar noExtField (noLocA sid)) }
-                  else
-                     setConstraintVar lie_var   $
-                          -- Put the 'lift' constraint into the right LIE
-                     newMethodFromName (OccurrenceOf id_name)
-                                       GHC.Builtin.Names.TH.liftName
-                                       [getRuntimeRep id_ty, id_ty]
-
-                   -- Warning for implicit lift (#17804)
-        ; addDetailedDiagnostic (TcRnImplicitLift $ idName id)
-
-                   -- Update the pending splices
-        ; ps <- readMutVar ps_var
-        ; let pending_splice = PendingTcSplice id_name
-                                 (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift))
-                                          (nlHsVar id))
-        ; writeMutVar ps_var (pending_splice : ps)
-
-        ; return () }
-  where
-    id_name = idName id
-
-checkCrossStageLifting _ _ _ = return ()
-
-{-
-Note [Lifting strings]
-~~~~~~~~~~~~~~~~~~~~~~
-If we see $(... [| s |] ...) where s::String, we don't want to
-generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
-So this conditional short-circuits the lifting mechanism to generate
-(liftString "xy") in that case.  I didn't want to use overlapping instances
-for the Lift class in TH.Syntax, because that can lead to overlapping-instance
-errors in a polymorphic situation.
-
-If this check fails (which isn't impossible) we get another chance; see
-Note [Converting strings] in Convert.hs
-
-Note [Local record selectors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Record selectors for TyCons in this module are ordinary local bindings,
-which show up as ATcIds rather than AGlobals.  So we need to check for
-naughtiness in both branches.  c.f. GHC.Tc.TyCl.Utils.mkRecSelBinds.
--}
-
-
-{- *********************************************************************
-*                                                                      *
-         Error reporting for function result mis-matches
-*                                                                      *
-********************************************************************* -}
-
-addFunResCtxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn]
-              -> TcType -> ExpRhoType
-              -> TcM a -> TcM a
--- When we have a mis-match in the return type of a function
--- try to give a helpful message about too many/few arguments
--- But not in generated code, where we don't want
--- to mention internal (rebindable syntax) function names
-addFunResCtxt fun args fun_res_ty env_ty thing_inside
-  = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg) thing_inside
-      -- NB: use a landmark error context, so that an empty context
-      -- doesn't suppress some more useful context
-  where
-    mk_msg
-      = do { mb_env_ty <- readExpType_maybe env_ty
-                     -- by the time the message is rendered, the ExpType
-                     -- will be filled in (except if we're debugging)
-           ; fun_res' <- zonkTcType fun_res_ty
-           ; env'     <- case mb_env_ty of
-                           Just env_ty -> zonkTcType env_ty
-                           Nothing     ->
-                             do { dumping <- doptM Opt_D_dump_tc_trace
-                                ; massert dumping
-                                ; newFlexiTyVarTy liftedTypeKind }
-           ; let -- See Note [Splitting nested sigma types in mismatched
-                 --           function types]
-                 (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res'
-                 (_, _, env_tau) = tcSplitNestedSigmaTys env'
-                     -- env_ty is an ExpRhoTy, but with simple subsumption it
-                     -- is not deeply skolemised, so still use tcSplitNestedSigmaTys
-                 (args_fun, res_fun) = tcSplitFunTys fun_tau
-                 (args_env, res_env) = tcSplitFunTys env_tau
-                 n_fun = length args_fun
-                 n_env = length args_env
-                 info  | -- Check for too few args
-                         --  fun_tau = a -> b, res_tau = Int
-                         n_fun > n_env
-                       , not_fun res_env
-                       = text "Probable cause:" <+> quotes (ppr fun)
-                         <+> text "is applied to too few arguments"
-
-                       | -- Check for too many args
-                         -- fun_tau = a -> Int,   res_tau = a -> b -> c -> d
-                         -- The final guard suppresses the message when there
-                         -- aren't enough args to drop; eg. the call is (f e1)
-                         n_fun < n_env
-                       , not_fun res_fun
-                       , (n_fun + count isValArg args) >= n_env
-                          -- Never suggest that a naked variable is
-                                           -- applied to too many args!
-                       = text "Possible cause:" <+> quotes (ppr fun)
-                         <+> text "is applied to too many arguments"
-
-                       | otherwise
-                       = Outputable.empty
-
-           ; return info }
-
-    not_fun ty   -- ty is definitely not an arrow type,
-                 -- and cannot conceivably become one
-      = case tcSplitTyConApp_maybe ty of
-          Just (tc, _) -> isAlgTyCon tc
-          Nothing      -> False
-
-{-
-Note [Splitting nested sigma types in mismatched function types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When one applies a function to too few arguments, GHC tries to determine this
-fact if possible so that it may give a helpful error message. It accomplishes
-this by checking if the type of the applied function has more argument types
-than supplied arguments.
-
-Previously, GHC computed the number of argument types through tcSplitSigmaTy.
-This is incorrect in the face of nested foralls, however!
-This caused Ticket #13311, for instance:
-
-  f :: forall a. (Monoid a) => Int -> forall b. (Monoid b) => Maybe a -> Maybe b
-
-If one uses `f` like so:
-
-  do { f; putChar 'a' }
-
-Then tcSplitSigmaTy will decompose the type of `f` into:
-
-  Tyvars: [a]
-  Context: (Monoid a)
-  Argument types: []
-  Return type: Int -> forall b. Monoid b => Maybe a -> Maybe b
-
-That is, it will conclude that there are *no* argument types, and since `f`
-was given no arguments, it won't print a helpful error message. On the other
-hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to:
-
-  Tyvars: [a, b]
-  Context: (Monoid a, Monoid b)
-  Argument types: [Int, Maybe a]
-  Return type: Maybe b
-
-So now GHC recognizes that `f` has one more argument type than it was actually
-provided.
-
-Notice that tcSplitNestedSigmaTys looks through function arrows too, regardless
-of simple/deep subsumption.  Here we are concerned only whether there is a
-mis-match in the number of value arguments.
--}
-
-
-{- *********************************************************************
-*                                                                      *
-             Misc utility functions
-*                                                                      *
-********************************************************************* -}
-
-addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
-addExprCtxt e thing_inside
-  = case e of
-      HsUnboundVar {} -> thing_inside
-      _ -> addErrCtxt (exprCtxt e) thing_inside
-   -- The HsUnboundVar special case addresses situations like
-   --    f x = _
-   -- when we don't want to say "In the expression: _",
-   -- because it is mentioned in the error message itself
-
-exprCtxt :: HsExpr GhcRn -> SDoc
-exprCtxt expr = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr))
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ /dev/null
@@ -1,4345 +0,0 @@
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE MonadComprehensions #-}
-{-# LANGUAGE RankNTypes          #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies        #-}
-{-# LANGUAGE ViewPatterns        #-}
-{-# LANGUAGE RecursiveDo        #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
--- | Typechecking user-specified @MonoTypes@
-module GHC.Tc.Gen.HsType (
-        -- Type signatures
-        kcClassSigType, tcClassSigType,
-        tcHsSigType, tcHsSigWcType,
-        tcHsPartialSigType,
-        tcStandaloneKindSig,
-        funsSigCtxt, addSigCtxt, pprSigCtxt,
-
-        tcHsClsInstType,
-        tcHsDeriv, tcDerivStrategy,
-        tcHsTypeApp,
-        UserTypeCtxt(..),
-        bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,
-            bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol,
-        bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,
-            bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,
-
-        bindOuterFamEqnTKBndrs_Q_Tv, bindOuterFamEqnTKBndrs,
-        tcOuterTKBndrs, scopedSortOuter, outerTyVars, outerTyVarBndrs,
-        bindOuterSigTKBndrs_Tv,
-        tcExplicitTKBndrs,
-        bindNamedWildCardBinders,
-
-        -- Type checking type and class decls, and instances thereof
-        bindTyClTyVars, bindTyClTyVarsAndZonk,
-        tcFamTyPats,
-        etaExpandAlgTyCon, tcbVisibilities,
-
-          -- tyvars
-        zonkAndScopedSort,
-
-        -- Kind-checking types
-        -- No kind generalisation, no checkValidType
-        InitialKindStrategy(..),
-        SAKS_or_CUSK(..),
-        ContextKind(..),
-        kcDeclHeader, checkForDuplicateScopedTyVars,
-        tcHsLiftedType,   tcHsOpenType,
-        tcHsLiftedTypeNC, tcHsOpenTypeNC,
-        tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated,
-        tcCheckLHsType,
-        tcHsContext, tcLHsPredType,
-
-        kindGeneralizeAll,
-
-        -- Sort-checking kinds
-        tcLHsKindSig, checkDataKindSig, DataSort(..),
-        checkClassKindSig,
-
-        -- Multiplicity
-        tcMult,
-
-        -- Pattern type signatures
-        tcHsPatSigType,
-        HoleMode(..),
-
-        -- Error messages
-        funAppCtxt, addTyConFlavCtxt
-   ) where
-
-import GHC.Prelude hiding ( head, init, last, tail )
-
-import GHC.Hs
-import GHC.Rename.Utils
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Types.Origin
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Validity
-import GHC.Tc.Utils.Unify
-import GHC.IfaceToCore
-import GHC.Tc.Solver
-import GHC.Tc.Utils.Zonk
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN,
-                                  tcInstInvisibleTyBinder, tcSkolemiseInvisibleBndrs,
-                                  tcInstTypeBndrs )
-
-import GHC.Core.Type
-import GHC.Core.Predicate
-import GHC.Core.TyCo.Rep
-import GHC.Core.TyCo.Ppr
-
-import GHC.Builtin.Types.Prim
-import GHC.Types.Error
-import GHC.Types.Name.Env
-import GHC.Types.Name.Reader( lookupLocalRdrOcc )
-import GHC.Types.Var
-import GHC.Types.Var.Set
-import GHC.Core.TyCon
-import GHC.Core.ConLike
-import GHC.Core.DataCon
-import GHC.Core.Class
-import GHC.Types.Name
-import GHC.Types.Var.Env
-import GHC.Builtin.Types
-import GHC.Types.Basic
-import GHC.Types.SrcLoc
-import GHC.Types.Unique
-import GHC.Types.Unique.FM
-import GHC.Utils.Misc
-import GHC.Types.Unique.Supply
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Builtin.Names hiding ( wildCardName )
-import GHC.Driver.Session
-import qualified GHC.LanguageExtensions as LangExt
-
-import GHC.Data.FastString
-import GHC.Data.List.Infinite ( Infinite (..) )
-import qualified GHC.Data.List.Infinite as Inf
-import GHC.Data.List.SetOps
-import GHC.Data.Maybe
-import GHC.Data.Bag( unitBag )
-
-import Data.Function ( on )
-import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )
-import qualified Data.List.NonEmpty as NE
-import Data.List ( find, mapAccumL )
-import Control.Monad
-import Data.Tuple( swap )
-
-{-
-        ----------------------------
-                General notes
-        ----------------------------
-
-Unlike with expressions, type-checking types both does some checking and
-desugars at the same time. This is necessary because we often want to perform
-equality checks on the types right away, and it would be incredibly painful
-to do this on un-desugared types. Luckily, desugared types are close enough
-to HsTypes to make the error messages sane.
-
-During type-checking, we perform as little validity checking as possible.
-Generally, after type-checking, you will want to do validity checking, say
-with GHC.Tc.Validity.checkValidType.
-
-Validity checking
-~~~~~~~~~~~~~~~~~
-Some of the validity check could in principle be done by the kind checker,
-but not all:
-
-- During desugaring, we normalise by expanding type synonyms.  Only
-  after this step can we check things like type-synonym saturation
-  e.g.  type T k = k Int
-        type S a = a
-  Then (T S) is ok, because T is saturated; (T S) expands to (S Int);
-  and then S is saturated.  This is a GHC extension.
-
-- Similarly, also a GHC extension, we look through synonyms before complaining
-  about the form of a class or instance declaration
-
-- Ambiguity checks involve functional dependencies
-
-Also, in a mutually recursive group of types, we can't look at the TyCon until we've
-finished building the loop.  So to keep things simple, we postpone most validity
-checking until step (3).
-
-%************************************************************************
-%*                                                                      *
-              Check types AND do validity checking
-*                                                                      *
-************************************************************************
-
-Note [Keeping implicitly quantified variables in order]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When the user implicitly quantifies over variables (say, in a type
-signature), we need to come up with some ordering on these variables.
-This is done by bumping the TcLevel, bringing the tyvars into scope,
-and then type-checking the thing_inside. The constraints are all
-wrapped in an implication, which is then solved. Finally, we can
-zonk all the binders and then order them with scopedSort.
-
-It's critical to solve before zonking and ordering in order to uncover
-any unifications. You might worry that this eager solving could cause
-trouble elsewhere. I don't think it will. Because it will solve only
-in an increased TcLevel, it can't unify anything that was mentioned
-elsewhere. Additionally, we require that the order of implicitly
-quantified variables is manifest by the scope of these variables, so
-we're not going to learn more information later that will help order
-these variables.
-
-Note [Recipe for checking a signature]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Kind-checking a user-written signature requires several steps:
-
- 0. Bump the TcLevel
- 1.   Bind any lexically-scoped type variables.
- 2.   Generate constraints.
- 3. Solve constraints.
- 4. Sort any implicitly-bound variables into dependency order
- 5. Promote tyvars and/or kind-generalize.
- 6. Zonk.
- 7. Check validity.
-
-Very similar steps also apply when kind-checking a type or class
-declaration.
-
-The general pattern looks something like this.  (But NB every
-specific instance varies in one way or another!)
-
-    do { (tclvl, wanted, (spec_tkvs, ty))
-              <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $
-                 bindImplicitTKBndrs_Skol sig_vars              $
-                 <kind-check the type>
-
-       ; spec_tkvs <- zonkAndScopedSort spec_tkvs
-
-       ; reportUnsolvedEqualities skol_info spec_tkvs tclvl wanted
-
-       ; let ty1 = mkSpecForAllTys spec_tkvs ty
-       ; kvs <- kindGeneralizeAll ty1
-
-       ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1)
-
-       ; checkValidType final_ty
-
-This pattern is repeated many times in GHC.Tc.Gen.HsType,
-GHC.Tc.Gen.Sig, and GHC.Tc.TyCl, with variations.  In more detail:
-
-* pushLevelAndSolveEqualitiesX (Step 0, step 3) bumps the TcLevel,
-  calls the thing inside to generate constraints, solves those
-  constraints as much as possible, returning the residual unsolved
-  constraints in 'wanted'.
-
-* bindImplicitTKBndrs_Skol (Step 1) binds the user-specified type
-  variables E.g.  when kind-checking f :: forall a. F a -> a we must
-  bring 'a' into scope before kind-checking (F a -> a)
-
-* zonkAndScopedSort (Step 4) puts those user-specified variables in
-  the dependency order.  (For "implicit" variables the order is no
-  user-specified.  E.g.  forall (a::k1) (b::k2). blah k1 and k2 are
-  implicitly brought into scope.
-
-* reportUnsolvedEqualities (Step 3 continued) reports any unsolved
-  equalities, carefully wrapping them in an implication that binds the
-  skolems.  We can't do that in pushLevelAndSolveEqualitiesX because
-  that function doesn't have access to the skolems.
-
-* kindGeneralize (Step 5). See Note [Kind generalisation]
-
-* The final zonkTcTypeToType must happen after promoting/generalizing,
-  because promoting and generalizing fill in metavariables.
-
-
-Doing Step 3 (constraint solving) eagerly (rather than building an
-implication constraint and solving later) is necessary for several
-reasons:
-
-* Exactly as for Solver.simplifyInfer: when generalising, we solve all
-  the constraints we can so that we don't have to quantify over them
-  or, since we don't quantify over constraints in kinds, float them
-  and inhibit generalisation.
-
-* Most signatures also bring implicitly quantified variables into
-  scope, and solving is necessary to get these in the right order
-  (Step 4) see Note [Keeping implicitly quantified variables in
-  order]).
-
-Note [Kind generalisation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Step 5 of Note [Recipe for checking a signature], namely
-kind-generalisation, is done by
-    kindGeneraliseAll
-    kindGeneraliseSome
-    kindGeneraliseNone
-
-Here, we have to deal with the fact that metatyvars generated in the
-type will have a bumped TcLevel, because explicit foralls raise the
-TcLevel. To avoid these variables from ever being visible in the
-surrounding context, we must obey the following dictum:
-
-  Every metavariable in a type must either be
-    (A) generalized, or
-    (B) promoted, or        See Note [Promotion in signatures]
-    (C) a cause to error    See Note [Naughty quantification candidates]
-                            in GHC.Tc.Utils.TcMType
-
-There are three steps (look at kindGeneraliseSome):
-
-1. candidateQTyVarsOfType finds the free variables of the type or kind,
-   to generalise
-
-2. filterConstrainedCandidates filters out candidates that appear
-   in the unsolved 'wanteds', and promotes the ones that get filtered out
-   thereby.
-
-3. quantifyTyVars quantifies the remaining type variables
-
-The kindGeneralize functions do not require pre-zonking; they zonk as they
-go.
-
-kindGeneraliseAll specialises for the case where step (2) is vacuous.
-kindGeneraliseNone specialises for the case where we do no quantification,
-but we must still promote.
-
-If you are actually doing kind-generalization, you need to bump the
-level before generating constraints, as we will only generalize
-variables with a TcLevel higher than the ambient one.
-Hence the "pushLevel" in pushLevelAndSolveEqualities.
-
-Note [Promotion in signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If an unsolved metavariable in a signature is not generalized
-(because we're not generalizing the construct -- e.g., pattern
-sig -- or because the metavars are constrained -- see kindGeneralizeSome)
-we need to promote to maintain (WantedInv) of Note [TcLevel invariants]
-in GHC.Tc.Utils.TcType. Note that promotion is identical in effect to generalizing
-and the reinstantiating with a fresh metavariable at the current level.
-So in some sense, we generalize *all* variables, but then re-instantiate
-some of them.
-
-Here is an example of why we must promote:
-  foo (x :: forall a. a -> Proxy b) = ...
-
-In the pattern signature, `b` is unbound, and will thus be brought into
-scope. We do not know its kind: it will be assigned kappa[2]. Note that
-kappa is at TcLevel 2, because it is invented under a forall. (A priori,
-the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel
-than the surrounding context.) This kappa cannot be solved for while checking
-the pattern signature (which is not kind-generalized). When we are checking
-the *body* of foo, though, we need to unify the type of x with the argument
-type of bar. At this point, the ambient TcLevel is 1, and spotting a
-metavariable with level 2 would violate the (WantedInv) invariant of
-Note [TcLevel invariants]. So, instead of kind-generalizing,
-we promote the metavariable to level 1. This is all done in kindGeneralizeNone.
-
--}
-
-funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt
--- Returns FunSigCtxt, with no redundant-context-reporting,
--- form a list of located names
-funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 NoRRC
-funsSigCtxt []              = panic "funSigCtxt"
-
-addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a
-addSigCtxt ctxt hs_ty thing_inside
-  = setSrcSpan (getLocA hs_ty) $
-    addErrCtxt (pprSigCtxt ctxt hs_ty) $
-    thing_inside
-
-pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc
--- (pprSigCtxt ctxt <extra> <type>)
--- prints    In the type signature for 'f':
---              f :: <type>
--- The <extra> is either empty or "the ambiguity check for"
-pprSigCtxt ctxt hs_ty
-  | Just n <- isSigMaybe ctxt
-  = hang (text "In the type signature:")
-       2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty)
-
-  | otherwise
-  = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)
-       2 (ppr hs_ty)
-
-tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
--- This one is used when we have a LHsSigWcType, but in
--- a place where wildcards aren't allowed. The renamer has
--- already checked this, so we can simply ignore it.
-tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)
-
-kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM ()
--- This is a special form of tcClassSigType that is used during the
--- kind-checking phase to infer the kind of class variables. Cf. tc_lhs_sig_type.
--- Importantly, this does *not* kind-generalize. Consider
---   class SC f where
---     meth :: forall a (x :: f a). Proxy x -> ()
--- When instantiating Proxy with kappa, we must unify kappa := f a. But we're
--- still working out the kind of f, and thus f a will have a coercion in it.
--- Coercions block unification (Note [Equalities with incompatible kinds] in
--- TcCanonical) and so we fail to unify. If we try to kind-generalize, we'll
--- end up promoting kappa to the top level (because kind-generalization is
--- normally done right before adding a binding to the context), and then we
--- can't set kappa := f a, because a is local.
-kcClassSigType names
-    sig_ty@(L _ (HsSig { sig_bndrs = hs_outer_bndrs, sig_body = hs_ty }))
-  = addSigCtxt (funsSigCtxt names) sig_ty $
-    do { _ <- bindOuterSigTKBndrs_Tv hs_outer_bndrs    $
-              tcLHsType hs_ty liftedTypeKind
-       ; return () }
-
-tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type
--- Does not do validity checking
-tcClassSigType names sig_ty
-  = addSigCtxt sig_ctxt sig_ty $
-    do { skol_info <- mkSkolemInfo skol_info_anon
-       ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (TheKind liftedTypeKind)
-       ; emitImplication implic
-       ; return ty }
-       -- Do not zonk-to-Type, nor perform a validity check
-       -- We are in a knot with the class and associated types
-       -- Zonking and validity checking is done by tcClassDecl
-       --
-       -- No need to fail here if the type has an error:
-       --   If we're in the kind-checking phase, the solveEqualities
-       --     in kcTyClGroup catches the error
-       --   If we're in the type-checking phase, the solveEqualities
-       --     in tcClassDecl1 gets it
-       -- Failing fast here degrades the error message in, e.g., tcfail135:
-       --   class Foo f where
-       --     baa :: f a -> f
-       -- If we fail fast, we're told that f has kind `k1` when we wanted `*`.
-       -- It should be that f has kind `k2 -> *`, but we never get a chance
-       -- to run the solver where the kind of f is touchable. This is
-       -- painfully delicate.
-  where
-    sig_ctxt = funsSigCtxt names
-    skol_info_anon = SigTypeSkol sig_ctxt
-
-tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
--- Does validity checking
--- See Note [Recipe for checking a signature]
-tcHsSigType ctxt sig_ty
-  = addSigCtxt ctxt sig_ty $
-    do { traceTc "tcHsSigType {" (ppr sig_ty)
-       ; skol_info <- mkSkolemInfo skol_info
-          -- Generalise here: see Note [Kind generalisation]
-       ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty  (expectedKindInCtxt ctxt)
-
-       -- Float out constraints, failing fast if not possible
-       -- See Note [Failure in local type signatures] in GHC.Tc.Solver
-       ; traceTc "tcHsSigType 2" (ppr implic)
-       ; simplifyAndEmitFlatConstraints (mkImplicWC (unitBag implic))
-
-       ; ty <- zonkTcType ty
-       ; checkValidType ctxt ty
-       ; traceTc "end tcHsSigType }" (ppr ty)
-       ; return ty }
-  where
-    skol_info = SigTypeSkol ctxt
-
-tc_lhs_sig_type :: SkolemInfo -> LHsSigType GhcRn
-               -> ContextKind -> TcM (Implication, TcType)
--- Kind-checks/desugars an 'LHsSigType',
---   solve equalities,
---   and then kind-generalizes.
--- This will never emit constraints, as it uses solveEqualities internally.
--- No validity checking or zonking
--- Returns also an implication for the unsolved constraints
-tc_lhs_sig_type skol_info full_hs_ty@(L loc (HsSig { sig_bndrs = hs_outer_bndrs
-                                                   , sig_body = hs_ty })) ctxt_kind
-  = setSrcSpanA loc $
-    do { (tc_lvl, wanted, (exp_kind, (outer_bndrs, ty)))
-              <- pushLevelAndSolveEqualitiesX "tc_lhs_sig_type" $
-                 -- See Note [Failure in local type signatures]
-                 do { exp_kind <- newExpectedKind ctxt_kind
-                          -- See Note [Escaping kind in type signatures]
-                    ; stuff <- tcOuterTKBndrs skol_info hs_outer_bndrs $
-                               tcLHsType hs_ty exp_kind
-                    ; return (exp_kind, stuff) }
-
-       -- Default any unconstrained variables free in the kind
-       -- See Note [Escaping kind in type signatures]
-       ; exp_kind_dvs <- candidateQTyVarsOfType exp_kind
-       ; doNotQuantifyTyVars exp_kind_dvs (mk_doc exp_kind)
-
-       ; traceTc "tc_lhs_sig_type" (ppr hs_outer_bndrs $$ ppr outer_bndrs)
-       ; outer_bndrs <- scopedSortOuter outer_bndrs
-
-       ; let outer_tv_bndrs :: [InvisTVBinder] = outerTyVarBndrs outer_bndrs
-             ty1 = mkInvisForAllTys outer_tv_bndrs ty
-       ; kvs <- kindGeneralizeSome skol_info wanted ty1
-
-       -- Build an implication for any as-yet-unsolved kind equalities
-       -- See Note [Skolem escape in type signatures]
-       ; implic <- buildTvImplication (getSkolemInfo skol_info) kvs tc_lvl wanted
-
-       ; return (implic, mkInfForAllTys kvs ty1) }
-  where
-    mk_doc exp_kind tidy_env
-      = do { (tidy_env2, exp_kind) <- zonkTidyTcType tidy_env exp_kind
-           ; return (tidy_env2, hang (text "The kind" <+> ppr exp_kind)
-                                   2 (text "of type signature:" <+> ppr full_hs_ty)) }
-
-
-
-{- Note [Escaping kind in type signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider kind-checking the signature for `foo` (#19495):
-  type family T (r :: RuntimeRep) :: TYPE r
-
-  foo :: forall (r :: RuntimeRep). T r
-  foo = ...
-
-We kind-check the type with expected kind `TYPE delta` (see newExpectedKind),
-where `delta :: RuntimeRep` is as-yet unknown. (We can't use `TYPE LiftedRep`
-because we allow signatures like `foo :: Int#`.)
-
-Suppose we are at level L currently.  We do this
-  * pushLevelAndSolveEqualitiesX: moves to level L+1
-  * newExpectedKind: allocates delta{L+1}
-  * tcOuterTKBndrs: pushes the level again to L+2, binds skolem r{L+2}
-  * kind-check the body (T r) :: TYPE delta{L+1}
-
-Then
-* We can't unify delta{L+1} with r{L+2}.
-  And rightly so: skolem would escape.
-
-* If delta{L+1} is unified with some-kind{L}, that is fine.
-  This can happen
-      \(x::a) -> let y :: a; y = x in ...(x :: Int#)...
-  Here (x :: a :: TYPE gamma) is in the environment when we check
-  the signature y::a.  We unify delta := gamma, and all is well.
-
-* If delta{L+1} is unconstrained, we /must not/ quantify over it!
-  E.g. Consider f :: Any   where Any :: forall k. k
-  We kind-check this with expected kind TYPE kappa. We get
-      Any @(TYPE kappa) :: TYPE kappa
-  We don't want to generalise to     forall k. Any @k
-  because that is ill-kinded: the kind of the body of the forall,
-  (Any @k :: k) mentions the bound variable k.
-
-  Instead we want to default it to LiftedRep.
-
-  An alternative would be to promote it, similar to the monomorphism
-  restriction, but the MR is pretty confusing.  Defaulting seems better
-
-How does that defaulting happen?  Well, since we /currently/ default
-RuntimeRep variables during generalisation, it'll happen in
-kindGeneralize. But in principle we might allow generalisation over
-RuntimeRep variables in future.  Moreover, what if we had
-   kappa{L+1} := F alpha{L+1}
-where F :: Type -> RuntimeRep.   Now it's alpha that is free in the kind
-and it /won't/ be defaulted.
-
-So we use doNotQuantifyTyVars to either default the free vars of
-exp_kind (if possible), or error (if not).
-
-Note [Skolem escape in type signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-tcHsSigType is tricky.  Consider (T11142)
-  foo :: forall b. (forall k (a :: k). SameKind a b) -> ()
-This is ill-kinded because of a nested skolem-escape.
-
-That will show up as an un-solvable constraint in the implication
-returned by buildTvImplication in tc_lhs_sig_type.  See Note [Skolem
-escape prevention] in GHC.Tc.Utils.TcType for why it is unsolvable
-(the unification variable for b's kind is untouchable).
-
-Then, in GHC.Tc.Solver.simplifyAndEmitFlatConstraints (called from tcHsSigType)
-we'll try to float out the constraint, be unable to do so, and fail.
-See GHC.Tc.Solver Note [Failure in local type signatures] for more
-detail on this.
-
-The separation between tcHsSigType and tc_lhs_sig_type is because
-tcClassSigType wants to use the latter, but *not* fail fast, because
-there are skolems from the class decl which are in scope; but it's fine
-not to because tcClassDecl1 has a solveEqualities wrapped around all
-the tcClassSigType calls.
-
-That's why tcHsSigType does simplifyAndEmitFlatConstraints (which
-fails fast) but tcClassSigType just does emitImplication (which does
-not).  Ugh.
-
-c.f. see also Note [Skolem escape and forall-types]. The difference
-is that we don't need to simplify at a forall type, only at the
-top level of a signature.
--}
-
--- Does validity checking and zonking.
-tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)
-tcStandaloneKindSig (L _ (StandaloneKindSig _ (L _ name) ksig))
-  = addSigCtxt ctxt ksig $
-    do { kind <- tc_top_lhs_type KindLevel ctxt ksig
-       ; checkValidType ctxt kind
-       ; return (name, kind) }
-  where
-   ctxt = StandaloneKindSigCtxt name
-
-tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
-tcTopLHsType ctxt lsig_ty
-  = checkNoErrs $  -- Fail eagerly to avoid follow-on errors.  We are at
-                   -- top level so these constraints will never be solved later.
-    tc_top_lhs_type TypeLevel ctxt lsig_ty
-
-tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
--- tc_top_lhs_type is used for kind-checking top-level LHsSigTypes where
---   we want to fully solve /all/ equalities, and report errors
--- Does zonking, but not validity checking because it's used
---   for things (like deriving and instances) that aren't
---   ordinary types
--- Used for both types and kinds
-tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs
-                                               , sig_body = body }))
-  = setSrcSpanA loc $
-    do { traceTc "tc_top_lhs_type {" (ppr sig_ty)
-       ; skol_info <- mkSkolemInfo skol_info_anon
-       ; (tclvl, wanted, (outer_bndrs, ty))
-              <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type"    $
-                 tcOuterTKBndrs skol_info hs_outer_bndrs $
-                 do { kind <- newExpectedKind (expectedKindInCtxt ctxt)
-                    ; tc_lhs_type (mkMode tyki) body kind }
-
-       ; outer_bndrs <- scopedSortOuter outer_bndrs
-       ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs
-             ty1 = mkInvisForAllTys outer_tv_bndrs ty
-
-       ; kvs <- kindGeneralizeAll skol_info ty1  -- "All" because it's a top-level type
-       ; reportUnsolvedEqualities skol_info kvs tclvl wanted
-
-       ; ze       <- mkEmptyZonkEnv NoFlexi
-       ; final_ty <- zonkTcTypeToTypeX ze (mkInfForAllTys kvs ty1)
-       ; traceTc "tc_top_lhs_type }" (vcat [ppr sig_ty, ppr final_ty])
-       ; return final_ty }
-  where
-    skol_info_anon = SigTypeSkol ctxt
-
------------------
-tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])
--- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause
--- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments
--- E.g.    class C (a::*) (b::k->k)
---         data T a b = ... deriving( C Int )
---    returns ([k], C, [k, Int], [k->k])
--- Return values are fully zonked
-tcHsDeriv hs_ty
-  = do { ty <- tcTopLHsType DerivClauseCtxt hs_ty
-       ; let (tvs, pred)    = splitForAllTyCoVars ty
-             (kind_args, _) = splitFunTys (typeKind pred)
-       ; case getClassPredTys_maybe pred of
-           Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args)
-           Nothing -> failWithTc $ TcRnIllegalDerivingItem hs_ty }
-
--- | Typecheck a deriving strategy. For most deriving strategies, this is a
--- no-op, but for the @via@ strategy, this requires typechecking the @via@ type.
-tcDerivStrategy :: Maybe (LDerivStrategy GhcRn)
-                   -- ^ The deriving strategy
-                -> TcM (Maybe (LDerivStrategy GhcTc), [TcTyVar])
-                   -- ^ The typechecked deriving strategy and the tyvars that it binds
-                   -- (if using 'ViaStrategy').
-tcDerivStrategy mb_lds
-  = case mb_lds of
-      Nothing -> boring_case Nothing
-      Just (L loc ds) ->
-        setSrcSpanA loc $ do
-          (ds', tvs) <- tc_deriv_strategy ds
-          pure (Just (L loc ds'), tvs)
-  where
-    tc_deriv_strategy :: DerivStrategy GhcRn
-                      -> TcM (DerivStrategy GhcTc, [TyVar])
-    tc_deriv_strategy (StockStrategy    _) = boring_case (StockStrategy    noExtField)
-    tc_deriv_strategy (AnyclassStrategy _) = boring_case (AnyclassStrategy noExtField)
-    tc_deriv_strategy (NewtypeStrategy  _) = boring_case (NewtypeStrategy  noExtField)
-    tc_deriv_strategy (ViaStrategy hs_sig)
-      = do { ty <- tcTopLHsType DerivClauseCtxt hs_sig
-           ; rec { (via_tvs, via_pred) <- tcSkolemiseInvisibleBndrs (DerivSkol via_pred) ty}
-           ; pure (ViaStrategy via_pred, via_tvs) }
-
-    boring_case :: ds -> TcM (ds, [a])
-    boring_case ds = pure (ds, [])
-
-tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt
-                -> LHsSigType GhcRn
-                -> TcM Type
--- Like tcHsSigType, but for a class instance declaration
-tcHsClsInstType user_ctxt hs_inst_ty
-  = setSrcSpan (getLocA hs_inst_ty) $
-    do { inst_ty <- tcTopLHsType user_ctxt hs_inst_ty
-       ; checkValidInstance user_ctxt hs_inst_ty inst_ty
-       ; return inst_ty }
-
-----------------------------------------------
--- | Type-check a visible type application
-tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type
--- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType
-tcHsTypeApp wc_ty kind
-  | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty
-  = do { mode <- mkHoleMode TypeLevel HM_VTA
-                 -- HM_VTA: See Note [Wildcards in visible type application]
-       ; ty <- addTypeCtxt hs_ty                  $
-               solveEqualities "tcHsTypeApp" $
-               -- We are looking at a user-written type, very like a
-               -- signature so we want to solve its equalities right now
-               bindNamedWildCardBinders sig_wcs $ \ _ ->
-               tc_lhs_type mode hs_ty kind
-
-       -- We do not kind-generalize type applications: we just
-       -- instantiate with exactly what the user says.
-       -- See Note [No generalization in type application]
-       -- We still must call kindGeneralizeNone, though, according
-       -- to Note [Recipe for checking a signature]
-       ; kindGeneralizeNone ty
-       ; ty <- zonkTcType ty
-       ; checkValidType TypeAppCtxt ty
-       ; return ty }
-
-{- Note [Wildcards in visible type application]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so
-any unnamed wildcards stay unchanged in hswc_body.  When called in
-tcHsTypeApp, tcCheckLHsType will call emitAnonTypeHole
-on these anonymous wildcards. However, this would trigger
-error/warning when an anonymous wildcard is passed in as a visible type
-argument, which we do not want because users should be able to write
-@_ to skip a instantiating a type variable variable without fuss. The
-solution is to switch the PartialTypeSignatures flags here to let the
-typechecker know that it's checking a '@_' and do not emit hole
-constraints on it.  See related Note [Wildcards in visible kind
-application] and Note [The wildcard story for types] in GHC.Hs.Type
-
-Ugh!
-
-Note [No generalization in type application]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not kind-generalize type applications. Imagine
-
-  id @(Proxy Nothing)
-
-If we kind-generalized, we would get
-
-  id @(forall {k}. Proxy @(Maybe k) (Nothing @k))
-
-which is very sneakily impredicative instantiation.
-
-There is also the possibility of mentioning a wildcard
-(`id @(Proxy _)`), which definitely should not be kind-generalized.
-
--}
-
-tcFamTyPats :: TyCon
-            -> HsTyPats GhcRn                -- Patterns
-            -> TcM (TcType, TcKind)          -- (lhs_type, lhs_kind)
--- Check the LHS of a type/data family instance
--- e.g.   type instance F ty1 .. tyn = ...
--- Used for both type and data families
-tcFamTyPats fam_tc hs_pats
-  = do { traceTc "tcFamTyPats {" $
-         vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ]
-
-       ; mode <- mkHoleMode TypeLevel HM_FamPat
-                 -- HM_FamPat: See Note [Wildcards in family instances] in
-                 -- GHC.Rename.Module
-       ; let fun_ty = mkTyConApp fam_tc []
-       ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats
-
-       -- Hack alert: see Note [tcFamTyPats: zonking the result kind]
-       ; res_kind <- zonkTcType res_kind
-
-       ; traceTc "End tcFamTyPats }" $
-         vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ]
-
-       ; return (fam_app, res_kind) }
-  where
-    fam_name  = tyConName fam_tc
-    fam_arity = tyConArity fam_tc
-    lhs_fun   = noLocA (HsTyVar noAnn NotPromoted (noLocA fam_name))
-
-{- Note [tcFamTyPats: zonking the result kind]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#19250)
-    F :: forall k. k -> k
-    type instance F (x :: Constraint) = ()
-
-The tricky point is this:
-  is that () an empty type tuple (() :: Type), or
-  an empty constraint tuple (() :: Constraint)?
-We work this out in a hacky way, by looking at the expected kind:
-see Note [Inferring tuple kinds].
-
-In this case, we kind-check the RHS using the kind gotten from the LHS:
-see the call to tcCheckLHsType in tcTyFamInstEqnGuts in GHC.Tc.Tycl.
-
-But we want the kind from the LHS to be /zonked/, so that when
-kind-checking the RHS (tcCheckLHsType) we can "see" what we learned
-from kind-checking the LHS (tcFamTyPats).  In our example above, the
-type of the LHS is just `kappa` (by instantiating the forall k), but
-then we learn (from x::Constraint) that kappa ~ Constraint.  We want
-that info when kind-checking the RHS.
-
-Easy solution: just zonk that return kind.  Of course this won't help
-if there is lots of type-family reduction to do, but it works fine in
-common cases.
--}
-
-
-{-
-************************************************************************
-*                                                                      *
-            The main kind checker: no validity checks here
-*                                                                      *
-************************************************************************
--}
-
----------------------------
-tcHsOpenType, tcHsLiftedType,
-  tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType
--- Used for type signatures
--- Do not do validity checking
-tcHsOpenType   hs_ty = addTypeCtxt hs_ty $ tcHsOpenTypeNC hs_ty
-tcHsLiftedType hs_ty = addTypeCtxt hs_ty $ tcHsLiftedTypeNC hs_ty
-
-tcHsOpenTypeNC   hs_ty = do { ek <- newOpenTypeKind; tcLHsType hs_ty ek }
-tcHsLiftedTypeNC hs_ty = tcLHsType hs_ty liftedTypeKind
-
--- Like tcHsType, but takes an expected kind
-tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType
-tcCheckLHsType hs_ty exp_kind
-  = addTypeCtxt hs_ty $
-    do { ek <- newExpectedKind exp_kind
-       ; tcLHsType hs_ty ek }
-
-tcInferLHsType :: LHsType GhcRn -> TcM TcType
-tcInferLHsType hs_ty
-  = do { (ty,_kind) <- tcInferLHsTypeKind hs_ty
-       ; return ty }
-
-tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind)
--- Called from outside: set the context
--- Eagerly instantiate any trailing invisible binders
-tcInferLHsTypeKind lhs_ty@(L loc hs_ty)
-  = addTypeCtxt lhs_ty $
-    setSrcSpanA loc    $  -- Cover the tcInstInvisibleTyBinders
-    do { (res_ty, res_kind) <- tc_infer_hs_type typeLevelMode hs_ty
-       ; tcInstInvisibleTyBinders res_ty res_kind }
-  -- See Note [Do not always instantiate eagerly in types]
-
--- Used to check the argument of GHCi :kind
--- Allow and report wildcards, e.g. :kind T _
--- Do not saturate family applications: see Note [Dealing with :kind]
--- Does not instantiate eagerly; See Note [Do not always instantiate eagerly in types]
-tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)
-tcInferLHsTypeUnsaturated hs_ty
-  = addTypeCtxt hs_ty $
-    do { mode <- mkHoleMode TypeLevel HM_Sig  -- Allow and report holes
-       ; case splitHsAppTys (unLoc hs_ty) of
-           Just (hs_fun_ty, hs_args)
-              -> do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty
-                    ; tcInferTyApps_nosat mode hs_fun_ty fun_ty hs_args }
-                      -- Notice the 'nosat'; do not instantiate trailing
-                      -- invisible arguments of a type family.
-                      -- See Note [Dealing with :kind]
-           Nothing -> tc_infer_lhs_type mode hs_ty }
-
-{- Note [Dealing with :kind]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this GHCi command
-  ghci> type family F :: Either j k
-  ghci> :kind F
-  F :: forall {j,k}. Either j k
-
-We will only get the 'forall' if we /refrain/ from saturating those
-invisible binders. But generally we /do/ saturate those invisible
-binders (see tcInferTyApps), and we want to do so for nested application
-even in GHCi.  Consider for example (#16287)
-  ghci> type family F :: k
-  ghci> data T :: (forall k. k) -> Type
-  ghci> :kind T F
-We want to reject this. It's just at the very top level that we want
-to switch off saturation.
-
-So tcInferLHsTypeUnsaturated does a little special case for top level
-applications.  Actually the common case is a bare variable, as above.
-
-Note [Do not always instantiate eagerly in types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Terms are eagerly instantiated. This means that if you say
-
-  x = id
-
-then `id` gets instantiated to have type alpha -> alpha. The variable
-alpha is then unconstrained and regeneralized. But we cannot do this
-in types, as we have no type-level lambda. So, when we are sure
-that we will not want to regeneralize later -- because we are done
-checking a type, for example -- we can instantiate. But we do not
-instantiate at variables, nor do we in tcInferLHsTypeUnsaturated,
-which is used by :kind in GHCi.
-
-************************************************************************
-*                                                                      *
-      Type-checking modes
-*                                                                      *
-************************************************************************
-
-The kind-checker is parameterised by a TcTyMode, which contains some
-information about where we're checking a type.
-
-The renamer issues errors about what it can. All errors issued here must
-concern things that the renamer can't handle.
-
--}
-
-tcMult :: HsArrow GhcRn -> TcM Mult
-tcMult hc = tc_mult typeLevelMode hc
-
--- | Info about the context in which we're checking a type. Currently,
--- differentiates only between types and kinds, but this will likely
--- grow, at least to include the distinction between patterns and
--- not-patterns.
---
--- To find out where the mode is used, search for 'mode_tyki'
---
--- This data type is purely local, not exported from this module
-data TcTyMode
-  = TcTyMode { mode_tyki :: TypeOrKind
-             , mode_holes :: HoleInfo   }
-
--- See Note [Levels for wildcards]
--- Nothing <=> no wildcards expected
-type HoleInfo = Maybe (TcLevel, HoleMode)
-
--- HoleMode says how to treat the occurrences
--- of anonymous wildcards; see tcAnonWildCardOcc
-data HoleMode = HM_Sig      -- Partial type signatures: f :: _ -> Int
-              | HM_FamPat   -- Family instances: F _ Int = Bool
-              | HM_VTA      -- Visible type and kind application:
-                            --   f @(Maybe _)
-                            --   Maybe @(_ -> _)
-              | HM_TyAppPat -- Visible type applications in patterns:
-                            --   foo (Con @_ @t x) = ...
-                            --   case x of Con @_ @t v -> ...
-
-mkMode :: TypeOrKind -> TcTyMode
-mkMode tyki = TcTyMode { mode_tyki = tyki, mode_holes = Nothing }
-
-typeLevelMode, kindLevelMode :: TcTyMode
--- These modes expect no wildcards (holes) in the type
-kindLevelMode = mkMode KindLevel
-typeLevelMode = mkMode TypeLevel
-
-mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode
-mkHoleMode tyki hm
-  = do { lvl <- getTcLevel
-       ; return (TcTyMode { mode_tyki  = tyki
-                          , mode_holes = Just (lvl,hm) }) }
-
-instance Outputable HoleMode where
-  ppr HM_Sig      = text "HM_Sig"
-  ppr HM_FamPat   = text "HM_FamPat"
-  ppr HM_VTA      = text "HM_VTA"
-  ppr HM_TyAppPat = text "HM_TyAppPat"
-
-instance Outputable TcTyMode where
-  ppr (TcTyMode { mode_tyki = tyki, mode_holes = hm })
-    = text "TcTyMode" <+> braces (sep [ ppr tyki <> comma
-                                      , ppr hm ])
-
-{-
-Note [Bidirectional type checking]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In expressions, whenever we see a polymorphic identifier, say `id`, we are
-free to instantiate it with metavariables, knowing that we can always
-re-generalize with type-lambdas when necessary. For example:
-
-  rank2 :: (forall a. a -> a) -> ()
-  x = rank2 id
-
-When checking the body of `x`, we can instantiate `id` with a metavariable.
-Then, when we're checking the application of `rank2`, we notice that we really
-need a polymorphic `id`, and then re-generalize over the unconstrained
-metavariable.
-
-In types, however, we're not so lucky, because *we cannot re-generalize*!
-There is no lambda. So, we must be careful only to instantiate at the last
-possible moment, when we're sure we're never going to want the lost polymorphism
-again. This is done in calls to tcInstInvisibleTyBinders.
-
-To implement this behavior, we use bidirectional type checking, where we
-explicitly think about whether we know the kind of the type we're checking
-or not. Note that there is a difference between not knowing a kind and
-knowing a metavariable kind: the metavariables are TauTvs, and cannot become
-forall-quantified kinds. Previously (before dependent types), there were
-no higher-rank kinds, and so we could instantiate early and be sure that
-no types would have polymorphic kinds, and so we could always assume that
-the kind of a type was a fresh metavariable. Not so anymore, thus the
-need for two algorithms.
-
-For HsType forms that can never be kind-polymorphic, we implement only the
-"down" direction, where we safely assume a metavariable kind. For HsType forms
-that *can* be kind-polymorphic, we implement just the "up" (functions with
-"infer" in their name) version, as we gain nothing by also implementing the
-"down" version.
-
-Note [Future-proofing the type checker]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As discussed in Note [Bidirectional type checking], each HsType form is
-handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions
-are mutually recursive, so that either one can work for any type former.
-But, we want to make sure that our pattern-matches are complete. So,
-we have a bunch of repetitive code just so that we get warnings if we're
-missing any patterns.
-
--}
-
-------------------------------------------
--- | Check and desugar a type, returning the core type and its
--- possibly-polymorphic kind. Much like 'tcInferRho' at the expression
--- level.
-tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)
-tc_infer_lhs_type mode (L span ty)
-  = setSrcSpanA span $
-    tc_infer_hs_type mode ty
-
----------------------------
--- | Call 'tc_infer_hs_type' and check its result against an expected kind.
-tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
-tc_infer_hs_type_ek mode hs_ty ek
-  = do { (ty, k) <- tc_infer_hs_type mode hs_ty
-       ; checkExpectedKind hs_ty ty k ek }
-
----------------------------
--- | Infer the kind of a type and desugar. This is the "up" type-checker,
--- as described in Note [Bidirectional type checking]
-tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)
-
-tc_infer_hs_type mode (HsParTy _ t)
-  = tc_infer_lhs_type mode t
-
-tc_infer_hs_type mode ty
-  | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty
-  = do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty
-       ; tcInferTyApps mode hs_fun_ty fun_ty hs_args }
-
-tc_infer_hs_type mode (HsKindSig _ ty sig)
-  = do { let mode' = mode { mode_tyki = KindLevel }
-       ; sig' <- tc_lhs_kind_sig mode' KindSigCtxt sig
-                 -- We must typecheck the kind signature, and solve all
-                 -- its equalities etc; from this point on we may do
-                 -- things like instantiate its foralls, so it needs
-                 -- to be fully determined (#14904)
-       ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig')
-       ; ty' <- tc_lhs_type mode ty sig'
-       ; return (ty', sig') }
-
--- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate
--- the splice location to the typechecker. Here we skip over it in order to have
--- the same kind inferred for a given expression whether it was produced from
--- splices or not.
---
--- See Note [Delaying modFinalizers in untyped splices].
-tc_infer_hs_type mode (HsSpliceTy (HsUntypedSpliceTop _ ty) _)
-  = tc_infer_lhs_type mode ty
-
-tc_infer_hs_type _ (HsSpliceTy (HsUntypedSpliceNested n) s) = pprPanic "tc_infer_hs_type: invalid nested splice" (pprUntypedSplice True (Just n) s)
-
-tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty
-
--- See Note [Typechecking HsCoreTys]
-tc_infer_hs_type _ (XHsType ty)
-  = do env <- getLclEnv
-       -- Raw uniques since we go from NameEnv to TvSubstEnv.
-       let subst_prs :: [(Unique, TcTyVar)]
-           subst_prs = [ (getUnique nm, tv)
-                       | ATyVar nm tv <- nonDetNameEnvElts (tcl_env env) ]
-           subst = mkTvSubst
-                     (mkInScopeSetList $ map snd subst_prs)
-                     (listToUFM_Directly $ map (fmap mkTyVarTy) subst_prs)
-           ty' = substTy subst ty
-       return (ty', typeKind ty')
-
-tc_infer_hs_type _ (HsExplicitListTy _ _ tys)
-  | null tys  -- this is so that we can use visible kind application with '[]
-              -- e.g ... '[] @Bool
-  = return (mkTyConTy promotedNilDataCon,
-            mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy)
-
-tc_infer_hs_type mode other_ty
-  = do { kv <- newMetaKindVar
-       ; ty' <- tc_hs_type mode other_ty kv
-       ; return (ty', kv) }
-
-{-
-Note [Typechecking HsCoreTys]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-HsCoreTy is an escape hatch that allows embedding Core Types in HsTypes.
-As such, there's not much to be done in order to typecheck an HsCoreTy,
-since it's already been typechecked to some extent. There is one thing that
-we must do, however: we must substitute the type variables from the tcl_env.
-To see why, consider GeneralizedNewtypeDeriving, which is one of the main
-clients of HsCoreTy (example adapted from #14579):
-
-  newtype T a = MkT a deriving newtype Eq
-
-This will produce an InstInfo GhcPs that looks roughly like this:
-
-  instance forall a_1. Eq a_1 => Eq (T a_1) where
-    (==) = coerce @(  a_1 ->   a_1 -> Bool) -- The type within @(...) is an HsCoreTy
-                  @(T a_1 -> T a_1 -> Bool) -- So is this
-                  (==)
-
-This is then fed into the renamer. Since all of the type variables in this
-InstInfo use Exact RdrNames, the resulting InstInfo GhcRn looks basically
-identical. Things get more interesting when the InstInfo is fed into the
-typechecker, however. GHC will first generate fresh skolems to instantiate
-the instance-bound type variables with. In the example above, we might generate
-the skolem a_2 and use that to instantiate a_1, which extends the local type
-environment (tcl_env) with [a_1 :-> a_2]. This gives us:
-
-  instance forall a_2. Eq a_2 => Eq (T a_2) where ...
-
-To ensure that the body of this instance is well scoped, every occurrence of
-the `a` type variable should refer to a_2, the new skolem. However, the
-HsCoreTys mention a_1, not a_2. Luckily, the tcl_env provides exactly the
-substitution we need ([a_1 :-> a_2]) to fix up the scoping. We apply this
-substitution to each HsCoreTy and all is well:
-
-  instance forall a_2. Eq a_2 => Eq (T a_2) where
-    (==) = coerce @(  a_2 ->   a_2 -> Bool)
-                  @(T a_2 -> T a_2 -> Bool)
-                  (==)
--}
-
-------------------------------------------
-tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType
-tcLHsType hs_ty exp_kind
-  = tc_lhs_type typeLevelMode hs_ty exp_kind
-
-tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType
-tc_lhs_type mode (L span ty) exp_kind
-  = setSrcSpanA span $
-    tc_hs_type mode ty exp_kind
-
-tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
--- See Note [Bidirectional type checking]
-
-tc_hs_type mode (HsParTy _ ty)   exp_kind = tc_lhs_type mode ty exp_kind
-tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind
-tc_hs_type _ ty@(HsBangTy _ bang _) _
-    -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),
-    -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of
-    -- bangs are invalid, so fail. (#7210, #14761)
-    = failWith $ TcRnUnexpectedAnnotation ty bang
-tc_hs_type _ ty@(HsRecTy {})      _
-      -- Record types (which only show up temporarily in constructor
-      -- signatures) should have been removed by now
-    = failWithTc $ TcRnIllegalRecordSyntax ty
-
--- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'.
--- Here we get rid of it and add the finalizers to the global environment
--- while capturing the local environment.
---
--- See Note [Delaying modFinalizers in untyped splices].
-tc_hs_type mode (HsSpliceTy (HsUntypedSpliceTop mod_finalizers ty) _)
-           exp_kind
-  = do addModFinalizersWithLclEnv mod_finalizers
-       tc_lhs_type mode ty exp_kind
-
-tc_hs_type _ (HsSpliceTy (HsUntypedSpliceNested n) s) _ = pprPanic "tc_hs_type: invalid nested splice" (pprUntypedSplice True (Just n) s)
-
----------- Functions and applications
-tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind
-  = tc_fun_type mode mult ty1 ty2 exp_kind
-
-tc_hs_type mode (HsOpTy _ _ ty1 (L _ op) ty2) exp_kind
-  | op `hasKey` unrestrictedFunTyConKey
-  = tc_fun_type mode (HsUnrestrictedArrow noHsUniTok) ty1 ty2 exp_kind
-
---------- Foralls
-tc_hs_type mode (HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind
-  = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $
-                            tc_lhs_type mode ty exp_kind
-                 -- Pass on the mode from the type, to any wildcards
-                 -- in kind signatures on the forall'd variables
-                 -- e.g.      f :: _ -> Int -> forall (a :: _). blah
-                 -- Why exp_kind?  See Note [Body kind of a HsForAllTy]
-
-       -- Do not kind-generalise here!  See Note [Kind generalisation]
-
-       ; return (mkForAllTys tv_bndrs ty') }
-
-tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind
-  | null (unLoc ctxt)
-  = tc_lhs_type mode rn_ty exp_kind
-
-  -- See Note [Body kind of a HsQualTy]
-  | isConstraintLikeKind exp_kind
-  = do { ctxt' <- tc_hs_context mode ctxt
-       ; ty'   <- tc_lhs_type mode rn_ty constraintKind
-       ; return (tcMkDFunPhiTy ctxt' ty') }
-
-  | otherwise
-  = do { ctxt' <- tc_hs_context mode ctxt
-
-       ; ek <- newOpenTypeKind  -- The body kind (result of the function) can
-                                -- be TYPE r, for any r, hence newOpenTypeKind
-       ; ty' <- tc_lhs_type mode rn_ty ek
-       ; checkExpectedKind (unLoc rn_ty) (tcMkPhiTy ctxt' ty')
-                           liftedTypeKind exp_kind }
-
---------- Lists, arrays, and tuples
-tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind
-  = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind
-       ; checkWiredInTyCon listTyCon
-       ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }
-
--- See Note [Distinguishing tuple kinds] in GHC.Hs.Type
--- See Note [Inferring tuple kinds]
-tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind
-     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)
-  | Just tup_sort <- tupKindSort_maybe exp_kind
-  = traceTc "tc_hs_type tuple" (ppr hs_tys) >>
-    tc_tuple rn_ty mode tup_sort hs_tys exp_kind
-  | otherwise
-  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)
-       ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys
-       ; kinds <- mapM zonkTcType kinds
-           -- Infer each arg type separately, because errors can be
-           -- confusing if we give them a shared kind.  Eg #7410
-           -- (Either Int, Int), we do not want to get an error saying
-           -- "the second argument of a tuple should have kind *->*"
-
-       ; let (arg_kind, tup_sort)
-               = case [ (k,s) | k <- kinds
-                              , Just s <- [tupKindSort_maybe k] ] of
-                    ((k,s) : _) -> (k,s)
-                    [] -> (liftedTypeKind, BoxedTuple)
-         -- In the [] case, it's not clear what the kind is, so guess *
-
-       ; tys' <- sequence [ setSrcSpanA loc $
-                            checkExpectedKind hs_ty ty kind arg_kind
-                          | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]
-
-       ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }
-
-
-tc_hs_type mode rn_ty@(HsTupleTy _ HsUnboxedTuple tys) exp_kind
-  = tc_tuple rn_ty mode UnboxedTuple tys exp_kind
-
-tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind
-  = do { let arity = length hs_tys
-       ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys
-       ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds
-       ; let arg_reps = map kindRep arg_kinds
-             arg_tys  = arg_reps ++ tau_tys
-             sum_ty   = mkTyConApp (sumTyCon arity) arg_tys
-             sum_kind = unboxedSumKind arg_reps
-       ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind
-       }
-
---------- Promoted lists and tuples
-tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind
-  = do { tks <- mapM (tc_infer_lhs_type mode) tys
-       ; (taus', kind) <- unifyKinds tys tks
-       ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')
-       ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind }
-  where
-    mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]
-    mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k]
-
-tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind
-  -- using newMetaKindVar means that we force instantiations of any polykinded
-  -- types. At first, I just used tc_infer_lhs_type, but that led to #11255.
-  = do { ks   <- replicateM arity newMetaKindVar
-       ; taus <- zipWithM (tc_lhs_type mode) tys ks
-       ; let kind_con   = tupleTyCon           Boxed arity
-             ty_con     = promotedTupleDataCon Boxed arity
-             tup_k      = mkTyConApp kind_con ks
-       ; checkTupSize arity
-       ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }
-  where
-    arity = length tys
-
---------- Constraint types
-tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind
-  = do { massert (isTypeLevel (mode_tyki mode))
-       ; ty' <- tc_lhs_type mode ty liftedTypeKind
-       ; let n' = mkStrLitTy $ hsIPNameFS n
-       ; ipClass <- tcLookupClass ipClassName
-       ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty'])
-                           constraintKind exp_kind }
-
-tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind
-  -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't
-  -- have to handle it in 'coreView'
-  = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind
-
---------- Literals
-tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind
-  = do { checkWiredInTyCon naturalTyCon
-       ; checkExpectedKind rn_ty (mkNumLitTy n) naturalTy exp_kind }
-
-tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind
-  = do { checkWiredInTyCon typeSymbolKindCon
-       ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }
-tc_hs_type _ rn_ty@(HsTyLit _ (HsCharTy _ c)) exp_kind
-  = do { checkWiredInTyCon charTyCon
-       ; checkExpectedKind rn_ty (mkCharLitTy c) charTy exp_kind }
-
---------- Wildcards
-
-tc_hs_type mode ty@(HsWildCardTy _)        ek
-  = tcAnonWildCardOcc NoExtraConstraint mode ty ek
-
---------- Potentially kind-polymorphic types: call the "up" checker
--- See Note [Future-proofing the type checker]
-tc_hs_type mode ty@(HsTyVar {})            ek = tc_infer_hs_type_ek mode ty ek
-tc_hs_type mode ty@(HsAppTy {})            ek = tc_infer_hs_type_ek mode ty ek
-tc_hs_type mode ty@(HsAppKindTy{})         ek = tc_infer_hs_type_ek mode ty ek
-tc_hs_type mode ty@(HsOpTy {})             ek = tc_infer_hs_type_ek mode ty ek
-tc_hs_type mode ty@(HsKindSig {})          ek = tc_infer_hs_type_ek mode ty ek
-tc_hs_type mode ty@(XHsType {})            ek = tc_infer_hs_type_ek mode ty ek
-
-{-
-Note [Variable Specificity and Forall Visibility]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A HsForAllTy contains an HsForAllTelescope to denote the visibility of the forall
-binder. Furthermore, each invisible type variable binder also has a
-Specificity. Together, these determine the variable binders (ForAllTyFlag) for each
-variable in the generated ForAllTy type.
-
-This table summarises this relation:
-----------------------------------------------------------------------------
-| User-written type         HsForAllTelescope   Specificity        ForAllTyFlag
-|---------------------------------------------------------------------------
-| f :: forall a. type       HsForAllInvis       SpecifiedSpec      Specified
-| f :: forall {a}. type     HsForAllInvis       InferredSpec       Inferred
-| f :: forall a -> type     HsForAllVis         SpecifiedSpec      Required
-| f :: forall {a} -> type   HsForAllVis         InferredSpec       /
-|   This last form is nonsensical and is thus rejected.
-----------------------------------------------------------------------------
-
-For more information regarding the interpretation of the resulting ForAllTyFlag, see
-Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep".
--}
-
-------------------------------------------
-tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult
-tc_mult mode ty = tc_lhs_type mode (arrowToHsType ty) multiplicityTy
-------------------------------------------
-tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind
-            -> TcM TcType
-tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of
-  TypeLevel ->
-    do { traceTc "tc_fun_type" (ppr ty1 $$ ppr ty2)
-       ; arg_k <- newOpenTypeKind
-       ; res_k <- newOpenTypeKind
-       ; ty1'  <- tc_lhs_type mode ty1 arg_k
-       ; ty2'  <- tc_lhs_type mode ty2 res_k
-       ; mult' <- tc_mult mode mult
-       ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2)
-                           (tcMkVisFunTy mult' ty1' ty2')
-                           liftedTypeKind exp_kind }
-  KindLevel ->  -- no representation polymorphism in kinds. yet.
-    do { ty1'  <- tc_lhs_type mode ty1 liftedTypeKind
-       ; ty2'  <- tc_lhs_type mode ty2 liftedTypeKind
-       ; mult' <- tc_mult mode mult
-       ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2)
-                           (tcMkVisFunTy mult' ty1' ty2')
-                           liftedTypeKind exp_kind }
-
-{- Note [Skolem escape and forall-types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See also Note [Checking telescopes].
-
-Consider
-  f :: forall a. (forall kb (b :: kb). Proxy '[a, b]) -> ()
-
-The Proxy '[a,b] forces a and b to have the same kind.  But a's
-kind must be bound outside the 'forall a', and hence escapes.
-We discover this by building an implication constraint for
-each forall.  So the inner implication constraint will look like
-    forall kb (b::kb).  kb ~ ka
-where ka is a's kind.  We can't unify these two, /even/ if ka is
-unification variable, because it would be untouchable inside
-this inner implication.
-
-That's what the pushLevelAndCaptureConstraints, plus subsequent
-buildTvImplication/emitImplication is all about, when kind-checking
-HsForAllTy.
-
-Note that
-
-* We don't need to /simplify/ the constraints here
-  because we aren't generalising. We just capture them.
-
-* We can't use emitResidualTvConstraint, because that has a fast-path
-  for empty constraints.  We can't take that fast path here, because
-  we must do the bad-telescope check even if there are no inner wanted
-  constraints. See Note [Checking telescopes] in
-  GHC.Tc.Types.Constraint.  Lacking this check led to #16247.
--}
-
-{- *********************************************************************
-*                                                                      *
-                Tuples
-*                                                                      *
-********************************************************************* -}
-
----------------------------
-tupKindSort_maybe :: TcKind -> Maybe TupleSort
-tupKindSort_maybe k
-  | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'
-  | Just k'      <- coreView k          = tupKindSort_maybe k'
-  | isConstraintKind k                  = Just ConstraintTuple
-  | tcIsLiftedTypeKind k                = Just BoxedTuple
-  | otherwise                           = Nothing
-
-tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType
-tc_tuple rn_ty mode tup_sort tys exp_kind
-  = do { arg_kinds <- case tup_sort of
-           BoxedTuple      -> return (replicate arity liftedTypeKind)
-           UnboxedTuple    -> replicateM arity newOpenTypeKind
-           ConstraintTuple -> return (replicate arity constraintKind)
-       ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds
-       ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind }
-  where
-    arity   = length tys
-
-finish_tuple :: HsType GhcRn
-             -> TupleSort
-             -> [TcType]    -- ^ argument types
-             -> [TcKind]    -- ^ of these kinds
-             -> TcKind      -- ^ expected kind of the whole tuple
-             -> TcM TcType
-finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do
-  traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind)
-  case tup_sort of
-    ConstraintTuple
-      |  [tau_ty] <- tau_tys
-         -- Drop any uses of 1-tuple constraints here.
-         -- See Note [Ignore unary constraint tuples]
-      -> check_expected_kind tau_ty constraintKind
-      |  otherwise
-      -> do let tycon = cTupleTyCon arity
-            checkCTupSize arity
-            check_expected_kind (mkTyConApp tycon tau_tys) constraintKind
-    BoxedTuple -> do
-      let tycon = tupleTyCon Boxed arity
-      checkTupSize arity
-      checkWiredInTyCon tycon
-      check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind
-    UnboxedTuple -> do
-      let tycon    = tupleTyCon Unboxed arity
-          tau_reps = map kindRep tau_kinds
-          -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
-          arg_tys  = tau_reps ++ tau_tys
-          res_kind = unboxedTupleKind tau_reps
-      checkTupSize arity
-      check_expected_kind (mkTyConApp tycon arg_tys) res_kind
-  where
-    arity = length tau_tys
-    check_expected_kind ty act_kind =
-      checkExpectedKind rn_ty ty act_kind exp_kind
-
-{-
-Note [Ignore unary constraint tuples]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in
-GHC.Builtin.Types) but does *not* provide unary constraint tuples. Why? First,
-recall the definition of a unary tuple data type:
-
-  data Solo a = Solo a
-
-Note that `Solo a` is *not* the same thing as `a`, since Solo is boxed and
-lazy. Therefore, the presence of `Solo` matters semantically. On the other
-hand, suppose we had a unary constraint tuple:
-
-  class a => Solo% a
-
-This compiles down a newtype (i.e., a cast) in Core, so `Solo% a` is
-semantically equivalent to `a`. Therefore, a 1-tuple constraint would have
-no user-visible impact, nor would it allow you to express anything that
-you couldn't otherwise.
-
-We could simply add Solo% for consistency with tuples (Solo) and unboxed
-tuples (Solo#), but that would require even more magic to wire in another
-magical class, so we opt not to do so. We must be careful, however, since
-one can try to sneak in uses of unary constraint tuples through Template
-Haskell, such as in this program (from #17511):
-
-  f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)]
-                       (ConT ''String)))
-  -- f :: Solo% (Show Int) => String
-  f = "abc"
-
-This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1,
-and since it is used in a Constraint position, GHC will attempt to treat
-it as thought it were a constraint tuple, which can potentially lead to
-trouble if one attempts to look up the name of a constraint tuple of arity
-1 (as it won't exist). To avoid this trouble, we simply take any unary
-constraint tuples discovered when typechecking and drop them—i.e., treat
-"Solo% a" as though the user had written "a". This is always safe to do
-since the two constraints should be semantically equivalent.
--}
-
-{- *********************************************************************
-*                                                                      *
-                Type applications
-*                                                                      *
-********************************************************************* -}
-
-splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])
-splitHsAppTys hs_ty
-  | is_app hs_ty = Just (go (noLocA hs_ty) [])
-  | otherwise    = Nothing
-  where
-    is_app :: HsType GhcRn -> Bool
-    is_app (HsAppKindTy {})        = True
-    is_app (HsAppTy {})            = True
-    is_app (HsOpTy _ _ _ (L _ op) _) = not (op `hasKey` unrestrictedFunTyConKey)
-      -- I'm not sure why this funTyConKey test is necessary
-      -- Can it even happen?  Perhaps for   t1 `(->)` t2
-      -- but then maybe it's ok to treat that like a normal
-      -- application rather than using the special rule for HsFunTy
-    is_app (HsTyVar {})            = True
-    is_app (HsParTy _ (L _ ty))    = is_app ty
-    is_app _                       = False
-
-    go :: LHsType GhcRn
-       -> [HsArg (LHsType GhcRn) (LHsKind GhcRn)]
-       -> (LHsType GhcRn,
-           [HsArg (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp
-    go (L _  (HsAppTy _ f a))      as = go f (HsValArg a : as)
-    go (L _  (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as)
-    go (L sp (HsParTy _ f))        as = go f (HsArgPar (locA sp) : as)
-    go (L _  (HsOpTy _ prom l op@(L sp _) r)) as
-      = ( L (na2la sp) (HsTyVar noAnn prom op)
-        , HsValArg l : HsValArg r : as )
-    go f as = (f, as)
-
----------------------------
-tcInferTyAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)
--- Version of tc_infer_lhs_type specialised for the head of an
--- application. In particular, for a HsTyVar (which includes type
--- constructors, it does not zoom off into tcInferTyApps and family
--- saturation
-tcInferTyAppHead _ (L _ (HsTyVar _ _ (L _ tv)))
-  = tcTyVar tv
-tcInferTyAppHead mode ty
-  = tc_infer_lhs_type mode ty
-
----------------------------
--- | Apply a type of a given kind to a list of arguments. This instantiates
--- invisible parameters as necessary. Always consumes all the arguments,
--- using matchExpectedFunKind as necessary.
--- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.-
--- These kinds should be used to instantiate invisible kind variables;
--- they come from an enclosing class for an associated type/data family.
---
--- tcInferTyApps also arranges to saturate any trailing invisible arguments
---   of a type-family application, which is usually the right thing to do
--- tcInferTyApps_nosat does not do this saturation; it is used only
---   by ":kind" in GHCi
-tcInferTyApps, tcInferTyApps_nosat
-    :: TcTyMode
-    -> LHsType GhcRn        -- ^ Function (for printing only)
-    -> TcType               -- ^ Function
-    -> [LHsTypeArg GhcRn]   -- ^ Args
-    -> TcM (TcType, TcKind) -- ^ (f args, result kind)
-tcInferTyApps mode hs_ty fun hs_args
-  = do { (f_args, res_k) <- tcInferTyApps_nosat mode hs_ty fun hs_args
-       ; saturateFamApp f_args res_k }
-
-tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args
-  = do { traceTc "tcInferTyApps {" (ppr orig_hs_ty $$ ppr orig_hs_args)
-       ; (f_args, res_k) <- go_init 1 fun orig_hs_args
-       ; traceTc "tcInferTyApps }" (ppr f_args <+> dcolon <+> ppr res_k)
-       ; return (f_args, res_k) }
-  where
-
-    -- go_init just initialises the auxiliary
-    -- arguments of the 'go' loop
-    go_init n fun all_args
-      = go n fun empty_subst fun_ki all_args
-      where
-        fun_ki = typeKind fun
-           -- We do (typeKind fun) here, even though the caller
-           -- knows the function kind, to absolutely guarantee
-           -- INVARIANT for 'go'
-           -- Note that in a typical application (F t1 t2 t3),
-           -- the 'fun' is just a TyCon, so typeKind is fast
-
-        empty_subst = mkEmptySubst $ mkInScopeSet $
-                      tyCoVarsOfType fun_ki
-
-    go :: Int             -- The # of the next argument
-       -> TcType          -- Function applied to some args
-       -> Subst        -- Applies to function kind
-       -> TcKind          -- Function kind
-       -> [LHsTypeArg GhcRn]    -- Un-type-checked args
-       -> TcM (TcType, TcKind)  -- Result type and its kind
-    -- INVARIANT: in any call (go n fun subst fun_ki args)
-    --               typeKind fun  =  subst(fun_ki)
-    -- So the 'subst' and 'fun_ki' arguments are simply
-    -- there to avoid repeatedly calling typeKind.
-    --
-    -- Reason for INVARIANT: to support the Purely Kinded Type Invariant
-    -- it's important that if fun_ki has a forall, then so does
-    -- (typeKind fun), because the next thing we are going to do
-    -- is apply 'fun' to an argument type.
-
-    -- Dispatch on all_args first, for performance reasons
-    go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of
-
-      ---------------- No user-written args left. We're done!
-      ([], _) -> return (fun, substTy subst fun_ki)
-
-      ---------------- HsArgPar: We don't care about parens here
-      (HsArgPar _ : args, _) -> go n fun subst fun_ki args
-
-      ---------------- HsTypeArg: a kind application (fun @ki)
-      (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) ->
-        case ki_binder of
-
-        -- FunTy with PredTy on LHS, or ForAllTy with Inferred
-        Named (Bndr _ Inferred)          -> instantiate ki_binder inner_ki
-        Anon _ af | isInvisibleFunArg af -> instantiate ki_binder inner_ki
-
-        Named (Bndr _ Specified) ->  -- Visible kind application
-          do { traceTc "tcInferTyApps (vis kind app)"
-                       (vcat [ ppr ki_binder, ppr hs_ki_arg
-                             , ppr (piTyBinderType ki_binder)
-                             , ppr subst ])
-
-             ; let exp_kind = substTy subst $ piTyBinderType ki_binder
-             ; arg_mode <- mkHoleMode KindLevel HM_VTA
-                   -- HM_VKA: see Note [Wildcards in visible kind application]
-             ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $
-                         tc_lhs_type arg_mode hs_ki_arg exp_kind
-
-             ; traceTc "tcInferTyApps (vis kind app)" (ppr exp_kind)
-             ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg
-             ; go (n+1) fun' subst' inner_ki hs_args }
-
-        -- Attempted visible kind application (fun @ki), but fun_ki is
-        --   forall k -> blah   or   k1 -> k2
-        -- So we need a normal application.  Error.
-        _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki
-
-      -- No binder; try applying the substitution, or fail if that's not possible
-      (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $
-                                           ty_app_err ki_arg substed_fun_ki
-
-      ---------------- HsValArg: a normal argument (fun ty)
-      (HsValArg arg : args, Just (ki_binder, inner_ki))
-        -- next binder is invisible; need to instantiate it
-        | isInvisiblePiTyBinder ki_binder   -- FunTy with constraint on LHS;
-                                            -- or ForAllTy with Inferred or Specified
-         -> instantiate ki_binder inner_ki
-
-        -- "normal" case
-        | otherwise
-         -> do { traceTc "tcInferTyApps (vis normal app)"
-                          (vcat [ ppr ki_binder
-                                , ppr arg
-                                , ppr (piTyBinderType ki_binder)
-                                , ppr subst ])
-                ; let exp_kind = substTy subst $ piTyBinderType ki_binder
-                ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $
-                          tc_lhs_type mode arg exp_kind
-                ; traceTc "tcInferTyApps (vis normal app) 2" (ppr exp_kind)
-                ; (subst', fun') <- mkAppTyM subst fun ki_binder arg'
-                ; go (n+1) fun' subst' inner_ki args }
-
-          -- no binder; try applying the substitution, or infer another arrow in fun kind
-      (HsValArg _ : _, Nothing)
-        -> try_again_after_substing_or $
-           do { let arrows_needed = n_initial_val_args all_args
-              ; co <- matchExpectedFunKind (HsTypeRnThing $ unLoc hs_ty) arrows_needed substed_fun_ki
-
-              ; fun' <- zonkTcType (fun `mkCastTy` co)
-                     -- This zonk is essential, to expose the fruits
-                     -- of matchExpectedFunKind to the 'go' loop
-
-              ; traceTc "tcInferTyApps (no binder)" $
-                   vcat [ ppr fun <+> dcolon <+> ppr fun_ki
-                        , ppr arrows_needed
-                        , ppr co
-                        , ppr fun' <+> dcolon <+> ppr (typeKind fun')]
-              ; go_init n fun' all_args }
-                -- Use go_init to establish go's INVARIANT
-      where
-        instantiate ki_binder inner_ki
-          = do { traceTc "tcInferTyApps (need to instantiate)"
-                         (vcat [ ppr ki_binder, ppr subst])
-               ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder
-               ; go n (mkAppTy fun arg') subst' inner_ki all_args }
-                 -- Because tcInvisibleTyBinder instantiate ki_binder,
-                 -- the kind of arg' will have the same shape as the kind
-                 -- of ki_binder.  So we don't need mkAppTyM here.
-
-        try_again_after_substing_or fallthrough
-          | not (isEmptyTCvSubst subst)
-          = go n fun zapped_subst substed_fun_ki all_args
-          | otherwise
-          = fallthrough
-
-        zapped_subst   = zapSubst subst
-        substed_fun_ki = substTy subst fun_ki
-        hs_ty          = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args)
-
-    n_initial_val_args :: [HsArg tm ty] -> Arity
-    -- Count how many leading HsValArgs we have
-    n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args
-    n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args
-    n_initial_val_args _                    = 0
-
-    ty_app_err arg ty
-      = failWith $ TcRnInvalidVisibleKindArgument arg ty
-
-mkAppTyM :: Subst
-         -> TcType -> PiTyBinder    -- fun, plus its top-level binder
-         -> TcType                  -- arg
-         -> TcM (Subst, TcType)  -- Extended subst, plus (fun arg)
--- Precondition: the application (fun arg) is well-kinded after zonking
---               That is, the application makes sense
---
--- Precondition: for (mkAppTyM subst fun bndr arg)
---       typeKind fun  =  Pi bndr. body
---  That is, fun always has a ForAllTy or FunTy at the top
---           and 'bndr' is fun's pi-binder
---
--- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type
---                invariant, then so does the result type (fun arg)
---
--- We do not require that
---    typeKind arg = tyVarKind (binderVar bndr)
--- This must be true after zonking (precondition 1), but it's not
--- required for the (PKTI).
-mkAppTyM subst fun ki_binder arg
-  | -- See Note [mkAppTyM]: Nasty case 2
-    TyConApp tc args <- fun
-  , isTypeSynonymTyCon tc
-  , args `lengthIs` (tyConArity tc - 1)
-  , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym
-  = do { arg'  <- zonkTcType  arg
-       ; args' <- zonkTcTypes args
-       ; let subst' = case ki_binder of
-                        Anon {}           -> subst
-                        Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg'
-       ; return (subst', mkTyConApp tc (args' ++ [arg'])) }
-
-
-mkAppTyM subst fun (Anon {}) arg
-   = return (subst, mk_app_ty fun arg)
-
-mkAppTyM subst fun (Named (Bndr tv _)) arg
-  = do { arg' <- if isTrickyTvBinder tv
-                 then -- See Note [mkAppTyM]: Nasty case 1
-                      zonkTcType arg
-                 else return     arg
-       ; return ( extendTvSubstAndInScope subst tv arg'
-                , mk_app_ty fun arg' ) }
-
-mk_app_ty :: TcType -> TcType -> TcType
--- This function just adds an ASSERT for mkAppTyM's precondition
-mk_app_ty fun arg
-  = assertPpr (isPiTy fun_kind)
-              (ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg) $
-    mkAppTy fun arg
-  where
-    fun_kind = typeKind fun
-
-isTrickyTvBinder :: TcTyVar -> Bool
--- NB: isTrickyTvBinder is just an optimisation
--- It would be absolutely sound to return True always
-isTrickyTvBinder tv = isPiTy (tyVarKind tv)
-
-{- Note [The Purely Kinded Type Invariant (PKTI)]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-During type inference, we maintain this invariant
-
- (PKTI) It is legal to call 'typeKind' on any Type ty,
-        on any sub-term of ty, /without/ zonking ty
-
-        Moreover, any such returned kind
-        will itself satisfy (PKTI)
-
-By "legal to call typeKind" we mean "typeKind will not crash".
-The way in which typeKind can crash is in applications
-    (a t1 t2 .. tn)
-if 'a' is a type variable whose kind doesn't have enough arrows
-or foralls.  (The crash is in piResultTys.)
-
-The loop in tcInferTyApps has to be very careful to maintain the (PKTI).
-For example, suppose
-    kappa is a unification variable
-    We have already unified kappa := Type
-      yielding    co :: Refl (Type -> Type)
-    a :: kappa
-then consider the type
-    (a Int)
-If we call typeKind on that, we'll crash, because the (un-zonked)
-kind of 'a' is just kappa, not an arrow kind.  So we must zonk first.
-
-So the type inference engine is very careful when building applications.
-This happens in tcInferTyApps. Suppose we are kind-checking the type (a Int),
-where (a :: kappa).  Then in tcInferApps we'll run out of binders on
-a's kind, so we'll call matchExpectedFunKind, and unify
-   kappa := kappa1 -> kappa2,  with evidence co :: kappa ~ (kappa1 ~ kappa2)
-At this point we must zonk the function type to expose the arrrow, so
-that (a Int) will satisfy (PKTI).
-
-The absence of this caused #14174 and #14520.
-
-The calls to mkAppTyM is the other place we are very careful; see Note [mkAppTyM].
-
-Wrinkle around FunTy:
-Note that the PKTI does *not* guarantee anything about the shape of FunTys.
-Specifically, when we have (FunTy vis mult arg res), it should be the case
-that arg :: TYPE rr1 and res :: TYPE rr2, for some rr1 and rr2. However, we
-might not have this. Example: if the user writes (a -> b), then we might
-invent a :: kappa1 and b :: kappa2. We soon will check whether kappa1 ~ TYPE rho1
-(for some rho1), and that will lead to kappa1 := TYPE rho1 (ditto for kappa2).
-However, when we build the FunTy, we might not have zonked `a`, and so the
-FunTy will be built without being able to purely extract the RuntimeReps.
-
-Because the PKTI does not guarantee that the RuntimeReps are available in a FunTy,
-we must be aware of this when splitting: splitTyConApp and splitAppTy will *not*
-split a FunTy if the RuntimeReps are not available. See also Note [Decomposing FunTy]
-in GHC.Tc.Solver.Canonical.
-
-Note [mkAppTyM]
-~~~~~~~~~~~~~~~
-mkAppTyM is trying to guarantee the Purely Kinded Type Invariant
-(PKTI) for its result type (fun arg).  There are two ways it can go wrong:
-
-* Nasty case 1: forall types (polykinds/T14174a)
-    T :: forall (p :: *->*). p Int -> p Bool
-  Now kind-check (T x), where x::kappa.
-  Well, T and x both satisfy the PKTI, but
-     T x :: x Int -> x Bool
-  and (x Int) does /not/ satisfy the PKTI.
-
-* Nasty case 2: type synonyms
-    type S f a = f a
-  Even though (S ff aa) would satisfy the (PKTI) if S was a data type
-  (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI)
-  if S is a type synonym, because the /expansion/ of (S ff aa) is
-  (ff aa), and /that/ does not satisfy (PKTI).  E.g. perhaps
-  (ff :: kappa), where 'kappa' has already been unified with (*->*).
-
-  We check for nasty case 2 on the final argument of a type synonym.
-
-Notice that in both cases the trickiness only happens if the
-bound variable has a pi-type.  Hence isTrickyTvBinder.
--}
-
-
-saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind)
--- Precondition for (saturateFamApp ty kind):
---     typeKind ty = kind
---
--- If 'ty' is an unsaturated family application with trailing
--- invisible arguments, instantiate them.
--- See Note [saturateFamApp]
-
-saturateFamApp ty kind
-  | Just (tc, args) <- tcSplitTyConApp_maybe ty
-  , tyConMustBeSaturated tc
-  , let n_to_inst = tyConArity tc - length args
-  = do { (extra_args, ki') <- tcInstInvisibleTyBindersN n_to_inst kind
-       ; return (ty `mkAppTys` extra_args, ki') }
-  | otherwise
-  = return (ty, kind)
-
-{- Note [saturateFamApp]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   type family F :: Either j k
-   type instance F @Type = Right Maybe
-   type instance F @Type = Right Either```
-
-Then F :: forall {j,k}. Either j k
-
-The two type instances do a visible kind application that instantiates
-'j' but not 'k'.  But we want to end up with instances that look like
-  type instance F @Type @(*->*) = Right @Type @(*->*) Maybe
-
-so that F has arity 2.  We must instantiate that trailing invisible
-binder. In general, Invisible binders precede Specified and Required,
-so this is only going to bite for apparently-nullary families.
-
-Note that
-  type family F2 :: forall k. k -> *
-is quite different and really does have arity 0.
-
-It's not just type instances where we need to saturate those
-unsaturated arguments: see #11246.  Hence doing this in tcInferApps.
--}
-
-appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn
-appTypeToArg f []                       = f
-appTypeToArg f (HsValArg arg    : args) = appTypeToArg (mkHsAppTy f arg) args
-appTypeToArg f (HsArgPar _      : args) = appTypeToArg f                 args
-appTypeToArg f (HsTypeArg l arg : args)
-  = appTypeToArg (mkHsAppKindTy l f arg) args
-
-
-{- *********************************************************************
-*                                                                      *
-                checkExpectedKind
-*                                                                      *
-********************************************************************* -}
-
--- | This instantiates invisible arguments for the type being checked if it must
--- be saturated and is not yet saturated. It then calls and uses the result
--- from checkExpectedKindX to build the final type
-checkExpectedKind :: HasDebugCallStack
-                  => HsType GhcRn       -- ^ type we're checking (for printing)
-                  -> TcType             -- ^ type we're checking
-                  -> TcKind             -- ^ the known kind of that type
-                  -> TcKind             -- ^ the expected kind
-                  -> TcM TcType
--- Just a convenience wrapper to save calls to 'ppr'
-checkExpectedKind hs_ty ty act_kind exp_kind
-  = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind)
-
-       ; (new_args, act_kind') <- tcInstInvisibleTyBindersN n_to_inst act_kind
-
-       ; let origin = TypeEqOrigin { uo_actual   = act_kind'
-                                   , uo_expected = exp_kind
-                                   , uo_thing    = Just (HsTypeRnThing hs_ty)
-                                   , uo_visible  = True } -- the hs_ty is visible
-
-       ; traceTc "checkExpectedKindX" $
-         vcat [ ppr hs_ty
-              , text "act_kind':" <+> ppr act_kind'
-              , text "exp_kind:" <+> ppr exp_kind ]
-
-       ; let res_ty = ty `mkAppTys` new_args
-
-       ; if act_kind' `tcEqType` exp_kind
-         then return res_ty  -- This is very common
-         else do { co_k <- uType KindLevel origin act_kind' exp_kind
-                 ; traceTc "checkExpectedKind" (vcat [ ppr act_kind
-                                                     , ppr exp_kind
-                                                     , ppr co_k ])
-                ; return (res_ty `mkCastTy` co_k) } }
-    where
-      -- We need to make sure that both kinds have the same number of implicit
-      -- foralls out front. If the actual kind has more, instantiate accordingly.
-      -- Otherwise, just pass the type & kind through: the errors are caught
-      -- in unifyType.
-      n_exp_invis_bndrs = invisibleTyBndrCount exp_kind
-      n_act_invis_bndrs = invisibleTyBndrCount act_kind
-      n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs
-
----------------------------
-
-tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]
-tcHsContext Nothing    = return []
-tcHsContext (Just cxt) = tc_hs_context typeLevelMode cxt
-
-tcLHsPredType :: LHsType GhcRn -> TcM PredType
-tcLHsPredType pred = tc_lhs_pred typeLevelMode pred
-
-tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType]
-tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt)
-
-tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType
-tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind
-
----------------------------
-tcTyVar :: Name -> TcM (TcType, TcKind)
--- See Note [Type checking recursive type and class declarations]
--- in GHC.Tc.TyCl
--- This does not instantiate. See Note [Do not always instantiate eagerly in types]
-tcTyVar name         -- Could be a tyvar, a tycon, or a datacon
-  = do { traceTc "lk1" (ppr name)
-       ; thing <- tcLookup name
-       ; case thing of
-           ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)
-
-           -- See Note [Recursion through the kinds]
-           (tcTyThingTyCon_maybe -> Just tc) -- TyCon or TcTyCon
-             -> return (mkTyConTy tc, tyConKind tc)
-
-           AGlobal (AConLike (RealDataCon dc))
-             -> do { data_kinds <- xoptM LangExt.DataKinds
-                   ; unless (data_kinds || specialPromotedDc dc) $
-                       promotionErr name NoDataKindsDC
-                   ; when (isFamInstTyCon (dataConTyCon dc)) $
-                       -- see #15245
-                       promotionErr name FamDataConPE
-                   ; let (_, _, _, theta, _, _) = dataConFullSig dc
-                   ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta))
-                   ; case dc_theta_illegal_constraint theta of
-                       Just pred -> promotionErr name $
-                                    ConstrainedDataConPE pred
-                       Nothing   -> pure ()
-                   ; let tc = promoteDataCon dc
-                   ; return (mkTyConApp tc [], tyConKind tc) }
-
-           APromotionErr err -> promotionErr name err
-
-           _  -> wrongThingErr "type" thing name }
-  where
-    -- We cannot promote a data constructor with a context that contains
-    -- constraints other than equalities, so error if we find one.
-    -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep
-    dc_theta_illegal_constraint :: ThetaType -> Maybe PredType
-    dc_theta_illegal_constraint = find (not . isEqPred)
-
-{-
-Note [Recursion through the kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider these examples
-
-Ticket #11554:
-  data P (x :: k) = Q
-  data A :: Type where
-    MkA :: forall (a :: A). P a -> A
-
-Ticket #12174
-  data V a
-  data T = forall (a :: T). MkT (V a)
-
-The type is recursive (which is fine) but it is recursive /through the
-kinds/.  In earlier versions of GHC this caused a loop in the compiler
-(to do with knot-tying) but there is nothing fundamentally wrong with
-the code (kinds are types, and the recursive declarations are OK). But
-it's hard to distinguish "recursion through the kinds" from "recursion
-through the types". Consider this (also #11554):
-
-  data PB k (x :: k) = Q
-  data B :: Type where
-    MkB :: P B a -> B
-
-Here the occurrence of B is not obviously in a kind position.
-
-So now GHC allows all these programs.  #12081 and #15942 are other
-examples.
-
-Note [Body kind of a HsForAllTy]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The body of a forall is usually a type, but in principle
-there's no reason to prohibit *unlifted* types.
-In fact, GHC can itself construct a function with an
-unboxed tuple inside a for-all (via CPR analysis; see
-typecheck/should_compile/tc170).
-
-Moreover in instance heads we get forall-types with
-kind Constraint.
-
-It's tempting to check that the body kind is either * or #. But this is
-wrong. For example:
-
-  class C a b
-  newtype N = Mk Foo deriving (C a)
-
-We're doing newtype-deriving for C. But notice how `a` isn't in scope in
-the predicate `C a`. So we quantify, yielding `forall a. C a` even though
-`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but
-convenient. Bottom line: don't check for * or # here.
-
-Note [Body kind of a HsQualTy]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If ctxt is non-empty, the HsQualTy really is a /function/, so the
-kind of the result really is '*', and in that case the kind of the
-body-type can be lifted or unlifted.
-
-However, consider
-    instance Eq a => Eq [a] where ...
-or
-    f :: (Eq a => Eq [a]) => blah
-Here both body-kind of the HsQualTy is Constraint rather than *.
-Rather crudely we tell the difference by looking at exp_kind. It's
-very convenient to typecheck instance types like any other HsSigType.
-
-Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's
-better to reject in checkValidType.  If we say that the body kind
-should be '*' we risk getting TWO error messages, one saying that Eq
-[a] doesn't have kind '*', and one saying that we need a Constraint to
-the left of the outer (=>).
-
-How do we figure out the right body kind?  Well, it's a bit of a
-kludge: I just look at the expected kind.  If it's Constraint, we
-must be in this instance situation context. It's a kludge because it
-wouldn't work if any unification was involved to compute that result
-kind -- but it isn't.  (The true way might be to use the 'mode'
-parameter, but that seemed like a sledgehammer to crack a nut.)
-
-Note [Inferring tuple kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,
-we try to figure out whether it's a tuple of kind * or Constraint.
-  Step 1: look at the expected kind
-  Step 2: infer argument kinds
-
-If after Step 2 it's not clear from the arguments that it's
-Constraint, then it must be *.  Once having decided that we re-check
-the arguments to give good error messages in
-  e.g.  (Maybe, Maybe)
-
-Note that we will still fail to infer the correct kind in this case:
-
-  type T a = ((a,a), D a)
-  type family D :: Constraint -> Constraint
-
-While kind checking T, we do not yet know the kind of D, so we will default the
-kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.
-
-Note [Desugaring types]
-~~~~~~~~~~~~~~~~~~~~~~~
-The type desugarer is phase 2 of dealing with HsTypes.  Specifically:
-
-  * It transforms from HsType to Type
-
-  * It zonks any kinds.  The returned type should have no mutable kind
-    or type variables (hence returning Type not TcType):
-      - any unconstrained kind variables are defaulted to (Any *) just
-        as in GHC.Tc.Utils.Zonk.
-      - there are no mutable type variables because we are
-        kind-checking a type
-    Reason: the returned type may be put in a TyCon or DataCon where
-    it will never subsequently be zonked.
-
-You might worry about nested scopes:
-        ..a:kappa in scope..
-            let f :: forall b. T '[a,b] -> Int
-In this case, f's type could have a mutable kind variable kappa in it;
-and we might then default it to (Any *) when dealing with f's type
-signature.  But we don't expect this to happen because we can't get a
-lexically scoped type variable with a mutable kind variable in it.  A
-delicate point, this.  If it becomes an issue we might need to
-distinguish top-level from nested uses.
-
-Moreover
-  * it cannot fail,
-  * it does no unifications
-  * it does no validity checking, except for structural matters, such as
-        (a) spurious ! annotations.
-        (b) a class used as a type
-
-Note [Kind of a type splice]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider these terms, each with TH type splice inside:
-     [| e1 :: Maybe $(..blah..) |]
-     [| e2 :: $(..blah..) |]
-When kind-checking the type signature, we'll kind-check the splice
-$(..blah..); we want to give it a kind that can fit in any context,
-as if $(..blah..) :: forall k. k.
-
-In the e1 example, the context of the splice fixes kappa to *.  But
-in the e2 example, we'll desugar the type, zonking the kind unification
-variables as we go.  When we encounter the unconstrained kappa, we
-want to default it to '*', not to (Any *).
-
--}
-
-addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a
-        -- Wrap a context around only if we want to show that contexts.
-        -- Omit invisible ones and ones user's won't grok
-addTypeCtxt (L _ (HsWildCardTy _)) thing = thing   -- "In the type '_'" just isn't helpful.
-addTypeCtxt (L _ ty) thing
-  = addErrCtxt doc thing
-  where
-    doc = text "In the type" <+> quotes (ppr ty)
-
-
-{- *********************************************************************
-*                                                                      *
-                Type-variable binders
-*                                                                      *
-********************************************************************* -}
-
-bindNamedWildCardBinders :: [Name]
-                         -> ([(Name, TcTyVar)] -> TcM a)
-                         -> TcM a
--- Bring into scope the /named/ wildcard binders.  Remember that
--- plain wildcards _ are anonymous and dealt with by HsWildCardTy
--- Soe Note [The wildcard story for types] in GHC.Hs.Type
-bindNamedWildCardBinders wc_names thing_inside
-  = do { wcs <- mapM newNamedWildTyVar wc_names
-       ; let wc_prs = wc_names `zip` wcs
-       ; tcExtendNameTyVarEnv wc_prs $
-         thing_inside wc_prs }
-
-newNamedWildTyVar :: Name -> TcM TcTyVar
--- ^ New unification variable '_' for a wildcard
-newNamedWildTyVar _name   -- Currently ignoring the "_x" wildcard name used in the type
-  = do { kind <- newMetaKindVar
-       ; details <- newMetaDetails TauTv
-       ; wc_name <- newMetaTyVarName (fsLit "w")   -- See Note [Wildcard names]
-       ; let tyvar = mkTcTyVar wc_name kind details
-       ; traceTc "newWildTyVar" (ppr tyvar)
-       ; return tyvar }
-
----------------------------
-tcAnonWildCardOcc :: IsExtraConstraint
-                  -> TcTyMode -> HsType GhcRn -> Kind -> TcM TcType
-tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) })
-                  ty exp_kind
-    -- hole_lvl: see Note [Checking partial type signatures]
-    --           esp the bullet on nested forall types
-  = do { kv_details <- newTauTvDetailsAtLevel hole_lvl
-       ; kv_name    <- newMetaTyVarName (fsLit "k")
-       ; wc_details <- newTauTvDetailsAtLevel hole_lvl
-       ; wc_name    <- newMetaTyVarName (fsLit wc_nm)
-       ; let kv      = mkTcTyVar kv_name liftedTypeKind kv_details
-             wc_kind = mkTyVarTy kv
-             wc_tv   = mkTcTyVar wc_name wc_kind wc_details
-
-       ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes)
-       ; when emit_holes $
-         emitAnonTypeHole is_extra wc_tv
-         -- Why the 'when' guard?
-         -- See Note [Wildcards in visible kind application]
-
-       -- You might think that this would always just unify
-       -- wc_kind with exp_kind, so we could avoid even creating kv
-       -- But the level numbers might not allow that unification,
-       -- so we have to do it properly (T14140a)
-       ; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind }
-  where
-     -- See Note [Wildcard names]
-     wc_nm = case hole_mode of
-               HM_Sig      -> "w"
-               HM_FamPat   -> "_"
-               HM_VTA      -> "w"
-               HM_TyAppPat -> "_"
-
-     emit_holes = case hole_mode of
-                     HM_Sig     -> True
-                     HM_FamPat  -> False
-                     HM_VTA     -> False
-                     HM_TyAppPat -> False
-
-tcAnonWildCardOcc is_extra _ _ _
--- mode_holes is Nothing. This means we have an anonymous wildcard
--- in an unexpected place. The renamer rejects these wildcards in 'checkAnonWildcard',
--- but it is possible for a wildcard to be introduced by a Template Haskell splice,
--- as per #15433. To account for this, we throw a generic catch-all error message.
-  = failWith $ TcRnIllegalWildcardInType Nothing reason
-    where
-      reason =
-        case is_extra of
-          YesExtraConstraint ->
-            ExtraConstraintWildcardNotAllowed
-              SoleExtraConstraintWildcardNotAllowed
-          NoExtraConstraint  ->
-            WildcardsNotAllowedAtAll
-
-{- Note [Wildcard names]
-~~~~~~~~~~~~~~~~~~~~~~~~
-So we hackily use the mode_holes flag to control the name used
-for wildcards:
-
-* For proper holes (whether in a visible type application (VTA) or no),
-  we rename the '_' to 'w'. This is so that we see variables like 'w0'
-  or 'w1' in error messages, a vast improvement upon '_0' and '_1'. For
-  example, we prefer
-       Found type wildcard ‘_’ standing for ‘w0’
-  over
-       Found type wildcard ‘_’ standing for ‘_1’
-
-  Even in the VTA case, where we do not emit an error to be printed, we
-  want to do the renaming, as the variables may appear in other,
-  non-wildcard error messages.
-
-* However, holes in the left-hand sides of type families ("type
-  patterns") stand for type variables which we do not care to name --
-  much like the use of an underscore in an ordinary term-level
-  pattern. When we spot these, we neither wish to generate an error
-  message nor to rename the variable.  We don't rename the variable so
-  that we can pretty-print a type family LHS as, e.g.,
-    F _ Int _ = ...
-  and not
-     F w1 Int w2 = ...
-
-  See also Note [Wildcards in family instances] in
-  GHC.Rename.Module. The choice of HM_FamPat is made in
-  tcFamTyPats. There is also some unsavory magic, relying on that
-  underscore, in GHC.Core.Coercion.tidyCoAxBndrsForUser.
-
-Note [Wildcards in visible kind application]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are cases where users might want to pass in a wildcard as a visible kind
-argument, for instance:
-
-data T :: forall k1 k2. k1 → k2 → Type where
-  MkT :: T a b
-x :: T @_ @Nat False n
-x = MkT
-
-So we should allow '@_' without emitting any hole constraints, and
-regardless of whether PartialTypeSignatures is enabled or not. But how
-would the typechecker know which '_' is being used in VKA and which is
-not when it calls emitNamedTypeHole in
-tcHsPartialSigType on all HsWildCardBndrs?  The solution is to neither
-rename nor include unnamed wildcards in HsWildCardBndrs, but instead
-give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc.
-
-And whenever we see a '@', we set mode_holes to HM_VKA, so that
-we do not call emitAnonTypeHole in tcAnonWildCardOcc.
-See related Note [Wildcards in visible type application] here and
-Note [The wildcard story for types] in GHC.Hs.Type
--}
-
-{- *********************************************************************
-*                                                                      *
-             Kind inference for type declarations
-*                                                                      *
-********************************************************************* -}
-
--- See Note [kcCheckDeclHeader vs kcInferDeclHeader]
-data InitialKindStrategy
-  = InitialKindCheck SAKS_or_CUSK
-  | InitialKindInfer
-
--- Does the declaration have a standalone kind signature (SAKS) or a complete
--- user-specified kind (CUSK)?
-data SAKS_or_CUSK
-  = SAKS Kind  -- Standalone kind signature, fully zonked! (zonkTcTypeToType)
-  | CUSK       -- Complete user-specified kind (CUSK)
-
-instance Outputable SAKS_or_CUSK where
-  ppr (SAKS k) = text "SAKS" <+> ppr k
-  ppr CUSK = text "CUSK"
-
--- See Note [kcCheckDeclHeader vs kcInferDeclHeader]
-kcDeclHeader
-  :: InitialKindStrategy
-  -> Name              -- ^ of the thing being checked
-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
-  -> LHsQTyVars GhcRn  -- ^ Binders in the header
-  -> TcM ContextKind   -- ^ The result kind
-  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon
-kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig
-kcDeclHeader InitialKindInfer = kcInferDeclHeader
-
-{- Note [kcCheckDeclHeader vs kcInferDeclHeader]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind
-of a type constructor.
-
-* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that
-  case, find the full, final, poly-kinded kind of the TyCon.  It's very like a
-  term-level binding where we have a complete type signature for the function.
-
-* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a
-  CUSK. Find a monomorphic kind, with unification variables in it; they will be
-  generalised later.  It's very like a term-level binding where we do not have a
-  type signature (or, more accurately, where we have a partial type signature),
-  so we infer the type and generalise.
--}
-
-------------------------------
-kcCheckDeclHeader
-  :: SAKS_or_CUSK
-  -> Name              -- ^ of the thing being checked
-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
-  -> LHsQTyVars GhcRn  -- ^ Binders in the header
-  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature
-  -> TcM PolyTcTyCon   -- ^ A suitably-kinded generalized TcTyCon
-kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig
-kcCheckDeclHeader CUSK       = kcCheckDeclHeader_cusk
-
-kcCheckDeclHeader_cusk
-  :: Name              -- ^ of the thing being checked
-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
-  -> LHsQTyVars GhcRn  -- ^ Binders in the header
-  -> TcM ContextKind   -- ^ The result kind
-  -> TcM PolyTcTyCon   -- ^ A suitably-kinded generalized TcTyCon
-kcCheckDeclHeader_cusk name flav
-              (HsQTvs { hsq_ext = kv_ns
-                      , hsq_explicit = hs_tvs }) kc_res_ki
-  -- CUSK case
-  -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl
-  = addTyConFlavCtxt name flav $
-    do { skol_info <- mkSkolemInfo skol_info_anon
-       ; (tclvl, wanted, (scoped_kvs, (tc_tvs, res_kind)))
-           <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_cusk" $
-              bindImplicitTKBndrs_Q_Skol skol_info kv_ns                      $
-              bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_tvs           $
-              newExpectedKind =<< kc_res_ki
-
-           -- Now, because we're in a CUSK,
-           -- we quantify over the mentioned kind vars
-       ; let spec_req_tkvs = scoped_kvs ++ tc_tvs
-             all_kinds     = res_kind : map tyVarKind spec_req_tkvs
-
-       ; candidates <- candidateQTyVarsOfKinds all_kinds
-             -- 'candidates' are all the variables that we are going to
-             -- skolemise and then quantify over.  We do not include spec_req_tvs
-             -- because they are /already/ skolems
-
-       ; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars $
-                     candidates `delCandidates` spec_req_tkvs
-                     -- NB: 'inferred' comes back sorted in dependency order
-
-       ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs  -- scoped_kvs and tc_tvs are skolems,
-       ; tc_tvs     <- mapM zonkTyCoVarKind tc_tvs      -- so zonkTyCoVarKind suffices
-       ; res_kind   <- zonkTcType           res_kind
-
-       ; let mentioned_kv_set = candidateKindVars candidates
-             specified        = scopedSort scoped_kvs
-                                -- NB: maintain the L-R order of scoped_kvs
-
-             all_tcbs =  mkNamedTyConBinders Inferred  inferred
-                      ++ mkNamedTyConBinders Specified specified
-                      ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs
-
-       -- Eta expand if necessary; we are building a PolyTyCon
-       ; (eta_tcbs, res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs res_kind
-
-       ; let all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)
-             final_tcbs = all_tcbs `chkAppend` eta_tcbs
-             tycon = mkTcTyCon name final_tcbs res_kind all_tv_prs
-                               True -- it is generalised
-                               flav
-
-       ; reportUnsolvedEqualities skol_info (binderVars final_tcbs)
-                                  tclvl wanted
-
-         -- If the ordering from
-         -- Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl
-         -- doesn't work, we catch it here, before an error cascade
-       ; checkTyConTelescope tycon
-
-       ; traceTc "kcCheckDeclHeader_cusk " $
-         vcat [ text "name" <+> ppr name
-              , text "candidates" <+> ppr candidates
-              , text "mentioned_kv_set" <+> ppr mentioned_kv_set
-              , text "kv_ns" <+> ppr kv_ns
-              , text "hs_tvs" <+> ppr hs_tvs
-              , text "scoped_kvs" <+> ppr scoped_kvs
-              , text "spec_req_tvs" <+> pprTyVars spec_req_tkvs
-              , text "all_kinds" <+> ppr all_kinds
-              , text "tc_tvs" <+> pprTyVars tc_tvs
-              , text "res_kind" <+> ppr res_kind
-              , text "inferred" <+> ppr inferred
-              , text "specified" <+> ppr specified
-              , text "final_tcbs" <+> ppr final_tcbs
-              , text "mkTyConKind final_tc_bndrs res_kind"
-                <+> ppr (mkTyConKind final_tcbs res_kind)
-              , text "all_tv_prs" <+> ppr all_tv_prs ]
-
-       ; return tycon }
-  where
-    skol_info_anon = TyConSkol flav name
-    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind
-              | otherwise            = AnyKind
-
--- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and
--- other kinds).
---
--- This function does not do telescope checking.
-kcInferDeclHeader
-  :: Name              -- ^ of the thing being checked
-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
-  -> LHsQTyVars GhcRn
-  -> TcM ContextKind   -- ^ The result kind
-  -> TcM MonoTcTyCon   -- ^ A suitably-kinded non-generalized TcTyCon
-kcInferDeclHeader name flav
-              (HsQTvs { hsq_ext = kv_ns
-                      , hsq_explicit = hs_tvs }) kc_res_ki
-  -- No standalone kind signature and no CUSK.
-  -- See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl
-  = addTyConFlavCtxt name flav $
-    do { (scoped_kvs, (tc_tvs, res_kind))
-           -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?
-           -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl
-           <- bindImplicitTKBndrs_Q_Tv kv_ns            $
-              bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $
-              newExpectedKind =<< kc_res_ki
-              -- Why "_Tv" not "_Skol"? See third wrinkle in
-              -- Note [Inferring kinds for type declarations] in GHC.Tc.TyCl,
-
-       ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they
-               -- might unify with kind vars in other types in a mutually
-               -- recursive group.
-               -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl
-
-             tc_binders = mkAnonTyConBinders tc_tvs
-               -- Also, note that tc_binders has the tyvars from only the
-               -- user-written tyvarbinders. See S1 in Note [How TcTyCons work]
-               -- in GHC.Tc.TyCl
-               --
-               -- mkAnonTyConBinder: see Note [No polymorphic recursion]
-
-             all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)
-               -- NB: bindExplicitTKBndrs_Q_Tv does not clone;
-               --     ditto Implicit
-               -- See Note [Cloning for type variable binders]
-
-             tycon = mkTcTyCon name tc_binders res_kind all_tv_prs
-                               False -- not yet generalised
-                               flav
-
-       ; traceTc "kcInferDeclHeader: not-cusk" $
-         vcat [ ppr name, ppr kv_ns, ppr hs_tvs
-              , ppr scoped_kvs
-              , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ]
-       ; return tycon }
-  where
-    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind
-              | otherwise            = AnyKind
-
--- | Kind-check a declaration header against a standalone kind signature.
--- See Note [kcCheckDeclHeader_sig]
-kcCheckDeclHeader_sig
-  :: Kind              -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType)
-  -> Name              -- ^ of the thing being checked
-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
-  -> LHsQTyVars GhcRn  -- ^ Binders in the header
-  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature
-  -> TcM PolyTcTyCon   -- ^ A suitably-kinded, fully generalised TcTyCon
--- Postcondition to (kcCheckDeclHeader_sig sig_kind n f hs_tvs kc_res_ki):
---   kind(returned PolyTcTyCon) = sig_kind
---
-kcCheckDeclHeader_sig sig_kind name flav
-          (HsQTvs { hsq_ext      = implicit_nms
-                  , hsq_explicit = hs_tv_bndrs }) kc_res_ki
-  = addTyConFlavCtxt name flav $
-    do { skol_info <- mkSkolemInfo (TyConSkol flav name)
-       ; (sig_tcbs :: [TcTyConBinder], sig_res_kind :: Kind)
-             <- splitTyConKind skol_info emptyInScopeSet
-                               (map getOccName hs_tv_bndrs) sig_kind
-
-       ; traceTc "kcCheckDeclHeader_sig {" $
-           vcat [ text "sig_kind:" <+> ppr sig_kind
-                , text "sig_tcbs:" <+> ppr sig_tcbs
-                , text "sig_res_kind:" <+> ppr sig_res_kind ]
-
-       ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, (extra_tcbs, tycon_res_kind))))
-           <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $  -- #16687
-              bindImplicitTKBndrs_Q_Tv implicit_nms                $  -- Q means don't clone
-              matchUpSigWithDecl sig_tcbs sig_res_kind hs_tv_bndrs $ \ excess_sig_tcbs sig_res_kind ->
-              do { -- Kind-check the result kind annotation, if present:
-                   --    data T a b :: res_ki where ...
-                   --               ^^^^^^^^^
-                   -- We do it here because at this point the environment has been
-                   -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'.
-                 ; ctx_k <- kc_res_ki
-
-                 -- Work out extra_arity, the number of extra invisible binders from
-                 -- the kind signature that should be part of the TyCon's arity.
-                 -- See Note [Arity inference in kcCheckDeclHeader_sig]
-                 ; let n_invis_tcbs = countWhile isInvisibleTyConBinder excess_sig_tcbs
-                       invis_arity = case ctx_k of
-                          AnyKind    -> n_invis_tcbs -- No kind signature, so make all the invisible binders
-                                                     -- the signature into part of the arity of the TyCon
-                          OpenKind   -> n_invis_tcbs -- Result kind is (TYPE rr), so again make all the
-                                                     -- invisible binders part of the arity of the TyCon
-                          TheKind ki -> 0 `max` (n_invis_tcbs - invisibleTyBndrCount ki)
-
-                 ; let (invis_tcbs, resid_tcbs) = splitAt invis_arity excess_sig_tcbs
-                 ; let sig_res_kind' = mkTyConKind resid_tcbs sig_res_kind
-
-                 ; traceTc "kcCheckDeclHeader_sig 2" $ vcat [ ppr excess_sig_tcbs
-                                                            , ppr invis_arity, ppr invis_tcbs
-                                                            , ppr n_invis_tcbs ]
-
-                 -- Unify res_ki (from the type declaration) with the residual kind from
-                 -- the kind signature. Don't forget to apply the skolemising 'subst' first.
-                 ; case ctx_k of
-                      AnyKind -> return ()   -- No signature
-                      _ -> do { res_ki <- newExpectedKind ctx_k
-                              ; discardResult (unifyKind Nothing sig_res_kind' res_ki) }
-
-                 -- Add more binders for data/newtype, so the result kind has no arrows
-                 -- See Note [Datatype return kinds]
-                 ; if null resid_tcbs || not (needsEtaExpansion flav)
-                   then return (invis_tcbs,      sig_res_kind')
-                   else return (excess_sig_tcbs, sig_res_kind)
-          }
-
-
-        -- Check that there are no unsolved equalities
-        ; let all_tcbs = skol_tcbs ++ extra_tcbs
-        ; reportUnsolvedEqualities skol_info (binderVars all_tcbs) tclvl wanted
-
-        -- Check that distinct binders map to distinct tyvars (see #20916). For example
-        --    type T :: k -> k -> Type
-        --    data T (a::p) (b::q) = ...
-        -- Here p and q both map to the same kind variable k.  We don't allow this
-        -- so we must check that they are distinct.  A similar thing happens
-        -- in GHC.Tc.TyCl.swizzleTcTyConBinders during inference.
-        ; implicit_tvs <- zonkTcTyVarsToTcTyVars implicit_tvs
-        ; let implicit_prs = implicit_nms `zip` implicit_tvs
-        ; checkForDuplicateScopedTyVars implicit_prs
-
-        -- Swizzle the Names so that the TyCon uses the user-declared implicit names
-        -- E.g  type T :: k -> Type
-        --      data T (a :: j) = ....
-        -- We want the TyConBinders of T to be [j, a::j], not [k, a::k]
-        -- Why? So that the TyConBinders of the TyCon will lexically scope over the
-        -- associated types and methods of a class.
-        ; let swizzle_env = mkVarEnv (map swap implicit_prs)
-              (subst, swizzled_tcbs) = mapAccumL (swizzleTcb swizzle_env) emptySubst all_tcbs
-              swizzled_kind          = substTy subst tycon_res_kind
-              all_tv_prs             = mkTyVarNamePairs (binderVars swizzled_tcbs)
-
-        ; traceTc "kcCheckDeclHeader swizzle" $ vcat
-          [ text "implicit_prs = "  <+> ppr implicit_prs
-          , text "implicit_nms = "  <+> ppr implicit_nms
-          , text "hs_tv_bndrs = "  <+> ppr hs_tv_bndrs
-          , text "all_tcbs = "      <+> pprTyVars (binderVars all_tcbs)
-          , text "swizzled_tcbs = " <+> pprTyVars (binderVars swizzled_tcbs)
-          , text "tycon_res_kind =" <+> ppr tycon_res_kind
-          , text "swizzled_kind ="  <+> ppr swizzled_kind ]
-
-        -- Build the final, generalized PolyTcTyCon
-        -- NB: all_tcbs must bind the tyvars in the range of all_tv_prs
-        --     because the tv_prs is used when (say) typechecking the RHS of
-        --     a type synonym.
-        ; let tc = mkTcTyCon name swizzled_tcbs swizzled_kind all_tv_prs True flav
-
-        ; traceTc "kcCheckDeclHeader_sig }" $ vcat
-          [ text "tyConName = " <+> ppr (tyConName tc)
-          , text "sig_kind =" <+> debugPprType sig_kind
-          , text "tyConKind =" <+> debugPprType (tyConKind tc)
-          , text "tyConBinders = " <+> ppr (tyConBinders tc)
-          , text "tyConResKind" <+> debugPprType (tyConResKind tc)
-          ]
-        ; return tc }
-
-matchUpSigWithDecl
-  :: [TcTyConBinder]             -- TcTyConBinders (with skolem TcTyVars) from the separate kind signature
-  -> TcKind                      -- The tail end of the kind signature
-  -> [LHsTyVarBndr () GhcRn]     -- User-written binders in decl
-  -> ([TcTyConBinder] -> TcKind -> TcM a)  -- All user-written binders are in scope
-                                           --   Argument is excess TyConBinders and tail kind
-  -> TcM ( [TcTyConBinder]       -- Skolemised binders, with TcTyVars
-         , a )
--- See Note [Matching a kind signature with a declaration]
--- Invariant: Length of returned TyConBinders + length of excess TyConBinders
---            = length of incoming TyConBinders
-matchUpSigWithDecl sig_tcbs sig_res_kind hs_bndrs thing_inside
-  = go emptySubst sig_tcbs hs_bndrs
-  where
-    go subst tcbs []
-      = do { let (subst', tcbs') = substTyConBindersX subst tcbs
-           ; res <- thing_inside tcbs' (substTy subst' sig_res_kind)
-           ; return ([], res) }
-
-    go _ [] hs_bndrs
-      = failWithTc (TcRnTooManyBinders sig_res_kind hs_bndrs)
-
-    go subst (tcb : tcbs') hs_bndrs
-      | Bndr tv vis <- tcb
-      , isVisibleTcbVis vis
-      , (L _ hs_bndr : hs_bndrs') <- hs_bndrs  -- hs_bndrs is non-empty
-      = -- Visible TyConBinder, so match up with the hs_bndrs
-        do { let tv' = updateTyVarKind (substTy subst) $
-                       setTyVarName tv (getName hs_bndr)
-                   -- Give the skolem the Name of the HsTyVarBndr, so that if it
-                   -- appears in an error message it has a name and binding site
-                   -- that come from the type declaration, not the kind signature
-                 subst' = extendTCvSubstWithClone subst tv tv'
-           ; tc_hs_bndr hs_bndr (tyVarKind tv')
-           ; (tcbs', res) <- tcExtendTyVarEnv [tv'] $
-                             go subst' tcbs' hs_bndrs'
-           ; return (Bndr tv' vis : tcbs', res) }
-
-      | otherwise
-      = -- Invisible TyConBinder, so do not consume one of the hs_bndrs
-        do { let (subst', tcb') = substTyConBinderX subst tcb
-           ; (tcbs', res) <- go subst' tcbs' hs_bndrs
-                   -- NB: pass on hs_bndrs unchanged; we do not consume a
-                   --     HsTyVarBndr for an invisible TyConBinder
-           ; return (tcb' : tcbs', res) }
-
-    tc_hs_bndr :: HsTyVarBndr () GhcRn -> TcKind -> TcM ()
-    tc_hs_bndr (UserTyVar _ _ _) _
-      = return ()
-    tc_hs_bndr (KindedTyVar _ _ (L _ hs_nm) lhs_kind) expected_kind
-      = do { sig_kind <- tcLHsKindSig (TyVarBndrKindCtxt hs_nm) lhs_kind
-           ; discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]
-             unifyKind (Just (NameThing hs_nm)) sig_kind expected_kind }
-
-substTyConBinderX :: Subst -> TyConBinder -> (Subst, TyConBinder)
-substTyConBinderX subst (Bndr tv vis)
-  = (subst', Bndr tv' vis)
-  where
-    (subst', tv') = substTyVarBndr subst tv
-
-substTyConBindersX :: Subst -> [TyConBinder] -> (Subst, [TyConBinder])
-substTyConBindersX = mapAccumL substTyConBinderX
-
-swizzleTcb :: VarEnv Name -> Subst -> TyConBinder -> (Subst, TyConBinder)
-swizzleTcb swizzle_env subst (Bndr tv vis)
-  = (subst', Bndr tv2 vis)
-  where
-    subst' = extendTCvSubstWithClone subst tv tv2
-    tv1 = updateTyVarKind (substTy subst) tv
-    tv2 = case lookupVarEnv swizzle_env tv of
-             Just user_name -> setTyVarName tv1 user_name
-             Nothing        -> tv1
-    -- NB: the SrcSpan on an implicitly-bound name deliberately spans
-    -- the whole declaration. e.g.
-    --    data T (a :: k) (b :: Type -> k) = ....
-    -- There is no single binding site for 'k'.
-    -- See Note [Source locations for implicitly bound type variables]
-    -- in GHC.Tc.Rename.HsType
-
-{- See Note [kcCheckDeclHeader_sig]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given a kind signature 'sig_kind' and a declaration header,
-kcCheckDeclHeader_sig verifies that the declaration conforms to the
-signature. The end result is a PolyTcTyCon 'tc' such that:
-  tyConKind tc == sig_kind
-
-Basic plan is this:
-  * splitTyConKind: Take the Kind from the separate kind signature, and
-    decompose it all the way to a [TyConBinder] and a Kind in the corner.
-
-    NB: these TyConBinders contain TyVars, not TcTyVars.
-
-  * matchUpSigWithDecl: match the [TyConBinder] from the signature with
-    the [LHsTyVarBndr () GhcRn] from the declaration.  The latter are the
-    explicit, user-written binders.  e.g.
-        data T (a :: k) b = ....
-    There may be more of the former than the latter, because the former
-    include invisible binders.  matchUpSigWithDecl uses isVisibleTcbVis
-    to decide which TyConBinders are visible.
-
-  * matchUpSigWithDecl also skolemises the [TyConBinder] to produce
-    a [TyConBinder], corresponding 1-1 with the consumed [TyConBinder].
-    Each new TyConBinder
-      - Uses the Name from the LHsTyVarBndr, if available, both because that's
-        what the user expects, and because the binding site accurately comes
-        from the data/type declaration.
-      - Uses a skolem TcTyVar.  We need these to allow unification.
-
-  * machUpSigWithDecl also unifies the user-supplied kind signature for each
-    LHsTyVarBndr with the kind that comes from the TyConBinder (itself coming
-    from the separate kind signature).
-
-  * Finally, kcCheckDeclHeader_sig unifies the return kind of the separate
-    signature with the kind signature (if any) in the data/type declaration.
-    E.g.
-           type S :: forall k. k -> k -> Type
-           type family S (a :: j) :: j -> Type
-    Here we match up the 'k ->' with (a :: j); and then must unify the leftover
-    part of the signature (k -> Type) with the kind signature of the decl,
-    (j -> Type).  This unification, done in kcCheckDeclHeader, needs TcTyVars.
-
-  * The tricky extra_arity part is described in
-    Note [Arity inference in kcCheckDeclHeader_sig]
-
-Note [Arity inference in kcCheckDeclHeader_sig]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider these declarations:
-  type family S1 :: forall k2. k1 -> k2 -> Type
-  type family S2 (a :: k1) (b :: k2) :: Type
-
-Both S1 and S2 can be given the same standalone kind signature:
-  type S1 :: forall k1 k2. k1 -> k2 -> Type
-  type S2 :: forall k1 k2. k1 -> k2 -> Type
-
-And, indeed, tyConKind S1 == tyConKind S2. However,
-tyConBinders and tyConResKind for S1 and S2 are different:
-
-  tyConBinders S1  ==  [spec k1]
-  tyConResKind S1  ==  forall k2. k1 -> k2 -> Type
-  tyConKind    S1  ==  forall k1 k2. k1 -> k2 -> Type
-
-  tyConBinders S2  ==  [spec k1, spec k2, anon-vis (a :: k1), anon-vis (b :: k2)]
-  tyConResKind S2  ==  Type
-  tyConKind    S1  ==  forall k1 k2. k1 -> k2 -> Type
-
-This difference determines the /arity/:
-  tyConArity tc == length (tyConBinders tc)
-That is, the arity of S1 is 1, while the arity of S2 is 4.
-
-'kcCheckDeclHeader_sig' needs to infer the desired arity, to split the
-standalone kind signature into binders and the result kind. It does so
-in two rounds:
-
-1. matchUpSigWithDecl matches up
-   - the [TyConBinder] from (applying splitTyConKind to) the kind signature
-   - with the [LHsTyVarBndr] from the type declaration.
-   That may leave some excess TyConBinder: in the case of S2 there are
-   no excess TyConBinders, but in the case of S1 there are two (since
-   there are no LHsTYVarBndrs.
-
-2. Split off further TyConBinders (in the case of S1, one more) to
-   make it possible to unify the residual return kind with the
-   signature in the type declaration.  More precisely, split off such
-   enough invisible that the remainder of the standalone kind
-   signature and the user-written result kind signature have the same
-   number of invisible quantifiers.
-
-As another example consider the following declarations:
-
-    type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type
-    type family F a b
-
-    type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type
-    type family G a b :: forall r2. (r1, r2) -> Type
-
-For both F and G, the signature (after splitTyConKind) has
-  sig_tcbs :: [TyConBinder]
-    = [ anon-vis (@a_aBq), spec (@j_auA), anon-vis (@(b_aBr :: j_auA))
-      , spec (@k1_auB), spec (@k2_auC)
-      , anon-vis (@(c_aBs :: (k1_auB, k2_auC)))]
-
-matchUpSigWithDecl will consume the first three of these, passing on
-  excess_sig_tcbs
-    = [ spec (@k1_auB), spec (@k2_auC)
-      , anon-vis (@(c_aBs :: (k1_auB, k2_auC)))]
-
-For F, there is no result kind signature in the declaration for F, so
-we absorb all invisible binders into F's arity. The resulting arity of
-F is 3+2=5.
-
-Now, in the case of G, we have a result kind sig 'forall r2. (r2,r2)->Type'.
-This has one invisible binder, so we split of enough extra binders from
-our excess_sig_tcbs to leave just one to match 'r2'.
-
-    res_ki  =  forall    r2. (r1, r2) -> Type
-    kisig   =  forall k1 k2. (k1, k2) -> Type
-                     ^^^
-                     split off this one.
-
-The resulting arity of G is 3+1=4.
-
-Note [discardResult in kcCheckDeclHeader_sig]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We use 'unifyKind' to check inline kind annotations in declaration headers
-against the signature.
-
-  type T :: [i] -> Maybe j -> Type
-  data T (a :: [k1]) (b :: Maybe k2) :: Type where ...
-
-Here, we will unify:
-
-       [k1] ~ [i]
-  Maybe k2  ~ Maybe j
-      Type  ~ Type
-
-The end result is that we fill in unification variables k1, k2:
-
-    k1  :=  i
-    k2  :=  j
-
-We also validate that the user isn't confused:
-
-  type T :: Type -> Type
-  data T (a :: Bool) = ...
-
-This will report that (Type ~ Bool) failed to unify.
-
-Now, consider the following example:
-
-  type family Id a where Id x = x
-  type T :: Bool -> Type
-  type T (a :: Id Bool) = ...
-
-We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion.
-However, we are free to discard it, as the kind of 'T' is determined by the
-signature, not by the inline kind annotation:
-
-      we have   T ::    Bool -> Type
-  rather than   T :: Id Bool -> Type
-
-This (Id Bool) will not show up anywhere after we're done validating it, so we
-have no use for the produced coercion.
--}
-
-{- Note [No polymorphic recursion]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Should this kind-check?
-  data T ka (a::ka) b  = MkT (T Type           Int   Bool)
-                             (T (Type -> Type) Maybe Bool)
-
-Notice that T is used at two different kinds in its RHS.  No!
-This should not kind-check.  Polymorphic recursion is known to
-be a tough nut.
-
-Previously, we laboriously (with help from the renamer)
-tried to give T the polymorphic kind
-   T :: forall ka -> ka -> kappa -> Type
-where kappa is a unification variable, even in the inferInitialKinds
-phase (which is what kcInferDeclHeader is all about).  But
-that is dangerously fragile (see the ticket).
-
-Solution: make kcInferDeclHeader give T a straightforward
-monomorphic kind, with no quantification whatsoever. That's why
-we use mkAnonTyConBinder for all arguments when figuring out
-tc_binders.
-
-But notice that (#16322 comment:3)
-
-* The algorithm successfully kind-checks this declaration:
-    data T2 ka (a::ka) = MkT2 (T2 Type a)
-
-  Starting with (inferInitialKinds)
-    T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> *
-  we get
-    kappa4 := kappa1   -- from the (a:ka) kind signature
-    kappa1 := Type     -- From application T2 Type
-
-  These constraints are soluble so generaliseTcTyCon gives
-    T2 :: forall (k::Type) -> k -> *
-
-  But now the /typechecking/ (aka desugaring, tcTyClDecl) phase
-  fails, because the call (T2 Type a) in the RHS is ill-kinded.
-
-  We'd really prefer all errors to show up in the kind checking
-  phase.
-
-* This algorithm still accepts (in all phases)
-     data T3 ka (a::ka) = forall b. MkT3 (T3 Type b)
-  although T3 is really polymorphic-recursive too.
-  Perhaps we should somehow reject that.
-
-Note [Kind variable ordering for associated types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What should be the kind of `T` in the following example? (#15591)
-
-  class C (a :: Type) where
-    type T (x :: f a)
-
-As per Note [Ordering of implicit variables] in GHC.Rename.HsType, we want to quantify
-the kind variables in left-to-right order of first occurrence in order to
-support visible kind application. But we cannot perform this analysis on just
-T alone, since its variable `a` actually occurs /before/ `f` if you consider
-the fact that `a` was previously bound by the parent class `C`. That is to say,
-the kind of `T` should end up being:
-
-  T :: forall a f. f a -> Type
-
-(It wouldn't necessarily be /wrong/ if the kind ended up being, say,
-forall f a. f a -> Type, but that would not be as predictable for users of
-visible kind application.)
-
-In contrast, if `T` were redefined to be a top-level type family, like `T2`
-below:
-
-  type family T2 (x :: f (a :: Type))
-
-Then `a` first appears /after/ `f`, so the kind of `T2` should be:
-
-  T2 :: forall f a. f a -> Type
-
-In order to make this distinction, we need to know (in kcCheckDeclHeader) which
-type variables have been bound by the parent class (if there is one). With
-the class-bound variables in hand, we can ensure that we always quantify
-these first.
--}
-
-
-{- *********************************************************************
-*                                                                      *
-             Expected kinds
-*                                                                      *
-********************************************************************* -}
-
--- | Describes the kind expected in a certain context.
-data ContextKind = TheKind TcKind   -- ^ a specific kind
-                 | AnyKind        -- ^ any kind will do
-                 | OpenKind       -- ^ something of the form @TYPE _@
-
------------------------
-newExpectedKind :: ContextKind -> TcM TcKind
-newExpectedKind (TheKind k)   = return k
-newExpectedKind AnyKind       = newMetaKindVar
-newExpectedKind OpenKind      = newOpenTypeKind
-
------------------------
-expectedKindInCtxt :: UserTypeCtxt -> ContextKind
--- Depending on the context, we might accept any kind (for instance, in a TH
--- splice), or only certain kinds (like in type signatures).
-expectedKindInCtxt (TySynCtxt _)   = AnyKind
-expectedKindInCtxt (GhciCtxt {})   = AnyKind
--- The types in a 'default' decl can have varying kinds
--- See Note [Extended defaults]" in GHC.Tc.Utils.Env
-expectedKindInCtxt DefaultDeclCtxt     = AnyKind
-expectedKindInCtxt DerivClauseCtxt     = AnyKind
-expectedKindInCtxt TypeAppCtxt         = AnyKind
-expectedKindInCtxt (ForSigCtxt _)      = TheKind liftedTypeKind
-expectedKindInCtxt (InstDeclCtxt {})   = TheKind constraintKind
-expectedKindInCtxt SpecInstCtxt        = TheKind constraintKind
-expectedKindInCtxt _                   = OpenKind
-
-
-{- *********************************************************************
-*                                                                      *
-          Scoped tyvars that map to the same thing
-*                                                                      *
-********************************************************************* -}
-
-checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM ()
--- Check for duplicates
--- E.g. data SameKind (a::k) (b::k)
---      data T (a::k1) (b::k2) c = MkT (SameKind a b) c
--- Here k1 and k2 start as TyVarTvs, and get unified with each other
--- If this happens, things get very confused later, so fail fast
---
--- In the CUSK case k1 and k2 are skolems so they won't unify;
--- but in the inference case (see generaliseTcTyCon),
--- and the type-sig case (see kcCheckDeclHeader_sig), they are
--- TcTyVars, so we must check.
-checkForDuplicateScopedTyVars scoped_prs
-  = unless (null err_prs) $
-    do { mapM_ report_dup err_prs; failM }
-  where
-    -------------- Error reporting ------------
-    err_prs :: [(Name,Name)]
-    err_prs = [ (n1,n2)
-              | prs :: NonEmpty (Name,TyVar) <- findDupsEq ((==) `on` snd) scoped_prs
-              , (n1,_) :| ((n2,_) : _) <- [NE.nubBy ((==) `on` fst) prs] ]
-              -- This nubBy avoids bogus error reports when we have
-              --    [("f", f), ..., ("f",f)....] in swizzle_prs
-              -- which happens with  class C f where { type T f }
-
-    report_dup :: (Name,Name) -> TcM ()
-    report_dup (n1,n2)
-      = setSrcSpan (getSrcSpan n2) $
-        addErrTc $ TcRnDifferentNamesForTyVar n1 n2
-
-
-{- *********************************************************************
-*                                                                      *
-             Bringing type variables into scope
-*                                                                      *
-********************************************************************* -}
-
---------------------------------------
---    HsForAllTelescope
---------------------------------------
-
-tcTKTelescope :: TcTyMode
-              -> HsForAllTelescope GhcRn
-              -> TcM a
-              -> TcM ([TcTyVarBinder], a)
--- A HsForAllTelescope comes only from a HsForAllTy,
--- an explicit, user-written forall type
-tcTKTelescope mode tele thing_inside = case tele of
-  HsForAllVis { hsf_vis_bndrs = bndrs }
-    -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs)))
-          ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode
-                                      , sm_tvtv = SMDSkolemTv skol_info }
-          ; (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside
-            -- req_tv_bndrs :: [VarBndr TyVar ()],
-            -- but we want [VarBndr TyVar ForAllTyFlag]
-          ; return (tyVarReqToBinders req_tv_bndrs, thing) }
-
-  HsForAllInvis { hsf_invis_bndrs = bndrs }
-    -> do { skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> bndrs)))
-          ; let skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode
-                                      , sm_tvtv = SMDSkolemTv skol_info }
-          ; (inv_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside
-            -- inv_tv_bndrs :: [VarBndr TyVar Specificity],
-            -- but we want [VarBndr TyVar ForAllTyFlag]
-          ; return (tyVarSpecToBinders inv_tv_bndrs, thing) }
-
---------------------------------------
---    HsOuterTyVarBndrs
---------------------------------------
-
-bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed
-                  => SkolemMode
-                  -> HsOuterTyVarBndrs flag GhcRn
-                  -> TcM a
-                  -> TcM (HsOuterTyVarBndrs flag GhcTc, a)
-bindOuterTKBndrsX skol_mode outer_bndrs thing_inside
-  = case outer_bndrs of
-      HsOuterImplicit{hso_ximplicit = imp_tvs} ->
-        do { (imp_tvs', thing) <- bindImplicitTKBndrsX skol_mode imp_tvs thing_inside
-           ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'}
-                    , thing) }
-      HsOuterExplicit{hso_bndrs = exp_bndrs} ->
-        do { (exp_tvs', thing) <- bindExplicitTKBndrsX skol_mode exp_bndrs thing_inside
-           ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'
-                                      , hso_bndrs     = exp_bndrs }
-                    , thing) }
-
----------------
-outerTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar]
--- The returned [TcTyVar] is not necessarily in dependency order
--- at least for the HsOuterImplicit case
-outerTyVars (HsOuterImplicit { hso_ximplicit = tvs })  = tvs
-outerTyVars (HsOuterExplicit { hso_xexplicit = tvbs }) = binderVars tvbs
-
----------------
-outerTyVarBndrs :: HsOuterTyVarBndrs Specificity GhcTc -> [InvisTVBinder]
-outerTyVarBndrs (HsOuterImplicit{hso_ximplicit = imp_tvs}) = [Bndr tv SpecifiedSpec | tv <- imp_tvs]
-outerTyVarBndrs (HsOuterExplicit{hso_xexplicit = exp_tvs}) = exp_tvs
-
----------------
-scopedSortOuter :: HsOuterTyVarBndrs flag GhcTc -> TcM (HsOuterTyVarBndrs flag GhcTc)
--- Sort any /implicit/ binders into dependency order
---     (zonking first so we can see the dependencies)
--- /Explicit/ ones are already in the right order
-scopedSortOuter (HsOuterImplicit{hso_ximplicit = imp_tvs})
-  = do { imp_tvs <- zonkAndScopedSort imp_tvs
-       ; return (HsOuterImplicit { hso_ximplicit = imp_tvs }) }
-scopedSortOuter bndrs@(HsOuterExplicit{})
-  = -- No need to dependency-sort (or zonk) explicit quantifiers
-    return bndrs
-
----------------
-bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn
-                       -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)
-bindOuterSigTKBndrs_Tv
-  = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv })
-
-bindOuterSigTKBndrs_Tv_M :: TcTyMode
-                         -> HsOuterSigTyVarBndrs GhcRn
-                         -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)
--- Do not push level; do not make implication constraint; use Tvs
--- Two major clients of this "bind-only" path are:
---    Note [Using TyVarTvs for kind-checking GADTs] in GHC.Tc.TyCl
---    Note [Checking partial type signatures]
-bindOuterSigTKBndrs_Tv_M mode
-  = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv
-                                 , sm_holes = mode_holes mode })
-
-bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn
-                            -> TcM a
-                            -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a)
-bindOuterFamEqnTKBndrs_Q_Tv hs_bndrs thing_inside
-  = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True
-                                 , sm_tvtv = SMDTyVarTv })
-                      hs_bndrs thing_inside
-    -- sm_clone=False: see Note [Cloning for type variable binders]
-
-bindOuterFamEqnTKBndrs :: SkolemInfo
-                       -> HsOuterFamEqnTyVarBndrs GhcRn
-                       -> TcM a
-                       -> TcM (HsOuterFamEqnTyVarBndrs GhcTc, a)
-bindOuterFamEqnTKBndrs skol_info
-  = bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True
-                                 , sm_tvtv = SMDSkolemTv skol_info })
-    -- sm_clone=False: see Note [Cloning for type variable binders]
-
----------------
-tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed
-               => SkolemInfo
-               -> HsOuterTyVarBndrs flag GhcRn
-               -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)
-tcOuterTKBndrs skol_info
-  = tcOuterTKBndrsX (smVanilla { sm_clone = False
-                               , sm_tvtv = SMDSkolemTv skol_info })
-                    skol_info
-  -- Do not clone the outer binders
-  -- See Note [Cloning for type variable binders] under "must not"
-
-tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed
-                => SkolemMode -> SkolemInfo
-                -> HsOuterTyVarBndrs flag GhcRn
-                -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)
--- Push level, capture constraints, make implication
-tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside
-  = case outer_bndrs of
-      HsOuterImplicit{hso_ximplicit = imp_tvs} ->
-        do { (imp_tvs', thing) <- tcImplicitTKBndrsX skol_mode skol_info imp_tvs thing_inside
-           ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'}
-                    , thing) }
-      HsOuterExplicit{hso_bndrs = exp_bndrs} ->
-        do { (exp_tvs', thing) <- tcExplicitTKBndrsX skol_mode exp_bndrs thing_inside
-           ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'
-                                      , hso_bndrs     = exp_bndrs }
-                    , thing) }
-
---------------------------------------
---    Explicit tyvar binders
---------------------------------------
-
-tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed
-                  => SkolemInfo
-                  -> [LHsTyVarBndr flag GhcRn]
-                  -> TcM a
-                  -> TcM ([VarBndr TyVar flag], a)
-tcExplicitTKBndrs skol_info
-  = tcExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info })
-
-tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed
-                   => SkolemMode
-                   -> [LHsTyVarBndr flag GhcRn]
-                   -> TcM a
-                   -> TcM ([VarBndr TyVar flag], a)
--- Push level, capture constraints, and emit an implication constraint.
--- The implication constraint has a ForAllSkol ic_info,
---   so that it is subject to a telescope test.
-tcExplicitTKBndrsX skol_mode bndrs thing_inside = case nonEmpty bndrs of
-    Nothing -> do
-       { res <- thing_inside
-       ; return ([], res) }
-
-    Just bndrs1 -> do
-       { (tclvl, wanted, (skol_tvs, res))
-             <- pushLevelAndCaptureConstraints $
-                bindExplicitTKBndrsX skol_mode bndrs $
-                thing_inside
-
-       -- Set up SkolemInfo for telescope test
-       ; let bndr_1 = NE.head bndrs1; bndr_n = NE.last bndrs1
-       ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn  (unLoc <$> bndrs)))
-         -- Notice that we use ForAllSkol here, ignoring the enclosing
-         -- skol_info unlike tcImplicitTKBndrs, because the bad-telescope
-         -- test applies only to ForAllSkol
-
-       ; setSrcSpan (combineSrcSpans (getLocA bndr_1) (getLocA bndr_n))
-       $ emitResidualTvConstraint skol_info (binderVars skol_tvs) tclvl wanted
-
-       ; return (skol_tvs, res) }
-
-----------------
--- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied
--- 'TcTyMode'.
-bindExplicitTKBndrs_Skol
-    :: (OutputableBndrFlag flag 'Renamed)
-    => SkolemInfo
-    -> [LHsTyVarBndr flag GhcRn]
-    -> TcM a
-    -> TcM ([VarBndr TyVar flag], a)
-
-bindExplicitTKBndrs_Tv
-    :: (OutputableBndrFlag flag 'Renamed)
-    => [LHsTyVarBndr flag GhcRn]
-    -> TcM a
-    -> TcM ([VarBndr TyVar flag], a)
-
-bindExplicitTKBndrs_Skol skol_info = bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_tvtv = SMDSkolemTv skol_info })
-bindExplicitTKBndrs_Tv   = bindExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv })
-   -- sm_clone: see Note [Cloning for type variable binders]
-
-bindExplicitTKBndrs_Q_Skol
-    :: SkolemInfo
-    -> ContextKind
-    -> [LHsTyVarBndr () GhcRn]
-    -> TcM a
-    -> TcM ([TcTyVar], a)
-
-bindExplicitTKBndrs_Q_Tv
-    :: ContextKind
-    -> [LHsTyVarBndr () GhcRn]
-    -> TcM a
-    -> TcM ([TcTyVar], a)
--- These do not clone: see Note [Cloning for type variable binders]
-bindExplicitTKBndrs_Q_Skol skol_info ctxt_kind hs_bndrs thing_inside
-  = mapFst binderVars $
-    bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True
-                                    , sm_kind = ctxt_kind, sm_tvtv = SMDSkolemTv skol_info })
-                         hs_bndrs thing_inside
-    -- sm_clone=False: see Note [Cloning for type variable binders]
-
-bindExplicitTKBndrs_Q_Tv  ctxt_kind hs_bndrs thing_inside
-  = mapFst binderVars $
-    bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True
-                                    , sm_tvtv = SMDTyVarTv, sm_kind = ctxt_kind })
-                         hs_bndrs thing_inside
-    -- sm_clone=False: see Note [Cloning for type variable binders]
-
-bindExplicitTKBndrsX :: (OutputableBndrFlag flag 'Renamed)
-    => SkolemMode
-    -> [LHsTyVarBndr flag GhcRn]
-    -> TcM a
-    -> TcM ([VarBndr TyVar flag], a)  -- Returned [TcTyVar] are in 1-1 correspondence
-                                      -- with the passed-in [LHsTyVarBndr]
-bindExplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind
-                                   , sm_holes = hole_info })
-                     hs_tvs thing_inside
-  = do { traceTc "bindExplicitTKBndrs" (ppr hs_tvs)
-       ; go hs_tvs }
-  where
-    tc_ki_mode = TcTyMode { mode_tyki = KindLevel, mode_holes = hole_info }
-                 -- Inherit the HoleInfo from the context
-
-    go [] = do { res <- thing_inside
-               ; return ([], res) }
-    go (L _ hs_tv : hs_tvs)
-       = do { lcl_env <- getLclTypeEnv
-            ; tv <- tc_hs_bndr lcl_env hs_tv
-            -- Extend the environment as we go, in case a binder
-            -- is mentioned in the kind of a later binder
-            --   e.g. forall k (a::k). blah
-            -- NB: tv's Name may differ from hs_tv's
-            -- See Note [Cloning for type variable binders]
-            ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $
-                           go hs_tvs
-            ; return (Bndr tv (hsTyVarBndrFlag hs_tv):tvs, res) }
-
-
-    tc_hs_bndr lcl_env (UserTyVar _ _ (L _ name))
-      | check_parent
-      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name
-      = return tv
-      | otherwise
-      = do { kind <- newExpectedKind ctxt_kind
-           ; newTyVarBndr skol_mode name kind }
-
-    tc_hs_bndr lcl_env (KindedTyVar _ _ (L _ name) lhs_kind)
-      | check_parent
-      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name
-      = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind
-           ; discardResult $
-             unifyKind (Just . NameThing $ name) kind (tyVarKind tv)
-                          -- This unify rejects:
-                          --    class C (m :: * -> *) where
-                          --      type F (m :: *) = ...
-           ; return tv }
-
-      | otherwise
-      = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind
-           ; newTyVarBndr skol_mode name kind }
-
-newTyVarBndr :: SkolemMode -> Name -> Kind -> TcM TcTyVar
-newTyVarBndr (SM { sm_clone = clone, sm_tvtv = tvtv }) name kind
-  = do { name <- case clone of
-              True -> do { uniq <- newUnique
-                         ; return (setNameUnique name uniq) }
-              False -> return name
-       ; details <- case tvtv of
-                 SMDTyVarTv  -> newMetaDetails TyVarTv
-                 SMDSkolemTv skol_info ->
-                  do { lvl <- getTcLevel
-                     ; return (SkolemTv skol_info lvl False) }
-       ; return (mkTcTyVar name kind details) }
-
---------------------------------------
---    Implicit tyvar binders
---------------------------------------
-
-tcImplicitTKBndrsX :: SkolemMode -> SkolemInfo
-                   -> [Name]
-                   -> TcM a
-                   -> TcM ([TcTyVar], a)
--- The workhorse:
---    push level, capture constraints, and emit an implication constraint
-tcImplicitTKBndrsX skol_mode skol_info bndrs thing_inside
-  | null bndrs  -- Short-cut the common case with no quantifiers
-                -- E.g. f :: Int -> Int
-                --      makes a HsOuterImplicit with empty bndrs,
-                --      and tcOuterTKBndrsX goes via here
-  = do { res <- thing_inside; return ([], res) }
-  | otherwise
-  = do { (tclvl, wanted, (skol_tvs, res))
-             <- pushLevelAndCaptureConstraints       $
-                bindImplicitTKBndrsX skol_mode bndrs $
-                thing_inside
-
-       ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted
-
-       ; return (skol_tvs, res) }
-
-------------------
-bindImplicitTKBndrs_Skol,
-  bindImplicitTKBndrs_Q_Skol :: SkolemInfo -> [Name] -> TcM a -> TcM ([TcTyVar], a)
-
-bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Q_Tv :: [Name] -> TcM a -> TcM ([TcTyVar], a)
-bindImplicitTKBndrs_Skol skol_info = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDSkolemTv skol_info })
-bindImplicitTKBndrs_Tv   = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = SMDTyVarTv })
-bindImplicitTKBndrs_Q_Skol skol_info = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = SMDSkolemTv skol_info })
-bindImplicitTKBndrs_Q_Tv = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = SMDTyVarTv })
-
-bindImplicitTKBndrsX
-   :: SkolemMode
-   -> [Name]               -- Generated by renamer; not in dependency order
-   -> TcM a
-   -> TcM ([TcTyVar], a)   -- Returned [TcTyVar] are in 1-1 correspondence
-                           -- with the passed in [Name]
-bindImplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind })
-                     tv_names thing_inside
-  = do { lcl_env <- getLclTypeEnv
-       ; tkvs <- mapM (new_tv lcl_env) tv_names
-       ; traceTc "bindImplicitTKBndrsX" (ppr tv_names $$ ppr tkvs)
-       ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs)
-                thing_inside
-       ; return (tkvs, res) }
-  where
-    new_tv lcl_env name
-      | check_parent
-      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name
-      = return tv
-      | otherwise
-      = do { kind <- newExpectedKind ctxt_kind
-           ; newTyVarBndr skol_mode name kind }
-
---------------------------------------
---           SkolemMode
---------------------------------------
-
--- | 'SkolemMode' describes how to typecheck an explicit ('HsTyVarBndr') or
--- implicit ('Name') binder in a type. It is just a record of flags
--- that describe what sort of 'TcTyVar' to create.
-data SkolemMode
-  = SM { sm_parent :: Bool    -- True <=> check the in-scope parent type variable
-                              -- Used only for asssociated types
-
-       , sm_clone  :: Bool    -- True <=> fresh unique
-                              -- See Note [Cloning for type variable binders]
-
-       , sm_tvtv   :: SkolemModeDetails    -- True <=> use a TyVarTv, rather than SkolemTv
-                              -- Why?  See Note [Inferring kinds for type declarations]
-                              -- in GHC.Tc.TyCl, and (in this module)
-                              -- Note [Checking partial type signatures]
-
-       , sm_kind   :: ContextKind  -- Use this for the kind of any new binders
-
-       , sm_holes  :: HoleInfo     -- What to do for wildcards in the kind
-       }
-
-data SkolemModeDetails
-  = SMDTyVarTv
-  | SMDSkolemTv SkolemInfo
-
-
-smVanilla :: HasCallStack => SkolemMode
-smVanilla = SM { sm_clone  = panic "sm_clone"  -- We always override this
-               , sm_parent = False
-               , sm_tvtv   = pprPanic "sm_tvtv" callStackDoc -- We always override this
-               , sm_kind   = AnyKind
-               , sm_holes  = Nothing }
-
-{- Note [Cloning for type variable binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Sometimes we must clone the Name of a type variable binder (written in
-the source program); and sometimes we must not. This is controlled by
-the sm_clone field of SkolemMode.
-
-In some cases it doesn't matter whether or not we clone. Perhaps
-it'd be better to use MustClone/MayClone/MustNotClone.
-
-When we /must not/ clone
-* In the binders of a type signature (tcOuterTKBndrs)
-      f :: forall a{27}. blah
-      f = rhs
-  Then 'a' scopes over 'rhs'. When we kind-check the signature (tcHsSigType),
-  we must get the type (forall a{27}. blah) for the Id f, because
-  we bring that type variable into scope when we typecheck 'rhs'.
-
-* In the binders of a data family instance (bindOuterFamEqnTKBndrs)
-     data instance
-       forall p q. D (p,q) = D1 p | D2 q
-  We kind-check the LHS in tcDataFamInstHeader, and then separately
-  (in tcDataFamInstDecl) bring p,q into scope before looking at the
-  the constructor decls.
-
-* bindExplicitTKBndrs_Q_Tv/bindImplicitTKBndrs_Q_Tv do not clone
-  We take advantage of this in kcInferDeclHeader:
-     all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)
-  If we cloned, we'd need to take a bit more care here; not hard.
-
-* bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Skol, do not clone.
-  There is no need, I think.
-
-  The payoff here is that avoiding gratuitous cloning means that we can
-  almost always take the fast path in swizzleTcTyConBndrs.
-
-When we /must/ clone.
-* bindOuterSigTKBndrs_Tv, bindExplicitTKBndrs_Tv do cloning
-
-  This for a narrow and tricky reason which, alas, I couldn't find a
-  simpler way round.  #16221 is the poster child:
-
-     data SameKind :: k -> k -> *
-     data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int
-
-  When kind-checking T, we give (a :: kappa1). Then:
-
-  - In kcConDecl we make a TyVarTv unification variable kappa2 for k2
-    (as described in Note [Using TyVarTvs for kind-checking GADTs],
-    even though this example is an existential)
-  - So we get (b :: kappa2) via bindExplicitTKBndrs_Tv
-  - We end up unifying kappa1 := kappa2, because of the (SameKind a b)
-
-  Now we generalise over kappa2. But if kappa2's Name is precisely k2
-  (i.e. we did not clone) we'll end up giving T the utterly final kind
-    T :: forall k2. k2 -> *
-  Nothing directly wrong with that but when we typecheck the data constructor
-  we have k2 in scope; but then it's brought into scope /again/ when we find
-  the forall k2.  This is chaotic, and we end up giving it the type
-    MkT :: forall k2 (a :: k2) k2 (b :: k2).
-           SameKind @k2 a b -> Int -> T @{k2} a
-  which is bogus -- because of the shadowing of k2, we can't
-  apply T to the kind or a!
-
-  And there no reason /not/ to clone the Name when making a unification
-  variable.  So that's what we do.
--}
-
---------------------------------------
--- Binding type/class variables in the
--- kind-checking and typechecking phases
---------------------------------------
-
-bindTyClTyVars :: Name -> ([TcTyConBinder] -> TcKind -> TcM a) -> TcM a
--- ^ Bring into scope the binders of a PolyTcTyCon
--- Used for the type variables of a type or class decl
--- in the "kind checking" and "type checking" pass,
--- but not in the initial-kind run.
-bindTyClTyVars tycon_name thing_inside
-  = do { tycon <- tcLookupTcTyCon tycon_name     -- The tycon is a PolyTcTyCon
-       ; let res_kind   = tyConResKind tycon
-             binders    = tyConBinders tycon
-       ; traceTc "bindTyClTyVars" (ppr tycon_name $$ ppr binders)
-       ; tcExtendTyVarEnv (binderVars binders) $
-         thing_inside binders res_kind }
-
-bindTyClTyVarsAndZonk :: Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
--- Like bindTyClTyVars, but in addition
--- zonk the skolem TcTyVars of a PolyTcTyCon to TyVars
--- We always do this same zonking after a call to bindTyClTyVars, but
--- here we do it right away because there are no more unifications to come
-bindTyClTyVarsAndZonk tycon_name thing_inside
-  = bindTyClTyVars tycon_name $ \ tc_bndrs tc_kind ->
-    do { ze          <- mkEmptyZonkEnv NoFlexi
-       ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs
-       ; kind        <- zonkTcTypeToTypeX ze tc_kind
-       ; thing_inside bndrs kind }
-
-
-{- *********************************************************************
-*                                                                      *
-             Kind generalisation
-*                                                                      *
-********************************************************************* -}
-
-zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]
-zonkAndScopedSort spec_tkvs
-  = do { spec_tkvs <- zonkTcTyVarsToTcTyVars spec_tkvs
-         -- Zonk the kinds, to we can do the dependency analysis
-
-       -- Do a stable topological sort, following
-       -- Note [Ordering of implicit variables] in GHC.Rename.HsType
-       ; return (scopedSort spec_tkvs) }
-
--- | Generalize some of the free variables in the given type.
--- All such variables should be *kind* variables; any type variables
--- should be explicitly quantified (with a `forall`) before now.
---
--- The WantedConstraints are un-solved kind constraints. Generally
--- they'll be reported as errors later, but meanwhile we refrain
--- from quantifying over any variable free in these unsolved
--- constraints. See Note [Failure in local type signatures].
---
--- But in all cases, generalize only those variables whose TcLevel is
--- strictly greater than the ambient level. This "strictly greater
--- than" means that you likely need to push the level before creating
--- whatever type gets passed here.
---
--- Any variable whose level is greater than the ambient level but is
--- not selected to be generalized will be promoted. (See [Promoting
--- unification variables] in "GHC.Tc.Solver" and Note [Recipe for
--- checking a signature].)
---
--- The resulting KindVar are the variables to quantify over, in the
--- correct, well-scoped order. They should generally be Inferred, not
--- Specified, but that's really up to the caller of this function.
-kindGeneralizeSome :: SkolemInfo
-                   -> WantedConstraints
-                   -> TcType    -- ^ needn't be zonked
-                   -> TcM [KindVar]
-kindGeneralizeSome skol_info wanted kind_or_type
-  = do { -- Use the "Kind" variant here, as any types we see
-         -- here will already have all type variables quantified;
-         -- thus, every free variable is really a kv, never a tv.
-       ; dvs <- candidateQTyVarsOfKind kind_or_type
-       ; dvs <- filterConstrainedCandidates wanted dvs
-       ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs }
-
-filterConstrainedCandidates
-  :: WantedConstraints    -- Don't quantify over variables free in these
-                          --   Not necessarily fully zonked
-  -> CandidatesQTvs       -- Candidates for quantification
-  -> TcM CandidatesQTvs
--- filterConstrainedCandidates removes any candidates that are free in
--- 'wanted'; instead, it promotes them.  This bit is very much like
--- decideMonoTyVars in GHC.Tc.Solver, but constraints are so much
--- simpler in kinds, it is much easier here. (In particular, we never
--- quantify over a constraint in a type.)
-filterConstrainedCandidates wanted dvs
-  | isEmptyWC wanted   -- Fast path for a common case
-  = return dvs
-  | otherwise
-  = do { wc_tvs <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)
-       ; let (to_promote, dvs') = partitionCandidates dvs (`elemVarSet` wc_tvs)
-       ; _ <- promoteTyVarSet to_promote
-       ; return dvs' }
-
--- |- Specialised version of 'kindGeneralizeSome', but with empty
--- WantedConstraints, so no filtering is needed
--- i.e.   kindGeneraliseAll = kindGeneralizeSome emptyWC
-kindGeneralizeAll :: SkolemInfo -> TcType -> TcM [KindVar]
-kindGeneralizeAll skol_info kind_or_type
-  = do { traceTc "kindGeneralizeAll" (ppr kind_or_type)
-       ; dvs <- candidateQTyVarsOfKind kind_or_type
-       ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs }
-
--- | Specialized version of 'kindGeneralizeSome', but where no variables
--- can be generalized, but perhaps some may need to be promoted.
--- Use this variant when it is unknowable whether metavariables might
--- later be constrained.
---
--- To see why this promotion is needed, see
--- Note [Recipe for checking a signature], and especially
--- Note [Promotion in signatures].
-kindGeneralizeNone :: TcType  -- needn't be zonked
-                   -> TcM ()
-kindGeneralizeNone kind_or_type
-  = do { traceTc "kindGeneralizeNone" (ppr kind_or_type)
-       ; dvs <- candidateQTyVarsOfKind kind_or_type
-       ; _ <- promoteTyVarSet (candidateKindVars dvs)
-       ; return () }
-
-{- Note [Levels and generalisation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  f x = e
-with no type signature. We are currently at level i.
-We must
-  * Push the level to level (i+1)
-  * Allocate a fresh alpha[i+1] for the result type
-  * Check that e :: alpha[i+1], gathering constraint WC
-  * Solve WC as far as possible
-  * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i]
-  * Find the free variables with level > i, in this case gamma[i]
-  * Skolemise those free variables and quantify over them, giving
-       f :: forall g. beta[i-1] -> g
-  * Emit the residual constraint wrapped in an implication for g,
-    thus   forall g. WC
-
-All of this happens for types too.  Consider
-  f :: Int -> (forall a. Proxy a -> Int)
-
-Note [Kind generalisation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do kind generalisation only at the outer level of a type signature.
-For example, consider
-  T :: forall k. k -> *
-  f :: (forall a. T a -> Int) -> Int
-When kind-checking f's type signature we generalise the kind at
-the outermost level, thus:
-  f1 :: forall k. (forall (a:k). T k a -> Int) -> Int  -- YES!
-and *not* at the inner forall:
-  f2 :: (forall k. forall (a:k). T k a -> Int) -> Int  -- NO!
-Reason: same as for HM inference on value level declarations,
-we want to infer the most general type.  The f2 type signature
-would be *less applicable* than f1, because it requires a more
-polymorphic argument.
-
-NB: There are no explicit kind variables written in f's signature.
-When there are, the renamer adds these kind variables to the list of
-variables bound by the forall, so you can indeed have a type that's
-higher-rank in its kind. But only by explicit request.
-
-Note [Kinds of quantified type variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-tcTyVarBndrsGen quantifies over a specified list of type variables,
-*and* over the kind variables mentioned in the kinds of those tyvars.
-
-Note that we must zonk those kinds (obviously) but less obviously, we
-must return type variables whose kinds are zonked too. Example
-    (a :: k7)  where  k7 := k9 -> k9
-We must return
-    [k9, a:k9->k9]
-and NOT
-    [k9, a:k7]
-Reason: we're going to turn this into a for-all type,
-   forall k9. forall (a:k7). blah
-which the type checker will then instantiate, and instantiate does not
-look through unification variables!
-
-Hence using zonked_kinds when forming tvs'.
-
--}
-
------------------------------------
-etaExpandAlgTyCon :: TyConFlavour -> SkolemInfo
-                  -> [TcTyConBinder] -> Kind
-                  -> TcM ([TcTyConBinder], Kind)
-etaExpandAlgTyCon flav skol_info tcbs res_kind
-  | needsEtaExpansion flav
-  = splitTyConKind skol_info in_scope avoid_occs res_kind
-  | otherwise
-  = return ([], res_kind)
-  where
-    tyvars     = binderVars tcbs
-    in_scope   = mkInScopeSetList tyvars
-    avoid_occs = map getOccName tyvars
-
-needsEtaExpansion :: TyConFlavour -> Bool
-needsEtaExpansion NewtypeFlavour  = True
-needsEtaExpansion DataTypeFlavour = True
-needsEtaExpansion ClassFlavour    = True
-needsEtaExpansion _               = False
-
-splitTyConKind :: SkolemInfo
-               -> InScopeSet
-               -> [OccName]  -- Avoid these OccNames
-               -> Kind       -- Must be zonked
-               -> TcM ([TcTyConBinder], TcKind)
--- GADT decls can have a (perhaps partial) kind signature
---      e.g.  data T a :: * -> * -> * where ...
--- This function makes up suitable (kinded) TyConBinders for the
--- argument kinds.  E.g. in this case it might return
---   ([b::*, c::*], *)
--- Skolemises the type as it goes, returning skolem TcTyVars
--- Never emits constraints.
--- It's a little trickier than you might think: see Note [splitTyConKind]
--- See also Note [Datatype return kinds] in GHC.Tc.TyCl
-splitTyConKind skol_info in_scope avoid_occs kind
-  = do  { loc     <- getSrcSpanM
-        ; uniqs   <- newUniqueSupply
-        ; rdr_env <- getLocalRdrEnv
-        ; lvl     <- getTcLevel
-        ; let new_occs = Inf.filter (\ occ ->
-                  isNothing (lookupLocalRdrOcc rdr_env occ) &&
-                  -- Note [Avoid name clashes for associated data types]
-                  not (occ `elem` avoid_occs)) $ mkOccName tvName <$> allNameStrings
-              new_uniqs = uniqsFromSupply uniqs
-              subst = mkEmptySubst in_scope
-              details = SkolemTv skol_info (pushTcLevel lvl) False
-                        -- As always, allocate skolems one level in
-
-              go occs uniqs subst acc kind
-                = case splitPiTy_maybe kind of
-                    Nothing -> (reverse acc, substTy subst kind)
-
-                    Just (Anon arg af, kind')
-                      -> go occs' uniqs' subst' (tcb : acc) kind'
-                      where
-                        tcb    = Bndr tv (AnonTCB af)
-                        arg'   = substTy subst (scaledThing arg)
-                        name   = mkInternalName uniq occ loc
-                        tv     = mkTcTyVar name arg' details
-                        subst' = extendSubstInScope subst tv
-                        uniq:uniqs' = uniqs
-                        Inf occ occs' = occs
-
-                    Just (Named (Bndr tv vis), kind')
-                      -> go occs uniqs subst' (tcb : acc) kind'
-                      where
-                        tcb           = Bndr tv' (NamedTCB vis)
-                        tc_tyvar      = mkTcTyVar (tyVarName tv) (tyVarKind tv) details
-                        (subst', tv') = substTyVarBndr subst tc_tyvar
-
-        ; return (go new_occs new_uniqs subst [] kind) }
-
-isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool
-isAllowedDataResKind AnyTYPEKind  kind = isTypeLikeKind     kind
-isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind  kind
-isAllowedDataResKind LiftedKind   kind = tcIsLiftedTypeKind kind
-
--- | Checks that the return kind in a data declaration's kind signature is
--- permissible. There are three cases:
---
--- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@
--- declaration, check that the return kind is @Type@.
---
--- If the declaration is a @newtype@ or @newtype instance@ and the
--- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so
--- that a return kind of the form @TYPE r@ (for some @r@) is permitted.
--- See @Note [Implementation of UnliftedNewtypes]@ in "GHC.Tc.TyCl".
---
--- If dealing with a @data family@ declaration, check that the return kind is
--- either of the form:
---
--- 1. @TYPE r@ (for some @r@), or
---
--- 2. @k@ (where @k@ is a bare kind variable; see #12369)
---
--- See also Note [Datatype return kinds] in "GHC.Tc.TyCl"
-checkDataKindSig :: DataSort -> Kind  -- any arguments in the kind are stripped off
-                 -> TcM ()
-checkDataKindSig data_sort kind
-  = do { dflags <- getDynFlags
-       ; traceTc "checkDataKindSig" (ppr kind)
-       ; checkTc (tYPE_ok dflags || is_kind_var)
-                 (err_msg dflags) }
-  where
-    res_kind = snd (tcSplitPiTys kind)
-       -- Look for the result kind after
-       -- peeling off any foralls and arrows
-
-    is_newtype :: Bool
-    is_newtype =
-      case data_sort of
-        DataDeclSort     new_or_data -> new_or_data == NewType
-        DataInstanceSort new_or_data -> new_or_data == NewType
-        DataFamilySort               -> False
-
-    is_datatype :: Bool
-    is_datatype =
-      case data_sort of
-        DataDeclSort     DataType -> True
-        DataInstanceSort DataType -> True
-        _                         -> False
-
-    is_data_family :: Bool
-    is_data_family =
-      case data_sort of
-        DataDeclSort{}     -> False
-        DataInstanceSort{} -> False
-        DataFamilySort     -> True
-
-    allowed_kind :: DynFlags -> AllowedDataResKind
-    allowed_kind dflags
-      | is_newtype && xopt LangExt.UnliftedNewtypes dflags
-        -- With UnliftedNewtypes, we allow kinds other than Type, but they
-        -- must still be of the form `TYPE r` since we don't want to accept
-        -- Constraint or Nat.
-        -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl.
-      = AnyTYPEKind
-      | is_data_family
-        -- If this is a `data family` declaration, we don't need to check if
-        -- UnliftedNewtypes is enabled, since data family declarations can
-        -- have return kind `TYPE r` unconditionally (#16827).
-      = AnyTYPEKind
-      | is_datatype && xopt LangExt.UnliftedDatatypes dflags
-        -- With UnliftedDatatypes, we allow kinds other than Type, but they
-        -- must still be of the form `TYPE (BoxedRep l)`, so that we don't
-        -- accept result kinds like `TYPE IntRep`.
-        -- See Note [Implementation of UnliftedDatatypes] in GHC.Tc.TyCl.
-      = AnyBoxedKind
-      | otherwise
-      = LiftedKind
-
-    tYPE_ok :: DynFlags -> Bool
-    tYPE_ok dflags = isAllowedDataResKind (allowed_kind dflags) res_kind
-
-    -- In the particular case of a data family, permit a return kind of the
-    -- form `:: k` (where `k` is a bare kind variable).
-    is_kind_var :: Bool
-    is_kind_var | is_data_family = isJust (getCastedTyVar_maybe res_kind)
-                | otherwise      = False
-
-    err_msg :: DynFlags -> TcRnMessage
-    err_msg dflags =
-      TcRnInvalidReturnKind data_sort (allowed_kind dflags) kind (ext_hint dflags)
-
-    ext_hint dflags
-      | isTypeLikeKind kind
-      , is_newtype
-      , not (xopt LangExt.UnliftedNewtypes dflags)
-      = Just SuggestUnliftedNewtypes
-      | tcIsBoxedTypeKind kind
-      , is_datatype
-      , not (xopt LangExt.UnliftedDatatypes dflags)
-      = Just SuggestUnliftedDatatypes
-      | otherwise
-      = Nothing
-
--- | Checks that the result kind of a class is exactly `Constraint`, rejecting
--- type synonyms and type families that reduce to `Constraint`. See #16826.
-checkClassKindSig :: Kind -> TcM ()
-checkClassKindSig kind = checkTc (isConstraintKind kind) err_msg
-  where
-    err_msg :: TcRnMessage
-    err_msg = TcRnClassKindNotConstraint kind
-
-tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]
--- Result is in 1-1 correspondence with orig_args
-tcbVisibilities tc orig_args
-  = go (tyConKind tc) init_subst orig_args
-  where
-    init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfTypes orig_args))
-    go _ _ []
-      = []
-
-    go fun_kind subst all_args@(arg : args)
-      | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind
-      = case tcb of
-          Anon _ af           -> AnonTCB af   : go inner_kind subst  args
-          Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args
-                 where
-                    subst' = extendTCvSubst subst tv arg
-
-      | not (isEmptyTCvSubst subst)
-      = go (substTy subst fun_kind) init_subst all_args
-
-      | otherwise
-      = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args)
-
-
-{- Note [splitTyConKind]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Given
-  data T (a::*) :: * -> forall k. k -> *
-we want to generate the extra TyConBinders for T, so we finally get
-  (a::*) (b::*) (k::*) (c::k)
-The function splitTyConKind generates these extra TyConBinders from
-the result kind signature.  The same function is also used by
-kcCheckDeclHeader_sig to get the [TyConBinder] from the Kind of
-the TyCon given in a standalone kind signature.  E.g.
-  type T :: forall (a::*). * -> forall k. k -> *
-
-We need to take care to give the TyConBinders
-  (a) Uniques that are fresh: the TyConBinders of a TyCon
-      must have distinct uniques.
-
-  (b) Preferably, OccNames that are fresh. If we happen to re-use
-      OccNames that are other TyConBinders, we'll get a TyCon with
-      TyConBinders like [a_72, a_53]; same OccName, different Uniques.
-      Then when pretty-printing (e.g. in GHCi :info) we'll see
-          data T a a0
-      whereas we'd prefer
-          data T a b
-      (NB: the tidying happens in the conversion to Iface syntax,
-      which happens as part of pretty-printing a TyThing.)
-
-      Using fresh OccNames is not essential; it's cosmetic.
-      And also see Note [Avoid name clashes for associated data types].
-
-For (a) perhaps surprisingly, duplicated uniques can happen, even if
-we use fresh uniques for Anon arrows.  Consider
-   data T :: forall k. k -> forall k. k -> *
-where the two k's are identical even up to their uniques.  Surprisingly,
-this can happen: see #14515, #19092,3,4.  Then if we use those k's in
-as TyConBinders we'll get duplicated uniques.
-
-For (b) we'd like to avoid OccName clashes with the tyvars declared by
-the user before the "::"; in the above example that is 'a'.
-
-It's reasonably easy to solve all this; just run down the list with a
-substitution; hence the recursive 'go' function.  But for the Uniques
-it has to be done.
-
-Note [Avoid name clashes for associated data types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider    class C a b where
-               data D b :: * -> *
-When typechecking the decl for D, we'll invent an extra type variable
-for D, to fill out its kind.  Ideally we don't want this type variable
-to be 'a', because when pretty printing we'll get
-            class C a b where
-               data D b a0
-(NB: the tidying happens in the conversion to Iface syntax, which happens
-as part of pretty-printing a TyThing.)
-
-That's why we look in the LocalRdrEnv to see what's in scope. This is
-important only to get nice-looking output when doing ":info C" in GHCi.
-It isn't essential for correctness.
-
-
-************************************************************************
-*                                                                      *
-             Partial signatures
-*                                                                      *
-************************************************************************
-
--}
-
-tcHsPartialSigType
-  :: UserTypeCtxt
-  -> LHsSigWcType GhcRn       -- The type signature
-  -> TcM ( [(Name, TcTyVar)]  -- Wildcards
-         , Maybe TcType       -- Extra-constraints wildcard
-         , [(Name,InvisTVBinder)] -- Original tyvar names, in correspondence with
-                              --   the implicitly and explicitly bound type variables
-         , TcThetaType        -- Theta part
-         , TcType )           -- Tau part
--- See Note [Checking partial type signatures]
-tcHsPartialSigType ctxt sig_ty
-  | HsWC { hswc_ext  = sig_wcs, hswc_body = sig_ty } <- sig_ty
-  , L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = body_ty}) <- sig_ty
-  , (hs_ctxt, hs_tau) <- splitLHsQualTy body_ty
-  = addSigCtxt ctxt sig_ty $
-    do { mode <- mkHoleMode TypeLevel HM_Sig
-       ; (outer_bndrs, (wcs, wcx, theta, tau))
-            <- solveEqualities "tcHsPartialSigType" $
-               -- See Note [Failure in local type signatures]
-               bindNamedWildCardBinders sig_wcs             $ \ wcs ->
-               bindOuterSigTKBndrs_Tv_M mode hs_outer_bndrs $
-               do {   -- Instantiate the type-class context; but if there
-                      -- is an extra-constraints wildcard, just discard it here
-                    (theta, wcx) <- tcPartialContext mode hs_ctxt
-
-                  ; ek <- newOpenTypeKind
-                  ; tau <- -- Don't do (addTypeCtxt hs_tau) here else we get
-                           --   In the type <blah>
-                           --   In the type signature: foo :: <blah>
-                           tc_lhs_type mode hs_tau ek
-
-                  ; return (wcs, wcx, theta, tau) }
-
-       ; traceTc "tcHsPartialSigType 2" empty
-       ; outer_bndrs <- scopedSortOuter outer_bndrs
-       ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs
-       ; traceTc "tcHsPartialSigType 3" empty
-
-         -- No kind-generalization here:
-       ; kindGeneralizeNone (mkInvisForAllTys outer_tv_bndrs $
-                             tcMkPhiTy theta $
-                             tau)
-
-       -- Spit out the wildcards (including the extra-constraints one)
-       -- as "hole" constraints, so that they'll be reported if necessary
-       -- See Note [Extra-constraint holes in partial type signatures]
-       ; mapM_ emitNamedTypeHole wcs
-
-         -- The "tau" from tcHsPartialSigType might very well have some foralls
-         -- at the top, hidden behind a type synonym. Instantiate them! E.g.
-         --    type T x = forall b. x -> b -> b
-         --    f :: forall a. T (a,_)
-         -- We must instantiate the `forall b` just as we do the `forall a`!
-         -- Missing this led to #21667.
-       ; (tv_prs', theta', tau) <- tcInstTypeBndrs tau
-
-         -- We return a proper (Name,InvisTVBinder) environment, to be sure that
-         -- we bring the right name into scope in the function body.
-         -- Test case: partial-sigs/should_compile/LocalDefinitionBug
-       ; let outer_bndr_names :: [Name]
-             outer_bndr_names = hsOuterTyVarNames hs_outer_bndrs
-             tv_prs :: [(Name,InvisTVBinder)]
-             tv_prs = outer_bndr_names `zip` outer_tv_bndrs
-
-       -- Zonk, so that any nested foralls can "see" their occurrences
-       -- See Note [Checking partial type signatures], and in particular
-       -- Note [Levels for wildcards]
-       ; tv_prs <- mapSndM zonkInvisTVBinder (tv_prs ++ tv_prs')
-       ; theta  <- mapM    zonkTcType        (theta ++ theta')
-       ; tau    <- zonkTcType                tau
-
-      -- NB: checkValidType on the final inferred type will be
-      --     done later by checkInferredPolyId.  We can't do it
-      --     here because we don't have a complete type to check
-
-       ; traceTc "tcHsPartialSigType" (ppr tv_prs)
-       ; return (wcs, wcx, tv_prs, theta, tau) }
-
-tcPartialContext :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM (TcThetaType, Maybe TcType)
-tcPartialContext _ Nothing = return ([], Nothing)
-tcPartialContext mode (Just (L _ hs_theta))
-  | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta
-  , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last
-  = do { wc_tv_ty <- setSrcSpanA wc_loc $
-                     tcAnonWildCardOcc YesExtraConstraint mode ty constraintKind
-       ; theta <- mapM (tc_lhs_pred mode) hs_theta1
-       ; return (theta, Just wc_tv_ty) }
-  | otherwise
-  = do { theta <- mapM (tc_lhs_pred mode) hs_theta
-       ; return (theta, Nothing) }
-
-{- Note [Checking partial type signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This Note is about tcHsPartialSigType.  See also
-Note [Recipe for checking a signature]
-
-When we have a partial signature like
-   f :: forall a. a -> _
-we do the following
-
-* tcHsPartialSigType does not make quantified type (forall a. blah)
-  and then instantiate it -- it makes no sense to instantiate a type
-  with wildcards in it.  Rather, tcHsPartialSigType just returns the
-  'a' and the 'blah' separately.
-
-  Nor, for the same reason, do we push a level in tcHsPartialSigType.
-
-* We instantiate 'a' to a unification variable, a TyVarTv, and /not/
-  a skolem; hence the "_Tv" in bindExplicitTKBndrs_Tv.  Consider
-    f :: forall a. a -> _
-    g :: forall b. _ -> b
-    f = g
-    g = f
-  They are typechecked as a recursive group, with monomorphic types,
-  so 'a' and 'b' will get unified together.  Very like kind inference
-  for mutually recursive data types (sans CUSKs or SAKS); see
-  Note [Cloning for type variable binders]
-
-* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike
-  the companion CompleteSig) contains the original, as-yet-unchecked
-  source-code LHsSigWcType
-
-* Then, for f and g /separately/, we call tcInstSig, which in turn
-  call tcHsPartialSig (defined near this Note).  It kind-checks the
-  LHsSigWcType, creating fresh unification variables for each "_"
-  wildcard.  It's important that the wildcards for f and g are distinct
-  because they might get instantiated completely differently.  E.g.
-     f,g :: forall a. a -> _
-     f x = a
-     g x = True
-  It's really as if we'd written two distinct signatures.
-
-* Nested foralls. See Note [Levels for wildcards]
-
-* Just as for ordinary signatures, we must solve local equalities and
-  zonk the type after kind-checking it, to ensure that all the nested
-  forall binders can "see" their occurrences
-
-  Just as for ordinary signatures, this zonk also gets any Refl casts
-  out of the way of instantiation.  Example: #18008 had
-       foo :: (forall a. (Show a => blah) |> Refl) -> _
-  and that Refl cast messed things up.  See #18062.
-
-Note [Levels for wildcards]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-     f :: forall b. (forall a. a -> _) -> b
-We do /not/ allow the "_" to be instantiated to 'a'; although we do
-(as before) allow it to be instantiated to the (top level) 'b'.
-Why not?  Suppose
-   f x = (x True, x 'c')
-
-During typecking the RHS we must instantiate that (forall a. a -> _),
-so we must know /precisely/ where all the a's are; they must not be
-hidden under (possibly-not-yet-filled-in) unification variables!
-
-We achieve this as follows:
-
-- For /named/ wildcards such sas
-     g :: forall b. (forall la. a -> _x) -> b
-  there is no problem: we create them at the outer level (ie the
-  ambient level of the signature itself), and push the level when we
-  go inside a forall.  So now the unification variable for the "_x"
-  can't unify with skolem 'a'.
-
-- For /anonymous/ wildcards, such as 'f' above, we carry the ambient
-  level of the signature to the hole in the TcLevel part of the
-  mode_holes field of TcTyMode.  Then, in tcAnonWildCardOcc we us that
-  level (and /not/ the level ambient at the occurrence of "_") to
-  create the unification variable for the wildcard.  That is the sole
-  purpose of the TcLevel in the mode_holes field: to transport the
-  ambient level of the signature down to the anonymous wildcard
-  occurrences.
-
-Note [Extra-constraint holes in partial type signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  f :: (_) => a -> a
-  f x = ...
-
-* The renamer leaves '_' untouched.
-
-* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in
-  tcWildCardBinders.
-
-* GHC.Tc.Gen.Bind.chooseInferredQuantifiers fills in that hole TcTyVar
-  with the inferred constraints, e.g. (Eq a, Show a)
-
-* GHC.Tc.Errors.mkHoleError finally reports the error.
-
-An annoying difficulty happens if there are more than 64 inferred
-constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple.
-Where do we find the TyCon?  For good reasons we only have constraint
-tuples up to 62 (see Note [How tuples work] in GHC.Builtin.Types).  So how
-can we make a 70-tuple?  This was the root cause of #14217.
-
-It's incredibly tiresome, because we only need this type to fill
-in the hole, to communicate to the error reporting machinery.  Nothing
-more.  So I use a HACK:
-
-* I make an /ordinary/ tuple of the constraints, in
-  GHC.Tc.Gen.Bind.chooseInferredQuantifiers. This is ill-kinded because
-  ordinary tuples can't contain constraints, but it works fine. And for
-  ordinary tuples we don't have the same limit as for constraint
-  tuples (which need selectors and an associated class).
-
-* Because it is ill-kinded (unifying something of kind Constraint with
-  something of kind Type), it should trip an assert in writeMetaTyVarRef.
-
-Result works fine, but it may eventually bite us.
-
-See also Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver for
-information about how these are printed.
-
-************************************************************************
-*                                                                      *
-      Pattern signatures (i.e signatures that occur in patterns)
-*                                                                      *
-********************************************************************* -}
-
-tcHsPatSigType :: UserTypeCtxt
-               -> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications.
-               -> HsPatSigType GhcRn          -- The type signature
-               -> ContextKind                -- What kind is expected
-               -> TcM ( [(Name, TcTyVar)]     -- Wildcards
-                      , [(Name, TcTyVar)]     -- The new bit of type environment, binding
-                                              -- the scoped type variables
-                      , TcType)       -- The type
--- Used for type-checking type signatures in
--- (a) patterns           e.g  f (x::Int) = e
--- (b) RULE forall bndrs  e.g. forall (x::Int). f x = x
--- See Note [Pattern signature binders and scoping] in GHC.Hs.Type
---
--- This may emit constraints
--- See Note [Recipe for checking a signature]
-tcHsPatSigType ctxt hole_mode
-  (HsPS { hsps_ext  = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }
-        , hsps_body = hs_ty })
-  ctxt_kind
-  = addSigCtxt ctxt hs_ty $
-    do { sig_tkv_prs <- mapM new_implicit_tv sig_ns
-       ; mode <- mkHoleMode TypeLevel hole_mode
-       ; (wcs, sig_ty)
-            <- addTypeCtxt hs_ty                     $
-               solveEqualities "tcHsPatSigType" $
-                 -- See Note [Failure in local type signatures]
-                 -- and c.f #16033
-               bindNamedWildCardBinders sig_wcs $ \ wcs ->
-               tcExtendNameTyVarEnv sig_tkv_prs $
-               do { ek     <- newExpectedKind ctxt_kind
-                  ; sig_ty <- tc_lhs_type mode hs_ty ek
-                  ; return (wcs, sig_ty) }
-
-        ; mapM_ emitNamedTypeHole wcs
-
-          -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty
-          -- contains a forall). Promote these.
-          -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ...
-          -- When we instantiate x, we have to compare the kind of the argument
-          -- to a's kind, which will be a metavariable.
-          -- kindGeneralizeNone does this:
-        ; kindGeneralizeNone sig_ty
-        ; sig_ty <- zonkTcType sig_ty
-        ; checkValidType ctxt sig_ty
-
-        ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs)
-        ; return (wcs, sig_tkv_prs, sig_ty) }
-  where
-    new_implicit_tv name
-      = do { kind <- newMetaKindVar
-           ; tv   <- case ctxt of
-                       RuleSigCtxt rname _  -> do
-                        skol_info <- mkSkolemInfo (RuleSkol rname)
-                        newSkolemTyVar skol_info name kind
-                       _              -> newPatSigTyVar name kind
-                       -- See Note [Typechecking pattern signature binders]
-             -- NB: tv's Name may be fresh (in the case of newPatSigTyVar)
-           ; return (name, tv) }
-
-{- Note [Typechecking pattern signature binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See also Note [Type variables in the type environment] in GHC.Tc.Utils.
-Consider
-
-  data T where
-    MkT :: forall a. a -> (a -> Int) -> T
-
-  f :: T -> ...
-  f (MkT x (f :: b -> c)) = <blah>
-
-Here
- * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk',
-   It must be a skolem so that it retains its identity, and
-   GHC.Tc.Errors.getSkolemInfo can thereby find the binding site for the skolem.
-
- * The type signature pattern (f :: b -> c) makes fresh meta-tyvars
-   beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the
-   environment
-
- * Then unification makes beta := a_sk, gamma := Int
-   That's why we must make beta and gamma a MetaTv,
-   not a SkolemTv, so that it can unify to a_sk (or Int, respectively).
-
- * Finally, in '<blah>' we have the envt "b" :-> beta, "c" :-> gamma,
-   so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType,
-
-Another example (#13881):
-   fl :: forall (l :: [a]). Sing l -> Sing l
-   fl (SNil :: Sing (l :: [y])) = SNil
-When we reach the pattern signature, 'l' is in scope from the
-outer 'forall':
-   "a" :-> a_sk :: *
-   "l" :-> l_sk :: [a_sk]
-We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check
-the pattern signature
-   Sing (l :: [y])
-That unifies y_sig := a_sk.  We return from tcHsPatSigType with
-the pair ("y" :-> y_sig).
-
-For RULE binders, though, things are a bit different (yuk).
-  RULE "foo" forall (x::a) (y::[a]).  f x y = ...
-Here this really is the binding site of the type variable so we'd like
-to use a skolem, so that we get a complaint if we unify two of them
-together.  Hence the new_implicit_tv function in tcHsPatSigType.
-
-
-************************************************************************
-*                                                                      *
-        Checking kinds
-*                                                                      *
-************************************************************************
-
--}
-
-unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)
-unifyKinds rn_tys act_kinds
-  = do { kind <- newMetaKindVar
-       ; let check rn_ty (ty, act_kind)
-               = checkExpectedKind (unLoc rn_ty) ty act_kind kind
-       ; tys' <- zipWithM check rn_tys act_kinds
-       ; return (tys', kind) }
-
-{-
-************************************************************************
-*                                                                      *
-        Sort checking kinds
-*                                                                      *
-************************************************************************
-
-tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.
-It does sort checking and desugaring at the same time, in one single pass.
--}
-
-tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind
-tcLHsKindSig ctxt hs_kind
-  = tc_lhs_kind_sig kindLevelMode ctxt hs_kind
-
-tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind
-tc_lhs_kind_sig mode ctxt hs_kind
--- See  Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType
--- Result is zonked
-  = do { kind <- addErrCtxt (text "In the kind" <+> quotes (ppr hs_kind)) $
-                 solveEqualities "tcLHsKindSig" $
-                 tc_lhs_type mode hs_kind liftedTypeKind
-       ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)
-       -- No generalization:
-       ; kindGeneralizeNone kind
-       ; kind <- zonkTcType kind
-         -- This zonk is very important in the case of higher rank kinds
-         -- E.g. #13879    f :: forall (p :: forall z (y::z). <blah>).
-         --                          <more blah>
-         --      When instantiating p's kind at occurrences of p in <more blah>
-         --      it's crucial that the kind we instantiate is fully zonked,
-         --      else we may fail to substitute properly
-
-       ; checkValidType ctxt kind
-       ; traceTc "tcLHsKindSig2" (ppr kind)
-       ; return kind }
-
-promotionErr :: Name -> PromotionErr -> TcM a
-promotionErr name err
-  = failWithTc $ TcRnUnpromotableThing name err
-
-{-
-************************************************************************
-*                                                                      *
-          Error messages and such
-*                                                                      *
-************************************************************************
--}
-
-
--- | Make an appropriate message for an error in a function argument.
--- Used for both expressions and types.
-funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc
-funAppCtxt fun arg arg_no
-  = hang (hsep [ text "In the", speakNth arg_no, text "argument of",
-                    quotes (ppr fun) <> text ", namely"])
-       2 (quotes (ppr arg))
-
--- | Add a "In the data declaration for T" or some such.
-addTyConFlavCtxt :: Name -> TyConFlavour -> TcM a -> TcM a
-addTyConFlavCtxt name flav
-  = addErrCtxt $ hsep [ text "In the", ppr flav
-                      , text "declaration for", quotes (ppr name) ]
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ /dev/null
@@ -1,1171 +0,0 @@
-
-{-# LANGUAGE ConstraintKinds  #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes       #-}
-{-# LANGUAGE RecordWildCards  #-}
-{-# LANGUAGE TupleSections    #-}
-{-# LANGUAGE TypeFamilies     #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
--- | Typecheck some @Matches@
-module GHC.Tc.Gen.Match
-   ( tcMatchesFun
-   , tcGRHS
-   , tcGRHSsPat
-   , tcMatchesCase
-   , tcMatchLambda
-   , TcMatchCtxt(..)
-   , TcStmtChecker
-   , TcExprStmtChecker
-   , TcCmdStmtChecker
-   , tcStmts
-   , tcStmtsAndThen
-   , tcDoStmts
-   , tcBody
-   , tcDoStmt
-   , tcGuardStmt
-   , checkPatCounts
-   )
-where
-
-import GHC.Prelude
-
-import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC
-                                       , tcMonoExpr, tcMonoExprNC, tcExpr
-                                       , tcCheckMonoExpr, tcCheckMonoExprNC
-                                       , tcCheckPolyExpr )
-
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Env
-import GHC.Tc.Gen.Pat
-import GHC.Tc.Gen.Head( tcCheckId )
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Gen.Bind
-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
-import GHC.Tc.Utils.Unify
-import GHC.Tc.Types.Origin
-import GHC.Tc.Types.Evidence
-
-import GHC.Core.Multiplicity
-import GHC.Core.UsageEnv
-import GHC.Core.TyCon
--- Create chunkified tuple tybes for monad comprehensions
-import GHC.Core.Make
-
-import GHC.Hs
-
-import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Misc
-import GHC.Driver.Session ( getDynFlags )
-
-import GHC.Types.Fixity (LexicalFixity(..))
-import GHC.Types.Name
-import GHC.Types.Id
-import GHC.Types.SrcLoc
-
-import Control.Monad
-import Control.Arrow ( second )
-import qualified Data.List.NonEmpty as NE
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{tcMatchesFun, tcMatchesCase}
-*                                                                      *
-************************************************************************
-
-@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
-@FunMonoBind@.  The second argument is the name of the function, which
-is used in error messages.  It checks that all the equations have the
-same number of arguments before using @tcMatches@ to do the work.
--}
-
-tcMatchesFun :: LocatedN Id -- MatchContext Id
-             -> MatchGroup GhcRn (LHsExpr GhcRn)
-             -> ExpRhoType    -- Expected type of function
-             -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-                                -- Returns type of body
-tcMatchesFun fun_id matches exp_ty
-  = do  {  -- Check that they all have the same no of arguments
-           -- Location is in the monad, set the caller so that
-           -- any inter-equation error messages get some vaguely
-           -- sensible location.        Note: we have to do this odd
-           -- ann-grabbing, because we don't always have annotations in
-           -- hand when we call tcMatchesFun...
-          traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
-           -- We can't easily call checkPatCounts here because fun_id can be an
-           -- unfilled thunk
-        ; checkArgCounts fun_name matches
-
-        ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->
-             -- NB: exp_type may be polymorphic, but
-             --     matchExpectedFunTys can cope with that
-          tcScalingUsage ManyTy $
-          -- toplevel bindings and let bindings are, at the
-          -- moment, always unrestricted. The value being bound
-          -- must, accordingly, be unrestricted. Hence them
-          -- being scaled by Many. When let binders come with a
-          -- multiplicity, then @tcMatchesFun@ will have to take
-          -- a multiplicity argument, and scale accordingly.
-          tcMatches match_ctxt pat_tys rhs_ty matches }
-  where
-    fun_name = idName (unLoc fun_id)
-    arity  = matchGroupArity matches
-    herald = ExpectedFunTyMatches (NameThing fun_name) matches
-    ctxt   = GenSigCtxt  -- Was: FunSigCtxt fun_name True
-                         -- But that's wrong for f :: Int -> forall a. blah
-    what   = FunRhs { mc_fun = fun_id, mc_fixity = Prefix, mc_strictness = strictness }
-                    -- Careful: this fun_id could be an unfilled
-                    -- thunk from fixM in tcMonoBinds, so we're
-                    -- not allowed to look at it, except for
-                    -- idName.
-                    -- See Note [fixM for rhs_ty in tcMonoBinds]
-    match_ctxt = MC { mc_what = what, mc_body = tcBody }
-    strictness
-      | [L _ match] <- unLoc $ mg_alts matches
-      , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match
-      = SrcStrict
-      | otherwise
-      = NoSrcStrict
-
-{-
-@tcMatchesCase@ doesn't do the argument-count check because the
-parser guarantees that each equation has exactly one argument.
--}
-
-tcMatchesCase :: (AnnoBody body) =>
-                TcMatchCtxt body      -- ^ Case context
-             -> Scaled TcSigmaTypeFRR -- ^ Type of scrutinee
-             -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- ^ The case alternatives
-             -> ExpRhoType                               -- ^ Type of the whole case expression
-             -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
-                -- Translated alternatives
-                -- wrapper goes from MatchGroup's ty to expected ty
-
-tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty
-  = tcMatches ctxt [Scaled scrut_mult (mkCheckExpType scrut_ty)] res_ty matches
-
-tcMatchLambda :: ExpectedFunTyOrigin -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify
-              -> TcMatchCtxt HsExpr
-              -> MatchGroup GhcRn (LHsExpr GhcRn)
-              -> ExpRhoType
-              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
-tcMatchLambda herald match_ctxt match res_ty
-  =  do { checkPatCounts (mc_what match_ctxt) match
-        ; matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> do
-            -- checking argument counts since this is also used for \cases
-            tcMatches match_ctxt pat_tys rhs_ty match }
-  where
-    n_pats | isEmptyMatchGroup match = 1   -- must be lambda-case
-           | otherwise               = matchGroupArity match
-
--- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
-
-tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType
-           -> TcM (GRHSs GhcTc (LHsExpr GhcTc))
--- Used for pattern bindings
-tcGRHSsPat grhss res_ty
-  = tcScalingUsage ManyTy $
-      -- Like in tcMatchesFun, this scaling happens because all
-      -- let bindings are unrestricted. A difference, here, is
-      -- that when this is not the case, any more, we will have to
-      -- make sure that the pattern is strict, otherwise this will
-      -- desugar to incorrect code.
-    tcGRHSs match_ctxt grhss res_ty
-  where
-    match_ctxt :: TcMatchCtxt HsExpr -- AZ
-    match_ctxt = MC { mc_what = PatBindRhs,
-                      mc_body = tcBody }
-
-{- *********************************************************************
-*                                                                      *
-                tcMatch
-*                                                                      *
-********************************************************************* -}
-
-data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module
-  = MC { mc_what :: HsMatchContext GhcTc,  -- What kind of thing this is
-         mc_body :: LocatedA (body GhcRn)  -- Type checker for a body of
-                                           -- an alternative
-                 -> ExpRhoType
-                 -> TcM (LocatedA (body GhcTc)) }
-
-type AnnoBody body
-  = ( Outputable (body GhcRn)
-    , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
-    , Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
-    , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL
-    , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL
-    , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns
-    , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
-    , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
-    , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
-    )
-
--- | Type-check a MatchGroup.
-tcMatches :: (AnnoBody body ) => TcMatchCtxt body
-          -> [Scaled ExpSigmaTypeFRR] -- ^ Expected pattern types.
-          -> ExpRhoType               -- ^ Expected result-type of the Match.
-          -> MatchGroup GhcRn (LocatedA (body GhcRn))
-          -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
-
-tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
-                                  , mg_ext = origin })
-  | null matches  -- Deal with case e of {}
-    -- Since there are no branches, no one else will fill in rhs_ty
-    -- when in inference mode, so we must do it ourselves,
-    -- here, using expTypeToType
-  = do { tcEmitBindingUsage bottomUE
-       ; pat_tys <- mapM scaledExpTypeToType pat_tys
-       ; rhs_ty  <- expTypeToType rhs_ty
-       ; return (MG { mg_alts = L l []
-                    , mg_ext = MatchGroupTc pat_tys rhs_ty origin
-                    }) }
-
-  | otherwise
-  = do { umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches
-       ; let (usages,matches') = unzip umatches
-       ; tcEmitBindingUsage $ supUEs usages
-       ; pat_tys  <- mapM readScaledExpType pat_tys
-       ; rhs_ty   <- readExpType rhs_ty
-       ; return (MG { mg_alts   = L l matches'
-                    , mg_ext    = MatchGroupTc pat_tys rhs_ty origin
-                    }) }
-
--------------
-tcMatch :: (AnnoBody body) => TcMatchCtxt body
-        -> [Scaled ExpSigmaType]        -- Expected pattern types
-        -> ExpRhoType            -- Expected result-type of the Match.
-        -> LMatch GhcRn (LocatedA (body GhcRn))
-        -> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
-
-tcMatch ctxt pat_tys rhs_ty match
-  = wrapLocMA (tc_match ctxt pat_tys rhs_ty) match
-  where
-    tc_match ctxt pat_tys rhs_ty
-             match@(Match { m_pats = pats, m_grhss = grhss })
-      = add_match_ctxt match $
-        do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
-                                tcGRHSs ctxt grhss rhs_ty
-           ; return (Match { m_ext = noAnn
-                           , m_ctxt = mc_what ctxt, m_pats = pats'
-                           , m_grhss = grhss' }) }
-
-        -- For (\x -> e), tcExpr has already said "In the expression \x->e"
-        -- so we don't want to add "In the lambda abstraction \x->e"
-    add_match_ctxt match thing_inside
-        = case mc_what ctxt of
-            LambdaExpr -> thing_inside
-            _          -> addErrCtxt (pprMatchInCtxt match) thing_inside
-
--------------
-tcGRHSs :: AnnoBody body
-        => TcMatchCtxt body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType
-        -> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
-
--- Notice that we pass in the full res_ty, so that we get
--- good inference from simple things like
---      f = \(x::forall a.a->a) -> <stuff>
--- We used to force it to be a monotype when there was more than one guard
--- but we don't need to do that any more
-
-tcGRHSs ctxt (GRHSs _ grhss binds) res_ty
-  = do  { (binds', ugrhss)
-            <- tcLocalBinds binds $
-               mapM (tcCollectingUsage . wrapLocMA (tcGRHS ctxt res_ty)) grhss
-        ; let (usages, grhss') = unzip ugrhss
-        ; tcEmitBindingUsage $ supUEs usages
-        ; return (GRHSs emptyComments grhss' binds') }
-
--------------
-tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (LocatedA (body GhcRn))
-       -> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
-
-tcGRHS ctxt res_ty (GRHS _ guards rhs)
-  = do  { (guards', rhs')
-            <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
-               mc_body ctxt rhs
-        ; return (GRHS noAnn guards' rhs') }
-  where
-    stmt_ctxt  = PatGuard (mc_what ctxt)
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
-*                                                                      *
-************************************************************************
--}
-
-tcDoStmts :: HsDoFlavour
-          -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)]
-          -> ExpRhoType
-          -> TcM (HsExpr GhcTc)          -- Returns a HsDo
-tcDoStmts ListComp (L l stmts) res_ty
-  = do  { res_ty <- expTypeToType res_ty
-        ; (co, elt_ty) <- matchExpectedListTy res_ty
-        ; let list_ty = mkListTy elt_ty
-        ; stmts' <- tcStmts (HsDoStmt ListComp) (tcLcStmt listTyCon) stmts
-                            (mkCheckExpType elt_ty)
-        ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
-
-tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty
-  = do  { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
-        ; res_ty <- readExpType res_ty
-        ; return (HsDo res_ty doExpr (L l stmts')) }
-
-tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty
-  = do  { stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty
-        ; res_ty <- readExpType res_ty
-        ; return (HsDo res_ty mDoExpr (L l stmts')) }
-
-tcDoStmts MonadComp (L l stmts) res_ty
-  = do  { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty
-        ; res_ty <- readExpType res_ty
-        ; return (HsDo res_ty MonadComp (L l stmts')) }
-tcDoStmts ctxt@GhciStmtCtxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt)
-
-tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
-tcBody body res_ty
-  = do  { traceTc "tcBody" (ppr res_ty)
-        ; tcMonoExpr body res_ty
-        }
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{tcStmts}
-*                                                                      *
-************************************************************************
--}
-
-type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
-type TcCmdStmtChecker  = TcStmtChecker HsCmd  TcRhoType
-
-type TcStmtChecker body rho_type
-  =  forall thing. HsStmtContext GhcTc
-                -> Stmt GhcRn (LocatedA (body GhcRn))
-                -> rho_type                 -- Result type for comprehension
-                -> (rho_type -> TcM thing)  -- Checker for what follows the stmt
-                -> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing)
-
-tcStmts :: (AnnoBody body) => HsStmtContext GhcTc
-        -> TcStmtChecker body rho_type   -- NB: higher-rank type
-        -> [LStmt GhcRn (LocatedA (body GhcRn))]
-        -> rho_type
-        -> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
-tcStmts ctxt stmt_chk stmts res_ty
-  = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
-                        const (return ())
-       ; return stmts' }
-
-tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcTc
-               -> TcStmtChecker body rho_type    -- NB: higher-rank type
-               -> [LStmt GhcRn (LocatedA (body GhcRn))]
-               -> rho_type
-               -> (rho_type -> TcM thing)
-               -> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
-
--- Note the higher-rank type.  stmt_chk is applied at different
--- types in the equations for tcStmts
-
-tcStmtsAndThen _ _ [] res_ty thing_inside
-  = do  { thing <- thing_inside res_ty
-        ; return ([], thing) }
-
--- LetStmts are handled uniformly, regardless of context
-tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x binds) : stmts)
-                                                             res_ty thing_inside
-  = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
-              tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
-        ; return (L loc (LetStmt x binds') : stmts', thing) }
-
--- Don't set the error context for an ApplicativeStmt.  It ought to be
--- possible to do this with a popErrCtxt in the tcStmt case for
--- ApplicativeStmt, but it did something strange and broke a test (ado002).
-tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
-  | ApplicativeStmt{} <- stmt
-  = do  { (stmt', (stmts', thing)) <-
-             stmt_chk ctxt stmt res_ty $ \ res_ty' ->
-               tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $
-                 thing_inside
-        ; return (L loc stmt' : stmts', thing) }
-
-  -- For the vanilla case, handle the location-setting part
-  | otherwise
-  = do  { (stmt', (stmts', thing)) <-
-                setSrcSpanA loc                             $
-                addErrCtxt (pprStmtInCtxt ctxt stmt)        $
-                stmt_chk ctxt stmt res_ty                   $ \ res_ty' ->
-                popErrCtxt                                  $
-                tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $
-                thing_inside
-        ; return (L loc stmt' : stmts', thing) }
-
----------------------------------------------------
---              Pattern guards
----------------------------------------------------
-
-tcGuardStmt :: TcExprStmtChecker
-tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside
-  = do  { guard' <- tcScalingUsage ManyTy $ tcCheckMonoExpr guard boolTy
-          -- Scale the guard to Many (see #19120 and #19193)
-        ; thing  <- thing_inside res_ty
-        ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }
-
-tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside
-  = do  { -- The Many on the next line and the unrestricted on the line after
-          -- are linked. These must be the same multiplicity. Consider
-          --   x <- rhs -> u
-          --
-          -- The multiplicity of x in u must be the same as the multiplicity at
-          -- which the rhs has been consumed. When solving #18738, we want these
-          -- two multiplicity to still be the same.
-          (rhs', rhs_ty) <- tcScalingUsage ManyTy $ tcInferRhoNC rhs
-                                   -- Stmt has a context already
-        ; hasFixedRuntimeRep_syntactic FRRBindStmtGuard rhs_ty
-        ; (pat', thing)  <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
-                                         pat (unrestricted rhs_ty) $
-                            thing_inside res_ty
-        ; return (mkTcBindStmt pat' rhs', thing) }
-
-tcGuardStmt _ stmt _ _
-  = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
-
-
----------------------------------------------------
---           List comprehensions
---               (no rebindable syntax)
----------------------------------------------------
-
--- Dealt with separately, rather than by tcMcStmt, because
---   a) We have special desugaring rules for list comprehensions,
---      which avoid creating intermediate lists.  They in turn
---      assume that the bind/return operations are the regular
---      polymorphic ones, and in particular don't have any
---      coercion matching stuff in them.  It's hard to avoid the
---      potential for non-trivial coercions in tcMcStmt
-
-tcLcStmt :: TyCon       -- The list type constructor ([])
-         -> TcExprStmtChecker
-
-tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside
-  = do { body' <- tcMonoExprNC body elt_ty
-       ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
-       ; return (LastStmt x body' noret noSyntaxExpr, thing) }
-
--- A generator, pat <- rhs
-tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside
- = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind
-        ; rhs'   <- tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty])
-        ; (pat', thing)  <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
-                            thing_inside elt_ty
-        ; return (mkTcBindStmt pat' rhs', thing) }
-
--- A boolean guard
-tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside
-  = do  { rhs'  <- tcCheckMonoExpr rhs boolTy
-        ; thing <- thing_inside elt_ty
-        ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) }
-
--- ParStmt: See notes with tcMcStmt
-tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside
-  = do  { (pairs', thing) <- loop bndr_stmts_s
-        ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) }
-  where
-    -- loop :: [([LStmt GhcRn], [GhcRn])]
-    --      -> TcM ([([LStmt GhcTc], [GhcTc])], thing)
-    loop [] = do { thing <- thing_inside elt_ty
-                 ; return ([], thing) }         -- matching in the branches
-
-    loop (ParStmtBlock x stmts names _ : pairs)
-      = do { (stmts', (ids, pairs', thing))
-                <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
-                   do { ids <- tcLookupLocalIds names
-                      ; (pairs', thing) <- loop pairs
-                      ; return (ids, pairs', thing) }
-           ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }
-
-tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
-                              , trS_bndrs =  bindersMap
-                              , trS_by = by, trS_using = using }) elt_ty thing_inside
-  = do { let (bndr_names, n_bndr_names) = unzip bindersMap
-             unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
-             -- The inner 'stmts' lack a LastStmt, so the element type
-             --  passed in to tcStmtsAndThen is never looked at
-       ; (stmts', (bndr_ids, by'))
-            <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
-               { by' <- traverse tcInferRho by
-               ; bndr_ids <- tcLookupLocalIds bndr_names
-               ; return (bndr_ids, by') }
-
-       ; let m_app ty = mkTyConApp m_tc [ty]
-
-       --------------- Typecheck the 'using' function -------------
-       -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m      (ThenForm)
-       --       :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c)))  (GroupForm)
-
-         -- n_app :: Type -> Type   -- Wraps a 'ty' into '[ty]' for GroupForm
-       ; let n_app = case form of
-                       ThenForm -> (\ty -> ty)
-                       _        -> m_app
-
-             by_arrow :: Type -> Type     -- Wraps 'ty' to '(a->t) -> ty' if the By is present
-             by_arrow = case by' of
-                          Nothing       -> \ty -> ty
-                          Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTyMany` e_ty) `mkVisFunTyMany` ty
-
-             tup_ty        = mkBigCoreVarTupTy bndr_ids
-             poly_arg_ty   = m_app alphaTy
-             poly_res_ty   = m_app (n_app alphaTy)
-             using_poly_ty = mkInfForAllTy alphaTyVar $
-                             by_arrow $
-                             poly_arg_ty `mkVisFunTyMany` poly_res_ty
-
-       ; using' <- tcCheckPolyExpr using using_poly_ty
-       ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
-
-             -- 'stmts' returns a result of type (m1_ty tuple_ty),
-             -- typically something like [(Int,Bool,Int)]
-             -- We don't know what tuple_ty is yet, so we use a variable
-       ; let mk_n_bndr :: Name -> TcId -> TcId
-             mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name ManyTy (n_app (idType bndr_id))
-
-             -- Ensure that every old binder of type `b` is linked up with its
-             -- new binder which should have type `n b`
-             -- See Note [TransStmt binder map] in GHC.Hs.Expr
-             n_bndr_ids  = zipWith mk_n_bndr n_bndr_names bndr_ids
-             bindersMap' = bndr_ids `zip` n_bndr_ids
-
-       -- Type check the thing in the environment with
-       -- these new binders and return the result
-       ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
-
-       ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
-                           , trS_by = fmap fst by', trS_using = final_using
-                           , trS_ret = noSyntaxExpr
-                           , trS_bind = noSyntaxExpr
-                           , trS_fmap = noExpr
-                           , trS_ext = unitTy
-                           , trS_form = form }, thing) }
-
-tcLcStmt _ _ stmt _ _
-  = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
-
-
----------------------------------------------------
---           Monad comprehensions
---        (supports rebindable syntax)
----------------------------------------------------
-
-tcMcStmt :: TcExprStmtChecker
-
-tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside
-  = do  { (body', return_op')
-            <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $
-               \ [a_ty] [mult]->
-               tcScalingUsage mult $ tcCheckMonoExprNC body a_ty
-        ; thing      <- thing_inside (panic "tcMcStmt: thing_inside")
-        ; return (LastStmt x body' noret return_op', thing) }
-
--- Generators for monad comprehensions ( pat <- rhs )
---
---   [ body | q <- gen ]  ->  gen :: m a
---                            q   ::   a
---
-
-tcMcStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside
-           -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
-  = do  { ((rhs_ty, rhs', pat_mult, pat', thing, new_res_ty), bind_op')
-            <- tcSyntaxOp MCompOrigin (xbsrn_bindOp xbsrn)
-                          [SynRho, SynFun SynAny SynRho] res_ty $
-               \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult, fun_mult, pat_mult] ->
-               do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty
-                  ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $
-                                     thing_inside (mkCheckExpType new_res_ty)
-                  ; return (rhs_ty, rhs', pat_mult, pat', thing, new_res_ty) }
-
-        ; hasFixedRuntimeRep_syntactic (FRRBindStmt MonadComprehension) rhs_ty
-
-        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
-        ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->
-            tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty
-
-        ; let xbstc = XBindStmtTc
-                { xbstc_bindOp = bind_op'
-                , xbstc_boundResultType = new_res_ty
-                , xbstc_boundResultMult = pat_mult
-                , xbstc_failOp = fail_op'
-                }
-        ; return (BindStmt xbstc pat' rhs', thing) }
-
--- Boolean expressions.
---
---   [ body | stmts, expr ]  ->  expr :: m Bool
---
-tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside
-  = do  { -- Deal with rebindable syntax:
-          --    guard_op :: test_ty -> rhs_ty
-          --    then_op  :: rhs_ty -> new_res_ty -> res_ty
-          -- Where test_ty is, for example, Bool
-        ; ((thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op'), then_op')
-            <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $
-               \ [rhs_ty, new_res_ty] [rhs_mult, fun_mult] ->
-               do { ((rhs', test_ty), guard_op')
-                      <- tcScalingUsage rhs_mult $
-                         tcSyntaxOp MCompOrigin guard_op [SynAny]
-                                    (mkCheckExpType rhs_ty) $
-                         \ [test_ty] [test_mult] -> do
-                           rhs' <- tcScalingUsage test_mult $ tcCheckMonoExpr rhs test_ty
-                           return $ (rhs', test_ty)
-                  ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty)
-                  ; return (thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op') }
-
-        ; hasFixedRuntimeRep_syntactic FRRBodyStmtGuard test_ty
-        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt MonadComprehension 1) rhs_ty
-        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt MonadComprehension 2) new_res_ty
-
-        ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) }
-
--- Grouping statements
---
---   [ body | stmts, then group by e using f ]
---     ->  e :: t
---         f :: forall a. (a -> t) -> m a -> m (m a)
---   [ body | stmts, then group using f ]
---     ->  f :: forall a. m a -> m (m a)
-
--- We type [ body | (stmts, group by e using f), ... ]
---     f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
---
--- We type the functions as follows:
---     f <optional by> :: m1 (a,b,c) -> m2 (a,b,c)              (ThenForm)
---                     :: m1 (a,b,c) -> m2 (n (a,b,c))          (GroupForm)
---     (>>=) :: m2 (a,b,c)     -> ((a,b,c)   -> res) -> res     (ThenForm)
---           :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res     (GroupForm)
---
-tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
-                         , trS_by = by, trS_using = using, trS_form = form
-                         , trS_ret = return_op, trS_bind = bind_op
-                         , trS_fmap = fmap_op }) res_ty thing_inside
-  = do { m1_ty   <- newFlexiTyVarTy typeToTypeKind
-       ; m2_ty   <- newFlexiTyVarTy typeToTypeKind
-       ; tup_ty  <- newFlexiTyVarTy liftedTypeKind
-       ; by_e_ty <- newFlexiTyVarTy liftedTypeKind  -- The type of the 'by' expression (if any)
-
-         -- n_app :: Type -> Type   -- Wraps a 'ty' into '(n ty)' for GroupForm
-       ; n_app <- case form of
-                    ThenForm -> return (\ty -> ty)
-                    _        -> do { n_ty <- newFlexiTyVarTy typeToTypeKind
-                                   ; return (n_ty `mkAppTy`) }
-       ; let by_arrow :: Type -> Type
-             -- (by_arrow res) produces ((alpha->e_ty) -> res)     ('by' present)
-             --                          or res                    ('by' absent)
-             by_arrow = case by of
-                          Nothing -> \res -> res
-                          Just {} -> \res -> (alphaTy `mkVisFunTyMany` by_e_ty) `mkVisFunTyMany` res
-
-             poly_arg_ty  = m1_ty `mkAppTy` alphaTy
-             using_arg_ty = m1_ty `mkAppTy` tup_ty
-             poly_res_ty  = m2_ty `mkAppTy` n_app alphaTy
-             using_res_ty = m2_ty `mkAppTy` n_app tup_ty
-             using_poly_ty = mkInfForAllTy alphaTyVar $
-                             by_arrow $
-                             poly_arg_ty `mkVisFunTyMany` poly_res_ty
-
-             -- 'stmts' returns a result of type (m1_ty tuple_ty),
-             -- typically something like [(Int,Bool,Int)]
-             -- We don't know what tuple_ty is yet, so we use a variable
-       ; let (bndr_names, n_bndr_names) = unzip bindersMap
-       ; (stmts', (bndr_ids, by', return_op')) <-
-            tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts
-                           (mkCheckExpType using_arg_ty) $ \res_ty' -> do
-                { by' <- case by of
-                           Nothing -> return Nothing
-                           Just e  -> do { e' <- tcCheckMonoExpr e by_e_ty
-                                         ; return (Just e') }
-
-                -- Find the Ids (and hence types) of all old binders
-                ; bndr_ids <- tcLookupLocalIds bndr_names
-
-                -- 'return' is only used for the binders, so we know its type.
-                --   return :: (a,b,c,..) -> m (a,b,c,..)
-                ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op
-                                       [synKnownType (mkBigCoreVarTupTy bndr_ids)]
-                                       res_ty' $ \ _ _ -> return ()
-
-                ; return (bndr_ids, by', return_op') }
-
-       --------------- Typecheck the 'bind' function -------------
-       -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
-       ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
-       ; (_, bind_op')  <- tcSyntaxOp MCompOrigin bind_op
-                             [ synKnownType using_res_ty
-                             , synKnownType (n_app tup_ty `mkVisFunTyMany` new_res_ty) ]
-                             res_ty $ \ _ _ -> return ()
-
-       --------------- Typecheck the 'fmap' function -------------
-       ; fmap_op' <- case form of
-                       ThenForm -> return noExpr
-                       _ -> fmap unLoc . tcCheckPolyExpr (noLocA fmap_op) $
-                            mkInfForAllTy alphaTyVar $
-                            mkInfForAllTy betaTyVar  $
-                            (alphaTy `mkVisFunTyMany` betaTy)
-                            `mkVisFunTyMany` (n_app alphaTy)
-                            `mkVisFunTyMany` (n_app betaTy)
-
-       --------------- Typecheck the 'using' function -------------
-       -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
-
-       ; using' <- tcCheckPolyExpr using using_poly_ty
-       ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
-
-       --------------- Building the bindersMap ----------------
-       ; let mk_n_bndr :: Name -> TcId -> TcId
-             mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name ManyTy (n_app (idType bndr_id))
-
-             -- Ensure that every old binder of type `b` is linked up with its
-             -- new binder which should have type `n b`
-             -- See Note [TransStmt binder map] in GHC.Hs.Expr
-             n_bndr_ids = zipWithEqual "tcMcStmt" mk_n_bndr n_bndr_names bndr_ids
-             bindersMap' = bndr_ids `zip` n_bndr_ids
-
-       -- Type check the thing in the environment with
-       -- these new binders and return the result
-       ; thing <- tcExtendIdEnv n_bndr_ids $
-                  thing_inside (mkCheckExpType new_res_ty)
-
-       ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
-                           , trS_by = by', trS_using = final_using
-                           , trS_ret = return_op', trS_bind = bind_op'
-                           , trS_ext = n_app tup_ty
-                           , trS_fmap = fmap_op', trS_form = form }, thing) }
-
--- A parallel set of comprehensions
---      [ (g x, h x) | ... ; let g v = ...
---                   | ... ; let h v = ... ]
---
--- It's possible that g,h are overloaded, so we need to feed the LIE from the
--- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
--- Similarly if we had an existential pattern match:
---
---      data T = forall a. Show a => C a
---
---      [ (show x, show y) | ... ; C x <- ...
---                         | ... ; C y <- ... ]
---
--- Then we need the LIE from (show x, show y) to be simplified against
--- the bindings for x and y.
---
--- It's difficult to do this in parallel, so we rely on the renamer to
--- ensure that g,h and x,y don't duplicate, and simply grow the environment.
--- So the binders of the first parallel group will be in scope in the second
--- group.  But that's fine; there's no shadowing to worry about.
---
--- Note: The `mzip` function will get typechecked via:
---
---   ParStmt [st1::t1, st2::t2, st3::t3]
---
---   mzip :: m st1
---        -> (m st2 -> m st3 -> m (st2, st3))   -- recursive call
---        -> m (st1, (st2, st3))
---
-tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside
-  = do { m_ty   <- newFlexiTyVarTy typeToTypeKind
-
-       ; let mzip_ty  = mkInfForAllTys [alphaTyVar, betaTyVar] $
-                        (m_ty `mkAppTy` alphaTy)
-                        `mkVisFunTyMany`
-                        (m_ty `mkAppTy` betaTy)
-                        `mkVisFunTyMany`
-                        (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
-       ; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLocA mzip_op) mzip_ty
-
-        -- type dummies since we don't know all binder types yet
-       ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
-                       [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ]
-
-       -- Typecheck bind:
-       ; let tup_tys  = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]
-             tuple_ty = mk_tuple_ty tup_tys
-
-       ; (((blocks', thing), inner_res_ty), bind_op')
-           <- tcSyntaxOp MCompOrigin bind_op
-                         [ synKnownType (m_ty `mkAppTy` tuple_ty)
-                         , SynFun (synKnownType tuple_ty) SynRho ] res_ty $
-              \ [inner_res_ty] _ ->
-              do { stuff <- loop m_ty (mkCheckExpType inner_res_ty)
-                                 tup_tys bndr_stmts_s
-                 ; return (stuff, inner_res_ty) }
-
-       ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) }
-
-  where
-    mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
-
-       -- loop :: Type                                  -- m_ty
-       --      -> ExpRhoType                            -- inner_res_ty
-       --      -> [TcType]                              -- tup_tys
-       --      -> [ParStmtBlock Name]
-       --      -> TcM ([([LStmt GhcTc], [TcId])], thing)
-    loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty
-                                   ; return ([], thing) }
-                                   -- matching in the branches
-
-    loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)
-                           (ParStmtBlock x stmts names return_op : pairs)
-      = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in
-           ; (stmts', (ids, return_op', pairs', thing))
-                <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $
-                   \m_tup_ty' ->
-                   do { ids <- tcLookupLocalIds names
-                      ; let tup_ty = mkBigCoreVarTupTy ids
-                      ; (_, return_op') <-
-                          tcSyntaxOp MCompOrigin return_op
-                                     [synKnownType tup_ty] m_tup_ty' $
-                                     \ _ _ -> return ()
-                      ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs
-                      ; return (ids, return_op', pairs', thing) }
-           ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) }
-    loop _ _ _ _ = panic "tcMcStmt.loop"
-
-tcMcStmt _ stmt _ _
-  = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
-
-
----------------------------------------------------
---           Do-notation
---        (supports rebindable syntax)
----------------------------------------------------
-
-tcDoStmt :: TcExprStmtChecker
-
-tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside
-  = do { body' <- tcMonoExprNC body res_ty
-       ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
-       ; return (LastStmt x body' noret noSyntaxExpr, thing) }
-
-tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside
-  = do  {       -- Deal with rebindable syntax:
-                --       (>>=) :: rhs_ty ->_rhs_mult (pat_ty ->_pat_mult new_res_ty) ->_fun_mult res_ty
-                -- This level of generality is needed for using do-notation
-                -- in full generality; see #1537
-
-          ((rhs_ty, rhs', pat_mult, pat', new_res_ty, thing), bind_op')
-            <- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $
-                \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult,fun_mult,pat_mult] ->
-                do { rhs' <-tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty
-                   ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $
-                                      thing_inside (mkCheckExpType new_res_ty)
-                   ; return (rhs_ty, rhs', pat_mult, pat', new_res_ty, thing) }
-
-        ; hasFixedRuntimeRep_syntactic (FRRBindStmt DoNotation) rhs_ty
-
-        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
-        ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->
-            tcMonadFailOp (DoPatOrigin pat) pat' fail new_res_ty
-        ; let xbstc = XBindStmtTc
-                { xbstc_bindOp = bind_op'
-                , xbstc_boundResultType = new_res_ty
-                , xbstc_boundResultMult = pat_mult
-                , xbstc_failOp = fail_op'
-                }
-        ; return (BindStmt xbstc pat' rhs', thing) }
-
-tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside
-  = do  { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
-                                thing_inside . mkCheckExpType
-        ; ((pairs', body_ty, thing), mb_join') <- case mb_join of
-            Nothing -> (, Nothing) <$> tc_app_stmts res_ty
-            Just join_op ->
-              second Just <$>
-              (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $
-               \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty))
-
-        ; return (ApplicativeStmt body_ty pairs' mb_join', thing) }
-
-tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside
-  = do  {       -- Deal with rebindable syntax;
-                --   (>>) :: rhs_ty -> new_res_ty -> res_ty
-        ; ((rhs', rhs_ty, new_res_ty, thing), then_op')
-            <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $
-               \ [rhs_ty, new_res_ty] [rhs_mult,fun_mult] ->
-               do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty
-                  ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty)
-                  ; return (rhs', rhs_ty, new_res_ty, thing) }
-        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 1) rhs_ty
-        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 2) new_res_ty
-        ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }
-
-tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names
-                       , recS_rec_ids = rec_names, recS_ret_fn = ret_op
-                       , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
-         res_ty thing_inside
-  = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
-        ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
-        ; let tup_ids = zipWith (\n t -> mkLocalId n ManyTy t) tup_names tup_elt_tys
-                -- Many because it's a recursive definition
-              tup_ty  = mkBigCoreTupTy tup_elt_tys
-
-        ; tcExtendIdEnv tup_ids $ do
-        { ((stmts', (ret_op', tup_rets)), stmts_ty)
-                <- tcInfer $ \ exp_ty ->
-                   tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty ->
-                   do { tup_rets <- zipWithM tcCheckId tup_names
-                                      (map mkCheckExpType tup_elt_tys)
-                             -- Unify the types of the "final" Ids (which may
-                             -- be polymorphic) with those of "knot-tied" Ids
-                      ; (_, ret_op')
-                          <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty]
-                                        inner_res_ty $ \_ _ -> return ()
-                      ; return (ret_op', tup_rets) }
-
-        ; ((_, mfix_op'), mfix_res_ty)
-            <- tcInfer $ \ exp_ty ->
-               tcSyntaxOp DoOrigin mfix_op
-                          [synKnownType (mkVisFunTyMany tup_ty stmts_ty)] exp_ty $
-               \ _ _ -> return ()
-
-        ; ((thing, new_res_ty), bind_op')
-            <- tcSyntaxOp DoOrigin bind_op
-                          [ synKnownType mfix_res_ty
-                          , SynFun (synKnownType tup_ty) SynRho ]
-                          res_ty $
-               \ [new_res_ty] _ ->
-               do { thing <- thing_inside (mkCheckExpType new_res_ty)
-                  ; return (thing, new_res_ty) }
-
-        ; let rec_ids = takeList rec_names tup_ids
-        ; later_ids <- tcLookupLocalIds later_names
-        ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
-                                 ppr later_ids <+> ppr (map idType later_ids)]
-        ; return (RecStmt { recS_stmts = L l stmts', recS_later_ids = later_ids
-                          , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
-                          , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
-                          , recS_ext = RecStmtTc
-                            { recS_bind_ty = new_res_ty
-                            , recS_later_rets = []
-                            , recS_rec_rets = tup_rets
-                            , recS_ret_ty = stmts_ty} }, thing)
-        }}
-
-tcDoStmt _ stmt _ _
-  = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
-
-
-
----------------------------------------------------
--- MonadFail Proposal warnings
----------------------------------------------------
-
--- The idea behind issuing MonadFail warnings is that we add them whenever a
--- failable pattern is encountered. However, instead of throwing a type error
--- when the constraint cannot be satisfied, we only issue a warning in
--- "GHC.Tc.Errors".
-
-tcMonadFailOp :: CtOrigin
-              -> LPat GhcTc
-              -> SyntaxExpr GhcRn    -- The fail op
-              -> TcType              -- Type of the whole do-expression
-              -> TcRn (FailOperator GhcTc)  -- Typechecked fail op
--- Get a 'fail' operator expression, to use if the pattern match fails.
--- This won't be used in cases where we've already determined the pattern
--- match can't fail (so the fail op is Nothing), however, it seems that the
--- isIrrefutableHsPat test is still required here for some reason I haven't
--- yet determined.
-tcMonadFailOp orig pat fail_op res_ty = do
-    dflags <- getDynFlags
-    if isIrrefutableHsPat dflags pat
-      then return Nothing
-      else Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
-                            (mkCheckExpType res_ty) $ \_ _ -> return ())
-
-{-
-Note [Treat rebindable syntax first]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When typechecking
-        do { bar; ... } :: IO ()
-we want to typecheck 'bar' in the knowledge that it should be an IO thing,
-pushing info from the context into the RHS.  To do this, we check the
-rebindable syntax first, and push that information into (tcLExprNC rhs).
-Otherwise the error shows up when checking the rebindable syntax, and
-the expected/inferred stuff is back to front (see #3613).
-
-Note [typechecking ApplicativeStmt]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en)
-
-fresh type variables:
-   pat_ty_1..pat_ty_n
-   exp_ty_1..exp_ty_n
-   t_1..t_(n-1)
-
-body  :: body_ty
-(\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty
-pat_i :: pat_ty_i
-e_i   :: exp_ty_i
-<$>   :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1
-<*>_i :: t_(i-1) -> exp_ty_i -> t_i
-join :: tn -> res_ty
--}
-
-tcApplicativeStmts
-  :: HsStmtContext GhcTc
-  -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
-  -> ExpRhoType                         -- rhs_ty
-  -> (TcRhoType -> TcM t)               -- thing_inside
-  -> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Type, t)
-
-tcApplicativeStmts ctxt pairs rhs_ty thing_inside
- = do { body_ty <- newFlexiTyVarTy liftedTypeKind
-      ; let arity = length pairs
-      ; ts <- replicateM (arity-1) $ newInferExpType
-      ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
-      ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
-      ; let fun_ty = mkVisFunTysMany pat_tys body_ty
-
-       -- NB. do the <$>,<*> operators first, we don't want type errors here
-       --     i.e. goOps before goArgs
-       -- See Note [Treat rebindable syntax first]
-      ; let (ops, args) = unzip pairs
-      ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
-
-      -- Typecheck each ApplicativeArg separately
-      -- See Note [ApplicativeDo and constraints]
-      ; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys)
-
-      -- Bring into scope all the things bound by the args,
-      -- and typecheck the thing_inside
-      -- See Note [ApplicativeDo and constraints]
-      ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $
-               thing_inside body_ty
-
-      ; return (zip ops' args', body_ty, res) }
-  where
-    goOps _ [] = return []
-    goOps t_left ((op,t_i,exp_ty) : ops)
-      = do { (_, op')
-               <- tcSyntaxOp DoOrigin op
-                             [synKnownType t_left, synKnownType exp_ty] t_i $
-                   \ _ _ -> return ()
-           ; t_i <- readExpType t_i
-           ; ops' <- goOps t_i ops
-           ; return (op' : ops') }
-
-    goArg :: Type -> (ApplicativeArg GhcRn, Type, Type)
-          -> TcM (ApplicativeArg GhcTc)
-
-    goArg body_ty (ApplicativeArgOne
-                    { xarg_app_arg_one = fail_op
-                    , app_arg_pattern = pat
-                    , arg_expr = rhs
-                    , ..
-                    }, pat_ty, exp_ty)
-      = setSrcSpan (combineSrcSpans (getLocA pat) (getLocA rhs)) $
-        addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs))   $
-        do { rhs'      <- tcCheckMonoExprNC rhs exp_ty
-           ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
-                          return ()
-           ; fail_op' <- fmap join . forM fail_op $ \fail ->
-               tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty
-
-           ; return (ApplicativeArgOne
-                      { xarg_app_arg_one = fail_op'
-                      , app_arg_pattern = pat'
-                      , arg_expr        = rhs'
-                      , .. }
-                    ) }
-
-    goArg _body_ty (ApplicativeArgMany x stmts ret pat ctxt, pat_ty, exp_ty)
-      = do { (stmts', (ret',pat')) <-
-                tcStmtsAndThen (HsDoStmt ctxt) tcDoStmt stmts (mkCheckExpType exp_ty) $
-                \res_ty  -> do
-                  { ret'      <- tcExpr ret res_ty
-                  ; (pat', _) <- tcCheckPat (StmtCtxt (HsDoStmt ctxt)) pat (unrestricted pat_ty) $
-                                 return ()
-                  ; return (ret', pat')
-                  }
-           ; return (ApplicativeArgMany x stmts' ret' pat' ctxt) }
-
-    get_arg_bndrs :: ApplicativeArg GhcTc -> [Id]
-    get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders CollNoDictBinders pat
-    get_arg_bndrs (ApplicativeArgMany { bv_pattern =  pat })    = collectPatBinders CollNoDictBinders pat
-
-{- Note [ApplicativeDo and constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-An applicative-do is supposed to take place in parallel, so
-constraints bound in one arm can't possibly be available in another
-(#13242).  Our current rule is this (more details and discussion
-on the ticket). Consider
-
-   ...stmts...
-   ApplicativeStmts [arg1, arg2, ... argN]
-   ...more stmts...
-
-where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts.
-Now, we say that:
-
-* Constraints required by the argi can be solved from
-  constraint bound by ...stmts...
-
-* Constraints and existentials bound by the argi are not available
-  to solve constraints required either by argj (where i /= j),
-  or by ...more stmts....
-
-* Within the stmts of each 'argi' individually, however, constraints bound
-  by earlier stmts can be used to solve later ones.
-
-To achieve this, we just typecheck each 'argi' separately, bring all
-the variables they bind into scope, and typecheck the thing_inside.
-
-************************************************************************
-*                                                                      *
-\subsection{Errors and contexts}
-*                                                                      *
-************************************************************************
-
-@checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same
-number of args are used in each equation.
--}
-
-checkArgCounts :: AnnoBody body
-               => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()
-checkArgCounts = check_match_pats . EquationArgs
-
--- @checkPatCounts@ takes a @[RenamedMatch]@ and decides whether the same
--- number of patterns are used in each alternative
-checkPatCounts :: AnnoBody body
-               => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))
-               -> TcM ()
-checkPatCounts = check_match_pats . PatternArgs
-
-check_match_pats :: AnnoBody body
-                 => MatchArgsContext -> MatchGroup GhcRn (LocatedA (body GhcRn))
-                 -> TcM ()
-check_match_pats _ (MG { mg_alts = L _ [] })
-    = return ()
-check_match_pats matchContext (MG { mg_alts = L _ (match1:matches) })
-    | Just bad_matches <- mb_bad_matches
-    = failWithTc $ TcRnMatchesHaveDiffNumArgs matchContext
-                 $ MatchArgMatches match1 bad_matches
-    | otherwise
-    = return ()
-  where
-    n_args1 = args_in_match match1
-    mb_bad_matches = NE.nonEmpty [m | m <- matches, args_in_match m /= n_args1]
-
-    args_in_match :: (LocatedA (Match GhcRn body1) -> Int)
-    args_in_match (L _ (Match { m_pats = pats })) = length pats
diff --git a/compiler/GHC/Tc/Gen/Match.hs-boot b/compiler/GHC/Tc/Gen/Match.hs-boot
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Match.hs-boot
+++ /dev/null
@@ -1,17 +0,0 @@
-module GHC.Tc.Gen.Match where
-import GHC.Hs           ( GRHSs, MatchGroup, LHsExpr )
-import GHC.Tc.Types.Evidence  ( HsWrapper )
-import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType )
-import GHC.Tc.Types     ( TcM )
-import GHC.Hs.Extension ( GhcRn, GhcTc )
-import GHC.Parser.Annotation ( LocatedN )
-import GHC.Types.Id (Id)
-
-tcGRHSsPat    :: GRHSs GhcRn (LHsExpr GhcRn)
-              -> ExpRhoType
-              -> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-
-tcMatchesFun :: LocatedN Id
-             -> MatchGroup GhcRn (LHsExpr GhcRn)
-             -> ExpSigmaType
-             -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ /dev/null
@@ -1,1504 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
--- | Typechecking patterns
-module GHC.Tc.Gen.Pat
-   ( tcLetPat
-   , newLetBndr
-   , LetBndrSpec(..)
-   , tcCheckPat, tcCheckPat_O, tcInferPat
-   , tcPats
-   , addDataConStupidTheta
-   )
-where
-
-import GHC.Prelude
-
-import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho )
-
-import GHC.Hs
-import GHC.Hs.Syn.Type
-import GHC.Rename.Utils
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Zonk
-import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags )
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Instantiate
-import GHC.Types.FieldLabel
-import GHC.Types.Id
-import GHC.Types.Var
-import GHC.Types.Name
-import GHC.Types.Name.Reader
-import GHC.Core.Multiplicity
-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Validity( arityErr )
-import GHC.Core.TyCo.Ppr ( pprTyVars )
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.Unify
-import GHC.Tc.Gen.HsType
-import GHC.Builtin.Types
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.Origin
-import GHC.Core.TyCon
-import GHC.Core.Type
-import GHC.Core.Coercion
-import GHC.Core.DataCon
-import GHC.Core.PatSyn
-import GHC.Core.ConLike
-import GHC.Builtin.Names
-import GHC.Types.Basic hiding (SuccessFlag(..))
-import GHC.Driver.Session
-import GHC.Types.SrcLoc
-import GHC.Types.Var.Set
-import GHC.Utils.Misc
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import qualified GHC.LanguageExtensions as LangExt
-import Control.Arrow  ( second )
-import Control.Monad
-import GHC.Data.FastString
-import qualified Data.List.NonEmpty as NE
-import GHC.Data.List.SetOps ( getNth )
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-{-
-************************************************************************
-*                                                                      *
-                External interface
-*                                                                      *
-************************************************************************
--}
-
-tcLetPat :: (Name -> Maybe TcId)
-         -> LetBndrSpec
-         -> LPat GhcRn -> Scaled ExpSigmaTypeFRR
-         -> TcM a
-         -> TcM (LPat GhcTc, a)
-tcLetPat sig_fn no_gen pat pat_ty thing_inside
-  = do { bind_lvl <- getTcLevel
-       ; let ctxt = LetPat { pc_lvl    = bind_lvl
-                           , pc_sig_fn = sig_fn
-                           , pc_new    = no_gen }
-             penv = PE { pe_lazy = True
-                       , pe_ctxt = ctxt
-                       , pe_orig = PatOrigin }
-
-       ; tc_lpat pat_ty penv pat thing_inside }
-
------------------
-tcPats :: HsMatchContext GhcTc
-       -> [LPat GhcRn]             -- ^ atterns
-       -> [Scaled ExpSigmaTypeFRR] -- ^ types of the patterns
-       -> TcM a                    -- ^ checker for the body
-       -> TcM ([LPat GhcTc], a)
-
--- This is the externally-callable wrapper function
--- Typecheck the patterns, extend the environment to bind the variables,
--- do the thing inside, use any existentially-bound dictionaries to
--- discharge parts of the returning LIE, and deal with pattern type
--- signatures
-
---   1. Initialise the PatState
---   2. Check the patterns
---   3. Check the body
---   4. Check that no existentials escape
-
-tcPats ctxt pats pat_tys thing_inside
-  = tc_lpats pat_tys penv pats thing_inside
-  where
-    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
-
-tcInferPat :: FixedRuntimeRepContext
-           -> HsMatchContext GhcTc
-           -> LPat GhcRn
-           -> TcM a
-           -> TcM ((LPat GhcTc, a), TcSigmaTypeFRR)
-tcInferPat frr_orig ctxt pat thing_inside
-  = tcInferFRR frr_orig $ \ exp_ty ->
-    tc_lpat (unrestricted exp_ty) penv pat thing_inside
- where
-    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
-
-tcCheckPat :: HsMatchContext GhcTc
-           -> LPat GhcRn -> Scaled TcSigmaTypeFRR
-           -> TcM a                     -- Checker for body
-           -> TcM (LPat GhcTc, a)
-tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin
-
--- | A variant of 'tcPat' that takes a custom origin
-tcCheckPat_O :: HsMatchContext GhcTc
-             -> CtOrigin              -- ^ origin to use if the type needs inst'ing
-             -> LPat GhcRn -> Scaled TcSigmaTypeFRR
-             -> TcM a                 -- Checker for body
-             -> TcM (LPat GhcTc, a)
-tcCheckPat_O ctxt orig pat (Scaled pat_mult pat_ty) thing_inside
-  = tc_lpat (Scaled pat_mult (mkCheckExpType pat_ty)) penv pat thing_inside
-  where
-    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig }
-
-
-{-
-************************************************************************
-*                                                                      *
-                PatEnv, PatCtxt, LetBndrSpec
-*                                                                      *
-************************************************************************
--}
-
-data PatEnv
-  = PE { pe_lazy :: Bool        -- True <=> lazy context, so no existentials allowed
-       , pe_ctxt :: PatCtxt     -- Context in which the whole pattern appears
-       , pe_orig :: CtOrigin    -- origin to use if the pat_ty needs inst'ing
-       }
-
-data PatCtxt
-  = LamPat   -- Used for lambdas, case etc
-       (HsMatchContext GhcTc)
-
-  | LetPat   -- Used only for let(rec) pattern bindings
-             -- See Note [Typing patterns in pattern bindings]
-       { pc_lvl    :: TcLevel
-                   -- Level of the binding group
-
-       , pc_sig_fn :: Name -> Maybe TcId
-                   -- Tells the expected type
-                   -- for binders with a signature
-
-       , pc_new :: LetBndrSpec
-                -- How to make a new binder
-       }        -- for binders without signatures
-
-data LetBndrSpec
-  = LetLclBndr            -- We are going to generalise, and wrap in an AbsBinds
-                          -- so clone a fresh binder for the local monomorphic Id
-
-  | LetGblBndr TcPragEnv  -- Generalisation plan is NoGen, so there isn't going
-                          -- to be an AbsBinds; So we must bind the global version
-                          -- of the binder right away.
-                          -- And here is the inline-pragma information
-
-instance Outputable LetBndrSpec where
-  ppr LetLclBndr      = text "LetLclBndr"
-  ppr (LetGblBndr {}) = text "LetGblBndr"
-
-makeLazy :: PatEnv -> PatEnv
-makeLazy penv = penv { pe_lazy = True }
-
-inPatBind :: PatEnv -> Bool
-inPatBind (PE { pe_ctxt = LetPat {} }) = True
-inPatBind (PE { pe_ctxt = LamPat {} }) = False
-
-{- *********************************************************************
-*                                                                      *
-                Binders
-*                                                                      *
-********************************************************************* -}
-
-tcPatBndr :: PatEnv -> Name -> Scaled ExpSigmaTypeFRR -> TcM (HsWrapper, TcId)
--- (coi, xp) = tcPatBndr penv x pat_ty
--- Then coi : pat_ty ~ typeof(xp)
---
-tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl    = bind_lvl
-                                      , pc_sig_fn = sig_fn
-                                      , pc_new    = no_gen } })
-          bndr_name exp_pat_ty
-  -- For the LetPat cases, see
-  -- Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind
-
-  | Just bndr_id <- sig_fn bndr_name   -- There is a signature
-  = do { wrap <- tc_sub_type penv (scaledThing exp_pat_ty) (idType bndr_id)
-           -- See Note [Subsumption check at pattern variables]
-       ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty)
-       ; return (wrap, bndr_id) }
-
-  | otherwise                          -- No signature
-  = do { (co, bndr_ty) <- case scaledThing exp_pat_ty of
-             Check pat_ty    -> promoteTcType bind_lvl pat_ty
-             Infer infer_res -> assert (bind_lvl == ir_lvl infer_res) $
-                                -- If we were under a constructor that bumped the
-                                -- level, we'd be in checking mode (see tcConArg)
-                                -- hence this assertion
-                                do { bndr_ty <- inferResultToType infer_res
-                                   ; return (mkNomReflCo bndr_ty, bndr_ty) }
-       ; let bndr_mult = scaledMult exp_pat_ty
-       ; bndr_id <- newLetBndr no_gen bndr_name bndr_mult bndr_ty
-       ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl
-                                          , ppr exp_pat_ty, ppr bndr_ty, ppr co
-                                          , ppr bndr_id ])
-       ; return (mkWpCastN co, bndr_id) }
-
-tcPatBndr _ bndr_name pat_ty
-  = do { let pat_mult = scaledMult pat_ty
-       ; pat_ty <- expTypeToType (scaledThing pat_ty)
-       ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty)
-       ; return (idHsWrapper, mkLocalIdOrCoVar bndr_name pat_mult pat_ty) }
-               -- We should not have "OrCoVar" here, this is a bug (#17545)
-               -- Whether or not there is a sig is irrelevant,
-               -- as this is local
-
-newLetBndr :: LetBndrSpec -> Name -> Mult -> TcType -> TcM TcId
--- Make up a suitable Id for the pattern-binder.
--- See Note [Typechecking pattern bindings], item (4) in GHC.Tc.Gen.Bind
---
--- In the polymorphic case when we are going to generalise
---    (plan InferGen, no_gen = LetLclBndr), generate a "monomorphic version"
---    of the Id; the original name will be bound to the polymorphic version
---    by the AbsBinds
--- In the monomorphic case when we are not going to generalise
---    (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds,
---    and we use the original name directly
-newLetBndr LetLclBndr name w ty
-  = do { mono_name <- cloneLocalName name
-       ; return (mkLocalId mono_name w ty) }
-newLetBndr (LetGblBndr prags) name w ty
-  = addInlinePrags (mkLocalId name w ty) (lookupPragEnv prags name)
-
-tc_sub_type :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
--- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt
--- Used during typechecking patterns
-tc_sub_type penv t1 t2 = tcSubTypePat (pe_orig penv) GenSigCtxt t1 t2
-
-{- Note [Subsumption check at pattern variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we come across a variable with a type signature, we need to do a
-subsumption, not equality, check against the context type.  e.g.
-
-    data T = MkT (forall a. a->a)
-      f :: forall b. [b]->[b]
-      MkT f = blah
-
-Since 'blah' returns a value of type T, its payload is a polymorphic
-function of type (forall a. a->a).  And that's enough to bind the
-less-polymorphic function 'f', but we need some impedance matching
-to witness the instantiation.
-
-
-************************************************************************
-*                                                                      *
-                The main worker functions
-*                                                                      *
-************************************************************************
-
-Note [Nesting]
-~~~~~~~~~~~~~~
-tcPat takes a "thing inside" over which the pattern scopes.  This is partly
-so that tcPat can extend the environment for the thing_inside, but also
-so that constraints arising in the thing_inside can be discharged by the
-pattern.
-
-This does not work so well for the ErrCtxt carried by the monad: we don't
-want the error-context for the pattern to scope over the RHS.
-Hence the getErrCtxt/setErrCtxt stuff in tcMultiple
--}
-
---------------------
-
-type Checker inp out =  forall r.
-                          PatEnv
-                       -> inp
-                       -> TcM r      -- Thing inside
-                       -> TcM ( out
-                              , r    -- Result of thing inside
-                              )
-
-tcMultiple :: Checker inp out -> Checker [inp] [out]
-tcMultiple tc_pat penv args thing_inside
-  = do  { err_ctxt <- getErrCtxt
-        ; let loop _ []
-                = do { res <- thing_inside
-                     ; return ([], res) }
-
-              loop penv (arg:args)
-                = do { (p', (ps', res))
-                                <- tc_pat penv arg $
-                                   setErrCtxt err_ctxt $
-                                   loop penv args
-                -- setErrCtxt: restore context before doing the next pattern
-                -- See Note [Nesting] above
-
-                     ; return (p':ps', res) }
-
-        ; loop penv args }
-
---------------------
-tc_lpat :: Scaled ExpSigmaTypeFRR
-        -> Checker (LPat GhcRn) (LPat GhcTc)
-tc_lpat pat_ty penv (L span pat) thing_inside
-  = setSrcSpanA span $
-    do  { (pat', res) <- maybeWrapPatCtxt pat (tc_pat pat_ty penv pat)
-                                          thing_inside
-        ; return (L span pat', res) }
-
-tc_lpats :: [Scaled ExpSigmaTypeFRR]
-         -> Checker [LPat GhcRn] [LPat GhcTc]
-tc_lpats tys penv pats
-  = assertPpr (equalLength pats tys) (ppr pats $$ ppr tys) $
-    tcMultiple (\ penv' (p,t) -> tc_lpat t penv' p)
-               penv
-               (zipEqual "tc_lpats" pats tys)
-
---------------------
--- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
-checkManyPattern :: Scaled a -> TcM HsWrapper
-checkManyPattern pat_ty = tcSubMult NonLinearPatternOrigin ManyTy (scaledMult pat_ty)
-
-tc_pat  :: Scaled ExpSigmaTypeFRR
-        -- ^ Fully refined result type
-        -> Checker (Pat GhcRn) (Pat GhcTc)
-        -- ^ Translated pattern
-
-tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
-
-  VarPat x (L l name) -> do
-        { (wrap, id) <- tcPatBndr penv name pat_ty
-        ; (res, mult_wrap) <- tcCheckUsage name (scaledMult pat_ty) $
-                              tcExtendIdEnv1 name id thing_inside
-            -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
-        ; pat_ty <- readExpType (scaledThing pat_ty)
-        ; return (mkHsWrapPat (wrap <.> mult_wrap) (VarPat x (L l id)) pat_ty, res) }
-
-  ParPat x lpar pat rpar -> do
-        { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
-        ; return (ParPat x lpar pat' rpar, res) }
-
-  BangPat x pat -> do
-        { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
-        ; return (BangPat x pat', res) }
-
-  LazyPat x pat -> do
-        { mult_wrap <- checkManyPattern pat_ty
-            -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
-        ; (pat', (res, pat_ct))
-                <- tc_lpat pat_ty (makeLazy penv) pat $
-                   captureConstraints thing_inside
-                -- Ignore refined penv', revert to penv
-
-        ; emitConstraints pat_ct
-        -- captureConstraints/extendConstraints:
-        --   see Note [Hopping the LIE in lazy patterns]
-
-        -- Check that the expected pattern type is itself lifted
-        ; pat_ty <- readExpType (scaledThing pat_ty)
-        ; _ <- unifyType Nothing (typeKind pat_ty) liftedTypeKind
-
-        ; return (mkHsWrapPat mult_wrap (LazyPat x pat') pat_ty, res) }
-
-  WildPat _ -> do
-        { mult_wrap <- checkManyPattern pat_ty
-            -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
-        ; res <- thing_inside
-        ; pat_ty <- expTypeToType (scaledThing pat_ty)
-        ; return (mkHsWrapPat mult_wrap (WildPat pat_ty) pat_ty, res) }
-
-  AsPat x (L nm_loc name) at pat -> do
-        { mult_wrap <- checkManyPattern pat_ty
-            -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
-        ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty)
-        ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
-                         tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id))
-                                 penv pat thing_inside
-            -- NB: if we do inference on:
-            --          \ (y@(x::forall a. a->a)) = e
-            -- we'll fail.  The as-pattern infers a monotype for 'y', which then
-            -- fails to unify with the polymorphic type for 'x'.  This could
-            -- perhaps be fixed, but only with a bit more work.
-            --
-            -- If you fix it, don't forget the bindInstsOfPatIds!
-        ; pat_ty <- readExpType (scaledThing pat_ty)
-        ; return (mkHsWrapPat (wrap <.> mult_wrap) (AsPat x (L nm_loc bndr_id) at pat') pat_ty, res) }
-
-  ViewPat _ expr pat -> do
-        { mult_wrap <- checkManyPattern pat_ty
-         -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
-         --
-         -- It should be possible to have view patterns at linear (or otherwise
-         -- non-Many) multiplicity. But it is not clear at the moment what
-         -- restriction need to be put in place, if any, for linear view
-         -- patterns to desugar to type-correct Core.
-
-        ; (expr',expr_ty) <- tcInferRho expr
-               -- Note [View patterns and polymorphism]
-
-         -- Expression must be a function
-        ; let herald = ExpectedFunTyViewPat $ unLoc expr
-        ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma)
-            <- matchActualFunTySigma herald (Just . HsExprRnThing $ unLoc expr) (1,[]) expr_ty
-               -- See Note [View patterns and polymorphism]
-               -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_sigma)
-
-         -- Check that overall pattern is more polymorphic than arg type
-        ; expr_wrap2 <- tc_sub_type penv (scaledThing pat_ty) inf_arg_ty
-            -- expr_wrap2 :: pat_ty "->" inf_arg_ty
-
-         -- Pattern must have inf_res_sigma
-        ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType inf_res_sigma) penv pat thing_inside
-
-        ; let Scaled w h_pat_ty = pat_ty
-        ; pat_ty <- readExpType h_pat_ty
-        ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
-                              (Scaled w pat_ty) inf_res_sigma
-          -- expr_wrap2' :: (inf_arg_ty -> inf_res_sigma) "->"
-          --                (pat_ty -> inf_res_sigma)
-          -- NB: pat_ty comes from matchActualFunTySigma, so it has a
-          -- fixed RuntimeRep, as needed to call mkWpFun.
-        ; let
-              expr_wrap = expr_wrap2' <.> expr_wrap1 <.> mult_wrap
-
-        ; return $ (ViewPat pat_ty (mkLHsWrap expr_wrap expr') pat', res) }
-
-{- Note [View patterns and polymorphism]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this exotic example:
-   pair :: forall a. Bool -> a -> forall b. b -> (a,b)
-
-   f :: Int -> blah
-   f (pair True -> x) = ...here (x :: forall b. b -> (Int,b))
-
-The expression (pair True) should have type
-    pair True :: Int -> forall b. b -> (Int,b)
-so that it is ready to consume the incoming Int. It should be an
-arrow type (t1 -> t2); hence using (tcInferRho expr).
-
-Then, when taking that arrow apart we want to get a *sigma* type
-(forall b. b->(Int,b)), because that's what we want to bind 'x' to.
-Fortunately that's what matchActualFunTySigma returns anyway.
--}
-
--- Type signatures in patterns
--- See Note [Pattern coercions] below
-  SigPat _ pat sig_ty -> do
-        { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
-                                                            sig_ty (scaledThing pat_ty)
-                -- Using tcExtendNameTyVarEnv is appropriate here
-                -- because we're not really bringing fresh tyvars into scope.
-                -- We're *naming* existing tyvars. Note that it is OK for a tyvar
-                -- from an outer scope to mention one of these tyvars in its kind.
-        ; (pat', res) <- tcExtendNameTyVarEnv wcs      $
-                         tcExtendNameTyVarEnv tv_binds $
-                         tc_lpat (pat_ty `scaledSet` mkCheckExpType inner_ty) penv pat thing_inside
-        ; pat_ty <- readExpType (scaledThing pat_ty)
-        ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
-
-------------------------
--- Lists, tuples, arrays
-
-  -- Necessarily a built-in list pattern, not an overloaded list pattern.
-  -- See Note [Desugaring overloaded list patterns].
-  ListPat _ pats -> do
-        { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv (scaledThing pat_ty)
-        ; (pats', res) <- tcMultiple (tc_lpat (pat_ty `scaledSet` mkCheckExpType elt_ty))
-                                     penv pats thing_inside
-        ; pat_ty <- readExpType (scaledThing pat_ty)
-        ; return (mkHsWrapPat coi
-                         (ListPat elt_ty pats') pat_ty, res)
-}
-
-  TuplePat _ pats boxity -> do
-        { let arity = length pats
-              tc = tupleTyCon boxity arity
-              -- NB: tupleTyCon does not flatten 1-tuples
-              -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
-        ; checkTupSize arity
-        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
-                                               penv (scaledThing pat_ty)
-                     -- Unboxed tuples have RuntimeRep vars, which we discard:
-                     -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
-        ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
-                                           Boxed   -> arg_tys
-        ; (pats', res) <- tc_lpats (map (scaledSet pat_ty . mkCheckExpType) con_arg_tys)
-                                   penv pats thing_inside
-
-        ; dflags <- getDynFlags
-
-        -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
-        -- so that we can experiment with lazy tuple-matching.
-        -- This is a pretty odd place to make the switch, but
-        -- it was easy to do.
-        ; let
-              unmangled_result = TuplePat con_arg_tys pats' boxity
-                                 -- pat_ty /= pat_ty iff coi /= IdCo
-              possibly_mangled_result
-                | gopt Opt_IrrefutableTuples dflags &&
-                  isBoxed boxity   = LazyPat noExtField (noLocA unmangled_result)
-                | otherwise        = unmangled_result
-
-        ; pat_ty <- readExpType (scaledThing pat_ty)
-        ; massert (con_arg_tys `equalLength` pats) -- Syntactically enforced
-        ; return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
-        }
-
-  SumPat _ pat alt arity  -> do
-        { let tc = sumTyCon arity
-        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
-                                               penv (scaledThing pat_ty)
-        ; -- Drop levity vars, we don't care about them here
-          let con_arg_tys = drop arity arg_tys
-        ; (pat', res) <- tc_lpat (pat_ty `scaledSet` mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
-                                 penv pat thing_inside
-        ; pat_ty <- readExpType (scaledThing pat_ty)
-        ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
-                 , res)
-        }
-
-------------------------
--- Data constructors
-  ConPat _ con arg_pats ->
-    tcConPat penv con pat_ty arg_pats thing_inside
-
-------------------------
--- Literal patterns
-  LitPat x simple_lit -> do
-        { let lit_ty = hsLitType simple_lit
-        ; wrap   <- tc_sub_type penv (scaledThing pat_ty) lit_ty
-        ; res    <- thing_inside
-        ; pat_ty <- readExpType (scaledThing pat_ty)
-        ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
-                 , res) }
-
-------------------------
--- Overloaded patterns: n, and n+k
-
--- In the case of a negative literal (the more complicated case),
--- we get
---
---   case v of (-5) -> blah
---
--- becoming
---
---   if v == (negate (fromInteger 5)) then blah else ...
---
--- There are two bits of rebindable syntax:
---   (==)   :: pat_ty -> neg_lit_ty -> Bool
---   negate :: lit_ty -> neg_lit_ty
--- where lit_ty is the type of the overloaded literal 5.
---
--- When there is no negation, neg_lit_ty and lit_ty are the same
-  NPat _ (L l over_lit) mb_neg eq -> do
-        { mult_wrap <- checkManyPattern pat_ty
-          -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
-          --
-          -- It may be possible to refine linear pattern so that they work in
-          -- linear environments. But it is not clear how useful this is.
-        ; let orig = LiteralOrigin over_lit
-        ; ((lit', mb_neg'), eq')
-            <- tcSyntaxOp orig eq [SynType (scaledThing pat_ty), SynAny]
-                          (mkCheckExpType boolTy) $
-               \ [neg_lit_ty] _ ->
-               let new_over_lit lit_ty = newOverloadedLit over_lit
-                                           (mkCheckExpType lit_ty)
-               in case mb_neg of
-                 Nothing  -> (, Nothing) <$> new_over_lit neg_lit_ty
-                 Just neg -> -- Negative literal
-                             -- The 'negate' is re-mappable syntax
-                   second Just <$>
-                   (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
-                    \ [lit_ty] _ -> new_over_lit lit_ty)
-                     -- applied to a closed literal: linearity doesn't matter as
-                     -- literals are typed in an empty environment, hence have
-                     -- all multiplicities.
-
-        ; res <- thing_inside
-        ; pat_ty <- readExpType (scaledThing pat_ty)
-        ; return (mkHsWrapPat mult_wrap (NPat pat_ty (L l lit') mb_neg' eq') pat_ty, res) }
-
-{-
-Note [NPlusK patterns]
-~~~~~~~~~~~~~~~~~~~~~~
-From
-
-  case v of x + 5 -> blah
-
-we get
-
-  if v >= 5 then (\x -> blah) (v - 5) else ...
-
-There are two bits of rebindable syntax:
-  (>=) :: pat_ty -> lit1_ty -> Bool
-  (-)  :: pat_ty -> lit2_ty -> var_ty
-
-lit1_ty and lit2_ty could conceivably be different.
-var_ty is the type inferred for x, the variable in the pattern.
-
-Note that we need to type-check the literal twice, because it is used
-twice, and may be used at different types. The second HsOverLit stored in the
-AST is used for the subtraction operation.
--}
-
--- See Note [NPlusK patterns]
-  NPlusKPat _ (L nm_loc name)
-               (L loc lit) _ ge minus -> do
-        { mult_wrap <- checkManyPattern pat_ty
-            -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
-        ; let pat_exp_ty = scaledThing pat_ty
-              orig = LiteralOrigin lit
-        ; (lit1', ge')
-            <- tcSyntaxOp orig ge [SynType pat_exp_ty, SynRho]
-                                  (mkCheckExpType boolTy) $
-               \ [lit1_ty] _ ->
-               newOverloadedLit lit (mkCheckExpType lit1_ty)
-        ; ((lit2', minus_wrap, bndr_id), minus')
-            <- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $
-               \ [lit2_ty, var_ty] _ ->
-               do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
-                  ; (wrap, bndr_id) <- setSrcSpanA nm_loc $
-                                     tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)
-                           -- co :: var_ty ~ idType bndr_id
-
-                           -- minus_wrap is applicable to minus'
-                  ; return (lit2', wrap, bndr_id) }
-
-        ; pat_ty <- readExpType pat_exp_ty
-
-        -- The Report says that n+k patterns must be in Integral
-        -- but it's silly to insist on this in the RebindableSyntax case
-        ; unlessM (xoptM LangExt.RebindableSyntax) $
-          do { icls <- tcLookupClass integralClassName
-             ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
-
-        ; res <- tcExtendIdEnv1 name bndr_id thing_inside
-
-        ; let minus'' = case minus' of
-                          NoSyntaxExprTc -> pprPanic "tc_pat NoSyntaxExprTc" (ppr minus')
-                                   -- this should be statically avoidable
-                                   -- Case (3) from Note [NoSyntaxExpr] in "GHC.Hs.Expr"
-                          SyntaxExprTc { syn_expr = minus'_expr
-                                       , syn_arg_wraps = minus'_arg_wraps
-                                       , syn_res_wrap = minus'_res_wrap }
-                            -> SyntaxExprTc { syn_expr = minus'_expr
-                                            , syn_arg_wraps = minus'_arg_wraps
-                                            , syn_res_wrap = minus_wrap <.> minus'_res_wrap }
-                             -- Oy. This should really be a record update, but
-                             -- we get warnings if we try. #17783
-              pat' = NPlusKPat pat_ty (L nm_loc bndr_id) (L loc lit1') lit2'
-                               ge' minus''
-        ; return (mkHsWrapPat mult_wrap pat' pat_ty, res) }
-
--- Here we get rid of it and add the finalizers to the global environment.
--- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
-  SplicePat (HsUntypedSpliceTop mod_finalizers pat) _ -> do
-      { addModFinalizersWithLclEnv mod_finalizers
-      ; tc_pat pat_ty penv pat thing_inside }
-
-  SplicePat (HsUntypedSpliceNested _) _ -> panic "tc_pat: nested splice in splice pat"
-
-  XPat (HsPatExpanded lpat rpat) -> do
-    { (rpat', res) <- tc_pat pat_ty penv rpat thing_inside
-    ; return (XPat $ ExpansionPat lpat rpat', res) }
-
-{-
-Note [Hopping the LIE in lazy patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In a lazy pattern, we must *not* discharge constraints from the RHS
-from dictionaries bound in the pattern.  E.g.
-        f ~(C x) = 3
-We can't discharge the Num constraint from dictionaries bound by
-the pattern C!
-
-So we have to make the constraints from thing_inside "hop around"
-the pattern.  Hence the captureConstraints and emitConstraints.
-
-The same thing ensures that equality constraints in a lazy match
-are not made available in the RHS of the match. For example
-        data T a where { T1 :: Int -> T Int; ... }
-        f :: T a -> Int -> a
-        f ~(T1 i) y = y
-It's obviously not sound to refine a to Int in the right
-hand side, because the argument might not match T1 at all!
-
-Finally, a lazy pattern should not bind any existential type variables
-because they won't be in scope when we do the desugaring
-
-
-************************************************************************
-*                                                                      *
-            Pattern signatures   (pat :: type)
-*                                                                      *
-************************************************************************
--}
-
-tcPatSig :: Bool                    -- True <=> pattern binding
-         -> HsPatSigType GhcRn
-         -> ExpSigmaType
-         -> TcM (TcType,            -- The type to use for "inside" the signature
-                 [(Name,TcTyVar)],  -- The new bit of type environment, binding
-                                    -- the scoped type variables
-                 [(Name,TcTyVar)],  -- The wildcards
-                 HsWrapper)         -- Coercion due to unification with actual ty
-                                    -- Of shape:  res_ty ~ sig_ty
-tcPatSig in_pat_bind sig res_ty
- = do  { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt HM_Sig sig OpenKind
-        -- sig_tvs are the type variables free in 'sig',
-        -- and not already in scope. These are the ones
-        -- that should be brought into scope
-
-        ; case NE.nonEmpty sig_tvs of
-            Nothing -> do {
-                -- Just do the subsumption check and return
-                  wrap <- addErrCtxtM (mk_msg sig_ty) $
-                          tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty
-                ; return (sig_ty, [], sig_wcs, wrap)
-                }
-            Just sig_tvs_ne -> do
-                -- Type signature binds at least one scoped type variable
-
-                -- A pattern binding cannot bind scoped type variables
-                -- It is more convenient to make the test here
-                -- than in the renamer
-              when in_pat_bind
-                (addErr (TcRnCannotBindScopedTyVarInPatSig sig_tvs_ne))
-
-              -- Now do a subsumption check of the pattern signature against res_ty
-              wrap <- addErrCtxtM (mk_msg sig_ty) $
-                      tcSubTypePat PatSigOrigin PatSigCtxt res_ty sig_ty
-
-              -- Phew!
-              return (sig_ty, sig_tvs, sig_wcs, wrap)
-       }
-  where
-    mk_msg sig_ty tidy_env
-       = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty
-            ; res_ty <- readExpType res_ty   -- should be filled in by now
-            ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty
-            ; let msg = vcat [ hang (text "When checking that the pattern signature:")
-                                  4 (ppr sig_ty)
-                             , nest 2 (hang (text "fits the type of its context:")
-                                          2 (ppr res_ty)) ]
-            ; return (tidy_env, msg) }
-
-
-{- *********************************************************************
-*                                                                      *
-        Most of the work for constructors is here
-        (the rest is in the ConPatIn case of tc_pat)
-*                                                                      *
-************************************************************************
-
-[Pattern matching indexed data types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider the following declarations:
-
-  data family Map k :: * -> *
-  data instance Map (a, b) v = MapPair (Map a (Pair b v))
-
-and a case expression
-
-  case x :: Map (Int, c) w of MapPair m -> ...
-
-As explained by [Wrappers for data instance tycons] in GHC.Types.Id.Make, the
-worker/wrapper types for MapPair are
-
-  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
-  $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
-
-So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is
-:R123Map, which means the straight use of boxySplitTyConApp would give a type
-error.  Hence, the smart wrapper function boxySplitTyConAppWithFamily calls
-boxySplitTyConApp with the family tycon Map instead, which gives us the family
-type list {(Int, c), w}.  To get the correct split for :R123Map, we need to
-unify the family type list {(Int, c), w} with the instance types {(a, b), v}
-(provided by tyConFamInst_maybe together with the family tycon).  This
-unification yields the substitution [a -> Int, b -> c, v -> w], which gives us
-the split arguments for the representation tycon :R123Map as {Int, c, w}
-
-In other words, boxySplitTyConAppWithFamily implicitly takes the coercion
-
-  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}
-
-moving between representation and family type into account.  To produce type
-correct Core, this coercion needs to be used to case the type of the scrutinee
-from the family to the representation type.  This is achieved by
-unwrapFamInstScrutinee using a CoPat around the result pattern.
-
-Now it might appear seem as if we could have used the previous GADT type
-refinement infrastructure of refineAlt and friends instead of the explicit
-unification and CoPat generation.  However, that would be wrong.  Why?  The
-whole point of GADT refinement is that the refinement is local to the case
-alternative.  In contrast, the substitution generated by the unification of
-the family type list and instance types needs to be propagated to the outside.
-Imagine that in the above example, the type of the scrutinee would have been
-(Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the
-substitution [x -> (a, b), v -> w].  In contrast to GADT matching, the
-instantiation of x with (a, b) must be global; ie, it must be valid in *all*
-alternatives of the case expression, whereas in the GADT case it might vary
-between alternatives.
-
-RIP GADT refinement: refinements have been replaced by the use of explicit
-equality constraints that are used in conjunction with implication constraints
-to express the local scope of GADT refinements.
-
-Note [Freshen existentials]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It is essential that these existentials are freshened.
-Otherwise, if we have something like
-  case (a :: Ex, b :: Ex) of (MkEx ..., MkEx ...) -> ...
-we'll give both unpacked existential variables the
-same name, leading to shadowing.
-
--}
-
---      Running example:
--- MkT :: forall a b c. (a~[b]) => b -> c -> T a
---       with scrutinee of type (T ty)
-
-tcConPat :: PatEnv -> LocatedN Name
-         -> Scaled ExpSigmaTypeFRR    -- Type of the pattern
-         -> HsConPatDetails GhcRn -> TcM a
-         -> TcM (Pat GhcTc, a)
-tcConPat penv con_lname@(L _ con_name) pat_ty arg_pats thing_inside
-  = do  { con_like <- tcLookupConLike con_name
-        ; case con_like of
-            RealDataCon data_con -> tcDataConPat penv con_lname data_con
-                                                 pat_ty arg_pats thing_inside
-            PatSynCon pat_syn -> tcPatSynPat penv con_lname pat_syn
-                                             pat_ty arg_pats thing_inside
-        }
-
--- Warn when pattern matching on a GADT or a pattern synonym
--- when MonoLocalBinds is off.
-warnMonoLocalBinds :: TcM ()
-warnMonoLocalBinds
-  = do { mono_local_binds <- xoptM LangExt.MonoLocalBinds
-       ; unless mono_local_binds $
-           addDiagnostic TcRnGADTMonoLocalBinds
-           -- We used to require the GADTs or TypeFamilies extension
-           -- to pattern match on a GADT (#2905, #7156)
-           --
-           -- In #20485 this was made into a warning.
-       }
-
-tcDataConPat :: PatEnv -> LocatedN Name -> DataCon
-             -> Scaled ExpSigmaTypeFRR        -- Type of the pattern
-             -> HsConPatDetails GhcRn -> TcM a
-             -> TcM (Pat GhcTc, a)
-tcDataConPat penv (L con_span con_name) data_con pat_ty_scaled
-             arg_pats thing_inside
-  = do  { let tycon = dataConTyCon data_con
-                  -- For data families this is the representation tycon
-              (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
-                = dataConFullSig data_con
-              header = L con_span (RealDataCon data_con)
-
-          -- Instantiate the constructor type variables [a->ty]
-          -- This may involve doing a family-instance coercion,
-          -- and building a wrapper
-        ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty_scaled
-        ; pat_ty <- readExpType (scaledThing pat_ty_scaled)
-
-          -- Add the stupid theta
-        ; setSrcSpanA con_span $ addDataConStupidTheta data_con ctxt_res_tys
-
-        -- Check that this isn't a GADT pattern match
-        -- in situations in which that isn't allowed.
-        ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys)
-        ; checkGADT (RealDataCon data_con) ex_tvs all_arg_tys penv
-
-        ; tenv1 <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys
-                  -- NB: Do not use zipTvSubst!  See #14154
-                  -- We want to create a well-kinded substitution, so
-                  -- that the instantiated type is well-kinded
-
-        ; let mc = case pe_ctxt penv of
-                     LamPat mc -> mc
-                     LetPat {} -> PatBindRhs
-        ; skol_info <- mkSkolemInfo (PatSkol (RealDataCon data_con) mc)
-        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info tenv1 ex_tvs
-                     -- Get location from monad, not from ex_tvs
-                     -- This freshens: See Note [Freshen existentials]
-                     -- Why "super"? See Note [Binding when looking up instances]
-                     -- in GHC.Core.InstEnv.
-
-        ; let arg_tys' = substScaledTys tenv arg_tys
-              pat_mult = scaledMult pat_ty_scaled
-              arg_tys_scaled = map (scaleScaled pat_mult) arg_tys'
-
-        -- This check is necessary to uphold the invariant that 'tcConArgs'
-        -- is given argument types with a fixed runtime representation.
-        -- See test case T20363.
-        ; zipWithM_
-            ( \ i arg_sty ->
-              hasFixedRuntimeRep_syntactic
-                (FRRDataConPatArg data_con i)
-                (scaledThing arg_sty)
-            )
-            [1..]
-            arg_tys'
-
-        ; traceTc "tcConPat" (vcat [ text "con_name:" <+> ppr con_name
-                                   , text "univ_tvs:" <+> pprTyVars univ_tvs
-                                   , text "ex_tvs:" <+> pprTyVars ex_tvs
-                                   , text "eq_spec:" <+> ppr eq_spec
-                                   , text "theta:" <+> ppr theta
-                                   , text "ex_tvs':" <+> pprTyVars ex_tvs'
-                                   , text "ctxt_res_tys:" <+> ppr ctxt_res_tys
-                                   , text "pat_ty:" <+> ppr pat_ty
-                                   , text "arg_tys':" <+> ppr arg_tys'
-                                   , text "arg_pats" <+> ppr arg_pats ])
-        ; if null ex_tvs && null eq_spec && null theta
-          then do { -- The common case; no class bindings etc
-                    -- (see Note [Arrows and patterns])
-                    (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys_scaled
-                                                  tenv penv arg_pats thing_inside
-                  ; let res_pat = ConPat { pat_con = header
-                                         , pat_args = arg_pats'
-                                         , pat_con_ext = ConPatTc
-                                           { cpt_tvs = [], cpt_dicts = []
-                                           , cpt_binds = emptyTcEvBinds
-                                           , cpt_arg_tys = ctxt_res_tys
-                                           , cpt_wrap = idHsWrapper
-                                           }
-                                         }
-
-                  ; return (mkHsWrapPat wrap res_pat pat_ty, res) }
-
-          else do   -- The general case, with existential,
-                    -- and local equality constraints
-        { let theta'     = substTheta tenv (eqSpecPreds eq_spec ++ theta)
-                           -- order is *important* as we generate the list of
-                           -- dictionary binders from theta'
-
-        ; when (not (null eq_spec) || any isEqPred theta) warnMonoLocalBinds
-
-        ; given <- newEvVars theta'
-        ; (ev_binds, (arg_pats', res))
-             <- checkConstraints (getSkolemInfo skol_info) ex_tvs' given $
-                tcConArgs (RealDataCon data_con) arg_tys_scaled tenv penv arg_pats thing_inside
-
-        ; let res_pat = ConPat
-                { pat_con   = header
-                , pat_args  = arg_pats'
-                , pat_con_ext = ConPatTc
-                  { cpt_tvs   = ex_tvs'
-                  , cpt_dicts = given
-                  , cpt_binds = ev_binds
-                  , cpt_arg_tys = ctxt_res_tys
-                  , cpt_wrap  = idHsWrapper
-                  }
-                }
-        ; return (mkHsWrapPat wrap res_pat pat_ty, res)
-        } }
-
-tcPatSynPat :: PatEnv -> LocatedN Name -> PatSyn
-            -> Scaled ExpSigmaType         -- ^ Type of the pattern
-            -> HsConPatDetails GhcRn -> TcM a
-            -> TcM (Pat GhcTc, a)
-tcPatSynPat penv (L con_span con_name) pat_syn pat_ty arg_pats thing_inside
-  = do  { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn
-
-        ; (subst, univ_tvs') <- newMetaTyVars univ_tvs
-
-        -- Check that we aren't matching on a GADT-like pattern synonym
-        -- in situations in which that isn't allowed.
-        ; let all_arg_tys = ty : prov_theta ++ (map scaledThing arg_tys)
-        ; checkGADT (PatSynCon pat_syn) ex_tvs all_arg_tys penv
-
-        ; skol_info <- case pe_ctxt penv of
-                            LamPat mc -> mkSkolemInfo (PatSkol (PatSynCon pat_syn) mc)
-                            LetPat {} -> return unkSkol -- Doesn't matter
-
-        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX skol_info subst ex_tvs
-           -- This freshens: Note [Freshen existentials]
-
-        ; let ty'         = substTy tenv ty
-              arg_tys'    = substScaledTys tenv arg_tys
-              pat_mult    = scaledMult pat_ty
-              arg_tys_scaled = map (scaleScaled pat_mult) arg_tys'
-              prov_theta' = substTheta tenv prov_theta
-              req_theta'  = substTheta tenv req_theta
-
-        ; when (any isEqPred prov_theta) warnMonoLocalBinds
-
-        ; mult_wrap <- checkManyPattern pat_ty
-            -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
-
-        ; wrap <- tc_sub_type penv (scaledThing pat_ty) ty'
-        ; traceTc "tcPatSynPat" (ppr pat_syn $$
-                                 ppr pat_ty $$
-                                 ppr ty' $$
-                                 ppr ex_tvs' $$
-                                 ppr prov_theta' $$
-                                 ppr req_theta' $$
-                                 ppr arg_tys')
-
-        ; prov_dicts' <- newEvVars prov_theta'
-
-
-        ; req_wrap <- instCall (OccurrenceOf con_name) (mkTyVarTys univ_tvs') req_theta'
-                      -- Origin (OccurrenceOf con_name):
-                      -- see Note [Call-stack tracing of pattern synonyms]
-        ; traceTc "instCall" (ppr req_wrap)
-
-          -- Pattern synonyms can never have representation-polymorphic argument types,
-          -- as checked in 'GHC.Tc.Gen.Sig.tcPatSynSig' (see use of 'FixedRuntimeRepPatSynSigArg')
-          -- and 'GHC.Tc.TyCl.PatSyn.tcInferPatSynDecl'.
-          -- (If you want to lift this restriction, use 'hasFixedRuntimeRep' here, to match
-          -- 'tcDataConPat'.)
-        ; let
-            bad_arg_tys :: [(Int, Scaled Type)]
-            bad_arg_tys = filter (\ (_, Scaled _ arg_ty) -> typeLevity_maybe arg_ty == Nothing)
-                        $ zip [0..] arg_tys'
-        ; massertPpr (null bad_arg_tys) $
-            vcat [ text "tcPatSynPat: pattern arguments do not have a fixed RuntimeRep"
-                 , text "bad_arg_tys:" <+> ppr bad_arg_tys ]
-
-        ; traceTc "checkConstraints {" Outputable.empty
-        ; (ev_binds, (arg_pats', res))
-             <- checkConstraints (getSkolemInfo skol_info) ex_tvs' prov_dicts' $
-                tcConArgs (PatSynCon pat_syn) arg_tys_scaled tenv penv arg_pats thing_inside
-
-        ; traceTc "checkConstraints }" (ppr ev_binds)
-        ; let res_pat = ConPat { pat_con   = L con_span $ PatSynCon pat_syn
-                               , pat_args  = arg_pats'
-                               , pat_con_ext = ConPatTc
-                                 { cpt_tvs   = ex_tvs'
-                                 , cpt_dicts = prov_dicts'
-                                 , cpt_binds = ev_binds
-                                 , cpt_arg_tys = mkTyVarTys univ_tvs'
-                                 , cpt_wrap  = req_wrap
-                                 }
-                               }
-        ; pat_ty <- readExpType (scaledThing pat_ty)
-        ; return (mkHsWrapPat (wrap <.> mult_wrap) res_pat pat_ty, res) }
-
-{- Note [Call-stack tracing of pattern synonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   f :: HasCallStack => blah
-
-   pattern Annotated :: HasCallStack => (CallStack, a) -> a
-   pattern Annotated x <- (f -> x)
-
-When we pattern-match against `Annotated` we will call `f`, and must
-pass a call-stack.  We may want `Annotated` itself to propagate the call
-stack, so we give it a HasCallStack constraint too.  But then we expect
-to see `Annotated` in the call stack.
-
-This is achieve easily, but a bit trickily.  When we instantiate
-Annotated's "required" constraints, in tcPatSynPat, give them a
-CtOrigin of (OccurrenceOf "Annotated"). That way the special magic
-in GHC.Tc.Solver.Canonical.canClassNC which deals with CallStack
-constraints will kick in: that logic only fires on constraints
-whose Origin is (OccurrenceOf f).
-
-See also Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
-and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types
--}
-----------------------------
--- | Convenient wrapper for calling a matchExpectedXXX function
-matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a))
-                    -> PatEnv -> ExpSigmaTypeFRR -> TcM (HsWrapper, a)
--- See Note [Matching polytyped patterns]
--- Returns a wrapper : pat_ty ~R inner_ty
-matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty
-  = do { pat_ty <- expTypeToType pat_ty
-       ; (wrap, pat_rho) <- topInstantiate orig pat_ty
-       ; (co, res) <- inner_match pat_rho
-       ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap)
-       ; return (mkWpCastN (mkSymCo co) <.> wrap, res) }
-
-----------------------------
-matchExpectedConTy :: PatEnv
-                   -> TyCon
-                       -- ^ The TyCon that this data constructor actually returns.
-                       -- In the case of a data family, this is
-                       -- the /representation/ TyCon.
-                   -> Scaled ExpSigmaTypeFRR
-                       -- ^ The type of the pattern.
-                       -- In the case of a data family, this would
-                       -- mention the /family/ TyCon
-                   -> TcM (HsWrapper, [TcSigmaType])
--- See Note [Matching constructor patterns]
--- Returns a wrapper : pat_ty "->" T ty1 ... tyn
-matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty
-  | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc
-         -- Comments refer to Note [Matching constructor patterns]
-         -- co_tc :: forall a. T [a] ~ T7 a
-  = do { pat_ty <- expTypeToType (scaledThing exp_pat_ty)
-       ; (wrap, pat_rho) <- topInstantiate orig pat_ty
-
-       ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc)
-             -- tys = [ty1,ty2]
-
-       ; traceTc "matchExpectedConTy" (vcat [ppr data_tc,
-                                             ppr (tyConTyVars data_tc),
-                                             ppr fam_tc, ppr fam_args,
-                                             ppr exp_pat_ty,
-                                             ppr pat_ty,
-                                             ppr pat_rho, ppr wrap])
-       ; co1 <- unifyType Nothing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho
-             -- co1 : T (ty1,ty2) ~N pat_rho
-             -- could use tcSubType here... but it's the wrong way round
-             -- for actual vs. expected in error messages.
-
-       ; let tys' = mkTyVarTys tvs'
-             co2 = mkUnbranchedAxInstCo Representational co_tc tys' []
-             -- co2 : T (ty1,ty2) ~R T7 ty1 ty2
-
-             full_co = mkSubCo (mkSymCo co1) `mkTransCo` co2
-             -- full_co :: pat_rho ~R T7 ty1 ty2
-
-       ; return ( mkWpCastR full_co <.> wrap, tys') }
-
-  | otherwise
-  = do { pat_ty <- expTypeToType (scaledThing exp_pat_ty)
-       ; (wrap, pat_rho) <- topInstantiate orig pat_ty
-       ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho
-       ; return (mkWpCastN (mkSymCo coi) <.> wrap, tys) }
-
-{-
-Note [Matching constructor patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose (coi, tys) = matchExpectedConType data_tc pat_ty
-
- * In the simple case, pat_ty = tc tys
-
- * If pat_ty is a polytype, we want to instantiate it
-   This is like part of a subsumption check.  Eg
-      f :: (forall a. [a]) -> blah
-      f [] = blah
-
- * In a type family case, suppose we have
-          data family T a
-          data instance T (p,q) = A p | B q
-       Then we'll have internally generated
-              data T7 p q = A p | B q
-              axiom coT7 p q :: T (p,q) ~ T7 p q
-
-       So if pat_ty = T (ty1,ty2), we return (coi, [ty1,ty2]) such that
-           coi = coi2 . coi1 : T7 t ~ pat_ty
-           coi1 : T (ty1,ty2) ~ pat_ty
-           coi2 : T7 ty1 ty2 ~ T (ty1,ty2)
-
-   For families we do all this matching here, not in the unifier,
-   because we never want a whisper of the data_tycon to appear in
-   error messages; it's a purely internal thing
--}
-
-{-
-Note [Typechecking type applications in patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-How should we typecheck type applications in patterns, such as
-   f :: Either (Maybe a) [b] -> blah
-   f (Left @x @[y] (v::Maybe x)) = blah
-
-It's quite straightforward, and very similar to the treatment of
-pattern signatures.
-
-* Step 1: bind the newly-in-scope type variables x and y to fresh
-  unification variables, say x0 and y0.
-
-* Step 2: typecheck those type arguments, @x and @[y], to get the
-  types x0 and [y0].
-
-* Step 3: Unify those types with the type arguments we expect,
-  in this case (Maybe a) and [b].  These unifications will
-  (perhaps after the constraint solver has done its work)
-  unify   x0 := Maybe a
-          y0 := b
-  Thus we learn that x stands for (Maybe a) and y for b.
-
-Wrinkles:
-
-* Surprisingly, we can discard the coercions arising from
-  these unifications.  The *only* thing the unification does is
-  to side-effect those unification variables, so that we know
-  what type x and y stand for; and cause an error if the equality
-  is not soluble.  It's a bit like a constraint arising
-  from a functional dependency, where we don't use the evidence.
-
-* Exactly the same works for existential arguments
-     data T where
-        MkT :: a -> a -> T
-     f :: T -> blah
-     f (MkT @x v w) = ...
-   Here we create a fresh unification variable x0 for x, and
-   unify it with the fresh existential variable bound by the pattern.
-
-* Note that both here and in pattern signatures the unification may
-  not even end up unifying the variable.  For example
-     type S a b = a
-     f :: Maybe a -> Bool
-     f (Just @(S a b) x) = True :: b
-   In Step 3 we will unify (S a0 b0 ~ a), which succeeds, but has no
-   effect on the unification variable b0, to which 'b' is bound.
-   Later, in the RHS, we find that b0 must be Bool, and unify it there.
-   All is fine.
--}
-
-tcConArgs :: ConLike
-          -> [Scaled TcSigmaTypeFRR]
-          -> Subst            -- Instantiating substitution for constructor type
-          -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc)
-tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of
-  PrefixCon type_args arg_pats -> do
-        { checkTc (con_arity == no_of_args)     -- Check correct arity
-                  (arityErr (text "constructor") con_like con_arity no_of_args)
-
-              -- forgetting to filter out inferred binders led to #20443
-        ; let con_spec_binders = filter ((== SpecifiedSpec) . binderFlag) $
-                                 conLikeUserTyVarBinders con_like
-        ; checkTc (type_args `leLength` con_spec_binders)
-                  (TcRnTooManyTyArgsInConPattern con_like (length con_spec_binders) (length type_args))
-
-        ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys
-        ; (type_args', (arg_pats', res))
-            <- tcMultiple tcConTyArg penv type_args $
-               tcMultiple tcConArg penv pats_w_tys thing_inside
-
-          -- This unification is straight from Figure 7 of
-          -- "Type Variables in Patterns", Haskell'18
-        ; _ <- zipWithM (unifyType Nothing) type_args' (substTyVars tenv $
-                                                        binderVars con_spec_binders)
-          -- OK to drop coercions here. These unifications are all about
-          -- guiding inference based on a user-written type annotation
-          -- See Note [Typechecking type applications in patterns]
-
-        ; return (PrefixCon type_args arg_pats', res) }
-    where
-      con_arity  = conLikeArity con_like
-      no_of_args = length arg_pats
-
-  InfixCon p1 p2 -> do
-        { checkTc (con_arity == 2)      -- Check correct arity
-                  (arityErr (text "constructor") con_like con_arity 2)
-        ; let [arg_ty1,arg_ty2] = arg_tys       -- This can't fail after the arity check
-        ; ([p1',p2'], res) <- tcMultiple tcConArg penv [(p1,arg_ty1),(p2,arg_ty2)]
-                                                  thing_inside
-        ; return (InfixCon p1' p2', res) }
-    where
-      con_arity  = conLikeArity con_like
-
-  RecCon (HsRecFields rpats dd) -> do
-        { (rpats', res) <- tcMultiple tc_field penv rpats thing_inside
-        ; return (RecCon (HsRecFields rpats' dd), res) }
-    where
-      tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))
-                          (LHsRecField GhcTc (LPat GhcTc))
-      tc_field penv
-               (L l (HsFieldBind ann (L loc (FieldOcc sel (L lr rdr))) pat pun))
-               thing_inside
-        = do { sel'   <- tcLookupId sel
-             ; pat_ty <- setSrcSpanA loc $ find_field_ty sel
-                                            (occNameFS $ rdrNameOcc rdr)
-             ; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside
-             ; return (L l (HsFieldBind ann (L loc (FieldOcc sel' (L lr rdr))) pat'
-                                                                        pun), res) }
-
-
-      find_field_ty :: Name -> FastString -> TcM (Scaled TcType)
-      find_field_ty sel lbl
-        = case [ty | (fl, ty) <- field_tys, flSelector fl == sel ] of
-
-                -- No matching field; chances are this field label comes from some
-                -- other record type (or maybe none).  If this happens, just fail,
-                -- otherwise we get crashes later (#8570), and similar:
-                --      f (R { foo = (a,b) }) = a+b
-                -- If foo isn't one of R's fields, we don't want to crash when
-                -- typechecking the "a+b".
-           [] -> failWith (badFieldConErr (getName con_like) (FieldLabelString lbl))
-
-                -- The normal case, when the field comes from the right constructor
-           (pat_ty : extras) -> do
-                traceTc "find_field" (ppr pat_ty <+> ppr extras)
-                assert (null extras) (return pat_ty)
-
-      field_tys :: [(FieldLabel, Scaled TcType)]
-      field_tys = zip (conLikeFieldLabels con_like) arg_tys
-          -- Don't use zipEqual! If the constructor isn't really a record, then
-          -- dataConFieldLabels will be empty (and each field in the pattern
-          -- will generate an error below).
-
-tcConTyArg :: Checker (HsConPatTyArg GhcRn) TcType
-tcConTyArg penv (HsConPatTyArg _ rn_ty) thing_inside
-  = do { (sig_wcs, sig_ibs, arg_ty) <- tcHsPatSigType TypeAppCtxt HM_TyAppPat rn_ty AnyKind
-               -- AnyKind is a bit suspect: it really should be the kind gotten
-               -- from instantiating the constructor type. But this would be
-               -- hard to get right, because earlier type patterns might influence
-               -- the kinds of later patterns. In any case, it all gets checked
-               -- by the calls to unifyType in tcConArgs, which will also unify
-               -- kinds.
-       ; case NE.nonEmpty sig_ibs of
-           Just sig_ibs_ne | inPatBind penv ->
-             addErr (TcRnCannotBindTyVarsInPatBind sig_ibs_ne)
-           _ -> pure ()
-       ; result <- tcExtendNameTyVarEnv sig_wcs $
-                   tcExtendNameTyVarEnv sig_ibs $
-                   thing_inside
-       ; return (arg_ty, result) }
-
-tcConArg :: Checker (LPat GhcRn, Scaled TcSigmaType) (LPat GhcTc)
-tcConArg penv (arg_pat, Scaled arg_mult arg_ty)
-  = tc_lpat (Scaled arg_mult (mkCheckExpType arg_ty)) penv arg_pat
-
-addDataConStupidTheta :: DataCon -> [TcType] -> TcM ()
--- Instantiate the "stupid theta" of the data con, and throw
--- the constraints into the constraint set.
--- See Note [The stupid context] in GHC.Core.DataCon.
-addDataConStupidTheta data_con inst_tys
-  | null stupid_theta = return ()
-  | otherwise         = instStupidTheta origin inst_theta
-  where
-    origin = OccurrenceOf (dataConName data_con)
-        -- The origin should always report "occurrence of C"
-        -- even when C occurs in a pattern
-    stupid_theta = dataConStupidTheta data_con
-    univ_tvs     = dataConUnivTyVars data_con
-    tenv = zipTvSubst univ_tvs (takeList univ_tvs inst_tys)
-         -- NB: inst_tys can be longer than the univ tyvars
-         --     because the constructor might have existentials
-    inst_theta = substTheta tenv stupid_theta
-
-{-
-Note [Arrows and patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-(Oct 07) Arrow notation has the odd property that it involves
-"holes in the scope". For example:
-  expr :: Arrow a => a () Int
-  expr = proc (y,z) -> do
-          x <- term -< y
-          expr' -< x
-
-Here the 'proc (y,z)' binding scopes over the arrow tails but not the
-arrow body (e.g 'term').  As things stand (bogusly) all the
-constraints from the proc body are gathered together, so constraints
-from 'term' will be seen by the tcPat for (y,z).  But we must *not*
-bind constraints from 'term' here, because the desugarer will not make
-these bindings scope over 'term'.
-
-The Right Thing is not to confuse these constraints together. But for
-now the Easy Thing is to ensure that we do not have existential or
-GADT constraints in a 'proc', which we do by disallowing any
-non-vanilla pattern match (i.e. one that introduces existential
-variables or provided constraints), in tcDataConPat and tcPatSynPat.
-
-We also short-cut the constraint simplification for such vanilla patterns,
-so that we bind no constraints. Hence the 'fast path' in tcDataConPat;
-which applies more generally (not just within 'proc'), as it's a good
-plan in general to bypass the constraint simplification step entirely
-when it's not needed.
-
-Note [Pattern coercions]
-~~~~~~~~~~~~~~~~~~~~~~~~
-In principle, these program would be reasonable:
-
-        f :: (forall a. a->a) -> Int
-        f (x :: Int->Int) = x 3
-
-        g :: (forall a. [a]) -> Bool
-        g [] = True
-
-In both cases, the function type signature restricts what arguments can be passed
-in a call (to polymorphic ones).  The pattern type signature then instantiates this
-type.  For example, in the first case,  (forall a. a->a) <= Int -> Int, and we
-generate the translated term
-        f = \x' :: (forall a. a->a).  let x = x' Int in x 3
-
-From a type-system point of view, this is perfectly fine, but it's *very* seldom useful.
-And it requires a significant amount of code to implement, because we need to decorate
-the translated pattern with coercion functions (generated from the subsumption check
-by tcSub).
-
-So for now I'm just insisting on type *equality* in patterns.  No subsumption.
-
-Old notes about desugaring, at a time when pattern coercions were handled:
-
-A SigPat is a type coercion and must be handled one at a time.  We can't
-combine them unless the type of the pattern inside is identical, and we don't
-bother to check for that.  For example:
-
-        data T = T1 Int | T2 Bool
-        f :: (forall a. a -> a) -> T -> t
-        f (g::Int->Int)   (T1 i) = T1 (g i)
-        f (g::Bool->Bool) (T2 b) = T2 (g b)
-
-We desugar this as follows:
-
-        f = \ g::(forall a. a->a) t::T ->
-            let gi = g Int
-            in case t of { T1 i -> T1 (gi i)
-                           other ->
-            let gb = g Bool
-            in case t of { T2 b -> T2 (gb b)
-                           other -> fail }}
-
-Note that we do not treat the first column of patterns as a
-column of variables, because the coerced variables (gi, gb)
-would be of different types.  So we get rather grotty code.
-But I don't think this is a common case, and if it was we could
-doubtless improve it.
-
-Meanwhile, the strategy is:
-        * treat each SigPat coercion (always non-identity coercions)
-                as a separate block
-        * deal with the stuff inside, and then wrap a binding round
-                the result to bind the new variable (gi, gb, etc)
-
-
-************************************************************************
-*                                                                      *
-\subsection{Errors and contexts}
-*                                                                      *
-************************************************************************
-
-Note [Existential check]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Lazy patterns can't bind existentials.  They arise in two ways:
-  * Let bindings      let { C a b = e } in b
-  * Twiddle patterns  f ~(C a b) = e
-The pe_lazy field of PatEnv says whether we are inside a lazy
-pattern (perhaps deeply)
-
-See also Note [Typechecking pattern bindings] in GHC.Tc.Gen.Bind
--}
-
-maybeWrapPatCtxt :: Pat GhcRn -> (TcM a -> TcM b) -> TcM a -> TcM b
--- Not all patterns are worth pushing a context
-maybeWrapPatCtxt pat tcm thing_inside
-  | not (worth_wrapping pat) = tcm thing_inside
-  | otherwise                = addErrCtxt msg $ tcm $ popErrCtxt thing_inside
-                               -- Remember to pop before doing thing_inside
-  where
-   worth_wrapping (VarPat {}) = False
-   worth_wrapping (ParPat {}) = False
-   worth_wrapping (AsPat {})  = False
-   worth_wrapping _           = True
-   msg = hang (text "In the pattern:") 2 (ppr pat)
-
------------------------------------------------
-
--- | Check that a pattern isn't a GADT, or doesn't have existential variables,
--- in a situation in which that is not permitted (inside a lazy pattern, or
--- in arrow notation).
-checkGADT :: ConLike
-          -> [TyVar] -- ^ existentials
-          -> [Type]  -- ^ argument types
-          -> PatEnv
-          -> TcM ()
-checkGADT conlike ex_tvs arg_tys = \case
-  PE { pe_ctxt = LetPat {} }
-    -> return ()
-  PE { pe_ctxt = LamPat (ArrowMatchCtxt {}) }
-    | not $ isVanillaConLike conlike
-    -- See Note [Arrows and patterns]
-    -> failWithTc TcRnArrowProcGADTPattern
-  PE { pe_lazy = True }
-    | has_existentials
-    -- See Note [Existential check]
-    -> failWithTc TcRnLazyGADTPattern
-  _ -> return ()
-  where
-    has_existentials :: Bool
-    has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs
diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Rule.hs
+++ /dev/null
@@ -1,506 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1993-1998
-
--}
-
--- | Typechecking rewrite rules
-module GHC.Tc.Gen.Rule ( tcRules ) where
-
-import GHC.Prelude
-
-import GHC.Hs
-import GHC.Tc.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Solver
-import GHC.Tc.Solver.Monad ( runTcS )
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Gen.HsType
-import GHC.Tc.Gen.Expr
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.Unify( buildImplicationFor )
-
-import GHC.Core.Type
-import GHC.Core.Coercion( mkCoVarCo )
-import GHC.Core.TyCon( isTypeFamilyTyCon )
-import GHC.Core.Predicate
-
-import GHC.Types.Id
-import GHC.Types.Var( EvVar, tyVarName )
-import GHC.Types.Var.Set
-import GHC.Types.Basic ( RuleName, NonStandardDefaultingStrategy(..) )
-import GHC.Types.SrcLoc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Data.FastString
-import GHC.Data.Bag
-
-{-
-Note [Typechecking rules]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-We *infer* the typ of the LHS, and use that type to *check* the type of
-the RHS.  That means that higher-rank rules work reasonably well. Here's
-an example (test simplCore/should_compile/rule2.hs) produced by Roman:
-
-   foo :: (forall m. m a -> m b) -> m a -> m b
-   foo f = ...
-
-   bar :: (forall m. m a -> m a) -> m a -> m a
-   bar f = ...
-
-   {-# RULES "foo/bar" foo = bar #-}
-
-He wanted the rule to typecheck.
-
-Note [TcLevel in type checking rules]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Bringing type variables into scope naturally bumps the TcLevel. Thus, we type
-check the term-level binders in a bumped level, and we must accordingly bump
-the level whenever these binders are in scope.
-
-Note [Re-quantify type variables in rules]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this example from #17710:
-
-  foo :: forall k (a :: k) (b :: k). Proxy a -> Proxy b
-  foo x = Proxy
-  {-# RULES "foo" forall (x :: Proxy (a :: k)). foo x = Proxy #-}
-
-Written out in more detail, the "foo" rewrite rule looks like this:
-
-  forall k (a :: k). forall (x :: Proxy (a :: k)). foo @k @a @b0 x = Proxy @k @b0
-
-Where b0 is a unification variable. Where should b0 be quantified? We have to
-quantify it after k, since (b0 :: k). But generalization usually puts inferred
-type variables (such as b0) at the /front/ of the telescope! This creates a
-conflict.
-
-One option is to simply throw an error, per the principles of
-Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType. This is what would happen
-if we were generalising over a normal type signature. On the other hand, the
-types in a rewrite rule aren't quite "normal", since the notions of specified
-and inferred type variables aren't applicable.
-
-A more permissive design (and the design that GHC uses) is to simply requantify
-all of the type variables. That is, we would end up with this:
-
-  forall k (a :: k) (b :: k). forall (x :: Proxy (a :: k)). foo @k @a @b x = Proxy @k @b
-
-It's a bit strange putting the generalized variable `b` after the user-written
-variables `k` and `a`. But again, the notion of specificity is not relevant to
-rewrite rules, since one cannot "visibly apply" a rewrite rule. This design not
-only makes "foo" typecheck, but it also makes the implementation simpler.
-
-See also Note [Generalising in tcTyFamInstEqnGuts] in GHC.Tc.TyCl, which
-explains a very similar design when generalising over a type family instance
-equation.
--}
-
-tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc]
-tcRules decls = mapM (wrapLocMA tcRuleDecls) decls
-
-tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc)
-tcRuleDecls (HsRules { rds_ext = src
-                     , rds_rules = decls })
-   = do { tc_decls <- mapM (wrapLocMA tcRule) decls
-        ; return $ HsRules { rds_ext   = src
-                           , rds_rules = tc_decls } }
-
-tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTc)
-tcRule (HsRule { rd_ext  = ext
-               , rd_name = rname@(L _ name)
-               , rd_act  = act
-               , rd_tyvs = ty_bndrs
-               , rd_tmvs = tm_bndrs
-               , rd_lhs  = lhs
-               , rd_rhs  = rhs })
-  = addErrCtxt (ruleCtxt name)  $
-    do { traceTc "---- Rule ------" (pprFullRuleName (snd ext) rname)
-       ; skol_info <- mkSkolemInfo (RuleSkol name)
-        -- Note [Typechecking rules]
-       ; (tc_lvl, stuff) <- pushTcLevelM $
-                            generateRuleConstraints name ty_bndrs tm_bndrs lhs rhs
-
-       ; let (id_bndrs, lhs', lhs_wanted
-                      , rhs', rhs_wanted, rule_ty) = stuff
-
-       ; traceTc "tcRule 1" (vcat [ pprFullRuleName (snd ext) rname
-                                  , ppr lhs_wanted
-                                  , ppr rhs_wanted ])
-
-       ; (lhs_evs, residual_lhs_wanted)
-            <- simplifyRule name tc_lvl lhs_wanted rhs_wanted
-
-       -- SimplifyRule Plan, step 4
-       -- Now figure out what to quantify over
-       -- c.f. GHC.Tc.Solver.simplifyInfer
-       -- We quantify over any tyvars free in *either* the rule
-       --  *or* the bound variables.  The latter is important.  Consider
-       --      ss (x,(y,z)) = (x,z)
-       --      RULE:  forall v. fst (ss v) = fst v
-       -- The type of the rhs of the rule is just a, but v::(a,(b,c))
-       --
-       -- We also need to get the completely-unconstrained tyvars of
-       -- the LHS, lest they otherwise get defaulted to Any; but we do that
-       -- during zonking (see GHC.Tc.Utils.Zonk.zonkRule)
-
-       ; let tpl_ids = lhs_evs ++ id_bndrs
-
-       -- See Note [Re-quantify type variables in rules]
-       ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids)
-       ; let don't_default = nonDefaultableTyVarsOfWC residual_lhs_wanted
-       ; let weed_out = (`dVarSetMinusVarSet` don't_default)
-             quant_cands = forall_tkvs { dv_kvs = weed_out (dv_kvs forall_tkvs)
-                                       , dv_tvs = weed_out (dv_tvs forall_tkvs) }
-       ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars quant_cands
-       ; traceTc "tcRule" (vcat [ pprFullRuleName (snd ext) rname
-                                , text "forall_tkvs:" <+> ppr forall_tkvs
-                                , text "quant_cands:" <+> ppr quant_cands
-                                , text "don't_default:" <+> ppr don't_default
-                                , text "residual_lhs_wanted:" <+> ppr residual_lhs_wanted
-                                , text "qtkvs:" <+> ppr qtkvs
-                                , text "rule_ty:" <+> ppr rule_ty
-                                , text "ty_bndrs:" <+> ppr ty_bndrs
-                                , text "qtkvs ++ tpl_ids:" <+> ppr (qtkvs ++ tpl_ids)
-                                , text "tpl_id info:" <+>
-                                  vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ]
-                  ])
-
-       -- SimplfyRule Plan, step 5
-       -- Simplify the LHS and RHS constraints:
-       -- For the LHS constraints we must solve the remaining constraints
-       -- (a) so that we report insoluble ones
-       -- (b) so that we bind any soluble ones
-       ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs
-                                         lhs_evs residual_lhs_wanted
-       ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl (getSkolemInfo skol_info) qtkvs
-                                         lhs_evs rhs_wanted
-       ; emitImplications (lhs_implic `unionBags` rhs_implic)
-       ; return $ HsRule { rd_ext = ext
-                         , rd_name = rname
-                         , rd_act = act
-                         , rd_tyvs = ty_bndrs -- preserved for ppr-ing
-                         , rd_tmvs = map (noLocA . RuleBndr noAnn . noLocA)
-                                         (qtkvs ++ tpl_ids)
-                         , rd_lhs  = mkHsDictLet lhs_binds lhs'
-                         , rd_rhs  = mkHsDictLet rhs_binds rhs' } }
-
-generateRuleConstraints :: FastString
-                        -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn]
-                        -> LHsExpr GhcRn -> LHsExpr GhcRn
-                        -> TcM ( [TcId]
-                               , LHsExpr GhcTc, WantedConstraints
-                               , LHsExpr GhcTc, WantedConstraints
-                               , TcType )
-generateRuleConstraints rule_name ty_bndrs tm_bndrs lhs rhs
-  = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $
-                                                tcRuleBndrs rule_name ty_bndrs tm_bndrs
-              -- bndr_wanted constraints can include wildcard hole
-              -- constraints, which we should not forget about.
-              -- It may mention the skolem type variables bound by
-              -- the RULE.  c.f. #10072
-       ; tcExtendNameTyVarEnv [(tyVarName tv, tv) | tv <- tv_bndrs] $
-         tcExtendIdEnv    id_bndrs $
-    do { -- See Note [Solve order for RULES]
-         ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)
-       ; (rhs',            rhs_wanted) <- captureConstraints $
-                                          tcCheckMonoExpr rhs rule_ty
-       ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted
-       ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } }
-
--- See Note [TcLevel in type checking rules]
-tcRuleBndrs :: FastString -> Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn]
-            -> TcM ([TcTyVar], [Id])
-tcRuleBndrs rule_name (Just bndrs) xs
-  = do { skol_info <- mkSkolemInfo (RuleSkol rule_name)
-       ; (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol skol_info bndrs $
-                                  tcRuleTmBndrs rule_name xs
-       ; let tys1 = binderVars tybndrs1
-       ; return (tys1 ++ tys2, tms) }
-
-tcRuleBndrs rule_name Nothing xs
-  = tcRuleTmBndrs rule_name xs
-
--- See Note [TcLevel in type checking rules]
-tcRuleTmBndrs :: FastString -> [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])
-tcRuleTmBndrs _ [] = return ([],[])
-tcRuleTmBndrs rule_name (L _ (RuleBndr _ (L _ name)) : rule_bndrs)
-  = do  { ty <- newOpenFlexiTyVarTy
-        ; (tyvars, tmvars) <- tcRuleTmBndrs rule_name rule_bndrs
-        ; return (tyvars, mkLocalId name ManyTy ty : tmvars) }
-tcRuleTmBndrs rule_name (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
---  e.g         x :: a->a
---  The tyvar 'a' is brought into scope first, just as if you'd written
---              a::*, x :: a->a
---  If there's an explicit forall, the renamer would have already reported an
---   error for each out-of-scope type variable used
-  = do  { let ctxt = RuleSigCtxt rule_name name
-        ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt HM_Sig rn_ty OpenKind
-        ; let id  = mkLocalId name ManyTy id_ty
-                    -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType
-
-              -- The type variables scope over subsequent bindings; yuk
-        ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $
-                                   tcRuleTmBndrs rule_name rule_bndrs
-        ; return (map snd tvs ++ tyvars, id : tmvars) }
-
-ruleCtxt :: FastString -> SDoc
-ruleCtxt name = text "When checking the rewrite rule" <+>
-                doubleQuotes (ftext name)
-
-
-{-
-*********************************************************************************
-*                                                                                 *
-              Constraint simplification for rules
-*                                                                                 *
-***********************************************************************************
-
-Note [The SimplifyRule Plan]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Example.  Consider the following left-hand side of a rule
-        f (x == y) (y > z) = ...
-If we typecheck this expression we get constraints
-        d1 :: Ord a, d2 :: Eq a
-We do NOT want to "simplify" to the LHS
-        forall x::a, y::a, z::a, d1::Ord a.
-          f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ...
-Instead we want
-        forall x::a, y::a, z::a, d1::Ord a, d2::Eq a.
-          f ((==) d2 x y) ((>) d1 y z) = ...
-
-Here is another example:
-        fromIntegral :: (Integral a, Num b) => a -> b
-        {-# RULES "foo"  fromIntegral = id :: Int -> Int #-}
-In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But
-we *dont* want to get
-        forall dIntegralInt.
-           fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int
-because the scsel will mess up RULE matching.  Instead we want
-        forall dIntegralInt, dNumInt.
-          fromIntegral Int Int dIntegralInt dNumInt = id Int
-
-Even if we have
-        g (x == y) (y == z) = ..
-where the two dictionaries are *identical*, we do NOT WANT
-        forall x::a, y::a, z::a, d1::Eq a
-          f ((==) d1 x y) ((>) d1 y z) = ...
-because that will only match if the dict args are (visibly) equal.
-Instead we want to quantify over the dictionaries separately.
-
-In short, simplifyRuleLhs must *only* squash equalities, leaving
-all dicts unchanged, with absolutely no sharing.
-
-Also note that we can't solve the LHS constraints in isolation:
-Example   foo :: Ord a => a -> a
-          foo_spec :: Int -> Int
-          {-# RULE "foo"  foo = foo_spec #-}
-Here, it's the RHS that fixes the type variable
-
-HOWEVER, under a nested implication things are different
-Consider
-  f :: (forall a. Eq a => a->a) -> Bool -> ...
-  {-# RULES "foo" forall (v::forall b. Eq b => b->b).
-       f b True = ...
-    #-}
-Here we *must* solve the wanted (Eq a) from the given (Eq a)
-resulting from skolemising the argument type of g.  So we
-revert to SimplCheck when going under an implication.
-
-
---------- So the SimplifyRule Plan is this -----------------------
-
-* Step 0: typecheck the LHS and RHS to get constraints from each
-
-* Step 1: Simplify the LHS and RHS constraints all together in one bag,
-          but /discarding/ the simplified constraints. We do this only
-          to discover all unification equalities.
-
-* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take
-          advantage of those unifications
-
-* Setp 3: Partition the LHS constraints into the ones we will
-          quantify over, and the others.
-          See Note [RULE quantification over equalities]
-
-* Step 4: Decide on the type variables to quantify over
-
-* Step 5: Simplify the LHS and RHS constraints separately, using the
-          quantified constraints as givens
-
-Note [Solve order for RULES]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In step 1 above, we need to be a bit careful about solve order.
-Consider
-   f :: Int -> T Int
-   type instance T Int = Bool
-
-   RULE f 3 = True
-
-From the RULE we get
-   lhs-constraints:  T Int ~ alpha
-   rhs-constraints:  Bool ~ alpha
-where 'alpha' is the type that connects the two.  If we glom them
-all together, and solve the RHS constraint first, we might solve
-with alpha := Bool.  But then we'd end up with a RULE like
-
-    RULE: f 3 |> (co :: T Int ~ Bool) = True
-
-which is terrible.  We want
-
-    RULE: f 3 = True |> (sym co :: Bool ~ T Int)
-
-So we are careful to solve the LHS constraints first, and *then* the
-RHS constraints.  Actually much of this is done by the on-the-fly
-constraint solving, so the same order must be observed in
-tcRule.
-
-
-Note [RULE quantification over equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Deciding which equalities to quantify over is tricky:
- * We do not want to quantify over insoluble equalities (Int ~ Bool)
-    (a) because we prefer to report a LHS type error
-    (b) because if such things end up in 'givens' we get a bogus
-        "inaccessible code" error
-
- * But we do want to quantify over things like (a ~ F b), where
-   F is a type function.
-
-The difficulty is that it's hard to tell what is insoluble!
-So we see whether the simplification step yielded any type errors,
-and if so refrain from quantifying over *any* equalities.
-
-Note [Quantifying over coercion holes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Equality constraints from the LHS will emit coercion hole Wanteds.
-These don't have a name, so we can't quantify over them directly.
-Instead, because we really do want to quantify here, invent a new
-EvVar for the coercion, fill the hole with the invented EvVar, and
-then quantify over the EvVar. Not too tricky -- just some
-impedance matching, really.
-
-Note [Simplify cloned constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-At this stage, we're simplifying constraints only for insolubility
-and for unification. Note that all the evidence is quickly discarded.
-We use a clone of the real constraint. If we don't do this,
-then RHS coercion-hole constraints get filled in, only to get filled
-in *again* when solving the implications emitted from tcRule. That's
-terrible, so we avoid the problem by cloning the constraints.
-
--}
-
-simplifyRule :: RuleName
-             -> TcLevel                 -- Level at which to solve the constraints
-             -> WantedConstraints       -- Constraints from LHS
-             -> WantedConstraints       -- Constraints from RHS
-             -> TcM ( [EvVar]               -- Quantify over these LHS vars
-                    , WantedConstraints)    -- Residual un-quantified LHS constraints
--- See Note [The SimplifyRule Plan]
--- NB: This consumes all simple constraints on the LHS, but not
--- any LHS implication constraints.
-simplifyRule name tc_lvl lhs_wanted rhs_wanted
-  = do {
-       -- Note [The SimplifyRule Plan] step 1
-       -- First solve the LHS and *then* solve the RHS
-       -- Crucially, this performs unifications
-       -- Why clone?  See Note [Simplify cloned constraints]
-       ; lhs_clone <- cloneWC lhs_wanted
-       ; rhs_clone <- cloneWC rhs_wanted
-       ; setTcLevel tc_lvl $
-         discardResult     $
-         runTcS            $
-         do { _ <- solveWanteds lhs_clone
-            ; _ <- solveWanteds rhs_clone
-                  -- Why do them separately?
-                  -- See Note [Solve order for RULES]
-            ; return () }
-
-       -- Note [The SimplifyRule Plan] step 2
-       ; lhs_wanted <- zonkWC lhs_wanted
-       ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted
-
-       -- Note [The SimplifyRule Plan] step 3
-       ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts)
-
-       ; traceTc "simplifyRule" $
-         vcat [ text "LHS of rule" <+> doubleQuotes (ftext name)
-              , text "lhs_wanted" <+> ppr lhs_wanted
-              , text "rhs_wanted" <+> ppr rhs_wanted
-              , text "quant_cts" <+> ppr quant_cts
-              , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted
-              ]
-
-       ; return (quant_evs, residual_lhs_wanted) }
-
-  where
-    mk_quant_ev :: Ct -> TcM EvVar
-    mk_quant_ev ct
-      | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct
-      = case dest of
-          EvVarDest ev_id -> return ev_id
-          HoleDest hole   -> -- See Note [Quantifying over coercion holes]
-                             do { ev_id <- newEvVar pred
-                                ; fillCoercionHole hole (mkCoVarCo ev_id)
-                                ; return ev_id }
-    mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct)
-
-
-getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints)
--- Extract all the constraints we can quantify over,
---   also returning the depleted WantedConstraints
---
--- NB: we must look inside implications, because with
---     -fdefer-type-errors we generate implications rather eagerly;
---     see GHC.Tc.Utils.Unify.implicationNeeded. Not doing so caused #14732.
---
--- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged,
---   and attempt to solve them from the quantified constraints.  That
---   nearly works, but fails for a constraint like (d :: Eq Int).
---   We /do/ want to quantify over it, but the short-cut solver
---   (see GHC.Tc.Solver.Interact Note [Shortcut solving]) ignores the quantified
---   and instead solves from the top level.
---
---   So we must partition the WantedConstraints ourselves
---   Not hard, but tiresome.
-
-getRuleQuantCts wc
-  = float_wc emptyVarSet wc
-  where
-    float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)
-    float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs })
-      = ( simple_yes `andCts` implic_yes
-        , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_errors = errs })
-     where
-        (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples
-        (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs)
-                                                emptyBag implics
-
-    float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication)
-    float_implic skol_tvs yes1 imp
-      = (yes1 `andCts` yes2, imp { ic_wanted = no })
-      where
-        (yes2, no) = float_wc new_skol_tvs (ic_wanted imp)
-        new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp
-
-    rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool
-    rule_quant_ct skol_tvs ct = case classifyPredType (ctPred ct) of
-      EqPred _ t1 t2
-        | not (ok_eq t1 t2)
-        -> False        -- Note [RULE quantification over equalities]
-      _ -> tyCoVarsOfCt ct `disjointVarSet` skol_tvs
-
-    ok_eq t1 t2
-       | t1 `tcEqType` t2 = False
-       | otherwise        = is_fun_app t1 || is_fun_app t2
-
-    is_fun_app ty   -- ty is of form (F tys) where F is a type function
-      = case tyConAppTyCon_maybe ty of
-          Just tc -> isTypeFamilyTyCon tc
-          Nothing -> False
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ /dev/null
@@ -1,891 +0,0 @@
-{-
-(c) The University of Glasgow 2006-2012
-(c) The GRASP Project, Glasgow University, 1992-2002
-
--}
-
-
-{-# LANGUAGE TypeFamilies #-}
-
-module GHC.Tc.Gen.Sig(
-       TcSigInfo(..),
-       TcIdSigInfo(..), TcIdSigInst,
-       TcPatSynInfo(..),
-       TcSigFun,
-
-       isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName,
-       completeSigPolyId_maybe, isCompleteHsSig,
-       lhsSigWcTypeContextSpan, lhsSigTypeContextSpan,
-
-       tcTySigs, tcUserTypeSig, completeSigFromId,
-       tcInstSig,
-
-       TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,
-       mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags,
-       addInlinePrags, addInlinePragArity
-   ) where
-
-import GHC.Prelude
-import GHC.Data.FastString
-
-import GHC.Driver.Session
-import GHC.Driver.Backend
-
-import GHC.Hs
-
-
-import GHC.Tc.Errors.Types ( FixedRuntimeRepProvenance(..), TcRnMessage(..) )
-import GHC.Tc.Gen.HsType
-import GHC.Tc.Types
-import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.TcMType ( checkTypeHasFixedRuntimeRep )
-import GHC.Tc.Utils.Zonk
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Validity ( checkValidType )
-import GHC.Tc.Utils.Unify( tcTopSkolemise, unifyType )
-import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs )
-import GHC.Tc.Utils.Env( tcLookupId )
-import GHC.Tc.Types.Evidence( HsWrapper, (<.>) )
-
-import GHC.Core( hasSomeUnfolding )
-import GHC.Core.Type ( mkTyVarBinders )
-import GHC.Core.Multiplicity
-import GHC.Core.TyCo.Rep( mkNakedFunTy )
-
-import GHC.Types.Error
-import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars, invisArgTypeLike )
-import GHC.Types.Id  ( Id, idName, idType, setInlinePragma
-                     , mkLocalId, realIdUnfolding )
-import GHC.Types.Basic
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.SrcLoc
-
-import GHC.Builtin.Names( mkUnboundName )
-import GHC.Unit.Module( getModule )
-
-import GHC.Utils.Misc as Utils ( singleton )
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import GHC.Data.Maybe( orElse, whenIsJust )
-
-import Data.Maybe( mapMaybe )
-import qualified Data.List.NonEmpty as NE
-import Control.Monad( unless )
-
-
-{- -------------------------------------------------------------
-          Note [Overview of type signatures]
-----------------------------------------------------------------
-Type signatures, including partial signatures, are jolly tricky,
-especially on value bindings.  Here's an overview.
-
-    f :: forall a. [a] -> [a]
-    g :: forall b. _ -> b
-
-    f = ...g...
-    g = ...f...
-
-* HsSyn: a signature in a binding starts off as a TypeSig, in
-  type HsBinds.Sig
-
-* When starting a mutually recursive group, like f/g above, we
-  call tcTySig on each signature in the group.
-
-* tcTySig: Sig -> TcIdSigInfo
-  - For a /complete/ signature, like 'f' above, tcTySig kind-checks
-    the HsType, producing a Type, and wraps it in a CompleteSig, and
-    extend the type environment with this polymorphic 'f'.
-
-  - For a /partial/signature, like 'g' above, tcTySig does nothing
-    Instead it just wraps the pieces in a PartialSig, to be handled
-    later.
-
-* tcInstSig: TcIdSigInfo -> TcIdSigInst
-  In tcMonoBinds, when looking at an individual binding, we use
-  tcInstSig to instantiate the signature forall's in the signature,
-  and attribute that instantiated (monomorphic) type to the
-  binder.  You can see this in GHC.Tc.Gen.Bind.tcLhsId.
-
-  The instantiation does the obvious thing for complete signatures,
-  but for /partial/ signatures it starts from the HsSyn, so it
-  has to kind-check it etc: tcHsPartialSigType.  It's convenient
-  to do this at the same time as instantiation, because we can
-  make the wildcards into unification variables right away, rather
-  than somehow quantifying over them.  And the "TcLevel" of those
-  unification variables is correct because we are in tcMonoBinds.
-
-
-Note [Binding scoped type variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The type variables *brought into lexical scope* by a type signature
-may be a subset of the *quantified type variables* of the signatures,
-for two reasons:
-
-* With kind polymorphism a signature like
-    f :: forall f a. f a -> f a
-  may actually give rise to
-    f :: forall k. forall (f::k -> *) (a:k). f a -> f a
-  So the sig_tvs will be [k,f,a], but only f,a are scoped.
-  NB: the scoped ones are not necessarily the *initial* ones!
-
-* Even aside from kind polymorphism, there may be more instantiated
-  type variables than lexically-scoped ones.  For example:
-        type T a = forall b. b -> (a,b)
-        f :: forall c. T c
-  Here, the signature for f will have one scoped type variable, c,
-  but two instantiated type variables, c' and b'.
-
-However, all of this only applies to the renamer.  The typechecker
-just puts all of them into the type environment; any lexical-scope
-errors were dealt with by the renamer.
-
--}
-
-
-{- *********************************************************************
-*                                                                      *
-             Utility functions for TcSigInfo
-*                                                                      *
-********************************************************************* -}
-
-tcIdSigName :: TcIdSigInfo -> Name
-tcIdSigName (CompleteSig { sig_bndr = id }) = idName id
-tcIdSigName (PartialSig { psig_name = n })  = n
-
-tcSigInfoName :: TcSigInfo -> Name
-tcSigInfoName (TcIdSig     idsi) = tcIdSigName idsi
-tcSigInfoName (TcPatSynSig tpsi) = patsig_name tpsi
-
-completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
-completeSigPolyId_maybe sig
-  | TcIdSig sig_info <- sig
-  , CompleteSig { sig_bndr = id } <- sig_info = Just id
-  | otherwise                                 = Nothing
-
-
-{- *********************************************************************
-*                                                                      *
-               Typechecking user signatures
-*                                                                      *
-********************************************************************* -}
-
-tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun)
-tcTySigs hs_sigs
-  = checkNoErrs $
-    do { -- Fail if any of the signatures is duff
-         -- Hence mapAndReportM
-         -- See Note [Fail eagerly on bad signatures]
-         ty_sigs_s <- mapAndReportM tcTySig hs_sigs
-
-       ; let ty_sigs = concat ty_sigs_s
-             poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs
-                        -- The returned [TcId] are the ones for which we have
-                        -- a complete type signature.
-                        -- See Note [Complete and partial type signatures]
-             env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs]
-
-       ; return (poly_ids, lookupNameEnv env) }
-
-tcTySig :: LSig GhcRn -> TcM [TcSigInfo]
-tcTySig (L _ (XSig (IdSig id)))
-  = do { let ctxt = FunSigCtxt (idName id) NoRRC
-                    -- NoRRC: do not report redundant constraints
-                    -- The user has no control over the signature!
-             sig = completeSigFromId ctxt id
-       ; return [TcIdSig sig] }
-
-tcTySig (L loc (TypeSig _ names sig_ty))
-  = setSrcSpanA loc $
-    do { sigs <- sequence [ tcUserTypeSig (locA loc) sig_ty (Just name)
-                          | L _ name <- names ]
-       ; return (map TcIdSig sigs) }
-
-tcTySig (L loc (PatSynSig _ names sig_ty))
-  = setSrcSpanA loc $
-    do { tpsigs <- sequence [ tcPatSynSig name sig_ty
-                            | L _ name <- names ]
-       ; return (map TcPatSynSig tpsigs) }
-
-tcTySig _ = return []
-
-
-tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name
-              -> TcM TcIdSigInfo
--- A function or expression type signature
--- Returns a fully quantified type signature; even the wildcards
--- are quantified with ordinary skolems that should be instantiated
---
--- The SrcSpan is what to declare as the binding site of the
--- any skolems in the signature. For function signatures we
--- use the whole `f :: ty' signature; for expression signatures
--- just the type part.
---
--- Just n  => Function type signature       name :: type
--- Nothing => Expression type signature   <expr> :: type
-tcUserTypeSig loc hs_sig_ty mb_name
-  | isCompleteHsSig hs_sig_ty
-  = do { sigma_ty <- tcHsSigWcType ctxt_no_rrc hs_sig_ty
-       ; traceTc "tcuser" (ppr sigma_ty)
-       ; return $
-         CompleteSig { sig_bndr  = mkLocalId name ManyTy sigma_ty
-                                   -- We use `Many' as the multiplicity here,
-                                   -- as if this identifier corresponds to
-                                   -- anything, it is a top-level
-                                   -- definition. Which are all unrestricted in
-                                   -- the current implementation.
-                     , sig_ctxt  = ctxt_rrc  -- Report redundant constraints
-                     , sig_loc   = loc } }
-                       -- Location of the <type> in   f :: <type>
-
-  -- Partial sig with wildcards
-  | otherwise
-  = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty
-                       , sig_ctxt = ctxt_no_rrc, sig_loc = loc })
-  where
-    name   = case mb_name of
-               Just n  -> n
-               Nothing -> mkUnboundName (mkVarOccFS (fsLit "<expression>"))
-
-    ctxt_rrc    = ctxt_fn (lhsSigWcTypeContextSpan hs_sig_ty)
-    ctxt_no_rrc = ctxt_fn NoRRC
-
-    ctxt_fn :: ReportRedundantConstraints -> UserTypeCtxt
-    ctxt_fn rcc = case mb_name of
-               Just n  -> FunSigCtxt n rcc
-               Nothing -> ExprSigCtxt rcc
-
-lhsSigWcTypeContextSpan :: LHsSigWcType GhcRn -> ReportRedundantConstraints
--- | Find the location of the top-level context of a HsType.  For example:
---
--- @
---   forall a b. (Eq a, Ord b) => blah
---               ^^^^^^^^^^^^^
--- @
--- If there is none, return Nothing
-lhsSigWcTypeContextSpan (HsWC { hswc_body = sigType }) = lhsSigTypeContextSpan sigType
-
-lhsSigTypeContextSpan :: LHsSigType GhcRn -> ReportRedundantConstraints
-lhsSigTypeContextSpan (L _ HsSig { sig_body = sig_ty }) = go sig_ty
-  where
-    go (L _ (HsQualTy { hst_ctxt = L span _ })) = WantRRC $ locA span -- Found it!
-    go (L _ (HsForAllTy { hst_body = hs_ty })) = go hs_ty  -- Look under foralls
-    go (L _ (HsParTy _ hs_ty)) = go hs_ty  -- Look under parens
-    go _ = NoRRC  -- Did not find it
-
-completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo
--- Used for instance methods and record selectors
-completeSigFromId ctxt id
-  = CompleteSig { sig_bndr = id
-                , sig_ctxt = ctxt
-                , sig_loc  = getSrcSpan id }
-
-isCompleteHsSig :: LHsSigWcType GhcRn -> Bool
--- ^ If there are no wildcards, return a LHsSigWcType
-isCompleteHsSig (HsWC { hswc_ext = wcs, hswc_body = hs_sig_ty })
-   = null wcs && no_anon_wc_sig_ty hs_sig_ty
-
-no_anon_wc_sig_ty :: LHsSigType GhcRn -> Bool
-no_anon_wc_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body}))
-  =  all no_anon_wc_tvb (hsOuterExplicitBndrs outer_bndrs)
-  && no_anon_wc_ty body
-
-no_anon_wc_ty :: LHsType GhcRn -> Bool
-no_anon_wc_ty lty = go lty
-  where
-    go (L _ ty) = case ty of
-      HsWildCardTy _                 -> False
-      HsAppTy _ ty1 ty2              -> go ty1 && go ty2
-      HsAppKindTy _ ty ki            -> go ty && go ki
-      HsFunTy _ w ty1 ty2            -> go ty1 && go ty2 && go (arrowToHsType w)
-      HsListTy _ ty                  -> go ty
-      HsTupleTy _ _ tys              -> gos tys
-      HsSumTy _ tys                  -> gos tys
-      HsOpTy _ _ ty1 _ ty2           -> go ty1 && go ty2
-      HsParTy _ ty                   -> go ty
-      HsIParamTy _ _ ty              -> go ty
-      HsKindSig _ ty kind            -> go ty && go kind
-      HsDocTy _ ty _                 -> go ty
-      HsBangTy _ _ ty                -> go ty
-      HsRecTy _ flds                 -> gos $ map (cd_fld_type . unLoc) flds
-      HsExplicitListTy _ _ tys       -> gos tys
-      HsExplicitTupleTy _ tys        -> gos tys
-      HsForAllTy { hst_tele = tele
-                 , hst_body = ty } -> no_anon_wc_tele tele
-                                        && go ty
-      HsQualTy { hst_ctxt = ctxt
-               , hst_body = ty }  -> gos (unLoc ctxt) && go ty
-      HsSpliceTy (HsUntypedSpliceTop _ ty) _ -> go ty
-      HsSpliceTy (HsUntypedSpliceNested _) _ -> True
-      HsTyLit{} -> True
-      HsTyVar{} -> True
-      HsStarTy{} -> True
-      XHsType{} -> True       -- HsCoreTy, which does not have any wildcard
-
-    gos = all go
-
-no_anon_wc_tele :: HsForAllTelescope GhcRn -> Bool
-no_anon_wc_tele tele = case tele of
-  HsForAllVis   { hsf_vis_bndrs   = ltvs } -> all no_anon_wc_tvb ltvs
-  HsForAllInvis { hsf_invis_bndrs = ltvs } -> all no_anon_wc_tvb ltvs
-
-no_anon_wc_tvb :: LHsTyVarBndr flag GhcRn -> Bool
-no_anon_wc_tvb (L _ tvb) = case tvb of
-  UserTyVar _ _ _      -> True
-  KindedTyVar _ _ _ ki -> no_anon_wc_ty ki
-
-{- Note [Fail eagerly on bad signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If a type signature is wrong, fail immediately:
-
- * the type sigs may bind type variables, so proceeding without them
-   can lead to a cascade of errors
-
- * the type signature might be ambiguous, in which case checking
-   the code against the signature will give a very similar error
-   to the ambiguity error.
-
-ToDo: this means we fall over if any top-level type signature in the
-module is wrong, because we typecheck all the signatures together
-(see GHC.Tc.Gen.Bind.tcValBinds).  Moreover, because of top-level
-captureTopConstraints, only insoluble constraints will be reported.
-We typecheck all signatures at the same time because a signature
-like   f,g :: blah   might have f and g from different SCCs.
-
-So it's a bit awkward to get better error recovery, and no one
-has complained!
--}
-
-{- *********************************************************************
-*                                                                      *
-        Type checking a pattern synonym signature
-*                                                                      *
-************************************************************************
-
-Note [Pattern synonym signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Pattern synonym signatures are surprisingly tricky (see #11224 for example).
-In general they look like this:
-
-   pattern P :: forall univ_tvs. req_theta
-             => forall ex_tvs. prov_theta
-             => arg1 -> .. -> argn -> res_ty
-
-For parsing and renaming we treat the signature as an ordinary LHsSigType.
-
-Once we get to type checking, we decompose it into its parts, in tcPatSynSig.
-
-* Note that 'forall univ_tvs' and 'req_theta =>'
-        and 'forall ex_tvs'   and 'prov_theta =>'
-  are all optional.  We gather the pieces at the top of tcPatSynSig
-
-* Initially the implicitly-bound tyvars (added by the renamer) include both
-  universal and existential vars.
-
-* After we kind-check the pieces and convert to Types, we do kind generalisation.
-
-Note [Report unsolved equalities in tcPatSynSig]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's important that we solve /all/ the equalities in a pattern
-synonym signature, because we are going to zonk the signature to
-a Type (not a TcType), in GHC.Tc.TyCl.PatSyn.tc_patsyn_finish, and that
-fails if there are un-filled-in coercion variables mentioned
-in the type (#15694).
-
-So we solve all the equalities we can, and report any unsolved ones,
-rather than leaving them in the ambient constraints to be solved
-later.  Pattern synonyms are top-level, so there's no problem with
-completely solving them.
--}
-
-tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo
--- See Note [Pattern synonym signatures]
--- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType
-tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty}))
-  | (hs_req, hs_ty1) <- splitLHsQualTy hs_ty
-  , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1
-  = do { traceTc "tcPatSynSig 1" (ppr sig_ty)
-
-       ; skol_info <- mkSkolemInfo (DataConSkol name)
-       ; (tclvl, wanted, (outer_bndrs, (ex_bndrs, (req, prov, body_ty))))
-           <- pushLevelAndSolveEqualitiesX "tcPatSynSig"           $
-                     -- See Note [Report unsolved equalities in tcPatSynSig]
-              tcOuterTKBndrs skol_info hs_outer_bndrs   $
-              tcExplicitTKBndrs skol_info ex_hs_tvbndrs $
-              do { req     <- tcHsContext hs_req
-                 ; prov    <- tcHsContext hs_prov
-                 ; body_ty <- tcHsOpenType hs_body_ty
-                     -- A (literal) pattern can be unlifted;
-                     -- e.g. pattern Zero <- 0#   (#12094)
-                 ; return (req, prov, body_ty) }
-
-       ; let implicit_tvs :: [TcTyVar]
-             univ_bndrs   :: [TcInvisTVBinder]
-             (implicit_tvs, univ_bndrs) = case outer_bndrs of
-               HsOuterImplicit{hso_ximplicit = implicit_tvs} -> (implicit_tvs, [])
-               HsOuterExplicit{hso_xexplicit = univ_bndrs}   -> ([], univ_bndrs)
-
-       ; implicit_tvs <- zonkAndScopedSort implicit_tvs
-       ; let implicit_bndrs = mkTyVarBinders SpecifiedSpec implicit_tvs
-
-       -- Kind generalisation
-       ; let ungen_patsyn_ty = build_patsyn_type implicit_bndrs univ_bndrs
-                                                 req ex_bndrs prov body_ty
-       ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty)
-       ; kvs <- kindGeneralizeAll skol_info ungen_patsyn_ty
-       ; reportUnsolvedEqualities skol_info kvs tclvl wanted
-               -- See Note [Report unsolved equalities in tcPatSynSig]
-
-       -- These are /signatures/ so we zonk to squeeze out any kind
-       -- unification variables.  Do this after kindGeneralizeAll which may
-       -- default kind variables to *.
-       ; ze                   <- mkEmptyZonkEnv NoFlexi
-       ; (ze, kv_bndrs)       <- zonkTyVarBindersX   ze (mkTyVarBinders InferredSpec kvs)
-       ; (ze, implicit_bndrs) <- zonkTyVarBindersX   ze implicit_bndrs
-       ; (ze, univ_bndrs)     <- zonkTyVarBindersX   ze univ_bndrs
-       ; (ze, ex_bndrs)       <- zonkTyVarBindersX   ze ex_bndrs
-       ; req                  <- zonkTcTypesToTypesX ze req
-       ; prov                 <- zonkTcTypesToTypesX ze prov
-       ; body_ty              <- zonkTcTypeToTypeX   ze body_ty
-
-       -- Now do validity checking
-       ; checkValidType ctxt $
-         build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body_ty
-
-       -- Neither argument types nor the return type may be representation polymorphic.
-       -- This is because, when creating a matcher:
-       --   - the argument types become the binder types (see test RepPolyPatySynArg),
-       --   - the return type becomes the scrutinee type (see test RepPolyPatSynRes).
-       ; let (arg_tys, res_ty) = tcSplitFunTys body_ty
-       ; mapM_
-           (\(Scaled _ arg_ty) -> checkTypeHasFixedRuntimeRep FixedRuntimeRepPatSynSigArg arg_ty)
-           arg_tys
-       ; checkTypeHasFixedRuntimeRep FixedRuntimeRepPatSynSigRes res_ty
-
-       ; traceTc "tcTySig }" $
-         vcat [ text "kvs"          <+> ppr_tvs (binderVars kv_bndrs)
-              , text "implicit_tvs" <+> ppr_tvs (binderVars implicit_bndrs)
-              , text "univ_tvs"     <+> ppr_tvs (binderVars univ_bndrs)
-              , text "req" <+> ppr req
-              , text "ex_tvs" <+> ppr_tvs (binderVars ex_bndrs)
-              , text "prov" <+> ppr prov
-              , text "body_ty" <+> ppr body_ty ]
-       ; return (TPSI { patsig_name = name
-                      , patsig_implicit_bndrs = kv_bndrs ++ implicit_bndrs
-                      , patsig_univ_bndrs     = univ_bndrs
-                      , patsig_req            = req
-                      , patsig_ex_bndrs       = ex_bndrs
-                      , patsig_prov           = prov
-                      , patsig_body_ty        = body_ty }) }
-  where
-    ctxt = PatSynCtxt name
-
-    build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body
-      = mkInvisForAllTys implicit_bndrs $
-        mkInvisForAllTys univ_bndrs $
-        mk_naked_phi_ty req $
-        mkInvisForAllTys ex_bndrs $
-        mk_naked_phi_ty prov $
-        body
-
-    -- Use mk_naked_phi_ty because we call build_patsyn_type /before zonking/
-    -- just before kindGeneraliseAll, and the invariants that mkPhiTy checks
-    -- don't hold of the un-zonked types.  #22521 was a case in point.
-    -- (We also called build_patsyn_type on the fully zonked type, so mkPhiTy
-    --  would work; but it doesn't seem worth duplicating the code.)
-    mk_naked_phi_ty :: [TcPredType] -> TcType -> TcType
-    mk_naked_phi_ty theta body = foldr (mkNakedFunTy invisArgTypeLike) body theta
-
-ppr_tvs :: [TyVar] -> SDoc
-ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)
-                           | tv <- tvs])
-
-
-{- *********************************************************************
-*                                                                      *
-               Instantiating user signatures
-*                                                                      *
-********************************************************************* -}
-
-
-tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst
--- Instantiate a type signature; only used with plan InferGen
-tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc })
-  = setSrcSpan loc $  -- Set the binding site of the tyvars
-    do { (tv_prs, theta, tau) <- tcInstTypeBndrs (idType poly_id)
-              -- See Note [Pattern bindings and complete signatures]
-
-       ; return (TISI { sig_inst_sig   = sig
-                      , sig_inst_skols = tv_prs
-                      , sig_inst_wcs   = []
-                      , sig_inst_wcx   = Nothing
-                      , sig_inst_theta = theta
-                      , sig_inst_tau   = tau }) }
-
-tcInstSig hs_sig@(PartialSig { psig_hs_ty = hs_ty
-                             , sig_ctxt = ctxt
-                             , sig_loc = loc })
-  = setSrcSpan loc $  -- Set the binding site of the tyvars
-    do { traceTc "Staring partial sig {" (ppr hs_sig)
-       ; (wcs, wcx, tv_prs, theta, tau) <- tcHsPartialSigType ctxt hs_ty
-         -- See Note [Checking partial type signatures] in GHC.Tc.Gen.HsType
-
-       ; let inst_sig = TISI { sig_inst_sig   = hs_sig
-                             , sig_inst_skols = tv_prs
-                             , sig_inst_wcs   = wcs
-                             , sig_inst_wcx   = wcx
-                             , sig_inst_theta = theta
-                             , sig_inst_tau   = tau }
-       ; traceTc "End partial sig }" (ppr inst_sig)
-       ; return inst_sig }
-
-
-{- Note [Pattern bindings and complete signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-      data T a = MkT a a
-      f :: forall a. a->a
-      g :: forall b. b->b
-      MkT f g = MkT (\x->x) (\y->y)
-Here we'll infer a type from the pattern of 'T a', but if we feed in
-the signature types for f and g, we'll end up unifying 'a' and 'b'
-
-So we instantiate f and g's signature with TyVarTv skolems
-(newMetaTyVarTyVars) that can unify with each other.  If too much
-unification takes place, we'll find out when we do the final
-impedance-matching check in GHC.Tc.Gen.Bind.mkExport
-
-See Note [TyVarTv] in GHC.Tc.Utils.TcMType
-
-None of this applies to a function binding with a complete
-signature, which doesn't use tcInstSig.  See GHC.Tc.Gen.Bind.tcPolyCheck.
--}
-
-{- *********************************************************************
-*                                                                      *
-                   Pragmas and PragEnv
-*                                                                      *
-********************************************************************* -}
-
-type TcPragEnv = NameEnv [LSig GhcRn]
-
-emptyPragEnv :: TcPragEnv
-emptyPragEnv = emptyNameEnv
-
-lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn]
-lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` []
-
-extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv
-extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) Utils.singleton prag_fn n sig
-
----------------
-mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
-mkPragEnv sigs binds
-  = foldl' extendPragEnv emptyNameEnv prs
-  where
-    prs = mapMaybe get_sig sigs
-
-    get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)
-    get_sig sig@(L _ (SpecSig _ (L _ nm) _ _))   = Just (nm, add_arity nm sig)
-    get_sig sig@(L _ (InlineSig _ (L _ nm) _))   = Just (nm, add_arity nm sig)
-    get_sig sig@(L _ (SCCFunSig _ (L _ nm) _)) = Just (nm, sig)
-    get_sig _ = Nothing
-
-    add_arity n sig  -- Adjust inl_sat field to match visible arity of function
-      = case lookupNameEnv ar_env n of
-          Just ar -> addInlinePragArity ar sig
-          Nothing -> sig -- See Note [Pattern synonym inline arity]
-
-    -- ar_env maps a local to the arity of its definition
-    ar_env :: NameEnv Arity
-    ar_env = foldr lhsBindArity emptyNameEnv binds
-
-addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn
-addInlinePragArity ar (L l (InlineSig x nm inl))  = L l (InlineSig x nm (add_inl_arity ar inl))
-addInlinePragArity ar (L l (SpecSig x nm ty inl)) = L l (SpecSig x nm ty (add_inl_arity ar inl))
-addInlinePragArity _ sig = sig
-
-add_inl_arity :: Arity -> InlinePragma -> InlinePragma
-add_inl_arity ar prag@(InlinePragma { inl_inline = inl_spec })
-  | Inline {} <- inl_spec  -- Add arity only for real INLINE pragmas, not INLINABLE
-  = prag { inl_sat = Just ar }
-  | otherwise
-  = prag
-
-lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
-lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
-  = extendNameEnv env (unLoc id) (matchGroupArity ms)
-lhsBindArity _ env = env        -- PatBind/VarBind
-
-
------------------
-addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId
-addInlinePrags poly_id prags_for_me
-  | inl@(L _ prag) : inls <- inl_prags
-  = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag)
-       ; unless (null inls) (warn_multiple_inlines inl inls)
-       ; return (poly_id `setInlinePragma` prag) }
-  | otherwise
-  = return poly_id
-  where
-    inl_prags = [L loc prag | L loc (InlineSig _ _ prag) <- prags_for_me]
-
-    warn_multiple_inlines _ [] = return ()
-
-    warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls)
-       | inlinePragmaActivation prag1 == inlinePragmaActivation prag2
-       , noUserInlineSpec (inlinePragmaSpec prag1)
-       =    -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop
-            -- and inl2 is a user NOINLINE pragma; we don't want to complain
-         warn_multiple_inlines inl2 inls
-       | otherwise
-       = setSrcSpanA loc $
-         let dia = TcRnMultipleInlinePragmas poly_id inl1 (inl2 NE.:| inls)
-         in addDiagnosticTc dia
-
-
-{- Note [Pattern synonym inline arity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-    {-# INLINE P #-}
-    pattern P x = (x, True)
-
-The INLINE pragma attaches to both the /matcher/ and the /builder/ for
-the pattern synonym; see Note [Pragmas for pattern synonyms] in
-GHC.Tc.TyCl.PatSyn.  But they have different inline arities (i.e. number
-of binders to which we apply the function before inlining), and we don't
-know what those arities are yet.  So for pattern synonyms we don't set
-the inl_sat field yet; instead we do so (via addInlinePragArity) in
-GHC.Tc.TyCl.PatSyn.tcPatSynMatcher and tcPatSynBuilderBind.
-
-It's a bit messy that we set the arities in different ways.  Perhaps we
-should add the arity later for all binders.  But it works fine like this.
--}
-
-
-{- *********************************************************************
-*                                                                      *
-                   SPECIALISE pragmas
-*                                                                      *
-************************************************************************
-
-Note [Handling SPECIALISE pragmas]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The basic idea is this:
-
-   foo :: Num a => a -> b -> a
-   {-# SPECIALISE foo :: Int -> b -> Int #-}
-
-We check that
-   (forall a b. Num a => a -> b -> a)
-      is more polymorphic than
-   forall b. Int -> b -> Int
-(for which we could use tcSubType, but see below), generating a HsWrapper
-to connect the two, something like
-      wrap = /\b. <hole> Int b dNumInt
-This wrapper is put in the TcSpecPrag, in the ABExport record of
-the AbsBinds.
-
-
-        f :: (Eq a, Ix b) => a -> b -> Bool
-        {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
-        f = <poly_rhs>
-
-From this the typechecker generates
-
-    AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
-
-    SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
-                      -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
-
-From these we generate:
-
-    Rule:       forall p, q, (dp:Ix p), (dq:Ix q).
-                    f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
-
-    Spec bind:  f_spec = wrap_fn <poly_rhs>
-
-Note that
-
-  * The LHS of the rule may mention dictionary *expressions* (eg
-    $dfIxPair dp dq), and that is essential because the dp, dq are
-    needed on the RHS.
-
-  * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
-    can fully specialise it.
-
-From the TcSpecPrag, in GHC.HsToCore.Binds we generate a binding for f_spec and a RULE:
-
-   f_spec :: Int -> b -> Int
-   f_spec = wrap<f rhs>
-
-   RULE: forall b (d:Num b). f b d = f_spec b
-
-The RULE is generated by taking apart the HsWrapper, which is a little
-delicate, but works.
-
-Some wrinkles
-
-1. In tcSpecWrapper, rather than calling tcSubType, we directly call
-   skolemise/instantiate.  That is mainly because of wrinkle (2).
-
-   Historical note: in the past, tcSubType did co/contra stuff, which
-   could generate too complex a LHS for the RULE, which was another
-   reason for not using tcSubType.  But that reason has gone away
-   with simple subsumption (#17775).
-
-2. We need to take care with type families (#5821).  Consider
-      type instance F Int = Bool
-      f :: Num a => a -> F a
-      {-# SPECIALISE foo :: Int -> Bool #-}
-
-  We *could* try to generate an f_spec with precisely the declared type:
-      f_spec :: Int -> Bool
-      f_spec = <f rhs> Int dNumInt |> co
-
-      RULE: forall d. f Int d = f_spec |> sym co
-
-  but the 'co' and 'sym co' are (a) playing no useful role, and (b) are
-  hard to generate.  At all costs we must avoid this:
-      RULE: forall d. f Int d |> co = f_spec
-  because the LHS will never match (indeed it's rejected in
-  decomposeRuleLhs).
-
-  So we simply do this:
-    - Generate a constraint to check that the specialised type (after
-      skolemisation) is equal to the instantiated function type.
-    - But *discard* the evidence (coercion) for that constraint,
-      so that we ultimately generate the simpler code
-          f_spec :: Int -> F Int
-          f_spec = <f rhs> Int dNumInt
-
-          RULE: forall d. f Int d = f_spec
-      You can see this discarding happening in tcSpecPrag
-
-3. Note that the HsWrapper can transform *any* function with the right
-   type prefix
-       forall ab. (Eq a, Ix b) => XXX
-   regardless of XXX.  It's sort of polymorphic in XXX.  This is
-   useful: we use the same wrapper to transform each of the class ops, as
-   well as the dict.  That's what goes on in GHC.Tc.TyCl.Instance.mk_meth_spec_prags
--}
-
-tcSpecPrags :: Id -> [LSig GhcRn]
-            -> TcM [LTcSpecPrag]
--- Add INLINE and SPECIALSE pragmas
---    INLINE prags are added to the (polymorphic) Id directly
---    SPECIALISE prags are passed to the desugarer via TcSpecPrags
--- Pre-condition: the poly_id is zonked
--- Reason: required by tcSubExp
-tcSpecPrags poly_id prag_sigs
-  = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)
-       ; whenIsJust (NE.nonEmpty bad_sigs) warn_discarded_sigs
-       ; pss <- mapAndRecoverM (wrapLocMA (tcSpecPrag poly_id)) spec_sigs
-       ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss }
-  where
-    spec_sigs = filter isSpecLSig prag_sigs
-    bad_sigs  = filter is_bad_sig prag_sigs
-    is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s)
-
-    warn_discarded_sigs bad_sigs_ne
-      = let dia = TcRnUnexpectedPragmas poly_id bad_sigs_ne
-        in addDiagnosticTc dia
-
---------------
-tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]
-tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)
--- See Note [Handling SPECIALISE pragmas]
---
--- The Name fun_name in the SpecSig may not be the same as that of the poly_id
--- Example: SPECIALISE for a class method: the Name in the SpecSig is
---          for the selector Id, but the poly_id is something like $cop
--- However we want to use fun_name in the error message, since that is
--- what the user wrote (#8537)
-  = addErrCtxt (spec_ctxt prag) $
-    do  { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl)) $
-                 TcRnNonOverloadedSpecialisePragma fun_name
-                    -- Note [SPECIALISE pragmas]
-        ; spec_prags <- mapM tc_one hs_tys
-        ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags)))
-        ; return spec_prags }
-  where
-    name      = idName poly_id
-    poly_ty   = idType poly_id
-    spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag)
-
-    tc_one hs_ty
-      = do { spec_ty <- tcHsSigType   (FunSigCtxt name NoRRC) hs_ty
-           ; wrap    <- tcSpecWrapper (FunSigCtxt name (lhsSigTypeContextSpan hs_ty)) poly_ty spec_ty
-           ; return (SpecPrag poly_id wrap inl) }
-
-tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
-
---------------
-tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper
--- A simpler variant of tcSubType, used for SPECIALISE pragmas
--- See Note [Handling SPECIALISE pragmas], wrinkle 1
-tcSpecWrapper ctxt poly_ty spec_ty
-  = do { (sk_wrap, inst_wrap)
-               <- tcTopSkolemise ctxt spec_ty $ \ spec_tau ->
-                  do { (inst_wrap, tau) <- topInstantiate orig poly_ty
-                     ; _ <- unifyType Nothing spec_tau tau
-                            -- Deliberately ignore the evidence
-                            -- See Note [Handling SPECIALISE pragmas],
-                            --   wrinkle (2)
-                     ; return inst_wrap }
-       ; return (sk_wrap <.> inst_wrap) }
-  where
-    orig = SpecPragOrigin ctxt
-
---------------
-tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag]
--- SPECIALISE pragmas for imported things
-tcImpPrags prags
-  = do { this_mod <- getModule
-       ; dflags <- getDynFlags
-       ; if (not_specialising dflags) then
-            return []
-         else do
-            { pss <- mapAndRecoverM (wrapLocMA tcImpSpec)
-                     [L loc (name,prag)
-                             | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags
-                             , not (nameIsLocalOrFrom this_mod name) ]
-            ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } }
-  where
-    -- Ignore SPECIALISE pragmas for imported things
-    -- when we aren't specialising, or when we aren't generating
-    -- code.  The latter happens when Haddocking the base library;
-    -- we don't want complaints about lack of INLINABLE pragmas
-    not_specialising dflags =
-      not (gopt Opt_Specialise dflags) || not (backendRespectsSpecialise (backend dflags))
-
-tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]
-tcImpSpec (name, prag)
- = do { id <- tcLookupId name
-      ; if hasSomeUnfolding (realIdUnfolding id)
-           -- See Note [SPECIALISE pragmas for imported Ids]
-        then tcSpecPrag id prag
-        else do { let dia = TcRnSpecialiseNotVisible name
-                ; addDiagnosticTc dia
-                ; return [] } }
-
-{- Note [SPECIALISE pragmas for imported Ids]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-An imported Id may or may not have an unfolding.  If not, we obviously
-can't specialise it here; indeed the desugar falls over (#18118).
-
-We used to test whether it had a user-specified INLINABLE pragma but,
-because of Note [Worker/wrapper for INLINABLE functions] in
-GHC.Core.Opt.WorkWrap, even an INLINABLE function may end up with
-a wrapper that has no pragma, just an unfolding (#19246).  So now
-we just test whether the function has an unfolding.
-
-There's a risk that a pragma-free function may have an unfolding now
-(because it is fairly small), and then gets a bit bigger, and no
-longer has an unfolding in the future.  But then you'll get a helpful
-error message suggesting an INLINABLE pragma, which you can follow.
-That seems enough for now.
--}
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ /dev/null
@@ -1,2877 +0,0 @@
-{-# LANGUAGE CPP                    #-}
-{-# LANGUAGE FlexibleInstances      #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE GADTs                  #-}
-{-# LANGUAGE InstanceSigs           #-}
-{-# LANGUAGE MultiWayIf             #-}
-{-# LANGUAGE ScopedTypeVariables    #-}
-{-# LANGUAGE TupleSections          #-}
-{-# LANGUAGE TypeFamilies           #-}
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-{-# LANGUAGE NamedFieldPuns #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
--- | Template Haskell splices
-module GHC.Tc.Gen.Splice(
-     tcTypedSplice, tcTypedBracket, tcUntypedBracket,
-     runAnnotation,
-
-     runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
-     tcTopSpliceExpr, lookupThName_maybe,
-     defaultRunMeta, runMeta', runRemoteModFinalizers,
-     finishTH, runTopSplice
-      ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Errors
-import GHC.Driver.Plugins
-import GHC.Driver.Main
-import GHC.Driver.Session
-import GHC.Driver.Env
-import GHC.Driver.Hooks
-import GHC.Driver.Config.Diagnostic
-import GHC.Driver.Config.Finder
-
-import GHC.Hs
-
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Gen.Expr
-import GHC.Tc.Utils.Unify
-import GHC.Tc.Utils.Env
-import GHC.Tc.Types.Origin
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Utils.Zonk
-import GHC.Tc.Solver
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Gen.HsType
-import GHC.Tc.Instance.Family
-import GHC.Tc.Utils.Instantiate
-
-import GHC.Core.Multiplicity
-import GHC.Core.Coercion( etaExpandCoAxBranch )
-import GHC.Core.Type as Type
-import GHC.Core.TyCo.Rep as TyCoRep
-import GHC.Core.FamInstEnv
-import GHC.Core.InstEnv as InstEnv
-
-import GHC.Builtin.Names.TH
-import GHC.Builtin.Names
-import GHC.Builtin.Types
-
-import GHC.ThToHs
-import GHC.HsToCore.Docs
-import GHC.HsToCore.Expr
-import GHC.HsToCore.Monad
-import GHC.IfaceToCore
-import GHC.Iface.Load
-
-import GHCi.Message
-import GHCi.RemoteTypes
-import GHC.Runtime.Interpreter
-
-import GHC.Rename.Splice( traceSplice, SpliceInfo(..))
-import GHC.Rename.Expr
-import GHC.Rename.Env
-import GHC.Rename.Fixity ( lookupFixityRn_help )
-import GHC.Rename.HsType
-
-import GHC.Core.Class
-import GHC.Core.TyCon
-import GHC.Core.Coercion.Axiom
-import GHC.Core.PatSyn
-import GHC.Core.ConLike
-import GHC.Core.DataCon as DataCon
-
-import GHC.Types.FieldLabel
-import GHC.Types.SrcLoc
-import GHC.Types.Name.Env
-import GHC.Types.Name.Set
-import GHC.Types.Name.Reader
-import GHC.Types.Name.Occurrence as OccName
-import GHC.Types.Var
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.Unique
-import GHC.Types.Var.Set
-import GHC.Types.Meta
-import GHC.Types.Basic hiding( SuccessFlag(..) )
-import GHC.Types.Error
-import GHC.Types.Fixity as Hs
-import GHC.Types.Annotations
-import GHC.Types.Name
-import GHC.Types.Unique.Map
-import GHC.Serialized
-
-import GHC.Unit.Finder
-import GHC.Unit.Module
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.Deps
-
-import GHC.Utils.Misc
-import GHC.Utils.Panic as Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Lexeme
-import GHC.Utils.Outputable
-import GHC.Utils.Logger
-import GHC.Utils.Exception (throwIO, ErrorCall(..), SomeException(..))
-
-import GHC.Utils.TmpFs ( newTempName, TempFileLifetime(..) )
-
-import GHC.Data.FastString
-import GHC.Data.Maybe( MaybeErr(..) )
-import qualified GHC.Data.EnumSet as EnumSet
-
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-import qualified Language.Haskell.TH as TH
--- THSyntax gives access to internal functions and data types
-import qualified Language.Haskell.TH.Syntax as TH
-
-#if defined(HAVE_INTERNAL_INTERPRETER)
--- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
-import GHC.Desugar      ( AnnotationWrapper(..) )
-import Unsafe.Coerce    ( unsafeCoerce )
-#endif
-
-import Control.Monad
-import Data.Binary
-import Data.Binary.Get
-import Data.List        ( find )
-import Data.Maybe
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as LB
-import Data.Dynamic  ( fromDynamic, toDyn )
-import qualified Data.IntMap as IntMap
-import qualified Data.Map as Map
-import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep )
-import Data.Data (Data)
-import Data.Proxy    ( Proxy (..) )
-import GHC.Parser.HaddockLex (lexHsDoc)
-import GHC.Parser (parseIdentifier)
-import GHC.Rename.Doc (rnHsDoc)
-
-
-
-{-
-Note [Template Haskell state diagram]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here are the ThStages, s, their corresponding level numbers
-(the result of (thLevel s)), and their state transitions.
-The top level of the program is stage Comp:
-
-     Start here
-         |
-         V
-      -----------     $      ------------   $
-      |  Comp   | ---------> |  Splice  | -----|
-      |   1     |            |    0     | <----|
-      -----------            ------------
-        ^     |                ^      |
-      $ |     | [||]         $ |      | [||]
-        |     v                |      v
-   --------------          ----------------
-   | Brack Comp |          | Brack Splice |
-   |     2      |          |      1       |
-   --------------          ----------------
-
-* Normal top-level declarations start in state Comp
-       (which has level 1).
-  Annotations start in state Splice, since they are
-       treated very like a splice (only without a '$')
-
-* Code compiled in state Splice (and only such code)
-  will be *run at compile time*, with the result replacing
-  the splice
-
-* The original paper used level -1 instead of 0, etc.
-
-* The original paper did not allow a splice within a
-  splice, but there is no reason not to. This is the
-  $ transition in the top right.
-
-Note [Template Haskell levels]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* Imported things are impLevel (= 0)
-
-* However things at level 0 are not *necessarily* imported.
-      eg  $( \b -> ... )   here b is bound at level 0
-
-* In GHCi, variables bound by a previous command are treated
-  as impLevel, because we have bytecode for them.
-
-* Variables are bound at the "current level"
-
-* The current level starts off at outerLevel (= 1)
-
-* The level is decremented by splicing $(..)
-               incremented by brackets [| |]
-               incremented by name-quoting 'f
-
-* When a variable is used, checkWellStaged compares
-        bind:  binding level, and
-        use:   current level at usage site
-
-  Generally
-        bind > use      Always error (bound later than used)
-                        [| \x -> $(f x) |]
-
-        bind = use      Always OK (bound same stage as used)
-                        [| \x -> $(f [| x |]) |]
-
-        bind < use      Inside brackets, it depends
-                        Inside splice, OK
-                        Inside neither, OK
-
-  For (bind < use) inside brackets, there are three cases:
-    - Imported things   OK      f = [| map |]
-    - Top-level things  OK      g = [| f |]
-    - Non-top-level     Only if there is a liftable instance
-                                h = \(x:Int) -> [| x |]
-
-  To track top-level-ness we use the ThBindEnv in TcLclEnv
-
-  For example:
-           f = ...
-           g1 = $(map ...)         is OK
-           g2 = $(f ...)           is not OK; because we haven't compiled f yet
-
-
-Note [How top-level splices are handled]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Top-level splices (those not inside a [| .. |] quotation bracket) are handled
-very straightforwardly:
-
-  1. tcTopSpliceExpr: typecheck the body e of the splice $(e)
-
-  2. runMetaT: desugar, compile, run it, and convert result back to
-     GHC.Hs syntax RdrName (of the appropriate flavour, eg HsType RdrName,
-     HsExpr RdrName etc)
-
-  3. treat the result as if that's what you saw in the first place
-     e.g for HsType, rename and kind-check
-         for HsExpr, rename and type-check
-
-     (The last step is different for decls, because they can *only* be
-      top-level: we return the result of step 2.)
-
-Note [Warnings for TH splices]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We only produce warnings for TH splices when the user requests so
-(-fenable-th-splice-warnings). There are multiple reasons:
-
-  * It's not clear that the user that compiles a splice is the author of the code
-    that produces the warning. Think of the situation where they just splice in
-    code from a third-party library that produces incomplete pattern matches.
-    In this scenario, the user isn't even able to fix that warning.
-  * Gathering information for producing the warnings (pattern-match check
-    warnings in particular) is costly. There's no point in doing so if the user
-    is not interested in those warnings.
-
-That's why we store Origin flags in the Haskell AST. The functions from ThToHs
-take such a flag and depending on whether TH splice warnings were enabled or
-not, we pass FromSource (if the user requests warnings) or Generated
-(otherwise). This is implemented in getThSpliceOrigin.
-
-For correct pattern-match warnings it's crucial that we annotate the Origin
-consistently (#17270). In the future we could offer the Origin as part of the
-TH AST. That would enable us to give quotes from the current module get
-FromSource origin, and/or third library authors to tag certain parts of
-generated code as FromSource to enable warnings.
-That effort is tracked in #14838.
-
-Note [The life cycle of a TH quotation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When desugaring a bracket (aka quotation), we want to produce Core
-code that, when run, will produce the TH syntax tree for the quotation.
-To that end, we want to desugar /renamed/ but not /typechecked/ code;
-the latter is cluttered with the typechecker's elaboration that should
-not appear in the TH syntax tree. So in (HsExpr GhcTc) tree, we must
-have a (HsExpr GhcRn) for the quotation itself.
-
-As such, when typechecking both typed and untyped brackets,
-we keep a /renamed/ bracket in the extension field.
-
-The HsBracketTc, the GhcTc ext field for both typed and untyped
-brackets, contains:
-  - The renamed quote :: HsQuote GhcRn -- for the desugarer
-  - [PendingTcSplice]
-  - The type of the quote
-  - Maybe QuoteWrapper
-
-Note that HsBracketTc stores the untyped (HsQuote GhcRn) for both typed and
-untyped brackets. They are treated uniformly by the desugarer, and we can
-easily construct untyped brackets from typed ones (with ExpBr).
-
-See Note [Desugaring of brackets].
-
-------------
-Typed quotes
-------------
-Here is the life cycle of a /typed/ quote [|| e ||], whose datacon is
-  HsTypedBracket (XTypedBracket p) (LHsExpr p)
-
-  In pass p   (XTypedBracket p)       (LHsExpr p)
-  -------------------------------------------
-  GhcPs       Annotations only        LHsExpr GhcPs
-  GhcRn       Annotations only        LHsExpr GhcRn
-  GhcTc       HsBracketTc             LHsExpr GhcTc: unused!
-
-Note that in the GhcTc tree, the second field (HsExpr GhcTc)
-is entirely unused; the desugarer uses the (HsExpr GhcRn) from the
-first field.
-
---------------
-Untyped quotes
---------------
-Here is the life cycle of an /untyped/ quote, whose datacon is
-   HsUntypedBracket (XUntypedBracket p) (HsQuote p)
-
-Here HsQuote is a sum-type of expressions [| e |], patterns [| p |],
-types [| t |] etc.
-
-  In pass p   (XUntypedBracket p)          (HsQuote p)
-  -------------------------------------------------------
-  GhcPs   Annotations only                 HsQuote GhcPs
-  GhcRn   Annotations, [PendingRnSplice]   HsQuote GhcRn
-  GhcTc   HsBracketTc                      HsQuote GhcTc: unused!
-
-The difficulty is: the typechecker does not typecheck the body of an
-untyped quote, so how do we make a (HsQuote GhcTc) to put in the
-second field?
-
-Answer: we use the extension constructor of HsQuote, namely XQuote,
-and make all the other constructors into DataConCantHappen.  That is,
-the only non-bottom value of type (HsQuote GhcTc) is (XQuote noExtField).
-Hence the instances
-
-  type instance XExpBr GhcTc = DataConCantHappen
-  ...etc...
-
-See the related Note [How brackets and nested splices are handled]
-
-Note [Typechecking Overloaded Quotes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The main function for typechecking untyped quotations is `tcUntypedBracket`.
-
-Consider an expression quote, `[| e |]`, its type is `forall m . Quote m => m Exp`.
-Note carefully that this is overloaded: its type is not `Q Exp` for some fixed Q.
-
-When we typecheck it we therefore create a template of a metavariable
-`m` applied to `Exp` and emit a constraint `Quote m`. All this is done
-in the `brackTy` function.  `brackTy` also selects the correct
-contents type for the quotation (Exp, Type, Decs etc).
-
-The meta variable and the constraint evidence variable are
-returned together in a `QuoteWrapper` and then passed along to two further places
-during compilation:
-
-1. Typechecking nested splices (immediately in tcPendingSplice)
-2. Desugaring quotations (see GHC.HsToCore.Quote)
-
-`tcPendingSplice` takes the `m` type variable as an argument and
-checks each nested splice against this variable `m`. During this
-process the variable `m` can either be fixed to a specific value or
-further constrained by the nested splices.
-
-Once we have checked all the nested splices, the quote type is checked against
-the expected return type.
-
-The process is very simple and like typechecking a list where the quotation is
-like the container and the splices are the elements of the list which must have
-a specific type.
-
-After the typechecking process is completed, the evidence variable for `Quote m`
-and the type `m` is stored in a `QuoteWrapper` which is passed through the pipeline
-and used when desugaring quotations.
-
-Typechecking typed quotations is a similar idea but the `QuoteWrapper` is stored
-in the `PendingStuff` as the nested splices are gathered up in a different way
-to untyped splices. Untyped splices are found in the renamer but typed splices are
-not typechecked and extracted until during typechecking.
-
-Note [Lifecycle of an untyped splice, and PendingRnSplice]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Untyped splices $(f x) and quasiquotes [p| stuff |] have the following
-life cycle. Remember, quasi-quotes are very like splices; see Note [Quasi-quote overview]).
-
-The type structure is
-
-  data HsExpr p = ...
-    | HsUntypedSplice (XUntypedSplice p) (HsUntypedSplice p)
-
-  data HsUntypedSplice p
-    = HsUntypedSpliceExpr (XUntypedSpliceExpr p) (LHsExpr p)
-    | HsQuasiQuote (XQuasiQuote p) (IdP id) (XRec p FastString)
-
-Remember that untyped splices can occur in expressions, patterns,
-types, and declarations.  So we have a HsUntypedSplice data
-constructor in all four of these types.
-
-Untyped splices never occur in (HsExpr GhcTc), and similarly
-patterns etc. So we have
-
-   type instance XUntypedSplice GhcTc = DataConCantHappen
-
-Top-level and nested splices are handled differently.
-
--------------------------------------
-Nested untyped splices/quasiquotes
-----------------------------------
-When we rename an /untyped/ bracket, such as
-     [| f $(g x) |]
-we name and lift out all the nested splices, so that when the
-typechecker hits the bracket, it can typecheck those nested splices
-without having to walk over the untyped bracket code.  Our example
-[| f $(g x) |] parses as
-
-    HsUntypedBracket _
-       (HsApp (HsVar "f")
-              (HsUntypedSplice _ (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcPs)))
-
-RENAMER (rnUntypedBracket):
-
-* Set the ThStage to (Brack s (RnPendingUntyped ps_var))
-
-* Rename the body
-
-* Nested splices (which must be untyped) are renamed (rnUntypedSplice),
-  and the results accumulated in ps_var. Each gets a fresh
-  SplicePointName, 'spn'
-
-* The SplicePointName connects the `PendingRnSplice` with the particular point
-  in the syntax tree where that expression should be spliced in.  That point
-  in the tree is identified by `(HsUntypedSpliceNested spn)`.  It is used by
-  the desugarer, so that we ultimately generate something like
-       let spn = g x
-       in App (Var "f") spn
-
-The result is
-    HsUntypedBracket
-        [PendingRnSplice UntypedExpSplice spn (g x  :: LHsExpr GHcRn)]
-        (HsApp (HsVar f) (HsUntypedSplice (HsUntypedSpliceNested spn)
-                                          (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcRn))))
-
-Note that a nested splice, such as the `$(g x)` now appears twice:
-  - In the PendingRnSplice: this is the version that will later be typechecked
-  - In the HsUntypedSpliceExpr in the body of the bracket. This copy is used
-    only for pretty printing.
-
-NB: a single untyped bracket can contain many splices, each of a different
-`UntypedSpliceFlavour`. For example
-
-   [| let $e0 in (f :: $e1) $e2 (\ $e -> body ) |] + 1
-
-Here $e0 is a declaration splice, $e1 is a type splice, $e2 is an
-expression splice, and $e3 is a pattern splice.  The `PendingRnSplice`
-keeps track of which is which through its `UntypedSpliceFlavour`
-field.
-
-TYPECHECKER (tcUntypedBracket): see also Note [Typechecking Overloaded Quotes]
-
-* Typecheck the [PendingRnSplice] individually, to give [PendingTcSplice]
-  So PendingTcSplice is used for both typed and untyped splices.
-
-* Ignore the body of the bracket; just check that the context
-  expects a bracket of that type (e.g. a [p| pat |] bracket should
-  be in a context needing a (m Pat)
-
-* Stash the whole lot inside a HsBracketTc
-
-Result is:
-    HsUntypedBracket
-        (HsBracketTc { hsb_splices = [PendingTcSplice spn (g x  :: LHsExpr GHcTc)]
-                     , hsb_quote = HsApp (HsVar f)
-                                         (HsUntypedSplice (HsUntypedSpliceNested spn)
-                                            (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcRn)))
-                     })
-        (XQuote noExtField)
-
-NB in the typechecker output, the original payload (which would now
-have type (HsQuote GhcTc) is stubbed off with (XQuote noExtField). The payload
-is now in the hsb_quote field of the HsBracketTc.
-
-
--------------------------------------
-Top-level untyped splices/quasiquotes
--------------------------------------
-A top-level splice (not inside a bracket) does not need a SpliceName,
-nor does a top-level splice ever end up inside a PendingRnSplice;
-hence HsUntypedSpliceTop does not have a SplicePointName field.
-
-Example $(g x).  This is parsed as
-
-  HsUntypedSplice _ (HsUntypedSpliceExpr _ ((g x) :: LHsExpr GhcPs))
-
-Renamer: the renamer runs the splice, so the output of the renamer looks like
-
-  HsUntypedSplice (HsUntypedSpliceTop fins (e2 :: LHsExpr GhcRn))
-                  (HsUntypedSpliceExpr ((g x) :: LHsExpr GhcRn))
-
-where 'e2' is the result of running (g x) to
-             produce the syntax tree for 'e2'
-      'fins' is a bunch of TH finalisers, to be run later.
-
-Typechecker: the typechecker simply adds the finalisers, and
-typechecks e2, discarding the HsUntypedSplice altogether.
-
-
-Note [Lifecycle of an typed splice, and PendingTcSplice]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-----------------------
-Nested, typed splices
-----------------------
-When we typecheck a /typed/ bracket, we lift nested splices out as
-`PendingTcSplice`, very similar to Note [PendingRnSplice]. Again, the
-splice needs a SplicePointName, for the desguarer to use to connect
-the splice expression with the point in the syntax tree where it is
-used.  Example:
-     [||  f $$(g 2)||]
-
-Parser: this is parsed as
-
-    HsTypedBracket _ (HsApp (HsVar "f")
-                            (HsTypedSplice _ (g 2 :: LHsExpr GhcPs)))
-
-RENAMER (rnTypedSplice): the renamer adds a SplicePointName, spn:
-
-    HsTypedBracket _ (HsApp (HsVar "f")
-                            (HsTypedSplice spn (g x :: LHsExpr GhcRn)))
-
-TYPECHECKER (tcTypedBracket):
-
-* Set the ThStage to (Brack s (TcPending ps_var lie_var))
-
-* Typecheck the body, and keep the elaborated result (despite never using it!)
-
-* Nested splices (which must be typed) are typechecked by tcNestedSplice, and
-  the results accumulated in ps_var; their constraints accumulate in lie_var
-
-* Result is a HsTypedBracket (HsBracketTc rn_brack ty quote_wrapper pending_splices) tc_brack
-  where rn_brack is the untyped renamed exp quote constructed from the typed renamed expression :: HsQuote GhcRn
-
-Just like untyped brackets, dump the output into a HsBracketTc.
-
-    HsTypedBracket
-        (HsBracketTc { hsb_splices = [PendingTcSplice spn (g x  :: LHsExpr GHcTc)]
-                     , hsb_quote = HsApp (HsVar f)
-                                         (HsUntypedSplice (HsUntypedSpliceNested spn)
-                                            (HsUntypedSpliceExpr _ (g x :: LHsExpr GhcRn)))
-                     })
-        (panic "should never be looked at")
-
-NB: we never need to represent typed /nested/ splices in phase GhcTc.
-
-There are only typed expression splices so `PendingTcSplice` doesn't have a
-flavour field.
-
-
---------------------------------
-Top-level, typed splices $$(f x)
---------------------------------
-Typed splices are renamed and typechecked, but only actually run in
-the zonker, after typechecking. See Note [Running typed splices in the zonker]
-
-* Output of parser:
-  HsTypedSplice _ (e :: HsExpr GhcPs)
-
-* Output of renamer:
-  HsTypedSplice (n :: SplicePointName) (e :: HsExpr GhcRn)
-
-* Output of typechecker: (top-level splices only)
-  HsTypedSplice (del_splice :: DelayedSplice) (e :: HsExpr GhcTc)
-  where 'del_splice' is something the zonker can run to produce
-           the syntax tree to splice in.
-           See Note [Running typed splices in the zonker]
-
-Note [Desugaring of brackets]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In both cases, desugaring happens like this:
-  * Hs*Bracket is desugared by GHC.HsToCore.Quote.dsBracket using the renamed
-    expression held in `HsBracketTc` (`type instance X*Bracket GhcTc = HsBracketTc`). It
-
-      a) Extends the ds_meta environment with the PendingSplices
-         attached to the bracket
-
-      b) Converts the quoted (HsExpr Name) to a CoreExpr that, when
-         run, will produce a suitable TH expression/type/decl.  This
-         is why we leave the *renamed* expression attached to the bracket:
-         the quoted expression should not be decorated with all the goop
-         added by the type checker
-
-  * Each splice carries a unique Name, called a "splice point", thus
-    ${n}(e).  The name is initialised to an (Unqual "splice") when the
-    splice is created; the renamer gives it a unique.
-
-  * When GHC.HsToCore.Quote (used to desugar the body of the bracket) comes across
-    a splice, it looks up the splice's Name, n, in the ds_meta envt,
-    to find an (HsExpr Id) that should be substituted for the splice;
-    it just desugars it to get a CoreExpr (GHC.HsToCore.Quote.repSplice).
-
-Example:
-    Source:       f = [| Just $(g 3) |]
-      The [| |] part is a HsUntypedBracket GhcPs
-
-    Typechecked:  f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
-      The [| |] part is a HsUntypedBracket GhcTc, containing *renamed*
-        (not typechecked) expression (see Note [The life cycle of a TH quotation])
-      The "s7" is the "splice point"; the (g Int 3) part
-        is a typechecked expression
-
-    Desugared:    f = do { s7 <- g Int 3
-                         ; return (ConE "Data.Maybe.Just" s7) }
-
--}
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Main interface + stubs for the non-GHCI case
-*                                                                      *
-************************************************************************
--}
-
-tcTypedBracket    :: HsExpr GhcRn -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-tcUntypedBracket  :: HsExpr GhcRn -> HsQuote GhcRn -> [PendingRnSplice] -> ExpRhoType
-                  -> TcM (HsExpr GhcTc)
-tcTypedSplice :: Name -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-        -- None of these functions add constraints to the LIE
-
-runAnnotation     :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
-{-
-************************************************************************
-*                                                                      *
-\subsection{Quoting an expression}
-*                                                                      *
-************************************************************************
--}
-
--- See Note [How brackets and nested splices are handled]
-tcTypedBracket rn_expr expr res_ty
-  = addErrCtxt (quotationCtxtDoc expr) $
-    do { cur_stage <- getStage
-       ; ps_ref <- newMutVar []
-       ; lie_var <- getConstraintVar   -- Any constraints arising from nested splices
-                                       -- should get thrown into the constraint set
-                                       -- from outside the bracket
-
-       -- Make a new type variable for the type of the overall quote
-       ; m_var <- mkTyVarTy <$> mkMetaTyVar
-       -- Make sure the type variable satisfies Quote
-       ; ev_var <- emitQuoteWanted m_var
-       -- Bundle them together so they can be used in GHC.HsToCore.Quote for desugaring
-       -- brackets.
-       ; let wrapper = QuoteWrapper ev_var m_var
-       -- Typecheck expr to make sure it is valid.
-       -- The typechecked expression won't be used, so we just discard it
-       --   (See Note [The life cycle of a TH quotation] in GHC.Hs.Expr)
-       -- We'll typecheck it again when we splice it in somewhere
-       ; (tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var wrapper)) $
-                                tcScalingUsage ManyTy $
-                                -- Scale by Many, TH lifting is currently nonlinear (#18465)
-                                tcInferRhoNC expr
-                                -- NC for no context; tcBracket does that
-       ; let rep = getRuntimeRep expr_ty
-       ; meta_ty <- tcTExpTy m_var expr_ty
-       ; ps' <- readMutVar ps_ref
-       ; codeco <- tcLookupId unsafeCodeCoerceName
-       ; bracket_ty <- mkAppTy m_var <$> tcMetaTy expTyConName
-       ; let brack_tc = HsBracketTc { hsb_quote = ExpBr noExtField expr, hsb_ty = bracket_ty
-                                    , hsb_wrap  = Just wrapper, hsb_splices = ps' }
-             -- The tc_expr is stored here so that the expression can be used in HIE files.
-             brack_expr = HsTypedBracket brack_tc tc_expr
-       ; tcWrapResultO (Shouldn'tHappenOrigin "TH typed bracket expression")
-                       rn_expr
-                       (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)
-                                                  (nlHsTyApp codeco [rep, expr_ty]))
-                                      (noLocA brack_expr)))
-                       meta_ty res_ty }
-
--- See Note [Typechecking Overloaded Quotes]
-tcUntypedBracket rn_expr brack ps res_ty
-  = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
-
-       -- Create the type m Exp for expression bracket, m Type for a type
-       -- bracket and so on. The brack_info is a Maybe because the
-       -- VarBracket ('a) isn't overloaded, but also shouldn't contain any
-       -- splices.
-       ; (brack_info, expected_type) <- brackTy brack
-
-       -- Match the expected type with the type of all the internal
-       -- splices. They might have further constrained types and if they do
-       -- we want to reflect that in the overall type of the bracket.
-       ; ps' <- case quoteWrapperTyVarTy <$> brack_info of
-                  Just m_var -> mapM (tcPendingSplice m_var) ps
-                  Nothing -> assert (null ps) $ return []
-
-       -- Notice that we don't attempt to typecheck the body
-       -- of the bracket, which is in brack.
-       ; traceTc "tc_bracket done untyped" (ppr expected_type)
-
-       -- Unify the overall type of the bracket with the expected result type
-       ; tcWrapResultO BracketOrigin rn_expr
-            (HsUntypedBracket (HsBracketTc { hsb_quote = brack, hsb_ty = expected_type
-                                           , hsb_wrap = brack_info, hsb_splices = ps' })
-                              (XQuote noExtField))
-                -- (XQuote noExtField): see Note [The life cycle of a TH quotation] in GHC.Hs.Expr
-            expected_type res_ty
-
-       }
-
--- | A type variable with kind * -> * named "m"
-mkMetaTyVar :: TcM TyVar
-mkMetaTyVar =
-  newNamedFlexiTyVar (fsLit "m") (mkVisFunTyMany liftedTypeKind liftedTypeKind)
-
-
--- | For a type 'm', emit the constraint 'Quote m'.
-emitQuoteWanted :: Type -> TcM EvVar
-emitQuoteWanted m_var =  do
-        quote_con <- tcLookupTyCon quoteClassName
-        emitWantedEvVar BracketOrigin $
-          mkTyConApp quote_con [m_var]
-
----------------
--- | Compute the expected type of a quotation, and also the QuoteWrapper in
--- the case where it is an overloaded quotation. All quotation forms are
--- overloaded aprt from Variable quotations ('foo)
-brackTy :: HsQuote GhcRn -> TcM (Maybe QuoteWrapper, Type)
-brackTy b =
-  let mkTy n = do
-        -- New polymorphic type variable for the bracket
-        m_var <- mkTyVarTy <$> mkMetaTyVar
-        -- Emit a Quote constraint for the bracket
-        ev_var <- emitQuoteWanted m_var
-        -- Construct the final expected type of the quote, for example
-        -- m Exp or m Type
-        final_ty <- mkAppTy m_var <$> tcMetaTy n
-        -- Return the evidence variable and metavariable to be used during
-        -- desugaring.
-        let wrapper = QuoteWrapper ev_var m_var
-        return (Just wrapper, final_ty)
-  in
-  case b of
-    (VarBr {}) -> (Nothing,) <$> tcMetaTy nameTyConName
-                                           -- Result type is Var (not Quote-monadic)
-    (ExpBr {})  -> mkTy expTyConName  -- Result type is m Exp
-    (TypBr {})  -> mkTy typeTyConName -- Result type is m Type
-    (DecBrG {}) -> mkTy decsTyConName -- Result type is m [Dec]
-    (PatBr {})  -> mkTy patTyConName  -- Result type is m Pat
-    (DecBrL {}) -> panic "tcBrackTy: Unexpected DecBrL"
-
----------------
--- | Typechecking a pending splice from a untyped bracket
-tcPendingSplice :: TcType -- Metavariable for the expected overall type of the
-                          -- quotation.
-                -> PendingRnSplice
-                -> TcM PendingTcSplice
-tcPendingSplice m_var (PendingRnSplice flavour splice_name expr)
-  -- See Note [Typechecking Overloaded Quotes]
-  = do { meta_ty <- tcMetaTy meta_ty_name
-         -- Expected type of splice, e.g. m Exp
-       ; let expected_type = mkAppTy m_var meta_ty
-       ; expr' <- tcScalingUsage ManyTy $ tcCheckPolyExpr expr expected_type
-                  -- Scale by Many, TH lifting is currently nonlinear (#18465)
-       ; return (PendingTcSplice splice_name expr') }
-  where
-     meta_ty_name = case flavour of
-                       UntypedExpSplice  -> expTyConName
-                       UntypedPatSplice  -> patTyConName
-                       UntypedTypeSplice -> typeTyConName
-                       UntypedDeclSplice -> decsTyConName
-
----------------
--- Takes a m and tau and returns the type m (TExp tau)
-tcTExpTy :: TcType -> TcType -> TcM TcType
-tcTExpTy m_ty exp_ty
-  = do { unless (isTauTy exp_ty) $ addErr (TcRnTypedTHWithPolyType exp_ty)
-       ; codeCon <- tcLookupTyCon codeTyConName
-       ; let rep = getRuntimeRep exp_ty
-       ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) }
-
-quotationCtxtDoc :: LHsExpr GhcRn -> SDoc
-quotationCtxtDoc br_body
-  = hang (text "In the Template Haskell quotation")
-         2 (thTyBrackets . ppr $ br_body)
-
-
-  -- The whole of the rest of the file is the else-branch (ie stage2 only)
-
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Splicing an expression}
-*                                                                      *
-************************************************************************
--}
-
-tcTypedSplice splice_name expr res_ty
-  = addErrCtxt (typedSpliceCtxtDoc splice_name expr) $
-    setSrcSpan (getLocA expr)    $ do
-    { stage <- getStage
-    ; case stage of
-          Splice {}            -> tcTopSplice expr res_ty
-          Brack pop_stage pend -> tcNestedSplice pop_stage pend splice_name expr res_ty
-          RunSplice _          ->
-            -- See Note [RunSplice ThLevel] in "GHC.Tc.Types".
-            pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++
-                      "running another splice") (pprTypedSplice (Just splice_name) expr)
-          Comp                 -> tcTopSplice expr res_ty
-    }
-
-{- Note [Collecting modFinalizers in typed splices]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local
-environment (see Note [Delaying modFinalizers in untyped splices] in
-GHC.Rename.Splice). Thus after executing the splice, we move the finalizers to the
-finalizer list in the global environment and set them to use the current local
-environment (with 'addModFinalizersWithLclEnv').
-
--}
-
-------------------
-tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-tcTopSplice expr res_ty
-  = do { -- Typecheck the expression,
-         -- making sure it has type Q (T res_ty)
-         res_ty <- expTypeToType res_ty
-       ; q_type <- tcMetaTy qTyConName
-       -- Top level splices must still be of type Q (TExp a)
-       ; meta_exp_ty <- tcTExpTy q_type res_ty
-       ; q_expr <- tcTopSpliceExpr Typed $
-                   tcCheckMonoExpr expr meta_exp_ty
-       ; lcl_env <- getLclEnv
-       ; let delayed_splice
-              = DelayedSplice lcl_env expr res_ty q_expr
-       ; return (HsTypedSplice delayed_splice q_expr)
-
-       }
-
--------------------
-tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
--- Note [How top-level splices are handled]
--- Type check an expression that is the body of a top-level splice
---   (the caller will compile and run it)
--- Note that set the level to Splice, regardless of the original level,
--- before typechecking the expression.  For example:
---      f x = $( ...$(g 3) ... )
--- The recursive call to tcCheckPolyExpr will simply expand the
--- inner escape before dealing with the outer one
-
-tcTopSpliceExpr isTypedSplice tc_action
-  = checkNoErrs $  -- checkNoErrs: must not try to run the thing
-                   -- if the type checker fails!
-    setStage (Splice isTypedSplice) $
-    do {    -- Typecheck the expression
-         (mb_expr', wanted) <- tryCaptureConstraints tc_action
-             -- If tc_action fails (perhaps because of insoluble constraints)
-             -- we want to capture and report those constraints, else we may
-             -- just get a silent failure (#20179). Hence the 'try' part.
-
-       ; const_binds <- simplifyTop wanted
-
-       ; case mb_expr' of
-            Nothing    -> failM   -- In this case simplifyTop should have
-                                  -- reported some errors
-            Just expr' -> return $ mkHsDictLet (EvBinds const_binds) expr' }
-
-------------------
-tcNestedSplice :: ThStage -> PendingStuff -> Name
-                -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-    -- See Note [How brackets and nested splices are handled]
-    -- A splice inside brackets
-tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) splice_name expr res_ty
-  = do { res_ty <- expTypeToType res_ty
-       ; let rep = getRuntimeRep res_ty
-       ; meta_exp_ty <- tcTExpTy m_var res_ty
-       ; expr' <- setStage pop_stage $
-                  setConstraintVar lie_var $
-                  tcCheckMonoExpr expr meta_exp_ty
-       ; untype_code <- tcLookupId unTypeCodeName
-       ; let expr'' = mkHsApp
-                        (mkLHsWrap (applyQuoteWrapper q)
-                          (nlHsTyApp untype_code [rep, res_ty])) expr'
-       ; ps <- readMutVar ps_var
-       ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)
-
-       -- The returned expression is ignored; it's in the pending splices
-       ; return stubNestedSplice }
-
-tcNestedSplice _ _ splice_name _ _
-  = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name)
-
-
-------------------
--- This is called in the zonker
--- See Note [Running typed splices in the zonker]
-runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
-runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)
-  = restoreLclEnv lcl_env $
-    do { zonked_ty <- zonkTcType res_ty
-       ; zonked_q_expr <- zonkTopLExpr q_expr
-        -- See Note [Collecting modFinalizers in typed splices].
-       ; modfinalizers_ref <- newTcRef []
-         -- Run the expression
-       ; expr2 <- setStage (RunSplice modfinalizers_ref) $
-                    runMetaE zonked_q_expr
-       ; mod_finalizers <- readTcRef modfinalizers_ref
-       ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers
-       -- We use orig_expr here and not q_expr when tracing as a call to
-       -- unsafeCodeCoerce is added to the original expression by the
-       -- typechecker when typed quotes are type checked.
-       ; traceSplice (SpliceInfo { spliceDescription = "expression"
-                                 , spliceIsDecl      = False
-                                 , spliceSource      = Just orig_expr
-                                 , spliceGenerated   = ppr expr2 })
-        -- Rename and typecheck the spliced-in expression,
-        -- making sure it has type res_ty
-        -- These steps should never fail; this is a *typed* splice
-       ; (res, wcs) <-
-            captureConstraints $
-              addErrCtxt (spliceResultDoc zonked_q_expr) $ do
-                { (exp3, _fvs) <- rnLExpr expr2
-                ; tcCheckMonoExpr exp3 zonked_ty }
-       ; ev <- simplifyTop wcs
-       ; return $ unLoc (mkHsDictLet (EvBinds ev) res)
-       }
-
-
-{-
-************************************************************************
-*                                                                      *
-
-*                                                                      *
-************************************************************************
--}
-
-typedSpliceCtxtDoc :: SplicePointName -> LHsExpr GhcRn -> SDoc
-typedSpliceCtxtDoc n splice
-  = hang (text "In the Template Haskell splice")
-         2 (pprTypedSplice (Just n) splice)
-
-spliceResultDoc :: LHsExpr GhcTc -> SDoc
-spliceResultDoc expr
-  = sep [ text "In the result of the splice:"
-        , nest 2 (char '$' <> ppr expr)
-        , text "To see what the splice expanded to, use -ddump-splices"]
-
-stubNestedSplice :: HsExpr GhcTc
--- Used when we need a (LHsExpr GhcTc) that we are never going
--- to look at.  We could use "panic" but that's confusing if we ever
--- do a debug-print.  The warning is because this should never happen
--- /except/ when doing debug prints.
-stubNestedSplice = warnPprTrace True "stubNestedSplice" empty $
-                   HsLit noComments (mkHsString "stubNestedSplice")
-
-
-{-
-************************************************************************
-*                                                                      *
-        Annotations
-*                                                                      *
-************************************************************************
--}
-
-runAnnotation target expr = do
-    -- Find the classes we want instances for in order to call toAnnotationWrapper
-    loc <- getSrcSpanM
-    data_class <- tcLookupClass dataClassName
-    to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
-
-    -- Check the instances we require live in another module (we want to execute it..)
-    -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
-    -- also resolves the LIE constraints to detect e.g. instance ambiguity
-    zonked_wrapped_expr' <- zonkTopLExpr =<< tcTopSpliceExpr Untyped (
-           do { (expr', expr_ty) <- tcInferRhoNC expr
-                -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
-                -- By instantiating the call >here< it gets registered in the
-                -- LIE consulted by tcTopSpliceExpr
-                -- and hence ensures the appropriate dictionary is bound by const_binds
-              ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
-              ; let loc' = noAnnSrcSpan loc
-              ; let specialised_to_annotation_wrapper_expr
-                      = L loc' (mkHsWrap wrapper
-                                 (HsVar noExtField (L (noAnnSrcSpan loc) to_annotation_wrapper_id)))
-              ; return (L loc' (HsApp noComments
-                                specialised_to_annotation_wrapper_expr expr'))
-                                })
-
-    -- Run the appropriately wrapped expression to get the value of
-    -- the annotation and its dictionaries. The return value is of
-    -- type AnnotationWrapper by construction, so this conversion is
-    -- safe
-    serialized <- runMetaAW zonked_wrapped_expr'
-    return Annotation {
-               ann_target = target,
-               ann_value = serialized
-           }
-
-convertAnnotationWrapper :: ForeignHValue -> TcM Serialized
-convertAnnotationWrapper fhv = do
-  interp <- tcGetInterp
-  case interpInstance interp of
-    ExternalInterp {} -> runTH THAnnWrapper fhv
-#if defined(HAVE_INTERNAL_INTERPRETER)
-    InternalInterp    -> do
-      annotation_wrapper <- liftIO $ wormhole interp fhv
-      return $
-        case unsafeCoerce annotation_wrapper of
-           AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
-               -- Got the value and dictionaries: build the serialized value and
-               -- call it a day. We ensure that we seq the entire serialized value
-               -- in order that any errors in the user-written code for the
-               -- annotation are exposed at this point.  This is also why we are
-               -- doing all this stuff inside the context of runMeta: it has the
-               -- facilities to deal with user error in a meta-level expression
-               seqSerialized serialized `seq` serialized
-
--- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
-seqSerialized :: Serialized -> ()
-seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
-
-#endif
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Running an expression}
-*                                                                      *
-************************************************************************
--}
-
-runQuasi :: TH.Q a -> TcM a
-runQuasi act = TH.runQ act
-
-runRemoteModFinalizers :: ThModFinalizers -> TcM ()
-runRemoteModFinalizers (ThModFinalizers finRefs) = do
-  let withForeignRefs [] f = f []
-      withForeignRefs (x : xs) f = withForeignRef x $ \r ->
-        withForeignRefs xs $ \rs -> f (r : rs)
-  interp <- tcGetInterp
-  case interpInstance interp of
-#if defined(HAVE_INTERNAL_INTERPRETER)
-    InternalInterp -> do
-      qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
-      runQuasi $ sequence_ qs
-#endif
-
-    ExternalInterp conf iserv -> withIServ_ conf iserv $ \i -> do
-      tcg <- getGblEnv
-      th_state <- readTcRef (tcg_th_remote_state tcg)
-      case th_state of
-        Nothing -> return () -- TH was not started, nothing to do
-        Just fhv -> do
-          liftIO $ withForeignRef fhv $ \st ->
-            withForeignRefs finRefs $ \qrefs ->
-              writeIServ i (putMessage (RunModFinalizers st qrefs))
-          () <- runRemoteTH i []
-          readQResult i
-
-runQResult
-  :: (a -> String)
-  -> (Origin -> SrcSpan -> a -> b)
-  -> (ForeignHValue -> TcM a)
-  -> SrcSpan
-  -> ForeignHValue {- TH.Q a -}
-  -> TcM b
-runQResult show_th f runQ expr_span hval
-  = do { th_result <- runQ hval
-       ; th_origin <- getThSpliceOrigin
-       ; traceTc "Got TH result:" (text (show_th th_result))
-       ; return (f th_origin expr_span th_result) }
-
-
------------------
-runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn)
-        -> LHsExpr GhcTc
-        -> TcM hs_syn
-runMeta unwrap e = do
-    hooks <- getHooks
-    case runMetaHook hooks of
-        Nothing -> unwrap defaultRunMeta e
-        Just h  -> unwrap h e
-
-defaultRunMeta :: MetaHook TcM
-defaultRunMeta (MetaE r)
-  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp)
-defaultRunMeta (MetaP r)
-  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat)
-defaultRunMeta (MetaT r)
-  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType)
-defaultRunMeta (MetaD r)
-  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec)
-defaultRunMeta (MetaAW r)
-  = fmap r . runMeta' False (const empty) (const $ fmap Right . convertAnnotationWrapper)
-    -- We turn off showing the code in meta-level exceptions because doing so exposes
-    -- the toAnnotationWrapper function that we slap around the user's code
-
-----------------
-runMetaAW :: LHsExpr GhcTc         -- Of type AnnotationWrapper
-          -> TcM Serialized
-runMetaAW = runMeta metaRequestAW
-
-runMetaE :: LHsExpr GhcTc          -- Of type (Q Exp)
-         -> TcM (LHsExpr GhcPs)
-runMetaE = runMeta metaRequestE
-
-runMetaP :: LHsExpr GhcTc          -- Of type (Q Pat)
-         -> TcM (LPat GhcPs)
-runMetaP = runMeta metaRequestP
-
-runMetaT :: LHsExpr GhcTc          -- Of type (Q Type)
-         -> TcM (LHsType GhcPs)
-runMetaT = runMeta metaRequestT
-
-runMetaD :: LHsExpr GhcTc          -- Of type Q [Dec]
-         -> TcM [LHsDecl GhcPs]
-runMetaD = runMeta metaRequestD
-
-{- Note [Errors in desugaring a splice]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What should we do if there are errors when desugaring a splice? We should
-abort. There are several cases to consider:
-
-(a) The desugarer hits an unrecoverable error and fails in the monad.
-(b) The desugarer hits a recoverable error, reports it, and continues.
-(c) The desugarer reports a fatal warning (with -Werror), reports it, and continues.
-(d) The desugarer reports a non-fatal warning, and continues.
-
-Each case is tested in th/T19709[abcd].
-
-General principle: we wish to report all messages from dealing with a splice
-eagerly, as these messages arise during an earlier stage than type-checking
-generally. It's also likely that a compile-time warning from spliced code
-will be easier to understand then an error that arises from processing the
-code the splice produces. (Rationale: the warning will be about the code the
-user actually wrote, not what is generated.)
-
-Case (a): We have no choice but to abort here, but we must make sure that
-the messages are printed or logged before aborting. Logging them is annoying,
-because we're in the type-checker, and the messages are DsMessages, from the
-desugarer. So we report and then fail in the monad. This case is detected
-by the fact that initDsTc returns Nothing.
-
-Case (b): We detect this case by looking for errors in the messages returned
-from initDsTc and aborting if we spot any (after printing, of course). Note
-that initDsTc will return a Just ds_expr in this case, but we don't wish to
-use the (likely very bogus) expression.
-
-Case (c): This is functionally the same as (b), except that the expression
-isn't bogus. We still don't wish to use it, as the user's request for -Werror
-tells us not to.
-
-Case (d): We report the warnings and then carry on with the expression.
-This might result in warnings printed out of source order, but this is
-appropriate, as the warnings from the splice arise from an earlier stage
-of compilation.
-
-Previously, we failed to abort in cases (b) and (c), leading to #19709.
--}
-
----------------
-runMeta' :: Bool                 -- Whether code should be printed in the exception message
-         -> (hs_syn -> SDoc)                                    -- how to print the code
-         -> (SrcSpan -> ForeignHValue -> TcM (Either RunSpliceFailReason hs_syn)) -- How to run x
-         -> LHsExpr GhcTc        -- Of type x; typically x = Q TH.Exp, or
-                                 --    something like that
-         -> TcM hs_syn           -- Of type t
-runMeta' show_code ppr_hs run_and_convert expr
-  = do  { traceTc "About to run" (ppr expr)
-        ; recordThSpliceUse -- seems to be the best place to do this,
-                            -- we catch all kinds of splices and annotations.
-
-        -- Check that we've had no errors of any sort so far.
-        -- For example, if we found an error in an earlier defn f, but
-        -- recovered giving it type f :: forall a.a, it'd be very dodgy
-        -- to carry on.  Mind you, the staging restrictions mean we won't
-        -- actually run f, but it still seems wrong. And, more concretely,
-        -- see #5358 for an example that fell over when trying to
-        -- reify a function with an unlifted kind in it.  (These don't occur
-        -- in type-correct programs.)
-        ; failIfErrsM
-
-        -- run plugins
-        ; hsc_env <- getTopEnv
-        ; expr' <- withPlugins (hsc_plugins hsc_env) spliceRunAction expr
-
-        -- Desugar
-        ; (ds_msgs, mb_ds_expr) <- initDsTc (dsLExpr expr')
-
-        -- Print any messages (even warnings) eagerly: they might be helpful if anything
-        -- goes wrong. See Note [Errors in desugaring a splice]. This happens in all
-        -- cases.
-        ; logger <- getLogger
-        ; diag_opts <- initDiagOpts <$> getDynFlags
-        ; print_config <- initDsMessageOpts <$> getDynFlags
-        ; liftIO $ printMessages logger print_config diag_opts ds_msgs
-
-        ; ds_expr <- case mb_ds_expr of
-            Nothing      -> failM   -- Case (a) from Note [Errors in desugaring a splice]
-            Just ds_expr ->  -- There still might be a fatal warning or recoverable
-                             -- Cases (b) and (c) from Note [Errors in desugaring a splice]
-              do { when (errorsOrFatalWarningsFound ds_msgs)
-                     failM
-                 ; return ds_expr }
-
-        -- Compile and link it; might fail if linking fails
-        ; src_span <- getSrcSpanM
-        ; traceTc "About to run (desugared)" (ppr ds_expr)
-        ; either_hval <- tryM $ liftIO $
-                         GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr
-        ; case either_hval of {
-            Left exn   -> fail_with_exn SplicePhase_CompileAndLink exn ;
-            Right (hval, needed_mods, needed_pkgs) -> do
-
-        {       -- Coerce it to Q t, and run it
-
-                -- Running might fail if it throws an exception of any kind (hence tryAllM)
-                -- including, say, a pattern-match exception in the code we are running
-                --
-                -- We also do the TH -> HS syntax conversion inside the same
-                -- exception-catching thing so that if there are any lurking
-                -- exceptions in the data structure returned by hval, we'll
-                -- encounter them inside the try
-                --
-                -- See Note [Exceptions in TH]
-          let expr_span = getLocA expr
-        ; recordThNeededRuntimeDeps needed_mods needed_pkgs
-        ; either_tval <- tryAllM $
-                         setSrcSpan expr_span $ -- Set the span so that qLocation can
-                                                -- see where this splice is
-             do { mb_result <- run_and_convert expr_span hval
-                ; case mb_result of
-                    Left err     -> failWithTc (TcRnRunSpliceFailure Nothing err)
-                    Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)
-                                       ; return $! result } }
-
-        ; case either_tval of
-            Right v -> return v
-            Left se -> case fromException se of
-                         Just IOEnvFailure -> failM -- Error already in Tc monad
-                         _ -> fail_with_exn SplicePhase_Run se -- Exception
-        }}}
-  where
-    -- see Note [Concealed TH exceptions]
-    fail_with_exn :: Exception e => SplicePhase -> e -> TcM a
-    fail_with_exn phase exn = do
-        exn_msg <- liftIO $ Panic.safeShowException exn
-        failWithTc
-          $ TcRnSpliceThrewException phase (SomeException exn) exn_msg expr show_code
-
-{-
-Note [Running typed splices in the zonker]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-See #15471 for the full discussion.
-
-For many years typed splices were run immediately after they were type checked
-however, this is too early as it means to zonk some type variables before
-they can be unified with type variables in the surrounding context.
-
-For example,
-
-```
-module A where
-
-test_foo :: forall a . Q (TExp (a -> a))
-test_foo = [|| id ||]
-
-module B where
-
-import A
-
-qux = $$(test_foo)
-```
-
-We would expect `qux` to have inferred type `forall a . a -> a` but if
-we run the splices too early the unified variables are zonked to `Any`. The
-inferred type is the unusable `Any -> Any`.
-
-To run the splice, we must compile `test_foo` all the way to byte code.
-But at the moment when the type checker is looking at the splice, test_foo
-has type `Q (TExp (alpha -> alpha))` and we
-certainly can't compile code involving unification variables!
-
-We could default `alpha` to `Any` but then we infer `qux :: Any -> Any`
-which definitely is not what we want.  Moreover, if we had
-  qux = [$$(test_foo), (\x -> x +1::Int)]
-then `alpha` would have to be `Int`.
-
-Conclusion: we must defer taking decisions about `alpha` until the
-typechecker is done; and *then* we can run the splice.  It's fine to do it
-later, because we know it'll produce type-correct code.
-
-Deferring running the splice until later, in the zonker, means that the
-unification variables propagate upwards from the splice into the surrounding
-context and are unified correctly.
-
-This is implemented by storing the arguments we need for running the splice
-in a `DelayedSplice`. In the zonker, the arguments are passed to
-`GHC.Tc.Gen.Splice.runTopSplice` and the expression inserted into the AST as normal.
-
-
-
-Note [Exceptions in TH]
-~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have something like this
-        $( f 4 )
-where
-        f :: Int -> Q [Dec]
-        f n | n>3       = fail "Too many declarations"
-            | otherwise = ...
-
-The 'fail' is a user-generated failure, and should be displayed as a
-perfectly ordinary compiler error message, not a panic or anything
-like that.  Here's how it's processed:
-
-  * 'fail' is the monad fail.  The monad instance for Q in TH.Syntax
-    effectively transforms (fail s) to
-        qReport True s >> fail
-    where 'qReport' comes from the Quasi class and fail from its monad
-    superclass.
-
-  * The TcM monad is an instance of Quasi (see GHC.Tc.Gen.Splice), and it implements
-    (qReport True s) by using addErr to add an error message to the bag of errors.
-    The 'fail' in TcM raises an IOEnvFailure exception
-
- * 'qReport' forces the message to ensure any exception hidden in unevaluated
-   thunk doesn't get into the bag of errors. Otherwise the following splice
-   will trigger panic (#8987):
-        $(fail undefined)
-   See also Note [Concealed TH exceptions]
-
-  * So, when running a splice, we catch all exceptions; then for
-        - an IOEnvFailure exception, we assume the error is already
-                in the error-bag (above)
-        - other errors, we add an error to the bag
-    and then fail
-
-Note [Concealed TH exceptions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When displaying the error message contained in an exception originated from TH
-code, we need to make sure that the error message itself does not contain an
-exception.  For example, when executing the following splice:
-
-    $( error ("foo " ++ error "bar") )
-
-the message for the outer exception is a thunk which will throw the inner
-exception when evaluated.
-
-For this reason, we display the message of a TH exception using the
-'safeShowException' function, which recursively catches any exception thrown
-when showing an error message.
-
-
-To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
--}
-
-instance TH.Quasi TcM where
-  qNewName s = do { u <- newUnique
-                  ; let i = toInteger (getKey u)
-                  ; return (TH.mkNameU s i) }
-
-  -- 'msg' is forced to ensure exceptions don't escape,
-  -- see Note [Exceptions in TH]
-  qReport True msg  = seqList msg $ addErr $ TcRnReportCustomQuasiError True msg
-  qReport False msg = seqList msg $ addDiagnostic $ TcRnReportCustomQuasiError False msg
-
-  qLocation :: TcM TH.Loc
-  qLocation = do { m <- getModule
-                 ; l <- getSrcSpanM
-                 ; r <- case l of
-                        UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
-                                                    (ppr l)
-                        RealSrcSpan s _ -> return s
-                 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
-                                  , TH.loc_module   = moduleNameString (moduleName m)
-                                  , TH.loc_package  = unitString (moduleUnit m)
-                                  , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
-                                  , TH.loc_end = (srcSpanEndLine   r, srcSpanEndCol   r) }) }
-
-  qLookupName       = lookupName
-  qReify            = reify
-  qReifyFixity nm   = lookupThName nm >>= reifyFixity
-  qReifyType        = reifyTypeOfThing
-  qReifyInstances   = reifyInstances
-  qReifyRoles       = reifyRoles
-  qReifyAnnotations = reifyAnnotations
-  qReifyModule      = reifyModule
-  qReifyConStrictness nm = do { nm' <- lookupThName nm
-                              ; dc  <- tcLookupDataCon nm'
-                              ; let bangs = dataConImplBangs dc
-                              ; return (map reifyDecidedStrictness bangs) }
-
-        -- For qRecover, discard error messages if
-        -- the recovery action is chosen.  Otherwise
-        -- we'll only fail higher up.
-  qRecover recover main = tryTcDiscardingErrs recover main
-
-  qGetPackageRoot = do
-    dflags <- getDynFlags
-    return $ fromMaybe "." (workingDirectory dflags)
-
-  qAddDependentFile fp = do
-    ref <- fmap tcg_dependent_files getGblEnv
-    dep_files <- readTcRef ref
-    writeTcRef ref (fp:dep_files)
-
-  qAddTempFile suffix = do
-    dflags <- getDynFlags
-    logger <- getLogger
-    tmpfs  <- hsc_tmpfs <$> getTopEnv
-    liftIO $ newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession suffix
-
-  qAddTopDecls thds = do
-      l <- getSrcSpanM
-      th_origin <- getThSpliceOrigin
-      let either_hval = convertToHsDecls th_origin l thds
-      ds <- case either_hval of
-              Left exn -> failWithTc
-                            $ TcRnRunSpliceFailure (Just "addTopDecls") exn
-              Right ds -> return ds
-      mapM_ (checkTopDecl . unLoc) ds
-      th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
-      updTcRef th_topdecls_var (\topds -> ds ++ topds)
-    where
-      checkTopDecl :: HsDecl GhcPs -> TcM ()
-      checkTopDecl (ValD _ binds)
-        = mapM_ bindName (collectHsBindBinders CollNoDictBinders binds)
-      checkTopDecl (SigD _ _)
-        = return ()
-      checkTopDecl (AnnD _ _)
-        = return ()
-      checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name }))
-        = bindName name
-      checkTopDecl d
-        = addErr $ TcRnInvalidTopDecl d
-
-      bindName :: RdrName -> TcM ()
-      bindName (Exact n)
-        = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
-             ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
-             }
-
-      bindName name = addErr $ TcRnNonExactName name
-
-  qAddForeignFilePath lang fp = do
-    var <- fmap tcg_th_foreign_files getGblEnv
-    updTcRef var ((lang, fp) :)
-
-  qAddModFinalizer fin = do
-      r <- liftIO $ mkRemoteRef fin
-      fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
-      addModFinalizerRef fref
-
-  qAddCorePlugin plugin = do
-      hsc_env <- getTopEnv
-      let fc        = hsc_FC hsc_env
-      let home_unit = hsc_home_unit hsc_env
-      let dflags    = hsc_dflags hsc_env
-      let fopts     = initFinderOpts dflags
-      r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)
-      let err = TcRnAddInvalidCorePlugin plugin
-      case r of
-        Found {} -> addErr err
-        FoundMultiple {} -> addErr err
-        _ -> return ()
-      th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
-      updTcRef th_coreplugins_var (plugin:)
-
-  qGetQ :: forall a. Typeable a => TcM (Maybe a)
-  qGetQ = do
-      th_state_var <- fmap tcg_th_state getGblEnv
-      th_state <- readTcRef th_state_var
-      -- See #10596 for why we use a scoped type variable here.
-      return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
-
-  qPutQ x = do
-      th_state_var <- fmap tcg_th_state getGblEnv
-      updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
-
-  qIsExtEnabled = xoptM
-
-  qExtsEnabled =
-    EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
-
-  qPutDoc doc_loc s = do
-    th_doc_var <- tcg_th_docs <$> getGblEnv
-    resolved_doc_loc <- resolve_loc doc_loc
-    is_local <- checkLocalName resolved_doc_loc
-    unless is_local $ failWithTc $ TcRnAddDocToNonLocalDefn doc_loc
-    let ds = mkGeneratedHsDocString s
-        hd = lexHsDoc parseIdentifier ds
-    hd' <- rnHsDoc hd
-    updTcRef th_doc_var (Map.insert resolved_doc_loc hd')
-    where
-      resolve_loc (TH.DeclDoc n) = DeclDoc <$> lookupThName n
-      resolve_loc (TH.ArgDoc n i) = ArgDoc <$> lookupThName n <*> pure i
-      resolve_loc (TH.InstDoc t) = InstDoc <$> fmap getName (lookupThInstName t)
-      resolve_loc TH.ModuleDoc = pure ModuleDoc
-
-      -- It doesn't make sense to add documentation to something not inside
-      -- the current module. So check for it!
-      checkLocalName (DeclDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n
-      checkLocalName (ArgDoc n _) = nameIsLocalOrFrom <$> getModule <*> pure n
-      checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n
-      checkLocalName ModuleDoc = pure True
-
-
-  qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc
-  qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc
-  qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i
-  qGetDoc TH.ModuleDoc = do
-    df <- getDynFlags
-    docs <- getGblEnv >>= extractDocs df
-    return (renderHsDocString . hsDocString <$> (docs_mod_hdr =<< docs))
-
--- | Looks up documentation for a declaration in first the current module,
--- otherwise tries to find it in another module via 'hscGetModuleInterface'.
-lookupDeclDoc :: Name -> TcM (Maybe String)
-lookupDeclDoc nm = do
-  df <- getDynFlags
-  Docs{docs_decls} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df
-  case lookupUniqMap docs_decls nm of
-    Just doc -> pure $ Just (renderHsDocStrings $ map hsDocString doc)
-    Nothing -> do
-      -- Wasn't in the current module. Try searching other external ones!
-      mIface <- getExternalModIface nm
-      case mIface of
-        Just ModIface { mi_docs = Just Docs{docs_decls = dmap} } ->
-          pure $ renderHsDocStrings . map hsDocString <$> lookupUniqMap dmap nm
-        _ -> pure Nothing
-
--- | Like 'lookupDeclDoc', looks up documentation for a function argument. If
--- it can't find any documentation for a function in this module, it tries to
--- find it in another module.
-lookupArgDoc :: Int -> Name -> TcM (Maybe String)
-lookupArgDoc i nm = do
-  df <- getDynFlags
-  Docs{docs_args = argDocs} <- fmap (fromMaybe emptyDocs) $ getGblEnv >>= extractDocs df
-  case lookupUniqMap argDocs nm of
-    Just m -> pure $ renderHsDocString . hsDocString <$> IntMap.lookup i m
-    Nothing -> do
-      mIface <- getExternalModIface nm
-      case mIface of
-        Just ModIface { mi_docs = Just Docs{docs_args = amap} } ->
-          pure $ renderHsDocString . hsDocString <$> (lookupUniqMap amap nm >>= IntMap.lookup i)
-        _ -> pure Nothing
-
--- | Returns the module a Name belongs to, if it is isn't local.
-getExternalModIface :: Name -> TcM (Maybe ModIface)
-getExternalModIface nm = do
-  isLocal <- nameIsLocalOrFrom <$> getModule <*> pure nm
-  if isLocal
-    then pure Nothing
-    else case nameModule_maybe nm of
-          Nothing -> pure Nothing
-          Just modNm -> do
-            hsc_env <- getTopEnv
-            iface <- liftIO $ hscGetModuleInterface hsc_env modNm
-            pure (Just iface)
-
--- | Find the GHC name of the first instance that matches the TH type
-lookupThInstName :: TH.Type -> TcM Name
-lookupThInstName th_type = do
-  cls_name <- inst_cls_name th_type
-  insts <- reifyInstances' cls_name (inst_arg_types th_type)
-  case insts of   -- This expands any type synonyms
-    Left  (_, (inst:_)) -> return $ getName inst
-    Left  (_, [])       -> noMatches
-    Right (_, (inst:_)) -> return $ getName inst
-    Right (_, [])       -> noMatches
-  where
-    noMatches = failWithTc $
-      TcRnFailedToLookupThInstName th_type NoMatchesFound
-
-    -- Get the name of the class for the instance we are documenting
-    -- > inst_cls_name (Monad Maybe) == Monad
-    -- > inst_cls_name C = C
-    inst_cls_name :: TH.Type -> TcM TH.Name
-    inst_cls_name (TH.AppT t _)              = inst_cls_name t
-    inst_cls_name (TH.SigT n _)              = inst_cls_name n
-    inst_cls_name (TH.VarT n)                = pure n
-    inst_cls_name (TH.ConT n)                = pure n
-    inst_cls_name (TH.PromotedT n)           = pure n
-    inst_cls_name (TH.InfixT _ n _)          = pure n
-    inst_cls_name (TH.UInfixT _ n _)         = pure n
-    inst_cls_name (TH.PromotedInfixT _ n _)  = pure n
-    inst_cls_name (TH.PromotedUInfixT _ n _) = pure n
-    inst_cls_name (TH.ParensT t)             = inst_cls_name t
-
-    inst_cls_name (TH.ForallT _ _ _)         = inst_cls_name_err
-    inst_cls_name (TH.ForallVisT _ _)        = inst_cls_name_err
-    inst_cls_name (TH.AppKindT _ _)          = inst_cls_name_err
-    inst_cls_name (TH.TupleT _)              = inst_cls_name_err
-    inst_cls_name (TH.UnboxedTupleT _)       = inst_cls_name_err
-    inst_cls_name (TH.UnboxedSumT _)         = inst_cls_name_err
-    inst_cls_name TH.ArrowT                  = inst_cls_name_err
-    inst_cls_name TH.MulArrowT               = inst_cls_name_err
-    inst_cls_name TH.EqualityT               = inst_cls_name_err
-    inst_cls_name TH.ListT                   = inst_cls_name_err
-    inst_cls_name (TH.PromotedTupleT _)      = inst_cls_name_err
-    inst_cls_name TH.PromotedNilT            = inst_cls_name_err
-    inst_cls_name TH.PromotedConsT           = inst_cls_name_err
-    inst_cls_name TH.StarT                   = inst_cls_name_err
-    inst_cls_name TH.ConstraintT             = inst_cls_name_err
-    inst_cls_name (TH.LitT _)                = inst_cls_name_err
-    inst_cls_name TH.WildCardT               = inst_cls_name_err
-    inst_cls_name (TH.ImplicitParamT _ _)    = inst_cls_name_err
-
-    inst_cls_name_err = failWithTc $
-      TcRnFailedToLookupThInstName th_type CouldNotDetermineInstance
-
-    -- Basically does the opposite of 'mkThAppTs'
-    -- > inst_arg_types (Monad Maybe) == [Maybe]
-    -- > inst_arg_types C == []
-    inst_arg_types :: TH.Type -> [TH.Type]
-    inst_arg_types (TH.AppT _ args) =
-      let go (TH.AppT t ts) = t:go ts
-          go t = [t]
-        in go args
-    inst_arg_types _ = []
-
--- | Adds a mod finalizer reference to the local environment.
-addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM ()
-addModFinalizerRef finRef = do
-    th_stage <- getStage
-    case th_stage of
-      RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :)
-      -- This case happens only if a splice is executed and the caller does
-      -- not set the 'ThStage' to 'RunSplice' to collect finalizers.
-      -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
-      _ ->
-        pprPanic "addModFinalizer was called when no finalizers were collected"
-                 (ppr th_stage)
-
--- | Releases the external interpreter state.
-finishTH :: TcM ()
-finishTH = do
-  hsc_env <- getTopEnv
-  case interpInstance <$> hsc_interp hsc_env of
-    Nothing                  -> pure ()
-#if defined(HAVE_INTERNAL_INTERPRETER)
-    Just InternalInterp      -> pure ()
-#endif
-    Just (ExternalInterp {}) -> do
-      tcg <- getGblEnv
-      writeTcRef (tcg_th_remote_state tcg) Nothing
-
-
-runTHExp :: ForeignHValue -> TcM TH.Exp
-runTHExp = runTH THExp
-
-runTHPat :: ForeignHValue -> TcM TH.Pat
-runTHPat = runTH THPat
-
-runTHType :: ForeignHValue -> TcM TH.Type
-runTHType = runTH THType
-
-runTHDec :: ForeignHValue -> TcM [TH.Dec]
-runTHDec = runTH THDec
-
-runTH :: Binary a => THResultType -> ForeignHValue -> TcM a
-runTH ty fhv = do
-  interp <- tcGetInterp
-  case interpInstance interp of
-#if defined(HAVE_INTERNAL_INTERPRETER)
-    InternalInterp -> do
-       -- Run it in the local TcM
-      hv <- liftIO $ wormhole interp fhv
-      r <- runQuasi (unsafeCoerce hv :: TH.Q a)
-      return r
-#endif
-
-    ExternalInterp conf iserv ->
-      -- Run it on the server.  For an overview of how TH works with
-      -- Remote GHCi, see Note [Remote Template Haskell] in
-      -- libraries/ghci/GHCi/TH.hs.
-      withIServ_ conf iserv $ \i -> do
-        rstate <- getTHState i
-        loc <- TH.qLocation
-        liftIO $
-          withForeignRef rstate $ \state_hv ->
-          withForeignRef fhv $ \q_hv ->
-            writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc)))
-        runRemoteTH i []
-        bs <- readQResult i
-        return $! runGet get (LB.fromStrict bs)
-
-
--- | communicate with a remotely-running TH computation until it finishes.
--- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
-runRemoteTH
-  :: IServInstance
-  -> [Messages TcRnMessage]   --  saved from nested calls to qRecover
-  -> TcM ()
-runRemoteTH iserv recovers = do
-  THMsg msg <- liftIO $ readIServ iserv getTHMessage
-  case msg of
-    RunTHDone -> return ()
-    StartRecover -> do -- Note [TH recover with -fexternal-interpreter]
-      v <- getErrsVar
-      msgs <- readTcRef v
-      writeTcRef v emptyMessages
-      runRemoteTH iserv (msgs : recovers)
-    EndRecover caught_error -> do
-      let (prev_msgs, rest) = case recovers of
-             [] -> panic "EndRecover"
-             a : b -> (a,b)
-      v <- getErrsVar
-      warn_msgs <- getWarningMessages <$> readTcRef v
-      -- keep the warnings only if there were no errors
-      writeTcRef v $ if caught_error
-        then prev_msgs
-        else mkMessages warn_msgs `unionMessages` prev_msgs
-      runRemoteTH iserv rest
-    _other -> do
-      r <- handleTHMessage msg
-      liftIO $ writeIServ iserv (put r)
-      runRemoteTH iserv recovers
-
--- | Read a value of type QResult from the iserv
-readQResult :: Binary a => IServInstance -> TcM a
-readQResult i = do
-  qr <- liftIO $ readIServ i get
-  case qr of
-    QDone a -> return a
-    QException str -> liftIO $ throwIO (ErrorCall str)
-    QFail str -> fail str
-
-{- Note [TH recover with -fexternal-interpreter]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Recover is slightly tricky to implement.
-
-The meaning of "recover a b" is
- - Do a
-   - If it finished with no errors, then keep the warnings it generated
-   - If it failed, discard any messages it generated, and do b
-
-Note that "failed" here can mean either
-  (1) threw an exception (failTc)
-  (2) generated an error message (addErrTcM)
-
-The messages are managed by GHC in the TcM monad, whereas the
-exception-handling is done in the ghc-iserv process, so we have to
-coordinate between the two.
-
-On the server:
-  - emit a StartRecover message
-  - run "a; FailIfErrs" inside a try
-  - emit an (EndRecover x) message, where x = True if "a; FailIfErrs" failed
-  - if "a; FailIfErrs" failed, run "b"
-
-Back in GHC, when we receive:
-
-  FailIfErrrs
-    failTc if there are any error messages (= failIfErrsM)
-  StartRecover
-    save the current messages and start with an empty set.
-  EndRecover caught_error
-    Restore the previous messages,
-    and merge in the new messages if caught_error is false.
--}
-
--- | Retrieve (or create, if it hasn't been created already), the
--- remote TH state.  The TH state is a remote reference to an IORef
--- QState living on the server, and we have to pass this to each RunTH
--- call we make.
---
--- The TH state is stored in tcg_th_remote_state in the TcGblEnv.
---
-getTHState :: IServInstance -> TcM (ForeignRef (IORef QState))
-getTHState i = do
-  tcg <- getGblEnv
-  th_state <- readTcRef (tcg_th_remote_state tcg)
-  case th_state of
-    Just rhv -> return rhv
-    Nothing -> do
-      interp <- tcGetInterp
-      fhv <- liftIO $ mkFinalizedHValue interp =<< iservCall i StartTH
-      writeTcRef (tcg_th_remote_state tcg) (Just fhv)
-      return fhv
-
-wrapTHResult :: TcM a -> TcM (THResult a)
-wrapTHResult tcm = do
-  e <- tryM tcm   -- only catch 'fail', treat everything else as catastrophic
-  case e of
-    Left e -> return (THException (show e))
-    Right a -> return (THComplete a)
-
-handleTHMessage :: THMessage a -> TcM a
-handleTHMessage msg = case msg of
-  NewName a -> wrapTHResult $ TH.qNewName a
-  Report b str -> wrapTHResult $ TH.qReport b str
-  LookupName b str -> wrapTHResult $ TH.qLookupName b str
-  Reify n -> wrapTHResult $ TH.qReify n
-  ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
-  ReifyType n -> wrapTHResult $ TH.qReifyType n
-  ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
-  ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
-  ReifyAnnotations lookup tyrep ->
-    wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
-  ReifyModule m -> wrapTHResult $ TH.qReifyModule m
-  ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
-  GetPackageRoot -> wrapTHResult $ TH.qGetPackageRoot
-  AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
-  AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
-  AddModFinalizer r -> do
-    interp <- hscInterp <$> getTopEnv
-    wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef
-  AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
-  AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
-  AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
-  IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
-  ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
-  PutDoc l s -> wrapTHResult $ TH.qPutDoc l s
-  GetDoc l -> wrapTHResult $ TH.qGetDoc l
-  FailIfErrs -> wrapTHResult failIfErrsM
-  _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
-
-getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]]
-getAnnotationsByTypeRep th_name tyrep
-  = do { name <- lookupThAnnLookup th_name
-       ; topEnv <- getTopEnv
-       ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
-       ; tcg <- getGblEnv
-       ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep
-       ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep
-       ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
-
-{-
-************************************************************************
-*                                                                      *
-            Instance Testing
-*                                                                      *
-************************************************************************
--}
-
-reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec]
-reifyInstances th_nm th_tys
-  = do { insts <- reifyInstances' th_nm th_tys
-       ; case insts of
-           Left (cls, cls_insts) ->
-             reifyClassInstances cls cls_insts
-           Right (tc, fam_insts) ->
-             reifyFamilyInstances tc fam_insts }
-
-reifyInstances' :: TH.Name
-                -> [TH.Type]
-                -> TcM (Either (Class, [ClsInst]) (TyCon, [FamInst]))
-                -- ^ Returns 'Left' in the case that the instances were found to
-                -- be class instances, or 'Right' if they are family instances.
-reifyInstances' th_nm th_tys
-   = addErrCtxt (text "In the argument of reifyInstances:"
-                 <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $
-     do { loc <- getSrcSpanM
-        ; th_origin <- getThSpliceOrigin
-        ; rdr_ty <- cvt th_origin loc (mkThAppTs (TH.ConT th_nm) th_tys)
-          -- #9262 says to bring vars into scope, like in HsForAllTy case
-          -- of rnHsTyKi
-        ; let tv_rdrs = extractHsTyRdrTyVars rdr_ty
-          -- Rename  to HsType Name
-        ; ((tv_names, rn_ty), _fvs)
-            <- checkNoErrs $ -- If there are out-of-scope Names here, then we
-                             -- must error before proceeding to typecheck the
-                             -- renamed type, as that will result in GHC
-                             -- internal errors (#13837).
-               rnImplicitTvOccs Nothing tv_rdrs $ \ tv_names ->
-               do { (rn_ty, fvs) <- rnLHsType doc rdr_ty
-                  ; return ((tv_names, rn_ty), fvs) }
-        ; skol_info <- mkSkolemInfo ReifySkol
-        ; (tclvl, wanted, (tvs, ty))
-            <- pushLevelAndSolveEqualitiesX "reifyInstances"  $
-               bindImplicitTKBndrs_Skol skol_info tv_names              $
-               tcInferLHsType rn_ty
-
-        ; tvs <- zonkAndScopedSort tvs
-
-        -- Avoid error cascade if there are unsolved
-        ; reportUnsolvedEqualities skol_info tvs tclvl wanted
-
-        ; ty <- zonkTcTypeToType ty
-                -- Substitute out the meta type variables
-                -- In particular, the type might have kind
-                -- variables inside it (#7477)
-
-        ; traceTc "reifyInstances'" (ppr ty $$ ppr (typeKind ty))
-        ; case splitTyConApp_maybe ty of   -- This expands any type synonyms
-            Just (tc, tys)                 -- See #7910
-               | Just cls <- tyConClass_maybe tc
-               -> do { inst_envs <- tcGetInstEnvs
-                     ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys
-                     ; traceTc "reifyInstances'1" (ppr matches)
-                     ; return $ Left (cls, map fst matches ++ getPotentialUnifiers unifies) }
-               | isOpenFamilyTyCon tc
-               -> do { inst_envs <- tcGetFamInstEnvs
-                     ; let matches = lookupFamInstEnv inst_envs tc tys
-                     ; traceTc "reifyInstances'2" (ppr matches)
-                     ; return $ Right (tc, map fim_instance matches) }
-            _  -> bale_out $ TcRnCannotReifyInstance ty }
-  where
-    doc = ClassInstanceCtx
-    bale_out msg = failWithTc msg
-
-    cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs)
-    cvt origin loc th_ty = case convertToHsType origin loc th_ty of
-      Left msg -> failWithTc (TcRnRunSpliceFailure Nothing msg)
-      Right ty -> return ty
-
-{-
-************************************************************************
-*                                                                      *
-                        Reification
-*                                                                      *
-************************************************************************
--}
-
-lookupName :: Bool      -- True  <=> type namespace
-                        -- False <=> value namespace
-           -> String -> TcM (Maybe TH.Name)
-lookupName is_type_name s
-  = do { mb_nm <- lookupOccRn_maybe rdr_name
-       ; return (fmap reifyName mb_nm) }
-  where
-    th_name = TH.mkName s       -- Parses M.x into a base of 'x' and a module of 'M'
-
-    occ_fs :: FastString
-    occ_fs = mkFastString (TH.nameBase th_name)
-
-    occ :: OccName
-    occ | is_type_name
-        = if isLexVarSym occ_fs || isLexCon occ_fs
-                             then mkTcOccFS    occ_fs
-                             else mkTyVarOccFS occ_fs
-        | otherwise
-        = if isLexCon occ_fs then mkDataOccFS occ_fs
-                             else mkVarOccFS  occ_fs
-
-    rdr_name = case TH.nameModule th_name of
-                 Nothing  -> mkRdrUnqual occ
-                 Just mod -> mkRdrQual (mkModuleName mod) occ
-
--- | We only want to produce warnings for TH-splices if the user requests so.
--- See Note [Warnings for TH splices].
-getThSpliceOrigin :: TcM Origin
-getThSpliceOrigin = do
-  warn <- goptM Opt_EnableThSpliceWarnings
-  if warn then return FromSource else return Generated
-
-
-getThing :: TH.Name -> TcM TcTyThing
-getThing th_name
-  = do  { name <- lookupThName th_name
-        ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
-        ; tcLookupTh name }
-        -- ToDo: this tcLookup could fail, which would give a
-        --       rather unhelpful error message
-  where
-    ppr_ns (TH.Name _ (TH.NameG TH.DataName  _pkg _mod)) = text "data"
-    ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
-    ppr_ns (TH.Name _ (TH.NameG TH.VarName   _pkg _mod)) = text "var"
-    ppr_ns _ = panic "reify/ppr_ns"
-
-reify :: TH.Name -> TcM TH.Info
-reify th_name
-  = do  { traceTc "reify 1" (text (TH.showName th_name))
-        ; thing <- getThing th_name
-        ; traceTc "reify 2" (ppr thing)
-        ; reifyThing thing }
-
-lookupThName :: TH.Name -> TcM Name
-lookupThName th_name = do
-    mb_name <- lookupThName_maybe th_name
-    case mb_name of
-        Nothing   -> failWithTc (notInScope th_name)
-        Just name -> return name
-
-lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
-lookupThName_maybe th_name
-  =  do { names <- mapMaybeM lookupOccRn_maybe (thRdrNameGuesses th_name)
-          -- Pick the first that works
-          -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
-        ; return (listToMaybe names) }
-
-tcLookupTh :: Name -> TcM TcTyThing
--- This is a specialised version of GHC.Tc.Utils.Env.tcLookup; specialised mainly in that
--- it gives a reify-related error message on failure, whereas in the normal
--- tcLookup, failure is a bug.
-tcLookupTh name
-  = do  { (gbl_env, lcl_env) <- getEnvs
-        ; case lookupNameEnv (tcl_env lcl_env) name of {
-                Just thing -> return thing;
-                Nothing    ->
-
-          case lookupNameEnv (tcg_type_env gbl_env) name of {
-                Just thing -> return (AGlobal thing);
-                Nothing    ->
-
-          -- EZY: I don't think this choice matters, no TH in signatures!
-          if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name
-          then  -- It's defined in this module
-                failWithTc (notInEnv name)
-
-          else
-     do { mb_thing <- tcLookupImported_maybe name
-        ; case mb_thing of
-            Succeeded thing -> return (AGlobal thing)
-            Failed msg      -> failWithTc (TcRnInterfaceLookupError name msg)
-    }}}}
-
-notInScope :: TH.Name -> TcRnMessage
-notInScope th_name =
-  TcRnCannotReifyOutOfScopeThing th_name
-
-notInEnv :: Name -> TcRnMessage
-notInEnv name = TcRnCannotReifyThingNotInTypeEnv name
-
-------------------------------
-reifyRoles :: TH.Name -> TcM [TH.Role]
-reifyRoles th_name
-  = do { thing <- getThing th_name
-       ; case thing of
-           AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))
-           _ -> failWithTc (TcRnNoRolesAssociatedWithThing thing)
-       }
-  where
-    reify_role Nominal          = TH.NominalR
-    reify_role Representational = TH.RepresentationalR
-    reify_role Phantom          = TH.PhantomR
-
-------------------------------
-reifyThing :: TcTyThing -> TcM TH.Info
--- The only reason this is monadic is for error reporting,
--- which in turn is mainly for the case when TH can't express
--- some random GHC extension
-
-reifyThing (AGlobal (AnId id))
-  = do  { ty <- reifyType (idType id)
-        ; let v = reifyName id
-        ; case idDetails id of
-            ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls))
-            RecSelId{sel_tycon=RecSelData tc}
-                          -> return (TH.VarI (reifySelector id tc) ty Nothing)
-            _             -> return (TH.VarI     v ty Nothing)
-    }
-
-reifyThing (AGlobal (ATyCon tc))   = reifyTyCon tc
-reifyThing (AGlobal (AConLike (RealDataCon dc)))
-  = do  { let name = dataConName dc
-        ; ty <- reifyType (idType (dataConWrapId dc))
-        ; return (TH.DataConI (reifyName name) ty
-                              (reifyName (dataConOrigTyCon dc)))
-        }
-
-reifyThing (AGlobal (AConLike (PatSynCon ps)))
-  = do { let name = reifyName ps
-       ; ty <- reifyPatSynType (patSynSigBndr ps)
-       ; return (TH.PatSynI name ty) }
-
-reifyThing (ATcId {tct_id = id})
-  = do  { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
-                                        -- though it may be incomplete
-        ; ty2 <- reifyType ty1
-        ; return (TH.VarI (reifyName id) ty2 Nothing) }
-
-reifyThing (ATyVar tv tv1)
-  = do { ty1 <- zonkTcTyVar tv1
-       ; ty2 <- reifyType ty1
-       ; return (TH.TyVarI (reifyName tv) ty2) }
-
-reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)
-
--------------------------------------------
-reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn
-reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs
-                                 , cab_lhs = lhs
-                                 , cab_rhs = rhs })
-            -- remove kind patterns (#8884)
-  = do { tvs' <- reifyTyVarsToMaybe tvs
-       ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
-       ; lhs' <- reifyTypes lhs_types_only
-       ; annot_th_lhs <- zipWith3M annotThType (tyConArgsPolyKinded fam_tc)
-                                   lhs_types_only lhs'
-       ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs
-       ; rhs'  <- reifyType rhs
-       ; return (TH.TySynEqn tvs' lhs_type rhs') }
-
-reifyTyCon :: TyCon -> TcM TH.Info
-reifyTyCon tc
-  | Just cls <- tyConClass_maybe tc
-  = reifyClass cls
-
-{-  Seems to be just a short cut for the next equation -- omit
-  | tc `hasKey` fUNTyConKey -- I'm not quite sure what is happening here
-  = return (TH.PrimTyConI (reifyName tc) 2 False)
--}
-
-  | isPrimTyCon tc
-  = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc))
-                          (isUnliftedTypeKind (tyConResKind tc)))
-
-  | isTypeFamilyTyCon tc
-  = do { let tvs      = tyConTyVars tc
-             res_kind = tyConResKind tc
-             resVar   = famTcResVar tc
-
-       ; kind' <- reifyKind res_kind
-       ; let (resultSig, injectivity) =
-                 case resVar of
-                   Nothing   -> (TH.KindSig kind', Nothing)
-                   Just name ->
-                     let thName   = reifyName name
-                         injAnnot = tyConInjectivityInfo tc
-                         sig = TH.TyVarSig (TH.KindedTV thName () kind')
-                         inj = case injAnnot of
-                                 NotInjective -> Nothing
-                                 Injective ms ->
-                                     Just (TH.InjectivityAnn thName injRHS)
-                                   where
-                                     injRHS = map (reifyName . tyVarName)
-                                                  (filterByList ms tvs)
-                     in (sig, inj)
-       ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
-       ; let tfHead =
-               TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity
-       ; if isOpenTypeFamilyTyCon tc
-         then do { fam_envs <- tcGetFamInstEnvs
-                 ; instances <- reifyFamilyInstances tc
-                                  (familyInstances fam_envs tc)
-                 ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) }
-         else do { eqns <-
-                     case isClosedSynFamilyTyConWithAxiom_maybe tc of
-                       Just ax -> mapM (reifyAxBranch tc) $
-                                  fromBranches $ coAxiomBranches ax
-                       Nothing -> return []
-                 ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns)
-                      []) } }
-
-  | isDataFamilyTyCon tc
-  = do { let res_kind = tyConResKind tc
-
-       ; kind' <- fmap Just (reifyKind res_kind)
-
-       ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
-       ; fam_envs <- tcGetFamInstEnvs
-       ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc)
-       ; return (TH.FamilyI
-                       (TH.DataFamilyD (reifyName tc) tvs' kind') instances) }
-
-  | Just (_, rhs) <- synTyConDefn_maybe tc  -- Vanilla type synonym
-  = do { rhs' <- reifyType rhs
-       ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
-       ; return (TH.TyConI
-                   (TH.TySynD (reifyName tc) tvs' rhs'))
-       }
-
-  | otherwise
-  = do  { cxt <- reifyCxt (tyConStupidTheta tc)
-        ; let tvs      = tyConTyVars tc
-              dataCons = tyConDataCons tc
-              isGadt   = isGadtSyntaxTyCon tc
-        ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
-        ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc)
-        ; let name = reifyName tc
-              deriv = []        -- Don't know about deriving
-              decl | isNewTyCon tc =
-                       TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv
-                   | otherwise     =
-                       TH.DataD    cxt name r_tvs Nothing       cons  deriv
-        ; return (TH.TyConI decl) }
-
-reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con
-reifyDataCon isGadtDataCon tys dc
-  = do { let -- used for H98 data constructors
-             (ex_tvs, theta, arg_tys)
-                 = dataConInstSig dc tys
-             -- used for GADTs data constructors
-             g_user_tvs' = dataConUserTyVarBinders dc
-             (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty')
-                 = dataConFullSig dc
-             (srcUnpks, srcStricts)
-                 = mapAndUnzip reifySourceBang (dataConSrcBangs dc)
-             dcdBangs  = zipWith TH.Bang srcUnpks srcStricts
-             fields    = dataConFieldLabels dc
-             name      = reifyName dc
-             -- Universal tvs present in eq_spec need to be filtered out, as
-             -- they will not appear anywhere in the type.
-             eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec)
-
-       ; (univ_subst, _)
-              -- See Note [Freshen reified GADT constructors' universal tyvars]
-           <- freshenTyVarBndrs $
-              filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs
-       ; let (tvb_subst, g_user_tvs) = subst_tv_binders univ_subst g_user_tvs'
-             g_theta   = substTys tvb_subst g_theta'
-             g_arg_tys = substTys tvb_subst (map scaledThing g_arg_tys')
-             g_res_ty  = substTy  tvb_subst g_res_ty'
-
-       ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)
-
-       ; main_con <-
-           if | not (null fields) && not isGadtDataCon ->
-                  return $ TH.RecC name (zip3 (map reifyFieldLabel fields)
-                                         dcdBangs r_arg_tys)
-              | not (null fields) -> do
-                  { res_ty <- reifyType g_res_ty
-                  ; return $ TH.RecGadtC [name]
-                                     (zip3 (map (reifyName . flSelector) fields)
-                                      dcdBangs r_arg_tys) res_ty }
-                -- We need to check not isGadtDataCon here because GADT
-                -- constructors can be declared infix.
-                -- See Note [Infix GADT constructors] in GHC.Tc.TyCl.
-              | dataConIsInfix dc && not isGadtDataCon ->
-                  assert (r_arg_tys `lengthIs` 2) $ do
-                  { let [r_a1, r_a2] = r_arg_tys
-                        [s1,   s2]   = dcdBangs
-                  ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }
-              | isGadtDataCon -> do
-                  { res_ty <- reifyType g_res_ty
-                  ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty }
-              | otherwise ->
-                  return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)
-
-       ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta)
-                               | otherwise     = assert (all isTyVar ex_tvs)
-                                                 -- no covars for haskell syntax
-                                                 (map mk_specified ex_tvs, theta)
-             ret_con | null ex_tvs' && null theta' = return main_con
-                     | otherwise                   = do
-                         { cxt <- reifyCxt theta'
-                         ; ex_tvs'' <- reifyTyVarBndrs ex_tvs'
-                         ; return (TH.ForallC ex_tvs'' cxt main_con) }
-       ; assert (r_arg_tys `equalLength` dcdBangs)
-         ret_con }
-  where
-    mk_specified tv = Bndr tv SpecifiedSpec
-
-    subst_tv_binders subst tv_bndrs =
-      let tvs            = binderVars tv_bndrs
-          flags          = binderFlags tv_bndrs
-          (subst', tvs') = substTyVarBndrs subst tvs
-          tv_bndrs'      = map (\(tv,fl) -> Bndr tv fl) (zip tvs' flags)
-      in (subst', tv_bndrs')
-
-{-
-Note [Freshen reified GADT constructors' universal tyvars]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose one were to reify this GADT:
-
-  data a :~: b where
-    Refl :: forall a b. (a ~ b) => a :~: b
-
-We ought to be careful here about the uniques we give to the occurrences of `a`
-and `b` in this definition. That is because in the original DataCon, all uses
-of `a` and `b` have the same unique, since `a` and `b` are both universally
-quantified type variables--that is, they are used in both the (:~:) tycon as
-well as in the constructor type signature. But when we turn the DataCon
-definition into the reified one, the `a` and `b` in the constructor type
-signature becomes differently scoped than the `a` and `b` in `data a :~: b`.
-
-While it wouldn't technically be *wrong* per se to re-use the same uniques for
-`a` and `b` across these two different scopes, it's somewhat annoying for end
-users of Template Haskell, since they wouldn't be able to rely on the
-assumption that all TH names have globally distinct uniques (#13885). For this
-reason, we freshen the universally quantified tyvars that go into the reified
-GADT constructor type signature to give them distinct uniques from their
-counterparts in the tycon.
--}
-
-------------------------------
-reifyClass :: Class -> TcM TH.Info
-reifyClass cls
-  = do  { cxt <- reifyCxt theta
-        ; inst_envs <- tcGetInstEnvs
-        ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
-        ; assocTys <- concatMapM reifyAT ats
-        ; ops <- concatMapM reify_op op_stuff
-        ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls))
-        ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)
-        ; return (TH.ClassI dec insts) }
-  where
-    (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls
-    fds' = map reifyFunDep fds
-    reify_op (op, def_meth)
-      = do { let (_, _, ty) = tcSplitMethodTy (idType op)
-               -- Use tcSplitMethodTy to get rid of the extraneous class
-               -- variables and predicates at the beginning of op's type
-               -- (see #15551).
-           ; ty' <- reifyType ty
-           ; let nm' = reifyName op
-           ; case def_meth of
-                Just (_, GenericDM gdm_ty) ->
-                  do { gdm_ty' <- reifyType gdm_ty
-                     ; return [TH.SigD nm' ty', TH.DefaultSigD nm' gdm_ty'] }
-                _ -> return [TH.SigD nm' ty'] }
-
-    reifyAT :: ClassATItem -> TcM [TH.Dec]
-    reifyAT (ATI tycon def) = do
-      tycon' <- reifyTyCon tycon
-      case tycon' of
-        TH.FamilyI dec _ -> do
-          let (tyName, tyArgs) = tfNames dec
-          (dec :) <$> maybe (return [])
-                            (fmap (:[]) . reifyDefImpl tyName tyArgs . fst)
-                            def
-        _ -> pprPanic "reifyAT" (text (show tycon'))
-
-    reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec
-    reifyDefImpl n args ty =
-      TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args))
-                                  <$> reifyType ty
-
-    tfNames :: TH.Dec -> (TH.Name, [TH.Name])
-    tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _))
-      = (n, map bndrName args)
-    tfNames d = pprPanic "tfNames" (text (show d))
-
-    bndrName :: TH.TyVarBndr flag -> TH.Name
-    bndrName (TH.PlainTV n _)    = n
-    bndrName (TH.KindedTV n _ _) = n
-
-------------------------------
--- | Annotate (with TH.SigT) a type if the first parameter is True
--- and if the type contains a free variable.
--- This is used to annotate type patterns for poly-kinded tyvars in
--- reifying class and type instances.
--- See @Note [Reified instances and explicit kind signatures]@.
-annotThType :: Bool   -- True <=> annotate
-            -> TyCoRep.Type -> TH.Type -> TcM TH.Type
-  -- tiny optimization: if the type is annotated, don't annotate again.
-annotThType _    _  th_ty@(TH.SigT {}) = return th_ty
-annotThType True ty th_ty
-  | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
-  = do { let ki = typeKind ty
-       ; th_ki <- reifyKind ki
-       ; return (TH.SigT th_ty th_ki) }
-annotThType _    _ th_ty = return th_ty
-
--- | For every argument type that a type constructor accepts,
--- report whether or not the argument is poly-kinded. This is used to
--- eventually feed into 'annotThType'.
--- See @Note [Reified instances and explicit kind signatures]@.
-tyConArgsPolyKinded :: TyCon -> [Bool]
-tyConArgsPolyKinded tc =
-     map (is_poly_ty . tyVarKind)      tc_vis_tvs
-     -- See "Wrinkle: Oversaturated data family instances" in
-     -- @Note [Reified instances and explicit kind signatures]@
-  ++ map (is_poly_ty . piTyBinderType) tc_res_kind_vis_bndrs -- (1) in Wrinkle
-  ++ repeat True                                             -- (2) in Wrinkle
-  where
-    is_poly_ty :: Type -> Bool
-    is_poly_ty ty = not $
-                    isEmptyVarSet $
-                    filterVarSet isTyVar $
-                    tyCoVarsOfType ty
-
-    tc_vis_tvs :: [TyVar]
-    tc_vis_tvs = tyConVisibleTyVars tc
-
-    tc_res_kind_vis_bndrs :: [PiTyBinder]
-    tc_res_kind_vis_bndrs = filter isVisiblePiTyBinder $ fst $ splitPiTys $ tyConResKind tc
-
-{-
-Note [Reified instances and explicit kind signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Reified class instances and type family instances often include extra kind
-information to disambiguate instances. Here is one such example that
-illustrates this (#8953):
-
-    type family Poly (a :: k) :: Type
-    type instance Poly (x :: Bool)    = Int
-    type instance Poly (x :: Maybe k) = Double
-
-If you're not careful, reifying these instances might yield this:
-
-    type instance Poly x = Int
-    type instance Poly x = Double
-
-To avoid this, we go through some care to annotate things with extra kind
-information. Some functions which accomplish this feat include:
-
-* annotThType: This annotates a type with a kind signature if the type contains
-  a free variable.
-* tyConArgsPolyKinded: This checks every argument that a type constructor can
-  accept and reports if the type of the argument is poly-kinded. This
-  information is ultimately fed into annotThType.
-
------
--- Wrinkle: Oversaturated data family instances
------
-
-What constitutes an argument to a type constructor in the definition of
-tyConArgsPolyKinded? For most type constructors, it's simply the visible
-type variable binders (i.e., tyConVisibleTyVars). There is one corner case
-we must keep in mind, however: data family instances can appear oversaturated
-(#17296). For instance:
-
-    data family   Foo :: Type -> Type
-    data instance Foo x
-
-    data family Bar :: k
-    data family Bar x
-
-For these sorts of data family instances, tyConVisibleTyVars isn't enough,
-as they won't give you the kinds of the oversaturated arguments. We must
-also consult:
-
-1. The kinds of the arguments in the result kind (i.e., the tyConResKind).
-   This will tell us, e.g., the kind of `x` in `Foo x` above.
-2. If we go beyond the number of arguments in the result kind (like the
-   `x` in `Bar x`), then we conservatively assume that the argument's
-   kind is poly-kinded.
-
------
--- Wrinkle: data family instances with return kinds
------
-
-Another squirrelly corner case is this:
-
-    data family Foo (a :: k)
-    data instance Foo :: Bool -> Type
-    data instance Foo :: Char -> Type
-
-If you're not careful, reifying these instances might yield this:
-
-    data instance Foo
-    data instance Foo
-
-We can fix this ambiguity by reifying the instances' explicit return kinds. We
-should only do this if necessary (see
-Note [When does a tycon application need an explicit kind signature?] in GHC.Core.Type),
-but more importantly, we *only* do this if either of the following are true:
-
-1. The data family instance has no constructors.
-2. The data family instance is declared with GADT syntax.
-
-If neither of these are true, then reifying the return kind would yield
-something like this:
-
-    data instance (Bar a :: Type) = MkBar a
-
-Which is not valid syntax.
--}
-
-------------------------------
-reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]
-reifyClassInstances cls insts
-  = mapM (reifyClassInstance (tyConArgsPolyKinded (classTyCon cls))) insts
-
-reifyClassInstance :: [Bool]  -- True <=> the corresponding tv is poly-kinded
-                              -- includes only *visible* tvs
-                   -> ClsInst -> TcM TH.Dec
-reifyClassInstance is_poly_tvs i
-  = do { cxt <- reifyCxt theta
-       ; let vis_types = filterOutInvisibleTypes cls_tc types
-       ; thtypes <- reifyTypes vis_types
-       ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes
-       ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes
-       ; return $ (TH.InstanceD over cxt head_ty []) }
-  where
-     (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
-     cls_tc   = classTyCon cls
-     dfun     = instanceDFunId i
-     over     = case overlapMode (is_flag i) of
-                  NoOverlap _     -> Nothing
-                  Overlappable _  -> Just TH.Overlappable
-                  Overlapping _   -> Just TH.Overlapping
-                  Overlaps _      -> Just TH.Overlaps
-                  Incoherent _    -> Just TH.Incoherent
-
-------------------------------
-reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
-reifyFamilyInstances fam_tc fam_insts
-  = mapM (reifyFamilyInstance (tyConArgsPolyKinded fam_tc)) fam_insts
-
-reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
-                              -- includes only *visible* tvs
-                    -> FamInst -> TcM TH.Dec
-reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor
-                                         , fi_axiom = ax
-                                         , fi_fam = fam })
-  | let fam_tc = coAxiomTyCon ax
-        branch = coAxiomSingleBranch ax
-  , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch
-  = case flavor of
-      SynFamilyInst ->
-               -- remove kind patterns (#8884)
-        do { th_tvs <- reifyTyVarsToMaybe tvs
-           ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
-           ; th_lhs <- reifyTypes lhs_types_only
-           ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only
-                                                   th_lhs
-           ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs
-           ; th_rhs <- reifyType rhs
-           ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) }
-
-      DataFamilyInst rep_tc ->
-        do { let -- eta-expand lhs types, because sometimes data/newtype
-                 -- instances are eta-reduced; See #9692
-                 -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom
-                 (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch
-                 fam'     = reifyName fam
-                 dataCons = tyConDataCons rep_tc
-                 isGadt   = isGadtSyntaxTyCon rep_tc
-           ; th_tvs <- reifyTyVarsToMaybe ee_tvs
-           ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons
-           ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs
-           ; th_tys <- reifyTypes types_only
-           ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
-           ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys
-           ; mb_sig <-
-               -- See "Wrinkle: data family instances with return kinds" in
-               -- Note [Reified instances and explicit kind signatures]
-               if (null cons || isGadtSyntaxTyCon rep_tc)
-                     && tyConAppNeedsKindSig False fam_tc (length ee_lhs)
-               then do { let full_kind = typeKind (mkTyConApp fam_tc ee_lhs)
-                       ; th_full_kind <- reifyKind full_kind
-                       ; pure $ Just th_full_kind }
-               else pure Nothing
-           ; return $
-               if isNewTyCon rep_tc
-               then TH.NewtypeInstD [] th_tvs lhs_type mb_sig (head cons) []
-               else TH.DataInstD    [] th_tvs lhs_type mb_sig       cons  []
-           }
-
-------------------------------
-reifyType :: TyCoRep.Type -> TcM TH.Type
--- Monadic only because of failure
-reifyType ty                | tcIsLiftedTypeKind ty = return TH.StarT
-  -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it
-  -- with Constraint (#14869).
-reifyType ty@(ForAllTy (Bndr _ argf) _)
-                            = reify_for_all argf ty
-reifyType (LitTy t)         = do { r <- reifyTyLit t; return (TH.LitT r) }
-reifyType (TyVarTy tv)      = return (TH.VarT (reifyName tv))
-reifyType (TyConApp tc tys) = reify_tc_app tc tys   -- Do not expand type synonyms here
-reifyType ty@(AppTy {})     = do
-  let (ty_head, ty_args) = splitAppTys ty
-  ty_head' <- reifyType ty_head
-  ty_args' <- reifyTypes (filter_out_invisible_args ty_head ty_args)
-  pure $ mkThAppTs ty_head' ty_args'
-  where
-    -- Make sure to filter out any invisible arguments. For instance, if you
-    -- reify the following:
-    --
-    --   newtype T (f :: forall a. a -> Type) = MkT (f Bool)
-    --
-    -- Then you should receive back `f Bool`, not `f Type Bool`, since the
-    -- `Type` argument is invisible (#15792).
-    filter_out_invisible_args :: Type -> [Type] -> [Type]
-    filter_out_invisible_args ty_head ty_args =
-      filterByList (map isVisibleForAllTyFlag $ appTyForAllTyFlags ty_head ty_args)
-                   ty_args
-reifyType ty@(FunTy { ft_af = af, ft_mult = ManyTy, ft_arg = t1, ft_res = t2 })
-  | isInvisibleFunArg af = reify_for_all Inferred ty  -- Types like ((?x::Int) => Char -> Char)
-  | otherwise            = do { [r1,r2] <- reifyTypes [t1,t2]
-                              ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
-reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 })
-  | isInvisibleFunArg af = noTH LinearInvisibleArgument ty
-  | otherwise            = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2]
-                              ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) }
-reifyType (CastTy t _)      = reifyType t -- Casts are ignored in TH
-reifyType ty@(CoercionTy {})= noTH CoercionsInTypes ty
-
-reify_for_all :: TyCoRep.ForAllTyFlag -> TyCoRep.Type -> TcM TH.Type
--- Arg of reify_for_all is always ForAllTy or a predicate FunTy
-reify_for_all argf ty
-  | isVisibleForAllTyFlag argf
-  = do let (req_bndrs, phi) = tcSplitForAllReqTVBinders ty
-       tvbndrs' <- reifyTyVarBndrs req_bndrs
-       phi' <- reifyType phi
-       pure $ TH.ForallVisT tvbndrs' phi'
-  | otherwise
-  = do let (inv_bndrs, phi) = tcSplitForAllInvisTVBinders ty
-       tvbndrs' <- reifyTyVarBndrs inv_bndrs
-       let (cxt, tau) = tcSplitPhiTy phi
-       cxt' <- reifyCxt cxt
-       tau' <- reifyType tau
-       pure $ TH.ForallT tvbndrs' cxt' tau'
-
-reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit
-reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)
-reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
-reifyTyLit (CharTyLit c) = return (TH.CharTyLit c)
-
-reifyTypes :: [Type] -> TcM [TH.Type]
-reifyTypes = mapM reifyType
-
-reifyPatSynType
-  :: ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Scaled Type], Type) -> TcM TH.Type
--- reifies a pattern synonym's type and returns its *complete* type
--- signature; see Note [Pattern synonym type signatures and Template
--- Haskell] in GHC.ThToHs
-reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy)
-  = do { univTyVars' <- reifyTyVarBndrs univTyVars
-       ; req'        <- reifyCxt req
-       ; exTyVars'   <- reifyTyVarBndrs exTyVars
-       ; prov'       <- reifyCxt prov
-       ; tau'        <- reifyType (mkScaledFunTys argTys resTy)
-       ; return $ TH.ForallT univTyVars' req'
-                $ TH.ForallT exTyVars' prov' tau' }
-
-reifyKind :: Kind -> TcM TH.Kind
-reifyKind = reifyType
-
-reifyCxt :: [PredType] -> TcM [TH.Pred]
-reifyCxt   = mapM reifyType
-
-reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
-reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
-
-class ReifyFlag flag flag' | flag -> flag' where
-    reifyFlag :: flag -> flag'
-
-instance ReifyFlag () () where
-    reifyFlag () = ()
-
-instance ReifyFlag Specificity TH.Specificity where
-    reifyFlag SpecifiedSpec = TH.SpecifiedSpec
-    reifyFlag InferredSpec  = TH.InferredSpec
-
-reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr ()]
-reifyTyVars = reifyTyVarBndrs . map mk_bndr
-  where
-    mk_bndr tv = Bndr tv ()
-
-reifyTyVarBndrs :: ReifyFlag flag flag'
-                => [VarBndr TyVar flag] -> TcM [TH.TyVarBndr flag']
-reifyTyVarBndrs = mapM reify_tvbndr
-  where
-    -- even if the kind is *, we need to include a kind annotation,
-    -- in case a poly-kind would be inferred without the annotation.
-    -- See #8953 or test th/T8953
-    reify_tvbndr (Bndr tv fl) = TH.KindedTV (reifyName tv)
-                                            (reifyFlag fl)
-                                            <$> reifyKind (tyVarKind tv)
-
-reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr ()])
-reifyTyVarsToMaybe []  = pure Nothing
-reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys
-
-reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type
-reify_tc_app tc tys
-  = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys)
-       ; maybe_sig_t (mkThAppTs r_tc tys') }
-  where
-    arity       = tyConArity tc
-
-    r_tc | isUnboxedSumTyCon tc           = TH.UnboxedSumT (arity `div` 2)
-         | isUnboxedTupleTyCon tc         = TH.UnboxedTupleT (arity `div` 2)
-         | isPromotedTupleTyCon tc        = TH.PromotedTupleT (arity `div` 2)
-             -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
-         | isTupleTyCon tc                = if isPromotedDataCon tc
-                                            then TH.PromotedTupleT arity
-                                            else TH.TupleT arity
-         | tc `hasKey` constraintKindTyConKey
-                                          = TH.ConstraintT
-         | tc `hasKey` unrestrictedFunTyConKey = TH.ArrowT
-         | tc `hasKey` listTyConKey       = TH.ListT
-         | tc `hasKey` nilDataConKey      = TH.PromotedNilT
-         | tc `hasKey` consDataConKey     = TH.PromotedConsT
-         | tc `hasKey` heqTyConKey        = TH.EqualityT
-         | tc `hasKey` eqPrimTyConKey     = TH.EqualityT
-         | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon)
-         | isPromotedDataCon tc           = TH.PromotedT (reifyName tc)
-         | otherwise                      = TH.ConT (reifyName tc)
-
-    -- See Note [When does a tycon application need an explicit kind
-    -- signature?] in GHC.Core.TyCo.Rep
-    maybe_sig_t th_type
-      | tyConAppNeedsKindSig
-          False -- We don't reify types using visible kind applications, so
-                -- don't count specified binders as contributing towards
-                -- injective positions in the kind of the tycon.
-          tc (length tys)
-      = do { let full_kind = typeKind (mkTyConApp tc tys)
-           ; th_full_kind <- reifyKind full_kind
-           ; return (TH.SigT th_type th_full_kind) }
-      | otherwise
-      = return th_type
-
-------------------------------
-reifyName :: NamedThing n => n -> TH.Name
-reifyName thing
-  | isExternalName name
-              = mk_varg pkg_str mod_str occ_str
-  | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name))
-        -- Many of the things we reify have local bindings, and
-        -- NameL's aren't supposed to appear in binding positions, so
-        -- we use NameU.  When/if we start to reify nested things, that
-        -- have free variables, we may need to generate NameL's for them.
-  where
-    name    = getName thing
-    mod     = assert (isExternalName name) $ nameModule name
-    pkg_str = unitString (moduleUnit mod)
-    mod_str = moduleNameString (moduleName mod)
-    occ_str = occNameString occ
-    occ     = nameOccName name
-    mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
-            | OccName.isVarOcc  occ = TH.mkNameG_v
-            | OccName.isTcOcc   occ = TH.mkNameG_tc
-            | otherwise             = pprPanic "reifyName" (ppr name)
-
--- See Note [Reifying field labels]
-reifyFieldLabel :: FieldLabel -> TH.Name
-reifyFieldLabel fl
-  | flIsOverloaded fl
-              = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str))
-  | otherwise = TH.mkNameG_v pkg_str mod_str occ_str
-  where
-    name    = flSelector fl
-    mod     = assert (isExternalName name) $ nameModule name
-    pkg_str = unitString (moduleUnit mod)
-    mod_str = moduleNameString (moduleName mod)
-    occ_str = unpackFS (field_label $ flLabel fl)
-
-reifySelector :: Id -> TyCon -> TH.Name
-reifySelector id tc
-  = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of
-      Just fl -> reifyFieldLabel fl
-      Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc)
-
-------------------------------
-reifyFixity :: Name -> TcM (Maybe TH.Fixity)
-reifyFixity name
-  = do { (found, fix) <- lookupFixityRn_help name
-       ; return (if found then Just (conv_fix fix) else Nothing) }
-    where
-      conv_fix (Hs.Fixity _ i d) = TH.Fixity i (conv_dir d)
-      conv_dir Hs.InfixR = TH.InfixR
-      conv_dir Hs.InfixL = TH.InfixL
-      conv_dir Hs.InfixN = TH.InfixN
-
-reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness
-reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness
-reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack
-reifyUnpackedness SrcUnpack   = TH.SourceUnpack
-
-reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness
-reifyStrictness NoSrcStrict = TH.NoSourceStrictness
-reifyStrictness SrcStrict   = TH.SourceStrict
-reifyStrictness SrcLazy     = TH.SourceLazy
-
-reifySourceBang :: DataCon.HsSrcBang
-                -> (TH.SourceUnpackedness, TH.SourceStrictness)
-reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s)
-
-reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness
-reifyDecidedStrictness HsLazy     = TH.DecidedLazy
-reifyDecidedStrictness HsStrict   = TH.DecidedStrict
-reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack
-
-reifyTypeOfThing :: TH.Name -> TcM TH.Type
-reifyTypeOfThing th_name = do
-  thing <- getThing th_name
-  case thing of
-    AGlobal (AnId id) -> reifyType (idType id)
-    AGlobal (ATyCon tc) -> reifyKind (tyConKind tc)
-    AGlobal (AConLike (RealDataCon dc)) ->
-      reifyType (idType (dataConWrapId dc))
-    AGlobal (AConLike (PatSynCon ps)) ->
-      reifyPatSynType (patSynSigBndr ps)
-    ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType
-    ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType
-    -- Impossible cases, supposedly:
-    AGlobal (ACoAxiom _) -> panic "reifyTypeOfThing: ACoAxiom"
-    ATcTyCon _ -> panic "reifyTypeOfThing: ATcTyCon"
-    APromotionErr _ -> panic "reifyTypeOfThing: APromotionErr"
-
-------------------------------
-lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
-lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
-lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))
-  = return $ ModuleTarget $
-    mkModule (stringToUnit $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
-
-reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]
-reifyAnnotations th_name
-  = do { name <- lookupThAnnLookup th_name
-       ; topEnv <- getTopEnv
-       ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
-       ; tcg <- getGblEnv
-       ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name
-       ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name
-       ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
-
-------------------------------
-modToTHMod :: Module -> TH.Module
-modToTHMod m = TH.Module (TH.PkgName $ unitString  $ moduleUnit m)
-                         (TH.ModName $ moduleNameString $ moduleName m)
-
-reifyModule :: TH.Module -> TcM TH.ModuleInfo
-reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
-  this_mod <- getModule
-  let reifMod = mkModule (stringToUnit pkgString) (mkModuleName mString)
-  if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod
-    where
-      reifyThisModule = do
-        usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports
-        return $ TH.ModuleInfo usages
-
-      reifyFromIface reifMod = do
-        iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod
-        let usages = [modToTHMod m | usage <- mi_usages iface,
-                                     Just m <- [usageToModule (moduleUnit reifMod) usage] ]
-        return $ TH.ModuleInfo usages
-
-      usageToModule :: Unit -> Usage -> Maybe Module
-      usageToModule _ (UsageFile {}) = Nothing
-      usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
-      usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m
-      usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m
-      usageToModule this_pkg (UsageHomeModuleInterface { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
-
-------------------------------
-mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
-mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys
-
-noTH :: UnrepresentableTypeDescr -> Type -> TcM a
-noTH s d = failWithTc $ TcRnCannotRepresentType s d
-
-ppr_th :: TH.Ppr a => a -> SDoc
-ppr_th x = text (TH.pprint x)
-
-{-
-Note [Reifying field labels]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When reifying a datatype declared with DuplicateRecordFields enabled, we want
-the reified names of the fields to be labels rather than selector functions.
-That is, we want (reify ''T) and (reify 'foo) to produce
-
-    data T = MkT { foo :: Int }
-    foo :: T -> Int
-
-rather than
-
-    data T = MkT { $sel:foo:MkT :: Int }
-    $sel:foo:MkT :: T -> Int
-
-because otherwise TH code that uses the field names as strings will silently do
-the wrong thing.  Thus we use the field label (e.g. foo) as the OccName, rather
-than the selector (e.g. $sel:foo:MkT).  Since the Orig name M.foo isn't in the
-environment, NameG can't be used to represent such fields.  Instead,
-reifyFieldLabel uses NameQ.
-
-However, this means that extracting the field name from the output of reify, and
-trying to reify it again, may fail with an ambiguity error if there are multiple
-such fields defined in the module (see the test case
-overloadedrecflds/should_fail/T11103.hs).  The "proper" fix requires changes to
-the TH AST to make it able to represent duplicate record fields.
--}
-
-tcGetInterp :: TcM Interp
-tcGetInterp = do
-   hsc_env <- getTopEnv
-   case hsc_interp hsc_env of
-      Nothing -> liftIO $ throwIO (InstallationError "Template haskell requires a target code interpreter")
-      Just i  -> pure i
diff --git a/compiler/GHC/Tc/Gen/Splice.hs-boot b/compiler/GHC/Tc/Gen/Splice.hs-boot
deleted file mode 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs-boot
+++ /dev/null
@@ -1,45 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-
-module GHC.Tc.Gen.Splice where
-
-import GHC.Prelude
-import GHC.Types.Name
-import GHC.Hs.Expr ( PendingRnSplice, DelayedSplice )
-import GHC.Tc.Types( TcM , SpliceType )
-import GHC.Tc.Utils.TcType   ( ExpRhoType )
-import GHC.Types.Annotations ( Annotation, CoreAnnTarget )
-import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc )
-
-import GHC.Hs ( HsQuote, HsExpr, LHsExpr, LHsType, LPat, LHsDecl, ThModFinalizers )
-import qualified Language.Haskell.TH as TH
-
-tcTypedSplice :: Name
-              -> LHsExpr GhcRn
-              -> ExpRhoType
-              -> TcM (HsExpr GhcTc)
-
-tcTypedBracket :: HsExpr GhcRn
-               -> LHsExpr GhcRn
-               -> ExpRhoType
-               -> TcM (HsExpr GhcTc)
-tcUntypedBracket :: HsExpr GhcRn
-                 -> HsQuote GhcRn
-                 -> [PendingRnSplice]
-                 -> ExpRhoType
-                 -> TcM (HsExpr GhcTc)
-
-runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
-
-runAnnotation     :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
-
-tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
-
-runMetaE :: LHsExpr GhcTc -> TcM (LHsExpr GhcPs)
-runMetaP :: LHsExpr GhcTc -> TcM (LPat GhcPs)
-runMetaT :: LHsExpr GhcTc -> TcM (LHsType GhcPs)
-runMetaD :: LHsExpr GhcTc -> TcM [LHsDecl GhcPs]
-
-lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
-runQuasi :: TH.Q a -> TcM a
-runRemoteModFinalizers :: ThModFinalizers -> TcM ()
-finishTH :: TcM ()
diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ /dev/null
@@ -1,986 +0,0 @@
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module GHC.Tc.Instance.Class (
-     matchGlobalInst,
-     ClsInstResult(..),
-     InstanceWhat(..), safeOverlap, instanceReturnsDictCon,
-     AssocInstInfo(..), isNotAssociated,
-  ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-
-import GHC.Core.TyCo.Rep
-
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.Instantiate(instDFunType, tcInstType)
-import GHC.Tc.Instance.Typeable
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )
-import GHC.Rename.Env( addUsedGRE )
-
-import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim
-import GHC.Builtin.Names
-
-import GHC.Types.FieldLabel
-import GHC.Types.Name.Reader( lookupGRE_FieldLabel, greMangledName )
-import GHC.Types.SafeHaskell
-import GHC.Types.Name   ( Name, pprDefinedAt )
-import GHC.Types.Var.Env ( VarEnv )
-import GHC.Types.Id
-import GHC.Types.Id.Make ( nospecId )
-import GHC.Types.Var
-
-import GHC.Core.Predicate
-import GHC.Core.Coercion
-import GHC.Core.InstEnv
-import GHC.Core.Type
-import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams )
-import GHC.Core.DataCon
-import GHC.Core.TyCon
-import GHC.Core.Class
-
-import GHC.Core ( Expr(Var, App, Cast, Type) )
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Misc( splitAtList, fstOf3 )
-import GHC.Data.FastString
-
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-{- *******************************************************************
-*                                                                    *
-              A helper for associated types within
-              class instance declarations
-*                                                                    *
-**********************************************************************-}
-
--- | Extra information about the parent instance declaration, needed
--- when type-checking associated types. The 'Class' is the enclosing
--- class, the [TyVar] are the /scoped/ type variable of the instance decl.
--- The @VarEnv Type@ maps class variables to their instance types.
-data AssocInstInfo
-  = NotAssociated
-  | InClsInst { ai_class    :: Class
-              , ai_tyvars   :: [TyVar]      -- ^ The /scoped/ tyvars of the instance
-                                            -- Why scoped?  See bind_me in
-                                            -- 'GHC.Tc.Validity.checkConsistentFamInst'
-              , ai_inst_env :: VarEnv Type  -- ^ Maps /class/ tyvars to their instance types
-                -- See Note [Matching in the consistent-instantiation check]
-    }
-
-isNotAssociated :: AssocInstInfo -> Bool
-isNotAssociated (NotAssociated {}) = True
-isNotAssociated (InClsInst {})     = False
-
-
-{- *******************************************************************
-*                                                                    *
-                       Class lookup
-*                                                                    *
-**********************************************************************-}
-
--- | Indicates if Instance met the Safe Haskell overlapping instances safety
--- check.
---
--- See Note [Safe Haskell Overlapping Instances] in GHC.Tc.Solver
--- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver
-type SafeOverlapping = Bool
-
-data ClsInstResult
-  = NoInstance   -- Definitely no instance
-
-  | OneInst { cir_new_theta :: [TcPredType]
-            , cir_mk_ev     :: [EvExpr] -> EvTerm
-            , cir_what      :: InstanceWhat }
-
-  | NotSure      -- Multiple matches and/or one or more unifiers
-
-data InstanceWhat  -- How did we solve this constraint?
-  = BuiltinEqInstance    -- Built-in solver for (t1 ~ t2), (t1 ~~ t2), Coercible t1 t2
-                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]
-
-  | BuiltinTypeableInstance TyCon   -- Built-in solver for Typeable (T t1 .. tn)
-                         -- See Note [Well-staged instance evidence]
-
-  | BuiltinInstance      -- Built-in solver for (C t1 .. tn) where C is
-                         --   KnownNat, .. etc (classes with no top-level evidence)
-
-  | LocalInstance        -- Solved by a quantified constraint
-                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]
-
-  | TopLevInstance       -- Solved by a top-level instance decl
-      { iw_dfun_id   :: DFunId
-      , iw_safe_over :: SafeOverlapping }
-
-instance Outputable ClsInstResult where
-  ppr NoInstance = text "NoInstance"
-  ppr NotSure    = text "NotSure"
-  ppr (OneInst { cir_new_theta = ev
-               , cir_what = what })
-    = text "OneInst" <+> vcat [ppr ev, ppr what]
-
-instance Outputable InstanceWhat where
-  ppr BuiltinInstance   = text "a built-in instance"
-  ppr BuiltinTypeableInstance {} = text "a built-in typeable instance"
-  ppr BuiltinEqInstance = text "a built-in equality instance"
-  ppr LocalInstance     = text "a locally-quantified instance"
-  ppr (TopLevInstance { iw_dfun_id = dfun })
-      = hang (text "instance" <+> pprSigmaType (idType dfun))
-           2 (text "--" <+> pprDefinedAt (idName dfun))
-
-safeOverlap :: InstanceWhat -> Bool
-safeOverlap (TopLevInstance { iw_safe_over = so }) = so
-safeOverlap _                                      = True
-
-instanceReturnsDictCon :: InstanceWhat -> Bool
--- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet
-instanceReturnsDictCon (TopLevInstance {}) = True
-instanceReturnsDictCon BuiltinInstance     = True
-instanceReturnsDictCon BuiltinTypeableInstance {} = True
-instanceReturnsDictCon BuiltinEqInstance   = False
-instanceReturnsDictCon LocalInstance       = False
-
-matchGlobalInst :: DynFlags
-                -> Bool      -- True <=> caller is the short-cut solver
-                             -- See Note [Shortcut solving: overlap]
-                -> Class -> [Type] -> TcM ClsInstResult
-matchGlobalInst dflags short_cut clas tys
-  | cls_name == knownNatClassName     = matchKnownNat    dflags short_cut clas tys
-  | cls_name == knownSymbolClassName  = matchKnownSymbol dflags short_cut clas tys
-  | cls_name == knownCharClassName    = matchKnownChar   dflags short_cut clas tys
-  | isCTupleClass clas                = matchCTuple                       clas tys
-  | cls_name == typeableClassName     = matchTypeable                     clas tys
-  | cls_name == withDictClassName     = matchWithDict                          tys
-  | clas `hasKey` heqTyConKey         = matchHeteroEquality                    tys
-  | clas `hasKey` eqTyConKey          = matchHomoEquality                      tys
-  | clas `hasKey` coercibleTyConKey   = matchCoercible                         tys
-  | cls_name == hasFieldClassName     = matchHasField    dflags short_cut clas tys
-  | otherwise                         = matchInstEnv     dflags short_cut clas tys
-  where
-    cls_name = className clas
-
-
-{- ********************************************************************
-*                                                                     *
-                   Looking in the instance environment
-*                                                                     *
-***********************************************************************-}
-
-
-matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
-matchInstEnv dflags short_cut_solver clas tys
-   = do { instEnvs <- tcGetInstEnvs
-        ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy]
-              (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys
-              safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps)
-        ; traceTc "matchInstEnv" $
-            vcat [ text "goal:" <+> ppr clas <+> ppr tys
-                 , text "matches:" <+> ppr matches
-                 , text "unify:" <+> ppr unify ]
-        ; case (matches, unify, safeHaskFail) of
-
-            -- Nothing matches
-            ([], NoUnifiers, _)
-                -> do { traceTc "matchClass not matching" (ppr pred $$ ppr (ie_local instEnvs))
-                      ; return NoInstance }
-
-            -- A single match (& no safe haskell failure)
-            ([(ispec, inst_tys)], NoUnifiers, False)
-                | short_cut_solver      -- Called from the short-cut solver
-                , isOverlappable ispec
-                -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT
-                -- then don't let the short-cut solver choose it, because a
-                -- later instance might overlap it.  #14434 is an example
-                -- See Note [Shortcut solving: overlap]
-                -> do { traceTc "matchClass: ignoring overlappable" (ppr pred)
-                      ; return NotSure }
-
-                | otherwise
-                -> do { let dfun_id = instanceDFunId ispec
-                      ; traceTc "matchClass success" $
-                        vcat [text "dict" <+> ppr pred,
-                              text "witness" <+> ppr dfun_id
-                                             <+> ppr (idType dfun_id) ]
-                                -- Record that this dfun is needed
-                      ; match_one (null unsafeOverlaps) dfun_id inst_tys }
-
-            -- More than one matches (or Safe Haskell fail!). Defer any
-            -- reactions of a multitude until we learn more about the reagent
-            _   -> do { traceTc "matchClass multiple matches, deferring choice" $
-                        vcat [text "dict" <+> ppr pred,
-                              text "matches" <+> ppr matches]
-                      ; return NotSure } }
-   where
-     pred = mkClassPred clas tys
-
-match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcM ClsInstResult
-             -- See Note [DFunInstType: instantiating types] in GHC.Core.InstEnv
-match_one so dfun_id mb_inst_tys
-  = do { traceTc "match_one" (ppr dfun_id $$ ppr mb_inst_tys)
-       ; (tys, theta) <- instDFunType dfun_id mb_inst_tys
-       ; traceTc "match_one 2" (ppr dfun_id $$ ppr tys $$ ppr theta)
-       ; return $ OneInst { cir_new_theta = theta
-                          , cir_mk_ev     = evDFunApp dfun_id tys
-                          , cir_what      = TopLevInstance { iw_dfun_id = dfun_id
-                                                           , iw_safe_over = so } } }
-
-
-{- Note [Shortcut solving: overlap]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-  instance {-# OVERLAPPABLE #-} C a where ...
-and we are typechecking
-  f :: C a => a -> a
-  f = e  -- Gives rise to [W] C a
-
-We don't want to solve the wanted constraint with the overlappable
-instance; rather we want to use the supplied (C a)! That was the whole
-point of it being overlappable!  #14434 wwas an example.
-
-Alas even if the instance has no overlap flag, thus
-  instance C a where ...
-there is nothing to stop it being overlapped. GHC provides no way to
-declare an instance as "final" so it can't be overlapped.  But really
-only final instances are OK for short-cut solving.  Sigh. #15135
-was a puzzling example.
--}
-
-
-{- ********************************************************************
-*                                                                     *
-                   Class lookup for CTuples
-*                                                                     *
-***********************************************************************-}
-
-matchCTuple :: Class -> [Type] -> TcM ClsInstResult
-matchCTuple clas tys   -- (isCTupleClass clas) holds
-  = return (OneInst { cir_new_theta = tys
-                    , cir_mk_ev     = tuple_ev
-                    , cir_what      = BuiltinInstance })
-            -- The dfun *is* the data constructor!
-  where
-     data_con = tyConSingleDataCon (classTyCon clas)
-     tuple_ev = evDFunApp (dataConWrapId data_con) tys
-
-{- ********************************************************************
-*                                                                     *
-                   Class lookup for Literals
-*                                                                     *
-***********************************************************************-}
-
-{-
-Note [KnownNat & KnownSymbol and EvLit]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A part of the type-level literals implementation are the classes
-"KnownNat" and "KnownSymbol", which provide a "smart" constructor for
-defining singleton values.  Here is the key stuff from GHC.TypeNats
-
-  class KnownNat (n :: Nat) where
-    natSing :: SNat n
-
-  newtype SNat (n :: Nat) = SNat Natural
-
-Conceptually, this class has infinitely many instances:
-
-  instance KnownNat 0       where natSing = SNat 0
-  instance KnownNat 1       where natSing = SNat 1
-  instance KnownNat 2       where natSing = SNat 2
-  ...
-
-In practice, we solve `KnownNat` predicates in the type-checker
-(see GHC.Tc.Solver.Interact) because we can't have infinitely many instances.
-The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`.
-
-We make the following assumptions about dictionaries in GHC:
-  1. The "dictionary" for classes with a single method---like `KnownNat`---is
-     a newtype for the type of the method, so using a evidence amounts
-     to a coercion, and
-  2. Newtypes use the same representation as their definition types.
-
-So, the evidence for `KnownNat` is just a value of the representation type,
-wrapped in two newtype constructors: one to make it into a `SNat` value,
-and another to make it into a `KnownNat` dictionary.
-
-Also note that `natSing` and `SNat` are never actually exposed from the
-library---they are just an implementation detail.  Instead, users see
-a more convenient function, defined in terms of `natSing`:
-
-  natVal :: KnownNat n => proxy n -> Natural
-
-The reason we don't use this directly in the class is that it is simpler
-and more efficient to pass around a Natural rather than an entire function,
-especially when the `KnownNat` evidence is packaged up in an existential.
-
-The story for kind `Symbol` is analogous:
-  * class KnownSymbol
-  * newtype SSymbol
-  * Evidence: a Core literal (e.g. mkNaturalExpr)
-
-
-Note [Fabricating Evidence for Literals in Backpack]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Let `T` be a type of kind `Nat`. When solving for a purported instance
-of `KnownNat T`, ghc tries to resolve the type `T` to an integer `n`,
-in which case the evidence `EvLit (EvNum n)` is generated on the
-fly. It might appear that this is sufficient as users cannot define
-their own instances of `KnownNat`. However, for backpack module this
-would not work (see issue #15379). Consider the signature `Abstract`
-
-> signature Abstract where
->   data T :: Nat
->   instance KnownNat T
-
-and a module `Util` that depends on it:
-
-> module Util where
->  import Abstract
->  printT :: IO ()
->  printT = do print $ natVal (Proxy :: Proxy T)
-
-Clearly, we need to "use" the dictionary associated with `KnownNat T`
-in the module `Util`, but it is too early for the compiler to produce
-a real dictionary as we still have not fixed what `T` is. Only when we
-mixin a concrete module
-
-> module Concrete where
->   type T = 42
-
-do we really get hold of the underlying integer. So the strategy that
-we follow is the following
-
-1. If T is indeed available as a type alias for an integer constant,
-   generate the dictionary on the fly, failing which
-
-2. Look up the type class environment for the evidence.
-
-Finally actual code gets generate for Util only when a module like
-Concrete gets "mixed-in" in place of the signature Abstract. As a
-result all things, including the typeclass instances, in Concrete gets
-reexported. So `KnownNat` gets resolved the normal way post-Backpack.
-
-A similar generation works for `KnownSymbol` as well
-
--}
-
-matchKnownNat :: DynFlags
-              -> Bool      -- True <=> caller is the short-cut solver
-                           -- See Note [Shortcut solving: overlap]
-              -> Class -> [Type] -> TcM ClsInstResult
-matchKnownNat dflags _ clas [ty]     -- clas = KnownNat
-  | Just n <- isNumLitTy ty  = makeLitDict clas ty (mkNaturalExpr (targetPlatform dflags) n)
-matchKnownNat df sc clas tys = matchInstEnv df sc clas tys
- -- See Note [Fabricating Evidence for Literals in Backpack] for why
- -- this lookup into the instance environment is required.
-
-matchKnownSymbol :: DynFlags
-                 -> Bool      -- True <=> caller is the short-cut solver
-                              -- See Note [Shortcut solving: overlap]
-                 -> Class -> [Type] -> TcM ClsInstResult
-matchKnownSymbol _ _ clas [ty]  -- clas = KnownSymbol
-  | Just s <- isStrLitTy ty = do
-        et <- mkStringExprFS s
-        makeLitDict clas ty et
-matchKnownSymbol df sc clas tys = matchInstEnv df sc clas tys
- -- See Note [Fabricating Evidence for Literals in Backpack] for why
- -- this lookup into the instance environment is required.
-
-matchKnownChar :: DynFlags
-                 -> Bool      -- True <=> caller is the short-cut solver
-                              -- See Note [Shortcut solving: overlap]
-                 -> Class -> [Type] -> TcM ClsInstResult
-matchKnownChar _ _ clas [ty]  -- clas = KnownChar
-  | Just s <- isCharLitTy ty = makeLitDict clas ty (mkCharExpr s)
-matchKnownChar df sc clas tys = matchInstEnv df sc clas tys
- -- See Note [Fabricating Evidence for Literals in Backpack] for why
- -- this lookup into the instance environment is required.
-
-makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult
--- makeLitDict adds a coercion that will convert the literal into a dictionary
--- of the appropriate type.  See Note [KnownNat & KnownSymbol and EvLit]
--- in GHC.Tc.Types.Evidence.  The coercion happens in 2 steps:
---
---     Integer -> SNat n     -- representation of literal to singleton
---     SNat n  -> KnownNat n -- singleton to dictionary
---
---     The process is mirrored for Symbols:
---     String    -> SSymbol n
---     SSymbol n -> KnownSymbol n
-makeLitDict clas ty et
-    | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]
-          -- co_dict :: KnownNat n ~ SNat n
-    , [ meth ]   <- classMethods clas
-    , Just tcRep <- tyConAppTyCon_maybe (classMethodTy meth)
-                    -- If the method type is forall n. KnownNat n => SNat n
-                    -- then tcRep is SNat
-    , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
-          -- SNat n ~ Integer
-    , let ev_tm = mkEvCast et (mkSymCo (mkTransCo co_dict co_rep))
-    = return $ OneInst { cir_new_theta = []
-                       , cir_mk_ev     = \_ -> ev_tm
-                       , cir_what      = BuiltinInstance }
-
-    | otherwise
-    = pprPanic "makeLitDict" $
-      text "Unexpected evidence for" <+> ppr (className clas)
-      $$ vcat (map (ppr . idType) (classMethods clas))
-
-{- ********************************************************************
-*                                                                     *
-                   Class lookup for WithDict
-*                                                                     *
-***********************************************************************-}
-
--- See Note [withDict]
-matchWithDict :: [Type] -> TcM ClsInstResult
-matchWithDict [cls, mty]
-    -- Check that cls is a class constraint `C t_1 ... t_n`, where
-    -- `dict_tc = C` and `dict_args = t_1 ... t_n`.
-  | Just (dict_tc, dict_args) <- tcSplitTyConApp_maybe cls
-    -- Check that C is a class of the form
-    -- `class C a_1 ... a_n where op :: meth_ty`
-    -- and in that case let
-    -- co :: C t1 ..tn ~R# inst_meth_ty
-  , Just (inst_meth_ty, co) <- tcInstNewTyCon_maybe dict_tc dict_args
-  = do { sv <- mkSysLocalM (fsLit "withDict_s") ManyTy mty
-       ; k  <- mkSysLocalM (fsLit "withDict_k") ManyTy (mkInvisFunTy cls openAlphaTy)
-
-       -- Given co2 : mty ~N# inst_meth_ty, construct the method of
-       -- the WithDict dictionary:
-       --
-       --   \@(r :: RuntimeRep) @(a :: TYPE r) (sv :: mty) (k :: cls => a) ->
-       --     nospec @(cls => a) k (sv |> (sub co ; sym co2))
-       --
-       -- where  nospec :: forall a. a -> a  ensures that the typeclass specialiser
-       -- doesn't attempt to common up this evidence term with other evidence terms
-       -- of the same type.
-       --
-       -- See (WD6) in Note [withDict], and Note [nospecId magic] in GHC.Types.Id.Make.
-       ; let evWithDict co2 =
-               mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $
-                 Var nospecId
-                   `App`
-                 (Type $ mkInvisFunTy cls openAlphaTy)
-                   `App`
-                 Var k
-                   `App`
-                 (Var sv `Cast` mkTransCo (mkSubCo co2) (mkSymCo co))
-
-       ; tc <- tcLookupTyCon withDictClassName
-       ; let Just withdict_data_con
-                 = tyConSingleDataCon_maybe tc    -- "Data constructor"
-                                                  -- for WithDict
-             mk_ev [c] = evDataConApp withdict_data_con
-                            [cls, mty] [evWithDict (evTermCoercion (EvExpr c))]
-             mk_ev e   = pprPanic "matchWithDict" (ppr e)
-
-       ; return $ OneInst { cir_new_theta = [mkPrimEqPred mty inst_meth_ty]
-                          , cir_mk_ev     = mk_ev
-                          , cir_what      = BuiltinInstance }
-       }
-
-matchWithDict _
-  = return NoInstance
-
-{-
-Note [withDict]
-~~~~~~~~~~~~~~~
-The class `WithDict` is defined as:
-
-    class WithDict cls meth where
-        withDict :: forall {rr :: RuntimeRep} (r :: TYPE rr). meth -> (cls => r) -> r
-
-This class is special, like `Typeable`: GHC automatically solves
-for instances of `WithDict`, users cannot write their own.
-
-It is used to implement a primitive that we cannot define in Haskell
-but we can write in Core.
-
-`WithDict` is used to create dictionaries for classes with a single method.
-Consider a class like this:
-
-   class C a where
-     f :: T a
-
-We can use `withDict` to cast values of type `T a` into dictionaries for `C a`.
-To do this, we can define a function like this in the library:
-
-  withT :: T a -> (C a => b) -> b
-  withT t k = withDict @(C a) @(T a) t k
-
-Here:
-
-* The `cls` in `withDict` is instantiated to `C a`.
-
-* The `meth` in `withDict` is instantiated to `T a`.
-  The definition of `T` itself is irrelevant, only that `C a` is a class
-  with a single method of type `T a`.
-
-* The `r` in `withDict` is instantiated to `b`.
-
-For any single-method class C:
-   class C a1 .. an where op :: meth_ty
-
-The solver will solve the constraint `WithDict (C t1 .. tn) mty`
-as if the following instance declaration existed:
-
-instance (mty ~# inst_meth_ty) => WithDict (C t1..tn) mty where
-  withDict = \@{rr} @(r :: TYPE rr) (sv :: mty) (k :: C t1..tn => r) ->
-    k (sv |> (sub co2 ; sym co))
-
-That is, it matches on the first (constraint) argument of C; if C is
-a single-method class, the instance "fires" and emits an equality
-constraint `mty ~ inst_meth_ty`, where `inst_meth_ty` is `meth_ty[ti/ai]`.
-The coercion `co2` witnesses the equality `mty ~ inst_meth_ty`.
-
-The coercion `co` is a newtype coercion that coerces from `C t1 ... tn`
-to `inst_meth_ty`.
-This coercion is guaranteed to exist by virtue of the fact that
-C is a class with exactly one method and no superclasses, so it
-is treated like a newtype when compiled to Core.
-
-The condition that `C` is a single-method class is implemented in the
-guards of matchWithDict's definition.
-If the conditions are not held, the rewriting will not fire,
-and we'll report an unsolved constraint.
-
-Some further observations about `withDict`:
-
-(WD1) The `cls` in the type of withDict must be explicitly instantiated with
-      visible type application, as invoking `withDict` would be ambiguous
-      otherwise.
-
-      For examples of how `withDict` is used in the `base` library, see `withSNat`
-      in GHC.TypeNats, as well as `withSChar` and `withSSymbol` in GHC.TypeLits.
-
-(WD2) The `r` is representation-polymorphic, to support things like
-      `withTypeable` in `Data.Typeable.Internal`.
-
-(WD3) As an alternative to `withDict`, one could define functions like `withT`
-      above in terms of `unsafeCoerce`. This is more error-prone, however.
-
-(WD4) In order to define things like `withKnownNat` below:
-
-        withKnownNat :: SNat n -> (KnownNat n => r) -> r
-
-      `withDict` needs to be instantiated with `Any`, like so:
-
-        withKnownNat = withDict @(KnownNat Any) @(SNat Any) @r
-
-      The use of `Any` is explained in Note [NOINLINE withSomeSNat] in
-      base:GHC.TypeNats.
-
-(WD5) In earlier implementations, `withDict` was implemented as an identifier
-      with special handling during either constant-folding or desugaring.
-      The current approach is more robust: previously, the type of `withDict`
-      did not have a type-class constraint and was overly polymorphic.
-      See #19915.
-
-(WD6) In fact, we desugar `withDict @cls @mty @{rr} @r` to
-
-         \@(r :: RuntimeRep) @(a :: TYPE r) (sv :: mty) (k :: cls => a) ->
-           nospec @(cls => a) k (sv |> (sub co2 ; sym co)))
-
-      That is, we cast the method using a coercion, and apply k to it.
-      However, we use the 'nospec' magicId (see Note [nospecId magic] in GHC.Types.Id.Make)
-      to ensure that the typeclass specialiser doesn't incorrectly common-up distinct
-      evidence terms. This is super important! Suppose we have calls
-
-          withDict A k
-          withDict B k
-
-      where k1, k2 :: C T -> blah.  If we desugared withDict naively, we'd get
-
-          k (A |> co1)
-          k (B |> co2)
-
-      and the Specialiser would assume that those arguments (of type `C T`) are
-      the same. It would then specialise `k` for that type, and then call the same,
-      specialised function from both call sites.  #21575 is a concrete case in point.
-
-      To avoid this, we need to stop the typeclass specialiser from seeing this
-      structure, by using nospec. This function is inlined only in CorePrep; crucially
-      this means that it still appears in interface files, so that the desugaring of
-      withDict remains opaque to the typeclass specialiser across modules.
-      This means the specialiser will always see instead:
-
-          nospec @(cls => a) k (A |> co1)
-          nospec @(cls => a) k (B |> co2)
-
-      Why does this work? Recall that nospec is not an overloaded function;
-      it has the type
-
-        nospec :: forall a. a -> a
-
-      This means that there is nothing for the specialiser to do with function calls
-      such as
-
-        nospec @(cls => a) k (A |> co)
-
-      as the specialiser only looks at calls of the form `f dict` for an
-      overloaded function `f` (e.g. with a type such as `f :: Eq a => ...`).
-
-      See test-case T21575b.
-
--}
-
-{- ********************************************************************
-*                                                                     *
-                   Class lookup for Typeable
-*                                                                     *
-***********************************************************************-}
-
--- | Assumes that we've checked that this is the 'Typeable' class,
--- and it was applied to the correct argument.
-matchTypeable :: Class -> [Type] -> TcM ClsInstResult
-matchTypeable clas [k,t]  -- clas = Typeable
-  -- Forall types: see Note [No Typeable for polytypes or qualified types]
-  | isForAllTy k = return NoInstance
-
-  -- Functions; but only with a visible argment
-  | Just (af,mult,arg,ret) <- splitFunTy_maybe t
-  = if isVisibleFunArg af
-    then doFunTy clas t mult arg ret
-    else return NoInstance
-      -- 'else' case: qualified types like (Num a => blah) are not typeable
-      -- see Note [No Typeable for polytypes or qualified types]
-
-  -- Now cases that do work
-  | k `eqType` naturalTy      = doTyLit knownNatClassName         t
-  | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName      t
-  | k `eqType` charTy         = doTyLit knownCharClassName        t
-
-  -- TyCon applied to its kind args
-  -- No special treatment of Type and Constraint; they get distinct TypeReps
-  -- see wrinkle (W4) of Note [Type and Constraint are not apart]
-  --     in GHC.Builtin.Types.Prim.
-  | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)]
-  , onlyNamedBndrsApplied tc ks            = doTyConApp clas t tc ks
-
-  | Just (f,kt)   <- splitAppTy_maybe t    = doTyApp    clas t f kt
-
-matchTypeable _ _ = return NoInstance
-
--- | Representation for a type @ty@ of the form @arg -> ret@.
-doFunTy :: Class -> Type -> Mult -> Type -> Type -> TcM ClsInstResult
-doFunTy clas ty mult arg_ty ret_ty
-  = return $ OneInst { cir_new_theta = preds
-                     , cir_mk_ev     = mk_ev
-                     , cir_what      = BuiltinInstance }
-  where
-    preds = map (mk_typeable_pred clas) [mult, arg_ty, ret_ty]
-    mk_ev [mult_ev, arg_ev, ret_ev] = evTypeable ty $
-                        EvTypeableTrFun (EvExpr mult_ev) (EvExpr arg_ev) (EvExpr ret_ev)
-    mk_ev _ = panic "GHC.Tc.Solver.Interact.doFunTy"
-
-
--- | Representation for type constructor applied to some kinds.
--- 'onlyNamedBndrsApplied' has ensured that this application results in a type
--- of monomorphic kind (e.g. all kind variables have been instantiated).
-doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult
-doTyConApp clas ty tc kind_args
-  | tyConIsTypeable tc
-  = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) kind_args
-                     , cir_mk_ev     = mk_ev
-                     , cir_what      = BuiltinTypeableInstance tc }
-  | otherwise
-  = return NoInstance
-  where
-    mk_ev kinds = evTypeable ty $ EvTypeableTyCon tc (map EvExpr kinds)
-
--- | Representation for TyCon applications of a concrete kind. We just use the
--- kind itself, but first we must make sure that we've instantiated all kind-
--- polymorphism, but no more.
-onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool
-onlyNamedBndrsApplied tc ks
- = all isNamedTyConBinder used_bndrs &&
-   not (any isNamedTyConBinder leftover_bndrs)
- where
-   bndrs                        = tyConBinders tc
-   (used_bndrs, leftover_bndrs) = splitAtList ks bndrs
-
-doTyApp :: Class -> Type -> Type -> KindOrType -> TcM ClsInstResult
--- Representation for an application of a type to a type-or-kind.
---  This may happen when the type expression starts with a type variable.
---  Example (ignoring kind parameter):
---    Typeable (f Int Char)                      -->
---    (Typeable (f Int), Typeable Char)          -->
---    (Typeable f, Typeable Int, Typeable Char)  --> (after some simp. steps)
---    Typeable f
-doTyApp clas ty f tk
-  | isForAllTy (typeKind f)
-  = return NoInstance -- We can't solve until we know the ctr.
-  | otherwise
-  = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) [f, tk]
-                     , cir_mk_ev     = mk_ev
-                     , cir_what      = BuiltinInstance }
-  where
-    mk_ev [t1,t2] = evTypeable ty $ EvTypeableTyApp (EvExpr t1) (EvExpr t2)
-    mk_ev _ = panic "doTyApp"
-
-
--- Emit a `Typeable` constraint for the given type.
-mk_typeable_pred :: Class -> Type -> PredType
-mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ]
-
-  -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal
-  -- we generate a sub-goal for the appropriate class.
-  -- See Note [Typeable for Nat and Symbol]
-doTyLit :: Name -> Type -> TcM ClsInstResult
-doTyLit kc t = do { kc_clas <- tcLookupClass kc
-                  ; let kc_pred    = mkClassPred kc_clas [ t ]
-                        mk_ev [ev] = evTypeable t $ EvTypeableTyLit (EvExpr ev)
-                        mk_ev _    = panic "doTyLit"
-                  ; return (OneInst { cir_new_theta = [kc_pred]
-                                    , cir_mk_ev     = mk_ev
-                                    , cir_what      = BuiltinInstance }) }
-
-{- Note [Typeable (T a b c)]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-For type applications we always decompose using binary application,
-via doTyApp (building a TrApp), until we get to a *kind* instantiation
-(building a TrTyCon).  We detect a pure kind instantiation using
-`onlyNamedBndrsApplied`.
-
-Example: Proxy :: forall k. k -> *
-
-  To solve Typeable (Proxy @(* -> *) Maybe) we
-
-  - First decompose with doTyApp (onlyNamedBndrsApplied is False)
-    to get (Typeable (Proxy @(* -> *))) and Typeable Maybe.
-    This step returns a TrApp.
-
-  - Then solve (Typeable (Proxy @(* -> *))) with doTyConApp
-    (onlyNamedBndrsApplied is True).
-    This step returns a TrTyCon
-
-  So the TypeRep we build is
-    TrApp (TrTyCon ("Proxy" @(*->*))) (TrTyCon "Maybe")
-
-Notice also that TYPE and CONSTRAINT are distinct so, in effect, we
-allow (Typeable TYPE) and (Typeable CONSTRAINT), giving disinct TypeReps.
-This is very important: we may want to get a TypeRep for a kind like
-   Type -> Constraint
-
-If we attempt to short-cut by solving it all at once, via
-doTyConApp
-
-(this note is sadly truncated FIXME)
-
-
-Note [No Typeable for polytypes or qualified types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not support impredicative typeable, such as
-   Typeable (forall a. a->a)
-   Typeable (Eq a => a -> a)
-   Typeable (() => Int)
-   Typeable (((),()) => Int)
-
-See #9858.  For forall's the case is clear: we simply don't have
-a TypeRep for them.  For qualified but not polymorphic types, like
-(Eq a => a -> a), things are murkier.  But:
-
- * We don't need a TypeRep for these things.  TypeReps are for
-   monotypes only.
-
- * Perhaps we could treat `=>` as another type constructor for `Typeable`
-   purposes, and thus support things like `Eq Int => Int`, however,
-   at the current state of affairs this would be an odd exception as
-   no other class works with impredicative types.
-   For now we leave it off, until we have a better story for impredicativity.
-
-
-Note [Typeable for Nat and Symbol]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We have special Typeable instances for Nat and Symbol.  Roughly we
-have this instance, implemented here by doTyLit:
-      instance KnownNat n => Typeable (n :: Nat) where
-         typeRep = typeNatTypeRep @n
-where
-   Data.Typeable.Internal.typeNatTypeRep :: KnownNat a => TypeRep a
-
-Ultimately typeNatTypeRep uses 'natSing' from KnownNat to get a
-runtime value 'n'; it turns it into a string with 'show' and uses
-that to whiz up a TypeRep TyCon for 'n', with mkTypeLitTyCon.
-See #10348.
-
-Because of this rule it's inadvisable (see #15322) to have a constraint
-    f :: (Typeable (n :: Nat)) => blah
-in a function signature; it gives rise to overlap problems just as
-if you'd written
-    f :: Eq [a] => blah
--}
-
-{- ********************************************************************
-*                                                                     *
-                   Class lookup for lifted equality
-*                                                                     *
-***********************************************************************-}
-
--- See also Note [The equality types story] in GHC.Builtin.Types.Prim
-matchHeteroEquality :: [Type] -> TcM ClsInstResult
--- Solves (t1 ~~ t2)
-matchHeteroEquality args
-  = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon args ]
-                    , cir_mk_ev     = evDataConApp heqDataCon args
-                    , cir_what      = BuiltinEqInstance })
-
-matchHomoEquality :: [Type] -> TcM ClsInstResult
--- Solves (t1 ~ t2)
-matchHomoEquality args@[k,t1,t2]
-  = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon [k,k,t1,t2] ]
-                    , cir_mk_ev     = evDataConApp eqDataCon args
-                    , cir_what      = BuiltinEqInstance })
-matchHomoEquality args = pprPanic "matchHomoEquality" (ppr args)
-
--- See also Note [The equality types story] in GHC.Builtin.Types.Prim
-matchCoercible :: [Type] -> TcM ClsInstResult
-matchCoercible args@[k, t1, t2]
-  = return (OneInst { cir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ]
-                    , cir_mk_ev     = evDataConApp coercibleDataCon args
-                    , cir_what      = BuiltinEqInstance })
-  where
-    args' = [k, k, t1, t2]
-matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args)
-
-{- ********************************************************************
-*                                                                     *
-              Class lookup for overloaded record fields
-*                                                                     *
-***********************************************************************-}
-
-{-
-Note [HasField instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-
-    data T y = MkT { foo :: [y] }
-
-and `foo` is in scope.  Then GHC will automatically solve a constraint like
-
-    HasField "foo" (T Int) b
-
-by emitting a new wanted
-
-    T alpha -> [alpha] ~# T Int -> b
-
-and building a HasField dictionary out of the selector function `foo`,
-appropriately cast.
-
-The HasField class is defined (in GHC.Records) thus:
-
-    class HasField (x :: k) r a | x r -> a where
-      getField :: r -> a
-
-Since this is a one-method class, it is represented as a newtype.
-Hence we can solve `HasField "foo" (T Int) b` by taking an expression
-of type `T Int -> b` and casting it using the newtype coercion.
-Note that
-
-    foo :: forall y . T y -> [y]
-
-so the expression we construct is
-
-    foo @alpha |> co
-
-where
-
-    co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b
-
-is built from
-
-    co1 :: (T alpha -> [alpha]) ~# (T Int -> b)
-
-which is the new wanted, and
-
-    co2 :: (T Int -> b) ~# HasField "foo" (T Int) b
-
-which can be derived from the newtype coercion.
-
-If `foo` is not in scope, or has a higher-rank or existentially
-quantified type, then the constraint is not solved automatically, but
-may be solved by a user-supplied HasField instance.  Similarly, if we
-encounter a HasField constraint where the field is not a literal
-string, or does not belong to the type, then we fall back on the
-normal constraint solver behaviour.
-
-
-Note [Unused name reporting and HasField]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When a HasField constraint is solved by the type-checker, we must record a use
-of the corresponding field name, as otherwise it might be reported as unused.
-See #19213.  We need to call keepAlive to add the name to the tcg_keep set,
-which accumulates names used by the constraint solver, as described by
-Note [Tracking unused binding and imports] in GHC.Tc.Types.
-
-We need to call addUsedGRE as well because there may be a deprecation warning on
-the field, which will be reported by addUsedGRE.  But calling addUsedGRE without
-keepAlive is not enough, because the field might be defined locally, and
-addUsedGRE extends tcg_used_gres with imported GREs only.
--}
-
--- See Note [HasField instances]
-matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
-matchHasField dflags short_cut clas tys
-  = do { fam_inst_envs <- tcGetFamInstEnvs
-       ; rdr_env       <- getGlobalRdrEnv
-       ; case tys of
-           -- We are matching HasField {k} x r a...
-           [_k_ty, x_ty, r_ty, a_ty]
-               -- x should be a literal string
-             | Just x <- isStrLitTy x_ty
-               -- r should be an applied type constructor
-             , Just (tc, args) <- tcSplitTyConApp_maybe r_ty
-               -- use representation tycon (if data family); it has the fields
-             , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)
-               -- x should be a field of r
-             , Just fl <- lookupTyConFieldLabel (FieldLabelString x) r_tc
-               -- the field selector should be in scope
-             , Just gre <- lookupGRE_FieldLabel rdr_env fl
-
-             -> do { sel_id <- tcLookupId (flSelector fl)
-                   ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id
-
-                         -- The first new wanted constraint equates the actual
-                         -- type of the selector with the type (r -> a) within
-                         -- the HasField x r a dictionary.  The preds will
-                         -- typically be empty, but if the datatype has a
-                         -- "stupid theta" then we have to include it here.
-                   ; let theta = mkPrimEqPred sel_ty (mkVisFunTyMany r_ty a_ty) : preds
-
-                         -- Use the equality proof to cast the selector Id to
-                         -- type (r -> a), then use the newtype coercion to cast
-                         -- it to a HasField dictionary.
-                         mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co
-                           where
-                             co = mkSubCo (evTermCoercion (EvExpr ev1))
-                                      `mkTransCo` mkSymCo co2
-                         mk_ev [] = panic "matchHasField.mk_ev"
-
-                         Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas)
-                                                              tys
-
-                         tvs = mkTyVarTys (map snd tv_prs)
-
-                     -- The selector must not be "naughty" (i.e. the field
-                     -- cannot have an existentially quantified type), and
-                     -- it must not be higher-rank.
-                   ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty
-                     then do { -- See Note [Unused name reporting and HasField]
-                               addUsedGRE True gre
-                             ; keepAlive (greMangledName gre)
-                             ; return OneInst { cir_new_theta = theta
-                                              , cir_mk_ev     = mk_ev
-                                              , cir_what      = BuiltinInstance } }
-                     else matchInstEnv dflags short_cut clas tys }
-
-           _ -> matchInstEnv dflags short_cut clas tys }
diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Instance/Family.hs
+++ /dev/null
@@ -1,1010 +0,0 @@
-{-# LANGUAGE GADTs, ViewPatterns #-}
-
--- | The @FamInst@ type: family instance heads
-module GHC.Tc.Instance.Family (
-        FamInstEnvs, tcGetFamInstEnvs,
-        checkFamInstConsistency, tcExtendLocalFamInstEnv,
-        tcLookupDataFamInst, tcLookupDataFamInst_maybe,
-        tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,
-        newFamInst,
-
-        -- * Injectivity
-        reportInjectivityErrors, reportConflictingInjectivityErrs
-    ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-import GHC.Driver.Env
-
-import GHC.Core.FamInstEnv
-import GHC.Core.InstEnv( roughMatchTcs )
-import GHC.Core.Coercion
-import GHC.Core.TyCon
-import GHC.Core.Coercion.Axiom
-import GHC.Core.DataCon ( dataConName )
-import GHC.Core.TyCo.Rep
-import GHC.Core.TyCo.FVs
-
-import GHC.Iface.Load
-
-import GHC.Tc.Errors.Types
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Instantiate( freshenTyVarBndrs, freshenCoVarBndrsX )
-import GHC.Tc.Utils.TcType
-
-import GHC.Unit.External
-import GHC.Unit.Module
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.ModDetails
-import GHC.Unit.Module.Deps
-import GHC.Unit.Home.ModInfo
-
-import GHC.Types.SrcLoc as SrcLoc
-import GHC.Types.Name.Reader
-import GHC.Types.Name
-import GHC.Types.Var.Set
-
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.FV
-
-import GHC.Data.Bag( Bag, unionBags, unitBag )
-import GHC.Data.Maybe
-
-import Control.Monad
-import Data.List.NonEmpty ( NonEmpty(..) )
-import qualified Data.List.NonEmpty as NE
-import Data.Function ( on )
-
-import qualified GHC.LanguageExtensions  as LangExt
-import GHC.Unit.Env (unitEnv_hpts)
-
-{- Note [The type family instance consistency story]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-To preserve type safety we must ensure that for any given module, all
-the type family instances used either in that module or in any module
-it directly or indirectly imports are consistent. For example, consider
-
-  module F where
-    type family F a
-
-  module A where
-    import F( F )
-    type instance F Int = Bool
-    f :: F Int -> Bool
-    f x = x
-
-  module B where
-    import F( F )
-    type instance F Int = Char
-    g :: Char -> F Int
-    g x = x
-
-  module Bad where
-    import A( f )
-    import B( g )
-    bad :: Char -> Int
-    bad c = f (g c)
-
-Even though module Bad never mentions the type family F at all, by
-combining the functions f and g that were type checked in contradictory
-type family instance environments, the function bad is able to coerce
-from one type to another. So when we type check Bad we must verify that
-the type family instances defined in module A are consistent with those
-defined in module B.
-
-How do we ensure that we maintain the necessary consistency?
-
-* Call a module which defines at least one type family instance a
-  "family instance module". This flag `mi_finsts` is recorded in the
-  interface file.
-
-* For every module we calculate the set of all of its direct and
-  indirect dependencies that are family instance modules. This list
-  `dep_finsts` is also recorded in the interface file so we can compute
-  this list for a module from the lists for its direct dependencies.
-
-* When type checking a module M we check consistency of all the type
-  family instances that are either provided by its `dep_finsts` or
-  defined in the module M itself. This is a pairwise check, i.e., for
-  every pair of instances we must check that they are consistent.
-
-  - For family instances coming from `dep_finsts`, this is checked in
-    checkFamInstConsistency, called from tcRnImports. See Note
-    [Checking family instance consistency] for details on this check
-    (and in particular how we avoid having to do all these checks for
-    every module we compile).
-
-  - That leaves checking the family instances defined in M itself
-    against instances defined in either M or its `dep_finsts`. This is
-    checked in `tcExtendLocalFamInstEnv'.
-
-There are four subtle points in this scheme which have not been
-addressed yet.
-
-* We have checked consistency of the family instances *defined* by M
-  or its imports, but this is not by definition the same thing as the
-  family instances *used* by M or its imports.  Specifically, we need to
-  ensure when we use a type family instance while compiling M that this
-  instance was really defined from either M or one of its imports,
-  rather than being an instance that we happened to know about from
-  reading an interface file in the course of compiling an unrelated
-  module. Otherwise, we'll end up with no record of the fact that M
-  depends on this family instance and type safety will be compromised.
-  See #13102.
-
-* It can also happen that M uses a function defined in another module
-  which is not transitively imported by M. Examples include the
-  desugaring of various overloaded constructs, and references inserted
-  by Template Haskell splices. If that function's definition makes use
-  of type family instances which are not checked against those visible
-  from M, type safety can again be compromised. See #13251.
-
-* When a module C imports a boot module B.hs-boot, we check that C's
-  type family instances are compatible with those visible from
-  B.hs-boot. However, C will eventually be linked against a different
-  module B.hs, which might define additional type family instances which
-  are inconsistent with C's. This can also lead to loss of type safety.
-  See #9562.
-
-* The call to checkFamConsistency for imported functions occurs very
-  early (in tcRnImports) and that causes problems if the imported
-  instances use type declared in the module being compiled.
-  See Note [Loading your own hi-boot file] in GHC.Iface.Load.
--}
-
-{-
-************************************************************************
-*                                                                      *
-                 Making a FamInst
-*                                                                      *
-************************************************************************
--}
-
--- All type variables in a FamInst must be fresh. This function
--- creates the fresh variables and applies the necessary substitution
--- It is defined here to avoid a dependency from FamInstEnv on the monad
--- code.
-
-newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst
--- Freshen the type variables of the FamInst branches
-newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc })
-  = do {
-         -- Freshen the type variables
-         (subst, tvs') <- freshenTyVarBndrs tvs
-       ; (subst, cvs') <- freshenCoVarBndrsX subst cvs
-       ; let lhs'     = substTys subst lhs
-             rhs'     = substTy  subst rhs
-
-       ; return (FamInst { fi_fam      = tyConName fam_tc
-                         , fi_flavor   = flavor
-                         , fi_tcs      = roughMatchTcs lhs
-                         , fi_tvs      = tvs'
-                         , fi_cvs      = cvs'
-                         , fi_tys      = lhs'
-                         , fi_rhs      = rhs'
-                         , fi_axiom    = axiom }) }
-  where
-    CoAxBranch { cab_tvs = tvs
-               , cab_cvs = cvs
-               , cab_lhs = lhs
-               , cab_rhs = rhs } = coAxiomSingleBranch axiom
-
-
-{-
-************************************************************************
-*                                                                      *
-        Optimised overlap checking for family instances
-*                                                                      *
-************************************************************************
-
-Note [Checking family instance consistency]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For any two family instance modules that we import directly or indirectly, we
-check whether the instances in the two modules are consistent, *unless* we can
-be certain that the instances of the two modules have already been checked for
-consistency during the compilation of modules that we import.
-
-Why do we need to check?  Consider
-   module X1 where                module X2 where
-    data T1                         data T2
-    type instance F T1 b = Int      type instance F a T2 = Char
-    f1 :: F T1 a -> Int             f2 :: Char -> F a T2
-    f1 x = x                        f2 x = x
-
-Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char.
-Notice that neither instance is an orphan.
-
-How do we know which pairs of modules have already been checked? For each
-module M we directly import, we look up the family instance modules that M
-imports (directly or indirectly), say F1, ..., FN. For any two modules
-among M, F1, ..., FN, we know that the family instances defined in those
-two modules are consistent--because we checked that when we compiled M.
-
-For every other pair of family instance modules we import (directly or
-indirectly), we check that they are consistent now. (So that we can be
-certain that the modules in our `GHC.Driver.Env.dep_finsts' are consistent.)
-
-There is some fancy footwork regarding hs-boot module loops, see
-Note [Don't check hs-boot type family instances too early]
-
-Note [Checking family instance optimization]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As explained in Note [Checking family instance consistency]
-we need to ensure that every pair of transitive imports that define type family
-instances is consistent.
-
-Let's define df(A) = transitive imports of A that define type family instances
-+ A, if A defines type family instances
-
-Then for every direct import A, df(A) is already consistent.
-
-Let's name the current module M.
-
-We want to make sure that df(M) is consistent.
-df(M) = df(D_1) U df(D_2) U ... U df(D_i) where D_1 .. D_i are direct imports.
-
-We perform the check iteratively, maintaining a set of consistent modules 'C'
-and trying to add df(D_i) to it.
-
-The key part is how to ensure that the union C U df(D_i) is consistent.
-
-Let's consider two modules: A and B from C U df(D_i).
-There are nine possible ways to choose A and B from C U df(D_i):
-
-             | A in C only      | A in C and B in df(D_i) | A in df(D_i) only
---------------------------------------------------------------------------------
-B in C only  | Already checked  | Already checked         | Needs to be checked
-             | when checking C  | when checking C         |
---------------------------------------------------------------------------------
-B in C and   | Already checked  | Already checked         | Already checked when
-B in df(D_i) | when checking C  | when checking C         | checking df(D_i)
---------------------------------------------------------------------------------
-B in df(D_i) | Needs to be      | Already checked         | Already checked when
-only         | checked          | when checking df(D_i)   | checking df(D_i)
-
-That means to ensure that C U df(D_i) is consistent we need to check every
-module from C - df(D_i) against every module from df(D_i) - C and
-every module from df(D_i) - C against every module from C - df(D_i).
-But since the checks are symmetric it suffices to pick A from C - df(D_i)
-and B from df(D_i) - C.
-
-In other words these are the modules we need to check:
-  [ (m1, m2) | m1 <- C, m1 not in df(D_i)
-             , m2 <- df(D_i), m2 not in C ]
-
-One final thing to note here is that if there's lot of overlap between
-subsequent df(D_i)'s then we expect those set differences to be small.
-That situation should be pretty common in practice, there's usually
-a set of utility modules that every module imports directly or indirectly.
-
-This is basically the idea from #13092, comment:14.
--}
-
--- This function doesn't check ALL instances for consistency,
--- only ones that aren't involved in recursive knot-tying
--- loops; see Note [Don't check hs-boot type family instances too early].
--- We don't need to check the current module, this is done in
--- tcExtendLocalFamInstEnv.
--- See Note [The type family instance consistency story].
-checkFamInstConsistency :: [Module] -> TcM ()
-checkFamInstConsistency directlyImpMods
-  = do { (eps, hug) <- getEpsAndHug
-       ; traceTc "checkFamInstConsistency" (ppr directlyImpMods)
-       ; let { -- Fetch the iface of a given module.  Must succeed as
-               -- all directly imported modules must already have been loaded.
-               modIface mod =
-                 case lookupIfaceByModule hug (eps_PIT eps) mod of
-                   Nothing    -> panicDoc "FamInst.checkFamInstConsistency"
-                                          (ppr mod $$ ppr hug)
-                   Just iface -> iface
-
-               -- Which family instance modules were checked for consistency
-               -- when we compiled `mod`?
-               -- Itself (if a family instance module) and its dep_finsts.
-               -- This is df(D_i) from
-               -- Note [Checking family instance optimization]
-             ; modConsistent :: Module -> [Module]
-             ; modConsistent mod =
-                 if mi_finsts (mi_final_exts (modIface mod)) then mod:deps else deps
-                 where
-                 deps = dep_finsts . mi_deps . modIface $ mod
-
-             ; hmiModule     = mi_module . hm_iface
-             ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv
-                               . md_fam_insts . hm_details
-             ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)
-                                           | hpt <- unitEnv_hpts hug
-                                           , hmi <- eltsHpt hpt ]
-
-             }
-
-       ; checkMany hpt_fam_insts modConsistent directlyImpMods
-       }
-  where
-    -- See Note [Checking family instance optimization]
-    checkMany
-      :: ModuleEnv FamInstEnv   -- home package family instances
-      -> (Module -> [Module])   -- given A, modules checked when A was checked
-      -> [Module]               -- modules to process
-      -> TcM ()
-    checkMany hpt_fam_insts modConsistent mods = go [] emptyModuleSet mods
-      where
-      go :: [Module] -- list of consistent modules
-         -> ModuleSet -- set of consistent modules, same elements as the
-                      -- list above
-         -> [Module] -- modules to process
-         -> TcM ()
-      go _ _ [] = return ()
-      go consistent consistent_set (mod:mods) = do
-        sequence_
-          [ check hpt_fam_insts m1 m2
-          | m1 <- to_check_from_mod
-            -- loop over toCheckFromMod first, it's usually smaller,
-            -- it may even be empty
-          , m2 <- to_check_from_consistent
-          ]
-        go consistent' consistent_set' mods
-        where
-        mod_deps_consistent =  modConsistent mod
-        mod_deps_consistent_set = mkModuleSet mod_deps_consistent
-        consistent' = to_check_from_mod ++ consistent
-        consistent_set' =
-          extendModuleSetList consistent_set to_check_from_mod
-        to_check_from_consistent =
-          filterOut (`elemModuleSet` mod_deps_consistent_set) consistent
-        to_check_from_mod =
-          filterOut (`elemModuleSet` consistent_set) mod_deps_consistent
-        -- Why don't we just minusModuleSet here?
-        -- We could, but doing so means one of two things:
-        --
-        --   1. When looping over the cartesian product we convert
-        --   a set into a non-deterministically ordered list. Which
-        --   happens to be fine for interface file determinism
-        --   in this case, today, because the order only
-        --   determines the order of deferred checks. But such
-        --   invariants are hard to keep.
-        --
-        --   2. When looping over the cartesian product we convert
-        --   a set into a deterministically ordered list - this
-        --   adds some additional cost of sorting for every
-        --   direct import.
-        --
-        --   That also explains why we need to keep both 'consistent'
-        --   and 'consistentSet'.
-        --
-        --   See also Note [ModuleEnv performance and determinism].
-    check hpt_fam_insts m1 m2
-      = do { env1' <- getFamInsts hpt_fam_insts m1
-           ; env2' <- getFamInsts hpt_fam_insts m2
-           -- We're checking each element of env1 against env2.
-           -- The cost of that is dominated by the size of env1, because
-           -- for each instance in env1 we look it up in the type family
-           -- environment env2, and lookup is cheap.
-           -- The code below ensures that env1 is the smaller environment.
-           ; let sizeE1 = famInstEnvSize env1'
-                 sizeE2 = famInstEnvSize env2'
-                 (env1, env2) = if sizeE1 < sizeE2 then (env1', env2')
-                                                   else (env2', env1')
-           -- Note [Don't check hs-boot type family instances too early]
-           -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-           -- Family instance consistency checking involves checking that
-           -- the family instances of our imported modules are consistent with
-           -- one another; this might lead you to think that this process
-           -- has nothing to do with the module we are about to typecheck.
-           -- Not so!  Consider the following case:
-           --
-           --   -- A.hs-boot
-           --   type family F a
-           --
-           --   -- B.hs
-           --   import {-# SOURCE #-} A
-           --   type instance F Int = Bool
-           --
-           --   -- A.hs
-           --   import B
-           --   type family F a
-           --
-           -- When typechecking A, we are NOT allowed to poke the TyThing
-           -- for F until we have typechecked the family.  Thus, we
-           -- can't do consistency checking for the instance in B
-           -- (checkFamInstConsistency is called during renaming).
-           -- Failing to defer the consistency check lead to #11062.
-           --
-           -- Additionally, we should also defer consistency checking when
-           -- type from the hs-boot file of the current module occurs on
-           -- the left hand side, as we will poke its TyThing when checking
-           -- for overlap.
-           --
-           --   -- F.hs
-           --   type family F a
-           --
-           --   -- A.hs-boot
-           --   import F
-           --   data T
-           --
-           --   -- B.hs
-           --   import {-# SOURCE #-} A
-           --   import F
-           --   type instance F T = Int
-           --
-           --   -- A.hs
-           --   import B
-           --   data T = MkT
-           --
-           -- In fact, it is even necessary to defer for occurrences in
-           -- the RHS, because we may test for *compatibility* in event
-           -- of an overlap.
-           --
-           -- Why don't we defer ALL of the checks to later?  Well, many
-           -- instances aren't involved in the recursive loop at all.  So
-           -- we might as well check them immediately; and there isn't
-           -- a good time to check them later in any case: every time
-           -- we finish kind-checking a type declaration and add it to
-           -- a context, we *then* consistency check all of the instances
-           -- which mentioned that type.  We DO want to check instances
-           -- as quickly as possible, so that we aren't typechecking
-           -- values with inconsistent axioms in scope.
-           --
-           -- See also Note [Tying the knot]
-           -- for why we are doing this at all.
-           ; let check_now = famInstEnvElts env1
-           ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))           check_now
-           ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now
- }
-
-getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
-getFamInsts hpt_fam_insts mod
-  | Just env <- lookupModuleEnv hpt_fam_insts mod = return env
-  | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)
-                   ; eps <- getEps
-                   ; return (expectJust "checkFamInstConsistency" $
-                             lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
-  where
-    doc = ppr mod <+> text "is a family-instance module"
-
-{-
-************************************************************************
-*                                                                      *
-        Lookup
-*                                                                      *
-************************************************************************
-
--}
-
--- | If @co :: T ts ~ rep_ty@ then:
---
--- > instNewTyCon_maybe T ts = Just (rep_ty, co)
---
--- Checks for a newtype, and for being saturated
--- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion
-tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion)
-tcInstNewTyCon_maybe = instNewTyCon_maybe
-
--- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if
--- there is no data family to unwrap.
--- Returns a Representational coercion
-tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType]
-                    -> (TyCon, [TcType], Coercion)
-tcLookupDataFamInst fam_inst_envs tc tc_args
-  | Just (rep_tc, rep_args, co)
-      <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
-  = (rep_tc, rep_args, co)
-  | otherwise
-  = (tc, tc_args, mkRepReflCo (mkTyConApp tc tc_args))
-
-tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType]
-                          -> Maybe (TyCon, [TcType], Coercion)
--- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a)
--- and returns a coercion between the two: co :: F [a] ~R FList a.
-tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
-  | isDataFamilyTyCon tc
-  , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args
-  , FamInstMatch { fim_instance = rep_fam@(FamInst { fi_axiom = ax
-                                                   , fi_cvs   = cvs })
-                 , fim_tys      = rep_args
-                 , fim_cos      = rep_cos } <- match
-  , let rep_tc = dataFamInstRepTyCon rep_fam
-        co     = mkUnbranchedAxInstCo Representational ax rep_args
-                                      (mkCoVarCos cvs)
-  = assert (null rep_cos) $ -- See Note [Constrained family instances] in GHC.Core.FamInstEnv
-    Just (rep_tc, rep_args, co)
-
-  | otherwise
-  = Nothing
-
--- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes,
--- potentially looking through newtype /instances/.
---
--- It is only used by the type inference engine (specifically, when
--- solving representational equality), and hence it is careful to unwrap
--- only if the relevant data constructor is in scope.  That's why
--- it gets a GlobalRdrEnv argument.
---
--- It is careful not to unwrap data/newtype instances if it can't
--- continue unwrapping.  Such care is necessary for proper error
--- messages.
---
--- It does not look through type families.
--- It does not normalise arguments to a tycon.
---
--- If the result is Just ((gres, co), rep_ty), then
---    co : ty ~R rep_ty
---    gres are the GREs for the data constructors that
---                          had to be in scope
-tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs
-                              -> GlobalRdrEnv
-                              -> Type
-                              -> Maybe ((Bag GlobalRdrElt, TcCoercion), Type)
-tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty
--- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe
-  = topNormaliseTypeX stepper plus ty
-  where
-    plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion)
-         -> (Bag GlobalRdrElt, TcCoercion)
-    plus (gres1, co1) (gres2, co2) = ( gres1 `unionBags` gres2
-                                     , co1 `mkTransCo` co2 )
-
-    stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
-    stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance
-
-    -- For newtype instances we take a double step or nothing, so that
-    -- we don't return the representation type of the newtype instance,
-    -- which would lead to terrible error messages
-    unwrap_newtype_instance rec_nts tc tys
-      | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys
-      = fmap (mkTransCo co) <$> unwrap_newtype rec_nts tc' tys'
-      | otherwise = NS_Done
-
-    unwrap_newtype rec_nts tc tys
-      | Just con <- newTyConDataCon_maybe tc
-      , Just gre <- lookupGRE_Name rdr_env (dataConName con)
-           -- This is where we check that the
-           -- data constructor is in scope
-      = (,) (unitBag gre) <$> unwrapNewTypeStepper rec_nts tc tys
-
-      | otherwise
-      = NS_Done
-
-{-
-************************************************************************
-*                                                                      *
-        Extending the family instance environment
-*                                                                      *
-************************************************************************
--}
-
--- Add new locally-defined family instances, checking consistency with
--- previous locally-defined family instances as well as all instances
--- available from imported modules. This requires loading all of our
--- imports that define family instances (if we haven't loaded them already).
-tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
-
--- If we weren't actually given any instances to add, then we don't want
--- to go to the bother of loading family instance module dependencies.
-tcExtendLocalFamInstEnv [] thing_inside = thing_inside
-
--- Otherwise proceed...
-tcExtendLocalFamInstEnv fam_insts thing_inside
- = do { -- Load family-instance modules "below" this module, so that
-        -- allLocalFamInst can check for consistency with them
-        -- See Note [The type family instance consistency story]
-        loadDependentFamInstModules fam_insts
-
-        -- Now add the instances one by one
-      ; env <- getGblEnv
-      ; (inst_env', fam_insts') <- foldlM addLocalFamInst
-                                       (tcg_fam_inst_env env, tcg_fam_insts env)
-                                       fam_insts
-
-      ; let env' = env { tcg_fam_insts    = fam_insts'
-                       , tcg_fam_inst_env = inst_env' }
-      ; setGblEnv env' thing_inside
-      }
-
-loadDependentFamInstModules :: [FamInst] -> TcM ()
--- Load family-instance modules "below" this module, so that
--- allLocalFamInst can check for consistency with them
--- See Note [The type family instance consistency story]
-loadDependentFamInstModules fam_insts
- = do { env <- getGblEnv
-      ; let this_mod = tcg_mod env
-            imports  = tcg_imports env
-
-            want_module mod  -- See Note [Home package family instances]
-              | mod == this_mod = False
-              | home_fams_only  = moduleUnit mod == moduleUnit this_mod
-              | otherwise       = True
-            home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts
-
-      ; loadModuleInterfaces (text "Loading family-instance modules") $
-        filter want_module (imp_finsts imports) }
-
-{- Note [Home package family instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Optimization: If we're only defining type family instances
-for type families *defined in the home package*, then we
-only have to load interface files that belong to the home
-package. The reason is that there's no recursion between
-packages, so modules in other packages can't possibly define
-instances for our type families.
-
-(Within the home package, we could import a module M that
-imports us via an hs-boot file, and thereby defines an
-instance of a type family defined in this module. So we can't
-apply the same logic to avoid reading any interface files at
-all, when we define an instances for type family defined in
-the current module.
--}
-
--- Check that the proposed new instance is OK,
--- and then add it to the home inst env
--- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match]
--- in GHC.Core.FamInstEnv
-addLocalFamInst :: (FamInstEnv,[FamInst])
-                -> FamInst
-                -> TcM (FamInstEnv, [FamInst])
-addLocalFamInst (home_fie, my_fis) fam_inst
-        -- home_fie includes home package and this module
-        -- my_fies is just the ones from this module
-  = do { traceTc "addLocalFamInst" (ppr fam_inst)
-
-           -- Unlike the case of class instances, don't override existing
-           -- instances in GHCi; it's unsound. See #7102.
-
-       ; mod <- getModule
-       ; traceTc "alfi" (ppr mod)
-
-           -- Fetch imported instances, so that we report
-           -- overlaps correctly.
-           -- Really we ought to only check consistency with
-           -- those instances which are transitively imported
-           -- by the current module, rather than every instance
-           -- we've ever seen. Fixing this is part of #13102.
-       ; eps <- getEps
-       ; let inst_envs = (eps_fam_inst_env eps, home_fie)
-             home_fie' = extendFamInstEnv home_fie fam_inst
-
-           -- Check for conflicting instance decls and injectivity violations
-       ; ((), no_errs) <- askNoErrs $
-         do { checkForConflicts            inst_envs fam_inst
-            ; checkForInjectivityConflicts inst_envs fam_inst
-            ; checkInjectiveEquation       fam_inst
-            }
-
-       ; if no_errs then
-            return (home_fie', fam_inst : my_fis)
-         else
-            return (home_fie,  my_fis) }
-
-{-
-************************************************************************
-*                                                                      *
-        Checking an instance against conflicts with an instance env
-*                                                                      *
-************************************************************************
-
-Check whether a single family instance conflicts with those in two instance
-environments (one for the EPS and one for the HPT).
--}
-
--- | Checks to make sure no two family instances overlap.
-checkForConflicts :: FamInstEnvs -> FamInst -> TcM ()
-checkForConflicts inst_envs fam_inst
-  = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst
-       ; traceTc "checkForConflicts" $
-         vcat [ ppr conflicts
-              , ppr fam_inst
-              -- , ppr inst_envs
-         ]
-       ; reportConflictInstErr fam_inst conflicts }
-
-checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM ()
-  -- see Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv, check 1B1.
-checkForInjectivityConflicts instEnvs famInst
-    | isTypeFamilyTyCon tycon   -- as opposed to data family tycon
-    , Injective inj <- tyConInjectivityInfo tycon
-    = let conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst in
-      reportConflictingInjectivityErrs tycon conflicts (coAxiomSingleBranch (fi_axiom famInst))
-
-    | otherwise
-    = return ()
-
-    where tycon = famInstTyCon famInst
-
--- | Check whether a new open type family equation can be added without
--- violating injectivity annotation supplied by the user. Returns True when
--- this is possible and False if adding this equation would violate injectivity
--- annotation. This looks only at the one equation; it does not look for
--- interaction between equations. Use checkForInjectivityConflicts for that.
--- Does checks (2)-(4) of Note [Verifying injectivity annotation] in "GHC.Core.FamInstEnv".
-checkInjectiveEquation :: FamInst -> TcM ()
-checkInjectiveEquation famInst
-    | isTypeFamilyTyCon tycon
-    -- type family is injective in at least one argument
-    , Injective inj <- tyConInjectivityInfo tycon = do
-    { dflags <- getDynFlags
-    ; let axiom = coAxiomSingleBranch fi_ax
-          -- see Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv
-    ; reportInjectivityErrors dflags fi_ax axiom inj
-    }
-
-    -- if there was no injectivity annotation or tycon does not represent a
-    -- type family we report no conflicts
-    | otherwise
-    = return ()
-
-    where tycon = famInstTyCon famInst
-          fi_ax = fi_axiom famInst
-
--- | Report a list of injectivity errors together with their source locations.
--- Looks only at one equation; does not look for conflicts *among* equations.
-reportInjectivityErrors
-   :: DynFlags
-   -> CoAxiom br   -- ^ Type family for which we generate errors
-   -> CoAxBranch   -- ^ Currently checked equation (represented by axiom)
-   -> [Bool]       -- ^ Injectivity annotation
-   -> TcM ()
-reportInjectivityErrors dflags fi_ax axiom inj
-  = assertPpr (any id inj) (text "No injective type variables") $
-    do let lhs             = coAxBranchLHS axiom
-           rhs             = coAxBranchRHS axiom
-           fam_tc          = coAxiomTyCon fi_ax
-           (unused_inj_tvs, unused_vis, undec_inst_flag)
-                           = unusedInjTvsInRHS dflags fam_tc lhs rhs
-           inj_tvs_unused  = not $ isEmptyVarSet unused_inj_tvs
-           tf_headed       = isTFHeaded rhs
-           bare_variables  = bareTvInRHSViolated lhs rhs
-           wrong_bare_rhs  = not $ null bare_variables
-
-       when inj_tvs_unused $ reportUnusedInjectiveVarsErr fam_tc unused_inj_tvs
-                                                          unused_vis undec_inst_flag axiom
-       when tf_headed      $ reportTfHeadedErr            fam_tc axiom
-       when wrong_bare_rhs $ reportBareVariableInRHSErr   fam_tc bare_variables axiom
-
--- | Is type headed by a type family application?
-isTFHeaded :: Type -> Bool
--- See Note [Verifying injectivity annotation], case 3.
-isTFHeaded ty | Just ty' <- coreView ty
-              = isTFHeaded ty'
-isTFHeaded ty | (TyConApp tc args) <- ty
-              , isTypeFamilyTyCon tc
-              = args `lengthIs` tyConArity tc
-isTFHeaded _  = False
-
-
--- | If a RHS is a bare type variable return a set of LHS patterns that are not
--- bare type variables.
-bareTvInRHSViolated :: [Type] -> Type -> [Type]
--- See Note [Verifying injectivity annotation], case 2.
-bareTvInRHSViolated pats rhs | isTyVarTy rhs
-   = filter (not . isTyVarTy) pats
-bareTvInRHSViolated _ _ = []
-
-------------------------------------------------------------------
--- Checking for the coverage condition for injective type families
-------------------------------------------------------------------
-
-{-
-Note [Coverage condition for injective type families]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The Injective Type Families paper describes how we can tell whether
-or not a type family equation upholds the injectivity condition.
-Briefly, consider the following:
-
-  type family F a b = r | r -> a      -- NB: b is not injective
-
-  type instance F ty1 ty2 = ty3
-
-We need to make sure that all variables mentioned in ty1 are mentioned in ty3
--- that's how we know that knowing ty3 determines ty1. But they can't be
-mentioned just anywhere in ty3: they must be in *injective* positions in ty3.
-For example:
-
-  type instance F a Int = Maybe (G a)
-
-This is no good, if G is not injective. However, if G is indeed injective,
-then this would appear to meet our needs. There is a trap here, though: while
-knowing G a does indeed determine a, trying to compute a from G a might not
-terminate. This is precisely the same problem that we have with functional
-dependencies and their liberal coverage condition. Here is the test case:
-
-  type family G a = r | r -> a
-  type instance G [a] = [G a]
-  [W] G alpha ~ [alpha]
-
-We see that the equation given applies, because G alpha equals a list. So we
-learn that alpha must be [beta] for some beta. We then have
-
-  [W] G [beta] ~ [[beta]]
-
-This can reduce to
-
-  [W] [G beta] ~ [[beta]]
-
-which then decomposes to
-
-  [W] G beta ~ [beta]
-
-right where we started. The equation G [a] = [G a] thus is dangerous: while
-it does not violate the injectivity assumption, it might throw us into a loop,
-with a particularly dastardly Wanted.
-
-We thus do what functional dependencies do: require -XUndecidableInstances to
-accept this.
-
-Checking the coverage condition is not terribly hard, but we also want to produce
-a nice error message. A nice error message has at least two properties:
-
-1. If any of the variables involved are invisible or are used in an invisible context,
-we want to print invisible arguments (as -fprint-explicit-kinds does).
-
-2. If we fail to accept the equation because we're worried about non-termination,
-we want to suggest UndecidableInstances.
-
-To gather the right information, we can talk about the *usage* of a variable. Every
-variable is used either visibly or invisibly, and it is either not used at all,
-in a context where acceptance requires UndecidableInstances, or in a context that
-does not require UndecidableInstances. If a variable is used both visibly and
-invisibly, then we want to remember the fact that it was used invisibly: printing
-out invisibles will be helpful for the user to understand what is going on.
-If a variable is used where we need -XUndecidableInstances and where we don't,
-we can similarly just remember the latter.
-
-We thus define Visibility and NeedsUndecInstFlag below. These enumerations are
-*ordered*, and we used their Ord instances. We then define VarUsage, which is just a pair
-of a Visibility and a NeedsUndecInstFlag. (The visibility is irrelevant when a
-variable is NotPresent, but this extra slack in the representation causes no
-harm.) We finally define VarUsages as a mapping from variables to VarUsage.
-Its Monoid instance combines two maps, using the Semigroup instance of VarUsage
-to combine elements that are represented in both maps. In this way, we can
-compositionally analyze types (and portions thereof).
-
-To do the injectivity check:
-
-1. We build VarUsages that represent the LHS (rather, the portion of the LHS
-that is flagged as injective); each usage on the LHS is NotPresent, because we
-have not yet looked at the RHS.
-
-2. We also build a VarUsage for the RHS, done by injTyVarUsages.
-
-3. We then combine these maps. Now, every variable in the injective components of the LHS
-will be mapped to its correct usage (either NotPresent or perhaps needing
--XUndecidableInstances in order to be seen as injective).
-
-4. We look up each var used in an injective argument on the LHS in
-the map, making a list of tvs that should be determined by the RHS
-but aren't.
-
-5. We then return the set of bad variables, whether any of the bad
-ones were used invisibly, and whether any bad ones need -XUndecidableInstances.
-If -XUndecidableInstances is enabled, than a var that needs the flag
-won't be bad, so it won't appear in this list.
-
-6. We use all this information to produce a nice error message, (a) switching
-on -fprint-explicit-kinds if appropriate and (b) telling the user about
--XUndecidableInstances if appropriate.
-
--}
-
--- | Return the set of type variables that a type family equation is
--- expected to be injective in but is not. Suppose we have @type family
--- F a b = r | r -> a@. Then any variables that appear free in the first
--- argument to F in an equation must be fixed by that equation's RHS.
--- This function returns all such variables that are not indeed fixed.
--- It also returns whether any of these variables appear invisibly
--- and whether -XUndecidableInstances would help.
--- See Note [Coverage condition for injective type families].
-unusedInjTvsInRHS :: DynFlags
-                  -> TyCon  -- type family
-                  -> [Type] -- LHS arguments
-                  -> Type   -- the RHS
-                  -> ( TyVarSet
-                     , HasKinds                     -- YesHasKinds <=> one or more variable is used invisibly
-                     , SuggestUndecidableInstances) -- YesSuggestUndecidableInstaces <=> suggest -XUndecidableInstances
--- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv.
--- This function implements check (4) described there, further
--- described in Note [Coverage condition for injective type families].
--- In theory (and modulo the -XUndecidableInstances wrinkle),
--- instead of implementing this whole check in this way, we could
--- attempt to unify equation with itself.  We would reject exactly the same
--- equations but this method gives us more precise error messages by returning
--- precise names of variables that are not mentioned in the RHS.
-unusedInjTvsInRHS dflags tycon@(tyConInjectivityInfo -> Injective inj_list) lhs rhs =
-  -- Note [Coverage condition for injective type families], step 5
-  (bad_vars, hasKinds any_invisible, suggestUndecidableInstances suggest_undec)
-    where
-      undec_inst = xopt LangExt.UndecidableInstances dflags
-
-      inj_lhs = filterByList inj_list lhs
-      lhs_vars = tyCoVarsOfTypes inj_lhs
-
-      rhs_inj_vars = fvVarSet $ injectiveVarsOfType undec_inst rhs
-
-      bad_vars = lhs_vars `minusVarSet` rhs_inj_vars
-
-      any_bad = not $ isEmptyVarSet bad_vars
-
-      invis_vars = fvVarSet $ invisibleVarsOfTypes [mkTyConApp tycon lhs, rhs]
-
-      any_invisible = any_bad && (bad_vars `intersectsVarSet` invis_vars)
-      suggest_undec = any_bad &&
-                      not undec_inst &&
-                      (lhs_vars `subVarSet` fvVarSet (injectiveVarsOfType True rhs))
-
--- When the type family is not injective in any arguments
-unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, NoHasKinds, NoSuggestUndecidableInstaces)
-
----------------------------------------
--- Producing injectivity error messages
----------------------------------------
-
--- | Report error message for a pair of equations violating an injectivity
--- annotation. No error message if there are no branches.
-reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM ()
-reportConflictingInjectivityErrs _ [] _ = return ()
-reportConflictingInjectivityErrs fam_tc (confEqn1:_) tyfamEqn
-  = addErrs [buildInjectivityError (TcRnFamInstNotInjective InjErrRhsOverlap)
-                                   fam_tc
-                                   (confEqn1 :| [tyfamEqn])]
-
--- | Report error message for equation with injective type variables unused in
--- the RHS. Note [Coverage condition for injective type families], step 6
-reportUnusedInjectiveVarsErr :: TyCon
-                             -> TyVarSet
-                             -> HasKinds                    -- YesHasKinds <=> print invisible arguments
-                             -> SuggestUndecidableInstances -- YesSuggestUndecidableInstaces <=> suggest -XUndecidableInstances
-                             -> CoAxBranch
-                             -> TcM ()
-reportUnusedInjectiveVarsErr fam_tc tvs has_kinds undec_inst tyfamEqn
-  = let reason     = InjErrCannotInferFromRhs tvs has_kinds undec_inst
-        (loc, dia) = buildInjectivityError (TcRnFamInstNotInjective reason) fam_tc (tyfamEqn :| [])
-    in addErrAt loc dia
-
--- | Report error message for equation that has a type family call at the top
--- level of RHS
-reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM ()
-reportTfHeadedErr fam_tc branch
-  = addErrs [buildInjectivityError (TcRnFamInstNotInjective InjErrRhsCannotBeATypeFam)
-                                   fam_tc
-                                   (branch :| [])]
-
--- | Report error message for equation that has a bare type variable in the RHS
--- but LHS pattern is not a bare type variable.
-reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM ()
-reportBareVariableInRHSErr fam_tc tys branch
-  = addErrs [buildInjectivityError (TcRnFamInstNotInjective (InjErrRhsBareTyVar tys))
-                                   fam_tc
-                                   (branch :| [])]
-
-buildInjectivityError :: (TyCon -> NonEmpty CoAxBranch -> TcRnMessage)
-                      -> TyCon
-                      -> NonEmpty CoAxBranch
-                      -> (SrcSpan, TcRnMessage)
-buildInjectivityError mkErr fam_tc branches
-  = ( coAxBranchSpan (NE.head branches), mkErr fam_tc branches )
-
-reportConflictInstErr :: FamInst -> [FamInst] -> TcRn ()
-reportConflictInstErr _ []
-  = return ()  -- No conflicts
-reportConflictInstErr fam_inst (conf_inst : _) =
-   -- The sortBy just arranges that instances are displayed in order
-   -- of source location, which reduced wobbling in error messages,
-   -- and is better for users
-  let   sorted  = NE.sortBy (SrcLoc.leftmost_smallest `on` getSpan) (fam_inst NE.:| [conf_inst])
-        fi1     = NE.head sorted
-        span    = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))
-        getSpan = getSrcSpan . famInstAxiom
-  in setSrcSpan span $ addErr $ TcRnConflictingFamInstDecls sorted
-
-tcGetFamInstEnvs :: TcM FamInstEnvs
--- Gets both the external-package inst-env
--- and the home-pkg inst env (includes module being compiled)
-tcGetFamInstEnvs
-  = do { eps <- getEps; env <- getGblEnv
-       ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Instance/FunDeps.hs
+++ /dev/null
@@ -1,708 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 2000
-
-
--}
-
-{-# LANGUAGE DeriveFunctor #-}
-
--- | Functional dependencies
---
--- It's better to read it as: "if we know these, then we're going to know these"
-module GHC.Tc.Instance.FunDeps
-   ( FunDepEqn(..)
-   , pprEquation
-   , improveFromInstEnv
-   , improveFromAnother
-   , checkInstCoverage
-   , checkFunDeps
-   , pprFundeps
-   , instFD, closeWrtFunDeps
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Types.Name
-import GHC.Types.Var
-import GHC.Core.Class
-import GHC.Core.Predicate
-import GHC.Core.Type
-import GHC.Core.RoughMap( RoughMatchTc(..) )
-import GHC.Core.Coercion.Axiom( TypeEqn )
-import GHC.Core.Unify
-import GHC.Core.InstEnv
-import GHC.Core.TyCo.FVs
-import GHC.Core.TyCo.Compare( eqTypes, eqType )
-import GHC.Core.TyCo.Ppr( pprWithExplicitKindsWhen )
-
-import GHC.Tc.Utils.TcType( transSuperClasses )
-
-import GHC.Types.Var.Set
-import GHC.Types.Var.Env
-import GHC.Types.SrcLoc
-
-import GHC.Utils.Outputable
-import GHC.Utils.FV
-import GHC.Utils.Error( Validity'(..), Validity, allValid )
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-
-import GHC.Data.Pair             ( Pair(..) )
-import Data.List        ( nubBy )
-import Data.Maybe
-import Data.Foldable    ( fold )
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Generate equations from functional dependencies}
-*                                                                      *
-************************************************************************
-
-Each functional dependency with one variable in the RHS is responsible
-for generating a single equality. For instance:
-     class C a b | a -> b
-The constraints ([Wanted] C Int Bool) and [Wanted] C Int alpha
-will generate the following FunDepEqn
-     FDEqn { fd_qtvs = []
-           , fd_eqs  = [Pair Bool alpha]
-           , fd_pred1 = C Int Bool
-           , fd_pred2 = C Int alpha
-           , fd_loc = ... }
-However notice that a functional dependency may have more than one variable
-in the RHS which will create more than one pair of types in fd_eqs. Example:
-     class C a b c | a -> b c
-     [Wanted] C Int alpha alpha
-     [Wanted] C Int Bool beta
-Will generate:
-     FDEqn { fd_qtvs = []
-           , fd_eqs  = [Pair Bool alpha, Pair alpha beta]
-           , fd_pred1 = C Int Bool
-           , fd_pred2 = C Int alpha
-           , fd_loc = ... }
-
-INVARIANT: Corresponding types aren't already equal
-That is, there exists at least one non-identity equality in FDEqs.
-
-Note [Improving against instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Assume:
-   class C a b | a -> b
-   instance C Int Bool
-   [W] C Int ty
-
-Then `improveFromInstEnv` should return a FDEqn with
-   FDEqn { fd_qtvs = [], fd_eqs = [Pair Bool ty] }
-
-describing an equality (Int ~ ty).  To do this we /match/ the instance head
-against the [W], using just the LHS of the fundep; if we match, we return
-an equality for the RHS.
-
-Wrinkles:
-
-(1) meta_tvs: sometimes the instance mentions variables in the RHS that
-    are not bound in the LHS.  For example
-
-     class C a b | a -> b
-     instance C Int (Maybe x)
-     [W] C Int ty
-
-    Note that although the `Int` parts match, that does not fix what `x` is.
-    So we just make up a fresh unification variable (a meta_tv), to give the
-    "shape" of the RHS.  So we emit the FDEqun
-       FDEqn { fd_qtvs = [x], fd_eqs = [Pair (Maybe x) ty] }
-
-    Note that the fd_qtvs can be free in the /first/ component of the Pair,
-
-    but not in the seconde (which comes from the [W] constraint.
-
-(2) Multi-range fundeps. When these meta_tvs are involved, there is a subtle
-    difference between the fundep (a -> b c) and the two fundeps (a->b, a->c).
-    Consider
-       class D a b c | a -> b c
-       instance D Int x (Maybe x)
-       [W] D Int Bool ty
-
-    Then we'll generate
-       FDEqn { fd_qtvs = [x0], fd_eqs = [ x0 ~ Bool, Maybe x0 ~ ty] }
-    which generates one fresh unification variable x0
-
-    But if the fundeps had been (a->b, a->c) we'd generate two FDEqns
-       FDEqn { fd_qtvs = [x1], fd_eqs = [ x1 ~ Bool ] }
-       FDEqn { fd_qtvs = [x2], fd_eqs = [ Maybe x2 ~ ty ] }
-    with two FDEqns, generating two separate unification variables.
-
-(3) improveFromInstEnv doesn't return any equations that already hold.
-    Reason: then we know if any actual improvement has happened, in
-    which case we need to iterate the solver
--}
-
-data FunDepEqn loc
-  = FDEqn { fd_qtvs :: [TyVar]   -- Instantiate these type and kind vars
-                                 --   to fresh unification vars,
-                                 -- Non-empty only for FunDepEqns arising from instance decls
-
-          , fd_eqs   :: [TypeEqn]  -- Make these pairs of types equal
-                                   -- Invariant: In each (Pair ty1 ty2), the fd_qtvs may be
-                                   -- free in ty1 but not in ty2.  See Wrinkle (1) of
-                                   -- Note [Improving against instances]
-
-          , fd_pred1 :: PredType   -- The FunDepEqn arose from
-          , fd_pred2 :: PredType   --  combining these two constraints
-          , fd_loc   :: loc  }
-    deriving Functor
-
-instance Outputable (FunDepEqn a) where
-  ppr = pprEquation
-
-pprEquation :: FunDepEqn a -> SDoc
-pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs })
-  = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs),
-          nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2
-                       | Pair t1 t2 <- pairs])]
-
-{-
-Given a bunch of predicates that must hold, such as
-
-        C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5
-
-improve figures out what extra equations must hold.
-For example, if we have
-
-        class C a b | a->b where ...
-
-then improve will return
-
-        [(t1,t2), (t4,t5)]
-
-NOTA BENE:
-
-  * improve does not iterate.  It's possible that when we make
-    t1=t2, for example, that will in turn trigger a new equation.
-    This would happen if we also had
-        C t1 t7, C t2 t8
-    If t1=t2, we also get t7=t8.
-
-    improve does *not* do this extra step.  It relies on the caller
-    doing so.
-
-  * The equations unify types that are not already equal.  So there
-    is no effect iff the result of improve is empty
--}
-
-instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type
--- (instFD fd tvs tys) returns fd instantiated with (tvs -> tys)
-instFD (ls,rs) tvs tys
-  = (map lookup ls, map lookup rs)
-  where
-    env       = zipVarEnv tvs tys
-    lookup tv = lookupVarEnv_NF env tv
-
-zipAndComputeFDEqs :: (Type -> Type -> Bool) -- Discard this FDEq if true
-                   -> [Type] -> [Type]
-                   -> [TypeEqn]
--- Create a list of (Type,Type) pairs from two lists of types,
--- making sure that the types are not already equal
-zipAndComputeFDEqs discard (ty1:tys1) (ty2:tys2)
- | discard ty1 ty2 = zipAndComputeFDEqs discard tys1 tys2
- | otherwise       = Pair ty1 ty2 : zipAndComputeFDEqs discard tys1 tys2
-zipAndComputeFDEqs _ _ _ = []
-
--- Improve a class constraint from another class constraint
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-improveFromAnother :: loc
-                   -> PredType -- Template item (usually given, or inert)
-                   -> PredType -- Workitem [that can be improved]
-                   -> [FunDepEqn loc]
--- Post: FDEqs always oriented from the other to the workitem
---       Equations have empty quantified variables
-improveFromAnother loc pred1 pred2
-  | Just (cls1, tys1) <- getClassPredTys_maybe pred1
-  , Just (cls2, tys2) <- getClassPredTys_maybe pred2
-  , cls1 == cls2
-  = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2, fd_loc = loc }
-    | let (cls_tvs, cls_fds) = classTvsFds cls1
-    , fd <- cls_fds
-    , let (ltys1, rs1) = instFD fd cls_tvs tys1
-          (ltys2, rs2) = instFD fd cls_tvs tys2
-    , eqTypes ltys1 ltys2               -- The LHSs match
-    , let eqs = zipAndComputeFDEqs eqType rs1 rs2
-    , not (null eqs) ]
-
-improveFromAnother _ _ _ = []
-
-
--- Improve a class constraint from instance declarations
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-improveFromInstEnv :: InstEnvs
-                   -> (PredType -> SrcSpan -> loc)
-                   -> Class -> [Type]
-                   -> [FunDepEqn loc] -- Needs to be a FunDepEqn because
-                                      -- of quantified variables
--- See Note [Improving against instances]
--- Post: Equations oriented from the template (matching instance) to the workitem!
-improveFromInstEnv inst_env mk_loc cls tys
-  = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs
-            , fd_pred1 = p_inst, fd_pred2 = pred
-            , fd_loc = mk_loc p_inst (getSrcSpan (is_dfun ispec)) }
-    | fd <- cls_fds             -- Iterate through the fundeps first,
-                                -- because there often are none!
-    , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs
-                -- Trim the rough_tcs based on the head of the fundep.
-                -- Remember that instanceCantMatch treats both arguments
-                -- symmetrically, so it's ok to trim the rough_tcs,
-                -- rather than trimming each inst_tcs in turn
-    , ispec <- instances
-    , (meta_tvs, eqs) <- improveClsFD cls_tvs fd ispec
-                                      tys trimmed_tcs -- NB: orientation
-    , let p_inst = mkClassPred cls (is_tys ispec)
-    ]
-  where
-    (cls_tvs, cls_fds) = classTvsFds cls
-    instances          = classInstances inst_env cls
-    rough_tcs          = RM_KnownTc (className cls) : roughMatchTcs tys
-    pred               = mkClassPred cls tys
-
-improveClsFD :: [TyVar] -> FunDep TyVar    -- One functional dependency from the class
-             -> ClsInst                    -- An instance template
-             -> [Type] -> [RoughMatchTc]   -- Arguments of this (C tys) predicate
-             -> [([TyCoVar], [TypeEqn])]   -- Empty or singleton
--- See Note [Improving against instances]
-
-improveClsFD clas_tvs fd
-             (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst })
-             tys_actual rough_tcs_actual
-
-  | instanceCantMatch rough_tcs_inst rough_tcs_actual
-  = []          -- Filter out ones that can't possibly match,
-
-  | otherwise
-  = assertPpr (equalLength tys_inst tys_actual &&
-               equalLength tys_inst clas_tvs)
-              (ppr tys_inst <+> ppr tys_actual) $
-
-    case tcMatchTyKisX init_subst ltys1 ltys2 of
-        Nothing  -> []
-        Just subst | isJust (tcMatchTyKisX subst rtys1 rtys2)
-                        -- Don't include any equations that already hold.
-                        -- See Note [Improving against instances] wrinkle (3)
-                        -- In making this check we must taking account of the fact that any
-                        -- qtvs that aren't already instantiated can be instantiated to anything
-                        -- at all
-                        -- NB: We can't do this 'is-useful-equation' check element-wise
-                        --     because of:
-                        --           class C a b c | a -> b c
-                        --           instance C Int x x
-                        --           [Wanted] C Int alpha Int
-                        -- We would get that  x -> alpha  (isJust) and x -> Int (isJust)
-                        -- so we would produce no FDs, which is clearly wrong.
-                  -> []
-
-                  | null fdeqs
-                  -> []
-
-                  | otherwise
-                  -> -- pprTrace "iproveClsFD" (vcat
-                     --  [ text "is_tvs =" <+> ppr qtvs
-                     --  , text "tys_inst =" <+> ppr tys_inst
-                     --  , text "tys_actual =" <+> ppr tys_actual
-                     --  , text "ltys1 =" <+> ppr ltys1
-                     --  , text "ltys2 =" <+> ppr ltys2
-                     --  , text "subst =" <+> ppr subst ]) $
-                     [(meta_tvs, fdeqs)]
-                        -- We could avoid this substTy stuff by producing the eqn
-                        -- (qtvs, ls1++rs1, ls2++rs2)
-                        -- which will re-do the ls1/ls2 unification when the equation is
-                        -- executed.  What we're doing instead is recording the partial
-                        -- work of the ls1/ls2 unification leaving a smaller unification problem
-                  where
-                    rtys1' = map (substTy subst) rtys1
-
-                    fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2
-                        -- Don't discard anything!
-                        -- We could discard equal types but it's an overkill to call
-                        -- eqType again, since we know for sure that /at least one/
-                        -- equation in there is useful)
-
-                    meta_tvs = [ setVarType tv (substTy subst (varType tv))
-                               | tv <- qtvs
-                               , tv `notElemSubst` subst
-                               , tv `elemVarSet` rtys1_tvs ]
-                        -- meta_tvs are the quantified type variables
-                        -- that have not been substituted out
-                        --
-                        -- Eg.  class C a b | a -> b
-                        --      instance C Int [y]
-                        -- Given constraint C Int z
-                        -- we generate the equation
-                        --      ({y}, [y], z)
-                        --
-                        -- But note (a) we get them from the dfun_id, so they are *in order*
-                        --              because the kind variables may be mentioned in the
-                        --              type variables' kinds
-                        --          (b) we must apply 'subst' to the kinds, in case we have
-                        --              matched out a kind variable, but not a type variable
-                        --              whose kind mentions that kind variable! #6015, #6068
-                        --          (c) no need to include tyvars not in rtys1
-  where
-    init_subst     = mkEmptySubst $ mkInScopeSet $
-                     mkVarSet qtvs `unionVarSet` tyCoVarsOfTypes ltys2
-    (ltys1, rtys1) = instFD fd clas_tvs tys_inst
-    (ltys2, rtys2) = instFD fd clas_tvs tys_actual
-    rtys1_tvs      = tyCoVarsOfTypes rtys1
-
-{-
-%************************************************************************
-%*                                                                      *
-        The Coverage condition for instance declarations
-*                                                                      *
-************************************************************************
-
-Note [Coverage condition]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Example
-      class C a b | a -> b
-      instance theta => C t1 t2
-
-For the coverage condition, we check
-   (normal)    fv(t2) `subset` fv(t1)
-   (liberal)   fv(t2) `subset` closeWrtFunDeps(fv(t1), theta)
-
-The liberal version  ensures the self-consistency of the instance, but
-it does not guarantee termination. Example:
-
-   class Mul a b c | a b -> c where
-        (.*.) :: a -> b -> c
-
-   instance Mul Int Int Int where (.*.) = (*)
-   instance Mul Int Float Float where x .*. y = fromIntegral x * y
-   instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v
-
-In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]).
-But it is the case that fv([c]) `subset` closeWrtFunDeps( theta, fv(a,[b]) )
-
-But it is a mistake to accept the instance because then this defn:
-        f = \ b x y -> if b then x .*. [y] else y
-makes instance inference go into a loop, because it requires the constraint
-        Mul a [b] b
--}
-
-checkInstCoverage :: Bool   -- Be liberal
-                  -> Class -> [PredType] -> [Type]
-                  -> Validity
--- "be_liberal" flag says whether to use "liberal" coverage of
---              See Note [Coverage condition] below
---
--- Return values
---    Nothing  => no problems
---    Just msg => coverage problem described by msg
-
-checkInstCoverage be_liberal clas theta inst_taus
-  = allValid (map fundep_ok fds)
-  where
-    (tyvars, fds) = classTvsFds clas
-    fundep_ok fd
-       | and (isEmptyVarSet <$> undetermined_tvs) = IsValid
-       | otherwise                                = NotValid msg
-       where
-         (ls,rs) = instFD fd tyvars inst_taus
-         ls_tvs = tyCoVarsOfTypes ls
-         rs_tvs = visVarsOfTypes rs
-
-         undetermined_tvs | be_liberal = liberal_undet_tvs
-                          | otherwise  = conserv_undet_tvs
-
-         closed_ls_tvs = closeWrtFunDeps theta ls_tvs
-         liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs
-         conserv_undet_tvs = (`minusVarSet` ls_tvs)        <$> rs_tvs
-
-         undet_set = fold undetermined_tvs
-
-         msg = pprWithExplicitKindsWhen
-                 (isEmptyVarSet $ pSnd undetermined_tvs) $
-               vcat [ -- text "ls_tvs" <+> ppr ls_tvs
-                      -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs)
-                      -- , text "theta" <+> ppr theta
-                      -- , text "closeWrtFunDeps" <+> ppr (closeWrtFunDeps theta (closeOverKinds ls_tvs))
-                      -- , text "rs_tvs" <+> ppr rs_tvs
-                      sep [ text "The"
-                            <+> ppWhen be_liberal (text "liberal")
-                            <+> text "coverage condition fails in class"
-                            <+> quotes (ppr clas)
-                          , nest 2 $ text "for functional dependency:"
-                            <+> quotes (pprFunDep fd) ]
-                    , sep [ text "Reason: lhs type"<>plural ls <+> pprQuotedList ls
-                          , nest 2 $
-                            (if isSingleton ls
-                             then text "does not"
-                             else text "do not jointly")
-                            <+> text "determine rhs type"<>plural rs
-                            <+> pprQuotedList rs ]
-                    , text "Un-determined variable" <> pluralVarSet undet_set <> colon
-                            <+> pprVarSet undet_set (pprWithCommas ppr)
-                    , ppWhen (not be_liberal &&
-                              and (isEmptyVarSet <$> liberal_undet_tvs)) $
-                      text "Using UndecidableInstances might help" ]
-
-{- Note [Closing over kinds in coverage]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have a fundep  (a::k) -> b
-Then if 'a' is instantiated to (x y), where x:k2->*, y:k2,
-then fixing x really fixes k2 as well, and so k2 should be added to
-the lhs tyvars in the fundep check.
-
-Example (#8391), using liberal coverage
-      data Foo a = ...  -- Foo :: forall k. k -> *
-      class Bar a b | a -> b
-      instance Bar a (Foo a)
-
-    In the instance decl, (a:k) does fix (Foo k a), but only if we notice
-    that (a:k) fixes k.  #10109 is another example.
-
-Here is a more subtle example, from HList-0.4.0.0 (#10564)
-
-  class HasFieldM (l :: k) r (v :: Maybe *)
-        | l r -> v where ...
-  class HasFieldM1 (b :: Maybe [*]) (l :: k) r v
-        | b l r -> v where ...
-  class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k])
-        | e1 l -> r
-
-  data Label :: k -> *
-  type family LabelsOf (a :: [*]) ::  *
-
-  instance (HMemberM (Label {k} (l::k)) (LabelsOf xs) b,
-            HasFieldM1 b l (r xs) v)
-         => HasFieldM l (r xs) v where
-
-Is the instance OK? Does {l,r,xs} determine v?  Well:
-
-  * From the instance constraint HMemberM (Label k l) (LabelsOf xs) b,
-    plus the fundep "| el l -> r" in class HMameberM,
-    we get {l,k,xs} -> b
-
-  * Note the 'k'!! We must call closeOverKinds on the seed set
-    ls_tvs = {l,r,xs}, BEFORE doing closeWrtFunDeps, else the {l,k,xs}->b
-    fundep won't fire.  This was the reason for #10564.
-
-  * So starting from seeds {l,r,xs,k} we do closeWrtFunDeps to get
-    first {l,r,xs,k,b}, via the HMemberM constraint, and then
-    {l,r,xs,k,b,v}, via the HasFieldM1 constraint.
-
-  * And that fixes v.
-
-However, we must closeOverKinds whenever augmenting the seed set
-in closeWrtFunDeps!  Consider #10109:
-
-  data Succ a   -- Succ :: forall k. k -> *
-  class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab
-  instance (Add a b ab) => Add (Succ {k1} (a :: k1))
-                               b
-                               (Succ {k3} (ab :: k3})
-
-We start with seed set {a:k1,b:k2} and closeOverKinds to {a,k1,b,k2}.
-Now use the fundep to extend to {a,k1,b,k2,ab}.  But we need to
-closeOverKinds *again* now to {a,k1,b,k2,ab,k3}, so that we fix all
-the variables free in (Succ {k3} ab).
-
-Bottom line:
-  * closeOverKinds on initial seeds (done automatically
-    by tyCoVarsOfTypes in checkInstCoverage)
-  * and closeOverKinds whenever extending those seeds (in closeWrtFunDeps)
-
-Note [The liberal coverage condition]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-(closeWrtFunDeps preds tvs) closes the set of type variables tvs,
-wrt functional dependencies in preds.  The result is a superset
-of the argument set.  For example, if we have
-        class C a b | a->b where ...
-then
-        closeWrtFunDeps [C (x,y) z, C (x,p) q] {x,y} = {x,y,z}
-because if we know x and y then that fixes z.
-
-We also use equality predicates in the predicates; if we have an
-assumption `t1 ~ t2`, then we use the fact that if we know `t1` we
-also know `t2` and the other way.
-  eg    closeWrtFunDeps [C (x,y) z, a ~ x] {a,y} = {a,y,z,x}
-
-closeWrtFunDeps is used
- - when checking the coverage condition for an instance declaration
- - when determining which tyvars are unquantifiable during generalization, in
-   GHC.Tc.Solver.decideMonoTyVars.
-
-Note [Equality superclasses]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-  class (a ~ [b]) => C a b
-
-Remember from Note [The equality types story] in GHC.Builtin.Types.Prim, that
-  * (a ~~ b) is a superclass of (a ~ b)
-  * (a ~# b) is a superclass of (a ~~ b)
-
-So when closeWrtFunDeps expands superclasses we'll get a (a ~# [b]) superclass.
-But that's an EqPred not a ClassPred, and we jolly well do want to
-account for the mutual functional dependencies implied by (t1 ~# t2).
-Hence the EqPred handling in closeWrtFunDeps.  See #10778.
-
-Note [Care with type functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#12803)
-  class C x y | x -> y
-  type family F a b
-  type family G c d = r | r -> d
-
-Now consider
-  closeWrtFunDeps (C (F a b) (G c d)) {a,b}
-
-Knowing {a,b} fixes (F a b) regardless of the injectivity of F.
-But knowing (G c d) fixes only {d}, because G is only injective
-in its second parameter.
-
-Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds.
--}
-
-closeWrtFunDeps :: [PredType] -> TyCoVarSet -> TyCoVarSet
--- See Note [The liberal coverage condition]
-closeWrtFunDeps preds fixed_tvs
-  | null tv_fds = fixed_tvs -- Fast escape hatch for common case.
-  | otherwise   = assertPpr (closeOverKinds fixed_tvs == fixed_tvs)
-                    (vcat [ text "closeWrtFunDeps: fixed_tvs is not closed over kinds"
-                          , text "fixed_tvs:" <+> ppr fixed_tvs
-                          , text "closure:" <+> ppr (closeOverKinds fixed_tvs) ])
-                $ fixVarSet extend fixed_tvs
-  where
-
-    extend fixed_tvs = foldl' add fixed_tvs tv_fds
-       where
-          add fixed_tvs (ls,rs)
-            | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` closeOverKinds rs
-            | otherwise                = fixed_tvs
-            -- closeOverKinds: see Note [Closing over kinds in coverage]
-
-    tv_fds  :: [(TyCoVarSet,TyCoVarSet)]
-    tv_fds  = [ (tyCoVarsOfTypes ls, fvVarSet $ injectiveVarsOfTypes True rs)
-                  -- See Note [Care with type functions]
-              | pred <- preds
-              , pred' <- pred : transSuperClasses pred
-                   -- Look for fundeps in superclasses too
-              , (ls, rs) <- determined pred' ]
-
-    determined :: PredType -> [([Type],[Type])]
-    determined pred
-       = case classifyPredType pred of
-            EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])]
-               -- See Note [Equality superclasses]
-            ClassPred cls tys  -> [ instFD fd cls_tvs tys
-                                  | let (cls_tvs, cls_fds) = classTvsFds cls
-                                  , fd <- cls_fds ]
-            _ -> []
-
-
-{- *********************************************************************
-*                                                                      *
-        Check that a new instance decl is OK wrt fundeps
-*                                                                      *
-************************************************************************
-
-Here is the bad case:
-        class C a b | a->b where ...
-        instance C Int Bool where ...
-        instance C Int Char where ...
-
-The point is that a->b, so Int in the first parameter must uniquely
-determine the second.  In general, given the same class decl, and given
-
-        instance C s1 s2 where ...
-        instance C t1 t2 where ...
-
-Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2).
-
-Matters are a little more complicated if there are free variables in
-the s2/t2.
-
-        class D a b c | a -> b
-        instance D a b => D [(a,a)] [b] Int
-        instance D a b => D [a]     [b] Bool
-
-The instance decls don't overlap, because the third parameter keeps
-them separate.  But we want to make sure that given any constraint
-        D s1 s2 s3
-if s1 matches
-
-Note [Bogus consistency check]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In checkFunDeps we check that a new ClsInst is consistent with all the
-ClsInsts in the environment.
-
-The bogus aspect is discussed in #10675. Currently it if the two
-types are *contradictory*, using (isNothing . tcUnifyTys).  But all
-the papers say we should check if the two types are *equal* thus
-   not (substTys subst rtys1 `eqTypes` substTys subst rtys2)
-For now I'm leaving the bogus form because that's the way it has
-been for years.
--}
-
-checkFunDeps :: InstEnvs -> ClsInst -> [ClsInst]
--- The Consistency Check.
--- Check whether adding DFunId would break functional-dependency constraints
--- Used only for instance decls defined in the module being compiled
--- Returns a list of the ClsInst in InstEnvs that are inconsistent
--- with the proposed new ClsInst
-checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls
-                                , is_tys = tys1, is_tcs = rough_tcs1 })
-  | null fds
-  = []
-  | otherwise
-  = nubBy eq_inst $
-    [ ispec | ispec <- cls_insts
-            , fd    <- fds
-            , is_inconsistent fd ispec ]
-  where
-    cls_insts      = classInstances inst_envs cls
-    (cls_tvs, fds) = classTvsFds cls
-    qtv_set1       = mkVarSet qtvs1
-
-    is_inconsistent fd (ClsInst { is_tvs = qtvs2, is_tys = tys2, is_tcs = rough_tcs2 })
-      | instanceCantMatch trimmed_tcs rough_tcs2
-      = False
-      | otherwise
-      = case tcUnifyTyKis bind_fn ltys1 ltys2 of
-          Nothing         -> False
-          Just subst
-            -> isNothing $   -- Bogus legacy test (#10675)
-                             -- See Note [Bogus consistency check]
-               tcUnifyTyKis bind_fn (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2)
-
-      where
-        trimmed_tcs    = trimRoughMatchTcs cls_tvs fd rough_tcs1
-        (ltys1, rtys1) = instFD fd cls_tvs tys1
-        (ltys2, rtys2) = instFD fd cls_tvs tys2
-        qtv_set2       = mkVarSet qtvs2
-        bind_fn        = matchBindFun (qtv_set1 `unionVarSet` qtv_set2)
-
-    eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2
-        -- A single instance may appear twice in the un-nubbed conflict list
-        -- because it may conflict with more than one fundep.  E.g.
-        --      class C a b c | a -> b, a -> c
-        --      instance C Int Bool Bool
-        --      instance C Int Char Char
-        -- The second instance conflicts with the first by *both* fundeps
-
-trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [RoughMatchTc] -> [RoughMatchTc]
--- Computing rough_tcs for a particular fundep
---     class C a b c | a -> b where ...
--- For each instance .... => C ta tb tc
--- we want to match only on the type ta; so our
--- rough-match thing must similarly be filtered.
--- Hence, we Nothing-ise the tb and tc types right here
---
--- Result list is same length as input list, just with more Nothings
-trimRoughMatchTcs _clas_tvs _ [] = panic "trimRoughMatchTcs: nullary [RoughMatchTc]"
-trimRoughMatchTcs clas_tvs (ltvs, _) (cls:mb_tcs)
-  = cls : zipWith select clas_tvs mb_tcs
-  where
-    select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc
-                         | otherwise           = RM_WildCard
diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Instance/Typeable.hs
+++ /dev/null
@@ -1,777 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1999
--}
-
-
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where
-
-import GHC.Prelude
-import GHC.Platform
-
-import GHC.Types.Basic ( Boxity(..), TypeOrConstraint(..), neverInlinePragma )
-import GHC.Types.SourceText ( SourceText(..) )
-import GHC.Iface.Env( newGlobalBinder )
-import GHC.Core.TyCo.Rep( Type(..), TyLit(..) )
-import GHC.Tc.Utils.Env
-import GHC.Tc.Types.Evidence ( mkWpTyApps )
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.TcType
-import GHC.Types.TyThing ( lookupId )
-import GHC.Builtin.Names
-import GHC.Builtin.Types.Prim ( primTyCons )
-import GHC.Builtin.Types
-                  ( tupleTyCon, sumTyCon, runtimeRepTyCon
-                  , levityTyCon, vecCountTyCon, vecElemTyCon
-                  , nilDataCon, consDataCon )
-import GHC.Types.Name
-import GHC.Types.Id
-import GHC.Core.Type
-import GHC.Core.TyCon
-import GHC.Core.DataCon
-import GHC.Unit.Module
-import GHC.Hs
-import GHC.Driver.Session
-import GHC.Data.Bag
-import GHC.Types.Var ( VarBndr(..) )
-import GHC.Core.Map.Type
-import GHC.Settings.Constants
-import GHC.Utils.Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Data.FastString ( FastString, mkFastString, fsLit )
-
-import Control.Monad.Trans.State.Strict
-import Control.Monad.Trans.Class (lift)
-import Data.Maybe ( isJust )
-
-{- Note [Grand plan for Typeable]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The overall plan is this:
-
-1. Generate a binding for each module p:M
-   (done in GHC.Tc.Instance.Typeable by mkModIdBindings)
-       M.$trModule :: GHC.Unit.Module
-       M.$trModule = Module "p" "M"
-   ("tr" is short for "type representation"; see GHC.Types)
-
-   We might want to add the filename too.
-   This can be used for the lightweight stack-tracing stuff too
-
-   Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv
-
-2. Generate a binding for every data type declaration T in module M,
-       M.$tcT :: GHC.Types.TyCon
-       M.$tcT = TyCon ...fingerprint info...
-                      $trModule
-                      "T"
-                      0#
-                      kind_rep
-
-   Here 0# is the number of arguments expected by the tycon to fully determine
-   its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a
-   recipe for computing the kind of an instantiation of the tycon (see
-   Note [Representing TyCon kinds: KindRep] later in this file for details).
-
-   We define (in GHC.Core.TyCon)
-
-        type TyConRepName = Name
-
-   to use for these M.$tcT "tycon rep names". Note that these must be
-   treated as "never exported" names by Backpack (see
-   Note [Handling never-exported TyThings under Backpack]). Consequently
-   they get slightly special treatment in GHC.Iface.Rename.rnIfaceDecl.
-
-3. Record the TyConRepName in T's TyCon, including for promoted
-   data and type constructors, and kinds like * and #.
-
-   The TyConRepName is not an "implicit Id".  It's more like a record
-   selector: the TyCon knows its name but you have to go to the
-   interface file to find its type, value, etc
-
-4. Solve Typeable constraints.  This is done by a custom Typeable solver,
-   currently in GHC.Tc.Solver.Interact, that use M.$tcT so solve (Typeable T).
-
-There are many wrinkles:
-
-* The timing of when we produce this bindings is rather important: they must be
-  defined after the rest of the module has been typechecked since we need to be
-  able to lookup Module and TyCon in the type environment and we may be
-  currently compiling GHC.Types (where they are defined).
-
-* GHC.Prim doesn't have any associated object code, so we need to put the
-  representations for types defined in this module elsewhere. We chose this
-  place to be GHC.Types. GHC.Tc.Instance.Typeable.mkPrimTypeableBinds is responsible for
-  injecting the bindings for the GHC.Prim representations when compiling
-  GHC.Types.
-
-* TyCon.tyConRepModOcc is responsible for determining where to find
-  the representation binding for a given type. This is where we handle
-  the special case for GHC.Prim.
-
-* To save space and reduce dependencies, we need use quite low-level
-  representations for TyCon and Module.  See GHC.Types
-  Note [Runtime representation of modules and tycons]
-
-* The KindReps can unfortunately get quite large. Moreover, the simplifier will
-  float out various pieces of them, resulting in numerous top-level bindings.
-  Consequently we mark the KindRep bindings as noinline, ensuring that the
-  float-outs don't make it into the interface file. This is important since
-  there is generally little benefit to inlining KindReps and they would
-  otherwise strongly affect compiler performance.
-
-* In general there are lots of things of kind *, * -> *, and * -> * -> *. To
-  reduce the number of bindings we need to produce, we generate their KindReps
-  once in GHC.Types. These are referred to as "built-in" KindReps below.
-
-* Even though KindReps aren't inlined, this scheme still has more of an effect on
-  compilation time than I'd like. This is especially true in the case of
-  families of type constructors (e.g. tuples and unboxed sums). The problem is
-  particularly bad in the case of sums, since each arity-N tycon brings with it
-  N promoted datacons, each with a KindRep whose size also scales with N.
-  Consequently we currently simply don't allow sums to be Typeable.
-
-  In general we might consider moving some or all of this generation logic back
-  to the solver since the performance hit we take in doing this at
-  type-definition time is non-trivial and Typeable isn't very widely used. This
-  is discussed in #13261.
-
--}
-
--- | Generate the Typeable bindings for a module. This is the only
--- entry-point of this module and is invoked by the typechecker driver in
--- 'tcRnSrcDecls'.
---
--- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable".
-mkTypeableBinds :: TcM TcGblEnv
-mkTypeableBinds
-  = do { dflags <- getDynFlags
-       ; if gopt Opt_NoTypeableBinds dflags then getGblEnv else do
-       { -- Create a binding for $trModule.
-         -- Do this before processing any data type declarations,
-         -- which need tcg_tr_module to be initialised
-       ; tcg_env <- mkModIdBindings
-         -- Now we can generate the TyCon representations...
-         -- First we handle the primitive TyCons if we are compiling GHC.Types
-       ; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos
-
-         -- Then we produce bindings for the user-defined types in this module.
-       ; setGblEnv tcg_env $
-    do { mod <- getModule
-       ; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env)
-             mod_id = case tcg_tr_module tcg_env of  -- Should be set by now
-                        Just mod_id -> mod_id
-                        Nothing     -> pprPanic "tcMkTypeableBinds" (ppr tycons)
-       ; traceTc "mkTypeableBinds" (ppr tycons)
-       ; this_mod_todos <- todoForTyCons mod mod_id tycons
-       ; mkTypeRepTodoBinds (this_mod_todos : prim_todos)
-       } } }
-  where
-    needs_typeable_binds tc
-      | tc `elem` [runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon]
-      = False
-      | otherwise =
-          isAlgTyCon tc
-       || isDataFamilyTyCon tc
-       || isClassTyCon tc
-
-
-{- *********************************************************************
-*                                                                      *
-            Building top-level binding for $trModule
-*                                                                      *
-********************************************************************* -}
-
-mkModIdBindings :: TcM TcGblEnv
-mkModIdBindings
-  = do { mod <- getModule
-       ; loc <- getSrcSpanM
-       ; mod_nm        <- newGlobalBinder mod (mkVarOccFS (fsLit "$trModule")) loc
-       ; trModuleTyCon <- tcLookupTyCon trModuleTyConName
-       ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon [])
-       ; mod_bind      <- mkVarBind mod_id <$> mkModIdRHS mod
-
-       ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
-       ; return (tcg_env { tcg_tr_module = Just mod_id }
-                 `addTypecheckedBinds` [unitBag mod_bind]) }
-
-mkModIdRHS :: Module -> TcM (LHsExpr GhcTc)
-mkModIdRHS mod
-  = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName
-       ; trNameLit <- mkTrNameLit
-       ; return $ nlHsDataCon trModuleDataCon
-                  `nlHsApp` trNameLit (unitFS (moduleUnit mod))
-                  `nlHsApp` trNameLit (moduleNameFS (moduleName mod))
-       }
-
-{- *********************************************************************
-*                                                                      *
-                Building type-representation bindings
-*                                                                      *
-********************************************************************* -}
-
--- | Information we need about a 'TyCon' to generate its representation. We
--- carry the 'Id' in order to share it between the generation of the @TyCon@ and
--- @KindRep@ bindings.
-data TypeableTyCon
-    = TypeableTyCon
-      { tycon        :: !TyCon
-      , tycon_rep_id :: !Id
-      }
-
--- | A group of 'TyCon's in need of type-rep bindings.
-data TypeRepTodo
-    = TypeRepTodo
-      { mod_rep_expr    :: LHsExpr GhcTc    -- ^ Module's typerep binding
-      , pkg_fingerprint :: !Fingerprint     -- ^ Package name fingerprint
-      , mod_fingerprint :: !Fingerprint     -- ^ Module name fingerprint
-      , todo_tycons     :: [TypeableTyCon]
-        -- ^ The 'TyCon's in need of bindings kinds
-      }
-    | ExportedKindRepsTodo [(Kind, Id)]
-      -- ^ Build exported 'KindRep' bindings for the given set of kinds.
-
-todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo
-todoForTyCons mod mod_id tycons = do
-    trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName
-    let mk_rep_id :: TyConRepName -> Id
-        mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy
-
-    let typeable_tycons :: [TypeableTyCon]
-        typeable_tycons =
-            [ TypeableTyCon { tycon = tc''
-                            , tycon_rep_id = mk_rep_id rep_name
-                            }
-            | tc     <- tycons
-            , tc'    <- tc : tyConATs tc
-              -- We need type representations for any associated types
-            , let promoted = map promoteDataCon (tyConDataCons tc')
-            , tc''   <- tc' : promoted
-              -- Don't make bindings for data-family instance tycons.
-              -- Do, however, make them for their promoted datacon (see #13915).
-            , not $ isFamInstTyCon tc''
-            , Just rep_name <- pure $ tyConRepName_maybe tc''
-            , tyConIsTypeable tc''
-            ]
-    return TypeRepTodo { mod_rep_expr    = nlHsVar mod_id
-                       , pkg_fingerprint = pkg_fpr
-                       , mod_fingerprint = mod_fpr
-                       , todo_tycons     = typeable_tycons
-                       }
-  where
-    mod_fpr = fingerprintString $ moduleNameString $ moduleName mod
-    pkg_fpr = fingerprintString $ unitString $ moduleUnit mod
-
-todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo
-todoForExportedKindReps kinds = do
-    trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName
-    let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy)
-    return $ ExportedKindRepsTodo $ map mkId kinds
-
--- | Generate TyCon bindings for a set of type constructors
-mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
-mkTypeRepTodoBinds [] = getGblEnv
-mkTypeRepTodoBinds todos
-  = do { stuff <- collect_stuff
-
-         -- First extend the type environment with all of the bindings
-         -- which we are going to produce since we may need to refer to them
-         -- while generating kind representations (namely, when we want to
-         -- represent a TyConApp in a kind, we must be able to look up the
-         -- TyCon associated with the applied type constructor).
-       ; let produced_bndrs :: [Id]
-             produced_bndrs = [ tycon_rep_id
-                              | todo@(TypeRepTodo{}) <- todos
-                              , TypeableTyCon {..} <- todo_tycons todo
-                              ] ++
-                              [ rep_id
-                              | ExportedKindRepsTodo kinds <- todos
-                              , (_, rep_id) <- kinds
-                              ]
-       ; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv
-
-       ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc]
-             mk_binds todo@(TypeRepTodo {}) =
-                 mapM (mkTyConRepBinds stuff todo) (todo_tycons todo)
-             mk_binds (ExportedKindRepsTodo kinds) =
-                 mkExportedKindReps stuff kinds >> return []
-
-       ; (gbl_env, binds) <- setGblEnv gbl_env
-                             $ runKindRepM (mapM mk_binds todos)
-       ; return $ gbl_env `addTypecheckedBinds` concat binds }
-
--- | Generate bindings for the type representation of a wired-in 'TyCon's
--- defined by the virtual "GHC.Prim" module. This is where we inject the
--- representation bindings for these primitive types into "GHC.Types"
---
--- See Note [Grand plan for Typeable] in this module.
-mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo])
-mkPrimTypeableTodos
-  = do { mod <- getModule
-       ; if mod == gHC_TYPES
-           then do { -- Build Module binding for GHC.Prim
-                     trModuleTyCon <- tcLookupTyCon trModuleTyConName
-                   ; let ghc_prim_module_id =
-                             mkExportedVanillaId trGhcPrimModuleName
-                                                 (mkTyConTy trModuleTyCon)
-
-                   ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id
-                                             <$> mkModIdRHS gHC_PRIM
-
-                     -- Extend our environment with above
-                   ; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id]
-                                                     getGblEnv
-                   ; let gbl_env' = gbl_env `addTypecheckedBinds`
-                                    [unitBag ghc_prim_module_bind]
-
-                     -- Build TypeRepTodos for built-in KindReps
-                   ; todo1 <- todoForExportedKindReps builtInKindReps
-
-                     -- Build TypeRepTodos for types in GHC.Prim
-                   ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id
-                                            ghcPrimTypeableTyCons
-
-                   ; return ( gbl_env' , [todo1, todo2])
-                   }
-           else do gbl_env <- getGblEnv
-                   return (gbl_env, [])
-       }
-
--- | This is the list of primitive 'TyCon's for which we must generate bindings
--- in "GHC.Types". This should include all types defined in "GHC.Prim".
---
--- The majority of the types we need here are contained in 'primTyCons'.
--- However, not all of them: in particular unboxed tuples are absent since we
--- don't want to include them in the original name cache. See
--- Note [Built-in syntax and the OrigNameCache] in "GHC.Iface.Env" for more.
-ghcPrimTypeableTyCons :: [TyCon]
-ghcPrimTypeableTyCons = concat
-    [ [ runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon ]
-    , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE]
-    , map sumTyCon [2..mAX_SUM_SIZE]
-    , primTyCons
-    ]
-
-data TypeableStuff
-    = Stuff { platform       :: Platform        -- ^ Target platform
-            , trTyConDataCon :: DataCon         -- ^ of @TyCon@
-            , trNameLit      :: FastString -> LHsExpr GhcTc
-                                                -- ^ To construct @TrName@s
-              -- The various TyCon and DataCons of KindRep
-            , kindRepTyCon           :: TyCon
-            , kindRepTyConAppDataCon :: DataCon
-            , kindRepVarDataCon      :: DataCon
-            , kindRepAppDataCon      :: DataCon
-            , kindRepFunDataCon      :: DataCon
-            , kindRepTYPEDataCon     :: DataCon
-            , kindRepTypeLitSDataCon :: DataCon
-            , typeLitSymbolDataCon   :: DataCon
-            , typeLitCharDataCon     :: DataCon
-            , typeLitNatDataCon      :: DataCon
-            }
-
--- | Collect various tidbits which we'll need to generate TyCon representations.
-collect_stuff :: TcM TypeableStuff
-collect_stuff = do
-    platform               <- targetPlatform <$> getDynFlags
-    trTyConDataCon         <- tcLookupDataCon trTyConDataConName
-    kindRepTyCon           <- tcLookupTyCon   kindRepTyConName
-    kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName
-    kindRepVarDataCon      <- tcLookupDataCon kindRepVarDataConName
-    kindRepAppDataCon      <- tcLookupDataCon kindRepAppDataConName
-    kindRepFunDataCon      <- tcLookupDataCon kindRepFunDataConName
-    kindRepTYPEDataCon     <- tcLookupDataCon kindRepTYPEDataConName
-    kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName
-    typeLitSymbolDataCon   <- tcLookupDataCon typeLitSymbolDataConName
-    typeLitNatDataCon      <- tcLookupDataCon typeLitNatDataConName
-    typeLitCharDataCon     <- tcLookupDataCon typeLitCharDataConName
-    trNameLit              <- mkTrNameLit
-    return Stuff {..}
-
--- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we
--- can save the work of repeating lookups when constructing many TyCon
--- representations.
-mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc)
-mkTrNameLit = do
-    trNameSDataCon <- tcLookupDataCon trNameSDataConName
-    let trNameLit :: FastString -> LHsExpr GhcTc
-        trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon
-                       `nlHsApp` nlHsLit (mkHsStringPrimLit fs)
-    return trNameLit
-
--- | Make Typeable bindings for the given 'TyCon'.
-mkTyConRepBinds :: TypeableStuff -> TypeRepTodo
-                -> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
-mkTyConRepBinds stuff todo (TypeableTyCon {..})
-  = do -- Make a KindRep
-       let (bndrs, kind) = splitForAllForAllTyBinders (tyConKind tycon)
-       liftTc $ traceTc "mkTyConKindRepBinds"
-                        (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind)
-       let ctx = mkDeBruijnContext (map binderVar bndrs)
-       kind_rep <- getKindRep stuff ctx kind
-
-       -- Make the TyCon binding
-       let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep
-           tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs
-       return $ unitBag tycon_rep_bind
-
--- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type
--- families and polytypes.
-tyConIsTypeable :: TyCon -> Bool
-tyConIsTypeable tc = isJust (tyConRepName_maybe tc)
-                  && kindIsTypeable (dropForAlls $ tyConKind tc)
-
--- | Is a particular 'Kind' representable by @Typeable@? Here we look for
--- polytypes and types containing casts (which may be, for instance, a type
--- family).
-kindIsTypeable :: Kind -> Bool
--- We handle types of the form (TYPE LiftedRep) specifically to avoid
--- looping on (tyConIsTypeable RuntimeRep). We used to consider (TYPE rr)
--- to be typeable without inspecting rr, but this exhibits bad behavior
--- when rr is a type family.
-kindIsTypeable ty
-  | Just ty' <- coreView ty         = kindIsTypeable ty'
-kindIsTypeable ty
-  | isLiftedTypeKind ty             = True
-kindIsTypeable (TyVarTy _)          = True
-kindIsTypeable (AppTy a b)          = kindIsTypeable a && kindIsTypeable b
-kindIsTypeable (FunTy _ w a b)      = kindIsTypeable w &&
-                                      kindIsTypeable a &&
-                                      kindIsTypeable b
-kindIsTypeable (TyConApp tc args)   = tyConIsTypeable tc
-                                   && all kindIsTypeable args
-kindIsTypeable (ForAllTy{})         = False
-kindIsTypeable (LitTy _)            = True
-kindIsTypeable (CastTy{})           = False
-  -- See Note [Typeable instances for casted types]
-kindIsTypeable (CoercionTy{})       = False
-
--- | Maps kinds to 'KindRep' bindings. This binding may either be defined in
--- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing')
--- or a binding which we generated in the current module (in which case it will
--- be 'Just' the RHS of the binding).
-type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc))
-
--- | A monad within which we will generate 'KindRep's. Here we keep an
--- environment containing 'KindRep's which we've already generated so we can
--- re-use them opportunistically.
-newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a }
-                   deriving (Functor, Applicative, Monad)
-
-liftTc :: TcRn a -> KindRepM a
-liftTc = KindRepM . lift
-
--- | We generate `KindRep`s for a few common kinds, so that they
--- can be reused across modules.
--- These definitions are generated in `ghc-prim:GHC.Types`.
-builtInKindReps :: [(Kind, Name)]
-builtInKindReps =
-    [ (star,                              starKindRepName)
-    , (constraintKind,                    constraintKindRepName)
-    , (mkVisFunTyMany star star,          starArrStarKindRepName)
-    , (mkVisFunTysMany [star, star] star, starArrStarArrStarKindRepName)
-    ]
-  where
-    star = liftedTypeKind
-
-initialKindRepEnv :: TcRn KindRepEnv
-initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps
-  where
-    add_kind_rep acc (k,n) = do
-        id <- tcLookupId n
-        return $! extendTypeMap acc k (id, Nothing)
-        -- The TypeMap looks through type synonyms
-
--- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's.
-mkExportedKindReps :: TypeableStuff
-                   -> [(Kind, Id)]  -- ^ the kinds to generate bindings for
-                   -> KindRepM ()
-mkExportedKindReps stuff = mapM_ kindrep_binding
-  where
-    empty_scope = mkDeBruijnContext []
-
-    kindrep_binding :: (Kind, Id) -> KindRepM ()
-    kindrep_binding (kind, rep_bndr) = do
-        -- We build the binding manually here instead of using mkKindRepRhs
-        -- since the latter would find the built-in 'KindRep's in the
-        -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv').
-        rhs <- mkKindRepRhs stuff empty_scope kind
-        liftTc (traceTc "mkExport" (ppr kind $$ ppr rep_bndr $$ ppr rhs))
-        addKindRepBind empty_scope kind rep_bndr rhs
-
-addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM ()
-addKindRepBind in_scope k bndr rhs =
-    KindRepM $ modify' $
-    \env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs)
-
--- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking
--- environment.
-runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a)
-runKindRepM (KindRepM action) = do
-    kindRepEnv <- initialKindRepEnv
-    (res, reps_env) <- runStateT action kindRepEnv
-    let rep_binds = foldTypeMap to_bind_pair [] reps_env
-        to_bind_pair (bndr, Just rhs) rest = (bndr, rhs) : rest
-        to_bind_pair (_, Nothing) rest = rest
-    tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv
-    let binds = map (uncurry mkVarBind) rep_binds
-        tcg_env' = tcg_env `addTypecheckedBinds` [listToBag binds]
-    return (tcg_env', res)
-
--- | Produce or find a 'KindRep' for the given kind.
-getKindRep :: TypeableStuff -> CmEnv  -- ^ in-scope kind variables
-           -> Kind   -- ^ the kind we want a 'KindRep' for
-           -> KindRepM (LHsExpr GhcTc)
-getKindRep stuff@(Stuff {..}) in_scope = go
-  where
-    go :: Kind -> KindRepM (LHsExpr GhcTc)
-    go = KindRepM . StateT . go'
-
-    go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
-    go' k env
-        -- We've already generated the needed KindRep
-        -- This lookup looks through synonyms
-      | Just (id, _) <- lookupTypeMapWithScope env in_scope k
-      = return (nlHsVar id, env)
-
-        -- We need to construct a new KindRep binding
-      | otherwise
-      = do -- Place a NOINLINE pragma on KindReps since they tend to be quite
-           -- large and bloat interface files.
-           rep_bndr <- (`setInlinePragma` neverInlinePragma)
-                   <$> newSysLocalId (fsLit "$krep") ManyTy (mkTyConTy kindRepTyCon)
-
-           -- do we need to tie a knot here?
-           flip runStateT env $ unKindRepM $ do
-               rhs <- mkKindRepRhs stuff in_scope k
-               addKindRepBind in_scope k rep_bndr rhs
-               return $ nlHsVar rep_bndr
-
--- | Construct the right-hand-side of the 'KindRep' for the given 'Kind' and
--- in-scope kind variable set.
-mkKindRepRhs :: TypeableStuff
-             -> CmEnv       -- ^ in-scope kind variables
-             -> Kind        -- ^ the kind we want a 'KindRep' for
-             -> KindRepM (LHsExpr GhcTc) -- ^ RHS expression
-mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep_shortcut
-  where
-    new_kind_rep_shortcut k
-        -- We handle (TYPE LiftedRep) etc separately to make it
-        -- clear to consumers (e.g. serializers) that there is
-        -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep)
-      | Just (TypeLike, rep) <- sORTKind_maybe k
-              -- Typeable respects the Constraint/Type distinction
-              -- so do not follow the special case here
-      = -- Here k = TYPE <something>
-        case splitTyConApp_maybe rep of
-          Just (tc, [])         -- TYPE IntRep, TYPE FloatRep etc
-            | Just dc <- isPromotedDataCon_maybe tc
-              -> return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc
-
-          Just (rep_tc, [levArg])  -- TYPE (BoxedRep lev)
-            | Just dcRep <- isPromotedDataCon_maybe rep_tc
-            , Just (lev_tc, []) <- splitTyConApp_maybe levArg
-            , Just dcLev <- isPromotedDataCon_maybe lev_tc
-              -> return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` (nlHsDataCon dcRep `nlHsApp` nlHsDataCon dcLev)
-
-          _   -> new_kind_rep k
-      | otherwise = new_kind_rep k
-
-    new_kind_rep ki  -- Expand synonyms
-      | Just ki' <- coreView ki
-      = new_kind_rep ki'
-
-    new_kind_rep (TyVarTy v)
-      | Just idx <- lookupCME in_scope v
-      = return $ nlHsDataCon kindRepVarDataCon
-                 `nlHsApp` nlHsIntLit (fromIntegral idx)
-      | otherwise
-      = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v)
-
-    new_kind_rep (AppTy t1 t2)
-      = do rep1 <- getKindRep stuff in_scope t1
-           rep2 <- getKindRep stuff in_scope t2
-           return $ nlHsDataCon kindRepAppDataCon
-                    `nlHsApp` rep1 `nlHsApp` rep2
-
-    new_kind_rep k@(TyConApp tc tys)
-      | Just rep_name <- tyConRepName_maybe tc
-      = do rep_id <- liftTc $ lookupId rep_name
-           tys' <- mapM (getKindRep stuff in_scope) tys
-           return $ nlHsDataCon kindRepTyConAppDataCon
-                    `nlHsApp` nlHsVar rep_id
-                    `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys'
-      | otherwise
-      = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k)
-
-    new_kind_rep (ForAllTy (Bndr var _) ty)
-      = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty)
-
-    new_kind_rep (FunTy _ _ t1 t2)
-      = do rep1 <- getKindRep stuff in_scope t1
-           rep2 <- getKindRep stuff in_scope t2
-           return $ nlHsDataCon kindRepFunDataCon
-                    `nlHsApp` rep1 `nlHsApp` rep2
-
-    new_kind_rep (LitTy (NumTyLit n))
-      = return $ nlHsDataCon kindRepTypeLitSDataCon
-                 `nlHsApp` nlHsDataCon typeLitNatDataCon
-                 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n)
-
-    new_kind_rep (LitTy (StrTyLit s))
-      = return $ nlHsDataCon kindRepTypeLitSDataCon
-                 `nlHsApp` nlHsDataCon typeLitSymbolDataCon
-                 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s)
-
-    new_kind_rep (LitTy (CharTyLit c))
-      = return $ nlHsDataCon kindRepTypeLitSDataCon
-                 `nlHsApp` nlHsDataCon typeLitCharDataCon
-                 `nlHsApp` nlHsLit (mkHsCharPrimLit c)
-
-    -- See Note [Typeable instances for casted types]
-    new_kind_rep (CastTy ty co)
-      = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co)
-
-    new_kind_rep (CoercionTy co)
-      = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co)
-
--- | Produce the right-hand-side of a @TyCon@ representation.
-mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo
-                   -> TyCon      -- ^ the 'TyCon' we are producing a binding for
-                   -> LHsExpr GhcTc -- ^ its 'KindRep'
-                   -> LHsExpr GhcTc
-mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep
-  =           nlHsDataCon trTyConDataCon
-    `nlHsApp` nlHsLit (HsWord64Prim NoSourceText (toInteger high))
-    `nlHsApp` nlHsLit (HsWord64Prim NoSourceText (toInteger low))
-    `nlHsApp` mod_rep_expr todo
-    `nlHsApp` trNameLit (mkFastString tycon_str)
-    `nlHsApp` nlHsLit (HsIntPrim NoSourceText (toInteger n_kind_vars))
-    `nlHsApp` kind_rep
-  where
-    n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon)
-    tycon_str = add_tick (occNameString (getOccName tycon))
-    add_tick s | isDataKindsPromotedDataCon tycon = '\'' : s
-               | otherwise               = s
-
-    -- This must match the computation done in
-    -- Data.Typeable.Internal.mkTyConFingerprint.
-    Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo
-                                                   , mod_fingerprint todo
-                                                   , fingerprintString tycon_str
-                                                   ]
-
-{-
-Note [Representing TyCon kinds: KindRep]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-One of the operations supported by Typeable is typeRepKind,
-
-    typeRepKind :: TypeRep (a :: k) -> TypeRep k
-
-Implementing this is a bit tricky for poly-kinded types like
-
-    data Proxy (a :: k) :: Type
-    -- Proxy :: forall k. k -> Type
-
-The TypeRep encoding of `Proxy Type Int` looks like this:
-
-    $tcProxy :: GHC.Types.TyCon
-    $trInt   :: TypeRep Int
-    TrType   :: TypeRep Type
-
-    $trProxyType :: TypeRep (Proxy Type :: Type -> Type)
-    $trProxyType = TrTyCon $tcProxy
-                           [TrType]  -- kind variable instantiation
-                           (tyConKind $tcProxy [TrType]) -- The TypeRep of
-                                                         -- Type -> Type
-
-    $trProxy :: TypeRep (Proxy Type Int)
-    $trProxy = TrApp $trProxyType $trInt TrType
-
-    $tkProxy :: GHC.Types.KindRep
-    $tkProxy = KindRepFun (KindRepVar 0)
-                          (KindRepTyConApp (KindRepTYPE LiftedRep) [])
-
-Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent
-polymorphic types.  So instead
-
- * $trProxyType uses 'TrTyCon' to apply Proxy to (the representations)
-   of all its kind arguments. We can't represent a tycon that is
-   applied to only some of its kind arguments.
-
- * In $tcProxy, the GHC.Types.TyCon structure for Proxy, we store a
-   GHC.Types.KindRep, which represents the polymorphic kind of Proxy
-       Proxy :: forall k. k->Type
-
- * A KindRep is just a recipe that we can instantiate with the
-   argument kinds, using Data.Typeable.Internal.tyConKind and
-   store in the relevant 'TypeRep' constructor.
-
-   Data.Typeable.Internal.typeRepKind looks up the stored kinds.
-
- * In a KindRep, the kind variables are represented by 0-indexed
-   de Bruijn numbers:
-
-    type KindBndr = Int   -- de Bruijn index
-
-    data KindRep = KindRepTyConApp TyCon [KindRep]
-                 | KindRepVar !KindBndr
-                 | KindRepApp KindRep KindRep
-                 | KindRepFun KindRep KindRep
-                 ...
-
-Note [Typeable instances for casted types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-At present, GHC does not manufacture TypeReps for types containing casts
-(#16835). In theory, GHC could do so today, but it might be dangerous tomorrow.
-
-In today's GHC, we normalize all types before computing their TypeRep.
-For example:
-
-    type family F a
-    type instance F Int = Type
-
-    data D = forall (a :: F Int). MkD a
-
-    tr :: TypeRep (MkD Bool)
-    tr = typeRep
-
-When computing the TypeRep for `MkD Bool` (or rather,
-`MkD (Bool |> Sym (FInt[0]))`), we simply discard the cast to obtain the
-TypeRep for `MkD Bool`.
-
-Why does this work? If we have a type definition with casts, then the
-only coercions that those casts can mention are either Refl, type family
-axioms, built-in axioms, and coercions built from those roots. Therefore,
-type family (and built-in) axioms will apply precisely when type normalization
-succeeds (i.e, the type family applications are reducible). Therefore, it
-is safe to ignore the cast entirely when constructing the TypeRep.
-
-This approach would be fragile in a future where GHC permits other forms of
-coercions to appear in casts (e.g., coercion quantification as described
-in #15710). If GHC permits local assumptions to appear in casts that cannot be
-reduced with conventional normalization, then discarding casts would become
-unsafe. It would be unfortunate for the Typeable solver to become a roadblock
-obstructing such a future, so we deliberately do not implement the ability
-for TypeReps to represent types with casts at the moment.
-
-If we do wish to allow this in the future, it will likely require modeling
-casts and coercions in TypeReps themselves.
--}
-
-mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc
-mkList ty = foldr consApp (nilExpr ty)
-  where
-    cons = consExpr ty
-    consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
-    consApp x xs = cons `nlHsApp` x `nlHsApp` xs
-
-    nilExpr :: Type -> LHsExpr GhcTc
-    nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon)
-
-    consExpr :: Type -> LHsExpr GhcTc
-    consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon)
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Module.hs
+++ /dev/null
@@ -1,3228 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NondecreasingIndentation #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE TupleSections #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
--- | Typechecking a whole module
---
--- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker
-module GHC.Tc.Module (
-        tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,
-        tcRnImportDecls,
-        tcRnLookupRdrName,
-        getModuleInterface,
-        tcRnDeclsi,
-        isGHCiMonad,
-        runTcInteractive,    -- Used by GHC API clients (#8878)
-        withTcPlugins,       -- Used by GHC API clients (#20499)
-        withHoleFitPlugins,  -- Used by GHC API clients (#20499)
-        tcRnLookupName,
-        tcRnGetInfo,
-        tcRnModule, tcRnModuleTcRnM,
-        tcTopSrcDecls,
-        rnTopSrcDecls,
-        checkBootDecl, checkHiBootIface',
-        findExtraSigImports,
-        implicitRequirements,
-        checkUnit,
-        mergeSignatures,
-        tcRnMergeSignatures,
-        instantiateSignature,
-        tcRnInstantiateSignature,
-        loadUnqualIfaces,
-        -- More private...
-        badReexportedBootThing,
-        checkBootDeclM,
-        missingBootThing,
-        getRenamedStuff, RenamedStuff
-    ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Env
-import GHC.Driver.Plugins
-import GHC.Driver.Session
-import GHC.Driver.Config.Diagnostic
-
-import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) )
-import GHC.Tc.Errors.Types
-import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers )
-import GHC.Tc.Gen.HsType
-import GHC.Tc.Validity( checkValidType )
-import GHC.Tc.Gen.Match
-import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma )
-import GHC.Tc.Utils.Zonk
-import GHC.Tc.Gen.Expr
-import GHC.Tc.Gen.App( tcInferSigma )
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Gen.Export
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Origin
-import GHC.Tc.Instance.Family
-import GHC.Tc.Gen.Annotation
-import GHC.Tc.Gen.Bind
-import GHC.Tc.Gen.Default
-import GHC.Tc.Utils.Env
-import GHC.Tc.Gen.Rule
-import GHC.Tc.Gen.Foreign
-import GHC.Tc.TyCl.Instance
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.Instantiate (tcGetInsts)
-import GHC.Tc.Solver
-import GHC.Tc.TyCl
-import GHC.Tc.Instance.Typeable ( mkTypeableBinds )
-import GHC.Tc.Utils.Backpack
-
-import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
-import GHC.Rename.HsType
-import GHC.Rename.Expr
-import GHC.Rename.Fixity ( lookupFixityRn )
-import GHC.Rename.Names
-import GHC.Rename.Env
-import GHC.Rename.Module
-import GHC.Rename.Doc
-
-import GHC.Iface.Syntax   ( ShowSub(..), showToHeader )
-import GHC.Iface.Type     ( ShowForAllFlag(..) )
-import GHC.Iface.Env     ( externaliseName )
-import GHC.Iface.Make   ( coAxiomToIfaceDecl )
-import GHC.Iface.Load
-
-import GHC.Builtin.Types ( unitTy, mkListTy )
-import GHC.Builtin.Names
-import GHC.Builtin.Utils
-
-import GHC.Hs
-import GHC.Hs.Dump
-
-import GHC.Core.PatSyn    ( pprPatSynType )
-import GHC.Core.Predicate ( classMethodTy )
-import GHC.Core.FVs         ( orphNamesOfFamInst )
-import GHC.Core.InstEnv
-import GHC.Core.TyCon
-import GHC.Core.ConLike
-import GHC.Core.DataCon
-import GHC.Core.Type
-import GHC.Core.Class
-import GHC.Core.Coercion.Axiom
-import GHC.Core.Reduction ( Reduction(..) )
-import GHC.Core.RoughMap( RoughMatchTc(..) )
-import GHC.Core.TyCo.Ppr( debugPprType )
-import GHC.Core.FamInstEnv
-   ( FamInst, pprFamInst, famInstsRepTyCons
-   , famInstEnvElts, extendFamInstEnvList, normaliseType )
-
-import GHC.Parser.Header       ( mkPrelImports )
-
-import GHC.IfaceToCore
-
-import GHC.Runtime.Context
-
-import GHC.Utils.Error
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Misc
-import GHC.Utils.Logger
-
-import GHC.Types.Error
-import GHC.Types.Name.Reader
-import GHC.Types.Fixity.Env
-import GHC.Types.Id as Id
-import GHC.Types.Id.Info( IdDetails(..) )
-import GHC.Types.Var.Env
-import GHC.Types.TypeEnv
-import GHC.Types.Unique.FM
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.Name.Set
-import GHC.Types.Avail
-import GHC.Types.Basic hiding( SuccessFlag(..) )
-import GHC.Types.Annotations
-import GHC.Types.SrcLoc
-import GHC.Types.SourceFile
-import GHC.Types.TyThing.Ppr ( pprTyThingInContext )
-import GHC.Types.PkgQual
-import qualified GHC.LanguageExtensions as LangExt
-
-import GHC.Unit.External
-import GHC.Unit.Types
-import GHC.Unit.State
-import GHC.Unit.Home
-import GHC.Unit.Module
-import GHC.Unit.Module.Warnings
-import GHC.Unit.Module.ModSummary
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.ModDetails
-import GHC.Unit.Module.Deps
-
-import GHC.Data.FastString
-import GHC.Data.Maybe
-import GHC.Data.List.SetOps
-import GHC.Data.Bag
-import qualified GHC.Data.BooleanFormula as BF
-
-import Data.Functor.Classes ( liftEq )
-import Data.List ( sortBy, sort )
-import Data.List.NonEmpty ( NonEmpty (..) )
-import qualified Data.List.NonEmpty as NE
-import Data.Ord
-import Data.Data ( Data )
-import qualified Data.Set as S
-import Control.DeepSeq
-import Control.Monad
-
-{-
-************************************************************************
-*                                                                      *
-        Typecheck and rename a module
-*                                                                      *
-************************************************************************
--}
-
--- | Top level entry point for typechecker and renamer
-tcRnModule :: HscEnv
-           -> ModSummary
-           -> Bool              -- True <=> save renamed syntax
-           -> HsParsedModule
-           -> IO (Messages TcRnMessage, Maybe TcGblEnv)
-
-tcRnModule hsc_env mod_sum save_rn_syntax
-   parsedModule@HsParsedModule {hpm_module= L loc this_module}
- | RealSrcSpan real_loc _ <- loc
- = withTiming logger
-              (text "Renamer/typechecker"<+>brackets (ppr this_mod))
-              (const ()) $
-   initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
-          withTcPlugins hsc_env $
-          withDefaultingPlugins hsc_env $
-          withHoleFitPlugins hsc_env $
-
-          tcRnModuleTcRnM hsc_env mod_sum parsedModule pair
-
-  | otherwise
-  = return (err_msg `addMessage` emptyMessages, Nothing)
-
-  where
-    hsc_src = ms_hsc_src mod_sum
-    logger  = hsc_logger hsc_env
-    home_unit = hsc_home_unit hsc_env
-    err_msg = mkPlainErrorMsgEnvelope loc $
-              TcRnModMissingRealSrcSpan this_mod
-
-    pair :: (Module, SrcSpan)
-    pair@(this_mod,_)
-      | Just (L mod_loc mod) <- hsmodName this_module
-      = (mkHomeModule home_unit mod, locA mod_loc)
-
-      | otherwise   -- 'module M where' is omitted
-      = (mkHomeModule home_unit mAIN_NAME, srcLocSpan (srcSpanStart loc))
-
-
-
-
-tcRnModuleTcRnM :: HscEnv
-                -> ModSummary
-                -> HsParsedModule
-                -> (Module, SrcSpan)
-                -> TcRn TcGblEnv
--- Factored out separately from tcRnModule so that a Core plugin can
--- call the type checker directly
-tcRnModuleTcRnM hsc_env mod_sum
-                (HsParsedModule {
-                   hpm_module =
-                      (L loc (HsModule (XModulePs _ _ mod_deprec maybe_doc_hdr)
-                                       maybe_mod export_ies import_decls local_decls)),
-                   hpm_src_files = src_files
-                })
-                (this_mod, prel_imp_loc)
- = setSrcSpan loc $
-   do { let { explicit_mod_hdr = isJust maybe_mod
-            ; hsc_src          = ms_hsc_src mod_sum }
-      ; -- Load the hi-boot interface for this module, if any
-        -- We do this now so that the boot_names can be passed
-        -- to tcTyAndClassDecls, because the boot_names are
-        -- automatically considered to be loop breakers
-        tcg_env <- getGblEnv
-      ; boot_info <- tcHiBootIface hsc_src this_mod
-      ; setGblEnv (tcg_env { tcg_self_boot = boot_info })
-        $ do
-        { -- Deal with imports; first add implicit prelude
-          implicit_prelude <- xoptM LangExt.ImplicitPrelude
-        ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
-                               implicit_prelude import_decls }
-
-        ; when (notNull prel_imports) $ do
-            let msg = mkTcRnUnknownMessage $
-                        mkPlainDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) noHints (implicitPreludeWarn)
-            addDiagnostic msg
-
-        ; -- TODO This is a little skeevy; maybe handle a bit more directly
-          let { simplifyImport (L _ idecl) =
-                  ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl)
-                  , reLoc $ ideclName idecl)
-              }
-        ; raw_sig_imports <- liftIO
-                             $ findExtraSigImports hsc_env hsc_src
-                                 (moduleName this_mod)
-        ; raw_req_imports <- liftIO
-                             $ implicitRequirements hsc_env
-                                (map simplifyImport (prel_imports
-                                                     ++ import_decls))
-        ; let { mkImport mod_name = noLocA
-                $ (simpleImportDecl mod_name)
-                  { ideclImportList = Just (Exactly, noLocA [])}}
-        ; let { withReason t imps = map (,text t) imps }
-        ; let { all_imports = withReason "is implicitly imported" prel_imports
-                  ++ withReason "is directly imported" import_decls
-                  ++ withReason "is an extra sig import" (map mkImport raw_sig_imports)
-                  ++ withReason "is an implicit req import" (map mkImport raw_req_imports) }
-        ; -- OK now finally rename the imports
-          tcg_env <- {-# SCC "tcRnImports" #-}
-                     tcRnImports hsc_env all_imports
-
-        -- Put a version of the header without identifier info into the tcg_env
-        -- Make sure to do this before 'tcRnSrcDecls', because we need the
-        -- module header when we're splicing TH, since it can be accessed via
-        -- 'getDoc'.
-        -- We will rename it properly after renaming everything else so that
-        -- haddock can link the identifiers
-        ; tcg_env <- return (tcg_env
-                              { tcg_doc_hdr = fmap (\(WithHsDocIdentifiers str _) -> WithHsDocIdentifiers str [])
-                                                                                 <$> maybe_doc_hdr })
-        ; -- If the whole module is warned about or deprecated
-          -- (via mod_deprec) record that in tcg_warns. If we do thereby add
-          -- a WarnAll, it will override any subsequent deprecations added to tcg_warns
-        ; tcg_env1 <- case mod_deprec of
-                             Just (L _ txt) -> do { txt' <- rnWarningTxt txt
-                                                  ; pure $ tcg_env {tcg_warns = WarnAll txt'}
-                                                  }
-                             Nothing            -> pure tcg_env
-        ; setGblEnv tcg_env1
-          $ do { -- Rename and type check the declarations
-                 traceRn "rn1a" empty
-               ; tcg_env <- if isHsBootOrSig hsc_src
-                            then do {
-                              ; tcg_env <- tcRnHsBootDecls hsc_src local_decls
-                              ; traceRn "rn4a: before exports" empty
-                              ; tcg_env <- setGblEnv tcg_env $
-                                           rnExports explicit_mod_hdr export_ies
-                              ; traceRn "rn4b: after exports" empty
-                              ; return tcg_env
-                              }
-                            else {-# SCC "tcRnSrcDecls" #-}
-                                 tcRnSrcDecls explicit_mod_hdr export_ies local_decls
-
-               ; whenM (goptM Opt_DoCoreLinting) $
-                 lintGblEnv (hsc_logger hsc_env) (hsc_dflags hsc_env) tcg_env
-
-               ; setGblEnv tcg_env
-                 $ do { -- Compare hi-boot iface (if any) with the real thing
-                        -- Must be done after processing the exports
-                        tcg_env <- checkHiBootIface tcg_env boot_info
-                      ; -- The new type env is already available to stuff
-                        -- slurped from interface files, via
-                        -- GHC.Tc.Utils.Env.setGlobalTypeEnv. It's important that this
-                        -- includes the stuff in checkHiBootIface,
-                        -- because the latter might add new bindings for
-                        -- boot_dfuns, which may be mentioned in imported
-                        -- unfoldings.
-                      ; -- Report unused names
-                        -- Do this /after/ typeinference, so that when reporting
-                        -- a function with no type signature we can give the
-                        -- inferred type
-                      ; reportUnusedNames tcg_env hsc_src
-
-                      -- Rename the module header properly after we have renamed everything else
-                      ; maybe_doc_hdr <- traverse rnLHsDoc maybe_doc_hdr;
-                      ; tcg_env <- return (tcg_env
-                                            { tcg_doc_hdr = maybe_doc_hdr })
-
-                      ; -- add extra source files to tcg_dependent_files
-                        addDependentFiles src_files
-                        -- Ensure plugins run with the same tcg_env that we pass in
-                      ; setGblEnv tcg_env
-                        $ do { tcg_env <- runTypecheckerPlugin mod_sum tcg_env
-                             ; -- Dump output and return
-                               tcDump tcg_env
-                             ; return tcg_env
-                             }
-                      }
-               }
-        }
-      }
-
-implicitPreludeWarn :: SDoc
-implicitPreludeWarn
-  = text "Module `Prelude' implicitly imported"
-
-{-
-************************************************************************
-*                                                                      *
-                Import declarations
-*                                                                      *
-************************************************************************
--}
-
-tcRnImports :: HscEnv -> [(LImportDecl GhcPs, SDoc)] -> TcM TcGblEnv
-tcRnImports hsc_env import_decls
-  = do  { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;
-
-        ; this_mod <- getModule
-        ; gbl_env <- getGblEnv
-        ; let { -- We want instance declarations from all home-package
-                -- modules below this one, including boot modules, except
-                -- ourselves.  The 'except ourselves' is so that we don't
-                -- get the instances from this module's hs-boot file.  This
-                -- filtering also ensures that we don't see instances from
-                -- modules batch (@--make@) compiled before this one, but
-                -- which are not below this one.
-              ; (home_insts, home_fam_insts) =
-
-                    hptInstancesBelow hsc_env (homeUnitId $ hsc_home_unit hsc_env) (GWIB (moduleName this_mod)(hscSourceToIsBoot (tcg_src gbl_env)))
-
-              } ;
-
-                -- Record boot-file info in the EPS, so that it's
-                -- visible to loadHiBootInterface in tcRnSrcDecls,
-                -- and any other incrementally-performed imports
-              ; when (isOneShot (ghcMode (hsc_dflags hsc_env))) $ do {
-                  updateEps_ $ \eps  -> eps { eps_is_boot = imp_boot_mods imports }
-               }
-
-                -- Update the gbl env
-        ; updGblEnv ( \ gbl ->
-            gbl {
-              tcg_rdr_env      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
-              tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
-              tcg_rn_imports   = rn_imports,
-              tcg_inst_env     = tcg_inst_env gbl `unionInstEnv` home_insts,
-              tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
-                                                      home_fam_insts,
-              tcg_hpc          = hpc_info
-            }) $ do {
-
-        ; traceRn "rn1" (ppr (imp_direct_dep_mods imports))
-                -- Fail if there are any errors so far
-                -- The error printing (if needed) takes advantage
-                -- of the tcg_env we have now set
---      ; traceIf (text "rdr_env: " <+> ppr rdr_env)
-        ; failIfErrsM
-
-                -- Load any orphan-module (including orphan family
-                -- instance-module) interfaces, so that their rules and
-                -- instance decls will be found.  But filter out a
-                -- self hs-boot: these instances will be checked when
-                -- we define them locally.
-                -- (We don't need to load non-orphan family instance
-                -- modules until we either try to use the instances they
-                -- define, or define our own family instances, at which
-                -- point we need to check them for consistency.)
-        ; loadModuleInterfaces (text "Loading orphan modules")
-                               (filter (/= this_mod) (imp_orphs imports))
-
-                -- Check type-family consistency between imports.
-                -- See Note [The type family instance consistency story]
-        ; traceRn "rn1: checking family instance consistency {" empty
-        ; let { dir_imp_mods = moduleEnvKeys
-                             . imp_mods
-                             $ imports }
-        ; checkFamInstConsistency dir_imp_mods
-        ; traceRn "rn1: } checking family instance consistency" empty
-
-        ; getGblEnv } }
-
-{-
-************************************************************************
-*                                                                      *
-        Type-checking the top level of a module
-*                                                                      *
-************************************************************************
--}
-
-tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
-             -> Maybe (LocatedL [LIE GhcPs])
-             -> [LHsDecl GhcPs]               -- Declarations
-             -> TcM TcGblEnv
-tcRnSrcDecls explicit_mod_hdr export_ies decls
- = do { -- Do all the declarations
-      ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls
-
-      ------ Simplify constraints ---------
-      --
-      -- We do this after checkMainType, so that we use the type
-      -- info that checkMainType adds
-      --
-      -- We do it with both global and local env in scope:
-      --  * the global env exposes the instances to simplifyTop,
-      --    and affects how names are rendered in error messages
-      --  * the local env exposes the local Ids to simplifyTop,
-      --    so that we get better error messages (monomorphism restriction)
-      ; new_ev_binds <- {-# SCC "simplifyTop" #-}
-                        restoreEnvs (tcg_env, tcl_env) $
-                        do { lie_main <- checkMainType tcg_env
-                           ; simplifyTop (lie `andWC` lie_main) }
-
-        -- Emit Typeable bindings
-      ; tcg_env <- setGblEnv tcg_env $
-                   mkTypeableBinds
-
-      ; traceTc "Tc9" empty
-      ; failIfErrsM    -- Stop now if if there have been errors
-                       -- Continuing is a waste of time; and we may get debug
-                       -- warnings when zonking about strangely-typed TyCons!
-
-        -- Zonk the final code.  This must be done last.
-        -- Even simplifyTop may do some unification.
-        -- This pass also warns about missing type signatures
-      ; (id_env, ev_binds', binds', fords', imp_specs', rules')
-            <- zonkTcGblEnv new_ev_binds tcg_env
-
-      --------- Run finalizers --------------
-      -- Finalizers must run after constraints are simplified, lest types
-      --    might not be complete when using reify (see #12777).
-      -- and also after we zonk the first time because we run typed splices
-      --    in the zonker which gives rise to the finalisers.
-      ; let -- init_tcg_env:
-            --   * Remove accumulated bindings, rules and so on from
-            --     TcGblEnv.  They are now in ev_binds', binds', etc.
-            --   * Add the zonked Ids from the value bindings to tcg_type_env
-            --     Up to now these Ids are only in tcl_env's type-envt
-            init_tcg_env = tcg_env { tcg_binds     = emptyBag
-                                   , tcg_ev_binds  = emptyBag
-                                   , tcg_imp_specs = []
-                                   , tcg_rules     = []
-                                   , tcg_fords     = []
-                                   , tcg_type_env  = tcg_type_env tcg_env
-                                                     `plusTypeEnv` id_env }
-      ; (tcg_env, tcl_env) <- setGblEnv init_tcg_env
-                              run_th_modfinalizers
-      ; finishTH
-      ; traceTc "Tc11" empty
-
-      --------- Deal with the exports ----------
-      -- Can't be done earlier, because the export list must "see"
-      -- the declarations created by the finalizers
-      ; tcg_env <- restoreEnvs (tcg_env, tcl_env) $
-                   rnExports explicit_mod_hdr export_ies
-
-      --------- Emit the ':Main.main = runMainIO main' declaration ----------
-      -- Do this /after/ rnExports, so that it can consult
-      -- the tcg_exports created by rnExports
-      ; (tcg_env, main_ev_binds)
-           <- restoreEnvs (tcg_env, tcl_env) $
-              do { (tcg_env, lie) <- captureTopConstraints $
-                                     checkMain explicit_mod_hdr export_ies
-                 ; ev_binds <- simplifyTop lie
-                 ; return (tcg_env, ev_binds) }
-
-      ; failIfErrsM    -- Stop now if if there have been errors
-                       -- Continuing is a waste of time; and we may get debug
-                       -- warnings when zonking about strangely-typed TyCons!
-
-      ---------- Final zonking ---------------
-      -- Zonk the new bindings arising from running the finalisers,
-      -- and main. This won't give rise to any more finalisers as you
-      -- can't nest finalisers inside finalisers.
-      ; (id_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf)
-            <- zonkTcGblEnv main_ev_binds tcg_env
-
-      ; let { !final_type_env = tcg_type_env tcg_env
-                                `plusTypeEnv` id_env_mf
-              -- Add the zonked Ids from the value bindings (they were in tcl_env)
-              -- Force !final_type_env, lest we retain an old reference
-              -- to the previous tcg_env
-
-            ; tcg_env' = tcg_env
-                          { tcg_binds     = binds'    `unionBags` binds_mf
-                          , tcg_ev_binds  = ev_binds' `unionBags` ev_binds_mf
-                          , tcg_imp_specs = imp_specs' ++ imp_specs_mf
-                          , tcg_rules     = rules'     ++ rules_mf
-                          , tcg_fords     = fords'     ++ fords_mf } } ;
-
-      ; setGlobalTypeEnv tcg_env' final_type_env
-   }
-
-zonkTcGblEnv :: Bag EvBind -> TcGblEnv
-             -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc,
-                       [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc])
-zonkTcGblEnv ev_binds tcg_env@(TcGblEnv { tcg_binds     = binds
-                                        , tcg_ev_binds  = cur_ev_binds
-                                        , tcg_imp_specs = imp_specs
-                                        , tcg_rules     = rules
-                                        , tcg_fords     = fords })
-  = {-# SCC "zonkTopDecls" #-}
-    setGblEnv tcg_env $ -- This sets the GlobalRdrEnv which is used when rendering
-                        --   error messages during zonking (notably levity errors)
-    do { let all_ev_binds = cur_ev_binds `unionBags` ev_binds
-       ; zonkTopDecls all_ev_binds binds rules imp_specs fords }
-
--- | Runs TH finalizers and renames and typechecks the top-level declarations
--- that they could introduce.
-run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)
-run_th_modfinalizers = do
-  th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
-  th_modfinalizers <- readTcRef th_modfinalizers_var
-  if null th_modfinalizers
-  then getEnvs
-  else do
-    writeTcRef th_modfinalizers_var []
-    let run_finalizer (lcl_env, f) =
-            restoreLclEnv lcl_env (runRemoteModFinalizers f)
-
-    (_, lie_th) <- captureTopConstraints $
-                   mapM_ run_finalizer th_modfinalizers
-
-      -- Finalizers can add top-level declarations with addTopDecls, so
-      -- we have to run tc_rn_src_decls to get them
-    (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls []
-
-    restoreEnvs (tcg_env, tcl_env) $ do
-      -- Subsequent rounds of finalizers run after any new constraints are
-      -- simplified, or some types might not be complete when using reify
-      -- (see #12777).
-      new_ev_binds <- {-# SCC "simplifyTop2" #-}
-                      simplifyTop (lie_th `andWC` lie_top_decls)
-      addTopEvBinds new_ev_binds run_th_modfinalizers
-        -- addTopDecls can add declarations which add new finalizers.
-
-tc_rn_src_decls :: [LHsDecl GhcPs]
-                -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
--- Loops around dealing with each top level inter-splice group
--- in turn, until it's dealt with the entire module
--- Never emits constraints; calls captureTopConstraints internally
-tc_rn_src_decls ds
- = {-# SCC "tc_rn_src_decls" #-}
-   do { (first_group, group_tail) <- findSplice ds
-                -- If ds is [] we get ([], Nothing)
-
-        -- Deal with decls up to, but not including, the first splice
-      ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group
-                -- rnTopSrcDecls fails if there are any errors
-
-        -- Get TH-generated top-level declarations and make sure they don't
-        -- contain any splices since we don't handle that at the moment
-        --
-        -- The plumbing here is a bit odd: see #10853
-      ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
-      ; th_ds <- readTcRef th_topdecls_var
-      ; writeTcRef th_topdecls_var []
-
-      ; (tcg_env, rn_decls) <-
-            if null th_ds
-            then return (tcg_env, rn_decls)
-            else do { (th_group, th_group_tail) <- findSplice th_ds
-                    ; case th_group_tail of
-                        { Nothing -> return ()
-                        ; Just (SpliceDecl _ (L loc _) _, _) ->
-                            setSrcSpanA loc
-                            $ addErr (mkTcRnUnknownMessage $ mkPlainError noHints $ text
-                                ("Declaration splices are not "
-                                  ++ "permitted inside top-level "
-                                  ++ "declarations added with addTopDecls"))
-                        }
-                      -- Rename TH-generated top-level declarations
-                    ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env
-                        $ rnTopSrcDecls th_group
-
-                      -- Dump generated top-level declarations
-                    ; let msg = "top-level declarations added with addTopDecls"
-                    ; traceSplice
-                        $ SpliceInfo { spliceDescription = msg
-                                     , spliceIsDecl    = True
-                                     , spliceSource    = Nothing
-                                     , spliceGenerated = ppr th_rn_decls }
-                    ; return (tcg_env, appendGroups rn_decls th_rn_decls)
-                    }
-
-      -- Type check all declarations
-      -- NB: set the env **before** captureTopConstraints so that error messages
-      -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that
-      -- the captureTopConstraints must go here, not in tcRnSrcDecls.
-      ; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $
-                                      captureTopConstraints $
-                                      tcTopSrcDecls rn_decls
-
-        -- If there is no splice, we're nearly done
-      ; restoreEnvs (tcg_env, tcl_env) $
-        case group_tail of
-          { Nothing -> return (tcg_env, tcl_env, lie1)
-
-            -- If there's a splice, we must carry on
-          ; Just (SpliceDecl _ (L _ splice) _, rest_ds) ->
-            do {
-                 -- We need to simplify any constraints from the previous declaration
-                 -- group, or else we might reify metavariables, as in #16980.
-               ; ev_binds1 <- simplifyTop lie1
-
-                 -- Rename the splice expression, and get its supporting decls
-               ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice
-
-                 -- Glue them on the front of the remaining decls and loop
-               ; setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
-                 addTopEvBinds ev_binds1                             $
-                 tc_rn_src_decls (spliced_decls ++ rest_ds)
-               }
-          }
-      }
-
-{-
-************************************************************************
-*                                                                      *
-        Compiling hs-boot source files, and
-        comparing the hi-boot interface with the real thing
-*                                                                      *
-************************************************************************
--}
-
-tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
-tcRnHsBootDecls hsc_src decls
-   = do { (first_group, group_tail) <- findSplice decls
-
-                -- Rename the declarations
-        ; (tcg_env, HsGroup { hs_tyclds = tycl_decls
-                            , hs_derivds = deriv_decls
-                            , hs_fords  = for_decls
-                            , hs_defds  = def_decls
-                            , hs_ruleds = rule_decls
-                            , hs_annds  = _
-                            , hs_valds  = XValBindsLR (NValBinds val_binds val_sigs) })
-              <- rnTopSrcDecls first_group
-
-        -- The empty list is for extra dependencies coming from .hs-boot files
-        -- See Note [Extra dependencies from .hs-boot files] in GHC.Rename.Module
-
-        ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do {
-              -- NB: setGblEnv **before** captureTopConstraints so that
-              -- if the latter reports errors, it knows what's in scope
-
-                -- Check for illegal declarations
-        ; case group_tail of
-             Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d
-             Nothing                    -> return ()
-        ; mapM_ (badBootDecl hsc_src "foreign") for_decls
-        ; mapM_ (badBootDecl hsc_src "default") def_decls
-        ; mapM_ (badBootDecl hsc_src "rule")    rule_decls
-
-                -- Typecheck type/class/instance decls
-        ; traceTc "Tc2 (boot)" empty
-        ; (tcg_env, inst_infos, _deriv_binds, _th_bndrs)
-             <- tcTyClsInstDecls tycl_decls deriv_decls val_binds
-        ; setGblEnv tcg_env     $ do {
-
-        -- Emit Typeable bindings
-        ; tcg_env <- mkTypeableBinds
-        ; setGblEnv tcg_env $ do {
-
-                -- Typecheck value declarations
-        ; traceTc "Tc5" empty
-        ; val_ids <- tcHsBootSigs val_binds val_sigs
-
-                -- Wrap up
-                -- No simplification or zonking to do
-        ; traceTc "Tc7a" empty
-        ; gbl_env <- getGblEnv
-
-                -- Make the final type-env
-                -- Include the dfun_ids so that their type sigs
-                -- are written into the interface file.
-        ; let { type_env0 = tcg_type_env gbl_env
-              ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
-              ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
-              ; dfun_ids = map iDFunId inst_infos
-              }
-
-        ; setGlobalTypeEnv gbl_env type_env2
-   }}}
-   ; traceTc "boot" (ppr lie); return gbl_env }
-
-badBootDecl :: HscSource -> String -> LocatedA decl -> TcM ()
-badBootDecl hsc_src what (L loc _)
-  = addErrAt (locA loc) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    (char 'A' <+> text what
-      <+> text "declaration is not (currently) allowed in a"
-      <+> (case hsc_src of
-            HsBootFile -> text "hs-boot"
-            HsigFile -> text "hsig"
-            _ -> panic "badBootDecl: should be an hsig or hs-boot file")
-      <+> text "file")
-
-{-
-Once we've typechecked the body of the module, we want to compare what
-we've found (gathered in a TypeEnv) with the hi-boot details (if any).
--}
-
-checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
--- Compare the hi-boot file for this module (if there is one)
--- with the type environment we've just come up with
--- In the common case where there is no hi-boot file, the list
--- of boot_names is empty.
-
-checkHiBootIface tcg_env boot_info
-  | NoSelfBoot <- boot_info  -- Common case
-  = return tcg_env
-
-  | HsBootFile <- tcg_src tcg_env   -- Current module is already a hs-boot file!
-  = return tcg_env
-
-  | SelfBoot { sb_mds = boot_details } <- boot_info
-  , TcGblEnv { tcg_binds    = binds
-             , tcg_insts    = local_insts
-             , tcg_type_env = local_type_env
-             , tcg_exports  = local_exports } <- tcg_env
-  = do  { -- This code is tricky, see Note [DFun knot-tying]
-        ; dfun_prs <- checkHiBootIface' local_insts local_type_env
-                                        local_exports boot_details
-
-        -- Now add the boot-dfun bindings  $fxblah = $fblah
-        -- to (a) the type envt, and (b) the top-level bindings
-        ; let boot_dfuns = map fst dfun_prs
-              type_env'  = extendTypeEnvWithIds local_type_env boot_dfuns
-              dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
-                                     | (boot_dfun, dfun) <- dfun_prs ]
-              tcg_env_w_binds
-                = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
-
-        ; type_env' `seq`
-             -- Why the seq?  Without, we will put a TypeEnv thunk in
-             -- tcg_type_env_var.  That thunk will eventually get
-             -- forced if we are typechecking interfaces, but that
-             -- is no good if we are trying to typecheck the very
-             -- DFun we were going to put in.
-             -- TODO: Maybe setGlobalTypeEnv should be strict.
-          setGlobalTypeEnv tcg_env_w_binds type_env' }
-
-#if __GLASGOW_HASKELL__ <= 810
-  | otherwise = panic "checkHiBootIface: unreachable code"
-#endif
-
-{- Note [DFun impedance matching]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We return a list of "impedance-matching" bindings for the dfuns
-defined in the hs-boot file, such as
-          $fxEqT = $fEqT
-We need these because the module and hi-boot file might differ in
-the name it chose for the dfun: the name of a dfun is not
-uniquely determined by its type; there might be multiple dfuns
-which, individually, would map to the same name (in which case
-we have to disambiguate them.)  There's no way for the hi file
-to know exactly what disambiguation to use... without looking
-at the hi-boot file itself.
-
-In fact, the names will always differ because we always pick names
-prefixed with "$fx" for boot dfuns, and "$f" for real dfuns
-(so that this impedance matching is always possible).
-
-Note [DFun knot-tying]
-~~~~~~~~~~~~~~~~~~~~~~
-The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from
-typechecking the hi-boot file that we are presently implementing.
-Suppose we are typechecking the module A: when we typecheck the
-hi-boot file, whenever we see an identifier A.T, we knot-tie this
-identifier to the *local* type environment (via if_rec_types.)  The
-contract then is that we don't *look* at 'SelfBootInfo' until we've
-finished typechecking the module and updated the type environment with
-the new tycons and ids.
-
-This most works well, but there is one problem: DFuns!  We do not want
-to look at the mb_insts of the ModDetails in SelfBootInfo, because a
-dfun in one of those ClsInsts is gotten (in GHC.IfaceToCore.tcIfaceInst) by a
-(lazily evaluated) lookup in the if_rec_types.  We could extend the
-type env, do a setGloblaTypeEnv etc; but that all seems very indirect.
-It is much more directly simply to extract the DFunIds from the
-md_types of the SelfBootInfo.
-
-See #4003, #16038 for why we need to take care here.
--}
-
-checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
-                  -> ModDetails -> TcM [(Id, Id)]
--- Variant which doesn't require a full TcGblEnv; you could get the
--- local components from another ModDetails.
-checkHiBootIface'
-        local_insts local_type_env local_exports
-        (ModDetails { md_types = boot_type_env
-                    , md_fam_insts = boot_fam_insts
-                    , md_exports = boot_exports })
-  = do  { traceTc "checkHiBootIface" $ vcat
-             [ ppr boot_type_env, ppr boot_exports]
-
-                -- Check the exports of the boot module, one by one
-        ; mapM_ check_export boot_exports
-
-                -- Check for no family instances
-        ; unless (null boot_fam_insts) $
-            panic ("GHC.Tc.Module.checkHiBootIface: Cannot handle family " ++
-                   "instances in boot files yet...")
-            -- FIXME: Why?  The actual comparison is not hard, but what would
-            --        be the equivalent to the dfun bindings returned for class
-            --        instances?  We can't easily equate tycons...
-
-                -- Check instance declarations
-                -- and generate an impedance-matching binding
-        ; mb_dfun_prs <- mapM check_cls_inst boot_dfuns
-
-        ; failIfErrsM
-
-        ; return (catMaybes mb_dfun_prs) }
-
-  where
-    boot_dfun_names = map idName boot_dfuns
-    boot_dfuns      = filter isDFunId $ typeEnvIds boot_type_env
-       -- NB: boot_dfuns is /not/ defined thus: map instanceDFunId md_insts
-       --     We don't want to look at md_insts!
-       --     Why not?  See Note [DFun knot-tying]
-
-    check_export boot_avail     -- boot_avail is exported by the boot iface
-      | name `elem` boot_dfun_names = return ()
-
-        -- Check that the actual module exports the same thing
-      | missing_name:_ <- missing_names
-      = addErrAt (nameSrcSpan missing_name)
-                 (missingBootThing True missing_name "exported by")
-
-        -- If the boot module does not *define* the thing, we are done
-        -- (it simply re-exports it, and names match, so nothing further to do)
-      | isNothing mb_boot_thing = return ()
-
-        -- Check that the actual module also defines the thing, and
-        -- then compare the definitions
-      | Just real_thing <- lookupTypeEnv local_type_env name,
-        Just boot_thing <- mb_boot_thing
-      = checkBootDeclM True boot_thing real_thing
-
-      | otherwise
-      = addErrTc (missingBootThing True name "defined in")
-      where
-        name          = availName boot_avail
-        mb_boot_thing = lookupTypeEnv boot_type_env name
-        missing_names = case lookupNameEnv local_export_env name of
-                          Nothing    -> [name]
-                          Just avail -> availNames boot_avail `minusList` availNames avail
-
-    local_export_env :: NameEnv AvailInfo
-    local_export_env = availsToNameEnv local_exports
-
-    check_cls_inst :: DFunId -> TcM (Maybe (Id, Id))
-        -- Returns a pair of the boot dfun in terms of the equivalent
-        -- real dfun. Delicate (like checkBootDecl) because it depends
-        -- on the types lining up precisely even to the ordering of
-        -- the type variables in the foralls.
-    check_cls_inst boot_dfun
-      | (real_dfun : _) <- find_real_dfun boot_dfun
-      , let local_boot_dfun = Id.mkExportedVanillaId
-                                  (idName boot_dfun) (idType real_dfun)
-      = return (Just (local_boot_dfun, real_dfun))
-          -- Two tricky points here:
-          --
-          --  * The local_boot_fun should have a Name from the /boot-file/,
-          --    but type from the dfun defined in /this module/.
-          --    That ensures that the TyCon etc inside the type are
-          --    the ones defined in this module, not the ones gotten
-          --    from the hi-boot file, which may have a lot less info
-          --    (#8743, comment:10).
-          --
-          --  * The DFunIds from boot_details are /GlobalIds/, because
-          --    they come from typechecking M.hi-boot.
-          --    But all bindings in this module should be for /LocalIds/,
-          --    otherwise dependency analysis fails (#16038). This
-          --    is another reason for using mkExportedVanillaId, rather
-          --    that modifying boot_dfun, to make local_boot_fun.
-
-      | otherwise
-      = setSrcSpan (nameSrcSpan (getName boot_dfun)) $
-        do { traceTc "check_cls_inst" $ vcat
-                [ text "local_insts"  <+>
-                     vcat (map (ppr . idType . instanceDFunId) local_insts)
-                , text "boot_dfun_ty" <+> ppr (idType boot_dfun) ]
-
-           ; addErrTc (instMisMatch boot_dfun)
-           ; return Nothing }
-
-    find_real_dfun :: DFunId -> [DFunId]
-    find_real_dfun boot_dfun
-       = [dfun | inst <- local_insts
-               , let dfun = instanceDFunId inst
-               , idType dfun `eqType` boot_dfun_ty ]
-       where
-          boot_dfun_ty   = idType boot_dfun
-
-
--- In general, to perform these checks we have to
--- compare the TyThing from the .hi-boot file to the TyThing
--- in the current source file.  We must be careful to allow alpha-renaming
--- where appropriate, and also the boot declaration is allowed to omit
--- constructors and class methods.
---
--- See rnfail055 for a good test of this stuff.
-
--- | Compares two things for equivalence between boot-file and normal code,
--- reporting an error if they don't match up.
-checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)
-               -> TyThing -> TyThing -> TcM ()
-checkBootDeclM is_boot boot_thing real_thing
-  = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err ->
-       addErrAt span
-                (bootMisMatch is_boot err real_thing boot_thing)
-  where
-    -- Here we use the span of the boot thing or, if it doesn't have a sensible
-    -- span, that of the real thing,
-    span
-      | let span = nameSrcSpan (getName boot_thing)
-      , isGoodSrcSpan span
-      = span
-      | otherwise
-      = nameSrcSpan (getName real_thing)
-
--- | Compares the two things for equivalence between boot-file and normal
--- code. Returns @Nothing@ on success or @Just "some helpful info for user"@
--- failure. If the difference will be apparent to the user, @Just empty@ is
--- perfectly suitable.
-checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc
-
-checkBootDecl _ (AnId id1) (AnId id2)
-  = assert (id1 == id2) $
-    check (idType id1 `eqType` idType id2)
-          (text "The two types are different")
-
-checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2)
-  = checkBootTyCon is_boot tc1 tc2
-
-checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _))
-  = pprPanic "checkBootDecl" (ppr dc1)
-
-checkBootDecl _ _ _ = Just empty -- probably shouldn't happen
-
--- | Combines two potential error messages
-andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
-Nothing `andThenCheck` msg     = msg
-msg     `andThenCheck` Nothing = msg
-Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2)
-infixr 0 `andThenCheck`
-
--- | If the test in the first parameter is True, succeed with @Nothing@;
--- otherwise, return the provided check
-checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc
-checkUnless True  _ = Nothing
-checkUnless False k = k
-
--- | Run the check provided for every pair of elements in the lists.
--- The provided SDoc should name the element type, in the plural.
-checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc
-            -> Maybe SDoc
-checkListBy check_fun as bs whats = go [] as bs
-  where
-    herald = text "The" <+> whats <+> text "do not match"
-
-    go []   [] [] = Nothing
-    go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs))
-    go docs (x:xs) (y:ys) = case check_fun x y of
-      Just doc -> go (doc:docs) xs ys
-      Nothing  -> go docs       xs ys
-    go _    _  _ = Just (hang (herald <> colon)
-                            2 (text "There are different numbers of" <+> whats))
-
--- | If the test in the first parameter is True, succeed with @Nothing@;
--- otherwise, fail with the given SDoc.
-check :: Bool -> SDoc -> Maybe SDoc
-check True  _   = Nothing
-check False doc = Just doc
-
--- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends.
-checkSuccess :: Maybe SDoc
-checkSuccess = Nothing
-
-----------------
-checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc
-checkBootTyCon is_boot tc1 tc2
-  | not (eqType (tyConKind tc1) (tyConKind tc2))
-  = Just $ text "The types have different kinds"    -- First off, check the kind
-
-  | Just c1 <- tyConClass_maybe tc1
-  , Just c2 <- tyConClass_maybe tc2
-  , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
-          = classExtraBigSig c1
-        (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
-          = classExtraBigSig c2
-  , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
-  = let
-       eqSig (id1, def_meth1) (id2, def_meth2)
-         = check (name1 == name2)
-                 (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
-                  text "are different") `andThenCheck`
-           check (eqTypeX env op_ty1 op_ty2)
-                 (text "The types of" <+> pname1 <+>
-                  text "are different") `andThenCheck`
-           if is_boot
-               then check (liftEq eqDM def_meth1 def_meth2)
-                          (text "The default methods associated with" <+> pname1 <+>
-                           text "are different")
-               else check (subDM op_ty1 def_meth1 def_meth2)
-                          (text "The default methods associated with" <+> pname1 <+>
-                           text "are not compatible")
-         where
-          name1 = idName id1
-          name2 = idName id2
-          pname1 = quotes (ppr name1)
-          pname2 = quotes (ppr name2)
-          op_ty1 = classMethodTy id1
-          op_ty2 = classMethodTy id2
-
-       eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2)
-         = checkBootTyCon is_boot tc1 tc2 `andThenCheck`
-           check (eqATDef def_ats1 def_ats2)
-                 (text "The associated type defaults differ")
-
-       eqDM (_, VanillaDM)    (_, VanillaDM)    = True
-       eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2
-       eqDM _ _ = False
-
-       -- NB: first argument is from hsig, second is from real impl.
-       -- Order of pattern matching matters.
-       subDM _ Nothing _ = True
-       subDM _ _ Nothing = False
-
-       -- If the hsig wrote:
-       --
-       --   f :: a -> a
-       --   default f :: a -> a
-       --
-       -- this should be validly implementable using an old-fashioned
-       -- vanilla default method.
-       subDM t1 (Just (_, GenericDM gdm_t1)) (Just (_, VanillaDM))
-        = eqType t1 gdm_t1   -- Take care (#22476).  Both t1 and gdm_t1 come
-                             -- from tc1, so use eqType, and /not/ eqTypeX
-
-       -- This case can occur when merging signatures
-       subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2))
-        = eqTypeX env t1 t2
-
-       subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True
-       subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2))
-        = eqTypeX env t1 t2
-
-       -- Ignore the location of the defaults
-       eqATDef Nothing             Nothing             = True
-       eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2
-       eqATDef _ _ = False
-
-       eqFD (as1,bs1) (as2,bs2) =
-         liftEq (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
-         liftEq (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
-    in
-    checkRoles roles1 roles2 `andThenCheck`
-          -- Checks kind of class
-    check (liftEq eqFD clas_fds1 clas_fds2)
-          (text "The functional dependencies do not match") `andThenCheck`
-    checkUnless (isAbstractTyCon tc1) $
-    check (liftEq (eqTypeX env) sc_theta1 sc_theta2)
-          (text "The class constraints do not match") `andThenCheck`
-    checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`
-    checkListBy eqAT ats1 ats2 (text "associated types") `andThenCheck`
-    check (classMinimalDef c1 `BF.implies` classMinimalDef c2)
-        (text "The MINIMAL pragmas are not compatible")
-
-  | Just syn_rhs1 <- synTyConRhs_maybe tc1
-  , Just syn_rhs2 <- synTyConRhs_maybe tc2
-  , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
-  = assert (tc1 == tc2) $
-    checkRoles roles1 roles2 `andThenCheck`
-    check (eqTypeX env syn_rhs1 syn_rhs2) empty   -- nothing interesting to say
-  -- This allows abstract 'data T a' to be implemented using 'type T = ...'
-  -- and abstract 'class K a' to be implement using 'type K = ...'
-  -- See Note [Synonyms implement abstract data]
-  | not is_boot -- don't support for hs-boot yet
-  , isAbstractTyCon tc1
-  , Just (tvs, ty) <- synTyConDefn_maybe tc2
-  , Just (tc2', args) <- tcSplitTyConApp_maybe ty
-  = checkSynAbsData tvs ty tc2' args
-    -- TODO: When it's a synonym implementing a class, we really
-    -- should check if the fundeps are satisfied, but
-    -- there is not an obvious way to do this for a constraint synonym.
-    -- So for now, let it all through (it won't cause segfaults, anyway).
-    -- Tracked at #12704.
-
-  -- This allows abstract 'data T :: Nat' to be implemented using
-  -- 'type T = 42' Since the kinds already match (we have checked this
-  -- upfront) all we need to check is that the implementation 'type T
-  -- = ...' defined an actual literal.  See #15138 for the case this
-  -- handles.
-  | not is_boot
-  , isAbstractTyCon tc1
-  , Just (_,ty2) <- synTyConDefn_maybe tc2
-  , isJust (isLitTy ty2)
-  = Nothing
-
-  | Just fam_flav1 <- famTyConFlav_maybe tc1
-  , Just fam_flav2 <- famTyConFlav_maybe tc2
-  = assert (tc1 == tc2) $
-    let eqFamFlav OpenSynFamilyTyCon   OpenSynFamilyTyCon = True
-        eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True
-        -- This case only happens for hsig merging:
-        eqFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon = True
-        eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
-        eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
-        eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
-            = eqClosedFamilyAx ax1 ax2
-        eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2
-        eqFamFlav _ _ = False
-        injInfo1 = tyConInjectivityInfo tc1
-        injInfo2 = tyConInjectivityInfo tc2
-    in
-    -- check equality of roles, family flavours and injectivity annotations
-    -- (NB: Type family roles are always nominal. But the check is
-    -- harmless enough.)
-    checkRoles roles1 roles2 `andThenCheck`
-    check (eqFamFlav fam_flav1 fam_flav2)
-        (whenPprDebug $
-            text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+>
-            text "do not match") `andThenCheck`
-    check (injInfo1 == injInfo2) (text "Injectivities do not match")
-
-  | isAlgTyCon tc1 && isAlgTyCon tc2
-  , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
-  = assert (tc1 == tc2) $
-    checkRoles roles1 roles2 `andThenCheck`
-    check (liftEq (eqTypeX env)
-                     (tyConStupidTheta tc1) (tyConStupidTheta tc2))
-          (text "The datatype contexts do not match") `andThenCheck`
-    eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2)
-
-  | otherwise = Just empty   -- two very different types -- should be obvious
-  where
-    roles1 = tyConRoles tc1 -- the abstract one
-    roles2 = tyConRoles tc2
-    roles_msg = text "The roles do not match." $$
-                (text "Roles on abstract types default to" <+>
-                 quotes (text "representational") <+> text "in boot files.")
-
-    roles_subtype_msg = text "The roles are not compatible:" $$
-                        text "Main module:" <+> ppr roles2 $$
-                        text "Hsig file:" <+> ppr roles1
-
-    checkRoles r1 r2
-      | is_boot || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping]
-      = check (r1 == r2) roles_msg
-      | otherwise = check (r2 `rolesSubtypeOf` r1) roles_subtype_msg
-
-    -- Note [Role subtyping]
-    -- ~~~~~~~~~~~~~~~~~~~~~
-    -- In the current formulation of roles, role subtyping is only OK if the
-    -- "abstract" TyCon was not representationally injective.  Among the most
-    -- notable examples of non representationally injective TyCons are abstract
-    -- data, which can be implemented via newtypes (which are not
-    -- representationally injective).  The key example is
-    -- in this example from #13140:
-    --
-    --      -- In an hsig file
-    --      data T a -- abstract!
-    --      type role T nominal
-    --
-    --      -- Elsewhere
-    --      foo :: Coercible (T a) (T b) => a -> b
-    --      foo x = x
-    --
-    -- We must NOT allow foo to typecheck, because if we instantiate
-    -- T with a concrete data type with a phantom role would cause
-    -- Coercible (T a) (T b) to be provable.  Fortunately, if T is not
-    -- representationally injective, we cannot make the inference that a ~N b if
-    -- T a ~R T b.
-    --
-    -- Unconditional role subtyping would be possible if we setup
-    -- an extra set of roles saying when we can project out coercions
-    -- (we call these proj-roles); then it would NOT be valid to instantiate T
-    -- with a data type at phantom since the proj-role subtyping check
-    -- would fail.  See #13140 for more details.
-    --
-    -- One consequence of this is we get no role subtyping for non-abstract
-    -- data types in signatures. Suppose you have:
-    --
-    --      signature A where
-    --          type role T nominal
-    --          data T a = MkT
-    --
-    -- If you write this, we'll treat T as injective, and make inferences
-    -- like T a ~R T b ==> a ~N b (mkSelCo).  But if we can
-    -- subsequently replace T with one at phantom role, we would then be able to
-    -- infer things like T Int ~R T Bool which is bad news.
-    --
-    -- We could allow role subtyping here if we didn't treat *any* data types
-    -- defined in signatures as injective.  But this would be a bit surprising,
-    -- replacing a data type in a module with one in a signature could cause
-    -- your code to stop typechecking (whereas if you made the type abstract,
-    -- it is more understandable that the type checker knows less).
-    --
-    -- It would have been best if this was purely a question of defaults
-    -- (i.e., a user could explicitly ask for one behavior or another) but
-    -- the current role system isn't expressive enough to do this.
-    -- Having explicit proj-roles would solve this problem.
-
-    rolesSubtypeOf [] [] = True
-    -- NB: this relation is the OPPOSITE of the subroling relation
-    rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys
-    rolesSubtypeOf _ _ = False
-
-    -- Note [Synonyms implement abstract data]
-    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-    -- An abstract data type or class can be implemented using a type synonym,
-    -- but ONLY if the type synonym is nullary and has no type family
-    -- applications.  This arises from two properties of skolem abstract data:
-    --
-    --    For any T (with some number of parameters),
-    --
-    --    1. T is a valid type (it is "curryable"), and
-    --
-    --    2. T is valid in an instance head (no type families).
-    --
-    -- See also 'HowAbstract' and Note [Skolem abstract data].
-
-    -- Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@,
-    -- check that this synonym is an acceptable implementation of @tc1@.
-    -- See Note [Synonyms implement abstract data]
-    checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc
-    checkSynAbsData tvs ty tc2' args =
-        check (null (tcTyFamInsts ty))
-              (text "Illegal type family application in implementation of abstract data.")
-                `andThenCheck`
-        check (null tvs)
-              (text "Illegal parameterized type synonym in implementation of abstract data." $$
-               text "(Try eta reducing your type synonym so that it is nullary.)")
-                `andThenCheck`
-        -- Don't report roles errors unless the type synonym is nullary
-        checkUnless (not (null tvs)) $
-            assert (null roles2) $
-            -- If we have something like:
-            --
-            --  signature H where
-            --      data T a
-            --  module H where
-            --      data K a b = ...
-            --      type T = K Int
-            --
-            -- we need to drop the first role of K when comparing!
-            checkRoles roles1 (drop (length args) (tyConRoles tc2'))
-{-
-        -- Hypothetically, if we were allow to non-nullary type synonyms, here
-        -- is how you would check the roles
-        if length tvs == length roles1
-            then checkRoles roles1 roles2
-            else case tcSplitTyConApp_maybe ty of
-                    Just (tc2', args) ->
-                        checkRoles roles1 (drop (length args) (tyConRoles tc2') ++ roles2)
-                    Nothing -> Just roles_msg
--}
-
-    eqAlgRhs _ (AbstractTyCon {}) _rhs2
-      = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon
-    eqAlgRhs _  tc1@DataTyCon{} tc2@DataTyCon{} =
-        checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")
-    eqAlgRhs _  tc1@NewTyCon{} tc2@NewTyCon{} =
-        eqCon (data_con tc1) (data_con tc2)
-    eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+>
-                           text "definition with a" <+> quotes (text "newtype") <+>
-                           text "definition")
-
-    eqCon c1 c2
-      =  check (name1 == name2)
-               (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
-                text "differ") `andThenCheck`
-         check (dataConIsInfix c1 == dataConIsInfix c2)
-               (text "The fixities of" <+> pname1 <+>
-                text "differ") `andThenCheck`
-         check (liftEq eqHsBang (dataConImplBangs c1) (dataConImplBangs c2))
-               (text "The strictness annotations for" <+> pname1 <+>
-                text "differ") `andThenCheck`
-         check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2))
-               (text "The record label lists for" <+> pname1 <+>
-                text "differ") `andThenCheck`
-         check (eqType (dataConWrapperType c1) (dataConWrapperType c2))
-               (text "The types for" <+> pname1 <+> text "differ")
-      where
-        name1 = dataConName c1
-        name2 = dataConName c2
-        pname1 = quotes (ppr name1)
-        pname2 = quotes (ppr name2)
-
-    eqClosedFamilyAx Nothing Nothing  = True
-    eqClosedFamilyAx Nothing (Just _) = False
-    eqClosedFamilyAx (Just _) Nothing = False
-    eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 }))
-                     (Just (CoAxiom { co_ax_branches = branches2 }))
-      =  numBranches branches1 == numBranches branches2
-      && (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2)
-      where
-        branch_list1 = fromBranches branches1
-        branch_list2 = fromBranches branches2
-
-    eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1
-                                     , cab_lhs = lhs1, cab_rhs = rhs1 })
-                         (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2
-                                     , cab_lhs = lhs2, cab_rhs = rhs2 })
-      | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2
-      , Just env  <- eqVarBndrs env1        cvs1 cvs2
-      = liftEq (eqTypeX env) lhs1 lhs2 &&
-        eqTypeX env rhs1 rhs2
-
-      | otherwise = False
-
-emptyRnEnv2 :: RnEnv2
-emptyRnEnv2 = mkRnEnv2 emptyInScopeSet
-
-----------------
-missingBootThing :: Bool -> Name -> String -> TcRnMessage
-missingBootThing is_boot name what
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    quotes (ppr name) <+> text "is exported by the"
-    <+> (if is_boot then text "hs-boot" else text "hsig")
-    <+> text "file, but not"
-    <+> text what <+> text "the module"
-
-badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage
-badReexportedBootThing is_boot name name'
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    withUserStyle alwaysQualify AllTheWay $ vcat
-        [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig")
-           <+> text "file (re)exports" <+> quotes (ppr name)
-        , text "but the implementing module exports a different identifier" <+> quotes (ppr name')
-        ]
-
-bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> TcRnMessage
-bootMisMatch is_boot extra_info real_thing boot_thing
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc
-  where
-    to_doc
-      = pprTyThingInContext $ showToHeader { ss_forall =
-                                              if is_boot
-                                                then ShowForAllMust
-                                                else ShowForAllWhen }
-
-    real_doc = to_doc real_thing
-    boot_doc = to_doc boot_thing
-
-    pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc
-    pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc
-      = vcat
-          [ ppr real_thing <+>
-            text "has conflicting definitions in the module",
-            text "and its" <+>
-              (if is_boot
-                then text "hs-boot file"
-                else text "hsig file"),
-            text "Main module:" <+> real_doc,
-              (if is_boot
-                then text "Boot file:  "
-                else text "Hsig file: ")
-                <+> boot_doc,
-            extra_info
-          ]
-
-instMisMatch :: DFunId -> TcRnMessage
-instMisMatch dfun
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (text "instance" <+> ppr (idType dfun))
-       2 (text "is defined in the hs-boot file, but not in the module itself")
-
-{-
-************************************************************************
-*                                                                      *
-        Type-checking the top level of a module (continued)
-*                                                                      *
-************************************************************************
--}
-
-rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn)
--- Fails if there are any errors
-rnTopSrcDecls group
- = do { -- Rename the source decls
-        traceRn "rn12" empty ;
-        (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
-        traceRn "rn13" empty ;
-        (tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ;
-        traceRn "rn13-plugin" empty ;
-
-        -- save the renamed syntax, if we want it
-        let { tcg_env'
-                | Just grp <- tcg_rn_decls tcg_env
-                  = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
-                | otherwise
-                   = tcg_env };
-
-                -- Dump trace of renaming part
-        rnDump rn_decls ;
-        return (tcg_env', rn_decls)
-   }
-
-tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv)
-tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-                         hs_derivds = deriv_decls,
-                         hs_fords  = foreign_decls,
-                         hs_defds  = default_decls,
-                         hs_annds  = annotation_decls,
-                         hs_ruleds = rule_decls,
-                         hs_valds  = hs_val_binds@(XValBindsLR
-                                              (NValBinds val_binds val_sigs)) })
- = do {         -- Type-check the type and class decls, and all imported decls
-                -- The latter come in via tycl_decls
-        traceTc "Tc2 (src)" empty ;
-
-                -- Source-language instances, including derivings,
-                -- and import the supporting declarations
-        traceTc "Tc3" empty ;
-        (tcg_env, inst_infos, th_bndrs,
-         XValBindsLR (NValBinds deriv_binds deriv_sigs))
-            <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
-
-        updLclEnv (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $
-        setGblEnv tcg_env       $ do {
-
-                -- Generate Applicative/Monad proposal (AMP) warnings
-        traceTc "Tc3b" empty ;
-
-                -- Generate Semigroup/Monoid warnings
-        traceTc "Tc3c" empty ;
-        tcSemigroupWarnings ;
-
-                -- Foreign import declarations next.
-        traceTc "Tc4" empty ;
-        (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
-        tcExtendGlobalValEnv fi_ids     $ do {
-
-                -- Default declarations
-        traceTc "Tc4a" empty ;
-        default_tys <- tcDefaults default_decls ;
-        updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
-
-                -- Value declarations next.
-                -- It is important that we check the top-level value bindings
-                -- before the GHC-generated derived bindings, since the latter
-                -- may be defined in terms of the former. (For instance,
-                -- the bindings produced in a Data instance.)
-        traceTc "Tc5" empty ;
-        tc_envs <- tcTopBinds val_binds val_sigs;
-        restoreEnvs tc_envs $ do {
-
-                -- Now GHC-generated derived bindings, generics, and selectors
-                -- Do not generate warnings from compiler-generated code;
-                -- hence the use of discardWarnings
-        tc_envs@(tcg_env, tcl_env)
-            <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ;
-        restoreEnvs tc_envs $ do {  -- Environment doesn't change now
-
-                -- Second pass over class and instance declarations,
-                -- now using the kind-checked decls
-        traceTc "Tc6" empty ;
-        inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ;
-
-                -- Foreign exports
-        traceTc "Tc7" empty ;
-        (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ;
-
-                -- Annotations
-        annotations <- tcAnnotations annotation_decls ;
-
-                -- Rules
-        rules <- tcRules rule_decls ;
-
-                -- Wrap up
-        traceTc "Tc7a" empty ;
-        let { all_binds = inst_binds     `unionBags`
-                          foe_binds
-
-            ; fo_gres = fi_gres `unionBags` foe_gres
-            ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` greMangledName gre)
-                                emptyFVs fo_gres
-
-            ; sig_names = mkNameSet (collectHsValBinders CollNoDictBinders hs_val_binds)
-                          `minusNameSet` getTypeSigNames val_sigs
-
-                -- Extend the GblEnv with the (as yet un-zonked)
-                -- bindings, rules, foreign decls
-            ; tcg_env' = tcg_env { tcg_binds   = tcg_binds tcg_env `unionBags` all_binds
-                                 , tcg_sigs    = tcg_sigs tcg_env `unionNameSet` sig_names
-                                 , tcg_rules   = tcg_rules tcg_env
-                                                      ++ flattenRuleDecls rules
-                                 , tcg_anns    = tcg_anns tcg_env ++ annotations
-                                 , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations
-                                 , tcg_fords   = tcg_fords tcg_env ++ foe_decls ++ fi_decls
-                                 , tcg_dus     = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;
-                                 -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]
-
-        -- See Note [Newtype constructor usage in foreign declarations]
-        addUsedGREs (bagToList fo_gres) ;
-
-        return (tcg_env', tcl_env)
-    }}}}}}
-
-tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn"
-
-
-tcSemigroupWarnings :: TcM ()
-tcSemigroupWarnings = do
-    mod <- getModule
-    -- ghc-prim doesn't depend on base
-    unless (moduleUnit mod == primUnit) $ do
-      traceTc "tcSemigroupWarnings" empty
-      let warnFlag = Opt_WarnSemigroup
-      tcPreludeClashWarn warnFlag sappendName
-      tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName
-
-
--- | Warn on local definitions of names that would clash with future Prelude
--- elements.
---
---   A name clashes if the following criteria are met:
---       1. It would is imported (unqualified) from Prelude
---       2. It is locally defined in the current module
---       3. It has the same literal name as the reference function
---       4. It is not identical to the reference function
-tcPreludeClashWarn :: WarningFlag
-                   -> Name
-                   -> TcM ()
-tcPreludeClashWarn warnFlag name = do
-    { warn <- woptM warnFlag
-    ; when warn $ do
-    { traceTc "tcPreludeClashWarn/wouldBeImported" empty
-    -- Is the name imported (unqualified) from Prelude? (Point 4 above)
-    ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv
-    -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude
-    -- will not appear in rnImports automatically if it is set.)
-
-    -- Continue only the name is imported from Prelude
-    ; when (importedViaPrelude name rnImports) $ do
-      -- Handle 2.-4.
-    { rdrElts <- fmap (concat . nonDetOccEnvElts . tcg_rdr_env) getGblEnv
-
-    ; let clashes :: GlobalRdrElt -> Bool
-          clashes x = isLocalDef && nameClashes && isNotInProperModule
-            where
-              isLocalDef = gre_lcl x == True
-              -- Names are identical ...
-              nameClashes = nameOccName (greMangledName x) == nameOccName name
-              -- ... but not the actual definitions, because we don't want to
-              -- warn about a bad definition of e.g. <> in Data.Semigroup, which
-              -- is the (only) proper place where this should be defined
-              isNotInProperModule = greMangledName x /= name
-
-          -- List of all offending definitions
-          clashingElts :: [GlobalRdrElt]
-          clashingElts = filter clashes rdrElts
-
-    ; traceTc "tcPreludeClashWarn/prelude_functions"
-                (hang (ppr name) 4 (sep [ppr clashingElts]))
-
-    ; let warn_msg x = addDiagnosticAt (nameSrcSpan (greMangledName x)) $
-            mkTcRnUnknownMessage $
-            mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $ (hsep
-              [ text "Local definition of"
-              , (quotes . ppr . nameOccName . greMangledName) x
-              , text "clashes with a future Prelude name." ]
-              $$
-              text "This will become an error in a future release." )
-    ; mapM_ warn_msg clashingElts
-    }}}
-
-  where
-
-    -- Is the given name imported via Prelude?
-    --
-    -- Possible scenarios:
-    --   a) Prelude is imported implicitly, issue warnings.
-    --   b) Prelude is imported explicitly, but without mentioning the name in
-    --      question. Issue no warnings.
-    --   c) Prelude is imported hiding the name in question. Issue no warnings.
-    --   d) Qualified import of Prelude, no warnings.
-    importedViaPrelude :: Name
-                       -> [ImportDecl GhcRn]
-                       -> Bool
-    importedViaPrelude name = any importViaPrelude
-      where
-        isPrelude :: ImportDecl GhcRn -> Bool
-        isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME
-
-        -- Implicit (Prelude) import?
-        isImplicit :: ImportDecl GhcRn -> Bool
-        isImplicit = ideclImplicit . ideclExt
-
-        -- Unqualified import?
-        isUnqualified :: ImportDecl GhcRn -> Bool
-        isUnqualified = not . isImportDeclQualified . ideclQualified
-
-        -- List of explicitly imported (or hidden) Names from a single import.
-        --   Nothing -> No explicit imports
-        --   Just (False, <names>) -> Explicit import list of <names>
-        --   Just (True , <names>) -> Explicit hiding of <names>
-        importListOf :: ImportDecl GhcRn -> Maybe (ImportListInterpretation, [Name])
-        importListOf = fmap toImportList . ideclImportList
-          where
-            toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc))
-
-        isExplicit :: ImportDecl GhcRn -> Bool
-        isExplicit x = case importListOf x of
-            Nothing -> False
-            Just (Exactly, explicit)
-                -> nameOccName name `elem`    map nameOccName explicit
-            Just (EverythingBut, hidden)
-                -> nameOccName name `notElem` map nameOccName hidden
-
-        -- Check whether the given name would be imported (unqualified) from
-        -- an import declaration.
-        importViaPrelude :: ImportDecl GhcRn -> Bool
-        importViaPrelude x = isPrelude x
-                          && isUnqualified x
-                          && (isImplicit x || isExplicit x)
-
-
--- Notation: is* is for classes the type is an instance of, should* for those
---           that it should also be an instance of based on the corresponding
---           is*.
-tcMissingParentClassWarn :: WarningFlag
-                         -> Name -- ^ Instances of this ...
-                         -> Name -- ^ should also be instances of this
-                         -> TcM ()
-tcMissingParentClassWarn warnFlag isName shouldName
-  = do { warn <- woptM warnFlag
-       ; when warn $ do
-       { traceTc "tcMissingParentClassWarn" empty
-       ; isClass'     <- tcLookupClass_maybe isName
-       ; shouldClass' <- tcLookupClass_maybe shouldName
-       ; case (isClass', shouldClass') of
-              (Just isClass, Just shouldClass) -> do
-                  { localInstances <- tcGetInsts
-                  ; let isInstance m = is_cls m == isClass
-                        isInsts = filter isInstance localInstances
-                  ; traceTc "tcMissingParentClassWarn/isInsts" (ppr isInsts)
-                  ; forM_ isInsts (checkShouldInst isClass shouldClass)
-                  }
-              (is',should') ->
-                  traceTc "tcMissingParentClassWarn/notIsShould"
-                          (hang (ppr isName <> text "/" <> ppr shouldName) 2 (
-                            (hsep [ quotes (text "Is"), text "lookup for"
-                                  , ppr isName
-                                  , text "resulted in", ppr is' ])
-                            $$
-                            (hsep [ quotes (text "Should"), text "lookup for"
-                                  , ppr shouldName
-                                  , text "resulted in", ppr should' ])))
-       }}
-  where
-    -- Check whether the desired superclass exists in a given environment.
-    checkShouldInst :: Class   -- Class of existing instance
-                    -> Class   -- Class there should be an instance of
-                    -> ClsInst -- Existing instance
-                    -> TcM ()
-    checkShouldInst isClass shouldClass isInst
-      = do { instEnv <- tcGetInstEnvs
-           ; let (instanceMatches, shouldInsts, _)
-                    = lookupInstEnv False instEnv shouldClass (is_tys isInst)
-
-           ; traceTc "tcMissingParentClassWarn/checkShouldInst"
-                     (hang (ppr isInst) 4
-                         (sep [ppr instanceMatches, ppr shouldInsts]))
-
-           -- "<location>: Warning: <type> is an instance of <is> but not
-           -- <should>" e.g. "Foo is an instance of Monad but not Applicative"
-           ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst
-                 warnMsg (RM_KnownTc name:_) =
-                      addDiagnosticAt instLoc $
-                        mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag warnFlag) noHints $
-                           hsep [ (quotes . ppr . nameOccName) name
-                                , text "is an instance of"
-                                , (ppr . nameOccName . className) isClass
-                                , text "but not"
-                                , (ppr . nameOccName . className) shouldClass ]
-                                <> text "."
-                           $$
-                           hsep [ text "This will become an error in"
-                                , text "a future release." ]
-                 warnMsg _ = pure ()
-           ; when (nullUnifiers shouldInsts && null instanceMatches) $
-                  warnMsg (is_tcs isInst)
-           }
-
-    tcLookupClass_maybe :: Name -> TcM (Maybe Class)
-    tcLookupClass_maybe name = tcLookupImported_maybe name >>= \case
-        Succeeded (ATyCon tc) | cls@(Just _) <- tyConClass_maybe tc -> pure cls
-        _else -> pure Nothing
-
-
----------------------------
-tcTyClsInstDecls :: [TyClGroup GhcRn]
-                 -> [LDerivDecl GhcRn]
-                 -> [(RecFlag, LHsBinds GhcRn)]
-                 -> TcM (TcGblEnv,            -- The full inst env
-                         [InstInfo GhcRn],    -- Source-code instance decls to
-                                              -- process; contains all dfuns for
-                                              -- this module
-                          ThBindEnv,          -- TH binding levels
-                          HsValBinds GhcRn)   -- Supporting bindings for derived
-                                              -- instances
-
-tcTyClsInstDecls tycl_decls deriv_decls binds
- = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $
-   tcAddPatSynPlaceholders (getPatSynBinds binds) $
-   do { (tcg_env, inst_info, deriv_info, th_bndrs)
-          <- tcTyAndClassDecls tycl_decls ;
-      ; setGblEnv tcg_env $ do {
-          -- With the @TyClDecl@s and @InstDecl@s checked we're ready to
-          -- process the deriving clauses, including data family deriving
-          -- clauses discovered in @tcTyAndClassDecls@.
-          --
-          -- Careful to quit now in case there were instance errors, so that
-          -- the deriving errors don't pile up as well.
-          ; failIfErrsM
-          ; (tcg_env', inst_info', val_binds)
-              <- tcInstDeclsDeriv deriv_info deriv_decls
-          ; setGblEnv tcg_env' $ do {
-                failIfErrsM
-              ; pure ( tcg_env', inst_info' ++ inst_info, th_bndrs, val_binds )
-      }}}
-
-{- *********************************************************************
-*                                                                      *
-        Checking for 'main'
-*                                                                      *
-************************************************************************
--}
-
-checkMainType :: TcGblEnv -> TcRn WantedConstraints
--- If this is the Main module, and it defines a function main,
---   check that its type is of form IO tau.
--- If not, do nothing
--- See Note [Dealing with main]
-checkMainType tcg_env
-  = do { hsc_env <- getTopEnv
-       ; if tcg_mod tcg_env /= mainModIs (hsc_HUE hsc_env)
-         then return emptyWC else
-
-    do { rdr_env <- getGlobalRdrEnv
-       ; let dflags    = hsc_dflags hsc_env
-             main_occ  = getMainOcc dflags
-             main_gres = lookupGlobalRdrEnv rdr_env main_occ
-       ; case filter isLocalGRE main_gres of {
-            []         -> return emptyWC ;
-            (_:_:_)    -> return emptyWC ;
-            [main_gre] ->
-
-    do { let main_name = greMangledName main_gre
-             ctxt      = FunSigCtxt main_name NoRRC
-       ; main_id   <- tcLookupId main_name
-       ; (io_ty,_) <- getIOType
-       ; let main_ty   = idType main_id
-             eq_orig   = TypeEqOrigin { uo_actual   = main_ty
-                                      , uo_expected = io_ty
-                                      , uo_thing    = Nothing
-                                      , uo_visible  = True }
-       ; (_, lie)  <- captureTopConstraints       $
-                      setMainCtxt main_name io_ty $
-                      tcSubTypeSigma eq_orig ctxt main_ty io_ty
-       ; return lie } } } }
-
-checkMain :: Bool  -- False => no 'module M(..) where' header at all
-          -> Maybe (LocatedL [LIE GhcPs])  -- Export specs of Main module
-          -> TcM TcGblEnv
--- If we are in module Main, check that 'main' is exported,
--- and generate the runMainIO binding that calls it
--- See Note [Dealing with main]
-checkMain explicit_mod_hdr export_ies
- = do { hsc_env  <- getTopEnv
-      ; tcg_env <- getGblEnv
-
-      ; let dflags      = hsc_dflags hsc_env
-            main_mod    = mainModIs (hsc_HUE hsc_env)
-            main_occ    = getMainOcc dflags
-
-            exported_mains :: [Name]
-            -- Exported things that are called 'main'
-            exported_mains  = [ name | avail <- tcg_exports tcg_env
-                                     , name  <- availNames avail
-                                     , nameOccName name == main_occ ]
-
-      ; if | tcg_mod tcg_env /= main_mod
-           -> -- Not the main module
-              return tcg_env
-
-           | [main_name] <- exported_mains
-           -> -- The module indeed exports a function called 'main'
-              generateMainBinding tcg_env main_name
-
-           | otherwise
-           -> assert (null exported_mains) $
-              -- A fully-checked export list can't contain more
-              -- than one function with the same OccName
-              do { complain_no_main dflags main_mod main_occ
-                 ; return tcg_env } }
-  where
-    complain_no_main dflags main_mod main_occ
-      = unless (interactive && not explicit_mod_hdr) $
-        addErrTc (noMainMsg main_mod main_occ)          -- #12906
-      where
-        interactive = ghcLink dflags == LinkInMemory
-        -- Without an explicit module header...
-        -- in interactive mode, don't worry about the absence of 'main'.
-        -- in other modes, add error message and go on with typechecking.
-
-    noMainMsg main_mod main_occ
-      = mkTcRnUnknownMessage $ mkPlainError noHints $
-            text "The" <+> ppMainFn main_occ
-        <+> text "is not" <+> text defOrExp <+> text "module"
-        <+> quotes (ppr main_mod)
-
-    defOrExp | explicit_export_list = "exported by"
-             | otherwise            = "defined in"
-    explicit_export_list = explicit_mod_hdr && isJust export_ies
-
--- | Get the unqualified name of the function to use as the \"main\" for the main module.
--- Either returns the default name or the one configured on the command line with -main-is
-getMainOcc :: DynFlags -> OccName
-getMainOcc dflags = case mainFunIs dflags of
-                      Just fn -> mkVarOccFS (mkFastString fn)
-                      Nothing -> mainOcc
-
-ppMainFn :: OccName -> SDoc
-ppMainFn main_occ
-  | main_occ == mainOcc
-  = text "IO action" <+> quotes (ppr main_occ)
-  | otherwise
-  = text "main IO action" <+> quotes (ppr main_occ)
-
-mainOcc :: OccName
-mainOcc = mkVarOccFS (fsLit "main")
-
-generateMainBinding :: TcGblEnv -> Name -> TcM TcGblEnv
--- There is a single exported 'main' function, called 'foo' (say),
--- which may be locally defined or imported
--- Define and typecheck the binding
---     :Main.main :: IO res_ty = runMainIO res_ty foo
--- This wraps the user's main function in the top-level stuff
--- defined in runMainIO (eg catching otherwise un-caught exceptions)
--- See Note [Dealing with main]
-generateMainBinding tcg_env main_name = do
-    { traceTc "checkMain found" (ppr main_name)
-    ; (io_ty, res_ty) <- getIOType
-    ; let loc = getSrcSpan main_name
-          main_expr_rn = L (noAnnSrcSpan loc) (HsVar noExtField (L (noAnnSrcSpan loc) main_name))
-    ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $
-                               tcCheckMonoExpr main_expr_rn io_ty
-
-            -- See Note [Root-main Id]
-            -- Construct the binding
-            --      :Main.main :: IO res_ty = runMainIO res_ty main
-    ; run_main_id <- tcLookupId runMainIOName
-    ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN
-                               (mkVarOccFS (fsLit "main"))
-                               (getSrcSpan main_name)
-          ; root_main_id = Id.mkExportedVanillaId root_main_name io_ty
-          ; co  = mkWpTyApps [res_ty]
-          -- The ev_binds of the `main` function may contain deferred
-          -- type errors when type of `main` is not `IO a`. The `ev_binds`
-          -- must be put inside `runMainIO` to ensure the deferred type
-          -- error can be emitted correctly. See #13838.
-          ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $
-                    mkHsDictLet ev_binds main_expr
-          ; main_bind = mkVarBind root_main_id rhs }
-
-    ; return (tcg_env { tcg_main  = Just main_name
-                      , tcg_binds = tcg_binds tcg_env
-                                    `snocBag` main_bind
-                      , tcg_dus   = tcg_dus tcg_env
-                                    `plusDU` usesOnly (unitFV main_name) })
-                    -- Record the use of 'main', so that we don't
-                    -- complain about it being defined but not used
-    }
-
-getIOType :: TcM (TcType, TcType)
--- Return (IO alpha, alpha) for fresh alpha
-getIOType = do { ioTyCon <- tcLookupTyCon ioTyConName
-               ; res_ty <- newFlexiTyVarTy liftedTypeKind
-               ; return (mkTyConApp ioTyCon [res_ty], res_ty) }
-
-setMainCtxt :: Name -> TcType -> TcM a -> TcM (TcEvBinds, a)
-setMainCtxt main_name io_ty thing_inside
-  = setSrcSpan (getSrcSpan main_name) $
-    addErrCtxt main_ctxt              $
-    checkConstraints skol_info [] []  $  -- Builds an implication if necessary
-    thing_inside                         -- e.g. with -fdefer-type-errors
-  where
-    skol_info = SigSkol (FunSigCtxt main_name NoRRC) io_ty []
-    main_ctxt = text "When checking the type of the"
-                <+> ppMainFn (nameOccName main_name)
-
-{- Note [Dealing with main]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Dealing with the 'main' declaration is surprisingly tricky. Here are
-the moving parts:
-
-* The flag -main-is=M.foo allows you to set the main module to 'M',
-  and the main function to 'foo'.  We access them through
-      mainModIs  :: HscEnv -> Module     -- returns M
-      getMainOcc :: DynFlags -> OccName  -- returns foo
-  Of course usually M = Main, and foo = main.
-
-* checkMainType: when typechecking module M, we add an extra check that
-    foo :: IO tau, for some type tau.
-  This avoids getting ambiguous-type errors from the monomorphism restriction
-  applying to things like
-      main = return ()
-  Note that checkMainType does not consult the export list because
-  we have not yet done rnExports (and can't do it until later).
-
-* rnExports: checks the export list.  Very annoyingly, we can only do
-  this after running any finalisers, which may add new declarations.
-  That's why checkMainType and checkMain have to be separate.
-
-* checkMain: does two things:
-  - check that the export list does indeed export something called 'foo'
-  - generateMainBinding: generate the root-main binding
-       :Main.main = runMainIO M.foo
-  See Note [Root-main Id]
-
-An annoying consequence of having both checkMainType and checkMain is
-that, when (but only when) -fdefer-type-errors is on, we may report an
-ill-typed 'main' twice (as warnings): once in checkMainType and once
-in checkMain. See test typecheck/should_fail/T13292.
-
-We have the following tests to check this processing:
-----------------+----------------------------------------------------------------------------------+
-                |                                  Module Header:                                  |
-                +-------------+-------------+-------------+-------------+-------------+------------+
-                | module      | module Main | <No Header> | module Main |module       |module Main |
-                |  Main(main) |             |             |   (module X)|   Main ()   |  (Sub.main)|
-----------------+==================================================================================+
-`main` function | ERROR:      | Main.main   | ERROR:      | Main.main   | ERROR:      | Sub.main   |
-in Main module  |  Ambiguous  |             |  Ambiguous  |             |  `main` not |            |
-and in imported |             |             |             |             |  exported   |            |
-module Sub.     | T19397E1    | T16453M0    | T19397E2    | T16453M3    |             | T16453M1   |
-                |             |             |             | X = Main    | Remark 2)   |            |
-----------------+-------------+-------------+-------------+-------------+-------------+------------+
-`main`function  | Sub.main    | ERROR:      | Sub.main    | Sub.main    | ERROR:      | Sub.main   |
-only in imported|             | No `main` in|             |             |  `main` not |            |
-submodule Sub.  |             |   `Main`    |             |             |  exported   |            |
-                | T19397M0    | T16453E1    | T19397M1    | T16453M4    |             | T16453M5   |
-                |             |             |             | X = Sub     | Remark 2)   |            |
-----------------+-------------+-------------+-------------+-------------+-------------+------------+
-`foo` function  | Sub.foo     | ERROR:      | Sub.foo     | Sub.foo     | ERROR:      | Sub.foo    |
-in submodule    |             | No `foo` in |             |             |  `foo` not  |            |
-Sub.            |             |   `Main`    |             |             |  exported   |            |
-GHC option:     |             |             |             |             |             |            |
-  -main-is foo  | T19397M2    | T19397E3    | T19397M3    | T19397M4    | T19397E4    | T16453M6   |
-                | Remark 1)   |             |             | X = Sub     |             | Remark 3)  |
-----------------+-------------+-------------+-------------+-------------+-------------+------------+
-
-Remarks:
-* The first line shows the exported `main` function or the error.
-* The second line shows the coresponding test case.
-* The module `Sub` contains the following functions:
-     main :: IO ()
-     foo :: IO ()
-* Remark 1) Here the header is `Main (foo)`.
-* Remark 2) Here we have no extra test case. It would exercise the same code path as `T19397E4`.
-* Remark 3) Here the header is `Main (Sub.foo)`.
-
-
-Note [Root-main Id]
-~~~~~~~~~~~~~~~~~~~
-The function that the RTS invokes is always :Main.main, which we call
-root_main_id.  (Because GHC allows the user to have a module not
-called Main as the main module, we can't rely on the main function
-being called "Main.main".  That's why root_main_id has a fixed module
-":Main".)
-
-This is unusual: it's a LocalId whose Name has a Module from another
-module. Tiresomely, we must filter it out again in GHC.Iface.Make, less we
-get two defns for 'main' in the interface file!
-
-
-*********************************************************
-*                                                       *
-                GHCi stuff
-*                                                       *
-*********************************************************
--}
-
-runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, Maybe a)
--- Initialise the tcg_inst_env with instances from all home modules.
--- This mimics the more selective call to hptInstances in tcRnImports
-runTcInteractive hsc_env thing_inside
-  = initTcInteractive hsc_env $ withTcPlugins hsc_env $
-    withDefaultingPlugins hsc_env $ withHoleFitPlugins hsc_env $
-    do { traceTc "setInteractiveContext" $
-            vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
-                 , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) (instEnvElts ic_insts))
-                 , text "icReaderEnv (LocalDef)" <+>
-                      vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (icReaderEnv icxt)
-                                                 , let local_gres = filter isLocalGRE gres
-                                                 , not (null local_gres) ]) ]
-
-       ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface
-                                          : dep_orphs (mi_deps iface))
-                                 (loadSrcInterface (text "runTcInteractive") m
-                                                   NotBoot mb_pkg)
-
-       ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
-            case i of                   -- force above: see #15111
-                IIModule n -> getOrphans n NoPkgQual
-                IIDecl i   -> getOrphans (unLoc (ideclName i))
-                                         (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
-
-       ; let imports = emptyImportAvails { imp_orphs = orphs }
-
-             upd_envs (gbl_env, lcl_env) = (gbl_env', lcl_env')
-               where
-                 gbl_env' = gbl_env { tcg_rdr_env      = icReaderEnv icxt
-                                    , tcg_type_env     = type_env
-
-                                    , tcg_inst_env     = tcg_inst_env gbl_env `unionInstEnv` ic_insts `unionInstEnv` home_insts
-                                    , tcg_fam_inst_env = extendFamInstEnvList
-                                               (extendFamInstEnvList (tcg_fam_inst_env gbl_env)
-                                                                     ic_finsts)
-                                               home_fam_insts
-                                    , tcg_field_env    = mkNameEnv con_fields
-                                         -- setting tcg_field_env is necessary
-                                         -- to make RecordWildCards work (test: ghci049)
-                                    , tcg_fix_env      = ic_fix_env icxt
-                                    , tcg_default      = ic_default icxt
-                                         -- must calculate imp_orphs of the ImportAvails
-                                         -- so that instance visibility is done correctly
-                                    , tcg_imports      = imports }
-
-                 lcl_env' = tcExtendLocalTypeEnv lcl_env lcl_ids
-
-       ; updEnvs upd_envs thing_inside }
-  where
-    (home_insts, home_fam_insts) = hptAllInstances hsc_env
-
-    icxt                     = hsc_IC hsc_env
-    (ic_insts, ic_finsts)    = ic_instances icxt
-    (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt)
-
-    is_closed :: TyThing -> Either (Name, TcTyThing) TyThing
-    -- Put Ids with free type variables (always RuntimeUnks)
-    -- in the *local* type environment
-    -- See Note [Initialising the type environment for GHCi]
-    is_closed thing
-      | AnId id <- thing
-      , not (isTypeClosedLetBndr id)
-      = Left (idName id, ATcId { tct_id = id
-                               , tct_info = NotLetBound })
-      | otherwise
-      = Right thing
-
-    type_env1 = mkTypeEnvWithImplicits top_ty_things
-    type_env  = extendTypeEnvWithIds type_env1 (map instanceDFunId (instEnvElts ic_insts))
-                -- Putting the dfuns in the type_env
-                -- is just to keep Core Lint happy
-
-    con_fields = [ (dataConName c, dataConFieldLabels c)
-                 | ATyCon t <- top_ty_things
-                 , c <- tyConDataCons t ]
-
-
-{- Note [Initialising the type environment for GHCi]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Most of the Ids in ic_things, defined by the user in 'let' stmts,
-have closed types. E.g.
-   ghci> let foo x y = x && not y
-
-However the GHCi debugger creates top-level bindings for Ids whose
-types have free RuntimeUnk skolem variables, standing for unknown
-types.  If we don't register these free TyVars as global TyVars then
-the typechecker will try to quantify over them and fall over in
-skolemiseQuantifiedTyVar. so we must add any free TyVars to the
-typechecker's global TyVar set.  That is done by using
-tcExtendLocalTypeEnv.
-
-We do this by splitting out the Ids with open types, using 'is_closed'
-to do the partition.  The top-level things go in the global TypeEnv;
-the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the
-local TypeEnv.
-
-Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope
-things are already in the interactive context's GlobalRdrEnv.
-Extending the local RdrEnv isn't terrible, but it means there is an
-entry for the same Name in both global and local RdrEnvs, and that
-lead to duplicate "perhaps you meant..." suggestions (e.g. T5564).
-
-We don't bother with the tcl_th_bndrs environment either.
--}
-
--- | The returned [Id] is the list of new Ids bound by this statement. It can
--- be used to extend the InteractiveContext via extendInteractiveContext.
---
--- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound
--- values, coerced to ().
-tcRnStmt :: HscEnv -> GhciLStmt GhcPs
-         -> IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
-tcRnStmt hsc_env rdr_stmt
-  = runTcInteractive hsc_env $ do {
-
-    -- The real work is done here
-    ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ;
-    zonked_expr <- zonkTopLExpr tc_expr ;
-    zonked_ids  <- zonkTopBndrs bound_ids ;
-
-    failIfErrsM ;  -- we can't do the next step if there are
-                   -- representation polymorphism errors
-                   -- test case: ghci/scripts/T13202{,a}
-
-        -- None of the Ids should be of unboxed type, because we
-        -- cast them all to HValues in the end!
-    mapM_ bad_unboxed (filter (mightBeUnliftedType . idType) zonked_ids) ;
-
-    traceTc "tcs 1" empty ;
-    this_mod <- getModule ;
-    global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ;
-        -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env
-
-    traceOptTcRn Opt_D_dump_tc
-        (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
-               text "Typechecked expr" <+> ppr zonked_expr]) ;
-
-    return (global_ids, zonked_expr, fix_env)
-    }
-  where
-    bad_unboxed id = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-      (sep [text "GHCi can't bind a variable of unlifted type:",
-                                  nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id))])
-
-{-
---------------------------------------------------------------------------
-                Typechecking Stmts in GHCi
-
-Here is the grand plan, implemented in tcUserStmt
-
-        What you type                   The IO [HValue] that hscStmt returns
-        -------------                   ------------------------------------
-        let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
-                                        bindings: [x,y,...]
-
-        pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
-                                        bindings: [x,y,...]
-
-        expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
-          [NB: result not printed]      bindings: [it]
-
-        expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
-          result showable)              bindings: [it]
-
-        expr (of non-IO type,
-          result not showable)  ==>     error
--}
-
--- | A plan is an attempt to lift some code into the IO monad.
-type PlanResult = ([Id], LHsExpr GhcTc)
-type Plan = TcM PlanResult
-
--- | Try the plans in order. If one fails (by raising an exn), try the next.
--- If one succeeds, take it.
-runPlans :: NonEmpty Plan -> Plan
-runPlans = foldr1 (flip tryTcDiscardingErrs)
-
--- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the
--- GHCi 'environment'.
---
--- By 'lift' and 'environment we mean that the code is changed to
--- execute properly in an IO monad. See Note [Interactively-bound Ids
--- in GHCi] in GHC.Driver.Env for more details. We do this lifting by trying
--- different ways ('plans') of lifting the code into the IO monad and
--- type checking each plan until one succeeds.
-tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
-
--- An expression typed at the prompt is treated very specially
-tcUserStmt (L loc (BodyStmt _ expr _ _))
-  = do  { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)
-
-        ; dumpOptTcRn Opt_D_dump_rn_ast "Renamer" FormatHaskell
-            (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_expr)
-               -- Don't try to typecheck if the renamer fails!
-        ; ghciStep <- getGhciStepIO
-        ; uniq <- newUnique
-        ; let loc' = noAnnSrcSpan $ locA loc
-        ; interPrintName <- getInteractivePrintName
-        ; let fresh_it  = itName uniq (locA loc)
-              matches   = [mkMatch (mkPrefixFunRhs (L loc' fresh_it)) [] rn_expr
-                                   emptyLocalBinds]
-              -- [it = expr]
-              the_bind  = L loc $ (mkTopFunBind FromSource
-                                     (L loc' fresh_it) matches)
-                                         { fun_ext = fvs }
-              -- Care here!  In GHCi the expression might have
-              -- free variables, and they in turn may have free type variables
-              -- (if we are at a breakpoint, say).  We must put those free vars
-
-              -- [let it = expr]
-              let_stmt  = L loc $ LetStmt noAnn $ HsValBinds noAnn
-                           $ XValBindsLR
-                               (NValBinds [(NonRecursive,unitBag the_bind)] [])
-
-              -- [it <- e]
-              bind_stmt = L loc $ BindStmt
-                                       (XBindStmtRn
-                                          { xbsrn_bindOp = mkRnSyntaxExpr bindIOName
-                                          , xbsrn_failOp = Nothing
-                                          })
-                                       (L loc (VarPat noExtField (L loc' fresh_it)))
-                                       (nlHsApp ghciStep rn_expr)
-
-              -- [; print it]
-              print_it  = L loc $ BodyStmt noExtField
-                                           (nlHsApp (nlHsVar interPrintName)
-                                           (nlHsVar fresh_it))
-                                           (mkRnSyntaxExpr thenIOName)
-                                                  noSyntaxExpr
-
-              -- NewA
-              no_it_a = L loc $ BodyStmt noExtField (nlHsApps bindIOName
-                                       [rn_expr , nlHsVar interPrintName])
-                                       (mkRnSyntaxExpr thenIOName)
-                                       noSyntaxExpr
-
-              no_it_b = L loc $ BodyStmt noExtField (rn_expr)
-                                       (mkRnSyntaxExpr thenIOName)
-                                       noSyntaxExpr
-
-              no_it_c = L loc $ BodyStmt noExtField
-                                      (nlHsApp (nlHsVar interPrintName) rn_expr)
-                                      (mkRnSyntaxExpr thenIOName)
-                                      noSyntaxExpr
-
-              -- See Note [GHCi Plans]
-
-              it_plans =
-                    -- Plan A
-                    do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
-                       ; it_ty <- zonkTcType (idType it_id)
-                       ; when (isUnitTy it_ty) failM
-                       ; return stuff } :|
-
-                        -- Plan B; a naked bind statement
-                  [ tcGhciStmts [bind_stmt]
-
-                        -- Plan C; check that the let-binding is typeable all by itself.
-                        -- If not, fail; if so, try to print it.
-                        -- The two-step process avoids getting two errors: one from
-                        -- the expression itself, and one from the 'print it' part
-                        -- This two-step story is very clunky, alas
-                  , do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
-                                --- checkNoErrs defeats the error recovery of let-bindings
-                       ; tcGhciStmts [let_stmt, print_it] } ]
-
-              -- Plans where we don't bind "it"
-              no_it_plans =
-                tcGhciStmts [no_it_a] :|
-                tcGhciStmts [no_it_b] :
-                tcGhciStmts [no_it_c] :
-                []
-
-        ; generate_it <- goptM Opt_NoIt
-
-        -- We disable `-fdefer-type-errors` in GHCi for naked expressions.
-        -- See Note [Deferred type errors in GHCi]
-
-        -- NB: The flag `-fdefer-type-errors` implies `-fdefer-type-holes`
-        -- and `-fdefer-out-of-scope-variables`. However the flag
-        -- `-fno-defer-type-errors` doesn't imply `-fdefer-type-holes` and
-        -- `-fno-defer-out-of-scope-variables`. Thus the later two flags
-        -- also need to be unset here.
-        ; plan <- unsetGOptM Opt_DeferTypeErrors $
-                  unsetGOptM Opt_DeferTypedHoles $
-                  unsetGOptM Opt_DeferOutOfScopeVariables $
-                    runPlans $ if generate_it
-                                 then no_it_plans
-                                 else it_plans
-
-        ; dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell
-              (showAstData NoBlankSrcSpan NoBlankEpAnnotations plan)
-
-        ; fix_env <- getFixityEnv
-        ; return (plan, fix_env) }
-
-{- Note [Deferred type errors in GHCi]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In GHCi, we ensure that type errors don't get deferred when type checking the
-naked expressions. Deferring type errors here is unhelpful because the
-expression gets evaluated right away anyway. It also would potentially emit
-two redundant type-error warnings, one from each plan.
-
-#14963 reveals another bug that when deferred type errors is enabled
-in GHCi, any reference of imported/loaded variables (directly or indirectly)
-in interactively issued naked expressions will cause ghc panic. See more
-detailed discussion in #14963.
-
-The interactively issued declarations, statements, as well as the modules
-loaded into GHCi, are not affected. That means, for declaration, you could
-have
-
-    Prelude> :set -fdefer-type-errors
-    Prelude> x :: IO (); x = putStrLn True
-    <interactive>:14:26: warning: [-Wdeferred-type-errors]
-        ? Couldn't match type ‘Bool’ with ‘[Char]’
-          Expected type: String
-            Actual type: Bool
-        ? In the first argument of ‘putStrLn’, namely ‘True’
-          In the expression: putStrLn True
-          In an equation for ‘x’: x = putStrLn True
-
-But for naked expressions, you will have
-
-    Prelude> :set -fdefer-type-errors
-    Prelude> putStrLn True
-    <interactive>:2:10: error:
-        ? Couldn't match type ‘Bool’ with ‘[Char]’
-          Expected type: String
-            Actual type: Bool
-        ? In the first argument of ‘putStrLn’, namely ‘True’
-          In the expression: putStrLn True
-          In an equation for ‘it’: it = putStrLn True
-
-    Prelude> let x = putStrLn True
-    <interactive>:2:18: warning: [-Wdeferred-type-errors]
-        ? Couldn't match type ‘Bool’ with ‘[Char]’
-          Expected type: String
-            Actual type: Bool
-        ? In the first argument of ‘putStrLn’, namely ‘True’
-          In the expression: putStrLn True
-          In an equation for ‘x’: x = putStrLn True
--}
-
-tcUserStmt rdr_stmt@(L loc _)
-  = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $
-           rnStmts (HsDoStmt GhciStmtCtxt) rnExpr [rdr_stmt] $ \_ -> do
-             fix_env <- getFixityEnv
-             return (fix_env, emptyFVs)
-            -- Don't try to typecheck if the renamer fails!
-       ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
-       ; rnDump rn_stmt ;
-
-       ; ghciStep <- getGhciStepIO
-       ; let gi_stmt
-               | (L loc (BindStmt x pat expr)) <- rn_stmt
-                     = L loc $ BindStmt x pat (nlHsApp ghciStep expr)
-               | otherwise = rn_stmt
-
-       ; opt_pr_flag <- goptM Opt_PrintBindResult
-       ; let print_result_plan
-               | opt_pr_flag                         -- The flag says "print result"
-               , [v] <- collectLStmtBinders CollNoDictBinders gi_stmt  -- One binder
-               = Just $ mk_print_result_plan gi_stmt v
-               | otherwise = Nothing
-
-        -- The plans are:
-        --      [stmt; print v]         if one binder and not v::()
-        --      [stmt]                  otherwise
-       ; plan <- runPlans $ maybe id (NE.<|) print_result_plan $ NE.singleton $ tcGhciStmts [gi_stmt]
-       ; return (plan, fix_env) }
-  where
-    mk_print_result_plan stmt v
-      = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
-           ; v_ty <- zonkTcType (idType v_id)
-           ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
-           ; return stuff }
-      where
-        print_v  = L loc $ BodyStmt noExtField (nlHsApp (nlHsVar printName)
-                                    (nlHsVar v))
-                                    (mkRnSyntaxExpr thenIOName) noSyntaxExpr
-
-{-
-Note [GHCi Plans]
-~~~~~~~~~~~~~~~~~
-When a user types an expression in the repl we try to print it in three different
-ways. Also, depending on whether -fno-it is set, we bind a variable called `it`
-which can be used to refer to the result of the expression subsequently in the repl.
-
-The normal plans are :
-  A. [it <- e; print e]     but not if it::()
-  B. [it <- e]
-  C. [let it = e; print it]
-
-When -fno-it is set, the plans are:
-  A. [e >>= print]
-  B. [e]
-  C. [let it = e in print it]
-
-The reason for -fno-it is explained in #14336. `it` can lead to the repl
-leaking memory as it is repeatedly queried.
--}
-
--- | Typecheck the statements given and then return the results of the
--- statement in the form 'IO [()]'.
-tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult
-tcGhciStmts stmts
- = do { ioTyCon <- tcLookupTyCon ioTyConName
-      ; ret_id  <- tcLookupId returnIOName             -- return @ IO
-      ; let ret_ty      = mkListTy unitTy
-            io_ret_ty   = mkTyConApp ioTyCon [ret_ty]
-            tc_io_stmts = tcStmtsAndThen (HsDoStmt GhciStmtCtxt) tcDoStmt stmts
-                                         (mkCheckExpType io_ret_ty)
-            names = collectLStmtsBinders CollNoDictBinders stmts
-
-        -- OK, we're ready to typecheck the stmts
-      ; traceTc "GHC.Tc.Module.tcGhciStmts: tc stmts" empty
-      ; ((tc_stmts, ids), lie) <- captureTopConstraints $
-                                  tc_io_stmts $ \ _ ->
-                                  mapM tcLookupId names
-                        -- Look up the names right in the middle,
-                        -- where they will all be in scope
-
-        -- Simplify the context
-      ; traceTc "GHC.Tc.Module.tcGhciStmts: simplify ctxt" empty
-      ; const_binds <- checkNoErrs (simplifyInteractive lie)
-                -- checkNoErrs ensures that the plan fails if context redn fails
-
-
-      ; traceTc "GHC.Tc.Module.tcGhciStmts: done" empty
-
-      -- ret_expr is the expression
-      --      returnIO @[()] [unsafeCoerce# () x, ..,  unsafeCoerce# () z]
-      --
-      -- Despite the inconvenience of building the type applications etc,
-      -- this *has* to be done in type-annotated post-typecheck form
-      -- because we are going to return a list of *polymorphic* values
-      -- coerced to type (). If we built a *source* stmt
-      --      return [coerce x, ..., coerce z]
-      -- then the type checker would instantiate x..z, and we wouldn't
-      -- get their *polymorphic* values.  (And we'd get ambiguity errs
-      -- if they were overloaded, since they aren't applied to anything.)
-
-      ; AnId unsafe_coerce_id <- tcLookupGlobal unsafeCoercePrimName
-           -- We use unsafeCoerce# here because of (U11) in
-           -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
-
-      ; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $
-                       noLocA $ ExplicitList unitTy $
-                       map mk_item ids
-
-            mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id)
-                                                      , getRuntimeRep unitTy
-                                                      , idType id, unitTy]
-                                          `nlHsApp` nlHsVar id
-            stmts = tc_stmts ++ [noLocA (mkLastStmt ret_expr)]
-
-      ; return (ids, mkHsDictLet (EvBinds const_binds) $
-                     noLocA (HsDo io_ret_ty GhciStmtCtxt (noLocA stmts)))
-    }
-
--- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
-getGhciStepIO :: TcM (LHsExpr GhcRn)
-getGhciStepIO = do
-    ghciTy <- getGHCiMonad
-    a_tv <- newName (mkTyVarOccFS (fsLit "a"))
-    let ghciM   = nlHsAppTy (nlHsTyVar NotPromoted ghciTy) (nlHsTyVar NotPromoted a_tv)
-        ioM     = nlHsAppTy (nlHsTyVar NotPromoted ioTyConName) (nlHsTyVar NotPromoted a_tv)
-
-        step_ty :: LHsSigType GhcRn
-        step_ty = noLocA $ HsSig
-                     { sig_bndrs = HsOuterImplicit{hso_ximplicit = [a_tv]}
-                     , sig_ext = noExtField
-                     , sig_body = nlHsFunTy ghciM ioM }
-
-        stepTy :: LHsSigWcType GhcRn
-        stepTy = mkEmptyWildCardBndrs step_ty
-
-    return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy)
-
-isGHCiMonad :: HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name)
-isGHCiMonad hsc_env ty
-  = runTcInteractive hsc_env $ do
-        rdrEnv <- getGlobalRdrEnv
-        let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)
-        case occIO of
-            Just [n] -> do
-                let name = greMangledName n
-                ghciClass <- tcLookupClass ghciIoClassName
-                userTyCon <- tcLookupTyCon name
-                let userTy = mkTyConApp userTyCon []
-                _ <- tcLookupInstance ghciClass [userTy]
-                return name
-
-            Just _  -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text "Ambiguous type!"
-            Nothing -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text ("Can't find type:" ++ ty)
-
--- | How should we infer a type? See Note [TcRnExprMode]
-data TcRnExprMode = TM_Inst     -- ^ Instantiate inferred quantifiers only (:type)
-                  | TM_Default  -- ^ Instantiate all quantifiers,
-                                --   and do eager defaulting (:type +d)
-
--- | tcRnExpr just finds the type of an expression
---   for :type
-tcRnExpr :: HscEnv
-         -> TcRnExprMode
-         -> LHsExpr GhcPs
-         -> IO (Messages TcRnMessage, Maybe Type)
-tcRnExpr hsc_env mode rdr_expr
-  = runTcInteractive hsc_env $
-    do {
-
-    (rn_expr, _fvs) <- rnLExpr rdr_expr ;
-    failIfErrsM ;
-
-    -- Typecheck the expression
-    ((tclvl, res_ty), lie)
-          <- captureTopConstraints $
-             pushTcLevelM          $
-             tcInferSigma inst rn_expr ;
-
-    -- Generalise
-    uniq <- newUnique ;
-    let { fresh_it = itName uniq (getLocA rdr_expr) } ;
-    ((qtvs, dicts, _, _), residual)
-         <- captureConstraints $
-            simplifyInfer tclvl infer_mode
-                          []    {- No sig vars -}
-                          [(fresh_it, res_ty)]
-                          lie ;
-
-    -- Ignore the dictionary bindings
-    _ <- perhaps_disable_default_warnings $
-         simplifyInteractive residual ;
-
-    let { all_expr_ty = mkInfForAllTys qtvs $
-                        mkPhiTy (map idType dicts) res_ty } ;
-    ty <- zonkTcType all_expr_ty ;
-
-    -- See Note [Normalising the type in :type]
-    fam_envs <- tcGetFamInstEnvs ;
-    let { normalised_type = reductionReducedType $ normaliseType fam_envs Nominal ty
-          -- normaliseType returns a coercion which we discard, so the Role is irrelevant.
-        ; final_type = if isSigmaTy res_ty then ty else normalised_type } ;
-    return final_type }
-  where
-    -- Optionally instantiate the type of the expression
-    -- See Note [TcRnExprMode]
-    (inst, infer_mode, perhaps_disable_default_warnings) = case mode of
-      TM_Inst    -> (False, NoRestrictions,  id)
-      TM_Default -> (True,  EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults)
-
-{- Note [Implementing :type]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider   :type const
-
-We want    forall a b. a -> b -> a
-and not    forall {a}{b}. a -> b -> a
-
-The latter is what we'd get if we eagerly instantiated and then
-re-generalised with Inferred binders.  It makes a difference, because
-it tells us we where we can use Visible Type Application (VTA).
-
-And also for   :type const @Int
-we want        forall b. Int -> b -> Int
-and not        forall {b}. Int -> b -> Int
-
-Solution: use tcInferSigma, which in turn uses tcInferApp, which
-has a special case for application chains.
-
-Note [Normalising the type in :type]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In :t <expr> we usually normalise the type (to simplify type functions)
-before displaying the result.  Reason (see #10321): otherwise we may show
-types like
-    <expr> :: Vec (1+2) Int
-rather than the simpler
-    <expr> :: Vec 3 Int
-In GHC.Tc.Gen.Bind.mkInferredPolyId we normalise for a very similar reason.
-
-However this normalisation is less helpful when <expr> is just
-an identifier, whose user-written type happens to contain type-function
-applications.  E.g. (#20974)
-    test :: F [Monad, A, B] m => m ()
-where F is a type family.  If we say `:t test`, we'd prefer to see
-the type family un-expanded.
-
-We adopt the following ad-hoc solution: if the type inferred for <expr>
-(before generalisation, namely res_ty) is a SigmaType (i.e. is not
-fully instantiated) then do not normalise; otherwise normalise.
-This is not ideal; for example, suppose  x :: F Int.  Then
-  :t x
-would be normalised because `F Int` is not a SigmaType.  But
-anything here is ad-hoc, and it's a user-sought improvement.
--}
-
---------------------------
-tcRnImportDecls :: HscEnv
-                -> [LImportDecl GhcPs]
-                -> IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
--- Find the new chunk of GlobalRdrEnv created by this list of import
--- decls.  In contract tcRnImports *extends* the TcGblEnv.
-tcRnImportDecls hsc_env import_decls
- =  runTcInteractive hsc_env $
-    do { gbl_env <- updGblEnv zap_rdr_env $
-                    tcRnImports hsc_env $ map (,text "is directly imported") import_decls
-       ; return (tcg_rdr_env gbl_env) }
-  where
-    zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }
-
--- tcRnType just finds the kind of a type
-tcRnType :: HscEnv
-         -> ZonkFlexi
-         -> Bool        -- Normalise the returned type
-         -> LHsType GhcPs
-         -> IO (Messages TcRnMessage, Maybe (Type, Kind))
-tcRnType hsc_env flexi normalise rdr_type
-  = runTcInteractive hsc_env $
-    setXOptM LangExt.PolyKinds $   -- See Note [Kind-generalise in tcRnType]
-    do { (HsWC { hswc_ext = wcs, hswc_body = rn_sig_type@(L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body })) }, _fvs)
-                 -- we are using 'rnHsSigWcType' to bind the unbound type variables
-                 -- and in combination with 'tcOuterTKBndrs' we are able to
-                 -- implicitly quantify them as if the user wrote 'forall' by
-                 -- hand (see #19217). This allows kind check to work in presence
-                 -- of free type variables :
-                 -- ghci> :k [a]
-                 -- [a] :: *
-               <- rnHsSigWcType GHCiCtx (mkHsWildCardBndrs $ noLocA (mkHsImplicitSigType rdr_type))
-                  -- The type can have wild cards, but no implicit
-                  -- generalisation; e.g.   :kind (T _)
-       ; failIfErrsM
-
-        -- We follow Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType here
-
-        -- Now kind-check the type
-        -- It can have any rank or kind
-        -- First bring into scope any wildcards
-       ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_sig_type])
-       ; si <- mkSkolemInfo $ SigTypeSkol (GhciCtxt True)
-       ; ((_, (ty, kind)), wanted)
-               <- captureTopConstraints $
-                  pushTcLevelM_         $
-                  bindNamedWildCardBinders wcs $ \ wcs' ->
-                  do { mapM_ emitNamedTypeHole wcs'
-                     ; tcOuterTKBndrs si outer_bndrs $ tcInferLHsTypeUnsaturated body }
-       -- Since all the wanteds are equalities, the returned bindings will be empty
-       ; empty_binds <- simplifyTop wanted
-       ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds)
-
-       -- Do kind generalisation; see Note [Kind-generalise in tcRnType]
-       ; kvs <- kindGeneralizeAll unkSkol kind
-
-       ; e <- mkEmptyZonkEnv flexi
-       ; ty  <- zonkTcTypeToTypeX e ty
-
-       -- Do validity checking on type
-       ; checkValidType (GhciCtxt True) ty
-
-       -- Optionally (:k vs :k!) normalise the type. Does two things:
-       --   normaliseType: expand type-family applications
-       --   expandTypeSynonyms: expand type synonyms (#18828)
-       ; fam_envs <- tcGetFamInstEnvs
-       ; let ty' | normalise = expandTypeSynonyms $ reductionReducedType $
-                               normaliseType fam_envs Nominal ty
-                 | otherwise = ty
-
-       ; traceTc "tcRnExpr" (debugPprType ty $$ debugPprType ty')
-       ; return (ty', mkInfForAllTys kvs (typeKind ty')) }
-
-
-{- Note [TcRnExprMode]
-~~~~~~~~~~~~~~~~~~~~~~
-How should we infer a type when a user asks for the type of an expression e
-at the GHCi prompt? We offer 2 different possibilities, described below. Each
-considers this example, with -fprint-explicit-foralls enabled.  See also
-https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0179-printing-foralls.rst
-
-:type / TM_Inst
-
-  In this mode, we report the type obtained by instantiating only the
-  /inferred/ quantifiers of e's type, solving constraints, and
-  re-generalising, as discussed in #11376.
-
-  > :type reverse
-  reverse :: forall a. [a] -> [a]
-
-  -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String
-  > :type foo @Int
-  forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String
-
-  Note that Show Int is still reported, because the solver never got a chance
-  to see it.
-
-:type +d / TM_Default
-
-  This mode is for the benefit of users who wish to see instantiations
-  of generalized types, and in particular to instantiate Foldable and
-  Traversable.  In this mode, all type variables (inferred or
-  specified) are instantiated.  Because GHCi uses
-  -XExtendedDefaultRules, this means that Foldable and Traversable are
-  defaulted.
-
-  > :type +d reverse
-  reverse :: forall {a}. [a] -> [a]
-
-  -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String
-  > :type +d foo @Int
-  Int -> [Integer] -> String
-
-  Note that this mode can sometimes lead to a type error, if a type variable is
-  used with a defaultable class but cannot actually be defaulted:
-
-  bar :: (Num a, Monoid a) => a -> a
-  > :type +d bar
-  ** error **
-
-  The error arises because GHC tries to default a but cannot find a concrete
-  type in the defaulting list that is both Num and Monoid. (If this list is
-  modified to include an element that is both Num and Monoid, the defaulting
-  would succeed, of course.)
-
-  Note that the variables and constraints are reordered here, because this
-  is possible during regeneralization. Also note that the variables are
-  reported as Inferred instead of Specified.
-
-Note [Kind-generalise in tcRnType]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We switch on PolyKinds when kind-checking a user type, so that we will
-kind-generalise the type, even when PolyKinds is not otherwise on.
-This gives the right default behaviour at the GHCi prompt, where if
-you say ":k T", and T has a polymorphic kind, you'd like to see that
-polymorphism. Of course.  If T isn't kind-polymorphic you won't get
-anything unexpected, but the apparent *loss* of polymorphism, for
-types that you know are polymorphic, is quite surprising.  See Trac
-#7688 for a discussion.
-
-Note that the goal is to generalise the *kind of the type*, not
-the type itself! Example:
-  ghci> data SameKind :: k -> k -> Type
-  ghci> :k SameKind _
-
-We want to get `k -> Type`, not `Any -> Type`, which is what we would
-get without kind-generalisation. Note that `:k SameKind` is OK, as
-GHC will not instantiate SameKind here, and so we see its full kind
-of `forall k. k -> k -> Type`.
-
-************************************************************************
-*                                                                      *
-                 tcRnDeclsi
-*                                                                      *
-************************************************************************
-
-tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
--}
-
-tcRnDeclsi :: HscEnv
-           -> [LHsDecl GhcPs]
-           -> IO (Messages TcRnMessage, Maybe TcGblEnv)
-tcRnDeclsi hsc_env local_decls
-  = runTcInteractive hsc_env $
-    tcRnSrcDecls False Nothing local_decls
-
-externaliseAndTidyId :: Module -> Id -> TcM Id
-externaliseAndTidyId this_mod id
-  = do { name' <- externaliseName this_mod (idName id)
-       ; return $ globaliseId id
-                     `setIdName` name'
-                     `setIdType` tidyTopType (idType id) }
-
-
-{-
-************************************************************************
-*                                                                      *
-        More GHCi stuff, to do with browsing and getting info
-*                                                                      *
-************************************************************************
--}
-
--- | ASSUMES that the module is either in the 'HomePackageTable' or is
--- a package module with an interface on disk.  If neither of these is
--- true, then the result will be an error indicating the interface
--- could not be found.
-getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface)
-getModuleInterface hsc_env mod
-  = runTcInteractive hsc_env $
-    loadModuleInterface (text "getModuleInterface") mod
-
-tcRnLookupRdrName :: HscEnv -> LocatedN RdrName
-                  -> IO (Messages TcRnMessage, Maybe [Name])
--- ^ Find all the Names that this RdrName could mean, in GHCi
-tcRnLookupRdrName hsc_env (L loc rdr_name)
-  = runTcInteractive hsc_env $
-    setSrcSpanA loc          $
-    do {   -- If the identifier is a constructor (begins with an
-           -- upper-case letter), then we need to consider both
-           -- constructor and type class identifiers.
-         let rdr_names = dataTcOccs rdr_name
-       ; names_s <- mapM lookupInfoOccRn rdr_names
-       ; let names = concat names_s
-       ; when (null names) (addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-           (text "Not in scope:" <+> quotes (ppr rdr_name)))
-       ; return names }
-
-tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing)
-tcRnLookupName hsc_env name
-  = runTcInteractive hsc_env $
-    tcRnLookupName' name
-
--- To look up a name we have to look in the local environment (tcl_lcl)
--- as well as the global environment, which is what tcLookup does.
--- But we also want a TyThing, so we have to convert:
-
-tcRnLookupName' :: Name -> TcRn TyThing
-tcRnLookupName' name = do
-   tcthing <- tcLookup name
-   case tcthing of
-     AGlobal thing    -> return thing
-     ATcId{tct_id=id} -> return (AnId id)
-     _ -> panic "tcRnLookupName'"
-
-tcRnGetInfo :: HscEnv
-            -> Name
-            -> IO ( Messages TcRnMessage
-                  , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-
--- Used to implement :info in GHCi
---
--- Look up a RdrName and return all the TyThings it might be
--- A capitalised RdrName is given to us in the DataName namespace,
--- but we want to treat it as *both* a data constructor
---  *and* as a type or class constructor;
--- hence the call to dataTcOccs, and we return up to two results
-tcRnGetInfo hsc_env name
-  = runTcInteractive hsc_env $
-    do { loadUnqualIfaces hsc_env (hsc_IC hsc_env)
-           -- Load the interface for all unqualified types and classes
-           -- That way we will find all the instance declarations
-           -- (Packages have not orphan modules, and we assume that
-           --  in the home package all relevant modules are loaded.)
-
-       ; thing  <- tcRnLookupName' name
-       ; fixity <- lookupFixityRn name
-       ; (cls_insts, fam_insts) <- lookupInsts thing
-       ; let info = lookupKnownNameInfo name
-       ; return (thing, fixity, cls_insts, fam_insts, info) }
-
-
--- Lookup all class and family instances for a type constructor.
---
--- This function filters all instances in the type environment, so there
--- is a lot of duplicated work if it is called many times in the same
--- type environment. If this becomes a problem, the NameEnv computed
--- in GHC.getNameToInstancesIndex could be cached in TcM and both functions
--- could be changed to consult that index.
-lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst])
-lookupInsts (ATyCon tc)
-  = do  { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs
-        ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
-                -- Load all instances for all classes that are
-                -- in the type environment (which are all the ones
-                -- we've seen in any interface file so far)
-
-          -- Return only the instances relevant to the given thing, i.e.
-          -- the instances whose head contains the thing's name.
-        ; let cls_insts =
-                 [ ispec        -- Search all
-                 | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
-                 , instIsVisible vis_mods ispec
-                 , tc_name `elemNameSet` orphNamesOfClsInst ispec ]
-        ; let fam_insts =
-                 [ fispec
-                 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
-                 , tc_name `elemNameSet` orphNamesOfFamInst fispec ]
-        ; return (cls_insts, fam_insts) }
-  where
-    tc_name     = tyConName tc
-
-lookupInsts _ = return ([],[])
-
-loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()
--- Load the interface for everything that is in scope unqualified
--- This is so that we can accurately report the instances for
--- something
-loadUnqualIfaces hsc_env ictxt
-  = initIfaceTcRn $
-    mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
-  where
-    home_unit = hsc_home_unit hsc_env
-
-    unqual_mods = [ nameModule name
-                  | gre <- globalRdrEnvElts (icReaderEnv ictxt)
-                  , let name = greMangledName gre
-                  , nameIsFromExternalPackage home_unit name
-                  , isTcOcc (nameOccName name)   -- Types and classes only
-                  , unQualOK gre ]               -- In scope unqualified
-    doc = text "Need interface for module whose export(s) are in scope unqualified"
-
-
-
-{-
-************************************************************************
-*                                                                      *
-                Debugging output
-      This is what happens when you do -ddump-types
-*                                                                      *
-************************************************************************
--}
-
--- | Dump, with a banner, if -ddump-rn
-rnDump :: (Outputable a, Data a) => a -> TcRn ()
-rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn)
-
-tcDump :: TcGblEnv -> TcRn ()
-tcDump env
- = do { unit_state <- hsc_units <$> getTopEnv ;
-        logger <- getLogger ;
-
-        -- Dump short output if -ddump-types or -ddump-tc
-        when (logHasDumpFlag logger Opt_D_dump_types || logHasDumpFlag logger Opt_D_dump_tc)
-          (dumpTcRn True Opt_D_dump_types
-            "" FormatText (pprWithUnitState unit_state short_dump)) ;
-
-        -- Dump bindings if -ddump-tc
-        dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump;
-
-        -- Dump bindings as an hsSyn AST if -ddump-tc-ast
-        dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell ast_dump
-   }
-  where
-    short_dump = pprTcGblEnv env
-    full_dump  = pprLHsBinds (tcg_binds env)
-        -- NB: foreign x-d's have undefined's in their types;
-        --     hence can't show the tc_fords
-    ast_dump = showAstData NoBlankSrcSpan NoBlankEpAnnotations (tcg_binds env)
-
--- It's unpleasant having both pprModGuts and pprModDetails here
-pprTcGblEnv :: TcGblEnv -> SDoc
-pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
-                        tcg_insts     = insts,
-                        tcg_fam_insts = fam_insts,
-                        tcg_rules     = rules,
-                        tcg_imports   = imports })
-  = getPprDebug $ \debug ->
-    vcat [ ppr_types debug type_env
-         , ppr_tycons debug fam_insts type_env
-         , ppr_datacons debug type_env
-         , ppr_patsyns type_env
-         , ppr_insts insts
-         , ppr_fam_insts fam_insts
-         , ppr_rules rules
-         , text "Dependent modules:" <+>
-                (ppr . sort . installedModuleEnvElts $ imp_direct_dep_mods imports)
-         , text "Dependent packages:" <+>
-                ppr (S.toList $ imp_dep_direct_pkgs imports)]
-                -- The use of sort is just to reduce unnecessary
-                -- wobbling in testsuite output
-
-ppr_rules :: [LRuleDecl GhcTc] -> SDoc
-ppr_rules rules
-  = ppUnless (null rules) $
-    hang (text "RULES")
-       2 (vcat (map ppr rules))
-
-ppr_types :: Bool -> TypeEnv -> SDoc
-ppr_types debug type_env
-  = ppr_things "TYPE SIGNATURES" ppr_sig
-             (sortBy (comparing getOccName) ids)
-  where
-    ids = [id | id <- typeEnvIds type_env, want_sig id]
-    want_sig id
-      | debug     = True
-      | otherwise = hasTopUserName id
-                    && case idDetails id of
-                         VanillaId    -> True
-                         WorkerLikeId{} -> True
-                         RecSelId {}  -> True
-                         ClassOpId {} -> True
-                         FCallId {}   -> True
-                         _            -> False
-             -- Data cons (workers and wrappers), pattern synonyms,
-             -- etc are suppressed (unless -dppr-debug),
-             -- because they appear elsewhere
-
-    ppr_sig id = hang (pprPrefixOcc id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
-
-ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc
-ppr_tycons debug fam_insts type_env
-  = vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons
-         , ppr_things "COERCION AXIOMS" ppr_ax
-                      (typeEnvCoAxioms type_env) ]
-  where
-    fi_tycons = famInstsRepTyCons fam_insts
-
-    tycons = sortBy (comparing getOccName) $
-             [tycon | tycon <- typeEnvTyCons type_env
-                    , want_tycon tycon]
-             -- Sort by OccName to reduce unnecessary changes
-    want_tycon tycon | debug      = True
-                     | otherwise  = isExternalName (tyConName tycon) &&
-                                    not (tycon `elem` fi_tycons)
-    ppr_tc tc
-       = vcat [ hang (ppr (tyConFlavour tc) <+> pprPrefixOcc (tyConName tc)
-                      <> braces (ppr (tyConArity tc)) <+> dcolon)
-                   2 (ppr (tidyTopType (tyConKind tc)))
-              , nest 2 $
-                ppWhen show_roles $
-                text "roles" <+> (sep (map ppr roles)) ]
-       where
-         show_roles = debug || not (all (== boring_role) roles)
-         roles = tyConRoles tc
-         boring_role | isClassTyCon tc = Nominal
-                     | otherwise       = Representational
-            -- Matches the choice in GHC.Iface.Syntax, calls to pprRoles
-
-    ppr_ax ax = ppr (coAxiomToIfaceDecl ax)
-      -- We go via IfaceDecl rather than using pprCoAxiom
-      -- This way we get the full axiom (both LHS and RHS) with
-      -- wildcard binders tidied to _1, _2, etc.
-
-ppr_datacons :: Bool -> TypeEnv -> SDoc
-ppr_datacons debug type_env
-  = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs
-      -- The filter gets rid of class data constructors
-  where
-    ppr_dc dc = sdocOption sdocLinearTypes (\show_linear_types ->
-                ppr dc <+> dcolon <+> ppr (dataConDisplayType show_linear_types dc))
-    all_dcs    = typeEnvDataCons type_env
-    wanted_dcs | debug     = all_dcs
-               | otherwise = filterOut is_cls_dc all_dcs
-    is_cls_dc dc = isClassTyCon (dataConTyCon dc)
-
-ppr_patsyns :: TypeEnv -> SDoc
-ppr_patsyns type_env
-  = ppr_things "PATTERN SYNONYMS" ppr_ps
-               (typeEnvPatSyns type_env)
-  where
-    ppr_ps ps = pprPrefixOcc ps <+> dcolon <+> pprPatSynType ps
-
-ppr_insts :: [ClsInst] -> SDoc
-ppr_insts ispecs
-  = ppr_things "CLASS INSTANCES" pprInstance ispecs
-
-ppr_fam_insts :: [FamInst] -> SDoc
-ppr_fam_insts fam_insts
-  = ppr_things "FAMILY INSTANCES" pprFamInst fam_insts
-
-ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc
-ppr_things herald ppr_one things
-  | null things = empty
-  | otherwise   = text herald $$ nest 2 (vcat (map ppr_one things))
-
-hasTopUserName :: NamedThing x => x -> Bool
--- A top-level thing whose name is not "derived"
--- Thus excluding things like $tcX, from Typeable boilerplate
--- and C:Coll from class-dictionary data constructors
-hasTopUserName x
-  = isExternalName name && not (isDerivedOccName (nameOccName name))
-  where
-    name = getName x
-
-{-
-********************************************************************************
-
-Type Checker Plugins
-
-********************************************************************************
--}
-
-withTcPlugins :: HscEnv -> TcM a -> TcM a
-withTcPlugins hsc_env m =
-    case catMaybes $ mapPlugins (hsc_plugins hsc_env) tcPlugin of
-       []      -> m  -- Common fast case
-       plugins -> do
-                (solvers, rewriters, stops) <-
-                  unzip3 `fmap` mapM start_plugin plugins
-                let
-                  rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter]
-                  !rewritersUniqFM = sequenceUFMList rewriters
-                -- The following ensures that tcPluginStop is called even if a type
-                -- error occurs during compilation (Fix of #10078)
-                eitherRes <- tryM $
-                  updGblEnv (\e -> e { tcg_tc_plugin_solvers   = solvers
-                                     , tcg_tc_plugin_rewriters = rewritersUniqFM }) m
-                mapM_ runTcPluginM stops
-                case eitherRes of
-                  Left _ -> failM
-                  Right res -> return res
-  where
-  start_plugin (TcPlugin start solve rewrite stop) =
-    do s <- runTcPluginM start
-       return (solve s, rewrite s, stop s)
-
-withDefaultingPlugins :: HscEnv -> TcM a -> TcM a
-withDefaultingPlugins hsc_env m =
-  do case catMaybes $ mapPlugins (hsc_plugins hsc_env) defaultingPlugin of
-       [] -> m  -- Common fast case
-       plugins  -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins
-                      -- This ensures that dePluginStop is called even if a type
-                      -- error occurs during compilation
-                      eitherRes <- tryM $ do
-                        updGblEnv (\e -> e { tcg_defaulting_plugins = plugins }) m
-                      mapM_ runTcPluginM stops
-                      case eitherRes of
-                        Left _ -> failM
-                        Right res -> return res
-  where
-  start_plugin (DefaultingPlugin start fill stop) =
-    do s <- runTcPluginM start
-       return (fill s, stop s)
-
-withHoleFitPlugins :: HscEnv -> TcM a -> TcM a
-withHoleFitPlugins hsc_env m =
-  case catMaybes $ mapPlugins (hsc_plugins hsc_env) holeFitPlugin of
-    [] -> m  -- Common fast case
-    plugins -> do (plugins,stops) <- mapAndUnzipM start_plugin plugins
-                  -- This ensures that hfPluginStop is called even if a type
-                  -- error occurs during compilation.
-                  eitherRes <- tryM $
-                    updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m
-                  sequence_ stops
-                  case eitherRes of
-                    Left _ -> failM
-                    Right res -> return res
-  where
-    start_plugin (HoleFitPluginR init plugin stop) =
-      do ref <- init
-         return (plugin ref, stop ref)
-
-
-runRenamerPlugin :: TcGblEnv
-                 -> HsGroup GhcRn
-                 -> TcM (TcGblEnv, HsGroup GhcRn)
-runRenamerPlugin gbl_env hs_group = do
-    hsc_env <- getTopEnv
-    withPlugins (hsc_plugins hsc_env)
-      (\p opts (e, g) -> ( mark_plugin_unsafe (hsc_dflags hsc_env)
-                            >> renamedResultAction p opts e g))
-      (gbl_env, hs_group)
-
-
--- XXX: should this really be a Maybe X?  Check under which circumstances this
--- can become a Nothing and decide whether this should instead throw an
--- exception/signal an error.
-type RenamedStuff =
-        (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
-                Maybe (LHsDoc GhcRn)))
-
--- | Extract the renamed information from TcGblEnv.
-getRenamedStuff :: TcGblEnv -> RenamedStuff
-getRenamedStuff tc_result
-  = fmap (\decls -> ( decls, tcg_rn_imports tc_result
-                    , tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) )
-         (tcg_rn_decls tc_result)
-
-runTypecheckerPlugin :: ModSummary -> TcGblEnv -> TcM TcGblEnv
-runTypecheckerPlugin sum gbl_env = do
-    hsc_env <- getTopEnv
-    withPlugins (hsc_plugins hsc_env)
-      (\p opts env -> mark_plugin_unsafe (hsc_dflags hsc_env)
-                        >> typeCheckResultAction p opts sum env)
-      gbl_env
-
-mark_plugin_unsafe :: DynFlags -> TcM ()
-mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $
-  recordUnsafeInfer pluginUnsafe
-  where
-    !diag_opts = initDiagOpts dflags
-    pluginUnsafe =
-      singleMessage $
-      mkPlainMsgEnvelope diag_opts noSrcSpan TcRnUnsafeDueToPlugin
diff --git a/compiler/GHC/Tc/Module.hs-boot b/compiler/GHC/Tc/Module.hs-boot
deleted file mode 100644
--- a/compiler/GHC/Tc/Module.hs-boot
+++ /dev/null
@@ -1,12 +0,0 @@
-module GHC.Tc.Module where
-
-import GHC.Prelude
-import GHC.Types.TyThing(TyThing)
-import GHC.Tc.Errors.Types (TcRnMessage)
-import GHC.Tc.Types (TcM)
-import GHC.Types.Name (Name)
-
-checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)
-               -> TyThing -> TyThing -> TcM ()
-missingBootThing :: Bool -> Name -> String -> TcRnMessage
-badReexportedBootThing :: Bool -> Name -> Name -> TcRnMessage
diff --git a/compiler/GHC/Tc/Plugin.hs b/compiler/GHC/Tc/Plugin.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Plugin.hs
+++ /dev/null
@@ -1,194 +0,0 @@
-
--- | This module provides an interface for typechecker plugins to
--- access select functions of the 'TcM', principally those to do with
--- reading parts of the state.
-module GHC.Tc.Plugin (
-        -- * Basic TcPluginM functionality
-        TcPluginM,
-        tcPluginIO,
-        tcPluginTrace,
-        unsafeTcPluginTcM,
-
-        -- * Finding Modules and Names
-        Finder.FindResult(..),
-        findImportedModule,
-        lookupOrig,
-
-        -- * Looking up Names in the typechecking environment
-        tcLookupGlobal,
-        tcLookupTyCon,
-        tcLookupDataCon,
-        tcLookupClass,
-        tcLookup,
-        tcLookupId,
-
-        -- * Getting the TcM state
-        getTopEnv,
-        getTargetPlatform,
-        getEnvs,
-        getInstEnvs,
-        getFamInstEnvs,
-        matchFam,
-
-        -- * Type variables
-        newUnique,
-        newFlexiTyVar,
-        isTouchableTcPluginM,
-
-        -- * Zonking
-        zonkTcType,
-        zonkCt,
-
-        -- * Creating constraints
-        newWanted,
-        newGiven,
-        newCoercionHole,
-
-        -- * Manipulating evidence bindings
-        newEvVar,
-        setEvBind,
-    ) where
-
-import GHC.Prelude
-
-import GHC.Platform (Platform)
-
-import qualified GHC.Tc.Utils.Monad     as TcM
-import qualified GHC.Tc.Solver.Monad    as TcS
-import qualified GHC.Tc.Utils.Env       as TcM
-import qualified GHC.Tc.Utils.TcMType   as TcM
-import qualified GHC.Tc.Instance.Family as TcM
-import qualified GHC.Iface.Env          as IfaceEnv
-import qualified GHC.Unit.Finder        as Finder
-
-import GHC.Core.FamInstEnv     ( FamInstEnv )
-import GHC.Tc.Utils.Monad      ( TcGblEnv, TcLclEnv, TcPluginM
-                               , unsafeTcPluginTcM
-                               , liftIO, traceTc )
-import GHC.Tc.Types.Constraint ( Ct, CtLoc, CtEvidence(..) )
-import GHC.Tc.Utils.TcMType    ( TcTyVar, TcType )
-import GHC.Tc.Utils.Env        ( TcTyThing )
-import GHC.Tc.Types.Evidence   ( CoercionHole, EvTerm(..)
-                               , EvExpr, EvBindsVar, EvBind, mkGivenEvBind )
-import GHC.Types.Var           ( EvVar )
-
-import GHC.Unit.Module    ( ModuleName, Module )
-import GHC.Types.Name     ( OccName, Name )
-import GHC.Types.TyThing  ( TyThing )
-import GHC.Core.Reduction ( Reduction )
-import GHC.Core.TyCon     ( TyCon )
-import GHC.Core.DataCon   ( DataCon )
-import GHC.Core.Class     ( Class )
-import GHC.Driver.Env       ( HscEnv(..) )
-import GHC.Utils.Outputable ( SDoc )
-import GHC.Core.Type        ( Kind, Type, PredType )
-import GHC.Types.Id         ( Id )
-import GHC.Core.InstEnv     ( InstEnvs )
-import GHC.Types.Unique     ( Unique )
-import GHC.Types.PkgQual    ( PkgQual )
-
-
--- | Perform some IO, typically to interact with an external tool.
-tcPluginIO :: IO a -> TcPluginM a
-tcPluginIO a = unsafeTcPluginTcM (liftIO a)
-
--- | Output useful for debugging the compiler.
-tcPluginTrace :: String -> SDoc -> TcPluginM ()
-tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)
-
-
-findImportedModule :: ModuleName -> PkgQual -> TcPluginM Finder.FindResult
-findImportedModule mod_name mb_pkg = do
-    hsc_env <- getTopEnv
-    tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg
-
-lookupOrig :: Module -> OccName -> TcPluginM Name
-lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod
-
-
-tcLookupGlobal :: Name -> TcPluginM TyThing
-tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal
-
-tcLookupTyCon :: Name -> TcPluginM TyCon
-tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon
-
-tcLookupDataCon :: Name -> TcPluginM DataCon
-tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon
-
-tcLookupClass :: Name -> TcPluginM Class
-tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass
-
-tcLookup :: Name -> TcPluginM TcTyThing
-tcLookup = unsafeTcPluginTcM . TcM.tcLookup
-
-tcLookupId :: Name -> TcPluginM Id
-tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId
-
-
-getTopEnv :: TcPluginM HscEnv
-getTopEnv = unsafeTcPluginTcM TcM.getTopEnv
-
-getTargetPlatform :: TcPluginM Platform
-getTargetPlatform = unsafeTcPluginTcM TcM.getPlatform
-
-
-getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)
-getEnvs = unsafeTcPluginTcM TcM.getEnvs
-
-getInstEnvs :: TcPluginM InstEnvs
-getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs
-
-getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)
-getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs
-
-matchFam :: TyCon -> [Type]
-         -> TcPluginM (Maybe Reduction)
-matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args
-
-newUnique :: TcPluginM Unique
-newUnique = unsafeTcPluginTcM TcM.newUnique
-
-newFlexiTyVar :: Kind -> TcPluginM TcTyVar
-newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar
-
-isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool
-isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM
-
--- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType.
-zonkTcType :: TcType -> TcPluginM TcType
-zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType
-
-zonkCt :: Ct -> TcPluginM Ct
-zonkCt = unsafeTcPluginTcM . TcM.zonkCt
-
--- | Create a new Wanted constraint with the given 'CtLoc'.
-newWanted :: CtLoc -> PredType -> TcPluginM CtEvidence
-newWanted loc pty
-  = unsafeTcPluginTcM (TcM.newWantedWithLoc loc pty)
-
--- | Create a new given constraint, with the supplied evidence.
---
--- This should only be invoked within 'tcPluginSolve'.
-newGiven :: EvBindsVar -> CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence
-newGiven tc_evbinds loc pty evtm = do
-   new_ev <- newEvVar pty
-   setEvBind tc_evbinds $ mkGivenEvBind new_ev (EvExpr evtm)
-   return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }
-
--- | Create a fresh evidence variable.
---
--- This should only be invoked within 'tcPluginSolve'.
-newEvVar :: PredType -> TcPluginM EvVar
-newEvVar = unsafeTcPluginTcM . TcM.newEvVar
-
--- | Create a fresh coercion hole.
--- This should only be invoked within 'tcPluginSolve'.
-newCoercionHole :: PredType -> TcPluginM CoercionHole
-newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole
-
--- | Bind an evidence variable.
---
--- This should only be invoked within 'tcPluginSolve'.
-setEvBind :: EvBindsVar -> EvBind -> TcPluginM ()
-setEvBind tc_evbinds ev_bind = do
-    unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ /dev/null
@@ -1,3286 +0,0 @@
-{-# LANGUAGE RecursiveDo #-}
-
-module GHC.Tc.Solver(
-       InferMode(..), simplifyInfer, findInferredDiff,
-       growThetaTyVars,
-       simplifyAmbiguityCheck,
-       simplifyDefault,
-       simplifyTop, simplifyTopImplic,
-       simplifyInteractive,
-       solveEqualities,
-       pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX,
-       reportUnsolvedEqualities,
-       simplifyWantedsTcM,
-       tcCheckGivens,
-       tcCheckWanteds,
-       tcNormalise,
-
-       captureTopConstraints,
-
-       simplifyTopWanteds,
-
-       promoteTyVarSet, simplifyAndEmitFlatConstraints,
-
-       -- For Rules we need these
-       solveWanteds,
-       approximateWC
-
-  ) where
-
-import GHC.Prelude
-
-import GHC.Data.Bag
-import GHC.Core.Class
-import GHC.Driver.Session
-import GHC.Tc.Utils.Instantiate
-import GHC.Data.List.SetOps
-import GHC.Types.Name
-import GHC.Types.Id( idType )
-import GHC.Utils.Outputable
-import GHC.Builtin.Utils
-import GHC.Builtin.Names
-import GHC.Tc.Errors
-import GHC.Tc.Errors.Types
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Solver.Interact
-import GHC.Tc.Solver.Canonical   ( makeSuperClasses, solveCallStack )
-import GHC.Tc.Solver.Rewrite     ( rewriteType )
-import GHC.Tc.Utils.Unify        ( buildTvImplication )
-import GHC.Tc.Utils.TcMType as TcM
-import GHC.Tc.Utils.Monad   as TcM
-import GHC.Tc.Solver.InertSet
-import GHC.Tc.Solver.Monad  as TcS
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Instance.FunDeps
-import GHC.Core.Predicate
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.TcType
-import GHC.Core.Type
-import GHC.Core.Ppr
-import GHC.Core.TyCon    ( TyConBinder, isTypeFamilyTyCon )
-import GHC.Builtin.Types ( liftedRepTy, liftedDataConTy )
-import GHC.Core.Unify    ( tcMatchTyKi )
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Types.Var
-import GHC.Types.Var.Set
-import GHC.Types.Basic    ( IntWithInf, intGtLimit
-                          , DefaultingStrategy(..), NonStandardDefaultingStrategy(..) )
-import GHC.Types.Error
-import qualified GHC.LanguageExtensions as LangExt
-
-import Control.Monad
-import Data.Foldable      ( toList )
-import Data.List          ( partition )
-import Data.List.NonEmpty ( NonEmpty(..) )
-import GHC.Data.Maybe     ( mapMaybe )
-
-{-
-*********************************************************************************
-*                                                                               *
-*                           External interface                                  *
-*                                                                               *
-*********************************************************************************
--}
-
-captureTopConstraints :: TcM a -> TcM (a, WantedConstraints)
--- (captureTopConstraints m) runs m, and returns the type constraints it
--- generates plus the constraints produced by static forms inside.
--- If it fails with an exception, it reports any insolubles
--- (out of scope variables) before doing so
---
--- captureTopConstraints is used exclusively by GHC.Tc.Module at the top
--- level of a module.
---
--- Importantly, if captureTopConstraints propagates an exception, it
--- reports any insoluble constraints first, lest they be lost
--- altogether.  This is important, because solveEqualities (maybe
--- other things too) throws an exception without adding any error
--- messages; it just puts the unsolved constraints back into the
--- monad. See GHC.Tc.Utils.Monad Note [Constraints and errors]
--- #16376 is an example of what goes wrong if you don't do this.
---
--- NB: the caller should bring any environments into scope before
--- calling this, so that the reportUnsolved has access to the most
--- complete GlobalRdrEnv
-captureTopConstraints thing_inside
-  = do { static_wc_var <- TcM.newTcRef emptyWC ;
-       ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $
-                          TcM.tryCaptureConstraints thing_inside
-       ; stWC <- TcM.readTcRef static_wc_var
-
-       -- See GHC.Tc.Utils.Monad Note [Constraints and errors]
-       -- If the thing_inside threw an exception, but generated some insoluble
-       -- constraints, report the latter before propagating the exception
-       -- Otherwise they will be lost altogether
-       ; case mb_res of
-           Just res -> return (res, lie `andWC` stWC)
-           Nothing  -> do { _ <- simplifyTop lie; failM } }
-                -- This call to simplifyTop is the reason
-                -- this function is here instead of GHC.Tc.Utils.Monad
-                -- We call simplifyTop so that it does defaulting
-                -- (esp of runtime-reps) before reporting errors
-
-simplifyTopImplic :: Bag Implication -> TcM ()
-simplifyTopImplic implics
-  = do { empty_binds <- simplifyTop (mkImplicWC implics)
-
-       -- Since all the inputs are implications the returned bindings will be empty
-       ; massertPpr (isEmptyBag empty_binds) (ppr empty_binds)
-
-       ; return () }
-
-simplifyTop :: WantedConstraints -> TcM (Bag EvBind)
--- Simplify top-level constraints
--- Usually these will be implications,
--- but when there is nothing to quantify we don't wrap
--- in a degenerate implication, so we do that here instead
-simplifyTop wanteds
-  = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds
-       ; ((final_wc, unsafe_ol), binds1) <- runTcS $
-            do { final_wc <- simplifyTopWanteds wanteds
-               ; unsafe_ol <- getSafeOverlapFailures
-               ; return (final_wc, unsafe_ol) }
-       ; traceTc "End simplifyTop }" empty
-
-       ; binds2 <- reportUnsolved final_wc
-
-       ; traceTc "reportUnsolved (unsafe overlapping) {" empty
-       ; unless (isEmptyCts unsafe_ol) $ do {
-           -- grab current error messages and clear, warnAllUnsolved will
-           -- update error messages which we'll grab and then restore saved
-           -- messages.
-           ; errs_var  <- getErrsVar
-           ; saved_msg <- TcM.readTcRef errs_var
-           ; TcM.writeTcRef errs_var emptyMessages
-
-           ; warnAllUnsolved $ emptyWC { wc_simple = unsafe_ol }
-
-           ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var
-           ; TcM.writeTcRef errs_var saved_msg
-           ; recordUnsafeInfer (mkMessages whyUnsafe)
-           }
-       ; traceTc "reportUnsolved (unsafe overlapping) }" empty
-
-       ; return (evBindMapBinds binds1 `unionBags` binds2) }
-
-pushLevelAndSolveEqualities :: SkolemInfoAnon -> [TyConBinder] -> TcM a -> TcM a
--- Push level, and solve all resulting equalities
--- If there are any unsolved equalities, report them
--- and fail (in the monad)
---
--- Panics if we solve any non-equality constraints.  (In runTCSEqualities
--- we use an error thunk for the evidence bindings.)
-pushLevelAndSolveEqualities skol_info_anon tcbs thing_inside
-  = do { (tclvl, wanted, res) <- pushLevelAndSolveEqualitiesX
-                                      "pushLevelAndSolveEqualities" thing_inside
-       ; report_unsolved_equalities skol_info_anon (binderVars tcbs) tclvl wanted
-       ; return res }
-
-pushLevelAndSolveEqualitiesX :: String -> TcM a
-                             -> TcM (TcLevel, WantedConstraints, a)
--- Push the level, gather equality constraints, and then solve them.
--- Returns any remaining unsolved equalities.
--- Does not report errors.
---
--- Panics if we solve any non-equality constraints.  (In runTCSEqualities
--- we use an error thunk for the evidence bindings.)
-pushLevelAndSolveEqualitiesX callsite thing_inside
-  = do { traceTc "pushLevelAndSolveEqualitiesX {" (text "Called from" <+> text callsite)
-       ; (tclvl, (wanted, res))
-            <- pushTcLevelM $
-               do { (res, wanted) <- captureConstraints thing_inside
-                  ; wanted <- runTcSEqualities (simplifyTopWanteds wanted)
-                  ; return (wanted,res) }
-       ; traceTc "pushLevelAndSolveEqualities }" (vcat [ text "Residual:" <+> ppr wanted
-                                                       , text "Level:" <+> ppr tclvl ])
-       ; return (tclvl, wanted, res) }
-
--- | Type-check a thing that emits only equality constraints, solving any
--- constraints we can and re-emitting constraints that we can't.
--- Use this variant only when we'll get another crack at it later
--- See Note [Failure in local type signatures]
---
--- Panics if we solve any non-equality constraints.  (In runTCSEqualities
--- we use an error thunk for the evidence bindings.)
-solveEqualities :: String -> TcM a -> TcM a
-solveEqualities callsite thing_inside
-  = do { traceTc "solveEqualities {" (text "Called from" <+> text callsite)
-       ; (res, wanted)   <- captureConstraints thing_inside
-       ; simplifyAndEmitFlatConstraints wanted
-            -- simplifyAndEmitFlatConstraints fails outright unless
-            --  the only unsolved constraints are soluble-looking
-            --  equalities that can float out
-       ; traceTc "solveEqualities }" empty
-       ; return res }
-
-simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM ()
--- See Note [Failure in local type signatures]
-simplifyAndEmitFlatConstraints wanted
-  = do { -- Solve and zonk to establish the
-         -- preconditions for floatKindEqualities
-         wanted <- runTcSEqualities (solveWanteds wanted)
-       ; wanted <- TcM.zonkWC wanted
-
-       ; traceTc "emitFlatConstraints {" (ppr wanted)
-       ; case floatKindEqualities wanted of
-           Nothing -> do { traceTc "emitFlatConstraints } failing" (ppr wanted)
-                         -- Emit the bad constraints, wrapped in an implication
-                         -- See Note [Wrapping failing kind equalities]
-                         ; tclvl  <- TcM.getTcLevel
-                         ; implic <- buildTvImplication unkSkolAnon [] (pushTcLevel tclvl) wanted
-                                        --                  ^^^^^^   |  ^^^^^^^^^^^^^^^^^
-                                        -- it's OK to use unkSkol    |  we must increase the TcLevel,
-                                        -- because we don't bind     |  as explained in
-                                        -- any skolem variables here |  Note [Wrapping failing kind equalities]
-                         ; emitImplication implic
-                         ; failM }
-           Just (simples, errs)
-              -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples)
-                    ; traceTc "emitFlatConstraints }" $
-                      vcat [ text "simples:" <+> ppr simples
-                           , text "errs:   " <+> ppr errs ]
-                      -- Holes and other delayed errors don't need promotion
-                    ; emitDelayedErrors errs
-                    ; emitSimples simples } }
-
-floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag DelayedError)
--- Float out all the constraints from the WantedConstraints,
--- Return Nothing if any constraints can't be floated (captured
--- by skolems), or if there is an insoluble constraint, or
--- IC_Telescope telescope error
--- Precondition 1: we have tried to solve the 'wanteds', both so that
---    the ic_status field is set, and because solving can make constraints
---    more floatable.
--- Precondition 2: the 'wanteds' are zonked, since floatKindEqualities
---    is not monadic
--- See Note [floatKindEqualities vs approximateWC]
-floatKindEqualities wc = float_wc emptyVarSet wc
-  where
-    float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag DelayedError)
-    float_wc trapping_tvs (WC { wc_simple = simples
-                              , wc_impl = implics
-                              , wc_errors = errs })
-      | all is_floatable simples
-      = do { (inner_simples, inner_errs)
-                <- flatMapBagPairM (float_implic trapping_tvs) implics
-           ; return ( simples `unionBags` inner_simples
-                    , errs `unionBags` inner_errs) }
-      | otherwise
-      = Nothing
-      where
-        is_floatable ct
-           | insolubleEqCt ct = False
-           | otherwise        = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs
-
-    float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag DelayedError)
-    float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs
-                                      , ic_skols = skols, ic_status = status })
-      | isInsolubleStatus status
-      = Nothing   -- A short cut /plus/ we must keep track of IC_BadTelescope
-      | otherwise
-      = do { (simples, holes) <- float_wc new_trapping_tvs wanted
-           ; when (not (isEmptyBag simples) && given_eqs == MaybeGivenEqs) $
-             Nothing
-                 -- If there are some constraints to float out, but we can't
-                 -- because we don't float out past local equalities
-                 -- (c.f GHC.Tc.Solver.approximateWC), then fail
-           ; return (simples, holes) }
-      where
-        new_trapping_tvs = trapping_tvs `extendVarSetList` skols
-
-
-{- Note [Failure in local type signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When kind checking a type signature, we like to fail fast if we can't
-solve all the kind equality constraints, for two reasons:
-
-  * A kind-bogus type signature may cause a cascade of knock-on
-    errors if we let it pass
-
-  * More seriously, we don't have a convenient term-level place to add
-    deferred bindings for unsolved kind-equality constraints.  In
-    earlier GHCs this led to un-filled-in coercion holes, which caused
-    GHC to crash with "fvProv falls into a hole" See #11563, #11520,
-    #11516, #11399
-
-But what about /local/ type signatures, mentioning in-scope type
-variables for which there might be 'given' equalities?  For these we
-might not be able to solve all the equalities locally. Here's an
-example (T15076b):
-
-  class (a ~ b) => C a b
-  data SameKind :: k -> k -> Type where { SK :: SameKind a b }
-
-  bar :: forall (a :: Type) (b :: Type).
-         C a b => Proxy a -> Proxy b -> ()
-  bar _ _ = const () (undefined :: forall (x :: a) (y :: b). SameKind x y)
-
-Consider the type signature on 'undefined'. It's ill-kinded unless
-a~b.  But the superclass of (C a b) means that indeed (a~b). So all
-should be well. BUT it's hard to see that when kind-checking the signature
-for undefined.  We want to emit a residual (a~b) constraint, to solve
-later.
-
-Another possibility is that we might have something like
-   F alpha ~ [Int]
-where alpha is bound further out, which might become soluble
-"later" when we learn more about alpha.  So we want to emit
-those residual constraints.
-
-BUT it's no good simply wrapping all unsolved constraints from
-a type signature in an implication constraint to solve later. The
-problem is that we are going to /use/ that signature, including
-instantiate it.  Say we have
-     f :: forall a.  (forall b. blah) -> blah2
-     f x = <body>
-To typecheck the definition of f, we have to instantiate those
-foralls.  Moreover, any unsolved kind equalities will be coercion
-holes in the type.  If we naively wrap them in an implication like
-     forall a. (co1:k1~k2,  forall b.  co2:k3~k4)
-hoping to solve it later, we might end up filling in the holes
-co1 and co2 with coercions involving 'a' and 'b' -- but by now
-we've instantiated the type.  Chaos!
-
-Moreover, the unsolved constraints might be skolem-escape things, and
-if we proceed with f bound to a nonsensical type, we get a cascade of
-follow-up errors. For example polykinds/T12593, T15577, and many others.
-
-So here's the plan (see tcHsSigType):
-
-* pushLevelAndSolveEqualitiesX: try to solve the constraints
-
-* kindGeneraliseSome: do kind generalisation
-
-* buildTvImplication: build an implication for the residual, unsolved
-  constraint
-
-* simplifyAndEmitFlatConstraints: try to float out every unsolved equality
-  inside that implication, in the hope that it constrains only global
-  type variables, not the locally-quantified ones.
-
-  * If we fail, or find an insoluble constraint, emit the implication,
-    so that the errors will be reported, and fail.
-
-  * If we succeed in floating all the equalities, promote them and
-    re-emit them as flat constraint, not wrapped at all (since they
-    don't mention any of the quantified variables.
-
-* Note that this float-and-promote step means that anonymous
-  wildcards get floated to top level, as we want; see
-  Note [Checking partial type signatures] in GHC.Tc.Gen.HsType.
-
-All this is done:
-
-* In GHC.Tc.Gen.HsType.tcHsSigType, as above
-
-* solveEqualities. Use this when there no kind-generalisation
-  step to complicate matters; then we don't need to push levels,
-  and can solve the equalities immediately without needing to
-  wrap it in an implication constraint.  (You'll generally see
-  a kindGeneraliseNone nearby.)
-
-* In GHC.Tc.TyCl and GHC.Tc.TyCl.Instance; see calls to
-  pushLevelAndSolveEqualitiesX, followed by quantification, and
-  then reportUnsolvedEqualities.
-
-  NB: we call reportUnsolvedEqualities before zonkTcTypeToType
-  because the latter does not expect to see any un-filled-in
-  coercions, which will happen if we have unsolved equalities.
-  By calling reportUnsolvedEqualities first, which fails after
-  reporting errors, we avoid that happening.
-
-See also #18062, #11506
-
-Note [Wrapping failing kind equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In simplifyAndEmitFlatConstraints, if we fail to get down to simple
-flat constraints we will
-* re-emit the constraints so that they are reported
-* fail in the monad
-But there is a Terrible Danger that, if -fdefer-type-errors is on, and
-we just re-emit an insoluble constraint like (* ~ (*->*)), that we'll
-report only a warning and proceed with compilation.  But if we ever fail
-in the monad it should be fatal; we should report an error and stop after
-the type checker.  If not, chaos results: #19142.
-
-Our solution is this:
-* Even with -fdefer-type-errors, inside an implication with no place for
-  value bindings (ic_binds = CoEvBindsVar), report failing equalities as
-  errors.  We have to do this anyway; see GHC.Tc.Errors
-  Note [Failing equalities with no evidence bindings].
-
-* Right here in simplifyAndEmitFlatConstraints, use buildTvImplication
-  to wrap the failing constraint in a degenerate implication (no
-  skolems, no theta), with ic_binds = CoEvBindsVar.  This setting of
-  `ic_binds` means that any failing equalities will lead to an
-  error not a warning, irrespective of -fdefer-type-errors: see
-  Note [Failing equalities with no evidence bindings] in GHC.Tc.Errors,
-  and `maybeSwitchOffDefer` in that module.
-
-  We still take care to bump the TcLevel of the implication.  Partly,
-  that ensures that nested implications have increasing level numbers
-  which seems nice.  But more specifically, suppose the outer level
-  has a Given `(C ty)`, which has pending (not-yet-expanded)
-  superclasses. Consider what happens when we process this implication
-  constraint (which we have re-emitted) in that context:
-    - in the inner implication we'll call `getPendingGivenScs`,
-    - we /do not/ want to get the `(C ty)` from the outer level,
-    lest we try to add an evidence term for the superclass,
-    which we can't do because we have specifically set
-    `ic_binds` = `CoEvBindsVar`.
-    - as `getPendingGivenSCcs is careful to only get Givens from
-    the /current/ level, and we bumped the `TcLevel` of the implication,
-    we're OK.
-
-  TL;DR: bump the `TcLevel` when creating the nested implication.
-  If we don't we get a panic in `GHC.Tc.Utils.Monad.addTcEvBind` (#20043).
-
-
-We re-emit the implication rather than reporting the errors right now,
-so that the error messages are improved by other solving and defaulting.
-e.g. we prefer
-    Cannot match 'Type->Type' with 'Type'
-to  Cannot match 'Type->Type' with 'TYPE r0'
-
-
-Note [floatKindEqualities vs approximateWC]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-floatKindEqualities and approximateWC are strikingly similar to each
-other, but
-
-* floatKindEqualites tries to float /all/ equalities, and fails if
-  it can't, or if any implication is insoluble.
-* approximateWC just floats out any constraints
-  (not just equalities) that can float; it never fails.
--}
-
-
-reportUnsolvedEqualities :: SkolemInfo -> [TcTyVar] -> TcLevel
-                         -> WantedConstraints -> TcM ()
--- Reports all unsolved wanteds provided; fails in the monad if there are any.
---
--- The provided SkolemInfo and [TcTyVar] arguments are used in an implication to
--- provide skolem info for any errors.
-reportUnsolvedEqualities skol_info skol_tvs tclvl wanted
-  = report_unsolved_equalities (getSkolemInfo skol_info) skol_tvs tclvl wanted
-
-report_unsolved_equalities :: SkolemInfoAnon -> [TcTyVar] -> TcLevel
-                           -> WantedConstraints -> TcM ()
-report_unsolved_equalities skol_info_anon skol_tvs tclvl wanted
-  | isEmptyWC wanted
-  = return ()
-
-  | otherwise  -- NB: we build an implication /even if skol_tvs is empty/,
-               -- just to ensure that our level invariants hold, specifically
-               -- (WantedInv).  See Note [TcLevel invariants].
-  = checkNoErrs $   -- Fail
-    do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted
-       ; reportAllUnsolved (mkImplicWC (unitBag implic)) }
-
-
--- | Simplify top-level constraints, but without reporting any unsolved
--- constraints nor unsafe overlapping.
-simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints
-    -- See Note [Top-level Defaulting Plan]
-simplifyTopWanteds wanteds
-  = do { wc_first_go <- nestTcS (solveWanteds wanteds)
-                            -- This is where the main work happens
-       ; dflags <- getDynFlags
-       ; try_tyvar_defaulting dflags wc_first_go }
-  where
-    try_tyvar_defaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints
-    try_tyvar_defaulting dflags wc
-      | isEmptyWC wc
-      = return wc
-      | insolubleWC wc
-      , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles]
-      = try_class_defaulting wc
-      | otherwise
-      = do { -- Need to zonk first, as the WantedConstraints are not yet zonked.
-           ; free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)
-           ; let defaultable_tvs = filter can_default free_tvs
-                 can_default tv
-                   =   isTyVar tv
-                       -- Weed out coercion variables.
-
-                    && isMetaTyVar tv
-                       -- Weed out runtime-skolems in GHCi, which we definitely
-                       -- shouldn't try to default.
-
-                    && not (tv `elemVarSet` nonDefaultableTyVarsOfWC wc)
-                       -- Weed out variables for which defaulting would be unhelpful,
-                       -- e.g. alpha appearing in [W] alpha[conc] ~# rr[sk].
-
-           ; defaulted <- mapM defaultTyVarTcS defaultable_tvs -- Has unification side effects
-           ; if or defaulted
-             then do { wc_residual <- nestTcS (solveWanteds wc)
-                            -- See Note [Must simplify after defaulting]
-                     ; try_class_defaulting wc_residual }
-             else try_class_defaulting wc }     -- No defaulting took place
-
-    try_class_defaulting :: WantedConstraints -> TcS WantedConstraints
-    try_class_defaulting wc
-      | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles]
-      = try_callstack_defaulting wc
-      | otherwise  -- See Note [When to do type-class defaulting]
-      = do { something_happened <- applyDefaultingRules wc
-                                   -- See Note [Top-level Defaulting Plan]
-           ; if something_happened
-             then do { wc_residual <- nestTcS (solveWanteds wc)
-                     ; try_class_defaulting wc_residual }
-                  -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
-             else try_callstack_defaulting wc }
-
-    try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints
-    try_callstack_defaulting wc
-      | isEmptyWC wc
-      = return wc
-      | otherwise
-      = defaultCallStacks wc
-
--- | Default any remaining @CallStack@ constraints to empty @CallStack@s.
-defaultCallStacks :: WantedConstraints -> TcS WantedConstraints
--- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
-defaultCallStacks wanteds
-  = do simples <- handle_simples (wc_simple wanteds)
-       mb_implics <- mapBagM handle_implic (wc_impl wanteds)
-       return (wanteds { wc_simple = simples
-                       , wc_impl = catBagMaybes mb_implics })
-
-  where
-
-  handle_simples simples
-    = catBagMaybes <$> mapBagM defaultCallStack simples
-
-  handle_implic :: Implication -> TcS (Maybe Implication)
-  -- The Maybe is because solving the CallStack constraint
-  -- may well allow us to discard the implication entirely
-  handle_implic implic
-    | isSolvedStatus (ic_status implic)
-    = return (Just implic)
-    | otherwise
-    = do { wanteds <- setEvBindsTcS (ic_binds implic) $
-                      -- defaultCallStack sets a binding, so
-                      -- we must set the correct binding group
-                      defaultCallStacks (ic_wanted implic)
-         ; setImplicationStatus (implic { ic_wanted = wanteds }) }
-
-  defaultCallStack ct
-    | ClassPred cls tys <- classifyPredType (ctPred ct)
-    , Just {} <- isCallStackPred cls tys
-    = do { solveCallStack (ctEvidence ct) EvCsEmpty
-         ; return Nothing }
-
-  defaultCallStack ct
-    = return (Just ct)
-
-
-{- Note [When to do type-class defaulting]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC
-was false, on the grounds that defaulting can't help solve insoluble
-constraints.  But if we *don't* do defaulting we may report a whole
-lot of errors that would be solved by defaulting; these errors are
-quite spurious because fixing the single insoluble error means that
-defaulting happens again, which makes all the other errors go away.
-This is jolly confusing: #9033.
-
-So it seems better to always do type-class defaulting.
-
-However, always doing defaulting does mean that we'll do it in
-situations like this (#5934):
-   run :: (forall s. GenST s) -> Int
-   run = fromInteger 0
-We don't unify the return type of fromInteger with the given function
-type, because the latter involves foralls.  So we're left with
-    (Num alpha, alpha ~ (forall s. GenST s) -> Int)
-Now we do defaulting, get alpha := Integer, and report that we can't
-match Integer with (forall s. GenST s) -> Int.  That's not totally
-stupid, but perhaps a little strange.
-
-Another potential alternative would be to suppress *all* non-insoluble
-errors if there are *any* insoluble errors, anywhere, but that seems
-too drastic.
-
-Note [Don't default in syntactic equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When there are unsolved syntactic equalities such as
-
-  rr[sk] ~S# alpha[conc]
-
-we should not default alpha, lest we obtain a poor error message such as
-
-  Couldn't match kind `rr' with `LiftedRep'
-
-We would rather preserve the original syntactic equality to be
-reported to the user, especially as the concrete metavariable alpha
-might store an informative origin for the user.
-
-Note [Must simplify after defaulting]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We may have a deeply buried constraint
-    (t:*) ~ (a:Open)
-which we couldn't solve because of the kind incompatibility, and 'a' is free.
-Then when we default 'a' we can solve the constraint.  And we want to do
-that before starting in on type classes.  We MUST do it before reporting
-errors, because it isn't an error!  #7967 was due to this.
-
-Note [Top-level Defaulting Plan]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We have considered two design choices for where/when to apply defaulting.
-   (i) Do it in SimplCheck mode only /whenever/ you try to solve some
-       simple constraints, maybe deep inside the context of implications.
-       This used to be the case in GHC 7.4.1.
-   (ii) Do it in a tight loop at simplifyTop, once all other constraints have
-        finished. This is the current story.
-
-Option (i) had many disadvantages:
-   a) Firstly, it was deep inside the actual solver.
-   b) Secondly, it was dependent on the context (Infer a type signature,
-      or Check a type signature, or Interactive) since we did not want
-      to always start defaulting when inferring (though there is an exception to
-      this, see Note [Default while Inferring]).
-   c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs:
-          f :: Int -> Bool
-          f x = const True (\y -> let w :: a -> a
-                                      w a = const a (y+1)
-                                  in w y)
-      We will get an implication constraint (for beta the type of y):
-               [untch=beta] forall a. 0 => Num beta
-      which we really cannot default /while solving/ the implication, since beta is
-      untouchable.
-
-Instead our new defaulting story is to pull defaulting out of the solver loop and
-go with option (ii), implemented at SimplifyTop. Namely:
-     - First, have a go at solving the residual constraint of the whole
-       program
-     - Try to approximate it with a simple constraint
-     - Figure out derived defaulting equations for that simple constraint
-     - Go round the loop again if you did manage to get some equations
-
-Now, that has to do with class defaulting. However there exists type variable /kind/
-defaulting. Again this is done at the top-level and the plan is:
-     - At the top-level, once you had a go at solving the constraint, do
-       figure out /all/ the touchable unification variables of the wanted constraints.
-     - Apply defaulting to their kinds
-
-More details in Note [DefaultTyVar].
-
-Note [Safe Haskell Overlapping Instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In Safe Haskell, we apply an extra restriction to overlapping instances. The
-motive is to prevent untrusted code provided by a third-party, changing the
-behavior of trusted code through type-classes. This is due to the global and
-implicit nature of type-classes that can hide the source of the dictionary.
-
-Another way to state this is: if a module M compiles without importing another
-module N, changing M to import N shouldn't change the behavior of M.
-
-Overlapping instances with type-classes can violate this principle. However,
-overlapping instances aren't always unsafe. They are just unsafe when the most
-selected dictionary comes from untrusted code (code compiled with -XSafe) and
-overlaps instances provided by other modules.
-
-In particular, in Safe Haskell at a call site with overlapping instances, we
-apply the following rule to determine if it is a 'unsafe' overlap:
-
- 1) Most specific instance, I1, defined in an `-XSafe` compiled module.
- 2) I1 is an orphan instance or a MPTC.
- 3) At least one overlapped instance, Ix, is both:
-    A) from a different module than I1
-    B) Ix is not marked `OVERLAPPABLE`
-
-This is a slightly involved heuristic, but captures the situation of an
-imported module N changing the behavior of existing code. For example, if
-condition (2) isn't violated, then the module author M must depend either on a
-type-class or type defined in N.
-
-Secondly, when should these heuristics be enforced? We enforced them when the
-type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`.
-This allows `-XUnsafe` modules to operate without restriction, and for Safe
-Haskell inference to infer modules with unsafe overlaps as unsafe.
-
-One alternative design would be to also consider if an instance was imported as
-a `safe` import or not and only apply the restriction to instances imported
-safely. However, since instances are global and can be imported through more
-than one path, this alternative doesn't work.
-
-Note [Safe Haskell Overlapping Instances Implementation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-How is this implemented? It's complicated! So we'll step through it all:
-
- 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where
-    we check if a particular type-class method call is safe or unsafe. We do this
-    through the return type, `ClsInstLookupResult`, where the last parameter is a
-    list of instances that are unsafe to overlap. When the method call is safe,
-    the list is null.
-
- 2) `GHC.Tc.Solver.Interact.matchClassInst` -- This module drives the instance resolution
-    / dictionary generation. The return type is `ClsInstResult`, which either
-    says no instance matched, or one found, and if it was a safe or unsafe
-    overlap.
-
- 3) `GHC.Tc.Solver.Interact.doTopReactDict` -- Takes a dictionary / class constraint and
-     tries to resolve it by calling (in part) `matchClassInst`. The resolving
-     mechanism has a work list (of constraints) that it process one at a time. If
-     the constraint can't be resolved, it's added to an inert set. When compiling
-     an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know
-     compilation should fail. These are handled as normal constraint resolution
-     failures from here-on (see step 6).
-
-     Otherwise, we may be inferring safety (or using `-Wunsafe`), and
-     compilation should succeed, but print warnings and/or mark the compiled module
-     as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds
-     the unsafe (but resolved!) constraint to the `inert_safehask` field of
-     `InertCans`.
-
- 4) `GHC.Tc.Solver.simplifyTop`:
-       * Call simplifyTopWanteds, the top-level function for driving the simplifier for
-         constraint resolution.
-
-       * Once finished, call `getSafeOverlapFailures` to retrieve the
-         list of overlapping instances that were successfully resolved,
-         but unsafe. Remember, this is only applicable for generating warnings
-         (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy`
-         cause compilation failure by not resolving the unsafe constraint at all.
-
-       * For unresolved constraints (all types), call `GHC.Tc.Errors.reportUnsolved`,
-         while for resolved but unsafe overlapping dictionary constraints, call
-         `GHC.Tc.Errors.warnAllUnsolved`. Both functions convert constraints into a
-         warning message for the user.
-
-       * In the case of `warnAllUnsolved` for resolved, but unsafe
-         dictionary constraints, we collect the generated warning
-         message (pop it) and call `GHC.Tc.Utils.Monad.recordUnsafeInfer` to
-         mark the module we are compiling as unsafe, passing the
-         warning message along as the reason.
-
- 5) `GHC.Tc.Errors.*Unsolved` -- Generates error messages for constraints by
-    actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we
-    know is the constraint that is unresolved or unsafe. For dictionary, all we
-    know is that we need a dictionary of type C, but not what instances are
-    available and how they overlap. So we once again call `lookupInstEnv` to
-    figure that out so we can generate a helpful error message.
-
- 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in
-      IORefs called `tcg_safe_infer` and `tcg_safe_infer_reason`.
-
- 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safe_infer` after type-checking, calling
-    `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inference
-    failed.
-
-Note [No defaulting in the ambiguity check]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When simplifying constraints for the ambiguity check, we use
-solveWanteds, not simplifyTopWanteds, so that we do no defaulting.
-#11947 was an example:
-   f :: Num a => Int -> Int
-This is ambiguous of course, but we don't want to default the
-(Num alpha) constraint to (Num Int)!  Doing so gives a defaulting
-warning, but no error.
-
-Note [Defaulting insolubles]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If a set of wanteds is insoluble, we have no hope of accepting the
-program. Yet we do not stop constraint solving, etc., because we may
-simplify the wanteds to produce better error messages. So, once
-we have an insoluble constraint, everything we do is just about producing
-helpful error messages.
-
-Should we default in this case or not? Let's look at an example (tcfail004):
-
-  (f,g) = (1,2,3)
-
-With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer).
-Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard)
-find the latter more helpful. Several other test cases (e.g. tcfail005) suggest
-similarly. So: we should not do class defaulting with insolubles.
-
-On the other hand, RuntimeRep-defaulting is different. Witness tcfail078:
-
-  f :: Integer i => i
-  f =               0
-
-Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind
-TYPE r0 -> Constraint and then complains that r0 is actually untouchable
-(presumably, because it can't be sure if `Integer i` entails an equality).
-If we default, we are told of a clash between (* -> Constraint) and Constraint.
-The latter seems far better, suggesting we *should* do RuntimeRep-defaulting
-even on insolubles.
-
-But, evidently, not always. Witness UnliftedNewtypesInfinite:
-
-  newtype Foo = FooC (# Int#, Foo #)
-
-This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes).
-If we default RuntimeRep-vars, we get
-
-  Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted
-
-which is just plain wrong.
-
-Another situation in which we don't want to default involves concrete metavariables.
-
-In equalities such as   alpha[conc] ~# rr[sk]  ,  alpha[conc] ~# RR beta[tau]
-for a type family RR (all at kind RuntimeRep), we would prefer to report a
-representation-polymorphism error rather than default alpha and get error:
-
-  Could not unify `rr` with `Lifted` / Could not unify `RR b0` with `Lifted`
-
-which is very confusing. For this reason, we weed out the concrete
-metavariables participating in such equalities in nonDefaultableTyVarsOfWC.
-Just looking at insolublity is not enough, as `alpha[conc] ~# RR beta[tau]` could
-become soluble after defaulting beta (see also #21430).
-
-Conclusion: we should do RuntimeRep-defaulting on insolubles only when the
-user does not want to hear about RuntimeRep stuff -- that is, when
--fprint-explicit-runtime-reps is not set.
-However, we must still take care not to default concrete type variables
-participating in an equality with a non-concrete type, as seen in the
-last example above.
--}
-
-------------------
-simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM ()
-simplifyAmbiguityCheck ty wanteds
-  = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds)
-       ; (final_wc, _) <- runTcS $ solveWanteds wanteds
-             -- NB: no defaulting!  See Note [No defaulting in the ambiguity check]
-
-       ; traceTc "End simplifyAmbiguityCheck }" empty
-
-       -- Normally report all errors; but with -XAllowAmbiguousTypes
-       -- report only insoluble ones, since they represent genuinely
-       -- inaccessible code
-       ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes
-       ; traceTc "reportUnsolved(ambig) {" empty
-       ; unless (allow_ambiguous && not (insolubleWC final_wc))
-                (discardResult (reportUnsolved final_wc))
-       ; traceTc "reportUnsolved(ambig) }" empty
-
-       ; return () }
-
-------------------
-simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)
-simplifyInteractive wanteds
-  = traceTc "simplifyInteractive" empty >>
-    simplifyTop wanteds
-
-------------------
-simplifyDefault :: ThetaType    -- Wanted; has no type variables in it
-                -> TcM Bool     -- Return if the constraint is soluble
-simplifyDefault theta
-  = do { traceTc "simplifyDefault" empty
-       ; wanteds  <- newWanteds DefaultOrigin theta
-       ; (unsolved, _) <- runTcS (solveWanteds (mkSimpleWC wanteds))
-       ; return (isEmptyWC unsolved) }
-
-------------------
-{- Note [Pattern match warnings with insoluble Givens]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A pattern match on a GADT can introduce new type-level information, which needs
-to be analysed in order to get the expected pattern match warnings.
-
-For example:
-
-> type IsBool :: Type -> Constraint
-> type family IsBool a where
->   IsBool Bool = ()
->   IsBool b    = b ~ Bool
->
-> data T a where
->   MkTInt  :: Int -> T Int
->   MkTBool :: IsBool b => b -> T b
->
-> f :: T Int -> Int
-> f (MkTInt i) = i
-
-The pattern matching performed by `f` is complete: we can't ever call
-`f (MkTBool b)`, as type-checking that application would require producing
-evidence for `Int ~ Bool`, which can't be done.
-
-The pattern match checker uses `tcCheckGivens` to accumulate all the Given
-constraints, and relies on `tcCheckGivens` to return Nothing if the
-Givens become insoluble.   `tcCheckGivens` in turn relies on `insolubleCt`
-to identify these insoluble constraints.  So the precise definition of
-`insolubleCt` has a big effect on pattern match overlap warnings.
-
-To detect this situation, we check whether there are any insoluble Given
-constraints. In the example above, the insoluble constraint was an
-equality constraint, but it is also important to detect custom type errors:
-
-> type NotInt :: Type -> Constraint
-> type family NotInt a where
->   NotInt Int = TypeError (Text "That's Int, silly.")
->   NotInt _   = ()
->
-> data R a where
->   MkT1 :: a -> R a
->   MkT2 :: NotInt a => R a
->
-> foo :: R Int -> Int
-> foo (MkT1 x) = x
-
-To see that we can't call `foo (MkT2)`, we must detect that `NotInt Int` is insoluble
-because it is a custom type error.
-Failing to do so proved quite inconvenient for users, as evidence by the
-tickets #11503 #14141 #16377 #20180.
-Test cases: T11503, T14141.
-
-Examples of constraints that tcCheckGivens considers insoluble:
-  - Int ~ Bool,
-  - Coercible Float Word,
-  - TypeError msg.
-
-Non-examples:
-  - constraints which we know aren't satisfied,
-    e.g. Show (Int -> Int) when no such instance is in scope,
-  - Eq (TypeError msg),
-  - C (Int ~ Bool), with @class C (c :: Constraint)@.
--}
-
-tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet)
--- ^ Return (Just new_inerts) if the Givens are satisfiable, Nothing if definitely
--- contradictory.
---
--- See Note [Pattern match warnings with insoluble Givens] above.
-tcCheckGivens inerts given_ids = do
-  (sat, new_inerts) <- runTcSInerts inerts $ do
-    traceTcS "checkGivens {" (ppr inerts <+> ppr given_ids)
-    lcl_env <- TcS.getLclEnv
-    let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) lcl_env
-    let given_cts = mkGivens given_loc (bagToList given_ids)
-    -- See Note [Superclasses and satisfiability]
-    solveSimpleGivens given_cts
-    insols <- getInertInsols
-    insols <- try_harder insols
-    traceTcS "checkGivens }" (ppr insols)
-    return (isEmptyBag insols)
-  return $ if sat then Just new_inerts else Nothing
-  where
-    try_harder :: Cts -> TcS Cts
-    -- Maybe we have to search up the superclass chain to find
-    -- an unsatisfiable constraint.  Example: pmcheck/T3927b.
-    -- At the moment we try just once
-    try_harder insols
-      | not (isEmptyBag insols)   -- We've found that it's definitely unsatisfiable
-      = return insols             -- Hurrah -- stop now.
-      | otherwise
-      = do { pending_given <- getPendingGivenScs
-           ; new_given <- makeSuperClasses pending_given
-           ; solveSimpleGivens new_given
-           ; getInertInsols }
-
-tcCheckWanteds :: InertSet -> ThetaType -> TcM Bool
--- ^ Return True if the Wanteds are soluble, False if not
-tcCheckWanteds inerts wanteds = do
-  cts <- newWanteds PatCheckOrigin wanteds
-  (sat, _new_inerts) <- runTcSInerts inerts $ do
-    traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds)
-    -- See Note [Superclasses and satisfiability]
-    wcs <- solveWanteds (mkSimpleWC cts)
-    traceTcS "checkWanteds }" (ppr wcs)
-    return (isSolvedWC wcs)
-  return sat
-
--- | Normalise a type as much as possible using the given constraints.
--- See @Note [tcNormalise]@.
-tcNormalise :: InertSet -> Type -> TcM Type
-tcNormalise inerts ty
-  = do { norm_loc <- getCtLocM PatCheckOrigin Nothing
-       ; (res, _new_inerts) <- runTcSInerts inerts $
-             do { traceTcS "tcNormalise {" (ppr inerts)
-                ; ty' <- rewriteType norm_loc ty
-                ; traceTcS "tcNormalise }" (ppr ty')
-                ; pure ty' }
-       ; return res }
-
-{- Note [Superclasses and satisfiability]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Expand superclasses before starting, because (Int ~ Bool), has
-(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool)
-as a superclass, and it's the latter that is insoluble.  See
-Note [The equality types story] in GHC.Builtin.Types.Prim.
-
-If we fail to prove unsatisfiability we (arbitrarily) try just once to
-find superclasses, using try_harder.  Reason: we might have a type
-signature
-   f :: F op (Implements push) => ..
-where F is a type function.  This happened in #3972.
-
-We could do more than once but we'd have to have /some/ limit: in the
-the recursive case, we would go on forever in the common case where
-the constraints /are/ satisfiable (#10592 comment:12!).
-
-For straightforward situations without type functions the try_harder
-step does nothing.
-
-Note [tcNormalise]
-~~~~~~~~~~~~~~~~~~
-tcNormalise is a rather atypical entrypoint to the constraint solver. Whereas
-most invocations of the constraint solver are intended to simplify a set of
-constraints or to decide if a particular set of constraints is satisfiable,
-the purpose of tcNormalise is to take a type, plus some locally solved
-constraints in the form of an InertSet, and normalise the type as much as
-possible with respect to those constraints.
-
-It does *not* reduce type or data family applications or look through newtypes.
-
-Why is this useful? As one example, when coverage-checking an EmptyCase
-expression, it's possible that the type of the scrutinee will only reduce
-if some local equalities are solved for. See "Wrinkle: Local equalities"
-in Note [Type normalisation] in "GHC.HsToCore.Pmc".
-
-To accomplish its stated goal, tcNormalise first initialises the solver monad
-with the given InertCans, then uses rewriteType to simplify the desired type
-with respect to the Givens in the InertCans.
-
-***********************************************************************************
-*                                                                                 *
-*                            Inference
-*                                                                                 *
-***********************************************************************************
-
-Note [Inferring the type of a let-bound variable]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   f x = rhs
-
-To infer f's type we do the following:
- * Gather the constraints for the RHS with ambient level *one more than*
-   the current one.  This is done by the call
-        pushLevelAndCaptureConstraints (tcMonoBinds...)
-   in GHC.Tc.Gen.Bind.tcPolyInfer
-
- * Call simplifyInfer to simplify the constraints and decide what to
-   quantify over. We pass in the level used for the RHS constraints,
-   here called rhs_tclvl.
-
-This ensures that the implication constraint we generate, if any,
-has a strictly-increased level compared to the ambient level outside
-the let binding.
-
-Note [Inferring principal types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We don't always infer principal types. For instance, the inferred type for
-
-> f x = show [x]
-
-is
-
-> f :: Show a => a -> String
-
-This is not the most general type if we allow flexible contexts.
-Indeed, if we try to write the following
-
-> g :: Show [a] => a -> String
-> g x = f x
-
-we get the error:
-
-  * Could not deduce (Show a) arising from a use of `f'
-    from the context: Show [a]
-
-Though replacing f x in the right-hand side of g with the definition
-of f x works, the call to f x does not. This is the hallmark of
-unprincip{led,al} types.
-
-Another example:
-
-> class C a
-> class D a where
->   d :: a
-> instance C a => D a where
->   d = undefined
-> h _ = d   -- argument is to avoid the monomorphism restriction
-
-The inferred type for h is
-
-> h :: C a => t -> a
-
-even though
-
-> h :: D a => t -> a
-
-is more general.
-
-The fix is easy: don't simplify constraints before inferring a type.
-That is, have the inferred type quantify over all constraints that arise
-in a definition's right-hand side, even if they are simplifiable.
-Unfortunately, this would yield all manner of unwieldy types,
-and so we won't do so.
--}
-
--- | How should we choose which constraints to quantify over?
-data InferMode = ApplyMR          -- ^ Apply the monomorphism restriction,
-                                  -- never quantifying over any constraints
-               | EagerDefaulting  -- ^ See Note [TcRnExprMode] in "GHC.Tc.Module",
-                                  -- the :type +d case; this mode refuses
-                                  -- to quantify over any defaultable constraint
-               | NoRestrictions   -- ^ Quantify over any constraint that
-                                  -- satisfies pickQuantifiablePreds
-
-instance Outputable InferMode where
-  ppr ApplyMR         = text "ApplyMR"
-  ppr EagerDefaulting = text "EagerDefaulting"
-  ppr NoRestrictions  = text "NoRestrictions"
-
-simplifyInfer :: TcLevel               -- Used when generating the constraints
-              -> InferMode
-              -> [TcIdSigInst]         -- Any signatures (possibly partial)
-              -> [(Name, TcTauType)]   -- Variables to be generalised,
-                                       -- and their tau-types
-              -> WantedConstraints
-              -> TcM ([TcTyVar],    -- Quantify over these type variables
-                      [EvVar],      -- ... and these constraints (fully zonked)
-                      TcEvBinds,    -- ... binding these evidence variables
-                      Bool)         -- True <=> the residual constraints are insoluble
-
-simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
-  | isEmptyWC wanteds
-   = do { -- When quantifying, we want to preserve any order of variables as they
-          -- appear in partial signatures. cf. decideQuantifiedTyVars
-          let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs
-                                          , (_,Bndr tv _) <- sig_inst_skols sig ]
-              psig_theta  = [ pred | sig <- partial_sigs
-                                   , pred <- sig_inst_theta sig ]
-
-       ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus)
-
-       ; skol_info <- mkSkolemInfo (InferSkol name_taus)
-       ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars dep_vars
-       ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)
-       ; return (qtkvs, [], emptyTcEvBinds, False) }
-
-  | otherwise
-  = do { traceTc "simplifyInfer {"  $ vcat
-             [ text "sigs =" <+> ppr sigs
-             , text "binds =" <+> ppr name_taus
-             , text "rhs_tclvl =" <+> ppr rhs_tclvl
-             , text "infer_mode =" <+> ppr infer_mode
-             , text "(unzonked) wanted =" <+> ppr wanteds
-             ]
-
-       ; let psig_theta = concatMap sig_inst_theta partial_sigs
-
-       -- First do full-blown solving
-       -- NB: we must gather up all the bindings from doing
-       -- this solving; hence (runTcSWithEvBinds ev_binds_var).
-       -- And note that since there are nested implications,
-       -- calling solveWanteds will side-effect their evidence
-       -- bindings, so we can't just revert to the input
-       -- constraint.
-
-       ; ev_binds_var <- TcM.newTcEvBinds
-       ; psig_evs     <- newWanteds AnnOrigin psig_theta
-       ; wanted_transformed
-            <- setTcLevel rhs_tclvl $
-               runTcSWithEvBinds ev_binds_var $
-               solveWanteds (mkSimpleWC psig_evs `andWC` wanteds)
-               -- psig_evs : see Note [Add signature contexts as wanteds]
-               -- See Note [Inferring principal types]
-
-       -- Find quant_pred_candidates, the predicates that
-       -- we'll consider quantifying over
-       -- NB1: wanted_transformed does not include anything provable from
-       --      the psig_theta; it's just the extra bit
-       -- NB2: We do not do any defaulting when inferring a type, this can lead
-       --      to less polymorphic types, see Note [Default while Inferring]
-       ; wanted_transformed <- TcM.zonkWC wanted_transformed
-       ; let definite_error = insolubleWC wanted_transformed
-                              -- See Note [Quantification with errors]
-             quant_pred_candidates
-               | definite_error = []
-               | otherwise      = ctsPreds (approximateWC False wanted_transformed)
-
-       -- Decide what type variables and constraints to quantify
-       -- NB: quant_pred_candidates is already fully zonked
-       -- NB: bound_theta are constraints we want to quantify over,
-       --     including the psig_theta, which we always quantify over
-       -- NB: bound_theta are fully zonked
-       ; rec { (qtvs, bound_theta, co_vars) <- decideQuantification skol_info infer_mode rhs_tclvl
-                                                     name_taus partial_sigs
-                                                     quant_pred_candidates
-             ;  bound_theta_vars <- mapM TcM.newEvVar bound_theta
-
-             ; let full_theta = map idType bound_theta_vars
-             ; skol_info <- mkSkolemInfo (InferSkol [ (name, mkSigmaTy [] full_theta ty)
-                                                    | (name, ty) <- name_taus ])
-       }
-
-
-       -- Now emit the residual constraint
-       ; emitResidualConstraints rhs_tclvl ev_binds_var
-                                 name_taus co_vars qtvs bound_theta_vars
-                                 wanted_transformed
-
-         -- All done!
-       ; traceTc "} simplifyInfer/produced residual implication for quantification" $
-         vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates
-              , text "psig_theta ="     <+> ppr psig_theta
-              , text "bound_theta ="    <+> pprCoreBinders bound_theta_vars
-              , text "qtvs ="           <+> ppr qtvs
-              , text "definite_error =" <+> ppr definite_error ]
-
-       ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var, definite_error ) }
-         -- NB: bound_theta_vars must be fully zonked
-  where
-    partial_sigs = filter isPartialSig sigs
-
---------------------
-emitResidualConstraints :: TcLevel -> EvBindsVar
-                        -> [(Name, TcTauType)]
-                        -> CoVarSet -> [TcTyVar] -> [EvVar]
-                        -> WantedConstraints -> TcM ()
--- Emit the remaining constraints from the RHS.
-emitResidualConstraints rhs_tclvl ev_binds_var
-                        name_taus co_vars qtvs full_theta_vars wanteds
-  | isEmptyWC wanteds
-  = return ()
-
-  | otherwise
-  = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds)
-       ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple
-             is_mono ct
-               | Just ct_ev_id <- wantedEvId_maybe ct
-               = ct_ev_id `elemVarSet` co_vars
-               | otherwise
-               = False
-             -- Reason for the partition:
-             -- see Note [Emitting the residual implication in simplifyInfer]
-
--- Already done by defaultTyVarsAndSimplify
---      ; _ <- TcM.promoteTyVarSet (tyCoVarsOfCts outer_simple)
-
-        ; let inner_wanted = wanteds { wc_simple = inner_simple }
-        ; implics <- if isEmptyWC inner_wanted
-                     then return emptyBag
-                     else do implic1 <- newImplication
-                             return $ unitBag $
-                                      implic1  { ic_tclvl     = rhs_tclvl
-                                               , ic_skols     = qtvs
-                                               , ic_given     = full_theta_vars
-                                               , ic_wanted    = inner_wanted
-                                               , ic_binds     = ev_binds_var
-                                               , ic_given_eqs = MaybeGivenEqs
-                                               , ic_info      = skol_info }
-
-        ; emitConstraints (emptyWC { wc_simple = outer_simple
-                                   , wc_impl   = implics }) }
-  where
-    full_theta = map idType full_theta_vars
-    skol_info = InferSkol [ (name, mkSigmaTy [] full_theta ty)
-                          | (name, ty) <- name_taus ]
-    -- We don't add the quantified variables here, because they are
-    -- also bound in ic_skols and we want them to be tidied
-    -- uniformly.
-
---------------------
-ctsPreds :: Cts -> [PredType]
-ctsPreds cts = [ ctEvPred ev | ct <- bagToList cts
-                             , let ev = ctEvidence ct ]
-
-findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType
--- Given a partial type signature f :: (C a, D a, _) => blah
--- and the inferred constraints (X a, D a, Y a, C a)
--- compute the difference, which is what will fill in the "_" underscore,
--- In this case the diff is (X a, Y a).
-findInferredDiff annotated_theta inferred_theta
-  | null annotated_theta   -- Short cut the common case when the user didn't
-  = return inferred_theta  -- write any constraints in the partial signature
-  | otherwise
-  = pushTcLevelM_ $
-    do { lcl_env   <- TcM.getLclEnv
-       ; given_ids <- mapM TcM.newEvVar annotated_theta
-       ; wanteds   <- newWanteds AnnOrigin inferred_theta
-       ; let given_loc = mkGivenLoc topTcLevel (getSkolemInfo unkSkol) lcl_env
-             given_cts = mkGivens given_loc given_ids
-
-       ; (residual, _) <- runTcS $
-                          do { _ <- solveSimpleGivens given_cts
-                             ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) }
-         -- NB: There are no meta tyvars fromn this level annotated_theta
-         -- because we have either promoted them or unified them
-         -- See `Note [Quantification and partial signatures]` Wrinkle 2
-
-       ; return (map (box_pred . ctPred) $
-                 bagToList               $
-                 wc_simple residual) }
-  where
-     box_pred :: PredType -> PredType
-     box_pred pred = case classifyPredType pred of
-                        EqPred rel ty1 ty2
-                          | Just (cls,tys) <- boxEqPred rel ty1 ty2
-                          -> mkClassPred cls tys
-                          | otherwise
-                          -> pprPanic "findInferredDiff" (ppr pred)
-                        _other -> pred
-
-{- Note [Emitting the residual implication in simplifyInfer]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   f = e
-where f's type is inferred to be something like (a, Proxy k (Int |> co))
-and we have an as-yet-unsolved, or perhaps insoluble, constraint
-   [W] co :: Type ~ k
-We can't form types like (forall co. blah), so we can't generalise over
-the coercion variable, and hence we can't generalise over things free in
-its kind, in the case 'k'.  But we can still generalise over 'a'.  So
-we'll generalise to
-   f :: forall a. (a, Proxy k (Int |> co))
-Now we do NOT want to form the residual implication constraint
-   forall a. [W] co :: Type ~ k
-because then co's eventual binding (which will be a value binding if we
-use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose
-type mentions 'co').  Instead, just as we don't generalise over 'co', we
-should not bury its constraint inside the implication.  Instead, we must
-put it outside.
-
-That is the reason for the partitionBag in emitResidualConstraints,
-which takes the CoVars free in the inferred type, and pulls their
-constraints out.  (NB: this set of CoVars should be closed-over-kinds.)
-
-All rather subtle; see #14584.
-
-Note [Add signature contexts as wanteds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this (#11016):
-  f2 :: (?x :: Int) => _
-  f2 = ?x
-
-or this
-  class C a b | a -> b
-  g :: C p q => p -> q
-  f3 :: C Int b => _
-  f3 = g (3::Int)
-
-We'll use plan InferGen because there are holes in the type.  But:
- * For f2 we want to have the (?x :: Int) constraint floating around
-   so that the functional dependencies kick in.  Otherwise the
-   occurrence of ?x on the RHS produces constraint (?x :: alpha), and
-   we won't unify alpha:=Int.
-
- * For f3 want the (C Int b) constraint from the partial signature
-   to meet the (C Int beta) constraint we get from the call to g; again,
-   fundeps
-
-Solution: in simplifyInfer, we add the constraints from the signature
-as extra Wanteds.
-
-Why Wanteds?  Wouldn't it be neater to treat them as Givens?  Alas
-that would mess up (GivenInv) in Note [TcLevel invariants].  Consider
-    f :: (Eq a, _) => blah1
-    f = ....g...
-    g :: (Eq b, _) => blah2
-    g = ...f...
-
-Then we have two psig_theta constraints (Eq a[tv], Eq b[tv]), both with
-TyVarTvs inside.  Ultimately a[tv] := b[tv], but only when we've solved
-all those constraints.  And both have level 1, so we can't put them as
-Givens when solving at level 1.
-
-Best to treat them as Wanteds.
-
-But see also #20076, which would be solved if they were Givens.
-
-
-************************************************************************
-*                                                                      *
-                Quantification
-*                                                                      *
-************************************************************************
-
-Note [Deciding quantification]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If the monomorphism restriction does not apply, then we quantify as follows:
-
-* Step 1: decideMonoTyVars.
-  Take the global tyvars, and "grow" them using functional dependencies
-     E.g.  if x:alpha is in the environment, and alpha ~ [beta] (which can
-          happen because alpha is untouchable here) then do not quantify over
-          beta, because alpha fixes beta, and beta is effectively free in
-          the environment too; this logic extends to general fundeps, not
-          just equalities
-
-  We also account for the monomorphism restriction; if it applies,
-  add the free vars of all the constraints.
-
-  Result is mono_tvs; we will not quantify over these.
-
-* Step 2: defaultTyVarsAndSimplify.
-  Default any non-mono tyvars (i.e ones that are definitely
-  not going to become further constrained), and re-simplify the
-  candidate constraints.
-
-  Motivation for re-simplification (#7857): imagine we have a
-  constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are
-  not free in the envt, and instance forall (a::*) (b::*). (C a) => C
-  (a -> b) The instance doesn't match while l1,l2 are polymorphic, but
-  it will match when we default them to LiftedRep.
-
-  This is all very tiresome.
-
-  This step also promotes the mono_tvs from Step 1. See
-  Note [Promote monomorphic tyvars]. In fact, the *only*
-  use of the mono_tvs from Step 1 is to promote them here.
-  This promotion effectively stops us from quantifying over them
-  later, in Step 3. Because the actual variables to quantify
-  over are determined in Step 3 (not in Step 1), it is OK for
-  the mono_tvs to be missing some variables free in the
-  environment. This is why removing the psig_qtvs is OK in
-  decideMonoTyVars. Test case for this scenario: T14479.
-
-* Step 3: decideQuantifiedTyVars.
-  Decide which variables to quantify over, as follows:
-
-  - Take the free vars of the partial-type-signature types and constraints,
-    and the tau-type (zonked_tau_tvs), and then "grow"
-    them using all the constraints.  These are grown_tcvs.
-    See Note [growThetaTyVars vs closeWrtFunDeps].
-
-  - Use quantifyTyVars to quantify over the free variables of all the types
-    involved, but only those in the grown_tcvs.
-
-  Result is qtvs.
-
-* Step 4: Filter the constraints using pickQuantifiablePreds and the
-  qtvs. We have to zonk the constraints first, so they "see" the
-  freshly created skolems.
-
-Note [Lift equality constraints when quantifying]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We can't quantify over a constraint (t1 ~# t2) because that isn't a
-predicate type; see Note [Types for coercions, predicates, and evidence]
-in GHC.Core.TyCo.Rep.
-
-So we have to 'lift' it to (t1 ~ t2).  Similarly (~R#) must be lifted
-to Coercible.
-
-This tiresome lifting is the reason that pick_me (in
-pickQuantifiablePreds) returns a Maybe rather than a Bool.
-
-Note [Inheriting implicit parameters]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this:
-
-        f x = (x::Int) + ?y
-
-where f is *not* a top-level binding.
-From the RHS of f we'll get the constraint (?y::Int).
-There are two types we might infer for f:
-
-        f :: Int -> Int
-
-(so we get ?y from the context of f's definition), or
-
-        f :: (?y::Int) => Int -> Int
-
-At first you might think the first was better, because then
-?y behaves like a free variable of the definition, rather than
-having to be passed at each call site.  But of course, the WHOLE
-IDEA is that ?y should be passed at each call site (that's what
-dynamic binding means) so we'd better infer the second.
-
-BOTTOM LINE: when *inferring types* you must quantify over implicit
-parameters, *even if* they don't mention the bound type variables.
-Reason: because implicit parameters, uniquely, have local instance
-declarations. See pickQuantifiablePreds.
-
-Note [Quantifying over equality constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Should we quantify over an equality constraint (s ~ t)?  In general, we don't.
-Doing so may simply postpone a type error from the function definition site to
-its call site.  (At worst, imagine (Int ~ Bool)).
-
-However, consider this
-         forall a. (F [a] ~ Int) => blah
-Should we quantify over the (F [a] ~ Int).  Perhaps yes, because at the call
-site we will know 'a', and perhaps we have instance  F [Bool] = Int.
-So we *do* quantify over a type-family equality where the arguments mention
-the quantified variables.
-
-Note [Unconditionally resimplify constraints when quantifying]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-During quantification (in defaultTyVarsAndSimplify, specifically), we re-invoke
-the solver to simplify the constraints before quantifying them. We do this for
-two reasons, enumerated below. We could, in theory, detect when either of these
-cases apply and simplify only then, but collecting this information is bothersome,
-and simplifying redundantly causes no real harm. Note that this code path
-happens only for definitions
-  * without a type signature
-  * when -XMonoLocalBinds does not apply
-  * with unsolved constraints
-and so the performance cost will be small.
-
-1. Defaulting
-
-Defaulting the variables handled by defaultTyVar may unlock instance simplifications.
-Example (typecheck/should_compile/T20584b):
-
-  with (t :: Double) (u :: String) = printf "..." t u
-
-We know the types of t and u, but we do not know the return type of `with`. So, we
-assume `with :: alpha`, where `alpha :: TYPE rho`. The type of printf is
-  printf :: PrintfType r => String -> r
-The occurrence of printf is instantiated with a fresh var beta. We then get
-  beta := Double -> String -> alpha
-and
-  [W] PrintfType (Double -> String -> alpha)
-
-Module Text.Printf exports
-  instance (PrintfArg a, PrintfType r) => PrintfType (a -> r)
-and it looks like that instance should apply.
-
-But I have elided some key details: (->) is polymorphic over multiplicity and
-runtime representation. Here it is in full glory:
-  [W] PrintfType ((Double :: Type) %m1 -> (String :: Type) %m2 -> (alpha :: TYPE rho))
-  instance (PrintfArg a, PrintfType r) => PrintfType ((a :: Type) %Many -> (r :: Type))
-
-Because we do not know that m1 is Many, we cannot use the instance. (Perhaps a better instance
-would have an explicit equality constraint to the left of =>, but that's not what we have.)
-Then, in defaultTyVarsAndSimplify, we get m1 := Many, m2 := Many, and rho := LiftedRep.
-Yet it's too late to simplify the quantified constraint, and thus GHC infers
-  wait :: PrintfType (Double -> String -> t) => Double -> String -> t
-which is silly. Simplifying again after defaulting solves this problem.
-
-2. Interacting functional dependencies
-
-Suppose we have
-
-  class C a b | a -> b
-
-and we are running simplifyInfer over
-
-  forall[2] x. () => [W] C a beta1[1]
-  forall[2] y. () => [W] C a beta2[1]
-
-These are two implication constraints, both of which contain a
-wanted for the class C. Neither constraint mentions the bound
-skolem. We might imagine that these constraint could thus float
-out of their implications and then interact, causing beta1 to unify
-with beta2, but constraints do not currently float out of implications.
-
-Unifying the beta1 and beta2 is important. Without doing so, then we might
-infer a type like (C a b1, C a b2) => a -> a, which will fail to pass the
-ambiguity check, which will say (rightly) that it cannot unify b1 with b2, as
-required by the fundep interactions. This happens in the parsec library, and
-in test case typecheck/should_compile/FloatFDs.
-
-If we re-simplify, however, the two fundep constraints will interact, causing
-a unification between beta1 and beta2, and all will be well. The key step
-is that this simplification happens *after* the call to approximateWC in
-simplifyInfer.
-
-Note [Do not quantify over constraints that determine a variable]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (typecheck/should_compile/tc231), where we're trying to infer
-the type of a top-level declaration. We have
-  class Zork s a b | a -> b
-and the candidate constraint at the end of simplifyInfer is
-  [W] Zork alpha (Z [Char]) beta
-We definitely do want to quantify over alpha (which is mentioned in
-the tau-type). But we do *not* want to quantify over beta: it is
-determined by the functional dependency on Zork: note that the second
-argument to Zork in the Wanted is a variable-free Z [Char].
-
-The question here: do we want to quantify over the constraint? Definitely not.
-Since we're not quantifying over beta, GHC has no choice but to zap beta
-to Any, and then we infer a type involving (Zork a (Z [Char]) Any => ...). No no no.
-
-The no_fixed_dependencies check in pickQuantifiablePreds eliminates this
-candidate from the pool. Because there are no Zork instances in scope, this
-program is rejected.
-
--}
-
-decideQuantification
-  :: SkolemInfo
-  -> InferMode
-  -> TcLevel
-  -> [(Name, TcTauType)]   -- Variables to be generalised
-  -> [TcIdSigInst]         -- Partial type signatures (if any)
-  -> [PredType]            -- Candidate theta; already zonked
-  -> TcM ( [TcTyVar]       -- Quantify over these (skolems)
-         , [PredType]      -- and this context (fully zonked)
-         , CoVarSet)
--- See Note [Deciding quantification]
-decideQuantification skol_info infer_mode rhs_tclvl name_taus psigs candidates
-  = do { -- Step 1: find the mono_tvs
-       ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars infer_mode
-                                              name_taus psigs candidates
-
-       -- Step 2: default any non-mono tyvars, and re-simplify
-       -- This step may do some unification, but result candidates is zonked
-       ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates
-
-       -- Step 3: decide which kind/type variables to quantify over
-       ; qtvs <- decideQuantifiedTyVars skol_info name_taus psigs candidates
-
-       -- Step 4: choose which of the remaining candidate
-       --         predicates to actually quantify over
-       -- NB: decideQuantifiedTyVars turned some meta tyvars
-       -- into quantified skolems, so we have to zonk again
-       ; candidates <- TcM.zonkTcTypes candidates
-       ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs)
-       ; let min_theta = mkMinimalBySCs id $  -- See Note [Minimize by Superclasses]
-                         pickQuantifiablePreds (mkVarSet qtvs) candidates
-
-             min_psig_theta = mkMinimalBySCs id psig_theta
-
-       -- Add psig_theta back in here, even though it's already
-       -- part of candidates, because we always want to quantify over
-       -- psig_theta, and pickQuantifiableCandidates might have
-       -- dropped some e.g. CallStack constraints.  c.f #14658
-       --                   equalities (a ~ Bool)
-       -- It's helpful to use the same "find difference" algorithm here as
-       -- we use in GHC.Tc.Gen.Bind.chooseInferredQuantifiers (#20921)
-       -- See Note [Constraints in partial type signatures]
-       ; theta <- if null psig_theta
-                  then return min_theta  -- Fast path for the non-partial-sig case
-                  else do { diff <- findInferredDiff min_psig_theta min_theta
-                          ; return (min_psig_theta ++ diff) }
-
-       ; traceTc "decideQuantification"
-           (vcat [ text "infer_mode:" <+> ppr infer_mode
-                 , text "candidates:" <+> ppr candidates
-                 , text "psig_theta:" <+> ppr psig_theta
-                 , text "mono_tvs:"   <+> ppr mono_tvs
-                 , text "co_vars:"    <+> ppr co_vars
-                 , text "qtvs:"       <+> ppr qtvs
-                 , text "theta:"      <+> ppr theta ])
-       ; return (qtvs, theta, co_vars) }
-
-{- Note [Constraints in partial type signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have a partial type signature
-    f :: (Eq a, C a, _) => blah
-
-We will ultimately quantify f over (Eq a, C a, <diff>), where
-
-   * <diff> is the result of
-         findInferredDiff (Eq a, C a) <quant-theta>
-     in GHC.Tc.Gen.Bind.chooseInferredQuantifiers
-
-   * <quant-theta> is the theta returned right here,
-     by decideQuantification
-
-At least for single functions we would like to quantify f over
-precisely the same theta as <quant-theta>, so that we get to take
-the short-cut path in GHC.Tc.Gen.Bind.mkExport, and avoid calling
-tcSubTypeSigma for impedance matching. Why avoid?  Because it falls
-over for ambiguous types (#20921).
-
-We can get precisely the same theta by using the same algorithm,
-findInferredDiff.
-
-All of this goes wrong if we have (a) mutual recursion, (b) multiple
-partial type signatures, (c) with different constraints, and (d)
-ambiguous types.  Something like
-    f :: forall a. Eq a => F a -> _
-    f x = (undefined :: a) == g x undefined
-    g :: forall b. Show b => F b -> _ -> b
-    g x y = let _ = (f y, show x) in x
-But that's a battle for another day.
--}
-
-decideMonoTyVars :: InferMode
-                 -> [(Name,TcType)]
-                 -> [TcIdSigInst]
-                 -> [PredType]
-                 -> TcM (TcTyCoVarSet, [PredType], CoVarSet)
--- Decide which tyvars and covars cannot be generalised:
---   (a) Free in the environment
---   (b) Mentioned in a constraint we can't generalise
---   (c) Connected by an equality or fundep to (a) or (b)
--- Also return CoVars that appear free in the final quantified types
---   we can't quantify over these, and we must make sure they are in scope
-decideMonoTyVars infer_mode name_taus psigs candidates
-  = do { (no_quant, maybe_quant) <- pick infer_mode candidates
-
-       -- If possible, we quantify over partial-sig qtvs, so they are
-       -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs
-       ; psig_qtvs <-  zonkTcTyVarsToTcTyVars $ binderVars $
-                      concatMap (map snd . sig_inst_skols) psigs
-
-       ; psig_theta <- mapM TcM.zonkTcType $
-                       concatMap sig_inst_theta psigs
-
-       ; taus <- mapM (TcM.zonkTcType . snd) name_taus
-
-       ; tc_lvl <- TcM.getTcLevel
-       ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta
-
-             co_vars = coVarsOfTypes (psig_tys ++ taus ++ candidates)
-             co_var_tvs = closeOverKinds co_vars
-               -- The co_var_tvs are tvs mentioned in the types of covars or
-               -- coercion holes. We can't quantify over these covars, so we
-               -- must include the variable in their types in the mono_tvs.
-               -- E.g.  If we can't quantify over co :: k~Type, then we can't
-               --       quantify over k either!  Hence closeOverKinds
-
-             mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $
-                         tyCoVarsOfTypes candidates
-               -- We need to grab all the non-quantifiable tyvars in the
-               -- types so that we can grow this set to find other
-               -- non-quantifiable tyvars. This can happen with something
-               -- like
-               --    f x y = ...
-               --      where z = x 3
-               -- The body of z tries to unify the type of x (call it alpha[1])
-               -- with (beta[2] -> gamma[2]). This unification fails because
-               -- alpha is untouchable. But we need to know not to quantify over
-               -- beta or gamma, because they are in the equality constraint with
-               -- alpha. Actual test case: typecheck/should_compile/tc213
-
-             mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs
-               -- mono_tvs1 is now the set of variables from an outer scope
-               -- (that's mono_tvs0) and the set of covars, closed over kinds.
-               -- Given this set of variables we know we will not quantify,
-               -- we want to find any other variables that are determined by this
-               -- set, by functional dependencies or equalities. We thus use
-               -- closeWrtFunDeps to find all further variables determined by this root
-               -- set. See Note [growThetaTyVars vs closeWrtFunDeps]
-
-             non_ip_candidates = filterOut isIPLikePred candidates
-               -- implicit params don't really determine a type variable
-               -- (that is, we might have IP "c" Bool and IP "c" Int in different
-               -- places within the same program), and
-               -- skipping this causes implicit params to monomorphise too many
-               -- variables; see Note [Inheriting implicit parameters] in
-               -- GHC.Tc.Solver. Skipping causes typecheck/should_compile/tc219
-               -- to fail.
-
-             mono_tvs2 = closeWrtFunDeps non_ip_candidates mono_tvs1
-               -- mono_tvs2 now contains any variable determined by the "root
-               -- set" of monomorphic tyvars in mono_tvs1.
-
-             constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $
-                               closeWrtFunDeps non_ip_candidates (tyCoVarsOfTypes no_quant)
-                                `minusVarSet` mono_tvs2
-             -- constrained_tvs: the tyvars that we are not going to
-             -- quantify solely because of the monomorphism restriction
-             --
-             -- (`minusVarSet` mono_tvs2): a type variable is only
-             --   "constrained" (so that the MR bites) if it is not
-             --   free in the environment (#13785) or is determined
-             --   by some variable that is free in the env't
-
-             mono_tvs = (mono_tvs2 `unionVarSet` constrained_tvs)
-                          `delVarSetList` psig_qtvs
-             -- (`delVarSetList` psig_qtvs): if the user has explicitly
-             --   asked for quantification, then that request "wins"
-             --   over the MR.
-             --
-             -- What if a psig variable is also free in the environment
-             -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation
-             -- in Step 2 of Note [Deciding quantification].
-
-           -- Warn about the monomorphism restriction
-       ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ do
-           let dia = TcRnMonomorphicBindings (map fst name_taus)
-           diagnosticTc (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) dia
-
-       ; traceTc "decideMonoTyVars" $ vcat
-           [ text "infer_mode =" <+> ppr infer_mode
-           , text "mono_tvs0 =" <+> ppr mono_tvs0
-           , text "no_quant =" <+> ppr no_quant
-           , text "maybe_quant =" <+> ppr maybe_quant
-           , text "mono_tvs =" <+> ppr mono_tvs
-           , text "co_vars =" <+> ppr co_vars ]
-
-       ; return (mono_tvs, maybe_quant, co_vars) }
-  where
-    pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType])
-    -- Split the candidates into ones we definitely
-    -- won't quantify, and ones that we might
-    pick NoRestrictions  cand = return ([], cand)
-    pick ApplyMR         cand = return (cand, [])
-    pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings
-                                   ; return (partition (is_int_ct os) cand) }
-
-    -- For EagerDefaulting, do not quantify over
-    -- over any interactive class constraint
-    is_int_ct ovl_strings pred
-      | Just (cls, _) <- getClassPredTys_maybe pred
-      = isInteractiveClass ovl_strings cls
-      | otherwise
-      = False
-
--------------------
-defaultTyVarsAndSimplify :: TcLevel
-                         -> TyCoVarSet          -- Promote these mono-tyvars
-                         -> [PredType]          -- Assumed zonked
-                         -> TcM [PredType]      -- Guaranteed zonked
--- Promote the known-monomorphic tyvars;
--- Default any tyvar free in the constraints;
--- and re-simplify in case the defaulting allows further simplification
-defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates
-  = do {  -- Promote any tyvars that we cannot generalise
-          -- See Note [Promote monomorphic tyvars]
-       ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs)
-       ; _ <- promoteTyVarSet mono_tvs
-
-       -- Default any kind/levity vars
-       ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}
-                <- candidateQTyVarsOfTypes candidates
-                -- any covars should already be handled by
-                -- the logic in decideMonoTyVars, which looks at
-                -- the constraints generated
-
-       ; poly_kinds  <- xoptM LangExt.PolyKinds
-       ; mapM_ (default_one poly_kinds True) (dVarSetElems cand_kvs)
-       ; mapM_ (default_one poly_kinds False) (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs))
-
-       ; simplify_cand candidates
-       }
-  where
-    default_one poly_kinds is_kind_var tv
-      | not (isMetaTyVar tv)
-      = return ()
-      | tv `elemVarSet` mono_tvs
-      = return ()
-      | otherwise
-      = void $ defaultTyVar
-          (if not poly_kinds && is_kind_var
-           then DefaultKindVars
-           else NonStandardDefaulting DefaultNonStandardTyVars)
-          -- NB: only pass 'DefaultKindVars' when we know we're dealing with a kind variable.
-          tv
-
-       -- this common case (no inferred constraints) should be fast
-    simplify_cand [] = return []
-       -- see Note [Unconditionally resimplify constraints when quantifying]
-    simplify_cand candidates
-      = do { clone_wanteds <- newWanteds DefaultOrigin candidates
-           ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $
-                                           simplifyWantedsTcM clone_wanteds
-              -- Discard evidence; simples is fully zonked
-
-           ; let new_candidates = ctsPreds simples
-           ; traceTc "Simplified after defaulting" $
-                      vcat [ text "Before:" <+> ppr candidates
-                           , text "After:"  <+> ppr new_candidates ]
-           ; return new_candidates }
-
-------------------
-decideQuantifiedTyVars
-   :: SkolemInfo
-   -> [(Name,TcType)]   -- Annotated theta and (name,tau) pairs
-   -> [TcIdSigInst]     -- Partial signatures
-   -> [PredType]        -- Candidates, zonked
-   -> TcM [TyVar]
--- Fix what tyvars we are going to quantify over, and quantify them
-decideQuantifiedTyVars skol_info name_taus psigs candidates
-  = do {     -- Why psig_tys? We try to quantify over everything free in here
-             -- See Note [Quantification and partial signatures]
-             --     Wrinkles 2 and 3
-       ; psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs
-                                                  , (_,Bndr tv _) <- sig_inst_skols sig ]
-       ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs
-                                                  , pred <- sig_inst_theta sig ]
-       ; tau_tys  <- mapM (TcM.zonkTcType . snd) name_taus
-
-       ; let -- Try to quantify over variables free in these types
-             psig_tys = psig_tv_tys ++ psig_theta
-             seed_tys = psig_tys ++ tau_tys
-
-             -- Now "grow" those seeds to find ones reachable via 'candidates'
-             -- See Note [growThetaTyVars vs closeWrtFunDeps]
-             grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys)
-
-       -- Now we have to classify them into kind variables and type variables
-       -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars
-       --
-       -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces
-       -- them in that order, so that the final qtvs quantifies in the same
-       -- order as the partial signatures do (#13524)
-       ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $
-                                                         psig_tys ++ candidates ++ tau_tys
-       ; let pick     = (`dVarSetIntersectVarSet` grown_tcvs)
-             dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs }
-
-       ; traceTc "decideQuantifiedTyVars" (vcat
-           [ text "tau_tys =" <+> ppr tau_tys
-           , text "candidates =" <+> ppr candidates
-           , text "cand_kvs =" <+> ppr cand_kvs
-           , text "cand_tvs =" <+> ppr cand_tvs
-           , text "tau_tys =" <+> ppr tau_tys
-           , text "seed_tys =" <+> ppr seed_tys
-           , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys)
-           , text "grown_tcvs =" <+> ppr grown_tcvs
-           , text "dvs =" <+> ppr dvs_plus])
-
-       ; quantifyTyVars skol_info DefaultNonStandardTyVars dvs_plus }
-
-------------------
--- | When inferring types, should we quantify over a given predicate?
--- Generally true of classes; generally false of equality constraints.
--- Equality constraints that mention quantified type variables and
--- implicit variables complicate the story. See Notes
--- [Inheriting implicit parameters] and [Quantifying over equality constraints]
-pickQuantifiablePreds
-  :: TyVarSet           -- Quantifying over these
-  -> TcThetaType        -- Proposed constraints to quantify
-  -> TcThetaType        -- A subset that we can actually quantify
--- This function decides whether a particular constraint should be
--- quantified over, given the type variables that are being quantified
-pickQuantifiablePreds qtvs theta
-  = let flex_ctxt = True in  -- Quantify over non-tyvar constraints, even without
-                             -- -XFlexibleContexts: see #10608, #10351
-         -- flex_ctxt <- xoptM Opt_FlexibleContexts
-    mapMaybe (pick_me flex_ctxt) theta
-  where
-    pick_me flex_ctxt pred
-      = case classifyPredType pred of
-
-          ClassPred cls tys
-            | Just {} <- isCallStackPred cls tys
-              -- NEVER infer a CallStack constraint.  Otherwise we let
-              -- the constraints bubble up to be solved from the outer
-              -- context, or be defaulted when we reach the top-level.
-              -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
-            -> Nothing
-
-            | isIPClass cls
-            -> Just pred -- See Note [Inheriting implicit parameters]
-
-            | pick_cls_pred flex_ctxt cls tys
-            -> Just pred
-
-          EqPred eq_rel ty1 ty2
-            | quantify_equality eq_rel ty1 ty2
-            , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2
-              -- boxEqPred: See Note [Lift equality constraints when quantifying]
-            , pick_cls_pred flex_ctxt cls tys
-            -> Just (mkClassPred cls tys)
-
-          IrredPred ty
-            | tyCoVarsOfType ty `intersectsVarSet` qtvs
-            -> Just pred
-
-          _ -> Nothing
-
-
-    pick_cls_pred flex_ctxt cls tys
-      = tyCoVarsOfTypes tys `intersectsVarSet` qtvs
-        && (checkValidClsArgs flex_ctxt cls tys)
-           -- Only quantify over predicates that checkValidType
-           -- will pass!  See #10351.
-        && (no_fixed_dependencies cls tys)
-
-    -- See Note [Do not quantify over constraints that determine a variable]
-    no_fixed_dependencies cls tys
-      = and [ qtvs `intersectsVarSet` tyCoVarsOfTypes fd_lhs_tys
-            | fd <- cls_fds
-            , let (fd_lhs_tys, _) = instFD fd cls_tvs tys ]
-      where
-        (cls_tvs, cls_fds) = classTvsFds cls
-
-    -- See Note [Quantifying over equality constraints]
-    quantify_equality NomEq  ty1 ty2 = quant_fun ty1 || quant_fun ty2
-    quantify_equality ReprEq _   _   = True
-
-    quant_fun ty
-      = case tcSplitTyConApp_maybe ty of
-          Just (tc, tys) | isTypeFamilyTyCon tc
-                         -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs
-          _ -> False
-
-
-------------------
-growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet
--- See Note [growThetaTyVars vs closeWrtFunDeps]
-growThetaTyVars theta tcvs
-  | null theta = tcvs
-  | otherwise  = transCloVarSet mk_next seed_tcvs
-  where
-    seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips
-    (ips, non_ips) = partition isIPLikePred theta
-                         -- See Note [Inheriting implicit parameters]
-
-    mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones
-    mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips
-    grow_one so_far pred tcvs
-       | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs
-       | otherwise                           = tcvs
-       where
-         pred_tcvs = tyCoVarsOfType pred
-
-
-{- Note [Promote monomorphic tyvars]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Promote any type variables that are free in the environment.  Eg
-   f :: forall qtvs. bound_theta => zonked_tau
-The free vars of f's type become free in the envt, and hence will show
-up whenever 'f' is called.  They may currently at rhs_tclvl, but they
-had better be unifiable at the outer_tclvl!  Example: envt mentions
-alpha[1]
-           tau_ty = beta[2] -> beta[2]
-           constraints = alpha ~ [beta]
-we don't quantify over beta (since it is fixed by envt)
-so we must promote it!  The inferred type is just
-  f :: beta -> beta
-
-NB: promoteTyVarSet ignores coercion variables
-
-Note [Quantification and partial signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When choosing type variables to quantify, the basic plan is to
-quantify over all type variables that are
- * free in the tau_tvs, and
- * not forced to be monomorphic (mono_tvs),
-   for example by being free in the environment.
-
-However, in the case of a partial type signature, we are doing inference
-*in the presence of a type signature*. For example:
-   f :: _ -> a
-   f x = ...
-or
-   g :: (Eq _a) => _b -> _b
-In both cases we use plan InferGen, and hence call simplifyInfer.  But
-those 'a' variables are skolems (actually TyVarTvs), and we should be
-sure to quantify over them.  This leads to several wrinkles:
-
-* Wrinkle 1.  In the case of a type error
-     f :: _ -> Maybe a
-     f x = True && x
-  The inferred type of 'f' is f :: Bool -> Bool, but there's a
-  left-over error of form (Maybe a ~ Bool).  The error-reporting
-  machine expects to find a binding site for the skolem 'a', so we
-  add it to the quantified tyvars.
-
-* Wrinkle 2.  Consider the partial type signature
-     f :: (Eq _) => Int -> Int
-     f x = x
-  In normal cases that makes sense; e.g.
-     g :: Eq _a => _a -> _a
-     g x = x
-  where the signature makes the type less general than it could
-  be. But for 'f' we must therefore quantify over the user-annotated
-  constraints, to get
-     f :: forall a. Eq a => Int -> Int
-  (thereby correctly triggering an ambiguity error later).  If we don't
-  we'll end up with a strange open type
-     f :: Eq alpha => Int -> Int
-  which isn't ambiguous but is still very wrong.
-
-  Bottom line: Try to quantify over any variable free in psig_theta,
-  just like the tau-part of the type.
-
-* Wrinkle 3 (#13482). Also consider
-    f :: forall a. _ => Int -> Int
-    f x = if (undefined :: a) == undefined then x else 0
-  Here we get an (Eq a) constraint, but it's not mentioned in the
-  psig_theta nor the type of 'f'.  But we still want to quantify
-  over 'a' even if the monomorphism restriction is on.
-
-* Wrinkle 4 (#14479)
-    foo :: Num a => a -> a
-    foo xxx = g xxx
-      where
-        g :: forall b. Num b => _ -> b
-        g y = xxx + y
-
-  In the signature for 'g', we cannot quantify over 'b' because it turns out to
-  get unified with 'a', which is free in g's environment.  So we carefully
-  refrain from bogusly quantifying, in GHC.Tc.Solver.decideMonoTyVars.  We
-  report the error later, in GHC.Tc.Gen.Bind.chooseInferredQuantifiers.
-
-Note [growThetaTyVars vs closeWrtFunDeps]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-GHC has two functions, growThetaTyVars and closeWrtFunDeps, both with
-the same type and similar behavior. This Note outlines the differences
-and why we use one or the other.
-
-Both functions take a list of constraints. We will call these the
-*candidates*.
-
-closeWrtFunDeps takes a set of "determined" type variables and finds the
-closure of that set with respect to the functional dependencies
-within the class constraints in the set of candidates. So, if we
-have
-
-  class C a b | a -> b
-  class D a b   -- no fundep
-  candidates = {C (Maybe a) (Either b c), D (Maybe a) (Either d e)}
-
-then closeWrtFunDeps {a} will return the set {a,b,c}.
-This is because, if `a` is determined, then `b` and `c` are, too,
-by functional dependency. closeWrtFunDeps called with any seed set not including
-`a` will just return its argument, as only `a` determines any other
-type variable (in this example).
-
-growThetaTyVars operates similarly, but it behaves as if every
-constraint has a functional dependency among all its arguments.
-So, continuing our example, growThetaTyVars {a} will return
-{a,b,c,d,e}. Put another way, growThetaTyVars grows the set of
-variables to include all variables that are mentioned in the same
-constraint (transitively).
-
-We use closeWrtFunDeps in places where we need to know which variables are
-*always* determined by some seed set. This includes
-  * when determining the mono-tyvars in decideMonoTyVars. If `a`
-    is going to be monomorphic, we need b and c to be also: they
-    are determined by the choice for `a`.
-  * when checking instance coverage, in
-    GHC.Tc.Instance.FunDeps.checkInstCoverage
-
-On the other hand, we use growThetaTyVars where we need to know
-which variables *might* be determined by some seed set. This includes
-  * deciding quantification (GHC.Tc.Gen.Bind.chooseInferredQuantifiers
-    and decideQuantifiedTyVars
-How can `a` determine (say) `d` in the example above without a fundep?
-Suppose we have
-  instance (b ~ a, c ~ a) => D (Maybe [a]) (Either b c)
-Now, if `a` turns out to be a list, it really does determine b and c.
-The danger in overdoing quantification is the creation of an ambiguous
-type signature, but this is conveniently caught in the validity checker.
-
-Note [Quantification with errors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we find that the RHS of the definition has some absolutely-insoluble
-constraints (including especially "variable not in scope"), we
-
-* Abandon all attempts to find a context to quantify over,
-  and instead make the function fully-polymorphic in whatever
-  type we have found
-
-* Return a flag from simplifyInfer, indicating that we found an
-  insoluble constraint.  This flag is used to suppress the ambiguity
-  check for the inferred type, which may well be bogus, and which
-  tends to obscure the real error.  This fix feels a bit clunky,
-  but I failed to come up with anything better.
-
-Reasons:
-    - Avoid downstream errors
-    - Do not perform an ambiguity test on a bogus type, which might well
-      fail spuriously, thereby obfuscating the original insoluble error.
-      #14000 is an example
-
-I tried an alternative approach: simply failM, after emitting the
-residual implication constraint; the exception will be caught in
-GHC.Tc.Gen.Bind.tcPolyBinds, which gives all the binders in the group the type
-(forall a. a).  But that didn't work with -fdefer-type-errors, because
-the recovery from failM emits no code at all, so there is no function
-to run!   But -fdefer-type-errors aspires to produce a runnable program.
-
-Note [Default while Inferring]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Our current plan is that defaulting only happens at simplifyTop and
-not simplifyInfer.  This may lead to some insoluble deferred constraints.
-Example:
-
-instance D g => C g Int b
-
-constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha
-type inferred       = gamma -> gamma
-
-Now, if we try to default (alpha := Int) we will be able to refine the implication to
-  (forall b. 0 => C gamma Int b)
-which can then be simplified further to
-  (forall b. 0 => D gamma)
-Finally, we /can/ approximate this implication with (D gamma) and infer the quantified
-type:  forall g. D g => g -> g
-
-Instead what will currently happen is that we will get a quantified type
-(forall g. g -> g) and an implication:
-       forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha
-
-Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an
-unsolvable implication:
-       forall g. 0 => (forall b. 0 => D g)
-
-The concrete example would be:
-       h :: C g a s => g -> a -> ST s a
-       f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1)
-
-But it is quite tedious to do defaulting and resolve the implication constraints, and
-we have not observed code breaking because of the lack of defaulting in inference, so
-we don't do it for now.
-
-
-
-Note [Minimize by Superclasses]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we quantify over a constraint, in simplifyInfer we need to
-quantify over a constraint that is minimal in some sense: For
-instance, if the final wanted constraint is (Eq alpha, Ord alpha),
-we'd like to quantify over Ord alpha, because we can just get Eq alpha
-from superclass selection from Ord alpha. This minimization is what
-mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint
-to check the original wanted.
-
-
-Note [Avoid unnecessary constraint simplification]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-    -------- NB NB NB (Jun 12) -------------
-    This note not longer applies; see the notes with #4361.
-    But I'm leaving it in here so we remember the issue.)
-    ----------------------------------------
-When inferring the type of a let-binding, with simplifyInfer,
-try to avoid unnecessarily simplifying class constraints.
-Doing so aids sharing, but it also helps with delicate
-situations like
-
-   instance C t => C [t] where ..
-
-   f :: C [t] => ....
-   f x = let g y = ...(constraint C [t])...
-         in ...
-When inferring a type for 'g', we don't want to apply the
-instance decl, because then we can't satisfy (C t).  So we
-just notice that g isn't quantified over 't' and partition
-the constraints before simplifying.
-
-This only half-works, but then let-generalisation only half-works.
-
-*********************************************************************************
-*                                                                                 *
-*                                 Main Simplifier                                 *
-*                                                                                 *
-***********************************************************************************
-
--}
-
-simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints
--- Solve the specified Wanted constraints
--- Discard the evidence binds
--- Postcondition: fully zonked
-simplifyWantedsTcM wanted
-  = do { traceTc "simplifyWantedsTcM {" (ppr wanted)
-       ; (result, _) <- runTcS (solveWanteds (mkSimpleWC wanted))
-       ; result <- TcM.zonkWC result
-       ; traceTc "simplifyWantedsTcM }" (ppr result)
-       ; return result }
-
-solveWanteds :: WantedConstraints -> TcS WantedConstraints
-solveWanteds wc@(WC { wc_errors = errs })
-  = do { cur_lvl <- TcS.getTcLevel
-       ; traceTcS "solveWanteds {" $
-         vcat [ text "Level =" <+> ppr cur_lvl
-              , ppr wc ]
-
-       ; dflags <- getDynFlags
-       ; solved_wc <- simplify_loop 0 (solverIterations dflags) True wc
-
-       ; errs' <- simplifyDelayedErrors errs
-       ; let final_wc = solved_wc { wc_errors = errs' }
-
-       ; ev_binds_var <- getTcEvBindsVar
-       ; bb <- TcS.getTcEvBindsMap ev_binds_var
-       ; traceTcS "solveWanteds }" $
-                 vcat [ text "final wc =" <+> ppr final_wc
-                      , text "current evbinds  =" <+> ppr (evBindMapBinds bb) ]
-
-       ; return final_wc }
-
-simplify_loop :: Int -> IntWithInf -> Bool
-              -> WantedConstraints -> TcS WantedConstraints
--- Do a round of solving, and call maybe_simplify_again to iterate
--- The 'definitely_redo_implications' flags is False if the only reason we
--- are iterating is that we have added some new Wanted superclasses
--- hoping for fundeps to help us; see Note [Superclass iteration]
---
--- Does not affect wc_holes at all; reason: wc_holes never affects anything
--- else, so we do them once, at the end in solveWanteds
-simplify_loop n limit definitely_redo_implications
-              wc@(WC { wc_simple = simples, wc_impl = implics })
-  = do { csTraceTcS $
-         text "simplify_loop iteration=" <> int n
-         <+> (parens $ hsep [ text "definitely_redo =" <+> ppr definitely_redo_implications <> comma
-                            , int (lengthBag simples) <+> text "simples to solve" ])
-       ; traceTcS "simplify_loop: wc =" (ppr wc)
-
-       ; (unifs1, wc1) <- reportUnifications $  -- See Note [Superclass iteration]
-                          solveSimpleWanteds simples
-                -- Any insoluble constraints are in 'simples' and so get rewritten
-                -- See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet
-
-       ; wc2 <- if not definitely_redo_implications  -- See Note [Superclass iteration]
-                   && unifs1 == 0                    -- for this conditional
-                   && isEmptyBag (wc_impl wc1)
-                then return (wc { wc_simple = wc_simple wc1 })  -- Short cut
-                else do { implics2 <- solveNestedImplications $
-                                      implics `unionBags` (wc_impl wc1)
-                        ; return (wc { wc_simple = wc_simple wc1
-                                     , wc_impl = implics2 }) }
-
-       ; unif_happened <- resetUnificationFlag
-       ; csTraceTcS $ text "unif_happened" <+> ppr unif_happened
-         -- Note [The Unification Level Flag] in GHC.Tc.Solver.Monad
-       ; maybe_simplify_again (n+1) limit unif_happened wc2 }
-
-maybe_simplify_again :: Int -> IntWithInf -> Bool
-                     -> WantedConstraints -> TcS WantedConstraints
-maybe_simplify_again n limit unif_happened wc@(WC { wc_simple = simples })
-  | n `intGtLimit` limit
-  = do { -- Add an error (not a warning) if we blow the limit,
-         -- Typically if we blow the limit we are going to report some other error
-         -- (an unsolved constraint), and we don't want that error to suppress
-         -- the iteration limit warning!
-         addErrTcS $ TcRnSimplifierTooManyIterations simples limit wc
-       ; return wc }
-
-  | unif_happened
-  = simplify_loop n limit True wc
-
-  | superClassesMightHelp wc
-  = -- We still have unsolved goals, and apparently no way to solve them,
-    -- so try expanding superclasses at this level, both Given and Wanted
-    do { pending_given <- getPendingGivenScs
-       ; let (pending_wanted, simples1) = getPendingWantedScs simples
-       ; if null pending_given && null pending_wanted
-           then return wc  -- After all, superclasses did not help
-           else
-    do { new_given  <- makeSuperClasses pending_given
-       ; new_wanted <- makeSuperClasses pending_wanted
-       ; solveSimpleGivens new_given -- Add the new Givens to the inert set
-       ; simplify_loop n limit (not (null pending_given)) $
-         wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } }
-         -- (not (null pending_given)): see Note [Superclass iteration]
-
-  | otherwise
-  = return wc
-
-{- Note [Superclass iteration]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this implication constraint
-    forall a.
-       [W] d: C Int beta
-       forall b. blah
-where
-  class D a b | a -> b
-  class D a b => C a b
-We will expand d's superclasses, giving [W] D Int beta, in the hope of geting
-fundeps to unify beta.  Doing so is usually fruitless (no useful fundeps),
-and if so it seems a pity to waste time iterating the implications (forall b. blah)
-(If we add new Given superclasses it's a different matter: it's really worth looking
-at the implications.)
-
-Hence the definitely_redo_implications flag to simplify_loop.  It's usually
-True, but False in the case where the only reason to iterate is new Wanted
-superclasses.  In that case we check whether the new Wanteds actually led to
-any new unifications, and iterate the implications only if so.
--}
-
-solveNestedImplications :: Bag Implication
-                        -> TcS (Bag Implication)
--- Precondition: the TcS inerts may contain unsolved simples which have
--- to be converted to givens before we go inside a nested implication.
-solveNestedImplications implics
-  | isEmptyBag implics
-  = return (emptyBag)
-  | otherwise
-  = do { traceTcS "solveNestedImplications starting {" empty
-       ; unsolved_implics <- mapBagM solveImplication implics
-
-       -- ... and we are back in the original TcS inerts
-       -- Notice that the original includes the _insoluble_simples so it was safe to ignore
-       -- them in the beginning of this function.
-       ; traceTcS "solveNestedImplications end }" $
-                  vcat [ text "unsolved_implics =" <+> ppr unsolved_implics ]
-
-       ; return (catBagMaybes unsolved_implics) }
-
-solveImplication :: Implication    -- Wanted
-                 -> TcS (Maybe Implication) -- Simplified implication (empty or singleton)
--- Precondition: The TcS monad contains an empty worklist and given-only inerts
--- which after trying to solve this implication we must restore to their original value
-solveImplication imp@(Implic { ic_tclvl  = tclvl
-                             , ic_binds  = ev_binds_var
-                             , ic_given  = given_ids
-                             , ic_wanted = wanteds
-                             , ic_info   = info
-                             , ic_status = status })
-  | isSolvedStatus status
-  = return (Just imp)  -- Do nothing
-
-  | otherwise  -- Even for IC_Insoluble it is worth doing more work
-               -- The insoluble stuff might be in one sub-implication
-               -- and other unsolved goals in another; and we want to
-               -- solve the latter as much as possible
-  = do { inerts <- getTcSInerts
-       ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts)
-
-       -- commented out; see `where` clause below
-       -- ; when debugIsOn check_tc_level
-
-         -- Solve the nested constraints
-       ; (has_given_eqs, given_insols, residual_wanted)
-            <- nestImplicTcS ev_binds_var tclvl $
-               do { let loc    = mkGivenLoc tclvl info (ic_env imp)
-                        givens = mkGivens loc given_ids
-                  ; solveSimpleGivens givens
-
-                  ; residual_wanted <- solveWanteds wanteds
-
-                  ; (has_eqs, given_insols) <- getHasGivenEqs tclvl
-                        -- Call getHasGivenEqs /after/ solveWanteds, because
-                        -- solveWanteds can augment the givens, via expandSuperClasses,
-                        -- to reveal given superclass equalities
-
-                  ; return (has_eqs, given_insols, residual_wanted) }
-
-       ; traceTcS "solveImplication 2"
-           (ppr given_insols $$ ppr residual_wanted)
-       ; let final_wanted = residual_wanted `addInsols` given_insols
-             -- Don't lose track of the insoluble givens,
-             -- which signal unreachable code; put them in ic_wanted
-
-       ; res_implic <- setImplicationStatus (imp { ic_given_eqs = has_given_eqs
-                                                 , ic_wanted = final_wanted })
-
-       ; evbinds <- TcS.getTcEvBindsMap ev_binds_var
-       ; tcvs    <- TcS.getTcEvTyCoVars ev_binds_var
-       ; traceTcS "solveImplication end }" $ vcat
-             [ text "has_given_eqs =" <+> ppr has_given_eqs
-             , text "res_implic =" <+> ppr res_implic
-             , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds)
-             , text "implication tvcs =" <+> ppr tcvs ]
-
-       ; return res_implic }
-
-    -- TcLevels must be strictly increasing (see (ImplicInv) in
-    -- Note [TcLevel invariants] in GHC.Tc.Utils.TcType),
-    -- and in fact I think they should always increase one level at a time.
-
-    -- Though sensible, this check causes lots of testsuite failures. It is
-    -- remaining commented out for now.
-    {-
-    check_tc_level = do { cur_lvl <- TcS.getTcLevel
-                        ; massertPpr (tclvl == pushTcLevel cur_lvl)
-                                     (text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl) }
-    -}
-
-----------------------
-setImplicationStatus :: Implication -> TcS (Maybe Implication)
--- Finalise the implication returned from solveImplication,
--- setting the ic_status field
--- Precondition: the ic_status field is not already IC_Solved
--- Return Nothing if we can discard the implication altogether
-setImplicationStatus implic@(Implic { ic_status     = status
-                                    , ic_info       = info
-                                    , ic_wanted     = wc
-                                    , ic_given      = givens })
- | assertPpr (not (isSolvedStatus status)) (ppr info) $
-   -- Precondition: we only set the status if it is not already solved
-   not (isSolvedWC pruned_wc)
- = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic)
-
-      ; implic <- neededEvVars implic
-
-      ; let new_status | insolubleWC pruned_wc = IC_Insoluble
-                       | otherwise             = IC_Unsolved
-            new_implic = implic { ic_status = new_status
-                                , ic_wanted = pruned_wc }
-
-      ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic)
-
-      ; return $ Just new_implic }
-
- | otherwise  -- Everything is solved
-              -- Set status to IC_Solved,
-              -- and compute the dead givens and outer needs
-              -- See Note [Tracking redundant constraints]
- = do { traceTcS "setImplicationStatus(all-solved) {" (ppr implic)
-
-      ; implic@(Implic { ic_need_inner = need_inner
-                       , ic_need_outer = need_outer }) <- neededEvVars implic
-
-      ; bad_telescope <- checkBadTelescope implic
-
-      ; let (used_givens, unused_givens)
-              | warnRedundantGivens info
-              = partition (`elemVarSet` need_inner) givens
-              | otherwise = (givens, [])   -- None to report
-
-            minimal_used_givens = mkMinimalBySCs evVarPred used_givens
-            is_minimal = (`elemVarSet` mkVarSet minimal_used_givens)
-
-            warn_givens
-              | not (null unused_givens) = unused_givens
-              | warnRedundantGivens info = filterOut is_minimal used_givens
-              | otherwise                = []
-
-            discard_entire_implication  -- Can we discard the entire implication?
-              =  null warn_givens           -- No warning from this implication
-              && not bad_telescope
-              && isEmptyWC pruned_wc        -- No live children
-              && isEmptyVarSet need_outer   -- No needed vars to pass up to parent
-
-            final_status
-              | bad_telescope = IC_BadTelescope
-              | otherwise     = IC_Solved { ics_dead = warn_givens }
-            final_implic = implic { ic_status = final_status
-                                  , ic_wanted = pruned_wc }
-
-      ; traceTcS "setImplicationStatus(all-solved) }" $
-        vcat [ text "discard:" <+> ppr discard_entire_implication
-             , text "new_implic:" <+> ppr final_implic ]
-
-      ; return $ if discard_entire_implication
-                 then Nothing
-                 else Just final_implic }
- where
-   WC { wc_simple = simples, wc_impl = implics, wc_errors = errs } = wc
-
-   pruned_implics = filterBag keep_me implics
-   pruned_wc = WC { wc_simple = simples
-                  , wc_impl   = pruned_implics
-                  , wc_errors = errs }   -- do not prune holes; these should be reported
-
-   keep_me :: Implication -> Bool
-   keep_me ic
-     | IC_Solved { ics_dead = dead_givens } <- ic_status ic
-                          -- Fully solved
-     , null dead_givens   -- No redundant givens to report
-     , isEmptyBag (wc_impl (ic_wanted ic))
-           -- And no children that might have things to report
-     = False       -- Tnen we don't need to keep it
-     | otherwise
-     = True        -- Otherwise, keep it
-
-checkBadTelescope :: Implication -> TcS Bool
--- True <=> the skolems form a bad telescope
--- See Note [Checking telescopes] in GHC.Tc.Types.Constraint
-checkBadTelescope (Implic { ic_info  = info
-                          , ic_skols = skols })
-  | checkTelescopeSkol info
-  = do{ skols <- mapM TcS.zonkTyCoVarKind skols
-      ; return (go emptyVarSet (reverse skols))}
-
-  | otherwise
-  = return False
-
-  where
-    go :: TyVarSet   -- skolems that appear *later* than the current ones
-       -> [TcTyVar]  -- ordered skolems, in reverse order
-       -> Bool       -- True <=> there is an out-of-order skolem
-    go _ [] = False
-    go later_skols (one_skol : earlier_skols)
-      | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols
-      = True
-      | otherwise
-      = go (later_skols `extendVarSet` one_skol) earlier_skols
-
-warnRedundantGivens :: SkolemInfoAnon -> Bool
-warnRedundantGivens (SigSkol ctxt _ _)
-  = case ctxt of
-       FunSigCtxt _ rrc -> reportRedundantConstraints rrc
-       ExprSigCtxt rrc  -> reportRedundantConstraints rrc
-       _                -> False
-
-  -- To think about: do we want to report redundant givens for
-  -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21.
-warnRedundantGivens (InstSkol {}) = True
-warnRedundantGivens _             = False
-
-neededEvVars :: Implication -> TcS Implication
--- Find all the evidence variables that are "needed",
--- and delete dead evidence bindings
---   See Note [Tracking redundant constraints]
---   See Note [Delete dead Given evidence bindings]
---
---   - Start from initial_seeds (from nested implications)
---
---   - Add free vars of RHS of all Wanted evidence bindings
---     and coercion variables accumulated in tcvs (all Wanted)
---
---   - Generate 'needed', the needed set of EvVars, by doing transitive
---     closure through Given bindings
---     e.g.   Needed {a,b}
---            Given  a = sc_sel a2
---            Then a2 is needed too
---
---   - Prune out all Given bindings that are not needed
---
---   - From the 'needed' set, delete ev_bndrs, the binders of the
---     evidence bindings, to give the final needed variables
---
-neededEvVars implic@(Implic { ic_given = givens
-                            , ic_binds = ev_binds_var
-                            , ic_wanted = WC { wc_impl = implics }
-                            , ic_need_inner = old_needs })
- = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var
-      ; tcvs     <- TcS.getTcEvTyCoVars ev_binds_var
-
-      ; let seeds1        = foldr add_implic_seeds old_needs implics
-            seeds2        = nonDetStrictFoldEvBindMap add_wanted seeds1 ev_binds
-                            -- It's OK to use a non-deterministic fold here
-                            -- because add_wanted is commutative
-            seeds3        = seeds2 `unionVarSet` tcvs
-            need_inner    = findNeededEvVars ev_binds seeds3
-            live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds
-            need_outer    = varSetMinusEvBindMap need_inner live_ev_binds
-                            `delVarSetList` givens
-
-      ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds
-           -- See Note [Delete dead Given evidence bindings]
-
-      ; traceTcS "neededEvVars" $
-        vcat [ text "old_needs:" <+> ppr old_needs
-             , text "seeds3:" <+> ppr seeds3
-             , text "tcvs:" <+> ppr tcvs
-             , text "ev_binds:" <+> ppr ev_binds
-             , text "live_ev_binds:" <+> ppr live_ev_binds ]
-
-      ; return (implic { ic_need_inner = need_inner
-                       , ic_need_outer = need_outer }) }
- where
-   add_implic_seeds (Implic { ic_need_outer = needs }) acc
-      = needs `unionVarSet` acc
-
-   needed_ev_bind needed (EvBind { eb_lhs = ev_var
-                                 , eb_is_given = is_given })
-     | is_given  = ev_var `elemVarSet` needed
-     | otherwise = True   -- Keep all wanted bindings
-
-   add_wanted :: EvBind -> VarSet -> VarSet
-   add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs
-     | is_given  = needs  -- Add the rhs vars of the Wanted bindings only
-     | otherwise = evVarsOfTerm rhs `unionVarSet` needs
-
--------------------------------------------------
-simplifyDelayedErrors :: Bag DelayedError -> TcS (Bag DelayedError)
-simplifyDelayedErrors = mapBagM simpl_err
-  where
-    simpl_err :: DelayedError -> TcS DelayedError
-    simpl_err (DE_Hole hole) = DE_Hole <$> simpl_hole hole
-    simpl_err err@(DE_NotConcrete {}) = return err
-
-    simpl_hole :: Hole -> TcS Hole
-
-     -- See Note [Do not simplify ConstraintHoles]
-    simpl_hole h@(Hole { hole_sort = ConstraintHole }) = return h
-
-     -- other wildcards should be simplified for printing
-     -- we must do so here, and not in the error-message generation
-     -- code, because we have all the givens already set up
-    simpl_hole h@(Hole { hole_ty = ty, hole_loc = loc })
-      = do { ty' <- rewriteType loc ty
-           ; return (h { hole_ty = ty' }) }
-
-{- Note [Delete dead Given evidence bindings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As a result of superclass expansion, we speculatively
-generate evidence bindings for Givens. E.g.
-   f :: (a ~ b) => a -> b -> Bool
-   f x y = ...
-We'll have
-   [G] d1 :: (a~b)
-and we'll speculatively generate the evidence binding
-   [G] d2 :: (a ~# b) = sc_sel d
-
-Now d2 is available for solving.  But it may not be needed!  Usually
-such dead superclass selections will eventually be dropped as dead
-code, but:
-
- * It won't always be dropped (#13032).  In the case of an
-   unlifted-equality superclass like d2 above, we generate
-       case heq_sc d1 of d2 -> ...
-   and we can't (in general) drop that case expression in case
-   d1 is bottom.  So it's technically unsound to have added it
-   in the first place.
-
- * Simply generating all those extra superclasses can generate lots of
-   code that has to be zonked, only to be discarded later.  Better not
-   to generate it in the first place.
-
-   Moreover, if we simplify this implication more than once
-   (e.g. because we can't solve it completely on the first iteration
-   of simpl_loop), we'll generate all the same bindings AGAIN!
-
-Easy solution: take advantage of the work we are doing to track dead
-(unused) Givens, and use it to prune the Given bindings too.  This is
-all done by neededEvVars.
-
-This led to a remarkable 25% overall compiler allocation decrease in
-test T12227.
-
-But we don't get to discard all redundant equality superclasses, alas;
-see #15205.
-
-Note [Do not simplify ConstraintHoles]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Before printing the inferred value for a type hole (a _ wildcard in
-a partial type signature), we simplify it w.r.t. any Givens. This
-makes for an easier-to-understand diagnostic for the user.
-
-However, we do not wish to do this for extra-constraint holes. Here is
-the example for why (partial-sigs/should_compile/T12844):
-
-  bar :: _ => FooData rngs
-  bar = foo
-
-  data FooData rngs
-
-  class Foo xs where foo :: (Head xs ~ '(r,r')) => FooData xs
-
-  type family Head (xs :: [k]) where Head (x ': xs) = x
-
-GHC correctly infers that the extra-constraints wildcard on `bar`
-should be (Head rngs ~ '(r, r'), Foo rngs). It then adds this
-constraint as a Given on the implication constraint for `bar`. (This
-implication is emitted by emitResidualConstraints.) The Hole for the _
-is stored within the implication's WantedConstraints.  When
-simplifyHoles is called, that constraint is already assumed as a
-Given. Simplifying with respect to it turns it into ('(r, r') ~ '(r,
-r'), Foo rngs), which is disastrous.
-
-Furthermore, there is no need to simplify here: extra-constraints wildcards
-are filled in with the output of the solver, in chooseInferredQuantifiers
-(choose_psig_context), so they are already simplified. (Contrast to normal
-type holes, which are just bound to a meta-variable.) Avoiding the poor output
-is simple: just don't simplify extra-constraints wildcards.
-
-This is the only reason we need to track ConstraintHole separately
-from TypeHole in HoleSort.
-
-See also Note [Extra-constraint holes in partial type signatures]
-in GHC.Tc.Gen.HsType.
-
-Note [Tracking redundant constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-With Opt_WarnRedundantConstraints, GHC can report which
-constraints of a type signature (or instance declaration) are
-redundant, and can be omitted.  Here is an overview of how it
-works.
-
-This is all tested in typecheck/should_compile/T20602 (among
-others).
-
------ What is a redundant constraint?
-
-* The things that can be redundant are precisely the Given
-  constraints of an implication.
-
-* A constraint can be redundant in two different ways:
-  a) It is not needed by the Wanted constraints covered by the
-     implication E.g.
-       f :: Eq a => a -> Bool
-       f x = True  -- Equality not used
-  b) It is implied by other givens.  E.g.
-       f :: (Eq a, Ord a)     => blah   -- Eq a unnecessary
-       g :: (Eq a, a~b, Eq b) => blah   -- Either Eq a or Eq b unnecessary
-
-*  To find (a) we need to know which evidence bindings are 'wanted';
-   hence the eb_is_given field on an EvBind.
-
-*  To find (b), we use mkMinimalBySCs on the Givens to see if any
-   are unnecessary.
-
------ How tracking works
-
-* When two Givens are the same, we drop the evidence for the one
-  that requires more superclass selectors. This is done
-  according to Note [Replacement vs keeping] in GHC.Tc.Solver.Interact.
-
-* The ic_need fields of an Implic records in-scope (given) evidence
-  variables bound by the context, that were needed to solve this
-  implication (so far).  See the declaration of Implication.
-
-* When the constraint solver finishes solving all the wanteds in
-  an implication, it sets its status to IC_Solved
-
-  - The ics_dead field, of IC_Solved, records the subset of this
-    implication's ic_given that are redundant (not needed).
-
-* We compute which evidence variables are needed by an implication
-  in setImplicationStatus.  A variable is needed if
-    a) it is free in the RHS of a Wanted EvBind,
-    b) it is free in the RHS of an EvBind whose LHS is needed, or
-    c) it is in the ics_need of a nested implication.
-
-* After computing which variables are needed, we then look at the
-  remaining variables for internal redundancies. This is case (b)
-  from above. This is also done in setImplicationStatus.
-  Note that we only look for case (b) if case (a) shows up empty,
-  as exemplified below.
-
-* We need to be careful not to discard an implication
-  prematurely, even one that is fully solved, because we might
-  thereby forget which variables it needs, and hence wrongly
-  report a constraint as redundant.  But we can discard it once
-  its free vars have been incorporated into its parent; or if it
-  simply has no free vars. This careful discarding is also
-  handled in setImplicationStatus.
-
-* Examples:
-
-    f, g, h :: (Eq a, Ord a) => a -> Bool
-    f x = x == x
-    g x = x > x
-    h x = x == x && x > x
-
-    All three will discover that they have two [G] Eq a constraints:
-    one as given and one extracted from the Ord a constraint. They will
-    both discard the latter, as noted above and in
-    Note [Replacement vs keeping] in GHC.Tc.Solver.Interact.
-
-    The body of f uses the [G] Eq a, but not the [G] Ord a. It will
-    report a redundant Ord a using the logic for case (a).
-
-    The body of g uses the [G] Ord a, but not the [G] Eq a. It will
-    report a redundant Eq a using the logic for case (a).
-
-    The body of h uses both [G] Ord a and [G] Eq a. Case (a) will
-    thus come up with nothing redundant. But then, the case (b)
-    check will discover that Eq a is redundant and report this.
-
-    If we did case (b) even when case (a) reports something, then
-    we would report both constraints as redundant for f, which is
-    terrible.
-
------ Reporting redundant constraints
-
-* GHC.Tc.Errors does the actual warning, in warnRedundantConstraints.
-
-* We don't report redundant givens for *every* implication; only
-  for those which reply True to GHC.Tc.Solver.warnRedundantGivens:
-
-   - For example, in a class declaration, the default method *can*
-     use the class constraint, but it certainly doesn't *have* to,
-     and we don't want to report an error there.
-
-   - More subtly, in a function definition
-       f :: (Ord a, Ord a, Ix a) => a -> a
-       f x = rhs
-     we do an ambiguity check on the type (which would find that one
-     of the Ord a constraints was redundant), and then we check that
-     the definition has that type (which might find that both are
-     redundant).  We don't want to report the same error twice, so we
-     disable it for the ambiguity check.  Hence using two different
-     FunSigCtxts, one with the warn-redundant field set True, and the
-     other set False in
-        - GHC.Tc.Gen.Bind.tcSpecPrag
-        - GHC.Tc.Gen.Bind.tcTySig
-
-  This decision is taken in setImplicationStatus, rather than GHC.Tc.Errors
-  so that we can discard implication constraints that we don't need.
-  So ics_dead consists only of the *reportable* redundant givens.
-
------ Shortcomings
-
-Consider
-
-  j :: (Eq a, a ~ b) => a -> Bool
-  j x = x == x
-
-  k :: (Eq a, b ~ a) => a -> Bool
-  k x = x == x
-
-Currently (Nov 2021), j issues no warning, while k says that b ~ a
-is redundant. This is because j uses the a ~ b constraint to rewrite
-everything to be in terms of b, while k does none of that. This is
-ridiculous, but I (Richard E) don't see a good fix.
-
--}
-
--- | Like 'defaultTyVar', but in the TcS monad.
-defaultTyVarTcS :: TcTyVar -> TcS Bool
-defaultTyVarTcS the_tv
-  | isTyVarTyVar the_tv
-    -- TyVarTvs should only be unified with a tyvar
-    -- never with a type; c.f. GHC.Tc.Utils.TcMType.defaultTyVar
-    -- and Note [Inferring kinds for type declarations] in GHC.Tc.TyCl
-  = return False
-  | isRuntimeRepVar the_tv
-  = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)
-       ; unifyTyVar the_tv liftedRepTy
-       ; return True }
-  | isLevityVar the_tv
-  = do { traceTcS "defaultTyVarTcS Levity" (ppr the_tv)
-       ; unifyTyVar the_tv liftedDataConTy
-       ; return True }
-  | isMultiplicityVar the_tv
-  = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv)
-       ; unifyTyVar the_tv ManyTy
-       ; return True }
-  | otherwise
-  = return False  -- the common case
-
-approximateWC :: Bool -> WantedConstraints -> Cts
--- Second return value is the depleted wc
--- Third return value is YesFDsCombined <=> multiple constraints for the same fundep floated
--- Postcondition: Wanted Cts
--- See Note [ApproximateWC]
--- See Note [floatKindEqualities vs approximateWC]
-approximateWC float_past_equalities wc
-  = float_wc emptyVarSet wc
-  where
-    float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts
-    float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics })
-      = filterBag (is_floatable trapping_tvs) simples `unionBags`
-        concatMapBag (float_implic trapping_tvs) implics
-    float_implic :: TcTyCoVarSet -> Implication -> Cts
-    float_implic trapping_tvs imp
-      | float_past_equalities || ic_given_eqs imp /= MaybeGivenEqs
-      = float_wc new_trapping_tvs (ic_wanted imp)
-      | otherwise   -- Take care with equalities
-      = emptyCts    -- See (1) under Note [ApproximateWC]
-      where
-        new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp
-
-    is_floatable skol_tvs ct
-       | isGivenCt ct     = False
-       | insolubleEqCt ct = False
-       | otherwise        = tyCoVarsOfCt ct `disjointVarSet` skol_tvs
-
-{- Note [ApproximateWC]
-~~~~~~~~~~~~~~~~~~~~~~~
-approximateWC takes a constraint, typically arising from the RHS of a
-let-binding whose type we are *inferring*, and extracts from it some
-*simple* constraints that we might plausibly abstract over.  Of course
-the top-level simple constraints are plausible, but we also float constraints
-out from inside, if they are not captured by skolems.
-
-The same function is used when doing type-class defaulting (see the call
-to applyDefaultingRules) to extract constraints that might be defaulted.
-
-There is one caveat:
-
-1.  When inferring most-general types (in simplifyInfer), we do *not*
-    float anything out if the implication binds equality constraints,
-    because that defeats the OutsideIn story.  Consider
-       data T a where
-         TInt :: T Int
-         MkT :: T a
-
-       f TInt = 3::Int
-
-    We get the implication (a ~ Int => res ~ Int), where so far we've decided
-      f :: T a -> res
-    We don't want to float (res~Int) out because then we'll infer
-      f :: T a -> Int
-    which is only on of the possible types. (GHC 7.6 accidentally *did*
-    float out of such implications, which meant it would happily infer
-    non-principal types.)
-
-   HOWEVER (#12797) in findDefaultableGroups we are not worried about
-   the most-general type; and we /do/ want to float out of equalities.
-   Hence the boolean flag to approximateWC.
-
------- Historical note -----------
-There used to be a second caveat, driven by #8155
-
-   2. We do not float out an inner constraint that shares a type variable
-      (transitively) with one that is trapped by a skolem.  Eg
-          forall a.  F a ~ beta, Integral beta
-      We don't want to float out (Integral beta).  Doing so would be bad
-      when defaulting, because then we'll default beta:=Integer, and that
-      makes the error message much worse; we'd get
-          Can't solve  F a ~ Integer
-      rather than
-          Can't solve  Integral (F a)
-
-      Moreover, floating out these "contaminated" constraints doesn't help
-      when generalising either. If we generalise over (Integral b), we still
-      can't solve the retained implication (forall a. F a ~ b).  Indeed,
-      arguably that too would be a harder error to understand.
-
-But this transitive closure stuff gives rise to a complex rule for
-when defaulting actually happens, and one that was never documented.
-Moreover (#12923), the more complex rule is sometimes NOT what
-you want.  So I simply removed the extra code to implement the
-contamination stuff.  There was zero effect on the testsuite (not even #8155).
------- End of historical note -----------
-
-Note [DefaultTyVar]
-~~~~~~~~~~~~~~~~~~~
-defaultTyVar is used on any un-instantiated meta type variables to
-default any RuntimeRep variables to LiftedRep.  This is important
-to ensure that instance declarations match.  For example consider
-
-     instance Show (a->b)
-     foo x = show (\_ -> True)
-
-Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r),
-and that won't match the typeKind (*) in the instance decl.  See tests
-tc217 and tc175.
-
-We look only at touchable type variables. No further constraints
-are going to affect these type variables, so it's time to do it by
-hand.  However we aren't ready to default them fully to () or
-whatever, because the type-class defaulting rules have yet to run.
-
-An alternate implementation would be to emit a Wanted constraint setting
-the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect.
-
-Note [Promote _and_ default when inferring]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we are inferring a type, we simplify the constraint, and then use
-approximateWC to produce a list of candidate constraints.  Then we MUST
-
-  a) Promote any meta-tyvars that have been floated out by
-     approximateWC, to restore invariant (WantedInv) described in
-     Note [TcLevel invariants] in GHC.Tc.Utils.TcType.
-
-  b) Default the kind of any meta-tyvars that are not mentioned in
-     in the environment.
-
-To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we
-have an instance (C ((x:*) -> Int)).  The instance doesn't match -- but it
-should!  If we don't solve the constraint, we'll stupidly quantify over
-(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over
-(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332.
-#7641 is a simpler example.
-
-Note [Promoting unification variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we float an equality out of an implication we must "promote" free
-unification variables of the equality, in order to maintain Invariant
-(WantedInv) from Note [TcLevel invariants] in GHC.Tc.Types.TcType.
-
-This is absolutely necessary. Consider the following example. We start
-with two implications and a class with a functional dependency.
-
-    class C x y | x -> y
-    instance C [a] [a]
-
-    (I1)      [untch=beta]forall b. 0 => F Int ~ [beta]
-    (I2)      [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c]
-
-We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2.
-They may react to yield that (beta := [alpha]) which can then be pushed inwards
-the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that
-(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable
-beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs:
-
-    class C x y | x -> y where
-     op :: x -> y -> ()
-
-    instance C [a] [a]
-
-    type family F a :: *
-
-    h :: F Int -> ()
-    h = undefined
-
-    data TEx where
-      TEx :: a -> TEx
-
-    f (x::beta) =
-        let g1 :: forall b. b -> ()
-            g1 _ = h [x]
-            g2 z = case z of TEx y -> (h [[undefined]], op x [y])
-        in (g1 '3', g2 undefined)
-
-
-*********************************************************************************
-*                                                                               *
-*                          Defaulting and disambiguation                        *
-*                                                                               *
-*********************************************************************************
--}
-
-applyDefaultingRules :: WantedConstraints -> TcS Bool
--- True <=> I did some defaulting, by unifying a meta-tyvar
--- Input WantedConstraints are not necessarily zonked
-
-applyDefaultingRules wanteds
-  | isEmptyWC wanteds
-  = return False
-  | otherwise
-  = do { info@(default_tys, _) <- getDefaultInfo
-       ; wanteds               <- TcS.zonkWC wanteds
-
-       ; tcg_env <- TcS.getGblEnv
-       ; let plugins = tcg_defaulting_plugins tcg_env
-
-       ; plugin_defaulted <- if null plugins then return [] else
-           do {
-             ; traceTcS "defaultingPlugins {" (ppr wanteds)
-             ; defaultedGroups <- mapM (run_defaulting_plugin wanteds) plugins
-             ; traceTcS "defaultingPlugins }" (ppr defaultedGroups)
-             ; return defaultedGroups
-             }
-
-       ; let groups = findDefaultableGroups info wanteds
-
-       ; traceTcS "applyDefaultingRules {" $
-                  vcat [ text "wanteds =" <+> ppr wanteds
-                       , text "groups  =" <+> ppr groups
-                       , text "info    =" <+> ppr info ]
-
-       ; something_happeneds <- mapM (disambigGroup default_tys) groups
-
-       ; traceTcS "applyDefaultingRules }" (ppr something_happeneds)
-
-       ; return $ or something_happeneds || or plugin_defaulted }
-    where run_defaulting_plugin wanteds p =
-            do { groups <- runTcPluginTcS (p wanteds)
-               ; defaultedGroups <-
-                    filterM (\g -> disambigGroup
-                                   (deProposalCandidates g)
-                                   (deProposalTyVar g, deProposalCts g))
-                    groups
-               ; traceTcS "defaultingPlugin " $ ppr defaultedGroups
-               ; case defaultedGroups of
-                 [] -> return False
-                 _  -> return True
-               }
-
-
-findDefaultableGroups
-    :: ( [Type]
-       , (Bool,Bool) )     -- (Overloaded strings, extended default rules)
-    -> WantedConstraints   -- Unsolved
-    -> [(TyVar, [Ct])]
-findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
-  | null default_tys
-  = []
-  | otherwise
-  = [ (tv, map fstOf3 group)
-    | group'@((_,_,tv) :| _) <- unary_groups
-    , let group = toList group'
-    , defaultable_tyvar tv
-    , defaultable_classes (map sndOf3 group) ]
-  where
-    simples                = approximateWC True wanteds
-    (unaries, non_unaries) = partitionWith find_unary (bagToList simples)
-    unary_groups           = equivClasses cmp_tv unaries
-
-    unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints
-    unaries      :: [(Ct, Class, TcTyVar)]          -- (C tv) constraints
-    non_unaries  :: [Ct]                            -- and *other* constraints
-
-        -- Finds unary type-class constraints
-        -- But take account of polykinded classes like Typeable,
-        -- which may look like (Typeable * (a:*))   (#8931)
-    find_unary :: Ct -> Either (Ct, Class, TyVar) Ct
-    find_unary cc
-        | Just (cls,tys)   <- getClassPredTys_maybe (ctPred cc)
-        , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys
-              -- Ignore invisible arguments for this purpose
-        , Just tv <- getTyVar_maybe ty
-        , isMetaTyVar tv  -- We might have runtime-skolems in GHCi, and
-                          -- we definitely don't want to try to assign to those!
-        = Left (cc, cls, tv)
-    find_unary cc = Right cc  -- Non unary or non dictionary
-
-    bad_tvs :: TcTyCoVarSet  -- TyVars mentioned by non-unaries
-    bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries
-
-    cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2
-
-    defaultable_tyvar :: TcTyVar -> Bool
-    defaultable_tyvar tv
-        = let b1 = isTyConableTyVar tv  -- Note [Avoiding spurious errors]
-              b2 = not (tv `elemVarSet` bad_tvs)
-          in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults]
-
-    defaultable_classes :: [Class] -> Bool
-    defaultable_classes clss
-        | extended_defaults = any (isInteractiveClass ovl_strings) clss
-        | otherwise         = all is_std_class clss && (any (isNumClass ovl_strings) clss)
-
-    -- is_std_class adds IsString to the standard numeric classes,
-    -- when -XOverloadedStrings is enabled
-    is_std_class cls = isStandardClass cls ||
-                       (ovl_strings && (cls `hasKey` isStringClassKey))
-
-------------------------------
-disambigGroup :: [Type]            -- The default types
-              -> (TcTyVar, [Ct])   -- All constraints sharing same type variable
-              -> TcS Bool   -- True <=> something happened, reflected in ty_binds
-
-disambigGroup [] _
-  = return False
-disambigGroup (default_ty:default_tys) group@(the_tv, wanteds)
-  = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ])
-       ; fake_ev_binds_var <- TcS.newTcEvBinds
-       ; tclvl             <- TcS.getTcLevel
-       ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group
-
-       ; if success then
-             -- Success: record the type variable binding, and return
-             do { unifyTyVar the_tv default_ty
-                ; wrapWarnTcS $ warnDefaulting the_tv wanteds default_ty
-                ; traceTcS "disambigGroup succeeded }" (ppr default_ty)
-                ; return True }
-         else
-             -- Failure: try with the next type
-             do { traceTcS "disambigGroup failed, will try other default types }"
-                           (ppr default_ty)
-                ; disambigGroup default_tys group } }
-  where
-    try_group
-      | Just subst <- mb_subst
-      = do { lcl_env <- TcS.getLclEnv
-           ; tc_lvl <- TcS.getTcLevel
-           ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) lcl_env
-           -- Equality constraints are possible due to type defaulting plugins
-           ; wanted_evs <- sequence [ newWantedNC loc rewriters pred'
-                                    | wanted <- wanteds
-                                    , CtWanted { ctev_pred = pred
-                                               , ctev_rewriters = rewriters }
-                                        <- return (ctEvidence wanted)
-                                    , let pred' = substTy subst pred ]
-           ; fmap isEmptyWC $
-             solveSimpleWanteds $ listToBag $
-             map mkNonCanonical wanted_evs }
-
-      | otherwise
-      = return False
-
-    the_ty   = mkTyVarTy the_tv
-    mb_subst = tcMatchTyKi the_ty default_ty
-      -- Make sure the kinds match too; hence this call to tcMatchTyKi
-      -- E.g. suppose the only constraint was (Typeable k (a::k))
-      -- With the addition of polykinded defaulting we also want to reject
-      -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here.
-
--- In interactive mode, or with -XExtendedDefaultRules,
--- we default Show a to Show () to avoid gratuitous errors on "show []"
-isInteractiveClass :: Bool   -- -XOverloadedStrings?
-                   -> Class -> Bool
-isInteractiveClass ovl_strings cls
-    = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys)
-
-    -- isNumClass adds IsString to the standard numeric classes,
-    -- when -XOverloadedStrings is enabled
-isNumClass :: Bool   -- -XOverloadedStrings?
-           -> Class -> Bool
-isNumClass ovl_strings cls
-  = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey))
-
-
-{-
-Note [Avoiding spurious errors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When doing the unification for defaulting, we check for skolem
-type variables, and simply don't default them.  For example:
-   f = (*)      -- Monomorphic
-   g :: Num a => a -> a
-   g x = f x x
-Here, we get a complaint when checking the type signature for g,
-that g isn't polymorphic enough; but then we get another one when
-dealing with the (Num a) context arising from f's definition;
-we try to unify a with Int (to default it), but find that it's
-already been unified with the rigid variable from g's type sig.
-
-Note [Multi-parameter defaults]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-With -XExtendedDefaultRules, we default only based on single-variable
-constraints, but do not exclude from defaulting any type variables which also
-appear in multi-variable constraints. This means that the following will
-default properly:
-
-   default (Integer, Double)
-
-   class A b (c :: Symbol) where
-      a :: b -> Proxy c
-
-   instance A Integer c where a _ = Proxy
-
-   main = print (a 5 :: Proxy "5")
-
-Note that if we change the above instance ("instance A Integer") to
-"instance A Double", we get an error:
-
-   No instance for (A Integer "5")
-
-This is because the first defaulted type (Integer) has successfully satisfied
-its single-parameter constraints (in this case Num).
--}
diff --git a/compiler/GHC/Tc/Solver/Canonical.hs b/compiler/GHC/Tc/Solver/Canonical.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Solver/Canonical.hs
+++ /dev/null
@@ -1,3323 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE MultiWayIf #-}
-
-module GHC.Tc.Solver.Canonical(
-     canonicalize,
-     unifyWanted,
-     makeSuperClasses,
-     StopOrContinue(..), stopWith, continueWith, andWhenContinue,
-     solveCallStack    -- For GHC.Tc.Solver
-  ) where
-
-import GHC.Prelude
-
-import GHC.Tc.Types.Constraint
-import GHC.Core.Predicate
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.Unify
-import GHC.Tc.Utils.TcType
-import GHC.Core.Type
-import GHC.Tc.Solver.Rewrite
-import GHC.Tc.Solver.Monad
-import GHC.Tc.Solver.InertSet
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.EvTerm
-import GHC.Core.Class
-import GHC.Core.DataCon ( dataConName )
-import GHC.Core.TyCon
-import GHC.Core.Multiplicity
-import GHC.Core.TyCo.Rep   -- cleverly decomposes types, good for completeness checking
-import GHC.Core.Coercion
-import GHC.Core.Coercion.Axiom
-import GHC.Core.Reduction
-import GHC.Core
-import GHC.Types.Id( mkTemplateLocals )
-import GHC.Core.FamInstEnv ( FamInstEnvs )
-import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe )
-import GHC.Types.Var
-import GHC.Types.Var.Env( mkInScopeSet )
-import GHC.Types.Var.Set( delVarSetList, anyVarSet )
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Builtin.Types ( anyTypeOfKind )
-import GHC.Types.Name.Set
-import GHC.Types.Name.Reader
-import GHC.Hs.Type( HsIPName(..) )
-import GHC.Types.Unique  ( hasKey )
-import GHC.Builtin.Names ( coercibleTyConKey )
-
-import GHC.Data.Pair
-import GHC.Utils.Misc
-import GHC.Data.Bag
-import GHC.Utils.Monad
-import GHC.Utils.Constants( debugIsOn )
-import Control.Monad
-import Data.Maybe ( isJust, isNothing )
-import Data.List  ( zip4 )
-import GHC.Types.Basic
-
-import qualified Data.Semigroup as S
-import Data.Bifunctor ( bimap )
-import Data.Foldable ( traverse_ )
-
-{-
-************************************************************************
-*                                                                      *
-*                      The Canonicaliser                               *
-*                                                                      *
-************************************************************************
-
-Note [Canonicalization]
-~~~~~~~~~~~~~~~~~~~~~~~
-
-Canonicalization converts a simple constraint to a canonical form. It is
-unary (i.e. treats individual constraints one at a time).
-
-Constraints originating from user-written code come into being as
-CNonCanonicals. We know nothing about these constraints. So, first:
-
-     Classify CNonCanoncal constraints, depending on whether they
-     are equalities, class predicates, or other.
-
-Then proceed depending on the shape of the constraint. Generally speaking,
-each constraint gets rewritten and then decomposed into one of several forms
-(see type Ct in GHC.Tc.Types).
-
-When an already-canonicalized constraint gets kicked out of the inert set,
-it must be recanonicalized. But we know a bit about its shape from the
-last time through, so we can skip the classification step.
-
--}
-
--- Top-level canonicalization
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-canonicalize :: Ct -> TcS (StopOrContinue Ct)
-canonicalize (CNonCanonical { cc_ev = ev })
-  = {-# SCC "canNC" #-}
-    canNC ev
-
-canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))
-  = canForAll ev pend_sc
-
-canonicalize (CIrredCan { cc_ev = ev })
-  = canNC ev
-    -- Instead of rewriting the evidence before classifying, it's possible we
-    -- can make progress without the rewrite. Try this first.
-    -- For insolubles (all of which are equalities), do /not/ rewrite the arguments
-    -- In #14350 doing so led entire-unnecessary and ridiculously large
-    -- type function expansion.  Instead, canEqNC just applies
-    -- the substitution to the predicate, and may do decomposition;
-    --    e.g. a ~ [a], where [G] a ~ [Int], can decompose
-
-canonicalize (CDictCan { cc_ev = ev, cc_class  = cls
-                       , cc_tyargs = xis, cc_pend_sc = pend_sc })
-  = {-# SCC "canClass" #-}
-    canClass ev cls xis pend_sc
-
-canonicalize (CEqCan { cc_ev     = ev
-                     , cc_lhs    = lhs
-                     , cc_rhs    = rhs
-                     , cc_eq_rel = eq_rel })
-  = {-# SCC "canEqLeafTyVarEq" #-}
-    canEqNC ev eq_rel (canEqLHSType lhs) rhs
-
-canNC :: CtEvidence -> TcS (StopOrContinue Ct)
-canNC ev =
-  case classifyPredType pred of
-      ClassPred cls tys     -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)
-                                  canClassNC ev cls tys
-      EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)
-                                  canEqNC    ev eq_rel ty1 ty2
-      IrredPred {}          -> do traceTcS "canEvNC:irred" (ppr pred)
-                                  canIrred ev
-      ForAllPred tvs th p   -> do traceTcS "canEvNC:forall" (ppr pred)
-                                  canForAllNC ev tvs th p
-
-  where
-    pred = ctEvPred ev
-
-{-
-************************************************************************
-*                                                                      *
-*                      Class Canonicalization
-*                                                                      *
-************************************************************************
--}
-
-canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)
--- "NC" means "non-canonical"; that is, we have got here
--- from a NonCanonical constraint, not from a CDictCan
--- Precondition: EvVar is class evidence
-canClassNC ev cls tys
-  | isGiven ev  -- See Note [Eagerly expand given superclasses]
-  = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys
-       ; emitWork sc_cts
-       ; canClass ev cls tys False }
-
-  | CtWanted { ctev_rewriters = rewriters } <- ev
-  , Just ip_name <- isCallStackPred cls tys
-  , isPushCallStackOrigin orig
-  -- If we're given a CallStack constraint that arose from a function
-  -- call, we need to push the current call-site onto the stack instead
-  -- of solving it directly from a given.
-  -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
-  -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Types
-  = do { -- First we emit a new constraint that will capture the
-         -- given CallStack.
-       ; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))
-                            -- We change the origin to IPOccOrigin so
-                            -- this rule does not fire again.
-                            -- See Note [Overview of implicit CallStacks]
-                            -- in GHC.Tc.Types.Evidence
-
-       ; new_ev <- newWantedEvVarNC new_loc rewriters pred
-
-         -- Then we solve the wanted by pushing the call-site
-         -- onto the newly emitted CallStack
-       ; let ev_cs = EvCsPushCall (callStackOriginFS orig)
-                                  (ctLocSpan loc) (ctEvExpr new_ev)
-       ; solveCallStack ev ev_cs
-
-       ; canClass new_ev cls tys False -- No superclasses
-       }
-
-  | otherwise
-  = canClass ev cls tys (has_scs cls)
-
-  where
-    has_scs cls = not (null (classSCTheta cls))
-    loc  = ctEvLoc ev
-    orig = ctLocOrigin loc
-    pred = ctEvPred ev
-
-solveCallStack :: CtEvidence -> EvCallStack -> TcS ()
--- Also called from GHC.Tc.Solver when defaulting call stacks
-solveCallStack ev ev_cs = do
-  -- We're given ev_cs :: CallStack, but the evidence term should be a
-  -- dictionary, so we have to coerce ev_cs to a dictionary for
-  -- `IP ip CallStack`. See Note [Overview of implicit CallStacks]
-  cs_tm <- evCallStack ev_cs
-  let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))
-  setEvBindIfWanted ev ev_tm
-
-canClass :: CtEvidence
-         -> Class -> [Type]
-         -> Bool            -- True <=> un-explored superclasses
-         -> TcS (StopOrContinue Ct)
--- Precondition: EvVar is class evidence
-
-canClass ev cls tys pend_sc
-  = -- all classes do *nominal* matching
-    assertPpr (ctEvRole ev == Nominal) (ppr ev $$ ppr cls $$ ppr tys) $
-    do { (redns@(Reductions _ xis), rewriters) <- rewriteArgsNom ev cls_tc tys
-       ; let redn@(Reduction _ xi) = mkClassPredRedn cls redns
-             mk_ct new_ev = CDictCan { cc_ev = new_ev
-                                     , cc_tyargs = xis
-                                     , cc_class = cls
-                                     , cc_pend_sc = pend_sc }
-       ; mb <- rewriteEvidence rewriters ev redn
-       ; traceTcS "canClass" (vcat [ ppr ev
-                                   , ppr xi, ppr mb ])
-       ; return (fmap mk_ct mb) }
-  where
-    cls_tc = classTyCon cls
-
-{- Note [The superclass story]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We need to add superclass constraints for two reasons:
-
-* For givens [G], they give us a route to proof.  E.g.
-    f :: Ord a => a -> Bool
-    f x = x == x
-  We get a Wanted (Eq a), which can only be solved from the superclass
-  of the Given (Ord a).
-
-* For wanteds [W], they may give useful
-  functional dependencies.  E.g.
-     class C a b | a -> b where ...
-     class C a b => D a b where ...
-  Now a [W] constraint (D Int beta) has (C Int beta) as a superclass
-  and that might tell us about beta, via C's fundeps.  We can get this
-  by generating a [W] (C Int beta) constraint. We won't use the evidence,
-  but it may lead to unification.
-
-See Note [Why adding superclasses can help].
-
-For these reasons we want to generate superclass constraints for both
-Givens and Wanteds. But:
-
-* (Minor) they are often not needed, so generating them aggressively
-  is a waste of time.
-
-* (Major) if we want recursive superclasses, there would be an infinite
-  number of them.  Here is a real-life example (#10318);
-
-     class (Frac (Frac a) ~ Frac a,
-            Fractional (Frac a),
-            IntegralDomain (Frac a))
-         => IntegralDomain a where
-      type Frac a :: *
-
-  Notice that IntegralDomain has an associated type Frac, and one
-  of IntegralDomain's superclasses is another IntegralDomain constraint.
-
-So here's the plan:
-
-1. Eagerly generate superclasses for given (but not wanted)
-   constraints; see Note [Eagerly expand given superclasses].
-   This is done using mkStrictSuperClasses in canClassNC, when
-   we take a non-canonical Given constraint and cannonicalise it.
-
-   However stop if you encounter the same class twice.  That is,
-   mkStrictSuperClasses expands eagerly, but has a conservative
-   termination condition: see Note [Expanding superclasses] in GHC.Tc.Utils.TcType.
-
-2. Solve the wanteds as usual, but do no further expansion of
-   superclasses for canonical CDictCans in solveSimpleGivens or
-   solveSimpleWanteds; Note [Danger of adding superclasses during solving]
-
-   However, /do/ continue to eagerly expand superclasses for new /given/
-   /non-canonical/ constraints (canClassNC does this).  As #12175
-   showed, a type-family application can expand to a class constraint,
-   and we want to see its superclasses for just the same reason as
-   Note [Eagerly expand given superclasses].
-
-3. If we have any remaining unsolved wanteds
-        (see Note [When superclasses help] in GHC.Tc.Types.Constraint)
-   try harder: take both the Givens and Wanteds, and expand
-   superclasses again.  See the calls to expandSuperClasses in
-   GHC.Tc.Solver.simpl_loop and solveWanteds.
-
-   This may succeed in generating (a finite number of) extra Givens,
-   and extra Wanteds. Both may help the proof.
-
-3a An important wrinkle: only expand Givens from the current level.
-   Two reasons:
-      - We only want to expand it once, and that is best done at
-        the level it is bound, rather than repeatedly at the leaves
-        of the implication tree
-      - We may be inside a type where we can't create term-level
-        evidence anyway, so we can't superclass-expand, say,
-        (a ~ b) to get (a ~# b).  This happened in #15290.
-
-4. Go round to (2) again.  This loop (2,3,4) is implemented
-   in GHC.Tc.Solver.simpl_loop.
-
-The cc_pend_sc flag in a CDictCan records whether the superclasses of
-this constraint have been expanded.  Specifically, in Step 3 we only
-expand superclasses for constraints with cc_pend_sc set to true (i.e.
-isPendingScDict holds).
-
-Why do we do this?  Two reasons:
-
-* To avoid repeated work, by repeatedly expanding the superclasses of
-  same constraint,
-
-* To terminate the above loop, at least in the -XNoUndecidableSuperClasses
-  case.  If there are recursive superclasses we could, in principle,
-  expand forever, always encountering new constraints.
-
-When we take a CNonCanonical or CIrredCan, but end up classifying it
-as a CDictCan, we set the cc_pend_sc flag to False.
-
-Note [Superclass loops]
-~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-  class C a => D a
-  class D a => C a
-
-Then, when we expand superclasses, we'll get back to the self-same
-predicate, so we have reached a fixpoint in expansion and there is no
-point in fruitlessly expanding further.  This case just falls out from
-our strategy.  Consider
-  f :: C a => a -> Bool
-  f x = x==x
-Then canClassNC gets the [G] d1: C a constraint, and eager emits superclasses
-G] d2: D a, [G] d3: C a (psc).  (The "psc" means it has its sc_pend flag set.)
-When processing d3 we find a match with d1 in the inert set, and we always
-keep the inert item (d1) if possible: see Note [Replacement vs keeping] in
-GHC.Tc.Solver.Interact.  So d3 dies a quick, happy death.
-
-Note [Eagerly expand given superclasses]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In step (1) of Note [The superclass story], why do we eagerly expand
-Given superclasses by one layer?  (By "one layer" we mean expand transitively
-until you meet the same class again -- the conservative criterion embodied
-in expandSuperClasses.  So a "layer" might be a whole stack of superclasses.)
-We do this eagerly for Givens mainly because of some very obscure
-cases like this:
-
-   instance Bad a => Eq (T a)
-
-   f :: (Ord (T a)) => blah
-   f x = ....needs Eq (T a), Ord (T a)....
-
-Here if we can't satisfy (Eq (T a)) from the givens we'll use the
-instance declaration; but then we are stuck with (Bad a).  Sigh.
-This is really a case of non-confluent proofs, but to stop our users
-complaining we expand one layer in advance.
-
-Note [Instance and Given overlap] in GHC.Tc.Solver.Interact.
-
-We also want to do this if we have
-
-   f :: F (T a) => blah
-
-where
-   type instance F (T a) = Ord (T a)
-
-So we may need to do a little work on the givens to expose the
-class that has the superclasses.  That's why the superclass
-expansion for Givens happens in canClassNC.
-
-This same scenario happens with quantified constraints, whose superclasses
-are also eagerly expanded. Test case: typecheck/should_compile/T16502b
-These are handled in canForAllNC, analogously to canClassNC.
-
-Note [Why adding superclasses can help]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Examples of how adding superclasses can help:
-
-    --- Example 1
-        class C a b | a -> b
-    Suppose we want to solve
-         [G] C a b
-         [W] C a beta
-    Then adding [W] beta~b will let us solve it.
-
-    -- Example 2 (similar but using a type-equality superclass)
-        class (F a ~ b) => C a b
-    And try to sllve:
-         [G] C a b
-         [W] C a beta
-    Follow the superclass rules to add
-         [G] F a ~ b
-         [W] F a ~ beta
-    Now we get [W] beta ~ b, and can solve that.
-
-    -- Example (tcfail138)
-      class L a b | a -> b
-      class (G a, L a b) => C a b
-
-      instance C a b' => G (Maybe a)
-      instance C a b  => C (Maybe a) a
-      instance L (Maybe a) a
-
-    When solving the superclasses of the (C (Maybe a) a) instance, we get
-      [G] C a b, and hence by superclasses, [G] G a, [G] L a b
-      [W] G (Maybe a)
-    Use the instance decl to get
-      [W] C a beta
-    Generate its superclass
-      [W] L a beta.  Now using fundeps, combine with [G] L a b to get
-      [W] beta ~ b
-    which is what we want.
-
-Note [Danger of adding superclasses during solving]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here's a serious, but now out-dated example, from #4497:
-
-   class Num (RealOf t) => Normed t
-   type family RealOf x
-
-Assume the generated wanted constraint is:
-   [W] RealOf e ~ e
-   [W] Normed e
-
-If we were to be adding the superclasses during simplification we'd get:
-   [W] RealOf e ~ e
-   [W] Normed e
-   [W] RealOf e ~ fuv
-   [W] Num fuv
-==>
-   e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv
-
-While looks exactly like our original constraint. If we add the
-superclass of (Normed fuv) again we'd loop.  By adding superclasses
-definitely only once, during canonicalisation, this situation can't
-happen.
-
-Note [Nested quantified constraint superclasses]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (typecheck/should_compile/T17202)
-
-  class C1 a
-  class (forall c. C1 c) => C2 a
-  class (forall b. (b ~ F a) => C2 a) => C3 a
-
-Elsewhere in the code, we get a [G] g1 :: C3 a. We expand its superclass
-to get [G] g2 :: (forall b. (b ~ F a) => C2 a). This constraint has a
-superclass, as well. But we now must be careful: we cannot just add
-(forall c. C1 c) as a Given, because we need to remember g2's context.
-That new constraint is Given only when forall b. (b ~ F a) is true.
-
-It's tempting to make the new Given be (forall b. (b ~ F a) => forall c. C1 c),
-but that's problematic, because it's nested, and ForAllPred is not capable
-of representing a nested quantified constraint. (We could change ForAllPred
-to allow this, but the solution in this Note is much more local and simpler.)
-
-So, we swizzle it around to get (forall b c. (b ~ F a) => C1 c).
-
-More generally, if we are expanding the superclasses of
-  g0 :: forall tvs. theta => cls tys
-and find a superclass constraint
-  forall sc_tvs. sc_theta => sc_inner_pred
-we must have a selector
-  sel_id :: forall cls_tvs. cls cls_tvs -> forall sc_tvs. sc_theta => sc_inner_pred
-and thus build
-  g_sc :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred
-  g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. \ sc_theta_ids.
-         sel_id tys (g0 tvs theta_ids) sc_tvs sc_theta_ids
-
-Actually, we cheat a bit by eta-reducing: note that sc_theta_ids are both the
-last bound variables and the last arguments. This avoids the need to produce
-the sc_theta_ids at all. So our final construction is
-
-  g_sc = /\ tvs. /\ sc_tvs. \ theta_ids.
-         sel_id tys (g0 tvs theta_ids) sc_tvs
-
-  -}
-
-makeSuperClasses :: [Ct] -> TcS [Ct]
--- Returns strict superclasses, transitively, see Note [The superclass story]
--- See Note [The superclass story]
--- The loop-breaking here follows Note [Expanding superclasses] in GHC.Tc.Utils.TcType
--- Specifically, for an incoming (C t) constraint, we return all of (C t)'s
---    superclasses, up to /and including/ the first repetition of C
---
--- Example:  class D a => C a
---           class C [a] => D a
--- makeSuperClasses (C x) will return (D x, C [x])
---
--- NB: the incoming constraints have had their cc_pend_sc flag already
---     flipped to False, by isPendingScDict, so we are /obliged/ to at
---     least produce the immediate superclasses
-makeSuperClasses cts = concatMapM go cts
-  where
-    go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
-      = mkStrictSuperClasses ev [] [] cls tys
-    go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev }))
-      = assertPpr (isClassPred pred) (ppr pred) $  -- The cts should all have
-                                                   -- class pred heads
-        mkStrictSuperClasses ev tvs theta cls tys
-      where
-        (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)
-    go ct = pprPanic "makeSuperClasses" (ppr ct)
-
-mkStrictSuperClasses
-    :: CtEvidence
-    -> [TyVar] -> ThetaType  -- These two args are non-empty only when taking
-                             -- superclasses of a /quantified/ constraint
-    -> Class -> [Type] -> TcS [Ct]
--- Return constraints for the strict superclasses of
---   ev :: forall as. theta => cls tys
-mkStrictSuperClasses ev tvs theta cls tys
-  = mk_strict_superclasses (unitNameSet (className cls))
-                           ev tvs theta cls tys
-
-mk_strict_superclasses :: NameSet -> CtEvidence
-                       -> [TyVar] -> ThetaType
-                       -> Class -> [Type] -> TcS [Ct]
--- Always return the immediate superclasses of (cls tys);
--- and expand their superclasses, provided none of them are in rec_clss
--- nor are repeated
-mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
-                       tvs theta cls tys
-  = concatMapM do_one_given $
-    classSCSelIds cls
-  where
-    dict_ids  = mkTemplateLocals theta
-    size      = sizeTypes tys
-
-    do_one_given sel_id
-      | isUnliftedType sc_pred
-         -- NB: class superclasses are never representation-polymorphic,
-         -- so isUnliftedType is OK here.
-      , not (null tvs && null theta)
-      = -- See Note [Equality superclasses in quantified constraints]
-        return []
-      | otherwise
-      = do { given_ev <- newGivenEvVar sc_loc $
-                         mk_given_desc sel_id sc_pred
-           ; mk_superclasses rec_clss given_ev tvs theta sc_pred }
-      where
-        sc_pred = classMethodInstTy sel_id tys
-
-      -- See Note [Nested quantified constraint superclasses]
-    mk_given_desc :: Id -> PredType -> (PredType, EvTerm)
-    mk_given_desc sel_id sc_pred
-      = (swizzled_pred, swizzled_evterm)
-      where
-        (sc_tvs, sc_rho)          = splitForAllTyCoVars sc_pred
-        (sc_theta, sc_inner_pred) = splitFunTys sc_rho
-
-        all_tvs       = tvs `chkAppend` sc_tvs
-        all_theta     = theta `chkAppend` (map scaledThing sc_theta)
-        swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred
-
-        -- evar :: forall tvs. theta => cls tys
-        -- sel_id :: forall cls_tvs. cls cls_tvs
-        --                        -> forall sc_tvs. sc_theta => sc_inner_pred
-        -- swizzled_evterm :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred
-        swizzled_evterm = EvExpr $
-          mkLams all_tvs $
-          mkLams dict_ids $
-          Var sel_id
-            `mkTyApps` tys
-            `App` (evId evar `mkVarApps` (tvs ++ dict_ids))
-            `mkVarApps` sc_tvs
-
-    sc_loc
-       | isCTupleClass cls
-       = loc   -- For tuple predicates, just take them apart, without
-               -- adding their (large) size into the chain.  When we
-               -- get down to a base predicate, we'll include its size.
-               -- #10335
-
-       |  isEqPredClass cls
-       || cls `hasKey` coercibleTyConKey
-       = loc   -- The only superclasses of ~, ~~, and Coercible are primitive
-               -- equalities, and they don't use the InstSCOrigin mechanism
-               -- detailed in Note [Solving superclass constraints] in
-               -- GHC.Tc.TyCl.Instance. Skip for a tiny performance win.
-
-         -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance
-         -- for explanation of InstSCOrigin and Note [Replacement vs keeping] in
-         -- GHC.Tc.Solver.Interact for why we need OtherSCOrigin and depths
-       | otherwise
-       = loc { ctl_origin = new_orig }
-       where
-         new_orig = case ctLocOrigin loc of
-            -- these cases are when we have something that's already a superclass constraint
-           InstSCOrigin  sc_depth n  -> InstSCOrigin  (sc_depth + 1) (n `max` size)
-           OtherSCOrigin sc_depth si -> OtherSCOrigin (sc_depth + 1) si
-
-            -- these cases do not already have a superclass constraint: depth starts at 1
-           GivenOrigin InstSkol      -> InstSCOrigin  1 size
-           GivenOrigin other_skol    -> OtherSCOrigin 1 other_skol
-
-           other_orig                -> pprPanic "Given constraint without given origin" $
-                                        ppr evar $$ ppr other_orig
-
-mk_strict_superclasses rec_clss ev tvs theta cls tys
-  | all noFreeVarsOfType tys
-  = return [] -- Wanteds with no variables yield no superclass constraints.
-              -- See Note [Improvement from Ground Wanteds]
-
-  | otherwise -- Wanted case, just add Wanted superclasses
-              -- that can lead to improvement.
-  = assertPpr (null tvs && null theta) (ppr tvs $$ ppr theta) $
-    concatMapM do_one (immSuperClasses cls tys)
-  where
-    loc = ctEvLoc ev `updateCtLocOrigin` WantedSuperclassOrigin (ctEvPred ev)
-
-    do_one sc_pred
-      = do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred)
-           ; sc_ev <- newWantedNC loc (ctEvRewriters ev) sc_pred
-           ; mk_superclasses rec_clss sc_ev [] [] sc_pred }
-
-{- Note [Improvement from Ground Wanteds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose class C b a => D a b
-and consider
-  [W] D Int Bool
-Is there any point in emitting [W] C Bool Int?  No!  The only point of
-emitting superclass constraints for W constraints is to get
-improvement, extra unifications that result from functional
-dependencies.  See Note [Why adding superclasses can help] above.
-
-But no variables means no improvement; case closed.
--}
-
-mk_superclasses :: NameSet -> CtEvidence
-                -> [TyVar] -> ThetaType -> PredType -> TcS [Ct]
--- Return this constraint, plus its superclasses, if any
-mk_superclasses rec_clss ev tvs theta pred
-  | ClassPred cls tys <- classifyPredType pred
-  = mk_superclasses_of rec_clss ev tvs theta cls tys
-
-  | otherwise   -- Superclass is not a class predicate
-  = return [mkNonCanonical ev]
-
-mk_superclasses_of :: NameSet -> CtEvidence
-                   -> [TyVar] -> ThetaType -> Class -> [Type]
-                   -> TcS [Ct]
--- Always return this class constraint,
--- and expand its superclasses
-mk_superclasses_of rec_clss ev tvs theta cls tys
-  | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)
-                    ; return [this_ct] }  -- cc_pend_sc of this_ct = True
-  | otherwise  = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys
-                                                          , ppr (isCTupleClass cls)
-                                                          , ppr rec_clss
-                                                          ])
-                    ; sc_cts <- mk_strict_superclasses rec_clss' ev tvs theta cls tys
-                    ; return (this_ct : sc_cts) }
-                                   -- cc_pend_sc of this_ct = False
-  where
-    cls_nm     = className cls
-    loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss
-                 -- Tuples never contribute to recursion, and can be nested
-    rec_clss'  = rec_clss `extendNameSet` cls_nm
-
-    this_ct | null tvs, null theta
-            = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys
-                       , cc_pend_sc = loop_found }
-                 -- NB: If there is a loop, we cut off, so we have not
-                 --     added the superclasses, hence cc_pend_sc = True
-            | otherwise
-            = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys
-                             , qci_ev = ev
-                             , qci_pend_sc = loop_found })
-
-
-{- Note [Equality superclasses in quantified constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#15359, #15593, #15625)
-  f :: (forall a. theta => a ~ b) => stuff
-
-It's a bit odd to have a local, quantified constraint for `(a~b)`,
-but some people want such a thing (see the tickets). And for
-Coercible it is definitely useful
-  f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q)))
-                 => stuff
-
-Moreover it's not hard to arrange; we just need to look up /equality/
-constraints in the quantified-constraint environment, which we do in
-GHC.Tc.Solver.Interact.doTopReactOther.
-
-There is a wrinkle though, in the case where 'theta' is empty, so
-we have
-  f :: (forall a. a~b) => stuff
-
-Now, potentially, the superclass machinery kicks in, in
-makeSuperClasses, giving us a a second quantified constraint
-       (forall a. a ~# b)
-BUT this is an unboxed value!  And nothing has prepared us for
-dictionary "functions" that are unboxed.  Actually it does just
-about work, but the simplifier ends up with stuff like
-   case (/\a. eq_sel d) of df -> ...(df @Int)...
-and fails to simplify that any further.  And it doesn't satisfy
-isPredTy any more.
-
-So for now we simply decline to take superclasses in the quantified
-case.  Instead we have a special case in GHC.Tc.Solver.Interact.doTopReactOther,
-which looks for primitive equalities specially in the quantified
-constraints.
-
-See also Note [Evidence for quantified constraints] in GHC.Core.Predicate.
-
-
-************************************************************************
-*                                                                      *
-*                      Irreducibles canonicalization
-*                                                                      *
-************************************************************************
--}
-
-canIrred :: CtEvidence -> TcS (StopOrContinue Ct)
--- Precondition: ty not a tuple and no other evidence form
-canIrred ev
-  = do { let pred = ctEvPred ev
-       ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)
-       ; (redn, rewriters) <- rewrite ev pred
-       ; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev ->
-
-    do { -- Re-classify, in case rewriting has improved its shape
-         -- Code is like the canNC, except
-         -- that the IrredPred branch stops work
-       ; case classifyPredType (ctEvPred new_ev) of
-           ClassPred cls tys     -> canClassNC new_ev cls tys
-           EqPred eq_rel ty1 ty2 -> -- IrredPreds have kind Constraint, so
-                                    -- cannot become EqPreds
-                                    pprPanic "canIrred: EqPred"
-                                      (ppr ev $$ ppr eq_rel $$ ppr ty1 $$ ppr ty2)
-           ForAllPred tvs th p   -> -- this is highly suspect; Quick Look
-                                    -- should never leave a meta-var filled
-                                    -- in with a polytype. This is #18987.
-                                    do traceTcS "canEvNC:forall" (ppr pred)
-                                       canForAllNC ev tvs th p
-           IrredPred {}          -> continueWith $
-                                    mkIrredCt IrredShapeReason new_ev } }
-
-{- *********************************************************************
-*                                                                      *
-*                      Quantified predicates
-*                                                                      *
-********************************************************************* -}
-
-{- Note [Quantified constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The -XQuantifiedConstraints extension allows type-class contexts like this:
-
-  data Rose f x = Rose x (f (Rose f x))
-
-  instance (Eq a, forall b. Eq b => Eq (f b))
-        => Eq (Rose f a)  where
-    (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2
-
-Note the (forall b. Eq b => Eq (f b)) in the instance contexts.
-This quantified constraint is needed to solve the
- [W] (Eq (f (Rose f x)))
-constraint which arises form the (==) definition.
-
-The wiki page is
-  https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints
-which in turn contains a link to the GHC Proposal where the change
-is specified, and a Haskell Symposium paper about it.
-
-We implement two main extensions to the design in the paper:
-
- 1. We allow a variable in the instance head, e.g.
-      f :: forall m a. (forall b. m b) => D (m a)
-    Notice the 'm' in the head of the quantified constraint, not
-    a class.
-
- 2. We support superclasses to quantified constraints.
-    For example (contrived):
-      f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool
-      f x y = x==y
-    Here we need (Eq (m a)); but the quantified constraint deals only
-    with Ord.  But we can make it work by using its superclass.
-
-Here are the moving parts
-  * Language extension {-# LANGUAGE QuantifiedConstraints #-}
-    and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension
-
-  * A new form of evidence, EvDFun, that is used to discharge
-    such wanted constraints
-
-  * checkValidType gets some changes to accept forall-constraints
-    only in the right places.
-
-  * Predicate.Pred gets a new constructor ForAllPred, and
-    and classifyPredType analyses a PredType to decompose
-    the new forall-constraints
-
-  * GHC.Tc.Solver.Monad.InertCans gets an extra field, inert_insts,
-    which holds all the Given forall-constraints.  In effect,
-    such Given constraints are like local instance decls.
-
-  * When trying to solve a class constraint, via
-    GHC.Tc.Solver.Interact.matchInstEnv, use the InstEnv from inert_insts
-    so that we include the local Given forall-constraints
-    in the lookup.  (See GHC.Tc.Solver.Monad.getInstEnvs.)
-
-  * GHC.Tc.Solver.Canonical.canForAll deals with solving a
-    forall-constraint.  See
-       Note [Solving a Wanted forall-constraint]
-
-  * We augment the kick-out code to kick out an inert
-    forall constraint if it can be rewritten by a new
-    type equality; see GHC.Tc.Solver.Monad.kick_out_rewritable
-
-Note that a quantified constraint is never /inferred/
-(by GHC.Tc.Solver.simplifyInfer).  A function can only have a
-quantified constraint in its type if it is given an explicit
-type signature.
-
--}
-
-canForAllNC :: CtEvidence -> [TyVar] -> TcThetaType -> TcPredType
-            -> TcS (StopOrContinue Ct)
-canForAllNC ev tvs theta pred
-  | isGiven ev  -- See Note [Eagerly expand given superclasses]
-  , Just (cls, tys) <- cls_pred_tys_maybe
-  = do { sc_cts <- mkStrictSuperClasses ev tvs theta cls tys
-       ; emitWork sc_cts
-       ; canForAll ev False }
-
-  | otherwise
-  = canForAll ev (isJust cls_pred_tys_maybe)
-
-  where
-    cls_pred_tys_maybe = getClassPredTys_maybe pred
-
-canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct)
--- We have a constraint (forall as. blah => C tys)
-canForAll ev pend_sc
-  = do { -- First rewrite it to apply the current substitution
-         let pred = ctEvPred ev
-       ; (redn, rewriters) <- rewrite ev pred
-       ; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev ->
-
-    do { -- Now decompose into its pieces and solve it
-         -- (It takes a lot less code to rewrite before decomposing.)
-       ; case classifyPredType (ctEvPred new_ev) of
-           ForAllPred tvs theta pred
-              -> solveForAll new_ev tvs theta pred pend_sc
-           _  -> pprPanic "canForAll" (ppr new_ev)
-    } }
-
-solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool
-            -> TcS (StopOrContinue Ct)
-solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc })
-            tvs theta pred _pend_sc
-  = -- See Note [Solving a Wanted forall-constraint]
-    setLclEnv (ctLocEnv loc) $
-    -- This setLclEnv is important: the emitImplicationTcS uses that
-    -- TcLclEnv for the implication, and that in turn sets the location
-    -- for the Givens when solving the constraint (#21006)
-    do { skol_info <- mkSkolemInfo QuantCtxtSkol
-       ; let empty_subst = mkEmptySubst $ mkInScopeSet $
-                           tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs
-       ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs
-       ; given_ev_vars <- mapM newEvVar (substTheta subst theta)
-
-       ; (lvl, (w_id, wanteds))
-             <- pushLevelNoWorkList (ppr skol_info) $
-                do { wanted_ev <- newWantedEvVarNC loc rewriters $
-                                  substTy subst pred
-                   ; return ( ctEvEvId wanted_ev
-                            , unitBag (mkNonCanonical wanted_ev)) }
-
-      ; ev_binds <- emitImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs
-                                       given_ev_vars wanteds
-
-      ; setWantedEvTerm dest $
-        EvFun { et_tvs = skol_tvs, et_given = given_ev_vars
-              , et_binds = ev_binds, et_body = w_id }
-
-      ; stopWith ev "Wanted forall-constraint" }
-
- -- See Note [Solving a Given forall-constraint]
-solveForAll ev@(CtGiven {}) tvs _theta pred pend_sc
-  = do { addInertForAll qci
-       ; stopWith ev "Given forall-constraint" }
-  where
-    qci = QCI { qci_ev = ev, qci_tvs = tvs
-              , qci_pred = pred, qci_pend_sc = pend_sc }
-
-{- Note [Solving a Wanted forall-constraint]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Solving a wanted forall (quantified) constraint
-  [W] df :: forall ab. (Eq a, Ord b) => C x a b
-is delightfully easy.   Just build an implication constraint
-    forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a
-and discharge df thus:
-    df = /\ab. \g1 g2. let <binds> in d
-where <binds> is filled in by solving the implication constraint.
-All the machinery is to hand; there is little to do.
-
-Note [Solving a Given forall-constraint]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For a Given constraint
-  [G] df :: forall ab. (Eq a, Ord b) => C x a b
-we just add it to TcS's local InstEnv of known instances,
-via addInertForall.  Then, if we look up (C x Int Bool), say,
-we'll find a match in the InstEnv.
-
-************************************************************************
-*                                                                      *
-*        Equalities
-*                                                                      *
-************************************************************************
-
-Note [Canonicalising equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In order to canonicalise an equality, we look at the structure of the
-two types at hand, looking for similarities. A difficulty is that the
-types may look dissimilar before rewriting but similar after rewriting.
-However, we don't just want to jump in and rewrite right away, because
-this might be wasted effort. So, after looking for similarities and failing,
-we rewrite and then try again. Of course, we don't want to loop, so we
-track whether or not we've already rewritten.
-
-It is conceivable to do a better job at tracking whether or not a type
-is rewritten, but this is left as future work. (Mar '15)
-
-Note [Decomposing FunTy]
-~~~~~~~~~~~~~~~~~~~~~~~~
-can_eq_nc' may attempt to decompose a FunTy that is un-zonked.  This
-means that we may very well have a FunTy containing a type of some
-unknown kind. For instance, we may have,
-
-    FunTy (a :: k) Int
-
-Where k is a unification variable. So the calls to splitRuntimeRep_maybe may
-fail (returning Nothing).  In that case we'll fall through, zonk, and try again.
-Zonking should fill the variable k, meaning that decomposition will succeed the
-second time around.
-
-Also note that we require the FunTyFlag to match.  This will stop
-us decomposing
-   (Int -> Bool)  ~  (Show a => blah)
-It's as if we treat (->) and (=>) as different type constructors, which
-indeed they are!
--}
-
-canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct)
-canEqNC ev eq_rel ty1 ty2
-  = do { result <- zonk_eq_types ty1 ty2
-       ; case result of
-           Right ty              -> canEqReflexive ev eq_rel ty
-           Left (Pair ty1' ty2') -> can_eq_nc False ev' eq_rel ty1' ty1' ty2' ty2'
-             where
-               ev' | debugIsOn = setCtEvPredType ev $
-                                 mkPrimEqPredRole (eqRelRole eq_rel) ty1' ty2'
-                   | otherwise = ev
-                   -- ev': satisfy the precondition of can_eq_nc
-       }
-
-can_eq_nc
-   :: Bool            -- True => both types are rewritten
-   -> CtEvidence
-   -> EqRel
-   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp
-   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp
-   -> TcS (StopOrContinue Ct)
--- Precondition: in DEBUG mode, the `ctev_pred` of `ev` is (ps_ty1 ~# ps_ty2),
---               without zonking
--- This precondition is needed (only in DEBUG) to satisfy the assertions
---   in mkSelCo, called in canDecomposableTyConAppOK and canDecomposableFunTy
-
-can_eq_nc rewritten ev eq_rel ty1 ps_ty1 ty2 ps_ty2
-  = do { traceTcS "can_eq_nc" $
-         vcat [ ppr rewritten, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ]
-       ; rdr_env <- getGlobalRdrEnvTcS
-       ; fam_insts <- getFamInstEnvs
-       ; can_eq_nc' rewritten rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 }
-
-can_eq_nc'
-   :: Bool           -- True => both input types are rewritten
-   -> GlobalRdrEnv   -- needed to see which newtypes are in scope
-   -> FamInstEnvs    -- needed to unwrap data instances
-   -> CtEvidence
-   -> EqRel
-   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp
-   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp
-   -> TcS (StopOrContinue Ct)
-
--- See Note [Comparing nullary type synonyms] in GHC.Core.Type.
-can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2
-  | tc1 == tc2
-  = canEqReflexive ev eq_rel ty1
-
--- Expand synonyms first; see Note [Type synonyms and canonicalization]
-can_eq_nc' rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
-  | Just ty1' <- coreView ty1 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2  ps_ty2
-  | Just ty2' <- coreView ty2 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1  ps_ty1 ty2' ps_ty2
-
--- need to check for reflexivity in the ReprEq case.
--- See Note [Eager reflexivity check]
--- Check only when rewritten because the zonk_eq_types check in canEqNC takes
--- care of the non-rewritten case.
-can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _
-  | ty1 `tcEqType` ty2
-  = canEqReflexive ev ReprEq ty1
-
--- When working with ReprEq, unwrap newtypes.
--- See Note [Unwrap newtypes first]
--- This must be above the TyVarTy case, in order to guarantee (TyEq:N)
-can_eq_nc' _rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
-  | ReprEq <- eq_rel
-  , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1
-  = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2
-
-  | ReprEq <- eq_rel
-  , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2
-  = can_eq_newtype_nc ev IsSwapped ty2 stuff2 ty1 ps_ty1
-
--- Then, get rid of casts
-can_eq_nc' rewritten _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2
-  | isNothing (canEqLHS_maybe ty2)  -- See (3) in Note [Equalities with incompatible kinds]
-  = canEqCast rewritten ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2
-can_eq_nc' rewritten _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _
-  | isNothing (canEqLHS_maybe ty1)  -- See (3) in Note [Equalities with incompatible kinds]
-  = canEqCast rewritten ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1
-
-----------------------
--- Otherwise try to decompose
-----------------------
-
--- Literals
-can_eq_nc' _rewritten _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
- | l1 == l2
-  = do { setEvBindIfWanted ev (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1)
-       ; stopWith ev "Equal LitTy" }
-
--- Decompose FunTy: (s -> t) and (c => t)
--- NB: don't decompose (Int -> blah) ~ (Show a => blah)
-can_eq_nc' _rewritten _rdr_env _envs ev eq_rel
-           (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ps_ty1
-           (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ps_ty2
-  | af1 == af2  -- See Note [Decomposing FunTy]
-  = canDecomposableFunTy ev eq_rel af1 (am1,ty1a,ty1b) (am2,ty2a,ty2b)
-
--- Decompose type constructor applications
--- NB: we have expanded type synonyms already
-can_eq_nc' _rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _
-  | Just (tc1, tys1) <- tcSplitTyConApp_maybe ty1
-  , Just (tc2, tys2) <- tcSplitTyConApp_maybe ty2
-   -- we want to catch e.g. Maybe Int ~ (Int -> Int) here for better
-   -- error messages rather than decomposing into AppTys;
-   -- hence no direct match on TyConApp
-  , not (isTypeFamilyTyCon tc1)
-  , not (isTypeFamilyTyCon tc2)
-  = canTyConApp ev eq_rel tc1 tys1 tc2 tys2
-
-can_eq_nc' _rewritten _rdr_env _envs ev eq_rel
-           s1@(ForAllTy (Bndr _ vis1) _) _
-           s2@(ForAllTy (Bndr _ vis2) _) _
-  | vis1 `eqForAllVis` vis2 -- Note [ForAllTy and type equality]
-  = can_eq_nc_forall ev eq_rel s1 s2
-
--- See Note [Canonicalising type applications] about why we require rewritten types
--- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families
--- NB: Only decompose AppTy for nominal equality.
---     See Note [Decomposing AppTy equalities]
-can_eq_nc' True _rdr_env _envs ev NomEq ty1 _ ty2 _
-  | Just (t1, s1) <- tcSplitAppTy_maybe ty1
-  , Just (t2, s2) <- tcSplitAppTy_maybe ty2
-  = can_eq_app ev t1 s1 t2 s2
-
--------------------
--- Can't decompose.
--------------------
-
--- No similarity in type structure detected. Rewrite and try again.
-can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2
-  = do { (redn1@(Reduction _ xi1), rewriters1) <- rewrite ev ps_ty1
-       ; (redn2@(Reduction _ xi2), rewriters2) <- rewrite ev ps_ty2
-       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
-       ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }
-
-----------------------------
--- Look for a canonical LHS. See Note [Canonical LHS].
--- Only rewritten types end up below here.
-----------------------------
-
--- NB: pattern match on True: we want only rewritten types sent to canEqLHS
--- This means we've rewritten any variables and reduced any type family redexes
--- See also Note [No top-level newtypes on RHS of representational equalities]
-can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
-  | Just can_eq_lhs1 <- canEqLHS_maybe ty1
-  = canEqCanLHS ev eq_rel NotSwapped can_eq_lhs1 ps_ty1 ty2 ps_ty2
-
-  | Just can_eq_lhs2 <- canEqLHS_maybe ty2
-  = canEqCanLHS ev eq_rel IsSwapped can_eq_lhs2 ps_ty2 ty1 ps_ty1
-
-     -- If the type is TyConApp tc1 args1, then args1 really can't be less
-     -- than tyConArity tc1. It could be *more* than tyConArity, but then we
-     -- should have handled the case as an AppTy. That case only fires if
-     -- _both_ sides of the equality are AppTy-like... but if one side is
-     -- AppTy-like and the other isn't (and it also isn't a variable or
-     -- saturated type family application, both of which are handled by
-     -- can_eq_nc'), we're in a failure mode and can just fall through.
-
-----------------------------
--- Fall-through. Give up.
-----------------------------
-
--- We've rewritten and the types don't match. Give up.
-can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2
-  = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2)
-       ; case eq_rel of -- See Note [Unsolved equalities]
-            ReprEq -> continueWith (mkIrredCt ReprEqReason ev)
-            NomEq  -> continueWith (mkIrredCt ShapeMismatchReason ev) }
-          -- No need to call canEqFailure/canEqHardFailure because they
-          -- rewrite, and the types involved here are already rewritten
-
-{- Note [Unsolved equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we have an unsolved equality like
-  (a b ~R# Int)
-that is not necessarily insoluble!  Maybe 'a' will turn out to be a newtype.
-So we want to make it a potentially-soluble Irred not an insoluble one.
-Missing this point is what caused #15431
--}
-
----------------------------------
-can_eq_nc_forall :: CtEvidence -> EqRel
-                 -> Type -> Type    -- LHS and RHS
-                 -> TcS (StopOrContinue Ct)
--- (forall as. phi1) ~ (forall bs. phi2)
--- Check for length match of as, bs
--- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs]
--- But remember also to unify the kinds of as and bs
---  (this is the 'go' loop), and actually substitute phi2[as |> cos / bs]
--- Remember also that we might have forall z (a:z). blah
---  so we must proceed one binder at a time (#13879)
-
-can_eq_nc_forall ev eq_rel s1 s2
- | CtWanted { ctev_loc = loc, ctev_dest = orig_dest, ctev_rewriters = rewriters } <- ev
- = do { let free_tvs       = tyCoVarsOfTypes [s1,s2]
-            (bndrs1, phi1) = tcSplitForAllTyVarBinders s1
-            (bndrs2, phi2) = tcSplitForAllTyVarBinders s2
-      ; if not (equalLength bndrs1 bndrs2)
-        then do { traceTcS "Forall failure" $
-                     vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2
-                          , ppr (binderFlags bndrs1)
-                          , ppr (binderFlags bndrs2) ]
-                ; canEqHardFailure ev s1 s2 }
-        else
-   do { traceTcS "Creating implication for polytype equality" $ ppr ev
-      ; let empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs
-      ; skol_info <- mkSkolemInfo (UnifyForAllSkol phi1)
-      ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $
-                              binderVars bndrs1
-
-      ; let phi1' = substTy subst1 phi1
-
-            -- Unify the kinds, extend the substitution
-            go :: [TcTyVar] -> Subst -> [TyVarBinder]
-               -> TcS (TcCoercion, Cts)
-            go (skol_tv:skol_tvs) subst (bndr2:bndrs2)
-              = do { let tv2 = binderVar bndr2
-                   ; (kind_co, wanteds1) <- unify loc rewriters Nominal (tyVarKind skol_tv)
-                                                  (substTy subst (tyVarKind tv2))
-                   ; let subst' = extendTvSubstAndInScope subst tv2
-                                       (mkCastTy (mkTyVarTy skol_tv) kind_co)
-                         -- skol_tv is already in the in-scope set, but the
-                         -- free vars of kind_co are not; hence "...AndInScope"
-                   ; (co, wanteds2) <- go skol_tvs subst' bndrs2
-                   ; return ( mkForAllCo skol_tv kind_co co
-                            , wanteds1 `unionBags` wanteds2 ) }
-
-            -- Done: unify phi1 ~ phi2
-            go [] subst bndrs2
-              = assert (null bndrs2) $
-                unify loc rewriters (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)
-
-            go _ _ _ = panic "cna_eq_nc_forall"  -- case (s:ss) []
-
-            empty_subst2 = mkEmptySubst (getSubstInScope subst1)
-
-      ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $
-                                    go skol_tvs empty_subst2 bndrs2
-      ; emitTvImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs wanteds
-
-      ; setWantedEq orig_dest all_co
-      ; stopWith ev "Deferred polytype equality" } }
-
- | otherwise
- = do { traceTcS "Omitting decomposition of given polytype equality" $
-        pprEq s1 s2    -- See Note [Do not decompose Given polytype equalities]
-      ; stopWith ev "Discard given polytype equality" }
-
- where
-    unify :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts)
-    -- This version returns the wanted constraint rather
-    -- than putting it in the work list
-    unify loc rewriters role ty1 ty2
-      | ty1 `tcEqType` ty2
-      = return (mkReflCo role ty1, emptyBag)
-      | otherwise
-      = do { (wanted, co) <- newWantedEq loc rewriters role ty1 ty2
-           ; return (co, unitBag (mkNonCanonical wanted)) }
-
----------------------------------
--- | Compare types for equality, while zonking as necessary. Gives up
--- as soon as it finds that two types are not equal.
--- This is quite handy when some unification has made two
--- types in an inert Wanted to be equal. We can discover the equality without
--- rewriting, which is sometimes very expensive (in the case of type functions).
--- In particular, this function makes a ~20% improvement in test case
--- perf/compiler/T5030.
---
--- Returns either the (partially zonked) types in the case of
--- inequality, or the one type in the case of equality. canEqReflexive is
--- a good next step in the 'Right' case. Returning 'Left' is always safe.
---
--- NB: This does *not* look through type synonyms. In fact, it treats type
--- synonyms as rigid constructors. In the future, it might be convenient
--- to look at only those arguments of type synonyms that actually appear
--- in the synonym RHS. But we're not there yet.
-zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType)
-zonk_eq_types = go
-  where
-    go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2
-    go (TyVarTy tv1) ty2           = tyvar NotSwapped tv1 ty2
-    go ty1 (TyVarTy tv2)           = tyvar IsSwapped  tv2 ty1
-
-    -- We handle FunTys explicitly here despite the fact that they could also be
-    -- treated as an application. Why? Well, for one it's cheaper to just look
-    -- at two types (the argument and result types) than four (the argument,
-    -- result, and their RuntimeReps). Also, we haven't completely zonked yet,
-    -- so we may run into an unzonked type variable while trying to compute the
-    -- RuntimeReps of the argument and result types. This can be observed in
-    -- testcase tc269.
-    go (FunTy af1 w1 arg1 res1) (FunTy af2 w2 arg2 res2)
-      | af1 == af2
-      , eqType w1 w2
-      = do { res_a <- go arg1 arg2
-           ; res_b <- go res1 res2
-           ; return $ combine_rev (FunTy af1 w1) res_b res_a }
-
-    go ty1@(FunTy {}) ty2 = bale_out ty1 ty2
-    go ty1 ty2@(FunTy {}) = bale_out ty1 ty2
-
-    go ty1 ty2
-      | Just (tc1, tys1) <- splitTyConAppNoView_maybe ty1
-      , Just (tc2, tys2) <- splitTyConAppNoView_maybe ty2
-      = if tc1 == tc2 && tys1 `equalLength` tys2
-          -- Crucial to check for equal-length args, because
-          -- we cannot assume that the two args to 'go' have
-          -- the same kind.  E.g go (Proxy *      (Maybe Int))
-          --                        (Proxy (*->*) Maybe)
-          -- We'll call (go (Maybe Int) Maybe)
-          -- See #13083
-        then tycon tc1 tys1 tys2
-        else bale_out ty1 ty2
-
-    go ty1 ty2
-      | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1
-      , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2
-      = do { res_a <- go ty1a ty2a
-           ; res_b <- go ty1b ty2b
-           ; return $ combine_rev mkAppTy res_b res_a }
-
-    go ty1@(LitTy lit1) (LitTy lit2)
-      | lit1 == lit2
-      = return (Right ty1)
-
-    go ty1 ty2 = bale_out ty1 ty2
-      -- We don't handle more complex forms here
-
-    bale_out ty1 ty2 = return $ Left (Pair ty1 ty2)
-
-    tyvar :: SwapFlag -> TcTyVar -> TcType
-          -> TcS (Either (Pair TcType) TcType)
-      -- Try to do as little as possible, as anything we do here is redundant
-      -- with rewriting. In particular, no need to zonk kinds. That's why
-      -- we don't use the already-defined zonking functions
-    tyvar swapped tv ty
-      = case tcTyVarDetails tv of
-          MetaTv { mtv_ref = ref }
-            -> do { cts <- readTcRef ref
-                  ; case cts of
-                      Flexi        -> give_up
-                      Indirect ty' -> do { trace_indirect tv ty'
-                                         ; unSwap swapped go ty' ty } }
-          _ -> give_up
-      where
-        give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty
-
-    tyvar_tyvar tv1 tv2
-      | tv1 == tv2 = return (Right (mkTyVarTy tv1))
-      | otherwise  = do { (ty1', progress1) <- quick_zonk tv1
-                        ; (ty2', progress2) <- quick_zonk tv2
-                        ; if progress1 || progress2
-                          then go ty1' ty2'
-                          else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) }
-
-    trace_indirect tv ty
-       = traceTcS "Following filled tyvar (zonk_eq_types)"
-                  (ppr tv <+> equals <+> ppr ty)
-
-    quick_zonk tv = case tcTyVarDetails tv of
-      MetaTv { mtv_ref = ref }
-        -> do { cts <- readTcRef ref
-              ; case cts of
-                  Flexi        -> return (TyVarTy tv, False)
-                  Indirect ty' -> do { trace_indirect tv ty'
-                                     ; return (ty', True) } }
-      _ -> return (TyVarTy tv, False)
-
-      -- This happens for type families, too. But recall that failure
-      -- here just means to try harder, so it's OK if the type function
-      -- isn't injective.
-    tycon :: TyCon -> [TcType] -> [TcType]
-          -> TcS (Either (Pair TcType) TcType)
-    tycon tc tys1 tys2
-      = do { results <- zipWithM go tys1 tys2
-           ; return $ case combine_results results of
-               Left tys  -> Left (mkTyConApp tc <$> tys)
-               Right tys -> Right (mkTyConApp tc tys) }
-
-    combine_results :: [Either (Pair TcType) TcType]
-                    -> Either (Pair [TcType]) [TcType]
-    combine_results = bimap (fmap reverse) reverse .
-                      foldl' (combine_rev (:)) (Right [])
-
-      -- combine (in reverse) a new result onto an already-combined result
-    combine_rev :: (a -> b -> c)
-                -> Either (Pair b) b
-                -> Either (Pair a) a
-                -> Either (Pair c) c
-    combine_rev f (Left list) (Left elt) = Left (f <$> elt     <*> list)
-    combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list)
-    combine_rev f (Right tys) (Left elt) = Left (f <$> elt     <*> pure tys)
-    combine_rev f (Right tys) (Right ty) = Right (f ty tys)
-
-{- See Note [Unwrap newtypes first]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See also Note [Decomposing newtype equalities]
-
-Consider
-  newtype N m a = MkN (m a)
-Then N will get a conservative, Nominal role for its second parameter 'a',
-because it appears as an argument to the unknown 'm'. Now consider
-  [W] N Maybe a  ~R#  N Maybe b
-
-If we decompose, we'll get
-  [W] a ~N# b
-
-But if instead we unwrap we'll get
-  [W] Maybe a ~R# Maybe b
-which in turn gives us
-  [W] a ~R# b
-which is easier to satisfy.
-
-Bottom line: unwrap newtypes before decomposing them!
-c.f. #9123 comment:52,53 for a compelling example.
-
-Note [Newtypes can blow the stack]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-
-  newtype X = MkX (Int -> X)
-  newtype Y = MkY (Int -> Y)
-
-and now wish to prove
-
-  [W] X ~R Y
-
-This Wanted will loop, expanding out the newtypes ever deeper looking
-for a solid match or a solid discrepancy. Indeed, there is something
-appropriate to this looping, because X and Y *do* have the same representation,
-in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized
-coercion will ever witness it. This loop won't actually cause GHC to hang,
-though, because we check our depth when unwrapping newtypes.
-
-Note [Eager reflexivity check]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-
-  newtype X = MkX (Int -> X)
-
-and
-
-  [W] X ~R X
-
-Naively, we would start unwrapping X and end up in a loop. Instead,
-we do this eager reflexivity check. This is necessary only for representational
-equality because the rewriter technology deals with the similar case
-(recursive type families) for nominal equality.
-
-Note that this check does not catch all cases, but it will catch the cases
-we're most worried about, types like X above that are actually inhabited.
-
-Here's another place where this reflexivity check is key:
-Consider trying to prove (f a) ~R (f a). The AppTys in there can't
-be decomposed, because representational equality isn't congruent with respect
-to AppTy. So, when canonicalising the equality above, we get stuck and
-would normally produce a CIrredCan. However, we really do want to
-be able to solve (f a) ~R (f a). So, in the representational case only,
-we do a reflexivity check.
-
-(This would be sound in the nominal case, but unnecessary, and I [Richard
-E.] am worried that it would slow down the common case.)
--}
-
-------------------------
--- | We're able to unwrap a newtype. Update the bits accordingly.
-can_eq_newtype_nc :: CtEvidence           -- ^ :: ty1 ~ ty2
-                  -> SwapFlag
-                  -> TcType                                    -- ^ ty1
-                  -> ((Bag GlobalRdrElt, TcCoercion), TcType)  -- ^ :: ty1 ~ ty1'
-                  -> TcType               -- ^ ty2
-                  -> TcType               -- ^ ty2, with type synonyms
-                  -> TcS (StopOrContinue Ct)
-can_eq_newtype_nc ev swapped ty1 ((gres, co1), ty1') ty2 ps_ty2
-  = do { traceTcS "can_eq_newtype_nc" $
-         vcat [ ppr ev, ppr swapped, ppr co1, ppr gres, ppr ty1', ppr ty2 ]
-
-         -- check for blowing our stack:
-         -- See Note [Newtypes can blow the stack]
-       ; checkReductionDepth (ctEvLoc ev) ty1
-
-         -- Next, we record uses of newtype constructors, since coercing
-         -- through newtypes is tantamount to using their constructors.
-       ; addUsedGREs gre_list
-         -- If a newtype constructor was imported, don't warn about not
-         -- importing it...
-       ; traverse_ keepAlive $ map greMangledName gre_list
-         -- ...and similarly, if a newtype constructor was defined in the same
-         -- module, don't warn about it being unused.
-         -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils.
-
-       ; let redn1 = mkReduction co1 ty1'
-
-       ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
-                     redn1
-                     (mkReflRedn Representational ps_ty2)
-       ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }
-  where
-    gre_list = bagToList gres
-
----------
--- ^ Decompose a type application.
--- All input types must be rewritten. See Note [Canonicalising type applications]
--- Nominal equality only!
-can_eq_app :: CtEvidence       -- :: s1 t1 ~N s2 t2
-           -> Xi -> Xi         -- s1 t1
-           -> Xi -> Xi         -- s2 t2
-           -> TcS (StopOrContinue Ct)
-
--- AppTys only decompose for nominal equality, so this case just leads
--- to an irreducible constraint; see typecheck/should_compile/T10494
--- See Note [Decomposing AppTy equalities]
-can_eq_app ev s1 t1 s2 t2
-  | CtWanted { ctev_dest = dest, ctev_rewriters = rewriters } <- ev
-  = do { co_s <- unifyWanted rewriters loc Nominal s1 s2
-       ; let arg_loc
-               | isNextArgVisible s1 = loc
-               | otherwise           = updateCtLocOrigin loc toInvisibleOrigin
-       ; co_t <- unifyWanted rewriters arg_loc Nominal t1 t2
-       ; let co = mkAppCo co_s co_t
-       ; setWantedEq dest co
-       ; stopWith ev "Decomposed [W] AppTy" }
-
-    -- If there is a ForAll/(->) mismatch, the use of the Left coercion
-    -- below is ill-typed, potentially leading to a panic in splitTyConApp
-    -- Test case: typecheck/should_run/Typeable1
-    -- We could also include this mismatch check above (for W and D), but it's slow
-    -- and we'll get a better error message not doing it
-  | s1k `mismatches` s2k
-  = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2)
-
-  | CtGiven { ctev_evar = evar } <- ev
-  = do { let co   = mkCoVarCo evar
-             co_s = mkLRCo CLeft  co
-             co_t = mkLRCo CRight co
-       ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2
-                                     , evCoercion co_s )
-       ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2
-                                     , evCoercion co_t )
-       ; emitWorkNC [evar_t]
-       ; canEqNC evar_s NomEq s1 s2 }
-
-  where
-    loc = ctEvLoc ev
-
-    s1k = typeKind s1
-    s2k = typeKind s2
-
-    k1 `mismatches` k2
-      =  isForAllTy k1 && not (isForAllTy k2)
-      || not (isForAllTy k1) && isForAllTy k2
-
------------------------
--- | Break apart an equality over a casted type
--- looking like   (ty1 |> co1) ~ ty2   (modulo a swap-flag)
-canEqCast :: Bool         -- are both types rewritten?
-          -> CtEvidence
-          -> EqRel
-          -> SwapFlag
-          -> TcType -> Coercion   -- LHS (res. RHS), ty1 |> co1
-          -> TcType -> TcType     -- RHS (res. LHS), ty2 both normal and pretty
-          -> TcS (StopOrContinue Ct)
-canEqCast rewritten ev eq_rel swapped ty1 co1 ty2 ps_ty2
-  = do { traceTcS "Decomposing cast" (vcat [ ppr ev
-                                           , ppr ty1 <+> text "|>" <+> ppr co1
-                                           , ppr ps_ty2 ])
-       ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
-                      (mkGReflLeftRedn role ty1 co1)
-                      (mkReflRedn role ps_ty2)
-       ; can_eq_nc rewritten new_ev eq_rel ty1 ty1 ty2 ps_ty2 }
-  where
-    role = eqRelRole eq_rel
-
-------------------------
-canTyConApp :: CtEvidence -> EqRel
-            -> TyCon -> [TcType]
-            -> TyCon -> [TcType]
-            -> TcS (StopOrContinue Ct)
--- See Note [Decomposing TyConApp equalities]
--- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
--- Neither tc1 nor tc2 is a saturated funTyCon, nor a type family
--- But they can be data families.
-canTyConApp ev eq_rel tc1 tys1 tc2 tys2
-  | tc1 == tc2
-  , tys1 `equalLength` tys2
-  = do { inerts <- getTcSInerts
-       ; if can_decompose inerts
-         then canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2
-         else canEqFailure ev eq_rel ty1 ty2 }
-
-  -- See Note [Skolem abstract data] in GHC.Core.Tycon
-  | tyConSkolem tc1 || tyConSkolem tc2
-  = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2)
-       ; continueWith (mkIrredCt AbstractTyConReason ev) }
-
-  -- Fail straight away for better error messages
-  -- See Note [Use canEqFailure in canDecomposableTyConApp]
-  | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational &&
-                             isGenerativeTyCon tc2 Representational)
-  = canEqFailure ev eq_rel ty1 ty2
-
-  | otherwise
-  = canEqHardFailure ev ty1 ty2
-  where
-    -- Reconstruct the types for error messages. This would do
-    -- the wrong thing (from a pretty printing point of view)
-    -- for functions, because we've lost the FunTyFlag; but
-    -- in fact we never call canTyConApp on a saturated FunTyCon
-    ty1 = mkTyConApp tc1 tys1
-    ty2 = mkTyConApp tc2 tys2
-
-     -- See Note [Decomposing TyConApp equalities]
-     -- Note [Decomposing newtypes a bit more aggressively]
-    can_decompose inerts
-      =  isInjectiveTyCon tc1 (eqRelRole eq_rel)
-      || (assert (eq_rel == ReprEq) $
-          -- assert: isInjectiveTyCon is always True for Nominal except
-          --   for type synonyms/families, neither of which happen here
-          -- Moreover isInjectiveTyCon is True for Representational
-          --   for algebraic data types.  So we are down to newtypes
-          --   and data families.
-          ctEvFlavour ev == Wanted && noGivenIrreds inerts)
-
-{-
-Note [Use canEqFailure in canDecomposableTyConApp]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must use canEqFailure, not canEqHardFailure here, because there is
-the possibility of success if working with a representational equality.
-Here is one case:
-
-  type family TF a where TF Char = Bool
-  data family DF a
-  newtype instance DF Bool = MkDF Int
-
-Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet
-know `a`. This is *not* a hard failure, because we might soon learn
-that `a` is, in fact, Char, and then the equality succeeds.
-
-Here is another case:
-
-  [G] Age ~R Int
-
-where Age's constructor is not in scope. We don't want to report
-an "inaccessible code" error in the context of this Given!
-
-For example, see typecheck/should_compile/T10493, repeated here:
-
-  import Data.Ord (Down)  -- no constructor
-
-  foo :: Coercible (Down Int) Int => Down Int -> Int
-  foo = coerce
-
-That should compile, but only because we use canEqFailure and not
-canEqHardFailure.
-
-Note [Fast path when decomposing TyConApps]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we see (T s1 t1 ~ T s2 t2), then we can just decompose to
-  (s1 ~ s2, t1 ~ t2)
-and push those back into the work list.  But if
-  s1 = K k1    s2 = K k2
-then we will just decompose s1~s2, and it might be better to
-do so on the spot.  An important special case is where s1=s2,
-and we get just Refl.
-
-So canDecomposableTyConAppOK uses unifyWanted etc to short-cut that work.
-See also Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
-
-Note [Decomposing TyConApp equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-        [G/W] T ty1 ~r T ty2
-Can we decompose it, and replace it by
-        [G/W] ty1 ~r' ty2
-and if so what role is r'?  (In this Note, all the "~" are primitive
-equalities "~#", but I have dropped the noisy "#" symbols.)  Lots of
-background in the paper "Safe zero-cost coercions for Haskell".
-
-This Note covers the topic for
-  * Datatypes
-  * Newtypes
-  * Data families
-For the rest:
-  * Type synonyms: are always expanded
-  * Type families: see Note [Decomposing type family applications]
-  * AppTy:         see Note [Decomposing AppTy equalities].
-
----- Roles of the decomposed constraints ----
-For a start, the role r' will always be defined like this:
-  * If r=N then r' = N
-  * If r=R then r' = role of T's first argument
-
-For example:
-   data TR a = MkTR a       -- Role of T's first arg is Representational
-   data TN a = MkTN (F a)   -- Role of T's first arg is Nominal
-
-The function tyConRolesX :: Role -> TyCon -> [Role] gets the argument
-role r' for a TyCon T at role r.  E.g.
-   tyConRolesX Nominal          TR = [Nominal]
-   tyConRolesX Representational TR = [Representational]
-
----- Soundness and completeness ----
-For Givens, for /soundness/ of decomposition we need, forall ty1,ty2:
-    T ty1 ~r T ty2   ===>    ty1 ~r' ty2
-Here "===>" means "implies".  That is, given evidence for (co1 : T ty1 ~r T co2)
-we can produce evidence for (co2 : ty1 ~r' ty2).  But in the solver we
-/replace/ co1 with co2 in the inert set, and we don't want to lose any proofs
-thereby. So for /completeness/ of decomposition we also need the reverse:
-    ty1 ~r' ty2   ===>    T ty1 ~r T ty2
-
-For Wanteds, for /soundness/ of decomposition we need:
-    ty1 ~r' ty2   ===>    T ty1 ~r T ty2
-because if we do decompose we'll get evidence (co2 : ty1 ~r' ty2) and
-from that we want to derive evidence (T co2 : T ty1 ~r T ty2).
-For /completeness/ of decomposition we need the reverse implication too,
-else we may decompose to a new proof obligation that is stronger than
-the one we started with.  See Note [Decomposing newtype equalities].
-
----- Injectivity ----
-When do these bi-implications hold? In one direction it is easy.
-We /always/ have
-    ty1 ~r'  ty2   ===>    T ty1 ~r T ty2
-This is the CO_TYCONAPP rule of the paper (Fig 5); see also the
-TyConAppCo case of GHC.Core.Lint.lintCoercion.
-
-In the other direction, we have
-    T ty1 ~r T ty2   ==>   ty1 ~r' ty2  if T is /injective at role r/
-This is the very /definition/ of injectivity: injectivity means result
-is the same => arguments are the same, modulo the role shift.
-See comments on GHC.Core.TyCon.isInjectiveTyCon.  This is also
-the CO_NTH rule in Fig 5 of the paper, except in the paper only
-newtypes are non-injective at representation role, so the rule says "H
-is not a newtype".
-
-Injectivity is a bit subtle:
-                 Nominal   Representational
-   Datatype        YES        YES
-   Newtype         YES        NO{1}
-   Data family     YES        NO{2}
-
-{1} Consider newtype N a = MkN (F a)   -- Arg has Nominal role
-    Is it true that (N t1) ~R (N t2)   ==>   t1 ~N t2  ?
-    No, absolutely not.  E.g.
-       type instance F Int = Int; type instance F Bool = Char
-       Then (N Int) ~R (N Bool), by unwrapping, but we don't want Int~Char!
-
-    See Note [Decomposing newtype equalities]
-
-{2} We must treat data families precisely like newtypes, because of the
-    possibility of newtype instances. See also
-    Note [Decomposing newtype equalities]. See #10534 and
-    test case typecheck/should_fail/T10534.
-
----- Takeaway summary -----
-For sound and complete decomposition, we simply need injectivity;
-that is for isInjectiveTyCon to be true:
-
-* At Nominal role, isInjectiveTyCon is True for all the TyCons we are
-  considering in this Note: datatypes, newtypes, and data families.
-
-* For Givens, injectivity is necessary for soundness; completeness has no
-  side conditions.
-
-* For Wanteds, soundness has no side conditions; but injectivity is needed
-  for completeness. See Note [Decomposing newtype equalities]
-
-This is implemented in `can_decompose` in `canTyConApp`; it looks at
-injectivity, just as specified above.
-
-
-Note [Decomposing type family applications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Supose we have
-   [G/W]  (F ty1) ~r  (F ty2)
-This is handled by the TyFamLHS/TyFamLHS case of canEqCanLHS2.
-
-We never decompose to
-   [G/W]  ty1 ~r' ty2
-
-Instead
-
-* For Givens we do nothing. Injective type families have no corresponding
-  evidence of their injectivity, so we cannot decompose an
-  injective-type-family Given.
-
-* For Wanteds, for the Nominal role only, we emit new Wanteds rather like
-  functional dependencies, for each injective argument position.
-
-  E.g type family F a b   -- injective in first arg, but not second
-      [W] (F s1 t1) ~N (F s2 t2)
-  Emit new Wanteds
-      [W] s1 ~N s2
-  But retain the existing, unsolved constraint.
-
-Note [Decomposing newtype equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This Note also applies to data families, which we treat like
-newtype in case of 'newtype instance'.
-
-As Note [Decomposing TyConApp equalities] describes, if N is injective
-at role r, we can do this decomposition?
-   [G/W] (N ty1) ~r (N ty2)    to     [G/W]  ty1 ~r' ty2
-
-For a Given with r=R, the answer is a solid NO: newtypes are not injective at
-representational role, and we must not decompose, or we lose soundness.
-Example is wrinkle {1} in Note [Decomposing TyConApp equalities].
-
-For a Wanted with r=R, since newtypes are not injective at representational
-role, decomposition is sound, but we may lose completeness.  Nevertheless,
-if the newtype is abstraction (so can't be unwrapped) we can only solve
-the equality by (a) using a Given or (b) decomposition.  If (a) is impossible
-(e.g. no Givens) then (b) is safe.
-
-Conclusion: decompose newtypes (at role R) only if there are no usable Givens.
-
-* Incompleteness example (EX1)
-      newtype Nt a = MkNt (Id a)
-      type family Id a where Id a = a
-
-      [W] Nt Int ~R Nt Age
-
-  Because of its use of a type family, Nt's parameter will get inferred to
-  have a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age,
-  which is unsatisfiable. Unwrapping, though, leads to a solution.
-
-  Conclusion: always unwrap newtypes before attempting to decompose
-  them.  This is done in can_eq_nc'.  Of course, we can't unwrap if the data
-  constructor isn't in scope.  See See Note [Unwrap newtypes first].
-
-* Incompleteness example (EX2)
-      newtype Nt a = Mk Bool         -- NB: a is not used in the RHS,
-      type role Nt representational  -- but the user gives it an R role anyway
-
-  If we have [W] Nt alpha ~R Nt beta, we *don't* want to decompose to
-  [W] alpha ~R beta, because it's possible that alpha and beta aren't
-  representationally equal.
-
-  and maybe there is a Given (Nt t1 ~R Nt t2), just waiting to be used, if we
-  figure out (elsewhere) that alpha:=t1 and beta:=t2.  This is somewhat
-  similar to the question of overlapping Givens for class constraints: see
-  Note [Instance and Given overlap] in GHC.Tc.Solver.Interact.
-
-  Conclusion: don't decompose [W] N s ~R N t, if there are any Given
-  equalities that could later solve it.
-
-  But what does "any Given equalities that could later solve it" mean, precisely?
-  It must be a Given constraint that could turn into N s ~ N t.  But that
-  could include [G] (a b) ~ (c d), or even just [G] c.  But it'll definitely
-  be an CIrredCan.  So we settle for having no CIrredCans at all, which is
-  conservative but safe. See noGivenIrreds and #22331.
-
-  Well not 100.0% safe. There could be a CDictCan with some un-expanded
-  superclasses; but only in some very obscure recursive-superclass
-  situations.
-
-If there are no Irred Givens (which is quite common) then we will
-successfuly decompose [W] (IO Age) ~R (IO Int), and solve it.  But
-that won't happen and [W] (IO Age) ~R (IO Int) will be stuck.
-We /could/, however, be a bit more aggressive about decomposition;
-see Note [Decomposing newtypes a bit more aggressively].
-
-Remember: decomposing Wanteds is always /sound/. This Note is
-only about /completeness/.
-
-Note [Decomposing newtypes a bit more aggressively]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-c.f. https://github.com/ghc-proposals/ghc-proposals/pull/549,
-issue #22441, and discussion on !9282.
-
-Consider [G] c, [W] (IO Int) ~R (IO Age)
-where IO is abstract, and
-   newtype Age = MkAge Int   -- Not abstract
-With the above rules, if there any Given Irreds,
-the Wanted is insoluble because we can't decompose it.  But in fact,
-if we look at the defn of IO, roughly,
-    newtype IO a = State# -> (State#, a)
-we can see that decomposing [W] (IO Int) ~R (IO Age) to
-    [W] Int ~R Age
-definitely does not lose completeness. Why not? Because the role of
-IO's argment is representational.  Hence:
-
-  DecomposeNewtypeIdea:
-     decompose [W] (N s1 .. sn) ~R (N t1 .. tn)
-     if the roles of all N's arguments are representational
-
-If N's arguments really /are/ representational this will not lose
-completeness.  Here "really are representational" means "if you expand
-all newtypes in N's RHS, we'd infer a representational role for each
-of N's type variables in that expansion".  See Note [Role inference]
-in GHC.Tc.TyCl.Utils.
-
-But the user might /override/ a phantom role with an explicit role
-annotation, and then we could (obscurely) get incompleteness.
-Consider
-
-   module A( silly, T ) where
-     newtype T a = MkT Int
-     type role T representational  -- Override phantom role
-
-     silly :: Coercion (T Int) (T Bool)
-     silly = Coercion  -- Typechecks by unwrapping the newtype
-
-     data Coercion a b where  -- Actually defined in Data.Type.Coercion
-       Coercion :: Coercible a b => Coercion a b
-
-   module B where
-     import A
-     f :: T Int -> T Bool
-     f = case silly of Coercion -> coerce
-
-Here the `coerce` gives [W] (T Int) ~R (T Bool) which, if we decompose,
-we'll get stuck with (Int ~R Bool).  Instead we want to use the
-[G] (T Int) ~R (T Bool), which will be in the Irreds.
-
-Summary: we could adopt (DecomposeNewtypeIdea), at the cost of a very
-obscure incompleteness (above).  But no one is reporting a problem from
-the lack of decompostion, so we'll just leave it for now.  This long
-Note is just to record the thinking for our future selves.
-
-Note [Decomposing AppTy equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For AppTy all the same questions arise as in
-Note [Decomposing TyConApp equalities]. We have
-
-    s1 ~r s2,  t1 ~N t2   ==>   s1 t1 ~r s2 t2       (rule CO_APP)
-    s1 t1 ~N s2 t2        ==>   s1 ~N s2,  t1 ~N t2  (CO_LEFT, CO_RIGHT)
-
-In the first of these, why do we need Nominal equality in (t1 ~N t2)?
-See {2} below.
-
-For sound and complete solving, we need both directions to decompose. So:
-* At nominal role, all is well: we have both directions.
-* At representational role, decomposition of Givens is unsound (see {1} below),
-  and decomposition of Wanteds is incomplete.
-
-Here is an example of the incompleteness for Wanteds:
-
-    [G] g1 :: a ~R b
-    [W] w1 :: Maybe b ~R alpha a
-    [W] w2 :: alpha ~N Maybe
-
-Suppose we see w1 before w2. If we decompose, using AppCo to prove w1, we get
-
-    w1 := AppCo w3 w4
-    [W] w3 :: Maybe ~R alpha
-    [W] w4 :: b ~N a
-
-Note that w4 is *nominal*. A nominal role here is necessary because AppCo
-requires a nominal role on its second argument. (See {2} for an example of
-why.) Now we are stuck, because w4 is insoluble. On the other hand, if we
-see w2 first, setting alpha := Maybe, all is well, as we can decompose
-Maybe b ~R Maybe a into b ~R a.
-
-Another example:
-    newtype Phant x = MkPhant Int
-    [W] w1 :: Phant Int ~R alpha Bool
-    [W] w2 :: alpha ~ Phant
-
-If we see w1 first, decomposing would be disastrous, as we would then try
-to solve Int ~ Bool. Instead, spotting w2 allows us to simplify w1 to become
-    [W] w1' :: Phant Int ~R Phant Bool
-
-which can then (assuming MkPhant is in scope) be simplified to Int ~R Int,
-and all will be well. See also Note [Unwrap newtypes first].
-
-Bottom line:
-* Always decompose AppTy at nominal role: can_eq_app
-* Never decompose AppTy at representational role (neither Given nor Wanted):
-  the lack of an equation in can_eq_nc'
-
-Extra points
-{1}  Decomposing a Given AppTy over a representational role is simply
-     unsound. For example, if we have co1 :: Phant Int ~R a Bool (for
-     the newtype Phant, above), then we surely don't want any relationship
-     between Int and Bool, lest we also have co2 :: Phant ~ a around.
-
-{2} The role on the AppCo coercion is a conservative choice, because we don't
-    know the role signature of the function. For example, let's assume we could
-    have a representational role on the second argument of AppCo. Then, consider
-
-    data G a where    -- G will have a nominal role, as G is a GADT
-      MkG :: G Int
-    newtype Age = MkAge Int
-
-    co1 :: G ~R a        -- by assumption
-    co2 :: Age ~R Int    -- by newtype axiom
-    co3 = AppCo co1 co2 :: G Age ~R a Int    -- by our broken AppCo
-
-    and now co3 can be used to cast MkG to have type G Age, in violation of
-    the way GADTs are supposed to work (which is to use nominal equality).
--}
-
-canDecomposableTyConAppOK :: CtEvidence -> EqRel
-                          -> TyCon -> [TcType] -> [TcType]
-                          -> TcS (StopOrContinue Ct)
--- Precondition: tys1 and tys2 are the same finite length, hence "OK"
-canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
-  = assert (tys1 `equalLength` tys2) $
-    do { traceTcS "canDecomposableTyConAppOK"
-                  (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2)
-       ; case ev of
-           CtWanted { ctev_dest = dest, ctev_rewriters = rewriters }
-                  -- new_locs and tc_roles are both infinite, so
-                  -- we are guaranteed that cos has the same lengthm
-                  -- as tys1 and tys2
-                  -- See Note [Fast path when decomposing TyConApps]
-                  -- Caution: unifyWanteds is order sensitive
-                  -- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
-             -> do { cos <- unifyWanteds rewriters new_locs tc_roles tys1 tys2
-                   ; setWantedEq dest (mkTyConAppCo role tc cos) }
-
-           CtGiven { ctev_evar = evar }
-             -> do { let ev_co = mkCoVarCo evar
-                   ; given_evs <- newGivenEvVars loc $
-                                  [ ( mkPrimEqPredRole r ty1 ty2
-                                    , evCoercion $ mkSelCo (SelTyCon i r) ev_co )
-                                  | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..]
-                                  , r /= Phantom
-                                  , not (isCoercionTy ty1) && not (isCoercionTy ty2) ]
-                   ; emitWorkNC given_evs }
-
-    ; stopWith ev "Decomposed TyConApp" }
-
-  where
-    loc  = ctEvLoc ev
-    role = eqRelRole eq_rel
-
-    -- Infinite, to allow for over-saturated TyConApps
-    tc_roles = tyConRoleListX role tc
-
-      -- Add nuances to the location during decomposition:
-      --  * if the argument is a kind argument, remember this, so that error
-      --    messages say "kind", not "type". This is determined based on whether
-      --    the corresponding tyConBinder is named (that is, dependent)
-      --  * if the argument is invisible, note this as well, again by
-      --    looking at the corresponding binder
-      -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't
-      -- do either of these changes. (Forgetting to do so led to #16188)
-      --
-      -- NB: infinite in length
-    new_locs = [ new_loc
-               | bndr <- tyConBinders tc
-               , let new_loc0 | isNamedTyConBinder bndr = toKindLoc loc
-                              | otherwise               = loc
-                     new_loc  | isInvisibleTyConBinder bndr
-                              = updateCtLocOrigin new_loc0 toInvisibleOrigin
-                              | otherwise
-                              = new_loc0 ]
-               ++ repeat loc
-
-canDecomposableFunTy :: CtEvidence -> EqRel -> FunTyFlag
-                     -> (Type,Type,Type)   -- (multiplicity,arg,res)
-                     -> (Type,Type,Type)   -- (multiplicity,arg,res)
-                     -> TcS (StopOrContinue Ct)
-canDecomposableFunTy ev eq_rel af f1@(m1,a1,r1) f2@(m2,a2,r2)
-  = do { traceTcS "canDecomposableFunTy"
-                  (ppr ev $$ ppr eq_rel $$ ppr f1 $$ ppr f2)
-       ; case ev of
-           CtWanted { ctev_dest = dest, ctev_rewriters = rewriters }
-             -> do { mult <- unifyWanted rewriters mult_loc (funRole role SelMult) m1 m2
-                   ; arg  <- unifyWanted rewriters loc      (funRole role SelArg)  a1 a2
-                   ; res  <- unifyWanted rewriters loc      (funRole role SelRes)  r1 r2
-                   ; setWantedEq dest (mkNakedFunCo1 role af mult arg res) }
-
-           CtGiven { ctev_evar = evar }
-             -> do { let ev_co = mkCoVarCo evar
-                   ; given_evs <- newGivenEvVars loc $
-                                  [ ( mkPrimEqPredRole role' ty1 ty2
-                                    , evCoercion $ mkSelCo (SelFun fs) ev_co )
-                                  | (fs, ty1, ty2) <- [(SelMult, m1, m2)
-                                                      ,(SelArg,  a1, a2)
-                                                      ,(SelRes,  r1, r2)]
-                                  , let role' = funRole role fs ]
-                   ; emitWorkNC given_evs }
-
-    ; stopWith ev "Decomposed TyConApp" }
-
-  where
-    loc      = ctEvLoc ev
-    role     = eqRelRole eq_rel
-    mult_loc = updateCtLocOrigin loc toInvisibleOrigin
-
--- | Call when canonicalizing an equality fails, but if the equality is
--- representational, there is some hope for the future.
--- Examples in Note [Use canEqFailure in canDecomposableTyConApp]
-canEqFailure :: CtEvidence -> EqRel
-             -> TcType -> TcType -> TcS (StopOrContinue Ct)
-canEqFailure ev NomEq ty1 ty2
-  = canEqHardFailure ev ty1 ty2
-canEqFailure ev ReprEq ty1 ty2
-  = do { (redn1, rewriters1) <- rewrite ev ty1
-       ; (redn2, rewriters2) <- rewrite ev ty2
-            -- We must rewrite the types before putting them in the
-            -- inert set, so that we are sure to kick them out when
-            -- new equalities become available
-       ; traceTcS "canEqFailure with ReprEq" $
-         vcat [ ppr ev, ppr redn1, ppr redn2 ]
-       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
-       ; continueWith (mkIrredCt ReprEqReason new_ev) }
-
--- | Call when canonicalizing an equality fails with utterly no hope.
-canEqHardFailure :: CtEvidence
-                 -> TcType -> TcType -> TcS (StopOrContinue Ct)
--- See Note [Make sure that insolubles are fully rewritten]
-canEqHardFailure ev ty1 ty2
-  = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2)
-       ; (redn1, rewriters1) <- rewrite ev ty1
-       ; (redn2, rewriters2) <- rewrite ev ty2
-       ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2
-       ; continueWith (mkIrredCt ShapeMismatchReason new_ev) }
-
-{-
-Note [Canonicalising type applications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given (s1 t1) ~ ty2, how should we proceed?
-The simple thing is to see if ty2 is of form (s2 t2), and
-decompose.
-
-However, over-eager decomposition gives bad error messages
-for things like
-   a b ~ Maybe c
-   e f ~ p -> q
-Suppose (in the first example) we already know a~Array.  Then if we
-decompose the application eagerly, yielding
-   a ~ Maybe
-   b ~ c
-we get an error        "Can't match Array ~ Maybe",
-but we'd prefer to get "Can't match Array b ~ Maybe c".
-
-So instead can_eq_wanted_app rewrites the LHS and RHS, in the hope of
-replacing (a b) by (Array b), before using try_decompose_app to
-decompose it.
-
-Note [Make sure that insolubles are fully rewritten]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When an equality fails, we still want to rewrite the equality
-all the way down, so that it accurately reflects
- (a) the mutable reference substitution in force at start of solving
- (b) any ty-binds in force at this point in solving
-See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet.
-And if we don't do this there is a bad danger that
-GHC.Tc.Solver.applyTyVarDefaulting will find a variable
-that has in fact been substituted.
-
-Note [Do not decompose Given polytype equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider [G] (forall a. t1 ~ forall a. t2).  Can we decompose this?
-No -- what would the evidence look like?  So instead we simply discard
-this given evidence.
-
-Note [No top-level newtypes on RHS of representational equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we're in this situation:
-
- work item:  [W] c1 : a ~R b
-     inert:  [G] c2 : b ~R Id a
-
-where
-  newtype Id a = Id a
-
-We want to make sure canEqCanLHS sees [W] a ~R a, after b is rewritten
-and the Id newtype is unwrapped. This is assured by requiring only rewritten
-types in canEqCanLHS *and* having the newtype-unwrapping check above
-the tyvar check in can_eq_nc.
-
-Note that this only applies to saturated applications of newtype TyCons, as
-we can't rewrite an unsaturated application. See for example T22310, where
-we ended up with:
-
-  newtype Compose f g a = ...
-
-  [W] t[tau] ~# Compose Foo Bar
-
-Note [Put touchable variables on the left]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Ticket #10009, a very nasty example:
-
-    f :: (UnF (F b) ~ b) => F b -> ()
-
-    g :: forall a. (UnF (F a) ~ a) => a -> ()
-    g _ = f (undefined :: F a)
-
-For g we get [G]  g1 : UnF (F a) ~ a
-             [W] w1 : UnF (F beta) ~ beta
-             [W] w2 : F a ~ F beta
-
-g1 is canonical (CEqCan). It is oriented as above because a is not touchable.
-See canEqTyVarFunEq.
-
-w1 is similarly canonical, though the occurs-check in canEqTyVarFunEq is key
-here.
-
-w2 is canonical. But which way should it be oriented? As written, we'll be
-stuck. When w2 is added to the inert set, nothing gets kicked out: g1 is
-a Given (and Wanteds don't rewrite Givens), and w2 doesn't mention the LHS
-of w2. We'll thus lose.
-
-But if w2 is swapped around, to
-
-    [W] w3 : F beta ~ F a
-
-then we'll kick w1 out of the inert
-set (it mentions the LHS of w3). We then rewrite w1 to
-
-    [W] w4 : UnF (F a) ~ beta
-
-and then, using g1, to
-
-    [W] w5 : a ~ beta
-
-at which point we can unify and go on to glory. (This rewriting actually
-happens all at once, in the call to rewrite during canonicalisation.)
-
-But what about the new LHS makes it better? It mentions a variable (beta)
-that can appear in a Wanted -- a touchable metavariable never appears
-in a Given. On the other hand, the original LHS mentioned only variables
-that appear in Givens. We thus choose to put variables that can appear
-in Wanteds on the left.
-
-Ticket #12526 is another good example of this in action.
-
--}
-
----------------------
-canEqCanLHS :: CtEvidence            -- ev :: lhs ~ rhs
-            -> EqRel -> SwapFlag
-            -> CanEqLHS              -- lhs (or, if swapped, rhs)
-            -> TcType                -- lhs: pretty lhs, already rewritten
-            -> TcType -> TcType      -- rhs: already rewritten
-            -> TcS (StopOrContinue Ct)
-canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
-  | k1 `tcEqType` k2
-  = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
-
-  | otherwise
-  = canEqCanLHSHetero ev eq_rel swapped lhs1 k1 xi2 k2
-
-  where
-    k1 = canEqLHSKind lhs1
-    k2 = typeKind xi2
-
-
-{-
-Note [Kind Equality Orientation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-While in theory [W] x ~ y and [W] y ~ x ought to give us the same behaviour, in practice it does not.
-See Note [Fundeps with instances, and equality orientation] where this is discussed at length.
-As a rule of thumb: we keep the newest unification variables on the left of the equality.
-See also Note [Improvement orientation] in GHC.Tc.Solver.Interact.
-
-In particular, `canEqCanLHSHetero` produces the following constraint equalities
-
-[X] (xi1 :: ki1) ~ (xi2 :: ki2)
-  -->  [X] kco :: ki1 ~ ki2
-       [X] co : xi1 :: ki1 ~ (xi2 |> sym kco) :: ki1
-
-Note that the types in the LHS of the new constraints are the ones that were on the LHS of
-the original constraint.
-
---- Historical note ---
-We prevously used to flip the kco to avoid using a sym in the cast
-
-[X] (xi1 :: ki1) ~ (xi2 :: ki2)
-  -->  [X] kco :: ki2 ~ ki1
-       [X] co : xi1 :: ki1 ~ (xi2 |> kco) :: ki1
-
-But this sent solver in an infinite loop (see #19415).
--- End of historical note --
--}
-
-canEqCanLHSHetero :: CtEvidence         -- :: (xi1 :: ki1) ~ (xi2 :: ki2)
-                  -> EqRel -> SwapFlag
-                  -> CanEqLHS           -- xi1
-                  -> TcKind             -- ki1
-                  -> TcType             -- xi2
-                  -> TcKind             -- ki2
-                  -> TcS (StopOrContinue Ct)
-canEqCanLHSHetero ev eq_rel swapped lhs1 ki1 xi2 ki2
-  -- See Note [Equalities with incompatible kinds]
-  -- See Note [Kind Equality Orientation]
-  -- NB: preserve left-to-right orientation!!
-  -- See Note [Fundeps with instances, and equality orientation]
-  --     wrinkle (W2) in GHC.Tc.Solver.Interact
-  = do { (kind_ev, kind_co) <- mk_kind_eq   -- :: ki1 ~N ki2
-
-       ; let  -- kind_co :: (ki1 :: *) ~N (ki2 :: *)   (whether swapped or not)
-             lhs_redn = mkReflRedn role xi1
-             rhs_redn = mkGReflRightRedn role xi2 (mkSymCo kind_co)
-
-             -- See Note [Equalities with incompatible kinds], Wrinkle (1)
-             -- This will be ignored in rewriteEqEvidence if the work item is a Given
-             rewriters = rewriterSetFromCo kind_co
-
-       ; traceTcS "Hetero equality gives rise to kind equality"
-           (ppr kind_co <+> dcolon <+> sep [ ppr ki1, text "~#", ppr ki2 ])
-       ; type_ev <- rewriteEqEvidence rewriters ev swapped lhs_redn rhs_redn
-
-       ; emitWorkNC [type_ev]  -- delay the type equality until after we've finished
-                               -- the kind equality, which may unlock things
-                               -- See Note [Equalities with incompatible kinds]
-
-       ; canEqNC kind_ev NomEq ki1 ki2 }
-  where
-    mk_kind_eq :: TcS (CtEvidence, CoercionN)
-    mk_kind_eq = case ev of
-      CtGiven { ctev_evar = evar }
-        -> do { let kind_co = maybe_sym $ mkKindCo (mkCoVarCo evar) -- :: k1 ~ k2
-              ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)
-              ; return (kind_ev, ctEvCoercion kind_ev) }
-
-      CtWanted { ctev_rewriters = rewriters }
-        -> newWantedEq kind_loc rewriters Nominal ki1 ki2
-
-    xi1      = canEqLHSType lhs1
-    loc      = ctev_loc ev
-    role     = eqRelRole eq_rel
-    kind_loc = mkKindLoc xi1 xi2 loc
-    kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki1 ki2
-
-    maybe_sym = case swapped of
-          IsSwapped  -> mkSymCo         -- if the input is swapped, then we
-                                        -- will have k2 ~ k1, so flip it to k1 ~ k2
-          NotSwapped -> id
-
--- guaranteed that typeKind lhs == typeKind rhs
-canEqCanLHSHomo :: CtEvidence
-                -> EqRel -> SwapFlag
-                -> CanEqLHS           -- lhs (or, if swapped, rhs)
-                -> TcType             -- pretty lhs
-                -> TcType -> TcType   -- rhs, pretty rhs
-                -> TcS (StopOrContinue Ct)
-canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2
-  | (xi2', mco) <- split_cast_ty xi2
-  , Just lhs2 <- canEqLHS_maybe xi2'
-  = canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 (ps_xi2 `mkCastTyMCo` mkSymMCo mco) mco
-
-  | otherwise
-  = canEqCanLHSFinish ev eq_rel swapped lhs1 ps_xi2
-
-  where
-    split_cast_ty (CastTy ty co) = (ty, MCo co)
-    split_cast_ty other          = (other, MRefl)
-
--- This function deals with the case that both LHS and RHS are potential
--- CanEqLHSs.
-canEqCanLHS2 :: CtEvidence              -- lhs ~ (rhs |> mco)
-                                        -- or, if swapped: (rhs |> mco) ~ lhs
-             -> EqRel -> SwapFlag
-             -> CanEqLHS                -- lhs (or, if swapped, rhs)
-             -> TcType                  -- pretty lhs
-             -> CanEqLHS                -- rhs
-             -> TcType                  -- pretty rhs
-             -> MCoercion               -- :: kind(rhs) ~N kind(lhs)
-             -> TcS (StopOrContinue Ct)
-canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco
-  | lhs1 `eqCanEqLHS` lhs2
-    -- It must be the case that mco is reflexive
-  = canEqReflexive ev eq_rel (canEqLHSType lhs1)
-
-  | TyVarLHS tv1 <- lhs1
-  , TyVarLHS tv2 <- lhs2
-  , swapOverTyVars (isGiven ev) tv1 tv2
-  = do { traceTcS "canEqLHS2 swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)
-       ; new_ev <- do_swap
-       ; canEqCanLHSFinish new_ev eq_rel IsSwapped (TyVarLHS tv2)
-                                                   (ps_xi1 `mkCastTyMCo` sym_mco) }
-
-  | TyVarLHS tv1 <- lhs1
-  , TyFamLHS fun_tc2 fun_args2 <- lhs2
-  = canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco
-
-  | TyFamLHS fun_tc1 fun_args1 <- lhs1
-  , TyVarLHS tv2 <- lhs2
-  = do { new_ev <- do_swap
-       ; canEqTyVarFunEq new_ev eq_rel IsSwapped tv2 ps_xi2
-                                                 fun_tc1 fun_args1 ps_xi1 sym_mco }
-
-  | TyFamLHS fun_tc1 fun_args1 <- lhs1
-  , TyFamLHS fun_tc2 fun_args2 <- lhs2
-  -- See Note [Decomposing type family applications]
-  = do { traceTcS "canEqCanLHS2 two type families" (ppr lhs1 $$ ppr lhs2)
-
-         -- emit wanted equalities for injective type families
-       ; let inj_eqns :: [TypeEqn]  -- TypeEqn = Pair Type
-             inj_eqns
-               | ReprEq <- eq_rel   = []   -- injectivity applies only for nom. eqs.
-               | fun_tc1 /= fun_tc2 = []   -- if the families don't match, stop.
-
-               | Injective inj <- tyConInjectivityInfo fun_tc1
-               = [ Pair arg1 arg2
-                 | (arg1, arg2, True) <- zip3 fun_args1 fun_args2 inj ]
-
-                 -- built-in synonym families don't have an entry point
-                 -- for this use case. So, we just use sfInteractInert
-                 -- and pass two equal RHSs. We *could* add another entry
-                 -- point, but then there would be a burden to make
-                 -- sure the new entry point and existing ones were
-                 -- internally consistent. This is slightly distasteful,
-                 -- but it works well in practice and localises the
-                 -- problem.
-               | Just ops <- isBuiltInSynFamTyCon_maybe fun_tc1
-               = let ki1 = canEqLHSKind lhs1
-                     ki2 | MRefl <- mco
-                         = ki1   -- just a small optimisation
-                         | otherwise
-                         = canEqLHSKind lhs2
-
-                     fake_rhs1 = anyTypeOfKind ki1
-                     fake_rhs2 = anyTypeOfKind ki2
-                 in
-                 sfInteractInert ops fun_args1 fake_rhs1 fun_args2 fake_rhs2
-
-               | otherwise  -- ordinary, non-injective type family
-               = []
-
-       ; case ev of
-           CtWanted { ctev_rewriters = rewriters } ->
-             mapM_ (\ (Pair t1 t2) -> unifyWanted rewriters (ctEvLoc ev) Nominal t1 t2) inj_eqns
-           CtGiven {} -> return ()
-             -- See Note [No Given/Given fundeps] in GHC.Tc.Solver.Interact
-
-       ; tclvl <- getTcLevel
-       ; let tvs1 = tyCoVarsOfTypes fun_args1
-             tvs2 = tyCoVarsOfTypes fun_args2
-
-             swap_for_rewriting = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 &&
-                          -- swap 'em: Note [Put touchable variables on the left]
-                                  not (anyVarSet (isTouchableMetaTyVar tclvl) tvs1)
-                          -- this check is just to avoid unfruitful swapping
-
-               -- If we have F a ~ F (F a), we want to swap.
-             swap_for_occurs
-               | cterHasNoProblem   $ checkTyFamEq fun_tc2 fun_args2
-                                                   (mkTyConApp fun_tc1 fun_args1)
-               , cterHasOccursCheck $ checkTyFamEq fun_tc1 fun_args1
-                                                   (mkTyConApp fun_tc2 fun_args2)
-               = True
-
-               | otherwise
-               = False
-
-       ; if swap_for_rewriting || swap_for_occurs
-         then do { new_ev <- do_swap
-                 ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTyMCo` sym_mco) }
-         else finish_without_swapping }
-
-  -- that's all the special cases. Now we just figure out which non-special case
-  -- to continue to.
-  | otherwise
-  = finish_without_swapping
-
-  where
-    sym_mco = mkSymMCo mco
-
-    do_swap = rewriteCastedEquality ev eq_rel swapped (canEqLHSType lhs1) (canEqLHSType lhs2) mco
-    finish_without_swapping = canEqCanLHSFinish ev eq_rel swapped lhs1 (ps_xi2 `mkCastTyMCo` mco)
-
-
--- This function handles the case where one side is a tyvar and the other is
--- a type family application. Which to put on the left?
---   If the tyvar is a touchable meta-tyvar, put it on the left, as this may
---   be our only shot to unify.
---   Otherwise, put the function on the left, because it's generally better to
---   rewrite away function calls. This makes types smaller. And it seems necessary:
---     [W] F alpha ~ alpha
---     [W] F alpha ~ beta
---     [W] G alpha beta ~ Int   ( where we have type instance G a a = a )
---   If we end up with a stuck alpha ~ F alpha, we won't be able to solve this.
---   Test case: indexed-types/should_compile/CEqCanOccursCheck
-canEqTyVarFunEq :: CtEvidence               -- :: lhs ~ (rhs |> mco)
-                                            -- or (rhs |> mco) ~ lhs if swapped
-                -> EqRel -> SwapFlag
-                -> TyVar -> TcType          -- lhs (or if swapped rhs), pretty lhs
-                -> TyCon -> [Xi] -> TcType  -- rhs (or if swapped lhs) fun and args, pretty rhs
-                -> MCoercion                -- :: kind(rhs) ~N kind(lhs)
-                -> TcS (StopOrContinue Ct)
-canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco
-  = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv1 rhs
-       ; if | case is_touchable of { Untouchable -> False; _ -> True }
-            , cterHasNoProblem $
-                checkTyVarEq tv1 rhs `cterRemoveProblem` cteTypeFamily
-            -> canEqCanLHSFinish ev eq_rel swapped (TyVarLHS tv1) rhs
-
-            | otherwise
-              -> do { new_ev <- rewriteCastedEquality ev eq_rel swapped
-                                  (mkTyVarTy tv1) (mkTyConApp fun_tc2 fun_args2)
-                                  mco
-                    ; canEqCanLHSFinish new_ev eq_rel IsSwapped
-                                  (TyFamLHS fun_tc2 fun_args2)
-                                  (ps_xi1 `mkCastTyMCo` sym_mco) } }
-  where
-    sym_mco = mkSymMCo mco
-    rhs = ps_xi2 `mkCastTyMCo` mco
-
--- The RHS here is either not CanEqLHS, or it's one that we
--- want to rewrite the LHS to (as per e.g. swapOverTyVars)
-canEqCanLHSFinish :: CtEvidence
-                  -> EqRel -> SwapFlag
-                  -> CanEqLHS             -- lhs (or, if swapped, rhs)
-                  -> TcType               -- rhs (or, if swapped, lhs)
-                  -> TcS (StopOrContinue Ct)
-canEqCanLHSFinish ev eq_rel swapped lhs rhs
--- RHS is fully rewritten, but with type synonyms
--- preserved as much as possible
--- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K)
--- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqCanLHS2
-
-  = do {
-          -- this performs the swap if necessary
-         new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
-                                     (mkReflRedn role lhs_ty)
-                                     (mkReflRedn role rhs)
-
-     -- by now, (TyEq:K) is already satisfied
-       ; massert (canEqLHSKind lhs `eqType` typeKind rhs)
-
-     -- by now, (TyEq:N) is already satisfied (if applicable)
-       ; assertPprM ty_eq_N_OK $
-           vcat [ text "CanEqCanLHSFinish: (TyEq:N) not satisfied"
-                , text "rhs:" <+> ppr rhs
-                ]
-
-     -- guarantees (TyEq:OC), (TyEq:F)
-     -- Must do the occurs check even on tyvar/tyvar
-     -- equalities, in case have  x ~ (y :: ..x...); this is #12593.
-       ; let result0 = checkTypeEq lhs rhs `cterRemoveProblem` cteTypeFamily
-     -- type families are OK here
-     -- NB: no occCheckExpand here; see Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite
-
-              -- a ~R# b a is soluble if b later turns out to be Identity
-             result = case eq_rel of
-                        NomEq  -> result0
-                        ReprEq -> cterSetOccursCheckSoluble result0
-
-             reason = NonCanonicalReason result
-
-       ; if cterHasNoProblem result
-         then do { traceTcS "CEqCan" (ppr lhs $$ ppr rhs)
-                 ; continueWith (CEqCan { cc_ev = new_ev, cc_lhs = lhs
-                                        , cc_rhs = rhs, cc_eq_rel = eq_rel }) }
-
-         else do { m_stuff <- breakTyEqCycle_maybe ev result lhs rhs
-                           -- See Note [Type equality cycles];
-                           -- returning Nothing is the vastly common case
-                 ; case m_stuff of
-                     { Nothing ->
-                         do { traceTcS "canEqCanLHSFinish can't make a canonical"
-                                       (ppr lhs $$ ppr rhs)
-                            ; continueWith (mkIrredCt reason new_ev) }
-                     ; Just rhs_redn@(Reduction _ new_rhs) ->
-              do { traceTcS "canEqCanLHSFinish breaking a cycle" $
-                            ppr lhs $$ ppr rhs
-                 ; traceTcS "new RHS:" (ppr new_rhs)
-
-                   -- This check is Detail (1) in the Note
-                 ; if cterHasOccursCheck (checkTypeEq lhs new_rhs)
-
-                   then do { traceTcS "Note [Type equality cycles] Detail (1)"
-                                      (ppr new_rhs)
-                           ; continueWith (mkIrredCt reason new_ev) }
-
-                   else do { -- See Detail (6) of Note [Type equality cycles]
-                             new_new_ev <- rewriteEqEvidence emptyRewriterSet
-                                             new_ev NotSwapped
-                                             (mkReflRedn Nominal lhs_ty)
-                                             rhs_redn
-
-                           ; continueWith (CEqCan { cc_ev = new_new_ev
-                                                  , cc_lhs = lhs
-                                                  , cc_rhs = new_rhs
-                                                  , cc_eq_rel = eq_rel }) }}}}}
-  where
-    role = eqRelRole eq_rel
-
-    lhs_ty = canEqLHSType lhs
-
-    -- This is about (TyEq:N): check that we don't have a saturated application
-    -- of a newtype TyCon at the top level of the RHS, if the constructor
-    -- of the newtype is in scope.
-    ty_eq_N_OK :: TcS Bool
-    ty_eq_N_OK
-      | ReprEq <- eq_rel
-      , Just (tc, tc_args) <- splitTyConApp_maybe rhs
-      , Just con <- newTyConDataCon_maybe tc
-      -- #22310: only a problem if the newtype TyCon is saturated.
-      , tc_args `lengthAtLeast` tyConArity tc
-      -- #21010: only a problem if the newtype constructor is in scope.
-      = do { rdr_env <- getGlobalRdrEnvTcS
-           ; let con_in_scope = isJust $ lookupGRE_Name rdr_env (dataConName con)
-           ; return $ not con_in_scope }
-      | otherwise
-      = return True
-
--- | Solve a reflexive equality constraint
-canEqReflexive :: CtEvidence    -- ty ~ ty
-               -> EqRel
-               -> TcType        -- ty
-               -> TcS (StopOrContinue Ct)   -- always Stop
-canEqReflexive ev eq_rel ty
-  = do { setEvBindIfWanted ev (evCoercion $
-                               mkReflCo (eqRelRole eq_rel) ty)
-       ; stopWith ev "Solved by reflexivity" }
-
-rewriteCastedEquality :: CtEvidence     -- :: lhs ~ (rhs |> mco), or (rhs |> mco) ~ lhs
-                      -> EqRel -> SwapFlag
-                      -> TcType         -- lhs
-                      -> TcType         -- rhs
-                      -> MCoercion      -- mco
-                      -> TcS CtEvidence -- :: (lhs |> sym mco) ~ rhs
-                                        -- result is independent of SwapFlag
-rewriteCastedEquality ev eq_rel swapped lhs rhs mco
-  = rewriteEqEvidence emptyRewriterSet ev swapped lhs_redn rhs_redn
-  where
-    lhs_redn = mkGReflRightMRedn role lhs sym_mco
-    rhs_redn = mkGReflLeftMRedn  role rhs mco
-
-    sym_mco = mkSymMCo mco
-    role    = eqRelRole eq_rel
-
-{- Note [Equalities with incompatible kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What do we do when we have an equality
-
-  (tv :: k1) ~ (rhs :: k2)
-
-where k1 and k2 differ? Easy: we create a coercion that relates k1 and
-k2 and use this to cast. To wit, from
-
-  [X] (tv :: k1) ~ (rhs :: k2)
-
-(where [X] is [G] or [W]), we go to
-
-  [X] co :: k1 ~ k2
-  [X] (tv :: k1) ~ ((rhs |> sym co) :: k1)
-
-We carry on with the *kind equality*, not the type equality, because
-solving the former may unlock the latter. This choice is made in
-canEqCanLHSHetero. It is important: otherwise, T13135 loops.
-
-Wrinkles:
-
- (1) When X is W, the new type-level wanted is effectively rewritten by the
-     kind-level one. We thus include the kind-level wanted in the RewriterSet
-     for the type-level one. See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint.
-     This is done in canEqCanLHSHetero.
-
- (2) If we have [W] w :: alpha ~ (rhs |> sym co_hole), should we unify alpha? No.
-     The problem is that the wanted w is effectively rewritten by another wanted,
-     and unifying alpha effectively promotes this wanted to a given. Doing so
-     means we lose track of the rewriter set associated with the wanted.
-
-     On the other hand, w is perfectly suitable for rewriting, because of the
-     way we carefully track rewriter sets.
-
-     We thus allow w to be a CEqCan, but we prevent unification. See
-     Note [Unification preconditions] in GHC.Tc.Utils.Unify.
-
-     The only tricky part is that we must later indeed unify if/when the kind-level
-     wanted gets solved. This is done in kickOutAfterFillingCoercionHole,
-     which kicks out all equalities whose RHS mentions the filled-in coercion hole.
-     Note that it looks for type family equalities, too, because of the use of
-     unifyTest in canEqTyVarFunEq.
-
- (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the
-     algorithm detailed here, producing [W] co :: k1 ~ k2, and adding
-     [W] (a :: k1) ~ ((rhs |> sym co) :: k1) to the irreducibles. Some time
-     later, we solve co, and fill in co's coercion hole. This kicks out
-     the irreducible as described in (2).
-     But now, during canonicalization, we see the cast
-     and remove it, in canEqCast. By the time we get into canEqCanLHS, the equality
-     is heterogeneous again, and the process repeats.
-
-     To avoid this, we don't strip casts off a type if the other type
-     in the equality is a CanEqLHS (the scenario above can happen with a
-     type family, too. testcase: typecheck/should_compile/T13822).
-     And this is an improvement regardless:
-     because tyvars can, generally, unify with casted types, there's no
-     reason to go through the work of stripping off the cast when the
-     cast appears opposite a tyvar. This is implemented in the cast case
-     of can_eq_nc'.
-
-Historical note:
-
-We used to do this via emitting a Derived kind equality and then parking
-the heterogeneous equality as irreducible. But this new approach is much
-more direct. And it doesn't produce duplicate Deriveds (as the old one did).
-
-Note [Type synonyms and canonicalization]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We treat type synonym applications as xi types, that is, they do not
-count as type function applications.  However, we do need to be a bit
-careful with type synonyms: like type functions they may not be
-generative or injective.  However, unlike type functions, they are
-parametric, so there is no problem in expanding them whenever we see
-them, since we do not need to know anything about their arguments in
-order to expand them; this is what justifies not having to treat them
-as specially as type function applications.  The thing that causes
-some subtleties is that we prefer to leave type synonym applications
-*unexpanded* whenever possible, in order to generate better error
-messages.
-
-If we encounter an equality constraint with type synonym applications
-on both sides, or a type synonym application on one side and some sort
-of type application on the other, we simply must expand out the type
-synonyms in order to continue decomposing the equality constraint into
-primitive equality constraints.  For example, suppose we have
-
-  type F a = [Int]
-
-and we encounter the equality
-
-  F a ~ [b]
-
-In order to continue we must expand F a into [Int], giving us the
-equality
-
-  [Int] ~ [b]
-
-which we can then decompose into the more primitive equality
-constraint
-
-  Int ~ b.
-
-However, if we encounter an equality constraint with a type synonym
-application on one side and a variable on the other side, we should
-NOT (necessarily) expand the type synonym, since for the purpose of
-good error messages we want to leave type synonyms unexpanded as much
-as possible.  Hence the ps_xi1, ps_xi2 argument passed to canEqCanLHS.
-
-Note [Type equality cycles]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this situation (from indexed-types/should_compile/GivenLoop):
-
-  instance C (Maybe b)
-  *[G] a ~ Maybe (F a)
-  [W] C a
-
-or (typecheck/should_compile/T19682b):
-
-  instance C (a -> b)
-  *[W] alpha ~ (Arg alpha -> Res alpha)
-  [W] C alpha
-
-or (typecheck/should_compile/T21515):
-
-  type family Code a
-  *[G] Code a ~ '[ '[ Head (Head (Code a)) ] ]
-  [W] Code a ~ '[ '[ alpha ] ]
-
-In order to solve the final Wanted, we must use the starred constraint
-for rewriting. But note that all starred constraints have occurs-check failures,
-and so we can't straightforwardly add these to the inert set and
-use them for rewriting. (NB: A rigid type constructor is at the
-top of all RHSs, preventing reorienting in canEqTyVarFunEq in the tyvar
-cases.)
-
-The key idea is to replace the outermost type family applications in the RHS of the
-starred constraints with a fresh variable, which we'll call a cycle-breaker
-variable, or cbv. Then, relate the cbv back with the original type family application
-via new equality constraints. Our situations thus become:
-
-  instance C (Maybe b)
-  [G] a ~ Maybe cbv
-  [G] F a ~ cbv
-  [W] C a
-
-or
-
-  instance C (a -> b)
-  [W] alpha ~ (cbv1 -> cbv2)
-  [W] Arg alpha ~ cbv1
-  [W] Res alpha ~ cbv2
-  [W] C alpha
-
-or
-
-  [G] Code a ~ '[ '[ cbv ] ]
-  [G] Head (Head (Code a)) ~ cbv
-  [W] Code a ~ '[ '[ alpha ] ]
-
-This transformation (creating the new types and emitting new equality
-constraints) is done in breakTyEqCycle_maybe.
-
-The details depend on whether we're working with a Given or a Wanted.
-
-Given
------
-
-We emit a new Given, [G] F a ~ cbv, equating the type family application to
-our new cbv. Note its orientation: The type family ends up on the left; see
-commentary on canEqTyVarFunEq, which decides how to orient such cases. No
-special treatment for CycleBreakerTvs is necessary. This scenario is now
-easily soluble, by using the first Given to rewrite the Wanted, which can now
-be solved.
-
-(The first Given actually also rewrites the second one, giving
-[G] F (Maybe cbv) ~ cbv, but this causes no trouble.)
-
-Of course, we don't want our fresh variables leaking into e.g. error messages.
-So we fill in the metavariables with their original type family applications
-after we're done running the solver (in nestImplicTcS and runTcSWithEvBinds).
-This is done by restoreTyVarCycles, which uses the inert_cycle_breakers field in
-InertSet, which contains the pairings invented in breakTyEqCycle_maybe.
-
-That is:
-
-We transform
-  [G] g : lhs ~ ...(F lhs)...
-to
-  [G] (Refl lhs) : F lhs ~ cbv      -- CEqCan
-  [G] g          : lhs ~ ...cbv...  -- CEqCan
-
-Note that
-* `cbv` is a fresh cycle breaker variable.
-* `cbv` is a is a meta-tyvar, but it is completely untouchable.
-* We track the cycle-breaker variables in inert_cycle_breakers in InertSet
-* We eventually fill in the cycle-breakers, with `cbv := F lhs`.
-  No one else fills in cycle-breakers!
-* The evidence for the new `F lhs ~ cbv` constraint is Refl, because we know
-  this fill-in is ultimately going to happen.
-* In inert_cycle_breakers, we remember the (cbv, F lhs) pair; that is, we
-  remember the /original/ type.  The [G] F lhs ~ cbv constraint may be rewritten
-  by other givens (eg if we have another [G] lhs ~ (b,c)), but at the end we
-  still fill in with cbv := F lhs
-* This fill-in is done when solving is complete, by restoreTyVarCycles
-  in nestImplicTcS and runTcSWithEvBinds.
-
-Wanted
-------
-The fresh cycle-breaker variables here must actually be normal, touchable
-metavariables. That is, they are TauTvs. Nothing at all unusual. Repeating
-the example from above, we have
-
-  *[W] alpha ~ (Arg alpha -> Res alpha)
-
-and we turn this into
-
-  *[W] alpha ~ (cbv1 -> cbv2)
-  [W] Arg alpha ~ cbv1
-  [W] Res alpha ~ cbv2
-
-where cbv1 and cbv2 are fresh TauTvs. Why TauTvs? See [Why TauTvs] below.
-
-Critically, we emit the two new constraints (the last two above)
-directly instead of calling unifyWanted. (Otherwise, we'd end up unifying cbv1
-and cbv2 immediately, achieving nothing.)
-Next, we unify alpha := cbv1 -> cbv2, having eliminated the occurs check. This
-unification -- which must be the next step after breaking the cycles --
-happens in the course of normal behavior of top-level
-interactions, later in the solver pipeline. We know this unification will
-indeed happen because breakTyEqCycle_maybe, which decides whether to apply
-this logic, checks to ensure unification will succeed in its final_check.
-(In particular, the LHS must be a touchable tyvar, never a type family. We don't
-yet have an example of where this logic is needed with a type family, and it's
-unclear how to handle this case, so we're skipping for now.) Now, we're
-here (including further context from our original example, from the top of the
-Note):
-
-  instance C (a -> b)
-  [W] Arg (cbv1 -> cbv2) ~ cbv1
-  [W] Res (cbv1 -> cbv2) ~ cbv2
-  [W] C (cbv1 -> cbv2)
-
-The first two W constraints reduce to reflexivity and are discarded,
-and the last is easily soluble.
-
-[Why TauTvs]:
-Let's look at another example (typecheck/should_compile/T19682) where we need
-to unify the cbvs:
-
-  class    (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys
-  instance (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys
-
-  type family SameShapeAs xs ys :: Constraint where
-    SameShapeAs '[] ys      = (ys ~ '[])
-    SameShapeAs (x : xs) ys = (ys ~ (Head ys : Tail ys))
-
-  type family AllEqF xs ys :: Constraint where
-    AllEqF '[]      '[]      = ()
-    AllEqF (x : xs) (y : ys) = (x ~ y, AllEq xs ys)
-
-  [W] alpha ~ (Head alpha : Tail alpha)
-  [W] AllEqF '[Bool] alpha
-
-Without the logic detailed in this Note, we're stuck here, as AllEqF cannot
-reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach,
-just as described above. We thus invent cbv1 and cbv2 and unify
-alpha := cbv1 -> cbv2, yielding (after zonking)
-
-  [W] Head (cbv1 : cbv2) ~ cbv1
-  [W] Tail (cbv1 : cbv2) ~ cbv2
-  [W] AllEqF '[Bool] (cbv1 : cbv2)
-
-The first two W constraints simplify to reflexivity and are discarded.
-But the last reduces:
-
-  [W] Bool ~ cbv1
-  [W] AllEq '[] cbv2
-
-The first of these is solved by unification: cbv1 := Bool. The second
-is solved by the instance for AllEq to become
-
-  [W] AllEqF '[] cbv2
-  [W] SameShapeAs '[] cbv2
-
-While the first of these is stuck, the second makes progress, to lead to
-
-  [W] AllEqF '[] cbv2
-  [W] cbv2 ~ '[]
-
-This second constraint is solved by unification: cbv2 := '[]. We now
-have
-
-  [W] AllEqF '[] '[]
-
-which reduces to
-
-  [W] ()
-
-which is trivially satisfiable. Hooray!
-
-Note that we need to unify the cbvs here; if we did not, there would be
-no way to solve those constraints. That's why the cycle-breakers are
-ordinary TauTvs.
-
-In all cases
-------------
-
-We detect this scenario by the following characteristics:
- - a constraint with a soluble occurs-check failure
-   (as indicated by the cteSolubleOccurs bit set in a CheckTyEqResult
-   from checkTypeEq)
- - and a nominal equality
- - and either
-    - a Given flavour (but see also Detail (7) below)
-    - a Wanted flavour, with a touchable metavariable on the left
-
-We don't use this trick for representational equalities, as there is no
-concrete use case where it is helpful (unlike for nominal equalities).
-Furthermore, because function applications can be CanEqLHSs, but newtype
-applications cannot, the disparities between the cases are enough that it
-would be effortful to expand the idea to representational equalities. A quick
-attempt, with
-
-      data family N a b
-
-      f :: (Coercible a (N a b), Coercible (N a b) b) => a -> b
-      f = coerce
-
-failed with "Could not match 'b' with 'b'." Further work is held off
-until when we have a concrete incentive to explore this dark corner.
-
-Details:
-
- (1) We don't look under foralls, at all, when substituting away type family
-     applications, because doing so can never be fruitful. Recall that we
-     are in a case like [G] lhs ~ forall b. ... lhs ....   Until we have a type
-     family that can pull the body out from a forall (e.g. type instance F (forall b. ty) = ty),
-     this will always be
-     insoluble. Note also that the forall cannot be in an argument to a
-     type family, or that outer type family application would already have
-     been substituted away.
-
-     However, we still must check to make sure that breakTyEqCycle_maybe actually
-     succeeds in getting rid of all occurrences of the offending lhs. If
-     one is hidden under a forall, this won't be true. A similar problem can
-     happen if the variable appears only in a kind
-     (e.g. k ~ ... (a :: k) ...). So we perform an additional check after
-     performing the substitution. It is tiresome to re-run all of checkTypeEq
-     here, but reimplementing just the occurs-check is even more tiresome.
-
-     Skipping this check causes typecheck/should_fail/GivenForallLoop and
-     polykinds/T18451 to loop.
-
- (2) Our goal here is to avoid loops in rewriting. We can thus skip looking
-     in coercions, as we don't rewrite in coercions in the algorithm in
-     GHC.Solver.Rewrite. (This is another reason
-     we need to re-check that we've gotten rid of all occurrences of the
-     offending variable.)
-
- (3) As we're substituting as described in this Note, we can build ill-kinded
-     types. For example, if we have Proxy (F a) b, where (b :: F a), then
-     replacing this with Proxy cbv b is ill-kinded. However, we will later
-     set cbv := F a, and so the zonked type will be well-kinded again.
-     The temporary ill-kinded type hurts no one, and avoiding this would
-     be quite painfully difficult.
-
-     Specifically, this detail does not contravene the Purely Kinded Type Invariant
-     (Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType).
-     The PKTI says that we can call typeKind on any type, without failure.
-     It would be violated if we, say, replaced a kind (a -> b) with a kind c,
-     because an arrow kind might be consulted in piResultTys. Here, we are
-     replacing one opaque type like (F a b c) with another, cbv (opaque in
-     that we never assume anything about its structure, like that it has a
-     result type or a RuntimeRep argument).
-
- (4) The evidence for the produced Givens is all just reflexive, because
-     we will eventually set the cycle-breaker variable to be the type family,
-     and then, after the zonk, all will be well. See also the notes at the
-     end of the Given section of this Note.
-
- (5) The approach here is inefficient because it replaces every (outermost)
-     type family application with a type variable, regardless of whether that
-     particular appplication is implicated in the occurs check.  An alternative
-     would be to replce only type-family applications that mention the offending LHS.
-     For instance, we could choose to
-     affect only type family applications that mention the offending LHS:
-     e.g. in a ~ (F b, G a), we need to replace only G a, not F b. Furthermore,
-     we could try to detect cases like a ~ (F a, F a) and use the same
-     tyvar to replace F a. (Cf.
-     Note [Flattening type-family applications when matching instances]
-     in GHC.Core.Unify, which
-     goes to this extra effort.) There may be other opportunities for
-     improvement. However, this is really a very small corner case.
-     The investment to craft a clever,
-     performant solution seems unworthwhile.
-
- (6) We often get the predicate associated with a constraint from its
-     evidence with ctPred. We thus must not only make sure the generated
-     CEqCan's fields have the updated RHS type (that is, the one produced
-     by replacing type family applications with fresh variables),
-     but we must also update the evidence itself. This is done by the call to rewriteEqEvidence
-     in canEqCanLHSFinish.
-
- (7) We don't wish to apply this magic on the equalities created
-     by this very same process.
-     Consider this, from typecheck/should_compile/ContextStack2:
-
-       type instance TF (a, b) = (TF a, TF b)
-       t :: (a ~ TF (a, Int)) => ...
-
-       [G] a ~ TF (a, Int)
-
-     The RHS reduces, so we get
-
-       [G] a ~ (TF a, TF Int)
-
-     We then break cycles, to get
-
-       [G] g1 :: a ~ (cbv1, cbv2)
-       [G] g2 :: TF a ~ cbv1
-       [G] g3 :: TF Int ~ cbv2
-
-     g1 gets added to the inert set, as written. But then g2 becomes
-     the work item. g1 rewrites g2 to become
-
-       [G] TF (cbv1, cbv2) ~ cbv1
-
-     which then uses the type instance to become
-
-       [G] (TF cbv1, TF cbv2) ~ cbv1
-
-     which looks remarkably like the Given we started with. If left
-     unchecked, this will end up breaking cycles again, looping ad
-     infinitum (and resulting in a context-stack reduction error,
-     not an outright loop). The solution is easy: don't break cycles
-     on an equality generated by breaking cycles. Instead, we mark this
-     final Given as a CIrredCan with a NonCanonicalReason with the soluble
-     occurs-check bit set (only).
-
-     We track these equalities by giving them a special CtOrigin,
-     CycleBreakerOrigin. This works for both Givens and Wanteds, as
-     we need the logic in the W case for e.g. typecheck/should_fail/T17139.
-     Because this logic needs to work for Wanteds, too, we cannot
-     simply look for a CycleBreakerTv on the left: Wanteds don't use them.
-
- (8) We really want to do this all only when there is a soluble occurs-check
-     failure, not when other problems arise (such as an impredicative
-     equality like alpha ~ forall a. a -> a). That is why breakTyEqCycle_maybe
-     uses cterHasOnlyProblem when looking at the result of checkTypeEq, which
-     checks for many of the invariants on a CEqCan.
--}
-
-{-
-************************************************************************
-*                                                                      *
-                  Evidence transformation
-*                                                                      *
-************************************************************************
--}
-
-data StopOrContinue a
-  = ContinueWith a    -- The constraint was not solved, although it may have
-                      --   been rewritten
-
-  | Stop CtEvidence   -- The (rewritten) constraint was solved
-         SDoc         -- Tells how it was solved
-                      -- Any new sub-goals have been put on the work list
-  deriving (Functor)
-
-instance Outputable a => Outputable (StopOrContinue a) where
-  ppr (Stop ev s)      = text "Stop" <> parens s <+> ppr ev
-  ppr (ContinueWith w) = text "ContinueWith" <+> ppr w
-
-continueWith :: a -> TcS (StopOrContinue a)
-continueWith = return . ContinueWith
-
-stopWith :: CtEvidence -> String -> TcS (StopOrContinue a)
-stopWith ev s = return (Stop ev (text s))
-
-andWhenContinue :: TcS (StopOrContinue a)
-                -> (a -> TcS (StopOrContinue b))
-                -> TcS (StopOrContinue b)
-andWhenContinue tcs1 tcs2
-  = do { r <- tcs1
-       ; case r of
-           Stop ev s       -> return (Stop ev s)
-           ContinueWith ct -> tcs2 ct }
-infixr 0 `andWhenContinue`    -- allow chaining with ($)
-
-rewriteEvidence :: RewriterSet  -- ^ See Note [Wanteds rewrite Wanteds]
-                                -- in GHC.Tc.Types.Constraint
-                -> CtEvidence   -- ^ old evidence
-                -> Reduction    -- ^ new predicate + coercion, of type <type of old evidence> ~ new predicate
-                -> TcS (StopOrContinue CtEvidence)
--- Returns Just new_ev iff either (i)  'co' is reflexivity
---                             or (ii) 'co' is not reflexivity, and 'new_pred' not cached
--- In either case, there is nothing new to do with new_ev
-{-
-     rewriteEvidence old_ev new_pred co
-Main purpose: create new evidence for new_pred;
-              unless new_pred is cached already
-* Returns a new_ev : new_pred, with same wanted/given flag as old_ev
-* If old_ev was wanted, create a binding for old_ev, in terms of new_ev
-* If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev
-* Returns Nothing if new_ev is already cached
-
-        Old evidence    New predicate is               Return new evidence
-        flavour                                        of same flavor
-        -------------------------------------------------------------------
-        Wanted          Already solved or in inert     Nothing
-                        Not                            Just new_evidence
-
-        Given           Already in inert               Nothing
-                        Not                            Just new_evidence
-
-Note [Rewriting with Refl]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-If the coercion is just reflexivity then you may re-use the same
-variable.  But be careful!  Although the coercion is Refl, new_pred
-may reflect the result of unification alpha := ty, so new_pred might
-not _look_ the same as old_pred, and it's vital to proceed from now on
-using new_pred.
-
-The rewriter preserves type synonyms, so they should appear in new_pred
-as well as in old_pred; that is important for good error messages.
-
-If we are rewriting with Refl, then there are no new rewriters to add to
-the rewriter set. We check this with an assertion.
- -}
-
-
-rewriteEvidence rewriters old_ev (Reduction co new_pred)
-  | isReflCo co -- See Note [Rewriting with Refl]
-  = assert (isEmptyRewriterSet rewriters) $
-    continueWith (setCtEvPredType old_ev new_pred)
-
-rewriteEvidence rewriters ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc })
-                (Reduction co new_pred)
-  = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted
-    do { new_ev <- newGivenEvVar loc (new_pred, new_tm)
-       ; continueWith new_ev }
-  where
-    -- mkEvCast optimises ReflCo
-    new_tm = mkEvCast (evId old_evar)
-                (downgradeRole Representational (ctEvRole ev) co)
-
-rewriteEvidence new_rewriters
-                ev@(CtWanted { ctev_dest = dest
-                             , ctev_loc = loc
-                             , ctev_rewriters = rewriters })
-                (Reduction co new_pred)
-  = do { mb_new_ev <- newWanted loc rewriters' new_pred
-       ; massert (coercionRole co == ctEvRole ev)
-       ; setWantedEvTerm dest
-            (mkEvCast (getEvExpr mb_new_ev)
-                      (downgradeRole Representational (ctEvRole ev) (mkSymCo co)))
-       ; case mb_new_ev of
-            Fresh  new_ev -> continueWith new_ev
-            Cached _      -> stopWith ev "Cached wanted" }
-  where
-    rewriters' = rewriters S.<> new_rewriters
-
-
-rewriteEqEvidence :: RewriterSet        -- New rewriters
-                                        -- See GHC.Tc.Types.Constraint
-                                        -- Note [Wanteds rewrite Wanteds]
-                  -> CtEvidence         -- Old evidence :: olhs ~ orhs (not swapped)
-                                        --              or orhs ~ olhs (swapped)
-                  -> SwapFlag
-                  -> Reduction          -- lhs_co :: olhs ~ nlhs
-                  -> Reduction          -- rhs_co :: orhs ~ nrhs
-                  -> TcS CtEvidence     -- Of type nlhs ~ nrhs
--- With reductions (Reduction lhs_co nlhs) (Reduction rhs_co nrhs),
--- rewriteEqEvidence yields, for a given equality (Given g olhs orhs):
--- If not swapped
---      g1 : nlhs ~ nrhs = sym lhs_co ; g ; rhs_co
--- If swapped
---      g1 : nlhs ~ nrhs = sym lhs_co ; Sym g ; rhs_co
---
--- For a wanted equality (Wanted w), we do the dual thing:
--- New  w1 : nlhs ~ nrhs
--- If not swapped
---      w : olhs ~ orhs = lhs_co ; w1 ; sym rhs_co
--- If swapped
---      w : orhs ~ olhs = rhs_co ; sym w1 ; sym lhs_co
---
--- It's all a form of rewriteEvidence, specialised for equalities
-rewriteEqEvidence new_rewriters old_ev swapped (Reduction lhs_co nlhs) (Reduction rhs_co nrhs)
-  | NotSwapped <- swapped
-  , isReflCo lhs_co      -- See Note [Rewriting with Refl]
-  , isReflCo rhs_co
-  = return (setCtEvPredType old_ev new_pred)
-
-  | CtGiven { ctev_evar = old_evar } <- old_ev
-  = do { let new_tm = evCoercion ( mkSymCo lhs_co
-                                  `mkTransCo` maybeSymCo swapped (mkCoVarCo old_evar)
-                                  `mkTransCo` rhs_co)
-       ; newGivenEvVar loc' (new_pred, new_tm) }
-
-  | CtWanted { ctev_dest = dest
-             , ctev_rewriters = rewriters } <- old_ev
-  , let rewriters' = rewriters S.<> new_rewriters
-  = do { (new_ev, hole_co) <- newWantedEq loc' rewriters'
-                                          (ctEvRole old_ev) nlhs nrhs
-       ; let co = maybeSymCo swapped $
-                  lhs_co
-                  `mkTransCo` hole_co
-                  `mkTransCo` mkSymCo rhs_co
-       ; setWantedEq dest co
-       ; traceTcS "rewriteEqEvidence" (vcat [ ppr old_ev
-                                            , ppr nlhs
-                                            , ppr nrhs
-                                            , ppr co
-                                            , ppr new_rewriters ])
-       ; return new_ev }
-
-#if __GLASGOW_HASKELL__ <= 810
-  | otherwise
-  = panic "rewriteEvidence"
-#endif
-  where
-    new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs
-
-      -- equality is like a type class. Bumping the depth is necessary because
-      -- of recursive newtypes, where "reducing" a newtype can actually make
-      -- it bigger. See Note [Newtypes can blow the stack].
-    loc      = ctEvLoc old_ev
-    loc'     = bumpCtLocDepth loc
-
-{-
-************************************************************************
-*                                                                      *
-              Unification
-*                                                                      *
-************************************************************************
-
-Note [unifyWanted]
-~~~~~~~~~~~~~~~~~~
-When decomposing equalities we often create new wanted constraints for
-(s ~ t).  But what if s=t?  Then it'd be faster to return Refl right away.
-
-Rather than making an equality test (which traverses the structure of the
-type, perhaps fruitlessly), unifyWanted traverses the common structure, and
-bales out when it finds a difference by creating a new Wanted constraint.
-But where it succeeds in finding common structure, it just builds a coercion
-to reflect it.
--}
-
-unifyWanted :: RewriterSet -> CtLoc
-            -> Role -> TcType -> TcType -> TcS Coercion
--- Return coercion witnessing the equality of the two types,
--- emitting new work equalities where necessary to achieve that
--- Very good short-cut when the two types are equal, or nearly so
--- See Note [unifyWanted]
--- The returned coercion's role matches the input parameter
-unifyWanted rewriters loc Phantom ty1 ty2
-  = do { kind_co <- unifyWanted rewriters loc Nominal (typeKind ty1) (typeKind ty2)
-       ; return (mkPhantomCo kind_co ty1 ty2) }
-
-unifyWanted rewriters loc role orig_ty1 orig_ty2
-  = go orig_ty1 orig_ty2
-  where
-    go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2
-    go ty1 ty2 | Just ty2' <- coreView ty2 = go ty1 ty2'
-
-    go (FunTy af1 w1 s1 t1) (FunTy af2 w2 s2 t2)
-      | af1 == af2    -- Important!  See #21530
-      = do { co_s <- unifyWanted rewriters loc role s1 s2
-           ; co_t <- unifyWanted rewriters loc role t1 t2
-           ; co_w <- unifyWanted rewriters loc Nominal w1 w2
-           ; return (mkNakedFunCo1 role af1 co_w co_s co_t) }
-
-    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
-      | tc1 == tc2, tys1 `equalLength` tys2
-      , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality
-      = do { cos <- zipWith3M (unifyWanted rewriters loc)
-                              (tyConRoleListX role tc1) tys1 tys2
-           ; return (mkTyConAppCo role tc1 cos) }
-
-    go ty1@(TyVarTy tv) ty2
-      = do { mb_ty <- isFilledMetaTyVar_maybe tv
-           ; case mb_ty of
-                Just ty1' -> go ty1' ty2
-                Nothing   -> bale_out ty1 ty2}
-    go ty1 ty2@(TyVarTy tv)
-      = do { mb_ty <- isFilledMetaTyVar_maybe tv
-           ; case mb_ty of
-                Just ty2' -> go ty1 ty2'
-                Nothing   -> bale_out ty1 ty2 }
-
-    go ty1@(CoercionTy {}) (CoercionTy {})
-      = return (mkReflCo role ty1) -- we just don't care about coercions!
-
-    go ty1 ty2 = bale_out ty1 ty2
-
-    bale_out ty1 ty2
-       | ty1 `tcEqType` ty2 = return (mkReflCo role ty1)
-        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)
-       | otherwise = emitNewWantedEq loc rewriters role orig_ty1 orig_ty2
-
-
-{-
-Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we decompose a dependent tycon we obtain a list of
-mixed wanted type and kind equalities. Ideally we want
-all the kind equalities to get solved first so that we avoid
-generating duplicate kind equalities
-
-For example, consider decomposing a TyCon equality
-
-    (0) [W] T k_fresh (t1::k_fresh) ~ T k1 (t2::k_fresh)
-
-This gives rise to 2 equalities in the solver worklist
-
-    (1) [W] k_fresh ~ k1
-    (2) [W] t1::k_fresh ~ t2::k1
-
-The solver worklist is processed in LIFO order:
-see GHC.Tc.Solver.InertSet.selectWorkItem.
-i.e. (2) is processed _before_ (1). Now, while solving (2)
-we would call `canEqCanLHSHetero` and that would emit a
-wanted kind equality
-
-    (3) [W] k_fresh ~ k1
-
-But (3) is exactly the same as (1)!
-
-To avoid such duplicate wanted constraints from being added to the worklist,
-we ensure that (2) is processed before (1). Since we are processing
-the worklist in a LIFO ordering, we do it by emitting (1) before (2).
-This is exactly what we do in `unifyWanteds`.
-
-NB: This ordering is not needed when we decompose FunTyCons as they are not dependently typed
--}
-
--- NB: Length of [CtLoc] and [Roles] may be infinite
--- but list of RHS [TcType] and LHS [TcType] is finite and both are of equal length
-unifyWanteds :: RewriterSet -> [CtLoc] -> [Role]
-             -> [TcType] -- List of RHS types
-             -> [TcType] -- List of LHS types
-             -> TcS [Coercion]
-unifyWanteds rewriters ctlocs roles rhss lhss = unify_wanteds rewriters $ zip4 ctlocs roles rhss lhss
-  where
-    -- Order is important here
-    -- See Note [Decomposing Dependent TyCons and Processing Wanted Equalities]
-    unify_wanteds _ [] = return []
-    unify_wanteds rewriters ((new_loc, tc_role, ty1, ty2) : rest)
-       = do { cos <- unify_wanteds rewriters rest
-            ; co  <- unifyWanted rewriters new_loc tc_role ty1 ty2
-            ; return (co:cos) }
diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Solver/Interact.hs
+++ /dev/null
@@ -1,2790 +0,0 @@
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
-
-module GHC.Tc.Solver.Interact (
-     solveSimpleGivens,   -- Solves [Ct]
-     solveSimpleWanteds   -- Solves Cts
-  ) where
-
-import GHC.Prelude
-import GHC.Types.Basic ( SwapFlag(..),
-                         infinity, IntWithInf, intGtLimit )
-import GHC.Tc.Solver.Canonical
-import GHC.Types.Var.Set
-
-import GHC.Types.Var
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.TcType
-import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey )
-import GHC.Tc.Instance.FunDeps
-import GHC.Tc.Instance.Family
-import GHC.Tc.Instance.Class ( InstanceWhat(..), safeOverlap )
-
-import GHC.Tc.Types.Evidence
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-import GHC.Tc.Types
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.TcMType( promoteMetaTyVarTo )
-import GHC.Tc.Solver.Types
-import GHC.Tc.Solver.InertSet
-import GHC.Tc.Solver.Monad
-
-import GHC.Core
-import GHC.Core.Type as Type
-import GHC.Core.InstEnv     ( DFunInstType )
-import GHC.Core.Class
-import GHC.Core.TyCon
-import GHC.Core.Predicate
-import GHC.Core.Coercion
-import GHC.Core.FamInstEnv
-import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX )
-import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches
-                               , sfInteractInert, sfInteractTop )
-
-import GHC.Types.SrcLoc
-import GHC.Types.Var.Env
-import GHC.Types.Unique( hasKey )
-
-import GHC.Data.Bag
-import GHC.Data.Pair (Pair(..))
-
-import GHC.Utils.Monad ( concatMapM, foldlM )
-import GHC.Utils.Misc
-
-import GHC.Driver.Session
-
-import qualified GHC.LanguageExtensions as LangExt
-
-import Data.List( deleteFirstsBy )
-import Data.Maybe ( listToMaybe, mapMaybe )
-import Data.Function ( on )
-import qualified Data.Semigroup as S
-
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Maybe
-import Control.Monad
-
-{-
-**********************************************************************
-*                                                                    *
-*                      Main Interaction Solver                       *
-*                                                                    *
-**********************************************************************
-
-Note [Basic Simplifier Plan]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-1. Pick an element from the WorkList if there exists one with depth
-   less than our context-stack depth.
-
-2. Run it down the 'stage' pipeline. Stages are:
-      - canonicalization
-      - inert reactions
-      - spontaneous reactions
-      - top-level interactions
-   Each stage returns a StopOrContinue and may have sideeffected
-   the inerts or worklist.
-
-   The threading of the stages is as follows:
-      - If (Stop) is returned by a stage then we start again from Step 1.
-      - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to
-        the next stage in the pipeline.
-4. If the element has survived (i.e. ContinueWith x) the last stage
-   then we add it in the inerts and jump back to Step 1.
-
-If in Step 1 no such element exists, we have exceeded our context-stack
-depth and will simply fail.
--}
-
-solveSimpleGivens :: [Ct] -> TcS ()
-solveSimpleGivens givens
-  | null givens  -- Shortcut for common case
-  = return ()
-  | otherwise
-  = do { traceTcS "solveSimpleGivens {" (ppr givens)
-       ; go givens
-       ; traceTcS "End solveSimpleGivens }" empty }
-  where
-    go givens = do { solveSimples (listToBag givens)
-                   ; new_givens <- runTcPluginsGiven
-                   ; when (notNull new_givens) $
-                     go new_givens }
-
-solveSimpleWanteds :: Cts -> TcS WantedConstraints
--- The result is not necessarily zonked
-solveSimpleWanteds simples
-  = do { traceTcS "solveSimpleWanteds {" (ppr simples)
-       ; dflags <- getDynFlags
-       ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples })
-       ; traceTcS "solveSimpleWanteds end }" $
-             vcat [ text "iterations =" <+> ppr n
-                  , text "residual =" <+> ppr wc ]
-       ; return wc }
-  where
-    go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints)
-    go n limit wc
-      | n `intGtLimit` limit
-      = failTcS $ TcRnSimplifierTooManyIterations simples limit wc
-     | isEmptyBag (wc_simple wc)
-     = return (n,wc)
-
-     | otherwise
-     = do { -- Solve
-            wc1 <- solve_simple_wanteds wc
-
-            -- Run plugins
-          ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1
-
-          ; if rerun_plugin
-            then do { traceTcS "solveSimple going round again:" (ppr rerun_plugin)
-                    ; go (n+1) limit wc2 }   -- Loop
-            else return (n, wc2) }           -- Done
-
-
-solve_simple_wanteds :: WantedConstraints -> TcS WantedConstraints
--- Try solving these constraints
--- Affects the unification state (of course) but not the inert set
--- The result is not necessarily zonked
-solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_errors = errs })
-  = nestTcS $
-    do { solveSimples simples1
-       ; (implics2, unsolved) <- getUnsolvedInerts
-       ; return (WC { wc_simple = unsolved
-                    , wc_impl   = implics1 `unionBags` implics2
-                    , wc_errors = errs }) }
-
-{- Note [The solveSimpleWanteds loop]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Solving a bunch of simple constraints is done in a loop,
-(the 'go' loop of 'solveSimpleWanteds'):
-  1. Try to solve them
-  2. Try the plugin
-  3. If the plugin wants to run again, go back to step 1
--}
-
--- The main solver loop implements Note [Basic Simplifier Plan]
----------------------------------------------------------------
-solveSimples :: Cts -> TcS ()
--- Returns the final InertSet in TcS
--- Has no effect on work-list or residual-implications
--- The constraints are initially examined in left-to-right order
-
-solveSimples cts
-  = {-# SCC "solveSimples" #-}
-    do { updWorkListTcS (\wl -> foldr extendWorkListCt wl cts)
-       ; solve_loop }
-  where
-    solve_loop
-      = {-# SCC "solve_loop" #-}
-        do { sel <- selectNextWorkItem
-           ; case sel of
-              Nothing -> return ()
-              Just ct -> do { runSolverPipeline thePipeline ct
-                            ; solve_loop } }
-
--- | Extract the (inert) givens and invoke the plugins on them.
--- Remove solved givens from the inert set and emit insolubles, but
--- return new work produced so that 'solveSimpleGivens' can feed it back
--- into the main solver.
-runTcPluginsGiven :: TcS [Ct]
-runTcPluginsGiven
-  = do { solvers <- getTcPluginSolvers
-       ; if null solvers then return [] else
-    do { givens <- getInertGivens
-       ; if null givens then return [] else
-    do { p <- runTcPluginSolvers solvers (givens,[])
-       ; let (solved_givens, _) = pluginSolvedCts p
-             insols             = pluginBadCts p
-       ; updInertCans (removeInertCts solved_givens)
-       ; updInertIrreds (\irreds -> extendCtsList irreds insols)
-       ; return (pluginNewCts p) } } }
-
--- | Given a bag of (rewritten, zonked) wanteds, invoke the plugins on
--- them and produce an updated bag of wanteds (possibly with some new
--- work) and a bag of insolubles.  The boolean indicates whether
--- 'solveSimpleWanteds' should feed the updated wanteds back into the
--- main solver.
-runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints)
-runTcPluginsWanted wc@(WC { wc_simple = simples1 })
-  | isEmptyBag simples1
-  = return (False, wc)
-  | otherwise
-  = do { solvers <- getTcPluginSolvers
-       ; if null solvers then return (False, wc) else
-
-    do { given <- getInertGivens
-       ; wanted <- zonkSimples simples1    -- Plugin requires zonked inputs
-       ; p <- runTcPluginSolvers solvers (given, bagToList wanted)
-       ; let (_, solved_wanted)   = pluginSolvedCts p
-             (_, unsolved_wanted) = pluginInputCts p
-             new_wanted                             = pluginNewCts p
-             insols                                 = pluginBadCts p
-
--- SLPJ: I'm deeply suspicious of this
---       ; updInertCans (removeInertCts $ solved_givens)
-
-       ; mapM_ setEv solved_wanted
-       ; return ( notNull (pluginNewCts p)
-                , wc { wc_simple = listToBag new_wanted       `andCts`
-                                   listToBag unsolved_wanted  `andCts`
-                                   listToBag insols } ) } }
-  where
-    setEv :: (EvTerm,Ct) -> TcS ()
-    setEv (ev,ct) = case ctEvidence ct of
-      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev
-      _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!"
-
--- | A pair of (given, wanted) constraints to pass to plugins
-type SplitCts  = ([Ct], [Ct])
-
--- | A solved pair of constraints, with evidence for wanteds
-type SolvedCts = ([Ct], [(EvTerm,Ct)])
-
--- | Represents collections of constraints generated by typechecker
--- plugins
-data TcPluginProgress = TcPluginProgress
-    { pluginInputCts  :: SplitCts
-      -- ^ Original inputs to the plugins with solved/bad constraints
-      -- removed, but otherwise unmodified
-    , pluginSolvedCts :: SolvedCts
-      -- ^ Constraints solved by plugins
-    , pluginBadCts    :: [Ct]
-      -- ^ Constraints reported as insoluble by plugins
-    , pluginNewCts    :: [Ct]
-      -- ^ New constraints emitted by plugins
-    }
-
-getTcPluginSolvers :: TcS [TcPluginSolver]
-getTcPluginSolvers
-  = do { tcg_env <- getGblEnv; return (tcg_tc_plugin_solvers tcg_env) }
-
--- | Starting from a pair of (given, wanted) constraints,
--- invoke each of the typechecker constraint-solving plugins in turn and return
---
---  * the remaining unmodified constraints,
---  * constraints that have been solved,
---  * constraints that are insoluble, and
---  * new work.
---
--- Note that new work generated by one plugin will not be seen by
--- other plugins on this pass (but the main constraint solver will be
--- re-invoked and they will see it later).  There is no check that new
--- work differs from the original constraints supplied to the plugin:
--- the plugin itself should perform this check if necessary.
-runTcPluginSolvers :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress
-runTcPluginSolvers solvers all_cts
-  = do { ev_binds_var <- getTcEvBindsVar
-       ; foldM (do_plugin ev_binds_var) initialProgress solvers }
-  where
-    do_plugin :: EvBindsVar -> TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress
-    do_plugin ev_binds_var p solver = do
-        result <- runTcPluginTcS (uncurry (solver ev_binds_var) (pluginInputCts p))
-        return $ progress p result
-
-    progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress
-    progress p
-      (TcPluginSolveResult
-        { tcPluginInsolubleCts = bad_cts
-        , tcPluginSolvedCts    = solved_cts
-        , tcPluginNewCts       = new_cts
-        }
-      ) =
-        p { pluginInputCts  = discard (bad_cts ++ map snd solved_cts) (pluginInputCts p)
-          , pluginSolvedCts = add solved_cts (pluginSolvedCts p)
-          , pluginNewCts    = new_cts ++ pluginNewCts p
-          , pluginBadCts    = bad_cts ++ pluginBadCts p
-          }
-
-    initialProgress = TcPluginProgress all_cts ([], []) [] []
-
-    discard :: [Ct] -> SplitCts -> SplitCts
-    discard cts (xs, ys) =
-        (xs `without` cts, ys `without` cts)
-
-    without :: [Ct] -> [Ct] -> [Ct]
-    without = deleteFirstsBy eqCt
-
-    eqCt :: Ct -> Ct -> Bool
-    eqCt c c' = ctFlavour c == ctFlavour c'
-             && ctPred c `tcEqType` ctPred c'
-
-    add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts
-    add xs scs = foldl' addOne scs xs
-
-    addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts
-    addOne (givens, wanteds) (ev,ct) = case ctEvidence ct of
-      CtGiven  {} -> (ct:givens, wanteds)
-      CtWanted {} -> (givens, (ev,ct):wanteds)
-
-
-type WorkItem = Ct
-type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct)
-
-runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline
-                  -> WorkItem                   -- The work item
-                  -> TcS ()
--- Run this item down the pipeline, leaving behind new work and inerts
-runSolverPipeline pipeline workItem
-  = do { wl <- getWorkList
-       ; inerts <- getTcSInerts
-       ; tclevel <- getTcLevel
-       ; traceTcS "----------------------------- " empty
-       ; traceTcS "Start solver pipeline {" $
-                  vcat [ text "tclevel =" <+> ppr tclevel
-                       , text "work item =" <+> ppr workItem
-                       , text "inerts =" <+> ppr inerts
-                       , text "rest of worklist =" <+> ppr wl ]
-
-       ; bumpStepCountTcS    -- One step for each constraint processed
-       ; final_res  <- run_pipeline pipeline (ContinueWith workItem)
-
-       ; case final_res of
-           Stop ev s       -> do { traceFireTcS ev s
-                                 ; traceTcS "End solver pipeline (discharged) }" empty
-                                 ; return () }
-           ContinueWith ct -> do { addInertCan ct
-                                 ; traceFireTcS (ctEvidence ct) (text "Kept as inert")
-                                 ; traceTcS "End solver pipeline (kept as inert) }" $
-                                            (text "final_item =" <+> ppr ct) }
-       }
-  where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct
-                     -> TcS (StopOrContinue Ct)
-        run_pipeline [] res        = return res
-        run_pipeline _ (Stop ev s) = return (Stop ev s)
-        run_pipeline ((stg_name,stg):stgs) (ContinueWith ct)
-          = do { traceTcS ("runStage " ++ stg_name ++ " {")
-                          (text "workitem   = " <+> ppr ct)
-               ; res <- stg ct
-               ; traceTcS ("end stage " ++ stg_name ++ " }") empty
-               ; run_pipeline stgs res }
-
-{-
-Example 1:
-  Inert:   {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given)
-  Reagent: a ~ [b] (given)
-
-React with (c~d)     ==> IR (ContinueWith (a~[b]))  True    []
-React with (F a ~ t) ==> IR (ContinueWith (a~[b]))  False   [F [b] ~ t]
-React with (b ~ Int) ==> IR (ContinueWith (a~[Int]) True    []
-
-Example 2:
-  Inert:  {c ~w d, F a ~g t, b ~w Int, a ~w ty}
-  Reagent: a ~w [b]
-
-React with (c ~w d)   ==> IR (ContinueWith (a~[b]))  True    []
-React with (F a ~g t) ==> IR (ContinueWith (a~[b]))  True    []    (can't rewrite given with wanted!)
-etc.
-
-Example 3:
-  Inert:  {a ~ Int, F Int ~ b} (given)
-  Reagent: F a ~ b (wanted)
-
-React with (a ~ Int)   ==> IR (ContinueWith (F Int ~ b)) True []
-React with (F Int ~ b) ==> IR Stop True []    -- after substituting we re-canonicalize and get nothing
--}
-
-thePipeline :: [(String,SimplifierStage)]
-thePipeline = [ ("canonicalization",        GHC.Tc.Solver.Canonical.canonicalize)
-              , ("interact with inerts",    interactWithInertsStage)
-              , ("top-level reactions",     topReactionsStage) ]
-
-{-
-*********************************************************************************
-*                                                                               *
-                       The interact-with-inert Stage
-*                                                                               *
-*********************************************************************************
-
-Note [The Solver Invariant]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We always add Givens first.  So you might think that the solver has
-the invariant
-
-   If the work-item is Given,
-   then the inert item must Given
-
-But this isn't quite true.  Suppose we have,
-    c1: [W] beta ~ [alpha], c2 : [W] blah, c3 :[W] alpha ~ Int
-After processing the first two, we get
-     c1: [G] beta ~ [alpha], c2 : [W] blah
-Now, c3 does not interact with the given c1, so when we spontaneously
-solve c3, we must re-react it with the inert set.  So we can attempt a
-reaction between inert c2 [W] and work-item c3 [G].
-
-It *is* true that [Solver Invariant]
-   If the work-item is Given,
-   AND there is a reaction
-   then the inert item must Given
-or, equivalently,
-   If the work-item is Given,
-   and the inert item is Wanted
-   then there is no reaction
--}
-
--- Interaction result of  WorkItem <~> Ct
-
-interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct)
--- Precondition: if the workitem is a CEqCan then it will not be able to
--- react with anything at this stage (except, maybe, via a type family
--- dependency)
-
-interactWithInertsStage wi
-  = do { inerts <- getTcSInerts
-       ; let ics = inert_cans inerts
-       ; case wi of
-             CEqCan       {} -> interactEq      ics wi
-             CIrredCan    {} -> interactIrred   ics wi
-             CDictCan     {} -> interactDict    ics wi
-             _ -> pprPanic "interactWithInerts" (ppr wi) }
-                -- CNonCanonical have been canonicalised
-
-data InteractResult
-   = KeepInert   -- Keep the inert item, and solve the work item from it
-                 -- (if the latter is Wanted; just discard it if not)
-   | KeepWork    -- Keep the work item, and solve the inert item from it
-
-instance Outputable InteractResult where
-  ppr KeepInert = text "keep inert"
-  ppr KeepWork  = text "keep work-item"
-
-solveOneFromTheOther :: Ct  -- Inert    (Dict or Irred)
-                     -> Ct  -- WorkItem (same predicate as inert)
-                     -> TcS InteractResult
--- Precondition:
--- * inert and work item represent evidence for the /same/ predicate
--- * Both are CDictCan or CIrredCan
---
--- We can always solve one from the other: even if both are wanted,
--- although we don't rewrite wanteds with wanteds, we can combine
--- two wanteds into one by solving one from the other
-
-solveOneFromTheOther ct_i ct_w
-  | CtWanted { ctev_loc = loc_w } <- ev_w
-  , prohibitedSuperClassSolve loc_i loc_w
-  = -- Inert must be Given
-    do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w)
-       ; return KeepWork }
-
-  | CtWanted {} <- ev_w
-  = -- Inert is Given or Wanted
-    case ev_i of
-      CtGiven {} -> return KeepInert
-        -- work is Wanted; inert is Given: easy choice.
-
-      CtWanted {} -- Both are Wanted
-        -- If only one has no pending superclasses, use it
-        -- Otherwise we can get infinite superclass expansion (#22516)
-        -- in silly cases like   class C T b => C a b where ...
-        | not is_psc_i, is_psc_w     -> return KeepInert
-        | is_psc_i,     not is_psc_w -> return KeepWork
-
-        -- If only one is a WantedSuperclassOrigin (arising from expanding
-        -- a Wanted class constraint), keep the other: wanted superclasses
-        -- may be unexpected by users
-        | not is_wsc_orig_i, is_wsc_orig_w     -> return KeepInert
-        | is_wsc_orig_i,     not is_wsc_orig_w -> return KeepWork
-
-        -- otherwise, just choose the lower span
-        -- reason: if we have something like (abs 1) (where the
-        -- Num constraint cannot be satisfied), it's better to
-        -- get an error about abs than about 1.
-        -- This test might become more elaborate if we see an
-        -- opportunity to improve the error messages
-        | ((<) `on` ctLocSpan) loc_i loc_w -> return KeepInert
-        | otherwise                        -> return KeepWork
-
-  -- From here on the work-item is Given
-
-  | CtWanted { ctev_loc = loc_i } <- ev_i
-  , prohibitedSuperClassSolve loc_w loc_i
-  = do { traceTcS "prohibitedClassSolve2" (ppr ev_i $$ ppr ev_w)
-       ; return KeepInert }      -- Just discard the un-usable Given
-                                 -- This never actually happens because
-                                 -- Givens get processed first
-
-  | CtWanted {} <- ev_i
-  = return KeepWork
-
-  -- From here on both are Given
-  -- See Note [Replacement vs keeping]
-
-  | lvl_i == lvl_w
-  = return same_level_strategy
-
-  | otherwise   -- Both are Given, levels differ
-  = return different_level_strategy
-  where
-     ev_i  = ctEvidence ct_i
-     ev_w  = ctEvidence ct_w
-
-     pred  = ctEvPred ev_i
-
-     loc_i = ctEvLoc ev_i
-     loc_w = ctEvLoc ev_w
-     lvl_i = ctLocLevel loc_i
-     lvl_w = ctLocLevel loc_w
-
-     is_psc_w = isPendingScDict ct_w
-     is_psc_i = isPendingScDict ct_i
-
-     is_wsc_orig_i = is_wanted_superclass_loc loc_i
-     is_wsc_orig_w = is_wanted_superclass_loc loc_w
-     is_wanted_superclass_loc = isWantedSuperclassOrigin . ctLocOrigin
-
-     different_level_strategy  -- Both Given
-       | isIPLikePred pred = if lvl_w > lvl_i then KeepWork  else KeepInert
-       | otherwise         = if lvl_w > lvl_i then KeepInert else KeepWork
-       -- See Note [Replacement vs keeping] part (1)
-       -- For the isIPLikePred case see Note [Shadowing of Implicit Parameters]
-
-     same_level_strategy -- Both Given
-       = case (ctLocOrigin loc_i, ctLocOrigin loc_w) of
-              -- case 2(a) from Note [Replacement vs keeping]
-           (InstSCOrigin _depth_i size_i, InstSCOrigin _depth_w size_w)
-             | size_w < size_i -> KeepWork
-             | otherwise       -> KeepInert
-
-              -- case 2(c) from Note [Replacement vs keeping]
-           (InstSCOrigin depth_i _, OtherSCOrigin depth_w _)  -> choose_shallower depth_i depth_w
-           (OtherSCOrigin depth_i _, InstSCOrigin depth_w _)  -> choose_shallower depth_i depth_w
-           (OtherSCOrigin depth_i _, OtherSCOrigin depth_w _) -> choose_shallower depth_i depth_w
-
-              -- case 2(b) from Note [Replacement vs keeping]
-           (InstSCOrigin {}, _)                         -> KeepWork
-           (OtherSCOrigin {}, _)                        -> KeepWork
-
-             -- case 2(d) from Note [Replacement vs keeping]
-           _                                      -> KeepInert
-
-     choose_shallower depth_i depth_w | depth_w < depth_i = KeepWork
-                                      | otherwise         = KeepInert
-       -- favor KeepInert in the equals case, according to 2(d) from the Note
-
-{-
-Note [Replacement vs keeping]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we have two Given constraints both of type (C tys), say, which should
-we keep?  More subtle than you might think! This is all implemented in
-solveOneFromTheOther.
-
-  1) Constraints come from different levels (different_level_strategy)
-
-      - For implicit parameters we want to keep the innermost (deepest)
-        one, so that it overrides the outer one.
-        See Note [Shadowing of Implicit Parameters]
-
-      - For everything else, we want to keep the outermost one.  Reason: that
-        makes it more likely that the inner one will turn out to be unused,
-        and can be reported as redundant.  See Note [Tracking redundant constraints]
-        in GHC.Tc.Solver.
-
-        It transpires that using the outermost one is responsible for an
-        8% performance improvement in nofib cryptarithm2, compared to
-        just rolling the dice.  I didn't investigate why.
-
-  2) Constraints coming from the same level (i.e. same implication)
-
-       (a) If both are InstSCOrigin, choose the one with the smallest TypeSize,
-           according to Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance.
-
-       (b) Prefer constraints that are not superclass selections. Example:
-
-             f :: (Eq a, Ord a) => a -> Bool
-             f x = x == x
-
-           Eager superclass expansion gives us two [G] Eq a constraints. We
-           want to keep the one from the user-written Eq a, not the superclass
-           selection. This means we report the Ord a as redundant with
-           -Wredundant-constraints, not the Eq a.
-
-           Getting this wrong was #20602. See also
-           Note [Tracking redundant constraints] in GHC.Tc.Solver.
-
-       (c) If both are superclass selections (but not both InstSCOrigin), choose the one
-           with the shallower superclass-selection depth, in the hope of identifying
-           more correct redundant constraints. This is really a generalization of
-           point (b), because the superclass depth of a non-superclass
-           constraint is 0.
-
-       (d) Finally, when there is still a choice, use KeepInert rather than
-           KeepWork, for two reasons:
-             - to avoid unnecessary munging of the inert set.
-             - to cut off superclass loops; see Note [Superclass loops] in GHC.Tc.Solver.Canonical
-
-Doing the level-check for implicit parameters, rather than making the work item
-always override, is important.  Consider
-
-    data T a where { T1 :: (?x::Int) => T Int; T2 :: T a }
-
-    f :: (?x::a) => T a -> Int
-    f T1 = ?x
-    f T2 = 3
-
-We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add
-two new givens in the work-list:  [G] (?x::Int)
-                                  [G] (a ~ Int)
-Now consider these steps
-  - process a~Int, kicking out (?x::a)
-  - process (?x::Int), the inner given, adding to inert set
-  - process (?x::a), the outer given, overriding the inner given
-Wrong!  The level-check ensures that the inner implicit parameter wins.
-(Actually I think that the order in which the work-list is processed means
-that this chain of events won't happen, but that's very fragile.)
-
-*********************************************************************************
-*                                                                               *
-                   interactIrred
-*                                                                               *
-*********************************************************************************
-
-Note [Multiple matching irreds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-You might think that it's impossible to have multiple irreds all match the
-work item; after all, interactIrred looks for matches and solves one from the
-other. However, note that interacting insoluble, non-droppable irreds does not
-do this matching. We thus might end up with several insoluble, non-droppable,
-matching irreds in the inert set. When another irred comes along that we have
-not yet labeled insoluble, we can find multiple matches. These multiple matches
-cause no harm, but it would be wrong to ASSERT that they aren't there (as we
-once had done). This problem can be tickled by typecheck/should_compile/holes.
-
--}
-
--- Two pieces of irreducible evidence: if their types are *exactly identical*
--- we can rewrite them. We can never improve using this:
--- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not
--- mean that (ty1 ~ ty2)
-interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct)
-
-interactIrred inerts ct_w@(CIrredCan { cc_ev = ev_w, cc_reason = reason })
-  | isInsolubleReason reason
-               -- For insolubles, don't allow the constraint to be dropped
-               -- which can happen with solveOneFromTheOther, so that
-               -- we get distinct error messages with -fdefer-type-errors
-  = continueWith ct_w
-
-  | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w
-  , ((ct_i, swap) : _rest) <- bagToList matching_irreds
-        -- See Note [Multiple matching irreds]
-  , let ev_i = ctEvidence ct_i
-  = do { what_next <- solveOneFromTheOther ct_i ct_w
-       ; traceTcS "iteractIrred" (ppr ct_w $$ ppr what_next $$ ppr ct_i)
-       ; case what_next of
-            KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i)
-                            ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) }
-            KeepWork ->  do { setEvBindIfWanted ev_i (swap_me swap ev_w)
-                            ; updInertIrreds (\_ -> others)
-                            ; continueWith ct_w } }
-
-  | otherwise
-  = continueWith ct_w
-
-  where
-    swap_me :: SwapFlag -> CtEvidence -> EvTerm
-    swap_me swap ev
-      = case swap of
-           NotSwapped -> ctEvTerm ev
-           IsSwapped  -> evCoercion (mkSymCo (evTermCoercion (ctEvTerm ev)))
-
-interactIrred _ wi = pprPanic "interactIrred" (ppr wi)
-
-findMatchingIrreds :: Cts -> CtEvidence -> (Bag (Ct, SwapFlag), Bag Ct)
-findMatchingIrreds irreds ev
-  | EqPred eq_rel1 lty1 rty1 <- classifyPredType pred
-    -- See Note [Solving irreducible equalities]
-  = partitionBagWith (match_eq eq_rel1 lty1 rty1) irreds
-  | otherwise
-  = partitionBagWith match_non_eq irreds
-  where
-    pred = ctEvPred ev
-    match_non_eq ct
-      | ctPred ct `tcEqTypeNoKindCheck` pred = Left (ct, NotSwapped)
-      | otherwise                            = Right ct
-
-    match_eq eq_rel1 lty1 rty1 ct
-      | EqPred eq_rel2 lty2 rty2 <- classifyPredType (ctPred ct)
-      , eq_rel1 == eq_rel2
-      , Just swap <- match_eq_help lty1 rty1 lty2 rty2
-      = Left (ct, swap)
-      | otherwise
-      = Right ct
-
-    match_eq_help lty1 rty1 lty2 rty2
-      | lty1 `tcEqTypeNoKindCheck` lty2, rty1 `tcEqTypeNoKindCheck` rty2
-      = Just NotSwapped
-      | lty1 `tcEqTypeNoKindCheck` rty2, rty1 `tcEqTypeNoKindCheck` lty2
-      = Just IsSwapped
-      | otherwise
-      = Nothing
-
-{- Note [Solving irreducible equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#14333)
-  [G] a b ~R# c d
-  [W] c d ~R# a b
-Clearly we should be able to solve this! Even though the constraints are
-not decomposable. We solve this when looking up the work-item in the
-irreducible constraints to look for an identical one.  When doing this
-lookup, findMatchingIrreds spots the equality case, and matches either
-way around. It has to return a swap-flag so we can generate evidence
-that is the right way round too.
--}
-
-{-
-*********************************************************************************
-*                                                                               *
-                   interactDict
-*                                                                               *
-*********************************************************************************
-
-Note [Shortcut solving]
-~~~~~~~~~~~~~~~~~~~~~~~
-When we interact a [W] constraint with a [G] constraint that solves it, there is
-a possibility that we could produce better code if instead we solved from a
-top-level instance declaration (See #12791, #5835). For example:
-
-    class M a b where m :: a -> b
-
-    type C a b = (Num a, M a b)
-
-    f :: C Int b => b -> Int -> Int
-    f _ x = x + 1
-
-The body of `f` requires a [W] `Num Int` instance. We could solve this
-constraint from the givens because we have `C Int b` and that provides us a
-solution for `Num Int`. This would let us produce core like the following
-(with -O2):
-
-    f :: forall b. C Int b => b -> Int -> Int
-    f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) ->
-        + @ Int
-          (GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%))
-          eta1
-          A.f1
-
-This is bad! We could do /much/ better if we solved [W] `Num Int` directly
-from the instance that we have in scope:
-
-    f :: forall b. C Int b => b -> Int -> Int
-    f = \ (@ b) _ _ (x :: Int) ->
-        case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) }
-
-** NB: It is important to emphasize that all this is purely an optimization:
-** exactly the same programs should typecheck with or without this
-** procedure.
-
-Solving fully
-~~~~~~~~~~~~~
-There is a reason why the solver does not simply try to solve such
-constraints with top-level instances. If the solver finds a relevant
-instance declaration in scope, that instance may require a context
-that can't be solved for. A good example of this is:
-
-    f :: Ord [a] => ...
-    f x = ..Need Eq [a]...
-
-If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would
-be left with the obligation to solve the constraint Eq a, which we cannot. So we
-must be conservative in our attempt to use an instance declaration to solve the
-[W] constraint we're interested in.
-
-Our rule is that we try to solve all of the instance's subgoals
-recursively all at once. Precisely: We only attempt to solve
-constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci
-are themselves class constraints of the form `C1', ... Cm' => C' t1'
-... tn'` and we only succeed if the entire tree of constraints is
-solvable from instances.
-
-An example that succeeds:
-
-    class Eq a => C a b | b -> a where
-      m :: b -> a
-
-    f :: C [Int] b => b -> Bool
-    f x = m x == []
-
-We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This
-produces the following core:
-
-    f :: forall b. C [Int] b => b -> Bool
-    f = \ (@ b) ($dC :: C [Int] b) (x :: b) ->
-        GHC.Classes.$fEq[]_$s$c==
-          (m @ [Int] @ b $dC x) (GHC.Types.[] @ Int)
-
-An example that fails:
-
-    class Eq a => C a b | b -> a where
-      m :: b -> a
-
-    f :: C [a] b => b -> Bool
-    f x = m x == []
-
-Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces:
-
-    f :: forall a b. C [a] b => b -> Bool
-    f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) ->
-        ==
-          @ [a]
-          (A.$p1C @ [a] @ b $dC)
-          (m @ [a] @ b $dC eta)
-          (GHC.Types.[] @ a)
-
-Note [Shortcut solving: type families]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have (#13943)
-  class Take (n :: Nat) where ...
-  instance {-# OVERLAPPING #-}                    Take 0 where ..
-  instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where ..
-
-And we have [W] Take 3.  That only matches one instance so we get
-[W] Take (3-1).  Really we should now rewrite to reduce the (3-1) to 2, and
-so on -- but that is reproducing yet more of the solver.  Sigh.  For now,
-we just give up (remember all this is just an optimisation).
-
-But we must not just naively try to lookup (Take (3-1)) in the
-InstEnv, or it'll (wrongly) appear not to match (Take 0) and get a
-unique match on the (Take n) instance.  That leads immediately to an
-infinite loop.  Hence the check that 'preds' have no type families
-(isTyFamFree).
-
-Note [Shortcut solving: incoherence]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This optimization relies on coherence of dictionaries to be correct. When we
-cannot assume coherence because of IncoherentInstances then this optimization
-can change the behavior of the user's code.
-
-The following four modules produce a program whose output would change depending
-on whether we apply this optimization when IncoherentInstances is in effect:
-
-=========
-    {-# LANGUAGE MultiParamTypeClasses #-}
-    module A where
-
-    class A a where
-      int :: a -> Int
-
-    class A a => C a b where
-      m :: b -> a -> a
-
-=========
-    {-# LANGUAGE FlexibleInstances     #-}
-    {-# LANGUAGE MultiParamTypeClasses #-}
-    module B where
-
-    import A
-
-    instance A a where
-      int _ = 1
-
-    instance C a [b] where
-      m _ = id
-
-=========
-    {-# LANGUAGE FlexibleContexts      #-}
-    {-# LANGUAGE FlexibleInstances     #-}
-    {-# LANGUAGE IncoherentInstances   #-}
-    {-# LANGUAGE MultiParamTypeClasses #-}
-    module C where
-
-    import A
-
-    instance A Int where
-      int _ = 2
-
-    instance C Int [Int] where
-      m _ = id
-
-    intC :: C Int a => a -> Int -> Int
-    intC _ x = int x
-
-=========
-    module Main where
-
-    import A
-    import B
-    import C
-
-    main :: IO ()
-    main = print (intC [] (0::Int))
-
-The output of `main` if we avoid the optimization under the effect of
-IncoherentInstances is `1`. If we were to do the optimization, the output of
-`main` would be `2`.
-
-Note [Shortcut try_solve_from_instance]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The workhorse of the short-cut solver is
-    try_solve_from_instance :: (EvBindMap, DictMap CtEvidence)
-                            -> CtEvidence       -- Solve this
-                            -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
-Note that:
-
-* The CtEvidence is the goal to be solved
-
-* The MaybeT manages early failure if we find a subgoal that
-  cannot be solved from instances.
-
-* The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional
-  state that allows try_solve_from_instance to augment the evidence
-  bindings and inert_solved_dicts as it goes.
-
-  If it succeeds, we commit all these bindings and solved dicts to the
-  main TcS InertSet.  If not, we abandon it all entirely.
-
-Passing along the solved_dicts important for two reasons:
-
-* We need to be able to handle recursive super classes. The
-  solved_dicts state  ensures that we remember what we have already
-  tried to solve to avoid looping.
-
-* As #15164 showed, it can be important to exploit sharing between
-  goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H;
-  and to solve G2 we may need H. If we don't spot this sharing we may
-  solve H twice; and if this pattern repeats we may get exponentially bad
-  behaviour.
-
-Note [No Given/Given fundeps]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not create constraints from:
-* Given/Given interactions via functional dependencies or type family
-  injectivity annotations.
-* Given/instance fundep interactions via functional dependencies or
-  type family injectivity annotations.
-
-In this Note, all these interactions are called just "fundeps".
-
-We ingore such fundeps for several reasons:
-
-1. These fundeps will never serve a purpose in accepting more
-   programs: Given constraints do not contain metavariables that could
-   be unified via exploring fundeps. They *could* be useful in
-   discovering inaccessible code. However, the constraints will be
-   Wanteds, and as such will cause errors (not just warnings) if they
-   go unsolved. Maybe there is a clever way to get the right
-   inaccessible code warnings, but the path forward is far from
-   clear. #12466 has further commentary.
-
-2. Furthermore, here is a case where a Given/instance interaction is actively
-   harmful (from dependent/should_compile/RaeJobTalk):
-
-       type family a == b :: Bool
-       type family Not a = r | r -> a where
-         Not False = True
-         Not True  = False
-
-       [G] Not (a == b) ~ True
-
-   Reacting this Given with the equations for Not produces
-
-      [W] a == b ~ False
-
-   This is indeed a true consequence, and would make sense as a fresh Given.
-   But we don't have a way to produce evidence for fundeps, as a Wanted it
-   is /harmful/: we can't prove it, and so we'll report an error and reject
-   the program. (Previously fundeps gave rise to Deriveds, which
-   carried no evidence, so it didn't matter that they could not be proved.)
-
-3. #20922 showed a subtle different problem with Given/instance fundeps.
-      type family ZipCons (as :: [k]) (bssx :: [[k]]) = (r :: [[k]]) | r -> as bssx where
-        ZipCons (a ': as) (bs ': bss) = (a ': bs) ': ZipCons as bss
-        ...
-
-      tclevel = 4
-      [G] ZipCons is1 iss ~ (i : is2) : jss
-
-   (The tclevel=4 means that this Given is at level 4.)  The fundep tells us that
-   'iss' must be of form (is2 : beta[4]) where beta[4] is a fresh unification
-   variable; we don't know what type it stands for. So we would emit
-      [W] iss ~ is2 : beta
-
-   Again we can't prove that equality; and worse we'll rewrite iss to
-   (is2:beta) in deeply nested constraints inside this implication,
-   where beta is untouchable (under other equality constraints), leading
-   to other insoluble constraints.
-
-The bottom line: since we have no evidence for them, we should ignore Given/Given
-and Given/instance fundeps entirely.
--}
-
-interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)
-interactDict inerts ct_w@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })
-  | Just ct_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys
-  , let ev_i = ctEvidence ct_i
-  = -- There is a matching dictionary in the inert set
-    do { -- First to try to solve it /completely/ from top level instances
-         -- See Note [Shortcut solving]
-         dflags <- getDynFlags
-       ; short_cut_worked <- shortCutSolver dflags ev_w ev_i
-       ; if short_cut_worked
-         then stopWith ev_w "interactDict/solved from instance"
-         else
-
-    do { -- Ths short-cut solver didn't fire, so we
-         -- solve ev_w from the matching inert ev_i we found
-         what_next <- solveOneFromTheOther ct_i ct_w
-       ; traceTcS "lookupInertDict" (ppr what_next)
-       ; case what_next of
-           KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i)
-                           ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) }
-           KeepWork  -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w)
-                           ; updInertDicts $ \ ds -> delDict ds cls tys
-                           ; continueWith ct_w } } }
-
-  | cls `hasKey` ipClassKey
-  , isGiven ev_w
-  = interactGivenIP inerts ct_w
-
-  | otherwise
-  = do { addFunDepWork inerts ev_w cls
-       ; continueWith ct_w  }
-
-interactDict _ wi = pprPanic "interactDict" (ppr wi)
-
--- See Note [Shortcut solving]
-shortCutSolver :: DynFlags
-               -> CtEvidence -- Work item
-               -> CtEvidence -- Inert we want to try to replace
-               -> TcS Bool   -- True <=> success
-shortCutSolver dflags ev_w ev_i
-  | isWanted ev_w
- && isGiven ev_i
- -- We are about to solve a [W] constraint from a [G] constraint. We take
- -- a moment to see if we can get a better solution using an instance.
- -- Note that we only do this for the sake of performance. Exactly the same
- -- programs should typecheck regardless of whether we take this step or
- -- not. See Note [Shortcut solving]
-
- && not (isIPLikePred (ctEvPred ev_w))   -- Not for implicit parameters (#18627)
-
- && not (xopt LangExt.IncoherentInstances dflags)
- -- If IncoherentInstances is on then we cannot rely on coherence of proofs
- -- in order to justify this optimization: The proof provided by the
- -- [G] constraint's superclass may be different from the top-level proof.
- -- See Note [Shortcut solving: incoherence]
-
- && gopt Opt_SolveConstantDicts dflags
- -- Enabled by the -fsolve-constant-dicts flag
-
-  = do { ev_binds_var <- getTcEvBindsVar
-       ; ev_binds <- assertPpr (not (isCoEvBindsVar ev_binds_var )) (ppr ev_w) $
-                     getTcEvBindsMap ev_binds_var
-       ; solved_dicts <- getSolvedDicts
-
-       ; mb_stuff <- runMaybeT $ try_solve_from_instance
-                                   (ev_binds, solved_dicts) ev_w
-
-       ; case mb_stuff of
-           Nothing -> return False
-           Just (ev_binds', solved_dicts')
-              -> do { setTcEvBindsMap ev_binds_var ev_binds'
-                    ; setSolvedDicts solved_dicts'
-                    ; return True } }
-
-  | otherwise
-  = return False
-  where
-    -- This `CtLoc` is used only to check the well-staged condition of any
-    -- candidate DFun. Our subgoals all have the same stage as our root
-    -- [W] constraint so it is safe to use this while solving them.
-    loc_w = ctEvLoc ev_w
-
-    try_solve_from_instance   -- See Note [Shortcut try_solve_from_instance]
-      :: (EvBindMap, DictMap CtEvidence) -> CtEvidence
-      -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
-    try_solve_from_instance (ev_binds, solved_dicts) ev
-      | let pred = ctEvPred ev
-            loc  = ctEvLoc  ev
-      , ClassPred cls tys <- classifyPredType pred
-      = do { inst_res <- lift $ matchGlobalInst dflags True cls tys
-           ; case inst_res of
-               OneInst { cir_new_theta = preds
-                       , cir_mk_ev     = mk_ev
-                       , cir_what      = what }
-                 | safeOverlap what
-                 , all isTyFamFree preds  -- Note [Shortcut solving: type families]
-                 -> do { let solved_dicts' = addDict solved_dicts cls tys ev
-                             -- solved_dicts': it is important that we add our goal
-                             -- to the cache before we solve! Otherwise we may end
-                             -- up in a loop while solving recursive dictionaries.
-
-                       ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds)
-                       ; loc' <- lift $ checkInstanceOK loc what pred
-                       ; lift $ checkReductionDepth loc' pred
-
-
-                       ; evc_vs <- mapM (new_wanted_cached ev loc' solved_dicts') preds
-                                  -- Emit work for subgoals but use our local cache
-                                  -- so we can solve recursive dictionaries.
-
-                       ; let ev_tm     = mk_ev (map getEvExpr evc_vs)
-                             ev_binds' = extendEvBinds ev_binds $
-                                         mkWantedEvBind (ctEvEvId ev) ev_tm
-
-                       ; foldlM try_solve_from_instance
-                                (ev_binds', solved_dicts')
-                                (freshGoals evc_vs) }
-
-               _ -> mzero }
-      | otherwise = mzero
-
-
-    -- Use a local cache of solved dicts while emitting EvVars for new work
-    -- We bail out of the entire computation if we need to emit an EvVar for
-    -- a subgoal that isn't a ClassPred.
-    new_wanted_cached :: CtEvidence -> CtLoc
-                      -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew
-    new_wanted_cached ev_w loc cache pty
-      | ClassPred cls tys <- classifyPredType pty
-      = lift $ case findDict cache loc_w cls tys of
-          Just ctev -> return $ Cached (ctEvExpr ctev)
-          Nothing   -> Fresh <$> newWantedNC loc (ctEvRewriters ev_w) pty
-      | otherwise = mzero
-
-addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS ()
--- Add wanted constraints from type-class functional dependencies.
-addFunDepWork inerts work_ev cls
-  = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls)
-               -- No need to check flavour; fundeps work between
-               -- any pair of constraints, regardless of flavour
-               -- Importantly we don't throw workitem back in the
-               -- worklist because this can cause loops (see #5236)
-  where
-    work_pred = ctEvPred work_ev
-    work_loc  = ctEvLoc work_ev
-
-    add_fds inert_ct
-      = do { traceTcS "addFunDepWork" (vcat
-                [ ppr work_ev
-                , pprCtLoc work_loc, ppr (isGivenLoc work_loc)
-                , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc)
-                , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ])
-
-           ; unless (isGiven work_ev && isGiven inert_ev) $
-             emitFunDepWanteds (ctEvRewriters work_ev) $
-             improveFromAnother (derived_loc, inert_rewriters) inert_pred work_pred
-               -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok
-               -- Do not create FDs from Given/Given interactions: See Note [No Given/Given fundeps]
-        }
-      where
-        inert_ev   = ctEvidence inert_ct
-        inert_pred = ctEvPred inert_ev
-        inert_loc  = ctEvLoc inert_ev
-        inert_rewriters = ctRewriters inert_ct
-        derived_loc = work_loc { ctl_depth  = ctl_depth work_loc `maxSubGoalDepth`
-                                              ctl_depth inert_loc
-                               , ctl_origin = FunDepOrigin1 work_pred
-                                                            (ctLocOrigin work_loc)
-                                                            (ctLocSpan work_loc)
-                                                            inert_pred
-                                                            (ctLocOrigin inert_loc)
-                                                            (ctLocSpan inert_loc) }
-
-{-
-**********************************************************************
-*                                                                    *
-                   Implicit parameters
-*                                                                    *
-**********************************************************************
--}
-
-interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct)
--- Work item is Given (?x:ty)
--- See Note [Shadowing of Implicit Parameters]
-interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls
-                                          , cc_tyargs = tys@(ip_str:_) })
-  = do { updInertCans $ \cans -> cans { inert_dicts = addDict filtered_dicts cls tys workItem }
-       ; stopWith ev "Given IP" }
-  where
-    dicts           = inert_dicts inerts
-    ip_dicts        = findDictsByClass dicts cls
-    other_ip_dicts  = filterBag (not . is_this_ip) ip_dicts
-    filtered_dicts  = addDictsByClass dicts cls other_ip_dicts
-
-    -- Pick out any Given constraints for the same implicit parameter
-    is_this_ip (CDictCan { cc_ev = ev, cc_tyargs = ip_str':_ })
-       = isGiven ev && ip_str `tcEqType` ip_str'
-    is_this_ip _ = False
-
-interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi)
-
-{- Note [Shadowing of Implicit Parameters]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider the following example:
-
-f :: (?x :: Char) => Char
-f = let ?x = 'a' in ?x
-
-The "let ?x = ..." generates an implication constraint of the form:
-
-?x :: Char => ?x :: Char
-
-Furthermore, the signature for `f` also generates an implication
-constraint, so we end up with the following nested implication:
-
-?x :: Char => (?x :: Char => ?x :: Char)
-
-Note that the wanted (?x :: Char) constraint may be solved in
-two incompatible ways:  either by using the parameter from the
-signature, or by using the local definition.  Our intention is
-that the local definition should "shadow" the parameter of the
-signature, and we implement this as follows: when we add a new
-*given* implicit parameter to the inert set, it replaces any existing
-givens for the same implicit parameter.
-
-Similarly, consider
-   f :: (?x::a) => Bool -> a
-
-   g v = let ?x::Int = 3
-         in (f v, let ?x::Bool = True in f v)
-
-This should probably be well typed, with
-   g :: Bool -> (Int, Bool)
-
-So the inner binding for ?x::Bool *overrides* the outer one.
-
-See ticket #17104 for a rather tricky example of this overriding
-behaviour.
-
-All this works for the normal cases but it has an odd side effect in
-some pathological programs like this:
--- This is accepted, the second parameter shadows
-f1 :: (?x :: Int, ?x :: Char) => Char
-f1 = ?x
-
--- This is rejected, the second parameter shadows
-f2 :: (?x :: Int, ?x :: Char) => Int
-f2 = ?x
-
-Both of these are actually wrong:  when we try to use either one,
-we'll get two incompatible wanted constraints (?x :: Int, ?x :: Char),
-which would lead to an error.
-
-I can think of two ways to fix this:
-
-  1. Simply disallow multiple constraints for the same implicit
-    parameter---this is never useful, and it can be detected completely
-    syntactically.
-
-  2. Move the shadowing machinery to the location where we nest
-     implications, and add some code here that will produce an
-     error if we get multiple givens for the same implicit parameter.
-
-
-**********************************************************************
-*                                                                    *
-                   interactFunEq
-*                                                                    *
-**********************************************************************
--}
-
-improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcType
-                   -> TcS ()
--- Generate improvement equalities, by comparing
--- the current work item with inert CFunEqs
--- E.g.   x + y ~ z,   x + y' ~ z   =>   [W] y ~ y'
---
--- See Note [FunDep and implicit parameter reactions]
-improveLocalFunEqs work_ev inerts fam_tc args rhs
-  = unless (null improvement_eqns) $
-    do { traceTcS "interactFunEq improvements: " $
-                   vcat [ text "Eqns:" <+> ppr improvement_eqns
-                        , text "Candidates:" <+> ppr funeqs_for_tc
-                        , text "Inert eqs:" <+> ppr (inert_eqs inerts) ]
-       ; emitFunDepWanteds (ctEvRewriters work_ev) improvement_eqns }
-  where
-    funeqs        = inert_funeqs inerts
-    funeqs_for_tc = [ funeq_ct | equal_ct_list <- findFunEqsByTyCon funeqs fam_tc
-                               , funeq_ct <- equal_ct_list
-                               , NomEq == ctEqRel funeq_ct ]
-                                  -- representational equalities don't interact
-                                  -- with type family dependencies
-    work_loc      = ctEvLoc work_ev
-    work_pred     = ctEvPred work_ev
-    fam_inj_info  = tyConInjectivityInfo fam_tc
-
-    --------------------
-    improvement_eqns :: [FunDepEqn (CtLoc, RewriterSet)]
-    improvement_eqns
-      | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
-      =    -- Try built-in families, notably for arithmethic
-        concatMap (do_one_built_in ops rhs) funeqs_for_tc
-
-      | Injective injective_args <- fam_inj_info
-      =    -- Try improvement from type families with injectivity annotations
-        concatMap (do_one_injective injective_args rhs) funeqs_for_tc
-
-      | otherwise
-      = []
-
-    --------------------
-    do_one_built_in ops rhs (CEqCan { cc_lhs = TyFamLHS _ iargs, cc_rhs = irhs, cc_ev = inert_ev })
-      | not (isGiven inert_ev && isGiven work_ev)  -- See Note [No Given/Given fundeps]
-      = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs irhs)
-
-      | otherwise
-      = []
-
-    do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc)
-
-    --------------------
-    -- See Note [Type inference for type families with injectivity]
-    do_one_injective inj_args rhs (CEqCan { cc_lhs = TyFamLHS _ inert_args
-                                          , cc_rhs = irhs, cc_ev = inert_ev })
-      | not (isGiven inert_ev && isGiven work_ev) -- See Note [No Given/Given fundeps]
-      , rhs `tcEqType` irhs
-      = mk_fd_eqns inert_ev $ [ Pair arg iarg
-                              | (arg, iarg, True) <- zip3 args inert_args inj_args ]
-      | otherwise
-      = []
-
-    do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc)
-
-    --------------------
-    mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn (CtLoc, RewriterSet)]
-    mk_fd_eqns inert_ev eqns
-      | null eqns  = []
-      | otherwise  = [ FDEqn { fd_qtvs = [], fd_eqs = eqns
-                             , fd_pred1 = work_pred
-                             , fd_pred2 = inert_pred
-                             , fd_loc   = (loc, inert_rewriters) } ]
-      where
-        initial_loc  -- start with the location of the Wanted involved
-          | isGiven work_ev = inert_loc
-          | otherwise       = work_loc
-        eqn_orig        = InjTFOrigin1 work_pred (ctLocOrigin work_loc) (ctLocSpan work_loc)
-                                       inert_pred (ctLocOrigin inert_loc) (ctLocSpan inert_loc)
-        eqn_loc         = setCtLocOrigin initial_loc eqn_orig
-        inert_pred      = ctEvPred inert_ev
-        inert_loc       = ctEvLoc inert_ev
-        inert_rewriters = ctEvRewriters inert_ev
-        loc = eqn_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`
-                                    ctl_depth work_loc }
-
-{- Note [Type inference for type families with injectivity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have a type family with an injectivity annotation:
-    type family F a b = r | r -> b
-
-Then if we have an equality like F s1 t1 ~ F s2 t2,
-we can use the injectivity to get a new Wanted constraint on
-the injective argument
-  [W] t1 ~ t2
-
-That in turn can help GHC solve constraints that would otherwise require
-guessing.  For example, consider the ambiguity check for
-   f :: F Int b -> Int
-We get the constraint
-   [W] F Int b ~ F Int beta
-where beta is a unification variable.  Injectivity lets us pick beta ~ b.
-
-Injectivity information is also used at the call sites. For example:
-   g = f True
-gives rise to
-   [W] F Int b ~ Bool
-from which we can derive b.  This requires looking at the defining equations of
-a type family, ie. finding equation with a matching RHS (Bool in this example)
-and inferring values of type variables (b in this example) from the LHS patterns
-of the matching equation.  For closed type families we have to perform
-additional apartness check for the selected equation to check that the selected
-is guaranteed to fire for given LHS arguments.
-
-These new constraints are Wanted constraints, but we will not use the evidence.
-We could go further and offer evidence from decomposing injective type-function
-applications, but that would require new evidence forms, and an extension to
-FC, so we don't do that right now (Dec 14).
-
-We generate these Wanteds in three places, depending on how we notice the
-injectivity.
-
-1. When we have a [W] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and
-described in Note [Decomposing type family applications] in GHC.Tc.Solver.Canonical.
-
-2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these
-constraints rewrites the other, as they have different LHSs. This is done
-in improveLocalFunEqs, called during the interactWithInertsStage.
-
-3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T.
-This is done in improve_top_fun_eqs, called from the top-level reactions stage.
-
-See also Note [Injective type families] in GHC.Core.TyCon
-
-Note [Cache-caused loops]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-It is very dangerous to cache a rewritten wanted family equation as 'solved' in our
-solved cache (which is the default behaviour or xCtEvidence), because the interaction
-may not be contributing towards a solution. Here is an example:
-
-Initial inert set:
-  [W] g1 : F a ~ beta1
-Work item:
-  [W] g2 : F a ~ beta2
-The work item will react with the inert yielding the _same_ inert set plus:
-    (i)   Will set g2 := g1 `cast` g3
-    (ii)  Will add to our solved cache that [S] g2 : F a ~ beta2
-    (iii) Will emit [W] g3 : beta1 ~ beta2
-Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2
-and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it
-will set
-      g1 := g ; sym g3
-and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but
-remember that we have this in our solved cache, and it is ... g2! In short we
-created the evidence loop:
-
-        g2 := g1 ; g3
-        g3 := refl
-        g1 := g2 ; sym g3
-
-To avoid this situation we do not cache as solved any workitems (or inert)
-which did not really made a 'step' towards proving some goal. Solved's are
-just an optimization so we don't lose anything in terms of completeness of
-solving.
-
-**********************************************************************
-*                                                                    *
-                   interactEq
-*                                                                    *
-**********************************************************************
--}
-
-{- Note [Combining equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-   Inert:     g1 :: a ~ t
-   Work item: g2 :: a ~ t
-
-Then we can simply solve g2 from g1, thus g2 := g1.  Easy!
-But it's not so simple:
-
-* If t is a type variable, the equalties might be oriented differently:
-      e.g. (g1 :: a~b) and (g2 :: b~a)
-  So we look both ways round.  Hence the SwapFlag result to
-  inertsCanDischarge.
-
-* We can only do g2 := g1 if g1 can discharge g2; that depends on
-  (a) the role and (b) the flavour.  E.g. a representational equality
-  cannot discharge a nominal one; a Wanted cannot discharge a Given.
-  The predicate is eqCanRewriteFR.
-
-* Visibility. Suppose  S :: forall k. k -> Type, and consider unifying
-      S @Type (a::Type)  ~   S @(Type->Type) (b::Type->Type)
-  From the first argument we get (Type ~ Type->Type); from the second
-  argument we get (a ~ b) which in turn gives (Type ~ Type->Type).
-  See typecheck/should_fail/T16204c.
-
-  That first argument is invisible in the source program (aside from
-  visible type application), so we'd much prefer to get the error from
-  the second. We track visibility in the uo_visible field of a TypeEqOrigin.
-  We use this to prioritise visible errors (see GHC.Tc.Errors.tryReporters,
-  the partition on isVisibleOrigin).
-
-  So when combining two otherwise-identical equalites, we want to
-  keep the visible one, and discharge the invisible one.  Hence the
-  call to strictly_more_visible.
--}
-
-inertsCanDischarge :: InertCans -> Ct
-                   -> Maybe ( CtEvidence  -- The evidence for the inert
-                            , SwapFlag )  -- Whether we need mkSymCo
-inertsCanDischarge inerts (CEqCan { cc_lhs = lhs_w, cc_rhs = rhs_w
-                                  , cc_ev = ev_w, cc_eq_rel = eq_rel })
-  | (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i
-                                  , cc_eq_rel = eq_rel }
-                             <- findEq inerts lhs_w
-                         , rhs_i `tcEqType` rhs_w
-                         , inert_beats_wanted ev_i eq_rel ]
-  =  -- Inert:     a ~ ty
-     -- Work item: a ~ ty
-    Just (ev_i, NotSwapped)
-
-  | Just rhs_lhs <- canEqLHS_maybe rhs_w
-  , (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i
-                                  , cc_eq_rel = eq_rel }
-                             <- findEq inerts rhs_lhs
-                         , rhs_i `tcEqType` canEqLHSType lhs_w
-                         , inert_beats_wanted ev_i eq_rel ]
-  =  -- Inert:     a ~ b
-     -- Work item: b ~ a
-     Just (ev_i, IsSwapped)
-
-  where
-    loc_w  = ctEvLoc ev_w
-    flav_w = ctEvFlavour ev_w
-    fr_w   = (flav_w, eq_rel)
-
-    inert_beats_wanted ev_i eq_rel
-      = -- eqCanRewriteFR:        see second bullet of Note [Combining equalities]
-        -- strictly_more_visible: see last bullet of Note [Combining equalities]
-        fr_i `eqCanRewriteFR` fr_w
-        && not ((loc_w `strictly_more_visible` ctEvLoc ev_i)
-                 && (fr_w `eqCanRewriteFR` fr_i))
-      where
-        fr_i = (ctEvFlavour ev_i, eq_rel)
-
-    -- See Note [Combining equalities], final bullet
-    strictly_more_visible loc1 loc2
-       = not (isVisibleOrigin (ctLocOrigin loc2)) &&
-         isVisibleOrigin (ctLocOrigin loc1)
-
-inertsCanDischarge _ _ = Nothing
-
-
-interactEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
-interactEq inerts workItem@(CEqCan { cc_lhs = lhs
-                                   , cc_rhs = rhs
-                                   , cc_ev = ev
-                                   , cc_eq_rel = eq_rel })
-  | Just (ev_i, swapped) <- inertsCanDischarge inerts workItem
-  = do { setEvBindIfWanted ev $
-         evCoercion (maybeSymCo swapped $
-                     downgradeRole (eqRelRole eq_rel)
-                                   (ctEvRole ev_i)
-                                   (ctEvCoercion ev_i))
-
-       ; stopWith ev "Solved from inert" }
-
-  | ReprEq <- eq_rel   -- See Note [Do not unify representational equalities]
-  = do { traceTcS "Not unifying representational equality" (ppr workItem)
-       ; continueWith workItem }
-
-  | otherwise
-  = case lhs of
-       TyVarLHS tv -> tryToSolveByUnification workItem ev tv rhs
-
-       TyFamLHS tc args -> do { improveLocalFunEqs ev inerts tc args rhs
-                              ; continueWith workItem }
-
-interactEq _ wi = pprPanic "interactEq" (ppr wi)
-
-----------------------
--- We have a meta-tyvar on the left, and metaTyVarUpdateOK has said "yes"
--- So try to solve by unifying.
--- Three reasons why not:
---    Skolem escape
---    Given equalities (GADTs)
---    Unifying a TyVarTv with a non-tyvar type
-tryToSolveByUnification :: Ct -> CtEvidence
-                        -> TcTyVar   -- LHS tyvar
-                        -> TcType    -- RHS
-                        -> TcS (StopOrContinue Ct)
-tryToSolveByUnification work_item ev tv rhs
-  = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv rhs
-       ; traceTcS "tryToSolveByUnification" (vcat [ ppr tv <+> char '~' <+> ppr rhs
-                                                  , ppr is_touchable ])
-
-       ; case is_touchable of
-           Untouchable -> continueWith work_item
-           -- For the latter two cases see Note [Solve by unification]
-           TouchableSameLevel -> solveByUnification ev tv rhs
-           TouchableOuterLevel free_metas tv_lvl
-             -> do { wrapTcS $ mapM_ (promoteMetaTyVarTo tv_lvl) free_metas
-                   ; setUnificationFlag tv_lvl
-                   ; solveByUnification ev tv rhs } }
-
-solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS (StopOrContinue Ct)
--- Solve with the identity coercion
--- Precondition: kind(xi) equals kind(tv)
--- Precondition: CtEvidence is Wanted
--- Precondition: CtEvidence is nominal
--- Returns: workItem where
---        workItem = the new Given constraint
---
--- NB: No need for an occurs check here, because solveByUnification always
---     arises from a CEqCan, a *canonical* constraint.  Its invariant (TyEq:OC)
---     says that in (a ~ xi), the type variable a does not appear in xi.
---     See GHC.Tc.Types.Constraint.Ct invariants.
---
--- Post: tv is unified (by side effect) with xi;
---       we often write tv := xi
-solveByUnification wd tv xi
-  = do { let tv_ty = mkTyVarTy tv
-       ; traceTcS "Sneaky unification:" $
-                       vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi,
-                             text "Coercion:" <+> pprEq tv_ty xi,
-                             text "Left Kind is:" <+> ppr (typeKind tv_ty),
-                             text "Right Kind is:" <+> ppr (typeKind xi) ]
-       ; unifyTyVar tv xi
-       ; setEvBindIfWanted wd (evCoercion (mkNomReflCo xi))
-       ; n_kicked <- kickOutAfterUnification tv
-       ; return (Stop wd (text "Solved by unification" <+> pprKicked n_kicked)) }
-
-{- Note [Avoid double unifications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The spontaneous solver has to return a given which mentions the unified unification
-variable *on the left* of the equality. Here is what happens if not:
-  Original wanted:  (a ~ alpha),  (alpha ~ Int)
-We spontaneously solve the first wanted, without changing the order!
-      given : a ~ alpha      [having unified alpha := a]
-Now the second wanted comes along, but it cannot rewrite the given, so we simply continue.
-At the end we spontaneously solve that guy, *reunifying*  [alpha := Int]
-
-We avoid this problem by orienting the resulting given so that the unification
-variable is on the left (note that alternatively we could attempt to
-enforce this at canonicalization).
-
-See also Note [No touchables as FunEq RHS] in GHC.Tc.Solver.Monad; avoiding
-double unifications is the main reason we disallow touchable
-unification variables as RHS of type family equations: F xis ~ alpha.
-
-Note [Do not unify representational equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider   [W] alpha ~R# b
-where alpha is touchable. Should we unify alpha := b?
-
-Certainly not!  Unifying forces alpha and be to be the same; but they
-only need to be representationally equal types.
-
-For example, we might have another constraint [W] alpha ~# N b
-where
-  newtype N b = MkN b
-and we want to get alpha := N b.
-
-See also #15144, which was caused by unifying a representational
-equality.
-
-Note [Solve by unification]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we solve
-   alpha[n] ~ ty
-by unification, there are two cases to consider
-
-* TouchableSameLevel: if the ambient level is 'n', then
-  we can simply update alpha := ty, and do nothing else
-
-* TouchableOuterLevel free_metas n: if the ambient level is greater than
-  'n' (the level of alpha), in addition to setting alpha := ty we must
-  do two other things:
-
-  1. Promote all the free meta-vars of 'ty' to level n.  After all,
-     alpha[n] is at level n, and so if we set, say,
-          alpha[n] := Maybe beta[m],
-     we must ensure that when unifying beta we do skolem-escape checks
-     etc relevant to level n.  Simple way to do that: promote beta to
-     level n.
-
-  2. Set the Unification Level Flag to record that a level-n unification has
-     taken place. See Note [The Unification Level Flag] in GHC.Tc.Solver.Monad
-
-NB: TouchableSameLevel is just an optimisation for TouchableOuterLevel. Promotion
-would be a no-op, and setting the unification flag unnecessarily would just
-make the solver iterate more often.  (We don't need to iterate when unifying
-at the ambient level because of the kick-out mechanism.)
-
-
-************************************************************************
-*                                                                      *
-*          Functional dependencies, instantiation of equations
-*                                                                      *
-************************************************************************
-
-When we spot an equality arising from a functional dependency,
-we now use that equality (a "wanted") to rewrite the work-item
-constraint right away.  This avoids two dangers
-
- Danger 1: If we send the original constraint on down the pipeline
-           it may react with an instance declaration, and in delicate
-           situations (when a Given overlaps with an instance) that
-           may produce new insoluble goals: see #4952
-
- Danger 2: If we don't rewrite the constraint, it may re-react
-           with the same thing later, and produce the same equality
-           again --> termination worries.
-
-To achieve this required some refactoring of GHC.Tc.Instance.FunDeps (nicer
-now!).
-
-Note [FunDep and implicit parameter reactions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Currently, our story of interacting two dictionaries (or a dictionary
-and top-level instances) for functional dependencies, and implicit
-parameters, is that we simply produce new Wanted equalities.  So for example
-
-        class D a b | a -> b where ...
-    Inert:
-        d1 :g D Int Bool
-    WorkItem:
-        d2 :w D Int alpha
-
-    We generate the extra work item
-        cv :w alpha ~ Bool
-    where 'cv' is currently unused.  However, this new item can perhaps be
-    spontaneously solved to become given and react with d2,
-    discharging it in favour of a new constraint d2' thus:
-        d2' :w D Int Bool
-        d2 := d2' |> D Int cv
-    Now d2' can be discharged from d1
-
-We could be more aggressive and try to *immediately* solve the dictionary
-using those extra equalities.
-
-If that were the case with the same inert set and work item we might discard
-d2 directly:
-
-        cv :w alpha ~ Bool
-        d2 := d1 |> D Int cv
-
-But in general it's a bit painful to figure out the necessary coercion,
-so we just take the first approach. Here is a better example. Consider:
-    class C a b c | a -> b
-And:
-     [Given]  d1 : C T Int Char
-     [Wanted] d2 : C T beta Int
-In this case, it's *not even possible* to solve the wanted immediately.
-So we should simply output the functional dependency and add this guy
-[but NOT its superclasses] back in the worklist. Even worse:
-     [Given] d1 : C T Int beta
-     [Wanted] d2: C T beta Int
-Then it is solvable, but its very hard to detect this on the spot.
-
-It's exactly the same with implicit parameters, except that the
-"aggressive" approach would be much easier to implement.
-
-Note [Fundeps with instances, and equality orientation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This Note describes a delicate interaction that constrains the orientation of
-equalities. This one is about fundeps, but the /exact/ same thing arises for
-type-family injectivity constraints: see Note [Improvement orientation].
-
-doTopFundepImprovement compares the constraint with all the instance
-declarations, to see if we can produce any equalities. E.g
-   class C2 a b | a -> b
-   instance C Int Bool
-Then the constraint (C Int ty) generates the equality [W] ty ~ Bool.
-
-There is a nasty corner in #19415 which led to the typechecker looping:
-   class C s t b | s -> t
-   instance ... => C (T kx x) (T ky y) Int
-   T :: forall k. k -> Type
-
-   work_item: dwrk :: C (T @ka (a::ka)) (T @kb0 (b0::kb0)) Char
-      where kb0, b0 are unification vars
-
-   ==> {doTopFundepImprovement: compare work_item with instance,
-        generate /fresh/ unification variables kfresh0, yfresh0,
-        emit a new Wanted, and add dwrk to inert set}
-
-   Suppose we emit this new Wanted from the fundep:
-       [W] T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0)
-
-   ==> {solve that equality kb0 := kfresh0, b0 := yfresh0}
-   Now kick out dwrk, since it mentions kb0
-   But now we are back to the start!  Loop!
-
-NB1: This example relies on an instance that does not satisfy the
-     coverage condition (although it may satisfy the weak coverage
-     condition), and hence whose fundeps generate fresh unification
-     variables.  Not satisfying the coverage condition is known to
-     lead to termination trouble, but in this case it's plain silly.
-
-NB2: In this example, the third parameter to C ensures that the
-     instance doesn't actually match the Wanted, so we can't use it to
-     solve the Wanted
-
-We solve the problem by (#21703):
-
-    carefully orienting the new Wanted so that all the
-    freshly-generated unification variables are on the LHS.
-
-    Thus we emit
-       [W] T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0)
-    and /NOT/
-       [W] T kb0 (b0::kb0) ~ T kfresh0 (yfresh0::kfresh0)
-
-Now we'll unify kfresh0:=kb0, yfresh0:=b0, and all is well.  The general idea
-is that we want to preferentially eliminate those freshly-generated
-unification variables, rather than unifying older variables, which causes
-kick-out etc.
-
-Keeping younger variables on the left also gives very minor improvement in
-the compiler performance by having less kick-outs and allocations (-0.1% on
-average).  Indeed Historical Note [Eliminate younger unification variables]
-in GHC.Tc.Utils.Unify describes an earlier attempt to do so systematically,
-apparently now in abeyance.
-
-But this is is a delicate solution. We must take care to /preserve/
-orientation during solving. Wrinkles:
-
-(W1) We start with
-       [W] T kfresh0 (yfresh0::kfresh0) ~ T kb0 (b0::kb0)
-     Decompose to
-       [W] kfresh0 ~ kb0
-       [W] (yfresh0::kfresh0) ~ (b0::kb0)
-     Preserve orientiation when decomposing!!
-
-(W2) Suppose we happen to tackle the second Wanted from (W1)
-     first. Then in canEqCanLHSHetero we emit a /kind/ equality, as
-     well as a now-homogeneous type equality
-       [W] kco : kfresh0 ~ kb0
-       [W] (yfresh0::kfresh0) ~ (b0::kb0) |> (sym kco)
-     Preserve orientation in canEqCanLHSHetero!!  (Failing to
-     preserve orientation here was the immediate cause of #21703.)
-
-(W3) There is a potential interaction with the swapping done by
-     GHC.Tc.Utils.Unify.swapOverTyVars.  We think it's fine, but it's
-     a slight worry.  See especially Note [TyVar/TyVar orientation] in
-     that module.
-
-The trouble is that "preserving orientation" is a rather global invariant,
-and sometimes we definitely do want to swap (e.g. Int ~ alpha), so we don't
-even have a precise statement of what the invariant is.  The advantage
-of the preserve-orientation plan is that it is extremely cheap to implement,
-and apparently works beautifully.
-
---- Alternative plan (1) ---
-Rather than have an ill-defined invariant, another possiblity is to
-elminate those fresh unification variables at birth, when generating
-the new fundep-inspired equalities.
-
-The key idea is to call `instFlexiX` in `emitFunDepWanteds` on only those
-type variables that are guaranteed to give us some progress. This means we
-have to locally (without calling emitWanteds) identify the type variables
-that do not give us any progress.  In the above example, we _know_ that
-emitting the two wanteds `kco` and `co` is fruitless.
-
-  Q: How do we identify such no-ops?
-
-  1. Generate a matching substitution from LHS to RHS
-        ɸ = [kb0 :-> k0, b0 :->  y0]
-  2. Call `instFlexiX` on only those type variables that do not appear in the domain of ɸ
-        ɸ' = instFlexiX ɸ (tvs - domain ɸ)
-  3. Apply ɸ' on LHS and then call emitWanteds
-        unifyWanteds ... (subst ɸ' LHS) RHS
-
-Why will this work?  The matching substitution ɸ will be a best effort
-substitution that gives us all the easy solutions. It can be generated with
-modified version of `Core/Unify.unify_tys` where we run it in a matching mode
-and never generate `SurelyApart` and always return a `MaybeApart Subst`
-instead.
-
-The same alternative plan would work for type-family injectivity constraints:
-see Note [Improvement orientation].
---- End of Alternative plan (1) ---
-
---- Alternative plan (2) ---
-We could have a new flavour of TcTyVar (like `TauTv`, `TyVarTv` etc; see GHC.Tc.Utils.TcType.MetaInfo)
-for the fresh unification variables introduced by functional dependencies.  Say `FunDepTv`.  Then in
-GHC.Tc.Utils.Unify.swapOverTyVars we could arrange to keep a `FunDepTv` on the left if possible.
-Looks possible, but it's one more complication.
---- End of Alternative plan (2) ---
-
-
---- Historical note: Failed Alternative Plan (3) ---
-Previously we used a flag `cc_fundeps` in `CDictCan`. It would flip to False
-once we used a fun dep to hint the solver to break and to stop emitting more
-wanteds.  This solution was not complete, and caused a failures while trying
-to solve for transitive functional dependencies (test case: T21703)
--- End of Historical note: Failed Alternative Plan (3) --
-
-Note [Weird fundeps]
-~~~~~~~~~~~~~~~~~~~~
-Consider   class Het a b | a -> b where
-              het :: m (f c) -> a -> m b
-
-           class GHet (a :: * -> *) (b :: * -> *) | a -> b
-           instance            GHet (K a) (K [a])
-           instance Het a b => GHet (K a) (K b)
-
-The two instances don't actually conflict on their fundeps,
-although it's pretty strange.  So they are both accepted. Now
-try   [W] GHet (K Int) (K Bool)
-This triggers fundeps from both instance decls;
-      [W] K Bool ~ K [a]
-      [W] K Bool ~ K beta
-And there's a risk of complaining about Bool ~ [a].  But in fact
-the Wanted matches the second instance, so we never get as far
-as the fundeps.
-
-#7875 is a case in point.
--}
-
-doTopFundepImprovement :: Ct -> TcS (StopOrContinue Ct)
--- Try to functional-dependency improvement between the constraint
--- and the top-level instance declarations
--- See Note [Fundeps with instances, and equality orientation]
--- See also Note [Weird fundeps]
-doTopFundepImprovement work_item@(CDictCan { cc_ev = ev, cc_class = cls
-                                           , cc_tyargs = xis })
-  = do { traceTcS "try_fundeps" (ppr work_item)
-       ; instEnvs <- getInstEnvs
-       ; let fundep_eqns = improveFromInstEnv instEnvs mk_ct_loc cls xis
-       ; emitFunDepWanteds (ctEvRewriters ev) fundep_eqns
-       ; continueWith work_item }
-  where
-     dict_pred   = mkClassPred cls xis
-     dict_loc    = ctEvLoc ev
-     dict_origin = ctLocOrigin dict_loc
-
-     mk_ct_loc :: PredType   -- From instance decl
-               -> SrcSpan    -- also from instance deol
-               -> (CtLoc, RewriterSet)
-     mk_ct_loc inst_pred inst_loc
-       = ( dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin
-                                                 inst_pred inst_loc }
-         , emptyRewriterSet )
-
-doTopFundepImprovement work_item = pprPanic "doTopFundepImprovement" (ppr work_item)
-
-emitFunDepWanteds :: RewriterSet  -- from the work item
-                  -> [FunDepEqn (CtLoc, RewriterSet)] -> TcS ()
-
-emitFunDepWanteds _ [] = return () -- common case noop
--- See Note [FunDep and implicit parameter reactions]
-
-emitFunDepWanteds work_rewriters fd_eqns
-  = mapM_ do_one_FDEqn fd_eqns
-  where
-    do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) })
-     | null tvs  -- Common shortcut
-     = do { traceTcS "emitFunDepWanteds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc))
-          ; mapM_ (\(Pair ty1 ty2) -> unifyWanted all_rewriters loc Nominal ty1 ty2)
-                  (reverse eqs) }
-             -- See Note [Reverse order of fundep equations]
-
-     | otherwise
-     = do { traceTcS "emitFunDepWanteds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs)
-          ; subst <- instFlexiX emptySubst tvs  -- Takes account of kind substitution
-          ; mapM_ (do_one_eq loc all_rewriters subst) (reverse eqs) }
-               -- See Note [Reverse order of fundep equations]
-     where
-       all_rewriters = work_rewriters S.<> rewriters
-
-    do_one_eq loc rewriters subst (Pair ty1 ty2)
-       = unifyWanted rewriters loc Nominal (substTyUnchecked subst' ty1) ty2
-         -- ty2 does not mention fd_qtvs, so no need to subst it.
-         -- See GHC.Tc.Instance.Fundeps Note [Improving against instances]
-         --     Wrinkle (1)
-      where
-         subst' = extendSubstInScopeSet subst (tyCoVarsOfType ty1)
-         -- The free vars of ty1 aren't just fd_qtvs: ty1 is the result
-         -- of matching with the [W] constraint. So we add its free
-         -- vars to InScopeSet, to satisfy substTy's invariants, even
-         -- though ty1 will never (currently) be a poytype, so this
-         -- InScopeSet will never be looked at.
-
-{-
-**********************************************************************
-*                                                                    *
-                       The top-reaction Stage
-*                                                                    *
-**********************************************************************
--}
-
-topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct)
--- The work item does not react with the inert set,
--- so try interaction with top-level instances.
-topReactionsStage work_item
-  = do { traceTcS "doTopReact" (ppr work_item)
-       ; case work_item of
-
-           CDictCan {} ->
-             do { inerts <- getTcSInerts
-                ; doTopReactDict inerts work_item }
-
-           CEqCan {} ->
-             doTopReactEq work_item
-
-           CIrredCan {} ->
-             doTopReactOther work_item
-
-           -- Any other work item does not react with any top-level equations
-           _  -> continueWith work_item }
-
---------------------
-doTopReactOther :: Ct -> TcS (StopOrContinue Ct)
--- Try local quantified constraints for
---     CEqCan    e.g.  (lhs ~# ty)
--- and CIrredCan e.g.  (c a)
---
--- Why equalities? See GHC.Tc.Solver.Canonical
--- Note [Equality superclasses in quantified constraints]
-doTopReactOther work_item
-  | isGiven ev
-  = continueWith work_item
-
-  | EqPred eq_rel t1 t2 <- classifyPredType pred
-  = doTopReactEqPred work_item eq_rel t1 t2
-
-  | otherwise
-  = do { res <- matchLocalInst pred loc
-       ; case res of
-           OneInst {} -> chooseInstance work_item res
-           _          -> continueWith work_item }
-
-  where
-    ev   = ctEvidence work_item
-    loc  = ctEvLoc ev
-    pred = ctEvPred ev
-
-{-********************************************************************
-*                                                                    *
-          Top-level reaction for equality constraints (CEqCan)
-*                                                                    *
-********************************************************************-}
-
-doTopReactEqPred :: Ct -> EqRel -> TcType -> TcType -> TcS (StopOrContinue Ct)
-doTopReactEqPred work_item eq_rel t1 t2
-  -- See Note [Looking up primitive equalities in quantified constraints]
-  | Just (cls, tys) <- boxEqPred eq_rel t1 t2
-  = do { res <- matchLocalInst (mkClassPred cls tys) loc
-       ; case res of
-           OneInst { cir_mk_ev = mk_ev }
-             -> chooseInstance work_item
-                    (res { cir_mk_ev = mk_eq_ev cls tys mk_ev })
-           _ -> continueWith work_item }
-
-  | otherwise
-  = continueWith work_item
-  where
-    ev   = ctEvidence work_item
-    loc = ctEvLoc ev
-
-    mk_eq_ev cls tys mk_ev evs
-      = case (mk_ev evs) of
-          EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e)
-          ev       -> pprPanic "mk_eq_ev" (ppr ev)
-      where
-        [sc_id] = classSCSelIds cls
-
-{- Note [Looking up primitive equalities in quantified constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For equalities (a ~# b) look up (a ~ b), and then do a superclass
-selection. This avoids having to support quantified constraints whose
-kind is not Constraint, such as (forall a. F a ~# b)
-
-See
- * Note [Evidence for quantified constraints] in GHC.Core.Predicate
- * Note [Equality superclasses in quantified constraints]
-   in GHC.Tc.Solver.Canonical
-
-Note [Reverse order of fundep equations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this scenario (from dependent/should_fail/T13135_simple):
-
-  type Sig :: Type -> Type
-  data Sig a = SigFun a (Sig a)
-
-  type SmartFun :: forall (t :: Type). Sig t -> Type
-  type family SmartFun sig = r | r -> sig where
-    SmartFun @Type (SigFun @Type a sig) = a -> SmartFun @Type sig
-
-  [W] SmartFun @kappa sigma ~ (Int -> Bool)
-
-The injectivity of SmartFun allows us to produce two new equalities:
-
-  [W] w1 :: Type ~ kappa
-  [W] w2 :: SigFun @Type Int beta ~ sigma
-
-for some fresh (beta :: SigType). The second Wanted here is actually
-heterogeneous: the LHS has type Sig Type while the RHS has type Sig kappa.
-Of course, if we solve the first wanted first, the second becomes homogeneous.
-
-When looking for injectivity-inspired equalities, we work left-to-right,
-producing the two equalities in the order written above. However, these
-equalities are then passed into unifyWanted, which will fail, adding these
-to the work list. However, crucially, the work list operates like a *stack*.
-So, because we add w1 and then w2, we process w2 first. This is silly: solving
-w1 would unlock w2. So we make sure to add equalities to the work
-list in left-to-right order, which requires a few key calls to 'reverse'.
-
-This treatment is also used for class-based functional dependencies, although
-we do not have a program yet known to exhibit a loop there. It just seems
-like the right thing to do.
-
-When this was originally conceived, it was necessary to avoid a loop in T13135.
-That loop is now avoided by continuing with the kind equality (not the type
-equality) in canEqCanLHSHetero (see Note [Equalities with incompatible kinds]
-in GHC.Tc.Solver.Canonical). However, the idea of working left-to-right still
-seems worthwhile, and so the calls to 'reverse' remain.
-
--}
-
---------------------
-doTopReactEq :: Ct -> TcS (StopOrContinue Ct)
-doTopReactEq work_item@(CEqCan { cc_ev = old_ev, cc_lhs = TyFamLHS fam_tc args
-                               , cc_rhs = rhs })
-  = do { improveTopFunEqs old_ev fam_tc args rhs
-       ; doTopReactOther work_item }
-doTopReactEq work_item = doTopReactOther work_item
-
-improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcType -> TcS ()
--- See Note [FunDep and implicit parameter reactions]
-improveTopFunEqs ev fam_tc args rhs
-  | isGiven ev  -- See Note [No Given/Given fundeps]
-  = return ()
-
-  | otherwise
-  = do { fam_envs <- getFamInstEnvs
-       ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs
-       ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs
-                                          , ppr eqns ])
-       ; mapM_ (\(Pair ty1 ty2) -> unifyWanted rewriters loc Nominal ty1 ty2)
-               (reverse eqns) }
-         -- Missing that `reverse` causes T13135 and T13135_simple to loop.
-         -- See Note [Reverse order of fundep equations]
-  where
-    loc = bumpCtLocDepth (ctEvLoc ev)
-        -- ToDo: this location is wrong; it should be FunDepOrigin2
-        -- See #14778
-    rewriters = ctEvRewriters ev
-
-improve_top_fun_eqs :: FamInstEnvs
-                    -> TyCon -> [TcType] -> TcType
-                    -> TcS [TypeEqn]
-improve_top_fun_eqs fam_envs fam_tc args rhs_ty
-  | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
-  = return (sfInteractTop ops args rhs_ty)
-
-  -- see Note [Type inference for type families with injectivity]
-  | isOpenTypeFamilyTyCon fam_tc
-  , Injective injective_args <- tyConInjectivityInfo fam_tc
-  , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc
-  = -- it is possible to have several compatible equations in an open type
-    -- family but we only want to derive equalities from one such equation.
-    do { let improvs = buildImprovementData fam_insts
-                           fi_tvs fi_tys fi_rhs (const Nothing)
-
-       ; traceTcS "improve_top_fun_eqs2" (ppr improvs)
-       ; concatMapM (injImproveEqns injective_args) $
-         take 1 improvs }
-
-  | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc
-  , Injective injective_args <- tyConInjectivityInfo fam_tc
-  = concatMapM (injImproveEqns injective_args) $
-    buildImprovementData (fromBranches (co_ax_branches ax))
-                         cab_tvs cab_lhs cab_rhs Just
-
-  | otherwise
-  = return []
-
-  where
-      in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty)
-
-      buildImprovementData
-          :: [a]                     -- axioms for a TF (FamInst or CoAxBranch)
-          -> (a -> [TyVar])          -- get bound tyvars of an axiom
-          -> (a -> [Type])           -- get LHS of an axiom
-          -> (a -> Type)             -- get RHS of an axiom
-          -> (a -> Maybe CoAxBranch) -- Just => apartness check required
-          -> [( [Type], Subst, [TyVar], Maybe CoAxBranch )]
-             -- Result:
-             -- ( [arguments of a matching axiom]
-             -- , RHS-unifying substitution
-             -- , axiom variables without substitution
-             -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] )
-      buildImprovementData axioms axiomTVs axiomLHS axiomRHS wrap =
-          [ (ax_args, subst, unsubstTvs, wrap axiom)
-          | axiom <- axioms
-          , let ax_args = axiomLHS axiom
-                ax_rhs  = axiomRHS axiom
-                ax_tvs  = axiomTVs axiom
-                in_scope1 = in_scope `extendInScopeSetList` ax_tvs
-          , Just subst <- [tcUnifyTyWithTFs False in_scope1 ax_rhs rhs_ty]
-          , let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst)
-                unsubstTvs    = filter (notInSubst <&&> isTyVar) ax_tvs ]
-                   -- The order of unsubstTvs is important; it must be
-                   -- in telescope order e.g. (k:*) (a:k)
-
-      injImproveEqns :: [Bool]
-                     -> ([Type], Subst, [TyCoVar], Maybe CoAxBranch)
-                     -> TcS [TypeEqn]
-      injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr)
-        = do { subst <- instFlexiX subst unsubstTvs
-                  -- If the current substitution bind [k -> *], and
-                  -- one of the un-substituted tyvars is (a::k), we'd better
-                  -- be sure to apply the current substitution to a's kind.
-                  -- Hence instFlexiX.   #13135 was an example.
-
-             ; return [ Pair (substTy subst ax_arg) arg
-                        -- NB: the ax_arg part is on the left
-                        -- see Note [Improvement orientation]
-                      | case cabr of
-                          Just cabr' -> apartnessCheck (substTys subst ax_args) cabr'
-                          _          -> True
-                      , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] }
-
-{-
-Note [MATCHING-SYNONYMS]
-~~~~~~~~~~~~~~~~~~~~~~~~
-When trying to match a dictionary (D tau) to a top-level instance, or a
-type family equation (F taus_1 ~ tau_2) to a top-level family instance,
-we do *not* need to expand type synonyms because the matcher will do that for us.
-
-Note [Improvement orientation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See also Note [Fundeps with instances, and equality orientation], which describes
-the Exact Same Prolem, with the same solution, but for functional dependencies.
-
-A very delicate point is the orientation of equalities
-arising from injectivity improvement (#12522).  Suppose we have
-  type family F x = t | t -> x
-  type instance F (a, Int) = (Int, G a)
-where G is injective; and wanted constraints
-
-  [W] TF (alpha, beta) ~ fuv
-  [W] fuv ~ (Int, <some type>)
-
-The injectivity will give rise to constraints
-
-  [W] gamma1 ~ alpha
-  [W] Int ~ beta
-
-The fresh unification variable gamma1 comes from the fact that we
-can only do "partial improvement" here; see Section 5.2 of
-"Injective type families for Haskell" (HS'15).
-
-Now, it's very important to orient the equations this way round,
-so that the fresh unification variable will be eliminated in
-favour of alpha.  If we instead had
-   [W] alpha ~ gamma1
-then we would unify alpha := gamma1; and kick out the wanted
-constraint.  But when we grough it back in, it'd look like
-   [W] TF (gamma1, beta) ~ fuv
-and exactly the same thing would happen again!  Infinite loop.
-
-This all seems fragile, and it might seem more robust to avoid
-introducing gamma1 in the first place, in the case where the
-actual argument (alpha, beta) partly matches the improvement
-template.  But that's a bit tricky, esp when we remember that the
-kinds much match too; so it's easier to let the normal machinery
-handle it.  Instead we are careful to orient the new
-equality with the template on the left.  Delicate, but it works.
-
--}
-
-{- *******************************************************************
-*                                                                    *
-         Top-level reaction for class constraints (CDictCan)
-*                                                                    *
-**********************************************************************-}
-
-doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct)
--- Try to use type-class instance declarations to simplify the constraint
-doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls
-                                          , cc_tyargs = xis })
-  | isGiven ev   -- Never use instances for Given constraints
-  = continueWith work_item
-     -- See Note [No Given/Given fundeps]
-
-  | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis   -- Cached
-  = do { setEvBindIfWanted ev (ctEvTerm solved_ev)
-       ; stopWith ev "Dict/Top (cached)" }
-
-  | otherwise  -- Wanted, but not cached
-   = do { dflags <- getDynFlags
-        ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc
-        ; case lkup_res of
-               OneInst { cir_what = what }
-                  -> do { insertSafeOverlapFailureTcS what work_item
-                        ; addSolvedDict what ev cls xis
-                        ; chooseInstance work_item lkup_res }
-               _  -> -- NoInstance or NotSure
-                     -- We didn't solve it; so try functional dependencies with
-                     -- the instance environment, and return
-                     doTopFundepImprovement work_item }
-   where
-     dict_loc = ctEvLoc ev
-
-
-doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)
-
-
-chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct)
-chooseInstance work_item
-               (OneInst { cir_new_theta = theta
-                        , cir_what      = what
-                        , cir_mk_ev     = mk_ev })
-  = do { traceTcS "doTopReact/found instance for" $ ppr ev
-       ; deeper_loc <- checkInstanceOK loc what pred
-       ; checkReductionDepth deeper_loc pred
-       ; evb <- getTcEvBindsVar
-       ; if isCoEvBindsVar evb
-         then continueWith work_item
-                  -- See Note [Instances in no-evidence implications]
-         else
-           do { evc_vars <- mapM (newWanted deeper_loc (ctRewriters work_item)) theta
-              ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars))
-              ; emitWorkNC (freshGoals evc_vars)
-              ; stopWith ev "Dict/Top (solved wanted)" }}
-  where
-     ev         = ctEvidence work_item
-     pred       = ctEvPred ev
-     loc        = ctEvLoc ev
-
-chooseInstance work_item lookup_res
-  = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res)
-
-checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc
--- Check that it's OK to use this instance:
---    (a) the use is well staged in the Template Haskell sense
--- Returns the CtLoc to used for sub-goals
--- Probably also want to call checkReductionDepth
-checkInstanceOK loc what pred
-  = do { checkWellStagedDFun loc what pred
-       ; return deeper_loc }
-  where
-     deeper_loc = zap_origin (bumpCtLocDepth loc)
-     origin     = ctLocOrigin loc
-
-     zap_origin loc  -- After applying an instance we can set ScOrigin to
-                     -- infinity, so that prohibitedSuperClassSolve never fires
-       | ScOrigin {} <- origin
-       = setCtLocOrigin loc (ScOrigin infinity)
-       | otherwise
-       = loc
-
-{- Note [Instances in no-evidence implications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In #15290 we had
-  [G] forall p q. Coercible p q => Coercible (m p) (m q))
-  [W] forall <no-ev> a. m (Int, IntStateT m a)
-                          ~R#
-                        m (Int, StateT Int m a)
-
-The Given is an ordinary quantified constraint; the Wanted is an implication
-equality that arises from
-  [W] (forall a. t1) ~R# (forall a. t2)
-
-But because the (t1 ~R# t2) is solved "inside a type" (under that forall a)
-we can't generate any term evidence.  So we can't actually use that
-lovely quantified constraint.  Alas!
-
-This test arranges to ignore the instance-based solution under these
-(rare) circumstances.   It's sad, but I  really don't see what else we can do.
--}
-
-
-matchClassInst :: DynFlags -> InertSet
-               -> Class -> [Type]
-               -> CtLoc -> TcS ClsInstResult
-matchClassInst dflags inerts clas tys loc
--- First check whether there is an in-scope Given that could
--- match this constraint.  In that case, do not use any instance
--- whether top level, or local quantified constraints.
--- See Note [Instance and Given overlap]
-  | not (xopt LangExt.IncoherentInstances dflags)
-  , not (naturallyCoherentClass clas)
-  , not (noMatchableGivenDicts inerts loc clas tys)
-  = do { traceTcS "Delaying instance application" $
-           vcat [ text "Work item=" <+> pprClassPred clas tys ]
-       ; return NotSure }
-
-  | otherwise
-  = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr pred <+> char '{'
-       ; local_res <- matchLocalInst pred loc
-       ; case local_res of
-           OneInst {} ->  -- See Note [Local instances and incoherence]
-                do { traceTcS "} matchClassInst local match" $ ppr local_res
-                   ; return local_res }
-
-           NotSure -> -- In the NotSure case for local instances
-                      -- we don't want to try global instances
-                do { traceTcS "} matchClassInst local not sure" empty
-                   ; return local_res }
-
-           NoInstance  -- No local instances, so try global ones
-              -> do { global_res <- matchGlobalInst dflags False clas tys
-                    ; traceTcS "} matchClassInst global result" $ ppr global_res
-                    ; return global_res } }
-  where
-    pred = mkClassPred clas tys
-
--- | If a class is "naturally coherent", then we needn't worry at all, in any
--- way, about overlapping/incoherent instances. Just solve the thing!
--- See Note [Naturally coherent classes]
--- See also Note [The equality types story] in GHC.Builtin.Types.Prim.
-naturallyCoherentClass :: Class -> Bool
-naturallyCoherentClass cls
-  = isCTupleClass cls
-    || cls `hasKey` heqTyConKey
-    || cls `hasKey` eqTyConKey
-    || cls `hasKey` coercibleTyConKey
-
-
-{- Note [Instance and Given overlap]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Example, from the OutsideIn(X) paper:
-       instance P x => Q [x]
-       instance (x ~ y) => R y [x]
-
-       wob :: forall a b. (Q [b], R b a) => a -> Int
-
-       g :: forall a. Q [a] => [a] -> Int
-       g x = wob x
-
-From 'g' we get the implication constraint:
-            forall a. Q [a] => (Q [beta], R beta [a])
-If we react (Q [beta]) with its top-level axiom, we end up with a
-(P beta), which we have no way of discharging. On the other hand,
-if we react R beta [a] with the top-level we get  (beta ~ a), which
-is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is
-now solvable by the given Q [a].
-
-The partial solution is that:
-  In matchClassInst (and thus in topReact), we return a matching
-  instance only when there is no Given in the inerts which is
-  unifiable to this particular dictionary.
-
-  We treat any meta-tyvar as "unifiable" for this purpose,
-  *including* untouchable ones.  But not skolems like 'a' in
-  the implication constraint above.
-
-The end effect is that, much as we do for overlapping instances, we
-delay choosing a class instance if there is a possibility of another
-instance OR a given to match our constraint later on. This fixes
-tickets #4981 and #5002.
-
-Other notes:
-
-* The check is done *first*, so that it also covers classes
-  with built-in instance solving, such as
-     - constraint tuples
-     - natural numbers
-     - Typeable
-
-* See also Note [What might equal later?] in GHC.Tc.Solver.InertSet.
-
-* The given-overlap problem is arguably not easy to appear in practice
-  due to our aggressive prioritization of equality solving over other
-  constraints, but it is possible. I've added a test case in
-  typecheck/should-compile/GivenOverlapping.hs
-
-* Another "live" example is #10195; another is #10177.
-
-* We ignore the overlap problem if -XIncoherentInstances is in force:
-  see #6002 for a worked-out example where this makes a
-  difference.
-
-* Moreover notice that our goals here are different than the goals of
-  the top-level overlapping checks. There we are interested in
-  validating the following principle:
-
-      If we inline a function f at a site where the same global
-      instance environment is available as the instance environment at
-      the definition site of f then we should get the same behaviour.
-
-  But for the Given Overlap check our goal is just related to completeness of
-  constraint solving.
-
-* The solution is only a partial one.  Consider the above example with
-       g :: forall a. Q [a] => [a] -> Int
-       g x = let v = wob x
-             in v
-  and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most
-  general type for 'v'.  When generalising v's type we'll simplify its
-  Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we
-  will use the instance declaration after all. #11948 was a case
-  in point.
-
-All of this is disgustingly delicate, so to discourage people from writing
-simplifiable class givens, we warn about signatures that contain them;
-see GHC.Tc.Validity Note [Simplifiable given constraints].
-
-Note [Naturally coherent classes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A few built-in classes are "naturally coherent".  This term means that
-the "instance" for the class is bidirectional with its superclass(es).
-For example, consider (~~), which behaves as if it was defined like
-this:
-  class a ~# b => a ~~ b
-  instance a ~# b => a ~~ b
-(See Note [The equality types story] in GHC.Builtin.Types.Prim.)
-
-Faced with [W] t1 ~~ t2, it's always OK to reduce it to [W] t1 ~# t2,
-without worrying about Note [Instance and Given overlap].  Why?  Because
-if we had [G] s1 ~~ s2, then we'd get the superclass [G] s1 ~# s2, and
-so the reduction of the [W] constraint does not risk losing any solutions.
-
-On the other hand, it can be fatal to /fail/ to reduce such
-equalities, on the grounds of Note [Instance and Given overlap],
-because many good things flow from [W] t1 ~# t2.
-
-The same reasoning applies to
-
-* (~~)        heqTyCon
-* (~)         eqTyCon
-* Coercible   coercibleTyCon
-
-And less obviously to:
-
-* Tuple classes.  For reasons described in GHC.Tc.Solver.Types
-  Note [Tuples hiding implicit parameters], we may have a constraint
-     [W] (?x::Int, C a)
-  with an exactly-matching Given constraint.  We must decompose this
-  tuple and solve the components separately, otherwise we won't solve
-  it at all!  It is perfectly safe to decompose it, because again the
-  superclasses invert the instance;  e.g.
-      class (c1, c2) => (% c1, c2 %)
-      instance (c1, c2) => (% c1, c2 %)
-  Example in #14218
-
-Examples: T5853, T10432, T5315, T9222, T2627b, T3028b
-
-PS: the term "naturally coherent" doesn't really seem helpful.
-Perhaps "invertible" or something?  I left it for now though.
-
-Note [Local instances and incoherence]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   f :: forall b c. (Eq b, forall a. Eq a => Eq (c a))
-                 => c b -> Bool
-   f x = x==x
-
-We get [W] Eq (c b), and we must use the local instance to solve it.
-
-BUT that wanted also unifies with the top-level Eq [a] instance,
-and Eq (Maybe a) etc.  We want the local instance to "win", otherwise
-we can't solve the wanted at all.  So we mark it as Incohherent.
-According to Note [Rules for instance lookup] in GHC.Core.InstEnv, that'll
-make it win even if there are other instances that unify.
-
-Moreover this is not a hack!  The evidence for this local instance
-will be constructed by GHC at a call site... from the very instances
-that unify with it here.  It is not like an incoherent user-written
-instance which might have utterly different behaviour.
-
-Consider  f :: Eq a => blah.  If we have [W] Eq a, we certainly
-get it from the Eq a context, without worrying that there are
-lots of top-level instances that unify with [W] Eq a!  We'll use
-those instances to build evidence to pass to f. That's just the
-nullary case of what's happening here.
--}
-
-matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult
--- Look up the predicate in Given quantified constraints,
--- which are effectively just local instance declarations.
-matchLocalInst pred loc
-  = do { inerts@(IS { inert_cans = ics }) <- getTcSInerts
-       ; case match_local_inst inerts (inert_insts ics) of
-          { ([], []) -> do { traceTcS "No local instance for" (ppr pred)
-                           ; return NoInstance }
-          ; (matches, unifs) ->
-    do { matches <- mapM mk_instDFun matches
-       ; unifs   <- mapM mk_instDFun unifs
-         -- See Note [Use only the best matching quantified constraint]
-       ; case dominatingMatch matches of
-          { Just (dfun_id, tys, theta)
-            | all ((theta `impliedBySCs`) . thdOf3) unifs
-            ->
-            do { let result = OneInst { cir_new_theta = theta
-                                      , cir_mk_ev     = evDFunApp dfun_id tys
-                                      , cir_what      = LocalInstance }
-               ; traceTcS "Best local instance found:" $
-                  vcat [ text "pred:" <+> ppr pred
-                       , text "result:" <+> ppr result
-                       , text "matches:" <+> ppr matches
-                       , text "unifs:" <+> ppr unifs ]
-               ; return result }
-
-          ; mb_best ->
-            do { traceTcS "Multiple local instances; not committing to any"
-                  $ vcat [ text "pred:" <+> ppr pred
-                         , text "matches:" <+> ppr matches
-                         , text "unifs:" <+> ppr unifs
-                         , text "best_match:" <+> ppr mb_best ]
-               ; return NotSure }}}}}
-  where
-    pred_tv_set = tyCoVarsOfType pred
-
-    mk_instDFun :: (CtEvidence, [DFunInstType]) -> TcS InstDFun
-    mk_instDFun (ev, tys) =
-      let dfun_id = ctEvEvId ev
-      in do { (tys, theta) <- instDFunType (ctEvEvId ev) tys
-            ; return (dfun_id, tys, theta) }
-
-    -- Compute matching and unifying local instances
-    match_local_inst :: InertSet
-                     -> [QCInst]
-                     -> ( [(CtEvidence, [DFunInstType])]
-                        , [(CtEvidence, [DFunInstType])] )
-    match_local_inst _inerts []
-      = ([], [])
-    match_local_inst inerts (qci@(QCI { qci_tvs  = qtvs
-                                      , qci_pred = qpred
-                                      , qci_ev   = qev })
-                            :qcis)
-      | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set)
-      , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope)
-                                        emptyTvSubstEnv qpred pred
-      , let match = (qev, map (lookupVarEnv tv_subst) qtvs)
-      = (match:matches, unifs)
-
-      | otherwise
-      = assertPpr (disjointVarSet qtv_set (tyCoVarsOfType pred))
-                  (ppr qci $$ ppr pred)
-            -- ASSERT: unification relies on the
-            -- quantified variables being fresh
-        (matches, this_unif `combine` unifs)
-      where
-        qloc = ctEvLoc qev
-        qtv_set = mkVarSet qtvs
-        (matches, unifs) = match_local_inst inerts qcis
-        this_unif
-          | Just subst <- mightEqualLater inerts qpred qloc pred loc
-          = Just (qev, map  (lookupTyVar subst) qtvs)
-          | otherwise
-          = Nothing
-
-        combine Nothing  us = us
-        combine (Just u) us = u : us
-
--- | Instance dictionary function and type.
-type InstDFun = (DFunId, [TcType], TcThetaType)
-
--- | Try to find a local quantified instance that dominates all others,
--- i.e. which has a weaker instance context than all the others.
---
--- See Note [Use only the best matching quantified constraint].
-dominatingMatch :: [InstDFun] -> Maybe InstDFun
-dominatingMatch matches =
-  listToMaybe $ mapMaybe (uncurry go) (holes matches)
-  -- listToMaybe: arbitrarily pick any one context that is weaker than
-  -- all others, e.g. so that we can handle [Eq a, Num a] vs [Num a, Eq a]
-  -- (see test case T22223).
-
-  where
-    go :: InstDFun -> [InstDFun] -> Maybe InstDFun
-    go this [] = Just this
-    go this@(_,_,this_theta) ((_,_,other_theta):others)
-      | this_theta `impliedBySCs` other_theta
-      = go this others
-      | otherwise
-      = Nothing
-
--- | Whether a collection of constraints is implied by another collection,
--- according to a simple superclass check.
---
--- See Note [When does a quantified instance dominate another?].
-impliedBySCs :: TcThetaType -> TcThetaType -> Bool
-impliedBySCs c1 c2 = all in_c2 c1
-  where
-    in_c2 :: TcPredType -> Bool
-    in_c2 pred = any (pred `tcEqType`) c2_expanded
-
-    c2_expanded :: [TcPredType]  -- Includes all superclasses
-    c2_expanded = [ q | p <- c2, q <- p : transSuperClasses p ]
-
-
-{- Note [When does a quantified instance dominate another?]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When matching local quantified instances, it's useful to be able to pick
-the one with the weakest precondition, e.g. if one has both
-
-  [G] d1: forall a b. ( Eq a, Num b, C a b  ) => D a b
-  [G] d2: forall a  .                C a Int  => D a Int
-  [W] {w}: D a Int
-
-Then it makes sense to use d2 to solve w, as doing so we end up with a strictly
-weaker proof obligation of `C a Int`, compared to `(Eq a, Num Int, C a Int)`
-were we to use d1.
-
-In theory, to compute whether one context implies another, we would need to
-recursively invoke the constraint solver. This is expensive, so we instead do
-a simple check using superclasses, implemented in impliedBySCs.
-
-Examples:
-
- - [Eq a] is implied by [Ord a]
- - [Ord a] is not implied by [Eq a],
- - any context is implied by itself,
- - the empty context is implied by any context.
-
-Note [Use only the best matching quantified constraint]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#20582) the ambiguity check for
-  (forall a. Ord (m a), forall a. Semigroup a => Eq (m a)) => m Int
-
-Because of eager expansion of given superclasses, we get
-  [G] d1: forall a. Ord (m a)
-  [G] d2: forall a. Eq (m a)
-  [G] d3: forall a. Semigroup a => Eq (m a)
-
-  [W] {w1}: forall a. Ord (m a)
-  [W] {w2}: forall a. Semigroup a => Eq (m a)
-
-The first wanted is solved straightforwardly. But the second wanted
-matches *two* local instances: d2 and d3. Our general rule around multiple local
-instances is that we refuse to commit to any of them. However, that
-means that our type fails the ambiguity check. That's bad: the type
-is perfectly fine. (This actually came up in the wild, in the streamly
-library.)
-
-The solution is to prefer local instances which are easier to prove, meaning
-that they have a weaker precondition. In this case, the empty context
-of d2 is a weaker constraint than the "Semigroup a" context of d3, so we prefer
-using it when proving w2. This allows us to pass the ambiguity check here.
-
-Our criterion for solving a Wanted by matching local quantified instances is
-thus as follows:
-
-  - There is a matching local quantified instance that dominates all others
-    matches, in the sense of [When does a quantified instance dominate another?].
-    Any such match do, we pick it arbitrarily (the T22223 example below says why).
-  - This local quantified instance also dominates all the unifiers, as we
-    wouldn't want to commit to a single match when we might have multiple,
-    genuinely different matches after further unification takes place.
-
-Some other examples:
-
-
-  #15244:
-
-    f :: (C g, D g) => ....
-    class S g => C g where ...
-    class S g => D g where ...
-    class (forall a. Eq a => Eq (g a)) => S g where ...
-
-  Here, in f's RHS, there are two identical quantified constraints
-  available, one via the superclasses of C and one via the superclasses
-  of D. Given that each implies the other, we pick one arbitrarily.
-
-
-  #22216:
-
-    class Eq a
-    class Eq a => Ord a
-    class (forall b. Eq b => Eq (f b)) => Eq1 f
-    class (Eq1 f, forall b. Ord b => Ord (f b)) => Ord1 f
-
-  Suppose we have
-
-    [G] d1: Ord1 f
-    [G] d2: Eq a
-    [W] {w}: Eq (f a)
-
-  Superclass expansion of d1 gives us:
-
-    [G] d3 : Eq1 f
-    [G] d4 : forall b. Ord b => Ord (f b)
-
-  expanding d4 and d5 gives us, respectively:
-
-    [G] d5 : forall b. Eq  b => Eq (f b)
-    [G] d6 : forall b. Ord b => Eq (f b)
-
-  Now we have two matching local instances that we could use when solving the
-  Wanted. However, it's obviously silly to use d6, given that d5 provides us with
-  as much information, with a strictly weaker precondition. So we pick d5 to solve
-  w. If we chose d6, we would get [W] Ord a, which in this case we can't solve.
-
-
-  #22223:
-
-    [G] forall a b. (Eq a, Ord b) => C a b
-    [G] forall a b. (Ord b, Eq a) => C a b
-    [W] C x y
-
-  Here we should be free to pick either quantified constraint, as they are
-  equivalent up to re-ordering of the constraints in the context.
-  See also Note [Do not add duplicate quantified instances]
-  in GHC.Tc.Solver.Monad.
-
-Test cases:
-  typecheck/should_compile/T20582
-  quantified-constraints/T15244
-  quantified-constraints/T22216{a,b,c,d,e}
-  quantified-constraints/T22223
-
-Historical note: a previous solution was to instead pick the local instance
-with the least superclass depth (see Note [Replacement vs keeping]),
-but that doesn't work for the example from #22216.
--}
diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Solver/Monad.hs
+++ /dev/null
@@ -1,2016 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-
-{-# OPTIONS_GHC -Wno-orphans #-}
-
--- | Monadic definitions for the constraint solver
-module GHC.Tc.Solver.Monad (
-
-    -- The TcS monad
-    TcS, runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts,
-    failTcS, warnTcS, addErrTcS, wrapTcS,
-    runTcSEqualities,
-    nestTcS, nestImplicTcS, setEvBindsTcS,
-    emitImplicationTcS, emitTvImplicationTcS,
-
-    selectNextWorkItem,
-    getWorkList,
-    updWorkListTcS,
-    pushLevelNoWorkList,
-
-    runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive,
-    matchGlobalInst, TcM.ClsInstResult(..),
-
-    QCInst(..),
-
-    -- Tracing etc
-    panicTcS, traceTcS,
-    traceFireTcS, bumpStepCountTcS, csTraceTcS,
-    wrapErrTcS, wrapWarnTcS,
-    resetUnificationFlag, setUnificationFlag,
-
-    -- Evidence creation and transformation
-    MaybeNew(..), freshGoals, isFresh, getEvExpr,
-
-    newTcEvBinds, newNoTcEvBinds,
-    newWantedEq, emitNewWantedEq,
-    newWanted,
-    newWantedNC, newWantedEvVarNC,
-    newBoundEvVarId,
-    unifyTyVar, reportUnifications, touchabilityTest, TouchabilityTestResult(..),
-    setEvBind, setWantedEq,
-    setWantedEvTerm, setEvBindIfWanted,
-    newEvVar, newGivenEvVar, newGivenEvVars,
-    checkReductionDepth,
-    getSolvedDicts, setSolvedDicts,
-
-    getInstEnvs, getFamInstEnvs,                -- Getting the environments
-    getTopEnv, getGblEnv, getLclEnv, setLclEnv,
-    getTcEvBindsVar, getTcLevel,
-    getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
-    tcLookupClass, tcLookupId,
-
-    -- Inerts
-    updInertTcS, updInertCans, updInertDicts, updInertIrreds,
-    getHasGivenEqs, setInertCans,
-    getInertEqs, getInertCans, getInertGivens,
-    getInertInsols, getInnermostGivenEqLevel,
-    getTcSInerts, setTcSInerts,
-    getUnsolvedInerts,
-    removeInertCts, getPendingGivenScs,
-    addInertCan, insertFunEq, addInertForAll,
-    emitWorkNC, emitWork,
-    lookupInertDict,
-
-    -- The Model
-    kickOutAfterUnification,
-
-    -- Inert Safe Haskell safe-overlap failures
-    addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,
-    getSafeOverlapFailures,
-
-    -- Inert solved dictionaries
-    addSolvedDict, lookupSolvedDict,
-
-    -- Irreds
-    foldIrreds,
-
-    -- The family application cache
-    lookupFamAppInert, lookupFamAppCache, extendFamAppCache,
-    pprKicked,
-
-    instDFunType,                              -- Instantiation
-
-    -- MetaTyVars
-    newFlexiTcSTy, instFlexiX,
-    cloneMetaTyVar,
-    tcInstSkolTyVarsX,
-
-    TcLevel,
-    isFilledMetaTyVar_maybe, isFilledMetaTyVar,
-    zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,
-    zonkTyCoVarsAndFVList,
-    zonkSimples, zonkWC,
-    zonkTyCoVarKind,
-
-    -- References
-    newTcRef, readTcRef, writeTcRef, updTcRef,
-
-    -- Misc
-    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,
-    matchFam, matchFamTcM,
-    checkWellStagedDFun,
-    pprEq,                                   -- Smaller utils, re-exported from TcM
-                                             -- TODO (DV): these are only really used in the
-                                             -- instance matcher in GHC.Tc.Solver. I am wondering
-                                             -- if the whole instance matcher simply belongs
-                                             -- here
-
-    breakTyEqCycle_maybe, rewriterView
-) where
-
-import GHC.Prelude
-
-import GHC.Driver.Env
-
-import qualified GHC.Tc.Utils.Instantiate as TcM
-import GHC.Core.InstEnv
-import GHC.Tc.Instance.Family as FamInst
-import GHC.Core.FamInstEnv
-
-import qualified GHC.Tc.Utils.Monad    as TcM
-import qualified GHC.Tc.Utils.TcMType  as TcM
-import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) )
-import qualified GHC.Tc.Utils.Env      as TcM
-       ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl
-       , tcInitTidyEnv )
-
-import GHC.Driver.Session
-
-import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon )
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Solver.Types
-import GHC.Tc.Solver.InertSet
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Errors.Types
-
-import GHC.Core.Type
-import qualified GHC.Core.TyCo.Rep as Rep  -- this needs to be used only very locally
-import GHC.Core.Coercion
-import GHC.Core.Reduction
-import GHC.Core.Class
-import GHC.Core.TyCon
-
-import GHC.Types.Error ( mkPlainError, noHints )
-import GHC.Types.Name
-import GHC.Types.TyThing
-import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt )
-
-import GHC.Unit.Module ( HasModule, getModule, extractModule )
-import qualified GHC.Rename.Env as TcM
-import GHC.Types.Var
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Logger
-import GHC.Utils.Misc (HasDebugCallStack)
-import GHC.Data.Bag as Bag
-import GHC.Types.Unique.Supply
-import GHC.Tc.Types
-import GHC.Tc.Types.Origin
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Utils.Unify
-import GHC.Core.Predicate
-import GHC.Types.Unique.Set (nonDetEltsUniqSet)
-
-import Control.Monad
-import GHC.Utils.Monad
-import Data.IORef
-import GHC.Exts (oneShot)
-import Data.List ( mapAccumL, partition, find )
-
-#if defined(DEBUG)
-import GHC.Data.Graph.Directed
-#endif
-
-{- *********************************************************************
-*                                                                      *
-                   Inert instances: inert_insts
-*                                                                      *
-********************************************************************* -}
-
-addInertForAll :: QCInst -> TcS ()
--- Add a local Given instance, typically arising from a type signature
-addInertForAll new_qci
-  = do { ics  <- getInertCans
-       ; ics1 <- add_qci ics
-
-       -- Update given equalities. C.f updateGivenEqs
-       ; tclvl <- getTcLevel
-       ; let pred         = qci_pred new_qci
-             not_equality = isClassPred pred && not (isEqPred pred)
-                  -- True <=> definitely not an equality
-                  -- A qci_pred like (f a) might be an equality
-
-             ics2 | not_equality = ics1
-                  | otherwise    = ics1 { inert_given_eq_lvl = tclvl
-                                        , inert_given_eqs    = True }
-
-       ; setInertCans ics2 }
-  where
-    add_qci :: InertCans -> TcS InertCans
-    -- See Note [Do not add duplicate quantified instances]
-    add_qci ics@(IC { inert_insts = qcis })
-      | any same_qci qcis
-      = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci)
-           ; return ics }
-
-      | otherwise
-      = do { traceTcS "adding new inert quantified instance" (ppr new_qci)
-           ; return (ics { inert_insts = new_qci : qcis }) }
-
-    same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci))
-                                (ctEvPred (qci_ev new_qci))
-
-{- Note [Do not add duplicate quantified instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As an optimisation, we avoid adding duplicate quantified instances to the
-inert set; we use a simple duplicate check using tcEqType for simplicity,
-even though it doesn't account for superficial differences, e.g. it will count
-the following two constraints as different (#22223):
-
-  - forall a b. C a b
-  - forall b a. C a b
-
-The main logic that allows us to pick local instances, even in the presence of
-duplicates, is explained in Note [Use only the best matching quantified constraint]
-in GHC.Tc.Solver.Interact.
--}
-
-{- *********************************************************************
-*                                                                      *
-                  Adding an inert
-*                                                                      *
-************************************************************************
-
-Note [Adding an equality to the InertCans]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When adding an equality to the inerts:
-
-* Kick out any constraints that can be rewritten by the thing
-  we are adding.  Done by kickOutRewritable.
-
-* Note that unifying a:=ty, is like adding [G] a~ty; just use
-  kickOutRewritable with Nominal, Given.  See kickOutAfterUnification.
-
-Note [Kick out existing binding for implicit parameter]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have (typecheck/should_compile/ImplicitParamFDs)
-  flub :: (?x :: Int) => (Int, Integer)
-  flub = (?x, let ?x = 5 in ?x)
-When we are checking the last ?x occurrence, we guess its type
-to be a fresh unification variable alpha and emit an (IP "x" alpha)
-constraint. But the given (?x :: Int) has been translated to an
-IP "x" Int constraint, which has a functional dependency from the
-name to the type. So fundep interaction tells us that alpha ~ Int,
-and we get a type error. This is bad.
-
-Instead, we wish to excise any old given for an IP when adding a
-new one. We also must make sure not to float out
-any IP constraints outside an implication that binds an IP of
-the same name; see GHC.Tc.Solver.floatConstraints.
--}
-
-addInertCan :: Ct -> TcS ()
--- Precondition: item /is/ canonical
--- See Note [Adding an equality to the InertCans]
-addInertCan ct =
-    do { traceTcS "addInertCan {" $
-         text "Trying to insert new inert item:" <+> ppr ct
-       ; mkTcS (\TcSEnv{tcs_abort_on_insoluble=abort_flag} ->
-                 when (abort_flag && insolubleEqCt ct) TcM.failM)
-       ; ics <- getInertCans
-       ; ics <- maybeKickOut ics ct
-       ; tclvl <- getTcLevel
-       ; setInertCans (addInertItem tclvl ics ct)
-
-       ; traceTcS "addInertCan }" $ empty }
-
-maybeKickOut :: InertCans -> Ct -> TcS InertCans
--- For a CEqCan, kick out any inert that can be rewritten by the CEqCan
-maybeKickOut ics ct
-  | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct
-  = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics
-       ; return ics' }
-
-     -- See [Kick out existing binding for implicit parameter]
-  | isGivenCt ct
-  , CDictCan { cc_class = cls, cc_tyargs = [ip_name_strty, _ip_ty] } <- ct
-  , isIPClass cls
-  , Just ip_name <- isStrLitTy ip_name_strty
-     -- Would this be more efficient if we used findDictsByClass and then delDict?
-  = let dict_map = inert_dicts ics
-        dict_map' = filterDicts doesn't_match_ip_name dict_map
-
-        doesn't_match_ip_name :: Ct -> Bool
-        doesn't_match_ip_name ct
-          | Just (inert_ip_name, _inert_ip_ty) <- isIPPred_maybe (ctPred ct)
-          = inert_ip_name /= ip_name
-
-          | otherwise
-          = True
-
-    in
-    return (ics { inert_dicts = dict_map' })
-
-  | otherwise
-  = return ics
-
------------------------------------------
-kickOutRewritable  :: CtFlavourRole  -- Flavour/role of the equality that
-                                      -- is being added to the inert set
-                   -> CanEqLHS        -- The new equality is lhs ~ ty
-                   -> InertCans
-                   -> TcS (Int, InertCans)
-kickOutRewritable new_fr new_lhs ics
-  = do { let (kicked_out, ics') = kickOutRewritableLHS new_fr new_lhs ics
-             n_kicked = workListSize kicked_out
-
-       ; unless (n_kicked == 0) $
-         do { updWorkListTcS (appendWorkList kicked_out)
-
-              -- The famapp-cache contains Given evidence from the inert set.
-              -- If we're kicking out Givens, we need to remove this evidence
-              -- from the cache, too.
-            ; let kicked_given_ev_vars =
-                    [ ev_var | ct <- wl_eqs kicked_out
-                             , CtGiven { ctev_evar = ev_var } <- [ctEvidence ct] ]
-            ; when (new_fr `eqCanRewriteFR` (Given, NomEq) &&
-                   -- if this isn't true, no use looking through the constraints
-                    not (null kicked_given_ev_vars)) $
-              do { traceTcS "Given(s) have been kicked out; drop from famapp-cache"
-                            (ppr kicked_given_ev_vars)
-                 ; dropFromFamAppCache (mkVarSet kicked_given_ev_vars) }
-
-            ; csTraceTcS $
-              hang (text "Kick out, lhs =" <+> ppr new_lhs)
-                 2 (vcat [ text "n-kicked =" <+> int n_kicked
-                         , text "kicked_out =" <+> ppr kicked_out
-                         , text "Residual inerts =" <+> ppr ics' ]) }
-
-       ; return (n_kicked, ics') }
-
-kickOutAfterUnification :: TcTyVar -> TcS Int
-kickOutAfterUnification new_tv
-  = do { ics <- getInertCans
-       ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)
-                                                 (TyVarLHS new_tv) ics
-                     -- Given because the tv := xi is given; NomEq because
-                     -- only nominal equalities are solved by unification
-
-       ; setInertCans ics2
-       ; return n_kicked }
-
--- See Wrinkle (2) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical
--- It's possible that this could just go ahead and unify, but could there be occurs-check
--- problems? Seems simpler just to kick out.
-kickOutAfterFillingCoercionHole :: CoercionHole -> TcS ()
-kickOutAfterFillingCoercionHole hole
-  = do { ics <- getInertCans
-       ; let (kicked_out, ics') = kick_out ics
-             n_kicked           = workListSize kicked_out
-
-       ; unless (n_kicked == 0) $
-         do { updWorkListTcS (appendWorkList kicked_out)
-            ; csTraceTcS $
-              hang (text "Kick out, hole =" <+> ppr hole)
-                 2 (vcat [ text "n-kicked =" <+> int n_kicked
-                         , text "kicked_out =" <+> ppr kicked_out
-                         , text "Residual inerts =" <+> ppr ics' ]) }
-
-       ; setInertCans ics' }
-  where
-    kick_out :: InertCans -> (WorkList, InertCans)
-    kick_out ics@(IC { inert_eqs = eqs, inert_funeqs = funeqs })
-      = (kicked_out, ics { inert_eqs = eqs_to_keep, inert_funeqs = funeqs_to_keep })
-      where
-        (eqs_to_kick, eqs_to_keep)       = partitionInertEqs kick_ct eqs
-        (funeqs_to_kick, funeqs_to_keep) = partitionFunEqs kick_ct funeqs
-        kicked_out = extendWorkListCts (eqs_to_kick ++ funeqs_to_kick) emptyWorkList
-
-    kick_ct :: Ct -> Bool
-         -- True: kick out; False: keep.
-    kick_ct (CEqCan { cc_rhs = rhs, cc_ev = ctev })
-      = isWanted ctev &&    -- optimisation: givens don't have coercion holes anyway
-        rhs `hasThisCoercionHoleTy` hole
-    kick_ct other = pprPanic "kick_ct (coercion hole)" (ppr other)
-
---------------
-addInertSafehask :: InertCans -> Ct -> InertCans
-addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })
-  = ics { inert_safehask = addDict (inert_dicts ics) cls tys item }
-
-addInertSafehask _ item
-  = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item
-
-insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS ()
--- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver
-insertSafeOverlapFailureTcS what item
-  | safeOverlap what = return ()
-  | otherwise        = updInertCans (\ics -> addInertSafehask ics item)
-
-getSafeOverlapFailures :: TcS Cts
--- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver
-getSafeOverlapFailures
- = do { IC { inert_safehask = safehask } <- getInertCans
-      ; return $ foldDicts consCts safehask emptyCts }
-
---------------
-addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS ()
--- Conditionally add a new item in the solved set of the monad
--- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet
-addSolvedDict what item cls tys
-  | isWanted item
-  , instanceReturnsDictCon what
-  = do { traceTcS "updSolvedSetTcs:" $ ppr item
-       ; updInertTcS $ \ ics ->
-             ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }
-  | otherwise
-  = return ()
-
-getSolvedDicts :: TcS (DictMap CtEvidence)
-getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) }
-
-setSolvedDicts :: DictMap CtEvidence -> TcS ()
-setSolvedDicts solved_dicts
-  = updInertTcS $ \ ics ->
-    ics { inert_solved_dicts = solved_dicts }
-
-{- *********************************************************************
-*                                                                      *
-                  Other inert-set operations
-*                                                                      *
-********************************************************************* -}
-
-updInertTcS :: (InertSet -> InertSet) -> TcS ()
--- Modify the inert set with the supplied function
-updInertTcS upd_fn
-  = do { is_var <- getTcSInertsRef
-       ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var
-                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }
-
-getInertCans :: TcS InertCans
-getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) }
-
-setInertCans :: InertCans -> TcS ()
-setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }
-
-updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a
--- Modify the inert set with the supplied function
-updRetInertCans upd_fn
-  = do { is_var <- getTcSInertsRef
-       ; wrapTcS (do { inerts <- TcM.readTcRef is_var
-                     ; let (res, cans') = upd_fn (inert_cans inerts)
-                     ; TcM.writeTcRef is_var (inerts { inert_cans = cans' })
-                     ; return res }) }
-
-updInertCans :: (InertCans -> InertCans) -> TcS ()
--- Modify the inert set with the supplied function
-updInertCans upd_fn
-  = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }
-
-updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()
--- Modify the inert set with the supplied function
-updInertDicts upd_fn
-  = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) }
-
-updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()
--- Modify the inert set with the supplied function
-updInertSafehask upd_fn
-  = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }
-
-updInertIrreds :: (Cts -> Cts) -> TcS ()
--- Modify the inert set with the supplied function
-updInertIrreds upd_fn
-  = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) }
-
-getInertEqs :: TcS InertEqs
-getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }
-
-getInnermostGivenEqLevel :: TcS TcLevel
-getInnermostGivenEqLevel = do { inert <- getInertCans
-                              ; return (inert_given_eq_lvl inert) }
-
-getInertInsols :: TcS Cts
--- Returns insoluble equality constraints and TypeError constraints,
--- specifically including Givens.
---
--- Note that this function only inspects irreducible constraints;
--- a DictCan constraint such as 'Eq (TypeError msg)' is not
--- considered to be an insoluble constraint by this function.
---
--- See Note [Pattern match warnings with insoluble Givens] in GHC.Tc.Solver.
-getInertInsols = do { inert <- getInertCans
-                    ; return $ filterBag insolubleCt (inert_irreds inert) }
-
-getInertGivens :: TcS [Ct]
--- Returns the Given constraints in the inert set
-getInertGivens
-  = do { inerts <- getInertCans
-       ; let all_cts = foldIrreds (:) (inert_irreds inerts)
-                     $ foldDicts (:) (inert_dicts inerts)
-                     $ foldFunEqs (++) (inert_funeqs inerts)
-                     $ foldDVarEnv (++) [] (inert_eqs inerts)
-       ; return (filter isGivenCt all_cts) }
-
-getPendingGivenScs :: TcS [Ct]
--- Find all inert Given dictionaries, or quantified constraints,
---     whose cc_pend_sc flag is True
---     and that belong to the current level
--- Set their cc_pend_sc flag to False in the inert set, and return that Ct
-getPendingGivenScs = do { lvl <- getTcLevel
-                        ; updRetInertCans (get_sc_pending lvl) }
-
-get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)
-get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
-  = assertPpr (all isGivenCt sc_pending) (ppr sc_pending)
-       -- When getPendingScDics is called,
-       -- there are never any Wanteds in the inert set
-    (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' })
-  where
-    sc_pending = sc_pend_insts ++ sc_pend_dicts
-
-    sc_pend_dicts = foldDicts get_pending dicts []
-    dicts' = foldr add dicts sc_pend_dicts
-
-    (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts
-
-    get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True
-                                       -- but flipping the flag
-    get_pending dict dicts
-        | Just dict' <- pendingScDict_maybe dict
-        , belongs_to_this_level (ctEvidence dict)
-        = dict' : dicts
-        | otherwise
-        = dicts
-
-    add :: Ct -> DictMap Ct -> DictMap Ct
-    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
-        = addDict dicts cls tys ct
-    add ct _ = pprPanic "getPendingScDicts" (ppr ct)
-
-    get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)
-    get_pending_inst cts qci@(QCI { qci_ev = ev })
-       | Just qci' <- pendingScInst_maybe qci
-       , belongs_to_this_level ev
-       = (CQuantCan qci' : cts, qci')
-       | otherwise
-       = (cts, qci)
-
-    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl
-    -- We only want Givens from this level; see (3a) in
-    -- Note [The superclass story] in GHC.Tc.Solver.Canonical
-
-getUnsolvedInerts :: TcS ( Bag Implication
-                         , Cts )   -- All simple constraints
--- Return all the unsolved [Wanted] constraints
---
--- Post-condition: the returned simple constraints are all fully zonked
---                     (because they come from the inert set)
---                 the unsolved implics may not be
-getUnsolvedInerts
- = do { IC { inert_eqs     = tv_eqs
-           , inert_funeqs  = fun_eqs
-           , inert_irreds  = irreds
-           , inert_dicts   = idicts
-           } <- getInertCans
-
-      ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts
-            unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts
-            unsolved_irreds  = Bag.filterBag isWantedCt irreds
-            unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts
-            unsolved_others  = unionManyBags [ unsolved_irreds
-                                             , unsolved_dicts ]
-
-      ; implics <- getWorkListImplics
-
-      ; traceTcS "getUnsolvedInerts" $
-        vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs
-             , text "fun eqs =" <+> ppr unsolved_fun_eqs
-             , text "others =" <+> ppr unsolved_others
-             , text "implics =" <+> ppr implics ]
-
-      ; return ( implics, unsolved_tv_eqs `unionBags`
-                          unsolved_fun_eqs `unionBags`
-                          unsolved_others) }
-  where
-    add_if_unsolved :: Ct -> Cts -> Cts
-    add_if_unsolved ct cts | isWantedCt ct = ct `consCts` cts
-                           | otherwise     = cts
-
-    add_if_unsolveds :: EqualCtList -> Cts -> Cts
-    add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts new_cts
-
-getHasGivenEqs :: TcLevel           -- TcLevel of this implication
-               -> TcS ( HasGivenEqs -- are there Given equalities?
-                      , Cts )       -- Insoluble equalities arising from givens
--- See Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet
-getHasGivenEqs tclvl
-  = do { inerts@(IC { inert_irreds       = irreds
-                    , inert_given_eqs    = given_eqs
-                    , inert_given_eq_lvl = ge_lvl })
-              <- getInertCans
-       ; let given_insols = filterBag insoluble_given_equality irreds
-                      -- Specifically includes ones that originated in some
-                      -- outer context but were refined to an insoluble by
-                      -- a local equality; so no level-check needed
-
-             -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and
-             -- Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet
-             has_ge | ge_lvl == tclvl = MaybeGivenEqs
-                    | given_eqs       = LocalGivenEqs
-                    | otherwise       = NoGivenEqs
-
-       ; traceTcS "getHasGivenEqs" $
-         vcat [ text "given_eqs:" <+> ppr given_eqs
-              , text "ge_lvl:" <+> ppr ge_lvl
-              , text "ambient level:" <+> ppr tclvl
-              , text "Inerts:" <+> ppr inerts
-              , text "Insols:" <+> ppr given_insols]
-       ; return (has_ge, given_insols) }
-  where
-    insoluble_given_equality ct
-       = insolubleEqCt ct && isGivenCt ct
-
-removeInertCts :: [Ct] -> InertCans -> InertCans
--- ^ Remove inert constraints from the 'InertCans', for use when a
--- typechecker plugin wishes to discard a given.
-removeInertCts cts icans = foldl' removeInertCt icans cts
-
-removeInertCt :: InertCans -> Ct -> InertCans
-removeInertCt is ct =
-  case ct of
-
-    CDictCan  { cc_class = cl, cc_tyargs = tys } ->
-      is { inert_dicts = delDict (inert_dicts is) cl tys }
-
-    CEqCan    { cc_lhs  = lhs, cc_rhs = rhs } -> delEq is lhs rhs
-
-    CIrredCan {}     -> is { inert_irreds = filterBag (not . eqCt ct) $ inert_irreds is }
-
-    CQuantCan {}     -> panic "removeInertCt: CQuantCan"
-    CNonCanonical {} -> panic "removeInertCt: CNonCanonical"
-
-eqCt :: Ct -> Ct -> Bool
--- Equality via ctEvId
-eqCt c c' = ctEvId c == ctEvId c'
-
--- | Looks up a family application in the inerts.
-lookupFamAppInert :: (CtFlavourRole -> Bool)  -- can it rewrite the target?
-                  -> TyCon -> [Type] -> TcS (Maybe (Reduction, CtFlavourRole))
-lookupFamAppInert rewrite_pred fam_tc tys
-  = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts
-       ; return (lookup_inerts inert_funeqs) }
-  where
-    lookup_inerts inert_funeqs
-      | Just ecl <- findFunEq inert_funeqs fam_tc tys
-      , Just (CEqCan { cc_ev = ctev, cc_rhs = rhs })
-          <- find (rewrite_pred . ctFlavourRole) ecl
-      = Just (mkReduction (ctEvCoercion ctev) rhs, ctEvFlavourRole ctev)
-      | otherwise = Nothing
-
-lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)
--- Is this exact predicate type cached in the solved or canonicals of the InertSet?
-lookupInInerts loc pty
-  | ClassPred cls tys <- classifyPredType pty
-  = do { inerts <- getTcSInerts
-       ; return (lookupSolvedDict inerts loc cls tys `mplus`
-                 fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)) }
-  | otherwise -- NB: No caching for equalities, IPs, holes, or errors
-  = return Nothing
-
--- | Look up a dictionary inert.
-lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe Ct
-lookupInertDict (IC { inert_dicts = dicts }) loc cls tys
-  = case findDict dicts loc cls tys of
-      Just ct -> Just ct
-      _       -> Nothing
-
--- | Look up a solved inert.
-lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence
--- Returns just if exactly this predicate type exists in the solved.
-lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys
-  = case findDict solved loc cls tys of
-      Just ev -> Just ev
-      _       -> Nothing
-
----------------------------
-lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe Reduction)
-lookupFamAppCache fam_tc tys
-  = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts
-       ; case findFunEq famapp_cache fam_tc tys of
-           result@(Just redn) ->
-             do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys)
-                                                    , ppr redn ])
-                ; return result }
-           Nothing -> return Nothing }
-
-extendFamAppCache :: TyCon -> [Type] -> Reduction -> TcS ()
--- NB: co :: rhs ~ F tys, to match expectations of rewriter
-extendFamAppCache tc xi_args stuff@(Reduction _ ty)
-  = do { dflags <- getDynFlags
-       ; when (gopt Opt_FamAppCache dflags) $
-    do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args
-                                            , ppr ty ])
-       ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) ->
-            is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } }
-
--- Remove entries from the cache whose evidence mentions variables in the
--- supplied set
-dropFromFamAppCache :: VarSet -> TcS ()
-dropFromFamAppCache varset
-  = do { inerts@(IS { inert_famapp_cache = famapp_cache }) <- getTcSInerts
-       ; let filtered = filterTcAppMap check famapp_cache
-       ; setTcSInerts $ inerts { inert_famapp_cache = filtered } }
-  where
-    check :: Reduction -> Bool
-    check redn
-      = not (anyFreeVarsOfCo (`elemVarSet` varset) $ reductionCoercion redn)
-
-{- *********************************************************************
-*                                                                      *
-                   Irreds
-*                                                                      *
-********************************************************************* -}
-
-foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b
-foldIrreds k irreds z = foldr k z irreds
-
-{-
-************************************************************************
-*                                                                      *
-*              The TcS solver monad                                    *
-*                                                                      *
-************************************************************************
-
-Note [The TcS monad]
-~~~~~~~~~~~~~~~~~~~~
-The TcS monad is a weak form of the main Tc monad
-
-All you can do is
-    * fail
-    * allocate new variables
-    * fill in evidence variables
-
-Filling in a dictionary evidence variable means to create a binding
-for it, so TcS carries a mutable location where the binding can be
-added.  This is initialised from the innermost implication constraint.
--}
-
-data TcSEnv
-  = TcSEnv {
-      tcs_ev_binds    :: EvBindsVar,
-
-      tcs_unified     :: IORef Int,
-         -- The number of unification variables we have filled
-         -- The important thing is whether it is non-zero
-
-      tcs_unif_lvl  :: IORef (Maybe TcLevel),
-         -- The Unification Level Flag
-         -- Outermost level at which we have unified a meta tyvar
-         -- Starts at Nothing, then (Just i), then (Just j) where j<i
-         -- See Note [The Unification Level Flag]
-
-      tcs_count     :: IORef Int, -- Global step count
-
-      tcs_inerts    :: IORef InertSet, -- Current inert set
-
-      -- Whether to throw an exception if we come across an insoluble constraint.
-      -- Used to fail-fast when checking for hole-fits. See Note [Speeding up
-      -- valid hole-fits].
-      tcs_abort_on_insoluble :: Bool,
-
-      -- See Note [WorkList priorities] in GHC.Tc.Solver.InertSet
-      tcs_worklist  :: IORef WorkList -- Current worklist
-    }
-
----------------
-newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor)
-
--- | Smart constructor for 'TcS', as describe in Note [The one-shot state
--- monad trick] in "GHC.Utils.Monad".
-mkTcS :: (TcSEnv -> TcM a) -> TcS a
-mkTcS f = TcS (oneShot f)
-
-instance Applicative TcS where
-  pure x = mkTcS $ \_ -> return x
-  (<*>) = ap
-
-instance Monad TcS where
-  m >>= k   = mkTcS $ \ebs -> do
-    unTcS m ebs >>= (\r -> unTcS (k r) ebs)
-
-instance MonadIO TcS where
-  liftIO act = TcS $ \_env -> liftIO act
-
-instance MonadFail TcS where
-  fail err  = mkTcS $ \_ -> fail err
-
-instance MonadUnique TcS where
-   getUniqueSupplyM = wrapTcS getUniqueSupplyM
-
-instance HasModule TcS where
-   getModule = wrapTcS getModule
-
-instance MonadThings TcS where
-   lookupThing n = wrapTcS (lookupThing n)
-
--- Basic functionality
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-wrapTcS :: TcM a -> TcS a
--- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,
--- and TcS is supposed to have limited functionality
-wrapTcS action = mkTcS $ \_env -> action -- a TcM action will not use the TcEvBinds
-
-wrap2TcS :: (TcM a -> TcM a) -> TcS a -> TcS a
-wrap2TcS fn (TcS thing) = mkTcS $ \env -> fn (thing env)
-
-wrapErrTcS :: TcM a -> TcS a
--- The thing wrapped should just fail
--- There's no static check; it's up to the user
--- Having a variant for each error message is too painful
-wrapErrTcS = wrapTcS
-
-wrapWarnTcS :: TcM a -> TcS a
--- The thing wrapped should just add a warning, or no-op
--- There's no static check; it's up to the user
-wrapWarnTcS = wrapTcS
-
-panicTcS  :: SDoc -> TcS a
-failTcS   :: TcRnMessage -> TcS a
-warnTcS, addErrTcS :: TcRnMessage -> TcS ()
-failTcS      = wrapTcS . TcM.failWith
-warnTcS msg  = wrapTcS (TcM.addDiagnostic msg)
-addErrTcS    = wrapTcS . TcM.addErr
-panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc
-
-traceTcS :: String -> SDoc -> TcS ()
-traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)
-{-# INLINE traceTcS #-}  -- see Note [INLINE conditional tracing utilities]
-
-runTcPluginTcS :: TcPluginM a -> TcS a
-runTcPluginTcS = wrapTcS . runTcPluginM
-
-instance HasDynFlags TcS where
-    getDynFlags = wrapTcS getDynFlags
-
-getGlobalRdrEnvTcS :: TcS GlobalRdrEnv
-getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv
-
-bumpStepCountTcS :: TcS ()
-bumpStepCountTcS = mkTcS $ \env ->
-  do { let ref = tcs_count env
-     ; n <- TcM.readTcRef ref
-     ; TcM.writeTcRef ref (n+1) }
-
-csTraceTcS :: SDoc -> TcS ()
-csTraceTcS doc
-  = wrapTcS $ csTraceTcM (return doc)
-{-# INLINE csTraceTcS #-}  -- see Note [INLINE conditional tracing utilities]
-
-traceFireTcS :: CtEvidence -> SDoc -> TcS ()
--- Dump a rule-firing trace
-traceFireTcS ev doc
-  = mkTcS $ \env -> csTraceTcM $
-    do { n <- TcM.readTcRef (tcs_count env)
-       ; tclvl <- TcM.getTcLevel
-       ; return (hang (text "Step" <+> int n
-                       <> brackets (text "l:" <> ppr tclvl <> comma <>
-                                    text "d:" <> ppr (ctLocDepth (ctEvLoc ev)))
-                       <+> doc <> colon)
-                     4 (ppr ev)) }
-{-# INLINE traceFireTcS #-}  -- see Note [INLINE conditional tracing utilities]
-
-csTraceTcM :: TcM SDoc -> TcM ()
--- Constraint-solver tracing, -ddump-cs-trace
-csTraceTcM mk_doc
-  = do { logger <- getLogger
-       ; when (  logHasDumpFlag logger Opt_D_dump_cs_trace
-                  || logHasDumpFlag logger Opt_D_dump_tc_trace)
-              ( do { msg <- mk_doc
-                   ; TcM.dumpTcRn False
-                       Opt_D_dump_cs_trace
-                       "" FormatText
-                       msg }) }
-{-# INLINE csTraceTcM #-}  -- see Note [INLINE conditional tracing utilities]
-
-runTcS :: TcS a                -- What to run
-       -> TcM (a, EvBindMap)
-runTcS tcs
-  = do { ev_binds_var <- TcM.newTcEvBinds
-       ; res <- runTcSWithEvBinds ev_binds_var tcs
-       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
-       ; return (res, ev_binds) }
-
--- | This variant of 'runTcS' will immediately fail upon encountering an
--- insoluble ct. See Note [Speeding up valid hole-fits]. Its one usage
--- site does not need the ev_binds, so we do not return them.
-runTcSEarlyAbort :: TcS a -> TcM a
-runTcSEarlyAbort tcs
-  = do { ev_binds_var <- TcM.newTcEvBinds
-       ; runTcSWithEvBinds' True True ev_binds_var tcs }
-
--- | This can deal only with equality constraints.
-runTcSEqualities :: TcS a -> TcM a
-runTcSEqualities thing_inside
-  = do { ev_binds_var <- TcM.newNoTcEvBinds
-       ; runTcSWithEvBinds ev_binds_var thing_inside }
-
--- | A variant of 'runTcS' that takes and returns an 'InertSet' for
--- later resumption of the 'TcS' session.
-runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)
-runTcSInerts inerts tcs = do
-  ev_binds_var <- TcM.newTcEvBinds
-  runTcSWithEvBinds' False False ev_binds_var $ do
-    setTcSInerts inerts
-    a <- tcs
-    new_inerts <- getTcSInerts
-    return (a, new_inerts)
-
-runTcSWithEvBinds :: EvBindsVar
-                  -> TcS a
-                  -> TcM a
-runTcSWithEvBinds = runTcSWithEvBinds' True False
-
-runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards?
-                           -- Don't if you want to reuse the InertSet.
-                           -- See also Note [Type equality cycles]
-                           -- in GHC.Tc.Solver.Canonical
-                   -> Bool
-                   -> EvBindsVar
-                   -> TcS a
-                   -> TcM a
-runTcSWithEvBinds' restore_cycles abort_on_insoluble ev_binds_var tcs
-  = do { unified_var <- TcM.newTcRef 0
-       ; step_count <- TcM.newTcRef 0
-       ; inert_var <- TcM.newTcRef emptyInert
-       ; wl_var <- TcM.newTcRef emptyWorkList
-       ; unif_lvl_var <- TcM.newTcRef Nothing
-       ; let env = TcSEnv { tcs_ev_binds           = ev_binds_var
-                          , tcs_unified            = unified_var
-                          , tcs_unif_lvl           = unif_lvl_var
-                          , tcs_count              = step_count
-                          , tcs_inerts             = inert_var
-                          , tcs_abort_on_insoluble = abort_on_insoluble
-                          , tcs_worklist           = wl_var }
-
-             -- Run the computation
-       ; res <- unTcS tcs env
-
-       ; count <- TcM.readTcRef step_count
-       ; when (count > 0) $
-         csTraceTcM $ return (text "Constraint solver steps =" <+> int count)
-
-       ; when restore_cycles $
-         do { inert_set <- TcM.readTcRef inert_var
-            ; restoreTyVarCycles inert_set }
-
-#if defined(DEBUG)
-       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
-       ; checkForCyclicBinds ev_binds
-#endif
-
-       ; return res }
-
-----------------------------
-#if defined(DEBUG)
-checkForCyclicBinds :: EvBindMap -> TcM ()
-checkForCyclicBinds ev_binds_map
-  | null cycles
-  = return ()
-  | null coercion_cycles
-  = TcM.traceTc "Cycle in evidence binds" $ ppr cycles
-  | otherwise
-  = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles
-  where
-    ev_binds = evBindMapBinds ev_binds_map
-
-    cycles :: [[EvBind]]
-    cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]
-
-    coercion_cycles = [c | c <- cycles, any is_co_bind c]
-    is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b)
-
-    edges :: [ Node EvVar EvBind ]
-    edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))
-            | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]
-            -- It's OK to use nonDetEltsUFM here as
-            -- stronglyConnCompFromEdgedVertices is still deterministic even
-            -- if the edges are in nondeterministic order as explained in
-            -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.
-#endif
-
-----------------------------
-setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a
-setEvBindsTcS ref (TcS thing_inside)
- = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref })
-
-nestImplicTcS :: EvBindsVar
-              -> TcLevel -> TcS a
-              -> TcS a
-nestImplicTcS ref inner_tclvl (TcS thing_inside)
-  = TcS $ \ TcSEnv { tcs_unified            = unified_var
-                   , tcs_inerts             = old_inert_var
-                   , tcs_count              = count
-                   , tcs_unif_lvl           = unif_lvl
-                   , tcs_abort_on_insoluble = abort_on_insoluble
-                   } ->
-    do { inerts <- TcM.readTcRef old_inert_var
-       ; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack
-                                                            (inert_cycle_breakers inerts)
-                                 , inert_cans = (inert_cans inerts)
-                                                   { inert_given_eqs = False } }
-                 -- All other InertSet fields are inherited
-       ; new_inert_var <- TcM.newTcRef nest_inert
-       ; new_wl_var    <- TcM.newTcRef emptyWorkList
-       ; let nest_env = TcSEnv { tcs_count              = count     -- Inherited
-                               , tcs_unif_lvl           = unif_lvl  -- Inherited
-                               , tcs_ev_binds           = ref
-                               , tcs_unified            = unified_var
-                               , tcs_inerts             = new_inert_var
-                               , tcs_abort_on_insoluble = abort_on_insoluble
-                               , tcs_worklist           = new_wl_var }
-       ; res <- TcM.setTcLevel inner_tclvl $
-                thing_inside nest_env
-
-       ; out_inert_set <- TcM.readTcRef new_inert_var
-       ; restoreTyVarCycles out_inert_set
-
-#if defined(DEBUG)
-       -- Perform a check that the thing_inside did not cause cycles
-       ; ev_binds <- TcM.getTcEvBindsMap ref
-       ; checkForCyclicBinds ev_binds
-#endif
-       ; return res }
-
-nestTcS ::  TcS a -> TcS a
--- Use the current untouchables, augmenting the current
--- evidence bindings, and solved dictionaries
--- But have no effect on the InertCans, or on the inert_famapp_cache
--- (we want to inherit the latter from processing the Givens)
-nestTcS (TcS thing_inside)
-  = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->
-    do { inerts <- TcM.readTcRef inerts_var
-       ; new_inert_var <- TcM.newTcRef inerts
-       ; new_wl_var    <- TcM.newTcRef emptyWorkList
-       ; let nest_env = env { tcs_inerts   = new_inert_var
-                            , tcs_worklist = new_wl_var }
-
-       ; res <- thing_inside nest_env
-
-       ; new_inerts <- TcM.readTcRef new_inert_var
-
-       -- we want to propagate the safe haskell failures
-       ; let old_ic = inert_cans inerts
-             new_ic = inert_cans new_inerts
-             nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }
-
-       ; TcM.writeTcRef inerts_var  -- See Note [Propagate the solved dictionaries]
-                        (inerts { inert_solved_dicts = inert_solved_dicts new_inerts
-                                , inert_cans = nxt_ic })
-
-       ; return res }
-
-emitImplicationTcS :: TcLevel -> SkolemInfoAnon
-                   -> [TcTyVar]        -- Skolems
-                   -> [EvVar]          -- Givens
-                   -> Cts              -- Wanteds
-                   -> TcS TcEvBinds
--- Add an implication to the TcS monad work-list
-emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds
-  = do { let wc = emptyWC { wc_simple = wanteds }
-       ; imp <- wrapTcS $
-                do { ev_binds_var <- TcM.newTcEvBinds
-                   ; imp <- TcM.newImplication
-                   ; return (imp { ic_tclvl  = new_tclvl
-                                 , ic_skols  = skol_tvs
-                                 , ic_given  = givens
-                                 , ic_wanted = wc
-                                 , ic_binds  = ev_binds_var
-                                 , ic_info   = skol_info }) }
-
-       ; emitImplication imp
-       ; return (TcEvBinds (ic_binds imp)) }
-
-emitTvImplicationTcS :: TcLevel -> SkolemInfoAnon
-                     -> [TcTyVar]        -- Skolems
-                     -> Cts              -- Wanteds
-                     -> TcS ()
--- Just like emitImplicationTcS but no givens and no bindings
-emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds
-  = do { let wc = emptyWC { wc_simple = wanteds }
-       ; imp <- wrapTcS $
-                do { ev_binds_var <- TcM.newNoTcEvBinds
-                   ; imp <- TcM.newImplication
-                   ; return (imp { ic_tclvl  = new_tclvl
-                                 , ic_skols  = skol_tvs
-                                 , ic_wanted = wc
-                                 , ic_binds  = ev_binds_var
-                                 , ic_info   = skol_info }) }
-
-       ; emitImplication imp }
-
-
-{- Note [Propagate the solved dictionaries]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's really quite important that nestTcS does not discard the solved
-dictionaries from the thing_inside.
-Consider
-   Eq [a]
-   forall b. empty =>  Eq [a]
-We solve the simple (Eq [a]), under nestTcS, and then turn our attention to
-the implications.  It's definitely fine to use the solved dictionaries on
-the inner implications, and it can make a significant performance difference
-if you do so.
--}
-
--- Getters and setters of GHC.Tc.Utils.Env fields
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
--- Getter of inerts and worklist
-getTcSInertsRef :: TcS (IORef InertSet)
-getTcSInertsRef = TcS (return . tcs_inerts)
-
-getTcSWorkListRef :: TcS (IORef WorkList)
-getTcSWorkListRef = TcS (return . tcs_worklist)
-
-getTcSInerts :: TcS InertSet
-getTcSInerts = getTcSInertsRef >>= readTcRef
-
-setTcSInerts :: InertSet -> TcS ()
-setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics }
-
-getWorkListImplics :: TcS (Bag Implication)
-getWorkListImplics
-  = do { wl_var <- getTcSWorkListRef
-       ; wl_curr <- readTcRef wl_var
-       ; return (wl_implics wl_curr) }
-
-pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a)
--- Push the level and run thing_inside
--- However, thing_inside should not generate any work items
-#if defined(DEBUG)
-pushLevelNoWorkList err_doc (TcS thing_inside)
-  = TcS (\env -> TcM.pushTcLevelM $
-                 thing_inside (env { tcs_worklist = wl_panic })
-        )
-  where
-    wl_panic  = pprPanic "GHC.Tc.Solver.Monad.buildImplication" err_doc
-                         -- This panic checks that the thing-inside
-                         -- does not emit any work-list constraints
-#else
-pushLevelNoWorkList _ (TcS thing_inside)
-  = TcS (\env -> TcM.pushTcLevelM (thing_inside env))  -- Don't check
-#endif
-
-updWorkListTcS :: (WorkList -> WorkList) -> TcS ()
-updWorkListTcS f
-  = do { wl_var <- getTcSWorkListRef
-       ; updTcRef wl_var f }
-
-emitWorkNC :: [CtEvidence] -> TcS ()
-emitWorkNC evs
-  | null evs
-  = return ()
-  | otherwise
-  = emitWork (map mkNonCanonical evs)
-
-emitWork :: [Ct] -> TcS ()
-emitWork [] = return ()   -- avoid printing, among other work
-emitWork cts
-  = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))
-       ; updWorkListTcS (extendWorkListCts cts) }
-
-emitImplication :: Implication -> TcS ()
-emitImplication implic
-  = updWorkListTcS (extendWorkListImplic implic)
-
-newTcRef :: a -> TcS (TcRef a)
-newTcRef x = wrapTcS (TcM.newTcRef x)
-
-readTcRef :: TcRef a -> TcS a
-readTcRef ref = wrapTcS (TcM.readTcRef ref)
-
-writeTcRef :: TcRef a -> a -> TcS ()
-writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val)
-
-updTcRef :: TcRef a -> (a->a) -> TcS ()
-updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)
-
-getTcEvBindsVar :: TcS EvBindsVar
-getTcEvBindsVar = TcS (return . tcs_ev_binds)
-
-getTcLevel :: TcS TcLevel
-getTcLevel = wrapTcS TcM.getTcLevel
-
-getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet
-getTcEvTyCoVars ev_binds_var
-  = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var
-
-getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap
-getTcEvBindsMap ev_binds_var
-  = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var
-
-setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS ()
-setTcEvBindsMap ev_binds_var binds
-  = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds
-
-unifyTyVar :: TcTyVar -> TcType -> TcS ()
--- Unify a meta-tyvar with a type
--- We keep track of how many unifications have happened in tcs_unified,
---
--- We should never unify the same variable twice!
-unifyTyVar tv ty
-  = assertPpr (isMetaTyVar tv) (ppr tv) $
-    TcS $ \ env ->
-    do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)
-       ; TcM.writeMetaTyVar tv ty
-       ; TcM.updTcRef (tcs_unified env) (+1) }
-
-reportUnifications :: TcS a -> TcS (Int, a)
-reportUnifications (TcS thing_inside)
-  = TcS $ \ env ->
-    do { inner_unified <- TcM.newTcRef 0
-       ; res <- thing_inside (env { tcs_unified = inner_unified })
-       ; n_unifs <- TcM.readTcRef inner_unified
-       ; TcM.updTcRef (tcs_unified env) (+ n_unifs)
-       ; return (n_unifs, res) }
-
-data TouchabilityTestResult
-  -- See Note [Solve by unification] in GHC.Tc.Solver.Interact
-  -- which points out that having TouchableSameLevel is just an optimisation;
-  -- we could manage with TouchableOuterLevel alone (suitably renamed)
-  = TouchableSameLevel
-  | TouchableOuterLevel [TcTyVar]   -- Promote these
-                        TcLevel     -- ..to this level
-  | Untouchable
-
-instance Outputable TouchabilityTestResult where
-  ppr TouchableSameLevel            = text "TouchableSameLevel"
-  ppr (TouchableOuterLevel tvs lvl) = text "TouchableOuterLevel" <> parens (ppr lvl <+> ppr tvs)
-  ppr Untouchable                   = text "Untouchable"
-
-touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS TouchabilityTestResult
--- This is the key test for untouchability:
--- See Note [Unification preconditions] in GHC.Tc.Utils.Unify
--- and Note [Solve by unification] in GHC.Tc.Solver.Interact
-touchabilityTest flav tv1 rhs
-  | flav /= Given  -- See Note [Do not unify Givens]
-  , MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1
-  = do { can_continue_solving <- wrapTcS $ startSolvingByUnification info rhs
-       ; if not can_continue_solving
-         then return Untouchable
-         else
-    do { ambient_lvl  <- getTcLevel
-       ; given_eq_lvl <- getInnermostGivenEqLevel
-
-       ; if | tv_lvl `sameDepthAs` ambient_lvl
-            -> return TouchableSameLevel
-
-            | tv_lvl `deeperThanOrSame` given_eq_lvl   -- No intervening given equalities
-            , all (does_not_escape tv_lvl) free_skols  -- No skolem escapes
-            -> return (TouchableOuterLevel free_metas tv_lvl)
-
-            | otherwise
-            -> return Untouchable } }
-  | otherwise
-  = return Untouchable
-  where
-     (free_metas, free_skols) = partition isPromotableMetaTyVar $
-                                nonDetEltsUniqSet               $
-                                tyCoVarsOfType rhs
-
-     does_not_escape tv_lvl fv
-       | isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv
-       | otherwise  = True
-       -- Coercion variables are not an escape risk
-       -- If an implication binds a coercion variable, it'll have equalities,
-       -- so the "intervening given equalities" test above will catch it
-       -- Coercion holes get filled with coercions, so again no problem.
-
-{- Note [Do not unify Givens]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this GADT match
-   data T a where
-      T1 :: T Int
-      ...
-
-   f x = case x of
-           T1 -> True
-           ...
-
-So we get f :: T alpha[1] -> beta[1]
-          x :: T alpha[1]
-and from the T1 branch we get the implication
-   forall[2] (alpha[1] ~ Int) => beta[1] ~ Bool
-
-Now, clearly we don't want to unify alpha:=Int!  Yet at the moment we
-process [G] alpha[1] ~ Int, we don't have any given-equalities in the
-inert set, and hence there are no given equalities to make alpha untouchable.
-
-NB: if it were alpha[2] ~ Int, this argument wouldn't hold.  But that
-never happens: invariant (GivenInv) in Note [TcLevel invariants]
-in GHC.Tc.Utils.TcType.
-
-Simple solution: never unify in Givens!
--}
-
-getDefaultInfo ::  TcS ([Type], (Bool, Bool))
-getDefaultInfo = wrapTcS TcM.tcGetDefaultTys
-
-getWorkList :: TcS WorkList
-getWorkList = do { wl_var <- getTcSWorkListRef
-                 ; wrapTcS (TcM.readTcRef wl_var) }
-
-selectNextWorkItem :: TcS (Maybe Ct)
--- Pick which work item to do next
--- See Note [Prioritise equalities]
-selectNextWorkItem
-  = do { wl_var <- getTcSWorkListRef
-       ; wl <- readTcRef wl_var
-       ; case selectWorkItem wl of {
-           Nothing -> return Nothing ;
-           Just (ct, new_wl) ->
-    do { -- checkReductionDepth (ctLoc ct) (ctPred ct)
-         -- This is done by GHC.Tc.Solver.Interact.chooseInstance
-       ; writeTcRef wl_var new_wl
-       ; return (Just ct) } } }
-
--- Just get some environments needed for instance looking up and matching
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-getInstEnvs :: TcS InstEnvs
-getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs
-
-getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)
-getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs
-
-getTopEnv :: TcS HscEnv
-getTopEnv = wrapTcS $ TcM.getTopEnv
-
-getGblEnv :: TcS TcGblEnv
-getGblEnv = wrapTcS $ TcM.getGblEnv
-
-getLclEnv :: TcS TcLclEnv
-getLclEnv = wrapTcS $ TcM.getLclEnv
-
-setLclEnv :: TcLclEnv -> TcS a -> TcS a
-setLclEnv env = wrap2TcS (TcM.setLclEnv env)
-
-tcLookupClass :: Name -> TcS Class
-tcLookupClass c = wrapTcS $ TcM.tcLookupClass c
-
-tcLookupId :: Name -> TcS Id
-tcLookupId n = wrapTcS $ TcM.tcLookupId n
-
--- Setting names as used (used in the deriving of Coercible evidence)
--- Too hackish to expose it to TcS? In that case somehow extract the used
--- constructors from the result of solveInteract
-addUsedGREs :: [GlobalRdrElt] -> TcS ()
-addUsedGREs gres = wrapTcS  $ TcM.addUsedGREs gres
-
-addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()
-addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre
-
-keepAlive :: Name -> TcS ()
-keepAlive = wrapTcS . TcM.keepAlive
-
--- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()
--- Check that we do not try to use an instance before it is available.  E.g.
---    instance Eq T where ...
---    f x = $( ... (\(p::T) -> p == p)... )
--- Here we can't use the equality function from the instance in the splice
-
-checkWellStagedDFun loc what pred
-  = do
-      mbind_lvl <- checkWellStagedInstanceWhat what
-      case mbind_lvl of
-        Just bind_lvl | bind_lvl > impLevel ->
-          wrapTcS $ TcM.setCtLocM loc $ do
-              { use_stage <- TcM.getStage
-              ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
-        _ ->
-          return ()
-  where
-    pp_thing = text "instance for" <+> quotes (ppr pred)
-
--- | Returns the ThLevel of evidence for the solved constraint (if it has evidence)
--- See Note [Well-staged instance evidence]
-checkWellStagedInstanceWhat :: InstanceWhat -> TcS (Maybe ThLevel)
-checkWellStagedInstanceWhat what
-  | TopLevInstance { iw_dfun_id = dfun_id } <- what
-    = return $ Just (TcM.topIdLvl dfun_id)
-  | BuiltinTypeableInstance tc <- what
-    = do
-        cur_mod <- extractModule <$> getGblEnv
-        return $ Just (if nameIsLocalOrFrom cur_mod (tyConName tc)
-                        then outerLevel
-                        else impLevel)
-  | otherwise = return Nothing
-
-{-
-Note [Well-staged instance evidence]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Evidence for instances must obey the same level restrictions as normal bindings.
-In particular, it is forbidden to use an instance in a top-level splice in the
-module which the instance is defined. This is because the evidence is bound at
-the top-level and top-level definitions are forbidden from being using in top-level splices in
-the same module.
-
-For example, suppose you have a function..  foo :: Show a => Code Q a -> Code Q ()
-then the following program is disallowed,
-
-```
-data T a = T a deriving (Show)
-
-main :: IO ()
-main =
-  let x = $$(foo [|| T () ||])
-  in return ()
-```
-
-because the `foo` function (used in a top-level splice) requires `Show T` evidence,
-which is defined at the top-level and therefore fails with an error that we have violated
-the stage restriction.
-
-```
-Main.hs:12:14: error:
-    • GHC stage restriction:
-        instance for ‘Show
-                        (T ())’ is used in a top-level splice, quasi-quote, or annotation,
-        and must be imported, not defined locally
-    • In the expression: foo [|| T () ||]
-      In the Template Haskell splice $$(foo [|| T () ||])
-      In the expression: $$(foo [|| T () ||])
-   |
-12 |   let x = $$(foo [|| T () ||])
-   |
-```
-
-Solving a `Typeable (T t1 ...tn)` constraint generates code that relies on
-`$tcT`, the `TypeRep` for `T`; and we must check that this reference to `$tcT`
-is well staged.  It's easy to know the stage of `$tcT`: for imported TyCons it
-will be `impLevel`, and for local TyCons it will be `toplevel`.
-
-Therefore the `InstanceWhat` type had to be extended with
-a special case for `Typeable`, which recorded the TyCon the evidence was for and
-could them be used to check that we were not attempting to evidence in a stage incorrect
-manner.
-
--}
-
-pprEq :: TcType -> TcType -> SDoc
-pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2
-
-isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)
-isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv)
-
-isFilledMetaTyVar :: TcTyVar -> TcS Bool
-isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)
-
-zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet
-zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs)
-
-zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar]
-zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs)
-
-zonkCo :: Coercion -> TcS Coercion
-zonkCo = wrapTcS . TcM.zonkCo
-
-zonkTcType :: TcType -> TcS TcType
-zonkTcType ty = wrapTcS (TcM.zonkTcType ty)
-
-zonkTcTypes :: [TcType] -> TcS [TcType]
-zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys)
-
-zonkTcTyVar :: TcTyVar -> TcS TcType
-zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)
-
-zonkSimples :: Cts -> TcS Cts
-zonkSimples cts = wrapTcS (TcM.zonkSimples cts)
-
-zonkWC :: WantedConstraints -> TcS WantedConstraints
-zonkWC wc = wrapTcS (TcM.zonkWC wc)
-
-zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar
-zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)
-
-----------------------------
-pprKicked :: Int -> SDoc
-pprKicked 0 = empty
-pprKicked n = parens (int n <+> text "kicked out")
-
-{- *********************************************************************
-*                                                                      *
-*              The Unification Level Flag                              *
-*                                                                      *
-********************************************************************* -}
-
-{- Note [The Unification Level Flag]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider a deep tree of implication constraints
-   forall[1] a.                              -- Outer-implic
-      C alpha[1]                               -- Simple
-      forall[2] c. ....(C alpha[1])....        -- Implic-1
-      forall[2] b. ....(alpha[1] ~ Int)....    -- Implic-2
-
-The (C alpha) is insoluble until we know alpha.  We solve alpha
-by unifying alpha:=Int somewhere deep inside Implic-2. But then we
-must try to solve the Outer-implic all over again. This time we can
-solve (C alpha) both in Outer-implic, and nested inside Implic-1.
-
-When should we iterate solving a level-n implication?
-Answer: if any unification of a tyvar at level n takes place
-        in the ic_implics of that implication.
-
-* What if a unification takes place at level n-1? Then don't iterate
-  level n, because we'll iterate level n-1, and that will in turn iterate
-  level n.
-
-* What if a unification takes place at level n, in the ic_simples of
-  level n?  No need to track this, because the kick-out mechanism deals
-  with it.  (We can't drop kick-out in favour of iteration, because kick-out
-  works for skolem-equalities, not just unifications.)
-
-So the monad-global Unification Level Flag, kept in tcs_unif_lvl keeps
-track of
-  - Whether any unifications at all have taken place (Nothing => no unifications)
-  - If so, what is the outermost level that has seen a unification (Just lvl)
-
-The iteration done in the simplify_loop/maybe_simplify_again loop in GHC.Tc.Solver.
-
-It helpful not to iterate unless there is a chance of progress.  #8474 is
-an example:
-
-  * There's a deeply-nested chain of implication constraints.
-       ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int
-
-  * From the innermost one we get a [W] alpha[1] ~ Int,
-    so we can unify.
-
-  * It's better not to iterate the inner implications, but go all the
-    way out to level 1 before iterating -- because iterating level 1
-    will iterate the inner levels anyway.
-
-(In the olden days when we "floated" thse Derived constraints, this was
-much, much more important -- we got exponential behaviour, as each iteration
-produced the same Derived constraint.)
--}
-
-
-resetUnificationFlag :: TcS Bool
--- We are at ambient level i
--- If the unification flag = Just i, reset it to Nothing and return True
--- Otherwise leave it unchanged and return False
-resetUnificationFlag
-  = TcS $ \env ->
-    do { let ref = tcs_unif_lvl env
-       ; ambient_lvl <- TcM.getTcLevel
-       ; mb_lvl <- TcM.readTcRef ref
-       ; TcM.traceTc "resetUnificationFlag" $
-         vcat [ text "ambient:" <+> ppr ambient_lvl
-              , text "unif_lvl:" <+> ppr mb_lvl ]
-       ; case mb_lvl of
-           Nothing       -> return False
-           Just unif_lvl | ambient_lvl `strictlyDeeperThan` unif_lvl
-                         -> return False
-                         | otherwise
-                         -> do { TcM.writeTcRef ref Nothing
-                               ; return True } }
-
-setUnificationFlag :: TcLevel -> TcS ()
--- (setUnificationFlag i) sets the unification level to (Just i)
--- unless it already is (Just j) where j <= i
-setUnificationFlag lvl
-  = TcS $ \env ->
-    do { let ref = tcs_unif_lvl env
-       ; mb_lvl <- TcM.readTcRef ref
-       ; case mb_lvl of
-           Just unif_lvl | lvl `deeperThanOrSame` unif_lvl
-                         -> return ()
-           _ -> TcM.writeTcRef ref (Just lvl) }
-
-
-{- *********************************************************************
-*                                                                      *
-*                Instantiation etc.
-*                                                                      *
-********************************************************************* -}
-
--- Instantiations
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType)
-instDFunType dfun_id inst_tys
-  = wrapTcS $ TcM.instDFunType dfun_id inst_tys
-
-newFlexiTcSTy :: Kind -> TcS TcType
-newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)
-
-cloneMetaTyVar :: TcTyVar -> TcS TcTyVar
-cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)
-
-instFlexiX :: Subst -> [TKVar] -> TcS Subst
-instFlexiX subst tvs
-  = wrapTcS (foldlM instFlexiHelper subst tvs)
-
-instFlexiHelper :: Subst -> TKVar -> TcM Subst
--- Makes fresh tyvar, extends the substitution, and the in-scope set
-instFlexiHelper subst tv
-  = do { uniq <- TcM.newUnique
-       ; details <- TcM.newMetaDetails TauTv
-       ; let name   = setNameUnique (tyVarName tv) uniq
-             kind   = substTyUnchecked subst (tyVarKind tv)
-             tv'    = mkTcTyVar name kind details
-             subst' = extendTvSubstWithClone subst tv tv'
-       ; TcM.traceTc "instFlexi" (ppr tv')
-       ; return (extendTvSubst subst' tv (mkTyVarTy tv')) }
-
-matchGlobalInst :: DynFlags
-                -> Bool      -- True <=> caller is the short-cut solver
-                             -- See Note [Shortcut solving: overlap]
-                -> Class -> [Type] -> TcS TcM.ClsInstResult
-matchGlobalInst dflags short_cut cls tys
-  = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys)
-
-tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcS (Subst, [TcTyVar])
-tcInstSkolTyVarsX skol_info subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX skol_info subst tvs
-
--- Creating and setting evidence variables and CtFlavors
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-data MaybeNew = Fresh CtEvidence | Cached EvExpr
-
-isFresh :: MaybeNew -> Bool
-isFresh (Fresh {})  = True
-isFresh (Cached {}) = False
-
-freshGoals :: [MaybeNew] -> [CtEvidence]
-freshGoals mns = [ ctev | Fresh ctev <- mns ]
-
-getEvExpr :: MaybeNew -> EvExpr
-getEvExpr (Fresh ctev) = ctEvExpr ctev
-getEvExpr (Cached evt) = evt
-
-setEvBind :: EvBind -> TcS ()
-setEvBind ev_bind
-  = do { evb <- getTcEvBindsVar
-       ; wrapTcS $ TcM.addTcEvBind evb ev_bind }
-
--- | Mark variables as used filling a coercion hole
-useVars :: CoVarSet -> TcS ()
-useVars co_vars
-  = do { ev_binds_var <- getTcEvBindsVar
-       ; let ref = ebv_tcvs ev_binds_var
-       ; wrapTcS $
-         do { tcvs <- TcM.readTcRef ref
-            ; let tcvs' = tcvs `unionVarSet` co_vars
-            ; TcM.writeTcRef ref tcvs' } }
-
--- | Equalities only
-setWantedEq :: HasDebugCallStack => TcEvDest -> Coercion -> TcS ()
-setWantedEq (HoleDest hole) co
-  = do { useVars (coVarsOfCo co)
-       ; fillCoercionHole hole co }
-setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev)
-
--- | Good for both equalities and non-equalities
-setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()
-setWantedEvTerm (HoleDest hole) tm
-  | Just co <- evTermCoercion_maybe tm
-  = do { useVars (coVarsOfCo co)
-       ; fillCoercionHole hole co }
-  | otherwise
-  = -- See Note [Yukky eq_sel for a HoleDest]
-    do { let co_var = coHoleCoVar hole
-       ; setEvBind (mkWantedEvBind co_var tm)
-       ; fillCoercionHole hole (mkCoVarCo co_var) }
-
-setWantedEvTerm (EvVarDest ev_id) tm
-  = setEvBind (mkWantedEvBind ev_id tm)
-
-{- Note [Yukky eq_sel for a HoleDest]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-How can it be that a Wanted with HoleDest gets evidence that isn't
-just a coercion? i.e. evTermCoercion_maybe returns Nothing.
-
-Consider [G] forall a. blah => a ~ T
-         [W] S ~# T
-
-Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~
-T) in the quantified constraints, and wraps the (boxed) evidence it
-gets back in an eq_sel to extract the unboxed (S ~# T).  We can't put
-that term into a coercion, so we add a value binding
-    h = eq_sel (...)
-and the coercion variable h to fill the coercion hole.
-We even re-use the CoHole's Id for this binding!
-
-Yuk!
--}
-
-fillCoercionHole :: CoercionHole -> Coercion -> TcS ()
-fillCoercionHole hole co
-  = do { wrapTcS $ TcM.fillCoercionHole hole co
-       ; kickOutAfterFillingCoercionHole hole }
-
-setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()
-setEvBindIfWanted ev tm
-  = case ev of
-      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm
-      _                             -> return ()
-
-newTcEvBinds :: TcS EvBindsVar
-newTcEvBinds = wrapTcS TcM.newTcEvBinds
-
-newNoTcEvBinds :: TcS EvBindsVar
-newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds
-
-newEvVar :: TcPredType -> TcS EvVar
-newEvVar pred = wrapTcS (TcM.newEvVar pred)
-
-newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence
--- Make a new variable of the given PredType,
--- immediately bind it to the given term
--- and return its CtEvidence
--- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint
-newGivenEvVar loc (pred, rhs)
-  = do { new_ev <- newBoundEvVarId pred rhs
-       ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }
-
--- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the
--- given term
-newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar
-newBoundEvVarId pred rhs
-  = do { new_ev <- newEvVar pred
-       ; setEvBind (mkGivenEvBind new_ev rhs)
-       ; return new_ev }
-
-newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]
-newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts
-
-emitNewWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType -> TcS Coercion
--- | Emit a new Wanted equality into the work-list
-emitNewWantedEq loc rewriters role ty1 ty2
-  = do { (ev, co) <- newWantedEq loc rewriters role ty1 ty2
-       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev))
-       ; return co }
-
--- | Create a new Wanted constraint holding a coercion hole
--- for an equality between the two types at the given 'Role'.
-newWantedEq :: CtLoc -> RewriterSet -> Role -> TcType -> TcType
-            -> TcS (CtEvidence, Coercion)
-newWantedEq loc rewriters role ty1 ty2
-  = do { hole <- wrapTcS $ TcM.newCoercionHole pty
-       ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)
-       ; return ( CtWanted { ctev_pred      = pty
-                           , ctev_dest      = HoleDest hole
-                           , ctev_loc       = loc
-                           , ctev_rewriters = rewriters }
-                , mkHoleCo hole ) }
-  where
-    pty = mkPrimEqPredRole role ty1 ty2
-
--- | Create a new Wanted constraint holding an evidence variable.
---
--- Don't use this for equality constraints: use 'newWantedEq' instead.
-newWantedEvVarNC :: CtLoc -> RewriterSet
-                 -> TcPredType -> TcS CtEvidence
--- Don't look up in the solved/inerts; we know it's not there
-newWantedEvVarNC loc rewriters pty
-  = do { new_ev <- newEvVar pty
-       ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$
-                                         pprCtLoc loc)
-       ; return (CtWanted { ctev_pred      = pty
-                          , ctev_dest      = EvVarDest new_ev
-                          , ctev_loc       = loc
-                          , ctev_rewriters = rewriters })}
-
--- | Like 'newWantedEvVarNC', except it might look up in the inert set
--- to see if an inert already exists, and uses that instead of creating
--- a new Wanted constraint.
---
--- Don't use this for equality constraints: this function is only for
--- constraints with 'EvVarDest'.
-newWantedEvVar :: CtLoc -> RewriterSet
-               -> TcPredType -> TcS MaybeNew
--- For anything except ClassPred, this is the same as newWantedEvVarNC
-newWantedEvVar loc rewriters pty
-  = assertPpr (not (isEqPrimPred pty))
-      (vcat [ text "newWantedEvVar: HoleDestPred"
-            , text "pty:" <+> ppr pty ]) $
-    do { mb_ct <- lookupInInerts loc pty
-       ; case mb_ct of
-            Just ctev
-              -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev
-                    ; return $ Cached (ctEvExpr ctev) }
-            _ -> do { ctev <- newWantedEvVarNC loc rewriters pty
-                    ; return (Fresh ctev) } }
-
--- | Create a new Wanted constraint, potentially looking up
--- non-equality constraints in the cache instead of creating
--- a new one from scratch.
---
--- Deals with both equality and non-equality constraints.
-newWanted :: CtLoc -> RewriterSet -> PredType -> TcS MaybeNew
-newWanted loc rewriters pty
-  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty
-  = Fresh . fst <$> newWantedEq loc rewriters role ty1 ty2
-  | otherwise
-  = newWantedEvVar loc rewriters pty
-
--- | Create a new Wanted constraint.
---
--- Deals with both equality and non-equality constraints.
---
--- Does not attempt to re-use non-equality constraints that already
--- exist in the inert set.
-newWantedNC :: CtLoc -> RewriterSet -> PredType -> TcS CtEvidence
-newWantedNC loc rewriters pty
-  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty
-  = fst <$> newWantedEq loc rewriters role ty1 ty2
-  | otherwise
-  = newWantedEvVarNC loc rewriters pty
-
--- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? ---------
--- | Checks if the depth of the given location is too much. Fails if
--- it's too big, with an appropriate error message.
-checkReductionDepth :: CtLoc -> TcType   -- ^ type being reduced
-                    -> TcS ()
-checkReductionDepth loc ty
-  = do { dflags <- getDynFlags
-       ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $
-         wrapErrTcS $ solverDepthError loc ty }
-
-matchFam :: TyCon -> [Type] -> TcS (Maybe ReductionN)
-matchFam tycon args = wrapTcS $ matchFamTcM tycon args
-
-matchFamTcM :: TyCon -> [Type] -> TcM (Maybe ReductionN)
--- Given (F tys) return (ty, co), where co :: F tys ~N ty
-matchFamTcM tycon args
-  = do { fam_envs <- FamInst.tcGetFamInstEnvs
-       ; let match_fam_result
-              = reduceTyFamApp_maybe fam_envs Nominal tycon args
-       ; TcM.traceTc "matchFamTcM" $
-         vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args)
-              , ppr_res match_fam_result ]
-       ; return match_fam_result }
-  where
-    ppr_res Nothing = text "Match failed"
-    ppr_res (Just (Reduction co ty))
-      = hang (text "Match succeeded:")
-          2 (vcat [ text "Rewrites to:" <+> ppr ty
-                  , text "Coercion:" <+> ppr co ])
-
-solverDepthError :: CtLoc -> TcType -> TcM a
-solverDepthError loc ty
-  = TcM.setCtLocM loc $
-    do { ty <- TcM.zonkTcType ty
-       ; env0 <- TcM.tcInitTidyEnv
-       ; let tidy_env     = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty)
-             tidy_ty      = tidyType tidy_env ty
-             msg = mkTcRnUnknownMessage $ mkPlainError noHints $
-               vcat [ text "Reduction stack overflow; size =" <+> ppr depth
-                      , hang (text "When simplifying the following type:")
-                           2 (ppr tidy_ty)
-                      , note ]
-       ; TcM.failWithTcM (tidy_env, msg) }
-  where
-    depth = ctLocDepth loc
-    note = vcat
-      [ text "Use -freduction-depth=0 to disable this check"
-      , text "(any upper bound you could choose might fail unpredictably with"
-      , text " minor updates to GHC, so disabling the check is recommended if"
-      , text " you're sure that type checking should terminate)" ]
-
-
-{-
-************************************************************************
-*                                                                      *
-              Breaking type variable cycles
-*                                                                      *
-************************************************************************
--}
-
--- | Conditionally replace all type family applications in the RHS with fresh
--- variables, emitting givens that relate the type family application to the
--- variable. See Note [Type equality cycles] in GHC.Tc.Solver.Canonical.
--- This only works under conditions as described in the Note; otherwise, returns
--- Nothing.
-breakTyEqCycle_maybe :: CtEvidence
-                     -> CheckTyEqResult   -- result of checkTypeEq
-                     -> CanEqLHS
-                     -> TcType     -- RHS
-                     -> TcS (Maybe ReductionN)
-                         -- new RHS that doesn't have any type families
-breakTyEqCycle_maybe (ctLocOrigin . ctEvLoc -> CycleBreakerOrigin _) _ _ _
-  -- see Detail (7) of Note
-  = return Nothing
-
-breakTyEqCycle_maybe ev cte_result lhs rhs
-  | NomEq <- eq_rel
-
-  , cte_result `cterHasOnlyProblem` cteSolubleOccurs
-     -- only do this if the only problem is a soluble occurs-check
-     -- See Detail (8) of the Note.
-
-  = do { should_break <- final_check
-       ; if should_break then do { redn <- go rhs
-                                 ; return (Just redn) }
-                         else return Nothing }
-  where
-    flavour = ctEvFlavour ev
-    eq_rel  = ctEvEqRel ev
-
-    final_check = case flavour of
-      Given  -> return True
-      Wanted    -- Wanteds work only with a touchable tyvar on the left
-                -- See "Wanted" section of the Note.
-        | TyVarLHS lhs_tv <- lhs ->
-          do { result <- touchabilityTest Wanted lhs_tv rhs
-             ; return $ case result of
-                          Untouchable -> False
-                          _           -> True }
-        | otherwise -> return False
-
-    -- This could be considerably more efficient. See Detail (5) of Note.
-    go :: TcType -> TcS ReductionN
-    go ty | Just ty' <- rewriterView ty = go ty'
-    go (Rep.TyConApp tc tys)
-      | isTypeFamilyTyCon tc  -- worried about whether this type family is not actually
-                              -- causing trouble? See Detail (5) of Note.
-      = do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys
-                 fun_app                = mkTyConApp tc fun_args
-                 fun_app_kind           = typeKind fun_app
-           ; fun_redn <- emit_work fun_app_kind fun_app
-           ; arg_redns <- unzipRedns <$> mapM go extra_args
-           ; return $ mkAppRedns fun_redn arg_redns }
-              -- Worried that this substitution will change kinds?
-              -- See Detail (3) of Note
-
-      | otherwise
-      = do { arg_redns <- unzipRedns <$> mapM go tys
-           ; return $ mkTyConAppRedn Nominal tc arg_redns }
-
-    go (Rep.AppTy ty1 ty2)
-      = mkAppRedn <$> go ty1 <*> go ty2
-    go (Rep.FunTy vis w arg res)
-      = mkFunRedn Nominal vis <$> go w <*> go arg <*> go res
-    go (Rep.CastTy ty cast_co)
-      = mkCastRedn1 Nominal ty cast_co <$> go ty
-    go ty@(Rep.TyVarTy {})    = skip ty
-    go ty@(Rep.LitTy {})      = skip ty
-    go ty@(Rep.ForAllTy {})   = skip ty  -- See Detail (1) of Note
-    go ty@(Rep.CoercionTy {}) = skip ty  -- See Detail (2) of Note
-
-    skip ty = return $ mkReflRedn Nominal ty
-
-    emit_work :: TcKind         -- of the function application
-              -> TcType         -- original function application
-              -> TcS ReductionN -- rewritten type (the fresh tyvar)
-    emit_work fun_app_kind fun_app = case flavour of
-      Given ->
-        do { new_tv <- wrapTcS (TcM.newCycleBreakerTyVar fun_app_kind)
-           ; let new_ty     = mkTyVarTy new_tv
-                 given_pred = mkHeteroPrimEqPred fun_app_kind fun_app_kind
-                                                 fun_app new_ty
-                 given_term = evCoercion $ mkNomReflCo new_ty  -- See Detail (4) of Note
-           ; new_given <- newGivenEvVar new_loc (given_pred, given_term)
-           ; traceTcS "breakTyEqCycle replacing type family in Given" (ppr new_given)
-           ; emitWorkNC [new_given]
-           ; updInertTcS $ \is ->
-               is { inert_cycle_breakers = insertCycleBreakerBinding new_tv fun_app
-                                             (inert_cycle_breakers is) }
-           ; return $ mkReflRedn Nominal new_ty }
-                -- Why reflexive? See Detail (4) of the Note
-
-      Wanted ->
-        do { new_tv <- wrapTcS (TcM.newFlexiTyVar fun_app_kind)
-           ; let new_ty = mkTyVarTy new_tv
-           ; co <- emitNewWantedEq new_loc (ctEvRewriters ev) Nominal new_ty fun_app
-           ; return $ mkReduction (mkSymCo co) new_ty }
-
-      -- See Detail (7) of the Note
-    new_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin
-
--- does not fit scenario from Note
-breakTyEqCycle_maybe _ _ _ _ = return Nothing
-
--- | Fill in CycleBreakerTvs with the variables they stand for.
--- See Note [Type equality cycles] in GHC.Tc.Solver.Canonical.
-restoreTyVarCycles :: InertSet -> TcM ()
-restoreTyVarCycles is
-  = forAllCycleBreakerBindings_ (inert_cycle_breakers is) TcM.writeMetaTyVar
-{-# SPECIALISE forAllCycleBreakerBindings_ ::
-      CycleBreakerVarStack -> (TcTyVar -> TcType -> TcM ()) -> TcM () #-}
-
--- Unwrap a type synonym only when either:
---   The type synonym is forgetful, or
---   the type synonym mentions a type family in its expansion
--- See Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite.
-rewriterView :: TcType -> Maybe TcType
-rewriterView ty@(Rep.TyConApp tc _)
-  | isForgetfulSynTyCon tc || (isTypeSynonymTyCon tc && not (isFamFreeTyCon tc))
-  = coreView ty
-rewriterView _other = Nothing
diff --git a/compiler/GHC/Tc/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Solver/Rewrite.hs
+++ /dev/null
@@ -1,1083 +0,0 @@
-{-# LANGUAGE BangPatterns  #-}
-
-{-# LANGUAGE DeriveFunctor #-}
-
-module GHC.Tc.Solver.Rewrite(
-   rewrite, rewriteArgsNom,
-   rewriteType
- ) where
-
-import GHC.Prelude
-
-import GHC.Core.TyCo.Ppr ( pprTyVar )
-import GHC.Tc.Types ( TcGblEnv(tcg_tc_plugin_rewriters),
-                      TcPluginRewriter, TcPluginRewriteResult(..),
-                      RewriteEnv(..),
-                      runTcPluginM )
-import GHC.Tc.Types.Constraint
-import GHC.Core.Predicate
-import GHC.Tc.Utils.TcType
-import GHC.Core.Type
-import GHC.Tc.Types.Evidence
-import GHC.Core.TyCon
-import GHC.Core.TyCo.Rep   -- performs delicate algorithm on types
-import GHC.Core.Coercion
-import GHC.Core.Reduction
-import GHC.Types.Unique.FM
-import GHC.Types.Var
-import GHC.Types.Var.Set
-import GHC.Types.Var.Env
-import GHC.Driver.Session
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Tc.Solver.Monad as TcS
-
-import GHC.Utils.Misc
-import GHC.Data.Maybe
-import GHC.Exts (oneShot)
-import Control.Monad
-import Control.Applicative (liftA3)
-import GHC.Builtin.Types (tYPETyCon)
-import Data.List ( find )
-import GHC.Data.List.Infinite (Infinite)
-import qualified GHC.Data.List.Infinite as Inf
-
-{-
-************************************************************************
-*                                                                      *
-*                RewriteEnv & RewriteM
-*             The rewriting environment & monad
-*                                                                      *
-************************************************************************
--}
-
--- | The 'RewriteM' monad is a wrapper around 'TcS' with a 'RewriteEnv'
-newtype RewriteM a
-  = RewriteM { runRewriteM :: RewriteEnv -> TcS a }
-  deriving (Functor)
-
--- | Smart constructor for 'RewriteM', as describe in Note [The one-shot state
--- monad trick] in "GHC.Utils.Monad".
-mkRewriteM :: (RewriteEnv -> TcS a) -> RewriteM a
-mkRewriteM f = RewriteM (oneShot f)
-{-# INLINE mkRewriteM #-}
-
-instance Monad RewriteM where
-  m >>= k  = mkRewriteM $ \env ->
-             do { a  <- runRewriteM m env
-                ; runRewriteM (k a) env }
-
-instance Applicative RewriteM where
-  pure x = mkRewriteM $ \_ -> pure x
-  (<*>) = ap
-
-instance HasDynFlags RewriteM where
-  getDynFlags = liftTcS getDynFlags
-
-liftTcS :: TcS a -> RewriteM a
-liftTcS thing_inside
-  = mkRewriteM $ \_ -> thing_inside
-
--- convenient wrapper when you have a CtEvidence describing
--- the rewriting operation
-runRewriteCtEv :: CtEvidence -> RewriteM a -> TcS (a, RewriterSet)
-runRewriteCtEv ev
-  = runRewrite (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev)
-
--- Run thing_inside (which does the rewriting)
--- Also returns the set of Wanteds which rewrote a Wanted;
--- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint
-runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS (a, RewriterSet)
-runRewrite loc flav eq_rel thing_inside
-  = do { rewriters_ref <- newTcRef emptyRewriterSet
-       ; let fmode = RE { re_loc  = loc
-                        , re_flavour = flav
-                        , re_eq_rel = eq_rel
-                        , re_rewriters = rewriters_ref }
-       ; res <- runRewriteM thing_inside fmode
-       ; rewriters <- readTcRef rewriters_ref
-       ; return (res, rewriters) }
-
-traceRewriteM :: String -> SDoc -> RewriteM ()
-traceRewriteM herald doc = liftTcS $ traceTcS herald doc
-{-# INLINE traceRewriteM #-}  -- see Note [INLINE conditional tracing utilities]
-
-getRewriteEnv :: RewriteM RewriteEnv
-getRewriteEnv
-  = mkRewriteM $ \env -> return env
-
-getRewriteEnvField :: (RewriteEnv -> a) -> RewriteM a
-getRewriteEnvField accessor
-  = mkRewriteM $ \env -> return (accessor env)
-
-getEqRel :: RewriteM EqRel
-getEqRel = getRewriteEnvField re_eq_rel
-
-getRole :: RewriteM Role
-getRole = eqRelRole <$> getEqRel
-
-getFlavour :: RewriteM CtFlavour
-getFlavour = getRewriteEnvField re_flavour
-
-getFlavourRole :: RewriteM CtFlavourRole
-getFlavourRole
-  = do { flavour <- getFlavour
-       ; eq_rel <- getEqRel
-       ; return (flavour, eq_rel) }
-
-getLoc :: RewriteM CtLoc
-getLoc = getRewriteEnvField re_loc
-
-checkStackDepth :: Type -> RewriteM ()
-checkStackDepth ty
-  = do { loc <- getLoc
-       ; liftTcS $ checkReductionDepth loc ty }
-
--- | Change the 'EqRel' in a 'RewriteM'.
-setEqRel :: EqRel -> RewriteM a -> RewriteM a
-setEqRel new_eq_rel thing_inside
-  = mkRewriteM $ \env ->
-    if new_eq_rel == re_eq_rel env
-    then runRewriteM thing_inside env
-    else runRewriteM thing_inside (env { re_eq_rel = new_eq_rel })
-{-# INLINE setEqRel #-}
-
-bumpDepth :: RewriteM a -> RewriteM a
-bumpDepth (RewriteM thing_inside)
-  = mkRewriteM $ \env -> do
-      -- bumpDepth can be called a lot during rewriting so we force the
-      -- new env to avoid accumulating thunks.
-      { let !env' = env { re_loc = bumpCtLocDepth (re_loc env) }
-      ; thing_inside env' }
-
--- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint
--- Precondition: the CtEvidence is a CtWanted of an equality
-recordRewriter :: CtEvidence -> RewriteM ()
-recordRewriter (CtWanted { ctev_dest = HoleDest hole })
-  = RewriteM $ \env -> updTcRef (re_rewriters env) (`addRewriterSet` hole)
-recordRewriter other = pprPanic "recordRewriter" (ppr other)
-
-{-
-Note [Rewriter EqRels]
-~~~~~~~~~~~~~~~~~~~~~~~
-When rewriting, we need to know which equality relation -- nominal
-or representation -- we should be respecting. The only difference is
-that we rewrite variables by representational equalities when re_eq_rel
-is ReprEq, and that we unwrap newtypes when rewriting w.r.t.
-representational equality.
-
-Note [Rewriter CtLoc]
-~~~~~~~~~~~~~~~~~~~~~~
-The rewriter does eager type-family reduction.
-Type families might loop, and we
-don't want GHC to do so. A natural solution is to have a bounded depth
-to these processes. A central difficulty is that such a solution isn't
-quite compositional. For example, say it takes F Int 10 steps to get to Bool.
-How many steps does it take to get from F Int -> F Int to Bool -> Bool?
-10? 20? What about getting from Const Char (F Int) to Char? 11? 1? Hard to
-know and hard to track. So, we punt, essentially. We store a CtLoc in
-the RewriteEnv and just update the environment when recurring. In the
-TyConApp case, where there may be multiple type families to rewrite,
-we just copy the current CtLoc into each branch. If any branch hits the
-stack limit, then the whole thing fails.
-
-A consequence of this is that setting the stack limits appropriately
-will be essentially impossible. So, the official recommendation if a
-stack limit is hit is to disable the check entirely. Otherwise, there
-will be baffling, unpredictable errors.
-
-Note [Phantoms in the rewriter]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-
-data Proxy p = Proxy
-
-and we're rewriting (Proxy ty) w.r.t. ReprEq. Then, we know that `ty`
-is really irrelevant -- it will be ignored when solving for representational
-equality later on. So, we omit rewriting `ty` entirely. This may
-violate the expectation of "xi"s for a bit, but the canonicaliser will
-soon throw out the phantoms when decomposing a TyConApp. (Or, the
-canonicaliser will emit an insoluble, in which case we get
-a better error message anyway.)
-
--}
-
-{- *********************************************************************
-*                                                                      *
-*      Externally callable rewriting functions                         *
-*                                                                      *
-************************************************************************
--}
-
--- | See Note [Rewriting].
--- If (xi, co, rewriters) <- rewrite mode ev ty, then co :: xi ~r ty
--- where r is the role in @ev@.
--- rewriters is the set of coercion holes that have been used to rewrite
--- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint
-rewrite :: CtEvidence -> TcType
-        -> TcS (Reduction, RewriterSet)
-rewrite ev ty
-  = do { traceTcS "rewrite {" (ppr ty)
-       ; result@(redn, _) <- runRewriteCtEv ev (rewrite_one ty)
-       ; traceTcS "rewrite }" (ppr $ reductionReducedType redn)
-       ; return result }
-
--- See Note [Rewriting]
-rewriteArgsNom :: CtEvidence -> TyCon -> [TcType]
-               -> TcS (Reductions, RewriterSet)
--- Externally-callable, hence runRewrite
--- Rewrite a vector of types all at once; in fact they are
--- always the arguments of type family or class, so
---      ctEvFlavour ev = Nominal
--- and we want to rewrite all at nominal role
--- The kind passed in is the kind of the type family or class, call it T
--- The kind of T args must be constant (i.e. not depend on the args)
---
--- Final return value returned which Wanteds rewrote another Wanted
--- See Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint
-rewriteArgsNom ev tc tys
-  = do { traceTcS "rewrite_args {" (vcat (map ppr tys))
-       ; (ArgsReductions redns@(Reductions _ tys') kind_co, rewriters)
-           <- runRewriteCtEv ev (rewrite_args_tc tc Nothing tys)
-       ; massert (isReflMCo kind_co)
-       ; traceTcS "rewrite }" (vcat (map ppr tys'))
-       ; return (redns, rewriters) }
-
--- | Rewrite a type w.r.t. nominal equality. This is useful to rewrite
--- a type w.r.t. any givens. It does not do type-family reduction. This
--- will never emit new constraints. Call this when the inert set contains
--- only givens.
-rewriteType :: CtLoc -> TcType -> TcS TcType
-rewriteType loc ty
-  = do { (redn, _) <- runRewrite loc Given NomEq $
-                       rewrite_one ty
-                     -- use Given flavor so that it is rewritten
-                     -- only w.r.t. Givens, never Wanteds
-                     -- (Shouldn't matter, if only Givens are present
-                     -- anyway)
-       ; return $ reductionReducedType redn }
-
-{- *********************************************************************
-*                                                                      *
-*           The main rewriting functions
-*                                                                      *
-********************************************************************* -}
-
-{- Note [Rewriting]
-~~~~~~~~~~~~~~~~~~~~
-  rewrite ty  ==>  Reduction co xi
-    where
-      xi has no reducible type functions
-         has no skolems that are mapped in the inert set
-         has no filled-in metavariables
-      co :: ty ~ xi (coercions in reductions are always left-to-right)
-
-Key invariants:
-  (F0) co :: zonk(ty') ~ xi   where zonk(ty') ~ zonk(ty)
-  (F1) typeKind(xi) succeeds and returns a fully zonked kind
-  (F2) typeKind(xi) `eqType` zonk(typeKind(ty))
-
-Note that it is rewrite's job to try to reduce *every type function it sees*.
-
-Rewriting also:
-  * zonks, removing any metavariables, and
-  * applies the substitution embodied in the inert set
-
-Because rewriting zonks and the returned coercion ("co" above) is also
-zonked, it's possible that (co :: ty ~ xi) isn't quite true. So, instead,
-we can rely on this fact:
-
-  (F0) co :: zonk(ty') ~ xi, where zonk(ty') ~ zonk(ty)
-
-Note that the right-hand type of co is *always* precisely xi. The left-hand
-type may or may not be ty, however: if ty has unzonked filled-in metavariables,
-then the left-hand type of co will be the zonk-equal to ty.
-It is for this reason that we occasionally have to explicitly zonk,
-when (co :: ty ~ xi) is important even before we zonk the whole program.
-For example, see the RTRNotFollowed case in rewriteTyVar.
-
-Why have these invariants on rewriting? Because we sometimes use typeKind
-during canonicalisation, and we want this kind to be zonked (e.g., see
-GHC.Tc.Solver.Canonical.canEqCanLHS).
-
-Rewriting is always homogeneous. That is, the kind of the result of rewriting is
-always the same as the kind of the input, modulo zonking. More formally:
-
-  (F2) zonk(typeKind(ty)) `eqType` typeKind(xi)
-
-This invariant means that the kind of a rewritten type might not itself be rewritten.
-
-Note that we prefer to leave type synonyms unexpanded when possible,
-so when the rewriter encounters one, it first asks whether its
-transitive expansion contains any type function applications or is
-forgetful -- that is, omits one or more type variables in its RHS.  If so,
-it expands the synonym and proceeds; if not, it simply returns the
-unexpanded synonym. See also Note [Rewriting synonyms].
-
-Where do we actually perform rewriting within a type? See Note [Rewritable] in
-GHC.Tc.Solver.InertSet.
-
-Note [rewrite_args performance]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In programs with lots of type-level evaluation, rewrite_args becomes
-part of a tight loop. For example, see test perf/compiler/T9872a, which
-calls rewrite_args a whopping 7,106,808 times. It is thus important
-that rewrite_args be efficient.
-
-Performance testing showed that the current implementation is indeed
-efficient. It's critically important that zipWithAndUnzipM be
-specialized to TcS, and it's also quite helpful to actually `inline`
-it. On test T9872a, here are the allocation stats (Dec 16, 2014):
-
- * Unspecialized, uninlined:     8,472,613,440 bytes allocated in the heap
- * Specialized, uninlined:       6,639,253,488 bytes allocated in the heap
- * Specialized, inlined:         6,281,539,792 bytes allocated in the heap
-
-To improve performance even further, rewrite_args_nom is split off
-from rewrite_args, as nominal equality is the common case. This would
-be natural to write using mapAndUnzipM, but even inlined, that function
-is not as performant as a hand-written loop.
-
- * mapAndUnzipM, inlined:        7,463,047,432 bytes allocated in the heap
- * hand-written recursion:       5,848,602,848 bytes allocated in the heap
-
-If you make any change here, pay close attention to the T9872{a,b,c} tests
-and T5321Fun.
-
-If we need to make this yet more performant, a possible way forward is to
-duplicate the rewriter code for the nominal case, and make that case
-faster. This doesn't seem quite worth it, yet.
-
-Note [rewrite_exact_fam_app performance]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Once we've got a rewritten rhs, we extend the famapp-cache to record
-the result. Doing so can save lots of work when the same redex shows up more
-than once. Note that we record the link from the redex all the way to its
-*final* value, not just the single step reduction.
-
-If we can reduce the family application right away (the first call
-to try_to_reduce), we do *not* add to the cache. There are two possibilities
-here: 1) we just read the result from the cache, or 2) we used one type
-family instance. In either case, recording the result in the cache doesn't
-save much effort the next time around. And adding to the cache here is
-actually disastrous: it more than doubles the allocations for T9872a. So
-we skip adding to the cache here.
--}
-
-{-# INLINE rewrite_args_tc #-}
-rewrite_args_tc
-  :: TyCon         -- T
-  -> Maybe (Infinite Role)  -- Nothing: ambient role is Nominal; all args are Nominal
-                   -- Otherwise: no assumptions; use roles provided
-  -> [Type]
-  -> RewriteM ArgsReductions -- See the commentary on rewrite_args
-rewrite_args_tc tc = rewrite_args all_bndrs any_named_bndrs inner_ki emptyVarSet
-  -- NB: TyCon kinds are always closed
-  where
-  -- There are many bang patterns in here. It's been observed that they
-  -- greatly improve performance of an optimized build.
-  -- The T9872 test cases are good witnesses of this fact.
-
-    (bndrs, named)
-      = ty_con_binders_ty_binders' (tyConBinders tc)
-    -- it's possible that the result kind has arrows (for, e.g., a type family)
-    -- so we must split it
-    (inner_bndrs, inner_ki, inner_named) = split_pi_tys' (tyConResKind tc)
-    !all_bndrs                           = bndrs `chkAppend` inner_bndrs
-    !any_named_bndrs                     = named || inner_named
-    -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%.
-
-{-# INLINE rewrite_args #-}
-rewrite_args :: [PiTyBinder] -> Bool -- Binders, and True iff any of them are
-                                     -- named.
-             -> Kind -> TcTyCoVarSet -- function kind; kind's free vars
-             -> Maybe (Infinite Role) -> [Type]    -- these are in 1-to-1 correspondence
-                                          -- Nothing: use all Nominal
-             -> RewriteM ArgsReductions
--- This function returns ArgsReductions (Reductions cos xis) res_co
---   coercions: co_i :: ty_i ~ xi_i, at roles given
---   types:     xi_i
---   coercion:  res_co :: typeKind(fun tys) ~N typeKind(fun xis)
--- That is, the result coercion relates the kind of some function (whose kind is
--- passed as the first parameter) instantiated at tys to the kind of that
--- function instantiated at the xis. This is useful in keeping rewriting
--- homogeneous. The list of roles must be at least as long as the list of
--- types.
-rewrite_args orig_binders
-             any_named_bndrs
-             orig_inner_ki
-             orig_fvs
-             orig_m_roles
-             orig_tys
-  = case (orig_m_roles, any_named_bndrs) of
-      (Nothing, False) -> rewrite_args_fast orig_tys
-      _ -> rewrite_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys
-        where orig_roles = fromMaybe (Inf.repeat Nominal) orig_m_roles
-
-{-# INLINE rewrite_args_fast #-}
--- | fast path rewrite_args, in which none of the binders are named and
--- therefore we can avoid tracking a lifting context.
-rewrite_args_fast :: [Type] -> RewriteM ArgsReductions
-rewrite_args_fast orig_tys
-  = fmap finish (iterate orig_tys)
-  where
-
-    iterate :: [Type] -> RewriteM Reductions
-    iterate (ty : tys) = do
-      Reduction  co  xi  <- rewrite_one ty
-      Reductions cos xis <- iterate tys
-      pure $ Reductions (co : cos) (xi : xis)
-    iterate [] = pure $ Reductions [] []
-
-    {-# INLINE finish #-}
-    finish :: Reductions -> ArgsReductions
-    finish redns = ArgsReductions redns MRefl
-
-{-# INLINE rewrite_args_slow #-}
--- | Slow path, compared to rewrite_args_fast, because this one must track
--- a lifting context.
-rewrite_args_slow :: [PiTyBinder] -> Kind -> TcTyCoVarSet
-                  -> Infinite Role -> [Type]
-                  -> RewriteM ArgsReductions
-rewrite_args_slow binders inner_ki fvs roles tys
-  = do { rewritten_args <- zipWithM rw (Inf.toList roles) tys
-       ; return (simplifyArgsWorker binders inner_ki fvs roles rewritten_args) }
-  where
-    {-# INLINE rw #-}
-    rw :: Role -> Type -> RewriteM Reduction
-    rw Nominal ty
-      = setEqRel NomEq $
-        rewrite_one ty
-
-    rw Representational ty
-      = setEqRel ReprEq $
-        rewrite_one ty
-
-    rw Phantom ty
-    -- See Note [Phantoms in the rewriter]
-      = do { ty <- liftTcS $ zonkTcType ty
-           ; return $ mkReflRedn Phantom ty }
-
-------------------
-rewrite_one :: TcType -> RewriteM Reduction
--- Rewrite a type to get rid of type function applications, returning
--- the new type-function-free type, and a collection of new equality
--- constraints.  See Note [Rewriting] for more detail.
---
--- Postcondition:
--- the role on the result coercion matches the EqRel in the RewriteEnv
-
-rewrite_one ty
-  | Just ty' <- rewriterView ty  -- See Note [Rewriting synonyms]
-  = rewrite_one ty'
-
-rewrite_one xi@(LitTy {})
-  = do { role <- getRole
-       ; return $ mkReflRedn role xi }
-
-rewrite_one (TyVarTy tv)
-  = rewriteTyVar tv
-
-rewrite_one (AppTy ty1 ty2)
-  = rewrite_app_tys ty1 [ty2]
-
-rewrite_one (TyConApp tc tys)
-  -- If it's a type family application, try to reduce it
-  | isTypeFamilyTyCon tc
-  = rewrite_fam_app tc tys
-
-  -- For * a normal data type application
-  --     * data family application
-  -- we just recursively rewrite the arguments.
-  | otherwise
-  = rewrite_ty_con_app tc tys
-
-rewrite_one (FunTy { ft_af = vis, ft_mult = mult, ft_arg = ty1, ft_res = ty2 })
-  = do { arg_redn <- rewrite_one ty1
-       ; res_redn <- rewrite_one ty2
-
-        -- Important: look at the *reduced* type, so that any unzonked variables
-        -- in kinds are gone and the getRuntimeRep succeeds.
-        -- cf. Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical.
-       ; let arg_rep = getRuntimeRep (reductionReducedType arg_redn)
-             res_rep = getRuntimeRep (reductionReducedType res_redn)
-
-       ; (w_redn, arg_rep_redn, res_rep_redn) <- setEqRel NomEq $
-           liftA3 (,,) (rewrite_one mult)
-                       (rewrite_one arg_rep)
-                       (rewrite_one res_rep)
-       ; role <- getRole
-
-       ; let arg_rep_co = reductionCoercion arg_rep_redn
-                -- :: arg_rep ~ arg_rep_xi
-             arg_ki_co  = mkTyConAppCo Nominal tYPETyCon [arg_rep_co]
-                -- :: TYPE arg_rep ~ TYPE arg_rep_xi
-             casted_arg_redn = mkCoherenceRightRedn role arg_redn arg_ki_co
-                -- :: ty1 ~> arg_xi |> arg_ki_co
-
-             res_rep_co = reductionCoercion res_rep_redn
-             res_ki_co  = mkTyConAppCo Nominal tYPETyCon [res_rep_co]
-             casted_res_redn = mkCoherenceRightRedn role res_redn res_ki_co
-
-          -- We must rewrite the representations, because that's what would
-          -- be done if we used TyConApp instead of FunTy. These rewritten
-          -- representations are seen only in casts of the arg and res, below.
-          -- Forgetting this caused #19677.
-       ; return $ mkFunRedn role vis w_redn casted_arg_redn casted_res_redn }
-
-rewrite_one ty@(ForAllTy {})
--- TODO (RAE): This is inadequate, as it doesn't rewrite the kind of
--- the bound tyvar. Doing so will require carrying around a substitution
--- and the usual substTyVarBndr-like silliness. Argh.
-
--- We allow for-alls when, but only when, no type function
--- applications inside the forall involve the bound type variables.
-  = do { let (bndrs, rho) = tcSplitForAllTyVarBinders ty
-       ; redn <- rewrite_one rho
-       ; return $ mkHomoForAllRedn bndrs redn }
-
-rewrite_one (CastTy ty g)
-  = do { redn <- rewrite_one ty
-       ; g'   <- rewrite_co g
-       ; role <- getRole
-       ; return $ mkCastRedn1 role ty g' redn }
-      -- This calls castCoercionKind1.
-      -- It makes a /big/ difference to call castCoercionKind1 not
-      -- the more general castCoercionKind2.
-      -- See Note [castCoercionKind1] in GHC.Core.Coercion
-
-rewrite_one (CoercionTy co)
-  = do { co' <- rewrite_co co
-       ; role <- getRole
-       ; return $ mkReflCoRedn role co' }
-
--- | "Rewrite" a coercion. Really, just zonk it so we can uphold
--- (F1) of Note [Rewriting]
-rewrite_co :: Coercion -> RewriteM Coercion
-rewrite_co co = liftTcS $ zonkCo co
-
--- | Rewrite a reduction, composing the resulting coercions.
-rewrite_reduction :: Reduction -> RewriteM Reduction
-rewrite_reduction (Reduction co xi)
-  = do { redn <- bumpDepth $ rewrite_one xi
-       ; return $ co `mkTransRedn` redn }
-
--- rewrite (nested) AppTys
-rewrite_app_tys :: Type -> [Type] -> RewriteM Reduction
--- commoning up nested applications allows us to look up the function's kind
--- only once. Without commoning up like this, we would spend a quadratic amount
--- of time looking up functions' types
-rewrite_app_tys (AppTy ty1 ty2) tys = rewrite_app_tys ty1 (ty2:tys)
-rewrite_app_tys fun_ty arg_tys
-  = do { redn <- rewrite_one fun_ty
-       ; rewrite_app_ty_args redn arg_tys }
-
--- Given a rewritten function (with the coercion produced by rewriting) and
--- a bunch of unrewritten arguments, rewrite the arguments and apply.
--- The coercion argument's role matches the role stored in the RewriteM monad.
---
--- The bang patterns used here were observed to improve performance. If you
--- wish to remove them, be sure to check for regressions in allocations.
-rewrite_app_ty_args :: Reduction -> [Type] -> RewriteM Reduction
-rewrite_app_ty_args redn []
-  -- this will be a common case when called from rewrite_fam_app, so shortcut
-  = return redn
-rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys
-  = do { het_redn <- case tcSplitTyConApp_maybe fun_xi of
-           Just (tc, xis) ->
-             do { let tc_roles  = tyConRolesRepresentational tc
-                      arg_roles = Inf.dropList xis tc_roles
-                ; ArgsReductions (Reductions arg_cos arg_xis) kind_co
-                    <- rewrite_vector (typeKind fun_xi) arg_roles arg_tys
-
-                  -- We start with a reduction of the form
-                  --   fun_co :: ty ~ T xi_1 ... xi_n
-                  -- and further arguments a_1, ..., a_m.
-                  -- We rewrite these arguments, and obtain coercions:
-                  --   arg_co_i :: a_i ~ zeta_i
-                  -- Now, we need to apply fun_co to the arg_cos. The problem is
-                  -- that using mkAppCo is wrong because that function expects
-                  -- its second coercion to be Nominal, and the arg_cos might
-                  -- not be. The solution is to use transitivity:
-                  -- fun_co <a_1> ... <a_m> ;; T <xi_1> .. <xi_n> arg_co_1 ... arg_co_m
-                ; eq_rel <- getEqRel
-                ; let app_xi = mkTyConApp tc (xis ++ arg_xis)
-                      app_co = case eq_rel of
-                        NomEq  -> mkAppCos fun_co arg_cos
-                        ReprEq -> mkAppCos fun_co (map mkNomReflCo arg_tys)
-                                  `mkTransCo`
-                                  mkTyConAppCo Representational tc
-                                    (zipWith mkReflCo (Inf.toList tc_roles) xis ++ arg_cos)
-
-                ; return $
-                    mkHetReduction
-                      (mkReduction app_co app_xi )
-                      kind_co }
-           Nothing ->
-             do { ArgsReductions redns kind_co
-                    <- rewrite_vector (typeKind fun_xi) (Inf.repeat Nominal) arg_tys
-                ; return $ mkHetReduction (mkAppRedns fun_redn redns) kind_co }
-
-       ; role <- getRole
-       ; return (homogeniseHetRedn role het_redn) }
-
-rewrite_ty_con_app :: TyCon -> [TcType] -> RewriteM Reduction
-rewrite_ty_con_app tc tys
-  = do { role <- getRole
-       ; let m_roles | Nominal <- role = Nothing
-                     | otherwise       = Just $ tyConRolesX role tc
-       ; ArgsReductions redns kind_co <- rewrite_args_tc tc m_roles tys
-       ; let tyconapp_redn
-                = mkHetReduction
-                    (mkTyConAppRedn role tc redns)
-                    kind_co
-       ; return $ homogeniseHetRedn role tyconapp_redn }
-
--- Rewrite a vector (list of arguments).
-rewrite_vector :: Kind   -- of the function being applied to these arguments
-               -> Infinite Role -- If we're rewriting w.r.t. ReprEq, what roles do the
-                         -- args have?
-               -> [Type] -- the args to rewrite
-               -> RewriteM ArgsReductions
-rewrite_vector ki roles tys
-  = do { eq_rel <- getEqRel
-       ; let mb_roles = case eq_rel of { NomEq -> Nothing; ReprEq -> Just roles }
-       ; rewrite_args bndrs any_named_bndrs inner_ki fvs mb_roles tys
-       }
-  where
-    (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki
-    fvs                                = tyCoVarsOfType ki
-{-# INLINE rewrite_vector #-}
-
-{-
-Note [Rewriting synonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Not expanding synonyms aggressively improves error messages, and
-keeps types smaller. But we need to take care.
-
-Suppose
-   type Syn a = Int
-   type instance F Bool = Syn (F Bool)
-   [G] F Bool ~ Syn (F Bool)
-
-If we don't expand the synonym, we'll get a spurious occurs-check
-failure. This is normally what occCheckExpand takes care of, but
-the LHS is a type family application, and occCheckExpand (already
-complex enough as it is) does not know how to expand to avoid
-a type family application.
-
-In addition, expanding the forgetful synonym like this
-will generally yield a *smaller* type. To wit, if we spot
-S ( ... F tys ... ), where S is forgetful, we don't want to bother
-doing hard work simplifying (F tys). We thus expand forgetful
-synonyms, but not others.
-
-isForgetfulSynTyCon returns True more often than it needs to, so
-we err on the side of more expansion.
-
-We also, of course, must expand type synonyms that mention type families,
-so those families can get reduced.
-
-************************************************************************
-*                                                                      *
-             Rewriting a type-family application
-*                                                                      *
-************************************************************************
-
-Note [How to normalise a family application]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given an exactly saturated family application, how should we normalise it?
-This Note spells out the algorithm and its reasoning.
-
-First, we attempt to directly rewrite the type family application,
-without simplifying any of the arguments first, in an attempt to avoid
-doing unnecessary work.
-
-STEP 1a. Call the rewriting plugins. If any plugin rewrites the type family
-application, jump to FINISH.
-
-STEP 1b. Try the famapp-cache. If we get a cache hit, jump to FINISH.
-
-STEP 1c. Try top-level instances. Remember: we haven't simplified the arguments
-  yet. Example:
-    type instance F (Maybe a) = Int
-    target: F (Maybe (G Bool))
-  Instead of first trying to simplify (G Bool), we use the instance first. This
-  avoids the work of simplifying G Bool.
-
-  If an instance is found, jump to FINISH.
-
-STEP 2: At this point we rewrite all arguments. This might expose more
-  information, which might allow plugins to make progress, or allow us to
-  pick up a top-level instance.
-
-STEP 3. Try the inerts. Note that we try the inerts *after* rewriting the
-  arguments, because the inerts will have rewritten LHSs.
-
-  If an inert is found, jump to FINISH.
-
-Next, we try STEP 1 again, as we might be able to make further progress after
-having rewritten the arguments:
-
-STEP 4a. Query the rewriting plugins again.
-
-  If any plugin supplies a rewriting, jump to FINISH.
-
-STEP 4b. Try the famapp-cache again.
-
-  If we get a cache hit, jump to FINISH.
-
-STEP 4c. Try top-level instances again.
-
-  If an instance is found, jump to FINISH.
-
-STEP 5: GIVEUP. No progress to be made. Return what we have. (Do not FINISH.)
-
-FINISH 1. We've made a reduction, but the new type may still have more
-  work to do. So rewrite the new type.
-
-FINISH 2. Add the result to the famapp-cache, connecting the type we started
-  with to the one we ended with.
-
-Because STEP 1{a,b,c} and STEP 4{a,b,c} happen the same way, they are abstracted into
-try_to_reduce.
-
-FINISH is naturally implemented in `finish`. But, Note [rewrite_exact_fam_app performance]
-tells us that we should not add to the famapp-cache after STEP 1. So `finish`
-is inlined in that case, and only FINISH 1 is performed.
-
--}
-
-rewrite_fam_app :: TyCon -> [TcType] -> RewriteM Reduction
-  --   rewrite_fam_app            can be over-saturated
-  --   rewrite_exact_fam_app      lifts out the application to top level
-  -- Postcondition: Coercion :: Xi ~ F tys
-rewrite_fam_app tc tys  -- Can be over-saturated
-    = assertPpr (tys `lengthAtLeast` tyConArity tc)
-                (ppr tc $$ ppr (tyConArity tc) $$ ppr tys) $
-
-                 -- Type functions are saturated
-                 -- The type function might be *over* saturated
-                 -- in which case the remaining arguments should
-                 -- be dealt with by AppTys
-      do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys
-         ; redn <- rewrite_exact_fam_app tc tys1
-         ; rewrite_app_ty_args redn tys_rest }
-
--- the [TcType] exactly saturate the TyCon
--- See Note [How to normalise a family application]
-rewrite_exact_fam_app :: TyCon -> [TcType] -> RewriteM Reduction
-rewrite_exact_fam_app tc tys
-  = do { checkStackDepth (mkTyConApp tc tys)
-
-       -- Query the typechecking plugins for all their rewriting functions
-       -- which apply to a type family application headed by the TyCon 'tc'.
-       ; tc_rewriters <- getTcPluginRewritersForTyCon tc
-
-       -- STEP 1. Try to reduce without reducing arguments first.
-       ; result1 <- try_to_reduce tc tys tc_rewriters
-       ; case result1 of
-             -- Don't use the cache;
-             -- See Note [rewrite_exact_fam_app performance]
-         { Just redn -> finish False redn
-         ; Nothing ->
-
-        -- That didn't work. So reduce the arguments, in STEP 2.
-    do { eq_rel <- getEqRel
-          -- checking eq_rel == NomEq saves ~0.5% in T9872a
-       ; ArgsReductions (Reductions cos xis) kind_co <-
-            if eq_rel == NomEq
-            then rewrite_args_tc tc Nothing tys
-            else setEqRel NomEq $
-                 rewrite_args_tc tc Nothing tys
-
-         -- If we manage to rewrite the type family application after
-         -- rewriting the arguments, we will need to compose these
-         -- reductions.
-         --
-         -- We have:
-         --
-         --   arg_co_i :: ty_i ~ xi_i
-         --   fam_co :: F xi_1 ... xi_n ~ zeta
-         --
-         -- The full reduction is obtained as a composite:
-         --
-         --   full_co :: F ty_1 ... ty_n ~ zeta
-         --   full_co = F co_1 ... co_n ;; fam_co
-       ; let
-           role    = eqRelRole eq_rel
-           args_co = mkTyConAppCo role tc cos
-       ;  let homogenise :: Reduction -> Reduction
-              homogenise redn
-                = homogeniseHetRedn role
-                $ mkHetReduction
-                    (args_co `mkTransRedn` redn)
-                    kind_co
-
-              give_up :: Reduction
-              give_up = homogenise $ mkReflRedn role reduced
-                where reduced = mkTyConApp tc xis
-
-         -- STEP 3: try the inerts
-       ; flavour <- getFlavour
-       ; result2 <- liftTcS $ lookupFamAppInert (`eqCanRewriteFR` (flavour, eq_rel)) tc xis
-       ; case result2 of
-         { Just (redn, (inert_flavour, inert_eq_rel))
-             -> do { traceRewriteM "rewrite family application with inert"
-                                (ppr tc <+> ppr xis $$ ppr redn)
-                   ; finish (inert_flavour == Given) (homogenise downgraded_redn) }
-               -- this will sometimes duplicate an inert in the cache,
-               -- but avoiding doing so had no impact on performance, and
-               -- it seems easier not to weed out that special case
-             where
-               inert_role      = eqRelRole inert_eq_rel
-               role            = eqRelRole eq_rel
-               downgraded_redn = downgradeRedn role inert_role redn
-
-         ; _ ->
-
-         -- inerts didn't work. Try to reduce again, in STEP 4.
-    do { result3 <- try_to_reduce tc xis tc_rewriters
-       ; case result3 of
-           Just redn -> finish True (homogenise redn)
-           -- we have made no progress at all: STEP 5 (GIVEUP).
-           _         -> return give_up }}}}}
-  where
-      -- call this if the above attempts made progress.
-      -- This recursively rewrites the result and then adds to the cache
-    finish :: Bool  -- add to the cache?
-                    -- Precondition: True ==> input coercion has
-                    --                        no coercion holes
-           -> Reduction -> RewriteM Reduction
-    finish use_cache redn
-      = do { -- rewrite the result: FINISH 1
-             final_redn <- rewrite_reduction redn
-           ; eq_rel <- getEqRel
-
-             -- extend the cache: FINISH 2
-           ; when (use_cache && eq_rel == NomEq) $
-             -- the cache only wants Nominal eqs
-             liftTcS $ extendFamAppCache tc tys final_redn
-           ; return final_redn }
-    {-# INLINE finish #-}
-
--- Returned coercion is input ~r output, where r is the role in the RewriteM monad
--- See Note [How to normalise a family application]
-try_to_reduce :: TyCon -> [TcType] -> [TcPluginRewriter]
-              -> RewriteM (Maybe Reduction)
-try_to_reduce tc tys tc_rewriters
-  = do { rewrite_env <- getRewriteEnv
-       ; result <-
-            liftTcS $ firstJustsM
-              [ runTcPluginRewriters rewrite_env tc_rewriters tys -- STEP 1a & STEP 4a
-              , lookupFamAppCache tc tys                          -- STEP 1b & STEP 4b
-              , matchFam tc tys ]                                 -- STEP 1c & STEP 4c
-       ; traverse downgrade result }
-  where
-    -- The result above is always Nominal. We might want a Representational
-    -- coercion; this downgrades (and prints, out of convenience).
-    downgrade :: Reduction -> RewriteM Reduction
-    downgrade redn
-      = do { traceRewriteM "Eager T.F. reduction success" $
-             vcat [ ppr tc
-                  , ppr tys
-                  , ppr redn
-                  ]
-           ; eq_rel <- getEqRel
-              -- manually doing it this way avoids allocation in the vastly
-              -- common NomEq case
-           ; case eq_rel of
-               NomEq  -> return redn
-               ReprEq -> return $ mkSubRedn redn }
-
--- Retrieve all type-checking plugins that can rewrite a (saturated) type-family application
--- headed by the given 'TyCon`.
-getTcPluginRewritersForTyCon :: TyCon -> RewriteM [TcPluginRewriter]
-getTcPluginRewritersForTyCon tc
-  = liftTcS $ do { rewriters <- tcg_tc_plugin_rewriters <$> getGblEnv
-                 ; return (lookupWithDefaultUFM rewriters [] tc) }
-
--- Run a collection of rewriting functions obtained from type-checking plugins,
--- querying in sequence if any plugin wants to rewrite the type family
--- applied to the given arguments.
---
--- Note that the 'TcPluginRewriter's provided all pertain to the same type family
--- (the 'TyCon' of which has been obtained ahead of calling this function).
-runTcPluginRewriters :: RewriteEnv
-                     -> [TcPluginRewriter]
-                     -> [TcType]
-                     -> TcS (Maybe Reduction)
-runTcPluginRewriters rewriteEnv rewriterFunctions tys
-  | null rewriterFunctions
-  = return Nothing -- short-circuit for common case
-  | otherwise
-  = do { givens <- getInertGivens
-       ; runRewriters givens rewriterFunctions }
-  where
-  runRewriters :: [Ct] -> [TcPluginRewriter] -> TcS (Maybe Reduction)
-  runRewriters _ []
-    = return Nothing
-  runRewriters givens (rewriter:rewriters)
-    = do
-        rewriteResult <- wrapTcS . runTcPluginM $ rewriter rewriteEnv givens tys
-        case rewriteResult of
-           TcPluginRewriteTo
-             { tcPluginReduction    = redn
-             , tcRewriterNewWanteds = wanteds
-             } -> do { emitWork wanteds; return $ Just redn }
-           TcPluginNoRewrite {} -> runRewriters givens rewriters
-
-{-
-************************************************************************
-*                                                                      *
-             Rewriting a type variable
-*                                                                      *
-********************************************************************* -}
-
--- | The result of rewriting a tyvar "one step".
-data RewriteTvResult
-  = RTRNotFollowed
-      -- ^ The inert set doesn't make the tyvar equal to anything else
-
-  | RTRFollowed !Reduction
-      -- ^ The tyvar rewrites to a not-necessarily rewritten other type.
-      -- The role is determined by the RewriteEnv.
-      --
-      -- With Quick Look, the returned TcType can be a polytype;
-      -- that is, in the constraint solver, a unification variable
-      -- can contain a polytype.  See GHC.Tc.Gen.App
-      -- Note [Instantiation variables are short lived]
-
-rewriteTyVar :: TyVar -> RewriteM Reduction
-rewriteTyVar tv
-  = do { mb_yes <- rewrite_tyvar1 tv
-       ; case mb_yes of
-           RTRFollowed redn -> rewrite_reduction redn
-
-           RTRNotFollowed   -- Done, but make sure the kind is zonked
-                            -- Note [Rewriting] invariant (F0) and (F1)
-             -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv
-                   ; role <- getRole
-                   ; let ty' = mkTyVarTy tv'
-                   ; return $ mkReflRedn role ty' } }
-
-rewrite_tyvar1 :: TcTyVar -> RewriteM RewriteTvResult
--- "Rewriting" a type variable means to apply the substitution to it
--- Specifically, look up the tyvar in
---   * the internal MetaTyVar box
---   * the inerts
--- See also the documentation for RewriteTvResult
-
-rewrite_tyvar1 tv
-  = do { mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv
-       ; case mb_ty of
-           Just ty -> do { traceRewriteM "Following filled tyvar"
-                             (ppr tv <+> equals <+> ppr ty)
-                         ; role <- getRole
-                         ; return $ RTRFollowed $
-                             mkReflRedn role ty }
-           Nothing -> do { traceRewriteM "Unfilled tyvar" (pprTyVar tv)
-                         ; fr <- getFlavourRole
-                         ; rewrite_tyvar2 tv fr } }
-
-rewrite_tyvar2 :: TcTyVar -> CtFlavourRole -> RewriteM RewriteTvResult
--- The tyvar is not a filled-in meta-tyvar
--- Try in the inert equalities
--- See Definition [Applying a generalised substitution] in GHC.Tc.Solver.Monad
--- See Note [Stability of rewriting] in GHC.Tc.Solver.Monad
-
-rewrite_tyvar2 tv fr@(_, eq_rel)
-  = do { ieqs <- liftTcS $ getInertEqs
-       ; case lookupDVarEnv ieqs tv of
-           Just equal_ct_list
-             | Just ct <- find can_rewrite equal_ct_list
-             , CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS tv
-                      , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct
-             -> do { let wrw = isWantedCt ct
-                   ; traceRewriteM "Following inert tyvar" $
-                        vcat [ ppr tv <+> equals <+> ppr rhs_ty
-                             , ppr ctev
-                             , text "wanted_rewrite_wanted:" <+> ppr wrw ]
-                   ; when wrw $ recordRewriter ctev
-
-                   ; let rewriting_co1 = ctEvCoercion ctev
-                         rewriting_co  = case (ct_eq_rel, eq_rel) of
-                            (ReprEq, _rel)  -> assert (_rel == ReprEq)
-                                    -- if this assert fails, then
-                                    -- eqCanRewriteFR answered incorrectly
-                                               rewriting_co1
-                            (NomEq, NomEq)  -> rewriting_co1
-                            (NomEq, ReprEq) -> mkSubCo rewriting_co1
-
-                   ; return $ RTRFollowed $ mkReduction rewriting_co rhs_ty }
-
-           _other -> return RTRNotFollowed }
-
-  where
-    can_rewrite :: Ct -> Bool
-    can_rewrite ct = ctFlavourRole ct `eqCanRewriteFR` fr
-      -- This is THE key call of eqCanRewriteFR
-
-{-
-Note [An alternative story for the inert substitution]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-(This entire note is just background, left here in case we ever want
- to return the previous state of affairs)
-
-We used (GHC 7.8) to have this story for the inert substitution inert_eqs
-
- * 'a' is not in fvs(ty)
- * They are *inert* in the weaker sense that there is no infinite chain of
-   (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc
-
-This means that rewriting must be recursive, but it does allow
-  [G] a ~ [b]
-  [G] b ~ Maybe c
-
-This avoids "saturating" the Givens, which can save a modest amount of work.
-It is easy to implement, in GHC.Tc.Solver.Interact.kick_out, by only kicking out an inert
-only if (a) the work item can rewrite the inert AND
-        (b) the inert cannot rewrite the work item
-
-This is significantly harder to think about. It can save a LOT of work
-in occurs-check cases, but we don't care about them much.  #5837
-is an example, but it causes trouble only with the old (pre-Fall 2020)
-rewriting story. It is unclear if there is any gain w.r.t. to
-the new story.
-
--}
-
---------------------------------------
--- Utilities
-
--- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at
--- least one named binder.
-split_pi_tys' :: Type -> ([PiTyBinder], Type, Bool)
-split_pi_tys' ty = split ty ty
-  where
-     -- put common cases first
-  split _       (ForAllTy b res) = let -- This bang is necessary lest we see rather
-                                       -- terrible reboxing, as noted in #19102.
-                                       !(bs, ty, _) = split res res
-                                   in  (Named b : bs, ty, True)
-  split _       (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res })
-                                 = let -- See #19102
-                                       !(bs, ty, named) = split res res
-                                   in  (Anon (mkScaled w arg) af : bs, ty, named)
-
-  split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty'
-  split orig_ty _                = ([], orig_ty, False)
-{-# INLINE split_pi_tys' #-}
-
--- | Like 'tyConBindersPiTyBinders' but you also get a 'Bool' which is true iff
--- there is at least one named binder.
-ty_con_binders_ty_binders' :: [TyConBinder] -> ([PiTyBinder], Bool)
-ty_con_binders_ty_binders' = foldr go ([], False)
-  where
-    go (Bndr tv (NamedTCB vis)) (bndrs, _)
-      = (Named (Bndr tv vis) : bndrs, True)
-    go (Bndr tv (AnonTCB af))   (bndrs, n)
-      = (Anon (tymult (tyVarKind tv)) af : bndrs, n)
-    {-# INLINE go #-}
-{-# INLINE ty_con_binders_ty_binders' #-}
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ /dev/null
@@ -1,5421 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1996-1998
-
--}
-
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TupleSections, ScopedTypeVariables, MultiWayIf #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE LambdaCase #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
--- | Typecheck type and class declarations
-module GHC.Tc.TyCl (
-        tcTyAndClassDecls,
-
-        -- Functions used by GHC.Tc.TyCl.Instance to check
-        -- data/type family instance declarations
-        kcConDecls, tcConDecls, DataDeclInfo(..),
-        dataDeclChecks, checkValidTyCon,
-        tcFamTyPats, tcTyFamInstEqn,
-        tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
-        unravelFamInstPats, addConsistencyConstraints,
-        wrongKindOfFamily, checkFamTelescope
-    ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Env
-import GHC.Driver.Session
-import GHC.Driver.Config.HsToCore
-
-import GHC.Hs
-
-import GHC.Tc.Errors.Types ( TcRnMessage(..), FixedRuntimeRepProvenance(..)
-                           , mkTcRnUnknownMessage, IllegalNewtypeReason (..) )
-import GHC.Tc.TyCl.Build
-import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX
-                    , reportUnsolvedEqualities )
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.Unify( unifyType, emitResidualTvConstraint )
-import GHC.Tc.Types.Constraint( emptyWC )
-import GHC.Tc.Validity
-import GHC.Tc.Utils.Zonk
-import GHC.Tc.TyCl.Utils
-import GHC.Tc.TyCl.Class
-import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 )
-import GHC.Tc.Deriv (DerivInfo(..))
-import GHC.Tc.Gen.HsType
-import GHC.Tc.Instance.Class( AssocInstInfo(..) )
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Instance.Family
-import GHC.Tc.Types.Origin
-
-import GHC.Builtin.Types (oneDataConTy,  unitTy, makeRecoveryTyCon )
-
-import GHC.Rename.Env( lookupConstructorFields )
-
-import GHC.Core.Multiplicity
-import GHC.Core.FamInstEnv
-import GHC.Core.Coercion
-import GHC.Core.Type
-import GHC.Core.TyCo.Rep   -- for checkValidRoles
-import GHC.Core.TyCo.Ppr( pprTyVars )
-import GHC.Core.Class
-import GHC.Core.Coercion.Axiom
-import GHC.Core.TyCon
-import GHC.Core.DataCon
-import GHC.Core.Unify
-
-import GHC.Types.Error
-import GHC.Types.Id
-import GHC.Types.Id.Make
-import GHC.Types.Var
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
-import GHC.Types.Name
-import GHC.Types.Name.Set
-import GHC.Types.Name.Env
-import GHC.Types.SrcLoc
-import GHC.Types.SourceFile
-import GHC.Types.Unique
-import GHC.Types.Basic
-import qualified GHC.LanguageExtensions as LangExt
-
-import GHC.Data.FastString
-import GHC.Data.Maybe
-import GHC.Data.List.SetOps( minusList, equivClasses )
-
-import GHC.Unit
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Constants (debugIsOn)
-import GHC.Utils.Misc
-
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-import Control.Monad
-import Data.Foldable ( toList, traverse_ )
-import Data.Functor.Identity
-import Data.List ( partition)
-import Data.List.NonEmpty ( NonEmpty(..) )
-import qualified Data.List.NonEmpty as NE
-import Data.Tuple( swap )
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Type checking for type and class declarations}
-*                                                                      *
-************************************************************************
-
-Note [Grouping of type and class declarations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly
-connected component of mutually dependent types and classes. We kind check and
-type check each group separately to enhance kind polymorphism. Take the
-following example:
-
-  type Id a = a
-  data X = X (Id Int)
-
-If we were to kind check the two declarations together, we would give Id the
-kind * -> *, since we apply it to an Int in the definition of X. But we can do
-better than that, since Id really is kind polymorphic, and should get kind
-forall (k::*). k -> k. Since it does not depend on anything else, it can be
-kind-checked by itself, hence getting the most general kind. We then kind check
-X, which works fine because we then know the polymorphic kind of Id, and simply
-instantiate k to *.
-
-Note [Check role annotations in a second pass]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Role inference potentially depends on the types of all of the datacons declared
-in a mutually recursive group. The validity of a role annotation, in turn,
-depends on the result of role inference. Because the types of datacons might
-be ill-formed (see #7175 and Note [rejigConRes]) we must check
-*all* the tycons in a group for validity before checking *any* of the roles.
-Thus, we take two passes over the resulting tycons, first checking for general
-validity and then checking for valid role annotations.
--}
-
-tcTyAndClassDecls :: [TyClGroup GhcRn]      -- Mutually-recursive groups in
-                                            -- dependency order
-                  -> TcM ( TcGblEnv         -- Input env extended by types and
-                                            -- classes
-                                            -- and their implicit Ids,DataCons
-                         , [InstInfo GhcRn] -- Source-code instance decls info
-                         , [DerivInfo]      -- Deriving info
-                         , ThBindEnv        -- TH binding levels
-                         )
--- Fails if there are any errors
-tcTyAndClassDecls tyclds_s
-  -- The code recovers internally, but if anything gave rise to
-  -- an error we'd better stop now, to avoid a cascade
-  -- Type check each group in dependency order folding the global env
-  = checkNoErrs $ fold_env [] [] emptyNameEnv tyclds_s
-  where
-    fold_env :: [InstInfo GhcRn]
-             -> [DerivInfo]
-             -> ThBindEnv
-             -> [TyClGroup GhcRn]
-             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
-    fold_env inst_info deriv_info th_bndrs []
-      = do { gbl_env <- getGblEnv
-           ; return (gbl_env, inst_info, deriv_info, th_bndrs) }
-    fold_env inst_info deriv_info th_bndrs (tyclds:tyclds_s)
-      = do { (tcg_env, inst_info', deriv_info', th_bndrs')
-               <- tcTyClGroup tyclds
-           ; setGblEnv tcg_env $
-               -- remaining groups are typechecked in the extended global env.
-             fold_env (inst_info' ++ inst_info)
-                      (deriv_info' ++ deriv_info)
-                      (th_bndrs' `plusNameEnv` th_bndrs)
-                      tyclds_s }
-
-tcTyClGroup :: TyClGroup GhcRn
-            -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
--- Typecheck one strongly-connected component of type, class, and instance decls
--- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls
-tcTyClGroup (TyClGroup { group_tyclds = tyclds
-                       , group_roles  = roles
-                       , group_kisigs = kisigs
-                       , group_instds = instds })
-  = do { let role_annots = mkRoleAnnotEnv roles
-
-           -- Step 1: Typecheck the standalone kind signatures and type/class declarations
-       ; traceTc "---- tcTyClGroup ---- {" empty
-       ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))
-       ; (tyclss, data_deriv_info, kindless) <-
-           tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution]
-           do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs
-              ; tcTyClDecls tyclds kisig_env role_annots }
-
-           -- Step 1.5: Make sure we don't have any type synonym cycles
-       ; traceTc "Starting synonym cycle check" (ppr tyclss)
-       ; home_unit <- hsc_home_unit <$> getTopEnv
-       ; checkSynCycles (homeUnitAsUnit home_unit) tyclss tyclds
-       ; traceTc "Done synonym cycle check" (ppr tyclss)
-
-           -- Step 2: Perform the validity check on those types/classes
-           -- We can do this now because we are done with the recursive knot
-           -- Do it before Step 3 (adding implicit things) because the latter
-           -- expects well-formed TyCons
-       ; traceTc "Starting validity check" (ppr tyclss)
-       ; tyclss <- concatMapM checkValidTyCl tyclss
-       ; traceTc "Done validity check" (ppr tyclss)
-       ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss
-           -- See Note [Check role annotations in a second pass]
-
-       ; traceTc "---- end tcTyClGroup ---- }" empty
-
-           -- Step 3: Add the implicit things;
-           -- we want them in the environment because
-           -- they may be mentioned in interface files
-       ; (gbl_env, th_bndrs) <- addTyConsToGblEnv tyclss
-
-           -- Step 4: check instance declarations
-       ; (gbl_env', inst_info, datafam_deriv_info, th_bndrs') <-
-         setGblEnv gbl_env $
-         tcInstDecls1 instds
-
-       ; let deriv_info = datafam_deriv_info ++ data_deriv_info
-       ; let gbl_env'' = gbl_env'
-                { tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless }
-       ; return (gbl_env'', inst_info, deriv_info,
-                 th_bndrs' `plusNameEnv` th_bndrs) }
-
--- Gives the kind for every TyCon that has a standalone kind signature
-type KindSigEnv = NameEnv Kind
-
-tcTyClDecls
-  :: [LTyClDecl GhcRn]
-  -> KindSigEnv
-  -> RoleAnnotEnv
-  -> TcM ([TyCon], [DerivInfo], NameSet)
-tcTyClDecls tyclds kisig_env role_annots
-  = do {    -- Step 1: kind-check this group and returns the final
-            -- (possibly-polymorphic) kind of each TyCon and Class
-            -- See Note [Kind checking for type and class decls]
-         (tc_tycons, kindless) <- kcTyClGroup kisig_env tyclds
-       ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))
-
-            -- Step 2: type-check all groups together, returning
-            -- the final TyCons and Classes
-            --
-            -- NB: We have to be careful here to NOT eagerly unfold
-            -- type synonyms, as we have not tested for type synonym
-            -- loops yet and could fall into a black hole.
-       ; fixM $ \ ~(rec_tyclss, _, _) -> do
-           { tcg_env <- getGblEnv
-                 -- Forced so we don't retain a reference to the TcGblEnv
-           ; let !src  = tcg_src tcg_env
-                 roles = inferRoles src role_annots rec_tyclss
-
-                 -- Populate environment with knot-tied ATyCon for TyCons
-                 -- NB: if the decls mention any ill-staged data cons
-                 -- (see Note [Recursion and promoting data constructors])
-                 -- we will have failed already in kcTyClGroup, so no worries here
-           ; (tycons, data_deriv_infos) <-
-             tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $
-
-                 -- Also extend the local type envt with bindings giving
-                 -- a TcTyCon for each knot-tied TyCon or Class
-                 -- See Note [Type checking recursive type and class declarations]
-                 -- and Note [Type environment evolution]
-             tcExtendKindEnvWithTyCons tc_tycons $
-
-                 -- Kind and type check declarations for this group
-               mapAndUnzipM (tcTyClDecl roles) tyclds
-           ; return (tycons, concat data_deriv_infos, kindless)
-           } }
-  where
-    ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma
-                                  , ppr (tyConBinders tc) <> comma
-                                  , ppr (tyConResKind tc)
-                                  , ppr (isTcTyCon tc) ])
-
-zipRecTyClss :: [TcTyCon]
-             -> [TyCon]           -- Knot-tied
-             -> [(Name,TyThing)]
--- Build a name-TyThing mapping for the TyCons bound by decls
--- being careful not to look at the knot-tied [TyThing]
--- The TyThings in the result list must have a visible ATyCon,
--- because typechecking types (in, say, tcTyClDecl) looks at
--- this outer constructor
-zipRecTyClss tc_tycons rec_tycons
-  = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ]
-  where
-    rec_tc_env :: NameEnv TyCon
-    rec_tc_env = foldr add_tc emptyNameEnv rec_tycons
-
-    add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
-    add_tc tc env = foldr add_one_tc env (tc : tyConATs tc)
-
-    add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
-    add_one_tc tc env = extendNameEnv env (tyConName tc) tc
-
-    get name = case lookupNameEnv rec_tc_env name of
-                 Just tc -> tc
-                 other   -> pprPanic "zipRecTyClss" (ppr name <+> ppr other)
-
-{-
-************************************************************************
-*                                                                      *
-                Kind checking
-*                                                                      *
-************************************************************************
-
-Note [Kind checking for type and class decls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Kind checking is done thus:
-
-   1. Make up a kind variable for each parameter of the declarations,
-      and extend the kind environment (which is in the TcLclEnv)
-
-   2. Kind check the declarations
-
-We need to kind check all types in the mutually recursive group
-before we know the kind of the type variables.  For example:
-
-  class C a where
-     op :: D b => a -> b -> b
-
-  class D c where
-     bop :: (Monad c) => ...
-
-Here, the kind of the locally-polymorphic type variable "b"
-depends on *all the uses of class D*.  For example, the use of
-Monad c in bop's type signature means that D must have kind Type->Type.
-
-Note: we don't treat type synonyms specially (we used to, in the past);
-in particular, even if we have a type synonym cycle, we still kind check
-it normally, and test for cycles later (checkSynCycles).  The reason
-we can get away with this is because we have more systematic TYPE r
-inference, which means that we can do unification between kinds that
-aren't lifted (this historically was not true.)
-
-The downside of not directly reading off the kinds of the RHS of
-type synonyms in topological order is that we don't transparently
-support making synonyms of types with higher-rank kinds.  But
-you can always specify a CUSK directly to make this work out.
-See tc269 for an example.
-
-Note [CUSKs and PolyKinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-    data T (a :: *) = MkT (S a)   -- Has CUSK
-    data S a = MkS (T Int) (S a)  -- No CUSK
-
-Via inferInitialKinds we get
-  T :: * -> *
-  S :: kappa -> *
-
-Then we call kcTyClDecl on each decl in the group, to constrain the
-kind unification variables.  BUT we /skip/ the RHS of any decl with
-a CUSK.  Here we skip the RHS of T, so we eventually get
-  S :: forall k. k -> *
-
-This gets us more polymorphism than we would otherwise get, similar
-(but implemented strangely differently from) the treatment of type
-signatures in value declarations.
-
-However, we only want to do so when we have PolyKinds.
-When we have NoPolyKinds, we don't skip those decls, because we have defaulting
-(#16609). Skipping won't bring us more polymorphism when we have defaulting.
-Consider
-
-  data T1 a = MkT1 T2        -- No CUSK
-  data T2 = MkT2 (T1 Maybe)  -- Has CUSK
-
-If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved.
-With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the
-program type-checks.
-But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens
-in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking
-(T1 Maybe) will throw a type error.
-
-Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip.
-
-Open type families
-~~~~~~~~~~~~~~~~~~
-This treatment of type synonyms only applies to Haskell 98-style synonyms.
-General type functions can be recursive, and hence, appear in `alg_decls'.
-
-The kind of an open type family is solely determined by its kind signature;
-hence, only kind signatures participate in the construction of the initial
-kind environment (as constructed by `inferInitialKind'). In fact, we ignore
-instances of families altogether in the following. However, we need to include
-the kinds of *associated* families into the construction of the initial kind
-environment. (This is handled by `allDecls').
-
-See also Note [Kind checking recursive type and class declarations]
-
-Note [How TcTyCons work]
-~~~~~~~~~~~~~~~~~~~~~~~~
-TcTyCons are used for two distinct purposes
-
-1.  When recovering from a type error in a type declaration,
-    we want to put the erroneous TyCon in the environment in a
-    way that won't lead to more errors.  We use a TcTyCon for this;
-    see makeRecoveryTyCon.
-
-2.  When checking a type/class declaration (in module GHC.Tc.TyCl), we come
-    upon knowledge of the eventual tycon in bits and pieces, and we use
-    a TcTyCon to record what we know before we are ready to build the
-    final TyCon.  Here is the plan:
-
-    Step 1 (inferInitialKinds, inference only, skipped for checking):
-       Make a MonoTcTyCon whose binders are TcTyVars,
-       which may contain free unification variables
-
-    Step 2 (generaliseTcTyCon)
-       Generalise that MonoTcTyCon to make a PolyTcTyCon
-       Its binders are skolem TcTyVars, with accurate SkolemInfo
-
-    Step 3 (tcTyClDecl)
-       Typecheck the type and class decls to produce a final TyCon
-       Its binders are final TyVars, not TcTyVars
-
-    Note that a MonoTcTyCon can contain unification variables,
-    but a PolyTcTyCon does not: only skolem TcTyVars.  See
-    Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType
-
-    More details about /kind inference/:
-
-      S1) In kcTyClGroup, we use inferInitialKinds to look over the
-          declaration of any TyCon that lacks a kind signature or
-          CUSK, to determine its "shape"; for example, the number of
-          parameters, and any kind signatures.
-
-          We record that shape record that shape in a MonoTcTyCon; it is
-          "mono" because it has not been been generalised, and its binders
-          and result kind may have free unification variables.
-
-      S2) Still in kcTyClGroup, we use kcLTyClDecl to kind-check the
-          body (class methods, data constructors, etc.) of each of
-          these MonoTcTyCons, which has the effect of filling in the
-          metavariables in the tycon's initial kind.
-
-      S3) Still in kcTyClGroup, we use generaliseTyClDecl to generalize
-          each MonoTcTyCon to get a PolyTcTyCon, with skolem TcTyVars in it,
-          and a final, fixed kind.
-
-      S4) Finally, back in TcTyClDecls, we extend the environment with
-          the PolyTcTyCons, and typecheck each declaration (regardless
-          of kind signatures etc) to get final TyCon.
-
-    More details about /kind checking/
-
-      S5) In kcTyClGroup, we use checkInitialKinds to get the
-          utterly-final Kind of all TyCons in the group that
-            (a) have a separate kind signature or
-            (b) have a CUSK.
-          This produces a PolyTcTyCon, that is, a TcTyCon in which the binders
-          and result kind are full of TyVars (not TcTyVars).  No unification
-          variables here; everything is in its final form.
-
-3.  tyConScopedTyVars.  A challenging piece in all of this is that we
-    end up taking three separate passes over every declaration:
-      - one in inferInitialKind (this pass look only at the head, not the body)
-      - one in kcTyClDecls (to kind-check the body)
-      - a final one in tcTyClDecls (to desugar)
-
-    In the latter two passes, we need to connect the user-written type
-    variables in an LHsQTyVars with the variables in the tycon's
-    inferred kind. Because the tycon might not have a CUSK, this
-    matching up is, in general, quite hard to do.  (Look through the
-    git history between Dec 2015 and Apr 2016 for
-    GHC.Tc.Gen.HsType.splitTelescopeTvs!)
-
-    Instead of trying, we just store the list of type variables to
-    bring into scope, in the tyConScopedTyVars field of a MonoTcTyCon.
-    These tyvars are brought into scope by the calls to
-       tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon)
-    in kcTyClDecl.
-
-    In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather
-    than just [TcTyVar]?  Consider these mutually-recursive decls
-       data T (a :: k1) b = MkT (S a b)
-       data S (c :: k2) d = MkS (T c d)
-    We start with k1 bound to kappa1, and k2 to kappa2; so initially
-    in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But
-    then kappa1 and kappa2 get unified; so after the zonking in
-    'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ.
-
-See also Note [Type checking recursive type and class declarations].
-
-Note [Swizzling the tyvars before generaliseTcTyCon]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This Note only applies when /inferring/ the kind of a TyCon.
-If there is a separate kind signature, or a CUSK, we take an entirely
-different code path.
-
-For inference, consider
-   class C (f :: k) x where
-      type T f
-      op :: D f => blah
-   class D (g :: j) y where
-      op :: C g => y -> blah
-
-Here C and D are considered mutually recursive.  Neither has a CUSK.
-Just before generalisation we have the (un-quantified) kinds
-   C :: k1 -> k2 -> Constraint
-   T :: k1 -> Type
-   D :: k1 -> Type -> Constraint
-Notice that f's kind and g's kind have been unified to 'k1'. We say
-that k1 is the "representative" of k in C's decl, and of j in D's decl.
-
-Now when quantifying, we'd like to end up with
-   C :: forall {k2}. forall k. k -> k2 -> Constraint
-   T :: forall k. k -> Type
-   D :: forall j. j -> Type -> Constraint
-
-That is, we want to swizzle the representative to have the Name given
-by the user. Partly this is to improve error messages and the output of
-:info in GHCi.  But it is /also/ important because the code for a
-default method may mention the class variable(s), but at that point
-(tcClassDecl2), we only have the final class tyvars available.
-(Alternatively, we could record the scoped type variables in the
-TyCon, but it's a nuisance to do so.)
-
-Notes:
-
-* On the input to generaliseTyClDecl, the mapping between the
-  user-specified Name and the representative TyVar is recorded in the
-  tyConScopedTyVars of the TcTyCon.  NB: you first need to zonk to see
-  this representative TyVar.
-
-* The swizzling is actually performed by swizzleTcTyConBndrs
-
-* We must do the swizzling across the whole class decl. Consider
-     class C f where
-       type S (f :: k)
-       type T f
-  Here f's kind k is a parameter of C, and its identity is shared
-  with S and T.  So if we swizzle the representative k at all, we
-  must do so consistently for the entire declaration.
-
-  Hence the call to check_duplicate_tc_binders is in generaliseTyClDecl,
-  rather than in generaliseTcTyCon.
-
-There are errors to catch here.  Suppose we had
-   class E (f :: j) (g :: k) where
-     op :: SameKind f g -> blah
-
-Then, just before generalisation we will have the (unquantified)
-   E :: k1 -> k1 -> Constraint
-
-That's bad!  Two distinctly-named tyvars (j and k) have ended up with
-the same representative k1.  So when swizzling, we check (in
-check_duplicate_tc_binders) that two distinct source names map
-to the same representative.
-
-Here's an interesting case:
-    class C1 f where
-      type S (f :: k1)
-      type T (f :: k2)
-Here k1 and k2 are different Names, but they end up mapped to the
-same representative TyVar.  To make the swizzling consistent (remember
-we must have a single k across C1, S and T) we reject the program.
-
-Another interesting case
-    class C2 f where
-      type S (f :: k) (p::Type)
-      type T (f :: k) (p::Type->Type)
-
-Here the two k's (and the two p's) get distinct Uniques, because they
-are seen by the renamer as locally bound in S and T resp.  But again
-the two (distinct) k's end up bound to the same representative TyVar.
-You might argue that this should be accepted, but it's definitely
-rejected (via an entirely different code path) if you add a kind sig:
-    type C2' :: j -> Constraint
-    class C2' f where
-      type S (f :: k) (p::Type)
-We get
-    • Expected kind ‘j’, but ‘f’ has kind ‘k’
-    • In the associated type family declaration for ‘S’
-
-So we reject C2 too, even without the kind signature.  We have
-to do a bit of work to get a good error message, since both k's
-look the same to the user.
-
-Another case
-    class C3 (f :: k1) where
-      type S (f :: k2)
-
-This will be rejected too.
-
-
-Note [Type environment evolution]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As we typecheck a group of declarations the type environment evolves.
-Consider for example:
-  data B (a :: Type) = MkB (Proxy 'MkB)
-
-We do the following steps:
-
-  1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the
-     type env with promotion errors
-            B   :-> TyConPE
-            MkB :-> DataConPE
-
-  2. kcTyCLGroup
-      - Do inferInitialKinds, which will signal a promotion
-        error if B is used in any of the kinds needed to initialise
-        B's kind (e.g. (a :: Type)) here
-
-      - Extend the type env with these initial kinds (monomorphic for
-        decls that lack a CUSK)
-            B :-> TcTyCon <initial kind>
-        (thereby overriding the B :-> TyConPE binding)
-        and do kcLTyClDecl on each decl to get equality constraints on
-        all those initial kinds
-
-      - Generalise the initial kind, making a poly-kinded TcTyCon
-
-  3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded
-     TcTyCons, again overriding the promotion-error bindings.
-
-     But note that the data constructor promotion errors are still in place
-     so that (in our example) a use of MkB will still be signalled as
-     an error.
-
-  4. Typecheck the decls.
-
-  5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons
-
-
-Note [Missed opportunity to retain higher-rank kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In 'kcTyClGroup', there is a missed opportunity to make kind
-inference work in a few more cases.  The idea is analogous
-to Note [Special case for non-recursive function bindings]:
-
-     * If we have an SCC with a single decl, which is non-recursive,
-       instead of creating a unification variable representing the
-       kind of the decl and unifying it with the rhs, we can just
-       read the type directly of the rhs.
-
-     * Furthermore, we can update our SCC analysis to ignore
-       dependencies on declarations which have CUSKs: we don't
-       have to kind-check these all at once, since we can use
-       the CUSK to initialize the kind environment.
-
-Unfortunately this requires reworking a bit of the code in
-'kcLTyClDecl' so I've decided to punt unless someone shouts about it.
-
-Note [Don't process associated types in getInitialKind]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Previously, we processed associated types in the thing_inside in getInitialKind,
-but this was wrong -- we want to do ATs separately.
-The consequence for not doing it this way is #15142:
-
-  class ListTuple (tuple :: Type) (as :: [(k, Type)]) where
-    type ListToTuple as :: Type
-
-We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify
-kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring
-`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't
-unified with Type. And then, when we generalize the kind of ListToTuple (which
-indeed has a CUSK, according to the rules), we skolemize the free metavariable
-kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple,
-because the solveEqualities in kcInferDeclHeader is at TcLevel 1 and so kappa[1]
-will unify with Type.
-
-Bottom line: as associated types should have no effect on a CUSK enclosing class,
-we move processing them to a separate action, run after the outer kind has
-been generalized.
-
--}
-
-kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([PolyTcTyCon], NameSet)
-
--- Kind check this group, kind generalize, and return the resulting local env
--- This binds the TyCons and Classes of the group, but not the DataCons
--- See Note [Kind checking for type and class decls]
--- and Note [Inferring kinds for type declarations]
---
--- The NameSet returned contains kindless tycon names, without CUSK or SAKS.
-kcTyClGroup kisig_env decls
-  = do  { mod <- getModule
-        ; traceTc "---- kcTyClGroup ---- {"
-                  (text "module" <+> ppr mod $$ vcat (map ppr decls))
-
-          -- Kind checking;
-          --    1. Bind kind variables for decls
-          --    2. Kind-check decls
-          --    3. Generalise the inferred kinds
-          -- See Note [Kind checking for type and class decls]
-
-        ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds
-                    -- See Note [CUSKs and PolyKinds]
-        ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls
-              kindless_names = mkNameSet $ map get_name kindless_decls
-
-              get_name d = tcdName (unLoc d)
-
-              get_kind d
-                | Just ki <- lookupNameEnv kisig_env (get_name d)
-                = Right (d, SAKS ki)
-
-                | cusks_enabled && hsDeclHasCusk (unLoc d)
-                = Right (d, CUSK)
-
-                | otherwise = Left d
-
-        ; checked_tcs <- checkNoErrs $
-                         checkInitialKinds kinded_decls
-                         -- checkNoErrs because we are about to extend
-                         -- the envt with these tycons, and we get
-                         -- knock-on errors if we have tycons with
-                         -- malformed kinds
-
-        ; inferred_tcs
-            <- tcExtendKindEnvWithTyCons checked_tcs  $
-               pushLevelAndSolveEqualities unkSkolAnon [] $
-                     -- We are going to kind-generalise, so unification
-                     -- variables in here must be one level in
-               do {  -- Step 1: Bind kind variables for all decls
-                    mono_tcs <- inferInitialKinds kindless_decls
-
-                  ; traceTc "kcTyClGroup: initial kinds" $
-                    ppr_tc_kinds mono_tcs
-
-                    -- Step 2: Set extended envt, kind-check the decls
-                    -- NB: the environment extension overrides the tycon
-                    --     promotion-errors bindings
-                    --     See Note [Type environment evolution]
-                  ; checkNoErrs $
-                    tcExtendKindEnvWithTyCons mono_tcs $
-                    mapM_ kcLTyClDecl kindless_decls
-
-                  ; return mono_tcs }
-
-        -- Step 3: generalisation
-        -- Finally, go through each tycon and give it its final kind,
-        -- with all the required, specified, and inferred variables
-        -- in order.
-        ; let inferred_tc_env = mkNameEnv $
-                                map (\tc -> (tyConName tc, tc)) inferred_tcs
-        ; generalized_tcs <- concatMapM (generaliseTyClDecl inferred_tc_env)
-                                        kindless_decls
-
-        ; let poly_tcs = checked_tcs ++ generalized_tcs
-        ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs)
-        ; return (poly_tcs, kindless_names) }
-  where
-    ppr_tc_kinds tcs = vcat (map pp_tc tcs)
-    pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)
-
-type ScopedPairs = [(Name, TcTyVar)]
-  -- The ScopedPairs for a TcTyCon are precisely
-  --    specified-tvs ++ required-tvs
-  -- You can distinguish them because there are tyConArity required-tvs
-
-generaliseTyClDecl :: NameEnv MonoTcTyCon -> LTyClDecl GhcRn -> TcM [PolyTcTyCon]
--- See Note [Swizzling the tyvars before generaliseTcTyCon]
-generaliseTyClDecl inferred_tc_env (L _ decl)
-  = do { let names_in_this_decl :: [Name]
-             names_in_this_decl = tycld_names decl
-
-       -- Extract the specified/required binders and skolemise them
-       ; tc_with_tvs  <- mapM skolemise_tc_tycon names_in_this_decl
-
-       -- Zonk, to manifest the side-effects of skolemisation to the swizzler
-       -- NB: it's important to skolemise them all before this step. E.g.
-       --         class C f where { type T (f :: k) }
-       --     We only skolemise k when looking at T's binders,
-       --     but k appears in f's kind in C's binders.
-       ; tc_infos <- mapM zonk_tc_tycon tc_with_tvs
-
-       -- Swizzle
-       ; swizzled_infos <- tcAddDeclCtxt decl (swizzleTcTyConBndrs tc_infos)
-
-       -- And finally generalise
-       ; mapAndReportM generaliseTcTyCon swizzled_infos }
-  where
-    tycld_names :: TyClDecl GhcRn -> [Name]
-    tycld_names decl = tcdName decl : at_names decl
-
-    at_names :: TyClDecl GhcRn -> [Name]
-    at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats
-    at_names _ = []  -- Only class decls have associated types
-
-    skolemise_tc_tycon :: Name -> TcM (TcTyCon, SkolemInfo, ScopedPairs)
-    -- Zonk and skolemise the Specified and Required binders
-    skolemise_tc_tycon tc_name
-      = do { let tc = lookupNameEnv_NF inferred_tc_env tc_name
-                      -- This lookup should not fail
-           ; skol_info <- mkSkolemInfo (TyConSkol (tyConFlavour tc) tc_name )
-           ; scoped_prs <- mapSndM (zonkAndSkolemise skol_info) (tcTyConScopedTyVars tc)
-           ; return (tc, skol_info, scoped_prs) }
-
-    zonk_tc_tycon :: (TcTyCon, SkolemInfo, ScopedPairs)
-                  -> TcM (TcTyCon, SkolemInfo, ScopedPairs, TcKind)
-    zonk_tc_tycon (tc, skol_info, scoped_prs)
-      = do { scoped_prs <- mapSndM zonkTcTyVarToTcTyVar scoped_prs
-                           -- We really have to do this again, even though
-                           -- we have just done zonkAndSkolemise, so that
-                           -- occurrences in the /kinds/ get zonked to the skolem
-           ; res_kind   <- zonkTcType (tyConResKind tc)
-           ; return (tc, skol_info, scoped_prs, res_kind) }
-
-swizzleTcTyConBndrs :: [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)]
-                -> TcM [(TcTyCon, SkolemInfo, ScopedPairs, TcKind)]
-swizzleTcTyConBndrs tc_infos
-  | all no_swizzle swizzle_prs
-    -- This fast path happens almost all the time
-    -- See Note [Cloning for type variable binders] in GHC.Tc.Gen.HsType
-    -- "Almost all the time" means not the case of mutual recursion with
-    -- polymorphic kinds.
-  = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr_infos tc_infos)
-       ; return tc_infos }
-
-  | otherwise
-  = do { checkForDuplicateScopedTyVars swizzle_prs
-
-       ; traceTc "swizzleTcTyConBndrs" $
-         vcat [ text "before" <+> ppr_infos tc_infos
-              , text "swizzle_prs" <+> ppr swizzle_prs
-              , text "after" <+> ppr_infos swizzled_infos ]
-
-       ; return swizzled_infos }
-
-  where
-    swizzled_infos =  [ (tc, skol_info, mapSnd swizzle_var scoped_prs, swizzle_ty kind)
-                      | (tc, skol_info, scoped_prs, kind) <- tc_infos ]
-
-    swizzle_prs :: [(Name,TyVar)]
-    -- Pairs the user-specified Name with its representative TyVar
-    -- See Note [Swizzling the tyvars before generaliseTcTyCon]
-    swizzle_prs = [ pr | (_, _, prs, _) <- tc_infos, pr <- prs ]
-
-    no_swizzle :: (Name,TyVar) -> Bool
-    no_swizzle (nm, tv) = nm == tyVarName tv
-
-    ppr_infos infos = vcat [ ppr tc <+> pprTyVars (map snd prs)
-                           | (tc, _, prs, _) <- infos ]
-
-    -------------- The swizzler ------------
-    -- This does a deep traverse, simply doing a
-    -- Name-to-Name change, governed by swizzle_env
-    -- The 'swap' is what gets from the representative TyVar
-    -- back to the original user-specified Name
-    swizzle_env = mkVarEnv (map swap swizzle_prs)
-
-    swizzleMapper :: TyCoMapper () Identity
-    swizzleMapper = TyCoMapper { tcm_tyvar = swizzle_tv
-                               , tcm_covar = swizzle_cv
-                               , tcm_hole  = swizzle_hole
-                               , tcm_tycobinder = swizzle_bndr
-                               , tcm_tycon      = swizzle_tycon }
-    swizzle_hole  _ hole = pprPanic "swizzle_hole" (ppr hole)
-       -- These types are pre-zonked
-    swizzle_tycon tc = pprPanic "swizzle_tc" (ppr tc)
-       -- TcTyCons can't appear in kinds (yet)
-    swizzle_tv _ tv = return (mkTyVarTy (swizzle_var tv))
-    swizzle_cv _ cv = return (mkCoVarCo (swizzle_var cv))
-
-    swizzle_bndr _ tcv _
-      = return ((), swizzle_var tcv)
-
-    swizzle_var :: Var -> Var
-    swizzle_var v
-      | Just nm <- lookupVarEnv swizzle_env v
-      = updateVarType swizzle_ty (v `setVarName` nm)
-      | otherwise
-      = updateVarType swizzle_ty v
-
-    (map_type, _, _, _) = mapTyCo swizzleMapper
-    swizzle_ty ty = runIdentity (map_type ty)
-
-
-generaliseTcTyCon :: (MonoTcTyCon, SkolemInfo, ScopedPairs, TcKind) -> TcM PolyTcTyCon
-generaliseTcTyCon (tc, skol_info, scoped_prs, tc_res_kind)
-  -- The scoped_prs are fully zonked skolem TcTyVars
-  -- And tc_res_kind is fully zonked too
-  -- See Note [Required, Specified, and Inferred for types]
-  = setSrcSpan (getSrcSpan tc) $
-    addTyConCtxt tc $
-    do { -- Step 1: Separate Specified from Required variables
-         -- NB: spec_req_tvs = spec_tvs ++ req_tvs
-         --     And req_tvs is 1-1 with tyConTyVars
-         --     See Note [Scoped tyvars in a TcTyCon] in GHC.Core.TyCon
-       ; let spec_req_tvs        = map snd scoped_prs
-             n_spec              = length spec_req_tvs - tyConArity tc
-             (spec_tvs, req_tvs) = splitAt n_spec spec_req_tvs
-             sorted_spec_tvs     = scopedSort spec_tvs
-                 -- NB: We can't do the sort until we've zonked
-                 --     Maintain the L-R order of scoped_tvs
-
-       -- Step 2a: find all the Inferred variables we want to quantify over
-       ; dvs1 <- candidateQTyVarsOfKinds $
-                 (tc_res_kind : map tyVarKind spec_req_tvs)
-       ; let dvs2 = dvs1 `delCandidates` spec_req_tvs
-
-       -- Step 2b: quantify, mainly meaning skolemise the free variables
-       -- Returned 'inferred' are scope-sorted and skolemised
-       ; inferred <- quantifyTyVars skol_info DefaultNonStandardTyVars dvs2
-
-       ; traceTc "generaliseTcTyCon: pre zonk"
-           (vcat [ text "tycon =" <+> ppr tc
-                 , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs
-                 , text "tc_res_kind =" <+> ppr tc_res_kind
-                 , text "dvs1 =" <+> ppr dvs1
-                 , text "inferred =" <+> pprTyVars inferred ])
-
-       -- Step 3: Final zonk: quantifyTyVars may have done some defaulting
-       ; inferred        <- zonkTcTyVarsToTcTyVars inferred
-       ; sorted_spec_tvs <- zonkTcTyVarsToTcTyVars sorted_spec_tvs
-       ; req_tvs         <- zonkTcTyVarsToTcTyVars req_tvs
-       ; tc_res_kind     <- zonkTcType             tc_res_kind
-
-       ; traceTc "generaliseTcTyCon: post zonk" $
-         vcat [ text "tycon =" <+> ppr tc
-              , text "inferred =" <+> pprTyVars inferred
-              , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs
-              , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs
-              , text "req_tvs =" <+> ppr req_tvs ]
-
-       -- Step 4: Make the TyConBinders.
-       ; let dep_fv_set     = candidateKindVars dvs1
-             inferred_tcbs  = mkNamedTyConBinders Inferred inferred
-             specified_tcbs = mkNamedTyConBinders Specified sorted_spec_tvs
-             required_tcbs  = map (mkRequiredTyConBinder dep_fv_set) req_tvs
-
-       -- Step 5: Assemble the final list.
-             all_tcbs = concat [ inferred_tcbs
-                               , specified_tcbs
-                               , required_tcbs ]
-             flav = tyConFlavour tc
-
-       -- Eta expand
-       ; (eta_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info all_tcbs tc_res_kind
-
-       -- Step 6: Make the result TcTyCon
-       ; let final_tcbs = all_tcbs `chkAppend` eta_tcbs
-             tycon = mkTcTyCon (tyConName tc)
-                               final_tcbs tc_res_kind
-                               (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs))
-                               True {- it's generalised now -}
-                               flav
-
-       ; traceTc "generaliseTcTyCon done" $
-         vcat [ text "tycon =" <+> ppr tc
-              , text "tc_res_kind =" <+> ppr tc_res_kind
-              , text "dep_fv_set =" <+> ppr dep_fv_set
-              , text "inferred_tcbs =" <+> ppr inferred_tcbs
-              , text "specified_tcbs =" <+> ppr specified_tcbs
-              , text "required_tcbs =" <+> ppr required_tcbs
-              , text "final_tcbs =" <+> ppr final_tcbs ]
-
-       -- Step 7: Check for validity.
-       -- We do this here because we're about to put the tycon into the
-       -- the environment, and we don't want anything malformed there
-       ; checkTyConTelescope tycon
-
-       ; return tycon }
-
-{- Note [Required, Specified, and Inferred for types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Each forall'd type variable in a type or kind is one of
-
-  * Required: an argument must be provided at every call site
-
-  * Specified: the argument can be inferred at call sites, but
-    may be instantiated with visible type/kind application
-
-  * Inferred: the argument must be inferred at call sites; it
-    is unavailable for use with visible type/kind application.
-
-Why have Inferred at all? Because we just can't make user-facing
-promises about the ordering of some variables. These might swizzle
-around even between minor released. By forbidding visible type
-application, we ensure users aren't caught unawares.
-
-Go read Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep.
-
-The question for this Note is this:
-   given a TyClDecl, how are its quantified type variables classified?
-Much of the debate is memorialized in #15743.
-
-Here is our design choice. When inferring the ordering of variables
-for a TyCl declaration (that is, for those variables that the user
-has not specified the order with an explicit `forall`), we use the
-following order:
-
- 1. Inferred variables
- 2. Specified variables; in the left-to-right order in which
-    the user wrote them, modified by scopedSort (see below)
-    to put them in dependency order.
- 3. Required variables before a top-level ::
- 4. All variables after a top-level ::
-
-If this ordering does not make a valid telescope, we reject the definition.
-
-Example:
-  data SameKind :: k -> k -> *
-  data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)
-
-For Bad:
-  - a, c, d, x are Required; they are explicitly listed by the user
-    as the positional arguments of Bad
-  - b is Specified; it appears explicitly in a kind signature
-  - k, the kind of a, is Inferred; it is not mentioned explicitly at all
-
-Putting variables in the order Inferred, Specified, Required
-gives us this telescope:
-  Inferred:  k
-  Specified: b : Proxy a
-  Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d)
-
-But this order is ill-scoped, because b's kind mentions a, which occurs
-after b in the telescope. So we reject Bad.
-
-Associated types
-~~~~~~~~~~~~~~~~
-For associated types everything above is determined by the
-associated-type declaration alone, ignoring the class header.
-Here is an example (#15592)
-  class C (a :: k) b where
-    type F (x :: b a)
-
-In the kind of C, 'k' is Specified.  But what about F?
-In the kind of F,
-
- * Should k be Inferred or Specified?  It's Specified for C,
-   but not mentioned in F's declaration.
-
- * In which order should the Specified variables a and b occur?
-   It's clearly 'a' then 'b' in C's declaration, but the L-R ordering
-   in F's declaration is 'b' then 'a'.
-
-In both cases we make the choice by looking at F's declaration alone,
-so it gets the kind
-   F :: forall {k}. forall b a. b a -> Type
-
-How it works
-~~~~~~~~~~~~
-These design choices are implemented by two completely different code
-paths for
-
-  * Declarations with a standalone kind signature or a complete user-specified
-    kind signature (CUSK). Handled by the kcCheckDeclHeader.
-
-  * Declarations without a kind signature (standalone or CUSK) are handled by
-    kcInferDeclHeader; see Note [Inferring kinds for type declarations].
-
-Note that neither code path worries about point (4) above, as this
-is nicely handled by not mangling the res_kind. (Mangling res_kinds is done
-*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.)
-
-We can tell Inferred apart from Specified by looking at the scoped
-tyvars; Specified are always included there.
-
-Design alternatives
-~~~~~~~~~~~~~~~~~~~
-* For associated types we considered putting the class variables
-  before the local variables, in a nod to the treatment for class
-  methods. But it got too complicated; see #15592, comment:21ff.
-
-* We rigidly require the ordering above, even though we could be much more
-  permissive. Relevant musings are at
-  https://gitlab.haskell.org/ghc/ghc/issues/15743#note_161623
-  The bottom line conclusion is that, if the user wants a different ordering,
-  then can specify it themselves, and it is better to be predictable and dumb
-  than clever and capricious.
-
-  I (Richard) conjecture we could be fully permissive, allowing all classes
-  of variables to intermix. We would have to augment ScopedSort to refuse to
-  reorder Required variables (or check that it wouldn't have). But this would
-  allow more programs. See #15743 for examples. Interestingly, Idris seems
-  to allow this intermixing. The intermixing would be fully specified, in that
-  we can be sure that inference wouldn't change between versions. However,
-  would users be able to predict it? That I cannot answer.
-
-Test cases (and tickets) relevant to these design decisions
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-  T15591*
-  T15592*
-  T15743*
-
-Note [Inferring kinds for type declarations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This note deals with /inference/ for type declarations
-that do not have a CUSK.  Consider
-  data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x)
-  data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y)
-
-We do kind inference as follows:
-
-* Step 1: inferInitialKinds, and in particular kcInferDeclHeader.
-  Make a unification variable for each of the Required and Specified
-  type variables in the header.
-
-  Record the connection between the Names the user wrote and the
-  fresh unification variables in the tcTyConScopedTyVars field
-  of the TcTyCon we are making
-      [ (a,  aa)
-      , (k1, kk1)
-      , (k2, kk2)
-      , (x,  xx) ]
-  (I'm using the convention that double letter like 'aa' or 'kk'
-  mean a unification variable.)
-
-  These unification variables
-    - Are TyVarTvs: that is, unification variables that can
-      unify only with other type variables.
-      See Note [TyVarTv] in GHC.Tc.Utils.TcMType
-
-    - Have complete fresh Names; see GHC.Tc.Utils.TcMType
-      Note [Unification variables need fresh Names]
-
-  Assign initial monomorphic kinds to S, T
-          T :: kk1 -> * -> kk2 -> *
-          S :: kk3 -> * -> kk4 -> *
-
-* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and
-  T, with these monomorphic kinds.  Now kind-check the declarations,
-  and solve the resulting equalities.  The goal here is to discover
-  constraints on all these unification variables.
-
-  Here we find that kk1 := kk3, and kk2 := kk4.
-
-  This is why we can't use skolems for kk1 etc; they have to
-  unify with each other.
-
-* Step 3: generaliseTcTyCon. Generalise each TyCon in turn.
-  We find the free variables of the kind, skolemise them,
-  sort them out into Inferred/Required/Specified (see the above
-  Note [Required, Specified, and Inferred for types]),
-  and perform some validity checks.
-
-  This makes the utterly-final TyConBinders for the TyCon.
-
-  All this is very similar at the level of terms: see GHC.Tc.Gen.Bind
-  Note [Quantified variables in partial type signatures]
-
-  But there are some tricky corners: Note [Tricky scoping in generaliseTcTyCon]
-
-* Step 4.  Extend the type environment with a TcTyCon for S and T, now
-  with their utterly-final polymorphic kinds (needed for recursive
-  occurrences of S, T).  Now typecheck the declarations, and build the
-  final AlgTyCon for S and T resp.
-
-The first three steps are in kcTyClGroup; the fourth is in
-tcTyClDecls.
-
-There are some wrinkles
-
-* Do not default TyVarTvs.  We always want to kind-generalise over
-  TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is
-  not allowed to unify with a type; it must stand for a type
-  variable. Hence the check in GHC.Tc.Solver.defaultTyVarTcS, and
-  GHC.Tc.Utils.TcMType.defaultTyVar.  Here's another example (#14555):
-     data Exp :: [TYPE rep] -> TYPE rep -> Type where
-        Lam :: Exp (a:xs) b -> Exp xs (a -> b)
-  We want to kind-generalise over the 'rep' variable.
-  #14563 is another example.
-
-* Duplicate type variables. Consider #11203
-    data SameKind :: k -> k -> *
-    data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)
-  Here we will unify k1 with k2, but this time doing so is an error,
-  because k1 and k2 are bound in the same declaration.
-
-  We spot this during validity checking (checkForDuplicateScopeTyVars),
-  in generaliseTcTyCon.
-
-* Required arguments.  Even the Required arguments should be made
-  into TyVarTvs, not skolems.  Consider
-    data T k (a :: k)
-  Here, k is a Required, dependent variable. For uniformity, it is helpful
-  to have k be a TyVarTv, in parallel with other dependent variables.
-
-* Duplicate skolemisation is expected.  When generalising in Step 3,
-  we may find that one of the variables we want to quantify has
-  already been skolemised.  For example, suppose we have already
-  generalise S. When we come to T we'll find that kk1 (now the same as
-  kk3) has already been skolemised.
-
-  That's fine -- but it means that
-    a) when collecting quantification candidates, in
-       candidateQTyVarsOfKind, we must collect skolems
-    b) quantifyTyVars should be a no-op on such a skolem
-
-Note [Tricky scoping in generaliseTcTyCon]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider #16342
-  class C (a::ka) x where
-    cop :: D a x => x -> Proxy a -> Proxy a
-    cop _ x = x :: Proxy (a::ka)
-
-  class D (b::kb) y where
-    dop :: C b y => y -> Proxy b -> Proxy b
-    dop _ x = x :: Proxy (b::kb)
-
-C and D are mutually recursive, by the time we get to
-generaliseTcTyCon we'll have unified kka := kkb.
-
-But when typechecking the default declarations for 'cop' and 'dop' in
-tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope.
-But at that point all we have is the utterly-final Class itself.
-
-Conclusion: the classTyVars of a class must have the same Name as
-that originally assigned by the user.  In our example, C must have
-classTyVars {a, ka, x} while D has classTyVars {a, kb, y}.  Despite
-the fact that kka and kkb got unified!
-
-We achieve this sleight of hand in generaliseTcTyCon, using
-the specialised function zonkRecTyVarBndrs.  We make the call
-   zonkRecTyVarBndrs [ka,a,x] [kkb,aa,xxx]
-where the [ka,a,x] are the Names originally assigned by the user, and
-[kkb,aa,xx] are the corresponding (post-zonking, skolemised) TcTyVars.
-zonkRecTyVarBndrs builds a recursive ZonkEnv that binds
-   kkb :-> (ka :: <zonked kind of kkb>)
-   aa  :-> (a  :: <konked kind of aa>)
-   etc
-That is, it maps each skolemised TcTyVars to the utterly-final
-TyVar to put in the class, with its correct user-specified name.
-When generalising D we'll do the same thing, but the ZonkEnv will map
-   kkb :-> (kb :: <zonked kind of kkb>)
-   bb  :-> (b  :: <konked kind of bb>)
-   etc
-Note that 'kkb' again appears in the domain of the mapping, but this
-time mapped to 'kb'.  That's how C and D end up with differently-named
-final TyVars despite the fact that we unified kka:=kkb
-
-zonkRecTyVarBndrs we need to do knot-tying because of the need to
-apply this same substitution to the kind of each.
-
-Note [Inferring visible dependent quantification]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-  data T k :: k -> Type where
-    MkT1 :: T Type Int
-    MkT2 :: T (Type -> Type) Maybe
-
-This looks like it should work. However, it is polymorphically recursive,
-as the uses of T in the constructor types specialize the k in the kind
-of T. This trips up our dear users (#17131, #17541), and so we add
-a "landmark" context (which cannot be suppressed) whenever we
-spot inferred visible dependent quantification (VDQ).
-
-It's hard to know when we've actually been tripped up by polymorphic recursion
-specifically, so we just include a note to users whenever we infer VDQ. The
-testsuite did not show up a single spurious inclusion of this message.
-
-The context is added in addVDQNote, which looks for a visible TyConBinder
-that also appears in the TyCon's kind. (I first looked at the kind for
-a visible, dependent quantifier, but Note [No polymorphic recursion] in
-GHC.Tc.Gen.HsType defeats that approach.) addVDQNote is used in kcTyClDecl,
-which is used only when inferring the kind of a tycon (never with a CUSK or
-SAK).
-
-Once upon a time, I (Richard E) thought that the tycon-kind could
-not be a forall-type. But this is wrong: data T :: forall k. k -> Type
-(with -XNoCUSKs) could end up here. And this is all OK.
-
-
--}
-
---------------
-tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a
-tcExtendKindEnvWithTyCons tcs
-  = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ]
-
---------------
-mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv
--- Maps each tycon/datacon to a suitable promotion error
---    tc :-> APromotionErr TyConPE
---    dc :-> APromotionErr RecDataConPE
---    See Note [Recursion and promoting data constructors]
-
-mkPromotionErrorEnv decls
-  = foldr (plusNameEnv . mk_prom_err_env . unLoc)
-          emptyNameEnv decls
-
-mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv
-mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats })
-  = unitNameEnv nm (APromotionErr ClassPE)
-    `plusNameEnv`
-    mkNameEnv [ (familyDeclName at, APromotionErr TyConPE)
-              | L _ at <- ats ]
-
-mk_prom_err_env (DataDecl { tcdLName = L _ name
-                          , tcdDataDefn = HsDataDefn { dd_cons = cons } })
-  = unitNameEnv name (APromotionErr TyConPE)
-    `plusNameEnv`
-    mkNameEnv [ (con, APromotionErr conPE)
-              | L _ con' <- toList cons
-              , L _ con  <- getConNames con' ]
-  where
-    -- In a "type data" declaration, the constructors are at the type level.
-    -- See Note [Type data declarations] in GHC.Rename.Module.
-    conPE
-      | isTypeDataDefnCons cons = TyConPE
-      | otherwise = RecDataConPE
-
-mk_prom_err_env decl
-  = unitNameEnv (tcdName decl) (APromotionErr TyConPE)
-    -- Works for family declarations too
-
---------------
-inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [MonoTcTyCon]
--- Returns a TcTyCon for each TyCon bound by the decls,
--- each with its initial kind
-
-inferInitialKinds decls
-  = do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls)
-       ; tcs <- concatMapM infer_initial_kind decls
-       ; traceTc "inferInitialKinds done }" empty
-       ; return tcs }
-  where
-    infer_initial_kind = addLocMA (getInitialKind InitialKindInfer)
-
--- Check type/class declarations against their standalone kind signatures or
--- CUSKs, producing a generalized TcTyCon for each.
-checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [PolyTcTyCon]
-checkInitialKinds decls
-  = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls)
-       ; tcs <- concatMapM check_initial_kind decls
-       ; traceTc "checkInitialKinds done }" empty
-       ; return tcs }
-  where
-    check_initial_kind (ldecl, msig) =
-      addLocMA (getInitialKind (InitialKindCheck msig)) ldecl
-
--- | Get the initial kind of a TyClDecl, either generalized or non-generalized,
--- depending on the 'InitialKindStrategy'.
-getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon]
-
--- Allocate a fresh kind variable for each TyCon and Class
--- For each tycon, return a TcTyCon with kind k
--- where k is the kind of tc, derived from the LHS
---         of the definition (and probably including
---         kind unification variables)
---      Example: data T a b = ...
---      return (T, kv1 -> kv2 -> kv3)
---
--- This pass deals with (ie incorporates into the kind it produces)
---   * The kind signatures on type-variable binders
---   * The result kinds signature on a TyClDecl
---
--- No family instances are passed to checkInitialKinds/inferInitialKinds
-getInitialKind strategy
-    (ClassDecl { tcdLName = L _ name
-               , tcdTyVars = ktvs
-               , tcdATs = ats })
-  = do { cls_tc <- kcDeclHeader strategy name ClassFlavour ktvs $
-                return (TheKind constraintKind)
-            -- See Note [Don't process associated types in getInitialKind]
-
-       ; at_tcs <- tcExtendTyVarEnv (tyConTyVars cls_tc) $
-                      mapM (addLocMA (getAssocFamInitialKind cls_tc)) ats
-       ; return (cls_tc : at_tcs) }
-  where
-    getAssocFamInitialKind cls =
-      case strategy of
-        InitialKindInfer   -> get_fam_decl_initial_kind (Just cls)
-        InitialKindCheck _ -> check_initial_kind_assoc_fam cls
-
-getInitialKind strategy
-    (DataDecl { tcdLName = L _ name
-              , tcdTyVars = ktvs
-              , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig, dd_cons = cons } })
-  = do  { let flav = newOrDataToFlavour (dataDefnConsNewOrData cons)
-              ctxt = DataKindCtxt name
-        ; tc <- kcDeclHeader strategy name flav ktvs $
-                case m_sig of
-                  Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig
-                  Nothing   -> return $ dataDeclDefaultResultKind strategy (dataDefnConsNewOrData cons)
-        ; return [tc] }
-
-getInitialKind InitialKindInfer (FamDecl { tcdFam = decl })
-  = do { tc <- get_fam_decl_initial_kind Nothing decl
-       ; return [tc] }
-
-getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam =
-  FamilyDecl { fdLName     = unLoc -> name
-             , fdTyVars    = ktvs
-             , fdResultSig = unLoc -> resultSig
-             , fdInfo      = info } } )
-  = do { let flav = getFamFlav Nothing info
-             ctxt = TyFamResKindCtxt name
-       ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $
-               case famResultKindSignature resultSig of
-                 Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig
-                 Nothing ->
-                   case msig of
-                     CUSK -> return (TheKind liftedTypeKind)
-                     SAKS _ -> return AnyKind
-       ; return [tc] }
-
-getInitialKind strategy
-    (SynDecl { tcdLName = L _ name
-             , tcdTyVars = ktvs
-             , tcdRhs = rhs })
-  = do { let ctxt = TySynKindCtxt name
-       ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $
-               case hsTyKindSig rhs of
-                 Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig
-                 Nothing -> return AnyKind
-       ; return [tc] }
-
-get_fam_decl_initial_kind
-  :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls
-  -> FamilyDecl GhcRn
-  -> TcM TcTyCon
-get_fam_decl_initial_kind mb_parent_tycon
-    FamilyDecl { fdLName     = L _ name
-               , fdTyVars    = ktvs
-               , fdResultSig = L _ resultSig
-               , fdInfo      = info }
-  = kcDeclHeader InitialKindInfer name flav ktvs $
-    case resultSig of
-      KindSig _ ki                            -> TheKind <$> tcLHsKindSig ctxt ki
-      TyVarSig _ (L _ (KindedTyVar _ _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki
-      _ -- open type families have * return kind by default
-        | tcFlavourIsOpen flav              -> return (TheKind liftedTypeKind)
-               -- closed type families have their return kind inferred
-               -- by default
-        | otherwise                         -> return AnyKind
-  where
-    flav = getFamFlav mb_parent_tycon info
-    ctxt = TyFamResKindCtxt name
-
--- See Note [Standalone kind signatures for associated types]
-check_initial_kind_assoc_fam
-  :: TcTyCon -- parent class
-  -> FamilyDecl GhcRn
-  -> TcM TcTyCon
-check_initial_kind_assoc_fam cls
-  FamilyDecl
-    { fdLName     = unLoc -> name
-    , fdTyVars    = ktvs
-    , fdResultSig = unLoc -> resultSig
-    , fdInfo      = info }
-  = kcDeclHeader (InitialKindCheck CUSK) name flav ktvs $
-    case famResultKindSignature resultSig of
-      Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig
-      Nothing -> return (TheKind liftedTypeKind)
-  where
-    ctxt = TyFamResKindCtxt name
-    flav = getFamFlav (Just cls) info
-
-{- Note [Standalone kind signatures for associated types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-If associated types had standalone kind signatures, would they wear them
-
----------------------------+------------------------------
-  like this? (OUT)         |   or like this? (IN)
----------------------------+------------------------------
-  type T :: Type -> Type   |   class C a where
-  class C a where          |     type T :: Type -> Type
-    type T a               |     type T a
-
-The (IN) variant is syntactically ambiguous:
-
-  class C a where
-    type T :: a   -- standalone kind signature?
-    type T :: a   -- declaration header?
-
-The (OUT) variant does not suffer from this issue, but it might not be the
-direction in which we want to take Haskell: we seek to unify type families and
-functions, and, by extension, associated types with class methods. And yet we
-give class methods their signatures inside the class, not outside. Neither do
-we have the counterpart of InstanceSigs for StandaloneKindSignatures.
-
-For now, we dodge the question by using CUSKs for associated types instead of
-standalone kind signatures. This is a simple addition to the rule we used to
-have before standalone kind signatures:
-
-  old rule:  associated type has a CUSK iff its parent class has a CUSK
-  new rule:  associated type has a CUSK iff its parent class has a CUSK or a standalone kind signature
-
--}
-
--- See Note [Data declaration default result kind]
-dataDeclDefaultResultKind :: InitialKindStrategy ->  NewOrData -> ContextKind
-dataDeclDefaultResultKind strategy new_or_data
-  | NewType <- new_or_data
-  = OpenKind -- See Note [Implementation of UnliftedNewtypes], point <Error Messages>.
-  | DataType <- new_or_data
-  , InitialKindCheck (SAKS _) <- strategy
-  = OpenKind -- See Note [Implementation of UnliftedDatatypes]
-  | otherwise
-  = TheKind liftedTypeKind
-
-{- Note [Data declaration default result kind]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When the user has not written an inline result kind annotation on a data
-declaration, we assume it to be 'Type'. That is, the following declarations
-D1 and D2 are considered equivalent:
-
-  data D1         where ...
-  data D2 :: Type where ...
-
-The consequence of this assumption is that we reject D3 even though we
-accept D4:
-
-  data D3 where
-    MkD3 :: ... -> D3 param
-
-  data D4 :: Type -> Type where
-    MkD4 :: ... -> D4 param
-
-However, there are two twists:
-
-  * For unlifted newtypes, we must relax the assumed result kind to (TYPE r):
-
-      newtype D5 where
-        MkD5 :: Int# -> D5
-
-    See Note [Implementation of UnliftedNewtypes], STEP 1 and it's sub-note
-    <Error Messages>.
-
-  * For unlifted datatypes, we must relax the assumed result kind to
-    (TYPE (BoxedRep l)) in the presence of a SAKS:
-
-      type D6 :: Type -> TYPE (BoxedRep Unlifted)
-      data D6 a = MkD6 a
-
-    Otherwise, it would be impossible to declare unlifted data types in H98
-    syntax (which doesn't allow specification of a result kind).
-
--}
-
----------------------------------
-getFamFlav
-  :: Maybe TcTyCon    -- ^ Just cls <=> this is an associated family of class cls
-  -> FamilyInfo pass
-  -> TyConFlavour
-getFamFlav mb_parent_tycon info =
-  case info of
-    DataFamily         -> DataFamilyFlavour mb_parent_tycon
-    OpenTypeFamily     -> OpenTypeFamilyFlavour mb_parent_tycon
-    ClosedTypeFamily _ -> assert (isNothing mb_parent_tycon) -- See Note [Closed type family mb_parent_tycon]
-                          ClosedTypeFamilyFlavour
-
-{- Note [Closed type family mb_parent_tycon]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There's no way to write a closed type family inside a class declaration:
-
-  class C a where
-    type family F a where  -- error: parse error on input ‘where’
-
-In fact, it is not clear what the meaning of such a declaration would be.
-Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing.
--}
-
-------------------------------------------------------------------------
-kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()
-  -- See Note [Kind checking for type and class decls]
-  -- Called only for declarations without a signature (no CUSKs or SAKs here)
-kcLTyClDecl (L loc decl)
-  = setSrcSpanA loc $
-    do { tycon <- tcLookupTcTyCon tc_name   -- Always a MonoTcTyCon
-       ; traceTc "kcTyClDecl {" (ppr tc_name)
-       ; addVDQNote tycon $   -- See Note [Inferring visible dependent quantification]
-         addErrCtxt (tcMkDeclCtxt decl) $
-         kcTyClDecl decl tycon
-       ; traceTc "kcTyClDecl done }" (ppr tc_name) }
-  where
-    tc_name = tcdName decl
-
-kcTyClDecl :: TyClDecl GhcRn -> MonoTcTyCon -> TcM ()
--- This function is used solely for its side effect on kind variables
--- NB kind signatures on the type variables and
---    result kind signature have already been dealt with
---    by inferInitialKind, so we can ignore them here.
-
--- NB these equations just extend the type environment with carefully constructed
--- TcTyVars rather than create skolemised variables for the bound variables.
--- - inferInitialKinds makes the TcTyCon where the  tyvars are TcTyVars
--- - In this function, those TcTyVars are unified with other kind variables during
---   kind inference (see [How TcTyCons work])
-
-kcTyClDecl (DataDecl { tcdLName    = (L _ _name), tcdDataDefn = HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } }) tycon
-  = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $
-       -- NB: binding these tyvars isn't necessary for GADTs, but it does no
-       -- harm.  For GADTs, each data con brings its own tyvars into scope,
-       -- and the ones from this bindTyClTyVars are either not mentioned or
-       -- (conceivably) shadowed.
-    do { traceTc "kcTyClDecl" (ppr tycon $$ ppr (tyConTyVars tycon) $$ ppr (tyConResKind tycon))
-       ; _ <- tcHsContext ctxt
-       ; kcConDecls (dataDefnConsNewOrData cons) (tyConResKind tycon) cons
-       }
-
-kcTyClDecl (SynDecl { tcdLName = L _ _name, tcdRhs = rhs }) tycon
-  = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $
-    let res_kind = tyConResKind tycon
-    in discardResult $ tcCheckLHsType rhs (TheKind res_kind)
-        -- NB: check against the result kind that we allocated
-        -- in inferInitialKinds.
-
-kcTyClDecl (ClassDecl { tcdLName = L _ _name
-                      , tcdCtxt = ctxt, tcdSigs = sigs }) tycon
-  = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $
-    do  { _ <- tcHsContext ctxt
-        ; mapM_ (wrapLocMA_ kc_sig) sigs }
-  where
-    kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType nms op_ty
-    kc_sig _                          = return ()
-
-kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo   = fd_info })) fam_tc
--- closed type families look at their equations, but other families don't
--- do anything here
-  = case fd_info of
-      ClosedTypeFamily (Just eqns) -> mapM_ (kcTyFamInstEqn fam_tc) eqns
-      _ -> return ()
-
--------------------
-
--- Kind-check the types of the arguments to a data constructor.
--- This includes doing kind unification if the type is a newtype.
--- See Note [Implementation of UnliftedNewtypes] for why we need
--- the first two arguments.
-kcConArgTys :: NewOrData -> TcKind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM ()
-kcConArgTys new_or_data res_kind arg_tys = do
-  { let exp_kind = getArgExpKind new_or_data res_kind
-  ; forM_ arg_tys (\(HsScaled mult ty) -> do _ <- tcCheckLHsType (getBangType ty) exp_kind
-                                             tcMult mult)
-    -- See Note [Implementation of UnliftedNewtypes], STEP 2
-  }
-
--- Kind-check the types of arguments to a Haskell98 data constructor.
-kcConH98Args :: NewOrData -> TcKind -> HsConDeclH98Details GhcRn -> TcM ()
-kcConH98Args new_or_data res_kind con_args = case con_args of
-  PrefixCon _ tys   -> kcConArgTys new_or_data res_kind tys
-  InfixCon ty1 ty2  -> kcConArgTys new_or_data res_kind [ty1, ty2]
-  RecCon (L _ flds) -> kcConArgTys new_or_data res_kind $
-                       map (hsLinear . cd_fld_type . unLoc) flds
-
--- Kind-check the types of arguments to a GADT data constructor.
-kcConGADTArgs :: NewOrData -> TcKind -> HsConDeclGADTDetails GhcRn -> TcM ()
-kcConGADTArgs new_or_data res_kind con_args = case con_args of
-  PrefixConGADT tys     ->   kcConArgTys new_or_data res_kind tys
-  RecConGADT (L _ flds) _ -> kcConArgTys new_or_data res_kind $
-                             map (hsLinear . cd_fld_type . unLoc) flds
-
-kcConDecls :: Foldable f
-           => NewOrData
-           -> TcKind             -- The result kind signature
-                               --   Used only in H98 case
-           -> f (LConDecl GhcRn) -- The data constructors
-           -> TcM ()
--- See Note [kcConDecls: kind-checking data type decls]
-kcConDecls new_or_data tc_res_kind = traverse_ (wrapLocMA_ (kcConDecl new_or_data tc_res_kind))
-
--- Kind check a data constructor. In additional to the data constructor,
--- we also need to know about whether or not its corresponding type was
--- declared with data or newtype, and we need to know the result kind of
--- this type. See Note [Implementation of UnliftedNewtypes] for why
--- we need the first two arguments.
-kcConDecl :: NewOrData
-          -> TcKind  -- Result kind of the type constructor
-                   -- Usually Type but can be TYPE UnliftedRep
-                   -- or even TYPE r, in the case of unlifted newtype
-                   -- Used only in H98 case
-          -> ConDecl GhcRn
-          -> TcM ()
-kcConDecl new_or_data tc_res_kind (ConDeclH98
-  { con_name = name, con_ex_tvs = ex_tvs
-  , con_mb_cxt = ex_ctxt, con_args = args })
-  = addErrCtxt (dataConCtxt (NE.singleton name)) $
-    discardResult                   $
-    bindExplicitTKBndrs_Tv ex_tvs $
-    do { _ <- tcHsContext ex_ctxt
-       ; kcConH98Args new_or_data tc_res_kind args
-         -- We don't need to check the telescope here,
-         -- because that's done in tcConDecl
-       }
-
-kcConDecl new_or_data
-          _tc_res_kind   -- Not used in GADT case (and doesn't make sense)
-          (ConDeclGADT
-    { con_names = names, con_bndrs = L _ outer_bndrs, con_mb_cxt = cxt
-    , con_g_args = args, con_res_ty = res_ty })
-  = -- See Note [kcConDecls: kind-checking data type decls]
-    addErrCtxt (dataConCtxt names) $
-    discardResult                      $
-    -- Not sure this is right, should just extend rather than skolemise but no test
-    bindOuterSigTKBndrs_Tv outer_bndrs $
-        -- Why "_Tv"?  See Note [Using TyVarTvs for kind-checking GADTs]
-    do { _ <- tcHsContext cxt
-       ; traceTc "kcConDecl:GADT {" (ppr names $$ ppr res_ty)
-       ; con_res_kind <- newOpenTypeKind
-       ; _ <- tcCheckLHsType res_ty (TheKind con_res_kind)
-       ; kcConGADTArgs new_or_data con_res_kind args
-       ; traceTc "kcConDecl:GADT }" (ppr names $$ ppr con_res_kind)
-       ; return () }
-
-{- Note [kcConDecls: kind-checking data type decls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-kcConDecls is used when we are inferring the kind of the type
-constructor in a data type declaration.  E.g.
-    data T f a = MkT (f a)
-we want to infer the kind of 'f' and 'a'. The basic plan is described
-in Note [Inferring kinds for type declarations]; here we are doing Step 2.
-
-In the GADT case we may have this:
-   data T f a where
-      MkT :: forall g b. g b -> T g b
-
-Notice that the variables f,a, and g,b are quite distinct.
-Nevertheless, the type signature for MkT must still influence the kind
-T which is (remember Step 1) something like
-  T :: kappa1 -> kappa2 -> Type
-Otherwise we'd infer the bogus kind
-  T :: forall k1 k2. k1 -> k2 -> Type.
-
-The type signature for MkT influences the kind of T simply by
-kind-checking the result type (T g b), which will force 'f' and 'g' to
-have the same kinds. This is the call to
-    tcCheckLHsType res_ty (TheKind con_res_kind)
-Because this is the result type of an arrow, we know the kind must be
-of form (TYPE rr), and we get better error messages if we enforce that
-here (e.g. test gadt10).
-
-For unlifted newtypes only, we must ensure that the argument kind
-and result kind are the same:
-* In the H98 case, we need the result kind of the TyCon, to unify with
-  the argument kind.
-
-* In GADT syntax, this unification happens via the result kind passed
-  to kcConGADTArgs. The tycon's result kind is not used at all in the
-  GADT case.
-
-Note [Using TyVarTvs for kind-checking GADTs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-  data Proxy a where
-    MkProxy1 :: forall k (b :: k). Proxy b
-    MkProxy2 :: forall j (c :: j). Proxy c
-
-It seems reasonable that this should be accepted. But something very strange
-is going on here: when we're kind-checking this declaration, we need to unify
-the kind of `a` with k and j -- even though k and j's scopes are local to the type of
-MkProxy{1,2}.
-
-In effect, we are simply gathering constraints on the shape of Proxy's
-kind, with no skolemisation or implication constraints involved at all.
-
-The best approach we've come up with is to use TyVarTvs during the
-kind-checking pass, rather than ordinary skolems. This is why we use
-the "_Tv" variant, bindOuterSigTKBndrs_Tv.
-
-Our only goal is to gather constraints on the kind of the type constructor;
-we do not certify that the data declaration is well-kinded. For example:
-
-  data SameKind :: k -> k -> Type
-  data Bad a where
-    MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b)
-
-which would be accepted by kcConDecl because k1 and k2 are
-TyVarTvs. It is correctly rejected in the second pass, tcConDecl.
-(Test case: polykinds/TyVarTvKinds3)
-
-One drawback of this approach is sometimes it will accept a definition that
-a (hypothetical) declarative specification would likely reject. As a general
-rule, we don't want to allow polymorphic recursion without a CUSK. Indeed,
-the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs
-approach allows a limited form of polymorphic recursion *without* a CUSK.
-
-To wit:
-  data T a = forall k (b :: k). MkT (T b) Int
-  (test case: dependent/should_compile/T14066a)
-
-Note that this is polymorphically recursive, with the recursive occurrence
-of T used at a kind other than a's kind. The approach outlined here accepts
-this definition, because this kind is still a kind variable (and so the
-TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a
-way to describe exactly what declarations will be accepted and which will
-be rejected (without a CUSK). However, the accepted definitions are indeed
-well-kinded and any rejected definitions would be accepted with a CUSK,
-and so this wrinkle need not cause anyone to lose sleep.
-
-Note [Recursion and promoting data constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We don't want to allow promotion in a strongly connected component
-when kind checking.
-
-Consider:
-  data T f = K (f (K Any))
-
-When kind checking the `data T' declaration the local env contains the
-mappings:
-  T -> ATcTyCon <some initial kind>
-  K -> APromotionErr
-
-APromotionErr is only used for DataCons, and only used during type checking
-in tcTyClGroup.
-
-The same restriction applies constructors in to "type data" declarations.
-See Note [Type data declarations] in GHC.Rename.Module.
-
-
-************************************************************************
-*                                                                      *
-\subsection{Type checking}
-*                                                                      *
-************************************************************************
-
-Note [Type checking recursive type and class declarations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-At this point we have completed *kind-checking* of a mutually
-recursive group of type/class decls (done in kcTyClGroup). However,
-we discarded the kind-checked types (eg RHSs of data type decls);
-note that kcTyClDecl returns ().  There are two reasons:
-
-  * It's convenient, because we don't have to rebuild a
-    kinded HsDecl (a fairly elaborate type)
-
-  * It's necessary, because after kind-generalisation, the
-    TyCons/Classes may now be kind-polymorphic, and hence need
-    to be given kind arguments.
-
-Example:
-       data T f a = MkT (f a) (T f a)
-During kind-checking, we give T the kind T :: k1 -> k2 -> *
-and figure out constraints on k1, k2 etc. Then we generalise
-to get   T :: forall k. (k->*) -> k -> *
-So now the (T f a) in the RHS must be elaborated to (T k f a).
-
-However, during tcTyClDecl of T (above) we will be in a recursive
-"knot". So we aren't allowed to look at the TyCon T itself; we are only
-allowed to put it (lazily) in the returned structures.  But when
-kind-checking the RHS of T's decl, we *do* need to know T's kind (so
-that we can correctly elaborate (T k f a).  How can we get T's kind
-without looking at T?  Delicate answer: during tcTyClDecl, we extend
-
-  *Global* env with T -> ATyCon (the (not yet built) final TyCon for T)
-  *Local*  env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T)
-
-Then:
-
-  * During GHC.Tc.Gen.HsType.tcTyVar we look in the *local* env, to get the
-    fully-known, not knot-tied TcTyCon for T.
-
-  * Then, in GHC.Tc.Utils.Zonk.zonkTcTypeToType (and zonkTcTyCon in particular)
-    we look in the *global* env to get the TyCon.
-
-This fancy footwork (with two bindings for T) is only necessary for the
-TyCons or Classes of this recursive group.  Earlier, finished groups,
-live in the global env only.
-
-See also Note [Kind checking recursive type and class declarations]
-
-Note [Kind checking recursive type and class declarations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Before we can type-check the decls, we must kind check them. This
-is done by establishing an "initial kind", which is a rather uninformed
-guess at a tycon's kind (by counting arguments, mainly) and then
-using this initial kind for recursive occurrences.
-
-The initial kind is stored in exactly the same way during
-kind-checking as it is during type-checking (Note [Type checking
-recursive type and class declarations]): in the *local* environment,
-with ATcTyCon. But we still must store *something* in the *global*
-environment. Even though we discard the result of kind-checking, we
-sometimes need to produce error messages. These error messages will
-want to refer to the tycons being checked, except that they don't
-exist yet, and it would be Terribly Annoying to get the error messages
-to refer back to HsSyn. So we create a TcTyCon and put it in the
-global env. This tycon can print out its name and knows its kind, but
-any other action taken on it will panic. Note that TcTyCons are *not*
-knot-tied, unlike the rather valid but knot-tied ones that occur
-during type-checking.
-
-Note [Declarations for wired-in things]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For wired-in things we simply ignore the declaration
-and take the wired-in information.  That avoids complications.
-e.g. the need to make the data constructor worker name for
-     a constraint tuple match the wired-in one
-
-Note [Datatype return kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are several poorly lit corners around datatype/newtype return kinds.
-This Note explains these.  We cover data/newtype families and instances
-in Note [Data family/instance return kinds].
-
-data    T a :: <kind> where ...   -- See Point DT4
-newtype T a :: <kind> where ...   -- See Point DT5
-
-DT1 Where this applies: Only GADT syntax for data/newtype/instance declarations
-    can have declared return kinds. This Note does not apply to Haskell98
-    syntax.
-
-DT2 Where these kinds come from: The return kind is part of the TyCon kind, gotten either
-     by checkInitialKind (standalone kind signature / CUSK) or
-     inferInitialKind. It is extracted by bindTyClTyVars in tcTyClDecl1. It is
-     then passed to tcDataDefn.
-
-DT3 Eta-expansion: Any forall-bound variables and function arguments in a result kind
-    become parameters to the type. That is, when we say
-
-     data T a :: Type -> Type where ...
-
-    we really mean for T to have two parameters. The second parameter
-    is produced by processing the return kind in etaExpandAlgTyCon,
-    called in tcDataDefn.
-
-    See also Note [splitTyConKind] in GHC.Tc.Gen.HsType.
-
-DT4 Datatype return kind restriction: A data type return kind must end
-    in a type that, after type-synonym expansion, yields `TYPE LiftedRep`. By
-    "end in", we mean we strip any foralls and function arguments off before
-    checking.
-
-    Examples:
-      data T1 :: Type                          -- good
-      data T2 :: Bool -> Type                  -- good
-      data T3 :: Bool -> forall k. Type        -- strange, but still accepted
-      data T4 :: forall k. k -> Type           -- good
-      data T5 :: Bool                          -- bad
-      data T6 :: Type -> Bool                  -- bad
-
-    Exactly the same applies to data instance (but not data family)
-    declarations.  Examples
-      data instance D1 :: Type                 -- good
-      data instance D2 :: Bool -> Type         -- good
-
-    We can "look through" type synonyms
-      type Star = Type
-      data T7 :: Bool -> Star                  -- good (synonym expansion ok)
-      type Arrow = (->)
-      data T8 :: Arrow Bool Type               -- good (ditto)
-
-    But we specifically do *not* do type family reduction here.
-      type family ARROW where
-        ARROW = (->)
-      data T9 :: ARROW Bool Type               -- bad
-
-      type family F a where
-        F Int  = Bool
-        F Bool = Type
-      data T10 :: Bool -> F Bool               -- bad
-
-    The /principle/ here is that in the TyCon for a data type or data instance,
-    we must be able to lay out all the type-variable binders, one by one, until
-    we reach (TYPE xx).  There is no place for a cast here.  We could add one,
-    but let's not!
-
-    This check is done in checkDataKindSig. For data declarations, this
-    call is in tcDataDefn; for data instances, this call is in tcDataFamInstDecl.
-
-DT5 Newtype return kind restriction.
-    If -XUnliftedNewtypes is not on, then newtypes are treated just
-    like datatypes --- see (4) above.
-
-    If -XUnliftedNewtypes is on, then a newtype return kind must end in
-    TYPE xyz, for some xyz (after type synonym expansion). The "xyz"
-    may include type families, but the TYPE part must be visible
-    /without/ expanding type families (only synonyms).
-
-    This kind is unified with the kind of the representation type (the
-    type of the one argument to the one constructor). See also steps
-    (2) and (3) of Note [Implementation of UnliftedNewtypes].
-
-    The checks are done in the same places as for datatypes.
-    Examples (assume -XUnliftedNewtypes):
-
-      newtype N1 :: Type                       -- good
-      newtype N2 :: Bool -> Type               -- good
-      newtype N3 :: forall r. Bool -> TYPE r   -- good
-
-      type family F (t :: Type) :: RuntimeRep
-      newtype N4 :: forall t -> TYPE (F t)     -- good
-
-      type family STAR where
-        STAR = Type
-      newtype N5 :: Bool -> STAR               -- bad
-
-Note [Data family/instance return kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Within this note, understand "instance" to mean data or newtype
-instance, and understand "family" to mean data family. No type
-families or classes here. Some examples:
-
-data family T a :: <kind>          -- See Point DF56
-
-data    instance T [a] :: <kind> where ...   -- See Point DF2
-newtype instance T [a] :: <kind> where ...   -- See Point DF2
-
-Here is the Plan for Data Families:
-
-DF0 Where these kinds come from:
-
-    Families: The return kind is either written in a standalone signature
-     or extracted from a family declaration in getInitialKind.
-     If a family declaration is missing a result kind, it is assumed to be
-     Type. This assumption is in getInitialKind for CUSKs or
-     get_fam_decl_initial_kind for non-signature & non-CUSK cases.
-
-   Instances: The data family already has a known kind. The return kind
-     of an instance is then calculated by applying the data family tycon
-     to the patterns provided, as computed by the typeKind lhs_ty in the
-     end of tcDataFamInstHeader. In the case of an instance written in GADT
-     syntax, there are potentially *two* return kinds: the one computed from
-     applying the data family tycon to the patterns, and the one given by
-     the user. This second kind is checked by the tc_kind_sig function within
-     tcDataFamInstHeader. See also DF3, below.
-
-DF1 In a data/newtype instance, we treat the kind of the /data family/,
-    once instantiated, as the "master kind" for the representation
-    TyCon.  For example:
-        data family T1 :: Type -> Type -> Type
-        data instance T1 Int :: F Bool -> Type where ...
-    The "master kind" for the representation TyCon R:T1Int comes
-    from T1, not from the signature on the data instance.  It is as
-    if we declared
-        data R:T1Int :: Type -> Type where ...
-     See Note [Liberalising data family return kinds] for an alternative
-     plan.  But this current plan is simple, and ensures that all instances
-     are simple instantiations of the master, without strange casts.
-
-     An example with non-trivial instantiation:
-        data family T2 :: forall k. Type -> k
-        data instance T2 :: Type -> Type -> Type where ...
-     Here 'k' gets instantiated with (Type -> Type), driven by
-     the signature on the 'data instance'. (See also DT3 of
-     Note [Datatype return kinds] about eta-expansion, which applies here,
-     too; see tcDataFamInstDecl's call of etaExpandAlgTyCon.)
-
-     A newtype example:
-
-       data Color = Red | Blue
-       type family Interpret (x :: Color) :: RuntimeRep where
-         Interpret 'Red = 'IntRep
-         Interpret 'Blue = 'WordRep
-       data family Foo (x :: Color) :: TYPE (Interpret x)
-       newtype instance Foo 'Red :: TYPE IntRep where
-         FooRedC :: Int# -> Foo 'Red
-
-    Here we get that Foo 'Red :: TYPE (Interpret Red), and our
-    representation newtype looks like
-         newtype R:FooRed :: TYPE (Interpret Red) where
-            FooRedC :: Int# -> R:FooRed
-    Remember: the master kind comes from the /family/ tycon.
-
-DF2 /After/ this instantiation, the return kind of the master kind
-    must obey the usual rules for data/newtype return kinds (DT4, DT5)
-    of Note [Datatype return kinds].  Examples:
-        data family T3 k :: k
-        data instance T3 Type where ...          -- OK
-        data instance T3 (Type->Type) where ...  -- OK
-        data instance T3 (F Int) where ...       -- Not OK
-
-DF3 Any kind signatures on the data/newtype instance are checked for
-    equality with the master kind (and hence may guide instantiation)
-    but are otherwise ignored. So in the T1 example above, we check
-    that (F Int ~ Type) by unification; but otherwise ignore the
-    user-supplied signature from the /family/ not the /instance/.
-
-    We must be sure to instantiate any trailing invisible binders
-    before doing this unification.  See the call to tcInstInvisibleBinders
-    in tcDataFamInstHeader. For example:
-       data family D :: forall k. k
-       data instance D :: Type               -- forall k. k   <:  Type
-       data instance D :: Type -> Type       -- forall k. k   <:  Type -> Type
-         -- NB: these do not overlap
-    we must instantiate D before unifying with the signature in the
-    data instance declaration
-
-DF4 We also (redundantly) check that any user-specified return kind
-    signature in the data instance also obeys DT4/DT5.  For example we
-    reject
-        data family T1 :: Type -> Type -> Type
-        data instance T1 Int :: Type -> F Int
-    even if (F Int ~ Type).  We could omit this check, because we
-    use the master kind; but it seems more uniform to check it, again
-    with checkDataKindSig.
-
-DF5 Data /family/ return kind restrictions. Consider
-       data family D8 a :: F a
-    where F is a type family.  No data/newtype instance can instantiate
-    this so that it obeys the rules of DT4 or DT5.  So GHC proactively
-    rejects the data /family/ declaration if it can never satisfy (DT4)/(DT5).
-    Remember that a data family supports both data and newtype instances.
-
-    More precisely, the return kind of a data family must be either
-        * TYPE xyz (for some type xyz) or
-        * a kind variable
-    Only in these cases can a data/newtype instance possibly satisfy (DT4)/(DT5).
-    This is checked by the call to checkDataKindSig in tcFamDecl1.  Examples:
-
-      data family D1 :: Type              -- good
-      data family D2 :: Bool -> Type      -- good
-      data family D3 k :: k               -- good
-      data family D4 :: forall k -> k     -- good
-      data family D5 :: forall k. k -> k  -- good
-      data family D6 :: forall r. TYPE r  -- good
-      data family D7 :: Bool -> STAR      -- bad (see STAR from point 5)
-
-DF6 Two return kinds for instances: If an instance has two return kinds,
-    one from the family declaration and one from the instance declaration
-    (see point DF3 above), they are unified. More accurately, we make sure
-    that the kind of the applied data family is a subkind of the user-written
-    kind. GHC.Tc.Gen.HsType.checkExpectedKind normally does this check for types, but
-    that's overkill for our needs here. Instead, we just instantiate any
-    invisible binders in the (instantiated) kind of the data family
-    (called lhs_kind in tcDataFamInstHeader) with tcInstInvisibleTyBinders
-    and then unify the resulting kind with the kind written by the user.
-    This unification naturally produces a coercion, which we can drop, as
-    the kind annotation on the instance is redundant (except perhaps for
-    effects of unification).
-
-    This all is Wrinkle (3) in Note [Implementation of UnliftedNewtypes].
-
-Note [Liberalising data family return kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Could we allow this?
-   type family F a where { F Int = Type }
-   data family T a :: F a
-   data instance T Int where
-      MkT :: T Int
-
-In the 'data instance', T Int :: F Int, and F Int = Type, so all seems
-well.  But there are lots of complications:
-
-* The representation constructor R:TInt presumably has kind Type.
-  So the axiom connecting the two would have to look like
-       axTInt :: T Int ~ R:TInt |> sym axFInt
-  and that doesn't match expectation in DataFamInstTyCon
-  in AlgTyConFlav
-
-* The wrapper can't have type
-     $WMkT :: Int -> T Int
-  because T Int has the wrong kind.  It would have to be
-     $WMkT :: Int -> (T Int) |> axFInt
-
-* The code for $WMkT would also be more complicated, needing
-  two coherence coercions. Try it!
-
-* Code for pattern matching would be complicated in an
-  exactly dual way.
-
-So yes, we could allow this, but we currently do not. That's
-why we have DF2 in Note [Data family/instance return kinds].
-
-Note [Implementation of UnliftedNewtypes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Expected behavior of UnliftedNewtypes:
-
-* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0013-unlifted-newtypes.rst
-* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/98
-
-What follows is a high-level overview of the implementation of the
-proposal.
-
-STEP 1: Getting the initial kind, as done by inferInitialKind. We have
-two sub-cases:
-
-* With a SAK/CUSK: no change in kind-checking; the tycon is given the kind
-  the user writes, whatever it may be.
-
-* Without a SAK/CUSK: If there is no kind signature, the tycon is given
-  a kind `TYPE r`, for a fresh unification variable `r`. We do this even
-  when -XUnliftedNewtypes is not on; see <Error Messages>, below.
-
-STEP 2: Kind-checking, as done by kcTyClDecl. This step is skipped for CUSKs.
-The key function here is kcConDecl, which looks at an individual constructor
-declaration. When we are processing a newtype (but whether or not -XUnliftedNewtypes
-is enabled; see <Error Messages>, below), we generate a correct ContextKind
-for the checking argument types: see getArgExpKind.
-
-Examples of newtypes affected by STEP 2, assuming -XUnliftedNewtypes is
-enabled (we use r0 to denote a unification variable):
-
-newtype Foo rep = MkFoo (forall (a :: TYPE rep). a)
-+ kcConDecl unifies (TYPE r0) with (TYPE rep), where (TYPE r0)
-  is the kind that inferInitialKind invented for (Foo rep).
-
-data Color = Red | Blue
-type family Interpret (x :: Color) :: RuntimeRep where
-  Interpret 'Red = 'IntRep
-  Interpret 'Blue = 'WordRep
-data family Foo (x :: Color) :: TYPE (Interpret x)
-newtype instance Foo 'Red = FooRedC Int#
-+ kcConDecl unifies TYPE (Interpret 'Red) with TYPE 'IntRep
-
-Note that, in the GADT case, we might have a kind signature with arrows
-(newtype XYZ a b :: Type -> Type where ...). We want only the final
-component of the kind for checking in kcConDecl, so we call etaExpanAlgTyCon
-in kcTyClDecl.
-
-STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function
-here is tcConDecl. Once again, we must use getArgExpKind to ensure that the
-representation type's kind matches that of the newtype, for two reasons:
-
-  A. It is possible that a GADT has a CUSK. (Note that this is *not*
-     possible for H98 types.) Recall that CUSK types don't go through
-     kcTyClDecl, so we might not have done this kind check.
-  B. We need to produce the coercion to put on the argument type
-     if the kinds are different (for both H98 and GADT).
-
-Example of (B):
-
-type family F a where
-  F Int = LiftedRep
-
-newtype N :: TYPE (F Int) where
-  MkN :: Int -> N
-
-We really need to have the argument to MkN be (Int |> TYPE (sym axF)), where
-axF :: F Int ~ LiftedRep. That way, the argument kind is the same as the
-newtype kind, which is the principal correctness condition for newtypes.
-
-Wrinkle: Consider (#17021, typecheck/should_fail/T17021)
-
-    type family Id (x :: a) :: a where
-      Id x = x
-
-    newtype T :: TYPE (Id LiftedRep) where
-      MkT :: Int -> T
-
-  In the type of MkT, we must end with (Int |> TYPE (sym axId)) -> T,
-  never Int -> (T |> TYPE axId); otherwise, the result type of the
-  constructor wouldn't match the datatype. However, type-checking the
-  HsType T might reasonably result in (T |> hole). We thus must ensure
-  that this cast is dropped, forcing the type-checker to add one to
-  the Int instead.
-
-  Why is it always safe to drop the cast? This result type is type-checked by
-  tcHsOpenType, so its kind definitely looks like TYPE r, for some r. It is
-  important that even after dropping the cast, the type's kind has the form
-  TYPE r. This is guaranteed by restrictions on the kinds of datatypes.
-  For example, a declaration like `newtype T :: Id Type` is rejected: a
-  newtype's final kind always has the form TYPE r, just as we want.
-
-Note that this is possible in the H98 case only for a data family, because
-the H98 syntax doesn't permit a kind signature on the newtype itself.
-
-There are also some changes for dealing with families:
-
-1. In tcFamDecl1, we suppress a tcIsLiftedTypeKind check if
-   UnliftedNewtypes is on. This allows us to write things like:
-     data family Foo :: TYPE 'IntRep
-
-2. In a newtype instance (with -XUnliftedNewtypes), if the user does
-   not write a kind signature, we want to allow the possibility that
-   the kind is not Type, so we use newOpenTypeKind instead of liftedTypeKind.
-   This is done in tcDataFamInstHeader in GHC.Tc.TyCl.Instance. Example:
-
-       data family Bar (a :: RuntimeRep) :: TYPE a
-       newtype instance Bar 'IntRep = BarIntC Int#
-       newtype instance Bar 'WordRep :: TYPE 'WordRep where
-         BarWordC :: Word# -> Bar 'WordRep
-
-   The data instance corresponding to IntRep does not specify a kind signature,
-   so tc_kind_sig just returns `TYPE r0` (where `r0` is a fresh metavariable).
-   The data instance corresponding to WordRep does have a kind signature, so
-   we use that kind signature.
-
-3. A data family and its newtype instance may be declared with slightly
-   different kinds. See point DF6 in Note [Data family/instance return kinds]
-
-There's also a change in the renamer:
-
-* In GHC.RenameSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means
-  for a newtype to have a CUSK. This is necessary since UnliftedNewtypes
-  means that, for newtypes without kind signatures, we must use the field
-  inside the data constructor to determine the result kind.
-  See Note [Unlifted Newtypes and CUSKs] for more detail.
-
-For completeness, it was also necessary to make coerce work on
-unlifted types, resolving #13595.
-
-<Error Messages>: It's tempting to think that the expected kind for a newtype
-constructor argument when -XUnliftedNewtypes is *not* enabled should just be Type.
-But this leads to difficulty in suggesting to enable UnliftedNewtypes. Here is
-an example:
-
-  newtype A = MkA Int#
-
-If we expect the argument to MkA to have kind Type, then we get a kind-mismatch
-error. The problem is that there is no way to connect this mismatch error to
--XUnliftedNewtypes, and suggest enabling the extension. So, instead, we allow
-the A to type-check, but then find the problem when doing validity checking (and
-where we get make a suitable error message). One potential worry is
-
-  {-# LANGUAGE PolyKinds #-}
-  newtype B a = MkB a
-
-This turns out OK, because unconstrained RuntimeReps default to LiftedRep, just
-as we would like. Another potential problem comes in a case like
-
-  -- no UnliftedNewtypes
-
-  data family D :: k
-  newtype instance D = MkD Any
-
-Here, we want inference to tell us that k should be instantiated to Type in
-the instance. With the approach described here (checking for Type only in
-the validity checker), that will not happen. But I cannot think of a non-contrived
-example that will notice this lack of inference, so it seems better to improve
-error messages than be able to infer this instantiation.
-
-Note [Implementation of UnliftedDatatypes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Expected behavior of UnliftedDatatypes:
-
-* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0265-unlifted-datatypes.rst
-* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/265
-
-The implementation heavily leans on Note [Implementation of UnliftedNewtypes].
-
-In the frontend, the following tweaks have been made in the typechecker:
-
-* STEP 1: In the inferInitialKinds phase, newExpectedKind gives data type
-  constructors a result kind of `TYPE r` with a fresh unification variable
-  `r :: RuntimeRep` when there is a SAKS. (Same as for UnliftedNewtypes.)
-  Not needed with a CUSK, because it can't specify result kinds.
-  If there's a GADTSyntax result kind signature, we keep on using that kind.
-
-  Similarly, for data instances without a kind signature, we use
-  `TYPE r` as the result kind, to support the following code:
-
-    data family F a :: UnliftedType
-    data instance F Int = TInt
-
-  The omission of a kind signature for `F` should not mean a result kind
-  of `Type` (and thus a kind error) here.
-
-* STEP 2: No change to kcTyClDecl.
-
-* STEP 3: In GHC.Tc.Gen.HsType.checkDataKindSig, we make sure that the result
-  kind of the data declaration is actually `Type` or `TYPE (BoxedRep l)`,
-  for some `l`. If UnliftedDatatypes is not activated, we emit an error with a
-  suggestion in the latter case.
-
-  Why not start out with `TYPE (BoxedRep l)` in the first place? Because then
-  we get worse kind error messages in e.g. saks_fail010:
-
-     -     Couldn't match expected kind: TYPE ('GHC.Types.BoxedRep t0)
-     -                  with actual kind: * -> *
-     +     Expected a type, but found something with kind ‘* -> *’
-           In the data type declaration for ‘T’
-
-  It seems `TYPE r` already has appropriate pretty-printing support.
-
-The changes to Core, STG and Cmm are of rather cosmetic nature.
-The IRs are already well-equipped to handle unlifted types, and unlifted
-datatypes are just a new sub-class thereof.
--}
-
-tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])
-tcTyClDecl roles_info (L loc decl)
-  | Just thing <- wiredInNameTyThing_maybe (tcdName decl)
-  = case thing of -- See Note [Declarations for wired-in things]
-      ATyCon tc -> return (tc, wiredInDerivInfo tc decl)
-      _ -> pprPanic "tcTyClDecl" (ppr thing)
-
-  | otherwise
-  = setSrcSpanA loc $ tcAddDeclCtxt decl $
-    do { traceTc "---- tcTyClDecl ---- {" (ppr decl)
-       ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl
-       ; traceTc "---- tcTyClDecl end ---- }" (ppr tc)
-       ; return (tc, deriv_infos) }
-
-noDerivInfos :: a -> (a, [DerivInfo])
-noDerivInfos a = (a, [])
-
-wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo]
-wiredInDerivInfo tycon decl
-  | DataDecl { tcdDataDefn = dataDefn } <- decl
-  , HsDataDefn { dd_derivs = derivs } <- dataDefn
-  = [ DerivInfo { di_rep_tc = tycon
-                , di_scoped_tvs =
-                    if isPrimTyCon tycon
-                       then []  -- no tyConTyVars
-                       else mkTyVarNamePairs (tyConTyVars tycon)
-                , di_clauses = derivs
-                , di_ctxt = tcMkDeclCtxt decl } ]
-wiredInDerivInfo _ _ = []
-
-  -- "type family" declarations
-tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo])
-tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd })
-  = fmap noDerivInfos $
-    tcFamDecl1 parent fd
-
-  -- "type" synonym declaration
-tcTyClDecl1 _parent roles_info
-            (SynDecl { tcdLName = L _ tc_name
-                     , tcdRhs   = rhs })
-  = assert (isNothing _parent )
-    fmap noDerivInfos $
-    tcTySynRhs roles_info tc_name rhs
-
-  -- "data/newtype" declaration
-tcTyClDecl1 _parent roles_info
-            decl@(DataDecl { tcdLName = L _ tc_name
-                           , tcdDataDefn = defn })
-  = assert (isNothing _parent) $
-    tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn
-
-tcTyClDecl1 _parent roles_info
-            (ClassDecl { tcdLName = L _ class_name
-                       , tcdCtxt = hs_ctxt
-                       , tcdMeths = meths
-                       , tcdFDs = fundeps
-                       , tcdSigs = sigs
-                       , tcdATs = ats
-                       , tcdATDefs = at_defs })
-  = assert (isNothing _parent) $
-    do { clas <- tcClassDecl1 roles_info class_name hs_ctxt
-                              meths fundeps sigs ats at_defs
-       ; return (noDerivInfos (classTyCon clas)) }
-
-
-{- *********************************************************************
-*                                                                      *
-          Class declarations
-*                                                                      *
-********************************************************************* -}
-
-tcClassDecl1 :: RolesInfo -> Name -> Maybe (LHsContext GhcRn)
-             -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn]
-             -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn]
-             -> TcM Class
-tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs
-  = fixM $ \ clas -> -- We need the knot because 'clas' is passed into tcClassATs
-    bindTyClTyVars class_name $ \ tc_bndrs res_kind ->
-    do { checkClassKindSig res_kind
-       ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr tc_bndrs)
-       ; let tycon_name = class_name        -- We use the same name
-             roles = roles_info tycon_name  -- for TyCon and Class
-
-       ; (ctxt, fds, sig_stuff, at_stuff)
-            <- pushLevelAndSolveEqualities skol_info tc_bndrs $
-               -- The (binderVars tc_bndrs) is needed bring into scope the
-               -- skolems bound by the class decl header (#17841)
-               do { ctxt <- tcHsContext hs_ctxt
-                  ; fds  <- mapM (addLocMA tc_fundep) fundeps
-                  ; sig_stuff <- tcClassSigs class_name sigs meths
-                  ; at_stuff  <- tcClassATs class_name clas ats at_defs
-                  ; return (ctxt, fds, sig_stuff, at_stuff) }
-
-       -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType
-       -- Example: (typecheck/should_fail/T17562)
-       --   type C :: Type -> Type -> Constraint
-       --   class (forall a. a b ~ a c) => C b c
-       -- The kind of `a` is unconstrained.
-       ; dvs <- candidateQTyVarsOfTypes ctxt
-       ; let mk_doc tidy_env = do { (tidy_env2, ctxt) <- zonkTidyTcTypes tidy_env ctxt
-                                  ; return ( tidy_env2
-                                           , sep [ text "the class context:"
-                                                 , pprTheta ctxt ] ) }
-       ; doNotQuantifyTyVars dvs mk_doc
-
-       -- The pushLevelAndSolveEqualities will report errors for any
-       -- unsolved equalities, so these zonks should not encounter
-       -- any unfilled coercion variables unless there is such an error
-       -- The zonk also squeeze out the TcTyCons, and converts
-       -- Skolems to tyvars.
-       ; ze          <- mkEmptyZonkEnv NoFlexi
-       ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs  -- From TcTyVars to TyVars
-       ; ctxt        <- zonkTcTypesToTypesX ze ctxt
-       ; sig_stuff   <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff
-         -- ToDo: do we need to zonk at_stuff?
-
-       -- TODO: Allow us to distinguish between abstract class,
-       -- and concrete class with no methods (maybe by
-       -- specifying a trailing where or not
-
-       ; mindef <- tcClassMinimalDef class_name sigs sig_stuff
-       ; is_boot <- tcIsHsBootOrSig
-       ; let body | is_boot, isNothing hs_ctxt, null at_stuff, null sig_stuff
-                  -- We use @isNothing hs_ctxt@ rather than @null ctxt@,
-                  -- so that a declaration in an hs-boot file such as:
-                  --
-                  -- class () => C a b | a -> b
-                  --
-                  -- is not considered abstract; it's sometimes useful
-                  -- to be able to declare such empty classes in hs-boot files.
-                  -- See #20661.
-                  = Nothing
-                  | otherwise
-                  = Just (ctxt, at_stuff, sig_stuff, mindef)
-
-       ; clas <- buildClass class_name bndrs roles fds body
-       ; traceTc "tcClassDecl" (ppr fundeps $$ ppr bndrs $$
-                                ppr fds)
-       ; return clas }
-  where
-    skol_info = TyConSkol ClassFlavour class_name
-
-    tc_fundep :: GHC.Hs.FunDep GhcRn -> TcM ([Var],[Var])
-    tc_fundep (FunDep _ tvs1 tvs2)
-                           = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;
-                                ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ;
-                                ; return (tvs1',tvs2') }
-
-
-{- Note [Associated type defaults]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-The following is an example of associated type defaults:
-             class C a where
-               data D a
-
-               type F a b :: *
-               type F a b = [a]        -- Default
-
-Note that we can get default definitions only for type families, not data
-families.
--}
-
-tcClassATs :: Name                    -- The class name (not knot-tied)
-           -> Class                   -- The class parent of this associated type
-           -> [LFamilyDecl GhcRn]     -- Associated types.
-           -> [LTyFamDefltDecl GhcRn] -- Associated type defaults.
-           -> TcM [ClassATItem]
-tcClassATs class_name cls ats at_defs
-  = do {  -- Complain about associated type defaults for non associated-types
-         sequence_ [ failWithTc (TcRnBadAssociatedType class_name n)
-                   | n <- map at_def_tycon at_defs
-                   , not (n `elemNameSet` at_names) ]
-       ; mapM tc_at ats }
-  where
-    at_def_tycon :: LTyFamDefltDecl GhcRn -> Name
-    at_def_tycon = tyFamInstDeclName . unLoc
-
-    at_fam_name :: LFamilyDecl GhcRn -> Name
-    at_fam_name = familyDeclName . unLoc
-
-    at_names = mkNameSet (map at_fam_name ats)
-
-    at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn]
-    -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs'
-    at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv
-                                          (at_def_tycon at_def) [at_def])
-                        emptyNameEnv at_defs
-
-    tc_at at = do { fam_tc <- addLocMA (tcFamDecl1 (Just cls)) at
-                  ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)
-                                  `orElse` []
-                  ; atd <- tcDefaultAssocDecl fam_tc at_defs
-                  ; return (ATI fam_tc atd) }
-
--------------------------
-tcDefaultAssocDecl ::
-     TyCon                                       -- ^ Family TyCon (not knot-tied)
-  -> [LTyFamDefltDecl GhcRn]                     -- ^ Defaults
-  -> TcM (Maybe (KnotTied Type, ATValidityInfo)) -- ^ Type checked RHS
-tcDefaultAssocDecl _ []
-  = return Nothing  -- No default declaration
-
-tcDefaultAssocDecl _ (d1:_:_)
-  = failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints $
-                text "More than one default declaration for"
-                <+> ppr (tyFamInstDeclName (unLoc d1)))
-
-tcDefaultAssocDecl fam_tc
-  [L loc (TyFamInstDecl { tfid_eqn =
-                            FamEqn { feqn_tycon = L _ tc_name
-                                   , feqn_bndrs = outer_bndrs
-                                   , feqn_pats  = hs_pats
-                                   , feqn_rhs   = hs_rhs_ty }})]
-  = -- See Note [Type-checking default assoc decls]
-    setSrcSpanA loc $
-    tcAddFamInstCtxt (text "default type instance") tc_name $
-    do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name)
-       ; let fam_tc_name = tyConName fam_tc
-             vis_arity = length (tyConVisibleTyVars fam_tc)
-             vis_pats  = numVisibleArgs hs_pats
-
-       -- Kind of family check
-       ; assert (fam_tc_name == tc_name) $
-         checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
-
-       -- Arity check
-       ; checkTc (vis_pats == vis_arity)
-                 (wrongNumberOfParmsErr vis_arity)
-
-       -- Typecheck RHS
-       --
-       -- You might think we should pass in some AssocInstInfo, as we're looking
-       -- at an associated type. But this would be wrong, because an associated
-       -- type default LHS can mention *different* type variables than the
-       -- enclosing class. So it's treated more as a freestanding beast.
-       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated
-                                      outer_bndrs hs_pats hs_rhs_ty
-
-       ; let fam_tvs = tyConTyVars fam_tc
-       ; traceTc "tcDefaultAssocDecl 2" (vcat
-           [ text "hs_pats"   <+> ppr hs_pats
-           , text "hs_rhs_ty" <+> ppr hs_rhs_ty
-           , text "fam_tvs" <+> ppr fam_tvs
-           , text "qtvs"    <+> ppr qtvs
-             -- NB: Do *not* print `pats` or rhs_ty here, as they can mention
-             -- knot-tied TyCons. See #18648.
-           ])
-       ; let subst = case traverse getTyVar_maybe pats of
-                       Just cpt_tvs -> zipTvSubst cpt_tvs (mkTyVarTys fam_tvs)
-                       Nothing      -> emptySubst
-                       -- The Nothing case can only be reached in invalid
-                       -- associated type family defaults. In such cases, we
-                       -- simply create an empty substitution and let GHC fall
-                       -- over later, in GHC.Tc.Validity.checkValidAssocTyFamDeflt.
-                       -- See Note [Type-checking default assoc decls].
-       ; pure $ Just (substTyUnchecked subst rhs_ty, ATVI (locA loc) pats)
-           -- We perform checks for well-formedness and validity later, in
-           -- GHC.Tc.Validity.checkValidAssocTyFamDeflt.
-     }
-
-{- Note [Type-checking default assoc decls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this default declaration for an associated type
-
-   class C a where
-      type F (a :: k) b :: Type
-      type F (x :: j) y = Proxy x -> y
-
-Note that the class variable 'a' doesn't scope over the default assoc
-decl, nor do the type variables `k` and `b`. Instead, the default decl is
-treated more like a top-level type instance. However, we store the default rhs
-(Proxy x -> y) in F's TyCon, using F's own type variables, so we need to
-convert it to (Proxy a -> b). We do this in the tcDefaultAssocDecl function by
-creating a substitution [j |-> k, x |-> a, b |-> y] and applying this
-substitution to the RHS.
-
-In order to create this substitution, we must first ensure that all of
-the arguments in the default instance consist of distinct type variables.
-Checking for this property proves surprisingly tricky. Three potential places
-where GHC could check for this property include:
-
-1. Before typechecking (in the parser or renamer)
-2. During typechecking (in tcDefaultAssocDecl)
-3. After typechecking (using GHC.Tc.Validity)
-
-Currently, GHC picks option (3) and implements this check using
-GHC.Tc.Validity.checkValidAssocTyFamDeflt. GHC previously used options (1) and
-(2), but neither option quite worked out for reasons that we will explain
-shortly.
-
-The first thing that checkValidAssocTyFamDeflt does is check that all arguments
-in an associated type family default are type variables. As a motivating
-example, consider this erroneous program (inspired by #11361):
-
-   class C a where
-      type F (a :: k) b :: Type
-      type F x        b = x
-
-If you squint, you'll notice that the kind of `x` is actually Type. However,
-we cannot substitute from [Type |-> k], so we reject this default. This also
-explains why GHC no longer implements option (1) above, since figuring out that
-`x`'s kind is Type would be much more difficult without the knowledge that the
-typechecker provides.
-
-Next, checkValidAssocTyFamDeflt checks that all arguments are distinct. Here is
-another offending example, this time taken from #13971:
-
-   class C2 (a :: j) where
-      type F2 (a :: j) (b :: k)
-      type F2 (x :: z) y = SameKind x y
-   data SameKind :: k -> k -> Type
-
-All of the arguments in the default equation for `F2` are type variables, so
-that passes the first check. However, if we were to build this substitution,
-then both `j` and `k` map to `z`! In terms of visible kind application, it's as
-if we had written `type F2 @z @z x y = SameKind @z x y`, which makes it clear
-that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is
-also rejected.
-
-There is one more design consideration in play here: what error message should
-checkValidAssocTyFamDeflt produce if one of its checks fails? Ideally, it would
-be something like this:
-
-  Illegal duplicate variable ‘z’ in:
-    ‘type F2 @z @z x y = ...’
-    The arguments to ‘F2’ must all be distinct type variables
-
-This requires printing out the arguments to the associated type family. This
-can be dangerous, however. Consider this example, adapted from #18648:
-
-  class C3 a where
-     type F3 a
-     type F3 (F3 a) = a
-
-F3's default is illegal, since its argument is not a bare type variable. But
-note that when we typecheck F3's default, the F3 type constructor is knot-tied.
-Therefore, if we print the type `F3 a` in an error message, GHC will diverge!
-This is the reason why GHC no longer implements option (2) above and instead
-waits until /after/ typechecking has finished, at which point the typechecker
-knot has been worked out.
-
-As one final point, one might worry that the typechecker knot could cause the
-substitution that tcDefaultAssocDecl creates to diverge, but this is not the
-case. Since the LHS of a valid associated type family default is always just
-variables, it won't contain any tycons. Accordingly, the patterns used in the
-substitution won't actually be knot-tied, even though we're in the knot. (This
-is too delicate for my taste, but it works.) If we're dealing with /invalid/
-default, such as F3's above, then we simply create an empty substitution and
-rely on checkValidAssocTyFamDeflt throwing an error message afterwards before
-any damage is done.
--}
-
-{- *********************************************************************
-*                                                                      *
-          Type family declarations
-*                                                                      *
-********************************************************************* -}
-
-tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon
-tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info
-                              , fdLName = tc_lname@(L _ tc_name)
-                              , fdResultSig = L _ sig
-                              , fdInjectivityAnn = inj })
-  | DataFamily <- fam_info
-  = bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> do
-  { traceTc "tcFamDecl1 data family:" (ppr tc_name)
-  ; checkFamFlag tc_name
-
-  -- Check that the result kind is OK
-  -- We allow things like
-  --   data family T (a :: Type) :: forall k. k -> Type
-  -- We treat T as having arity 1, but result kind forall k. k -> Type
-  -- But we want to check that the result kind finishes in
-  --   Type or a kind-variable
-  -- For the latter, consider
-  --   data family D a :: forall k. Type -> k
-  -- When UnliftedNewtypes is enabled, we loosen this restriction
-  -- on the return kind. See Note [Implementation of UnliftedNewtypes], wrinkle (1).
-  -- See also Note [Datatype return kinds]
-  ; checkDataKindSig DataFamilySort res_kind
-  ; tc_rep_name <- newTyConRepName tc_name
-  ; let inj   = Injective $ replicate (length tc_bndrs) True
-        tycon = mkFamilyTyCon tc_name tc_bndrs
-                              res_kind
-                              (resultVariableName sig)
-                              (DataFamilyTyCon tc_rep_name)
-                              parent inj
-  ; return tycon }
-
-  | OpenTypeFamily <- fam_info
-  = bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> do
-  { traceTc "tcFamDecl1 open type family:" (ppr tc_name)
-  ; checkFamFlag tc_name
-  ; inj' <- tcInjectivity tc_bndrs inj
-  ; checkResultSigFlag tc_name sig  -- check after injectivity for better errors
-  ; let tycon = mkFamilyTyCon tc_name tc_bndrs res_kind
-                               (resultVariableName sig) OpenSynFamilyTyCon
-                               parent inj'
-  ; return tycon }
-
-  | ClosedTypeFamily mb_eqns <- fam_info
-  = -- Closed type families are a little tricky, because they contain the definition
-    -- of both the type family and the equations for a CoAxiom.
-    do { traceTc "tcFamDecl1 Closed type family:" (ppr tc_name)
-         -- the variables in the header scope only over the injectivity
-         -- declaration but this is not involved here
-       ; (inj', tc_bndrs, res_kind)
-            <- bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind ->
-               do { inj' <- tcInjectivity tc_bndrs inj
-                  ; return (inj', tc_bndrs, res_kind) }
-
-       ; checkFamFlag tc_name -- make sure we have -XTypeFamilies
-       ; checkResultSigFlag tc_name sig
-
-         -- If Nothing, this is an abstract family in a hs-boot file;
-         -- but eqns might be empty in the Just case as well
-       ; case mb_eqns of
-           Nothing   ->
-               return $ mkFamilyTyCon tc_name tc_bndrs res_kind
-                                      (resultVariableName sig)
-                                      AbstractClosedSynFamilyTyCon parent
-                                      inj'
-           Just eqns -> do {
-
-         -- Process the equations, creating CoAxBranches
-       ; let tc_fam_tc = mkTcTyCon tc_name tc_bndrs res_kind
-                                   noTcTyConScopedTyVars
-                                   False {- this doesn't matter here -}
-                                   ClosedTypeFamilyFlavour
-
-       ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns
-         -- Do not attempt to drop equations dominated by earlier
-         -- ones here; in the case of mutual recursion with a data
-         -- type, we get a knot-tying failure.  Instead we check
-         -- for this afterwards, in GHC.Tc.Validity.checkValidCoAxiom
-         -- Example: tc265
-
-         -- Create a CoAxiom, with the correct src location.
-       ; co_ax_name <- newFamInstAxiomName tc_lname []
-
-       ; let mb_co_ax
-              | null eqns = Nothing   -- mkBranchedCoAxiom fails on empty list
-              | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches)
-
-             fam_tc = mkFamilyTyCon tc_name tc_bndrs res_kind (resultVariableName sig)
-                      (ClosedSynFamilyTyCon mb_co_ax) parent inj'
-
-         -- We check for instance validity later, when doing validity
-         -- checking for the tycon. Exception: checking equations
-         -- overlap done by dropDominatedAxioms
-       ; return fam_tc } }
-
-#if __GLASGOW_HASKELL__ <= 810
-  | otherwise = panic "tcFamInst1"  -- Silence pattern-exhaustiveness checker
-#endif
-
--- | Maybe return a list of Bools that say whether a type family was declared
--- injective in the corresponding type arguments. Length of the list is equal to
--- the number of arguments (including implicit kind/coercion arguments).
--- True on position
--- N means that a function is injective in its Nth argument. False means it is
--- not.
-tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn)
-              -> TcM Injectivity
-tcInjectivity _ Nothing
-  = return NotInjective
-
-  -- User provided an injectivity annotation, so for each tyvar argument we
-  -- check whether a type family was declared injective in that argument. We
-  -- return a list of Bools, where True means that corresponding type variable
-  -- was mentioned in lInjNames (type family is injective in that argument) and
-  -- False means that it was not mentioned in lInjNames (type family is not
-  -- injective in that type variable). We also extend injectivity information to
-  -- kind variables, so if a user declares:
-  --
-  --   type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a
-  --
-  -- then we mark both `a` and `k1` as injective.
-  -- NB: the return kind is considered to be *input* argument to a type family.
-  -- Since injectivity allows to infer input arguments from the result in theory
-  -- we should always mark the result kind variable (`k3` in this example) as
-  -- injective.  The reason is that result type has always an assigned kind and
-  -- therefore we can always infer the result kind if we know the result type.
-  -- But this does not seem to be useful in any way so we don't do it.  (Another
-  -- reason is that the implementation would not be straightforward.)
-tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames)))
-  = setSrcSpanA loc $
-    do { let tvs = binderVars tcbs
-       ; dflags <- getDynFlags
-       ; checkTc (xopt LangExt.TypeFamilyDependencies dflags)
-                 (mkTcRnUnknownMessage $ mkPlainError noHints $
-                  text "Illegal injectivity annotation" $$
-                  text "Use TypeFamilyDependencies to allow this")
-       ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames
-       ; inj_tvs <- zonkTcTyVarsToTcTyVars inj_tvs -- zonk the kinds
-       ; let inj_ktvs = filterVarSet isTyVar $  -- no injective coercion vars
-                        closeOverKinds (mkVarSet inj_tvs)
-       ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs
-       ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs
-                                       , ppr inj_ktvs, ppr inj_bools ])
-       ; return $ Injective inj_bools }
-
-tcTySynRhs :: RolesInfo -> Name
-           -> LHsType GhcRn -> TcM TyCon
-tcTySynRhs roles_info tc_name hs_ty
-  = bindTyClTyVars tc_name $ \ tc_bndrs res_kind ->
-    do { env <- getLclEnv
-       ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))
-       ; rhs_ty <- pushLevelAndSolveEqualities skol_info tc_bndrs $
-                   tcCheckLHsType hs_ty (TheKind res_kind)
-
-         -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType
-         -- Example: (typecheck/should_fail/T17567)
-         --   type T = forall a. Proxy a
-         -- The kind of `a` is unconstrained.
-       ; dvs <- candidateQTyVarsOfType rhs_ty
-       ; let mk_doc tidy_env = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty
-                                  ; return ( tidy_env2
-                                           , sep [ text "the type synonym right-hand side:"
-                                                 , ppr rhs_ty ] ) }
-       ; doNotQuantifyTyVars dvs mk_doc
-
-       ; ze          <- mkEmptyZonkEnv NoFlexi
-       ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs
-       ; rhs_ty      <- zonkTcTypeToTypeX ze rhs_ty
-       ; let roles = roles_info tc_name
-       ; return (buildSynTyCon tc_name bndrs res_kind roles rhs_ty) }
-  where
-    skol_info = TyConSkol TypeSynonymFlavour tc_name
-
-tcDataDefn :: SDoc -> RolesInfo -> Name
-           -> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo])
-  -- NB: not used for newtype/data instances (whether associated or not)
-tcDataDefn err_ctxt roles_info tc_name
-           (HsDataDefn { dd_cType = cType
-                       , dd_ctxt = ctxt
-                       , dd_kindSig = mb_ksig  -- Already in tc's kind
-                                               -- via inferInitialKinds
-                       , dd_cons = cons
-                       , dd_derivs = derivs })
-  = bindTyClTyVars tc_name $ \ tc_bndrs res_kind ->
-       -- The TyCon tyvars must scope over
-       --    - the stupid theta (dd_ctxt)
-       --    - for H98 constructors only, the ConDecl
-       -- But it does no harm to bring them into scope
-       -- over GADT ConDecls as well; and it's awkward not to
-    do { gadt_syntax <- dataDeclChecks tc_name ctxt cons
-
-       ; tcg_env <- getGblEnv
-       ; let hsc_src = tcg_src tcg_env
-       ; unless (mk_permissive_kind hsc_src cons) $
-         checkDataKindSig (DataDeclSort (dataDefnConsNewOrData cons)) res_kind
-
-       ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info tc_bndrs $
-                            tcHsContext ctxt
-
-       -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType
-       -- Example: (typecheck/should_fail/T17567StupidTheta)
-       --   data (forall a. a b ~ a c) => T b c
-       -- The kind of 'a' is unconstrained.
-       ; dvs <- candidateQTyVarsOfTypes stupid_tc_theta
-       ; let mk_doc tidy_env
-               = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env stupid_tc_theta
-                    ; return ( tidy_env2
-                             , sep [ text "the datatype context:"
-                                   , pprTheta theta ] ) }
-       ; doNotQuantifyTyVars dvs mk_doc
-
-             -- Check that we don't use kind signatures without the extension
-       ; kind_signatures <- xoptM LangExt.KindSignatures
-       ; when (isJust mb_ksig) $
-         checkTc (kind_signatures) (badSigTyDecl tc_name)
-
-       ; ze             <- mkEmptyZonkEnv NoFlexi
-       ; (ze, bndrs)    <- zonkTyVarBindersX   ze tc_bndrs
-       ; stupid_theta   <- zonkTcTypesToTypesX ze stupid_tc_theta
-       ; res_kind       <- zonkTcTypeToTypeX   ze res_kind
-
-       ; tycon <- fixM $ \ rec_tycon -> do
-             { data_cons <- tcConDecls DDataType rec_tycon tc_bndrs res_kind cons
-             ; tc_rhs    <- mk_tc_rhs hsc_src rec_tycon data_cons
-             ; tc_rep_nm <- newTyConRepName tc_name
-
-             ; return (mkAlgTyCon tc_name
-                                  bndrs
-                                  res_kind
-                                  (roles_info tc_name)
-                                  (fmap unLoc cType)
-                                  stupid_theta tc_rhs
-                                  (VanillaAlgTyCon tc_rep_nm)
-                                  gadt_syntax)
-         }
-
-       ; let scoped_tvs = mkTyVarNamePairs (binderVars tc_bndrs)
-                          -- scoped_tvs: still the skolem TcTyVars
-             deriv_info = DerivInfo { di_rep_tc = tycon
-                                    , di_scoped_tvs = scoped_tvs
-                                    , di_clauses = derivs
-                                    , di_ctxt = err_ctxt }
-       ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tc_bndrs)
-       ; return (tycon, [deriv_info]) }
-  where
-    skol_info = TyConSkol flav tc_name
-    flav = newOrDataToFlavour (dataDefnConsNewOrData cons)
-
-    -- Abstract data types in hsig files can have arbitrary kinds,
-    -- because they may be implemented by type synonyms
-    -- (which themselves can have arbitrary kinds, not just *). See #13955.
-    --
-    -- Note that this is only a property that data type declarations possess,
-    -- so one could not have, say, a data family instance in an hsig file that
-    -- has kind `Bool`. Therefore, this check need only occur in the code that
-    -- typechecks data type declarations.
-    mk_permissive_kind HsigFile (DataTypeCons _ []) = True
-    mk_permissive_kind _ _ = False
-
-    -- In an hs-boot or a signature file,
-    -- a 'data' declaration with no constructors
-    -- indicates a nominally distinct abstract data type.
-    mk_tc_rhs (isHsBootOrSig -> True) _ (DataTypeCons _ [])
-      = return AbstractTyCon
-
-    mk_tc_rhs _ tycon data_cons = case data_cons of
-          DataTypeCons is_type_data data_cons -> return $
-                        mkLevPolyDataTyConRhs
-                          (isFixedRuntimeRepKind (tyConResKind tycon))
-                          is_type_data
-                          data_cons
-          NewTypeCon data_con -> mkNewTyConRhs tc_name tycon data_con
-
--------------------------
-kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()
--- Used for the equations of a closed type family only
--- Not used for data/type instances
-kcTyFamInstEqn tc_fam_tc
-    (L loc (FamEqn { feqn_tycon = L _ eqn_tc_name
-                   , feqn_bndrs = outer_bndrs
-                   , feqn_pats  = hs_pats
-                   , feqn_rhs   = hs_rhs_ty }))
-  = setSrcSpanA loc $
-    do { traceTc "kcTyFamInstEqn" (vcat
-           [ text "tc_name ="    <+> ppr eqn_tc_name
-           , text "fam_tc ="     <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc)
-           , text "feqn_bndrs =" <+> ppr outer_bndrs
-           , text "feqn_pats ="  <+> ppr hs_pats ])
-
-       ; checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats
-
-       ; discardResult $
-         bindOuterFamEqnTKBndrs_Q_Tv outer_bndrs $
-         do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats
-            ; tcCheckLHsType hs_rhs_ty (TheKind res_kind) }
-             -- Why "_Tv" here?  Consider (#14066)
-             --  type family Bar x y where
-             --      Bar (x :: a) (y :: b) = Int
-             --      Bar (x :: c) (y :: d) = Bool
-             -- During kind-checking, a,b,c,d should be TyVarTvs and unify appropriately
-    }
-
---------------------------
-tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn
-               -> TcM (KnotTied CoAxBranch)
--- Needs to be here, not in GHC.Tc.TyCl.Instance, because closed families
--- (typechecked here) have TyFamInstEqns
-
-tcTyFamInstEqn fam_tc mb_clsinfo
-    (L loc (FamEqn { feqn_tycon  = L _ eqn_tc_name
-                   , feqn_bndrs  = outer_bndrs
-                   , feqn_pats   = hs_pats
-                   , feqn_rhs    = hs_rhs_ty }))
-  = setSrcSpanA loc $
-    do { traceTc "tcTyFamInstEqn" $
-         vcat [ ppr loc, ppr fam_tc <+> ppr hs_pats
-              , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc)
-              , case mb_clsinfo of
-                  NotAssociated {} -> empty
-                  InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ]
-
-       ; checkTyFamInstEqn fam_tc eqn_tc_name hs_pats
-
-       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo
-                                      outer_bndrs hs_pats hs_rhs_ty
-       -- Don't print results they may be knot-tied
-       -- (tcFamInstEqnGuts zonks to Type)
-       ; return (mkCoAxBranch qtvs [] [] pats rhs_ty
-                              (map (const Nominal) qtvs)
-                              (locA loc)) }
-
-checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg tm ty] -> TcM ()
-checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats =
-  do { -- Ensure that each equation's type constructor is for the right
-       -- type family.  E.g. barf on
-       --    type family F a where { G Int = Bool }
-       let tc_fam_tc_name = getName tc_fam_tc
-     ; checkTc (tc_fam_tc_name == eqn_tc_name) $
-               wrongTyFamName tc_fam_tc_name eqn_tc_name
-
-       -- Check the arity of visible arguments
-       -- If we wait until validity checking, we'll get kind errors
-       -- below when an arity error will be much easier to understand.
-     ; let vis_arity = length (tyConVisibleTyVars tc_fam_tc)
-           vis_pats  = numVisibleArgs hs_pats
-     ; checkTc (vis_pats == vis_arity) $
-               wrongNumberOfParmsErr vis_arity
-     }
-
-{- Note [Instantiating a family tycon]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's possible that kind-checking the result of a family tycon applied to
-its patterns will instantiate the tycon further. For example, we might
-have
-
-  type family F :: k where
-    F = Int
-    F = Maybe
-
-After checking (F :: forall k. k) (with no visible patterns), we still need
-to instantiate the k. With data family instances, this problem can be even
-more intricate, due to Note [Arity of data families] in GHC.Core.FamInstEnv. See
-indexed-types/should_compile/T12369 for an example.
-
-So, the kind-checker must return the new skolems and args (that is, Type
-or (Type -> Type) for the equations above) and the instantiated kind.
-
-Note [Generalising in tcTyFamInstEqnGuts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have something like
-  type instance forall (a::k) b. F (Proxy t1) _ = rhs
-
-Then  imp_vars = [k], exp_bndrs = [a::k, b]
-
-We want to quantify over all the free vars of the LHS including
-  * any invisible kind variables arising from instantiating tycons,
-    such as Proxy
-  * wildcards such as '_' above
-
-The wildcards are particularly awkward: they may need to be quantified
-  - before the explicit variables k,a,b
-  - after them
-  - or even interleaved with them
-  c.f. Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType
-
-So, we use bindOuterFamEqnTKBndrs (which does not create an implication for
-the telescope), and generalise over /all/ the variables in the LHS,
-without treating the explicitly-quantified ones specially. Wrinkles:
-
- - When generalising, include the explicit user-specified forall'd
-   variables, so that we get an error from Validity.checkFamPatBinders
-   if a forall'd variable is not bound on the LHS
-
- - We still want to complain about a bad telescope among the user-specified
-   variables.  So in checkFamTelescope we emit an implication constraint
-   quantifying only over them, purely so that we get a good telescope error.
-
-  - Note that, unlike a type signature like
-       f :: forall (a::k). blah
-    we do /not/ care about the Inferred/Specified designation or order for
-    the final quantified tyvars.  Type-family instances are not invoked
-    directly in Haskell source code, so visible type application etc plays
-    no role.
-
-See also Note [Re-quantify type variables in rules] in
-GHC.Tc.Gen.Rule, which explains a /very/ similar design when
-generalising over the type of a rewrite rule.
-
--}
-
---------------------------
-tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo
-                   -> HsOuterFamEqnTyVarBndrs GhcRn     -- Implicit and explicit binders
-                   -> HsTyPats GhcRn                    -- Patterns
-                   -> LHsType GhcRn                     -- RHS
-                   -> TcM ([TyVar], [TcType], TcType)   -- (tyvars, pats, rhs)
--- Used only for type families, not data families
-tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty
-  = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc $$ ppr outer_hs_bndrs $$ ppr hs_pats)
-
-       -- By now, for type families (but not data families) we should
-       -- have checked that the number of patterns matches tyConArity
-       ; skol_info <- mkSkolemInfo FamInstSkol
-
-       -- This code is closely related to the code
-       -- in GHC.Tc.Gen.HsType.kcCheckDeclHeader_cusk
-       ; (tclvl, wanted, (outer_bndrs, (lhs_ty, rhs_ty)))
-               <- pushLevelAndSolveEqualitiesX "tcTyFamInstEqnGuts" $
-                  bindOuterFamEqnTKBndrs skol_info outer_hs_bndrs   $
-                  do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats
-                       -- Ensure that the instance is consistent with its
-                       -- parent class (#16008)
-                     ; addConsistencyConstraints mb_clsinfo lhs_ty
-                     ; rhs_ty <- tcCheckLHsType hs_rhs_ty (TheKind rhs_kind)
-                     ; return (lhs_ty, rhs_ty) }
-
-       ; outer_bndrs <- scopedSortOuter outer_bndrs
-       ; let outer_tvs = outerTyVars outer_bndrs
-       ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs
-
-       ; traceTc "tcTyFamInstEqnGuts 1" (pprTyVars outer_tvs $$ ppr skol_info)
-
-       -- This code (and the stuff immediately above) is very similar
-       -- to that in tcDataFamInstHeader.  Maybe we should abstract the
-       -- common code; but for the moment I concluded that it's
-       -- clearer to duplicate it.  Still, if you fix a bug here,
-       -- check there too!
-
-       -- See Note [Generalising in tcTyFamInstEqnGuts]
-       ; dvs  <- candidateQTyVarsWithBinders outer_tvs lhs_ty
-       ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs
-       ; let final_tvs = scopedSort (qtvs ++ outer_tvs)
-             -- This scopedSort is important: the qtvs may be /interleaved/ with
-             -- the outer_tvs.  See Note [Generalising in tcTyFamInstEqnGuts]
-       ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted
-
-       ; traceTc "tcTyFamInstEqnGuts 2" $
-         vcat [ ppr fam_tc
-              , text "lhs_ty:"    <+> ppr lhs_ty
-              , text "final_tvs:" <+> pprTyVars final_tvs ]
-
-       -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType
-       -- Example: typecheck/should_fail/T17301
-       ; dvs_rhs <- candidateQTyVarsOfType rhs_ty
-       ; let mk_doc tidy_env
-               = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty
-                    ; return ( tidy_env2
-                             , sep [ text "type family equation right-hand side:"
-                                   , ppr rhs_ty ] ) }
-       ; doNotQuantifyTyVars dvs_rhs mk_doc
-
-       ; ze              <- mkEmptyZonkEnv NoFlexi
-       ; (ze, final_tvs) <- zonkTyBndrsX      ze final_tvs
-       ; lhs_ty          <- zonkTcTypeToTypeX ze lhs_ty
-       ; rhs_ty          <- zonkTcTypeToTypeX ze rhs_ty
-
-       ; let pats = unravelFamInstPats lhs_ty
-             -- Note that we do this after solveEqualities
-             -- so that any strange coercions inside lhs_ty
-             -- have been solved before we attempt to unravel it
-
-       ; traceTc "tcTyFamInstEqnGuts }" (vcat [ ppr fam_tc, pprTyVars final_tvs ])
-                 -- Don't try to print 'pats' here, because lhs_ty involves
-                 -- a knot-tied type constructor, so we get a black hole
-
-       ; return (final_tvs, pats, rhs_ty) }
-
-checkFamTelescope :: TcLevel
-                  -> HsOuterFamEqnTyVarBndrs GhcRn
-                  -> [TcTyVar] -> TcM ()
--- Emit a constraint (forall a b c. <empty>), so that
--- we will do telescope-checking on a,b,c
--- See Note [Generalising in tcTyFamInstEqnGuts]
-checkFamTelescope tclvl hs_outer_bndrs outer_tvs
-  | HsOuterExplicit { hso_bndrs = bndrs } <- hs_outer_bndrs
-  , (b_first : _) <- bndrs
-  , let b_last    = last bndrs
-  = do { skol_info <- mkSkolemInfo (ForAllSkol $ HsTyVarBndrsRn (map unLoc bndrs))
-       ; setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $ do
-         emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC }
-  | otherwise
-  = return ()
-
------------------
-unravelFamInstPats :: TcType -> [TcType]
--- Decompose fam_app to get the argument patterns
---
--- We expect fam_app to look like (F t1 .. tn)
---   tcFamTyPats is capable of returning ((F ty1 |> co) ty2),
---   but that can't happen here because we already checked the
---   arity of F matches the number of pattern
-unravelFamInstPats fam_app
-  = case tcSplitTyConApp_maybe fam_app of
-      Just (_, pats) -> pats
-      Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance"
-        -- The Nothing case cannot happen for type families, because
-        -- we don't call unravelFamInstPats until we've solved the
-        -- equalities. For data families, it shouldn't happen either,
-        -- we need to fail hard and early if it does. See trac issue #15905
-        -- for an example of this happening.
-
-addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM ()
--- In the corresponding positions of the class and type-family,
--- ensure the family argument is the same as the class argument
---   E.g    class C a b c d where
---             F c x y a :: Type
--- Here the first  arg of F should be the same as the third of C
---  and the fourth arg of F should be the same as the first of C
-addConsistencyConstraints mb_clsinfo fam_app
-  | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo
-  , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app
-  = do { let eqs = [ (cls_ty, pat)
-                   | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats
-                   , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ]
-       ; traceTc "addConsistencyConstraints" (ppr eqs)
-       ; emitWantedEqs AssocFamPatOrigin eqs }
-    -- Improve inference; these equalities will not produce errors.
-    -- See Note [Constraints to ignore] in GHC.Tc.Errors
-    -- Any mis-match is reports by checkConsistentFamInst
-  | otherwise
-  = return ()
-
-{- Note [Constraints in patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-NB: This isn't the whole story. See comment in tcFamTyPats.
-
-At first glance, it seems there is a complicated story to tell in tcFamTyPats
-around constraint solving. After all, type family patterns can now do
-GADT pattern-matching, which is jolly complicated. But, there's a key fact
-which makes this all simple: everything is at top level! There cannot
-be untouchable type variables. There can't be weird interaction between
-case branches. There can't be global skolems.
-
-This means that the semantics of type-level GADT matching is a little
-different than term level. If we have
-
-  data G a where
-    MkGBool :: G Bool
-
-And then
-
-  type family F (a :: G k) :: k
-  type instance F MkGBool = True
-
-we get
-
-  axF : F Bool (MkGBool <Bool>) ~ True
-
-Simple! No casting on the RHS, because we can affect the kind parameter
-to F.
-
-If we ever introduce local type families, this all gets a lot more
-complicated, and will end up looking awfully like term-level GADT
-pattern-matching.
-
-
-** The new story **
-
-Here is really what we want:
-
-The matcher really can't deal with covars in arbitrary spots in coercions.
-But it can deal with covars that are arguments to GADT data constructors.
-So we somehow want to allow covars only in precisely those spots, then use
-them as givens when checking the RHS. TODO (RAE): Implement plan.
-
-Note [Quantified kind variables of a family pattern]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider   type family KindFam (p :: k1) (q :: k1)
-           data T :: Maybe k1 -> k2 -> *
-           type instance KindFam (a :: Maybe k) b = T a b -> Int
-The HsBSig for the family patterns will be ([k], [a])
-
-Then in the family instance we want to
-  * Bring into scope [ "k" -> k:*, "a" -> a:k ]
-  * Kind-check the RHS
-  * Quantify the type instance over k and k', as well as a,b, thus
-       type instance [k, k', a:Maybe k, b:k']
-                     KindFam (Maybe k) k' a b = T k k' a b -> Int
-
-Notice that in the third step we quantify over all the visibly-mentioned
-type variables (a,b), but also over the implicitly mentioned kind variables
-(k, k').  In this case one is bound explicitly but often there will be
-none. The role of the kind signature (a :: Maybe k) is to add a constraint
-that 'a' must have that kind, and to bring 'k' into scope.
-
-
-
-************************************************************************
-*                                                                      *
-               Data types
-*                                                                      *
-************************************************************************
--}
-
-dataDeclChecks :: Name
-               -> Maybe (LHsContext GhcRn) -> DataDefnCons (LConDecl GhcRn)
-               -> TcM Bool
-dataDeclChecks tc_name mctxt cons
-  = do { let stupid_theta = fromMaybeContext mctxt
-         -- Check that we don't use GADT syntax in H98 world
-       ;  gadtSyntax_ok <- xoptM LangExt.GADTSyntax
-       ; let gadt_syntax = anyLConIsGadt cons
-       ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name)
-
-           -- Check that the stupid theta is empty for a GADT-style declaration.
-           -- See Note [The stupid context] in GHC.Core.DataCon.
-       ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name)
-
-         -- Check that there's at least one condecl,
-         -- or else we're reading an hs-boot file, or -XEmptyDataDecls
-       ; empty_data_decls <- xoptM LangExt.EmptyDataDecls
-       ; is_boot <- tcIsHsBootOrSig  -- Are we compiling an hs-boot file?
-       ; checkTc (not (null cons) || empty_data_decls || is_boot)
-                 (emptyConDeclsErr tc_name)
-       ; return gadt_syntax }
-
-
------------------------------------
-data DataDeclInfo
-  = DDataType      -- data T a b = T1 a | T2 b
-  | DDataInstance  -- data instance D [a] = D1 a | D2
-       Type        --   The header D [a]
-
-mkDDHeaderTy :: DataDeclInfo -> TyCon -> [TyConBinder] -> Type
-mkDDHeaderTy dd_info rep_tycon tc_bndrs
-  = case dd_info of
-      DDataType -> mkTyConApp rep_tycon $
-                   mkTyVarTys (binderVars tc_bndrs)
-      DDataInstance header_ty -> header_ty
-
--- We use `concatMapDataDefnConsTcM` here, since the following is illegal:
--- @newtype T a where T1, T2 :: a -> T a@
--- It would be represented as a single 'ConDeclGadt' with multiple names, which is valid for 'data', but not 'newtype'.
--- So when 'tcConDecl' expands the 'ConDecl' per each name it has, if we are type-checking a 'newtype' declaration, we
--- must fail if it returns more than one.
-tcConDecls :: DataDeclInfo
-           -> KnotTied TyCon            -- Representation TyCon
-           -> [TcTyConBinder]           -- Binders of representation TyCon
-           -> TcKind                    -- Result kind
-           -> DataDefnCons (LConDecl GhcRn) -> TcM (DataDefnCons DataCon)
-tcConDecls dd_info rep_tycon tmpl_bndrs res_kind
-  = concatMapDataDefnConsTcM (tyConName rep_tycon) $ \ new_or_data ->
-    addLocMA $ tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind (mkTyConTagMap rep_tycon)
-    -- mkTyConTagMap: it's important that we pay for tag allocation here,
-    -- once per TyCon. See Note [Constructor tag allocation], fixes #14657
-
--- 'concatMap' for 'DataDefnCons', but fail if the given function returns multiple values and the argument is a 'NewTypeCon'.
-concatMapDataDefnConsTcM :: Name -> (NewOrData -> a -> TcM (NonEmpty b)) -> DataDefnCons a -> TcM (DataDefnCons b)
-concatMapDataDefnConsTcM name f = \ case
-    NewTypeCon a -> f NewType a >>= \ case
-        b:|[] -> pure (NewTypeCon b)
-        bs -> failWithTc $ newtypeConError name (length bs)
-    DataTypeCons is_type_data as -> DataTypeCons is_type_data <$> concatMapM (fmap toList . f DataType) as
-
-tcConDecl :: NewOrData
-          -> DataDeclInfo
-          -> KnotTied TyCon   -- Representation tycon. Knot-tied!
-          -> [TcTyConBinder]  -- Binders of representation TyCon
-          -> TcKind           -- Result kind
-          -> NameEnv ConTag
-          -> ConDecl GhcRn
-          -> TcM (NonEmpty DataCon)
-
-tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map
-          (ConDeclH98 { con_name = lname@(L _ name)
-                      , con_ex_tvs = explicit_tkv_nms
-                      , con_mb_cxt = hs_ctxt
-                      , con_args = hs_args })
-  = addErrCtxt (dataConCtxt (NE.singleton lname)) $
-    do { -- NB: the tyvars from the declaration header are in scope
-
-         -- Get hold of the existential type variables
-         -- e.g. data T a = forall k (b::k) f. MkT a (f b)
-         -- Here tc_bndrs = {a}
-         --      hs_qvars = HsQTvs { hsq_implicit = {k}
-         --                        , hsq_explicit = {f,b} }
-
-       ; traceTc "tcConDecl 1" (vcat [ ppr name
-                                     , text "explicit_tkv_nms" <+> ppr explicit_tkv_nms
-                                     , text "tc_bndrs" <+> ppr tc_bndrs ])
-       ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn (unLoc <$> explicit_tkv_nms)))
-
-       ; (tclvl, wanted, (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts)))
-           <- pushLevelAndSolveEqualitiesX "tcConDecl:H98"  $
-              tcExplicitTKBndrs skol_info explicit_tkv_nms  $
-              do { ctxt <- tcHsContext hs_ctxt
-                 ; let exp_kind = getArgExpKind new_or_data res_kind
-                 ; btys <- tcConH98Args exp_kind hs_args
-                 ; field_lbls <- lookupConstructorFields name
-                 ; let (arg_tys, stricts) = unzip btys
-                 ; return (ctxt, arg_tys, field_lbls, stricts)
-                 }
-
-
-       ; let tc_tvs   = binderVars tc_bndrs
-             fake_ty  = mkSpecForAllTys  tc_tvs      $
-                        mkInvisForAllTys exp_tvbndrs $
-                        tcMkPhiTy ctxt               $
-                        tcMkScaledFunTys arg_tys     $
-                        unitTy
-             -- That type is a lie, of course. (It shouldn't end in ()!)
-             -- And we could construct a proper result type from the info
-             -- at hand. But the result would mention only the univ_tvs,
-             -- and so it just creates more work to do it right. Really,
-             -- we're only doing this to find the right kind variables to
-             -- quantify over, and this type is fine for that purpose.
-
-         -- exp_tvbndrs have explicit, user-written binding sites
-         -- the kvs below are those kind variables entirely unmentioned by the user
-         --   and discovered only by generalization
-
-       ; kvs <- kindGeneralizeAll skol_info fake_ty
-
-       ; let all_skol_tvs = tc_tvs ++ kvs
-       ; reportUnsolvedEqualities skol_info all_skol_tvs tclvl wanted
-             -- The skol_info claims that all the variables are bound
-             -- by the data constructor decl, whereas actually the
-             -- univ_tvs are bound by the data type decl itself.  It
-             -- would be better to have a doubly-nested implication.
-             -- But that just doesn't seem worth it.
-             -- See test dependent/should_fail/T13780a
-
-       -- Zonk to Types
-       ; ze                <- mkEmptyZonkEnv NoFlexi
-       ; (ze, tc_bndrs)    <- zonkTyVarBindersX         ze tc_bndrs
-       ; (ze, kvs)         <- zonkTyBndrsX              ze kvs
-       ; (ze, exp_tvbndrs) <- zonkTyVarBindersX         ze exp_tvbndrs
-       ; arg_tys           <- zonkScaledTcTypesToTypesX ze arg_tys
-       ; ctxt              <- zonkTcTypesToTypesX       ze ctxt
-
-       -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here
-       ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)
-       ; let univ_tvbs = tyConInvisTVBinders tc_bndrs
-             ex_tvbs   = mkTyVarBinders InferredSpec kvs ++ exp_tvbndrs
-             ex_tvs    = binderVars ex_tvbs
-                -- For H98 datatypes, the user-written tyvar binders are precisely
-                -- the universals followed by the existentials.
-                -- See Note [DataCon user type variable binders] in GHC.Core.DataCon.
-             user_tvbs = univ_tvbs ++ ex_tvbs
-             user_res_ty = mkDDHeaderTy dd_info rep_tycon tc_bndrs
-
-       ; traceTc "tcConDecl 2" (ppr name)
-       ; is_infix <- tcConIsInfixH98 name hs_args
-       ; rep_nm   <- newTyConRepName name
-       ; fam_envs <- tcGetFamInstEnvs
-       ; dflags   <- getDynFlags
-       ; let bang_opts = SrcBangOpts (initBangOpts dflags)
-       ; dc <- buildDataCon fam_envs bang_opts name is_infix rep_nm
-                            stricts field_lbls
-                            tc_tvs ex_tvs user_tvbs
-                            [{- no eq_preds -}] ctxt arg_tys
-                            user_res_ty rep_tycon tag_map
-                  -- NB:  we put data_tc, the type constructor gotten from the
-                  --      constructor type signature into the data constructor;
-                  --      that way checkValidDataCon can complain if it's wrong.
-
-       ; return (NE.singleton dc) }
-
-tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map
-  -- NB: don't use res_kind here, as it's ill-scoped. Instead,
-  -- we get the res_kind by typechecking the result type.
-          (ConDeclGADT { con_names = names
-                       , con_bndrs = L _ outer_hs_bndrs
-                       , con_mb_cxt = cxt, con_g_args = hs_args
-                       , con_res_ty = hs_res_ty })
-  = addErrCtxt (dataConCtxt names) $
-    do { traceTc "tcConDecl 1 gadt" (ppr names)
-       ; let L _ name :| _ = names
-       ; skol_info <- mkSkolemInfo (DataConSkol name)
-       ; (tclvl, wanted, (outer_bndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))
-           <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $
-              tcOuterTKBndrs skol_info outer_hs_bndrs       $
-              do { ctxt <- tcHsContext cxt
-                 ; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty
-                         -- See Note [GADT return kinds]
-
-                 -- For data instances (only), ensure that the return type,
-                 -- res_ty, is a substitution instance of the header.
-                 -- See Note [GADT return types]
-                 ; case dd_info of
-                      DDataType -> return ()
-                      DDataInstance hdr_ty ->
-                        do { (subst, _meta_tvs) <- newMetaTyVars (binderVars tc_bndrs)
-                           ; let head_shape = substTy subst hdr_ty
-                           ; discardResult $
-                             popErrCtxt $  -- Drop dataConCtxt
-                             addErrCtxt (dataConResCtxt names) $
-                             unifyType Nothing res_ty head_shape }
-
-                   -- See Note [Datatype return kinds]
-                 ; let exp_kind = getArgExpKind new_or_data res_kind
-                 ; btys <- tcConGADTArgs exp_kind hs_args
-
-                 ; let (arg_tys, stricts) = unzip btys
-                 ; field_lbls <- lookupConstructorFields name
-                 ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
-                 }
-
-       ; outer_bndrs <- scopedSortOuter outer_bndrs
-       ; let outer_tv_bndrs = outerTyVarBndrs outer_bndrs
-
-       ; tkvs <- kindGeneralizeAll skol_info
-                    (mkInvisForAllTys outer_tv_bndrs $
-                     tcMkPhiTy ctxt                  $
-                     tcMkScaledFunTys arg_tys        $
-                     res_ty)
-       ; traceTc "tcConDecl:GADT" (ppr names $$ ppr res_ty $$ ppr tkvs)
-       ; reportUnsolvedEqualities skol_info tkvs tclvl wanted
-
-       ; let tvbndrs =  mkTyVarBinders InferredSpec tkvs ++ outer_tv_bndrs
-
-             -- Zonk to Types
-       ; ze            <- mkEmptyZonkEnv NoFlexi
-       ; (ze, tvbndrs) <- zonkTyVarBindersX         ze tvbndrs
-       ; arg_tys       <- zonkScaledTcTypesToTypesX ze arg_tys
-       ; ctxt          <- zonkTcTypesToTypesX       ze ctxt
-       ; res_ty        <- zonkTcTypeToTypeX         ze res_ty
-
-       ; let res_tmpl = mkDDHeaderTy dd_info rep_tycon tc_bndrs
-             (univ_tvs, ex_tvs, tvbndrs', eq_preds, arg_subst)
-               = rejigConRes tc_bndrs res_tmpl tvbndrs res_ty
-             -- See Note [rejigConRes]
-
-             ctxt'      = substTys arg_subst ctxt
-             arg_tys'   = substScaledTys arg_subst arg_tys
-             res_ty'    = substTy  arg_subst res_ty
-
-       -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here
-       ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)
-       ; fam_envs <- tcGetFamInstEnvs
-       ; dflags <- getDynFlags
-       ; let
-           buildOneDataCon (L _ name) = do
-             { is_infix <- tcConIsInfixGADT name hs_args
-             ; rep_nm   <- newTyConRepName name
-
-             ; let bang_opts = SrcBangOpts (initBangOpts dflags)
-             ; buildDataCon fam_envs bang_opts name is_infix
-                            rep_nm stricts field_lbls
-                            univ_tvs ex_tvs tvbndrs' eq_preds
-                            ctxt' arg_tys' res_ty' rep_tycon tag_map
-                  -- NB:  we put data_tc, the type constructor gotten from the
-                  --      constructor type signature into the data constructor;
-                  --      that way checkValidDataCon can complain if it's wrong.
-             }
-       ; mapM buildOneDataCon names }
-
-{- Note [GADT return types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  data family T :: forall k. k -> Type
-  data instance T (a :: Type) where
-    MkT :: forall b. T b
-
-What kind does `b` have in the signature for MkT?
-Since the return type must be an instance of the type in the header,
-we must have (b :: Type), but you can't tell that by looking only at
-the type of the data constructor; you have to look at the header too.
-If you wrote it out fully, it'd look like
-  data instance T @Type (a :: Type) where
-    MkT :: forall (b::Type). T @Type b
-
-We could reject the program, and expect the user to add kind
-annotations to `MkT` to restrict the signature.  But an easy and
-helpful alternative is this: simply instantiate the type from the
-header with fresh unification variables, and unify with the return
-type of `MkT`. That will force `b` to have kind `Type`.  See #8707
-and #14111.
-
-Wrikles
-* At first sight it looks as though this would completely subsume the
-  return-type check in checkValidDataCon.  But it does not. Suppose we
-  have
-     data instance T [a] where
-        MkT :: T (F (Maybe a))
-
-  where F is a type function.  Then maybe (F (Maybe a)) evaluates to
-  [a], so unifyType will succeed.  But we discard the coercion
-  returned by unifyType; and we really don't want to accept this
-  program.  The check in checkValidDataCon will, however, reject it.
-  TL;DR: keep the check in checkValidDataCon.
-
-* Consider a data type, rather than a data instance, declaration
-     data S a where { MkS :: b -> S [b]  }
-  In tcConDecl, S is knot-tied, so we don't want to unify (S alpha)
-  with (S [b]). To put it another way, unifyType should never see a
-  TcTycon.  Simple solution: do *not* do the extra unifyType for
-  data types (DDataType) only for data instances (DDataInstance); in
-  the latter the family constructor is not knot-tied so there is no
-  problem.
-
-* Consider this (from an earlier form of GHC itself):
-
-     data Pass = Parsed | ...
-     data GhcPass (c :: Pass) where
-       GhcPs :: GhcPs
-       ...
-     type GhcPs   = GhcPass 'Parsed
-
-   Now GhcPs and GhcPass are mutually recursive. If we did unifyType
-   for datatypes like GhcPass, we would not be able to expand the type
-   synonym (it'd still be a TcTyCon).  So again, we don't do unifyType
-   for data types; we leave it to checkValidDataCon.
-
-   We /do/ perform the unifyType for data /instances/, but a data
-   instance doesn't declare a new (user-visible) type constructor, so
-   there is no mutual recursion with type synonyms to worry about.
-   All good.
-
-   TL;DR we do support mutual recursion between type synonyms and
-   data type/instance declarations, as above.
-
-Note [GADT return kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   type family Star where Star = Type
-   data T :: Type where
-      MkT :: Int -> T
-
-If, for some stupid reason, tcInferLHsTypeKind on the return type of
-MkT returned (T |> ax, Star), then the return-type check in
-checkValidDataCon would reject the decl (although of course there is
-nothing wrong with it).  We are implicitly requiring tha
-tcInferLHsTypeKind doesn't any gratuitous top-level casts.
--}
-
--- | Produce an "expected kind" for the arguments of a data/newtype.
--- If the declaration is indeed for a newtype,
--- then this expected kind will be the kind provided. Otherwise,
--- it is OpenKind for datatypes and liftedTypeKind.
--- Why do we not check for -XUnliftedNewtypes? See point <Error Messages>
--- in Note [Implementation of UnliftedNewtypes]
-getArgExpKind :: NewOrData -> TcKind -> ContextKind
-getArgExpKind NewType res_ki = TheKind res_ki
-getArgExpKind DataType _     = OpenKind
-
-tcConIsInfixH98 :: Name
-             -> HsConDeclH98Details GhcRn
-             -> TcM Bool
-tcConIsInfixH98 _   details
-  = case details of
-           InfixCon{}  -> return True
-           RecCon{}    -> return False
-           PrefixCon{} -> return False
-
-tcConIsInfixGADT :: Name
-             -> HsConDeclGADTDetails GhcRn
-             -> TcM Bool
-tcConIsInfixGADT con details
-  = case details of
-           RecConGADT{} -> return False
-           PrefixConGADT arg_tys       -- See Note [Infix GADT constructors]
-               | isSymOcc (getOccName con)
-               , [_ty1,_ty2] <- map hsScaledThing arg_tys
-                  -> do { fix_env <- getFixityEnv
-                        ; return (con `elemNameEnv` fix_env) }
-               | otherwise -> return False
-
-tcConH98Args :: ContextKind  -- expected kind of arguments
-                             -- always OpenKind for datatypes, but unlifted newtypes
-                             -- might have a specific kind
-             -> HsConDeclH98Details GhcRn
-             -> TcM [(Scaled TcType, HsSrcBang)]
-tcConH98Args exp_kind (PrefixCon _ btys)
-  = mapM (tcConArg exp_kind) btys
-tcConH98Args exp_kind (InfixCon bty1 bty2)
-  = do { bty1' <- tcConArg exp_kind bty1
-       ; bty2' <- tcConArg exp_kind bty2
-       ; return [bty1', bty2'] }
-tcConH98Args exp_kind (RecCon fields)
-  = tcRecConDeclFields exp_kind fields
-
-tcConGADTArgs :: ContextKind  -- expected kind of arguments
-                              -- always OpenKind for datatypes, but unlifted newtypes
-                              -- might have a specific kind
-              -> HsConDeclGADTDetails GhcRn
-              -> TcM [(Scaled TcType, HsSrcBang)]
-tcConGADTArgs exp_kind (PrefixConGADT btys)
-  = mapM (tcConArg exp_kind) btys
-tcConGADTArgs exp_kind (RecConGADT fields _)
-  = tcRecConDeclFields exp_kind fields
-
-tcConArg :: ContextKind  -- expected kind for args; always OpenKind for datatypes,
-                         -- but might be an unlifted type with UnliftedNewtypes
-         -> HsScaled GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang)
-tcConArg exp_kind (HsScaled w bty)
-  = do  { traceTc "tcConArg 1" (ppr bty)
-        ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind
-        ; w' <- tcDataConMult w
-        ; traceTc "tcConArg 2" (ppr bty)
-        ; return (Scaled w' arg_ty, getBangStrictness bty) }
-
-tcRecConDeclFields :: ContextKind
-                   -> LocatedL [LConDeclField GhcRn]
-                   -> TcM [(Scaled TcType, HsSrcBang)]
-tcRecConDeclFields exp_kind fields
-  = mapM (tcConArg exp_kind) btys
-  where
-    -- We need a one-to-one mapping from field_names to btys
-    combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f)))
-                   (unLoc fields)
-    explode (ns,ty) = zip ns (repeat ty)
-    exploded = concatMap explode combined
-    (_,btys) = unzip exploded
-
-tcDataConMult :: HsArrow GhcRn -> TcM Mult
-tcDataConMult arr@(HsUnrestrictedArrow _) = do
-  -- See Note [Function arrows in GADT constructors]
-  linearEnabled <- xoptM LangExt.LinearTypes
-  if linearEnabled then tcMult arr else return oneDataConTy
-tcDataConMult arr = tcMult arr
-
-{-
-Note [Function arrows in GADT constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In the absence of -XLinearTypes, we always interpret function arrows
-in GADT constructor types as linear, even if the user wrote an
-unrestricted arrow. See the "Without -XLinearTypes" section of the
-linear types GHC proposal (#111). We opt to do this in the
-typechecker, and not in an earlier pass, to ensure that the AST
-matches what the user wrote (#18791).
-
-Note [Infix GADT constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We do not currently have syntax to declare an infix constructor in GADT syntax,
-but it makes a (small) difference to the Show instance.  So as a slightly
-ad-hoc solution, we regard a GADT data constructor as infix if
-  a) it is an operator symbol
-  b) it has two arguments
-  c) there is a fixity declaration for it
-For example:
-   infix 6 (:--:)
-   data T a where
-     (:--:) :: t1 -> t2 -> T Int
-
-
-Note [rejigConRes]
-~~~~~~~~~~~~~~~~~~
-There is a delicacy around checking the return types of a datacon. The
-central problem is dealing with a declaration like
-
-  data T a where
-    MkT :: T a -> Q a
-
-Note that the return type of MkT is totally bogus. When creating the T
-tycon, we also need to create the MkT datacon, which must have a "rejigged"
-return type. That is, the MkT datacon's type must be transformed to have
-a uniform return type with explicit coercions for GADT-like type parameters.
-This rejigging is what rejigConRes does. The problem is, though, that checking
-that the return type is appropriate is much easier when done over *Type*,
-not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully
-defined yet.
-
-So, we want to make rejigConRes lazy and then check the validity of
-the return type in checkValidDataCon.  To do this we /always/ return a
-6-tuple from rejigConRes (so that we can compute the return type from it, which
-checkValidDataCon needs), but the first three fields may be bogus if
-the return type isn't valid (the last equation for rejigConRes).
-
-This is better than an earlier solution which reduced the number of
-errors reported in one pass.  See #7175, and #10836.
--}
-
--- Example
---   data instance T (b,c) where
---      TI :: forall e. e -> T (e,e)
---
--- The representation tycon looks like this:
---   data :R7T b c where
---      TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1
--- In this case orig_res_ty = T (e,e)
-
-rejigConRes :: [KnotTied TyConBinder]  -- Template for result type; e.g.
-            -> KnotTied Type           -- data instance T [a] b c ...
-                                       --      gives template ([a,b,c], T [a] b c)
-            -> [InvisTVBinder]    -- The constructor's type variables (both inferred and user-written)
-            -> KnotTied Type      -- res_ty
-            -> ([TyVar],          -- Universal
-                [TyVar],          -- Existential (distinct OccNames from univs)
-                [InvisTVBinder],  -- The constructor's rejigged, user-written
-                                  -- type variables
-                [EqSpec],         -- Equality predicates
-                Subst)            -- Substitution to apply to argument types
-        -- We don't check that the TyCon given in the ResTy is
-        -- the same as the parent tycon, because checkValidDataCon will do it
--- NB: All arguments may potentially be knot-tied
-rejigConRes tc_tvbndrs res_tmpl dc_tvbndrs res_ty
-        -- E.g.  data T [a] b c where
-        --         MkT :: forall x y z. T [(x,y)] z z
-        -- The {a,b,c} are the tc_tvs, and the {x,y,z} are the dc_tvs
-        --     (NB: unlike the H98 case, the dc_tvs are not all existential)
-        -- Then we generate
-        --      Univ tyvars     Eq-spec
-        --          a              a~(x,y)
-        --          b              b~z
-        --          z
-        -- Existentials are the leftover type vars: [x,y]
-        -- The user-written type variables are what is listed in the forall:
-        --   [x, y, z] (all specified). We must rejig these as well.
-        --   See Note [DataCon user type variable binders] in GHC.Core.DataCon.
-        -- So we return ( [a,b,z], [x,y]
-        --              , [], [x,y,z]
-        --              , [a~(x,y),b~z], <arg-subst> )
-  | Just subst <- tcMatchTy res_tmpl res_ty
-  = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tc_tvs dc_tvs subst
-        raw_ex_tvs = dc_tvs `minusList` univ_tvs
-        (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs
-
-        -- After rejigging the existential tyvars, the resulting substitution
-        -- gives us exactly what we need to rejig the user-written tyvars,
-        -- since the dcUserTyVarBinders invariant guarantees that the
-        -- substitution has *all* the tyvars in its domain.
-        -- See Note [DataCon user type variable binders] in GHC.Core.DataCon.
-        subst_user_tvs  = mapVarBndrs (substTyVarToTyVar arg_subst)
-        substed_tvbndrs = subst_user_tvs dc_tvbndrs
-
-        substed_eqs = [ mkEqSpec (substTyVarToTyVar arg_subst tv)
-                                 (substTy arg_subst ty)
-                      | (tv,ty) <- raw_eqs ]
-    in
-    (univ_tvs, substed_ex_tvs, substed_tvbndrs, substed_eqs, arg_subst)
-
-  | otherwise
-        -- If the return type of the data constructor doesn't match the parent
-        -- type constructor, or the arity is wrong, the tcMatchTy will fail
-        --    e.g   data T a b where
-        --            T1 :: Maybe a   -- Wrong tycon
-        --            T2 :: T [a]     -- Wrong arity
-        -- We are detect that later, in checkValidDataCon, but meanwhile
-        -- we must do *something*, not just crash.  So we do something simple
-        -- albeit bogus, relying on checkValidDataCon to check the
-        --  bad-result-type error before seeing that the other fields look odd
-        -- See Note [rejigConRes]
-  = (tc_tvs, dc_tvs `minusList` tc_tvs, dc_tvbndrs, [], emptySubst)
-  where
-    dc_tvs = binderVars dc_tvbndrs
-    tc_tvs = binderVars tc_tvbndrs
-
-{- Note [mkGADTVars]
-~~~~~~~~~~~~~~~~~~~~
-Running example:
-
-data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where
-  MkT :: forall (x1 : *) (y :: x1) (z :: *).
-         T x1 * (Proxy (y :: x1), z) z
-
-We need the rejigged type to be
-
-  MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2).
-         forall (y :: x1) (z :: *).
-         (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z)
-      => T x1 k2 a b
-
-You might naively expect that z should become a universal tyvar,
-not an existential. (After all, x1 becomes a universal tyvar.)
-But z has kind * while b has kind k2, so the return type
-   T x1 k2 a z
-is ill-kinded.  Another way to say it is this: the universal
-tyvars must have exactly the same kinds as the tyConTyVars.
-
-So we need an existential tyvar and a heterogeneous equality
-constraint. (The b ~ z is a bit redundant with the k2 ~ * that
-comes before in that b ~ z implies k2 ~ *. I'm sure we could do
-some analysis that could eliminate k2 ~ *. But we don't do this
-yet.)
-
-The data con signature has already been fully kind-checked.
-The return type
-
-  T x1 * (Proxy (y :: x1), z) z
-becomes
-  qtkvs    = [x1 :: *, y :: x1, z :: *]
-  res_tmpl = T x1 * (Proxy x1 y, z) z
-
-We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We
-know this match will succeed because of the validity check (actually done
-later, but laziness saves us -- see Note [rejigConRes]).
-Thus, we get
-
-  subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z }
-
-Now, we need to figure out what the GADT equalities should be. In this case,
-we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a
-renaming. The others should be GADT equalities. We also need to make
-sure that the universally-quantified variables of the datacon match up
-with the tyvars of the tycon, as required for Core context well-formedness.
-(This last bit is why we have to rejig at all!)
-
-`choose` walks down the tycon tyvars, figuring out what to do with each one.
-It carries two substitutions:
-  - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables
-    mentioned in the datacon signature.
-  - r_sub's domain is *result* tyvars, names written by the programmer in
-    the datacon signature. The final rejigged type will use these names, but
-    the subst is still needed because sometimes the printed name of these variables
-    is different. (See choose_tv_name, below.)
-
-Before explaining the details of `choose`, let's just look at its operation
-on our example:
-
-  choose [] [] {} {} [k1, k2, a, b]
-  -->          -- first branch of `case` statement
-  choose
-    univs:    [x1 :: *]
-    eq_spec:  []
-    t_sub:    {k1 |-> x1}
-    r_sub:    {x1 |-> x1}
-    t_tvs:    [k2, a, b]
-  -->          -- second branch of `case` statement
-  choose
-    univs:    [k2 :: *, x1 :: *]
-    eq_spec:  [k2 ~ *]
-    t_sub:    {k1 |-> x1, k2 |-> k2}
-    r_sub:    {x1 |-> x1}
-    t_tvs:    [a, b]
-  -->          -- second branch of `case` statement
-  choose
-    univs:    [a :: k2, k2 :: *, x1 :: *]
-    eq_spec:  [ a ~ (Proxy x1 y, z)
-              , k2 ~ * ]
-    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a}
-    r_sub:    {x1 |-> x1}
-    t_tvs:    [b]
-  -->          -- second branch of `case` statement
-  choose
-    univs:    [b :: k2, a :: k2, k2 :: *, x1 :: *]
-    eq_spec:  [ b ~ z
-              , a ~ (Proxy x1 y, z)
-              , k2 ~ * ]
-    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z}
-    r_sub:    {x1 |-> x1}
-    t_tvs:    []
-  -->          -- end of recursion
-  ( [x1 :: *, k2 :: *, a :: k2, b :: k2]
-  , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z]
-  , {x1 |-> x1} )
-
-`choose` looks up each tycon tyvar in the matching (it *must* be matched!).
-
-* If it finds a bare result tyvar (the first branch of the `case`
-  statement), it checks to make sure that the result tyvar isn't yet
-  in the list of univ_tvs.  If it is in that list, then we have a
-  repeated variable in the return type, and we in fact need a GADT
-  equality.
-
-* It then checks to make sure that the kind of the result tyvar
-  matches the kind of the template tyvar. This check is what forces
-  `z` to be existential, as it should be, explained above.
-
-* Assuming no repeated variables or kind-changing, we wish to use the
-  variable name given in the datacon signature (that is, `x1` not
-  `k1`), not the tycon signature (which may have been made up by
-  GHC). So, we add a mapping from the tycon tyvar to the result tyvar
-  to t_sub.
-
-* If we discover that a mapping in `subst` gives us a non-tyvar (the
-  second branch of the `case` statement), then we have a GADT equality
-  to create.  We create a fresh equality, but we don't extend any
-  substitutions. The template variable substitution is meant for use
-  in universal tyvar kinds, and these shouldn't be affected by any
-  GADT equalities.
-
-This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways
-of simplifying it:
-
-1) The first branch of the `case` statement is really an optimization, used
-in order to get fewer GADT equalities. It might be possible to make a GADT
-equality for *every* univ. tyvar, even if the equality is trivial, and then
-either deal with the bigger type or somehow reduce it later.
-
-2) This algorithm strives to use the names for type variables as specified
-by the user in the datacon signature. If we always used the tycon tyvar
-names, for example, this would be simplified. This change would almost
-certainly degrade error messages a bit, though.
--}
-
--- ^ From information about a source datacon definition, extract out
--- what the universal variables and the GADT equalities should be.
--- See Note [mkGADTVars].
-mkGADTVars :: [TyVar]    -- ^ The tycon vars
-           -> [TyVar]    -- ^ The datacon vars
-           -> Subst   -- ^ The matching between the template result type
-                         -- and the actual result type
-           -> ( [TyVar]
-              , [(TyVar,Type)]   -- The un-substituted eq-spec
-              , Subst ) -- ^ The univ. variables, the GADT equalities,
-                           -- and a subst to apply to the GADT equalities
-                           -- and existentials.
-mkGADTVars tmpl_tvs dc_tvs subst
-  = choose [] [] empty_subst empty_subst tmpl_tvs
-  where
-    in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs)
-               `unionInScope` getSubstInScope subst
-    empty_subst = mkEmptySubst in_scope
-
-    choose :: [TyVar]        -- accumulator of univ tvs, reversed
-           -> [(TyVar,Type)] -- accumulator of GADT equalities, reversed
-           -> Subst          -- template substitution
-           -> Subst          -- res. substitution
-           -> [TyVar]           -- template tvs (the univ tvs passed in)
-           -> ( [TyVar]         -- the univ_tvs
-              , [(TyVar,Type)]  -- GADT equalities
-              , Subst )       -- a substitution to fix kinds in ex_tvs
-
-    choose univs eqs _t_sub r_sub []
-      = (reverse univs, reverse eqs, r_sub)
-    choose univs eqs t_sub r_sub (t_tv:t_tvs)
-      | Just r_ty <- lookupTyVar subst t_tv
-      = case getTyVar_maybe r_ty of
-          Just r_tv
-            |  not (r_tv `elem` univs)
-            ,  tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv))
-            -> -- simple, well-kinded variable substitution.
-               -- the name of the universal comes from the result of the ctor
-               -- see (R2) of Note [DataCon user type variable binders] in GHC.Core.DataCon
-               choose (r_tv:univs) eqs
-                      (extendTvSubst t_sub t_tv r_ty')
-                      (extendTvSubst r_sub r_tv r_ty')
-                      t_tvs
-            where
-              r_tv1  = setTyVarName r_tv (choose_tv_name r_tv t_tv)
-              r_ty'  = mkTyVarTy r_tv1
-
-               -- Not a simple substitution: make an equality predicate
-               -- the name of the universal comes from the datatype header
-               -- see (R2) of Note [DataCon user type variable binders] in GHC.Core.DataCon
-          _ -> choose (t_tv':univs) eqs'
-                      (extendTvSubst t_sub t_tv (mkTyVarTy t_tv'))
-                         -- We've updated the kind of t_tv,
-                         -- so add it to t_sub (#14162)
-                      r_sub t_tvs
-            where
-              tv_kind  = tyVarKind t_tv
-              tv_kind' = substTy t_sub tv_kind
-              t_tv'    = setTyVarKind t_tv tv_kind'
-              eqs' | isConstraintLikeKind (typeKind tv_kind') = eqs
-                   | otherwise = (t_tv', r_ty) : eqs
-
-      | otherwise
-      = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst)
-
-      -- choose an appropriate name for a univ tyvar.
-      -- This *must* preserve the Unique of the result tv, so that we
-      -- can detect repeated variables. It prefers user-specified names
-      -- over system names. A result variable with a system name can
-      -- happen with GHC-generated implicit kind variables.
-    choose_tv_name :: TyVar -> TyVar -> Name
-    choose_tv_name r_tv t_tv
-      | isSystemName r_tv_name
-      = setNameUnique t_tv_name (getUnique r_tv_name)
-
-      | otherwise
-      = r_tv_name
-
-      where
-        r_tv_name = getName r_tv
-        t_tv_name = getName t_tv
-
-{-
-Note [Substitution in template variables kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-data G (a :: Maybe k) where
-  MkG :: G Nothing
-
-With explicit kind variables
-
-data G k (a :: Maybe k) where
-  MkG :: G k1 (Nothing k1)
-
-Note how k1 is distinct from k. So, when we match the template
-`G k a` against `G k1 (Nothing k1)`, we get a subst
-[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two
-mappings, we surely don't want to add (k, k1) to the list of
-GADT equalities -- that would be overly complex and would create
-more untouchable variables than we need. So, when figuring out
-which tyvars are GADT-like and which aren't (the fundamental
-job of `choose`), we want to treat `k` as *not* GADT-like.
-Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1)
-instead of (a :: Maybe k). This is the reason for dealing
-with a substitution in here.
-
-However, we do not *always* want to substitute. Consider
-
-data H (a :: k) where
-  MkH :: H Int
-
-With explicit kind variables:
-
-data H k (a :: k) where
-  MkH :: H * Int
-
-Here, we have a kind-indexed GADT. The subst in question is
-[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s
-kind, because that would give a constructor with the type
-
-MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a
-
-The problem here is that a's kind is wrong -- it needs to be k, not *!
-So, if the matching for a variable is anything but another bare variable,
-we drop the mapping from the substitution before proceeding. This
-was not an issue before kind-indexed GADTs because this case could
-never happen.
-
-************************************************************************
-*                                                                      *
-                Validity checking
-*                                                                      *
-************************************************************************
-
-Validity checking is done once the mutually-recursive knot has been
-tied, so we can look at things freely.
--}
-
-checkValidTyCl :: TyCon -> TcM [TyCon]
--- The returned list is either a singleton (if valid)
--- or a list of "fake tycons" (if not); the fake tycons
--- include any implicits, like promoted data constructors
--- See Note [Recover from validity error]
-checkValidTyCl tc
-  = setSrcSpan (getSrcSpan tc) $
-    addTyConCtxt tc            $
-    recoverM recovery_code     $
-    do { traceTc "Starting validity for tycon" (ppr tc)
-       ; checkValidTyCon tc
-       ; traceTc "Done validity for tycon" (ppr tc)
-       ; return [tc] }
-  where
-    recovery_code -- See Note [Recover from validity error]
-      = do { traceTc "Aborted validity for tycon" (ppr tc)
-           ; return (map mk_fake_tc $
-                     tc : child_tycons tc) }
-
-    mk_fake_tc tc
-      | isClassTyCon tc = tc   -- Ugh! Note [Recover from validity error]
-      | otherwise       = makeRecoveryTyCon tc
-
-    child_tycons tc = tyConATs tc ++ map promoteDataCon (tyConDataCons tc)
-
-{- Note [Recover from validity error]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We recover from a validity error in a type or class, which allows us
-to report multiple validity errors. In the failure case we return a
-TyCon of the right kind, but with no interesting behaviour
-(makeRecoveryTyCon). Why?  Suppose we have
-   type T a = Fun
-where Fun is a type family of arity 1.  The RHS is invalid, but we
-want to go on checking validity of subsequent type declarations.
-So we replace T with an abstract TyCon which will do no harm.
-See indexed-types/should_fail/BadSock and #10896
-
-Some notes:
-
-* We must make fakes for promoted DataCons too. Consider (#15215)
-      data T a = MkT ...
-      data S a = ...T...MkT....
-  If there is an error in the definition of 'T' we add a "fake type
-  constructor" to the type environment, so that we can continue to
-  typecheck 'S'.  But we /were not/ adding a fake anything for 'MkT'
-  and so there was an internal error when we met 'MkT' in the body of
-  'S'.
-
-  Similarly for associated types.
-
-* Painfully, we *don't* want to do this for classes.
-  Consider tcfail041:
-     class (?x::Int) => C a where ...
-     instance C Int
-  The class is invalid because of the superclass constraint.  But
-  we still want it to look like a /class/, else the instance bleats
-  that the instance is mal-formed because it hasn't got a class in
-  the head.
-
-  This is really bogus; now we have in scope a Class that is invalid
-  in some way, with unknown downstream consequences.  A better
-  alternative might be to make a fake class TyCon.  A job for another day.
-
-* Previously, we used implicitTyConThings to snaffle out the parts
-  to add to the context. The problem is that this also grabs data con
-  wrapper Ids. These could be filtered out. But, painfully, getting
-  the wrapper Ids checks the DataConRep, and forcing the DataConRep
-  can panic if there is a representation-polymorphic argument. This is #18534.
-  We don't need the wrapper Ids here anyway. So the code just takes what
-  it needs, via child_tycons.
--}
-
--------------------------
--- For data types declared with record syntax, we require
--- that each constructor that has a field 'f'
---      (a) has the same result type
---      (b) has the same type for 'f'
--- module alpha conversion of the quantified type variables
--- of the constructor.
---
--- Note that we allow existentials to match because the
--- fields can never meet. E.g
---      data T where
---        T1 { f1 :: b, f2 :: a, f3 ::Int } :: T
---        T2 { f1 :: c, f2 :: c, f3 ::Int } :: T
--- Here we do not complain about f1,f2 because they are existential
-
-checkValidTyCon :: TyCon -> TcM ()
-checkValidTyCon tc
-  | isPrimTyCon tc   -- Happens when Haddock'ing GHC.Prim
-  = return ()
-
-  | isWiredIn tc     -- validity-checking wired-in tycons is a waste of
-                     -- time. More importantly, a wired-in tycon might
-                     -- violate assumptions. Example: (~) has a superclass
-                     -- mentioning (~#), which is ill-kinded in source Haskell
-  = traceTc "Skipping validity check for wired-in" (ppr tc)
-
-  | otherwise
-  = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc))
-       ; if | Just cl <- tyConClass_maybe tc
-              -> checkValidClass cl
-
-            | Just syn_rhs <- synTyConRhs_maybe tc
-              -> do { checkValidType syn_ctxt syn_rhs
-                    ; checkTySynRhs syn_ctxt syn_rhs }
-
-            | Just fam_flav <- famTyConFlav_maybe tc
-              -> case fam_flav of
-               { ClosedSynFamilyTyCon (Just ax)
-                   -> tcAddClosedTypeFamilyDeclCtxt tc $
-                      checkValidCoAxiom ax
-               ; ClosedSynFamilyTyCon Nothing   -> return ()
-               ; AbstractClosedSynFamilyTyCon ->
-                 do { hsBoot <- tcIsHsBootOrSig
-                    ; checkTc hsBoot $ mkTcRnUnknownMessage $ mkPlainError noHints $
-                      text "You may define an abstract closed type family" $$
-                      text "only in a .hs-boot file" }
-               ; DataFamilyTyCon {}           -> return ()
-               ; OpenSynFamilyTyCon           -> return ()
-               ; BuiltInSynFamTyCon _         -> return () }
-
-             | otherwise -> do
-               { -- Check the context on the data decl
-                 traceTc "cvtc1" (ppr tc)
-               ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
-
-               ; traceTc "cvtc2" (ppr tc)
-
-               ; dflags          <- getDynFlags
-               ; existential_ok  <- xoptM LangExt.ExistentialQuantification
-               ; gadt_ok         <- xoptM LangExt.GADTs
-               ; let ex_ok = existential_ok || gadt_ok
-                     -- Data cons can have existential context
-               ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons
-               ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc)
-
-                -- Check that fields with the same name share a type
-               ; mapM_ check_fields groups }}
-  where
-    syn_ctxt  = TySynCtxt name
-    name      = tyConName tc
-    data_cons = tyConDataCons tc
-
-    groups = equivClasses cmp_fld (concatMap get_fields data_cons)
-    -- This spot seems OK with non-determinism. cmp_fld is used only in equivClasses
-    -- which produces equivalence classes.
-    -- The order of these equivalence classes might conceivably (non-deterministically)
-    -- depend on the result of this comparison, but that just affects the order in which
-    -- fields are checked for compatibility. It will not affect the compiled binary.
-    cmp_fld (f1,_) (f2,_) = field_label (flLabel f1) `uniqCompareFS` field_label (flLabel f2)
-    get_fields con = dataConFieldLabels con `zip` repeat con
-        -- dataConFieldLabels may return the empty list, which is fine
-
-    -- See Note [GADT record selectors] in GHC.Tc.TyCl.Utils
-    -- We must check (a) that the named field has the same
-    --                   type in each constructor
-    --               (b) that those constructors have the same result type
-    --
-    -- However, the constructors may have differently named type variable
-    -- and (worse) we don't know how the correspond to each other.  E.g.
-    --     C1 :: forall a b. { f :: a, g :: b } -> T a b
-    --     C2 :: forall d c. { f :: c, g :: c } -> T c d
-    --
-    -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's
-    -- result type against other candidates' types BOTH WAYS ROUND.
-    -- If they magically agrees, take the substitution and
-    -- apply them to the latter ones, and see if they match perfectly.
-    check_fields ((label, con1) :| other_fields)
-        -- These fields all have the same name, but are from
-        -- different constructors in the data type
-        = recoverM (return ()) $ mapM_ checkOne other_fields
-                -- Check that all the fields in the group have the same type
-                -- NB: this check assumes that all the constructors of a given
-                -- data type use the same type variables
-        where
-        res1 = dataConOrigResTy con1
-        fty1 = dataConFieldType con1 lbl
-        lbl = flLabel label
-
-        checkOne (_, con2)    -- Do it both ways to ensure they are structurally identical
-            = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2
-                 ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 }
-            where
-                res2 = dataConOrigResTy con2
-                fty2 = dataConFieldType con2 lbl
-
-checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM ()
--- Checks the partial record field selector, and warns.
--- See Note [Checking partial record field]
-checkPartialRecordField all_cons fld
-  = setSrcSpan loc $
-      warnIf (not is_exhaustive && not (startsWithUnderscore occ_name))
-        (mkTcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnPartialFields) noHints $
-          sep [text "Use of partial record field selector" <> colon,
-                nest 2 $ quotes (ppr occ_name)])
-  where
-    loc = getSrcSpan (flSelector fld)
-    occ_name = occName fld
-
-    (cons_with_field, cons_without_field) = partition has_field all_cons
-    has_field con = fld `elem` (dataConFieldLabels con)
-    is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field
-
-    con1 = assert (not (null cons_with_field)) $ head cons_with_field
-    inst_tys = dataConResRepTyArgs con1
-
-checkFieldCompat :: FieldLabelString -> DataCon -> DataCon
-                 -> Type -> Type -> Type -> Type -> TcM ()
-checkFieldCompat fld con1 con2 res1 res2 fty1 fty2
-  = do  { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
-        ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
-  where
-    mb_subst1 = tcMatchTy res1 res2
-    mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
-
--------------------------------
-checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()
-checkValidDataCon dflags existential_ok tc con
-  = setSrcSpan con_loc $
-    addErrCtxt (dataConCtxt (NE.singleton (L (noAnnSrcSpan con_loc) con_name))) $
-    do  { let tc_tvs      = tyConTyVars tc
-              res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
-              arg_tys     = dataConOrigArgTys con
-              orig_res_ty = dataConOrigResTy  con
-
-        ; traceTc "checkValidDataCon" (vcat
-              [ ppr con, ppr tc, ppr tc_tvs
-              , ppr res_ty_tmpl <+> dcolon <+> ppr (typeKind res_ty_tmpl)
-              , ppr orig_res_ty <+> dcolon <+> ppr (typeKind orig_res_ty)])
-
-
-        -- Check that the return type of the data constructor
-        -- matches the type constructor; eg reject this:
-        --   data T a where { MkT :: Bogus a }
-        -- It's important to do this first:
-        --  see Note [rejigConRes]
-        --  and c.f. Note [Check role annotations in a second pass]
-
-        -- Check that the return type of the data constructor is an instance
-        -- of the header of the header of data decl.  This checks for
-        --      data T a where { MkT :: S a }
-        --      data instance D [a] where { MkD :: D (Maybe b) }
-        -- see Note [GADT return types]
-        ; checkTc (isJust (tcMatchTyKi res_ty_tmpl orig_res_ty))
-                  (badDataConTyCon con res_ty_tmpl)
-            -- Note that checkTc aborts if it finds an error. This is
-            -- critical to avoid panicking when we call dataConDisplayType
-            -- on an un-rejiggable datacon!
-            -- Also NB that we match the *kind* as well as the *type* (#18357)
-            -- However, if the kind is the only thing that doesn't match, the
-            -- error message is terrible.  E.g. test T18357b
-            --    type family Star where Star = Type
-            --    newtype T :: Type where MkT :: Int -> (T :: Star)
-
-        ; traceTc "checkValidDataCon 2" (ppr data_con_display_type)
-
-          -- Check that the result type is a *monotype*
-          --  e.g. reject this:   MkT :: T (forall a. a->a)
-          -- Reason: it's really the argument of an equality constraint
-        ; checkValidMonoType orig_res_ty
-
-        -- Check for an escaping result kind
-        -- See Note [Check for escaping result kind]
-        ; checkEscapingKind con
-
-        -- For /data/ types check that each argument has a fixed runtime rep
-        -- If we are dealing with a /newtype/, we allow representation
-        -- polymorphism regardless of whether or not UnliftedNewtypes
-        -- is enabled. A later check in checkNewDataCon handles this,
-        -- producing a better error message than checkTypeHasFixedRuntimeRep would.
-        ; let check_rr = checkTypeHasFixedRuntimeRep FixedRuntimeRepDataConField
-        ; unless (isNewTyCon tc) $
-          checkNoErrs            $
-          mapM_ (check_rr . scaledThing) arg_tys
-            -- The checkNoErrs is to prevent a panic in isVanillaDataCon
-            -- (called a a few lines down), which can fall over if there is a
-            -- bang on a representation-polymorphic argument. This is #18534,
-            -- typecheck/should_fail/T18534
-
-          -- Extra checks for newtype data constructors. Importantly, these
-          -- checks /must/ come before the call to checkValidType below. This
-          -- is because checkValidType invokes the constraint solver, and
-          -- invoking the solver on an ill formed newtype constructor can
-          -- confuse GHC to the point of panicking. See #17955 for an example.
-        ; when (isNewTyCon tc) (checkNewDataCon con)
-
-          -- Check all argument types for validity
-        ; checkValidType ctxt data_con_display_type
-
-          -- Check that existentials are allowed if they are used
-        ; checkTc (existential_ok || isVanillaDataCon con)
-                  (badExistential con)
-
-          -- Check that the only constraints in signatures of constructors
-          -- in a "type data" declaration are equality constraints.
-          -- See Note [Type data declarations] in GHC.Rename.Module,
-          -- restriction (R4).
-        ; when (isTypeDataCon con) $
-          checkTc (all isEqPred (dataConOtherTheta con))
-                  (TcRnConstraintInKind (dataConRepType con))
-
-          -- Check that UNPACK pragmas and bangs work out
-          -- E.g.  reject   data T = MkT {-# UNPACK #-} Int     -- No "!"
-          --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack
-        ; hsc_env <- getTopEnv
-        ; let check_bang :: Type -> HsSrcBang -> HsImplBang -> Int -> TcM ()
-              check_bang orig_arg_ty bang rep_bang n
-               | HsSrcBang _ _ SrcLazy <- bang
-               , not (bang_opt_strict_data bang_opts)
-               = addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-                 (bad_bang n (text "Lazy annotation (~) without StrictData"))
-
-               | HsSrcBang _ want_unpack strict_mark <- bang
-               , isSrcUnpacked want_unpack, not (is_strict strict_mark)
-               , not (isUnliftedType orig_arg_ty)
-               = addDiagnosticTc $ mkTcRnUnknownMessage $
-                   mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "UNPACK pragma lacks '!'"))
-
-               -- Warn about a redundant ! on an unlifted type
-               -- e.g.   data T = MkT !Int#
-               | HsSrcBang _ _ SrcStrict <- bang
-               , isUnliftedType orig_arg_ty
-               = addDiagnosticTc $ TcRnBangOnUnliftedType orig_arg_ty
-
-               -- Warn about a ~ on an unlifted type (#21951)
-               -- e.g.   data T = MkT ~Int#
-               | HsSrcBang _ _ SrcLazy <- bang
-               , isUnliftedType orig_arg_ty
-               = addDiagnosticTc $ TcRnLazyBangOnUnliftedType orig_arg_ty
-
-               | HsSrcBang _ want_unpack _ <- bang
-               , isSrcUnpacked want_unpack
-               , case rep_bang of { HsUnpack {} -> False; _ -> True }
-               -- If not optimising, we don't unpack (rep_bang is never
-               -- HsUnpack), so don't complain!  This happens, e.g., in Haddock.
-               -- See dataConSrcToImplBang.
-               , not (bang_opt_unbox_disable bang_opts)
-               -- When typechecking an indefinite package in Backpack, we
-               -- may attempt to UNPACK an abstract type.  The test here will
-               -- conclude that this is unusable, but it might become usable
-               -- when we actually fill in the abstract type.  As such, don't
-               -- warn in this case (it gives users the wrong idea about whether
-               -- or not UNPACK on abstract types is supported; it is!)
-               , isHomeUnitDefinite (hsc_home_unit hsc_env)
-               = addDiagnosticTc $ mkTcRnUnknownMessage $
-                   mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "Ignoring unusable UNPACK pragma"))
-
-               | otherwise
-               = return ()
-
-        ; void $ zipWith4M check_bang (map scaledThing $ dataConOrigArgTys con)
-          (dataConSrcBangs con) (dataConImplBangs con) [1..]
-
-          -- Check the dcUserTyVarBinders invariant
-          -- See Note [DataCon user type variable binders] in GHC.Core.DataCon
-          -- checked here because we sometimes build invalid DataCons before
-          -- erroring above here
-        ; when debugIsOn $
-          massertPpr (checkDataConTyVars con) $
-          ppr con $$  ppr (dataConFullSig con) $$ ppr (dataConUserTyVars con)
-
-        ; traceTc "Done validity of data con" $
-          vcat [ ppr con
-               , text "Datacon wrapper type:" <+> ppr (dataConWrapperType con)
-               , text "Datacon rep type:" <+> ppr (dataConRepType con)
-               , text "Datacon display type:" <+> ppr data_con_display_type
-               , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con))
-               , case tyConFamInst_maybe (dataConTyCon con) of
-                   Nothing -> text "not family"
-                   Just (f, _) -> ppr (tyConBinders f) ]
-    }
-  where
-    bang_opts = initBangOpts dflags
-    con_name  = dataConName con
-    con_loc   = nameSrcSpan con_name
-    ctxt      = ConArgCtxt con_name
-    is_strict = \case
-      NoSrcStrict -> bang_opt_strict_data bang_opts
-      bang        -> isSrcStrict bang
-
-    bad_bang n herald
-      = hang herald 2 (text "on the" <+> speakNth n
-                       <+> text "argument of" <+> quotes (ppr con))
-
-    show_linear_types     = xopt LangExt.LinearTypes dflags
-    data_con_display_type = dataConDisplayType show_linear_types con
-
--------------------------------
-checkNewDataCon :: DataCon -> TcM ()
--- Further checks for the data constructor of a newtype
--- You might wonder if we need to check for an unlifted newtype
--- without -XUnliftedNewTypes, such as
---   newtype C = MkC Int#
--- But they are caught earlier, by GHC.Tc.Gen.HsType.checkDataKindSig
-checkNewDataCon con
-  = do  { show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags
-
-        ; checkTc (isSingleton arg_tys) $
-          TcRnIllegalNewtype con show_linear_types (DoesNotHaveSingleField $ length arg_tys)
-
-        ; checkTc (ok_mult (scaledMult arg_ty1)) $
-          TcRnIllegalNewtype con show_linear_types IsNonLinear
-
-        ; checkTc (null eq_spec) $
-          TcRnIllegalNewtype con show_linear_types IsGADT
-
-        ; checkTc (null theta) $
-          TcRnIllegalNewtype con show_linear_types HasConstructorContext
-
-        ; checkTc (null ex_tvs) $
-          TcRnIllegalNewtype con show_linear_types HasExistentialTyVar
-
-        ; checkTc (all ok_bang (dataConSrcBangs con)) $
-          TcRnIllegalNewtype con show_linear_types HasStrictnessAnnotation
-    }
-  where
-    (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)
-      = dataConFullSig con
-
-    (arg_ty1 : _) = arg_tys
-
-    ok_bang (HsSrcBang _ _ SrcStrict) = False
-    ok_bang (HsSrcBang _ _ SrcLazy)   = False
-    ok_bang _                         = True
-
-    ok_mult OneTy = True
-    ok_mult _     = False
-
-
--- | Reject nullary data constructors where a type variable
--- would escape through the result kind
--- See Note [Check for escaping result kind]
-checkEscapingKind :: DataCon -> TcM ()
-checkEscapingKind data_con
-  | null eq_spec, null theta, null arg_tys
-  , let tau_kind = typeKind res_ty
-  , Nothing <- occCheckExpand (univ_tvs ++ ex_tvs) tau_kind
-    -- Ensure that none of the tvs occur in the kind of the forall
-    -- /after/ expanding type synonyms.
-    -- See Note [Phantom type variables in kinds] in GHC.Core.Type
-  = failWithTc $ TcRnForAllEscapeError (dataConWrapperType data_con) tau_kind
-  | otherwise
-  = return ()
-  where
-    (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)
-      = dataConFullSig data_con
-
-{- Note [Check for escaping result kind]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider:
-  type T :: TYPE (BoxedRep l)
-  data T = MkT
-This is not OK: we get
-  MkT :: forall l. T @l :: TYPE (BoxedRep l)
-which is ill-kinded.
-
-For ordinary type signatures f :: blah, we make this check as part of kind-checking
-the type signature; see Note [Escaping kind in type signatures] in GHC.Tc.Gen.HsType.
-But for data constructors we check the type piecemeal, and there is no very
-convenient place to do it.  For example, note that it only applies for /nullary/
-constructors.  If we had
-  data T = MkT Int
-then the type of MkT would be MkT :: forall l. Int -> T @l, which is fine.
-
-So we make the check in checkValidDataCon.
-
-Historical note: we used to do the check in checkValidType (#20929 discusses).
--}
-
--------------------------------
-checkValidClass :: Class -> TcM ()
-checkValidClass cls
-  = do  { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods
-        ; multi_param_type_classes  <- xoptM LangExt.MultiParamTypeClasses
-        ; nullary_type_classes      <- xoptM LangExt.NullaryTypeClasses
-        ; fundep_classes            <- xoptM LangExt.FunctionalDependencies
-        ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses
-
-        -- Check that the class is unary, unless multiparameter type classes
-        -- are enabled; also recognize deprecated nullary type classes
-        -- extension (subsumed by multiparameter type classes, #8993)
-        ; checkTc (multi_param_type_classes || cls_arity == 1 ||
-                    (nullary_type_classes && cls_arity == 0))
-                  (classArityErr cls_arity cls)
-        ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)
-
-        -- Check the super-classes
-        ; checkValidTheta (ClassSCCtxt (className cls)) theta
-
-          -- Now check for cyclic superclasses
-          -- If there are superclass cycles, checkClassCycleErrs bails.
-        ; unless undecidable_super_classes $
-          case checkClassCycles cls of
-             Just err -> setSrcSpan (getSrcSpan cls) $
-                         addErrTc (mkTcRnUnknownMessage $ mkPlainError noHints err)
-             Nothing  -> return ()
-
-        -- Check the class operations.
-        -- But only if there have been no earlier errors
-        -- See Note [Abort when superclass cycle is detected]
-        ; whenNoErrs $
-          mapM_ (check_op constrained_class_methods) op_stuff
-
-        -- Check the associated type defaults are well-formed and instantiated
-        ; mapM_ check_at at_stuff  }
-  where
-    (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls
-    cls_arity = length (tyConVisibleTyVars (classTyCon cls))
-       -- Ignore invisible variables
-    cls_tv_set = mkVarSet tyvars
-
-    check_op constrained_class_methods (sel_id, dm)
-      = setSrcSpan (getSrcSpan sel_id) $
-        addErrCtxt (classOpCtxt sel_id op_ty) $ do
-        { traceTc "class op type" (ppr op_ty)
-        ; checkValidType ctxt op_ty
-                -- This implements the ambiguity check, among other things
-                -- Example: tc223
-                --   class Error e => Game b mv e | b -> mv e where
-                --      newBoard :: MonadState b m => m ()
-                -- Here, MonadState has a fundep m->b, so newBoard is fine
-
-        -- NB: we don't check that the class method is not representation-polymorphic here,
-        -- as GHC.TcGen.TyCl.tcClassSigType already includes a subtype check that guarantees
-        -- typeclass methods always have kind 'Type'.
-        --
-        -- Test case: rep-poly/RepPolyClassMethod.
-
-        ; unless constrained_class_methods $
-          mapM_ check_constraint op_theta
-
-        ; check_dm ctxt sel_id cls_pred tau2 dm
-        }
-        where
-          ctxt    = FunSigCtxt op_name (WantRRC (getSrcSpan cls)) -- Report redundant class constraints
-          op_name = idName sel_id
-          op_ty   = idType sel_id
-          (_,cls_pred,tau1) = tcSplitMethodTy op_ty
-          -- See Note [Splitting nested sigma types in class type signatures]
-          (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1
-
-          check_constraint :: TcPredType -> TcM ()
-          check_constraint pred -- See Note [Class method constraints]
-            = when (not (isEmptyVarSet pred_tvs) &&
-                    pred_tvs `subVarSet` cls_tv_set)
-                   (addErrTc (badMethPred sel_id pred))
-            where
-              pred_tvs = tyCoVarsOfType pred
-
-    check_at (ATI fam_tc m_dflt_rhs)
-      = do { traceTc "ati" (ppr fam_tc $$ ppr tyvars $$ ppr fam_tvs)
-           ; checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)
-                     (noClassTyVarErr cls fam_tc)
-                        -- Check that the associated type mentions at least
-                        -- one of the class type variables
-                        -- The check is disabled for nullary type classes,
-                        -- since there is no possible ambiguity (#10020)
-
-             -- Check that any default declarations for associated types are valid
-           ; whenIsJust m_dflt_rhs $ \ (rhs, at_validity_info) ->
-             case at_validity_info of
-               NoATVI -> pure ()
-               ATVI loc pats ->
-                 setSrcSpan loc $
-                 tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $
-                 do { checkValidAssocTyFamDeflt fam_tc pats
-                    ; checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs }}
-        where
-          fam_tvs = tyConTyVars fam_tc
-
-    check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM ()
-    -- Check validity of the /top-level/ generic-default type
-    -- E.g for   class C a where
-    --             default op :: forall b. (a~b) => blah
-    -- we do not want to do an ambiguity check on a type with
-    -- a free TyVar 'a' (#11608).  See TcType
-    -- Note [TyVars and TcTyVars during type checking] in GHC.Tc.Utils.TcType
-    -- Hence the mkDefaultMethodType to close the type.
-    check_dm ctxt sel_id vanilla_cls_pred vanilla_tau
-             (Just (dm_name, dm_spec@(GenericDM dm_ty)))
-      = setSrcSpan (getSrcSpan dm_name) $ do
-            -- We have carefully set the SrcSpan on the generic
-            -- default-method Name to be that of the generic
-            -- default type signature
-
-          -- First, we check that the method's default type signature
-          -- aligns with the non-default type signature.
-          -- See Note [Default method type signatures must align]
-          let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls
-              -- Note that the second field of this tuple contains the context
-              -- of the default type signature, making it apparent that we
-              -- ignore method contexts completely when validity-checking
-              -- default type signatures. See the end of
-              -- Note [Default method type signatures must align]
-              -- to learn why this is OK.
-              --
-              -- See also
-              -- Note [Splitting nested sigma types in class type signatures]
-              -- for an explanation of why we don't use tcSplitSigmaTy here.
-              (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty
-
-              -- Given this class definition:
-              --
-              --  class C a b where
-              --    op         :: forall p q. (Ord a, D p q)
-              --               => a -> b -> p -> (a, b)
-              --    default op :: forall r s. E r
-              --               => a -> b -> s -> (a, b)
-              --
-              -- We want to match up two types of the form:
-              --
-              --   Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb)
-              --   Default type sig: C a  b  => a  -> b  -> s -> (a,  b)
-              --
-              -- Notice that the two type signatures can be quantified over
-              -- different class type variables! Therefore, it's important that
-              -- we include the class predicate parts to match up a with aa and
-              -- b with bb.
-              vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau
-              dm_phi_ty      = mkPhiTy [cls_pred] dm_tau
-
-          traceTc "check_dm" $ vcat
-              [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty
-              , text "dm_phi_ty"      <+> ppr dm_phi_ty ]
-
-          -- Actually checking that the types align is done with a call to
-          -- tcMatchTys. We need to get a match in both directions to rule
-          -- out degenerate cases like these:
-          --
-          --  class Foo a where
-          --    foo1         :: a -> b
-          --    default foo1 :: a -> Int
-          --
-          --    foo2         :: a -> Int
-          --    default foo2 :: a -> b
-          unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty]
-                                      [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $
-               mkTcRnUnknownMessage $ mkPlainError noHints $
-               hang (text "The default type signature for"
-                     <+> ppr sel_id <> colon)
-                 2 (ppr dm_ty)
-            $$ (text "does not match its corresponding"
-                <+> text "non-default type signature")
-
-          -- Now do an ambiguity check on the default type signature.
-          checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec)
-    check_dm _ _ _ _ _ = return ()
-
-checkFamFlag :: Name -> TcM ()
--- Check that we don't use families without -XTypeFamilies
--- The parser won't even parse them, but I suppose a GHC API
--- client might have a go!
-checkFamFlag tc_name
-  = do { idx_tys <- xoptM LangExt.TypeFamilies
-       ; checkTc idx_tys err_msg }
-  where
-    err_msg :: TcRnMessage
-    err_msg = mkTcRnUnknownMessage $ mkPlainError noHints $
-      hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))
-         2 (text "Enable TypeFamilies to allow indexed type families")
-
-checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM ()
-checkResultSigFlag tc_name (TyVarSig _ tvb)
-  = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies
-       ; checkTc ty_fam_deps $ mkTcRnUnknownMessage $ mkPlainError noHints $
-         hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name))
-            2 (text "Enable TypeFamilyDependencies to allow result variable names") }
-checkResultSigFlag _ _ = return ()  -- other cases OK
-
-{- Note [Class method constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Haskell 2010 is supposed to reject
-  class C a where
-    op :: Eq a => a -> a
-where the method type constrains only the class variable(s).  (The extension
--XConstrainedClassMethods switches off this check.)  But regardless
-we should not reject
-  class C a where
-    op :: (?x::Int) => a -> a
-as pointed out in #11793. So the test here rejects the program if
-  * -XConstrainedClassMethods is off
-  * the tyvars of the constraint are non-empty
-  * all the tyvars are class tyvars, none are locally quantified
-
-Note [Abort when superclass cycle is detected]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must avoid doing the ambiguity check for the methods (in
-checkValidClass.check_op) when there are already errors accumulated.
-This is because one of the errors may be a superclass cycle, and
-superclass cycles cause canonicalization to loop. Here is a
-representative example:
-
-  class D a => C a where
-    meth :: D a => ()
-  class C a => D a
-
-This fixes #9415, #9739
-
-Note [Default method type signatures must align]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-GHC enforces the invariant that a class method's default type signature
-must "align" with that of the method's non-default type signature, as per
-GHC #12918. For instance, if you have:
-
-  class Foo a where
-    bar :: forall b. Context => a -> b
-
-Then a default type signature for bar must be alpha equivalent to
-(forall b. a -> b). That is, the types must be the same modulo differences in
-contexts. So the following would be acceptable default type signatures:
-
-    default bar :: forall b. Context1 => a -> b
-    default bar :: forall x. Context2 => a -> x
-
-But the following are NOT acceptable default type signatures:
-
-    default bar :: forall b. b -> a
-    default bar :: forall x. x
-    default bar :: a -> Int
-
-Note that a is bound by the class declaration for Foo itself, so it is
-not allowed to differ in the default type signature.
-
-The default type signature (default bar :: a -> Int) deserves special mention,
-since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To
-write this, you need to declare the default type signature like so:
-
-    default bar :: forall b. (b ~ Int). a -> b
-
-As noted in #12918, there are several reasons to do this:
-
-1. It would make no sense to have a type that was flat-out incompatible with
-   the non-default type signature. For instance, if you had:
-
-     class Foo a where
-       bar :: a -> Int
-       default bar :: a -> Bool
-
-   Then that would always fail in an instance declaration. So this check
-   nips such cases in the bud before they have the chance to produce
-   confusing error messages.
-
-2. Internally, GHC uses TypeApplications to instantiate the default method in
-   an instance. See Note [Default methods in instances] in GHC.Tc.TyCl.Instance.
-   Thus, GHC needs to know exactly what the universally quantified type
-   variables are, and when instantiated that way, the default method's type
-   must match the expected type.
-
-3. Aesthetically, by only allowing the default type signature to differ in its
-   context, we are making it more explicit the ways in which the default type
-   signature is less polymorphic than the non-default type signature.
-
-You might be wondering: why are the contexts allowed to be different, but not
-the rest of the type signature? That's because default implementations often
-rely on assumptions that the more general, non-default type signatures do not.
-For instance, in the Enum class declaration:
-
-    class Enum a where
-      enum :: [a]
-      default enum :: (Generic a, GEnum (Rep a)) => [a]
-      enum = map to genum
-
-    class GEnum f where
-      genum :: [f a]
-
-The default implementation for enum only works for types that are instances of
-Generic, and for which their generic Rep type is an instance of GEnum. But
-clearly enum doesn't _have_ to use this implementation, so naturally, the
-context for enum is allowed to be different to accommodate this. As a result,
-when we validity-check default type signatures, we ignore contexts completely.
-
-Note that when checking whether two type signatures match, we must take care to
-split as many foralls as it takes to retrieve the tau types we which to check.
-See Note [Splitting nested sigma types in class type signatures].
-
-Extra note: July 22.  If we have
-   class C a b where
-      op :: op_ty
-      default op :: def_ty
-      op = blah
-
-then we'll generate something like
-   $gdm_op :: C a b => def_ty
-   $gdm_op = blah
-
-We expect to write an instance that looks (in effect) like this:
-   instance G => C t1 t2 where
-      op = $gdm_op  -- Added when you leave out binding for 'op'
-
-So we need that
-  assuming constraints G, and C t1 t2,
-  we have (def_ty[t1/a,t2/b] <= op_ty[t1/a,t2/b]
-
-In the validity check, we want to check that there is such a G.
-E.g. if we check  def_ty <= op_ty, and get an insoluble constraint
-(Int~Bool), we know there will never be such a G, and can complain.
-
-This seems to be a more general way of thinking about the problem.
-But no one is complaining, so it'll have to wait for another day
-
-Note [Splitting nested sigma types in class type signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this type synonym and class definition:
-
-  type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t
-
-  class Each s t a b where
-    each         ::                                      Traversal s t a b
-    default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b
-
-It might seem obvious that the tau types in both type signatures for `each`
-are the same, but actually getting GHC to conclude this is surprisingly tricky.
-That is because in general, the form of a class method's non-default type
-signature is:
-
-  forall a. C a => forall d. D d => E a b
-
-And the general form of a default type signature is:
-
-  forall f. F f => E a f -- The variable `a` comes from the class
-
-So it you want to get the tau types in each type signature, you might find it
-reasonable to call tcSplitSigmaTy twice on the non-default type signature, and
-call it once on the default type signature. For most classes and methods, this
-will work, but Each is a bit of an exceptional case. The way `each` is written,
-it doesn't quantify any additional type variables besides those of the Each
-class itself, so the non-default type signature for `each` is actually this:
-
-  forall s t a b. Each s t a b => Traversal s t a b
-
-Notice that there _appears_ to only be one forall. But there's actually another
-forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy
-twice, you'll also go under the forall in Traversal! That is, you'll end up
-with:
-
-  (a -> f b) -> s -> f t
-
-A problem arises because you only call tcSplitSigmaTy once on the default type
-signature for `each`, which gives you
-
-  Traversal s t a b
-
-Or, equivalently:
-
-  forall f. Applicative f => (a -> f b) -> s -> f t
-
-This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will
-say that the tau types for `each` are not equal.
-
-A solution to this problem is to use tcSplitNestedSigmaTys instead of
-tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it
-sees until it can't go any further, so if you called it on the default type
-signature for `each`, it would return (a -> f b) -> s -> f t like we desired.
-
-Note [Checking partial record field]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-This check checks the partial record field selector, and warns (#7169).
-
-For example:
-
-  data T a = A { m1 :: a, m2 :: a } | B { m1 :: a }
-
-The function 'm2' is partial record field, and will fail when it is applied to
-'B'. The warning identifies such partial fields. The check is performed at the
-declaration of T, not at the call-sites of m2.
-
-The warning can be suppressed by prefixing the field-name with an underscore.
-For example:
-
-  data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a }
-
-************************************************************************
-*                                                                      *
-                Checking role validity
-*                                                                      *
-************************************************************************
--}
-
-checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM ()
-checkValidRoleAnnots role_annots tc
-  | isTypeSynonymTyCon tc = check_no_roles
-  | isFamilyTyCon tc      = check_no_roles
-  | isAlgTyCon tc         = check_roles
-  | otherwise             = return ()
-  where
-    -- Role annotations are given only on *explicit* variables,
-    -- but a tycon stores roles for all variables.
-    -- So, we drop the implicit roles (which are all Nominal, anyway).
-    name                   = tyConName tc
-    roles                  = tyConRoles tc
-    (vis_roles, vis_vars)  = unzip $ mapMaybe pick_vis $
-                             zip roles (tyConBinders tc)
-    role_annot_decl_maybe  = lookupRoleAnnot role_annots name
-
-    pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar)
-    pick_vis (role, tvb)
-      | isVisibleTyConBinder tvb = Just (role, binderVar tvb)
-      | otherwise                = Nothing
-
-    check_roles
-      = whenIsJust role_annot_decl_maybe $
-          \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) ->
-          addRoleAnnotCtxt name $
-          setSrcSpanA loc $ do
-          { role_annots_ok <- xoptM LangExt.RoleAnnotations
-          ; checkTc role_annots_ok $ needXRoleAnnotations tc
-          ; checkTc (vis_vars `equalLength` the_role_annots)
-                    (wrongNumberOfRoles vis_vars decl)
-          ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles
-          -- Representational or phantom roles for class parameters
-          -- quickly lead to incoherence. So, we require
-          -- IncoherentInstances to have them. See #8773, #14292
-          ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances
-          ; checkTc (  incoherent_roles_ok
-                    || (not $ isClassTyCon tc)
-                    || (all (== Nominal) vis_roles))
-                    incoherentRoles
-
-          ; lint <- goptM Opt_DoCoreLinting
-          ; when lint $ checkValidRoles tc }
-
-    check_no_roles
-      = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl
-
-checkRoleAnnot :: TyVar -> LocatedAn NoEpAnns (Maybe Role) -> Role -> TcM ()
-checkRoleAnnot _  (L _ Nothing)   _  = return ()
-checkRoleAnnot tv (L _ (Just r1)) r2
-  = when (r1 /= r2) $
-    addErrTc $ badRoleAnnot (tyVarName tv) r1 r2
-
--- This is a double-check on the role inference algorithm. It is only run when
--- -dcore-lint is enabled. See Note [Role inference] in GHC.Tc.TyCl.Utils
-checkValidRoles :: TyCon -> TcM ()
--- If you edit this function, you may need to update the GHC formalism
--- See Note [GHC Formalism] in GHC.Core.Lint
-checkValidRoles tc
-  | isAlgTyCon tc
-    -- tyConDataCons returns an empty list for data families
-  = mapM_ check_dc_roles (tyConDataCons tc)
-  | Just rhs <- synTyConRhs_maybe tc
-  = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs
-  | otherwise
-  = return ()
-  where
-    check_dc_roles datacon
-      = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc))
-           ; mapM_ (check_ty_roles role_env Representational) $
-             eqSpecPreds eq_spec ++ theta ++ map scaledThing arg_tys }
-                    -- See Note [Role-checking data constructor arguments] in GHC.Tc.TyCl.Utils
-      where
-        (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)
-          = dataConFullSig datacon
-        univ_roles = zipVarEnv univ_tvs (tyConRoles tc)
-              -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs
-        ex_roles   = mkVarEnv (map (, Nominal) ex_tvs)
-        role_env   = univ_roles `plusVarEnv` ex_roles
-
-    check_ty_roles env role ty
-      | Just ty' <- coreView ty -- #14101
-      = check_ty_roles env role ty'
-
-    check_ty_roles env role (TyVarTy tv)
-      = case lookupVarEnv env tv of
-          Just role' -> unless (role' `ltRole` role || role' == role) $
-                        report_error $ text "type variable" <+> quotes (ppr tv) <+>
-                                       text "cannot have role" <+> ppr role <+>
-                                       text "because it was assigned role" <+> ppr role'
-          Nothing    -> report_error $ text "type variable" <+> quotes (ppr tv) <+>
-                                       text "missing in environment"
-
-    check_ty_roles env Representational (TyConApp tc tys)
-      = let roles' = tyConRoles tc in
-        zipWithM_ (maybe_check_ty_roles env) roles' tys
-
-    check_ty_roles env Nominal (TyConApp _ tys)
-      = mapM_ (check_ty_roles env Nominal) tys
-
-    check_ty_roles _   Phantom ty@(TyConApp {})
-      = pprPanic "check_ty_roles" (ppr ty)
-
-    check_ty_roles env role (AppTy ty1 ty2)
-      =  check_ty_roles env role    ty1
-      >> check_ty_roles env Nominal ty2
-
-    check_ty_roles env role (FunTy _ w ty1 ty2)
-      =  check_ty_roles env Nominal w
-      >> check_ty_roles env role ty1
-      >> check_ty_roles env role ty2
-
-    check_ty_roles env role (ForAllTy (Bndr tv _) ty)
-      =  check_ty_roles env Nominal (tyVarKind tv)
-      >> check_ty_roles (extendVarEnv env tv Nominal) role ty
-
-    check_ty_roles _   _    (LitTy {}) = return ()
-
-    check_ty_roles env role (CastTy t _)
-      = check_ty_roles env role t
-
-    check_ty_roles _   role (CoercionTy co)
-      = unless (role == Phantom) $
-        report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role
-
-    maybe_check_ty_roles env role ty
-      = when (role == Nominal || role == Representational) $
-        check_ty_roles env role ty
-
-    report_error doc
-      = addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-         vcat [text "Internal error in role inference:",
-               doc,
-               text "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug"]
-
-{-
-************************************************************************
-*                                                                      *
-                Error messages
-*                                                                      *
-************************************************************************
--}
-
-tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc
-tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl,
-                      text "declaration for", quotes (ppr (tcdName decl))]
-
-addVDQNote :: TcTyCon -> TcM a -> TcM a
--- See Note [Inferring visible dependent quantification]
--- Only types without a signature (CUSK or SAK) here
-addVDQNote tycon thing_inside
-  | assertPpr (isTcTyCon tycon) (ppr tycon) $
-    assertPpr (not (tcTyConIsPoly tycon)) (ppr tycon $$ ppr tc_kind)
-    has_vdq
-  = addLandmarkErrCtxt vdq_warning thing_inside
-  | otherwise
-  = thing_inside
-  where
-      -- Check whether a tycon has visible dependent quantification.
-      -- This will *always* be a TcTyCon. Furthermore, it will *always*
-      -- be an ungeneralised TcTyCon, straight out of kcInferDeclHeader.
-      -- Thus, all the TyConBinders will be anonymous. Thus, the
-      -- free variables of the tycon's kind will be the same as the free
-      -- variables from all the binders.
-    has_vdq  = any is_vdq_tcb (tyConBinders tycon)
-    tc_kind  = tyConKind tycon
-    kind_fvs = tyCoVarsOfType tc_kind
-
-    is_vdq_tcb tcb = (binderVar tcb `elemVarSet` kind_fvs) &&
-                     isVisibleTyConBinder tcb
-
-    vdq_warning = vcat
-      [ text "NB: Type" <+> quotes (ppr tycon) <+>
-        text "was inferred to use visible dependent quantification."
-      , text "Most types with visible dependent quantification are"
-      , text "polymorphically recursive and need a standalone kind"
-      , text "signature. Perhaps supply one, with StandaloneKindSignatures."
-      ]
-
-tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a
-tcAddDeclCtxt decl thing_inside
-  = addErrCtxt (tcMkDeclCtxt decl) thing_inside
-
-tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a
-tcAddTyFamInstCtxt decl
-  = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)
-
-tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc
-tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn = eqn })
-  = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")
-                    (unLoc (feqn_tycon eqn))
-
-tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a
-tcAddDataFamInstCtxt decl
-  = addErrCtxt (tcMkDataFamInstCtxt decl)
-
-tcMkFamInstCtxt :: SDoc -> Name -> SDoc
-tcMkFamInstCtxt flavour tycon
-  = hsep [ text "In the" <+> flavour <+> text "declaration for"
-         , quotes (ppr tycon) ]
-
-tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a
-tcAddFamInstCtxt flavour tycon thing_inside
-  = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside
-
-tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a
-tcAddClosedTypeFamilyDeclCtxt tc
-  = addErrCtxt ctxt
-  where
-    ctxt = text "In the equations for closed type family" <+>
-           quotes (ppr tc)
-
-resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage
-resultTypeMisMatch field_name con1 con2
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,
-                text "have a common field" <+> quotes (ppr field_name) <> comma],
-          nest 2 $ text "but have different result types"]
-
-fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> TcRnMessage
-fieldTypeMisMatch field_name con1 con2
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,
-         text "give different types for field", quotes (ppr field_name)]
-
-dataConCtxt :: NonEmpty (LocatedN Name) -> SDoc
-dataConCtxt cons = text "In the definition of data constructor" <> plural (toList cons)
-                   <+> ppr_cons (toList cons)
-
-dataConResCtxt :: NonEmpty (LocatedN Name) -> SDoc
-dataConResCtxt cons = text "In the result type of data constructor" <> plural (toList cons)
-                      <+> ppr_cons (toList cons)
-
-ppr_cons :: [LocatedN Name] -> SDoc
-ppr_cons [con] = quotes (ppr con)
-ppr_cons cons  = interpp'SP cons
-
-classOpCtxt :: Var -> Type -> SDoc
-classOpCtxt sel_id tau = sep [text "When checking the class method:",
-                              nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)]
-
-classArityErr :: Int -> Class -> TcRnMessage
-classArityErr n cls
-    | n == 0 = mkErr "No" "no-parameter"
-    | otherwise = mkErr "Too many" "multi-parameter"
-  where
-    mkErr howMany allowWhat = mkTcRnUnknownMessage $ mkPlainError noHints $
-        vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls),
-              parens (text ("Enable MultiParamTypeClasses to allow "
-                                    ++ allowWhat ++ " classes"))]
-
-classFunDepsErr :: Class -> TcRnMessage
-classFunDepsErr cls
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [text "Fundeps in class" <+> quotes (ppr cls),
-          parens (text "Enable FunctionalDependencies to allow fundeps")]
-
-badMethPred :: Id -> TcPredType -> TcRnMessage
-badMethPred sel_id pred
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [ hang (text "Constraint" <+> quotes (ppr pred)
-                 <+> text "in the type of" <+> quotes (ppr sel_id))
-              2 (text "constrains only the class type variables")
-         , text "Enable ConstrainedClassMethods to allow it" ]
-
-noClassTyVarErr :: Class -> TyCon -> TcRnMessage
-noClassTyVarErr clas fam_tc
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc)))
-        , text "mentions none of the type or kind variables of the class" <+>
-                quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))]
-
-badDataConTyCon :: DataCon -> Type -> TcRnMessage
-badDataConTyCon data_con res_ty_tmpl
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (text "Data constructor" <+> quotes (ppr data_con) <+>
-                text "returns type" <+> quotes (ppr actual_res_ty))
-       2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl))
-  where
-    actual_res_ty = dataConOrigResTy data_con
-
-badGadtDecl :: Name -> TcRnMessage
-badGadtDecl tc_name
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)
-         , nest 2 (parens $ text "Enable the GADTs extension to allow this") ]
-
-badExistential :: DataCon -> TcRnMessage
-badExistential con
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    sdocOption sdocLinearTypes (\show_linear_types ->
-      hang (text "Data constructor" <+> quotes (ppr con) <+>
-                  text "has existential type variables, a context, or a specialised result type")
-         2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)
-                 , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ]))
-
-badStupidTheta :: Name -> TcRnMessage
-badStupidTheta tc_name
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-  text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name)
-
-newtypeConError :: Name -> Int -> TcRnMessage
-newtypeConError tycon n
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    sep [text "A newtype must have exactly one constructor,",
-         nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ]
-
-badSigTyDecl :: Name -> TcRnMessage
-badSigTyDecl tc_name
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [ text "Illegal kind signature" <+>
-           quotes (ppr tc_name)
-         , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ]
-
-emptyConDeclsErr :: Name -> TcRnMessage
-emptyConDeclsErr tycon
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    sep [quotes (ppr tycon) <+> text "has no constructors",
-         nest 2 $ text "(EmptyDataDecls permits this)"]
-
-wrongKindOfFamily :: TyCon -> TcRnMessage
-wrongKindOfFamily family
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    text "Wrong category of family instance; declaration was for a"
-    <+> kindOfFamily
-  where
-    kindOfFamily | isTypeFamilyTyCon family = text "type family"
-                 | isDataFamilyTyCon family = text "data family"
-                 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
-
--- | Produce an error for oversaturated type family equations with too many
--- required arguments.
--- See Note [Oversaturated type family equations] in "GHC.Tc.Validity".
-wrongNumberOfParmsErr :: Arity -> TcRnMessage
-wrongNumberOfParmsErr max_args
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    text "Number of parameters must match family declaration; expected"
-    <+> ppr max_args
-
-badRoleAnnot :: Name -> Role -> Role -> TcRnMessage
-badRoleAnnot var annot inferred
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (text "Role mismatch on variable" <+> ppr var <> colon)
-       2 (sep [ text "Annotation says", ppr annot
-              , text "but role", ppr inferred
-              , text "is required" ])
-
-wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> TcRnMessage
-wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots))
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (text "Wrong number of roles listed in role annotation;" $$
-          text "Expected" <+> (ppr $ length tyvars) <> comma <+>
-          text "got" <+> (ppr $ length annots) <> colon)
-       2 (ppr d)
-
-
-illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()
-illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _))
-  = setErrCtxt [] $
-    setSrcSpanA loc $
-    addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-      (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$
-       text "they are allowed only for datatypes and classes.")
-
-needXRoleAnnotations :: TyCon -> TcRnMessage
-needXRoleAnnotations tc
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    text "Illegal role annotation for" <+> ppr tc <> char ';' $$
-    text "did you intend to use RoleAnnotations?"
-
-incoherentRoles :: TcRnMessage
-incoherentRoles = mkTcRnUnknownMessage $ mkPlainError noHints $
-  (text "Roles other than" <+> quotes (text "nominal") <+>
-   text "for class parameters can lead to incoherence.") $$
-  (text "Use IncoherentInstances to allow this; bad role found")
-
-wrongTyFamName :: Name -> Name -> TcRnMessage
-wrongTyFamName fam_tc_name eqn_tc_name
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (text "Mismatched type name in type family instance.")
-       2 (vcat [ text "Expected:" <+> ppr fam_tc_name
-               , text "  Actual:" <+> ppr eqn_tc_name ])
-
-addTyConCtxt :: TyCon -> TcM a -> TcM a
-addTyConCtxt tc = addTyConFlavCtxt name flav
-  where
-    name = getName tc
-    flav = tyConFlavour tc
-
-addRoleAnnotCtxt :: Name -> TcM a -> TcM a
-addRoleAnnotCtxt name
-  = addErrCtxt $
-    text "while checking a role annotation for" <+> quotes (ppr name)
diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/TyCl/Build.hs
+++ /dev/null
@@ -1,458 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
--}
-
-
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-module GHC.Tc.TyCl.Build (
-        buildDataCon,
-        buildPatSyn,
-        TcMethInfo, MethInfo, buildClass,
-        mkNewTyConRhs,
-        newImplicitBinder, newTyConRepName
-    ) where
-
-import GHC.Prelude
-
-import GHC.Iface.Env
-import GHC.Builtin.Types( isCTupleTyConName, unboxedUnitTy )
-
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.Monad
-
-import GHC.Core.DataCon
-import GHC.Core.PatSyn
-import GHC.Core.Class
-import GHC.Core.TyCon
-import GHC.Core.Type
-import GHC.Core.Multiplicity
-import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
-
-import GHC.Types.SrcLoc( SrcSpan, noSrcSpan )
-import GHC.Types.Var
-import GHC.Types.Var.Set
-import GHC.Types.Basic
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.Id.Make
-import GHC.Types.SourceText
-import GHC.Types.Unique.Supply
-
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-
-
-mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
--- ^ Monadic because it makes a Name for the coercion TyCon
---   We pass the Name of the parent TyCon, as well as the TyCon itself,
---   because the latter is part of a knot, whereas the former is not.
-mkNewTyConRhs tycon_name tycon con
-  = do  { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
-        ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs
-        ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)
-        ; return (NewTyCon { data_con     = con,
-                             nt_rhs       = rhs_ty,
-                             nt_etad_rhs  = (etad_tvs, etad_rhs),
-                             nt_co        = nt_ax,
-                             nt_fixed_rep = isFixedRuntimeRepKind res_kind } ) }
-                             -- Coreview looks through newtypes with a Nothing
-                             -- for nt_co, or uses explicit coercions otherwise
-  where
-    tvs      = tyConTyVars tycon
-    roles    = tyConRoles tycon
-    res_kind = tyConResKind tycon
-    con_arg_ty = case dataConRepArgTys con of
-                   [arg_ty] -> scaledThing arg_ty
-                   tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys)
-    rhs_ty = substTyWith (dataConUnivTyVars con)
-                         (mkTyVarTys tvs) con_arg_ty
-        -- Instantiate the newtype's RHS with the
-        -- type variables from the tycon
-        -- NB: a newtype DataCon has a type that must look like
-        --        forall tvs.  <arg-ty> -> T tvs
-        -- Note that we *can't* use dataConInstOrigArgTys here because
-        -- the newtype arising from   class Foo a => Bar a where {}
-        -- has a single argument (Foo a) that is a *type class*, so
-        -- dataConInstOrigArgTys returns [].
-
-    -- Eta-reduce the newtype
-    -- See Note [Newtype eta] in GHC.Core.TyCon
-    etad_tvs   :: [TyVar]  -- Matched lazily, so that mkNewTypeCo can
-    etad_roles :: [Role]   -- return a TyCon without pulling on rhs_ty
-    etad_rhs   :: Type     -- See Note [Tricky iface loop] in GHC.Iface.Load
-    (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty
-
-    eta_reduce :: [TyVar]       -- Reversed
-               -> [Role]        -- also reversed
-               -> Type          -- Rhs type
-               -> ([TyVar], [Role], Type)  -- Eta-reduced version
-                                           -- (tyvars in normal order)
-    eta_reduce (a:as) (_:rs) ty
-      | Just (fun, arg) <- splitAppTy_maybe ty
-      , Just tv <- getTyVar_maybe arg
-      , tv == a
-      , not (a `elemVarSet` tyCoVarsOfType fun)
-      , typeKind fun `eqType` typeKind (mkTyConApp tycon (mkTyVarTys $ reverse as))
-        -- Why this kind-check?  See Note [Newtype eta and homogeneous axioms]
-      = eta_reduce as rs fun
-    eta_reduce as rs ty = (reverse as, reverse rs, ty)
-
-{- Note [Newtype eta and homogeneous axioms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When eta-reducing a newtype, we must be careful to make sure the axiom
-is homogeneous.  (That is, the two types related by the axiom must
-have the same kind.)  All known proofs of type safety for Core rely on
-the homogeneity of axioms, so let's not monkey with that.
-
-It is easy to mistakenly make an inhomogeneous axiom (#19739):
-  type T :: forall (a :: Type) -> Type
-  newtype T a = MkT (Proxy a)
-
-Can we eta-reduce, thus?
-  axT :: T ~ Proxy
-
-No!  Because
-   T     :: forall a -> Type
-   Proxy :: Type     -> Type
-
-This is inhomogeneous. Hence, we have an extra kind-check in eta_reduce,
-to make sure the reducts have the same kind. This is simple, although
-perhaps quadratic in complexity, if we eta-reduce many arguments (which
-seems vanishingly unlikely in practice).  But NB that the free-variable
-check, which immediately precedes the kind check, is also potentially
-quadratic.
-
-There are other ways we could do the check (discussion on #19739):
-
-* We could look at the sequence of binders on the newtype and on the
-  head of the representation type, and make sure the visibilities on
-  the binders match up. This is quite a bit more code, and the reasoning
-  is subtler.
-
-* We could, say, do the kind-check at the end and then backtrack until the
-  kinds match up. Hard to know whether that's more performant or not.
--}
-
-------------------------------------------------------
-buildDataCon :: FamInstEnvs
-            -> DataConBangOpts
-            -> Name
-            -> Bool                     -- Declared infix
-            -> TyConRepName
-            -> [HsSrcBang]
-           -> [FieldLabel]             -- Field labels
-           -> [TyVar]                  -- Universals
-           -> [TyCoVar]                -- Existentials
-           -> [InvisTVBinder]          -- User-written 'TyVarBinder's
-           -> [EqSpec]                 -- Equality spec
-           -> KnotTied ThetaType       -- Does not include the "stupid theta"
-                                       -- or the GADT equalities
-           -> [KnotTied (Scaled Type)] -- Arguments
-           -> KnotTied Type            -- Result types
-           -> KnotTied TyCon           -- Rep tycon
-           -> NameEnv ConTag           -- Maps the Name of each DataCon to its
-                                       -- ConTag
-           -> TcRnIf m n DataCon
--- A wrapper for DataCon.mkDataCon that
---   a) makes the worker Id
---   b) makes the wrapper Id if necessary, including
---      allocating its unique (hence monadic)
-buildDataCon fam_envs dc_bang_opts src_name declared_infix prom_info src_bangs
-             field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty
-             rep_tycon tag_map
-  = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
-        ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
-        -- This last one takes the name of the data constructor in the source
-        -- code, which (for Haskell source anyway) will be in the DataName name
-        -- space, and puts it into the VarName name space
-
-        ; traceIf (text "buildDataCon 1" <+> ppr src_name)
-        ; us <- newUniqueSupply
-        ; let stupid_ctxt = mkDataConStupidTheta rep_tycon (map scaledThing arg_tys) univ_tvs
-              tag = lookupNameEnv_NF tag_map src_name
-              -- See Note [Constructor tag allocation], fixes #14657
-              data_con = mkDataCon src_name declared_infix prom_info
-                                   src_bangs field_lbls
-                                   univ_tvs ex_tvs user_tvbs eq_spec ctxt
-                                   arg_tys res_ty NoPromInfo rep_tycon tag
-                                   stupid_ctxt dc_wrk dc_rep
-              dc_wrk = mkDataConWorkId work_name data_con
-              dc_rep = initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con)
-
-        ; traceIf (text "buildDataCon 2" <+> ppr src_name)
-        ; return data_con }
-
-
--- The stupid context for a data constructor should be limited to
--- the type variables mentioned in the arg_tys
--- ToDo: Or functionally dependent on?
---       This whole stupid theta thing is, well, stupid.
---
--- See Note [The stupid context] in GHC.Core.DataCon.
-mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
-mkDataConStupidTheta tycon arg_tys univ_tvs
-  | null stupid_theta = []      -- The common case
-  | otherwise         = filter in_arg_tys stupid_theta
-  where
-    tc_subst     = zipTvSubst (tyConTyVars tycon)
-                              (mkTyVarTys univ_tvs)
-    stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
-        -- Start by instantiating the master copy of the
-        -- stupid theta, taken from the TyCon
-
-    arg_tyvars      = tyCoVarsOfTypes arg_tys
-    in_arg_tys pred = tyCoVarsOfType pred `intersectsVarSet` arg_tyvars
-
-
-------------------------------------------------------
-buildPatSyn :: Name -> Bool
-            -> PatSynMatcher -> PatSynBuilder
-            -> ([InvisTVBinder], ThetaType) -- ^ Univ and req
-            -> ([InvisTVBinder], ThetaType) -- ^ Ex and prov
-            -> [FRRType]                    -- ^ Argument types
-            -> Type                         -- ^ Result type
-            -> [FieldLabel]                 -- ^ Field labels for
-                                            --   a record pattern synonym
-            -> PatSyn
-buildPatSyn src_name declared_infix matcher@(_, matcher_ty,_) builder
-            (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
-            pat_ty field_labels
-  = -- The assertion checks that the matcher is
-    -- compatible with the pattern synonym
-    assertPpr (and [ univ_tvs `equalLength` univ_tvs1
-                   , ex_tvs `equalLength` ex_tvs1
-                   , pat_ty `eqType` substTy subst (scaledThing pat_ty1)
-                   , prov_theta `eqTypes` substTys subst prov_theta1
-                   , req_theta `eqTypes` substTys subst req_theta1
-                   , compareArgTys arg_tys (substTys subst (map scaledThing arg_tys1))
-                   ])
-              (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
-                    , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
-                    , ppr pat_ty <+> twiddle <+> ppr pat_ty1
-                    , ppr prov_theta <+> twiddle <+> ppr prov_theta1
-                    , ppr req_theta <+> twiddle <+> ppr req_theta1
-                    , ppr arg_tys <+> twiddle <+> ppr arg_tys1]) $
-    mkPatSyn src_name declared_infix
-             (univ_tvs, req_theta) (ex_tvs, prov_theta)
-             arg_tys pat_ty
-             matcher builder field_labels
-  where
-    ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ matcher_ty
-    ([pat_ty1, cont_sigma, _], _)      = tcSplitFunTys tau
-    (ex_tvs1, prov_theta1, cont_tau)   = tcSplitSigmaTy (scaledThing cont_sigma)
-    (arg_tys1, _) = (tcSplitFunTys cont_tau)
-    twiddle = char '~'
-    subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)
-                       (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs)))
-
-    -- For a nullary pattern synonym we add a single (# #) argument to the
-    -- matcher to preserve laziness in the case of unlifted types.
-    -- See #12746
-    compareArgTys :: [Type] -> [Type] -> Bool
-    compareArgTys [] [x] = x `eqType` unboxedUnitTy
-    compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys
-
-
-------------------------------------------------------
-type TcMethInfo = MethInfo  -- this variant needs zonking
-type MethInfo       -- A temporary intermediate, to communicate
-                    -- between tcClassSigs and buildClass.
-  = ( Name   -- Name of the class op
-    , Type   -- Type of the class op
-    , Maybe (DefMethSpec (SrcSpan, Type)))
-         -- Nothing                    => no default method
-         --
-         -- Just VanillaDM             => There is an ordinary
-         --                               polymorphic default method
-         --
-         -- Just (GenericDM (loc, ty)) => There is a generic default metho
-         --                               Here is its type, and the location
-         --                               of the type signature
-         --    We need that location /only/ to attach it to the
-         --    generic default method's Name; and we need /that/
-         --    only to give the right location of an ambiguity error
-         --    for the generic default method, spat out by checkValidClass
-
-buildClass :: Name  -- Name of the class/tycon (they have the same Name)
-           -> [TyConBinder]                -- Of the tycon
-           -> [Role]
-           -> [FunDep TyVar]               -- Functional dependencies
-           -- Super classes, associated types, method info, minimal complete def.
-           -- This is Nothing if the class is abstract.
-           -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef)
-           -> TcRnIf m n Class
-
-buildClass tycon_name binders roles fds Nothing
-  = fixM  $ \ rec_clas ->       -- Only name generation inside loop
-    do  { traceIf (text "buildClass")
-
-        ; tc_rep_name  <- newTyConRepName tycon_name
-        ; let univ_tvs = binderVars binders
-              tycon = mkClassTyCon tycon_name binders roles
-                                   AbstractTyCon
-                                   rec_clas tc_rep_name
-              result = mkAbstractClass tycon_name univ_tvs fds tycon
-        ; traceIf (text "buildClass" <+> ppr tycon)
-        ; return result }
-
-buildClass tycon_name binders roles fds
-           (Just (sc_theta, at_items, sig_stuff, mindef))
-  = fixM  $ \ rec_clas ->       -- Only name generation inside loop
-    do  { traceIf (text "buildClass")
-
-        ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
-        ; tc_rep_name  <- newTyConRepName tycon_name
-
-        ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
-                        -- Build the selector id and default method id
-
-              -- Make selectors for the superclasses
-        ; sc_sel_names <- mapM  (newImplicitBinder tycon_name . mkSuperDictSelOcc)
-                                (takeList sc_theta [fIRST_TAG..])
-        ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
-                           | sc_name <- sc_sel_names]
-              -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
-              -- can construct names for the selectors. Thus
-              --      class (C a, C b) => D a b where ...
-              -- gives superclass selectors
-              --      D_sc1, D_sc2
-              -- (We used to call them D_C, but now we can have two different
-              --  superclasses both called C!)
-
-        ; let use_newtype = isSingleton (sc_theta ++ op_tys)
-                -- Use a newtype if the data constructor
-                --   (a) has exactly one value field
-                --       i.e. exactly one operation or superclass taken together
-                --   (b) that value is of lifted type (which they always are, because
-                --       we box equality superclasses)
-                -- See Note [Class newtypes and equality predicates]
-                --
-                -- In the case of
-                --     class C a => D a
-                -- we use a newtype, but with one superclass and no arguments
-              args       = sc_sel_names ++ op_names
-              op_tys     = [ty | (_,ty,_) <- sig_stuff]
-              op_names   = [op | (op,_,_) <- sig_stuff]
-              rec_tycon  = classTyCon rec_clas
-              univ_bndrs = tyConInvisTVBinders binders
-              univ_tvs   = binderVars univ_bndrs
-              bang_opts  = FixedBangOpts (map (const HsLazy) args)
-
-        ; rep_nm   <- newTyConRepName datacon_name
-        ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
-                                   bang_opts
-                                   datacon_name
-                                   False        -- Not declared infix
-                                   rep_nm
-                                   (map (const no_bang) args)
-                                   [{- No fields -}]
-                                   univ_tvs
-                                   [{- no existentials -}]
-                                   univ_bndrs
-                                   [{- No GADT equalities -}]
-                                   sc_theta
-                                   (map unrestricted op_tys) -- type classes are unrestricted
-                                   (mkTyConApp rec_tycon (mkTyVarTys univ_tvs))
-                                   rec_tycon
-                                   (mkTyConTagMap rec_tycon)
-
-        ; rhs <- case () of
-                  _ | use_newtype
-                    -> mkNewTyConRhs tycon_name rec_tycon dict_con
-                    | isCTupleTyConName tycon_name
-                    -> return (TupleTyCon { data_con = dict_con
-                                          , tup_sort = ConstraintTuple })
-                    | otherwise
-                    -> return (mkDataTyConRhs [dict_con])
-
-        ; let { tycon = mkClassTyCon tycon_name binders roles
-                                     rhs rec_clas tc_rep_name
-                -- A class can be recursive, and in the case of newtypes
-                -- this matters.  For example
-                --      class C a where { op :: C b => a -> b -> Int }
-                -- Because C has only one operation, it is represented by
-                -- a newtype, and it should be a *recursive* newtype.
-                -- [If we don't make it a recursive newtype, we'll expand the
-                -- newtype like a synonym, but that will lead to an infinite
-                -- type]
-
-              ; result = mkClass tycon_name univ_tvs fds
-                                 sc_theta sc_sel_ids at_items
-                                 op_items mindef tycon
-              }
-        ; traceIf (text "buildClass" <+> ppr tycon)
-        ; return result }
-  where
-    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
-
-    mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
-    mk_op_item rec_clas (op_name, _, dm_spec)
-      = do { dm_info <- mk_dm_info op_name dm_spec
-           ; return (mkDictSelId op_name rec_clas, dm_info) }
-
-    mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type))
-               -> TcRnIf n m (Maybe (Name, DefMethSpec Type))
-    mk_dm_info _ Nothing
-      = return Nothing
-    mk_dm_info op_name (Just VanillaDM)
-      = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
-           ; return (Just (dm_name, VanillaDM)) }
-    mk_dm_info op_name (Just (GenericDM (loc, dm_ty)))
-      = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc
-           ; return (Just (dm_name, GenericDM dm_ty)) }
-
-{-
-Note [Class newtypes and equality predicates]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-        class (a ~ F b) => C a b where
-          op :: a -> b
-
-We cannot represent this by a newtype, even though it's not
-existential, because there are two value fields (the equality
-predicate and op. See #2238
-
-Moreover,
-          class (a ~ F b) => C a b where {}
-Here we can't use a newtype either, even though there is only
-one field, because equality predicates are unboxed, and classes
-are boxed.
--}
-
-newImplicitBinder :: Name                       -- Base name
-                  -> (OccName -> OccName)       -- Occurrence name modifier
-                  -> TcRnIf m n Name            -- Implicit name
--- Called in GHC.Tc.TyCl.Build to allocate the implicit binders of type/class decls
--- For source type/class decls, this is the first occurrence
--- For iface ones, GHC.Iface.Load has already allocated a suitable name in the cache
-newImplicitBinder base_name mk_sys_occ
-  = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name)
-
-newImplicitBinderLoc :: Name                       -- Base name
-                     -> (OccName -> OccName)       -- Occurrence name modifier
-                     -> SrcSpan
-                     -> TcRnIf m n Name            -- Implicit name
--- Just the same, but lets you specify the SrcSpan
-newImplicitBinderLoc base_name mk_sys_occ loc
-  | Just mod <- nameModule_maybe base_name
-  = newGlobalBinder mod occ loc
-  | otherwise           -- When typechecking a [d| decl bracket |],
-                        -- TH generates types, classes etc with Internal names,
-                        -- so we follow suit for the implicit binders
-  = do  { uniq <- newUnique
-        ; return (mkInternalName uniq occ loc) }
-  where
-    occ = mk_sys_occ (nameOccName base_name)
-
--- | Make the 'TyConRepName' for this 'TyCon'
-newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
-newTyConRepName tc_name
-  | Just mod <- nameModule_maybe tc_name
-  , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
-  = newGlobalBinder mod occ noSrcSpan
-  | otherwise
-  = newImplicitBinder tc_name mkTyConRepOcc
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ /dev/null
@@ -1,543 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
-
-{-# LANGUAGE TypeFamilies #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
--- | Typechecking class declarations
-module GHC.Tc.TyCl.Class
-   ( tcClassSigs
-   , tcClassDecl2
-   , findMethodBind
-   , instantiateMethod
-   , tcClassMinimalDef
-   , HsSigFun
-   , mkHsSigFun
-   , instDeclCtxt1
-   , instDeclCtxt2
-   , instDeclCtxt3
-   , tcATDefault
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Hs
-import GHC.Tc.Errors.Types
-import GHC.Tc.Gen.Sig
-import GHC.Tc.Types.Evidence ( idHsWrapper )
-import GHC.Tc.Gen.Bind
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.Unify
-import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars )
-import GHC.Tc.Gen.HsType
-import GHC.Tc.Utils.TcMType
-import GHC.Core.Type     ( piResultTys )
-import GHC.Core.Predicate
-import GHC.Core.Multiplicity
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.Monad
-import GHC.Tc.TyCl.Build( TcMethInfo )
-import GHC.Core.Class
-import GHC.Core.Coercion ( pprCoAxiom )
-import GHC.Driver.Session
-import GHC.Tc.Instance.Family
-import GHC.Core.FamInstEnv
-import GHC.Types.Error
-import GHC.Types.Id
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.Name.Set
-import GHC.Types.Var
-import GHC.Types.Var.Env
-import GHC.Types.SourceFile (HscSource(..))
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Types.SrcLoc
-import GHC.Core.TyCon
-import GHC.Data.Maybe
-import GHC.Types.Basic
-import GHC.Data.Bag
-import GHC.Data.BooleanFormula
-
-import Control.Monad
-import Data.List ( mapAccumL, partition )
-import qualified Data.List.NonEmpty as NE
-
-{-
-Dictionary handling
-~~~~~~~~~~~~~~~~~~~
-Every class implicitly declares a new data type, corresponding to dictionaries
-of that class. So, for example:
-
-        class (D a) => C a where
-          op1 :: a -> a
-          op2 :: forall b. Ord b => a -> b -> b
-
-would implicitly declare
-
-        data CDict a = CDict (D a)
-                             (a -> a)
-                             (forall b. Ord b => a -> b -> b)
-
-(We could use a record decl, but that means changing more of the existing apparatus.
-One step at a time!)
-
-For classes with just one superclass+method, we use a newtype decl instead:
-
-        class C a where
-          op :: forallb. a -> b -> b
-
-generates
-
-        newtype CDict a = CDict (forall b. a -> b -> b)
-
-Now DictTy in Type is just a form of type synonym:
-        DictTy c t = TyConTy CDict `AppTy` t
-
-Death to "ExpandingDicts".
-
-
-************************************************************************
-*                                                                      *
-                Type-checking the class op signatures
-*                                                                      *
-************************************************************************
--}
-
-tcClassSigs :: Name                -- Name of the class
-            -> [LSig GhcRn]
-            -> LHsBinds GhcRn
-            -> TcM [TcMethInfo]    -- Exactly one for each method
-tcClassSigs clas sigs def_methods
-  = do { traceTc "tcClassSigs 1" (ppr clas)
-
-       ; gen_dm_prs <- concatMapM (addLocM tc_gen_sig) gen_sigs
-       ; let gen_dm_env :: NameEnv (SrcSpan, Type)
-             gen_dm_env = mkNameEnv gen_dm_prs
-
-       ; op_info <- concatMapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
-
-       ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
-       ; sequence_ [ failWithTc (TcRnBadMethodErr clas n)
-                   | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
-                   -- Value binding for non class-method (ie no TypeSig)
-
-       ; tcg_env <- getGblEnv
-       ; if tcg_src tcg_env == HsigFile
-            then
-               -- Error if we have value bindings
-               -- (Generic signatures without value bindings indicate
-               -- that a default of this form is expected to be
-               -- provided.)
-               case bagToList def_methods of
-                 []           -> return ()
-                 meth : meths -> failWithTc (TcRnIllegalHsigDefaultMethods clas (meth NE.:| meths))
-            else
-               -- Error for each generic signature without value binding
-               sequence_ [ failWithTc (TcRnBadGenericMethod clas n)
-                         | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
-
-       ; traceTc "tcClassSigs 2" (ppr clas)
-       ; return op_info }
-  where
-    vanilla_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp
-    vanilla_sigs = [L (locA loc) (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs]
-    gen_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp
-    gen_sigs     = [L (locA loc) (nm,ty) | L loc (ClassOpSig _ True  nm ty) <- sigs]
-    dm_bind_names :: [Name] -- These ones have a value binding in the class decl
-    dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
-
-    tc_sig :: NameEnv (SrcSpan, Type) -> ([LocatedN Name], LHsSigType GhcRn)
-           -> TcM [TcMethInfo]
-    tc_sig gen_dm_env (op_names, op_hs_ty)
-      = do { traceTc "ClsSig 1" (ppr op_names)
-           ; op_ty <- tcClassSigType op_names op_hs_ty
-                   -- Class tyvars already in scope
-
-           ; traceTc "ClsSig 2" (ppr op_names $$ ppr op_ty)
-           ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }
-           where
-             f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty)
-                  | nm `elem` dm_bind_names                 = Just VanillaDM
-                  | otherwise                               = Nothing
-
-    tc_gen_sig :: ([LocatedN Name], LHsSigType GhcRn)
-                      -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))] -- AZ temp
-    tc_gen_sig (op_names, gen_hs_ty)
-      = do { gen_op_ty <- tcClassSigType op_names gen_hs_ty
-           ; return [ (op_name, (locA loc, gen_op_ty))
-                                                 | L loc op_name <- op_names ] }
-
-{-
-************************************************************************
-*                                                                      *
-                Class Declarations
-*                                                                      *
-************************************************************************
--}
-
-tcClassDecl2 :: LTyClDecl GhcRn          -- The class declaration
-             -> TcM (LHsBinds GhcTc)
-
-tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
-                                tcdMeths = default_binds}))
-  = recoverM (return emptyLHsBinds) $
-    setSrcSpan (getLocA class_name) $
-    do  { clas <- tcLookupLocatedClass (n2l class_name)
-
-        -- We make a separate binding for each default method.
-        -- At one time I used a single AbsBinds for all of them, thus
-        -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
-        -- But that desugars into
-        --      ds = \d -> (..., ..., ...)
-        --      dm1 = \d -> case ds d of (a,b,c) -> a
-        -- And since ds is big, it doesn't get inlined, so we don't get good
-        -- default methods.  Better to make separate AbsBinds for each
-
-        ; skol_info <- mkSkolemInfo (TyConSkol ClassFlavour (getName class_name))
-        ; tc_lvl    <- getTcLevel
-        ; let (tyvars, _, _, op_items) = classBigSig clas
-              prag_fn = mkPragEnv sigs default_binds
-              sig_fn  = mkHsSigFun sigs
-              (_skol_subst, clas_tyvars) = tcSuperSkolTyVars tc_lvl skol_info tyvars
-                    -- This make skolemTcTyVars, but does not clone,
-                    -- so we can put them in scope with tcExtendTyVarEnv
-              pred = mkClassPred clas (mkTyVarTys clas_tyvars)
-        ; this_dict <- newEvVar pred
-
-        ; let tc_item = tcDefMeth clas clas_tyvars this_dict
-                                  default_binds sig_fn prag_fn
-        ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
-                      mapM tc_item op_items
-
-        ; return (unionManyBags dm_binds) }
-
-tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
-
-tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn
-          -> HsSigFun -> TcPragEnv -> ClassOpItem
-          -> TcM (LHsBinds GhcTc)
--- Generate code for default methods
--- This is incompatible with Hugs, which expects a polymorphic
--- default method for every class op, regardless of whether or not
--- the programmer supplied an explicit default decl for the class.
--- (If necessary we can fix that, but we don't have a convenient Id to hand.)
-
-tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)
-  = do { -- No default method
-         mapM_ (addLocMA (badDmPrag sel_id ))
-               (lookupPragEnv prag_fn (idName sel_id))
-       ; return emptyBag }
-
-tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
-          (sel_id, Just (dm_name, dm_spec))
-  | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn
-  = do { -- First look up the default method; it should be there!
-         -- It can be the ordinary default method
-         -- or the generic-default method.  E.g of the latter
-         --      class C a where
-         --        op :: a -> a -> Bool
-         --        default op :: Eq a => a -> a -> Bool
-         --        op x y = x==y
-         -- The default method we generate is
-         --    $gm :: (C a, Eq a) => a -> a -> Bool
-         --    $gm x y = x==y
-
-         global_dm_id  <- tcLookupId dm_name
-       ; global_dm_id  <- addInlinePrags global_dm_id prags
-       ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc
-            -- Base the local_dm_name on the selector name, because
-            -- type errors from tcInstanceMethodBody come from here
-
-       ; spec_prags <- discardConstraints $
-                       tcSpecPrags global_dm_id prags
-       ; let dia = TcRnIgnoreSpecialisePragmaOnDefMethod sel_name
-
-       ; diagnosticTc (not (null spec_prags)) dia
-
-       ; let hs_ty = hs_sig_fn sel_name
-                     `orElse` pprPanic "tc_dm" (ppr sel_name)
-             -- We need the HsType so that we can bring the right
-             -- type variables into scope
-             --
-             -- Eg.   class C a where
-             --          op :: forall b. Eq b => a -> [b] -> a
-             --          gen_op :: a -> a
-             --          generic gen_op :: D a => a -> a
-             -- The "local_dm_ty" is precisely the type in the above
-             -- type signatures, ie with no "forall a. C a =>" prefix
-
-             local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)
-
-             lm_bind     = dm_bind { fun_id = L (la2na bind_loc) local_dm_name }
-                             -- Substitute the local_meth_name for the binder
-                             -- NB: the binding is always a FunBind
-
-             warn_redundant = case dm_spec of
-                                GenericDM {} -> lhsSigTypeContextSpan hs_ty
-                                VanillaDM    -> NoRRC
-                -- For GenericDM, warn if the user specifies a signature
-                -- with redundant constraints; but not for VanillaDM, where
-                -- the default method may well be 'error' or something
-
-             ctxt = FunSigCtxt sel_name warn_redundant
-
-       ; let local_dm_id = mkLocalId local_dm_name ManyTy local_dm_ty
-             local_dm_sig = CompleteSig { sig_bndr = local_dm_id
-                                        , sig_ctxt  = ctxt
-                                        , sig_loc   = getLocA hs_ty }
-
-       ; (ev_binds, (tc_bind, _))
-               <- checkConstraints skol_info tyvars [this_dict] $
-                  tcPolyCheck no_prag_fn local_dm_sig
-                              (L bind_loc lm_bind)
-
-       ; let export = ABE { abe_poly  = global_dm_id
-                          , abe_mono  = local_dm_id
-                          , abe_wrap  = idHsWrapper
-                          , abe_prags = IsDefaultMethod }
-             full_bind = XHsBindsLR $
-                         AbsBinds { abs_tvs      = tyvars
-                                  , abs_ev_vars  = [this_dict]
-                                  , abs_exports  = [export]
-                                  , abs_ev_binds = [ev_binds]
-                                  , abs_binds    = tc_bind
-                                  , abs_sig      = True }
-
-       ; return (unitBag (L bind_loc full_bind)) }
-
-  | otherwise = pprPanic "tcDefMeth" (ppr sel_id)
-  where
-    skol_info = TyConSkol ClassFlavour (getName clas)
-    sel_name = idName sel_id
-    no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;
-                                -- they are all for meth_id
-
----------------
-tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef
-tcClassMinimalDef _clas sigs op_info
-  = case findMinimalDef sigs of
-      Nothing -> return defMindef
-      Just mindef -> do
-        -- Warn if the given mindef does not imply the default one
-        -- That is, the given mindef should at least ensure that the
-        -- class ops without default methods are required, since we
-        -- have no way to fill them in otherwise
-        tcg_env <- getGblEnv
-        -- However, only do this test when it's not an hsig file,
-        -- since you can't write a default implementation.
-        when (tcg_src tcg_env /= HsigFile) $
-            whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
-                       (\bf -> addDiagnosticTc (TcRnWarningMinimalDefIncomplete bf))
-        return mindef
-  where
-    -- By default require all methods without a default implementation
-    defMindef :: ClassMinimalDef
-    defMindef = mkAnd [ noLocA (mkVar name)
-                      | (name, _, Nothing) <- op_info ]
-
-instantiateMethod :: Class -> TcId -> [TcType] -> TcType
--- Take a class operation, say
---      op :: forall ab. C a => forall c. Ix c => (b,c) -> a
--- Instantiate it at [ty1,ty2]
--- Return the "local method type":
---      forall c. Ix x => (ty2,c) -> ty1
-instantiateMethod clas sel_id inst_tys
-  = assert ok_first_pred local_meth_ty
-  where
-    rho_ty = piResultTys (idType sel_id) inst_tys
-    (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
-                `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
-
-    ok_first_pred = case getClassPredTys_maybe first_pred of
-                      Just (clas1, _tys) -> clas == clas1
-                      Nothing -> False
-              -- The first predicate should be of form (C a b)
-              -- where C is the class in question
-
-
----------------------------
-type HsSigFun = Name -> Maybe (LHsSigType GhcRn)
-
-mkHsSigFun :: [LSig GhcRn] -> HsSigFun
-mkHsSigFun sigs = lookupNameEnv env
-  where
-    env = mkHsSigEnv get_classop_sig sigs
-
-    get_classop_sig :: LSig GhcRn -> Maybe ([LocatedN Name], LHsSigType GhcRn)
-    get_classop_sig  (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty)
-    get_classop_sig  _                               = Nothing
-
----------------------------
-findMethodBind  :: Name                 -- Selector
-                -> LHsBinds GhcRn       -- A group of bindings
-                -> TcPragEnv
-                -> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn])
-                -- Returns the binding, the binding
-                -- site of the method binder, and any inline or
-                -- specialisation pragmas
-findMethodBind sel_name binds prag_fn
-  = foldl' mplus Nothing (mapBag f binds)
-  where
-    prags    = lookupPragEnv prag_fn sel_name
-
-    f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
-      | op_name == sel_name
-             = Just (bind, locA bndr_loc, prags)
-    f _other = Nothing
-
----------------------------
-findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
-findMinimalDef = firstJusts . map toMinimalDef
-  where
-    toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
-    toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf)
-    toMinimalDef _                               = Nothing
-
-{-
-Note [Polymorphic methods]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-    class Foo a where
-        op :: forall b. Ord b => a -> b -> b -> b
-    instance Foo c => Foo [c] where
-        op = e
-
-When typechecking the binding 'op = e', we'll have a meth_id for op
-whose type is
-      op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
-
-So tcPolyBinds must be capable of dealing with nested polytypes;
-and so it is. See GHC.Tc.Gen.Bind.tcMonoBinds (with type-sig case).
-
-Note [Silly default-method bind]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we pass the default method binding to the type checker, it must
-look like    op2 = e
-not          $dmop2 = e
-otherwise the "$dm" stuff comes out error messages.  But we want the
-"$dm" to come out in the interface file.  So we typecheck the former,
-and wrap it in a let, thus
-          $dmop2 = let op2 = e in op2
-This makes the error messages right.
-
-
-************************************************************************
-*                                                                      *
-                Error messages
-*                                                                      *
-************************************************************************
--}
-
-{-
-badGenericInstanceType :: LHsBinds Name -> SDoc
-badGenericInstanceType binds
-  = vcat [text "Illegal type pattern in the generic bindings",
-          nest 2 (ppr binds)]
-
-missingGenericInstances :: [Name] -> SDoc
-missingGenericInstances missing
-  = text "Missing type patterns for" <+> pprQuotedList missing
-
-dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
-dupGenericInsts tc_inst_infos
-  = vcat [text "More than one type pattern for a single generic type constructor:",
-          nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
-          text "All the type patterns for a generic type constructor must be identical"
-    ]
-  where
-    ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
--}
-
-badDmPrag :: TcId -> Sig GhcRn -> TcM ()
-badDmPrag sel_id prag
-  = addErrTc (TcRnDefaultMethodForPragmaLacksBinding sel_id prag)
-
-instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
-instDeclCtxt1 hs_inst_ty
-  = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
-
-instDeclCtxt2 :: Type -> SDoc
-instDeclCtxt2 dfun_ty
-  = instDeclCtxt3 cls tys
-  where
-    (_,_,cls,tys) = tcSplitDFunTy dfun_ty
-
-instDeclCtxt3 :: Class -> [Type] -> SDoc
-instDeclCtxt3 cls cls_tys
-  = inst_decl_ctxt (ppr (mkClassPred cls cls_tys))
-
-inst_decl_ctxt :: SDoc -> SDoc
-inst_decl_ctxt doc = hang (text "In the instance declaration for")
-                        2 (quotes doc)
-
-tcATDefault :: SrcSpan
-            -> Subst
-            -> NameSet
-            -> ClassATItem
-            -> TcM [FamInst]
--- ^ Construct default instances for any associated types that
--- aren't given a user definition
--- Returns [] or singleton
-tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)
-  -- User supplied instances ==> everything is OK
-  | tyConName fam_tc `elemNameSet` defined_ats
-  = return []
-
-  -- No user instance, have defaults ==> instantiate them
-   -- Example:   class C a where { type F a b :: *; type F a b = () }
-   --            instance C [x]
-   -- Then we want to generate the decl:   type F [x] b = ()
-  | Just (rhs_ty, _loc) <- defs
-  = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst
-                                            (tyConTyVars fam_tc)
-             rhs'     = substTyUnchecked subst' rhs_ty
-             tcv' = tyCoVarsOfTypesList pat_tys'
-             (tv', cv') = partition isTyVar tcv'
-             tvs'     = scopedSort tv'
-             cvs'     = scopedSort cv'
-       ; rep_tc_name <- newFamInstTyConName (L (noAnnSrcSpan loc) (tyConName fam_tc)) pat_tys'
-       ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs'
-                                     fam_tc pat_tys' rhs'
-           -- NB: no validity check. We check validity of default instances
-           -- in the class definition. Because type instance arguments cannot
-           -- be type family applications and cannot be polytypes, the
-           -- validity check is redundant.
-
-       ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty
-                                              , pprCoAxiom axiom ])
-       ; fam_inst <- newFamInst SynFamilyInst axiom
-       ; return [fam_inst] }
-
-   -- No defaults ==> generate a warning
-  | otherwise  -- defs = Nothing
-  = do { warnMissingAT (tyConName fam_tc)
-       ; return [] }
-  where
-    subst_tv subst tc_tv
-      | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
-      = (subst, ty)
-      | otherwise
-      = (extendTvSubst subst tc_tv ty', ty')
-      where
-        ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv)
-
-warnMissingAT :: Name -> TcM ()
-warnMissingAT name
-  = do { warn <- woptM Opt_WarnMissingMethods
-       ; traceTc "warn" (ppr name <+> ppr warn)
-       ; hsc_src <- fmap tcg_src getGblEnv
-       -- hs-boot and signatures never need to provide complete "definitions"
-       -- of any sort, as they aren't really defining anything, but just
-       -- constraining items which are defined elsewhere.
-       ; let dia = TcRnNoExplicitAssocTypeOrDefaultDeclaration name
-       ; diagnosticTc  (warn && hsc_src == HsSrcFile) dia
-                       }
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ /dev/null
@@ -1,2363 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
--- | Typechecking instance declarations
-module GHC.Tc.TyCl.Instance
-   ( tcInstDecls1
-   , tcInstDeclsDeriv
-   , tcInstDecls2
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Hs
-import GHC.Tc.Errors.Types
-import GHC.Tc.Gen.Bind
-import GHC.Tc.TyCl
-import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv )
-import GHC.Tc.TyCl.Class ( tcClassDecl2, tcATDefault,
-                           HsSigFun, mkHsSigFun, findMethodBind,
-                           instantiateMethod )
-import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )
-import GHC.Tc.Gen.Sig
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Validity
-import GHC.Tc.Utils.Zonk
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Origin
-import GHC.Tc.TyCl.Build
-import GHC.Tc.Utils.Instantiate
-import GHC.Tc.Instance.Class( AssocInstInfo(..), isNotAssociated )
-import GHC.Core.Multiplicity
-import GHC.Core.InstEnv
-import GHC.Tc.Instance.Family
-import GHC.Core.FamInstEnv
-import GHC.Tc.Deriv
-import GHC.Tc.Utils.Env
-import GHC.Tc.Gen.HsType
-import GHC.Tc.Utils.Unify
-import GHC.Core        ( Expr(..), mkApps, mkVarApps, mkLams )
-import GHC.Core.Make   ( nO_METHOD_BINDING_ERROR_ID )
-import GHC.Core.Unfold.Make ( mkInlineUnfoldingWithArity, mkDFunUnfolding )
-import GHC.Core.Type
-import GHC.Core.SimpleOpt
-import GHC.Core.Predicate( classMethodInstTy )
-import GHC.Tc.Types.Evidence
-import GHC.Core.TyCon
-import GHC.Core.Coercion.Axiom
-import GHC.Core.DataCon
-import GHC.Core.ConLike
-import GHC.Core.Class
-import GHC.Types.Error
-import GHC.Types.Var as Var
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
-import GHC.Data.Bag
-import GHC.Types.Basic
-import GHC.Types.Fixity
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-import GHC.Utils.Logger
-import GHC.Data.FastString
-import GHC.Types.Id
-import GHC.Types.SourceText
-import GHC.Data.List.SetOps
-import GHC.Types.Name
-import GHC.Types.Name.Set
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Types.SrcLoc
-import GHC.Utils.Misc
-import GHC.Data.BooleanFormula ( isUnsatisfied )
-import qualified GHC.LanguageExtensions as LangExt
-
-import Control.Monad
-import Data.Tuple
-import GHC.Data.Maybe
-import Data.List( mapAccumL )
-
-
-{-
-Typechecking instance declarations is done in two passes. The first
-pass, made by @tcInstDecls1@, collects information to be used in the
-second pass.
-
-This pre-processed info includes the as-yet-unprocessed bindings
-inside the instance declaration.  These are type-checked in the second
-pass, when the class-instance envs and GVE contain all the info from
-all the instance and value decls.  Indeed that's the reason we need
-two passes over the instance decls.
-
-
-Note [How instance declarations are translated]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here is how we translate instance declarations into Core
-
-Running example:
-        class C a where
-           op1, op2 :: Ix b => a -> b -> b
-           op2 = <dm-rhs>
-
-        instance C a => C [a]
-           {-# INLINE [2] op1 #-}
-           op1 = <rhs>
-===>
-        -- Method selectors
-        op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
-        op1 = ...
-        op2 = ...
-
-        -- Default methods get the 'self' dictionary as argument
-        -- so they can call other methods at the same type
-        -- Default methods get the same type as their method selector
-        $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
-        $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
-               -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
-               -- Note [Tricky type variable scoping]
-
-        -- A top-level definition for each instance method
-        -- Here op1_i, op2_i are the "instance method Ids"
-        -- The INLINE pragma comes from the user pragma
-        {-# INLINE [2] op1_i #-}  -- From the instance decl bindings
-        op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
-        op1_i = /\a. \(d:C a).
-               let this :: C [a]
-                   this = df_i a d
-                     -- Note [Subtle interaction of recursion and overlap]
-
-                   local_op1 :: forall b. Ix b => [a] -> b -> b
-                   local_op1 = <rhs>
-                     -- Source code; run the type checker on this
-                     -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
-                     -- Note [Tricky type variable scoping]
-
-               in local_op1 a d
-
-        op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
-
-        -- The dictionary function itself
-        {-# NOINLINE CONLIKE df_i #-}   -- Never inline dictionary functions
-        df_i :: forall a. C a -> C [a]
-        df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
-                -- But see Note [Default methods in instances]
-                -- We can't apply the type checker to the default-method call
-
-        -- Use a RULE to short-circuit applications of the class ops
-        {-# RULE "op1@C[a]" forall a, d:C a.
-                            op1 [a] (df_i d) = op1_i a d #-}
-
-Note [Instances and loop breakers]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* Note that df_i may be mutually recursive with both op1_i and op2_i.
-  It's crucial that df_i is not chosen as the loop breaker, even
-  though op1_i has a (user-specified) INLINE pragma.
-
-* Instead the idea is to inline df_i into op1_i, which may then select
-  methods from the MkC record, and thereby break the recursion with
-  df_i, leaving a *self*-recursive op1_i.  (If op1_i doesn't call op at
-  the same type, it won't mention df_i, so there won't be recursion in
-  the first place.)
-
-* If op1_i is marked INLINE by the user there's a danger that we won't
-  inline df_i in it, and that in turn means that (since it'll be a
-  loop-breaker because df_i isn't), op1_i will ironically never be
-  inlined.  But this is OK: the recursion breaking happens by way of
-  a RULE (the magic ClassOp rule above), and RULES work inside stable
-  unfoldings. See Note [RULEs enabled in InitialPhase] in GHC.Core.Opt.Simplify.Utils
-
-Note [ClassOp/DFun selection]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-One thing we see a lot is stuff like
-    op2 (df d1 d2)
-where 'op2' is a ClassOp and 'df' is DFun.  Now, we could inline *both*
-'op2' and 'df' to get
-     case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
-       MkD _ op2 _ _ _ -> op2
-And that will reduce to ($cop2 d1 d2) which is what we wanted.
-
-But it's tricky to make this work in practice, because it requires us to
-inline both 'op2' and 'df'.  But neither is keen to inline without having
-seen the other's result; and it's very easy to get code bloat (from the
-big intermediate) if you inline a bit too much.
-
-Instead we use a cunning trick.
- * We arrange that 'df' and 'op2' NEVER inline.
-
- * We arrange that 'df' is ALWAYS defined in the sylised form
-      df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
-
- * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
-   that lists its methods.
-
- * We make GHC.Core.Unfold.exprIsConApp_maybe spot a DFunUnfolding and return
-   a suitable constructor application -- inlining df "on the fly" as it
-   were.
-
- * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that
-   extracts the right piece iff its argument satisfies
-   exprIsConApp_maybe.  This is done in GHC.Types.Id.Make.mkDictSelId
-
- * We make 'df' CONLIKE, so that shared uses still match; eg
-      let d = df d1 d2
-      in ...(op2 d)...(op1 d)...
-
-Note [Single-method classes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If the class has just one method (or, more accurately, just one element
-of {superclasses + methods}), then we use a different strategy.
-
-   class C a where op :: a -> a
-   instance C a => C [a] where op = <blah>
-
-We translate the class decl into a newtype, which just gives a
-top-level axiom. The "constructor" MkC expands to a cast, as does the
-class-op selector.
-
-   axiom Co:C a :: C a ~ (a->a)
-
-   op :: forall a. C a -> (a -> a)
-   op a d = d |> (Co:C a)
-
-   MkC :: forall a. (a->a) -> C a
-   MkC = /\a.\op. op |> (sym Co:C a)
-
-The clever RULE stuff doesn't work now, because ($df a d) isn't
-a constructor application, so exprIsConApp_maybe won't return
-Just <blah>.
-
-Instead, we simply rely on the fact that casts are cheap:
-
-   $df :: forall a. C a => C [a]
-   {-# INLINE df #-}  -- NB: INLINE this
-   $df = /\a. \d. MkC [a] ($cop_list a d)
-       = $cop_list |> forall a. C a -> (sym (Co:C [a]))
-
-   $cop_list :: forall a. C a => [a] -> [a]
-   $cop_list = <blah>
-
-So if we see
-   (op ($df a d))
-we'll inline 'op' and '$df', since both are simply casts, and
-good things happen.
-
-Why do we use this different strategy?  Because otherwise we
-end up with non-inlined dictionaries that look like
-    $df = $cop |> blah
-which adds an extra indirection to every use, which seems stupid.  See
-#4138 for an example (although the regression reported there
-wasn't due to the indirection).
-
-There is an awkward wrinkle though: we want to be very
-careful when we have
-    instance C a => C [a] where
-      {-# INLINE op #-}
-      op = ...
-then we'll get an INLINE pragma on $cop_list but it's important that
-$cop_list only inlines when it's applied to *two* arguments (the
-dictionary and the list argument).  So we must not eta-expand $df
-above.  We ensure that this doesn't happen by putting an INLINE
-pragma on the dfun itself; after all, it ends up being just a cast.
-
-There is one more dark corner to the INLINE story, even more deeply
-buried.  Consider this (#3772):
-
-    class DeepSeq a => C a where
-      gen :: Int -> a
-
-    instance C a => C [a] where
-      gen n = ...
-
-    class DeepSeq a where
-      deepSeq :: a -> b -> b
-
-    instance DeepSeq a => DeepSeq [a] where
-      {-# INLINE deepSeq #-}
-      deepSeq xs b = foldr deepSeq b xs
-
-That gives rise to these defns:
-
-    $cdeepSeq :: DeepSeq a -> [a] -> b -> b
-    -- User INLINE( 3 args )!
-    $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...
-
-    $fDeepSeq[] :: DeepSeq a -> DeepSeq [a]
-    -- DFun (with auto INLINE pragma)
-    $fDeepSeq[] a d = $cdeepSeq a d |> blah
-
-    $cp1 a d :: C a => DeepSep [a]
-    -- We don't want to eta-expand this, lest
-    -- $cdeepSeq gets inlined in it!
-    $cp1 a d = $fDeepSep[] a (scsel a d)
-
-    $fC[] :: C a => C [a]
-    -- Ordinary DFun
-    $fC[] a d = MkC ($cp1 a d) ($cgen a d)
-
-Here $cp1 is the code that generates the superclass for C [a].  The
-issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]
-and then $cdeepSeq will inline there, which is definitely wrong.  Like
-on the dfun, we solve this by adding an INLINE pragma to $cp1.
-
-Note [Subtle interaction of recursion and overlap]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this
-  class C a where { op1,op2 :: a -> a }
-  instance C a => C [a] where
-    op1 x = op2 x ++ op2 x
-    op2 x = ...
-  instance C [Int] where
-    ...
-
-When type-checking the C [a] instance, we need a C [a] dictionary (for
-the call of op2).  If we look up in the instance environment, we find
-an overlap.  And in *general* the right thing is to complain (see Note
-[Overlapping instances] in GHC.Core.InstEnv).  But in *this* case it's wrong to
-complain, because we just want to delegate to the op2 of this same
-instance.
-
-Why is this justified?  Because we generate a (C [a]) constraint in
-a context in which 'a' cannot be instantiated to anything that matches
-other overlapping instances, or else we would not be executing this
-version of op1 in the first place.
-
-It might even be a bit disguised:
-
-  nullFail :: C [a] => [a] -> [a]
-  nullFail x = op2 x ++ op2 x
-
-  instance C a => C [a] where
-    op1 x = nullFail x
-
-Precisely this is used in package 'regex-base', module Context.hs.
-See the overlapping instances for RegexContext, and the fact that they
-call 'nullFail' just like the example above.  The DoCon package also
-does the same thing; it shows up in module Fraction.hs.
-
-Conclusion: when typechecking the methods in a C [a] instance, we want to
-treat the 'a' as an *existential* type variable, in the sense described
-by Note [Binding when looking up instances].  That is why isOverlappableTyVar
-responds True to an InstSkol, which is the kind of skolem we use in
-tcInstDecl2.
-
-
-Note [Tricky type variable scoping]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In our example
-        class C a where
-           op1, op2 :: Ix b => a -> b -> b
-           op2 = <dm-rhs>
-
-        instance C a => C [a]
-           {-# INLINE [2] op1 #-}
-           op1 = <rhs>
-
-note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
-in scope in <rhs>.  In particular, we must make sure that 'b' is in
-scope when typechecking <dm-rhs>.  This is achieved by subFunTys,
-which brings appropriate tyvars into scope. This happens for both
-<dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
-complained if 'b' is mentioned in <rhs>.
-
-
-
-************************************************************************
-*                                                                      *
-\subsection{Extracting instance decls}
-*                                                                      *
-************************************************************************
-
-Gather up the instance declarations from their various sources
--}
-
-tcInstDecls1    -- Deal with both source-code and imported instance decls
-   :: [LInstDecl GhcRn]         -- Source code instance decls
-   -> TcM (TcGblEnv,            -- The full inst env
-           [InstInfo GhcRn],    -- Source-code instance decls to process;
-                                -- contains all dfuns for this module
-           [DerivInfo],         -- From data family instances
-           ThBindEnv)           -- TH binding levels
-
-tcInstDecls1 inst_decls
-  = do {    -- Do class and family instance declarations
-       ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls
-
-       ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff
-             fam_insts   = concat fam_insts_s
-             local_infos = concat local_infos_s
-
-       ; (gbl_env, th_bndrs) <-
-           addClsInsts local_infos $
-           addFamInsts fam_insts
-
-       ; return ( gbl_env
-                , local_infos
-                , concat datafam_deriv_infos
-                , th_bndrs ) }
-
--- | Use DerivInfo for data family instances (produced by tcInstDecls1),
---   datatype declarations (TyClDecl), and standalone deriving declarations
---   (DerivDecl) to check and process all derived class instances.
-tcInstDeclsDeriv
-  :: [DerivInfo]
-  -> [LDerivDecl GhcRn]
-  -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
-tcInstDeclsDeriv deriv_infos derivds
-  = do th_stage <- getStage -- See Note [Deriving inside TH brackets]
-       if isBrackStage th_stage
-       then do { gbl_env <- getGblEnv
-               ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) }
-       else do { (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds
-               ; return (tcg_env, bagToList info_bag, valbinds) }
-
-addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a
-addClsInsts infos thing_inside
-  = tcExtendLocalInstEnv (map iSpec infos) thing_inside
-
-addFamInsts :: [FamInst] -> TcM (TcGblEnv, ThBindEnv)
--- Extend (a) the family instance envt
---        (b) the type envt with stuff from data type decls
-addFamInsts fam_insts
-  = tcExtendLocalFamInstEnv fam_insts $
-    tcExtendGlobalEnv axioms          $
-    do { traceTc "addFamInsts" (pprFamInsts fam_insts)
-       ; (gbl_env, th_bndrs) <- addTyConsToGblEnv data_rep_tycons
-                    -- Does not add its axiom; that comes
-                    -- from adding the 'axioms' above
-       ; return (gbl_env, th_bndrs)
-       }
-  where
-    axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts
-    data_rep_tycons = famInstsRepTyCons fam_insts
-      -- The representation tycons for 'data instances' declarations
-
-{-
-Note [Deriving inside TH brackets]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given a declaration bracket
-  [d| data T = A | B deriving( Show ) |]
-
-there is really no point in generating the derived code for deriving(
-Show) and then type-checking it. This will happen at the call site
-anyway, and the type check should never fail!  Moreover (#6005)
-the scoping of the generated code inside the bracket does not seem to
-work out.
-
-The easy solution is simply not to generate the derived instances at
-all.  (A less brutal solution would be to generate them with no
-bindings.)  This will become moot when we shift to the new TH plan, so
-the brutal solution will do.
--}
-
-tcLocalInstDecl :: LInstDecl GhcRn
-                -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
-        -- A source-file instance declaration
-        -- Type-check all the stuff before the "where"
-        --
-        -- We check for respectable instance type, and context
-tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))
-  = do { fam_inst <- tcTyFamInstDecl NotAssociated (L loc decl)
-       ; return ([], [fam_inst], []) }
-
-tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))
-  = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated emptyVarEnv (L loc decl)
-       ; return ([], [fam_inst], maybeToList m_deriv_info) }
-
-tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
-  = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl)
-       ; return (insts, fam_insts, deriv_infos) }
-
-tcClsInstDecl :: LClsInstDecl GhcRn
-              -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
--- The returned DerivInfos are for any associated data families
-tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
-                                  , cid_sigs = uprags, cid_tyfam_insts = ats
-                                  , cid_overlap_mode = overlap_mode
-                                  , cid_datafam_insts = adts }))
-  = setSrcSpanA loc                      $
-    addErrCtxt (instDeclCtxt1 hs_ty)  $
-    do  { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty
-        ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty
-             -- NB: tcHsClsInstType does checkValidInstance
-        ; skol_info <- mkSkolemInfo InstSkol
-        ; (subst, skol_tvs) <- tcInstSkolTyVars skol_info tyvars
-        ; let tv_skol_prs = [ (tyVarName tv, skol_tv)
-                            | (tv, skol_tv) <- tyvars `zip` skol_tvs ]
-              -- Map from the skolemized Names to the original Names.
-              -- See Note [Associated data family instances and di_scoped_tvs].
-              tv_skol_env = mkVarEnv $ map swap tv_skol_prs
-              n_inferred = countWhile ((== Inferred) . binderFlag) $
-                           fst $ splitForAllForAllTyBinders dfun_ty
-              visible_skol_tvs = drop n_inferred skol_tvs
-
-        ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs)
-
-        -- Next, process any associated types.
-        ; (datafam_stuff, tyfam_insts)
-             <- tcExtendNameTyVarEnv tv_skol_prs $
-                do  { let mini_env   = mkVarEnv (classTyVars clas `zip` substTys subst inst_tys)
-                          mini_subst = mkTvSubst (mkInScopeSet (mkVarSet skol_tvs)) mini_env
-                          mb_info    = InClsInst { ai_class = clas
-                                                 , ai_tyvars = visible_skol_tvs
-                                                 , ai_inst_env = mini_env }
-                    ; df_stuff  <- mapAndRecoverM (tcDataFamInstDecl mb_info tv_skol_env) adts
-                    ; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info)   ats
-
-                      -- Check for missing associated types and build them
-                      -- from their defaults (if available)
-                    ; is_boot <- tcIsHsBootOrSig
-                    ; let atItems = classATItems clas
-                    ; tf_insts2 <- mapM (tcATDefault (locA loc) mini_subst defined_ats)
-                                        (if is_boot then [] else atItems)
-                      -- Don't default type family instances, but rather omit, in hsig/hs-boot.
-                      -- Since hsig/hs-boot files are essentially large binders we want omission
-                      -- of the definition to result in no restriction, rather than for example
-                      -- attempting to "pattern match" with the invisible defaults and generate
-                      -- equalities. Without further handling, this would just result in a panic
-                      -- anyway.
-                      -- See https://github.com/ghc-proposals/ghc-proposals/pull/320 for
-                      -- additional discussion.
-                    ; return (df_stuff, tf_insts1 ++ concat tf_insts2) }
-
-
-        -- Finally, construct the Core representation of the instance.
-        -- (This no longer includes the associated types.)
-        ; dfun_name <- newDFunName clas inst_tys (getLocA hs_ty)
-                -- Dfun location is that of instance *header*
-
-        ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name
-                              tyvars theta clas inst_tys
-
-        ; let inst_binds = InstBindings
-                             { ib_binds = binds
-                             , ib_tyvars = map Var.varName tyvars -- Scope over bindings
-                             , ib_pragmas = uprags
-                             , ib_extensions = []
-                             , ib_derived = False }
-              inst_info = InstInfo { iSpec  = ispec, iBinds = inst_binds }
-
-              (datafam_insts, m_deriv_infos) = unzip datafam_stuff
-              deriv_infos                    = catMaybes m_deriv_infos
-              all_insts                      = tyfam_insts ++ datafam_insts
-
-         -- In hs-boot files there should be no bindings
-        ; let no_binds = isEmptyLHsBinds binds && null uprags
-        ; is_boot <- tcIsHsBootOrSig
-        ; failIfTc (is_boot && not no_binds) TcRnIllegalHsBootFileDecl
-
-        ; return ( [inst_info], all_insts, deriv_infos ) }
-  where
-    defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
-                  `unionNameSet`
-                  mkNameSet (map (unLoc . feqn_tycon
-                                        . dfid_eqn
-                                        . unLoc) adts)
-
-{-
-************************************************************************
-*                                                                      *
-               Type family instances
-*                                                                      *
-************************************************************************
-
-Family instances are somewhat of a hybrid.  They are processed together with
-class instance heads, but can contain data constructors and hence they share a
-lot of kinding and type checking code with ordinary algebraic data types (and
-GADTs).
--}
-
-tcTyFamInstDecl :: AssocInstInfo
-                -> LTyFamInstDecl GhcRn -> TcM FamInst
-  -- "type instance"
-  -- See Note [Associated type instances]
-tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
-  = setSrcSpanA loc           $
-    tcAddTyFamInstCtxt decl  $
-    do { let fam_lname = feqn_tycon eqn
-       ; fam_tc <- tcLookupLocatedTyCon fam_lname
-       ; tcFamInstDeclChecks mb_clsinfo fam_tc
-
-         -- (0) Check it's an open type family
-       ; checkTc (isTypeFamilyTyCon fam_tc)     (wrongKindOfFamily fam_tc)
-       ; checkTc (isOpenTypeFamilyTyCon fam_tc) (TcRnNotOpenFamily fam_tc)
-
-         -- (1) do the work of verifying the synonym group
-         -- For some reason we don't have a location for the equation
-         -- itself, so we make do with the location of family name
-       ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo
-                                        (L (na2la $ getLoc fam_lname) eqn)
-
-         -- (2) check for validity
-       ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch
-       ; checkValidCoAxBranch fam_tc co_ax_branch
-
-         -- (3) construct coercion axiom
-       ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch]
-       ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch
-       ; newFamInst SynFamilyInst axiom }
-
-
----------------------
-tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcM ()
--- Used for both type and data families
-tcFamInstDeclChecks mb_clsinfo fam_tc
-  = do { -- Type family instances require -XTypeFamilies
-         -- and can't (currently) be in an hs-boot file
-       ; traceTc "tcFamInstDecl" (ppr fam_tc)
-       ; type_families <- xoptM LangExt.TypeFamilies
-       ; is_boot       <- tcIsHsBootOrSig   -- Are we compiling an hs-boot file?
-       ; checkTc type_families (TcRnBadFamInstDecl fam_tc)
-       ; checkTc (not is_boot) TcRnBadBootFamInstDecl
-
-       -- Check that it is a family TyCon, and that
-       -- oplevel type instances are not for associated types.
-       ; checkTc (isFamilyTyCon fam_tc) (TcRnIllegalFamilyInstance fam_tc)
-
-       ; when (isNotAssociated mb_clsinfo &&   -- Not in a class decl
-               isTyConAssoc fam_tc)            -- but an associated type
-              (addErr $ TcRnMissingClassAssoc fam_tc)
-       }
-
-{- Note [Associated type instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We allow this:
-  class C a where
-    type T x a
-  instance C Int where
-    type T (S y) Int = y
-    type T Z     Int = Char
-
-Note that
-  a) The variable 'x' is not bound by the class decl
-  b) 'x' is instantiated to a non-type-variable in the instance
-  c) There are several type instance decls for T in the instance
-
-All this is fine.  Of course, you can't give any *more* instances
-for (T ty Int) elsewhere, because it's an *associated* type.
-
-
-************************************************************************
-*                                                                      *
-               Data family instances
-*                                                                      *
-************************************************************************
-
-For some reason data family instances are a lot more complicated
-than type family instances
--}
-
-tcDataFamInstDecl ::
-     AssocInstInfo
-  -> TyVarEnv Name -- If this is an associated data family instance, maps the
-                   -- parent class's skolemized type variables to their
-                   -- original Names. If this is a non-associated instance,
-                   -- this will be empty.
-                   -- See Note [Associated data family instances and di_scoped_tvs].
-  -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)
-  -- "newtype instance" and "data instance"
-tcDataFamInstDecl mb_clsinfo tv_skol_env
-    (L loc decl@(DataFamInstDecl { dfid_eqn =
-      FamEqn { feqn_bndrs  = outer_bndrs
-             , feqn_pats   = hs_pats
-             , feqn_tycon  = lfam_name@(L _ fam_name)
-             , feqn_fixity = fixity
-             , feqn_rhs    = HsDataDefn { dd_cType   = cType
-                                        , dd_ctxt    = hs_ctxt
-                                        , dd_cons    = hs_cons
-                                        , dd_kindSig = m_ksig
-                                        , dd_derivs  = derivs } }}))
-  = setSrcSpanA loc            $
-    tcAddDataFamInstCtxt decl  $
-    do { fam_tc <- tcLookupLocatedTyCon lfam_name
-
-       ; tcFamInstDeclChecks mb_clsinfo fam_tc
-
-       -- Check that the family declaration is for the right kind
-       ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
-       ; gadt_syntax <- dataDeclChecks fam_name hs_ctxt hs_cons
-          -- Do /not/ check that the number of patterns = tyConArity fam_tc
-          -- See [Arity of data families] in GHC.Core.FamInstEnv
-       ; skol_info <- mkSkolemInfo FamInstSkol
-       ; let new_or_data = dataDefnConsNewOrData hs_cons
-       ; (qtvs, pats, tc_res_kind, stupid_theta)
-             <- tcDataFamInstHeader mb_clsinfo skol_info fam_tc outer_bndrs fixity
-                                    hs_ctxt hs_pats m_ksig new_or_data
-
-       -- Eta-reduce the axiom if possible
-       -- Quite tricky: see Note [Implementing eta reduction for data families]
-       ; let (eta_pats, eta_tcbs) = eta_reduce fam_tc pats
-             eta_tvs       = map binderVar eta_tcbs
-             post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs
-
-             full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs
-                            (tyCoVarsOfType (mkSpecForAllTys eta_tvs tc_res_kind))
-                         ++ eta_tcbs
-                 -- Put the eta-removed tyvars at the end
-                 -- Remember, qtvs is in arbitrary order, except kind vars are
-                 -- first, so there is no reason to suppose that the eta_tvs
-                 -- (obtained from the pats) are at the end (#11148)
-
-       -- Eta-expand the representation tycon until it has result
-       -- kind `TYPE r`, for some `r`. If UnliftedNewtypes is not enabled, we
-       -- go one step further and ensure that it has kind `TYPE 'LiftedRep`.
-       --
-       -- See also Note [Arity of data families] in GHC.Core.FamInstEnv
-       -- NB: we can do this after eta-reducing the axiom, because if
-       --     we did it before the "extra" tvs from etaExpandAlgTyCon
-       --     would always be eta-reduced
-       --
-       ; let flav = newOrDataToFlavour new_or_data
-       ; (extra_tcbs, tc_res_kind) <- etaExpandAlgTyCon flav skol_info full_tcbs tc_res_kind
-
-       -- Check the result kind; it may come from a user-written signature.
-       -- See Note [Datatype return kinds] in GHC.Tc.TyCl point 4(a)
-       ; let extra_pats    = map (mkTyVarTy . binderVar) extra_tcbs
-             all_pats      = pats `chkAppend` extra_pats
-             orig_res_ty   = mkTyConApp fam_tc all_pats
-             tc_ty_binders = full_tcbs `chkAppend` extra_tcbs
-
-       ; traceTc "tcDataFamInstDecl 1" $
-         vcat [ text "Fam tycon:" <+> ppr fam_tc
-              , text "Pats:" <+> ppr pats
-              , text "visibilities:" <+> ppr (tcbVisibilities fam_tc pats)
-              , text "all_pats:" <+> ppr all_pats
-              , text "tc_ty_binders" <+> ppr tc_ty_binders
-              , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc)
-              , text "tc_res_kind:" <+> ppr tc_res_kind
-              , text "eta_pats" <+> ppr eta_pats
-              , text "eta_tcbs" <+> ppr eta_tcbs ]
-
-       -- Zonk the patterns etc into the Type world
-       ; ze                <- mkEmptyZonkEnv NoFlexi
-       ; (ze, ty_binders)  <- zonkTyVarBindersX   ze tc_ty_binders
-       ; res_kind          <- zonkTcTypeToTypeX   ze tc_res_kind
-       ; all_pats          <- zonkTcTypesToTypesX ze all_pats
-       ; eta_pats          <- zonkTcTypesToTypesX ze eta_pats
-       ; stupid_theta      <- zonkTcTypesToTypesX ze stupid_theta
-       ; let zonked_post_eta_qtvs = map (lookupTyVarX ze) post_eta_qtvs
-             zonked_eta_tvs       = map (lookupTyVarX ze) eta_tvs
-             -- All these qtvs are in ty_binders, and hence will be in
-             -- the ZonkEnv, ze.  We need the zonked (TyVar) versions to
-             -- put in the CoAxiom that we are about to build.
-
-       ; traceTc "tcDataFamInstDecl" $
-         vcat [ text "Fam tycon:" <+> ppr fam_tc
-              , text "Pats:" <+> ppr pats
-              , text "visibilities:" <+> ppr (tcbVisibilities fam_tc pats)
-              , text "all_pats:" <+> ppr all_pats
-              , text "ty_binders" <+> ppr ty_binders
-              , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc)
-              , text "res_kind:" <+> ppr res_kind
-              , text "eta_pats" <+> ppr eta_pats
-              , text "eta_tcbs" <+> ppr eta_tcbs ]
-       ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->
-           do { data_cons <- tcExtendTyVarEnv (binderVars tc_ty_binders) $
-                  -- For H98 decls, the tyvars scope
-                  -- over the data constructors
-                  tcConDecls (DDataInstance orig_res_ty) rec_rep_tc tc_ty_binders tc_res_kind
-                      hs_cons
-
-              ; rep_tc_name <- newFamInstTyConName lfam_name pats
-              ; axiom_name  <- newFamInstAxiomName lfam_name [pats]
-              ; tc_rhs <- case data_cons of
-                     DataTypeCons type_data data_cons -> return $
-                        mkLevPolyDataTyConRhs
-                          (isFixedRuntimeRepKind res_kind)
-                          type_data
-                          data_cons
-                     NewTypeCon data_con -> mkNewTyConRhs rep_tc_name rec_rep_tc data_con
-
-              ; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys zonked_post_eta_qtvs)
-                    axiom  = mkSingleCoAxiom Representational axiom_name
-                                 zonked_post_eta_qtvs zonked_eta_tvs
-                                 [] fam_tc eta_pats ax_rhs
-                    parent = DataFamInstTyCon axiom fam_tc all_pats
-
-                      -- NB: Use the full ty_binders from the pats. See bullet toward
-                      -- the end of Note [Data type families] in GHC.Core.TyCon
-                    rep_tc   = mkAlgTyCon rep_tc_name
-                                          ty_binders res_kind
-                                          (map (const Nominal) ty_binders)
-                                          (fmap unLoc cType) stupid_theta
-                                          tc_rhs parent
-                                          gadt_syntax
-                 -- We always assume that indexed types are recursive.  Why?
-                 -- (1) Due to their open nature, we can never be sure that a
-                 -- further instance might not introduce a new recursive
-                 -- dependency.  (2) They are always valid loop breakers as
-                 -- they involve a coercion.
-              ; return (rep_tc, axiom) }
-
-       -- Remember to check validity; no recursion to worry about here
-       -- Check that left-hand sides are ok (mono-types, no type families,
-       -- consistent instantiations, etc)
-       ; let ax_branch = coAxiomSingleBranch axiom
-       ; checkConsistentFamInst mb_clsinfo fam_tc ax_branch
-       ; checkValidCoAxBranch fam_tc ax_branch
-       ; checkValidTyCon rep_tc
-
-       ; let scoped_tvs = map mk_deriv_info_scoped_tv_pr (tyConTyVars rep_tc)
-             m_deriv_info = case derivs of
-               []    -> Nothing
-               preds ->
-                 Just $ DerivInfo { di_rep_tc  = rep_tc
-                                  , di_scoped_tvs = scoped_tvs
-                                  , di_clauses = preds
-                                  , di_ctxt    = tcMkDataFamInstCtxt decl }
-
-       ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom
-       ; return (fam_inst, m_deriv_info) }
-  where
-    eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder])
-    -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom
-    -- Splits the incoming patterns into two: the [TyVar]
-    -- are the patterns that can be eta-reduced away.
-    -- e.g.     T [a] Int a d c   ==>  (T [a] Int a, [d,c])
-    --
-    -- NB: quadratic algorithm, but types are small here
-    eta_reduce fam_tc pats
-        = go (reverse (zip3 pats fvs_s vis_s)) []
-        where
-          vis_s :: [TyConBndrVis]
-          vis_s = tcbVisibilities fam_tc pats
-
-          fvs_s :: [TyCoVarSet]  -- 1-1 correspondence with pats
-                                 -- Each elt is the free vars of all /earlier/ pats
-          (_, fvs_s) = mapAccumL add_fvs emptyVarSet pats
-          add_fvs fvs pat = (fvs `unionVarSet` tyCoVarsOfType pat, fvs)
-
-    go ((pat, fvs_to_the_left, tcb_vis):pats) etad_tvs
-      | Just tv <- getTyVar_maybe pat
-      , not (tv `elemVarSet` fvs_to_the_left)
-      = go pats (Bndr tv tcb_vis : etad_tvs)
-    go pats etad_tvs = (reverse (map fstOf3 pats), etad_tvs)
-
-    -- Create a Name-TyVar mapping to bring into scope when typechecking any
-    -- deriving clauses this data family instance may have.
-    -- See Note [Associated data family instances and di_scoped_tvs].
-    mk_deriv_info_scoped_tv_pr :: TyVar -> (Name, TyVar)
-    mk_deriv_info_scoped_tv_pr tv =
-      let n = lookupWithDefaultVarEnv tv_skol_env (tyVarName tv) tv
-      in (n, tv)
-
-{-
-Note [Associated data family instances and di_scoped_tvs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Some care is required to implement `deriving` correctly for associated data
-family instances. Consider this example from #18055:
-
-  class C a where
-    data D a
-
-  class X a b
-
-  instance C (Maybe a) where
-    data D (Maybe a) deriving (X a)
-
-When typechecking the `X a` in `deriving (X a)`, we must ensure that the `a`
-from the instance header is brought into scope. This is the role of
-di_scoped_tvs, which maps from the original, renamed `a` to the skolemized,
-typechecked `a`. When typechecking the `deriving` clause, this mapping will be
-consulted when looking up the `a` in `X a`.
-
-A naïve attempt at creating the di_scoped_tvs is to simply reuse the
-tyConTyVars of the representation TyCon for `data D (Maybe a)`. This is only
-half correct, however. We do want the typechecked `a`'s Name in the /range/
-of the mapping, but we do not want it in the /domain/ of the mapping.
-To ensure that the original `a`'s Name ends up in the domain, we consult a
-TyVarEnv (passed as an argument to tcDataFamInstDecl) that maps from the
-typechecked `a`'s Name to the original `a`'s Name. In the even that
-tcDataFamInstDecl is processing a non-associated data family instance, this
-TyVarEnv will simply be empty, and there is nothing to worry about.
--}
-
------------------------
-tcDataFamInstHeader
-    :: AssocInstInfo -> SkolemInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn
-    -> LexicalFixity -> Maybe (LHsContext GhcRn)
-    -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn)
-    -> NewOrData
-    -> TcM ([TcTyVar], [TcType], TcKind, TcThetaType)
-         -- All skolem TcTyVars, all zonked so it's clear what the free vars are
--- The "header" of a data family instance is the part other than
--- the data constructors themselves
---    e.g.  data instance D [a] :: * -> * where ...
--- Here the "header" is the bit before the "where"
-tcDataFamInstHeader mb_clsinfo skol_info fam_tc hs_outer_bndrs fixity
-                    hs_ctxt hs_pats m_ksig new_or_data
-  = do { traceTc "tcDataFamInstHeader {" (ppr fam_tc <+> ppr hs_pats)
-       ; (tclvl, wanted, (outer_bndrs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind)))
-            <- pushLevelAndSolveEqualitiesX "tcDataFamInstHeader" $
-               bindOuterFamEqnTKBndrs skol_info hs_outer_bndrs    $  -- Binds skolem TcTyVars
-               do { stupid_theta <- tcHsContext hs_ctxt
-                  ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats
-                  ; (lhs_applied_ty, lhs_applied_kind)
-                      <- tcInstInvisibleTyBinders lhs_ty lhs_kind
-                      -- See Note [Data family/instance return kinds]
-                      -- in GHC.Tc.TyCl point (DF3)
-
-                  -- Ensure that the instance is consistent
-                  -- with its parent class
-                  ; addConsistencyConstraints mb_clsinfo lhs_ty
-
-                  -- Add constraints from the result signature
-                  ; res_kind <- tc_kind_sig m_ksig
-
-                  -- Do not add constraints from the data constructors
-                  -- See Note [Kind inference for data family instances]
-
-                  -- Check that the result kind of the TyCon applied to its args
-                  -- is compatible with the explicit signature (or Type, if there
-                  -- is none)
-                  ; let hs_lhs = nlHsTyConApp NotPromoted fixity (getName fam_tc) hs_pats
-                  ; _ <- unifyKind (Just . HsTypeRnThing $ unLoc hs_lhs) lhs_applied_kind res_kind
-
-                  ; traceTc "tcDataFamInstHeader" $
-                    vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind, ppr m_ksig]
-                  ; return ( stupid_theta
-                           , lhs_applied_ty
-                           , lhs_applied_kind
-                           , res_kind ) }
-
-       ; outer_bndrs <- scopedSortOuter outer_bndrs
-       ; let outer_tvs = outerTyVars outer_bndrs
-       ; checkFamTelescope tclvl hs_outer_bndrs outer_tvs
-
-       -- This code (and the stuff immediately above) is very similar
-       -- to that in tcTyFamInstEqnGuts.  Maybe we should abstract the
-       -- common code; but for the moment I concluded that it's
-       -- clearer to duplicate it.  Still, if you fix a bug here,
-       -- check there too!
-
-       -- See GHC.Tc.TyCl Note [Generalising in tcTyFamInstEqnGuts]
-       ; dvs  <- candidateQTyVarsWithBinders outer_tvs lhs_ty
-       ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs
-       ; let final_tvs = scopedSort (qtvs ++ outer_tvs)
-             -- This scopedSort is important: the qtvs may be /interleaved/ with
-             -- the outer_tvs.  See Note [Generalising in tcTyFamInstEqnGuts]
-       ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted
-
-       ; final_tvs         <- zonkTcTyVarsToTcTyVars final_tvs
-       ; lhs_ty            <- zonkTcType  lhs_ty
-       ; master_res_kind   <- zonkTcType  master_res_kind
-       ; instance_res_kind <- zonkTcType  instance_res_kind
-       ; stupid_theta      <- zonkTcTypes stupid_theta
-
-       -- Check that res_kind is OK with checkDataKindSig.  We need to
-       -- check that it's ok because res_kind can come from a user-written
-       -- kind signature.  See Note [Datatype return kinds], point (4a)
-       ; checkDataKindSig (DataInstanceSort new_or_data) master_res_kind
-       ; checkDataKindSig (DataInstanceSort new_or_data) instance_res_kind
-
-       -- Split up the LHS type to get the type patterns
-       -- For the scopedSort see Note [Generalising in tcTyFamInstEqnGuts]
-       ; let pats      = unravelFamInstPats lhs_ty
-
-       ; return (final_tvs, pats, master_res_kind, stupid_theta) }
-  where
-    fam_name  = tyConName fam_tc
-    data_ctxt = DataKindCtxt fam_name
-
-    -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl, families (2),
-    -- and Note [Implementation of UnliftedDatatypes].
-    tc_kind_sig Nothing
-      = do { unlifted_newtypes  <- xoptM LangExt.UnliftedNewtypes
-           ; unlifted_datatypes <- xoptM LangExt.UnliftedDatatypes
-           ; case new_or_data of
-               NewType  | unlifted_newtypes  -> newOpenTypeKind
-               DataType | unlifted_datatypes -> newOpenTypeKind
-               _                             -> pure liftedTypeKind
-           }
-
-    -- See Note [Result kind signature for a data family instance]
-    tc_kind_sig (Just hs_kind)
-      = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind
-           ; (_tvs', inner_kind') <- tcSkolemiseInvisibleBndrs (SigTypeSkol data_ctxt) sig_kind
-                   -- Perhaps surprisingly, we don't need the skolemised tvs themselves
-           ; return inner_kind' }
-
-{- Note [Result kind signature for a data family instance]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The expected type might have a forall at the type. Normally, we
-can't skolemise in kinds because we don't have type-level lambda.
-But here, we're at the top-level of an instance declaration, so
-we actually have a place to put the regeneralised variables.
-Thus: skolemise away. cf. GHC.Tc.Utils.Unify.tcTopSkolemise
-Examples in indexed-types/should_compile/T12369
-
-Note [Implementing eta reduction for data families]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   data D :: * -> * -> * -> * -> *
-
-   data instance D [(a,b)] p q :: * -> * where
-      D1 :: blah1
-      D2 :: blah2
-
-Then we'll generate a representation data type
-  data Drep a b p q z where
-      D1 :: blah1
-      D2 :: blah2
-
-and an axiom to connect them
-  axiom AxDrep forall a b p q z. D [(a,b]] p q z = Drep a b p q z
-
-except that we'll eta-reduce the axiom to
-  axiom AxDrep forall a b. D [(a,b]] = Drep a b
-
-This is described at some length in Note [Eta reduction for data families]
-in GHC.Core.Coercion.Axiom. There are several fiddly subtleties lurking here,
-however, so this Note aims to describe these subtleties:
-
-* The representation tycon Drep is parameterised over the free
-  variables of the pattern, in no particular order. So there is no
-  guarantee that 'p' and 'q' will come last in Drep's parameters, and
-  in the right order.  So, if the /patterns/ of the family instance
-  are eta-reducible, we re-order Drep's parameters to put the
-  eta-reduced type variables last.
-
-* Although we eta-reduce the axiom, we eta-/expand/ the representation
-  tycon Drep.  The kind of D says it takes four arguments, but the
-  data instance header only supplies three.  But the AlgTyCon for Drep
-  itself must have enough TyConBinders so that its result kind is Type.
-  So, with etaExpandAlgTyCon we make up some extra TyConBinders.
-  See point (3) in Note [Datatype return kinds] in GHC.Tc.TyCl.
-
-* The result kind in the instance might be a polykind, like this:
-     data family DP a :: forall k. k -> *
-     data instance DP [b] :: forall k1 k2. (k1,k2) -> *
-
-  So in type-checking the LHS (DP Int) we need to check that it is
-  more polymorphic than the signature.  To do that we must skolemise
-  the signature and instantiate the call of DP.  So we end up with
-     data instance DP [b] @(k1,k2) (z :: (k1,k2)) where
-
-  Note that we must parameterise the representation tycon DPrep over
-  'k1' and 'k2', as well as 'b'.
-
-  The skolemise bit is done in tc_kind_sig, while the instantiate bit
-  is done by tcFamTyPats.
-
-* Very fiddly point.  When we eta-reduce to
-     axiom AxDrep forall a b. D [(a,b]] = Drep a b
-
-  we want the kind of (D [(a,b)]) to be the same as the kind of
-  (Drep a b).  This ensures that applying the axiom doesn't change the
-  kind.  Why is that hard?  Because the kind of (Drep a b) depends on
-  the TyConBndrVis on Drep's arguments. In particular do we have
-    (forall (k::*). blah) or (* -> blah)?
-
-  We must match whatever D does!  In #15817 we had
-      data family X a :: forall k. * -> *   -- Note: a forall that is not used
-      data instance X Int b = MkX
-
-  So the data instance is really
-      data istance X Int @k b = MkX
-
-  The axiom will look like
-      axiom    X Int = Xrep
-
-  and it's important that XRep :: forall k * -> *, following X.
-
-  To achieve this we get the TyConBndrVis flags from tcbVisibilities,
-  and use those flags for any eta-reduced arguments.  Sigh.
-
-* The final turn of the knife is that tcbVisibilities is itself
-  tricky to sort out.  Consider
-      data family D k :: k
-  Then consider D (forall k2. k2 -> k2) Type Type
-  The visibility flags on an application of D may affected by the arguments
-  themselves.  Heavy sigh.  But not truly hard; that's what tcbVisibilities
-  does.
-
-* Happily, we don't need to worry about the possibility of
-  building an inhomogeneous axiom, described in GHC.Tc.TyCl.Build
-  Note [Newtype eta and homogeneous axioms].   For example
-     type F :: Type -> forall (b :: Type) -> Type
-     data family F a b
-     newtype instance F Int b = MkF (Proxy b)
-  we get a newtype, and a eta-reduced axiom connecting the data family
-  with the newtype:
-     type R:FIntb :: forall (b :: Type) -> Type
-     newtype R:FIntb b = MkF (Proxy b)
-     axiom Foo.D:R:FIntb0 :: F Int = Foo.R:FIntb
-  Now the subtleties of Note [Newtype eta and homogeneous axioms] are
-  dealt with by the newtype (via mkNewTyConRhs called in tcDataFamInstDecl)
-  while the axiom connecting F Int ~ R:FIntb is eta-reduced, but the
-  quantifier 'b' is derived from the original data family F, and so the
-  kinds will always match.
-
-Note [Kind inference for data family instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this GADT-style data type declaration, where I have used
-fresh variables in the data constructor's type, to stress that c,d are
-quite distinct from a,b.
-   data T a b where
-     MkT :: forall c d. c d -> T c d
-
-Following Note [Inferring kinds for type declarations] in GHC.Tc.TyCl,
-to infer T's kind, we initially give T :: kappa, a monomorpic kind,
-gather constraints from the header and data constructors, and conclude
-   T :: (kappa1 -> type) -> kappa1 -> Type
-Then we generalise, giving
-   T :: forall k. (k->Type) -> k -> Type
-
-Now what about a data /instance/ decl
-   data family T :: forall k. (k->Type) -> k -> Type
-
-   data instance T p Int where ...
-
-No doubt here! The poly-kinded T is instantiated with k=Type, so the
-header really looks like
-   data instance T @Type (p :: Type->Type) Int where ...
-
-But what about this?
-   data instance T p q where
-      MkT :: forall r. r Int -> T r Int
-
-So what kind do 'p' and 'q' have?  No clues from the header, but from
-the data constructor we can clearly see that (r :: Type->Type).  Does
-that mean that the /entire data instance/ is instantiated at Type,
-like this?
-   data instance T @Type (p :: Type->Type) (q :: Type) where
-      ...
-
-Not at all! This is a /GADT/-style decl, so the kind argument might
-be specialised in this particular data constructor, thus:
-   data instance T @k (p :: k->Type) (q :: k) where
-     MkT :: forall (r :: Type -> Type).
-            r Int -> T @Type r Int
-(and perhaps specialised differently in some other data
-constructor MkT2).
-
-The key difference in this case and 'data T' at the top of this Note
-is that we have no known kind for 'data T'. We thus forbid different
-specialisations of T in its constructors, in an attempt to avoid
-inferring polymorphic recursion. In data family T, however, there is
-no problem with polymorphic recursion: we already /fully know/ T's
-kind -- that came from the family declaration, and is not influenced
-by the data instances -- and hence we /can/ specialise T's kind
-differently in different GADT data constructors.
-
-SHORT SUMMARY: in a data instance decl, it's not clear whether kind
-constraints arising from the data constructors should be considered
-local to the (GADT) data /constructor/ or should apply to the entire
-data instance.
-
-DESIGN CHOICE: in data/newtype family instance declarations, we ignore
-the /data constructor/ declarations altogether, looking only at the
-data instance /header/.
-
-Observations:
-* This choice is simple to describe, as well as simple to implement.
-  For a data/newtype instance decl, the instance kinds are influenced
-  /only/ by the header.
-
-* We could treat Haskell-98 style data-instance decls differently, by
-  taking the data constructors into account, since there are no GADT
-  issues.  But we don't, for simplicity, and because it means you can
-  understand the data type instance by looking only at the header.
-
-* Newtypes can be declared in GADT syntax, but they can't do GADT-style
-  specialisation, so like Haskell-98 definitions we could take the
-  data constructors into account.  Again we don't, for the same reason.
-
-So for now at least, we keep the simplest choice. See #18891 and !4419
-for more discussion of this issue.
-
-Kind inference for data types (Xie et al) https://arxiv.org/abs/1911.06153
-takes a slightly different approach.
--}
-
-
-{- *********************************************************************
-*                                                                      *
-      Class instance declarations, pass 2
-*                                                                      *
-********************************************************************* -}
-
-tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn]
-             -> TcM (LHsBinds GhcTc)
--- (a) From each class declaration,
---      generate any default-method bindings
--- (b) From each instance decl
---      generate the dfun binding
-
-tcInstDecls2 tycl_decls inst_decls
-  = do  { -- (a) Default methods from class decls
-          let class_decls = filter (isClassDecl . unLoc) tycl_decls
-        ; dm_binds_s <- mapM tcClassDecl2 class_decls
-        ; let dm_binds = unionManyBags dm_binds_s
-
-          -- (b) instance declarations
-        ; let dm_ids = collectHsBindsBinders CollNoDictBinders dm_binds
-              -- Add the default method Ids (again)
-              -- (they were already added in GHC.Tc.TyCl.Utils.tcAddImplicits)
-              -- See Note [Default methods in the type environment]
-        ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $
-                          mapM tcInstDecl2 inst_decls
-
-          -- Done
-        ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
-
-{- Note [Default methods in the type environment]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The default method Ids are already in the type environment (see Note
-[Default method Ids and Template Haskell] in TcTyDcls), BUT they
-don't have their InlinePragmas yet.  Usually that would not matter,
-because the simplifier propagates information from binding site to
-use.  But, unusually, when compiling instance decls we *copy* the
-INLINE pragma from the default method to the method for that
-particular operation (see Note [INLINE and default methods] below).
-
-So right here in tcInstDecls2 we must re-extend the type envt with
-the default method Ids replete with their INLINE pragmas.  Urk.
--}
-
-tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc)
-            -- Returns a binding for the dfun
-tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
-  = recoverM (return emptyLHsBinds)             $
-    setSrcSpan loc                              $
-    addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
-    do {  -- Instantiate the instance decl with skolem constants
-       ; skol_info <- mkSkolemInfo InstSkol
-       ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType skol_info dfun_id
-       ; dfun_ev_vars <- newEvVars dfun_theta
-                     -- We instantiate the dfun_id with superSkolems.
-                     -- See Note [Subtle interaction of recursion and overlap]
-                     -- and Note [Binding when looking up instances]
-
-       ; let (clas, inst_tys) = tcSplitDFunHead inst_head
-             (class_tyvars, sc_theta, _, op_items) = classBigSig clas
-             sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta
-
-       ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta'])
-
-                      -- Deal with 'SPECIALISE instance' pragmas
-                      -- See Note [SPECIALISE instance pragmas]
-       ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
-
-         -- Typecheck superclasses and methods
-         -- See Note [Typechecking plan for instance declarations]
-       ; dfun_ev_binds_var <- newTcEvBinds
-       ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var
-       ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics))
-             <- pushTcLevelM $
-                do { (sc_ids, sc_binds, sc_implics)
-                        <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars
-                                          inst_tys dfun_ev_binds
-                                          sc_theta'
-
-                      -- Typecheck the methods
-                   ; (meth_ids, meth_binds, meth_implics)
-                        <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars
-                                     inst_tys dfun_ev_binds spec_inst_info
-                                     op_items ibinds
-
-                   ; return ( sc_ids     ++          meth_ids
-                            , sc_binds   `unionBags` meth_binds
-                            , sc_implics `unionBags` meth_implics ) }
-
-       ; imp <- newImplication
-       ; emitImplication $
-         imp { ic_tclvl  = tclvl
-             , ic_skols  = inst_tyvars
-             , ic_given  = dfun_ev_vars
-             , ic_wanted = mkImplicWC sc_meth_implics
-             , ic_binds  = dfun_ev_binds_var
-             , ic_info   = InstSkol }
-
-       -- Create the result bindings
-       ; self_dict <- newDict clas inst_tys
-       ; let class_tc      = classTyCon clas
-             loc'          = noAnnSrcSpan loc
-             dict_constr   = tyConSingleDataCon class_tc
-             dict_bind = mkVarBind self_dict (L loc' con_app_args)
-
-                     -- We don't produce a binding for the dict_constr; instead we
-                     -- rely on the simplifier to unfold this saturated application
-                     -- We do this rather than generate an HsCon directly, because
-                     -- it means that the special cases (e.g. dictionary with only one
-                     -- member) are dealt with by the common MkId.mkDataConWrapId
-                     -- code rather than needing to be repeated here.
-                     --    con_app_tys  = MkD ty1 ty2
-                     --    con_app_scs  = MkD ty1 ty2 sc1 sc2
-                     --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
-             con_app_tys  = mkHsWrap (mkWpTyApps inst_tys) $
-                            mkConLikeTc (RealDataCon dict_constr)
-                       -- NB: We *can* have covars in inst_tys, in the case of
-                       -- promoted GADT constructors.
-
-             con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids
-
-             app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc
-             app_to_meth fun meth_id = HsApp noComments (L loc' fun)
-                                            (L loc' (wrapId arg_wrapper meth_id))
-
-             inst_tv_tys = mkTyVarTys inst_tyvars
-             arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
-
-             is_newtype = isNewTyCon class_tc
-             dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids
-             dfun_spec_prags
-                | is_newtype = SpecPrags []
-                | otherwise  = SpecPrags spec_inst_prags
-                    -- Newtype dfuns just inline unconditionally,
-                    -- so don't attempt to specialise them
-
-             export = ABE { abe_wrap = idHsWrapper
-                          , abe_poly = dfun_id_w_prags
-                          , abe_mono = self_dict
-                          , abe_prags = dfun_spec_prags }
-                          -- NB: see Note [SPECIALISE instance pragmas]
-             main_bind = XHsBindsLR $
-                         AbsBinds { abs_tvs = inst_tyvars
-                                  , abs_ev_vars = dfun_ev_vars
-                                  , abs_exports = [export]
-                                  , abs_ev_binds = []
-                                  , abs_binds = unitBag dict_bind
-                                  , abs_sig = True }
-
-       ; return (unitBag (L loc' main_bind)
-                  `unionBags` sc_meth_binds)
-       }
- where
-   dfun_id = instanceDFunId ispec
-   loc     = getSrcSpan dfun_id
-
-addDFunPrags :: DFunId -> [Id] -> DFunId
--- DFuns need a special Unfolding and InlinePrag
---    See Note [ClassOp/DFun selection]
---    and Note [Single-method classes]
--- It's easiest to create those unfoldings right here, where
--- have all the pieces in hand, even though we are messing with
--- Core at this point, which the typechecker doesn't usually do
--- However we take care to build the unfolding using the TyVars from
--- the DFunId rather than from the skolem pieces that the typechecker
--- is messing with.
-addDFunPrags dfun_id sc_meth_ids
- | is_newtype
-  = dfun_id `setIdUnfolding`  mkInlineUnfoldingWithArity defaultSimpleOpts StableSystemSrc 0 con_app
-            `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
- | otherwise
- = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_bndrs dict_con dict_args
-           `setInlinePragma` dfunInlinePragma
- where
-   con_app    = mkLams dfun_bndrs $
-                mkApps (Var (dataConWrapId dict_con)) dict_args
-                -- This application will satisfy the Core invariants
-                -- from Note [Representation polymorphism invariants] in GHC.Core,
-                -- because typeclass method types are never unlifted.
-   dict_args  = map Type inst_tys ++
-                [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids]
-
-   (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id)
-   ev_ids      = mkTemplateLocalsNum 1                    dfun_theta
-   dfun_bndrs  = dfun_tvs ++ ev_ids
-   clas_tc     = classTyCon clas
-   dict_con    = tyConSingleDataCon clas_tc
-   is_newtype  = isNewTyCon clas_tc
-
-wrapId :: HsWrapper -> Id -> HsExpr GhcTc
-wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLocA id))
-
-{- Note [Typechecking plan for instance declarations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For instance declarations we generate the following bindings and implication
-constraints.  Example:
-
-   instance Ord a => Ord [a] where compare = <compare-rhs>
-
-generates this:
-
-   Bindings:
-      -- Method bindings
-      $ccompare :: forall a. Ord a => a -> a -> Ordering
-      $ccompare = /\a \(d:Ord a). let <meth-ev-binds> in ...
-
-      -- Superclass bindings
-      $cp1Ord :: forall a. Ord a => Eq [a]
-      $cp1Ord = /\a \(d:Ord a). let <sc-ev-binds>
-               in dfEqList (dw :: Eq a)
-
-   Constraints:
-      forall a. Ord a =>
-                -- Method constraint
-             (forall. (empty) => <constraints from compare-rhs>)
-                -- Superclass constraint
-          /\ (forall. (empty) => dw :: Eq a)
-
-Notice that
-
- * Per-meth/sc implication.  There is one inner implication per
-   superclass or method, with no skolem variables or givens.  The only
-   reason for this one is to gather the evidence bindings privately
-   for this superclass or method.  This implication is generated
-   by checkInstConstraints.
-
- * Overall instance implication. There is an overall enclosing
-   implication for the whole instance declaration, with the expected
-   skolems and givens.  We need this to get the correct "redundant
-   constraint" warnings, gathering all the uses from all the methods
-   and superclasses.  See GHC.Tc.Solver Note [Tracking redundant
-   constraints]
-
- * The given constraints in the outer implication may generate
-   evidence, notably by superclass selection.  Since the method and
-   superclass bindings are top-level, we want that evidence copied
-   into *every* method or superclass definition.  (Some of it will
-   be usused in some, but dead-code elimination will drop it.)
-
-   We achieve this by putting the evidence variable for the overall
-   instance implication into the AbsBinds for each method/superclass.
-   Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses.
-   (And that in turn is why the abs_ev_binds field of AbBinds is a
-   [TcEvBinds] rather than simply TcEvBinds.
-
-   This is a bit of a hack, but works very nicely in practice.
-
- * Note that if a method has a locally-polymorphic binding, there will
-   be yet another implication for that, generated by tcPolyCheck
-   in tcMethodBody. E.g.
-          class C a where
-            foo :: forall b. Ord b => blah
-
-
-************************************************************************
-*                                                                      *
-      Type-checking superclasses
-*                                                                      *
-************************************************************************
--}
-
-tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType]
-               -> TcEvBinds
-               -> TcThetaType
-               -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication)
--- Make a new top-level function binding for each superclass,
--- something like
---    $Ordp1 :: forall a. Ord a => Eq [a]
---    $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d)
---
--- See Note [Recursive superclasses] for why this is so hard!
--- In effect, we build a special-purpose solver for the first step
--- of solving each superclass constraint
-tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta
-  = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..])
-       ; return (ids, listToBag binds, listToBag implics) }
-  where
-    loc = getSrcSpan dfun_id
-    size = sizeTypes inst_tys
-    tc_super (sc_pred, n)
-      = do { (sc_implic, ev_binds_var, sc_ev_tm)
-                <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred
-
-           ; sc_top_name  <- newName (mkSuperDictAuxOcc n (getOccName cls))
-           ; sc_ev_id     <- newEvVar sc_pred
-           ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm
-           ; let sc_top_ty = tcMkDFunSigmaTy tyvars (map idType dfun_evs) sc_pred
-                 sc_top_id = mkLocalId sc_top_name ManyTy sc_top_ty
-                 export = ABE { abe_wrap = idHsWrapper
-                              , abe_poly = sc_top_id
-                              , abe_mono = sc_ev_id
-                              , abe_prags = noSpecPrags }
-                 local_ev_binds = TcEvBinds ev_binds_var
-                 bind = XHsBindsLR $
-                        AbsBinds { abs_tvs      = tyvars
-                                 , abs_ev_vars  = dfun_evs
-                                 , abs_exports  = [export]
-                                 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
-                                 , abs_binds    = emptyBag
-                                 , abs_sig      = False }
-           ; return (sc_top_id, L (noAnnSrcSpan loc) bind, sc_implic) }
-
--------------------
-checkInstConstraints :: TcM result
-                     -> TcM (Implication, EvBindsVar, result)
--- See Note [Typechecking plan for instance declarations]
-checkInstConstraints thing_inside
-  = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints  $
-                                    thing_inside
-
-       ; ev_binds_var <- newTcEvBinds
-       ; implic <- newImplication
-       ; let implic' = implic { ic_tclvl  = tclvl
-                              , ic_wanted = wanted
-                              , ic_binds  = ev_binds_var
-                              , ic_info   = InstSkol }
-
-       ; return (implic', ev_binds_var, result) }
-
-{-
-Note [Recursive superclasses]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See #3731, #4809, #5751, #5913, #6117, #6161, which all
-describe somewhat more complicated situations, but ones
-encountered in practice.
-
-See also tests tcrun020, tcrun021, tcrun033, and #11427.
-
------ THE PROBLEM --------
-The problem is that it is all too easy to create a class whose
-superclass is bottom when it should not be.
-
-Consider the following (extreme) situation:
-        class C a => D a where ...
-        instance D [a] => D [a] where ...   (dfunD)
-        instance C [a] => C [a] where ...   (dfunC)
-Although this looks wrong (assume D [a] to prove D [a]), it is only a
-more extreme case of what happens with recursive dictionaries, and it
-can, just about, make sense because the methods do some work before
-recursing.
-
-To implement the dfunD we must generate code for the superclass C [a],
-which we had better not get by superclass selection from the supplied
-argument:
-       dfunD :: forall a. D [a] -> D [a]
-       dfunD = \d::D [a] -> MkD (scsel d) ..
-
-Otherwise if we later encounter a situation where
-we have a [Wanted] dw::D [a] we might solve it thus:
-     dw := dfunD dw
-Which is all fine except that now ** the superclass C is bottom **!
-
-The instance we want is:
-       dfunD :: forall a. D [a] -> D [a]
-       dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ...
-
------ THE SOLUTION --------
-The basic solution is simple: be very careful about using superclass
-selection to generate a superclass witness in a dictionary function
-definition.  More precisely:
-
-  Superclass Invariant: in every class dictionary,
-                        every superclass dictionary field
-                        is non-bottom
-
-To achieve the Superclass Invariant, in a dfun definition we can
-generate a guaranteed-non-bottom superclass witness from:
-  (sc1) one of the dictionary arguments itself (all non-bottom)
-  (sc2) an immediate superclass of a smaller dictionary
-  (sc3) a call of a dfun (always returns a dictionary constructor)
-
-The tricky case is (sc2).  We proceed by induction on the size of
-the (type of) the dictionary, defined by GHC.Tc.Validity.sizeTypes.
-Let's suppose we are building a dictionary of size 3, and
-suppose the Superclass Invariant holds of smaller dictionaries.
-Then if we have a smaller dictionary, its immediate superclasses
-will be non-bottom by induction.
-
-What does "we have a smaller dictionary" mean?  It might be
-one of the arguments of the instance, or one of its superclasses.
-Here is an example, taken from CmmExpr:
-       class Ord r => UserOfRegs r a where ...
-(i1)   instance UserOfRegs r a => UserOfRegs r (Maybe a) where
-(i2)   instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
-
-For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a),
-since it is smaller than the thing we are building (UserOfRegs r (Maybe a).
-
-But for (i2) that isn't the case, so we must add an explicit, and
-perhaps surprising, (Ord r) argument to the instance declaration.
-
-Here's another example from #6161:
-
-       class       Super a => Duper a  where ...
-       class Duper (Fam a) => Foo a    where ...
-(i3)   instance Foo a => Duper (Fam a) where ...
-(i4)   instance              Foo Float where ...
-
-It would be horribly wrong to define
-   dfDuperFam :: Foo a -> Duper (Fam a)  -- from (i3)
-   dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ...
-
-   dfFooFloat :: Foo Float               -- from (i4)
-   dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ...
-
-Now the Super superclass of Duper is definitely bottom!
-
-This won't happen because when processing (i3) we can use the
-superclasses of (Foo a), which is smaller, namely Duper (Fam a).  But
-that is *not* smaller than the target so we can't take *its*
-superclasses.  As a result the program is rightly rejected, unless you
-add (Super (Fam a)) to the context of (i3).
-
-Note [Solving superclass constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-How do we ensure that every superclass witness is generated by
-one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses].
-Answer:
-
-  * Superclass "wanted" constraints have CtOrigin of (ScOrigin size)
-    where 'size' is the size of the instance declaration. e.g.
-          class C a => D a where...
-          instance blah => D [a] where ...
-    The wanted superclass constraint for C [a] has origin
-    ScOrigin size, where size = size( D [a] ).
-
-  * (sc1) When we rewrite such a wanted constraint, it retains its
-    origin.  But if we apply an instance declaration, we can set the
-    origin to (ScOrigin infinity), thus lifting any restrictions by
-    making prohibitedSuperClassSolve return False.
-
-  * (sc2) ScOrigin wanted constraints can't be solved from a
-    superclass selection, except at a smaller type.  This test is
-    implemented by GHC.Tc.Solver.Interact.prohibitedSuperClassSolve
-
-  * The "given" constraints of an instance decl have CtOrigin
-    GivenOrigin InstSkol.
-
-  * When we make a superclass selection from InstSkol we use
-    a CtOrigin of (InstSCOrigin size), where 'size' is the size of
-    the constraint whose superclass we are taking.  And similarly
-    when taking the superclass of an InstSCOrigin.  This is implemented
-    in GHC.Tc.Solver.Canonical.mk_strict_superclasses (in the
-    mk_given_loc helper function).
-
-Note [Silent superclass arguments] (historical interest only)
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-NB1: this note describes our *old* solution to the
-     recursive-superclass problem. I'm keeping the Note
-     for now, just as institutional memory.
-     However, the code for silent superclass arguments
-     was removed in late Dec 2014
-
-NB2: the silent-superclass solution introduced new problems
-     of its own, in the form of instance overlap.  Tests
-     SilentParametersOverlapping, T5051, and T7862 are examples
-
-NB3: the silent-superclass solution also generated tons of
-     extra dictionaries.  For example, in monad-transformer
-     code, when constructing a Monad dictionary you had to pass
-     an Applicative dictionary; and to construct that you need
-     a Functor dictionary. Yet these extra dictionaries were
-     often never used.  Test T3064 compiled *far* faster after
-     silent superclasses were eliminated.
-
-Our solution to this problem "silent superclass arguments".  We pass
-to each dfun some ``silent superclass arguments’’, which are the
-immediate superclasses of the dictionary we are trying to
-construct. In our example:
-       dfun :: forall a. C [a] -> D [a] -> D [a]
-       dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
-Notice the extra (dc :: C [a]) argument compared to the previous version.
-
-This gives us:
-
-     -----------------------------------------------------------
-     DFun Superclass Invariant
-     ~~~~~~~~~~~~~~~~~~~~~~~~
-     In the body of a DFun, every superclass argument to the
-     returned dictionary is
-       either   * one of the arguments of the DFun,
-       or       * constant, bound at top level
-     -----------------------------------------------------------
-
-This net effect is that it is safe to treat a dfun application as
-wrapping a dictionary constructor around its arguments (in particular,
-a dfun never picks superclasses from the arguments under the
-dictionary constructor). No superclass is hidden inside a dfun
-application.
-
-The extra arguments required to satisfy the DFun Superclass Invariant
-always come first, and are called the "silent" arguments.  You can
-find out how many silent arguments there are using Id.dfunNSilent;
-and then you can just drop that number of arguments to see the ones
-that were in the original instance declaration.
-
-DFun types are built (only) by MkId.mkDictFunId, so that is where we
-decide what silent arguments are to be added.
--}
-
-{-
-************************************************************************
-*                                                                      *
-      Type-checking an instance method
-*                                                                      *
-************************************************************************
-
-tcMethod
-- Make the method bindings, as a [(NonRec, HsBinds)], one per method
-- Remembering to use fresh Name (the instance method Name) as the binder
-- Bring the instance method Ids into scope, for the benefit of tcInstSig
-- Use sig_fn mapping instance method Name -> instance tyvars
-- Ditto prag_fn
-- Use tcValBinds to do the checking
--}
-
-tcMethods :: DFunId -> Class
-          -> [TcTyVar] -> [EvVar]
-          -> [TcType]
-          -> TcEvBinds
-          -> ([LTcSpecPrag], TcPragEnv)
-          -> [ClassOpItem]
-          -> InstBindings GhcRn
-          -> TcM ([Id], LHsBinds GhcTc, Bag Implication)
-        -- The returned inst_meth_ids all have types starting
-        --      forall tvs. theta => ...
-tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
-                  dfun_ev_binds (spec_inst_prags, prag_fn) op_items
-                  (InstBindings { ib_binds      = binds
-                                , ib_tyvars     = lexical_tvs
-                                , ib_pragmas    = sigs
-                                , ib_extensions = exts
-                                , ib_derived    = is_derived })
-  = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $
-       -- The lexical_tvs scope over the 'where' part
-    do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
-       ; checkMinimalDefinition
-       ; checkMethBindMembership
-       ; (ids, binds, mb_implics) <- set_exts exts $
-                                     unset_warnings_deriving $
-                                     mapAndUnzip3M tc_item op_items
-       ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }
-  where
-    set_exts :: [LangExt.Extension] -> TcM a -> TcM a
-    set_exts es thing = foldr setXOptM thing es
-
-    -- See Note [Avoid -Winaccessible-code when deriving]
-    unset_warnings_deriving :: TcM a -> TcM a
-    unset_warnings_deriving
-      | is_derived = unsetWOptM Opt_WarnInaccessibleCode
-      | otherwise  = id
-
-    hs_sig_fn = mkHsSigFun sigs
-    inst_loc  = getSrcSpan dfun_id
-
-    ----------------------
-    tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)
-    tc_item (sel_id, dm_info)
-      | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn
-      = tcMethodBody clas tyvars dfun_ev_vars inst_tys
-                              dfun_ev_binds is_derived hs_sig_fn
-                              spec_inst_prags prags
-                              sel_id user_bind bndr_loc
-      | otherwise
-      = do { traceTc "tc_def" (ppr sel_id)
-           ; tc_default sel_id dm_info }
-
-    ----------------------
-    tc_default :: Id -> DefMethInfo
-               -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
-
-    tc_default sel_id (Just (dm_name, _))
-      = do { (meth_bind, inline_prags) <- mkDefMethBind inst_loc dfun_id clas sel_id dm_name
-           ; tcMethodBody clas tyvars dfun_ev_vars inst_tys
-                          dfun_ev_binds is_derived hs_sig_fn
-                          spec_inst_prags inline_prags
-                          sel_id meth_bind inst_loc }
-
-    tc_default sel_id Nothing     -- No default method at all
-      = do { traceTc "tc_def: warn" (ppr sel_id)
-           ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
-                                       inst_tys sel_id
-           ; dflags <- getDynFlags
-           ; let meth_bind = mkVarBind meth_id $
-                             mkLHsWrap lam_wrapper (error_rhs dflags)
-           ; return (meth_id, meth_bind, Nothing) }
-      where
-        inst_loc' = noAnnSrcSpan inst_loc
-        error_rhs dflags = L inst_loc'
-                                 $ HsApp noComments error_fun (error_msg dflags)
-        error_fun    = L inst_loc' $
-                       wrapId (mkWpTyApps
-                                [ getRuntimeRep meth_tau, meth_tau])
-                              nO_METHOD_BINDING_ERROR_ID
-        error_msg dflags = L inst_loc'
-                                    (HsLit noComments (HsStringPrim NoSourceText
-                                              (unsafeMkByteString (error_string dflags))))
-        meth_tau     = classMethodInstTy sel_id inst_tys
-        error_string dflags = showSDoc dflags
-                              (hcat [ppr inst_loc, vbar, ppr sel_id ])
-        lam_wrapper  = mkWpTyLams tyvars <.> mkWpEvLams dfun_ev_vars
-
-    ----------------------
-    -- Check if one of the minimal complete definitions is satisfied
-    checkMinimalDefinition
-      = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
-        warnUnsatisfiedMinimalDefinition
-
-    methodExists meth = isJust (findMethodBind meth binds prag_fn)
-
-    ----------------------
-    -- Check if any method bindings do not correspond to the class.
-    -- See Note [Mismatched class methods and associated type families].
-    checkMethBindMembership
-      = mapM_ (addErrTc . TcRnBadMethodErr (className clas)) mismatched_meths
-      where
-        bind_nms         = map unLoc $ collectMethodBinders binds
-        cls_meth_nms     = map (idName . fst) op_items
-        mismatched_meths = bind_nms `minusList` cls_meth_nms
-
-{-
-Note [Mismatched class methods and associated type families]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's entirely possible for someone to put methods or associated type family
-instances inside of a class in which it doesn't belong. For instance, we'd
-want to fail if someone wrote this:
-
-  instance Eq () where
-    type Rep () = Maybe
-    compare = undefined
-
-Since neither the type family `Rep` nor the method `compare` belong to the
-class `Eq`. Normally, this is caught in the renamer when resolving RdrNames,
-since that would discover that the parent class `Eq` is incorrect.
-
-However, there is a scenario in which the renamer could fail to catch this:
-if the instance was generated through Template Haskell, as in #12387. In that
-case, Template Haskell will provide fully resolved names (e.g.,
-`GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going
-on. For this reason, we also put an extra validity check for this in the
-typechecker as a last resort.
-
-Note [Avoid -Winaccessible-code when deriving]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--Winaccessible-code can be particularly noisy when deriving instances for
-GADTs. Consider the following example (adapted from #8128):
-
-  data T a where
-    MkT1 :: Int -> T Int
-    MkT2 :: T Bool
-    MkT3 :: T Bool
-  deriving instance Eq (T a)
-  deriving instance Ord (T a)
-
-In the derived Ord instance, GHC will generate the following code:
-
-  instance Ord (T a) where
-    compare x y
-      = case x of
-          MkT2
-            -> case y of
-                 MkT1 {} -> GT
-                 MkT2    -> EQ
-                 _       -> LT
-          ...
-
-However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2
-differ, so if -Winaccessible-code is enabled, then deriving this instance will
-result in unwelcome warnings.
-
-One conceivable approach to fixing this issue would be to change `deriving Ord`
-such that it becomes smarter about not generating unreachable cases. This,
-however, would be a highly nontrivial refactor, as we'd have to propagate
-through typing information everywhere in the algorithm that generates Ord
-instances in order to determine which cases were unreachable. This seems like
-a lot of work for minimal gain, so we have opted not to go for this approach.
-
-Instead, we take the much simpler approach of always disabling
--Winaccessible-code for derived code. To accomplish this, we do the following:
-
-1. In tcMethods (which typechecks method bindings), disable
-   -Winaccessible-code.
-2. When creating Implications during typechecking, record this flag
-   (in ic_warn_inaccessible) at the time of creation.
-3. After typechecking comes error reporting, where GHC must decide how to
-   report inaccessible code to the user, on an Implication-by-Implication
-   basis. If an Implication's DynFlags indicate that -Winaccessible-code was
-   disabled, then don't bother reporting it. That's it!
--}
-
-------------------------
-tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]
-             -> TcEvBinds -> Bool
-             -> HsSigFun
-             -> [LTcSpecPrag] -> [LSig GhcRn]
-             -> Id -> LHsBind GhcRn -> SrcSpan
-             -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
-tcMethodBody clas tyvars dfun_ev_vars inst_tys
-                     dfun_ev_binds is_derived
-                     sig_fn spec_inst_prags prags
-                     sel_id (L bind_loc meth_bind) bndr_loc
-  = add_meth_ctxt $
-    do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc)
-       ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $
-                                            mkMethIds clas tyvars dfun_ev_vars
-                                                      inst_tys sel_id
-
-       ; let lm_bind = meth_bind { fun_id = L (noAnnSrcSpan bndr_loc)
-                                                        (idName local_meth_id) }
-                       -- Substitute the local_meth_name for the binder
-                       -- NB: the binding is always a FunBind
-
-            -- taking instance signature into account might change the type of
-            -- the local_meth_id
-       ; (meth_implic, ev_binds_var, tc_bind)
-             <- checkInstConstraints $
-                tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind)
-
-       ; global_meth_id <- addInlinePrags global_meth_id prags
-       ; spec_prags     <- tcSpecPrags global_meth_id prags
-
-        ; let specs  = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
-              export = ABE { abe_poly  = global_meth_id
-                           , abe_mono  = local_meth_id
-                           , abe_wrap  = idHsWrapper
-                           , abe_prags = specs }
-
-              local_ev_binds = TcEvBinds ev_binds_var
-              full_bind = XHsBindsLR $
-                          AbsBinds { abs_tvs      = tyvars
-                                   , abs_ev_vars  = dfun_ev_vars
-                                   , abs_exports  = [export]
-                                   , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
-                                   , abs_binds    = tc_bind
-                                   , abs_sig      = True }
-
-        ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }
-  where
-        -- For instance decls that come from deriving clauses
-        -- we want to print out the full source code if there's an error
-        -- because otherwise the user won't see the code at all
-    add_meth_ctxt thing
-      | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing
-      | otherwise  = thing
-
-tcMethodBodyHelp :: HsSigFun -> Id -> TcId
-                 -> LHsBind GhcRn -> TcM (LHsBinds GhcTc)
-tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
-  | Just hs_sig_ty <- hs_sig_fn sel_name
-              -- There is a signature in the instance
-              -- See Note [Instance method signatures]
-  = do { (sig_ty, hs_wrap)
-             <- setSrcSpan (getLocA hs_sig_ty) $
-                do { inst_sigs <- xoptM LangExt.InstanceSigs
-                   ; checkTc inst_sigs (TcRnMisplacedInstSig sel_name hs_sig_ty)
-                   ; let ctxt = FunSigCtxt sel_name NoRRC
-                   ; sig_ty  <- tcHsSigType ctxt hs_sig_ty
-                   ; let local_meth_ty = idType local_meth_id
-                                -- False <=> do not report redundant constraints when
-                                --           checking instance-sig <= class-meth-sig
-                                -- The instance-sig is the focus here; the class-meth-sig
-                                -- is fixed (#18036)
-                   ; let orig = InstanceSigOrigin sel_name sig_ty local_meth_ty
-                   ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $
-                                tcSubTypeSigma orig ctxt sig_ty local_meth_ty
-                   ; return (sig_ty, hs_wrap) }
-
-       ; inner_meth_name <- newName (nameOccName sel_name)
-       ; let ctxt = FunSigCtxt sel_name (lhsSigTypeContextSpan hs_sig_ty)
-                    -- WantRCC <=> check for redundant constraints in the
-                    --          user-specified instance signature
-             inner_meth_id  = mkLocalId inner_meth_name ManyTy sig_ty
-             inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id
-                                          , sig_ctxt = ctxt
-                                          , sig_loc  = getLocA hs_sig_ty }
-
-
-       ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
-
-       ; let export = ABE { abe_poly  = local_meth_id
-                          , abe_mono  = inner_id
-                          , abe_wrap  = hs_wrap
-                          , abe_prags = noSpecPrags }
-
-       ; return (unitBag $ L (getLoc meth_bind) $ XHsBindsLR $
-                 AbsBinds { abs_tvs = [], abs_ev_vars = []
-                          , abs_exports = [export]
-                          , abs_binds = tc_bind, abs_ev_binds = []
-                          , abs_sig = True }) }
-
-  | otherwise  -- No instance signature
-  = do { let ctxt = FunSigCtxt sel_name NoRRC
-                    -- NoRRC <=> don't report redundant constraints
-                    -- The signature is not under the users control!
-             tc_sig = completeSigFromId ctxt local_meth_id
-              -- Absent a type sig, there are no new scoped type variables here
-              -- Only the ones from the instance decl itself, which are already
-              -- in scope.  Example:
-              --      class C a where { op :: forall b. Eq b => ... }
-              --      instance C [c] where { op = <rhs> }
-              -- In <rhs>, 'c' is scope but 'b' is not!
-
-       ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind
-       ; return tc_bind }
-
-  where
-    sel_name   = idName sel_id
-    no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;
-                                -- they are all for meth_id
-
-------------------------
-mkMethIds :: Class -> [TcTyVar] -> [EvVar]
-          -> [TcType] -> Id -> TcM (TcId, TcId)
-             -- returns (poly_id, local_id), but ignoring any instance signature
-             -- See Note [Instance method signatures]
-mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
-  = do  { poly_meth_name  <- newName (mkClassOpAuxOcc sel_occ)
-        ; local_meth_name <- newName sel_occ
-                  -- Base the local_meth_name on the selector name, because
-                  -- type errors from tcMethodBody come from here
-        ; let poly_meth_id  = mkLocalId poly_meth_name  ManyTy poly_meth_ty
-              local_meth_id = mkLocalId local_meth_name ManyTy local_meth_ty
-
-        ; return (poly_meth_id, local_meth_id) }
-  where
-    sel_name      = idName sel_id
-    -- Force so that a thunk doesn't end up in a Name (#19619)
-    !sel_occ      = nameOccName sel_name
-    local_meth_ty = instantiateMethod clas sel_id inst_tys
-    poly_meth_ty  = mkSpecSigmaTy tyvars theta local_meth_ty
-    theta         = map idType dfun_ev_vars
-
-methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
-methSigCtxt sel_name sig_ty meth_ty env0
-  = do { (env1, sig_ty)  <- zonkTidyTcType env0 sig_ty
-       ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty
-       ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name))
-                      2 (vcat [ text "is more general than its signature in the class"
-                              , text "Instance sig:" <+> ppr sig_ty
-                              , text "   Class sig:" <+> ppr meth_ty ])
-       ; return (env2, msg) }
-
-{- Note [Instance method signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-With -XInstanceSigs we allow the user to supply a signature for the
-method in an instance declaration.  Here is an artificial example:
-
-       data T a = MkT a
-       instance Ord a => Ord (T a) where
-         (>) :: forall b. b -> b -> Bool
-         (>) = error "You can't compare Ts"
-
-The instance signature can be *more* polymorphic than the instantiated
-class method (in this case: Age -> Age -> Bool), but it cannot be less
-polymorphic.  Moreover, if a signature is given, the implementation
-code should match the signature, and type variables bound in the
-signature should scope over the method body.
-
-We achieve this by building a TcSigInfo for the method, whether or not
-there is an instance method signature, and using that to typecheck
-the declaration (in tcMethodBody).  That means, conveniently,
-that the type variables bound in the signature will scope over the body.
-
-What about the check that the instance method signature is more
-polymorphic than the instantiated class method type?  We just do a
-tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like
-this (for the example above
-
- AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a]
-         , abs_exports
-             = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool
-                        , gr_lcl :: T a -> T a -> Bool }
-         , abs_binds
-             = AbsBind { abs_tvs = [], abs_ev_vars = []
-                       , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool
-                                                , gr_inner :: forall b. b -> b -> Bool }
-                       , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = []
-                                             , ..etc.. }
-               } }
-
-Wow!  Three nested AbsBinds!
- * The outer one abstracts over the tyvars and dicts for the instance
- * The middle one is only present if there is an instance signature,
-   and does the impedance matching for that signature
- * The inner one is for the method binding itself against either the
-   signature from the class, or the instance signature.
--}
-
-----------------------
-mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
-        -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id
-        -- There are two sources:
-        --   * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
-        --   * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
-        --     These ones have the dfun inside, but [perhaps surprisingly]
-        --     the correct wrapper.
-        -- See Note [Handling SPECIALISE pragmas] in GHC.Tc.Gen.Bind
-mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me
-  = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
-  where
-    spec_prags_from_inst
-       | isInlinePragma (idInlinePragma meth_id)
-       = []  -- Do not inherit SPECIALISE from the instance if the
-             -- method is marked INLINE, because then it'll be inlined
-             -- and the specialisation would do nothing. (Indeed it'll provoke
-             -- a warning from the desugarer
-       | otherwise
-       = [ L inst_loc (SpecPrag meth_id wrap inl)
-         | L inst_loc (SpecPrag _       wrap inl) <- spec_inst_prags]
-
-
-mkDefMethBind :: SrcSpan -> DFunId -> Class -> Id -> Name
-              -> TcM (LHsBind GhcRn, [LSig GhcRn])
--- The is a default method (vanailla or generic) defined in the class
--- So make a binding   op = $dmop @t1 @t2
--- where $dmop is the name of the default method in the class,
--- and t1,t2 are the instance types.
--- See Note [Default methods in instances] for why we use
--- visible type application here
-mkDefMethBind loc dfun_id clas sel_id dm_name
-  = do  { logger <- getLogger
-        ; dm_id <- tcLookupId dm_name
-        ; let inline_prag = idInlinePragma dm_id
-              inline_prags | isAnyInlinePragma inline_prag
-                           = [noLocA (InlineSig noAnn fn inline_prag)]
-                           | otherwise
-                           = []
-                 -- Copy the inline pragma (if any) from the default method
-                 -- to this version. Note [INLINE and default methods]
-
-              fn   = noLocA (idName sel_id)
-              visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys
-                                      , tyConBinderForAllTyFlag tcb /= Inferred ]
-              rhs  = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
-              bind = L (noAnnSrcSpan loc)
-                    $ mkTopFunBind Generated fn
-                        [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
-
-        ; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body"
-                   FormatHaskell
-                   (vcat [ppr clas <+> ppr inst_tys,
-                          nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
-
-       ; return (bind, inline_prags) }
-  where
-    (_, _, _, inst_tys) = tcSplitDFunTy (idType dfun_id)
-
-    mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
-    mk_vta fun ty = noLocA (HsAppType noExtField fun noHsTok
-        (mkEmptyWildCardBndrs $ nlHsParTy $ noLocA $ XHsType ty))
-       -- NB: use visible type application
-       -- See Note [Default methods in instances]
-
-----------------------
-derivBindCtxt :: Id -> Class -> [Type ] -> SDoc
-derivBindCtxt sel_id clas tys
-   = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id)
-          , nest 2 (text "in a derived instance for"
-                    <+> quotes (pprClassPred clas tys) <> colon)
-          , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ]
-
-warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()
-warnUnsatisfiedMinimalDefinition mindef
-  = do { warn <- woptM Opt_WarnMissingMethods
-       ; let msg = TcRnUnsatisfiedMinimalDef mindef
-       ; diagnosticTc warn msg
-       }
-
-{-
-Note [Export helper functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We arrange to export the "helper functions" of an instance declaration,
-so that they are not subject to preInlineUnconditionally, even if their
-RHS is trivial.  Reason: they are mentioned in the DFunUnfolding of
-the dict fun as Ids, not as CoreExprs, so we can't substitute a
-non-variable for them.
-
-We could change this by making DFunUnfoldings have CoreExprs, but it
-seems a bit simpler this way.
-
-Note [Default methods in instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this
-
-   class Baz v x where
-      foo :: x -> x
-      foo y = <blah>
-
-   instance Baz Int Int
-
-From the class decl we get
-
-   $dmfoo :: forall v x. Baz v x => x -> x
-   $dmfoo y = <blah>
-
-Notice that the type is ambiguous.  So we use Visible Type Application
-to disambiguate:
-
-   $dBazIntInt = MkBaz fooIntInt
-   fooIntInt = $dmfoo @Int @Int
-
-Lacking VTA we'd get ambiguity errors involving the default method.  This applies
-equally to vanilla default methods (#1061) and generic default methods
-(#12220).
-
-Historical note: before we had VTA we had to generate
-post-type-checked code, which took a lot more code, and didn't work for
-generic default methods.
-
-Note [INLINE and default methods]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Default methods need special case.  They are supposed to behave rather like
-macros.  For example
-
-  class Foo a where
-    op1, op2 :: Bool -> a -> a
-
-    {-# INLINE op1 #-}
-    op1 b x = op2 (not b) x
-
-  instance Foo Int where
-    -- op1 via default method
-    op2 b x = <blah>
-
-The instance declaration should behave
-
-   just as if 'op1' had been defined with the
-   code, and INLINE pragma, from its original
-   definition.
-
-That is, just as if you'd written
-
-  instance Foo Int where
-    op2 b x = <blah>
-
-    {-# INLINE op1 #-}
-    op1 b x = op2 (not b) x
-
-So for the above example we generate:
-
-  {-# INLINE $dmop1 #-}
-  -- $dmop1 has an InlineCompulsory unfolding
-  $dmop1 d b x = op2 d (not b) x
-
-  $fFooInt = MkD $cop1 $cop2
-
-  {-# INLINE $cop1 #-}
-  $cop1 = $dmop1 $fFooInt
-
-  $cop2 = <blah>
-
-Note carefully:
-
-* We *copy* any INLINE pragma from the default method $dmop1 to the
-  instance $cop1.  Otherwise we'll just inline the former in the
-  latter and stop, which isn't what the user expected
-
-* Regardless of its pragma, we give the default method an
-  unfolding with an InlineCompulsory source. That means
-  that it'll be inlined at every use site, notably in
-  each instance declaration, such as $cop1.  This inlining
-  must happen even though
-    a) $dmop1 is not saturated in $cop1
-    b) $cop1 itself has an INLINE pragma
-
-  It's vital that $dmop1 *is* inlined in this way, to allow the mutual
-  recursion between $fooInt and $cop1 to be broken
-
-* To communicate the need for an InlineCompulsory to the desugarer
-  (which makes the Unfoldings), we use the IsDefaultMethod constructor
-  in TcSpecPrags.
-
-
-************************************************************************
-*                                                                      *
-        Specialise instance pragmas
-*                                                                      *
-************************************************************************
-
-Note [SPECIALISE instance pragmas]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-   instance (Ix a, Ix b) => Ix (a,b) where
-     {-# SPECIALISE instance Ix (Int,Int) #-}
-     range (x,y) = ...
-
-We make a specialised version of the dictionary function, AND
-specialised versions of each *method*.  Thus we should generate
-something like this:
-
-  $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
-  {-# DFUN [$crangePair, ...] #-}
-  {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}
-  $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
-
-  $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
-  {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
-  $crange da db = <blah>
-
-The SPECIALISE pragmas are acted upon by the desugarer, which generate
-
-  dii :: Ix Int
-  dii = ...
-
-  $s$dfIxPair :: Ix ((Int,Int),(Int,Int))
-  {-# DFUN [$crangePair di di, ...] #-}
-  $s$dfIxPair = Ix ($crangePair di di) (...)
-
-  {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}
-
-  $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]
-  $c$crangePair = ...specialised RHS of $crangePair...
-
-  {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
-
-Note that
-
-  * The specialised dictionary $s$dfIxPair is very much needed, in case we
-    call a function that takes a dictionary, but in a context where the
-    specialised dictionary can be used.  See #7797.
-
-  * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
-    it still has a DFunUnfolding.  See Note [ClassOp/DFun selection]
-
-  * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:
-       --> {ClassOp rule for range}     $crangePair Int Int d1 d2
-       --> {SPEC rule for $crangePair}  $s$crangePair
-    or thus:
-       --> {SPEC rule for $dfIxPair}    range $s$dfIxPair
-       --> {ClassOpRule for range}      $s$crangePair
-    It doesn't matter which way.
-
-  * We want to specialise the RHS of both $dfIxPair and $crangePair,
-    but the SAME HsWrapper will do for both!  We can call tcSpecPrag
-    just once, and pass the result (in spec_inst_info) to tcMethods.
--}
-
-tcSpecInstPrags :: DFunId -> InstBindings GhcRn
-                -> TcM ([LTcSpecPrag], TcPragEnv)
-tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
-  = do { spec_inst_prags <- mapM (wrapLocAM (tcSpecInst dfun_id)) $
-                            filter isSpecInstLSig uprags
-             -- The filter removes the pragmas for methods
-       ; return (spec_inst_prags, mkPragEnv uprags binds) }
-
-------------------------------
-tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag
-tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty)
-  = addErrCtxt (spec_ctxt prag) $
-    do  { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty
-        ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty
-        ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
-  where
-    spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag)
-
-tcSpecInst _  _ = panic "tcSpecInst"
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Error messages}
-*                                                                      *
-************************************************************************
--}
-
-instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
-instDeclCtxt1 hs_inst_ty
-  = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
-
-instDeclCtxt2 :: Type -> SDoc
-instDeclCtxt2 dfun_ty
-  = inst_decl_ctxt (ppr (mkClassPred cls tys))
-  where
-    (_,_,cls,tys) = tcSplitDFunTy dfun_ty
-
-inst_decl_ctxt :: SDoc -> SDoc
-inst_decl_ctxt doc = hang (text "In the instance declaration for")
-                        2 (quotes doc)
-
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs-boot b/compiler/GHC/Tc/TyCl/Instance.hs-boot
deleted file mode 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs-boot
+++ /dev/null
@@ -1,16 +0,0 @@
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
--}
-
-module GHC.Tc.TyCl.Instance ( tcInstDecls1 ) where
-
-import GHC.Hs
-import GHC.Tc.Types
-import GHC.Tc.Utils.Env( InstInfo )
-import GHC.Tc.Deriv
-
--- We need this because of the mutual recursion
--- between GHC.Tc.TyCl and GHC.Tc.TyCl.Instance
-tcInstDecls1 :: [LInstDecl GhcRn]
-             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ /dev/null
@@ -1,1303 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
--- | Typechecking pattern synonym declarations
-module GHC.Tc.TyCl.PatSyn
-   ( tcPatSynDecl
-   , tcPatSynBuilderBind
-   , patSynBuilderOcc
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Hs
-
-import GHC.Tc.Gen.Pat
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.Zonk
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv
-                      , addInlinePrags, addInlinePragArity )
-import GHC.Tc.Solver
-import GHC.Tc.Utils.Unify
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.Origin
-import GHC.Tc.TyCl.Build
-
-import GHC.Core.Multiplicity
-import GHC.Core.Type ( typeKind, tidyForAllTyBinders, tidyTypes, tidyType, isManyTy, mkTYPEapp )
-import GHC.Core.TyCo.Subst( extendTvSubstWithClone )
-import GHC.Core.Predicate
-
-import GHC.Builtin.Types.Prim
-import GHC.Types.Error
-import GHC.Types.Name
-import GHC.Types.Name.Set
-import GHC.Types.SrcLoc
-import GHC.Core.PatSyn
-import GHC.Utils.Panic
-import GHC.Utils.Outputable
-import GHC.Data.FastString
-import GHC.Types.Var
-import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSetList )
-import GHC.Types.Id
-import GHC.Types.Id.Info( RecSelParent(..) )
-import GHC.Tc.Gen.Bind
-import GHC.Types.Basic
-import GHC.Builtin.Types
-import GHC.Types.Var.Set
-import GHC.Tc.TyCl.Utils
-import GHC.Core.ConLike
-import GHC.Types.FieldLabel
-import GHC.Rename.Env
-import GHC.Rename.Utils (wrapGenSpan)
-import GHC.Data.Bag
-import GHC.Utils.Misc
-import GHC.Driver.Session ( getDynFlags, xopt_FieldSelectors )
-import Data.Maybe( mapMaybe )
-import Control.Monad ( zipWithM )
-import Data.List( partition, mapAccumL )
-
-{-
-************************************************************************
-*                                                                      *
-                    Type checking a pattern synonym
-*                                                                      *
-************************************************************************
--}
-
-tcPatSynDecl :: LocatedA (PatSynBind GhcRn GhcRn)
-             -> TcSigFun
-             -> TcPragEnv -- See Note [Pragmas for pattern synonyms]
-             -> TcM (LHsBinds GhcTc, TcGblEnv)
-tcPatSynDecl (L loc psb@(PSB { psb_id = L _ name })) sig_fn prag_fn
-  = setSrcSpanA loc $
-    addErrCtxt (text "In the declaration for pattern synonym"
-                <+> quotes (ppr name)) $
-    recoverM (recoverPSB psb) $
-    case (sig_fn name) of
-      Nothing                 -> tcInferPatSynDecl psb prag_fn
-      Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi prag_fn
-      _                       -> panic "tcPatSynDecl"
-
-recoverPSB :: PatSynBind GhcRn GhcRn
-           -> TcM (LHsBinds GhcTc, TcGblEnv)
--- See Note [Pattern synonym error recovery]
-recoverPSB (PSB { psb_id = L _ name
-                , psb_args = details })
- = do { matcher_name <- newImplicitBinder name mkMatcherOcc
-      ; let placeholder = AConLike $ PatSynCon $
-                          mk_placeholder matcher_name
-      ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv
-      ; return (emptyBag, gbl_env) }
-  where
-    (_arg_names, is_infix) = collectPatSynArgInfo details
-    mk_placeholder matcher_name
-      = mkPatSyn name is_infix
-                        ([mkTyVarBinder SpecifiedSpec alphaTyVar], []) ([], [])
-                        [] -- Arg tys
-                        alphaTy
-                        (matcher_name, matcher_ty, True) Nothing
-                        []  -- Field labels
-       where
-         -- The matcher_id is used only by the desugarer, so actually
-         -- and error-thunk would probably do just as well here.
-         matcher_ty = mkSpecForAllTys [alphaTyVar] alphaTy
-
-{- Note [Pattern synonym error recovery]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If type inference for a pattern synonym fails, we can't continue with
-the rest of tc_patsyn_finish, because we may get knock-on errors, or
-even a crash.  E.g. from
-   pattern What = True :: Maybe
-we get a kind error; and we must stop right away (#15289).
-
-We stop if there are /any/ unsolved constraints, not just insoluble
-ones; because pattern synonyms are top-level things, we will never
-solve them later if we can't solve them now.  And if we were to carry
-on, tc_patsyn_finish does zonkTcTypeToType, which defaults any
-unsolved unification variables to Any, which confuses the error
-reporting no end (#15685).
-
-So we use simplifyTop to completely solve the constraint, report
-any errors, throw an exception.
-
-Even in the event of such an error we can recover and carry on, just
-as we do for value bindings, provided we plug in placeholder for the
-pattern synonym: see recoverPSB.  The goal of the placeholder is not
-to cause a raft of follow-on errors.  I've used the simplest thing for
-now, but we might need to elaborate it a bit later.  (e.g.  I've given
-it zero args, which may cause knock-on errors if it is used in a
-pattern.) But it'll do for now.
-
--}
-
-tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
-                  -> TcPragEnv
-                  -> TcM (LHsBinds GhcTc, TcGblEnv)
-tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details
-                       , psb_def = lpat, psb_dir = dir })
-                  prag_fn
-  = do { traceTc "tcInferPatSynDecl {" $ ppr name
-
-       ; let (arg_names, is_infix) = collectPatSynArgInfo details
-       ; (tclvl, wanted, ((lpat', args), pat_ty))
-            <- pushLevelAndCaptureConstraints      $
-               tcInferPat FRRPatSynArg PatSyn lpat $
-               mapM tcLookupId arg_names
-
-       ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'
-
-             named_taus = (name, pat_ty) : map mk_named_tau args
-             mk_named_tau arg
-               = (getName arg, mkSpecForAllTys ex_tvs (varType arg))
-               -- The mkSpecForAllTys is important (#14552), albeit
-               -- slightly artificial (there is no variable with this funny type).
-               -- We do not want to quantify over variable (alpha::k)
-               -- that mention the existentially-bound type variables
-               -- ex_tvs in its kind k.
-               -- See Note [Type variables whose kind is captured]
-
-       ; ((univ_tvs, req_dicts, ev_binds, _), residual)
-               <- captureConstraints $
-                  simplifyInfer tclvl NoRestrictions [] named_taus wanted
-       ; top_ev_binds <- checkNoErrs (simplifyTop residual)
-       ; addTopEvBinds top_ev_binds $
-
-    do { prov_dicts <- mapM zonkId prov_dicts
-       ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts
-             -- Filtering: see Note [Remove redundant provided dicts]
-             (prov_theta, prov_evs)
-                 = unzip (mapMaybe mkProvEvidence filtered_prov_dicts)
-             req_theta = map evVarPred req_dicts
-
-       -- Report coercions that escape
-       -- See Note [Coercions that escape]
-       ; args <- mapM zonkId args
-       ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts
-                              , let bad_cos = filterDVarSet isId $
-                                              (tyCoVarsOfTypeDSet (idType arg))
-                              , not (isEmptyDVarSet bad_cos) ]
-       ; mapM_ dependentArgErr bad_args
-
-       -- Report un-quantifiable type variables:
-       -- see Note [Unquantified tyvars in a pattern synonym]
-       ; dvs <- candidateQTyVarsOfTypes prov_theta
-       ; let mk_doc tidy_env
-               = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env prov_theta
-                    ; return ( tidy_env2
-                             , sep [ text "the provided context:"
-                                   , pprTheta theta ] ) }
-       ; doNotQuantifyTyVars dvs mk_doc
-
-       ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
-       ; rec_fields <- lookupConstructorFields name
-       ; tc_patsyn_finish lname dir is_infix lpat' prag_fn
-                          (mkTyVarBinders InferredSpec univ_tvs
-                            , req_theta,  ev_binds, req_dicts)
-                          (mkTyVarBinders InferredSpec ex_tvs
-                            , mkTyVarTys ex_tvs, prov_theta, prov_evs)
-                          (map nlHsVar args, map idType args)
-                          pat_ty rec_fields } }
-
-mkProvEvidence :: EvId -> Maybe (PredType, EvTerm)
--- See Note [Equality evidence in pattern synonyms]
-mkProvEvidence ev_id
-  | EqPred r ty1 ty2 <- classifyPredType pred
-  , let k1 = typeKind ty1
-        k2 = typeKind ty2
-        is_homo = k1 `tcEqType` k2
-        homo_tys   = [k1, ty1, ty2]
-        hetero_tys = [k1, k2, ty1, ty2]
-  = case r of
-      ReprEq | is_homo
-             -> Just ( mkClassPred coercibleClass    homo_tys
-                     , evDataConApp coercibleDataCon homo_tys eq_con_args )
-             | otherwise -> Nothing
-      NomEq  | is_homo
-             -> Just ( mkClassPred eqClass    homo_tys
-                     , evDataConApp eqDataCon homo_tys eq_con_args )
-             | otherwise
-             -> Just ( mkClassPred heqClass    hetero_tys
-                     , evDataConApp heqDataCon hetero_tys eq_con_args )
-
-  | otherwise
-  = Just (pred, EvExpr (evId ev_id))
-  where
-    pred = evVarPred ev_id
-    eq_con_args = [evId ev_id]
-
-dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
--- See Note [Coercions that escape]
-dependentArgErr (arg, bad_cos)
-  = failWithTc $  -- fail here: otherwise we get downstream errors
-    mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"
-         , hang (text "Pattern-bound variable")
-              2 (ppr arg <+> dcolon <+> ppr (idType arg))
-         , nest 2 $
-           hang (text "has a type that mentions pattern-bound coercion"
-                 <> plural bad_co_list <> colon)
-              2 (pprWithCommas ppr bad_co_list)
-         , text "Hint: use -fprint-explicit-coercions to see the coercions"
-         , text "Probable fix: add a pattern signature" ]
-  where
-    bad_co_list = dVarSetElems bad_cos
-
-{- Note [Type variables whose kind is captured]
-~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  data AST a = Sym [a]
-  class Prj s where { prj :: [a] -> Maybe (s a) }
-  pattern P x <= Sym (prj -> Just x)
-
-Here we get a matcher with this type
-  $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r
-
-No problem.  But note that 's' is not fixed by the type of the
-pattern (AST a), nor is it existentially bound.  It's really only
-fixed by the type of the continuation.
-
-#14552 showed that this can go wrong if the kind of 's' mentions
-existentially bound variables.  We obviously can't make a type like
-  $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r)
-                                   -> r -> r
-But neither is 's' itself existentially bound, so the forall (s::k->*)
-can't go in the inner forall either.  (What would the matcher apply
-the continuation to?)
-
-Solution: do not quantify over any unification variable whose kind
-mentions the existentials.  We can conveniently do that by making the
-"taus" passed to simplifyInfer look like
-   forall ex_tvs. arg_ty
-
-After that, Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType takes
-over and errors.
-
-Note [Remove redundant provided dicts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Recall that
-   HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2)
-                                       => a1 :~~: a2
-(NB: technically the (k1~k2) existential dictionary is not necessary,
-but it's there at the moment.)
-
-Now consider (#14394):
-   pattern Foo = HRefl
-in a non-poly-kinded module.  We don't want to get
-    pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b
-with that redundant (* ~ *).  We'd like to remove it; hence the call to
-mkMinimalWithSCs.
-
-Similarly consider
-  data S a where { MkS :: Ord a => a -> S a }
-  pattern Bam x y <- (MkS (x::a), MkS (y::a)))
-
-The pattern (Bam x y) binds two (Ord a) dictionaries, but we only
-need one.  Again mkMimimalWithSCs removes the redundant one.
-
-Note [Equality evidence in pattern synonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  data X a where
-     MkX :: Eq a => [a] -> X (Maybe a)
-  pattern P x = MkG x
-
-Then there is a danger that GHC will infer
-  P :: forall a.  () =>
-       forall b. (a ~# Maybe b, Eq b) => [b] -> X a
-
-The 'builder' for P, which is called in user-code, will then
-have type
-  $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a
-
-and that is bad because (a ~# Maybe b) is not a predicate type
-(see Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep
-and is not implicitly instantiated.
-
-So in mkProvEvidence we lift (a ~# b) to (a ~ b).  Tiresome, and
-marginally less efficient, if the builder/matcher are not inlined.
-
-See also Note [Lift equality constraints when quantifying] in GHC.Tc.Solver
-
-Note [Coercions that escape]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-#14507 showed an example where the inferred type of the matcher
-for the pattern synonym was something like
-   $mSO :: forall (r :: TYPE rep) kk (a :: k).
-           TypeRep k a
-           -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r)
-           -> (Void# -> r)
-           -> r
-
-What is that co_a2sv :: Bool ~# *??  It was bound (via a superclass
-selection) by the pattern being matched; and indeed it is implicit in
-the context (Bool ~ k).  You could imagine trying to extract it like
-this:
-   $mSO :: forall (r :: TYPE rep) kk (a :: k).
-           TypeRep k a
-           -> ( co :: ((Bool :: *) ~ (k :: *)) =>
-                  let co_a2sv = sc_sel co
-                  in TypeRep Bool (a |> co_a2sv) -> r)
-           -> (Void# -> r)
-           -> r
-
-But we simply don't allow that in types.  Maybe one day but not now.
-
-How to detect this situation?  We just look for free coercion variables
-in the types of any of the arguments to the matcher.  The error message
-is not very helpful, but at least we don't get a Lint error.
-
-Note [Unquantified tyvars in a pattern synonym]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#21479)
-
-   data T a where MkT :: Int -> T Char   -- A GADT
-   foo :: forall b. Bool -> T b          -- Somewhat strange type
-
-   pattern T1 <- (foo -> MkT)
-
-In the view pattern, foo is instantiated, let's say b :-> b0
-where b0 is a unification variable.  Then matching the GADT
-MkT will add the "provided" constraint b0~Char, so we might infer
-   pattern T1 :: () => (b0~Char) => Int -> Bool
-
-Nothing constrains that `b0`. We don't want to quantify over it.
-We don't want to to zonk to Any (we don't like Any showing up in
-user-visible types).  So we want to error here. See
-Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType
-
-Hence the call to doNotQuantifyTyVars here.
--}
-
-tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
-                  -> TcPatSynInfo
-                  -> TcPragEnv
-                  -> TcM (LHsBinds GhcTc, TcGblEnv)
-tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details
-                         , psb_def = lpat, psb_dir = dir }
-                  TPSI{ patsig_implicit_bndrs = implicit_bndrs
-                      , patsig_univ_bndrs = explicit_univ_bndrs, patsig_req  = req_theta
-                      , patsig_ex_bndrs   = explicit_ex_bndrs,   patsig_prov = prov_theta
-                      , patsig_body_ty    = sig_body_ty }
-                  prag_fn
-  = do { traceTc "tcCheckPatSynDecl" $
-         vcat [ ppr implicit_bndrs, ppr explicit_univ_bndrs, ppr req_theta
-              , ppr explicit_ex_bndrs, ppr prov_theta, ppr sig_body_ty ]
-
-       ; let decl_arity = length arg_names
-             (arg_names, is_infix) = collectPatSynArgInfo details
-
-       ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of
-                                 Right stuff  -> return stuff
-                                 Left missing -> wrongNumberOfParmsErr name decl_arity missing
-
-       -- Complain about:  pattern P :: () => forall x. x -> P x
-       -- The existential 'x' should not appear in the result type
-       -- Can't check this until we know P's arity (decl_arity above)
-       ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs
-       ; checkTc (null bad_tvs) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-         hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
-                   , text "namely" <+> quotes (ppr pat_ty) ])
-            2 (text "mentions existential type variable" <> plural bad_tvs
-               <+> pprQuotedList bad_tvs)
-
-         -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.Gen.Sig
-       ; let univ_fvs = closeOverKinds $
-                        (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` (binderVars explicit_univ_bndrs))
-             (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_bndrs
-             univ_bndrs = extra_univ ++ explicit_univ_bndrs
-             ex_bndrs   = extra_ex   ++ explicit_ex_bndrs
-             univ_tvs   = binderVars univ_bndrs
-             ex_tvs     = binderVars ex_bndrs
-
-         -- Pattern synonyms currently cannot be linear (#18806)
-       ; checkTc (all (isManyTy . scaledMult) arg_tys) $
-           TcRnLinearPatSyn sig_body_ty
-
-       ; skol_info <- mkSkolemInfo (SigSkol (PatSynCtxt name) pat_ty [])
-                         -- The type here is a bit bogus, but we do not print
-                         -- the type for PatSynCtxt, so it doesn't matter
-                         -- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin"
-
-         -- Skolemise the quantified type variables. This is necessary
-         -- in order to check the actual pattern type against the
-         -- expected type. Even though the tyvars in the type are
-         -- already skolems, this step changes their TcLevels,
-         -- avoiding level-check errors when unifying.
-       ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX skol_info emptySubst univ_bndrs
-       ; (skol_subst, skol_ex_bndrs)    <- skolemiseTvBndrsX skol_info skol_subst0   ex_bndrs
-       ; let skol_univ_tvs   = binderVars skol_univ_bndrs
-             skol_ex_tvs     = binderVars skol_ex_bndrs
-             skol_req_theta  = substTheta skol_subst0 req_theta
-             skol_prov_theta = substTheta skol_subst  prov_theta
-             skol_arg_tys    = substTys   skol_subst  (map scaledThing arg_tys)
-             skol_pat_ty     = substTy    skol_subst  pat_ty
-
-             univ_tv_prs     = [ (getName orig_univ_tv, skol_univ_tv)
-                               | (orig_univ_tv, skol_univ_tv) <- univ_tvs `zip` skol_univ_tvs ]
-
-       -- Right!  Let's check the pattern against the signature
-       -- See Note [Checking against a pattern signature]
-       ; req_dicts <- newEvVars skol_req_theta
-       ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
-           assertPpr (equalLength arg_names arg_tys) (ppr name $$ ppr arg_names $$ ppr arg_tys) $
-           pushLevelAndCaptureConstraints   $
-           tcExtendNameTyVarEnv univ_tv_prs $
-           tcCheckPat PatSyn lpat (unrestricted skol_pat_ty)   $
-           do { let in_scope    = mkInScopeSetList skol_univ_tvs
-                    empty_subst = mkEmptySubst in_scope
-              ; (inst_subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst skol_ex_tvs
-                    -- newMetaTyVarX: see the "Existential type variables"
-                    -- part of Note [Checking against a pattern signature]
-              ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
-              ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
-              ; let prov_theta' = substTheta inst_subst skol_prov_theta
-                  -- Add univ_tvs to the in_scope set to
-                  -- satisfy the substitution invariant. There's no need to
-                  -- add 'ex_tvs' as they are already in the domain of the
-                  -- substitution.
-                  -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.
-              ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'
-              ; args'      <- zipWithM (tc_arg inst_subst) arg_names
-                                       skol_arg_tys
-              ; return (ex_tvs', prov_dicts, args') }
-
-       ; (implics, ev_binds) <- buildImplicationFor tclvl (getSkolemInfo skol_info) skol_univ_tvs
-                                                    req_dicts wanted
-
-       -- Solve the constraints now, because we are about to make a PatSyn,
-       -- which should not contain unification variables and the like (#10997)
-       ; simplifyTopImplic implics
-
-       -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct
-       -- Otherwise we may get a type error when typechecking the builder,
-       -- when that should be impossible
-
-       ; traceTc "tcCheckPatSynDecl }" $ ppr name
-
-       ; rec_fields <- lookupConstructorFields name
-       ; tc_patsyn_finish lname dir is_infix lpat' prag_fn
-                          (skol_univ_bndrs, skol_req_theta, ev_binds, req_dicts)
-                          (skol_ex_bndrs, mkTyVarTys ex_tvs', skol_prov_theta, prov_dicts)
-                          (args', skol_arg_tys)
-                          skol_pat_ty rec_fields }
-  where
-    tc_arg :: Subst -> Name -> Type -> TcM (LHsExpr GhcTc)
-     -- Look up the variable actually bound by lpat
-     -- and check that it has the expected type
-    tc_arg subst arg_name arg_ty
-      = setSrcSpan (nameSrcSpan arg_name) $
-           -- Set the SrcSpan to be the binding site of the Id (#18856)
-           -- e.g.  pattern P :: Int -> Maybe (Int,Bool)
-           --       pattern P x = Just (x,True)
-           -- Before unifying x's actual type with its expected type, in tc_arg, set
-           -- location to x's binding site in lpat, namely the 'x' in Just (x,True).
-           -- Else the error message location is wherever tcCheckPat finished,
-           -- namely the right-hand corner of the pattern
-        do { arg_id <- tcLookupId arg_name
-           ; wrap <- tcSubTypeSigma (OccurrenceOf (idName arg_id))
-                                    GenSigCtxt
-                                    (idType arg_id)
-                                    (substTy subst arg_ty)
-                -- Why do we need tcSubType here?
-                -- See Note [Pattern synonyms and higher rank types]
-           ; return (mkLHsWrap wrap $ nlHsVar arg_id) }
-
-skolemiseTvBndrsX :: SkolemInfo -> Subst -> [VarBndr TyVar flag]
-                  -> TcM (Subst, [VarBndr TcTyVar flag])
--- Make new TcTyVars, all skolems with levels, but do not clone
--- The level is one level deeper than the current level
--- See Note [Skolemising when checking a pattern synonym]
-skolemiseTvBndrsX skol_info orig_subst tvs
-  = do { tc_lvl <- getTcLevel
-       ; let pushed_lvl = pushTcLevel tc_lvl
-             details    = SkolemTv skol_info pushed_lvl False
-
-             mk_skol_tv_x :: Subst -> VarBndr TyVar flag
-                          -> (Subst, VarBndr TcTyVar flag)
-             mk_skol_tv_x subst (Bndr tv flag)
-               = (subst', Bndr new_tv flag)
-               where
-                 new_kind = substTyUnchecked subst (tyVarKind tv)
-                 new_tv   = mkTcTyVar (tyVarName tv) new_kind details
-                 subst'   = extendTvSubstWithClone subst tv new_tv
-
-       ; return (mapAccumL mk_skol_tv_x orig_subst tvs) }
-
-{- Note [Skolemising when checking a pattern synonym]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   pattern P1 :: forall a. a -> Maybe a
-   pattern P1 x <- Just x where
-      P1 x = Just (x :: a)
-
-The scoped type variable 'a' scopes over the builder RHS, Just (x::a).
-But the builder RHS is typechecked much later in tcPatSynBuilderBind,
-and gets its scoped type variables from the type of the builder_id.
-The easiest way to achieve this is not to clone when skolemising.
-
-Hence a special-purpose skolemiseTvBndrX here, similar to
-GHC.Tc.Utils.Instantiate.tcInstSkolTyVarsX except that the latter
-does cloning.
-
-Note [Pattern synonyms and higher rank types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  data T = MkT (forall a. a->a)
-
-  pattern P :: (Int -> Int) -> T
-  pattern P x <- MkT x
-
-This should work.  But in the matcher we must match against MkT, and then
-instantiate its argument 'x', to get a function of type (Int -> Int).
-Equality is not enough!  #13752 was an example.
-
-
-Note [The pattern-synonym signature splitting rule]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given a pattern signature, we must split
-     the kind-generalised variables, and
-     the implicitly-bound variables
-into universal and existential.  The rule is this
-(see discussion on #11224):
-
-     The universal tyvars are the ones mentioned in
-          - univ_tvs: the user-specified (forall'd) universals
-          - req_theta
-          - res_ty
-     The existential tyvars are all the rest
-
-For example
-
-   pattern P :: () => b -> T a
-   pattern P x = ...
-
-Here 'a' is universal, and 'b' is existential.  But there is a wrinkle:
-how do we split the arg_tys from req_ty?  Consider
-
-   pattern Q :: () => b -> S c -> T a
-   pattern Q x = ...
-
-This is an odd example because Q has only one syntactic argument, and
-so presumably is defined by a view pattern matching a function.  But
-it can happen (#11977, #12108).
-
-We don't know Q's arity from the pattern signature, so we have to wait
-until we see the pattern declaration itself before deciding res_ty is,
-and hence which variables are existential and which are universal.
-
-And that in turn is why TcPatSynInfo has a separate field,
-patsig_implicit_bndrs, to capture the implicitly bound type variables,
-because we don't yet know how to split them up.
-
-It's a slight compromise, because it means we don't really know the
-pattern synonym's real signature until we see its declaration.  So,
-for example, in hs-boot file, we may need to think what to do...
-(eg don't have any implicitly-bound variables).
-
-
-Note [Checking against a pattern signature]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When checking the actual supplied pattern against the pattern synonym
-signature, we need to be quite careful.
-
------ Provided constraints
-Example
-
-    data T a where
-      MkT :: Ord a => a -> T a
-
-    pattern P :: () => Eq a => a -> [T a]
-    pattern P x = [MkT x]
-
-We must check that the (Eq a) that P claims to bind (and to
-make available to matches against P), is derivable from the
-actual pattern.  For example:
-    f (P (x::a)) = ...here (Eq a) should be available...
-And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs.
-
------ Existential type variables
-Unusually, we instantiate the existential tyvars of the pattern with
-*meta* type variables.  For example
-
-    data S where
-      MkS :: Eq a => [a] -> S
-
-    pattern P :: () => Eq x => x -> S
-    pattern P x <- MkS x
-
-The pattern synonym conceals from its client the fact that MkS has a
-list inside it.  The client just thinks it's a type 'x'.  So we must
-unify x := [a] during type checking, and then use the instantiating type
-[a] (called ex_tys) when building the matcher.  In this case we'll get
-
-   $mP :: S -> (forall x. Ex x => x -> r) -> r -> r
-   $mP x k = case x of
-               MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a]
-                                              dl = $dfunEqList d
-                                          in k [a] dl ys
-
-All this applies when type-checking the /matching/ side of
-a pattern synonym.  What about the /building/ side?
-
-* For Unidirectional, there is no builder
-
-* For ExplicitBidirectional, the builder is completely separate
-  code, typechecked in tcPatSynBuilderBind
-
-* For ImplicitBidirectional, the builder is still typechecked in
-  tcPatSynBuilderBind, by converting the pattern to an expression and
-  typechecking it.
-
-  At one point, for ImplicitBidirectional I used TyVarTvs (instead of
-  TauTvs) in tcCheckPatSynDecl.  But (a) strengthening the check here
-  is redundant since tcPatSynBuilderBind does the job, (b) it was
-  still incomplete (TyVarTvs can unify with each other), and (c) it
-  didn't even work (#13441 was accepted with
-  ExplicitBidirectional, but rejected if expressed in
-  ImplicitBidirectional form.  Conclusion: trying to be too clever is
-  a bad idea.
--}
-
-collectPatSynArgInfo :: HsPatSynDetails GhcRn
-                     -> ([Name], Bool)
-collectPatSynArgInfo details =
-  case details of
-    PrefixCon _ names    -> (map unLoc names, False)
-    InfixCon name1 name2 -> (map unLoc [name1, name2], True)
-    RecCon names         -> (map (unLoc . recordPatSynPatVar) names, False)
-
-wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
-wrongNumberOfParmsErr name decl_arity missing
-  = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has"
-          <+> speakNOf decl_arity (text "argument"))
-       2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
-
--------------------------
--- Shared by both tcInferPatSyn and tcCheckPatSyn
-tc_patsyn_finish :: LocatedN Name   -- ^ PatSyn Name
-                 -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
-                 -> Bool              -- ^ Whether infix
-                 -> LPat GhcTc        -- ^ Pattern of the PatSyn
-                 -> TcPragEnv
-                 -> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar])
-                 -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm])
-                 -> ([LHsExpr GhcTc], [TcTypeFRR])
-                   -- ^ Pattern arguments and types.
-                   -- These must have a syntactically fixed RuntimeRep as per
-                   -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
-                 -> TcType            -- ^ Pattern type
-                 -> [FieldLabel]      -- ^ Selector names
-                 -- ^ Whether fields, empty if not record PatSyn
-                 -> TcM (LHsBinds GhcTc, TcGblEnv)
-tc_patsyn_finish lname dir is_infix lpat' prag_fn
-                 (univ_tvs, req_theta, req_ev_binds, req_dicts)
-                 (ex_tvs,   ex_tys,    prov_theta,   prov_dicts)
-                 (args, arg_tys)
-                 pat_ty field_labels
-  = do { -- Zonk everything.  We are about to build a final PatSyn
-         -- so there had better be no unification variables in there
-
-       ; ze              <- mkEmptyZonkEnv NoFlexi
-       ; (ze, univ_tvs') <- zonkTyVarBindersX   ze univ_tvs
-       ; req_theta'      <- zonkTcTypesToTypesX ze req_theta
-       ; (ze, ex_tvs')   <- zonkTyVarBindersX   ze ex_tvs
-       ; prov_theta'     <- zonkTcTypesToTypesX ze prov_theta
-       ; pat_ty'         <- zonkTcTypeToTypeX   ze pat_ty
-       ; arg_tys'        <- zonkTcTypesToTypesX ze arg_tys
-
-       ; let (env1, univ_tvs) = tidyForAllTyBinders emptyTidyEnv univ_tvs'
-             (env2, ex_tvs)   = tidyForAllTyBinders env1 ex_tvs'
-             req_theta  = tidyTypes env2 req_theta'
-             prov_theta = tidyTypes env2 prov_theta'
-             arg_tys    = tidyTypes env2 arg_tys'
-             pat_ty     = tidyType  env2 pat_ty'
-
-       ; traceTc "tc_patsyn_finish {" $
-           ppr (unLoc lname) $$ ppr (unLoc lpat') $$
-           ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
-           ppr (ex_tvs, prov_theta, prov_dicts) $$
-           ppr args $$
-           ppr arg_tys $$
-           ppr pat_ty
-
-       -- Make the 'matcher'
-       ; (matcher, matcher_bind) <- tcPatSynMatcher lname lpat' prag_fn
-                                         (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)
-                                         (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)
-                                         (args, arg_tys)
-                                         pat_ty
-
-       -- Make the 'builder'
-       ; builder <- mkPatSynBuilder dir lname
-                                    univ_tvs req_theta
-                                    ex_tvs   prov_theta
-                                    arg_tys pat_ty
-
-       -- Make the PatSyn itself
-       ; let patSyn = mkPatSyn (unLoc lname) is_infix
-                        (univ_tvs, req_theta)
-                        (ex_tvs, prov_theta)
-                        arg_tys
-                        pat_ty
-                        matcher builder
-                        field_labels
-
-       -- Selectors
-       ; has_sel <- xopt_FieldSelectors <$> getDynFlags
-       ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn) has_sel
-             tything = AConLike (PatSynCon patSyn)
-       ; tcg_env <- tcExtendGlobalEnv [tything] $
-                    tcRecSelBinds rn_rec_sel_binds
-
-       ; traceTc "tc_patsyn_finish }" empty
-       ; return (matcher_bind, tcg_env) }
-
-{-
-************************************************************************
-*                                                                      *
-         Constructing the "matcher" Id and its binding
-*                                                                      *
-************************************************************************
--}
-
-tcPatSynMatcher :: LocatedN Name
-                -> LPat GhcTc
-                -> TcPragEnv
-                -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
-                -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
-                -> ([LHsExpr GhcTc], [TcType])
-                -> TcType
-                -> TcM (PatSynMatcher, LHsBinds GhcTc)
--- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn
-tcPatSynMatcher (L loc ps_name) lpat prag_fn
-                (univ_tvs, req_theta, req_ev_binds, req_dicts)
-                (ex_tvs, ex_tys, prov_theta, prov_dicts)
-                (args, arg_tys) pat_ty
-  = do { let loc' = locA loc
-       ; rr_name <- newNameAt (mkTyVarOccFS (fsLit "rep")) loc'
-       ; tv_name <- newNameAt (mkTyVarOccFS (fsLit "r"))   loc'
-       ; let rr_tv  = mkTyVar rr_name runtimeRepTy
-             rr     = mkTyVarTy rr_tv
-             res_tv = mkTyVar tv_name (mkTYPEapp rr)
-             res_ty = mkTyVarTy res_tv
-             is_unlifted = null args && null prov_dicts
-             (cont_args, cont_arg_tys)
-               | is_unlifted = ([nlHsDataCon unboxedUnitDataCon], [unboxedUnitTy])
-               | otherwise   = (args,                             arg_tys)
-             cont_ty = mkInfSigmaTy ex_tvs prov_theta $
-                       mkVisFunTysMany cont_arg_tys res_ty
-
-             fail_ty  = mkVisFunTyMany unboxedUnitTy res_ty
-
-       ; matcher_name <- newImplicitBinder ps_name mkMatcherOcc
-       ; scrutinee    <- newSysLocalId (fsLit "scrut") ManyTy pat_ty
-       ; cont         <- newSysLocalId (fsLit "cont")  ManyTy cont_ty
-       ; fail         <- newSysLocalId (fsLit "fail")  ManyTy fail_ty
-
-       ; dflags       <- getDynFlags
-       ; let matcher_tau   = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty
-             matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
-             matcher_id    = mkExportedVanillaId matcher_name matcher_sigma
-             patsyn_id     = mkExportedVanillaId ps_name matcher_sigma
-                             -- See Note [Exported LocalIds] in GHC.Types.Id
-
-             inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
-             cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
-
-             fail' = nlHsApps fail [nlHsDataCon unboxedUnitDataCon]
-
-             args = map nlVarPat [scrutinee, cont, fail]
-             lwpat = noLocA $ WildPat pat_ty
-             cases = if isIrrefutableHsPat dflags lpat
-                     then [mkHsCaseAlt lpat  cont']
-                     else [mkHsCaseAlt lpat  cont',
-                           mkHsCaseAlt lwpat fail']
-             body = mkLHsWrap (mkWpLet req_ev_binds) $
-                    L (getLoc lpat) $
-                    HsCase noExtField (nlHsVar scrutinee) $
-                    MG{ mg_alts = L (l2l $ getLoc lpat) cases
-                      , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty Generated
-                      }
-             body' = noLocA $
-                     HsLam noExtField $
-                     MG{ mg_alts = noLocA [mkSimpleMatch LambdaExpr
-                                                         args body]
-                       , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty Generated
-                       }
-             match = mkMatch (mkPrefixFunRhs (L loc patsyn_id)) []
-                             (mkHsLams (rr_tv:res_tv:univ_tvs)
-                                       req_dicts body')
-                             (EmptyLocalBinds noExtField)
-             mg :: MatchGroup GhcTc (LHsExpr GhcTc)
-             mg = MG{ mg_alts = L (l2l $ getLoc match) [match]
-                    , mg_ext = MatchGroupTc [] res_ty Generated
-                    }
-             matcher_arity = length req_theta + 3
-             -- See Note [Pragmas for pattern synonyms]
-
-       -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms]
-       -- NB: prag_fn is keyed by the PatSyn Name, not the (internal) matcher name
-       ; matcher_prag_id <- addInlinePrags matcher_id              $
-                            map (addInlinePragArity matcher_arity) $
-                            lookupPragEnv prag_fn ps_name
-
-       ; let bind = FunBind{ fun_id = L loc matcher_prag_id
-                           , fun_matches = mg
-                           , fun_ext = (idHsWrapper, [])
-                           }
-             matcher_bind = unitBag (noLocA bind)
-       ; traceTc "tcPatSynMatcher" (ppr ps_name $$ ppr (idType matcher_id))
-       ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
-
-       ; return ((matcher_name, matcher_sigma, is_unlifted), matcher_bind) }
-
-mkPatSynRecSelBinds :: PatSyn
-                    -> [FieldLabel]  -- ^ Visible field labels
-                    -> FieldSelectors
-                    -> [(Id, LHsBind GhcRn)]
-mkPatSynRecSelBinds ps fields has_sel
-  = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl has_sel
-    | fld_lbl <- fields ]
-
-isUnidirectional :: HsPatSynDir a -> Bool
-isUnidirectional Unidirectional          = True
-isUnidirectional ImplicitBidirectional   = False
-isUnidirectional ExplicitBidirectional{} = False
-
-{-
-************************************************************************
-*                                                                      *
-         Constructing the "builder" Id
-*                                                                      *
-************************************************************************
--}
-
-mkPatSynBuilder :: HsPatSynDir a -> LocatedN Name
-                -> [InvisTVBinder] -> ThetaType
-                -> [InvisTVBinder] -> ThetaType
-                -> [Type] -> Type
-                -> TcM PatSynBuilder
-mkPatSynBuilder dir (L _ name)
-                  univ_bndrs req_theta ex_bndrs prov_theta
-                  arg_tys pat_ty
-  | isUnidirectional dir
-  = return Nothing
-  | otherwise
-  = do { builder_name <- newImplicitBinder name mkBuilderOcc
-       ; let theta          = req_theta ++ prov_theta
-             need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
-                              -- NB: pattern arguments cannot be representation-polymorphic,
-                              -- as checked in 'tcPatSynSig'. So 'isUnliftedType' is OK here.
-             builder_sigma  = add_void need_dummy_arg $
-                              mkInvisForAllTys univ_bndrs $
-                              mkInvisForAllTys ex_bndrs $
-                              mkPhiTy theta $
-                              mkVisFunTysMany arg_tys $
-                              pat_ty
-
-       ; return (Just (builder_name, builder_sigma, need_dummy_arg)) }
-
-tcPatSynBuilderBind :: TcPragEnv
-                    -> PatSynBind GhcRn GhcRn
-                    -> TcM (LHsBinds GhcTc)
--- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn
-tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
-                                 , psb_def = lpat
-                                 , psb_dir = dir
-                                 , psb_args = details })
-  | isUnidirectional dir
-  = return emptyBag
-
-  | Left why <- mb_match_group       -- Can't invert the pattern
-  = setSrcSpan (getLocA lpat) $ failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
-                 <+> quotes (ppr ps_name) <> colon)
-              2 why
-         , text "RHS pattern:" <+> ppr lpat ]
-
-  | Right match_group <- mb_match_group  -- Bidirectional
-  = do { patsyn <- tcLookupPatSyn ps_name
-       ; case patSynBuilder patsyn of {
-           Nothing -> return emptyBag ;
-             -- This case happens if we found a type error in the
-             -- pattern synonym, recovered, and put a placeholder
-             -- with patSynBuilder=Nothing in the environment
-
-           Just (builder_name, builder_ty, need_dummy_arg) ->  -- Normal case
-    do { -- Bidirectional, so patSynBuilder returns Just
-         let builder_id = mkExportedVanillaId builder_name builder_ty
-                         -- See Note [Exported LocalIds] in GHC.Types.Id
-
-             (_, req_theta, _, prov_theta, arg_tys, _) = patSynSigBndr patsyn
-             builder_arity = length req_theta + length prov_theta
-                             + length arg_tys
-                             + (if need_dummy_arg then 1 else 0)
-
-       -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms]
-       -- NB: prag_fn is keyed by the PatSyn Name, not the (internal) builder name
-       ; builder_id <- addInlinePrags builder_id              $
-                       map (addInlinePragArity builder_arity) $
-                       lookupPragEnv prag_fn ps_name
-
-       ; let match_group' | need_dummy_arg = add_dummy_arg match_group
-                          | otherwise      = match_group
-
-             bind = FunBind { fun_id      = L loc (idName builder_id)
-                            , fun_matches = match_group'
-                            , fun_ext     = emptyNameSet
-                            }
-
-             sig = completeSigFromId (PatSynCtxt ps_name) builder_id
-
-       ; traceTc "tcPatSynBuilderBind {" $
-         vcat [ ppr patsyn
-              , ppr builder_id <+> dcolon <+> ppr (idType builder_id) ]
-       ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLocA bind)
-       ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
-       ; return builder_binds } } }
-
-#if __GLASGOW_HASKELL__ <= 810
-  | otherwise = panic "tcPatSynBuilderBind"  -- Both cases dealt with
-#endif
-  where
-    mb_match_group
-       = case dir of
-           ExplicitBidirectional explicit_mg -> Right explicit_mg
-           ImplicitBidirectional -> fmap mk_mg (tcPatToExpr ps_name args lpat)
-           Unidirectional -> panic "tcPatSynBuilderBind"
-
-    mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
-    mk_mg body = mkMatchGroup Generated (noLocA [builder_match])
-          where
-            builder_args  = [L (na2la loc) (VarPat noExtField (L loc n))
-                            | L loc n <- args]
-            builder_match = mkMatch (mkPrefixFunRhs ps_lname)
-                                    builder_args body
-                                    (EmptyLocalBinds noExtField)
-
-    args = case details of
-              PrefixCon _ args   -> args
-              InfixCon arg1 arg2 -> [arg1, arg2]
-              RecCon args        -> map recordPatSynPatVar args
-
-    add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
-                  -> MatchGroup GhcRn (LHsExpr GhcRn)
-    add_dummy_arg mg@(MG { mg_alts =
-                           (L l [L loc match@(Match { m_pats = pats })]) })
-      = mg { mg_alts = L l [L loc (match { m_pats = nlWildPatName : pats })] }
-    add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
-                             pprMatches other_mg
-
-patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType)
-patSynBuilderOcc ps
-  | Just (_, builder_ty, add_void_arg) <- patSynBuilder ps
-  , let builder_expr = mkConLikeTc (PatSynCon ps)
-  = Just $
-    if add_void_arg
-    then ( builder_expr   -- still just return builder_expr; the void# arg
-                          -- is added by dsConLike in the desugarer
-         , tcFunResultTy builder_ty )
-    else (builder_expr, builder_ty)
-
-  | otherwise  -- Unidirectional
-  = Nothing
-
-add_void :: Bool -> Type -> Type
-add_void need_dummy_arg ty
-  | need_dummy_arg = mkVisFunTyMany unboxedUnitTy ty
-  | otherwise      = ty
-
-tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn
-            -> Either SDoc (LHsExpr GhcRn)
--- Given a /pattern/, return an /expression/ that builds a value
--- that matches the pattern.  E.g. if the pattern is (Just [x]),
--- the expression is (Just [x]).  They look the same, but the
--- input uses constructors from HsPat and the output uses constructors
--- from HsExpr.
---
--- Returns (Left r) if the pattern is not invertible, for reason r.
--- See Note [Builder for a bidirectional pattern synonym]
-tcPatToExpr name args pat = go pat
-  where
-    lhsVars = mkNameSet (map unLoc args)
-
-    -- Make a prefix con for prefix and infix patterns for simplicity
-    mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn]
-                    -> Either SDoc (HsExpr GhcRn)
-    mkPrefixConExpr lcon@(L loc _) pats
-      = do { exprs <- mapM go pats
-           ; let con = L (l2l loc) (HsVar noExtField lcon)
-           ; return (unLoc $ mkHsApps con exprs)
-           }
-
-    mkRecordConExpr :: LocatedN Name -> HsRecFields GhcRn (LPat GhcRn)
-                    -> Either SDoc (HsExpr GhcRn)
-    mkRecordConExpr con (HsRecFields fields dd)
-      = do { exprFields <- mapM go' fields
-           ; return (RecordCon noExtField con (HsRecFields exprFields dd)) }
-
-    go' :: LHsRecField GhcRn (LPat GhcRn) -> Either SDoc (LHsRecField GhcRn (LHsExpr GhcRn))
-    go' (L l rf) = L l <$> traverse go rf
-
-    go :: LPat GhcRn -> Either SDoc (LHsExpr GhcRn)
-    go (L loc p) = L loc <$> go1 p
-
-    go1 :: Pat GhcRn -> Either SDoc (HsExpr GhcRn)
-    go1 (ConPat NoExtField con info)
-      = case info of
-          PrefixCon _ ps -> mkPrefixConExpr con ps
-          InfixCon l r   -> mkPrefixConExpr con [l,r]
-          RecCon fields  -> mkRecordConExpr con fields
-
-    go1 (SigPat _ pat _) = go1 (unLoc pat)
-        -- See Note [Type signatures and the builder expression]
-
-    go1 (VarPat _ (L l var))
-        | var `elemNameSet` lhsVars
-        = return $ HsVar noExtField (L l var)
-        | otherwise
-        = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
-    go1 (ParPat _ lpar pat rpar) = fmap (\e -> HsPar noAnn lpar e rpar) $ go pat
-    go1 (ListPat _ pats)
-      = do { exprs <- mapM go pats
-           ; return $ ExplicitList noExtField exprs }
-    go1 (TuplePat _ pats box)       = do { exprs <- mapM go pats
-                                         ; return $ ExplicitTuple noExtField
-                                           (map (Present noAnn) exprs) box }
-    go1 (SumPat _ pat alt arity)    = do { expr <- go1 (unLoc pat)
-                                         ; return $ ExplicitSum noExtField alt arity
-                                                                   (noLocA expr)
-                                         }
-    go1 (LitPat _ lit)              = return $ HsLit noComments lit
-    go1 (NPat _ (L _ n) mb_neg _)
-        | Just (SyntaxExprRn neg) <- mb_neg
-                                    = return $ unLoc $ foldl' nlHsApp (noLocA neg)
-                                                       [noLocA (HsOverLit noAnn n)]
-        | otherwise                 = return $ HsOverLit noAnn n
-    go1 (SplicePat (HsUntypedSpliceTop _ pat) _) = go1 pat
-    go1 (SplicePat (HsUntypedSpliceNested _) _)  = panic "tcPatToExpr: invalid nested splice"
-    go1 (XPat (HsPatExpanded _ pat))= go1 pat
-
-    -- See Note [Invertible view patterns]
-    go1 p@(ViewPat mbInverse _ pat) = case mbInverse of
-      Nothing      -> notInvertible p
-      Just inverse ->
-        fmap
-          (\ expr -> HsApp noAnn (wrapGenSpan inverse) (wrapGenSpan expr))
-          (go1 (unLoc pat))
-
-    -- The following patterns are not invertible.
-    go1 p@(BangPat {})                       = notInvertible p -- #14112
-    go1 p@(LazyPat {})                       = notInvertible p
-    go1 p@(WildPat {})                       = notInvertible p
-    go1 p@(AsPat {})                         = notInvertible p
-    go1 p@(NPlusKPat {})                     = notInvertible p
-
-    notInvertible p = Left (not_invertible_msg p)
-
-    not_invertible_msg p
-      =   text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
-      $+$ hang (text "Suggestion: instead use an explicitly bidirectional"
-                <+> text "pattern synonym, e.g.")
-             2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow
-                      <+> ppr pat <+> text "where")
-                   2 (pp_name <+> pp_args <+> equals <+> text "..."))
-      where
-        pp_name = ppr name
-        pp_args = hsep (map ppr args)
-
-
-{- Note [Builder for a bidirectional pattern synonym]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For a bidirectional pattern synonym, the function 'tcPatToExpr'
-needs to produce an /expression/ that matches the supplied /pattern/,
-given values for the arguments of the pattern synonym. For example:
-  pattern F x y = (Just x, [y])
-The 'builder' for F looks like
-  $builderF x y = (Just x, [y])
-
-We can't always do this:
- * Some patterns aren't invertible; e.g. general view patterns
-      pattern F x = (f -> x)
-   as we don't have the ability to write down an expression that matches
-   the view pattern specified by an arbitrary view function `f`.
-   It is however sometimes possible to write down an inverse;
-     see Note [Invertible view patterns].
-
- * The RHS pattern might bind more variables than the pattern
-   synonym, so again we can't invert it
-      pattern F x = (x,y)
-
- * Ditto wildcards
-      pattern F x = (x,_)
-
-Note [Invertible view patterns]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For some view patterns, such as those that arise from expansion of overloaded
-patterns (as detailed in Note [Handling overloaded and rebindable patterns]),
-we are able to explicitly write out an inverse (in the sense of the previous
-Note [Builder for a bidirectional pattern synonym]).
-For instance, the inverse to the pattern
-
-  (toList -> [True, False])
-
-is the expression
-
-  (fromListN 2 [True,False])
-
-Keeping track of the inverse for such view patterns fixed #14380.
-
-Note [Redundant constraints for builder]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The builder can have redundant constraints, which are awkward to eliminate.
-Consider
-   pattern P = Just 34
-To match against this pattern we need (Eq a, Num a).  But to build
-(Just 34) we need only (Num a).  Fortunately instTcSigFromId sets
-sig_warn_redundant to False.
-
-************************************************************************
-*                                                                      *
-         Helper functions
-*                                                                      *
-************************************************************************
-
-Note [As-patterns in pattern synonym definitions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The rationale for rejecting as-patterns in pattern synonym definitions
-is that an as-pattern would introduce nonindependent pattern synonym
-arguments, e.g. given a pattern synonym like:
-
-        pattern K x y = x@(Just y)
-
-one could write a nonsensical function like
-
-        f (K Nothing x) = ...
-
-or
-        g (K (Just True) False) = ...
-
-Note [Type signatures and the builder expression]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   pattern L x = Left x :: Either [a] [b]
-
-In tc{Infer/Check}PatSynDecl we will check that the pattern has the
-specified type.  We check the pattern *as a pattern*, so the type
-signature is a pattern signature, and so brings 'a' and 'b' into
-scope.  But we don't have a way to bind 'a, b' in the LHS, as we do
-'x', say.  Nevertheless, the signature may be useful to constrain
-the type.
-
-When making the binding for the *builder*, though, we don't want
-  $buildL x = Left x :: Either [a] [b]
-because that wil either mean (forall a b. Either [a] [b]), or we'll
-get a complaint that 'a' and 'b' are out of scope. (Actually the
-latter; #9867.)  No, the job of the signature is done, so when
-converting the pattern to an expression (for the builder RHS) we
-simply discard the signature.
-
-Note [Record PatSyn Desugaring]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It is important that prov_theta comes before req_theta as this ordering is used
-when desugaring record pattern synonym updates.
-
-Any change to this ordering should make sure to change GHC.HsToCore.Expr if you
-want to avoid difficult to decipher core lint errors!
-
-Note [Pragmas for pattern synonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-INLINE and NOINLINE pragmas are supported for pattern synonyms.
-They affect both the matcher and the builder.
-(See Note [Matchers and builders for pattern synonyms] in PatSyn)
-
-For example:
-    pattern InlinedPattern x = [x]
-    {-# INLINE InlinedPattern #-}
-
-    pattern NonInlinedPattern x = [x]
-    {-# NOINLINE NonInlinedPattern #-}
-
-For pattern synonyms with explicit builders, only a pragma for the
-entire pattern synonym is supported. For example:
-    pattern HeadC x <- x:xs where
-      HeadC x = [x]
-      -- This wouldn't compile: {-# INLINE HeadC #-}
-    {-# INLINE HeadC #-} -- But this works
-
-When no pragma is provided for a pattern, the inlining decision might change
-between different versions of GHC.
-
-Implementation notes.  The prag_fn passed in to tcPatSynDecl will have a binding
-for the /pattern synonym/ Name, thus
-      InlinedPattern :-> INLINE
-From this we cook up an INLINE pragma for the matcher (in tcPatSynMatcher)
-and builder (in tcPatSynBuilderBind), by looking up the /pattern synonym/
-Name in the prag_fn, and then using addInlinePragArity to add the right
-inl_sat field to that INLINE pragma for the matcher or builder respectively.
- -}
-
-
--- Walk the whole pattern and for all ConPatOuts, collect the
--- existentially-bound type variables and evidence binding variables.
---
--- These are used in computing the type of a pattern synonym and also
--- in generating matcher functions, since success continuations need
--- to be passed these pattern-bound evidences.
-tcCollectEx
-  :: LPat GhcTc
-  -> ( [TyVar]        -- Existentially-bound type variables
-                      -- in correctly-scoped order; e.g. [ k:*, x:k ]
-     , [EvVar] )      -- and evidence variables
-
-tcCollectEx pat = go pat
-  where
-    go :: LPat GhcTc -> ([TyVar], [EvVar])
-    go = go1 . unLoc
-
-    go1 :: Pat GhcTc -> ([TyVar], [EvVar])
-    go1 (LazyPat _ p)      = go p
-    go1 (AsPat _ _ _ p)    = go p
-    go1 (ParPat _ _ p _)   = go p
-    go1 (BangPat _ p)      = go p
-    go1 (ListPat _ ps)     = mergeMany . map go $ ps
-    go1 (TuplePat _ ps _)  = mergeMany . map go $ ps
-    go1 (SumPat _ p _ _)   = go p
-    go1 (ViewPat _ _ p)    = go p
-    go1 con@ConPat{ pat_con_ext = con' }
-                           = merge (cpt_tvs con', cpt_dicts con') $
-                              goConDetails $ pat_args con
-    go1 (SigPat _ p _)     = go p
-    go1 (XPat ext) = case ext of
-      CoPat _ p _      -> go1 p
-      ExpansionPat _ p -> go1 p
-    go1 (NPlusKPat _ n k _ geq subtract)
-      = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
-    go1 _                   = empty
-
-    goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar])
-    goConDetails (PrefixCon _ ps) = mergeMany . map go $ ps
-    goConDetails (InfixCon p1 p2) = go p1 `merge` go p2
-    goConDetails (RecCon HsRecFields{ rec_flds = flds })
-      = mergeMany . map goRecFd $ flds
-
-    goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])
-    goRecFd (L _ HsFieldBind{ hfbRHS = p }) = go p
-
-    merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2)
-    mergeMany = foldr merge empty
-    empty     = ([], [])
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot
deleted file mode 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot
+++ /dev/null
@@ -1,17 +0,0 @@
-module GHC.Tc.TyCl.PatSyn where
-
-import GHC.Hs    ( PatSynBind, LHsBinds )
-import GHC.Tc.Types ( TcM )
-import GHC.Tc.Utils.Monad ( TcGblEnv)
-import GHC.Hs.Extension ( GhcRn, GhcTc )
-import GHC.Tc.Gen.Sig ( TcPragEnv, TcSigFun )
-import GHC.Parser.Annotation( LocatedA )
-
-tcPatSynDecl :: LocatedA (PatSynBind GhcRn GhcRn)
-             -> TcSigFun
-             -> TcPragEnv
-             -> TcM (LHsBinds GhcTc, TcGblEnv)
-
-tcPatSynBuilderBind :: TcPragEnv -> PatSynBind GhcRn GhcRn
-                    -> TcM (LHsBinds GhcTc)
-
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ /dev/null
@@ -1,1164 +0,0 @@
-
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE TypeFamilies #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1999
-
--}
-
--- | Analysis functions over data types. Specifically, detecting recursive types.
---
--- This stuff is only used for source-code decls; it's recorded in interface
--- files for imported data types.
-module GHC.Tc.TyCl.Utils(
-        RolesInfo,
-        inferRoles,
-        checkSynCycles,
-        checkClassCycles,
-
-        -- * Implicits
-        addTyConsToGblEnv, mkDefaultMethodType,
-
-        -- * Record selectors
-        tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector
-    ) where
-
-import GHC.Prelude
-
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Env
-import GHC.Tc.Gen.Bind( tcValBinds )
-import GHC.Tc.Utils.TcType
-
-import GHC.Builtin.Types( unitTy )
-import GHC.Builtin.Uniques ( mkBuiltinUnique )
-
-import GHC.Hs
-
-import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) )
-import GHC.Core.Multiplicity
-import GHC.Core.Predicate
-import GHC.Core.Make( rEC_SEL_ERROR_ID )
-import GHC.Core.Class
-import GHC.Core.Type
-import GHC.Core.TyCon
-import GHC.Core.ConLike
-import GHC.Core.DataCon
-import GHC.Core.TyCon.Set
-import GHC.Core.Coercion ( ltRole )
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Misc
-import GHC.Utils.FV as FV
-
-import GHC.Data.Maybe
-import GHC.Data.Bag
-import GHC.Data.FastString
-
-import GHC.Unit.Module
-
-import GHC.Types.Basic
-import GHC.Types.Error
-import GHC.Types.FieldLabel
-import GHC.Types.SrcLoc
-import GHC.Types.SourceFile
-import GHC.Types.SourceText
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.Name.Reader ( mkVarUnqual )
-import GHC.Types.Id
-import GHC.Types.Id.Info
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
-import GHC.Types.Unique.Set
-import GHC.Types.TyThing
-import qualified GHC.LanguageExtensions as LangExt
-
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-import Control.Monad
-
-{-
-************************************************************************
-*                                                                      *
-        Cycles in type synonym declarations
-*                                                                      *
-************************************************************************
--}
-
-synonymTyConsOfType :: Type -> [TyCon]
--- Does not look through type synonyms at all.
--- Returns a list of synonym tycons in nondeterministic order.
--- Keep this synchronized with 'expandTypeSynonyms'
-synonymTyConsOfType ty
-  = nonDetNameEnvElts (go ty)
-  where
-     go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
-     go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys
-     go (LitTy _)         = emptyNameEnv
-     go (TyVarTy _)       = emptyNameEnv
-     go (AppTy a b)       = go a `plusNameEnv` go b
-     go (FunTy _ w a b)   = go w `plusNameEnv` go a `plusNameEnv` go b
-     go (ForAllTy _ ty)   = go ty
-     go (CastTy ty co)    = go ty `plusNameEnv` go_co co
-     go (CoercionTy co)   = go_co co
-
-     -- Note [TyCon cycles through coercions?!]
-     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-     -- Although, in principle, it's possible for a type synonym loop
-     -- could go through a coercion (since a coercion can refer to
-     -- a TyCon or Type), it doesn't seem possible to actually construct
-     -- a Haskell program which tickles this case.  Here is an example
-     -- program which causes a coercion:
-     --
-     --   type family Star where
-     --       Star = Type
-     --
-     --   data T :: Star -> Type
-     --   data S :: forall (a :: Type). T a -> Type
-     --
-     -- Here, the application 'T a' must first coerce a :: Type to a :: Star,
-     -- witnessed by the type family.  But if we now try to make Type refer
-     -- to a type synonym which in turn refers to Star, we'll run into
-     -- trouble: we're trying to define and use the type constructor
-     -- in the same recursive group.  Possibly this restriction will be
-     -- lifted in the future but for now, this code is "just for completeness
-     -- sake".
-     go_mco MRefl    = emptyNameEnv
-     go_mco (MCo co) = go_co co
-
-     go_co (Refl ty)              = go ty
-     go_co (GRefl _ ty mco)       = go ty `plusNameEnv` go_mco mco
-     go_co (TyConAppCo _ tc cs)   = go_tc tc `plusNameEnv` go_co_s cs
-     go_co (AppCo co co')         = go_co co `plusNameEnv` go_co co'
-     go_co (ForAllCo _ co co')    = go_co co `plusNameEnv` go_co co'
-     go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r })
-                                  = go_co m `plusNameEnv` go_co a `plusNameEnv` go_co r
-     go_co (CoVarCo _)            = emptyNameEnv
-     go_co (HoleCo {})            = emptyNameEnv
-     go_co (AxiomInstCo _ _ cs)   = go_co_s cs
-     go_co (UnivCo p _ ty ty')    = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty'
-     go_co (SymCo co)             = go_co co
-     go_co (TransCo co co')       = go_co co `plusNameEnv` go_co co'
-     go_co (SelCo _ co)           = go_co co
-     go_co (LRCo _ co)            = go_co co
-     go_co (InstCo co co')        = go_co co `plusNameEnv` go_co co'
-     go_co (KindCo co)            = go_co co
-     go_co (SubCo co)             = go_co co
-     go_co (AxiomRuleCo _ cs)     = go_co_s cs
-
-     go_prov (PhantomProv co)     = go_co co
-     go_prov (ProofIrrelProv co)  = go_co co
-     go_prov (PluginProv _)       = emptyNameEnv
-     go_prov (CorePrepProv _)     = emptyNameEnv
-
-     go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc
-              | otherwise             = emptyNameEnv
-     go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
-     go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos
-
--- | A monad for type synonym cycle checking, which keeps
--- track of the TyCons which are known to be acyclic, or
--- a failure message reporting that a cycle was found.
-newtype SynCycleM a = SynCycleM {
-    runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }
-    deriving (Functor)
-
--- TODO: TyConSet is implemented as IntMap over uniques.
--- But we could get away with something based on IntSet
--- since we only check membership, but never extract the
--- elements.
-type SynCycleState = TyConSet
-
-instance Applicative SynCycleM where
-    pure x = SynCycleM $ \state -> Right (x, state)
-    (<*>) = ap
-
-instance Monad SynCycleM where
-    m >>= f = SynCycleM $ \state ->
-        case runSynCycleM m state of
-            Right (x, state') ->
-                runSynCycleM (f x) state'
-            Left err -> Left err
-
-failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
-failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err)
-
--- | Test if a 'Name' is acyclic, short-circuiting if we've
--- seen it already.
-checkTyConIsAcyclic :: TyCon -> SynCycleM () -> SynCycleM ()
-checkTyConIsAcyclic tc m = SynCycleM $ \s ->
-    if tc `elemTyConSet` s
-        then Right ((), s) -- short circuit
-        else case runSynCycleM m s of
-                Right ((), s') -> Right ((), extendTyConSet s' tc)
-                Left err -> Left err
-
--- | Checks if any of the passed in 'TyCon's have cycles.
--- Takes the 'Unit' of the home package (as we can avoid
--- checking those TyCons: cycles never go through foreign packages) and
--- the corresponding @LTyClDecl Name@ for each 'TyCon', so we
--- can give better error messages.
-checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
-checkSynCycles this_uid tcs tyclds =
-    case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of
-        Left (loc, err) -> setSrcSpan loc $ failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err)
-        Right _  -> return ()
-  where
-    -- Try our best to print the LTyClDecl for locally defined things
-    lcl_decls = mkNameEnv (zip (map tyConName tcs) tyclds)
-
-    -- Short circuit if we've already seen this Name and concluded
-    -- it was acyclic.
-    go :: TyConSet -> [TyCon] -> TyCon -> SynCycleM ()
-    go so_far seen_tcs tc =
-        checkTyConIsAcyclic tc $ go' so_far seen_tcs tc
-
-    -- Expand type synonyms, complaining if you find the same
-    -- type synonym a second time.
-    go' :: TyConSet -> [TyCon] -> TyCon -> SynCycleM ()
-    go' so_far seen_tcs tc
-        | tc `elemTyConSet` so_far
-            = failSynCycleM (getSrcSpan (head seen_tcs)) $
-                  sep [ text "Cycle in type synonym declarations:"
-                      , nest 2 (vcat (map ppr_decl seen_tcs)) ]
-        -- Optimization: we don't allow cycles through external packages,
-        -- so once we find a non-local name we are guaranteed to not
-        -- have a cycle.
-        --
-        -- This won't hold once we get recursive packages with Backpack,
-        -- but for now it's fine.
-        | not (isHoleModule mod ||
-               moduleUnit mod == this_uid ||
-               isInteractiveModule mod)
-            = return ()
-        | Just ty <- synTyConRhs_maybe tc =
-            go_ty (extendTyConSet so_far tc) (tc:seen_tcs) ty
-        | otherwise = return ()
-      where
-        n = tyConName tc
-        mod = nameModule n
-        ppr_decl tc =
-          case lookupNameEnv lcl_decls n of
-            Just (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl
-            Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n
-                       <+> text "from external module"
-         where
-          n = tyConName tc
-
-    go_ty :: TyConSet -> [TyCon] -> Type -> SynCycleM ()
-    go_ty so_far seen_tcs ty =
-        mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty)
-
-{- Note [Superclass cycle check]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The superclass cycle check for C decides if we can statically
-guarantee that expanding C's superclass cycles transitively is
-guaranteed to terminate.  This is a Haskell98 requirement,
-but one that we lift with -XUndecidableSuperClasses.
-
-The worry is that a superclass cycle could make the type checker loop.
-More precisely, with a constraint (Given or Wanted)
-    C ty1 .. tyn
-one approach is to instantiate all of C's superclasses, transitively.
-We can only do so if that set is finite.
-
-This potential loop occurs only through superclasses.  This, for
-example, is fine
-  class C a where
-    op :: C b => a -> b -> b
-even though C's full definition uses C.
-
-Making the check static also makes it conservative.  Eg
-  type family F a
-  class F a => C a
-Here an instance of (F a) might mention C:
-  type instance F [a] = C a
-and now we'd have a loop.
-
-The static check works like this, starting with C
-  * Look at C's superclass predicates
-  * If any is a type-function application,
-    or is headed by a type variable, fail
-  * If any has C at the head, fail
-  * If any has a type class D at the head,
-    make the same test with D
-
-A tricky point is: what if there is a type variable at the head?
-Consider this:
-   class f (C f) => C f
-   class c       => Id c
-and now expand superclasses for constraint (C Id):
-     C Id
- --> Id (C Id)
- --> C Id
- --> ....
-Each step expands superclasses one layer, and clearly does not terminate.
--}
-
-type ClassSet = UniqSet Class
-
-checkClassCycles :: Class -> Maybe SDoc
--- Nothing  <=> ok
--- Just err <=> possible cycle error
-checkClassCycles cls
-  = do { (definite_cycle, err) <- go (unitUniqSet cls)
-                                     cls (mkTyVarTys (classTyVars cls))
-       ; let herald | definite_cycle = text "Superclass cycle for"
-                    | otherwise      = text "Potential superclass cycle for"
-       ; return (vcat [ herald <+> quotes (ppr cls)
-                      , nest 2 err, hint]) }
-  where
-    hint = text "Use UndecidableSuperClasses to accept this"
-
-    -- Expand superclasses starting with (C a b), complaining
-    -- if you find the same class a second time, or a type function
-    -- or predicate headed by a type variable
-    --
-    -- NB: this code duplicates TcType.transSuperClasses, but
-    --     with more error message generation clobber
-    -- Make sure the two stay in sync.
-    go :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
-    go so_far cls tys = firstJusts $
-                        map (go_pred so_far) $
-                        immSuperClasses cls tys
-
-    go_pred :: ClassSet -> PredType -> Maybe (Bool, SDoc)
-       -- Nothing <=> ok
-       -- Just (True, err)  <=> definite cycle
-       -- Just (False, err) <=> possible cycle
-    go_pred so_far pred  -- NB: tcSplitTyConApp looks through synonyms
-       | Just (tc, tys) <- tcSplitTyConApp_maybe pred
-       = go_tc so_far pred tc tys
-       | hasTyVarHead pred
-       = Just (False, hang (text "one of whose superclass constraints is headed by a type variable:")
-                         2 (quotes (ppr pred)))
-       | otherwise
-       = Nothing
-
-    go_tc :: ClassSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)
-    go_tc so_far pred tc tys
-      | isFamilyTyCon tc
-      = Just (False, hang (text "one of whose superclass constraints is headed by a type family:")
-                        2 (quotes (ppr pred)))
-      | Just cls <- tyConClass_maybe tc
-      = go_cls so_far cls tys
-      | otherwise   -- Equality predicate, for example
-      = Nothing
-
-    go_cls :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
-    go_cls so_far cls tys
-       | cls `elementOfUniqSet` so_far
-       = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls))
-       | isCTupleClass cls
-       = go so_far cls tys
-       | otherwise
-       = do { (b,err) <- go  (so_far `addOneToUniqSet` cls) cls tys
-          ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls)
-                       $$ err) }
-
-{-
-************************************************************************
-*                                                                      *
-        Role inference
-*                                                                      *
-************************************************************************
-
-Note [Role inference]
-~~~~~~~~~~~~~~~~~~~~~
-The role inference algorithm datatype definitions to infer the roles on the
-parameters. Although these roles are stored in the tycons, we can perform this
-algorithm on the built tycons, as long as we don't peek at an as-yet-unknown
-roles field! Ah, the magic of laziness.
-
-First, we choose appropriate initial roles. For families and classes, roles
-(including initial roles) are N. For datatypes, we start with the role in the
-role annotation (if any), or otherwise use Phantom. This is done in
-initialRoleEnv1.
-
-The function irGroup then propagates role information until it reaches a
-fixpoint, preferring N over (R or P) and R over P. To aid in this, we have a
-monad RoleM, which is a combination reader and state monad. In its state are
-the current RoleEnv, which gets updated by role propagation, and an update
-bit, which we use to know whether or not we've reached the fixpoint. The
-environment of RoleM contains the tycon whose parameters we are inferring, and
-a VarEnv from parameters to their positions, so we can update the RoleEnv.
-Between tycons, this reader information is missing; it is added by
-addRoleInferenceInfo.
-
-There are two kinds of tycons to consider: algebraic ones (excluding classes)
-and type synonyms. (Remember, families don't participate -- all their parameters
-are N.) An algebraic tycon processes each of its datacons, in turn. Note that
-a datacon's universally quantified parameters might be different from the parent
-tycon's parameters, so we use the datacon's univ parameters in the mapping from
-vars to positions. Note also that we don't want to infer roles for existentials
-(they're all at N, too), so we put them in the set of local variables. As an
-optimisation, we skip any tycons whose roles are already all Nominal, as there
-nowhere else for them to go. For synonyms, we just analyse their right-hand sides.
-
-irType walks through a type, looking for uses of a variable of interest and
-propagating role information. Because anything used under a phantom position
-is at phantom and anything used under a nominal position is at nominal, the
-irType function can assume that anything it sees is at representational. (The
-other possibilities are pruned when they're encountered.)
-
-The rest of the code is just plumbing.
-
-How do we know that this algorithm is correct? It should meet the following
-specification:
-
-Let Z be a role context -- a mapping from variables to roles. The following
-rules define the property (Z |- t : r), where t is a type and r is a role:
-
-Z(a) = r'        r' <= r
-------------------------- RCVar
-Z |- a : r
-
----------- RCConst
-Z |- T : r               -- T is a type constructor
-
-Z |- t1 : r
-Z |- t2 : N
--------------- RCApp
-Z |- t1 t2 : r
-
-forall i<=n. (r_i is R or N) implies Z |- t_i : r_i
-roles(T) = r_1 .. r_n
----------------------------------------------------- RCDApp
-Z |- T t_1 .. t_n : R
-
-Z, a:N |- t : r
----------------------- RCAll
-Z |- forall a:k.t : r
-
-
-We also have the following rules:
-
-For all datacon_i in type T, where a_1 .. a_n are universally quantified
-and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p,
-then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R,
-then roles(T) = r_1 .. r_n
-
-roles(->) = R, R
-roles(~#) = N, N
-
-With -dcore-lint on, the output of this algorithm is checked in checkValidRoles,
-called from checkValidTycon.
-
-Note [Role-checking data constructor arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  data T a where
-    MkT :: Eq b => F a -> (a->a) -> T (G a)
-
-Then we want to check the roles at which 'a' is used
-in MkT's type.  We want to work on the user-written type,
-so we need to take into account
-  * the arguments:   (F a) and (a->a)
-  * the context:     C a b
-  * the result type: (G a)   -- this is in the eq_spec
-
-
-Note [Coercions in role inference]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Is (t |> co1) representationally equal to (t |> co2)? Of course they are! Changing
-the kind of a type is totally irrelevant to the representation of that type. So,
-we want to totally ignore coercions when doing role inference. This includes omitting
-any type variables that appear in nominal positions but only within coercions.
--}
-
-type RolesInfo = Name -> [Role]
-
-type RoleEnv = NameEnv [Role]        -- from tycon names to roles
-
--- This, and any of the functions it calls, must *not* look at the roles
--- field of a tycon we are inferring roles about!
--- See Note [Role inference]
-inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role]
-inferRoles hsc_src annots tycons
-  = let role_env  = initialRoleEnv hsc_src annots tycons
-        role_env' = irGroup role_env tycons in
-    \name -> case lookupNameEnv role_env' name of
-      Just roles -> roles
-      Nothing    -> pprPanic "inferRoles" (ppr name)
-
-initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv
-initialRoleEnv hsc_src annots = extendNameEnvList emptyNameEnv .
-                                map (initialRoleEnv1 hsc_src annots)
-
-initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role])
-initialRoleEnv1 hsc_src annots_env tc
-  | isFamilyTyCon tc      = (name, map (const Nominal) bndrs)
-  | isAlgTyCon tc         = (name, default_roles)
-  | isTypeSynonymTyCon tc = (name, default_roles)
-  | otherwise             = pprPanic "initialRoleEnv1" (ppr tc)
-  where name         = tyConName tc
-        bndrs        = tyConBinders tc
-        argflags     = map tyConBinderForAllTyFlag bndrs
-        num_exps     = count isVisibleForAllTyFlag argflags
-
-          -- if the number of annotations in the role annotation decl
-          -- is wrong, just ignore it. We check this in the validity check.
-        role_annots
-          = case lookupRoleAnnot annots_env name of
-              Just (L _ (RoleAnnotDecl _ _ annots))
-                | annots `lengthIs` num_exps -> map unLoc annots
-              _                              -> replicate num_exps Nothing
-        default_roles = build_default_roles argflags role_annots
-
-        build_default_roles (argf : argfs) (m_annot : ras)
-          | isVisibleForAllTyFlag argf
-          = (m_annot `orElse` default_role) : build_default_roles argfs ras
-        build_default_roles (_argf : argfs) ras
-          = Nominal : build_default_roles argfs ras
-        build_default_roles [] [] = []
-        build_default_roles _ _ = pprPanic "initialRoleEnv1 (2)"
-                                           (vcat [ppr tc, ppr role_annots])
-
-        default_role
-          | isClassTyCon tc               = Nominal
-          -- Note [Default roles for abstract TyCons in hs-boot/hsig]
-          | HsBootFile <- hsc_src
-          , isAbstractTyCon tc            = Representational
-          | HsigFile   <- hsc_src
-          , isAbstractTyCon tc            = Nominal
-          | otherwise                     = Phantom
-
--- Note [Default roles for abstract TyCons in hs-boot/hsig]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- What should the default role for an abstract TyCon be?
---
--- Originally, we inferred phantom role for abstract TyCons
--- in hs-boot files, because the type variables were never used.
---
--- This was silly, because the role of the abstract TyCon
--- was required to match the implementation, and the roles of
--- data types are almost never phantom.  Thus, in ticket #9204,
--- the default was changed so be representational (the most common case).  If
--- the implementing data type was actually nominal, you'd get an easy
--- to understand error, and add the role annotation yourself.
---
--- Then Backpack was added, and with it we added role *subtyping*
--- the matching judgment: if an abstract TyCon has a nominal
--- parameter, it's OK to implement it with a representational
--- parameter.  But now, the representational default is not a good
--- one, because you should *only* request representational if
--- you're planning to do coercions. To be maximally flexible
--- with what data types you will accept, you want the default
--- for hsig files is nominal.  We don't allow role subtyping
--- with hs-boot files (it's good practice to give an exactly
--- accurate role here, because any types that use the abstract
--- type will propagate the role information.)
-
-irGroup :: RoleEnv -> [TyCon] -> RoleEnv
-irGroup env tcs
-  = let (env', update) = runRoleM env $ mapM_ irTyCon tcs in
-    if update
-    then irGroup env' tcs
-    else env'
-
-irTyCon :: TyCon -> RoleM ()
-irTyCon tc
-  | isAlgTyCon tc
-  = do { old_roles <- lookupRoles tc
-       ; unless (all (== Nominal) old_roles) $  -- also catches data families,
-                                                -- which don't want or need role inference
-         irTcTyVars tc $
-         do { mapM_ (irType emptyVarSet) (tyConStupidTheta tc)  -- See #8958
-            ; whenIsJust (tyConClass_maybe tc) irClass
-            ; mapM_ irDataCon (visibleDataCons $ algTyConRhs tc) }}
-
-  | Just ty <- synTyConRhs_maybe tc
-  = irTcTyVars tc $
-    irType emptyVarSet ty
-
-  | otherwise
-  = return ()
-
--- any type variable used in an associated type must be Nominal
-irClass :: Class -> RoleM ()
-irClass cls
-  = mapM_ ir_at (classATs cls)
-  where
-    cls_tvs    = classTyVars cls
-    cls_tv_set = mkVarSet cls_tvs
-
-    ir_at at_tc
-      = mapM_ (updateRole Nominal) nvars
-      where nvars = filter (`elemVarSet` cls_tv_set) $ tyConTyVars at_tc
-
--- See Note [Role inference]
-irDataCon :: DataCon -> RoleM ()
-irDataCon datacon
-  = setRoleInferenceVars univ_tvs $
-    irExTyVars ex_tvs $ \ ex_var_set ->
-      do mapM_ (irType ex_var_set) (eqSpecPreds eq_spec ++ theta ++ map scaledThing arg_tys)
-         mapM_ (markNominal ex_var_set) (map tyVarKind ex_tvs ++ map scaledMult arg_tys)  -- Field multiplicities are nominal (#18799)
-      -- See Note [Role-checking data constructor arguments]
-  where
-    (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)
-      = dataConFullSig datacon
-
-irType :: VarSet -> Type -> RoleM ()
-irType = go
-  where
-    go lcls ty                 | Just ty' <- coreView ty -- #14101
-                               = go lcls ty'
-    go lcls (TyVarTy tv)       = unless (tv `elemVarSet` lcls) $
-                                 updateRole Representational tv
-    go lcls (AppTy t1 t2)      = go lcls t1 >> markNominal lcls t2
-    go lcls (TyConApp tc tys)  = do { roles <- lookupRolesX tc
-                                    ; zipWithM_ (go_app lcls) roles tys }
-    go lcls (ForAllTy tvb ty)  = do { let tv = binderVar tvb
-                                          lcls' = extendVarSet lcls tv
-                                    ; markNominal lcls (tyVarKind tv)
-                                    ; go lcls' ty }
-    go lcls (FunTy _ w arg res)  = markNominal lcls w >> go lcls arg >> go lcls res
-    go _    (LitTy {})         = return ()
-      -- See Note [Coercions in role inference]
-    go lcls (CastTy ty _)      = go lcls ty
-    go _    (CoercionTy _)     = return ()
-
-    go_app _ Phantom _ = return ()                 -- nothing to do here
-    go_app lcls Nominal ty = markNominal lcls ty  -- all vars below here are N
-    go_app lcls Representational ty = go lcls ty
-
-irTcTyVars :: TyCon -> RoleM a -> RoleM a
-irTcTyVars tc thing
-  = setRoleInferenceTc (tyConName tc) $ go (tyConTyVars tc)
-  where
-    go []       = thing
-    go (tv:tvs) = do { markNominal emptyVarSet (tyVarKind tv)
-                     ; addRoleInferenceVar tv $ go tvs }
-
-irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a
-irExTyVars orig_tvs thing = go emptyVarSet orig_tvs
-  where
-    go lcls []       = thing lcls
-    go lcls (tv:tvs) = do { markNominal lcls (tyVarKind tv)
-                          ; go (extendVarSet lcls tv) tvs }
-
-markNominal :: TyVarSet   -- local variables
-            -> Type -> RoleM ()
-markNominal lcls ty = let nvars = fvVarList (FV.delFVs lcls $ get_ty_vars ty) in
-                      mapM_ (updateRole Nominal) nvars
-  where
-     -- get_ty_vars gets all the tyvars (no covars!) from a type *without*
-     -- recurring into coercions. Recall: coercions are totally ignored during
-     -- role inference. See [Coercions in role inference]
-    get_ty_vars :: Type -> FV
-    get_ty_vars t                 | Just t' <- coreView t -- #20999
-                                  = get_ty_vars t'
-    get_ty_vars (TyVarTy tv)      = unitFV tv
-    get_ty_vars (AppTy t1 t2)     = get_ty_vars t1 `unionFV` get_ty_vars t2
-    get_ty_vars (FunTy _ w t1 t2) = get_ty_vars w `unionFV` get_ty_vars t1 `unionFV` get_ty_vars t2
-    get_ty_vars (TyConApp _ tys)  = mapUnionFV get_ty_vars tys
-    get_ty_vars (ForAllTy tvb ty) = tyCoFVsBndr tvb (get_ty_vars ty)
-    get_ty_vars (LitTy {})        = emptyFV
-    get_ty_vars (CastTy ty _)     = get_ty_vars ty
-    get_ty_vars (CoercionTy _)    = emptyFV
-
--- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps
-lookupRolesX :: TyCon -> RoleM [Role]
-lookupRolesX tc
-  = do { roles <- lookupRoles tc
-       ; return $ roles ++ repeat Nominal }
-
--- gets the roles either from the environment or the tycon
-lookupRoles :: TyCon -> RoleM [Role]
-lookupRoles tc
-  = do { env <- getRoleEnv
-       ; case lookupNameEnv env (tyConName tc) of
-           Just roles -> return roles
-           Nothing    -> return $ tyConRoles tc }
-
--- tries to update a role; won't ever update a role "downwards"
-updateRole :: Role -> TyVar -> RoleM ()
-updateRole role tv
-  = do { var_ns <- getVarNs
-       ; name <- getTyConName
-       ; case lookupVarEnv var_ns tv of
-           Nothing -> pprPanic "updateRole" (ppr name $$ ppr tv $$ ppr var_ns)
-           Just n  -> updateRoleEnv name n role }
-
--- the state in the RoleM monad
-data RoleInferenceState = RIS { role_env  :: RoleEnv
-                              , update    :: Bool }
-
--- the environment in the RoleM monad
-type VarPositions = VarEnv Int
-
--- See [Role inference]
-newtype RoleM a = RM { unRM :: Maybe Name -- of the tycon
-                            -> VarPositions
-                            -> Int          -- size of VarPositions
-                            -> RoleInferenceState
-                            -> (a, RoleInferenceState) }
-    deriving (Functor)
-
-instance Applicative RoleM where
-    pure x = RM $ \_ _ _ state -> (x, state)
-    (<*>) = ap
-
-instance Monad RoleM where
-  a >>= f  = RM $ \m_info vps nvps state ->
-                  let (a', state') = unRM a m_info vps nvps state in
-                  unRM (f a') m_info vps nvps state'
-
-runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool)
-runRoleM env thing = (env', update)
-  where RIS { role_env = env', update = update }
-          = snd $ unRM thing Nothing emptyVarEnv 0 state
-        state = RIS { role_env  = env
-                    , update    = False }
-
-setRoleInferenceTc :: Name -> RoleM a -> RoleM a
-setRoleInferenceTc name thing = RM $ \m_name vps nvps state ->
-                                assert (isNothing m_name) $
-                                assert (isEmptyVarEnv vps) $
-                                assert (nvps == 0) $
-                                unRM thing (Just name) vps nvps state
-
-addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a
-addRoleInferenceVar tv thing
-  = RM $ \m_name vps nvps state ->
-    assert (isJust m_name) $
-    unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state
-
-setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a
-setRoleInferenceVars tvs thing
-  = RM $ \m_name _vps _nvps state ->
-    assert (isJust m_name) $
-    unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars")
-         state
-
-getRoleEnv :: RoleM RoleEnv
-getRoleEnv = RM $ \_ _ _ state@(RIS { role_env = env }) -> (env, state)
-
-getVarNs :: RoleM VarPositions
-getVarNs = RM $ \_ vps _ state -> (vps, state)
-
-getTyConName :: RoleM Name
-getTyConName = RM $ \m_name _ _ state ->
-                    case m_name of
-                      Nothing   -> panic "getTyConName"
-                      Just name -> (name, state)
-
-updateRoleEnv :: Name -> Int -> Role -> RoleM ()
-updateRoleEnv name n role
-  = RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((),
-         case lookupNameEnv role_env name of
-           Nothing -> pprPanic "updateRoleEnv" (ppr name)
-           Just roles -> let (before, old_role : after) = splitAt n roles in
-                         if role `ltRole` old_role
-                         then let roles' = before ++ role : after
-                                  role_env' = extendNameEnv role_env name roles' in
-                              RIS { role_env = role_env', update = True }
-                         else state )
-
-
-{- *********************************************************************
-*                                                                      *
-                Building implicits
-*                                                                      *
-********************************************************************* -}
-
-addTyConsToGblEnv :: [TyCon] -> TcM (TcGblEnv, ThBindEnv)
--- Given a [TyCon], add to the TcGblEnv
---   * extend the TypeEnv with the tycons
---   * extend the TypeEnv with their implicitTyThings
---   * extend the TypeEnv with any default method Ids
---   * add bindings for record selectors
--- Return separately the TH levels of these bindings,
--- to be added to a LclEnv later.
-addTyConsToGblEnv tyclss
-  = tcExtendTyConEnv tyclss                    $
-    tcExtendGlobalEnvImplicit implicit_things  $
-    tcExtendGlobalValEnv def_meth_ids          $
-    do { traceTc "tcAddTyCons" $ vcat
-            [ text "tycons" <+> ppr tyclss
-            , text "implicits" <+> ppr implicit_things ]
-       ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss)
-       ; th_bndrs <- tcTyThBinders implicit_things
-       ; return (gbl_env, th_bndrs)
-       }
- where
-   implicit_things = concatMap implicitTyConThings tyclss
-   def_meth_ids    = mkDefaultMethodIds tyclss
-
-mkDefaultMethodIds :: [TyCon] -> [Id]
--- We want to put the default-method Ids (both vanilla and generic)
--- into the type environment so that they are found when we typecheck
--- the filled-in default methods of each instance declaration
--- See Note [Default method Ids and Template Haskell]
-mkDefaultMethodIds tycons
-  = [ mkExportedVanillaId dm_name (mkDefaultMethodType cls sel_id dm_spec)
-    | tc <- tycons
-    , Just cls <- [tyConClass_maybe tc]
-    , (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ]
-
-mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type
--- Returns the top-level type of the default method
-mkDefaultMethodType _ sel_id VanillaDM        = idType sel_id
-mkDefaultMethodType cls _   (GenericDM dm_ty) = mkSigmaTy tv_bndrs [pred] dm_ty
-   where
-     pred      = mkClassPred cls (mkTyVarTys (binderVars cls_bndrs))
-     cls_bndrs = tyConBinders (classTyCon cls)
-     tv_bndrs  = tyVarSpecToBinders $ tyConInvisTVBinders cls_bndrs
-     -- NB: the Class doesn't have TyConBinders; we reach into its
-     --     TyCon to get those.  We /do/ need the TyConBinders because
-     --     we need the correct visibility: these default methods are
-     --     used in code generated by the fill-in for missing
-     --     methods in instances (GHC.Tc.TyCl.Instance.mkDefMethBind), and
-     --     then typechecked.  So we need the right visibility info
-     --     (#13998)
-
-{-
-************************************************************************
-*                                                                      *
-                Building record selectors
-*                                                                      *
-************************************************************************
--}
-
-{-
-Note [Default method Ids and Template Haskell]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this (#4169):
-   class Numeric a where
-     fromIntegerNum :: a
-     fromIntegerNum = ...
-
-   ast :: Q [Dec]
-   ast = [d| instance Numeric Int |]
-
-When we typecheck 'ast' we have done the first pass over the class decl
-(in tcTyClDecls), but we have not yet typechecked the default-method
-declarations (because they can mention value declarations).  So we
-must bring the default method Ids into scope first (so they can be seen
-when typechecking the [d| .. |] quote, and typecheck them later.
--}
-
-{-
-************************************************************************
-*                                                                      *
-                Building record selectors
-*                                                                      *
-************************************************************************
--}
-
-tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
-tcRecSelBinds sel_bind_prs
-  = tcExtendGlobalValEnv [sel_id | (L _ (XSig (IdSig sel_id))) <- sigs] $
-    do { (rec_sel_binds, tcg_env) <- discardWarnings $
-                                     -- See Note [Impredicative record selectors]
-                                     setXOptM LangExt.ImpredicativeTypes $
-                                     tcValBinds TopLevel binds sigs getGblEnv
-       ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) }
-  where
-    sigs = [ L (noAnnSrcSpan loc) (XSig $ IdSig sel_id)
-                                             | (sel_id, _) <- sel_bind_prs
-                                             , let loc = getSrcSpan sel_id ]
-    binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs]
-
-mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]
--- NB We produce *un-typechecked* bindings, rather like 'deriving'
---    This makes life easier, because the later type checking will add
---    all necessary type abstractions and applications
-mkRecSelBinds tycons
-  = map mkRecSelBind [ (tc,fld) | tc <- tycons
-                                , fld <- tyConFieldLabels tc ]
-
-mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn)
-mkRecSelBind (tycon, fl)
-  = mkOneRecordSelector all_cons (RecSelData tycon) fl
-        FieldSelectors  -- See Note [NoFieldSelectors and naughty record selectors]
-  where
-    all_cons = map RealDataCon (tyConDataCons tycon)
-
-mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors
-                    -> (Id, LHsBind GhcRn)
-mkOneRecordSelector all_cons idDetails fl has_sel
-  = (sel_id, L (noAnnSrcSpan loc) sel_bind)
-  where
-    loc      = getSrcSpan sel_name
-    loc'     = noAnnSrcSpan loc
-    locn     = noAnnSrcSpan loc
-    locc     = noAnnSrcSpan loc
-    lbl      = flLabel fl
-    sel_name = flSelector fl
-
-    sel_id = mkExportedLocalId rec_details sel_name sel_ty
-    rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty }
-
-    -- Find a representative constructor, con1
-    cons_w_field = conLikesWithFields all_cons [lbl]
-    con1 = assert (not (null cons_w_field)) $ head cons_w_field
-
-    -- Selector type; Note [Polymorphic selectors]
-    field_ty    = conLikeFieldType con1 lbl
-    data_tv_set = tyCoVarsOfTypes (data_ty : req_theta)
-    data_tvbs   = filter (\tvb -> binderVar tvb `elemVarSet` data_tv_set) $
-                  conLikeUserTyVarBinders con1
-
-    -- is_naughty: see Note [Naughty record selectors]
-    is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set)
-              || has_sel == NoFieldSelectors  -- No field selectors => all are naughty
-                                              -- thus suppressing making a binding
-                                              -- A slight hack!
-
-    sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]
-           | otherwise  = mkForAllTys (tyVarSpecToBinders data_tvbs) $
-                          -- Urgh! See Note [The stupid context] in GHC.Core.DataCon
-                          mkPhiTy (conLikeStupidTheta con1) $
-                          -- req_theta is empty for normal DataCon
-                          mkPhiTy req_theta                 $
-                          mkVisFunTyMany data_ty            $
-                            -- Record selectors are always typed with Many. We
-                            -- could improve on it in the case where all the
-                            -- fields in all the constructor have multiplicity Many.
-                          field_ty
-
-    -- Make the binding: sel (C2 { fld = x }) = x
-    --                   sel (C7 { fld = x }) = x
-    --    where cons_w_field = [C2,C7]
-    sel_bind = mkTopFunBind Generated sel_lname alts
-      where
-        alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname)
-                                           [] unit_rhs]
-             | otherwise =  map mk_match cons_w_field ++ deflt
-    mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)
-                                 [L loc' (mk_sel_pat con)]
-                                 (L loc' (HsVar noExtField (L locn field_var)))
-    mk_sel_pat con = ConPat NoExtField (L locn (getName con)) (RecCon rec_fields)
-    rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
-    rec_field  = noLocA (HsFieldBind
-                        { hfbAnn = noAnn
-                        , hfbLHS
-                           = L locc (FieldOcc sel_name
-                                      (L locn $ mkVarUnqual (field_label lbl)))
-                        , hfbRHS
-                           = L loc' (VarPat noExtField (L locn field_var))
-                        , hfbPun = False })
-    sel_lname = L locn sel_name
-    field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
-
-    -- Add catch-all default case unless the case is exhaustive
-    -- We do this explicitly so that we get a nice error message that
-    -- mentions this particular record selector
-    deflt | all dealt_with all_cons = []
-          | otherwise = [mkSimpleMatch CaseAlt
-                            [L loc' (WildPat noExtField)]
-                            (mkHsApp (L loc' (HsVar noExtField
-                                         (L locn (getName rEC_SEL_ERROR_ID))))
-                                     (L loc' (HsLit noComments msg_lit)))]
-
-        -- Do not add a default case unless there are unmatched
-        -- constructors.  We must take account of GADTs, else we
-        -- get overlap warning messages from the pattern-match checker
-        -- NB: we need to pass type args for the *representation* TyCon
-        --     to dataConCannotMatch, hence the calculation of inst_tys
-        --     This matters in data families
-        --              data instance T Int a where
-        --                 A :: { fld :: Int } -> T Int Bool
-        --                 B :: { fld :: Int } -> T Int Char
-    dealt_with :: ConLike -> Bool
-    dealt_with (PatSynCon _) = False -- We can't predict overlap
-    dealt_with con@(RealDataCon dc)
-      = con `elem` cons_w_field || dataConCannotMatch inst_tys dc
-      where
-        inst_tys = dataConResRepTyArgs dc
-
-    (_, _, _, _, req_theta, _, data_ty) = conLikeFullSig con1
-
-    unit_rhs = mkLHsTupleExpr [] noExtField
-    msg_lit = HsStringPrim NoSourceText (bytesFS (field_label lbl))
-
-{-
-Note [Polymorphic selectors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We take care to build the type of a polymorphic selector in the right
-order, so that visible type application works according to the specification in
-the GHC User's Guide (see the "Field selectors and TypeApplications" section).
-We won't bother rehashing the entire specification in this Note, but the tricky
-part is dealing with GADT constructor fields. Here is an appropriately tricky
-example to illustrate the challenges:
-
-  {-# LANGUAGE PolyKinds #-}
-  data T a b where
-    MkT :: forall b a x.
-           { field1 :: forall c. (Num a, Show c) => (Either a c, Proxy b)
-           , field2 :: x
-           }
-        -> T a b
-
-Our goal is to obtain the following type for `field1`:
-
-  field1 :: forall {k} (b :: k) a.
-            T a b -> forall c. (Num a, Show c) => (Either a c, Proxy b)
-
-(`field2` is naughty, per Note [Naughty record selectors], so we cannot turn
-it into a top-level field selector.)
-
-Some potential gotchas, inspired by #18023:
-
-1. Since the user wrote `forall b a x.` in the type of `MkT`, we want the `b`
-   to appear before the `a` when quantified in the type of `field1`.
-2. On the other hand, we *don't* want to quantify `x` in the type of `field1`.
-   This is because `x` does not appear in the GADT return type, so it is not
-   needed in the selector type.
-3. Because of PolyKinds, the kind of `b` is generalized to `k`. Moreover, since
-   this `k` is not written in the source code, it is inferred (i.e., not
-   available for explicit type applications) and thus written as {k} in the type
-   of `field1`.
-
-In order to address these gotchas, we start by looking at the
-conLikeUserTyVarBinders, which gives the order and specificity of each binder.
-This effectively solves (1) and (3). To solve (2), we filter the binders to
-leave only those that are needed for the selector type.
-
-Note [Naughty record selectors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A "naughty" field is one for which we can't define a record
-selector, because an existential type variable would escape.  For example:
-        data T = forall a. MkT { x,y::a }
-We obviously can't define
-        x (MkT v _) = v
-Nevertheless we *do* put a RecSelId into the type environment
-so that if the user tries to use 'x' as a selector we can bleat
-helpfully, rather than saying unhelpfully that 'x' is not in scope.
-Hence the sel_naughty flag, to identify record selectors that don't really exist.
-
-In general, a field is "naughty" if its type mentions a type variable that
-isn't in
-  * the (original, user-written) result type of the constructor, or
-  * the "required theta" for the constructor
-
-Note that this *allows* GADT record selectors (Note [GADT record
-selectors]) whose types may look like sel :: T [a] -> a
-
-The "required theta" part is illustrated by test patsyn/should_run/records_run
-where we have
-
-  pattern ReadP :: Read a => a -> String
-  pattern ReadP {readp} <- (read -> readp)
-
-The selector is defined like this:
-
-  $selreadp :: ReadP a => String -> a
-  $selReadP s = readp s
-
-Perfectly fine!  The (ReadP a) constraint lets us contructor a value
-of type 'a' from a bare String.  NB: "required theta" is empty for
-data cons (see conLikeFullSig), so this reasoning only bites for
-patttern synonyms.
-
-For naughty selectors we make a dummy binding
-   sel = ()
-so that the later type-check will add them to the environment, and they'll be
-exported.  The function is never called, because the typechecker spots the
-sel_naughty field.
-
-Note [NoFieldSelectors and naughty record selectors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Under NoFieldSelectors (see Note [NoFieldSelectors] in GHC.Rename.Env), record
-selectors will not be in scope in the renamer.  However, for normal datatype
-declarations we still generate the underlying selector functions, so they can be
-used for constructing the dictionaries for HasField constraints (as described by
-Note [HasField instances] in GHC.Tc.Instance.Class).  Hence the call to
-mkOneRecordSelector in mkRecSelBind always uses FieldSelectors.
-
-However, record pattern synonyms are not used with HasField, so when
-NoFieldSelectors is used we do not need to generate selector functions.  Thus
-mkPatSynRecSelBinds passes the current state of the FieldSelectors extension to
-mkOneRecordSelector, and in the NoFieldSelectors case it will treat them as
-"naughty" fields (see Note [Naughty record selectors]).
-
-Why generate a naughty binding, rather than no binding at all? Because when
-type-checking a record update, we need to look up Ids for the fields. In
-particular, disambiguateRecordBinds calls lookupParents which needs to look up
-the RecSelIds to determine the sel_tycon.
-
-Note [GADT record selectors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For GADTs, we require that all constructors with a common field 'f' have the same
-result type (modulo alpha conversion).  [Checked in GHC.Tc.TyCl.checkValidTyCon]
-E.g.
-        data T where
-          T1 { f :: Maybe a } :: T [a]
-          T2 { f :: Maybe a, y :: b  } :: T [a]
-          T3 :: T Int
-
-and now the selector takes that result type as its argument:
-   f :: forall a. T [a] -> Maybe a
-
-Details: the "real" types of T1,T2 are:
-   T1 :: forall r a.   (r~[a]) => a -> T r
-   T2 :: forall r a b. (r~[a]) => a -> b -> T r
-
-So the selector loooks like this:
-   f :: forall a. T [a] -> Maybe a
-   f (a:*) (t:T [a])
-     = case t of
-         T1 c   (g:[a]~[c]) (v:Maybe c)       -> v `cast` Maybe (right (sym g))
-         T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g))
-         T3 -> error "T3 does not have field f"
-
-Note the forall'd tyvars of the selector are just the free tyvars
-of the result type; there may be other tyvars in the constructor's
-type (e.g. 'b' in T2).
-
-Note the need for casts in the result!
-
-Note [Selector running example]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's OK to combine GADTs and type families.  Here's a running example:
-
-        data instance T [a] where
-          T1 { fld :: b } :: T [Maybe b]
-
-The representation type looks like this
-        data :R7T a where
-          T1 { fld :: b } :: :R7T (Maybe b)
-
-and there's coercion from the family type to the representation type
-        :CoR7T a :: T [a] ~ :R7T a
-
-The selector we want for fld looks like this:
-
-        fld :: forall b. T [Maybe b] -> b
-        fld = /\b. \(d::T [Maybe b]).
-              case d `cast` :CoR7T (Maybe b) of
-                T1 (x::b) -> x
-
-The scrutinee of the case has type :R7T (Maybe b), which can be
-gotten by applying the eq_spec to the univ_tvs of the data con.
-
-Note [Impredicative record selectors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There are situations where generating code for record selectors requires the
-use of ImpredicativeTypes. Here is one example (adapted from #18005):
-
-  type S = (forall b. b -> b) -> Int
-  data T = MkT {unT :: S}
-         | Dummy
-
-We want to generate HsBinds for unT that look something like this:
-
-  unT :: S
-  unT (MkT x) = x
-  unT _       = recSelError "unT"#
-
-Note that the type of recSelError is `forall r (a :: TYPE r). Addr# -> a`.
-Therefore, when used in the right-hand side of `unT`, GHC attempts to
-instantiate `a` with `(forall b. b -> b) -> Int`, which is impredicative.
-To make sure that GHC is OK with this, we enable ImpredicativeTypes internally
-when typechecking these HsBinds so that the user does not have to.
--}
diff --git a/compiler/GHC/Tc/Types/EvTerm.hs b/compiler/GHC/Tc/Types/EvTerm.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Types/EvTerm.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-
--- (those who have too heavy dependencies for GHC.Tc.Types.Evidence)
-module GHC.Tc.Types.EvTerm
-    ( evDelayedError, evCallStack )
-where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-
-import GHC.Tc.Types.Evidence
-
-import GHC.Unit
-
-import GHC.Builtin.Names
-import GHC.Builtin.Types ( unitTy )
-
-import GHC.Core.Type
-import GHC.Core
-import GHC.Core.Make
-import GHC.Core.Utils
-
-import GHC.Types.SrcLoc
-import GHC.Types.TyThing
-
--- Used with Opt_DeferTypeErrors
--- See Note [Deferring coercion errors to runtime]
--- in GHC.Tc.Solver
-evDelayedError :: Type -> String -> EvTerm
-evDelayedError ty msg
-  = EvExpr $
-    let fail_expr = mkRuntimeErrorApp tYPE_ERROR_ID unitTy msg
-    in mkWildCase fail_expr (unrestricted unitTy) ty []
-       -- See Note [Incompleteness and linearity] in GHC.HsToCore.Utils
-       -- c.f. mkErrorAppDs in GHC.HsToCore.Utils
-
--- Dictionary for CallStack implicit parameters
-evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
-    EvCallStack -> m EvExpr
--- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence
-evCallStack cs = do
-  df            <- getDynFlags
-  let platform = targetPlatform df
-  m             <- getModule
-  srcLocDataCon <- lookupDataCon srcLocDataConName
-  let mkSrcLoc l = mkCoreConApps srcLocDataCon <$>
-               sequence [ mkStringExprFS (unitFS $ moduleUnit m)
-                        , mkStringExprFS (moduleNameFS $ moduleName m)
-                        , mkStringExprFS (srcSpanFile l)
-                        , return $ mkIntExprInt platform (srcSpanStartLine l)
-                        , return $ mkIntExprInt platform (srcSpanStartCol l)
-                        , return $ mkIntExprInt platform (srcSpanEndLine l)
-                        , return $ mkIntExprInt platform (srcSpanEndCol l)
-                        ]
-
-  emptyCS <- Var <$> lookupId emptyCallStackName
-
-  pushCSVar <- lookupId pushCallStackName
-  let pushCS name loc rest =
-        mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]
-
-  let mkPush name loc tm = do
-        nameExpr <- mkStringExprFS name
-        locExpr <- mkSrcLoc loc
-        -- at this point tm :: IP sym CallStack
-        -- but we need the actual CallStack to pass to pushCS,
-        -- so we use unwrapIP to strip the dictionary wrapper
-        -- See Note [Overview of implicit CallStacks]
-        let ip_co = unwrapIP (exprType tm)
-        return (pushCS nameExpr locExpr (Cast tm ip_co))
-
-  case cs of
-    EvCsPushCall fs loc tm -> mkPush fs loc tm
-    EvCsEmpty              -> return emptyCS
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ /dev/null
@@ -1,1049 +0,0 @@
-
-{-# LANGUAGE NondecreasingIndentation #-}
-{-# LANGUAGE ScopedTypeVariables      #-}
-{-# LANGUAGE TypeFamilies             #-}
-
-module GHC.Tc.Utils.Backpack (
-    findExtraSigImports,
-    implicitRequirements,
-    implicitRequirementsShallow,
-    checkUnit,
-    tcRnCheckUnit,
-    tcRnMergeSignatures,
-    mergeSignatures,
-    tcRnInstantiateSignature,
-    instantiateSignature,
-) where
-
-import GHC.Prelude
-
-
-import GHC.Driver.Env
-import GHC.Driver.Ppr
-import GHC.Driver.Session
-
-import GHC.Types.Basic (TypeOrKind(..))
-import GHC.Types.Fixity (defaultFixity)
-import GHC.Types.Fixity.Env
-import GHC.Types.TypeEnv
-import GHC.Types.Name.Reader
-import GHC.Types.Id
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.Name.Set
-import GHC.Types.Avail
-import GHC.Types.SrcLoc
-import GHC.Types.SourceFile
-import GHC.Types.Var
-import GHC.Types.Unique.DSet
-import GHC.Types.Name.Shape
-import GHC.Types.PkgQual
-
-import GHC.Unit
-import GHC.Unit.Finder
-import GHC.Unit.Module.Warnings
-import GHC.Unit.Module.ModIface
-import GHC.Unit.Module.ModDetails
-import GHC.Unit.Module.Imported
-import GHC.Unit.Module.Deps
-
-import GHC.Tc.Errors.Types
-import GHC.Tc.Gen.Export
-import GHC.Tc.Solver
-import GHC.Tc.TyCl.Utils
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Instantiate
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.TcType
-
-import GHC.Hs
-
-import GHC.Core.InstEnv
-import GHC.Core.FamInstEnv
-import GHC.Core.Type
-import GHC.Core.Multiplicity
-
-import GHC.IfaceToCore
-import GHC.Iface.Load
-import GHC.Iface.Rename
-import GHC.Iface.Syntax
-
-import GHC.Rename.Names
-import GHC.Rename.Fixity ( lookupFixityRn )
-
-import GHC.Tc.Utils.Env
-import GHC.Tc.Errors
-import GHC.Tc.Utils.Unify
-
-import GHC.Utils.Error
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-import GHC.Data.FastString
-import GHC.Data.Maybe
-
-import Control.Monad
-import Data.List (find)
-
-import {-# SOURCE #-} GHC.Tc.Module
-
-
-fixityMisMatch :: TyThing -> Fixity -> Fixity -> TcRnMessage
-fixityMisMatch real_thing real_fixity sig_fixity =
-  mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [ppr real_thing <+> text "has conflicting fixities in the module",
-          text "and its hsig file",
-          text "Main module:" <+> ppr_fix real_fixity,
-          text "Hsig file:" <+> ppr_fix sig_fixity]
-  where
-    ppr_fix f =
-        ppr f <+>
-        (if f == defaultFixity
-            then parens (text "default")
-            else empty)
-
-checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()
-checkHsigDeclM sig_iface sig_thing real_thing = do
-    let name = getName real_thing
-    -- TODO: Distinguish between signature merging and signature
-    -- implementation cases.
-    checkBootDeclM False sig_thing real_thing
-    real_fixity <- lookupFixityRn name
-    let sig_fixity = case mi_fix_fn (mi_final_exts sig_iface) (occName name) of
-                        Nothing -> defaultFixity
-                        Just f -> f
-    when (real_fixity /= sig_fixity) $
-      addErrAt (nameSrcSpan name)
-        (fixityMisMatch real_thing real_fixity sig_fixity)
-
--- | Given a 'ModDetails' of an instantiated signature (note that the
--- 'ModDetails' must be knot-tied consistently with the actual implementation)
--- and a 'GlobalRdrEnv' constructed from the implementor of this interface,
--- verify that the actual implementation actually matches the original
--- interface.
---
--- Note that it is already assumed that the implementation *exports*
--- a sufficient set of entities, since otherwise the renaming and then
--- typechecking of the signature 'ModIface' would have failed.
-checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn ()
-checkHsigIface tcg_env gr sig_iface
-  ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,
-               md_types = sig_type_env, md_exports = sig_exports   } = do
-    traceTc "checkHsigIface" $ vcat
-        [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]
-    mapM_ check_export (map availName sig_exports)
-    failIfErrsM -- See Note [Fail before checking instances in checkHsigIface]
-    unless (null sig_fam_insts) $
-        panic ("GHC.Tc.Module.checkHsigIface: Cannot handle family " ++
-               "instances in hsig files yet...")
-    -- Delete instances so we don't look them up when
-    -- checking instance satisfiability
-    -- TODO: this should not be necessary
-    tcg_env <- getGblEnv
-    setGblEnv tcg_env { tcg_inst_env = emptyInstEnv,
-                        tcg_fam_inst_env = emptyFamInstEnv,
-                        tcg_insts = [],
-                        tcg_fam_insts = [] } $ do
-    mapM_ check_inst (instEnvElts sig_insts)
-    failIfErrsM
-  where
-    -- NB: the Names in sig_type_env are bogus.  Let's say we have H.hsig
-    -- in package p that defines T; and we implement with himpl:H.  Then the
-    -- Name is p[himpl:H]:H.T, NOT himplH:H.T.  That's OK but we just
-    -- have to look up the right name.
-    sig_type_occ_env = mkOccEnv
-                     . map (\t -> (nameOccName (getName t), t))
-                     $ nonDetNameEnvElts sig_type_env
-    dfun_names = map getName (instEnvElts sig_insts)
-    check_export name
-      -- Skip instances, we'll check them later
-      -- TODO: Actually this should never happen, because DFuns are
-      -- never exported...
-      | name `elem` dfun_names = return ()
-      -- See if we can find the type directly in the hsig ModDetails
-      -- TODO: need to special case wired in names
-      | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do
-        -- NB: We use tcLookupImported_maybe because we want to EXCLUDE
-        -- tcg_env (TODO: but maybe this isn't relevant anymore).
-        r <- tcLookupImported_maybe name
-        case r of
-          Failed err -> addErr (TcRnInterfaceLookupError name err)
-          Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing
-
-      -- The hsig did NOT define this function; that means it must
-      -- be a reexport.  In this case, make sure the 'Name' of the
-      -- reexport matches the 'Name exported here.
-      | [gre] <- lookupGlobalRdrEnv gr (nameOccName name) = do
-        let name' = greMangledName gre
-        when (name /= name') $ do
-            -- See Note [Error reporting bad reexport]
-            -- TODO: Actually this error swizzle doesn't work
-            let p (L _ ie) = name `elem` ieNames ie
-                loc = case tcg_rn_exports tcg_env of
-                       Just es | Just e <- find p (map fst es)
-                         -- TODO: maybe we can be a little more
-                         -- precise here and use the Located
-                         -- info for the *specific* name we matched.
-                         -> getLocA e
-                       _ -> nameSrcSpan name
-            addErrAt loc
-                (badReexportedBootThing False name name')
-      -- This should actually never happen, but whatever...
-      | otherwise =
-        addErrAt (nameSrcSpan name)
-            (missingBootThing False name "exported by")
-
--- Note [Fail before checking instances in checkHsigIface]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- We need to be careful about failing before checking instances if there happens
--- to be an error in the exports.
--- Otherwise, we might proceed with typechecking (and subsequently panic-ing) on
--- ill-kinded types that are constructed while checking instances.
--- This lead to #19244
-
--- Note [Error reporting bad reexport]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- NB: You want to be a bit careful about what location you report on reexports.
--- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the
--- correct source location.  However, if it was *reexported*, obviously the name
--- is not going to have the right location.  In this case, we need to grovel in
--- tcg_rn_exports to figure out where the reexport came from.
-
-
-
--- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't
--- assume that the implementing file actually implemented the instances (they
--- may be reexported from elsewhere).  Where should we look for the instances?
--- We do the same as we would otherwise: consult the EPS.  This isn't perfect
--- (we might conclude the module exports an instance when it doesn't, see
--- #9422), but we will never refuse to compile something.
-check_inst :: ClsInst -> TcM ()
-check_inst sig_inst = do
-    -- TODO: This could be very well generalized to support instance
-    -- declarations in boot files.
-    tcg_env <- getGblEnv
-    -- NB: Have to tug on the interface, not necessarily
-    -- tugged... but it didn't work?
-    mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst))
-    -- Based off of 'simplifyDeriv'
-    let ty = idType (instanceDFunId sig_inst)
-        -- Based off of tcSplitDFunTy
-        (tvs, theta, pred) =
-           case tcSplitForAllInvisTyVars ty of { (tvs, rho)    ->
-           case splitFunTys rho             of { (theta, pred) ->
-           (tvs, theta, pred) }}
-        origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst
-    skol_info <- mkSkolemInfo InstSkol
-    (skol_subst, tvs_skols) <- tcInstSkolTyVars skol_info tvs -- Skolemize
-    (tclvl,cts) <- pushTcLevelM $ do
-       wanted <- newWanted origin
-                           (Just TypeLevel)
-                           (substTy skol_subst pred)
-       givens <- forM theta $ \given -> do
-           loc <- getCtLocM origin (Just TypeLevel)
-           let given_pred = substTy skol_subst (scaledThing given)
-           new_ev <- newEvVar given_pred
-           return CtGiven { ctev_pred = given_pred
-                          -- Doesn't matter, make something up
-                          , ctev_evar = new_ev
-                          , ctev_loc = loc
-                          }
-       return $ wanted : givens
-    unsolved <- simplifyWantedsTcM cts
-
-    (implic, _) <- buildImplicationFor tclvl (getSkolemInfo skol_info) tvs_skols [] unsolved
-    reportAllUnsolved (mkImplicWC implic)
-
--- | For a module @modname@ of type 'HscSource', determine the list
--- of extra "imports" of other requirements which should be considered part of
--- the import of the requirement, because it transitively depends on those
--- requirements by imports of modules from other packages.  The situation
--- is something like this:
---
---      unit p where
---          signature X
---          signature Y
---              import X
---
---      unit q where
---          dependency p[X=\<A>,Y=\<B>]
---          signature A
---          signature B
---
--- Although q's B does not directly import A, we still have to make sure we
--- process A first, because the merging process will cause B to indirectly
--- import A.  This function finds the TRANSITIVE closure of all such imports
--- we need to make.
-findExtraSigImports :: HscEnv
-                    -> HscSource
-                    -> ModuleName
-                    -> IO [ModuleName]
-findExtraSigImports hsc_env HsigFile modname = do
-    let
-      dflags     = hsc_dflags hsc_env
-      ctx        = initSDocContext dflags defaultUserStyle
-      unit_state = hsc_units hsc_env
-      reqs       = requirementMerges unit_state modname
-    holes <- forM reqs $ \(Module iuid mod_name) -> do
-        initIfaceLoad hsc_env
-            . withException ctx
-            $ moduleFreeHolesPrecise (text "findExtraSigImports")
-                (mkModule (VirtUnit iuid) mod_name)
-    return (uniqDSetToList (unionManyUniqDSets holes))
-
-findExtraSigImports _ _ _ = return []
-
--- Given a list of 'import M' statements in a module, figure out
--- any extra implicit requirement imports they may have.  For
--- example, if they 'import M' and M resolves to p[A=<B>,C=D], then
--- they actually also import the local requirement B.
-implicitRequirements :: HscEnv
-                     -> [(PkgQual, Located ModuleName)]
-                     -> IO [ModuleName]
-implicitRequirements hsc_env normal_imports
-  = fmap concat $
-    forM normal_imports $ \(mb_pkg, L _ imp) -> do
-        found <- findImportedModule hsc_env imp mb_pkg
-        case found of
-            Found _ mod | notHomeModuleMaybe mhome_unit mod ->
-                return (uniqDSetToList (moduleFreeHoles mod))
-            _ -> return []
-  where
-    mhome_unit = hsc_home_unit_maybe hsc_env
-
--- | Like @implicitRequirements'@, but returns either the module name, if it is
--- a free hole, or the instantiated unit the imported module is from, so that
--- that instantiated unit can be processed and via the batch mod graph (rather
--- than a transitive closure done here) all the free holes are still reachable.
-implicitRequirementsShallow
-  :: HscEnv
-  -> [(PkgQual, Located ModuleName)]
-  -> IO ([ModuleName], [InstantiatedUnit])
-implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports
- where
-  mhome_unit = hsc_home_unit_maybe hsc_env
-
-  go acc [] = pure acc
-  go (accL, accR) ((mb_pkg, L _ imp):imports) = do
-    found <- findImportedModule hsc_env imp mb_pkg
-    let acc' = case found of
-          Found _ mod | notHomeModuleMaybe mhome_unit mod ->
-              case moduleUnit mod of
-                  HoleUnit -> (moduleName mod : accL, accR)
-                  RealUnit _ -> (accL, accR)
-                  VirtUnit u -> (accL, u:accR)
-          _ -> (accL, accR)
-    go acc' imports
-
--- | Given a 'Unit', make sure it is well typed.  This is because
--- unit IDs come from Cabal, which does not know if things are well-typed or
--- not; a component may have been filled with implementations for the holes
--- that don't actually fulfill the requirements.
-checkUnit :: Unit -> TcM ()
-checkUnit HoleUnit         = return ()
-checkUnit (RealUnit _)     = return () -- if it's already compiled, must be well-typed
-checkUnit (VirtUnit indef) = do
-   let insts = instUnitInsts indef
-   forM_ insts $ \(mod_name, mod) ->
-       -- NB: direct hole instantiations are well-typed by construction
-       -- (because we FORCE things to be merged in), so don't check them
-       when (not (isHoleModule mod)) $ do
-           checkUnit (moduleUnit mod)
-           _ <- mod `checkImplements` Module indef mod_name
-           return ()
-
--- | Top-level driver for signature instantiation (run when compiling
--- an @hsig@ file.)
-tcRnCheckUnit ::
-    HscEnv -> Unit ->
-    IO (Messages TcRnMessage, Maybe ())
-tcRnCheckUnit hsc_env uid =
-   withTiming logger
-              (text "Check unit id" <+> ppr uid)
-              (const ()) $
-   initTc hsc_env
-          HsigFile -- bogus
-          False
-          (mainModIs (hsc_HUE hsc_env))
-          (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus
-    $ checkUnit uid
-  where
-   dflags = hsc_dflags hsc_env
-   logger = hsc_logger hsc_env
-   loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid)
-
--- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear...
-
--- | Top-level driver for signature merging (run after typechecking
--- an @hsig@ file).
-tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface
-                    -> IO (Messages TcRnMessage, Maybe TcGblEnv)
-tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =
-  withTiming logger
-             (text "Signature merging" <+> brackets (ppr this_mod))
-             (const ()) $
-  initTc hsc_env HsigFile False this_mod real_loc $
-    mergeSignatures hpm orig_tcg_env iface
- where
-  logger   = hsc_logger hsc_env
-  this_mod = mi_module iface
-  real_loc = tcg_top_loc orig_tcg_env
-
-thinModIface :: [AvailInfo] -> ModIface -> ModIface
-thinModIface avails iface =
-    iface {
-        mi_exports = avails,
-        -- mi_fixities = ...,
-        -- mi_warns = ...,
-        -- mi_anns = ...,
-        -- TODO: The use of nameOccName here is a bit dodgy, because
-        -- perhaps there might be two IfaceTopBndr that are the same
-        -- OccName but different Name.  Requires better understanding
-        -- of invariants here.
-        mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls
-        -- mi_insts = ...,
-        -- mi_fam_insts = ...,
-    }
-  where
-    decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs
-    filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface)
-
-    exported_occs = mkOccSet [ occName n
-                             | a <- avails
-                             , n <- availNames a ]
-    exported_decls = filter_decls exported_occs
-
-    non_exported_occs = mkOccSet [ occName n
-                                 | (_, d) <- exported_decls
-                                 , n <- ifaceDeclNeverExportedRefs d ]
-    non_exported_decls = filter_decls non_exported_occs
-
-    dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True
-    dfun_pred _ = False
-    dfun_decls = filter (dfun_pred . snd) (mi_decls iface)
-
--- | The list of 'Name's of *non-exported* 'IfaceDecl's which this
--- 'IfaceDecl' may refer to.  A non-exported 'IfaceDecl' should be kept
--- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps)
--- refers to it; we can't decide to keep it by looking at the exports
--- of a module after thinning.  Keep this synchronized with
--- 'rnIfaceDecl'.
-ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name]
-ifaceDeclNeverExportedRefs d@IfaceFamily{} =
-    case ifFamFlav d of
-        IfaceClosedSynFamilyTyCon (Just (n, _))
-            -> [n]
-        _   -> []
-ifaceDeclNeverExportedRefs _ = []
-
-
--- Note [Blank hsigs for all requirements]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- One invariant that a client of GHC must uphold is that there
--- must be an hsig file for every requirement (according to
--- @-this-unit-id@); this ensures that for every interface
--- file (hi), there is a source file (hsig), which helps grease
--- the wheels of recompilation avoidance which assumes that
--- source files always exist.
-
-{-
-inheritedSigPvpWarning :: WarningTxt
-inheritedSigPvpWarning =
-    WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))]
-  where
-    msg = "Inherited requirements from non-signature libraries (libraries " ++
-          "with modules) should not be used, as this mode of use is not " ++
-          "compatible with PVP-style version bounds.  Instead, copy the " ++
-          "declaration to the local hsig file or move the signature to a " ++
-          "library of its own and add that library as a dependency."
--}
-
--- Note [Handling never-exported TyThings under Backpack]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
---   DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will
---   never be mentioned in the export list of a module (mi_avails).
---   Unlike implicit TyThings (Note [Implicit TyThings]), non-exported
---   TyThings DO have a standalone IfaceDecl declaration in their
---   interface file.
---
--- Originally, Backpack was designed under the assumption that anything
--- you could declare in a module could also be exported; thus, merging
--- the export lists of two signatures is just merging the declarations
--- of two signatures writ small.  Of course, in GHC Haskell, there are a
--- few important things which are not explicitly exported but still can
--- be used:  in particular, dictionary functions for instances, Typeable
--- TyCon bindings, and coercion axioms for type families also count.
---
--- When handling these non-exported things, there two primary things
--- we need to watch out for:
---
---  * Signature matching/merging is done by comparing each
---    of the exported entities of a signature and a module.  These exported
---    entities may refer to non-exported TyThings which must be tested for
---    consistency.  For example, an instance (ClsInst) will refer to a
---    non-exported DFunId.  In this case, 'checkBootDeclM' directly compares the
---    embedded 'DFunId' in 'is_dfun'.
---
---    For this to work at all, we must ensure that pointers in 'is_dfun' refer
---    to DISTINCT 'DFunId's, even though the 'Name's (may) be the same.
---    Unfortunately, this is the OPPOSITE of how we treat most other references
---    to 'Name's, so this case needs to be handled specially.
---
---    The details are in the documentation for 'typecheckIfacesForMerging'.
---    and the Note [Resolving never-exported Names] in GHC.IfaceToCore.
---
---  * When we rename modules and signatures, we use the export lists to
---    decide how the declarations should be renamed.  However, this
---    means we don't get any guidance for how to rename non-exported
---    entities.  Fortunately, we only need to rename these entities
---    *consistently*, so that 'typecheckIfacesForMerging' can wire them
---    up as needed.
---
---    The details are in Note [rnIfaceNeverExported] in 'GHC.Iface.Rename'.
---
--- The root cause for all of these complications is the fact that these
--- logically "implicit" entities are defined indirectly in an interface
--- file.  #13151 gives a proposal to make these *truly* implicit.
-
-merge_msg :: ModuleName -> [InstantiatedModule] -> SDoc
-merge_msg mod_name [] =
-    text "while checking the local signature" <+> ppr mod_name <+>
-    text "for consistency"
-merge_msg mod_name reqs =
-  hang (text "while merging the signatures from" <> colon)
-   2 (vcat [ bullet <+> ppr req | req <- reqs ] $$
-      bullet <+> text "...and the local signature for" <+> ppr mod_name)
-
--- | Given a local 'ModIface', merge all inherited requirements
--- from 'requirementMerges' into this signature, producing
--- a final 'TcGblEnv' that matches the local signature and
--- all required signatures.
-mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv
-mergeSignatures
-  (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }),
-                    hpm_src_files = src_files })
-  orig_tcg_env lcl_iface0 = setSrcSpan loc $ do
-    -- The lcl_iface0 is the ModIface for the local hsig
-    -- file, which is guaranteed to exist, see
-    -- Note [Blank hsigs for all requirements]
-    hsc_env <- getTopEnv
-
-    -- Copy over some things from the original TcGblEnv that
-    -- we want to preserve
-    updGblEnv (\env -> env {
-        -- Renamed imports/declarations are often used
-        -- by programs that use the GHC API, e.g., Haddock.
-        -- These won't get filled by the merging process (since
-        -- we don't actually rename the parsed module again) so
-        -- we need to take them directly from the previous
-        -- typechecking.
-        --
-        -- NB: the export declarations aren't in their final
-        -- form yet.  We'll fill those in when we reprocess
-        -- the export declarations.
-        tcg_rn_imports = tcg_rn_imports orig_tcg_env,
-        tcg_rn_decls   = tcg_rn_decls   orig_tcg_env,
-        -- Annotations
-        tcg_ann_env    = tcg_ann_env    orig_tcg_env,
-        -- Documentation header
-        tcg_doc_hdr    = tcg_doc_hdr orig_tcg_env
-        -- tcg_dus?
-        -- tcg_th_used           = tcg_th_used orig_tcg_env,
-        -- tcg_th_splice_used    = tcg_th_splice_used orig_tcg_env
-       }) $ do
-    tcg_env <- getGblEnv
-
-    let outer_mod  = tcg_mod tcg_env
-    let inner_mod  = tcg_semantic_mod tcg_env
-    let mod_name   = moduleName (tcg_mod tcg_env)
-    let unit_state = hsc_units hsc_env
-    let dflags     = hsc_dflags hsc_env
-
-    -- STEP 1: Figure out all of the external signature interfaces
-    -- we are going to merge in.
-    let reqs = requirementMerges unit_state mod_name
-
-    addErrCtxt (pprWithUnitState unit_state $ merge_msg mod_name reqs) $ do
-
-    -- STEP 2: Read in the RAW forms of all of these interfaces
-    ireq_ifaces0 <- liftIO $ forM reqs $ \(Module iuid mod_name) -> do
-        let m = mkModule (VirtUnit iuid) mod_name
-            im = fst (getModuleInstantiation m)
-            ctx = initSDocContext dflags defaultUserStyle
-        fmap fst
-         . withException ctx
-         $ findAndReadIface hsc_env
-                            (text "mergeSignatures") im m NotBoot
-
-    -- STEP 3: Get the unrenamed exports of all these interfaces,
-    -- thin it according to the export list, and do shaping on them.
-    let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as
-        -- This function gets run on every inherited interface, and
-        -- it's responsible for:
-        --
-        --  1. Merging the exports of the interface into @nsubst@,
-        --  2. Adding these exports to the "OK to import" set (@oks@)
-        --  if they came from a package with no exposed modules
-        --  (this means we won't report a PVP error in this case), and
-        --  3. Thinning the interface according to an explicit export
-        --  list.
-        --
-        gen_subst (nsubst,oks,ifaces) (imod@(Module iuid _), ireq_iface) = do
-            let insts = instUnitInsts iuid
-                isFromSignaturePackage =
-                    let inst_uid = instUnitInstanceOf iuid
-                        pkg = unsafeLookupUnitId unit_state inst_uid
-                    in null (unitExposedModules pkg)
-            -- 3(a). Rename the exports according to how the dependency
-            -- was instantiated.  The resulting export list will be accurate
-            -- except for exports *from the signature itself* (which may
-            -- be subsequently updated by exports from other signatures in
-            -- the merge.
-            as1 <- tcRnModExports insts ireq_iface
-            -- 3(b). Thin the interface if it comes from a signature package.
-            (thinned_iface, as2) <- case mb_exports of
-                    Just (L loc _)
-                      -- Check if the package containing this signature is
-                      -- a signature package (i.e., does not expose any
-                      -- modules.)  If so, we can thin it.
-                      | isFromSignaturePackage
-                      -> setSrcSpanA loc $ do
-                        -- Suppress missing errors; they might be used to refer
-                        -- to entities from other signatures we are merging in.
-                        -- If an identifier truly doesn't exist in any of the
-                        -- signatures that are merged in, we will discover this
-                        -- when we run exports_from_avail on the final merged
-                        -- export list.
-                        (mb_r, msgs) <- tryTc $ do
-                            -- Suppose that we have written in a signature:
-                            --  signature A ( module A ) where {- empty -}
-                            -- If I am also inheriting a signature from a
-                            -- signature package, does 'module A' scope over
-                            -- all of its exports?
-                            --
-                            -- There are two possible interpretations:
-                            --
-                            --  1. For non self-reexports, a module reexport
-                            --  is interpreted only in terms of the local
-                            --  signature module, and not any of the inherited
-                            --  ones.  The reason for this is because after
-                            --  typechecking, module exports are completely
-                            --  erased from the interface of a file, so we
-                            --  have no way of "interpreting" a module reexport.
-                            --  Thus, it's only useful for the local signature
-                            --  module (where we have a useful GlobalRdrEnv.)
-                            --
-                            --  2. On the other hand, a common idiom when
-                            --  you want to "export everything, plus a reexport"
-                            --  in modules is to say module A ( module A, reex ).
-                            --  This applies to signature modules too; and in
-                            --  particular, you probably still want the entities
-                            --  from the inherited signatures to be preserved
-                            --  too.
-                            --
-                            -- We think it's worth making a special case for
-                            -- self reexports to make use case (2) work.  To
-                            -- do this, we take the exports of the inherited
-                            -- signature @as1@, and bundle them into a
-                            -- GlobalRdrEnv where we treat them as having come
-                            -- from the import @import A@.  Thus, we will
-                            -- pick them up if they are referenced explicitly
-                            -- (@foo@) or even if we do a module reexport
-                            -- (@module A@).
-                            let ispec = ImpSpec ImpDeclSpec{
-                                            -- NB: This needs to be mod name
-                                            -- of the local signature, not
-                                            -- the (original) module name of
-                                            -- the inherited signature,
-                                            -- because we need module
-                                            -- LocalSig (from the local
-                                            -- export list) to match it!
-                                            is_mod  = mod_name,
-                                            is_as   = mod_name,
-                                            is_qual = False,
-                                            is_dloc = locA loc
-                                          } ImpAll
-                                rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1)
-                            setGblEnv tcg_env {
-                                tcg_rdr_env = rdr_env
-                            } $ exports_from_avail mb_exports rdr_env
-                                    -- NB: tcg_imports is also empty!
-                                    emptyImportAvails
-                                    (tcg_semantic_mod tcg_env)
-                        case mb_r of
-                            Just (_, as2) -> return (thinModIface as2 ireq_iface, as2)
-                            Nothing -> addMessages msgs >> failM
-                    -- We can't think signatures from non signature packages
-                    _ -> return (ireq_iface, as1)
-            -- 3(c). Only identifiers from signature packages are "ok" to
-            -- import (that is, they are safe from a PVP perspective.)
-            -- (NB: This code is actually dead right now.)
-            let oks' | isFromSignaturePackage
-                     = extendOccSetList oks (exportOccs as2)
-                     | otherwise
-                     = oks
-            -- 3(d). Extend the name substitution (performing shaping)
-            mb_r <- extend_ns nsubst as2
-            case mb_r of
-                Left err -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err)
-                Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces)
-        nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0)
-        ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0))
-    -- Process each interface, getting the thinned interfaces as well as
-    -- the final, full set of exports @nsubst@ and the exports which are
-    -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.)
-    (nsubst, ok_to_use, rev_thinned_ifaces)
-        <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0)
-    let thinned_ifaces = reverse rev_thinned_ifaces
-        exports        = nameShapeExports nsubst
-        rdr_env        = mkGlobalRdrEnv (gresFromAvails Nothing exports)
-        _warn_occs     = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports)
-        warns          = NoWarnings
-        {-
-        -- TODO: Warnings are transitive, but this is not what we want here:
-        -- if a module reexports an entity from a signature, that should be OK.
-        -- Not supported in current warning framework
-        warns | null warn_occs = NoWarnings
-              | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs
-        -}
-    setGblEnv tcg_env {
-        -- The top-level GlobalRdrEnv is quite interesting.  It consists
-        -- of two components:
-        --  1. First, we reuse the GlobalRdrEnv of the local signature.
-        --     This is very useful, because it means that if we have
-        --     to print a message involving some entity that the local
-        --     signature imported, we'll qualify it accordingly.
-        --  2. Second, we need to add all of the declarations we are
-        --     going to merge in (as they need to be in scope for the
-        --     final test of the export list.)
-        tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env,
-        -- Inherit imports from the local signature, so that module
-        -- reexports are picked up correctly
-        tcg_imports = tcg_imports orig_tcg_env,
-        tcg_exports = exports,
-        tcg_dus     = usesOnly (availsToNameSetWithSelectors exports),
-        tcg_warns   = warns
-        } $ do
-    tcg_env <- getGblEnv
-
-    -- Make sure we didn't refer to anything that doesn't actually exist
-    -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return ()
-    (mb_lies, _) <- exports_from_avail mb_exports rdr_env
-                        (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)
-
-    {- -- NB: This is commented out, because warns above is disabled.
-    -- If you tried to explicitly export an identifier that has a warning
-    -- attached to it, that's probably a mistake.  Warn about it.
-    case mb_lies of
-      Nothing -> return ()
-      Just lies ->
-        forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) ->
-          setSrcSpan loc $
-            unless (nameOccName n `elemOccSet` ok_to_use) $
-                addWarn NoReason $ vcat [
-                    text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.",
-                    parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.")
-                    ]
-    -}
-
-    failIfErrsM
-
-    -- Save the exports
-    setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do
-    tcg_env <- getGblEnv
-
-    let home_unit = hsc_home_unit hsc_env
-
-    -- STEP 4: Rename the interfaces
-    ext_ifaces <- forM thinned_ifaces $ \((Module iuid _), ireq_iface) ->
-        tcRnModIface (instUnitInsts iuid) (Just nsubst) ireq_iface
-    lcl_iface <- tcRnModIface (homeUnitInstantiations home_unit) (Just nsubst) lcl_iface0
-    let ifaces = lcl_iface : ext_ifaces
-
-    -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env
-    let fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f)
-                            | (occ, f) <- concatMap mi_fixities ifaces
-                            , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ]
-
-    -- STEP 5: Typecheck the interfaces
-    let type_env_var = tcg_type_env_var tcg_env
-
-    -- typecheckIfacesForMerging does two things:
-    --      1. It merges the all of the ifaces together, and typechecks the
-    --      result to type_env.
-    --      2. It typechecks each iface individually, but with their 'Name's
-    --      resolving to the merged type_env from (1).
-    -- See typecheckIfacesForMerging for more details.
-    (type_env, detailss) <- initIfaceTcRn $
-                            typecheckIfacesForMerging inner_mod ifaces type_env_var
-    let infos = zip ifaces detailss
-
-    -- Test for cycles
-    checkSynCycles (homeUnitAsUnit home_unit) (typeEnvTyCons type_env) []
-
-    -- NB on type_env: it contains NO dfuns.  DFuns are recorded inside
-    -- detailss, and given a Name that doesn't correspond to anything real.  See
-    -- also Note [Signature merging DFuns]
-
-    -- Add the merged type_env to TcGblEnv, so that it gets serialized
-    -- out when we finally write out the interface.
-    --
-    -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly,
-    -- rather than use tcExtendGlobalEnv (the normal method to add newly
-    -- defined types to TcGblEnv?)  tcExtendGlobalEnv adds these
-    -- TyThings to 'tcg_type_env_var', which is consulted when
-    -- we read in interfaces to tie the knot.  But *these TyThings themselves
-    -- come from interface*, so that would result in deadlock.  Don't
-    -- update it!
-    setGblEnv tcg_env {
-        tcg_tcs = typeEnvTyCons type_env,
-        tcg_patsyns = typeEnvPatSyns type_env,
-        tcg_type_env = type_env,
-        tcg_fix_env = fix_env
-        } $ do
-    tcg_env <- getGblEnv
-
-    -- STEP 6: Check for compatibility/merge things
-    tcg_env <- (\x -> foldM x tcg_env infos)
-             $ \tcg_env (iface, details) -> do
-
-        let check_export name
-              | Just sig_thing <- lookupTypeEnv (md_types details) name
-              = case lookupTypeEnv type_env (getName sig_thing) of
-                  Just thing -> checkHsigDeclM iface sig_thing thing
-                  Nothing -> panic "mergeSignatures: check_export"
-              -- Oops! We're looking for this export but it's
-              -- not actually in the type environment of the signature's
-              -- ModDetails.
-              --
-              -- NB: This case happens because the we're iterating
-              -- over the union of all exports, so some interfaces
-              -- won't have everything.  Note that md_exports is nonsense
-              -- (it's the same as exports); maybe we should fix this
-              -- eventually.
-              | otherwise
-              = return ()
-        mapM_ check_export (map availName exports)
-
-        -- Note [Signature merging instances]
-        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-        -- Merge instances into the global environment.  The algorithm here is
-        -- dumb and simple: if an instance has exactly the same DFun type
-        -- (tested by 'memberInstEnv') as an existing instance, we drop it;
-        -- otherwise, we add it even, even if this would cause overlap.
-        --
-        -- Why don't we deduplicate instances with identical heads?  There's no
-        -- good choice if they have premises:
-        --
-        --      instance K1 a => K (T a)
-        --      instance K2 a => K (T a)
-        --
-        -- Why not eagerly error in this case?  The overlapping head does not
-        -- necessarily mean that the instances are unimplementable: in fact,
-        -- they may be implemented without overlap (if, for example, the
-        -- implementing module has 'instance K (T a)'; both are implemented in
-        -- this case.)  The implements test just checks that the wanteds are
-        -- derivable assuming the givens.
-        --
-        -- Still, overlapping instances with hypotheses like above are going
-        -- to be a bad deal, because instance resolution when we're typechecking
-        -- against the merged signature is going to have a bad time when
-        -- there are overlapping heads like this: we never backtrack, so it
-        -- may be difficult to see that a wanted is derivable.  For now,
-        -- we hope that we get lucky / the overlapping instances never
-        -- get used, but it is not a very good situation to be in.
-        --
-        hsc_env <- getTopEnv
-        let merge_inst (insts, inst_env) inst
-                | memberInstEnv inst_env inst -- test DFun Type equality
-                = (insts, inst_env)
-                | otherwise
-                -- NB: is_dfun_name inst is still nonsense here,
-                -- see Note [Signature merging DFuns]
-                = (inst:insts, extendInstEnv inst_env inst)
-            (insts, inst_env) = foldl' merge_inst
-                                    (tcg_insts tcg_env, tcg_inst_env tcg_env)
-                                    (instEnvElts $ md_insts details)
-            -- This is a HACK to prevent calculateAvails from including imp_mod
-            -- in the listing.  We don't want it because a module is NOT
-            -- supposed to include itself in its dep_orphs/dep_finsts.  See #13214
-            iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } }
-            home_unit = hsc_home_unit hsc_env
-            other_home_units = hsc_all_home_unit_ids hsc_env
-            avails = plusImportAvails (tcg_imports tcg_env) $
-                        calculateAvails home_unit other_home_units iface' False NotBoot ImportedBySystem
-        return tcg_env {
-            tcg_inst_env = inst_env,
-            tcg_insts    = insts,
-            tcg_imports  = avails,
-            tcg_merged   =
-                if outer_mod == mi_module iface
-                    -- Don't add ourselves!
-                    then tcg_merged tcg_env
-                    else (mi_module iface, mi_mod_hash (mi_final_exts iface)) : tcg_merged tcg_env
-            }
-
-    -- Note [Signature merging DFuns]
-    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-    -- Once we know all of instances which will be defined by this merged
-    -- signature, we go through each of the DFuns and rename them with a fresh,
-    -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing
-    -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'.
-    --
-    -- We can't do this fixup earlier, because we need a way to identify each
-    -- source DFun (from each of the signatures we are merging in) so that
-    -- when we have a ClsInst, we can pull up the correct DFun to check if
-    -- the types match.
-    --
-    -- See also Note [rnIfaceNeverExported] in GHC.Iface.Rename
-    dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do
-        n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst))
-        let dfun = setVarName (is_dfun inst) n
-        return (dfun, inst { is_dfun_name = n, is_dfun = dfun })
-    tcg_env <- return tcg_env {
-            tcg_insts = map snd dfun_insts,
-            tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts)
-        }
-
-    addDependentFiles src_files
-
-    return tcg_env
-
--- | Top-level driver for signature instantiation (run when compiling
--- an @hsig@ file.)
-tcRnInstantiateSignature ::
-    HscEnv -> Module -> RealSrcSpan ->
-    IO (Messages TcRnMessage, Maybe TcGblEnv)
-tcRnInstantiateSignature hsc_env this_mod real_loc =
-   withTiming logger
-              (text "Signature instantiation"<+>brackets (ppr this_mod))
-              (const ()) $
-   initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature
-  where
-   logger = hsc_logger hsc_env
-
-exportOccs :: [AvailInfo] -> [OccName]
-exportOccs = concatMap (map occName . availNames)
-
-impl_msg :: UnitState -> Module -> InstantiatedModule -> SDoc
-impl_msg unit_state impl_mod (Module req_uid req_mod_name)
-   = pprWithUnitState unit_state $
-      text "while checking that" <+> ppr impl_mod <+>
-      text "implements signature" <+> ppr req_mod_name <+>
-      text "in" <+> ppr req_uid
-
--- | Check if module implements a signature.  (The signature is
--- always un-hashed, which is why its components are specified
--- explicitly.)
-checkImplements :: Module -> InstantiatedModule -> TcRn TcGblEnv
-checkImplements impl_mod req_mod@(Module uid mod_name) = do
-  hsc_env <- getTopEnv
-  let unit_state = hsc_units hsc_env
-      home_unit  = hsc_home_unit hsc_env
-      other_home_units = hsc_all_home_unit_ids hsc_env
-  addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do
-    let insts = instUnitInsts uid
-
-    -- STEP 1: Load the implementing interface, and make a RdrEnv
-    -- for its exports.  Also, add its 'ImportAvails' to 'tcg_imports',
-    -- so that we treat all orphan instances it provides as visible
-    -- when we verify that all instances are checked (see #12945), and so that
-    -- when we eventually write out the interface we record appropriate
-    -- dependency information.
-    impl_iface <- initIfaceTcRn $
-        loadSysInterface (text "checkImplements 1") impl_mod
-    let impl_gr = mkGlobalRdrEnv
-                    (gresFromAvails Nothing (mi_exports impl_iface))
-        nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface)
-
-    -- Load all the orphans, so the subsequent 'checkHsigIface' sees
-    -- all the instances it needs to
-    loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")
-                         (dep_orphs (mi_deps impl_iface))
-
-    let avails = calculateAvails home_unit other_home_units
-                    impl_iface False{- safe -} NotBoot ImportedBySystem
-        fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f)
-                            | (occ, f) <- mi_fixities impl_iface
-                            , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ]
-    updGblEnv (\tcg_env -> tcg_env {
-        -- Setting tcg_rdr_env to treat all exported entities from
-        -- the implementing module as in scope improves error messages,
-        -- as it reduces the amount of qualification we need.  Unfortunately,
-        -- we still end up qualifying references to external modules
-        -- (see bkpfail07 for an example); we'd need to record more
-        -- information in ModIface to solve this.
-        tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr,
-        tcg_imports = tcg_imports tcg_env `plusImportAvails` avails,
-        -- This is here so that when we call 'lookupFixityRn' for something
-        -- directly implemented by the module, we grab the right thing
-        tcg_fix_env = fix_env
-        }) $ do
-
-    -- STEP 2: Load the *unrenamed, uninstantiated* interface for
-    -- the ORIGINAL signature.  We are going to eventually rename it,
-    -- but we must proceed slowly, because it is NOT known if the
-    -- instantiation is correct.
-    let sig_mod = mkModule (VirtUnit uid) mod_name
-        isig_mod = fst (getModuleInstantiation sig_mod)
-    hsc_env <- getTopEnv
-    mb_isig_iface <- liftIO $ findAndReadIface hsc_env
-                                               (text "checkImplements 2")
-                                               isig_mod sig_mod NotBoot
-    isig_iface <- case mb_isig_iface of
-        Succeeded (iface, _) -> return iface
-        Failed err -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-            hang (text "Could not find hi interface for signature" <+>
-                  quotes (ppr isig_mod) <> colon) 4 err
-
-    -- STEP 3: Check that the implementing interface exports everything
-    -- we need.  (Notice we IGNORE the Modules in the AvailInfos.)
-    forM_ (exportOccs (mi_exports isig_iface)) $ \occ ->
-        case lookupGlobalRdrEnv impl_gr occ of
-            [] -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-                        quotes (ppr occ)
-                    <+> text "is exported by the hsig file, but not exported by the implementing module"
-                    <+> quotes (pprWithUnitState unit_state $ ppr impl_mod)
-            _ -> return ()
-    failIfErrsM
-
-    -- STEP 4: Now that the export is complete, rename the interface...
-    sig_iface <- tcRnModIface insts (Just nsubst) isig_iface
-
-    -- STEP 5: ...and typecheck it.  (Note that in both cases, the nsubst
-    -- lets us determine how top-level identifiers should be handled.)
-    sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface
-
-    -- STEP 6: Check that it's sufficient
-    tcg_env <- getGblEnv
-    checkHsigIface tcg_env impl_gr sig_iface sig_details
-
-    -- STEP 7: Return the updated 'TcGblEnv' with the signature exports,
-    -- so we write them out.
-    return tcg_env {
-        tcg_exports = mi_exports sig_iface
-        }
-
--- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite
--- library to use the actual implementations of the relevant entities,
--- checking that the implementation matches the signature.
-instantiateSignature :: TcRn TcGblEnv
-instantiateSignature = do
-    hsc_env <- getTopEnv
-    tcg_env <- getGblEnv
-    let outer_mod = tcg_mod tcg_env
-        inner_mod = tcg_semantic_mod tcg_env
-        home_unit = hsc_home_unit hsc_env
-    -- TODO: setup the local RdrEnv so the error messages look a little better.
-    -- But this information isn't stored anywhere. Should we RETYPECHECK
-    -- the local one just to get the information?  Hmm...
-    massert (isHomeModule home_unit outer_mod )
-    massert (isHomeUnitInstantiating home_unit)
-    let uid = homeUnitInstanceOf home_unit
-    inner_mod `checkImplements`
-        Module
-            (mkInstantiatedUnit uid (homeUnitInstantiations home_unit))
-            (moduleName outer_mod)
diff --git a/compiler/GHC/Tc/Utils/Concrete.hs b/compiler/GHC/Tc/Utils/Concrete.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Utils/Concrete.hs
+++ /dev/null
@@ -1,684 +0,0 @@
-{-# LANGUAGE MultiWayIf #-}
-
--- | Checking for representation-polymorphism using the Concrete mechanism.
---
--- This module contains the logic for enforcing the representation-polymorphism
--- invariants by way of emitting constraints.
-module GHC.Tc.Utils.Concrete
-  ( -- * Ensuring that a type has a fixed runtime representation
-    hasFixedRuntimeRep
-  , hasFixedRuntimeRep_syntactic
-
-    -- * Making a type concrete
-  , makeTypeConcrete
-  )
- where
-
-import GHC.Prelude
-
-import GHC.Builtin.Types       ( liftedTypeKindTyCon, unliftedTypeKindTyCon )
-
-import GHC.Core.Coercion       ( coToMCo, mkCastTyMCo
-                               , mkGReflRightMCo, mkNomReflCo )
-import GHC.Core.TyCo.Rep       ( Type(..), MCoercion(..) )
-import GHC.Core.TyCon          ( isConcreteTyCon )
-import GHC.Core.Type           ( isConcrete, typeKind, tyVarKind, coreView
-                               , mkTyVarTy, mkTyConApp, mkFunTy, mkAppTy )
-
-import GHC.Tc.Types            ( TcM, ThStage(..), PendingStuff(..) )
-import GHC.Tc.Types.Constraint ( NotConcreteError(..), NotConcreteReason(..) )
-import GHC.Tc.Types.Evidence   ( Role(..), TcCoercionN, TcMCoercionN )
-import GHC.Tc.Types.Origin     ( CtOrigin(..), FixedRuntimeRepContext, FixedRuntimeRepOrigin(..) )
-import GHC.Tc.Utils.Monad      ( emitNotConcreteError, setTcLevel, getCtLocM, getStage, traceTc )
-import GHC.Tc.Utils.TcType     ( TcType, TcKind, TcTypeFRR
-                               , MetaInfo(..), ConcreteTvOrigin(..)
-                               , isMetaTyVar, metaTyVarInfo, tcTyVarLevel )
-import GHC.Tc.Utils.TcMType    ( newConcreteTyVar, isFilledMetaTyVar_maybe, writeMetaTyVar
-                               , emitWantedEq )
-
-import GHC.Types.Basic         ( TypeOrKind(..) )
-import GHC.Utils.Misc          ( HasDebugCallStack )
-import GHC.Utils.Outputable
-
-import Control.Monad      ( void )
-import Data.Functor       ( ($>) )
-import Data.List.NonEmpty ( NonEmpty((:|)) )
-
-import Control.Monad.Trans.Class      ( lift )
-import Control.Monad.Trans.Writer.CPS ( WriterT, runWriterT, tell )
-
-{- Note [Concrete overview]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-GHC ensures that certain types have a fixed runtime representation in the
-typechecker, by emitting certain constraints.
-Emitting constraints to be solved later allows us to accept more programs:
-if we directly inspected the type (using e.g. `typePrimRep`), we might not
-have enough information available (e.g. if the type has kind `TYPE r` for
-a metavariable `r` which has not yet been filled in.)
-
-We give here an overview of the various moving parts, to serve
-as a central point of reference for this topic.
-
-  * Representation polymorphism
-    Note [Representation polymorphism invariants] in GHC.Core
-    Note [Representation polymorphism checking]
-
-    The first note explains why we require that certain types have
-    a fixed runtime representation.
-
-    The second note details why we sometimes need a constraint to
-    perform such checks in the typechecker: we might not know immediately
-    whether a type has a fixed runtime representation. For example, we might
-    need further unification to take place before being able to decide.
-    So, instead of checking immediately, we emit a constraint.
-
-  * What does it mean for a type to be concrete?
-    Note [Concrete types] explains what it means for a type to be concrete.
-
-    To compute which representation to use for a type, `typePrimRep` expects
-    its kind to be concrete: something specific like `BoxedRep Lifted` or
-    `IntRep`; certainly not a type involving type variables or type families.
-
-  * What constraints do we emit?
-    Note [The Concrete mechanism]
-
-    Instead of simply checking that a type `ty` is concrete (i.e. computing
-    'isConcrete`), we emit an equality constraint:
-
-       co :: ty ~# concrete_ty
-
-    where 'concrete_ty' is a concrete metavariable: a metavariable whose 'MetaInfo'
-    is 'ConcreteTv', signifying that it can only be unified with a concrete type.
-
-    The Note explains that this allows us to accept more programs. The Note
-    also explains that the implementation is happening in two phases
-    (PHASE 1 and PHASE 2).
-    In PHASE 1 (the current implementation) we only allow trivial evidence
-    of the form `co = Refl`.
-
-  * Fixed runtime representation vs fixed RuntimeRep
-    Note [Fixed RuntimeRep]
-
-    We currently enforce the representation-polymorphism invariants by checking
-    that binders and function arguments have a "fixed RuntimeRep".
-
-    This is slightly less general than we might like, as this rules out
-    types with kind `TYPE (BoxedRep l)`: we know that this will be represented
-    by a pointer, which should be enough to go on in many situations.
-
-  * When do we emit these constraints?
-    Note [hasFixedRuntimeRep]
-
-    We introduce constraints to satisfy the representation-polymorphism
-    invariants outlined in Note [Representation polymorphism invariants] in GHC.Core,
-    which mostly amounts to the following two cases:
-
-      - checking that a binder has a fixed runtime representation,
-      - checking that a function argument has a fixed runtime representation.
-
-    The Note explains precisely how and where these constraints are emitted.
-
-  * Reporting unsolved constraints
-    Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin
-
-    When we emit a constraint to enforce a fixed representation, we also provide
-    a 'FixedRuntimeRepOrigin' which gives context about the check being done.
-    This origin gets reported to the user if we end up with such an an unsolved Wanted constraint.
-
-Note [Representation polymorphism checking]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-According to the "Levity Polymorphism" paper (PLDI '17),
-there are two places in which we must know that a type has a
-fixed runtime representation, as explained in
-  Note [Representation polymorphism invariants] in GHC.Core:
-
-  I1. the type of a bound term-level variable,
-  I2. the type of an argument to a function.
-
-The paper explains the restrictions more fully, but briefly:
-expressions in these contexts need to be stored in registers, and it's
-hard (read: impossible) to store something that does not have a
-fixed runtime representation.
-
-In practice, we enforce these types to have a /fixed RuntimeRep/, which is slightly
-stronger, as explained in Note [Fixed RuntimeRep].
-
-There are two different ways we check whether a given type
-has a fixed runtime representation, both in the typechecker:
-
-  1. When typechecking type declarations (e.g. datatypes, typeclass, pattern synonyms),
-     under the GHC.Tc.TyCl module hierarchy.
-     In these situations, we can immediately reject bad representation polymorphism.
-
-     For instance, the following datatype declaration
-
-       data Foo (r :: RuntimeRep) (a :: TYPE r) = Foo a
-
-     is rejected in GHC.Tc.TyCl.checkValidDataCon upon seeing that the type 'a'
-     is representation-polymorphic.
-
-     Such checks are done using `GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep`,
-     with `GHC.Tc.Errors.Types.FixedRuntimeRepProvenance` describing the different
-     contexts in which bad representation polymorphism can occur while validity checking.
-
-  2. When typechecking value-level declarations (functions, expressions, patterns, ...),
-     under the GHC.Tc.Gen module hierarchy.
-     In these situations, the typechecker might need to do some work to figure out
-     whether a type has a fixed runtime representation or not. For instance,
-     GHC might introduce a metavariable (rr :: RuntimeRep), which is only later
-     (through constraint solving) discovered to be equal to FloatRep.
-
-     This is handled by the Concrete mechanism outlined in
-     Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete.
-     See Note [Concrete overview] in GHC.Tc.Utils.Concrete for an overview
-     of the various moving parts.
-
-Note [Concrete types]
-~~~~~~~~~~~~~~~~~~~~~
-Definition: a type is /concrete/ iff it is:
-            - a concrete type constructor (as defined below), or
-            - a concrete type variable (see Note [ConcreteTv] below), or
-            - an application of a concrete type to another concrete type
-GHC.Core.Type.isConcrete checks whether a type meets this definition.
-
-Definition: a /concrete type constructor/ is defined by
-            - a promoted data constructor
-            - a class, data type or newtype
-            - a primitive type like Array# or Int#
-            - an abstract type as defined in a Backpack signature file
-              (see Note [Synonyms implement abstract data] in GHC.Tc.Module)
-            In particular, type and data families are not concrete.
-GHC.Core.TyCon.isConcreteTyCon checks whether a TyCon meets this definition.
-
-Examples of concrete types:
-   Lifted, BoxedRep Lifted, TYPE (BoxedRep Lifted) are all concrete
-Examples of non-concrete types
-   F Int, TYPE (F Int), TYPE r, a[sk]
-   NB: (F Int) is not concrete because F is a type function
-
-The recursive definition of concreteness entails the following property:
-
-Concrete Congruence Property (CCP)
-  All sub-trees of a concrete type tree are concrete.
-
-The following property also holds due to the invariant that the kind of a
-concrete metavariable is itself concrete (see Note [ConcreteTv]):
-
-Concrete Kinds Property (CKP)
-  The kind of a concrete type is concrete.
-
-Note [ConcreteTv]
-~~~~~~~~~~~~~~~~~
-A concrete metavariable is a metavariable whose 'MetaInfo' is 'ConcreteTv'.
-Similar to 'TyVarTv's which are type variables which can only be unified with
-other type variables, a 'ConcreteTv' type variable is a type variable which can
-only be unified with a concrete type (in the sense of Note [Concrete types]).
-
-INVARIANT: the kind of a concrete metavariable is concrete.
-
-This invariant is upheld at the time of creation of a new concrete metavariable.
-
-Concrete metavariables are useful for representation-polymorphism checks:
-they allow us to refer to a type whose representation is not yet known but will
-be figured out by the typechecker (see Note [The Concrete mechanism]).
-
-Note [The Concrete mechanism]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-To check (ty :: ki) has a fixed runtime representation, we proceed as follows:
-
-  - Create a new concrete metavariable `concrete_tv`, i.e. a metavariable
-    with 'ConcreteTv' 'MetaInfo' (see Note [ConcreteTv]).
-
-  - Emit an equality constraint:
-
-      ki ~# concrete_tv
-
-    The origin for such an equality constraint uses
-    `GHC.Tc.Types.Origin.FixedRuntimeRepOrigin`, so that we can report the
-    appropriate representation-polymorphism error if any such constraint
-    goes unsolved.
-
-To solve `ki ~# concrete_ki`, we must unify `concrete_tv := concrete_ki`,
-where `concrete_ki` is some concrete type. We can then compute `kindPrimRep`
-on `concrete_ki` to compute the representation: this means `ty` indeed
-has a fixed runtime representation.
-
--------------------------
--- PHASE 1 and PHASE 2 --
--------------------------
-
-The Concrete mechanism is being implemented in two separate phases.
-
-In PHASE 1, we enforce that we only solve the emitted constraints
-`co :: ki ~# concrete_tv` with `Refl`. This forbids any program
-which requires type family evaluation in order to determine that a 'RuntimeRep'
-is fixed.
-To achieve this, instead of creating a new concrete metavariable, we directly
-ensure that 'ki' is concrete, using 'makeTypeConcrete'. If it fails, then
-we report an error (even though rewriting might have allowed us to proceed).
-
-In PHASE 2, we lift this restriction. This means we replace a call to
-`hasFixedRuntimeRep_syntactic` with a call to `hasFixedRuntimeRep`, and insert the
-obtained coercion in the typechecked result. To illustrate what this entails,
-recall that the code generator needs to be able to compute 'PrimRep's, so that it
-can put function arguments in the correct registers, etc.
-As a result, we must insert additional casts in Core to ensure that no type family
-reduction is needed to be able to compute 'PrimRep's. For example, the Core
-
-  f = /\ ( a :: F Int ). \ ( x :: a ). some_expression
-
-is problematic when 'F' is a type family: we don't know what runtime representation to use
-for 'x', so we can't compile this function (we can't evaluate type family applications
-after we are done with typechecking). Instead, we ensure the 'RuntimeRep' is always
-explicitly visible:
-
-  f = /\ ( a :: F Int ). \ ( x :: ( a |> kco ) ). some_expression
-
-where 'kco' is the appropriate coercion; for example if `F Int = TYPE Int#`
-this would be:
-
-  kco :: F Int ~# TYPE Int#
-
-As `( a |> kco ) :: TYPE Int#`, the code generator knows to use a machine-sized
-integer register for `x`, and all is good again.
-
-Because we can convert calls from hasFixedRuntimeRep_syntactic to
-hasFixedRuntimeRep one at a time, we can migrate from PHASE 1 to PHASE 2
-incrementally.
-
-Example test cases that require PHASE 2: T13105, T17021, T20363b.
-
-Note [Fixed RuntimeRep]
-~~~~~~~~~~~~~~~~~~~~~~~
-Definitions:
-
-  FRR.
-
-    The type `ty :: ki` has a /syntactically fixed RuntimeRep/
-    (we also say that `ty` is an `FRRType`)
-      <=>
-    the kind `ki` is concrete (in the sense of Note [Concrete types])
-      <=>
-    `typePrimRep ty` (= `kindPrimRep ki`) does not crash
-    (assuming that typechecking succeeded, so that all metavariables
-    in `ty` have been filled)
-
-  Fixed RuntimeRep.
-
-    The type `ty :: ki` has a /fixed RuntimeRep/
-      <=>
-    there exists an FRR type `ty'` with `ty ~# ty'`
-      <=>
-    there exists a concrete type `concrete_ki` such that
-    `ki ~ concrete_ki`
-
-These definitions are crafted to be useful to satisfy the invariants of
-Core; see Note [Representation polymorphism invariants] in GHC.Core.
-
-Notice that "fixed RuntimeRep" means (for now anyway) that
-  * we know the runtime representation, and
-  * we know the levity.
-
-For example (ty :: TYPE (BoxedRep l)), where `l` is a levity variable
-is /not/ "fixed RuntimeRep", even though it is always represented by
-a heap pointer, because we don't know the levity.  In due course we
-will want to make finer distinctions, as explained in the paper
-Kinds are Calling Conventions [ICFP'20], but this suffices for now.
-
-Note [hasFixedRuntimeRep]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-The 'hasFixedRuntimeRep' function is responsible for taking a type 'ty'
-and emitting a constraint to ensure that 'ty' has a fixed `RuntimeRep`,
-as outlined in Note [The Concrete mechanism].
-
-To do so, we compute the kind 'ki' of 'ty', create a new concrete metavariable
-`concrete_tv` of kind `ki`, and emit a constraint `ki ~# concrete_tv`,
-which will only be solved if we can prove that 'ty' indeed has a fixed RuntimeRep.
-
-If we can solve the equality constraint, i.e. produce a coercion
-`kco :: ki ~# concrete_tv`, then 'hasFixedRuntimeRep' returns the coercion
-
-  co = GRefl ty kco :: ty ~# ty |> kco
-
-The RHS of the coercion `co` is `ty |> kco`. The kind of this type is
-concrete (by construction), which means that `ty |> kco` is an FRRType
-in the sense of Note [Fixed RuntimeRep], so that we can directely compute
-its runtime representation using `typePrimRep`.
-
-  [Wrinkle: Typed Template Haskell]
-    We don't perform any checks when type-checking a typed Template Haskell quote:
-    we want to allow representation polymorphic quotes, as long as they are
-    monomorphised at splice site.
-
-    Example:
-
-      Module1
-
-        repPolyId :: forall r (a :: TYPE r). CodeQ (a -> a)
-        repPolyId = [|| \ x -> x ||]
-
-      Module2
-
-        import Module1
-
-        id1 :: Int -> Int
-        id1 = $$repPolyId
-
-        id2 :: Int# -> Int#
-        id2 = $$repPolyId
-
-    We implement this skip by inspecting the TH stage in `hasFixedRuntimeRep`.
-
-    A better solution would be to use 'CodeC' constraints, as in the paper
-      "Staging With Class", POPL 2022
-        by Ningning Xie, Matthew Pickering, Andres Löh, Nicolas Wu, Jeremy Yallop, Meng Wang
-    but for the moment, as we will typecheck again when splicing,
-    this shouldn't cause any problems in practice.  See ticket #18170.
-
-    Test case: rep-poly/T18170a.
--}
-
--- | Given a type @ty :: ki@, this function ensures that @ty@
--- has a __fixed__ 'RuntimeRep', by emitting a new equality constraint
--- @ki ~ concrete_tv@ for a concrete metavariable @concrete_tv@.
---
--- Returns a coercion @co :: ty ~# concrete_ty@ as evidence.
--- If @ty@ obviously has a fixed 'RuntimeRep', e.g @ki = IntRep@,
--- then this function immediately returns 'MRefl',
--- without emitting any constraints.
-hasFixedRuntimeRep :: HasDebugCallStack
-                   => FixedRuntimeRepContext
-                        -- ^ Context to be reported to the user
-                        -- if the type ends up not having a fixed
-                        -- 'RuntimeRep'.
-                   -> TcType
-                        -- ^ The type to check (we only look at its kind).
-                   -> TcM (TcCoercionN, TcTypeFRR)
-                        -- ^ @(co, ty')@ where @ty' :: ki'@,
-                        -- @ki@ is concrete, and @co :: ty ~# ty'@.
-                        -- That is, @ty'@ has a syntactically fixed RuntimeRep
-                        -- in the sense of Note [Fixed RuntimeRep].
-hasFixedRuntimeRep frr_ctxt ty = checkFRR_with unifyConcrete frr_ctxt ty
-
--- | Like 'hasFixedRuntimeRep', but we perform an eager syntactic check.
---
--- Throws an error in the 'TcM' monad if the check fails.
---
--- This is useful if we are not actually going to use the coercion returned
--- from 'hasFixedRuntimeRep'; it would generally be unsound to allow a non-reflexive
--- coercion but not actually make use of it in a cast.
---
--- The goal is to eliminate all uses of this function and replace them with
--- 'hasFixedRuntimeRep', making use of the returned coercion. This is what
--- is meant by going from PHASE 1 to PHASE 2, in Note [The Concrete mechanism].
-hasFixedRuntimeRep_syntactic :: HasDebugCallStack
-                             => FixedRuntimeRepContext
-                                  -- ^ Context to be reported to the user
-                                  -- if the type does not have a syntactically
-                                  -- fixed 'RuntimeRep'.
-                             -> TcType
-                                  -- ^ The type to check (we only look at its kind).
-                             -> TcM ()
-hasFixedRuntimeRep_syntactic frr_ctxt ty
-  = void $ checkFRR_with ensure_conc frr_ctxt ty
-    where
-      ensure_conc :: FixedRuntimeRepOrigin -> TcKind -> TcM TcMCoercionN
-      ensure_conc frr_orig ki = ensureConcrete frr_orig ki $> MRefl
-
--- | Internal function to check whether the given type has a fixed 'RuntimeRep'.
---
--- Use 'hasFixedRuntimeRep' to allow rewriting, or 'hasFixedRuntimeRep_syntactic'
--- to perform a syntactic check.
-checkFRR_with :: HasDebugCallStack
-              => (FixedRuntimeRepOrigin -> TcKind -> TcM TcMCoercionN)
-                   -- ^ The check to perform on the kind.
-              -> FixedRuntimeRepContext
-                   -- ^ The context which required a fixed 'RuntimeRep',
-                   -- e.g. an application, a lambda abstraction, ...
-              -> TcType
-                   -- ^ The type @ty@ to check (the check itself only looks at its kind).
-              -> TcM (TcCoercionN, TcTypeFRR)
-                  -- ^ Returns @(co, frr_ty)@ with @co :: ty ~# frr_ty@
-                  -- and @frr_@ty has a fixed 'RuntimeRep'.
-checkFRR_with check_kind frr_ctxt ty
-  = do { th_stage <- getStage
-       ; if
-          -- Shortcut: check for 'Type' and 'UnliftedType' type synonyms.
-          | TyConApp tc [] <- ki
-          , tc == liftedTypeKindTyCon || tc == unliftedTypeKindTyCon
-          -> return refl
-
-          -- See [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep].
-          | Brack _ (TcPending {}) <- th_stage
-          -> return refl
-
-          -- Otherwise: ensure that the kind 'ki' of 'ty' is concrete.
-          | otherwise
-          -> do { kco <- check_kind frr_orig ki
-                ; return ( mkGReflRightMCo Nominal ty kco
-                         , mkCastTyMCo ty kco ) } }
-
-  where
-    refl :: (TcCoercionN, TcType)
-    refl = (mkNomReflCo ty, ty)
-    ki :: TcKind
-    ki = typeKind ty
-    frr_orig :: FixedRuntimeRepOrigin
-    frr_orig = FixedRuntimeRepOrigin { frr_type = ty, frr_context = frr_ctxt }
-
--- | Ensure that the given type @ty@ can unify with a concrete type,
--- in the sense of Note [Concrete types].
---
--- Returns a coercion @co :: ty ~# conc_ty@, where @conc_ty@ is
--- concrete.
---
--- If the type is already syntactically concrete, this
--- immediately returns a reflexive coercion. Otherwise,
--- it creates a new concrete metavariable @concrete_tv@
--- and emits an equality constraint @ty ~# concrete_tv@,
--- to be handled by the constraint solver.
---
--- Invariant: the kind of the supplied type must be concrete.
---
--- We assume the provided type is already at the kind-level
--- (this only matters for error messages).
-unifyConcrete :: HasDebugCallStack
-              => FixedRuntimeRepOrigin -> TcType -> TcM TcMCoercionN
-unifyConcrete frr_orig ty
-  = do { (ty, errs) <- makeTypeConcrete (ConcreteFRR frr_orig) ty
-       ; case errs of
-           -- We were able to make the type fully concrete.
-         { [] -> return MRefl
-           -- The type could not be made concrete; perhaps it contains
-           -- a skolem type variable, a type family application, ...
-           --
-           -- Create a new ConcreteTv metavariable @concrete_tv@
-           -- and unify @ty ~# concrete_tv@.
-         ; _  ->
-    do { conc_tv <- newConcreteTyVar (ConcreteFRR frr_orig) ki
-           -- NB: newConcreteTyVar asserts that 'ki' is concrete.
-       ; coToMCo <$> emitWantedEq orig KindLevel Nominal ty (mkTyVarTy conc_tv) } } }
-  where
-    ki :: TcKind
-    ki = typeKind ty
-    orig :: CtOrigin
-    orig = FRROrigin frr_orig
-
--- | Ensure that the given type is concrete.
---
--- This is an eager syntactic check, and never defers
--- any work to the constraint solver.
---
--- Invariant: the kind of the supplied type must be concrete.
--- Invariant: the output type is equal to the input type,
---            up to zonking.
---
--- We assume the provided type is already at the kind-level
--- (this only matters for error messages).
-ensureConcrete :: HasDebugCallStack
-               => FixedRuntimeRepOrigin
-               -> TcType
-               -> TcM TcType
-ensureConcrete frr_orig ty
-  = do { (ty', errs) <- makeTypeConcrete conc_orig ty
-       ; case errs of
-          { err:errs ->
-              do { traceTc "ensureConcrete } failure" $
-                     vcat [ text "ty:" <+> ppr ty
-                          , text "ty':" <+> ppr ty' ]
-                 ; loc <- getCtLocM (FRROrigin frr_orig) (Just KindLevel)
-                 ; emitNotConcreteError $
-                     NCE_FRR
-                       { nce_loc = loc
-                       , nce_frr_origin = frr_orig
-                       , nce_reasons = err :| errs }
-                 }
-          ; [] ->
-              traceTc "ensureConcrete } success" $
-                vcat [ text "ty: " <+> ppr ty
-                     , text "ty':" <+> ppr ty' ] }
-        ; return ty' }
-  where
-    conc_orig :: ConcreteTvOrigin
-    conc_orig = ConcreteFRR frr_orig
-
-{-***********************************************************************
-%*                                                                      *
-                    Making a type concrete
-%*                                                                      *
-%************************************************************************
-
-Note [Unifying concrete metavariables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Unifying concrete metavariables (as defined in Note [ConcreteTv]) is not
-an all-or-nothing affair as it is for other sorts of metavariables.
-
-Consider the following unification problem in which all metavariables
-are unfilled (and ignoring any TcLevel considerations):
-
-  alpha[conc] ~# TYPE (TupleRep '[ beta[conc], IntRep, gamma[tau] ])
-
-We can't immediately unify `alpha` with the RHS, because the RHS is not
-a concrete type (in the sense of Note [Concrete types]). Instead, we
-proceed as follows:
-
-  - create a fresh concrete metavariable variable `gamma'[conc]`,
-  - write gamma[tau] := gamma'[conc],
-  - write alpha[conc] := TYPE (TupleRep '[ beta[conc], IntRep, gamma'[conc] ]).
-
-Thus, in general, to unify `alpha[conc] ~# rhs`, we first try to turn
-`rhs` into a concrete type (see the 'makeTypeConcrete' function).
-If this succeeds, resulting in a concrete type `rhs'`, we simply fill
-`alpha[conc] := rhs'`. If it fails, then syntactic unification fails.
-
-Example 1:
-
-    alpha[conc] ~# TYPE (TupleRep '[ beta[conc], IntRep, gamma[tau] ])
-
-  We proceed by filling metavariables:
-
-    gamma[tau] := gamma[conc]
-    alpha[conc] := TYPE (TupleRep '[ beta[conc], IntRep, gamma[conc] ])
-
-  This successfully unifies alpha.
-
-Example 2:
-
-  For a type family `F :: Type -> Type`:
-
-    delta[conc] ~# TYPE (SumRep '[ zeta[tau], a[sk], F omega[tau] ])
-
-  We write zeta[tau] := zeta[conc], and then fail, providing the following
-  two reasons:
-
-    - `a[sk]` is not a concrete type variable, so the overall type
-      cannot be concrete
-    - `F` is not a concrete type constructor, in the sense of
-       Note [Concrete types]. So we keep it as is; in particular,
-       we /should not/ try to make its argument `omega[tau]` into
-       a ConcreteTv.
-
-  Note that making zeta concrete allows us to propagate information.
-  For example, after more typechecking, we might try to unify
-  `zeta ~# rr[sk]`. If we made zeta a ConcreteTv, we will report
-  this unsolved equality using the 'ConcreteTvOrigin' stored in zeta[conc].
-  This allows us to report ALL the problems in a representation-polymorphism
-  check (instead of only a non-empty subset).
--}
-
--- | Try to turn the provided type into a concrete type, by ensuring
--- unfilled metavariables are appropriately marked as concrete.
---
--- Returns a zonked type which is "as concrete as possible", and
--- a list of problems encountered when trying to make it concrete.
---
--- INVARIANT: the returned type is equal to the input type, up to zonking.
--- INVARIANT: if this function returns an empty list of 'NotConcreteReasons',
--- then the returned type is concrete, in the sense of Note [Concrete types].
-makeTypeConcrete :: ConcreteTvOrigin -> TcType -> TcM (TcType, [NotConcreteReason])
--- TODO: it could be worthwhile to return enough information to continue solving.
--- Consider unifying `alpha[conc] ~# TupleRep '[ beta[tau], F Int ]` for
--- a type family 'F'.
--- This function will concretise `beta[tau] := beta[conc]` and return
--- that `TupleRep '[ beta[conc], F Int ]` is not concrete because of the
--- type family application `F Int`. But we could decompose by setting
--- alpha := TupleRep '[ beta, gamma[conc] ] and emitting `[W] gamma[conc] ~ F Int`.
---
--- This would be useful in startSolvingByUnification.
-makeTypeConcrete conc_orig ty =
-  do { res@(ty', _) <- runWriterT $ go ty
-     ; traceTc "makeTypeConcrete" $
-        vcat [ text "ty:" <+> ppr ty
-             , text "ty':" <+> ppr ty' ]
-     ; return res }
-  where
-    go :: TcType -> WriterT [NotConcreteReason] TcM TcType
-    go ty
-      | Just ty <- coreView ty
-      = go ty
-      | isConcrete ty
-      = pure ty
-    go ty@(TyVarTy tv) -- not a ConcreteTv (already handled above)
-      = do { mb_filled <- lift $ isFilledMetaTyVar_maybe tv
-           ; case mb_filled of
-           { Just ty -> go ty
-           ; Nothing
-               | isMetaTyVar tv
-               , TauTv <- metaTyVarInfo tv
-               -> -- Change the MetaInfo to ConcreteTv, but retain the TcLevel
-               do { kind <- go (tyVarKind tv)
-                  ; lift $
-                    do { conc_tv <- setTcLevel (tcTyVarLevel tv) $
-                                    newConcreteTyVar conc_orig kind
-                       ; let conc_ty = mkTyVarTy conc_tv
-                       ; writeMetaTyVar tv conc_ty
-                       ; return conc_ty } }
-               | otherwise
-               -- Don't attempt to make other type variables concrete
-               -- (e.g. SkolemTv, TyVarTv, CycleBreakerTv, RuntimeUnkTv).
-               -> bale_out ty (NonConcretisableTyVar tv) } }
-    go ty@(TyConApp tc tys)
-      | isConcreteTyCon tc
-      = mkTyConApp tc <$> mapM go tys
-      | otherwise
-      = bale_out ty (NonConcreteTyCon tc tys)
-    go (FunTy af w ty1 ty2)
-      = do { w <- go w
-           ; ty1 <- go ty1
-           ; ty2 <- go ty2
-           ; return $ mkFunTy af w ty1 ty2 }
-    go (AppTy ty1 ty2)
-      = do { ty1 <- go ty1
-           ; ty2 <- go ty2
-           ; return $ mkAppTy ty1 ty2 }
-    go ty@(LitTy {})
-      = return ty
-    go ty@(CastTy cast_ty kco)
-      = bale_out ty (ContainsCast cast_ty kco)
-    go ty@(ForAllTy tcv body)
-      = bale_out ty (ContainsForall tcv body)
-    go ty@(CoercionTy co)
-      = bale_out ty (ContainsCoercionTy co)
-
-    bale_out :: TcType -> NotConcreteReason -> WriterT [NotConcreteReason] TcM TcType
-    bale_out ty reason = do { tell [reason]; return ty }
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ /dev/null
@@ -1,1209 +0,0 @@
--- (c) The University of Glasgow 2006
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an
-                                       -- orphan
-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-                                      -- in module Language.Haskell.Syntax.Extension
-{-# LANGUAGE TypeFamilies #-}
-
-module GHC.Tc.Utils.Env(
-        TyThing(..), TcTyThing(..), TcId,
-
-        -- Instance environment, and InstInfo type
-        InstInfo(..), iDFunId, pprInstInfoDetails,
-        simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
-        InstBindings(..),
-
-        -- Global environment
-        tcExtendGlobalEnv, tcExtendTyConEnv,
-        tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
-        tcExtendGlobalValEnv, tcTyThBinders,
-        tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,
-        tcLookupTyCon, tcLookupClass,
-        tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
-        tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
-        tcLookupLocatedClass, tcLookupAxiom,
-        lookupGlobal, lookupGlobal_maybe, ioLookupDataCon,
-        addTypecheckedBinds,
-
-        -- Local environment
-        tcExtendKindEnv, tcExtendKindEnvList,
-        tcExtendTyVarEnv, tcExtendNameTyVarEnv,
-        tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,
-        tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
-        tcExtendBinderStack, tcExtendLocalTypeEnv,
-        isTypeClosedLetBndr,
-        tcCheckUsage,
-
-        tcLookup, tcLookupLocated, tcLookupLocalIds,
-        tcLookupId, tcLookupIdMaybe, tcLookupTyVar,
-        tcLookupTcTyCon,
-        tcLookupLcl_maybe,
-        getInLocalScope,
-        wrongThingErr, pprBinders,
-
-        tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,
-        getTypeSigNames,
-        tcExtendRecEnv,         -- For knot-tying
-
-        -- Tidying
-        tcInitTidyEnv, tcInitOpenTidyEnv,
-
-        -- Instances
-        tcLookupInstance, tcGetInstEnvs,
-
-        -- Rules
-        tcExtendRules,
-
-        -- Defaults
-        tcGetDefaultTys,
-
-        -- Template Haskell stuff
-        checkWellStaged, tcMetaTy, thLevel,
-        topIdLvl, isBrackStage,
-
-        -- New Ids
-        newDFunName,
-        newFamInstTyConName, newFamInstAxiomName,
-        mkStableIdFromString, mkStableIdFromName,
-        mkWrapperName
-  ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Env
-import GHC.Driver.Session
-
-import GHC.Builtin.Names
-import GHC.Builtin.Types
-
-import GHC.Runtime.Context
-
-import GHC.Hs
-
-import GHC.Iface.Env
-import GHC.Iface.Load
-
-import GHC.Tc.Errors.Types
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Types.Evidence (HsWrapper, idHsWrapper)
-import {-# SOURCE #-} GHC.Tc.Utils.Unify ( tcSubMult )
-import GHC.Tc.Types.Origin ( CtOrigin(UsageEnvironmentOf) )
-
-import GHC.Core.UsageEnv
-import GHC.Core.InstEnv
-import GHC.Core.DataCon ( DataCon, flSelector )
-import GHC.Core.PatSyn  ( PatSyn )
-import GHC.Core.ConLike
-import GHC.Core.TyCon
-import GHC.Core.Type
-import GHC.Core.Coercion.Axiom
-import GHC.Core.Class
-
-import GHC.Unit.Module
-import GHC.Unit.Home
-import GHC.Unit.External
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Encoding
-import GHC.Utils.Misc ( HasDebugCallStack )
-
-import GHC.Data.FastString
-import GHC.Data.Bag
-import GHC.Data.List.SetOps
-import GHC.Data.Maybe( MaybeErr(..), orElse )
-
-import GHC.Types.SrcLoc
-import GHC.Types.Basic hiding( SuccessFlag(..) )
-import GHC.Types.TypeEnv
-import GHC.Types.SourceFile
-import GHC.Types.Name
-import GHC.Types.Name.Set
-import GHC.Types.Name.Env
-import GHC.Types.Id
-import GHC.Types.Var
-import GHC.Types.Var.Env
-import GHC.Types.Name.Reader
-import GHC.Types.TyThing
-import GHC.Types.Error
-import qualified GHC.LanguageExtensions as LangExt
-
-import Data.IORef
-import Data.List (intercalate)
-import Control.Monad
-import GHC.Driver.Env.KnotVars
-
-{- *********************************************************************
-*                                                                      *
-            An IO interface to looking up globals
-*                                                                      *
-********************************************************************* -}
-
-lookupGlobal :: HscEnv -> Name -> IO TyThing
--- A variant of lookupGlobal_maybe for the clients which are not
--- interested in recovering from lookup failure and accept panic.
-lookupGlobal hsc_env name
-  = do  {
-          mb_thing <- lookupGlobal_maybe hsc_env name
-        ; case mb_thing of
-            Succeeded thing -> return thing
-            Failed msg      -> pprPanic "lookupGlobal" msg
-        }
-
-lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
--- This may look up an Id that one has previously looked up.
--- If so, we are going to read its interface file, and add its bindings
--- to the ExternalPackageTable.
-lookupGlobal_maybe hsc_env name
-  = do  {    -- Try local envt
-          let mod = icInteractiveModule (hsc_IC hsc_env)
-              mhome_unit = hsc_home_unit_maybe hsc_env
-              tcg_semantic_mod = homeModuleInstantiation mhome_unit mod
-
-        ; if nameIsLocalOrFrom tcg_semantic_mod name
-              then (return
-                (Failed (text "Can't find local name: " <+> ppr name)))
-                  -- Internal names can happen in GHCi
-              else
-           -- Try home package table and external package table
-          lookupImported_maybe hsc_env name
-        }
-
-lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
--- Returns (Failed err) if we can't find the interface file for the thing
-lookupImported_maybe hsc_env name
-  = do  { mb_thing <- lookupType hsc_env name
-        ; case mb_thing of
-            Just thing -> return (Succeeded thing)
-            Nothing    -> importDecl_maybe hsc_env name
-            }
-
-importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
-importDecl_maybe hsc_env name
-  | Just thing <- wiredInNameTyThing_maybe name
-  = do  { when (needWiredInHomeIface thing)
-               (initIfaceLoad hsc_env (loadWiredInHomeIface name))
-                -- See Note [Loading instances for wired-in things]
-        ; return (Succeeded thing) }
-  | otherwise
-  = initIfaceLoad hsc_env (importDecl name)
-
-ioLookupDataCon :: HscEnv -> Name -> IO DataCon
-ioLookupDataCon hsc_env name = do
-  mb_thing <- ioLookupDataCon_maybe hsc_env name
-  case mb_thing of
-    Succeeded thing -> return thing
-    Failed msg      -> pprPanic "lookupDataConIO" msg
-
-ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc DataCon)
-ioLookupDataCon_maybe hsc_env name = do
-    thing <- lookupGlobal hsc_env name
-    return $ case thing of
-        AConLike (RealDataCon con) -> Succeeded con
-        _                          -> Failed $
-          pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+>
-                text "used as a data constructor"
-
-addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
-addTypecheckedBinds tcg_env binds
-  | isHsBootOrSig (tcg_src tcg_env) = tcg_env
-    -- Do not add the code for record-selector bindings
-    -- when compiling hs-boot files
-  | otherwise = tcg_env { tcg_binds = foldr unionBags
-                                            (tcg_binds tcg_env)
-                                            binds }
-
-{-
-************************************************************************
-*                                                                      *
-*                      tcLookupGlobal                                  *
-*                                                                      *
-************************************************************************
-
-Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
-unless you know that the SrcSpan in the monad is already set to the
-span of the Name.
--}
-
-
-tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing
--- c.f. GHC.IfaceToCore.tcIfaceGlobal
-tcLookupLocatedGlobal name
-  = addLocMA tcLookupGlobal name
-
-tcLookupGlobal :: Name -> TcM TyThing
--- The Name is almost always an ExternalName, but not always
--- In GHCi, we may make command-line bindings (ghci> let x = True)
--- that bind a GlobalId, but with an InternalName
-tcLookupGlobal name
-  = do  {    -- Try local envt
-          env <- getGblEnv
-        ; case lookupNameEnv (tcg_type_env env) name of {
-                Just thing -> return thing ;
-                Nothing    ->
-
-                -- Should it have been in the local envt?
-                -- (NB: use semantic mod here, since names never use
-                -- identity module, see Note [Identity versus semantic module].)
-          if nameIsLocalOrFrom (tcg_semantic_mod env) name
-          then notFound name  -- Internal names can happen in GHCi
-          else
-
-           -- Try home package table and external package table
-    do  { mb_thing <- tcLookupImported_maybe name
-        ; case mb_thing of
-            Succeeded thing -> return thing
-            Failed msg      -> failWithTc (TcRnInterfaceLookupError name msg)
-        }}}
-
--- Look up only in this module's global env't. Don't look in imports, etc.
--- Panic if it's not there.
-tcLookupGlobalOnly :: Name -> TcM TyThing
-tcLookupGlobalOnly name
-  = do { env <- getGblEnv
-       ; return $ case lookupNameEnv (tcg_type_env env) name of
-                    Just thing -> thing
-                    Nothing    -> pprPanic "tcLookupGlobalOnly" (ppr name) }
-
-tcLookupDataCon :: Name -> TcM DataCon
-tcLookupDataCon name = do
-    thing <- tcLookupGlobal name
-    case thing of
-        AConLike (RealDataCon con) -> return con
-        _                          -> wrongThingErr "data constructor" (AGlobal thing) name
-
-tcLookupPatSyn :: Name -> TcM PatSyn
-tcLookupPatSyn name = do
-    thing <- tcLookupGlobal name
-    case thing of
-        AConLike (PatSynCon ps) -> return ps
-        _                       -> wrongThingErr "pattern synonym" (AGlobal thing) name
-
-tcLookupConLike :: Name -> TcM ConLike
-tcLookupConLike name = do
-    thing <- tcLookupGlobal name
-    case thing of
-        AConLike cl -> return cl
-        _           -> wrongThingErr "constructor-like thing" (AGlobal thing) name
-
-tcLookupClass :: Name -> TcM Class
-tcLookupClass name = do
-    thing <- tcLookupGlobal name
-    case thing of
-        ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls
-        _                                           -> wrongThingErr "class" (AGlobal thing) name
-
-tcLookupTyCon :: Name -> TcM TyCon
-tcLookupTyCon name = do
-    thing <- tcLookupGlobal name
-    case thing of
-        ATyCon tc -> return tc
-        _         -> wrongThingErr "type constructor" (AGlobal thing) name
-
-tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
-tcLookupAxiom name = do
-    thing <- tcLookupGlobal name
-    case thing of
-        ACoAxiom ax -> return ax
-        _           -> wrongThingErr "axiom" (AGlobal thing) name
-
-tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id
-tcLookupLocatedGlobalId = addLocMA tcLookupId
-
-tcLookupLocatedClass :: LocatedA Name -> TcM Class
-tcLookupLocatedClass = addLocMA tcLookupClass
-
-tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon
-tcLookupLocatedTyCon = addLocMA tcLookupTyCon
-
--- Find the instance that exactly matches a type class application.  The class arguments must be precisely
--- the same as in the instance declaration (modulo renaming & casts).
---
-tcLookupInstance :: Class -> [Type] -> TcM ClsInst
-tcLookupInstance cls tys
-  = do { instEnv <- tcGetInstEnvs
-       ; case lookupUniqueInstEnv instEnv cls tys of
-           Left err             ->
-             failWithTc $ mkTcRnUnknownMessage
-                        $ mkPlainError noHints (text "Couldn't match instance:" <+> err)
-           Right (inst, tys)
-             | uniqueTyVars tys -> return inst
-             | otherwise        -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints errNotExact)
-       }
-  where
-    errNotExact = text "Not an exact match (i.e., some variables get instantiated)"
-
-    uniqueTyVars tys = all isTyVarTy tys
-                    && hasNoDups (map getTyVar tys)
-
-tcGetInstEnvs :: TcM InstEnvs
--- Gets both the external-package inst-env
--- and the home-pkg inst env (includes module being compiled)
-tcGetInstEnvs = do { eps <- getEps
-                   ; env <- getGblEnv
-                   ; return (InstEnvs { ie_global  = eps_inst_env eps
-                                      , ie_local   = tcg_inst_env env
-                                      , ie_visible = tcVisibleOrphanMods env }) }
-
-instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
-    lookupThing = tcLookupGlobal
-
-{-
-************************************************************************
-*                                                                      *
-                Extending the global environment
-*                                                                      *
-************************************************************************
--}
-
-setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
--- Use this to update the global type env
--- It updates both  * the normal tcg_type_env field
---                  * the tcg_type_env_var field seen by interface files
-setGlobalTypeEnv tcg_env new_type_env
-  = do  {     -- Sync the type-envt variable seen by interface files
-         ; case lookupKnotVars (tcg_type_env_var tcg_env) (tcg_mod tcg_env) of
-              Just tcg_env_var -> writeMutVar tcg_env_var new_type_env
-              Nothing -> return ()
-         ; return (tcg_env { tcg_type_env = new_type_env }) }
-
-
-tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
-  -- Just extend the global environment with some TyThings
-  -- Do not extend tcg_tcs, tcg_patsyns etc
-tcExtendGlobalEnvImplicit things thing_inside
-   = do { tcg_env <- getGblEnv
-        ; let ge'  = extendTypeEnvList (tcg_type_env tcg_env) things
-        ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
-        ; setGblEnv tcg_env' thing_inside }
-
-tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
-  -- Given a mixture of Ids, TyCons, Classes, all defined in the
-  -- module being compiled, extend the global environment
-tcExtendGlobalEnv things thing_inside
-  = do { env <- getGblEnv
-       ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env,
-                          tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env }
-       ; setGblEnv env' $
-            tcExtendGlobalEnvImplicit things thing_inside
-       }
-
-tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r
-  -- Given a mixture of Ids, TyCons, Classes, all defined in the
-  -- module being compiled, extend the global environment
-tcExtendTyConEnv tycons thing_inside
-  = do { env <- getGblEnv
-       ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env }
-       ; setGblEnv env' $
-         tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside
-       }
-
--- Given a [TyThing] of "non-value" bindings coming from type decls
--- (constructors, field selectors, class methods) return their
--- TH binding levels (to be added to a LclEnv).
--- See GHC ticket #17820 .
-tcTyThBinders :: [TyThing] -> TcM ThBindEnv
-tcTyThBinders implicit_things = do
-  stage <- getStage
-  let th_lvl  = thLevel stage
-      th_bndrs = mkNameEnv
-                  [ ( n , (TopLevel, th_lvl) ) | n <- names ]
-  return th_bndrs
-  where
-    names = concatMap get_names implicit_things
-    get_names (AConLike acl) =
-      conLikeName acl : map flSelector (conLikeFieldLabels acl)
-    get_names (AnId i) = [idName i]
-    get_names _ = []
-
-tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
-  -- Same deal as tcExtendGlobalEnv, but for Ids
-tcExtendGlobalValEnv ids thing_inside
-  = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside
-
-tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
--- Extend the global environments for the type/class knot tying game
--- Just like tcExtendGlobalEnv, except the argument is a list of pairs
-tcExtendRecEnv gbl_stuff thing_inside
- = do  { tcg_env <- getGblEnv
-       ; let ge'      = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff
-             tcg_env' = tcg_env { tcg_type_env = ge' }
-         -- No need for setGlobalTypeEnv (which side-effects the
-         -- tcg_type_env_var); tcExtendRecEnv is used just
-         -- when kind-check a group of type/class decls. It would
-         -- in any case be wrong for an interface-file decl to end up
-         -- with a TcTyCon in it!
-       ; setGblEnv tcg_env' thing_inside }
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{The local environment}
-*                                                                      *
-************************************************************************
--}
-
-tcLookupLocated :: LocatedA Name -> TcM TcTyThing
-tcLookupLocated = addLocMA tcLookup
-
-tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
-tcLookupLcl_maybe name
-  = do { local_env <- getLclTypeEnv
-       ; return (lookupNameEnv local_env name) }
-
-tcLookup :: Name -> TcM TcTyThing
-tcLookup name = do
-    local_env <- getLclTypeEnv
-    case lookupNameEnv local_env name of
-        Just thing -> return thing
-        Nothing    -> (AGlobal <$> tcLookupGlobal name)
-
-tcLookupTyVar :: Name -> TcM TcTyVar
-tcLookupTyVar name
-  = do { thing <- tcLookup name
-       ; case thing of
-           ATyVar _ tv -> return tv
-           _           -> pprPanic "tcLookupTyVar" (ppr name) }
-
-tcLookupId :: Name -> TcM Id
--- Used when we aren't interested in the binding level, nor refinement.
--- The "no refinement" part means that we return the un-refined Id regardless
---
--- The Id is never a DataCon. (Why does that matter? see GHC.Tc.Gen.Expr.tcId)
-tcLookupId name = do
-    thing <- tcLookupIdMaybe name
-    case thing of
-        Just id -> return id
-        _       -> pprPanic "tcLookupId" (ppr name)
-
-tcLookupIdMaybe :: Name -> TcM (Maybe Id)
-tcLookupIdMaybe name
-  = do { thing <- tcLookup name
-       ; case thing of
-           ATcId { tct_id = id} -> return $ Just id
-           AGlobal (AnId id)    -> return $ Just id
-           _                    -> return Nothing }
-
-tcLookupLocalIds :: [Name] -> TcM [TcId]
--- We expect the variables to all be bound, and all at
--- the same level as the lookup.  Only used in one place...
-tcLookupLocalIds ns
-  = do { env <- getLclEnv
-       ; return (map (lookup (tcl_env env)) ns) }
-  where
-    lookup lenv name
-        = case lookupNameEnv lenv name of
-                Just (ATcId { tct_id = id }) ->  id
-                _ -> pprPanic "tcLookupLocalIds" (ppr name)
-
--- inferInitialKind has made a suitably-shaped kind for the type or class
--- Look it up in the local environment. This is used only for tycons
--- that we're currently type-checking, so we're sure to find a TcTyCon.
-tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon
-tcLookupTcTyCon name = do
-    thing <- tcLookup name
-    case thing of
-        ATcTyCon tc -> return tc
-        _           -> pprPanic "tcLookupTcTyCon" (ppr name)
-
-getInLocalScope :: TcM (Name -> Bool)
-getInLocalScope = do { lcl_env <- getLclTypeEnv
-                     ; return (`elemNameEnv` lcl_env) }
-
-tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r
--- Used only during kind checking, for TcThings that are
---      ATcTyCon or APromotionErr
--- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr
-tcExtendKindEnvList things thing_inside
-  = do { traceTc "tcExtendKindEnvList" (ppr things)
-       ; updLclEnv upd_env thing_inside }
-  where
-    upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }
-
-tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r
--- A variant of tcExtendKindEvnList
-tcExtendKindEnv extra_env thing_inside
-  = do { traceTc "tcExtendKindEnv" (ppr extra_env)
-       ; updLclEnv upd_env thing_inside }
-  where
-    upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env }
-
------------------------
--- Scoped type and kind variables
-tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
-tcExtendTyVarEnv tvs thing_inside
-  -- MP: This silently coerces TyVar to TcTyVar.
-  = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside
-
-tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r
-tcExtendNameTyVarEnv binds thing_inside
-  -- this should be used only for explicitly mentioned scoped variables.
-  -- thus, no coercion variables
-  = tc_extend_local_env NotTopLevel names $
-        tcExtendBinderStack tv_binds $
-        thing_inside
-  where
-    tv_binds :: [TcBinder]
-    tv_binds = [TcTvBndr name tv | (name,tv) <- binds]
-
-    names = [(name, ATyVar name tv) | (name, tv) <- binds]
-
-isTypeClosedLetBndr :: Id -> Bool
--- See Note [Bindings with closed types: ClosedTypeId] in GHC.Tc.Types
-isTypeClosedLetBndr = noFreeVarsOfType . idType
-
-tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
--- Used for binding the recursive uses of Ids in a binding
--- both top-level value bindings and nested let/where-bindings
--- Does not extend the TcBinderStack
-tcExtendRecIds pairs thing_inside
-  = tc_extend_local_env NotTopLevel
-          [ (name, ATcId { tct_id   = let_id
-                         , tct_info = NonClosedLet emptyNameSet False })
-          | (name, let_id) <- pairs ] $
-    thing_inside
-
-tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
--- Used for binding the Ids that have a complete user type signature
--- Does not extend the TcBinderStack
-tcExtendSigIds top_lvl sig_ids thing_inside
-  = tc_extend_local_env top_lvl
-          [ (idName id, ATcId { tct_id   = id
-                              , tct_info = info })
-          | id <- sig_ids
-          , let closed = isTypeClosedLetBndr id
-                info   = NonClosedLet emptyNameSet closed ]
-     thing_inside
-
-
-tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
-                  -> [TcId] -> TcM a -> TcM a
--- Used for both top-level value bindings and nested let/where-bindings
--- Adds to the TcBinderStack too
-tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)
-               ids thing_inside
-  = tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $
-    tc_extend_local_env top_lvl
-          [ (idName id, ATcId { tct_id   = id
-                              , tct_info = mk_tct_info id })
-          | id <- ids ]
-    thing_inside
-  where
-    mk_tct_info id
-      | type_closed && isEmptyNameSet rhs_fvs = ClosedLet
-      | otherwise                             = NonClosedLet rhs_fvs type_closed
-      where
-        name        = idName id
-        rhs_fvs     = lookupNameEnv fvs name `orElse` emptyNameSet
-        type_closed = isTypeClosedLetBndr id &&
-                      (fv_type_closed || hasCompleteSig sig_fn name)
-
-tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
--- For lambda-bound and case-bound Ids
--- Extends the TcBinderStack as well
-tcExtendIdEnv ids thing_inside
-  = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
-
-tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
--- Exactly like tcExtendIdEnv2, but for a single (name,id) pair
-tcExtendIdEnv1 name id thing_inside
-  = tcExtendIdEnv2 [(name,id)] thing_inside
-
-tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
-tcExtendIdEnv2 names_w_ids thing_inside
-  = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
-                        | (_,mono_id) <- names_w_ids ] $
-    tc_extend_local_env NotTopLevel
-            [ (name, ATcId { tct_id = id
-                           , tct_info    = NotLetBound })
-            | (name,id) <- names_w_ids]
-    thing_inside
-
-tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
-tc_extend_local_env top_lvl extra_env thing_inside
--- Precondition: the argument list extra_env has TcTyThings
---               that ATcId or ATyVar, but nothing else
---
--- Invariant: the ATcIds are fully zonked. Reasons:
---      (a) The kinds of the forall'd type variables are defaulted
---          (see Kind.defaultKind, done in skolemiseQuantifiedTyVar)
---      (b) There are no via-Indirect occurrences of the bound variables
---          in the types, because instantiation does not look through such things
---      (c) The call to tyCoVarsOfTypes is ok without looking through refs
-
--- The second argument of type TyVarSet is a set of type variables
--- that are bound together with extra_env and should not be regarded
--- as free in the types of extra_env.
-  = do  { traceTc "tc_extend_local_env" (ppr extra_env)
-        ; updLclEnv upd_lcl_env thing_inside }
-  where
-    upd_lcl_env env0@(TcLclEnv { tcl_th_ctxt  = stage
-                               , tcl_rdr      = rdr_env
-                               , tcl_th_bndrs = th_bndrs
-                               , tcl_env      = lcl_type_env })
-       = env0 { tcl_rdr = extendLocalRdrEnvList rdr_env
-                          [ n | (n, _) <- extra_env, isInternalName n ]
-                          -- The LocalRdrEnv contains only non-top-level names
-                          -- (GlobalRdrEnv handles the top level)
-
-              , tcl_th_bndrs = extendNameEnvList th_bndrs
-                               [(n, thlvl) | (n, ATcId {}) <- extra_env]
-                               -- We only track Ids in tcl_th_bndrs
-
-              , tcl_env = extendNameEnvList lcl_type_env extra_env }
-              -- tcl_rdr and tcl_th_bndrs: extend the local LocalRdrEnv and
-              -- Template Haskell staging env simultaneously. Reason for extending
-              -- LocalRdrEnv: after running a TH splice we need to do renaming.
-      where
-        thlvl = (top_lvl, thLevel stage)
-
-
-tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv
-tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
-  = lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things }
-
--- | @tcCheckUsage name mult thing_inside@ runs @thing_inside@, checks that the
--- usage of @name@ is a submultiplicity of @mult@, and removes @name@ from the
--- usage environment. See also Note [Wrapper returned from tcSubMult] in
--- GHC.Tc.Utils.Unify, which applies to the wrapper returned from this function.
-tcCheckUsage :: Name -> Mult -> TcM a -> TcM (a, HsWrapper)
-tcCheckUsage name id_mult thing_inside
-  = do { (local_usage, result) <- tcCollectingUsage thing_inside
-       ; wrapper <- check_then_add_usage local_usage
-       ; return (result, wrapper) }
-    where
-    check_then_add_usage :: UsageEnv -> TcM HsWrapper
-    -- Checks that the usage of the newly introduced binder is compatible with
-    -- its multiplicity, and combines the usage of non-new binders to |uenv|
-    check_then_add_usage uenv
-      = do { let actual_u = lookupUE uenv name
-           ; traceTc "check_then_add_usage" (ppr id_mult $$ ppr actual_u)
-           ; wrapper <- case actual_u of
-               Bottom -> return idHsWrapper
-               Zero     -> tcSubMult (UsageEnvironmentOf name) ManyTy id_mult
-               MUsage m -> do { m <- promote_mult m
-                              ; tcSubMult (UsageEnvironmentOf name) m id_mult }
-           ; tcEmitBindingUsage (deleteUE uenv name)
-           ; return wrapper }
-
-    -- This is gross. The problem is in test case typecheck/should_compile/T18998:
-    --   f :: a %1-> Id n a -> Id n a
-    --   f x (MkId _) = MkId x
-    -- where MkId is a GADT constructor. Multiplicity polymorphism of constructors
-    -- invents a new multiplicity variable p[2] for the application MkId x. This
-    -- variable is at level 2, bumped because of the GADT pattern-match (MkId _).
-    -- We eventually unify the variable with One, due to the call to tcSubMult in
-    -- tcCheckUsage. But by then, we're at TcLevel 1, and so the level-check
-    -- fails.
-    --
-    -- What to do? If we did inference "for real", the sub-multiplicity constraint
-    -- would end up in the implication of the GADT pattern-match, and all would
-    -- be well. But we don't have a real sub-multiplicity constraint to put in
-    -- the implication. (Multiplicity inference works outside the usual generate-
-    -- constraints-and-solve scheme.) Here, where the multiplicity arrives, we
-    -- must promote all multiplicity variables to reflect this outer TcLevel.
-    -- It's reminiscent of floating a constraint, really, so promotion is
-    -- appropriate. The promoteTcType function works only on types of kind TYPE rr,
-    -- so we can't use it here. Thus, this dirtiness.
-    --
-    -- It works nicely in practice.
-    --
-    -- We use a set to avoid calling promoteMetaTyVarTo twice on the same
-    -- metavariable. This happened in #19400.
-    promote_mult m = do { fvs <- zonkTyCoVarsAndFV (tyCoVarsOfType m)
-                        ; any_promoted <- promoteTyVarSet fvs
-                        ; if any_promoted then zonkTcType m else return m
-                        }
-
-{- *********************************************************************
-*                                                                      *
-             The TcBinderStack
-*                                                                      *
-********************************************************************* -}
-
-tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a
-tcExtendBinderStack bndrs thing_inside
-  = do { traceTc "tcExtendBinderStack" (ppr bndrs)
-       ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })
-                   thing_inside }
-
-tcInitTidyEnv :: TcM TidyEnv
--- We initialise the "tidy-env", used for tidying types before printing,
--- by building a reverse map from the in-scope type variables to the
--- OccName that the programmer originally used for them
-tcInitTidyEnv
-  = do  { lcl_env <- getLclEnv
-        ; go emptyTidyEnv (tcl_bndrs lcl_env) }
-  where
-    go (env, subst) []
-      = return (env, subst)
-    go (env, subst) (b : bs)
-      | TcTvBndr name tyvar <- b
-       = do { let (env', occ') = tidyOccName env (nameOccName name)
-                  name'  = tidyNameOcc name occ'
-                  tyvar1 = setTyVarName tyvar name'
-            ; tyvar2 <- zonkTcTyVarToTcTyVar tyvar1
-              -- Be sure to zonk here!  Tidying applies to zonked
-              -- types, so if we don't zonk we may create an
-              -- ill-kinded type (#14175)
-            ; go (env', extendVarEnv subst tyvar tyvar2) bs }
-      | otherwise
-      = go (env, subst) bs
-
--- | Get a 'TidyEnv' that includes mappings for all vars free in the given
--- type. Useful when tidying open types.
-tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
-tcInitOpenTidyEnv tvs
-  = do { env1 <- tcInitTidyEnv
-       ; let env2 = tidyFreeTyCoVars env1 tvs
-       ; return env2 }
-
-
-
-{- *********************************************************************
-*                                                                      *
-             Adding placeholders
-*                                                                      *
-********************************************************************* -}
-
-tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a
--- See Note [AFamDataCon: not promoting data family constructors]
-tcAddDataFamConPlaceholders inst_decls thing_inside
-  = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE)
-                        | lid <- inst_decls, con <- get_cons lid ]
-      thing_inside
-      -- Note [AFamDataCon: not promoting data family constructors]
-  where
-    -- get_cons extracts the *constructor* bindings of the declaration
-    get_cons :: LInstDecl GhcRn -> [Name]
-    get_cons (L _ (TyFamInstD {}))                     = []
-    get_cons (L _ (DataFamInstD { dfid_inst = fid }))  = get_fi_cons fid
-    get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
-      = concatMap (get_fi_cons . unLoc) fids
-
-    get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
-    get_fi_cons (DataFamInstDecl { dfid_eqn =
-                  FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }})
-      = map unLoc $ concatMap (getConNames . unLoc) cons
-
-
-tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
--- See Note [Don't promote pattern synonyms]
-tcAddPatSynPlaceholders pat_syns thing_inside
-  = tcExtendKindEnvList [ (name, APromotionErr PatSynPE)
-                        | PSB{ psb_id = L _ name } <- pat_syns ]
-       thing_inside
-
-getTypeSigNames :: [LSig GhcRn] -> NameSet
--- Get the names that have a user type sig
-getTypeSigNames sigs
-  = foldr get_type_sig emptyNameSet sigs
-  where
-    get_type_sig :: LSig GhcRn -> NameSet -> NameSet
-    get_type_sig sig ns =
-      case sig of
-        L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names)
-        L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names)
-        _ -> ns
-
-
-{- Note [AFamDataCon: not promoting data family constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  data family T a
-  data instance T Int = MkT
-  data Proxy (a :: k)
-  data S = MkS (Proxy 'MkT)
-
-Is it ok to use the promoted data family instance constructor 'MkT' in
-the data declaration for S (where both declarations live in the same module)?
-No, we don't allow this. It *might* make sense, but at least it would mean that
-we'd have to interleave typechecking instances and data types, whereas at
-present we do data types *then* instances.
-
-So to check for this we put in the TcLclEnv a binding for all the family
-constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
-type checking 'S' we'll produce a decent error message.
-
-#12088 describes this limitation. Of course, when MkT and S live in
-different modules then all is well.
-
-Note [Don't promote pattern synonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We never promote pattern synonyms.
-
-Consider this (#11265):
-  pattern A = True
-  instance Eq A
-We want a civilised error message from the occurrence of 'A'
-in the instance, yet 'A' really has not yet been type checked.
-
-Similarly (#9161)
-  {-# LANGUAGE PatternSynonyms, DataKinds #-}
-  pattern A = ()
-  b :: A
-  b = undefined
-Here, the type signature for b mentions A.  But A is a pattern
-synonym, which is typechecked as part of a group of bindings (for very
-good reasons; a view pattern in the RHS may mention a value binding).
-It is entirely reasonable to reject this, but to do so we need A to be
-in the kind environment when kind-checking the signature for B.
-
-Hence tcAddPatSynPlaceholders adds a binding
-    A -> APromotionErr PatSynPE
-to the environment. Then GHC.Tc.Gen.HsType.tcTyVar will find A in the kind
-environment, and will give a 'wrongThingErr' as a result.  But the
-lookup of A won't fail.
-
-
-************************************************************************
-*                                                                      *
-\subsection{Rules}
-*                                                                      *
-************************************************************************
--}
-
-tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a
-        -- Just pop the new rules into the EPS and envt resp
-        -- All the rules come from an interface file, not source
-        -- Nevertheless, some may be for this module, if we read
-        -- its interface instead of its source code
-tcExtendRules lcl_rules thing_inside
- = do { env <- getGblEnv
-      ; let
-          env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
-      ; setGblEnv env' thing_inside }
-
-{-
-************************************************************************
-*                                                                      *
-                Meta level
-*                                                                      *
-************************************************************************
--}
-
-checkWellStaged :: SDoc         -- What the stage check is for
-                -> ThLevel      -- Binding level (increases inside brackets)
-                -> ThLevel      -- Use stage
-                -> TcM ()       -- Fail if badly staged, adding an error
-checkWellStaged pp_thing bind_lvl use_lvl
-  | use_lvl >= bind_lvl         -- OK! Used later than bound
-  = return ()                   -- E.g.  \x -> [| $(f x) |]
-
-  | bind_lvl == outerLevel      -- GHC restriction on top level splices
-  = stageRestrictionError pp_thing
-
-  | otherwise                   -- Badly staged
-  = failWithTc $                -- E.g.  \x -> $(f x)
-    mkTcRnUnknownMessage $ mkPlainError noHints $
-    text "Stage error:" <+> pp_thing <+>
-        hsep   [text "is bound at stage" <+> ppr bind_lvl,
-                text "but used at stage" <+> ppr use_lvl]
-
-stageRestrictionError :: SDoc -> TcM a
-stageRestrictionError pp_thing
-  = failWithTc $
-    mkTcRnUnknownMessage $ mkPlainError noHints $
-    sep [ text "GHC stage restriction:"
-        , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"
-                       , text "and must be imported, not defined locally"])]
-
-topIdLvl :: Id -> ThLevel
--- Globals may either be imported, or may be from an earlier "chunk"
--- (separated by declaration splices) of this module.  The former
---  *can* be used inside a top-level splice, but the latter cannot.
--- Hence we give the former impLevel, but the latter topLevel
--- E.g. this is bad:
---      x = [| foo |]
---      $( f x )
--- By the time we are processing the $(f x), the binding for "x"
--- will be in the global env, not the local one.
-topIdLvl id | isLocalId id = outerLevel
-            | otherwise    = impLevel
-
-tcMetaTy :: Name -> TcM Type
--- Given the name of a Template Haskell data type,
--- return the type
--- E.g. given the name "Expr" return the type "Expr"
-tcMetaTy tc_name = do
-    t <- tcLookupTyCon tc_name
-    return (mkTyConTy t)
-
-isBrackStage :: ThStage -> Bool
-isBrackStage (Brack {}) = True
-isBrackStage _other     = False
-
-{-
-************************************************************************
-*                                                                      *
-                 getDefaultTys
-*                                                                      *
-************************************************************************
--}
-
-tcGetDefaultTys :: TcM ([Type], -- Default types
-                        (Bool,  -- True <=> Use overloaded strings
-                         Bool)) -- True <=> Use extended defaulting rules
-tcGetDefaultTys
-  = do  { dflags <- getDynFlags
-        ; let ovl_strings = xopt LangExt.OverloadedStrings dflags
-              extended_defaults = xopt LangExt.ExtendedDefaultRules dflags
-                                        -- See also #1974
-              flags = (ovl_strings, extended_defaults)
-
-        ; mb_defaults <- getDeclaredDefaultTys
-        ; case mb_defaults of {
-           Just tys -> return (tys, flags) ;
-                                -- User-supplied defaults
-           Nothing  -> do
-
-        -- No user-supplied default
-        -- Use [Integer, Double], plus modifications
-        { integer_ty <- tcMetaTy integerTyConName
-        ; list_ty <- tcMetaTy listTyConName
-        ; checkWiredInTyCon doubleTyCon
-        ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]
-                          -- Note [Extended defaults]
-                          ++ [integer_ty, doubleTy]
-                          ++ opt_deflt ovl_strings [stringTy]
-        ; return (deflt_tys, flags) } } }
-  where
-    opt_deflt True  xs = xs
-    opt_deflt False _  = []
-
-{-
-Note [Extended defaults]
-~~~~~~~~~~~~~~~~~~~~~
-In interactive mode (or with -XExtendedDefaultRules) we add () as the first type we
-try when defaulting.  This has very little real impact, except in the following case.
-Consider:
-        Text.Printf.printf "hello"
-This has type (forall a. IO a); it prints "hello", and returns 'undefined'.  We don't
-want the GHCi repl loop to try to print that 'undefined'.  The neatest thing is to
-default the 'a' to (), rather than to Integer (which is what would otherwise happen;
-and then GHCi doesn't attempt to print the ().  So in interactive mode, we add
-() to the list of defaulting types.  See #1200.
-
-Additionally, the list type [] is added as a default specialization for
-Traversable and Foldable. As such the default default list now has types of
-varying kinds, e.g. ([] :: * -> *)  and (Integer :: *).
-
-************************************************************************
-*                                                                      *
-\subsection{The InstInfo type}
-*                                                                      *
-************************************************************************
-
-The InstInfo type summarises the information in an instance declaration
-
-    instance c => k (t tvs) where b
-
-It is used just for *local* instance decls (not ones from interface files).
-But local instance decls includes
-        - derived ones
-        - generic ones
-as well as explicit user written ones.
--}
-
-data InstInfo a
-  = InstInfo
-      { iSpec   :: ClsInst          -- Includes the dfun id
-      , iBinds  :: InstBindings a
-      }
-
-iDFunId :: InstInfo a -> DFunId
-iDFunId info = instanceDFunId (iSpec info)
-
-data InstBindings a
-  = InstBindings
-      { ib_tyvars  :: [Name]   -- Names of the tyvars from the instance head
-                               -- that are lexically in scope in the bindings
-                               -- Must correspond 1-1 with the forall'd tyvars
-                               -- of the dfun Id.  When typechecking, we are
-                               -- going to extend the typechecker's envt with
-                               --     ib_tyvars -> dfun_forall_tyvars
-
-      , ib_binds   :: LHsBinds a    -- Bindings for the instance methods
-
-      , ib_pragmas :: [LSig a]      -- User pragmas recorded for generating
-                                    -- specialised instances
-
-      , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should
-                                             -- be enabled when type-checking
-                                             -- this instance; needed for
-                                             -- GeneralizedNewtypeDeriving
-
-      , ib_derived :: Bool
-           -- True <=> This code was generated by GHC from a deriving clause
-           --          or standalone deriving declaration
-           --          Used only to improve error messages
-      }
-
-instance (OutputableBndrId a)
-       => Outputable (InstInfo (GhcPass a)) where
-    ppr = pprInstInfoDetails
-
-pprInstInfoDetails :: (OutputableBndrId a)
-                   => InstInfo (GhcPass a) -> SDoc
-pprInstInfoDetails info
-   = hang (pprInstanceHdr (iSpec info) <+> text "where")
-        2 (details (iBinds info))
-  where
-    details (InstBindings { ib_pragmas = p, ib_binds = b }) =
-      pprDeclList (pprLHsBindsForUser b p)
-
-simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
-simpleInstInfoClsTy info = case instanceHead (iSpec info) of
-                           (_, cls, [ty]) -> (cls, ty)
-                           _ -> panic "simpleInstInfoClsTy"
-
-simpleInstInfoTy :: InstInfo a -> Type
-simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
-
-simpleInstInfoTyCon :: InstInfo a -> TyCon
-  -- Gets the type constructor for a simple instance declaration,
-  -- i.e. one of the form       instance (...) => C (T a b c) where ...
-simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
-
--- | Make a name for the dict fun for an instance decl.  It's an *external*
--- name, like other top-level names, and hence must be made with
--- newGlobalBinder.
-newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
-newDFunName clas tys loc
-  = do  { is_boot <- tcIsHsBootOrSig
-        ; mod     <- getModule
-        ; let info_string = occNameString (getOccName clas) ++
-                            concatMap (occNameString.getDFunTyKey) tys
-        ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
-        ; newGlobalBinder mod dfun_occ loc }
-
-newFamInstTyConName :: LocatedN Name -> [Type] -> TcM Name
-newFamInstTyConName (L loc name) tys = mk_fam_inst_name id (locA loc) name [tys]
-
-newFamInstAxiomName :: LocatedN Name -> [[Type]] -> TcM Name
-newFamInstAxiomName (L loc name) branches
-  = mk_fam_inst_name mkInstTyCoOcc (locA loc) name branches
-
-mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
-mk_fam_inst_name adaptOcc loc tc_name tyss
-  = do  { mod   <- getModule
-        ; let info_string = occNameString (getOccName tc_name) ++
-                            intercalate "|" ty_strings
-        ; occ   <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
-        ; newGlobalBinder mod (adaptOcc occ) loc }
-  where
-    ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss
-
-{-
-Stable names used for foreign exports and annotations.
-For stable names, the name must be unique (see #1533).  If the
-same thing has several stable Ids based on it, the
-top-level bindings generated must not have the same name.
-Hence we create an External name (doesn't change), and we
-append a Unique to the string right here.
--}
-
-mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
-mkStableIdFromString str sig_ty loc occ_wrapper = do
-    uniq <- newUnique
-    mod <- getModule
-    nextWrapperNum <- tcg_next_wrapper_num <$> getGblEnv
-    name <- mkWrapperName nextWrapperNum "stable" str
-    let occ = mkVarOccFS name :: OccName
-        gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
-        id  = mkExportedVanillaId gnm sig_ty :: Id
-    return id
-
-mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
-mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
-
-mkWrapperName :: (MonadIO m, HasModule m)
-              => IORef (ModuleEnv Int) -> String -> String -> m FastString
--- ^ @mkWrapperName ref what nameBase@
---
--- See Note [Generating fresh names for FFI wrappers] for @ref@'s purpose.
-mkWrapperName wrapperRef what nameBase
-    = do thisMod <- getModule
-         let pkg = unitString  (moduleUnit thisMod)
-             mod = moduleNameString (moduleName      thisMod)
-         wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
-             let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
-                 mod_env' = extendModuleEnv mod_env thisMod (num+1)
-             in (mod_env', num)
-         let components = [what, show wrapperNum, pkg, mod, nameBase]
-         return $ mkFastString $ zEncodeString $ intercalate ":" components
-
-{-
-Note [Generating fresh names for FFI wrappers]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We used to use a unique, rather than nextWrapperNum, to distinguish
-between FFI wrapper functions. However, the wrapper names that we
-generate are external names. This means that if a call to them ends up
-in an unfolding, then we can't alpha-rename them, and thus if the
-unique randomly changes from one compile to another then we get a
-spurious ABI change (#4012).
-
-The wrapper counter has to be per-module, not global, so that the number we end
-up using is not dependent on the modules compiled before the current one.
--}
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Errors}
-*                                                                      *
-************************************************************************
--}
-
-pprBinders :: [Name] -> SDoc
--- Used in error messages
--- Use quotes for a single one; they look a bit "busy" for several
-pprBinders [bndr] = quotes (ppr bndr)
-pprBinders bndrs  = pprWithCommas ppr bndrs
-
-notFound :: Name -> TcM TyThing
-notFound name
-  = do { lcl_env <- getLclEnv
-       ; let stage = tcl_th_ctxt lcl_env
-       ; case stage of   -- See Note [Out of scope might be a staging error]
-           Splice {}
-             | isUnboundName name -> failM  -- If the name really isn't in scope
-                                            -- don't report it again (#11941)
-             | otherwise -> stageRestrictionError (quotes (ppr name))
-           _ -> failWithTc $
-                mkTcRnUnknownMessage $ mkPlainError noHints $
-                vcat[text "GHC internal error:" <+> quotes (ppr name) <+>
-                     text "is not in scope during type checking, but it passed the renamer",
-                     text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)]
-                       -- Take care: printing the whole gbl env can
-                       -- cause an infinite loop, in the case where we
-                       -- are in the middle of a recursive TyCon/Class group;
-                       -- so let's just not print it!  Getting a loop here is
-                       -- very unhelpful, because it hides one compiler bug with another
-       }
-
-wrongThingErr :: String -> TcTyThing -> Name -> TcM a
-wrongThingErr expected thing name
-  = let msg = mkTcRnUnknownMessage $ mkPlainError noHints $
-          (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
-                     text "used as a" <+> text expected)
-  in failWithTc msg
-
-{- Note [Out of scope might be a staging error]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-  x = 3
-  data T = MkT $(foo x)
-
-where 'foo' is imported from somewhere.
-
-This is really a staging error, because we can't run code involving 'x'.
-But in fact the type checker processes types first, so 'x' won't even be
-in the type envt when we look for it in $(foo x).  So inside splices we
-report something missing from the type env as a staging error.
-See #5752 and #5795.
--}
diff --git a/compiler/GHC/Tc/Utils/Env.hs-boot b/compiler/GHC/Tc/Utils/Env.hs-boot
deleted file mode 100644
--- a/compiler/GHC/Tc/Utils/Env.hs-boot
+++ /dev/null
@@ -1,10 +0,0 @@
-module GHC.Tc.Utils.Env where
-
-import GHC.Tc.Types( TcM )
-import GHC.Types.Var.Env( TidyEnv )
-
--- Annoyingly, there's a recursion between tcInitTidyEnv
--- (which does zonking and hence needs GHC.Tc.Utils.TcMType) and
--- addErrTc etc which live in GHC.Tc.Utils.Monad.  Rats.
-tcInitTidyEnv :: TcM TidyEnv
-
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ /dev/null
@@ -1,1036 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE DisambiguateRecordFields #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
-module GHC.Tc.Utils.Instantiate (
-     topSkolemise,
-     topInstantiate,
-     instantiateSigma,
-     instCall, instDFunType, instStupidTheta, instTyVarsWith,
-     newWanted, newWanteds,
-
-     tcInstType, tcInstTypeBndrs,
-     tcSkolemiseInvisibleBndrs,
-     tcInstSkolTyVars, tcInstSkolTyVarsX,
-     tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,
-
-     freshenTyVarBndrs, freshenCoVarBndrsX,
-
-     tcInstInvisibleTyBindersN, tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,
-
-     newOverloadedLit, mkOverLit,
-
-     newClsInst,
-     tcGetInsts, tcGetInstEnvs, getOverlapFlag,
-     tcExtendLocalInstEnv,
-     instCallConstraints, newMethodFromName,
-     tcSyntaxName,
-
-     -- Simple functions over evidence variables
-     tyCoVarsOfWC,
-     tyCoVarsOfCt, tyCoVarsOfCts,
-  ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-import GHC.Driver.Env
-
-import GHC.Builtin.Types  ( heqDataCon, eqDataCon, integerTyConName )
-import GHC.Builtin.Names
-
-import GHC.Hs
-import GHC.Hs.Syn.Type   ( hsLitType )
-
-import GHC.Core.InstEnv
-import GHC.Core.Predicate
-import GHC.Core ( Expr(..), isOrphan ) -- For the Coercion constructor
-import GHC.Core.Type
-import GHC.Core.Multiplicity
-import GHC.Core.TyCo.Rep
-import GHC.Core.TyCo.Ppr ( debugPprType )
-import GHC.Core.Class( Class )
-import GHC.Core.DataCon
-
-import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp )
-import {-# SOURCE #-}   GHC.Tc.Utils.Unify( unifyType, unifyKind )
-import GHC.Tc.Utils.Zonk
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.Env
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Instance.FunDeps
-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Errors.Types
-
-import GHC.Types.Id.Make( mkDictFunId )
-import GHC.Types.Basic ( TypeOrKind(..), Arity )
-import GHC.Types.Error
-import GHC.Types.SourceText
-import GHC.Types.SrcLoc as SrcLoc
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
-import GHC.Types.Id
-import GHC.Types.Name
-import GHC.Types.Var
-import qualified GHC.LanguageExtensions as LangExt
-
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Outputable
-
-import GHC.Unit.State
-import GHC.Unit.External
-
-import Data.List ( mapAccumL )
-import qualified Data.List.NonEmpty as NE
-import Control.Monad( when, unless )
-import Data.Function ( on )
-
-{-
-************************************************************************
-*                                                                      *
-                Creating and emittind constraints
-*                                                                      *
-************************************************************************
--}
-
-newMethodFromName
-  :: CtOrigin              -- ^ why do we need this?
-  -> Name                  -- ^ name of the method
-  -> [TcRhoType]           -- ^ types with which to instantiate the class
-  -> TcM (HsExpr GhcTc)
--- ^ Used when 'Name' is the wired-in name for a wired-in class method,
--- so the caller knows its type for sure, which should be of form
---
--- > forall a. C a => <blah>
---
--- 'newMethodFromName' is supposed to instantiate just the outer
--- type variable and constraint
-
-newMethodFromName origin name ty_args
-  = do { id <- tcLookupId name
-              -- Use tcLookupId not tcLookupGlobalId; the method is almost
-              -- always a class op, but with -XRebindableSyntax GHC is
-              -- meant to find whatever thing is in scope, and that may
-              -- be an ordinary function.
-
-       ; let ty = piResultTys (idType id) ty_args
-             (theta, _caller_knows_this) = tcSplitPhiTy ty
-       ; wrap <- assert (not (isForAllTy ty) && isSingleton theta) $
-                 instCall origin ty_args theta
-
-       ; return (mkHsWrap wrap (HsVar noExtField (noLocA id))) }
-
-{-
-************************************************************************
-*                                                                      *
-         Instantiation and skolemisation
-*                                                                      *
-************************************************************************
-
-Note [Skolemisation]
-~~~~~~~~~~~~~~~~~~~~
-topSkolemise decomposes and skolemises a type, returning a type
-with no top level foralls or (=>)
-
-Examples:
-
-  topSkolemise (forall a. Ord a => a -> a)
-    =  ( wp, [a], [d:Ord a], a->a )
-    where wp = /\a. \(d:Ord a). <hole> a d
-
-  topSkolemise  (forall a. Ord a => forall b. Eq b => a->b->b)
-    =  ( wp, [a,b], [d1:Ord a,d2:Eq b], a->b->b )
-    where wp = /\a.\(d1:Ord a)./\b.\(d2:Ord b). <hole> a d1 b d2
-
-This second example is the reason for the recursive 'go'
-function in topSkolemise: we must remove successive layers
-of foralls and (=>).
-
-In general,
-  if      topSkolemise ty = (wrap, tvs, evs, rho)
-    and   e :: rho
-  then    wrap e :: ty
-    and   'wrap' binds {tvs, evs}
-
--}
-
-topSkolemise :: SkolemInfo
-             -> TcSigmaType
-             -> TcM ( HsWrapper
-                    , [(Name,TyVar)]     -- All skolemised variables
-                    , [EvVar]            -- All "given"s
-                    , TcRhoType )
--- See Note [Skolemisation]
-topSkolemise skolem_info ty
-  = go init_subst idHsWrapper [] [] ty
-  where
-    init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty))
-
-    -- Why recursive?  See Note [Skolemisation]
-    go subst wrap tv_prs ev_vars ty
-      | (tvs, theta, inner_ty) <- tcSplitSigmaTy ty
-      , not (null tvs && null theta)
-      = do { (subst', tvs1) <- tcInstSkolTyVarsX skolem_info subst tvs
-           ; ev_vars1       <- newEvVars (substTheta subst' theta)
-           ; go subst'
-                (wrap <.> mkWpTyLams tvs1 <.> mkWpEvLams ev_vars1)
-                (tv_prs ++ (map tyVarName tvs `zip` tvs1))
-                (ev_vars ++ ev_vars1)
-                inner_ty }
-
-      | otherwise
-      = return (wrap, tv_prs, ev_vars, substTy subst ty)
-        -- substTy is a quick no-op on an empty substitution
-
-topInstantiate ::CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
--- Instantiate outer invisible binders (both Inferred and Specified)
--- If    top_instantiate ty = (wrap, inner_ty)
--- then  wrap :: inner_ty "->" ty
--- NB: returns a type with no (=>),
---     and no invisible forall at the top
-topInstantiate orig sigma
-  | (tvs,   body1) <- tcSplitSomeForAllTyVars isInvisibleForAllTyFlag sigma
-  , (theta, body2) <- tcSplitPhiTy body1
-  , not (null tvs && null theta)
-  = do { (_, wrap1, body3) <- instantiateSigma orig tvs theta body2
-
-       -- Loop, to account for types like
-       --       forall a. Num a => forall b. Ord b => ...
-       ; (wrap2, body4) <- topInstantiate orig body3
-
-       ; return (wrap2 <.> wrap1, body4) }
-
-  | otherwise = return (idHsWrapper, sigma)
-
-instantiateSigma :: CtOrigin -> [TyVar] -> TcThetaType -> TcSigmaType
-                 -> TcM ([TcTyVar], HsWrapper, TcSigmaType)
--- (instantiate orig tvs theta ty)
--- instantiates the type variables tvs, emits the (instantiated)
--- constraints theta, and returns the (instantiated) type ty
-instantiateSigma orig tvs theta body_ty
-  = do { (subst, inst_tvs) <- mapAccumLM newMetaTyVarX empty_subst tvs
-       ; let inst_theta  = substTheta subst theta
-             inst_body   = substTy subst body_ty
-             inst_tv_tys = mkTyVarTys inst_tvs
-
-       ; wrap <- instCall orig inst_tv_tys inst_theta
-       ; traceTc "Instantiating"
-                 (vcat [ text "origin" <+> pprCtOrigin orig
-                       , text "tvs"   <+> ppr tvs
-                       , text "theta" <+> ppr theta
-                       , text "type" <+> debugPprType body_ty
-                       , text "with" <+> vcat (map debugPprType inst_tv_tys)
-                       , text "theta:" <+>  ppr inst_theta ])
-
-      ; return (inst_tvs, wrap, inst_body) }
-  where
-    free_tvs = tyCoVarsOfType body_ty `unionVarSet` tyCoVarsOfTypes theta
-    in_scope = mkInScopeSet (free_tvs `delVarSetList` tvs)
-    empty_subst = mkEmptySubst in_scope
-
-instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM Subst
--- Use this when you want to instantiate (forall a b c. ty) with
--- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might
--- not yet match (perhaps because there are unsolved constraints; #14154)
--- If they don't match, emit a kind-equality to promise that they will
--- eventually do so, and thus make a kind-homogeneous substitution.
-instTyVarsWith orig tvs tys
-  = go emptySubst tvs tys
-  where
-    go subst [] []
-      = return subst
-    go subst (tv:tvs) (ty:tys)
-      | tv_kind `tcEqType` ty_kind
-      = go (extendTvSubstAndInScope subst tv ty) tvs tys
-      | otherwise
-      = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind
-           ; go (extendTvSubstAndInScope subst tv (ty `mkCastTy` co)) tvs tys }
-      where
-        tv_kind = substTy subst (tyVarKind tv)
-        ty_kind = typeKind ty
-
-    go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys)
-
-
-{-
-************************************************************************
-*                                                                      *
-            Instantiating a call
-*                                                                      *
-************************************************************************
-
-Note [Handling boxed equality]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The solver deals entirely in terms of unboxed (primitive) equality.
-There should never be a boxed Wanted equality. Ever. But, what if
-we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality
-is boxed, so naive treatment here would emit a boxed Wanted equality.
-
-So we simply check for this case and make the right boxing of evidence.
-
--}
-
-----------------
-instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
--- Instantiate the constraints of a call
---      (instCall o tys theta)
--- (a) Makes fresh dictionaries as necessary for the constraints (theta)
--- (b) Throws these dictionaries into the LIE
--- (c) Returns an HsWrapper ([.] tys dicts)
-
-instCall orig tys theta
-  = do  { dict_app <- instCallConstraints orig theta
-        ; return (dict_app <.> mkWpTyApps tys) }
-
-----------------
-instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
--- Instantiates the TcTheta, puts all constraints thereby generated
--- into the LIE, and returns a HsWrapper to enclose the call site.
-
-instCallConstraints orig preds
-  | null preds
-  = return idHsWrapper
-  | otherwise
-  = do { evs <- mapM go preds
-       ; traceTc "instCallConstraints" (ppr evs)
-       ; return (mkWpEvApps evs) }
-  where
-    go :: TcPredType -> TcM EvTerm
-    go pred
-     | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
-     = do  { co <- unifyType Nothing ty1 ty2
-           ; return (evCoercion co) }
-
-       -- Try short-cut #2
-     | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
-     , tc `hasKey` heqTyConKey
-     = do { co <- unifyType Nothing ty1 ty2
-          ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) }
-
-     | otherwise
-     = emitWanted orig pred
-
-instDFunType :: DFunId -> [DFunInstType]
-             -> TcM ( [TcType]      -- instantiated argument types
-                    , TcThetaType ) -- instantiated constraint
--- See Note [DFunInstType: instantiating types] in GHC.Core.InstEnv
-instDFunType dfun_id dfun_inst_tys
-  = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys
-       ; return (inst_tys, substTheta subst dfun_theta) }
-  where
-    dfun_ty = idType dfun_id
-    (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty
-    empty_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType dfun_ty))
-                  -- With quantified constraints, the
-                  -- type of a dfun may not be closed
-
-    go :: Subst -> [TyVar] -> [DFunInstType] -> TcM (Subst, [TcType])
-    go subst [] [] = return (subst, [])
-    go subst (tv:tvs) (Just ty : mb_tys)
-      = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty)
-                                 tvs
-                                 mb_tys
-           ; return (subst', ty : tys) }
-    go subst (tv:tvs) (Nothing : mb_tys)
-      = do { (subst', tv') <- newMetaTyVarX subst tv
-           ; (subst'', tys) <- go subst' tvs mb_tys
-           ; return (subst'', mkTyVarTy tv' : tys) }
-    go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)
-
-----------------
-instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
--- Similar to instCall, but only emit the constraints in the LIE
--- Used exclusively for the 'stupid theta' of a data constructor
-instStupidTheta orig theta
-  = do  { _co <- instCallConstraints orig theta -- Discard the coercion
-        ; return () }
-
-
-{- *********************************************************************
-*                                                                      *
-         Instantiating Kinds
-*                                                                      *
-********************************************************************* -}
-
--- | Given ty::forall k1 k2. k, instantiate all the invisible forall-binders
---   returning ty @kk1 @kk2 :: k[kk1/k1, kk2/k1]
--- Called only to instantiate kinds, in user-written type signatures
-tcInstInvisibleTyBinders :: TcType -> TcKind -> TcM (TcType, TcKind)
-tcInstInvisibleTyBinders ty kind
-  = do { (extra_args, kind') <- tcInstInvisibleTyBindersN n_invis kind
-       ; return (mkAppTys ty extra_args, kind') }
-  where
-    n_invis = invisibleTyBndrCount kind
-
-tcInstInvisibleTyBindersN :: Int -> TcKind -> TcM ([TcType], TcKind)
--- Called only to instantiate kinds, in user-written type signatures
-tcInstInvisibleTyBindersN 0 kind
-  = return ([], kind)
-tcInstInvisibleTyBindersN n ty
-  = go n empty_subst ty
-  where
-    empty_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty))
-
-    go n subst kind
-      | n > 0
-      , Just (bndr, body) <- tcSplitPiTy_maybe kind
-      , isInvisiblePiTyBinder bndr
-      = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr
-           ; (args, inner_ty) <- go (n-1) subst' body
-           ; return (arg:args, inner_ty) }
-      | otherwise
-      = return ([], substTy subst kind)
-
-tcInstInvisibleTyBinder :: Subst -> PiTyVarBinder -> TcM (Subst, TcType)
--- Called only to instantiate kinds, in user-written type signatures
-
-tcInstInvisibleTyBinder subst (Named (Bndr tv _))
-  = do { (subst', tv') <- newMetaTyVarX subst tv
-       ; return (subst', mkTyVarTy tv') }
-
-tcInstInvisibleTyBinder subst (Anon ty af)
-  | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst (scaledThing ty))
-    -- For kinds like (k1 ~ k2) => blah, we want to emit a unification
-    -- constraint for (k1 ~# k2) and return the argument (Eq# k1 k2)
-    -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep
-    -- Equality is the *only* constraint currently handled in types.
-  = assert (isInvisibleFunArg af) $
-    do { co <- unifyKind Nothing k1 k2
-       ; return (subst, mk co) }
-
-  | otherwise  -- This should never happen
-               -- See GHC.Core.TyCo.Rep Note [Constraints in kinds]
-  = pprPanic "tcInvisibleTyBinder" (ppr ty)
-
--------------------------------
-get_eq_tys_maybe :: Type
-                 -> Maybe ( Coercion -> Type
-                             -- Given a coercion proving t1 ~# t2, produce the
-                             -- right instantiation for the PiTyVarBinder at hand
-                          , Type  -- t1
-                          , Type  -- t2
-                          )
--- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep
-get_eq_tys_maybe ty
-  -- Lifted heterogeneous equality (~~)
-  | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty
-  , tc `hasKey` heqTyConKey
-  = Just (mkHEqBoxTy k1 k2, k1, k2)
-
-  -- Lifted homogeneous equality (~)
-  | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty
-  , tc `hasKey` eqTyConKey
-  = Just (mkEqBoxTy k1 k2, k1, k2)
-
-  | otherwise
-  = Nothing
-
--- | This takes @a ~# b@ and returns @a ~~ b@.
-mkHEqBoxTy :: Type -> Type -> TcCoercion -> Type
-mkHEqBoxTy ty1 ty2 co
-  = mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co]
-  where k1 = typeKind ty1
-        k2 = typeKind ty2
-
--- | This takes @a ~# b@ and returns @a ~ b@.
-mkEqBoxTy :: Type -> Type -> TcCoercion -> Type
-mkEqBoxTy ty1 ty2 co
-  = mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co]
-  where k = typeKind ty1
-
-{- *********************************************************************
-*                                                                      *
-        SkolemTvs (immutable)
-*                                                                      *
-********************************************************************* -}
-
-tcInstType :: ([TyVar] -> TcM (Subst, [TcTyVar]))
-                   -- ^ How to instantiate the type variables
-           -> Id                                           -- ^ Type to instantiate
-           -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result
-                -- (type vars, preds (incl equalities), rho)
-tcInstType inst_tyvars id
-  | null tyvars   -- There may be overloading despite no type variables;
-                  --      (?x :: Int) => Int -> Int
-  = return ([], theta, tau)
-  | otherwise
-  = do { (subst, tyvars') <- inst_tyvars tyvars
-       ; let tv_prs  = map tyVarName tyvars `zip` tyvars'
-             subst'  = extendSubstInScopeSet subst (tyCoVarsOfType rho)
-       ; return (tv_prs, substTheta subst' theta, substTy subst' tau) }
-  where
-    (tyvars, rho) = tcSplitForAllInvisTyVars (idType id)
-    (theta, tau)  = tcSplitPhiTy rho
-
-tcInstTypeBndrs :: Type -> TcM ([(Name, InvisTVBinder)], TcThetaType, TcType)
-                     -- (type vars, preds (incl equalities), rho)
--- Instantiate the binders of a type signature with TyVarTvs
-tcInstTypeBndrs poly_ty
-  | null tyvars   -- There may be overloading despite no type variables;
-                  --      (?x :: Int) => Int -> Int
-  = return ([], theta, tau)
-  | otherwise
-  = do { (subst, tyvars') <- mapAccumLM inst_invis_bndr emptySubst tyvars
-       ; let tv_prs  = map (tyVarName . binderVar) tyvars `zip` tyvars'
-             subst'  = extendSubstInScopeSet subst (tyCoVarsOfType rho)
-       ; return (tv_prs, substTheta subst' theta, substTy subst' tau) }
-  where
-    (tyvars, rho) = tcSplitForAllInvisTVBinders poly_ty
-    (theta, tau)  = tcSplitPhiTy rho
-
-    inst_invis_bndr :: Subst -> InvisTVBinder
-                    -> TcM (Subst, InvisTVBinder)
-    inst_invis_bndr subst (Bndr tv spec)
-      = do { (subst', tv') <- newMetaTyVarTyVarX subst tv
-           ; return (subst', Bndr tv' spec) }
-
---------------------------
-tcSkolDFunType :: SkolemInfo -> DFunId -> TcM ([TcTyVar], TcThetaType, TcType)
--- Instantiate a type signature with skolem constants.
--- This freshens the names, but no need to do so
-tcSkolDFunType skol_info dfun
-  = do { (tv_prs, theta, tau) <- tcInstType (tcInstSuperSkolTyVars skol_info) dfun
-       ; return (map snd tv_prs, theta, tau) }
-
-tcSuperSkolTyVars :: TcLevel -> SkolemInfo -> [TyVar] -> (Subst, [TcTyVar])
--- Make skolem constants, but do *not* give them new names, as above
--- As always, allocate them one level in
--- Moreover, make them "super skolems"; see GHC.Core.InstEnv
---    Note [Binding when looking up instances]
--- See Note [Kind substitution when instantiating]
--- Precondition: tyvars should be ordered by scoping
-tcSuperSkolTyVars tc_lvl skol_info = mapAccumL do_one emptySubst
-  where
-    details = SkolemTv skol_info (pushTcLevel tc_lvl)
-                       True   -- The "super" bit
-    do_one subst tv = (extendTvSubstWithClone subst tv new_tv, new_tv)
-      where
-        kind   = substTyUnchecked subst (tyVarKind tv)
-        new_tv = mkTcTyVar (tyVarName tv) kind details
-
--- | Given a list of @['TyVar']@, skolemize the type variables,
--- returning a substitution mapping the original tyvars to the
--- skolems, and the list of newly bound skolems.
-tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (Subst, [TcTyVar])
--- See Note [Skolemising type variables]
-tcInstSkolTyVars skol_info = tcInstSkolTyVarsX skol_info emptySubst
-
-tcInstSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcM (Subst, [TcTyVar])
--- See Note [Skolemising type variables]
-tcInstSkolTyVarsX skol_info = tcInstSkolTyVarsPushLevel skol_info False
-
-tcInstSuperSkolTyVars :: SkolemInfo -> [TyVar] -> TcM (Subst, [TcTyVar])
--- See Note [Skolemising type variables]
--- This version freshens the names and creates "super skolems";
--- see comments around superSkolemTv.
-tcInstSuperSkolTyVars skol_info = tcInstSuperSkolTyVarsX skol_info emptySubst
-
-tcInstSuperSkolTyVarsX :: SkolemInfo -> Subst -> [TyVar] -> TcM (Subst, [TcTyVar])
--- See Note [Skolemising type variables]
--- This version freshens the names and creates "super skolems";
--- see comments around superSkolemTv.
-tcInstSuperSkolTyVarsX skol_info subst = tcInstSkolTyVarsPushLevel skol_info True subst
-
-tcInstSkolTyVarsPushLevel :: SkolemInfo -> Bool  -- True <=> make "super skolem"
-                          -> Subst -> [TyVar]
-                          -> TcM (Subst, [TcTyVar])
--- Skolemise one level deeper, hence pushTcLevel
--- See Note [Skolemising type variables]
-tcInstSkolTyVarsPushLevel skol_info overlappable subst tvs
-  = do { tc_lvl <- getTcLevel
-       -- Do not retain the whole TcLclEnv
-       ; let !pushed_lvl = pushTcLevel tc_lvl
-       ; tcInstSkolTyVarsAt skol_info pushed_lvl overlappable subst tvs }
-
-tcInstSkolTyVarsAt :: SkolemInfo -> TcLevel -> Bool
-                   -> Subst -> [TyVar]
-                   -> TcM (Subst, [TcTyVar])
-tcInstSkolTyVarsAt skol_info lvl overlappable subst tvs
-  = freshenTyCoVarsX new_skol_tv subst tvs
-  where
-    sk_details = SkolemTv skol_info lvl overlappable
-    new_skol_tv name kind = mkTcTyVar name kind sk_details
-
-tcSkolemiseInvisibleBndrs :: SkolemInfoAnon -> Type -> TcM ([TcTyVar], TcType)
--- Skolemise the outer invisible binders of a type
--- Do /not/ freshen them, because their scope is broader than
--- just this type.  It's a bit dubious, but used in very limited ways.
-tcSkolemiseInvisibleBndrs skol_info ty
-  = do { let (tvs, body_ty) = tcSplitForAllInvisTyVars ty
-       ; lvl           <- getTcLevel
-       ; skol_info     <- mkSkolemInfo skol_info
-       ; let details = SkolemTv skol_info lvl False
-             mk_skol_tv name kind = return (mkTcTyVar name kind details)  -- No freshening
-       ; (subst, tvs') <- instantiateTyVarsX mk_skol_tv emptySubst tvs
-       ; return (tvs', substTy subst body_ty) }
-
-instantiateTyVarsX :: (Name -> Kind -> TcM TcTyVar)
-                   -> Subst -> [TyVar]
-                   -> TcM (Subst, [TcTyVar])
--- Instantiate each type variable in turn with the specified function
-instantiateTyVarsX mk_tv subst tvs
-  = case tvs of
-      []       -> return (subst, [])
-      (tv:tvs) -> do { let kind1 = substTyUnchecked subst (tyVarKind tv)
-                     ; tv' <- mk_tv (tyVarName tv) kind1
-                     ; let subst1 = extendTCvSubstWithClone subst tv tv'
-                     ; (subst', tvs') <- instantiateTyVarsX mk_tv subst1 tvs
-                     ; return (subst', tv':tvs') }
-
-------------------
-freshenTyVarBndrs :: [TyVar] -> TcM (Subst, [TyVar])
--- ^ Give fresh uniques to a bunch of TyVars, but they stay
---   as TyVars, rather than becoming TcTyVars
--- Used in 'GHC.Tc.Instance.Family.newFamInst', and 'GHC.Tc.Utils.Instantiate.newClsInst'
-freshenTyVarBndrs = freshenTyCoVars mkTyVar
-
-freshenCoVarBndrsX :: Subst -> [CoVar] -> TcM (Subst, [CoVar])
--- ^ Give fresh uniques to a bunch of CoVars
--- Used in "GHC.Tc.Instance.Family.newFamInst"
-freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst
-
-------------------
-freshenTyCoVars :: (Name -> Kind -> TyCoVar)
-                -> [TyVar] -> TcM (Subst, [TyCoVar])
-freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptySubst
-
-freshenTyCoVarsX :: (Name -> Kind -> TyCoVar)
-                 -> Subst -> [TyCoVar]
-                 -> TcM (Subst, [TyCoVar])
--- This a complete freshening operation:
--- the skolems have a fresh unique, and a location from the monad
--- See Note [Skolemising type variables]
-freshenTyCoVarsX mk_tcv
-  = instantiateTyVarsX freshen_tcv
-  where
-    freshen_tcv :: Name -> Kind -> TcM TcTyVar
-    freshen_tcv name kind
-      = do { loc  <- getSrcSpanM
-           ; uniq <- newUnique
-           ; let !occ_name = getOccName name
-                    -- Force so we don't retain reference to the old
-                    -- name and id.   See (#19619) for more discussion
-                 new_name = mkInternalName uniq occ_name loc
-           ; return (mk_tcv new_name kind) }
-
-{- Note [Skolemising type variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The tcInstSkolTyVars family of functions instantiate a list of TyVars
-to fresh skolem TcTyVars. Important notes:
-
-a) Level allocation. We generally skolemise /before/ calling
-   pushLevelAndCaptureConstraints.  So we want their level to the level
-   of the soon-to-be-created implication, which has a level ONE HIGHER
-   than the current level.  Hence the pushTcLevel.  It feels like a
-   slight hack.
-
-b) The [TyVar] should be ordered (kind vars first)
-   See Note [Kind substitution when instantiating]
-
-c) Clone the variable to give a fresh unique.  This is essential.
-   Consider (tc160)
-       type Foo x = forall a. a -> x
-   And typecheck the expression
-       (e :: Foo (Foo ())
-   We will skolemise the signature, but after expanding synonyms it
-   looks like
-        forall a. a -> forall a. a -> x
-   We don't want to make two big-lambdas with the same unique!
-
-d) We retain locations. Because the location of the variable is the correct
-   location to report in errors (e.g. in the signature). We don't want the
-   location to change to the body of the function, which does *not* explicitly
-   bind the variable.
-
-e) The resulting skolems are
-        non-overlappable for tcInstSkolTyVars,
-   but overlappable for tcInstSuperSkolTyVars
-   See GHC.Tc.Deriv.Infer Note [Overlap and deriving] for an example
-   of where this matters.
-
-Note [Kind substitution when instantiating]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we instantiate a bunch of kind and type variables, first we
-expect them to be topologically sorted.
-Then we have to instantiate the kind variables, build a substitution
-from old variables to the new variables, then instantiate the type
-variables substituting the original kind.
-
-Example: If we want to instantiate
-  [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)]
-we want
-  [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)]
-instead of the bogus
-  [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)]
--}
-
-{- *********************************************************************
-*                                                                      *
-                Literals
-*                                                                      *
-********************************************************************* -}
-
-{-
-In newOverloadedLit we convert directly to an Int or Integer if we
-know that's what we want.  This may save some time, by not
-temporarily generating overloaded literals, but it won't catch all
-cases (the rest are caught in lookupInst).
-
--}
-
-newOverloadedLit :: HsOverLit GhcRn
-                 -> ExpRhoType
-                 -> TcM (HsOverLit GhcTc)
-newOverloadedLit lit res_ty
-  = do { mb_lit' <- tcShortCutLit lit res_ty
-       ; case mb_lit' of
-            Just lit' -> return lit'
-            Nothing   -> newNonTrivialOverloadedLit lit res_ty }
-
--- Does not handle things that 'shortCutLit' can handle. See also
--- newOverloadedLit in GHC.Tc.Utils.Unify
-newNonTrivialOverloadedLit :: HsOverLit GhcRn
-                           -> ExpRhoType
-                           -> TcM (HsOverLit GhcTc)
-newNonTrivialOverloadedLit
-  lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable (L _ meth_name) })
-  res_ty
-  = do  { hs_lit <- mkOverLit val
-        ; let lit_ty = hsLitType hs_lit
-        ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
-                                      [synKnownType lit_ty] res_ty $
-                      \_ _ -> return ()
-        ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
-        ; res_ty <- readExpType res_ty
-        ; return (lit { ol_ext = OverLitTc { ol_rebindable = rebindable
-                                           , ol_witness = witness
-                                           , ol_type = res_ty } }) }
-  where
-    orig = LiteralOrigin lit
-
-------------
-mkOverLit ::OverLitVal -> TcM (HsLit GhcTc)
-mkOverLit (HsIntegral i)
-  = do  { integer_ty <- tcMetaTy integerTyConName
-        ; return (HsInteger (il_text i)
-                            (il_value i) integer_ty) }
-
-mkOverLit (HsFractional r)
-  = do  { rat_ty <- tcMetaTy rationalTyConName
-        ; return (HsRat noExtField r rat_ty) }
-
-mkOverLit (HsIsString src s) = return (HsString src s)
-
-{-
-************************************************************************
-*                                                                      *
-                Re-mappable syntax
-
-     Used only for arrow syntax -- find a way to nuke this
-*                                                                      *
-************************************************************************
-
-Suppose we are doing the -XRebindableSyntax thing, and we encounter
-a do-expression.  We have to find (>>) in the current environment, which is
-done by the rename. Then we have to check that it has the same type as
-Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
-this:
-
-  (>>) :: HB m n mn => m a -> n b -> mn b
-
-So the idea is to generate a local binding for (>>), thus:
-
-        let then72 :: forall a b. m a -> m b -> m b
-            then72 = ...something involving the user's (>>)...
-        in
-        ...the do-expression...
-
-Now the do-expression can proceed using then72, which has exactly
-the expected type.
-
-In fact tcSyntaxName just generates the RHS for then72, because we only
-want an actual binding in the do-expression case. For literals, we can
-just use the expression inline.
--}
-
-tcSyntaxName :: CtOrigin
-             -> TcType                  -- ^ Type to instantiate it at
-             -> (Name, HsExpr GhcRn)    -- ^ (Standard name, user name)
-             -> TcM (Name, HsExpr GhcTc)
-                                        -- ^ (Standard name, suitable expression)
--- USED ONLY FOR CmdTop (sigh) ***
--- See Note [CmdSyntaxTable] in "GHC.Hs.Expr"
-
-tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))
-  | std_nm == user_nm
-  = do rhs <- newMethodFromName orig std_nm [ty]
-       return (std_nm, rhs)
-
-tcSyntaxName orig ty (std_nm, user_nm_expr) = do
-    std_id <- tcLookupId std_nm
-    let
-        ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
-        sigma1         = substTyWith [tv] [ty] tau
-        -- Actually, the "tau-type" might be a sigma-type in the
-        -- case of locally-polymorphic methods.
-
-    span <- getSrcSpanM
-    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1 span) $ do
-
-        -- Check that the user-supplied thing has the
-        -- same type as the standard one.
-        -- Tiresome jiggling because tcCheckSigma takes a located expression
-     expr <- tcCheckPolyExpr (L (noAnnSrcSpan span) user_nm_expr) sigma1
-     hasFixedRuntimeRepRes std_nm user_nm_expr sigma1
-     return (std_nm, unLoc expr)
-
-syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> SrcSpan -> TidyEnv
-               -> TcRn (TidyEnv, SDoc)
-syntaxNameCtxt name orig ty loc tidy_env = return (tidy_env, msg)
-  where
-    msg = vcat [ text "When checking that" <+> quotes (ppr name)
-                          <+> text "(needed by a syntactic construct)"
-               , nest 2 (text "has the required type:"
-                         <+> ppr (tidyType tidy_env ty))
-               , nest 2 (sep [ppr orig, text "at" <+> ppr loc])]
-
-{-
-************************************************************************
-*                                                                      *
-                FixedRuntimeRep
-*                                                                      *
-************************************************************************
--}
-
--- | Check that the result type of an expression has a fixed runtime representation.
---
--- Used only for arrow operations such as 'arr', 'first', etc.
-hasFixedRuntimeRepRes :: Name -> HsExpr GhcRn -> TcSigmaType -> TcM ()
-hasFixedRuntimeRepRes std_nm user_expr ty = mapM_ do_check mb_arity
-  where
-   do_check :: Arity -> TcM ()
-   do_check arity =
-     let res_ty = nTimes arity (snd . splitPiTy) ty
-     in hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowFun user_expr) res_ty
-   mb_arity :: Maybe Arity
-   mb_arity -- arity of the arrow operation, counting type-level arguments
-     | std_nm == arrAName     -- result used as an argument in, e.g., do_premap
-     = Just 3
-     | std_nm == composeAName -- result used as an argument in, e.g., dsCmdStmt/BodyStmt
-     = Just 5
-     | std_nm == firstAName   -- result used as an argument in, e.g., dsCmdStmt/BodyStmt
-     = Just 4
-     | std_nm == appAName     -- result used as an argument in, e.g., dsCmd/HsCmdArrApp/HsHigherOrderApp
-     = Just 2
-     | std_nm == choiceAName  -- result used as an argument in, e.g., HsCmdIf
-     = Just 5
-     | std_nm == loopAName    -- result used as an argument in, e.g., HsCmdIf
-     = Just 4
-     | otherwise
-     = Nothing
-
-{-
-************************************************************************
-*                                                                      *
-                Instances
-*                                                                      *
-************************************************************************
--}
-
-getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
--- Construct the OverlapFlag from the global module flags,
--- but if the overlap_mode argument is (Just m),
---     set the OverlapMode to 'm'
-getOverlapFlag overlap_mode
-  = do  { dflags <- getDynFlags
-        ; let overlap_ok    = xopt LangExt.OverlappingInstances dflags
-              incoherent_ok = xopt LangExt.IncoherentInstances  dflags
-              use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
-                                  , overlapMode   = x }
-              default_oflag | incoherent_ok = use (Incoherent NoSourceText)
-                            | overlap_ok    = use (Overlaps NoSourceText)
-                            | otherwise     = use (NoOverlap NoSourceText)
-
-              final_oflag = setOverlapModeMaybe default_oflag overlap_mode
-        ; return final_oflag }
-
-tcGetInsts :: TcM [ClsInst]
--- Gets the local class instances.
-tcGetInsts = fmap tcg_insts getGblEnv
-
-newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
-           -> Class -> [Type] -> TcM ClsInst
-newClsInst overlap_mode dfun_name tvs theta clas tys
-  = do { (subst, tvs') <- freshenTyVarBndrs tvs
-             -- Be sure to freshen those type variables,
-             -- so they are sure not to appear in any lookup
-       ; let tys' = substTys subst tys
-
-             dfun = mkDictFunId dfun_name tvs theta clas tys
-             -- The dfun uses the original 'tvs' because
-             -- (a) they don't need to be fresh
-             -- (b) they may be mentioned in the ib_binds field of
-             --     an InstInfo, and in GHC.Tc.Utils.Env.pprInstInfoDetails it's
-             --     helpful to use the same names
-
-       ; oflag <- getOverlapFlag overlap_mode
-       ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
-       ; when (isOrphan (is_orphan inst)) $
-          addDiagnostic (TcRnOrphanInstance inst)
-       ; return inst }
-
-tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
-  -- Add new locally-defined instances
-tcExtendLocalInstEnv dfuns thing_inside
- = do { traceDFuns dfuns
-      ; env <- getGblEnv
-      -- Force the access to the TcgEnv so it isn't retained.
-      -- During auditing it is much easier to observe in -hi profiles if
-      -- there are a very small number of TcGblEnv. Keeping a TcGblEnv
-      -- alive is quite dangerous because it contains reference to many
-      -- large data structures.
-      ; let !init_inst_env = tcg_inst_env env
-            !init_insts = tcg_insts env
-      ; (inst_env', cls_insts') <- foldlM addLocalInst
-                                          (init_inst_env, init_insts)
-                                          dfuns
-      ; let env' = env { tcg_insts    = cls_insts'
-                       , tcg_inst_env = inst_env' }
-      ; setGblEnv env' thing_inside }
-
-addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
--- Check that the proposed new instance is OK,
--- and then add it to the home inst env
--- If overwrite_inst, then we can overwrite a direct match
-addLocalInst (home_ie, my_insts) ispec
-   = do {
-             -- Load imported instances, so that we report
-             -- duplicates correctly
-
-             -- 'matches'  are existing instance declarations that are less
-             --            specific than the new one
-             -- 'dups'     are those 'matches' that are equal to the new one
-         ; isGHCi <- getIsGHCi
-         ; eps    <- getEps
-         ; tcg_env <- getGblEnv
-
-           -- In GHCi, we *override* any identical instances
-           -- that are also defined in the interactive context
-           -- See Note [Override identical instances in GHCi]
-         ; let home_ie'
-                 | isGHCi    = deleteFromInstEnv home_ie ispec
-                 | otherwise = home_ie
-
-               global_ie = eps_inst_env eps
-               inst_envs = InstEnvs { ie_global  = global_ie
-                                    , ie_local   = home_ie'
-                                    , ie_visible = tcVisibleOrphanMods tcg_env }
-
-             -- Check for inconsistent functional dependencies
-         ; let inconsistent_ispecs = checkFunDeps inst_envs ispec
-         ; unless (null inconsistent_ispecs) $
-           funDepErr ispec inconsistent_ispecs
-
-             -- Check for duplicate instance decls.
-         ; let (_tvs, cls, tys) = instanceHead ispec
-               (matches, _, _)  = lookupInstEnv False inst_envs cls tys
-               dups             = filter (identicalClsInstHead ispec) (map fst matches)
-         ; unless (null dups) $
-           dupInstErr ispec (head dups)
-
-         ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
-
-{-
-Note [Signature files and type class instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Instances in signature files do not have an effect when compiling:
-when you compile a signature against an implementation, you will
-see the instances WHETHER OR NOT the instance is declared in
-the file (this is because the signatures go in the EPS and we
-can't filter them out easily.)  This is also why we cannot
-place the instance in the hi file: it would show up as a duplicate,
-and we don't have instance reexports anyway.
-
-However, you might find them useful when typechecking against
-a signature: the instance is a way of indicating to GHC that
-some instance exists, in case downstream code uses it.
-
-Implementing this is a little tricky.  Consider the following
-situation (sigof03):
-
- module A where
-     instance C T where ...
-
- module ASig where
-     instance C T
-
-When compiling ASig, A.hi is loaded, which brings its instances
-into the EPS.  When we process the instance declaration in ASig,
-we should ignore it for the purpose of doing a duplicate check,
-since it's not actually a duplicate. But don't skip the check
-entirely, we still want this to fail (tcfail221):
-
- module ASig where
-     instance C T
-     instance C T
-
-Note that in some situations, the interface containing the type
-class instances may not have been loaded yet at all.  The usual
-situation when A imports another module which provides the
-instances (sigof02m):
-
- module A(module B) where
-     import B
-
-See also Note [Signature lazy interface loading].  We can't
-rely on this, however, since sometimes we'll have spurious
-type class instances in the EPS, see #9422 (sigof02dm)
-
-************************************************************************
-*                                                                      *
-        Errors and tracing
-*                                                                      *
-************************************************************************
--}
-
-traceDFuns :: [ClsInst] -> TcRn ()
-traceDFuns ispecs
-  = traceTc "Adding instances:" (vcat (map pp ispecs))
-  where
-    pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
-                  2 (ppr ispec)
-        -- Print the dfun name itself too
-
-funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
-funDepErr ispec ispecs
-  = addClsInstsErr TcRnFunDepConflict (ispec NE.:| ispecs)
-
-dupInstErr :: ClsInst -> ClsInst -> TcRn ()
-dupInstErr ispec dup_ispec
-  = addClsInstsErr TcRnDupInstanceDecls (ispec NE.:| [dup_ispec])
-
-addClsInstsErr :: (UnitState -> NE.NonEmpty ClsInst -> TcRnMessage)
-               -> NE.NonEmpty ClsInst
-               -> TcRn ()
-addClsInstsErr mkErr ispecs = do
-   unit_state <- hsc_units <$> getTopEnv
-   setSrcSpan (getSrcSpan (NE.head sorted)) $
-      addErr $ mkErr unit_state sorted
- where
-   sorted = NE.sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs
-   -- The sortBy just arranges that instances are displayed in order
-   -- of source location, which reduced wobbling in error messages,
-   -- and is better for users
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ /dev/null
@@ -1,2283 +0,0 @@
-{-# LANGUAGE BangPatterns      #-}
-{-# LANGUAGE ExplicitForAll    #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE RecordWildCards   #-}
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-{-
-(c) The University of Glasgow 2006
-
--}
-
--- | Functions for working with the typechecker environment (setters,
--- getters...).
-module GHC.Tc.Utils.Monad(
-  -- * Initialisation
-  initTc, initTcWithGbl, initTcInteractive, initTcRnIf,
-
-  -- * Simple accessors
-  discardResult,
-  getTopEnv, updTopEnv, getGblEnv, updGblEnv,
-  setGblEnv, getLclEnv, updLclEnv, setLclEnv, restoreLclEnv,
-  updTopFlags,
-  getEnvs, setEnvs, updEnvs, restoreEnvs,
-  xoptM, doptM, goptM, woptM,
-  setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,
-  whenDOptM, whenGOptM, whenWOptM,
-  whenXOptM, unlessXOptM,
-  getGhcMode,
-  withoutDynamicNow,
-  getEpsVar,
-  getEps,
-  updateEps, updateEps_,
-  getHpt, getEpsAndHug,
-
-  -- * Arrow scopes
-  newArrowScope, escapeArrowScope,
-
-  -- * Unique supply
-  newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName,
-  newSysName, newSysLocalId, newSysLocalIds,
-
-  -- * Accessing input/output
-  newTcRef, readTcRef, writeTcRef, updTcRef,
-
-  -- * Debugging
-  traceTc, traceRn, traceOptTcRn, dumpOptTcRn,
-  dumpTcRn,
-  getNamePprCtx,
-  printForUserTcRn,
-  traceIf, traceOptIf,
-  debugTc,
-
-  -- * Typechecker global environment
-  getIsGHCi, getGHCiMonad, getInteractivePrintName,
-  tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv,
-  getRdrEnvs, getImports,
-  getFixityEnv, extendFixityEnv, getRecFieldEnv,
-  getDeclaredDefaultTys,
-  addDependentFiles,
-
-  -- * Error management
-  getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, inGeneratedCode,
-  wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
-  wrapLocMA_,wrapLocMA,
-  getErrsVar, setErrsVar,
-  addErr,
-  failWith, failAt,
-  addErrAt, addErrs,
-  checkErr,
-  addMessages,
-  discardWarnings, mkDetailedMessage,
-
-  -- * Usage environment
-  tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,
-
-  -- * Shared error message stuff: renamer and typechecker
-  recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
-  attemptM, tryTc,
-  askNoErrs, discardErrs, tryTcDiscardingErrs,
-  checkNoErrs, whenNoErrs,
-  ifErrsM, failIfErrsM,
-
-  -- * Context management for the type checker
-  getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
-  addLandmarkErrCtxtM, popErrCtxt, getCtLocM, setCtLocM,
-
-  -- * Diagnostic message generation (type checker)
-  addErrTc,
-  addErrTcM,
-  failWithTc, failWithTcM,
-  checkTc, checkTcM,
-  failIfTc, failIfTcM,
-  mkErrInfo,
-  addTcRnDiagnostic, addDetailedDiagnostic,
-  mkTcRnMessage, reportDiagnostic, reportDiagnostics,
-  warnIf, diagnosticTc, diagnosticTcM,
-  addDiagnosticTc, addDiagnosticTcM, addDiagnostic, addDiagnosticAt,
-
-  -- * Type constraints
-  newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,
-  addTcEvBind, addTopEvBinds,
-  getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
-  chooseUniqueOccTc,
-  getConstraintVar, setConstraintVar,
-  emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
-  emitImplication, emitImplications, emitInsoluble,
-  emitDelayedErrors, emitHole, emitHoles, emitNotConcreteError,
-  discardConstraints, captureConstraints, tryCaptureConstraints,
-  pushLevelAndCaptureConstraints,
-  pushTcLevelM_, pushTcLevelM,
-  getTcLevel, setTcLevel, isTouchableTcM,
-  getLclTypeEnv, setLclTypeEnv,
-  traceTcConstraints,
-  emitNamedTypeHole, IsExtraConstraint(..), emitAnonTypeHole,
-
-  -- * Template Haskell context
-  recordThUse, recordThSpliceUse, recordThNeededRuntimeDeps,
-  keepAlive, getStage, getStageAndBindLevel, setStage,
-  addModFinalizersWithLclEnv,
-
-  -- * Safe Haskell context
-  recordUnsafeInfer, finalSafeMode, fixSafeInstances,
-
-  -- * Stuff for the renamer's local env
-  getLocalRdrEnv, setLocalRdrEnv,
-
-  -- * Stuff for interface decls
-  mkIfLclEnv,
-  initIfaceTcRn,
-  initIfaceCheck,
-  initIfaceLcl,
-  initIfaceLclWithSubst,
-  initIfaceLoad,
-  initIfaceLoadModule,
-  getIfModule,
-  failIfM,
-  forkM,
-  setImplicitEnvM,
-
-  withException,
-
-  -- * Stuff for cost centres.
-  getCCIndexM, getCCIndexTcM,
-
-  -- * Types etc.
-  module GHC.Tc.Types,
-  module GHC.Data.IOEnv
-  ) where
-
-import GHC.Prelude
-
-
-import GHC.Builtin.Names
-
-import GHC.Tc.Types     -- Re-export all
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.Origin
-import GHC.Tc.Utils.TcType
-
-import GHC.Hs hiding (LIE)
-
-import GHC.Unit
-import GHC.Unit.Env
-import GHC.Unit.External
-import GHC.Unit.Module.Warnings
-import GHC.Unit.Home.ModInfo
-
-import GHC.Core.UsageEnv
-import GHC.Core.Multiplicity
-import GHC.Core.InstEnv
-import GHC.Core.FamInstEnv
-
-import GHC.Driver.Env
-import GHC.Driver.Session
-import GHC.Driver.Config.Diagnostic
-
-import GHC.Runtime.Context
-
-import GHC.Data.IOEnv -- Re-export all
-import GHC.Data.Bag
-import GHC.Data.FastString
-import GHC.Data.Maybe
-
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Error
-import GHC.Utils.Panic
-import GHC.Utils.Constants (debugIsOn)
-import GHC.Utils.Logger
-import qualified GHC.Data.Strict as Strict
-
-import GHC.Types.Error
-import GHC.Types.Fixity.Env
-import GHC.Types.Name.Reader
-import GHC.Types.Name
-import GHC.Types.SafeHaskell
-import GHC.Types.Id
-import GHC.Types.TypeEnv
-import GHC.Types.Var.Set
-import GHC.Types.Var.Env
-import GHC.Types.SrcLoc
-import GHC.Types.Name.Env
-import GHC.Types.Name.Set
-import GHC.Types.Name.Ppr
-import GHC.Types.Unique.FM ( emptyUFM )
-import GHC.Types.Unique.Supply
-import GHC.Types.Annotations
-import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) )
-import GHC.Types.CostCentre.State
-import GHC.Types.SourceFile
-
-import qualified GHC.LanguageExtensions as LangExt
-
-import Data.IORef
-import Control.Monad
-
-import GHC.Tc.Errors.Types
-import {-# SOURCE #-} GHC.Tc.Utils.Env    ( tcInitTidyEnv )
-
-import qualified Data.Map as Map
-import GHC.Driver.Env.KnotVars
-import GHC.Linker.Types
-import GHC.Types.Unique.DFM
-
-{-
-************************************************************************
-*                                                                      *
-                        initTc
-*                                                                      *
-************************************************************************
--}
-
--- | Setup the initial typechecking environment
-initTc :: HscEnv
-       -> HscSource
-       -> Bool          -- True <=> retain renamed syntax trees
-       -> Module
-       -> RealSrcSpan
-       -> TcM r
-       -> IO (Messages TcRnMessage, Maybe r)
-                -- Nothing => error thrown by the thing inside
-                -- (error messages should have been printed already)
-
-initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
- = do { keep_var     <- newIORef emptyNameSet ;
-        used_gre_var <- newIORef [] ;
-        th_var       <- newIORef False ;
-        th_splice_var<- newIORef False ;
-        infer_var    <- newIORef True ;
-        infer_reasons_var <- newIORef emptyMessages ;
-        dfun_n_var   <- newIORef emptyOccSet ;
-        let { type_env_var = hsc_type_env_vars hsc_env };
-
-        dependent_files_var <- newIORef [] ;
-        static_wc_var       <- newIORef emptyWC ;
-        cc_st_var           <- newIORef newCostCentreState ;
-        th_topdecls_var      <- newIORef [] ;
-        th_foreign_files_var <- newIORef [] ;
-        th_topnames_var      <- newIORef emptyNameSet ;
-        th_modfinalizers_var <- newIORef [] ;
-        th_coreplugins_var <- newIORef [] ;
-        th_state_var         <- newIORef Map.empty ;
-        th_remote_state_var  <- newIORef Nothing ;
-        th_docs_var          <- newIORef Map.empty ;
-        th_needed_deps_var   <- newIORef ([], emptyUDFM) ;
-        next_wrapper_num     <- newIORef emptyModuleEnv ;
-        let {
-             -- bangs to avoid leaking the env (#19356)
-             !dflags = hsc_dflags hsc_env ;
-             !mhome_unit = hsc_home_unit_maybe hsc_env;
-             !logger = hsc_logger hsc_env ;
-
-             maybe_rn_syntax :: forall a. a -> Maybe a ;
-             maybe_rn_syntax empty_val
-                | logHasDumpFlag logger Opt_D_dump_rn_ast = Just empty_val
-
-                | gopt Opt_WriteHie dflags       = Just empty_val
-
-                  -- We want to serialize the documentation in the .hi-files,
-                  -- and need to extract it from the renamed syntax first.
-                  -- See 'GHC.HsToCore.Docs.extractDocs'.
-                | gopt Opt_Haddock dflags       = Just empty_val
-
-                | keep_rn_syntax                = Just empty_val
-                | otherwise                     = Nothing ;
-
-             gbl_env = TcGblEnv {
-                tcg_th_topdecls      = th_topdecls_var,
-                tcg_th_foreign_files = th_foreign_files_var,
-                tcg_th_topnames      = th_topnames_var,
-                tcg_th_modfinalizers = th_modfinalizers_var,
-                tcg_th_coreplugins = th_coreplugins_var,
-                tcg_th_state         = th_state_var,
-                tcg_th_remote_state  = th_remote_state_var,
-                tcg_th_docs          = th_docs_var,
-
-                tcg_mod            = mod,
-                tcg_semantic_mod   = homeModuleInstantiation mhome_unit mod,
-                tcg_src            = hsc_src,
-                tcg_rdr_env        = emptyGlobalRdrEnv,
-                tcg_fix_env        = emptyNameEnv,
-                tcg_field_env      = emptyNameEnv,
-                tcg_default        = if moduleUnit mod == primUnit
-                                     || moduleUnit mod == bignumUnit
-                                     then Just []  -- See Note [Default types]
-                                     else Nothing,
-                tcg_type_env       = emptyNameEnv,
-                tcg_type_env_var   = type_env_var,
-                tcg_inst_env       = emptyInstEnv,
-                tcg_fam_inst_env   = emptyFamInstEnv,
-                tcg_ann_env        = emptyAnnEnv,
-                tcg_th_used        = th_var,
-                tcg_th_splice_used = th_splice_var,
-                tcg_th_needed_deps = th_needed_deps_var,
-                tcg_exports        = [],
-                tcg_imports        = emptyImportAvails,
-                tcg_used_gres     = used_gre_var,
-                tcg_dus            = emptyDUs,
-
-                tcg_rn_imports     = [],
-                tcg_rn_exports     =
-                    if hsc_src == HsigFile
-                        -- Always retain renamed syntax, so that we can give
-                        -- better errors.  (TODO: how?)
-                        then Just []
-                        else maybe_rn_syntax [],
-                tcg_rn_decls       = maybe_rn_syntax emptyRnGroup,
-                tcg_tr_module      = Nothing,
-                tcg_binds          = emptyLHsBinds,
-                tcg_imp_specs      = [],
-                tcg_sigs           = emptyNameSet,
-                tcg_ksigs          = emptyNameSet,
-                tcg_ev_binds       = emptyBag,
-                tcg_warns          = NoWarnings,
-                tcg_anns           = [],
-                tcg_tcs            = [],
-                tcg_insts          = [],
-                tcg_fam_insts      = [],
-                tcg_rules          = [],
-                tcg_fords          = [],
-                tcg_patsyns        = [],
-                tcg_merged         = [],
-                tcg_dfun_n         = dfun_n_var,
-                tcg_keep           = keep_var,
-                tcg_doc_hdr        = Nothing,
-                tcg_hpc            = False,
-                tcg_main           = Nothing,
-                tcg_self_boot      = NoSelfBoot,
-                tcg_safe_infer     = infer_var,
-                tcg_safe_infer_reasons = infer_reasons_var,
-                tcg_dependent_files = dependent_files_var,
-                tcg_tc_plugin_solvers   = [],
-                tcg_tc_plugin_rewriters = emptyUFM,
-                tcg_defaulting_plugins  = [],
-                tcg_hf_plugins     = [],
-                tcg_top_loc        = loc,
-                tcg_static_wc      = static_wc_var,
-                tcg_complete_matches = [],
-                tcg_cc_st          = cc_st_var,
-                tcg_next_wrapper_num = next_wrapper_num
-             } ;
-        } ;
-
-        -- OK, here's the business end!
-        initTcWithGbl hsc_env gbl_env loc do_this
-    }
-
--- | Run a 'TcM' action in the context of an existing 'GblEnv'.
-initTcWithGbl :: HscEnv
-              -> TcGblEnv
-              -> RealSrcSpan
-              -> TcM r
-              -> IO (Messages TcRnMessage, Maybe r)
-initTcWithGbl hsc_env gbl_env loc do_this
- = do { lie_var      <- newIORef emptyWC
-      ; errs_var     <- newIORef emptyMessages
-      ; usage_var    <- newIORef zeroUE
-      ; let lcl_env = TcLclEnv {
-                tcl_errs       = errs_var,
-                tcl_loc        = loc,
-                -- tcl_loc should be over-ridden very soon!
-                tcl_in_gen_code = False,
-                tcl_ctxt       = [],
-                tcl_rdr        = emptyLocalRdrEnv,
-                tcl_th_ctxt    = topStage,
-                tcl_th_bndrs   = emptyNameEnv,
-                tcl_arrow_ctxt = NoArrowCtxt,
-                tcl_env        = emptyNameEnv,
-                tcl_usage      = usage_var,
-                tcl_bndrs      = [],
-                tcl_lie        = lie_var,
-                tcl_tclvl      = topTcLevel
-                }
-
-      ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
-                     do { r <- tryM do_this
-                        ; case r of
-                          Right res -> return (Just res)
-                          Left _    -> return Nothing }
-
-      -- Check for unsolved constraints
-      -- If we succeed (maybe_res = Just r), there should be
-      -- no unsolved constraints.  But if we exit via an
-      -- exception (maybe_res = Nothing), we may have skipped
-      -- solving, so don't panic then (#13466)
-      ; lie <- readIORef (tcl_lie lcl_env)
-      ; when (isJust maybe_res && not (isEmptyWC lie)) $
-        pprPanic "initTc: unsolved constraints" (ppr lie)
-
-        -- Collect any error messages
-      ; msgs <- readIORef (tcl_errs lcl_env)
-
-      ; let { final_res | errorsFound msgs = Nothing
-                        | otherwise        = maybe_res }
-
-      ; return (msgs, final_res)
-      }
-
-initTcInteractive :: HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
--- Initialise the type checker monad for use in GHCi
-initTcInteractive hsc_env thing_inside
-  = initTc hsc_env HsSrcFile False
-           (icInteractiveModule (hsc_IC hsc_env))
-           (realSrcLocSpan interactive_src_loc)
-           thing_inside
-  where
-    interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
-
-{- Note [Default types]
-~~~~~~~~~~~~~~~~~~~~~~~
-The Integer type is simply not available in ghc-prim and ghc-bignum packages (it
-is declared in ghc-bignum). So we set the defaulting types to (Just []), meaning
-there are no default types, rather than Nothing, which means "use the default
-default types of Integer, Double".
-
-If you don't do this, attempted defaulting in package ghc-prim causes
-an actual crash (attempting to look up the Integer type).
-
-
-************************************************************************
-*                                                                      *
-                Initialisation
-*                                                                      *
-************************************************************************
--}
-
-initTcRnIf :: Char              -- ^ Mask for unique supply
-           -> HscEnv
-           -> gbl -> lcl
-           -> TcRnIf gbl lcl a
-           -> IO a
-initTcRnIf uniq_mask hsc_env gbl_env lcl_env thing_inside
-   = do { let { env = Env { env_top = hsc_env,
-                            env_um  = uniq_mask,
-                            env_gbl = gbl_env,
-                            env_lcl = lcl_env} }
-
-        ; runIOEnv env thing_inside
-        }
-
-{-
-************************************************************************
-*                                                                      *
-                Simple accessors
-*                                                                      *
-************************************************************************
--}
-
-discardResult :: TcM a -> TcM ()
-discardResult a = a >> return ()
-
-getTopEnv :: TcRnIf gbl lcl HscEnv
-getTopEnv = do { env <- getEnv; return (env_top env) }
-
-updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
-                          env { env_top = upd top })
-
-getGblEnv :: TcRnIf gbl lcl gbl
-getGblEnv = do { Env{..} <- getEnv; return env_gbl }
-
-updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
-                          env { env_gbl = upd gbl })
-
-setGblEnv :: gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
-setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
-
-getLclEnv :: TcRnIf gbl lcl lcl
-getLclEnv = do { Env{..} <- getEnv; return env_lcl }
-
-updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
-                          env { env_lcl = upd lcl })
-
-
-setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
-setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
-
-restoreLclEnv :: TcLclEnv -> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
--- See Note [restoreLclEnv vs setLclEnv]
-restoreLclEnv new_lcl_env = updLclEnv upd
-  where
-    upd old_lcl_env =  new_lcl_env { tcl_errs  = tcl_errs  old_lcl_env
-                                   , tcl_lie   = tcl_lie   old_lcl_env
-                                   , tcl_usage = tcl_usage old_lcl_env }
-
-getEnvs :: TcRnIf gbl lcl (gbl, lcl)
-getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
-
-setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
-setEnvs (gbl_env, lcl_env) = setGblEnv gbl_env . setLclEnv lcl_env
-
-updEnvs :: ((gbl,lcl) -> (gbl, lcl)) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-updEnvs upd_envs = updEnv upd
-  where
-    upd env@(Env { env_gbl = gbl, env_lcl = lcl })
-      = env { env_gbl = gbl', env_lcl = lcl' }
-      where
-        !(gbl', lcl') = upd_envs (gbl, lcl)
-
-restoreEnvs :: (TcGblEnv, TcLclEnv) -> TcRn a -> TcRn a
--- See Note [restoreLclEnv vs setLclEnv]
-restoreEnvs (gbl, lcl) = setGblEnv gbl . restoreLclEnv lcl
-
-{- Note [restoreLclEnv vs setLclEnv]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In the typechecker we use this idiom quite a lot
-   do { (gbl_env, lcl_env) <- tcRnSrcDecls ...
-      ; setGblEnv gbl_env $ setLclEnv lcl_env $
-        more_stuff }
-
-The `tcRnSrcDecls` extends the environments in `gbl_env` and `lcl_env`
-which we then want to be in scope in `more stuff`.
-
-The problem is that `lcl_env :: TcLclEnv` has an IORef for error
-messages `tcl_errs`, and another for constraints (`tcl_lie`), and
-another for Linear Haskell usage information (`tcl_usage`).  Now
-suppose we change it a tiny bit
-   do { (gbl_env, lcl_env) <- checkNoErrs $
-                              tcRnSrcDecls ...
-      ; setGblEnv gbl_env $ setLclEnv lcl_env $
-        more_stuff }
-
-That should be innocuous.  But *alas*, `checkNoErrs` gathers errors in
-a fresh IORef *which is then captured in the returned `lcl_env`.  When
-we do the `setLclEnv` we'll make that captured IORef into the place
-where we gather error messages -- but no one is going to look at that!!!
-This led to #19470 and #20981.
-
-Solution: instead of setLclEnv use restoreLclEnv, which preserves from
-the /parent/ context these mutable collection IORefs:
-      tcl_errs, tcl_lie, tcl_usage
--}
-
--- Command-line flags
-
-xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool
-xoptM flag = xopt flag <$> getDynFlags
-
-doptM :: DumpFlag -> TcRnIf gbl lcl Bool
-doptM flag = do
-  logger <- getLogger
-  return (logHasDumpFlag logger flag)
-
-goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
-goptM flag = gopt flag <$> getDynFlags
-
-woptM :: WarningFlag -> TcRnIf gbl lcl Bool
-woptM flag = wopt flag <$> getDynFlags
-
-setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-setXOptM flag = updTopFlags (\dflags -> xopt_set dflags flag)
-
-unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-unsetXOptM flag = updTopFlags (\dflags -> xopt_unset dflags flag)
-
-unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-unsetGOptM flag = updTopFlags (\dflags -> gopt_unset dflags flag)
-
-unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-unsetWOptM flag = updTopFlags (\dflags -> wopt_unset dflags flag)
-
--- | Do it flag is true
-whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
-whenDOptM flag thing_inside = do b <- doptM flag
-                                 when b thing_inside
-{-# INLINE whenDOptM #-} -- see Note [INLINE conditional tracing utilities]
-
-
-whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
-whenGOptM flag thing_inside = do b <- goptM flag
-                                 when b thing_inside
-{-# INLINE whenGOptM #-} -- see Note [INLINE conditional tracing utilities]
-
-whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
-whenWOptM flag thing_inside = do b <- woptM flag
-                                 when b thing_inside
-{-# INLINE whenWOptM #-} -- see Note [INLINE conditional tracing utilities]
-
-whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
-whenXOptM flag thing_inside = do b <- xoptM flag
-                                 when b thing_inside
-{-# INLINE whenXOptM #-} -- see Note [INLINE conditional tracing utilities]
-
-unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
-unlessXOptM flag thing_inside = do b <- xoptM flag
-                                   unless b thing_inside
-{-# INLINE unlessXOptM #-} -- see Note [INLINE conditional tracing utilities]
-
-getGhcMode :: TcRnIf gbl lcl GhcMode
-getGhcMode = ghcMode <$> getDynFlags
-
-withoutDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-withoutDynamicNow = updTopFlags (\dflags -> dflags { dynamicNow = False})
-
-updTopFlags :: (DynFlags -> DynFlags) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
-updTopFlags f = updTopEnv (hscUpdateFlags f)
-
-getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
-getEpsVar = do
-  env <- getTopEnv
-  return (euc_eps (ue_eps (hsc_unit_env env)))
-
-getEps :: TcRnIf gbl lcl ExternalPackageState
-getEps = do { env <- getTopEnv; liftIO $ hscEPS env }
-
--- | Update the external package state.  Returns the second result of the
--- modifier function.
---
--- This is an atomic operation and forces evaluation of the modified EPS in
--- order to avoid space leaks.
-updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
-          -> TcRnIf gbl lcl a
-updateEps upd_fn = do
-  traceIf (text "updating EPS")
-  eps_var <- getEpsVar
-  atomicUpdMutVar' eps_var upd_fn
-
--- | Update the external package state.
---
--- This is an atomic operation and forces evaluation of the modified EPS in
--- order to avoid space leaks.
-updateEps_ :: (ExternalPackageState -> ExternalPackageState)
-           -> TcRnIf gbl lcl ()
-updateEps_ upd_fn = updateEps (\eps -> (upd_fn eps, ()))
-
-getHpt :: TcRnIf gbl lcl HomePackageTable
-getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
-
-getEpsAndHug :: TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph)
-getEpsAndHug = do { env <- getTopEnv; eps <- liftIO $ hscEPS env
-                  ; return (eps, hsc_HUG env) }
-
--- | A convenient wrapper for taking a @MaybeErr SDoc a@ and throwing
--- an exception if it is an error.
-withException :: MonadIO m => SDocContext -> m (MaybeErr SDoc a) -> m a
-withException ctx do_this = do
-    r <- do_this
-    case r of
-        Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (renderWithContext ctx err))
-        Succeeded result -> return result
-
-{-
-************************************************************************
-*                                                                      *
-                Arrow scopes
-*                                                                      *
-************************************************************************
--}
-
-newArrowScope :: TcM a -> TcM a
-newArrowScope
-  = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }
-
--- Return to the stored environment (from the enclosing proc)
-escapeArrowScope :: TcM a -> TcM a
-escapeArrowScope
-  = updLclEnv $ \ env ->
-    case tcl_arrow_ctxt env of
-      NoArrowCtxt       -> env
-      ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
-                                   , tcl_lie = lie
-                                   , tcl_rdr = rdr_env }
-
-{-
-************************************************************************
-*                                                                      *
-                Unique supply
-*                                                                      *
-************************************************************************
--}
-
-newUnique :: TcRnIf gbl lcl Unique
-newUnique
- = do { env <- getEnv
-      ; let mask = env_um env
-      ; liftIO $! uniqFromMask mask }
-
-newUniqueSupply :: TcRnIf gbl lcl UniqSupply
-newUniqueSupply
- = do { env <- getEnv
-      ; let mask = env_um env
-      ; liftIO $! mkSplitUniqSupply mask }
-
-cloneLocalName :: Name -> TcM Name
--- Make a fresh Internal name with the same OccName and SrcSpan
-cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name)
-
-newName :: OccName -> TcM Name
-newName occ = do { loc  <- getSrcSpanM
-                 ; newNameAt occ loc }
-
-newNameAt :: OccName -> SrcSpan -> TcM Name
-newNameAt occ span
-  = do { uniq <- newUnique
-       ; return (mkInternalName uniq occ span) }
-
-newSysName :: OccName -> TcRnIf gbl lcl Name
-newSysName occ
-  = do { uniq <- newUnique
-       ; return (mkSystemName uniq occ) }
-
-newSysLocalId :: FastString -> Mult -> TcType -> TcRnIf gbl lcl TcId
-newSysLocalId fs w ty
-  = do  { u <- newUnique
-        ; return (mkSysLocal fs u w ty) }
-
-newSysLocalIds :: FastString -> [Scaled TcType] -> TcRnIf gbl lcl [TcId]
-newSysLocalIds fs tys
-  = do  { us <- newUniqueSupply
-        ; let mkId' n (Scaled w t) = mkSysLocal fs n w t
-        ; return (zipWith mkId' (uniqsFromSupply us) tys) }
-
-instance MonadUnique (IOEnv (Env gbl lcl)) where
-        getUniqueM = newUnique
-        getUniqueSupplyM = newUniqueSupply
-
-{-
-************************************************************************
-*                                                                      *
-                Accessing input/output
-*                                                                      *
-************************************************************************
--}
-
-newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
-newTcRef = newMutVar
-
-readTcRef :: TcRef a -> TcRnIf gbl lcl a
-readTcRef = readMutVar
-
-writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
-writeTcRef = writeMutVar
-
-updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
--- Returns ()
-updTcRef ref fn = liftIO $ modifyIORef' ref fn
-
-{-
-************************************************************************
-*                                                                      *
-                Debugging
-*                                                                      *
-************************************************************************
--}
-
-{- Note [INLINE conditional tracing utilities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In general we want to optimise for the case where tracing is not enabled.
-To ensure this happens, we ensure that traceTc and friends are inlined; this
-ensures that the allocation of the document can be pushed into the tracing
-path, keeping the non-traced path free of this extraneous work. For
-instance, if we don't inline traceTc, we'll get
-
-    let stuff_to_print = ...
-    in traceTc "wombat" stuff_to_print
-
-and the stuff_to_print thunk will be allocated in the "hot path", regardless
-of tracing.  But if we INLINE traceTc we get
-
-    let stuff_to_print = ...
-    in if doTracing
-         then emitTraceMsg "wombat" stuff_to_print
-         else return ()
-
-and then we float in:
-
-    if doTracing
-      then let stuff_to_print = ...
-           in emitTraceMsg "wombat" stuff_to_print
-      else return ()
-
-Now stuff_to_print is allocated only in the "cold path".
-
-Moreover, on the "cold" path, after the conditional, we want to inline
-as /little/ as possible.  Performance doesn't matter here, and we'd like
-to bloat the caller's code as little as possible.  So we put a NOINLINE
-on 'emitTraceMsg'
-
-See #18168.
--}
-
--- Typechecker trace
-traceTc :: String -> SDoc -> TcRn ()
-traceTc herald doc =
-    labelledTraceOptTcRn Opt_D_dump_tc_trace herald doc
-{-# INLINE traceTc #-} -- see Note [INLINE conditional tracing utilities]
-
--- Renamer Trace
-traceRn :: String -> SDoc -> TcRn ()
-traceRn herald doc =
-    labelledTraceOptTcRn Opt_D_dump_rn_trace herald doc
-{-# INLINE traceRn #-} -- see Note [INLINE conditional tracing utilities]
-
--- | Trace when a certain flag is enabled. This is like `traceOptTcRn`
--- but accepts a string as a label and formats the trace message uniformly.
-labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()
-labelledTraceOptTcRn flag herald doc =
-  traceOptTcRn flag (formatTraceMsg herald doc)
-{-# INLINE labelledTraceOptTcRn #-} -- see Note [INLINE conditional tracing utilities]
-
-formatTraceMsg :: String -> SDoc -> SDoc
-formatTraceMsg herald doc = hang (text herald) 2 doc
-
-traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
-traceOptTcRn flag doc =
-  whenDOptM flag $
-    dumpTcRn False flag "" FormatText doc
-{-# INLINE traceOptTcRn #-} -- see Note [INLINE conditional tracing utilities]
-
--- | Dump if the given 'DumpFlag' is set.
-dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()
-dumpOptTcRn flag title fmt doc =
-  whenDOptM flag $
-    dumpTcRn False flag title fmt doc
-{-# INLINE dumpOptTcRn #-} -- see Note [INLINE conditional tracing utilities]
-
--- | Unconditionally dump some trace output
---
--- Certain tests (T3017, Roles3, T12763 etc.) expect part of the
--- output generated by `-ddump-types` to be in 'PprUser' style. However,
--- generally we want all other debugging output to use 'PprDump'
--- style. We 'PprUser' style if 'useUserStyle' is True.
---
-dumpTcRn :: Bool -> DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()
-dumpTcRn useUserStyle flag title fmt doc = do
-  logger <- getLogger
-  name_ppr_ctx <- getNamePprCtx
-  real_doc <- wrapDocLoc doc
-  let sty = if useUserStyle
-              then mkUserStyle name_ppr_ctx AllTheWay
-              else mkDumpStyle name_ppr_ctx
-  liftIO $ logDumpFile logger sty flag title fmt real_doc
-
--- | Add current location if -dppr-debug
--- (otherwise the full location is usually way too much)
-wrapDocLoc :: SDoc -> TcRn SDoc
-wrapDocLoc doc = do
-  logger <- getLogger
-  if logHasDumpFlag logger Opt_D_ppr_debug
-    then do
-      loc <- getSrcSpanM
-      return (mkLocMessage MCOutput loc doc)
-    else
-      return doc
-
-getNamePprCtx :: TcRn NamePprCtx
-getNamePprCtx
-  = do { ptc <- initPromotionTickContext <$> getDynFlags
-       ; rdr_env <- getGlobalRdrEnv
-       ; hsc_env <- getTopEnv
-       ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env }
-
--- | Like logInfoTcRn, but for user consumption
-printForUserTcRn :: SDoc -> TcRn ()
-printForUserTcRn doc = do
-    logger <- getLogger
-    name_ppr_ctx <- getNamePprCtx
-    liftIO (printOutputForUser logger name_ppr_ctx doc)
-
-{-
-traceIf works in the TcRnIf monad, where no RdrEnv is
-available.  Alas, they behave inconsistently with the other stuff;
-e.g. are unaffected by -dump-to-file.
--}
-
-traceIf :: SDoc -> TcRnIf m n ()
-traceIf = traceOptIf Opt_D_dump_if_trace
-{-# INLINE traceIf #-}
-  -- see Note [INLINE conditional tracing utilities]
-
-traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
-traceOptIf flag doc
-  = whenDOptM flag $ do   -- No RdrEnv available, so qualify everything
-        logger <- getLogger
-        liftIO (putMsg logger doc)
-{-# INLINE traceOptIf #-}  -- see Note [INLINE conditional tracing utilities]
-
-{-
-************************************************************************
-*                                                                      *
-                Typechecker global environment
-*                                                                      *
-************************************************************************
--}
-
-getIsGHCi :: TcRn Bool
-getIsGHCi = do { mod <- getModule
-               ; return (isInteractiveModule mod) }
-
-getGHCiMonad :: TcRn Name
-getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
-
-getInteractivePrintName :: TcRn Name
-getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
-
-tcIsHsBootOrSig :: TcRn Bool
-tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
-
-tcIsHsig :: TcRn Bool
-tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) }
-
-tcSelfBootInfo :: TcRn SelfBootInfo
-tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }
-
-getGlobalRdrEnv :: TcRn GlobalRdrEnv
-getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
-
-getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
-getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
-
-getImports :: TcRn ImportAvails
-getImports = do { env <- getGblEnv; return (tcg_imports env) }
-
-getFixityEnv :: TcRn FixityEnv
-getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
-
-extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
-extendFixityEnv new_bit
-  = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
-                env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
-
-getRecFieldEnv :: TcRn RecFieldEnv
-getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
-
-getDeclaredDefaultTys :: TcRn (Maybe [Type])
-getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
-
-addDependentFiles :: [FilePath] -> TcRn ()
-addDependentFiles fs = do
-  ref <- fmap tcg_dependent_files getGblEnv
-  dep_files <- readTcRef ref
-  writeTcRef ref (fs ++ dep_files)
-
-{-
-************************************************************************
-*                                                                      *
-                Error management
-*                                                                      *
-************************************************************************
--}
-
-getSrcSpanM :: TcRn SrcSpan
-        -- Avoid clash with Name.getSrcLoc
-getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Strict.Nothing) }
-
--- See Note [Error contexts in generated code]
-inGeneratedCode :: TcRn Bool
-inGeneratedCode = tcl_in_gen_code <$> getLclEnv
-
-setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
--- See Note [Error contexts in generated code]
--- for the tcl_in_gen_code manipulation
-setSrcSpan (RealSrcSpan loc _) thing_inside
-  = updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False })
-              thing_inside
-
-setSrcSpan loc@(UnhelpfulSpan _) thing_inside
-  | isGeneratedSrcSpan loc
-  = updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside
-
-  | otherwise
-  = thing_inside
-
-setSrcSpanA :: SrcSpanAnn' ann -> TcRn a -> TcRn a
-setSrcSpanA l = setSrcSpan (locA l)
-
-addLocM :: (a -> TcM b) -> Located a -> TcM b
-addLocM fn (L loc a) = setSrcSpan loc $ fn a
-
-addLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
-addLocMA fn (L loc a) = setSrcSpanA loc $ fn a
-
-wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
-wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a
-                                            ; return (L loc b) }
-
-wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b)
-wrapLocAM fn a = wrapLocM fn (reLoc a)
-
-wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b)
-wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a
-                                              ; return (L loc b) }
-
-wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
-wrapLocFstM fn (L loc a) =
-  setSrcSpan loc $ do
-    (b,c) <- fn a
-    return (L loc b, c)
-
--- Possible instantiations:
---    wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA    a -> TcM (LocatedA    b, c)
---    wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedN    a -> TcM (LocatedN    b, c)
---    wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedAn t a -> TcM (LocatedAn t b, c)
--- and so on.
-wrapLocFstMA :: (a -> TcM (b,c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (GenLocated (SrcSpanAnn' ann) b, c)
-wrapLocFstMA fn (L loc a) =
-  setSrcSpanA loc $ do
-    (b,c) <- fn a
-    return (L loc b, c)
-
-wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c)
-wrapLocSndM fn (L loc a) =
-  setSrcSpan loc $ do
-    (b,c) <- fn a
-    return (b, L loc c)
-
--- Possible instantiations:
---    wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA    a -> TcM (b, LocatedA    c)
---    wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedN    a -> TcM (b, LocatedN    c)
---    wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedAn t a -> TcM (b, LocatedAn t c)
--- and so on.
-wrapLocSndMA :: (a -> TcM (b, c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (b, GenLocated (SrcSpanAnn' ann) c)
-wrapLocSndMA fn (L loc a) =
-  setSrcSpanA loc $ do
-    (b,c) <- fn a
-    return (b, L loc c)
-
-wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM ()
-wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a)
-
-wrapLocMA_ :: (a -> TcM ()) -> LocatedA a -> TcM ()
-wrapLocMA_ fn (L loc a) = setSrcSpan (locA loc) (fn a)
-
--- Reporting errors
-
-getErrsVar :: TcRn (TcRef (Messages TcRnMessage))
-getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
-
-setErrsVar :: TcRef (Messages TcRnMessage) -> TcRn a -> TcRn a
-setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
-
-addErr :: TcRnMessage -> TcRn ()
-addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
-
-failWith :: TcRnMessage -> TcRn a
-failWith msg = addErr msg >> failM
-
-failAt :: SrcSpan -> TcRnMessage -> TcRn a
-failAt loc msg = addErrAt loc msg >> failM
-
-addErrAt :: SrcSpan -> TcRnMessage -> TcRn ()
--- addErrAt is mainly (exclusively?) used by the renamer, where
--- tidying is not an issue, but it's all lazy so the extra
--- work doesn't matter
-addErrAt loc msg = do { ctxt <- getErrCtxt
-                      ; tidy_env <- tcInitTidyEnv
-                      ; err_info <- mkErrInfo tidy_env ctxt
-                      ; let detailed_msg = mkDetailedMessage (ErrInfo err_info Outputable.empty) msg
-                      ; add_long_err_at loc detailed_msg }
-
-mkDetailedMessage :: ErrInfo -> TcRnMessage -> TcRnMessageDetailed
-mkDetailedMessage err_info msg =
-  TcRnMessageDetailed err_info msg
-
-addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn ()
-addErrs msgs = mapM_ add msgs
-             where
-               add (loc,msg) = addErrAt loc msg
-
-checkErr :: Bool -> TcRnMessage -> TcRn ()
--- Add the error if the bool is False
-checkErr ok msg = unless ok (addErr msg)
-
-addMessages :: Messages TcRnMessage -> TcRn ()
-addMessages msgs1
-  = do { errs_var <- getErrsVar
-       ; msgs0    <- readTcRef errs_var
-       ; writeTcRef errs_var (msgs0 `unionMessages` msgs1) }
-
-discardWarnings :: TcRn a -> TcRn a
--- Ignore warnings inside the thing inside;
--- used to ignore-unused-variable warnings inside derived code
-discardWarnings thing_inside
-  = do  { errs_var <- getErrsVar
-        ; old_warns <- getWarningMessages <$> readTcRef errs_var
-
-        ; result <- thing_inside
-
-        -- Revert warnings to old_warns
-        ; new_errs <- getErrorMessages <$> readTcRef errs_var
-        ; writeTcRef errs_var $ mkMessages (old_warns `unionBags` new_errs)
-
-        ; return result }
-
-{-
-************************************************************************
-*                                                                      *
-        Shared error message stuff: renamer and typechecker
-*                                                                      *
-************************************************************************
--}
-
-add_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn ()
-add_long_err_at loc msg = mk_long_err_at loc msg >>= reportDiagnostic
-  where
-    mk_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn (MsgEnvelope TcRnMessage)
-    mk_long_err_at loc msg
-      = do { name_ppr_ctx <- getNamePprCtx ;
-             unit_state <- hsc_units <$> getTopEnv ;
-             return $ mkErrorMsgEnvelope loc name_ppr_ctx
-                    $ TcRnMessageWithInfo unit_state msg
-                    }
-
-mkTcRnMessage :: SrcSpan
-              -> TcRnMessage
-              -> TcRn (MsgEnvelope TcRnMessage)
-mkTcRnMessage loc msg
-  = do { name_ppr_ctx <- getNamePprCtx ;
-         diag_opts <- initDiagOpts <$> getDynFlags ;
-         return $ mkMsgEnvelope diag_opts loc name_ppr_ctx msg }
-
-reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM ()
-reportDiagnostics = mapM_ reportDiagnostic
-
-reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn ()
-reportDiagnostic msg
-  = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelopeDefault msg) ;
-         errs_var <- getErrsVar ;
-         msgs     <- readTcRef errs_var ;
-         writeTcRef errs_var (msg `addMessage` msgs) }
-
------------------------
-checkNoErrs :: TcM r -> TcM r
--- (checkNoErrs m) succeeds iff m succeeds and generates no errors
--- If m fails then (checkNoErrs m) fails.
--- If m succeeds, it checks whether m generated any errors messages
---      (it might have recovered internally)
---      If so, it fails too.
--- Regardless, any errors generated by m are propagated to the enclosing context.
-checkNoErrs main
-  = do  { (res, no_errs) <- askNoErrs main
-        ; unless no_errs failM
-        ; return res }
-
------------------------
-whenNoErrs :: TcM () -> TcM ()
-whenNoErrs thing = ifErrsM (return ()) thing
-
-ifErrsM :: TcRn r -> TcRn r -> TcRn r
---      ifErrsM bale_out normal
--- does 'bale_out' if there are errors in errors collection
--- otherwise does 'normal'
-ifErrsM bale_out normal
- = do { errs_var <- getErrsVar ;
-        msgs <- readTcRef errs_var ;
-        if errorsFound msgs then
-           bale_out
-        else
-           normal }
-
-failIfErrsM :: TcRn ()
--- Useful to avoid error cascades
-failIfErrsM = ifErrsM failM (return ())
-
-{- *********************************************************************
-*                                                                      *
-        Context management for the type checker
-*                                                                      *
-************************************************************************
--}
-
-{- Note [Inlining addErrCtxt]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-You will notice a bunch of INLINE pragamas on addErrCtxt and friends.
-The reason is to promote better eta-expansion in client modules.
-Consider
-    \e s. addErrCtxt c (tc_foo x) e s
-It looks as if tc_foo is applied to only two arguments, but if we
-inline addErrCtxt it'll turn into something more like
-    \e s. tc_foo x (munge c e) s
-This is much better because Called Arity analysis can see that tc_foo
-is applied to four arguments.  See #18379 for a concrete example.
-
-This reliance on delicate inlining and Called Arity is not good.
-See #18202 for a more general approach.  But meanwhile, these
-inlinings seem unobjectional, and they solve the immediate
-problem.
-
-Note [Error contexts in generated code]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* setSrcSpan sets tc_in_gen_code to True if the SrcSpan is GeneratedSrcSpan,
-  and back to False when we get a useful SrcSpan
-
-* When tc_in_gen_code is True, addErrCtxt becomes a no-op.
-
-So typically it's better to do setSrcSpan /before/ addErrCtxt.
-
-See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr for
-more discussion of this fancy footwork.
--}
-
-getErrCtxt :: TcM [ErrCtxt]
-getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
-
-setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
-{-# INLINE setErrCtxt #-}   -- Note [Inlining addErrCtxt]
-setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
-
--- | Add a fixed message to the error context. This message should not
--- do any tidying.
-addErrCtxt :: SDoc -> TcM a -> TcM a
-{-# INLINE addErrCtxt #-}   -- Note [Inlining addErrCtxt]
-addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
-
--- | Add a message to the error context. This message may do tidying.
-addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
-{-# INLINE addErrCtxtM #-}  -- Note [Inlining addErrCtxt]
-addErrCtxtM ctxt = pushCtxt (False, ctxt)
-
--- | Add a fixed landmark message to the error context. A landmark
--- message is always sure to be reported, even if there is a lot of
--- context. It also doesn't count toward the maximum number of contexts
--- reported.
-addLandmarkErrCtxt :: SDoc -> TcM a -> TcM a
-{-# INLINE addLandmarkErrCtxt #-}  -- Note [Inlining addErrCtxt]
-addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
-
--- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
--- and tidying.
-addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
-{-# INLINE addLandmarkErrCtxtM #-}  -- Note [Inlining addErrCtxt]
-addLandmarkErrCtxtM ctxt = pushCtxt (True, ctxt)
-
-pushCtxt :: ErrCtxt -> TcM a -> TcM a
-{-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt]
-pushCtxt ctxt = updLclEnv (updCtxt ctxt)
-
-updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv
--- Do not update the context if we are in generated code
--- See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr
-updCtxt ctxt env@(TcLclEnv { tcl_ctxt = ctxts, tcl_in_gen_code = in_gen })
-  | in_gen    = env
-  | otherwise = env { tcl_ctxt = ctxt : ctxts }
-
-popErrCtxt :: TcM a -> TcM a
-popErrCtxt = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
-                          env { tcl_ctxt = pop ctxt })
-           where
-             pop []       = []
-             pop (_:msgs) = msgs
-
-getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
-getCtLocM origin t_or_k
-  = do { env <- getLclEnv
-       ; return (CtLoc { ctl_origin   = origin
-                       , ctl_env      = env
-                       , ctl_t_or_k   = t_or_k
-                       , ctl_depth    = initialSubGoalDepth }) }
-
-setCtLocM :: CtLoc -> TcM a -> TcM a
--- Set the SrcSpan and error context from the CtLoc
-setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
-  = updLclEnv (\env -> env { tcl_loc   = tcl_loc lcl
-                           , tcl_bndrs = tcl_bndrs lcl
-                           , tcl_ctxt  = tcl_ctxt lcl })
-              thing_inside
-
-
-{- *********************************************************************
-*                                                                      *
-             Error recovery and exceptions
-*                                                                      *
-********************************************************************* -}
-
-tcTryM :: TcRn r -> TcRn (Maybe r)
--- The most basic function: catch the exception
---   Nothing => an exception happened
---   Just r  => no exception, result R
--- Errors and constraints are propagated in both cases
--- Never throws an exception
-tcTryM thing_inside
-  = do { either_res <- tryM thing_inside
-       ; return (case either_res of
-                    Left _  -> Nothing
-                    Right r -> Just r) }
-         -- In the Left case the exception is always the IOEnv
-         -- built-in in exception; see IOEnv.failM
-
------------------------
-capture_constraints :: TcM r -> TcM (r, WantedConstraints)
--- capture_constraints simply captures and returns the
---                     constraints generated by thing_inside
--- Precondition: thing_inside must not throw an exception!
--- Reason for precondition: an exception would blow past the place
--- where we read the lie_var, and we'd lose the constraints altogether
-capture_constraints thing_inside
-  = do { lie_var <- newTcRef emptyWC
-       ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $
-                thing_inside
-       ; lie <- readTcRef lie_var
-       ; return (res, lie) }
-
-capture_messages :: TcM r -> TcM (r, Messages TcRnMessage)
--- capture_messages simply captures and returns the
---                  errors arnd warnings generated by thing_inside
--- Precondition: thing_inside must not throw an exception!
--- Reason for precondition: an exception would blow past the place
--- where we read the msg_var, and we'd lose the constraints altogether
-capture_messages thing_inside
-  = do { msg_var <- newTcRef emptyMessages
-       ; res     <- setErrsVar msg_var thing_inside
-       ; msgs    <- readTcRef msg_var
-       ; return (res, msgs) }
-
------------------------
--- (askNoErrs m) runs m
--- If m fails,
---    then (askNoErrs m) fails, propagating only
---         insoluble constraints
---
--- If m succeeds with result r,
---    then (askNoErrs m) succeeds with result (r, b),
---         where b is True iff m generated no errors
---
--- Regardless of success or failure,
---   propagate any errors/warnings generated by m
-askNoErrs :: TcRn a -> TcRn (a, Bool)
-askNoErrs thing_inside
-  = do { ((mb_res, lie), msgs) <- capture_messages    $
-                                  capture_constraints $
-                                  tcTryM thing_inside
-       ; addMessages msgs
-
-       ; case mb_res of
-           Nothing  -> do { emitConstraints (dropMisleading lie)
-                          ; failM }
-
-           Just res -> do { emitConstraints lie
-                          ; let errs_found = errorsFound msgs
-                                          || insolubleWC lie
-                          ; return (res, not errs_found) } }
-
------------------------
-tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints)
--- (tryCaptureConstraints_maybe m) runs m,
---   and returns the type constraints it generates
--- It never throws an exception; instead if thing_inside fails,
---   it returns Nothing and the /insoluble/ constraints
--- Error messages are propagated
-tryCaptureConstraints thing_inside
-  = do { (mb_res, lie) <- capture_constraints $
-                          tcTryM thing_inside
-
-       -- See Note [Constraints and errors]
-       ; let lie_to_keep = case mb_res of
-                             Nothing -> dropMisleading lie
-                             Just {} -> lie
-
-       ; return (mb_res, lie_to_keep) }
-
-captureConstraints :: TcM a -> TcM (a, WantedConstraints)
--- (captureConstraints m) runs m, and returns the type constraints it generates
--- If thing_inside fails (throwing an exception),
---   then (captureConstraints thing_inside) fails too
---   propagating the insoluble constraints only
--- Error messages are propagated in either case
-captureConstraints thing_inside
-  = do { (mb_res, lie) <- tryCaptureConstraints thing_inside
-
-            -- See Note [Constraints and errors]
-            -- If the thing_inside threw an exception, emit the insoluble
-            -- constraints only (returned by tryCaptureConstraints)
-            -- so that they are not lost
-       ; case mb_res of
-           Nothing  -> do { emitConstraints lie; failM }
-           Just res -> return (res, lie) }
-
------------------------
--- | @tcCollectingUsage thing_inside@ runs @thing_inside@ and returns the usage
--- information which was collected as part of the execution of
--- @thing_inside@. Careful: @tcCollectingUsage thing_inside@ itself does not
--- report any usage information, it's up to the caller to incorporate the
--- returned usage information into the larger context appropriately.
-tcCollectingUsage :: TcM a -> TcM (UsageEnv,a)
-tcCollectingUsage thing_inside
-  = do { local_usage_ref <- newTcRef zeroUE
-       ; result <- updLclEnv (\env -> env { tcl_usage = local_usage_ref }) thing_inside
-       ; local_usage <- readTcRef local_usage_ref
-       ; return (local_usage,result) }
-
--- | @tcScalingUsage mult thing_inside@ runs @thing_inside@ and scales all the
--- usage information by @mult@.
-tcScalingUsage :: Mult -> TcM a -> TcM a
-tcScalingUsage mult thing_inside
-  = do { (usage, result) <- tcCollectingUsage thing_inside
-       ; traceTc "tcScalingUsage" (ppr mult)
-       ; tcEmitBindingUsage $ scaleUE mult usage
-       ; return result }
-
-tcEmitBindingUsage :: UsageEnv -> TcM ()
-tcEmitBindingUsage ue
-  = do { lcl_env <- getLclEnv
-       ; let usage = tcl_usage lcl_env
-       ; updTcRef usage (addUE ue) }
-
------------------------
-attemptM :: TcRn r -> TcRn (Maybe r)
--- (attemptM thing_inside) runs thing_inside
--- If thing_inside succeeds, returning r,
---   we return (Just r), and propagate all constraints and errors
--- If thing_inside fail, throwing an exception,
---   we return Nothing, propagating insoluble constraints,
---                      and all errors
--- attemptM never throws an exception
-attemptM thing_inside
-  = do { (mb_r, lie) <- tryCaptureConstraints thing_inside
-       ; emitConstraints lie
-
-       -- Debug trace
-       ; when (isNothing mb_r) $
-         traceTc "attemptM recovering with insoluble constraints" $
-                 (ppr lie)
-
-       ; return mb_r }
-
------------------------
-recoverM :: TcRn r      -- Recovery action; do this if the main one fails
-         -> TcRn r      -- Main action: do this first;
-                        --  if it generates errors, propagate them all
-         -> TcRn r
--- (recoverM recover thing_inside) runs thing_inside
--- If thing_inside fails, propagate its errors and insoluble constraints
---                        and run 'recover'
--- If thing_inside succeeds, propagate all its errors and constraints
---
--- Can fail, if 'recover' fails
-recoverM recover thing
-  = do { mb_res <- attemptM thing ;
-         case mb_res of
-           Nothing  -> recover
-           Just res -> return res }
-
------------------------
-
--- | Drop elements of the input that fail, so the result
--- list can be shorter than the argument list
-mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
-mapAndRecoverM f xs
-  = do { mb_rs <- mapM (attemptM . f) xs
-       ; return [r | Just r <- mb_rs] }
-
--- | Apply the function to all elements on the input list
--- If all succeed, return the list of results
--- Otherwise fail, propagating all errors
-mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
-mapAndReportM f xs
-  = do { mb_rs <- mapM (attemptM . f) xs
-       ; when (any isNothing mb_rs) failM
-       ; return [r | Just r <- mb_rs] }
-
--- | The accumulator is not updated if the action fails
-foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
-foldAndRecoverM _ acc []     = return acc
-foldAndRecoverM f acc (x:xs) =
-                          do { mb_r <- attemptM (f acc x)
-                             ; case mb_r of
-                                Nothing   -> foldAndRecoverM f acc xs
-                                Just acc' -> foldAndRecoverM f acc' xs  }
-
------------------------
-tryTc :: TcRn a -> TcRn (Maybe a, Messages TcRnMessage)
--- (tryTc m) executes m, and returns
---      Just r,  if m succeeds (returning r)
---      Nothing, if m fails
--- It also returns all the errors and warnings accumulated by m
--- It always succeeds (never raises an exception)
-tryTc thing_inside
- = capture_messages (attemptM thing_inside)
-
------------------------
-discardErrs :: TcRn a -> TcRn a
--- (discardErrs m) runs m,
---   discarding all error messages and warnings generated by m
--- If m fails, discardErrs fails, and vice versa
-discardErrs m
- = do { errs_var <- newTcRef emptyMessages
-      ; setErrsVar errs_var m }
-
------------------------
-tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
--- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside';
---      if 'main' succeeds with no error messages, it's the answer
---      otherwise discard everything from 'main', including errors,
---          and try 'recover' instead.
-tryTcDiscardingErrs recover thing_inside
-  = do { ((mb_res, lie), msgs) <- capture_messages    $
-                                  capture_constraints $
-                                  tcTryM thing_inside
-        ; case mb_res of
-            Just res | not (errorsFound msgs)
-                     , not (insolubleWC lie)
-              -> -- 'main' succeeded with no errors
-                 do { addMessages msgs  -- msgs might still have warnings
-                    ; emitConstraints lie
-                    ; return res }
-
-            _ -> -- 'main' failed, or produced an error message
-                 recover     -- Discard all errors and warnings
-                             -- and unsolved constraints entirely
-        }
-
-{-
-************************************************************************
-*                                                                      *
-             Error message generation (type checker)
-*                                                                      *
-************************************************************************
-
-    The addErrTc functions add an error message, but do not cause failure.
-    The 'M' variants pass a TidyEnv that has already been used to
-    tidy up the message; we then use it to tidy the context messages
--}
-
-addErrTc :: TcRnMessage -> TcM ()
-addErrTc err_msg = do { env0 <- tcInitTidyEnv
-                      ; addErrTcM (env0, err_msg) }
-
-addErrTcM :: (TidyEnv, TcRnMessage) -> TcM ()
-addErrTcM (tidy_env, err_msg)
-  = do { ctxt <- getErrCtxt ;
-         loc  <- getSrcSpanM ;
-         add_err_tcm tidy_env err_msg loc ctxt }
-
--- The failWith functions add an error message and cause failure
-
-failWithTc :: TcRnMessage -> TcM a               -- Add an error message and fail
-failWithTc err_msg
-  = addErrTc err_msg >> failM
-
-failWithTcM :: (TidyEnv, TcRnMessage) -> TcM a   -- Add an error message and fail
-failWithTcM local_and_msg
-  = addErrTcM local_and_msg >> failM
-
-checkTc :: Bool -> TcRnMessage -> TcM ()         -- Check that the boolean is true
-checkTc True  _   = return ()
-checkTc False err = failWithTc err
-
-checkTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
-checkTcM True  _   = return ()
-checkTcM False err = failWithTcM err
-
-failIfTc :: Bool -> TcRnMessage -> TcM ()         -- Check that the boolean is false
-failIfTc False _   = return ()
-failIfTc True  err = failWithTc err
-
-failIfTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
-   -- Check that the boolean is false
-failIfTcM False _   = return ()
-failIfTcM True  err = failWithTcM err
-
-
---         Warnings have no 'M' variant, nor failure
-
--- | Display a warning if a condition is met.
-warnIf :: Bool -> TcRnMessage -> TcRn ()
-warnIf is_bad msg -- No need to check any flag here, it will be done in 'diagReasonSeverity'.
-  = when is_bad (addDiagnostic msg)
-
-no_err_info :: ErrInfo
-no_err_info = ErrInfo Outputable.empty Outputable.empty
-
--- | Display a warning if a condition is met.
-diagnosticTc :: Bool -> TcRnMessage -> TcM ()
-diagnosticTc should_report warn_msg
-  | should_report = addDiagnosticTc warn_msg
-  | otherwise     = return ()
-
--- | Display a diagnostic if a condition is met.
-diagnosticTcM :: Bool -> (TidyEnv, TcRnMessage) -> TcM ()
-diagnosticTcM should_report warn_msg
-  | should_report = addDiagnosticTcM warn_msg
-  | otherwise     = return ()
-
--- | Display a diagnostic in the current context.
-addDiagnosticTc :: TcRnMessage -> TcM ()
-addDiagnosticTc msg
- = do { env0 <- tcInitTidyEnv ;
-      addDiagnosticTcM (env0, msg) }
-
--- | Display a diagnostic in a given context.
-addDiagnosticTcM :: (TidyEnv, TcRnMessage) -> TcM ()
-addDiagnosticTcM (env0, msg)
- = do { ctxt <- getErrCtxt
-      ; extra <- mkErrInfo env0 ctxt
-      ; let err_info = ErrInfo extra Outputable.empty
-            detailed_msg = mkDetailedMessage err_info msg
-      ; add_diagnostic detailed_msg }
-
--- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage'
--- given some additional context about the diagnostic.
-addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM ()
-addDetailedDiagnostic mkMsg = do
-  loc <- getSrcSpanM
-  name_ppr_ctx <- getNamePprCtx
-  !diag_opts  <- initDiagOpts <$> getDynFlags
-  env0 <- tcInitTidyEnv
-  ctxt <- getErrCtxt
-  err_info <- mkErrInfo env0 ctxt
-  reportDiagnostic (mkMsgEnvelope diag_opts loc name_ppr_ctx (mkMsg (ErrInfo err_info empty)))
-
-addTcRnDiagnostic :: TcRnMessage -> TcM ()
-addTcRnDiagnostic msg = do
-  loc <- getSrcSpanM
-  mkTcRnMessage loc msg >>= reportDiagnostic
-
--- | Display a diagnostic for the current source location, taken from
--- the 'TcRn' monad.
-addDiagnostic :: TcRnMessage -> TcRn ()
-addDiagnostic msg = add_diagnostic (mkDetailedMessage no_err_info msg)
-
--- | Display a diagnostic for a given source location.
-addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn ()
-addDiagnosticAt loc msg = do
-  unit_state <- hsc_units <$> getTopEnv
-  let detailed_msg = mkDetailedMessage no_err_info msg
-  mkTcRnMessage loc (TcRnMessageWithInfo unit_state detailed_msg) >>= reportDiagnostic
-
--- | Display a diagnostic, with an optional flag, for the current source
--- location.
-add_diagnostic :: TcRnMessageDetailed -> TcRn ()
-add_diagnostic msg
-  = do { loc <- getSrcSpanM
-       ; unit_state <- hsc_units <$> getTopEnv
-       ; mkTcRnMessage loc (TcRnMessageWithInfo unit_state msg) >>= reportDiagnostic
-       }
-
-
-{-
------------------------------------
-        Other helper functions
--}
-
-add_err_tcm :: TidyEnv -> TcRnMessage -> SrcSpan
-            -> [ErrCtxt]
-            -> TcM ()
-add_err_tcm tidy_env msg loc ctxt
- = do { err_info <- mkErrInfo tidy_env ctxt ;
-        add_long_err_at loc (mkDetailedMessage (ErrInfo err_info Outputable.empty) msg) }
-
-mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
--- Tidy the error info, trimming excessive contexts
-mkErrInfo env ctxts
---  = do
---       dbg <- hasPprDebug <$> getDynFlags
---       if dbg                -- In -dppr-debug style the output
---          then return empty  -- just becomes too voluminous
---          else go dbg 0 env ctxts
- = go False 0 env ctxts
- where
-   go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
-   go _ _ _   [] = return empty
-   go dbg n env ((is_landmark, ctxt) : ctxts)
-     | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg
-     = do { (env', msg) <- ctxt env
-          ; let n' = if is_landmark then n else n+1
-          ; rest <- go dbg n' env' ctxts
-          ; return (msg $$ rest) }
-     | otherwise
-     = go dbg n env ctxts
-
-mAX_CONTEXTS :: Int     -- No more than this number of non-landmark contexts
-mAX_CONTEXTS = 3
-
--- debugTc is useful for monadic debugging code
-
-debugTc :: TcM () -> TcM ()
-debugTc thing
- | debugIsOn = thing
- | otherwise = return ()
-
-{-
-************************************************************************
-*                                                                      *
-             Type constraints
-*                                                                      *
-************************************************************************
--}
-
-addTopEvBinds :: Bag EvBind -> TcM a -> TcM a
-addTopEvBinds new_ev_binds thing_inside
-  =updGblEnv upd_env thing_inside
-  where
-    upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env
-                                               `unionBags` new_ev_binds }
-
-newTcEvBinds :: TcM EvBindsVar
-newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
-                  ; tcvs_ref  <- newTcRef emptyVarSet
-                  ; uniq <- newUnique
-                  ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
-                  ; return (EvBindsVar { ebv_binds = binds_ref
-                                       , ebv_tcvs = tcvs_ref
-                                       , ebv_uniq = uniq }) }
-
--- | Creates an EvBindsVar incapable of holding any bindings. It still
--- tracks covar usages (see comments on ebv_tcvs in "GHC.Tc.Types.Evidence"), thus
--- must be made monadically
-newNoTcEvBinds :: TcM EvBindsVar
-newNoTcEvBinds
-  = do { tcvs_ref  <- newTcRef emptyVarSet
-       ; uniq <- newUnique
-       ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)
-       ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref
-                              , ebv_uniq = uniq }) }
-
-cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
--- Clone the refs, so that any binding created when
--- solving don't pollute the original
-cloneEvBindsVar ebv@(EvBindsVar {})
-  = do { binds_ref <- newTcRef emptyEvBindMap
-       ; tcvs_ref  <- newTcRef emptyVarSet
-       ; return (ebv { ebv_binds = binds_ref
-                     , ebv_tcvs = tcvs_ref }) }
-cloneEvBindsVar ebv@(CoEvBindsVar {})
-  = do { tcvs_ref  <- newTcRef emptyVarSet
-       ; return (ebv { ebv_tcvs = tcvs_ref }) }
-
-getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
-getTcEvTyCoVars ev_binds_var
-  = readTcRef (ebv_tcvs ev_binds_var)
-
-getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
-getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })
-  = readTcRef ev_ref
-getTcEvBindsMap (CoEvBindsVar {})
-  = return emptyEvBindMap
-
-setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()
-setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds
-  = writeTcRef ev_ref binds
-setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds
-  | isEmptyEvBindMap ev_binds
-  = return ()
-  | otherwise
-  = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds)
-
-addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
--- Add a binding to the TcEvBinds by side effect
-addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
-  = do { traceTc "addTcEvBind" $ ppr u $$
-                                 ppr ev_bind
-       ; bnds <- readTcRef ev_ref
-       ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
-addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind
-  = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u)
-
-chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
-chooseUniqueOccTc fn =
-  do { env <- getGblEnv
-     ; let dfun_n_var = tcg_dfun_n env
-     ; set <- readTcRef dfun_n_var
-     ; let occ = fn set
-     ; writeTcRef dfun_n_var (extendOccSet set occ)
-     ; return occ }
-
-getConstraintVar :: TcM (TcRef WantedConstraints)
-getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
-
-setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
-setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
-
-emitStaticConstraints :: WantedConstraints -> TcM ()
-emitStaticConstraints static_lie
-  = do { gbl_env <- getGblEnv
-       ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }
-
-emitConstraints :: WantedConstraints -> TcM ()
-emitConstraints ct
-  | isEmptyWC ct
-  = return ()
-  | otherwise
-  = do { lie_var <- getConstraintVar ;
-         updTcRef lie_var (`andWC` ct) }
-
-emitSimple :: Ct -> TcM ()
-emitSimple ct
-  = do { lie_var <- getConstraintVar ;
-         updTcRef lie_var (`addSimples` unitBag ct) }
-
-emitSimples :: Cts -> TcM ()
-emitSimples cts
-  = do { lie_var <- getConstraintVar ;
-         updTcRef lie_var (`addSimples` cts) }
-
-emitImplication :: Implication -> TcM ()
-emitImplication ct
-  = do { lie_var <- getConstraintVar ;
-         updTcRef lie_var (`addImplics` unitBag ct) }
-
-emitImplications :: Bag Implication -> TcM ()
-emitImplications ct
-  = unless (isEmptyBag ct) $
-    do { lie_var <- getConstraintVar ;
-         updTcRef lie_var (`addImplics` ct) }
-
-emitInsoluble :: Ct -> TcM ()
-emitInsoluble ct
-  = do { traceTc "emitInsoluble" (ppr ct)
-       ; lie_var <- getConstraintVar
-       ; updTcRef lie_var (`addInsols` unitBag ct) }
-
-emitDelayedErrors :: Bag DelayedError -> TcM ()
-emitDelayedErrors errs
-  = do { traceTc "emitDelayedErrors" (ppr errs)
-       ; lie_var <- getConstraintVar
-       ; updTcRef lie_var (`addDelayedErrors` errs)}
-
-emitHole :: Hole -> TcM ()
-emitHole hole
-  = do { traceTc "emitHole" (ppr hole)
-       ; lie_var <- getConstraintVar
-       ; updTcRef lie_var (`addHoles` unitBag hole) }
-
-emitHoles :: Bag Hole -> TcM ()
-emitHoles holes
-  = do { traceTc "emitHoles" (ppr holes)
-       ; lie_var <- getConstraintVar
-       ; updTcRef lie_var (`addHoles` holes) }
-
-emitNotConcreteError :: NotConcreteError -> TcM ()
-emitNotConcreteError err
-  = do { traceTc "emitNotConcreteError" (ppr err)
-       ; lie_var <- getConstraintVar
-       ; updTcRef lie_var (`addNotConcreteError` err) }
-
--- | Throw out any constraints emitted by the thing_inside
-discardConstraints :: TcM a -> TcM a
-discardConstraints thing_inside = fst <$> captureConstraints thing_inside
-
--- | The name says it all. The returned TcLevel is the *inner* TcLevel.
-pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
-pushLevelAndCaptureConstraints thing_inside
-  = do { tclvl <- getTcLevel
-       ; let tclvl' = pushTcLevel tclvl
-       ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl')
-       ; (res, lie) <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) $
-                       captureConstraints thing_inside
-       ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl')
-       ; return (tclvl', lie, res) }
-
-pushTcLevelM_ :: TcM a -> TcM a
-pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
-
-pushTcLevelM :: TcM a -> TcM (TcLevel, a)
--- See Note [TcLevel assignment] in GHC.Tc.Utils.TcType
-pushTcLevelM thing_inside
-  = do { tclvl <- getTcLevel
-       ; let tclvl' = pushTcLevel tclvl
-       ; res <- updLclEnv (\env -> env { tcl_tclvl = tclvl' }) thing_inside
-       ; return (tclvl', res) }
-
-getTcLevel :: TcM TcLevel
-getTcLevel = do { env <- getLclEnv
-                ; return (tcl_tclvl env) }
-
-setTcLevel :: TcLevel -> TcM a -> TcM a
-setTcLevel tclvl thing_inside
-  = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
-
-isTouchableTcM :: TcTyVar -> TcM Bool
-isTouchableTcM tv
-  = do { lvl <- getTcLevel
-       ; return (isTouchableMetaTyVar lvl tv) }
-
-getLclTypeEnv :: TcM TcTypeEnv
-getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
-
-setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
--- Set the local type envt, but do *not* disturb other fields,
--- notably the lie_var
-setLclTypeEnv lcl_env thing_inside
-  = updLclEnv upd thing_inside
-  where
-    upd env = env { tcl_env = tcl_env lcl_env }
-
-traceTcConstraints :: String -> TcM ()
-traceTcConstraints msg
-  = do { lie_var <- getConstraintVar
-       ; lie     <- readTcRef lie_var
-       ; traceOptTcRn Opt_D_dump_tc_trace $
-         hang (text (msg ++ ": LIE:")) 2 (ppr lie)
-       }
-
-data IsExtraConstraint = YesExtraConstraint
-                       | NoExtraConstraint
-
-instance Outputable IsExtraConstraint where
-  ppr YesExtraConstraint = text "YesExtraConstraint"
-  ppr NoExtraConstraint  = text "NoExtraConstraint"
-
-emitAnonTypeHole :: IsExtraConstraint
-                 -> TcTyVar -> TcM ()
-emitAnonTypeHole extra_constraints tv
-  = do { ct_loc <- getCtLocM (TypeHoleOrigin occ) Nothing
-       ; let hole = Hole { hole_sort = sort
-                         , hole_occ  = occ
-                         , hole_ty   = mkTyVarTy tv
-                         , hole_loc  = ct_loc }
-       ; emitHole hole }
-  where
-    occ = mkTyVarOccFS (fsLit "_")
-    sort | YesExtraConstraint <- extra_constraints = ConstraintHole
-         | otherwise                               = TypeHole
-
-emitNamedTypeHole :: (Name, TcTyVar) -> TcM ()
-emitNamedTypeHole (name, tv)
-  = do { ct_loc <- setSrcSpan (nameSrcSpan name) $
-                   getCtLocM (TypeHoleOrigin occ) Nothing
-       ; let hole = Hole { hole_sort = TypeHole
-                         , hole_occ  = occ
-                         , hole_ty   = mkTyVarTy tv
-                         , hole_loc  = ct_loc }
-       ; emitHole hole }
-  where
-    occ       = nameOccName name
-
-{- Note [Constraints and errors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this (#12124):
-
-  foo :: Maybe Int
-  foo = return (case Left 3 of
-                  Left -> 1  -- Hard error here!
-                  _    -> 0)
-
-The call to 'return' will generate a (Monad m) wanted constraint; but
-then there'll be "hard error" (i.e. an exception in the TcM monad), from
-the unsaturated Left constructor pattern.
-
-We'll recover in tcPolyBinds, using recoverM.  But then the final
-tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
-un-filled-in, and will emit a misleading error message.
-
-The underlying problem is that an exception interrupts the constraint
-gathering process. Bottom line: if we have an exception, it's best
-simply to discard any gathered constraints.  Hence in 'attemptM' we
-capture the constraints in a fresh variable, and only emit them into
-the surrounding context if we exit normally.  If an exception is
-raised, simply discard the collected constraints... we have a hard
-error to report.  So this capture-the-emit dance isn't as stupid as it
-looks :-).
-
-However suppose we throw an exception inside an invocation of
-captureConstraints, and discard all the constraints. Some of those
-constraints might be "variable out of scope" Hole constraints, and that
-might have been the actual original cause of the exception!  For
-example (#12529):
-   f = p @ Int
-Here 'p' is out of scope, so we get an insoluble Hole constraint. But
-the visible type application fails in the monad (throws an exception).
-We must not discard the out-of-scope error.
-
-It's distressingly delicate though:
-
-* If we discard too /many/ constraints we may fail to report the error
-  that led us to interrupt the constraint gathering process.
-
-  One particular example "variable out of scope" Hole constraints. For
-  example (#12529):
-   f = p @ Int
-  Here 'p' is out of scope, so we get an insoluble Hole constraint. But
-  the visible type application fails in the monad (throws an exception).
-  We must not discard the out-of-scope error.
-
-  Also GHC.Tc.Solver.simplifyAndEmitFlatConstraints may fail having
-  emitted some constraints with skolem-escape problems.
-
-* If we discard too /few/ constraints, we may get the misleading
-  class constraints mentioned above.  But we may /also/ end up taking
-  constraints built at some inner level, and emitting them at some
-  outer level, and then breaking the TcLevel invariants
-  See Note [TcLevel invariants] in GHC.Tc.Utils.TcType
-
-So dropMisleading has a horridly ad-hoc structure.  It keeps only
-/insoluble/ flat constraints (which are unlikely to very visibly trip
-up on the TcLevel invariant, but all /implication/ constraints (except
-the class constraints inside them).  The implication constraints are
-OK because they set the ambient level before attempting to solve any
-inner constraints.  Ugh! I hate this. But it seems to work.
-
-However note that freshly-generated constraints like (Int ~ Bool), or
-((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as
-insoluble.  The constraint solver does that.  So they'll be discarded.
-That's probably ok; but see th/5358 as a not-so-good example:
-   t1 :: Int
-   t1 x = x   -- Manifestly wrong
-
-   foo = $(...raises exception...)
-We report the exception, but not the bug in t1.  Oh well.  Possible
-solution: make GHC.Tc.Utils.Unify.uType spot manifestly-insoluble constraints.
-
-
-************************************************************************
-*                                                                      *
-             Template Haskell context
-*                                                                      *
-************************************************************************
--}
-
-recordThUse :: TcM ()
-recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
-
-recordThSpliceUse :: TcM ()
-recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
-
-recordThNeededRuntimeDeps :: [Linkable] -> PkgsLoaded -> TcM ()
-recordThNeededRuntimeDeps new_links new_pkgs
-  = do { env <- getGblEnv
-       ; updTcRef (tcg_th_needed_deps env) $ \(needed_links, needed_pkgs) ->
-           let links = new_links ++ needed_links
-               !pkgs = plusUDFM needed_pkgs new_pkgs
-               in (links, pkgs)
-       }
-
-keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set
-keepAlive name
-  = do { env <- getGblEnv
-       ; traceRn "keep alive" (ppr name)
-       ; updTcRef (tcg_keep env) (`extendNameSet` name) }
-
-getStage :: TcM ThStage
-getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
-
-getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
-getStageAndBindLevel name
-  = do { env <- getLclEnv;
-       ; case lookupNameEnv (tcl_th_bndrs env) name of
-           Nothing                  -> return Nothing
-           Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
-
-setStage :: ThStage -> TcM a -> TcRn a
-setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
-
--- | Adds the given modFinalizers to the global environment and set them to use
--- the current local environment.
-addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
-addModFinalizersWithLclEnv mod_finalizers
-  = do lcl_env <- getLclEnv
-       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
-       updTcRef th_modfinalizers_var $ \fins ->
-         (lcl_env, mod_finalizers) : fins
-
-{-
-************************************************************************
-*                                                                      *
-             Safe Haskell context
-*                                                                      *
-************************************************************************
--}
-
--- | Mark that safe inference has failed
--- See Note [Safe Haskell Overlapping Instances Implementation]
--- although this is used for more than just that failure case.
-recordUnsafeInfer :: Messages TcRnMessage -> TcM ()
-recordUnsafeInfer msgs =
-    getGblEnv >>= \env -> do writeTcRef (tcg_safe_infer env) False
-                             writeTcRef (tcg_safe_infer_reasons env) msgs
-
--- | Figure out the final correct safe haskell mode
-finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
-finalSafeMode dflags tcg_env = do
-    safeInf <- readIORef (tcg_safe_infer tcg_env)
-    return $ case safeHaskell dflags of
-        Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred
-                | otherwise                     -> Sf_None
-        s -> s
-
--- | Switch instances to safe instances if we're in Safe mode.
-fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
-fixSafeInstances sfMode | sfMode /= Sf_Safe && sfMode /= Sf_SafeInferred = id
-fixSafeInstances _ = map fixSafe
-  where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
-                       in inst { is_flag = new_flag }
-
-{-
-************************************************************************
-*                                                                      *
-             Stuff for the renamer's local env
-*                                                                      *
-************************************************************************
--}
-
-getLocalRdrEnv :: RnM LocalRdrEnv
-getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
-
-setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
-setLocalRdrEnv rdr_env thing_inside
-  = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
-
-{-
-************************************************************************
-*                                                                      *
-             Stuff for interface decls
-*                                                                      *
-************************************************************************
--}
-
-mkIfLclEnv :: Module -> SDoc -> IsBootInterface -> IfLclEnv
-mkIfLclEnv mod loc boot
-                   = IfLclEnv { if_mod     = mod,
-                                if_loc     = loc,
-                                if_boot    = boot,
-                                if_nsubst  = Nothing,
-                                if_implicits_env = Nothing,
-                                if_tv_env  = emptyFsEnv,
-                                if_id_env  = emptyFsEnv }
-
--- | Run an 'IfG' (top-level interface monad) computation inside an existing
--- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
--- based on 'TcGblEnv'.
-initIfaceTcRn :: IfG a -> TcRn a
-initIfaceTcRn thing_inside
-  = do  { tcg_env <- getGblEnv
-        ; hsc_env <- getTopEnv
-          -- bangs to avoid leaking the envs (#19356)
-        ; let !mhome_unit = hsc_home_unit_maybe hsc_env
-              !knot_vars = tcg_type_env_var tcg_env
-              -- When we are instantiating a signature, we DEFINITELY
-              -- do not want to knot tie.
-              is_instantiate = fromMaybe False (isHomeUnitInstantiating <$> mhome_unit)
-        ; let { if_env = IfGblEnv {
-                            if_doc = text "initIfaceTcRn",
-                            if_rec_types =
-                                if is_instantiate
-                                    then emptyKnotVars
-                                    else readTcRef <$> knot_vars
-                            }
-                         }
-        ; setEnvs (if_env, ()) thing_inside }
-
--- | 'initIfaceLoad' can be used when there's no chance that the action will
--- call 'typecheckIface' when inside a module loop and hence 'tcIfaceGlobal'.
-initIfaceLoad :: HscEnv -> IfG a -> IO a
-initIfaceLoad hsc_env do_this
- = do let gbl_env = IfGblEnv {
-                        if_doc = text "initIfaceLoad",
-                        if_rec_types = emptyKnotVars
-                    }
-      initTcRnIf 'i' (hsc_env { hsc_type_env_vars = emptyKnotVars }) gbl_env () do_this
-
--- | This is used when we are doing to call 'typecheckModule' on an 'ModIface',
--- if it's part of a loop with some other modules then we need to use their
--- IORef TypeEnv vars when typechecking but crucially not our own.
-initIfaceLoadModule :: HscEnv -> Module -> IfG a -> IO a
-initIfaceLoadModule hsc_env this_mod do_this
- = do let gbl_env = IfGblEnv {
-                        if_doc = text "initIfaceLoadModule",
-                        if_rec_types = readTcRef <$> knotVarsWithout this_mod (hsc_type_env_vars hsc_env)
-                    }
-      initTcRnIf 'i' hsc_env gbl_env () do_this
-
-initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
--- Used when checking the up-to-date-ness of the old Iface
--- Initialise the environment with no useful info at all
-initIfaceCheck doc hsc_env do_this
- = do let gbl_env = IfGblEnv {
-                        if_doc = text "initIfaceCheck" <+> doc,
-                        if_rec_types = readTcRef <$> hsc_type_env_vars hsc_env
-                    }
-      initTcRnIf 'i' hsc_env gbl_env () do_this
-
-initIfaceLcl :: Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
-initIfaceLcl mod loc_doc hi_boot_file thing_inside
-  = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
-
--- | Initialize interface typechecking, but with a 'NameShape'
--- to apply when typechecking top-level 'OccName's (see
--- 'lookupIfaceTop')
-initIfaceLclWithSubst :: Module -> SDoc -> IsBootInterface -> NameShape -> IfL a -> IfM lcl a
-initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside
-  = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside
-
-getIfModule :: IfL Module
-getIfModule = do { env <- getLclEnv; return (if_mod env) }
-
---------------------
-failIfM :: SDoc -> IfL a
--- The Iface monad doesn't have a place to accumulate errors, so we
--- just fall over fast if one happens; it "shouldn't happen".
--- We use IfL here so that we can get context info out of the local env
-failIfM msg = do
-    env <- getLclEnv
-    let full_msg = (if_loc env <> colon) $$ nest 2 msg
-    logger <- getLogger
-    liftIO (logMsg logger MCFatal
-             noSrcSpan $ withPprStyle defaultErrStyle full_msg)
-    failM
-
---------------------
-
--- | Run thing_inside in an interleaved thread.
--- It shares everything with the parent thread, so this is DANGEROUS.
---
--- It throws an error if the computation fails
---
--- It's used for lazily type-checking interface
--- signatures, which is pretty benign.
---
--- See Note [Masking exceptions in forkM]
-forkM :: SDoc -> IfL a -> IfL a
-forkM doc thing_inside
- = unsafeInterleaveM $ uninterruptibleMaskM_ $
-    do { traceIf (text "Starting fork {" <+> doc)
-       ; mb_res <- tryM $
-                   updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
-                   thing_inside
-       ; case mb_res of
-            Right r  -> do  { traceIf (text "} ending fork" <+> doc)
-                            ; return r }
-            Left exn -> do {
-                -- Bleat about errors in the forked thread, if -ddump-if-trace is on
-                -- Otherwise we silently discard errors. Errors can legitimately
-                -- happen when compiling interface signatures.
-                  whenDOptM Opt_D_dump_if_trace $ do
-                      logger <- getLogger
-                      let msg = hang (text "forkM failed:" <+> doc)
-                                   2 (text (show exn))
-                      liftIO $ logMsg logger
-                                         MCFatal
-                                         noSrcSpan
-                                         $ withPprStyle defaultErrStyle msg
-                ; traceIf (text "} ending fork (badly)" <+> doc)
-                ; pgmError "Cannot continue after interface file error" }
-    }
-
-setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
-setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl
-                                     { if_implicits_env = Just tenv }) m
-
-{-
-Note [Masking exceptions in forkM]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-When using GHC-as-API it must be possible to interrupt snippets of code
-executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
-by throwing an asynchronous interrupt to the GHC thread. However, there is a
-subtle problem: runStmt first typechecks the code before running it, and the
-exception might interrupt the type checker rather than the code. Moreover, the
-typechecker might be inside an unsafeInterleaveIO (through forkM), and
-more importantly might be inside an exception handler inside that
-unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
-asynchronous exception as a synchronous exception, and the exception will end
-up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
-discussion).  We don't currently know a general solution to this problem, but
-we can use uninterruptibleMask_ to avoid the situation.
--}
-
--- | Get the next cost centre index associated with a given name.
-getCCIndexM :: (gbl -> TcRef CostCentreState) -> FastString -> TcRnIf gbl lcl CostCentreIndex
-getCCIndexM get_ccs nm = do
-  env <- getGblEnv
-  let cc_st_ref = get_ccs env
-  cc_st <- readTcRef cc_st_ref
-  let (idx, cc_st') = getCCIndex nm cc_st
-  writeTcRef cc_st_ref cc_st'
-  return idx
-
--- | See 'getCCIndexM'.
-getCCIndexTcM :: FastString -> TcM CostCentreIndex
-getCCIndexTcM = getCCIndexM tcg_cc_st
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ /dev/null
@@ -1,2796 +0,0 @@
-{-# LANGUAGE MultiWayIf      #-}
-{-# LANGUAGE TupleSections   #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
--}
-
--- | Monadic type operations
---
--- This module contains monadic operations over types that contain mutable type
--- variables.
-module GHC.Tc.Utils.TcMType (
-  TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet,
-
-  --------------------------------
-  -- Creating new mutable type variables
-  newFlexiTyVar,
-  newNamedFlexiTyVar,
-  newFlexiTyVarTy,              -- Kind -> TcM TcType
-  newFlexiTyVarTys,             -- Int -> Kind -> TcM [TcType]
-  newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind,
-  newOpenBoxedTypeKind,
-  newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel,
-  newAnonMetaTyVar, newConcreteTyVar, cloneMetaTyVar,
-  newCycleBreakerTyVar,
-
-  newMultiplicityVar,
-  readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
-  newTauTvDetailsAtLevel, newMetaDetails, newMetaTyVarName,
-  isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar,
-
-  --------------------------------
-  -- Creating new evidence variables
-  newEvVar, newEvVars, newDict,
-  newWantedWithLoc, newWanted, newWanteds, cloneWanted, cloneWC, cloneWantedCtEv,
-  emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,
-  emitWantedEqs,
-  newTcEvBinds, newNoTcEvBinds, addTcEvBind,
-  emitNewExprHole,
-
-  newCoercionHole, fillCoercionHole, isFilledCoercionHole,
-  unpackCoercionHole, unpackCoercionHole_maybe,
-  checkCoercionHole,
-
-  ConcreteHole, newConcreteHole,
-
-  newImplication,
-
-  --------------------------------
-  -- Instantiation
-  newMetaTyVars, newMetaTyVarX, newMetaTyVarsX,
-  newMetaTyVarTyVarX,
-  newTyVarTyVar, cloneTyVarTyVar,
-  newPatSigTyVar, newSkolemTyVar, newWildCardX,
-
-  --------------------------------
-  -- Expected types
-  ExpType(..), ExpSigmaType, ExpRhoType,
-  mkCheckExpType, newInferExpType, newInferExpTypeFRR,
-  tcInfer, tcInferFRR,
-  readExpType, readExpType_maybe, readScaledExpType,
-  expTypeToType, scaledExpTypeToType,
-  checkingExpType_maybe, checkingExpType,
-  inferResultToType, ensureMonoType, promoteTcType,
-
-  --------------------------------
-  -- Zonking and tidying
-  zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin, zonkTidyOrigins,
-  zonkTidyFRRInfos,
-  tidyEvVar, tidyCt, tidyHole, tidyDelayedError,
-    zonkTcTyVar, zonkTcTyVars,
-  zonkTcTyVarToTcTyVar, zonkTcTyVarsToTcTyVars,
-  zonkInvisTVBinder,
-  zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV,
-  zonkTyCoVarsAndFVList,
-
-  zonkTcType, zonkTcTypes, zonkCo,
-  zonkTyCoVarKind,
-  zonkEvVar, zonkWC, zonkImplication, zonkSimples,
-  zonkId, zonkCoVar,
-  zonkCt, zonkSkolemInfo, zonkSkolemInfoAnon,
-
-  ---------------------------------
-  -- Promotion, defaulting, skolemisation
-  defaultTyVar, promoteMetaTyVarTo, promoteTyVarSet,
-  quantifyTyVars, isQuantifiableTv,
-  zonkAndSkolemise, skolemiseQuantifiedTyVar,
-  doNotQuantifyTyVars,
-
-  candidateQTyVarsOfType,  candidateQTyVarsOfKind,
-  candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,
-  candidateQTyVarsWithBinders,
-  CandidatesQTvs(..), delCandidates,
-  candidateKindVars, partitionCandidates,
-
-  ------------------------------
-  -- Representation polymorphism
-  checkTypeHasFixedRuntimeRep,
-
-  ------------------------------
-  -- Other
-  anyUnfilledCoercionHoles
-  ) where
-
-import GHC.Prelude
-
-import GHC.Driver.Session
-import qualified GHC.LanguageExtensions as LangExt
-
-import GHC.Tc.Types.Origin
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Utils.Monad        -- TcType, amongst others
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Errors.Types
-import GHC.Tc.Errors.Ppr
-
-import GHC.Core.TyCo.Rep
-import GHC.Core.TyCo.Ppr
-import GHC.Core.Type
-import GHC.Core.TyCon
-import GHC.Core.Coercion
-import GHC.Core.Class
-import GHC.Core.Predicate
-import GHC.Core.InstEnv (ClsInst(is_tys))
-
-import GHC.Types.Var
-import GHC.Types.Id as Id
-import GHC.Types.Name
-import GHC.Types.Var.Set
-
-import GHC.Builtin.Types
-import GHC.Types.Error
-import GHC.Types.Var.Env
-import GHC.Types.Unique.Set
-import GHC.Types.Basic ( TypeOrKind(..)
-                       , NonStandardDefaultingStrategy(..)
-                       , DefaultingStrategy(..), defaultNonStandardTyVars )
-
-import GHC.Data.FastString
-import GHC.Data.Bag
-import GHC.Data.Pair
-
-import GHC.Utils.Misc
-import GHC.Utils.Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-import GHC.Utils.Constants (debugIsOn)
-
-import Control.Monad
-import GHC.Data.Maybe
-import qualified Data.Semigroup as Semi
-
-{-
-************************************************************************
-*                                                                      *
-        Kind variables
-*                                                                      *
-************************************************************************
--}
-
-newMetaKindVar :: TcM TcKind
-newMetaKindVar
-  = do { details <- newMetaDetails TauTv
-       ; name    <- newMetaTyVarName (fsLit "k")
-                    -- All MetaKindVars are called "k"
-                    -- They may be jiggled by tidying
-       ; let kv = mkTcTyVar name liftedTypeKind details
-       ; traceTc "newMetaKindVar" (ppr kv)
-       ; return (mkTyVarTy kv) }
-
-newMetaKindVars :: Int -> TcM [TcKind]
-newMetaKindVars n = replicateM n newMetaKindVar
-
-{-
-************************************************************************
-*                                                                      *
-     Evidence variables; range over constraints we can abstract over
-*                                                                      *
-************************************************************************
--}
-
-newEvVars :: TcThetaType -> TcM [EvVar]
-newEvVars theta = mapM newEvVar theta
-
---------------
-
-newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar
--- Creates new *rigid* variables for predicates
-newEvVar ty = do { name <- newSysName (predTypeOccName ty)
-                 ; return (mkLocalIdOrCoVar name ManyTy ty) }
-
--- | Create a new Wanted constraint with the given 'CtLoc'.
-newWantedWithLoc :: CtLoc -> PredType -> TcM CtEvidence
-newWantedWithLoc loc pty
-  = do dst <- case classifyPredType pty of
-                EqPred {} -> HoleDest  <$> newCoercionHole pty
-                _         -> EvVarDest <$> newEvVar pty
-       return $ CtWanted { ctev_dest      = dst
-                         , ctev_pred      = pty
-                         , ctev_loc       = loc
-                         , ctev_rewriters = emptyRewriterSet }
-
--- | Create a new Wanted constraint with the given 'CtOrigin', and
--- location information taken from the 'TcM' environment.
-newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence
--- Deals with both equality and non-equality predicates
-newWanted orig t_or_k pty
-  = do loc <- getCtLocM orig t_or_k
-       newWantedWithLoc loc pty
-
--- | Create new Wanted constraints with the given 'CtOrigin',
--- and location information taken from the 'TcM' environment.
-newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence]
-newWanteds orig = mapM (newWanted orig Nothing)
-
-----------------------------------------------
--- Cloning constraints
-----------------------------------------------
-
-cloneWantedCtEv :: CtEvidence -> TcM CtEvidence
-cloneWantedCtEv ctev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _ })
-  | isEqPrimPred pty
-  = do { co_hole <- newCoercionHole pty
-       ; return (ctev { ctev_dest = HoleDest co_hole }) }
-  | otherwise
-  = pprPanic "cloneWantedCtEv" (ppr pty)
-cloneWantedCtEv ctev = return ctev
-
-cloneWanted :: Ct -> TcM Ct
-cloneWanted ct = mkNonCanonical <$> cloneWantedCtEv (ctEvidence ct)
-
-cloneWC :: WantedConstraints -> TcM WantedConstraints
--- Clone all the evidence bindings in
---   a) the ic_bind field of any implications
---   b) the CoercionHoles of any wanted constraints
--- so that solving the WantedConstraints will not have any visible side
--- effect, /except/ from causing unifications
-cloneWC wc@(WC { wc_simple = simples, wc_impl = implics })
-  = do { simples' <- mapBagM cloneWanted simples
-       ; implics' <- mapBagM cloneImplication implics
-       ; return (wc { wc_simple = simples', wc_impl = implics' }) }
-
-cloneImplication :: Implication -> TcM Implication
-cloneImplication implic@(Implic { ic_binds = binds, ic_wanted = inner_wanted })
-  = do { binds'        <- cloneEvBindsVar binds
-       ; inner_wanted' <- cloneWC inner_wanted
-       ; return (implic { ic_binds = binds', ic_wanted = inner_wanted' }) }
-
-----------------------------------------------
--- Emitting constraints
-----------------------------------------------
-
--- | Emits a new Wanted. Deals with both equalities and non-equalities.
-emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm
-emitWanted origin pty
-  = do { ev <- newWanted origin Nothing pty
-       ; emitSimple $ mkNonCanonical ev
-       ; return $ ctEvTerm ev }
-
-emitWantedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM ()
--- Emit some new wanted nominal equalities
-emitWantedEqs origin pairs
-  | null pairs
-  = return ()
-  | otherwise
-  = mapM_ (uncurry (emitWantedEq origin TypeLevel Nominal)) pairs
-
--- | Emits a new equality constraint
-emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion
-emitWantedEq origin t_or_k role ty1 ty2
-  = do { hole <- newCoercionHole pty
-       ; loc <- getCtLocM origin (Just t_or_k)
-       ; emitSimple $ mkNonCanonical $
-         CtWanted { ctev_pred = pty
-                  , ctev_dest = HoleDest hole
-                  , ctev_loc = loc
-                  , ctev_rewriters = rewriterSetFromTypes [ty1, ty2] }
-       ; return (HoleCo hole) }
-  where
-    pty = mkPrimEqPredRole role ty1 ty2
-
--- | Creates a new EvVar and immediately emits it as a Wanted.
--- No equality predicates here.
-emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar
-emitWantedEvVar origin ty
-  = do { new_cv <- newEvVar ty
-       ; loc <- getCtLocM origin Nothing
-       ; let ctev = CtWanted { ctev_dest      = EvVarDest new_cv
-                             , ctev_pred      = ty
-                             , ctev_loc       = loc
-                             , ctev_rewriters = emptyRewriterSet }
-       ; emitSimple $ mkNonCanonical ctev
-       ; return new_cv }
-
-emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar]
-emitWantedEvVars orig = mapM (emitWantedEvVar orig)
-
--- | Emit a new wanted expression hole
-emitNewExprHole :: OccName         -- of the hole
-                -> Type -> TcM HoleExprRef
-emitNewExprHole occ ty
-  = do { u <- newUnique
-       ; ref <- newTcRef (pprPanic "unfilled unbound-variable evidence" (ppr u))
-       ; let her = HER ref ty u
-
-       ; loc <- getCtLocM (ExprHoleOrigin (Just occ)) (Just TypeLevel)
-
-       ; let hole = Hole { hole_sort = ExprHole her
-                         , hole_occ  = occ
-                         , hole_ty   = ty
-                         , hole_loc  = loc }
-       ; emitHole hole
-       ; return her }
-
-newDict :: Class -> [TcType] -> TcM DictId
-newDict cls tys
-  = do { name <- newSysName (mkDictOcc (getOccName cls))
-       ; return (mkLocalId name ManyTy (mkClassPred cls tys)) }
-
-predTypeOccName :: PredType -> OccName
-predTypeOccName ty = case classifyPredType ty of
-    ClassPred cls _ -> mkDictOcc (getOccName cls)
-    EqPred {}       -> mkVarOccFS (fsLit "co")
-    IrredPred {}    -> mkVarOccFS (fsLit "irred")
-    ForAllPred {}   -> mkVarOccFS (fsLit "df")
-
--- | Create a new 'Implication' with as many sensible defaults for its fields
--- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do
--- /not/ have sensible defaults, so they are initialized with lazy thunks that
--- will 'panic' if forced, so one should take care to initialize these fields
--- after creation.
---
--- This is monadic to look up the 'TcLclEnv', which is used to initialize
--- 'ic_env', and to set the -Winaccessible-code flag. See
--- Note [Avoid -Winaccessible-code when deriving] in "GHC.Tc.TyCl.Instance".
-newImplication :: TcM Implication
-newImplication
-  = do env <- getLclEnv
-       warn_inaccessible <- woptM Opt_WarnInaccessibleCode
-       return (implicationPrototype { ic_env = env
-                                    , ic_warn_inaccessible = warn_inaccessible })
-
-{-
-************************************************************************
-*                                                                      *
-        Coercion holes
-*                                                                      *
-************************************************************************
--}
-
-newCoercionHole :: TcPredType -> TcM CoercionHole
-newCoercionHole pred_ty
-  = do { co_var <- newEvVar pred_ty
-       ; traceTc "New coercion hole:" (ppr co_var <+> dcolon <+> ppr pred_ty)
-       ; ref <- newMutVar Nothing
-       ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } }
-
--- | Put a value in a coercion hole
-fillCoercionHole :: CoercionHole -> Coercion -> TcM ()
-fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co = do
-  when debugIsOn $ do
-    cts <- readTcRef ref
-    whenIsJust cts $ \old_co ->
-      pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co)
-  traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co)
-  writeTcRef ref (Just co)
-
--- | Is a coercion hole filled in?
-isFilledCoercionHole :: CoercionHole -> TcM Bool
-isFilledCoercionHole (CoercionHole { ch_ref = ref }) = isJust <$> readTcRef ref
-
--- | Retrieve the contents of a coercion hole. Panics if the hole
--- is unfilled
-unpackCoercionHole :: CoercionHole -> TcM Coercion
-unpackCoercionHole hole
-  = do { contents <- unpackCoercionHole_maybe hole
-       ; case contents of
-           Just co -> return co
-           Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) }
-
--- | Retrieve the contents of a coercion hole, if it is filled
-unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion)
-unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref
-
--- | Check that a coercion is appropriate for filling a hole. (The hole
--- itself is needed only for printing.)
--- Always returns the checked coercion, but this return value is necessary
--- so that the input coercion is forced only when the output is forced.
-checkCoercionHole :: CoVar -> Coercion -> TcM Coercion
-checkCoercionHole cv co
-  | debugIsOn
-  = do { cv_ty <- zonkTcType (varType cv)
-                  -- co is already zonked, but cv might not be
-       ; return $
-         assertPpr (ok cv_ty)
-                   (text "Bad coercion hole" <+>
-                    ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role
-                                             , ppr cv_ty ])
-         co }
-  | otherwise
-  = return co
-
-  where
-    (Pair t1 t2, role) = coercionKindRole co
-    ok cv_ty | EqPred cv_rel cv_t1 cv_t2 <- classifyPredType cv_ty
-             =  t1 `eqType` cv_t1
-             && t2 `eqType` cv_t2
-             && role == eqRelRole cv_rel
-             | otherwise
-             = False
-
--- | A coercion hole used to store evidence for `Concrete#` constraints.
---
--- See Note [The Concrete mechanism].
-type ConcreteHole = CoercionHole
-
--- | Create a new (initially unfilled) coercion hole,
--- to hold evidence for a @'Concrete#' (ty :: ki)@ constraint.
-newConcreteHole :: Kind -- ^ Kind of the thing we want to ensure is concrete (e.g. 'runtimeRepTy')
-                -> Type -- ^ Thing we want to ensure is concrete (e.g. some 'RuntimeRep')
-                -> TcM (ConcreteHole, TcType)
-                  -- ^ where to put the evidence, and a metavariable to store
-                  -- the concrete type
-newConcreteHole ki ty
-  = do { concrete_ty <- newFlexiTyVarTy ki
-       ; let co_ty = mkHeteroPrimEqPred ki ki ty concrete_ty
-       ; hole <- newCoercionHole co_ty
-       ; return (hole, concrete_ty) }
-
-{- **********************************************************************
-*
-                      ExpType functions
-*
-********************************************************************** -}
-
-{- Note [ExpType]
-~~~~~~~~~~~~~~~~~
-An ExpType is used as the "expected type" when type-checking an expression.
-An ExpType can hold a "hole" that can be filled in by the type-checker.
-This allows us to have one tcExpr that works in both checking mode and
-synthesis mode (that is, bidirectional type-checking). Previously, this
-was achieved by using ordinary unification variables, but we don't need
-or want that generality. (For example, #11397 was caused by doing the
-wrong thing with unification variables.) Instead, we observe that these
-holes should
-
-1. never be nested
-2. never appear as the type of a variable
-3. be used linearly (never be duplicated)
-
-By defining ExpType, separately from Type, we can achieve goals 1 and 2
-statically.
-
-See also [wiki:typechecking]
-
-Note [TcLevel of ExpType]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-  data G a where
-    MkG :: G Bool
-
-  foo MkG = True
-
-This is a classic untouchable-variable / ambiguous GADT return type
-scenario. But, with ExpTypes, we'll be inferring the type of the RHS.
-We thus must track a TcLevel in an Inferring ExpType. If we try to
-fill the ExpType and find that the TcLevels don't work out, we fill
-the ExpType with a tau-tv at the low TcLevel, hopefully to be worked
-out later by some means -- see fillInferResult, and Note [fillInferResult]
-
-This behaviour triggered in test gadt/gadt-escape1.
-
-Note [FixedRuntimeRep context in ExpType]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Sometimes, we want to be sure that we fill an ExpType with a type
-that has a syntactically fixed RuntimeRep (in the sense of
-Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete).
-
-Example:
-
-  pattern S a = (a :: (T :: TYPE R))
-
-We have to infer a type for `a` which has a syntactically fixed RuntimeRep.
-When it comes time to filling in the inferred type, we do the appropriate
-representation-polymorphism check, much like we do a level check
-as explained in Note [TcLevel of ExpType].
-
-See test case T21325.
--}
-
--- actual data definition is in GHC.Tc.Utils.TcType
-
-newInferExpType :: TcM ExpType
-newInferExpType = new_inferExpType Nothing
-
-newInferExpTypeFRR :: FixedRuntimeRepContext -> TcM ExpTypeFRR
-newInferExpTypeFRR frr_orig = new_inferExpType (Just frr_orig)
-
-new_inferExpType :: Maybe FixedRuntimeRepContext -> TcM ExpType
-new_inferExpType mb_frr_orig
-  = do { u <- newUnique
-       ; tclvl <- getTcLevel
-       ; traceTc "newInferExpType" (ppr u <+> ppr tclvl)
-       ; ref <- newMutVar Nothing
-       ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl
-                           , ir_ref = ref
-                           , ir_frr = mb_frr_orig })) }
-
--- | Extract a type out of an ExpType, if one exists. But one should always
--- exist. Unless you're quite sure you know what you're doing.
-readExpType_maybe :: ExpType -> TcM (Maybe TcType)
-readExpType_maybe (Check ty)                   = return (Just ty)
-readExpType_maybe (Infer (IR { ir_ref = ref})) = readMutVar ref
-
--- | Same as readExpType, but for Scaled ExpTypes
-readScaledExpType :: Scaled ExpType -> TcM (Scaled Type)
-readScaledExpType (Scaled m exp_ty)
-  = do { ty <- readExpType exp_ty
-       ; return (Scaled m ty) }
-
--- | Extract a type out of an ExpType. Otherwise, panics.
-readExpType :: ExpType -> TcM TcType
-readExpType exp_ty
-  = do { mb_ty <- readExpType_maybe exp_ty
-       ; case mb_ty of
-           Just ty -> return ty
-           Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) }
-
--- | Returns the expected type when in checking mode.
-checkingExpType_maybe :: ExpType -> Maybe TcType
-checkingExpType_maybe (Check ty) = Just ty
-checkingExpType_maybe (Infer {}) = Nothing
-
--- | Returns the expected type when in checking mode. Panics if in inference
--- mode.
-checkingExpType :: String -> ExpType -> TcType
-checkingExpType _   (Check ty) = ty
-checkingExpType err et         = pprPanic "checkingExpType" (text err $$ ppr et)
-
-scaledExpTypeToType :: Scaled ExpType -> TcM (Scaled TcType)
-scaledExpTypeToType (Scaled m exp_ty)
-  = do { ty <- expTypeToType exp_ty
-       ; return (Scaled m ty) }
-
--- | Extracts the expected type if there is one, or generates a new
--- TauTv if there isn't.
-expTypeToType :: ExpType -> TcM TcType
-expTypeToType (Check ty)      = return ty
-expTypeToType (Infer inf_res) = inferResultToType inf_res
-
-inferResultToType :: InferResult -> TcM Type
-inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl
-                      , ir_ref = ref })
-  = do { mb_inferred_ty <- readTcRef ref
-       ; tau <- case mb_inferred_ty of
-            Just ty -> do { ensureMonoType ty
-                            -- See Note [inferResultToType]
-                          ; return ty }
-            Nothing -> do { rr  <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy
-                          ; tau <- newMetaTyVarTyAtLevel tc_lvl (mkTYPEapp rr)
-                            -- See Note [TcLevel of ExpType]
-                          ; writeMutVar ref (Just tau)
-                          ; return tau }
-       ; traceTc "Forcing ExpType to be monomorphic:"
-                 (ppr u <+> text ":=" <+> ppr tau)
-       ; return tau }
-
-{- Note [inferResultToType]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-expTypeToType and inferResultType convert an InferResult to a monotype.
-It must be a monotype because if the InferResult isn't already filled in,
-we fill it in with a unification variable (hence monotype).  So to preserve
-order-independence we check for mono-type-ness even if it *is* filled in
-already.
-
-See also Note [TcLevel of ExpType] above, and
-Note [fillInferResult] in GHC.Tc.Utils.Unify.
--}
-
--- | Infer a type using a fresh ExpType
--- See also Note [ExpType] in "GHC.Tc.Utils.TcMType"
---
--- Use 'tcInferFRR' if you require the type to have a fixed
--- runtime representation.
-tcInfer :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
-tcInfer = tc_infer Nothing
-
--- | Like 'tcInfer', except it ensures that the resulting type
--- has a syntactically fixed RuntimeRep as per Note [Fixed RuntimeRep] in
--- GHC.Tc.Utils.Concrete.
-tcInferFRR :: FixedRuntimeRepContext -> (ExpSigmaTypeFRR -> TcM a) -> TcM (a, TcSigmaTypeFRR)
-tcInferFRR frr_orig = tc_infer (Just frr_orig)
-
-tc_infer :: Maybe FixedRuntimeRepContext -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
-tc_infer mb_frr tc_check
-  = do { res_ty <- new_inferExpType mb_frr
-       ; result <- tc_check res_ty
-       ; res_ty <- readExpType res_ty
-       ; return (result, res_ty) }
-
-{- *********************************************************************
-*                                                                      *
-              Promoting types
-*                                                                      *
-********************************************************************* -}
-
-ensureMonoType :: TcType -> TcM ()
--- Assuming that the argument type is of kind (TYPE r),
--- ensure that it is a /monotype/
--- If it is not a monotype we can see right away (since unification
--- variables and type-function applications stand for monotypes), but
--- we emit a Wanted equality just to delay the error message until later
-ensureMonoType res_ty
-  | isTauTy res_ty   -- isTauTy doesn't need zonking or anything
-  = return ()
-  | otherwise
-  = do { mono_ty <- newOpenFlexiTyVarTy
-       ; let eq_orig = TypeEqOrigin { uo_actual   = res_ty
-                                    , uo_expected = mono_ty
-                                    , uo_thing    = Nothing
-                                    , uo_visible  = False }
-
-       ; _co <- emitWantedEq eq_orig TypeLevel Nominal res_ty mono_ty
-       ; return () }
-
-promoteTcType :: TcLevel -> TcType -> TcM (TcCoercionN, TcType)
--- See Note [Promoting a type]
--- See also Note [fillInferResult]
--- promoteTcType level ty = (co, ty')
---   * Returns ty'  whose max level is just 'level'
---             and  whose kind is ~# to the kind of 'ty'
---             and  whose kind has form TYPE rr
---   * and co :: ty ~ ty'
---   * and emits constraints to justify the coercion
---
--- NB: we expect that 'ty' has already kind (TYPE rr) for
---     some rr::RuntimeRep.  It is, after all, the type of a term.
-promoteTcType dest_lvl ty
-  = do { cur_lvl <- getTcLevel
-       ; if (cur_lvl `sameDepthAs` dest_lvl)
-         then return (mkNomReflCo ty, ty)
-         else promote_it }
-  where
-    promote_it :: TcM (TcCoercion, TcType)
-    promote_it  -- Emit a constraint  (alpha :: TYPE rr) ~ ty
-                -- where alpha and rr are fresh and from level dest_lvl
-      = do { rr      <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy
-           ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (mkTYPEapp rr)
-           ; let eq_orig = TypeEqOrigin { uo_actual   = ty
-                                        , uo_expected = prom_ty
-                                        , uo_thing    = Nothing
-                                        , uo_visible  = False }
-
-           ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty
-           ; return (co, prom_ty) }
-
-{- Note [Promoting a type]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#12427)
-
-  data T where
-    MkT :: (Int -> Int) -> a -> T
-
-  h y = case y of MkT v w -> v
-
-We'll infer the RHS type with an expected type ExpType of
-  (IR { ir_lvl = l, ir_ref = ref, ... )
-where 'l' is the TcLevel of the RHS of 'h'.  Then the MkT pattern
-match will increase the level, so we'll end up in tcSubType, trying to
-unify the type of v,
-  v :: Int -> Int
-with the expected type.  But this attempt takes place at level (l+1),
-rightly so, since v's type could have mentioned existential variables,
-(like w's does) and we want to catch that.
-
-So we
-  - create a new meta-var alpha[l+1]
-  - fill in the InferRes ref cell 'ref' with alpha
-  - emit an equality constraint, thus
-        [W] alpha[l+1] ~ (Int -> Int)
-
-That constraint will float outwards, as it should, unless v's
-type mentions a skolem-captured variable.
-
-This approach fails if v has a higher rank type; see
-Note [Promotion and higher rank types]
-
-
-Note [Promotion and higher rank types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If v had a higher-rank type, say v :: (forall a. a->a) -> Int,
-then we'd emit an equality
-        [W] alpha[l+1] ~ ((forall a. a->a) -> Int)
-which will sadly fail because we can't unify a unification variable
-with a polytype.  But there is nothing really wrong with the program
-here.
-
-We could just about solve this by "promote the type" of v, to expose
-its polymorphic "shape" while still leaving constraints that will
-prevent existential escape.  But we must be careful!  Exposing
-the "shape" of the type is precisely what we must NOT do under
-a GADT pattern match!  So in this case we might promote the type
-to
-        (forall a. a->a) -> alpha[l+1]
-and emit the constraint
-        [W] alpha[l+1] ~ Int
-Now the promoted type can fill the ref cell, while the emitted
-equality can float or not, according to the usual rules.
-
-But that's not quite right!  We are exposing the arrow! We could
-deal with that too:
-        (forall a. mu[l+1] a a) -> alpha[l+1]
-with constraints
-        [W] alpha[l+1] ~ Int
-        [W] mu[l+1] ~ (->)
-Here we abstract over the '->' inside the forall, in case that
-is subject to an equality constraint from a GADT match.
-
-Note that we kept the outer (->) because that's part of
-the polymorphic "shape".  And because of impredicativity,
-GADT matches can't give equalities that affect polymorphic
-shape.
-
-This reasoning just seems too complicated, so I decided not
-to do it.  These higher-rank notes are just here to record
-the thinking.
--}
-
-
-{- *********************************************************************
-*                                                                      *
-        MetaTvs (meta type variables; mutable)
-*                                                                      *
-********************************************************************* -}
-
-{- Note [TyVarTv]
-~~~~~~~~~~~~~~~~~
-A TyVarTv can unify with type *variables* only, including other TyVarTvs and
-skolems.  They are used in two places:
-
-1. In kind signatures, see GHC.Tc.TyCl
-      Note [Inferring kinds for type declarations]
-   and Note [Using TyVarTvs for kind-checking GADTs]
-
-2. In partial type signatures.  See GHC.Tc.Types
-   Note [Quantified variables in partial type signatures]
-
-Sometimes, they can unify with type variables that the user would
-rather keep distinct; see #11203 for an example.  So, any client of
-this function needs to either allow the TyVarTvs to unify with each
-other or check that they don't. In the case of (1) the check is done
-in GHC.Tc.TyCl.swizzleTcTyConBndrs.  In case of (2) it's done by
-findDupTyVarTvs in GHC.Tc.Gen.Bind.chooseInferredQuantifiers.
-
-Historical note: Before #15050 this (under the name SigTv) was also
-used for ScopedTypeVariables in patterns, to make sure these type
-variables only refer to other type variables, but this restriction was
-dropped, and ScopedTypeVariables can now refer to full types (GHC
-Proposal 29).
--}
-
-newMetaTyVarName :: FastString -> TcM Name
--- Makes a /System/ Name, which is eagerly eliminated by
--- the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and
--- GHC.Tc.Solver.Canonical.canEqTyVarTyVar (nicer_to_update_tv2)
-newMetaTyVarName str
-  = do { uniq <- newUnique
-       ; return (mkSystemName uniq (mkTyVarOccFS str)) }
-
-cloneMetaTyVarName :: Name -> TcM Name
-cloneMetaTyVarName name
-  = do { uniq <- newUnique
-       ; return (mkSystemName uniq (nameOccName name)) }
-         -- See Note [Name of an instantiated type variable]
-
-{- Note [Name of an instantiated type variable]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-At the moment we give a unification variable a System Name, which
-influences the way it is tidied; see TypeRep.tidyTyVarBndr.
--}
-
-metaInfoToTyVarName :: MetaInfo -> FastString
-metaInfoToTyVarName  meta_info =
-  case meta_info of
-       TauTv          -> fsLit "t"
-       TyVarTv        -> fsLit "a"
-       RuntimeUnkTv   -> fsLit "r"
-       CycleBreakerTv -> fsLit "b"
-       ConcreteTv {}  -> fsLit "c"
-
-newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
-newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi
-
-newNamedAnonMetaTyVar :: FastString -> MetaInfo -> Kind -> TcM TcTyVar
--- Make a new meta tyvar out of thin air
-newNamedAnonMetaTyVar tyvar_name meta_info kind
-
-  = do  { name    <- newMetaTyVarName tyvar_name
-        ; details <- newMetaDetails meta_info
-        ; let tyvar = mkTcTyVar name kind details
-        ; traceTc "newAnonMetaTyVar" (ppr tyvar)
-        ; return tyvar }
-
--- makes a new skolem tv
-newSkolemTyVar :: SkolemInfo -> Name -> Kind -> TcM TcTyVar
-newSkolemTyVar skol_info name kind
-  = do { lvl <- getTcLevel
-       ; return (mkTcTyVar name kind (SkolemTv skol_info lvl False)) }
-
-newTyVarTyVar :: Name -> Kind -> TcM TcTyVar
--- See Note [TyVarTv]
--- Does not clone a fresh unique
-newTyVarTyVar name kind
-  = do { details <- newMetaDetails TyVarTv
-       ; let tyvar = mkTcTyVar name kind details
-       ; traceTc "newTyVarTyVar" (ppr tyvar)
-       ; return tyvar }
-
-cloneTyVarTyVar :: Name -> Kind -> TcM TcTyVar
--- See Note [TyVarTv]
--- Clones a fresh unique
-cloneTyVarTyVar name kind
-  = do { details <- newMetaDetails TyVarTv
-       ; uniq <- newUnique
-       ; let name' = name `setNameUnique` uniq
-             tyvar = mkTcTyVar name' kind details
-         -- Don't use cloneMetaTyVar, which makes a SystemName
-         -- We want to keep the original more user-friendly Name
-         -- In practical terms that means that in error messages,
-         -- when the Name is tidied we get 'a' rather than 'a0'
-       ; traceTc "cloneTyVarTyVar" (ppr tyvar)
-       ; return tyvar }
-
--- | Create a new metavariable, of the given kind, which can only be unified
--- with a concrete type.
---
--- Invariant: the kind must be concrete, as per Note [ConcreteTv].
--- This is checked with an assertion.
-newConcreteTyVar :: HasDebugCallStack => ConcreteTvOrigin -> TcKind -> TcM TcTyVar
-newConcreteTyVar reason kind =
-  assertPpr (isConcrete kind)
-    (text "newConcreteTyVar: non-concrete kind" <+> ppr kind)
-  $ newAnonMetaTyVar (ConcreteTv reason) kind
-
-newPatSigTyVar :: Name -> Kind -> TcM TcTyVar
-newPatSigTyVar name kind
-  = do { details <- newMetaDetails TauTv
-       ; uniq <- newUnique
-       ; let name' = name `setNameUnique` uniq
-             tyvar = mkTcTyVar name' kind details
-         -- Don't use cloneMetaTyVar;
-         -- same reasoning as in newTyVarTyVar
-       ; traceTc "newPatSigTyVar" (ppr tyvar)
-       ; return tyvar }
-
-cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar
--- Make a fresh MetaTyVar, basing the name
--- on that of the supplied TyVar
-cloneAnonMetaTyVar info tv kind
-  = do  { details <- newMetaDetails info
-        ; name    <- cloneMetaTyVarName (tyVarName tv)
-        ; let tyvar = mkTcTyVar name kind details
-        ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar))
-        ; return tyvar }
-
--- Make a new CycleBreakerTv. See Note [Type equality cycles]
--- in GHC.Tc.Solver.Canonical.
-newCycleBreakerTyVar :: TcKind -> TcM TcTyVar
-newCycleBreakerTyVar kind
-  = do { details <- newMetaDetails CycleBreakerTv
-       ; name <- newMetaTyVarName (fsLit "cbv")
-       ; return (mkTcTyVar name kind details) }
-
-newMetaDetails :: MetaInfo -> TcM TcTyVarDetails
-newMetaDetails info
-  = do { ref <- newMutVar Flexi
-       ; tclvl <- getTcLevel
-       ; return (MetaTv { mtv_info = info
-                        , mtv_ref = ref
-                        , mtv_tclvl = tclvl }) }
-
-newTauTvDetailsAtLevel :: TcLevel -> TcM TcTyVarDetails
-newTauTvDetailsAtLevel tclvl
-  = do { ref <- newMutVar Flexi
-       ; return (MetaTv { mtv_info  = TauTv
-                        , mtv_ref   = ref
-                        , mtv_tclvl = tclvl }) }
-
-cloneMetaTyVar :: TcTyVar -> TcM TcTyVar
-cloneMetaTyVar tv
-  = assert (isTcTyVar tv) $
-    do  { ref  <- newMutVar Flexi
-        ; name' <- cloneMetaTyVarName (tyVarName tv)
-        ; let details' = case tcTyVarDetails tv of
-                           details@(MetaTv {}) -> details { mtv_ref = ref }
-                           _ -> pprPanic "cloneMetaTyVar" (ppr tv)
-              tyvar = mkTcTyVar name' (tyVarKind tv) details'
-        ; traceTc "cloneMetaTyVar" (ppr tyvar)
-        ; return tyvar }
-
--- Works for both type and kind variables
-readMetaTyVar :: TyVar -> TcM MetaDetails
-readMetaTyVar tyvar = assertPpr (isMetaTyVar tyvar) (ppr tyvar) $
-                      readMutVar (metaTyVarRef tyvar)
-
-isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type)
-isFilledMetaTyVar_maybe tv
--- TODO: This should be an assertion that tv is definitely a TcTyVar but it fails
--- at the moment (Jan 22)
- | isTcTyVar tv
- , MetaTv { mtv_ref = ref } <- tcTyVarDetails tv
- = do { cts <- readTcRef ref
-      ; case cts of
-          Indirect ty -> return (Just ty)
-          Flexi       -> return Nothing }
- | otherwise
- = return Nothing
-
-isFilledMetaTyVar :: TyVar -> TcM Bool
--- True of a filled-in (Indirect) meta type variable
-isFilledMetaTyVar tv = isJust <$> isFilledMetaTyVar_maybe tv
-
-isUnfilledMetaTyVar :: TyVar -> TcM Bool
--- True of a un-filled-in (Flexi) meta type variable
--- NB: Not the opposite of isFilledMetaTyVar
-isUnfilledMetaTyVar tv
-  | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv
-  = do  { details <- readMutVar ref
-        ; return (isFlexi details) }
-  | otherwise = return False
-
---------------------
--- Works with both type and kind variables
-writeMetaTyVar :: TcTyVar -> TcType -> TcM ()
--- Write into a currently-empty MetaTyVar
-
-writeMetaTyVar tyvar ty
-  | not debugIsOn
-  = writeMetaTyVarRef tyvar (metaTyVarRef tyvar) ty
-
--- Everything from here on only happens if DEBUG is on
-  | not (isTcTyVar tyvar)
-  = massertPpr False (text "Writing to non-tc tyvar" <+> ppr tyvar)
-
-  | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar
-  = writeMetaTyVarRef tyvar ref ty
-
-  | otherwise
-  = massertPpr False (text "Writing to non-meta tyvar" <+> ppr tyvar)
-
---------------------
-writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()
--- Here the tyvar is for error checking only;
--- the ref cell must be for the same tyvar
-writeMetaTyVarRef tyvar ref ty
-  | not debugIsOn
-  = do { traceTc "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)
-                                   <+> text ":=" <+> ppr ty)
-       ; writeTcRef ref (Indirect ty) }
-
-  -- Everything from here on only happens if DEBUG is on
-  -- Need to zonk 'ty' because we may only recently have promoted
-  -- its free meta-tyvars (see Solver.Interact.tryToSolveByUnification)
-  | otherwise
-  = do { meta_details <- readMutVar ref;
-       -- Zonk kinds to allow the error check to work
-       ; zonked_tv_kind <- zonkTcType tv_kind
-       ; zonked_ty      <- zonkTcType ty
-       ; let zonked_ty_kind = typeKind zonked_ty
-             zonked_ty_lvl  = tcTypeLevel zonked_ty
-             level_check_ok  = not (zonked_ty_lvl `strictlyDeeperThan` tv_lvl)
-             level_check_msg = ppr zonked_ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty
-             kind_check_ok = zonked_ty_kind `eqType` zonked_tv_kind
-             -- Note [Extra-constraint holes in partial type signatures] in GHC.Tc.Gen.HsType
-
-             kind_msg = hang (text "Ill-kinded update to meta tyvar")
-                           2 (    ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind)
-                              <+> text ":="
-                              <+> ppr ty <+> text "::" <+> (ppr zonked_ty_kind) )
-
-       ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
-
-       -- Check for double updates
-       ; massertPpr (isFlexi meta_details) (double_upd_msg meta_details)
-
-       -- Check for level OK
-       ; massertPpr level_check_ok level_check_msg
-
-       -- Check Kinds ok
-       ; massertPpr kind_check_ok kind_msg
-
-       -- Do the write
-       ; writeMutVar ref (Indirect ty) }
-  where
-    tv_kind = tyVarKind tyvar
-
-    tv_lvl = tcTyVarLevel tyvar
-
-
-    double_upd_msg details = hang (text "Double update of meta tyvar")
-                                2 (ppr tyvar $$ ppr details)
-
-{-
-************************************************************************
-*                                                                      *
-        MetaTvs: TauTvs
-*                                                                      *
-************************************************************************
-
-Note [Never need to instantiate coercion variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-With coercion variables sloshing around in types, it might seem that we
-sometimes need to instantiate coercion variables. This would be problematic,
-because coercion variables inhabit unboxed equality (~#), and the constraint
-solver thinks in terms only of boxed equality (~). The solution is that
-we never need to instantiate coercion variables in the first place.
-
-The tyvars that we need to instantiate come from the types of functions,
-data constructors, and patterns. These will never be quantified over
-coercion variables, except for the special case of the promoted Eq#. But,
-that can't ever appear in user code, so we're safe!
--}
-
-
-newMultiplicityVar :: TcM TcType
-newMultiplicityVar = newFlexiTyVarTy multiplicityTy
-
-newFlexiTyVar :: Kind -> TcM TcTyVar
-newFlexiTyVar kind = newAnonMetaTyVar TauTv kind
-
--- | Create a new flexi ty var with a specific name
-newNamedFlexiTyVar :: FastString -> Kind -> TcM TcTyVar
-newNamedFlexiTyVar fs kind = newNamedAnonMetaTyVar fs TauTv kind
-
-newFlexiTyVarTy :: Kind -> TcM TcType
-newFlexiTyVarTy kind = do
-    tc_tyvar <- newFlexiTyVar kind
-    return (mkTyVarTy tc_tyvar)
-
-newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]
-newFlexiTyVarTys n kind = replicateM n (newFlexiTyVarTy kind)
-
-newOpenTypeKind :: TcM TcKind
-newOpenTypeKind
-  = do { rr <- newFlexiTyVarTy runtimeRepTy
-       ; return (mkTYPEapp rr) }
-
--- | Create a tyvar that can be a lifted or unlifted type.
--- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh
-newOpenFlexiTyVarTy :: TcM TcType
-newOpenFlexiTyVarTy
-  = do { tv <- newOpenFlexiTyVar
-       ; return (mkTyVarTy tv) }
-
-newOpenFlexiTyVar :: TcM TcTyVar
-newOpenFlexiTyVar
-  = do { kind <- newOpenTypeKind
-       ; newFlexiTyVar kind }
-
-newOpenBoxedTypeKind :: TcM TcKind
-newOpenBoxedTypeKind
-  = do { lev <- newFlexiTyVarTy (mkTyConTy levityTyCon)
-       ; let rr = mkTyConApp boxedRepDataConTyCon [lev]
-       ; return (mkTYPEapp rr) }
-
-newMetaTyVars :: [TyVar] -> TcM (Subst, [TcTyVar])
--- Instantiate with META type variables
--- Note that this works for a sequence of kind, type, and coercion variables
--- variables.  Eg    [ (k:*), (a:k->k) ]
---             Gives [ (k7:*), (a8:k7->k7) ]
-newMetaTyVars = newMetaTyVarsX emptySubst
-    -- emptySubst has an empty in-scope set, but that's fine here
-    -- Since the tyvars are freshly made, they cannot possibly be
-    -- captured by any existing for-alls.
-
-newMetaTyVarsX :: Subst -> [TyVar] -> TcM (Subst, [TcTyVar])
--- Just like newMetaTyVars, but start with an existing substitution.
-newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst
-
-newMetaTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar)
--- Make a new unification variable tyvar whose Name and Kind come from
--- an existing TyVar. We substitute kind variables in the kind.
-newMetaTyVarX = new_meta_tv_x TauTv
-
-newMetaTyVarTyVarX :: Subst -> TyVar -> TcM (Subst, TcTyVar)
--- Just like newMetaTyVarX, but make a TyVarTv
-newMetaTyVarTyVarX = new_meta_tv_x TyVarTv
-
-newWildCardX :: Subst -> TyVar -> TcM (Subst, TcTyVar)
-newWildCardX subst tv
-  = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv))
-       ; return (extendTvSubstWithClone subst tv new_tv, new_tv) }
-
-new_meta_tv_x :: MetaInfo -> Subst -> TyVar -> TcM (Subst, TcTyVar)
-new_meta_tv_x info subst tv
-  = do  { new_tv <- cloneAnonMetaTyVar info tv substd_kind
-        ; let subst1 = extendTvSubstWithClone subst tv new_tv
-        ; return (subst1, new_tv) }
-  where
-    substd_kind = substTyUnchecked subst (tyVarKind tv)
-      -- NOTE: #12549 is fixed so we could use
-      -- substTy here, but the tc_infer_args problem
-      -- is not yet fixed so leaving as unchecked for now.
-      -- OLD NOTE:
-      -- Unchecked because we call newMetaTyVarX from
-      -- tcInstTyBinder, which is called from tcInferTyApps
-      -- which does not yet take enough trouble to ensure
-      -- the in-scope set is right; e.g. #12785 trips
-      -- if we use substTy here
-
-newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType
-newMetaTyVarTyAtLevel tc_lvl kind
-  = do  { details <- newTauTvDetailsAtLevel tc_lvl
-        ; name    <- newMetaTyVarName (fsLit "p")
-        ; return (mkTyVarTy (mkTcTyVar name kind details)) }
-
-{- *********************************************************************
-*                                                                      *
-          Finding variables to quantify over
-*                                                                      *
-********************************************************************* -}
-
-{- Note [Dependent type variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In Haskell type inference we quantify over type variables; but we only
-quantify over /kind/ variables when -XPolyKinds is on.  Without -XPolyKinds
-we default the kind variables to *.
-
-So, to support this defaulting, and only for that reason, when
-collecting the free vars of a type (in candidateQTyVarsOfType and friends),
-prior to quantifying, we must keep the type and kind variables separate.
-
-But what does that mean in a system where kind variables /are/ type
-variables? It's a fairly arbitrary distinction based on how the
-variables appear:
-
-  - "Kind variables" appear in the kind of some other free variable
-    or in the kind of a locally quantified type variable
-    (forall (a :: kappa). ...) or in the kind of a coercion
-    (a |> (co :: kappa1 ~ kappa2)).
-
-     These are the ones we default to * if -XPolyKinds is off
-
-  - "Type variables" are all free vars that are not kind variables
-
-E.g.  In the type    T k (a::k)
-      'k' is a kind variable, because it occurs in the kind of 'a',
-          even though it also appears at "top level" of the type
-      'a' is a type variable, because it doesn't
-
-We gather these variables using a CandidatesQTvs record:
-  DV { dv_kvs: Variables free in the kind of a free type variable
-               or of a forall-bound type variable
-     , dv_tvs: Variables syntactically free in the type }
-
-So:  dv_kvs            are the kind variables of the type
-     (dv_tvs - dv_kvs) are the type variable of the type
-
-Note that
-
-* A variable can occur in both.
-      T k (x::k)    The first occurrence of k makes it
-                    show up in dv_tvs, the second in dv_kvs
-
-* We include any coercion variables in the "dependent",
-  "kind-variable" set because we never quantify over them.
-
-* The "kind variables" might depend on each other; e.g
-     (k1 :: k2), (k2 :: *)
-  The "type variables" do not depend on each other; if
-  one did, it'd be classified as a kind variable!
-
-Note [CandidatesQTvs determinism and order]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* Determinism: when we quantify over type variables we decide the
-  order in which they appear in the final type. Because the order of
-  type variables in the type can end up in the interface file and
-  affects some optimizations like worker-wrapper, we want this order to
-  be deterministic.
-
-  To achieve that we use deterministic sets of variables that can be
-  converted to lists in a deterministic order. For more information
-  about deterministic sets see Note [Deterministic UniqFM] in GHC.Types.Unique.DFM.
-
-* Order: as well as being deterministic, we use an
-  accumulating-parameter style for candidateQTyVarsOfType so that we
-  add variables one at a time, left to right.  That means we tend to
-  produce the variables in left-to-right order.  This is just to make
-  it bit more predictable for the programmer.
-
-Note [Naughty quantification candidates]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider (#14880, dependent/should_compile/T14880-2), suppose
-we are trying to generalise this type:
-
-  forall arg. ... (alpha[tau]:arg) ...
-
-We have a metavariable alpha whose kind mentions a skolem variable
-bound inside the very type we are generalising.
-This can arise while type-checking a user-written type signature
-(see the test case for the full code).
-
-We cannot generalise over alpha!  That would produce a type like
-  forall {a :: arg}. forall arg. ...blah...
-The fact that alpha's kind mentions arg renders it completely
-ineligible for generalisation.
-
-However, we are not going to learn any new constraints on alpha,
-because its kind isn't even in scope in the outer context (but see Wrinkle).
-So alpha is entirely unconstrained.
-
-What then should we do with alpha?  During generalization, every
-metavariable is either (A) promoted, (B) generalized, or (C) zapped
-(according to Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType).
-
- * We can't generalise it.
- * We can't promote it, because its kind prevents that
- * We can't simply leave it be, because this type is about to
-   go into the typing environment (as the type of some let-bound
-   variable, say), and then chaos erupts when we try to instantiate.
-
-Previously, we zapped it to Any. This worked, but it had the unfortunate
-effect of causing Any sometimes to appear in error messages. If this
-kind of signature happens, the user probably has made a mistake -- no
-one really wants Any in their types. So we now error. This must be
-a hard error (failure in the monad) to avoid other messages from mentioning
-Any.
-
-We do this eager erroring in candidateQTyVars, which always precedes
-generalisation, because at that moment we have a clear picture of what
-skolems are in scope within the type itself (e.g. that 'forall arg').
-
-This change is inspired by and described in Section 7.2 of "Kind Inference
-for Datatypes", POPL'20.
-
-NB: this is all rather similar to, but sadly not the same as
-    Note [Error on unconstrained meta-variables]
-
-Wrinkle:
-
-We must make absolutely sure that alpha indeed is not
-from an outer context. (Otherwise, we might indeed learn more information
-about it.) This can be done easily: we just check alpha's TcLevel.
-That level must be strictly greater than the ambient TcLevel in order
-to treat it as naughty. We say "strictly greater than" because the call to
-candidateQTyVars is made outside the bumped TcLevel, as stated in the
-comment to candidateQTyVarsOfType. The level check is done in go_tv
-in collect_cand_qtvs. Skipping this check caused #16517.
-
--}
-
-data CandidatesQTvs
-  -- See Note [Dependent type variables]
-  -- See Note [CandidatesQTvs determinism and order]
-  --
-  -- Invariants:
-  --   * All variables are fully zonked, including their kinds
-  --   * All variables are at a level greater than the ambient level
-  --     See Note [Use level numbers for quantification]
-  --
-  -- This *can* contain skolems. For example, in `data X k :: k -> Type`
-  -- we need to know that the k is a dependent variable. This is done
-  -- by collecting the candidates in the kind after skolemising. It also
-  -- comes up when generalizing a associated type instance, where instance
-  -- variables are skolems. (Recall that associated type instances are generalized
-  -- independently from their enclosing class instance, and the associated
-  -- type instance may be generalized by more, fewer, or different variables
-  -- than the class instance.)
-  --
-  = DV { dv_kvs :: DTyVarSet    -- "kind" metavariables (dependent)
-       , dv_tvs :: DTyVarSet    -- "type" metavariables (non-dependent)
-         -- A variable may appear in both sets
-         -- E.g.   T k (x::k)    The first occurrence of k makes it
-         --                      show up in dv_tvs, the second in dv_kvs
-         -- See Note [Dependent type variables]
-
-       , dv_cvs :: CoVarSet
-         -- These are covars. Included only so that we don't repeatedly
-         -- look at covars' kinds in accumulator. Not used by quantifyTyVars.
-    }
-
-instance Semi.Semigroup CandidatesQTvs where
-   (DV { dv_kvs = kv1, dv_tvs = tv1, dv_cvs = cv1 })
-     <> (DV { dv_kvs = kv2, dv_tvs = tv2, dv_cvs = cv2 })
-          = DV { dv_kvs = kv1 `unionDVarSet` kv2
-               , dv_tvs = tv1 `unionDVarSet` tv2
-               , dv_cvs = cv1 `unionVarSet` cv2 }
-
-instance Monoid CandidatesQTvs where
-   mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet, dv_cvs = emptyVarSet }
-   mappend = (Semi.<>)
-
-instance Outputable CandidatesQTvs where
-  ppr (DV {dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs })
-    = text "DV" <+> braces (pprWithCommas id [ text "dv_kvs =" <+> ppr kvs
-                                             , text "dv_tvs =" <+> ppr tvs
-                                             , text "dv_cvs =" <+> ppr cvs ])
-
-isEmptyCandidates :: CandidatesQTvs -> Bool
-isEmptyCandidates (DV { dv_kvs = kvs, dv_tvs = tvs })
-  = isEmptyDVarSet kvs && isEmptyDVarSet tvs
-
--- | Extract out the kind vars (in order) and type vars (in order) from
--- a 'CandidatesQTvs'. The lists are guaranteed to be distinct. Keeping
--- the lists separate is important only in the -XNoPolyKinds case.
-candidateVars :: CandidatesQTvs -> ([TcTyVar], [TcTyVar])
-candidateVars (DV { dv_kvs = dep_kv_set, dv_tvs = nondep_tkv_set })
-  = (dep_kvs, nondep_tvs)
-  where
-    dep_kvs = scopedSort $ dVarSetElems dep_kv_set
-      -- scopedSort: put the kind variables into
-      --    well-scoped order.
-      --    E.g.  [k, (a::k)] not the other way round
-
-    nondep_tvs = dVarSetElems (nondep_tkv_set `minusDVarSet` dep_kv_set)
-      -- See Note [Dependent type variables]
-      -- The `minus` dep_tkvs removes any kind-level vars
-      --    e.g. T k (a::k)   Since k appear in a kind it'll
-      --    be in dv_kvs, and is dependent. So remove it from
-      --    dv_tvs which will also contain k
-      -- NB kinds of tvs are already zonked
-
-candidateKindVars :: CandidatesQTvs -> TyVarSet
-candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs)
-
-delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs
-delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars
-  = DV { dv_kvs = kvs `delDVarSetList` vars
-       , dv_tvs = tvs `delDVarSetList` vars
-       , dv_cvs = cvs `delVarSetList`  vars }
-
-partitionCandidates :: CandidatesQTvs -> (TyVar -> Bool) -> (TyVarSet, CandidatesQTvs)
--- The selected TyVars are returned as a non-deterministic TyVarSet
-partitionCandidates dvs@(DV { dv_kvs = kvs, dv_tvs = tvs }) pred
-  = (extracted, dvs { dv_kvs = rest_kvs, dv_tvs = rest_tvs })
-  where
-    (extracted_kvs, rest_kvs) = partitionDVarSet pred kvs
-    (extracted_tvs, rest_tvs) = partitionDVarSet pred tvs
-    extracted = dVarSetToVarSet extracted_kvs `unionVarSet` dVarSetToVarSet extracted_tvs
-
-candidateQTyVarsWithBinders :: [TyVar] -> Type -> TcM CandidatesQTvs
--- (candidateQTyVarsWithBinders tvs ty) returns the candidateQTyVars
--- of (forall tvs. ty), but do not treat 'tvs' as bound for the purpose
--- of Note [Naughty quantification candidates].  Why?
--- Because we are going to scoped-sort the quantified variables
--- in among the tvs
-candidateQTyVarsWithBinders bound_tvs ty
-  = do { kvs <- candidateQTyVarsOfKinds (map tyVarKind bound_tvs)
-       ; all_tvs <- collect_cand_qtvs ty False emptyVarSet kvs ty
-       ; return (all_tvs `delCandidates` bound_tvs) }
-
--- | Gathers free variables to use as quantification candidates (in
--- 'quantifyTyVars'). This might output the same var
--- in both sets, if it's used in both a type and a kind.
--- The variables to quantify must have a TcLevel strictly greater than
--- the ambient level. (See Wrinkle in Note [Naughty quantification candidates])
--- See Note [CandidatesQTvs determinism and order]
--- See Note [Dependent type variables]
-candidateQTyVarsOfType :: TcType       -- not necessarily zonked
-                       -> TcM CandidatesQTvs
-candidateQTyVarsOfType ty = collect_cand_qtvs ty False emptyVarSet mempty ty
-
--- | Like 'candidateQTyVarsOfType', but over a list of types
--- The variables to quantify must have a TcLevel strictly greater than
--- the ambient level. (See Wrinkle in Note [Naughty quantification candidates])
-candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs
-candidateQTyVarsOfTypes tys = foldlM (\acc ty -> collect_cand_qtvs ty False emptyVarSet acc ty)
-                                     mempty tys
-
--- | Like 'candidateQTyVarsOfType', but consider every free variable
--- to be dependent. This is appropriate when generalizing a *kind*,
--- instead of a type. (That way, -XNoPolyKinds will default the variables
--- to Type.)
-candidateQTyVarsOfKind :: TcKind       -- Not necessarily zonked
-                       -> TcM CandidatesQTvs
-candidateQTyVarsOfKind ty = collect_cand_qtvs ty True emptyVarSet mempty ty
-
-candidateQTyVarsOfKinds :: [TcKind]    -- Not necessarily zonked
-                       -> TcM CandidatesQTvs
-candidateQTyVarsOfKinds tys = foldM (\acc ty -> collect_cand_qtvs ty True emptyVarSet acc ty)
-                                    mempty tys
-
-collect_cand_qtvs
-  :: TcType          -- original type that we started recurring into; for errors
-  -> Bool            -- True <=> consider every fv in Type to be dependent
-  -> VarSet          -- Bound variables (locals only)
-  -> CandidatesQTvs  -- Accumulating parameter
-  -> Type            -- Not necessarily zonked
-  -> TcM CandidatesQTvs
-
--- Key points:
---   * Looks through meta-tyvars as it goes;
---     no need to zonk in advance
---
---   * Needs to be monadic anyway, because it handles naughty
---     quantification; see Note [Naughty quantification candidates]
---
---   * Returns fully-zonked CandidateQTvs, including their kinds
---     so that subsequent dependency analysis (to build a well
---     scoped telescope) works correctly
-
-collect_cand_qtvs orig_ty is_dep bound dvs ty
-  = go dvs ty
-  where
-    is_bound tv = tv `elemVarSet` bound
-
-    -----------------
-    go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs
-    -- Uses accumulating-parameter style
-    go dv (AppTy t1 t2)    = foldlM go dv [t1, t2]
-    go dv (TyConApp tc tys) = go_tc_args dv (tyConBinders tc) tys
-    go dv (FunTy _ w arg res) = foldlM go dv [w, arg, res]
-    go dv (LitTy {})        = return dv
-    go dv (CastTy ty co)    = do dv1 <- go dv ty
-                                 collect_cand_qtvs_co orig_ty bound dv1 co
-    go dv (CoercionTy co)   = collect_cand_qtvs_co orig_ty bound dv co
-
-    go dv (TyVarTy tv)
-      | is_bound tv = return dv
-      | otherwise   = do { m_contents <- isFilledMetaTyVar_maybe tv
-                         ; case m_contents of
-                             Just ind_ty -> go dv ind_ty
-                             Nothing     -> go_tv dv tv }
-
-    go dv (ForAllTy (Bndr tv _) ty)
-      = do { dv1 <- collect_cand_qtvs orig_ty True bound dv (tyVarKind tv)
-           ; collect_cand_qtvs orig_ty is_dep (bound `extendVarSet` tv) dv1 ty }
-
-      -- This makes sure that we default e.g. the alpha in Proxy alpha (Any alpha).
-      -- Tested in polykinds/NestedProxies.
-      -- We just might get this wrong in AppTy, but I don't think that's possible
-      -- with -XNoPolyKinds. And fixing it would be non-performant, as we'd need
-      -- to look at kinds.
-    go_tc_args dv (tc_bndr:tc_bndrs) (ty:tys)
-      = do { dv1 <- collect_cand_qtvs orig_ty (is_dep || isNamedTyConBinder tc_bndr)
-                                      bound dv ty
-           ; go_tc_args dv1 tc_bndrs tys }
-    go_tc_args dv _bndrs tys  -- _bndrs might be non-empty: undersaturation
-                              -- tys might be non-empty: oversaturation
-                              -- either way, the foldlM is correct
-      = foldlM go dv tys
-
-    -----------------
-    go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv
-      | tv `elemDVarSet` kvs
-      = return dv  -- We have met this tyvar already
-
-      | not is_dep
-      , tv `elemDVarSet` tvs
-      = return dv  -- We have met this tyvar already
-
-      | otherwise
-      = do { tv_kind <- zonkTcType (tyVarKind tv)
-                 -- This zonk is annoying, but it is necessary, both to
-                 -- ensure that the collected candidates have zonked kinds
-                 -- (#15795) and to make the naughty check
-                 -- (which comes next) works correctly
-
-           ; let tv_kind_vars = tyCoVarsOfType tv_kind
-           ; cur_lvl <- getTcLevel
-           ; if |  tcTyVarLevel tv <= cur_lvl
-                -> return dv   -- this variable is from an outer context; skip
-                               -- See Note [Use level numbers for quantification]
-
-                | case tcTyVarDetails tv of
-                     SkolemTv _ lvl _ -> lvl > pushTcLevel cur_lvl
-                     _                -> False
-                -> return dv  -- Skip inner skolems; ToDo: explain
-
-                |  intersectsVarSet bound tv_kind_vars
-                   -- the tyvar must not be from an outer context, but we have
-                   -- already checked for this.
-                   -- See Note [Naughty quantification candidates]
-                -> do { traceTc "Naughty quantifier" $
-                          vcat [ ppr tv <+> dcolon <+> ppr tv_kind
-                               , text "bound:" <+> pprTyVars (nonDetEltsUniqSet bound)
-                               , text "fvs:" <+> pprTyVars (nonDetEltsUniqSet tv_kind_vars) ]
-
-                      ; let escapees = intersectVarSet bound tv_kind_vars
-                      ; naughtyQuantification orig_ty tv escapees }
-
-                |  otherwise
-                -> do { let tv' = tv `setTyVarKind` tv_kind
-                            dv' | is_dep    = dv { dv_kvs = kvs `extendDVarSet` tv' }
-                                | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' }
-                                -- See Note [Order of accumulation]
-
-                        -- See Note [Recurring into kinds for candidateQTyVars]
-                      ; collect_cand_qtvs orig_ty True bound dv' tv_kind } }
-
-collect_cand_qtvs_co :: TcType -- original type at top of recursion; for errors
-                     -> VarSet -- bound variables
-                     -> CandidatesQTvs -> Coercion
-                     -> TcM CandidatesQTvs
-collect_cand_qtvs_co orig_ty bound = go_co
-  where
-    go_co dv (Refl ty)               = collect_cand_qtvs orig_ty True bound dv ty
-    go_co dv (GRefl _ ty mco)        = do dv1 <- collect_cand_qtvs orig_ty True bound dv ty
-                                          go_mco dv1 mco
-    go_co dv (TyConAppCo _ _ cos)    = foldlM go_co dv cos
-    go_co dv (AppCo co1 co2)         = foldlM go_co dv [co1, co2]
-    go_co dv (FunCo _ _ _ w co1 co2) = foldlM go_co dv [w, co1, co2]
-    go_co dv (AxiomInstCo _ _ cos)   = foldlM go_co dv cos
-    go_co dv (AxiomRuleCo _ cos)     = foldlM go_co dv cos
-    go_co dv (UnivCo prov _ t1 t2)   = do dv1 <- go_prov dv prov
-                                          dv2 <- collect_cand_qtvs orig_ty True bound dv1 t1
-                                          collect_cand_qtvs orig_ty True bound dv2 t2
-    go_co dv (SymCo co)              = go_co dv co
-    go_co dv (TransCo co1 co2)       = foldlM go_co dv [co1, co2]
-    go_co dv (SelCo _ co)            = go_co dv co
-    go_co dv (LRCo _ co)             = go_co dv co
-    go_co dv (InstCo co1 co2)        = foldlM go_co dv [co1, co2]
-    go_co dv (KindCo co)             = go_co dv co
-    go_co dv (SubCo co)              = go_co dv co
-
-    go_co dv (HoleCo hole)
-      = do m_co <- unpackCoercionHole_maybe hole
-           case m_co of
-             Just co -> go_co dv co
-             Nothing -> go_cv dv (coHoleCoVar hole)
-
-    go_co dv (CoVarCo cv) = go_cv dv cv
-
-    go_co dv (ForAllCo tcv kind_co co)
-      = do { dv1 <- go_co dv kind_co
-           ; collect_cand_qtvs_co orig_ty (bound `extendVarSet` tcv) dv1 co }
-
-    go_mco dv MRefl    = return dv
-    go_mco dv (MCo co) = go_co dv co
-
-    go_prov dv (PhantomProv co)    = go_co dv co
-    go_prov dv (ProofIrrelProv co) = go_co dv co
-    go_prov dv (PluginProv _)      = return dv
-    go_prov dv (CorePrepProv _)    = return dv
-
-    go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs
-    go_cv dv@(DV { dv_cvs = cvs }) cv
-      | is_bound cv         = return dv
-      | cv `elemVarSet` cvs = return dv
-
-        -- See Note [Recurring into kinds for candidateQTyVars]
-      | otherwise           = collect_cand_qtvs orig_ty True bound
-                                    (dv { dv_cvs = cvs `extendVarSet` cv })
-                                    (idType cv)
-
-    is_bound tv = tv `elemVarSet` bound
-
-{- Note [Order of accumulation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-You might be tempted (like I was) to use unitDVarSet and mappend
-rather than extendDVarSet.  However, the union algorithm for
-deterministic sets depends on (roughly) the size of the sets. The
-elements from the smaller set end up to the right of the elements from
-the larger one. When sets are equal, the left-hand argument to
-`mappend` goes to the right of the right-hand argument.
-
-In our case, if we use unitDVarSet and mappend, we learn that the free
-variables of (a -> b -> c -> d) are [b, a, c, d], and we then quantify
-over them in that order. (The a comes after the b because we union the
-singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter,
-the size criterion works to our advantage.) This is just annoying to
-users, so I use `extendDVarSet`, which unambiguously puts the new
-element to the right.
-
-Note that the unitDVarSet/mappend implementation would not be wrong
-against any specification -- just suboptimal and confounding to users.
-
-Note [Recurring into kinds for candidateQTyVars]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-First, read Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs, paying
-attention to the end of the Note about using an empty bound set when
-traversing a variable's kind.
-
-That Note concludes with the recommendation that we empty out the bound
-set when recurring into the kind of a type variable. Yet, we do not do
-this here. I have two tasks in order to convince you that this code is
-right. First, I must show why it is safe to ignore the reasoning in that
-Note. Then, I must show why is is necessary to contradict the reasoning in
-that Note.
-
-Why it is safe: There can be no
-shadowing in the candidateQ... functions: they work on the output of
-type inference, which is seeded by the renamer and its insistence to
-use different Uniques for different variables. (In contrast, the Core
-functions work on the output of optimizations, which may introduce
-shadowing.) Without shadowing, the problem studied by
-Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs cannot happen.
-
-Why it is necessary:
-Wiping the bound set would be just plain wrong here. Consider
-
-  forall k1 k2 (a :: k1). Proxy k2 (a |> (hole :: k1 ~# k2))
-
-We really don't want to think k1 and k2 are free here. (It's true that we'll
-never be able to fill in `hole`, but we don't want to go off the rails just
-because we have an insoluble coercion hole.) So: why is it wrong to wipe
-the bound variables here but right in Core? Because the final statement
-in Note [Closing over free variable kinds] in GHC.Core.TyCo.FVs is wrong: not
-every variable is either free or bound. A variable can be a hole, too!
-The reasoning in that Note then breaks down.
-
-And the reasoning applies just as well to free non-hole variables, so we
-retain the bound set always.
-
--}
-
-{- *********************************************************************
-*                                                                      *
-             Quantification
-*                                                                      *
-************************************************************************
-
-Note [quantifyTyVars]
-~~~~~~~~~~~~~~~~~~~~~
-quantifyTyVars is given the free vars of a type that we
-are about to wrap in a forall.
-
-It takes these free type/kind variables (partitioned into dependent and
-non-dependent variables) skolemises metavariables with a TcLevel greater
-than the ambient level (see Note [Use level numbers for quantification]).
-
-* This function distinguishes between dependent and non-dependent
-  variables only to keep correct defaulting behavior with -XNoPolyKinds.
-  With -XPolyKinds, it treats both classes of variables identically.
-
-* quantifyTyVars never quantifies over
-    - a coercion variable (or any tv mentioned in the kind of a covar)
-    - a runtime-rep variable
-
-Note [Use level numbers for quantification]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The level numbers assigned to metavariables are very useful. Not only
-do they track touchability (Note [TcLevel invariants] in GHC.Tc.Utils.TcType),
-but they also allow us to determine which variables to
-generalise. The rule is this:
-
-  When generalising, quantify only metavariables with a TcLevel greater
-  than the ambient level.
-
-This works because we bump the level every time we go inside a new
-source-level construct. In a traditional generalisation algorithm, we
-would gather all free variables that aren't free in an environment.
-However, if a variable is in that environment, it will always have a lower
-TcLevel: it came from an outer scope. So we can replace the "free in
-environment" check with a level-number check.
-
-Here is an example:
-
-  f x = x + (z True)
-    where
-      z y = x * x
-
-We start by saying (x :: alpha[1]). When inferring the type of z, we'll
-quickly discover that z :: alpha[1]. But it would be disastrous to
-generalise over alpha in the type of z. So we need to know that alpha
-comes from an outer environment. By contrast, the type of y is beta[2],
-and we are free to generalise over it. What's the difference between
-alpha[1] and beta[2]? Their levels. beta[2] has the right TcLevel for
-generalisation, and so we generalise it. alpha[1] does not, and so
-we leave it alone.
-
-Note that not *every* variable with a higher level will get
-generalised, either due to the monomorphism restriction or other
-quirks. See, for example, the code in GHC.Tc.Solver.decideMonoTyVars
-and in GHC.Tc.Gen.HsType.kindGeneralizeSome, both of which exclude
-certain otherwise-eligible variables from being generalised.
-
-Using level numbers for quantification is implemented in the candidateQTyVars...
-functions, by adding only those variables with a level strictly higher than
-the ambient level to the set of candidates.
-
-Note [quantifyTyVars determinism]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The results of quantifyTyVars are wrapped in a forall and can end up in the
-interface file. One such example is inferred type signatures. They also affect
-the results of optimizations, for example worker-wrapper. This means that to
-get deterministic builds quantifyTyVars needs to be deterministic.
-
-To achieve this CandidatesQTvs is backed by deterministic sets which allows them
-to be later converted to a list in a deterministic order.
-
-For more information about deterministic sets see
-Note [Deterministic UniqFM] in GHC.Types.Unique.DFM.
--}
-
-quantifyTyVars :: SkolemInfo
-               -> NonStandardDefaultingStrategy
-               -> CandidatesQTvs   -- See Note [Dependent type variables]
-                                   -- Already zonked
-               -> TcM [TcTyVar]
--- See Note [quantifyTyVars]
--- Can be given a mixture of TcTyVars and TyVars, in the case of
---   associated type declarations. Also accepts covars, but *never* returns any.
--- According to Note [Use level numbers for quantification] and the
--- invariants on CandidateQTvs, we do not have to filter out variables
--- free in the environment here. Just quantify unconditionally, subject
--- to the restrictions in Note [quantifyTyVars].
-quantifyTyVars skol_info ns_strat dvs
-       -- short-circuit common case
-  | isEmptyCandidates dvs
-  = do { traceTc "quantifyTyVars has nothing to quantify" empty
-       ; return [] }
-
-  | otherwise
-  = do { traceTc "quantifyTyVars {"
-           ( vcat [ text "ns_strat =" <+> ppr ns_strat
-                  , text "dvs =" <+> ppr dvs ])
-
-       ; undefaulted <- defaultTyVars ns_strat dvs
-       ; final_qtvs  <- mapMaybeM zonk_quant undefaulted
-
-       ; traceTc "quantifyTyVars }"
-           (vcat [ text "undefaulted:" <+> pprTyVars undefaulted
-                 , text "final_qtvs:"  <+> pprTyVars final_qtvs ])
-
-       -- We should never quantify over coercion variables; check this
-       ; let co_vars = filter isCoVar final_qtvs
-       ; massertPpr (null co_vars) (ppr co_vars)
-
-       ; return final_qtvs }
-  where
-    -- zonk_quant returns a tyvar if it should be quantified over;
-    -- otherwise, it returns Nothing. The latter case happens for
-    -- non-meta-tyvars
-    zonk_quant tkv
-      | not (isTyVar tkv)
-      = return Nothing   -- this can happen for a covar that's associated with
-                         -- a coercion hole. Test case: typecheck/should_compile/T2494
-
-      | otherwise
-      = Just <$> skolemiseQuantifiedTyVar skol_info tkv
-
-isQuantifiableTv :: TcLevel   -- Level of the context, outside the quantification
-                 -> TcTyVar
-                 -> Bool
-isQuantifiableTv outer_tclvl tcv
-  | isTcTyVar tcv  -- Might be a CoVar; change this when gather covars separately
-  = tcTyVarLevel tcv > outer_tclvl
-  | otherwise
-  = False
-
-zonkAndSkolemise :: SkolemInfo -> TcTyCoVar -> TcM TcTyCoVar
--- A tyvar binder is never a unification variable (TauTv),
--- rather it is always a skolem. It *might* be a TyVarTv.
--- (Because non-CUSK type declarations use TyVarTvs.)
--- Regardless, it may have a kind that has not yet been zonked,
--- and may include kind unification variables.
-zonkAndSkolemise skol_info tyvar
-  | isTyVarTyVar tyvar
-     -- We want to preserve the binding location of the original TyVarTv.
-     -- This is important for error messages. If we don't do this, then
-     -- we get bad locations in, e.g., typecheck/should_fail/T2688
-  = do { zonked_tyvar <- zonkTcTyVarToTcTyVar tyvar
-       ; skolemiseQuantifiedTyVar skol_info zonked_tyvar }
-
-  | otherwise
-  = assertPpr (isImmutableTyVar tyvar || isCoVar tyvar) (pprTyVar tyvar) $
-    zonkTyCoVarKind tyvar
-
-skolemiseQuantifiedTyVar :: SkolemInfo -> TcTyVar -> TcM TcTyVar
--- The quantified type variables often include meta type variables
--- we want to freeze them into ordinary type variables
--- The meta tyvar is updated to point to the new skolem TyVar.  Now any
--- bound occurrences of the original type variable will get zonked to
--- the immutable version.
---
--- We leave skolem TyVars alone; they are immutable.
---
--- This function is called on both kind and type variables,
--- but kind variables *only* if PolyKinds is on.
-
-skolemiseQuantifiedTyVar skol_info tv
-  = case tcTyVarDetails tv of
-      MetaTv {} -> skolemiseUnboundMetaTyVar skol_info tv
-
-      SkolemTv _ lvl _  -- It might be a skolem type variable,
-                        -- for example from a user type signature
-        -- But it might also be a shared meta-variable across several
-        -- type declarations, each with its own skol_info. The first
-        -- will skolemise it, but the other uses must update its
-        -- skolem info (#22379)
-        -> do { kind <- zonkTcType (tyVarKind tv)
-              ; let details = SkolemTv skol_info lvl False
-                    name = tyVarName tv
-              ; return (mkTcTyVar name kind details) }
-
-      _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk
-
--- | Default a type variable using the given defaulting strategy.
---
--- See Note [Type variable defaulting options] in GHC.Types.Basic.
-defaultTyVar :: DefaultingStrategy
-             -> TcTyVar    -- If it's a MetaTyVar then it is unbound
-             -> TcM Bool   -- True <=> defaulted away altogether
-defaultTyVar def_strat tv
-  | not (isMetaTyVar tv)
-  || isTyVarTyVar tv
-    -- Do not default TyVarTvs. Doing so would violate the invariants
-    -- on TyVarTvs; see Note [TyVarTv] in GHC.Tc.Utils.TcMType.
-    -- #13343 is an example; #14555 is another
-    -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl
-  = return False
-
-  | isRuntimeRepVar tv
-  , default_ns_vars
-  = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv)
-       ; writeMetaTyVar tv liftedRepTy
-       ; return True }
-  | isLevityVar tv
-  , default_ns_vars
-  = do { traceTc "Defaulting a Levity var to Lifted" (ppr tv)
-       ; writeMetaTyVar tv liftedDataConTy
-       ; return True }
-  | isMultiplicityVar tv
-  , default_ns_vars
-  = do { traceTc "Defaulting a Multiplicity var to Many" (ppr tv)
-       ; writeMetaTyVar tv manyDataConTy
-       ; return True }
-
-  | DefaultKindVars <- def_strat -- -XNoPolyKinds and this is a kind var: we must default it
-  = default_kind_var tv
-
-  | otherwise
-  = return False
-
-  where
-    default_ns_vars :: Bool
-    default_ns_vars = defaultNonStandardTyVars def_strat
-    default_kind_var :: TyVar -> TcM Bool
-       -- defaultKindVar is used exclusively with -XNoPolyKinds
-       -- See Note [Defaulting with -XNoPolyKinds]
-       -- It takes an (unconstrained) meta tyvar and defaults it.
-       -- Works only on vars of type *; for other kinds, it issues an error.
-    default_kind_var kv
-      | isLiftedTypeKind (tyVarKind kv)
-      = do { traceTc "Defaulting a kind var to *" (ppr kv)
-           ; writeMetaTyVar kv liftedTypeKind
-           ; return True }
-      | otherwise
-      = do { addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-               (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv')
-                     , text "of kind:" <+> ppr (tyVarKind kv')
-                     , text "Perhaps enable PolyKinds or add a kind signature" ])
-           -- We failed to default it, so return False to say so.
-           -- Hence, it'll get skolemised.  That might seem odd, but we must either
-           -- promote, skolemise, or zap-to-Any, to satisfy GHC.Tc.Gen.HsType
-           --    Note [Recipe for checking a signature]
-           -- Otherwise we get level-number assertion failures. It doesn't matter much
-           -- because we are in an error situation anyway.
-           ; return False
-        }
-      where
-        (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv
-
--- | Default some unconstrained type variables, as specified
--- by the defaulting options:
---
---  - 'RuntimeRep' tyvars default to 'LiftedRep'
---  - 'Levity' tyvars default to 'Lifted'
---  - 'Multiplicity' tyvars default to 'Many'
---  - 'Type' tyvars from dv_kvs default to 'Type', when -XNoPolyKinds
---    (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error)
-defaultTyVars :: NonStandardDefaultingStrategy
-              -> CandidatesQTvs    -- ^ all candidates for quantification
-              -> TcM [TcTyVar]     -- ^ those variables not defaulted
-defaultTyVars ns_strat dvs
-  = do { poly_kinds <- xoptM LangExt.PolyKinds
-       ; let
-           def_tvs, def_kvs :: DefaultingStrategy
-           def_tvs = NonStandardDefaulting ns_strat
-           def_kvs
-             | poly_kinds = def_tvs
-             | otherwise  = DefaultKindVars
-             -- As -XNoPolyKinds precludes polymorphic kind variables, we default them.
-             -- For example:
-             --
-             --   type F :: Type -> Type
-             --   type family F a where
-             --      F (a -> b) = b
-             --
-             -- Here we get `a :: TYPE r`, so to accept this program when -XNoPolyKinds is enabled
-             -- we must default the kind variable `r :: RuntimeRep`.
-             -- Test case: T20584.
-       ; defaulted_kvs <- mapM (defaultTyVar def_kvs) dep_kvs
-       ; defaulted_tvs <- mapM (defaultTyVar def_tvs) nondep_tvs
-       ; let undefaulted_kvs = [ kv | (kv, False) <- dep_kvs    `zip` defaulted_kvs ]
-             undefaulted_tvs = [ tv | (tv, False) <- nondep_tvs `zip` defaulted_tvs ]
-       ; return (undefaulted_kvs ++ undefaulted_tvs) }
-          -- NB: kvs before tvs because tvs may depend on kvs
-  where
-    (dep_kvs, nondep_tvs) = candidateVars dvs
-
-skolemiseUnboundMetaTyVar :: SkolemInfo -> TcTyVar -> TcM TyVar
--- We have a Meta tyvar with a ref-cell inside it
--- Skolemise it, so that we are totally out of Meta-tyvar-land
--- We create a skolem TcTyVar, not a regular TyVar
---   See Note [Zonking to Skolem]
---
--- Its level should be one greater than the ambient level, which will typically
--- be the same as the level on the meta-tyvar. But not invariably; for example
---    f :: (forall a b. SameKind a b) -> Int
--- The skolems 'a' and 'b' are bound by tcTKTelescope, at level 2; and they each
--- have a level-2 kind unification variable, since it might get unified with another
--- of the level-2 skolems e.g. 'k' in this version
---    f :: (forall k (a :: k) b. SameKind a b) -> Int
--- So when we quantify the kind vars at the top level of the signature, the ambient
--- level is 1, but we will quantify over kappa[2].
-
-skolemiseUnboundMetaTyVar skol_info tv
-  = assertPpr (isMetaTyVar tv) (ppr tv) $
-    do  { check_empty tv
-        ; tc_lvl <- getTcLevel   -- Get the location and level from "here"
-        ; here   <- getSrcSpanM  -- i.e. where we are generalising
-        ; kind   <- zonkTcType (tyVarKind tv)
-        ; let tv_name = tyVarName tv
-              -- See Note [Skolemising and identity]
-              final_name | isSystemName tv_name
-                         = mkInternalName (nameUnique tv_name)
-                                          (nameOccName tv_name) here
-                         | otherwise
-                         = tv_name
-              details    = SkolemTv skol_info (pushTcLevel tc_lvl) False
-              final_tv   = mkTcTyVar final_name kind details
-
-        ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv)
-        ; writeMetaTyVar tv (mkTyVarTy final_tv)
-        ; return final_tv }
-  where
-    check_empty tv       -- [Sept 04] Check for non-empty.
-      = when debugIsOn $  -- See Note [Silly Type Synonyms]
-        do { cts <- readMetaTyVar tv
-           ; case cts of
-               Flexi       -> return ()
-               Indirect ty -> warnPprTrace True "skolemiseUnboundMetaTyVar" (ppr tv $$ ppr ty) $
-                              return () }
-
-{- Note [Error on unconstrained meta-variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-* type C :: Type -> Type -> Constraint
-  class (forall a. a b ~ a c) => C b c
-
-* type T = forall a. Proxy a
-
-* data (forall a. a b ~ a c) => T b c
-
-* type instance F Int = Proxy Any
-  where Any :: forall k. k
-
-In the first three cases we will infer a :: Type -> kappa, but then
-we get no further information on kappa. In the last, we will get
-  Proxy kappa Any
-but again will get no further info on kappa.
-
-What do do?
- A. We could choose kappa := Type. But this only works when the kind of kappa
-    is Type (true in this example, but not always).
- B. We could default to Any.
- C. We could quantify.
- D. We could error.
-
-We choose (D), as described in #17567, and implement this choice in
-doNotQuantifyTyVars.  Discussion of alternativs A-C is below.
-
-NB: this is all rather similar to, but sadly not the same as
-    Note [Naughty quantification candidates]
-
-To do this, we must take an extra step before doing the final zonk to create
-e.g. a TyCon. (There is no problem in the final term-level zonk. See the
-section on alternative (B) below.) This extra step is needed only for
-constructs that do not quantify their free meta-variables, such as a class
-constraint or right-hand side of a type synonym.
-
-Specifically: before the final zonk, every construct must either call
-quantifyTyVars or doNotQuantifyTyVars. The latter issues an error
-if it is passed any free variables. (Exception: we still default
-RuntimeRep and Multiplicity variables.)
-
-Because no meta-variables remain after quantifying or erroring, we perform
-the zonk with NoFlexi, which panics upon seeing a meta-variable.
-
-Alternatives A-C, not implemented:
-
-A. As stated above, this works only sometimes. We might have a free
-   meta-variable of kind Nat, for example.
-
-B. This is what we used to do, but it caused Any to appear in error
-   messages sometimes. See #17567 for several examples. Defaulting to
-   Any during the final, whole-program zonk is OK, though, because
-   we are completely done type-checking at that point. No chance to
-   leak into an error message.
-
-C. Examine the class declaration at the top of this Note again.
-   Where should we quantify? We might imagine quantifying and
-   putting the kind variable in the forall of the quantified constraint.
-   But what if there are nested foralls? Which one should get the
-   variable? Other constructs have other problems. (For example,
-   the right-hand side of a type family instance equation may not
-   be a poly-type.)
-
-   More broadly, the GHC AST defines a set of places where it performs
-   implicit lexical generalization. For example, in a type
-   signature
-
-     f :: Proxy a -> Bool
-
-   the otherwise-unbound a is lexically quantified, giving us
-
-     f :: forall a. Proxy a -> Bool
-
-   The places that allow lexical quantification are marked in the AST with
-   HsImplicitBndrs. HsImplicitBndrs offers a binding site for otherwise-unbound
-   variables.
-
-   Later, during type-checking, we discover that a's kind is unconstrained.
-   We thus quantify *again*, to
-
-     f :: forall {k} (a :: k). Proxy @k a -> Bool
-
-   It is this second quantification that this Note is really about --
-   let's call it *inferred quantification*.
-   So there are two sorts of implicit quantification in types:
-     1. Lexical quantification: signalled by HsImplicitBndrs, occurs over
-        variables mentioned by the user but with no explicit binding site,
-        suppressed by a user-written forall (by the forall-or-nothing rule,
-        in Note [forall-or-nothing rule] in GHC.Hs.Type).
-     2. Inferred quantification: no signal in HsSyn, occurs over unconstrained
-        variables invented by the type-checker, possible only with -XPolyKinds,
-        unaffected by forall-or-nothing rule
-   These two quantifications are performed in different compiler phases, and are
-   essentially unrelated. However, it is convenient
-   for programmers to remember only one set of implicit quantification
-   sites. So, we choose to use the same places (those with HsImplicitBndrs)
-   for lexical quantification as for inferred quantification of unconstrained
-   meta-variables. Accordingly, there is no quantification in a class
-   constraint, or the other constructs that call doNotQuantifyTyVars.
--}
-
-doNotQuantifyTyVars :: CandidatesQTvs
-                    -> (TidyEnv -> TcM (TidyEnv, SDoc))
-                            -- ^ like "the class context (D a b, E foogle)"
-                    -> TcM ()
--- See Note [Error on unconstrained meta-variables]
-doNotQuantifyTyVars dvs where_found
-  | isEmptyCandidates dvs
-  = traceTc "doNotQuantifyTyVars has nothing to error on" empty
-
-  | otherwise
-  = do { traceTc "doNotQuantifyTyVars" (ppr dvs)
-       ; undefaulted <- defaultTyVars DefaultNonStandardTyVars dvs
-          -- could have regular TyVars here, in an associated type RHS, or
-          -- bound by a type declaration head. So filter looking only for
-          -- metavars. e.g. b and c in `class (forall a. a b ~ a c) => C b c`
-          -- are OK
-       ; let leftover_metas = filter isMetaTyVar undefaulted
-       ; unless (null leftover_metas) $
-         do { let (tidy_env1, tidied_tvs) = tidyOpenTyCoVars emptyTidyEnv leftover_metas
-            ; (tidy_env2, where_doc) <- where_found tidy_env1
-            ; let msg = mkTcRnUnknownMessage            $
-                        mkPlainError noHints          $
-                        pprWithExplicitKindsWhen True $
-                    vcat [ text "Uninferrable type variable"
-                           <> plural tidied_tvs
-                           <+> pprWithCommas pprTyVar tidied_tvs
-                           <+> text "in"
-                         , where_doc ]
-            ; failWithTcM (tidy_env2, msg) }
-       ; traceTc "doNotQuantifyTyVars success" empty }
-
-{- Note [Defaulting with -XNoPolyKinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-
-  data Compose f g a = Mk (f (g a))
-
-We infer
-
-  Compose :: forall k1 k2. (k2 -> *) -> (k1 -> k2) -> k1 -> *
-  Mk :: forall k1 k2 (f :: k2 -> *) (g :: k1 -> k2) (a :: k1).
-        f (g a) -> Compose k1 k2 f g a
-
-Now, in another module, we have -XNoPolyKinds -XDataKinds in effect.
-What does 'Mk mean? Pre GHC-8.0 with -XNoPolyKinds,
-we just defaulted all kind variables to *. But that's no good here,
-because the kind variables in 'Mk aren't of kind *, so defaulting to *
-is ill-kinded.
-
-After some debate on #11334, we decided to issue an error in this case.
-The code is in defaultKindVar.
-
-Note [What is a meta variable?]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A "meta type-variable", also know as a "unification variable" is a placeholder
-introduced by the typechecker for an as-yet-unknown monotype.
-
-For example, when we see a call `reverse (f xs)`, we know that we calling
-    reverse :: forall a. [a] -> [a]
-So we know that the argument `f xs` must be a "list of something". But what is
-the "something"? We don't know until we explore the `f xs` a bit more. So we set
-out what we do know at the call of `reverse` by instantiating its type with a fresh
-meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the
-result, is `[alpha]`. The unification variable `alpha` stands for the
-as-yet-unknown type of the elements of the list.
-
-As type inference progresses we may learn more about `alpha`. For example, suppose
-`f` has the type
-    f :: forall b. b -> [Maybe b]
-Then we instantiate `f`'s type with another fresh unification variable, say
-`beta`; and equate `f`'s result type with reverse's argument type, thus
-`[alpha] ~ [Maybe beta]`.
-
-Now we can solve this equality to learn that `alpha ~ Maybe beta`, so we've
-refined our knowledge about `alpha`. And so on.
-
-If you found this Note useful, you may also want to have a look at
-Section 5 of "Practical type inference for higher rank types" (Peyton Jones,
-Vytiniotis, Weirich and Shields. J. Functional Programming. 2011).
-
-Note [What is zonking?]
-~~~~~~~~~~~~~~~~~~~~~~~
-GHC relies heavily on mutability in the typechecker for efficient operation.
-For this reason, throughout much of the type checking process meta type
-variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable
-variables (known as TcRefs).
-
-Zonking is the process of ripping out these mutable variables and replacing them
-with a real Type. This involves traversing the entire type expression, but the
-interesting part of replacing the mutable variables occurs in zonkTyVarOcc.
-
-There are two ways to zonk a Type:
-
- * zonkTcTypeToType, which is intended to be used at the end of type-checking
-   for the final zonk. It has to deal with unfilled metavars, either by filling
-   it with a value like Any or failing (determined by the UnboundTyVarZonker
-   used).
-
- * zonkTcType, which will happily ignore unfilled metavars. This is the
-   appropriate function to use while in the middle of type-checking.
-
-Note [Zonking to Skolem]
-~~~~~~~~~~~~~~~~~~~~~~~~
-We used to zonk quantified type variables to regular TyVars.  However, this
-leads to problems.  Consider this program from the regression test suite:
-
-  eval :: Int -> String -> String -> String
-  eval 0 root actual = evalRHS 0 root actual
-
-  evalRHS :: Int -> a
-  evalRHS 0 root actual = eval 0 root actual
-
-It leads to the deferral of an equality (wrapped in an implication constraint)
-
-  forall a. () => ((String -> String -> String) ~ a)
-
-which is propagated up to the toplevel (see GHC.Tc.Solver.tcSimplifyInferCheck).
-In the meantime `a' is zonked and quantified to form `evalRHS's signature.
-This has the *side effect* of also zonking the `a' in the deferred equality
-(which at this point is being handed around wrapped in an implication
-constraint).
-
-Finally, the equality (with the zonked `a') will be handed back to the
-simplifier by GHC.Tc.Module.tcRnSrcDecls calling GHC.Tc.Solver.tcSimplifyTop.
-If we zonk `a' with a regular type variable, we will have this regular type
-variable now floating around in the simplifier, which in many places assumes to
-only see proper TcTyVars.
-
-We can avoid this problem by zonking with a skolem TcTyVar.  The
-skolem is rigid (which we require for a quantified variable), but is
-still a TcTyVar that the simplifier knows how to deal with.
-
-Note [Skolemising and identity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In some places, we make a TyVarTv for a binder. E.g.
-    class C a where ...
-As Note [Inferring kinds for type declarations] discusses,
-we make a TyVarTv for 'a'.  Later we skolemise it, and we'd
-like to retain its identity, location info etc.  (If we don't
-retain its identity we'll have to do some pointless swizzling;
-see GHC.Tc.TyCl.swizzleTcTyConBndrs.  If we retain its identity
-but not its location we'll lose the detailed binding site info.
-
-Conclusion: use the Name of the TyVarTv.  But we don't want
-to do that when skolemising random unification variables;
-there the location we want is the skolemisation site.
-
-Fortunately we can tell the difference: random unification
-variables have System Names.  That's why final_name is
-set based on the isSystemName test.
-
-
-Note [Silly Type Synonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this:
-        type C u a = u  -- Note 'a' unused
-
-        foo :: (forall a. C u a -> C u a) -> u
-        foo x = ...
-
-        bar :: Num u => u
-        bar = foo (\t -> t + t)
-
-* From the (\t -> t+t) we get type  {Num d} =>  d -> d
-  where d is fresh.
-
-* Now unify with type of foo's arg, and we get:
-        {Num (C d a)} =>  C d a -> C d a
-  where a is fresh.
-
-* Now abstract over the 'a', but float out the Num (C d a) constraint
-  because it does not 'really' mention a.  (see exactTyVarsOfType)
-  The arg to foo becomes
-        \/\a -> \t -> t+t
-
-* So we get a dict binding for Num (C d a), which is zonked to give
-        a = ()
-  Note (Sept 04): now that we are zonking quantified type variables
-  on construction, the 'a' will be frozen as a regular tyvar on
-  quantification, so the floated dict will still have type (C d a).
-  Which renders this whole note moot; happily!]
-
-* Then the \/\a abstraction has a zonked 'a' in it.
-
-All very silly.   I think its harmless to ignore the problem.  We'll end up with
-a \/\a in the final result but all the occurrences of a will be zonked to ()
--}
-
-{- *********************************************************************
-*                                                                      *
-              Promotion
-*                                                                      *
-********************************************************************* -}
-
-promoteMetaTyVarTo :: TcLevel -> TcTyVar -> TcM Bool
--- When we float a constraint out of an implication we must restore
--- invariant (WantedInv) in Note [TcLevel invariants] in GHC.Tc.Utils.TcType
--- Return True <=> we did some promotion
--- Also returns either the original tyvar (no promotion) or the new one
--- See Note [Promoting unification variables]
-promoteMetaTyVarTo tclvl tv
-  | assertPpr (isMetaTyVar tv) (ppr tv) $
-    tcTyVarLevel tv `strictlyDeeperThan` tclvl
-  = do { cloned_tv <- cloneMetaTyVar tv
-       ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl
-       ; writeMetaTyVar tv (mkTyVarTy rhs_tv)
-       ; traceTc "promoteTyVar" (ppr tv <+> text "-->" <+> ppr rhs_tv)
-       ; return True }
-   | otherwise
-   = return False
-
--- Returns whether or not *any* tyvar is defaulted
-promoteTyVarSet :: TcTyVarSet -> TcM Bool
-promoteTyVarSet tvs
-  = do { tclvl <- getTcLevel
-       ; bools <- mapM (promoteMetaTyVarTo tclvl)  $
-                  filter isPromotableMetaTyVar $
-                  nonDetEltsUniqSet tvs
-         -- Non-determinism is OK because order of promotion doesn't matter
-       ; return (or bools) }
-
-
-{- *********************************************************************
-*                                                                      *
-              Zonking types
-*                                                                      *
-********************************************************************* -}
-
-zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet
--- Zonk a type and take its free variables
--- With kind polymorphism it can be essential to zonk *first*
--- so that we find the right set of free variables.  Eg
---    forall k1. forall (a:k2). a
--- where k2:=k1 is in the substitution.  We don't want
--- k2 to look free in this type!
-zonkTcTypeAndFV ty
-  = tyCoVarsOfTypeDSet <$> zonkTcType ty
-
-zonkTyCoVar :: TyCoVar -> TcM TcType
--- Works on TyVars and TcTyVars
-zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv
-               | isTyVar   tv = mkTyVarTy <$> zonkTyCoVarKind tv
-               | otherwise    = assertPpr (isCoVar tv) (ppr tv) $
-                                mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv
-   -- Hackily, when typechecking type and class decls
-   -- we have TyVars in scope added (only) in
-   -- GHC.Tc.Gen.HsType.bindTyClTyVars, but it seems
-   -- painful to make them into TcTyVars there
-
-zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet
-zonkTyCoVarsAndFV tycovars
-  = tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars)
-  -- It's OK to use nonDetEltsUniqSet here because we immediately forget about
-  -- the ordering by turning it into a nondeterministic set and the order
-  -- of zonking doesn't matter for determinism.
-
-zonkDTyCoVarSetAndFV :: DTyCoVarSet -> TcM DTyCoVarSet
-zonkDTyCoVarSetAndFV tycovars
-  = mkDVarSet <$> (zonkTyCoVarsAndFVList $ dVarSetElems tycovars)
-
--- Takes a list of TyCoVars, zonks them and returns a
--- deterministically ordered list of their free variables.
-zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar]
-zonkTyCoVarsAndFVList tycovars
-  = tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars
-
-zonkTcTyVars :: [TcTyVar] -> TcM [TcType]
-zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars
-
------------------  Types
-zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar
-zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv)
-                        ; return (setTyVarKind tv kind') }
-
-{-
-************************************************************************
-*                                                                      *
-              Zonking constraints
-*                                                                      *
-************************************************************************
--}
-
-zonkImplication :: Implication -> TcM Implication
-zonkImplication implic@(Implic { ic_skols  = skols
-                               , ic_given  = given
-                               , ic_wanted = wanted
-                               , ic_info   = info })
-  = do { skols'  <- mapM zonkTyCoVarKind skols  -- Need to zonk their kinds!
-                                                -- as #7230 showed
-       ; given'  <- mapM zonkEvVar given
-       ; info'   <- zonkSkolemInfoAnon info
-       ; wanted' <- zonkWCRec wanted
-       ; return (implic { ic_skols  = skols'
-                        , ic_given  = given'
-                        , ic_wanted = wanted'
-                        , ic_info   = info' }) }
-
-zonkEvVar :: EvVar -> TcM EvVar
-zonkEvVar var = updateIdTypeAndMultM zonkTcType var
-
-
-zonkWC :: WantedConstraints -> TcM WantedConstraints
-zonkWC wc = zonkWCRec wc
-
-zonkWCRec :: WantedConstraints -> TcM WantedConstraints
-zonkWCRec (WC { wc_simple = simple, wc_impl = implic, wc_errors = errs })
-  = do { simple' <- zonkSimples simple
-       ; implic' <- mapBagM zonkImplication implic
-       ; errs'   <- mapBagM zonkDelayedError errs
-       ; return (WC { wc_simple = simple', wc_impl = implic', wc_errors = errs' }) }
-
-zonkSimples :: Cts -> TcM Cts
-zonkSimples cts = do { cts' <- mapBagM zonkCt cts
-                     ; traceTc "zonkSimples done:" (ppr cts')
-                     ; return cts' }
-
-zonkDelayedError :: DelayedError -> TcM DelayedError
-zonkDelayedError (DE_Hole hole)
-  = DE_Hole <$> zonkHole hole
-zonkDelayedError (DE_NotConcrete err)
-  = DE_NotConcrete <$> zonkNotConcreteError err
-
-zonkHole :: Hole -> TcM Hole
-zonkHole hole@(Hole { hole_ty = ty })
-  = do { ty' <- zonkTcType ty
-       ; return (hole { hole_ty = ty' }) }
-
-zonkNotConcreteError :: NotConcreteError -> TcM NotConcreteError
-zonkNotConcreteError err@(NCE_FRR { nce_frr_origin = frr_orig })
-  = do { frr_orig  <- zonkFRROrigin frr_orig
-       ; return $ err { nce_frr_origin = frr_orig  } }
-
-zonkFRROrigin :: FixedRuntimeRepOrigin -> TcM FixedRuntimeRepOrigin
-zonkFRROrigin (FixedRuntimeRepOrigin ty orig)
-  = do { ty' <- zonkTcType ty
-       ; return $ FixedRuntimeRepOrigin ty' orig }
-
-{- Note [zonkCt behaviour]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-zonkCt tries to maintain the canonical form of a Ct.  For example,
-  - a CDictCan should stay a CDictCan;
-  - a CIrredCan should stay a CIrredCan with its cc_reason flag intact
-
-Why?, for example:
-- For CDictCan, the @GHC.Tc.Solver.expandSuperClasses@ step, which runs after the
-  simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use,
-  constraints are zonked before being passed to the plugin. This means if we
-  don't preserve a canonical form, @expandSuperClasses@ fails to expand
-  superclasses. This is what happened in #11525.
-
-- For CIrredCan we want to see if a constraint is insoluble with insolubleWC
-
-On the other hand, we change CEqCan to CNonCanonical, because of all of
-CEqCan's invariants, which can break during zonking. (Example: a ~R alpha, where
-we have alpha := N Int, where N is a newtype.) Besides, the constraint
-will be canonicalised again, so there is little benefit in keeping the
-CEqCan structure.
-
-NB: Constraints are always rewritten etc by the canonicaliser in
-@GHC.Tc.Solver.Canonical@ even if they come in as CDictCan. Only canonical constraints that
-are actually in the inert set carry all the guarantees. So it is okay if zonkCt
-creates e.g. a CDictCan where the cc_tyars are /not/ fully reduced.
--}
-
-zonkCt :: Ct -> TcM Ct
--- See Note [zonkCt behaviour]
-zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args })
-  = do { ev'   <- zonkCtEvidence ev
-       ; args' <- mapM zonkTcType args
-       ; return $ ct { cc_ev = ev', cc_tyargs = args' } }
-
-zonkCt (CEqCan { cc_ev = ev })
-  = mkNonCanonical <$> zonkCtEvidence ev
-
-zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_reason flag
-  = do { ev' <- zonkCtEvidence ev
-       ; return (ct { cc_ev = ev' }) }
-
-zonkCt ct
-  = do { fl' <- zonkCtEvidence (ctEvidence ct)
-       ; return (mkNonCanonical fl') }
-
-zonkCtEvidence :: CtEvidence -> TcM CtEvidence
-zonkCtEvidence ctev
-  = do { pred' <- zonkTcType (ctev_pred ctev)
-       ; return (setCtEvPredType ctev pred')
-       }
-
-zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo
-zonkSkolemInfo (SkolemInfo u sk) = SkolemInfo u <$> zonkSkolemInfoAnon sk
-
-zonkSkolemInfoAnon :: SkolemInfoAnon -> TcM SkolemInfoAnon
-zonkSkolemInfoAnon (SigSkol cx ty tv_prs)  = do { ty' <- zonkTcType ty
-                                            ; return (SigSkol cx ty' tv_prs) }
-zonkSkolemInfoAnon (InferSkol ntys) = do { ntys' <- mapM do_one ntys
-                                     ; return (InferSkol ntys') }
-  where
-    do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') }
-zonkSkolemInfoAnon skol_info = return skol_info
-
-{-
-************************************************************************
-*                                                                      *
-     Zonking -- the main work-horses: zonkTcType, zonkTcTyVar
-*                                                                      *
-************************************************************************
--}
-
--- For unbound, mutable tyvars, zonkType uses the function given to it
--- For tyvars bound at a for-all, zonkType zonks them to an immutable
---      type variable and zonks the kind too
-zonkTcType  :: TcType -> TcM TcType
-zonkTcTypes :: [TcType] -> TcM [TcType]
-zonkCo      :: Coercion -> TcM Coercion
-
-(zonkTcType, zonkTcTypes, zonkCo, _)
-  = mapTyCo zonkTcTypeMapper
-
--- | A suitable TyCoMapper for zonking a type during type-checking,
--- before all metavars are filled in.
-zonkTcTypeMapper :: TyCoMapper () TcM
-zonkTcTypeMapper = TyCoMapper
-  { tcm_tyvar = const zonkTcTyVar
-  , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv)
-  , tcm_hole  = hole
-  , tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTyCoVarKind tv
-  , tcm_tycon      = zonkTcTyCon }
-  where
-    hole :: () -> CoercionHole -> TcM Coercion
-    hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
-      = do { contents <- readTcRef ref
-           ; case contents of
-               Just co -> do { co' <- zonkCo co
-                             ; checkCoercionHole cv co' }
-               Nothing -> do { cv' <- zonkCoVar cv
-                             ; return $ HoleCo (hole { ch_co_var = cv' }) } }
-
-zonkTcTyCon :: TcTyCon -> TcM TcTyCon
--- Only called on TcTyCons
--- A non-poly TcTyCon may have unification
--- variables that need zonking, but poly ones cannot
-zonkTcTyCon tc
- | tcTyConIsPoly tc = return tc
- | otherwise        = do { tck' <- zonkTcType (tyConKind tc)
-                         ; return (setTcTyConKind tc tck') }
-
-zonkTcTyVar :: TcTyVar -> TcM TcType
--- Simply look through all Flexis
-zonkTcTyVar tv
-  | isTcTyVar tv
-  = case tcTyVarDetails tv of
-      SkolemTv {}   -> zonk_kind_and_return
-      RuntimeUnk {} -> zonk_kind_and_return
-      MetaTv { mtv_ref = ref }
-         -> do { cts <- readMutVar ref
-               ; case cts of
-                    Flexi       -> zonk_kind_and_return
-                    Indirect ty -> do { zty <- zonkTcType ty
-                                      ; writeTcRef ref (Indirect zty)
-                                        -- See Note [Sharing in zonking]
-                                      ; return zty } }
-
-  | otherwise -- coercion variable
-  = zonk_kind_and_return
-  where
-    zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv
-                              ; return (mkTyVarTy z_tv) }
-
--- Variant that assumes that any result of zonking is still a TyVar.
--- Should be used only on skolems and TyVarTvs
-zonkTcTyVarsToTcTyVars :: HasDebugCallStack => [TcTyVar] -> TcM [TcTyVar]
-zonkTcTyVarsToTcTyVars = mapM zonkTcTyVarToTcTyVar
-
-zonkTcTyVarToTcTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar
-zonkTcTyVarToTcTyVar tv
-  = do { ty <- zonkTcTyVar tv
-       ; let tv' = case getTyVar_maybe ty of
-                     Just tv' -> tv'
-                     Nothing  -> pprPanic "zonkTcTyVarToTcTyVar"
-                                          (ppr tv $$ ppr ty)
-       ; return tv' }
-
-zonkInvisTVBinder :: VarBndr TcTyVar spec -> TcM (VarBndr TcTyVar spec)
-zonkInvisTVBinder (Bndr tv spec) = do { tv' <- zonkTcTyVarToTcTyVar tv
-                                      ; return (Bndr tv' spec) }
-
--- zonkId is used *during* typechecking just to zonk the Id's type
-zonkId :: TcId -> TcM TcId
-zonkId id = Id.updateIdTypeAndMultM zonkTcType id
-
-zonkCoVar :: CoVar -> TcM CoVar
-zonkCoVar = zonkId
-
-{- Note [Sharing in zonking]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have
-   alpha :-> beta :-> gamma :-> ty
-where the ":->" means that the unification variable has been
-filled in with Indirect. Then when zonking alpha, it'd be nice
-to short-circuit beta too, so we end up with
-   alpha :-> zty
-   beta  :-> zty
-   gamma :-> zty
-where zty is the zonked version of ty.  That way, if we come across
-beta later, we'll have less work to do.  (And indeed the same for
-alpha.)
-
-This is easily achieved: just overwrite (Indirect ty) with (Indirect
-zty).  Non-systematic perf comparisons suggest that this is a modest
-win.
-
-But c.f Note [Sharing when zonking to Type] in GHC.Tc.Utils.Zonk.
-
-%************************************************************************
-%*                                                                      *
-                 Tidying
-*                                                                      *
-************************************************************************
--}
-
-zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
-zonkTidyTcType env ty = do { ty' <- zonkTcType ty
-                           ; return (tidyOpenType env ty') }
-
-zonkTidyTcTypes :: TidyEnv -> [TcType] -> TcM (TidyEnv, [TcType])
-zonkTidyTcTypes = zonkTidyTcTypes' []
-  where zonkTidyTcTypes' zs env [] = return (env, reverse zs)
-        zonkTidyTcTypes' zs env (ty:tys)
-          = do { (env', ty') <- zonkTidyTcType env ty
-               ; zonkTidyTcTypes' (ty':zs) env' tys }
-
-zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin)
-zonkTidyOrigin env (GivenOrigin skol_info)
-  = do { skol_info1 <- zonkSkolemInfoAnon skol_info
-       ; let skol_info2 = tidySkolemInfoAnon env skol_info1
-       ; return (env, GivenOrigin skol_info2) }
-zonkTidyOrigin env (OtherSCOrigin sc_depth skol_info)
-  = do { skol_info1 <- zonkSkolemInfoAnon skol_info
-       ; let skol_info2 = tidySkolemInfoAnon env skol_info1
-       ; return (env, OtherSCOrigin sc_depth skol_info2) }
-zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual   = act
-                                      , uo_expected = exp })
-  = do { (env1, act') <- zonkTidyTcType env  act
-       ; (env2, exp') <- zonkTidyTcType env1 exp
-       ; return ( env2, orig { uo_actual   = act'
-                             , uo_expected = exp' }) }
-zonkTidyOrigin env (KindEqOrigin ty1 ty2 orig t_or_k)
-  = do { (env1, ty1')  <- zonkTidyTcType env  ty1
-       ; (env2, ty2')  <- zonkTidyTcType env1 ty2
-       ; (env3, orig') <- zonkTidyOrigin env2 orig
-       ; return (env3, KindEqOrigin ty1' ty2' orig' t_or_k) }
-zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2)
-  = do { (env1, p1') <- zonkTidyTcType env  p1
-       ; (env2, o1') <- zonkTidyOrigin env1 o1
-       ; (env3, p2') <- zonkTidyTcType env2 p2
-       ; (env4, o2') <- zonkTidyOrigin env3 o2
-       ; return (env4, FunDepOrigin1 p1' o1' l1 p2' o2' l2) }
-zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2)
-  = do { (env1, p1') <- zonkTidyTcType env  p1
-       ; (env2, p2') <- zonkTidyTcType env1 p2
-       ; (env3, o1') <- zonkTidyOrigin env2 o1
-       ; return (env3, FunDepOrigin2 p1' o1' p2' l2) }
-zonkTidyOrigin env (InjTFOrigin1 pred1 orig1 loc1 pred2 orig2 loc2)
-  = do { (env1, pred1') <- zonkTidyTcType env  pred1
-       ; (env2, orig1') <- zonkTidyOrigin env1 orig1
-       ; (env3, pred2') <- zonkTidyTcType env2 pred2
-       ; (env4, orig2') <- zonkTidyOrigin env3 orig2
-       ; return (env4, InjTFOrigin1 pred1' orig1' loc1 pred2' orig2' loc2) }
-zonkTidyOrigin env (CycleBreakerOrigin orig)
-  = do { (env1, orig') <- zonkTidyOrigin env orig
-       ; return (env1, CycleBreakerOrigin orig') }
-zonkTidyOrigin env (InstProvidedOrigin mod cls_inst)
-  = do { (env1, is_tys') <- mapAccumLM zonkTidyTcType env (is_tys cls_inst)
-       ; return (env1, InstProvidedOrigin mod (cls_inst {is_tys = is_tys'})) }
-zonkTidyOrigin env (WantedSuperclassOrigin pty orig)
-  = do { (env1, pty')  <- zonkTidyTcType env pty
-       ; (env2, orig') <- zonkTidyOrigin env1 orig
-       ; return (env2, WantedSuperclassOrigin pty' orig') }
-zonkTidyOrigin env orig = return (env, orig)
-
-zonkTidyOrigins :: TidyEnv -> [CtOrigin] -> TcM (TidyEnv, [CtOrigin])
-zonkTidyOrigins = mapAccumLM zonkTidyOrigin
-
-zonkTidyFRRInfos :: TidyEnv
-                 -> [FixedRuntimeRepErrorInfo]
-                 -> TcM (TidyEnv, [FixedRuntimeRepErrorInfo])
-zonkTidyFRRInfos = go []
-  where
-    go zs env [] = return (env, reverse zs)
-    go zs env (FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig
-                        , frr_info_not_concrete = mb_not_conc } : tys)
-      = do { (env, ty) <- zonkTidyTcType env ty
-           ; (env, mb_not_conc) <- go_mb_not_conc env mb_not_conc
-           ; let info = FRR_Info { frr_info_origin = FixedRuntimeRepOrigin ty orig
-                                 , frr_info_not_concrete = mb_not_conc }
-           ; go (info:zs) env tys }
-
-    go_mb_not_conc env Nothing = return (env, Nothing)
-    go_mb_not_conc env (Just (tv, ty))
-      = do { (env, tv) <- return $ tidyOpenTyCoVar env tv
-           ; (env, ty) <- zonkTidyTcType env ty
-           ; return (env, Just (tv, ty)) }
-
-----------------
-tidyCt :: TidyEnv -> Ct -> Ct
--- Used only in error reporting
-tidyCt env ct = ct { cc_ev = tidyCtEvidence env (ctEvidence ct) }
-
-tidyCtEvidence :: TidyEnv -> CtEvidence -> CtEvidence
-     -- NB: we do not tidy the ctev_evar field because we don't
-     --     show it in error messages
-tidyCtEvidence env ctev = ctev { ctev_pred = tidyType env ty }
-  where
-    ty  = ctev_pred ctev
-
-tidyHole :: TidyEnv -> Hole -> Hole
-tidyHole env h@(Hole { hole_ty = ty }) = h { hole_ty = tidyType env ty }
-
-tidyDelayedError :: TidyEnv -> DelayedError -> DelayedError
-tidyDelayedError env (DE_Hole hole)
-  = DE_Hole $ tidyHole env hole
-tidyDelayedError env (DE_NotConcrete err)
-  = DE_NotConcrete $ tidyConcreteError env err
-
-tidyConcreteError :: TidyEnv -> NotConcreteError -> NotConcreteError
-tidyConcreteError env err@(NCE_FRR { nce_frr_origin = frr_orig })
-  = err { nce_frr_origin = tidyFRROrigin env frr_orig }
-
-tidyFRROrigin :: TidyEnv -> FixedRuntimeRepOrigin -> FixedRuntimeRepOrigin
-tidyFRROrigin env (FixedRuntimeRepOrigin ty orig)
-  = FixedRuntimeRepOrigin (tidyType env ty) orig
-
-----------------
-tidyEvVar :: TidyEnv -> EvVar -> EvVar
-tidyEvVar env var = updateIdTypeAndMult (tidyType env) var
-
-
--------------------------------------------------------------------------
-{-
-%************************************************************************
-%*                                                                      *
-             Representation polymorphism checks
-*                                                                       *
-***********************************************************************-}
-
--- | Check that the specified type has a fixed runtime representation.
---
--- If it isn't, throw a representation-polymorphism error appropriate
--- for the context (as specified by the 'FixedRuntimeRepProvenance').
---
--- Unlike the other representation polymorphism checks, which can emit
--- new Wanted constraints to be solved by the constraint solver, this function
--- does not emit any constraints: it has enough information to immediately
--- make a decision.
---
--- See (1) in Note [Representation polymorphism checking] in GHC.Tc.Utils.Concrete
-checkTypeHasFixedRuntimeRep :: FixedRuntimeRepProvenance -> Type -> TcM ()
-checkTypeHasFixedRuntimeRep prov ty =
-  unless (typeHasFixedRuntimeRep ty)
-    (addDetailedDiagnostic $ TcRnTypeDoesNotHaveFixedRuntimeRep ty prov)
-
-{-
-%************************************************************************
-%*                                                                      *
-             Error messages
-*                                                                       *
-*************************************************************************
-
--}
-
--- See Note [Naughty quantification candidates]
-naughtyQuantification :: TcType   -- original type user wanted to quantify
-                      -> TcTyVar  -- naughty var
-                      -> TyVarSet -- skolems that would escape
-                      -> TcM a
-naughtyQuantification orig_ty tv escapees
-  = do { orig_ty1 <- zonkTcType orig_ty  -- in case it's not zonked
-
-       ; escapees' <- zonkTcTyVarsToTcTyVars $
-                      nonDetEltsUniqSet escapees
-                     -- we'll just be printing, so no harmful non-determinism
-
-       ; let fvs  = tyCoVarsOfTypeWellScoped orig_ty1
-             env0 = tidyFreeTyCoVars emptyTidyEnv fvs
-             env  = env0 `delTidyEnvList` escapees'
-                    -- this avoids gratuitous renaming of the escaped
-                    -- variables; very confusing to users!
-
-             orig_ty'   = tidyType env orig_ty1
-             ppr_tidied = pprTyVars . map (tidyTyCoVarOcc env)
-             msg = mkTcRnUnknownMessage $ mkPlainError noHints $
-                   pprWithExplicitKindsWhen True $
-                   vcat [ sep [ text "Cannot generalise type; skolem" <> plural escapees'
-                              , quotes $ ppr_tidied escapees'
-                              , text "would escape" <+> itsOrTheir escapees' <+> text "scope"
-                              ]
-                        , sep [ text "if I tried to quantify"
-                              , ppr_tidied [tv]
-                              , text "in this type:"
-                              ]
-                        , nest 2 (pprTidiedType orig_ty')
-                        , text "(Indeed, I sometimes struggle even printing this correctly,"
-                        , text " due to its ill-scoped nature.)"
-                        ]
-
-       ; failWithTcM (env, msg) }
-
-{-
-************************************************************************
-*                                                                      *
-             Checking for coercion holes
-*                                                                      *
-************************************************************************
--}
-
--- | Check whether any coercion hole in a RewriterSet is still unsolved.
--- Does this by recursively looking through filled coercion holes until
--- one is found that is not yet filled in, at which point this aborts.
-anyUnfilledCoercionHoles :: RewriterSet -> TcM Bool
-anyUnfilledCoercionHoles (RewriterSet set)
-  = nonDetStrictFoldUniqSet go (return False) set
-     -- this does not introduce non-determinism, because the only
-     -- monadic action is to read, and the combining function is
-     -- commutative
-  where
-    go :: CoercionHole -> TcM Bool -> TcM Bool
-    go hole m_acc = m_acc <||> check_hole hole
-
-    check_hole :: CoercionHole -> TcM Bool
-    check_hole hole = do { m_co <- unpackCoercionHole_maybe hole
-                         ; case m_co of
-                             Nothing -> return True  -- unfilled hole
-                             Just co -> unUCHM (check_co co) }
-
-    check_ty :: Type -> UnfilledCoercionHoleMonoid
-    check_co :: Coercion -> UnfilledCoercionHoleMonoid
-    (check_ty, _, check_co, _) = foldTyCo folder ()
-
-    folder :: TyCoFolder () UnfilledCoercionHoleMonoid
-    folder = TyCoFolder { tcf_view  = noView
-                        , tcf_tyvar = \ _ tv -> check_ty (tyVarKind tv)
-                        , tcf_covar = \ _ cv -> check_ty (varType cv)
-                        , tcf_hole  = \ _ -> UCHM . check_hole
-                        , tcf_tycobinder = \ _ _ _ -> () }
-
-newtype UnfilledCoercionHoleMonoid = UCHM { unUCHM :: TcM Bool }
-
-instance Semigroup UnfilledCoercionHoleMonoid where
-  UCHM l <> UCHM r = UCHM (l <||> r)
-
-instance Monoid UnfilledCoercionHoleMonoid where
-  mempty = UCHM (return False)
diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Utils/Unify.hs
+++ /dev/null
@@ -1,2721 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections       #-}
-{-# LANGUAGE RecursiveDo         #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
--}
-
--- | Type subsumption and unification
-module GHC.Tc.Utils.Unify (
-  -- Full-blown subsumption
-  tcWrapResult, tcWrapResultO, tcWrapResultMono,
-  tcTopSkolemise, tcSkolemiseScoped, tcSkolemiseExpType,
-  tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeDS,
-  tcSubTypeAmbiguity, tcSubMult,
-  checkConstraints, checkTvConstraints,
-  buildImplicationFor, buildTvImplication, emitResidualTvConstraint,
-
-  -- Various unifications
-  unifyType, unifyKind, unifyExpectedType,
-  uType, promoteTcType,
-  swapOverTyVars, startSolvingByUnification,
-
-  --------------------------------
-  -- Holes
-  tcInfer,
-  matchExpectedListTy,
-  matchExpectedTyConApp,
-  matchExpectedAppTy,
-  matchExpectedFunTys,
-  matchExpectedFunKind,
-  matchActualFunTySigma, matchActualFunTysRho,
-
-  checkTyVarEq, checkTyFamEq, checkTypeEq
-
-  ) where
-
-import GHC.Prelude
-
-import GHC.Hs
-
-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep, makeTypeConcrete, hasFixedRuntimeRep_syntactic )
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.Instantiate
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.TcType
-
-import GHC.Core.Type
-import GHC.Core.TyCo.Rep
-import GHC.Core.TyCo.Ppr( debugPprType )
-import GHC.Core.TyCon
-import GHC.Core.Coercion
-import GHC.Core.Multiplicity
-
-import qualified GHC.LanguageExtensions as LangExt
-
-import GHC.Tc.Types.Evidence
-import GHC.Tc.Types.Constraint
-import GHC.Tc.Types.Origin
-import GHC.Types.Name( Name, isSystemName )
-
-import GHC.Builtin.Types
-import GHC.Types.Var as Var
-import GHC.Types.Var.Set
-import GHC.Types.Var.Env
-import GHC.Utils.Error
-import GHC.Driver.Session
-import GHC.Types.Basic
-import GHC.Data.Bag
-import GHC.Data.FastString( fsLit )
-import GHC.Utils.Misc
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-import GHC.Exts      ( inline )
-import Control.Monad
-import qualified Data.Semigroup as S ( (<>) )
-
-{- *********************************************************************
-*                                                                      *
-              matchActualFunTys
-*                                                                      *
-********************************************************************* -}
-
--- | 'matchActualFunTySigma' looks for just one function arrow,
--- returning an uninstantiated sigma-type.
---
--- Invariant: the returned argument type has a syntactically fixed
--- RuntimeRep in the sense of Note [Fixed RuntimeRep]
--- in GHC.Tc.Utils.Concrete.
---
--- See Note [Return arguments with a fixed RuntimeRep].
-matchActualFunTySigma
-  :: ExpectedFunTyOrigin
-      -- ^ See Note [Herald for matchExpectedFunTys]
-  -> Maybe TypedThing
-      -- ^ The thing with type TcSigmaType
-  -> (Arity, [Scaled TcSigmaType])
-      -- ^ Total number of value args in the call, and
-      -- types of values args to which function has
-      --   been applied already (reversed)
-      -- (Both are used only for error messages)
-  -> TcRhoType
-      -- ^ Type to analyse: a TcRhoType
-  -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType)
--- This function takes in a type to analyse (a RhoType) and returns
--- an argument type and a result type (splitting apart a function arrow).
--- The returned argument type is a SigmaType with a fixed RuntimeRep;
--- as explained in Note [Return arguments with a fixed RuntimeRep].
---
--- See Note [matchActualFunTy error handling] for the first three arguments
-
--- If   (wrap, arg_ty, res_ty) = matchActualFunTySigma ... fun_ty
--- then wrap :: fun_ty ~> (arg_ty -> res_ty)
--- and NB: res_ty is an (uninstantiated) SigmaType
-
-matchActualFunTySigma herald mb_thing err_info fun_ty
-  = assertPpr (isRhoTy fun_ty) (ppr fun_ty) $
-    go fun_ty
-  where
-    -- Does not allocate unnecessary meta variables: if the input already is
-    -- a function, we just take it apart.  Not only is this efficient,
-    -- it's important for higher rank: the argument might be of form
-    --              (forall a. ty) -> other
-    -- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd
-    -- hide the forall inside a meta-variable
-    go :: TcRhoType   -- The type we're processing, perhaps after
-                      -- expanding type synonyms
-       -> TcM (HsWrapper, Scaled TcSigmaTypeFRR, TcSigmaType)
-    go ty | Just ty' <- coreView ty = go ty'
-
-    go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty })
-      = assert (isVisibleFunArg af) $
-      do { hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty
-         ; return (idHsWrapper, Scaled w arg_ty, res_ty) }
-
-    go ty@(TyVarTy tv)
-      | isMetaTyVar tv
-      = do { cts <- readMetaTyVar tv
-           ; case cts of
-               Indirect ty' -> go ty'
-               Flexi        -> defer ty }
-
-       -- In all other cases we bale out into ordinary unification
-       -- However unlike the meta-tyvar case, we are sure that the
-       -- number of arguments doesn't match arity of the original
-       -- type, so we can add a bit more context to the error message
-       -- (cf #7869).
-       --
-       -- It is not always an error, because specialized type may have
-       -- different arity, for example:
-       --
-       -- > f1 = f2 'a'
-       -- > f2 :: Monad m => m Bool
-       -- > f2 = undefined
-       --
-       -- But in that case we add specialized type into error context
-       -- anyway, because it may be useful. See also #9605.
-    go ty = addErrCtxtM (mk_ctxt ty) (defer ty)
-
-    ------------
-    defer fun_ty
-      = do { arg_ty <- newOpenFlexiTyVarTy
-           ; res_ty <- newOpenFlexiTyVarTy
-           ; mult <- newFlexiTyVarTy multiplicityTy
-           ; let unif_fun_ty = tcMkVisFunTy mult arg_ty res_ty
-           ; co <- unifyType mb_thing fun_ty unif_fun_ty
-           ; hasFixedRuntimeRep_syntactic (FRRExpectedFunTy herald 1) arg_ty
-           ; return (mkWpCastN co, Scaled mult arg_ty, res_ty) }
-
-    ------------
-    mk_ctxt :: TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
-    mk_ctxt res_ty env = mkFunTysMsg env herald (reverse arg_tys_so_far)
-                                     res_ty n_val_args_in_call
-    (n_val_args_in_call, arg_tys_so_far) = err_info
-
-{- Note [matchActualFunTy error handling]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-matchActualFunTySigma is made much more complicated by the
-desire to produce good error messages. Consider the application
-    f @Int x y
-In GHC.Tc.Gen.Expr.tcArgs we deal with visible type arguments,
-and then call matchActualFunTysPart for each individual value
-argument. It, in turn, must instantiate any type/dictionary args,
-before looking for an arrow type.
-
-But if it doesn't find an arrow type, it wants to generate a message
-like "f is applied to two arguments but its type only has one".
-To do that, it needs to know about the args that tcArgs has already
-munched up -- hence passing in n_val_args_in_call and arg_tys_so_far;
-and hence also the accumulating so_far arg to 'go'.
-
-This allows us (in mk_ctxt) to construct f's /instantiated/ type,
-with just the values-arg arrows, which is what we really want
-in the error message.
-
-Ugh!
--}
-
--- | Like 'matchExpectedFunTys', but used when you have an "actual" type,
--- for example in function application.
---
--- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep
--- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
--- See Note [Return arguments with a fixed RuntimeRep].
-matchActualFunTysRho :: ExpectedFunTyOrigin -- ^ See Note [Herald for matchExpectedFunTys]
-                     -> CtOrigin
-                     -> Maybe TypedThing -- ^ the thing with type TcSigmaType
-                     -> Arity
-                     -> TcSigmaType
-                     -> TcM (HsWrapper, [Scaled TcSigmaTypeFRR], TcRhoType)
--- If    matchActualFunTysRho n ty = (wrap, [t1,..,tn], res_ty)
--- then  wrap : ty ~> (t1 -> ... -> tn -> res_ty)
---       and res_ty is a RhoType
--- NB: the returned type is top-instantiated; it's a RhoType
-matchActualFunTysRho herald ct_orig mb_thing n_val_args_wanted fun_ty
-  = go n_val_args_wanted [] fun_ty
-  where
-    go n so_far fun_ty
-      | not (isRhoTy fun_ty)
-      = do { (wrap1, rho) <- topInstantiate ct_orig fun_ty
-           ; (wrap2, arg_tys, res_ty) <- go n so_far rho
-           ; return (wrap2 <.> wrap1, arg_tys, res_ty) }
-
-    go 0 _ fun_ty = return (idHsWrapper, [], fun_ty)
-
-    go n so_far fun_ty
-      = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTySigma
-                                                 herald mb_thing
-                                                 (n_val_args_wanted, so_far)
-                                                 fun_ty
-           ; (wrap_res, arg_tys, res_ty)   <- go (n-1) (arg_ty1:so_far) res_ty1
-           ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty
-           -- NB: arg_ty1 comes from matchActualFunTySigma, so it has
-           -- a syntactically fixed RuntimeRep as needed to call mkWpFun.
-           ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) }
-
-{-
-************************************************************************
-*                                                                      *
-             matchExpected functions
-*                                                                      *
-************************************************************************
-
-Note [Herald for matchExpectedFunTys]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The 'herald' always looks like:
-   "The equation(s) for 'f' have"
-   "The abstraction (\x.e) takes"
-   "The section (+ x) expects"
-   "The function 'f' is applied to"
-
-This is used to construct a message of form
-
-   The abstraction `\Just 1 -> ...' takes two arguments
-   but its type `Maybe a -> a' has only one
-
-   The equation(s) for `f' have two arguments
-   but its type `Maybe a -> a' has only one
-
-   The section `(f 3)' requires 'f' to take two arguments
-   but its type `Int -> Int' has only one
-
-   The function 'f' is applied to two arguments
-   but its type `Int -> Int' has only one
-
-When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the
-picture, we have a choice in deciding whether to count the type applications as
-proper arguments:
-
-   The function 'f' is applied to one visible type argument
-     and two value arguments
-   but its type `forall a. a -> a` has only one visible type argument
-     and one value argument
-
-Or whether to include the type applications as part of the herald itself:
-
-   The expression 'f @Int' is applied to two arguments
-   but its type `Int -> Int` has only one
-
-The latter is easier to implement and is arguably easier to understand, so we
-choose to implement that option.
-
-Note [matchExpectedFunTys]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-matchExpectedFunTys checks that a sigma has the form
-of an n-ary function.  It passes the decomposed type to the
-thing_inside, and returns a wrapper to coerce between the two types
-
-It's used wherever a language construct must have a functional type,
-namely:
-        A lambda expression
-        A function definition
-     An operator section
-
-This function must be written CPS'd because it needs to fill in the
-ExpTypes produced for arguments before it can fill in the ExpType
-passed in.
-
-Note [Return arguments with a fixed RuntimeRep]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The functions
-
-  - matchExpectedFunTys,
-  - matchActualFunTySigma,
-  - matchActualFunTysRho,
-
-peel off argument types, as explained in Note [matchExpectedFunTys].
-It's important that these functions return argument types that have
-a fixed runtime representation, otherwise we would be in violation
-of the representation-polymorphism invariants of
-Note [Representation polymorphism invariants] in GHC.Core.
-
-This is why all these functions have an additional invariant,
-that the argument types they return all have a syntactically fixed RuntimeRep,
-in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
-
-Example:
-
-  Suppose we have
-
-    type F :: Type -> RuntimeRep
-    type family F a where { F Int = LiftedRep }
-
-    type Dual :: Type -> Type
-    type family Dual a where
-      Dual a = a -> ()
-
-    f :: forall (a :: TYPE (F Int)). Dual a
-    f = \ x -> ()
-
-  The body of `f` is a lambda abstraction, so we must be able to split off
-  one argument type from its type. This is handled by `matchExpectedFunTys`
-  (see 'GHC.Tc.Gen.Match.tcMatchLambda'). We end up with desugared Core that
-  looks like this:
-
-    f :: forall (a :: TYPE (F Int)). Dual (a |> (TYPE F[0]))
-    f = \ @(a :: TYPE (F Int)) ->
-          (\ (x :: (a |> (TYPE F[0]))) -> ())
-          `cast`
-          (Sub (Sym (Dual[0] <(a |> (TYPE F[0]))>)))
-
-  Two important transformations took place:
-
-    1. We inserted casts around the argument type to ensure that it has
-       a fixed runtime representation, as required by invariant (I1) from
-       Note [Representation polymorphism invariants] in GHC.Core.
-    2. We inserted a cast around the whole lambda to make everything line up
-       with the type signature.
--}
-
--- | Use this function to split off arguments types when you have an
--- \"expected\" type.
---
--- This function skolemises at each polytype.
---
--- Invariant: this function only applies the provided function
--- to a list of argument types which all have a syntactically fixed RuntimeRep
--- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
--- See Note [Return arguments with a fixed RuntimeRep].
-matchExpectedFunTys :: forall a.
-                       ExpectedFunTyOrigin -- See Note [Herald for matchExpectedFunTys]
-                    -> UserTypeCtxt
-                    -> Arity
-                    -> ExpRhoType      -- Skolemised
-                    -> ([Scaled ExpSigmaTypeFRR] -> ExpRhoType -> TcM a)
-                    -> TcM (HsWrapper, a)
--- If    matchExpectedFunTys n ty = (wrap, _)
--- then  wrap : (t1 -> ... -> tn -> ty_r) ~> ty,
---   where [t1, ..., tn], ty_r are passed to the thing_inside
-matchExpectedFunTys herald ctx arity orig_ty thing_inside
-  = case orig_ty of
-      Check ty -> go [] arity ty
-      _        -> defer [] arity orig_ty
-  where
-    -- Skolemise any foralls /before/ the zero-arg case
-    -- so that we guarantee to return a rho-type
-    go acc_arg_tys n ty
-      | (tvs, theta, _) <- tcSplitSigmaTy ty
-      , not (null tvs && null theta)
-      = do { (wrap_gen, (wrap_res, result)) <- tcTopSkolemise ctx ty $ \ty' ->
-                                               go acc_arg_tys n ty'
-           ; return (wrap_gen <.> wrap_res, result) }
-
-    -- No more args; do this /before/ coreView, so
-    -- that we do not unnecessarily unwrap synonyms
-    go acc_arg_tys 0 rho_ty
-      = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType rho_ty)
-           ; return (idHsWrapper, result) }
-
-    go acc_arg_tys n ty
-      | Just ty' <- coreView ty = go acc_arg_tys n ty'
-
-    go acc_arg_tys n (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg_ty, ft_res = res_ty })
-      = assert (isVisibleFunArg af) $
-        do { let arg_pos = 1 + length acc_arg_tys -- for error messages only
-           ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty
-           ; (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys)
-                                      (n-1) res_ty
-           ; let wrap_arg = mkWpCastN arg_co
-                 fun_wrap = mkWpFun wrap_arg wrap_res (Scaled mult arg_ty) res_ty
-           ; return (fun_wrap, result) }
-
-    go acc_arg_tys n ty@(TyVarTy tv)
-      | isMetaTyVar tv
-      = do { cts <- readMetaTyVar tv
-           ; case cts of
-               Indirect ty' -> go acc_arg_tys n ty'
-               Flexi        -> defer acc_arg_tys n (mkCheckExpType ty) }
-
-       -- In all other cases we bale out into ordinary unification
-       -- However unlike the meta-tyvar case, we are sure that the
-       -- number of arguments doesn't match arity of the original
-       -- type, so we can add a bit more context to the error message
-       -- (cf #7869).
-       --
-       -- It is not always an error, because specialized type may have
-       -- different arity, for example:
-       --
-       -- > f1 = f2 'a'
-       -- > f2 :: Monad m => m Bool
-       -- > f2 = undefined
-       --
-       -- But in that case we add specialized type into error context
-       -- anyway, because it may be useful. See also #9605.
-    go acc_arg_tys n ty = addErrCtxtM (mk_ctxt acc_arg_tys ty) $
-                          defer acc_arg_tys n (mkCheckExpType ty)
-
-    ------------
-    defer :: [Scaled ExpSigmaTypeFRR] -> Arity -> ExpRhoType -> TcM (HsWrapper, a)
-    defer acc_arg_tys n fun_ty
-      = do { let last_acc_arg_pos = length acc_arg_tys
-           ; more_arg_tys <- mapM new_exp_arg_ty [last_acc_arg_pos + 1 .. last_acc_arg_pos + n]
-           ; res_ty       <- newInferExpType
-           ; result       <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty
-           ; more_arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) more_arg_tys
-           ; res_ty       <- readExpType res_ty
-           ; let unif_fun_ty = mkScaledFunTys more_arg_tys res_ty
-           ; wrap <- tcSubType AppOrigin ctx unif_fun_ty fun_ty
-                         -- Not a good origin at all :-(
-           ; return (wrap, result) }
-
-    new_exp_arg_ty :: Int -> TcM (Scaled ExpSigmaTypeFRR)
-    new_exp_arg_ty arg_pos -- position for error messages only
-      = mkScaled <$> newFlexiTyVarTy multiplicityTy
-                 <*> newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos)
-
-    ------------
-    mk_ctxt :: [Scaled ExpSigmaTypeFRR] -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
-    mk_ctxt arg_tys res_ty env
-      = mkFunTysMsg env herald arg_tys' res_ty arity
-      where
-        arg_tys' = map (\(Scaled u v) -> Scaled u (checkingExpType "matchExpectedFunTys" v)) $
-                   reverse arg_tys
-            -- this is safe b/c we're called from "go"
-
-mkFunTysMsg :: TidyEnv
-            -> ExpectedFunTyOrigin
-            -> [Scaled TcType] -> TcType -> Arity
-            -> TcM (TidyEnv, SDoc)
-mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call
-  = do { (env', fun_rho) <- zonkTidyTcType env $
-                            mkScaledFunTys arg_tys res_ty
-
-       ; let (all_arg_tys, _) = splitFunTys fun_rho
-             n_fun_args = length all_arg_tys
-
-             msg | n_val_args_in_call <= n_fun_args  -- Enough args, in the end
-                 = text "In the result of a function call"
-                 | otherwise
-                 = hang (full_herald <> comma)
-                      2 (sep [ text "but its type" <+> quotes (pprType fun_rho)
-                             , if n_fun_args == 0 then text "has none"
-                               else text "has only" <+> speakN n_fun_args])
-
-       ; return (env', msg) }
- where
-  full_herald = pprExpectedFunTyHerald herald
-            <+> speakNOf n_val_args_in_call (text "value argument")
-
-----------------------
-matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType)
--- Special case for lists
-matchExpectedListTy exp_ty
- = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty
-      ; return (co, elt_ty) }
-
----------------------
-matchExpectedTyConApp :: TyCon                -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> *
-                      -> TcRhoType            -- orig_ty
-                      -> TcM (TcCoercionN,    -- T k1 k2 k3 a b c ~N orig_ty
-                              [TcSigmaType])  -- Element types, k1 k2 k3 a b c
-
--- It's used for wired-in tycons, so we call checkWiredInTyCon
--- Precondition: never called with FunTyCon
--- Precondition: input type :: *
--- Postcondition: (T k1 k2 k3 a b c) is well-kinded
-
-matchExpectedTyConApp tc orig_ty
-  = assertPpr (isAlgTyCon tc) (ppr tc) $
-    go orig_ty
-  where
-    go ty
-       | Just ty' <- coreView ty
-       = go ty'
-
-    go ty@(TyConApp tycon args)
-       | tc == tycon  -- Common case
-       = return (mkNomReflCo ty, args)
-
-    go (TyVarTy tv)
-       | isMetaTyVar tv
-       = do { cts <- readMetaTyVar tv
-            ; case cts of
-                Indirect ty -> go ty
-                Flexi       -> defer }
-
-    go _ = defer
-
-    -- If the common case does not occur, instantiate a template
-    -- T k1 .. kn t1 .. tm, and unify with the original type
-    -- Doing it this way ensures that the types we return are
-    -- kind-compatible with T.  For example, suppose we have
-    --       matchExpectedTyConApp T (f Maybe)
-    -- where data T a = MkT a
-    -- Then we don't want to instantiate T's data constructors with
-    --    (a::*) ~ Maybe
-    -- because that'll make types that are utterly ill-kinded.
-    -- This happened in #7368
-    defer
-      = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc)
-           ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs)
-           ; let args = mkTyVarTys arg_tvs
-                 tc_template = mkTyConApp tc args
-           ; co <- unifyType Nothing tc_template orig_ty
-           ; return (co, args) }
-
-----------------------
-matchExpectedAppTy :: TcRhoType                         -- orig_ty
-                   -> TcM (TcCoercion,                   -- m a ~N orig_ty
-                           (TcSigmaType, TcSigmaType))  -- Returns m, a
--- If the incoming type is a mutable type variable of kind k, then
--- matchExpectedAppTy returns a new type variable (m: * -> k); note the *.
-
-matchExpectedAppTy orig_ty
-  = go orig_ty
-  where
-    go ty
-      | Just ty' <- coreView ty = go ty'
-
-      | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
-      = return (mkNomReflCo orig_ty, (fun_ty, arg_ty))
-
-    go (TyVarTy tv)
-      | isMetaTyVar tv
-      = do { cts <- readMetaTyVar tv
-           ; case cts of
-               Indirect ty -> go ty
-               Flexi       -> defer }
-
-    go _ = defer
-
-    -- Defer splitting by generating an equality constraint
-    defer
-      = do { ty1 <- newFlexiTyVarTy kind1
-           ; ty2 <- newFlexiTyVarTy kind2
-           ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty
-           ; return (co, (ty1, ty2)) }
-
-    orig_kind = typeKind orig_ty
-    kind1 = mkVisFunTyMany liftedTypeKind orig_kind
-    kind2 = liftedTypeKind    -- m :: * -> k
-                              -- arg type :: *
-
-{- **********************************************************************
-*
-                      fillInferResult
-*
-********************************************************************** -}
-
-{- Note [inferResultToType]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-expTypeToType and inferResultType convert an InferResult to a monotype.
-It must be a monotype because if the InferResult isn't already filled in,
-we fill it in with a unification variable (hence monotype).  So to preserve
-order-independence we check for mono-type-ness even if it *is* filled in
-already.
-
-See also Note [TcLevel of ExpType] in GHC.Tc.Utils.TcType, and
-Note [fillInferResult].
--}
-
--- | Fill an 'InferResult' with the given type.
---
--- If @co = fillInferResult t1 infer_res@, then @co :: t1 ~# t2@,
--- where @t2@ is the type stored in the 'ir_ref' field of @infer_res@.
---
--- This function enforces the following invariants:
---
---  - Level invariant.
---    The stored type @t2@ is at the same level as given by the
---    'ir_lvl' field.
---  - FRR invariant.
---    Whenever the 'ir_frr' field is not @Nothing@, @t2@ is guaranteed
---    to have a syntactically fixed RuntimeRep, in the sense of
---    Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.
-fillInferResult :: TcType -> InferResult -> TcM TcCoercionN
-fillInferResult act_res_ty (IR { ir_uniq = u
-                               , ir_lvl  = res_lvl
-                               , ir_frr  = mb_frr
-                               , ir_ref  = ref })
-  = do { mb_exp_res_ty <- readTcRef ref
-       ; case mb_exp_res_ty of
-            Just exp_res_ty
-               -- We progressively refine the type stored in 'ref',
-               -- for example when inferring types across multiple equations.
-               --
-               -- Example:
-               --
-               --  \ x -> case y of { True -> x ; False -> 3 :: Int }
-               --
-               -- When inferring the return type of this function, we will create
-               -- an 'Infer' 'ExpType', which will first be filled by the type of 'x'
-               -- after typechecking the first equation, and then filled again with
-               -- the type 'Int', at which point we want to ensure that we unify
-               -- the type of 'x' with 'Int'. This is what is happening below when
-               -- we are "joining" several inferred 'ExpType's.
-               -> do { traceTc "Joining inferred ExpType" $
-                       ppr u <> colon <+> ppr act_res_ty <+> char '~' <+> ppr exp_res_ty
-                     ; cur_lvl <- getTcLevel
-                     ; unless (cur_lvl `sameDepthAs` res_lvl) $
-                       ensureMonoType act_res_ty
-                     ; unifyType Nothing act_res_ty exp_res_ty }
-            Nothing
-               -> do { traceTc "Filling inferred ExpType" $
-                       ppr u <+> text ":=" <+> ppr act_res_ty
-
-                     -- Enforce the level invariant: ensure the TcLevel of
-                     -- the type we are writing to 'ref' matches 'ir_lvl'.
-                     ; (prom_co, act_res_ty) <- promoteTcType res_lvl act_res_ty
-
-                     -- Enforce the FRR invariant: ensure the type has a syntactically
-                     -- fixed RuntimeRep (if necessary, i.e. 'mb_frr' is not 'Nothing').
-                     ; (frr_co, act_res_ty) <-
-                         case mb_frr of
-                           Nothing       -> return (mkNomReflCo act_res_ty, act_res_ty)
-                           Just frr_orig -> hasFixedRuntimeRep frr_orig act_res_ty
-
-                     -- Compose the two coercions.
-                     ; let final_co = prom_co `mkTransCo` frr_co
-
-                     ; writeTcRef ref (Just act_res_ty)
-
-                     ; return final_co }
-     }
-
-{- Note [fillInferResult]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-When inferring, we use fillInferResult to "fill in" the hole in InferResult
-   data InferResult = IR { ir_uniq :: Unique
-                         , ir_lvl  :: TcLevel
-                         , ir_ref  :: IORef (Maybe TcType) }
-
-There are two things to worry about:
-
-1. What if it is under a GADT or existential pattern match?
-   - GADTs: a unification variable (and Infer's hole is similar) is untouchable
-   - Existentials: be careful about skolem-escape
-
-2. What if it is filled in more than once?  E.g. multiple branches of a case
-     case e of
-        T1 -> e1
-        T2 -> e2
-
-Our typing rules are:
-
-* The RHS of a existential or GADT alternative must always be a
-  monotype, regardless of the number of alternatives.
-
-* Multiple non-existential/GADT branches can have (the same)
-  higher rank type (#18412).  E.g. this is OK:
-      case e of
-        True  -> hr
-        False -> hr
-  where hr:: (forall a. a->a) -> Int
-  c.f. Section 7.1 of "Practical type inference for arbitrary-rank types"
-       We use choice (2) in that Section.
-       (GHC 8.10 and earlier used choice (1).)
-
-  But note that
-      case e of
-        True  -> hr
-        False -> \x -> hr x
-  will fail, because we still /infer/ both branches, so the \x will get
-  a (monotype) unification variable, which will fail to unify with
-  (forall a. a->a)
-
-For (1) we can detect the GADT/existential situation by seeing that
-the current TcLevel is greater than that stored in ir_lvl of the Infer
-ExpType.  We bump the level whenever we go past a GADT/existential match.
-
-Then, before filling the hole use promoteTcType to promote the type
-to the outer ir_lvl.  promoteTcType does this
-  - create a fresh unification variable alpha at level ir_lvl
-  - emits an equality alpha[ir_lvl] ~ ty
-  - fills the hole with alpha
-That forces the type to be a monotype (since unification variables can
-only unify with monotypes); and catches skolem-escapes because the
-alpha is untouchable until the equality floats out.
-
-For (2), we simply look to see if the hole is filled already.
-  - if not, we promote (as above) and fill the hole
-  - if it is filled, we simply unify with the type that is
-    already there
-
-There is one wrinkle.  Suppose we have
-   case e of
-      T1 -> e1 :: (forall a. a->a) -> Int
-      G2 -> e2
-where T1 is not GADT or existential, but G2 is a GADT.  Then suppose the
-T1 alternative fills the hole with (forall a. a->a) -> Int, which is fine.
-But now the G2 alternative must not *just* unify with that else we'd risk
-allowing through (e2 :: (forall a. a->a) -> Int).  If we'd checked G2 first
-we'd have filled the hole with a unification variable, which enforces a
-monotype.
-
-So if we check G2 second, we still want to emit a constraint that restricts
-the RHS to be a monotype. This is done by ensureMonoType, and it works
-by simply generating a constraint (alpha ~ ty), where alpha is a fresh
-unification variable.  We discard the evidence.
-
--}
-
-
-
-{-
-************************************************************************
-*                                                                      *
-                Subsumption checking
-*                                                                      *
-************************************************************************
-
-Note [Subsumption checking: tcSubType]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-All the tcSubType calls have the form
-                tcSubType actual_ty expected_ty
-which checks
-                actual_ty <= expected_ty
-
-That is, that a value of type actual_ty is acceptable in
-a place expecting a value of type expected_ty.  I.e. that
-
-    actual ty   is more polymorphic than   expected_ty
-
-It returns a wrapper function
-        co_fn :: actual_ty ~ expected_ty
-which takes an HsExpr of type actual_ty into one of type
-expected_ty.
-
-Note [Ambiguity check and deep subsumption]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   f :: (forall b. Eq b => a -> a) -> Int
-
-Does `f` have an ambiguous type?   The ambiguity check usually checks
-that this definition of f' would typecheck, where f' has the exact same
-type as f:
-   f' :: (forall b. Eq b => a -> a) -> Intp
-   f' = f
-
-This will be /rejected/ with DeepSubsumption but /accepted/ with
-ShallowSubsumption.  On the other hand, this eta-expanded version f''
-would be rejected both ways:
-   f'' :: (forall b. Eq b => a -> a) -> Intp
-   f'' x = f x
-
-This is squishy in the same way as other examples in GHC.Tc.Validity
-Note [The squishiness of the ambiguity check]
-
-The situation in June 2022.  Since we have SimpleSubsumption at the moment,
-we don't want introduce new breakage if you add -XDeepSubsumption, by
-rejecting types as ambiguous that weren't ambiguous before.  So, as a
-holding decision, we /always/ use SimpleSubsumption for the ambiguity check
-(erring on the side accepting more programs). Hence tcSubTypeAmbiguity.
--}
-
-
-
------------------
--- tcWrapResult needs both un-type-checked (for origins and error messages)
--- and type-checked (for wrapping) expressions
-tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType
-             -> TcM (HsExpr GhcTc)
-tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr
-
-tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType
-               -> TcM (HsExpr GhcTc)
-tcWrapResultO orig rn_expr expr actual_ty res_ty
-  = do { traceTc "tcWrapResult" (vcat [ text "Actual:  " <+> ppr actual_ty
-                                      , text "Expected:" <+> ppr res_ty ])
-       ; wrap <- tcSubTypeNC orig GenSigCtxt (Just $ HsExprRnThing rn_expr) actual_ty res_ty
-       ; return (mkHsWrap wrap expr) }
-
-tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc
-                 -> TcRhoType   -- Actual -- a rho-type not a sigma-type
-                 -> ExpRhoType  -- Expected
-                 -> TcM (HsExpr GhcTc)
--- A version of tcWrapResult to use when the actual type is a
--- rho-type, so nothing to instantiate; just go straight to unify.
--- It means we don't need to pass in a CtOrigin
-tcWrapResultMono rn_expr expr act_ty res_ty
-  = assertPpr (isRhoTy act_ty) (ppr act_ty $$ ppr rn_expr) $
-    do { co <- unifyExpectedType rn_expr act_ty res_ty
-       ; return (mkHsWrapCo co expr) }
-
-unifyExpectedType :: HsExpr GhcRn
-                  -> TcRhoType   -- Actual -- a rho-type not a sigma-type
-                  -> ExpRhoType  -- Expected
-                  -> TcM TcCoercionN
-unifyExpectedType rn_expr act_ty exp_ty
-  = case exp_ty of
-      Infer inf_res -> fillInferResult act_ty inf_res
-      Check exp_ty  -> unifyType (Just $ HsExprRnThing rn_expr) act_ty exp_ty
-
-------------------------
-tcSubTypePat :: CtOrigin -> UserTypeCtxt
-            -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
--- Used in patterns; polarity is backwards compared
---   to tcSubType
--- If wrap = tc_sub_type_et t1 t2
---    => wrap :: t1 ~> t2
-tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected
-  = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected
-
-tcSubTypePat _ _ (Infer inf_res) ty_expected
-  = do { co <- fillInferResult ty_expected inf_res
-               -- In patterns we do not instantatiate
-
-       ; return (mkWpCastN (mkSymCo co)) }
-
----------------
-tcSubType :: CtOrigin -> UserTypeCtxt
-          -> TcSigmaType  -- ^ Actual
-          -> ExpRhoType   -- ^ Expected
-          -> TcM HsWrapper
--- Checks that 'actual' is more polymorphic than 'expected'
-tcSubType orig ctxt ty_actual ty_expected
-  = addSubTypeCtxt ty_actual ty_expected $
-    do { traceTc "tcSubType" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])
-       ; tcSubTypeNC orig ctxt Nothing ty_actual ty_expected }
-
----------------
-tcSubTypeDS :: HsExpr GhcRn
-            -> TcRhoType   -- Actual -- a rho-type not a sigma-type
-            -> ExpRhoType  -- Expected
-            -> TcM HsWrapper
--- Similar signature to unifyExpectedType; does deep subsumption
--- Only one call site, in GHC.Tc.Gen.App.tcApp
-tcSubTypeDS rn_expr act_rho res_ty
-  = case res_ty of
-      Check exp_rho -> tc_sub_type_deep (unifyType m_thing) orig
-                                        GenSigCtxt act_rho exp_rho
-
-      Infer inf_res -> do { co <- fillInferResult act_rho inf_res
-                          ; return (mkWpCastN co) }
-  where
-    orig    = exprCtOrigin rn_expr
-    m_thing = Just (HsExprRnThing rn_expr)
-
----------------
-tcSubTypeNC :: CtOrigin          -- ^ Used when instantiating
-            -> UserTypeCtxt      -- ^ Used when skolemising
-            -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known)
-            -> TcSigmaType       -- ^ Actual type
-            -> ExpRhoType        -- ^ Expected type
-            -> TcM HsWrapper
-tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty
-  = case res_ty of
-      Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt
-                                       ty_actual ty_expected
-
-      Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual
-                                   -- See Note [Instantiation of InferResult]
-                          ; co <- fillInferResult rho inf_res
-                          ; return (mkWpCastN co <.> wrap) }
-
----------------
-tcSubTypeSigma :: CtOrigin       -- where did the actual type arise / why are we
-                                 -- doing this subtype check?
-               -> UserTypeCtxt   -- where did the expected type arise?
-               -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
--- External entry point, but no ExpTypes on either side
--- Checks that actual <= expected
--- Returns HsWrapper :: actual ~ expected
-tcSubTypeSigma orig ctxt ty_actual ty_expected
-  = tc_sub_type (unifyType Nothing) orig ctxt ty_actual ty_expected
-
----------------
-tcSubTypeAmbiguity :: UserTypeCtxt   -- Where did this type arise
-                   -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
--- See Note [Ambiguity check and deep subsumption]
-tcSubTypeAmbiguity ctxt ty_actual ty_expected
-  = tc_sub_type_shallow (unifyType Nothing)
-                        (AmbiguityCheckOrigin ctxt)
-                        ctxt ty_actual ty_expected
-
----------------
-addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a
-addSubTypeCtxt ty_actual ty_expected thing_inside
- | isRhoTy ty_actual        -- If there is no polymorphism involved, the
- , isRhoExpTy ty_expected   -- TypeEqOrigin stuff (added by the _NC functions)
- = thing_inside             -- gives enough context by itself
- | otherwise
- = addErrCtxtM mk_msg thing_inside
-  where
-    mk_msg tidy_env
-      = do { (tidy_env, ty_actual)   <- zonkTidyTcType tidy_env ty_actual
-           ; ty_expected             <- readExpType ty_expected
-                   -- A worry: might not be filled if we're debugging. Ugh.
-           ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected
-           ; let msg = vcat [ hang (text "When checking that:")
-                                 4 (ppr ty_actual)
-                            , nest 2 (hang (text "is more polymorphic than:")
-                                         2 (ppr ty_expected)) ]
-           ; return (tidy_env, msg) }
-
-
-{- Note [Instantiation of InferResult]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We now always instantiate before filling in InferResult, so that
-the result is a TcRhoType: see #17173 for discussion.
-
-For example:
-
-1. Consider
-    f x = (*)
-   We want to instantiate the type of (*) before returning, else we
-   will infer the type
-     f :: forall {a}. a -> forall b. Num b => b -> b -> b
-   This is surely confusing for users.
-
-   And worse, the monomorphism restriction won't work properly. The MR is
-   dealt with in simplifyInfer, and simplifyInfer has no way of
-   instantiating. This could perhaps be worked around, but it may be
-   hard to know even when instantiation should happen.
-
-2. Another reason.  Consider
-       f :: (?x :: Int) => a -> a
-       g y = let ?x = 3::Int in f
-   Here want to instantiate f's type so that the ?x::Int constraint
-  gets discharged by the enclosing implicit-parameter binding.
-
-3. Suppose one defines plus = (+). If we instantiate lazily, we will
-   infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism
-   restriction compels us to infer
-      plus :: Integer -> Integer -> Integer
-   (or similar monotype). Indeed, the only way to know whether to apply
-   the monomorphism restriction at all is to instantiate
-
-There is one place where we don't want to instantiate eagerly,
-namely in GHC.Tc.Module.tcRnExpr, which implements GHCi's :type
-command. See Note [Implementing :type] in GHC.Tc.Module.
--}
-
----------------
-tc_sub_type, tc_sub_type_deep, tc_sub_type_shallow
-    :: (TcType -> TcType -> TcM TcCoercionN)  -- How to unify
-    -> CtOrigin       -- Used when instantiating
-    -> UserTypeCtxt   -- Used when skolemising
-    -> TcSigmaType    -- Actual; a sigma-type
-    -> TcSigmaType    -- Expected; also a sigma-type
-    -> TcM HsWrapper
--- Checks that actual_ty is more polymorphic than expected_ty
--- If wrap = tc_sub_type t1 t2
---    => wrap :: t1 ~> t2
---
--- The "how to unify argument" is always a call to `uType TypeLevel orig`,
--- but with different ways of constructing the CtOrigin `orig` from
--- the argument types and context.
-
-----------------------
-tc_sub_type unify inst_orig ctxt ty_actual ty_expected
-  = do { deep_subsumption <- xoptM LangExt.DeepSubsumption
-       ; if deep_subsumption
-         then tc_sub_type_deep    unify inst_orig ctxt ty_actual ty_expected
-         else tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected
-  }
-
-----------------------
-tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected
-  | definitely_poly ty_expected   -- See Note [Don't skolemise unnecessarily]
-  , definitely_mono_shallow ty_actual
-  = do { traceTc "tc_sub_type (drop to equality)" $
-         vcat [ text "ty_actual   =" <+> ppr ty_actual
-              , text "ty_expected =" <+> ppr ty_expected ]
-       ; mkWpCastN <$>
-         unify ty_actual ty_expected }
-
-  | otherwise   -- This is the general case
-  = do { traceTc "tc_sub_type (general case)" $
-         vcat [ text "ty_actual   =" <+> ppr ty_actual
-              , text "ty_expected =" <+> ppr ty_expected ]
-
-       ; (sk_wrap, inner_wrap)
-           <- tcTopSkolemise ctxt ty_expected $ \ sk_rho ->
-              do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual
-                 ; cow           <- unify rho_a sk_rho
-                 ; return (mkWpCastN cow <.> wrap) }
-
-       ; return (sk_wrap <.> inner_wrap) }
-
-----------------------
-tc_sub_type_deep unify inst_orig ctxt ty_actual ty_expected
-  | definitely_poly ty_expected      -- See Note [Don't skolemise unnecessarily]
-  , definitely_mono_deep ty_actual
-  = do { traceTc "tc_sub_type_deep (drop to equality)" $
-         vcat [ text "ty_actual   =" <+> ppr ty_actual
-              , text "ty_expected =" <+> ppr ty_expected ]
-       ; mkWpCastN <$>
-         unify ty_actual ty_expected }
-
-  | otherwise   -- This is the general case
-  = do { traceTc "tc_sub_type_deep (general case)" $
-         vcat [ text "ty_actual   =" <+> ppr ty_actual
-              , text "ty_expected =" <+> ppr ty_expected ]
-
-       ; (sk_wrap, inner_wrap)
-           <- tcDeeplySkolemise ctxt ty_expected $ \ sk_rho ->
-              -- See Note [Deep subsumption]
-              tc_sub_type_ds unify inst_orig ctxt ty_actual sk_rho
-
-       ; return (sk_wrap <.> inner_wrap) }
-
-definitely_mono_shallow :: TcType -> Bool
-definitely_mono_shallow ty = isRhoTy ty
-    -- isRhoTy: no top level forall or (=>)
-
-definitely_mono_deep :: TcType -> Bool
-definitely_mono_deep ty
-  | not (definitely_mono_shallow ty)     = False
-    -- isRhoTy: False means top level forall or (=>)
-  | Just (_, res) <- tcSplitFunTy_maybe ty = definitely_mono_deep res
-    -- Top level (->)
-  | otherwise                              = True
-
-definitely_poly :: TcType -> Bool
--- A very conservative test:
--- see Note [Don't skolemise unnecessarily]
-definitely_poly ty
-  | (tvs, theta, tau) <- tcSplitSigmaTy ty
-  , (tv:_) <- tvs   -- At least one tyvar
-  , null theta      -- No constraints; see (DP1)
-  , checkTyVarEq tv tau `cterHasProblem` cteInsolubleOccurs
-       -- The tyvar actually occurs (DP2),
-       --     and occurs in an injective position (DP3).
-       -- Fortunately checkTyVarEq, used for the occur check,
-       -- is just what we need.
-  = True
-  | otherwise
-  = False
-
-{- Note [Don't skolemise unnecessarily]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we are trying to solve
-     ty_actual   <= ty_expected
-    (Char->Char) <= (forall a. a->a)
-We could skolemise the 'forall a', and then complain
-that (Char ~ a) is insoluble; but that's a pretty obscure
-error.  It's better to say that
-    (Char->Char) ~ (forall a. a->a)
-fails.
-
-If we prematurely go to equality we'll reject a program we should
-accept (e.g. #13752).  So the test (which is only to improve error
-message) is very conservative:
-
- * ty_actual   is /definitely/ monomorphic: see `definitely_mono`
-   This definitely_mono test comes in "shallow" and "deep" variants
-
- * ty_expected is /definitely/ polymorphic: see `definitely_poly`
-   This definitely_poly test is more subtle than you might think.
-   Here are three cases where expected_ty looks polymorphic, but
-   isn't, and where it would be /wrong/ to switch to equality:
-
-   (DP1)  (Char->Char) <= (forall a. (a~Char) => a -> a)
-
-   (DP2)  (Char->Char) <= (forall a. Char -> Char)
-
-   (DP3)  (Char->Char) <= (forall a. F [a] Char -> Char)
-                          where type instance F [x] t = t
-
-
-Note [Wrapper returned from tcSubMult]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There is no notion of multiplicity coercion in Core, therefore the wrapper
-returned by tcSubMult (and derived functions such as tcCheckUsage and
-checkManyPattern) is quite unlike any other wrapper: it checks whether the
-coercion produced by the constraint solver is trivial, producing a type error
-if it is not. This is implemented via the WpMultCoercion wrapper, as desugared
-by GHC.HsToCore.Binds.dsHsWrapper, which does the reflexivity check.
-
-This wrapper needs to be placed in the term; otherwise, checking of the
-eventual coercion won't be triggered during desugaring. But it can be put
-anywhere, since it doesn't affect the desugared code.
-
-Why do we check this in the desugarer? It's a convenient place, since it's
-right after all the constraints are solved. We need the constraints to be
-solved to check whether they are trivial or not.
-
-An alternative would be to have a kind of constraint which can
-only produce trivial evidence. This would allow such checks to happen
-in the constraint solver (#18756).
-This would be similar to the existing setup for Concrete, see
-  Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete
-    (PHASE 1 in particular).
--}
-
-tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper
-tcSubMult origin w_actual w_expected
-  | Just (w1, w2) <- isMultMul w_actual =
-  do { w1 <- tcSubMult origin w1 w_expected
-     ; w2 <- tcSubMult origin w2 w_expected
-     ; return (w1 <.> w2) }
-  -- Currently, we consider p*q and sup p q to be equal.  Therefore, p*q <= r is
-  -- equivalent to p <= r and q <= r.  For other cases, we approximate p <= q by p
-  -- ~ q.  This is not complete, but it's sound. See also Note [Overapproximating
-  -- multiplicities] in Multiplicity.
-tcSubMult origin w_actual w_expected =
-  case submult w_actual w_expected of
-    Submult -> return WpHole
-    Unknown -> tcEqMult origin w_actual w_expected
-
-tcEqMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper
-tcEqMult origin w_actual w_expected = do
-  {
-  -- Note that here we do not call to `submult`, so we check
-  -- for strict equality.
-  ; coercion <- uType TypeLevel origin w_actual w_expected
-  ; return $ if isReflCo coercion then WpHole else WpMultCoercion coercion }
-
-
-{- *********************************************************************
-*                                                                      *
-                    Deep subsumption
-*                                                                      *
-********************************************************************* -}
-
-{- Note [Deep subsumption]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-The DeepSubsumption extension, documented here
-
-    https://github.com/ghc-proposals/ghc-proposals/pull/511.
-
-makes a best-efforts attempt implement deep subsumption as it was
-prior to the Simplify Subsumption proposal:
-
-    https://github.com/ghc-proposals/ghc-proposals/pull/287
-
-The effects are in these main places:
-
-1. In the subsumption check, tcSubType, we must do deep skolemisation:
-   see the call to tcDeeplySkolemise in tc_sub_type_deep
-
-2. In tcPolyExpr we must do deep skolemisation:
-   see the call to tcDeeplySkolemise in tcSkolemiseExpType
-
-3. for expression type signatures (e :: ty), and functions with type
-   signatures (e.g. f :: ty; f = e), we must deeply skolemise the type;
-   see the call to tcDeeplySkolemise in tcSkolemiseScoped.
-
-4. In GHC.Tc.Gen.App.tcApp we call tcSubTypeDS to match the result
-   type. Without deep subsumption, unifyExpectedType would be sufficent.
-
-In all these cases note that the deep skolemisation must be done /first/.
-Consider (1)
-     (forall a. Int -> a -> a)  <=  Int -> (forall b. b -> b)
-We must skolemise the `forall b` before instantiating the `forall a`.
-See also Note [Deep skolemisation].
-
-Note that we /always/ use shallow subsumption in the ambiguity check.
-See Note [Ambiguity check and deep subsumption].
-
-Note [Deep skolemisation]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-deeplySkolemise decomposes and skolemises a type, returning a type
-with all its arrows visible (ie not buried under foralls)
-
-Examples:
-
-  deeplySkolemise (Int -> forall a. Ord a => blah)
-    =  ( wp, [a], [d:Ord a], Int -> blah )
-    where wp = \x:Int. /\a. \(d:Ord a). <hole> x
-
-  deeplySkolemise  (forall a. Ord a => Maybe a -> forall b. Eq b => blah)
-    =  ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )
-    where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x
-
-In general,
-  if      deeplySkolemise ty = (wrap, tvs, evs, rho)
-    and   e :: rho
-  then    wrap e :: ty
-    and   'wrap' binds tvs, evs
-
-ToDo: this eta-abstraction plays fast and loose with termination,
-      because it can introduce extra lambdas.  Maybe add a `seq` to
-      fix this
-
-Note [Setting the argument context]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider we are doing the ambiguity check for the (bogus)
-  f :: (forall a b. C b => a -> a) -> Int
-
-We'll call
-   tcSubType ((forall a b. C b => a->a) -> Int )
-             ((forall a b. C b => a->a) -> Int )
-
-with a UserTypeCtxt of (FunSigCtxt "f").  Then we'll do the co/contra thing
-on the argument type of the (->) -- and at that point we want to switch
-to a UserTypeCtxt of GenSigCtxt.  Why?
-
-* Error messages.  If we stick with FunSigCtxt we get errors like
-     * Could not deduce: C b
-       from the context: C b0
-        bound by the type signature for:
-            f :: forall a b. C b => a->a
-  But of course f does not have that type signature!
-  Example tests: T10508, T7220a, Simple14
-
-* Implications. We may decide to build an implication for the whole
-  ambiguity check, but we don't need one for each level within it,
-  and TcUnify.alwaysBuildImplication checks the UserTypeCtxt.
-  See Note [When to build an implication]
-
-Note [Multiplicity in deep subsumption]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   t1 ->{mt} t2  <=   s1 ->{ms} s2
-
-At the moment we /unify/ ms~mt, via tcEqMult.
-
-Arguably we should use `tcSubMult`. But then if mt=m0 (a unification
-variable) and ms=Many, `tcSubMult` is a no-op (since anything is a
-sub-multiplicty of Many).  But then `m0` may never get unified with
-anything.  It is then skolemised by the zonker; see GHC.HsToCore.Binds
-Note [Free tyvars on rule LHS].  So we in RULE foldr/app in GHC.Base
-we get this
-
- "foldr/app"     [1] forall ys m1 m2. foldr (\x{m1} \xs{m2}. (:) x xs) ys
-                                       = \xs -> xs ++ ys
-
-where we eta-expanded that (:).  But now foldr expects an argument
-with ->{Many} and gets an argument with ->{m1} or ->{m2}, and Lint
-complains.
-
-The easiest solution was to use tcEqMult in tc_sub_type_ds, and
-insist on equality. This is only in the DeepSubsumption code anyway.
--}
-
-tc_sub_type_ds :: (TcType -> TcType -> TcM TcCoercionN)  -- How to unify
-               -> CtOrigin       -- Used when instantiating
-               -> UserTypeCtxt   -- Used when skolemising
-               -> TcSigmaType    -- Actual; a sigma-type
-               -> TcRhoType      -- Expected; deeply skolemised
-               -> TcM HsWrapper
-
--- If wrap = tc_sub_type_ds t1 t2
---    => wrap :: t1 ~> t2
--- Here is where the work actually happens!
--- Precondition: ty_expected is deeply skolemised
-
-tc_sub_type_ds unify inst_orig ctxt ty_actual ty_expected
-  = do { traceTc "tc_sub_type_ds" $
-         vcat [ text "ty_actual   =" <+> ppr ty_actual
-              , text "ty_expected =" <+> ppr ty_expected ]
-       ; go ty_actual ty_expected }
-  where
-    -- NB: 'go' is not recursive, except for doing coreView
-    go ty_a ty_e | Just ty_a' <- coreView ty_a = go ty_a' ty_e
-                 | Just ty_e' <- coreView ty_e = go ty_a  ty_e'
-
-    go (TyVarTy tv_a) ty_e
-      = do { lookup_res <- isFilledMetaTyVar_maybe tv_a
-           ; case lookup_res of
-               Just ty_a' ->
-                 do { traceTc "tc_sub_type_ds following filled meta-tyvar:"
-                        (ppr tv_a <+> text "-->" <+> ppr ty_a')
-                    ; tc_sub_type_ds unify inst_orig ctxt ty_a' ty_e }
-               Nothing -> just_unify ty_actual ty_expected }
-
-    go ty_a@(FunTy { ft_af = af1, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res })
-       ty_e@(FunTy { ft_af = af2, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res })
-      | isVisibleFunArg af1, isVisibleFunArg af2
-      = if (isTauTy ty_a && isTauTy ty_e)       -- Short cut common case to avoid
-        then just_unify ty_actual ty_expected   -- unnecessary eta expansion
-        else
-        -- This is where we do the co/contra thing, and generate a WpFun, which in turn
-        -- causes eta-expansion, which we don't like; hence encouraging NoDeepSubsumption
-        do { arg_wrap  <- tc_sub_type_deep unify given_orig GenSigCtxt exp_arg act_arg
-                          -- GenSigCtxt: See Note [Setting the argument context]
-           ; res_wrap  <- tc_sub_type_ds   unify inst_orig  ctxt       act_res exp_res
-           ; mult_wrap <- tcEqMult inst_orig act_mult exp_mult
-                          -- See Note [Multiplicity in deep subsumption]
-           ; return (mult_wrap <.>
-                     mkWpFun arg_wrap res_wrap (Scaled exp_mult exp_arg) exp_res) }
-                     -- arg_wrap :: exp_arg ~> act_arg
-                     -- res_wrap :: act-res ~> exp_res
-      where
-        given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg [])
-
-    go ty_a ty_e
-      | let (tvs, theta, _) = tcSplitSigmaTy ty_a
-      , not (null tvs && null theta)
-      = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a
-           ; body_wrap <- tc_sub_type_ds unify inst_orig ctxt in_rho ty_e
-           ; return (body_wrap <.> in_wrap) }
-
-      | otherwise   -- Revert to unification
-      = do { -- It's still possible that ty_actual has nested foralls. Instantiate
-             -- these, as there's no way unification will succeed with them in.
-             -- See typecheck/should_compile/T11305 for an example of when this
-             -- is important. The problem is that we're checking something like
-             --  a -> forall b. b -> b     <=   alpha beta gamma
-             -- where we end up with alpha := (->)
-             (inst_wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual
-           ; unify_wrap         <- just_unify rho_a ty_expected
-           ; return (unify_wrap <.> inst_wrap) }
-
-    just_unify ty_a ty_e = do { cow <- unify ty_a ty_e
-                              ; return (mkWpCastN cow) }
-
-tcDeeplySkolemise
-    :: UserTypeCtxt -> TcSigmaType
-    -> (TcType -> TcM result)
-    -> TcM (HsWrapper, result)
-        -- ^ The wrapper has type: spec_ty ~> expected_ty
--- Just like tcTopSkolemise, but calls
--- deeplySkolemise instead of topSkolemise
--- See Note [Deep skolemisation]
-tcDeeplySkolemise ctxt expected_ty thing_inside
-  | isTauTy expected_ty  -- Short cut for common case
-  = do { res <- thing_inside expected_ty
-       ; return (idHsWrapper, res) }
-  | otherwise
-  = do  { -- This (unpleasant) rec block allows us to pass skol_info to deeplySkolemise;
-          -- but skol_info can't be built until we have tv_prs
-          rec { (wrap, tv_prs, given, rho_ty) <- deeplySkolemise skol_info expected_ty
-              ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) }
-
-        ; traceTc "tcDeeplySkolemise" (ppr expected_ty $$ ppr rho_ty $$ ppr tv_prs)
-
-        ; let skol_tvs  = map snd tv_prs
-        ; (ev_binds, result)
-              <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $
-                 thing_inside rho_ty
-
-        ; return (wrap <.> mkWpLet ev_binds, result) }
-          -- The ev_binds returned by checkConstraints is very
-          -- often empty, in which case mkWpLet is a no-op
-
-deeplySkolemise :: SkolemInfo -> TcSigmaType
-                -> TcM ( HsWrapper
-                       , [(Name,TyVar)]     -- All skolemised variables
-                       , [EvVar]            -- All "given"s
-                       , TcRhoType )
--- See Note [Deep skolemisation]
-deeplySkolemise skol_info ty
-  = go init_subst ty
-  where
-    init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty))
-
-    go subst ty
-      | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
-      = do { let arg_tys' = substScaledTys subst arg_tys
-           ; ids1           <- newSysLocalIds (fsLit "dk") arg_tys'
-           ; (subst', tvs1) <- tcInstSkolTyVarsX skol_info subst tvs
-           ; ev_vars1       <- newEvVars (substTheta subst' theta)
-           ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'
-           ; let tv_prs1 = map tyVarName tvs `zip` tvs1
-           ; return ( mkWpEta ids1 (mkWpTyLams tvs1
-                                    <.> mkWpEvLams ev_vars1
-                                    <.> wrap)
-                    , tv_prs1  ++ tvs_prs2
-                    , ev_vars1 ++ ev_vars2
-                    , mkScaledFunTys arg_tys' rho ) }
-
-      | otherwise
-      = return (idHsWrapper, [], [], substTy subst ty)
-        -- substTy is a quick no-op on an empty substitution
-
-deeplyInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type)
-deeplyInstantiate orig ty
-  = go init_subst ty
-  where
-    init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty))
-
-    go subst ty
-      | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
-      = do { (subst', tvs') <- newMetaTyVarsX subst tvs
-           ; let arg_tys' = substScaledTys   subst' arg_tys
-                 theta'   = substTheta subst' theta
-           ; ids1  <- newSysLocalIds (fsLit "di") arg_tys'
-           ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
-           ; (wrap2, rho2) <- go subst' rho
-           ; return (mkWpEta ids1 (wrap2 <.> wrap1),
-                     mkScaledFunTys arg_tys' rho2) }
-
-      | otherwise
-      = do { let ty' = substTy subst ty
-           ; return (idHsWrapper, ty') }
-
-tcDeepSplitSigmaTy_maybe
-  :: TcSigmaType -> Maybe ([Scaled TcType], [TyVar], ThetaType, TcSigmaType)
--- Looks for a *non-trivial* quantified type, under zero or more function arrows
--- By "non-trivial" we mean either tyvars or constraints are non-empty
-
-tcDeepSplitSigmaTy_maybe ty
-  | Just (arg_ty, res_ty)           <- tcSplitFunTy_maybe ty
-  , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty
-  = Just (arg_ty:arg_tys, tvs, theta, rho)
-
-  | (tvs, theta, rho) <- tcSplitSigmaTy ty
-  , not (null tvs && null theta)
-  = Just ([], tvs, theta, rho)
-
-  | otherwise = Nothing
-
-
-{- *********************************************************************
-*                                                                      *
-                    Generalisation
-*                                                                      *
-********************************************************************* -}
-
-{- Note [Skolemisation]
-~~~~~~~~~~~~~~~~~~~~~~~
-tcTopSkolemise takes "expected type" and strip off quantifiers to expose the
-type underneath, binding the new skolems for the 'thing_inside'
-The returned 'HsWrapper' has type (specific_ty -> expected_ty).
-
-Note that for a nested type like
-   forall a. Eq a => forall b. Ord b => blah
-we still only build one implication constraint
-   forall a b. (Eq a, Ord b) => <constraints>
-This is just an optimisation, but it's why we use topSkolemise to
-build the pieces from all the layers, before making a single call
-to checkConstraints.
-
-tcSkolemiseScoped is very similar, but differs in two ways:
-
-* It deals specially with just the outer forall, bringing those type
-  variables into lexical scope.  To my surprise, I found that doing
-  this unconditionally in tcTopSkolemise (i.e. doing it even if we don't
-  need to bring the variables into lexical scope, which is harmless)
-  caused a non-trivial (1%-ish) perf hit on the compiler.
-
-* It handles deep subumption, wheres tcTopSkolemise never looks under
-  function arrows.
-
-* It always calls checkConstraints, even if there are no skolem
-  variables at all.  Reason: there might be nested deferred errors
-  that must not be allowed to float to top level.
-  See Note [When to build an implication] below.
--}
-
-tcTopSkolemise, tcSkolemiseScoped
-    :: UserTypeCtxt -> TcSigmaType
-    -> (TcType -> TcM result)
-    -> TcM (HsWrapper, result)
-        -- ^ The wrapper has type: spec_ty ~> expected_ty
--- See Note [Skolemisation] for the differences between
--- tcSkolemiseScoped and tcTopSkolemise
-
-tcSkolemiseScoped ctxt expected_ty thing_inside
-  = do { deep_subsumption <- xoptM LangExt.DeepSubsumption
-       ; let skolemise | deep_subsumption = deeplySkolemise
-                       | otherwise        = topSkolemise
-       ; -- This (unpleasant) rec block allows us to pass skol_info to deeplySkolemise;
-         -- but skol_info can't be built until we have tv_prs
-         rec { (wrap, tv_prs, given, rho_ty) <- skolemise skol_info expected_ty
-             ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) }
-
-       ; let skol_tvs = map snd tv_prs
-       ; (ev_binds, res)
-             <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $
-                tcExtendNameTyVarEnv tv_prs               $
-                thing_inside rho_ty
-
-       ; return (wrap <.> mkWpLet ev_binds, res) }
-
-tcTopSkolemise ctxt expected_ty thing_inside
-  | isRhoTy expected_ty  -- Short cut for common case
-  = do { res <- thing_inside expected_ty
-       ; return (idHsWrapper, res) }
-  | otherwise
-  = do { rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty
-             ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) }
-
-       ; let skol_tvs = map snd tv_prs
-       ; (ev_binds, result)
-             <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $
-                thing_inside rho_ty
-
-       ; return (wrap <.> mkWpLet ev_binds, result) }
-         -- The ev_binds returned by checkConstraints is very
-        -- often empty, in which case mkWpLet is a no-op
-
--- | Variant of 'tcTopSkolemise' that takes an ExpType
-tcSkolemiseExpType :: UserTypeCtxt -> ExpSigmaType
-                   -> (ExpRhoType -> TcM result)
-                   -> TcM (HsWrapper, result)
-tcSkolemiseExpType _ et@(Infer {}) thing_inside
-  = (idHsWrapper, ) <$> thing_inside et
-tcSkolemiseExpType ctxt (Check ty) thing_inside
-  = do { deep_subsumption <- xoptM LangExt.DeepSubsumption
-       ; let skolemise | deep_subsumption = tcDeeplySkolemise
-                       | otherwise        = tcTopSkolemise
-       ; skolemise ctxt ty $ \rho_ty ->
-         thing_inside (mkCheckExpType rho_ty) }
-
-checkConstraints :: SkolemInfoAnon
-                 -> [TcTyVar]           -- Skolems
-                 -> [EvVar]             -- Given
-                 -> TcM result
-                 -> TcM (TcEvBinds, result)
-
-checkConstraints skol_info skol_tvs given thing_inside
-  = do { implication_needed <- implicationNeeded skol_info skol_tvs given
-
-       ; if implication_needed
-         then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside
-                 ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted
-                 ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs)
-                 ; emitImplications implics
-                 ; return (ev_binds, result) }
-
-         else -- Fast path.  We check every function argument with tcCheckPolyExpr,
-              -- which uses tcTopSkolemise and hence checkConstraints.
-              -- So this fast path is well-exercised
-              do { res <- thing_inside
-                 ; return (emptyTcEvBinds, res) } }
-
-checkTvConstraints :: SkolemInfo
-                   -> [TcTyVar]          -- Skolem tyvars
-                   -> TcM result
-                   -> TcM result
-
-checkTvConstraints skol_info skol_tvs thing_inside
-  = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside
-       ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted
-       ; return result }
-
-emitResidualTvConstraint :: SkolemInfo -> [TcTyVar]
-                         -> TcLevel -> WantedConstraints -> TcM ()
-emitResidualTvConstraint skol_info skol_tvs tclvl wanted
-  | not (isEmptyWC wanted) ||
-    checkTelescopeSkol skol_info_anon
-  = -- checkTelescopeSkol: in this case, /always/ emit this implication
-    -- even if 'wanted' is empty. We need the implication so that we check
-    -- for a bad telescope. See Note [Skolem escape and forall-types] in
-    -- GHC.Tc.Gen.HsType
-    do { implic <- buildTvImplication skol_info_anon skol_tvs tclvl wanted
-       ; emitImplication implic }
-
-  | otherwise  -- Empty 'wanted', emit nothing
-  = return ()
-  where
-     skol_info_anon = getSkolemInfo skol_info
-
-buildTvImplication :: SkolemInfoAnon -> [TcTyVar]
-                   -> TcLevel -> WantedConstraints -> TcM Implication
-buildTvImplication skol_info skol_tvs tclvl wanted
-  = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $
-    do { ev_binds <- newNoTcEvBinds  -- Used for equalities only, so all the constraints
-                                     -- are solved by filling in coercion holes, not
-                                     -- by creating a value-level evidence binding
-       ; implic   <- newImplication
-
-       ; let implic' = implic { ic_tclvl     = tclvl
-                              , ic_skols     = skol_tvs
-                              , ic_given_eqs = NoGivenEqs
-                              , ic_wanted    = wanted
-                              , ic_binds     = ev_binds
-                              , ic_info      = skol_info }
-
-       ; checkImplicationInvariants implic'
-       ; return implic' }
-
-implicationNeeded :: SkolemInfoAnon -> [TcTyVar] -> [EvVar] -> TcM Bool
--- See Note [When to build an implication]
-implicationNeeded skol_info skol_tvs given
-  | null skol_tvs
-  , null given
-  , not (alwaysBuildImplication skol_info)
-  = -- Empty skolems and givens
-    do { tc_lvl <- getTcLevel
-       ; if not (isTopTcLevel tc_lvl)  -- No implication needed if we are
-         then return False             -- already inside an implication
-         else
-    do { dflags <- getDynFlags       -- If any deferral can happen,
-                                     -- we must build an implication
-       ; return (gopt Opt_DeferTypeErrors dflags ||
-                 gopt Opt_DeferTypedHoles dflags ||
-                 gopt Opt_DeferOutOfScopeVariables dflags) } }
-
-  | otherwise     -- Non-empty skolems or givens
-  = return True   -- Definitely need an implication
-
-alwaysBuildImplication :: SkolemInfoAnon -> Bool
--- See Note [When to build an implication]
-alwaysBuildImplication _ = False
-
-{-  Commmented out for now while I figure out about error messages.
-    See #14185
-
-alwaysBuildImplication (SigSkol ctxt _ _)
-  = case ctxt of
-      FunSigCtxt {} -> True  -- RHS of a binding with a signature
-      _             -> False
-alwaysBuildImplication (RuleSkol {})      = True
-alwaysBuildImplication (InstSkol {})      = True
-alwaysBuildImplication (FamInstSkol {})   = True
-alwaysBuildImplication _                  = False
--}
-
-buildImplicationFor :: TcLevel -> SkolemInfoAnon -> [TcTyVar]
-                   -> [EvVar] -> WantedConstraints
-                   -> TcM (Bag Implication, TcEvBinds)
-buildImplicationFor tclvl skol_info skol_tvs given wanted
-  | isEmptyWC wanted && null given
-             -- Optimisation : if there are no wanteds, and no givens
-             -- don't generate an implication at all.
-             -- Reason for the (null given): we don't want to lose
-             -- the "inaccessible alternative" error check
-  = return (emptyBag, emptyTcEvBinds)
-
-  | otherwise
-  = assertPpr (all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs) (ppr skol_tvs) $
-      -- Why allow TyVarTvs? Because implicitly declared kind variables in
-      -- non-CUSK type declarations are TyVarTvs, and we need to bring them
-      -- into scope as a skolem in an implication. This is OK, though,
-      -- because TyVarTvs will always remain tyvars, even after unification.
-    do { ev_binds_var <- newTcEvBinds
-       ; implic <- newImplication
-       ; let implic' = implic { ic_tclvl  = tclvl
-                              , ic_skols  = skol_tvs
-                              , ic_given  = given
-                              , ic_wanted = wanted
-                              , ic_binds  = ev_binds_var
-                              , ic_info   = skol_info }
-       ; checkImplicationInvariants implic'
-
-       ; return (unitBag implic', TcEvBinds ev_binds_var) }
-
-{- Note [When to build an implication]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have some 'skolems' and some 'givens', and we are
-considering whether to wrap the constraints in their scope into an
-implication.  We must /always/ so if either 'skolems' or 'givens' are
-non-empty.  But what if both are empty?  You might think we could
-always drop the implication.  Other things being equal, the fewer
-implications the better.  Less clutter and overhead.  But we must
-take care:
-
-* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors,
-  we'll make a /term-level/ evidence binding for 'g = error "blah"'.
-  We must have an EvBindsVar those bindings!, otherwise they end up as
-  top-level unlifted bindings, which are verboten. This only matters
-  at top level, so we check for that
-  See also Note [Deferred errors for coercion holes] in GHC.Tc.Errors.
-  cf #14149 for an example of what goes wrong.
-
-* If you have
-     f :: Int;  f = f_blah
-     g :: Bool; g = g_blah
-  If we don't build an implication for f or g (no tyvars, no givens),
-  the constraints for f_blah and g_blah are solved together.  And that
-  can yield /very/ confusing error messages, because we can get
-      [W] C Int b1    -- from f_blah
-      [W] C Int b2    -- from g_blan
-  and fundpes can yield [W] b1 ~ b2, even though the two functions have
-  literally nothing to do with each other.  #14185 is an example.
-  Building an implication keeps them separate.
--}
-
-{-
-************************************************************************
-*                                                                      *
-                Boxy unification
-*                                                                      *
-************************************************************************
-
-The exported functions are all defined as versions of some
-non-exported generic functions.
--}
-
-unifyType :: Maybe TypedThing  -- ^ If present, the thing that has type ty1
-          -> TcTauType -> TcTauType    -- ty1 (actual), ty2 (expected)
-          -> TcM TcCoercionN           -- :: ty1 ~# ty2
--- Actual and expected types
--- Returns a coercion : ty1 ~ ty2
-unifyType thing ty1 ty2
-  = uType TypeLevel origin ty1 ty2
-  where
-    origin = TypeEqOrigin { uo_actual   = ty1
-                          , uo_expected = ty2
-                          , uo_thing    = thing
-                          , uo_visible  = True }
-
-unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN
--- Like unifyType, but swap expected and actual in error messages
--- This is used when typechecking patterns
-unifyTypeET ty1 ty2
-  = uType TypeLevel origin ty1 ty2
-  where
-    origin = TypeEqOrigin { uo_actual   = ty2   -- NB swapped
-                          , uo_expected = ty1   -- NB swapped
-                          , uo_thing    = Nothing
-                          , uo_visible  = True }
-
-
-unifyKind :: Maybe TypedThing -> TcKind -> TcKind -> TcM CoercionN
-unifyKind mb_thing ty1 ty2
-  = uType KindLevel origin ty1 ty2
-  where
-    origin = TypeEqOrigin { uo_actual   = ty1
-                          , uo_expected = ty2
-                          , uo_thing    = mb_thing
-                          , uo_visible  = True }
-
-
-{-
-%************************************************************************
-%*                                                                      *
-                 uType and friends
-%*                                                                      *
-%************************************************************************
-
-uType is the heart of the unifier.
--}
-
-uType, uType_defer
-  :: TypeOrKind
-  -> CtOrigin
-  -> TcType    -- ty1 is the *actual* type
-  -> TcType    -- ty2 is the *expected* type
-  -> TcM CoercionN
-
---------------
--- It is always safe to defer unification to the main constraint solver
--- See Note [Deferred unification]
---    ty1 is "actual"
---    ty2 is "expected"
-uType_defer t_or_k origin ty1 ty2
-  = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2
-
-       -- Error trace only
-       -- NB. do *not* call mkErrInfo unless tracing is on,
-       --     because it is hugely expensive (#5631)
-       ; whenDOptM Opt_D_dump_tc_trace $ do
-            { ctxt <- getErrCtxt
-            ; doc <- mkErrInfo emptyTidyEnv ctxt
-            ; traceTc "utype_defer" (vcat [ debugPprType ty1
-                                          , debugPprType ty2
-                                          , pprCtOrigin origin
-                                          , doc])
-            ; traceTc "utype_defer2" (ppr co)
-            }
-       ; return co }
-
---------------
-uType t_or_k origin orig_ty1 orig_ty2
-  = do { tclvl <- getTcLevel
-       ; traceTc "u_tys" $ vcat
-              [ text "tclvl" <+> ppr tclvl
-              , sep [ ppr orig_ty1, text "~", ppr orig_ty2]
-              , pprCtOrigin origin]
-       ; co <- go orig_ty1 orig_ty2
-       ; if isReflCo co
-            then traceTc "u_tys yields no coercion" Outputable.empty
-            else traceTc "u_tys yields coercion:" (ppr co)
-       ; return co }
-  where
-    go :: TcType -> TcType -> TcM CoercionN
-        -- The arguments to 'go' are always semantically identical
-        -- to orig_ty{1,2} except for looking through type synonyms
-
-     -- Unwrap casts before looking for variables. This way, we can easily
-     -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we
-     -- didn't do it this way, and then the unification above was deferred.
-    go (CastTy t1 co1) t2
-      = do { co_tys <- uType t_or_k origin t1 t2
-           ; return (mkCoherenceLeftCo Nominal t1 co1 co_tys) }
-
-    go t1 (CastTy t2 co2)
-      = do { co_tys <- uType t_or_k origin t1 t2
-           ; return (mkCoherenceRightCo Nominal t2 co2 co_tys) }
-
-        -- Variables; go for uUnfilledVar
-        -- Note that we pass in *original* (before synonym expansion),
-        -- so that type variables tend to get filled in with
-        -- the most informative version of the type
-    go (TyVarTy tv1) ty2
-      = do { lookup_res <- isFilledMetaTyVar_maybe tv1
-           ; case lookup_res of
-               Just ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1)
-                                ; go ty1 ty2 }
-               Nothing  -> uUnfilledVar origin t_or_k NotSwapped tv1 ty2 }
-    go ty1 (TyVarTy tv2)
-      = do { lookup_res <- isFilledMetaTyVar_maybe tv2
-           ; case lookup_res of
-               Just ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2)
-                              ; go ty1 ty2 }
-               Nothing  -> uUnfilledVar origin t_or_k IsSwapped tv2 ty1 }
-
-      -- See Note [Expanding synonyms during unification]
-    go ty1@(TyConApp tc1 []) (TyConApp tc2 [])
-      | tc1 == tc2
-      = return $ mkNomReflCo ty1
-
-        -- See Note [Expanding synonyms during unification]
-        --
-        -- Also NB that we recurse to 'go' so that we don't push a
-        -- new item on the origin stack. As a result if we have
-        --   type Foo = Int
-        -- and we try to unify  Foo ~ Bool
-        -- we'll end up saying "can't match Foo with Bool"
-        -- rather than "can't match "Int with Bool".  See #4535.
-    go ty1 ty2
-      | Just ty1' <- coreView ty1 = go ty1' ty2
-      | Just ty2' <- coreView ty2 = go ty1  ty2'
-
-    -- Functions (t1 -> t2) just check the two parts
-    -- Do not attempt (c => t); just defer
-    go (FunTy { ft_af = af1, ft_mult = w1, ft_arg = arg1, ft_res = res1 })
-       (FunTy { ft_af = af2, ft_mult = w2, ft_arg = arg2, ft_res = res2 })
-      | isVisibleFunArg af1, af1 == af2
-      = do { co_l <- uType t_or_k origin arg1 arg2
-           ; co_r <- uType t_or_k origin res1 res2
-           ; co_w <- uType t_or_k origin w1 w2
-           ; return $ mkNakedFunCo1 Nominal af1 co_w co_l co_r }
-
-        -- Always defer if a type synonym family (type function)
-        -- is involved.  (Data families behave rigidly.)
-    go ty1@(TyConApp tc1 _) ty2
-      | isTypeFamilyTyCon tc1 = defer ty1 ty2
-    go ty1 ty2@(TyConApp tc2 _)
-      | isTypeFamilyTyCon tc2 = defer ty1 ty2
-
-    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
-      -- See Note [Mismatched type lists and application decomposition]
-      | tc1 == tc2, equalLength tys1 tys2
-      = assertPpr (isGenerativeTyCon tc1 Nominal) (ppr tc1) $
-        do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2
-           ; return $ mkTyConAppCo Nominal tc1 cos }
-      where
-        origins' = map (\is_vis -> if is_vis then origin else toInvisibleOrigin origin)
-                       (tcTyConVisibilities tc1)
-
-    go (LitTy m) ty@(LitTy n)
-      | m == n
-      = return $ mkNomReflCo ty
-
-        -- See Note [Care with type applications]
-        -- Do not decompose FunTy against App;
-        -- it's often a type error, so leave it for the constraint solver
-    go (AppTy s1 t1) (AppTy s2 t2)
-      = go_app (isNextArgVisible s1) s1 t1 s2 t2
-
-    go (AppTy s1 t1) (TyConApp tc2 ts2)
-      | Just (ts2', t2') <- snocView ts2
-      = assert (not (tyConMustBeSaturated tc2)) $
-        go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'
-
-    go (TyConApp tc1 ts1) (AppTy s2 t2)
-      | Just (ts1', t1') <- snocView ts1
-      = assert (not (tyConMustBeSaturated tc1)) $
-        go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2
-
-    go (CoercionTy co1) (CoercionTy co2)
-      = do { let ty1 = coercionType co1
-                 ty2 = coercionType co2
-           ; kco <- uType KindLevel
-                          (KindEqOrigin orig_ty1 orig_ty2 origin
-                                        (Just t_or_k))
-                          ty1 ty2
-           ; return $ mkProofIrrelCo Nominal kco co1 co2 }
-
-        -- Anything else fails
-        -- E.g. unifying for-all types, which is relative unusual
-    go ty1 ty2 = defer ty1 ty2
-
-    ------------------
-    defer ty1 ty2   -- See Note [Check for equality before deferring]
-      | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1)
-      | otherwise          = uType_defer t_or_k origin ty1 ty2
-
-    ------------------
-    go_app vis s1 t1 s2 t2
-      = do { co_s <- uType t_or_k origin s1 s2
-           ; let arg_origin
-                   | vis       = origin
-                   | otherwise = toInvisibleOrigin origin
-           ; co_t <- uType t_or_k arg_origin t1 t2
-           ; return $ mkAppCo co_s co_t }
-
-{- Note [Check for equality before deferring]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Particularly in ambiguity checks we can get equalities like (ty ~ ty).
-If ty involves a type function we may defer, which isn't very sensible.
-An egregious example of this was in test T9872a, which has a type signature
-       Proxy :: Proxy (Solutions Cubes)
-Doing the ambiguity check on this signature generates the equality
-   Solutions Cubes ~ Solutions Cubes
-and currently the constraint solver normalises both sides at vast cost.
-This little short-cut in 'defer' helps quite a bit.
-
-Note [Care with type applications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Note: type applications need a bit of care!
-They can match FunTy and TyConApp, so use splitAppTy_maybe
-NB: we've already dealt with type variables and Notes,
-so if one type is an App the other one jolly well better be too
-
-Note [Mismatched type lists and application decomposition]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we find two TyConApps, you might think that the argument lists
-are guaranteed equal length.  But they aren't. Consider matching
-        w (T x) ~ Foo (T x y)
-We do match (w ~ Foo) first, but in some circumstances we simply create
-a deferred constraint; and then go ahead and match (T x ~ T x y).
-This came up in #3950.
-
-So either
-   (a) either we must check for identical argument kinds
-       when decomposing applications,
-
-   (b) or we must be prepared for ill-kinded unification sub-problems
-
-Currently we adopt (b) since it seems more robust -- no need to maintain
-a global invariant.
-
-Note [Expanding synonyms during unification]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We expand synonyms during unification, but:
- * We expand *after* the variable case so that we tend to unify
-   variables with un-expanded type synonym. This just makes it
-   more likely that the inferred types will mention type synonyms
-   understandable to the user
-
- * Similarly, we expand *after* the CastTy case, just in case the
-   CastTy wraps a variable.
-
- * We expand *before* the TyConApp case.  For example, if we have
-      type Phantom a = Int
-   and are unifying
-      Phantom Int ~ Phantom Char
-   it is *wrong* to unify Int and Char.
-
- * The problem case immediately above can happen only with arguments
-   to the tycon. So we check for nullary tycons *before* expanding.
-   This is particularly helpful when checking (* ~ *), because * is
-   now a type synonym.
-
-Note [Deferred unification]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically,
-and yet its consistency is undetermined. Previously, there was no way to still
-make it consistent. So a mismatch error was issued.
-
-Now these unifications are deferred until constraint simplification, where type
-family instances and given equations may (or may not) establish the consistency.
-Deferred unifications are of the form
-                F ... ~ ...
-or              x ~ ...
-where F is a type function and x is a type variable.
-E.g.
-        id :: x ~ y => x -> y
-        id e = e
-
-involves the unification x = y. It is deferred until we bring into account the
-context x ~ y to establish that it holds.
-
-If available, we defer original types (rather than those where closed type
-synonyms have already been expanded via tcCoreView).  This is, as usual, to
-improve error messages.
-
-************************************************************************
-*                                                                      *
-                 uUnfilledVar and friends
-*                                                                      *
-************************************************************************
-
-@uunfilledVar@ is called when at least one of the types being unified is a
-variable.  It does {\em not} assume that the variable is a fixed point
-of the substitution; rather, notice that @uVar@ (defined below) nips
-back into @uTys@ if it turns out that the variable is already bound.
--}
-
-----------
-uUnfilledVar :: CtOrigin
-             -> TypeOrKind
-             -> SwapFlag
-             -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar
-                               --    definitely not a /filled/ meta-tyvar
-             -> TcTauType      -- Type 2
-             -> TcM Coercion
--- "Unfilled" means that the variable is definitely not a filled-in meta tyvar
---            It might be a skolem, or untouchable, or meta
-
-uUnfilledVar origin t_or_k swapped tv1 ty2
-  = do { ty2 <- zonkTcType ty2
-             -- Zonk to expose things to the
-             -- occurs check, and so that if ty2
-             -- looks like a type variable then it
-             -- /is/ a type variable
-       ; uUnfilledVar1 origin t_or_k swapped tv1 ty2 }
-
-----------
-uUnfilledVar1 :: CtOrigin
-              -> TypeOrKind
-              -> SwapFlag
-              -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar
-                                --    definitely not a /filled/ meta-tyvar
-              -> TcTauType      -- Type 2, zonked
-              -> TcM Coercion
-uUnfilledVar1 origin t_or_k swapped tv1 ty2
-  | Just tv2 <- getTyVar_maybe ty2
-  = go tv2
-
-  | otherwise
-  = uUnfilledVar2 origin t_or_k swapped tv1 ty2
-
-  where
-    -- 'go' handles the case where both are
-    -- tyvars so we might want to swap
-    -- E.g. maybe tv2 is a meta-tyvar and tv1 is not
-    go tv2 | tv1 == tv2  -- Same type variable => no-op
-           = return (mkNomReflCo (mkTyVarTy tv1))
-
-           | swapOverTyVars False tv1 tv2   -- Distinct type variables
-               -- Swap meta tyvar to the left if poss
-           = do { tv1 <- zonkTyCoVarKind tv1
-                     -- We must zonk tv1's kind because that might
-                     -- not have happened yet, and it's an invariant of
-                     -- uUnfilledTyVar2 that ty2 is fully zonked
-                     -- Omitting this caused #16902
-                ; uUnfilledVar2 origin t_or_k (flipSwap swapped)
-                           tv2 (mkTyVarTy tv1) }
-
-           | otherwise
-           = uUnfilledVar2 origin t_or_k swapped tv1 ty2
-
-----------
-uUnfilledVar2 :: CtOrigin
-              -> TypeOrKind
-              -> SwapFlag
-              -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar
-                                --    definitely not a /filled/ meta-tyvar
-              -> TcTauType      -- Type 2, zonked
-              -> TcM Coercion
-uUnfilledVar2 origin t_or_k swapped tv1 ty2
-  = do { cur_lvl <- getTcLevel
-       ; go cur_lvl }
-  where
-    go cur_lvl
-      | isTouchableMetaTyVar cur_lvl tv1
-           -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles
-      , cterHasNoProblem (checkTyVarEq tv1 ty2)
-           -- See Note [Prevent unification with type families]
-      = do { can_continue_solving <- startSolvingByUnification (metaTyVarInfo tv1) ty2
-           ; if not can_continue_solving
-             then not_ok_so_defer
-             else
-        do { co_k <- uType KindLevel kind_origin (typeKind ty2) (tyVarKind tv1)
-           ; traceTc "uUnfilledVar2 ok" $
-             vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)
-                  , ppr ty2 <+> dcolon <+> ppr (typeKind  ty2)
-                  , ppr (isReflCo co_k), ppr co_k ]
-
-           ; if isReflCo co_k
-               -- Only proceed if the kinds match
-               -- NB: tv1 should still be unfilled, despite the kind unification
-               --     because tv1 is not free in ty2 (or, hence, in its kind)
-             then do { writeMetaTyVar tv1 ty2
-                     ; return (mkNomReflCo ty2) }
-
-             else defer }} -- This cannot be solved now.  See GHC.Tc.Solver.Canonical
-                           -- Note [Equalities with incompatible kinds] for how
-                           -- this will be dealt with in the solver
-
-      | otherwise
-      = not_ok_so_defer
-
-    ty1 = mkTyVarTy tv1
-    kind_origin = KindEqOrigin ty1 ty2 origin (Just t_or_k)
-
-    defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2
-
-    not_ok_so_defer =
-      do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2)
-               -- Occurs check or an untouchable: just defer
-               -- NB: occurs check isn't necessarily fatal:
-               --     eg tv1 occurred in type family parameter
-          ; defer }
-
--- | Checks (TYVAR-TV), (COERCION-HOLE) and (CONCRETE) of
--- Note [Unification preconditions]; returns True if these conditions
--- are satisfied. But see the Note for other preconditions, too.
-startSolvingByUnification :: MetaInfo -> TcType  -- zonked
-                          -> TcM Bool
-startSolvingByUnification _ xi
-  | hasCoercionHoleTy xi  -- (COERCION-HOLE) check
-  = return False
-startSolvingByUnification info xi
-  = case info of
-      CycleBreakerTv -> return False
-      ConcreteTv conc_orig ->
-        do { (_, not_conc_reasons) <- makeTypeConcrete conc_orig xi
-                 -- NB: makeTypeConcrete has the side-effect of turning
-                 -- some TauTvs into ConcreteTvs, e.g.
-                 -- alpha[conc] ~# TYPE (TupleRep '[ beta[tau], IntRep ])
-                 -- will write `beta[tau] := beta[conc]`.
-                 --
-                 -- We don't need to track these unifications for the purposes
-                 -- of constraint solving (e.g. updating tcs_unified or tcs_unif_lvl),
-                 -- as they don't unlock any further progress.
-           ; case not_conc_reasons of
-               [] -> return True
-               _  -> return False }
-      TyVarTv ->
-        case getTyVar_maybe xi of
-           Nothing -> return False
-           Just tv ->
-             case tcTyVarDetails tv of -- (TYVAR-TV) wrinkle
-                SkolemTv {} -> return True
-                RuntimeUnk  -> return True
-                MetaTv { mtv_info = info } ->
-                  case info of
-                    TyVarTv -> return True
-                    _       -> return False
-      _ -> return True
-
-swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool
-swapOverTyVars is_given tv1 tv2
-  -- See Note [Unification variables on the left]
-  | not is_given, pri1 == 0, pri2 > 0 = True
-  | not is_given, pri2 == 0, pri1 > 0 = False
-
-  -- Level comparison: see Note [TyVar/TyVar orientation]
-  | lvl1 `strictlyDeeperThan` lvl2 = False
-  | lvl2 `strictlyDeeperThan` lvl1 = True
-
-  -- Priority: see Note [TyVar/TyVar orientation]
-  | pri1 > pri2 = False
-  | pri2 > pri1 = True
-
-  -- Names: see Note [TyVar/TyVar orientation]
-  | isSystemName tv2_name, not (isSystemName tv1_name) = True
-
-  | otherwise = False
-
-  where
-    lvl1 = tcTyVarLevel tv1
-    lvl2 = tcTyVarLevel tv2
-    pri1 = lhsPriority tv1
-    pri2 = lhsPriority tv2
-    tv1_name = Var.varName tv1
-    tv2_name = Var.varName tv2
-
-
-lhsPriority :: TcTyVar -> Int
--- Higher => more important to be on the LHS
---        => more likely to be eliminated
--- See Note [TyVar/TyVar orientation]
-lhsPriority tv
-  = assertPpr (isTyVar tv) (ppr tv) $
-    case tcTyVarDetails tv of
-      RuntimeUnk  -> 0
-      SkolemTv {} -> 0
-      MetaTv { mtv_info = info } -> case info of
-                                     CycleBreakerTv -> 0
-                                     TyVarTv        -> 1
-                                     ConcreteTv {}  -> 2
-                                     TauTv          -> 3
-                                     RuntimeUnkTv   -> 4
-
-{- Note [Unification preconditions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Question: given a homogeneous equality (alpha ~# ty), when is it OK to
-unify alpha := ty?
-
-This note only applied to /homogeneous/ equalities, in which both
-sides have the same kind.
-
-There are five reasons not to unify:
-
-1. (SKOL-ESC) Skolem-escape
-   Consider the constraint
-        forall[2] a[2]. alpha[1] ~ Maybe a[2]
-   If we unify alpha := Maybe a, the skolem 'a' may escape its scope.
-   The level alpha[1] says that alpha may be used outside this constraint,
-   where 'a' is not in scope at all.  So we must not unify.
-
-   Bottom line: when looking at a constraint alpha[n] := ty, do not unify
-   if any free variable of 'ty' has level deeper (greater) than n
-
-2. (UNTOUCHABLE) Untouchable unification variables
-   Consider the constraint
-        forall[2] a[2]. b[1] ~ Int => alpha[1] ~ Int
-   There is no (SKOL-ESC) problem with unifying alpha := Int, but it might
-   not be the principal solution. Perhaps the "right" solution is alpha := b.
-   We simply can't tell.  See "OutsideIn(X): modular type inference with local
-   assumptions", section 2.2.  We say that alpha[1] is "untouchable" inside
-   this implication.
-
-   Bottom line: at ambient level 'l', when looking at a constraint
-   alpha[n] ~ ty, do not unify alpha := ty if there are any given equalities
-   between levels 'n' and 'l'.
-
-   Exactly what is a "given equality" for the purpose of (UNTOUCHABLE)?
-   Answer: see Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet
-
-3. (TYVAR-TV) Unifying TyVarTvs and CycleBreakerTvs
-   This precondition looks at the MetaInfo of the unification variable:
-
-   * TyVarTv: When considering alpha{tyv} ~ ty, if alpha{tyv} is a
-     TyVarTv it can only unify with a type variable, not with a
-     structured type.  So if 'ty' is a structured type, such as (Maybe x),
-     don't unify.
-
-   * CycleBreakerTv: never unified, except by restoreTyVarCycles.
-
-4. (CONCRETE) A ConcreteTv can only unify with a concrete type,
-    by definition.
-
-    That is, if we have `rr[conc] ~ F Int`, we can't unify
-    `rr` with `F Int`, so we hold off on unifying.
-    Note however that the equality might get rewritten; for instance
-    if we can rewrite `F Int` to a concrete type, say `FloatRep`,
-    then we will have `rr[conc] ~ FloatRep` and we can unify `rr ~ FloatRep`.
-
-    Note that we can still make progress on unification even if
-    we can't fully solve an equality, e.g.
-
-      alpha[conc] ~# TupleRep '[ beta[tau], F gamma[tau] ]
-
-    we can fill beta[tau] := beta[conc]. This is why we call
-    'makeTypeConcrete' in startSolvingByUnification.
-
-5. (COERCION-HOLE) Confusing coercion holes
-   Suppose our equality is
-     (alpha :: k) ~ (Int |> {co})
-   where co :: Type ~ k is an unsolved wanted. Note that this
-   equality is homogeneous; both sides have kind k. Unifying here
-   is sensible, but it can lead to very confusing error messages.
-   It's very much like a Wanted rewriting a Wanted. Even worse,
-   unifying a variable essentially turns an equality into a Given,
-   and so we could not use the tracking mechanism in
-   Note [Wanteds rewrite Wanteds] in GHC.Tc.Types.Constraint.
-   We thus simply do not unify in this case.
-
-   This is expanded as Wrinkle (2) in Note [Equalities with incompatible kinds]
-   in GHC.Tc.Solver.Canonical.
-
-
-Needless to say, all there are wrinkles:
-
-* (SKOL-ESC) Promotion.  Given alpha[n] ~ ty, what if beta[k] is free
-  in 'ty', where beta is a unification variable, and k>n?  'beta'
-  stands for a monotype, and since it is part of a level-n type
-  (equal to alpha[n]), we must /promote/ beta to level n.  Just make
-  up a fresh gamma[n], and unify beta[k] := gamma[n].
-
-* (TYVAR-TV) Unification variables.  Suppose alpha[tyv,n] is a level-n
-  TyVarTv (see Note [TyVarTv] in GHC.Tc.Types.TcMType)? Now
-  consider alpha[tyv,n] ~ Bool.  We don't want to unify because that
-  would break the TyVarTv invariant.
-
-  What about alpha[tyv,n] ~ beta[tau,n], where beta is an ordinary
-  TauTv?  Again, don't unify, because beta might later be unified
-  with, say Bool.  (If levels permit, we reverse the orientation here;
-  see Note [TyVar/TyVar orientation].)
-
-* (UNTOUCHABLE) Untouchability.  When considering (alpha[n] ~ ty), how
-  do we know whether there are any given equalities between level n
-  and the ambient level?  We answer in two ways:
-
-  * In the eager unifier, we only unify if l=n.  If not, alpha may be
-    untouchable, and defer to the constraint solver.  This check is
-    made in GHC.Tc.Utils.uUnifilledVar2, in the guard
-    isTouchableMetaTyVar.
-
-  * In the constraint solver, we track where Given equalities occur
-    and use that to guard unification in GHC.Tc.Solver.Canonical.touchabilityTest
-    More details in Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet
-
-    Historical note: in the olden days (pre 2021) the constraint solver
-    also used to unify only if l=n.  Equalities were "floated" out of the
-    implication in a separate step, so that they would become touchable.
-    But the float/don't-float question turned out to be very delicate,
-    as you can see if you look at the long series of Notes associated with
-    GHC.Tc.Solver.floatEqualities, around Nov 2020.  It's much easier
-    to unify in-place, with no floating.
-
-Note [TyVar/TyVar orientation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See also Note [Fundeps with instances, and equality orientation]
-where the kind equality orientation is important
-
-Given (a ~ b), should we orient the CEqCan as (a~b) or (b~a)?
-This is a surprisingly tricky question! This is invariant (TyEq:TV).
-
-The question is answered by swapOverTyVars, which is used
-  - in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1
-  - in the constraint solver, in GHC.Tc.Solver.Canonical.canEqCanLHS2
-
-First note: only swap if you have to!
-   See Note [Avoid unnecessary swaps]
-
-So we look for a positive reason to swap, using a three-step test:
-
-* Level comparison. If 'a' has deeper level than 'b',
-  put 'a' on the left.  See Note [Deeper level on the left]
-
-* Priority.  If the levels are the same, look at what kind of
-  type variable it is, using 'lhsPriority'.
-
-  Generally speaking we always try to put a MetaTv on the left
-  in preference to SkolemTv or RuntimeUnkTv:
-     a) Because the MetaTv may be touchable and can be unified
-     b) Even if it's not touchable, GHC.Tc.Solver.floatConstraints
-        looks for meta tyvars on the left
-
-  Tie-breaking rules for MetaTvs:
-  - CycleBreakerTv: This is essentially a stand-in for another type;
-       it's untouchable and should have the same priority as a skolem: 0.
-
-  - TyVarTv: These can unify only with another tyvar, but we can't unify
-       a TyVarTv with a TauTv, because then the TyVarTv could (transitively)
-       get a non-tyvar type. So give these a low priority: 1.
-
-  - ConcreteTv: These are like TauTv, except they can only unify with
-    a concrete type. So we want to be able to write to them, but not quite
-    as much as TauTvs: 2.
-
-  - TauTv: This is the common case; we want these on the left so that they
-       can be written to: 3.
-
-  - RuntimeUnkTv: These aren't really meta-variables used in type inference,
-       but just a convenience in the implementation of the GHCi debugger.
-       Eagerly write to these: 4. See Note [RuntimeUnkTv] in
-       GHC.Runtime.Heap.Inspect.
-
-* Names. If the level and priority comparisons are all
-  equal, try to eliminate a TyVar with a System Name in
-  favour of ones with a Name derived from a user type signature
-
-* Age.  At one point in the past we tried to break any remaining
-  ties by eliminating the younger type variable, based on their
-  Uniques.  See Note [Eliminate younger unification variables]
-  (which also explains why we don't do this any more)
-
-Note [Unification variables on the left]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-For wanteds, but not givens, swap (skolem ~ meta-tv) regardless of
-level, so that the unification variable is on the left.
-
-* We /don't/ want this for Givens because if we ave
-    [G] a[2] ~ alpha[1]
-    [W] Bool ~ a[2]
-  we want to rewrite the wanted to Bool ~ alpha[1],
-  so we can float the constraint and solve it.
-
-* But for Wanteds putting the unification variable on
-  the left means an easier job when floating, and when
-  reporting errors -- just fewer cases to consider.
-
-  In particular, we get better skolem-escape messages:
-  see #18114
-
-Note [Deeper level on the left]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The most important thing is that we want to put tyvars with
-the deepest level on the left.  The reason to do so differs for
-Wanteds and Givens, but either way, deepest wins!  Simple.
-
-* Wanteds.  Putting the deepest variable on the left maximise the
-  chances that it's a touchable meta-tyvar which can be solved.
-
-* Givens. Suppose we have something like
-     forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2]
-
-  If we orient the Given a[2] on the left, we'll rewrite the Wanted to
-  (beta[1] ~ b[1]), and that can float out of the implication.
-  Otherwise it can't.  By putting the deepest variable on the left
-  we maximise our changes of eliminating skolem capture.
-
-  See also GHC.Tc.Solver.InertSet Note [Let-bound skolems] for another reason
-  to orient with the deepest skolem on the left.
-
-  IMPORTANT NOTE: this test does a level-number comparison on
-  skolems, so it's important that skolems have (accurate) level
-  numbers.
-
-See #15009 for an further analysis of why "deepest on the left"
-is a good plan.
-
-Note [Avoid unnecessary swaps]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we swap without actually improving matters, we can get an infinite loop.
-Consider
-    work item:  a ~ b
-   inert item:  b ~ c
-We canonicalise the work-item to (a ~ c).  If we then swap it before
-adding to the inert set, we'll add (c ~ a), and therefore kick out the
-inert guy, so we get
-   new work item:  b ~ c
-   inert item:     c ~ a
-And now the cycle just repeats
-
-Historical Note [Eliminate younger unification variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Given a choice of unifying
-     alpha := beta   or   beta := alpha
-we try, if possible, to eliminate the "younger" one, as determined
-by `ltUnique`.  Reason: the younger one is less likely to appear free in
-an existing inert constraint, and hence we are less likely to be forced
-into kicking out and rewriting inert constraints.
-
-This is a performance optimisation only.  It turns out to fix
-#14723 all by itself, but clearly not reliably so!
-
-It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars).
-But, to my surprise, it didn't seem to make any significant difference
-to the compiler's performance, so I didn't take it any further.  Still
-it seemed too nice to discard altogether, so I'm leaving these
-notes.  SLPJ Jan 18.
-
-Note [Prevent unification with type families]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We prevent unification with type families because of an uneasy compromise.
-It's perfectly sound to unify with type families, and it even improves the
-error messages in the testsuite. It also modestly improves performance, at
-least in some cases. But it's disastrous for test case perf/compiler/T3064.
-Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a.
-What do we do? Do we reduce F? Or do we use the given? Hard to know what's
-best. GHC reduces. This is a disaster for T3064, where the type's size
-spirals out of control during reduction. If we prevent
-unification with type families, then the solver happens to use the equality
-before expanding the type family.
-
-It would be lovely in the future to revisit this problem and remove this
-extra, unnecessary check. But we retain it for now as it seems to work
-better in practice.
-
-Revisited in Nov '20, along with removing flattening variables. Problem
-is still present, and the solution is still the same.
-
-Note [Type synonyms and the occur check]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Generally speaking we try to update a variable with type synonyms not
-expanded, which improves later error messages, unless looking
-inside a type synonym may help resolve a spurious occurs check
-error. Consider:
-          type A a = ()
-
-          f :: (A a -> a -> ()) -> ()
-          f = \ _ -> ()
-
-          x :: ()
-          x = f (\ x p -> p x)
-
-We will eventually get a constraint of the form t ~ A t. The ok function above will
-properly expand the type (A t) to just (), which is ok to be unified with t. If we had
-unified with the original type A t, we would lead the type checker into an infinite loop.
-
-Hence, if the occurs check fails for a type synonym application, then (and *only* then),
-the ok function expands the synonym to detect opportunities for occurs check success using
-the underlying definition of the type synonym.
-
-The same applies later on in the constraint interaction code; see GHC.Tc.Solver.Interact,
-function @occ_check_ok@.
-
-Note [Non-TcTyVars in GHC.Tc.Utils.Unify]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Because the same code is now shared between unifying types and unifying
-kinds, we sometimes will see proper TyVars floating around the unifier.
-Example (from test case polykinds/PolyKinds12):
-
-    type family Apply (f :: k1 -> k2) (x :: k1) :: k2
-    type instance Apply g y = g y
-
-When checking the instance declaration, we first *kind-check* the LHS
-and RHS, discovering that the instance really should be
-
-    type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y
-
-During this kind-checking, all the tyvars will be TcTyVars. Then, however,
-as a second pass, we desugar the RHS (which is done in functions prefixed
-with "tc" in GHC.Tc.TyCl"). By this time, all the kind-vars are proper
-TyVars, not TcTyVars, get some kind unification must happen.
-
-Thus, we always check if a TyVar is a TcTyVar before asking if it's a
-meta-tyvar.
-
-This used to not be necessary for type-checking (that is, before * :: *)
-because expressions get desugared via an algorithm separate from
-type-checking (with wrappers, etc.). Types get desugared very differently,
-causing this wibble in behavior seen here.
--}
-
--- | Breaks apart a function kind into its pieces.
-matchExpectedFunKind
-  :: TypedThing     -- ^ type, only for errors
-  -> Arity           -- ^ n: number of desired arrows
-  -> TcKind          -- ^ fun_kind
-  -> TcM Coercion    -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res)
-
-matchExpectedFunKind hs_ty n k = go n k
-  where
-    go 0 k = return (mkNomReflCo k)
-
-    go n k | Just k' <- coreView k = go n k'
-
-    go n k@(TyVarTy kvar)
-      | isMetaTyVar kvar
-      = do { maybe_kind <- readMetaTyVar kvar
-           ; case maybe_kind of
-                Indirect fun_kind -> go n fun_kind
-                Flexi ->             defer n k }
-
-    go n (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res })
-      | isVisibleFunArg af
-      = do { co <- go (n-1) res
-           ; return (mkNakedFunCo1 Nominal af (mkNomReflCo w) (mkNomReflCo arg) co) }
-
-    go n other
-     = defer n other
-
-    defer n k
-      = do { arg_kinds <- newMetaKindVars n
-           ; res_kind  <- newMetaKindVar
-           ; let new_fun = mkVisFunTysMany arg_kinds res_kind
-                 origin  = TypeEqOrigin { uo_actual   = k
-                                        , uo_expected = new_fun
-                                        , uo_thing    = Just hs_ty
-                                        , uo_visible  = True
-                                        }
-           ; uType KindLevel origin k new_fun }
-
-{- *********************************************************************
-*                                                                      *
-                 Equality invariant checking
-*                                                                      *
-********************************************************************* -}
-
-
-{-  Note [Checking for foralls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Unless we have -XImpredicativeTypes (which is a totally unsupported
-feature), we do not want to unify
-    alpha ~ (forall a. a->a) -> Int
-So we look for foralls hidden inside the type, and it's convenient
-to do that at the same time as the occurs check (which looks for
-occurrences of alpha).
-
-However, it's not just a question of looking for foralls /anywhere/!
-Consider
-   (alpha :: forall k. k->*)  ~  (beta :: forall k. k->*)
-This is legal; e.g. dependent/should_compile/T11635.
-
-We don't want to reject it because of the forall in beta's kind, but
-(see Note [Occurrence checking: look inside kinds] in GHC.Core.Type)
-we do need to look in beta's kind.  So we carry a flag saying if a
-'forall' is OK, and switch the flag on when stepping inside a kind.
-
-Why is it OK?  Why does it not count as impredicative polymorphism?
-The reason foralls are bad is because we reply on "seeing" foralls
-when doing implicit instantiation.  But the forall inside the kind is
-fine.  We'll generate a kind equality constraint
-  (forall k. k->*) ~ (forall k. k->*)
-to check that the kinds of lhs and rhs are compatible.  If alpha's
-kind had instead been
-  (alpha :: kappa)
-then this kind equality would rightly complain about unifying kappa
-with (forall k. k->*)
-
--}
-
-----------------
-{-# NOINLINE checkTyVarEq #-}  -- checkTyVarEq becomes big after the `inline` fires
-checkTyVarEq :: TcTyVar -> TcType -> CheckTyEqResult
-checkTyVarEq tv ty
-  = inline checkTypeEq (TyVarLHS tv) ty
-    -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away
-
-{-# NOINLINE checkTyFamEq #-}  -- checkTyFamEq becomes big after the `inline` fires
-checkTyFamEq :: TyCon     -- type function
-             -> [TcType]  -- args, exactly saturated
-             -> TcType    -- RHS
-             -> CheckTyEqResult   -- always drops cteTypeFamily
-checkTyFamEq fun_tc fun_args ty
-  = inline checkTypeEq (TyFamLHS fun_tc fun_args) ty
-    `cterRemoveProblem` cteTypeFamily
-    -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away
-
-checkTypeEq :: CanEqLHS -> TcType -> CheckTyEqResult
--- If cteHasNoProblem (checkTypeEq dflags lhs rhs), then lhs ~ rhs
--- is a canonical CEqCan.
---
--- In particular, this looks for:
---   (a) a forall type (forall a. blah)
---   (b) a predicate type (c => ty)
---   (c) a type family; see Note [Prevent unification with type families]
---   (d) an occurrence of the LHS (occurs check)
---
--- Note that an occurs-check does not mean "definite error".  For example
---   type family F a
---   type instance F Int = Int
--- consider
---   b0 ~ F b0
--- This is perfectly reasonable, if we later get b0 ~ Int.  But we
--- certainly can't unify b0 := F b0
---
--- For (a), (b), and (c) we check only the top level of the type, NOT
--- inside the kinds of variables it mentions, and for (d) see
--- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.
---
--- checkTypeEq is called from
---    * checkTyFamEq, checkTyVarEq (which inline it to specialise away the
---      case-analysis on 'lhs')
---    * checkEqCanLHSFinish, which does not know the form of 'lhs'
-checkTypeEq lhs ty
-  = go ty
-  where
-    impredicative      = cteProblem cteImpredicative
-    type_family        = cteProblem cteTypeFamily
-    insoluble_occurs   = cteProblem cteInsolubleOccurs
-    soluble_occurs     = cteProblem cteSolubleOccurs
-
-    -- The GHCi runtime debugger does its type-matching with
-    -- unification variables that can unify with a polytype
-    -- or a TyCon that would usually be disallowed by bad_tc
-    -- See Note [RuntimeUnkTv] in GHC.Runtime.Heap.Inspect
-    ghci_tv
-      | TyVarLHS tv <- lhs
-      , MetaTv { mtv_info = RuntimeUnkTv } <- tcTyVarDetails tv
-      = True
-
-      | otherwise
-      = False
-
-    go :: TcType -> CheckTyEqResult
-    go (TyVarTy tv')           = go_tv tv'
-    go (TyConApp tc tys)       = go_tc tc tys
-    go (LitTy {})              = cteOK
-    go (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r})
-                               = go w S.<> go a S.<> go r S.<>
-                                 if not ghci_tv && isInvisibleFunArg af
-                                   then impredicative
-                                   else cteOK
-    go (AppTy fun arg) = go fun S.<> go arg
-    go (CastTy ty co)  = go ty  S.<> go_co co
-    go (CoercionTy co) = go_co co
-    go (ForAllTy (Bndr tv' _) ty) = (case lhs of
-      TyVarLHS tv | tv == tv' -> go_occ (tyVarKind tv') S.<> cterClearOccursCheck (go ty)
-                  | otherwise -> go_occ (tyVarKind tv') S.<> go ty
-      _                       -> go ty)
-      S.<>
-      if ghci_tv then cteOK else impredicative
-
-    go_tv :: TcTyVar -> CheckTyEqResult
-      -- this slightly peculiar way of defining this means
-      -- we don't have to evaluate this `case` at every variable
-      -- occurrence
-    go_tv = case lhs of
-      TyVarLHS tv -> \ tv' -> go_occ (tyVarKind tv') S.<>
-                              if tv == tv' then insoluble_occurs else cteOK
-      TyFamLHS {} -> \ _tv' -> cteOK
-           -- See Note [Occurrence checking: look inside kinds] in GHC.Core.Type
-
-     -- For kinds, we only do an occurs check; we do not worry
-     -- about type families or foralls
-     -- See Note [Checking for foralls]
-    go_occ k = cterFromKind $ go k
-
-    go_tc :: TyCon -> [TcType] -> CheckTyEqResult
-      -- this slightly peculiar way of defining this means
-      -- we don't have to evaluate this `case` at every tyconapp
-    go_tc = case lhs of
-      TyVarLHS {} -> \ tc tys -> check_tc tc S.<> go_tc_args tc tys
-      TyFamLHS fam_tc fam_args -> \ tc tys ->
-        if tcEqTyConApps fam_tc fam_args tc tys
-          then insoluble_occurs
-          else check_tc tc S.<> go_tc_args tc tys
-
-      -- just look at arguments, not the tycon itself
-    go_tc_args :: TyCon -> [TcType] -> CheckTyEqResult
-    go_tc_args tc tys | isGenerativeTyCon tc Nominal = foldMap go tys
-                      | otherwise
-                      = let (tf_args, non_tf_args) = splitAt (tyConArity tc) tys in
-                        cterSetOccursCheckSoluble (foldMap go tf_args) S.<> foldMap go non_tf_args
-
-     -- no bother about impredicativity in coercions, as they're
-     -- inferred
-    go_co co | TyVarLHS tv <- lhs
-             , tv `elemVarSet` tyCoVarsOfCo co
-             = soluble_occurs
-
-        -- Don't check coercions for type families; see commentary at top of function
-             | otherwise
-             = cteOK
-
-    check_tc :: TyCon -> CheckTyEqResult
-    check_tc
-      | ghci_tv   = \ _tc -> cteOK
-      | otherwise = \ tc  -> (if isTauTyCon tc then cteOK else impredicative) S.<>
-                             (if isFamFreeTyCon tc then cteOK else type_family)
diff --git a/compiler/GHC/Tc/Utils/Unify.hs-boot b/compiler/GHC/Tc/Utils/Unify.hs-boot
deleted file mode 100644
--- a/compiler/GHC/Tc/Utils/Unify.hs-boot
+++ /dev/null
@@ -1,17 +0,0 @@
-module GHC.Tc.Utils.Unify where
-
-import GHC.Prelude
-import GHC.Core.Type         ( Mult )
-import GHC.Tc.Utils.TcType   ( TcTauType )
-import GHC.Tc.Types          ( TcM )
-import GHC.Tc.Types.Evidence ( TcCoercion, HsWrapper )
-import GHC.Tc.Types.Origin   ( CtOrigin, TypedThing )
-
-
--- This boot file exists only to tie the knot between
---   GHC.Tc.Utils.Unify and GHC.Tc.Utils.Instantiate
-
-unifyType :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion
-unifyKind :: Maybe TypedThing -> TcTauType -> TcTauType -> TcM TcCoercion
-
-tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ /dev/null
@@ -1,1930 +0,0 @@
-
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies     #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The AQUA Project, Glasgow University, 1996-1998
-
--}
-
--- | Specialisations of the @HsSyn@ syntax for the typechecker
---
--- This module is an extension of @HsSyn@ syntax, for use in the type checker.
-module GHC.Tc.Utils.Zonk (
-        -- * Other HsSyn functions
-        mkHsDictLet, mkHsApp,
-        mkHsAppTy, mkHsCaseAlt,
-        tcShortCutLit, shortCutLit, hsOverLitName,
-        conLikeResTy,
-
-        -- * re-exported from TcMonad
-        TcId, TcIdSet,
-
-        -- * Zonking
-        -- | For a description of "zonking", see Note [What is zonking?]
-        -- in "GHC.Tc.Utils.TcMType"
-        zonkTopDecls, zonkTopExpr, zonkTopLExpr,
-        zonkTopBndrs,
-        ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv,
-        zonkTyVarBindersX, zonkTyVarBinderX,
-        zonkTyBndrs, zonkTyBndrsX,
-        zonkTcTypeToType,  zonkTcTypeToTypeX,
-        zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX,
-        zonkTyVarOcc,
-        zonkCoToCo,
-        zonkEvBinds, zonkTcEvBinds,
-        zonkTcMethInfoToMethInfoX,
-        lookupTyVarX
-  ) where
-
-import GHC.Prelude
-
-import GHC.Platform
-
-import GHC.Builtin.Types
-import GHC.Builtin.Names
-
-import GHC.Hs
-
-import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice)
-import GHC.Tc.Utils.Monad
-import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo )
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.TcMType
-import GHC.Tc.Utils.Env   ( tcLookupGlobalOnly )
-import GHC.Tc.Types.Evidence
-
-import GHC.Core.TyCo.Ppr     ( pprTyVar )
-import GHC.Core.TyCon
-import GHC.Core.Type
-import GHC.Core.Coercion
-import GHC.Core.ConLike
-import GHC.Core.DataCon
-
-import GHC.Utils.Outputable
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Panic.Plain
-
-import GHC.Core.Multiplicity
-import GHC.Core
-import GHC.Core.Predicate
-
-import GHC.Types.Name
-import GHC.Types.Name.Env
-import GHC.Types.Var
-import GHC.Types.Var.Env
-import GHC.Types.Id
-import GHC.Types.TypeEnv
-import GHC.Types.SourceText
-import GHC.Types.Basic
-import GHC.Types.SrcLoc
-import GHC.Types.Unique.FM
-import GHC.Types.TyThing
-import GHC.Driver.Session( getDynFlags, targetPlatform )
-
-import GHC.Data.Maybe
-import GHC.Data.Bag
-
-import Control.Monad
-import Data.List  ( partition )
-import Control.Arrow ( second )
-
-{- *********************************************************************
-*                                                                      *
-         Short-cuts for overloaded numeric literals
-*                                                                      *
-********************************************************************* -}
-
--- Overloaded literals. Here mainly because it uses isIntTy etc
-
-{- Note [Short cut for overloaded literals]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A literal like "3" means (fromInteger @ty (dNum :: Num ty) (3::Integer)).
-But if we have a list like
-  [4,2,3,2,4,4,2]::[Int]
-we use a lot of compile time and space generating and solving all those Num
-constraints, and generating calls to fromInteger etc.  Better just to cut to
-the chase, and cough up an Int literal. Large collections of literals like this
-sometimes appear in source files, so it's quite a worthwhile fix.
-
-So we try to take advantage of whatever nearby type information we have,
-to short-cut the process for built-in types.  We can do this in two places;
-
-* In the typechecker, when we are about to typecheck the literal.
-* If that fails, in the desugarer, once we know the final type.
--}
-
-tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc))
-tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = OverLitRn rebindable _}) exp_res_ty
-  | not rebindable
-  , Just res_ty <- checkingExpType_maybe exp_res_ty
-  = do { dflags <- getDynFlags
-       ; let platform = targetPlatform dflags
-       ; case shortCutLit platform val res_ty of
-            Just expr -> return $ Just $
-                         lit { ol_ext = OverLitTc False expr res_ty }
-            Nothing   -> return Nothing }
-  | otherwise
-  = return Nothing
-
-shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc)
-shortCutLit platform val res_ty
-  = case val of
-      HsIntegral int_lit    -> go_integral int_lit
-      HsFractional frac_lit -> go_fractional frac_lit
-      HsIsString s src      -> go_string   s src
-  where
-    go_integral int@(IL src neg i)
-      | isIntTy res_ty  && platformInIntRange  platform i
-      = Just (HsLit noAnn (HsInt noExtField int))
-      | isWordTy res_ty && platformInWordRange platform i
-      = Just (mkLit wordDataCon (HsWordPrim src i))
-      | isIntegerTy res_ty
-      = Just (HsLit noAnn (HsInteger src i res_ty))
-      | otherwise
-      = go_fractional (integralFractionalLit neg i)
-        -- The 'otherwise' case is important
-        -- Consider (3 :: Float).  Syntactically it looks like an IntLit,
-        -- so we'll call shortCutIntLit, but of course it's a float
-        -- This can make a big difference for programs with a lot of
-        -- literals, compiled without -O
-
-    go_fractional f
-      | isFloatTy res_ty && valueInRange  = Just (mkLit floatDataCon  (HsFloatPrim noExtField f))
-      | isDoubleTy res_ty && valueInRange = Just (mkLit doubleDataCon (HsDoublePrim noExtField f))
-      | otherwise                         = Nothing
-      where
-        valueInRange =
-          case f of
-            FL { fl_exp = e } -> (-100) <= e && e <= 100
-            -- We limit short-cutting Fractional Literals to when their power of 10
-            -- is less than 100, which ensures desugaring isn't slow.
-
-    go_string src s
-      | isStringTy res_ty = Just (HsLit noAnn (HsString src s))
-      | otherwise         = Nothing
-
-mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
-mkLit con lit = HsApp noComments (nlHsDataCon con) (nlHsLit lit)
-
-------------------------------
-hsOverLitName :: OverLitVal -> Name
--- Get the canonical 'fromX' name for a particular OverLitVal
-hsOverLitName (HsIntegral {})   = fromIntegerName
-hsOverLitName (HsFractional {}) = fromRationalName
-hsOverLitName (HsIsString {})   = fromStringName
-
-{-
-************************************************************************
-*                                                                      *
-\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
-*                                                                      *
-************************************************************************
-
-The rest of the zonking is done *after* typechecking.
-The main zonking pass runs over the bindings
-
- a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
- b) convert unbound TcTyVar to Void
- c) convert each TcId to an Id by zonking its type
-
-The type variables are converted by binding mutable tyvars to immutable ones
-and then zonking as normal.
-
-The Ids are converted by binding them in the normal Tc envt; that
-way we maintain sharing; eg an Id is zonked at its binding site and they
-all occurrences of that Id point to the common zonked copy
-
-It's all pretty boring stuff, because HsSyn is such a large type, and
-the environment manipulation is tiresome.
--}
-
--- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType.
-
--- | See Note [The ZonkEnv]
--- Confused by zonking? See Note [What is zonking?] in "GHC.Tc.Utils.TcMType".
-data ZonkEnv  -- See Note [The ZonkEnv]
-  = ZonkEnv { ze_flexi  :: ZonkFlexi
-            , ze_tv_env :: TyCoVarEnv TyCoVar
-            , ze_id_env :: IdEnv      Id
-            , ze_meta_tv_env :: TcRef (TyVarEnv Type) }
-
-{- Note [The ZonkEnv]
-~~~~~~~~~~~~~~~~~~~~~
-* ze_flexi :: ZonkFlexi says what to do with a
-  unification variable that is still un-unified.
-  See Note [Un-unified unification variables]
-
-* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site
-  of a tyvar or covar, we zonk the kind right away and add a mapping
-  to the env. This prevents re-zonking the kind at every
-  occurrence. But this is *just* an optimisation.
-
-* ze_id_env : IdEnv Id promotes sharing among Ids, by making all
-  occurrences of the Id point to a single zonked copy, built at the
-  binding site.
-
-  Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec.
-  In a mutually recursive group
-     rec { f = ...g...; g = ...f... }
-  we want the occurrence of g to point to the one zonked Id for g,
-  and the same for f.
-
-  Because it is knot-tied, we must be careful to consult it lazily.
-  Specifically, zonkIdOcc is not monadic.
-
-* ze_meta_tv_env: see Note [Sharing when zonking to Type]
-
-
-Notes:
-  * We must be careful never to put coercion variables (which are Ids,
-    after all) in the knot-tied ze_id_env, because coercions can
-    appear in types, and we sometimes inspect a zonked type in this
-    module.  [Question: where, precisely?]
-
-  * In zonkTyVarOcc we consult ze_tv_env in a monadic context,
-    a second reason that ze_tv_env can't be monadic.
-
-  * An obvious suggestion would be to have one VarEnv Var to
-    replace both ze_id_env and ze_tv_env, but that doesn't work
-    because of the knot-tying stuff mentioned above.
-
-Note [Un-unified unification variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What should we do if we find a Flexi unification variable?
-There are three possibilities:
-
-* DefaultFlexi: this is the common case, in situations like
-     length @alpha ([] @alpha)
-  It really doesn't matter what type we choose for alpha.  But
-  we must choose a type!  We can't leave mutable unification
-  variables floating around: after typecheck is complete, every
-  type variable occurrence must have a binding site.
-
-  So we default it to 'Any' of the right kind.
-
-  All this works for both type and kind variables (indeed
-  the two are the same thing).
-
-* SkolemiseFlexi: is a special case for the LHS of RULES.
-  See Note [Zonking the LHS of a RULE]
-
-* RuntimeUnkFlexi: is a special case for the GHCi debugger.
-  It's a way to have a variable that is not a mutable
-  unification variable, but doesn't have a binding site
-  either.
-
-* NoFlexi: See Note [Error on unconstrained meta-variables]
-  in GHC.Tc.Utils.TcMType. This mode will panic on unfilled
-  meta-variables.
--}
-
-data ZonkFlexi   -- See Note [Un-unified unification variables]
-  = DefaultFlexi    -- Default unbound unification variables to Any
-  | SkolemiseFlexi  -- Skolemise unbound unification variables
-                    -- See Note [Zonking the LHS of a RULE]
-  | RuntimeUnkFlexi -- Used in the GHCi debugger
-  | NoFlexi         -- Panic on unfilled meta-variables
-                    -- See Note [Error on unconstrained meta-variables]
-                    -- in GHC.Tc.Utils.TcMType
-
-instance Outputable ZonkEnv where
-  ppr (ZonkEnv { ze_tv_env = tv_env
-               , ze_id_env = id_env })
-    = text "ZE" <+> braces (vcat
-         [ text "ze_tv_env =" <+> ppr tv_env
-         , text "ze_id_env =" <+> ppr id_env ])
-
--- The EvBinds have to already be zonked, but that's usually the case.
-emptyZonkEnv :: TcM ZonkEnv
-emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi
-
-mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv
-mkEmptyZonkEnv flexi
-  = do { mtv_env_ref <- newTcRef emptyVarEnv
-       ; return (ZonkEnv { ze_flexi = flexi
-                         , ze_tv_env = emptyVarEnv
-                         , ze_id_env = emptyVarEnv
-                         , ze_meta_tv_env = mtv_env_ref }) }
-
-initZonkEnv :: (ZonkEnv -> TcM b) -> TcM b
-initZonkEnv thing_inside = do { ze <- mkEmptyZonkEnv DefaultFlexi
-                              ; thing_inside ze }
-
--- | Extend the knot-tied environment.
-extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv
-extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids
-    -- NB: Don't look at the var to decide which env't to put it in. That
-    -- would end up knot-tying all the env'ts.
-  = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] }
-  -- Given coercion variables will actually end up here. That's OK though:
-  -- coercion variables are never looked up in the knot-tied env't, so zonking
-  -- them simply doesn't get optimised. No one gets hurt. An improvement (?)
-  -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the
-  -- recursive groups. But perhaps the time it takes to do the analysis is
-  -- more than the savings.
-
-extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
-extendZonkEnv ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) vars
-  = ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars]
-       , ze_id_env = extendVarEnvList id_env   [(id,id) | id <- ids] }
-  where
-    (tycovars, ids) = partition isTyCoVar vars
-
-extendIdZonkEnv :: ZonkEnv -> Var -> ZonkEnv
-extendIdZonkEnv ze@(ZonkEnv { ze_id_env = id_env }) id
-  = ze { ze_id_env = extendVarEnv id_env id id }
-
-extendTyZonkEnv :: ZonkEnv -> TyVar -> ZonkEnv
-extendTyZonkEnv ze@(ZonkEnv { ze_tv_env = ty_env }) tv
-  = ze { ze_tv_env = extendVarEnv ty_env tv tv }
-
-setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv
-setZonkType ze flexi = ze { ze_flexi = flexi }
-
-zonkEnvIds :: ZonkEnv -> TypeEnv
-zonkEnvIds (ZonkEnv { ze_id_env = id_env})
-  = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]
-  -- It's OK to use nonDetEltsUFM here because we forget the ordering
-  -- immediately by creating a TypeEnv
-
-zonkLIdOcc :: ZonkEnv -> LocatedN TcId -> LocatedN Id
-zonkLIdOcc env = fmap (zonkIdOcc env)
-
-zonkIdOcc :: ZonkEnv -> TcId -> Id
--- Ids defined in this module should be in the envt;
--- ignore others.  (Actually, data constructors are also
--- not LocalVars, even when locally defined, but that is fine.)
--- (Also foreign-imported things aren't currently in the ZonkEnv;
---  that's ok because they don't need zonking.)
---
--- Actually, Template Haskell works in 'chunks' of declarations, and
--- an earlier chunk won't be in the 'env' that the zonking phase
--- carries around.  Instead it'll be in the tcg_gbl_env, already fully
--- zonked.  There's no point in looking it up there (except for error
--- checking), and it's not conveniently to hand; hence the simple
--- 'orElse' case in the LocalVar branch.
---
--- Even without template splices, in module Main, the checking of
--- 'main' is done as a separate chunk.
-zonkIdOcc (ZonkEnv { ze_id_env = id_env}) id
-  | isLocalVar id = lookupVarEnv id_env id `orElse`
-                    id
-  | otherwise     = id
-
-zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
-zonkIdOccs env ids = map (zonkIdOcc env) ids
-
--- zonkIdBndr is used *after* typechecking to get the Id's type
--- to its final form.  The TyVarEnv give
-zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
-zonkIdBndr env v
-  = do Scaled w' ty' <- zonkScaledTcTypeToTypeX env (idScaledType v)
-       return (setIdMult (setIdType v ty') w')
-
-zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
-zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
-
-zonkTopBndrs :: [TcId] -> TcM [Id]
-zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids
-
-zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTc -> TcM (FieldOcc GhcTc)
-zonkFieldOcc env (FieldOcc sel lbl)
-  = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel
-
-zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
-zonkEvBndrsX = mapAccumLM zonkEvBndrX
-
-zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
--- Works for dictionaries and coercions
-zonkEvBndrX env var
-  = do { var' <- zonkEvBndr env var
-       ; return (extendZonkEnv env [var'], var') }
-
-zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
--- Works for dictionaries and coercions
--- Does not extend the ZonkEnv
-zonkEvBndr env var
-  = updateIdTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX env) var
-
-{-
-zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm
-zonkEvVarOcc env v
-  | isCoVar v
-  = EvCoercion <$> zonkCoVarOcc env v
-  | otherwise
-  = return (EvId $ zonkIdOcc env v)
--}
-
-zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var)
-zonkCoreBndrX env v
-  | isId v = do { v' <- zonkIdBndr env v
-                ; return (extendIdZonkEnv env v', v') }
-  | otherwise = zonkTyBndrX env v
-
-zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])
-zonkCoreBndrsX = mapAccumLM zonkCoreBndrX
-
-zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar])
-zonkTyBndrs tvs = initZonkEnv $ \ze -> zonkTyBndrsX ze tvs
-
-zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
-zonkTyBndrsX = mapAccumLM zonkTyBndrX
-
-zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
--- This guarantees to return a TyVar (not a TcTyVar)
--- then we add it to the envt, so all occurrences are replaced
---
--- It does not clone: the new TyVar has the sane Name
--- as the old one.  This important when zonking the
--- TyVarBndrs of a TyCon, whose Names may scope.
-zonkTyBndrX env tv
-  = assertPpr (isImmutableTyVar tv) (ppr tv <+> dcolon <+> ppr (tyVarKind tv)) $
-    do { ki <- zonkTcTypeToTypeX env (tyVarKind tv)
-               -- Internal names tidy up better, for iface files.
-       ; let tv' = mkTyVar (tyVarName tv) ki
-       ; return (extendTyZonkEnv env tv', tv') }
-
-zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis]
-                             -> TcM (ZonkEnv, [VarBndr TyVar vis])
-zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
-
-zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis
-                            -> TcM (ZonkEnv, VarBndr TyVar vis)
--- Takes a TcTyVar and guarantees to return a TyVar
-zonkTyVarBinderX env (Bndr tv vis)
-  = do { (env', tv') <- zonkTyBndrX env tv
-       ; return (env', Bndr tv' vis) }
-
-zonkTopExpr :: HsExpr GhcTc -> TcM (HsExpr GhcTc)
-zonkTopExpr e = initZonkEnv $ \ ze -> zonkExpr ze e
-
-zonkTopLExpr :: LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
-zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e
-
-zonkTopDecls :: Bag EvBind
-             -> LHsBinds GhcTc
-             -> [LRuleDecl GhcTc] -> [LTcSpecPrag]
-             -> [LForeignDecl GhcTc]
-             -> TcM (TypeEnv,
-                     Bag EvBind,
-                     LHsBinds GhcTc,
-                     [LForeignDecl GhcTc],
-                     [LTcSpecPrag],
-                     [LRuleDecl    GhcTc])
-zonkTopDecls ev_binds binds rules imp_specs fords
-  = do  { (env1, ev_binds') <- initZonkEnv $ \ ze -> zonkEvBinds ze ev_binds
-        ; (env2, binds')    <- zonkRecMonoBinds env1 binds
-                        -- Top level is implicitly recursive
-        ; rules' <- zonkRules env2 rules
-        ; specs' <- zonkLTcSpecPrags env2 imp_specs
-        ; fords' <- zonkForeignExports env2 fords
-        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
-
----------------------------------------------
-zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTc
-               -> TcM (ZonkEnv, HsLocalBinds GhcTc)
-zonkLocalBinds env (EmptyLocalBinds x)
-  = return (env, (EmptyLocalBinds x))
-
-zonkLocalBinds _ (HsValBinds _ (ValBinds {}))
-  = panic "zonkLocalBinds" -- Not in typechecker output
-
-zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
-  = do  { (env1, new_binds) <- go env binds
-        ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }
-  where
-    go env []
-      = return (env, [])
-    go env ((r,b):bs)
-      = do { (env1, b')  <- zonkRecMonoBinds env b
-           ; (env2, bs') <- go env1 bs
-           ; return (env2, (r,b'):bs') }
-
-zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do
-    new_binds <- mapM (wrapLocMA zonk_ip_bind) binds
-    let
-        env1 = extendIdZonkEnvRec env
-                 [ n | (L _ (IPBind n _ _)) <- new_binds]
-    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
-    return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))
-  where
-    zonk_ip_bind (IPBind dict_id n e)
-        = do dict_id' <- zonkIdBndr env dict_id
-             e' <- zonkLExpr env e
-             return (IPBind dict_id' n e')
-
----------------------------------------------
-zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc)
-zonkRecMonoBinds env binds
- = fixM (\ ~(_, new_binds) -> do
-        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders CollNoDictBinders new_binds)
-        ; binds' <- zonkMonoBinds env1 binds
-        ; return (env1, binds') })
-
----------------------------------------------
-zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (LHsBinds GhcTc)
-zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
-
-zonk_lbind :: ZonkEnv -> LHsBind GhcTc -> TcM (LHsBind GhcTc)
-zonk_lbind env = wrapLocMA (zonk_bind env)
-
-zonk_bind :: ZonkEnv -> HsBind GhcTc -> TcM (HsBind GhcTc)
-zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss
-                            , pat_ext = (ty, ticks)})
-  = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
-        ; new_grhss <- zonkGRHSs env zonkLExpr grhss
-        ; new_ty    <- zonkTcTypeToTypeX env ty
-        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss
-                       , pat_ext = (new_ty, ticks) }) }
-
-zonk_bind env (VarBind { var_ext = x
-                       , var_id = var, var_rhs = expr })
-  = do { new_var  <- zonkIdBndr env var
-       ; new_expr <- zonkLExpr env expr
-       ; return (VarBind { var_ext = x
-                         , var_id = new_var
-                         , var_rhs = new_expr }) }
-
-zonk_bind env bind@(FunBind { fun_id = L loc var
-                            , fun_matches = ms
-                            , fun_ext = (co_fn, ticks) })
-  = do { new_var <- zonkIdBndr env var
-       ; (env1, new_co_fn) <- zonkCoFn env co_fn
-       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
-       ; return (bind { fun_id = L loc new_var
-                      , fun_matches = new_ms
-                      , fun_ext = (new_co_fn, ticks) }) }
-
-zonk_bind env (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
-                                    , abs_ev_binds = ev_binds
-                                    , abs_exports = exports
-                                    , abs_binds = val_binds
-                                    , abs_sig = has_sig }))
-  = assert ( all isImmutableTyVar tyvars ) $
-    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
-       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
-       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
-       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
-         do { let env3 = extendIdZonkEnvRec env2 $
-                         collectHsBindsBinders CollNoDictBinders new_val_binds
-            ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds
-            ; new_exports   <- mapM (zonk_export env3) exports
-            ; return (new_val_binds, new_exports) }
-       ; return $ XHsBindsLR $
-                 AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs
-                          , abs_ev_binds = new_ev_binds
-                          , abs_exports = new_exports, abs_binds = new_val_bind
-                          , abs_sig = has_sig } }
-  where
-    zonk_val_bind env lbind
-      | has_sig
-      , (L loc bind@(FunBind { fun_id      = (L mloc mono_id)
-                             , fun_matches = ms
-                             , fun_ext     = (co_fn, ticks) })) <- lbind
-      = do { new_mono_id <- updateIdTypeAndMultM (zonkTcTypeToTypeX env) mono_id
-                            -- Specifically /not/ zonkIdBndr; we do not want to
-                            -- complain about a representation-polymorphic binder
-           ; (env', new_co_fn) <- zonkCoFn env co_fn
-           ; new_ms            <- zonkMatchGroup env' zonkLExpr ms
-           ; return $ L loc $
-             bind { fun_id      = L mloc new_mono_id
-                  , fun_matches = new_ms
-                  , fun_ext     = (new_co_fn, ticks) } }
-      | otherwise
-      = zonk_lbind env lbind   -- The normal case
-
-    zonk_export :: ZonkEnv -> ABExport -> TcM ABExport
-    zonk_export env (ABE{ abe_wrap = wrap
-                        , abe_poly = poly_id
-                        , abe_mono = mono_id
-                        , abe_prags = prags })
-        = do new_poly_id <- zonkIdBndr env poly_id
-             (_, new_wrap) <- zonkCoFn env wrap
-             new_prags <- zonkSpecPrags env prags
-             return (ABE{ abe_wrap = new_wrap
-                        , abe_poly = new_poly_id
-                        , abe_mono = zonkIdOcc env mono_id
-                        , abe_prags = new_prags })
-
-zonk_bind env (PatSynBind x bind@(PSB { psb_id = L loc id
-                                      , psb_args = details
-                                      , psb_def = lpat
-                                      , psb_dir = dir }))
-  = do { id' <- zonkIdBndr env id
-       ; (env1, lpat') <- zonkPat env lpat
-       ; details' <- zonkPatSynDetails env1 details
-       ; (_env2, dir') <- zonkPatSynDir env1 dir
-       ; return $ PatSynBind x $
-                  bind { psb_id = L loc id'
-                       , psb_args = details'
-                       , psb_def = lpat'
-                       , psb_dir = dir' } }
-
-zonkPatSynDetails :: ZonkEnv
-                  -> HsPatSynDetails GhcTc
-                  -> TcM (HsPatSynDetails GhcTc)
-zonkPatSynDetails env (PrefixCon _ as)
-  = pure $ PrefixCon noTypeArgs (map (zonkLIdOcc env) as)
-zonkPatSynDetails env (InfixCon a1 a2)
-  = pure $ InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2)
-zonkPatSynDetails env (RecCon flds)
-  = RecCon <$> mapM (zonkPatSynField env) flds
-
-zonkPatSynField :: ZonkEnv -> RecordPatSynField GhcTc -> TcM (RecordPatSynField GhcTc)
-zonkPatSynField env (RecordPatSynField x y) =
-    RecordPatSynField <$> zonkFieldOcc env x <*> pure (zonkLIdOcc env y)
-
-zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTc
-              -> TcM (ZonkEnv, HsPatSynDir GhcTc)
-zonkPatSynDir env Unidirectional        = return (env, Unidirectional)
-zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
-zonkPatSynDir env (ExplicitBidirectional mg) = do
-    mg' <- zonkMatchGroup env zonkLExpr mg
-    return (env, ExplicitBidirectional mg')
-
-zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
-zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
-zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
-                                       ; return (SpecPrags ps') }
-
-zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
-zonkLTcSpecPrags env ps
-  = mapM zonk_prag ps
-  where
-    zonk_prag (L loc (SpecPrag id co_fn inl))
-        = do { (_, co_fn') <- zonkCoFn env co_fn
-             ; return (L loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
-
-{-
-************************************************************************
-*                                                                      *
-\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
-*                                                                      *
-************************************************************************
--}
-
-zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
-            => ZonkEnv
-            -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-            -> MatchGroup GhcTc (LocatedA (body GhcTc))
-            -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
-zonkMatchGroup env zBody (MG { mg_alts = L l ms
-                             , mg_ext = MatchGroupTc arg_tys res_ty origin
-                             })
-  = do  { ms' <- mapM (zonkMatch env zBody) ms
-        ; arg_tys' <- zonkScaledTcTypesToTypesX env arg_tys
-        ; res_ty'  <- zonkTcTypeToTypeX env res_ty
-        ; return (MG { mg_alts = L l ms'
-                     , mg_ext = MatchGroupTc arg_tys' res_ty' origin
-                     }) }
-
-zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
-          => ZonkEnv
-          -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-          -> LMatch GhcTc (LocatedA (body GhcTc))
-          -> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
-zonkMatch env zBody (L loc match@(Match { m_pats = pats
-                                        , m_grhss = grhss }))
-  = do  { (env1, new_pats) <- zonkPats env pats
-        ; new_grhss <- zonkGRHSs env1 zBody grhss
-        ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
-
--------------------------------------------------------------------------
-zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
-          => ZonkEnv
-          -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-          -> GRHSs GhcTc (LocatedA (body GhcTc))
-          -> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
-
-zonkGRHSs env zBody (GRHSs x grhss binds) = do
-    (new_env, new_binds) <- zonkLocalBinds env binds
-    let
-        zonk_grhs (GRHS xx guarded rhs)
-          = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
-               new_rhs <- zBody env2 rhs
-               return (GRHS xx new_guarded new_rhs)
-    new_grhss <- mapM (wrapLocMA zonk_grhs) grhss
-    return (GRHSs x new_grhss new_binds)
-
-{-
-************************************************************************
-*                                                                      *
-\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
-*                                                                      *
-************************************************************************
--}
-
-zonkLExprs :: ZonkEnv -> [LHsExpr GhcTc] -> TcM [LHsExpr GhcTc]
-zonkLExpr  :: ZonkEnv -> LHsExpr GhcTc   -> TcM (LHsExpr GhcTc)
-zonkExpr   :: ZonkEnv -> HsExpr GhcTc    -> TcM (HsExpr GhcTc)
-
-zonkLExprs env exprs = mapM (zonkLExpr env) exprs
-zonkLExpr  env expr  = wrapLocMA (zonkExpr env) expr
-
-zonkExpr env (HsVar x (L l id))
-  = assertPpr (isNothing (isDataConId_maybe id)) (ppr id) $
-    return (HsVar x (L l (zonkIdOcc env id)))
-
-zonkExpr env (HsUnboundVar her occ)
-  = do her' <- zonk_her her
-       return (HsUnboundVar her' occ)
-  where
-    zonk_her :: HoleExprRef -> TcM HoleExprRef
-    zonk_her (HER ref ty u)
-      = do updMutVarM ref (zonkEvTerm env)
-           ty'  <- zonkTcTypeToTypeX env ty
-           return (HER ref ty' u)
-
-zonkExpr env (HsRecSel _ (FieldOcc v occ))
-  = return (HsRecSel noExtField (FieldOcc (zonkIdOcc env v) occ))
-
-zonkExpr _ (HsIPVar x _) = dataConCantHappen x
-
-zonkExpr _ (HsOverLabel x _) = dataConCantHappen x
-
-zonkExpr env (HsLit x (HsRat e f ty))
-  = do new_ty <- zonkTcTypeToTypeX env ty
-       return (HsLit x (HsRat e f new_ty))
-
-zonkExpr _ (HsLit x lit)
-  = return (HsLit x lit)
-
-zonkExpr env (HsOverLit x lit)
-  = do  { lit' <- zonkOverLit env lit
-        ; return (HsOverLit x lit') }
-
-zonkExpr env (HsLam x matches)
-  = do new_matches <- zonkMatchGroup env zonkLExpr matches
-       return (HsLam x new_matches)
-
-zonkExpr env (HsLamCase x lc_variant matches)
-  = do new_matches <- zonkMatchGroup env zonkLExpr matches
-       return (HsLamCase x lc_variant new_matches)
-
-zonkExpr env (HsApp x e1 e2)
-  = do new_e1 <- zonkLExpr env e1
-       new_e2 <- zonkLExpr env e2
-       return (HsApp x new_e1 new_e2)
-
-zonkExpr env (HsAppType ty e at t)
-  = do new_e <- zonkLExpr env e
-       new_ty <- zonkTcTypeToTypeX env ty
-       return (HsAppType new_ty new_e at t)
-       -- NB: the type is an HsType; can't zonk that!
-
-zonkExpr env (HsTypedBracket hsb_tc body)
-  = (\x -> HsTypedBracket x body) <$> zonkBracket env hsb_tc
-
-zonkExpr env (HsUntypedBracket hsb_tc body)
-  = (\x -> HsUntypedBracket x body) <$> zonkBracket env hsb_tc
-
-zonkExpr env (HsTypedSplice s _) = runTopSplice s >>= zonkExpr env
-
-zonkExpr _ e@(HsUntypedSplice _ _) = pprPanic "zonkExpr: HsUntypedSplice" (ppr e)
-
-zonkExpr _ (OpApp x _ _ _) = dataConCantHappen x
-
-zonkExpr env (NegApp x expr op)
-  = do (env', new_op) <- zonkSyntaxExpr env op
-       new_expr <- zonkLExpr env' expr
-       return (NegApp x new_expr new_op)
-
-zonkExpr env (HsPar x lpar e rpar)
-  = do new_e <- zonkLExpr env e
-       return (HsPar x lpar new_e rpar)
-
-zonkExpr _ (SectionL x _ _) = dataConCantHappen x
-zonkExpr _ (SectionR x _ _) = dataConCantHappen x
-zonkExpr env (ExplicitTuple x tup_args boxed)
-  = do { new_tup_args <- mapM zonk_tup_arg tup_args
-       ; return (ExplicitTuple x new_tup_args boxed) }
-  where
-    zonk_tup_arg (Present x e) = do { e' <- zonkLExpr env e
-                                    ; return (Present x e') }
-    zonk_tup_arg (Missing t) = do { t' <- zonkScaledTcTypeToTypeX env t
-                                  ; return (Missing t') }
-
-
-zonkExpr env (ExplicitSum args alt arity expr)
-  = do new_args <- mapM (zonkTcTypeToTypeX env) args
-       new_expr <- zonkLExpr env expr
-       return (ExplicitSum new_args alt arity new_expr)
-
-zonkExpr env (HsCase x expr ms)
-  = do new_expr <- zonkLExpr env expr
-       new_ms <- zonkMatchGroup env zonkLExpr ms
-       return (HsCase x new_expr new_ms)
-
-zonkExpr env (HsIf x e1 e2 e3)
-  = do new_e1 <- zonkLExpr env e1
-       new_e2 <- zonkLExpr env e2
-       new_e3 <- zonkLExpr env e3
-       return (HsIf x new_e1 new_e2 new_e3)
-
-zonkExpr env (HsMultiIf ty alts)
-  = do { alts' <- mapM (wrapLocMA zonk_alt) alts
-       ; ty'   <- zonkTcTypeToTypeX env ty
-       ; return $ HsMultiIf ty' alts' }
-  where zonk_alt (GRHS x guard expr)
-          = do { (env', guard') <- zonkStmts env zonkLExpr guard
-               ; expr'          <- zonkLExpr env' expr
-               ; return $ GRHS x guard' expr' }
-
-zonkExpr env (HsLet x tkLet binds tkIn expr)
-  = do (new_env, new_binds) <- zonkLocalBinds env binds
-       new_expr <- zonkLExpr new_env expr
-       return (HsLet x tkLet new_binds tkIn new_expr)
-
-zonkExpr env (HsDo ty do_or_lc (L l stmts))
-  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
-       new_ty <- zonkTcTypeToTypeX env ty
-       return (HsDo new_ty do_or_lc (L l new_stmts))
-
-zonkExpr env (ExplicitList ty exprs)
-  = do new_ty <- zonkTcTypeToTypeX env ty
-       new_exprs <- zonkLExprs env exprs
-       return (ExplicitList new_ty new_exprs)
-
-zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds })
-  = do  { new_con_expr <- zonkExpr env con_expr
-        ; new_rbinds   <- zonkRecFields env rbinds
-        ; return (expr { rcon_ext  = new_con_expr
-                       , rcon_flds = new_rbinds }) }
-
-zonkExpr env (ExprWithTySig _ e ty)
-  = do { e' <- zonkLExpr env e
-       ; return (ExprWithTySig noExtField e' ty) }
-
-zonkExpr env (ArithSeq expr wit info)
-  = do (env1, new_wit) <- zonkWit env wit
-       new_expr <- zonkExpr env expr
-       new_info <- zonkArithSeq env1 info
-       return (ArithSeq new_expr new_wit new_info)
-   where zonkWit env Nothing    = return (env, Nothing)
-         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
-
-zonkExpr env (HsPragE x prag expr)
-  = do new_expr <- zonkLExpr env expr
-       return (HsPragE x prag new_expr)
-
--- arrow notation extensions
-zonkExpr env (HsProc x pat body)
-  = do  { (env1, new_pat) <- zonkPat env pat
-        ; new_body <- zonkCmdTop env1 body
-        ; return (HsProc x new_pat new_body) }
-
--- StaticPointers extension
-zonkExpr env (HsStatic (fvs, ty) expr)
-  = do new_ty <- zonkTcTypeToTypeX env ty
-       HsStatic (fvs, new_ty) <$> zonkLExpr env expr
-
-zonkExpr env (XExpr (WrapExpr (HsWrap co_fn expr)))
-  = do (env1, new_co_fn) <- zonkCoFn env co_fn
-       new_expr <- zonkExpr env1 expr
-       return (XExpr (WrapExpr (HsWrap new_co_fn new_expr)))
-
-zonkExpr env (XExpr (ExpansionExpr (HsExpanded a b)))
-  = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr env b
-
-zonkExpr env (XExpr (ConLikeTc con tvs tys))
-  = XExpr . ConLikeTc con tvs <$> mapM zonk_scale tys
-  where
-    zonk_scale (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m <*> pure ty
-    -- Only the multiplicity can contain unification variables
-    -- The tvs come straight from the data-con, and so are strictly redundant
-    -- See Wrinkles of Note [Typechecking data constructors] in GHC.Tc.Gen.Head
-
-zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
-
--------------------------------------------------------------------------
-{-
-Note [Skolems in zonkSyntaxExpr]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider rebindable syntax with something like
-
-  (>>=) :: (forall x. blah) -> (forall y. blah') -> blah''
-
-The x and y become skolems that are in scope when type-checking the
-arguments to the bind. This means that we must extend the ZonkEnv with
-these skolems when zonking the arguments to the bind. But the skolems
-are different between the two arguments, and so we should theoretically
-carry around different environments to use for the different arguments.
-
-However, this becomes a logistical nightmare, especially in dealing with
-the more exotic Stmt forms. So, we simplify by making the critical
-assumption that the uniques of the skolems are different. (This assumption
-is justified by the use of newUnique in GHC.Tc.Utils.TcMType.instSkolTyCoVarX.)
-Now, we can safely just extend one environment.
--}
-
--- See Note [Skolems in zonkSyntaxExpr]
-zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTc
-               -> TcM (ZonkEnv, SyntaxExpr GhcTc)
-zonkSyntaxExpr env (SyntaxExprTc { syn_expr      = expr
-                               , syn_arg_wraps = arg_wraps
-                               , syn_res_wrap  = res_wrap })
-  = do { (env0, res_wrap')  <- zonkCoFn env res_wrap
-       ; expr'              <- zonkExpr env0 expr
-       ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps
-       ; return (env1, SyntaxExprTc { syn_expr      = expr'
-                                    , syn_arg_wraps = arg_wraps'
-                                    , syn_res_wrap  = res_wrap' }) }
-zonkSyntaxExpr env NoSyntaxExprTc = return (env, NoSyntaxExprTc)
-
--------------------------------------------------------------------------
-
-zonkLCmd  :: ZonkEnv -> LHsCmd GhcTc   -> TcM (LHsCmd GhcTc)
-zonkCmd   :: ZonkEnv -> HsCmd GhcTc    -> TcM (HsCmd GhcTc)
-
-zonkLCmd  env cmd  = wrapLocMA (zonkCmd env) cmd
-
-zonkCmd env (XCmd (HsWrap w cmd))
-  = do { (env1, w') <- zonkCoFn env w
-       ; cmd' <- zonkCmd env1 cmd
-       ; return (XCmd (HsWrap w' cmd')) }
-zonkCmd env (HsCmdArrApp ty e1 e2 ho rl)
-  = do new_e1 <- zonkLExpr env e1
-       new_e2 <- zonkLExpr env e2
-       new_ty <- zonkTcTypeToTypeX env ty
-       return (HsCmdArrApp new_ty new_e1 new_e2 ho rl)
-
-zonkCmd env (HsCmdArrForm x op f fixity args)
-  = do new_op <- zonkLExpr env op
-       new_args <- mapM (zonkCmdTop env) args
-       return (HsCmdArrForm x new_op f fixity new_args)
-
-zonkCmd env (HsCmdApp x c e)
-  = do new_c <- zonkLCmd env c
-       new_e <- zonkLExpr env e
-       return (HsCmdApp x new_c new_e)
-
-zonkCmd env (HsCmdLam x matches)
-  = do new_matches <- zonkMatchGroup env zonkLCmd matches
-       return (HsCmdLam x new_matches)
-
-zonkCmd env (HsCmdPar x lpar c rpar)
-  = do new_c <- zonkLCmd env c
-       return (HsCmdPar x lpar new_c rpar)
-
-zonkCmd env (HsCmdCase x expr ms)
-  = do new_expr <- zonkLExpr env expr
-       new_ms <- zonkMatchGroup env zonkLCmd ms
-       return (HsCmdCase x new_expr new_ms)
-
-zonkCmd env (HsCmdLamCase x lc_variant ms)
-  = do new_ms <- zonkMatchGroup env zonkLCmd ms
-       return (HsCmdLamCase x lc_variant new_ms)
-
-zonkCmd env (HsCmdIf x eCond ePred cThen cElse)
-  = do { (env1, new_eCond) <- zonkSyntaxExpr env eCond
-       ; new_ePred <- zonkLExpr env1 ePred
-       ; new_cThen <- zonkLCmd env1 cThen
-       ; new_cElse <- zonkLCmd env1 cElse
-       ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) }
-
-zonkCmd env (HsCmdLet x tkLet binds tkIn cmd)
-  = do (new_env, new_binds) <- zonkLocalBinds env binds
-       new_cmd <- zonkLCmd new_env cmd
-       return (HsCmdLet x tkLet new_binds tkIn new_cmd)
-
-zonkCmd env (HsCmdDo ty (L l stmts))
-  = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
-       new_ty <- zonkTcTypeToTypeX env ty
-       return (HsCmdDo new_ty (L l new_stmts))
-
-
-
-zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTc -> TcM (LHsCmdTop GhcTc)
-zonkCmdTop env cmd = wrapLocMA (zonk_cmd_top env) cmd
-
-zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTc -> TcM (HsCmdTop GhcTc)
-zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
-  = do new_cmd <- zonkLCmd env cmd
-       new_stack_tys <- zonkTcTypeToTypeX env stack_tys
-       new_ty <- zonkTcTypeToTypeX env ty
-       new_ids <- mapSndM (zonkExpr env) ids
-
-       massert (isLiftedTypeKind (typeKind new_stack_tys))
-         -- desugarer assumes that this is not representation-polymorphic...
-         -- but indeed it should always be lifted due to the typing
-         -- rules for arrows
-
-       return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)
-
--------------------------------------------------------------------------
-zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
-zonkCoFn env WpHole   = return (env, WpHole)
-zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
-                                    ; (env2, c2') <- zonkCoFn env1 c2
-                                    ; return (env2, WpCompose c1' c2') }
-zonkCoFn env (WpFun c1 c2 t1)  = do { (env1, c1') <- zonkCoFn env c1
-                                    ; (env2, c2') <- zonkCoFn env1 c2
-                                    ; t1'         <- zonkScaledTcTypeToTypeX env2 t1
-                                    ; return (env2, WpFun c1' c2' t1') }
-zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co
-                              ; return (env, WpCast co') }
-zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
-                                 ; return (env', WpEvLam ev') }
-zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg
-                                 ; return (env, WpEvApp arg') }
-zonkCoFn env (WpTyLam tv)   = assert (isImmutableTyVar tv) $
-                              do { (env', tv') <- zonkTyBndrX env tv
-                                 ; return (env', WpTyLam tv') }
-zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToTypeX env ty
-                                 ; return (env, WpTyApp ty') }
-zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
-                                 ; return (env1, WpLet bs') }
-zonkCoFn env (WpMultCoercion co) = do { co' <- zonkCoToCo env co
-                                      ; return (env, WpMultCoercion co') }
-
--------------------------------------------------------------------------
-zonkOverLit :: ZonkEnv -> HsOverLit GhcTc -> TcM (HsOverLit GhcTc)
-zonkOverLit env lit@(OverLit {ol_ext = x@OverLitTc { ol_witness = e, ol_type = ty } })
-  = do  { ty' <- zonkTcTypeToTypeX env ty
-        ; e' <- zonkExpr env e
-        ; return (lit { ol_ext = x { ol_witness = e'
-                                   , ol_type = ty' } }) }
-
--------------------------------------------------------------------------
-zonkBracket :: ZonkEnv -> HsBracketTc -> TcM HsBracketTc
-zonkBracket env (HsBracketTc hsb_thing ty wrap bs)
-  = do wrap' <- traverse zonkQuoteWrap wrap
-       bs' <- mapM (zonk_b env) bs
-       new_ty <- zonkTcTypeToTypeX env ty
-       return (HsBracketTc hsb_thing new_ty wrap' bs')
-  where
-    zonkQuoteWrap (QuoteWrapper ev ty) = do
-        let ev' = zonkIdOcc env ev
-        ty' <- zonkTcTypeToTypeX env ty
-        return (QuoteWrapper ev' ty')
-
-    zonk_b env' (PendingTcSplice n e) = do e' <- zonkLExpr env' e
-                                           return (PendingTcSplice n e')
-
--------------------------------------------------------------------------
-zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTc -> TcM (ArithSeqInfo GhcTc)
-
-zonkArithSeq env (From e)
-  = do new_e <- zonkLExpr env e
-       return (From new_e)
-
-zonkArithSeq env (FromThen e1 e2)
-  = do new_e1 <- zonkLExpr env e1
-       new_e2 <- zonkLExpr env e2
-       return (FromThen new_e1 new_e2)
-
-zonkArithSeq env (FromTo e1 e2)
-  = do new_e1 <- zonkLExpr env e1
-       new_e2 <- zonkLExpr env e2
-       return (FromTo new_e1 new_e2)
-
-zonkArithSeq env (FromThenTo e1 e2 e3)
-  = do new_e1 <- zonkLExpr env e1
-       new_e2 <- zonkLExpr env e2
-       new_e3 <- zonkLExpr env e3
-       return (FromThenTo new_e1 new_e2 new_e3)
-
--------------------------------------------------------------------------
-zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
-          => ZonkEnv
-          -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-          -> [LStmt GhcTc (LocatedA (body GhcTc))]
-          -> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))])
-zonkStmts env _ []     = return (env, [])
-zonkStmts env zBody (s:ss) = do { (env1, s')  <- wrapLocSndMA (zonkStmt env zBody) s
-                                ; (env2, ss') <- zonkStmts env1 zBody ss
-                                ; return (env2, s' : ss') }
-
-zonkStmt :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
-         => ZonkEnv
-         -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-         -> Stmt GhcTc (LocatedA (body GhcTc))
-         -> TcM (ZonkEnv, Stmt GhcTc (LocatedA (body GhcTc)))
-zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op)
-  = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op
-       ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
-       ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs
-       ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs
-                              , b <- bs]
-             env2 = extendIdZonkEnvRec env1 new_binders
-       ; new_mzip <- zonkExpr env2 mzip_op
-       ; return (env2
-                , ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)}
-  where
-    zonk_branch :: ZonkEnv -> ParStmtBlock GhcTc GhcTc
-                -> TcM (ParStmtBlock GhcTc GhcTc)
-    zonk_branch env1 (ParStmtBlock x stmts bndrs return_op)
-       = do { (env2, new_stmts)  <- zonkStmts env1 zonkLExpr stmts
-            ; (env3, new_return) <- zonkSyntaxExpr env2 return_op
-            ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs)
-                                                                   new_return) }
-
-zonkStmt env zBody (RecStmt { recS_stmts = L _ segStmts, recS_later_ids = lvs
-                            , recS_rec_ids = rvs
-                            , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id
-                            , recS_bind_fn = bind_id
-                            , recS_ext =
-                                       RecStmtTc { recS_bind_ty = bind_ty
-                                                 , recS_later_rets = later_rets
-                                                 , recS_rec_rets = rec_rets
-                                                 , recS_ret_ty = ret_ty} })
-  = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id
-       ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id
-       ; (env3, new_ret_id)  <- zonkSyntaxExpr env2 ret_id
-       ; new_bind_ty <- zonkTcTypeToTypeX env3 bind_ty
-       ; new_rvs <- zonkIdBndrs env3 rvs
-       ; new_lvs <- zonkIdBndrs env3 lvs
-       ; new_ret_ty  <- zonkTcTypeToTypeX env3 ret_ty
-       ; let env4 = extendIdZonkEnvRec env3 new_rvs
-       ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts
-        -- Zonk the ret-expressions in an envt that
-        -- has the polymorphic bindings in the envt
-       ; new_later_rets <- mapM (zonkExpr env5) later_rets
-       ; new_rec_rets <- mapM (zonkExpr env5) rec_rets
-       ; return (extendIdZonkEnvRec env3 new_lvs,     -- Only the lvs are needed
-                 RecStmt { recS_stmts = noLocA new_segStmts
-                         , recS_later_ids = new_lvs
-                         , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
-                         , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
-                         , recS_ext = RecStmtTc
-                             { recS_bind_ty = new_bind_ty
-                             , recS_later_rets = new_later_rets
-                             , recS_rec_rets = new_rec_rets
-                             , recS_ret_ty = new_ret_ty } }) }
-
-zonkStmt env zBody (BodyStmt ty body then_op guard_op)
-  = do (env1, new_then_op)  <- zonkSyntaxExpr env then_op
-       (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op
-       new_body <- zBody env2 body
-       new_ty   <- zonkTcTypeToTypeX env2 ty
-       return (env2, BodyStmt new_ty new_body new_then_op new_guard_op)
-
-zonkStmt env zBody (LastStmt x body noret ret_op)
-  = do (env1, new_ret) <- zonkSyntaxExpr env ret_op
-       new_body <- zBody env1 body
-       return (env, LastStmt x new_body noret new_ret)
-
-zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
-                          , trS_by = by, trS_form = form, trS_using = using
-                          , trS_ret = return_op, trS_bind = bind_op
-                          , trS_ext = bind_arg_ty
-                          , trS_fmap = liftM_op })
-  = do {
-    ; (env1, bind_op') <- zonkSyntaxExpr env bind_op
-    ; bind_arg_ty' <- zonkTcTypeToTypeX env1 bind_arg_ty
-    ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts
-    ; by'        <- traverse (zonkLExpr env2) by
-    ; using'     <- zonkLExpr env2 using
-
-    ; (env3, return_op') <- zonkSyntaxExpr env2 return_op
-    ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap
-    ; liftM_op'  <- zonkExpr env3 liftM_op
-    ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap')
-    ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
-                               , trS_by = by', trS_form = form, trS_using = using'
-                               , trS_ret = return_op', trS_bind = bind_op'
-                               , trS_ext = bind_arg_ty'
-                               , trS_fmap = liftM_op' }) }
-  where
-    zonkBinderMapEntry env  (oldBinder, newBinder) = do
-        let oldBinder' = zonkIdOcc env oldBinder
-        newBinder' <- zonkIdBndr env newBinder
-        return (oldBinder', newBinder')
-
-zonkStmt env _ (LetStmt x binds)
-  = do (env1, new_binds) <- zonkLocalBinds env binds
-       return (env1, LetStmt x new_binds)
-
-zonkStmt env zBody (BindStmt xbs pat body)
-  = do  { (env1, new_bind) <- zonkSyntaxExpr env (xbstc_bindOp xbs)
-        ; new_w <- zonkTcTypeToTypeX env1 (xbstc_boundResultMult xbs)
-        ; new_bind_ty <- zonkTcTypeToTypeX env1 (xbstc_boundResultType xbs)
-        ; new_body <- zBody env1 body
-        ; (env2, new_pat) <- zonkPat env1 pat
-        ; new_fail <- case xbstc_failOp xbs of
-            Nothing -> return Nothing
-            Just f -> fmap (Just . snd) (zonkSyntaxExpr env1 f)
-        ; return ( env2
-                 , BindStmt (XBindStmtTc
-                              { xbstc_bindOp = new_bind
-                              , xbstc_boundResultType = new_bind_ty
-                              , xbstc_boundResultMult = new_w
-                              , xbstc_failOp = new_fail
-                              })
-                            new_pat new_body) }
-
--- Scopes: join > ops (in reverse order) > pats (in forward order)
---              > rest of stmts
-zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
-  = do  { (env1, new_mb_join)   <- zonk_join env mb_join
-        ; (env2, new_args)      <- zonk_args env1 args
-        ; new_body_ty           <- zonkTcTypeToTypeX env2 body_ty
-        ; return ( env2
-                 , ApplicativeStmt new_body_ty new_args new_mb_join) }
-  where
-    zonk_join env Nothing  = return (env, Nothing)
-    zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j
-
-    get_pat :: (SyntaxExpr GhcTc, ApplicativeArg GhcTc) -> LPat GhcTc
-    get_pat (_, ApplicativeArgOne _ pat _ _) = pat
-    get_pat (_, ApplicativeArgMany _ _ _ pat _) = pat
-
-    replace_pat :: LPat GhcTc
-                -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-                -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
-    replace_pat pat (op, ApplicativeArgOne fail_op _ a isBody)
-      = (op, ApplicativeArgOne fail_op pat a isBody)
-    replace_pat pat (op, ApplicativeArgMany x a b _ c)
-      = (op, ApplicativeArgMany x a b pat c)
-
-    zonk_args env args
-      = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)
-           ; (env2, new_pats)     <- zonkPats env1 (map get_pat args)
-           ; return (env2, zipWithEqual "zonkStmt" replace_pat
-                                        new_pats (reverse new_args_rev)) }
-
-     -- these need to go backward, because if any operators are higher-rank,
-     -- later operators may introduce skolems that are in scope for earlier
-     -- arguments
-    zonk_args_rev env ((op, arg) : args)
-      = do { (env1, new_op)         <- zonkSyntaxExpr env op
-           ; new_arg                <- zonk_arg env1 arg
-           ; (env2, new_args)       <- zonk_args_rev env1 args
-           ; return (env2, (new_op, new_arg) : new_args) }
-    zonk_args_rev env [] = return (env, [])
-
-    zonk_arg env (ApplicativeArgOne fail_op pat expr isBody)
-      = do { new_expr <- zonkLExpr env expr
-           ; new_fail <- forM fail_op $ \old_fail ->
-              do { (_, fail') <- zonkSyntaxExpr env old_fail
-                 ; return fail'
-                 }
-           ; return (ApplicativeArgOne new_fail pat new_expr isBody) }
-    zonk_arg env (ApplicativeArgMany x stmts ret pat ctxt)
-      = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
-           ; new_ret           <- zonkExpr env1 ret
-           ; return (ApplicativeArgMany x new_stmts new_ret pat ctxt) }
-
--------------------------------------------------------------------------
-zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTc -> TcM (HsRecordBinds GhcTc)
-zonkRecFields env (HsRecFields flds dd)
-  = do  { flds' <- mapM zonk_rbind flds
-        ; return (HsRecFields flds' dd) }
-  where
-    zonk_rbind (L l fld)
-      = do { new_id   <- wrapLocMA (zonkFieldOcc env) (hfbLHS fld)
-           ; new_expr <- zonkLExpr env (hfbRHS fld)
-           ; return (L l (fld { hfbLHS = new_id
-                              , hfbRHS = new_expr })) }
-
-{-
-************************************************************************
-*                                                                      *
-\subsection[BackSubst-Pats]{Patterns}
-*                                                                      *
-************************************************************************
--}
-
-zonkPat :: ZonkEnv -> LPat GhcTc -> TcM (ZonkEnv, LPat GhcTc)
--- Extend the environment as we go, because it's possible for one
--- pattern to bind something that is used in another (inside or
--- to the right)
-zonkPat env pat = wrapLocSndMA (zonk_pat env) pat
-
-zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc)
-zonk_pat env (ParPat x lpar p rpar)
-  = do  { (env', p') <- zonkPat env p
-        ; return (env', ParPat x lpar p' rpar) }
-
-zonk_pat env (WildPat ty)
-  = do  { ty' <- zonkTcTypeToTypeX env ty
-        ; return (env, WildPat ty') }
-
-zonk_pat env (VarPat x (L l v))
-  = do  { v' <- zonkIdBndr env v
-        ; return (extendIdZonkEnv env v', VarPat x (L l v')) }
-
-zonk_pat env (LazyPat x pat)
-  = do  { (env', pat') <- zonkPat env pat
-        ; return (env',  LazyPat x pat') }
-
-zonk_pat env (BangPat x pat)
-  = do  { (env', pat') <- zonkPat env pat
-        ; return (env',  BangPat x pat') }
-
-zonk_pat env (AsPat x (L loc v) at pat)
-  = do  { v' <- zonkIdBndr env v
-        ; (env', pat') <- zonkPat (extendIdZonkEnv env v') pat
-        ; return (env', AsPat x (L loc v') at pat') }
-
-zonk_pat env (ViewPat ty expr pat)
-  = do  { expr' <- zonkLExpr env expr
-        ; (env', pat') <- zonkPat env pat
-        ; ty' <- zonkTcTypeToTypeX env ty
-        ; return (env', ViewPat ty' expr' pat') }
-
-zonk_pat env (ListPat ty pats)
-  = do  { ty' <- zonkTcTypeToTypeX env ty
-        ; (env', pats') <- zonkPats env pats
-        ; return (env', ListPat ty' pats') }
-
-zonk_pat env (TuplePat tys pats boxed)
-  = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys
-        ; (env', pats') <- zonkPats env pats
-        ; return (env', TuplePat tys' pats' boxed) }
-
-zonk_pat env (SumPat tys pat alt arity )
-  = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys
-        ; (env', pat') <- zonkPat env pat
-        ; return (env', SumPat tys' pat' alt arity) }
-
-zonk_pat env p@(ConPat { pat_args = args
-                       , pat_con_ext = p'@(ConPatTc
-                         { cpt_tvs = tyvars
-                         , cpt_dicts = evs
-                         , cpt_binds = binds
-                         , cpt_wrap = wrapper
-                         , cpt_arg_tys = tys
-                         })
-                       })
-  = assert (all isImmutableTyVar tyvars) $
-    do  { new_tys <- mapM (zonkTcTypeToTypeX env) tys
-        ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
-          -- Must zonk the existential variables, because their
-          -- /kind/ need potential zonking.
-          -- cf typecheck/should_compile/tc221.hs
-        ; (env1, new_evs) <- zonkEvBndrsX env0 evs
-        ; (env2, new_binds) <- zonkTcEvBinds env1 binds
-        ; (env3, new_wrapper) <- zonkCoFn env2 wrapper
-        ; (env', new_args) <- zonkConStuff env3 args
-        ; pure ( env'
-               , p
-                 { pat_args = new_args
-                 , pat_con_ext = p'
-                   { cpt_arg_tys = new_tys
-                   , cpt_tvs = new_tyvars
-                   , cpt_dicts = new_evs
-                   , cpt_binds = new_binds
-                   , cpt_wrap = new_wrapper
-                   }
-                 }
-               )
-        }
-
-zonk_pat env (LitPat x lit) = return (env, LitPat x lit)
-
-zonk_pat env (SigPat ty pat hs_ty)
-  = do  { ty' <- zonkTcTypeToTypeX env ty
-        ; (env', pat') <- zonkPat env pat
-        ; return (env', SigPat ty' pat' hs_ty) }
-
-zonk_pat env (NPat ty (L l lit) mb_neg eq_expr)
-  = do  { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr
-        ; (env2, mb_neg') <- case mb_neg of
-            Nothing -> return (env1, Nothing)
-            Just n  -> second Just <$> zonkSyntaxExpr env1 n
-
-        ; lit' <- zonkOverLit env2 lit
-        ; ty' <- zonkTcTypeToTypeX env2 ty
-        ; return (env2, NPat ty' (L l lit') mb_neg' eq_expr') }
-
-zonk_pat env (NPlusKPat ty (L loc n) (L l lit1) lit2 e1 e2)
-  = do  { (env1, e1') <- zonkSyntaxExpr env  e1
-        ; (env2, e2') <- zonkSyntaxExpr env1 e2
-        ; n' <- zonkIdBndr env2 n
-        ; lit1' <- zonkOverLit env2 lit1
-        ; lit2' <- zonkOverLit env2 lit2
-        ; ty' <- zonkTcTypeToTypeX env2 ty
-        ; return (extendIdZonkEnv env2 n',
-                  NPlusKPat ty' (L loc n') (L l lit1') lit2' e1' e2') }
-zonk_pat env (XPat ext) = case ext of
-  { ExpansionPat orig pat->
-    do { (env, pat') <- zonk_pat env pat
-       ; return $ (env, XPat $ ExpansionPat orig pat') }
-  ; CoPat co_fn pat ty ->
-    do { (env', co_fn') <- zonkCoFn env co_fn
-       ; (env'', pat') <- zonkPat env' (noLocA pat)
-       ; ty' <- zonkTcTypeToTypeX env'' ty
-       ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty')
-       }}
-
-zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
-
----------------------------
-zonkConStuff :: ZonkEnv -> HsConPatDetails GhcTc
-             -> TcM (ZonkEnv, HsConPatDetails GhcTc)
-zonkConStuff env (PrefixCon tyargs pats)
-  = do  { (env', pats') <- zonkPats env pats
-        ; return (env', PrefixCon tyargs pats') }
-
-zonkConStuff env (InfixCon p1 p2)
-  = do  { (env1, p1') <- zonkPat env  p1
-        ; (env', p2') <- zonkPat env1 p2
-        ; return (env', InfixCon p1' p2') }
-
-zonkConStuff env (RecCon (HsRecFields rpats dd))
-  = do  { (env', pats') <- zonkPats env (map (hfbRHS . unLoc) rpats)
-        ; let rpats' = zipWith (\(L l rp) p' ->
-                                  L l (rp { hfbRHS = p' }))
-                               rpats pats'
-        ; return (env', RecCon (HsRecFields rpats' dd)) }
-        -- Field selectors have declared types; hence no zonking
-
----------------------------
-zonkPats :: ZonkEnv -> [LPat GhcTc] -> TcM (ZonkEnv, [LPat GhcTc])
-zonkPats env []         = return (env, [])
-zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
-                             ; (env', pats') <- zonkPats env1 pats
-                             ; return (env', pat':pats') }
-
-{-
-************************************************************************
-*                                                                      *
-\subsection[BackSubst-Foreign]{Foreign exports}
-*                                                                      *
-************************************************************************
--}
-
-zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTc]
-                   -> TcM [LForeignDecl GhcTc]
-zonkForeignExports env ls = mapM (wrapLocMA (zonkForeignExport env)) ls
-
-zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTc -> TcM (ForeignDecl GhcTc)
-zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co
-                                     , fd_fe = spec })
-  = return (ForeignExport { fd_name = zonkLIdOcc env i
-                          , fd_sig_ty = undefined, fd_e_ext = co
-                          , fd_fe = spec })
-zonkForeignExport _ for_imp
-  = return for_imp     -- Foreign imports don't need zonking
-
-zonkRules :: ZonkEnv -> [LRuleDecl GhcTc] -> TcM [LRuleDecl GhcTc]
-zonkRules env rs = mapM (wrapLocMA (zonkRule env)) rs
-
-zonkRule :: ZonkEnv -> RuleDecl GhcTc -> TcM (RuleDecl GhcTc)
-zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
-                          , rd_lhs = lhs
-                          , rd_rhs = rhs })
-  = do { (env_inside, new_tm_bndrs) <- mapAccumLM zonk_tm_bndr env tm_bndrs
-
-       ; let env_lhs = setZonkType env_inside SkolemiseFlexi
-              -- See Note [Zonking the LHS of a RULE]
-
-       ; new_lhs <- zonkLExpr env_lhs    lhs
-       ; new_rhs <- zonkLExpr env_inside rhs
-
-       ; return $ rule { rd_tmvs = new_tm_bndrs
-                       , rd_lhs  = new_lhs
-                       , rd_rhs  = new_rhs } }
-  where
-   zonk_tm_bndr :: ZonkEnv -> LRuleBndr GhcTc -> TcM (ZonkEnv, LRuleBndr GhcTc)
-   zonk_tm_bndr env (L l (RuleBndr x (L loc v)))
-      = do { (env', v') <- zonk_it env v
-           ; return (env', L l (RuleBndr x (L loc v'))) }
-   zonk_tm_bndr _ (L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"
-
-   zonk_it env v
-     | isId v     = do { v' <- zonkIdBndr env v
-                       ; return (extendIdZonkEnvRec env [v'], v') }
-     | otherwise  = assert (isImmutableTyVar v)
-                    zonkTyBndrX env v
-                    -- DV: used to be return (env,v) but that is plain
-                    -- wrong because we may need to go inside the kind
-                    -- of v and zonk there!
-
-{-
-************************************************************************
-*                                                                      *
-              Constraints and evidence
-*                                                                      *
-************************************************************************
--}
-
-zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
-zonkEvTerm env (EvExpr e)
-  = EvExpr <$> zonkCoreExpr env e
-zonkEvTerm env (EvTypeable ty ev)
-  = EvTypeable <$> zonkTcTypeToTypeX env ty <*> zonkEvTypeable env ev
-zonkEvTerm env (EvFun { et_tvs = tvs, et_given = evs
-                      , et_binds = ev_binds, et_body = body_id })
-  = do { (env0, new_tvs) <- zonkTyBndrsX env tvs
-       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
-       ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
-       ; let new_body_id = zonkIdOcc env2 body_id
-       ; return (EvFun { et_tvs = new_tvs, et_given = new_evs
-                       , et_binds = new_ev_binds, et_body = new_body_id }) }
-
-zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr
-zonkCoreExpr env (Var v)
-    | isCoVar v
-    = Coercion <$> zonkCoVarOcc env v
-    | otherwise
-    = return (Var $ zonkIdOcc env v)
-zonkCoreExpr _ (Lit l)
-    = return $ Lit l
-zonkCoreExpr env (Coercion co)
-    = Coercion <$> zonkCoToCo env co
-zonkCoreExpr env (Type ty)
-    = Type <$> zonkTcTypeToTypeX env ty
-
-zonkCoreExpr env (Cast e co)
-    = Cast <$> zonkCoreExpr env e <*> zonkCoToCo env co
-zonkCoreExpr env (Tick t e)
-    = Tick t <$> zonkCoreExpr env e -- Do we need to zonk in ticks?
-
-zonkCoreExpr env (App e1 e2)
-    = App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2
-zonkCoreExpr env (Lam v e)
-    = do { (env1, v') <- zonkCoreBndrX env v
-         ; Lam v' <$> zonkCoreExpr env1 e }
-zonkCoreExpr env (Let bind e)
-    = do (env1, bind') <- zonkCoreBind env bind
-         Let bind'<$> zonkCoreExpr env1 e
-zonkCoreExpr env (Case scrut b ty alts)
-    = do scrut' <- zonkCoreExpr env scrut
-         ty' <- zonkTcTypeToTypeX env ty
-         b' <- zonkIdBndr env b
-         let env1 = extendIdZonkEnv env b'
-         alts' <- mapM (zonkCoreAlt env1) alts
-         return $ Case scrut' b' ty' alts'
-
-zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt
-zonkCoreAlt env (Alt dc bndrs rhs)
-    = do (env1, bndrs') <- zonkCoreBndrsX env bndrs
-         rhs' <- zonkCoreExpr env1 rhs
-         return $ Alt dc bndrs' rhs'
-
-zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind)
-zonkCoreBind env (NonRec v e)
-    = do v' <- zonkIdBndr env v
-         e' <- zonkCoreExpr env e
-         let env1 = extendIdZonkEnv env v'
-         return (env1, NonRec v' e')
-zonkCoreBind env (Rec pairs)
-    = do (env1, pairs') <- fixM go
-         return (env1, Rec pairs')
-  where
-    go ~(_, new_pairs) = do
-         let env1 = extendIdZonkEnvRec env (map fst new_pairs)
-         pairs' <- mapM (zonkCorePair env1) pairs
-         return (env1, pairs')
-
-zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr)
-zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e
-
-zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
-zonkEvTypeable env (EvTypeableTyCon tycon e)
-  = do { e'  <- mapM (zonkEvTerm env) e
-       ; return $ EvTypeableTyCon tycon e' }
-zonkEvTypeable env (EvTypeableTyApp t1 t2)
-  = do { t1' <- zonkEvTerm env t1
-       ; t2' <- zonkEvTerm env t2
-       ; return (EvTypeableTyApp t1' t2') }
-zonkEvTypeable env (EvTypeableTrFun tm t1 t2)
-  = do { tm' <- zonkEvTerm env tm
-       ; t1' <- zonkEvTerm env t1
-       ; t2' <- zonkEvTerm env t2
-       ; return (EvTypeableTrFun tm' t1' t2') }
-zonkEvTypeable env (EvTypeableTyLit t1)
-  = do { t1' <- zonkEvTerm env t1
-       ; return (EvTypeableTyLit t1') }
-
-zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
-zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs
-                            ; return (env, [EvBinds (unionManyBags bs')]) }
-
-zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
-zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs
-                          ; return (env', EvBinds bs') }
-
-zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)
-zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var
-zonk_tc_ev_binds env (EvBinds bs)    = zonkEvBinds env bs
-
-zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
-zonkEvBindsVar env (EvBindsVar { ebv_binds = ref })
-  = do { bs <- readMutVar ref
-       ; zonkEvBinds env (evBindMapBinds bs) }
-zonkEvBindsVar env (CoEvBindsVar {}) = return (env, emptyBag)
-
-zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
-zonkEvBinds env binds
-  = {-# SCC "zonkEvBinds" #-}
-    fixM (\ ~( _, new_binds) -> do
-         { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds)
-         ; binds' <- mapBagM (zonkEvBind env1) binds
-         ; return (env1, binds') })
-  where
-    collect_ev_bndrs :: Bag EvBind -> [EvVar]
-    collect_ev_bndrs = foldr add []
-    add (EvBind { eb_lhs = var }) vars = var : vars
-
-zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
-zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term })
-  = do { var'  <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var
-
-         -- Optimise the common case of Refl coercions
-         -- See Note [Optimise coercion zonking]
-         -- This has a very big effect on some programs (eg #5030)
-
-       ; term' <- case getEqPredTys_maybe (idType var') of
-           Just (r, ty1, ty2) | ty1 `eqType` ty2
-                  -> return (evCoercion (mkReflCo r ty1))
-           _other -> zonkEvTerm env term
-
-       ; return (bind { eb_lhs = var', eb_rhs = term' }) }
-
-{- Note [Optimise coercion zonking]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When optimising evidence binds we may come across situations where
-a coercion looks like
-      cv = ReflCo ty
-or    cv1 = cv2
-where the type 'ty' is big.  In such cases it is a waste of time to zonk both
-  * The variable on the LHS
-  * The coercion on the RHS
-Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just
-use Refl on the right, ignoring the actual coercion on the RHS.
-
-This can have a very big effect, because the constraint solver sometimes does go
-to a lot of effort to prove Refl!  (Eg when solving  10+3 = 10+3; cf #5030)
-
-
-************************************************************************
-*                                                                      *
-                         Zonking types
-*                                                                      *
-************************************************************************
--}
-
-{- Note [Sharing when zonking to Type]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Problem:
-
-    In GHC.Tc.Utils.TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to
-    (Indirect zty), see Note [Sharing in zonking] in GHC.Tc.Utils.TcMType. But we
-    /can't/ do this when zonking a TcType to a Type (#15552, esp
-    comment:3).  Suppose we have
-
-       alpha -> alpha
-         where
-            alpha is already unified:
-             alpha := T{tc-tycon} Int -> Int
-         and T is knot-tied
-
-    By "knot-tied" I mean that the occurrence of T is currently a TcTyCon,
-    but the global env contains a mapping "T" :-> T{knot-tied-tc}. See
-    Note [Type checking recursive type and class declarations] in
-    GHC.Tc.TyCl.
-
-    Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow
-    the same path as Note [Sharing in zonking] in GHC.Tc.Utils.TcMType, we'll
-    update alpha to
-       alpha := T{knot-tied-tc} Int -> Int
-
-    But alas, if we encounter alpha for a /second/ time, we end up
-    looking at T{knot-tied-tc} and fall into a black hole. The whole
-    point of zonkTcTypeToType is that it produces a type full of
-    knot-tied tycons, and you must not look at the result!!
-
-    To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not
-    the same as zonkTcTypeToType. (If we distinguished TcType from
-    Type, this issue would have been a type error!)
-
-Solutions: (see #15552 for other variants)
-
-One possible solution is simply not to do the short-circuiting.
-That has less sharing, but maybe sharing is rare. And indeed,
-that usually turns out to be viable from a perf point of view
-
-But zonkTyVarOcc implements something a bit better
-
-* ZonkEnv contains ze_meta_tv_env, which maps
-      from a MetaTyVar (unification variable)
-      to a Type (not a TcType)
-
-* In zonkTyVarOcc, we check this map to see if we have zonked
-  this variable before. If so, use the previous answer; if not
-  zonk it, and extend the map.
-
-* The map is of course stateful, held in a TcRef. (That is unlike
-  the treatment of lexically-scoped variables in ze_tv_env and
-  ze_id_env.)
-
-* In zonkTyVarOcc we read the TcRef to look up the unification
-  variable:
-    - if we get a hit we use the zonked result;
-    - if not, in zonk_meta we see if the variable is `Indirect ty`,
-      zonk that, and update the map (in finish_meta)
-  But Nota Bene that the "update map" step must re-read the TcRef
-  (or, more precisely, use updTcRef) because the zonking of the
-  `Indirect ty` may have added lots of stuff to the map.  See
-  #19668 for an example where this made an asymptotic difference!
-
-Is it worth the extra work of carrying ze_meta_tv_env? Some
-non-systematic perf measurements suggest that compiler allocation is
-reduced overall (by 0.5% or so) but compile time really doesn't
-change.  But in some cases it makes a HUGE difference: see test
-T9198 and #19668.  So yes, it seems worth it.
--}
-
-zonkTyVarOcc :: ZonkEnv -> TcTyVar -> TcM Type
-zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi
-                          , ze_tv_env = tv_env
-                          , ze_meta_tv_env = mtv_env_ref }) tv
-  | isTcTyVar tv
-  = case tcTyVarDetails tv of
-      SkolemTv {}    -> lookup_in_tv_env
-      RuntimeUnk {}  -> lookup_in_tv_env
-      MetaTv { mtv_ref = ref }
-        -> do { mtv_env <- readTcRef mtv_env_ref
-                -- See Note [Sharing when zonking to Type]
-              ; case lookupVarEnv mtv_env tv of
-                  Just ty -> return ty
-                  Nothing -> do { mtv_details <- readTcRef ref
-                                ; zonk_meta ref mtv_details } }
-  | otherwise  -- This should never really happen;
-               -- TyVars should not occur in the typechecker
-  = lookup_in_tv_env
-
-  where
-    lookup_in_tv_env    -- Look up in the env just as we do for Ids
-      = case lookupVarEnv tv_env tv of
-          Nothing  -> -- TyVar/SkolemTv/RuntimeUnk that isn't in the ZonkEnv
-                      -- This can happen for RuntimeUnk variables (which
-                      -- should stay as RuntimeUnk), but I think it should
-                      -- not happen for SkolemTv.
-                      mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv
-
-          Just tv' -> return (mkTyVarTy tv')
-
-    zonk_meta ref Flexi
-      = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv)
-           ; ty <- commitFlexi flexi tv kind
-           ; writeMetaTyVarRef tv ref ty  -- Belt and braces
-           ; finish_meta ty }
-
-    zonk_meta _ (Indirect ty)
-      = do { zty <- zonkTcTypeToTypeX env ty
-           ; finish_meta zty }
-
-    finish_meta ty
-      = do { updTcRef mtv_env_ref (\env -> extendVarEnv env tv ty)
-           ; return ty }
-
-lookupTyVarX :: ZonkEnv -> TcTyVar -> TyVar
-lookupTyVarX (ZonkEnv { ze_tv_env = tv_env }) tv
-  = case lookupVarEnv tv_env tv of
-       Just tv -> tv
-       Nothing -> pprPanic "lookupTyVarOcc" (ppr tv $$ ppr tv_env)
-
-commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type
--- Only monadic so we can do tc-tracing
-commitFlexi flexi tv zonked_kind
-  = case flexi of
-      SkolemiseFlexi  -> return (mkTyVarTy (mkTyVar name zonked_kind))
-
-      DefaultFlexi
-          -- Normally, RuntimeRep variables are defaulted in TcMType.defaultTyVar
-          -- But that sees only type variables that appear in, say, an inferred type
-          -- Defaulting here in the zonker is needed to catch e.g.
-          --    y :: Bool
-          --    y = (\x -> True) undefined
-          -- We need *some* known RuntimeRep for the x and undefined, but no one
-          -- will choose it until we get here, in the zonker.
-        | isRuntimeRepTy zonked_kind
-        -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv)
-              ; return liftedRepTy }
-        | isLevityTy zonked_kind
-        -> do { traceTc "Defaulting flexi tyvar to Lifted:" (pprTyVar tv)
-              ; return liftedDataConTy }
-        | isMultiplicityTy zonked_kind
-        -> do { traceTc "Defaulting flexi tyvar to Many:" (pprTyVar tv)
-              ; return manyDataConTy }
-        | otherwise
-        -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv)
-              ; return (anyTypeOfKind zonked_kind) }
-
-      RuntimeUnkFlexi
-        -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv)
-              ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) }
-                        -- This is where RuntimeUnks are born:
-                        -- otherwise-unconstrained unification variables are
-                        -- turned into RuntimeUnks as they leave the
-                        -- typechecker's monad
-
-      NoFlexi -> pprPanic "NoFlexi" (ppr tv <+> dcolon <+> ppr zonked_kind)
-
-  where
-     name = tyVarName tv
-
-zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion
-zonkCoVarOcc (ZonkEnv { ze_tv_env = tyco_env }) cv
-  | Just cv' <- lookupVarEnv tyco_env cv  -- don't look in the knot-tied env
-  = return $ mkCoVarCo cv'
-  | otherwise
-  = do { cv' <- zonkCoVar cv; return (mkCoVarCo cv') }
-
-zonkCoHole :: ZonkEnv -> CoercionHole -> TcM Coercion
-zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
-  = do { contents <- readTcRef ref
-       ; case contents of
-           Just co -> do { co' <- zonkCoToCo env co
-                         ; checkCoercionHole cv co' }
-
-              -- This next case should happen only in the presence of
-              -- (undeferred) type errors. Originally, I put in a panic
-              -- here, but that caused too many uses of `failIfErrsM`.
-           Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole)
-                         ; cv' <- zonkCoVar cv
-                         ; return $ mkCoVarCo cv' } }
-                             -- This will be an out-of-scope variable, but keeping
-                             -- this as a coercion hole led to #15787
-
-zonk_tycomapper :: TyCoMapper ZonkEnv TcM
-zonk_tycomapper = TyCoMapper
-  { tcm_tyvar      = zonkTyVarOcc
-  , tcm_covar      = zonkCoVarOcc
-  , tcm_hole       = zonkCoHole
-  , tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv
-  , tcm_tycon      = zonkTcTyConToTyCon }
-
--- Zonk a TyCon by changing a TcTyCon to a regular TyCon
-zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon
-zonkTcTyConToTyCon tc
-  | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc)
-                      ; case thing of
-                          ATyCon real_tc -> return real_tc
-                          _              -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) }
-  | otherwise    = return tc -- it's already zonked
-
--- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType.
-zonkTcTypeToType :: TcType -> TcM Type
-zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty
-
-zonkScaledTcTypeToTypeX :: ZonkEnv -> Scaled TcType -> TcM (Scaled TcType)
-zonkScaledTcTypeToTypeX env (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m
-                                                   <*> zonkTcTypeToTypeX env ty
-
-zonkTcTypeToTypeX   :: ZonkEnv -> TcType   -> TcM Type
-zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type]
-zonkCoToCo          :: ZonkEnv -> Coercion -> TcM Coercion
-(zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkCoToCo, _)
-  = mapTyCoX zonk_tycomapper
-
-zonkScaledTcTypesToTypesX :: ZonkEnv -> [Scaled TcType] -> TcM [Scaled Type]
-zonkScaledTcTypesToTypesX env scaled_tys =
-   mapM (zonkScaledTcTypeToTypeX env) scaled_tys
-
-zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo
-zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec)
-  = do { ty' <- zonkTcTypeToTypeX ze ty
-       ; gdm_spec' <- zonk_gdm gdm_spec
-       ; return (name, ty', gdm_spec') }
-  where
-    zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType))
-             -> TcM (Maybe (DefMethSpec (SrcSpan, Type)))
-    zonk_gdm Nothing = return Nothing
-    zonk_gdm (Just VanillaDM) = return (Just VanillaDM)
-    zonk_gdm (Just (GenericDM (loc, ty)))
-      = do { ty' <- zonkTcTypeToTypeX ze ty
-           ; return (Just (GenericDM (loc, ty'))) }
-
----------------------------------------
-{- Note [Zonking the LHS of a RULE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See also GHC.HsToCore.Binds Note [Free tyvars on rule LHS]
-
-We need to gather the type variables mentioned on the LHS so we can
-quantify over them.  Example:
-  data T a = C
-
-  foo :: T a -> Int
-  foo C = 1
-
-  {-# RULES "myrule"  foo C = 1 #-}
-
-After type checking the LHS becomes (foo alpha (C alpha)) and we do
-not want to zap the unbound meta-tyvar 'alpha' to Any, because that
-limits the applicability of the rule.  Instead, we want to quantify
-over it!
-
-We do this in two stages.
-
-* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'.  We
-  do this by using zonkTvSkolemising as the UnboundTyVarZonker in the
-  ZonkEnv.  (This is in fact the whole reason that the ZonkEnv has a
-  UnboundTyVarZonker.)
-
-* In GHC.HsToCore.Binds, we quantify over it.  See GHC.HsToCore.Binds
-  Note [Free tyvars on rule LHS]
-
-Quantifying here is awkward because (a) the data type is big and (b)
-finding the free type vars of an expression is necessarily monadic
-operation. (consider /\a -> f @ b, where b is side-effected to a)
--}
diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs
deleted file mode 100644
--- a/compiler/GHC/Tc/Validity.hs
+++ /dev/null
@@ -1,2835 +0,0 @@
-{-# LANGUAGE DerivingStrategies #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
--}
-
-module GHC.Tc.Validity (
-  Rank(..), UserTypeCtxt(..), checkValidType, checkValidMonoType,
-  checkValidTheta,
-  checkValidInstance, checkValidInstHead, validDerivPred,
-  checkTySynRhs,
-  checkValidCoAxiom, checkValidCoAxBranch,
-  checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst,
-  arityErr,
-  checkTyConTelescope,
-  allDistinctTyVars
-  ) where
-
-import GHC.Prelude
-import GHC.Data.FastString
-
-import GHC.Data.Maybe
-
--- friends:
-import GHC.Tc.Utils.Unify    ( tcSubTypeAmbiguity )
-import GHC.Tc.Solver         ( simplifyAmbiguityCheck )
-import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) )
-import GHC.Core.TyCo.FVs
-import GHC.Core.TyCo.Rep
-import GHC.Core.TyCo.Ppr
-import GHC.Tc.Utils.TcType hiding ( sizeType, sizeTypes )
-import GHC.Builtin.Types
-import GHC.Builtin.Names
-import GHC.Core.Type
-import GHC.Core.Unify ( tcMatchTyX_BM, BindFlag(..) )
-import GHC.Core.Coercion
-import GHC.Core.Coercion.Axiom
-import GHC.Core.Class
-import GHC.Core.TyCon
-import GHC.Core.Predicate
-import GHC.Tc.Types.Origin
-import GHC.Tc.Types.Rank
-import GHC.Tc.Errors.Types
-import GHC.Types.Error
-
--- others:
-import GHC.Iface.Type    ( pprIfaceType, pprIfaceTypeApp )
-import GHC.CoreToIface   ( toIfaceTyCon, toIfaceTcArgs, toIfaceType )
-import GHC.Hs
-import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Env  ( tcInitTidyEnv, tcInitOpenTidyEnv )
-import GHC.Tc.Instance.FunDeps
-import GHC.Core.FamInstEnv
-   ( isDominatedBy, injectiveBranches, InjectivityCheckResult(..) )
-import GHC.Tc.Instance.Family
-import GHC.Types.Basic   ( UnboxedTupleOrSum(..), unboxedTupleOrSumExtension )
-import GHC.Types.Name
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set
-import GHC.Types.Var     ( VarBndr(..), mkTyVar )
-import GHC.Utils.FV
-import GHC.Utils.Error
-import GHC.Driver.Session
-import GHC.Utils.Misc
-import GHC.Data.List.SetOps
-import GHC.Types.SrcLoc
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-import GHC.Builtin.Uniques  ( mkAlphaTyVarUnique )
-import qualified GHC.LanguageExtensions as LangExt
-
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-import Control.Monad
-import Data.Foldable
-import Data.Function
-import Data.List        ( (\\), nub )
-import qualified Data.List.NonEmpty as NE
-
-{-
-************************************************************************
-*                                                                      *
-          Checking for ambiguity
-*                                                                      *
-************************************************************************
-
-Note [The ambiguity check for type signatures]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-checkAmbiguity is a check on *user-supplied type signatures*.  It is
-*purely* there to report functions that cannot possibly be called.  So for
-example we want to reject:
-   f :: C a => Int
-The idea is there can be no legal calls to 'f' because every call will
-give rise to an ambiguous constraint.  We could soundly omit the
-ambiguity check on type signatures entirely, at the expense of
-delaying ambiguity errors to call sites.  Indeed, the flag
--XAllowAmbiguousTypes switches off the ambiguity check.
-
-What about things like this:
-   class D a b | a -> b where ..
-   h :: D Int b => Int
-The Int may well fix 'b' at the call site, so that signature should
-not be rejected.  Moreover, using *visible* fundeps is too
-conservative.  Consider
-   class X a b where ...
-   class D a b | a -> b where ...
-   instance D a b => X [a] b where...
-   h :: X a b => a -> a
-Here h's type looks ambiguous in 'b', but here's a legal call:
-   ...(h [True])...
-That gives rise to a (X [Bool] beta) constraint, and using the
-instance means we need (D Bool beta) and that fixes 'beta' via D's
-fundep!
-
-Behind all these special cases there is a simple guiding principle.
-Consider
-
-  f :: <type>
-  f = ...blah...
-
-  g :: <type>
-  g = f
-
-You would think that the definition of g would surely typecheck!
-After all f has exactly the same type, and g=f. But in fact f's type
-is instantiated and the instantiated constraints are solved against
-the originals, so in the case of an ambiguous type it won't work.
-Consider our earlier example f :: C a => Int.  Then in g's definition,
-we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a),
-and fail.
-
-So in fact we use this as our *definition* of ambiguity.  We use a
-very similar test for *inferred* types, to ensure that they are
-unambiguous. See Note [Impedance matching] in GHC.Tc.Gen.Bind.
-
-This test is very conveniently implemented by calling
-    tcSubType <type> <type>
-This neatly takes account of the functional dependency stuff above,
-and implicit parameter (see Note [Implicit parameters and ambiguity]).
-And this is what checkAmbiguity does.
-
-Note [The squishiness of the ambiguity check]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-What about this?
-   g :: C [a] => Int
-Is every call to 'g' ambiguous?  After all, we might have
-   instance C [a] where ...
-at the call site.  So maybe that type is ok!  Indeed even f's
-quintessentially ambiguous type might, just possibly be callable:
-with -XFlexibleInstances we could have
-  instance C a where ...
-and now a call could be legal after all!  Well, we'll reject this
-unless the instance is available *here*.
-
-But even that's not quite right. Even a function with an utterly-ambiguous
-type like f :: Eq a => Int -> Int
-is still callable if you are prepared to use visible type application,
-thus (f @Bool x).
-
-In short, the ambiguity check is a good-faith attempt to say "you are likely
-to have trouble if your function has this type"; it is NOT the case that
-"you can't call this function without giving a type error".
-
-See also Note [Ambiguity check and deep subsumption] in GHC.Tc.Utils.Unify.
-
-Note [When to call checkAmbiguity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We call checkAmbiguity
-   (a) on user-specified type signatures
-   (b) in checkValidType
-
-Conncerning (b), you might wonder about nested foralls.  What about
-    f :: forall b. (forall a. Eq a => b) -> b
-The nested forall is ambiguous.  Originally we called checkAmbiguity
-in the forall case of check_type, but that had two bad consequences:
-  * We got two error messages about (Eq b) in a nested forall like this:
-       g :: forall a. Eq a => forall b. Eq b => a -> a
-  * If we try to check for ambiguity of a nested forall like
-    (forall a. Eq a => b), the implication constraint doesn't bind
-    all the skolems, which results in "No skolem info" in error
-    messages (see #10432).
-
-To avoid this, we call checkAmbiguity once, at the top, in checkValidType.
-(I'm still a bit worried about unbound skolems when the type mentions
-in-scope type variables.)
-
-In fact, because of the co/contra-variance implemented in tcSubType,
-this *does* catch function f above. too.
-
-Concerning (a) the ambiguity check is only used for *user* types, not
-for types coming from interface files.  The latter can legitimately
-have ambiguous types. Example
-
-   class S a where s :: a -> (Int,Int)
-   instance S Char where s _ = (1,1)
-   f:: S a => [a] -> Int -> (Int,Int)
-   f (_::[a]) x = (a*x,b)
-        where (a,b) = s (undefined::a)
-
-Here the worker for f gets the type
-        fw :: forall a. S a => Int -> (# Int, Int #)
-
-
-Note [Implicit parameters and ambiguity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Only a *class* predicate can give rise to ambiguity
-An *implicit parameter* cannot.  For example:
-        foo :: (?x :: [a]) => Int
-        foo = length ?x
-is fine.  The call site will supply a particular 'x'
-
-Furthermore, the type variables fixed by an implicit parameter
-propagate to the others.  E.g.
-        foo :: (Show a, ?x::[a]) => Int
-        foo = show (?x++?x)
-The type of foo looks ambiguous.  But it isn't, because at a call site
-we might have
-        let ?x = 5::Int in foo
-and all is well.  In effect, implicit parameters are, well, parameters,
-so we can take their type variables into account as part of the
-"tau-tvs" stuff.  This is done in the function 'GHC.Tc.Instance.FunDeps.grow'.
--}
-
-checkAmbiguity :: UserTypeCtxt -> Type -> TcM ()
-checkAmbiguity ctxt ty
-  | wantAmbiguityCheck ctxt
-  = do { traceTc "Ambiguity check for" (ppr ty)
-         -- Solve the constraints eagerly because an ambiguous type
-         -- can cause a cascade of further errors.  Since the free
-         -- tyvars are skolemised, we can safely use tcSimplifyTop
-       ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes
-       ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $
-                            captureConstraints $
-                            tcSubTypeAmbiguity ctxt ty ty
-                            -- See Note [Ambiguity check and deep subsumption]
-                            -- in GHC.Tc.Utils.Unify
-       ; simplifyAmbiguityCheck ty wanted
-
-       ; traceTc "Done ambiguity check for" (ppr ty) }
-
-  | otherwise
-  = return ()
- where
-   mk_msg allow_ambiguous
-     = vcat [ text "In the ambiguity check for" <+> what
-            , ppUnless allow_ambiguous ambig_msg ]
-   ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes"
-   what | Just n <- isSigMaybe ctxt = quotes (ppr n)
-        | otherwise                 = pprUserTypeCtxt ctxt
-
-wantAmbiguityCheck :: UserTypeCtxt -> Bool
-wantAmbiguityCheck ctxt
-  = case ctxt of  -- See Note [When we don't check for ambiguity]
-      GhciCtxt {}  -> False
-      TySynCtxt {} -> False
-      TypeAppCtxt  -> False
-      StandaloneKindSigCtxt{} -> False
-      _            -> True
-
--- | Check whether the type signature contains custom type errors,
--- and fail if so.
---
--- Note that some custom type errors are acceptable:
---
---   - in the RHS of a type synonym, e.g. to allow users to define
---     type synonyms for custom type errors with large messages (#20181),
---   - inside a type family application, as a custom type error
---     might evaporate after performing type family reduction (#20241).
-checkUserTypeError :: UserTypeCtxt -> Type -> TcM ()
--- Very unsatisfactorily (#11144) we need to tidy the type
--- because it may have come from an /inferred/ signature, not a
--- user-supplied one.  This is really only a half-baked fix;
--- the other errors in checkValidType don't do tidying, and so
--- may give bad error messages when given an inferred type.
-checkUserTypeError ctxt ty
-  | TySynCtxt {} <- ctxt  -- Do not complain about TypeError on the
-  = return ()             -- RHS of type synonyms. See #20181
-
-  | otherwise
-  = check ty
-  where
-  check ty
-    | Just msg    <- userTypeError_maybe ty      = fail_with msg
-    | Just (_,t1) <- splitForAllTyCoVar_maybe ty = check t1
-    | let (_,tys) =  splitAppTys ty              = mapM_ check tys
-    -- splitAppTys keeps type family applications saturated.
-    -- This means we don't go looking for user type errors
-    -- inside type family arguments (see #20241).
-
-  fail_with :: Type -> TcM ()
-  fail_with msg = do { env0 <- tcInitTidyEnv
-                     ; let (env1, tidy_msg) = tidyOpenType env0 msg
-                     ; failWithTcM (env1, TcRnUserTypeError tidy_msg)
-                     }
-
-
-{- Note [When we don't check for ambiguity]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In a few places we do not want to check a user-specified type for ambiguity
-
-* GhciCtxt: Allow ambiguous types in GHCi's :kind command
-  E.g.   type family T a :: *  -- T :: forall k. k -> *
-  Then :k T should work in GHCi, not complain that
-  (T k) is ambiguous!
-
-* TySynCtxt: type T a b = C a b => blah
-  It may be that when we /use/ T, we'll give an 'a' or 'b' that somehow
-  cure the ambiguity.  So we defer the ambiguity check to the use site.
-
-  There is also an implementation reason (#11608).  In the RHS of
-  a type synonym we don't (currently) instantiate 'a' and 'b' with
-  TcTyVars before calling checkValidType, so we get assertion failures
-  from doing an ambiguity check on a type with TyVars in it.  Fixing this
-  would not be hard, but let's wait till there's a reason.
-
-* TypeAppCtxt: visible type application
-     f @ty
-  No need to check ty for ambiguity
-
-* StandaloneKindSigCtxt: type T :: ksig
-  Kinds need a different ambiguity check than types, and the currently
-  implemented check is only good for types. See #14419, in particular
-  https://gitlab.haskell.org/ghc/ghc/issues/14419#note_160844
-
-************************************************************************
-*                                                                      *
-          Checking validity of a user-defined type
-*                                                                      *
-************************************************************************
-
-When dealing with a user-written type, we first translate it from an HsType
-to a Type, performing kind checking, and then check various things that should
-be true about it.  We don't want to perform these checks at the same time
-as the initial translation because (a) they are unnecessary for interface-file
-types and (b) when checking a mutually recursive group of type and class decls,
-we can't "look" at the tycons/classes yet.  Also, the checks are rather
-diverse, and used to really mess up the other code.
-
-One thing we check for is 'rank'.
-
-        Rank 0:         monotypes (no foralls)
-        Rank 1:         foralls at the front only, Rank 0 inside
-        Rank 2:         foralls at the front, Rank 1 on left of fn arrow,
-
-        basic ::= tyvar | T basic ... basic
-
-        r2  ::= forall tvs. cxt => r2a
-        r2a ::= r1 -> r2a | basic
-        r1  ::= forall tvs. cxt => r0
-        r0  ::= r0 -> r0 | basic
-
-Another thing is to check that type synonyms are saturated.
-This might not necessarily show up in kind checking.
-        type A i = i
-        data T k = MkT (k Int)
-        f :: T A        -- BAD!
--}
-
-checkValidType :: UserTypeCtxt -> Type -> TcM ()
--- Checks that a user-written type is valid for the given context
--- Assumes argument is fully zonked
--- Assumes argument is well-kinded;
---    that is, checkValidType doesn't need to do kind checking
--- Not used for instance decls; checkValidInstance instead
-checkValidType ctxt ty
-  = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty))
-       ; rankn_flag  <- xoptM LangExt.RankNTypes
-       ; impred_flag <- xoptM LangExt.ImpredicativeTypes
-       ; let gen_rank :: Rank -> Rank
-             gen_rank r | rankn_flag = ArbitraryRank
-                        | otherwise  = r
-
-             rank1 = gen_rank r1
-             rank0 = gen_rank MonoTypeRankZero
-
-             r1 = LimitedRank True MonoTypeRankZero
-
-             rank
-               = case ctxt of
-                 DefaultDeclCtxt-> MustBeMonoType
-                 PatSigCtxt     -> rank0
-                 RuleSigCtxt {} -> rank1
-                 TySynCtxt _    -> rank0
-
-                 ExprSigCtxt {} -> rank1
-                 KindSigCtxt    -> rank1
-                 StandaloneKindSigCtxt{} -> rank1
-                 TypeAppCtxt | impred_flag -> ArbitraryRank
-                             | otherwise   -> MonoTypeTyConArg
-                    -- Normally, ImpredicativeTypes is handled in check_arg_type,
-                    -- but visible type applications don't go through there.
-                    -- So we do this check here.
-
-                 FunSigCtxt {}  -> rank1
-                 InfSigCtxt {}  -> rank1 -- Inferred types should obey the
-                                         -- same rules as declared ones
-
-                 ConArgCtxt _   -> rank1 -- We are given the type of the entire
-                                         -- constructor, hence rank 1
-                 PatSynCtxt _   -> rank1
-
-                 ForSigCtxt _   -> rank1
-                 SpecInstCtxt   -> rank1
-                 GhciCtxt {}    -> ArbitraryRank
-
-                 TyVarBndrKindCtxt _ -> rank0
-                 DataKindCtxt _      -> rank1
-                 TySynKindCtxt _     -> rank1
-                 TyFamResKindCtxt _  -> rank1
-
-                 _              -> panic "checkValidType"
-                                          -- Can't happen; not used for *user* sigs
-
-       ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty)
-       ; expand <- initialExpandMode
-       ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt
-                             , ve_rank = rank, ve_expand = expand }
-
-       -- Check the internal validity of the type itself
-       -- Fail if bad things happen, else we misleading
-       -- (and more complicated) errors in checkAmbiguity
-       ; checkNoErrs $
-         do { check_type ve ty
-            ; checkUserTypeError ctxt ty
-            ; traceTc "done ct" (ppr ty) }
-
-       -- Check for ambiguous types.  See Note [When to call checkAmbiguity]
-       -- NB: this will happen even for monotypes, but that should be cheap;
-       --     and there may be nested foralls for the subtype test to examine
-       ; checkAmbiguity ctxt ty
-
-       ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (typeKind ty)) }
-
-checkValidMonoType :: Type -> TcM ()
--- Assumes argument is fully zonked
-checkValidMonoType ty
-  = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty)
-       ; expand <- initialExpandMode
-       ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = SigmaCtxt
-                             , ve_rank = MustBeMonoType, ve_expand = expand }
-       ; check_type ve ty }
-
-checkTySynRhs :: UserTypeCtxt -> TcType -> TcM ()
-checkTySynRhs ctxt ty
-  | returnsConstraintKind actual_kind
-  = do { ck <- xoptM LangExt.ConstraintKinds
-       ; if ck
-         then  when (isConstraintLikeKind actual_kind)
-                    (do { dflags <- getDynFlags
-                        ; expand <- initialExpandMode
-                        ; check_pred_ty emptyTidyEnv dflags ctxt expand ty })
-         else addErrTcM ( emptyTidyEnv
-                        , TcRnIllegalConstraintSynonymOfKind (tidyType emptyTidyEnv actual_kind)
-                        ) }
-
-  | otherwise
-  = return ()
-  where
-    actual_kind = typeKind ty
-
-funArgResRank :: Rank -> (Rank, Rank)             -- Function argument and result
-funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank)
-funArgResRank other_rank               = (other_rank, other_rank)
-
-forAllAllowed :: Rank -> Bool
-forAllAllowed ArbitraryRank             = True
-forAllAllowed (LimitedRank forall_ok _) = forall_ok
-forAllAllowed _                         = False
-
--- | Indicates whether a 'UserTypeCtxt' represents type-level contexts,
--- kind-level contexts, or both.
-data TypeOrKindCtxt
-  = OnlyTypeCtxt
-    -- ^ A 'UserTypeCtxt' that only represents type-level positions.
-  | OnlyKindCtxt
-    -- ^ A 'UserTypeCtxt' that only represents kind-level positions.
-  | BothTypeAndKindCtxt
-    -- ^ A 'UserTypeCtxt' that can represent both type- and kind-level positions.
-  deriving Eq
-
-instance Outputable TypeOrKindCtxt where
-  ppr ctxt = text $ case ctxt of
-    OnlyTypeCtxt        -> "OnlyTypeCtxt"
-    OnlyKindCtxt        -> "OnlyKindCtxt"
-    BothTypeAndKindCtxt -> "BothTypeAndKindCtxt"
-
--- | Determine whether a 'UserTypeCtxt' can represent type-level contexts,
--- kind-level contexts, or both.
-typeOrKindCtxt :: UserTypeCtxt -> TypeOrKindCtxt
-typeOrKindCtxt (FunSigCtxt {})      = OnlyTypeCtxt
-typeOrKindCtxt (InfSigCtxt {})      = OnlyTypeCtxt
-typeOrKindCtxt (ExprSigCtxt {})     = OnlyTypeCtxt
-typeOrKindCtxt (TypeAppCtxt {})     = OnlyTypeCtxt
-typeOrKindCtxt (PatSynCtxt {})      = OnlyTypeCtxt
-typeOrKindCtxt (PatSigCtxt {})      = OnlyTypeCtxt
-typeOrKindCtxt (RuleSigCtxt {})     = OnlyTypeCtxt
-typeOrKindCtxt (ForSigCtxt {})      = OnlyTypeCtxt
-typeOrKindCtxt (DefaultDeclCtxt {}) = OnlyTypeCtxt
-typeOrKindCtxt (InstDeclCtxt {})    = OnlyTypeCtxt
-typeOrKindCtxt (SpecInstCtxt {})    = OnlyTypeCtxt
-typeOrKindCtxt (GenSigCtxt {})      = OnlyTypeCtxt
-typeOrKindCtxt (ClassSCCtxt {})     = OnlyTypeCtxt
-typeOrKindCtxt (SigmaCtxt {})       = OnlyTypeCtxt
-typeOrKindCtxt (DataTyCtxt {})      = OnlyTypeCtxt
-typeOrKindCtxt (DerivClauseCtxt {}) = OnlyTypeCtxt
-typeOrKindCtxt (ConArgCtxt {})      = OnlyTypeCtxt
-  -- Although data constructors can be promoted with DataKinds, we always
-  -- validity-check them as though they are the types of terms. We may need
-  -- to revisit this decision if we ever allow visible dependent quantification
-  -- in the types of data constructors.
-
-typeOrKindCtxt (KindSigCtxt {})           = OnlyKindCtxt
-typeOrKindCtxt (StandaloneKindSigCtxt {}) = OnlyKindCtxt
-typeOrKindCtxt (TyVarBndrKindCtxt {})     = OnlyKindCtxt
-typeOrKindCtxt (DataKindCtxt {})          = OnlyKindCtxt
-typeOrKindCtxt (TySynKindCtxt {})         = OnlyKindCtxt
-typeOrKindCtxt (TyFamResKindCtxt {})      = OnlyKindCtxt
-
-typeOrKindCtxt (TySynCtxt {}) = BothTypeAndKindCtxt
-  -- Type synonyms can have types and kinds on their RHSs
-typeOrKindCtxt (GhciCtxt {})  = BothTypeAndKindCtxt
-  -- GHCi's :kind command accepts both types and kinds
-
--- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the
--- context for a kind of a type.
--- If the 'UserTypeCtxt' can refer to both types and kinds, this function
--- conservatively returns 'True'.
---
--- An example of something that is unambiguously the kind of a type is the
--- @Show a => a -> a@ in @type Foo :: Show a => a -> a@. On the other hand, the
--- same type in @foo :: Show a => a -> a@ is unambiguously the type of a term,
--- not the kind of a type, so it is permitted.
-typeLevelUserTypeCtxt :: UserTypeCtxt -> Bool
-typeLevelUserTypeCtxt ctxt = case typeOrKindCtxt ctxt of
-  OnlyTypeCtxt        -> True
-  OnlyKindCtxt        -> False
-  BothTypeAndKindCtxt -> True
-
--- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the
--- context for a kind of a type, where the arbitrary use of constraints is
--- currently disallowed.
--- (See @Note [Constraints in kinds]@ in "GHC.Core.TyCo.Rep".)
-allConstraintsAllowed :: UserTypeCtxt -> Bool
-allConstraintsAllowed = typeLevelUserTypeCtxt
-
--- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the
--- context for a kind of a type, where all function arrows currently
--- must be unrestricted.
-linearityAllowed :: UserTypeCtxt -> Bool
-linearityAllowed = typeLevelUserTypeCtxt
-
--- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the
--- context for the type of a term, where visible, dependent quantification is
--- currently disallowed. If the 'UserTypeCtxt' can refer to both types and
--- kinds, this function conservatively returns 'True'.
---
--- An example of something that is unambiguously the type of a term is the
--- @forall a -> a -> a@ in @foo :: forall a -> a -> a@. On the other hand, the
--- same type in @type family Foo :: forall a -> a -> a@ is unambiguously the
--- kind of a type, not the type of a term, so it is permitted.
---
--- For more examples, see
--- @testsuite/tests/dependent/should_compile/T16326_Compile*.hs@ (for places
--- where VDQ is permitted) and
--- @testsuite/tests/dependent/should_fail/T16326_Fail*.hs@ (for places where
--- VDQ is disallowed).
-vdqAllowed :: UserTypeCtxt -> Bool
-vdqAllowed ctxt = case typeOrKindCtxt ctxt of
-  OnlyTypeCtxt        -> False
-  OnlyKindCtxt        -> True
-  BothTypeAndKindCtxt -> True
-
-{-
-Note [Correctness and performance of type synonym validity checking]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider the type A arg1 arg2, where A is a type synonym. How should we check
-this type for validity? We have three distinct choices, corresponding to the
-three constructors of ExpandMode:
-
-1. Expand the application of A, and check the resulting type (`Expand`).
-2. Don't expand the application of A. Only check the arguments (`NoExpand`).
-3. Check the arguments *and* check the expanded type (`Both`).
-
-It's tempting to think that we could always just pick choice (3), but this
-results in serious performance issues when checking a type like in the
-signature for `f` below:
-
-  type S = ...
-  f :: S (S (S (S (S (S ....(S Int)...))))
-
-When checking the type of `f`, we'll check the outer `S` application with and
-without expansion, and in *each* of those checks, we'll check the next `S`
-application with and without expansion... the result is exponential blowup! So
-clearly we don't want to use `Both` 100% of the time.
-
-On the other hand, neither is it correct to use exclusively `Expand` or
-exclusively `NoExpand` 100% of the time:
-
-* If one always expands, then one can miss erroneous programs like the one in
-  the `tcfail129` test case:
-
-    type Foo a = String -> Maybe a
-    type Bar m = m Int
-    blah = undefined :: Bar Foo
-
-  If we expand `Bar Foo` immediately, we'll miss the fact that the `Foo` type
-  synonyms is unsaturated.
-* If one never expands and only checks the arguments, then one can miss
-  erroneous programs like the one in #16059:
-
-    type Foo b = Eq b => b
-    f :: forall b (a :: Foo b). Int
-
-  The kind of `a` contains a constraint, which is illegal, but this will only
-  be caught if `Foo b` is expanded.
-
-Therefore, it's impossible to have these validity checks be simultaneously
-correct and performant if one sticks exclusively to a single `ExpandMode`. In
-that case, the solution is to vary the `ExpandMode`s! In more detail:
-
-1. When we start validity checking, we start with `Expand` if
-   LiberalTypeSynonyms is enabled (see Note [Liberal type synonyms] for why we
-   do this), and we start with `Both` otherwise. The `initialExpandMode`
-   function is responsible for this.
-2. When expanding an application of a type synonym (in `check_syn_tc_app`), we
-   determine which things to check based on the current `ExpandMode` argument.
-   Importantly, if the current mode is `Both`, then we check the arguments in
-   `NoExpand` mode and check the expanded type in `Both` mode.
-
-   Switching to `NoExpand` when checking the arguments is vital to avoid
-   exponential blowup. One consequence of this choice is that if you have
-   the following type synonym in one module (with RankNTypes enabled):
-
-     {-# LANGUAGE RankNTypes #-}
-     module A where
-     type A = forall a. a
-
-   And you define the following in a separate module *without* RankNTypes
-   enabled:
-
-     module B where
-
-     import A
-
-     type Const a b = a
-     f :: Const Int A -> Int
-
-   Then `f` will be accepted, even though `A` (which is technically a rank-n
-   type) appears in its type. We view this as an acceptable compromise, since
-   `A` never appears in the type of `f` post-expansion. If `A` _did_ appear in
-   a type post-expansion, such as in the following variant:
-
-     g :: Const A A -> Int
-
-   Then that would be rejected unless RankNTypes were enabled.
--}
-
--- | When validity-checking an application of a type synonym, should we
--- check the arguments, check the expanded type, or both?
--- See Note [Correctness and performance of type synonym validity checking]
-data ExpandMode
-  = Expand   -- ^ Only check the expanded type.
-  | NoExpand -- ^ Only check the arguments.
-  | Both     -- ^ Check both the arguments and the expanded type.
-
-instance Outputable ExpandMode where
-  ppr e = text $ case e of
-                   Expand   -> "Expand"
-                   NoExpand -> "NoExpand"
-                   Both     -> "Both"
-
--- | If @LiberalTypeSynonyms@ is enabled, we start in 'Expand' mode for the
--- reasons explained in @Note [Liberal type synonyms]@. Otherwise, we start
--- in 'Both' mode.
-initialExpandMode :: TcM ExpandMode
-initialExpandMode = do
-  liberal_flag <- xoptM LangExt.LiberalTypeSynonyms
-  pure $ if liberal_flag then Expand else Both
-
--- | Information about a type being validity-checked.
-data ValidityEnv = ValidityEnv
-  { ve_tidy_env :: TidyEnv
-  , ve_ctxt     :: UserTypeCtxt
-  , ve_rank     :: Rank
-  , ve_expand   :: ExpandMode }
-
-instance Outputable ValidityEnv where
-  ppr (ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt
-                  , ve_rank = rank, ve_expand = expand }) =
-    hang (text "ValidityEnv")
-       2 (vcat [ text "ve_tidy_env" <+> ppr env
-               , text "ve_ctxt"     <+> pprUserTypeCtxt ctxt
-               , text "ve_rank"     <+> ppr rank
-               , text "ve_expand"   <+> ppr expand ])
-
-----------------------------------------
-check_type :: ValidityEnv -> Type -> TcM ()
--- The args say what the *type context* requires, independent
--- of *flag* settings.  You test the flag settings at usage sites.
---
--- Rank is allowed rank for function args
--- Rank 0 means no for-alls anywhere
-
-check_type _ (TyVarTy _)
-  = return ()
-
-check_type ve (AppTy ty1 ty2)
-  = do  { check_type ve ty1
-        ; check_arg_type False ve ty2 }
-
-check_type ve ty@(TyConApp tc tys)
-  | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
-  = check_syn_tc_app ve ty tc tys
-
-  -- Check for unboxed tuples and unboxed sums: these
-  -- require the corresponding extension to be enabled.
-  | isUnboxedTupleTyCon tc
-  = check_ubx_tuple_or_sum UnboxedTupleType ve ty tys
-  | isUnboxedSumTyCon tc
-  = check_ubx_tuple_or_sum UnboxedSumType   ve ty tys
-
-  | otherwise
-  = mapM_ (check_arg_type False ve) tys
-
-check_type _ (LitTy {}) = return ()
-
-check_type ve (CastTy ty _) = check_type ve ty
-
--- Check for rank-n types, such as (forall x. x -> x) or (Show x => x).
---
--- Critically, this case must come *after* the case for TyConApp.
--- See Note [Liberal type synonyms].
-check_type ve@(ValidityEnv{ ve_tidy_env = env
-                          , ve_rank = rank, ve_expand = expand }) ty
-  | not (null tvbs && null theta)
-  = do  { traceTc "check_type" (ppr ty $$ ppr rank)
-        ; checkTcM (forAllAllowed rank) (env, TcRnForAllRankErr rank (tidyType env ty))
-                -- Reject e.g. (Maybe (?x::Int => Int)),
-                -- with a decent error message
-
-        ; checkConstraintsOK ve theta ty
-                -- Reject forall (a :: Eq b => b). blah
-                -- In a kind signature we don't allow constraints
-
-        ; checkVdqOK ve tvbs ty
-                -- Reject visible, dependent quantification in the type of a
-                -- term (e.g., `f :: forall a -> a -> Maybe a`)
-
-        ; check_valid_theta env' SigmaCtxt expand theta
-                -- Allow     type T = ?x::Int => Int -> Int
-                -- but not   type T = ?x::Int
-
-        ; check_type (ve{ve_tidy_env = env'}) tau
-                -- Allow foralls to right of arrow
-
-        }
-  where
-    (tvbs, phi)   = tcSplitForAllTyVarBinders ty
-    (theta, tau)  = tcSplitPhiTy phi
-    (env', _)     = tidyForAllTyBinders env tvbs
-
-check_type (ve@ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt
-                          , ve_rank = rank })
-           ty@(FunTy _ mult arg_ty res_ty)
-  = do  { failIfTcM (not (linearityAllowed ctxt) && not (isManyTy mult))
-                     (env, TcRnLinearFuncInKind (tidyType env ty))
-        ; check_type (ve{ve_rank = arg_rank}) arg_ty
-        ; check_type (ve{ve_rank = res_rank}) res_ty }
-  where
-    (arg_rank, res_rank) = funArgResRank rank
-
-check_type _ ty = pprPanic "check_type" (ppr ty)
-
-----------------------------------------
-check_syn_tc_app :: ValidityEnv
-                 -> KindOrType -> TyCon -> [KindOrType] -> TcM ()
--- Used for type synonyms and type synonym families,
--- which must be saturated,
--- but not data families, which need not be saturated
-check_syn_tc_app (ve@ValidityEnv{ ve_ctxt = ctxt, ve_expand = expand })
-                 ty tc tys
-  | tys `lengthAtLeast` tc_arity   -- Saturated
-       -- Check that the synonym has enough args
-       -- This applies equally to open and closed synonyms
-       -- It's OK to have an *over-applied* type synonym
-       --      data Tree a b = ...
-       --      type Foo a = Tree [a]
-       --      f :: Foo a b -> ...
-  = case expand of
-      _ |  isTypeFamilyTyCon tc
-        -> check_args_only expand
-      -- See Note [Correctness and performance of type synonym validity
-      --           checking]
-      Expand   -> check_expansion_only expand
-      NoExpand -> check_args_only expand
-      Both     -> check_args_only NoExpand *> check_expansion_only Both
-
-  | GhciCtxt True <- ctxt  -- Accept outermost under-saturated type synonym or
-                           -- type family constructors in GHCi :kind commands.
-                           -- See Note [Unsaturated type synonyms in GHCi]
-  = check_args_only expand
-
-  | otherwise
-  = failWithTc (tyConArityErr tc tys)
-  where
-    tc_arity  = tyConArity tc
-
-    check_arg :: ExpandMode -> KindOrType -> TcM ()
-    check_arg expand =
-      check_arg_type (isTypeSynonymTyCon tc) (ve{ve_expand = expand})
-
-    check_args_only, check_expansion_only :: ExpandMode -> TcM ()
-    check_args_only expand = mapM_ (check_arg expand) tys
-
-    check_expansion_only expand
-      = assertPpr (isTypeSynonymTyCon tc) (ppr tc) $
-        case coreView ty of
-         Just ty' -> let err_ctxt = text "In the expansion of type synonym"
-                                    <+> quotes (ppr tc)
-                     in addErrCtxt err_ctxt $
-                        check_type (ve{ve_expand = expand}) ty'
-         Nothing  -> pprPanic "check_syn_tc_app" (ppr ty)
-
-{-
-Note [Unsaturated type synonyms in GHCi]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Generally speaking, GHC disallows unsaturated uses of type synonyms or type
-families. For instance, if one defines `type Const a b = a`, then GHC will not
-permit using `Const` unless it is applied to (at least) two arguments. There is
-an exception to this rule, however: GHCi's :kind command. For instance, it
-is quite common to look up the kind of a type constructor like so:
-
-  λ> :kind Const
-  Const :: j -> k -> j
-  λ> :kind Const Int
-  Const Int :: k -> Type
-
-Strictly speaking, the two uses of `Const` above are unsaturated, but this
-is an extremely benign (and useful) example of unsaturation, so we allow it
-here as a special case.
-
-That being said, we do not allow unsaturation carte blanche in GHCi. Otherwise,
-this GHCi interaction would be possible:
-
-  λ> newtype Fix f = MkFix (f (Fix f))
-  λ> type Id a = a
-  λ> :kind Fix Id
-  Fix Id :: Type
-
-This is rather dodgy, so we move to disallow this. We only permit unsaturated
-synonyms in GHCi if they are *top-level*—that is, if the synonym is the
-outermost type being applied. This allows `Const` and `Const Int` in the
-first example, but not `Fix Id` in the second example, as `Id` is not the
-outermost type being applied (`Fix` is).
-
-We track this outermost property in the GhciCtxt constructor of UserTypeCtxt.
-A field of True in GhciCtxt indicates that we're in an outermost position. Any
-time we invoke `check_arg` to check the validity of an argument, we switch the
-field to False.
--}
-
-----------------------------------------
-check_ubx_tuple_or_sum :: UnboxedTupleOrSum -> ValidityEnv -> KindOrType -> [KindOrType] -> TcM ()
-check_ubx_tuple_or_sum tup_or_sum (ve@ValidityEnv{ve_tidy_env = env}) ty tys
-  = do  { ub_thing_allowed <- xoptM $ unboxedTupleOrSumExtension tup_or_sum
-        ; checkTcM ub_thing_allowed
-            (env, TcRnUnboxedTupleOrSumTypeFuncArg tup_or_sum (tidyType env ty))
-
-        ; impred <- xoptM LangExt.ImpredicativeTypes
-        ; let rank' = if impred then ArbitraryRank else MonoTypeTyConArg
-                -- c.f. check_arg_type
-                -- However, args are allowed to be unlifted, or
-                -- more unboxed tuples or sums, so can't use check_arg_ty
-        ; mapM_ (check_type (ve{ve_rank = rank'})) tys }
-
-----------------------------------------
-check_arg_type
-  :: Bool -- ^ Is this the argument to a type synonym?
-  -> ValidityEnv -> KindOrType -> TcM ()
--- The sort of type that can instantiate a type variable,
--- or be the argument of a type constructor.
--- Not an unboxed tuple, but now *can* be a forall (since impredicativity)
--- Other unboxed types are very occasionally allowed as type
--- arguments depending on the kind of the type constructor
---
--- For example, we want to reject things like:
---
---      instance Ord a => Ord (forall s. T s a)
--- and
---      g :: T s (forall b.b)
---
--- NB: unboxed tuples can have polymorphic or unboxed args.
---     This happens in the workers for functions returning
---     product types with polymorphic components.
---     But not in user code.
--- Anyway, they are dealt with by a special case in check_tau_type
-
-check_arg_type _ _ (CoercionTy {}) = return ()
-
-check_arg_type type_syn (ve@ValidityEnv{ve_ctxt = ctxt, ve_rank = rank}) ty
-  = do  { impred <- xoptM LangExt.ImpredicativeTypes
-        ; let rank' = case rank of          -- Predictive => must be monotype
-                        -- Rank-n arguments to type synonyms are OK, provided
-                        -- that LiberalTypeSynonyms is enabled.
-                        _ | type_syn       -> MonoTypeSynArg
-                        MustBeMonoType     -> MustBeMonoType  -- Monotype, regardless
-                        _other | impred    -> ArbitraryRank
-                               | otherwise -> MonoTypeTyConArg
-                        -- Make sure that MustBeMonoType is propagated,
-                        -- so that we don't suggest -XImpredicativeTypes in
-                        --    (Ord (forall a.a)) => a -> a
-                        -- and so that if it Must be a monotype, we check that it is!
-              ctxt' :: UserTypeCtxt
-              ctxt'
-                | GhciCtxt _ <- ctxt = GhciCtxt False
-                    -- When checking an argument, set the field of GhciCtxt to
-                    -- False to indicate that we are no longer in an outermost
-                    -- position (and thus unsaturated synonyms are no longer
-                    -- allowed).
-                    -- See Note [Unsaturated type synonyms in GHCi]
-                | otherwise          = ctxt
-
-        ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty }
-
-----------------------------------------
-checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM ()
-checkConstraintsOK ve theta ty
-  | null theta                         = return ()
-  | allConstraintsAllowed (ve_ctxt ve) = return ()
-  | otherwise
-  = -- We are in a kind, where we allow only equality predicates
-    -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and #16263
-    checkTcM (all isEqPred theta) (env, TcRnConstraintInKind (tidyType env ty))
-  where env = ve_tidy_env ve
-
-checkVdqOK :: ValidityEnv -> [TyVarBinder] -> Type -> TcM ()
-checkVdqOK ve tvbs ty = do
-  checkTcM (vdqAllowed ctxt || no_vdq)
-           (env, TcRnVDQInTermType (Just (tidyType env ty)))
-  where
-    no_vdq = all (isInvisibleForAllTyFlag . binderFlag) tvbs
-    ValidityEnv{ve_tidy_env = env, ve_ctxt = ctxt} = ve
-
-{-
-Note [Liberal type synonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If -XLiberalTypeSynonyms is on, expand closed type synonyms *before*
-doing validity checking.  This allows us to instantiate a synonym defn
-with a for-all type, or with a partially-applied type synonym.
-        e.g.   type T a b = a
-               type S m   = m ()
-               f :: S (T Int)
-Here, T is partially applied, so it's illegal in H98.  But if you
-expand S first, then T we get just
-               f :: Int
-which is fine.
-
-IMPORTANT: suppose T is a type synonym.  Then we must do validity
-checking on an application (T ty1 ty2)
-
-        *either* before expansion (i.e. check ty1, ty2)
-        *or* after expansion (i.e. expand T ty1 ty2, and then check)
-        BUT NOT BOTH
-
-If we do both, we get exponential behaviour!!
-
-  data TIACons1 i r c = c i ::: r c
-  type TIACons2 t x = TIACons1 t (TIACons1 t x)
-  type TIACons3 t x = TIACons2 t (TIACons1 t x)
-  type TIACons4 t x = TIACons2 t (TIACons2 t x)
-  type TIACons7 t x = TIACons4 t (TIACons3 t x)
-
-The order in which you do validity checking is also somewhat delicate. Consider
-the `check_type` function, which drives the validity checking for unsaturated
-uses of type synonyms. There is a special case for rank-n types, such as
-(forall x. x -> x) or (Show x => x), since those require at least one language
-extension to use. It used to be the case that this case came before every other
-case, but this can lead to bugs. Imagine you have this scenario (from #15954):
-
-  type A a = Int
-  type B (a :: Type -> Type) = forall x. x -> x
-  type C = B A
-
-If the rank-n case came first, then in the process of checking for `forall`s
-or contexts, we would expand away `B A` to `forall x. x -> x`. This is because
-the functions that split apart `forall`s/contexts
-(tcSplitForAllTyVarBinders/tcSplitPhiTy) expand type synonyms! If `B A` is expanded
-away to `forall x. x -> x` before the actually validity checks occur, we will
-have completely obfuscated the fact that we had an unsaturated application of
-the `A` type synonym.
-
-We have since learned from our mistakes and now put this rank-n case /after/
-the case for TyConApp, which ensures that an unsaturated `A` TyConApp will be
-caught properly. But be careful! We can't make the rank-n case /last/ either,
-as the FunTy case must came after the rank-n case. Otherwise, something like
-(Eq a => Int) would be treated as a function type (FunTy), which just
-wouldn't do.
-
-************************************************************************
-*                                                                      *
-\subsection{Checking a theta or source type}
-*                                                                      *
-************************************************************************
-
-Note [Implicit parameters in instance decls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Implicit parameters _only_ allowed in type signatures; not in instance
-decls, superclasses etc. The reason for not allowing implicit params in
-instances is a bit subtle.  If we allowed
-  instance (?x::Int, Eq a) => Foo [a] where ...
-then when we saw
-     (e :: (?x::Int) => t)
-it would be unclear how to discharge all the potential uses of the ?x
-in e.  For example, a constraint Foo [Int] might come out of e, and
-applying the instance decl would show up two uses of ?x.  #8912.
--}
-
-checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM ()
--- Assumes argument is fully zonked
-checkValidTheta ctxt theta
-  = addErrCtxtM (checkThetaCtxt ctxt theta) $
-    do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta)
-       ; expand <- initialExpandMode
-       ; check_valid_theta env ctxt expand theta }
-
--------------------------
-check_valid_theta :: TidyEnv -> UserTypeCtxt -> ExpandMode
-                  -> [PredType] -> TcM ()
-check_valid_theta _ _ _ []
-  = return ()
-check_valid_theta env ctxt expand theta
-  = do { dflags <- getDynFlags
-       ; traceTc "check_valid_theta" (ppr theta)
-       ; mapM_ (check_pred_ty env dflags ctxt expand) theta }
-
--------------------------
-{- Note [Validity checking for constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We look through constraint synonyms so that we can see the underlying
-constraint(s).  For example
-   type Foo = ?x::Int
-   instance Foo => C T
-We should reject the instance because it has an implicit parameter in
-the context.
-
-But we record, in 'under_syn', whether we have looked under a synonym
-to avoid requiring language extensions at the use site.  Main example
-(#9838):
-
-   {-# LANGUAGE ConstraintKinds #-}
-   module A where
-      type EqShow a = (Eq a, Show a)
-
-   module B where
-      import A
-      foo :: EqShow a => a -> String
-
-We don't want to require ConstraintKinds in module B.
--}
-
-check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> ExpandMode
-              -> PredType -> TcM ()
--- Check the validity of a predicate in a signature
--- See Note [Validity checking for constraints]
-check_pred_ty env dflags ctxt expand pred
-  = do { check_type ve pred
-       ; check_pred_help False env dflags ctxt pred }
-  where
-    rank | xopt LangExt.QuantifiedConstraints dflags
-         = ArbitraryRank
-         | otherwise
-         = MonoTypeConstraint
-
-    ve :: ValidityEnv
-    ve = ValidityEnv{ ve_tidy_env = env
-                    , ve_ctxt     = SigmaCtxt
-                    , ve_rank     = rank
-                    , ve_expand   = expand }
-
-check_pred_help :: Bool    -- True <=> under a type synonym
-                -> TidyEnv
-                -> DynFlags -> UserTypeCtxt
-                -> PredType -> TcM ()
-check_pred_help under_syn env dflags ctxt pred
-  | Just pred' <- coreView pred  -- Switch on under_syn when going under a
-                                 -- synonym (#9838, yuk)
-  = check_pred_help True env dflags ctxt pred'
-
-  | otherwise  -- A bit like classifyPredType, but not the same
-               -- E.g. we treat (~) like (~#); and we look inside tuples
-  = case classifyPredType pred of
-      ClassPred cls tys
-        | isCTupleClass cls   -> check_tuple_pred under_syn env dflags ctxt pred tys
-        | otherwise           -> check_class_pred env dflags ctxt pred cls tys
-
-      EqPred _ _ _      -> pprPanic "check_pred_help" (ppr pred)
-              -- EqPreds, such as (t1 ~# t2) or (t1 ~R# t2), don't even have kind Constraint
-              -- and should never appear before the '=>' of a type.  Thus
-              --     f :: (a ~# b) => blah
-              -- is wrong.  For user written signatures, it'll be rejected by kind-checking
-              -- well before we get to validity checking.  For inferred types we are careful
-              -- to box such constraints in GHC.Tc.Utils.TcType.pickQuantifiablePreds, as described
-              -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Solver
-
-      ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head
-      _                       -> return ()
-
-check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt
-                 -> PredType -> ThetaType -> PredType -> TcM ()
-check_quant_pred env dflags ctxt pred theta head_pred
-  = addErrCtxt (text "In the quantified constraint" <+> quotes (ppr pred)) $
-    do { -- Check the instance head
-         case classifyPredType head_pred of
-                                 -- SigmaCtxt tells checkValidInstHead that
-                                 -- this is the head of a quantified constraint
-            ClassPred cls tys -> do { checkValidInstHead SigmaCtxt cls tys
-                                    ; check_pred_help False env dflags ctxt head_pred }
-                               -- need check_pred_help to do extra pred-only validity
-                               -- checks, such as for (~). Otherwise, we get #17563
-                               -- NB: checks for the context are covered by the check_type
-                               -- in check_pred_ty
-            IrredPred {}      | hasTyVarHead head_pred
-                              -> return ()
-            _                 -> failWithTcM (env, TcRnBadQuantPredHead (tidyType env pred))
-
-         -- Check for termination
-       ; unless (xopt LangExt.UndecidableInstances dflags) $
-         checkInstTermination theta head_pred
-    }
-
-check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM ()
-check_tuple_pred under_syn env dflags ctxt pred ts
-  = do { -- See Note [ConstraintKinds in predicates]
-         checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags)
-                  (env, TcRnIllegalTupleConstraint (tidyType env pred))
-       ; mapM_ (check_pred_help under_syn env dflags ctxt) ts }
-    -- This case will not normally be executed because without
-    -- -XConstraintKinds tuple types are only kind-checked as *
-
-{- Note [ConstraintKinds in predicates]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Don't check for -XConstraintKinds under a type synonym, because that
-was done at the type synonym definition site; see #9838
-e.g.   module A where
-          type C a = (Eq a, Ix a)   -- Needs -XConstraintKinds
-       module B where
-          import A
-          f :: C a => a -> a        -- Does *not* need -XConstraintKinds
--}
-
--------------------------
-check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt
-                 -> PredType -> Class -> [TcType] -> TcM ()
-check_class_pred env dflags ctxt pred cls tys
-  | isEqPredClass cls    -- (~) and (~~) are classified as classes,
-                         -- but here we want to treat them as equalities
-  = -- Equational constraints are valid in all contexts, and
-    -- we do not need to check e.g. for FlexibleContexts here, so just do nothing
-    -- We used to require TypeFamilies/GADTs for equality constraints,
-    -- but not anymore (GHC Proposal #371)
-   return ()
-
-  | isIPClass cls
-  = do { check_arity
-       ; checkTcM (okIPCtxt ctxt) (env, TcRnIllegalImplicitParam (tidyType env pred)) }
-
-  | otherwise     -- Includes Coercible
-  = do { check_arity
-       ; checkSimplifiableClassConstraint env dflags ctxt cls tys
-       ; checkTcM arg_tys_ok (env, TcRnNonTypeVarArgInConstraint (tidyType env pred)) }
-  where
-    check_arity = checkTc (tys `lengthIs` classArity cls)
-                          (tyConArityErr (classTyCon cls) tys)
-
-    -- Check the arguments of a class constraint
-    flexible_contexts = xopt LangExt.FlexibleContexts     dflags
-    arg_tys_ok = case ctxt of
-        SpecInstCtxt -> True    -- {-# SPECIALISE instance Eq (T Int) #-} is fine
-        InstDeclCtxt {} -> checkValidClsArgs flexible_contexts cls tys
-                                -- Further checks on head and theta
-                                -- in checkInstTermination
-        _               -> checkValidClsArgs flexible_contexts cls tys
-
-checkSimplifiableClassConstraint :: TidyEnv -> DynFlags -> UserTypeCtxt
-                                 -> Class -> [TcType] -> TcM ()
--- See Note [Simplifiable given constraints]
-checkSimplifiableClassConstraint env dflags ctxt cls tys
-  | not (wopt Opt_WarnSimplifiableClassConstraints dflags)
-  = return ()
-  | xopt LangExt.MonoLocalBinds dflags
-  = return ()
-
-  | DataTyCtxt {} <- ctxt   -- Don't do this check for the "stupid theta"
-  = return ()               -- of a data type declaration
-
-  | cls `hasKey` coercibleTyConKey
-  = return ()   -- Oddly, we treat (Coercible t1 t2) as unconditionally OK
-                -- matchGlobalInst will reply "yes" because we can reduce
-                -- (Coercible a b) to (a ~R# b)
-
-  | otherwise
-  = do { result <- matchGlobalInst dflags False cls tys
-       ; case result of
-           OneInst { cir_what = what }
-              -> let dia = mkTcRnUnknownMessage $
-                       mkPlainDiagnostic (WarningWithFlag Opt_WarnSimplifiableClassConstraints)
-                                         noHints
-                                         (simplifiable_constraint_warn what)
-                 in addDiagnosticTc dia
-           _          -> return () }
-  where
-    pred = mkClassPred cls tys
-
-    simplifiable_constraint_warn :: InstanceWhat -> SDoc
-    simplifiable_constraint_warn what
-     = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env pred))
-                    <+> text "matches")
-                 2 (ppr what)
-            , hang (text "This makes type inference for inner bindings fragile;")
-                 2 (text "either use MonoLocalBinds, or simplify it using the instance") ]
-
-{- Note [Simplifiable given constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A type signature like
-   f :: Eq [(a,b)] => a -> b
-is very fragile, for reasons described at length in GHC.Tc.Solver.Interact
-Note [Instance and Given overlap].  As that Note discusses, for the
-most part the clever stuff in GHC.Tc.Solver.Interact means that we don't use a
-top-level instance if a local Given might fire, so there is no
-fragility. But if we /infer/ the type of a local let-binding, things
-can go wrong (#11948 is an example, discussed in the Note).
-
-So this warning is switched on only if we have NoMonoLocalBinds; in
-that case the warning discourages users from writing simplifiable
-class constraints.
-
-The warning only fires if the constraint in the signature
-matches the top-level instances in only one way, and with no
-unifiers -- that is, under the same circumstances that
-GHC.Tc.Solver.Interact.matchInstEnv fires an interaction with the top
-level instances.  For example (#13526), consider
-
-  instance {-# OVERLAPPABLE #-} Eq (T a) where ...
-  instance                   Eq (T Char) where ..
-  f :: Eq (T a) => ...
-
-We don't want to complain about this, even though the context
-(Eq (T a)) matches an instance, because the user may be
-deliberately deferring the choice so that the Eq (T Char)
-has a chance to fire when 'f' is called.  And the fragility
-only matters when there's a risk that the instance might
-fire instead of the local 'given'; and there is no such
-risk in this case.  Just use the same rules as for instance
-firing!
--}
-
--------------------------
-okIPCtxt :: UserTypeCtxt -> Bool
-  -- See Note [Implicit parameters in instance decls]
-okIPCtxt (FunSigCtxt {})        = True
-okIPCtxt (InfSigCtxt {})        = True
-okIPCtxt (ExprSigCtxt {})       = True
-okIPCtxt TypeAppCtxt            = True
-okIPCtxt PatSigCtxt             = True
-okIPCtxt GenSigCtxt             = True
-okIPCtxt (ConArgCtxt {})        = True
-okIPCtxt (ForSigCtxt {})        = True  -- ??
-okIPCtxt (GhciCtxt {})          = True
-okIPCtxt SigmaCtxt              = True
-okIPCtxt (DataTyCtxt {})        = True
-okIPCtxt (PatSynCtxt {})        = True
-okIPCtxt (TySynCtxt {})         = True   -- e.g.   type Blah = ?x::Int
-                                         -- #11466
-
-okIPCtxt (KindSigCtxt {})       = False
-okIPCtxt (StandaloneKindSigCtxt {}) = False
-okIPCtxt (ClassSCCtxt {})       = False
-okIPCtxt (InstDeclCtxt {})      = False
-okIPCtxt (SpecInstCtxt {})      = False
-okIPCtxt (RuleSigCtxt {})       = False
-okIPCtxt DefaultDeclCtxt        = False
-okIPCtxt DerivClauseCtxt        = False
-okIPCtxt (TyVarBndrKindCtxt {}) = False
-okIPCtxt (DataKindCtxt {})      = False
-okIPCtxt (TySynKindCtxt {})     = False
-okIPCtxt (TyFamResKindCtxt {})  = False
-
-{-
-Note [Kind polymorphic type classes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-MultiParam check:
-
-    class C f where...   -- C :: forall k. k -> Constraint
-    instance C Maybe where...
-
-  The dictionary gets type [C * Maybe] even if it's not a MultiParam
-  type class.
-
-Flexibility check:
-
-    class C f where...   -- C :: forall k. k -> Constraint
-    data D a = D a
-    instance C D where
-
-  The dictionary gets type [C * (D *)]. IA0_TODO it should be
-  generalized actually.
--}
-
-checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc)
-checkThetaCtxt ctxt theta env
-  = return ( env
-           , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta)
-                  , text "While checking" <+> pprUserTypeCtxt ctxt ] )
-
-tyConArityErr :: TyCon -> [TcType] -> TcRnMessage
--- For type-constructor arity errors, be careful to report
--- the number of /visible/ arguments required and supplied,
--- ignoring the /invisible/ arguments, which the user does not see.
--- (e.g. #10516)
-tyConArityErr tc tks
-  = arityErr (ppr (tyConFlavour tc)) (tyConName tc)
-             tc_type_arity tc_type_args
-  where
-    vis_tks = filterOutInvisibleTypes tc tks
-
-    -- tc_type_arity = number of *type* args expected
-    -- tc_type_args  = number of *type* args encountered
-    tc_type_arity = count isVisibleTyConBinder (tyConBinders tc)
-    tc_type_args  = length vis_tks
-
-arityErr :: Outputable a => SDoc -> a -> Int -> Int -> TcRnMessage
-arityErr what name n m
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    hsep [ text "The" <+> what, quotes (ppr name), text "should have",
-           n_arguments <> comma, text "but has been given",
-           if m==0 then text "none" else int m]
-    where
-        n_arguments | n == 0 = text "no arguments"
-                    | n == 1 = text "1 argument"
-                    | True   = hsep [int n, text "arguments"]
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Checking for a decent instance head type}
-*                                                                      *
-************************************************************************
-
-@checkValidInstHead@ checks the type {\em and} its syntactic constraints:
-it must normally look like: @instance Foo (Tycon a b c ...) ...@
-
-The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
-flag is on, or (2)~the instance is imported (they must have been
-compiled elsewhere). In these cases, we let them go through anyway.
-
-We can also have instances for functions: @instance Foo (a -> b) ...@.
--}
-
-checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()
-checkValidInstHead ctxt clas cls_args
-  = do { dflags   <- getDynFlags
-       ; is_boot  <- tcIsHsBootOrSig
-       ; is_sig   <- tcIsHsig
-       ; check_special_inst_head dflags is_boot is_sig ctxt clas cls_args
-       ; checkValidTypePats (classTyCon clas) cls_args
-       }
-
-{-
-
-Note [Instances of built-in classes in signature files]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-User defined instances for KnownNat, KnownSymbol, KnownChar,
-and Typeable are disallowed
-  -- they are generated when needed by GHC itself, on-the-fly.
-
-However, if they occur in a Backpack signature file, they have an
-entirely different meaning. To illustrate, suppose in M.hsig we see
-
-  signature M where
-    data T :: Nat
-    instance KnownNat T
-
-That says that any module satisfying M.hsig must provide a KnownNat
-instance for T.  We absolutely need that instance when compiling a
-module that imports M.hsig: see #15379 and
-Note [Fabricating Evidence for Literals in Backpack] in GHC.Tc.Instance.Class.
-
-Hence, checkValidInstHead accepts a user-written instance declaration
-in hsig files, where `is_sig` is True.
-
--}
-
-check_special_inst_head :: DynFlags -> Bool -> Bool
-                        -> UserTypeCtxt -> Class -> [Type] -> TcM ()
--- Wow!  There are a surprising number of ad-hoc special cases here.
--- TODO: common up the logic for special typeclasses (see GHC ticket #20441).
-check_special_inst_head dflags is_boot is_sig ctxt clas cls_args
-
-  -- If not in an hs-boot file, abstract classes cannot have instances
-  | isAbstractClass clas
-  , not is_boot
-  = failWithTc (TcRnAbstractClassInst clas)
-
-  -- Complain about hand-written instances of built-in classes
-  -- Typeable, KnownNat, KnownSymbol, Coercible, HasField.
-
-  -- Disallow hand-written Typeable instances, except that we
-  -- allow a standalone deriving declaration: they are no-ops,
-  -- and we warn about them in GHC.Tc.Deriv.deriveStandalone.
-  | clas_nm == typeableClassName
-  , not is_sig
-    -- Note [Instances of built-in classes in signature files]
-  , hand_written_bindings
-  = failWithTc $ TcRnSpecialClassInst clas False
-
-  -- Handwritten instances of KnownNat/KnownChar/KnownSymbol
-  -- are forbidden outside of signature files (#12837).
-  -- Derived instances are forbidden completely (#21087).
-  | clas_nm `elem` [ knownNatClassName, knownSymbolClassName, knownCharClassName ]
-  , (not is_sig && hand_written_bindings) || derived_instance
-    -- Note [Instances of built-in classes in signature files]
-  = failWithTc $ TcRnSpecialClassInst clas False
-
-  -- For the most part we don't allow
-  -- instances for (~), (~~), or Coercible;
-  -- but we DO want to allow them in quantified constraints:
-  --   f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m...
-  | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName, withDictClassName ]
-  , not quantified_constraint
-  = failWithTc $ TcRnSpecialClassInst clas False
-
-  -- Check for hand-written Generic instances (disallowed in Safe Haskell)
-  | clas_nm `elem` genericClassNames
-  , hand_written_bindings
-  =  do { failIfTc (safeLanguageOn dflags) (TcRnSpecialClassInst clas True)
-        ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) }
-
-  | clas_nm == hasFieldClassName
-  , not quantified_constraint
-  -- Don't do any validity checking for HasField contexts
-  -- inside quantified constraints (#20989): the validity checks
-  -- only apply to user-written instances.
-  = checkHasFieldInst clas cls_args
-
-  | isCTupleClass clas
-  = failWithTc (TcRnTupleConstraintInst clas)
-
-  -- Check language restrictions on the args to the class
-  | check_h98_arg_shape
-  , Just msg <- mb_ty_args_msg
-  = failWithTc (instTypeErr clas cls_args msg)
-
-  | otherwise
-  = pure ()
-  where
-    clas_nm = getName clas
-    ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
-
-    hand_written_bindings
-      = case ctxt of
-          InstDeclCtxt standalone -> not standalone
-          SpecInstCtxt            -> False
-          DerivClauseCtxt         -> False
-          SigmaCtxt               -> False
-          _                       -> True
-
-    derived_instance
-      = case ctxt of
-            InstDeclCtxt standalone -> standalone
-            DerivClauseCtxt         -> True
-            _                       -> False
-
-    check_h98_arg_shape = case ctxt of
-                            SpecInstCtxt    -> False
-                            DerivClauseCtxt -> False
-                            SigmaCtxt       -> False
-                            _               -> True
-        -- SigmaCtxt: once we are in quantified-constraint land, we
-        -- aren't so picky about enforcing H98-language restrictions
-        -- E.g. we want to allow a head like Coercible (m a) (m b)
-
-
-    -- When we are looking at the head of a quantified constraint,
-    -- check_quant_pred sets ctxt to SigmaCtxt
-    quantified_constraint = case ctxt of
-                              SigmaCtxt -> True
-                              _         -> False
-
-    head_type_synonym_msg = parens (
-                text "All instance types must be of the form (T t1 ... tn)" $$
-                text "where T is not a synonym." $$
-                text "Use TypeSynonymInstances if you want to disable this.")
-
-    head_type_args_tyvars_msg = parens (vcat [
-                text "All instance types must be of the form (T a1 ... an)",
-                text "where a1 ... an are *distinct type variables*,",
-                text "and each type variable appears at most once in the instance head.",
-                text "Use FlexibleInstances if you want to disable this."])
-
-    head_one_type_msg = parens $
-                        text "Only one type can be given in an instance head." $$
-                        text "Use MultiParamTypeClasses if you want to allow more, or zero."
-
-    mb_ty_args_msg
-      | not (xopt LangExt.TypeSynonymInstances dflags)
-      , not (all tcInstHeadTyNotSynonym ty_args)
-      = Just head_type_synonym_msg
-
-      | not (xopt LangExt.FlexibleInstances dflags)
-      , not (all tcInstHeadTyAppAllTyVars ty_args)
-      = Just head_type_args_tyvars_msg
-
-      | length ty_args /= 1
-      , not (xopt LangExt.MultiParamTypeClasses dflags)
-      , not (xopt LangExt.NullaryTypeClasses dflags && null ty_args)
-      = Just head_one_type_msg
-
-      | otherwise
-      = Nothing
-
-tcInstHeadTyNotSynonym :: Type -> Bool
--- Used in Haskell-98 mode, for the argument types of an instance head
--- These must not be type synonyms, but everywhere else type synonyms
--- are transparent, so we need a special function here
-tcInstHeadTyNotSynonym ty
-  = case ty of  -- Do not use splitTyConApp,
-                -- because that expands synonyms!
-        TyConApp tc _ -> not (isTypeSynonymTyCon tc) || tc == unrestrictedFunTyCon
-                -- Allow (->), e.g. instance Category (->),
-                -- even though it's a type synonym for FUN 'Many
-        _ -> True
-
-tcInstHeadTyAppAllTyVars :: Type -> Bool
--- Used in Haskell-98 mode, for the argument types of an instance head
--- These must be a constructor applied to type variable arguments
--- or a type-level literal.
--- But we allow
--- 1) kind instantiations
--- 2) the type (->) = FUN 'Many, even though it's not in this form.
-tcInstHeadTyAppAllTyVars ty
-  | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty)
-  = let tys' = filterOutInvisibleTypes tc tys  -- avoid kinds
-        tys'' | tc `hasKey` fUNTyConKey
-              , ManyTy : tys_t <- tys'
-              = tys_t
-              | otherwise = tys'
-    in ok tys''
-  | LitTy _ <- ty = True  -- accept type literals (#13833)
-  | otherwise
-  = False
-  where
-        -- Check that all the types are type variables,
-        -- and that each is distinct
-    ok tys = equalLength tvs tys && hasNoDups tvs
-           where
-             tvs = mapMaybe getTyVar_maybe tys
-
-dropCasts :: Type -> Type
--- See Note [Casts during validity checking]
--- This function can turn a well-kinded type into an ill-kinded
--- one, so I've kept it local to this module
--- To consider: drop only HoleCo casts
-dropCasts (CastTy ty _)       = dropCasts ty
-dropCasts (AppTy t1 t2)       = mkAppTy (dropCasts t1) (dropCasts t2)
-dropCasts ty@(FunTy _ w t1 t2)  = ty { ft_mult = dropCasts w, ft_arg = dropCasts t1, ft_res = dropCasts t2 }
-dropCasts (TyConApp tc tys)   = mkTyConApp tc (map dropCasts tys)
-dropCasts (ForAllTy b ty)     = ForAllTy (dropCastsB b) (dropCasts ty)
-dropCasts ty                  = ty  -- LitTy, TyVarTy, CoercionTy
-
-dropCastsB :: TyVarBinder -> TyVarBinder
-dropCastsB b = b   -- Don't bother in the kind of a forall
-
-instTypeErr :: Class -> [Type] -> SDoc -> TcRnMessage
-instTypeErr cls tys msg
-  = mkTcRnUnknownMessage $ mkPlainError noHints $
-    hang (hang (text "Illegal instance declaration for")
-             2 (quotes (pprClassPred cls tys)))
-       2 msg
-
--- | See Note [Validity checking of HasField instances]
-checkHasFieldInst :: Class -> [Type] -> TcM ()
-checkHasFieldInst cls tys@[_k_ty, x_ty, r_ty, _a_ty] =
-  case splitTyConApp_maybe r_ty of
-    Nothing -> whoops (text "Record data type must be specified")
-    Just (tc, _)
-      | isFamilyTyCon tc
-                  -> whoops (text "Record data type may not be a data family")
-      | otherwise -> case isStrLitTy x_ty of
-       Just lbl
-         | isJust (lookupTyConFieldLabel (FieldLabelString lbl) tc)
-                     -> whoops (ppr tc <+> text "already has a field"
-                                       <+> quotes (ppr lbl))
-         | otherwise -> return ()
-       Nothing
-         | null (tyConFieldLabels tc) -> return ()
-         | otherwise -> whoops (ppr tc <+> text "has fields")
-  where
-    whoops = addErrTc . instTypeErr cls tys
-checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys)
-
-{- Note [Casts during validity checking]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider the (bogus)
-     instance Eq Char#
-We elaborate to  'Eq (Char# |> UnivCo(hole))'  where the hole is an
-insoluble equality constraint for Type ~ TYPE WordRep.  We'll report the insoluble
-constraint separately, but we don't want to *also* complain that Eq is
-not applied to a type constructor.  So we look gaily look through
-CastTys here.
-
-Another example:  Eq (Either a).  Then we actually get a cast in
-the middle:
-   Eq ((Either |> g) a)
-
-
-Note [Validity checking of HasField instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The HasField class has magic constraint solving behaviour (see Note
-[HasField instances] in GHC.Tc.Solver.Interact).  However, we permit users to
-declare their own instances, provided they do not clash with the
-built-in behaviour.  In particular, we forbid:
-
-  1. `HasField _ r _` where r is a variable
-
-  2. `HasField _ (T ...) _` if T is a data family
-     (because it might have fields introduced later)
-
-  3. `HasField x (T ...) _` where x is a variable,
-      if T has any fields at all
-
-  4. `HasField "foo" (T ...) _` if T has a "foo" field
-
-The usual functional dependency checks also apply.
-
-
-Note [Valid 'deriving' predicate]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-validDerivPred checks for OK 'deriving' context.  See Note [Exotic
-derived instance contexts] in GHC.Tc.Deriv.  However the predicate is
-here because it uses sizeTypes, fvTypes.
-
-It checks for three things
-
-(VD1) No repeated variables (hasNoDups fvs)
-
-(VD2) No type constructors.  This is done by comparing
-        sizeTypes tys == length (fvTypes tys)
-      sizeTypes counts variables and constructors; fvTypes returns variables.
-      So if they are the same, there must be no constructors.  But there
-      might be applications thus (f (g x)).
-
-      Note that tys only includes the visible arguments of the class type
-      constructor. Including the non-visible arguments can cause the following,
-      perfectly valid instance to be rejected:
-         class Category (cat :: k -> k -> *) where ...
-         newtype T (c :: * -> * -> *) a b = MkT (c a b)
-         instance Category c => Category (T c) where ...
-      since the first argument to Category is a non-visible *, which sizeTypes
-      would count as a constructor! See #11833.
-
-(VD3) Also check for a bizarre corner case, when the derived instance decl
-      would look like
-         instance C a b => D (T a) where ...
-      Note that 'b' isn't a parameter of T.  This gives rise to all sorts of
-      problems; in particular, it's hard to compare solutions for equality
-      when finding the fixpoint, and that means the inferContext loop does
-      not converge.  See #5287, #21302
-
-Note [Equality class instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We can't have users writing instances for the equality classes. But we
-still need to be able to write instances for them ourselves. So we allow
-instances only in the defining module.
-
--}
-
-validDerivPred :: TyVarSet -> PredType -> Bool
--- See Note [Valid 'deriving' predicate]
-validDerivPred tv_set pred
-  | not (tyCoVarsOfType pred `subVarSet` tv_set)
-  = False  -- Check (VD3)
-
-  | otherwise
-  = case classifyPredType pred of
-
-       ClassPred cls tys
-          | isTerminatingClass cls -> True
-            -- Typeable constraints are bigger than they appear due
-            -- to kind polymorphism, but that's OK
-
-          | otherwise -> hasNoDups visible_fvs                        -- Check (VD1)
-                      && lengthIs visible_fvs (sizeTypes visible_tys) -- Check (VD2)
-          where
-            visible_tys = filterOutInvisibleTypes (classTyCon cls) tys
-            visible_fvs = fvTypes visible_tys
-
-       IrredPred {}   -> True   -- Accept (f a)
-       EqPred {}      -> False  -- Reject equality constraints
-       ForAllPred {}  -> False  -- Rejects quantified predicates
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Checking instance for termination}
-*                                                                      *
-************************************************************************
--}
-
-{- Note [Instances and constraint synonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Currently, we don't allow instances for constraint synonyms at all.
-Consider these (#13267):
-  type C1 a = Show (a -> Bool)
-  instance C1 Int where    -- I1
-    show _ = "ur"
-
-This elicits "show is not a (visible) method of class C1", which isn't
-a great message. But it comes from the renamer, so it's hard to improve.
-
-This needs a bit more care:
-  type C2 a = (Show a, Show Int)
-  instance C2 Int           -- I2
-
-If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose
-the instance head, we'll expand the synonym on fly, and it'll look like
-  instance (%,%) (Show Int, Show Int)
-and we /really/ don't want that.  So we carefully do /not/ expand
-synonyms, by matching on TyConApp directly.
--}
-
-checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM ()
-checkValidInstance ctxt hs_type ty = case tau of
-  -- See Note [Instances and constraint synonyms]
-  TyConApp tc inst_tys -> case tyConClass_maybe tc of
-    Nothing -> failWithTc (TcRnIllegalClassInst (tyConFlavour tc))
-    Just clas -> do
-        { setSrcSpanA head_loc $
-          checkValidInstHead ctxt clas inst_tys
-
-        ; traceTc "checkValidInstance {" (ppr ty)
-
-        ; env0 <- tcInitTidyEnv
-        ; expand <- initialExpandMode
-        ; check_valid_theta env0 ctxt expand theta
-
-        -- The Termination and Coverage Conditions
-        -- Check that instance inference will terminate (if we care)
-        -- For Haskell 98 this will already have been done by checkValidTheta,
-        -- but as we may be using other extensions we need to check.
-        --
-        -- Note that the Termination Condition is *more conservative* than
-        -- the checkAmbiguity test we do on other type signatures
-        --   e.g.  Bar a => Bar Int is ambiguous, but it also fails
-        --   the termination condition, because 'a' appears more often
-        --   in the constraint than in the head
-        ; undecidable_ok <- xoptM LangExt.UndecidableInstances
-        ; if undecidable_ok
-          then checkAmbiguity ctxt ty
-          else checkInstTermination theta tau
-
-        ; traceTc "cvi 2" (ppr ty)
-
-        ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of
-            IsValid      -> return ()   -- Check succeeded
-            NotValid msg -> addErrTc (instTypeErr clas inst_tys msg)
-
-        ; traceTc "End checkValidInstance }" empty
-
-        ; return () }
-  _ -> failWithTc (TcRnNoClassInstHead tau)
-  where
-    (_tvs, theta, tau)   = tcSplitSigmaTy ty
-
-        -- The location of the "head" of the instance
-    head_loc = getLoc (getLHsInstDeclHead hs_type)
-
-{-
-Note [Paterson conditions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-Termination test: the so-called "Paterson conditions" (see Section 5 of
-"Understanding functional dependencies via Constraint Handling Rules,
-JFP Jan 2007).
-
-We check that each assertion in the context satisfies:
- (1) no variable has more occurrences in the assertion than in the head, and
- (2) the assertion has fewer constructors and variables (taken together
-     and counting repetitions) than the head.
-This is only needed with -fglasgow-exts, as Haskell 98 restrictions
-(which have already been checked) guarantee termination.
-
-The underlying idea is that
-
-    for any ground substitution, each assertion in the
-    context has fewer type constructors than the head.
--}
-
-checkInstTermination :: ThetaType -> TcPredType -> TcM ()
--- See Note [Paterson conditions]
-checkInstTermination theta head_pred
-  = check_preds emptyVarSet theta
-  where
-   head_fvs  = fvType head_pred
-   head_size = sizeType head_pred
-
-   check_preds :: VarSet -> [PredType] -> TcM ()
-   check_preds foralld_tvs preds = mapM_ (check foralld_tvs) preds
-
-   check :: VarSet -> PredType -> TcM ()
-   check foralld_tvs pred
-     = case classifyPredType pred of
-         EqPred {}      -> return ()  -- See #4200.
-         IrredPred {}   -> check2 foralld_tvs pred (sizeType pred)
-         ClassPred cls tys
-           | isTerminatingClass cls
-           -> return ()
-
-           | isCTupleClass cls  -- Look inside tuple predicates; #8359
-           -> check_preds foralld_tvs tys
-
-           | otherwise          -- Other ClassPreds
-           -> check2 foralld_tvs pred bogus_size
-           where
-              bogus_size = 1 + sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys)
-                               -- See Note [Invisible arguments and termination]
-
-         ForAllPred tvs _ head_pred'
-           -> check (foralld_tvs `extendVarSetList` tvs) head_pred'
-              -- Termination of the quantified predicate itself is checked
-              -- when the predicates are individually checked for validity
-
-   check2 foralld_tvs pred pred_size
-     | not (null bad_tvs)     = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-       (noMoreMsg bad_tvs what (ppr head_pred))
-     | not (isTyFamFree pred) = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-       (nestedMsg what)
-     | pred_size >= head_size = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-       (smallerMsg what (ppr head_pred))
-     | otherwise              = return ()
-     -- isTyFamFree: see Note [Type families in instance contexts]
-     where
-        what    = text "constraint" <+> quotes (ppr pred)
-        bad_tvs = filterOut (`elemVarSet` foralld_tvs) (fvType pred)
-                  \\ head_fvs
-
-smallerMsg :: SDoc -> SDoc -> SDoc
-smallerMsg what inst_head
-  = vcat [ hang (text "The" <+> what)
-              2 (sep [ text "is no smaller than"
-                     , text "the instance head" <+> quotes inst_head ])
-         , parens undecidableMsg ]
-
-noMoreMsg :: [TcTyVar] -> SDoc -> SDoc -> SDoc
-noMoreMsg tvs what inst_head
-  = vcat [ hang (text "Variable" <> plural tvs1 <+> quotes (pprWithCommas ppr tvs1)
-                <+> occurs <+> text "more often")
-              2 (sep [ text "in the" <+> what
-                     , text "than in the instance head" <+> quotes inst_head ])
-         , parens undecidableMsg ]
-  where
-   tvs1   = nub tvs
-   occurs = if isSingleton tvs1 then text "occurs"
-                               else text "occur"
-
-undecidableMsg :: SDoc
-undecidableMsg = text "Use UndecidableInstances to permit this"
-
-{- Note [Type families in instance contexts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Are these OK?
-  type family F a
-  instance F a    => C (Maybe [a]) where ...
-  instance C (F a) => C [[[a]]]     where ...
-
-No: the type family in the instance head might blow up to an
-arbitrarily large type, depending on how 'a' is instantiated.
-So we require UndecidableInstances if we have a type family
-in the instance head.  #15172.
-
-Note [Invisible arguments and termination]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When checking the ​Paterson conditions for termination an instance
-declaration, we check for the number of "constructors and variables"
-in the instance head and constraints. Question: Do we look at
-
- * All the arguments, visible or invisible?
- * Just the visible arguments?
-
-I think both will ensure termination, provided we are consistent.
-Currently we are /not/ consistent, which is really a bug.  It's
-described in #15177, which contains a number of examples.
-The suspicious bits are the calls to filterOutInvisibleTypes.
--}
-
-
-{-
-************************************************************************
-*                                                                      *
-        Checking type instance well-formedness and termination
-*                                                                      *
-************************************************************************
--}
-
-checkValidCoAxiom :: CoAxiom Branched -> TcM ()
-checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })
-  = do { mapM_ (checkValidCoAxBranch fam_tc) branch_list
-       ; foldlM_ check_branch_compat [] branch_list }
-  where
-    branch_list = fromBranches branches
-    injectivity = tyConInjectivityInfo fam_tc
-
-    check_branch_compat :: [CoAxBranch]    -- previous branches in reverse order
-                        -> CoAxBranch      -- current branch
-                        -> TcM [CoAxBranch]-- current branch : previous branches
-    -- Check for
-    --   (a) this branch is dominated by previous ones
-    --   (b) failure of injectivity
-    check_branch_compat prev_branches cur_branch
-      | cur_branch `isDominatedBy` prev_branches
-      = do { let dia = mkTcRnUnknownMessage $
-                   mkPlainDiagnostic WarningWithoutFlag noHints (inaccessibleCoAxBranch fam_tc cur_branch)
-           ; addDiagnosticAt (coAxBranchSpan cur_branch) dia
-           ; return prev_branches }
-      | otherwise
-      = do { check_injectivity prev_branches cur_branch
-           ; return (cur_branch : prev_branches) }
-
-     -- Injectivity check: check whether a new (CoAxBranch) can extend
-     -- already checked equations without violating injectivity
-     -- annotation supplied by the user.
-     -- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv
-    check_injectivity prev_branches cur_branch
-      | Injective inj <- injectivity
-      = do { dflags <- getDynFlags
-           ; let conflicts =
-                     fst $ foldl' (gather_conflicts inj prev_branches cur_branch)
-                                 ([], 0) prev_branches
-           ; reportConflictingInjectivityErrs fam_tc conflicts cur_branch
-           ; reportInjectivityErrors dflags ax cur_branch inj }
-      | otherwise
-      = return ()
-
-    gather_conflicts inj prev_branches cur_branch (acc, n) branch
-               -- n is 0-based index of branch in prev_branches
-      = case injectiveBranches inj cur_branch branch of
-           -- Case 1B2 in Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv
-          InjectivityUnified ax1 ax2
-            | ax1 `isDominatedBy` (replace_br prev_branches n ax2)
-                -> (acc, n + 1)
-            | otherwise
-                -> (branch : acc, n + 1)
-          InjectivityAccepted -> (acc, n + 1)
-
-    -- Replace n-th element in the list. Assumes 0-based indexing.
-    replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch]
-    replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs
-
-
--- Check that a "type instance" is well-formed (which includes decidability
--- unless -XUndecidableInstances is given).
---
-checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM ()
-checkValidCoAxBranch fam_tc
-                    (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
-                                , cab_lhs = typats
-                                , cab_rhs = rhs, cab_loc = loc })
-  = setSrcSpan loc $
-    checkValidTyFamEqn fam_tc (tvs++cvs) typats rhs
-
--- | Do validity checks on a type family equation, including consistency
--- with any enclosing class instance head, termination, and lack of
--- polytypes.
-checkValidTyFamEqn :: TyCon   -- ^ of the type family
-                   -> [Var]   -- ^ Bound variables in the equation
-                   -> [Type]  -- ^ Type patterns
-                   -> Type    -- ^ Rhs
-                   -> TcM ()
-checkValidTyFamEqn fam_tc qvs typats rhs
-  = do { checkValidTypePats fam_tc typats
-
-         -- Check for things used on the right but not bound on the left
-       ; checkFamPatBinders fam_tc qvs typats rhs
-
-         -- Check for oversaturated visible kind arguments in a type family
-         -- equation.
-         -- See Note [Oversaturated type family equations]
-       ; when (isTypeFamilyTyCon fam_tc) $
-           case drop (tyConArity fam_tc) typats of
-             [] -> pure ()
-             spec_arg:_ ->
-               addErr (TcRnOversaturatedVisibleKindArg spec_arg)
-
-         -- The argument patterns, and RHS, are all boxed tau types
-         -- E.g  Reject type family F (a :: k1) :: k2
-         --             type instance F (forall a. a->a) = ...
-         --             type instance F Int#             = ...
-         --             type instance F Int              = forall a. a->a
-         --             type instance F Int              = Int#
-         -- See #9357
-       ; checkValidMonoType rhs
-
-         -- We have a decidable instance unless otherwise permitted
-       ; undecidable_ok <- xoptM LangExt.UndecidableInstances
-       ; traceTc "checkVTFE" (ppr fam_tc $$ ppr rhs $$ ppr (tcTyFamInsts rhs))
-       ; unless undecidable_ok $
-         mapM_ addErrTc (checkFamInstRhs fam_tc typats (tcTyFamInsts rhs)) }
-
--- | Checks that an associated type family default:
---
--- 1. Only consists of arguments that are bare type variables, and
---
--- 2. Has a distinct type variable in each argument.
---
--- See @Note [Type-checking default assoc decls]@ in "GHC.Tc.TyCl".
-checkValidAssocTyFamDeflt :: TyCon  -- ^ of the type family
-                          -> [Type] -- ^ Type patterns
-                          -> TcM ()
-checkValidAssocTyFamDeflt fam_tc pats =
-  do { cpt_tvs <- zipWithM extract_tv pats pats_vis
-     ; check_all_distinct_tvs $ zip cpt_tvs pats_vis }
-  where
-    pats_vis :: [ForAllTyFlag]
-    pats_vis = tyConForAllTyFlags fam_tc pats
-
-    -- Checks that a pattern on the LHS of a default is a type
-    -- variable. If so, return the underlying type variable, and if
-    -- not, throw an error.
-    -- See Note [Type-checking default assoc decls]
-    extract_tv :: Type          -- The particular type pattern from which to
-                                -- extrace its underlying type variable
-               -> ForAllTyFlag  -- The visibility of the type pattern
-                                -- (only used for error message purposes)
-               -> TcM TyVar
-    extract_tv pat pat_vis =
-      case getTyVar_maybe pat of
-        Just tv -> pure tv
-        Nothing -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-          pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $
-          hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:")
-             2 (vcat [ppr_eqn, suggestion])
-
-    -- Checks that no type variables in an associated default declaration are
-    -- duplicated. If that is the case, throw an error.
-    -- See Note [Type-checking default assoc decls]
-    check_all_distinct_tvs ::
-         [(TyVar, ForAllTyFlag)] -- The type variable arguments in the associated
-                            -- default declaration, along with their respective
-                            -- visibilities (the latter are only used for error
-                            -- message purposes)
-      -> TcM ()
-    check_all_distinct_tvs cpt_tvs_vis =
-      let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in
-      traverse_
-        (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $
-              mkTcRnUnknownMessage $ mkPlainError noHints $
-               pprWithExplicitKindsWhen (isInvisibleForAllTyFlag pat_vis) $
-               hang (text "Illegal duplicate variable"
-                       <+> quotes (ppr pat_tv) <+> text "in:")
-                  2 (vcat [ppr_eqn, suggestion]))
-        dups
-
-    ppr_eqn :: SDoc
-    ppr_eqn =
-      quotes (text "type" <+> ppr (mkTyConApp fam_tc pats)
-                <+> equals <+> text "...")
-
-    suggestion :: SDoc
-    suggestion = text "The arguments to" <+> quotes (ppr fam_tc)
-             <+> text "must all be distinct type variables"
-
--- Make sure that each type family application is
---   (1) strictly smaller than the lhs,
---   (2) mentions no type variable more often than the lhs, and
---   (3) does not contain any further type family instances.
---
-checkFamInstRhs :: TyCon -> [Type]         -- LHS
-                -> [(TyCon, [Type])]       -- type family calls in RHS
-                -> [TcRnMessage]
-checkFamInstRhs lhs_tc lhs_tys famInsts
-  = map (mkTcRnUnknownMessage . mkPlainError noHints) $ mapMaybe check famInsts
-  where
-   lhs_size  = sizeTyConAppArgs lhs_tc lhs_tys
-   inst_head = pprType (TyConApp lhs_tc lhs_tys)
-   lhs_fvs   = fvTypes lhs_tys
-   check (tc, tys)
-      | not (all isTyFamFree tys) = Just (nestedMsg what)
-      | not (null bad_tvs)        = Just (noMoreMsg bad_tvs what inst_head)
-      | lhs_size <= fam_app_size  = Just (smallerMsg what inst_head)
-      | otherwise                 = Nothing
-      where
-        what = text "type family application"
-               <+> quotes (pprType (TyConApp tc tys))
-        fam_app_size = sizeTyConAppArgs tc tys
-        bad_tvs      = fvTypes tys \\ lhs_fvs
-                       -- The (\\) is list difference; e.g.
-                       --   [a,b,a,a] \\ [a,a] = [b,a]
-                       -- So we are counting repetitions
-
------------------
-checkFamPatBinders :: TyCon
-                   -> [TcTyVar]   -- Bound on LHS of family instance
-                   -> [TcType]    -- LHS patterns
-                   -> Type        -- RHS
-                   -> TcM ()
-checkFamPatBinders fam_tc qtvs pats rhs
-  = do { traceTc "checkFamPatBinders" $
-         vcat [ debugPprType (mkTyConApp fam_tc pats)
-              , ppr (mkTyConApp fam_tc pats)
-              , text "qtvs:" <+> ppr qtvs
-              , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs)
-              , text "cpt_tvs:" <+> ppr cpt_tvs
-              , text "inj_cpt_tvs:" <+> ppr inj_cpt_tvs ]
-
-         -- Check for implicitly-bound tyvars, mentioned on the
-         -- RHS but not bound on the LHS
-         --    data T            = MkT (forall (a::k). blah)
-         --    data family D Int = MkD (forall (a::k). blah)
-         -- In both cases, 'k' is not bound on the LHS, but is used on the RHS
-         -- We catch the former in kcDeclHeader, and the latter right here
-         -- See Note [Check type-family instance binders]
-       ; check_tvs bad_rhs_tvs (text "mentioned in the RHS")
-                               (text "bound on the LHS of")
-
-         -- Check for explicitly forall'd variable that is not bound on LHS
-         --    data instance forall a.  T Int = MkT Int
-         -- See Note [Unused explicitly bound variables in a family pattern]
-         -- See Note [Check type-family instance binders]
-       ; check_tvs bad_qtvs (text "bound by a forall")
-                            (text "used in")
-       }
-  where
-    cpt_tvs     = tyCoVarsOfTypes pats
-    inj_cpt_tvs = fvVarSet $ injectiveVarsOfTypes False pats
-      -- The type variables that are in injective positions.
-      -- See Note [Dodgy binding sites in type family instances]
-      -- NB: The False above is irrelevant, as we never have type families in
-      -- patterns.
-      --
-      -- NB: It's OK to use the nondeterministic `fvVarSet` function here,
-      -- since the order of `inj_cpt_tvs` is never revealed in an error
-      -- message.
-    rhs_fvs     = tyCoFVsOfType rhs
-    used_tvs    = cpt_tvs `unionVarSet` fvVarSet rhs_fvs
-    bad_qtvs    = filterOut (`elemVarSet` used_tvs) qtvs
-                  -- Bound but not used at all
-    bad_rhs_tvs = filterOut (`elemVarSet` inj_cpt_tvs) (fvVarList rhs_fvs)
-                  -- Used on RHS but not bound on LHS
-    dodgy_tvs   = cpt_tvs `minusVarSet` inj_cpt_tvs
-
-    check_tvs tvs what what2
-      = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $ mkTcRnUnknownMessage $ mkPlainError noHints $
-        hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs
-              <+> isOrAre tvs <+> what <> comma)
-           2 (vcat [ text "but not" <+> what2 <+> text "the family instance"
-                   , mk_extra tvs ])
-
-    -- mk_extra: #7536: give a decent error message for
-    --         type T a = Int
-    --         type instance F (T a) = a
-    mk_extra tvs = ppWhen (any (`elemVarSet` dodgy_tvs) tvs) $
-                   hang (text "The real LHS (expanding synonyms) is:")
-                      2 (pprTypeApp fam_tc (map expandTypeSynonyms pats))
-
-
--- | Checks that a list of type patterns is valid in a matching (LHS)
--- position of a class instances or type/data family instance.
---
--- Specifically:
---    * All monotypes
---    * No type-family applications
-checkValidTypePats :: TyCon -> [Type] -> TcM ()
-checkValidTypePats tc pat_ty_args
-  = do { -- Check that each of pat_ty_args is a monotype.
-         -- One could imagine generalising to allow
-         --      instance C (forall a. a->a)
-         -- but we don't know what all the consequences might be.
-         traverse_ checkValidMonoType pat_ty_args
-
-       -- Ensure that no type family applications occur a type pattern
-       ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of
-            [] -> pure ()
-            ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
-               ty_fam_inst_illegal_err tf_is_invis_arg
-                                       (mkTyConApp tf_tc tf_args) }
-  where
-    inst_ty = mkTyConApp tc pat_ty_args
-
-    ty_fam_inst_illegal_err :: Bool -> Type -> SDoc
-    ty_fam_inst_illegal_err invis_arg ty
-      = pprWithExplicitKindsWhen invis_arg $
-        hang (text "Illegal type synonym family application"
-                <+> quotes (ppr ty) <+> text "in instance" <> colon)
-           2 (ppr inst_ty)
-
--- Error messages
-
-inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc
-inaccessibleCoAxBranch fam_tc cur_branch
-  = text "Type family instance equation is overlapped:" $$
-    nest 2 (pprCoAxBranchUser fam_tc cur_branch)
-
-nestedMsg :: SDoc -> SDoc
-nestedMsg what
-  = sep [ text "Illegal nested" <+> what
-        , parens undecidableMsg ]
-
--------------------------
-checkConsistentFamInst :: AssocInstInfo
-                       -> TyCon     -- ^ Family tycon
-                       -> CoAxBranch
-                       -> TcM ()
--- See Note [Checking consistent instantiation]
-
-checkConsistentFamInst NotAssociated _ _
-  = return ()
-
-checkConsistentFamInst (InClsInst { ai_class = clas
-                                  , ai_tyvars = inst_tvs
-                                  , ai_inst_env = mini_env })
-                       fam_tc branch
-  = do { traceTc "checkConsistentFamInst" (vcat [ ppr inst_tvs
-                                                , ppr arg_triples
-                                                , ppr mini_env
-                                                , ppr ax_tvs
-                                                , ppr ax_arg_tys
-                                                , ppr arg_triples ])
-       -- Check that the associated type indeed comes from this class
-       -- See [Mismatched class methods and associated type families]
-       -- in TcInstDecls.
-       ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc)
-                 (TcRnBadAssociatedType (className clas) (tyConName fam_tc))
-
-       ; check_match arg_triples
-       }
-  where
-    (ax_tvs, ax_arg_tys, _) = etaExpandCoAxBranch branch
-
-    arg_triples :: [(Type,Type, ForAllTyFlag)]
-    arg_triples = [ (cls_arg_ty, at_arg_ty, vis)
-                  | (fam_tc_tv, vis, at_arg_ty)
-                       <- zip3 (tyConTyVars fam_tc)
-                               (tyConForAllTyFlags fam_tc ax_arg_tys)
-                               ax_arg_tys
-                  , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ]
-
-    pp_wrong_at_arg vis
-      = pprWithExplicitKindsWhen (isInvisibleForAllTyFlag vis) $
-        vcat [ text "Type indexes must match class instance head"
-             , text "Expected:" <+> pp_expected_ty
-             , text "  Actual:" <+> pp_actual_ty ]
-
-    -- Fiddling around to arrange that wildcards unconditionally print as "_"
-    -- We only need to print the LHS, not the RHS at all
-    -- See Note [Printing conflicts with class header]
-    (tidy_env1, _) = tidyVarBndrs emptyTidyEnv inst_tvs
-    (tidy_env2, _) = tidyCoAxBndrsForUser tidy_env1 (ax_tvs \\ inst_tvs)
-
-    pp_expected_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $
-                     toIfaceTcArgs fam_tc $
-                     [ case lookupVarEnv mini_env at_tv of
-                         Just cls_arg_ty -> tidyType tidy_env2 cls_arg_ty
-                         Nothing         -> mk_wildcard at_tv
-                     | at_tv <- tyConTyVars fam_tc ]
-
-    pp_actual_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $
-                   toIfaceTcArgs fam_tc $
-                   tidyTypes tidy_env2 ax_arg_tys
-
-    mk_wildcard at_tv = mkTyVarTy (mkTyVar tv_name (tyVarKind at_tv))
-    tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOccFS (fsLit "_")) noSrcSpan
-
-    -- For check_match, bind_me, see
-    -- Note [Matching in the consistent-instantiation check]
-    check_match :: [(Type,Type,ForAllTyFlag)] -> TcM ()
-    check_match triples = go emptySubst emptySubst triples
-
-    go _ _ [] = return ()
-    go lr_subst rl_subst ((ty1,ty2,vis):triples)
-      | Just lr_subst1 <- tcMatchTyX_BM bind_me lr_subst ty1 ty2
-      , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1
-      = go lr_subst1 rl_subst1 triples
-      | otherwise
-      = addErrTc (mkTcRnUnknownMessage $ mkPlainError noHints $ pp_wrong_at_arg vis)
-
-    -- The /scoped/ type variables from the class-instance header
-    -- should not be alpha-renamed.  Inferred ones can be.
-    no_bind_set = mkVarSet inst_tvs
-    bind_me tv _ty | tv `elemVarSet` no_bind_set = Apart
-                   | otherwise                   = BindMe
-
-
-{- Note [Check type-family instance binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In a type family instance, we require (of course), type variables
-used on the RHS are matched on the LHS. This is checked by
-checkFamPatBinders.  Here is an interesting example:
-
-    type family   T :: k
-    type instance T = (Nothing :: Maybe a)
-
-Upon a cursory glance, it may appear that the kind variable `a` is unbound
-since there are no (visible) LHS patterns in `T`. However, there is an
-*invisible* pattern due to the return kind, so inside of GHC, the instance
-looks closer to this:
-
-    type family T @k :: k
-    type instance T @(Maybe a) = (Nothing :: Maybe a)
-
-Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in
-fact not unbound. Contrast that with this example (#13985)
-
-    type instance T = Proxy (Nothing :: Maybe a)
-
-This would looks like this inside of GHC:
-
-    type instance T @(*) = Proxy (Nothing :: Maybe a)
-
-So this time, `a` is neither bound by a visible nor invisible type pattern on
-the LHS, so `a` would be reported as not in scope.
-
-Finally, here's one more brain-teaser (from #9574). In the example below:
-
-    class Funct f where
-      type Codomain f :: *
-    instance Funct ('KProxy :: KProxy o) where
-      type Codomain 'KProxy = NatTr (Proxy :: o -> *)
-
-As it turns out, `o` is in scope in this example. That is because `o` is
-bound by the kind signature of the LHS type pattern 'KProxy. To make this more
-obvious, one can also write the instance like so:
-
-    instance Funct ('KProxy :: KProxy o) where
-      type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *)
-
-Note [Dodgy binding sites in type family instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider the following example (from #7536):
-
-  type T a = Int
-  type instance F (T a) = a
-
-This `F` instance is extremely fishy, since the RHS, `a`, purports to be
-"bound" by the LHS pattern `T a`. "Bound" has scare quotes around it because
-`T a` expands to `Int`, which doesn't mention at all, so it's as if one had
-actually written:
-
-  type instance F Int = a
-
-That is clearly bogus, so to reject this, we check that every type variable
-that is mentioned on the RHS is /actually/ bound on the LHS. In other words,
-we need to do something slightly more sophisticated that just compute the free
-variables of the LHS patterns.
-
-It's tempting to just expand all type synonyms on the LHS and then compute
-their free variables, but even that isn't sophisticated enough. After all,
-an impish user could write the following (#17008):
-
-  type family ConstType (a :: Type) :: Type where
-    ConstType _ = Type
-
-  type family F (x :: ConstType a) :: Type where
-    F (x :: ConstType a) = a
-
-Just like in the previous example, the `a` on the RHS isn't actually bound
-on the LHS, but this time a type family is responsible for the deception, not
-a type synonym.
-
-We avoid both issues by requiring that all RHS type variables are mentioned
-in injective positions on the left-hand side (by way of
-`injectiveVarsOfTypes`). For instance, the `a` in `T a` is not in an injective
-position, as `T` is not an injective type constructor, so we do not count that.
-Similarly for the `a` in `ConstType a`.
-
-Note [Matching in the consistent-instantiation check]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Matching the class-instance header to family-instance tyvars is
-tricker than it sounds.  Consider (#13972)
-    class C (a :: k) where
-      type T k :: Type
-    instance C Left where
-      type T (a -> Either a b) = Int
-
-Here there are no lexically-scoped variables from (C Left).
-Yet the real class-instance header is   C @(p -> Either @p @q)) (Left @p @q)
-while the type-family instance is       T (a -> Either @a @b)
-So we allow alpha-renaming of variables that don't come
-from the class-instance header.
-
-We track the lexically-scoped type variables from the
-class-instance header in ai_tyvars.
-
-Here's another example (#14045a)
-    class C (a :: k) where
-      data S (a :: k)
-    instance C (z :: Bool) where
-      data S :: Bool -> Type where
-
-Again, there is no lexical connection, but we will get
-   class-instance header:   C @Bool (z::Bool)
-   family instance          S @Bool (a::Bool)
-
-When looking for mis-matches, we check left-to-right,
-kinds first.  If we look at types first, we'll fail to
-suggest -fprint-explicit-kinds for a mis-match with
-      T @k    vs    T @Type
-somewhere deep inside the type
-
-Note [Checking consistent instantiation]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See #11450 for background discussion on this check.
-
-  class C a b where
-    type T a x b
-
-With this class decl, if we have an instance decl
-  instance C ty1 ty2 where ...
-then the type instance must look like
-     type T ty1 v ty2 = ...
-with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'.
-For example:
-
-  instance C [p] Int
-    type T [p] y Int = (p,y,y)
-
-Note that
-
-* We used to allow completely different bound variables in the
-  associated type instance; e.g.
-    instance C [p] Int
-      type T [q] y Int = ...
-  But from GHC 8.2 onwards, we don't.  It's much simpler this way.
-  See #11450.
-
-* When the class variable isn't used on the RHS of the type instance,
-  it's tempting to allow wildcards, thus
-    instance C [p] Int
-      type T [_] y Int = (y,y)
-  But it's awkward to do the test, and it doesn't work if the
-  variable is repeated:
-    instance C (p,p) Int
-      type T (_,_) y Int = (y,y)
-  Even though 'p' is not used on the RHS, we still need to use 'p'
-  on the LHS to establish the repeated pattern.  So to keep it simple
-  we just require equality.
-
-* For variables in associated type families that are not bound by the class
-  itself, we do _not_ check if they are over-specific. In other words,
-  it's perfectly acceptable to have an instance like this:
-
-    instance C [p] Int where
-      type T [p] (Maybe x) Int = x
-
-  While the first and third arguments to T are required to be exactly [p] and
-  Int, respectively, since they are bound by C, the second argument is allowed
-  to be more specific than just a type variable. Furthermore, it is permissible
-  to define multiple equations for T that differ only in the non-class-bound
-  argument:
-
-    instance C [p] Int where
-      type T [p] (Maybe x)    Int = x
-      type T [p] (Either x y) Int = x -> y
-
-  We once considered requiring that non-class-bound variables in associated
-  type family instances be instantiated with distinct type variables. However,
-  that requirement proved too restrictive in practice, as there were examples
-  of extremely simple associated type family instances that this check would
-  reject, and fixing them required tiresome boilerplate in the form of
-  auxiliary type families. For instance, you would have to define the above
-  example as:
-
-    instance C [p] Int where
-      type T [p] x Int = CAux x
-
-    type family CAux x where
-      CAux (Maybe x)    = x
-      CAux (Either x y) = x -> y
-
-  We decided that this restriction wasn't buying us much, so we opted not
-  to pursue that design (see also GHC #13398).
-
-Implementation
-  * Form the mini-envt from the class type variables a,b
-    to the instance decl types [p],Int:   [a->[p], b->Int]
-
-  * Look at the tyvars a,x,b of the type family constructor T
-    (it shares tyvars with the class C)
-
-  * Apply the mini-evnt to them, and check that the result is
-    consistent with the instance types [p] y Int. (where y can be any type, as
-    it is not scoped over the class type variables.
-
-We make all the instance type variables scope over the
-type instances, of course, which picks up non-obvious kinds.  Eg
-   class Foo (a :: k) where
-      type F a
-   instance Foo (b :: k -> k) where
-      type F b = Int
-Here the instance is kind-indexed and really looks like
-      type F (k->k) (b::k->k) = Int
-But if the 'b' didn't scope, we would make F's instance too
-poly-kinded.
-
-Note [Printing conflicts with class header]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's remarkably painful to give a decent error message for conflicts
-with the class header.  Consider
-   class C b where
-     type F a b c
-   instance C [b] where
-     type F x Int _ _ = ...
-
-Here we want to report a conflict between
-    Expected: F _ [b] _
-    Actual:   F x Int _ _
-
-But if the type instance shadows the class variable like this
-(rename/should_fail/T15828):
-   instance C [b] where
-     type forall b. F x (Tree b) _ _ = ...
-
-then we must use a fresh variable name
-    Expected: F _ [b] _
-    Actual:   F x [b1] _ _
-
-Notice that:
-  - We want to print an underscore in the "Expected" type in
-    positions where the class header has no influence over the
-    parameter.  Hence the fancy footwork in pp_expected_ty
-
-  - Although the binders in the axiom are already tidy, we must
-    re-tidy them to get a fresh variable name when we shadow
-
-  - The (ax_tvs \\ inst_tvs) is to avoid tidying one of the
-    class-instance variables a second time, from 'a' to 'a1' say.
-    Remember, the ax_tvs of the axiom share identity with the
-    class-instance variables, inst_tvs..
-
-  - We use tidyCoAxBndrsForUser to get underscores rather than
-    _1, _2, etc in the axiom tyvars; see the definition of
-    tidyCoAxBndrsForUser
-
-This all seems absurdly complicated.
-
-Note [Unused explicitly bound variables in a family pattern]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Why is 'unusedExplicitForAllErr' not just a warning?
-
-Consider the following examples:
-
-  type instance F a = Maybe b
-  type instance forall b. F a = Bool
-  type instance forall b. F a = Maybe b
-
-In every case, b is a type variable not determined by the LHS pattern. The
-first is caught by the renamer, but we catch the last two here. Perhaps one
-could argue that the second should be accepted, albeit with a warning, but
-consider the fact that in a type family instance, there is no way to interact
-with such a variable. At least with @x :: forall a. Int@ we can use visible
-type application, like @x \@Bool 1@. (Of course it does nothing, but it is
-permissible.) In the type family case, the only sensible explanation is that
-the user has made a mistake -- thus we throw an error.
-
-Note [Oversaturated type family equations]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Type family tycons have very rigid arities. We want to reject something like
-this:
-
-  type family Foo :: Type -> Type where
-    Foo x = ...
-
-Because Foo has arity zero (i.e., it doesn't bind anything to the left of the
-double colon), we want to disallow any equation for Foo that has more than zero
-arguments, such as `Foo x = ...`. The algorithm here is pretty simple: if an
-equation has more arguments than the arity of the type family, reject.
-
-Things get trickier when visible kind application enters the picture. Consider
-the following example:
-
-  type family Bar (x :: j) :: forall k. Either j k where
-    Bar 5 @Symbol = ...
-
-The arity of Bar is two, since it binds two variables, `j` and `x`. But even
-though Bar's equation has two arguments, it's still invalid. Imagine the same
-equation in Core:
-
-    Bar Nat 5 Symbol = ...
-
-Here, it becomes apparent that Bar is actually taking /three/ arguments! So
-we can't just rely on a simple counting argument to reject
-`Bar 5 @Symbol = ...`, since it only has two user-written arguments.
-Moreover, there's one explicit argument (5) and one visible kind argument
-(@Symbol), which matches up perfectly with the fact that Bar has one required
-binder (x) and one specified binder (j), so that's not a valid way to detect
-oversaturation either.
-
-To solve this problem in a robust way, we do the following:
-
-1. When kind-checking, we count the number of user-written *required*
-   arguments and check if there is an equal number of required tycon binders.
-   If not, reject. (See `wrongNumberOfParmsErr` in GHC.Tc.TyCl.)
-
-   We perform this step during kind-checking, not during validity checking,
-   since we can give better error messages if we catch it early.
-2. When validity checking, take all of the (Core) type patterns from on
-   equation, drop the first n of them (where n is the arity of the type family
-   tycon), and check if there are any types leftover. If so, reject.
-
-   Why does this work? We know that after dropping the first n type patterns,
-   none of the leftover types can be required arguments, since step (1) would
-   have already caught that. Moreover, the only places where visible kind
-   applications should be allowed are in the first n types, since those are the
-   only arguments that can correspond to binding forms. Therefore, the
-   remaining arguments must correspond to oversaturated uses of visible kind
-   applications, which are precisely what we want to reject.
-
-Note that we only perform this check for type families, and not for data
-families. This is because it is perfectly acceptable to oversaturate data
-family instance equations: see Note [Arity of data families] in GHC.Core.FamInstEnv.
-
-************************************************************************
-*                                                                      *
-   Telescope checking
-*                                                                      *
-************************************************************************
-
-Note [Bad TyCon telescopes]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Now that we can mix type and kind variables, there are an awful lot of
-ways to shoot yourself in the foot. Here are some.
-
-  data SameKind :: k -> k -> *   -- just to force unification
-
-1.  data T1 a k (b :: k) (x :: SameKind a b)
-
-The problem here is that we discover that a and b should have the same
-kind. But this kind mentions k, which is bound *after* a.
-(Testcase: dependent/should_fail/BadTelescope)
-
-2.  data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)
-
-Note that b is not bound. Yet its kind mentions a. Because we have
-a nice rule that all implicitly bound variables come before others,
-this is bogus.
-
-To catch these errors, we call checkTyConTelescope during kind-checking
-datatype declarations.  This checks for
-
-* Ill-scoped binders. From (1) and (2) above we can get putative
-  kinds like
-       T1 :: forall (a:k) (k:*) (b:k). SameKind a b -> *
-  where 'k' is mentioned a's kind before k is bound
-
-  This is easy to check for: just look for
-  out-of-scope variables in the kind
-
-* We should arguably also check for ambiguous binders
-  but we don't.  See Note [Ambiguous kind vars].
-
-See also
-  * Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl.
-  * Note [Checking telescopes] in GHC.Tc.Types.Constraint discusses how
-    this check works for `forall x y z.` written in a type.
-
-Note [Ambiguous kind vars]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-We used to be concerned about ambiguous binders. Suppose we have the kind
-     S1 :: forall k -> * -> *
-     S2 :: forall k. * -> *
-Here S1 is OK, because k is Required, and at a use of S1 we will
-see (S1 *) or (S1 (*->*)) or whatever.
-
-But S2 is /not/ OK because 'k' is Specfied (and hence invisible) and
-we have no way (ever) to figure out how 'k' should be instantiated.
-For example if we see (S2 Int), that tells us nothing about k's
-instantiation.  (In this case we'll instantiate it to Any, but that
-seems wrong.)  This is really the same test as we make for ambiguous
-type in term type signatures.
-
-Now, it's impossible for a Specified variable not to occur
-at all in the kind -- after all, it is Specified so it must have
-occurred.  (It /used/ to be possible; see tests T13983 and T7873.  But
-with the advent of the forall-or-nothing rule for kind variables,
-those strange cases went away. See Note [forall-or-nothing rule] in
-GHC.Hs.Type.)
-
-But one might worry about
-    type v k = *
-    S3 :: forall k. V k -> *
-which appears to mention 'k' but doesn't really.  Or
-    S4 :: forall k. F k -> *
-where F is a type function.  But we simply don't check for
-those cases of ambiguity, yet anyway.  The worst that can happen
-is ambiguity at the call sites.
-
-Historical note: this test used to be called reportFloatingKvs.
--}
-
--- | Check a list of binders to see if they make a valid telescope.
--- See Note [Bad TyCon telescopes]
-type TelescopeAcc
-      = ( TyVarSet   -- Bound earlier in the telescope
-        , Bool       -- At least one binder occurred (in a kind) before
-                     -- it was bound in the telescope.  E.g.
-        )            --    T :: forall (a::k) k. blah
-
-checkTyConTelescope :: TyCon -> TcM ()
-checkTyConTelescope tc
-  | bad_scope
-  = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes]
-    addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $
-    vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped")
-              2 pp_tc_kind
-         , extra
-         , hang (text "Perhaps try this order instead:")
-              2 (pprTyVars sorted_tvs) ]
-
-  | otherwise
-  = return ()
-  where
-    tcbs = tyConBinders tc
-    tvs  = binderVars tcbs
-    sorted_tvs = scopedSort tvs
-
-    (_, bad_scope) = foldl add_one (emptyVarSet, False) tcbs
-
-    add_one :: TelescopeAcc -> TyConBinder -> TelescopeAcc
-    add_one (bound, bad_scope) tcb
-      = ( bound `extendVarSet` tv
-        , bad_scope || not (isEmptyVarSet (fkvs `minusVarSet` bound)) )
-      where
-        tv = binderVar tcb
-        fkvs = tyCoVarsOfType (tyVarKind tv)
-
-    inferred_tvs  = [ binderVar tcb
-                    | tcb <- tcbs, Inferred == tyConBinderForAllTyFlag tcb ]
-    specified_tvs = [ binderVar tcb
-                    | tcb <- tcbs, Specified == tyConBinderForAllTyFlag tcb ]
-
-    pp_inf  = parens (text "namely:" <+> pprTyVars inferred_tvs)
-    pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs)
-
-    pp_tc_kind = text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc)
-    ppr_untidy ty = pprIfaceType (toIfaceType ty)
-      -- We need ppr_untidy here because pprType will tidy the type, which
-      -- will turn the bogus kind we are trying to report
-      --     T :: forall (a::k) k (b::k) -> blah
-      -- into a misleadingly sanitised version
-      --     T :: forall (a::k) k1 (b::k1) -> blah
-
-    extra
-      | null inferred_tvs && null specified_tvs
-      = empty
-      | null inferred_tvs
-      = hang (text "NB: Specified variables")
-           2 (sep [pp_spec, text "always come first"])
-      | null specified_tvs
-      = hang (text "NB: Inferred variables")
-           2 (sep [pp_inf, text "always come first"])
-      | otherwise
-      = hang (text "NB: Inferred variables")
-           2 (vcat [ sep [ pp_inf, text "always come first"]
-                   , sep [text "then Specified variables", pp_spec]])
-
-{-
-************************************************************************
-*                                                                      *
-\subsection{Auxiliary functions}
-*                                                                      *
-************************************************************************
--}
-
--- Free variables of a type, retaining repetitions, and expanding synonyms
--- This ignores coercions, as coercions aren't user-written
-fvType :: Type -> [TyCoVar]
-fvType ty | Just exp_ty <- coreView ty = fvType exp_ty
-fvType (TyVarTy tv)          = [tv]
-fvType (TyConApp _ tys)      = fvTypes tys
-fvType (LitTy {})            = []
-fvType (AppTy fun arg)       = fvType fun ++ fvType arg
-fvType (FunTy _ w arg res)   = fvType w ++ fvType arg ++ fvType res
-fvType (ForAllTy (Bndr tv _) ty)
-  = fvType (tyVarKind tv) ++
-    filter (/= tv) (fvType ty)
-fvType (CastTy ty _)         = fvType ty
-fvType (CoercionTy {})       = []
-
-fvTypes :: [Type] -> [TyVar]
-fvTypes tys                = concatMap fvType tys
-
-sizeType :: Type -> Int
--- Size of a type: the number of variables and constructors
-sizeType ty | Just exp_ty <- coreView ty = sizeType exp_ty
-sizeType (TyVarTy {})      = 1
-sizeType (TyConApp tc tys) = 1 + sizeTyConAppArgs tc tys
-sizeType (LitTy {})        = 1
-sizeType (AppTy fun arg)   = sizeType fun + sizeType arg
-sizeType (FunTy _ w arg res) = sizeType w + sizeType arg + sizeType res + 1
-sizeType (ForAllTy _ ty)   = sizeType ty
-sizeType (CastTy ty _)     = sizeType ty
-sizeType (CoercionTy _)    = 0
-
-sizeTypes :: [Type] -> Int
-sizeTypes = foldr ((+) . sizeType) 0
-
-sizeTyConAppArgs :: TyCon -> [Type] -> Int
-sizeTyConAppArgs _tc tys = sizeTypes tys -- (filterOutInvisibleTypes tc tys)
-                           -- See Note [Invisible arguments and termination]
-
--- | When this says "True", ignore this class constraint during
--- a termination check
-isTerminatingClass :: Class -> Bool
-isTerminatingClass cls
-  = isIPClass cls    -- Implicit parameter constraints always terminate because
-                     -- there are no instances for them --- they are only solved
-                     -- by "local instances" in expressions
-    || isEqPredClass cls
-    || cls `hasKey` typeableClassKey
-    || cls `hasKey` coercibleTyConKey
-
-allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool
--- (allDistinctTyVars tvs tys) returns True if tys are
--- a) all tyvars
--- b) all distinct
--- c) disjoint from tvs
-allDistinctTyVars _    [] = True
-allDistinctTyVars tkvs (ty : tys)
-  = case getTyVar_maybe ty of
-      Nothing -> False
-      Just tv | tv `elemVarSet` tkvs -> False
-              | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
deleted file mode 100644
--- a/compiler/GHC/ThToHs.hs
+++ /dev/null
@@ -1,2231 +0,0 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ConstrainedClassMethods #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE ViewPatterns #-}
-
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-
-{-
-(c) The University of Glasgow 2006
-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-
-
-This module converts Template Haskell syntax into Hs syntax
--}
-
-module GHC.ThToHs
-   ( convertToHsExpr
-   , convertToPat
-   , convertToHsDecls
-   , convertToHsType
-   , thRdrNameGuesses
-   )
-where
-
-import GHC.Prelude hiding (head, init, last, tail)
-
-import GHC.Hs as Hs
-import GHC.Builtin.Names
-import GHC.Tc.Errors.Types
-import GHC.Types.Name.Reader
-import qualified GHC.Types.Name as Name
-import GHC.Unit.Module
-import GHC.Parser.PostProcess
-import GHC.Types.Name.Occurrence as OccName
-import GHC.Types.SrcLoc
-import GHC.Core.Type as Hs
-import qualified GHC.Core.Coercion as Coercion ( Role(..) )
-import GHC.Builtin.Types
-import GHC.Builtin.Types.Prim( fUNTyCon )
-import GHC.Types.Basic as Hs
-import GHC.Types.Fixity as Hs
-import GHC.Types.ForeignCall
-import GHC.Types.Unique
-import GHC.Types.SourceText
-import GHC.Data.Bag
-import GHC.Utils.Lexeme
-import GHC.Utils.Misc
-import GHC.Data.FastString
-import GHC.Utils.Panic
-
-import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-
-import qualified Data.ByteString as BS
-import Control.Monad( unless, ap )
-import Control.Applicative( (<|>) )
-import Data.Bifunctor (first)
-import Data.Foldable (for_)
-import Data.List.NonEmpty( NonEmpty (..), nonEmpty )
-import qualified Data.List.NonEmpty as NE
-import Data.Maybe( catMaybes, isNothing )
-import Language.Haskell.TH as TH hiding (sigP)
-import Language.Haskell.TH.Syntax as TH
-import Foreign.ForeignPtr
-import Foreign.Ptr
-import System.IO.Unsafe
-
--------------------------------------------------------------------
---              The external interface
-
-convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either RunSpliceFailReason [LHsDecl GhcPs]
-convertToHsDecls origin loc ds =
-  initCvt origin loc $ fmap catMaybes (mapM cvt_dec ds)
-  where
-    cvt_dec d =
-      wrapMsg (ConvDec d) $ cvtDec d
-
-convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either RunSpliceFailReason (LHsExpr GhcPs)
-convertToHsExpr origin loc e
-  = initCvt origin loc $ wrapMsg (ConvExp e) $ cvtl e
-
-convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either RunSpliceFailReason (LPat GhcPs)
-convertToPat origin loc p
-  = initCvt origin loc $ wrapMsg (ConvPat p) $ cvtPat p
-
-convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either RunSpliceFailReason (LHsType GhcPs)
-convertToHsType origin loc t
-  = initCvt origin loc $ wrapMsg (ConvType t) $ cvtType t
-
--------------------------------------------------------------------
-newtype CvtM' err a = CvtM { unCvtM :: Origin -> SrcSpan -> Either err (SrcSpan, a) }
-    deriving (Functor)
-        -- Push down the Origin (that is configurable by
-        -- -fenable-th-splice-warnings) and source location;
-        -- Can fail, with a single error message
-
-type CvtM = CvtM' ConversionFailReason
-
--- NB: If the conversion succeeds with (Right x), there should
---     be no exception values hiding in x
--- Reason: so a (head []) in TH code doesn't subsequently
---         make GHC crash when it tries to walk the generated tree
-
--- Use the SrcSpan everywhere, for lack of anything better.
--- See Note [Source locations within TH splices].
-
-instance Applicative (CvtM' err) where
-    pure x = CvtM $ \_ loc -> Right (loc,x)
-    (<*>) = ap
-
-instance Monad (CvtM' err) where
-  (CvtM m) >>= k = CvtM $ \origin loc -> case m origin loc of
-    Left err -> Left err
-    Right (loc',v) -> unCvtM (k v) origin loc'
-
-mapCvtMError :: (err1 -> err2) -> CvtM' err1 a -> CvtM' err2 a
-mapCvtMError f (CvtM m) = CvtM $ \origin loc -> first f $ m origin loc
-
-initCvt :: Origin -> SrcSpan -> CvtM' err a -> Either err a
-initCvt origin loc (CvtM m) = fmap snd (m origin loc)
-
-force :: a -> CvtM ()
-force a = a `seq` return ()
-
-failWith :: ConversionFailReason -> CvtM a
-failWith m = CvtM (\_ _ -> Left m)
-
-getOrigin :: CvtM Origin
-getOrigin = CvtM (\origin loc -> Right (loc,origin))
-
-getL :: CvtM SrcSpan
-getL = CvtM (\_ loc -> Right (loc,loc))
-
--- NB: This is only used in conjunction with LineP pragmas.
--- See Note [Source locations within TH splices].
-setL :: SrcSpan -> CvtM ()
-setL loc = CvtM (\_ _ -> Right (loc, ()))
-
-returnLA :: e -> CvtM (LocatedAn ann e)
-returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x))
-
-returnJustLA :: a -> CvtM (Maybe (LocatedA a))
-returnJustLA = fmap Just . returnLA
-
-wrapParLA :: (LocatedAn ann a -> b) -> a -> CvtM b
-wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x)))
-
-wrapMsg :: ThingBeingConverted -> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
-wrapMsg what = mapCvtMError (ConversionFail what)
-
-wrapL :: CvtM a -> CvtM (Located a)
-wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of
-  Left err -> Left err
-  Right (loc', v) -> Right (loc', L loc v)
-
-wrapLN :: CvtM a -> CvtM (LocatedN a)
-wrapLN (CvtM m) = CvtM $ \origin loc -> case m origin loc of
-  Left err -> Left err
-  Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v)
-
-wrapLA :: CvtM a -> CvtM (LocatedA a)
-wrapLA (CvtM m) = CvtM $ \origin loc -> case m origin loc of
-  Left err -> Left err
-  Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v)
-
-{-
-Note [Source locations within TH splices]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider a TH splice such as $(x), where `x` evaluates to `id True`. What
-source locations should we use for subexpressions within the splice, such as
-`id` and `True`? We basically have two options:
-
-1. Don't give anything within the splice a SrcSpan. That is, use the `noLoc`
-   everywhere.
-2. Give everything within the splice the same `SrcSpan` as where the splice
-   occurs (i.e., where $(x) occurs).
-
-We implement option (2) for the following reasons:
-
-* We want SrcSpans on binding locations so that variables bound in the
-  spliced-in declarations get a location that at least relates to the splice
-  point.
-
-* Generally speaking, having *some* SrcSpan for each sub-expression in the AST
-  in better than having no SrcSpan at all. This extra information can be useful
-  for programs that walk over the AST directly.
-
-Because of our choice of option (2), we are very careful not to use the noLoc
-function anywhere in GHC.ThToHs. Instead, we thread around a SrcSpan in CvtM
-and allow retrieving the SrcSpan through combinators such as getL, returnLA,
-wrapParLA, etc.
-
-Note that CvtM is actually a *state* monad vis-à-vis SrcSpan, not just a
-reader monad. This is because LineP pragmas can change the source location
-within a splice—see testsuite/tests/th/TH_linePragma.hs for an example. This
-is a bit unusual, since it changes the source location from that of the splice
-point to that of the code being spliced in. Nevertheless, LineP is *the* reason
-why CvtM is a state monad.
--}
-
--------------------------------------------------------------------
-cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
-cvtDecs = fmap catMaybes . mapM cvtDec
-
-cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))
-cvtDec (TH.ValD pat body ds)
-  | TH.VarP s <- pat
-  = do  { s' <- vNameN s
-        ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
-        ; th_origin <- getOrigin
-        ; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] }
-
-  | otherwise
-  = do  { pat' <- cvtPat pat
-        ; body' <- cvtGuard body
-        ; ds' <- cvtLocalDecs WhereClause ds
-        ; returnJustLA $ Hs.ValD noExtField $
-          PatBind { pat_lhs = pat'
-                  , pat_rhs = GRHSs emptyComments body' ds'
-                  , pat_ext = noAnn
-                  } }
-
-cvtDec (TH.FunD nm cls)
-  | null cls
-  = failWith $ FunBindLacksEquations nm
-  | otherwise
-  = do  { nm' <- vNameN nm
-        ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
-        ; th_origin <- getOrigin
-        ; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' }
-
-cvtDec (TH.SigD nm typ)
-  = do  { nm' <- vNameN nm
-        ; ty' <- cvtSigType typ
-        ; returnJustLA $ Hs.SigD noExtField
-                                    (TypeSig noAnn [nm'] (mkHsWildCardBndrs ty')) }
-
-cvtDec (TH.KiSigD nm ki)
-  = do  { nm' <- tconNameN nm
-        ; ki' <- cvtSigKind ki
-        ; let sig' = StandaloneKindSig noAnn nm' ki'
-        ; returnJustLA $ Hs.KindSigD noExtField sig' }
-
-cvtDec (TH.InfixD fx nm)
-  -- Fixity signatures are allowed for variables, constructors, and types
-  -- the renamer automatically looks for types during renaming, even when
-  -- the RdrName says it's a variable or a constructor. So, just assume
-  -- it's a variable or constructor and proceed.
-  = do { nm' <- vcNameN nm
-       ; returnJustLA (Hs.SigD noExtField (FixSig noAnn
-                                      (FixitySig noExtField [nm'] (cvtFixity fx)))) }
-
-cvtDec (TH.DefaultD tys)
-  = do  { tys' <- traverse cvtType tys
-        ; returnJustLA (Hs.DefD noExtField $ DefaultDecl noAnn tys') }
-
-cvtDec (PragmaD prag)
-  = cvtPragmaD prag
-
-cvtDec (TySynD tc tvs rhs)
-  = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
-        ; rhs' <- cvtType rhs
-        ; returnJustLA $ TyClD noExtField $
-          SynDecl { tcdSExt = noAnn, tcdLName = tc', tcdTyVars = tvs'
-                  , tcdFixity = Prefix
-                  , tcdRhs = rhs' } }
-
-cvtDec (DataD ctxt tc tvs ksig constrs derivs)
-  = do  { let isGadtCon (GadtC    _ _ _) = True
-              isGadtCon (RecGadtC _ _ _) = True
-              isGadtCon (ForallC  _ _ c) = isGadtCon c
-              isGadtCon _                = False
-              isGadtDecl  = all isGadtCon constrs
-              isH98Decl   = all (not . isGadtCon) constrs
-        ; unless (isGadtDecl || isH98Decl)
-                 (failWith CannotMixGADTConsWith98Cons)
-        ; unless (isNothing ksig || isGadtDecl)
-                 (failWith KindSigsOnlyAllowedOnGADTs)
-        ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
-        ; ksig' <- cvtKind `traverse` ksig
-        ; cons' <- mapM cvtConstr constrs
-        ; derivs' <- cvtDerivs derivs
-        ; let defn = HsDataDefn { dd_ext = noExtField
-                                , dd_cType = Nothing
-                                , dd_ctxt = mkHsContextMaybe ctxt'
-                                , dd_kindSig = ksig'
-                                , dd_cons = DataTypeCons False cons'
-                                , dd_derivs = derivs' }
-        ; returnJustLA $ TyClD noExtField $
-          DataDecl { tcdDExt = noAnn
-                   , tcdLName = tc', tcdTyVars = tvs'
-                   , tcdFixity = Prefix
-                   , tcdDataDefn = defn } }
-
-cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
-  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
-        ; ksig' <- cvtKind `traverse` ksig
-        ; con' <- cvtConstr constr
-        ; derivs' <- cvtDerivs derivs
-        ; let defn = HsDataDefn { dd_ext = noExtField
-                                , dd_cType = Nothing
-                                , dd_ctxt = mkHsContextMaybe ctxt'
-                                , dd_kindSig = ksig'
-                                , dd_cons = NewTypeCon con'
-                                , dd_derivs = derivs' }
-        ; returnJustLA $ TyClD noExtField $
-          DataDecl { tcdDExt = noAnn
-                   , tcdLName = tc', tcdTyVars = tvs'
-                   , tcdFixity = Prefix
-                   , tcdDataDefn = defn } }
-
-cvtDec (ClassD ctxt cl tvs fds decs)
-  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
-        ; fds'  <- mapM cvt_fundep fds
-        ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs ClssDecl decs
-        ; unless (null adts')
-            (failWith $ DefaultDataInstDecl adts')
-        ; returnJustLA $ TyClD noExtField $
-          ClassDecl { tcdCExt = (noAnn, NoAnnSortKey), tcdLayout = NoLayoutInfo
-                    , tcdCtxt = mkHsContextMaybe cxt', tcdLName = tc', tcdTyVars = tvs'
-                    , tcdFixity = Prefix
-                    , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
-                    , tcdMeths = binds'
-                    , tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] }
-                              -- no docs in TH ^^
-        }
-
-cvtDec (InstanceD o ctxt ty decs)
-  = do  { (binds', sigs', fams', ats', adts') <- cvt_ci_decs InstanceDecl decs
-        ; for_ (nonEmpty fams') $ \ bad_fams ->
-            failWith (IllegalDeclaration InstanceDecl $ IllegalFamDecls bad_fams)
-        ; ctxt' <- cvtContext funPrec ctxt
-        ; (L loc ty') <- cvtType ty
-        ; let inst_ty' = L loc $ mkHsImplicitSigType $
-                         mkHsQualTy ctxt loc ctxt' $ L loc ty'
-        ; returnJustLA $ InstD noExtField $ ClsInstD noExtField $
-          ClsInstDecl { cid_ext = (noAnn, NoAnnSortKey), cid_poly_ty = inst_ty'
-                      , cid_binds = binds'
-                      , cid_sigs = Hs.mkClassOpSigs sigs'
-                      , cid_tyfam_insts = ats', cid_datafam_insts = adts'
-                      , cid_overlap_mode
-                                   = fmap (L (l2l loc) . overlap) o } }
-  where
-  overlap pragma =
-    case pragma of
-      TH.Overlaps      -> Hs.Overlaps     (SourceText "OVERLAPS")
-      TH.Overlappable  -> Hs.Overlappable (SourceText "OVERLAPPABLE")
-      TH.Overlapping   -> Hs.Overlapping  (SourceText "OVERLAPPING")
-      TH.Incoherent    -> Hs.Incoherent   (SourceText "INCOHERENT")
-
-
-
-
-cvtDec (ForeignD ford)
-  = do { ford' <- cvtForD ford
-       ; returnJustLA $ ForD noExtField ford' }
-
-cvtDec (DataFamilyD tc tvs kind)
-  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
-       ; result <- cvtMaybeKindToFamilyResultSig kind
-       ; returnJustLA $ TyClD noExtField $ FamDecl noExtField $
-         FamilyDecl noAnn DataFamily TopLevel tc' tvs' Prefix result Nothing }
-
-cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
-  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
-       ; ksig' <- cvtKind `traverse` ksig
-       ; cons' <- mapM cvtConstr constrs
-       ; derivs' <- cvtDerivs derivs
-       ; let defn = HsDataDefn { dd_ext = noExtField
-                               , dd_cType = Nothing
-                               , dd_ctxt = mkHsContextMaybe ctxt'
-                               , dd_kindSig = ksig'
-                               , dd_cons = DataTypeCons False cons'
-                               , dd_derivs = derivs' }
-
-       ; returnJustLA $ InstD noExtField $ DataFamInstD
-           { dfid_ext = noExtField
-           , dfid_inst = DataFamInstDecl { dfid_eqn =
-                           FamEqn { feqn_ext = noAnn
-                                  , feqn_tycon = tc'
-                                  , feqn_bndrs = bndrs'
-                                  , feqn_pats = typats'
-                                  , feqn_rhs = defn
-                                  , feqn_fixity = Prefix } }}}
-
-cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
-  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
-       ; ksig' <- cvtKind `traverse` ksig
-       ; con' <- cvtConstr constr
-       ; derivs' <- cvtDerivs derivs
-       ; let defn = HsDataDefn { dd_ext = noExtField
-                               , dd_cType = Nothing
-                               , dd_ctxt = mkHsContextMaybe ctxt'
-                               , dd_kindSig = ksig'
-                               , dd_cons = NewTypeCon con', dd_derivs = derivs' }
-       ; returnJustLA $ InstD noExtField $ DataFamInstD
-           { dfid_ext = noExtField
-           , dfid_inst = DataFamInstDecl { dfid_eqn =
-                           FamEqn { feqn_ext = noAnn
-                                  , feqn_tycon = tc'
-                                  , feqn_bndrs = bndrs'
-                                  , feqn_pats = typats'
-                                  , feqn_rhs = defn
-                                  , feqn_fixity = Prefix } }}}
-
-cvtDec (TySynInstD eqn)
-  = do  { (L _ eqn') <- cvtTySynEqn eqn
-        ; returnJustLA $ InstD noExtField $ TyFamInstD
-            { tfid_ext = noExtField
-            , tfid_inst = TyFamInstDecl { tfid_xtn = noAnn, tfid_eqn = eqn' } }}
-
-cvtDec (OpenTypeFamilyD head)
-  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
-       ; returnJustLA $ TyClD noExtField $ FamDecl noExtField $
-         FamilyDecl noAnn OpenTypeFamily TopLevel tc' tyvars' Prefix result' injectivity'
-       }
-
-cvtDec (ClosedTypeFamilyD head eqns)
-  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
-       ; eqns' <- mapM cvtTySynEqn eqns
-       ; returnJustLA $ TyClD noExtField $ FamDecl noExtField $
-         FamilyDecl noAnn (ClosedTypeFamily (Just eqns')) TopLevel tc' tyvars' Prefix
-                           result' injectivity' }
-
-cvtDec (TH.RoleAnnotD tc roles)
-  = do { tc' <- tconNameN tc
-       ; roles' <- traverse (returnLA . cvtRole) roles
-       ; returnJustLA
-                   $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noAnn tc' roles') }
-
-cvtDec (TH.StandaloneDerivD ds cxt ty)
-  = do { cxt' <- cvtContext funPrec cxt
-       ; ds'  <- traverse cvtDerivStrategy ds
-       ; (L loc ty') <- cvtType ty
-       ; let inst_ty' = L loc $ mkHsImplicitSigType $
-                        mkHsQualTy cxt loc cxt' $ L loc ty'
-       ; returnJustLA $ DerivD noExtField $
-         DerivDecl { deriv_ext = noAnn
-                   , deriv_strategy = ds'
-                   , deriv_type = mkHsWildCardBndrs inst_ty'
-                   , deriv_overlap_mode = Nothing } }
-
-cvtDec (TH.DefaultSigD nm typ)
-  = do { nm' <- vNameN nm
-       ; ty' <- cvtSigType typ
-       ; returnJustLA $ Hs.SigD noExtField
-                      $ ClassOpSig noAnn True [nm'] ty'}
-
-cvtDec (TH.PatSynD nm args dir pat)
-  = do { nm'   <- cNameN nm
-       ; args' <- cvtArgs args
-       ; dir'  <- cvtDir nm' dir
-       ; pat'  <- cvtPat pat
-       ; returnJustLA $ Hs.ValD noExtField $ PatSynBind noExtField $
-           PSB noAnn nm' args' pat' dir' }
-  where
-    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon noTypeArgs <$> mapM vNameN args
-    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameN a1 <*> vNameN a2
-    cvtArgs (TH.RecordPatSyn sels)
-      = do { sels' <- mapM (fmap (\ (L li i) -> FieldOcc noExtField (L li i)) . vNameN) sels
-           ; vars' <- mapM (vNameN . mkNameS . nameBase) sels
-           ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }
-
-    -- cvtDir :: LocatedN RdrName -> (PatSynDir -> CvtM (HsPatSynDir RdrName))
-    cvtDir _ Unidir          = return Unidirectional
-    cvtDir _ ImplBidir       = return ImplicitBidirectional
-    cvtDir n (ExplBidir cls) =
-      do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
-         ; th_origin <- getOrigin
-         ; wrapParLA (ExplicitBidirectional . mkMatchGroup th_origin) ms }
-
-cvtDec (TH.PatSynSigD nm ty)
-  = do { nm' <- cNameN nm
-       ; ty' <- cvtPatSynSigTy ty
-       ; returnJustLA $ Hs.SigD noExtField $ PatSynSig noAnn [nm'] ty'}
-
--- Implicit parameter bindings are handled in cvtLocalDecs and
--- cvtImplicitParamBind. They are not allowed in any other scope, so
--- reaching this case indicates an error.
-cvtDec (TH.ImplicitParamBindD _ _)
-  = failWith InvalidImplicitParamBinding
-
-----------------
-cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
-cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)
-  = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs
-       ; let outer_bndrs = mkHsOuterFamEqnTyVarBndrs mb_bndrs'
-       ; (head_ty, args) <- split_ty_app lhs
-       ; case head_ty of
-           ConT nm -> do { nm' <- tconNameN nm
-                         ; rhs' <- cvtType rhs
-                         ; let args' = map wrap_tyarg args
-                         ; returnLA
-                            $ FamEqn { feqn_ext    = noAnn
-                                     , feqn_tycon  = nm'
-                                     , feqn_bndrs  = outer_bndrs
-                                     , feqn_pats   = args'
-                                     , feqn_fixity = Prefix
-                                     , feqn_rhs    = rhs' } }
-           InfixT t1 nm t2 -> do { nm' <- tconNameN nm
-                                 ; args' <- mapM cvtType [t1,t2]
-                                 ; rhs' <- cvtType rhs
-                                 ; returnLA
-                                      $ FamEqn { feqn_ext    = noAnn
-                                               , feqn_tycon  = nm'
-                                               , feqn_bndrs  = outer_bndrs
-                                               , feqn_pats   =
-                                                (map HsValArg args') ++ args
-                                               , feqn_fixity = Hs.Infix
-                                               , feqn_rhs    = rhs' } }
-           _ -> failWith $ InvalidTyFamInstLHS lhs
-        }
-
-----------------
-cvt_ci_decs :: THDeclDescriptor -> [TH.Dec]
-            -> CvtM (LHsBinds GhcPs,
-                     [LSig GhcPs],
-                     [LFamilyDecl GhcPs],
-                     [LTyFamInstDecl GhcPs],
-                     [LDataFamInstDecl GhcPs])
--- Convert the declarations inside a class or instance decl
--- ie signatures, bindings, and associated types
-cvt_ci_decs declDescr decs
-  = do  { decs' <- cvtDecs decs
-        ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
-        ; let (adts', no_ats')       = partitionWith is_datafam_inst bind_sig_decs'
-        ; let (sigs', prob_binds')   = partitionWith is_sig no_ats'
-        ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
-        ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
-        ; for_ (nonEmpty bads) $ \ bad_decls ->
-            failWith (IllegalDeclaration declDescr $ IllegalDecls bad_decls)
-        ; return (listToBag binds', sigs', fams', ats', adts') }
-
-----------------
-cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr ()]
-             -> CvtM ( LHsContext GhcPs
-                     , LocatedN RdrName
-                     , LHsQTyVars GhcPs)
-cvt_tycl_hdr cxt tc tvs
-  = do { cxt' <- cvtContext funPrec cxt
-       ; tc'  <- tconNameN tc
-       ; tvs' <- cvtTvs tvs
-       ; return (cxt', tc', mkHsQTvs tvs')
-       }
-
-cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr ()] -> TH.Type
-               -> CvtM ( LHsContext GhcPs
-                       , LocatedN RdrName
-                       , HsOuterFamEqnTyVarBndrs GhcPs
-                       , HsTyPats GhcPs)
-cvt_datainst_hdr cxt bndrs tys
-  = do { cxt' <- cvtContext funPrec cxt
-       ; bndrs' <- traverse (mapM cvt_tv) bndrs
-       ; let outer_bndrs = mkHsOuterFamEqnTyVarBndrs bndrs'
-       ; (head_ty, args) <- split_ty_app tys
-       ; case head_ty of
-          ConT nm -> do { nm' <- tconNameN nm
-                        ; let args' = map wrap_tyarg args
-                        ; return (cxt', nm', outer_bndrs, args') }
-          InfixT t1 nm t2 -> do { nm' <- tconNameN nm
-                                ; args' <- mapM cvtType [t1,t2]
-                                ; return (cxt', nm', outer_bndrs,
-                                         ((map HsValArg args') ++ args)) }
-          _ -> failWith $ InvalidTypeInstanceHeader tys }
-
-----------------
-cvt_tyfam_head :: TypeFamilyHead
-               -> CvtM ( LocatedN RdrName
-                       , LHsQTyVars GhcPs
-                       , Hs.LFamilyResultSig GhcPs
-                       , Maybe (Hs.LInjectivityAnn GhcPs))
-
-cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
-  = do { (_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars
-       ; result' <- cvtFamilyResultSig result
-       ; injectivity' <- traverse cvtInjectivityAnnotation injectivity
-       ; return (tc', tyvars', result', injectivity') }
-
--------------------------------------------------------------------
---              Partitioning declarations
--------------------------------------------------------------------
-
-is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
-is_fam_decl (L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (L loc d)
-is_fam_decl decl = Right decl
-
-is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
-is_tyfam_inst (L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
-  = Left (L loc d)
-is_tyfam_inst decl
-  = Right decl
-
-is_datafam_inst :: LHsDecl GhcPs
-                -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
-is_datafam_inst (L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))
-  = Left (L loc d)
-is_datafam_inst decl
-  = Right decl
-
-is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
-is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig)
-is_sig decl                    = Right decl
-
-is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
-is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind)
-is_bind decl                     = Right decl
-
-is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec
-is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)
-is_ip_bind decl             = Right decl
-
----------------------------------------------------
---      Data types
----------------------------------------------------
-
-cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)
-
-cvtConstr (NormalC c strtys)
-  = do  { c'   <- cNameN c
-        ; tys' <- mapM cvt_arg strtys
-        ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon noTypeArgs (map hsLinear tys')) }
-
-cvtConstr (RecC c varstrtys)
-  = do  { c'    <- cNameN c
-        ; args' <- mapM cvt_id_arg varstrtys
-        ; con_decl <- wrapParLA (mkConDeclH98 noAnn c' Nothing Nothing . RecCon) args'
-        ; returnLA con_decl }
-
-cvtConstr (InfixC st1 c st2)
-  = do  { c'   <- cNameN c
-        ; st1' <- cvt_arg st1
-        ; st2' <- cvt_arg st2
-        ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing
-                       (InfixCon (hsLinear st1') (hsLinear st2')) }
-
-cvtConstr (ForallC tvs ctxt con)
-  = do  { tvs'      <- cvtTvs tvs
-        ; ctxt'     <- cvtContext funPrec ctxt
-        ; L _ con'  <- cvtConstr con
-        ; returnLA $ add_forall tvs' ctxt' con' }
-  where
-    add_cxt lcxt         Nothing           = mkHsContextMaybe lcxt
-    add_cxt (L loc cxt1) (Just (L _ cxt2))
-      = Just (L loc (cxt1 ++ cxt2))
-
-    add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs
-               -> ConDecl GhcPs -> ConDecl GhcPs
-    add_forall tvs' cxt' con@(ConDeclGADT { con_bndrs = L l outer_bndrs, con_mb_cxt = cxt })
-      = con { con_bndrs  = L l outer_bndrs'
-            , con_mb_cxt = add_cxt cxt' cxt }
-      where
-        outer_bndrs'
-          | null all_tvs = mkHsOuterImplicit
-          | otherwise    = mkHsOuterExplicit noAnn all_tvs
-
-        all_tvs = tvs' ++ outer_exp_tvs
-
-        outer_exp_tvs = hsOuterExplicitBndrs outer_bndrs
-
-    add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })
-      = con { con_forall = not (null all_tvs)
-            , con_ex_tvs = all_tvs
-            , con_mb_cxt = add_cxt cxt' cxt }
-      where
-        all_tvs = tvs' ++ ex_tvs
-
-cvtConstr (GadtC c strtys ty) = case nonEmpty c of
-    Nothing -> failWith GadtNoCons
-    Just c -> do
-        { c'      <- mapM cNameN c
-        ; args    <- mapM cvt_arg strtys
-        ; ty'     <- cvtType ty
-        ; mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'}
-
-cvtConstr (RecGadtC c varstrtys ty) = case nonEmpty c of
-    Nothing -> failWith RecGadtNoCons
-    Just c -> do
-        { c'       <- mapM cNameN c
-        ; ty'      <- cvtType ty
-        ; rec_flds <- mapM cvt_id_arg varstrtys
-        ; lrec_flds <- returnLA rec_flds
-        ; mk_gadt_decl c' (RecConGADT lrec_flds noHsUniTok) ty' }
-
-mk_gadt_decl :: NonEmpty (LocatedN RdrName) -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs
-             -> CvtM (LConDecl GhcPs)
-mk_gadt_decl names args res_ty
-  = do bndrs <- returnLA mkHsOuterImplicit
-       returnLA $ ConDeclGADT
-                   { con_g_ext  = noAnn
-                   , con_names  = names
-                   , con_dcolon = noHsUniTok
-                   , con_bndrs  = bndrs
-                   , con_mb_cxt = Nothing
-                   , con_g_args = args
-                   , con_res_ty = res_ty
-                   , con_doc    = Nothing }
-
-cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
-cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
-cvtSrcUnpackedness SourceNoUnpack       = SrcNoUnpack
-cvtSrcUnpackedness SourceUnpack         = SrcUnpack
-
-cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness
-cvtSrcStrictness NoSourceStrictness = NoSrcStrict
-cvtSrcStrictness SourceLazy         = SrcLazy
-cvtSrcStrictness SourceStrict       = SrcStrict
-
-cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)
-cvt_arg (Bang su ss, ty)
-  = do { ty'' <- cvtType ty
-       ; let ty' = parenthesizeHsType appPrec ty''
-             su' = cvtSrcUnpackedness su
-             ss' = cvtSrcStrictness ss
-       ; returnLA $ HsBangTy noAnn (HsSrcBang NoSourceText su' ss') ty' }
-
-cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
-cvt_id_arg (i, str, ty)
-  = do  { L li i' <- vNameN i
-        ; ty' <- cvt_arg (str,ty)
-        ; returnLA $ ConDeclField
-                          { cd_fld_ext = noAnn
-                          , cd_fld_names
-                              = [L (l2l li) $ FieldOcc noExtField (L li i')]
-                          , cd_fld_type =  ty'
-                          , cd_fld_doc = Nothing} }
-
-cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
-cvtDerivs cs = do { mapM cvtDerivClause cs }
-
-cvt_fundep :: TH.FunDep -> CvtM (LHsFunDep GhcPs)
-cvt_fundep (TH.FunDep xs ys) = do { xs' <- mapM tNameN xs
-                                  ; ys' <- mapM tNameN ys
-                                  ; returnLA (Hs.FunDep noAnn xs' ys') }
-
-
-------------------------------------------
---      Foreign declarations
-------------------------------------------
-
-cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
-cvtForD (ImportF callconv safety from nm ty) =
-  do { l <- getL
-     ; if -- the prim and javascript calling conventions do not support headers
-          -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess
-          |  callconv == TH.Prim || callconv == TH.JavaScript
-          -> mk_imp (CImport (L l $ quotedSourceText from) (L l (cvt_conv callconv)) (L l safety') Nothing
-                             (CFunction (StaticTarget (SourceText from)
-                                                      (mkFastString from) Nothing
-                                                      True)))
-          |  Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety')
-                                          (mkFastString (TH.nameBase nm))
-                                          from (L l $ quotedSourceText from)
-          -> mk_imp impspec
-          |  otherwise
-          -> failWith $ InvalidCCallImpent from }
-  where
-    mk_imp impspec
-      = do { nm' <- vNameN nm
-           ; ty' <- cvtSigType ty
-           ; return (ForeignImport { fd_i_ext = noAnn
-                                   , fd_name = nm'
-                                   , fd_sig_ty = ty'
-                                   , fd_fi = impspec })
-           }
-    safety' = case safety of
-                     Unsafe     -> PlayRisky
-                     Safe       -> PlaySafe
-                     Interruptible -> PlayInterruptible
-
-cvtForD (ExportF callconv as nm ty)
-  = do  { nm' <- vNameN nm
-        ; ty' <- cvtSigType ty
-        ; l <- getL
-        ; let e = CExport (L l (SourceText as)) (L l (CExportStatic (SourceText as)
-                                                (mkFastString as)
-                                                (cvt_conv callconv)))
-        ; return $ ForeignExport { fd_e_ext = noAnn
-                                 , fd_name = nm'
-                                 , fd_sig_ty = ty'
-                                 , fd_fe = e } }
-
-cvt_conv :: TH.Callconv -> CCallConv
-cvt_conv TH.CCall      = CCallConv
-cvt_conv TH.StdCall    = StdCallConv
-cvt_conv TH.CApi       = CApiConv
-cvt_conv TH.Prim       = PrimCallConv
-cvt_conv TH.JavaScript = JavaScriptCallConv
-
-------------------------------------------
---              Pragmas
-------------------------------------------
-
-cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
-cvtPragmaD (InlineP nm inline rm phases)
-  = do { nm' <- vNameN nm
-       ; let dflt = dfltActivation inline
-       ; let src TH.NoInline  = "{-# NOINLINE"
-             src TH.Inline    = "{-# INLINE"
-             src TH.Inlinable = "{-# INLINABLE"
-       ; let ip   = InlinePragma { inl_src    = toSrcTxt inline
-                                 , inl_inline = cvtInline inline (toSrcTxt inline)
-                                 , inl_rule   = cvtRuleMatch rm
-                                 , inl_act    = cvtPhases phases dflt
-                                 , inl_sat    = Nothing }
-                    where
-                     toSrcTxt a = SourceText $ src a
-       ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip }
-
-cvtPragmaD (OpaqueP nm)
-  = do { nm' <- vNameN nm
-       ; let ip = InlinePragma { inl_src    = srcTxt
-                               , inl_inline = Opaque srcTxt
-                               , inl_rule   = Hs.FunLike
-                               , inl_act    = NeverActive
-                               , inl_sat    = Nothing }
-                  where
-                    srcTxt = SourceText "{-# OPAQUE"
-       ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip }
-
-cvtPragmaD (SpecialiseP nm ty inline phases)
-  = do { nm' <- vNameN nm
-       ; ty' <- cvtSigType ty
-       ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"
-             src TH.Inline    = "{-# SPECIALISE INLINE"
-             src TH.Inlinable = "{-# SPECIALISE INLINE"
-       ; let (inline', dflt, srcText) = case inline of
-               Just inline1 -> (cvtInline inline1 (toSrcTxt inline1), dfltActivation inline1,
-                                toSrcTxt inline1)
-               Nothing      -> (NoUserInlinePrag,   AlwaysActive,
-                                SourceText "{-# SPECIALISE")
-               where
-                toSrcTxt a = SourceText $ src a
-       ; let ip = InlinePragma { inl_src    = srcText
-                               , inl_inline = inline'
-                               , inl_rule   = Hs.FunLike
-                               , inl_act    = cvtPhases phases dflt
-                               , inl_sat    = Nothing }
-       ; returnJustLA $ Hs.SigD noExtField $ SpecSig noAnn nm' [ty'] ip }
-
-cvtPragmaD (SpecialiseInstP ty)
-  = do { ty' <- cvtSigType ty
-       ; returnJustLA $ Hs.SigD noExtField $
-         SpecInstSig (noAnn, (SourceText "{-# SPECIALISE")) ty' }
-
-cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
-  = do { let nm' = mkFastString nm
-       ; rd_name' <- returnLA nm'
-       ; let act = cvtPhases phases AlwaysActive
-       ; ty_bndrs' <- traverse cvtTvs ty_bndrs
-       ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs
-       ; lhs'   <- cvtl lhs
-       ; rhs'   <- cvtl rhs
-       ; rule <- returnLA $
-                   HsRule { rd_ext  = (noAnn, quotedSourceText nm)
-                          , rd_name = rd_name'
-                          , rd_act  = act
-                          , rd_tyvs = ty_bndrs'
-                          , rd_tmvs = tm_bndrs'
-                          , rd_lhs  = lhs'
-                          , rd_rhs  = rhs' }
-       ; returnJustLA $ Hs.RuleD noExtField
-            $ HsRules { rds_ext = (noAnn, SourceText "{-# RULES")
-                      , rds_rules = [rule] }
-
-          }
-
-cvtPragmaD (AnnP target exp)
-  = do { exp' <- cvtl exp
-       ; target' <- case target of
-         ModuleAnnotation  -> return ModuleAnnProvenance
-         TypeAnnotation n  -> do
-           n' <- tconName n
-           wrapParLA TypeAnnProvenance n'
-         ValueAnnotation n -> do
-           n' <- vcName n
-           wrapParLA ValueAnnProvenance n'
-       ; returnJustLA $ Hs.AnnD noExtField
-                     $ HsAnnotation (noAnn, (SourceText "{-# ANN")) target' exp'
-       }
-
--- NB: This is the only place in GHC.ThToHs that makes use of the `setL`
--- function. See Note [Source locations within TH splices].
-cvtPragmaD (LineP line file)
-  = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))
-       ; return Nothing
-       }
-cvtPragmaD (CompleteP cls mty)
-  = do { cls'  <- wrapL $ mapM cNameN cls
-       ; mty'  <- traverse tconNameN mty
-       ; returnJustLA $ Hs.SigD noExtField
-                   $ CompleteMatchSig (noAnn, NoSourceText) cls' mty' }
-
-dfltActivation :: TH.Inline -> Activation
-dfltActivation TH.NoInline = NeverActive
-dfltActivation _           = AlwaysActive
-
-cvtInline :: TH.Inline  -> SourceText -> Hs.InlineSpec
-cvtInline TH.NoInline   srcText  = Hs.NoInline  srcText
-cvtInline TH.Inline     srcText  = Hs.Inline    srcText
-cvtInline TH.Inlinable  srcText  = Hs.Inlinable srcText
-
-cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
-cvtRuleMatch TH.ConLike = Hs.ConLike
-cvtRuleMatch TH.FunLike = Hs.FunLike
-
-cvtPhases :: TH.Phases -> Activation -> Activation
-cvtPhases AllPhases       dflt = dflt
-cvtPhases (FromPhase i)   _    = ActiveAfter NoSourceText i
-cvtPhases (BeforePhase i) _    = ActiveBefore NoSourceText i
-
-cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
-cvtRuleBndr (RuleVar n)
-  = do { n' <- vNameN n
-       ; returnLA $ Hs.RuleBndr noAnn n' }
-cvtRuleBndr (TypedRuleVar n ty)
-  = do { n'  <- vNameN n
-       ; ty' <- cvtType ty
-       ; returnLA $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' }
-
----------------------------------------------------
---              Declarations
----------------------------------------------------
-
-cvtLocalDecs :: THDeclDescriptor -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
-cvtLocalDecs declDescr ds
-  = case partitionWith is_ip_bind ds of
-      ([], []) -> return (EmptyLocalBinds noExtField)
-      ([], _) -> do
-        ds' <- cvtDecs ds
-        let (binds, prob_sigs) = partitionWith is_bind ds'
-        let (sigs, bads) = partitionWith is_sig prob_sigs
-        for_ (nonEmpty bads) $ \ bad_decls ->
-          failWith (IllegalDeclaration declDescr $ IllegalDecls bad_decls)
-        return (HsValBinds noAnn (ValBinds NoAnnSortKey (listToBag binds) sigs))
-      (ip_binds, []) -> do
-        binds <- mapM (uncurry cvtImplicitParamBind) ip_binds
-        return (HsIPBinds noAnn (IPBinds noExtField binds))
-      ((_:_), (_:_)) ->
-        failWith ImplicitParamsWithOtherBinds
-
-cvtClause :: HsMatchContext GhcPs
-          -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
-cvtClause ctxt (Clause ps body wheres)
-  = do  { ps' <- cvtPats ps
-        ; let pps = map (parenthesizePat appPrec) ps'
-        ; g'  <- cvtGuard body
-        ; ds' <- cvtLocalDecs WhereClause wheres
-        ; returnLA $ Hs.Match noAnn ctxt pps (GRHSs emptyComments g' ds') }
-
-cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
-cvtImplicitParamBind n e = do
-    n' <- wrapL (ipName n)
-    e' <- cvtl e
-    returnLA (IPBind noAnn (reLocA n') e')
-
--------------------------------------------------------------------
---              Expressions
--------------------------------------------------------------------
-
-cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
-cvtl e = wrapLA (cvt e)
-  where
-    cvt (VarE s)   = do { s' <- vName s; wrapParLA (HsVar noExtField) s' }
-    cvt (ConE s)   = do { s' <- cName s; wrapParLA (HsVar noExtField) s' }
-    cvt (LitE l)
-      | overloadedLit l = go cvtOverLit (HsOverLit noComments)
-                             (hsOverLitNeedsParens appPrec)
-      | otherwise       = go cvtLit (HsLit noComments)
-                             (hsLitNeedsParens appPrec)
-      where
-        go :: (Lit -> CvtM (l GhcPs))
-           -> (l GhcPs -> HsExpr GhcPs)
-           -> (l GhcPs -> Bool)
-           -> CvtM (HsExpr GhcPs)
-        go cvt_lit mk_expr is_compound_lit = do
-          l' <- cvt_lit l
-          let e' = mk_expr l'
-          if is_compound_lit l' then wrapParLA gHsPar e' else pure e'
-    cvt (AppE e1 e2)   = do { e1' <- parenthesizeHsExpr opPrec <$> cvtl e1
-                            ; e2' <- parenthesizeHsExpr appPrec <$> cvtl e2
-                            ; return $ HsApp noComments e1' e2' }
-    cvt (AppTypeE e t) = do { e' <- parenthesizeHsExpr opPrec <$> cvtl e
-                            ; t' <- parenthesizeHsType appPrec <$> cvtType t
-                            ; return $ HsAppType noExtField e' noHsTok
-                                     $ mkHsWildCardBndrs t' }
-    cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its
-                               -- own expression to avoid pretty-printing
-                               -- oddities that can result from zero-argument
-                               -- lambda expressions. See #13856.
-    cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
-                            ; let pats = map (parenthesizePat appPrec) ps'
-                            ; th_origin <- getOrigin
-                            ; wrapParLA (HsLam noExtField . mkMatchGroup th_origin)
-                                        [mkSimpleMatch LambdaExpr pats e']}
-    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch $ LamCaseAlt LamCase) ms
-                            ; th_origin <- getOrigin
-                            ; wrapParLA (HsLamCase noAnn LamCase . mkMatchGroup th_origin) ms'
-                            }
-    cvt (LamCasesE ms)
-      | null ms   = failWith CasesExprWithoutAlts
-      | otherwise = do { ms' <- mapM (cvtClause $ LamCaseAlt LamCases) ms
-                       ; th_origin <- getOrigin
-                       ; wrapParLA (HsLamCase noAnn LamCases . mkMatchGroup th_origin) ms'
-                       }
-    cvt (TupE es)        = cvt_tup es Boxed
-    cvt (UnboxedTupE es) = cvt_tup es Unboxed
-    cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
-                                       ; unboxedSumChecks alt arity
-                                       ; return $ ExplicitSum noAnn alt arity e'}
-    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
-                            ; return $ mkHsIf x' y' z' noAnn }
-    cvt (MultiIfE alts)
-      | null alts      = failWith MultiWayIfWithoutAlts
-      | otherwise      = do { alts' <- mapM cvtpair alts
-                            ; return $ HsMultiIf noAnn alts' }
-    cvt (LetE ds e)    = do { ds' <- cvtLocalDecs LetExpression ds
-                            ; e' <- cvtl e; return $ HsLet noAnn noHsTok ds' noHsTok e'}
-    cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
-                            ; th_origin <- getOrigin
-                            ; wrapParLA (HsCase noAnn e' . mkMatchGroup th_origin) ms' }
-    cvt (DoE m ss)     = cvtHsDo (DoExpr (mk_mod <$> m)) ss
-    cvt (MDoE m ss)    = cvtHsDo (MDoExpr (mk_mod <$> m)) ss
-    cvt (CompE ss)     = cvtHsDo ListComp ss
-    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd
-                            ; return $ ArithSeq noAnn Nothing dd' }
-    cvt (ListE xs)
-      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s)
-                                          ; return (HsLit noComments l') }
-             -- Note [Converting strings]
-      | otherwise       = do { xs' <- mapM cvtl xs
-                             ; return $ ExplicitList noAnn xs'
-                             }
-
-    -- Infix expressions
-    cvt (InfixE (Just x) s (Just y)) = ensureValidOpExp s $
-      do { x' <- cvtl x
-         ; s' <- cvtl s
-         ; y' <- cvtl y
-         ; let px = parenthesizeHsExpr opPrec x'
-               py = parenthesizeHsExpr opPrec y'
-         ; wrapParLA gHsPar
-           $ OpApp noAnn px s' py }
-           -- Parenthesise both arguments and result,
-           -- to ensure this operator application does
-           -- does not get re-associated
-           -- See Note [Operator association]
-    cvt (InfixE Nothing  s (Just y)) = ensureValidOpExp s $
-                                       do { s' <- cvtl s; y' <- cvtl y
-                                          ; wrapParLA gHsPar $
-                                                          SectionR noComments s' y' }
-                                            -- See Note [Sections in HsSyn] in GHC.Hs.Expr
-    cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $
-                                       do { x' <- cvtl x; s' <- cvtl s
-                                          ; wrapParLA gHsPar $
-                                                          SectionL noComments x' s' }
-
-    cvt (InfixE Nothing  s Nothing ) = ensureValidOpExp s $
-                                       do { s' <- cvtl s
-                                          ; return $ gHsPar s' }
-                                       -- Can I indicate this is an infix thing?
-                                       -- Note [Dropping constructors]
-
-    cvt (UInfixE x s y)  = ensureValidOpExp s $
-                           do { x' <- cvtl x
-                              ; let x'' = case unLoc x' of
-                                            OpApp {} -> x'
-                                            _ -> mkLHsPar x'
-                              ; cvtOpApp x'' s y } --  Note [Converting UInfix]
-
-    cvt (ParensE e)      = do { e' <- cvtl e; return $ gHsPar e' }
-    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtSigType t
-                              ; let pe = parenthesizeHsExpr sigPrec e'
-                              ; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') }
-    cvt (RecConE c flds) = do { c' <- cNameN c
-                              ; flds' <- mapM (cvtFld (wrapParLA mkFieldOcc)) flds
-                              ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) noAnn }
-    cvt (RecUpdE e flds) = do { e' <- cvtl e
-                              ; flds'
-                                  <- mapM (cvtFld (wrapParLA mkAmbiguousFieldOcc))
-                                           flds
-                              ; return $ RecordUpd noAnn e' (Left flds') }
-    cvt (StaticE e)      = fmap (HsStatic noAnn) $ cvtl e
-    cvt (UnboundVarE s)  = do -- Use of 'vcName' here instead of 'vName' is
-                              -- important, because UnboundVarE may contain
-                              -- constructor names - see #14627.
-                              { s' <- vcName s
-                              ; wrapParLA (HsVar noExtField) s' }
-    cvt (LabelE s)       = return $ HsOverLabel noComments (fsLit s)
-    cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' }
-    cvt (GetFieldE exp f) = do { e' <- cvtl exp
-                               ; return $ HsGetField noComments e'
-                                         (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (FieldLabelString (fsLit f))))) }
-    cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap
-                                         (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . FieldLabelString  . fsLit) xs
-
-{- | #16895 Ensure an infix expression's operator is a variable/constructor.
-Consider this example:
-
-  $(uInfixE [|1|] [|id id|] [|2|])
-
-This infix expression is obviously ill-formed so we use this helper function
-to reject such programs outright.
-
-The constructors `ensureValidOpExp` permits should be in sync with `pprInfixExp`
-in Language.Haskell.TH.Ppr from the template-haskell library.
--}
-ensureValidOpExp :: TH.Exp -> CvtM a -> CvtM a
-ensureValidOpExp (VarE _n) m = m
-ensureValidOpExp (ConE _n) m = m
-ensureValidOpExp (UnboundVarE _n) m = m
-ensureValidOpExp _e _m = failWith NonVarInInfixExpr
-
-{- Note [Dropping constructors]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we drop constructors from the input, we must insert parentheses around the
-argument. For example:
-
-  UInfixE x * (AppE (InfixE (Just y) + Nothing) z)
-
-If we convert the InfixE expression to an operator section but don't insert
-parentheses, the above expression would be reassociated to
-
-  OpApp (OpApp x * y) + z
-
-which we don't want.
--}
-
-cvtFld :: (RdrName -> CvtM t) -> (TH.Name, TH.Exp)
-       -> CvtM (LHsFieldBind GhcPs (LocatedAn NoEpAnns t) (LHsExpr GhcPs))
-cvtFld f (v,e)
-  = do  { v' <- vNameL v
-        ; lhs' <- traverse f v'
-        ; e' <- cvtl e
-        ; returnLA $ HsFieldBind { hfbAnn = noAnn
-                                 , hfbLHS = la2la lhs'
-                                 , hfbRHS = e'
-                                 , hfbPun = False} }
-
-cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)
-cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
-cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
-cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
-cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
-
-cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)
-cvt_tup es boxity = do { let cvtl_maybe Nothing  = return (missingTupArg noAnn)
-                             cvtl_maybe (Just e) = fmap (Present noAnn) (cvtl e)
-                       ; es' <- mapM cvtl_maybe es
-                       ; return $ ExplicitTuple
-                                    noAnn
-                                    es'
-                                    boxity }
-
-{- Note [Operator association]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must be quite careful about adding parens:
-  * Infix (UInfix ...) op arg      Needs parens round the first arg
-  * Infix (Infix ...) op arg       Needs parens round the first arg
-  * UInfix (UInfix ...) op arg     No parens for first arg
-  * UInfix (Infix ...) op arg      Needs parens round first arg
-
-
-Note [Converting UInfix]
-~~~~~~~~~~~~~~~~~~~~~~~~
-When converting @UInfixE@, @UInfixP@, @UInfixT@, and @PromotedUInfixT@ values,
-we want to readjust the trees to reflect the fixities of the underlying
-operators:
-
-  UInfixE x * (UInfixE y + z) ---> (x * y) + z
-
-This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
-@mkHsOpTyRn@ in GHC.Rename.HsType), which expects that the input will be
-completely right-biased for types and left-biased for everything else. So we
-left-bias the trees of @UInfixP@ and @UInfixE@ and right-bias the trees of
-@UInfixT@ and @PromotedUnfixT@.
-
-Sample input:
-
-  UInfixE
-   (UInfixE x op1 y)
-   op2
-   (UInfixE z op3 w)
-
-Sample output:
-
-  OpApp
-    (OpApp
-      (OpApp x op1 y)
-      op2
-      z)
-    op3
-    w
-
-The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this
-biasing.
--}
-
-{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
-The produced tree of infix expressions will be left-biased, provided @x@ is.
-
-We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis
-is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that
-this holds for both branches (of @cvtOpApp@), provided we assume it holds for
-the recursive calls to @cvtOpApp@.
-
-When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
-since we have already run @cvtl@ on it.
--}
-cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs)
-cvtOpApp x op1 (UInfixE y op2 z)
-  = do { l <- wrapLA $ cvtOpApp x op1 y
-       ; cvtOpApp l op2 z }
-cvtOpApp x op y
-  = do { op' <- cvtl op
-       ; y' <- cvtl y
-       ; return (OpApp noAnn x op' y') }
-
--------------------------------------
---      Do notation and statements
--------------------------------------
-
-cvtHsDo :: HsDoFlavour -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
-cvtHsDo do_or_lc stmts = case nonEmpty stmts of
-    Nothing -> failWith EmptyStmtListInDoBlock
-    Just stmts -> do
-        { stmts' <- traverse cvtStmt stmts
-        ; let stmts'' = NE.init stmts'
-              last' = NE.last stmts'
-
-        ; last'' <- case last' of
-                    (L loc (BodyStmt _ body _ _))
-                      -> return (L loc (mkLastStmt body))
-                    _ -> failWith (bad_last last')
-
-        ; wrapParLA (HsDo noAnn do_or_lc) (stmts'' ++ [last'']) }
-  where
-    bad_last stmt = IllegalLastStatement do_or_lc stmt
-
-cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)]
-cvtStmts = mapM cvtStmt
-
-cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))
-cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnLA $ mkBodyStmt e' }
-cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnLA $ mkPsBindStmt noAnn p' e' }
-cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs LetBinding ds
-                            ; returnLA $ LetStmt noAnn ds' }
-cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss
-                            ; returnLA $ ParStmt noExtField dss' noExpr noSyntaxExpr }
-  where
-    cvt_one ds = do { ds' <- cvtStmts ds
-                    ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) }
-cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss
-                          ; rec_stmt <- wrapParLA (mkRecStmt noAnn) ss'
-                          ; returnLA rec_stmt }
-
-cvtMatch :: HsMatchContext GhcPs
-         -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
-cvtMatch ctxt (TH.Match p body decs)
-  = do  { p' <- cvtPat p
-        ; let lp = case p' of
-                     (L loc SigPat{}) -> L loc (gParPat p') -- #14875
-                     _                -> p'
-        ; g' <- cvtGuard body
-        ; decs' <- cvtLocalDecs WhereClause decs
-        ; returnLA $ Hs.Match noAnn ctxt [lp] (GRHSs emptyComments g' decs') }
-
-cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
-cvtGuard (GuardedB pairs) = mapM cvtpair pairs
-cvtGuard (NormalB e)      = do { e' <- cvtl e
-                               ; g' <- returnLA $ GRHS noAnn [] e'; return [g'] }
-
-cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
-cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
-                              ; g' <- returnLA $ mkBodyStmt ge'
-                              ; returnLA $ GRHS noAnn [g'] rhs' }
-cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
-                              ; returnLA $ GRHS noAnn gs' rhs' }
-
-cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
-cvtOverLit (IntegerL i)
-  = do { force i; return $ mkHsIntegral   (mkIntegralLit i) }
-cvtOverLit (RationalL r)
-  = do { force r; return $ mkHsFractional (mkTHFractionalLit r) }
-cvtOverLit (StringL s)
-  = do { let { s' = mkFastString s }
-       ; force s'
-       ; return $ mkHsIsString (quotedSourceText s) s'
-       }
-cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
--- An Integer is like an (overloaded) '3' in a Haskell source program
--- Similarly 3.5 for fractionals
-
-{- Note [Converting strings]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
-a string literal for "xy".  Of course, we might hope to get
-(LitE (StringL "xy")), but not always, and allCharLs fails quickly
-if it isn't a literal string
--}
-
-allCharLs :: [TH.Exp] -> Maybe String
--- Note [Converting strings]
--- NB: only fire up this setup for a non-empty list, else
---     there's a danger of returning "" for [] :: [Int]!
-allCharLs xs
-  = case xs of
-      LitE (CharL c) : ys -> go [c] ys
-      _                   -> Nothing
-  where
-    go cs []                    = Just (reverse cs)
-    go cs (LitE (CharL c) : ys) = go (c:cs) ys
-    go _  _                     = Nothing
-
-cvtLit :: Lit -> CvtM (HsLit GhcPs)
-cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim NoSourceText i }
-cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim NoSourceText w }
-cvtLit (FloatPrimL f)
-  = do { force f; return $ HsFloatPrim noExtField (mkTHFractionalLit f) }
-cvtLit (DoublePrimL f)
-  = do { force f; return $ HsDoublePrim noExtField (mkTHFractionalLit f) }
-cvtLit (CharL c)       = do { force c; return $ HsChar NoSourceText c }
-cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim NoSourceText c }
-cvtLit (StringL s)     = do { let { s' = mkFastString s }
-                            ; force s'
-                            ; return $ HsString (quotedSourceText s) s' }
-cvtLit (StringPrimL s) = do { let { !s' = BS.pack s }
-                            ; return $ HsStringPrim NoSourceText s' }
-cvtLit (BytesPrimL (Bytes fptr off sz)) = do
-  let bs = unsafePerformIO $ withForeignPtr fptr $ \ptr ->
-             BS.packCStringLen (ptr `plusPtr` fromIntegral off, fromIntegral sz)
-  force bs
-  return $ HsStringPrim NoSourceText bs
-cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
-        -- cvtLit should not be called on IntegerL, RationalL
-        -- That precondition is established right here in
-        -- "GHC.ThToHs", hence panic
-
-quotedSourceText :: String -> SourceText
-quotedSourceText s = SourceText $ "\"" ++ s ++ "\""
-
-cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]
-cvtPats pats = mapM cvtPat pats
-
-cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)
-cvtPat pat = wrapLA (cvtp pat)
-
-cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)
-cvtp (TH.LitP l)
-  | overloadedLit l    = do { l' <- cvtOverLit l
-                            ; l'' <- returnLA l'
-                            ; return (mkNPat l'' Nothing noAnn) }
-                                  -- Not right for negative patterns;
-                                  -- need to think about that!
-  | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' }
-cvtp (TH.VarP s)       = do { s' <- vName s
-                            ; wrapParLA (Hs.VarPat noExtField) s' }
-cvtp (TupP ps)         = do { ps' <- cvtPats ps
-                            ; return $ TuplePat noAnn ps' Boxed }
-cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps
-                            ; return $ TuplePat noAnn ps' Unboxed }
-cvtp (UnboxedSumP p alt arity)
-                       = do { p' <- cvtPat p
-                            ; unboxedSumChecks alt arity
-                            ; return $ SumPat noAnn p' alt arity }
-cvtp (ConP s ts ps)    = do { s' <- cNameN s
-                            ; ps' <- cvtPats ps
-                            ; ts' <- mapM cvtType ts
-                            ; let pps = map (parenthesizePat appPrec) ps'
-                                  pts = map (\t -> HsConPatTyArg noHsTok (mkHsPatSigType noAnn t)) ts'
-                            ; return $ ConPat
-                                { pat_con_ext = noAnn
-                                , pat_con = s'
-                                , pat_args = PrefixCon pts pps
-                                }
-                            }
-cvtp (InfixP p1 s p2)  = do { s' <- cNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2
-                            ; wrapParLA gParPat $
-                              ConPat
-                                { pat_con_ext = noAnn
-                                , pat_con = s'
-                                , pat_args = InfixCon
-                                    (parenthesizePat opPrec p1')
-                                    (parenthesizePat opPrec p2')
-                                }
-                            }
-                            -- See Note [Operator association]
-cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
-cvtp (ParensP p)       = do { p' <- cvtPat p;
-                            ; case unLoc p' of  -- may be wrapped ConPatIn
-                                ParPat {} -> return $ unLoc p'
-                                _         -> return $ gParPat p' }
-cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noAnn p' }
-cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noAnn p' }
-cvtp (TH.AsP s p)      = do { s' <- vNameN s; p' <- cvtPat p
-                            ; return $ AsPat noAnn s' noHsTok p' }
-cvtp TH.WildP          = return $ WildPat noExtField
-cvtp (RecP c fs)       = do { c' <- cNameN c; fs' <- mapM cvtPatFld fs
-                            ; return $ ConPat
-                                { pat_con_ext = noAnn
-                                , pat_con = c'
-                                , pat_args = Hs.RecCon $ HsRecFields fs' Nothing
-                                }
-                            }
-cvtp (ListP ps)        = do { ps' <- cvtPats ps
-                            ; return
-                                   $ ListPat noAnn ps'}
-cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
-                            ; return $ SigPat noAnn p' (mkHsPatSigType noAnn t') }
-cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
-                            ; return $ ViewPat noAnn e' p'}
-
-cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
-cvtPatFld (s,p)
-  = do  { L ls s' <- vNameN s
-        ; p' <- cvtPat p
-        ; returnLA $ HsFieldBind { hfbAnn = noAnn
-                                 , hfbLHS
-                                    = L (l2l ls) $ mkFieldOcc (L (l2l ls) s')
-                                 , hfbRHS = p'
-                                 , hfbPun = False} }
-
-{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
-The produced tree of infix patterns will be left-biased, provided @x@ is.
-
-See the @cvtOpApp@ documentation for how this function works.
--}
-cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs)
-cvtOpAppP x op1 (UInfixP y op2 z)
-  = do { l <- wrapLA $ cvtOpAppP x op1 y
-       ; cvtOpAppP l op2 z }
-cvtOpAppP x op y
-  = do { op' <- cNameN op
-       ; y' <- cvtPat y
-       ; return $ ConPat
-          { pat_con_ext = noAnn
-          , pat_con = op'
-          , pat_args = InfixCon x y'
-          }
-       }
-
------------------------------------------------------------
---      Types and type variables
-
-class CvtFlag flag flag' | flag -> flag' where
-  cvtFlag :: flag -> flag'
-
-instance CvtFlag () () where
-  cvtFlag () = ()
-
-instance CvtFlag TH.Specificity Hs.Specificity where
-  cvtFlag TH.SpecifiedSpec = Hs.SpecifiedSpec
-  cvtFlag TH.InferredSpec  = Hs.InferredSpec
-
-cvtTvs :: CvtFlag flag flag' => [TH.TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs]
-cvtTvs tvs = mapM cvt_tv tvs
-
-cvt_tv :: CvtFlag flag flag' => (TH.TyVarBndr flag) -> CvtM (LHsTyVarBndr flag' GhcPs)
-cvt_tv (TH.PlainTV nm fl)
-  = do { nm' <- tNameN nm
-       ; let fl' = cvtFlag fl
-       ; returnLA $ UserTyVar noAnn fl' nm' }
-cvt_tv (TH.KindedTV nm fl ki)
-  = do { nm' <- tNameN nm
-       ; let fl' = cvtFlag fl
-       ; ki' <- cvtKind ki
-       ; returnLA $ KindedTyVar noAnn fl' nm' ki' }
-
-cvtRole :: TH.Role -> Maybe Coercion.Role
-cvtRole TH.NominalR          = Just Coercion.Nominal
-cvtRole TH.RepresentationalR = Just Coercion.Representational
-cvtRole TH.PhantomR          = Just Coercion.Phantom
-cvtRole TH.InferR            = Nothing
-
-cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs)
-cvtContext p tys = do { preds' <- mapM cvtPred tys
-                      ; parenthesizeHsContext p <$> returnLA preds' }
-
-cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)
-cvtPred = cvtType
-
-cvtDerivClauseTys :: TH.Cxt -> CvtM (LDerivClauseTys GhcPs)
-cvtDerivClauseTys tys
-  = do { tys' <- mapM cvtSigType tys
-         -- Since TH.Cxt doesn't indicate the presence or absence of
-         -- parentheses in a deriving clause, we have to choose between
-         -- DctSingle and DctMulti somewhat arbitrarily. We opt to use DctMulti
-         -- unless the TH.Cxt is a singleton list whose type is a bare type
-         -- constructor with no arguments.
-       ; case tys' of
-           [ty'@(L l (HsSig { sig_bndrs = HsOuterImplicit{}
-                            , sig_body  = L _ (HsTyVar _ NotPromoted _) }))]
-                 -> return $ L (l2l l) $ DctSingle noExtField ty'
-           _     -> returnLA $ DctMulti noExtField tys' }
-
-cvtDerivClause :: TH.DerivClause
-               -> CvtM (LHsDerivingClause GhcPs)
-cvtDerivClause (TH.DerivClause ds tys)
-  = do { tys' <- cvtDerivClauseTys tys
-       ; ds'  <- traverse cvtDerivStrategy ds
-       ; returnLA $ HsDerivingClause noAnn ds' tys' }
-
-cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
-cvtDerivStrategy TH.StockStrategy    = returnLA (Hs.StockStrategy noAnn)
-cvtDerivStrategy TH.AnyclassStrategy = returnLA (Hs.AnyclassStrategy noAnn)
-cvtDerivStrategy TH.NewtypeStrategy  = returnLA (Hs.NewtypeStrategy noAnn)
-cvtDerivStrategy (TH.ViaStrategy ty) = do
-  ty' <- cvtSigType ty
-  returnLA $ Hs.ViaStrategy (XViaStrategyPs noAnn ty')
-
-cvtType :: TH.Type -> CvtM (LHsType GhcPs)
-cvtType = cvtTypeKind TypeLevel
-
-cvtSigType :: TH.Type -> CvtM (LHsSigType GhcPs)
-cvtSigType = cvtSigTypeKind TypeLevel
-
--- | Convert a Template Haskell 'Type' to an 'LHsSigType'. To avoid duplicating
--- the logic in 'cvtTypeKind' here, we simply reuse 'cvtTypeKind' and perform
--- surgery on the 'LHsType' it returns to turn it into an 'LHsSigType'.
-cvtSigTypeKind :: TypeOrKind -> TH.Type -> CvtM (LHsSigType GhcPs)
-cvtSigTypeKind typeOrKind ty = do
-  ty' <- cvtTypeKind typeOrKind ty
-  pure $ hsTypeToHsSigType ty'
-
-cvtTypeKind :: TypeOrKind -> TH.Type -> CvtM (LHsType GhcPs)
-cvtTypeKind typeOrKind ty
-  = do { (head_ty, tys') <- split_ty_app ty
-       ; let m_normals = mapM extract_normal tys'
-                                where extract_normal (HsValArg ty) = Just ty
-                                      extract_normal _ = Nothing
-
-       ; case head_ty of
-           TupleT n
-            | Just normals <- m_normals
-            , normals `lengthIs` n         -- Saturated
-            -> returnLA (HsTupleTy noAnn HsBoxedOrConstraintTuple normals)
-            | otherwise
-            -> do { tuple_tc <- returnLA $ getRdrName $ tupleTyCon Boxed n
-                  ; mk_apps (HsTyVar noAnn NotPromoted tuple_tc) tys' }
-           UnboxedTupleT n
-             | Just normals <- m_normals
-             , normals `lengthIs` n               -- Saturated
-             -> returnLA (HsTupleTy noAnn HsUnboxedTuple normals)
-             | otherwise
-             -> do { tuple_tc <- returnLA $ getRdrName $ tupleTyCon Unboxed n
-                   ; mk_apps (HsTyVar noAnn NotPromoted tuple_tc) tys' }
-           UnboxedSumT n
-             | n < 2
-            -> failWith $ IllegalSumArity n
-             | Just normals <- m_normals
-             , normals `lengthIs` n -- Saturated
-             -> returnLA (HsSumTy noAnn normals)
-             | otherwise
-             -> do { sum_tc <- returnLA $ getRdrName $ sumTyCon n
-                   ; mk_apps (HsTyVar noAnn NotPromoted sum_tc) tys' }
-           ArrowT
-             | Just normals <- m_normals
-             , [x',y'] <- normals -> do
-                 x'' <- case unLoc x' of
-                          HsFunTy{}    -> returnLA (HsParTy noAnn x')
-                          HsForAllTy{} -> returnLA (HsParTy noAnn x') -- #14646
-                          HsQualTy{}   -> returnLA (HsParTy noAnn x') -- #15324
-                          _            -> return $
-                                          parenthesizeHsType sigPrec x'
-                 let y'' = parenthesizeHsType sigPrec y'
-                 returnLA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) x'' y'')
-             | otherwise
-             -> do { fun_tc <- returnLA $ getRdrName unrestrictedFunTyCon
-                   ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' }
-           MulArrowT
-             | Just normals <- m_normals
-             , [w',x',y'] <- normals -> do
-                 x'' <- case unLoc x' of
-                          HsFunTy{}    -> returnLA (HsParTy noAnn x')
-                          HsForAllTy{} -> returnLA (HsParTy noAnn x') -- #14646
-                          HsQualTy{}   -> returnLA (HsParTy noAnn x') -- #15324
-                          _            -> return $
-                                          parenthesizeHsType sigPrec x'
-                 let y'' = parenthesizeHsType sigPrec y'
-                     w'' = hsTypeToArrow w'
-                 returnLA (HsFunTy noAnn w'' x'' y'')
-             | otherwise
-             -> do { fun_tc <- returnLA $ getRdrName fUNTyCon
-                   ; mk_apps (HsTyVar noAnn NotPromoted fun_tc) tys' }
-           ListT
-             | Just normals <- m_normals
-             , [x'] <- normals ->
-                returnLA (HsListTy noAnn x')
-             | otherwise
-             -> do { list_tc <- returnLA $ getRdrName listTyCon
-                   ; mk_apps (HsTyVar noAnn NotPromoted list_tc) tys' }
-
-           VarT nm -> do { nm' <- tNameN nm
-                         ; mk_apps (HsTyVar noAnn NotPromoted nm') tys' }
-           ConT nm -> do { nm' <- tconName nm
-                         ; let prom = name_promotedness nm'
-                         ; lnm' <- returnLA nm'
-                         ; mk_apps (HsTyVar noAnn prom lnm') tys'}
-
-           ForallT tvs cxt ty
-             | null tys'
-             -> do { tvs' <- cvtTvs tvs
-                   ; cxt' <- cvtContext funPrec cxt
-                   ; ty'  <- cvtType ty
-                   ; loc <- getL
-                   ; let loc' = noAnnSrcSpan loc
-                   ; let tele   = mkHsForAllInvisTele noAnn tvs'
-                         hs_ty  = mkHsForAllTy loc' tele rho_ty
-                         rho_ty = mkHsQualTy cxt loc' cxt' ty'
-
-                   ; return hs_ty }
-
-           ForallVisT tvs ty
-             | null tys'
-             -> do { tvs' <- cvtTvs tvs
-                   ; ty'  <- cvtType ty
-                   ; loc  <- getL
-                   ; let loc' = noAnnSrcSpan loc
-                   ; let tele = mkHsForAllVisTele noAnn tvs'
-                   ; pure $ mkHsForAllTy loc' tele ty' }
-
-           SigT ty ki
-             -> do { ty' <- cvtType ty
-                   ; ki' <- cvtKind ki
-                   ; mk_apps (HsKindSig noAnn ty' ki') tys'
-                   }
-
-           LitT lit
-             -> mk_apps (HsTyLit noExtField (cvtTyLit lit)) tys'
-
-           WildCardT
-             -> mk_apps mkAnonWildCardTy tys'
-
-           InfixT t1 s t2
-             -> do { s'  <- tconName s
-                   ; t1' <- cvtType t1
-                   ; t2' <- cvtType t2
-                   ; let prom = name_promotedness s'
-                   ; ls' <- returnLA s'
-                   ; mk_apps
-                      (HsTyVar noAnn prom ls')
-                      ([HsValArg t1', HsValArg t2'] ++ tys')
-                   }
-
-           UInfixT t1 s t2
-             -> do { s' <- tconNameN s
-                   ; t2' <- cvtType t2
-                   ; t <- cvtOpAppT NotPromoted t1 s' t2'
-                   ; mk_apps (unLoc t) tys'
-                   } -- Note [Converting UInfix]
-
-           PromotedInfixT t1 s t2
-             -> do { s'  <- cNameN s
-                   ; t1' <- cvtType t1
-                   ; t2' <- cvtType t2
-                   ; mk_apps
-                      (HsTyVar noAnn IsPromoted s')
-                      ([HsValArg t1', HsValArg t2'] ++ tys')
-                   }
-
-           PromotedUInfixT t1 s t2
-             -> do { s' <- cNameN s
-                   ; t2' <- cvtType t2
-                   ; t <- cvtOpAppT IsPromoted t1 s' t2'
-                   ; mk_apps (unLoc t) tys'
-                   } -- Note [Converting UInfix]
-
-           ParensT t
-             -> do { t' <- cvtType t
-                   ; mk_apps (HsParTy noAnn t') tys'
-                   }
-
-           PromotedT nm -> do { nm' <- cNameN nm
-                              ; mk_apps (HsTyVar noAnn IsPromoted nm')
-                                        tys' }
-                 -- Promoted data constructor; hence cName
-
-           PromotedTupleT n
-              | Just normals <- m_normals
-              , normals `lengthIs` n   -- Saturated
-              -> returnLA (HsExplicitTupleTy noAnn normals)
-              | otherwise
-              -> do { tuple_tc <- returnLA $ getRdrName $ tupleDataCon Boxed n
-                    ; mk_apps (HsTyVar noAnn IsPromoted tuple_tc) tys' }
-
-           PromotedNilT
-             -> mk_apps (HsExplicitListTy noAnn IsPromoted []) tys'
-
-           PromotedConsT  -- See Note [Representing concrete syntax in types]
-                          -- in Language.Haskell.TH.Syntax
-              | Just normals <- m_normals
-              , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals
-              -> returnLA (HsExplicitListTy noAnn ip (ty1:tys2))
-              | otherwise
-              -> do { cons_tc <- returnLA $ getRdrName consDataCon
-                    ; mk_apps (HsTyVar noAnn IsPromoted cons_tc) tys' }
-
-           StarT
-             -> do { type_tc <- returnLA $ getRdrName liftedTypeKindTyCon
-                   ; mk_apps (HsTyVar noAnn NotPromoted type_tc) tys' }
-
-           ConstraintT
-             -> do { constraint_tc <- returnLA $ getRdrName constraintKindTyCon
-                   ; mk_apps (HsTyVar noAnn NotPromoted constraint_tc) tys' }
-
-           EqualityT
-             | Just normals <- m_normals
-             , [x',y'] <- normals ->
-                   let px = parenthesizeHsType opPrec x'
-                       py = parenthesizeHsType opPrec y'
-                   in do { eq_tc <- returnLA eqTyCon_RDR
-                         ; returnLA (HsOpTy noAnn NotPromoted px eq_tc py) }
-               -- The long-term goal is to remove the above case entirely and
-               -- subsume it under the case for InfixT. See #15815, comment:6,
-               -- for more details.
-
-             | otherwise ->
-                   do { eq_tc <- returnLA eqTyCon_RDR
-                      ; mk_apps (HsTyVar noAnn NotPromoted eq_tc) tys' }
-           ImplicitParamT n t
-             -> do { n' <- wrapL $ ipName n
-                   ; t' <- cvtType t
-                   ; returnLA (HsIParamTy noAnn (reLocA n') t')
-                   }
-
-           _ -> failWith (MalformedType typeOrKind ty)
-    }
-
-hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs
-hsTypeToArrow w = case unLoc w of
-                     HsTyVar _ _ (L _ (isExact_maybe -> Just n))
-                        | n == oneDataConName -> HsLinearArrow (HsPct1 noHsTok noHsUniTok)
-                        | n == manyDataConName -> HsUnrestrictedArrow noHsUniTok
-                     _ -> HsExplicitMult noHsTok w noHsUniTok
-
--- ConT/InfixT can contain both data constructor (i.e., promoted) names and
--- other (i.e, unpromoted) names, as opposed to PromotedT, which can only
--- contain data constructor names. See #15572/#17394. We use this function to
--- determine whether to mark a name as promoted/unpromoted when dealing with
--- ConT/InfixT.
-name_promotedness :: RdrName -> Hs.PromotionFlag
-name_promotedness nm
-  | isRdrDataCon nm = IsPromoted
-  | otherwise       = NotPromoted
-
--- | Constructs an application of a type to arguments passed in a list.
-mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
-mk_apps head_ty type_args = do
-  head_ty' <- returnLA head_ty
-  -- We must parenthesize the function type in case of an explicit
-  -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there
-  -- _must_ be parentheses around `Maybe :: Type -> Type`.
-  let phead_ty :: LHsType GhcPs
-      phead_ty = parenthesizeHsType sigPrec head_ty'
-
-      go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
-      go [] = pure head_ty'
-      go (arg:args) =
-        case arg of
-          HsValArg ty  -> do p_ty <- add_parens ty
-                             mk_apps (HsAppTy noExtField phead_ty p_ty) args
-          HsTypeArg l ki -> do p_ki <- add_parens ki
-                               mk_apps (HsAppKindTy l phead_ty p_ki) args
-          HsArgPar _   -> mk_apps (HsParTy noAnn phead_ty) args
-
-  go type_args
-   where
-    -- See Note [Adding parens for splices]
-    add_parens lt@(L _ t)
-      | hsTypeNeedsParens appPrec t = returnLA (HsParTy noAnn lt)
-      | otherwise                   = return lt
-
-wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs
-wrap_tyarg (HsValArg ty)    = HsValArg  $ parenthesizeHsType appPrec ty
-wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki
-wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized
-
--- ---------------------------------------------------------------------
-{-
-Note [Adding parens for splices]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The hsSyn representation of parsed source explicitly contains all the original
-parens, as written in the source.
-
-When a Template Haskell (TH) splice is evaluated, the original splice is first
-renamed and type checked and then finally converted to core in
-GHC.HsToCore.Quote. This core is then run in the TH engine, and the result
-comes back as a TH AST.
-
-In the process, all parens are stripped out, as they are not needed.
-
-This Convert module then converts the TH AST back to hsSyn AST.
-
-In order to pretty-print this hsSyn AST, parens need to be adde back at certain
-points so that the code is readable with its original meaning.
-
-So scattered through "GHC.ThToHs" are various points where parens are added.
-
-See (among other closed issues) https://gitlab.haskell.org/ghc/ghc/issues/14289
--}
--- ---------------------------------------------------------------------
-
-split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])
-split_ty_app ty = go ty []
-  where
-    go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') }
-    go (AppKindT ty ki) as' = do { ki' <- cvtKind ki
-                                 ; go ty (HsTypeArg noSrcSpan ki':as') }
-    go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') }
-    go f as           = return (f,as)
-
-cvtTyLit :: TH.TyLit -> HsTyLit (GhcPass p)
-cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i
-cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
-cvtTyLit (TH.CharTyLit c) = HsCharTy NoSourceText c
-
-{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator
-application @x `op` y@. The produced tree of infix types will be right-biased,
-provided @y@ is.
-
-See the @cvtOpApp@ documentation for how this function works.
--}
-cvtOpAppT :: PromotionFlag -> TH.Type -> LocatedN RdrName -> LHsType GhcPs -> CvtM (LHsType GhcPs)
-cvtOpAppT prom (UInfixT x op2 y) op1 z
-  = do { op2' <- tconNameN op2
-       ; l <- cvtOpAppT prom y op1 z
-       ; cvtOpAppT NotPromoted x op2' l }
-cvtOpAppT prom (PromotedUInfixT x op2 y) op1 z
-  = do { op2' <- cNameN op2
-       ; l <- cvtOpAppT prom y op1 z
-       ; cvtOpAppT IsPromoted x op2' l }
-cvtOpAppT prom x op y
-  = do { x' <- cvtType x
-       ; returnLA (mkHsOpTy prom x' op y) }
-
-cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
-cvtKind = cvtTypeKind KindLevel
-
-cvtSigKind :: TH.Kind -> CvtM (LHsSigType GhcPs)
-cvtSigKind = cvtSigTypeKind KindLevel
-
--- | Convert Maybe Kind to a type family result signature. Used with data
--- families where naming of the result is not possible (thus only kind or no
--- signature is possible).
-cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
-                              -> CvtM (LFamilyResultSig GhcPs)
-cvtMaybeKindToFamilyResultSig Nothing   = returnLA (Hs.NoSig noExtField)
-cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki
-                                             ; returnLA (Hs.KindSig noExtField ki') }
-
--- | Convert type family result signature. Used with both open and closed type
--- families.
-cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)
-cvtFamilyResultSig TH.NoSig           = returnLA (Hs.NoSig noExtField)
-cvtFamilyResultSig (TH.KindSig ki)    = do { ki' <- cvtKind ki
-                                           ; returnLA (Hs.KindSig noExtField  ki') }
-cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr
-                                           ; returnLA (Hs.TyVarSig noExtField tv) }
-
--- | Convert injectivity annotation of a type family.
-cvtInjectivityAnnotation :: TH.InjectivityAnn
-                         -> CvtM (Hs.LInjectivityAnn GhcPs)
-cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
-  = do { annLHS' <- tNameN annLHS
-       ; annRHS' <- mapM tNameN annRHS
-       ; returnLA (Hs.InjectivityAnn noAnn annLHS' annRHS') }
-
-cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs)
--- pattern synonym types are of peculiar shapes, which is why we treat
--- them separately from regular types;
--- see Note [Pattern synonym type signatures and Template Haskell]
-cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
-  | null exis, null provs = cvtSigType (ForallT univs reqs ty)
-  | null univs, null reqs = do { ty' <- cvtType (ForallT exis provs ty)
-                               ; ctxt' <- returnLA []
-                               ; cxtTy <- wrapParLA mkHsImplicitSigType $
-                                          HsQualTy { hst_ctxt = ctxt'
-                                                   , hst_xqual = noExtField
-                                                   , hst_body = ty' }
-                               ; returnLA cxtTy }
-  | null reqs             = do { univs' <- cvtTvs univs
-                               ; ty'    <- cvtType (ForallT exis provs ty)
-                               ; ctxt'  <- returnLA []
-                               ; let cxtTy = HsQualTy { hst_ctxt = ctxt'
-                                                      , hst_xqual = noExtField
-                                                      , hst_body = ty' }
-                               ; forTy <- wrapParLA (mkHsExplicitSigType noAnn univs') cxtTy
-                               ; returnLA forTy }
-  | otherwise             = cvtSigType (ForallT univs reqs (ForallT exis provs ty))
-cvtPatSynSigTy ty         = cvtSigType ty
-
------------------------------------------------------------
-cvtFixity :: TH.Fixity -> Hs.Fixity
-cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)
-   where
-     cvt_dir TH.InfixL = Hs.InfixL
-     cvt_dir TH.InfixR = Hs.InfixR
-     cvt_dir TH.InfixN = Hs.InfixN
-
------------------------------------------------------------
-
-
------------------------------------------------------------
--- some useful things
-
-overloadedLit :: Lit -> Bool
--- True for literals that Haskell treats as overloaded
-overloadedLit (IntegerL  _) = True
-overloadedLit (RationalL _) = True
-overloadedLit _             = False
-
--- Checks that are performed when converting unboxed sum expressions and
--- patterns alike.
-unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()
-unboxedSumChecks alt arity
-    | alt > arity
-    = failWith $ SumAltArityExceeded alt arity
-    | alt <= 0
-    = failWith $ IllegalSumAlt alt
-    | arity < 2
-    = failWith $ IllegalSumArity arity
-    | otherwise
-    = return ()
-
--- | If passed an empty list of 'LHsTyVarBndr's, this simply returns the
--- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'
--- using the provided 'LHsQTyVars' and 'LHsType'.
-mkHsForAllTy :: SrcSpanAnnA
-             -- ^ The location of the returned 'LHsType' if it needs an
-             --   explicit forall
-             -> HsForAllTelescope GhcPs
-             -- ^ The converted type variable binders
-             -> LHsType GhcPs
-             -- ^ The converted rho type
-             -> LHsType GhcPs
-             -- ^ The complete type, quantified with a forall if necessary
-mkHsForAllTy loc tele rho_ty
-  | no_tvs    = rho_ty
-  | otherwise = L loc $ HsForAllTy { hst_tele = tele
-                                   , hst_xforall = noExtField
-                                   , hst_body = rho_ty }
-  where
-    no_tvs = case tele of
-      HsForAllVis   { hsf_vis_bndrs   = bndrs } -> null bndrs
-      HsForAllInvis { hsf_invis_bndrs = bndrs } -> null bndrs
-
--- | If passed an empty 'TH.Cxt', this simply returns the third argument
--- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided
--- 'LHsContext' and 'LHsType'.
-
--- It's important that we don't build an HsQualTy if the context is empty,
--- as the pretty-printer for HsType _always_ prints contexts, even if
--- they're empty. See #13183.
-mkHsQualTy :: TH.Cxt
-           -- ^ The original Template Haskell context
-           -> SrcSpanAnnA
-           -- ^ The location of the returned 'LHsType' if it needs an
-           --   explicit context
-           -> LHsContext GhcPs
-           -- ^ The converted context
-           -> LHsType GhcPs
-           -- ^ The converted tau type
-           -> LHsType GhcPs
-           -- ^ The complete type, qualified with a context if necessary
-mkHsQualTy ctxt loc ctxt' ty
-  | null ctxt = ty
-  | otherwise = L loc $ HsQualTy { hst_xqual = noExtField
-                                 , hst_ctxt  = ctxt'
-                                 , hst_body  = ty }
-
--- | @'mkHsContextMaybe' lc@ returns 'Nothing' if @lc@ is empty and @'Just' lc@
--- otherwise.
---
--- This is much like 'mkHsQualTy', except that it returns a
--- @'Maybe' ('LHsContext' 'GhcPs')@. This is used specifically for constructing
--- superclasses, datatype contexts (#20011), and contexts in GADT constructor
--- types (#20590). We wish to avoid using @'Just' []@ in the case of an empty
--- contexts, as the pretty-printer always prints 'Just' contexts, even if
--- they're empty.
-mkHsContextMaybe :: LHsContext GhcPs -> Maybe (LHsContext GhcPs)
-mkHsContextMaybe lctxt@(L _ ctxt)
-  | null ctxt = Nothing
-  | otherwise = Just lctxt
-
-mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs
-mkHsOuterFamEqnTyVarBndrs = maybe mkHsOuterImplicit (mkHsOuterExplicit noAnn)
-
---------------------------------------------------------------------
---      Turning Name back into RdrName
---------------------------------------------------------------------
-
--- variable names
-vNameN, cNameN, vcNameN, tNameN, tconNameN :: TH.Name -> CvtM (LocatedN RdrName)
-vNameL                                     :: TH.Name -> CvtM (LocatedA RdrName)
-vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName
-
--- Variable names
-vNameN n = wrapLN (vName n)
-vNameL n = wrapLA (vName n)
-vName n = cvtName OccName.varName n
-
--- Constructor function names; this is Haskell source, hence srcDataName
-cNameN n = wrapLN (cName n)
-cName n = cvtName OccName.dataName n
-
--- Variable *or* constructor names; check by looking at the first char
-vcNameN n = wrapLN (vcName n)
-vcName n = if isVarName n then vName n else cName n
-
--- Type variable names
-tNameN n = wrapLN (tName n)
-tName n = cvtName OccName.tvName n
-
--- Type Constructor names
-tconNameN n = wrapLN (tconName n)
-tconName n = cvtName OccName.tcClsName n
-
-ipName :: String -> CvtM HsIPName
-ipName n
-  = do { unless (okVarOcc n) (failWith (IllegalOccName OccName.varName n))
-       ; return (HsIPName (fsLit n)) }
-
-cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
-cvtName ctxt_ns (TH.Name occ flavour)
-  | not (okOcc ctxt_ns occ_str) = failWith (IllegalOccName ctxt_ns occ_str)
-  | otherwise
-  = do { loc <- getL
-       ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour
-       ; force rdr_name
-       ; return rdr_name }
-  where
-    occ_str = TH.occString occ
-
-okOcc :: OccName.NameSpace -> String -> Bool
-okOcc ns str
-  | OccName.isVarNameSpace ns     = okVarOcc str
-  | OccName.isDataConNameSpace ns = okConOcc str
-  | otherwise                     = okTcOcc  str
-
--- Determine the name space of a name in a type
---
-isVarName :: TH.Name -> Bool
-isVarName (TH.Name occ _)
-  = case TH.occString occ of
-      ""    -> False
-      (c:_) -> startsVarId c || startsVarSym c
-
-thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
--- This turns a TH Name into a RdrName; used for both binders and occurrences
--- See Note [Binders in Template Haskell]
--- The passed-in name space tells what the context is expecting;
---      use it unless the TH name knows what name-space it comes
---      from, in which case use the latter
---
--- We pass in a SrcSpan (gotten from the monad) because this function
--- is used for *binders* and if we make an Exact Name we want it
--- to have a binding site inside it.  (cf #5434)
---
--- ToDo: we may generate silly RdrNames, by passing a name space
---       that doesn't match the string, like VarName ":+",
---       which will give confusing error messages later
---
--- The strict applications ensure that any buried exceptions get forced
-thRdrName loc ctxt_ns th_occ th_name
-  = case th_name of
-     TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod
-     TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ
-     TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc)
-     TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc)
-     TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name
-              | otherwise                           -> mkRdrUnqual $! occ
-              -- We check for built-in syntax here, because the TH
-              -- user might have written a (NameS "(,,)"), for example
-  where
-    occ :: OccName.OccName
-    occ = mk_occ ctxt_ns th_occ
-
--- Return an unqualified exact RdrName if we're dealing with built-in syntax.
--- See #13776.
-thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
-thOrigRdrName occ th_ns pkg mod =
-  let occ' = mk_occ (mk_ghc_ns th_ns) occ
-      mod' = mkModule (mk_pkg pkg) (mk_mod mod)
-  in case isBuiltInOcc_maybe occ' <|> isPunOcc_maybe mod' occ' of
-       Just name -> nameRdrName name
-       Nothing   -> (mkOrig $! mod') $! occ'
-
-thRdrNameGuesses :: TH.Name -> [RdrName]
-thRdrNameGuesses (TH.Name occ flavour)
-  -- This special case for NameG ensures that we don't generate duplicates in the output list
-  | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]
-  | otherwise                         = [ thRdrName noSrcSpan gns occ_str flavour
-                                        | gns <- guessed_nss]
-  where
-    -- guessed_ns are the name spaces guessed from looking at the TH name
-    guessed_nss
-      | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
-      | otherwise                       = [OccName.varName, OccName.tvName]
-    occ_str = TH.occString occ
-
--- The packing and unpacking is rather turgid :-(
-mk_occ :: OccName.NameSpace -> String -> OccName.OccName
-mk_occ ns occ = OccName.mkOccName ns occ
-
-mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
-mk_ghc_ns TH.DataName  = OccName.dataName
-mk_ghc_ns TH.TcClsName = OccName.tcClsName
-mk_ghc_ns TH.VarName   = OccName.varName
-
-mk_mod :: TH.ModName -> ModuleName
-mk_mod mod = mkModuleName (TH.modString mod)
-
-mk_pkg :: TH.PkgName -> Unit
-mk_pkg pkg = stringToUnit (TH.pkgString pkg)
-
-mk_uniq :: Int -> Unique
-mk_uniq u = mkUniqueGrimily u
-
-{-
-Note [Binders in Template Haskell]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this TH term construction:
-  do { x1 <- TH.newName "x"   -- newName :: String -> Q TH.Name
-     ; x2 <- TH.newName "x"   -- Builds a NameU
-     ; x3 <- TH.newName "x"
-
-     ; let x = mkName "x"     -- mkName :: String -> TH.Name
-                              -- Builds a NameS
-
-     ; return (LamE (..pattern [x1,x2]..) $
-               LamE (VarPat x3) $
-               ..tuple (x1,x2,x3,x)) }
-
-It represents the term   \[x1,x2]. \x3. (x1,x2,x3,x)
-
-a) We don't want to complain about "x" being bound twice in
-   the pattern [x1,x2]
-b) We don't want x3 to shadow the x1,x2
-c) We *do* want 'x' (dynamically bound with mkName) to bind
-   to the innermost binding of "x", namely x3.
-d) When pretty printing, we want to print a unique with x1,x2
-   etc, else they'll all print as "x" which isn't very helpful
-
-When we convert all this to HsSyn, the TH.Names are converted with
-thRdrName.  To achieve (b) we want the binders to be Exact RdrNames.
-Achieving (a) is a bit awkward, because
-   - We must check for duplicate and shadowed names on Names,
-     not RdrNames, *after* renaming.
-     See Note [Collect binders only after renaming] in GHC.Hs.Utils
-
-   - But to achieve (a) we must distinguish between the Exact
-     RdrNames arising from TH and the Unqual RdrNames that would
-     come from a user writing \[x,x] -> blah
-
-So in Convert.thRdrName we translate
-   TH Name                          RdrName
-   --------------------------------------------------------
-   NameU (arising from newName) --> Exact (Name{ System })
-   NameS (arising from mkName)  --> Unqual
-
-Notice that the NameUs generate *System* Names.  Then, when
-figuring out shadowing and duplicates, we can filter out
-System Names.
-
-This use of System Names fits with other uses of System Names, eg for
-temporary variables "a". Since there are lots of things called "a" we
-usually want to print the name with the unique, and that is indeed
-the way System Names are printed.
-
-There's a small complication of course; see Note [Looking up Exact
-RdrNames] in GHC.Rename.Env.
--}
-
-{-
-Note [Pattern synonym type signatures and Template Haskell]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-In general, the type signature of a pattern synonym
-
-  pattern P x1 x2 .. xn = <some-pattern>
-
-is of the form
-
-   forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
-
-with the following parts:
-
-   1) the (possibly empty lists of) universally quantified type
-      variables `univs` and required constraints `reqs` on them.
-   2) the (possibly empty lists of) existentially quantified type
-      variables `exis` and the provided constraints `provs` on them.
-   3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,
-      x2, .., xn, respectively
-   4) the type `t` of <some-pattern>, mentioning only universals from `univs`.
-
-Due to the two forall quantifiers and constraint contexts (either of
-which might be empty), pattern synonym type signatures are treated
-specially in `GHC.HsToCore.Quote`, `GHC.ThToHs`, and
-`GHC.Tc.Gen.Splice`:
-
-   (a) When desugaring a pattern synonym from HsSyn to TH.Dec in
-       `GHC.HsToCore.Quote`, we represent its *full* type signature in TH, i.e.:
-
-           ForallT univs reqs (ForallT exis provs ty)
-              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
-
-   (b) When converting pattern synonyms from TH.Dec to HsSyn in
-       `GHC.ThToHs`, we convert their TH type signatures back to an
-       appropriate Haskell pattern synonym type of the form
-
-         forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
-
-       where initial empty `univs` type variables or an empty `reqs`
-       constraint context are represented *explicitly* as `() =>`.
-
-   (c) When reifying a pattern synonym in `GHC.Tc.Gen.Splice`, we always
-       return its *full* type, i.e.:
-
-           ForallT univs reqs (ForallT exis provs ty)
-              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
-
-The key point is to always represent a pattern synonym's *full* type
-in cases (a) and (c) to make it clear which of the two forall
-quantifiers and/or constraint contexts are specified, and which are
-not. See GHC's user's guide on pattern synonyms for more information
-about pattern synonym type signatures.
-
--}
diff --git a/compiler/GHC/Types/Name/Shape.hs b/compiler/GHC/Types/Name/Shape.hs
deleted file mode 100644
--- a/compiler/GHC/Types/Name/Shape.hs
+++ /dev/null
@@ -1,275 +0,0 @@
-
-
-module GHC.Types.Name.Shape
-   ( NameShape(..)
-   , emptyNameShape
-   , mkNameShape
-   , extendNameShape
-   , nameShapeExports
-   , substNameShape
-   , maybeSubstNameShape
-   )
-where
-
-import GHC.Prelude
-
-import GHC.Driver.Env
-
-import GHC.Unit.Module
-
-import GHC.Types.Unique.FM
-import GHC.Types.Avail
-import GHC.Types.FieldLabel
-import GHC.Types.Name
-import GHC.Types.Name.Env
-
-import GHC.Tc.Utils.Monad
-import GHC.Iface.Env
-
-import GHC.Utils.Outputable
-import GHC.Utils.Panic.Plain
-
-import Control.Monad
-
--- Note [NameShape]
--- ~~~~~~~~~~~~~~~~
--- When we write a declaration in a signature, e.g., data T, we
--- ascribe to it a *name variable*, e.g., {m.T}.  This
--- name variable may be substituted with an actual original
--- name when the signature is implemented (or even if we
--- merge the signature with one which reexports this entity
--- from another module).
-
--- When we instantiate a signature m with a module M,
--- we also need to substitute over names.  To do so, we must
--- compute the *name substitution* induced by the *exports*
--- of the module in question.  A NameShape represents
--- such a name substitution for a single module instantiation.
--- The "shape" in the name comes from the fact that the computation
--- of a name substitution is essentially the *shaping pass* from
--- Backpack'14, but in a far more restricted form.
-
--- The name substitution for an export list is easy to explain.  If we are
--- filling the module variable <m>, given an export N of the form
--- M.n or {m'.n} (where n is an OccName), the induced name
--- substitution is from {m.n} to N.  So, for example, if we have
--- A=impl:B, and the exports of impl:B are impl:B.f and
--- impl:C.g, then our name substitution is {A.f} to impl:B.f
--- and {A.g} to impl:C.g
-
-
-
-
--- The 'NameShape' type is defined in GHC.Tc.Types, because GHC.Tc.Types
--- needs to refer to NameShape, and having GHC.Tc.Types import
--- NameShape (even by SOURCE) would cause a large number of
--- modules to be pulled into the DynFlags cycle.
-{-
-data NameShape = NameShape {
-        ns_mod_name :: ModuleName,
-        ns_exports :: [AvailInfo],
-        ns_map :: OccEnv Name
-    }
--}
-
--- NB: substitution functions need 'HscEnv' since they need the name cache
--- to allocate new names if we change the 'Module' of a 'Name'
-
--- | Create an empty 'NameShape' (i.e., the renaming that
--- would occur with an implementing module with no exports)
--- for a specific hole @mod_name@.
-emptyNameShape :: ModuleName -> NameShape
-emptyNameShape mod_name = NameShape mod_name [] emptyOccEnv
-
--- | Create a 'NameShape' corresponding to an implementing
--- module for the hole @mod_name@ that exports a list of 'AvailInfo's.
-mkNameShape :: ModuleName -> [AvailInfo] -> NameShape
-mkNameShape mod_name as =
-    NameShape mod_name as $ mkOccEnv $ do
-        a <- as
-        n <- availName a : availNamesWithSelectors a
-        return (occName n, n)
-
--- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's
--- with Backpack style mix-in linking.  This is used solely when merging
--- signatures together: we successively merge the exports of each
--- signature until we have the final, full exports of the merged signature.
---
--- What makes this operation nontrivial is what we are supposed to do when
--- we want to merge in an export for M.T when we already have an existing
--- export {H.T}.  What should happen in this case is that {H.T} should be
--- unified with @M.T@: we've determined a more *precise* identity for the
--- export at 'OccName' @T@.
---
--- Note that we don't do unrestricted unification: only name holes from
--- @ns_mod_name ns@ are flexible.  This is because we have a much more
--- restricted notion of shaping than in Backpack'14: we do shaping
--- *as* we do type-checking.  Thus, once we shape a signature, its
--- exports are *final* and we're not allowed to refine them further,
-extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape)
-extendNameShape hsc_env ns as =
-    case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of
-        Left err -> return (Left err)
-        Right nsubst -> do
-            as1 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) (ns_exports ns)
-            as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as
-            let new_avails = mergeAvails as1 as2
-            return . Right $ ns {
-                ns_exports = new_avails,
-                -- TODO: stop repeatedly rebuilding the OccEnv
-                ns_map = mkOccEnv $ do
-                            a <- new_avails
-                            n <- availName a : availNames a
-                            return (occName n, n)
-                }
-
--- | The export list associated with this 'NameShape' (i.e., what
--- the exports of an implementing module which induces this 'NameShape'
--- would be.)
-nameShapeExports :: NameShape -> [AvailInfo]
-nameShapeExports = ns_exports
-
--- | Given a 'Name', substitute it according to the 'NameShape' implied
--- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module
--- exports @M.T@.
-substNameShape :: NameShape -> Name -> Name
-substNameShape ns n | nameModule n == ns_module ns
-                    , Just n' <- lookupOccEnv (ns_map ns) (occName n)
-                    = n'
-                    | otherwise
-                    = n
-
--- | Like 'substNameShape', but returns @Nothing@ if no substitution
--- works.
-maybeSubstNameShape :: NameShape -> Name -> Maybe Name
-maybeSubstNameShape ns n
-    | nameModule n == ns_module ns
-    = lookupOccEnv (ns_map ns) (occName n)
-    | otherwise
-    = Nothing
-
--- | The 'Module' of any 'Name's a 'NameShape' has action over.
-ns_module :: NameShape -> Module
-ns_module = mkHoleModule . ns_mod_name
-
-{-
-************************************************************************
-*                                                                      *
-                        Name substitutions
-*                                                                      *
-************************************************************************
--}
-
--- | Substitution on @{A.T}@.  We enforce the invariant that the
--- 'nameModule' of keys of this map have 'moduleUnit' @hole@
--- (meaning that if we have a hole substitution, the keys of the map
--- are never affected.)  Alternatively, this is isomorphic to
--- @Map ('ModuleName', 'OccName') 'Name'@.
-type ShNameSubst = NameEnv Name
-
--- NB: In this module, we actually only ever construct 'ShNameSubst'
--- at a single 'ModuleName'.  But 'ShNameSubst' is more convenient to
--- work with.
-
--- | Substitute names in a 'Name'.
-substName :: ShNameSubst -> Name -> Name
-substName env n | Just n' <- lookupNameEnv env n = n'
-                | otherwise                      = n
-
--- | Substitute names in an 'AvailInfo'.  This has special behavior
--- for type constructors, where it is sufficient to substitute the 'availName'
--- to induce a substitution on 'availNames'.
-substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo
-substNameAvailInfo _ env (Avail (NormalGreName n)) = return (Avail (NormalGreName (substName env n)))
-substNameAvailInfo _ env (Avail (FieldGreName fl)) =
-    return (Avail (FieldGreName fl { flSelector = substName env (flSelector fl) }))
-substNameAvailInfo hsc_env env (AvailTC n ns) =
-    let mb_mod = fmap nameModule (lookupNameEnv env n)
-    in AvailTC (substName env n) <$> mapM (setNameGreName hsc_env mb_mod) ns
-
-setNameGreName :: HscEnv -> Maybe Module -> GreName -> IO GreName
-setNameGreName hsc_env mb_mod gname = case gname of
-    NormalGreName n -> NormalGreName <$> initIfaceLoad hsc_env (setNameModule mb_mod n)
-    FieldGreName fl -> FieldGreName  <$> setNameFieldSelector hsc_env mb_mod fl
-
--- | Set the 'Module' of a 'FieldSelector'
-setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel
-setNameFieldSelector _ Nothing f = return f
-setNameFieldSelector hsc_env mb_mod (FieldLabel l b has_sel sel) = do
-    sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel
-    return (FieldLabel l b has_sel sel')
-
-{-
-************************************************************************
-*                                                                      *
-                        AvailInfo merging
-*                                                                      *
-************************************************************************
--}
-
--- | Merges to 'AvailInfo' lists together, assuming the 'AvailInfo's have
--- already been unified ('uAvailInfos').
-mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo]
-mergeAvails as1 as2 =
-    let mkNE as = mkNameEnv [(availName a, a) | a <- as]
-    in nonDetNameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2))
-
-{-
-************************************************************************
-*                                                                      *
-                        AvailInfo unification
-*                                                                      *
-************************************************************************
--}
-
--- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@,
--- with only name holes from @flexi@ unifiable (all other name holes rigid.)
-uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst
-uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $
-    let mkOE as = listToUFM $ do a <- as
-                                 n <- availNames a
-                                 return (nameOccName n, a)
-    in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv
-             (nonDetEltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2)))
-             -- Edward: I have to say, this is pretty clever.
-
--- | Unify two 'AvailInfo's, given an existing substitution @subst@,
--- with only name holes from @flexi@ unifiable (all other name holes rigid.)
-uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo
-           -> Either SDoc ShNameSubst
-uAvailInfo flexi subst (Avail (NormalGreName n1)) (Avail (NormalGreName n2)) = uName flexi subst n1 n2
-uAvailInfo flexi subst (AvailTC n1 _) (AvailTC n2 _) = uName flexi subst n1 n2
-uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine"
-                           <+> ppr a1 <+> text "with" <+> ppr a2
-                           <+> parens (text "one is a type, the other is a plain identifier")
-
--- | Unify two 'Name's, given an existing substitution @subst@,
--- with only name holes from @flexi@ unifiable (all other name holes rigid.)
-uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst
-uName flexi subst n1 n2
-    | n1 == n2      = Right subst
-    | isFlexi n1    = uHoleName flexi subst n1 n2
-    | isFlexi n2    = uHoleName flexi subst n2 n1
-    | otherwise     = Left (text "While merging export lists, could not unify"
-                         <+> ppr n1 <+> text "with" <+> ppr n2 $$ extra)
-  where
-    isFlexi n = isHoleName n && moduleName (nameModule n) == flexi
-    extra | isHoleName n1 || isHoleName n2
-          = text "Neither name variable originates from the current signature."
-          | otherwise
-          = empty
-
--- | Unify a name @h@ which 'isHoleName' with another name, given an existing
--- substitution @subst@, with only name holes from @flexi@ unifiable (all
--- other name holes rigid.)
-uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name
-          -> Either SDoc ShNameSubst
-uHoleName flexi subst h n =
-    assert (isHoleName h) $
-    case lookupNameEnv subst h of
-        Just n' -> uName flexi subst n' n
-                -- Do a quick check if the other name is substituted.
-        Nothing | Just n' <- lookupNameEnv subst n ->
-                    assert (isHoleName n) $ uName flexi subst h n'
-                | otherwise ->
-                    Right (extendNameEnv subst h n)
diff --git a/compiler/GHC/Types/TyThing/Ppr.hs b/compiler/GHC/Types/TyThing/Ppr.hs
deleted file mode 100644
--- a/compiler/GHC/Types/TyThing/Ppr.hs
+++ /dev/null
@@ -1,196 +0,0 @@
------------------------------------------------------------------------------
---
--- Pretty-printing TyThings
---
--- (c) The GHC Team 2005
---
------------------------------------------------------------------------------
-
-
-module GHC.Types.TyThing.Ppr (
-        pprTyThing,
-        pprTyThingInContext,
-        pprTyThingLoc,
-        pprTyThingInContextLoc,
-        pprTyThingHdr,
-        pprFamInst
-  ) where
-
-import GHC.Prelude
-
-import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe )
-import GHC.Types.Name
-
-import GHC.Core.Type    ( ForAllTyFlag(..), mkTyVarBinders )
-import GHC.Core.Coercion.Axiom ( coAxiomTyCon )
-import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) )
-import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp )
-
-import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)
-  , showToHeader, pprIfaceDecl )
-import GHC.Iface.Make ( tyThingToIfaceDecl )
-
-import GHC.Utils.Outputable
-
-import Data.Maybe ( isJust )
-
--- -----------------------------------------------------------------------------
--- Pretty-printing entities that we get from the GHC API
-
-{- Note [Pretty printing via Iface syntax]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Our general plan for pretty-printing
-  - Types
-  - TyCons
-  - Classes
-  - Pattern synonyms
-  ...etc...
-
-is to convert them to Iface syntax, and pretty-print that. For example
-  - pprType converts a Type to an IfaceType, and pretty prints that.
-  - pprTyThing converts the TyThing to an IfaceDecl,
-    and pretty prints that.
-
-So Iface syntax plays a dual role:
-  - it's the internal version of an interface files
-  - it's used for pretty-printing
-
-Why do this?
-
-* A significant reason is that we need to be able
-  to pretty-print Iface syntax (to display Foo.hi), and it was a
-  pain to duplicate masses of pretty-printing goop, esp for
-  Type and IfaceType.
-
-* When pretty-printing (a type, say), we want to tidy (with
-  tidyType) to avoids having (forall a a. blah) where the two
-  a's have different uniques.
-
-  Alas, for type constructors, TyCon, tidying does not work well,
-  because a TyCon includes DataCons which include Types, which mention
-  TyCons. And tidying can't tidy a mutually recursive data structure
-  graph, only trees.
-
-* Interface files contains fast-strings, not uniques, so the very same
-  tidying must take place when we convert to IfaceDecl. E.g.
-  GHC.Iface.Make.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,
-  Class etc) to an IfaceDecl.
-
-  Bottom line: IfaceDecls are already 'tidy', so it's straightforward
-  to print them.
-
-* An alternative I once explored was to ensure that TyCons get type
-  variables with distinct print-names. That's ok for type variables
-  but less easy for kind variables. Processing data type declarations
-  is already so complicated that I don't think it's sensible to add
-  the extra requirement that it generates only "pretty" types and
-  kinds.
-
-Consequences:
-
-- Iface syntax (and IfaceType) must contain enough information to
-  print nicely.  Hence, for example, the IfaceAppArgs type, which
-  allows us to suppress invisible kind arguments in types
-  (see Note [Suppressing invisible arguments] in GHC.Iface.Type)
-
-- In a few places we have info that is used only for pretty-printing,
-  and is totally ignored when turning Iface syntax back into Core
-  (in GHC.IfaceToCore). For example, IfaceClosedSynFamilyTyCon
-  stores a [IfaceAxBranch] that is used only for pretty-printing.
-
-- See Note [Free tyvars in IfaceType] in GHC.Iface.Type
-
-See #7730, #8776 for details   -}
-
---------------------
--- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location.
-pprFamInst :: FamInst -> SDoc
---  * For data instances we go via pprTyThing of the representational TyCon,
---    because there is already much cleverness associated with printing
---    data type declarations that I don't want to duplicate
---  * For type instances we print directly here; there is no TyCon
---    to give to pprTyThing
---
--- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes
-
-pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc })
-  = pprTyThingInContextLoc (ATyCon rep_tc)
-
-pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom
-                    , fi_tvs = tvs, fi_tys = lhs_tys, fi_rhs = rhs })
-  = showWithLoc (pprDefinedAt (getName axiom)) $
-    hang (text "type instance"
-            <+> pprUserForAll (mkTyVarBinders Specified tvs)
-                -- See Note [Printing foralls in type family instances]
-                -- in GHC.Iface.Type
-            <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)
-       2 (equals <+> ppr rhs)
-
-----------------------------
--- | Pretty-prints a 'TyThing' with its defining location.
-pprTyThingLoc :: TyThing -> SDoc
-pprTyThingLoc tyThing
-  = showWithLoc (pprDefinedAt (getName tyThing))
-                (pprTyThing showToHeader tyThing)
-
--- | Pretty-prints the 'TyThing' header. For functions and data constructors
--- the function is equivalent to 'pprTyThing' but for type constructors
--- and classes it prints only the header part of the declaration.
-pprTyThingHdr :: TyThing -> SDoc
-pprTyThingHdr = pprTyThing showToHeader
-
--- | Pretty-prints a 'TyThing' in context: that is, if the entity
--- is a data constructor, record selector, or class method, then
--- the entity's parent declaration is pretty-printed with irrelevant
--- parts omitted.
-pprTyThingInContext :: ShowSub -> TyThing -> SDoc
-pprTyThingInContext show_sub thing
-  = go [] thing
-  where
-    go ss thing
-      = case tyThingParent_maybe thing of
-          Just parent ->
-            go (getOccName thing : ss) parent
-          Nothing ->
-            pprTyThing
-              (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) })
-              thing
-
--- | Like 'pprTyThingInContext', but adds the defining location.
-pprTyThingInContextLoc :: TyThing -> SDoc
-pprTyThingInContextLoc tyThing
-  = showWithLoc (pprDefinedAt (getName tyThing))
-                (pprTyThingInContext showToHeader tyThing)
-
--- | Pretty-prints a 'TyThing'.
-pprTyThing :: ShowSub -> TyThing -> SDoc
--- We pretty-print 'TyThing' via 'IfaceDecl'
--- See Note [Pretty printing via Iface syntax]
-pprTyThing ss ty_thing
-  = sdocOption sdocLinearTypes $ \show_linear_types ->
-      pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing)
-  where
-    ss' = case ss_how_much ss of
-      ShowHeader (AltPpr Nothing)  -> ss { ss_how_much = ShowHeader ppr' }
-      ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' }
-      _                   -> ss
-
-    ppr' = AltPpr $ ppr_bndr $ getName ty_thing
-
-    ppr_bndr :: Name -> Maybe (OccName -> SDoc)
-    ppr_bndr name
-      | isBuiltInSyntax name || isJust (namePun_maybe name)
-         = Nothing
-      | otherwise
-         = case nameModule_maybe name of
-             Just mod -> Just $ \occ -> getPprStyle $ \sty ->
-               pprModulePrefix sty mod occ <> ppr occ
-             Nothing  -> warnPprTrace True "pprTyThing" (ppr name) Nothing
-             -- Nothing is unexpected here; TyThings have External names
-
-showWithLoc :: SDoc -> SDoc -> SDoc
-showWithLoc loc doc
-    = hang doc 2 (char '\t' <> comment <+> loc)
-                -- The tab tries to make them line up a bit
-  where
-    comment = text "--"
diff --git a/compiler/GHC/Types/Unique/MemoFun.hs b/compiler/GHC/Types/Unique/MemoFun.hs
deleted file mode 100644
--- a/compiler/GHC/Types/Unique/MemoFun.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module GHC.Types.Unique.MemoFun (memoiseUniqueFun) where
-
-import GHC.Prelude
-import GHC.Types.Unique
-import GHC.Types.Unique.FM
-
-import Data.IORef
-import System.IO.Unsafe
-
-memoiseUniqueFun :: Uniquable k => (k -> a) -> k -> a
-memoiseUniqueFun fun = unsafePerformIO $ do
-  ref <- newIORef emptyUFM
-  return $ \k -> unsafePerformIO $ do
-    m <- readIORef ref
-    case lookupUFM m k of
-      Just a  -> return a
-      Nothing -> do
-        let !a  = fun k
-            !m' = addToUFM m k a
-        writeIORef ref m'
-        return a
diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs
deleted file mode 100644
--- a/compiler/GHC/Unit/Finder.hs
+++ /dev/null
@@ -1,762 +0,0 @@
-{-
-(c) The University of Glasgow, 2000-2006
-
--}
-
-
-{-# LANGUAGE FlexibleContexts #-}
-
--- | Module finder
-module GHC.Unit.Finder (
-    FindResult(..),
-    InstalledFindResult(..),
-    FinderOpts(..),
-    FinderCache,
-    initFinderCache,
-    flushFinderCaches,
-    findImportedModule,
-    findPluginModule,
-    findExactModule,
-    findHomeModule,
-    findExposedPackageModule,
-    mkHomeModLocation,
-    mkHomeModLocation2,
-    mkHiOnlyModLocation,
-    mkHiPath,
-    mkObjPath,
-    addModuleToFinder,
-    addHomeModuleToFinder,
-    uncacheModule,
-    mkStubPaths,
-
-    findObjectLinkableMaybe,
-    findObjectLinkable,
-
-    -- Hash cache
-    lookupFileCache
-  ) where
-
-import GHC.Prelude
-
-import GHC.Platform.Ways
-
-import GHC.Builtin.Names ( gHC_PRIM )
-
-import GHC.Unit.Env
-import GHC.Unit.Types
-import GHC.Unit.Module
-import GHC.Unit.Home
-import GHC.Unit.State
-import GHC.Unit.Finder.Types
-
-import GHC.Data.Maybe    ( expectJust )
-import qualified GHC.Data.ShortText as ST
-
-import GHC.Utils.Misc
-import GHC.Utils.Outputable as Outputable
-import GHC.Utils.Panic
-
-import GHC.Linker.Types
-import GHC.Types.PkgQual
-
-import GHC.Fingerprint
-import Data.IORef
-import System.Directory
-import System.FilePath
-import Control.Monad
-import Data.Time
-import qualified Data.Map as M
-import GHC.Driver.Env
-    ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
-import GHC.Driver.Config.Finder
-import qualified Data.Set as Set
-
-type FileExt = String   -- Filename extension
-type BaseName = String  -- Basename of file
-
--- -----------------------------------------------------------------------------
--- The Finder
-
--- The Finder provides a thin filesystem abstraction to the rest of
--- the compiler.  For a given module, it can tell you where the
--- source, interface, and object files for that module live.
-
--- It does *not* know which particular package a module lives in.  Use
--- Packages.lookupModuleInAllUnits for that.
-
--- -----------------------------------------------------------------------------
--- The finder's cache
-
-
-initFinderCache :: IO FinderCache
-initFinderCache = FinderCache <$> newIORef emptyInstalledModuleEnv
-                              <*> newIORef M.empty
-
--- remove all the home modules from the cache; package modules are
--- assumed to not move around during a session; also flush the file hash
--- cache
-flushFinderCaches :: FinderCache -> UnitEnv -> IO ()
-flushFinderCaches (FinderCache ref file_ref) ue = do
-  atomicModifyIORef' ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
-  atomicModifyIORef' file_ref $ \_ -> (M.empty, ())
- where
-  is_ext mod _ = not (isUnitEnvInstalledModule ue mod)
-
-addToFinderCache :: FinderCache -> InstalledModule -> InstalledFindResult -> IO ()
-addToFinderCache (FinderCache ref _) key val =
-  atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())
-
-removeFromFinderCache :: FinderCache -> InstalledModule -> IO ()
-removeFromFinderCache (FinderCache ref _) key =
-  atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())
-
-lookupFinderCache :: FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)
-lookupFinderCache (FinderCache ref _) key = do
-   c <- readIORef ref
-   return $! lookupInstalledModuleEnv c key
-
-lookupFileCache :: FinderCache -> FilePath -> IO Fingerprint
-lookupFileCache (FinderCache _ ref) key = do
-   c <- readIORef ref
-   case M.lookup key c of
-     Nothing -> do
-       hash <- getFileHash key
-       atomicModifyIORef' ref $ \c -> (M.insert key hash c, ())
-       return hash
-     Just fp -> return fp
-
--- -----------------------------------------------------------------------------
--- The three external entry points
-
-
--- | Locate a module that was imported by the user.  We have the
--- module's name, and possibly a package name.  Without a package
--- name, this function will use the search path and the known exposed
--- packages to find the module, if a package is specified then only
--- that package is searched for the module.
-
-findImportedModule :: HscEnv -> ModuleName -> PkgQual -> IO FindResult
-findImportedModule hsc_env mod fs =
-  let fc        = hsc_FC hsc_env
-      mhome_unit = hsc_home_unit_maybe hsc_env
-      dflags    = hsc_dflags hsc_env
-      fopts     = initFinderOpts dflags
-  in do
-    findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod fs
-
-findImportedModuleNoHsc
-  :: FinderCache
-  -> FinderOpts
-  -> UnitEnv
-  -> Maybe HomeUnit
-  -> ModuleName
-  -> PkgQual
-  -> IO FindResult
-findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
-  case mb_pkg of
-    NoPkgQual  -> unqual_import
-    ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
-                | Just os <- lookup uid other_fopts -> home_pkg_import (uid, os)
-                | otherwise -> pprPanic "findImportModule" (ppr mod_name $$ ppr mb_pkg $$ ppr (homeUnitId <$> mhome_unit) $$ ppr uid $$ ppr (map fst all_opts))
-    OtherPkg _ -> pkg_import
-  where
-    all_opts = case mhome_unit of
-                Nothing -> other_fopts
-                Just home_unit -> (homeUnitId home_unit, fopts) : other_fopts
-
-
-    home_import = case mhome_unit of
-                   Just home_unit -> findHomeModule fc fopts home_unit mod_name
-                   Nothing -> pure $ NoPackage (panic "findImportedModule: no home-unit")
-
-
-    home_pkg_import (uid, opts)
-      -- If the module is reexported, then look for it as if it was from the perspective
-      -- of that package which reexports it.
-      | mod_name `Set.member` finder_reexportedModules opts =
-        findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
-      | mod_name `Set.member` finder_hiddenModules opts =
-        return (mkHomeHidden uid)
-      | otherwise =
-        findHomePackageModule fc opts uid mod_name
-
-    any_home_import = foldr orIfNotFound home_import (map home_pkg_import other_fopts)
-
-    pkg_import    = findExposedPackageModule fc fopts units  mod_name mb_pkg
-
-    unqual_import = any_home_import
-                    `orIfNotFound`
-                    findExposedPackageModule fc fopts units mod_name NoPkgQual
-
-    units     = case mhome_unit of
-                  Nothing -> ue_units ue
-                  Just home_unit -> homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue
-    hpt_deps :: [UnitId]
-    hpt_deps  = homeUnitDepends units
-    other_fopts  = map (\uid -> (uid, initFinderOpts (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps
-
--- | Locate a plugin module requested by the user, for a compiler
--- plugin.  This consults the same set of exposed packages as
--- 'findImportedModule', unless @-hide-all-plugin-packages@ or
--- @-plugin-package@ are specified.
-findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult
-findPluginModule fc fopts units (Just home_unit) mod_name =
-  findHomeModule fc fopts home_unit mod_name
-  `orIfNotFound`
-  findExposedPluginPackageModule fc fopts units mod_name
-findPluginModule fc fopts units Nothing mod_name =
-  findExposedPluginPackageModule fc fopts units mod_name
-
--- | Locate a specific 'Module'.  The purpose of this function is to
--- create a 'ModLocation' for a given 'Module', that is to find out
--- where the files associated with this module live.  It is used when
--- reading the interface for a module mentioned by another interface,
--- for example (a "system import").
-
-findExactModule :: FinderCache -> FinderOpts ->  UnitEnvGraph FinderOpts -> UnitState -> Maybe HomeUnit -> InstalledModule -> IO InstalledFindResult
-findExactModule fc fopts other_fopts unit_state mhome_unit mod = do
-  case mhome_unit of
-    Just home_unit
-     | isHomeInstalledModule home_unit mod
-        -> findInstalledHomeModule fc fopts (homeUnitId home_unit) (moduleName mod)
-     | Just home_fopts <- unitEnv_lookup_maybe (moduleUnit mod) other_fopts
-        -> findInstalledHomeModule fc home_fopts (moduleUnit mod) (moduleName mod)
-    _ -> findPackageModule fc unit_state fopts mod
-
--- -----------------------------------------------------------------------------
--- Helpers
-
--- | Given a monadic actions @this@ and @or_this@, first execute
--- @this@.  If the returned 'FindResult' is successful, return
--- it; otherwise, execute @or_this@.  If both failed, this function
--- also combines their failure messages in a reasonable way.
-orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult
-orIfNotFound this or_this = do
-  res <- this
-  case res of
-    NotFound { fr_paths = paths1, fr_mods_hidden = mh1
-             , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 }
-     -> do res2 <- or_this
-           case res2 of
-             NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2
-                      , fr_pkgs_hidden = ph2, fr_unusables = u2
-                      , fr_suggestions = s2 }
-              -> return (NotFound { fr_paths = paths1 ++ paths2
-                                  , fr_pkg = mb_pkg2 -- snd arg is the package search
-                                  , fr_mods_hidden = mh1 ++ mh2
-                                  , fr_pkgs_hidden = ph1 ++ ph2
-                                  , fr_unusables = u1 ++ u2
-                                  , fr_suggestions = s1  ++ s2 })
-             _other -> return res2
-    _other -> return res
-
--- | Helper function for 'findHomeModule': this function wraps an IO action
--- which would look up @mod_name@ in the file system (the home package),
--- and first consults the 'hsc_FC' cache to see if the lookup has already
--- been done.  Otherwise, do the lookup (with the IO action) and save
--- the result in the finder cache and the module location cache (if it
--- was successful.)
-homeSearchCache :: FinderCache -> UnitId -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
-homeSearchCache fc home_unit mod_name do_this = do
-  let mod = mkModule home_unit mod_name
-  modLocationCache fc mod do_this
-
-findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
-findExposedPackageModule fc fopts units mod_name mb_pkg =
-  findLookupResult fc fopts
-    $ lookupModuleWithSuggestions units mod_name mb_pkg
-
-findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
-findExposedPluginPackageModule fc fopts units mod_name =
-  findLookupResult fc fopts
-    $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual
-
-findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult
-findLookupResult fc fopts r = case r of
-     LookupFound m pkg_conf -> do
-       let im = fst (getModuleInstantiation m)
-       r' <- findPackageModule_ fc fopts im (fst pkg_conf)
-       case r' of
-        -- TODO: ghc -M is unlikely to do the right thing
-        -- with just the location of the thing that was
-        -- instantiated; you probably also need all of the
-        -- implicit locations from the instances
-        InstalledFound loc   _ -> return (Found loc m)
-        InstalledNoPackage   _ -> return (NoPackage (moduleUnit m))
-        InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m)
-                                         , fr_pkgs_hidden = []
-                                         , fr_mods_hidden = []
-                                         , fr_unusables = []
-                                         , fr_suggestions = []})
-     LookupMultiple rs ->
-       return (FoundMultiple rs)
-     LookupHidden pkg_hiddens mod_hiddens ->
-       return (NotFound{ fr_paths = [], fr_pkg = Nothing
-                       , fr_pkgs_hidden = map (moduleUnit.fst) pkg_hiddens
-                       , fr_mods_hidden = map (moduleUnit.fst) mod_hiddens
-                       , fr_unusables = []
-                       , fr_suggestions = [] })
-     LookupUnusable unusable ->
-       let unusables' = map get_unusable unusable
-           get_unusable (m, ModUnusable r) = (moduleUnit m, r)
-           get_unusable (_, r)             =
-             pprPanic "findLookupResult: unexpected origin" (ppr r)
-       in return (NotFound{ fr_paths = [], fr_pkg = Nothing
-                          , fr_pkgs_hidden = []
-                          , fr_mods_hidden = []
-                          , fr_unusables = unusables'
-                          , fr_suggestions = [] })
-     LookupNotFound suggest -> do
-       let suggest'
-             | finder_enableSuggestions fopts = suggest
-             | otherwise = []
-       return (NotFound{ fr_paths = [], fr_pkg = Nothing
-                       , fr_pkgs_hidden = []
-                       , fr_mods_hidden = []
-                       , fr_unusables = []
-                       , fr_suggestions = suggest' })
-
-modLocationCache :: FinderCache -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
-modLocationCache fc mod do_this = do
-  m <- lookupFinderCache fc mod
-  case m of
-    Just result -> return result
-    Nothing     -> do
-        result <- do_this
-        addToFinderCache fc mod result
-        return result
-
-addModuleToFinder :: FinderCache -> Module -> ModLocation -> IO ()
-addModuleToFinder fc mod loc = do
-  let imod = toUnitId <$> mod
-  addToFinderCache fc imod (InstalledFound loc imod)
-
--- This returns a module because it's more convenient for users
-addHomeModuleToFinder :: FinderCache -> HomeUnit -> ModuleName -> ModLocation -> IO Module
-addHomeModuleToFinder fc home_unit mod_name loc = do
-  let mod = mkHomeInstalledModule home_unit mod_name
-  addToFinderCache fc mod (InstalledFound loc mod)
-  return (mkHomeModule home_unit mod_name)
-
-uncacheModule :: FinderCache -> HomeUnit -> ModuleName -> IO ()
-uncacheModule fc home_unit mod_name = do
-  let mod = mkHomeInstalledModule home_unit mod_name
-  removeFromFinderCache fc mod
-
--- -----------------------------------------------------------------------------
---      The internal workers
-
-findHomeModule :: FinderCache -> FinderOpts -> HomeUnit -> ModuleName -> IO FindResult
-findHomeModule fc fopts  home_unit mod_name = do
-  let uid       = homeUnitAsUnit home_unit
-  r <- findInstalledHomeModule fc fopts (homeUnitId home_unit) mod_name
-  return $ case r of
-    InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)
-    InstalledNoPackage _ -> NoPackage uid -- impossible
-    InstalledNotFound fps _ -> NotFound {
-        fr_paths = fps,
-        fr_pkg = Just uid,
-        fr_mods_hidden = [],
-        fr_pkgs_hidden = [],
-        fr_unusables = [],
-        fr_suggestions = []
-      }
-
-mkHomeHidden :: UnitId -> FindResult
-mkHomeHidden uid =
-  NotFound { fr_paths = []
-           , fr_pkg = Just (RealUnit (Definite uid))
-           , fr_mods_hidden = [RealUnit (Definite uid)]
-           , fr_pkgs_hidden = []
-           , fr_unusables = []
-           , fr_suggestions = []}
-
-findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO FindResult
-findHomePackageModule fc fopts  home_unit mod_name = do
-  let uid       = RealUnit (Definite home_unit)
-  r <- findInstalledHomeModule fc fopts home_unit mod_name
-  return $ case r of
-    InstalledFound loc _ -> Found loc (mkModule uid mod_name)
-    InstalledNoPackage _ -> NoPackage uid -- impossible
-    InstalledNotFound fps _ -> NotFound {
-        fr_paths = fps,
-        fr_pkg = Just uid,
-        fr_mods_hidden = [],
-        fr_pkgs_hidden = [],
-        fr_unusables = [],
-        fr_suggestions = []
-      }
-
-
--- | Implements the search for a module name in the home package only.  Calling
--- this function directly is usually *not* what you want; currently, it's used
--- as a building block for the following operations:
---
---  1. When you do a normal package lookup, we first check if the module
---  is available in the home module, before looking it up in the package
---  database.
---
---  2. When you have a package qualified import with package name "this",
---  we shortcut to the home module.
---
---  3. When we look up an exact 'Module', if the unit id associated with
---  the module is the current home module do a look up in the home module.
---
---  4. Some special-case code in GHCi (ToDo: Figure out why that needs to
---  call this.)
-findInstalledHomeModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO InstalledFindResult
-findInstalledHomeModule fc fopts home_unit mod_name = do
-  homeSearchCache fc home_unit mod_name $
-   let
-     maybe_working_dir = finder_workingDirectory fopts
-     home_path = case maybe_working_dir of
-                  Nothing -> finder_importPaths fopts
-                  Just fp -> augmentImports fp (finder_importPaths fopts)
-     hi_dir_path =
-      case finder_hiDir fopts of
-        Just hiDir -> case maybe_working_dir of
-                        Nothing -> [hiDir]
-                        Just fp -> [fp </> hiDir]
-        Nothing -> home_path
-     hisuf = finder_hiSuf fopts
-     mod = mkModule home_unit mod_name
-
-     source_exts =
-      [ ("hs",    mkHomeModLocationSearched fopts mod_name "hs")
-      , ("lhs",   mkHomeModLocationSearched fopts mod_name "lhs")
-      , ("hsig",  mkHomeModLocationSearched fopts mod_name "hsig")
-      , ("lhsig", mkHomeModLocationSearched fopts mod_name "lhsig")
-      ]
-
-     -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that
-     -- when hiDir field is set in dflags, we know to look there (see #16500)
-     hi_exts = [ (hisuf,                mkHomeModHiOnlyLocation fopts mod_name)
-               , (addBootSuffix hisuf,  mkHomeModHiOnlyLocation fopts mod_name)
-               ]
-
-        -- In compilation manager modes, we look for source files in the home
-        -- package because we can compile these automatically.  In one-shot
-        -- compilation mode we look for .hi and .hi-boot files only.
-     (search_dirs, exts)
-          | finder_lookupHomeInterfaces fopts = (hi_dir_path, hi_exts)
-          | otherwise                         = (home_path, source_exts)
-   in
-
-   -- special case for GHC.Prim; we won't find it in the filesystem.
-   -- This is important only when compiling the base package (where GHC.Prim
-   -- is a home module).
-   if mod `installedModuleEq` gHC_PRIM
-         then return (InstalledFound (error "GHC.Prim ModLocation") mod)
-         else searchPathExts search_dirs mod exts
-
--- | Prepend the working directory to the search path.
-augmentImports :: FilePath -> [FilePath] -> [FilePath]
-augmentImports _work_dir [] = []
-augmentImports work_dir (fp:fps) | isAbsolute fp = fp : augmentImports work_dir fps
-                                 | otherwise     = (work_dir </> fp) : augmentImports work_dir fps
-
--- | Search for a module in external packages only.
-findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> IO InstalledFindResult
-findPackageModule fc unit_state fopts mod = do
-  let pkg_id = moduleUnit mod
-  case lookupUnitId unit_state pkg_id of
-     Nothing -> return (InstalledNoPackage pkg_id)
-     Just u  -> findPackageModule_ fc fopts mod u
-
--- | Look up the interface file associated with module @mod@.  This function
--- requires a few invariants to be upheld: (1) the 'Module' in question must
--- be the module identifier of the *original* implementation of a module,
--- not a reexport (this invariant is upheld by "GHC.Unit.State") and (2)
--- the 'UnitInfo' must be consistent with the unit id in the 'Module'.
--- The redundancy is to avoid an extra lookup in the package state
--- for the appropriate config.
-findPackageModule_ :: FinderCache -> FinderOpts -> InstalledModule -> UnitInfo -> IO InstalledFindResult
-findPackageModule_ fc fopts mod pkg_conf = do
-  massertPpr (moduleUnit mod == unitId pkg_conf)
-             (ppr (moduleUnit mod) <+> ppr (unitId pkg_conf))
-  modLocationCache fc mod $
-
-    -- special case for GHC.Prim; we won't find it in the filesystem.
-    if mod `installedModuleEq` gHC_PRIM
-          then return (InstalledFound (error "GHC.Prim ModLocation") mod)
-          else
-
-    let
-       tag = waysBuildTag (finder_ways fopts)
-
-             -- hi-suffix for packages depends on the build tag.
-       package_hisuf | null tag  = "hi"
-                     | otherwise = tag ++ "_hi"
-
-       package_dynhisuf = waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi"
-
-       mk_hi_loc = mkHiOnlyModLocation fopts package_hisuf package_dynhisuf
-
-       import_dirs = map ST.unpack $ unitImportDirs pkg_conf
-        -- we never look for a .hi-boot file in an external package;
-        -- .hi-boot files only make sense for the home package.
-    in
-    case import_dirs of
-      [one] | finder_bypassHiFileCheck fopts ->
-            -- there's only one place that this .hi file can be, so
-            -- don't bother looking for it.
-            let basename = moduleNameSlashes (moduleName mod)
-                loc = mk_hi_loc one basename
-            in return $ InstalledFound loc mod
-      _otherwise ->
-            searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]
-
--- -----------------------------------------------------------------------------
--- General path searching
-
-searchPathExts :: [FilePath]      -- paths to search
-               -> InstalledModule -- module name
-               -> [ (
-                     FileExt,                             -- suffix
-                     FilePath -> BaseName -> ModLocation  -- action
-                    )
-                  ]
-               -> IO InstalledFindResult
-
-searchPathExts paths mod exts = search to_search
-  where
-    basename = moduleNameSlashes (moduleName mod)
-
-    to_search :: [(FilePath, ModLocation)]
-    to_search = [ (file, fn path basename)
-                | path <- paths,
-                  (ext,fn) <- exts,
-                  let base | path == "." = basename
-                           | otherwise   = path </> basename
-                      file = base <.> ext
-                ]
-
-    search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod)))
-
-    search ((file, loc) : rest) = do
-      b <- doesFileExist file
-      if b
-        then return $ InstalledFound loc mod
-        else search rest
-
-mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt
-                          -> FilePath -> BaseName -> ModLocation
-mkHomeModLocationSearched fopts mod suff path basename =
-  mkHomeModLocation2 fopts mod (path </> basename) suff
-
-
--- -----------------------------------------------------------------------------
--- Constructing a home module location
-
--- This is where we construct the ModLocation for a module in the home
--- package, for which we have a source file.  It is called from three
--- places:
---
---  (a) Here in the finder, when we are searching for a module to import,
---      using the search path (-i option).
---
---  (b) The compilation manager, when constructing the ModLocation for
---      a "root" module (a source file named explicitly on the command line
---      or in a :load command in GHCi).
---
---  (c) The driver in one-shot mode, when we need to construct a
---      ModLocation for a source file named on the command-line.
---
--- Parameters are:
---
--- mod
---      The name of the module
---
--- path
---      (a): The search path component where the source file was found.
---      (b) and (c): "."
---
--- src_basename
---      (a): (moduleNameSlashes mod)
---      (b) and (c): The filename of the source file, minus its extension
---
--- ext
---      The filename extension of the source file (usually "hs" or "lhs").
-
-mkHomeModLocation :: FinderOpts -> ModuleName -> FilePath -> ModLocation
-mkHomeModLocation dflags mod src_filename =
-   let (basename,extension) = splitExtension src_filename
-   in mkHomeModLocation2 dflags mod basename extension
-
-mkHomeModLocation2 :: FinderOpts
-                   -> ModuleName
-                   -> FilePath  -- Of source module, without suffix
-                   -> String    -- Suffix
-                   -> ModLocation
-mkHomeModLocation2 fopts mod src_basename ext =
-   let mod_basename = moduleNameSlashes mod
-
-       obj_fn = mkObjPath  fopts src_basename mod_basename
-       dyn_obj_fn = mkDynObjPath  fopts src_basename mod_basename
-       hi_fn  = mkHiPath   fopts src_basename mod_basename
-       dyn_hi_fn  = mkDynHiPath   fopts src_basename mod_basename
-       hie_fn = mkHiePath  fopts src_basename mod_basename
-
-   in (ModLocation{ ml_hs_file   = Just (src_basename <.> ext),
-                        ml_hi_file   = hi_fn,
-                        ml_dyn_hi_file = dyn_hi_fn,
-                        ml_obj_file  = obj_fn,
-                        ml_dyn_obj_file = dyn_obj_fn,
-                        ml_hie_file  = hie_fn })
-
-mkHomeModHiOnlyLocation :: FinderOpts
-                        -> ModuleName
-                        -> FilePath
-                        -> BaseName
-                        -> ModLocation
-mkHomeModHiOnlyLocation fopts mod path basename =
-   let loc = mkHomeModLocation2 fopts mod (path </> basename) ""
-   in loc { ml_hs_file = Nothing }
-
--- This function is used to make a ModLocation for a package module. Hence why
--- we explicitly pass in the interface file suffixes.
-mkHiOnlyModLocation :: FinderOpts -> Suffix -> Suffix -> FilePath -> String
-                    -> ModLocation
-mkHiOnlyModLocation fopts hisuf dynhisuf path basename
- = let full_basename = path </> basename
-       obj_fn = mkObjPath fopts full_basename basename
-       dyn_obj_fn = mkDynObjPath fopts full_basename basename
-       hie_fn = mkHiePath fopts full_basename basename
-   in ModLocation{    ml_hs_file   = Nothing,
-                             ml_hi_file   = full_basename <.> hisuf,
-                                -- Remove the .hi-boot suffix from
-                                -- hi_file, if it had one.  We always
-                                -- want the name of the real .hi file
-                                -- in the ml_hi_file field.
-                             ml_dyn_obj_file = dyn_obj_fn,
-                             -- MP: TODO
-                             ml_dyn_hi_file  = full_basename <.> dynhisuf,
-                             ml_obj_file  = obj_fn,
-                             ml_hie_file  = hie_fn
-                  }
-
--- | Constructs the filename of a .o file for a given source file.
--- Does /not/ check whether the .o file exists
-mkObjPath
-  :: FinderOpts
-  -> FilePath           -- the filename of the source file, minus the extension
-  -> String             -- the module name with dots replaced by slashes
-  -> FilePath
-mkObjPath fopts basename mod_basename = obj_basename <.> osuf
-  where
-                odir = finder_objectDir fopts
-                osuf = finder_objectSuf fopts
-
-                obj_basename | Just dir <- odir = dir </> mod_basename
-                             | otherwise        = basename
-
--- | Constructs the filename of a .dyn_o file for a given source file.
--- Does /not/ check whether the .dyn_o file exists
-mkDynObjPath
-  :: FinderOpts
-  -> FilePath           -- the filename of the source file, minus the extension
-  -> String             -- the module name with dots replaced by slashes
-  -> FilePath
-mkDynObjPath fopts basename mod_basename = obj_basename <.> dynosuf
-  where
-                odir = finder_objectDir fopts
-                dynosuf = finder_dynObjectSuf fopts
-
-                obj_basename | Just dir <- odir = dir </> mod_basename
-                             | otherwise        = basename
-
-
--- | Constructs the filename of a .hi file for a given source file.
--- Does /not/ check whether the .hi file exists
-mkHiPath
-  :: FinderOpts
-  -> FilePath           -- the filename of the source file, minus the extension
-  -> String             -- the module name with dots replaced by slashes
-  -> FilePath
-mkHiPath fopts basename mod_basename = hi_basename <.> hisuf
- where
-                hidir = finder_hiDir fopts
-                hisuf = finder_hiSuf fopts
-
-                hi_basename | Just dir <- hidir = dir </> mod_basename
-                            | otherwise         = basename
-
--- | Constructs the filename of a .dyn_hi file for a given source file.
--- Does /not/ check whether the .dyn_hi file exists
-mkDynHiPath
-  :: FinderOpts
-  -> FilePath           -- the filename of the source file, minus the extension
-  -> String             -- the module name with dots replaced by slashes
-  -> FilePath
-mkDynHiPath fopts basename mod_basename = hi_basename <.> dynhisuf
- where
-                hidir = finder_hiDir fopts
-                dynhisuf = finder_dynHiSuf fopts
-
-                hi_basename | Just dir <- hidir = dir </> mod_basename
-                            | otherwise         = basename
-
--- | Constructs the filename of a .hie file for a given source file.
--- Does /not/ check whether the .hie file exists
-mkHiePath
-  :: FinderOpts
-  -> FilePath           -- the filename of the source file, minus the extension
-  -> String             -- the module name with dots replaced by slashes
-  -> FilePath
-mkHiePath fopts basename mod_basename = hie_basename <.> hiesuf
- where
-                hiedir = finder_hieDir fopts
-                hiesuf = finder_hieSuf fopts
-
-                hie_basename | Just dir <- hiedir = dir </> mod_basename
-                             | otherwise          = basename
-
-
-
--- -----------------------------------------------------------------------------
--- Filenames of the stub files
-
--- We don't have to store these in ModLocations, because they can be derived
--- from other available information, and they're only rarely needed.
-
-mkStubPaths
-  :: FinderOpts
-  -> ModuleName
-  -> ModLocation
-  -> FilePath
-
-mkStubPaths fopts mod location
-  = let
-        stubdir = finder_stubDir fopts
-
-        mod_basename = moduleNameSlashes mod
-        src_basename = dropExtension $ expectJust "mkStubPaths"
-                                                  (ml_hs_file location)
-
-        stub_basename0
-            | Just dir <- stubdir = dir </> mod_basename
-            | otherwise           = src_basename
-
-        stub_basename = stub_basename0 ++ "_stub"
-     in
-        stub_basename <.> "h"
-
--- -----------------------------------------------------------------------------
--- findLinkable isn't related to the other stuff in here,
--- but there's no other obvious place for it
-
-findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)
-findObjectLinkableMaybe mod locn
-   = do let obj_fn = ml_obj_file locn
-        maybe_obj_time <- modificationTimeIfExists obj_fn
-        case maybe_obj_time of
-          Nothing -> return Nothing
-          Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time)
-
--- Make an object linkable when we know the object file exists, and we know
--- its modification time.
-findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable
-findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])
-  -- We used to look for _stub.o files here, but that was a bug (#706)
-  -- Now GHC merges the stub.o into the main .o (#3687)
-
diff --git a/compiler/GHC/Utils/Asm.hs b/compiler/GHC/Utils/Asm.hs
deleted file mode 100644
--- a/compiler/GHC/Utils/Asm.hs
+++ /dev/null
@@ -1,22 +0,0 @@
--- | Various utilities used in generating assembler.
---
--- These are used not only by the native code generator, but also by the
--- "GHC.Driver.Pipeline"
-module GHC.Utils.Asm
-    ( sectionType
-    ) where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Utils.Outputable
-
--- | Generate a section type (e.g. @\@progbits@). See #13937.
-sectionType :: IsLine doc
-            => Platform -- ^ Target platform
-            -> String   -- ^ section type
-            -> doc      -- ^ pretty assembler fragment
-sectionType platform ty =
-    case platformArch platform of
-      ArchARM{} -> char '%' <> text ty
-      _         -> char '@' <> text ty
diff --git a/compiler/GHC/Wasm/ControlFlow.hs b/compiler/GHC/Wasm/ControlFlow.hs
deleted file mode 100644
--- a/compiler/GHC/Wasm/ControlFlow.hs
+++ /dev/null
@@ -1,53 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE DataKinds, GADTs, RankNTypes, TypeOperators, KindSignatures #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PatternSynonyms #-}
-
-module GHC.Wasm.ControlFlow
-  ( WasmControl(..), (<>), pattern WasmIf, wasmReturn
-  , BrTableInterval(..), inclusiveInterval
-
-  , WasmType, WasmTypeTag(..)
-  , TypeList(..)
-  , WasmFunctionType(..)
-  )
-where
-
-import GHC.Prelude
-
-import GHC.CmmToAsm.Wasm.Types
-import GHC.Utils.Panic
-
-{-|
-Module      : GHC.Wasm.ControlFlow
-Description : Representation of control-flow portion of the WebAssembly instruction set
--}
-
-inclusiveInterval :: Integer -> Integer -> BrTableInterval
-inclusiveInterval lo hi
-    | lo <= hi = let count = hi - lo + 1
-                 in  BrTableInterval lo count
-    | otherwise = panic "GHC.Wasm.ControlFlow: empty interval"
-
-(<>) :: forall s e pre mid post
-      . WasmControl s e pre mid
-     -> WasmControl s e mid post
-     -> WasmControl s e pre post
-(<>) = WasmSeq
--- N.B. Fallthrough can't be optimized away because of type checking.
-
-
-
--- Syntactic sugar.
-pattern WasmIf :: WasmFunctionType pre post
-               -> e
-               -> WasmControl s e pre post
-               -> WasmControl s e pre post
-               -> WasmControl s e pre post
-
-pattern WasmIf ty e t f =
-    WasmPush TagI32 e `WasmSeq` WasmIfTop ty t f
-
--- More syntactic sugar.
-wasmReturn :: WasmTypeTag t -> e -> WasmControl s e (t ': t1star) t2star
-wasmReturn tag e = WasmPush tag e `WasmSeq` WasmReturnTop tag
diff --git a/compiler/GHC/Wasm/ControlFlow/FromCmm.hs b/compiler/GHC/Wasm/ControlFlow/FromCmm.hs
deleted file mode 100644
--- a/compiler/GHC/Wasm/ControlFlow/FromCmm.hs
+++ /dev/null
@@ -1,352 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DataKinds #-}
-
-module GHC.Wasm.ControlFlow.FromCmm
-  ( structuredControl
-  )
-where
-
-import GHC.Prelude hiding (succ)
-
-import Data.Function
-import Data.List (sortBy)
-import qualified Data.Tree as Tree
-
-import GHC.Cmm
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Dominators
-import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.Switch
-
-import GHC.CmmToAsm.Wasm.Types
-
-import GHC.Platform
-
-import GHC.Utils.Misc
-import GHC.Utils.Panic
-import GHC.Utils.Outputable ( Outputable, text, (<+>), ppr
-                            , pprWithCommas
-                            )
-
-import GHC.Wasm.ControlFlow
-
-
-{-|
-Module      : GHC.Wasm.ControlFlow.FromCmm
-Description : Translation of (reducible) Cmm control flow to WebAssembly
-
-Code in this module can translate any _reducible_ Cmm control-flow
-graph to the structured control flow that is required by WebAssembly.
-The algorithm is subtle and is described in detail in a draft paper
-to be found at https://www.cs.tufts.edu/~nr/pubs/relooper.pdf.
--}
-
---------------------- Abstraction of Cmm control flow -----------------------
-
--- | Abstracts the kind of control flow we understand how to convert.
--- A block can be left in one of four ways:
---
---   * Unconditionally
---
---   * Conditionally on a predicate of type `e`
---
---   * To a location determined by the value of a scrutinee of type `e`
---
---   * Not at all.
-
-data ControlFlow e = Unconditional Label
-                   | Conditional e Label Label
-                   | Switch { _scrutinee :: e
-                            , _range :: BrTableInterval
-                            , _targets :: [Maybe Label] -- from 0
-                            , _defaultTarget :: Maybe Label
-                            }
-                   | TailCall e
-
-flowLeaving :: Platform -> CmmBlock -> ControlFlow CmmExpr
-flowLeaving platform b =
-    case lastNode b of
-      CmmBranch l -> Unconditional l
-      CmmCondBranch c t f _ -> Conditional c t f
-      CmmSwitch e targets ->
-          let (offset, target_labels) = switchTargetsToTable targets
-              (lo, hi) = switchTargetsRange targets
-              default_label = switchTargetsDefault targets
-              scrutinee = smartPlus platform e offset
-              range = inclusiveInterval (lo+toInteger offset) (hi+toInteger offset)
-          in  Switch scrutinee range target_labels default_label
-      CmmCall { cml_cont = Nothing, cml_target = e } -> TailCall e
-      _ -> panic "flowLeaving: unreachable"
-
------------------------ Evaluation contexts ------------------------------
-
--- | The syntactic constructs in which Wasm code may be contained.
--- A list of these constructs represents an evaluation context,
--- which is used to determined what level of `br` instruction
--- reaches a given label.
-
-data ContainingSyntax
-    = BlockFollowedBy Label
-    | LoopHeadedBy Label
-    | IfThenElse (Maybe Label) -- ^ Carries the label that follows `if...end`, if any
-
-matchesFrame :: Label -> ContainingSyntax -> Bool
-matchesFrame label (BlockFollowedBy l) = label == l
-matchesFrame label (LoopHeadedBy l) = label == l
-matchesFrame label (IfThenElse (Just l)) = label == l
-matchesFrame _ _ = False
-
-data Context = Context { enclosing :: [ContainingSyntax]
-                       , fallthrough :: Maybe Label  -- the label can
-                                                     -- be reached just by "falling through"
-                                                     -- the hole
-                       }
-
-instance Outputable Context where
-  ppr c | Just l <- fallthrough c =
-                    pprWithCommas ppr (enclosing c) <+> text "fallthrough to" <+> ppr l
-        | otherwise = pprWithCommas ppr (enclosing c)
-
-emptyContext :: Context
-emptyContext = Context [] Nothing
-
-inside :: ContainingSyntax -> Context -> Context
-withFallthrough :: Context -> Label -> Context
-
-inside frame c = c { enclosing = frame : enclosing c }
-withFallthrough c l = c { fallthrough = Just l }
-
-type CmmActions = Block CmmNode O O
-
-type FT pre post = WasmFunctionType pre post
-
-returns :: FT '[] '[ 'I32]
-doesn'tReturn :: FT '[] '[]
-
-returns = WasmFunctionType TypeListNil (TypeListCons TagI32 TypeListNil)
-doesn'tReturn = WasmFunctionType TypeListNil TypeListNil
-
-emptyPost :: FT pre post -> Bool
-emptyPost (WasmFunctionType _ TypeListNil) = True
-emptyPost _ = False
-
------------------------ Translation ------------------------------
-
--- | Convert a Cmm CFG to WebAssembly's structured control flow.
-
-structuredControl :: forall expr stmt m .
-                     Applicative m
-                  => Platform  -- ^ needed for offset calculation
-                  -> (Label -> CmmExpr -> m expr) -- ^ translator for expressions
-                  -> (Label -> CmmActions -> m stmt) -- ^ translator for straight-line code
-                  -> CmmGraph -- ^ CFG to be translated
-                  -> m (WasmControl stmt expr '[] '[ 'I32])
-structuredControl platform txExpr txBlock g =
-   doTree returns dominatorTree emptyContext
- where
-   gwd :: GraphWithDominators CmmNode
-   gwd = graphWithDominators g
-
-   dominatorTree :: Tree.Tree CmmBlock-- Dominator tree in which children are sorted
-                                       -- with highest reverse-postorder number first
-   dominatorTree = fmap blockLabeled $ sortTree $ gwdDominatorTree gwd
-
-   doTree     :: FT '[] post -> Tree.Tree CmmBlock -> Context -> m (WasmControl stmt expr '[] post)
-   nodeWithin :: forall post .
-                 FT '[] post -> CmmBlock -> [Tree.Tree CmmBlock] -> Maybe Label
-                                                   -> Context -> m (WasmControl stmt expr '[] post)
-   doBranch   :: FT '[] post -> Label -> Label     -> Context -> m (WasmControl stmt expr '[] post)
-
-   doTree fty (Tree.Node x children) context =
-       let codeForX = nodeWithin fty x selectedChildren Nothing
-       in  if isLoopHeader x then
-             WasmLoop fty <$> codeForX loopContext
-           else
-             codeForX context
-     where selectedChildren = case lastNode x of
-                                CmmSwitch {} -> children
-                                   -- N.B. Unlike `if`, translation of Switch uses only labels.
-                                _ -> filter hasMergeRoot children
-           loopContext = LoopHeadedBy (entryLabel x) `inside` context
-           hasMergeRoot = isMergeNode . Tree.rootLabel
-
-   nodeWithin fty x (y_n:ys) (Just zlabel) context =
-       WasmBlock fty <$> nodeWithin fty x (y_n:ys) Nothing context'
-     where context' = BlockFollowedBy zlabel `inside` context
-   nodeWithin fty x (y_n:ys) Nothing context =
-       nodeWithin doesn'tReturn x ys (Just ylabel) (context `withFallthrough` ylabel) <<>>
-       doTree fty y_n context
-     where ylabel = treeEntryLabel y_n
-   nodeWithin fty x [] (Just zlabel) context
-     | not (generatesIf x) =
-         WasmBlock fty <$> nodeWithin fty x [] Nothing context'
-     where context' = BlockFollowedBy zlabel `inside` context
-   nodeWithin fty x [] maybeMarks context =
-       translationOfX context
-     where xlabel = entryLabel x
-
-           translationOfX :: Context -> m (WasmControl stmt expr '[] post)
-           translationOfX context =
-             (WasmActions <$> txBlock xlabel (nodeBody x)) <<>>
-             case flowLeaving platform x of
-               Unconditional l -> doBranch fty xlabel l context
-               Conditional e t f ->
-                 WasmIf fty
-                        <$> txExpr xlabel e
-                        <*> doBranch fty xlabel t (IfThenElse maybeMarks `inside` context)
-                        <*> doBranch fty xlabel f (IfThenElse maybeMarks `inside` context)
-               TailCall e -> (WasmPush TagI32 <$> txExpr xlabel e) <<>> pure (WasmReturnTop TagI32)
-               Switch e range targets default' ->
-                   WasmBrTable <$>  txExpr xlabel e
-                               <$~> range
-                               <$~> map switchIndex targets
-                               <$~> switchIndex default'
-            where switchIndex :: Maybe Label -> Int
-                  switchIndex Nothing = 0 -- arbitrary; GHC won't go here
-                  switchIndex (Just lbl) = index lbl (enclosing context)
-
-   doBranch fty from to context
-      | to `elem` fallthrough context && emptyPost fty = pure WasmFallthrough
-                -- optimization: `br` is not needed, but it typechecks
-                -- only if nothing is expected to be left on the stack
-
-      | isBackward from to = pure $ WasmBr i -- continue
-      | isMergeLabel to = pure $ WasmBr i -- exit
-      | otherwise = doTree fty (subtreeAt to) context -- inline the code here
-     where i = index to (enclosing context)
-
-   generatesIf :: CmmBlock -> Bool
-   generatesIf x = case flowLeaving platform x of Conditional {} -> True
-                                                  _ -> False
-
-   ---- everything else is utility functions
-
-   treeEntryLabel :: Tree.Tree CmmBlock -> Label
-   treeEntryLabel = entryLabel . Tree.rootLabel
-
-   sortTree :: Tree.Tree Label -> Tree.Tree Label
-    -- Sort highest rpnum first
-   sortTree (Tree.Node label children) =
-      Tree.Node label $ sortBy (flip compare `on` (rpnum . Tree.rootLabel)) $
-                        map sortTree children
-
-   subtreeAt :: Label -> Tree.Tree CmmBlock
-   blockLabeled :: Label -> CmmBlock
-   rpnum :: Label -> RPNum-- reverse postorder number of the labeled block
-   isMergeLabel :: Label -> Bool
-   isMergeNode :: CmmBlock -> Bool
-   isLoopHeader :: CmmBlock -> Bool-- identify loop headers
-    -- all nodes whose immediate dominator is the given block.
-     -- They are produced with the largest RP number first,
-     -- so the largest RP number is pushed on the context first.
-   dominates :: Label -> Label -> Bool
-    -- Domination relation (not just immediate domination)
-
-   blockmap :: LabelMap CmmBlock
-   GMany NothingO blockmap NothingO = g_graph g
-
-   blockLabeled l = findLabelIn l blockmap
-
-   rpblocks :: [CmmBlock]
-   rpblocks = revPostorderFrom blockmap (g_entry g)
-
-   foldEdges :: forall a . (Label -> Label -> a -> a) -> a -> a
-   foldEdges f a =
-     foldl (\a (from, to) -> f from to a)
-           a
-           [(entryLabel from, to) | from <- rpblocks, to <- successors from]
-
-   isMergeLabel l = setMember l mergeBlockLabels
-   isMergeNode = isMergeLabel . entryLabel
-
-   isBackward :: Label -> Label -> Bool
-   isBackward from to = rpnum to <= rpnum from -- self-edge counts as a backward edge
-
-   subtreeAt label = findLabelIn label subtrees
-   subtrees :: LabelMap (Tree.Tree CmmBlock)
-   subtrees = addSubtree mapEmpty dominatorTree
-     where addSubtree map t@(Tree.Node root children) =
-               foldl addSubtree (mapInsert (entryLabel root) t map) children
-
-   mergeBlockLabels :: LabelSet
-   -- N.B. A block is a merge node if it is where control flow merges.
-   -- That means it is entered by multiple control-flow edges, _except_
-   -- back edges don't count.  There must be multiple paths that enter the
-   -- block _without_ passing through the block itself.
-   mergeBlockLabels =
-       setFromList [entryLabel n | n <- rpblocks, big (forwardPreds (entryLabel n))]
-    where big [] = False
-          big [_] = False
-          big (_ : _ : _) = True
-
-          forwardPreds :: Label -> [Label] -- reachable predecessors of reachable blocks,
-                                           -- via forward edges only
-          forwardPreds = \l -> mapFindWithDefault [] l predmap
-              where predmap :: LabelMap [Label]
-                    predmap = foldEdges addForwardEdge mapEmpty
-                    addForwardEdge from to pm
-                        | isBackward from to = pm
-                        | otherwise = addToList (from :) to pm
-
-   isLoopHeader = isHeaderLabel . entryLabel
-   isHeaderLabel = (`setMember` headers)  -- loop headers
-      where headers :: LabelSet
-            headers = foldMap headersPointedTo blockmap
-            headersPointedTo block =
-                setFromList [label | label <- successors block,
-                                              dominates label (entryLabel block)]
-
-   index :: Label -> [ContainingSyntax] -> Int
-   index _ [] = panic "destination label not in evaluation context"
-   index label (frame : context)
-       | label `matchesFrame` frame = 0
-       | otherwise = 1 + index label context
-
-   rpnum = gwdRPNumber gwd
-   dominates lbl blockname =
-       lbl == blockname || dominatorsMember lbl (gwdDominatorsOf gwd blockname)
-
-
-
-nodeBody :: CmmBlock -> CmmActions
-nodeBody (BlockCC _first middle _last) = middle
-
-
-smartPlus :: Platform -> CmmExpr -> Int -> CmmExpr
-smartPlus _ e 0 = e
-smartPlus platform e k =
-    CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger k) width)]
-  where width = cmmExprWidth platform e
-
-addToList :: (IsMap map) => ([a] -> [a]) -> KeyOf map -> map [a] -> map [a]
-addToList consx = mapAlter add
-    where add Nothing = Just (consx [])
-          add (Just xs) = Just (consx xs)
-
-------------------------------------------------------------------
---- everything below here is for diagnostics in case of panic
-
-instance Outputable ContainingSyntax where
-    ppr (BlockFollowedBy l) = text "node" <+> ppr l
-    ppr (LoopHeadedBy l) = text "loop" <+> ppr l
-    ppr (IfThenElse l) = text "if-then-else" <+> ppr l
-
-findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a
-findLabelIn lbl = mapFindWithDefault failed lbl
-  where failed =
-            pprPanic "label not found in control-flow graph" (ppr lbl)
-
-
-infixl 4 <$~>
-(<$~>) :: Functor m => m (a -> b) -> a -> m b
-(<$~>) f x = fmap ($ x) f
-
-(<<>>) :: forall m s e pre mid post
-       . Applicative m
-       => m (WasmControl s e pre mid)
-       -> m (WasmControl s e mid post)
-       -> m (WasmControl s e pre post)
-(<<>>) = liftA2 (<>)
diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h
new file mode 100644
--- /dev/null
+++ b/compiler/HsVersions.h
@@ -0,0 +1,65 @@
+#pragma once
+
+#if 0
+
+IMPORTANT!  If you put extra tabs/spaces in these macro definitions,
+you will screw up the layout where they are used in case expressions!
+
+(This is cpp-dependent, of course)
+
+#endif
+
+/* Useful in the headers that we share with the RTS */
+#define COMPILING_GHC 1
+
+/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */
+#include "ghc_boot_platform.h"
+
+/* Pull in the autoconf defines (HAVE_FOO), but don't include
+ * ghcconfig.h, because that will include ghcplatform.h which has the
+ * wrong platform settings for the compiler (it has the platform
+ * settings for the target plat instead). */
+#include "ghcautoconf.h"
+
+#define GLOBAL_VAR(name,value,ty)  \
+{-# NOINLINE name #-};             \
+name :: IORef (ty);                \
+name = Util.global (value);
+
+#define GLOBAL_VAR_M(name,value,ty) \
+{-# NOINLINE name #-};              \
+name :: IORef (ty);                 \
+name = Util.globalM (value);
+
+
+#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \
+{-# NOINLINE name #-};                                      \
+name :: IORef (ty);                                         \
+name = Util.sharedGlobal (value) (accessor);                \
+foreign import ccall unsafe saccessor                       \
+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));
+
+#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty)  \
+{-# NOINLINE name #-};                                         \
+name :: IORef (ty);                                            \
+name = Util.sharedGlobalM (value) (accessor);                  \
+foreign import ccall unsafe saccessor                          \
+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));
+
+
+#define ASSERT(e)      if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else
+#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else
+#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $
+
+-- Examples:   Assuming   flagSet :: String -> m Bool
+--
+--    do { c   <- getChar; MASSERT( isUpper c ); ... }
+--    do { c   <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }
+--    do { str <- getStr;  ASSERTM( flagSet str ); .. }
+--    do { str <- getStr;  ASSERTM2( flagSet str, text "Bad" ); .. }
+--    do { str <- getStr;  WARNM2( flagSet str, text "Flag is set" ); .. }
+#define MASSERT(e)      ASSERT(e) return ()
+#define MASSERT2(e,msg) ASSERT2(e,msg) return ()
+#define ASSERTM(e)      do { bool <- e; MASSERT(bool) }
+#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }
+#define WARNM2(e,msg)   do { bool <- e; WARN(bool, msg) return () }
diff --git a/compiler/MachRegs.h b/compiler/MachRegs.h
deleted file mode 100644
--- a/compiler/MachRegs.h
+++ /dev/null
@@ -1,755 +0,0 @@
-/* -----------------------------------------------------------------------------
- *
- * (c) The GHC Team, 1998-2014
- *
- * Registers used in STG code.  Might or might not correspond to
- * actual machine registers.
- *
- * Do not #include this file directly: #include "Rts.h" instead.
- *
- * To understand the structure of the RTS headers, see the wiki:
- *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes
- *
- * ---------------------------------------------------------------------------*/
-
-#pragma once
-
-/* This file is #included into Haskell code in the compiler: #defines
- * only in here please.
- */
-
-/*
- * Undefine these as a precaution: some of them were found to be
- * defined by system headers on ARM/Linux.
- */
-#undef REG_R1
-#undef REG_R2
-#undef REG_R3
-#undef REG_R4
-#undef REG_R5
-#undef REG_R6
-#undef REG_R7
-#undef REG_R8
-#undef REG_R9
-#undef REG_R10
-
-/*
- * Defining MACHREGS_NO_REGS to 1 causes no global registers to be used.
- * MACHREGS_NO_REGS is typically controlled by NO_REGS, which is
- * typically defined by GHC, via a command-line option passed to gcc,
- * when the -funregisterised flag is given.
- *
- * NB. When MACHREGS_NO_REGS to 1, calling & return conventions may be
- * different.  For example, all function arguments will be passed on
- * the stack, and components of an unboxed tuple will be returned on
- * the stack rather than in registers.
- */
-#if MACHREGS_NO_REGS == 1
-
-/* Nothing */
-
-#elif MACHREGS_NO_REGS == 0
-
-/* ----------------------------------------------------------------------------
-   Caller saves and callee-saves regs.
-
-   Caller-saves regs have to be saved around C-calls made from STG
-   land, so this file defines CALLER_SAVES_<reg> for each <reg> that
-   is designated caller-saves in that machine's C calling convention.
-
-   As it stands, the only registers that are ever marked caller saves
-   are the RX, FX, DX and USER registers; as a result, if you
-   decide to caller save a system register (e.g. SP, HP, etc), note that
-   this code path is completely untested! -- EZY
-
-   See Note [Register parameter passing] for details.
-   -------------------------------------------------------------------------- */
-
-/* -----------------------------------------------------------------------------
-   The x86 register mapping
-
-   Ok, we've only got 6 general purpose registers, a frame pointer and a
-   stack pointer.  \tr{%eax} and \tr{%edx} are return values from C functions,
-   hence they get trashed across ccalls and are caller saves. \tr{%ebx},
-   \tr{%esi}, \tr{%edi}, \tr{%ebp} are all callee-saves.
-
-   Reg     STG-Reg
-   ---------------
-   ebx     Base
-   ebp     Sp
-   esi     R1
-   edi     Hp
-
-   Leaving SpLim out of the picture.
-   -------------------------------------------------------------------------- */
-
-#if defined(MACHREGS_i386)
-
-#define REG(x) __asm__("%" #x)
-
-#if !defined(not_doing_dynamic_linking)
-#define REG_Base    ebx
-#endif
-#define REG_Sp      ebp
-
-#if !defined(STOLEN_X86_REGS)
-#define STOLEN_X86_REGS 4
-#endif
-
-#if STOLEN_X86_REGS >= 3
-# define REG_R1     esi
-#endif
-
-#if STOLEN_X86_REGS >= 4
-# define REG_Hp     edi
-#endif
-#define REG_MachSp  esp
-
-#define REG_XMM1    xmm0
-#define REG_XMM2    xmm1
-#define REG_XMM3    xmm2
-#define REG_XMM4    xmm3
-
-#define REG_YMM1    ymm0
-#define REG_YMM2    ymm1
-#define REG_YMM3    ymm2
-#define REG_YMM4    ymm3
-
-#define REG_ZMM1    zmm0
-#define REG_ZMM2    zmm1
-#define REG_ZMM3    zmm2
-#define REG_ZMM4    zmm3
-
-#define MAX_REAL_VANILLA_REG 1  /* always, since it defines the entry conv */
-#define MAX_REAL_FLOAT_REG   0
-#define MAX_REAL_DOUBLE_REG  0
-#define MAX_REAL_LONG_REG    0
-#define MAX_REAL_XMM_REG     4
-#define MAX_REAL_YMM_REG     4
-#define MAX_REAL_ZMM_REG     4
-
-/* -----------------------------------------------------------------------------
-  The x86-64 register mapping
-
-  %rax          caller-saves, don't steal this one
-  %rbx          YES
-  %rcx          arg reg, caller-saves
-  %rdx          arg reg, caller-saves
-  %rsi          arg reg, caller-saves
-  %rdi          arg reg, caller-saves
-  %rbp          YES (our *prime* register)
-  %rsp          (unavailable - stack pointer)
-  %r8           arg reg, caller-saves
-  %r9           arg reg, caller-saves
-  %r10          caller-saves
-  %r11          caller-saves
-  %r12          YES
-  %r13          YES
-  %r14          YES
-  %r15          YES
-
-  %xmm0-7       arg regs, caller-saves
-  %xmm8-15      caller-saves
-
-  Use the caller-saves regs for Rn, because we don't always have to
-  save those (as opposed to Sp/Hp/SpLim etc. which always have to be
-  saved).
-
-  --------------------------------------------------------------------------- */
-
-#elif defined(MACHREGS_x86_64)
-
-#define REG(x) __asm__("%" #x)
-
-#define REG_Base  r13
-#define REG_Sp    rbp
-#define REG_Hp    r12
-#define REG_R1    rbx
-#define REG_R2    r14
-#define REG_R3    rsi
-#define REG_R4    rdi
-#define REG_R5    r8
-#define REG_R6    r9
-#define REG_SpLim r15
-#define REG_MachSp  rsp
-
-/*
-Map both Fn and Dn to register xmmn so that we can pass a function any
-combination of up to six Float# or Double# arguments without touching
-the stack. See Note [Overlapping global registers] for implications.
-*/
-
-#define REG_F1    xmm1
-#define REG_F2    xmm2
-#define REG_F3    xmm3
-#define REG_F4    xmm4
-#define REG_F5    xmm5
-#define REG_F6    xmm6
-
-#define REG_D1    xmm1
-#define REG_D2    xmm2
-#define REG_D3    xmm3
-#define REG_D4    xmm4
-#define REG_D5    xmm5
-#define REG_D6    xmm6
-
-#define REG_XMM1    xmm1
-#define REG_XMM2    xmm2
-#define REG_XMM3    xmm3
-#define REG_XMM4    xmm4
-#define REG_XMM5    xmm5
-#define REG_XMM6    xmm6
-
-#define REG_YMM1    ymm1
-#define REG_YMM2    ymm2
-#define REG_YMM3    ymm3
-#define REG_YMM4    ymm4
-#define REG_YMM5    ymm5
-#define REG_YMM6    ymm6
-
-#define REG_ZMM1    zmm1
-#define REG_ZMM2    zmm2
-#define REG_ZMM3    zmm3
-#define REG_ZMM4    zmm4
-#define REG_ZMM5    zmm5
-#define REG_ZMM6    zmm6
-
-#if !defined(mingw32_HOST_OS)
-#define CALLER_SAVES_R3
-#define CALLER_SAVES_R4
-#endif
-#define CALLER_SAVES_R5
-#define CALLER_SAVES_R6
-
-#define CALLER_SAVES_F1
-#define CALLER_SAVES_F2
-#define CALLER_SAVES_F3
-#define CALLER_SAVES_F4
-#define CALLER_SAVES_F5
-#if !defined(mingw32_HOST_OS)
-#define CALLER_SAVES_F6
-#endif
-
-#define CALLER_SAVES_D1
-#define CALLER_SAVES_D2
-#define CALLER_SAVES_D3
-#define CALLER_SAVES_D4
-#define CALLER_SAVES_D5
-#if !defined(mingw32_HOST_OS)
-#define CALLER_SAVES_D6
-#endif
-
-#define CALLER_SAVES_XMM1
-#define CALLER_SAVES_XMM2
-#define CALLER_SAVES_XMM3
-#define CALLER_SAVES_XMM4
-#define CALLER_SAVES_XMM5
-#if !defined(mingw32_HOST_OS)
-#define CALLER_SAVES_XMM6
-#endif
-
-#define CALLER_SAVES_YMM1
-#define CALLER_SAVES_YMM2
-#define CALLER_SAVES_YMM3
-#define CALLER_SAVES_YMM4
-#define CALLER_SAVES_YMM5
-#if !defined(mingw32_HOST_OS)
-#define CALLER_SAVES_YMM6
-#endif
-
-#define CALLER_SAVES_ZMM1
-#define CALLER_SAVES_ZMM2
-#define CALLER_SAVES_ZMM3
-#define CALLER_SAVES_ZMM4
-#define CALLER_SAVES_ZMM5
-#if !defined(mingw32_HOST_OS)
-#define CALLER_SAVES_ZMM6
-#endif
-
-#define MAX_REAL_VANILLA_REG 6
-#define MAX_REAL_FLOAT_REG   6
-#define MAX_REAL_DOUBLE_REG  6
-#define MAX_REAL_LONG_REG    0
-#define MAX_REAL_XMM_REG     6
-#define MAX_REAL_YMM_REG     6
-#define MAX_REAL_ZMM_REG     6
-
-/* -----------------------------------------------------------------------------
-   The PowerPC register mapping
-
-   0            system glue?    (caller-save, volatile)
-   1            SP              (callee-save, non-volatile)
-   2            AIX, powerpc64-linux:
-                    RTOC        (a strange special case)
-                powerpc32-linux:
-                                reserved for use by system
-
-   3-10         args/return     (caller-save, volatile)
-   11,12        system glue?    (caller-save, volatile)
-   13           on 64-bit:      reserved for thread state pointer
-                on 32-bit:      (callee-save, non-volatile)
-   14-31                        (callee-save, non-volatile)
-
-   f0                           (caller-save, volatile)
-   f1-f13       args/return     (caller-save, volatile)
-   f14-f31                      (callee-save, non-volatile)
-
-   \tr{14}--\tr{31} are wonderful callee-save registers on all ppc OSes.
-   \tr{0}--\tr{12} are caller-save registers.
-
-   \tr{%f14}--\tr{%f31} are callee-save floating-point registers.
-
-   We can do the Whole Business with callee-save registers only!
-   -------------------------------------------------------------------------- */
-
-#elif defined(MACHREGS_powerpc)
-
-#define REG(x) __asm__(#x)
-
-#define REG_R1          r14
-#define REG_R2          r15
-#define REG_R3          r16
-#define REG_R4          r17
-#define REG_R5          r18
-#define REG_R6          r19
-#define REG_R7          r20
-#define REG_R8          r21
-#define REG_R9          r22
-#define REG_R10         r23
-
-#define REG_F1          fr14
-#define REG_F2          fr15
-#define REG_F3          fr16
-#define REG_F4          fr17
-#define REG_F5          fr18
-#define REG_F6          fr19
-
-#define REG_D1          fr20
-#define REG_D2          fr21
-#define REG_D3          fr22
-#define REG_D4          fr23
-#define REG_D5          fr24
-#define REG_D6          fr25
-
-#define REG_Sp          r24
-#define REG_SpLim       r25
-#define REG_Hp          r26
-#define REG_Base        r27
-
-#define MAX_REAL_FLOAT_REG   6
-#define MAX_REAL_DOUBLE_REG  6
-
-/* -----------------------------------------------------------------------------
-   The ARM EABI register mapping
-
-   Here we consider ARM mode (i.e. 32bit isns)
-   and also CPU with full VFPv3 implementation
-
-   ARM registers (see Chapter 5.1 in ARM IHI 0042D and
-   Section 9.2.2 in ARM Software Development Toolkit Reference Guide)
-
-   r15  PC         The Program Counter.
-   r14  LR         The Link Register.
-   r13  SP         The Stack Pointer.
-   r12  IP         The Intra-Procedure-call scratch register.
-   r11  v8/fp      Variable-register 8.
-   r10  v7/sl      Variable-register 7.
-   r9   v6/SB/TR   Platform register. The meaning of this register is
-                   defined by the platform standard.
-   r8   v5         Variable-register 5.
-   r7   v4         Variable register 4.
-   r6   v3         Variable register 3.
-   r5   v2         Variable register 2.
-   r4   v1         Variable register 1.
-   r3   a4         Argument / scratch register 4.
-   r2   a3         Argument / scratch register 3.
-   r1   a2         Argument / result / scratch register 2.
-   r0   a1         Argument / result / scratch register 1.
-
-   VFPv2/VFPv3/NEON registers
-   s0-s15/d0-d7/q0-q3    Argument / result/ scratch registers
-   s16-s31/d8-d15/q4-q7  callee-saved registers (must be preserved across
-                         subroutine calls)
-
-   VFPv3/NEON registers (added to the VFPv2 registers set)
-   d16-d31/q8-q15        Argument / result/ scratch registers
-   ----------------------------------------------------------------------------- */
-
-#elif defined(MACHREGS_arm)
-
-#define REG(x) __asm__(#x)
-
-#define REG_Base        r4
-#define REG_Sp          r5
-#define REG_Hp          r6
-#define REG_R1          r7
-#define REG_R2          r8
-#define REG_R3          r9
-#define REG_R4          r10
-#define REG_SpLim       r11
-
-#if !defined(arm_HOST_ARCH_PRE_ARMv6)
-/* d8 */
-#define REG_F1    s16
-#define REG_F2    s17
-/* d9 */
-#define REG_F3    s18
-#define REG_F4    s19
-
-#define REG_D1    d10
-#define REG_D2    d11
-#endif
-
-/* -----------------------------------------------------------------------------
-   The ARMv8/AArch64 ABI register mapping
-
-   The AArch64 provides 31 64-bit general purpose registers
-   and 32 128-bit SIMD/floating point registers.
-
-   General purpose registers (see Chapter 5.1.1 in ARM IHI 0055B)
-
-   Register | Special | Role in the procedure call standard
-   ---------+---------+------------------------------------
-     SP     |         | The Stack Pointer
-     r30    |  LR     | The Link Register
-     r29    |  FP     | The Frame Pointer
-   r19-r28  |         | Callee-saved registers
-     r18    |         | The Platform Register, if needed;
-            |         | or temporary register
-     r17    |  IP1    | The second intra-procedure-call temporary register
-     r16    |  IP0    | The first intra-procedure-call scratch register
-    r9-r15  |         | Temporary registers
-     r8     |         | Indirect result location register
-    r0-r7   |         | Parameter/result registers
-
-
-   FPU/SIMD registers
-
-   s/d/q/v0-v7    Argument / result/ scratch registers
-   s/d/q/v8-v15   callee-saved registers (must be preserved across subroutine calls,
-                  but only bottom 64-bit value needs to be preserved)
-   s/d/q/v16-v31  temporary registers
-
-   ----------------------------------------------------------------------------- */
-
-#elif defined(MACHREGS_aarch64)
-
-#define REG(x) __asm__(#x)
-
-#define REG_Base        r19
-#define REG_Sp          r20
-#define REG_Hp          r21
-#define REG_R1          r22
-#define REG_R2          r23
-#define REG_R3          r24
-#define REG_R4          r25
-#define REG_R5          r26
-#define REG_R6          r27
-#define REG_SpLim       r28
-
-#define REG_F1          s8
-#define REG_F2          s9
-#define REG_F3          s10
-#define REG_F4          s11
-
-#define REG_D1          d12
-#define REG_D2          d13
-#define REG_D3          d14
-#define REG_D4          d15
-
-/* -----------------------------------------------------------------------------
-   The s390x register mapping
-
-   Register    | Role(s)                                 | Call effect
-   ------------+-------------------------------------+-----------------
-   r0,r1       | -                                       | caller-saved
-   r2          | Argument / return value                 | caller-saved
-   r3,r4,r5    | Arguments                               | caller-saved
-   r6          | Argument                                | callee-saved
-   r7...r11    | -                                       | callee-saved
-   r12         | (Commonly used as GOT pointer)          | callee-saved
-   r13         | (Commonly used as literal pool pointer) | callee-saved
-   r14         | Return address                          | caller-saved
-   r15         | Stack pointer                           | callee-saved
-   f0          | Argument / return value                 | caller-saved
-   f2,f4,f6    | Arguments                               | caller-saved
-   f1,f3,f5,f7 | -                                       | caller-saved
-   f8...f15    | -                                       | callee-saved
-   v0...v31    | -                                       | caller-saved
-
-   Each general purpose register r0 through r15 as well as each floating-point
-   register f0 through f15 is 64 bits wide. Each vector register v0 through v31
-   is 128 bits wide.
-
-   Note, the vector registers v0 through v15 overlap with the floating-point
-   registers f0 through f15.
-
-   -------------------------------------------------------------------------- */
-
-#elif defined(MACHREGS_s390x)
-
-#define REG(x) __asm__("%" #x)
-
-#define REG_Base        r7
-#define REG_Sp          r8
-#define REG_Hp          r10
-#define REG_R1          r11
-#define REG_R2          r12
-#define REG_R3          r13
-#define REG_R4          r6
-#define REG_R5          r2
-#define REG_R6          r3
-#define REG_R7          r4
-#define REG_R8          r5
-#define REG_SpLim       r9
-#define REG_MachSp      r15
-
-#define REG_F1          f8
-#define REG_F2          f9
-#define REG_F3          f10
-#define REG_F4          f11
-#define REG_F5          f0
-#define REG_F6          f1
-
-#define REG_D1          f12
-#define REG_D2          f13
-#define REG_D3          f14
-#define REG_D4          f15
-#define REG_D5          f2
-#define REG_D6          f3
-
-#define CALLER_SAVES_R5
-#define CALLER_SAVES_R6
-#define CALLER_SAVES_R7
-#define CALLER_SAVES_R8
-
-#define CALLER_SAVES_F5
-#define CALLER_SAVES_F6
-
-#define CALLER_SAVES_D5
-#define CALLER_SAVES_D6
-
-/* -----------------------------------------------------------------------------
-   The riscv64 register mapping
-
-   Register    | Role(s)                                 | Call effect
-   ------------+-----------------------------------------+-------------
-   zero        | Hard-wired zero                         | -
-   ra          | Return address                          | caller-saved
-   sp          | Stack pointer                           | callee-saved
-   gp          | Global pointer                          | callee-saved
-   tp          | Thread pointer                          | callee-saved
-   t0,t1,t2    | -                                       | caller-saved
-   s0          | Frame pointer                           | callee-saved
-   s1          | -                                       | callee-saved
-   a0,a1       | Arguments / return values               | caller-saved
-   a2..a7      | Arguments                               | caller-saved
-   s2..s11     | -                                       | callee-saved
-   t3..t6      | -                                       | caller-saved
-   ft0..ft7    | -                                       | caller-saved
-   fs0,fs1     | -                                       | callee-saved
-   fa0,fa1     | Arguments / return values               | caller-saved
-   fa2..fa7    | Arguments                               | caller-saved
-   fs2..fs11   | -                                       | callee-saved
-   ft8..ft11   | -                                       | caller-saved
-
-   Each general purpose register as well as each floating-point
-   register is 64 bits wide.
-
-   -------------------------------------------------------------------------- */
-
-#elif defined(MACHREGS_riscv64)
-
-#define REG(x) __asm__(#x)
-
-#define REG_Base        s1
-#define REG_Sp          s2
-#define REG_Hp          s3
-#define REG_R1          s4
-#define REG_R2          s5
-#define REG_R3          s6
-#define REG_R4          s7
-#define REG_R5          s8
-#define REG_R6          s9
-#define REG_R7          s10
-#define REG_SpLim       s11
-
-#define REG_F1          fs0
-#define REG_F2          fs1
-#define REG_F3          fs2
-#define REG_F4          fs3
-#define REG_F5          fs4
-#define REG_F6          fs5
-
-#define REG_D1          fs6
-#define REG_D2          fs7
-#define REG_D3          fs8
-#define REG_D4          fs9
-#define REG_D5          fs10
-#define REG_D6          fs11
-
-#define MAX_REAL_FLOAT_REG   6
-#define MAX_REAL_DOUBLE_REG  6
-
-#elif defined(MACHREGS_wasm32)
-
-#define REG_R1             1
-#define REG_R2             2
-#define REG_R3             3
-#define REG_R4             4
-#define REG_R5             5
-#define REG_R6             6
-#define REG_R7             7
-#define REG_R8             8
-#define REG_R9             9
-#define REG_R10            10
-
-#define REG_F1             11
-#define REG_F2             12
-#define REG_F3             13
-#define REG_F4             14
-#define REG_F5             15
-#define REG_F6             16
-
-#define REG_D1             17
-#define REG_D2             18
-#define REG_D3             19
-#define REG_D4             20
-#define REG_D5             21
-#define REG_D6             22
-
-#define REG_L1             23
-
-#define REG_Sp             24
-#define REG_SpLim          25
-#define REG_Hp             26
-#define REG_HpLim          27
-#define REG_CCCS           28
-
-#else
-
-#error Cannot find platform to give register info for
-
-#endif
-
-#else
-
-#error Bad MACHREGS_NO_REGS value
-
-#endif
-
-/* -----------------------------------------------------------------------------
- * These constants define how many stg registers will be used for
- * passing arguments (and results, in the case of an unboxed-tuple
- * return).
- *
- * We usually set MAX_REAL_VANILLA_REG and co. to be the number of the
- * highest STG register to occupy a real machine register, otherwise
- * the calling conventions will needlessly shuffle data between the
- * stack and memory-resident STG registers.  We might occasionally
- * set these macros to other values for testing, though.
- *
- * Registers above these values might still be used, for instance to
- * communicate with PrimOps and RTS functions.
- */
-
-#if !defined(MAX_REAL_VANILLA_REG)
-#  if   defined(REG_R10)
-#  define MAX_REAL_VANILLA_REG 10
-#  elif   defined(REG_R9)
-#  define MAX_REAL_VANILLA_REG 9
-#  elif   defined(REG_R8)
-#  define MAX_REAL_VANILLA_REG 8
-#  elif defined(REG_R7)
-#  define MAX_REAL_VANILLA_REG 7
-#  elif defined(REG_R6)
-#  define MAX_REAL_VANILLA_REG 6
-#  elif defined(REG_R5)
-#  define MAX_REAL_VANILLA_REG 5
-#  elif defined(REG_R4)
-#  define MAX_REAL_VANILLA_REG 4
-#  elif defined(REG_R3)
-#  define MAX_REAL_VANILLA_REG 3
-#  elif defined(REG_R2)
-#  define MAX_REAL_VANILLA_REG 2
-#  elif defined(REG_R1)
-#  define MAX_REAL_VANILLA_REG 1
-#  else
-#  define MAX_REAL_VANILLA_REG 0
-#  endif
-#endif
-
-#if !defined(MAX_REAL_FLOAT_REG)
-#  if   defined(REG_F7)
-#  error Please manually define MAX_REAL_FLOAT_REG for this architecture
-#  elif defined(REG_F6)
-#  define MAX_REAL_FLOAT_REG 6
-#  elif defined(REG_F5)
-#  define MAX_REAL_FLOAT_REG 5
-#  elif defined(REG_F4)
-#  define MAX_REAL_FLOAT_REG 4
-#  elif defined(REG_F3)
-#  define MAX_REAL_FLOAT_REG 3
-#  elif defined(REG_F2)
-#  define MAX_REAL_FLOAT_REG 2
-#  elif defined(REG_F1)
-#  define MAX_REAL_FLOAT_REG 1
-#  else
-#  define MAX_REAL_FLOAT_REG 0
-#  endif
-#endif
-
-#if !defined(MAX_REAL_DOUBLE_REG)
-#  if   defined(REG_D7)
-#  error Please manually define MAX_REAL_DOUBLE_REG for this architecture
-#  elif defined(REG_D6)
-#  define MAX_REAL_DOUBLE_REG 6
-#  elif defined(REG_D5)
-#  define MAX_REAL_DOUBLE_REG 5
-#  elif defined(REG_D4)
-#  define MAX_REAL_DOUBLE_REG 4
-#  elif defined(REG_D3)
-#  define MAX_REAL_DOUBLE_REG 3
-#  elif defined(REG_D2)
-#  define MAX_REAL_DOUBLE_REG 2
-#  elif defined(REG_D1)
-#  define MAX_REAL_DOUBLE_REG 1
-#  else
-#  define MAX_REAL_DOUBLE_REG 0
-#  endif
-#endif
-
-#if !defined(MAX_REAL_LONG_REG)
-#  if   defined(REG_L1)
-#  define MAX_REAL_LONG_REG 1
-#  else
-#  define MAX_REAL_LONG_REG 0
-#  endif
-#endif
-
-#if !defined(MAX_REAL_XMM_REG)
-#  if   defined(REG_XMM6)
-#  define MAX_REAL_XMM_REG 6
-#  elif defined(REG_XMM5)
-#  define MAX_REAL_XMM_REG 5
-#  elif defined(REG_XMM4)
-#  define MAX_REAL_XMM_REG 4
-#  elif defined(REG_XMM3)
-#  define MAX_REAL_XMM_REG 3
-#  elif defined(REG_XMM2)
-#  define MAX_REAL_XMM_REG 2
-#  elif defined(REG_XMM1)
-#  define MAX_REAL_XMM_REG 1
-#  else
-#  define MAX_REAL_XMM_REG 0
-#  endif
-#endif
-
-/* define NO_ARG_REGS if we have no argument registers at all (we can
- * optimise certain code paths using this predicate).
- */
-#if MAX_REAL_VANILLA_REG < 2
-#define NO_ARG_REGS
-#else
-#undef NO_ARG_REGS
-#endif
diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs
new file mode 100644
--- /dev/null
+++ b/compiler/backpack/DriverBkp.hs
@@ -0,0 +1,831 @@
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+
+-- | This is the driver for the 'ghc --backpack' mode, which
+-- is a reimplementation of the "package manager" bits of
+-- Backpack directly in GHC.  The basic method of operation
+-- is to compile packages and then directly insert them into
+-- GHC's in memory database.
+--
+-- The compilation products of this mode aren't really suitable
+-- for Cabal, because GHC makes up component IDs for the things
+-- it builds and doesn't serialize out the database contents.
+-- But it's still handy for constructing tests.
+
+module DriverBkp (doBackpack) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+-- In a separate module because it hooks into the parser.
+import BkpSyn
+
+import GHC hiding (Failed, Succeeded)
+import Packages
+import Parser
+import Lexer
+import GhcMonad
+import DynFlags
+import TcRnMonad
+import TcRnDriver
+import Module
+import HscTypes
+import StringBuffer
+import FastString
+import ErrUtils
+import SrcLoc
+import HscMain
+import UniqFM
+import UniqDFM
+import Outputable
+import Maybes
+import HeaderInfo
+import MkIface
+import GhcMake
+import UniqDSet
+import PrelNames
+import BasicTypes hiding (SuccessFlag(..))
+import Finder
+import Util
+
+import qualified GHC.LanguageExtensions as LangExt
+
+import Panic
+import Data.List
+import System.Exit
+import Control.Monad
+import System.FilePath
+import Data.Version
+
+-- for the unification
+import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+-- | Entry point to compile a Backpack file.
+doBackpack :: [FilePath] -> Ghc ()
+doBackpack [src_filename] = do
+    -- Apply options from file to dflags
+    dflags0 <- getDynFlags
+    let dflags1 = dflags0
+    src_opts <- liftIO $ getOptionsFromFile dflags1 src_filename
+    (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts
+    modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags})
+    -- Cribbed from: preprocessFile / DriverPipeline
+    liftIO $ checkProcessArgsResult dflags unhandled_flags
+    liftIO $ handleFlagWarnings dflags warns
+    -- TODO: Preprocessing not implemented
+
+    buf <- liftIO $ hGetStringBuffer src_filename
+    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great
+    case unP parseBackpack (mkPState dflags buf loc) of
+        PFailed _ span err -> do
+            liftIO $ throwOneError (mkPlainErrMsg dflags span err)
+        POk _ pkgname_bkp -> do
+            -- OK, so we have an LHsUnit PackageName, but we want an
+            -- LHsUnit HsComponentId.  So let's rename it.
+            let bkp = renameHsUnits dflags (packageNameMap pkgname_bkp) pkgname_bkp
+            initBkpM src_filename bkp $
+                forM_ (zip [1..] bkp) $ \(i, lunit) -> do
+                    let comp_name = unLoc (hsunitName (unLoc lunit))
+                    msgTopPackage (i,length bkp) comp_name
+                    innerBkpM $ do
+                        let (cid, insts) = computeUnitId lunit
+                        if null insts
+                            then if cid == ComponentId (fsLit "main")
+                                    then compileExe lunit
+                                    else compileUnit cid []
+                            else typecheckUnit cid insts
+doBackpack _ =
+    throwGhcException (CmdLineError "--backpack can only process a single file")
+
+computeUnitId :: LHsUnit HsComponentId -> (ComponentId, [(ModuleName, Module)])
+computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])
+  where
+    cid = hsComponentId (unLoc (hsunitName unit))
+    reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))
+    get_reqs (DeclD SignatureD (L _ modname) _) = unitUniqDSet modname
+    get_reqs (DeclD ModuleD _ _) = emptyUniqDSet
+    get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =
+        unitIdFreeHoles (convertHsUnitId hsuid)
+
+-- | Tiny enum for all types of Backpack operations we may do.
+data SessionType
+    -- | A compilation operation which will result in a
+    -- runnable executable being produced.
+    = ExeSession
+    -- | A type-checking operation which produces only
+    -- interface files, no object files.
+    | TcSession
+    -- | A compilation operation which produces both
+    -- interface files and object files.
+    | CompSession
+    deriving (Eq)
+
+-- | Create a temporary Session to do some sort of type checking or
+-- compilation.
+withBkpSession :: ComponentId
+               -> [(ModuleName, Module)]
+               -> [(UnitId, ModRenaming)]
+               -> SessionType   -- what kind of session are we doing
+               -> BkpM a        -- actual action to run
+               -> BkpM a
+withBkpSession cid insts deps session_type do_this = do
+    dflags <- getDynFlags
+    let (ComponentId cid_fs) = cid
+        is_primary = False
+        uid_str = unpackFS (hashUnitId cid insts)
+        cid_str = unpackFS cid_fs
+        -- There are multiple units in a single Backpack file, so we
+        -- need to separate out the results in those cases.  Right now,
+        -- we follow this hierarchy:
+        --      $outputdir/$compid          --> typecheck results
+        --      $outputdir/$compid/$unitid  --> compile results
+        key_base p | Just f <- p dflags = f
+                   | otherwise          = "."
+        sub_comp p | is_primary = p
+                   | otherwise = p </> cid_str
+        outdir p | CompSession <- session_type
+                 -- Special case when package is definite
+                 , not (null insts) = sub_comp (key_base p) </> uid_str
+                 | otherwise = sub_comp (key_base p)
+    withTempSession (overHscDynFlags (\dflags ->
+      -- If we're type-checking an indefinite package, we want to
+      -- turn on interface writing.  However, if the user also
+      -- explicitly passed in `-fno-code`, we DON'T want to write
+      -- interfaces unless the user also asked for `-fwrite-interface`.
+      -- See Note [-fno-code mode]
+      (case session_type of
+        -- Make sure to write interfaces when we are type-checking
+        -- indefinite packages.
+        TcSession | hscTarget dflags /= HscNothing
+                  -> flip gopt_set Opt_WriteInterface
+                  | otherwise -> id
+        CompSession -> id
+        ExeSession -> id) $
+      dflags {
+        hscTarget   = case session_type of
+                        TcSession -> HscNothing
+                        _ -> hscTarget dflags,
+        thisUnitIdInsts_ = Just insts,
+        thisComponentId_ = Just cid,
+        thisInstalledUnitId =
+            case session_type of
+                TcSession -> newInstalledUnitId cid Nothing
+                -- No hash passed if no instances
+                _ | null insts -> newInstalledUnitId cid Nothing
+                  | otherwise  -> newInstalledUnitId cid (Just (hashUnitId cid insts)),
+        -- Setup all of the output directories according to our hierarchy
+        objectDir   = Just (outdir objectDir),
+        hiDir       = Just (outdir hiDir),
+        stubDir     = Just (outdir stubDir),
+        -- Unset output-file for non exe builds
+        outputFile  = if session_type == ExeSession
+                        then outputFile dflags
+                        else Nothing,
+        -- Clear the import path so we don't accidentally grab anything
+        importPaths = [],
+        -- Synthesized the flags
+        packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
+          let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)
+          in ExposePackage
+            (showSDoc dflags
+                (text "-unit-id" <+> ppr uid <+> ppr rn))
+            (UnitIdArg uid) rn) deps
+      } )) $ do
+        dflags <- getSessionDynFlags
+        -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
+        -- Calls initPackages
+        _ <- setSessionDynFlags dflags
+        do_this
+
+withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a
+withBkpExeSession deps do_this = do
+    withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this
+
+getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)
+getSource cid = do
+    bkp_env <- getBkpEnv
+    case Map.lookup cid (bkp_table bkp_env) of
+        Nothing -> pprPanic "missing needed dependency" (ppr cid)
+        Just lunit -> return lunit
+
+typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
+typecheckUnit cid insts = do
+    lunit <- getSource cid
+    buildUnit TcSession cid insts lunit
+
+compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()
+compileUnit cid insts = do
+    -- Let everyone know we're building this unit ID
+    msgUnitId (newUnitId cid insts)
+    lunit <- getSource cid
+    buildUnit CompSession cid insts lunit
+
+-- | Compute the dependencies with instantiations of a syntactic
+-- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a
+-- unit file, return the 'UnitId' corresponding to @p[A=<A>]@.
+-- The @include_sigs@ parameter controls whether or not we also
+-- include @dependency signature@ declarations in this calculation.
+--
+-- Invariant: this NEVER returns InstalledUnitId.
+hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)]
+hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit)
+  where
+    get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig)))
+        | include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)]
+        | otherwise = []
+      where
+        go Nothing = ModRenaming True []
+        go (Just lrns) = ModRenaming False (map convRn lrns)
+          where
+            convRn (L _ (Renaming (L _ from) Nothing))         = (from, from)
+            convRn (L _ (Renaming (L _ from) (Just (L _ to)))) = (from, to)
+    get_dep _ = []
+
+buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
+buildUnit session cid insts lunit = do
+    -- NB: include signature dependencies ONLY when typechecking.
+    -- If we're compiling, it's not necessary to recursively
+    -- compile a signature since it isn't going to produce
+    -- any object files.
+    let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)
+        raw_deps = map fst deps_w_rns
+    dflags <- getDynFlags
+    -- The compilation dependencies are just the appropriately filled
+    -- in unit IDs which must be compiled before we can compile.
+    let hsubst = listToUFM insts
+        deps0 = map (renameHoleUnitId dflags hsubst) raw_deps
+
+    -- Build dependencies OR make sure they make sense. BUT NOTE,
+    -- we can only check the ones that are fully filled; the rest
+    -- we have to defer until we've typechecked our local signature.
+    -- TODO: work this into GhcMake!!
+    forM_ (zip [1..] deps0) $ \(i, dep) ->
+        case session of
+            TcSession -> return ()
+            _ -> compileInclude (length deps0) (i, dep)
+
+    dflags <- getDynFlags
+    -- IMPROVE IT
+    let deps = map (improveUnitId (getPackageConfigMap dflags)) deps0
+
+    mb_old_eps <- case session of
+                    TcSession -> fmap Just getEpsGhc
+                    _ -> return Nothing
+
+    conf <- withBkpSession cid insts deps_w_rns session $ do
+
+        dflags <- getDynFlags
+        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
+        -- pprTrace "mod_graph" (ppr mod_graph) $ return ()
+
+        msg <- mkBackpackMsg
+        ok <- load' LoadAllTargets (Just msg) mod_graph
+        when (failed ok) (liftIO $ exitWith (ExitFailure 1))
+
+        let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags
+            export_mod ms = (ms_mod_name ms, ms_mod ms)
+            -- Export everything!
+            mods = [ export_mod ms | ms <- mgModSummaries mod_graph
+                                   , ms_hsc_src ms == HsSrcFile ]
+
+        -- Compile relevant only
+        hsc_env <- getSession
+        let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)
+            linkables = map (expectJust "bkp link" . hm_linkable)
+                      . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)
+                      $ home_mod_infos
+            getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
+            obj_files = concatMap getOfiles linkables
+
+        let compat_fs = (case cid of ComponentId fs -> fs)
+            compat_pn = PackageName compat_fs
+
+        return InstalledPackageInfo {
+            -- Stub data
+            abiHash = "",
+            sourcePackageId = SourcePackageId compat_fs,
+            packageName = compat_pn,
+            packageVersion = makeVersion [0],
+            unitId = toInstalledUnitId (thisPackage dflags),
+            sourceLibName = Nothing,
+            componentId = cid,
+            instantiatedWith = insts,
+            -- Slight inefficiency here haha
+            exposedModules = map (\(m,n) -> (m,Just n)) mods,
+            hiddenModules = [], -- TODO: doc only
+            depends = case session of
+                        -- Technically, we should state that we depend
+                        -- on all the indefinite libraries we used to
+                        -- typecheck this.  However, this field isn't
+                        -- really used for anything, so we leave it
+                        -- blank for now.
+                        TcSession -> []
+                        _ -> map (toInstalledUnitId . unwireUnitId dflags)
+                                $ deps ++ [ moduleUnitId mod
+                                          | (_, mod) <- insts
+                                          , not (isHoleModule mod) ],
+            abiDepends = [],
+            ldOptions = case session of
+                            TcSession -> []
+                            _ -> obj_files,
+            importDirs = [ hi_dir ],
+            exposed = False,
+            indefinite = case session of
+                            TcSession -> True
+                            _ -> False,
+            -- nope
+            hsLibraries = [],
+            extraLibraries = [],
+            extraGHCiLibraries = [],
+            libraryDynDirs = [],
+            libraryDirs = [],
+            frameworks = [],
+            frameworkDirs = [],
+            ccOptions = [],
+            includes = [],
+            includeDirs = [],
+            haddockInterfaces = [],
+            haddockHTMLs = [],
+            trusted = False
+            }
+
+
+    addPackage conf
+    case mb_old_eps of
+        Just old_eps -> updateEpsGhc_ (const old_eps)
+        _ -> return ()
+
+compileExe :: LHsUnit HsComponentId -> BkpM ()
+compileExe lunit = do
+    msgUnitId mainUnitId
+    let deps_w_rns = hsunitDeps False (unLoc lunit)
+        deps = map fst deps_w_rns
+        -- no renaming necessary
+    forM_ (zip [1..] deps) $ \(i, dep) ->
+        compileInclude (length deps) (i, dep)
+    withBkpExeSession deps_w_rns $ do
+        dflags <- getDynFlags
+        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)
+        msg <- mkBackpackMsg
+        ok <- load' LoadAllTargets (Just msg) mod_graph
+        when (failed ok) (liftIO $ exitWith (ExitFailure 1))
+
+addPackage :: GhcMonad m => PackageConfig -> m ()
+addPackage pkg = do
+    dflags0 <- GHC.getSessionDynFlags
+    case pkgDatabase dflags0 of
+        Nothing -> panic "addPackage: called too early"
+        Just pkgs -> do let dflags = dflags0 { pkgDatabase =
+                            Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) }
+                        _ <- GHC.setSessionDynFlags dflags
+                        -- By this time, the global ref has probably already
+                        -- been forced, in which case doing this isn't actually
+                        -- going to do you any good.
+                        -- dflags <- GHC.getSessionDynFlags
+                        -- liftIO $ setUnsafeGlobalDynFlags dflags
+                        return ()
+
+-- Precondition: UnitId is NOT InstalledUnitId
+compileInclude :: Int -> (Int, UnitId) -> BkpM ()
+compileInclude n (i, uid) = do
+    hsc_env <- getSession
+    let dflags = hsc_dflags hsc_env
+    msgInclude (i, n) uid
+    -- Check if we've compiled it already
+    case lookupPackage dflags uid of
+        Nothing -> do
+            case splitUnitIdInsts uid of
+                (_, Just indef) ->
+                    innerBkpM $ compileUnit (indefUnitIdComponentId indef)
+                                            (indefUnitIdInsts indef)
+                _ -> return ()
+        Just _ -> return ()
+
+-- ----------------------------------------------------------------------------
+-- Backpack monad
+
+-- | Backpack monad is a 'GhcMonad' which also maintains a little extra state
+-- beyond the 'Session', c.f. 'BkpEnv'.
+type BkpM = IOEnv BkpEnv
+
+-- | Backpack environment.  NB: this has a 'Session' and not an 'HscEnv',
+-- because we are going to update the 'HscEnv' as we go.
+data BkpEnv
+    = BkpEnv {
+        -- | The session
+        bkp_session :: Session,
+        -- | The filename of the bkp file we're compiling
+        bkp_filename :: FilePath,
+        -- | Table of source units which we know how to compile
+        bkp_table :: Map ComponentId (LHsUnit HsComponentId),
+        -- | When a package we are compiling includes another package
+        -- which has not been compiled, we bump the level and compile
+        -- that.
+        bkp_level :: Int
+    }
+
+-- Blah, to get rid of the default instance for IOEnv
+-- TODO: just make a proper new monad for BkpM, rather than use IOEnv
+instance {-# OVERLAPPING #-} HasDynFlags BkpM where
+    getDynFlags = fmap hsc_dflags getSession
+
+instance GhcMonad BkpM where
+    getSession = do
+        Session s <- fmap bkp_session getEnv
+        readMutVar s
+    setSession hsc_env = do
+        Session s <- fmap bkp_session getEnv
+        writeMutVar s hsc_env
+
+-- | Get the current 'BkpEnv'.
+getBkpEnv :: BkpM BkpEnv
+getBkpEnv = getEnv
+
+-- | Get the nesting level, when recursively compiling modules.
+getBkpLevel :: BkpM Int
+getBkpLevel = bkp_level `fmap` getBkpEnv
+
+-- | Apply a function on 'DynFlags' on an 'HscEnv'
+overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv
+overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) }
+
+-- | Run a 'BkpM' computation, with the nesting level bumped one.
+innerBkpM :: BkpM a -> BkpM a
+innerBkpM do_this = do
+    -- NB: withTempSession mutates, so we don't have to worry
+    -- about bkp_session being stale.
+    updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this
+
+-- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.
+updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()
+updateEpsGhc_ f = do
+    hsc_env <- getSession
+    liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ()))
+
+-- | Get the EPS from a 'GhcMonad'.
+getEpsGhc :: GhcMonad m => m ExternalPackageState
+getEpsGhc = do
+    hsc_env <- getSession
+    liftIO $ readIORef (hsc_EPS hsc_env)
+
+-- | Run 'BkpM' in 'Ghc'.
+initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a
+initBkpM file bkp m = do
+    reifyGhc $ \session -> do
+    let env = BkpEnv {
+                    bkp_session = session,
+                    bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],
+                    bkp_filename = file,
+                    bkp_level = 0
+                }
+    runIOEnv env m
+
+-- ----------------------------------------------------------------------------
+-- Messaging
+
+-- | Print a compilation progress message, but with indentation according
+-- to @level@ (for nested compilation).
+backpackProgressMsg :: Int -> DynFlags -> String -> IO ()
+backpackProgressMsg level dflags msg =
+    compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg
+
+-- | Creates a 'Messager' for Backpack compilation; this is basically
+-- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which
+-- handles indentation.
+mkBackpackMsg :: BkpM Messager
+mkBackpackMsg = do
+    level <- getBkpLevel
+    return $ \hsc_env mod_index recomp mod_summary ->
+      let dflags = hsc_dflags hsc_env
+          showMsg msg reason =
+            backpackProgressMsg level dflags $
+                showModuleIndex mod_index ++
+                msg ++ showModMsg dflags (hscTarget dflags)
+                                  (recompileRequired recomp) mod_summary
+                    ++ reason
+      in case recomp of
+            MustCompile -> showMsg "Compiling " ""
+            UpToDate
+                | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping  " ""
+                | otherwise -> return ()
+            RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
+
+-- | 'PprStyle' for Backpack messages; here we usually want the module to
+-- be qualified (so we can tell how it was instantiated.) But we try not
+-- to qualify packages so we can use simple names for them.
+backpackStyle :: DynFlags -> PprStyle
+backpackStyle dflags =
+    mkUserStyle dflags
+        (QueryQualify neverQualifyNames
+                      alwaysQualifyModules
+                      neverQualifyPackages) AllTheWay
+
+-- | Message when we initially process a Backpack unit.
+msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()
+msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do
+    dflags <- getDynFlags
+    level <- getBkpLevel
+    liftIO . backpackProgressMsg level dflags
+        $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn
+
+-- | Message when we instantiate a Backpack unit.
+msgUnitId :: UnitId -> BkpM ()
+msgUnitId pk = do
+    dflags <- getDynFlags
+    level <- getBkpLevel
+    liftIO . backpackProgressMsg level dflags
+        $ "Instantiating " ++ renderWithStyle dflags (ppr pk)
+                                (backpackStyle dflags)
+
+-- | Message when we include a Backpack unit.
+msgInclude :: (Int,Int) -> UnitId -> BkpM ()
+msgInclude (i,n) uid = do
+    dflags <- getDynFlags
+    level <- getBkpLevel
+    liftIO . backpackProgressMsg level dflags
+        $ showModuleIndex (i, n) ++ "Including " ++
+          renderWithStyle dflags (ppr uid) (backpackStyle dflags)
+
+-- ----------------------------------------------------------------------------
+-- Conversion from PackageName to HsComponentId
+
+type PackageNameMap a = Map PackageName a
+
+-- For now, something really simple, since we're not actually going
+-- to use this for anything
+unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)
+unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
+    = (pn, HsComponentId pn (ComponentId fs))
+
+packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId
+packageNameMap units = Map.fromList (map unitDefines units)
+
+renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
+renameHsUnits dflags m units = map (fmap renameHsUnit) units
+  where
+
+    renamePackageName :: PackageName -> HsComponentId
+    renamePackageName pn =
+        case Map.lookup pn m of
+            Nothing ->
+                case lookupPackageName dflags pn of
+                    Nothing -> error "no package name"
+                    Just cid -> HsComponentId pn cid
+            Just hscid -> hscid
+
+    renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId
+    renameHsUnit u =
+        HsUnit {
+            hsunitName = fmap renamePackageName (hsunitName u),
+            hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)
+        }
+
+    renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId
+    renameHsUnitDecl (DeclD a b c) = DeclD a b c
+    renameHsUnitDecl (IncludeD idecl) =
+        IncludeD IncludeDecl {
+            idUnitId = fmap renameHsUnitId (idUnitId idecl),
+            idModRenaming = idModRenaming idecl,
+            idSignatureInclude = idSignatureInclude idecl
+        }
+
+    renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
+    renameHsUnitId (HsUnitId ln subst)
+        = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)
+
+    renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId
+    renameHsModuleSubst (lk, lm)
+        = (lk, fmap renameHsModuleId lm)
+
+    renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId
+    renameHsModuleId (HsModuleVar lm) = HsModuleVar lm
+    renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm
+
+convertHsUnitId :: HsUnitId HsComponentId -> UnitId
+convertHsUnitId (HsUnitId (L _ hscid) subst)
+    = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)
+
+convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)
+convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)
+
+convertHsModuleId :: HsModuleId HsComponentId -> Module
+convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname
+convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname
+
+
+
+{-
+************************************************************************
+*                                                                      *
+                        Module graph construction
+*                                                                      *
+************************************************************************
+-}
+
+-- | This is our version of GhcMake.downsweep, but with a few modifications:
+--
+--  1. Every module is required to be mentioned, so we don't do any funny
+--     business with targets or recursively grabbing dependencies.  (We
+--     could support this in principle).
+--  2. We support inline modules, whose summary we have to synthesize ourself.
+--
+-- We don't bother trying to support GhcMake for now, it's more trouble
+-- than it's worth for inline modules.
+hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph
+hsunitModuleGraph dflags unit = do
+    let decls = hsunitBody unit
+        pn = hsPackageName (unLoc (hsunitName unit))
+
+    --  1. Create a HsSrcFile/HsigFile summary for every
+    --  explicitly mentioned module/signature.
+    let get_decl (L _ (DeclD dt lmodname mb_hsmod)) = do
+          let hsc_src = case dt of
+                          ModuleD    -> HsSrcFile
+                          SignatureD -> HsigFile
+          Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod
+        get_decl _ = return Nothing
+    nodes <- catMaybes `fmap` mapM get_decl decls
+
+    --  2. For each hole which does not already have an hsig file,
+    --  create an "empty" hsig file to induce compilation for the
+    --  requirement.
+    let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n)
+                                | n <- nodes ]
+    req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) ->
+        let has_local = Map.member (mod_name, True) node_map
+        in if has_local
+            then return Nothing
+            else fmap Just $ summariseRequirement pn mod_name
+
+    -- 3. Return the kaboodle
+    return $ mkModuleGraph $ nodes ++ req_nodes
+
+summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
+summariseRequirement pn mod_name = do
+    hsc_env <- getSession
+    let dflags = hsc_dflags hsc_env
+
+    let PackageName pn_fs = pn
+    location <- liftIO $ mkHomeModLocation2 dflags mod_name
+                 (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"
+
+    env <- getBkpEnv
+    time <- liftIO $ getModificationUTCTime (bkp_filename env)
+    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
+    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+    let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)
+
+    mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
+
+    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name
+
+    return ModSummary {
+        ms_mod = mod,
+        ms_hsc_src = HsigFile,
+        ms_location = location,
+        ms_hs_date = time,
+        ms_obj_date = Nothing,
+        ms_iface_date = hi_timestamp,
+        ms_hie_date = hie_timestamp,
+        ms_srcimps = [],
+        ms_textual_imps = extra_sig_imports,
+        ms_parsed_mod = Just (HsParsedModule {
+                hpm_module = L loc (HsModule {
+                        hsmodName = Just (L loc mod_name),
+                        hsmodExports = Nothing,
+                        hsmodImports = [],
+                        hsmodDecls = [],
+                        hsmodDeprecMessage = Nothing,
+                        hsmodHaddockModHeader = Nothing
+                    }),
+                hpm_src_files = [],
+                hpm_annotations = (Map.empty, Map.empty)
+            }),
+        ms_hspp_file = "", -- none, it came inline
+        ms_hspp_opts = dflags,
+        ms_hspp_buf = Nothing
+        }
+
+summariseDecl :: PackageName
+              -> HscSource
+              -> Located ModuleName
+              -> Maybe (Located (HsModule GhcPs))
+              -> BkpM ModSummary
+summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod
+summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
+    = do hsc_env <- getSession
+         let dflags = hsc_dflags hsc_env
+         -- TODO: this looks for modules in the wrong place
+         r <- liftIO $ summariseModule hsc_env
+                         Map.empty -- GHC API recomp not supported
+                         (hscSourceToIsBoot hsc_src)
+                         lmodname
+                         True -- Target lets you disallow, but not here
+                         Nothing -- GHC API buffer support not supported
+                         [] -- No exclusions
+         case r of
+            Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found"))
+            Just (Left err) -> throwOneError err
+            Just (Right summary) -> return summary
+
+-- | Up until now, GHC has assumed a single compilation target per source file.
+-- Backpack files with inline modules break this model, since a single file
+-- may generate multiple output files.  How do we decide to name these files?
+-- Should there only be one output file? This function our current heuristic,
+-- which is we make a "fake" module and use that.
+hsModuleToModSummary :: PackageName
+                     -> HscSource
+                     -> ModuleName
+                     -> Located (HsModule GhcPs)
+                     -> BkpM ModSummary
+hsModuleToModSummary pn hsc_src modname
+                     hsmod = do
+    let imps = hsmodImports (unLoc hsmod)
+        loc  = getLoc hsmod
+    hsc_env <- getSession
+    -- Sort of the same deal as in DriverPipeline's getLocation
+    -- Use the PACKAGE NAME to find the location
+    let PackageName unit_fs = pn
+        dflags = hsc_dflags hsc_env
+    -- Unfortunately, we have to define a "fake" location in
+    -- order to appease the various code which uses the file
+    -- name to figure out where to put, e.g. object files.
+    -- To add insult to injury, we don't even actually use
+    -- these filenames to figure out where the hi files go.
+    -- A travesty!
+    location0 <- liftIO $ mkHomeModLocation2 dflags modname
+                             (unpackFS unit_fs </>
+                              moduleNameSlashes modname)
+                              (case hsc_src of
+                                HsigFile -> "hsig"
+                                HsBootFile -> "hs-boot"
+                                HsSrcFile -> "hs")
+    -- DANGEROUS: bootifying can POISON the module finder cache
+    let location = case hsc_src of
+                        HsBootFile -> addBootSuffixLocnOut location0
+                        _ -> location0
+    -- This duplicates a pile of logic in GhcMake
+    env <- getBkpEnv
+    time <- liftIO $ getModificationUTCTime (bkp_filename env)
+    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
+    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
+
+    -- Also copied from 'getImports'
+    let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
+
+             -- GHC.Prim doesn't exist physically, so don't go looking for it.
+        ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)
+                               ord_idecls
+
+        implicit_prelude = xopt LangExt.ImplicitPrelude dflags
+        implicit_imports = mkPrelImports modname loc
+                                         implicit_prelude imps
+        convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
+
+    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
+
+    let normal_imports = map convImport (implicit_imports ++ ordinary_imps)
+    required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports
+
+    -- So that Finder can find it, even though it doesn't exist...
+    this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location
+    return ModSummary {
+            ms_mod = this_mod,
+            ms_hsc_src = hsc_src,
+            ms_location = location,
+            ms_hspp_file = (case hiDir dflags of
+                            Nothing -> ""
+                            Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",
+            ms_hspp_opts = dflags,
+            ms_hspp_buf = Nothing,
+            ms_srcimps = map convImport src_idecls,
+            ms_textual_imps = normal_imports
+                           -- We have to do something special here:
+                           -- due to merging, requirements may end up with
+                           -- extra imports
+                           ++ extra_sig_imports
+                           ++ required_by_imports,
+            -- This is our hack to get the parse tree to the right spot
+            ms_parsed_mod = Just (HsParsedModule {
+                    hpm_module = hsmod,
+                    hpm_src_files = [], -- TODO if we preprocessed it
+                    hpm_annotations = (Map.empty, Map.empty) -- BOGUS
+                }),
+            ms_hs_date = time,
+            ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
+            ms_iface_date = hi_timestamp,
+            ms_hie_date = hie_timestamp
+        }
+
+-- | Create a new, externally provided hashed unit id from
+-- a hash.
+newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId
+newInstalledUnitId (ComponentId cid_fs) (Just fs)
+    = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs)
+newInstalledUnitId (ComponentId cid_fs) Nothing
+    = InstalledUnitId cid_fs
diff --git a/compiler/backpack/NameShape.hs b/compiler/backpack/NameShape.hs
new file mode 100644
--- /dev/null
+++ b/compiler/backpack/NameShape.hs
@@ -0,0 +1,268 @@
+{-# LANGUAGE CPP #-}
+
+module NameShape(
+    NameShape(..),
+    emptyNameShape,
+    mkNameShape,
+    extendNameShape,
+    nameShapeExports,
+    substNameShape,
+    maybeSubstNameShape,
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Outputable
+import HscTypes
+import Module
+import UniqFM
+import Avail
+import FieldLabel
+
+import Name
+import NameEnv
+import TcRnMonad
+import Util
+import IfaceEnv
+
+import Control.Monad
+
+-- Note [NameShape]
+-- ~~~~~~~~~~~~~~~~
+-- When we write a declaration in a signature, e.g., data T, we
+-- ascribe to it a *name variable*, e.g., {m.T}.  This
+-- name variable may be substituted with an actual original
+-- name when the signature is implemented (or even if we
+-- merge the signature with one which reexports this entity
+-- from another module).
+
+-- When we instantiate a signature m with a module M,
+-- we also need to substitute over names.  To do so, we must
+-- compute the *name substitution* induced by the *exports*
+-- of the module in question.  A NameShape represents
+-- such a name substitution for a single module instantiation.
+-- The "shape" in the name comes from the fact that the computation
+-- of a name substitution is essentially the *shaping pass* from
+-- Backpack'14, but in a far more restricted form.
+
+-- The name substitution for an export list is easy to explain.  If we are
+-- filling the module variable <m>, given an export N of the form
+-- M.n or {m'.n} (where n is an OccName), the induced name
+-- substitution is from {m.n} to N.  So, for example, if we have
+-- A=impl:B, and the exports of impl:B are impl:B.f and
+-- impl:C.g, then our name substitution is {A.f} to impl:B.f
+-- and {A.g} to impl:C.g
+
+
+
+
+-- The 'NameShape' type is defined in TcRnTypes, because TcRnTypes
+-- needs to refer to NameShape, and having TcRnTypes import
+-- NameShape (even by SOURCE) would cause a large number of
+-- modules to be pulled into the DynFlags cycle.
+{-
+data NameShape = NameShape {
+        ns_mod_name :: ModuleName,
+        ns_exports :: [AvailInfo],
+        ns_map :: OccEnv Name
+    }
+-}
+
+-- NB: substitution functions need 'HscEnv' since they need the name cache
+-- to allocate new names if we change the 'Module' of a 'Name'
+
+-- | Create an empty 'NameShape' (i.e., the renaming that
+-- would occur with an implementing module with no exports)
+-- for a specific hole @mod_name@.
+emptyNameShape :: ModuleName -> NameShape
+emptyNameShape mod_name = NameShape mod_name [] emptyOccEnv
+
+-- | Create a 'NameShape' corresponding to an implementing
+-- module for the hole @mod_name@ that exports a list of 'AvailInfo's.
+mkNameShape :: ModuleName -> [AvailInfo] -> NameShape
+mkNameShape mod_name as =
+    NameShape mod_name as $ mkOccEnv $ do
+        a <- as
+        n <- availName a : availNamesWithSelectors a
+        return (occName n, n)
+
+-- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's
+-- with Backpack style mix-in linking.  This is used solely when merging
+-- signatures together: we successively merge the exports of each
+-- signature until we have the final, full exports of the merged signature.
+--
+-- What makes this operation nontrivial is what we are supposed to do when
+-- we want to merge in an export for M.T when we already have an existing
+-- export {H.T}.  What should happen in this case is that {H.T} should be
+-- unified with @M.T@: we've determined a more *precise* identity for the
+-- export at 'OccName' @T@.
+--
+-- Note that we don't do unrestricted unification: only name holes from
+-- @ns_mod_name ns@ are flexible.  This is because we have a much more
+-- restricted notion of shaping than in Backpack'14: we do shaping
+-- *as* we do type-checking.  Thus, once we shape a signature, its
+-- exports are *final* and we're not allowed to refine them further,
+extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape)
+extendNameShape hsc_env ns as =
+    case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of
+        Left err -> return (Left err)
+        Right nsubst -> do
+            as1 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) (ns_exports ns)
+            as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as
+            let new_avails = mergeAvails as1 as2
+            return . Right $ ns {
+                ns_exports = new_avails,
+                -- TODO: stop repeatedly rebuilding the OccEnv
+                ns_map = mkOccEnv $ do
+                            a <- new_avails
+                            n <- availName a : availNames a
+                            return (occName n, n)
+                }
+
+-- | The export list associated with this 'NameShape' (i.e., what
+-- the exports of an implementing module which induces this 'NameShape'
+-- would be.)
+nameShapeExports :: NameShape -> [AvailInfo]
+nameShapeExports = ns_exports
+
+-- | Given a 'Name', substitute it according to the 'NameShape' implied
+-- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module
+-- exports @M.T@.
+substNameShape :: NameShape -> Name -> Name
+substNameShape ns n | nameModule n == ns_module ns
+                    , Just n' <- lookupOccEnv (ns_map ns) (occName n)
+                    = n'
+                    | otherwise
+                    = n
+
+-- | Like 'substNameShape', but returns @Nothing@ if no substitution
+-- works.
+maybeSubstNameShape :: NameShape -> Name -> Maybe Name
+maybeSubstNameShape ns n
+    | nameModule n == ns_module ns
+    = lookupOccEnv (ns_map ns) (occName n)
+    | otherwise
+    = Nothing
+
+-- | The 'Module' of any 'Name's a 'NameShape' has action over.
+ns_module :: NameShape -> Module
+ns_module = mkHoleModule . ns_mod_name
+
+{-
+************************************************************************
+*                                                                      *
+                        Name substitutions
+*                                                                      *
+************************************************************************
+-}
+
+-- | Substitution on @{A.T}@.  We enforce the invariant that the
+-- 'nameModule' of keys of this map have 'moduleUnitId' @hole@
+-- (meaning that if we have a hole substitution, the keys of the map
+-- are never affected.)  Alternatively, this is isomorphic to
+-- @Map ('ModuleName', 'OccName') 'Name'@.
+type ShNameSubst = NameEnv Name
+
+-- NB: In this module, we actually only ever construct 'ShNameSubst'
+-- at a single 'ModuleName'.  But 'ShNameSubst' is more convenient to
+-- work with.
+
+-- | Substitute names in a 'Name'.
+substName :: ShNameSubst -> Name -> Name
+substName env n | Just n' <- lookupNameEnv env n = n'
+                | otherwise                      = n
+
+-- | Substitute names in an 'AvailInfo'.  This has special behavior
+-- for type constructors, where it is sufficient to substitute the 'availName'
+-- to induce a substitution on 'availNames'.
+substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo
+substNameAvailInfo _ env (Avail n) = return (Avail (substName env n))
+substNameAvailInfo hsc_env env (AvailTC n ns fs) =
+    let mb_mod = fmap nameModule (lookupNameEnv env n)
+    in AvailTC (substName env n)
+        <$> mapM (initIfaceLoad hsc_env . setNameModule mb_mod) ns
+        <*> mapM (setNameFieldSelector hsc_env mb_mod) fs
+
+-- | Set the 'Module' of a 'FieldSelector'
+setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel
+setNameFieldSelector _ Nothing f = return f
+setNameFieldSelector hsc_env mb_mod (FieldLabel l b sel) = do
+    sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel
+    return (FieldLabel l b sel')
+
+{-
+************************************************************************
+*                                                                      *
+                        AvailInfo merging
+*                                                                      *
+************************************************************************
+-}
+
+-- | Merges to 'AvailInfo' lists together, assuming the 'AvailInfo's have
+-- already been unified ('uAvailInfos').
+mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo]
+mergeAvails as1 as2 =
+    let mkNE as = mkNameEnv [(availName a, a) | a <- as]
+    in nameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2))
+
+{-
+************************************************************************
+*                                                                      *
+                        AvailInfo unification
+*                                                                      *
+************************************************************************
+-}
+
+-- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@,
+-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
+uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst
+uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $
+    let mkOE as = listToUFM $ do a <- as
+                                 n <- availNames a
+                                 return (nameOccName n, a)
+    in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv
+             (eltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2)))
+             -- Edward: I have to say, this is pretty clever.
+
+-- | Unify two 'AvailInfo's, given an existing substitution @subst@,
+-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
+uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo
+           -> Either SDoc ShNameSubst
+uAvailInfo flexi subst (Avail n1) (Avail n2) = uName flexi subst n1 n2
+uAvailInfo flexi subst (AvailTC n1 _ _) (AvailTC n2 _ _) = uName flexi subst n1 n2
+uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine"
+                           <+> ppr a1 <+> text "with" <+> ppr a2
+                           <+> parens (text "one is a type, the other is a plain identifier")
+
+-- | Unify two 'Name's, given an existing substitution @subst@,
+-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
+uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst
+uName flexi subst n1 n2
+    | n1 == n2      = Right subst
+    | isFlexi n1    = uHoleName flexi subst n1 n2
+    | isFlexi n2    = uHoleName flexi subst n2 n1
+    | otherwise     = Left (text "While merging export lists, could not unify"
+                         <+> ppr n1 <+> text "with" <+> ppr n2 $$ extra)
+  where
+    isFlexi n = isHoleName n && moduleName (nameModule n) == flexi
+    extra | isHoleName n1 || isHoleName n2
+          = text "Neither name variable originates from the current signature."
+          | otherwise
+          = empty
+
+-- | Unify a name @h@ which 'isHoleName' with another name, given an existing
+-- substitution @subst@, with only name holes from @flexi@ unifiable (all
+-- other name holes rigid.)
+uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name
+          -> Either SDoc ShNameSubst
+uHoleName flexi subst h n =
+    ASSERT( isHoleName h )
+    case lookupNameEnv subst h of
+        Just n' -> uName flexi subst n' n
+                -- Do a quick check if the other name is substituted.
+        Nothing | Just n' <- lookupNameEnv subst n ->
+                    ASSERT( isHoleName n ) uName flexi subst h n'
+                | otherwise ->
+                    Right (extendNameEnv subst h n)
diff --git a/compiler/backpack/RnModIface.hs b/compiler/backpack/RnModIface.hs
new file mode 100644
--- /dev/null
+++ b/compiler/backpack/RnModIface.hs
@@ -0,0 +1,745 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+
+-- | This module implements interface renaming, which is
+-- used to rewrite interface files on the fly when we
+-- are doing indefinite typechecking and need instantiations
+-- of modules which do not necessarily exist yet.
+
+module RnModIface(
+    rnModIface,
+    rnModExports,
+    tcRnModIface,
+    tcRnModExports,
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import SrcLoc
+import Outputable
+import HscTypes
+import Module
+import UniqFM
+import Avail
+import IfaceSyn
+import FieldLabel
+import Var
+import ErrUtils
+
+import Name
+import TcRnMonad
+import Util
+import Fingerprint
+import BasicTypes
+
+-- a bit vexing
+import {-# SOURCE #-} LoadIface
+import DynFlags
+
+import qualified Data.Traversable as T
+
+import Bag
+import Data.IORef
+import NameShape
+import IfaceEnv
+
+tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a
+tcRnMsgMaybe do_this = do
+    r <- liftIO $ do_this
+    case r of
+        Left errs -> do
+            addMessages (emptyBag, errs)
+            failM
+        Right x -> return x
+
+tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface
+tcRnModIface x y z = do
+    hsc_env <- getTopEnv
+    tcRnMsgMaybe $ rnModIface hsc_env x y z
+
+tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo]
+tcRnModExports x y = do
+    hsc_env <- getTopEnv
+    tcRnMsgMaybe $ rnModExports hsc_env x y
+
+failWithRn :: SDoc -> ShIfM a
+failWithRn doc = do
+    errs_var <- fmap sh_if_errs getGblEnv
+    dflags <- getDynFlags
+    errs <- readTcRef errs_var
+    -- TODO: maybe associate this with a source location?
+    writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc)
+    failM
+
+-- | What we have is a generalized ModIface, which corresponds to
+-- a module that looks like p[A=<A>]:B.  We need a *specific* ModIface, e.g.
+-- p[A=q():A]:B (or maybe even p[A=<B>]:B) which we load
+-- up (either to merge it, or to just use during typechecking).
+--
+-- Suppose we have:
+--
+--  p[A=<A>]:M  ==>  p[A=q():A]:M
+--
+-- Substitute all occurrences of <A> with q():A (renameHoleModule).
+-- Then, for any Name of form {A.T}, replace the Name with
+-- the Name according to the exports of the implementing module.
+-- This works even for p[A=<B>]:M, since we just read in the
+-- exports of B.hi, which is assumed to be ready now.
+--
+-- This function takes an optional 'NameShape', which can be used
+-- to further refine the identities in this interface: suppose
+-- we read a declaration for {H.T} but we actually know that this
+-- should be Foo.T; then we'll also rename this (this is used
+-- when loading an interface to merge it into a requirement.)
+rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape
+           -> ModIface -> IO (Either ErrorMessages ModIface)
+rnModIface hsc_env insts nsubst iface = do
+    initRnIface hsc_env iface insts nsubst $ do
+        mod <- rnModule (mi_module iface)
+        sig_of <- case mi_sig_of iface of
+                    Nothing -> return Nothing
+                    Just x  -> fmap Just (rnModule x)
+        exports <- mapM rnAvailInfo (mi_exports iface)
+        decls <- mapM rnIfaceDecl' (mi_decls iface)
+        insts <- mapM rnIfaceClsInst (mi_insts iface)
+        fams <- mapM rnIfaceFamInst (mi_fam_insts iface)
+        deps <- rnDependencies (mi_deps iface)
+        -- TODO:
+        -- mi_rules
+        return iface { mi_module = mod
+                     , mi_sig_of = sig_of
+                     , mi_insts = insts
+                     , mi_fam_insts = fams
+                     , mi_exports = exports
+                     , mi_decls = decls
+                     , mi_deps = deps }
+
+-- | Rename just the exports of a 'ModIface'.  Useful when we're doing
+-- shaping prior to signature merging.
+rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo])
+rnModExports hsc_env insts iface
+    = initRnIface hsc_env iface insts Nothing
+    $ mapM rnAvailInfo (mi_exports iface)
+
+rnDependencies :: Rename Dependencies
+rnDependencies deps = do
+    orphs  <- rnDepModules dep_orphs deps
+    finsts <- rnDepModules dep_finsts deps
+    return deps { dep_orphs = orphs, dep_finsts = finsts }
+
+rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module]
+rnDepModules sel deps = do
+    hsc_env <- getTopEnv
+    hmap <- getHoleSubst
+    -- NB: It's not necessary to test if we're doing signature renaming,
+    -- because ModIface will never contain module reference for itself
+    -- in these dependencies.
+    fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do
+        dflags <- getDynFlags
+        -- For holes, its necessary to "see through" the instantiation
+        -- of the hole to get accurate family instance dependencies.
+        -- For example, if B imports <A>, and <A> is instantiated with
+        -- F, we must grab and include all of the dep_finsts from
+        -- F to have an accurate transitive dep_finsts list.
+        --
+        -- However, we MUST NOT do this for regular modules.
+        -- First, for efficiency reasons, doing this
+        -- bloats the the dep_finsts list, because we *already* had
+        -- those modules in the list (it wasn't a hole module, after
+        -- all). But there's a second, more important correctness
+        -- consideration: we perform module renaming when running
+        -- --abi-hash.  In this case, GHC's contract to the user is that
+        -- it will NOT go and read out interfaces of any dependencies
+        -- (https://github.com/haskell/cabal/issues/3633); the point of
+        -- --abi-hash is just to get a hash of the on-disk interfaces
+        -- for this *specific* package.  If we go off and tug on the
+        -- interface for /everything/ in dep_finsts, we're gonna have a
+        -- bad time.  (It's safe to do do this for hole modules, though,
+        -- because the hmap for --abi-hash is always trivial, so the
+        -- interface we request is local.  Though, maybe we ought
+        -- not to do it in this case either...)
+        --
+        -- This mistake was bug #15594.
+        let mod' = renameHoleModule dflags hmap mod
+        if isHoleModule mod
+          then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env
+                                  $ loadSysInterface (text "rnDepModule") mod'
+                  return (mod' : sel (mi_deps iface))
+          else return [mod']
+
+{-
+************************************************************************
+*                                                                      *
+                        ModIface substitution
+*                                                                      *
+************************************************************************
+-}
+
+-- | Run a computation in the 'ShIfM' monad.
+initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape
+            -> ShIfM a -> IO (Either ErrorMessages a)
+initRnIface hsc_env iface insts nsubst do_this = do
+    errs_var <- newIORef emptyBag
+    let dflags = hsc_dflags hsc_env
+        hsubst = listToUFM insts
+        rn_mod = renameHoleModule dflags hsubst
+        env = ShIfEnv {
+            sh_if_module = rn_mod (mi_module iface),
+            sh_if_semantic_module = rn_mod (mi_semantic_module iface),
+            sh_if_hole_subst = listToUFM insts,
+            sh_if_shape = nsubst,
+            sh_if_errs = errs_var
+        }
+    -- Modeled off of 'initTc'
+    res <- initTcRnIf 'c' hsc_env env () $ tryM do_this
+    msgs <- readIORef errs_var
+    case res of
+        Left _                          -> return (Left msgs)
+        Right r | not (isEmptyBag msgs) -> return (Left msgs)
+                | otherwise             -> return (Right r)
+
+-- | Environment for 'ShIfM' monads.
+data ShIfEnv = ShIfEnv {
+        -- What we are renaming the ModIface to.  It assumed that
+        -- the original mi_module of the ModIface is
+        -- @generalizeModule (mi_module iface)@.
+        sh_if_module :: Module,
+        -- The semantic module that we are renaming to
+        sh_if_semantic_module :: Module,
+        -- Cached hole substitution, e.g.
+        -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@
+        sh_if_hole_subst :: ShHoleSubst,
+        -- An optional name substitution to be applied when renaming
+        -- the names in the interface.  If this is 'Nothing', then
+        -- we just load the target interface and look at the export
+        -- list to determine the renaming.
+        sh_if_shape :: Maybe NameShape,
+        -- Mutable reference to keep track of errors (similar to 'tcl_errs')
+        sh_if_errs :: IORef ErrorMessages
+    }
+
+getHoleSubst :: ShIfM ShHoleSubst
+getHoleSubst = fmap sh_if_hole_subst getGblEnv
+
+type ShIfM = TcRnIf ShIfEnv ()
+type Rename a = a -> ShIfM a
+
+
+rnModule :: Rename Module
+rnModule mod = do
+    hmap <- getHoleSubst
+    dflags <- getDynFlags
+    return (renameHoleModule dflags hmap mod)
+
+rnAvailInfo :: Rename AvailInfo
+rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n
+rnAvailInfo (AvailTC n ns fs) = do
+    -- Why don't we rnIfaceGlobal the availName itself?  It may not
+    -- actually be exported by the module it putatively is from, in
+    -- which case we won't be able to tell what the name actually
+    -- is.  But for the availNames they MUST be exported, so they
+    -- will rename fine.
+    ns' <- mapM rnIfaceGlobal ns
+    fs' <- mapM rnFieldLabel fs
+    case ns' ++ map flSelector fs' of
+        [] -> panic "rnAvailInfoEmpty AvailInfo"
+        (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do
+                         n' <- setNameModule (Just (nameModule rep)) n
+                         return (AvailTC n' ns' fs')
+
+rnFieldLabel :: Rename FieldLabel
+rnFieldLabel (FieldLabel l b sel) = do
+    sel' <- rnIfaceGlobal sel
+    return (FieldLabel l b sel')
+
+
+
+
+-- | The key function.  This gets called on every Name embedded
+-- inside a ModIface.  Our job is to take a Name from some
+-- generalized unit ID p[A=<A>, B=<B>], and change
+-- it to the correct name for a (partially) instantiated unit
+-- ID, e.g. p[A=q[]:A, B=<B>].
+--
+-- There are two important things to do:
+--
+-- If a hole is substituted with a real module implementation,
+-- we need to look at that actual implementation to determine what
+-- the true identity of this name should be.  We'll do this by
+-- loading that module's interface and looking at the mi_exports.
+--
+-- However, there is one special exception: when we are loading
+-- the interface of a requirement.  In this case, we may not have
+-- the "implementing" interface, because we are reading this
+-- interface precisely to "merge it in".
+--
+--     External case:
+--         p[A=<B>]:A (and thisUnitId is something else)
+--     We are loading this in order to determine B.hi!  So
+--     don't load B.hi to find the exports.
+--
+--     Local case:
+--         p[A=<A>]:A (and thisUnitId is p[A=<A>])
+--     This should not happen, because the rename is not necessary
+--     in this case, but if it does we shouldn't load A.hi!
+--
+-- Compare me with 'tcIfaceGlobal'!
+
+-- In effect, this function needs compute the name substitution on the
+-- fly.  What it has is the name that we would like to substitute.
+-- If the name is not a hole name {M.x} (e.g. isHoleModule) then
+-- no renaming can take place (although the inner hole structure must
+-- be updated to account for the hole module renaming.)
+rnIfaceGlobal :: Name -> ShIfM Name
+rnIfaceGlobal n = do
+    hsc_env <- getTopEnv
+    let dflags = hsc_dflags hsc_env
+    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
+    mb_nsubst <- fmap sh_if_shape getGblEnv
+    hmap <- getHoleSubst
+    let m = nameModule n
+        m' = renameHoleModule dflags hmap m
+    case () of
+       -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so,
+       -- do NOT assume B.hi is available.
+       -- In this case, rename {A.T} to {B.T} but don't look up exports.
+     _ | m' == iface_semantic_mod
+       , isHoleModule m'
+      -- NB: this could be Nothing for computeExports, we have
+      -- nothing to say.
+      -> do n' <- setNameModule (Just m') n
+            case mb_nsubst of
+                Nothing -> return n'
+                Just nsubst ->
+                    case maybeSubstNameShape nsubst n' of
+                        -- TODO: would love to have context
+                        -- TODO: This will give an unpleasant message if n'
+                        -- is a constructor; then we'll suggest adding T
+                        -- but it won't work.
+                        Nothing -> failWithRn $ vcat [
+                            text "The identifier" <+> ppr (occName n') <+>
+                                text "does not exist in the local signature.",
+                            parens (text "Try adding it to the export list of the hsig file.")
+                            ]
+                        Just n'' -> return n''
+       -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the
+       -- export list is irrelevant.
+       | not (isHoleModule m)
+      -> setNameModule (Just m') n
+       -- The substitution was from <A> to p[]:A.
+       -- But this does not mean {A.T} goes to p[]:A.T:
+       -- p[]:A may reexport T from somewhere else.  Do the name
+       -- substitution.  Furthermore, we need
+       -- to make sure we pick the accurate name NOW,
+       -- or we might accidentally reject a merge.
+       | otherwise
+      -> do -- Make sure we look up the local interface if substitution
+            -- went from <A> to <B>.
+            let m'' = if isHoleModule m'
+                        -- Pull out the local guy!!
+                        then mkModule (thisPackage dflags) (moduleName m')
+                        else m'
+            iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env
+                            $ loadSysInterface (text "rnIfaceGlobal") m''
+            let nsubst = mkNameShape (moduleName m) (mi_exports iface)
+            case maybeSubstNameShape nsubst n of
+                Nothing -> failWithRn $ vcat [
+                    text "The identifier" <+> ppr (occName n) <+>
+                        -- NB: report m' because it's more user-friendly
+                        text "does not exist in the signature for" <+> ppr m',
+                    parens (text "Try adding it to the export list in that hsig file.")
+                    ]
+                Just n' -> return n'
+
+-- | Rename an implicit name, e.g., a DFun or coercion axiom.
+-- Here is where we ensure that DFuns have the correct module as described in
+-- Note [rnIfaceNeverExported].
+rnIfaceNeverExported :: Name -> ShIfM Name
+rnIfaceNeverExported name = do
+    hmap <- getHoleSubst
+    dflags <- getDynFlags
+    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv
+    let m = renameHoleModule dflags hmap $ nameModule name
+    -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.
+    MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )
+    setNameModule (Just m) name
+
+-- Note [rnIfaceNeverExported]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- For the high-level overview, see
+-- Note [Handling never-exported TyThings under Backpack]
+--
+-- When we see a reference to an entity that was defined in a signature,
+-- 'rnIfaceGlobal' relies on the identifier in question being part of the
+-- exports of the implementing 'ModIface', so that we can use the exports to
+-- decide how to rename the identifier.  Unfortunately, references to 'DFun's
+-- and 'CoAxiom's will run into trouble under this strategy, because they are
+-- never exported.
+--
+-- Let us consider first what should happen in the absence of promotion.  In
+-- this setting, a reference to a 'DFun' or a 'CoAxiom' can only occur inside
+-- the signature *that is defining it* (as there are no Core terms in
+-- typechecked-only interface files, there's no way for a reference to occur
+-- besides from the defining 'ClsInst' or closed type family).  Thus,
+-- it doesn't really matter what names we give the DFun/CoAxiom, as long
+-- as it's consistent between the declaration site and the use site.
+--
+-- We have to make sure that these bogus names don't get propagated,
+-- but it is fine: see Note [Signature merging DFuns] for the fixups
+-- to the names we do before writing out the merged interface.
+-- (It's even easier for instantiation, since the DFuns all get
+-- dropped entirely; the instances are reexported implicitly.)
+--
+-- Unfortunately, this strategy is not enough in the presence of promotion
+-- (see bug #13149), where modules which import the signature may make
+-- reference to their coercions.  It's not altogether clear how to
+-- fix this case, but it is definitely a bug!
+
+-- PILES AND PILES OF BOILERPLATE
+
+-- | Rename an 'IfaceClsInst', with special handling for an associated
+-- dictionary function.
+rnIfaceClsInst :: Rename IfaceClsInst
+rnIfaceClsInst cls_inst = do
+    n <- rnIfaceGlobal (ifInstCls cls_inst)
+    tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst)
+
+    dfun <- rnIfaceNeverExported (ifDFun cls_inst)
+    return cls_inst { ifInstCls = n
+                    , ifInstTys = tys
+                    , ifDFun = dfun
+                    }
+
+rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon)
+rnMaybeIfaceTyCon Nothing = return Nothing
+rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc
+
+rnIfaceFamInst :: Rename IfaceFamInst
+rnIfaceFamInst d = do
+    fam <- rnIfaceGlobal (ifFamInstFam d)
+    tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d)
+    axiom <- rnIfaceGlobal (ifFamInstAxiom d)
+    return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom }
+
+rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl)
+rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl
+
+rnIfaceDecl :: Rename IfaceDecl
+rnIfaceDecl d@IfaceId{} = do
+            name <- case ifIdDetails d of
+                      IfDFunId -> rnIfaceNeverExported (ifName d)
+                      _ | isDefaultMethodOcc (occName (ifName d))
+                        -> rnIfaceNeverExported (ifName d)
+                      -- Typeable bindings. See Note [Grand plan for Typeable].
+                      _ | isTypeableBindOcc (occName (ifName d))
+                        -> rnIfaceNeverExported (ifName d)
+                        | otherwise -> rnIfaceGlobal (ifName d)
+            ty <- rnIfaceType (ifType d)
+            details <- rnIfaceIdDetails (ifIdDetails d)
+            info <- rnIfaceIdInfo (ifIdInfo d)
+            return d { ifName = name
+                     , ifType = ty
+                     , ifIdDetails = details
+                     , ifIdInfo = info
+                     }
+rnIfaceDecl d@IfaceData{} = do
+            name <- rnIfaceGlobal (ifName d)
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            ctxt <- mapM rnIfaceType (ifCtxt d)
+            cons <- rnIfaceConDecls (ifCons d)
+            res_kind <- rnIfaceType (ifResKind d)
+            parent <- rnIfaceTyConParent (ifParent d)
+            return d { ifName = name
+                     , ifBinders = binders
+                     , ifCtxt = ctxt
+                     , ifCons = cons
+                     , ifResKind = res_kind
+                     , ifParent = parent
+                     }
+rnIfaceDecl d@IfaceSynonym{} = do
+            name <- rnIfaceGlobal (ifName d)
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            syn_kind <- rnIfaceType (ifResKind d)
+            syn_rhs <- rnIfaceType (ifSynRhs d)
+            return d { ifName = name
+                     , ifBinders = binders
+                     , ifResKind = syn_kind
+                     , ifSynRhs = syn_rhs
+                     }
+rnIfaceDecl d@IfaceFamily{} = do
+            name <- rnIfaceGlobal (ifName d)
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            fam_kind <- rnIfaceType (ifResKind d)
+            fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d)
+            return d { ifName = name
+                     , ifBinders = binders
+                     , ifResKind = fam_kind
+                     , ifFamFlav = fam_flav
+                     }
+rnIfaceDecl d@IfaceClass{} = do
+            name <- rnIfaceGlobal (ifName d)
+            binders <- mapM rnIfaceTyConBinder (ifBinders d)
+            body <- rnIfaceClassBody (ifBody d)
+            return d { ifName    = name
+                     , ifBinders = binders
+                     , ifBody    = body
+                     }
+rnIfaceDecl d@IfaceAxiom{} = do
+            name <- rnIfaceNeverExported (ifName d)
+            tycon <- rnIfaceTyCon (ifTyCon d)
+            ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d)
+            return d { ifName = name
+                     , ifTyCon = tycon
+                     , ifAxBranches = ax_branches
+                     }
+rnIfaceDecl d@IfacePatSyn{} =  do
+            name <- rnIfaceGlobal (ifName d)
+            let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b
+            pat_matcher <- rnPat (ifPatMatcher d)
+            pat_builder <- T.traverse rnPat (ifPatBuilder d)
+            pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d)
+            pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d)
+            pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d)
+            pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d)
+            pat_args <- mapM rnIfaceType (ifPatArgs d)
+            pat_ty <- rnIfaceType (ifPatTy d)
+            return d { ifName = name
+                     , ifPatMatcher = pat_matcher
+                     , ifPatBuilder = pat_builder
+                     , ifPatUnivBndrs = pat_univ_bndrs
+                     , ifPatExBndrs = pat_ex_bndrs
+                     , ifPatProvCtxt = pat_prov_ctxt
+                     , ifPatReqCtxt = pat_req_ctxt
+                     , ifPatArgs = pat_args
+                     , ifPatTy = pat_ty
+                     }
+
+rnIfaceClassBody :: Rename IfaceClassBody
+rnIfaceClassBody IfAbstractClass = return IfAbstractClass
+rnIfaceClassBody d@IfConcreteClass{} = do
+    ctxt <- mapM rnIfaceType (ifClassCtxt d)
+    ats <- mapM rnIfaceAT (ifATs d)
+    sigs <- mapM rnIfaceClassOp (ifSigs d)
+    return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }
+
+rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav
+rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs)))
+    = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n
+                                                <*> mapM rnIfaceAxBranch axs)
+rnIfaceFamTyConFlav flav = pure flav
+
+rnIfaceAT :: Rename IfaceAT
+rnIfaceAT (IfaceAT decl mb_ty)
+    = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty
+
+rnIfaceTyConParent :: Rename IfaceTyConParent
+rnIfaceTyConParent (IfDataInstance n tc args)
+    = IfDataInstance <$> rnIfaceGlobal n
+                     <*> rnIfaceTyCon tc
+                     <*> rnIfaceAppArgs args
+rnIfaceTyConParent IfNoParent = pure IfNoParent
+
+rnIfaceConDecls :: Rename IfaceConDecls
+rnIfaceConDecls (IfDataTyCon ds)
+    = IfDataTyCon <$> mapM rnIfaceConDecl ds
+rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d
+rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon
+
+rnIfaceConDecl :: Rename IfaceConDecl
+rnIfaceConDecl d = do
+    con_name <- rnIfaceGlobal (ifConName d)
+    con_ex_tvs <- mapM rnIfaceBndr (ifConExTCvs d)
+    con_user_tvbs <- mapM rnIfaceForAllBndr (ifConUserTvBinders d)
+    let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t
+    con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)
+    con_ctxt <- mapM rnIfaceType (ifConCtxt d)
+    con_arg_tys <- mapM rnIfaceType (ifConArgTys d)
+    con_fields <- mapM rnFieldLabel (ifConFields d)
+    let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co
+        rnIfaceBang bang = pure bang
+    con_stricts <- mapM rnIfaceBang (ifConStricts d)
+    return d { ifConName = con_name
+             , ifConExTCvs = con_ex_tvs
+             , ifConUserTvBinders = con_user_tvbs
+             , ifConEqSpec = con_eq_spec
+             , ifConCtxt = con_ctxt
+             , ifConArgTys = con_arg_tys
+             , ifConFields = con_fields
+             , ifConStricts = con_stricts
+             }
+
+rnIfaceClassOp :: Rename IfaceClassOp
+rnIfaceClassOp (IfaceClassOp n ty dm) =
+    IfaceClassOp <$> rnIfaceGlobal n
+                 <*> rnIfaceType ty
+                 <*> rnMaybeDefMethSpec dm
+
+rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType))
+rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty
+rnMaybeDefMethSpec mb = return mb
+
+rnIfaceAxBranch :: Rename IfaceAxBranch
+rnIfaceAxBranch d = do
+    ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d)
+    lhs <- rnIfaceAppArgs (ifaxbLHS d)
+    rhs <- rnIfaceType (ifaxbRHS d)
+    return d { ifaxbTyVars = ty_vars
+             , ifaxbLHS = lhs
+             , ifaxbRHS = rhs }
+
+rnIfaceIdInfo :: Rename IfaceIdInfo
+rnIfaceIdInfo NoInfo = pure NoInfo
+rnIfaceIdInfo (HasInfo is) = HasInfo <$> mapM rnIfaceInfoItem is
+
+rnIfaceInfoItem :: Rename IfaceInfoItem
+rnIfaceInfoItem (HsUnfold lb if_unf)
+    = HsUnfold lb <$> rnIfaceUnfolding if_unf
+rnIfaceInfoItem i
+    = pure i
+
+rnIfaceUnfolding :: Rename IfaceUnfolding
+rnIfaceUnfolding (IfCoreUnfold stable if_expr)
+    = IfCoreUnfold stable <$> rnIfaceExpr if_expr
+rnIfaceUnfolding (IfCompulsory if_expr)
+    = IfCompulsory <$> rnIfaceExpr if_expr
+rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr)
+    = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr
+rnIfaceUnfolding (IfDFunUnfold bs ops)
+    = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops
+
+rnIfaceExpr :: Rename IfaceExpr
+rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name)
+rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl
+rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty
+rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co
+rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args
+rnIfaceExpr (IfaceLam lam_bndr expr)
+    = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr
+rnIfaceExpr (IfaceApp fun arg)
+    = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg
+rnIfaceExpr (IfaceCase scrut case_bndr alts)
+    = IfaceCase <$> rnIfaceExpr scrut
+                <*> pure case_bndr
+                <*> mapM rnIfaceAlt alts
+rnIfaceExpr (IfaceECase scrut ty)
+    = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty
+rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
+    = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs)
+               <*> rnIfaceExpr body
+rnIfaceExpr (IfaceLet (IfaceRec pairs) body)
+    = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) ->
+                                        (,) <$> rnIfaceLetBndr bndr
+                                            <*> rnIfaceExpr rhs) pairs)
+               <*> rnIfaceExpr body
+rnIfaceExpr (IfaceCast expr co)
+    = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co
+rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit)
+rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty
+rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr
+
+rnIfaceBndrs :: Rename [IfaceBndr]
+rnIfaceBndrs = mapM rnIfaceBndr
+
+rnIfaceBndr :: Rename IfaceBndr
+rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty)
+rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceTvBndr <$> rnIfaceTvBndr tv_bndr
+
+rnIfaceTvBndr :: Rename IfaceTvBndr
+rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind
+
+rnIfaceTyConBinder :: Rename IfaceTyConBinder
+rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis
+
+rnIfaceAlt :: Rename IfaceAlt
+rnIfaceAlt (conalt, names, rhs)
+     = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs
+
+rnIfaceConAlt :: Rename IfaceConAlt
+rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ
+rnIfaceConAlt alt = pure alt
+
+rnIfaceLetBndr :: Rename IfaceLetBndr
+rnIfaceLetBndr (IfLetBndr fs ty info jpi)
+    = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info <*> pure jpi
+
+rnIfaceLamBndr :: Rename IfaceLamBndr
+rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot
+
+rnIfaceMCo :: Rename IfaceMCoercion
+rnIfaceMCo IfaceMRefl    = pure IfaceMRefl
+rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co
+
+rnIfaceCo :: Rename IfaceCoercion
+rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty
+rnIfaceCo (IfaceGReflCo role ty mco)
+  = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco
+rnIfaceCo (IfaceFunCo role co1 co2)
+    = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2
+rnIfaceCo (IfaceTyConAppCo role tc cos)
+    = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos
+rnIfaceCo (IfaceAppCo co1 co2)
+    = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2
+rnIfaceCo (IfaceForAllCo bndr co1 co2)
+    = IfaceForAllCo <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2
+rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c)
+rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl
+rnIfaceCo (IfaceHoleCo lcl)  = IfaceHoleCo  <$> pure lcl
+rnIfaceCo (IfaceAxiomInstCo n i cs)
+    = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs
+rnIfaceCo (IfaceUnivCo s r t1 t2)
+    = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2
+rnIfaceCo (IfaceSymCo c)
+    = IfaceSymCo <$> rnIfaceCo c
+rnIfaceCo (IfaceTransCo c1 c2)
+    = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
+rnIfaceCo (IfaceInstCo c1 c2)
+    = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2
+rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c
+rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c
+rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c
+rnIfaceCo (IfaceAxiomRuleCo ax cos)
+    = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos
+rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c
+
+rnIfaceTyCon :: Rename IfaceTyCon
+rnIfaceTyCon (IfaceTyCon n info)
+    = IfaceTyCon <$> rnIfaceGlobal n <*> pure info
+
+rnIfaceExprs :: Rename [IfaceExpr]
+rnIfaceExprs = mapM rnIfaceExpr
+
+rnIfaceIdDetails :: Rename IfaceIdDetails
+rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b
+rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b
+rnIfaceIdDetails details = pure details
+
+rnIfaceType :: Rename IfaceType
+rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n)
+rnIfaceType (IfaceTyVar   n)   = pure (IfaceTyVar n)
+rnIfaceType (IfaceAppTy t1 t2)
+    = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2
+rnIfaceType (IfaceLitTy l)         = return (IfaceLitTy l)
+rnIfaceType (IfaceFunTy t1 t2)
+    = IfaceFunTy <$> rnIfaceType t1 <*> rnIfaceType t2
+rnIfaceType (IfaceDFunTy t1 t2)
+    = IfaceDFunTy <$> rnIfaceType t1 <*> rnIfaceType t2
+rnIfaceType (IfaceTupleTy s i tks)
+    = IfaceTupleTy s i <$> rnIfaceAppArgs tks
+rnIfaceType (IfaceTyConApp tc tks)
+    = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceAppArgs tks
+rnIfaceType (IfaceForAllTy tv t)
+    = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t
+rnIfaceType (IfaceCoercionTy co)
+    = IfaceCoercionTy <$> rnIfaceCo co
+rnIfaceType (IfaceCastTy ty co)
+    = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co
+
+rnIfaceForAllBndr :: Rename IfaceForAllBndr
+rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis
+
+rnIfaceAppArgs :: Rename IfaceAppArgs
+rnIfaceAppArgs (IA_Arg t a ts) = IA_Arg <$> rnIfaceType t <*> pure a
+                                        <*> rnIfaceAppArgs ts
+rnIfaceAppArgs IA_Nil = pure IA_Nil
diff --git a/compiler/cmm/Bitmap.hs b/compiler/cmm/Bitmap.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Bitmap.hs
@@ -0,0 +1,134 @@
+{-# LANGUAGE BangPatterns #-}
+
+--
+-- (c) The University of Glasgow 2003-2006
+--
+
+-- Functions for constructing bitmaps, which are used in various
+-- places in generated code (stack frame liveness masks, function
+-- argument liveness masks, SRT bitmaps).
+
+module Bitmap (
+        Bitmap, mkBitmap,
+        intsToBitmap, intsToReverseBitmap,
+        mAX_SMALL_BITMAP_SIZE,
+        seqBitmap,
+  ) where
+
+import GhcPrelude
+
+import SMRep
+import DynFlags
+import Util
+
+import Data.Bits
+
+{-|
+A bitmap represented by a sequence of 'StgWord's on the /target/
+architecture.  These are used for bitmaps in info tables and other
+generated code which need to be emitted as sequences of StgWords.
+-}
+type Bitmap = [StgWord]
+
+-- | Make a bitmap from a sequence of bits
+mkBitmap :: DynFlags -> [Bool] -> Bitmap
+mkBitmap _ [] = []
+mkBitmap dflags stuff = chunkToBitmap dflags chunk : mkBitmap dflags rest
+  where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff
+
+chunkToBitmap :: DynFlags -> [Bool] -> StgWord
+chunkToBitmap dflags chunk =
+  foldl' (.|.) (toStgWord dflags 0) [ oneAt n | (True,n) <- zip chunk [0..] ]
+  where
+    oneAt :: Int -> StgWord
+    oneAt i = toStgWord dflags 1 `shiftL` i
+
+-- | Make a bitmap where the slots specified are the /ones/ in the bitmap.
+-- eg. @[0,1,3], size 4 ==> 0xb@.
+--
+-- The list of @Int@s /must/ be already sorted.
+intsToBitmap :: DynFlags
+             -> Int        -- ^ size in bits
+             -> [Int]      -- ^ sorted indices of ones
+             -> Bitmap
+intsToBitmap dflags size = go 0
+  where
+    word_sz = wORD_SIZE_IN_BITS dflags
+    oneAt :: Int -> StgWord
+    oneAt i = toStgWord dflags 1 `shiftL` i
+
+    -- It is important that we maintain strictness here.
+    -- See Note [Strictness when building Bitmaps].
+    go :: Int -> [Int] -> Bitmap
+    go !pos slots
+      | size <= pos = []
+      | otherwise =
+        (foldl' (.|.) (toStgWord dflags 0) (map (\i->oneAt (i - pos)) these)) :
+          go (pos + word_sz) rest
+      where
+        (these,rest) = span (< (pos + word_sz)) slots
+
+-- | Make a bitmap where the slots specified are the /zeros/ in the bitmap.
+-- eg. @[0,1,3], size 4 ==> 0x4@  (we leave any bits outside the size as zero,
+-- just to make the bitmap easier to read).
+--
+-- The list of @Int@s /must/ be already sorted and duplicate-free.
+intsToReverseBitmap :: DynFlags
+                    -> Int      -- ^ size in bits
+                    -> [Int]    -- ^ sorted indices of zeros free of duplicates
+                    -> Bitmap
+intsToReverseBitmap dflags size = go 0
+  where
+    word_sz = wORD_SIZE_IN_BITS dflags
+    oneAt :: Int -> StgWord
+    oneAt i = toStgWord dflags 1 `shiftL` i
+
+    -- It is important that we maintain strictness here.
+    -- See Note [Strictness when building Bitmaps].
+    go :: Int -> [Int] -> Bitmap
+    go !pos slots
+      | size <= pos = []
+      | otherwise =
+        (foldl' xor (toStgWord dflags init) (map (\i->oneAt (i - pos)) these)) :
+          go (pos + word_sz) rest
+      where
+        (these,rest) = span (< (pos + word_sz)) slots
+        remain = size - pos
+        init
+          | remain >= word_sz = -1
+          | otherwise         = (1 `shiftL` remain) - 1
+
+{-
+
+Note [Strictness when building Bitmaps]
+========================================
+
+One of the places where @Bitmap@ is used is in in building Static Reference
+Tables (SRTs) (in @CmmBuildInfoTables.procpointSRT@). In #7450 it was noticed
+that some test cases (particularly those whose C-- have large numbers of CAFs)
+produced large quantities of allocations from this function.
+
+The source traced back to 'intsToBitmap', which was lazily subtracting the word
+size from the elements of the tail of the @slots@ list and recursively invoking
+itself with the result. This resulted in large numbers of subtraction thunks
+being built up. Here we take care to avoid passing new thunks to the recursive
+call. Instead we pass the unmodified tail along with an explicit position
+accumulator, which get subtracted in the fold when we compute the Word.
+
+-}
+
+{- |
+Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h.
+Some kinds of bitmap pack a size\/bitmap into a single word if
+possible, or fall back to an external pointer when the bitmap is too
+large.  This value represents the largest size of bitmap that can be
+packed into a single word.
+-}
+mAX_SMALL_BITMAP_SIZE :: DynFlags -> Int
+mAX_SMALL_BITMAP_SIZE dflags
+ | wORD_SIZE dflags == 4 = 27
+ | otherwise             = 58
+
+seqBitmap :: Bitmap -> a -> a
+seqBitmap = seqList
+
diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/BlockId.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+{- BlockId module should probably go away completely, being superseded by Label -}
+module BlockId
+  ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
+  , newBlockId
+  , blockLbl, infoTblLbl
+  ) where
+
+import GhcPrelude
+
+import CLabel
+import IdInfo
+import Name
+import Unique
+import UniqSupply
+
+import Hoopl.Label (Label, mkHooplLabel)
+
+----------------------------------------------------------------
+--- Block Ids, their environments, and their sets
+
+{- Note [Unique BlockId]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Although a 'BlockId' is a local label, for reasons of implementation,
+'BlockId's must be unique within an entire compilation unit.  The reason
+is that each local label is mapped to an assembly-language label, and in
+most assembly languages allow, a label is visible throughout the entire
+compilation unit in which it appears.
+-}
+
+type BlockId = Label
+
+mkBlockId :: Unique -> BlockId
+mkBlockId unique = mkHooplLabel $ getKey unique
+
+newBlockId :: MonadUnique m => m BlockId
+newBlockId = mkBlockId <$> getUniqueM
+
+blockLbl :: BlockId -> CLabel
+blockLbl label = mkLocalBlockLabel (getUnique label)
+
+infoTblLbl :: BlockId -> CLabel
+infoTblLbl label
+  = mkBlockInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs
diff --git a/compiler/cmm/BlockId.hs-boot b/compiler/cmm/BlockId.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/BlockId.hs-boot
@@ -0,0 +1,8 @@
+module BlockId (BlockId, mkBlockId) where
+
+import Hoopl.Label (Label)
+import Unique (Unique)
+
+type BlockId = Label
+
+mkBlockId :: Unique -> BlockId
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CLabel.hs
@@ -0,0 +1,1436 @@
+-----------------------------------------------------------------------------
+--
+-- Object-file symbols (called CLabel for histerical raisins).
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+
+module CLabel (
+        CLabel, -- abstract type
+        ForeignLabelSource(..),
+        pprDebugCLabel,
+
+        mkClosureLabel,
+        mkSRTLabel,
+        mkInfoTableLabel,
+        mkEntryLabel,
+        mkRednCountsLabel,
+        mkConInfoTableLabel,
+        mkApEntryLabel,
+        mkApInfoTableLabel,
+        mkClosureTableLabel,
+        mkBytesLabel,
+
+        mkLocalBlockLabel,
+        mkLocalClosureLabel,
+        mkLocalInfoTableLabel,
+        mkLocalClosureTableLabel,
+
+        mkBlockInfoTableLabel,
+
+        mkBitmapLabel,
+        mkStringLitLabel,
+
+        mkAsmTempLabel,
+        mkAsmTempDerivedLabel,
+        mkAsmTempEndLabel,
+        mkAsmTempDieLabel,
+
+        mkSplitMarkerLabel,
+        mkDirty_MUT_VAR_Label,
+        mkUpdInfoLabel,
+        mkBHUpdInfoLabel,
+        mkIndStaticInfoLabel,
+        mkMainCapabilityLabel,
+        mkMAP_FROZEN_CLEAN_infoLabel,
+        mkMAP_FROZEN_DIRTY_infoLabel,
+        mkMAP_DIRTY_infoLabel,
+        mkSMAP_FROZEN_CLEAN_infoLabel,
+        mkSMAP_FROZEN_DIRTY_infoLabel,
+        mkSMAP_DIRTY_infoLabel,
+        mkBadAlignmentLabel,
+        mkArrWords_infoLabel,
+        mkSRTInfoLabel,
+
+        mkTopTickyCtrLabel,
+        mkCAFBlackHoleInfoTableLabel,
+        mkRtsPrimOpLabel,
+        mkRtsSlowFastTickyCtrLabel,
+
+        mkSelectorInfoLabel,
+        mkSelectorEntryLabel,
+
+        mkCmmInfoLabel,
+        mkCmmEntryLabel,
+        mkCmmRetInfoLabel,
+        mkCmmRetLabel,
+        mkCmmCodeLabel,
+        mkCmmDataLabel,
+        mkCmmClosureLabel,
+
+        mkRtsApFastLabel,
+
+        mkPrimCallLabel,
+
+        mkForeignLabel,
+        addLabelSize,
+
+        foreignLabelStdcallInfo,
+        isBytesLabel,
+        isForeignLabel,
+        isSomeRODataLabel,
+        isStaticClosureLabel,
+        mkCCLabel, mkCCSLabel,
+
+        DynamicLinkerLabelInfo(..),
+        mkDynamicLinkerLabel,
+        dynamicLinkerLabelInfo,
+
+        mkPicBaseLabel,
+        mkDeadStripPreventer,
+
+        mkHpcTicksLabel,
+
+        -- * Predicates
+        hasCAF,
+        needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,
+        isMathFun,
+        isCFunctionLabel, isGcPtrLabel, labelDynamic,
+        isLocalCLabel,
+
+        -- * Conversions
+        toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,
+
+        pprCLabel,
+        isInfoTableLabel,
+        isConInfoTableLabel
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import IdInfo
+import BasicTypes
+import {-# SOURCE #-} BlockId (BlockId, mkBlockId)
+import Packages
+import Module
+import Name
+import Unique
+import PrimOp
+import Config
+import CostCentre
+import Outputable
+import FastString
+import DynFlags
+import Platform
+import UniqSet
+import Util
+import PprCore ( {- instances -} )
+
+-- -----------------------------------------------------------------------------
+-- The CLabel type
+
+{- |
+  'CLabel' is an abstract type that supports the following operations:
+
+  - Pretty printing
+
+  - In a C file, does it need to be declared before use?  (i.e. is it
+    guaranteed to be already in scope in the places we need to refer to it?)
+
+  - If it needs to be declared, what type (code or data) should it be
+    declared to have?
+
+  - Is it visible outside this object file or not?
+
+  - Is it "dynamic" (see details below)
+
+  - Eq and Ord, so that we can make sets of CLabels (currently only
+    used in outputting C as far as I can tell, to avoid generating
+    more than one declaration for any given label).
+
+  - Converting an info table label into an entry label.
+
+  CLabel usage is a bit messy in GHC as they are used in a number of different
+  contexts:
+
+  - By the C-- AST to identify labels
+
+  - By the unregisterised C code generator ("PprC") for naming functions (hence
+    the name 'CLabel')
+
+  - By the native and LLVM code generators to identify labels
+
+  For extra fun, each of these uses a slightly different subset of constructors
+  (e.g. 'AsmTempLabel' and 'AsmTempDerivedLabel' are used only in the NCG and
+  LLVM backends).
+
+  In general, we use 'IdLabel' to represent Haskell things early in the
+  pipeline. However, later optimization passes will often represent blocks they
+  create with 'LocalBlockLabel' where there is no obvious 'Name' to hang off the
+  label.
+-}
+
+data CLabel
+  = -- | A label related to the definition of a particular Id or Con in a .hs file.
+    IdLabel
+        Name
+        CafInfo
+        IdLabelInfo             -- encodes the suffix of the label
+
+  -- | A label from a .cmm file that is not associated with a .hs level Id.
+  | CmmLabel
+        UnitId               -- what package the label belongs to.
+        FastString              -- identifier giving the prefix of the label
+        CmmLabelInfo            -- encodes the suffix of the label
+
+  -- | A label with a baked-in \/ algorithmically generated name that definitely
+  --    comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so
+  --    If it doesn't have an algorithmically generated name then use a CmmLabel
+  --    instead and give it an appropriate UnitId argument.
+  | RtsLabel
+        RtsLabelInfo
+
+  -- | A label associated with a block. These aren't visible outside of the
+  -- compilation unit in which they are defined. These are generally used to
+  -- name blocks produced by Cmm-to-Cmm passes and the native code generator,
+  -- where we don't have a 'Name' to associate the label to and therefore can't
+  -- use 'IdLabel'.
+  | LocalBlockLabel
+        {-# UNPACK #-} !Unique
+
+  -- | A 'C' (or otherwise foreign) label.
+  --
+  | ForeignLabel
+        FastString              -- name of the imported label.
+
+        (Maybe Int)             -- possible '@n' suffix for stdcall functions
+                                -- When generating C, the '@n' suffix is omitted, but when
+                                -- generating assembler we must add it to the label.
+
+        ForeignLabelSource      -- what package the foreign label is in.
+
+        FunctionOrData
+
+  -- | Local temporary label used for native (or LLVM) code generation; must not
+  -- appear outside of these contexts. Use primarily for debug information
+  | AsmTempLabel
+        {-# UNPACK #-} !Unique
+
+  -- | A label \"derived\" from another 'CLabel' by the addition of a suffix.
+  -- Must not occur outside of the NCG or LLVM code generators.
+  | AsmTempDerivedLabel
+        CLabel
+        FastString              -- suffix
+
+  | StringLitLabel
+        {-# UNPACK #-} !Unique
+
+  | CC_Label  CostCentre
+  | CCS_Label CostCentreStack
+
+
+  -- | These labels are generated and used inside the NCG only.
+  --    They are special variants of a label used for dynamic linking
+  --    see module PositionIndependentCode for details.
+  | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel
+
+  -- | This label is generated and used inside the NCG only.
+  --    It is used as a base for PIC calculations on some platforms.
+  --    It takes the form of a local numeric assembler label '1'; and
+  --    is pretty-printed as 1b, referring to the previous definition
+  --    of 1: in the assembler source file.
+  | PicBaseLabel
+
+  -- | A label before an info table to prevent excessive dead-stripping on darwin
+  | DeadStripPreventer CLabel
+
+
+  -- | Per-module table of tick locations
+  | HpcTicksLabel Module
+
+  -- | Static reference table
+  | SRTLabel
+        {-# UNPACK #-} !Unique
+
+  -- | A bitmap (function or case return)
+  | LargeBitmapLabel
+        {-# UNPACK #-} !Unique
+
+  deriving Eq
+
+-- This is laborious, but necessary. We can't derive Ord because
+-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the
+-- implementation. See Note [No Ord for Unique]
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+instance Ord CLabel where
+  compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) =
+    compare a1 a2 `thenCmp`
+    compare b1 b2 `thenCmp`
+    compare c1 c2
+  compare (CmmLabel a1 b1 c1) (CmmLabel a2 b2 c2) =
+    compare a1 a2 `thenCmp`
+    compare b1 b2 `thenCmp`
+    compare c1 c2
+  compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2
+  compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2
+  compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =
+    compare a1 a2 `thenCmp`
+    compare b1 b2 `thenCmp`
+    compare c1 c2 `thenCmp`
+    compare d1 d2
+  compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2
+  compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =
+    compare a1 a2 `thenCmp`
+    compare b1 b2
+  compare (StringLitLabel u1) (StringLitLabel u2) =
+    nonDetCmpUnique u1 u2
+  compare (CC_Label a1) (CC_Label a2) =
+    compare a1 a2
+  compare (CCS_Label a1) (CCS_Label a2) =
+    compare a1 a2
+  compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) =
+    compare a1 a2 `thenCmp`
+    compare b1 b2
+  compare PicBaseLabel PicBaseLabel = EQ
+  compare (DeadStripPreventer a1) (DeadStripPreventer a2) =
+    compare a1 a2
+  compare (HpcTicksLabel a1) (HpcTicksLabel a2) =
+    compare a1 a2
+  compare (SRTLabel u1) (SRTLabel u2) =
+    nonDetCmpUnique u1 u2
+  compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) =
+    nonDetCmpUnique u1 u2
+  compare IdLabel{} _ = LT
+  compare _ IdLabel{} = GT
+  compare CmmLabel{} _ = LT
+  compare _ CmmLabel{} = GT
+  compare RtsLabel{} _ = LT
+  compare _ RtsLabel{} = GT
+  compare LocalBlockLabel{} _ = LT
+  compare _ LocalBlockLabel{} = GT
+  compare ForeignLabel{} _ = LT
+  compare _ ForeignLabel{} = GT
+  compare AsmTempLabel{} _ = LT
+  compare _ AsmTempLabel{} = GT
+  compare AsmTempDerivedLabel{} _ = LT
+  compare _ AsmTempDerivedLabel{} = GT
+  compare StringLitLabel{} _ = LT
+  compare _ StringLitLabel{} = GT
+  compare CC_Label{} _ = LT
+  compare _ CC_Label{} = GT
+  compare CCS_Label{} _ = LT
+  compare _ CCS_Label{} = GT
+  compare DynamicLinkerLabel{} _ = LT
+  compare _ DynamicLinkerLabel{} = GT
+  compare PicBaseLabel{} _ = LT
+  compare _ PicBaseLabel{} = GT
+  compare DeadStripPreventer{} _ = LT
+  compare _ DeadStripPreventer{} = GT
+  compare HpcTicksLabel{} _ = LT
+  compare _ HpcTicksLabel{} = GT
+  compare SRTLabel{} _ = LT
+  compare _ SRTLabel{} = GT
+
+-- | Record where a foreign label is stored.
+data ForeignLabelSource
+
+   -- | Label is in a named package
+   = ForeignLabelInPackage      UnitId
+
+   -- | Label is in some external, system package that doesn't also
+   --   contain compiled Haskell code, and is not associated with any .hi files.
+   --   We don't have to worry about Haskell code being inlined from
+   --   external packages. It is safe to treat the RTS package as "external".
+   | ForeignLabelInExternalPackage
+
+   -- | Label is in the package currenly being compiled.
+   --   This is only used for creating hacky tmp labels during code generation.
+   --   Don't use it in any code that might be inlined across a package boundary
+   --   (ie, core code) else the information will be wrong relative to the
+   --   destination module.
+   | ForeignLabelInThisPackage
+
+   deriving (Eq, Ord)
+
+
+-- | For debugging problems with the CLabel representation.
+--      We can't make a Show instance for CLabel because lots of its components don't have instances.
+--      The regular Outputable instance only shows the label name, and not its other info.
+--
+pprDebugCLabel :: CLabel -> SDoc
+pprDebugCLabel lbl
+ = case lbl of
+        IdLabel _ _ info-> ppr lbl <> (parens $ text "IdLabel"
+                                       <> whenPprDebug (text ":" <> text (show info)))
+        CmmLabel pkg _name _info
+         -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg)
+
+        RtsLabel{}      -> ppr lbl <> (parens $ text "RtsLabel")
+
+        ForeignLabel _name mSuffix src funOrData
+            -> ppr lbl <> (parens $ text "ForeignLabel"
+                                <+> ppr mSuffix
+                                <+> ppr src
+                                <+> ppr funOrData)
+
+        _               -> ppr lbl <> (parens $ text "other CLabel")
+
+
+data IdLabelInfo
+  = Closure             -- ^ Label for closure
+  | InfoTable           -- ^ Info tables for closures; always read-only
+  | Entry               -- ^ Entry point
+  | Slow                -- ^ Slow entry point
+
+  | LocalInfoTable      -- ^ Like InfoTable but not externally visible
+  | LocalEntry          -- ^ Like Entry but not externally visible
+
+  | RednCounts          -- ^ Label of place to keep Ticky-ticky  info for this Id
+
+  | ConEntry            -- ^ Constructor entry point
+  | ConInfoTable        -- ^ Corresponding info table
+
+  | ClosureTable        -- ^ Table of closures for Enum tycons
+
+  | Bytes               -- ^ Content of a string literal. See
+                        -- Note [Bytes label].
+  | BlockInfoTable      -- ^ Like LocalInfoTable but for a proc-point block
+                        -- instead of a closure entry-point.
+                        -- See Note [Proc-point local block entry-point].
+
+  deriving (Eq, Ord, Show)
+
+
+data RtsLabelInfo
+  = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-}  -- ^ Selector thunks
+  | RtsSelectorEntry     Bool{-updatable-} Int{-offset-}
+
+  | RtsApInfoTable       Bool{-updatable-} Int{-arity-}    -- ^ AP thunks
+  | RtsApEntry           Bool{-updatable-} Int{-arity-}
+
+  | RtsPrimOp PrimOp
+  | RtsApFast     FastString    -- ^ _fast versions of generic apply
+  | RtsSlowFastTickyCtr String
+
+  deriving (Eq, Ord)
+  -- NOTE: Eq on PtrString compares the pointer only, so this isn't
+  -- a real equality.
+
+
+-- | What type of Cmm label we're dealing with.
+--      Determines the suffix appended to the name when a CLabel.CmmLabel
+--      is pretty printed.
+data CmmLabelInfo
+  = CmmInfo                     -- ^ misc rts info tables,      suffix _info
+  | CmmEntry                    -- ^ misc rts entry points,     suffix _entry
+  | CmmRetInfo                  -- ^ misc rts ret info tables,  suffix _info
+  | CmmRet                      -- ^ misc rts return points,    suffix _ret
+  | CmmData                     -- ^ misc rts data bits, eg CHARLIKE_closure
+  | CmmCode                     -- ^ misc rts code
+  | CmmClosure                  -- ^ closures eg CHARLIKE_closure
+  | CmmPrimCall                 -- ^ a prim call to some hand written Cmm code
+  deriving (Eq, Ord)
+
+data DynamicLinkerLabelInfo
+  = CodeStub                    -- MachO: Lfoo$stub, ELF: foo@plt
+  | SymbolPtr                   -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo
+  | GotSymbolPtr                -- ELF: foo@got
+  | GotSymbolOffset             -- ELF: foo@gotoff
+
+  deriving (Eq, Ord)
+
+
+-- -----------------------------------------------------------------------------
+-- Constructing CLabels
+-- -----------------------------------------------------------------------------
+
+-- Constructing IdLabels
+-- These are always local:
+
+mkSRTLabel     :: Unique -> CLabel
+mkSRTLabel u = SRTLabel u
+
+mkRednCountsLabel :: Name -> CLabel
+mkRednCountsLabel       name    =
+  IdLabel name NoCafRefs RednCounts  -- Note [ticky for LNE]
+
+-- These have local & (possibly) external variants:
+mkLocalClosureLabel      :: Name -> CafInfo -> CLabel
+mkLocalInfoTableLabel    :: Name -> CafInfo -> CLabel
+mkLocalClosureTableLabel :: Name -> CafInfo -> CLabel
+mkLocalClosureLabel     name c  = IdLabel name  c Closure
+mkLocalInfoTableLabel   name c  = IdLabel name  c LocalInfoTable
+mkLocalClosureTableLabel name c = IdLabel name  c ClosureTable
+
+mkClosureLabel              :: Name -> CafInfo -> CLabel
+mkInfoTableLabel            :: Name -> CafInfo -> CLabel
+mkEntryLabel                :: Name -> CafInfo -> CLabel
+mkClosureTableLabel         :: Name -> CafInfo -> CLabel
+mkConInfoTableLabel         :: Name -> CafInfo -> CLabel
+mkBytesLabel                :: Name -> CLabel
+mkClosureLabel name         c     = IdLabel name c Closure
+mkInfoTableLabel name       c     = IdLabel name c InfoTable
+mkEntryLabel name           c     = IdLabel name c Entry
+mkClosureTableLabel name    c     = IdLabel name c ClosureTable
+mkConInfoTableLabel name    c     = IdLabel name c ConInfoTable
+mkBytesLabel name                 = IdLabel name NoCafRefs Bytes
+
+mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel
+mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable
+                               -- See Note [Proc-point local block entry-point].
+
+-- Constructing Cmm Labels
+mkDirty_MUT_VAR_Label, mkSplitMarkerLabel, mkUpdInfoLabel,
+    mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,
+    mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,
+    mkMAP_DIRTY_infoLabel,
+    mkArrWords_infoLabel,
+    mkTopTickyCtrLabel,
+    mkCAFBlackHoleInfoTableLabel,
+    mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,
+    mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel
+mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
+mkSplitMarkerLabel              = CmmLabel rtsUnitId (fsLit "__stg_split_marker")    CmmCode
+mkUpdInfoLabel                  = CmmLabel rtsUnitId (fsLit "stg_upd_frame")         CmmInfo
+mkBHUpdInfoLabel                = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" )     CmmInfo
+mkIndStaticInfoLabel            = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC")        CmmInfo
+mkMainCapabilityLabel           = CmmLabel rtsUnitId (fsLit "MainCapability")        CmmData
+mkMAP_FROZEN_CLEAN_infoLabel    = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
+mkMAP_FROZEN_DIRTY_infoLabel    = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
+mkMAP_DIRTY_infoLabel           = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkTopTickyCtrLabel              = CmmLabel rtsUnitId (fsLit "top_ct")                CmmData
+mkCAFBlackHoleInfoTableLabel    = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE")     CmmInfo
+mkArrWords_infoLabel            = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS")         CmmInfo
+mkSMAP_FROZEN_CLEAN_infoLabel   = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo
+mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
+mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
+mkBadAlignmentLabel             = CmmLabel rtsUnitId (fsLit "stg_badAlignment")      CmmEntry
+
+mkSRTInfoLabel :: Int -> CLabel
+mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo
+ where
+   lbl =
+     case n of
+       1 -> fsLit "stg_SRT_1"
+       2 -> fsLit "stg_SRT_2"
+       3 -> fsLit "stg_SRT_3"
+       4 -> fsLit "stg_SRT_4"
+       5 -> fsLit "stg_SRT_5"
+       6 -> fsLit "stg_SRT_6"
+       7 -> fsLit "stg_SRT_7"
+       8 -> fsLit "stg_SRT_8"
+       9 -> fsLit "stg_SRT_9"
+       10 -> fsLit "stg_SRT_10"
+       11 -> fsLit "stg_SRT_11"
+       12 -> fsLit "stg_SRT_12"
+       13 -> fsLit "stg_SRT_13"
+       14 -> fsLit "stg_SRT_14"
+       15 -> fsLit "stg_SRT_15"
+       16 -> fsLit "stg_SRT_16"
+       _ -> panic "mkSRTInfoLabel"
+
+-----
+mkCmmInfoLabel,   mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
+  mkCmmCodeLabel, mkCmmDataLabel,  mkCmmClosureLabel
+        :: UnitId -> FastString -> CLabel
+
+mkCmmInfoLabel      pkg str     = CmmLabel pkg str CmmInfo
+mkCmmEntryLabel     pkg str     = CmmLabel pkg str CmmEntry
+mkCmmRetInfoLabel   pkg str     = CmmLabel pkg str CmmRetInfo
+mkCmmRetLabel       pkg str     = CmmLabel pkg str CmmRet
+mkCmmCodeLabel      pkg str     = CmmLabel pkg str CmmCode
+mkCmmDataLabel      pkg str     = CmmLabel pkg str CmmData
+mkCmmClosureLabel   pkg str     = CmmLabel pkg str CmmClosure
+
+mkLocalBlockLabel :: Unique -> CLabel
+mkLocalBlockLabel u = LocalBlockLabel u
+
+-- Constructing RtsLabels
+mkRtsPrimOpLabel :: PrimOp -> CLabel
+mkRtsPrimOpLabel primop         = RtsLabel (RtsPrimOp primop)
+
+mkSelectorInfoLabel  :: Bool -> Int -> CLabel
+mkSelectorEntryLabel :: Bool -> Int -> CLabel
+mkSelectorInfoLabel  upd off    = RtsLabel (RtsSelectorInfoTable upd off)
+mkSelectorEntryLabel upd off    = RtsLabel (RtsSelectorEntry     upd off)
+
+mkApInfoTableLabel :: Bool -> Int -> CLabel
+mkApEntryLabel     :: Bool -> Int -> CLabel
+mkApInfoTableLabel   upd off    = RtsLabel (RtsApInfoTable       upd off)
+mkApEntryLabel       upd off    = RtsLabel (RtsApEntry           upd off)
+
+
+-- A call to some primitive hand written Cmm code
+mkPrimCallLabel :: PrimCall -> CLabel
+mkPrimCallLabel (PrimCall str pkg)
+        = CmmLabel pkg str CmmPrimCall
+
+
+-- Constructing ForeignLabels
+
+-- | Make a foreign label
+mkForeignLabel
+        :: FastString           -- name
+        -> Maybe Int            -- size prefix
+        -> ForeignLabelSource   -- what package it's in
+        -> FunctionOrData
+        -> CLabel
+
+mkForeignLabel str mb_sz src fod
+    = ForeignLabel str mb_sz src  fod
+
+
+-- | Update the label size field in a ForeignLabel
+addLabelSize :: CLabel -> Int -> CLabel
+addLabelSize (ForeignLabel str _ src  fod) sz
+    = ForeignLabel str (Just sz) src fod
+addLabelSize label _
+    = label
+
+-- | Whether label is a top-level string literal
+isBytesLabel :: CLabel -> Bool
+isBytesLabel (IdLabel _ _ Bytes) = True
+isBytesLabel _lbl = False
+
+-- | Whether label is a non-haskell label (defined in C code)
+isForeignLabel :: CLabel -> Bool
+isForeignLabel (ForeignLabel _ _ _ _) = True
+isForeignLabel _lbl = False
+
+-- | Whether label is a static closure label (can come from haskell or cmm)
+isStaticClosureLabel :: CLabel -> Bool
+-- Closure defined in haskell (.hs)
+isStaticClosureLabel (IdLabel _ _ Closure) = True
+-- Closure defined in cmm
+isStaticClosureLabel (CmmLabel _ _ CmmClosure) = True
+isStaticClosureLabel _lbl = False
+
+-- | Whether label is a .rodata label
+isSomeRODataLabel :: CLabel -> Bool
+-- info table defined in haskell (.hs)
+isSomeRODataLabel (IdLabel _ _ ClosureTable) = True
+isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True
+isSomeRODataLabel (IdLabel _ _ InfoTable) = True
+isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True
+isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True
+-- info table defined in cmm (.cmm)
+isSomeRODataLabel (CmmLabel _ _ CmmInfo) = True
+isSomeRODataLabel _lbl = False
+
+-- | Whether label is points to some kind of info table
+isInfoTableLabel :: CLabel -> Bool
+isInfoTableLabel (IdLabel _ _ InfoTable)      = True
+isInfoTableLabel (IdLabel _ _ LocalInfoTable) = True
+isInfoTableLabel (IdLabel _ _ ConInfoTable)   = True
+isInfoTableLabel (IdLabel _ _ BlockInfoTable) = True
+isInfoTableLabel _                            = False
+
+-- | Whether label is points to constructor info table
+isConInfoTableLabel :: CLabel -> Bool
+isConInfoTableLabel (IdLabel _ _ ConInfoTable)   = True
+isConInfoTableLabel _                            = False
+
+-- | Get the label size field from a ForeignLabel
+foreignLabelStdcallInfo :: CLabel -> Maybe Int
+foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info
+foreignLabelStdcallInfo _lbl = Nothing
+
+
+-- Constructing Large*Labels
+mkBitmapLabel   :: Unique -> CLabel
+mkBitmapLabel   uniq            = LargeBitmapLabel uniq
+
+-- Constructing Cost Center Labels
+mkCCLabel  :: CostCentre      -> CLabel
+mkCCSLabel :: CostCentreStack -> CLabel
+mkCCLabel           cc          = CC_Label cc
+mkCCSLabel          ccs         = CCS_Label ccs
+
+mkRtsApFastLabel :: FastString -> CLabel
+mkRtsApFastLabel str = RtsLabel (RtsApFast str)
+
+mkRtsSlowFastTickyCtrLabel :: String -> CLabel
+mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat)
+
+
+-- Constructing Code Coverage Labels
+mkHpcTicksLabel :: Module -> CLabel
+mkHpcTicksLabel                = HpcTicksLabel
+
+
+-- Constructing labels used for dynamic linking
+mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel
+mkDynamicLinkerLabel            = DynamicLinkerLabel
+
+dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel)
+dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl)
+dynamicLinkerLabelInfo _        = Nothing
+
+mkPicBaseLabel :: CLabel
+mkPicBaseLabel                  = PicBaseLabel
+
+
+-- Constructing miscellaneous other labels
+mkDeadStripPreventer :: CLabel -> CLabel
+mkDeadStripPreventer lbl        = DeadStripPreventer lbl
+
+mkStringLitLabel :: Unique -> CLabel
+mkStringLitLabel                = StringLitLabel
+
+mkAsmTempLabel :: Uniquable a => a -> CLabel
+mkAsmTempLabel a                = AsmTempLabel (getUnique a)
+
+mkAsmTempDerivedLabel :: CLabel -> FastString -> CLabel
+mkAsmTempDerivedLabel = AsmTempDerivedLabel
+
+mkAsmTempEndLabel :: CLabel -> CLabel
+mkAsmTempEndLabel l = mkAsmTempDerivedLabel l (fsLit "_end")
+
+-- | Construct a label for a DWARF Debug Information Entity (DIE)
+-- describing another symbol.
+mkAsmTempDieLabel :: CLabel -> CLabel
+mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die")
+
+-- -----------------------------------------------------------------------------
+-- Convert between different kinds of label
+
+toClosureLbl :: CLabel -> CLabel
+toClosureLbl (IdLabel n c _) = IdLabel n c Closure
+toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure
+toClosureLbl l = pprPanic "toClosureLbl" (ppr l)
+
+toSlowEntryLbl :: CLabel -> CLabel
+toSlowEntryLbl (IdLabel n _ BlockInfoTable)
+  = pprPanic "toSlowEntryLbl" (ppr n)
+toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow
+toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l)
+
+toEntryLbl :: CLabel -> CLabel
+toEntryLbl (IdLabel n c LocalInfoTable)  = IdLabel n c LocalEntry
+toEntryLbl (IdLabel n c ConInfoTable)    = IdLabel n c ConEntry
+toEntryLbl (IdLabel n _ BlockInfoTable)  = mkLocalBlockLabel (nameUnique n)
+                              -- See Note [Proc-point local block entry-point].
+toEntryLbl (IdLabel n c _)               = IdLabel n c Entry
+toEntryLbl (CmmLabel m str CmmInfo)      = CmmLabel m str CmmEntry
+toEntryLbl (CmmLabel m str CmmRetInfo)   = CmmLabel m str CmmRet
+toEntryLbl l = pprPanic "toEntryLbl" (ppr l)
+
+toInfoLbl :: CLabel -> CLabel
+toInfoLbl (IdLabel n c LocalEntry)     = IdLabel n c LocalInfoTable
+toInfoLbl (IdLabel n c ConEntry)       = IdLabel n c ConInfoTable
+toInfoLbl (IdLabel n c _)              = IdLabel n c InfoTable
+toInfoLbl (CmmLabel m str CmmEntry)    = CmmLabel m str CmmInfo
+toInfoLbl (CmmLabel m str CmmRet)      = CmmLabel m str CmmRetInfo
+toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l)
+
+hasHaskellName :: CLabel -> Maybe Name
+hasHaskellName (IdLabel n _ _) = Just n
+hasHaskellName _               = Nothing
+
+-- -----------------------------------------------------------------------------
+-- Does a CLabel's referent itself refer to a CAF?
+hasCAF :: CLabel -> Bool
+hasCAF (IdLabel _ _ RednCounts) = False -- Note [ticky for LNE]
+hasCAF (IdLabel _ MayHaveCafRefs _) = True
+hasCAF _                            = False
+
+-- Note [ticky for LNE]
+-- ~~~~~~~~~~~~~~~~~~~~~
+
+-- Until 14 Feb 2013, every ticky counter was associated with a
+-- closure. Thus, ticky labels used IdLabel. It is odd that
+-- CmmBuildInfoTables.cafTransfers would consider such a ticky label
+-- reason to add the name to the CAFEnv (and thus eventually the SRT),
+-- but it was harmless because the ticky was only used if the closure
+-- was also.
+--
+-- Since we now have ticky counters for LNEs, it is no longer the case
+-- that every ticky counter has an actual closure. So I changed the
+-- generation of ticky counters' CLabels to not result in their
+-- associated id ending up in the SRT.
+--
+-- NB IdLabel is still appropriate for ticky ids (as opposed to
+-- CmmLabel) because the LNE's counter is still related to an .hs Id,
+-- that Id just isn't for a proper closure.
+
+-- -----------------------------------------------------------------------------
+-- Does a CLabel need declaring before use or not?
+--
+-- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
+
+needsCDecl :: CLabel -> Bool
+  -- False <=> it's pre-declared; don't bother
+  -- don't bother declaring Bitmap labels, we always make sure
+  -- they are defined before use.
+needsCDecl (SRTLabel _)                 = True
+needsCDecl (LargeBitmapLabel _)         = False
+needsCDecl (IdLabel _ _ _)              = True
+needsCDecl (LocalBlockLabel _)          = True
+
+needsCDecl (StringLitLabel _)           = False
+needsCDecl (AsmTempLabel _)             = False
+needsCDecl (AsmTempDerivedLabel _ _)    = False
+needsCDecl (RtsLabel _)                 = False
+
+needsCDecl (CmmLabel pkgId _ _)
+        -- Prototypes for labels defined in the runtime system are imported
+        --      into HC files via includes/Stg.h.
+        | pkgId == rtsUnitId         = False
+
+        -- For other labels we inline one into the HC file directly.
+        | otherwise                     = True
+
+needsCDecl l@(ForeignLabel{})           = not (isMathFun l)
+needsCDecl (CC_Label _)                 = True
+needsCDecl (CCS_Label _)                = True
+needsCDecl (HpcTicksLabel _)            = True
+needsCDecl (DynamicLinkerLabel {})      = panic "needsCDecl DynamicLinkerLabel"
+needsCDecl PicBaseLabel                 = panic "needsCDecl PicBaseLabel"
+needsCDecl (DeadStripPreventer {})      = panic "needsCDecl DeadStripPreventer"
+
+-- | If a label is a local block label then return just its 'BlockId', otherwise
+-- 'Nothing'.
+maybeLocalBlockLabel :: CLabel -> Maybe BlockId
+maybeLocalBlockLabel (LocalBlockLabel uq)  = Just $ mkBlockId uq
+maybeLocalBlockLabel _                     = Nothing
+
+
+-- | Check whether a label corresponds to a C function that has
+--      a prototype in a system header somehere, or is built-in
+--      to the C compiler. For these labels we avoid generating our
+--      own C prototypes.
+isMathFun :: CLabel -> Bool
+isMathFun (ForeignLabel fs _ _ _)       = fs `elementOfUniqSet` math_funs
+isMathFun _ = False
+
+math_funs :: UniqSet FastString
+math_funs = mkUniqSet [
+        -- _ISOC99_SOURCE
+        (fsLit "acos"),         (fsLit "acosf"),        (fsLit "acosh"),
+        (fsLit "acoshf"),       (fsLit "acoshl"),       (fsLit "acosl"),
+        (fsLit "asin"),         (fsLit "asinf"),        (fsLit "asinl"),
+        (fsLit "asinh"),        (fsLit "asinhf"),       (fsLit "asinhl"),
+        (fsLit "atan"),         (fsLit "atanf"),        (fsLit "atanl"),
+        (fsLit "atan2"),        (fsLit "atan2f"),       (fsLit "atan2l"),
+        (fsLit "atanh"),        (fsLit "atanhf"),       (fsLit "atanhl"),
+        (fsLit "cbrt"),         (fsLit "cbrtf"),        (fsLit "cbrtl"),
+        (fsLit "ceil"),         (fsLit "ceilf"),        (fsLit "ceill"),
+        (fsLit "copysign"),     (fsLit "copysignf"),    (fsLit "copysignl"),
+        (fsLit "cos"),          (fsLit "cosf"),         (fsLit "cosl"),
+        (fsLit "cosh"),         (fsLit "coshf"),        (fsLit "coshl"),
+        (fsLit "erf"),          (fsLit "erff"),         (fsLit "erfl"),
+        (fsLit "erfc"),         (fsLit "erfcf"),        (fsLit "erfcl"),
+        (fsLit "exp"),          (fsLit "expf"),         (fsLit "expl"),
+        (fsLit "exp2"),         (fsLit "exp2f"),        (fsLit "exp2l"),
+        (fsLit "expm1"),        (fsLit "expm1f"),       (fsLit "expm1l"),
+        (fsLit "fabs"),         (fsLit "fabsf"),        (fsLit "fabsl"),
+        (fsLit "fdim"),         (fsLit "fdimf"),        (fsLit "fdiml"),
+        (fsLit "floor"),        (fsLit "floorf"),       (fsLit "floorl"),
+        (fsLit "fma"),          (fsLit "fmaf"),         (fsLit "fmal"),
+        (fsLit "fmax"),         (fsLit "fmaxf"),        (fsLit "fmaxl"),
+        (fsLit "fmin"),         (fsLit "fminf"),        (fsLit "fminl"),
+        (fsLit "fmod"),         (fsLit "fmodf"),        (fsLit "fmodl"),
+        (fsLit "frexp"),        (fsLit "frexpf"),       (fsLit "frexpl"),
+        (fsLit "hypot"),        (fsLit "hypotf"),       (fsLit "hypotl"),
+        (fsLit "ilogb"),        (fsLit "ilogbf"),       (fsLit "ilogbl"),
+        (fsLit "ldexp"),        (fsLit "ldexpf"),       (fsLit "ldexpl"),
+        (fsLit "lgamma"),       (fsLit "lgammaf"),      (fsLit "lgammal"),
+        (fsLit "llrint"),       (fsLit "llrintf"),      (fsLit "llrintl"),
+        (fsLit "llround"),      (fsLit "llroundf"),     (fsLit "llroundl"),
+        (fsLit "log"),          (fsLit "logf"),         (fsLit "logl"),
+        (fsLit "log10l"),       (fsLit "log10"),        (fsLit "log10f"),
+        (fsLit "log1pl"),       (fsLit "log1p"),        (fsLit "log1pf"),
+        (fsLit "log2"),         (fsLit "log2f"),        (fsLit "log2l"),
+        (fsLit "logb"),         (fsLit "logbf"),        (fsLit "logbl"),
+        (fsLit "lrint"),        (fsLit "lrintf"),       (fsLit "lrintl"),
+        (fsLit "lround"),       (fsLit "lroundf"),      (fsLit "lroundl"),
+        (fsLit "modf"),         (fsLit "modff"),        (fsLit "modfl"),
+        (fsLit "nan"),          (fsLit "nanf"),         (fsLit "nanl"),
+        (fsLit "nearbyint"),    (fsLit "nearbyintf"),   (fsLit "nearbyintl"),
+        (fsLit "nextafter"),    (fsLit "nextafterf"),   (fsLit "nextafterl"),
+        (fsLit "nexttoward"),   (fsLit "nexttowardf"),  (fsLit "nexttowardl"),
+        (fsLit "pow"),          (fsLit "powf"),         (fsLit "powl"),
+        (fsLit "remainder"),    (fsLit "remainderf"),   (fsLit "remainderl"),
+        (fsLit "remquo"),       (fsLit "remquof"),      (fsLit "remquol"),
+        (fsLit "rint"),         (fsLit "rintf"),        (fsLit "rintl"),
+        (fsLit "round"),        (fsLit "roundf"),       (fsLit "roundl"),
+        (fsLit "scalbln"),      (fsLit "scalblnf"),     (fsLit "scalblnl"),
+        (fsLit "scalbn"),       (fsLit "scalbnf"),      (fsLit "scalbnl"),
+        (fsLit "sin"),          (fsLit "sinf"),         (fsLit "sinl"),
+        (fsLit "sinh"),         (fsLit "sinhf"),        (fsLit "sinhl"),
+        (fsLit "sqrt"),         (fsLit "sqrtf"),        (fsLit "sqrtl"),
+        (fsLit "tan"),          (fsLit "tanf"),         (fsLit "tanl"),
+        (fsLit "tanh"),         (fsLit "tanhf"),        (fsLit "tanhl"),
+        (fsLit "tgamma"),       (fsLit "tgammaf"),      (fsLit "tgammal"),
+        (fsLit "trunc"),        (fsLit "truncf"),       (fsLit "truncl"),
+        -- ISO C 99 also defines these function-like macros in math.h:
+        -- fpclassify, isfinite, isinf, isnormal, signbit, isgreater,
+        -- isgreaterequal, isless, islessequal, islessgreater, isunordered
+
+        -- additional symbols from _BSD_SOURCE
+        (fsLit "drem"),         (fsLit "dremf"),        (fsLit "dreml"),
+        (fsLit "finite"),       (fsLit "finitef"),      (fsLit "finitel"),
+        (fsLit "gamma"),        (fsLit "gammaf"),       (fsLit "gammal"),
+        (fsLit "isinf"),        (fsLit "isinff"),       (fsLit "isinfl"),
+        (fsLit "isnan"),        (fsLit "isnanf"),       (fsLit "isnanl"),
+        (fsLit "j0"),           (fsLit "j0f"),          (fsLit "j0l"),
+        (fsLit "j1"),           (fsLit "j1f"),          (fsLit "j1l"),
+        (fsLit "jn"),           (fsLit "jnf"),          (fsLit "jnl"),
+        (fsLit "lgamma_r"),     (fsLit "lgammaf_r"),    (fsLit "lgammal_r"),
+        (fsLit "scalb"),        (fsLit "scalbf"),       (fsLit "scalbl"),
+        (fsLit "significand"),  (fsLit "significandf"), (fsLit "significandl"),
+        (fsLit "y0"),           (fsLit "y0f"),          (fsLit "y0l"),
+        (fsLit "y1"),           (fsLit "y1f"),          (fsLit "y1l"),
+        (fsLit "yn"),           (fsLit "ynf"),          (fsLit "ynl"),
+
+        -- These functions are described in IEEE Std 754-2008 -
+        -- Standard for Floating-Point Arithmetic and ISO/IEC TS 18661
+        (fsLit "nextup"),       (fsLit "nextupf"),      (fsLit "nextupl"),
+        (fsLit "nextdown"),     (fsLit "nextdownf"),    (fsLit "nextdownl")
+    ]
+
+-- -----------------------------------------------------------------------------
+-- | Is a CLabel visible outside this object file or not?
+--      From the point of view of the code generator, a name is
+--      externally visible if it has to be declared as exported
+--      in the .o file's symbol table; that is, made non-static.
+externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
+externallyVisibleCLabel (StringLitLabel _)      = False
+externallyVisibleCLabel (AsmTempLabel _)        = False
+externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False
+externallyVisibleCLabel (RtsLabel _)            = True
+externallyVisibleCLabel (LocalBlockLabel _)     = False
+externallyVisibleCLabel (CmmLabel _ _ _)        = True
+externallyVisibleCLabel (ForeignLabel{})        = True
+externallyVisibleCLabel (IdLabel name _ info)   = isExternalName name && externallyVisibleIdLabel info
+externallyVisibleCLabel (CC_Label _)            = True
+externallyVisibleCLabel (CCS_Label _)           = True
+externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False
+externallyVisibleCLabel (HpcTicksLabel _)       = True
+externallyVisibleCLabel (LargeBitmapLabel _)    = False
+externallyVisibleCLabel (SRTLabel _)            = False
+externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"
+externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"
+
+externallyVisibleIdLabel :: IdLabelInfo -> Bool
+externallyVisibleIdLabel LocalInfoTable  = False
+externallyVisibleIdLabel LocalEntry      = False
+externallyVisibleIdLabel BlockInfoTable  = False
+externallyVisibleIdLabel _               = True
+
+-- -----------------------------------------------------------------------------
+-- Finding the "type" of a CLabel
+
+-- For generating correct types in label declarations:
+
+data CLabelType
+  = CodeLabel   -- Address of some executable instructions
+  | DataLabel   -- Address of data, not a GC ptr
+  | GcPtrLabel  -- Address of a (presumably static) GC object
+
+isCFunctionLabel :: CLabel -> Bool
+isCFunctionLabel lbl = case labelType lbl of
+                        CodeLabel -> True
+                        _other    -> False
+
+isGcPtrLabel :: CLabel -> Bool
+isGcPtrLabel lbl = case labelType lbl of
+                        GcPtrLabel -> True
+                        _other     -> False
+
+
+-- | Work out the general type of data at the address of this label
+--    whether it be code, data, or static GC object.
+labelType :: CLabel -> CLabelType
+labelType (IdLabel _ _ info)                    = idInfoLabelType info
+labelType (CmmLabel _ _ CmmData)                = DataLabel
+labelType (CmmLabel _ _ CmmClosure)             = GcPtrLabel
+labelType (CmmLabel _ _ CmmCode)                = CodeLabel
+labelType (CmmLabel _ _ CmmInfo)                = DataLabel
+labelType (CmmLabel _ _ CmmEntry)               = CodeLabel
+labelType (CmmLabel _ _ CmmPrimCall)            = CodeLabel
+labelType (CmmLabel _ _ CmmRetInfo)             = DataLabel
+labelType (CmmLabel _ _ CmmRet)                 = CodeLabel
+labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel
+labelType (RtsLabel (RtsApInfoTable _ _))       = DataLabel
+labelType (RtsLabel (RtsApFast _))              = CodeLabel
+labelType (RtsLabel _)                          = DataLabel
+labelType (LocalBlockLabel _)                   = CodeLabel
+labelType (SRTLabel _)                          = DataLabel
+labelType (ForeignLabel _ _ _ IsFunction)       = CodeLabel
+labelType (ForeignLabel _ _ _ IsData)           = DataLabel
+labelType (AsmTempLabel _)                      = panic "labelType(AsmTempLabel)"
+labelType (AsmTempDerivedLabel _ _)             = panic "labelType(AsmTempDerivedLabel)"
+labelType (StringLitLabel _)                    = DataLabel
+labelType (CC_Label _)                          = DataLabel
+labelType (CCS_Label _)                         = DataLabel
+labelType (DynamicLinkerLabel _ _)              = DataLabel -- Is this right?
+labelType PicBaseLabel                          = DataLabel
+labelType (DeadStripPreventer _)                = DataLabel
+labelType (HpcTicksLabel _)                     = DataLabel
+labelType (LargeBitmapLabel _)                  = DataLabel
+
+idInfoLabelType :: IdLabelInfo -> CLabelType
+idInfoLabelType info =
+  case info of
+    InfoTable     -> DataLabel
+    LocalInfoTable -> DataLabel
+    BlockInfoTable -> DataLabel
+    Closure       -> GcPtrLabel
+    ConInfoTable  -> DataLabel
+    ClosureTable  -> DataLabel
+    RednCounts    -> DataLabel
+    Bytes         -> DataLabel
+    _             -> CodeLabel
+
+
+-- -----------------------------------------------------------------------------
+
+-- | Is a 'CLabel' defined in the current module being compiled?
+--
+-- Sometimes we can optimise references within a compilation unit in ways that
+-- we couldn't for inter-module references. This provides a conservative
+-- estimate of whether a 'CLabel' lives in the current module.
+isLocalCLabel :: Module -> CLabel -> Bool
+isLocalCLabel this_mod lbl =
+  case lbl of
+    IdLabel name _ _
+      | isInternalName name -> True
+      | otherwise           -> nameModule name == this_mod
+    LocalBlockLabel _       -> True
+    _                       -> False
+
+-- -----------------------------------------------------------------------------
+
+-- | Does a 'CLabel' need dynamic linkage?
+--
+-- When referring to data in code, we need to know whether
+-- that data resides in a DLL or not. [Win32 only.]
+-- @labelDynamic@ returns @True@ if the label is located
+-- in a DLL, be it a data reference or not.
+labelDynamic :: DynFlags -> Module -> CLabel -> Bool
+labelDynamic dflags this_mod lbl =
+  case lbl of
+   -- is the RTS in a DLL or not?
+   RtsLabel _ ->
+     externalDynamicRefs && (this_pkg /= rtsUnitId)
+
+   IdLabel n _ _ ->
+     isDllName dflags this_mod n
+
+   -- When compiling in the "dyn" way, each package is to be linked into
+   -- its own shared library.
+   CmmLabel pkg _ _
+    | os == OSMinGW32 ->
+       externalDynamicRefs && (this_pkg /= pkg)
+    | otherwise ->
+       gopt Opt_ExternalDynamicRefs dflags
+
+   LocalBlockLabel _    -> False
+
+   ForeignLabel _ _ source _  ->
+       if os == OSMinGW32
+       then case source of
+            -- Foreign label is in some un-named foreign package (or DLL).
+            ForeignLabelInExternalPackage -> True
+
+            -- Foreign label is linked into the same package as the
+            -- source file currently being compiled.
+            ForeignLabelInThisPackage -> False
+
+            -- Foreign label is in some named package.
+            -- When compiling in the "dyn" way, each package is to be
+            -- linked into its own DLL.
+            ForeignLabelInPackage pkgId ->
+                externalDynamicRefs && (this_pkg /= pkgId)
+
+       else -- On Mac OS X and on ELF platforms, false positives are OK,
+            -- so we claim that all foreign imports come from dynamic
+            -- libraries
+            True
+
+   CC_Label cc ->
+     externalDynamicRefs && not (ccFromThisModule cc this_mod)
+
+   -- CCS_Label always contains a CostCentre defined in the current module
+   CCS_Label _ -> False
+
+   HpcTicksLabel m ->
+     externalDynamicRefs && this_mod /= m
+
+   -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
+   _                 -> False
+  where
+    externalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
+    os = platformOS (targetPlatform dflags)
+    this_pkg = moduleUnitId this_mod
+
+
+-----------------------------------------------------------------------------
+-- Printing out CLabels.
+
+{-
+Convention:
+
+      <name>_<type>
+
+where <name> is <Module>_<name> for external names and <unique> for
+internal names. <type> is one of the following:
+
+         info                   Info table
+         srt                    Static reference table
+         entry                  Entry code (function, closure)
+         slow                   Slow entry code (if any)
+         ret                    Direct return address
+         vtbl                   Vector table
+         <n>_alt                Case alternative (tag n)
+         dflt                   Default case alternative
+         btm                    Large bitmap vector
+         closure                Static closure
+         con_entry              Dynamic Constructor entry code
+         con_info               Dynamic Constructor info table
+         static_entry           Static Constructor entry code
+         static_info            Static Constructor info table
+         sel_info               Selector info table
+         sel_entry              Selector entry code
+         cc                     Cost centre
+         ccs                    Cost centre stack
+
+Many of these distinctions are only for documentation reasons.  For
+example, _ret is only distinguished from _entry to make it easy to
+tell whether a code fragment is a return point or a closure/function
+entry.
+
+Note [Closure and info labels]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For a function 'foo, we have:
+   foo_info    : Points to the info table describing foo's closure
+                 (and entry code for foo with tables next to code)
+   foo_closure : Static (no-free-var) closure only:
+                 points to the statically-allocated closure
+
+For a data constructor (such as Just or Nothing), we have:
+    Just_con_info: Info table for the data constructor itself
+                   the first word of a heap-allocated Just
+    Just_info:     Info table for the *worker function*, an
+                   ordinary Haskell function of arity 1 that
+                   allocates a (Just x) box:
+                      Just = \x -> Just x
+    Just_closure:  The closure for this worker
+
+    Nothing_closure: a statically allocated closure for Nothing
+    Nothing_static_info: info table for Nothing_closure
+
+All these must be exported symbol, EXCEPT Just_info.  We don't need to
+export this because in other modules we either have
+       * A reference to 'Just'; use Just_closure
+       * A saturated call 'Just x'; allocate using Just_con_info
+Not exporting these Just_info labels reduces the number of symbols
+somewhat.
+
+Note [Bytes label]
+~~~~~~~~~~~~~~~~~~
+For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which
+points to a static data block containing the content of the literal.
+
+Note [Proc-point local block entry-points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A label for a proc-point local block entry-point has no "_entry" suffix. With
+`infoTblLbl` we derive an info table label from a proc-point block ID. If
+we convert such an info table label into an entry label we must produce
+the label without an "_entry" suffix. So an info table label records
+the fact that it was derived from a block ID in `IdLabelInfo` as
+`BlockInfoTable`.
+
+The info table label and the local block label are both local labels
+and are not externally visible.
+-}
+
+instance Outputable CLabel where
+  ppr c = sdocWithPlatform $ \platform -> pprCLabel platform c
+
+pprCLabel :: Platform -> CLabel -> SDoc
+
+pprCLabel _ (LocalBlockLabel u)
+  =  tempLabelPrefixOrUnderscore <> pprUniqueAlways u
+
+pprCLabel platform (AsmTempLabel u)
+ | not (platformUnregisterised platform)
+  =  tempLabelPrefixOrUnderscore <> pprUniqueAlways u
+
+pprCLabel platform (AsmTempDerivedLabel l suf)
+ | cGhcWithNativeCodeGen == "YES"
+   = ptext (asmTempLabelPrefix platform)
+     <> case l of AsmTempLabel u    -> pprUniqueAlways u
+                  LocalBlockLabel u -> pprUniqueAlways u
+                  _other            -> pprCLabel platform l
+     <> ftext suf
+
+pprCLabel platform (DynamicLinkerLabel info lbl)
+ | cGhcWithNativeCodeGen == "YES"
+   = pprDynamicLinkerAsmLabel platform info lbl
+
+pprCLabel _ PicBaseLabel
+ | cGhcWithNativeCodeGen == "YES"
+   = text "1b"
+
+pprCLabel platform (DeadStripPreventer lbl)
+ | cGhcWithNativeCodeGen == "YES"
+   =
+   {-
+      `lbl` can be temp one but we need to ensure that dsp label will stay
+      in the final binary so we prepend non-temp prefix ("dsp_") and
+      optional `_` (underscore) because this is how you mark non-temp symbols
+      on some platforms (Darwin)
+   -}
+   maybe_underscore $ text "dsp_"
+   <> pprCLabel platform lbl <> text "_dsp"
+
+pprCLabel _ (StringLitLabel u)
+ | cGhcWithNativeCodeGen == "YES"
+  = pprUniqueAlways u <> ptext (sLit "_str")
+
+pprCLabel platform lbl
+   = getPprStyle $ \ sty ->
+     if cGhcWithNativeCodeGen == "YES" && asmStyle sty
+     then maybe_underscore (pprAsmCLbl platform lbl)
+     else pprCLbl lbl
+
+maybe_underscore :: SDoc -> SDoc
+maybe_underscore doc
+  | underscorePrefix = pp_cSEP <> doc
+  | otherwise        = doc
+
+pprAsmCLbl :: Platform -> CLabel -> SDoc
+pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _)
+ | platformOS platform == OSMinGW32
+    -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
+    -- (The C compiler does this itself).
+    = ftext fs <> char '@' <> int sz
+pprAsmCLbl _ lbl
+   = pprCLbl lbl
+
+pprCLbl :: CLabel -> SDoc
+pprCLbl (StringLitLabel u)
+  = pprUniqueAlways u <> text "_str"
+
+pprCLbl (SRTLabel u)
+  = tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"
+
+pprCLbl (LargeBitmapLabel u)  =
+  tempLabelPrefixOrUnderscore
+  <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"
+-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')
+-- until that gets resolved we'll just force them to start
+-- with a letter so the label will be legal assembly code.
+
+
+pprCLbl (CmmLabel _ str CmmCode)        = ftext str
+pprCLbl (CmmLabel _ str CmmData)        = ftext str
+pprCLbl (CmmLabel _ str CmmPrimCall)    = ftext str
+
+pprCLbl (LocalBlockLabel u)             =
+    tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u
+
+pprCLbl (RtsLabel (RtsApFast str))   = ftext str <> text "_fast"
+
+pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
+  = sdocWithDynFlags $ \dflags ->
+    ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)
+    hcat [text "stg_sel_", text (show offset),
+          ptext (if upd_reqd
+                 then (sLit "_upd_info")
+                 else (sLit "_noupd_info"))
+        ]
+
+pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
+  = sdocWithDynFlags $ \dflags ->
+    ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)
+    hcat [text "stg_sel_", text (show offset),
+                ptext (if upd_reqd
+                        then (sLit "_upd_entry")
+                        else (sLit "_noupd_entry"))
+        ]
+
+pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity))
+  = sdocWithDynFlags $ \dflags ->
+    ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)
+    hcat [text "stg_ap_", text (show arity),
+                ptext (if upd_reqd
+                        then (sLit "_upd_info")
+                        else (sLit "_noupd_info"))
+        ]
+
+pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
+  = sdocWithDynFlags $ \dflags ->
+    ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)
+    hcat [text "stg_ap_", text (show arity),
+                ptext (if upd_reqd
+                        then (sLit "_upd_entry")
+                        else (sLit "_noupd_entry"))
+        ]
+
+pprCLbl (CmmLabel _ fs CmmInfo)
+  = ftext fs <> text "_info"
+
+pprCLbl (CmmLabel _ fs CmmEntry)
+  = ftext fs <> text "_entry"
+
+pprCLbl (CmmLabel _ fs CmmRetInfo)
+  = ftext fs <> text "_info"
+
+pprCLbl (CmmLabel _ fs CmmRet)
+  = ftext fs <> text "_ret"
+
+pprCLbl (CmmLabel _ fs CmmClosure)
+  = ftext fs <> text "_closure"
+
+pprCLbl (RtsLabel (RtsPrimOp primop))
+  = text "stg_" <> ppr primop
+
+pprCLbl (RtsLabel (RtsSlowFastTickyCtr pat))
+  = text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")
+
+pprCLbl (ForeignLabel str _ _ _)
+  = ftext str
+
+pprCLbl (IdLabel name _cafs flavor) =
+  internalNamePrefix name <> ppr name <> ppIdFlavor flavor
+
+pprCLbl (CC_Label cc)           = ppr cc
+pprCLbl (CCS_Label ccs)         = ppr ccs
+
+pprCLbl (HpcTicksLabel mod)
+  = text "_hpc_tickboxes_"  <> ppr mod <> ptext (sLit "_hpc")
+
+pprCLbl (AsmTempLabel {})       = panic "pprCLbl AsmTempLabel"
+pprCLbl (AsmTempDerivedLabel {})= panic "pprCLbl AsmTempDerivedLabel"
+pprCLbl (DynamicLinkerLabel {}) = panic "pprCLbl DynamicLinkerLabel"
+pprCLbl (PicBaseLabel {})       = panic "pprCLbl PicBaseLabel"
+pprCLbl (DeadStripPreventer {}) = panic "pprCLbl DeadStripPreventer"
+
+ppIdFlavor :: IdLabelInfo -> SDoc
+ppIdFlavor x = pp_cSEP <> text
+               (case x of
+                       Closure          -> "closure"
+                       InfoTable        -> "info"
+                       LocalInfoTable   -> "info"
+                       Entry            -> "entry"
+                       LocalEntry       -> "entry"
+                       Slow             -> "slow"
+                       RednCounts       -> "ct"
+                       ConEntry         -> "con_entry"
+                       ConInfoTable     -> "con_info"
+                       ClosureTable     -> "closure_tbl"
+                       Bytes            -> "bytes"
+                       BlockInfoTable   -> "info"
+                      )
+
+
+pp_cSEP :: SDoc
+pp_cSEP = char '_'
+
+
+instance Outputable ForeignLabelSource where
+ ppr fs
+  = case fs of
+        ForeignLabelInPackage pkgId     -> parens $ text "package: " <> ppr pkgId
+        ForeignLabelInThisPackage       -> parens $ text "this package"
+        ForeignLabelInExternalPackage   -> parens $ text "external package"
+
+internalNamePrefix :: Name -> SDoc
+internalNamePrefix name = getPprStyle $ \ sty ->
+  if asmStyle sty && isRandomGenerated then
+    sdocWithPlatform $ \platform ->
+      ptext (asmTempLabelPrefix platform)
+  else
+    empty
+  where
+    isRandomGenerated = not $ isExternalName name
+
+tempLabelPrefixOrUnderscore :: SDoc
+tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform ->
+  getPprStyle $ \ sty ->
+   if asmStyle sty then
+      ptext (asmTempLabelPrefix platform)
+   else
+      char '_'
+
+-- -----------------------------------------------------------------------------
+-- Machine-dependent knowledge about labels.
+
+underscorePrefix :: Bool   -- leading underscore on assembler labels?
+underscorePrefix = (cLeadingUnderscore == "YES")
+
+asmTempLabelPrefix :: Platform -> PtrString  -- for formatting labels
+asmTempLabelPrefix platform = case platformOS platform of
+    OSDarwin -> sLit "L"
+    OSAIX    -> sLit "__L" -- follow IBM XL C's convention
+    _        -> sLit ".L"
+
+pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc
+pprDynamicLinkerAsmLabel platform dllInfo lbl =
+    case platformOS platform of
+      OSDarwin
+        | platformArch platform == ArchX86_64 ->
+          case dllInfo of
+            CodeStub        -> char 'L' <> ppr lbl <> text "$stub"
+            SymbolPtr       -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"
+            GotSymbolPtr    -> ppr lbl <> text "@GOTPCREL"
+            GotSymbolOffset -> ppr lbl
+        | otherwise ->
+          case dllInfo of
+            CodeStub  -> char 'L' <> ppr lbl <> text "$stub"
+            SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"
+            _         -> panic "pprDynamicLinkerAsmLabel"
+
+      OSAIX ->
+          case dllInfo of
+            SymbolPtr -> text "LC.." <> ppr lbl -- GCC's naming convention
+            _         -> panic "pprDynamicLinkerAsmLabel"
+
+      _ | osElfTarget (platformOS platform) -> elfLabel
+
+      OSMinGW32 ->
+          case dllInfo of
+            SymbolPtr -> text "__imp_" <> ppr lbl
+            _         -> panic "pprDynamicLinkerAsmLabel"
+
+      _ -> panic "pprDynamicLinkerAsmLabel"
+  where
+    elfLabel
+      | platformArch platform == ArchPPC
+      = case dllInfo of
+          CodeStub  -> -- See Note [.LCTOC1 in PPC PIC code]
+                       ppr lbl <> text "+32768@plt"
+          SymbolPtr -> text ".LC_" <> ppr lbl
+          _         -> panic "pprDynamicLinkerAsmLabel"
+
+      | platformArch platform == ArchX86_64
+      = case dllInfo of
+          CodeStub        -> ppr lbl <> text "@plt"
+          GotSymbolPtr    -> ppr lbl <> text "@gotpcrel"
+          GotSymbolOffset -> ppr lbl
+          SymbolPtr       -> text ".LC_" <> ppr lbl
+
+      | platformArch platform == ArchPPC_64 ELF_V1
+        || platformArch platform == ArchPPC_64 ELF_V2
+      = case dllInfo of
+          GotSymbolPtr    -> text ".LC_"  <> ppr lbl
+                                  <> text "@toc"
+          GotSymbolOffset -> ppr lbl
+          SymbolPtr       -> text ".LC_" <> ppr lbl
+          _               -> panic "pprDynamicLinkerAsmLabel"
+
+      | otherwise
+      = case dllInfo of
+          CodeStub        -> ppr lbl <> text "@plt"
+          SymbolPtr       -> text ".LC_" <> ppr lbl
+          GotSymbolPtr    -> ppr lbl <> text "@got"
+          GotSymbolOffset -> ppr lbl <> text "@gotoff"
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Cmm.hs
@@ -0,0 +1,230 @@
+-- Cmm representations using Hoopl's Graph CmmNode e x.
+{-# LANGUAGE GADTs #-}
+
+module Cmm (
+     -- * Cmm top-level datatypes
+     CmmProgram, CmmGroup, GenCmmGroup,
+     CmmDecl, GenCmmDecl(..),
+     CmmGraph, GenCmmGraph(..),
+     CmmBlock,
+     RawCmmDecl, RawCmmGroup,
+     Section(..), SectionType(..), CmmStatics(..), CmmStatic(..),
+     isSecConstant,
+
+     -- ** Blocks containing lists
+     GenBasicBlock(..), blockId,
+     ListGraph(..), pprBBlock,
+
+     -- * Info Tables
+     CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,
+     ClosureTypeInfo(..),
+     ProfilingInfo(..), ConstrDescription,
+
+     -- * Statements, expressions and types
+     module CmmNode,
+     module CmmExpr,
+  ) where
+
+import GhcPrelude
+
+import Id
+import CostCentre
+import CLabel
+import BlockId
+import CmmNode
+import SMRep
+import CmmExpr
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
+import Outputable
+
+import Data.Word        ( Word8 )
+
+-----------------------------------------------------------------------------
+--  Cmm, GenCmm
+-----------------------------------------------------------------------------
+
+-- A CmmProgram is a list of CmmGroups
+-- A CmmGroup is a list of top-level declarations
+
+-- When object-splitting is on, each group is compiled into a separate
+-- .o file. So typically we put closely related stuff in a CmmGroup.
+-- Section-splitting follows suit and makes one .text subsection for each
+-- CmmGroup.
+
+type CmmProgram = [CmmGroup]
+
+type GenCmmGroup d h g = [GenCmmDecl d h g]
+type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
+type RawCmmGroup = GenCmmGroup CmmStatics (LabelMap CmmStatics) CmmGraph
+
+-----------------------------------------------------------------------------
+--  CmmDecl, GenCmmDecl
+-----------------------------------------------------------------------------
+
+-- GenCmmDecl is abstracted over
+--   d, the type of static data elements in CmmData
+--   h, the static info preceding the code of a CmmProc
+--   g, the control-flow graph of a CmmProc
+--
+-- We expect there to be two main instances of this type:
+--   (a) C--, i.e. populated with various C-- constructs
+--   (b) Native code, populated with data/instructions
+
+-- | A top-level chunk, abstracted over the type of the contents of
+-- the basic blocks (Cmm or instructions are the likely instantiations).
+data GenCmmDecl d h g
+  = CmmProc     -- A procedure
+     h                 -- Extra header such as the info table
+     CLabel            -- Entry label
+     [GlobalReg]       -- Registers live on entry. Note that the set of live
+                       -- registers will be correct in generated C-- code, but
+                       -- not in hand-written C-- code. However,
+                       -- splitAtProcPoints calculates correct liveness
+                       -- information for CmmProcs.
+     g                 -- Control-flow graph for the procedure's code
+
+  | CmmData     -- Static data
+        Section
+        d
+
+type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph
+
+type RawCmmDecl
+   = GenCmmDecl
+        CmmStatics
+        (LabelMap CmmStatics)
+        CmmGraph
+
+-----------------------------------------------------------------------------
+--     Graphs
+-----------------------------------------------------------------------------
+
+type CmmGraph = GenCmmGraph CmmNode
+data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
+type CmmBlock = Block CmmNode C C
+
+-----------------------------------------------------------------------------
+--     Info Tables
+-----------------------------------------------------------------------------
+
+data CmmTopInfo   = TopInfo { info_tbls  :: LabelMap CmmInfoTable
+                            , stack_info :: CmmStackInfo }
+
+topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
+topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)
+topInfoTable _                     = Nothing
+
+data CmmStackInfo
+   = StackInfo {
+       arg_space :: ByteOff,
+               -- number of bytes of arguments on the stack on entry to the
+               -- the proc.  This is filled in by StgCmm.codeGen, and used
+               -- by the stack allocator later.
+       updfr_space :: Maybe ByteOff,
+               -- XXX: this never contains anything useful, but it should.
+               -- See comment in CmmLayoutStack.
+       do_layout :: Bool
+               -- Do automatic stack layout for this proc.  This is
+               -- True for all code generated by the code generator,
+               -- but is occasionally False for hand-written Cmm where
+               -- we want to do the stack manipulation manually.
+  }
+
+-- | Info table as a haskell data type
+data CmmInfoTable
+  = CmmInfoTable {
+      cit_lbl  :: CLabel, -- Info table label
+      cit_rep  :: SMRep,
+      cit_prof :: ProfilingInfo,
+      cit_srt  :: Maybe CLabel,   -- empty, or a closure address
+      cit_clo  :: Maybe (Id, CostCentreStack)
+        -- Just (id,ccs) <=> build a static closure later
+        -- Nothing <=> don't build a static closure
+        --
+        -- Static closures for FUNs and THUNKs are *not* generated by
+        -- the code generator, because we might want to add SRT
+        -- entries to them later (for FUNs at least; THUNKs are
+        -- treated the same for consistency). See Note [SRTs] in
+        -- CmmBuildInfoTables, in particular the [FUN] optimisation.
+        --
+        -- This is strictly speaking not a part of the info table that
+        -- will be finally generated, but it's the only convenient
+        -- place to convey this information from the code generator to
+        -- where we build the static closures in
+        -- CmmBuildInfoTables.doSRTs.
+    }
+
+data ProfilingInfo
+  = NoProfilingInfo
+  | ProfilingInfo [Word8] [Word8] -- closure_type, closure_desc
+
+-----------------------------------------------------------------------------
+--              Static Data
+-----------------------------------------------------------------------------
+
+data SectionType
+  = Text
+  | Data
+  | ReadOnlyData
+  | RelocatableReadOnlyData
+  | UninitialisedData
+  | ReadOnlyData16      -- .rodata.cst16 on x86_64, 16-byte aligned
+  | CString
+  | OtherSection String
+  deriving (Show)
+
+-- | Should a data in this section be considered constant
+isSecConstant :: Section -> Bool
+isSecConstant (Section t _) = case t of
+    Text                    -> True
+    ReadOnlyData            -> True
+    RelocatableReadOnlyData -> True
+    ReadOnlyData16          -> True
+    CString                 -> True
+    Data                    -> False
+    UninitialisedData       -> False
+    (OtherSection _)        -> False
+
+data Section = Section SectionType CLabel
+
+data CmmStatic
+  = CmmStaticLit CmmLit
+        -- a literal value, size given by cmmLitRep of the literal.
+  | CmmUninitialised Int
+        -- uninitialised data, N bytes long
+  | CmmString [Word8]
+        -- string of 8-bit values only, not zero terminated.
+
+data CmmStatics
+   = Statics
+       CLabel      -- Label of statics
+       [CmmStatic] -- The static data itself
+
+-- -----------------------------------------------------------------------------
+-- Basic blocks consisting of lists
+
+-- These are used by the LLVM and NCG backends, when populating Cmm
+-- with lists of instructions.
+
+data GenBasicBlock i = BasicBlock BlockId [i]
+
+-- | The branch block id is that of the first block in
+-- the branch, which is that branch's entry point
+blockId :: GenBasicBlock i -> BlockId
+blockId (BasicBlock blk_id _ ) = blk_id
+
+newtype ListGraph i = ListGraph [GenBasicBlock i]
+
+instance Outputable instr => Outputable (ListGraph instr) where
+    ppr (ListGraph blocks) = vcat (map ppr blocks)
+
+instance Outputable instr => Outputable (GenBasicBlock instr) where
+    ppr = pprBBlock
+
+pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
+pprBBlock (BasicBlock ident stmts) =
+    hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
+
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -0,0 +1,896 @@
+{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
+    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections #-}
+
+module CmmBuildInfoTables
+  ( CAFSet, CAFEnv, cafAnal
+  , doSRTs, ModuleSRTInfo, emptySRT
+  ) where
+
+import GhcPrelude hiding (succ)
+
+import Id
+import BlockId
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Label
+import Hoopl.Collections
+import Hoopl.Dataflow
+import Module
+import Platform
+import Digraph
+import CLabel
+import PprCmmDecl ()
+import Cmm
+import CmmUtils
+import DynFlags
+import Maybes
+import Outputable
+import SMRep
+import UniqSupply
+import CostCentre
+import StgCmmHeap
+
+import PprCmm()
+import Control.Monad
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Tuple
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Class
+
+
+{- Note [SRTs]
+
+SRTs are the mechanism by which the garbage collector can determine
+the live CAFs in the program.
+
+Representation
+^^^^^^^^^^^^^^
+
++------+
+| info |
+|      |     +-----+---+---+---+
+|   -------->|SRT_2| | | | | 0 |
+|------|     +-----+-|-+-|-+---+
+|      |             |   |
+| code |             |   |
+|      |             v   v
+
+An SRT is simply an object in the program's data segment. It has the
+same representation as a static constructor.  There are 16
+pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info,
+representing SRT objects with 1-16 pointers, respectively.
+
+The entries of an SRT object point to static closures, which are either
+- FUN_STATIC, THUNK_STATIC or CONSTR
+- Another SRT (actually just a CONSTR)
+
+The final field of the SRT is the static link field, used by the
+garbage collector to chain together static closures that it visits and
+to determine whether a static closure has been visited or not. (see
+Note [STATIC_LINK fields])
+
+By traversing the transitive closure of an SRT, the GC will reach all
+of the CAFs that are reachable from the code associated with this SRT.
+
+If we need to create an SRT with more than 16 entries, we build a
+chain of SRT objects with all but the last having 16 entries.
+
++-----+---+- -+---+---+
+|SRT16| | |   | | | 0 |
++-----+-|-+- -+-|-+---+
+        |       |
+        v       v
+              +----+---+---+---+
+              |SRT2| | | | | 0 |
+              +----+-|-+-|-+---+
+                     |   |
+                     |   |
+                     v   v
+
+Referring to an SRT from the info table
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+The following things have SRTs:
+
+- Static functions (FUN)
+- Static thunks (THUNK), ie. CAFs
+- Continuations (RET_SMALL, etc.)
+
+In each case, the info table points to the SRT.
+
+- info->srt is zero if there's no SRT, otherwise:
+- info->srt == 1 and info->f.srt_offset points to the SRT
+
+e.g. for a FUN with an SRT:
+
+StgFunInfoTable       +------+
+  info->f.srt_offset  |  ------------> offset to SRT object
+StgStdInfoTable       +------+
+  info->layout.ptrs   | ...  |
+  info->layout.nptrs  | ...  |
+  info->srt           |  1   |
+  info->type          | ...  |
+                      |------|
+
+On x86_64, we optimise the info table representation further.  The
+offset to the SRT can be stored in 32 bits (all code lives within a
+2GB region in x86_64's small memory model), so we can save a word in
+the info table by storing the srt_offset in the srt field, which is
+half a word.
+
+On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):
+
+- info->srt is zero if there's no SRT, otherwise:
+- info->srt is an offset from the info pointer to the SRT object
+
+StgStdInfoTable       +------+
+  info->layout.ptrs   |      |
+  info->layout.nptrs  |      |
+  info->srt           |  ------------> offset to SRT object
+                      |------|
+
+
+EXAMPLE
+^^^^^^^
+
+f = \x. ... g ...
+  where
+    g = \y. ... h ... c1 ...
+    h = \z. ... c2 ...
+
+c1 & c2 are CAFs
+
+g and h are local functions, but they have no static closures.  When
+we generate code for f, we start with a CmmGroup of four CmmDecls:
+
+   [ f_closure, f_entry, g_entry, h_entry ]
+
+we process each CmmDecl separately in cpsTop, giving us a list of
+CmmDecls. e.g. for f_entry, we might end up with
+
+   [ f_entry, f1_ret, f2_proc ]
+
+where f1_ret is a return point, and f2_proc is a proc-point.  We have
+a CAFSet for each of these CmmDecls, let's suppose they are
+
+   [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ]
+   [ g_entry{h_info, c1_closure} ]
+   [ h_entry{c2_closure} ]
+
+Next, we make an SRT for each of these functions:
+
+  f_srt : [g_info]
+  g_srt : [h_info, c1_closure]
+  h_srt : [c2_closure]
+
+Now, for g_info and h_info, we want to refer to the SRTs for g and h
+respectively, which we'll label g_srt and h_srt:
+
+  f_srt : [g_srt]
+  g_srt : [h_srt, c1_closure]
+  h_srt : [c2_closure]
+
+Now, when an SRT has a single entry, we don't actually generate an SRT
+closure for it, instead we just replace references to it with its
+single element.  So, since h_srt == c2_closure, we have
+
+  f_srt : [g_srt]
+  g_srt : [c2_closure, c1_closure]
+  h_srt : [c2_closure]
+
+and the only SRT closure we generate is
+
+  g_srt = SRT_2 [c2_closure, c1_closure]
+
+
+Optimisations
+^^^^^^^^^^^^^
+
+To reduce the code size overhead and the cost of traversing SRTs in
+the GC, we want to simplify SRTs where possible. We therefore apply
+the following optimisations.  Each has a [keyword]; search for the
+keyword in the code below to see where the optimisation is
+implemented.
+
+1. [Inline] we never create an SRT with a single entry, instead we
+   point to the single entry directly from the info table.
+
+   i.e. instead of
+
+    +------+
+    | info |
+    |      |     +-----+---+---+
+    |   -------->|SRT_1| | | 0 |
+    |------|     +-----+-|-+---+
+    |      |             |
+    | code |             |
+    |      |             v
+                         C
+
+   we can point directly to the closure:
+
+    +------+
+    | info |
+    |      |
+    |   -------->C
+    |------|
+    |      |
+    | code |
+    |      |
+
+
+   Furthermore, the SRT for any code that refers to this info table
+   can point directly to C.
+
+   The exception to this is when we're doing dynamic linking. In that
+   case, if the closure is not locally defined then we can't point to
+   it directly from the info table, because this is the text section
+   which cannot contain runtime relocations. In this case we skip this
+   optimisation and generate the singleton SRT, becase SRTs are in the
+   data section and *can* have relocatable references.
+
+2. [FUN] A static function closure can also be an SRT, we simply put
+   the SRT entries as fields in the static closure.  This makes a lot
+   of sense: the static references are just like the free variables of
+   the FUN closure.
+
+   i.e. instead of
+
+   f_closure:
+   +-----+---+
+   |  |  | 0 |
+   +- |--+---+
+      |            +------+
+      |            | info |     f_srt:
+      |            |      |     +-----+---+---+---+
+      |            |   -------->|SRT_2| | | | + 0 |
+      `----------->|------|     +-----+-|-+-|-+---+
+                   |      |             |   |
+                   | code |             |   |
+                   |      |             v   v
+
+
+   We can generate:
+
+   f_closure:
+   +-----+---+---+---+
+   |  |  | | | | | 0 |
+   +- |--+-|-+-|-+---+
+      |    |   |   +------+
+      |    v   v   | info |
+      |            |      |
+      |            |   0  |
+      `----------->|------|
+                   |      |
+                   | code |
+                   |      |
+
+
+   (note: we can't do this for THUNKs, because the thunk gets
+   overwritten when it is entered, so we wouldn't be able to share
+   this SRT with other info tables that want to refer to it (see
+   [Common] below). FUNs are immutable so don't have this problem.)
+
+3. [Common] Identical SRTs can be commoned up.
+
+4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also
+   refers to C (perhaps transitively), then we can omit the reference
+   to C from A.
+
+
+Note that there are many other optimisations that we could do, but
+aren't implemented. In general, we could omit any reference from an
+SRT if everything reachable from it is also reachable from the other
+fields in the SRT. Our [Filter] optimisation is a special case of
+this.
+
+Another opportunity we don't exploit is this:
+
+A = {X,Y,Z}
+B = {Y,Z}
+C = {X,B}
+
+Here we could use C = {A} and therefore [Inline] C = A.
+-}
+
+-- ---------------------------------------------------------------------
+{- Note [Invalid optimisation: shortcutting]
+
+You might think that if we have something like
+
+A's SRT = {B}
+B's SRT = {X}
+
+that we could replace the reference to B in A's SRT with X.
+
+A's SRT = {X}
+B's SRT = {X}
+
+and thereby perhaps save a little work at runtime, because we don't
+have to visit B.
+
+But this is NOT valid.
+
+Consider these cases:
+
+0. B can't be a constructor, because constructors don't have SRTs
+
+1. B is a CAF. This is the easy one. Obviously we want A's SRT to
+   point to B, so that it keeps B alive.
+
+2. B is a function.  This is the tricky one. The reason we can't
+shortcut in this case is that we aren't allowed to resurrect static
+objects.
+
+== How does this cause a problem? ==
+
+The particular case that cropped up when we tried this was #15544.
+- A is a thunk
+- B is a static function
+- X is a CAF
+- suppose we GC when A is alive, and B is not otherwise reachable.
+- B is "collected", meaning that it doesn't make it onto the static
+  objects list during this GC, but nothing bad happens yet.
+- Next, suppose we enter A, and then call B. (remember that A refers to B)
+  At the entry point to B, we GC. This puts B on the stack, as part of the
+  RET_FUN stack frame that gets pushed when we GC at a function entry point.
+- This GC will now reach B
+- But because B was previous "collected", it breaks the assumption
+  that static objects are never resurrected. See Note [STATIC_LINK
+  fields] in rts/sm/Storage.h for why this is bad.
+- In practice, the GC thinks that B has already been visited, and so
+  doesn't visit X, and catastrophe ensues.
+
+== Isn't this caused by the RET_FUN business? ==
+
+Maybe, but could you prove that RET_FUN is the only way that
+resurrection can occur?
+
+So, no shortcutting.
+-}
+
+-- ---------------------------------------------------------------------
+-- Label types
+
+-- Labels that come from cafAnal can be:
+--   - _closure labels for static functions or CAFs
+--   - _info labels for dynamic functions, thunks, or continuations
+--   - _entry labels for functions or thunks
+--
+-- Meanwhile the labels on top-level blocks are _entry labels.
+--
+-- To put everything in the same namespace we convert all labels to
+-- closure labels using toClosureLbl.  Note that some of these
+-- labels will not actually exist; that's ok because we're going to
+-- map them to SRTEntry later, which ranges over labels that do exist.
+--
+newtype CAFLabel = CAFLabel CLabel
+  deriving (Eq,Ord,Outputable)
+
+type CAFSet = Set CAFLabel
+type CAFEnv = LabelMap CAFSet
+
+mkCAFLabel :: CLabel -> CAFLabel
+mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)
+
+-- This is a label that we can put in an SRT.  It *must* be a closure label,
+-- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.
+newtype SRTEntry = SRTEntry CLabel
+  deriving (Eq, Ord, Outputable)
+
+-- ---------------------------------------------------------------------
+-- CAF analysis
+
+-- |
+-- For each code block:
+--   - collect the references reachable from this code block to FUN,
+--     THUNK or RET labels for which hasCAF == True
+--
+-- This gives us a `CAFEnv`: a mapping from code block to sets of labels
+--
+cafAnal
+  :: LabelSet   -- The blocks representing continuations, ie. those
+                -- that will get RET info tables.  These labels will
+                -- get their own SRTs, so we don't aggregate CAFs from
+                -- references to these labels, we just use the label.
+  -> CLabel     -- The top label of the proc
+  -> CmmGraph
+  -> CAFEnv
+cafAnal contLbls topLbl cmmGraph =
+  analyzeCmmBwd cafLattice
+    (cafTransfers contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty
+
+
+cafLattice :: DataflowLattice CAFSet
+cafLattice = DataflowLattice Set.empty add
+  where
+    add (OldFact old) (NewFact new) =
+        let !new' = old `Set.union` new
+        in changedIf (Set.size new' > Set.size old) new'
+
+
+cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet
+cafTransfers contLbls entry topLbl
+  (BlockCC eNode middle xNode) fBase =
+    let joined = cafsInNode xNode $! live'
+        !result = foldNodesBwdOO cafsInNode middle joined
+
+        facts = mapMaybe successorFact (successors xNode)
+        live' = joinFacts cafLattice facts
+
+        successorFact s
+          -- If this is a loop back to the entry, we can refer to the
+          -- entry label.
+          | s == entry = Just (add topLbl Set.empty)
+          -- If this is a continuation, we want to refer to the
+          -- SRT for the continuation's info table
+          | s `setMember` contLbls
+          = Just (Set.singleton (mkCAFLabel (infoTblLbl s)))
+          -- Otherwise, takes the CAF references from the destination
+          | otherwise
+          = lookupFact s fBase
+
+        cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
+        cafsInNode node set = foldExpDeep addCaf node set
+
+        addCaf expr !set =
+          case expr of
+              CmmLit (CmmLabel c) -> add c set
+              CmmLit (CmmLabelOff c _) -> add c set
+              CmmLit (CmmLabelDiffOff c1 c2 _ _) -> add c1 $! add c2 set
+              _ -> set
+        add l s | hasCAF l  = Set.insert (mkCAFLabel l) s
+                | otherwise = s
+
+    in mapSingleton (entryLabel eNode) result
+
+
+-- -----------------------------------------------------------------------------
+-- ModuleSRTInfo
+
+data ModuleSRTInfo = ModuleSRTInfo
+  { thisModule :: Module
+    -- ^ Current module being compiled. Required for calling labelDynamic.
+  , dedupSRTs :: Map (Set SRTEntry) SRTEntry
+    -- ^ previous SRTs we've emitted, so we can de-duplicate.
+    -- Used to implement the [Common] optimisation.
+  , flatSRTs :: Map SRTEntry (Set SRTEntry)
+    -- ^ The reverse mapping, so that we can remove redundant
+    -- entries. e.g.  if we have an SRT [a,b,c], and we know that b
+    -- points to [c,d], we can omit c and emit [a,b].
+    -- Used to implement the [Filter] optimisation.
+  }
+instance Outputable ModuleSRTInfo where
+  ppr ModuleSRTInfo{..} =
+    text "ModuleSRTInfo:" <+> ppr dedupSRTs <+> ppr flatSRTs
+
+emptySRT :: Module -> ModuleSRTInfo
+emptySRT mod =
+  ModuleSRTInfo
+    { thisModule = mod
+    , dedupSRTs = Map.empty
+    , flatSRTs = Map.empty }
+
+-- -----------------------------------------------------------------------------
+-- Constructing SRTs
+
+{- Implementation notes
+
+- In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable
+
+- The entry in info_tbls corresponding to g_entry is the closure info
+  table, the rest are continuations.
+
+- Each entry in info_tbls possibly needs an SRT.  We need to make a
+  label for each of these.
+
+- We get the CAFSet for each entry from the CAFEnv
+
+-}
+
+-- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,
+--   where the label is
+--   - the info label for a continuation or dynamic closure
+--   - the closure label for a top-level function (not a CAF)
+getLabelledBlocks :: CmmDecl -> [(Label, CAFLabel)]
+getLabelledBlocks (CmmData _ _) = []
+getLabelledBlocks (CmmProc top_info _ _ _) =
+  [ (blockId, mkCAFLabel (cit_lbl info))
+  | (blockId, info) <- mapToList (info_tbls top_info)
+  , let rep = cit_rep info
+  , not (isStaticRep rep) || not (isThunkRep rep)
+  ]
+
+
+-- | Put the labelled blocks that we will be annotating with SRTs into
+-- dependency order.  This is so that we can process them one at a
+-- time, resolving references to earlier blocks to point to their
+-- SRTs. CAFs themselves are not included here; see getCAFs below.
+depAnalSRTs
+  :: CAFEnv
+  -> [CmmDecl]
+  -> [SCC (Label, CAFLabel, Set CAFLabel)]
+depAnalSRTs cafEnv decls =
+  srtTrace "depAnalSRTs" (ppr graph) graph
+ where
+  labelledBlocks = concatMap getLabelledBlocks decls
+  labelToBlock = Map.fromList (map swap labelledBlocks)
+  graph = stronglyConnCompFromEdgedVerticesOrd
+             [ let cafs' = Set.delete lbl cafs in
+               DigraphNode (l,lbl,cafs') l
+                 (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))
+             | (l, lbl) <- labelledBlocks
+             , Just cafs <- [mapLookup l cafEnv] ]
+
+
+-- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.
+-- These are treated differently from other labelled blocks:
+--  - we never shortcut a reference to a CAF to the contents of its
+--    SRT, since the point of SRTs is to keep CAFs alive.
+--  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
+--    instead we generate their SRTs after everything else.
+getCAFs :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]
+getCAFs cafEnv decls =
+  [ (g_entry g, mkCAFLabel topLbl, cafs)
+  | CmmProc top_info topLbl _ g <- decls
+  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
+  , let rep = cit_rep info
+  , isStaticRep rep && isThunkRep rep
+  , Just cafs <- [mapLookup (g_entry g) cafEnv]
+  ]
+
+
+-- | Get the list of blocks that correspond to the entry points for
+-- FUN_STATIC closures.  These are the blocks for which if we have an
+-- SRT we can merge it with the static closure. [FUN]
+getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)]
+getStaticFuns decls =
+  [ (g_entry g, lbl)
+  | CmmProc top_info _ _ g <- decls
+  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
+  , Just (id, _) <- [cit_clo info]
+  , let rep = cit_rep info
+  , isStaticRep rep && isFunRep rep
+  , let lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
+  ]
+
+
+-- | Maps labels from 'cafAnal' to the final CLabel that will appear
+-- in the SRT.
+--   - closures with singleton SRTs resolve to their single entry
+--   - closures with larger SRTs map to the label for that SRT
+--   - CAFs must not map to anything!
+--   - if a labels maps to Nothing, we found that this label's SRT
+--     is empty, so we don't need to refer to it from other SRTs.
+type SRTMap = Map CAFLabel (Maybe SRTEntry)
+
+-- | resolve a CAFLabel to its SRTEntry using the SRTMap
+resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry
+resolveCAF srtMap lbl@(CAFLabel l) =
+  Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap
+
+
+-- | Attach SRTs to all info tables in the CmmDecls, and add SRT
+-- declarations to the ModuleSRTInfo.
+--
+doSRTs
+  :: DynFlags
+  -> ModuleSRTInfo
+  -> [(CAFEnv, [CmmDecl])]
+  -> IO (ModuleSRTInfo, [CmmDecl])
+
+doSRTs dflags moduleSRTInfo tops = do
+  us <- mkSplitUniqSupply 'u'
+
+  -- Ignore the original grouping of decls, and combine all the
+  -- CAFEnvs into a single CAFEnv.
+  let (cafEnvs, declss) = unzip tops
+      cafEnv = mapUnions cafEnvs
+      decls = concat declss
+      staticFuns = mapFromList (getStaticFuns decls)
+
+  -- Put the decls in dependency order. Why? So that we can implement
+  -- [Inline] and [Filter].  If we need to refer to an SRT that has
+  -- a single entry, we use the entry itself, which means that we
+  -- don't need to generate the singleton SRT in the first place.  But
+  -- to do this we need to process blocks before things that depend on
+  -- them.
+  let
+    sccs = depAnalSRTs cafEnv decls
+    cafsWithSRTs = getCAFs cafEnv decls
+
+  -- On each strongly-connected group of decls, construct the SRT
+  -- closures and the SRT fields for info tables.
+  let result ::
+        [ ( [CmmDecl]              -- generated SRTs
+          , [(Label, CLabel)]      -- SRT fields for info tables
+          , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
+          ) ]
+      ((result, _srtMap), moduleSRTInfo') =
+        initUs_ us $
+        flip runStateT moduleSRTInfo $
+        flip runStateT Map.empty $ do
+          nonCAFs <- mapM (doSCC dflags staticFuns) sccs
+          cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->
+            oneSRT dflags staticFuns [l] [cafLbl] True{-is a CAF-} cafs
+          return (nonCAFs ++ cAFs)
+
+      (declss, pairs, funSRTs) = unzip3 result
+
+  -- Next, update the info tables with the SRTs
+  let
+    srtFieldMap = mapFromList (concat pairs)
+    funSRTMap = mapFromList (concat funSRTs)
+    decls' = concatMap (updInfoSRTs dflags srtFieldMap funSRTMap) decls
+
+  return (moduleSRTInfo', concat declss ++ decls')
+
+
+-- | Build the SRT for a strongly-connected component of blocks
+doSCC
+  :: DynFlags
+  -> LabelMap CLabel           -- which blocks are static function entry points
+  -> SCC (Label, CAFLabel, Set CAFLabel)
+  -> StateT SRTMap
+        (StateT ModuleSRTInfo UniqSM)
+        ( [CmmDecl]              -- generated SRTs
+        , [(Label, CLabel)]      -- SRT fields for info tables
+        , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
+        )
+
+doSCC dflags staticFuns  (AcyclicSCC (l, cafLbl, cafs)) =
+  oneSRT dflags staticFuns [l] [cafLbl] False cafs
+
+doSCC dflags staticFuns (CyclicSCC nodes) = do
+  -- build a single SRT for the whole cycle, see Note [recursive SRTs]
+  let (blockids, lbls, cafsets) = unzip3 nodes
+      cafs = Set.unions cafsets
+  oneSRT dflags staticFuns blockids lbls False cafs
+
+
+{- Note [recursive SRTs]
+
+If the dependency analyser has found us a recursive group of
+declarations, then we build a single SRT for the whole group, on the
+grounds that everything in the group is reachable from everything
+else, so we lose nothing by having a single SRT.
+
+However, there are a couple of wrinkles to be aware of.
+
+* The Set CAFLabel for this SRT will contain labels in the group
+itself. The SRTMap will therefore not contain entries for these labels
+yet, so we can't turn them into SRTEntries using resolveCAF. BUT we
+can just remove recursive references from the Set CAFLabel before
+generating the SRT - the SRT will still contain all the CAFLabels that
+we need to refer to from this group's SRT.
+
+* That is, EXCEPT for static function closures. For the same reason
+described in Note [Invalid optimisation: shortcutting], we cannot omit
+references to static function closures.
+  - But, since we will merge the SRT with one of the static function
+    closures (see [FUN]), we can omit references to *that* static
+    function closure from the SRT.
+-}
+
+-- | Build an SRT for a set of blocks
+oneSRT
+  :: DynFlags
+  -> LabelMap CLabel            -- which blocks are static function entry points
+  -> [Label]                    -- blocks in this set
+  -> [CAFLabel]                 -- labels for those blocks
+  -> Bool                       -- True <=> this SRT is for a CAF
+  -> Set CAFLabel               -- SRT for this set
+  -> StateT SRTMap
+       (StateT ModuleSRTInfo UniqSM)
+       ( [CmmDecl]                    -- SRT objects we built
+       , [(Label, CLabel)]            -- SRT fields for these blocks' itbls
+       , [(Label, [SRTEntry])]        -- SRTs to attach to static functions
+       )
+
+oneSRT dflags staticFuns blockids lbls isCAF cafs = do
+  srtMap <- get
+  topSRT <- lift get
+  let
+    -- Can we merge this SRT with a FUN_STATIC closure?
+    (maybeFunClosure, otherFunLabels) =
+      case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of
+        [] -> (Nothing, [])
+        ((l,b):xs) -> (Just (l,b), map (mkCAFLabel . fst) xs)
+
+    -- Remove recursive references from the SRT, except for (all but
+    -- one of the) static functions. See Note [recursive SRTs].
+    nonRec = cafs `Set.difference`
+      (Set.fromList lbls `Set.difference` Set.fromList otherFunLabels)
+
+    -- First resolve all the CAFLabels to SRTEntries
+    -- Implements the [Inline] optimisation.
+    resolved =
+       Set.fromList $
+       catMaybes (map (resolveCAF srtMap) (Set.toList nonRec))
+
+    -- The set of all SRTEntries in SRTs that we refer to from here.
+    allBelow =
+      Set.unions [ lbls | caf <- Set.toList resolved
+                        , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ]
+
+    -- Remove SRTEntries that are also in an SRT that we refer to.
+    -- Implements the [Filter] optimisation.
+    filtered = Set.difference resolved allBelow
+
+  srtTrace "oneSRT:"
+     (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return ()
+
+  let
+    isStaticFun = isJust maybeFunClosure
+
+    -- For a label without a closure (e.g. a continuation), we must
+    -- update the SRTMap for the label to point to a closure. It's
+    -- important that we don't do this for static functions or CAFs,
+    -- see Note [Invalid optimisation: shortcutting].
+    updateSRTMap srtEntry =
+      when (not isCAF && not isStaticFun) $ do
+        let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]
+        put (Map.union newSRTMap srtMap)
+
+    this_mod = thisModule topSRT
+
+  case Set.toList filtered of
+    [] -> do
+      srtTrace "oneSRT: empty" (ppr lbls) $ return ()
+      updateSRTMap Nothing
+      return ([], [], [])
+
+    -- [Inline] - when we have only one entry there is no need to
+    -- build an SRT object at all, instead we put the singleton SRT
+    -- entry in the info table.
+    [one@(SRTEntry lbl)]
+      | -- Info tables refer to SRTs by offset (as noted in the section
+        -- "Referring to an SRT from the info table" of Note [SRTs]). However,
+        -- when dynamic linking is used we cannot guarantee that the offset
+        -- between the SRT and the info table will fit in the offset field.
+        -- Consequently we build a singleton SRT in in this case.
+        not (labelDynamic dflags this_mod lbl)
+
+        -- MachO relocations can't express offsets between compilation units at
+        -- all, so we are always forced to build a singleton SRT in this case.
+          && (not (osMachOTarget $ platformOS $ targetPlatform dflags)
+             || isLocalCLabel this_mod lbl) -> do
+
+        -- If we have a static function closure, then it becomes the
+        -- SRT object, and everything else points to it. (the only way
+        -- we could have multiple labels here is if this is a
+        -- recursive group, see Note [recursive SRTs])
+        case maybeFunClosure of
+          Just (staticFunLbl,staticFunBlock) -> return ([], withLabels, [])
+            where
+              withLabels =
+                [ (b, if b == staticFunBlock then lbl else staticFunLbl)
+                | b <- blockids ]
+          Nothing -> do
+            updateSRTMap (Just one)
+            return ([], map (,lbl) blockids, [])
+
+    cafList ->
+      -- Check whether an SRT with the same entries has been emitted already.
+      -- Implements the [Common] optimisation.
+      case Map.lookup filtered (dedupSRTs topSRT) of
+        Just srtEntry@(SRTEntry srtLbl)  -> do
+          srtTrace "oneSRT [Common]" (ppr lbls <+> ppr srtLbl) $ return ()
+          updateSRTMap (Just srtEntry)
+          return ([], map (,srtLbl) blockids, [])
+        Nothing -> do
+          -- No duplicates: we have to build a new SRT object
+          srtTrace "oneSRT: new" (ppr lbls <+> ppr filtered) $ return ()
+          (decls, funSRTs, srtEntry) <-
+            case maybeFunClosure of
+              Just (fun,block) ->
+                return ( [], [(block, cafList)], SRTEntry fun )
+              Nothing -> do
+                (decls, entry) <- lift . lift $ buildSRTChain dflags cafList
+                return (decls, [], entry)
+          updateSRTMap (Just srtEntry)
+          let allBelowThis = Set.union allBelow filtered
+              oldFlatSRTs = flatSRTs topSRT
+              newFlatSRTs = Map.insert srtEntry allBelowThis oldFlatSRTs
+              newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT)
+          lift (put (topSRT { dedupSRTs = newDedupSRTs
+                            , flatSRTs = newFlatSRTs }))
+          let SRTEntry lbl = srtEntry
+          return (decls, map (,lbl) blockids, funSRTs)
+
+
+-- | build a static SRT object (or a chain of objects) from a list of
+-- SRTEntries.
+buildSRTChain
+   :: DynFlags
+   -> [SRTEntry]
+   -> UniqSM
+        ( [CmmDecl]    -- The SRT object(s)
+        , SRTEntry     -- label to use in the info table
+        )
+buildSRTChain _ [] = panic "buildSRT: empty"
+buildSRTChain dflags cafSet =
+  case splitAt mAX_SRT_SIZE cafSet of
+    (these, []) -> do
+      (decl,lbl) <- buildSRT dflags these
+      return ([decl], lbl)
+    (these,those) -> do
+      (rest, rest_lbl) <- buildSRTChain dflags (head these : those)
+      (decl,lbl) <- buildSRT dflags (rest_lbl : tail these)
+      return (decl:rest, lbl)
+  where
+    mAX_SRT_SIZE = 16
+
+
+buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry)
+buildSRT dflags refs = do
+  id <- getUniqueM
+  let
+    lbl = mkSRTLabel id
+    srt_n_info = mkSRTInfoLabel (length refs)
+    fields =
+      mkStaticClosure dflags srt_n_info dontCareCCS
+        [ CmmLabel lbl | SRTEntry lbl <- refs ]
+        [] -- no padding
+        [mkIntCLit dflags 0] -- link field
+        [] -- no saved info
+  return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
+
+
+-- | Update info tables with references to their SRTs. Also generate
+-- static closures, splicing in SRT fields as necessary.
+updInfoSRTs
+  :: DynFlags
+  -> LabelMap CLabel               -- SRT labels for each block
+  -> LabelMap [SRTEntry]           -- SRTs to merge into FUN_STATIC closures
+  -> CmmDecl
+  -> [CmmDecl]
+
+updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g)
+  | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]
+  | otherwise = [ proc ]
+  where
+    proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g
+    newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)
+    updInfoTbl l info_tbl
+      | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf
+      | otherwise  = info_tbl { cit_srt = mapLookup l srt_env }
+
+    -- Generate static closures [FUN].  Note that this also generates
+    -- static closures for thunks (CAFs), because it's easier to treat
+    -- them uniformly in the code generator.
+    maybeStaticClosure :: Maybe (CmmInfoTable, CmmDecl)
+    maybeStaticClosure
+      | Just info_tbl@CmmInfoTable{..} <-
+           mapLookup (g_entry g) (info_tbls top_info)
+      , Just (id, ccs) <- cit_clo
+      , isStaticRep cit_rep =
+        let
+          (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of
+            Nothing ->
+              -- if we don't add SRT entries to this closure, then we
+              -- want to set the srt field in its info table as usual
+              (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, [])
+            Just srtEntries -> srtTrace "maybeStaticFun" (ppr res)
+              (info_tbl { cit_rep = new_rep }, res)
+              where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]
+          fields = mkStaticClosureFields dflags info_tbl ccs (idCafInfo id)
+            srtEntries
+          new_rep = case cit_rep of
+             HeapRep sta ptrs nptrs ty ->
+               HeapRep sta (ptrs + length srtEntries) nptrs ty
+             _other -> panic "maybeStaticFun"
+          lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
+        in
+          Just (newInfo, mkDataLits (Section Data lbl) lbl fields)
+      | otherwise = Nothing
+
+updInfoSRTs _ _ _ t = [t]
+
+
+srtTrace :: String -> SDoc -> b -> b
+-- srtTrace = pprTrace
+srtTrace _ _ b = b
diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmCallConv.hs
@@ -0,0 +1,212 @@
+module CmmCallConv (
+  ParamLocation(..),
+  assignArgumentsPos,
+  assignStack,
+  realArgRegsCover
+) where
+
+import GhcPrelude
+
+import CmmExpr
+import SMRep
+import Cmm (Convention(..))
+import PprCmm ()
+
+import DynFlags
+import Platform
+import Outputable
+
+-- Calculate the 'GlobalReg' or stack locations for function call
+-- parameters as used by the Cmm calling convention.
+
+data ParamLocation
+  = RegisterParam GlobalReg
+  | StackParam ByteOff
+
+instance Outputable ParamLocation where
+  ppr (RegisterParam g) = ppr g
+  ppr (StackParam p)    = ppr p
+
+-- |
+-- Given a list of arguments, and a function that tells their types,
+-- return a list showing where each argument is passed
+--
+assignArgumentsPos :: DynFlags
+                   -> ByteOff           -- stack offset to start with
+                   -> Convention
+                   -> (a -> CmmType)    -- how to get a type from an arg
+                   -> [a]               -- args
+                   -> (
+                        ByteOff              -- bytes of stack args
+                      , [(a, ParamLocation)] -- args and locations
+                      )
+
+assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
+    where
+      regs = case (reps, conv) of
+               (_,   NativeNodeCall)   -> getRegsWithNode dflags
+               (_,   NativeDirectCall) -> getRegsWithoutNode dflags
+               ([_], NativeReturn)     -> allRegs dflags
+               (_,   NativeReturn)     -> getRegsWithNode dflags
+               -- GC calling convention *must* put values in registers
+               (_,   GC)               -> allRegs dflags
+               (_,   Slow)             -> nodeOnly
+      -- The calling conventions first assign arguments to registers,
+      -- then switch to the stack when we first run out of registers
+      -- (even if there are still available registers for args of a
+      -- different type).  When returning an unboxed tuple, we also
+      -- separate the stack arguments by pointerhood.
+      (reg_assts, stk_args)  = assign_regs [] reps regs
+      (stk_off,   stk_assts) = assignStack dflags off arg_ty stk_args
+      assignments = reg_assts ++ stk_assts
+
+      assign_regs assts []     _    = (assts, [])
+      assign_regs assts (r:rs) regs | isVecType ty   = vec
+                                    | isFloatType ty = float
+                                    | otherwise      = int
+        where vec = case (w, regs) of
+                      (W128, (vs, fs, ds, ls, s:ss))
+                          | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))
+                      (W256, (vs, fs, ds, ls, s:ss))
+                          | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))
+                      (W512, (vs, fs, ds, ls, s:ss))
+                          | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))
+                      _ -> (assts, (r:rs))
+              float = case (w, regs) of
+                        (W32, (vs, fs, ds, ls, s:ss))
+                            | passFloatInXmm          -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss))
+                        (W32, (vs, f:fs, ds, ls, ss))
+                            | not passFloatInXmm      -> k (RegisterParam f, (vs, fs, ds, ls, ss))
+                        (W64, (vs, fs, ds, ls, s:ss))
+                            | passFloatInXmm          -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))
+                        (W64, (vs, fs, d:ds, ls, ss))
+                            | not passFloatInXmm      -> k (RegisterParam d, (vs, fs, ds, ls, ss))
+                        (W80, _) -> panic "F80 unsupported register type"
+                        _ -> (assts, (r:rs))
+              int = case (w, regs) of
+                      (W128, _) -> panic "W128 unsupported register type"
+                      (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags)
+                          -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss))
+                      (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags)
+                          -> k (RegisterParam l, (vs, fs, ds, ls, ss))
+                      _   -> (assts, (r:rs))
+              k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
+              ty = arg_ty r
+              w  = typeWidth ty
+              gcp | isGcPtrType ty = VGcPtr
+                  | otherwise      = VNonGcPtr
+              passFloatInXmm = passFloatArgsInXmm dflags
+
+passFloatArgsInXmm :: DynFlags -> Bool
+passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of
+                              ArchX86_64 -> True
+                              _          -> False
+
+-- We used to spill vector registers to the stack since the LLVM backend didn't
+-- support vector registers in its calling convention. However, this has now
+-- been fixed. This function remains only as a convenient way to re-enable
+-- spilling when debugging code generation.
+passVectorInReg :: Width -> DynFlags -> Bool
+passVectorInReg _ _ = True
+
+assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]
+            -> (
+                 ByteOff              -- bytes of stack args
+               , [(a, ParamLocation)] -- args and locations
+               )
+assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)
+ where
+      assign_stk offset assts [] = (offset, assts)
+      assign_stk offset assts (r:rs)
+        = assign_stk off' ((r, StackParam off') : assts) rs
+        where w    = typeWidth (arg_ty r)
+              off' = offset + size
+              -- Stack arguments always take a whole number of words, we never
+              -- pack them unlike constructor fields.
+              size = roundUpToWords dflags (widthInBytes w)
+
+-----------------------------------------------------------------------------
+-- Local information about the registers available
+
+type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.
+                 , [GlobalReg]   -- floats
+                 , [GlobalReg]   -- doubles
+                 , [GlobalReg]   -- longs (int64 and word64)
+                 , [Int]         -- XMM (floats and doubles)
+                 )
+
+-- Vanilla registers can contain pointers, Ints, Chars.
+-- Floats and doubles have separate register supplies.
+--
+-- We take these register supplies from the *real* registers, i.e. those
+-- that are guaranteed to map to machine registers.
+
+getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
+getRegsWithoutNode dflags =
+  ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)
+  , realFloatRegs dflags
+  , realDoubleRegs dflags
+  , realLongRegs dflags
+  , realXmmRegNos dflags)
+
+-- getRegsWithNode uses R1/node even if it isn't a register
+getRegsWithNode dflags =
+  ( if null (realVanillaRegs dflags)
+    then [VanillaReg 1]
+    else realVanillaRegs dflags
+  , realFloatRegs dflags
+  , realDoubleRegs dflags
+  , realLongRegs dflags
+  , realXmmRegNos dflags)
+
+allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]
+allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
+allXmmRegs :: DynFlags -> [Int]
+
+allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)
+allFloatRegs   dflags = map FloatReg   $ regList (mAX_Float_REG   dflags)
+allDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Double_REG  dflags)
+allLongRegs    dflags = map LongReg    $ regList (mAX_Long_REG    dflags)
+allXmmRegs     dflags =                  regList (mAX_XMM_REG     dflags)
+
+realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]
+realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
+realXmmRegNos :: DynFlags -> [Int]
+
+realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)
+realFloatRegs   dflags = map FloatReg   $ regList (mAX_Real_Float_REG   dflags)
+realDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Real_Double_REG  dflags)
+realLongRegs    dflags = map LongReg    $ regList (mAX_Real_Long_REG    dflags)
+
+realXmmRegNos dflags
+    | isSse2Enabled dflags = regList (mAX_Real_XMM_REG     dflags)
+    | otherwise            = []
+
+regList :: Int -> [Int]
+regList n = [1 .. n]
+
+allRegs :: DynFlags -> AvailRegs
+allRegs dflags = (allVanillaRegs dflags,
+                  allFloatRegs dflags,
+                  allDoubleRegs dflags,
+                  allLongRegs dflags,
+                  allXmmRegs dflags)
+
+nodeOnly :: AvailRegs
+nodeOnly = ([VanillaReg 1], [], [], [], [])
+
+-- This returns the set of global registers that *cover* the machine registers
+-- used for argument passing. On platforms where registers can overlap---right
+-- now just x86-64, where Float and Double registers overlap---passing this set
+-- of registers is guaranteed to preserve the contents of all live registers. We
+-- only use this functionality in hand-written C-- code in the RTS.
+realArgRegsCover :: DynFlags -> [GlobalReg]
+realArgRegsCover dflags
+    | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++
+                                  realLongRegs dflags ++
+                                  map XmmReg (realXmmRegNos dflags)
+    | otherwise                 = map ($VGcPtr) (realVanillaRegs dflags) ++
+                                  realFloatRegs dflags ++
+                                  realDoubleRegs dflags ++
+                                  realLongRegs dflags ++
+                                  map XmmReg (realXmmRegNos dflags)
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/cmm/CmmCommonBlockElim.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmCommonBlockElim.hs
@@ -0,0 +1,321 @@
+{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}
+
+module CmmCommonBlockElim
+  ( elimCommonBlocks
+  )
+where
+
+
+import GhcPrelude hiding (iterate, succ, unzip, zip)
+
+import BlockId
+import Cmm
+import CmmUtils
+import CmmSwitch (eqSwitchTargetWith)
+import CmmContFlowOpt
+-- import PprCmm ()
+
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Label
+import Hoopl.Collections
+import Data.Bits
+import Data.Maybe (mapMaybe)
+import qualified Data.List as List
+import Data.Word
+import qualified Data.Map as M
+import Outputable
+import qualified TrieMap as TM
+import UniqFM
+import Unique
+import Control.Arrow (first, second)
+
+-- -----------------------------------------------------------------------------
+-- Eliminate common blocks
+
+-- If two blocks are identical except for the label on the first node,
+-- then we can eliminate one of the blocks. To ensure that the semantics
+-- of the program are preserved, we have to rewrite each predecessor of the
+-- eliminated block to proceed with the block we keep.
+
+-- The algorithm iterates over the blocks in the graph,
+-- checking whether it has seen another block that is equal modulo labels.
+-- If so, then it adds an entry in a map indicating that the new block
+-- is made redundant by the old block.
+-- Otherwise, it is added to the useful blocks.
+
+-- To avoid comparing every block with every other block repeatedly, we group
+-- them by
+--   * a hash of the block, ignoring labels (explained below)
+--   * the list of outgoing labels
+-- The hash is invariant under relabeling, so we only ever compare within
+-- the same group of blocks.
+--
+-- The list of outgoing labels is updated as we merge blocks (that is why they
+-- are not included in the hash, which we want to calculate only once).
+--
+-- All in all, two blocks should never be compared if they have different
+-- hashes, and at most once otherwise. Previously, we were slower, and people
+-- rightfully complained: #10397
+
+-- TODO: Use optimization fuel
+elimCommonBlocks :: CmmGraph -> CmmGraph
+elimCommonBlocks g = replaceLabels env $ copyTicks env g
+  where
+     env = iterate mapEmpty blocks_with_key
+     -- The order of blocks doesn't matter here. While we could use
+     -- revPostorder which drops unreachable blocks this is done in
+     -- ContFlowOpt already which runs before this pass. So we use
+     -- toBlockList since it is faster.
+     groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]]
+     blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
+
+-- Invariant: The blocks in the list are pairwise distinct
+-- (so avoid comparing them again)
+type DistinctBlocks = [CmmBlock]
+type Key = [Label]
+type Subst = LabelMap BlockId
+
+-- The outer list groups by hash. We retain this grouping throughout.
+iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
+iterate subst blocks
+    | mapNull new_substs = subst
+    | otherwise = iterate subst' updated_blocks
+  where
+    grouped_blocks :: [[(Key, [DistinctBlocks])]]
+    grouped_blocks = map groupByLabel blocks
+
+    merged_blocks :: [[(Key, DistinctBlocks)]]
+    (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks
+      where
+        go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))
+          where
+            (new_subst2, db) = mergeBlockList subst dbs
+
+    subst' = subst `mapUnion` new_substs
+    updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
+
+-- Combine two lists of blocks.
+-- While they are internally distinct they can still share common blocks.
+mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
+mergeBlocks subst existing new = go new
+  where
+    go [] = (mapEmpty, existing)
+    go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of
+        -- This block is a duplicate. Drop it, and add it to the substitution
+        Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs
+        -- This block is not a duplicate, keep it.
+        Nothing -> second (b:) $ go bs
+
+mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)
+mergeBlockList _ [] = pprPanic "mergeBlockList" empty
+mergeBlockList subst (b:bs) = go mapEmpty b bs
+  where
+    go !new_subst1 b [] = (new_subst1, b)
+    go !new_subst1 b1 (b2:bs) = go new_subst b bs
+      where
+        (new_subst2, b) =  mergeBlocks subst b1 b2
+        new_subst = new_subst1 `mapUnion` new_subst2
+
+
+-- -----------------------------------------------------------------------------
+-- Hashing and equality on blocks
+
+-- Below here is mostly boilerplate: hashing blocks ignoring labels,
+-- and comparing blocks modulo a label mapping.
+
+-- To speed up comparisons, we hash each basic block modulo jump labels.
+-- The hashing is a bit arbitrary (the numbers are completely arbitrary),
+-- but it should be fast and good enough.
+
+-- We want to get as many small buckets as possible, as comparing blocks is
+-- expensive. So include as much as possible in the hash. Ideally everything
+-- that is compared with (==) in eqBlockBodyWith.
+
+type HashCode = Int
+
+hash_block :: CmmBlock -> HashCode
+hash_block block =
+  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
+  -- UniqFM doesn't like negative Ints
+  where hash_fst _ h = h
+        hash_mid m h = hash_node m + h `shiftL` 1
+        hash_lst m h = hash_node m + h `shiftL` 1
+
+        hash_node :: CmmNode O x -> Word32
+        hash_node n | dont_care n = 0 -- don't care
+        hash_node (CmmAssign r e) = hash_reg r + hash_e e
+        hash_node (CmmStore e e') = hash_e e + hash_e e'
+        hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
+        hash_node (CmmBranch _) = 23 -- NB. ignore the label
+        hash_node (CmmCondBranch p _ _ _) = hash_e p
+        hash_node (CmmCall e _ _ _ _ _) = hash_e e
+        hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
+        hash_node (CmmSwitch e _) = hash_e e
+        hash_node _ = error "hash_node: unknown Cmm node!"
+
+        hash_reg :: CmmReg -> Word32
+        hash_reg   (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397
+        hash_reg   (CmmGlobal _)    = 19
+
+        hash_e :: CmmExpr -> Word32
+        hash_e (CmmLit l) = hash_lit l
+        hash_e (CmmLoad e _) = 67 + hash_e e
+        hash_e (CmmReg r) = hash_reg r
+        hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
+        hash_e (CmmRegOff r i) = hash_reg r + cvt i
+        hash_e (CmmStackSlot _ _) = 13
+
+        hash_lit :: CmmLit -> Word32
+        hash_lit (CmmInt i _) = fromInteger i
+        hash_lit (CmmFloat r _) = truncate r
+        hash_lit (CmmVec ls) = hash_list hash_lit ls
+        hash_lit (CmmLabel _) = 119 -- ugh
+        hash_lit (CmmLabelOff _ i) = cvt $ 199 + i
+        hash_lit (CmmLabelDiffOff _ _ i _) = cvt $ 299 + i
+        hash_lit (CmmBlock _) = 191 -- ugh
+        hash_lit (CmmHighStackMark) = cvt 313
+
+        hash_tgt (ForeignTarget e _) = hash_e e
+        hash_tgt (PrimTarget _) = 31 -- lots of these
+
+        hash_list f = foldl' (\z x -> f x + z) (0::Word32)
+
+        cvt = fromInteger . toInteger
+
+        hash_unique :: Uniquable a => a -> Word32
+        hash_unique = cvt . getKey . getUnique
+
+-- | Ignore these node types for equality
+dont_care :: CmmNode O x -> Bool
+dont_care CmmComment {}  = True
+dont_care CmmTick {}     = True
+dont_care CmmUnwind {}   = True
+dont_care _other         = False
+
+-- Utilities: equality and substitution on the graph.
+
+-- Given a map ``subst'' from BlockID -> BlockID, we define equality.
+eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool
+eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
+lookupBid :: LabelMap BlockId -> BlockId -> BlockId
+lookupBid subst bid = case mapLookup bid subst of
+                        Just bid  -> lookupBid subst bid
+                        Nothing -> bid
+
+-- Middle nodes and expressions can contain BlockIds, in particular in
+-- CmmStackSlot and CmmBlock, so we have to use a special equality for
+-- these.
+--
+eqMiddleWith :: (BlockId -> BlockId -> Bool)
+             -> CmmNode O O -> CmmNode O O -> Bool
+eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
+  = r1 == r2 && eqExprWith eqBid e1 e2
+eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)
+  = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2
+eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)
+                   (CmmUnsafeForeignCall t2 r2 a2)
+  = t1 == t2 && r1 == r2 && eqListWith (eqExprWith eqBid) a1 a2
+eqMiddleWith _ _ _ = False
+
+eqExprWith :: (BlockId -> BlockId -> Bool)
+           -> CmmExpr -> CmmExpr -> Bool
+eqExprWith eqBid = eq
+ where
+  CmmLit l1          `eq` CmmLit l2          = eqLit l1 l2
+  CmmLoad e1 _       `eq` CmmLoad e2 _       = e1 `eq` e2
+  CmmReg r1          `eq` CmmReg r2          = r1==r2
+  CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2
+  CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && es1 `eqs` es2
+  CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2
+  _e1                `eq` _e2                = False
+
+  xs `eqs` ys = eqListWith eq xs ys
+
+  eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2
+  eqLit l1 l2 = l1 == l2
+
+  eqArea Old Old = True
+  eqArea (Young id1) (Young id2) = eqBid id1 id2
+  eqArea _ _ = False
+
+-- Equality on the body of a block, modulo a function mapping block
+-- IDs to block IDs.
+eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
+eqBlockBodyWith eqBid block block'
+  {-
+  | equal     = pprTrace "equal" (vcat [ppr block, ppr block']) True
+  | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False
+  -}
+  = equal
+  where (_,m,l)   = blockSplit block
+        nodes     = filter (not . dont_care) (blockToList m)
+        (_,m',l') = blockSplit block'
+        nodes'    = filter (not . dont_care) (blockToList m')
+
+        equal = eqListWith (eqMiddleWith eqBid) nodes nodes' &&
+                eqLastWith eqBid l l'
+
+
+eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
+eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
+eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) =
+  c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2
+eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =
+  t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
+eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =
+  e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2
+eqLastWith _ _ _ = False
+
+eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
+eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
+eqMaybeWith _ Nothing Nothing = True
+eqMaybeWith _ _ _ = False
+
+eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs
+eqListWith _ []       []       = True
+eqListWith _ _        _        = False
+
+-- | Given a block map, ensure that all "target" blocks are covered by
+-- the same ticks as the respective "source" blocks. This not only
+-- means copying ticks, but also adjusting tick scopes where
+-- necessary.
+copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph
+copyTicks env g
+  | mapNull env = g
+  | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap
+  where -- Reverse block merge map
+        blockMap = toBlockMap g
+        revEnv = mapFoldlWithKey insertRev M.empty env
+        insertRev m k x = M.insertWith (const (k:)) x [k] m
+        -- Copy ticks and scopes into the given block
+        copyTo block = case M.lookup (entryLabel block) revEnv of
+          Nothing -> block
+          Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls
+        copy from to =
+          let ticks = blockTicks from
+              CmmEntry  _   scp0        = firstNode from
+              (CmmEntry lbl scp1, code) = blockSplitHead to
+          in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`
+             foldr blockCons code (map CmmTick ticks)
+
+-- Group by [Label]
+-- See Note [Compressed TrieMap] in coreSyn/TrieMap about the usage of GenMap.
+groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]
+groupByLabel =
+  go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))
+    where
+      go !m [] = TM.foldTM (:) m []
+      go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries
+        where --k' = map (getKey . getUnique) k
+              adjust Nothing       = Just (k,[v])
+              adjust (Just (_,vs)) = Just (k,v:vs)
+
+groupByInt :: (a -> Int) -> [a] -> [[a]]
+groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs
+   -- See Note [Unique Determinism and code generation]
+  where
+    go m x = alterUFM addEntry m (f x)
+      where
+        addEntry xs = Just $! maybe [x] (x:) xs
diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmContFlowOpt.hs
@@ -0,0 +1,444 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+module CmmContFlowOpt
+    ( cmmCfgOpts
+    , cmmCfgOptsProc
+    , removeUnreachableBlocksProc
+    , replaceLabels
+    )
+where
+
+import GhcPrelude hiding (succ, unzip, zip)
+
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
+import BlockId
+import Cmm
+import CmmUtils
+import CmmSwitch (mapSwitchTargets)
+import Maybes
+import Panic
+import Util
+
+import Control.Monad
+
+
+-- Note [What is shortcutting]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Consider this Cmm code:
+--
+-- L1: ...
+--     goto L2;
+-- L2: goto L3;
+-- L3: ...
+--
+-- Here L2 is an empty block and contains only an unconditional branch
+-- to L3. In this situation any block that jumps to L2 can jump
+-- directly to L3:
+--
+-- L1: ...
+--     goto L3;
+-- L2: goto L3;
+-- L3: ...
+--
+-- In this situation we say that we shortcut L2 to L3. One of
+-- consequences of shortcutting is that some blocks of code may become
+-- unreachable (in the example above this is true for L2).
+
+
+-- Note [Control-flow optimisations]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- This optimisation does three things:
+--
+--   - If a block finishes in an unconditional branch to another block
+--     and that is the only jump to that block we concatenate the
+--     destination block at the end of the current one.
+--
+--   - If a block finishes in a call whose continuation block is a
+--     goto, then we can shortcut the destination, making the
+--     continuation block the destination of the goto - but see Note
+--     [Shortcut call returns].
+--
+--   - For any block that is not a call we try to shortcut the
+--     destination(s). Additionally, if a block ends with a
+--     conditional branch we try to invert the condition.
+--
+-- Blocks are processed using postorder DFS traversal. A side effect
+-- of determining traversal order with a graph search is elimination
+-- of any blocks that are unreachable.
+--
+-- Transformations are improved by working from the end of the graph
+-- towards the beginning, because we may be able to perform many
+-- shortcuts in one go.
+
+
+-- Note [Shortcut call returns]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- We are going to maintain the "current" graph (LabelMap CmmBlock) as
+-- we go, and also a mapping from BlockId to BlockId, representing
+-- continuation labels that we have renamed.  This latter mapping is
+-- important because we might shortcut a CmmCall continuation.  For
+-- example:
+--
+--    Sp[0] = L
+--    call g returns to L
+--    L: goto M
+--    M: ...
+--
+-- So when we shortcut the L block, we need to replace not only
+-- the continuation of the call, but also references to L in the
+-- code (e.g. the assignment Sp[0] = L):
+--
+--    Sp[0] = M
+--    call g returns to M
+--    M: ...
+--
+-- So we keep track of which labels we have renamed and apply the mapping
+-- at the end with replaceLabels.
+
+
+-- Note [Shortcut call returns and proc-points]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Consider this code that you might get from a recursive
+-- let-no-escape:
+--
+--       goto L1
+--      L1:
+--       if (Hp > HpLim) then L2 else L3
+--      L2:
+--       call stg_gc_noregs returns to L4
+--      L4:
+--       goto L1
+--      L3:
+--       ...
+--       goto L1
+--
+-- Then the control-flow optimiser shortcuts L4.  But that turns L1
+-- into the call-return proc point, and every iteration of the loop
+-- has to shuffle variables to and from the stack.  So we must *not*
+-- shortcut L4.
+--
+-- Moreover not shortcutting call returns is probably fine.  If L4 can
+-- concat with its branch target then it will still do so.  And we
+-- save some compile time because we don't have to traverse all the
+-- code in replaceLabels.
+--
+-- However, we probably do want to do this if we are splitting proc
+-- points, because L1 will be a proc-point anyway, so merging it with
+-- L4 reduces the number of proc points.  Unfortunately recursive
+-- let-no-escapes won't generate very good code with proc-point
+-- splitting on - we should probably compile them to explicitly use
+-- the native calling convention instead.
+
+cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph
+cmmCfgOpts split g = fst (blockConcat split g)
+
+cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl
+cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g'
+    where (g', env) = blockConcat split g
+          info' = info{ info_tbls = new_info_tbls }
+          new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))
+
+          -- If we changed any labels, then we have to update the info tables
+          -- too, except for the top-level info table because that might be
+          -- referred to by other procs.
+          upd_info (k,info)
+             | Just k' <- mapLookup k env
+             = (k', if k' == g_entry g'
+                       then info
+                       else info{ cit_lbl = infoTblLbl k' })
+             | otherwise
+             = (k,info)
+cmmCfgOptsProc _ top = top
+
+
+blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)
+blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
+  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')
+  where
+     -- We might be able to shortcut the entry BlockId itself.
+     -- Remember to update the shortcut_map, since we also have to
+     -- update the info_tbls mapping now.
+     (new_entry, shortcut_map')
+       | Just entry_blk <- mapLookup entry_id new_blocks
+       , Just dest      <- canShortcut entry_blk
+       = (dest, mapInsert entry_id dest shortcut_map)
+       | otherwise
+       = (entry_id, shortcut_map)
+
+     -- blocks are sorted in reverse postorder, but we want to go from the exit
+     -- towards beginning, so we use foldr below.
+     blocks = revPostorder g
+     blockmap = foldl' (flip addBlock) emptyBody blocks
+
+     -- Accumulator contains three components:
+     --  * map of blocks in a graph
+     --  * map of shortcut labels. See Note [Shortcut call returns]
+     --  * map containing number of predecessors for each block. We discard
+     --    it after we process all blocks.
+     (new_blocks, shortcut_map, _) =
+           foldr maybe_concat (blockmap, mapEmpty, initialBackEdges) blocks
+
+     -- Map of predecessors for initial graph. We increase number of
+     -- predecessors for entry block by one to denote that it is
+     -- target of a jump, even if no block in the current graph jumps
+     -- to it.
+     initialBackEdges = incPreds entry_id (predMap blocks)
+
+     maybe_concat :: CmmBlock
+                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
+                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)
+     maybe_concat block (!blocks, !shortcut_map, !backEdges)
+        -- If:
+        --   (1) current block ends with unconditional branch to b' and
+        --   (2) it has exactly one predecessor (namely, current block)
+        --
+        -- Then:
+        --   (1) append b' block at the end of current block
+        --   (2) remove b' from the map of blocks
+        --   (3) remove information about b' from predecessors map
+        --
+        -- Since we know that the block has only one predecessor we call
+        -- mapDelete directly instead of calling decPreds.
+        --
+        -- Note that we always maintain an up-to-date list of predecessors, so
+        -- we can ignore the contents of shortcut_map
+        | CmmBranch b' <- last
+        , hasOnePredecessor b'
+        , Just blk' <- mapLookup b' blocks
+        = let bid' = entryLabel blk'
+          in ( mapDelete bid' $ mapInsert bid (splice head blk') blocks
+             , shortcut_map
+             , mapDelete b' backEdges )
+
+        -- If:
+        --   (1) we are splitting proc points (see Note
+        --       [Shortcut call returns and proc-points]) and
+        --   (2) current block is a CmmCall or CmmForeignCall with
+        --       continuation b' and
+        --   (3) we can shortcut that continuation to dest
+        -- Then:
+        --   (1) we change continuation to point to b'
+        --   (2) create mapping from b' to dest
+        --   (3) increase number of predecessors of dest by 1
+        --   (4) decrease number of predecessors of b' by 1
+        --
+        -- Later we will use replaceLabels to substitute all occurrences of b'
+        -- with dest.
+        | splitting_procs
+        , Just b'   <- callContinuation_maybe last
+        , Just blk' <- mapLookup b' blocks
+        , Just dest <- canShortcut blk'
+        = ( mapInsert bid (blockJoinTail head (update_cont dest)) blocks
+          , mapInsert b' dest shortcut_map
+          , decPreds b' $ incPreds dest backEdges )
+
+        -- If:
+        --   (1) a block does not end with a call
+        -- Then:
+        --   (1) if it ends with a conditional attempt to invert the
+        --       conditional
+        --   (2) attempt to shortcut all destination blocks
+        --   (3) if new successors of a block are different from the old ones
+        --       update the of predecessors accordingly
+        --
+        -- A special case of this is a situation when a block ends with an
+        -- unconditional jump to a block that can be shortcut.
+        | Nothing <- callContinuation_maybe last
+        = let oldSuccs = successors last
+              newSuccs = successors rewrite_last
+          in ( mapInsert bid (blockJoinTail head rewrite_last) blocks
+             , shortcut_map
+             , if oldSuccs == newSuccs
+               then backEdges
+               else foldr incPreds (foldr decPreds backEdges oldSuccs) newSuccs )
+
+        -- Otherwise don't do anything
+        | otherwise
+        = ( blocks, shortcut_map, backEdges )
+        where
+          (head, last) = blockSplitTail block
+          bid = entryLabel block
+
+          -- Changes continuation of a call to a specified label
+          update_cont dest =
+              case last of
+                CmmCall{}        -> last { cml_cont = Just dest }
+                CmmForeignCall{} -> last { succ = dest }
+                _                -> panic "Can't shortcut continuation."
+
+          -- Attempts to shortcut successors of last node
+          shortcut_last = mapSuccessors shortcut last
+            where
+              shortcut l =
+                 case mapLookup l blocks of
+                   Just b | Just dest <- canShortcut b -> dest
+                   _otherwise -> l
+
+          rewrite_last
+            -- Sometimes we can get rid of the conditional completely.
+            | CmmCondBranch _cond t f _l <- shortcut_last
+            , t == f
+            = CmmBranch t
+
+            -- See Note [Invert Cmm conditionals]
+            | CmmCondBranch cond t f l <- shortcut_last
+            , hasOnePredecessor t -- inverting will make t a fallthrough
+            , likelyTrue l || (numPreds f > 1)
+            , Just cond' <- maybeInvertCmmExpr cond
+            = CmmCondBranch cond' f t (invertLikeliness l)
+
+            | otherwise
+            = shortcut_last
+
+          likelyTrue (Just True)   = True
+          likelyTrue _             = False
+
+          invertLikeliness :: Maybe Bool -> Maybe Bool
+          invertLikeliness         = fmap not
+
+          -- Number of predecessors for a block
+          numPreds bid = mapLookup bid backEdges `orElse` 0
+
+          hasOnePredecessor b = numPreds b == 1
+
+{-
+  Note [Invert Cmm conditionals]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  The native code generator always produces jumps to the true branch.
+  Falling through to the false branch is however faster. So we try to
+  arrange for that to happen.
+  This means we invert the condition if:
+  * The likely path will become a fallthrough.
+  * We can't guarantee a fallthrough for the false branch but for the
+    true branch.
+
+  In some cases it's faster to avoid inverting when the false branch is likely.
+  However determining when that is the case is neither easy nor cheap so for
+  now we always invert as this produces smaller binaries and code that is
+  equally fast on average. (On an i7-6700K)
+
+  TODO:
+  There is also the edge case when both branches have multiple predecessors.
+  In this case we could assume that we will end up with a jump for BOTH
+  branches. In this case it might be best to put the likely path in the true
+  branch especially if there are large numbers of predecessors as this saves
+  us the jump thats not taken. However I haven't tested this and as of early
+  2018 we almost never generate cmm where this would apply.
+-}
+
+-- Functions for incrementing and decrementing number of predecessors. If
+-- decrementing would set the predecessor count to 0, we remove entry from the
+-- map.
+-- Invariant: if a block has no predecessors it should be dropped from the
+-- graph because it is unreachable. maybe_concat is constructed to maintain
+-- that invariant, but calling replaceLabels may introduce unreachable blocks.
+-- We rely on subsequent passes in the Cmm pipeline to remove unreachable
+-- blocks.
+incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int
+incPreds bid edges = mapInsertWith (+) bid 1 edges
+decPreds bid edges = case mapLookup bid edges of
+                       Just preds | preds > 1 -> mapInsert bid (preds - 1) edges
+                       Just _                 -> mapDelete bid edges
+                       _                      -> edges
+
+
+-- Checks if a block consists only of "goto dest". If it does than we return
+-- "Just dest" label. See Note [What is shortcutting]
+canShortcut :: CmmBlock -> Maybe BlockId
+canShortcut block
+    | (_, middle, CmmBranch dest) <- blockSplit block
+    , all dont_care $ blockToList middle
+    = Just dest
+    | otherwise
+    = Nothing
+    where dont_care CmmComment{} = True
+          dont_care CmmTick{}    = True
+          dont_care _other       = False
+
+-- Concatenates two blocks. First one is assumed to be open on exit, the second
+-- is assumed to be closed on entry (i.e. it has a label attached to it, which
+-- the splice function removes by calling snd on result of blockSplitHead).
+splice :: Block CmmNode C O -> CmmBlock -> CmmBlock
+splice head rest = entry `blockJoinHead` code0 `blockAppend` code1
+  where (CmmEntry lbl sc0, code0) = blockSplitHead head
+        (CmmEntry _   sc1, code1) = blockSplitHead rest
+        entry = CmmEntry lbl (combineTickScopes sc0 sc1)
+
+-- If node is a call with continuation call return Just label of that
+-- continuation. Otherwise return Nothing.
+callContinuation_maybe :: CmmNode O C -> Maybe BlockId
+callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b
+callContinuation_maybe (CmmForeignCall { succ = b })   = Just b
+callContinuation_maybe _ = Nothing
+
+
+-- Map over the CmmGraph, replacing each label with its mapping in the
+-- supplied LabelMap.
+replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph
+replaceLabels env g
+  | mapNull env = g
+  | otherwise   = replace_eid $ mapGraphNodes1 txnode g
+   where
+     replace_eid g = g {g_entry = lookup (g_entry g)}
+     lookup id = mapLookup id env `orElse` id
+
+     txnode :: CmmNode e x -> CmmNode e x
+     txnode (CmmBranch bid) = CmmBranch (lookup bid)
+     txnode (CmmCondBranch p t f l) =
+       mkCmmCondBranch (exp p) (lookup t) (lookup f) l
+     txnode (CmmSwitch e ids) =
+       CmmSwitch (exp e) (mapSwitchTargets lookup ids)
+     txnode (CmmCall t k rg a res r) =
+       CmmCall (exp t) (liftM lookup k) rg a res r
+     txnode fc@CmmForeignCall{} =
+       fc{ args = map exp (args fc), succ = lookup (succ fc) }
+     txnode other = mapExpDeep exp other
+
+     exp :: CmmExpr -> CmmExpr
+     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))
+     exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i
+     exp e                                      = e
+
+mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C
+mkCmmCondBranch p t f l =
+  if t == f then CmmBranch t else CmmCondBranch p t f l
+
+-- Build a map from a block to its set of predecessors.
+predMap :: [CmmBlock] -> LabelMap Int
+predMap blocks = foldr add_preds mapEmpty blocks
+  where
+    add_preds block env = foldr add env (successors block)
+      where add lbl env = mapInsertWith (+) lbl 1 env
+
+-- Removing unreachable blocks
+removeUnreachableBlocksProc :: CmmDecl -> CmmDecl
+removeUnreachableBlocksProc proc@(CmmProc info lbl live g)
+   | used_blocks `lengthLessThan` mapSize (toBlockMap g)
+   = CmmProc info' lbl live g'
+   | otherwise
+   = proc
+   where
+     g'    = ofBlockList (g_entry g) used_blocks
+     info' = info { info_tbls = keep_used (info_tbls info) }
+             -- Remove any info_tbls for unreachable
+
+     keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable
+     keep_used bs = mapFoldlWithKey keep mapEmpty bs
+
+     keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable
+     keep env l i | l `setMember` used_lbls = mapInsert l i env
+                  | otherwise               = env
+
+     used_blocks :: [CmmBlock]
+     used_blocks = revPostorder g
+
+     used_lbls :: LabelSet
+     used_lbls = setFromList $ map entryLabel used_blocks
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmExpr.hs
@@ -0,0 +1,604 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module CmmExpr
+    ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
+    , CmmReg(..), cmmRegType, cmmRegWidth
+    , CmmLit(..), cmmLitType
+    , LocalReg(..), localRegType
+    , GlobalReg(..), isArgReg, globalRegType
+    , spReg, hpReg, spLimReg, hpLimReg, nodeReg
+    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg
+    , node, baseReg
+    , VGcPtr(..)
+
+    , DefinerOfRegs, UserOfRegs
+    , foldRegsDefd, foldRegsUsed
+    , foldLocalRegsDefd, foldLocalRegsUsed
+
+    , RegSet, LocalRegSet, GlobalRegSet
+    , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
+    , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
+    , regSetToList
+
+    , Area(..)
+    , module CmmMachOp
+    , module CmmType
+    )
+where
+
+import GhcPrelude
+
+import BlockId
+import CLabel
+import CmmMachOp
+import CmmType
+import DynFlags
+import Outputable (panic)
+import Unique
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+-----------------------------------------------------------------------------
+--              CmmExpr
+-- An expression.  Expressions have no side effects.
+-----------------------------------------------------------------------------
+
+data CmmExpr
+  = CmmLit CmmLit               -- Literal
+  | CmmLoad !CmmExpr !CmmType   -- Read memory location
+  | CmmReg !CmmReg              -- Contents of register
+  | CmmMachOp MachOp [CmmExpr]  -- Machine operation (+, -, *, etc.)
+  | CmmStackSlot Area {-# UNPACK #-} !Int
+                                -- addressing expression of a stack slot
+                                -- See Note [CmmStackSlot aliasing]
+  | CmmRegOff !CmmReg Int
+        -- CmmRegOff reg i
+        --        ** is shorthand only, meaning **
+        -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
+        --      where rep = typeWidth (cmmRegType reg)
+
+instance Eq CmmExpr where       -- Equality ignores the types
+  CmmLit l1          == CmmLit l2          = l1==l2
+  CmmLoad e1 _       == CmmLoad e2 _       = e1==e2
+  CmmReg r1          == CmmReg r2          = r1==r2
+  CmmRegOff r1 i1    == CmmRegOff r2 i2    = r1==r2 && i1==i2
+  CmmMachOp op1 es1  == CmmMachOp op2 es2  = op1==op2 && es1==es2
+  CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2
+  _e1                == _e2                = False
+
+data CmmReg
+  = CmmLocal  {-# UNPACK #-} !LocalReg
+  | CmmGlobal GlobalReg
+  deriving( Eq, Ord )
+
+-- | A stack area is either the stack slot where a variable is spilled
+-- or the stack space where function arguments and results are passed.
+data Area
+  = Old            -- See Note [Old Area]
+  | Young {-# UNPACK #-} !BlockId  -- Invariant: must be a continuation BlockId
+                   -- See Note [Continuation BlockId] in CmmNode.
+  deriving (Eq, Ord)
+
+{- Note [Old Area]
+~~~~~~~~~~~~~~~~~~
+There is a single call area 'Old', allocated at the extreme old
+end of the stack frame (ie just younger than the return address)
+which holds:
+  * incoming (overflow) parameters,
+  * outgoing (overflow) parameter to tail calls,
+  * outgoing (overflow) result values
+  * the update frame (if any)
+
+Its size is the max of all these requirements.  On entry, the stack
+pointer will point to the youngest incoming parameter, which is not
+necessarily at the young end of the Old area.
+
+End of note -}
+
+
+{- Note [CmmStackSlot aliasing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When do two CmmStackSlots alias?
+
+ - T[old+N] aliases with U[young(L)+M] for all T, U, L, N and M
+ - T[old+N] aliases with U[old+M] only if the areas actually overlap
+
+Or more informally, different Areas may overlap with each other.
+
+An alternative semantics, that we previously had, was that different
+Areas do not overlap.  The problem that lead to redefining the
+semantics of stack areas is described below.
+
+e.g. if we had
+
+    x = Sp[old + 8]
+    y = Sp[old + 16]
+
+    Sp[young(L) + 8]  = L
+    Sp[young(L) + 16] = y
+    Sp[young(L) + 24] = x
+    call f() returns to L
+
+if areas semantically do not overlap, then we might optimise this to
+
+    Sp[young(L) + 8]  = L
+    Sp[young(L) + 16] = Sp[old + 8]
+    Sp[young(L) + 24] = Sp[old + 16]
+    call f() returns to L
+
+and now young(L) cannot be allocated at the same place as old, and we
+are doomed to use more stack.
+
+  - old+8  conflicts with young(L)+8
+  - old+16 conflicts with young(L)+16 and young(L)+8
+
+so young(L)+8 == old+24 and we get
+
+    Sp[-8]  = L
+    Sp[-16] = Sp[8]
+    Sp[-24] = Sp[0]
+    Sp -= 24
+    call f() returns to L
+
+However, if areas are defined to be "possibly overlapping" in the
+semantics, then we cannot commute any loads/stores of old with
+young(L), and we will be able to re-use both old+8 and old+16 for
+young(L).
+
+    x = Sp[8]
+    y = Sp[0]
+
+    Sp[8] = L
+    Sp[0] = y
+    Sp[-8] = x
+    Sp = Sp - 8
+    call f() returns to L
+
+Now, the assignments of y go away,
+
+    x = Sp[8]
+    Sp[8] = L
+    Sp[-8] = x
+    Sp = Sp - 8
+    call f() returns to L
+-}
+
+data CmmLit
+  = CmmInt !Integer  Width
+        -- Interpretation: the 2's complement representation of the value
+        -- is truncated to the specified size.  This is easier than trying
+        -- to keep the value within range, because we don't know whether
+        -- it will be used as a signed or unsigned value (the CmmType doesn't
+        -- distinguish between signed & unsigned).
+  | CmmFloat  Rational Width
+  | CmmVec [CmmLit]                     -- Vector literal
+  | CmmLabel    CLabel                  -- Address of label
+  | CmmLabelOff CLabel Int              -- Address of label + byte offset
+
+        -- Due to limitations in the C backend, the following
+        -- MUST ONLY be used inside the info table indicated by label2
+        -- (label2 must be the info label), and label1 must be an
+        -- SRT, a slow entrypoint or a large bitmap (see the Mangler)
+        -- Don't use it at all unless tablesNextToCode.
+        -- It is also used inside the NCG during when generating
+        -- position-independent code.
+  | CmmLabelDiffOff CLabel CLabel Int Width -- label1 - label2 + offset
+        -- In an expression, the width just has the effect of MO_SS_Conv
+        -- from wordWidth to the desired width.
+        --
+        -- In a static literal, the supported Widths depend on the
+        -- architecture: wordWidth is supported on all
+        -- architectures. Additionally W32 is supported on x86_64 when
+        -- using the small memory model.
+
+  | CmmBlock {-# UNPACK #-} !BlockId     -- Code label
+        -- Invariant: must be a continuation BlockId
+        -- See Note [Continuation BlockId] in CmmNode.
+
+  | CmmHighStackMark -- A late-bound constant that stands for the max
+                     -- #bytes of stack space used during a procedure.
+                     -- During the stack-layout pass, CmmHighStackMark
+                     -- is replaced by a CmmInt for the actual number
+                     -- of bytes used
+  deriving Eq
+
+cmmExprType :: DynFlags -> CmmExpr -> CmmType
+cmmExprType dflags (CmmLit lit)        = cmmLitType dflags lit
+cmmExprType _      (CmmLoad _ rep)     = rep
+cmmExprType dflags (CmmReg reg)        = cmmRegType dflags reg
+cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args)
+cmmExprType dflags (CmmRegOff reg _)   = cmmRegType dflags reg
+cmmExprType dflags (CmmStackSlot _ _)  = bWord dflags -- an address
+-- Careful though: what is stored at the stack slot may be bigger than
+-- an address
+
+cmmLitType :: DynFlags -> CmmLit -> CmmType
+cmmLitType _      (CmmInt _ width)     = cmmBits  width
+cmmLitType _      (CmmFloat _ width)   = cmmFloat width
+cmmLitType _      (CmmVec [])          = panic "cmmLitType: CmmVec []"
+cmmLitType cflags (CmmVec (l:ls))      = let ty = cmmLitType cflags l
+                                         in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls)
+                                            then cmmVec (1+length ls) ty
+                                            else panic "cmmLitType: CmmVec"
+cmmLitType dflags (CmmLabel lbl)       = cmmLabelType dflags lbl
+cmmLitType dflags (CmmLabelOff lbl _)  = cmmLabelType dflags lbl
+cmmLitType _      (CmmLabelDiffOff _ _ _ width) = cmmBits width
+cmmLitType dflags (CmmBlock _)         = bWord dflags
+cmmLitType dflags (CmmHighStackMark)   = bWord dflags
+
+cmmLabelType :: DynFlags -> CLabel -> CmmType
+cmmLabelType dflags lbl
+ | isGcPtrLabel lbl = gcWord dflags
+ | otherwise        = bWord dflags
+
+cmmExprWidth :: DynFlags -> CmmExpr -> Width
+cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)
+
+--------
+--- Negation for conditional branches
+
+maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
+maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
+                                            return (CmmMachOp op' args)
+maybeInvertCmmExpr _ = Nothing
+
+-----------------------------------------------------------------------------
+--              Local registers
+-----------------------------------------------------------------------------
+
+data LocalReg
+  = LocalReg {-# UNPACK #-} !Unique CmmType
+    -- ^ Parameters:
+    --   1. Identifier
+    --   2. Type
+
+instance Eq LocalReg where
+  (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
+
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+-- See Note [No Ord for Unique]
+instance Ord LocalReg where
+  compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2
+
+instance Uniquable LocalReg where
+  getUnique (LocalReg uniq _) = uniq
+
+cmmRegType :: DynFlags -> CmmReg -> CmmType
+cmmRegType _      (CmmLocal  reg) = localRegType reg
+cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg
+
+cmmRegWidth :: DynFlags -> CmmReg -> Width
+cmmRegWidth dflags = typeWidth . cmmRegType dflags
+
+localRegType :: LocalReg -> CmmType
+localRegType (LocalReg _ rep) = rep
+
+-----------------------------------------------------------------------------
+--    Register-use information for expressions and other types
+-----------------------------------------------------------------------------
+
+-- | Sets of registers
+
+-- These are used for dataflow facts, and a common operation is taking
+-- the union of two RegSets and then asking whether the union is the
+-- same as one of the inputs.  UniqSet isn't good here, because
+-- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary
+-- Sets.
+
+type RegSet r     = Set r
+type LocalRegSet  = RegSet LocalReg
+type GlobalRegSet = RegSet GlobalReg
+
+emptyRegSet             :: RegSet r
+nullRegSet              :: RegSet r -> Bool
+elemRegSet              :: Ord r => r -> RegSet r -> Bool
+extendRegSet            :: Ord r => RegSet r -> r -> RegSet r
+deleteFromRegSet        :: Ord r => RegSet r -> r -> RegSet r
+mkRegSet                :: Ord r => [r] -> RegSet r
+minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r
+sizeRegSet              :: RegSet r -> Int
+regSetToList            :: RegSet r -> [r]
+
+emptyRegSet      = Set.empty
+nullRegSet       = Set.null
+elemRegSet       = Set.member
+extendRegSet     = flip Set.insert
+deleteFromRegSet = flip Set.delete
+mkRegSet         = Set.fromList
+minusRegSet      = Set.difference
+plusRegSet       = Set.union
+timesRegSet      = Set.intersection
+sizeRegSet       = Set.size
+regSetToList     = Set.toList
+
+class Ord r => UserOfRegs r a where
+  foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b
+
+foldLocalRegsUsed :: UserOfRegs LocalReg a
+                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
+foldLocalRegsUsed = foldRegsUsed
+
+class Ord r => DefinerOfRegs r a where
+  foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b
+
+foldLocalRegsDefd :: DefinerOfRegs LocalReg a
+                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
+foldLocalRegsDefd = foldRegsDefd
+
+instance UserOfRegs LocalReg CmmReg where
+    foldRegsUsed _ f z (CmmLocal reg) = f z reg
+    foldRegsUsed _ _ z (CmmGlobal _)  = z
+
+instance DefinerOfRegs LocalReg CmmReg where
+    foldRegsDefd _ f z (CmmLocal reg) = f z reg
+    foldRegsDefd _ _ z (CmmGlobal _)  = z
+
+instance UserOfRegs GlobalReg CmmReg where
+    foldRegsUsed _ _ z (CmmLocal _)    = z
+    foldRegsUsed _ f z (CmmGlobal reg) = f z reg
+
+instance DefinerOfRegs GlobalReg CmmReg where
+    foldRegsDefd _ _ z (CmmLocal _)    = z
+    foldRegsDefd _ f z (CmmGlobal reg) = f z reg
+
+instance Ord r => UserOfRegs r r where
+    foldRegsUsed _ f z r = f z r
+
+instance Ord r => DefinerOfRegs r r where
+    foldRegsDefd _ f z r = f z r
+
+instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
+  -- The (Ord r) in the context is necessary here
+  -- See Note [Recursive superclasses] in TcInstDcls
+  foldRegsUsed dflags f !z e = expr z e
+    where expr z (CmmLit _)          = z
+          expr z (CmmLoad addr _)    = foldRegsUsed dflags f z addr
+          expr z (CmmReg r)          = foldRegsUsed dflags f z r
+          expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs
+          expr z (CmmRegOff r _)     = foldRegsUsed dflags f z r
+          expr z (CmmStackSlot _ _)  = z
+
+instance UserOfRegs r a => UserOfRegs r [a] where
+  foldRegsUsed dflags f set as = foldl' (foldRegsUsed dflags f) set as
+  {-# INLINABLE foldRegsUsed #-}
+
+instance DefinerOfRegs r a => DefinerOfRegs r [a] where
+  foldRegsDefd dflags f set as = foldl' (foldRegsDefd dflags f) set as
+  {-# INLINABLE foldRegsDefd #-}
+
+-----------------------------------------------------------------------------
+--              Global STG registers
+-----------------------------------------------------------------------------
+
+data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
+
+-----------------------------------------------------------------------------
+--              Global STG registers
+-----------------------------------------------------------------------------
+{-
+Note [Overlapping global registers]
+
+The backend might not faithfully implement the abstraction of the STG
+machine with independent registers for different values of type
+GlobalReg. Specifically, certain pairs of registers (r1, r2) may
+overlap in the sense that a store to r1 invalidates the value in r2,
+and vice versa.
+
+Currently this occurs only on the x86_64 architecture where FloatReg n
+and DoubleReg n are assigned the same microarchitectural register, in
+order to allow functions to receive more Float# or Double# arguments
+in registers (as opposed to on the stack).
+
+There are no specific rules about which registers might overlap with
+which other registers, but presumably it's safe to assume that nothing
+will overlap with special registers like Sp or BaseReg.
+
+Use CmmUtils.regsOverlap to determine whether two GlobalRegs overlap
+on a particular platform. The instance Eq GlobalReg is syntactic
+equality of STG registers and does not take overlap into
+account. However it is still used in UserOfRegs/DefinerOfRegs and
+there are likely still bugs there, beware!
+-}
+
+data GlobalReg
+  -- Argument and return registers
+  = VanillaReg                  -- pointers, unboxed ints and chars
+        {-# UNPACK #-} !Int     -- its number
+        VGcPtr
+
+  | FloatReg            -- single-precision floating-point registers
+        {-# UNPACK #-} !Int     -- its number
+
+  | DoubleReg           -- double-precision floating-point registers
+        {-# UNPACK #-} !Int     -- its number
+
+  | LongReg             -- long int registers (64-bit, really)
+        {-# UNPACK #-} !Int     -- its number
+
+  | XmmReg                      -- 128-bit SIMD vector register
+        {-# UNPACK #-} !Int     -- its number
+
+  | YmmReg                      -- 256-bit SIMD vector register
+        {-# UNPACK #-} !Int     -- its number
+
+  | ZmmReg                      -- 512-bit SIMD vector register
+        {-# UNPACK #-} !Int     -- its number
+
+  -- STG registers
+  | Sp                  -- Stack ptr; points to last occupied stack location.
+  | SpLim               -- Stack limit
+  | Hp                  -- Heap ptr; points to last occupied heap location.
+  | HpLim               -- Heap limit register
+  | CCCS                -- Current cost-centre stack
+  | CurrentTSO          -- pointer to current thread's TSO
+  | CurrentNursery      -- pointer to allocation area
+  | HpAlloc             -- allocation count for heap check failure
+
+                -- We keep the address of some commonly-called
+                -- functions in the register table, to keep code
+                -- size down:
+  | EagerBlackholeInfo  -- stg_EAGER_BLACKHOLE_info
+  | GCEnter1            -- stg_gc_enter_1
+  | GCFun               -- stg_gc_fun
+
+  -- Base offset for the register table, used for accessing registers
+  -- which do not have real registers assigned to them.  This register
+  -- will only appear after we have expanded GlobalReg into memory accesses
+  -- (where necessary) in the native code generator.
+  | BaseReg
+
+  -- The register used by the platform for the C stack pointer. This is
+  -- a break in the STG abstraction used exclusively to setup stack unwinding
+  -- information.
+  | MachSp
+
+  -- The is a dummy register used to indicate to the stack unwinder where
+  -- a routine would return to.
+  | UnwindReturnReg
+
+  -- Base Register for PIC (position-independent code) calculations
+  -- Only used inside the native code generator. It's exact meaning differs
+  -- from platform to platform (see module PositionIndependentCode).
+  | PicBaseReg
+
+  deriving( Show )
+
+instance Eq GlobalReg where
+   VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
+   FloatReg i == FloatReg j = i==j
+   DoubleReg i == DoubleReg j = i==j
+   LongReg i == LongReg j = i==j
+   XmmReg i == XmmReg j = i==j
+   YmmReg i == YmmReg j = i==j
+   ZmmReg i == ZmmReg j = i==j
+   Sp == Sp = True
+   SpLim == SpLim = True
+   Hp == Hp = True
+   HpLim == HpLim = True
+   CCCS == CCCS = True
+   CurrentTSO == CurrentTSO = True
+   CurrentNursery == CurrentNursery = True
+   HpAlloc == HpAlloc = True
+   EagerBlackholeInfo == EagerBlackholeInfo = True
+   GCEnter1 == GCEnter1 = True
+   GCFun == GCFun = True
+   BaseReg == BaseReg = True
+   MachSp == MachSp = True
+   UnwindReturnReg == UnwindReturnReg = True
+   PicBaseReg == PicBaseReg = True
+   _r1 == _r2 = False
+
+instance Ord GlobalReg where
+   compare (VanillaReg i _) (VanillaReg j _) = compare i j
+     -- Ignore type when seeking clashes
+   compare (FloatReg i)  (FloatReg  j) = compare i j
+   compare (DoubleReg i) (DoubleReg j) = compare i j
+   compare (LongReg i)   (LongReg   j) = compare i j
+   compare (XmmReg i)    (XmmReg    j) = compare i j
+   compare (YmmReg i)    (YmmReg    j) = compare i j
+   compare (ZmmReg i)    (ZmmReg    j) = compare i j
+   compare Sp Sp = EQ
+   compare SpLim SpLim = EQ
+   compare Hp Hp = EQ
+   compare HpLim HpLim = EQ
+   compare CCCS CCCS = EQ
+   compare CurrentTSO CurrentTSO = EQ
+   compare CurrentNursery CurrentNursery = EQ
+   compare HpAlloc HpAlloc = EQ
+   compare EagerBlackholeInfo EagerBlackholeInfo = EQ
+   compare GCEnter1 GCEnter1 = EQ
+   compare GCFun GCFun = EQ
+   compare BaseReg BaseReg = EQ
+   compare MachSp MachSp = EQ
+   compare UnwindReturnReg UnwindReturnReg = EQ
+   compare PicBaseReg PicBaseReg = EQ
+   compare (VanillaReg _ _) _ = LT
+   compare _ (VanillaReg _ _) = GT
+   compare (FloatReg _) _     = LT
+   compare _ (FloatReg _)     = GT
+   compare (DoubleReg _) _    = LT
+   compare _ (DoubleReg _)    = GT
+   compare (LongReg _) _      = LT
+   compare _ (LongReg _)      = GT
+   compare (XmmReg _) _       = LT
+   compare _ (XmmReg _)       = GT
+   compare (YmmReg _) _       = LT
+   compare _ (YmmReg _)       = GT
+   compare (ZmmReg _) _       = LT
+   compare _ (ZmmReg _)       = GT
+   compare Sp _ = LT
+   compare _ Sp = GT
+   compare SpLim _ = LT
+   compare _ SpLim = GT
+   compare Hp _ = LT
+   compare _ Hp = GT
+   compare HpLim _ = LT
+   compare _ HpLim = GT
+   compare CCCS _ = LT
+   compare _ CCCS = GT
+   compare CurrentTSO _ = LT
+   compare _ CurrentTSO = GT
+   compare CurrentNursery _ = LT
+   compare _ CurrentNursery = GT
+   compare HpAlloc _ = LT
+   compare _ HpAlloc = GT
+   compare GCEnter1 _ = LT
+   compare _ GCEnter1 = GT
+   compare GCFun _ = LT
+   compare _ GCFun = GT
+   compare BaseReg _ = LT
+   compare _ BaseReg = GT
+   compare MachSp _ = LT
+   compare _ MachSp = GT
+   compare UnwindReturnReg _ = LT
+   compare _ UnwindReturnReg = GT
+   compare EagerBlackholeInfo _ = LT
+   compare _ EagerBlackholeInfo = GT
+
+-- convenient aliases
+baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,
+  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg  :: CmmReg
+baseReg = CmmGlobal BaseReg
+spReg = CmmGlobal Sp
+hpReg = CmmGlobal Hp
+hpLimReg = CmmGlobal HpLim
+spLimReg = CmmGlobal SpLim
+nodeReg = CmmGlobal node
+currentTSOReg = CmmGlobal CurrentTSO
+currentNurseryReg = CmmGlobal CurrentNursery
+hpAllocReg = CmmGlobal HpAlloc
+cccsReg = CmmGlobal CCCS
+
+node :: GlobalReg
+node = VanillaReg 1 VGcPtr
+
+globalRegType :: DynFlags -> GlobalReg -> CmmType
+globalRegType dflags (VanillaReg _ VGcPtr)    = gcWord dflags
+globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags
+globalRegType _      (FloatReg _)      = cmmFloat W32
+globalRegType _      (DoubleReg _)     = cmmFloat W64
+globalRegType _      (LongReg _)       = cmmBits W64
+globalRegType _      (XmmReg _)        = cmmVec 4 (cmmBits W32)
+globalRegType _      (YmmReg _)        = cmmVec 8 (cmmBits W32)
+globalRegType _      (ZmmReg _)        = cmmVec 16 (cmmBits W32)
+
+globalRegType dflags Hp                = gcWord dflags
+                                            -- The initialiser for all
+                                            -- dynamically allocated closures
+globalRegType dflags _                 = bWord dflags
+
+isArgReg :: GlobalReg -> Bool
+isArgReg (VanillaReg {}) = True
+isArgReg (FloatReg {})   = True
+isArgReg (DoubleReg {})  = True
+isArgReg (LongReg {})    = True
+isArgReg (XmmReg {})     = True
+isArgReg (YmmReg {})     = True
+isArgReg (ZmmReg {})     = True
+isArgReg _               = False
diff --git a/compiler/cmm/CmmImplementSwitchPlans.hs b/compiler/cmm/CmmImplementSwitchPlans.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmImplementSwitchPlans.hs
@@ -0,0 +1,92 @@
+{-# LANGUAGE GADTs #-}
+module CmmImplementSwitchPlans
+  ( cmmImplementSwitchPlans
+  )
+where
+
+import GhcPrelude
+
+import Hoopl.Block
+import BlockId
+import Cmm
+import CmmUtils
+import CmmSwitch
+import UniqSupply
+import DynFlags
+
+--
+-- This module replaces Switch statements as generated by the Stg -> Cmm
+-- transformation, which might be huge and sparse and hence unsuitable for
+-- assembly code, by proper constructs (if-then-else trees, dense jump tables).
+--
+-- The actual, abstract strategy is determined by createSwitchPlan in
+-- CmmSwitch and returned as a SwitchPlan; here is just the implementation in
+-- terms of Cmm code. See Note [Cmm Switches, the general plan] in CmmSwitch.
+--
+-- This division into different modules is both to clearly separate concerns,
+-- but also because createSwitchPlan needs access to the constructors of
+-- SwitchTargets, a data type exported abstractly by CmmSwitch.
+--
+
+-- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for
+-- code generation.
+cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph
+cmmImplementSwitchPlans dflags g
+    | targetSupportsSwitch (hscTarget dflags) = return g
+    | otherwise = do
+    blocks' <- concat `fmap` mapM (visitSwitches dflags) (toBlockList g)
+    return $ ofBlockList (g_entry g) blocks'
+
+visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock]
+visitSwitches dflags block
+  | (entry@(CmmEntry _ scope), middle, CmmSwitch expr ids) <- blockSplit block
+  = do
+    let plan = createSwitchPlan ids
+
+    (newTail, newBlocks) <- implementSwitchPlan dflags scope expr plan
+
+    let block' = entry `blockJoinHead` middle `blockAppend` newTail
+
+    return $ block' : newBlocks
+
+  | otherwise
+  = return [block]
+
+
+-- Implementing a switch plan (returning a tail block)
+implementSwitchPlan :: DynFlags -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])
+implementSwitchPlan dflags scope expr = go
+  where
+    go (Unconditionally l)
+      = return (emptyBlock `blockJoinTail` CmmBranch l, [])
+    go (JumpTable ids)
+      = return (emptyBlock `blockJoinTail` CmmSwitch expr ids, [])
+    go (IfLT signed i ids1 ids2)
+      = do
+        (bid1, newBlocks1) <- go' ids1
+        (bid2, newBlocks2) <- go' ids2
+
+        let lt | signed    = cmmSLtWord
+               | otherwise = cmmULtWord
+            scrut = lt dflags expr $ CmmLit $ mkWordCLit dflags i
+            lastNode = CmmCondBranch scrut bid1 bid2 Nothing
+            lastBlock = emptyBlock `blockJoinTail` lastNode
+        return (lastBlock, newBlocks1++newBlocks2)
+    go (IfEqual i l ids2)
+      = do
+        (bid2, newBlocks2) <- go' ids2
+
+        let scrut = cmmNeWord dflags expr $ CmmLit $ mkWordCLit dflags i
+            lastNode = CmmCondBranch scrut bid2 l Nothing
+            lastBlock = emptyBlock `blockJoinTail` lastNode
+        return (lastBlock, newBlocks2)
+
+    -- Same but returning a label to branch to
+    go' (Unconditionally l)
+      = return (l, [])
+    go' p
+      = do
+        bid <- mkBlockId `fmap` getUniqueM
+        (last, newBlocks) <- go p
+        let block = CmmEntry bid scope `blockJoinHead` last
+        return (bid, block: newBlocks)
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmInfo.hs
@@ -0,0 +1,586 @@
+{-# LANGUAGE CPP #-}
+module CmmInfo (
+  mkEmptyContInfoTable,
+  cmmToRawCmm,
+  mkInfoTable,
+  srtEscape,
+
+  -- info table accessors
+  closureInfoPtr,
+  entryCode,
+  getConstrTag,
+  cmmGetClosureType,
+  infoTable,
+  infoTableConstrTag,
+  infoTableSrtBitmap,
+  infoTableClosureType,
+  infoTablePtrs,
+  infoTableNonPtrs,
+  funInfoTable,
+  funInfoArity,
+
+  -- info table sizes and offsets
+  stdInfoTableSizeW,
+  fixedInfoTableSizeW,
+  profInfoTableSizeW,
+  maxStdInfoTableSizeW,
+  maxRetInfoTableSizeW,
+  stdInfoTableSizeB,
+  conInfoTableSizeB,
+  stdSrtBitmapOffset,
+  stdClosureTypeOffset,
+  stdPtrsOffset, stdNonPtrsOffset,
+) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Cmm
+import CmmUtils
+import CLabel
+import SMRep
+import Bitmap
+import Stream (Stream)
+import qualified Stream
+import Hoopl.Collections
+
+import Platform
+import Maybes
+import DynFlags
+import Panic
+import UniqSupply
+import MonadUtils
+import Util
+import Outputable
+
+import Data.Bits
+import Data.Word
+
+-- When we split at proc points, we need an empty info table.
+mkEmptyContInfoTable :: CLabel -> CmmInfoTable
+mkEmptyContInfoTable info_lbl
+  = CmmInfoTable { cit_lbl  = info_lbl
+                 , cit_rep  = mkStackRep []
+                 , cit_prof = NoProfilingInfo
+                 , cit_srt  = Nothing
+                 , cit_clo  = Nothing }
+
+cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()
+            -> IO (Stream IO RawCmmGroup ())
+cmmToRawCmm dflags cmms
+  = do { uniqs <- mkSplitUniqSupply 'i'
+       ; let do_one uniqs cmm = do
+                case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
+                  (b,uniqs') -> return (uniqs',b)
+                  -- NB. strictness fixes a space leak.  DO NOT REMOVE.
+       ; return (Stream.mapAccumL do_one uniqs cmms >> return ())
+       }
+
+-- Make a concrete info table, represented as a list of CmmStatic
+-- (it can't be simply a list of Word, because the SRT field is
+-- represented by a label+offset expression).
+--
+-- With tablesNextToCode, the layout is
+--      <reversed variable part>
+--      <normal forward StgInfoTable, but without
+--              an entry point at the front>
+--      <code>
+--
+-- Without tablesNextToCode, the layout of an info table is
+--      <entry label>
+--      <normal forward rest of StgInfoTable>
+--      <forward variable part>
+--
+--      See includes/rts/storage/InfoTables.h
+--
+-- For return-points these are as follows
+--
+-- Tables next to code:
+--
+--                      <srt slot>
+--                      <standard info table>
+--      ret-addr -->    <entry code (if any)>
+--
+-- Not tables-next-to-code:
+--
+--      ret-addr -->    <ptr to entry code>
+--                      <standard info table>
+--                      <srt slot>
+--
+--  * The SRT slot is only there if there is SRT info to record
+
+mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
+mkInfoTable _ (CmmData sec dat)
+  = return [CmmData sec dat]
+
+mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
+  --
+  -- in the non-tables-next-to-code case, procs can have at most a
+  -- single info table associated with the entry label of the proc.
+  --
+  | not (tablesNextToCode dflags)
+  = case topInfoTable proc of   --  must be at most one
+      -- no info table
+      Nothing ->
+         return [CmmProc mapEmpty entry_lbl live blocks]
+
+      Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
+        (top_decls, (std_info, extra_bits)) <-
+             mkInfoTableContents dflags info Nothing
+        let
+          rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info
+          rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
+        --
+        -- Separately emit info table (with the function entry
+        -- point as first entry) and the entry code
+        --
+        return (top_decls ++
+                [CmmProc mapEmpty entry_lbl live blocks,
+                 mkRODataLits info_lbl
+                    (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
+
+  --
+  -- With tables-next-to-code, we can have many info tables,
+  -- associated with some of the BlockIds of the proc.  For each info
+  -- table we need to turn it into CmmStatics, and collect any new
+  -- CmmDecls that arise from doing so.
+  --
+  | otherwise
+  = do
+    (top_declss, raw_infos) <-
+       unzip `fmap` mapM do_one_info (mapToList (info_tbls infos))
+    return (concat top_declss ++
+            [CmmProc (mapFromList raw_infos) entry_lbl live blocks])
+
+  where
+   do_one_info (lbl,itbl) = do
+     (top_decls, (std_info, extra_bits)) <-
+         mkInfoTableContents dflags itbl Nothing
+     let
+        info_lbl = cit_lbl itbl
+        rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info
+        rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
+     --
+     return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $
+                              reverse rel_extra_bits ++ rel_std_info))
+
+-----------------------------------------------------
+type InfoTableContents = ( [CmmLit]          -- The standard part
+                         , [CmmLit] )        -- The "extra bits"
+-- These Lits have *not* had mkRelativeTo applied to them
+
+mkInfoTableContents :: DynFlags
+                    -> CmmInfoTable
+                    -> Maybe Int               -- Override default RTS type tag?
+                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls
+                               InfoTableContents)       -- Info tbl + extra bits
+
+mkInfoTableContents dflags
+                    info@(CmmInfoTable { cit_lbl  = info_lbl
+                                       , cit_rep  = smrep
+                                       , cit_prof = prof
+                                       , cit_srt = srt })
+                    mb_rts_tag
+  | RTSRep rts_tag rep <- smrep
+  = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)
+    -- Completely override the rts_tag that mkInfoTableContents would
+    -- otherwise compute, with the rts_tag stored in the RTSRep
+    -- (which in turn came from a handwritten .cmm file)
+
+  | StackRep frame <- smrep
+  = do { (prof_lits, prof_data) <- mkProfLits dflags prof
+       ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt
+       ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame
+       ; let
+             std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit
+             rts_tag | Just tag <- mb_rts_tag = tag
+                     | null liveness_data     = rET_SMALL -- Fits in extra_bits
+                     | otherwise              = rET_BIG   -- Does not; extra_bits is
+                                                          -- a label
+       ; return (prof_data ++ liveness_data, (std_info, srt_label)) }
+
+  | HeapRep _ ptrs nonptrs closure_type <- smrep
+  = do { let layout  = packIntsCLit dflags ptrs nonptrs
+       ; (prof_lits, prof_data) <- mkProfLits dflags prof
+       ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt
+       ; (mb_srt_field, mb_layout, extra_bits, ct_data)
+                                <- mk_pieces closure_type srt_label
+       ; let std_info = mkStdInfoTable dflags prof_lits
+                                       (mb_rts_tag   `orElse` rtsClosureType smrep)
+                                       (mb_srt_field `orElse` srt_bitmap)
+                                       (mb_layout    `orElse` layout)
+       ; return (prof_data ++ ct_data, (std_info, extra_bits)) }
+  where
+    mk_pieces :: ClosureTypeInfo -> [CmmLit]
+              -> UniqSM ( Maybe CmmLit  -- Override the SRT field with this
+                        , Maybe CmmLit  -- Override the layout field with this
+                        , [CmmLit]           -- "Extra bits" for info table
+                        , [RawCmmDecl])      -- Auxiliary data decls
+    mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor
+      = do { (descr_lit, decl) <- newStringLit con_descr
+           ; return ( Just (CmmInt (fromIntegral con_tag)
+                                   (halfWordWidth dflags))
+                    , Nothing, [descr_lit], [decl]) }
+
+    mk_pieces Thunk srt_label
+      = return (Nothing, Nothing, srt_label, [])
+
+    mk_pieces (ThunkSelector offset) _no_srt
+      = return (Just (CmmInt 0 (halfWordWidth dflags)),
+                Just (mkWordCLit dflags (fromIntegral offset)), [], [])
+         -- Layout known (one free var); we use the layout field for offset
+
+    mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
+      = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label
+           ; return (Nothing, Nothing,  extra_bits, []) }
+
+    mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
+      = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits
+           ; let fun_type | null liveness_data = aRG_GEN
+                          | otherwise          = aRG_GEN_BIG
+                 extra_bits = [ packIntsCLit dflags fun_type arity ]
+                           ++ (if inlineSRT dflags then [] else [ srt_lit ])
+                           ++ [ liveness_lit, slow_entry ]
+           ; return (Nothing, Nothing, extra_bits, liveness_data) }
+      where
+        slow_entry = CmmLabel (toSlowEntryLbl info_lbl)
+        srt_lit = case srt_label of
+                    []          -> mkIntCLit dflags 0
+                    (lit:_rest) -> ASSERT( null _rest ) lit
+
+    mk_pieces other _ = pprPanic "mk_pieces" (ppr other)
+
+mkInfoTableContents _ _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier
+
+packIntsCLit :: DynFlags -> Int -> Int -> CmmLit
+packIntsCLit dflags a b = packHalfWordsCLit dflags
+                           (toStgHalfWord dflags (fromIntegral a))
+                           (toStgHalfWord dflags (fromIntegral b))
+
+
+mkSRTLit :: DynFlags
+         -> CLabel
+         -> Maybe CLabel
+         -> ([CmmLit],    -- srt_label, if any
+             CmmLit)      -- srt_bitmap
+mkSRTLit dflags info_lbl (Just lbl)
+  | inlineSRT dflags
+  = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth dflags))
+mkSRTLit dflags _ Nothing    = ([], CmmInt 0 (halfWordWidth dflags))
+mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth dflags))
+
+
+-- | Is the SRT offset field inline in the info table on this platform?
+--
+-- See the section "Referring to an SRT from the info table" in
+-- Note [SRTs] in CmmBuildInfoTables.hs
+inlineSRT :: DynFlags -> Bool
+inlineSRT dflags = platformArch (targetPlatform dflags) == ArchX86_64
+  && tablesNextToCode dflags
+
+-------------------------------------------------------------------------
+--
+--      Lay out the info table and handle relative offsets
+--
+-------------------------------------------------------------------------
+
+-- This function takes
+--   * the standard info table portion (StgInfoTable)
+--   * the "extra bits" (StgFunInfoExtraRev etc.)
+--   * the entry label
+--   * the code
+-- and lays them out in memory, producing a list of RawCmmDecl
+
+-------------------------------------------------------------------------
+--
+--      Position independent code
+--
+-------------------------------------------------------------------------
+-- In order to support position independent code, we mustn't put absolute
+-- references into read-only space. Info tables in the tablesNextToCode
+-- case must be in .text, which is read-only, so we doctor the CmmLits
+-- to use relative offsets instead.
+
+-- Note that this is done even when the -fPIC flag is not specified,
+-- as we want to keep binary compatibility between PIC and non-PIC.
+
+makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit
+
+makeRelativeRefTo dflags info_lbl (CmmLabel lbl)
+  | tablesNextToCode dflags
+  = CmmLabelDiffOff lbl info_lbl 0 (wordWidth dflags)
+makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)
+  | tablesNextToCode dflags
+  = CmmLabelDiffOff lbl info_lbl off (wordWidth dflags)
+makeRelativeRefTo _ _ lit = lit
+
+
+-------------------------------------------------------------------------
+--
+--              Build a liveness mask for the stack layout
+--
+-------------------------------------------------------------------------
+
+-- There are four kinds of things on the stack:
+--
+--      - pointer variables (bound in the environment)
+--      - non-pointer variables (bound in the environment)
+--      - free slots (recorded in the stack free list)
+--      - non-pointer data slots (recorded in the stack free list)
+--
+-- The first two are represented with a 'Just' of a 'LocalReg'.
+-- The last two with one or more 'Nothing' constructors.
+-- Each 'Nothing' represents one used word.
+--
+-- The head of the stack layout is the top of the stack and
+-- the least-significant bit.
+
+mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
+              -- ^ Returns:
+              --   1. The bitmap (literal value or label)
+              --   2. Large bitmap CmmData if needed
+
+mkLivenessBits dflags liveness
+  | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word
+  = do { uniq <- getUniqueM
+       ; let bitmap_lbl = mkBitmapLabel uniq
+       ; return (CmmLabel bitmap_lbl,
+                 [mkRODataLits bitmap_lbl lits]) }
+
+  | otherwise -- Fits in one word
+  = return (mkStgWordCLit dflags bitmap_word, [])
+  where
+    n_bits = length liveness
+
+    bitmap :: Bitmap
+    bitmap = mkBitmap dflags liveness
+
+    small_bitmap = case bitmap of
+                     []  -> toStgWord dflags 0
+                     [b] -> b
+                     _   -> panic "mkLiveness"
+    bitmap_word = toStgWord dflags (fromIntegral n_bits)
+              .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
+
+    lits = mkWordCLit dflags (fromIntegral n_bits)
+         : map (mkStgWordCLit dflags) bitmap
+      -- The first word is the size.  The structure must match
+      -- StgLargeBitmap in includes/rts/storage/InfoTable.h
+
+-------------------------------------------------------------------------
+--
+--      Generating a standard info table
+--
+-------------------------------------------------------------------------
+
+-- The standard bits of an info table.  This part of the info table
+-- corresponds to the StgInfoTable type defined in
+-- includes/rts/storage/InfoTables.h.
+--
+-- Its shape varies with ticky/profiling/tables next to code etc
+-- so we can't use constant offsets from Constants
+
+mkStdInfoTable
+   :: DynFlags
+   -> (CmmLit,CmmLit)   -- Closure type descr and closure descr  (profiling)
+   -> Int               -- Closure RTS tag
+   -> CmmLit            -- SRT length
+   -> CmmLit            -- layout field
+   -> [CmmLit]
+
+mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit
+ =      -- Parallel revertible-black hole field
+    prof_info
+        -- Ticky info (none at present)
+        -- Debug info (none at present)
+ ++ [layout_lit, tag, srt]
+
+ where
+    prof_info
+        | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
+        | otherwise = []
+
+    tag = CmmInt (fromIntegral cl_type) (halfWordWidth dflags)
+
+-------------------------------------------------------------------------
+--
+--      Making string literals
+--
+-------------------------------------------------------------------------
+
+mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
+mkProfLits dflags NoProfilingInfo       = return ((zeroCLit dflags, zeroCLit dflags), [])
+mkProfLits _ (ProfilingInfo td cd)
+  = do { (td_lit, td_decl) <- newStringLit td
+       ; (cd_lit, cd_decl) <- newStringLit cd
+       ; return ((td_lit,cd_lit), [td_decl,cd_decl]) }
+
+newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
+newStringLit bytes
+  = do { uniq <- getUniqueM
+       ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }
+
+
+-- Misc utils
+
+-- | Value of the srt field of an info table when using an StgLargeSRT
+srtEscape :: DynFlags -> StgHalfWord
+srtEscape dflags = toStgHalfWord dflags (-1)
+
+-------------------------------------------------------------------------
+--
+--      Accessing fields of an info table
+--
+-------------------------------------------------------------------------
+
+-- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is
+-- enabled.
+wordAligned :: DynFlags -> CmmExpr -> CmmExpr
+wordAligned dflags e
+  | gopt Opt_AlignmentSanitisation dflags
+  = CmmMachOp (MO_AlignmentCheck (wORD_SIZE dflags) (wordWidth dflags)) [e]
+  | otherwise
+  = e
+
+closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes a closure pointer and returns the info table pointer
+closureInfoPtr dflags e =
+    CmmLoad (wordAligned dflags e) (bWord dflags)
+
+entryCode :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes an info pointer (the first word of a closure)
+-- and returns its entry code
+entryCode dflags e
+ | tablesNextToCode dflags = e
+ | otherwise               = CmmLoad e (bWord dflags)
+
+getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes a closure pointer, and return the *zero-indexed*
+-- constructor tag obtained from the info table
+-- This lives in the SRT field of the info table
+-- (constructors don't need SRTs).
+getConstrTag dflags closure_ptr
+  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]
+  where
+    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
+
+cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes a closure pointer, and return the closure type
+-- obtained from the info table
+cmmGetClosureType dflags closure_ptr
+  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]
+  where
+    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
+
+infoTable :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes an info pointer (the first word of a closure)
+-- and returns a pointer to the first word of the standard-form
+-- info table, excluding the entry-code word (if present)
+infoTable dflags info_ptr
+  | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)
+  | otherwise               = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer
+
+infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes an info table pointer (from infoTable) and returns the constr tag
+-- field of the info table (same as the srt_bitmap field)
+infoTableConstrTag = infoTableSrtBitmap
+
+infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes an info table pointer (from infoTable) and returns the srt_bitmap
+-- field of the info table
+infoTableSrtBitmap dflags info_tbl
+  = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)
+
+infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes an info table pointer (from infoTable) and returns the closure type
+-- field of the info table.
+infoTableClosureType dflags info_tbl
+  = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)
+
+infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
+infoTablePtrs dflags info_tbl
+  = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)
+
+infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
+infoTableNonPtrs dflags info_tbl
+  = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)
+
+funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes the info pointer of a function,
+-- and returns a pointer to the first word of the StgFunInfoExtra struct
+-- in the info table.
+funInfoTable dflags info_ptr
+  | tablesNextToCode dflags
+  = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
+  | otherwise
+  = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
+                                -- Past the entry code pointer
+
+-- Takes the info pointer of a function, returns the function's arity
+funInfoArity :: DynFlags -> CmmExpr -> CmmExpr
+funInfoArity dflags iptr
+  = cmmToWord dflags (cmmLoadIndex dflags rep fun_info (offset `div` rep_bytes))
+  where
+   fun_info = funInfoTable dflags iptr
+   rep = cmmBits (widthFromBytes rep_bytes)
+
+   (rep_bytes, offset)
+    | tablesNextToCode dflags = ( pc_REP_StgFunInfoExtraRev_arity pc
+                                , oFFSET_StgFunInfoExtraRev_arity dflags )
+    | otherwise               = ( pc_REP_StgFunInfoExtraFwd_arity pc
+                                , oFFSET_StgFunInfoExtraFwd_arity dflags )
+
+   pc = sPlatformConstants (settings dflags)
+
+-----------------------------------------------------------------------------
+--
+--      Info table sizes & offsets
+--
+-----------------------------------------------------------------------------
+
+stdInfoTableSizeW :: DynFlags -> WordOff
+-- The size of a standard info table varies with profiling/ticky etc,
+-- so we can't get it from Constants
+-- It must vary in sync with mkStdInfoTable
+stdInfoTableSizeW dflags
+  = fixedInfoTableSizeW
+  + if gopt Opt_SccProfilingOn dflags
+       then profInfoTableSizeW
+       else 0
+
+fixedInfoTableSizeW :: WordOff
+fixedInfoTableSizeW = 2 -- layout, type
+
+profInfoTableSizeW :: WordOff
+profInfoTableSizeW = 2
+
+maxStdInfoTableSizeW :: WordOff
+maxStdInfoTableSizeW =
+  1 {- entry, when !tablesNextToCode -}
+  + fixedInfoTableSizeW
+  + profInfoTableSizeW
+
+maxRetInfoTableSizeW :: WordOff
+maxRetInfoTableSizeW =
+  maxStdInfoTableSizeW
+  + 1 {- srt label -}
+
+stdInfoTableSizeB  :: DynFlags -> ByteOff
+stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags
+
+stdSrtBitmapOffset :: DynFlags -> ByteOff
+-- Byte offset of the SRT bitmap half-word which is
+-- in the *higher-addressed* part of the type_lit
+stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags
+
+stdClosureTypeOffset :: DynFlags -> ByteOff
+-- Byte offset of the closure type half-word
+stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags
+
+stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
+stdPtrsOffset    dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
+stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags
+
+conInfoTableSizeB :: DynFlags -> Int
+conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -0,0 +1,1237 @@
+{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-}
+module CmmLayoutStack (
+       cmmLayoutStack, setInfoTableStackMap
+  ) where
+
+import GhcPrelude hiding ((<*>))
+
+import StgCmmUtils      ( callerSaveVolatileRegs ) -- XXX layering violation
+import StgCmmForeign    ( saveThreadState, loadThreadState ) -- XXX layering violation
+
+import BasicTypes
+import Cmm
+import CmmInfo
+import BlockId
+import CLabel
+import CmmUtils
+import MkGraph
+import ForeignCall
+import CmmLive
+import CmmProcPoint
+import SMRep
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Dataflow
+import Hoopl.Graph
+import Hoopl.Label
+import UniqSupply
+import StgCmmUtils      ( newTemp )
+import Maybes
+import UniqFM
+import Util
+
+import DynFlags
+import FastString
+import Outputable hiding ( isEmpty )
+import qualified Data.Set as Set
+import Control.Monad.Fix
+import Data.Array as Array
+import Data.Bits
+import Data.List (nub)
+
+{- Note [Stack Layout]
+
+The job of this pass is to
+
+ - replace references to abstract stack Areas with fixed offsets from Sp.
+
+ - replace the CmmHighStackMark constant used in the stack check with
+   the maximum stack usage of the proc.
+
+ - save any variables that are live across a call, and reload them as
+   necessary.
+
+Before stack allocation, local variables remain live across native
+calls (CmmCall{ cmm_cont = Just _ }), and after stack allocation local
+variables are clobbered by native calls.
+
+We want to do stack allocation so that as far as possible
+ - stack use is minimized, and
+ - unnecessary stack saves and loads are avoided.
+
+The algorithm we use is a variant of linear-scan register allocation,
+where the stack is our register file.
+
+We proceed in two passes, see Note [Two pass approach] for why they are not easy
+to merge into one.
+
+Pass 1:
+
+ - First, we do a liveness analysis, which annotates every block with
+   the variables live on entry to the block.
+
+ - We traverse blocks in reverse postorder DFS; that is, we visit at
+   least one predecessor of a block before the block itself.  The
+   stack layout flowing from the predecessor of the block will
+   determine the stack layout on entry to the block.
+
+ - We maintain a data structure
+
+     Map Label StackMap
+
+   which describes the contents of the stack and the stack pointer on
+   entry to each block that is a successor of a block that we have
+   visited.
+
+ - For each block we visit:
+
+    - Look up the StackMap for this block.
+
+    - If this block is a proc point (or a call continuation, if we aren't
+      splitting proc points), we need to reload all the live variables from the
+      stack - but this is done in Pass 2, which calculates more precise liveness
+      information (see description of Pass 2).
+
+    - Walk forwards through the instructions:
+      - At an assignment  x = Sp[loc]
+        - Record the fact that Sp[loc] contains x, so that we won't
+          need to save x if it ever needs to be spilled.
+      - At an assignment  x = E
+        - If x was previously on the stack, it isn't any more
+      - At the last node, if it is a call or a jump to a proc point
+        - Lay out the stack frame for the call (see setupStackFrame)
+        - emit instructions to save all the live variables
+        - Remember the StackMaps for all the successors
+        - emit an instruction to adjust Sp
+      - If the last node is a branch, then the current StackMap is the
+        StackMap for the successors.
+
+    - Manifest Sp: replace references to stack areas in this block
+      with real Sp offsets. We cannot do this until we have laid out
+      the stack area for the successors above.
+
+      In this phase we also eliminate redundant stores to the stack;
+      see elimStackStores.
+
+  - There is one important gotcha: sometimes we'll encounter a control
+    transfer to a block that we've already processed (a join point),
+    and in that case we might need to rearrange the stack to match
+    what the block is expecting. (exactly the same as in linear-scan
+    register allocation, except here we have the luxury of an infinite
+    supply of temporary variables).
+
+  - Finally, we update the magic CmmHighStackMark constant with the
+    stack usage of the function, and eliminate the whole stack check
+    if there was no stack use. (in fact this is done as part of the
+    main traversal, by feeding the high-water-mark output back in as
+    an input. I hate cyclic programming, but it's just too convenient
+    sometimes.)
+
+  There are plenty of tricky details: update frames, proc points, return
+  addresses, foreign calls, and some ad-hoc optimisations that are
+  convenient to do here and effective in common cases.  Comments in the
+  code below explain these.
+
+Pass 2:
+
+- Calculate live registers, but taking into account that nothing is live at the
+  entry to a proc point.
+
+- At each proc point and call continuation insert reloads of live registers from
+  the stack (they were saved by Pass 1).
+
+
+Note [Two pass approach]
+
+The main reason for Pass 2 is being able to insert only the reloads that are
+needed and the fact that the two passes need different liveness information.
+Let's consider an example:
+
+  .....
+   \ /
+    D   <- proc point
+   / \
+  E   F
+   \ /
+    G   <- proc point
+    |
+    X
+
+Pass 1 needs liveness assuming that local variables are preserved across calls.
+This is important because it needs to save any local registers to the stack
+(e.g., if register a is used in block X, it must be saved before any native
+call).
+However, for Pass 2, where we want to reload registers from stack (in a proc
+point), this is overly conservative and would lead us to generate reloads in D
+for things used in X, even though we're going to generate reloads in G anyway
+(since it's also a proc point).
+So Pass 2 calculates liveness knowing that nothing is live at the entry to a
+proc point. This means that in D we only need to reload things used in E or F.
+This can be quite important, for an extreme example see testcase for #3294.
+
+Merging the two passes is not trivial - Pass 2 is a backward rewrite and Pass 1
+is a forward one. Furthermore, Pass 1 is creating code that uses local registers
+(saving them before a call), which the liveness analysis for Pass 2 must see to
+be correct.
+
+-}
+
+
+-- All stack locations are expressed as positive byte offsets from the
+-- "base", which is defined to be the address above the return address
+-- on the stack on entry to this CmmProc.
+--
+-- Lower addresses have higher StackLocs.
+--
+type StackLoc = ByteOff
+
+{-
+ A StackMap describes the stack at any given point.  At a continuation
+ it has a particular layout, like this:
+
+         |             | <- base
+         |-------------|
+         |     ret0    | <- base + 8
+         |-------------|
+         .  upd frame  . <- base + sm_ret_off
+         |-------------|
+         |             |
+         .    vars     .
+         . (live/dead) .
+         |             | <- base + sm_sp - sm_args
+         |-------------|
+         |    ret1     |
+         .  ret vals   . <- base + sm_sp    (<--- Sp points here)
+         |-------------|
+
+Why do we include the final return address (ret0) in our stack map?  I
+have absolutely no idea, but it seems to be done that way consistently
+in the rest of the code generator, so I played along here. --SDM
+
+Note that we will be constructing an info table for the continuation
+(ret1), which needs to describe the stack down to, but not including,
+the update frame (or ret0, if there is no update frame).
+-}
+
+data StackMap = StackMap
+ {  sm_sp   :: StackLoc
+       -- ^ the offset of Sp relative to the base on entry
+       -- to this block.
+ ,  sm_args :: ByteOff
+       -- ^ the number of bytes of arguments in the area for this block
+       -- Defn: the offset of young(L) relative to the base is given by
+       -- (sm_sp - sm_args) of the StackMap for block L.
+ ,  sm_ret_off :: ByteOff
+       -- ^ Number of words of stack that we do not describe with an info
+       -- table, because it contains an update frame.
+ ,  sm_regs :: UniqFM (LocalReg,StackLoc)
+       -- ^ regs on the stack
+ }
+
+instance Outputable StackMap where
+  ppr StackMap{..} =
+     text "Sp = " <> int sm_sp $$
+     text "sm_args = " <> int sm_args $$
+     text "sm_ret_off = " <> int sm_ret_off $$
+     text "sm_regs = " <> pprUFM sm_regs ppr
+
+
+cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph
+               -> UniqSM (CmmGraph, LabelMap StackMap)
+cmmLayoutStack dflags procpoints entry_args
+               graph@(CmmGraph { g_entry = entry })
+  = do
+    -- We need liveness info. Dead assignments are removed later
+    -- by the sinking pass.
+    let liveness = cmmLocalLiveness dflags graph
+        blocks = revPostorder graph
+
+    (final_stackmaps, _final_high_sp, new_blocks) <-
+          mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
+            layout dflags procpoints liveness entry entry_args
+                   rec_stackmaps rec_high_sp blocks
+
+    blocks_with_reloads <-
+        insertReloadsAsNeeded dflags procpoints final_stackmaps entry new_blocks
+    new_blocks' <- mapM (lowerSafeForeignCall dflags) blocks_with_reloads
+    return (ofBlockList entry new_blocks', final_stackmaps)
+
+-- -----------------------------------------------------------------------------
+-- Pass 1
+-- -----------------------------------------------------------------------------
+
+layout :: DynFlags
+       -> LabelSet                      -- proc points
+       -> LabelMap CmmLocalLive         -- liveness
+       -> BlockId                       -- entry
+       -> ByteOff                       -- stack args on entry
+
+       -> LabelMap StackMap             -- [final] stack maps
+       -> ByteOff                       -- [final] Sp high water mark
+
+       -> [CmmBlock]                    -- [in] blocks
+
+       -> UniqSM
+          ( LabelMap StackMap           -- [out] stack maps
+          , ByteOff                     -- [out] Sp high water mark
+          , [CmmBlock]                  -- [out] new blocks
+          )
+
+layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks
+  = go blocks init_stackmap entry_args []
+  where
+    (updfr, cont_info)  = collectContInfo blocks
+
+    init_stackmap = mapSingleton entry StackMap{ sm_sp   = entry_args
+                                               , sm_args = entry_args
+                                               , sm_ret_off = updfr
+                                               , sm_regs = emptyUFM
+                                               }
+
+    go [] acc_stackmaps acc_hwm acc_blocks
+      = return (acc_stackmaps, acc_hwm, acc_blocks)
+
+    go (b0 : bs) acc_stackmaps acc_hwm acc_blocks
+      = do
+       let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0
+
+       let stack0@StackMap { sm_sp = sp0 }
+               = mapFindWithDefault
+                     (pprPanic "no stack map for" (ppr entry_lbl))
+                     entry_lbl acc_stackmaps
+
+       -- (a) Update the stack map to include the effects of
+       --     assignments in this block
+       let stack1 = foldBlockNodesF (procMiddle acc_stackmaps) middle0 stack0
+
+       -- (b) Look at the last node and if we are making a call or
+       --     jumping to a proc point, we must save the live
+       --     variables, adjust Sp, and construct the StackMaps for
+       --     each of the successor blocks.  See handleLastNode for
+       --     details.
+       (middle1, sp_off, last1, fixup_blocks, out)
+           <- handleLastNode dflags procpoints liveness cont_info
+                             acc_stackmaps stack1 tscope middle0 last0
+
+       -- (c) Manifest Sp: run over the nodes in the block and replace
+       --     CmmStackSlot with CmmLoad from Sp with a concrete offset.
+       --
+       -- our block:
+       --    middle0          -- the original middle nodes
+       --    middle1          -- live variable saves from handleLastNode
+       --    Sp = Sp + sp_off -- Sp adjustment goes here
+       --    last1            -- the last node
+       --
+       let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1
+
+       let final_blocks =
+               manifestSp dflags final_stackmaps stack0 sp0 final_sp_high
+                          entry0 middle_pre sp_off last1 fixup_blocks
+
+       let acc_stackmaps' = mapUnion acc_stackmaps out
+
+           -- If this block jumps to the GC, then we do not take its
+           -- stack usage into account for the high-water mark.
+           -- Otherwise, if the only stack usage is in the stack-check
+           -- failure block itself, we will do a redundant stack
+           -- check.  The stack has a buffer designed to accommodate
+           -- the largest amount of stack needed for calling the GC.
+           --
+           this_sp_hwm | isGcJump last0 = 0
+                       | otherwise      = sp0 - sp_off
+
+           hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out))
+
+       go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks)
+
+
+-- -----------------------------------------------------------------------------
+
+-- Not foolproof, but GCFun is the culprit we most want to catch
+isGcJump :: CmmNode O C -> Bool
+isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) })
+  = l == GCFun || l == GCEnter1
+isGcJump _something_else = False
+
+-- -----------------------------------------------------------------------------
+
+-- This doesn't seem right somehow.  We need to find out whether this
+-- proc will push some update frame material at some point, so that we
+-- can avoid using that area of the stack for spilling.  The
+-- updfr_space field of the CmmProc *should* tell us, but it doesn't
+-- (I think maybe it gets filled in later when we do proc-point
+-- splitting).
+--
+-- So we'll just take the max of all the cml_ret_offs.  This could be
+-- unnecessarily pessimistic, but probably not in the code we
+-- generate.
+
+collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff)
+collectContInfo blocks
+  = (maximum ret_offs, mapFromList (catMaybes mb_argss))
+ where
+  (mb_argss, ret_offs) = mapAndUnzip get_cont blocks
+
+  get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)
+  get_cont b =
+     case lastNode b of
+        CmmCall { cml_cont = Just l, .. }
+           -> (Just (l, cml_ret_args), cml_ret_off)
+        CmmForeignCall { .. }
+           -> (Just (succ, ret_args), ret_off)
+        _other -> (Nothing, 0)
+
+
+-- -----------------------------------------------------------------------------
+-- Updating the StackMap from middle nodes
+
+-- Look for loads from stack slots, and update the StackMap.  This is
+-- purely for optimisation reasons, so that we can avoid saving a
+-- variable back to a different stack slot if it is already on the
+-- stack.
+--
+-- This happens a lot: for example when function arguments are passed
+-- on the stack and need to be immediately saved across a call, we
+-- want to just leave them where they are on the stack.
+--
+procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap
+procMiddle stackmaps node sm
+  = case node of
+     CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _)
+       -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) }
+        where loc = getStackLoc area off stackmaps
+     CmmAssign (CmmLocal r) _other
+       -> sm { sm_regs = delFromUFM (sm_regs sm) r }
+     _other
+       -> sm
+
+getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc
+getStackLoc Old       n _         = n
+getStackLoc (Young l) n stackmaps =
+  case mapLookup l stackmaps of
+    Nothing -> pprPanic "getStackLoc" (ppr l)
+    Just sm -> sm_sp sm - sm_args sm + n
+
+
+-- -----------------------------------------------------------------------------
+-- Handling stack allocation for a last node
+
+-- We take a single last node and turn it into:
+--
+--    C1 (some statements)
+--    Sp = Sp + N
+--    C2 (some more statements)
+--    call f()          -- the actual last node
+--
+-- plus possibly some more blocks (we may have to add some fixup code
+-- between the last node and the continuation).
+--
+-- C1: is the code for saving the variables across this last node onto
+-- the stack, if the continuation is a call or jumps to a proc point.
+--
+-- C2: if the last node is a safe foreign call, we have to inject some
+-- extra code that goes *after* the Sp adjustment.
+
+handleLastNode
+   :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff
+   -> LabelMap StackMap -> StackMap -> CmmTickScope
+   -> Block CmmNode O O
+   -> CmmNode O C
+   -> UniqSM
+      ( [CmmNode O O]      -- nodes to go *before* the Sp adjustment
+      , ByteOff            -- amount to adjust Sp
+      , CmmNode O C        -- new last node
+      , [CmmBlock]         -- new blocks
+      , LabelMap StackMap  -- stackmaps for the continuations
+      )
+
+handleLastNode dflags procpoints liveness cont_info stackmaps
+               stack0@StackMap { sm_sp = sp0 } tscp middle last
+ = case last of
+    --  At each return / tail call,
+    --  adjust Sp to point to the last argument pushed, which
+    --  is cml_args, after popping any other junk from the stack.
+    CmmCall{ cml_cont = Nothing, .. } -> do
+      let sp_off = sp0 - cml_args
+      return ([], sp_off, last, [], mapEmpty)
+
+    --  At each CmmCall with a continuation:
+    CmmCall{ cml_cont = Just cont_lbl, .. } ->
+       return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off
+
+    CmmForeignCall{ succ = cont_lbl, .. } -> do
+       return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off
+            -- one word of args: the return address
+
+    CmmBranch {}     ->  handleBranches
+    CmmCondBranch {} ->  handleBranches
+    CmmSwitch {}     ->  handleBranches
+
+  where
+     -- Calls and ForeignCalls are handled the same way:
+     lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff
+              -> ( [CmmNode O O]
+                 , ByteOff
+                 , CmmNode O C
+                 , [CmmBlock]
+                 , LabelMap StackMap
+                 )
+     lastCall lbl cml_args cml_ret_args cml_ret_off
+      =  ( assignments
+         , spOffsetForCall sp0 cont_stack cml_args
+         , last
+         , [] -- no new blocks
+         , mapSingleton lbl cont_stack )
+      where
+         (assignments, cont_stack) = prepareStack lbl cml_ret_args cml_ret_off
+
+
+     prepareStack lbl cml_ret_args cml_ret_off
+       | Just cont_stack <- mapLookup lbl stackmaps
+             -- If we have already seen this continuation before, then
+             -- we just have to make the stack look the same:
+       = (fixupStack stack0 cont_stack, cont_stack)
+             -- Otherwise, we have to allocate the stack frame
+       | otherwise
+       = (save_assignments, new_cont_stack)
+       where
+        (new_cont_stack, save_assignments)
+           = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0
+
+
+     -- For other last nodes (branches), if any of the targets is a
+     -- proc point, we have to set up the stack to match what the proc
+     -- point is expecting.
+     --
+     handleBranches :: UniqSM ( [CmmNode O O]
+                                , ByteOff
+                                , CmmNode O C
+                                , [CmmBlock]
+                                , LabelMap StackMap )
+
+     handleBranches
+         -- Note [diamond proc point]
+       | Just l <- futureContinuation middle
+       , (nub $ filter (`setMember` procpoints) $ successors last) == [l]
+       = do
+         let cont_args = mapFindWithDefault 0 l cont_info
+             (assigs, cont_stack) = prepareStack l cont_args (sm_ret_off stack0)
+             out = mapFromList [ (l', cont_stack)
+                               | l' <- successors last ]
+         return ( assigs
+                , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags)
+                , last
+                , []
+                , out)
+
+        | otherwise = do
+          pps <- mapM handleBranch (successors last)
+          let lbl_map :: LabelMap Label
+              lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ]
+              fix_lbl l = mapFindWithDefault l l lbl_map
+          return ( []
+                 , 0
+                 , mapSuccessors fix_lbl last
+                 , concat [ blk | (_,_,_,blk) <- pps ]
+                 , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )
+
+     -- For each successor of this block
+     handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])
+     handleBranch l
+        --   (a) if the successor already has a stackmap, we need to
+        --       shuffle the current stack to make it look the same.
+        --       We have to insert a new block to make this happen.
+        | Just stack2 <- mapLookup l stackmaps
+        = do
+             let assigs = fixupStack stack0 stack2
+             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs
+             return (l, tmp_lbl, stack2, block)
+
+        --   (b) if the successor is a proc point, save everything
+        --       on the stack.
+        | l `setMember` procpoints
+        = do
+             let cont_args = mapFindWithDefault 0 l cont_info
+                 (stack2, assigs) =
+                      setupStackFrame dflags l liveness (sm_ret_off stack0)
+                                                        cont_args stack0
+             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs
+             return (l, tmp_lbl, stack2, block)
+
+        --   (c) otherwise, the current StackMap is the StackMap for
+        --       the continuation.  But we must remember to remove any
+        --       variables from the StackMap that are *not* live at
+        --       the destination, because this StackMap might be used
+        --       by fixupStack if this is a join point.
+        | otherwise = return (l, l, stack1, [])
+        where live = mapFindWithDefault (panic "handleBranch") l liveness
+              stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) }
+              is_live (r,_) = r `elemRegSet` live
+
+
+makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap
+               -> CmmTickScope -> [CmmNode O O]
+               -> UniqSM (Label, [CmmBlock])
+makeFixupBlock dflags sp0 l stack tscope assigs
+  | null assigs && sp0 == sm_sp stack = return (l, [])
+  | otherwise = do
+    tmp_lbl <- newBlockId
+    let sp_off = sp0 - sm_sp stack
+        block = blockJoin (CmmEntry tmp_lbl tscope)
+                          ( maybeAddSpAdj dflags sp0 sp_off
+                           $ blockFromList assigs )
+                          (CmmBranch l)
+    return (tmp_lbl, [block])
+
+
+-- Sp is currently pointing to current_sp,
+-- we want it to point to
+--    (sm_sp cont_stack - sm_args cont_stack + args)
+-- so the difference is
+--    sp0 - (sm_sp cont_stack - sm_args cont_stack + args)
+spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff
+spOffsetForCall current_sp cont_stack args
+  = current_sp - (sm_sp cont_stack - sm_args cont_stack + args)
+
+
+-- | create a sequence of assignments to establish the new StackMap,
+-- given the old StackMap.
+fixupStack :: StackMap -> StackMap -> [CmmNode O O]
+fixupStack old_stack new_stack = concatMap move new_locs
+ where
+     old_map  = sm_regs old_stack
+     new_locs = stackSlotRegs new_stack
+
+     move (r,n)
+       | Just (_,m) <- lookupUFM old_map r, n == m = []
+       | otherwise = [CmmStore (CmmStackSlot Old n)
+                               (CmmReg (CmmLocal r))]
+
+
+
+setupStackFrame
+             :: DynFlags
+             -> BlockId                 -- label of continuation
+             -> LabelMap CmmLocalLive   -- liveness
+             -> ByteOff      -- updfr
+             -> ByteOff      -- bytes of return values on stack
+             -> StackMap     -- current StackMap
+             -> (StackMap, [CmmNode O O])
+
+setupStackFrame dflags lbl liveness updfr_off ret_args stack0
+  = (cont_stack, assignments)
+  where
+      -- get the set of LocalRegs live in the continuation
+      live = mapFindWithDefault Set.empty lbl liveness
+
+      -- the stack from the base to updfr_off is off-limits.
+      -- our new stack frame contains:
+      --   * saved live variables
+      --   * the return address [young(C) + 8]
+      --   * the args for the call,
+      --     which are replaced by the return values at the return
+      --     point.
+
+      -- everything up to updfr_off is off-limits
+      -- stack1 contains updfr_off, plus everything we need to save
+      (stack1, assignments) = allocate dflags updfr_off live stack0
+
+      -- And the Sp at the continuation is:
+      --   sm_sp stack1 + ret_args
+      cont_stack = stack1{ sm_sp = sm_sp stack1 + ret_args
+                         , sm_args = ret_args
+                         , sm_ret_off = updfr_off
+                         }
+
+
+-- -----------------------------------------------------------------------------
+-- Note [diamond proc point]
+--
+-- This special case looks for the pattern we get from a typical
+-- tagged case expression:
+--
+--    Sp[young(L1)] = L1
+--    if (R1 & 7) != 0 goto L1 else goto L2
+--  L2:
+--    call [R1] returns to L1
+--  L1: live: {y}
+--    x = R1
+--
+-- If we let the generic case handle this, we get
+--
+--    Sp[-16] = L1
+--    if (R1 & 7) != 0 goto L1a else goto L2
+--  L2:
+--    Sp[-8] = y
+--    Sp = Sp - 16
+--    call [R1] returns to L1
+--  L1a:
+--    Sp[-8] = y
+--    Sp = Sp - 16
+--    goto L1
+--  L1:
+--    x = R1
+--
+-- The code for saving the live vars is duplicated in each branch, and
+-- furthermore there is an extra jump in the fast path (assuming L1 is
+-- a proc point, which it probably is if there is a heap check).
+--
+-- So to fix this we want to set up the stack frame before the
+-- conditional jump.  How do we know when to do this, and when it is
+-- safe?  The basic idea is, when we see the assignment
+--
+--   Sp[young(L)] = L
+--
+-- we know that
+--   * we are definitely heading for L
+--   * there can be no more reads from another stack area, because young(L)
+--     overlaps with it.
+--
+-- We don't necessarily know that everything live at L is live now
+-- (some might be assigned between here and the jump to L).  So we
+-- simplify and only do the optimisation when we see
+--
+--   (1) a block containing an assignment of a return address L
+--   (2) ending in a branch where one (and only) continuation goes to L,
+--       and no other continuations go to proc points.
+--
+-- then we allocate the stack frame for L at the end of the block,
+-- before the branch.
+--
+-- We could generalise (2), but that would make it a bit more
+-- complicated to handle, and this currently catches the common case.
+
+futureContinuation :: Block CmmNode O O -> Maybe BlockId
+futureContinuation middle = foldBlockNodesB f middle Nothing
+   where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId
+         f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _
+               = Just l
+         f _ r = r
+
+-- -----------------------------------------------------------------------------
+-- Saving live registers
+
+-- | Given a set of live registers and a StackMap, save all the registers
+-- on the stack and return the new StackMap and the assignments to do
+-- the saving.
+--
+allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap
+         -> (StackMap, [CmmNode O O])
+allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
+                                              , sm_regs = regs0 }
+ =
+   -- we only have to save regs that are not already in a slot
+   let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live)
+       regs1   = filterUFM (\(r,_) -> elemRegSet r live) regs0
+   in
+
+   -- make a map of the stack
+   let stack = reverse $ Array.elems $
+               accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $
+                 ret_words ++ live_words
+            where ret_words =
+                   [ (x, Occupied)
+                   | x <- [ 1 .. toWords dflags ret_off] ]
+                  live_words =
+                   [ (toWords dflags x, Occupied)
+                   | (r,off) <- nonDetEltsUFM regs1,
+                   -- See Note [Unique Determinism and code generation]
+                     let w = localRegBytes dflags r,
+                     x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ]
+   in
+
+   -- Pass over the stack: find slots to save all the new live variables,
+   -- choosing the oldest slots first (hence a foldr).
+   let
+       save slot ([], stack, n, assigs, regs) -- no more regs to save
+          = ([], slot:stack, plusW dflags n 1, assigs, regs)
+       save slot (to_save, stack, n, assigs, regs)
+          = case slot of
+               Occupied ->  (to_save, Occupied:stack, plusW dflags n 1, assigs, regs)
+               Empty
+                 | Just (stack', r, to_save') <-
+                       select_save to_save (slot:stack)
+                 -> let assig = CmmStore (CmmStackSlot Old n')
+                                         (CmmReg (CmmLocal r))
+                        n' = plusW dflags n 1
+                   in
+                        (to_save', stack', n', assig : assigs, (r,(r,n')):regs)
+
+                 | otherwise
+                 -> (to_save, slot:stack, plusW dflags n 1, assigs, regs)
+
+       -- we should do better here: right now we'll fit the smallest first,
+       -- but it would make more sense to fit the biggest first.
+       select_save :: [LocalReg] -> [StackSlot]
+                   -> Maybe ([StackSlot], LocalReg, [LocalReg])
+       select_save regs stack = go regs []
+         where go []     _no_fit = Nothing
+               go (r:rs) no_fit
+                 | Just rest <- dropEmpty words stack
+                 = Just (replicate words Occupied ++ rest, r, rs++no_fit)
+                 | otherwise
+                 = go rs (r:no_fit)
+                 where words = localRegWords dflags r
+
+       -- fill in empty slots as much as possible
+       (still_to_save, save_stack, n, save_assigs, save_regs)
+          = foldr save (to_save, [], 0, [], []) stack
+
+       -- push any remaining live vars on the stack
+       (push_sp, push_assigs, push_regs)
+          = foldr push (n, [], []) still_to_save
+          where
+              push r (n, assigs, regs)
+                = (n', assig : assigs, (r,(r,n')) : regs)
+                where
+                  n' = n + localRegBytes dflags r
+                  assig = CmmStore (CmmStackSlot Old n')
+                                   (CmmReg (CmmLocal r))
+
+       trim_sp
+          | not (null push_regs) = push_sp
+          | otherwise
+          = plusW dflags n (- length (takeWhile isEmpty save_stack))
+
+       final_regs = regs1 `addListToUFM` push_regs
+                          `addListToUFM` save_regs
+
+   in
+  -- XXX should be an assert
+   if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else
+
+   if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0  then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
+
+   ( stackmap { sm_regs = final_regs , sm_sp = trim_sp }
+   , push_assigs ++ save_assigs )
+
+
+-- -----------------------------------------------------------------------------
+-- Manifesting Sp
+
+-- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp.  The
+-- block looks like this:
+--
+--    middle_pre       -- the middle nodes
+--    Sp = Sp + sp_off -- Sp adjustment goes here
+--    last             -- the last node
+--
+-- And we have some extra blocks too (that don't contain Sp adjustments)
+--
+-- The adjustment for middle_pre will be different from that for
+-- middle_post, because the Sp adjustment intervenes.
+--
+manifestSp
+   :: DynFlags
+   -> LabelMap StackMap  -- StackMaps for other blocks
+   -> StackMap           -- StackMap for this block
+   -> ByteOff            -- Sp on entry to the block
+   -> ByteOff            -- SpHigh
+   -> CmmNode C O        -- first node
+   -> [CmmNode O O]      -- middle
+   -> ByteOff            -- sp_off
+   -> CmmNode O C        -- last node
+   -> [CmmBlock]         -- new blocks
+   -> [CmmBlock]         -- final blocks with Sp manifest
+
+manifestSp dflags stackmaps stack0 sp0 sp_high
+           first middle_pre sp_off last fixup_blocks
+  = final_block : fixup_blocks'
+  where
+    area_off = getAreaOff stackmaps
+
+    adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
+    adj_pre_sp  = mapExpDeep (areaToSp dflags sp0            sp_high area_off)
+    adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)
+
+    final_middle = maybeAddSpAdj dflags sp0 sp_off
+                 . blockFromList
+                 . map adj_pre_sp
+                 . elimStackStores stack0 stackmaps area_off
+                 $ middle_pre
+    final_last    = optStackCheck (adj_post_sp last)
+
+    final_block   = blockJoin first final_middle final_last
+
+    fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks
+
+getAreaOff :: LabelMap StackMap -> (Area -> StackLoc)
+getAreaOff _ Old = 0
+getAreaOff stackmaps (Young l) =
+  case mapLookup l stackmaps of
+    Just sm -> sm_sp sm - sm_args sm
+    Nothing -> pprPanic "getAreaOff" (ppr l)
+
+
+maybeAddSpAdj
+  :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
+maybeAddSpAdj dflags sp0 sp_off block =
+  add_initial_unwind $ add_adj_unwind $ adj block
+  where
+    adj block
+      | sp_off /= 0
+      = block `blockSnoc` CmmAssign spReg (cmmOffset dflags spExpr sp_off)
+      | otherwise = block
+    -- Add unwind pseudo-instruction at the beginning of each block to
+    -- document Sp level for debugging
+    add_initial_unwind block
+      | debugLevel dflags > 0
+      = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block
+      | otherwise
+      = block
+      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags)
+
+    -- Add unwind pseudo-instruction right after the Sp adjustment
+    -- if there is one.
+    add_adj_unwind block
+      | debugLevel dflags > 0
+      , sp_off /= 0
+      = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]
+      | otherwise
+      = block
+      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags - sp_off)
+
+{- Note [SP old/young offsets]
+
+Sp(L) is the Sp offset on entry to block L relative to the base of the
+OLD area.
+
+SpArgs(L) is the size of the young area for L, i.e. the number of
+arguments.
+
+ - in block L, each reference to [old + N] turns into
+   [Sp + Sp(L) - N]
+
+ - in block L, each reference to [young(L') + N] turns into
+   [Sp + Sp(L) - Sp(L') + SpArgs(L') - N]
+
+ - be careful with the last node of each block: Sp has already been adjusted
+   to be Sp + Sp(L) - Sp(L')
+-}
+
+areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
+
+areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)
+  = cmmOffset dflags spExpr (sp_old - area_off area - n)
+    -- Replace (CmmStackSlot area n) with an offset from Sp
+
+areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)
+  = mkIntExpr dflags sp_hwm
+    -- Replace CmmHighStackMark with the number of bytes of stack used,
+    -- the sp_hwm.   See Note [Stack usage] in StgCmmHeap
+
+areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args)
+  | falseStackCheck args
+  = zeroExpr dflags
+areaToSp dflags _ _ _ (CmmMachOp (MO_U_Ge _) args)
+  | falseStackCheck args
+  = mkIntExpr dflags 1
+    -- Replace a stack-overflow test that cannot fail with a no-op
+    -- See Note [Always false stack check]
+
+areaToSp _ _ _ _ other = other
+
+-- | Determine whether a stack check cannot fail.
+falseStackCheck :: [CmmExpr] -> Bool
+falseStackCheck [ CmmMachOp (MO_Sub _)
+                      [ CmmRegOff (CmmGlobal Sp) x_off
+                      , CmmLit (CmmInt y_lit _)]
+                , CmmReg (CmmGlobal SpLim)]
+  = fromIntegral x_off >= y_lit
+falseStackCheck _ = False
+
+-- Note [Always false stack check]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- We can optimise stack checks of the form
+--
+--   if ((Sp + x) - y < SpLim) then .. else ..
+--
+-- where are non-negative integer byte offsets.  Since we know that
+-- SpLim <= Sp (remember the stack grows downwards), this test must
+-- yield False if (x >= y), so we can rewrite the comparison to False.
+-- A subsequent sinking pass will later drop the dead code.
+-- Optimising this away depends on knowing that SpLim <= Sp, so it is
+-- really the job of the stack layout algorithm, hence we do it now.
+--
+-- The control flow optimiser may negate a conditional to increase
+-- the likelihood of a fallthrough if the branch is not taken.  But
+-- not every conditional is inverted as the control flow optimiser
+-- places some requirements on the predecessors of both branch targets.
+-- So we better look for the inverted comparison too.
+
+optStackCheck :: CmmNode O C -> CmmNode O C
+optStackCheck n = -- Note [Always false stack check]
+ case n of
+   CmmCondBranch (CmmLit (CmmInt 0 _)) _true false _ -> CmmBranch false
+   CmmCondBranch (CmmLit (CmmInt _ _)) true _false _ -> CmmBranch true
+   other -> other
+
+
+-- -----------------------------------------------------------------------------
+
+-- | Eliminate stores of the form
+--
+--    Sp[area+n] = r
+--
+-- when we know that r is already in the same slot as Sp[area+n].  We
+-- could do this in a later optimisation pass, but that would involve
+-- a separate analysis and we already have the information to hand
+-- here.  It helps clean up some extra stack stores in common cases.
+--
+-- Note that we may have to modify the StackMap as we walk through the
+-- code using procMiddle, since an assignment to a variable in the
+-- StackMap will invalidate its mapping there.
+--
+elimStackStores :: StackMap
+                -> LabelMap StackMap
+                -> (Area -> ByteOff)
+                -> [CmmNode O O]
+                -> [CmmNode O O]
+elimStackStores stackmap stackmaps area_off nodes
+  = go stackmap nodes
+  where
+    go _stackmap [] = []
+    go stackmap (n:ns)
+     = case n of
+         CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r))
+            | Just (_,off) <- lookupUFM (sm_regs stackmap) r
+            , area_off area + m == off
+            -> go stackmap ns
+         _otherwise
+            -> n : go (procMiddle stackmaps n stackmap) ns
+
+
+-- -----------------------------------------------------------------------------
+-- Update info tables to include stack liveness
+
+
+setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl
+setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
+  = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
+  where
+    fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
+       info_tbl { cit_rep = StackRep (get_liveness lbl) }
+    fix_info _ other = other
+
+    get_liveness :: BlockId -> Liveness
+    get_liveness lbl
+      = case mapLookup lbl stackmaps of
+          Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)
+          Just sm -> stackMapToLiveness dflags sm
+
+setInfoTableStackMap _ _ d = d
+
+
+stackMapToLiveness :: DynFlags -> StackMap -> Liveness
+stackMapToLiveness dflags StackMap{..} =
+   reverse $ Array.elems $
+        accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1,
+                                     toWords dflags (sm_sp - sm_args)) live_words
+   where
+     live_words =  [ (toWords dflags off, False)
+                   | (r,off) <- nonDetEltsUFM sm_regs
+                   , isGcPtrType (localRegType r) ]
+                   -- See Note [Unique Determinism and code generation]
+
+-- -----------------------------------------------------------------------------
+-- Pass 2
+-- -----------------------------------------------------------------------------
+
+insertReloadsAsNeeded
+    :: DynFlags
+    -> ProcPointSet
+    -> LabelMap StackMap
+    -> BlockId
+    -> [CmmBlock]
+    -> UniqSM [CmmBlock]
+insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do
+    toBlockList . fst <$>
+        rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty
+  where
+    rewriteCC :: RewriteFun CmmLocalLive
+    rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do
+        let entry_label = entryLabel e_node
+            stackmap = case mapLookup entry_label final_stackmaps of
+                Just sm -> sm
+                Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap"
+
+            -- Merge the liveness from successor blocks and analyse the last
+            -- node.
+            joined = gen_kill dflags x_node $!
+                         joinOutFacts liveLattice x_node fact_base0
+            -- What is live at the start of middle0.
+            live_at_middle0 = foldNodesBwdOO (gen_kill dflags) middle0 joined
+
+            -- If this is a procpoint we need to add the reloads, but only if
+            -- they're actually live. Furthermore, nothing is live at the entry
+            -- to a proc point.
+            (middle1, live_with_reloads)
+                | entry_label `setMember` procpoints
+                = let reloads = insertReloads dflags stackmap live_at_middle0
+                  in (foldr blockCons middle0 reloads, emptyRegSet)
+                | otherwise
+                = (middle0, live_at_middle0)
+
+            -- Final liveness for this block.
+            !fact_base2 = mapSingleton entry_label live_with_reloads
+
+        return (BlockCC e_node middle1 x_node, fact_base2)
+
+insertReloads :: DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]
+insertReloads dflags stackmap live =
+     [ CmmAssign (CmmLocal reg)
+                 -- This cmmOffset basically corresponds to manifesting
+                 -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]
+                 (CmmLoad (cmmOffset dflags spExpr (sp_off - reg_off))
+                          (localRegType reg))
+     | (reg, reg_off) <- stackSlotRegs stackmap
+     , reg `elemRegSet` live
+     ]
+   where
+     sp_off = sm_sp stackmap
+
+-- -----------------------------------------------------------------------------
+-- Lowering safe foreign calls
+
+{-
+Note [Lower safe foreign calls]
+
+We start with
+
+   Sp[young(L1)] = L1
+ ,-----------------------
+ | r1 = foo(x,y,z) returns to L1
+ '-----------------------
+ L1:
+   R1 = r1 -- copyIn, inserted by mkSafeCall
+   ...
+
+the stack layout algorithm will arrange to save and reload everything
+live across the call.  Our job now is to expand the call so we get
+
+   Sp[young(L1)] = L1
+ ,-----------------------
+ | SAVE_THREAD_STATE()
+ | token = suspendThread(BaseReg, interruptible)
+ | r = foo(x,y,z)
+ | BaseReg = resumeThread(token)
+ | LOAD_THREAD_STATE()
+ | R1 = r  -- copyOut
+ | jump Sp[0]
+ '-----------------------
+ L1:
+   r = R1 -- copyIn, inserted by mkSafeCall
+   ...
+
+Note the copyOut, which saves the results in the places that L1 is
+expecting them (see Note [safe foreign call convention]). Note also
+that safe foreign call is replace by an unsafe one in the Cmm graph.
+-}
+
+lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
+lowerSafeForeignCall dflags block
+  | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block
+  = do
+    -- Both 'id' and 'new_base' are KindNonPtr because they're
+    -- RTS-only objects and are not subject to garbage collection
+    id <- newTemp (bWord dflags)
+    new_base <- newTemp (cmmRegType dflags baseReg)
+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags
+    save_state_code <- saveThreadState dflags
+    load_state_code <- loadThreadState dflags
+    let suspend = save_state_code  <*>
+                  caller_save <*>
+                  mkMiddle (callSuspendThread dflags id intrbl)
+        midCall = mkUnsafeCall tgt res args
+        resume  = mkMiddle (callResumeThread new_base id) <*>
+                  -- Assign the result to BaseReg: we
+                  -- might now have a different Capability!
+                  mkAssign baseReg (CmmReg (CmmLocal new_base)) <*>
+                  caller_load <*>
+                  load_state_code
+
+        (_, regs, copyout) =
+             copyOutOflow dflags NativeReturn Jump (Young succ)
+                            (map (CmmReg . CmmLocal) res)
+                            ret_off []
+
+        -- NB. after resumeThread returns, the top-of-stack probably contains
+        -- the stack frame for succ, but it might not: if the current thread
+        -- received an exception during the call, then the stack might be
+        -- different.  Hence we continue by jumping to the top stack frame,
+        -- not by jumping to succ.
+        jump = CmmCall { cml_target    = entryCode dflags $
+                                         CmmLoad spExpr (bWord dflags)
+                       , cml_cont      = Just succ
+                       , cml_args_regs = regs
+                       , cml_args      = widthInBytes (wordWidth dflags)
+                       , cml_ret_args  = ret_args
+                       , cml_ret_off   = ret_off }
+
+    graph' <- lgraphOfAGraph ( suspend <*>
+                               midCall <*>
+                               resume  <*>
+                               copyout <*>
+                               mkLast jump, tscp)
+
+    case toBlockList graph' of
+      [one] -> let (_, middle', last) = blockSplit one
+               in return (blockJoin entry (middle `blockAppend` middle') last)
+      _ -> panic "lowerSafeForeignCall0"
+
+  -- Block doesn't end in a safe foreign call:
+  | otherwise = return block
+
+
+foreignLbl :: FastString -> CmmExpr
+foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))
+
+callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
+callSuspendThread dflags id intrbl =
+  CmmUnsafeForeignCall
+       (ForeignTarget (foreignLbl (fsLit "suspendThread"))
+        (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))
+       [id] [baseExpr, mkIntExpr dflags (fromEnum intrbl)]
+
+callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
+callResumeThread new_base id =
+  CmmUnsafeForeignCall
+       (ForeignTarget (foreignLbl (fsLit "resumeThread"))
+            (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn))
+       [new_base] [CmmReg (CmmLocal id)]
+
+-- -----------------------------------------------------------------------------
+
+plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff
+plusW dflags b w = b + w * wORD_SIZE dflags
+
+data StackSlot = Occupied | Empty
+     -- Occupied: a return address or part of an update frame
+
+instance Outputable StackSlot where
+  ppr Occupied = text "XXX"
+  ppr Empty    = text "---"
+
+dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]
+dropEmpty 0 ss           = Just ss
+dropEmpty n (Empty : ss) = dropEmpty (n-1) ss
+dropEmpty _ _            = Nothing
+
+isEmpty :: StackSlot -> Bool
+isEmpty Empty = True
+isEmpty _ = False
+
+localRegBytes :: DynFlags -> LocalReg -> ByteOff
+localRegBytes dflags r
+    = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r)))
+
+localRegWords :: DynFlags -> LocalReg -> WordOff
+localRegWords dflags = toWords dflags . localRegBytes dflags
+
+toWords :: DynFlags -> ByteOff -> WordOff
+toWords dflags x = x `quot` wORD_SIZE dflags
+
+
+stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
+stackSlotRegs sm = nonDetEltsUFM (sm_regs sm)
+  -- See Note [Unique Determinism and code generation]
diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmLex.x
@@ -0,0 +1,368 @@
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2004-2006
+--
+-- Lexer for concrete Cmm.  We try to stay close to the C-- spec, but there
+-- are a few minor differences:
+--
+--   * extra keywords for our macros, and float32/float64 types
+--   * global registers (Sp,Hp, etc.)
+--
+-----------------------------------------------------------------------------
+
+{
+module CmmLex (
+   CmmToken(..), cmmlex,
+  ) where
+
+import GhcPrelude
+
+import CmmExpr
+
+import Lexer
+import CmmMonad
+import SrcLoc
+import UniqFM
+import StringBuffer
+import FastString
+import Ctype
+import Util
+--import TRACE
+
+import Data.Word
+import Data.Char
+}
+
+$whitechar   = [\ \t\n\r\f\v\xa0] -- \xa0 is Unicode no-break space
+$white_no_nl = $whitechar # \n
+
+$ascdigit  = 0-9
+$unidigit  = \x01 -- Trick Alex into handling Unicode. See alexGetChar.
+$digit     = [$ascdigit $unidigit]
+$octit     = 0-7
+$hexit     = [$digit A-F a-f]
+
+$unilarge  = \x03 -- Trick Alex into handling Unicode. See alexGetChar.
+$asclarge  = [A-Z \xc0-\xd6 \xd8-\xde]
+$large     = [$asclarge $unilarge]
+
+$unismall  = \x04 -- Trick Alex into handling Unicode. See alexGetChar.
+$ascsmall  = [a-z \xdf-\xf6 \xf8-\xff]
+$small     = [$ascsmall $unismall \_]
+
+$namebegin = [$large $small \. \$ \@]
+$namechar  = [$namebegin $digit]
+
+@decimal     = $digit+
+@octal       = $octit+
+@hexadecimal = $hexit+
+@exponent    = [eE] [\-\+]? @decimal
+
+@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
+
+@escape      = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3})
+@strchar     = ($printable # [\"\\]) | @escape
+
+cmm :-
+
+$white_no_nl+           ;
+^\# pragma .* \n        ; -- Apple GCC 3.3 CPP generates pragmas in its output
+
+^\# (line)?             { begin line_prag }
+
+-- single-line line pragmas, of the form
+--    # <line> "<file>" <extra-stuff> \n
+<line_prag> $digit+                     { setLine line_prag1 }
+<line_prag1> \" [^\"]* \"       { setFile line_prag2 }
+<line_prag2> .*                         { pop }
+
+<0> {
+  \n                    ;
+
+  [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!]      { special_char }
+
+  ".."                  { kw CmmT_DotDot }
+  "::"                  { kw CmmT_DoubleColon }
+  ">>"                  { kw CmmT_Shr }
+  "<<"                  { kw CmmT_Shl }
+  ">="                  { kw CmmT_Ge }
+  "<="                  { kw CmmT_Le }
+  "=="                  { kw CmmT_Eq }
+  "!="                  { kw CmmT_Ne }
+  "&&"                  { kw CmmT_BoolAnd }
+  "||"                  { kw CmmT_BoolOr }
+
+  "True"                { kw CmmT_True  }
+  "False"               { kw CmmT_False }
+  "likely"              { kw CmmT_likely}
+
+  P@decimal             { global_regN (\n -> VanillaReg n VGcPtr) }
+  R@decimal             { global_regN (\n -> VanillaReg n VNonGcPtr) }
+  F@decimal             { global_regN FloatReg }
+  D@decimal             { global_regN DoubleReg }
+  L@decimal             { global_regN LongReg }
+  Sp                    { global_reg Sp }
+  SpLim                 { global_reg SpLim }
+  Hp                    { global_reg Hp }
+  HpLim                 { global_reg HpLim }
+  CCCS                  { global_reg CCCS }
+  CurrentTSO            { global_reg CurrentTSO }
+  CurrentNursery        { global_reg CurrentNursery }
+  HpAlloc               { global_reg HpAlloc }
+  BaseReg               { global_reg BaseReg }
+  MachSp                { global_reg MachSp }
+  UnwindReturnReg       { global_reg UnwindReturnReg }
+
+  $namebegin $namechar* { name }
+
+  0 @octal              { tok_octal }
+  @decimal              { tok_decimal }
+  0[xX] @hexadecimal    { tok_hexadecimal }
+  @floating_point       { strtoken tok_float }
+
+  \" @strchar* \"       { strtoken tok_string }
+}
+
+{
+data CmmToken
+  = CmmT_SpecChar  Char
+  | CmmT_DotDot
+  | CmmT_DoubleColon
+  | CmmT_Shr
+  | CmmT_Shl
+  | CmmT_Ge
+  | CmmT_Le
+  | CmmT_Eq
+  | CmmT_Ne
+  | CmmT_BoolAnd
+  | CmmT_BoolOr
+  | CmmT_CLOSURE
+  | CmmT_INFO_TABLE
+  | CmmT_INFO_TABLE_RET
+  | CmmT_INFO_TABLE_FUN
+  | CmmT_INFO_TABLE_CONSTR
+  | CmmT_INFO_TABLE_SELECTOR
+  | CmmT_else
+  | CmmT_export
+  | CmmT_section
+  | CmmT_goto
+  | CmmT_if
+  | CmmT_call
+  | CmmT_jump
+  | CmmT_foreign
+  | CmmT_never
+  | CmmT_prim
+  | CmmT_reserve
+  | CmmT_return
+  | CmmT_returns
+  | CmmT_import
+  | CmmT_switch
+  | CmmT_case
+  | CmmT_default
+  | CmmT_push
+  | CmmT_unwind
+  | CmmT_bits8
+  | CmmT_bits16
+  | CmmT_bits32
+  | CmmT_bits64
+  | CmmT_bits128
+  | CmmT_bits256
+  | CmmT_bits512
+  | CmmT_float32
+  | CmmT_float64
+  | CmmT_gcptr
+  | CmmT_GlobalReg GlobalReg
+  | CmmT_Name      FastString
+  | CmmT_String    String
+  | CmmT_Int       Integer
+  | CmmT_Float     Rational
+  | CmmT_EOF
+  | CmmT_False
+  | CmmT_True
+  | CmmT_likely
+  deriving (Show)
+
+-- -----------------------------------------------------------------------------
+-- Lexer actions
+
+type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken)
+
+begin :: Int -> Action
+begin code _span _str _len = do liftP (pushLexState code); lexToken
+
+pop :: Action
+pop _span _buf _len = liftP popLexState >> lexToken
+
+special_char :: Action
+special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf)))
+
+kw :: CmmToken -> Action
+kw tok span _buf _len = return (L span tok)
+
+global_regN :: (Int -> GlobalReg) -> Action
+global_regN con span buf len
+  = return (L span (CmmT_GlobalReg (con (fromIntegral n))))
+  where buf' = stepOn buf
+        n = parseUnsignedInteger buf' (len-1) 10 octDecDigit
+
+global_reg :: GlobalReg -> Action
+global_reg r span _buf _len = return (L span (CmmT_GlobalReg r))
+
+strtoken :: (String -> CmmToken) -> Action
+strtoken f span buf len =
+  return (L span $! (f $! lexemeToString buf len))
+
+name :: Action
+name span buf len =
+  case lookupUFM reservedWordsFM fs of
+        Just tok -> return (L span tok)
+        Nothing  -> return (L span (CmmT_Name fs))
+  where
+        fs = lexemeToFastString buf len
+
+reservedWordsFM = listToUFM $
+        map (\(x, y) -> (mkFastString x, y)) [
+        ( "CLOSURE",            CmmT_CLOSURE ),
+        ( "INFO_TABLE",         CmmT_INFO_TABLE ),
+        ( "INFO_TABLE_RET",     CmmT_INFO_TABLE_RET ),
+        ( "INFO_TABLE_FUN",     CmmT_INFO_TABLE_FUN ),
+        ( "INFO_TABLE_CONSTR",  CmmT_INFO_TABLE_CONSTR ),
+        ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),
+        ( "else",               CmmT_else ),
+        ( "export",             CmmT_export ),
+        ( "section",            CmmT_section ),
+        ( "goto",               CmmT_goto ),
+        ( "if",                 CmmT_if ),
+        ( "call",               CmmT_call ),
+        ( "jump",               CmmT_jump ),
+        ( "foreign",            CmmT_foreign ),
+        ( "never",              CmmT_never ),
+        ( "prim",               CmmT_prim ),
+        ( "reserve",            CmmT_reserve ),
+        ( "return",             CmmT_return ),
+        ( "returns",            CmmT_returns ),
+        ( "import",             CmmT_import ),
+        ( "switch",             CmmT_switch ),
+        ( "case",               CmmT_case ),
+        ( "default",            CmmT_default ),
+        ( "push",               CmmT_push ),
+        ( "unwind",             CmmT_unwind ),
+        ( "bits8",              CmmT_bits8 ),
+        ( "bits16",             CmmT_bits16 ),
+        ( "bits32",             CmmT_bits32 ),
+        ( "bits64",             CmmT_bits64 ),
+        ( "bits128",            CmmT_bits128 ),
+        ( "bits256",            CmmT_bits256 ),
+        ( "bits512",            CmmT_bits512 ),
+        ( "float32",            CmmT_float32 ),
+        ( "float64",            CmmT_float64 ),
+-- New forms
+        ( "b8",                 CmmT_bits8 ),
+        ( "b16",                CmmT_bits16 ),
+        ( "b32",                CmmT_bits32 ),
+        ( "b64",                CmmT_bits64 ),
+        ( "b128",               CmmT_bits128 ),
+        ( "b256",               CmmT_bits256 ),
+        ( "b512",               CmmT_bits512 ),
+        ( "f32",                CmmT_float32 ),
+        ( "f64",                CmmT_float64 ),
+        ( "gcptr",              CmmT_gcptr ),
+        ( "likely",             CmmT_likely),
+        ( "True",               CmmT_True  ),
+        ( "False",              CmmT_False )
+        ]
+
+tok_decimal span buf len
+  = return (L span (CmmT_Int  $! parseUnsignedInteger buf len 10 octDecDigit))
+
+tok_octal span buf len
+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))
+
+tok_hexadecimal span buf len
+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))
+
+tok_float str = CmmT_Float $! readRational str
+
+tok_string str = CmmT_String (read str)
+                 -- urk, not quite right, but it'll do for now
+
+-- -----------------------------------------------------------------------------
+-- Line pragmas
+
+setLine :: Int -> Action
+setLine code span buf len = do
+  let line = parseUnsignedInteger buf len 10 octDecDigit
+  liftP $ do
+    setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
+          -- subtract one: the line number refers to the *following* line
+    -- trace ("setLine "  ++ show line) $ do
+    popLexState >> pushLexState code
+  lexToken
+
+setFile :: Int -> Action
+setFile code span buf len = do
+  let file = lexemeToFastString (stepOn buf) (len-2)
+  liftP $ do
+    setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
+    popLexState >> pushLexState code
+  lexToken
+
+-- -----------------------------------------------------------------------------
+-- This is the top-level function: called from the parser each time a
+-- new token is to be read from the input.
+
+cmmlex :: (Located CmmToken -> PD a) -> PD a
+cmmlex cont = do
+  (L span tok) <- lexToken
+  --trace ("token: " ++ show tok) $ do
+  cont (L (RealSrcSpan span) tok)
+
+lexToken :: PD (RealLocated CmmToken)
+lexToken = do
+  inp@(loc1,buf) <- getInput
+  sc <- liftP getLexState
+  case alexScan inp sc of
+    AlexEOF -> do let span = mkRealSrcSpan loc1 loc1
+                  liftP (setLastToken span 0)
+                  return (L span CmmT_EOF)
+    AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error"
+    AlexSkip inp2 _ -> do
+        setInput inp2
+        lexToken
+    AlexToken inp2@(end,_buf2) len t -> do
+        setInput inp2
+        let span = mkRealSrcSpan loc1 end
+        span `seq` liftP (setLastToken span len)
+        t span buf len
+
+-- -----------------------------------------------------------------------------
+-- Monad stuff
+
+-- Stuff that Alex needs to know about our input type:
+type AlexInput = (RealSrcLoc,StringBuffer)
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (_,s) = prevChar s '\n'
+
+-- backwards compatibility for Alex 2.x
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar inp = case alexGetByte inp of
+                    Nothing    -> Nothing
+                    Just (b,i) -> c `seq` Just (c,i)
+                       where c = chr $ fromIntegral b
+
+alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)
+alexGetByte (loc,s)
+  | atEnd s   = Nothing
+  | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s'))
+  where c    = currentChar s
+        b    = fromIntegral $ ord $ c
+        loc' = advanceSrcLoc loc c
+        s'   = stepOn s
+
+getInput :: PD AlexInput
+getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b)
+
+setInput :: AlexInput -> PD ()
+setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } ()
+}
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmLint.hs
@@ -0,0 +1,262 @@
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2011
+--
+-- CmmLint: checking the correctness of Cmm statements and expressions
+--
+-----------------------------------------------------------------------------
+{-# LANGUAGE GADTs #-}
+module CmmLint (
+    cmmLint, cmmLintGraph
+  ) where
+
+import GhcPrelude
+
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
+import Cmm
+import CmmUtils
+import CmmLive
+import CmmSwitch (switchTargetsToList)
+import PprCmm ()
+import Outputable
+import DynFlags
+
+import Control.Monad (liftM, ap)
+
+-- Things to check:
+--     - invariant on CmmBlock in CmmExpr (see comment there)
+--     - check for branches to blocks that don't exist
+--     - check types
+
+-- -----------------------------------------------------------------------------
+-- Exported entry points:
+
+cmmLint :: (Outputable d, Outputable h)
+        => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc
+cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops
+
+cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc
+cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g
+
+runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
+runCmmLint dflags l p =
+   case unCL (l p) dflags of
+     Left err -> Just (vcat [text "Cmm lint error:",
+                             nest 2 err,
+                             text "Program was:",
+                             nest 2 (ppr p)])
+     Right _  -> Nothing
+
+lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()
+lintCmmDecl dflags (CmmProc _ lbl _ g)
+  = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g
+lintCmmDecl _ (CmmData {})
+  = return ()
+
+
+lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()
+lintCmmGraph dflags g =
+    cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks
+    -- cmmLiveness throws an error if there are registers
+    -- live on entry to the graph (i.e. undefined
+    -- variables)
+  where
+       blocks = toBlockList g
+       labels = setFromList (map entryLabel blocks)
+
+
+lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()
+lintCmmBlock labels block
+  = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do
+        let (_, middle, last) = blockSplit block
+        mapM_ lintCmmMiddle (blockToList middle)
+        lintCmmLast labels last
+
+-- -----------------------------------------------------------------------------
+-- lintCmmExpr
+
+-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
+-- byte/word mismatches.
+
+lintCmmExpr :: CmmExpr -> CmmLint CmmType
+lintCmmExpr (CmmLoad expr rep) = do
+  _ <- lintCmmExpr expr
+  -- Disabled, if we have the inlining phase before the lint phase,
+  -- we can have funny offsets due to pointer tagging. -- EZY
+  -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
+  --   cmmCheckWordAddress expr
+  return rep
+lintCmmExpr expr@(CmmMachOp op args) = do
+  dflags <- getDynFlags
+  tys <- mapM lintCmmExpr args
+  if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op
+        then cmmCheckMachOp op args tys
+        else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)
+lintCmmExpr (CmmRegOff reg offset)
+  = do dflags <- getDynFlags
+       let rep = typeWidth (cmmRegType dflags reg)
+       lintCmmExpr (CmmMachOp (MO_Add rep)
+                [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
+lintCmmExpr expr =
+  do dflags <- getDynFlags
+     return (cmmExprType dflags expr)
+
+-- Check for some common byte/word mismatches (eg. Sp + 1)
+cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
+cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
+  = cmmCheckMachOp op [reg, lit] tys
+cmmCheckMachOp op _ tys
+  = do dflags <- getDynFlags
+       return (machOpResultType dflags op tys)
+
+{-
+isOffsetOp :: MachOp -> Bool
+isOffsetOp (MO_Add _) = True
+isOffsetOp (MO_Sub _) = True
+isOffsetOp _ = False
+
+-- This expression should be an address from which a word can be loaded:
+-- check for funny-looking sub-word offsets.
+_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
+_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
+  = cmmLintDubiousWordOffset e
+_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
+  = cmmLintDubiousWordOffset e
+_cmmCheckWordAddress _
+  = return ()
+
+-- No warnings for unaligned arithmetic with the node register,
+-- which is used to extract fields from tagged constructor closures.
+notNodeReg :: CmmExpr -> Bool
+notNodeReg (CmmReg reg) | reg == nodeReg = False
+notNodeReg _                             = True
+-}
+
+lintCmmMiddle :: CmmNode O O -> CmmLint ()
+lintCmmMiddle node = case node of
+  CmmComment _ -> return ()
+  CmmTick _    -> return ()
+  CmmUnwind{}  -> return ()
+
+  CmmAssign reg expr -> do
+            dflags <- getDynFlags
+            erep <- lintCmmExpr expr
+            let reg_ty = cmmRegType dflags reg
+            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
+                then return ()
+                else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
+
+  CmmStore l r -> do
+            _ <- lintCmmExpr l
+            _ <- lintCmmExpr r
+            return ()
+
+  CmmUnsafeForeignCall target _formals actuals -> do
+            lintTarget target
+            mapM_ lintCmmExpr actuals
+
+
+lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()
+lintCmmLast labels node = case node of
+  CmmBranch id -> checkTarget id
+
+  CmmCondBranch e t f _ -> do
+            dflags <- getDynFlags
+            mapM_ checkTarget [t,f]
+            _ <- lintCmmExpr e
+            checkCond dflags e
+
+  CmmSwitch e ids -> do
+            dflags <- getDynFlags
+            mapM_ checkTarget $ switchTargetsToList ids
+            erep <- lintCmmExpr e
+            if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
+              then return ()
+              else cmmLintErr (text "switch scrutinee is not a word: " <>
+                               ppr e <> text " :: " <> ppr erep)
+
+  CmmCall { cml_target = target, cml_cont = cont } -> do
+          _ <- lintCmmExpr target
+          maybe (return ()) checkTarget cont
+
+  CmmForeignCall tgt _ args succ _ _ _ -> do
+          lintTarget tgt
+          mapM_ lintCmmExpr args
+          checkTarget succ
+ where
+  checkTarget id
+     | setMember id labels = return ()
+     | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
+
+
+lintTarget :: ForeignTarget -> CmmLint ()
+lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
+lintTarget (PrimTarget {})     = return ()
+
+
+checkCond :: DynFlags -> CmmExpr -> CmmLint ()
+checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
+checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values
+checkCond _ expr
+    = cmmLintErr (hang (text "expression is not a conditional:") 2
+                         (ppr expr))
+
+-- -----------------------------------------------------------------------------
+-- CmmLint monad
+
+-- just a basic error monad:
+
+newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }
+
+instance Functor CmmLint where
+      fmap = liftM
+
+instance Applicative CmmLint where
+      pure a = CmmLint (\_ -> Right a)
+      (<*>) = ap
+
+instance Monad CmmLint where
+  CmmLint m >>= k = CmmLint $ \dflags ->
+                                case m dflags of
+                                Left e -> Left e
+                                Right a -> unCL (k a) dflags
+
+instance HasDynFlags CmmLint where
+    getDynFlags = CmmLint (\dflags -> Right dflags)
+
+cmmLintErr :: SDoc -> CmmLint a
+cmmLintErr msg = CmmLint (\_ -> Left msg)
+
+addLintInfo :: SDoc -> CmmLint a -> CmmLint a
+addLintInfo info thing = CmmLint $ \dflags ->
+   case unCL thing dflags of
+        Left err -> Left (hang info 2 err)
+        Right a  -> Right a
+
+cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
+cmmLintMachOpErr expr argsRep opExpectsRep
+     = cmmLintErr (text "in MachOp application: " $$
+                   nest 2 (ppr  expr) $$
+                      (text "op is expecting: " <+> ppr opExpectsRep) $$
+                      (text "arguments provide: " <+> ppr argsRep))
+
+cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a
+cmmLintAssignErr stmt e_ty r_ty
+  = cmmLintErr (text "in assignment: " $$
+                nest 2 (vcat [ppr stmt,
+                              text "Reg ty:" <+> ppr r_ty,
+                              text "Rhs ty:" <+> ppr e_ty]))
+
+
+{-
+cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
+cmmLintDubiousWordOffset expr
+   = cmmLintErr (text "offset is not a multiple of words: " $$
+                 nest 2 (ppr expr))
+-}
+
diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmLive.hs
@@ -0,0 +1,93 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module CmmLive
+    ( CmmLocalLive
+    , cmmLocalLiveness
+    , cmmGlobalLiveness
+    , liveLattice
+    , gen_kill
+    )
+where
+
+import GhcPrelude
+
+import DynFlags
+import BlockId
+import Cmm
+import PprCmmExpr ()
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Dataflow
+import Hoopl.Label
+
+import Maybes
+import Outputable
+
+-----------------------------------------------------------------------------
+-- Calculating what variables are live on entry to a basic block
+-----------------------------------------------------------------------------
+
+-- | The variables live on entry to a block
+type CmmLive r = RegSet r
+type CmmLocalLive = CmmLive LocalReg
+
+-- | The dataflow lattice
+liveLattice :: Ord r => DataflowLattice (CmmLive r)
+{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-}
+{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-}
+liveLattice = DataflowLattice emptyRegSet add
+  where
+    add (OldFact old) (NewFact new) =
+        let !join = plusRegSet old new
+        in changedIf (sizeRegSet join > sizeRegSet old) join
+
+-- | A mapping from block labels to the variables live on entry
+type BlockEntryLiveness r = LabelMap (CmmLive r)
+
+-----------------------------------------------------------------------------
+-- | Calculated liveness info for a CmmGraph
+-----------------------------------------------------------------------------
+
+cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg
+cmmLocalLiveness dflags graph =
+    check $ analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty
+  where
+    entry = g_entry graph
+    check facts =
+        noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts
+
+cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg
+cmmGlobalLiveness dflags graph =
+    analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty
+
+-- | On entry to the procedure, there had better not be any LocalReg's live-in.
+noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a
+noLiveOnEntry bid in_fact x =
+  if nullRegSet in_fact then x
+  else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
+
+gen_kill
+    :: (DefinerOfRegs r n, UserOfRegs r n)
+    => DynFlags -> n -> CmmLive r -> CmmLive r
+gen_kill dflags node set =
+    let !afterKill = foldRegsDefd dflags deleteFromRegSet set node
+    in foldRegsUsed dflags extendRegSet afterKill node
+{-# INLINE gen_kill #-}
+
+xferLive
+    :: forall r.
+       ( UserOfRegs r (CmmNode O O)
+       , DefinerOfRegs r (CmmNode O O)
+       , UserOfRegs r (CmmNode O C)
+       , DefinerOfRegs r (CmmNode O C)
+       )
+    => DynFlags -> TransferFun (CmmLive r)
+xferLive dflags (BlockCC eNode middle xNode) fBase =
+    let joined = gen_kill dflags xNode $! joinOutFacts liveLattice xNode fBase
+        !result = foldNodesBwdOO (gen_kill dflags) middle joined
+    in mapSingleton (entryLabel eNode) result
+{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive LocalReg) #-}
+{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive GlobalReg) #-}
diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmMachOp.hs
@@ -0,0 +1,657 @@
+module CmmMachOp
+    ( MachOp(..)
+    , pprMachOp, isCommutableMachOp, isAssociativeMachOp
+    , isComparisonMachOp, maybeIntComparison, machOpResultType
+    , machOpArgReps, maybeInvertComparison, isFloatComparison
+
+    -- MachOp builders
+    , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
+    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
+    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe
+    , mo_wordULe, mo_wordUGt, mo_wordULt
+    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot
+    , mo_wordShl, mo_wordSShr, mo_wordUShr
+    , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
+    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord
+    , mo_u_32ToWord, mo_s_32ToWord
+    , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64
+
+    -- CallishMachOp
+    , CallishMachOp(..), callishMachOpHints
+    , pprCallishMachOp
+    , machOpMemcpyishAlign
+
+    -- Atomic read-modify-write
+    , AtomicMachOp(..)
+   )
+where
+
+import GhcPrelude
+
+import CmmType
+import Outputable
+import DynFlags
+
+-----------------------------------------------------------------------------
+--              MachOp
+-----------------------------------------------------------------------------
+
+{- |
+Machine-level primops; ones which we can reasonably delegate to the
+native code generators to handle.
+
+Most operations are parameterised by the 'Width' that they operate on.
+Some operations have separate signed and unsigned versions, and float
+and integer versions.
+-}
+
+data MachOp
+  -- Integer operations (insensitive to signed/unsigned)
+  = MO_Add Width
+  | MO_Sub Width
+  | MO_Eq  Width
+  | MO_Ne  Width
+  | MO_Mul Width                -- low word of multiply
+
+  -- Signed multiply/divide
+  | MO_S_MulMayOflo Width       -- nonzero if signed multiply overflows
+  | MO_S_Quot Width             -- signed / (same semantics as IntQuotOp)
+  | MO_S_Rem  Width             -- signed % (same semantics as IntRemOp)
+  | MO_S_Neg  Width             -- unary -
+
+  -- Unsigned multiply/divide
+  | MO_U_MulMayOflo Width       -- nonzero if unsigned multiply overflows
+  | MO_U_Quot Width             -- unsigned / (same semantics as WordQuotOp)
+  | MO_U_Rem  Width             -- unsigned % (same semantics as WordRemOp)
+
+  -- Signed comparisons
+  | MO_S_Ge Width
+  | MO_S_Le Width
+  | MO_S_Gt Width
+  | MO_S_Lt Width
+
+  -- Unsigned comparisons
+  | MO_U_Ge Width
+  | MO_U_Le Width
+  | MO_U_Gt Width
+  | MO_U_Lt Width
+
+  -- Floating point arithmetic
+  | MO_F_Add  Width
+  | MO_F_Sub  Width
+  | MO_F_Neg  Width             -- unary -
+  | MO_F_Mul  Width
+  | MO_F_Quot Width
+
+  -- Floating point comparison
+  | MO_F_Eq Width
+  | MO_F_Ne Width
+  | MO_F_Ge Width
+  | MO_F_Le Width
+  | MO_F_Gt Width
+  | MO_F_Lt Width
+
+  -- Bitwise operations.  Not all of these may be supported
+  -- at all sizes, and only integral Widths are valid.
+  | MO_And   Width
+  | MO_Or    Width
+  | MO_Xor   Width
+  | MO_Not   Width
+  | MO_Shl   Width
+  | MO_U_Shr Width      -- unsigned shift right
+  | MO_S_Shr Width      -- signed shift right
+
+  -- Conversions.  Some of these will be NOPs.
+  -- Floating-point conversions use the signed variant.
+  | MO_SF_Conv Width Width      -- Signed int -> Float
+  | MO_FS_Conv Width Width      -- Float -> Signed int
+  | MO_SS_Conv Width Width      -- Signed int -> Signed int
+  | MO_UU_Conv Width Width      -- unsigned int -> unsigned int
+  | MO_XX_Conv Width Width      -- int -> int; puts no requirements on the
+                                -- contents of upper bits when extending;
+                                -- narrowing is simply truncation; the only
+                                -- expectation is that we can recover the
+                                -- original value by applying the opposite
+                                -- MO_XX_Conv, e.g.,
+                                --   MO_XX_CONV W64 W8 (MO_XX_CONV W8 W64 x)
+                                -- is equivalent to just x.
+  | MO_FF_Conv Width Width      -- Float -> Float
+
+  -- Vector element insertion and extraction operations
+  | MO_V_Insert  Length Width   -- Insert scalar into vector
+  | MO_V_Extract Length Width   -- Extract scalar from vector
+
+  -- Integer vector operations
+  | MO_V_Add Length Width
+  | MO_V_Sub Length Width
+  | MO_V_Mul Length Width
+
+  -- Signed vector multiply/divide
+  | MO_VS_Quot Length Width
+  | MO_VS_Rem  Length Width
+  | MO_VS_Neg  Length Width
+
+  -- Unsigned vector multiply/divide
+  | MO_VU_Quot Length Width
+  | MO_VU_Rem  Length Width
+
+  -- Floting point vector element insertion and extraction operations
+  | MO_VF_Insert  Length Width   -- Insert scalar into vector
+  | MO_VF_Extract Length Width   -- Extract scalar from vector
+
+  -- Floating point vector operations
+  | MO_VF_Add  Length Width
+  | MO_VF_Sub  Length Width
+  | MO_VF_Neg  Length Width      -- unary negation
+  | MO_VF_Mul  Length Width
+  | MO_VF_Quot Length Width
+
+  -- Alignment check (for -falignment-sanitisation)
+  | MO_AlignmentCheck Int Width
+  deriving (Eq, Show)
+
+pprMachOp :: MachOp -> SDoc
+pprMachOp mo = text (show mo)
+
+
+
+-- -----------------------------------------------------------------------------
+-- Some common MachReps
+
+-- A 'wordRep' is a machine word on the target architecture
+-- Specifically, it is the size of an Int#, Word#, Addr#
+-- and the unit of allocation on the stack and the heap
+-- Any pointer is also guaranteed to be a wordRep.
+
+mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
+    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
+    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe
+    , mo_wordULe, mo_wordUGt, mo_wordULt
+    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
+    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
+    , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64
+    :: DynFlags -> MachOp
+
+mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
+    , mo_32To8, mo_32To16
+    :: MachOp
+
+mo_wordAdd      dflags = MO_Add (wordWidth dflags)
+mo_wordSub      dflags = MO_Sub (wordWidth dflags)
+mo_wordEq       dflags = MO_Eq  (wordWidth dflags)
+mo_wordNe       dflags = MO_Ne  (wordWidth dflags)
+mo_wordMul      dflags = MO_Mul (wordWidth dflags)
+mo_wordSQuot    dflags = MO_S_Quot (wordWidth dflags)
+mo_wordSRem     dflags = MO_S_Rem (wordWidth dflags)
+mo_wordSNeg     dflags = MO_S_Neg (wordWidth dflags)
+mo_wordUQuot    dflags = MO_U_Quot (wordWidth dflags)
+mo_wordURem     dflags = MO_U_Rem (wordWidth dflags)
+
+mo_wordSGe      dflags = MO_S_Ge  (wordWidth dflags)
+mo_wordSLe      dflags = MO_S_Le  (wordWidth dflags)
+mo_wordSGt      dflags = MO_S_Gt  (wordWidth dflags)
+mo_wordSLt      dflags = MO_S_Lt  (wordWidth dflags)
+
+mo_wordUGe      dflags = MO_U_Ge  (wordWidth dflags)
+mo_wordULe      dflags = MO_U_Le  (wordWidth dflags)
+mo_wordUGt      dflags = MO_U_Gt  (wordWidth dflags)
+mo_wordULt      dflags = MO_U_Lt  (wordWidth dflags)
+
+mo_wordAnd      dflags = MO_And (wordWidth dflags)
+mo_wordOr       dflags = MO_Or  (wordWidth dflags)
+mo_wordXor      dflags = MO_Xor (wordWidth dflags)
+mo_wordNot      dflags = MO_Not (wordWidth dflags)
+mo_wordShl      dflags = MO_Shl (wordWidth dflags)
+mo_wordSShr     dflags = MO_S_Shr (wordWidth dflags)
+mo_wordUShr     dflags = MO_U_Shr (wordWidth dflags)
+
+mo_u_8To32             = MO_UU_Conv W8 W32
+mo_s_8To32             = MO_SS_Conv W8 W32
+mo_u_16To32            = MO_UU_Conv W16 W32
+mo_s_16To32            = MO_SS_Conv W16 W32
+
+mo_u_8ToWord    dflags = MO_UU_Conv W8  (wordWidth dflags)
+mo_s_8ToWord    dflags = MO_SS_Conv W8  (wordWidth dflags)
+mo_u_16ToWord   dflags = MO_UU_Conv W16 (wordWidth dflags)
+mo_s_16ToWord   dflags = MO_SS_Conv W16 (wordWidth dflags)
+mo_s_32ToWord   dflags = MO_SS_Conv W32 (wordWidth dflags)
+mo_u_32ToWord   dflags = MO_UU_Conv W32 (wordWidth dflags)
+
+mo_WordTo8      dflags = MO_UU_Conv (wordWidth dflags) W8
+mo_WordTo16     dflags = MO_UU_Conv (wordWidth dflags) W16
+mo_WordTo32     dflags = MO_UU_Conv (wordWidth dflags) W32
+mo_WordTo64     dflags = MO_UU_Conv (wordWidth dflags) W64
+
+mo_32To8               = MO_UU_Conv W32 W8
+mo_32To16              = MO_UU_Conv W32 W16
+
+
+-- ----------------------------------------------------------------------------
+-- isCommutableMachOp
+
+{- |
+Returns 'True' if the MachOp has commutable arguments.  This is used
+in the platform-independent Cmm optimisations.
+
+If in doubt, return 'False'.  This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isCommutableMachOp :: MachOp -> Bool
+isCommutableMachOp mop =
+  case mop of
+        MO_Add _                -> True
+        MO_Eq _                 -> True
+        MO_Ne _                 -> True
+        MO_Mul _                -> True
+        MO_S_MulMayOflo _       -> True
+        MO_U_MulMayOflo _       -> True
+        MO_And _                -> True
+        MO_Or _                 -> True
+        MO_Xor _                -> True
+        MO_F_Add _              -> True
+        MO_F_Mul _              -> True
+        _other                  -> False
+
+-- ----------------------------------------------------------------------------
+-- isAssociativeMachOp
+
+{- |
+Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@)
+This is used in the platform-independent Cmm optimisations.
+
+If in doubt, return 'False'.  This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isAssociativeMachOp :: MachOp -> Bool
+isAssociativeMachOp mop =
+  case mop of
+        MO_Add {} -> True       -- NB: does not include
+        MO_Mul {} -> True --     floatint point!
+        MO_And {} -> True
+        MO_Or  {} -> True
+        MO_Xor {} -> True
+        _other    -> False
+
+
+-- ----------------------------------------------------------------------------
+-- isComparisonMachOp
+
+{- |
+Returns 'True' if the MachOp is a comparison.
+
+If in doubt, return False.  This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isComparisonMachOp :: MachOp -> Bool
+isComparisonMachOp mop =
+  case mop of
+    MO_Eq   _  -> True
+    MO_Ne   _  -> True
+    MO_S_Ge _  -> True
+    MO_S_Le _  -> True
+    MO_S_Gt _  -> True
+    MO_S_Lt _  -> True
+    MO_U_Ge _  -> True
+    MO_U_Le _  -> True
+    MO_U_Gt _  -> True
+    MO_U_Lt _  -> True
+    MO_F_Eq {} -> True
+    MO_F_Ne {} -> True
+    MO_F_Ge {} -> True
+    MO_F_Le {} -> True
+    MO_F_Gt {} -> True
+    MO_F_Lt {} -> True
+    _other     -> False
+
+{- |
+Returns @Just w@ if the operation is an integer comparison with width
+@w@, or @Nothing@ otherwise.
+-}
+maybeIntComparison :: MachOp -> Maybe Width
+maybeIntComparison mop =
+  case mop of
+    MO_Eq   w  -> Just w
+    MO_Ne   w  -> Just w
+    MO_S_Ge w  -> Just w
+    MO_S_Le w  -> Just w
+    MO_S_Gt w  -> Just w
+    MO_S_Lt w  -> Just w
+    MO_U_Ge w  -> Just w
+    MO_U_Le w  -> Just w
+    MO_U_Gt w  -> Just w
+    MO_U_Lt w  -> Just w
+    _ -> Nothing
+
+isFloatComparison :: MachOp -> Bool
+isFloatComparison mop =
+  case mop of
+    MO_F_Eq {} -> True
+    MO_F_Ne {} -> True
+    MO_F_Ge {} -> True
+    MO_F_Le {} -> True
+    MO_F_Gt {} -> True
+    MO_F_Lt {} -> True
+    _other     -> False
+
+-- -----------------------------------------------------------------------------
+-- Inverting conditions
+
+-- Sometimes it's useful to be able to invert the sense of a
+-- condition.  Not all conditional tests are invertible: in
+-- particular, floating point conditionals cannot be inverted, because
+-- there exist floating-point values which return False for both senses
+-- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)).
+
+maybeInvertComparison :: MachOp -> Maybe MachOp
+maybeInvertComparison op
+  = case op of  -- None of these Just cases include floating point
+        MO_Eq r   -> Just (MO_Ne r)
+        MO_Ne r   -> Just (MO_Eq r)
+        MO_U_Lt r -> Just (MO_U_Ge r)
+        MO_U_Gt r -> Just (MO_U_Le r)
+        MO_U_Le r -> Just (MO_U_Gt r)
+        MO_U_Ge r -> Just (MO_U_Lt r)
+        MO_S_Lt r -> Just (MO_S_Ge r)
+        MO_S_Gt r -> Just (MO_S_Le r)
+        MO_S_Le r -> Just (MO_S_Gt r)
+        MO_S_Ge r -> Just (MO_S_Lt r)
+        _other    -> Nothing
+
+-- ----------------------------------------------------------------------------
+-- machOpResultType
+
+{- |
+Returns the MachRep of the result of a MachOp.
+-}
+machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType
+machOpResultType dflags mop tys =
+  case mop of
+    MO_Add {}           -> ty1  -- Preserve GC-ptr-hood
+    MO_Sub {}           -> ty1  -- of first arg
+    MO_Mul    r         -> cmmBits r
+    MO_S_MulMayOflo r   -> cmmBits r
+    MO_S_Quot r         -> cmmBits r
+    MO_S_Rem  r         -> cmmBits r
+    MO_S_Neg  r         -> cmmBits r
+    MO_U_MulMayOflo r   -> cmmBits r
+    MO_U_Quot r         -> cmmBits r
+    MO_U_Rem  r         -> cmmBits r
+
+    MO_Eq {}            -> comparisonResultRep dflags
+    MO_Ne {}            -> comparisonResultRep dflags
+    MO_S_Ge {}          -> comparisonResultRep dflags
+    MO_S_Le {}          -> comparisonResultRep dflags
+    MO_S_Gt {}          -> comparisonResultRep dflags
+    MO_S_Lt {}          -> comparisonResultRep dflags
+
+    MO_U_Ge {}          -> comparisonResultRep dflags
+    MO_U_Le {}          -> comparisonResultRep dflags
+    MO_U_Gt {}          -> comparisonResultRep dflags
+    MO_U_Lt {}          -> comparisonResultRep dflags
+
+    MO_F_Add r          -> cmmFloat r
+    MO_F_Sub r          -> cmmFloat r
+    MO_F_Mul r          -> cmmFloat r
+    MO_F_Quot r         -> cmmFloat r
+    MO_F_Neg r          -> cmmFloat r
+    MO_F_Eq  {}         -> comparisonResultRep dflags
+    MO_F_Ne  {}         -> comparisonResultRep dflags
+    MO_F_Ge  {}         -> comparisonResultRep dflags
+    MO_F_Le  {}         -> comparisonResultRep dflags
+    MO_F_Gt  {}         -> comparisonResultRep dflags
+    MO_F_Lt  {}         -> comparisonResultRep dflags
+
+    MO_And {}           -> ty1  -- Used for pointer masking
+    MO_Or {}            -> ty1
+    MO_Xor {}           -> ty1
+    MO_Not   r          -> cmmBits r
+    MO_Shl   r          -> cmmBits r
+    MO_U_Shr r          -> cmmBits r
+    MO_S_Shr r          -> cmmBits r
+
+    MO_SS_Conv _ to     -> cmmBits to
+    MO_UU_Conv _ to     -> cmmBits to
+    MO_XX_Conv _ to     -> cmmBits to
+    MO_FS_Conv _ to     -> cmmBits to
+    MO_SF_Conv _ to     -> cmmFloat to
+    MO_FF_Conv _ to     -> cmmFloat to
+
+    MO_V_Insert  l w    -> cmmVec l (cmmBits w)
+    MO_V_Extract _ w    -> cmmBits w
+
+    MO_V_Add l w        -> cmmVec l (cmmBits w)
+    MO_V_Sub l w        -> cmmVec l (cmmBits w)
+    MO_V_Mul l w        -> cmmVec l (cmmBits w)
+
+    MO_VS_Quot l w      -> cmmVec l (cmmBits w)
+    MO_VS_Rem  l w      -> cmmVec l (cmmBits w)
+    MO_VS_Neg  l w      -> cmmVec l (cmmBits w)
+
+    MO_VU_Quot l w      -> cmmVec l (cmmBits w)
+    MO_VU_Rem  l w      -> cmmVec l (cmmBits w)
+
+    MO_VF_Insert  l w   -> cmmVec l (cmmFloat w)
+    MO_VF_Extract _ w   -> cmmFloat w
+
+    MO_VF_Add  l w      -> cmmVec l (cmmFloat w)
+    MO_VF_Sub  l w      -> cmmVec l (cmmFloat w)
+    MO_VF_Mul  l w      -> cmmVec l (cmmFloat w)
+    MO_VF_Quot l w      -> cmmVec l (cmmFloat w)
+    MO_VF_Neg  l w      -> cmmVec l (cmmFloat w)
+
+    MO_AlignmentCheck _ _ -> ty1
+  where
+    (ty1:_) = tys
+
+comparisonResultRep :: DynFlags -> CmmType
+comparisonResultRep = bWord  -- is it?
+
+
+-- -----------------------------------------------------------------------------
+-- machOpArgReps
+
+-- | This function is used for debugging only: we can check whether an
+-- application of a MachOp is "type-correct" by checking that the MachReps of
+-- its arguments are the same as the MachOp expects.  This is used when
+-- linting a CmmExpr.
+
+machOpArgReps :: DynFlags -> MachOp -> [Width]
+machOpArgReps dflags op =
+  case op of
+    MO_Add    r         -> [r,r]
+    MO_Sub    r         -> [r,r]
+    MO_Eq     r         -> [r,r]
+    MO_Ne     r         -> [r,r]
+    MO_Mul    r         -> [r,r]
+    MO_S_MulMayOflo r   -> [r,r]
+    MO_S_Quot r         -> [r,r]
+    MO_S_Rem  r         -> [r,r]
+    MO_S_Neg  r         -> [r]
+    MO_U_MulMayOflo r   -> [r,r]
+    MO_U_Quot r         -> [r,r]
+    MO_U_Rem  r         -> [r,r]
+
+    MO_S_Ge r           -> [r,r]
+    MO_S_Le r           -> [r,r]
+    MO_S_Gt r           -> [r,r]
+    MO_S_Lt r           -> [r,r]
+
+    MO_U_Ge r           -> [r,r]
+    MO_U_Le r           -> [r,r]
+    MO_U_Gt r           -> [r,r]
+    MO_U_Lt r           -> [r,r]
+
+    MO_F_Add r          -> [r,r]
+    MO_F_Sub r          -> [r,r]
+    MO_F_Mul r          -> [r,r]
+    MO_F_Quot r         -> [r,r]
+    MO_F_Neg r          -> [r]
+    MO_F_Eq  r          -> [r,r]
+    MO_F_Ne  r          -> [r,r]
+    MO_F_Ge  r          -> [r,r]
+    MO_F_Le  r          -> [r,r]
+    MO_F_Gt  r          -> [r,r]
+    MO_F_Lt  r          -> [r,r]
+
+    MO_And   r          -> [r,r]
+    MO_Or    r          -> [r,r]
+    MO_Xor   r          -> [r,r]
+    MO_Not   r          -> [r]
+    MO_Shl   r          -> [r, wordWidth dflags]
+    MO_U_Shr r          -> [r, wordWidth dflags]
+    MO_S_Shr r          -> [r, wordWidth dflags]
+
+    MO_SS_Conv from _   -> [from]
+    MO_UU_Conv from _   -> [from]
+    MO_XX_Conv from _   -> [from]
+    MO_SF_Conv from _   -> [from]
+    MO_FS_Conv from _   -> [from]
+    MO_FF_Conv from _   -> [from]
+
+    MO_V_Insert  l r    -> [typeWidth (vec l (cmmBits r)),r,wordWidth dflags]
+    MO_V_Extract l r    -> [typeWidth (vec l (cmmBits r)),wordWidth dflags]
+
+    MO_V_Add _ r        -> [r,r]
+    MO_V_Sub _ r        -> [r,r]
+    MO_V_Mul _ r        -> [r,r]
+
+    MO_VS_Quot _ r      -> [r,r]
+    MO_VS_Rem  _ r      -> [r,r]
+    MO_VS_Neg  _ r      -> [r]
+
+    MO_VU_Quot _ r      -> [r,r]
+    MO_VU_Rem  _ r      -> [r,r]
+
+    MO_VF_Insert  l r   -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags]
+    MO_VF_Extract l r   -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags]
+
+    MO_VF_Add  _ r      -> [r,r]
+    MO_VF_Sub  _ r      -> [r,r]
+    MO_VF_Mul  _ r      -> [r,r]
+    MO_VF_Quot _ r      -> [r,r]
+    MO_VF_Neg  _ r      -> [r]
+
+    MO_AlignmentCheck _ r -> [r]
+
+-----------------------------------------------------------------------------
+-- CallishMachOp
+-----------------------------------------------------------------------------
+
+-- CallishMachOps tend to be implemented by foreign calls in some backends,
+-- so we separate them out.  In Cmm, these can only occur in a
+-- statement position, in contrast to an ordinary MachOp which can occur
+-- anywhere in an expression.
+data CallishMachOp
+  = MO_F64_Pwr
+  | MO_F64_Sin
+  | MO_F64_Cos
+  | MO_F64_Tan
+  | MO_F64_Sinh
+  | MO_F64_Cosh
+  | MO_F64_Tanh
+  | MO_F64_Asin
+  | MO_F64_Acos
+  | MO_F64_Atan
+  | MO_F64_Asinh
+  | MO_F64_Acosh
+  | MO_F64_Atanh
+  | MO_F64_Log
+  | MO_F64_Exp
+  | MO_F64_Fabs
+  | MO_F64_Sqrt
+  | MO_F32_Pwr
+  | MO_F32_Sin
+  | MO_F32_Cos
+  | MO_F32_Tan
+  | MO_F32_Sinh
+  | MO_F32_Cosh
+  | MO_F32_Tanh
+  | MO_F32_Asin
+  | MO_F32_Acos
+  | MO_F32_Atan
+  | MO_F32_Asinh
+  | MO_F32_Acosh
+  | MO_F32_Atanh
+  | MO_F32_Log
+  | MO_F32_Exp
+  | MO_F32_Fabs
+  | MO_F32_Sqrt
+
+  | MO_UF_Conv Width
+
+  | MO_S_QuotRem Width
+  | MO_U_QuotRem Width
+  | MO_U_QuotRem2 Width
+  | MO_Add2      Width
+  | MO_AddWordC  Width
+  | MO_SubWordC  Width
+  | MO_AddIntC   Width
+  | MO_SubIntC   Width
+  | MO_U_Mul2    Width
+
+  | MO_WriteBarrier
+  | MO_Touch         -- Keep variables live (when using interior pointers)
+
+  -- Prefetch
+  | MO_Prefetch_Data Int -- Prefetch hint. May change program performance but not
+                     -- program behavior.
+                     -- the Int can be 0-3. Needs to be known at compile time
+                     -- to interact with code generation correctly.
+                     --  TODO: add support for prefetch WRITES,
+                     --  currently only exposes prefetch reads, which
+                     -- would the majority of use cases in ghc anyways
+
+
+  -- These three MachOps are parameterised by the known alignment
+  -- of the destination and source (for memcpy/memmove) pointers.
+  -- This information may be used for optimisation in backends.
+  | MO_Memcpy Int
+  | MO_Memset Int
+  | MO_Memmove Int
+  | MO_Memcmp Int
+
+  | MO_PopCnt Width
+  | MO_Pdep Width
+  | MO_Pext Width
+  | MO_Clz Width
+  | MO_Ctz Width
+
+  | MO_BSwap Width
+
+  -- Atomic read-modify-write.
+  | MO_AtomicRMW Width AtomicMachOp
+  | MO_AtomicRead Width
+  | MO_AtomicWrite Width
+  | MO_Cmpxchg Width
+  deriving (Eq, Show)
+
+-- | The operation to perform atomically.
+data AtomicMachOp =
+      AMO_Add
+    | AMO_Sub
+    | AMO_And
+    | AMO_Nand
+    | AMO_Or
+    | AMO_Xor
+      deriving (Eq, Show)
+
+pprCallishMachOp :: CallishMachOp -> SDoc
+pprCallishMachOp mo = text (show mo)
+
+callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint])
+callishMachOpHints op = case op of
+  MO_Memcpy _  -> ([], [AddrHint,AddrHint,NoHint])
+  MO_Memset _  -> ([], [AddrHint,NoHint,NoHint])
+  MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint])
+  MO_Memcmp _  -> ([], [AddrHint, AddrHint, NoHint])
+  _            -> ([],[])
+  -- empty lists indicate NoHint
+
+-- | The alignment of a 'memcpy'-ish operation.
+machOpMemcpyishAlign :: CallishMachOp -> Maybe Int
+machOpMemcpyishAlign op = case op of
+  MO_Memcpy  align -> Just align
+  MO_Memset  align -> Just align
+  MO_Memmove align -> Just align
+  MO_Memcmp  align -> Just align
+  _                -> Nothing
diff --git a/compiler/cmm/CmmMonad.hs b/compiler/cmm/CmmMonad.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmMonad.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+-- A Parser monad with access to the 'DynFlags'.
+--
+-- The 'P' monad  only has access to the subset of of 'DynFlags'
+-- required for parsing Haskell.
+
+-- The parser for C-- requires access to a lot more of the 'DynFlags',
+-- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.
+-----------------------------------------------------------------------------
+module CmmMonad (
+    PD(..)
+  , liftP
+  ) where
+
+import GhcPrelude
+
+import Control.Monad
+import qualified Control.Monad.Fail as MonadFail
+
+import DynFlags
+import Lexer
+
+newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }
+
+instance Functor PD where
+  fmap = liftM
+
+instance Applicative PD where
+  pure = returnPD
+  (<*>) = ap
+
+instance Monad PD where
+  (>>=) = thenPD
+#if !MIN_VERSION_base(4,13,0)
+  fail = MonadFail.fail
+#endif
+
+instance MonadFail.MonadFail PD where
+  fail = failPD
+
+liftP :: P a -> PD a
+liftP (P f) = PD $ \_ s -> f s
+
+returnPD :: a -> PD a
+returnPD = liftP . return
+
+thenPD :: PD a -> (a -> PD b) -> PD b
+(PD m) `thenPD` k = PD $ \d s ->
+        case m d s of
+                POk s1 a         -> unPD (k a) d s1
+                PFailed warnFn span err -> PFailed warnFn span err
+
+failPD :: String -> PD a
+failPD = liftP . fail
+
+instance HasDynFlags PD where
+   getDynFlags = PD $ \d s -> POk s d
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmNode.hs
@@ -0,0 +1,724 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+
+-- CmmNode type for representation using Hoopl graphs.
+
+module CmmNode (
+     CmmNode(..), CmmFormal, CmmActual, CmmTickish,
+     UpdFrameOffset, Convention(..),
+     ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
+     CmmReturnInfo(..),
+     mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
+     mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, mapCollectSuccessors,
+
+     -- * Tick scopes
+     CmmTickScope(..), isTickSubScope, combineTickScopes,
+  ) where
+
+import GhcPrelude hiding (succ)
+
+import CodeGen.Platform
+import CmmExpr
+import CmmSwitch
+import DynFlags
+import FastString
+import ForeignCall
+import Outputable
+import SMRep
+import CoreSyn (Tickish)
+import qualified Unique as U
+
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Collections
+import Hoopl.Label
+import Data.Maybe
+import Data.List (tails,sortBy)
+import Unique (nonDetCmpUnique)
+import Util
+
+
+------------------------
+-- CmmNode
+
+#define ULabel {-# UNPACK #-} !Label
+
+data CmmNode e x where
+  CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O
+
+  CmmComment :: FastString -> CmmNode O O
+
+    -- Tick annotation, covering Cmm code in our tick scope. We only
+    -- expect non-code @Tickish@ at this point (e.g. @SourceNote@).
+    -- See Note [CmmTick scoping details]
+  CmmTick :: !CmmTickish -> CmmNode O O
+
+    -- Unwind pseudo-instruction, encoding stack unwinding
+    -- instructions for a debugger. This describes how to reconstruct
+    -- the "old" value of a register if we want to navigate the stack
+    -- up one frame. Having unwind information for @Sp@ will allow the
+    -- debugger to "walk" the stack.
+    --
+    -- See Note [What is this unwinding business?] in Debug
+  CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O
+
+  CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O
+    -- Assign to register
+
+  CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O
+    -- Assign to memory location.  Size is
+    -- given by cmmExprType of the rhs.
+
+  CmmUnsafeForeignCall ::       -- An unsafe foreign call;
+                                -- see Note [Foreign calls]
+                                -- Like a "fat machine instruction"; can occur
+                                -- in the middle of a block
+      ForeignTarget ->          -- call target
+      [CmmFormal] ->            -- zero or more results
+      [CmmActual] ->            -- zero or more arguments
+      CmmNode O O
+      -- Semantics: clobbers any GlobalRegs for which callerSaves r == True
+      -- See Note [Unsafe foreign calls clobber caller-save registers]
+      --
+      -- Invariant: the arguments and the ForeignTarget must not
+      -- mention any registers for which CodeGen.Platform.callerSaves
+      -- is True.  See Note [Register Parameter Passing].
+
+  CmmBranch :: ULabel -> CmmNode O C
+                                   -- Goto another block in the same procedure
+
+  CmmCondBranch :: {                 -- conditional branch
+      cml_pred :: CmmExpr,
+      cml_true, cml_false :: ULabel,
+      cml_likely :: Maybe Bool       -- likely result of the conditional,
+                                     -- if known
+  } -> CmmNode O C
+
+  CmmSwitch
+    :: CmmExpr       -- Scrutinee, of some integral type
+    -> SwitchTargets -- Cases. See [Note SwitchTargets]
+    -> CmmNode O C
+
+  CmmCall :: {                -- A native call or tail call
+      cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!
+
+      cml_cont :: Maybe Label,
+          -- Label of continuation (Nothing for return or tail call)
+          --
+          -- Note [Continuation BlockId]: these BlockIds are called
+          -- Continuation BlockIds, and are the only BlockIds that can
+          -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or
+          -- (CmmStackSlot (Young b) _).
+
+      cml_args_regs :: [GlobalReg],
+          -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed
+          -- to the call.  This is essential information for the
+          -- native code generator's register allocator; without
+          -- knowing which GlobalRegs are live it has to assume that
+          -- they are all live.  This list should only include
+          -- GlobalRegs that are mapped to real machine registers on
+          -- the target platform.
+
+      cml_args :: ByteOff,
+          -- Byte offset, from the *old* end of the Area associated with
+          -- the Label (if cml_cont = Nothing, then Old area), of
+          -- youngest outgoing arg.  Set the stack pointer to this before
+          -- transferring control.
+          -- (NB: an update frame might also have been stored in the Old
+          --      area, but it'll be in an older part than the args.)
+
+      cml_ret_args :: ByteOff,
+          -- For calls *only*, the byte offset for youngest returned value
+          -- This is really needed at the *return* point rather than here
+          -- at the call, but in practice it's convenient to record it here.
+
+      cml_ret_off :: ByteOff
+        -- For calls *only*, the byte offset of the base of the frame that
+        -- must be described by the info table for the return point.
+        -- The older words are an update frames, which have their own
+        -- info-table and layout information
+
+        -- From a liveness point of view, the stack words older than
+        -- cml_ret_off are treated as live, even if the sequel of
+        -- the call goes into a loop.
+  } -> CmmNode O C
+
+  CmmForeignCall :: {           -- A safe foreign call; see Note [Foreign calls]
+                                -- Always the last node of a block
+      tgt   :: ForeignTarget,   -- call target and convention
+      res   :: [CmmFormal],     -- zero or more results
+      args  :: [CmmActual],     -- zero or more arguments; see Note [Register parameter passing]
+      succ  :: ULabel,          -- Label of continuation
+      ret_args :: ByteOff,      -- same as cml_ret_args
+      ret_off :: ByteOff,       -- same as cml_ret_off
+      intrbl:: Bool             -- whether or not the call is interruptible
+  } -> CmmNode O C
+
+{- Note [Foreign calls]
+~~~~~~~~~~~~~~~~~~~~~~~
+A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
+a CmmForeignCall call is used for *safe* foreign calls.
+
+Unsafe ones are mostly easy: think of them as a "fat machine
+instruction".  In particular, they do *not* kill all live registers,
+just the registers they return to (there was a bit of code in GHC that
+conservatively assumed otherwise.)  However, see [Register parameter passing].
+
+Safe ones are trickier.  A safe foreign call
+     r = f(x)
+ultimately expands to
+     push "return address"      -- Never used to return to;
+                                -- just points an info table
+     save registers into TSO
+     call suspendThread
+     r = f(x)                   -- Make the call
+     call resumeThread
+     restore registers
+     pop "return address"
+We cannot "lower" a safe foreign call to this sequence of Cmms, because
+after we've saved Sp all the Cmm optimiser's assumptions are broken.
+
+Note that a safe foreign call needs an info table.
+
+So Safe Foreign Calls must remain as last nodes until the stack is
+made manifest in CmmLayoutStack, where they are lowered into the above
+sequence.
+-}
+
+{- Note [Unsafe foreign calls clobber caller-save registers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A foreign call is defined to clobber any GlobalRegs that are mapped to
+caller-saves machine registers (according to the prevailing C ABI).
+StgCmmUtils.callerSaves tells you which GlobalRegs are caller-saves.
+
+This is a design choice that makes it easier to generate code later.
+We could instead choose to say that foreign calls do *not* clobber
+caller-saves regs, but then we would have to figure out which regs
+were live across the call later and insert some saves/restores.
+
+Furthermore when we generate code we never have any GlobalRegs live
+across a call, because they are always copied-in to LocalRegs and
+copied-out again before making a call/jump.  So all we have to do is
+avoid any code motion that would make a caller-saves GlobalReg live
+across a foreign call during subsequent optimisations.
+-}
+
+{- Note [Register parameter passing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+On certain architectures, some registers are utilized for parameter
+passing in the C calling convention.  For example, in x86-64 Linux
+convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for
+argument passing.  These are registers R3-R6, which our generated
+code may also be using; as a result, it's necessary to save these
+values before doing a foreign call.  This is done during initial
+code generation in callerSaveVolatileRegs in StgCmmUtils.hs.  However,
+one result of doing this is that the contents of these registers
+may mysteriously change if referenced inside the arguments.  This
+is dangerous, so you'll need to disable inlining much in the same
+way is done in cmm/CmmOpt.hs currently.  We should fix this!
+-}
+
+---------------------------------------------
+-- Eq instance of CmmNode
+
+deriving instance Eq (CmmNode e x)
+
+----------------------------------------------
+-- Hoopl instances of CmmNode
+
+instance NonLocal CmmNode where
+  entryLabel (CmmEntry l _) = l
+
+  successors (CmmBranch l) = [l]
+  successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
+  successors (CmmSwitch _ ids) = switchTargetsToList ids
+  successors (CmmCall {cml_cont=l}) = maybeToList l
+  successors (CmmForeignCall {succ=l}) = [l]
+
+
+--------------------------------------------------
+-- Various helper types
+
+type CmmActual = CmmExpr
+type CmmFormal = LocalReg
+
+type UpdFrameOffset = ByteOff
+
+-- | A convention maps a list of values (function arguments or return
+-- values) to registers or stack locations.
+data Convention
+  = NativeDirectCall
+       -- ^ top-level Haskell functions use @NativeDirectCall@, which
+       -- maps arguments to registers starting with R2, according to
+       -- how many registers are available on the platform.  This
+       -- convention ignores R1, because for a top-level function call
+       -- the function closure is implicit, and doesn't need to be passed.
+  | NativeNodeCall
+       -- ^ non-top-level Haskell functions, which pass the address of
+       -- the function closure in R1 (regardless of whether R1 is a
+       -- real register or not), and the rest of the arguments in
+       -- registers or on the stack.
+  | NativeReturn
+       -- ^ a native return.  The convention for returns depends on
+       -- how many values are returned: for just one value returned,
+       -- the appropriate register is used (R1, F1, etc.). regardless
+       -- of whether it is a real register or not.  For multiple
+       -- values returned, they are mapped to registers or the stack.
+  | Slow
+       -- ^ Slow entry points: all args pushed on the stack
+  | GC
+       -- ^ Entry to the garbage collector: uses the node reg!
+       -- (TODO: I don't think we need this --SDM)
+  deriving( Eq )
+
+data ForeignConvention
+  = ForeignConvention
+        CCallConv               -- Which foreign-call convention
+        [ForeignHint]           -- Extra info about the args
+        [ForeignHint]           -- Extra info about the result
+        CmmReturnInfo
+  deriving Eq
+
+data CmmReturnInfo
+  = CmmMayReturn
+  | CmmNeverReturns
+  deriving ( Eq )
+
+data ForeignTarget        -- The target of a foreign call
+  = ForeignTarget                -- A foreign procedure
+        CmmExpr                  -- Its address
+        ForeignConvention        -- Its calling convention
+  | PrimTarget            -- A possibly-side-effecting machine operation
+        CallishMachOp            -- Which one
+  deriving Eq
+
+foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
+foreignTargetHints target
+  = ( res_hints ++ repeat NoHint
+    , arg_hints ++ repeat NoHint )
+  where
+    (res_hints, arg_hints) =
+       case target of
+          PrimTarget op -> callishMachOpHints op
+          ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->
+             (res_hints, arg_hints)
+
+--------------------------------------------------
+-- Instances of register and slot users / definers
+
+instance UserOfRegs LocalReg (CmmNode e x) where
+  foldRegsUsed dflags f !z n = case n of
+    CmmAssign _ expr -> fold f z expr
+    CmmStore addr rval -> fold f (fold f z addr) rval
+    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
+    CmmCondBranch expr _ _ _ -> fold f z expr
+    CmmSwitch expr _ -> fold f z expr
+    CmmCall {cml_target=tgt} -> fold f z tgt
+    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
+    _ -> z
+    where fold :: forall a b. UserOfRegs LocalReg a
+               => (b -> LocalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsUsed dflags f z n
+
+instance UserOfRegs GlobalReg (CmmNode e x) where
+  foldRegsUsed dflags f !z n = case n of
+    CmmAssign _ expr -> fold f z expr
+    CmmStore addr rval -> fold f (fold f z addr) rval
+    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
+    CmmCondBranch expr _ _ _ -> fold f z expr
+    CmmSwitch expr _ -> fold f z expr
+    CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt
+    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
+    _ -> z
+    where fold :: forall a b.  UserOfRegs GlobalReg a
+               => (b -> GlobalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsUsed dflags f z n
+
+instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where
+  -- The (Ord r) in the context is necessary here
+  -- See Note [Recursive superclasses] in TcInstDcls
+  foldRegsUsed _      _ !z (PrimTarget _)      = z
+  foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e
+
+instance DefinerOfRegs LocalReg (CmmNode e x) where
+  foldRegsDefd dflags f !z n = case n of
+    CmmAssign lhs _ -> fold f z lhs
+    CmmUnsafeForeignCall _ fs _ -> fold f z fs
+    CmmForeignCall {res=res} -> fold f z res
+    _ -> z
+    where fold :: forall a b. DefinerOfRegs LocalReg a
+               => (b -> LocalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsDefd dflags f z n
+
+instance DefinerOfRegs GlobalReg (CmmNode e x) where
+  foldRegsDefd dflags f !z n = case n of
+    CmmAssign lhs _ -> fold f z lhs
+    CmmUnsafeForeignCall tgt _ _  -> fold f z (foreignTargetRegs tgt)
+    CmmCall        {} -> fold f z activeRegs
+    CmmForeignCall {} -> fold f z activeRegs
+                      -- See Note [Safe foreign calls clobber STG registers]
+    _ -> z
+    where fold :: forall a b. DefinerOfRegs GlobalReg a
+               => (b -> GlobalReg -> b) -> b -> a -> b
+          fold f z n = foldRegsDefd dflags f z n
+
+          platform = targetPlatform dflags
+          activeRegs = activeStgRegs platform
+          activeCallerSavesRegs = filter (callerSaves platform) activeRegs
+
+          foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []
+          foreignTargetRegs _ = activeCallerSavesRegs
+
+-- Note [Safe foreign calls clobber STG registers]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- During stack layout phase every safe foreign call is expanded into a block
+-- that contains unsafe foreign call (instead of safe foreign call) and ends
+-- with a normal call (See Note [Foreign calls]). This means that we must
+-- treat safe foreign call as if it was a normal call (because eventually it
+-- will be). This is important if we try to run sinking pass before stack
+-- layout phase. Consider this example of what might go wrong (this is cmm
+-- code from stablename001 test). Here is code after common block elimination
+-- (before stack layout):
+--
+--  c1q6:
+--      _s1pf::P64 = R1;
+--      _c1q8::I64 = performMajorGC;
+--      I64[(young<c1q9> + 8)] = c1q9;
+--      foreign call "ccall" arg hints:  []  result hints:  [] (_c1q8::I64)(...)
+--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
+--  c1q9:
+--      I64[(young<c1qb> + 8)] = c1qb;
+--      R1 = _s1pc::P64;
+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- If we run sinking pass now (still before stack layout) we will get this:
+--
+--  c1q6:
+--      I64[(young<c1q9> + 8)] = c1q9;
+--      foreign call "ccall" arg hints:  []  result hints:  [] performMajorGC(...)
+--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;
+--  c1q9:
+--      I64[(young<c1qb> + 8)] = c1qb;
+--      _s1pf::P64 = R1;         <------ _s1pf sunk past safe foreign call
+--      R1 = _s1pc::P64;
+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- Notice that _s1pf was sunk past a foreign call. When we run stack layout
+-- safe call to performMajorGC will be turned into:
+--
+--  c1q6:
+--      _s1pc::P64 = P64[Sp + 8];
+--      I64[Sp - 8] = c1q9;
+--      Sp = Sp - 8;
+--      I64[I64[CurrentTSO + 24] + 16] = Sp;
+--      P64[CurrentNursery + 8] = Hp + 8;
+--      (_u1qI::I64) = call "ccall" arg hints:  [PtrHint,]
+--                           result hints:  [PtrHint] suspendThread(BaseReg, 0);
+--      call "ccall" arg hints:  []  result hints:  [] performMajorGC();
+--      (_u1qJ::I64) = call "ccall" arg hints:  [PtrHint]
+--                           result hints:  [PtrHint] resumeThread(_u1qI::I64);
+--      BaseReg = _u1qJ::I64;
+--      _u1qK::P64 = CurrentTSO;
+--      _u1qL::P64 = I64[_u1qK::P64 + 24];
+--      Sp = I64[_u1qL::P64 + 16];
+--      SpLim = _u1qL::P64 + 192;
+--      HpAlloc = 0;
+--      Hp = I64[CurrentNursery + 8] - 8;
+--      HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);
+--      call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;
+--  c1q9:
+--      I64[(young<c1qb> + 8)] = c1qb;
+--      _s1pf::P64 = R1;         <------ INCORRECT!
+--      R1 = _s1pc::P64;
+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;
+--
+-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that
+-- call is clearly incorrect. This is what would happen if we assumed that
+-- safe foreign call has the same semantics as unsafe foreign call. To prevent
+-- this we need to treat safe foreign call as if was normal call.
+
+-----------------------------------
+-- mapping Expr in CmmNode
+
+mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
+mapForeignTarget exp   (ForeignTarget e c) = ForeignTarget (exp e) c
+mapForeignTarget _   m@(PrimTarget _)      = m
+
+wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
+-- Take a transformer on expressions and apply it recursively.
+-- (wrapRecExp f e) first recursively applies itself to sub-expressions of e
+--                  then  uses f to rewrite the resulting expression
+wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)
+wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)
+wrapRecExp f e                    = f e
+
+mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExp _ f@(CmmEntry{})                          = f
+mapExp _ m@(CmmComment _)                        = m
+mapExp _ m@(CmmTick _)                           = m
+mapExp f   (CmmUnwind regs)                      = CmmUnwind (map (fmap (fmap f)) regs)
+mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)
+mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)
+mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
+mapExp _ l@(CmmBranch _)                         = l
+mapExp f   (CmmCondBranch e ti fi l)             = CmmCondBranch (f e) ti fi l
+mapExp f   (CmmSwitch e ids)                     = CmmSwitch (f e) ids
+mapExp f   n@CmmCall {cml_target=tgt}            = n{cml_target = f tgt}
+mapExp f   (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl
+
+mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExpDeep f = mapExp $ wrapRecExp f
+
+------------------------------------------------------------------------
+-- mapping Expr in CmmNode, but not performing allocation if no changes
+
+mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget
+mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e
+mapForeignTargetM _ (PrimTarget _)      = Nothing
+
+wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)
+-- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e
+--                   then  gives f a chance to rewrite the resulting expression
+wrapRecExpM f n@(CmmMachOp op es)  = maybe (f n) (f . CmmMachOp op)    (mapListM (wrapRecExpM f) es)
+wrapRecExpM f n@(CmmLoad addr ty)  = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)
+wrapRecExpM f e                    = f e
+
+mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
+mapExpM _ (CmmEntry{})              = Nothing
+mapExpM _ (CmmComment _)            = Nothing
+mapExpM _ (CmmTick _)               = Nothing
+mapExpM f (CmmUnwind regs)          = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs
+mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e
+mapExpM f (CmmStore addr e)         = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]
+mapExpM _ (CmmBranch _)             = Nothing
+mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e
+mapExpM f (CmmSwitch e tbl)         = (\x -> CmmSwitch x tbl)       `fmap` f e
+mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt
+mapExpM f (CmmUnsafeForeignCall tgt fs as)
+    = case mapForeignTargetM f tgt of
+        Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))
+        Nothing   -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as
+mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)
+    = case mapForeignTargetM f tgt of
+        Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)
+        Nothing   -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as
+
+-- share as much as possible
+mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]
+mapListM f xs = let (b, r) = mapListT f xs
+                in if b then Just r else Nothing
+
+mapListJ :: (a -> Maybe a) -> [a] -> [a]
+mapListJ f xs = snd (mapListT f xs)
+
+mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])
+mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))
+    where g (_,   y, Nothing) (True, ys)  = (True,  y:ys)
+          g (_,   _, Just y)  (True, ys)  = (True,  y:ys)
+          g (ys', _, Nothing) (False, _)  = (False, ys')
+          g (_,   _, Just y)  (False, ys) = (True,  y:ys)
+
+mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)
+mapExpDeepM f = mapExpM $ wrapRecExpM f
+
+-----------------------------------
+-- folding Expr in CmmNode
+
+foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
+foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
+foldExpForeignTarget _   (PrimTarget _)      z = z
+
+-- Take a folder on expressions and apply it recursively.
+-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad
+-- itself, delegating all the other CmmExpr forms to 'f'.
+wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
+wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
+wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
+wrapRecExpf f e                  z = f e z
+
+foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExp _ (CmmEntry {}) z                         = z
+foldExp _ (CmmComment {}) z                       = z
+foldExp _ (CmmTick {}) z                          = z
+foldExp f (CmmUnwind xs) z                        = foldr (maybe id f) z (map snd xs)
+foldExp f (CmmAssign _ e) z                       = f e z
+foldExp f (CmmStore addr e) z                     = f addr $ f e z
+foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as
+foldExp _ (CmmBranch _) z                         = z
+foldExp f (CmmCondBranch e _ _ _) z               = f e z
+foldExp f (CmmSwitch e _) z                       = f e z
+foldExp f (CmmCall {cml_target=tgt}) z            = f tgt z
+foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
+
+foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExpDeep f = foldExp (wrapRecExpf f)
+
+-- -----------------------------------------------------------------------------
+
+mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C
+mapSuccessors f (CmmBranch bid)         = CmmBranch (f bid)
+mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l
+mapSuccessors f (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets f ids)
+mapSuccessors _ n = n
+
+mapCollectSuccessors :: forall a. (Label -> (Label,a)) -> CmmNode O C
+                     -> (CmmNode O C, [a])
+mapCollectSuccessors f (CmmBranch bid)
+  = let (bid', acc) = f bid in (CmmBranch bid', [acc])
+mapCollectSuccessors f (CmmCondBranch p y n l)
+  = let (bidt, acct) = f y
+        (bidf, accf) = f n
+    in  (CmmCondBranch p bidt bidf l, [accf, acct])
+mapCollectSuccessors f (CmmSwitch e ids)
+  = let lbls = switchTargetsToList ids :: [Label]
+        lblMap = mapFromList $ zip lbls (map f lbls) :: LabelMap (Label, a)
+    in ( CmmSwitch e
+          (mapSwitchTargets
+            (\l -> fst $ mapFindWithDefault (error "impossible") l lblMap) ids)
+          , map snd (mapElems lblMap)
+        )
+mapCollectSuccessors _ n = (n, [])
+
+-- -----------------------------------------------------------------------------
+
+-- | Tickish in Cmm context (annotations only)
+type CmmTickish = Tickish ()
+
+-- | Tick scope identifier, allowing us to reason about what
+-- annotations in a Cmm block should scope over. We especially take
+-- care to allow optimisations to reorganise blocks without losing
+-- tick association in the process.
+data CmmTickScope
+  = GlobalScope
+    -- ^ The global scope is the "root" of the scope graph. Every
+    -- scope is a sub-scope of the global scope. It doesn't make sense
+    -- to add ticks to this scope. On the other hand, this means that
+    -- setting this scope on a block means no ticks apply to it.
+
+  | SubScope !U.Unique CmmTickScope
+    -- ^ Constructs a new sub-scope to an existing scope. This allows
+    -- us to translate Core-style scoping rules (see @tickishScoped@)
+    -- into the Cmm world. Suppose the following code:
+    --
+    --   tick<1> case ... of
+    --             A -> tick<2> ...
+    --             B -> tick<3> ...
+    --
+    -- We want the top-level tick annotation to apply to blocks
+    -- generated for the A and B alternatives. We can achieve that by
+    -- generating tick<1> into a block with scope a, while the code
+    -- for alternatives A and B gets generated into sub-scopes a/b and
+    -- a/c respectively.
+
+  | CombinedScope CmmTickScope CmmTickScope
+    -- ^ A combined scope scopes over everything that the two given
+    -- scopes cover. It is therefore a sub-scope of either scope. This
+    -- is required for optimisations. Consider common block elimination:
+    --
+    --   A -> tick<2> case ... of
+    --     C -> [common]
+    --   B -> tick<3> case ... of
+    --     D -> [common]
+    --
+    -- We will generate code for the C and D alternatives, and figure
+    -- out afterwards that it's actually common code. Scoping rules
+    -- dictate that the resulting common block needs to be covered by
+    -- both tick<2> and tick<3>, therefore we need to construct a
+    -- scope that is a child to *both* scope. Now we can do that - if
+    -- we assign the scopes a/c and b/d to the common-ed up blocks,
+    -- the new block could have a combined tick scope a/c+b/d, which
+    -- both tick<2> and tick<3> apply to.
+
+-- Note [CmmTick scoping details]:
+--
+-- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the
+-- same block. Note that as a result of this, optimisations making
+-- tick scopes more specific can *reduce* the amount of code a tick
+-- scopes over. Fixing this would require a separate @CmmTickScope@
+-- field for @CmmTick@. Right now we do not do this simply because I
+-- couldn't find an example where it actually mattered -- multiple
+-- blocks within the same scope generally jump to each other, which
+-- prevents common block elimination from happening in the first
+-- place. But this is no strong reason, so if Cmm optimisations become
+-- more involved in future this might have to be revisited.
+
+-- | Output all scope paths.
+scopeToPaths :: CmmTickScope -> [[U.Unique]]
+scopeToPaths GlobalScope           = [[]]
+scopeToPaths (SubScope u s)        = map (u:) (scopeToPaths s)
+scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2
+
+-- | Returns the head uniques of the scopes. This is based on the
+-- assumption that the @Unique@ of @SubScope@ identifies the
+-- underlying super-scope. Used for efficient equality and comparison,
+-- see below.
+scopeUniques :: CmmTickScope -> [U.Unique]
+scopeUniques GlobalScope           = []
+scopeUniques (SubScope u _)        = [u]
+scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2
+
+-- Equality and order is based on the head uniques defined above. We
+-- take care to short-cut the (extremly) common cases.
+instance Eq CmmTickScope where
+  GlobalScope    == GlobalScope     = True
+  GlobalScope    == _               = False
+  _              == GlobalScope     = False
+  (SubScope u _) == (SubScope u' _) = u == u'
+  (SubScope _ _) == _               = False
+  _              == (SubScope _ _)  = False
+  scope          == scope'          =
+    sortBy nonDetCmpUnique (scopeUniques scope) ==
+    sortBy nonDetCmpUnique (scopeUniques scope')
+    -- This is still deterministic because
+    -- the order is the same for equal lists
+
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+-- See Note [No Ord for Unique]
+instance Ord CmmTickScope where
+  compare GlobalScope    GlobalScope     = EQ
+  compare GlobalScope    _               = LT
+  compare _              GlobalScope     = GT
+  compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u'
+  compare scope scope'                   = cmpList nonDetCmpUnique
+     (sortBy nonDetCmpUnique $ scopeUniques scope)
+     (sortBy nonDetCmpUnique $ scopeUniques scope')
+
+instance Outputable CmmTickScope where
+  ppr GlobalScope     = text "global"
+  ppr (SubScope us GlobalScope)
+                      = ppr us
+  ppr (SubScope us s) = ppr s <> char '/' <> ppr us
+  ppr combined        = parens $ hcat $ punctuate (char '+') $
+                        map (hcat . punctuate (char '/') . map ppr . reverse) $
+                        scopeToPaths combined
+
+-- | Checks whether two tick scopes are sub-scopes of each other. True
+-- if the two scopes are equal.
+isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool
+isTickSubScope = cmp
+  where cmp _              GlobalScope             = True
+        cmp GlobalScope    _                       = False
+        cmp (CombinedScope s1 s2) s'               = cmp s1 s' && cmp s2 s'
+        cmp s              (CombinedScope s1' s2') = cmp s s1' || cmp s s2'
+        cmp (SubScope u s) s'@(SubScope u' _)      = u == u' || cmp s s'
+
+-- | Combine two tick scopes. The new scope should be sub-scope of
+-- both parameters. We simplfy automatically if one tick scope is a
+-- sub-scope of the other already.
+combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope
+combineTickScopes s1 s2
+  | s1 `isTickSubScope` s2 = s1
+  | s2 `isTickSubScope` s1 = s2
+  | otherwise              = CombinedScope s1 s2
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmOpt.hs
@@ -0,0 +1,427 @@
+-- The default iteration limit is a bit too low for the definitions
+-- in this module.
+{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
+
+-----------------------------------------------------------------------------
+--
+-- Cmm optimisation
+--
+-- (c) The University of Glasgow 2006
+--
+-----------------------------------------------------------------------------
+
+module CmmOpt (
+        constantFoldNode,
+        constantFoldExpr,
+        cmmMachOpFold,
+        cmmMachOpFoldM
+ ) where
+
+import GhcPrelude
+
+import CmmUtils
+import Cmm
+import DynFlags
+import Util
+
+import Outputable
+import Platform
+
+import Data.Bits
+import Data.Maybe
+
+
+constantFoldNode :: DynFlags -> CmmNode e x -> CmmNode e x
+constantFoldNode dflags = mapExp (constantFoldExpr dflags)
+
+constantFoldExpr :: DynFlags -> CmmExpr -> CmmExpr
+constantFoldExpr dflags = wrapRecExp f
+  where f (CmmMachOp op args) = cmmMachOpFold dflags op args
+        f (CmmRegOff r 0) = CmmReg r
+        f e = e
+
+-- -----------------------------------------------------------------------------
+-- MachOp constant folder
+
+-- Now, try to constant-fold the MachOps.  The arguments have already
+-- been optimized and folded.
+
+cmmMachOpFold
+    :: DynFlags
+    -> MachOp       -- The operation from an CmmMachOp
+    -> [CmmExpr]    -- The optimized arguments
+    -> CmmExpr
+
+cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args)
+
+-- Returns Nothing if no changes, useful for Hoopl, also reduces
+-- allocation!
+cmmMachOpFoldM
+    :: DynFlags
+    -> MachOp
+    -> [CmmExpr]
+    -> Maybe CmmExpr
+
+cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]
+  = Just $ case op of
+      MO_S_Neg _ -> CmmLit (CmmInt (-x) rep)
+      MO_Not _   -> CmmLit (CmmInt (complement x) rep)
+
+        -- these are interesting: we must first narrow to the
+        -- "from" type, in order to truncate to the correct size.
+        -- The final narrow/widen to the destination type
+        -- is implicit in the CmmLit.
+      MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to)
+      MO_SS_Conv  from to -> CmmLit (CmmInt (narrowS from x) to)
+      MO_UU_Conv  from to -> CmmLit (CmmInt (narrowU from x) to)
+
+      _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op
+
+
+-- Eliminate conversion NOPs
+cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
+cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
+
+-- Eliminate nested conversions where possible
+cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]
+  | Just (rep1,rep2,signed1) <- isIntConversion conv_inner,
+    Just (_,   rep3,signed2) <- isIntConversion conv_outer
+  = case () of
+        -- widen then narrow to the same size is a nop
+      _ | rep1 < rep2 && rep1 == rep3 -> Just x
+        -- Widen then narrow to different size: collapse to single conversion
+        -- but remember to use the signedness from the widening, just in case
+        -- the final conversion is a widen.
+        | rep1 < rep2 && rep2 > rep3 ->
+            Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]
+        -- Nested widenings: collapse if the signedness is the same
+        | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->
+            Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]
+        -- Nested narrowings: collapse
+        | rep1 > rep2 && rep2 > rep3 ->
+            Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x]
+        | otherwise ->
+            Nothing
+  where
+        isIntConversion (MO_UU_Conv rep1 rep2)
+          = Just (rep1,rep2,False)
+        isIntConversion (MO_SS_Conv rep1 rep2)
+          = Just (rep1,rep2,True)
+        isIntConversion _ = Nothing
+
+        intconv True  = MO_SS_Conv
+        intconv False = MO_UU_Conv
+
+-- ToDo: a narrow of a load can be collapsed into a narrow load, right?
+-- but what if the architecture only supports word-sized loads, should
+-- we do the transformation anyway?
+
+cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
+  = case mop of
+        -- for comparisons: don't forget to narrow the arguments before
+        -- comparing, since they might be out of range.
+        MO_Eq _   -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags))
+        MO_Ne _   -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags))
+
+        MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u >  y_u then 1 else 0) (wordWidth dflags))
+        MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags))
+        MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u <  y_u then 1 else 0) (wordWidth dflags))
+        MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags))
+
+        MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s >  y_s then 1 else 0) (wordWidth dflags))
+        MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags))
+        MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s <  y_s then 1 else 0) (wordWidth dflags))
+        MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags))
+
+        MO_Add r -> Just $ CmmLit (CmmInt (x + y) r)
+        MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r)
+        MO_Mul r -> Just $ CmmLit (CmmInt (x * y) r)
+        MO_U_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `quot` y_u) r)
+        MO_U_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `rem`  y_u) r)
+        MO_S_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x `quot` y) r)
+        MO_S_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x `rem` y) r)
+
+        MO_And   r -> Just $ CmmLit (CmmInt (x .&. y) r)
+        MO_Or    r -> Just $ CmmLit (CmmInt (x .|. y) r)
+        MO_Xor   r -> Just $ CmmLit (CmmInt (x `xor` y) r)
+
+        MO_Shl   r -> Just $ CmmLit (CmmInt (x `shiftL` fromIntegral y) r)
+        MO_U_Shr r -> Just $ CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)
+        MO_S_Shr r -> Just $ CmmLit (CmmInt (x `shiftR` fromIntegral y) r)
+
+        _          -> Nothing
+
+   where
+        x_u = narrowU xrep x
+        y_u = narrowU xrep y
+        x_s = narrowS xrep x
+        y_s = narrowS xrep y
+
+
+-- When possible, shift the constants to the right-hand side, so that we
+-- can match for strength reductions.  Note that the code generator will
+-- also assume that constants have been shifted to the right when
+-- possible.
+
+cmmMachOpFoldM dflags op [x@(CmmLit _), y]
+   | not (isLit y) && isCommutableMachOp op
+   = Just (cmmMachOpFold dflags op [y, x])
+
+-- Turn (a+b)+c into a+(b+c) where possible.  Because literals are
+-- moved to the right, it is more likely that we will find
+-- opportunities for constant folding when the expression is
+-- right-associated.
+--
+-- ToDo: this appears to introduce a quadratic behaviour due to the
+-- nested cmmMachOpFold.  Can we fix this?
+--
+-- Why do we check isLit arg1?  If arg1 is a lit, it means that arg2
+-- is also a lit (otherwise arg1 would be on the right).  If we
+-- put arg1 on the left of the rearranged expression, we'll get into a
+-- loop:  (x1+x2)+x3 => x1+(x2+x3)  => (x2+x3)+x1 => x2+(x3+x1) ...
+--
+-- Also don't do it if arg1 is PicBaseReg, so that we don't separate the
+-- PicBaseReg from the corresponding label (or label difference).
+--
+cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
+   | mop2 `associates_with` mop1
+     && not (isLit arg1) && not (isPicReg arg1)
+   = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]])
+   where
+     MO_Add{} `associates_with` MO_Sub{} = True
+     mop1 `associates_with` mop2 =
+        mop1 == mop2 && isAssociativeMachOp mop1
+
+-- special case: (a - b) + c  ==>  a + (c - b)
+cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]
+   | not (isLit arg1) && not (isPicReg arg1)
+   = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]])
+
+-- special case: (PicBaseReg + lit) + N  ==>  PicBaseReg + (lit+N)
+--
+-- this is better because lit+N is a single link-time constant (e.g. a
+-- CmmLabelOff), so the right-hand expression needs only one
+-- instruction, whereas the left needs two.  This happens when pointer
+-- tagging gives us label+offset, and PIC turns the label into
+-- PicBaseReg + label.
+--
+cmmMachOpFoldM _ MO_Add{} [ CmmMachOp op@MO_Add{} [pic, CmmLit lit]
+                          , CmmLit (CmmInt n rep) ]
+  | isPicReg pic
+  = Just $ CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ]
+  where off = fromIntegral (narrowS rep n)
+
+-- Make a RegOff if we can
+cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]
+  = Just $ cmmRegOff reg (fromIntegral (narrowS rep n))
+cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
+  = Just $ cmmRegOff reg (off + fromIntegral (narrowS rep n))
+cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]
+  = Just $ cmmRegOff reg (- fromIntegral (narrowS rep n))
+cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
+  = Just $ cmmRegOff reg (off - fromIntegral (narrowS rep n))
+
+-- Fold label(+/-)offset into a CmmLit where possible
+
+cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)]
+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))
+cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit]
+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))
+cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]
+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i))))
+
+
+-- Comparison of literal with widened operand: perform the comparison
+-- at the smaller width, as long as the literal is within range.
+
+-- We can't do the reverse trick, when the operand is narrowed:
+-- narrowing throws away bits from the operand, there's no way to do
+-- the same comparison at the larger size.
+
+cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
+  |     -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try
+    platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64],
+        -- if the operand is widened:
+    Just (rep, signed, narrow_fn) <- maybe_conversion conv,
+        -- and this is a comparison operation:
+    Just narrow_cmp <- maybe_comparison cmp rep signed,
+        -- and the literal fits in the smaller size:
+    i == narrow_fn rep i
+        -- then we can do the comparison at the smaller size
+  = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)])
+ where
+    maybe_conversion (MO_UU_Conv from to)
+        | to > from
+        = Just (from, False, narrowU)
+    maybe_conversion (MO_SS_Conv from to)
+        | to > from
+        = Just (from, True, narrowS)
+
+        -- don't attempt to apply this optimisation when the source
+        -- is a float; see #1916
+    maybe_conversion _ = Nothing
+
+        -- careful (#2080): if the original comparison was signed, but
+        -- we were doing an unsigned widen, then we must do an
+        -- unsigned comparison at the smaller size.
+    maybe_comparison (MO_U_Gt _) rep _     = Just (MO_U_Gt rep)
+    maybe_comparison (MO_U_Ge _) rep _     = Just (MO_U_Ge rep)
+    maybe_comparison (MO_U_Lt _) rep _     = Just (MO_U_Lt rep)
+    maybe_comparison (MO_U_Le _) rep _     = Just (MO_U_Le rep)
+    maybe_comparison (MO_Eq   _) rep _     = Just (MO_Eq   rep)
+    maybe_comparison (MO_S_Gt _) rep True  = Just (MO_S_Gt rep)
+    maybe_comparison (MO_S_Ge _) rep True  = Just (MO_S_Ge rep)
+    maybe_comparison (MO_S_Lt _) rep True  = Just (MO_S_Lt rep)
+    maybe_comparison (MO_S_Le _) rep True  = Just (MO_S_Le rep)
+    maybe_comparison (MO_S_Gt _) rep False = Just (MO_U_Gt rep)
+    maybe_comparison (MO_S_Ge _) rep False = Just (MO_U_Ge rep)
+    maybe_comparison (MO_S_Lt _) rep False = Just (MO_U_Lt rep)
+    maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep)
+    maybe_comparison _ _ _ = Nothing
+
+-- We can often do something with constants of 0 and 1 ...
+-- See Note [Comparison operators]
+
+cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]
+  = case mop of
+        -- Arithmetic
+        MO_Add   _ -> Just x   -- x + 0 = x
+        MO_Sub   _ -> Just x   -- x - 0 = x
+        MO_Mul   _ -> Just y   -- x * 0 = 0
+
+        -- Logical operations
+        MO_And   _ -> Just y   -- x &     0 = 0
+        MO_Or    _ -> Just x   -- x |     0 = x
+        MO_Xor   _ -> Just x   -- x `xor` 0 = x
+
+        -- Shifts
+        MO_Shl   _ -> Just x   -- x << 0 = x
+        MO_S_Shr _ -> Just x   -- ditto shift-right
+        MO_U_Shr _ -> Just x
+
+        -- Comparisons; these ones are trickier
+        -- See Note [Comparison operators]
+        MO_Ne    _ | isComparisonExpr x -> Just x                -- (x > y) != 0  =  x > y
+        MO_Eq    _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x > y) == 0  =  x <= y
+        MO_U_Gt  _ | isComparisonExpr x -> Just x                -- (x > y) > 0   =  x > y
+        MO_S_Gt  _ | isComparisonExpr x -> Just x                -- ditto
+        MO_U_Lt  _ | isComparisonExpr x -> Just zero             -- (x > y) < 0  =  0
+        MO_S_Lt  _ | isComparisonExpr x -> Just zero
+        MO_U_Ge  _ | isComparisonExpr x -> Just one              -- (x > y) >= 0  =  1
+        MO_S_Ge  _ | isComparisonExpr x -> Just one
+
+        MO_U_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x > y) <= 0  =  x <= y
+        MO_S_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'
+        _ -> Nothing
+  where
+    zero = CmmLit (CmmInt 0 (wordWidth dflags))
+    one  = CmmLit (CmmInt 1 (wordWidth dflags))
+
+cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]
+  = case mop of
+        -- Arithmetic: x*1 = x, etc
+        MO_Mul    _ -> Just x
+        MO_S_Quot _ -> Just x
+        MO_U_Quot _ -> Just x
+        MO_S_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)
+        MO_U_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)
+
+        -- Comparisons; trickier
+        -- See Note [Comparison operators]
+        MO_Ne    _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) != 1  =  x<=y
+        MO_Eq    _ | isComparisonExpr x -> Just x                -- (x>y) == 1  =  x>y
+        MO_U_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) < 1   =  x<=y
+        MO_S_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- ditto
+        MO_U_Gt  _ | isComparisonExpr x -> Just zero             -- (x>y) > 1   = 0
+        MO_S_Gt  _ | isComparisonExpr x -> Just zero
+        MO_U_Le  _ | isComparisonExpr x -> Just one              -- (x>y) <= 1  = 1
+        MO_S_Le  _ | isComparisonExpr x -> Just one
+        MO_U_Ge  _ | isComparisonExpr x -> Just x                -- (x>y) >= 1  = x>y
+        MO_S_Ge  _ | isComparisonExpr x -> Just x
+        _ -> Nothing
+  where
+    zero = CmmLit (CmmInt 0 (wordWidth dflags))
+    one  = CmmLit (CmmInt 1 (wordWidth dflags))
+
+-- Now look for multiplication/division by powers of 2 (integers).
+
+cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]
+  = case mop of
+        MO_Mul rep
+           | Just p <- exactLog2 n ->
+                 Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)])
+        MO_U_Quot rep
+           | Just p <- exactLog2 n ->
+                 Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])
+        MO_U_Rem rep
+           | Just _ <- exactLog2 n ->
+                 Just (cmmMachOpFold dflags (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])
+        MO_S_Quot rep
+           | Just p <- exactLog2 n,
+             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require
+                                -- it is a reg.  FIXME: remove this restriction.
+                Just (cmmMachOpFold dflags (MO_S_Shr rep)
+                  [signedQuotRemHelper rep p, CmmLit (CmmInt p rep)])
+        MO_S_Rem rep
+           | Just p <- exactLog2 n,
+             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require
+                                -- it is a reg.  FIXME: remove this restriction.
+                -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).
+                -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)
+                -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.
+                Just (cmmMachOpFold dflags (MO_Sub rep)
+                    [x, cmmMachOpFold dflags (MO_And rep)
+                      [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])
+        _ -> Nothing
+  where
+    -- In contrast with unsigned integers, for signed ones
+    -- shift right is not the same as quot, because it rounds
+    -- to minus infinity, whereas quot rounds toward zero.
+    -- To fix this up, we add one less than the divisor to the
+    -- dividend if it is a negative number.
+    --
+    -- to avoid a test/jump, we use the following sequence:
+    --      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)
+    --      x2 = y & (divisor-1)
+    --      result = x + x2
+    -- this could be done a bit more simply using conditional moves,
+    -- but we're processor independent here.
+    --
+    -- we optimise the divide by 2 case slightly, generating
+    --      x1 = x >> word_size-1  (unsigned)
+    --      return = x + x1
+    signedQuotRemHelper :: Width -> Integer -> CmmExpr
+    signedQuotRemHelper rep p = CmmMachOp (MO_Add rep) [x, x2]
+      where
+        bits = fromIntegral (widthInBits rep) - 1
+        shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep
+        x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)]
+        x2 = if p == 1 then x1 else
+             CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]
+
+-- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x
+-- Unfortunately this needs a unique supply because x might not be a
+-- register.  See #2253 (program 6) for an example.
+
+
+-- Anything else is just too hard.
+
+cmmMachOpFoldM _ _ _ = Nothing
+
+{- Note [Comparison operators]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+   CmmCondBranch ((x>#y) == 1) t f
+we really want to convert to
+   CmmCondBranch (x>#y) t f
+
+That's what the constant-folding operations on comparison operators do above.
+-}
+
+
+-- -----------------------------------------------------------------------------
+-- Utils
+
+isPicReg :: CmmExpr -> Bool
+isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True
+isPicReg _ = False
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmParse.y
@@ -0,0 +1,1442 @@
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2004-2012
+--
+-- Parser for concrete Cmm.
+--
+-----------------------------------------------------------------------------
+
+{- -----------------------------------------------------------------------------
+Note [Syntax of .cmm files]
+
+NOTE: You are very much on your own in .cmm.  There is very little
+error checking at all:
+
+  * Type errors are detected by the (optional) -dcmm-lint pass, if you
+    don't turn this on then a type error will likely result in a panic
+    from the native code generator.
+
+  * Passing the wrong number of arguments or arguments of the wrong
+    type is not detected.
+
+There are two ways to write .cmm code:
+
+ (1) High-level Cmm code delegates the stack handling to GHC, and
+     never explicitly mentions Sp or registers.
+
+ (2) Low-level Cmm manages the stack itself, and must know about
+     calling conventions.
+
+Whether you want high-level or low-level Cmm is indicated by the
+presence of an argument list on a procedure.  For example:
+
+foo ( gcptr a, bits32 b )
+{
+  // this is high-level cmm code
+
+  if (b > 0) {
+     // we can make tail calls passing arguments:
+     jump stg_ap_0_fast(a);
+  }
+
+  push (stg_upd_frame_info, a) {
+    // stack frames can be explicitly pushed
+
+    (x,y) = call wibble(a,b,3,4);
+      // calls pass arguments and return results using the native
+      // Haskell calling convention.  The code generator will automatically
+      // construct a stack frame and an info table for the continuation.
+
+    return (x,y);
+      // we can return multiple values from the current proc
+  }
+}
+
+bar
+{
+  // this is low-level cmm code, indicated by the fact that we did not
+  // put an argument list on bar.
+
+  x = R1;  // the calling convention is explicit: better be careful
+           // that this works on all platforms!
+
+  jump %ENTRY_CODE(Sp(0))
+}
+
+Here is a list of rules for high-level and low-level code.  If you
+break the rules, you get a panic (for using a high-level construct in
+a low-level proc), or wrong code (when using low-level code in a
+high-level proc).  This stuff isn't checked! (TODO!)
+
+High-level only:
+
+  - tail-calls with arguments, e.g.
+    jump stg_fun (arg1, arg2);
+
+  - function calls:
+    (ret1,ret2) = call stg_fun (arg1, arg2);
+
+    This makes a call with the NativeNodeCall convention, and the
+    values are returned to the following code using the NativeReturn
+    convention.
+
+  - returning:
+    return (ret1, ret2)
+
+    These use the NativeReturn convention to return zero or more
+    results to the caller.
+
+  - pushing stack frames:
+    push (info_ptr, field1, ..., fieldN) { ... statements ... }
+
+  - reserving temporary stack space:
+
+      reserve N = x { ... }
+
+    this reserves an area of size N (words) on the top of the stack,
+    and binds its address to x (a local register).  Typically this is
+    used for allocating temporary storage for passing to foreign
+    functions.
+
+    Note that if you make any native calls or invoke the GC in the
+    scope of the reserve block, you are responsible for ensuring that
+    the stack you reserved is laid out correctly with an info table.
+
+Low-level only:
+
+  - References to Sp, R1-R8, F1-F4 etc.
+
+    NB. foreign calls may clobber the argument registers R1-R8, F1-F4
+    etc., so ensure they are saved into variables around foreign
+    calls.
+
+  - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp
+    directly.
+
+Both high-level and low-level code can use a raw tail-call:
+
+    jump stg_fun [R1,R2]
+
+NB. you *must* specify the list of GlobalRegs that are passed via a
+jump, otherwise the register allocator will assume that all the
+GlobalRegs are dead at the jump.
+
+
+Calling Conventions
+-------------------
+
+High-level procedures use the NativeNode calling convention, or the
+NativeReturn convention if the 'return' keyword is used (see Stack
+Frames below).
+
+Low-level procedures implement their own calling convention, so it can
+be anything at all.
+
+If a low-level procedure implements the NativeNode calling convention,
+then it can be called by high-level code using an ordinary function
+call.  In general this is hard to arrange because the calling
+convention depends on the number of physical registers available for
+parameter passing, but there are two cases where the calling
+convention is platform-independent:
+
+ - Zero arguments.
+
+ - One argument of pointer or non-pointer word type; this is always
+   passed in R1 according to the NativeNode convention.
+
+ - Returning a single value; these conventions are fixed and platform
+   independent.
+
+
+Stack Frames
+------------
+
+A stack frame is written like this:
+
+INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN )
+               return ( arg1, ..., argM )
+{
+  ... code ...
+}
+
+where field1 ... fieldN are the fields of the stack frame (with types)
+arg1...argN are the values returned to the stack frame (with types).
+The return values are assumed to be passed according to the
+NativeReturn convention.
+
+On entry to the code, the stack frame looks like:
+
+   |----------|
+   | fieldN   |
+   |   ...    |
+   | field1   |
+   |----------|
+   | info_ptr |
+   |----------|
+   |  argN    |
+   |   ...    | <- Sp
+
+and some of the args may be in registers.
+
+We prepend the code by a copyIn of the args, and assign all the stack
+frame fields to their formals.  The initial "arg offset" for stack
+layout purposes consists of the whole stack frame plus any args that
+might be on the stack.
+
+A tail-call may pass a stack frame to the callee using the following
+syntax:
+
+jump f (info_ptr, field1,..,fieldN) (arg1,..,argN)
+
+where info_ptr and field1..fieldN describe the stack frame, and
+arg1..argN are the arguments passed to f using the NativeNodeCall
+convention. Note if a field is longer than a word (e.g. a D_ on
+a 32-bit machine) then the call will push as many words as
+necessary to the stack to accommodate it (e.g. 2).
+
+
+----------------------------------------------------------------------------- -}
+
+{
+module CmmParse ( parseCmmFile ) where
+
+import GhcPrelude
+
+import StgCmmExtCode
+import CmmCallConv
+import StgCmmProf
+import StgCmmHeap
+import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore
+                          , emitAssign, emitOutOfLine, withUpdFrameOff
+                          , getUpdFrameOff )
+import qualified StgCmmMonad as F
+import StgCmmUtils
+import StgCmmForeign
+import StgCmmExpr
+import StgCmmClosure
+import StgCmmLayout     hiding (ArgRep(..))
+import StgCmmTicky
+import StgCmmBind       ( emitBlackHoleCode, emitUpdateFrame )
+import CoreSyn          ( Tickish(SourceNote) )
+
+import CmmOpt
+import MkGraph
+import Cmm
+import CmmUtils
+import CmmSwitch        ( mkSwitchTargets )
+import CmmInfo
+import BlockId
+import CmmLex
+import CLabel
+import SMRep
+import Lexer
+import CmmMonad
+
+import CostCentre
+import ForeignCall
+import Module
+import Platform
+import Literal
+import Unique
+import UniqFM
+import SrcLoc
+import DynFlags
+import ErrUtils
+import StringBuffer
+import FastString
+import Panic
+import Constants
+import Outputable
+import BasicTypes
+import Bag              ( emptyBag, unitBag )
+import Var
+
+import Control.Monad
+import Data.Array
+import Data.Char        ( ord )
+import System.Exit
+import Data.Maybe
+import qualified Data.Map as M
+
+#include "HsVersions.h"
+}
+
+%expect 0
+
+%token
+        ':'     { L _ (CmmT_SpecChar ':') }
+        ';'     { L _ (CmmT_SpecChar ';') }
+        '{'     { L _ (CmmT_SpecChar '{') }
+        '}'     { L _ (CmmT_SpecChar '}') }
+        '['     { L _ (CmmT_SpecChar '[') }
+        ']'     { L _ (CmmT_SpecChar ']') }
+        '('     { L _ (CmmT_SpecChar '(') }
+        ')'     { L _ (CmmT_SpecChar ')') }
+        '='     { L _ (CmmT_SpecChar '=') }
+        '`'     { L _ (CmmT_SpecChar '`') }
+        '~'     { L _ (CmmT_SpecChar '~') }
+        '/'     { L _ (CmmT_SpecChar '/') }
+        '*'     { L _ (CmmT_SpecChar '*') }
+        '%'     { L _ (CmmT_SpecChar '%') }
+        '-'     { L _ (CmmT_SpecChar '-') }
+        '+'     { L _ (CmmT_SpecChar '+') }
+        '&'     { L _ (CmmT_SpecChar '&') }
+        '^'     { L _ (CmmT_SpecChar '^') }
+        '|'     { L _ (CmmT_SpecChar '|') }
+        '>'     { L _ (CmmT_SpecChar '>') }
+        '<'     { L _ (CmmT_SpecChar '<') }
+        ','     { L _ (CmmT_SpecChar ',') }
+        '!'     { L _ (CmmT_SpecChar '!') }
+
+        '..'    { L _ (CmmT_DotDot) }
+        '::'    { L _ (CmmT_DoubleColon) }
+        '>>'    { L _ (CmmT_Shr) }
+        '<<'    { L _ (CmmT_Shl) }
+        '>='    { L _ (CmmT_Ge) }
+        '<='    { L _ (CmmT_Le) }
+        '=='    { L _ (CmmT_Eq) }
+        '!='    { L _ (CmmT_Ne) }
+        '&&'    { L _ (CmmT_BoolAnd) }
+        '||'    { L _ (CmmT_BoolOr) }
+
+        'True'  { L _ (CmmT_True ) }
+        'False' { L _ (CmmT_False) }
+        'likely'{ L _ (CmmT_likely)}
+
+        'CLOSURE'       { L _ (CmmT_CLOSURE) }
+        'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }
+        'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
+        'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
+        'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
+        'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
+        'else'          { L _ (CmmT_else) }
+        'export'        { L _ (CmmT_export) }
+        'section'       { L _ (CmmT_section) }
+        'goto'          { L _ (CmmT_goto) }
+        'if'            { L _ (CmmT_if) }
+        'call'          { L _ (CmmT_call) }
+        'jump'          { L _ (CmmT_jump) }
+        'foreign'       { L _ (CmmT_foreign) }
+        'never'         { L _ (CmmT_never) }
+        'prim'          { L _ (CmmT_prim) }
+        'reserve'       { L _ (CmmT_reserve) }
+        'return'        { L _ (CmmT_return) }
+        'returns'       { L _ (CmmT_returns) }
+        'import'        { L _ (CmmT_import) }
+        'switch'        { L _ (CmmT_switch) }
+        'case'          { L _ (CmmT_case) }
+        'default'       { L _ (CmmT_default) }
+        'push'          { L _ (CmmT_push) }
+        'unwind'        { L _ (CmmT_unwind) }
+        'bits8'         { L _ (CmmT_bits8) }
+        'bits16'        { L _ (CmmT_bits16) }
+        'bits32'        { L _ (CmmT_bits32) }
+        'bits64'        { L _ (CmmT_bits64) }
+        'bits128'       { L _ (CmmT_bits128) }
+        'bits256'       { L _ (CmmT_bits256) }
+        'bits512'       { L _ (CmmT_bits512) }
+        'float32'       { L _ (CmmT_float32) }
+        'float64'       { L _ (CmmT_float64) }
+        'gcptr'         { L _ (CmmT_gcptr) }
+
+        GLOBALREG       { L _ (CmmT_GlobalReg   $$) }
+        NAME            { L _ (CmmT_Name        $$) }
+        STRING          { L _ (CmmT_String      $$) }
+        INT             { L _ (CmmT_Int         $$) }
+        FLOAT           { L _ (CmmT_Float       $$) }
+
+%monad { PD } { >>= } { return }
+%lexer { cmmlex } { L _ CmmT_EOF }
+%name cmmParse cmm
+%tokentype { Located CmmToken }
+
+-- C-- operator precedences, taken from the C-- spec
+%right '||'     -- non-std extension, called %disjoin in C--
+%right '&&'     -- non-std extension, called %conjoin in C--
+%right '!'
+%nonassoc '>=' '>' '<=' '<' '!=' '=='
+%left '|'
+%left '^'
+%left '&'
+%left '>>' '<<'
+%left '-' '+'
+%left '/' '*' '%'
+%right '~'
+
+%%
+
+cmm     :: { CmmParse () }
+        : {- empty -}                   { return () }
+        | cmmtop cmm                    { do $1; $2 }
+
+cmmtop  :: { CmmParse () }
+        : cmmproc                       { $1 }
+        | cmmdata                       { $1 }
+        | decl                          { $1 } 
+        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  
+                {% liftP . withThisPackage $ \pkg ->
+                   do lits <- sequence $6;
+                      staticClosure pkg $3 $5 (map getLit lits) }
+
+-- The only static closures in the RTS are dummy closures like
+-- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need
+-- to provide the full generality of static closures here.
+-- In particular:
+--      * CCS can always be CCS_DONT_CARE
+--      * closure is always extern
+--      * payload is always empty
+--      * we can derive closure and info table labels from a single NAME
+
+cmmdata :: { CmmParse () }
+        : 'section' STRING '{' data_label statics '}' 
+                { do lbl <- $4;
+                     ss <- sequence $5;
+                     code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }
+
+data_label :: { CmmParse CLabel }
+    : NAME ':'  
+                {% liftP . withThisPackage $ \pkg ->
+                   return (mkCmmDataLabel pkg $1) }
+
+statics :: { [CmmParse [CmmStatic]] }
+        : {- empty -}                   { [] }
+        | static statics                { $1 : $2 }
+    
+static  :: { CmmParse [CmmStatic] }
+        : type expr ';' { do e <- $2;
+                             return [CmmStaticLit (getLit e)] }
+        | type ';'                      { return [CmmUninitialised
+                                                        (widthInBytes (typeWidth $1))] }
+        | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
+        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised 
+                                                        (fromIntegral $3)] }
+        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised 
+                                                (widthInBytes (typeWidth $1) * 
+                                                        fromIntegral $3)] }
+        | 'CLOSURE' '(' NAME lits ')'
+                { do { lits <- sequence $4
+                ; dflags <- getDynFlags
+                     ; return $ map CmmStaticLit $
+                        mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
+                         -- mkForeignLabel because these are only used
+                         -- for CHARLIKE and INTLIKE closures in the RTS.
+                        dontCareCCS (map getLit lits) [] [] [] } }
+        -- arrays of closures required for the CHARLIKE & INTLIKE arrays
+
+lits    :: { [CmmParse CmmExpr] }
+        : {- empty -}           { [] }
+        | ',' expr lits         { $2 : $3 }
+
+cmmproc :: { CmmParse () }
+        : info maybe_conv maybe_formals maybe_body
+                { do ((entry_ret_label, info, stk_formals, formals), agraph) <-
+                       getCodeScoped $ loopDecls $ do {
+                         (entry_ret_label, info, stk_formals) <- $1;
+                         dflags <- getDynFlags;
+                         formals <- sequence (fromMaybe [] $3);
+                         withName (showSDoc dflags (ppr entry_ret_label))
+                           $4;
+                         return (entry_ret_label, info, stk_formals, formals) }
+                     let do_layout = isJust $3
+                     code (emitProcWithStackFrame $2 info
+                                entry_ret_label stk_formals formals agraph
+                                do_layout ) }
+
+maybe_conv :: { Convention }
+           : {- empty -}        { NativeNodeCall }
+           | 'return'           { NativeReturn }
+
+maybe_body :: { CmmParse () }
+           : ';'                { return () }
+           | '{' body '}'       { withSourceNote $1 $3 $2 }
+
+info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
+        : NAME
+                {% liftP . withThisPackage $ \pkg ->
+                   do   newFunctionName $1 pkg
+                        return (mkCmmCodeLabel pkg $1, Nothing, []) }
+
+
+        | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
+                -- ptrs, nptrs, closure type, description, type
+                {% liftP . withThisPackage $ \pkg ->
+                   do dflags <- getDynFlags
+                      let prof = profilingInfo dflags $11 $13
+                          rep  = mkRTSRep (fromIntegral $9) $
+                                   mkHeapRep dflags False (fromIntegral $5)
+                                                   (fromIntegral $7) Thunk
+                              -- not really Thunk, but that makes the info table
+                              -- we want.
+                      return (mkCmmEntryLabel pkg $3,
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                                           , cit_rep = rep
+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
+                              []) }
+        
+        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
+                -- ptrs, nptrs, closure type, description, type, fun type
+                {% liftP . withThisPackage $ \pkg ->
+                   do dflags <- getDynFlags
+                      let prof = profilingInfo dflags $11 $13
+                          ty   = Fun 0 (ArgSpec (fromIntegral $15))
+                                -- Arity zero, arg_type $15
+                          rep = mkRTSRep (fromIntegral $9) $
+                                    mkHeapRep dflags False (fromIntegral $5)
+                                                    (fromIntegral $7) ty
+                      return (mkCmmEntryLabel pkg $3,
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                                           , cit_rep = rep
+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
+                              []) }
+                -- we leave most of the fields zero here.  This is only used
+                -- to generate the BCO info table in the RTS at the moment.
+
+        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
+                -- ptrs, nptrs, tag, closure type, description, type
+                {% liftP . withThisPackage $ \pkg ->
+                   do dflags <- getDynFlags
+                      let prof = profilingInfo dflags $13 $15
+                          ty  = Constr (fromIntegral $9)  -- Tag
+                                       (stringToWord8s $13)
+                          rep = mkRTSRep (fromIntegral $11) $
+                                  mkHeapRep dflags False (fromIntegral $5)
+                                                  (fromIntegral $7) ty
+                      return (mkCmmEntryLabel pkg $3,
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                                           , cit_rep = rep
+                                           , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },
+                              []) }
+
+                     -- If profiling is on, this string gets duplicated,
+                     -- but that's the way the old code did it we can fix it some other time.
+        
+        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
+                -- selector, closure type, description, type
+                {% liftP . withThisPackage $ \pkg ->
+                   do dflags <- getDynFlags
+                      let prof = profilingInfo dflags $9 $11
+                          ty  = ThunkSelector (fromIntegral $5)
+                          rep = mkRTSRep (fromIntegral $7) $
+                                   mkHeapRep dflags False 0 0 ty
+                      return (mkCmmEntryLabel pkg $3,
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                                           , cit_rep = rep
+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
+                              []) }
+
+        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
+                -- closure type (no live regs)
+                {% liftP . withThisPackage $ \pkg ->
+                   do let prof = NoProfilingInfo
+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
+                      return (mkCmmRetLabel pkg $3,
+                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
+                                           , cit_rep = rep
+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
+                              []) }
+
+        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
+                -- closure type, live regs
+                {% liftP . withThisPackage $ \pkg ->
+                   do dflags <- getDynFlags
+                      live <- sequence $7
+                      let prof = NoProfilingInfo
+                          -- drop one for the info pointer
+                          bitmap = mkLiveness dflags (drop 1 live)
+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
+                      return (mkCmmRetLabel pkg $3,
+                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
+                                           , cit_rep = rep
+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
+                              live) }
+
+body    :: { CmmParse () }
+        : {- empty -}                   { return () }
+        | decl body                     { do $1; $2 }
+        | stmt body                     { do $1; $2 }
+
+decl    :: { CmmParse () }
+        : type names ';'                { mapM_ (newLocal $1) $2 }
+        | 'import' importNames ';'      { mapM_ newImport $2 }
+        | 'export' names ';'            { return () }  -- ignore exports
+
+
+-- an imported function name, with optional packageId
+importNames
+        :: { [(FastString, CLabel)] }
+        : importName                    { [$1] }
+        | importName ',' importNames    { $1 : $3 }
+
+importName
+        :: { (FastString,  CLabel) }
+
+        -- A label imported without an explicit packageId.
+        --      These are taken to come frome some foreign, unnamed package.
+        : NAME  
+        { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
+
+        -- as previous 'NAME', but 'IsData'
+        | 'CLOSURE' NAME
+        { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }
+
+        -- A label imported with an explicit packageId.
+        | STRING NAME
+        { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }
+        
+        
+names   :: { [FastString] }
+        : NAME                          { [$1] }
+        | NAME ',' names                { $1 : $3 }
+
+stmt    :: { CmmParse () }
+        : ';'                                   { return () }
+
+        | NAME ':'
+                { do l <- newLabel $1; emitLabel l }
+
+
+
+        | lreg '=' expr ';'
+                { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) }
+        | type '[' expr ']' '=' expr ';'
+                { withSourceNote $2 $7 (doStore $1 $3 $6) }
+
+        -- Gah! We really want to say "foreign_results" but that causes
+        -- a shift/reduce conflict with assignment.  We either
+        -- we expand out the no-result and single result cases or
+        -- we tweak the syntax to avoid the conflict.  The later
+        -- option is taken here because the other way would require
+        -- multiple levels of expanding and get unwieldy.
+        | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
+                {% foreignCall $3 $1 $4 $6 $8 $9 }
+        | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'
+                {% primCall $1 $4 $6 }
+        -- stmt-level macros, stealing syntax from ordinary C-- function calls.
+        -- Perhaps we ought to use the %%-form?
+        | NAME '(' exprs0 ')' ';'
+                {% stmtMacro $1 $3  }
+        | 'switch' maybe_range expr '{' arms default '}'
+                { do as <- sequence $5; doSwitch $2 $3 as $6 }
+        | 'goto' NAME ';'
+                { do l <- lookupLabel $2; emit (mkBranch l) }
+        | 'return' '(' exprs0 ')' ';'
+                { doReturn $3 }
+        | 'jump' expr vols ';'
+                { doRawJump $2 $3 }
+        | 'jump' expr '(' exprs0 ')' ';'
+                { doJumpWithStack $2 [] $4 }
+        | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';'
+                { doJumpWithStack $2 $4 $7 }
+        | 'call' expr '(' exprs0 ')' ';'
+                { doCall $2 [] $4 }
+        | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'
+                { doCall $6 $2 $8 }
+        | 'if' bool_expr cond_likely 'goto' NAME
+                { do l <- lookupLabel $5; cmmRawIf $2 l $3 }
+        | 'if' bool_expr cond_likely '{' body '}' else
+                { cmmIfThenElse $2 (withSourceNote $4 $6 $5) $7 $3 }
+        | 'push' '(' exprs0 ')' maybe_body
+                { pushStackFrame $3 $5 }
+        | 'reserve' expr '=' lreg maybe_body
+                { reserveStackFrame $2 $4 $5 }
+        | 'unwind' unwind_regs ';'
+                { $2 >>= code . emitUnwind }
+
+unwind_regs
+        :: { CmmParse [(GlobalReg, Maybe CmmExpr)] }
+        : GLOBALREG '=' expr_or_unknown ',' unwind_regs
+                { do e <- $3; rest <- $5; return (($1, e) : rest) }
+        | GLOBALREG '=' expr_or_unknown
+                { do e <- $3; return [($1, e)] }
+
+-- | Used by unwind to indicate unknown unwinding values.
+expr_or_unknown
+        :: { CmmParse (Maybe CmmExpr) }
+        : 'return'
+                { do return Nothing }
+        | expr
+                { do e <- $1; return (Just e) }
+
+foreignLabel     :: { CmmParse CmmExpr }
+        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }
+
+opt_never_returns :: { CmmReturnInfo }
+        :                               { CmmMayReturn }
+        | 'never' 'returns'             { CmmNeverReturns }
+
+bool_expr :: { CmmParse BoolExpr }
+        : bool_op                       { $1 }
+        | expr                          { do e <- $1; return (BoolTest e) }
+
+bool_op :: { CmmParse BoolExpr }
+        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; 
+                                          return (BoolAnd e1 e2) }
+        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; 
+                                          return (BoolOr e1 e2)  }
+        | '!' bool_expr                 { do e <- $2; return (BoolNot e) }
+        | '(' bool_op ')'               { $2 }
+
+safety  :: { Safety }
+        : {- empty -}                   { PlayRisky }
+        | STRING                        {% parseSafety $1 }
+
+vols    :: { [GlobalReg] }
+        : '[' ']'                       { [] }
+        | '[' '*' ']'                   {% do df <- getDynFlags
+                                         ; return (realArgRegsCover df) }
+                                           -- All of them. See comment attached
+                                           -- to realArgRegsCover
+        | '[' globals ']'               { $2 }
+
+globals :: { [GlobalReg] }
+        : GLOBALREG                     { [$1] }
+        | GLOBALREG ',' globals         { $1 : $3 }
+
+maybe_range :: { Maybe (Integer,Integer) }
+        : '[' INT '..' INT ']'  { Just ($2, $4) }
+        | {- empty -}           { Nothing }
+
+arms    :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] }
+        : {- empty -}                   { [] }
+        | arm arms                      { $1 : $2 }
+
+arm     :: { CmmParse ([Integer],Either BlockId (CmmParse ())) }
+        : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
+
+arm_body :: { CmmParse (Either BlockId (CmmParse ())) }
+        : '{' body '}'                  { return (Right (withSourceNote $1 $3 $2)) }
+        | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
+
+ints    :: { [Integer] }
+        : INT                           { [ $1 ] }
+        | INT ',' ints                  { $1 : $3 }
+
+default :: { Maybe (CmmParse ()) }
+        : 'default' ':' '{' body '}'    { Just (withSourceNote $3 $5 $4) }
+        -- taking a few liberties with the C-- syntax here; C-- doesn't have
+        -- 'default' branches
+        | {- empty -}                   { Nothing }
+
+-- Note: OldCmm doesn't support a first class 'else' statement, though
+-- CmmNode does.
+else    :: { CmmParse () }
+        : {- empty -}                   { return () }
+        | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }
+
+cond_likely :: { Maybe Bool }
+        : '(' 'likely' ':' 'True'  ')'  { Just True  }
+        | '(' 'likely' ':' 'False' ')'  { Just False }
+        | {- empty -}                   { Nothing }
+
+
+-- we have to write this out longhand so that Happy's precedence rules
+-- can kick in.
+expr    :: { CmmParse CmmExpr }
+        : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }
+        | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }
+        | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }
+        | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }
+        | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }
+        | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }
+        | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }
+        | expr '&' expr                 { mkMachOp MO_And [$1,$3] }
+        | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }
+        | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }
+        | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }
+        | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }
+        | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }
+        | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }
+        | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }
+        | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }
+        | '~' expr                      { mkMachOp MO_Not [$2] }
+        | '-' expr                      { mkMachOp MO_S_Neg [$2] }
+        | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;
+                                                return (mkMachOp mo [$1,$5]) } }
+        | expr0                         { $1 }
+
+expr0   :: { CmmParse CmmExpr }
+        : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
+        | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
+        | STRING                 { do s <- code (newStringCLit $1); 
+                                      return (CmmLit s) }
+        | reg                    { $1 }
+        | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
+        | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
+        | '(' expr ')'           { $2 }
+
+
+-- leaving out the type of a literal gives you the native word size in C--
+maybe_ty :: { CmmType }
+        : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord dflags }
+        | '::' type                     { $2 }
+
+cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
+        : {- empty -}                   { [] }
+        | cmm_hint_exprs                { $1 }
+
+cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }
+        : cmm_hint_expr                 { [$1] }
+        | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
+
+cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }
+        : expr                          { do e <- $1;
+                                             return (e, inferCmmHint e) }
+        | expr STRING                   {% do h <- parseCmmHint $2;
+                                              return $ do
+                                                e <- $1; return (e, h) }
+
+exprs0  :: { [CmmParse CmmExpr] }
+        : {- empty -}                   { [] }
+        | exprs                         { $1 }
+
+exprs   :: { [CmmParse CmmExpr] }
+        : expr                          { [ $1 ] }
+        | expr ',' exprs                { $1 : $3 }
+
+reg     :: { CmmParse CmmExpr }
+        : NAME                  { lookupName $1 }
+        | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
+
+foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }
+        : {- empty -}                   { [] }
+        | '(' foreign_formals ')' '='   { $2 }
+
+foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }
+        : foreign_formal                        { [$1] }
+        | foreign_formal ','                    { [$1] }
+        | foreign_formal ',' foreign_formals    { $1 : $3 }
+
+foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
+        : local_lreg            { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) }
+        | STRING local_lreg     {% do h <- parseCmmHint $1;
+                                      return $ do
+                                         e <- $2; return (e,h) }
+
+local_lreg :: { CmmParse LocalReg }
+        : NAME                  { do e <- lookupName $1;
+                                     return $
+                                       case e of 
+                                        CmmReg (CmmLocal r) -> r
+                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
+
+lreg    :: { CmmParse CmmReg }
+        : NAME                  { do e <- lookupName $1;
+                                     return $
+                                       case e of 
+                                        CmmReg r -> r
+                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
+        | GLOBALREG             { return (CmmGlobal $1) }
+
+maybe_formals :: { Maybe [CmmParse LocalReg] }
+        : {- empty -}           { Nothing }
+        | '(' formals0 ')'      { Just $2 }
+
+formals0 :: { [CmmParse LocalReg] }
+        : {- empty -}           { [] }
+        | formals               { $1 }
+
+formals :: { [CmmParse LocalReg] }
+        : formal ','            { [$1] }
+        | formal                { [$1] }
+        | formal ',' formals       { $1 : $3 }
+
+formal :: { CmmParse LocalReg }
+        : type NAME             { newLocal $1 $2 }
+
+type    :: { CmmType }
+        : 'bits8'               { b8 }
+        | typenot8              { $1 }
+
+typenot8 :: { CmmType }
+        : 'bits16'              { b16 }
+        | 'bits32'              { b32 }
+        | 'bits64'              { b64 }
+        | 'bits128'             { b128 }
+        | 'bits256'             { b256 }
+        | 'bits512'             { b512 }
+        | 'float32'             { f32 }
+        | 'float64'             { f64 }
+        | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }
+
+{
+section :: String -> SectionType
+section "text"      = Text
+section "data"      = Data
+section "rodata"    = ReadOnlyData
+section "relrodata" = RelocatableReadOnlyData
+section "bss"       = UninitialisedData
+section s           = OtherSection s
+
+mkString :: String -> CmmStatic
+mkString s = CmmString (map (fromIntegral.ord) s)
+
+-- |
+-- Given an info table, decide what the entry convention for the proc
+-- is.  That is, for an INFO_TABLE_RET we want the return convention,
+-- otherwise it is a NativeNodeCall.
+--
+infoConv :: Maybe CmmInfoTable -> Convention
+infoConv Nothing = NativeNodeCall
+infoConv (Just info)
+  | isStackRep (cit_rep info) = NativeReturn
+  | otherwise                 = NativeNodeCall
+
+-- mkMachOp infers the type of the MachOp from the type of its first
+-- argument.  We assume that this is correct: for MachOps that don't have
+-- symmetrical args (e.g. shift ops), the first arg determines the type of
+-- the op.
+mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
+mkMachOp fn args = do
+  dflags <- getDynFlags
+  arg_exprs <- sequence args
+  return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)
+
+getLit :: CmmExpr -> CmmLit
+getLit (CmmLit l) = l
+getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
+getLit _ = panic "invalid literal" -- TODO messy failure
+
+nameToMachOp :: FastString -> PD (Width -> MachOp)
+nameToMachOp name =
+  case lookupUFM machOps name of
+        Nothing -> fail ("unknown primitive " ++ unpackFS name)
+        Just m  -> return m
+
+exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
+exprOp name args_code = do
+  dflags <- getDynFlags
+  case lookupUFM (exprMacros dflags) name of
+     Just f  -> return $ do
+        args <- sequence args_code
+        return (f args)
+     Nothing -> do
+        mo <- nameToMachOp name
+        return $ mkMachOp mo args_code
+
+exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
+exprMacros dflags = listToUFM [
+  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),
+  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),
+  ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),
+  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),
+  ( fsLit "GET_ENTRY",    \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),
+  ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),
+  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),
+  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),
+  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),
+  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )
+  ]
+
+-- we understand a subset of C-- primitives:
+machOps = listToUFM $
+        map (\(x, y) -> (mkFastString x, y)) [
+        ( "add",        MO_Add ),
+        ( "sub",        MO_Sub ),
+        ( "eq",         MO_Eq ),
+        ( "ne",         MO_Ne ),
+        ( "mul",        MO_Mul ),
+        ( "neg",        MO_S_Neg ),
+        ( "quot",       MO_S_Quot ),
+        ( "rem",        MO_S_Rem ),
+        ( "divu",       MO_U_Quot ),
+        ( "modu",       MO_U_Rem ),
+
+        ( "ge",         MO_S_Ge ),
+        ( "le",         MO_S_Le ),
+        ( "gt",         MO_S_Gt ),
+        ( "lt",         MO_S_Lt ),
+
+        ( "geu",        MO_U_Ge ),
+        ( "leu",        MO_U_Le ),
+        ( "gtu",        MO_U_Gt ),
+        ( "ltu",        MO_U_Lt ),
+
+        ( "and",        MO_And ),
+        ( "or",         MO_Or ),
+        ( "xor",        MO_Xor ),
+        ( "com",        MO_Not ),
+        ( "shl",        MO_Shl ),
+        ( "shrl",       MO_U_Shr ),
+        ( "shra",       MO_S_Shr ),
+
+        ( "fadd",       MO_F_Add ),
+        ( "fsub",       MO_F_Sub ),
+        ( "fneg",       MO_F_Neg ),
+        ( "fmul",       MO_F_Mul ),
+        ( "fquot",      MO_F_Quot ),
+
+        ( "feq",        MO_F_Eq ),
+        ( "fne",        MO_F_Ne ),
+        ( "fge",        MO_F_Ge ),
+        ( "fle",        MO_F_Le ),
+        ( "fgt",        MO_F_Gt ),
+        ( "flt",        MO_F_Lt ),
+
+        ( "lobits8",  flip MO_UU_Conv W8  ),
+        ( "lobits16", flip MO_UU_Conv W16 ),
+        ( "lobits32", flip MO_UU_Conv W32 ),
+        ( "lobits64", flip MO_UU_Conv W64 ),
+
+        ( "zx16",     flip MO_UU_Conv W16 ),
+        ( "zx32",     flip MO_UU_Conv W32 ),
+        ( "zx64",     flip MO_UU_Conv W64 ),
+
+        ( "sx16",     flip MO_SS_Conv W16 ),
+        ( "sx32",     flip MO_SS_Conv W32 ),
+        ( "sx64",     flip MO_SS_Conv W64 ),
+
+        ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode
+        ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode
+        ( "f2i8",     flip MO_FS_Conv W8 ),
+        ( "f2i16",    flip MO_FS_Conv W16 ),
+        ( "f2i32",    flip MO_FS_Conv W32 ),
+        ( "f2i64",    flip MO_FS_Conv W64 ),
+        ( "i2f32",    flip MO_SF_Conv W32 ),
+        ( "i2f64",    flip MO_SF_Conv W64 )
+        ]
+
+callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
+callishMachOps = listToUFM $
+        map (\(x, y) -> (mkFastString x, y)) [
+        ( "write_barrier", (,) MO_WriteBarrier ),
+        ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
+        ( "memset", memcpyLikeTweakArgs MO_Memset ),
+        ( "memmove", memcpyLikeTweakArgs MO_Memmove ),
+        ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),
+
+        ("prefetch0", (,) $ MO_Prefetch_Data 0),
+        ("prefetch1", (,) $ MO_Prefetch_Data 1),
+        ("prefetch2", (,) $ MO_Prefetch_Data 2),
+        ("prefetch3", (,) $ MO_Prefetch_Data 3),
+
+        ( "popcnt8",  (,) $ MO_PopCnt W8  ),
+        ( "popcnt16", (,) $ MO_PopCnt W16 ),
+        ( "popcnt32", (,) $ MO_PopCnt W32 ),
+        ( "popcnt64", (,) $ MO_PopCnt W64 ),
+
+        ( "pdep8",  (,) $ MO_Pdep W8  ),
+        ( "pdep16", (,) $ MO_Pdep W16 ),
+        ( "pdep32", (,) $ MO_Pdep W32 ),
+        ( "pdep64", (,) $ MO_Pdep W64 ),
+
+        ( "pext8",  (,) $ MO_Pext W8  ),
+        ( "pext16", (,) $ MO_Pext W16 ),
+        ( "pext32", (,) $ MO_Pext W32 ),
+        ( "pext64", (,) $ MO_Pext W64 ),
+
+        ( "cmpxchg8",  (,) $ MO_Cmpxchg W8  ),
+        ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ),
+        ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ),
+        ( "cmpxchg64", (,) $ MO_Cmpxchg W64 )
+
+        -- ToDo: the rest, maybe
+        -- edit: which rest?
+        -- also: how do we tell CMM Lint how to type check callish macops?
+    ]
+  where
+    memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])
+    memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"
+    memcpyLikeTweakArgs op args@(_:_) =
+        (op align, args')
+      where
+        args' = init args
+        align = case last args of
+          CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger
+          e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e)
+        -- The alignment of memcpy-ish operations must be a
+        -- compile-time constant. We verify this here, passing it around
+        -- in the MO_* constructor. In order to do this, however, we
+        -- must intercept the arguments in primCall.
+
+parseSafety :: String -> PD Safety
+parseSafety "safe"   = return PlaySafe
+parseSafety "unsafe" = return PlayRisky
+parseSafety "interruptible" = return PlayInterruptible
+parseSafety str      = fail ("unrecognised safety: " ++ str)
+
+parseCmmHint :: String -> PD ForeignHint
+parseCmmHint "ptr"    = return AddrHint
+parseCmmHint "signed" = return SignedHint
+parseCmmHint str      = fail ("unrecognised hint: " ++ str)
+
+-- labels are always pointers, so we might as well infer the hint
+inferCmmHint :: CmmExpr -> ForeignHint
+inferCmmHint (CmmLit (CmmLabel _)) = AddrHint
+inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint
+inferCmmHint _ = NoHint
+
+isPtrGlobalReg Sp                    = True
+isPtrGlobalReg SpLim                 = True
+isPtrGlobalReg Hp                    = True
+isPtrGlobalReg HpLim                 = True
+isPtrGlobalReg CCCS                  = True
+isPtrGlobalReg CurrentTSO            = True
+isPtrGlobalReg CurrentNursery        = True
+isPtrGlobalReg (VanillaReg _ VGcPtr) = True
+isPtrGlobalReg _                     = False
+
+happyError :: PD a
+happyError = PD $ \_ s -> unP srcParseFail s
+
+-- -----------------------------------------------------------------------------
+-- Statement-level macros
+
+stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())
+stmtMacro fun args_code = do
+  case lookupUFM stmtMacros fun of
+    Nothing -> fail ("unknown macro: " ++ unpackFS fun)
+    Just fcode -> return $ do
+        args <- sequence args_code
+        code (fcode args)
+
+stmtMacros :: UniqFM ([CmmExpr] -> FCode ())
+stmtMacros = listToUFM [
+  ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
+  ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),
+
+  ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
+  ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),
+
+  -- completely generic heap and stack checks, for use in high-level cmm.
+  ( fsLit "HP_CHK_GEN",            \[bytes] ->
+                                      heapStackCheckGen Nothing (Just bytes) ),
+  ( fsLit "STK_CHK_GEN",           \[] ->
+                                      heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),
+
+  -- A stack check for a fixed amount of stack.  Sounds a bit strange, but
+  -- we use the stack for a bit of temporary storage in a couple of primops
+  ( fsLit "STK_CHK_GEN_N",         \[bytes] ->
+                                      heapStackCheckGen (Just bytes) Nothing ),
+
+  -- A stack check on entry to a thunk, where the argument is the thunk pointer.
+  ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),
+
+  ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),
+  ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),
+
+  ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),
+  ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),
+
+  ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),
+  ( fsLit "SET_HDR",               \[ptr,info,ccs] ->
+                                        emitSetDynHdr ptr info ccs ),
+  ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->
+                                        tickyAllocPrim hdr goods slop ),
+  ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->
+                                        tickyAllocPAP goods slop ),
+  ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->
+                                        tickyAllocThunk goods slop ),
+  ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )
+ ]
+
+emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
+emitPushUpdateFrame sp e = do
+  dflags <- getDynFlags
+  emitUpdateFrame dflags sp mkUpdInfoLabel e
+
+pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()
+pushStackFrame fields body = do
+  dflags <- getDynFlags
+  exprs <- sequence fields
+  updfr_off <- getUpdFrameOff
+  let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old
+                                           [] updfr_off exprs
+  emit g
+  withUpdFrameOff new_updfr_off body
+
+reserveStackFrame
+  :: CmmParse CmmExpr
+  -> CmmParse CmmReg
+  -> CmmParse ()
+  -> CmmParse ()
+reserveStackFrame psize preg body = do
+  dflags <- getDynFlags
+  old_updfr_off <- getUpdFrameOff
+  reg <- preg
+  esize <- psize
+  let size = case constantFoldExpr dflags esize of
+               CmmLit (CmmInt n _) -> n
+               _other -> pprPanic "CmmParse: not a compile-time integer: "
+                            (ppr esize)
+  let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size
+  emitAssign reg (CmmStackSlot Old frame)
+  withUpdFrameOff frame body
+
+profilingInfo dflags desc_str ty_str
+  = if not (gopt Opt_SccProfilingOn dflags)
+    then NoProfilingInfo
+    else ProfilingInfo (stringToWord8s desc_str)
+                       (stringToWord8s ty_str)
+
+staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
+staticClosure pkg cl_label info payload
+  = do dflags <- getDynFlags
+       let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
+       code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
+
+foreignCall
+        :: String
+        -> [CmmParse (LocalReg, ForeignHint)]
+        -> CmmParse CmmExpr
+        -> [CmmParse (CmmExpr, ForeignHint)]
+        -> Safety
+        -> CmmReturnInfo
+        -> PD (CmmParse ())
+foreignCall conv_string results_code expr_code args_code safety ret
+  = do  conv <- case conv_string of
+          "C" -> return CCallConv
+          "stdcall" -> return StdCallConv
+          _ -> fail ("unknown calling convention: " ++ conv_string)
+        return $ do
+          dflags <- getDynFlags
+          results <- sequence results_code
+          expr <- expr_code
+          args <- sequence args_code
+          let
+                  expr' = adjCallTarget dflags conv expr args
+                  (arg_exprs, arg_hints) = unzip args
+                  (res_regs,  res_hints) = unzip results
+                  fc = ForeignConvention conv arg_hints res_hints ret
+                  target = ForeignTarget expr' fc
+          _ <- code $ emitForeignCall safety res_regs target arg_exprs
+          return ()
+
+
+doReturn :: [CmmParse CmmExpr] -> CmmParse ()
+doReturn exprs_code = do
+  dflags <- getDynFlags
+  exprs <- sequence exprs_code
+  updfr_off <- getUpdFrameOff
+  emit (mkReturnSimple dflags exprs updfr_off)
+
+mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
+mkReturnSimple dflags actuals updfr_off =
+  mkReturn dflags e actuals updfr_off
+  where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
+                             (gcWord dflags))
+
+doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
+doRawJump expr_code vols = do
+  dflags <- getDynFlags
+  expr <- expr_code
+  updfr_off <- getUpdFrameOff
+  emit (mkRawJump dflags expr updfr_off vols)
+
+doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
+                -> [CmmParse CmmExpr] -> CmmParse ()
+doJumpWithStack expr_code stk_code args_code = do
+  dflags <- getDynFlags
+  expr <- expr_code
+  stk_args <- sequence stk_code
+  args <- sequence args_code
+  updfr_off <- getUpdFrameOff
+  emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)
+
+doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
+       -> CmmParse ()
+doCall expr_code res_code args_code = do
+  dflags <- getDynFlags
+  expr <- expr_code
+  args <- sequence args_code
+  ress <- sequence res_code
+  updfr_off <- getUpdFrameOff
+  c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
+  emit c
+
+adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
+              -> CmmExpr
+-- On Windows, we have to add the '@N' suffix to the label when making
+-- a call with the stdcall calling convention.
+adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
+ | platformOS (targetPlatform dflags) == OSMinGW32
+  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
+  where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
+                 -- c.f. CgForeignCall.emitForeignCall
+adjCallTarget _ _ expr _
+  = expr
+
+primCall
+        :: [CmmParse (CmmFormal, ForeignHint)]
+        -> FastString
+        -> [CmmParse CmmExpr]
+        -> PD (CmmParse ())
+primCall results_code name args_code
+  = case lookupUFM callishMachOps name of
+        Nothing -> fail ("unknown primitive " ++ unpackFS name)
+        Just f  -> return $ do
+                results <- sequence results_code
+                args <- sequence args_code
+                let (p, args') = f args
+                code (emitPrimCall (map fst results) p args')
+
+doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()
+doStore rep addr_code val_code
+  = do dflags <- getDynFlags
+       addr <- addr_code
+       val <- val_code
+        -- if the specified store type does not match the type of the expr
+        -- on the rhs, then we insert a coercion that will cause the type
+        -- mismatch to be flagged by cmm-lint.  If we don't do this, then
+        -- the store will happen at the wrong type, and the error will not
+        -- be noticed.
+       let val_width = typeWidth (cmmExprType dflags val)
+           rep_width = typeWidth rep
+       let coerce_val
+                | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
+                | otherwise              = val
+       emitStore addr coerce_val
+
+-- -----------------------------------------------------------------------------
+-- If-then-else and boolean expressions
+
+data BoolExpr
+  = BoolExpr `BoolAnd` BoolExpr
+  | BoolExpr `BoolOr`  BoolExpr
+  | BoolNot BoolExpr
+  | BoolTest CmmExpr
+
+-- ToDo: smart constructors which simplify the boolean expression.
+
+cmmIfThenElse cond then_part else_part likely = do
+     then_id <- newBlockId
+     join_id <- newBlockId
+     c <- cond
+     emitCond c then_id likely
+     else_part
+     emit (mkBranch join_id)
+     emitLabel then_id
+     then_part
+     -- fall through to join
+     emitLabel join_id
+
+cmmRawIf cond then_id likely = do
+    c <- cond
+    emitCond c then_id likely
+
+-- 'emitCond cond true_id'  emits code to test whether the cond is true,
+-- branching to true_id if so, and falling through otherwise.
+emitCond (BoolTest e) then_id likely = do
+  else_id <- newBlockId
+  emit (mkCbranch e then_id else_id likely)
+  emitLabel else_id
+emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely
+  | Just op' <- maybeInvertComparison op
+  = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely)
+emitCond (BoolNot e) then_id likely = do
+  else_id <- newBlockId
+  emitCond e else_id likely
+  emit (mkBranch then_id)
+  emitLabel else_id
+emitCond (e1 `BoolOr` e2) then_id likely = do
+  emitCond e1 then_id likely
+  emitCond e2 then_id likely
+emitCond (e1 `BoolAnd` e2) then_id likely = do
+        -- we'd like to invert one of the conditionals here to avoid an
+        -- extra branch instruction, but we can't use maybeInvertComparison
+        -- here because we can't look too closely at the expression since
+        -- we're in a loop.
+  and_id <- newBlockId
+  else_id <- newBlockId
+  emitCond e1 and_id likely
+  emit (mkBranch else_id)
+  emitLabel and_id
+  emitCond e2 then_id likely
+  emitLabel else_id
+
+-- -----------------------------------------------------------------------------
+-- Source code notes
+
+-- | Generate a source note spanning from "a" to "b" (inclusive), then
+-- proceed with parsing. This allows debugging tools to reason about
+-- locations in Cmm code.
+withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c
+withSourceNote a b parse = do
+  name <- getName
+  case combineSrcSpans (getLoc a) (getLoc b) of
+    RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse
+    _other           -> parse
+
+-- -----------------------------------------------------------------------------
+-- Table jumps
+
+-- We use a simplified form of C-- switch statements for now.  A
+-- switch statement always compiles to a table jump.  Each arm can
+-- specify a list of values (not ranges), and there can be a single
+-- default branch.  The range of the table is given either by the
+-- optional range on the switch (eg. switch [0..7] {...}), or by
+-- the minimum/maximum values from the branches.
+
+doSwitch :: Maybe (Integer,Integer)
+         -> CmmParse CmmExpr
+         -> [([Integer],Either BlockId (CmmParse ()))]
+         -> Maybe (CmmParse ()) -> CmmParse ()
+doSwitch mb_range scrut arms deflt
+   = do
+        -- Compile code for the default branch
+        dflt_entry <- 
+                case deflt of
+                  Nothing -> return Nothing
+                  Just e  -> do b <- forkLabelledCode e; return (Just b)
+
+        -- Compile each case branch
+        table_entries <- mapM emitArm arms
+        let table = M.fromList (concat table_entries)
+
+        dflags <- getDynFlags
+        let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range
+
+        expr <- scrut
+        -- ToDo: check for out of range and jump to default if necessary
+        emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)
+   where
+        emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]
+        emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
+        emitArm (ints,Right code) = do
+           blockid <- forkLabelledCode code
+           return [ (i,blockid) | i <- ints ]
+
+forkLabelledCode :: CmmParse () -> CmmParse BlockId
+forkLabelledCode p = do
+  (_,ag) <- getCodeScoped p
+  l <- newBlockId
+  emitOutOfLine l ag
+  return l
+
+-- -----------------------------------------------------------------------------
+-- Putting it all together
+
+-- The initial environment: we define some constants that the compiler
+-- knows about here.
+initEnv :: DynFlags -> Env
+initEnv dflags = listToUFM [
+  ( fsLit "SIZEOF_StgHeader",
+    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),
+  ( fsLit "SIZEOF_StgInfoTable",
+    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
+  ]
+
+parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
+parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
+  buf <- hGetStringBuffer filename
+  let
+        init_loc = mkRealSrcLoc (mkFastString filename) 1 1
+        init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
+                -- reset the lex_state: the Lexer monad leaves some stuff
+                -- in there we don't want.
+  case unPD cmmParse dflags init_state of
+    PFailed warnFn span err -> do
+        let msg = mkPlainErrMsg dflags span err
+            errMsgs = (emptyBag, unitBag msg)
+            warnMsgs = warnFn dflags
+        return (unionMessages warnMsgs errMsgs, Nothing)
+    POk pst code -> do
+        st <- initC
+        let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
+            (cmm,_) = runC dflags no_module st fcode
+        let ms = getMessages pst dflags
+        if (errorsFound dflags ms)
+         then return (ms, Nothing)
+         else return (ms, Just cmm)
+  where
+        no_module = panic "parseCmmFile: no module"
+}
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmPipeline.hs
@@ -0,0 +1,360 @@
+{-# LANGUAGE BangPatterns #-}
+
+module CmmPipeline (
+  -- | Converts C-- with an implicit stack and native C-- calls into
+  -- optimized, CPS converted and native-call-less C--.  The latter
+  -- C-- can be used to generate assembly.
+  cmmPipeline
+) where
+
+import GhcPrelude
+
+import Cmm
+import CmmLint
+import CmmBuildInfoTables
+import CmmCommonBlockElim
+import CmmImplementSwitchPlans
+import CmmProcPoint
+import CmmContFlowOpt
+import CmmLayoutStack
+import CmmSink
+import Hoopl.Collections
+
+import UniqSupply
+import DynFlags
+import ErrUtils
+import HscTypes
+import Control.Monad
+import Outputable
+import Platform
+
+-----------------------------------------------------------------------------
+-- | Top level driver for C-- pipeline
+-----------------------------------------------------------------------------
+
+cmmPipeline
+ :: HscEnv -- Compilation env including
+           -- dynamic flags: -dcmm-lint -ddump-cmm-cps
+ -> ModuleSRTInfo        -- Info about SRTs generated so far
+ -> CmmGroup             -- Input C-- with Procedures
+ -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C--
+
+cmmPipeline hsc_env srtInfo prog =
+  do let dflags = hsc_dflags hsc_env
+
+     tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
+
+     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops
+     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms)
+
+     return (srtInfo, cmms)
+
+
+cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
+cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
+cpsTop hsc_env proc =
+    do
+       ----------- Control-flow optimisations ----------------------------------
+
+       -- The first round of control-flow optimisation speeds up the
+       -- later passes by removing lots of empty blocks, so we do it
+       -- even when optimisation isn't turned on.
+       --
+       CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}
+            return $ cmmCfgOptsProc splitting_proc_points proc
+       dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
+
+       let !TopInfo {stack_info=StackInfo { arg_space = entry_off
+                                          , do_layout = do_layout }} = h
+
+       ----------- Eliminate common blocks -------------------------------------
+       g <- {-# SCC "elimCommonBlocks" #-}
+            condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
+                          Opt_D_dump_cmm_cbe "Post common block elimination"
+
+       -- Any work storing block Labels must be performed _after_
+       -- elimCommonBlocks
+
+       g <- {-# SCC "createSwitchPlans" #-}
+            runUniqSM $ cmmImplementSwitchPlans dflags g
+       dump Opt_D_dump_cmm_switch "Post switch plan" g
+
+       ----------- Proc points -------------------------------------------------
+       let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
+       proc_points <-
+          if splitting_proc_points
+             then do
+               pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
+                  minimalProcPointSet (targetPlatform dflags) call_pps g
+               dumpWith dflags Opt_D_dump_cmm_proc "Proc points"
+                     (ppr l $$ ppr pp $$ ppr g)
+               return pp
+             else
+               return call_pps
+
+       ----------- Layout the stack and manifest Sp ----------------------------
+       (g, stackmaps) <-
+            {-# SCC "layoutStack" #-}
+            if do_layout
+               then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
+               else return (g, mapEmpty)
+       dump Opt_D_dump_cmm_sp "Layout Stack" g
+
+       ----------- Sink and inline assignments  --------------------------------
+       g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]
+            condPass Opt_CmmSink (cmmSink dflags) g
+                     Opt_D_dump_cmm_sink "Sink assignments"
+
+       ------------- CAF analysis ----------------------------------------------
+       let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g
+       dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv)
+
+       g <- if splitting_proc_points
+            then do
+               ------------- Split into separate procedures -----------------------
+               let pp_map = {-# SCC "procPointAnalysis" #-}
+                            procPointAnalysis proc_points g
+               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $
+                    ppr pp_map
+               g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
+                    splitAtProcPoints dflags l call_pps proc_points pp_map
+                                      (CmmProc h l v g)
+               dumps Opt_D_dump_cmm_split "Post splitting" g
+               return g
+             else do
+               -- attach info tables to return points
+               return $ [attachContInfoTables call_pps (CmmProc h l v g)]
+
+       ------------- Populate info tables with stack info -----------------
+       g <- {-# SCC "setInfoTableStackMap" #-}
+            return $ map (setInfoTableStackMap dflags stackmaps) g
+       dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g
+
+       ----------- Control-flow optimisations -----------------------------
+       g <- {-# SCC "cmmCfgOpts(2)" #-}
+            return $ if optLevel dflags >= 1
+                     then map (cmmCfgOptsProc splitting_proc_points) g
+                     else g
+       g <- return (map removeUnreachableBlocksProc g)
+            -- See Note [unreachable blocks]
+       dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
+
+       return (cafEnv, g)
+
+  where dflags = hsc_dflags hsc_env
+        platform = targetPlatform dflags
+        dump = dumpGraph dflags
+
+        dumps flag name
+           = mapM_ (dumpWith dflags flag name . ppr)
+
+        condPass flag pass g dumpflag dumpname =
+            if gopt flag dflags
+               then do
+                    g <- return $ pass g
+                    dump dumpflag dumpname g
+                    return g
+               else return g
+
+        -- we don't need to split proc points for the NCG, unless
+        -- tablesNextToCode is off.  The latter is because we have no
+        -- label to put on info tables for basic blocks that are not
+        -- the entry point.
+        splitting_proc_points = hscTarget dflags /= HscAsm
+                             || not (tablesNextToCode dflags)
+                             || -- Note [inconsistent-pic-reg]
+                                usingInconsistentPicReg
+        usingInconsistentPicReg
+           = case (platformArch platform, platformOS platform, positionIndependent dflags)
+             of   (ArchX86, OSDarwin, pic) -> pic
+                  _                        -> False
+
+-- Note [Sinking after stack layout]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- In the past we considered running sinking pass also before stack
+-- layout, but after making some measurements we realized that:
+--
+--   a) running sinking only before stack layout produces slower
+--      code than running sinking only before stack layout
+--
+--   b) running sinking both before and after stack layout produces
+--      code that has the same performance as when running sinking
+--      only after stack layout.
+--
+-- In other words sinking before stack layout doesn't buy as anything.
+--
+-- An interesting question is "why is it better to run sinking after
+-- stack layout"? It seems that the major reason are stores and loads
+-- generated by stack layout. Consider this code before stack layout:
+--
+--  c1E:
+--      _c1C::P64 = R3;
+--      _c1B::P64 = R2;
+--      _c1A::P64 = R1;
+--      I64[(young<c1D> + 8)] = c1D;
+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
+--  c1D:
+--      R3 = _c1C::P64;
+--      R2 = _c1B::P64;
+--      R1 = _c1A::P64;
+--      call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8;
+--
+-- Stack layout pass will save all local variables live across a call
+-- (_c1C, _c1B and _c1A in this example) on the stack just before
+-- making a call and reload them from the stack after returning from a
+-- call:
+--
+--  c1E:
+--      _c1C::P64 = R3;
+--      _c1B::P64 = R2;
+--      _c1A::P64 = R1;
+--      I64[Sp - 32] = c1D;
+--      P64[Sp - 24] = _c1A::P64;
+--      P64[Sp - 16] = _c1B::P64;
+--      P64[Sp - 8] = _c1C::P64;
+--      Sp = Sp - 32;
+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
+--  c1D:
+--      _c1A::P64 = P64[Sp + 8];
+--      _c1B::P64 = P64[Sp + 16];
+--      _c1C::P64 = P64[Sp + 24];
+--      R3 = _c1C::P64;
+--      R2 = _c1B::P64;
+--      R1 = _c1A::P64;
+--      Sp = Sp + 32;
+--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
+--
+-- If we don't run sinking pass after stack layout we are basically
+-- left with such code. However, running sinking on this code can lead
+-- to significant improvements:
+--
+--  c1E:
+--      I64[Sp - 32] = c1D;
+--      P64[Sp - 24] = R1;
+--      P64[Sp - 16] = R2;
+--      P64[Sp - 8] = R3;
+--      Sp = Sp - 32;
+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;
+--  c1D:
+--      R3 = P64[Sp + 24];
+--      R2 = P64[Sp + 16];
+--      R1 = P64[Sp + 8];
+--      Sp = Sp + 32;
+--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;
+--
+-- Now we only have 9 assignments instead of 15.
+--
+-- There is one case when running sinking before stack layout could
+-- be beneficial. Consider this:
+--
+--   L1:
+--      x = y
+--      call f() returns L2
+--   L2: ...x...y...
+--
+-- Since both x and y are live across a call to f, they will be stored
+-- on the stack during stack layout and restored after the call:
+--
+--   L1:
+--      x = y
+--      P64[Sp - 24] = L2
+--      P64[Sp - 16] = x
+--      P64[Sp - 8]  = y
+--      Sp = Sp - 24
+--      call f() returns L2
+--   L2:
+--      y = P64[Sp + 16]
+--      x = P64[Sp + 8]
+--      Sp = Sp + 24
+--      ...x...y...
+--
+-- However, if we run sinking before stack layout we would propagate x
+-- to its usage place (both x and y must be local register for this to
+-- be possible - global registers cannot be floated past a call):
+--
+--   L1:
+--      x = y
+--      call f() returns L2
+--   L2: ...y...y...
+--
+-- Thus making x dead at the call to f(). If we ran stack layout now
+-- we would generate less stores and loads:
+--
+--   L1:
+--      x = y
+--      P64[Sp - 16] = L2
+--      P64[Sp - 8]  = y
+--      Sp = Sp - 16
+--      call f() returns L2
+--   L2:
+--      y = P64[Sp + 8]
+--      Sp = Sp + 16
+--      ...y...y...
+--
+-- But since we don't see any benefits from running sinking befroe stack
+-- layout, this situation probably doesn't arise too often in practice.
+--
+
+{- Note [inconsistent-pic-reg]
+
+On x86/Darwin, PIC is implemented by inserting a sequence like
+
+    call 1f
+ 1: popl %reg
+
+at the proc entry point, and then referring to labels as offsets from
+%reg.  If we don't split proc points, then we could have many entry
+points in a proc that would need this sequence, and each entry point
+would then get a different value for %reg.  If there are any join
+points, then at the join point we don't have a consistent value for
+%reg, so we don't know how to refer to labels.
+
+Hence, on x86/Darwin, we have to split proc points, and then each proc
+point will get its own PIC initialisation sequence.
+
+This isn't an issue on x86/ELF, where the sequence is
+
+    call 1f
+ 1: popl %reg
+    addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg
+
+so %reg always has a consistent value: the address of
+_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.
+
+-}
+
+{- Note [unreachable blocks]
+
+The control-flow optimiser sometimes leaves unreachable blocks behind
+containing junk code.  These aren't necessarily a problem, but
+removing them is good because it might save time in the native code
+generator later.
+
+-}
+
+runUniqSM :: UniqSM a -> IO a
+runUniqSM m = do
+  us <- mkSplitUniqSupply 'u'
+  return (initUs_ us m)
+
+
+dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
+dumpGraph dflags flag name g = do
+  when (gopt Opt_DoCmmLinting dflags) $ do_lint g
+  dumpWith dflags flag name (ppr g)
+ where
+  do_lint g = case cmmLintGraph dflags g of
+                 Just err -> do { fatalErrorMsg dflags err
+                                ; ghcExit dflags 1
+                                }
+                 Nothing  -> return ()
+
+dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
+dumpWith dflags flag txt sdoc = do
+         -- ToDo: No easy way of say "dump all the cmm, *and* split
+         -- them into files."  Also, -ddump-cmm-verbose doesn't play
+         -- nicely with -ddump-to-file, since the headers get omitted.
+   dumpIfSet_dyn dflags flag txt sdoc
+   when (not (dopt flag dflags)) $
+      dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose txt sdoc
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -0,0 +1,496 @@
+{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}
+
+module CmmProcPoint
+    ( ProcPointSet, Status(..)
+    , callProcPoints, minimalProcPointSet
+    , splitAtProcPoints, procPointAnalysis
+    , attachContInfoTables
+    )
+where
+
+import GhcPrelude hiding (last, unzip, succ, zip)
+
+import DynFlags
+import BlockId
+import CLabel
+import Cmm
+import PprCmm ()
+import CmmUtils
+import CmmInfo
+import CmmLive
+import CmmSwitch
+import Data.List (sortBy)
+import Maybes
+import Control.Monad
+import Outputable
+import Platform
+import UniqSupply
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Dataflow
+import Hoopl.Graph
+import Hoopl.Label
+
+-- Compute a minimal set of proc points for a control-flow graph.
+
+-- Determine a protocol for each proc point (which live variables will
+-- be passed as arguments and which will be on the stack).
+
+{-
+A proc point is a basic block that, after CPS transformation, will
+start a new function.  The entry block of the original function is a
+proc point, as is the continuation of each function call.
+A third kind of proc point arises if we want to avoid copying code.
+Suppose we have code like the following:
+
+  f() {
+    if (...) { ..1..; call foo(); ..2..}
+    else     { ..3..; call bar(); ..4..}
+    x = y + z;
+    return x;
+  }
+
+The statement 'x = y + z' can be reached from two different proc
+points: the continuations of foo() and bar().  We would prefer not to
+put a copy in each continuation; instead we would like 'x = y + z' to
+be the start of a new procedure to which the continuations can jump:
+
+  f_cps () {
+    if (...) { ..1..; push k_foo; jump foo_cps(); }
+    else     { ..3..; push k_bar; jump bar_cps(); }
+  }
+  k_foo() { ..2..; jump k_join(y, z); }
+  k_bar() { ..4..; jump k_join(y, z); }
+  k_join(y, z) { x = y + z; return x; }
+
+You might think then that a criterion to make a node a proc point is
+that it is directly reached by two distinct proc points.  (Note
+[Direct reachability].)  But this criterion is a bit too simple; for
+example, 'return x' is also reached by two proc points, yet there is
+no point in pulling it out of k_join.  A good criterion would be to
+say that a node should be made a proc point if it is reached by a set
+of proc points that is different than its immediate dominator.  NR
+believes this criterion can be shown to produce a minimum set of proc
+points, and given a dominator tree, the proc points can be chosen in
+time linear in the number of blocks.  Lacking a dominator analysis,
+however, we turn instead to an iterative solution, starting with no
+proc points and adding them according to these rules:
+
+  1. The entry block is a proc point.
+  2. The continuation of a call is a proc point.
+  3. A node is a proc point if it is directly reached by more proc
+     points than one of its predecessors.
+
+Because we don't understand the problem very well, we apply rule 3 at
+most once per iteration, then recompute the reachability information.
+(See Note [No simple dataflow].)  The choice of the new proc point is
+arbitrary, and I don't know if the choice affects the final solution,
+so I don't know if the number of proc points chosen is the
+minimum---but the set will be minimal.
+
+
+
+Note [Proc-point analysis]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Given a specified set of proc-points (a set of block-ids), "proc-point
+analysis" figures out, for every block, which proc-point it belongs to.
+All the blocks belonging to proc-point P will constitute a single
+top-level C procedure.
+
+A non-proc-point block B "belongs to" a proc-point P iff B is
+reachable from P without going through another proc-point.
+
+Invariant: a block B should belong to at most one proc-point; if it
+belongs to two, that's a bug.
+
+Note [Non-existing proc-points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+On some architectures it might happen that the list of proc-points
+computed before stack layout pass will be invalidated by the stack
+layout. This will happen if stack layout removes from the graph
+blocks that were determined to be proc-points. Later on in the pipeline
+we use list of proc-points to perform [Proc-point analysis], but
+if a proc-point does not exist anymore then we will get compiler panic.
+See #8205.
+-}
+
+type ProcPointSet = LabelSet
+
+data Status
+  = ReachedBy ProcPointSet  -- set of proc points that directly reach the block
+  | ProcPoint               -- this block is itself a proc point
+
+instance Outputable Status where
+  ppr (ReachedBy ps)
+      | setNull ps = text "<not-reached>"
+      | otherwise = text "reached by" <+>
+                    (hsep $ punctuate comma $ map ppr $ setElems ps)
+  ppr ProcPoint = text "<procpt>"
+
+--------------------------------------------------
+-- Proc point analysis
+
+-- Once you know what the proc-points are, figure out
+-- what proc-points each block is reachable from
+-- See Note [Proc-point analysis]
+procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status
+procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =
+    analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints
+  where
+    initProcPoints =
+        mkFactBase
+            procPointLattice
+            [ (id, ProcPoint)
+            | id <- setElems procPoints
+            -- See Note [Non-existing proc-points]
+            , id `setMember` labelsInGraph
+            ]
+    labelsInGraph = labelsDefined graph
+
+procPointTransfer :: TransferFun Status
+procPointTransfer block facts =
+    let label = entryLabel block
+        !fact = case getFact procPointLattice label facts of
+            ProcPoint -> ReachedBy $! setSingleton label
+            f -> f
+        result = map (\id -> (id, fact)) (successors block)
+    in mkFactBase procPointLattice result
+
+procPointLattice :: DataflowLattice Status
+procPointLattice = DataflowLattice unreached add_to
+  where
+    unreached = ReachedBy setEmpty
+    add_to (OldFact ProcPoint) _ = NotChanged ProcPoint
+    add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case
+    add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))
+        | setSize union > setSize p = Changed (ReachedBy union)
+        | otherwise = NotChanged (ReachedBy p)
+      where
+        union = setUnion p' p
+
+----------------------------------------------------------------------
+
+-- It is worth distinguishing two sets of proc points: those that are
+-- induced by calls in the original graph and those that are
+-- introduced because they're reachable from multiple proc points.
+--
+-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].
+callProcPoints      :: CmmGraph -> ProcPointSet
+callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g
+  where add :: LabelSet -> CmmBlock -> LabelSet
+        add set b = case lastNode b of
+                      CmmCall {cml_cont = Just k} -> setInsert k set
+                      CmmForeignCall {succ=k}     -> setInsert k set
+                      _ -> set
+
+minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
+                    -> UniqSM ProcPointSet
+-- Given the set of successors of calls (which must be proc-points)
+-- figure out the minimal set of necessary proc-points
+minimalProcPointSet platform callProcPoints g
+  = extendPPSet platform g (revPostorder g) callProcPoints
+
+extendPPSet
+    :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
+extendPPSet platform g blocks procPoints =
+    let env = procPointAnalysis procPoints g
+        add pps block = let id = entryLabel block
+                        in  case mapLookup id env of
+                              Just ProcPoint -> setInsert id pps
+                              _ -> pps
+        procPoints' = foldlGraphBlocks add setEmpty g
+        newPoints = mapMaybe ppSuccessor blocks
+        newPoint  = listToMaybe newPoints
+        ppSuccessor b =
+            let nreached id = case mapLookup id env `orElse`
+                                    pprPanic "no ppt" (ppr id <+> ppr b) of
+                                ProcPoint -> 1
+                                ReachedBy ps -> setSize ps
+                block_procpoints = nreached (entryLabel b)
+                -- | Looking for a successor of b that is reached by
+                -- more proc points than b and is not already a proc
+                -- point.  If found, it can become a proc point.
+                newId succ_id = not (setMember succ_id procPoints') &&
+                                nreached succ_id > block_procpoints
+            in  listToMaybe $ filter newId $ successors b
+
+    in case newPoint of
+         Just id ->
+             if setMember id procPoints'
+                then panic "added old proc pt"
+                else extendPPSet platform g blocks (setInsert id procPoints')
+         Nothing -> return procPoints'
+
+
+-- At this point, we have found a set of procpoints, each of which should be
+-- the entry point of a procedure.
+-- Now, we create the procedure for each proc point,
+-- which requires that we:
+-- 1. build a map from proc points to the blocks reachable from the proc point
+-- 2. turn each branch to a proc point into a jump
+-- 3. turn calls and returns into jumps
+-- 4. build info tables for the procedures -- and update the info table for
+--    the SRTs in the entry procedure as well.
+-- Input invariant: A block should only be reachable from a single ProcPoint.
+-- ToDo: use the _ret naming convention that the old code generator
+-- used. -- EZY
+splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->
+                     CmmDecl -> UniqSM [CmmDecl]
+splitAtProcPoints dflags entry_label callPPs procPoints procMap
+                  (CmmProc (TopInfo {info_tbls = info_tbls})
+                           top_l _ g@(CmmGraph {g_entry=entry})) =
+  do -- Build a map from procpoints to the blocks they reach
+     let add_block
+             :: LabelMap (LabelMap CmmBlock)
+             -> CmmBlock
+             -> LabelMap (LabelMap CmmBlock)
+         add_block graphEnv b =
+           case mapLookup bid procMap of
+             Just ProcPoint -> add graphEnv bid bid b
+             Just (ReachedBy set) ->
+               case setElems set of
+                 []   -> graphEnv
+                 [id] -> add graphEnv id bid b
+                 _    -> panic "Each block should be reachable from only one ProcPoint"
+             Nothing -> graphEnv
+           where bid = entryLabel b
+         add graphEnv procId bid b = mapInsert procId graph' graphEnv
+               where graph  = mapLookup procId graphEnv `orElse` mapEmpty
+                     graph' = mapInsert bid b graph
+
+     let liveness = cmmGlobalLiveness dflags g
+     let ppLiveness pp = filter isArgReg $
+                         regSetToList $
+                         expectJust "ppLiveness" $ mapLookup pp liveness
+
+     graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g
+
+     -- Build a map from proc point BlockId to pairs of:
+     --  * Labels for their new procedures
+     --  * Labels for the info tables of their new procedures (only if
+     --    the proc point is a callPP)
+     -- Due to common blockification, we may overestimate the set of procpoints.
+     let add_label map pp = mapInsert pp lbls map
+           where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))
+                      | otherwise   = (block_lbl, guard (setMember pp callPPs) >>
+                                                    Just info_table_lbl)
+                      where block_lbl      = blockLbl pp
+                            info_table_lbl = infoTblLbl pp
+
+         procLabels :: LabelMap (CLabel, Maybe CLabel)
+         procLabels = foldl' add_label mapEmpty
+                             (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
+
+     -- In each new graph, add blocks jumping off to the new procedures,
+     -- and replace branches to procpoints with branches to the jump-off blocks
+     let add_jump_block
+             :: (LabelMap Label, [CmmBlock])
+             -> (Label, CLabel)
+             -> UniqSM (LabelMap Label, [CmmBlock])
+         add_jump_block (env, bs) (pp, l) =
+           do bid <- liftM mkBlockId getUniqueM
+              let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump
+                  live = ppLiveness pp
+                  jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
+              return (mapInsert pp bid env, b : bs)
+
+         add_jumps
+             :: LabelMap CmmGraph
+             -> (Label, LabelMap CmmBlock)
+             -> UniqSM (LabelMap CmmGraph)
+         add_jumps newGraphEnv (ppId, blockEnv) =
+           do let needed_jumps = -- find which procpoints we currently branch to
+                    mapFoldr add_if_branch_to_pp [] blockEnv
+                  add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
+                  add_if_branch_to_pp block rst =
+                    case lastNode block of
+                      CmmBranch id          -> add_if_pp id rst
+                      CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)
+                      CmmSwitch _ ids       -> foldr add_if_pp rst $ switchTargetsToList ids
+                      _                     -> rst
+
+                  -- when jumping to a PP that has an info table, if
+                  -- tablesNextToCode is off we must jump to the entry
+                  -- label instead.
+                  jump_label (Just info_lbl) _
+                             | tablesNextToCode dflags = info_lbl
+                             | otherwise               = toEntryLbl info_lbl
+                  jump_label Nothing         block_lbl = block_lbl
+
+                  add_if_pp id rst = case mapLookup id procLabels of
+                                       Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
+                                       Nothing                 -> rst
+              (jumpEnv, jumpBlocks) <-
+                 foldM add_jump_block (mapEmpty, []) needed_jumps
+                  -- update the entry block
+              let b = expectJust "block in env" $ mapLookup ppId blockEnv
+                  blockEnv' = mapInsert ppId b blockEnv
+                  -- replace branches to procpoints with branches to jumps
+                  blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
+                  -- add the jump blocks to the graph
+                  blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks
+              let g' = ofBlockMap ppId blockEnv'''
+              -- pprTrace "g' pre jumps" (ppr g') $ do
+              return (mapInsert ppId g' newGraphEnv)
+
+     graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv
+
+     let to_proc (bid, g)
+             | bid == entry
+             =  CmmProc (TopInfo {info_tbls  = info_tbls,
+                                  stack_info = stack_info})
+                        top_l live g'
+             | otherwise
+             = case expectJust "pp label" $ mapLookup bid procLabels of
+                 (lbl, Just info_lbl)
+                    -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)
+                                        , stack_info=stack_info})
+                               lbl live g'
+                 (lbl, Nothing)
+                    -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
+                               lbl live g'
+                where
+                 g' = replacePPIds g
+                 live = ppLiveness (g_entry g')
+                 stack_info = StackInfo { arg_space = 0
+                                        , updfr_space =  Nothing
+                                        , do_layout = True }
+                               -- cannot use panic, this is printed by -ddump-cmm
+
+         -- References to procpoint IDs can now be replaced with the
+         -- infotable's label
+         replacePPIds g = {-# SCC "replacePPIds" #-}
+                          mapGraphNodes (id, mapExp repl, mapExp repl) g
+           where repl e@(CmmLit (CmmBlock bid)) =
+                   case mapLookup bid procLabels of
+                     Just (_, Just info_lbl)  -> CmmLit (CmmLabel info_lbl)
+                     _ -> e
+                 repl e = e
+
+     -- The C back end expects to see return continuations before the
+     -- call sites.  Here, we sort them in reverse order -- it gets
+     -- reversed later.
+     let (_, block_order) =
+             foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)
+                   (revPostorder g)
+         add_block_num (i, map) block =
+           (i + 1, mapInsert (entryLabel block) i map)
+         sort_fn (bid, _) (bid', _) =
+           compare (expectJust "block_order" $ mapLookup bid  block_order)
+                   (expectJust "block_order" $ mapLookup bid' block_order)
+     procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
+     return -- pprTrace "procLabels" (ppr procLabels)
+            -- pprTrace "splitting graphs" (ppr procs)
+            procs
+splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
+
+-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
+-- recursive lookup, see comment below.
+replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph
+replaceBranches env cmmg
+  = {-# SCC "replaceBranches" #-}
+    ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg
+  where
+    f block = replaceLastNode block $ last (lastNode block)
+
+    last :: CmmNode O C -> CmmNode O C
+    last (CmmBranch id)          = CmmBranch (lookup id)
+    last (CmmCondBranch e ti fi l) = CmmCondBranch e (lookup ti) (lookup fi) l
+    last (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets lookup ids)
+    last l@(CmmCall {})          = l { cml_cont = Nothing }
+            -- NB. remove the continuation of a CmmCall, since this
+            -- label will now be in a different CmmProc.  Not only
+            -- is this tidier, it stops CmmLint from complaining.
+    last l@(CmmForeignCall {})   = l
+    lookup id = fmap lookup (mapLookup id env) `orElse` id
+            -- XXX: this is a recursive lookup, it follows chains
+            -- until the lookup returns Nothing, at which point we
+            -- return the last BlockId
+
+-- --------------------------------------------------------------
+-- Not splitting proc points: add info tables for continuations
+
+attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
+attachContInfoTables call_proc_points (CmmProc top_info top_l live g)
+ = CmmProc top_info{info_tbls = info_tbls'} top_l live g
+ where
+   info_tbls' = mapUnion (info_tbls top_info) $
+                mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))
+                            | l <- setElems call_proc_points
+                            , l /= g_entry g ]
+attachContInfoTables _ other_decl
+ = other_decl
+
+----------------------------------------------------------------
+
+{-
+Note [Direct reachability]
+
+Block B is directly reachable from proc point P iff control can flow
+from P to B without passing through an intervening proc point.
+-}
+
+----------------------------------------------------------------
+
+{-
+Note [No simple dataflow]
+
+Sadly, it seems impossible to compute the proc points using a single
+dataflow pass.  One might attempt to use this simple lattice:
+
+  data Location = Unknown
+                | InProc BlockId -- node is in procedure headed by the named proc point
+                | ProcPoint      -- node is itself a proc point
+
+At a join, a node in two different blocks becomes a proc point.
+The difficulty is that the change of information during iterative
+computation may promote a node prematurely.  Here's a program that
+illustrates the difficulty:
+
+  f () {
+  entry:
+    ....
+  L1:
+    if (...) { ... }
+    else { ... }
+
+  L2: if (...) { g(); goto L1; }
+      return x + y;
+  }
+
+The only proc-point needed (besides the entry) is L1.  But in an
+iterative analysis, consider what happens to L2.  On the first pass
+through, it rises from Unknown to 'InProc entry', but when L1 is
+promoted to a proc point (because it's the successor of g()), L1's
+successors will be promoted to 'InProc L1'.  The problem hits when the
+new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.
+The join operation makes it a proc point when in fact it needn't be,
+because its immediate dominator L1 is already a proc point and there
+are no other proc points that directly reach L2.
+-}
+
+
+
+{- Note [Separate Adams optimization]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It may be worthwhile to attempt the Adams optimization by rewriting
+the graph before the assignment of proc-point protocols.  Here are a
+couple of rules:
+
+  g() returns to k;                    g() returns to L;
+  k: CopyIn c ress; goto L:
+   ...                        ==>        ...
+  L: // no CopyIn node here            L: CopyIn c ress;
+
+
+And when c == c' and ress == ress', this also:
+
+  g() returns to k;                    g() returns to L;
+  k: CopyIn c ress; goto L:
+   ...                        ==>        ...
+  L: CopyIn c' ress'                   L: CopyIn c' ress' ;
+
+In both cases the goal is to eliminate k.
+-}
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmSink.hs
@@ -0,0 +1,855 @@
+{-# LANGUAGE GADTs #-}
+module CmmSink (
+     cmmSink
+  ) where
+
+import GhcPrelude
+
+import Cmm
+import CmmOpt
+import CmmLive
+import CmmUtils
+import Hoopl.Block
+import Hoopl.Label
+import Hoopl.Collections
+import Hoopl.Graph
+import CodeGen.Platform
+import Platform (isARM, platformArch)
+
+import DynFlags
+import Unique
+import UniqFM
+import PprCmm ()
+
+import qualified Data.IntSet as IntSet
+import Data.List (partition)
+import qualified Data.Set as Set
+import Data.Maybe
+
+-- Compact sets for membership tests of local variables.
+
+type LRegSet = IntSet.IntSet
+
+emptyLRegSet :: LRegSet
+emptyLRegSet = IntSet.empty
+
+nullLRegSet :: LRegSet -> Bool
+nullLRegSet = IntSet.null
+
+insertLRegSet :: LocalReg -> LRegSet -> LRegSet
+insertLRegSet l = IntSet.insert (getKey (getUnique l))
+
+elemLRegSet :: LocalReg -> LRegSet -> Bool
+elemLRegSet l = IntSet.member (getKey (getUnique l))
+
+-- -----------------------------------------------------------------------------
+-- Sinking and inlining
+
+-- This is an optimisation pass that
+--  (a) moves assignments closer to their uses, to reduce register pressure
+--  (b) pushes assignments into a single branch of a conditional if possible
+--  (c) inlines assignments to registers that are mentioned only once
+--  (d) discards dead assignments
+--
+-- This tightens up lots of register-heavy code.  It is particularly
+-- helpful in the Cmm generated by the Stg->Cmm code generator, in
+-- which every function starts with a copyIn sequence like:
+--
+--    x1 = R1
+--    x2 = Sp[8]
+--    x3 = Sp[16]
+--    if (Sp - 32 < SpLim) then L1 else L2
+--
+-- we really want to push the x1..x3 assignments into the L2 branch.
+--
+-- Algorithm:
+--
+--  * Start by doing liveness analysis.
+--
+--  * Keep a list of assignments A; earlier ones may refer to later ones.
+--    Currently we only sink assignments to local registers, because we don't
+--    have liveness information about global registers.
+--
+--  * Walk forwards through the graph, look at each node N:
+--
+--    * If it is a dead assignment, i.e. assignment to a register that is
+--      not used after N, discard it.
+--
+--    * Try to inline based on current list of assignments
+--      * If any assignments in A (1) occur only once in N, and (2) are
+--        not live after N, inline the assignment and remove it
+--        from A.
+--
+--      * If an assignment in A is cheap (RHS is local register), then
+--        inline the assignment and keep it in A in case it is used afterwards.
+--
+--      * Otherwise don't inline.
+--
+--    * If N is assignment to a local register pick up the assignment
+--      and add it to A.
+--
+--    * If N is not an assignment to a local register:
+--      * remove any assignments from A that conflict with N, and
+--        place them before N in the current block.  We call this
+--        "dropping" the assignments.
+--
+--      * An assignment conflicts with N if it:
+--        - assigns to a register mentioned in N
+--        - mentions a register assigned by N
+--        - reads from memory written by N
+--      * do this recursively, dropping dependent assignments
+--
+--    * At an exit node:
+--      * drop any assignments that are live on more than one successor
+--        and are not trivial
+--      * if any successor has more than one predecessor (a join-point),
+--        drop everything live in that successor. Since we only propagate
+--        assignments that are not dead at the successor, we will therefore
+--        eliminate all assignments dead at this point. Thus analysis of a
+--        join-point will always begin with an empty list of assignments.
+--
+--
+-- As a result of above algorithm, sinking deletes some dead assignments
+-- (transitively, even).  This isn't as good as removeDeadAssignments,
+-- but it's much cheaper.
+
+-- -----------------------------------------------------------------------------
+-- things that we aren't optimising very well yet.
+--
+-- -----------
+-- (1) From GHC's FastString.hashStr:
+--
+--  s2ay:
+--      if ((_s2an::I64 == _s2ao::I64) >= 1) goto c2gn; else goto c2gp;
+--  c2gn:
+--      R1 = _s2au::I64;
+--      call (I64[Sp])(R1) args: 8, res: 0, upd: 8;
+--  c2gp:
+--      _s2cO::I64 = %MO_S_Rem_W64(%MO_UU_Conv_W8_W64(I8[_s2aq::I64 + (_s2an::I64 << 0)]) + _s2au::I64 * 128,
+--                                 4091);
+--      _s2an::I64 = _s2an::I64 + 1;
+--      _s2au::I64 = _s2cO::I64;
+--      goto s2ay;
+--
+-- a nice loop, but we didn't eliminate the silly assignment at the end.
+-- See Note [dependent assignments], which would probably fix this.
+-- This is #8336 on Trac.
+--
+-- -----------
+-- (2) From stg_atomically_frame in PrimOps.cmm
+--
+-- We have a diamond control flow:
+--
+--     x = ...
+--       |
+--      / \
+--     A   B
+--      \ /
+--       |
+--    use of x
+--
+-- Now x won't be sunk down to its use, because we won't push it into
+-- both branches of the conditional.  We certainly do have to check
+-- that we can sink it past all the code in both A and B, but having
+-- discovered that, we could sink it to its use.
+--
+
+-- -----------------------------------------------------------------------------
+
+type Assignment = (LocalReg, CmmExpr, AbsMem)
+  -- Assignment caches AbsMem, an abstraction of the memory read by
+  -- the RHS of the assignment.
+
+type Assignments = [Assignment]
+  -- A sequence of assignments; kept in *reverse* order
+  -- So the list [ x=e1, y=e2 ] means the sequence of assignments
+  --     y = e2
+  --     x = e1
+
+cmmSink :: DynFlags -> CmmGraph -> CmmGraph
+cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
+  where
+  liveness = cmmLocalLiveness dflags graph
+  getLive l = mapFindWithDefault Set.empty l liveness
+
+  blocks = revPostorder graph
+
+  join_pts = findJoinPoints blocks
+
+  sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]
+  sink _ [] = []
+  sink sunk (b:bs) =
+    -- pprTrace "sink" (ppr lbl) $
+    blockJoin first final_middle final_last : sink sunk' bs
+    where
+      lbl = entryLabel b
+      (first, middle, last) = blockSplit b
+
+      succs = successors last
+
+      -- Annotate the middle nodes with the registers live *after*
+      -- the node.  This will help us decide whether we can inline
+      -- an assignment in the current node or not.
+      live = Set.unions (map getLive succs)
+      live_middle = gen_kill dflags last live
+      ann_middles = annotate dflags live_middle (blockToList middle)
+
+      -- Now sink and inline in this block
+      (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk)
+      fold_last = constantFoldNode dflags last
+      (final_last, assigs') = tryToInline dflags live fold_last assigs
+
+      -- We cannot sink into join points (successors with more than
+      -- one predecessor), so identify the join points and the set
+      -- of registers live in them.
+      (joins, nonjoins) = partition (`mapMember` join_pts) succs
+      live_in_joins = Set.unions (map getLive joins)
+
+      -- We do not want to sink an assignment into multiple branches,
+      -- so identify the set of registers live in multiple successors.
+      -- This is made more complicated because when we sink an assignment
+      -- into one branch, this might change the set of registers that are
+      -- now live in multiple branches.
+      init_live_sets = map getLive nonjoins
+      live_in_multi live_sets r =
+         case filter (Set.member r) live_sets of
+           (_one:_two:_) -> True
+           _ -> False
+
+      -- Now, drop any assignments that we will not sink any further.
+      (dropped_last, assigs'') = dropAssignments dflags drop_if init_live_sets assigs'
+
+      drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')
+          where
+            should_drop =  conflicts dflags a final_last
+                        || not (isTrivial dflags rhs) && live_in_multi live_sets r
+                        || r `Set.member` live_in_joins
+
+            live_sets' | should_drop = live_sets
+                       | otherwise   = map upd live_sets
+
+            upd set | r `Set.member` set = set `Set.union` live_rhs
+                    | otherwise          = set
+
+            live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs
+
+      final_middle = foldl' blockSnoc middle' dropped_last
+
+      sunk' = mapUnion sunk $
+                 mapFromList [ (l, filterAssignments dflags (getLive l) assigs'')
+                             | l <- succs ]
+
+{- TODO: enable this later, when we have some good tests in place to
+   measure the effect and tune it.
+
+-- small: an expression we don't mind duplicating
+isSmall :: CmmExpr -> Bool
+isSmall (CmmReg (CmmLocal _)) = True  --
+isSmall (CmmLit _) = True
+isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y
+isSmall (CmmRegOff (CmmLocal _) _) = True
+isSmall _ = False
+-}
+
+--
+-- We allow duplication of trivial expressions: registers (both local and
+-- global) and literals.
+--
+isTrivial :: DynFlags -> CmmExpr -> Bool
+isTrivial _ (CmmReg (CmmLocal _)) = True
+isTrivial dflags (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?]
+  if isARM (platformArch (targetPlatform dflags))
+  then True -- CodeGen.Platform.ARM does not have globalRegMaybe
+  else isJust (globalRegMaybe (targetPlatform dflags) r)
+  -- GlobalRegs that are loads from BaseReg are not trivial
+isTrivial _ (CmmLit _) = True
+isTrivial _ _          = False
+
+--
+-- annotate each node with the set of registers live *after* the node
+--
+annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)]
+annotate dflags live nodes = snd $ foldr ann (live,[]) nodes
+  where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes)
+
+--
+-- Find the blocks that have multiple successors (join points)
+--
+findJoinPoints :: [CmmBlock] -> LabelMap Int
+findJoinPoints blocks = mapFilter (>1) succ_counts
+ where
+  all_succs = concatMap successors blocks
+
+  succ_counts :: LabelMap Int
+  succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs
+
+--
+-- filter the list of assignments to remove any assignments that
+-- are not live in a continuation.
+--
+filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments
+filterAssignments dflags live assigs = reverse (go assigs [])
+  where go []             kept = kept
+        go (a@(r,_,_):as) kept | needed    = go as (a:kept)
+                               | otherwise = go as kept
+           where
+              needed = r `Set.member` live
+                       || any (conflicts dflags a) (map toNode kept)
+                       --  Note that we must keep assignments that are
+                       -- referred to by other assignments we have
+                       -- already kept.
+
+-- -----------------------------------------------------------------------------
+-- Walk through the nodes of a block, sinking and inlining assignments
+-- as we go.
+--
+-- On input we pass in a:
+--    * list of nodes in the block
+--    * a list of assignments that appeared *before* this block and
+--      that are being sunk.
+--
+-- On output we get:
+--    * a new block
+--    * a list of assignments that will be placed *after* that block.
+--
+
+walk :: DynFlags
+     -> [(LocalRegSet, CmmNode O O)]    -- nodes of the block, annotated with
+                                        -- the set of registers live *after*
+                                        -- this node.
+
+     -> Assignments                     -- The current list of
+                                        -- assignments we are sinking.
+                                        -- Earlier assignments may refer
+                                        -- to later ones.
+
+     -> ( Block CmmNode O O             -- The new block
+        , Assignments                   -- Assignments to sink further
+        )
+
+walk dflags nodes assigs = go nodes emptyBlock assigs
+ where
+   go []               block as = (block, as)
+   go ((live,node):ns) block as
+    | shouldDiscard node live           = go ns block as
+       -- discard dead assignment
+    | Just a <- shouldSink dflags node2 = go ns block (a : as1)
+    | otherwise                         = go ns block' as'
+    where
+      node1 = constantFoldNode dflags node
+
+      (node2, as1) = tryToInline dflags live node1 as
+
+      (dropped, as') = dropAssignmentsSimple dflags
+                          (\a -> conflicts dflags a node2) as1
+
+      block' = foldl' blockSnoc block dropped `blockSnoc` node2
+
+
+--
+-- Heuristic to decide whether to pick up and sink an assignment
+-- Currently we pick up all assignments to local registers.  It might
+-- be profitable to sink assignments to global regs too, but the
+-- liveness analysis doesn't track those (yet) so we can't.
+--
+shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment
+shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e)
+  where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e
+shouldSink _ _other = Nothing
+
+--
+-- discard dead assignments.  This doesn't do as good a job as
+-- removeDeadAssignments, because it would need multiple passes
+-- to get all the dead code, but it catches the common case of
+-- superfluous reloads from the stack that the stack allocator
+-- leaves behind.
+--
+-- Also we catch "r = r" here.  You might think it would fall
+-- out of inlining, but the inliner will see that r is live
+-- after the instruction and choose not to inline r in the rhs.
+--
+shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool
+shouldDiscard node live
+   = case node of
+       CmmAssign r (CmmReg r') | r == r' -> True
+       CmmAssign (CmmLocal r) _ -> not (r `Set.member` live)
+       _otherwise -> False
+
+
+toNode :: Assignment -> CmmNode O O
+toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs
+
+dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments
+                      -> ([CmmNode O O], Assignments)
+dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) ()
+
+dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments
+                -> ([CmmNode O O], Assignments)
+dropAssignments dflags should_drop state assigs
+ = (dropped, reverse kept)
+ where
+   (dropped,kept) = go state assigs [] []
+
+   go _ []             dropped kept = (dropped, kept)
+   go state (assig : rest) dropped kept
+      | conflict  = go state' rest (toNode assig : dropped) kept
+      | otherwise = go state' rest dropped (assig:kept)
+      where
+        (dropit, state') = should_drop assig state
+        conflict = dropit || any (conflicts dflags assig) dropped
+
+
+-- -----------------------------------------------------------------------------
+-- Try to inline assignments into a node.
+-- This also does constant folding for primpops, since
+-- inlining opens up opportunities for doing so.
+
+tryToInline
+   :: DynFlags
+   -> LocalRegSet               -- set of registers live after this
+                                -- node.  We cannot inline anything
+                                -- that is live after the node, unless
+                                -- it is small enough to duplicate.
+   -> CmmNode O x               -- The node to inline into
+   -> Assignments               -- Assignments to inline
+   -> (
+        CmmNode O x             -- New node
+      , Assignments             -- Remaining assignments
+      )
+
+tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
+ where
+  usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used
+  usages = foldLocalRegsUsed dflags addUsage emptyUFM node
+
+  go _usages node _skipped [] = (node, [])
+
+  go usages node skipped (a@(l,rhs,_) : rest)
+   | cannot_inline           = dont_inline
+   | occurs_none             = discard  -- Note [discard during inlining]
+   | occurs_once             = inline_and_discard
+   | isTrivial dflags rhs    = inline_and_keep
+   | otherwise               = dont_inline
+   where
+        inline_and_discard = go usages' inl_node skipped rest
+          where usages' = foldLocalRegsUsed dflags addUsage usages rhs
+
+        discard = go usages node skipped rest
+
+        dont_inline        = keep node  -- don't inline the assignment, keep it
+        inline_and_keep    = keep inl_node -- inline the assignment, keep it
+
+        keep node' = (final_node, a : rest')
+          where (final_node, rest') = go usages' node' (insertLRegSet l skipped) rest
+                usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2)
+                                            usages rhs
+                -- we must not inline anything that is mentioned in the RHS
+                -- of a binding that we have already skipped, so we set the
+                -- usages of the regs on the RHS to 2.
+
+        cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments]
+                        || l `elemLRegSet` skipped
+                        || not (okToInline dflags rhs node)
+
+        l_usages = lookupUFM usages l
+        l_live   = l `elemRegSet` live
+
+        occurs_once = not l_live && l_usages == Just 1
+        occurs_none = not l_live && l_usages == Nothing
+
+        inl_node = improveConditional (mapExpDeep inl_exp node)
+
+        inl_exp :: CmmExpr -> CmmExpr
+        -- inl_exp is where the inlining actually takes place!
+        inl_exp (CmmReg    (CmmLocal l'))     | l == l' = rhs
+        inl_exp (CmmRegOff (CmmLocal l') off) | l == l'
+                    = cmmOffset dflags rhs off
+                    -- re-constant fold after inlining
+        inl_exp (CmmMachOp op args) = cmmMachOpFold dflags op args
+        inl_exp other = other
+
+
+{- Note [improveConditional]
+
+cmmMachOpFold tries to simplify conditionals to turn things like
+  (a == b) != 1
+into
+  (a != b)
+but there's one case it can't handle: when the comparison is over
+floating-point values, we can't invert it, because floating-point
+comparisons aren't invertible (because of NaNs).
+
+But we *can* optimise this conditional by swapping the true and false
+branches. Given
+  CmmCondBranch ((a >## b) != 1) t f
+we can turn it into
+  CmmCondBranch (a >## b) f t
+
+So here we catch conditionals that weren't optimised by cmmMachOpFold,
+and apply above transformation to eliminate the comparison against 1.
+
+It's tempting to just turn every != into == and then let cmmMachOpFold
+do its thing, but that risks changing a nice fall-through conditional
+into one that requires two jumps. (see swapcond_last in
+CmmContFlowOpt), so instead we carefully look for just the cases where
+we can eliminate a comparison.
+-}
+improveConditional :: CmmNode O x -> CmmNode O x
+improveConditional
+  (CmmCondBranch (CmmMachOp mop [x, CmmLit (CmmInt 1 _)]) t f l)
+  | neLike mop, isComparisonExpr x
+  = CmmCondBranch x f t (fmap not l)
+  where
+    neLike (MO_Ne _) = True
+    neLike (MO_U_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1
+    neLike (MO_S_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1
+    neLike _ = False
+improveConditional other = other
+
+-- Note [dependent assignments]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- If our assignment list looks like
+--
+--    [ y = e,  x = ... y ... ]
+--
+-- We cannot inline x.  Remember this list is really in reverse order,
+-- so it means  x = ... y ...; y = e
+--
+-- Hence if we inline x, the outer assignment to y will capture the
+-- reference in x's right hand side.
+--
+-- In this case we should rename the y in x's right-hand side,
+-- i.e. change the list to [ y = e, x = ... y1 ..., y1 = y ]
+-- Now we can go ahead and inline x.
+--
+-- For now we do nothing, because this would require putting
+-- everything inside UniqSM.
+--
+-- One more variant of this (#7366):
+--
+--   [ y = e, y = z ]
+--
+-- If we don't want to inline y = e, because y is used many times, we
+-- might still be tempted to inline y = z (because we always inline
+-- trivial rhs's).  But of course we can't, because y is equal to e,
+-- not z.
+
+-- Note [discard during inlining]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Opportunities to discard assignments sometimes appear after we've
+-- done some inlining.  Here's an example:
+--
+--      x = R1;
+--      y = P64[x + 7];
+--      z = P64[x + 15];
+--      /* z is dead */
+--      R1 = y & (-8);
+--
+-- The x assignment is trivial, so we inline it in the RHS of y, and
+-- keep both x and y.  z gets dropped because it is dead, then we
+-- inline y, and we have a dead assignment to x.  If we don't notice
+-- that x is dead in tryToInline, we end up retaining it.
+
+addUsage :: UniqFM Int -> LocalReg -> UniqFM Int
+addUsage m r = addToUFM_C (+) m r 1
+
+regsUsedIn :: LRegSet -> CmmExpr -> Bool
+regsUsedIn ls _ | nullLRegSet ls = False
+regsUsedIn ls e = wrapRecExpf f e False
+  where f (CmmReg (CmmLocal l))      _ | l `elemLRegSet` ls = True
+        f (CmmRegOff (CmmLocal l) _) _ | l `elemLRegSet` ls = True
+        f _ z = z
+
+-- we don't inline into CmmUnsafeForeignCall if the expression refers
+-- to global registers.  This is a HACK to avoid global registers
+-- clashing with C argument-passing registers, really the back-end
+-- ought to be able to handle it properly, but currently neither PprC
+-- nor the NCG can do it.  See Note [Register parameter passing]
+-- See also StgCmmForeign:load_args_into_temps.
+okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
+okToInline dflags expr node@(CmmUnsafeForeignCall{}) =
+    not (globalRegistersConflict dflags expr node)
+okToInline _ _ _ = True
+
+-- -----------------------------------------------------------------------------
+
+-- | @conflicts (r,e) node@ is @False@ if and only if the assignment
+-- @r = e@ can be safely commuted past statement @node@.
+conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool
+conflicts dflags (r, rhs, addr) node
+
+  -- (1) node defines registers used by rhs of assignment. This catches
+  -- assignments and all three kinds of calls. See Note [Sinking and calls]
+  | globalRegistersConflict dflags rhs node                       = True
+  | localRegistersConflict  dflags rhs node                       = True
+
+  -- (2) node uses register defined by assignment
+  | foldRegsUsed dflags (\b r' -> r == r' || b) False node        = True
+
+  -- (3) a store to an address conflicts with a read of the same memory
+  | CmmStore addr' e <- node
+  , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True
+
+  -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively
+  | HeapMem    <- addr, CmmAssign (CmmGlobal Hp) _ <- node        = True
+  | StackMem   <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True
+  | SpMem{}    <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True
+
+  -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap]
+  | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem      = True
+
+  -- (6) native calls clobber any memory
+  | CmmCall{} <- node, memConflicts addr AnyMem                   = True
+
+  -- (7) otherwise, no conflict
+  | otherwise = False
+
+-- Returns True if node defines any global registers that are used in the
+-- Cmm expression
+globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
+globalRegistersConflict dflags expr node =
+    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmGlobal r) expr)
+                 False node
+
+-- Returns True if node defines any local registers that are used in the
+-- Cmm expression
+localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
+localRegistersConflict dflags expr node =
+    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmLocal  r) expr)
+                 False node
+
+-- Note [Sinking and calls]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall)
+-- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after
+-- stack layout (see Note [Sinking after stack layout]) which leads to two
+-- invariants related to calls:
+--
+--   a) during stack layout phase all safe foreign calls are turned into
+--      unsafe foreign calls (see Note [Lower safe foreign calls]). This
+--      means that we will never encounter CmmForeignCall node when running
+--      sinking after stack layout
+--
+--   b) stack layout saves all variables live across a call on the stack
+--      just before making a call (remember we are not sinking assignments to
+--      stack):
+--
+--       L1:
+--          x = R1
+--          P64[Sp - 16] = L2
+--          P64[Sp - 8]  = x
+--          Sp = Sp - 16
+--          call f() returns L2
+--       L2:
+--
+--      We will attempt to sink { x = R1 } but we will detect conflict with
+--      { P64[Sp - 8]  = x } and hence we will drop { x = R1 } without even
+--      checking whether it conflicts with { call f() }. In this way we will
+--      never need to check any assignment conflicts with CmmCall. Remember
+--      that we still need to check for potential memory conflicts.
+--
+-- So the result is that we only need to worry about CmmUnsafeForeignCall nodes
+-- when checking conflicts (see Note [Unsafe foreign calls clobber caller-save registers]).
+-- This assumption holds only when we do sinking after stack layout. If we run
+-- it before stack layout we need to check for possible conflicts with all three
+-- kinds of calls. Our `conflicts` function does that by using a generic
+-- foldRegsDefd and foldRegsUsed functions defined in DefinerOfRegs and
+-- UserOfRegs typeclasses.
+--
+
+-- An abstraction of memory read or written.
+data AbsMem
+  = NoMem            -- no memory accessed
+  | AnyMem           -- arbitrary memory
+  | HeapMem          -- definitely heap memory
+  | StackMem         -- definitely stack memory
+  | SpMem            -- <size>[Sp+n]
+       {-# UNPACK #-} !Int
+       {-# UNPACK #-} !Int
+
+-- Having SpMem is important because it lets us float loads from Sp
+-- past stores to Sp as long as they don't overlap, and this helps to
+-- unravel some long sequences of
+--    x1 = [Sp + 8]
+--    x2 = [Sp + 16]
+--    ...
+--    [Sp + 8]  = xi
+--    [Sp + 16] = xj
+--
+-- Note that SpMem is invalidated if Sp is changed, but the definition
+-- of 'conflicts' above handles that.
+
+-- ToDo: this won't currently fix the following commonly occurring code:
+--    x1 = [R1 + 8]
+--    x2 = [R1 + 16]
+--    ..
+--    [Hp - 8] = x1
+--    [Hp - 16] = x2
+--    ..
+
+-- because [R1 + 8] and [Hp - 8] are both HeapMem.  We know that
+-- assignments to [Hp + n] do not conflict with any other heap memory,
+-- but this is tricky to nail down.  What if we had
+--
+--   x = Hp + n
+--   [x] = ...
+--
+--  the store to [x] should be "new heap", not "old heap".
+--  Furthermore, you could imagine that if we started inlining
+--  functions in Cmm then there might well be reads of heap memory
+--  that was written in the same basic block.  To take advantage of
+--  non-aliasing of heap memory we will have to be more clever.
+
+-- Note [Foreign calls clobber heap]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- It is tempting to say that foreign calls clobber only
+-- non-heap/stack memory, but unfortunately we break this invariant in
+-- the RTS.  For example, in stg_catch_retry_frame we call
+-- stmCommitNestedTransaction() which modifies the contents of the
+-- TRec it is passed (this actually caused incorrect code to be
+-- generated).
+--
+-- Since the invariant is true for the majority of foreign calls,
+-- perhaps we ought to have a special annotation for calls that can
+-- modify heap/stack memory.  For now we just use the conservative
+-- definition here.
+--
+-- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and
+-- therefore we should never float any memory operations across one of
+-- these calls.
+
+
+bothMems :: AbsMem -> AbsMem -> AbsMem
+bothMems NoMem    x         = x
+bothMems x        NoMem     = x
+bothMems HeapMem  HeapMem   = HeapMem
+bothMems StackMem StackMem     = StackMem
+bothMems (SpMem o1 w1) (SpMem o2 w2)
+  | o1 == o2  = SpMem o1 (max w1 w2)
+  | otherwise = StackMem
+bothMems SpMem{}  StackMem  = StackMem
+bothMems StackMem SpMem{}   = StackMem
+bothMems _         _        = AnyMem
+
+memConflicts :: AbsMem -> AbsMem -> Bool
+memConflicts NoMem      _          = False
+memConflicts _          NoMem      = False
+memConflicts HeapMem    StackMem   = False
+memConflicts StackMem   HeapMem    = False
+memConflicts SpMem{}    HeapMem    = False
+memConflicts HeapMem    SpMem{}    = False
+memConflicts (SpMem o1 w1) (SpMem o2 w2)
+  | o1 < o2   = o1 + w1 > o2
+  | otherwise = o2 + w2 > o1
+memConflicts _         _         = True
+
+exprMem :: DynFlags -> CmmExpr -> AbsMem
+exprMem dflags (CmmLoad addr w)  = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr)
+exprMem dflags (CmmMachOp _ es)  = foldr bothMems NoMem (map (exprMem dflags) es)
+exprMem _      _                 = NoMem
+
+loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem
+loadAddr dflags e w =
+  case e of
+   CmmReg r       -> regAddr dflags r 0 w
+   CmmRegOff r i  -> regAddr dflags r i w
+   _other | regUsedIn dflags spReg e -> StackMem
+          | otherwise -> AnyMem
+
+regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem
+regAddr _      (CmmGlobal Sp) i w = SpMem i (widthInBytes w)
+regAddr _      (CmmGlobal Hp) _ _ = HeapMem
+regAddr _      (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps
+regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself
+regAddr _      _ _ _ = AnyMem
+
+{-
+Note [Inline GlobalRegs?]
+
+Should we freely inline GlobalRegs?
+
+Actually it doesn't make a huge amount of difference either way, so we
+*do* currently treat GlobalRegs as "trivial" and inline them
+everywhere, but for what it's worth, here is what I discovered when I
+(SimonM) looked into this:
+
+Common sense says we should not inline GlobalRegs, because when we
+have
+
+  x = R1
+
+the register allocator will coalesce this assignment, generating no
+code, and simply record the fact that x is bound to $rbx (or
+whatever).  Furthermore, if we were to sink this assignment, then the
+range of code over which R1 is live increases, and the range of code
+over which x is live decreases.  All things being equal, it is better
+for x to be live than R1, because R1 is a fixed register whereas x can
+live in any register.  So we should neither sink nor inline 'x = R1'.
+
+However, not inlining GlobalRegs can have surprising
+consequences. e.g. (cgrun020)
+
+  c3EN:
+      _s3DB::P64 = R1;
+      _c3ES::P64 = _s3DB::P64 & 7;
+      if (_c3ES::P64 >= 2) goto c3EU; else goto c3EV;
+  c3EU:
+      _s3DD::P64 = P64[_s3DB::P64 + 6];
+      _s3DE::P64 = P64[_s3DB::P64 + 14];
+      I64[Sp - 8] = c3F0;
+      R1 = _s3DE::P64;
+      P64[Sp] = _s3DD::P64;
+
+inlining the GlobalReg gives:
+
+  c3EN:
+      if (R1 & 7 >= 2) goto c3EU; else goto c3EV;
+  c3EU:
+      I64[Sp - 8] = c3F0;
+      _s3DD::P64 = P64[R1 + 6];
+      R1 = P64[R1 + 14];
+      P64[Sp] = _s3DD::P64;
+
+but if we don't inline the GlobalReg, instead we get:
+
+      _s3DB::P64 = R1;
+      if (_s3DB::P64 & 7 >= 2) goto c3EU; else goto c3EV;
+  c3EU:
+      I64[Sp - 8] = c3F0;
+      R1 = P64[_s3DB::P64 + 14];
+      P64[Sp] = P64[_s3DB::P64 + 6];
+
+This looks better - we managed to inline _s3DD - but in fact it
+generates an extra reg-reg move:
+
+.Lc3EU:
+        movq $c3F0_info,-8(%rbp)
+        movq %rbx,%rax
+        movq 14(%rbx),%rbx
+        movq 6(%rax),%rax
+        movq %rax,(%rbp)
+
+because _s3DB is now live across the R1 assignment, we lost the
+benefit of coalescing.
+
+Who is at fault here?  Perhaps if we knew that _s3DB was an alias for
+R1, then we would not sink a reference to _s3DB past the R1
+assignment.  Or perhaps we *should* do that - we might gain by sinking
+it, despite losing the coalescing opportunity.
+
+Sometimes not inlining global registers wins by virtue of the rule
+about not inlining into arguments of a foreign call, e.g. (T7163) this
+is what happens when we inlined F1:
+
+      _s3L2::F32 = F1;
+      _c3O3::F32 = %MO_F_Mul_W32(F1, 10.0 :: W32);
+      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(_c3O3::F32);
+
+but if we don't inline F1:
+
+      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(%MO_F_Mul_W32(_s3L2::F32,
+                                                                                            10.0 :: W32));
+-}
diff --git a/compiler/cmm/CmmSwitch.hs b/compiler/cmm/CmmSwitch.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmSwitch.hs
@@ -0,0 +1,500 @@
+{-# LANGUAGE GADTs #-}
+module CmmSwitch (
+     SwitchTargets,
+     mkSwitchTargets,
+     switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned,
+     mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough,
+     switchTargetsToList, eqSwitchTargetWith,
+
+     SwitchPlan(..),
+     targetSupportsSwitch,
+     createSwitchPlan,
+  ) where
+
+import GhcPrelude
+
+import Outputable
+import DynFlags
+import Hoopl.Label (Label)
+
+import Data.Maybe
+import Data.List (groupBy)
+import Data.Function (on)
+import qualified Data.Map as M
+
+-- Note [Cmm Switches, the general plan]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Compiling a high-level switch statement, as it comes out of a STG case
+-- expression, for example, allows for a surprising amount of design decisions.
+-- Therefore, we cleanly separated this from the Stg → Cmm transformation, as
+-- well as from the actual code generation.
+--
+-- The overall plan is:
+--  * The Stg → Cmm transformation creates a single `SwitchTargets` in
+--    emitSwitch and emitCmmLitSwitch in StgCmmUtils.hs.
+--    At this stage, they are unsuitable for code generation.
+--  * A dedicated Cmm transformation (CmmImplementSwitchPlans) replaces these
+--    switch statements with code that is suitable for code generation, i.e.
+--    a nice balanced tree of decisions with dense jump tables in the leafs.
+--    The actual planning of this tree is performed in pure code in createSwitchPlan
+--    in this module. See Note [createSwitchPlan].
+--  * The actual code generation will not do any further processing and
+--    implement each CmmSwitch with a jump tables.
+--
+-- When compiling to LLVM or C, CmmImplementSwitchPlans leaves the switch
+-- statements alone, as we can turn a SwitchTargets value into a nice
+-- switch-statement in LLVM resp. C, and leave the rest to the compiler.
+--
+-- See Note [CmmSwitch vs. CmmImplementSwitchPlans] why the two module are
+-- separated.
+
+-----------------------------------------------------------------------------
+-- Note [Magic Constants in CmmSwitch]
+--
+-- There are a lot of heuristics here that depend on magic values where it is
+-- hard to determine the "best" value (for whatever that means). These are the
+-- magic values:
+
+-- | Number of consecutive default values allowed in a jump table. If there are
+-- more of them, the jump tables are split.
+--
+-- Currently 7, as it costs 7 words of additional code when a jump table is
+-- split (at least on x64, determined experimentally).
+maxJumpTableHole :: Integer
+maxJumpTableHole = 7
+
+-- | Minimum size of a jump table. If the number is smaller, the switch is
+-- implemented using conditionals.
+-- Currently 5, because an if-then-else tree of 4 values is nice and compact.
+minJumpTableSize :: Int
+minJumpTableSize = 5
+
+-- | Minimum non-zero offset for a jump table. See Note [Jump Table Offset].
+minJumpTableOffset :: Integer
+minJumpTableOffset = 2
+
+
+-----------------------------------------------------------------------------
+-- Switch Targets
+
+-- Note [SwitchTargets]:
+-- ~~~~~~~~~~~~~~~~~~~~~
+--
+-- The branches of a switch are stored in a SwitchTargets, which consists of an
+-- (optional) default jump target, and a map from values to jump targets.
+--
+-- If the default jump target is absent, the behaviour of the switch outside the
+-- values of the map is undefined.
+--
+-- We use an Integer for the keys the map so that it can be used in switches on
+-- unsigned as well as signed integers.
+--
+-- The map may be empty (we prune out-of-range branches here, so it could be us
+-- emptying it).
+--
+-- Before code generation, the table needs to be brought into a form where all
+-- entries are non-negative, so that it can be compiled into a jump table.
+-- See switchTargetsToTable.
+
+
+-- | A value of type SwitchTargets contains the alternatives for a 'CmmSwitch'
+-- value, and knows whether the value is signed, the possible range, an
+-- optional default value and a map from values to jump labels.
+data SwitchTargets =
+    SwitchTargets
+        Bool                       -- Signed values
+        (Integer, Integer)         -- Range
+        (Maybe Label)              -- Default value
+        (M.Map Integer Label)      -- The branches
+    deriving (Show, Eq)
+
+-- | The smart constructor mkSwitchTargets normalises the map a bit:
+--  * No entries outside the range
+--  * No entries equal to the default
+--  * No default if all elements have explicit values
+mkSwitchTargets :: Bool -> (Integer, Integer) -> Maybe Label -> M.Map Integer Label -> SwitchTargets
+mkSwitchTargets signed range@(lo,hi) mbdef ids
+    = SwitchTargets signed range mbdef' ids'
+  where
+    ids' = dropDefault $ restrict ids
+    mbdef' | defaultNeeded = mbdef
+           | otherwise     = Nothing
+
+    -- Drop entries outside the range, if there is a range
+    restrict = restrictMap (lo,hi)
+
+    -- Drop entries that equal the default, if there is a default
+    dropDefault | Just l <- mbdef = M.filter (/= l)
+                | otherwise       = id
+
+    -- Check if the default is still needed
+    defaultNeeded = fromIntegral (M.size ids') /= hi-lo+1
+
+
+-- | Changes all labels mentioned in the SwitchTargets value
+mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets
+mapSwitchTargets f (SwitchTargets signed range mbdef branches)
+    = SwitchTargets signed range (fmap f mbdef) (fmap f branches)
+
+-- | Returns the list of non-default branches of the SwitchTargets value
+switchTargetsCases :: SwitchTargets -> [(Integer, Label)]
+switchTargetsCases (SwitchTargets _ _ _ branches) = M.toList branches
+
+-- | Return the default label of the SwitchTargets value
+switchTargetsDefault :: SwitchTargets -> Maybe Label
+switchTargetsDefault (SwitchTargets _ _ mbdef _) = mbdef
+
+-- | Return the range of the SwitchTargets value
+switchTargetsRange :: SwitchTargets -> (Integer, Integer)
+switchTargetsRange (SwitchTargets _ range _ _) = range
+
+-- | Return whether this is used for a signed value
+switchTargetsSigned :: SwitchTargets -> Bool
+switchTargetsSigned (SwitchTargets signed _ _ _) = signed
+
+-- | switchTargetsToTable creates a dense jump table, usable for code generation.
+--
+-- Also returns an offset to add to the value; the list is 0-based on the
+-- result of that addition.
+--
+-- The conversion from Integer to Int is a bit of a wart, as the actual
+-- scrutinee might be an unsigned word, but it just works, due to wrap-around
+-- arithmetic (as verified by the CmmSwitchTest test case).
+switchTargetsToTable :: SwitchTargets -> (Int, [Maybe Label])
+switchTargetsToTable (SwitchTargets _ (lo,hi) mbdef branches)
+    = (fromIntegral (-start), [ labelFor i | i <- [start..hi] ])
+  where
+    labelFor i = case M.lookup i branches of Just l -> Just l
+                                             Nothing -> mbdef
+    start | lo >= 0 && lo < minJumpTableOffset  = 0  -- See Note [Jump Table Offset]
+          | otherwise                           = lo
+
+-- Note [Jump Table Offset]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Usually, the code for a jump table starting at x will first subtract x from
+-- the value, to avoid a large amount of empty entries. But if x is very small,
+-- the extra entries are no worse than the subtraction in terms of code size, and
+-- not having to do the subtraction is quicker.
+--
+-- I.e. instead of
+--     _u20N:
+--             leaq -1(%r14),%rax
+--             jmp *_n20R(,%rax,8)
+--     _n20R:
+--             .quad   _c20p
+--             .quad   _c20q
+-- do
+--     _u20N:
+--             jmp *_n20Q(,%r14,8)
+--
+--     _n20Q:
+--             .quad   0
+--             .quad   _c20p
+--             .quad   _c20q
+--             .quad   _c20r
+
+-- | The list of all labels occuring in the SwitchTargets value.
+switchTargetsToList :: SwitchTargets -> [Label]
+switchTargetsToList (SwitchTargets _ _ mbdef branches)
+    = maybeToList mbdef ++ M.elems branches
+
+-- | Groups cases with equal targets, suitable for pretty-printing to a
+-- c-like switch statement with fall-through semantics.
+switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label)
+switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef)
+  where
+    groups = map (\xs -> (map fst xs, snd (head xs))) $
+             groupBy ((==) `on` snd) $
+             M.toList branches
+
+-- | Custom equality helper, needed for "CmmCommonBlockElim"
+eqSwitchTargetWith :: (Label -> Label -> Bool) -> SwitchTargets -> SwitchTargets -> Bool
+eqSwitchTargetWith eq (SwitchTargets signed1 range1 mbdef1 ids1) (SwitchTargets signed2 range2 mbdef2 ids2) =
+    signed1 == signed2 && range1 == range2 && goMB mbdef1 mbdef2 && goList (M.toList ids1) (M.toList ids2)
+  where
+    goMB Nothing Nothing = True
+    goMB (Just l1) (Just l2) = l1 `eq` l2
+    goMB _ _ = False
+    goList [] [] = True
+    goList ((i1,l1):ls1) ((i2,l2):ls2) = i1 == i2 && l1 `eq` l2 && goList ls1 ls2
+    goList _ _ = False
+
+-----------------------------------------------------------------------------
+-- Code generation for Switches
+
+
+-- | A SwitchPlan abstractly describes how a Switch statement ought to be
+-- implemented. See Note [createSwitchPlan]
+data SwitchPlan
+    = Unconditionally Label
+    | IfEqual Integer Label SwitchPlan
+    | IfLT Bool Integer SwitchPlan SwitchPlan
+    | JumpTable SwitchTargets
+  deriving Show
+--
+-- Note [createSwitchPlan]
+-- ~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- A SwitchPlan describes how a Switch statement is to be broken down into
+-- smaller pieces suitable for code generation.
+--
+-- createSwitchPlan creates such a switch plan, in these steps:
+--  1. It splits the switch statement at segments of non-default values that
+--     are too large. See splitAtHoles and Note [Magic Constants in CmmSwitch]
+--  2. Too small jump tables should be avoided, so we break up smaller pieces
+--     in breakTooSmall.
+--  3. We fill in the segments between those pieces with a jump to the default
+--     label (if there is one), returning a SeparatedList in mkFlatSwitchPlan
+--  4. We find and replace two less-than branches by a single equal-to-test in
+--     findSingleValues
+--  5. The thus collected pieces are assembled to a balanced binary tree.
+
+{-
+  Note [Two alts + default]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Discussion and a bit more info at #14644
+
+When dealing with a switch of the form:
+switch(e) {
+  case 1: goto l1;
+  case 3000: goto l2;
+  default: goto ldef;
+}
+
+If we treat it as a sparse jump table we would generate:
+
+if (e > 3000) //Check if value is outside of the jump table.
+    goto ldef;
+else {
+    if (e < 3000) { //Compare to upper value
+        if(e != 1) //Compare to remaining value
+            goto ldef;
+          else
+            goto l2;
+    }
+    else
+        goto l1;
+}
+
+Instead we special case this to :
+
+if (e==1) goto l1;
+else if (e==3000) goto l2;
+else goto l3;
+
+This means we have:
+* Less comparisons for: 1,<3000
+* Unchanged for 3000
+* One more for >3000
+
+This improves code in a few ways:
+* One comparison less means smaller code which helps with cache.
+* It exchanges a taken jump for two jumps no taken in the >range case.
+  Jumps not taken are cheaper (See Agner guides) making this about as fast.
+* For all other cases the first range check is removed making it faster.
+
+The end result is that the change is not measurably slower for the case
+>3000 and faster for the other cases.
+
+This makes running this kind of match in an inner loop cheaper by 10-20%
+depending on the data.
+In nofib this improves wheel-sieve1 by 4-9% depending on problem
+size.
+
+We could also add a second conditional jump after the comparison to
+keep the range check like this:
+    cmp 3000, rArgument
+    jg <default>
+    je <branch 2>
+While this is fairly cheap it made no big difference for the >3000 case
+and slowed down all other cases making it not worthwhile.
+-}
+
+
+-- | Does the target support switch out of the box? Then leave this to the
+-- target!
+targetSupportsSwitch :: HscTarget -> Bool
+targetSupportsSwitch HscC = True
+targetSupportsSwitch HscLlvm = True
+targetSupportsSwitch _ = False
+
+-- | This function creates a SwitchPlan from a SwitchTargets value, breaking it
+-- down into smaller pieces suitable for code generation.
+createSwitchPlan :: SwitchTargets -> SwitchPlan
+-- Lets do the common case of a singleton map quicky and efficiently (#10677)
+createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m)
+    | [(x, l)] <- M.toList m
+    = IfEqual x l (Unconditionally defLabel)
+-- And another common case, matching "booleans"
+createSwitchPlan (SwitchTargets _signed (lo,hi) Nothing m)
+    | [(x1, l1), (_x2,l2)] <- M.toAscList m
+    --Checking If |range| = 2 is enough if we have two unique literals
+    , hi - lo == 1
+    = IfEqual x1 l1 (Unconditionally l2)
+-- See Note [Two alts + default]
+createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m)
+    | [(x1, l1), (x2,l2)] <- M.toAscList m
+    = IfEqual x1 l1 (IfEqual x2 l2 (Unconditionally defLabel))
+createSwitchPlan (SwitchTargets signed range mbdef m) =
+    -- pprTrace "createSwitchPlan" (text (show ids) $$ text (show (range,m)) $$ text (show pieces) $$ text (show flatPlan) $$ text (show plan)) $
+    plan
+  where
+    pieces = concatMap breakTooSmall $ splitAtHoles maxJumpTableHole m
+    flatPlan = findSingleValues $ mkFlatSwitchPlan signed mbdef range pieces
+    plan = buildTree signed $ flatPlan
+
+
+---
+--- Step 1: Splitting at large holes
+---
+splitAtHoles :: Integer -> M.Map Integer a -> [M.Map Integer a]
+splitAtHoles _        m | M.null m = []
+splitAtHoles holeSize m = map (\range -> restrictMap range m) nonHoles
+  where
+    holes = filter (\(l,h) -> h - l > holeSize) $ zip (M.keys m) (tail (M.keys m))
+    nonHoles = reassocTuples lo holes hi
+
+    (lo,_) = M.findMin m
+    (hi,_) = M.findMax m
+
+---
+--- Step 2: Avoid small jump tables
+---
+-- We do not want jump tables below a certain size. This breaks them up
+-- (into singleton maps, for now).
+breakTooSmall :: M.Map Integer a -> [M.Map Integer a]
+breakTooSmall m
+  | M.size m > minJumpTableSize = [m]
+  | otherwise                   = [M.singleton k v | (k,v) <- M.toList m]
+
+---
+---  Step 3: Fill in the blanks
+---
+
+-- | A FlatSwitchPlan is a list of SwitchPlans, with an integer inbetween every
+-- two entries, dividing the range.
+-- So if we have (abusing list syntax) [plan1,n,plan2], then we use plan1 if
+-- the expression is < n, and plan2 otherwise.
+
+type FlatSwitchPlan = SeparatedList Integer SwitchPlan
+
+mkFlatSwitchPlan :: Bool -> Maybe Label -> (Integer, Integer) -> [M.Map Integer Label] -> FlatSwitchPlan
+
+-- If we have no default (i.e. undefined where there is no entry), we can
+-- branch at the minimum of each map
+mkFlatSwitchPlan _ Nothing _ [] = pprPanic "mkFlatSwitchPlan with nothing left to do" empty
+mkFlatSwitchPlan signed  Nothing _ (m:ms)
+  = (mkLeafPlan signed Nothing m , [ (fst (M.findMin m'), mkLeafPlan signed Nothing m') | m' <- ms ])
+
+-- If we have a default, we have to interleave segments that jump
+-- to the default between the maps
+mkFlatSwitchPlan signed (Just l) r ms = let ((_,p1):ps) = go r ms in (p1, ps)
+  where
+    go (lo,hi) []
+        | lo > hi = []
+        | otherwise = [(lo, Unconditionally l)]
+    go (lo,hi) (m:ms)
+        | lo < min
+        = (lo, Unconditionally l) : go (min,hi) (m:ms)
+        | lo == min
+        = (lo, mkLeafPlan signed (Just l) m) : go (max+1,hi) ms
+        | otherwise
+        = pprPanic "mkFlatSwitchPlan" (integer lo <+> integer min)
+      where
+        min = fst (M.findMin m)
+        max = fst (M.findMax m)
+
+
+mkLeafPlan :: Bool -> Maybe Label -> M.Map Integer Label -> SwitchPlan
+mkLeafPlan signed mbdef m
+    | [(_,l)] <- M.toList m -- singleton map
+    = Unconditionally l
+    | otherwise
+    = JumpTable $ mkSwitchTargets signed (min,max) mbdef m
+  where
+    min = fst (M.findMin m)
+    max = fst (M.findMax m)
+
+---
+---  Step 4: Reduce the number of branches using ==
+---
+
+-- A sequence of three unconditional jumps, with the outer two pointing to the
+-- same value and the bounds off by exactly one can be improved
+findSingleValues :: FlatSwitchPlan -> FlatSwitchPlan
+findSingleValues (Unconditionally l, (i, Unconditionally l2) : (i', Unconditionally l3) : xs)
+  | l == l3 && i + 1 == i'
+  = findSingleValues (IfEqual i l2 (Unconditionally l), xs)
+findSingleValues (p, (i,p'):xs)
+  = (p,i) `consSL` findSingleValues (p', xs)
+findSingleValues (p, [])
+  = (p, [])
+
+---
+---  Step 5: Actually build the tree
+---
+
+-- Build a balanced tree from a separated list
+buildTree :: Bool -> FlatSwitchPlan -> SwitchPlan
+buildTree _ (p,[]) = p
+buildTree signed sl = IfLT signed m (buildTree signed sl1) (buildTree signed sl2)
+  where
+    (sl1, m, sl2) = divideSL sl
+
+
+
+--
+-- Utility data type: Non-empty lists with extra markers in between each
+-- element:
+--
+
+type SeparatedList b a = (a, [(b,a)])
+
+consSL :: (a, b) -> SeparatedList b a -> SeparatedList b a
+consSL (a, b) (a', xs) = (a, (b,a'):xs)
+
+divideSL :: SeparatedList b a -> (SeparatedList b a, b, SeparatedList b a)
+divideSL (_,[]) = error "divideSL: Singleton SeparatedList"
+divideSL (p,xs) = ((p, xs1), m, (p', xs2))
+  where
+    (xs1, (m,p'):xs2) = splitAt (length xs `div` 2) xs
+
+--
+-- Other Utilities
+--
+
+restrictMap :: (Integer,Integer) -> M.Map Integer b -> M.Map Integer b
+restrictMap (lo,hi) m = mid
+  where (_,   mid_hi) = M.split (lo-1) m
+        (mid, _) =      M.split (hi+1) mid_hi
+
+-- for example: reassocTuples a [(b,c),(d,e)] f == [(a,b),(c,d),(e,f)]
+reassocTuples :: a -> [(a,a)] -> a -> [(a,a)]
+reassocTuples initial [] last
+    = [(initial,last)]
+reassocTuples initial ((a,b):tuples) last
+    = (initial,a) : reassocTuples b tuples last
+
+-- Note [CmmSwitch vs. CmmImplementSwitchPlans]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- I (Joachim) separated the two somewhat closely related modules
+--
+--  - CmmSwitch, which provides the CmmSwitchTargets type and contains the strategy
+--    for implementing a Cmm switch (createSwitchPlan), and
+--  - CmmImplementSwitchPlans, which contains the actuall Cmm graph modification,
+--
+-- for these reasons:
+--
+--  * CmmSwitch is very low in the dependency tree, i.e. does not depend on any
+--    GHC specific modules at all (with the exception of Output and Hoople
+--    (Literal)). CmmImplementSwitchPlans is the Cmm transformation and hence very
+--    high in the dependency tree.
+--  * CmmSwitch provides the CmmSwitchTargets data type, which is abstract, but
+--    used in CmmNodes.
+--  * Because CmmSwitch is low in the dependency tree, the separation allows
+--    for more parallelism when building GHC.
+--  * The interaction between the modules is very explicit and easy to
+--    understand, due to the small and simple interface.
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/CmmUtils.hs
@@ -0,0 +1,591 @@
+{-# LANGUAGE GADTs, RankNTypes #-}
+
+-----------------------------------------------------------------------------
+--
+-- Cmm utilities.
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module CmmUtils(
+        -- CmmType
+        primRepCmmType, slotCmmType, slotForeignHint,
+        typeCmmType, typeForeignHint, primRepForeignHint,
+
+        -- CmmLit
+        zeroCLit, mkIntCLit,
+        mkWordCLit, packHalfWordsCLit,
+        mkByteStringCLit,
+        mkDataLits, mkRODataLits,
+        mkStgWordCLit,
+
+        -- CmmExpr
+        mkIntExpr, zeroExpr,
+        mkLblExpr,
+        cmmRegOff,  cmmOffset,  cmmLabelOff,  cmmOffsetLit,  cmmOffsetExpr,
+        cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,
+        cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,
+        cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,
+        cmmNegate,
+        cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
+        cmmSLtWord,
+        cmmNeWord, cmmEqWord,
+        cmmOrWord, cmmAndWord,
+        cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,
+        cmmToWord,
+
+        isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,
+
+        baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
+        currentTSOExpr, currentNurseryExpr, cccsExpr,
+
+        -- Statics
+        blankWord,
+
+        -- Tagging
+        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,
+        cmmConstrTag1,
+
+        -- Overlap and usage
+        regsOverlap, regUsedIn,
+
+        -- Liveness and bitmaps
+        mkLiveness,
+
+        -- * Operations that probably don't belong here
+        modifyGraph,
+
+        ofBlockMap, toBlockMap,
+        ofBlockList, toBlockList, bodyToBlockList,
+        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
+        foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1,
+
+        -- * Ticks
+        blockTicks
+  ) where
+
+import GhcPrelude
+
+import TyCon    ( PrimRep(..), PrimElemRep(..) )
+import RepType  ( UnaryType, SlotTy (..), typePrimRep1 )
+
+import SMRep
+import Cmm
+import BlockId
+import CLabel
+import Outputable
+import DynFlags
+import CodeGen.Platform
+
+import Data.Word
+import Data.Bits
+import Hoopl.Graph
+import Hoopl.Label
+import Hoopl.Block
+import Hoopl.Collections
+
+---------------------------------------------------
+--
+--      CmmTypes
+--
+---------------------------------------------------
+
+primRepCmmType :: DynFlags -> PrimRep -> CmmType
+primRepCmmType _      VoidRep          = panic "primRepCmmType:VoidRep"
+primRepCmmType dflags LiftedRep        = gcWord dflags
+primRepCmmType dflags UnliftedRep      = gcWord dflags
+primRepCmmType dflags IntRep           = bWord dflags
+primRepCmmType dflags WordRep          = bWord dflags
+primRepCmmType _      Int8Rep          = b8
+primRepCmmType _      Word8Rep         = b8
+primRepCmmType _      Int16Rep         = b16
+primRepCmmType _      Word16Rep        = b16
+primRepCmmType _      Int64Rep         = b64
+primRepCmmType _      Word64Rep        = b64
+primRepCmmType dflags AddrRep          = bWord dflags
+primRepCmmType _      FloatRep         = f32
+primRepCmmType _      DoubleRep        = f64
+primRepCmmType _      (VecRep len rep) = vec len (primElemRepCmmType rep)
+
+slotCmmType :: DynFlags -> SlotTy -> CmmType
+slotCmmType dflags PtrSlot    = gcWord dflags
+slotCmmType dflags WordSlot   = bWord dflags
+slotCmmType _      Word64Slot = b64
+slotCmmType _      FloatSlot  = f32
+slotCmmType _      DoubleSlot = f64
+
+primElemRepCmmType :: PrimElemRep -> CmmType
+primElemRepCmmType Int8ElemRep   = b8
+primElemRepCmmType Int16ElemRep  = b16
+primElemRepCmmType Int32ElemRep  = b32
+primElemRepCmmType Int64ElemRep  = b64
+primElemRepCmmType Word8ElemRep  = b8
+primElemRepCmmType Word16ElemRep = b16
+primElemRepCmmType Word32ElemRep = b32
+primElemRepCmmType Word64ElemRep = b64
+primElemRepCmmType FloatElemRep  = f32
+primElemRepCmmType DoubleElemRep = f64
+
+typeCmmType :: DynFlags -> UnaryType -> CmmType
+typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)
+
+primRepForeignHint :: PrimRep -> ForeignHint
+primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"
+primRepForeignHint LiftedRep    = AddrHint
+primRepForeignHint UnliftedRep  = AddrHint
+primRepForeignHint IntRep       = SignedHint
+primRepForeignHint Int8Rep      = SignedHint
+primRepForeignHint Int16Rep     = SignedHint
+primRepForeignHint Int64Rep     = SignedHint
+primRepForeignHint WordRep      = NoHint
+primRepForeignHint Word8Rep     = NoHint
+primRepForeignHint Word16Rep    = NoHint
+primRepForeignHint Word64Rep    = NoHint
+primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg
+primRepForeignHint FloatRep     = NoHint
+primRepForeignHint DoubleRep    = NoHint
+primRepForeignHint (VecRep {})  = NoHint
+
+slotForeignHint :: SlotTy -> ForeignHint
+slotForeignHint PtrSlot       = AddrHint
+slotForeignHint WordSlot      = NoHint
+slotForeignHint Word64Slot    = NoHint
+slotForeignHint FloatSlot     = NoHint
+slotForeignHint DoubleSlot    = NoHint
+
+typeForeignHint :: UnaryType -> ForeignHint
+typeForeignHint = primRepForeignHint . typePrimRep1
+
+---------------------------------------------------
+--
+--      CmmLit
+--
+---------------------------------------------------
+
+-- XXX: should really be Integer, since Int doesn't necessarily cover
+-- the full range of target Ints.
+mkIntCLit :: DynFlags -> Int -> CmmLit
+mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)
+
+mkIntExpr :: DynFlags -> Int -> CmmExpr
+mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i
+
+zeroCLit :: DynFlags -> CmmLit
+zeroCLit dflags = CmmInt 0 (wordWidth dflags)
+
+zeroExpr :: DynFlags -> CmmExpr
+zeroExpr dflags = CmmLit (zeroCLit dflags)
+
+mkWordCLit :: DynFlags -> Integer -> CmmLit
+mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)
+
+mkByteStringCLit
+  :: CLabel -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
+-- We have to make a top-level decl for the string,
+-- and return a literal pointing to it
+mkByteStringCLit lbl bytes
+  = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes])
+  where
+    -- This can not happen for String literals (as there \NUL is replaced by
+    -- C0 80). However, it can happen with Addr# literals.
+    sec = if 0 `elem` bytes then ReadOnlyData else CString
+
+mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
+-- Build a data-segment data block
+mkDataLits section lbl lits
+  = CmmData section (Statics lbl $ map CmmStaticLit lits)
+
+mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
+-- Build a read-only data block
+mkRODataLits lbl lits
+  = mkDataLits section lbl lits
+  where
+    section | any needsRelocation lits = Section RelocatableReadOnlyData lbl
+            | otherwise                = Section ReadOnlyData lbl
+    needsRelocation (CmmLabel _)      = True
+    needsRelocation (CmmLabelOff _ _) = True
+    needsRelocation _                 = False
+
+mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
+mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
+
+packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
+-- Make a single word literal in which the lower_half_word is
+-- at the lower address, and the upper_half_word is at the
+-- higher address
+-- ToDo: consider using half-word lits instead
+--       but be careful: that's vulnerable when reversed
+packHalfWordsCLit dflags lower_half_word upper_half_word
+   = if wORDS_BIGENDIAN dflags
+     then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u)
+     else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags))
+    where l = fromStgHalfWord lower_half_word
+          u = fromStgHalfWord upper_half_word
+
+---------------------------------------------------
+--
+--      CmmExpr
+--
+---------------------------------------------------
+
+mkLblExpr :: CLabel -> CmmExpr
+mkLblExpr lbl = CmmLit (CmmLabel lbl)
+
+cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+-- assumes base and offset have the same CmmType
+cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n)
+cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off]
+
+cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr
+cmmOffset _ e                 0        = e
+cmmOffset _ (CmmReg reg)      byte_off = cmmRegOff reg byte_off
+cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)
+cmmOffset _ (CmmLit lit)      byte_off = CmmLit (cmmOffsetLit lit byte_off)
+cmmOffset _ (CmmStackSlot area off) byte_off
+  = CmmStackSlot area (off - byte_off)
+  -- note stack area offsets increase towards lower addresses
+cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
+  = CmmMachOp (MO_Add rep)
+              [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
+cmmOffset dflags expr byte_off
+  = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]
+  where
+    width = cmmExprWidth dflags expr
+
+-- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.
+cmmRegOff :: CmmReg -> Int -> CmmExpr
+cmmRegOff reg 0        = CmmReg reg
+cmmRegOff reg byte_off = CmmRegOff reg byte_off
+
+cmmOffsetLit :: CmmLit -> Int -> CmmLit
+cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff l byte_off
+cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)
+cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off
+                                        = CmmLabelDiffOff l1 l2 (m+byte_off) w
+cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep
+cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
+
+cmmLabelOff :: CLabel -> Int -> CmmLit
+-- Smart constructor for CmmLabelOff
+cmmLabelOff lbl 0        = CmmLabel lbl
+cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off
+
+-- | Useful for creating an index into an array, with a statically known offset.
+-- The type is the element type; used for making the multiplier
+cmmIndex :: DynFlags
+         -> Width       -- Width w
+         -> CmmExpr     -- Address of vector of items of width w
+         -> Int         -- Which element of the vector (0 based)
+         -> CmmExpr     -- Address of i'th element
+cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)
+
+-- | Useful for creating an index into an array, with an unknown offset.
+cmmIndexExpr :: DynFlags
+             -> Width           -- Width w
+             -> CmmExpr         -- Address of vector of items of width w
+             -> CmmExpr         -- Which element of the vector (0 based)
+             -> CmmExpr         -- Address of i'th element
+cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)
+cmmIndexExpr dflags width base idx =
+  cmmOffsetExpr dflags base byte_off
+  where
+    idx_w = cmmExprWidth dflags idx
+    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]
+
+cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr
+cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty
+
+-- The "B" variants take byte offsets
+cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
+cmmRegOffB = cmmRegOff
+
+cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr
+cmmOffsetB = cmmOffset
+
+cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOffsetExprB = cmmOffsetExpr
+
+cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
+cmmLabelOffB = cmmLabelOff
+
+cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
+cmmOffsetLitB = cmmOffsetLit
+
+-----------------------
+-- The "W" variants take word offsets
+
+cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+-- The second arg is a *word* offset; need to change it to bytes
+cmmOffsetExprW dflags  e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)
+cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off
+
+cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr
+cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)
+
+cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr
+cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)
+
+cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit
+cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)
+
+cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit
+cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)
+
+cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr
+cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty
+
+-----------------------
+cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
+  cmmSLtWord,
+  cmmNeWord, cmmEqWord,
+  cmmOrWord, cmmAndWord,
+  cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord
+  :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOrWord dflags  e1 e2 = CmmMachOp (mo_wordOr dflags)  [e1, e2]
+cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2]
+cmmNeWord dflags  e1 e2 = CmmMachOp (mo_wordNe dflags)  [e1, e2]
+cmmEqWord dflags  e1 e2 = CmmMachOp (mo_wordEq dflags)  [e1, e2]
+cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]
+cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]
+cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]
+cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]
+cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]
+cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]
+cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]
+cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2]
+cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2]
+
+cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
+cmmNegate _      (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
+cmmNegate dflags e                       = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]
+
+blankWord :: DynFlags -> CmmStatic
+blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
+
+cmmToWord :: DynFlags -> CmmExpr -> CmmExpr
+cmmToWord dflags e
+  | w == word  = e
+  | otherwise  = CmmMachOp (MO_UU_Conv w word) [e]
+  where
+    w = cmmExprWidth dflags e
+    word = wordWidth dflags
+
+---------------------------------------------------
+--
+--      CmmExpr predicates
+--
+---------------------------------------------------
+
+isTrivialCmmExpr :: CmmExpr -> Bool
+isTrivialCmmExpr (CmmLoad _ _)      = False
+isTrivialCmmExpr (CmmMachOp _ _)    = False
+isTrivialCmmExpr (CmmLit _)         = True
+isTrivialCmmExpr (CmmReg _)         = True
+isTrivialCmmExpr (CmmRegOff _ _)    = True
+isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"
+
+hasNoGlobalRegs :: CmmExpr -> Bool
+hasNoGlobalRegs (CmmLoad e _)              = hasNoGlobalRegs e
+hasNoGlobalRegs (CmmMachOp _ es)           = all hasNoGlobalRegs es
+hasNoGlobalRegs (CmmLit _)                 = True
+hasNoGlobalRegs (CmmReg (CmmLocal _))      = True
+hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
+hasNoGlobalRegs _ = False
+
+isLit :: CmmExpr -> Bool
+isLit (CmmLit _) = True
+isLit _          = False
+
+isComparisonExpr :: CmmExpr -> Bool
+isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
+isComparisonExpr _                  = False
+
+---------------------------------------------------
+--
+--      Tagging
+--
+---------------------------------------------------
+
+-- Tag bits mask
+cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
+cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
+cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
+
+-- Used to untag a possibly tagged pointer
+-- A static label need not be untagged
+cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
+cmmUntag _ e@(CmmLit (CmmLabel _)) = e
+-- Default case
+cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)
+
+-- Test if a closure pointer is untagged
+cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
+
+-- Get constructor tag, but one based.
+cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
+
+
+-----------------------------------------------------------------------------
+-- Overlap and usage
+
+-- | Returns True if the two STG registers overlap on the specified
+-- platform, in the sense that writing to one will clobber the
+-- other. This includes the case that the two registers are the same
+-- STG register. See Note [Overlapping global registers] for details.
+regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool
+regsOverlap dflags (CmmGlobal g) (CmmGlobal g')
+  | Just real  <- globalRegMaybe (targetPlatform dflags) g,
+    Just real' <- globalRegMaybe (targetPlatform dflags) g',
+    real == real'
+    = True
+regsOverlap _ reg reg' = reg == reg'
+
+-- | Returns True if the STG register is used by the expression, in
+-- the sense that a store to the register might affect the value of
+-- the expression.
+--
+-- We must check for overlapping registers and not just equal
+-- registers here, otherwise CmmSink may incorrectly reorder
+-- assignments that conflict due to overlap. See Trac #10521 and Note
+-- [Overlapping global registers].
+regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool
+regUsedIn dflags = regUsedIn_ where
+  _   `regUsedIn_` CmmLit _         = False
+  reg `regUsedIn_` CmmLoad e  _     = reg `regUsedIn_` e
+  reg `regUsedIn_` CmmReg reg'      = regsOverlap dflags reg reg'
+  reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg'
+  reg `regUsedIn_` CmmMachOp _ es   = any (reg `regUsedIn_`) es
+  _   `regUsedIn_` CmmStackSlot _ _ = False
+
+--------------------------------------------
+--
+--        mkLiveness
+--
+---------------------------------------------
+
+mkLiveness :: DynFlags -> [LocalReg] -> Liveness
+mkLiveness _      [] = []
+mkLiveness dflags (reg:regs)
+  = bits ++ mkLiveness dflags regs
+  where
+    sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags - 1)
+            `quot` wORD_SIZE dflags
+            -- number of words, rounded up
+    bits = replicate sizeW is_non_ptr -- True <=> Non Ptr
+
+    is_non_ptr = not $ isGcPtrType (localRegType reg)
+
+
+-- ============================================== -
+-- ============================================== -
+-- ============================================== -
+
+---------------------------------------------------
+--
+--      Manipulating CmmGraphs
+--
+---------------------------------------------------
+
+modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
+modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}
+
+toBlockMap :: CmmGraph -> LabelMap CmmBlock
+toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
+
+ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
+ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
+
+toBlockList :: CmmGraph -> [CmmBlock]
+toBlockList g = mapElems $ toBlockMap g
+
+-- | like 'toBlockList', but the entry block always comes first
+toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
+toBlockListEntryFirst g
+  | mapNull m  = []
+  | otherwise  = entry_block : others
+  where
+    m = toBlockMap g
+    entry_id = g_entry g
+    Just entry_block = mapLookup entry_id m
+    others = filter ((/= entry_id) . entryLabel) (mapElems m)
+
+-- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks
+-- so that the false case of a conditional jumps to the next block in the output
+-- list of blocks. This matches the way OldCmm blocks were output since in
+-- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches
+-- have both true and false successors. Block ordering can make a big difference
+-- in performance in the LLVM backend. Note that we rely crucially on the order
+-- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode
+-- defined in cmm/CmmNode.hs. -GBM
+toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]
+toBlockListEntryFirstFalseFallthrough g
+  | mapNull m  = []
+  | otherwise  = dfs setEmpty [entry_block]
+  where
+    m = toBlockMap g
+    entry_id = g_entry g
+    Just entry_block = mapLookup entry_id m
+
+    dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]
+    dfs _ [] = []
+    dfs visited (block:bs)
+      | id `setMember` visited = dfs visited bs
+      | otherwise              = block : dfs (setInsert id visited) bs'
+      where id = entryLabel block
+            bs' = foldr add_id bs (successors block)
+            add_id id bs = case mapLookup id m of
+                              Just b  -> b : bs
+                              Nothing -> bs
+
+ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
+ofBlockList entry blocks = CmmGraph { g_entry = entry
+                                    , g_graph = GMany NothingO body NothingO }
+  where body = foldr addBlock emptyBody blocks
+
+bodyToBlockList :: Body CmmNode -> [CmmBlock]
+bodyToBlockList body = mapElems body
+
+mapGraphNodes :: ( CmmNode C O -> CmmNode C O
+                 , CmmNode O O -> CmmNode O O
+                 , CmmNode O C -> CmmNode O C)
+              -> CmmGraph -> CmmGraph
+mapGraphNodes funs@(mf,_,_) g =
+  ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $
+  mapMap (mapBlock3' funs) $ toBlockMap g
+
+mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph
+mapGraphNodes1 f = modifyGraph (mapGraph f)
+
+
+foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
+foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g
+
+revPostorder :: CmmGraph -> [CmmBlock]
+revPostorder g = {-# SCC "revPostorder" #-}
+    revPostorderFrom (toBlockMap g) (g_entry g)
+
+-------------------------------------------------
+-- Tick utilities
+
+-- | Extract all tick annotations from the given block
+blockTicks :: Block CmmNode C C -> [CmmTickish]
+blockTicks b = reverse $ foldBlockNodesF goStmt b []
+  where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]
+        goStmt  (CmmTick t) ts = t:ts
+        goStmt  _other      ts = ts
+
+
+-- -----------------------------------------------------------------------------
+-- Access to common global registers
+
+baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,
+  spLimExpr, hpLimExpr, cccsExpr :: CmmExpr
+baseExpr = CmmReg baseReg
+spExpr = CmmReg spReg
+spLimExpr = CmmReg spLimReg
+hpExpr = CmmReg hpReg
+hpLimExpr = CmmReg hpLimReg
+currentTSOExpr = CmmReg currentTSOReg
+currentNurseryExpr = CmmReg currentNurseryReg
+cccsExpr = CmmReg cccsReg
diff --git a/compiler/cmm/Debug.hs b/compiler/cmm/Debug.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Debug.hs
@@ -0,0 +1,550 @@
+{-# LANGUAGE GADTs #-}
+
+-----------------------------------------------------------------------------
+--
+-- Debugging data
+--
+-- Association of debug data on the Cmm level, with methods to encode it in
+-- event log format for later inclusion in profiling event logs.
+--
+-----------------------------------------------------------------------------
+
+module Debug (
+
+  DebugBlock(..), dblIsEntry,
+  cmmDebugGen,
+  cmmDebugLabels,
+  cmmDebugLink,
+  debugToMap,
+
+  -- * Unwinding information
+  UnwindTable, UnwindPoint(..),
+  UnwindExpr(..), toUnwindExpr
+  ) where
+
+import GhcPrelude
+
+import BlockId
+import CLabel
+import Cmm
+import CmmUtils
+import CoreSyn
+import FastString      ( nilFS, mkFastString )
+import Module
+import Outputable
+import PprCore         ()
+import PprCmmExpr      ( pprExpr )
+import SrcLoc
+import Util            ( seqList )
+
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
+
+import Data.Maybe
+import Data.List     ( minimumBy, nubBy )
+import Data.Ord      ( comparing )
+import qualified Data.Map as Map
+import Data.Either   ( partitionEithers )
+
+-- | Debug information about a block of code. Ticks scope over nested
+-- blocks.
+data DebugBlock =
+  DebugBlock
+  { dblProcedure  :: !Label        -- ^ Entry label of containing proc
+  , dblLabel      :: !Label        -- ^ Hoopl label
+  , dblCLabel     :: !CLabel       -- ^ Output label
+  , dblHasInfoTbl :: !Bool         -- ^ Has an info table?
+  , dblParent     :: !(Maybe DebugBlock)
+    -- ^ The parent of this proc. See Note [Splitting DebugBlocks]
+  , dblTicks      :: ![CmmTickish] -- ^ Ticks defined in this block
+  , dblSourceTick
+            :: !(Maybe CmmTickish) -- ^ Best source tick covering block
+  , dblPosition   :: !(Maybe Int)  -- ^ Output position relative to
+                                   -- other blocks. @Nothing@ means
+                                   -- the block was optimized out
+  , dblUnwind     :: [UnwindPoint]
+  , dblBlocks     :: ![DebugBlock] -- ^ Nested blocks
+  }
+
+-- | Is this the entry block?
+dblIsEntry :: DebugBlock -> Bool
+dblIsEntry blk = dblProcedure blk == dblLabel blk
+
+instance Outputable DebugBlock where
+  ppr blk = (if dblProcedure blk == dblLabel blk
+             then text "proc "
+             else if dblHasInfoTbl blk
+                  then text "pp-blk "
+                  else text "blk ") <>
+            ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+>
+            (maybe empty ppr (dblSourceTick blk)) <+>
+            (maybe (text "removed") ((text "pos " <>) . ppr)
+                   (dblPosition blk)) <+>
+            (ppr (dblUnwind blk)) <+>
+            (if null (dblBlocks blk) then empty else ppr (dblBlocks blk))
+
+-- | Intermediate data structure holding debug-relevant context information
+-- about a block.
+type BlockContext = (CmmBlock, RawCmmDecl)
+
+-- | Extract debug data from a group of procedures. We will prefer
+-- source notes that come from the given module (presumably the module
+-- that we are currently compiling).
+cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]
+cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
+  where
+      blockCtxs :: Map.Map CmmTickScope [BlockContext]
+      blockCtxs = blockContexts decls
+
+      -- Analyse tick scope structure: Each one is either a top-level
+      -- tick scope, or the child of another.
+      (topScopes, childScopes)
+        = partitionEithers $ map (\a -> findP a a) $ Map.keys blockCtxs
+      findP tsc GlobalScope = Left tsc -- top scope
+      findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)
+                    | otherwise                   = findP tsc scp'
+        where -- Note that we only following the left parent of
+              -- combined scopes. This loses us ticks, which we will
+              -- recover by copying ticks below.
+              scp' | SubScope _ scp' <- scp      = scp'
+                   | CombinedScope scp' _ <- scp = scp'
+                   | otherwise                   = panic "findP impossible"
+
+      scopeMap = foldr (uncurry insertMulti) Map.empty childScopes
+
+      -- This allows us to recover ticks that we lost by flattening
+      -- the graph. Basically, if the parent is A but the child is
+      -- CBA, we know that there is no BA, because it would have taken
+      -- priority - but there might be a B scope, with ticks that
+      -- would not be associated with our child anymore. Note however
+      -- that there might be other childs (DB), which we have to
+      -- filter out.
+      --
+      -- We expect this to be called rarely, which is why we are not
+      -- trying too hard to be efficient here. In many cases we won't
+      -- have to construct blockCtxsU in the first place.
+      ticksToCopy :: CmmTickScope -> [CmmTickish]
+      ticksToCopy (CombinedScope scp s) = go s
+        where go s | scp `isTickSubScope` s   = [] -- done
+                   | SubScope _ s' <- s       = ticks ++ go s'
+                   | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2
+                   | otherwise                = panic "ticksToCopy impossible"
+                where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs
+      ticksToCopy _ = []
+      bCtxsTicks = concatMap (blockTicks . fst)
+
+      -- Finding the "best" source tick is somewhat arbitrary -- we
+      -- select the first source span, while preferring source ticks
+      -- from the same source file.  Furthermore, dumps take priority
+      -- (if we generated one, we probably want debug information to
+      -- refer to it).
+      bestSrcTick = minimumBy (comparing rangeRating)
+      rangeRating (SourceNote span _)
+        | srcSpanFile span == thisFile = 1
+        | otherwise                    = 2 :: Int
+      rangeRating note                 = pprPanic "rangeRating" (ppr note)
+      thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc
+
+      -- Returns block tree for this scope as well as all nested
+      -- scopes. Note that if there are multiple blocks in the (exact)
+      -- same scope we elect one as the "branch" node and add the rest
+      -- as children.
+      blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock
+      blocksForScope cstick scope = mkBlock True (head bctxs)
+        where bctxs = fromJust $ Map.lookup scope blockCtxs
+              nested = fromMaybe [] $ Map.lookup scope scopeMap
+              childs = map (mkBlock False) (tail bctxs) ++
+                       map (blocksForScope stick) nested
+
+              mkBlock :: Bool -> BlockContext -> DebugBlock
+              mkBlock top (block, prc)
+                = DebugBlock { dblProcedure    = g_entry graph
+                             , dblLabel        = label
+                             , dblCLabel       = case info of
+                                 Just (Statics infoLbl _)   -> infoLbl
+                                 Nothing
+                                   | g_entry graph == label -> entryLbl
+                                   | otherwise              -> blockLbl label
+                             , dblHasInfoTbl   = isJust info
+                             , dblParent       = Nothing
+                             , dblTicks        = ticks
+                             , dblPosition     = Nothing -- see cmmDebugLink
+                             , dblSourceTick   = stick
+                             , dblBlocks       = blocks
+                             , dblUnwind       = []
+                             }
+                where (CmmProc infos entryLbl _ graph) = prc
+                      label = entryLabel block
+                      info = mapLookup label infos
+                      blocks | top       = seqList childs childs
+                             | otherwise = []
+
+              -- A source tick scopes over all nested blocks. However
+              -- their source ticks might take priority.
+              isSourceTick SourceNote {} = True
+              isSourceTick _             = False
+              -- Collect ticks from all blocks inside the tick scope.
+              -- We attempt to filter out duplicates while we're at it.
+              ticks = nubBy (flip tickishContains) $
+                      bCtxsTicks bctxs ++ ticksToCopy scope
+              stick = case filter isSourceTick ticks of
+                []     -> cstick
+                sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)
+
+-- | Build a map of blocks sorted by their tick scopes
+--
+-- This involves a pre-order traversal, as we want blocks in rough
+-- control flow order (so ticks have a chance to be sorted in the
+-- right order).
+blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]
+blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls
+  where walkProc :: RawCmmDecl
+                 -> Map.Map CmmTickScope [BlockContext]
+                 -> Map.Map CmmTickScope [BlockContext]
+        walkProc CmmData{}                 m = m
+        walkProc prc@(CmmProc _ _ _ graph) m
+          | mapNull blocks = m
+          | otherwise      = snd $ walkBlock prc entry (emptyLbls, m)
+          where blocks = toBlockMap graph
+                entry  = [mapFind (g_entry graph) blocks]
+                emptyLbls = setEmpty :: LabelSet
+
+        walkBlock :: RawCmmDecl -> [Block CmmNode C C]
+                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])
+                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])
+        walkBlock _   []             c            = c
+        walkBlock prc (block:blocks) (visited, m)
+          | lbl `setMember` visited
+          = walkBlock prc blocks (visited, m)
+          | otherwise
+          = walkBlock prc blocks $
+            walkBlock prc succs
+              (lbl `setInsert` visited,
+               insertMulti scope (block, prc) m)
+          where CmmEntry lbl scope = firstNode block
+                (CmmProc _ _ _ graph) = prc
+                succs = map (flip mapFind (toBlockMap graph))
+                            (successors (lastNode block))
+        mapFind = mapFindWithDefault (error "contextTree: block not found!")
+
+insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a]
+insertMulti k v = Map.insertWith (const (v:)) k [v]
+
+cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
+cmmDebugLabels isMeta nats = seqList lbls lbls
+  where -- Find order in which procedures will be generated by the
+        -- back-end (that actually matters for DWARF generation).
+        --
+        -- Note that we might encounter blocks that are missing or only
+        -- consist of meta instructions -- we will declare them missing,
+        -- which will skip debug data generation without messing up the
+        -- block hierarchy.
+        lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats
+        getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs
+        getBlocks _other                         = []
+        allMeta (BasicBlock _ instrs) = all isMeta instrs
+
+-- | Sets position and unwind table fields in the debug block tree according to
+-- native generated code.
+cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]
+             -> [DebugBlock] -> [DebugBlock]
+cmmDebugLink labels unwindPts blocks = map link blocks
+  where blockPos :: LabelMap Int
+        blockPos = mapFromList $ flip zip [0..] labels
+        link block = block { dblPosition = mapLookup (dblLabel block) blockPos
+                           , dblBlocks   = map link (dblBlocks block)
+                           , dblUnwind   = fromMaybe mempty
+                                         $ mapLookup (dblLabel block) unwindPts
+                           }
+
+-- | Converts debug blocks into a label map for easier lookups
+debugToMap :: [DebugBlock] -> LabelMap DebugBlock
+debugToMap = mapUnions . map go
+   where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b)
+
+{-
+Note [What is this unwinding business?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Unwinding tables are a variety of debugging information used by debugging tools
+to reconstruct the execution history of a program at runtime. These tables
+consist of sets of "instructions", one set for every instruction in the program,
+which describe how to reconstruct the state of the machine at the point where
+the current procedure was called. For instance, consider the following annotated
+pseudo-code,
+
+  a_fun:
+    add rsp, 8            -- unwind: rsp = rsp - 8
+    mov rax, 1            -- unwind: rax = unknown
+    call another_block
+    sub rsp, 8            -- unwind: rsp = rsp
+
+We see that attached to each instruction there is an "unwind" annotation, which
+provides a relationship between each updated register and its value at the
+time of entry to a_fun. This is the sort of information that allows gdb to give
+you a stack backtrace given the execution state of your program. This
+unwinding information is captured in various ways by various debug information
+formats; in the case of DWARF (the only format supported by GHC) it is known as
+Call Frame Information (CFI) and can be found in the .debug.frames section of
+your object files.
+
+Currently we only bother to produce unwinding information for registers which
+are necessary to reconstruct flow-of-execution. On x86_64 this includes $rbp
+(which is the STG stack pointer) and $rsp (the C stack pointer).
+
+Let's consider how GHC would annotate a C-- program with unwinding information
+with a typical C-- procedure as would come from the STG-to-Cmm code generator,
+
+  entry()
+     { c2fe:
+           v :: P64 = R2;
+           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;
+       c2ff:
+           R2 = v :: P64;
+           R1 = test_closure;
+           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
+       c2fg:
+           I64[Sp - 8] = c2dD;
+           R1 = v :: P64;
+           Sp = Sp - 8;          // Sp updated here
+           if (R1 & 7 != 0) goto c2dD; else goto c2dE;
+       c2dE:
+           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;
+       c2dD:
+           w :: P64 = R1;
+           Hp = Hp + 48;
+           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;
+       ...
+  },
+
+Let's consider how this procedure will be decorated with unwind information
+(largely by CmmLayoutStack). Naturally, when we enter the procedure `entry` the
+value of Sp is no different from what it was at its call site. Therefore we will
+add an `unwind` statement saying this at the beginning of its unwind-annotated
+code,
+
+  entry()
+     { c2fe:
+           unwind Sp = Just Sp + 0;
+           v :: P64 = R2;
+           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;
+
+After c2fe we may pass to either c2ff or c2fg; let's first consider the
+former. In this case there is nothing in particular that we need to do other
+than reiterate what we already know about Sp,
+
+       c2ff:
+           unwind Sp = Just Sp + 0;
+           R2 = v :: P64;
+           R1 = test_closure;
+           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;
+
+In contrast, c2fg updates Sp midway through its body. To ensure that unwinding
+can happen correctly after this point we must include an unwind statement there,
+in addition to the usual beginning-of-block statement,
+
+       c2fg:
+           unwind Sp = Just Sp + 0;
+           I64[Sp - 8] = c2dD;
+           R1 = v :: P64;
+           Sp = Sp - 8;
+           unwind Sp = Just Sp + 8;
+           if (R1 & 7 != 0) goto c2dD; else goto c2dE;
+
+The remaining blocks are simple,
+
+       c2dE:
+           unwind Sp = Just Sp + 8;
+           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;
+       c2dD:
+           unwind Sp = Just Sp + 8;
+           w :: P64 = R1;
+           Hp = Hp + 48;
+           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;
+       ...
+  },
+
+
+The flow of unwinding information through the compiler is a bit convoluted:
+
+ * C-- begins life in StgCmm without any unwind information. This is because we
+   haven't actually done any register assignment or stack layout yet, so there
+   is no need for unwind information.
+
+ * CmmLayoutStack figures out how to layout each procedure's stack, and produces
+   appropriate unwinding nodes for each adjustment of the STG Sp register.
+
+ * The unwind nodes are carried through the sinking pass. Currently this is
+   guaranteed not to invalidate unwind information since it won't touch stores
+   to Sp, but this will need revisiting if CmmSink gets smarter in the future.
+
+ * Eventually we make it to the native code generator backend which can then
+   preserve the unwind nodes in its machine-specific instructions. In so doing
+   the backend can also modify or add unwinding information; this is necessary,
+   for instance, in the case of x86-64, where adjustment of $rsp may be
+   necessary during calls to native foreign code due to the native calling
+   convention.
+
+ * The NCG then retrieves the final unwinding table for each block from the
+   backend with extractUnwindPoints.
+
+ * This unwind information is converted to DebugBlocks by Debug.cmmDebugGen
+
+ * These DebugBlocks are then converted to, e.g., DWARF unwinding tables
+   (by the Dwarf module) and emitted in the final object.
+
+See also:
+  Note [Unwinding information in the NCG] in AsmCodeGen,
+  Note [Unwind pseudo-instruction in Cmm],
+  Note [Debugging DWARF unwinding info].
+
+
+Note [Debugging DWARF unwinding info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For debugging generated unwinding info I've found it most useful to dump the
+disassembled binary with objdump -D and dump the debug info with
+readelf --debug-dump=frames-interp.
+
+You should get something like this:
+
+  0000000000000010 <stg_catch_frame_info>:
+    10:   48 83 c5 18             add    $0x18,%rbp
+    14:   ff 65 00                jmpq   *0x0(%rbp)
+
+and:
+
+  Contents of the .debug_frame section:
+
+  00000000 0000000000000014 ffffffff CIE "" cf=1 df=-8 ra=16
+     LOC           CFA      rbp   rsp   ra
+  0000000000000000 rbp+0    v+0   s     c+0
+
+  00000018 0000000000000024 00000000 FDE cie=00000000 pc=000000000000000f..0000000000000017
+     LOC           CFA      rbp   rsp   ra
+  000000000000000f rbp+0    v+0   s     c+0
+  000000000000000f rbp+24   v+0   s     c+0
+
+To read it http://www.dwarfstd.org/doc/dwarf-2.0.0.pdf has a nice example in
+Appendix 5 (page 101 of the pdf) and more details in the relevant section.
+
+The key thing to keep in mind is that the value at LOC is the value from
+*before* the instruction at LOC executes. In other words it answers the
+question: if my $rip is at LOC, how do I get the relevant values given the
+values obtained through unwinding so far.
+
+If the readelf --debug-dump=frames-interp output looks wrong, it may also be
+useful to look at readelf --debug-dump=frames, which is closer to the
+information that GHC generated.
+
+It's also useful to dump the relevant Cmm with -ddump-cmm -ddump-opt-cmm
+-ddump-cmm-proc -ddump-cmm-verbose. Note [Unwind pseudo-instruction in Cmm]
+explains how to interpret it.
+
+Inside gdb there are a couple useful commands for inspecting frames.
+For example:
+
+  gdb> info frame <num>
+
+It shows the values of registers obtained through unwinding.
+
+Another useful thing to try when debugging the DWARF unwinding is to enable
+extra debugging output in GDB:
+
+  gdb> set debug frame 1
+
+This makes GDB produce a trace of its internal workings. Having gone this far,
+it's just a tiny step to run GDB in GDB. Make sure you install debugging
+symbols for gdb if you obtain it through a package manager.
+
+Keep in mind that the current release of GDB has an instruction pointer handling
+heuristic that works well for C-like languages, but doesn't always work for
+Haskell. See Note [Info Offset] in Dwarf.Types for more details.
+
+Note [Unwind pseudo-instruction in Cmm]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+One of the possible CmmNodes is a CmmUnwind pseudo-instruction. It doesn't
+generate any assembly, but controls what DWARF unwinding information gets
+generated.
+
+It's important to understand what ranges of code the unwind pseudo-instruction
+refers to.
+For a sequence of CmmNodes like:
+
+  A // starts at addr X and ends at addr Y-1
+  unwind Sp = Just Sp + 16;
+  B // starts at addr Y and ends at addr Z
+
+the unwind statement reflects the state after A has executed, but before B
+has executed. If you consult the Note [Debugging DWARF unwinding info], the
+LOC this information will end up in is Y.
+-}
+
+-- | A label associated with an 'UnwindTable'
+data UnwindPoint = UnwindPoint !CLabel !UnwindTable
+
+instance Outputable UnwindPoint where
+  ppr (UnwindPoint lbl uws) =
+      braces $ ppr lbl<>colon
+      <+> hsep (punctuate comma $ map pprUw $ Map.toList uws)
+    where
+      pprUw (g, expr) = ppr g <> char '=' <> ppr expr
+
+-- | Maps registers to expressions that yield their "old" values
+-- further up the stack. Most interesting for the stack pointer @Sp@,
+-- but might be useful to document saved registers, too. Note that a
+-- register's value will be 'Nothing' when the register's previous
+-- value cannot be reconstructed.
+type UnwindTable = Map.Map GlobalReg (Maybe UnwindExpr)
+
+-- | Expressions, used for unwind information
+data UnwindExpr = UwConst !Int                  -- ^ literal value
+                | UwReg !GlobalReg !Int         -- ^ register plus offset
+                | UwDeref UnwindExpr            -- ^ pointer dereferencing
+                | UwLabel CLabel
+                | UwPlus UnwindExpr UnwindExpr
+                | UwMinus UnwindExpr UnwindExpr
+                | UwTimes UnwindExpr UnwindExpr
+                deriving (Eq)
+
+instance Outputable UnwindExpr where
+  pprPrec _ (UwConst i)     = ppr i
+  pprPrec _ (UwReg g 0)     = ppr g
+  pprPrec p (UwReg g x)     = pprPrec p (UwPlus (UwReg g 0) (UwConst x))
+  pprPrec _ (UwDeref e)     = char '*' <> pprPrec 3 e
+  pprPrec _ (UwLabel l)     = pprPrec 3 l
+  pprPrec p (UwPlus e0 e1)  | p <= 0
+                            = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1
+  pprPrec p (UwMinus e0 e1) | p <= 0
+                            = pprPrec 1 e0 <> char '-' <> pprPrec 1 e1
+  pprPrec p (UwTimes e0 e1) | p <= 1
+                            = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1
+  pprPrec _ other           = parens (pprPrec 0 other)
+
+-- | Conversion of Cmm expressions to unwind expressions. We check for
+-- unsupported operator usages and simplify the expression as far as
+-- possible.
+toUnwindExpr :: CmmExpr -> UnwindExpr
+toUnwindExpr (CmmLit (CmmInt i _))       = UwConst (fromIntegral i)
+toUnwindExpr (CmmLit (CmmLabel l))       = UwLabel l
+toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i
+toUnwindExpr (CmmReg (CmmGlobal g))      = UwReg g 0
+toUnwindExpr (CmmLoad e _)               = UwDeref (toUnwindExpr e)
+toUnwindExpr e@(CmmMachOp op [e1, e2])   =
+  case (op, toUnwindExpr e1, toUnwindExpr e2) of
+    (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)
+    (MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y)
+    (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y)
+    (MO_Add{}, UwConst x, UwConst y) -> UwConst (x + y)
+    (MO_Sub{}, UwConst x, UwConst y) -> UwConst (x - y)
+    (MO_Mul{}, UwConst x, UwConst y) -> UwConst (x * y)
+    (MO_Add{}, u1,        u2       ) -> UwPlus u1 u2
+    (MO_Sub{}, u1,        u2       ) -> UwMinus u1 u2
+    (MO_Mul{}, u1,        u2       ) -> UwTimes u1 u2
+    _otherwise -> pprPanic "Unsupported operator in unwind expression!"
+                           (pprExpr e)
+toUnwindExpr e
+  = pprPanic "Unsupported unwind expression!" (ppr e)
diff --git a/compiler/cmm/Hoopl/Block.hs b/compiler/cmm/Hoopl/Block.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Hoopl/Block.hs
@@ -0,0 +1,328 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hoopl.Block
+    ( C
+    , O
+    , MaybeO(..)
+    , IndexedCO
+    , Block(..)
+    , blockAppend
+    , blockCons
+    , blockFromList
+    , blockJoin
+    , blockJoinHead
+    , blockJoinTail
+    , blockSnoc
+    , blockSplit
+    , blockSplitHead
+    , blockSplitTail
+    , blockToList
+    , emptyBlock
+    , firstNode
+    , foldBlockNodesB
+    , foldBlockNodesB3
+    , foldBlockNodesF
+    , isEmptyBlock
+    , lastNode
+    , mapBlock
+    , mapBlock'
+    , mapBlock3'
+    , replaceFirstNode
+    , replaceLastNode
+    ) where
+
+import GhcPrelude
+
+-- -----------------------------------------------------------------------------
+-- Shapes: Open and Closed
+
+-- | Used at the type level to indicate an "open" structure with
+-- a unique, unnamed control-flow edge flowing in or out.
+-- "Fallthrough" and concatenation are permitted at an open point.
+data O
+
+-- | Used at the type level to indicate a "closed" structure which
+-- supports control transfer only through the use of named
+-- labels---no "fallthrough" is permitted.  The number of control-flow
+-- edges is unconstrained.
+data C
+
+-- | Either type indexed by closed/open using type families
+type family IndexedCO ex a b :: *
+type instance IndexedCO C a _b = a
+type instance IndexedCO O _a b = b
+
+-- | Maybe type indexed by open/closed
+data MaybeO ex t where
+  JustO    :: t -> MaybeO O t
+  NothingO ::      MaybeO C t
+
+-- | Maybe type indexed by closed/open
+data MaybeC ex t where
+  JustC    :: t -> MaybeC C t
+  NothingC ::      MaybeC O t
+
+
+instance Functor (MaybeO ex) where
+  fmap _ NothingO = NothingO
+  fmap f (JustO a) = JustO (f a)
+
+instance Functor (MaybeC ex) where
+  fmap _ NothingC = NothingC
+  fmap f (JustC a) = JustC (f a)
+
+-- -----------------------------------------------------------------------------
+-- The Block type
+
+-- | A sequence of nodes.  May be any of four shapes (O/O, O/C, C/O, C/C).
+-- Open at the entry means single entry, mutatis mutandis for exit.
+-- A closed/closed block is a /basic/ block and can't be extended further.
+-- Clients should avoid manipulating blocks and should stick to either nodes
+-- or graphs.
+data Block n e x where
+  BlockCO  :: n C O -> Block n O O          -> Block n C O
+  BlockCC  :: n C O -> Block n O O -> n O C -> Block n C C
+  BlockOC  ::          Block n O O -> n O C -> Block n O C
+
+  BNil    :: Block n O O
+  BMiddle :: n O O                      -> Block n O O
+  BCat    :: Block n O O -> Block n O O -> Block n O O
+  BSnoc   :: Block n O O -> n O O       -> Block n O O
+  BCons   :: n O O       -> Block n O O -> Block n O O
+
+
+-- -----------------------------------------------------------------------------
+-- Simple operations on Blocks
+
+-- Predicates
+
+isEmptyBlock :: Block n e x -> Bool
+isEmptyBlock BNil       = True
+isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r
+isEmptyBlock _          = False
+
+
+-- Building
+
+emptyBlock :: Block n O O
+emptyBlock = BNil
+
+blockCons :: n O O -> Block n O x -> Block n O x
+blockCons n b = case b of
+  BlockOC b l  -> (BlockOC $! (n `blockCons` b)) l
+  BNil{}    -> BMiddle n
+  BMiddle{} -> n `BCons` b
+  BCat{}    -> n `BCons` b
+  BSnoc{}   -> n `BCons` b
+  BCons{}   -> n `BCons` b
+
+blockSnoc :: Block n e O -> n O O -> Block n e O
+blockSnoc b n = case b of
+  BlockCO f b -> BlockCO f $! (b `blockSnoc` n)
+  BNil{}      -> BMiddle n
+  BMiddle{}   -> b `BSnoc` n
+  BCat{}      -> b `BSnoc` n
+  BSnoc{}     -> b `BSnoc` n
+  BCons{}     -> b `BSnoc` n
+
+blockJoinHead :: n C O -> Block n O x -> Block n C x
+blockJoinHead f (BlockOC b l) = BlockCC f b l
+blockJoinHead f b = BlockCO f BNil `cat` b
+
+blockJoinTail :: Block n e O -> n O C -> Block n e C
+blockJoinTail (BlockCO f b) t = BlockCC f b t
+blockJoinTail b t = b `cat` BlockOC BNil t
+
+blockJoin :: n C O -> Block n O O -> n O C -> Block n C C
+blockJoin f b t = BlockCC f b t
+
+blockAppend :: Block n e O -> Block n O x -> Block n e x
+blockAppend = cat
+
+
+-- Taking apart
+
+firstNode :: Block n C x -> n C O
+firstNode (BlockCO n _)   = n
+firstNode (BlockCC n _ _) = n
+
+lastNode :: Block n x C -> n O C
+lastNode (BlockOC   _ n) = n
+lastNode (BlockCC _ _ n) = n
+
+blockSplitHead :: Block n C x -> (n C O, Block n O x)
+blockSplitHead (BlockCO n b)   = (n, b)
+blockSplitHead (BlockCC n b t) = (n, BlockOC b t)
+
+blockSplitTail :: Block n e C -> (Block n e O, n O C)
+blockSplitTail (BlockOC b n)   = (b, n)
+blockSplitTail (BlockCC f b t) = (BlockCO f b, t)
+
+-- | Split a closed block into its entry node, open middle block, and
+-- exit node.
+blockSplit :: Block n C C -> (n C O, Block n O O, n O C)
+blockSplit (BlockCC f b t) = (f, b, t)
+
+blockToList :: Block n O O -> [n O O]
+blockToList b = go b []
+   where go :: Block n O O -> [n O O] -> [n O O]
+         go BNil         r = r
+         go (BMiddle n)  r = n : r
+         go (BCat b1 b2) r = go b1 $! go b2 r
+         go (BSnoc b1 n) r = go b1 (n:r)
+         go (BCons n b1) r = n : go b1 r
+
+blockFromList :: [n O O] -> Block n O O
+blockFromList = foldr BCons BNil
+
+-- Modifying
+
+replaceFirstNode :: Block n C x -> n C O -> Block n C x
+replaceFirstNode (BlockCO _ b)   f = BlockCO f b
+replaceFirstNode (BlockCC _ b n) f = BlockCC f b n
+
+replaceLastNode :: Block n x C -> n O C -> Block n x C
+replaceLastNode (BlockOC   b _) n = BlockOC b n
+replaceLastNode (BlockCC l b _) n = BlockCC l b n
+
+-- -----------------------------------------------------------------------------
+-- General concatenation
+
+cat :: Block n e O -> Block n O x -> Block n e x
+cat x y = case x of
+  BNil -> y
+
+  BlockCO l b1 -> case y of
+                   BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n
+                   BNil         -> x
+                   BMiddle _    -> BlockCO l $! (b1 `cat` y)
+                   BCat{}       -> BlockCO l $! (b1 `cat` y)
+                   BSnoc{}      -> BlockCO l $! (b1 `cat` y)
+                   BCons{}      -> BlockCO l $! (b1 `cat` y)
+
+  BMiddle n -> case y of
+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+                   BNil          -> x
+                   BMiddle{}     -> BCons n y
+                   BCat{}        -> BCons n y
+                   BSnoc{}       -> BCons n y
+                   BCons{}       -> BCons n y
+
+  BCat{} -> case y of
+                   BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2
+                   BNil          -> x
+                   BMiddle n     -> BSnoc x n
+                   BCat{}        -> BCat x y
+                   BSnoc{}       -> BCat x y
+                   BCons{}       -> BCat x y
+
+  BSnoc{} -> case y of
+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+                   BNil          -> x
+                   BMiddle n     -> BSnoc x n
+                   BCat{}        -> BCat x y
+                   BSnoc{}       -> BCat x y
+                   BCons{}       -> BCat x y
+
+
+  BCons{} -> case y of
+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
+                   BNil          -> x
+                   BMiddle n     -> BSnoc x n
+                   BCat{}        -> BCat x y
+                   BSnoc{}       -> BCat x y
+                   BCons{}       -> BCat x y
+
+
+-- -----------------------------------------------------------------------------
+-- Mapping
+
+-- | map a function over the nodes of a 'Block'
+mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x
+mapBlock f (BlockCO n b  ) = BlockCO (f n) (mapBlock f b)
+mapBlock f (BlockOC   b n) = BlockOC       (mapBlock f b) (f n)
+mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m)
+mapBlock _  BNil           = BNil
+mapBlock f (BMiddle n)     = BMiddle (f n)
+mapBlock f (BCat b1 b2)    = BCat    (mapBlock f b1) (mapBlock f b2)
+mapBlock f (BSnoc b n)     = BSnoc   (mapBlock f b)  (f n)
+mapBlock f (BCons n b)     = BCons   (f n)  (mapBlock f b)
+
+-- | A strict 'mapBlock'
+mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x)
+mapBlock' f = mapBlock3' (f, f, f)
+
+-- | map over a block, with different functions to apply to first nodes,
+-- middle nodes and last nodes respectively.  The map is strict.
+--
+mapBlock3' :: forall n n' e x .
+             ( n C O -> n' C O
+             , n O O -> n' O O,
+               n O C -> n' O C)
+          -> Block n e x -> Block n' e x
+mapBlock3' (f, m, l) b = go b
+  where go :: forall e x . Block n e x -> Block n' e x
+        go (BlockOC b y)   = (BlockOC $! go b) $! l y
+        go (BlockCO x b)   = (BlockCO $! f x) $! (go b)
+        go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y)
+        go BNil            = BNil
+        go (BMiddle n)     = BMiddle $! m n
+        go (BCat x y)      = (BCat $! go x) $! (go y)
+        go (BSnoc x n)     = (BSnoc $! go x) $! (m n)
+        go (BCons n x)     = (BCons $! m n) $! (go x)
+
+-- -----------------------------------------------------------------------------
+-- Folding
+
+
+-- | Fold a function over every node in a block, forward or backward.
+-- The fold function must be polymorphic in the shape of the nodes.
+foldBlockNodesF3 :: forall n a b c .
+                   ( n C O       -> a -> b
+                   , n O O       -> b -> b
+                   , n O C       -> b -> c)
+                 -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)
+foldBlockNodesF  :: forall n a .
+                    (forall e x . n e x       -> a -> a)
+                 -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a)
+foldBlockNodesB3 :: forall n a b c .
+                   ( n C O       -> b -> c
+                   , n O O       -> b -> b
+                   , n O C       -> a -> b)
+                 -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b)
+foldBlockNodesB  :: forall n a .
+                    (forall e x . n e x       -> a -> a)
+                 -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a)
+
+foldBlockNodesF3 (ff, fm, fl) = block
+  where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b
+        block (BlockCO f b  )   = ff f `cat` block b
+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l
+        block (BlockOC   b l)   =            block b `cat` fl l
+        block BNil              = id
+        block (BMiddle node)    = fm node
+        block (b1 `BCat`    b2) = block b1 `cat` block b2
+        block (b1 `BSnoc` n)    = block b1 `cat` fm n
+        block (n `BCons` b2)    = fm n `cat` block b2
+        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
+        cat f f' = f' . f
+
+foldBlockNodesF f = foldBlockNodesF3 (f, f, f)
+
+foldBlockNodesB3 (ff, fm, fl) = block
+  where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b
+        block (BlockCO f b  )   = ff f `cat` block b
+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l
+        block (BlockOC   b l)   =            block b `cat` fl l
+        block BNil              = id
+        block (BMiddle node)    = fm node
+        block (b1 `BCat`    b2) = block b1 `cat` block b2
+        block (b1 `BSnoc` n)    = block b1 `cat` fm n
+        block (n `BCons` b2)    = fm n `cat` block b2
+        cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c
+        cat f f' = f . f'
+
+foldBlockNodesB f = foldBlockNodesB3 (f, f, f)
+
diff --git a/compiler/cmm/Hoopl/Collections.hs b/compiler/cmm/Hoopl/Collections.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Hoopl/Collections.hs
@@ -0,0 +1,177 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Hoopl.Collections
+    ( IsSet(..)
+    , setInsertList, setDeleteList, setUnions
+    , IsMap(..)
+    , mapInsertList, mapDeleteList, mapUnions
+    , UniqueMap, UniqueSet
+    ) where
+
+import GhcPrelude
+
+import qualified Data.IntMap.Strict as M
+import qualified Data.IntSet as S
+
+import Data.List (foldl1')
+
+class IsSet set where
+  type ElemOf set
+
+  setNull :: set -> Bool
+  setSize :: set -> Int
+  setMember :: ElemOf set -> set -> Bool
+
+  setEmpty :: set
+  setSingleton :: ElemOf set -> set
+  setInsert :: ElemOf set -> set -> set
+  setDelete :: ElemOf set -> set -> set
+
+  setUnion :: set -> set -> set
+  setDifference :: set -> set -> set
+  setIntersection :: set -> set -> set
+  setIsSubsetOf :: set -> set -> Bool
+  setFilter :: (ElemOf set -> Bool) -> set -> set
+
+  setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b
+  setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b
+
+  setElems :: set -> [ElemOf set]
+  setFromList :: [ElemOf set] -> set
+
+-- Helper functions for IsSet class
+setInsertList :: IsSet set => [ElemOf set] -> set -> set
+setInsertList keys set = foldl' (flip setInsert) set keys
+
+setDeleteList :: IsSet set => [ElemOf set] -> set -> set
+setDeleteList keys set = foldl' (flip setDelete) set keys
+
+setUnions :: IsSet set => [set] -> set
+setUnions [] = setEmpty
+setUnions sets = foldl1' setUnion sets
+
+
+class IsMap map where
+  type KeyOf map
+
+  mapNull :: map a -> Bool
+  mapSize :: map a -> Int
+  mapMember :: KeyOf map -> map a -> Bool
+  mapLookup :: KeyOf map -> map a -> Maybe a
+  mapFindWithDefault :: a -> KeyOf map -> map a -> a
+
+  mapEmpty :: map a
+  mapSingleton :: KeyOf map -> a -> map a
+  mapInsert :: KeyOf map -> a -> map a -> map a
+  mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a
+  mapDelete :: KeyOf map -> map a -> map a
+  mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
+  mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a
+
+  mapUnion :: map a -> map a -> map a
+  mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a
+  mapDifference :: map a -> map a -> map a
+  mapIntersection :: map a -> map a -> map a
+  mapIsSubmapOf :: Eq a => map a -> map a -> Bool
+
+  mapMap :: (a -> b) -> map a -> map b
+  mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b
+  mapFoldl :: (b -> a -> b) -> b -> map a -> b
+  mapFoldr :: (a -> b -> b) -> b -> map a -> b
+  mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b
+  mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m
+  mapFilter :: (a -> Bool) -> map a -> map a
+  mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a
+
+
+  mapElems :: map a -> [a]
+  mapKeys :: map a -> [KeyOf map]
+  mapToList :: map a -> [(KeyOf map, a)]
+  mapFromList :: [(KeyOf map, a)] -> map a
+  mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a
+
+-- Helper functions for IsMap class
+mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a
+mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs
+
+mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a
+mapDeleteList keys map = foldl' (flip mapDelete) map keys
+
+mapUnions :: IsMap map => [map a] -> map a
+mapUnions [] = mapEmpty
+mapUnions maps = foldl1' mapUnion maps
+
+-----------------------------------------------------------------------------
+-- Basic instances
+-----------------------------------------------------------------------------
+
+newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show, Semigroup, Monoid)
+
+instance IsSet UniqueSet where
+  type ElemOf UniqueSet = Int
+
+  setNull (US s) = S.null s
+  setSize (US s) = S.size s
+  setMember k (US s) = S.member k s
+
+  setEmpty = US S.empty
+  setSingleton k = US (S.singleton k)
+  setInsert k (US s) = US (S.insert k s)
+  setDelete k (US s) = US (S.delete k s)
+
+  setUnion (US x) (US y) = US (S.union x y)
+  setDifference (US x) (US y) = US (S.difference x y)
+  setIntersection (US x) (US y) = US (S.intersection x y)
+  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y
+  setFilter f (US s) = US (S.filter f s)
+
+  setFoldl k z (US s) = S.foldl' k z s
+  setFoldr k z (US s) = S.foldr k z s
+
+  setElems (US s) = S.elems s
+  setFromList ks = US (S.fromList ks)
+
+newtype UniqueMap v = UM (M.IntMap v)
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance IsMap UniqueMap where
+  type KeyOf UniqueMap = Int
+
+  mapNull (UM m) = M.null m
+  mapSize (UM m) = M.size m
+  mapMember k (UM m) = M.member k m
+  mapLookup k (UM m) = M.lookup k m
+  mapFindWithDefault def k (UM m) = M.findWithDefault def k m
+
+  mapEmpty = UM M.empty
+  mapSingleton k v = UM (M.singleton k v)
+  mapInsert k v (UM m) = UM (M.insert k v m)
+  mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)
+  mapDelete k (UM m) = UM (M.delete k m)
+  mapAlter f k (UM m) = UM (M.alter f k m)
+  mapAdjust f k (UM m) = UM (M.adjust f k m)
+
+  mapUnion (UM x) (UM y) = UM (M.union x y)
+  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)
+  mapDifference (UM x) (UM y) = UM (M.difference x y)
+  mapIntersection (UM x) (UM y) = UM (M.intersection x y)
+  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y
+
+  mapMap f (UM m) = UM (M.map f m)
+  mapMapWithKey f (UM m) = UM (M.mapWithKey f m)
+  mapFoldl k z (UM m) = M.foldl' k z m
+  mapFoldr k z (UM m) = M.foldr k z m
+  mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m
+  mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m
+  mapFilter f (UM m) = UM (M.filter f m)
+  mapFilterWithKey f (UM m) = UM (M.filterWithKey f m)
+
+  mapElems (UM m) = M.elems m
+  mapKeys (UM m) = M.keys m
+  mapToList (UM m) = M.toList m
+  mapFromList assocs = UM (M.fromList assocs)
+  mapFromListWith f assocs = UM (M.fromListWith f assocs)
diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Hoopl/Dataflow.hs
@@ -0,0 +1,440 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses  #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fprof-auto-top #-}
+
+--
+-- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,
+-- and Norman Ramsey
+--
+-- Modifications copyright (c) The University of Glasgow 2012
+--
+-- This module is a specialised and optimised version of
+-- Compiler.Hoopl.Dataflow in the hoopl package.  In particular it is
+-- specialised to the UniqSM monad.
+--
+
+module Hoopl.Dataflow
+  ( C, O, Block
+  , lastNode, entryLabel
+  , foldNodesBwdOO
+  , foldRewriteNodesBwdOO
+  , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..)
+  , TransferFun, RewriteFun
+  , Fact, FactBase
+  , getFact, mkFactBase
+  , analyzeCmmFwd, analyzeCmmBwd
+  , rewriteCmmBwd
+  , changedIf
+  , joinOutFacts
+  , joinFacts
+  )
+where
+
+import GhcPrelude
+
+import Cmm
+import UniqSupply
+
+import Data.Array
+import Data.Maybe
+import Data.IntSet (IntSet)
+import qualified Data.IntSet as IntSet
+
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Collections
+import Hoopl.Label
+
+type family   Fact x f :: *
+type instance Fact C f = FactBase f
+type instance Fact O f = f
+
+newtype OldFact a = OldFact a
+
+newtype NewFact a = NewFact a
+
+-- | The result of joining OldFact and NewFact.
+data JoinedFact a
+    = Changed !a     -- ^ Result is different than OldFact.
+    | NotChanged !a  -- ^ Result is the same as OldFact.
+
+getJoined :: JoinedFact a -> a
+getJoined (Changed a) = a
+getJoined (NotChanged a) = a
+
+changedIf :: Bool -> a -> JoinedFact a
+changedIf True = Changed
+changedIf False = NotChanged
+
+type JoinFun a = OldFact a -> NewFact a -> JoinedFact a
+
+data DataflowLattice a = DataflowLattice
+    { fact_bot :: a
+    , fact_join :: JoinFun a
+    }
+
+data Direction = Fwd | Bwd
+
+type TransferFun f = CmmBlock -> FactBase f -> FactBase f
+
+-- | Function for rewrtiting and analysis combined. To be used with
+-- @rewriteCmm@.
+--
+-- Currently set to work with @UniqSM@ monad, but we could probably abstract
+-- that away (if we do that, we might want to specialize the fixpoint algorithms
+-- to the particular monads through SPECIALIZE).
+type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f)
+
+analyzeCmmBwd, analyzeCmmFwd
+    :: DataflowLattice f
+    -> TransferFun f
+    -> CmmGraph
+    -> FactBase f
+    -> FactBase f
+analyzeCmmBwd = analyzeCmm Bwd
+analyzeCmmFwd = analyzeCmm Fwd
+
+analyzeCmm
+    :: Direction
+    -> DataflowLattice f
+    -> TransferFun f
+    -> CmmGraph
+    -> FactBase f
+    -> FactBase f
+analyzeCmm dir lattice transfer cmmGraph initFact =
+    let entry = g_entry cmmGraph
+        hooplGraph = g_graph cmmGraph
+        blockMap =
+            case hooplGraph of
+                GMany NothingO bm NothingO -> bm
+    in fixpointAnalysis dir lattice transfer entry blockMap initFact
+
+-- Fixpoint algorithm.
+fixpointAnalysis
+    :: forall f.
+       Direction
+    -> DataflowLattice f
+    -> TransferFun f
+    -> Label
+    -> LabelMap CmmBlock
+    -> FactBase f
+    -> FactBase f
+fixpointAnalysis direction lattice do_block entry blockmap = loop start
+  where
+    -- Sorting the blocks helps to minimize the number of times we need to
+    -- process blocks. For instance, for forward analysis we want to look at
+    -- blocks in reverse postorder. Also, see comments for sortBlocks.
+    blocks     = sortBlocks direction entry blockmap
+    num_blocks = length blocks
+    block_arr  = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks
+    start      = {-# SCC "start" #-} IntSet.fromDistinctAscList
+      [0 .. num_blocks - 1]
+    dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks
+    join       = fact_join lattice
+
+    loop
+        :: IntHeap     -- ^ Worklist, i.e., blocks to process
+        -> FactBase f  -- ^ Current result (increases monotonically)
+        -> FactBase f
+    loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo =
+        let block = block_arr ! index
+            out_facts = {-# SCC "do_block" #-} do_block block fbase1
+            -- For each of the outgoing edges, we join it with the current
+            -- information in fbase1 and (if something changed) we update it
+            -- and add the affected blocks to the worklist.
+            (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-}
+                mapFoldlWithKey
+                    (updateFact join dep_blocks) (todo1, fbase1) out_facts
+        in loop todo2 fbase2
+    loop _ !fbase1 = fbase1
+
+rewriteCmmBwd
+    :: DataflowLattice f
+    -> RewriteFun f
+    -> CmmGraph
+    -> FactBase f
+    -> UniqSM (CmmGraph, FactBase f)
+rewriteCmmBwd = rewriteCmm Bwd
+
+rewriteCmm
+    :: Direction
+    -> DataflowLattice f
+    -> RewriteFun f
+    -> CmmGraph
+    -> FactBase f
+    -> UniqSM (CmmGraph, FactBase f)
+rewriteCmm dir lattice rwFun cmmGraph initFact = do
+    let entry = g_entry cmmGraph
+        hooplGraph = g_graph cmmGraph
+        blockMap1 =
+            case hooplGraph of
+                GMany NothingO bm NothingO -> bm
+    (blockMap2, facts) <-
+        fixpointRewrite dir lattice rwFun entry blockMap1 initFact
+    return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts)
+
+fixpointRewrite
+    :: forall f.
+       Direction
+    -> DataflowLattice f
+    -> RewriteFun f
+    -> Label
+    -> LabelMap CmmBlock
+    -> FactBase f
+    -> UniqSM (LabelMap CmmBlock, FactBase f)
+fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap
+  where
+    -- Sorting the blocks helps to minimize the number of times we need to
+    -- process blocks. For instance, for forward analysis we want to look at
+    -- blocks in reverse postorder. Also, see comments for sortBlocks.
+    blocks     = sortBlocks dir entry blockmap
+    num_blocks = length blocks
+    block_arr  = {-# SCC "block_arr_rewrite" #-}
+                 listArray (0, num_blocks - 1) blocks
+    start      = {-# SCC "start_rewrite" #-}
+                 IntSet.fromDistinctAscList [0 .. num_blocks - 1]
+    dep_blocks = {-# SCC "dep_blocks_rewrite" #-} mkDepBlocks dir blocks
+    join       = fact_join lattice
+
+    loop
+        :: IntHeap            -- ^ Worklist, i.e., blocks to process
+        -> LabelMap CmmBlock  -- ^ Rewritten blocks.
+        -> FactBase f         -- ^ Current facts.
+        -> UniqSM (LabelMap CmmBlock, FactBase f)
+    loop todo !blocks1 !fbase1
+      | Just (index, todo1) <- IntSet.minView todo = do
+        -- Note that we use the *original* block here. This is important.
+        -- We're optimistically rewriting blocks even before reaching the fixed
+        -- point, which means that the rewrite might be incorrect. So if the
+        -- facts change, we need to rewrite the original block again (taking
+        -- into account the new facts).
+        let block = block_arr ! index
+        (new_block, out_facts) <- {-# SCC "do_block_rewrite" #-}
+            do_block block fbase1
+        let blocks2 = mapInsert (entryLabel new_block) new_block blocks1
+            (todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-}
+                mapFoldlWithKey
+                    (updateFact join dep_blocks) (todo1, fbase1) out_facts
+        loop todo2 blocks2 fbase2
+    loop _ !blocks1 !fbase1 = return (blocks1, fbase1)
+
+
+{-
+Note [Unreachable blocks]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+A block that is not in the domain of tfb_fbase is "currently unreachable".
+A currently-unreachable block is not even analyzed.  Reason: consider
+constant prop and this graph, with entry point L1:
+  L1: x:=3; goto L4
+  L2: x:=4; goto L4
+  L4: if x>3 goto L2 else goto L5
+Here L2 is actually unreachable, but if we process it with bottom input fact,
+we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.
+
+* If a currently-unreachable block is not analyzed, then its rewritten
+  graph will not be accumulated in tfb_rg.  And that is good:
+  unreachable blocks simply do not appear in the output.
+
+* Note that clients must be careful to provide a fact (even if bottom)
+  for each entry point. Otherwise useful blocks may be garbage collected.
+
+* Note that updateFact must set the change-flag if a label goes from
+  not-in-fbase to in-fbase, even if its fact is bottom.  In effect the
+  real fact lattice is
+       UNR
+       bottom
+       the points above bottom
+
+* Even if the fact is going from UNR to bottom, we still call the
+  client's fact_join function because it might give the client
+  some useful debugging information.
+
+* All of this only applies for *forward* ixpoints.  For the backward
+  case we must treat every block as reachable; it might finish with a
+  'return', and therefore have no successors, for example.
+-}
+
+
+-----------------------------------------------------------------------------
+--  Pieces that are shared by fixpoint and fixpoint_anal
+-----------------------------------------------------------------------------
+
+-- | Sort the blocks into the right order for analysis. This means reverse
+-- postorder for a forward analysis. For the backward one, we simply reverse
+-- that (see Note [Backward vs forward analysis]).
+sortBlocks
+    :: NonLocal n
+    => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]
+sortBlocks direction entry blockmap =
+    case direction of
+        Fwd -> fwd
+        Bwd -> reverse fwd
+  where
+    fwd = revPostorderFrom blockmap entry
+
+-- Note [Backward vs forward analysis]
+--
+-- The forward and backward cases are not dual.  In the forward case, the entry
+-- points are known, and one simply traverses the body blocks from those points.
+-- In the backward case, something is known about the exit points, but a
+-- backward analysis must also include reachable blocks that don't reach the
+-- exit, as in a procedure that loops forever and has side effects.)
+-- For instance, let E be the entry and X the exit blocks (arrows indicate
+-- control flow)
+--   E -> X
+--   E -> B
+--   B -> C
+--   C -> B
+-- We do need to include B and C even though they're unreachable in the
+-- *reverse* graph (that we could use for backward analysis):
+--   E <- X
+--   E <- B
+--   B <- C
+--   C <- B
+-- So when sorting the blocks for the backward analysis, we simply take the
+-- reverse of what is used for the forward one.
+
+
+-- | Construct a mapping from a @Label@ to the block indexes that should be
+-- re-analyzed if the facts at that @Label@ change.
+--
+-- Note that we're considering here the entry point of the block, so if the
+-- facts change at the entry:
+-- * for a backward analysis we need to re-analyze all the predecessors, but
+-- * for a forward analysis, we only need to re-analyze the current block
+--   (and that will in turn propagate facts into its successors).
+mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntSet
+mkDepBlocks Fwd blocks = go blocks 0 mapEmpty
+  where
+    go []     !_ !dep_map = dep_map
+    go (b:bs) !n !dep_map =
+        go bs (n + 1) $ mapInsert (entryLabel b) (IntSet.singleton n) dep_map
+mkDepBlocks Bwd blocks = go blocks 0 mapEmpty
+  where
+    go []     !_ !dep_map = dep_map
+    go (b:bs) !n !dep_map =
+        let insert m l = mapInsertWith IntSet.union l (IntSet.singleton n) m
+        in go bs (n + 1) $ foldl' insert dep_map (successors b)
+
+-- | After some new facts have been generated by analysing a block, we
+-- fold this function over them to generate (a) a list of block
+-- indices to (re-)analyse, and (b) the new FactBase.
+updateFact
+    :: JoinFun f
+    -> LabelMap IntSet
+    -> (IntHeap, FactBase f)
+    -> Label
+    -> f -- out fact
+    -> (IntHeap, FactBase f)
+updateFact fact_join dep_blocks (todo, fbase) lbl new_fact
+  = case lookupFact lbl fbase of
+      Nothing ->
+          -- Note [No old fact]
+          let !z = mapInsert lbl new_fact fbase in (changed, z)
+      Just old_fact ->
+          case fact_join (OldFact old_fact) (NewFact new_fact) of
+              (NotChanged _) -> (todo, fbase)
+              (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)
+  where
+    changed = todo `IntSet.union`
+              mapFindWithDefault IntSet.empty lbl dep_blocks
+
+{-
+Note [No old fact]
+
+We know that the new_fact is >= _|_, so we don't need to join.  However,
+if the new fact is also _|_, and we have already analysed its block,
+we don't need to record a change.  So there's a tradeoff here.  It turns
+out that always recording a change is faster.
+-}
+
+----------------------------------------------------------------
+--       Utilities
+----------------------------------------------------------------
+
+-- Fact lookup: the fact `orelse` bottom
+getFact  :: DataflowLattice f -> Label -> FactBase f -> f
+getFact lat l fb = case lookupFact l fb of Just  f -> f
+                                           Nothing -> fact_bot lat
+
+-- | Returns the result of joining the facts from all the successors of the
+-- provided node or block.
+joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f
+joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts
+  where
+    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
+    facts =
+        [ fromJust fact
+        | s <- successors nonLocal
+        , let fact = lookupFact s fact_base
+        , isJust fact
+        ]
+
+joinFacts :: DataflowLattice f -> [f] -> f
+joinFacts lattice facts  = foldl' join (fact_bot lattice) facts
+  where
+    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
+
+-- | Returns the joined facts for each label.
+mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
+mkFactBase lattice = foldl' add mapEmpty
+  where
+    join = fact_join lattice
+
+    add result (l, f1) =
+        let !newFact =
+                case mapLookup l result of
+                    Nothing -> f1
+                    Just f2 -> getJoined $ join (OldFact f1) (NewFact f2)
+        in mapInsert l newFact result
+
+-- | Folds backward over all nodes of an open-open block.
+-- Strict in the accumulator.
+foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
+foldNodesBwdOO funOO = go
+  where
+    go (BCat b1 b2) f = go b1 $! go b2 f
+    go (BSnoc h n) f = go h $! funOO n f
+    go (BCons n t) f = funOO n $! go t f
+    go (BMiddle n) f = funOO n f
+    go BNil f = f
+{-# INLINABLE foldNodesBwdOO #-}
+
+-- | Folds backward over all the nodes of an open-open block and allows
+-- rewriting them. The accumulator is both the block of nodes and @f@ (usually
+-- dataflow facts).
+-- Strict in both accumulated parts.
+foldRewriteNodesBwdOO
+    :: forall f.
+       (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f))
+    -> Block CmmNode O O
+    -> f
+    -> UniqSM (Block CmmNode O O, f)
+foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts
+  where
+    go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1
+    go (BSnoc block1 node1) !fact1 = (go block1 `comp` rewriteOO node1) fact1
+    go (BCat blockA1 blockB1) !fact1 = (go blockA1 `comp` go blockB1) fact1
+    go (BMiddle node) !fact1 = rewriteOO node fact1
+    go BNil !fact = return (BNil, fact)
+
+    comp rew1 rew2 = \f1 -> do
+        (b, f2) <- rew2 f1
+        (a, !f3) <- rew1 f2
+        let !c = joinBlocksOO a b
+        return (c, f3)
+    {-# INLINE comp #-}
+{-# INLINABLE foldRewriteNodesBwdOO #-}
+
+joinBlocksOO :: Block n O O -> Block n O O -> Block n O O
+joinBlocksOO BNil b = b
+joinBlocksOO b BNil = b
+joinBlocksOO (BMiddle n) b = blockCons n b
+joinBlocksOO b (BMiddle n) = blockSnoc b n
+joinBlocksOO b1 b2 = BCat b1 b2
+
+type IntHeap = IntSet
diff --git a/compiler/cmm/Hoopl/Graph.hs b/compiler/cmm/Hoopl/Graph.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Hoopl/Graph.hs
@@ -0,0 +1,185 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module Hoopl.Graph
+    ( Body
+    , Graph
+    , Graph'(..)
+    , NonLocal(..)
+    , addBlock
+    , bodyList
+    , emptyBody
+    , labelsDefined
+    , mapGraph
+    , mapGraphBlocks
+    , revPostorderFrom
+    ) where
+
+
+import GhcPrelude
+import Util
+
+import Hoopl.Label
+import Hoopl.Block
+import Hoopl.Collections
+
+-- | A (possibly empty) collection of closed/closed blocks
+type Body n = LabelMap (Block n C C)
+
+-- | @Body@ abstracted over @block@
+type Body' block (n :: * -> * -> *) = LabelMap (block n C C)
+
+-------------------------------
+-- | Gives access to the anchor points for
+-- nonlocal edges as well as the edges themselves
+class NonLocal thing where
+  entryLabel :: thing C x -> Label   -- ^ The label of a first node or block
+  successors :: thing e C -> [Label] -- ^ Gives control-flow successors
+
+instance NonLocal n => NonLocal (Block n) where
+  entryLabel (BlockCO f _)   = entryLabel f
+  entryLabel (BlockCC f _ _) = entryLabel f
+
+  successors (BlockOC   _ n) = successors n
+  successors (BlockCC _ _ n) = successors n
+
+
+emptyBody :: Body' block n
+emptyBody = mapEmpty
+
+bodyList :: Body' block n -> [(Label,block n C C)]
+bodyList body = mapToList body
+
+addBlock
+    :: (NonLocal block, HasDebugCallStack)
+    => block C C -> LabelMap (block C C) -> LabelMap (block C C)
+addBlock block body = mapAlter add lbl body
+  where
+    lbl = entryLabel block
+    add Nothing = Just block
+    add _ = error $ "duplicate label " ++ show lbl ++ " in graph"
+
+
+-- ---------------------------------------------------------------------------
+-- Graph
+
+-- | A control-flow graph, which may take any of four shapes (O/O,
+-- O/C, C/O, C/C).  A graph open at the entry has a single,
+-- distinguished, anonymous entry point; if a graph is closed at the
+-- entry, its entry point(s) are supplied by a context.
+type Graph = Graph' Block
+
+-- | @Graph'@ is abstracted over the block type, so that we can build
+-- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow
+-- needs this).
+data Graph' block (n :: * -> * -> *) e x where
+  GNil  :: Graph' block n O O
+  GUnit :: block n O O -> Graph' block n O O
+  GMany :: MaybeO e (block n O C)
+        -> Body' block n
+        -> MaybeO x (block n C O)
+        -> Graph' block n e x
+
+
+-- -----------------------------------------------------------------------------
+-- Mapping over graphs
+
+-- | Maps over all nodes in a graph.
+mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x
+mapGraph f = mapGraphBlocks (mapBlock f)
+
+-- | Function 'mapGraphBlocks' enables a change of representation of blocks,
+-- nodes, or both.  It lifts a polymorphic block transform into a polymorphic
+-- graph transform.  When the block representation stabilizes, a similar
+-- function should be provided for blocks.
+mapGraphBlocks :: forall block n block' n' e x .
+                  (forall e x . block n e x -> block' n' e x)
+               -> (Graph' block n e x -> Graph' block' n' e x)
+
+mapGraphBlocks f = map
+  where map :: Graph' block n e x -> Graph' block' n' e x
+        map GNil = GNil
+        map (GUnit b) = GUnit (f b)
+        map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)
+
+-- -----------------------------------------------------------------------------
+-- Extracting Labels from graphs
+
+labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x
+              -> LabelSet
+labelsDefined GNil      = setEmpty
+labelsDefined (GUnit{}) = setEmpty
+labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body
+  where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet
+        addEntry labels label _ = setInsert label labels
+        exitLabel :: MaybeO x (block n C O) -> LabelSet
+        exitLabel NothingO  = setEmpty
+        exitLabel (JustO b) = setSingleton (entryLabel b)
+
+
+----------------------------------------------------------------
+
+-- | Returns a list of blocks reachable from the provided Labels in the reverse
+-- postorder.
+--
+-- This is the most important traversal over this data structure.  It drops
+-- unreachable code and puts blocks in an order that is good for solving forward
+-- dataflow problems quickly.  The reverse order is good for solving backward
+-- dataflow problems quickly.  The forward order is also reasonably good for
+-- emitting instructions, except that it will not usually exploit Forrest
+-- Baskett's trick of eliminating the unconditional branch from a loop.  For
+-- that you would need a more serious analysis, probably based on dominators, to
+-- identify loop headers.
+--
+-- For forward analyses we want reverse postorder visitation, consider:
+-- @
+--      A -> [B,C]
+--      B -> D
+--      C -> D
+-- @
+-- Postorder: [D, C, B, A] (or [D, B, C, A])
+-- Reverse postorder: [A, B, C, D] (or [A, C, B, D])
+-- This matters for, e.g., forward analysis, because we want to analyze *both*
+-- B and C before we analyze D.
+revPostorderFrom
+  :: forall block.  (NonLocal block)
+  => LabelMap (block C C) -> Label -> [block C C]
+revPostorderFrom graph start = go start_worklist setEmpty []
+  where
+    start_worklist = lookup_for_descend start Nil
+
+    -- To compute the postorder we need to "visit" a block (mark as done)
+    -- *after* visiting all its successors. So we need to know whether we
+    -- already processed all successors of each block (and @NonLocal@ allows
+    -- arbitrary many successors). So we use an explicit stack with an extra bit
+    -- of information:
+    -- * @ConsTodo@ means to explore the block if it wasn't visited before
+    -- * @ConsMark@ means that all successors were already done and we can add
+    --   the block to the result.
+    --
+    -- NOTE: We add blocks to the result list in postorder, but we *prepend*
+    -- them (i.e., we use @(:)@), which means that the final list is in reverse
+    -- postorder.
+    go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]
+    go Nil                      !_           !result = result
+    go (ConsMark block rest)    !wip_or_done !result =
+        go rest wip_or_done (block : result)
+    go (ConsTodo block rest)    !wip_or_done !result
+        | entryLabel block `setMember` wip_or_done = go rest wip_or_done result
+        | otherwise =
+            let new_worklist =
+                    foldr lookup_for_descend
+                          (ConsMark block rest)
+                          (successors block)
+            in go new_worklist (setInsert (entryLabel block) wip_or_done) result
+
+    lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C)
+    lookup_for_descend label wl
+      | Just b <- mapLookup label graph = ConsTodo b wl
+      | otherwise =
+           error $ "Label that doesn't have a block?! " ++ show label
+
+data DfsStack a = ConsTodo a (DfsStack a) | ConsMark a (DfsStack a) | Nil
diff --git a/compiler/cmm/Hoopl/Label.hs b/compiler/cmm/Hoopl/Label.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/Hoopl/Label.hs
@@ -0,0 +1,142 @@
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Hoopl.Label
+    ( Label
+    , LabelMap
+    , LabelSet
+    , FactBase
+    , lookupFact
+    , mkHooplLabel
+    ) where
+
+import GhcPrelude
+
+import Outputable
+
+-- TODO: This should really just use GHC's Unique and Uniq{Set,FM}
+import Hoopl.Collections
+
+import Unique (Uniquable(..))
+import TrieMap
+
+
+-----------------------------------------------------------------------------
+--              Label
+-----------------------------------------------------------------------------
+
+newtype Label = Label { lblToUnique :: Int }
+  deriving (Eq, Ord)
+
+mkHooplLabel :: Int -> Label
+mkHooplLabel = Label
+
+instance Show Label where
+  show (Label n) = "L" ++ show n
+
+instance Uniquable Label where
+  getUnique label = getUnique (lblToUnique label)
+
+instance Outputable Label where
+  ppr label = ppr (getUnique label)
+
+-----------------------------------------------------------------------------
+-- LabelSet
+
+newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup)
+
+instance IsSet LabelSet where
+  type ElemOf LabelSet = Label
+
+  setNull (LS s) = setNull s
+  setSize (LS s) = setSize s
+  setMember (Label k) (LS s) = setMember k s
+
+  setEmpty = LS setEmpty
+  setSingleton (Label k) = LS (setSingleton k)
+  setInsert (Label k) (LS s) = LS (setInsert k s)
+  setDelete (Label k) (LS s) = LS (setDelete k s)
+
+  setUnion (LS x) (LS y) = LS (setUnion x y)
+  setDifference (LS x) (LS y) = LS (setDifference x y)
+  setIntersection (LS x) (LS y) = LS (setIntersection x y)
+  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y
+  setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s)
+  setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s
+  setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s
+
+  setElems (LS s) = map mkHooplLabel (setElems s)
+  setFromList ks = LS (setFromList (map lblToUnique ks))
+
+-----------------------------------------------------------------------------
+-- LabelMap
+
+newtype LabelMap v = LM (UniqueMap v)
+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
+
+instance IsMap LabelMap where
+  type KeyOf LabelMap = Label
+
+  mapNull (LM m) = mapNull m
+  mapSize (LM m) = mapSize m
+  mapMember (Label k) (LM m) = mapMember k m
+  mapLookup (Label k) (LM m) = mapLookup k m
+  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m
+
+  mapEmpty = LM mapEmpty
+  mapSingleton (Label k) v = LM (mapSingleton k v)
+  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
+  mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
+  mapDelete (Label k) (LM m) = LM (mapDelete k m)
+  mapAlter f (Label k) (LM m) = LM (mapAlter f k m)
+  mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m)
+
+  mapUnion (LM x) (LM y) = LM (mapUnion x y)
+  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)
+  mapDifference (LM x) (LM y) = LM (mapDifference x y)
+  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)
+  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y
+
+  mapMap f (LM m) = LM (mapMap f m)
+  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)
+  mapFoldl k z (LM m) = mapFoldl k z m
+  mapFoldr k z (LM m) = mapFoldr k z m
+  mapFoldlWithKey k z (LM m) =
+      mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m
+  mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m
+  mapFilter f (LM m) = LM (mapFilter f m)
+  mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)
+
+  mapElems (LM m) = mapElems m
+  mapKeys (LM m) = map mkHooplLabel (mapKeys m)
+  mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]
+  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
+  mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])
+
+-----------------------------------------------------------------------------
+-- Instances
+
+instance Outputable LabelSet where
+  ppr = ppr . setElems
+
+instance Outputable a => Outputable (LabelMap a) where
+  ppr = ppr . mapToList
+
+instance TrieMap LabelMap where
+  type Key LabelMap = Label
+  emptyTM = mapEmpty
+  lookupTM k m = mapLookup k m
+  alterTM k f m = mapAlter f k m
+  foldTM k m z = mapFoldr k z m
+  mapTM f m = mapMap f m
+
+-----------------------------------------------------------------------------
+-- FactBase
+
+type FactBase f = LabelMap f
+
+lookupFact :: Label -> FactBase f -> Maybe f
+lookupFact = mapLookup
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/MkGraph.hs
@@ -0,0 +1,484 @@
+{-# LANGUAGE BangPatterns, GADTs #-}
+
+module MkGraph
+  ( CmmAGraph, CmmAGraphScoped, CgStmt(..)
+  , (<*>), catAGraphs
+  , mkLabel, mkMiddle, mkLast, outOfLine
+  , lgraphOfAGraph, labelAGraph
+
+  , stackStubExpr
+  , mkNop, mkAssign, mkStore
+  , mkUnsafeCall, mkFinalCall, mkCallReturnsTo
+  , mkJumpReturnsTo
+  , mkJump, mkJumpExtra
+  , mkRawJump
+  , mkCbranch, mkSwitch
+  , mkReturn, mkComment, mkCallEntry, mkBranch
+  , mkUnwind
+  , copyInOflow, copyOutOflow
+  , noExtraStack
+  , toCall, Transfer(..)
+  )
+where
+
+import GhcPrelude hiding ( (<*>) ) -- avoid importing (<*>)
+
+import BlockId
+import Cmm
+import CmmCallConv
+import CmmSwitch (SwitchTargets)
+
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Label
+import DynFlags
+import FastString
+import ForeignCall
+import OrdList
+import SMRep (ByteOff)
+import UniqSupply
+import Util
+import Panic
+
+
+-----------------------------------------------------------------------------
+-- Building Graphs
+
+
+-- | CmmAGraph is a chunk of code consisting of:
+--
+--   * ordinary statements (assignments, stores etc.)
+--   * jumps
+--   * labels
+--   * out-of-line labelled blocks
+--
+-- The semantics is that control falls through labels and out-of-line
+-- blocks.  Everything after a jump up to the next label is by
+-- definition unreachable code, and will be discarded.
+--
+-- Two CmmAGraphs can be stuck together with <*>, with the meaning that
+-- control flows from the first to the second.
+--
+-- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends)
+-- by providing a label for the entry point and a tick scope; see
+-- 'labelAGraph'.
+type CmmAGraph = OrdList CgStmt
+-- | Unlabeled graph with tick scope
+type CmmAGraphScoped = (CmmAGraph, CmmTickScope)
+
+data CgStmt
+  = CgLabel BlockId CmmTickScope
+  | CgStmt  (CmmNode O O)
+  | CgLast  (CmmNode O C)
+  | CgFork  BlockId CmmAGraph CmmTickScope
+
+flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph
+flattenCmmAGraph id (stmts_t, tscope) =
+    CmmGraph { g_entry = id,
+               g_graph = GMany NothingO body NothingO }
+  where
+  body = foldr addBlock emptyBody $ flatten id stmts_t tscope []
+
+  --
+  -- flatten: given an entry label and a CmmAGraph, make a list of blocks.
+  --
+  -- NB. avoid the quadratic-append trap by passing in the tail of the
+  -- list.  This is important for Very Long Functions (e.g. in T783).
+  --
+  flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C]
+          -> [Block CmmNode C C]
+  flatten id g tscope blocks
+      = flatten1 (fromOL g) block' blocks
+      where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock
+  --
+  -- flatten0: we are outside a block at this point: any code before
+  -- the first label is unreachable, so just drop it.
+  --
+  flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]
+  flatten0 [] blocks = blocks
+
+  flatten0 (CgLabel id tscope : stmts) blocks
+    = flatten1 stmts block blocks
+    where !block = blockJoinHead (CmmEntry id tscope) emptyBlock
+
+  flatten0 (CgFork fork_id stmts_t tscope : rest) blocks
+    = flatten fork_id stmts_t tscope $ flatten0 rest blocks
+
+  flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks
+  flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks
+
+  --
+  -- flatten1: we have a partial block, collect statements until the
+  -- next last node to make a block, then call flatten0 to get the rest
+  -- of the blocks
+  --
+  flatten1 :: [CgStmt] -> Block CmmNode C O
+           -> [Block CmmNode C C] -> [Block CmmNode C C]
+
+  -- The current block falls through to the end of a function or fork:
+  -- this code should not be reachable, but it may be referenced by
+  -- other code that is not reachable.  We'll remove it later with
+  -- dead-code analysis, but for now we have to keep the graph
+  -- well-formed, so we terminate the block with a branch to the
+  -- beginning of the current block.
+  flatten1 [] block blocks
+    = blockJoinTail block (CmmBranch (entryLabel block)) : blocks
+
+  flatten1 (CgLast stmt : stmts) block blocks
+    = block' : flatten0 stmts blocks
+    where !block' = blockJoinTail block stmt
+
+  flatten1 (CgStmt stmt : stmts) block blocks
+    = flatten1 stmts block' blocks
+    where !block' = blockSnoc block stmt
+
+  flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks
+    = flatten fork_id stmts_t tscope $ flatten1 rest block blocks
+
+  -- a label here means that we should start a new block, and the
+  -- current block should fall through to the new block.
+  flatten1 (CgLabel id tscp : stmts) block blocks
+    = blockJoinTail block (CmmBranch id) :
+      flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks
+
+
+
+---------- AGraph manipulation
+
+(<*>)          :: CmmAGraph -> CmmAGraph -> CmmAGraph
+(<*>)           = appOL
+
+catAGraphs     :: [CmmAGraph] -> CmmAGraph
+catAGraphs      = concatOL
+
+-- | created a sequence "goto id; id:" as an AGraph
+mkLabel        :: BlockId -> CmmTickScope -> CmmAGraph
+mkLabel bid scp = unitOL (CgLabel bid scp)
+
+-- | creates an open AGraph from a given node
+mkMiddle        :: CmmNode O O -> CmmAGraph
+mkMiddle middle = unitOL (CgStmt middle)
+
+-- | created a closed AGraph from a given node
+mkLast         :: CmmNode O C -> CmmAGraph
+mkLast last     = unitOL (CgLast last)
+
+-- | A labelled code block; should end in a last node
+outOfLine      :: BlockId -> CmmAGraphScoped -> CmmAGraph
+outOfLine l (c,s) = unitOL (CgFork l c s)
+
+-- | allocate a fresh label for the entry point
+lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph
+lgraphOfAGraph g = do
+  u <- getUniqueM
+  return (labelAGraph (mkBlockId u) g)
+
+-- | use the given BlockId as the label of the entry point
+labelAGraph    :: BlockId -> CmmAGraphScoped -> CmmGraph
+labelAGraph lbl ag = flattenCmmAGraph lbl ag
+
+---------- No-ops
+mkNop        :: CmmAGraph
+mkNop         = nilOL
+
+mkComment    :: FastString -> CmmAGraph
+mkComment fs
+  -- SDM: generating all those comments takes time, this saved about 4% for me
+  | debugIsOn = mkMiddle $ CmmComment fs
+  | otherwise = nilOL
+
+---------- Assignment and store
+mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
+mkAssign l (CmmReg r) | l == r  = mkNop
+mkAssign l r  = mkMiddle $ CmmAssign l r
+
+mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
+mkStore  l r  = mkMiddle $ CmmStore  l r
+
+---------- Control transfer
+mkJump          :: DynFlags -> Convention -> CmmExpr
+                -> [CmmExpr]
+                -> UpdFrameOffset
+                -> CmmAGraph
+mkJump dflags conv e actuals updfr_off =
+  lastWithArgs dflags Jump Old conv actuals updfr_off $
+    toCall e Nothing updfr_off 0
+
+-- | A jump where the caller says what the live GlobalRegs are.  Used
+-- for low-level hand-written Cmm.
+mkRawJump       :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg]
+                -> CmmAGraph
+mkRawJump dflags e updfr_off vols =
+  lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $
+    \arg_space _  -> toCall e Nothing updfr_off 0 arg_space vols
+
+
+mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]
+                -> UpdFrameOffset -> [CmmExpr]
+                -> CmmAGraph
+mkJumpExtra dflags conv e actuals updfr_off extra_stack =
+  lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
+    toCall e Nothing updfr_off 0
+
+mkCbranch       :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
+mkCbranch pred ifso ifnot likely =
+  mkLast (CmmCondBranch pred ifso ifnot likely)
+
+mkSwitch        :: CmmExpr -> SwitchTargets -> CmmAGraph
+mkSwitch e tbl   = mkLast $ CmmSwitch e tbl
+
+mkReturn        :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset
+                -> CmmAGraph
+mkReturn dflags e actuals updfr_off =
+  lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $
+    toCall e Nothing updfr_off 0
+
+mkBranch        :: BlockId -> CmmAGraph
+mkBranch bid     = mkLast (CmmBranch bid)
+
+mkFinalCall   :: DynFlags
+              -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset
+              -> CmmAGraph
+mkFinalCall dflags f _ actuals updfr_off =
+  lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
+    toCall f Nothing updfr_off 0
+
+mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
+                -> BlockId
+                -> ByteOff
+                -> UpdFrameOffset
+                -> [CmmExpr]
+                -> CmmAGraph
+mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
+  lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
+     updfr_off extra_stack $
+       toCall f (Just ret_lbl) updfr_off ret_off
+
+-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
+-- already on the stack).
+mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
+                -> BlockId
+                -> ByteOff
+                -> UpdFrameOffset
+                -> CmmAGraph
+mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off  = do
+  lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $
+       toCall f (Just ret_lbl) updfr_off ret_off
+
+mkUnsafeCall  :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
+mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
+
+-- | Construct a 'CmmUnwind' node for the given register and unwinding
+-- expression.
+mkUnwind     :: GlobalReg -> CmmExpr -> CmmAGraph
+mkUnwind r e  = mkMiddle $ CmmUnwind [(r, Just e)]
+
+--------------------------------------------------------------------------
+
+
+
+
+-- Why are we inserting extra blocks that simply branch to the successors?
+-- Because in addition to the branch instruction, @mkBranch@ will insert
+-- a necessary adjustment to the stack pointer.
+
+
+-- For debugging purposes, we can stub out dead stack slots:
+stackStubExpr :: Width -> CmmExpr
+stackStubExpr w = CmmLit (CmmInt 0 w)
+
+-- When we copy in parameters, we usually want to put overflow
+-- parameters on the stack, but sometimes we want to pass the
+-- variables in their spill slots.  Therefore, for copying arguments
+-- and results, we provide different functions to pass the arguments
+-- in an overflow area and to pass them in spill slots.
+copyInOflow  :: DynFlags -> Convention -> Area
+             -> [CmmFormal]
+             -> [CmmFormal]
+             -> (Int, [GlobalReg], CmmAGraph)
+
+copyInOflow dflags conv area formals extra_stk
+  = (offset, gregs, catAGraphs $ map mkMiddle nodes)
+  where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk
+
+-- Return the number of bytes used for copying arguments, as well as the
+-- instructions to copy the arguments.
+copyIn :: DynFlags -> Convention -> Area
+       -> [CmmFormal]
+       -> [CmmFormal]
+       -> (ByteOff, [GlobalReg], [CmmNode O O])
+copyIn dflags conv area formals extra_stk
+  = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
+  where
+    -- See Note [Width of parameters]
+    ci (reg, RegisterParam r@(VanillaReg {})) =
+        let local = CmmLocal reg
+            global = CmmReg (CmmGlobal r)
+            width = cmmRegWidth dflags local
+            expr
+                | width == wordWidth dflags = global
+                | width < wordWidth dflags =
+                    CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [global]
+                | otherwise = panic "Parameter width greater than word width"
+
+        in CmmAssign local expr
+
+    -- Non VanillaRegs
+    ci (reg, RegisterParam r) =
+        CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))
+
+    ci (reg, StackParam off)
+      | isBitsType $ localRegType reg
+      , typeWidth (localRegType reg) < wordWidth dflags =
+        let
+          stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth dflags))
+          local = CmmLocal reg
+          width = cmmRegWidth dflags local
+          expr  = CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [stack_slot]
+        in CmmAssign local expr 
+         
+      | otherwise =
+         CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
+         where ty = localRegType reg
+
+    init_offset = widthInBytes (wordWidth dflags) -- infotable
+
+    (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk
+
+    (stk_size, args) = assignArgumentsPos dflags stk_off conv
+                                          localRegType formals
+
+-- Factoring out the common parts of the copyout functions yielded something
+-- more complicated:
+
+data Transfer = Call | JumpRet | Jump | Ret deriving Eq
+
+copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]
+             -> UpdFrameOffset
+             -> [CmmExpr] -- extra stack args
+             -> (Int, [GlobalReg], CmmAGraph)
+
+-- Generate code to move the actual parameters into the locations
+-- required by the calling convention.  This includes a store for the
+-- return address.
+--
+-- The argument layout function ignores the pointer to the info table,
+-- so we slot that in here. When copying-out to a young area, we set
+-- the info table for return and adjust the offsets of the other
+-- parameters.  If this is a call instruction, we adjust the offsets
+-- of the other parameters.
+copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
+  = (stk_size, regs, graph)
+  where
+    (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
+
+    -- See Note [Width of parameters]
+    co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =
+        let width = cmmExprWidth dflags v
+            value
+                | width == wordWidth dflags = v
+                | width < wordWidth dflags =
+                    CmmMachOp (MO_XX_Conv width (wordWidth dflags)) [v]
+                | otherwise = panic "Parameter width greater than word width"
+
+        in (r:rs, mkAssign (CmmGlobal r) value <*> ms)
+
+    -- Non VanillaRegs
+    co (v, RegisterParam r) (rs, ms) =
+        (r:rs, mkAssign (CmmGlobal r) v <*> ms)
+
+    -- See Note [Width of parameters]
+    co (v, StackParam off)  (rs, ms)
+      = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms)
+
+    width v = cmmExprWidth dflags v
+    value v
+      | isBitsType $ cmmExprType dflags v
+      , width v < wordWidth dflags =
+        CmmMachOp (MO_XX_Conv (width v) (wordWidth dflags)) [v]
+      | otherwise = v
+
+    (setRA, init_offset) =
+      case area of
+            Young id ->  -- Generate a store instruction for
+                         -- the return address if making a call
+                  case transfer of
+                     Call ->
+                       ([(CmmLit (CmmBlock id), StackParam init_offset)],
+                       widthInBytes (wordWidth dflags))
+                     JumpRet ->
+                       ([],
+                       widthInBytes (wordWidth dflags))
+                     _other ->
+                       ([], 0)
+            Old -> ([], updfr_off)
+
+    (extra_stack_off, stack_params) =
+       assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff
+
+    args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it
+    (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv
+                                          (cmmExprType dflags) actuals
+
+
+-- Note [Width of parameters]
+--
+-- Consider passing a small (< word width) primitive like Int8# to a function.
+-- It's actually non-trivial to do this without extending/narrowing:
+-- * Global registers are considered to have native word width (i.e., 64-bits on
+--   x86-64), so CmmLint would complain if we assigned an 8-bit parameter to a
+--   global register.
+-- * Same problem exists with LLVM IR.
+-- * Lowering gets harder since on x86-32 not every register exposes its lower
+--   8 bits (e.g., for %eax we can use %al, but there isn't a corresponding
+--   8-bit register for %edi). So we would either need to extend/narrow anyway,
+--   or complicate the calling convention.
+-- * Passing a small integer in a stack slot, which has native word width,
+--   requires extending to word width when writing to the stack and narrowing
+--   when reading off the stack (see #16258).
+-- So instead, we always extend every parameter smaller than native word width
+-- in copyOutOflow and then truncate it back to the expected width in copyIn.
+-- Note that we do this in cmm using MO_XX_Conv to avoid requiring
+-- zero-/sign-extending - it's up to a backend to handle this in a most
+-- efficient way (e.g., a simple register move or a smaller size store).
+-- This convention (of ignoring the upper bits) is different from some C ABIs,
+-- e.g. all PowerPC ELF ABIs, that require sign or zero extending parameters.
+--
+-- There was some discussion about this on this PR:
+-- https://github.com/ghc-proposals/ghc-proposals/pull/74
+
+
+mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
+            -> (Int, [GlobalReg], CmmAGraph)
+mkCallEntry dflags conv formals extra_stk
+  = copyInOflow dflags conv Old formals extra_stk
+
+lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr]
+             -> UpdFrameOffset
+             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
+             -> CmmAGraph
+lastWithArgs dflags transfer area conv actuals updfr_off last =
+  lastWithArgsAndExtraStack dflags transfer area conv actuals
+                            updfr_off noExtraStack last
+
+lastWithArgsAndExtraStack :: DynFlags
+             -> Transfer -> Area -> Convention -> [CmmExpr]
+             -> UpdFrameOffset -> [CmmExpr]
+             -> (ByteOff -> [GlobalReg] -> CmmAGraph)
+             -> CmmAGraph
+lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
+                          extra_stack last =
+  copies <*> last outArgs regs
+ where
+  (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
+                               updfr_off extra_stack
+
+
+noExtraStack :: [CmmExpr]
+noExtraStack = []
+
+toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
+       -> ByteOff -> [GlobalReg]
+       -> CmmAGraph
+toCall e cont updfr_off res_space arg_space regs =
+  mkLast $ CmmCall e cont regs arg_space res_space updfr_off
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/PprC.hs
@@ -0,0 +1,1380 @@
+{-# LANGUAGE CPP, GADTs #-}
+
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing of Cmm as C, suitable for feeding gcc
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-- Print Cmm as real C, for -fvia-C
+--
+-- See wiki:Commentary/Compiler/Backends/PprC
+--
+-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"
+-- relative to the old AbstractC, and many oddities/decorations have
+-- disappeared from the data type.
+--
+-- This code generator is only supported in unregisterised mode.
+--
+-----------------------------------------------------------------------------
+
+module PprC (
+        writeCs,
+        pprStringInCStyle
+  ) where
+
+#include "HsVersions.h"
+
+-- Cmm stuff
+import GhcPrelude
+
+import BlockId
+import CLabel
+import ForeignCall
+import Cmm hiding (pprBBlock)
+import PprCmm ()
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import CmmUtils
+import CmmSwitch
+
+-- Utils
+import CPrim
+import DynFlags
+import FastString
+import Outputable
+import Platform
+import UniqSet
+import UniqFM
+import Unique
+import Util
+
+-- The rest
+import Control.Monad.ST
+import Data.Bits
+import Data.Char
+import Data.List
+import Data.Map (Map)
+import Data.Word
+import System.IO
+import qualified Data.Map as Map
+import Control.Monad (liftM, ap)
+import qualified Data.Array.Unsafe as U ( castSTUArray )
+import Data.Array.ST
+
+-- --------------------------------------------------------------------------
+-- Top level
+
+pprCs :: [RawCmmGroup] -> SDoc
+pprCs cmms
+ = pprCode CStyle (vcat $ map pprC cmms)
+
+writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO ()
+writeCs dflags handle cmms
+  = printForC dflags handle (pprCs cmms)
+
+-- --------------------------------------------------------------------------
+-- Now do some real work
+--
+-- for fun, we could call cmmToCmm over the tops...
+--
+
+pprC :: RawCmmGroup -> SDoc
+pprC tops = vcat $ intersperse blankLine $ map pprTop tops
+
+--
+-- top level procs
+--
+pprTop :: RawCmmDecl -> SDoc
+pprTop (CmmProc infos clbl _in_live_regs graph) =
+
+    (case mapLookup (g_entry graph) infos of
+       Nothing -> empty
+       Just (Statics info_clbl info_dat) ->
+           pprDataExterns info_dat $$
+           pprWordArray info_is_in_rodata info_clbl info_dat) $$
+    (vcat [
+           blankLine,
+           extern_decls,
+           (if (externallyVisibleCLabel clbl)
+                    then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,
+           nest 8 temp_decls,
+           vcat (map pprBBlock blocks),
+           rbrace ]
+    )
+  where
+        -- info tables are always in .rodata
+        info_is_in_rodata = True
+        blocks = toBlockListEntryFirst graph
+        (temp_decls, extern_decls) = pprTempAndExternDecls blocks
+
+
+-- Chunks of static data.
+
+-- We only handle (a) arrays of word-sized things and (b) strings.
+
+pprTop (CmmData section (Statics lbl [CmmString str])) =
+  pprExternDecl lbl $$
+  hcat [
+    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
+    text "[] = ", pprStringInCStyle str, semi
+  ]
+
+pprTop (CmmData section (Statics lbl [CmmUninitialised size])) =
+  pprExternDecl lbl $$
+  hcat [
+    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
+    brackets (int size), semi
+  ]
+
+pprTop (CmmData section (Statics lbl lits)) =
+  pprDataExterns lits $$
+  pprWordArray (isSecConstant section) lbl lits
+
+-- --------------------------------------------------------------------------
+-- BasicBlocks are self-contained entities: they always end in a jump.
+--
+-- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn
+-- as many jumps as possible into fall throughs.
+--
+
+pprBBlock :: CmmBlock -> SDoc
+pprBBlock block =
+  nest 4 (pprBlockId (entryLabel block) <> colon) $$
+  nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)
+ where
+  (_, nodes, last)  = blockSplit block
+
+-- --------------------------------------------------------------------------
+-- Info tables. Just arrays of words.
+-- See codeGen/ClosureInfo, and nativeGen/PprMach
+
+pprWordArray :: Bool -> CLabel -> [CmmStatic] -> SDoc
+pprWordArray is_ro lbl ds
+  = sdocWithDynFlags $ \dflags ->
+    -- TODO: align closures only
+    pprExternDecl lbl $$
+    hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"
+         , space, ppr lbl, text "[]"
+         -- See Note [StgWord alignment]
+         , pprAlignment (wordWidth dflags)
+         , text "= {" ]
+    $$ nest 8 (commafy (pprStatics dflags ds))
+    $$ text "};"
+
+pprAlignment :: Width -> SDoc
+pprAlignment words =
+     text "__attribute__((aligned(" <> int (widthInBytes words) <> text ")))"
+
+-- Note [StgWord alignment]
+-- C codegen builds static closures as StgWord C arrays (pprWordArray).
+-- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume
+-- pointers to 'StgClosure' are aligned at pointer size boundary:
+--  4 byte boundary on 32 systems
+--  and 8 bytes on 64-bit systems
+-- see TAG_MASK and TAG_BITS definition and usage.
+--
+-- It's a reasonable assumption also known as natural alignment.
+-- Although some architectures have different alignment rules.
+-- One of known exceptions is m68k (Trac #11395, comment:16) where:
+--   __alignof__(StgWord) == 2, sizeof(StgWord) == 4
+--
+-- Thus we explicitly increase alignment by using
+--    __attribute__((aligned(4)))
+-- declaration.
+
+--
+-- has to be static, if it isn't globally visible
+--
+pprLocalness :: CLabel -> SDoc
+pprLocalness lbl | not $ externallyVisibleCLabel lbl = text "static "
+                 | otherwise = empty
+
+pprConstness :: Bool -> SDoc
+pprConstness is_ro | is_ro = text "const "
+                   | otherwise = empty
+
+-- --------------------------------------------------------------------------
+-- Statements.
+--
+
+pprStmt :: CmmNode e x -> SDoc
+
+pprStmt stmt =
+    sdocWithDynFlags $ \dflags ->
+    case stmt of
+    CmmEntry{}   -> empty
+    CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")
+                          -- XXX if the string contains "*/", we need to fix it
+                          -- XXX we probably want to emit these comments when
+                          -- some debugging option is on.  They can get quite
+                          -- large.
+
+    CmmTick _ -> empty
+    CmmUnwind{} -> empty
+
+    CmmAssign dest src -> pprAssign dflags dest src
+
+    CmmStore  dest src
+        | typeWidth rep == W64 && wordWidth dflags /= W64
+        -> (if isFloatType rep then text "ASSIGN_DBL"
+                               else ptext (sLit ("ASSIGN_Word64"))) <>
+           parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
+
+        | otherwise
+        -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
+        where
+          rep = cmmExprType dflags src
+
+    CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->
+        fnCall
+        where
+        (res_hints, arg_hints) = foreignTargetHints target
+        hresults = zip results res_hints
+        hargs    = zip args arg_hints
+
+        ForeignConvention cconv _ _ ret = conv
+
+        cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)
+
+        -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
+        fnCall =
+            case fn of
+              CmmLit (CmmLabel lbl)
+                | StdCallConv <- cconv ->
+                    pprCall (ppr lbl) cconv hresults hargs
+                        -- stdcall functions must be declared with
+                        -- a function type, otherwise the C compiler
+                        -- doesn't add the @n suffix to the label.  We
+                        -- can't add the @n suffix ourselves, because
+                        -- it isn't valid C.
+                | CmmNeverReturns <- ret ->
+                    pprCall cast_fn cconv hresults hargs <> semi
+                | not (isMathFun lbl) ->
+                    pprForeignCall (ppr lbl) cconv hresults hargs
+              _ ->
+                    pprCall cast_fn cconv hresults hargs <> semi
+                        -- for a dynamic call, no declaration is necessary.
+
+    CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty
+    CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _)) _results _args -> empty
+
+    CmmUnsafeForeignCall target@(PrimTarget op) results args ->
+        fn_call
+      where
+        cconv = CCallConv
+        fn = pprCallishMachOp_for_C op
+
+        (res_hints, arg_hints) = foreignTargetHints target
+        hresults = zip results res_hints
+        hargs    = zip args arg_hints
+
+        fn_call
+          -- The mem primops carry an extra alignment arg.
+          -- We could maybe emit an alignment directive using this info.
+          -- We also need to cast mem primops to prevent conflicts with GCC
+          -- builtins (see bug #5967).
+          | Just _align <- machOpMemcpyishAlign op
+          = (text ";EFF_(" <> fn <> char ')' <> semi) $$
+            pprForeignCall fn cconv hresults hargs
+          | otherwise
+          = pprCall fn cconv hresults hargs
+
+    CmmBranch ident          -> pprBranch ident
+    CmmCondBranch expr yes no _ -> pprCondBranch expr yes no
+    CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi
+    CmmSwitch arg ids        -> sdocWithDynFlags $ \dflags ->
+                                pprSwitch dflags arg ids
+
+    _other -> pprPanic "PprC.pprStmt" (ppr stmt)
+
+type Hinted a = (a, ForeignHint)
+
+pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]
+               -> SDoc
+pprForeignCall fn cconv results args = fn_call
+  where
+    fn_call = braces (
+                 pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
+              $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
+              $$ pprCall (text "ghcFunPtr") cconv results args <> semi
+             )
+    cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)
+
+pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
+pprCFunType ppr_fn cconv ress args
+  = sdocWithDynFlags $ \dflags ->
+    let res_type [] = text "void"
+        res_type [(one, hint)] = machRepHintCType (localRegType one) hint
+        res_type _ = panic "pprCFunType: only void or 1 return value supported"
+
+        arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint
+    in res_type ress <+>
+       parens (ccallConvAttribute cconv <> ppr_fn) <>
+       parens (commafy (map arg_type args))
+
+-- ---------------------------------------------------------------------
+-- unconditional branches
+pprBranch :: BlockId -> SDoc
+pprBranch ident = text "goto" <+> pprBlockId ident <> semi
+
+
+-- ---------------------------------------------------------------------
+-- conditional branches to local labels
+pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc
+pprCondBranch expr yes no
+        = hsep [ text "if" , parens(pprExpr expr) ,
+                        text "goto", pprBlockId yes <> semi,
+                        text "else goto", pprBlockId no <> semi ]
+
+-- ---------------------------------------------------------------------
+-- a local table branch
+--
+-- we find the fall-through cases
+--
+pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc
+pprSwitch dflags e ids
+  = (hang (text "switch" <+> parens ( pprExpr e ) <+> lbrace)
+                4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace
+  where
+    (pairs, mbdef) = switchTargetsFallThrough ids
+
+    -- fall through case
+    caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
+        where
+        do_fallthrough ix =
+                 hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,
+                        text "/* fall through */" ]
+
+        final_branch ix =
+                hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,
+                       text "goto" , (pprBlockId ident) <> semi ]
+
+    caseify (_     , _    ) = panic "pprSwitch: switch with no cases!"
+
+    def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi
+        | otherwise       = empty
+
+-- ---------------------------------------------------------------------
+-- Expressions.
+--
+
+-- C Types: the invariant is that the C expression generated by
+--
+--      pprExpr e
+--
+-- has a type in C which is also given by
+--
+--      machRepCType (cmmExprType e)
+--
+-- (similar invariants apply to the rest of the pretty printer).
+
+pprExpr :: CmmExpr -> SDoc
+pprExpr e = case e of
+    CmmLit lit -> pprLit lit
+
+
+    CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty
+    CmmReg reg      -> pprCastReg reg
+    CmmRegOff reg 0 -> pprCastReg reg
+
+    -- CmmRegOff is an alias of MO_Add
+    CmmRegOff reg i -> sdocWithDynFlags $ \dflags ->
+                       pprCastReg reg <> char '+' <>
+                       pprHexVal (fromIntegral i) (wordWidth dflags)
+
+    CmmMachOp mop args -> pprMachOpApp mop args
+
+    CmmStackSlot _ _   -> panic "pprExpr: CmmStackSlot not supported!"
+
+
+pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc
+pprLoad dflags e ty
+  | width == W64, wordWidth dflags /= W64
+  = (if isFloatType ty then text "PK_DBL"
+                       else text "PK_Word64")
+    <> parens (mkP_ <> pprExpr1 e)
+
+  | otherwise
+  = case e of
+        CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)
+                 -> char '*' <> pprAsPtrReg r
+
+        CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)
+                      -> char '*' <> pprAsPtrReg r
+
+        CmmRegOff r off | isPtrReg r && width == wordWidth dflags
+                        , off `rem` wORD_SIZE dflags == 0 && not (isFloatType ty)
+        -- ToDo: check that the offset is a word multiple?
+        --       (For tagging to work, I had to avoid unaligned loads. --ARY)
+                        -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags))
+
+        _other -> cLoad e ty
+  where
+    width = typeWidth ty
+
+pprExpr1 :: CmmExpr -> SDoc
+pprExpr1 (CmmLit lit)     = pprLit1 lit
+pprExpr1 e@(CmmReg _reg)  = pprExpr e
+pprExpr1 other            = parens (pprExpr other)
+
+-- --------------------------------------------------------------------------
+-- MachOp applications
+
+pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc
+
+pprMachOpApp op args
+  | isMulMayOfloOp op
+  = text "mulIntMayOflo" <> parens (commafy (map pprExpr args))
+  where isMulMayOfloOp (MO_U_MulMayOflo _) = True
+        isMulMayOfloOp (MO_S_MulMayOflo _) = True
+        isMulMayOfloOp _ = False
+
+pprMachOpApp mop args
+  | Just ty <- machOpNeedsCast mop
+  = ty <> parens (pprMachOpApp' mop args)
+  | otherwise
+  = pprMachOpApp' mop args
+
+-- Comparisons in C have type 'int', but we want type W_ (this is what
+-- resultRepOfMachOp says).  The other C operations inherit their type
+-- from their operands, so no casting is required.
+machOpNeedsCast :: MachOp -> Maybe SDoc
+machOpNeedsCast mop
+  | isComparisonMachOp mop = Just mkW_
+  | otherwise              = Nothing
+
+pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc
+pprMachOpApp' mop args
+ = case args of
+    -- dyadic
+    [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y
+
+    -- unary
+    [x]   -> pprMachOp_for_C mop <> parens (pprArg x)
+
+    _     -> panic "PprC.pprMachOp : machop with wrong number of args"
+
+  where
+        -- Cast needed for signed integer ops
+    pprArg e | signedOp    mop = sdocWithDynFlags $ \dflags ->
+                                 cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e
+             | needsFCasts mop = sdocWithDynFlags $ \dflags ->
+                                 cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e
+             | otherwise    = pprExpr1 e
+    needsFCasts (MO_F_Eq _)   = False
+    needsFCasts (MO_F_Ne _)   = False
+    needsFCasts (MO_F_Neg _)  = True
+    needsFCasts (MO_F_Quot _) = True
+    needsFCasts mop  = floatComparison mop
+
+-- --------------------------------------------------------------------------
+-- Literals
+
+pprLit :: CmmLit -> SDoc
+pprLit lit = case lit of
+    CmmInt i rep      -> pprHexVal i rep
+
+    CmmFloat f w       -> parens (machRep_F_CType w) <> str
+        where d = fromRational f :: Double
+              str | isInfinite d && d < 0 = text "-INFINITY"
+                  | isInfinite d          = text "INFINITY"
+                  | isNaN d               = text "NAN"
+                  | otherwise             = text (show d)
+                -- these constants come from <math.h>
+                -- see #1861
+
+    CmmVec {} -> panic "PprC printing vector literal"
+
+    CmmBlock bid       -> mkW_ <> pprCLabelAddr (infoTblLbl bid)
+    CmmHighStackMark   -> panic "PprC printing high stack mark"
+    CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl
+    CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
+    CmmLabelDiffOff clbl1 _ i _   -- non-word widths not supported via C
+        -- WARNING:
+        --  * the lit must occur in the info table clbl2
+        --  * clbl1 must be an SRT, a slow entry point or a large bitmap
+        -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
+
+    where
+        pprCLabelAddr lbl = char '&' <> ppr lbl
+
+pprLit1 :: CmmLit -> SDoc
+pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmLabelDiffOff _ _ _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmFloat _ _)    = parens (pprLit lit)
+pprLit1 other = pprLit other
+
+-- ---------------------------------------------------------------------------
+-- Static data
+
+pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]
+pprStatics _ [] = []
+pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest)
+  -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding
+  | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
+  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest'
+  -- adjacent floats aren't padded but combined into a single word
+  | wORD_SIZE dflags == 8, CmmStaticLit (CmmFloat g W32) : rest' <- rest
+  = pprLit1 (floatPairToWord dflags f g) : pprStatics dflags rest'
+  | wORD_SIZE dflags == 4
+  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest
+  | otherwise
+  = pprPanic "pprStatics: float" (vcat (map ppr' rest))
+    where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags ->
+                                  ppr (cmmLitType dflags l)
+          ppr' _other           = text "bad static!"
+pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest)
+  = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest
+
+pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest)
+  | wordWidth dflags == W32
+  = if wORDS_BIGENDIAN dflags
+    then pprStatics dflags (CmmStaticLit (CmmInt q W32) :
+                            CmmStaticLit (CmmInt r W32) : rest)
+    else pprStatics dflags (CmmStaticLit (CmmInt r W32) :
+                            CmmStaticLit (CmmInt q W32) : rest)
+  where r = i .&. 0xffffffff
+        q = i `shiftR` 32
+pprStatics dflags (CmmStaticLit (CmmInt a W32) :
+                   CmmStaticLit (CmmInt b W32) : rest)
+  | wordWidth dflags == W64
+  = if wORDS_BIGENDIAN dflags
+    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) :
+                            rest)
+    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) :
+                            rest)
+pprStatics dflags (CmmStaticLit (CmmInt a W16) :
+                   CmmStaticLit (CmmInt b W16) : rest)
+  | wordWidth dflags == W32
+  = if wORDS_BIGENDIAN dflags
+    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) :
+                            rest)
+    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) :
+                            rest)
+pprStatics dflags (CmmStaticLit (CmmInt _ w) : _)
+  | w /= wordWidth dflags
+  = pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w)
+pprStatics dflags (CmmStaticLit lit : rest)
+  = pprLit1 lit : pprStatics dflags rest
+pprStatics _ (other : _)
+  = pprPanic "pprStatics: other" (pprStatic other)
+
+pprStatic :: CmmStatic -> SDoc
+pprStatic s = case s of
+
+    CmmStaticLit lit   -> nest 4 (pprLit lit)
+    CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))
+
+    -- these should be inlined, like the old .hc
+    CmmString s'       -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))
+
+
+-- ---------------------------------------------------------------------------
+-- Block Ids
+
+pprBlockId :: BlockId -> SDoc
+pprBlockId b = char '_' <> ppr (getUnique b)
+
+-- --------------------------------------------------------------------------
+-- Print a MachOp in a way suitable for emitting via C.
+--
+
+pprMachOp_for_C :: MachOp -> SDoc
+
+pprMachOp_for_C mop = case mop of
+
+        -- Integer operations
+        MO_Add          _ -> char '+'
+        MO_Sub          _ -> char '-'
+        MO_Eq           _ -> text "=="
+        MO_Ne           _ -> text "!="
+        MO_Mul          _ -> char '*'
+
+        MO_S_Quot       _ -> char '/'
+        MO_S_Rem        _ -> char '%'
+        MO_S_Neg        _ -> char '-'
+
+        MO_U_Quot       _ -> char '/'
+        MO_U_Rem        _ -> char '%'
+
+        -- & Floating-point operations
+        MO_F_Add        _ -> char '+'
+        MO_F_Sub        _ -> char '-'
+        MO_F_Neg        _ -> char '-'
+        MO_F_Mul        _ -> char '*'
+        MO_F_Quot       _ -> char '/'
+
+        -- Signed comparisons
+        MO_S_Ge         _ -> text ">="
+        MO_S_Le         _ -> text "<="
+        MO_S_Gt         _ -> char '>'
+        MO_S_Lt         _ -> char '<'
+
+        -- & Unsigned comparisons
+        MO_U_Ge         _ -> text ">="
+        MO_U_Le         _ -> text "<="
+        MO_U_Gt         _ -> char '>'
+        MO_U_Lt         _ -> char '<'
+
+        -- & Floating-point comparisons
+        MO_F_Eq         _ -> text "=="
+        MO_F_Ne         _ -> text "!="
+        MO_F_Ge         _ -> text ">="
+        MO_F_Le         _ -> text "<="
+        MO_F_Gt         _ -> char '>'
+        MO_F_Lt         _ -> char '<'
+
+        -- Bitwise operations.  Not all of these may be supported at all
+        -- sizes, and only integral MachReps are valid.
+        MO_And          _ -> char '&'
+        MO_Or           _ -> char '|'
+        MO_Xor          _ -> char '^'
+        MO_Not          _ -> char '~'
+        MO_Shl          _ -> text "<<"
+        MO_U_Shr        _ -> text ">>" -- unsigned shift right
+        MO_S_Shr        _ -> text ">>" -- signed shift right
+
+-- Conversions.  Some of these will be NOPs, but never those that convert
+-- between ints and floats.
+-- Floating-point conversions use the signed variant.
+-- We won't know to generate (void*) casts here, but maybe from
+-- context elsewhere
+
+-- noop casts
+        MO_UU_Conv from to | from == to -> empty
+        MO_UU_Conv _from to -> parens (machRep_U_CType to)
+
+        MO_SS_Conv from to | from == to -> empty
+        MO_SS_Conv _from to -> parens (machRep_S_CType to)
+
+        MO_XX_Conv from to | from == to -> empty
+        MO_XX_Conv _from to -> parens (machRep_U_CType to)
+
+        MO_FF_Conv from to | from == to -> empty
+        MO_FF_Conv _from to -> parens (machRep_F_CType to)
+
+        MO_SF_Conv _from to -> parens (machRep_F_CType to)
+        MO_FS_Conv _from to -> parens (machRep_S_CType to)
+
+        MO_S_MulMayOflo _ -> pprTrace "offending mop:"
+                                (text "MO_S_MulMayOflo")
+                                (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"
+                                      ++ " should have been handled earlier!")
+        MO_U_MulMayOflo _ -> pprTrace "offending mop:"
+                                (text "MO_U_MulMayOflo")
+                                (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo"
+                                      ++ " should have been handled earlier!")
+
+        MO_V_Insert {}    -> pprTrace "offending mop:"
+                                (text "MO_V_Insert")
+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Insert"
+                                      ++ " should have been handled earlier!")
+        MO_V_Extract {}   -> pprTrace "offending mop:"
+                                (text "MO_V_Extract")
+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Extract"
+                                      ++ " should have been handled earlier!")
+
+        MO_V_Add {}       -> pprTrace "offending mop:"
+                                (text "MO_V_Add")
+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Add"
+                                      ++ " should have been handled earlier!")
+        MO_V_Sub {}       -> pprTrace "offending mop:"
+                                (text "MO_V_Sub")
+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Sub"
+                                      ++ " should have been handled earlier!")
+        MO_V_Mul {}       -> pprTrace "offending mop:"
+                                (text "MO_V_Mul")
+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Mul"
+                                      ++ " should have been handled earlier!")
+
+        MO_VS_Quot {}     -> pprTrace "offending mop:"
+                                (text "MO_VS_Quot")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot"
+                                      ++ " should have been handled earlier!")
+        MO_VS_Rem {}      -> pprTrace "offending mop:"
+                                (text "MO_VS_Rem")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem"
+                                      ++ " should have been handled earlier!")
+        MO_VS_Neg {}      -> pprTrace "offending mop:"
+                                (text "MO_VS_Neg")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg"
+                                      ++ " should have been handled earlier!")
+
+        MO_VU_Quot {}     -> pprTrace "offending mop:"
+                                (text "MO_VU_Quot")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot"
+                                      ++ " should have been handled earlier!")
+        MO_VU_Rem {}      -> pprTrace "offending mop:"
+                                (text "MO_VU_Rem")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem"
+                                      ++ " should have been handled earlier!")
+
+        MO_VF_Insert {}   -> pprTrace "offending mop:"
+                                (text "MO_VF_Insert")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert"
+                                      ++ " should have been handled earlier!")
+        MO_VF_Extract {}  -> pprTrace "offending mop:"
+                                (text "MO_VF_Extract")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract"
+                                      ++ " should have been handled earlier!")
+
+        MO_VF_Add {}      -> pprTrace "offending mop:"
+                                (text "MO_VF_Add")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Add"
+                                      ++ " should have been handled earlier!")
+        MO_VF_Sub {}      -> pprTrace "offending mop:"
+                                (text "MO_VF_Sub")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub"
+                                      ++ " should have been handled earlier!")
+        MO_VF_Neg {}      -> pprTrace "offending mop:"
+                                (text "MO_VF_Neg")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg"
+                                      ++ " should have been handled earlier!")
+        MO_VF_Mul {}      -> pprTrace "offending mop:"
+                                (text "MO_VF_Mul")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul"
+                                      ++ " should have been handled earlier!")
+        MO_VF_Quot {}     -> pprTrace "offending mop:"
+                                (text "MO_VF_Quot")
+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"
+                                      ++ " should have been handled earlier!")
+
+        MO_AlignmentCheck {} -> panic "-falignment-santisation not supported by unregisterised backend"
+
+signedOp :: MachOp -> Bool      -- Argument type(s) are signed ints
+signedOp (MO_S_Quot _)    = True
+signedOp (MO_S_Rem  _)    = True
+signedOp (MO_S_Neg  _)    = True
+signedOp (MO_S_Ge   _)    = True
+signedOp (MO_S_Le   _)    = True
+signedOp (MO_S_Gt   _)    = True
+signedOp (MO_S_Lt   _)    = True
+signedOp (MO_S_Shr  _)    = True
+signedOp (MO_SS_Conv _ _) = True
+signedOp (MO_SF_Conv _ _) = True
+signedOp _                = False
+
+floatComparison :: MachOp -> Bool  -- comparison between float args
+floatComparison (MO_F_Eq   _) = True
+floatComparison (MO_F_Ne   _) = True
+floatComparison (MO_F_Ge   _) = True
+floatComparison (MO_F_Le   _) = True
+floatComparison (MO_F_Gt   _) = True
+floatComparison (MO_F_Lt   _) = True
+floatComparison _             = False
+
+-- ---------------------------------------------------------------------
+-- tend to be implemented by foreign calls
+
+pprCallishMachOp_for_C :: CallishMachOp -> SDoc
+
+pprCallishMachOp_for_C mop
+    = case mop of
+        MO_F64_Pwr      -> text "pow"
+        MO_F64_Sin      -> text "sin"
+        MO_F64_Cos      -> text "cos"
+        MO_F64_Tan      -> text "tan"
+        MO_F64_Sinh     -> text "sinh"
+        MO_F64_Cosh     -> text "cosh"
+        MO_F64_Tanh     -> text "tanh"
+        MO_F64_Asin     -> text "asin"
+        MO_F64_Acos     -> text "acos"
+        MO_F64_Atanh    -> text "atanh"
+        MO_F64_Asinh    -> text "asinh"
+        MO_F64_Acosh    -> text "acosh"
+        MO_F64_Atan     -> text "atan"
+        MO_F64_Log      -> text "log"
+        MO_F64_Exp      -> text "exp"
+        MO_F64_Sqrt     -> text "sqrt"
+        MO_F64_Fabs     -> text "fabs"
+        MO_F32_Pwr      -> text "powf"
+        MO_F32_Sin      -> text "sinf"
+        MO_F32_Cos      -> text "cosf"
+        MO_F32_Tan      -> text "tanf"
+        MO_F32_Sinh     -> text "sinhf"
+        MO_F32_Cosh     -> text "coshf"
+        MO_F32_Tanh     -> text "tanhf"
+        MO_F32_Asin     -> text "asinf"
+        MO_F32_Acos     -> text "acosf"
+        MO_F32_Atan     -> text "atanf"
+        MO_F32_Asinh    -> text "asinhf"
+        MO_F32_Acosh    -> text "acoshf"
+        MO_F32_Atanh    -> text "atanhf"
+        MO_F32_Log      -> text "logf"
+        MO_F32_Exp      -> text "expf"
+        MO_F32_Sqrt     -> text "sqrtf"
+        MO_F32_Fabs     -> text "fabsf"
+        MO_WriteBarrier -> text "write_barrier"
+        MO_Memcpy _     -> text "memcpy"
+        MO_Memset _     -> text "memset"
+        MO_Memmove _    -> text "memmove"
+        MO_Memcmp _     -> text "memcmp"
+        (MO_BSwap w)    -> ptext (sLit $ bSwapLabel w)
+        (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)
+        (MO_Pext w)     -> ptext (sLit $ pextLabel w)
+        (MO_Pdep w)     -> ptext (sLit $ pdepLabel w)
+        (MO_Clz w)      -> ptext (sLit $ clzLabel w)
+        (MO_Ctz w)      -> ptext (sLit $ ctzLabel w)
+        (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)
+        (MO_Cmpxchg w)  -> ptext (sLit $ cmpxchgLabel w)
+        (MO_AtomicRead w)  -> ptext (sLit $ atomicReadLabel w)
+        (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)
+        (MO_UF_Conv w)  -> ptext (sLit $ word2FloatLabel w)
+
+        MO_S_QuotRem  {} -> unsupported
+        MO_U_QuotRem  {} -> unsupported
+        MO_U_QuotRem2 {} -> unsupported
+        MO_Add2       {} -> unsupported
+        MO_AddWordC   {} -> unsupported
+        MO_SubWordC   {} -> unsupported
+        MO_AddIntC    {} -> unsupported
+        MO_SubIntC    {} -> unsupported
+        MO_U_Mul2     {} -> unsupported
+        MO_Touch         -> unsupported
+        (MO_Prefetch_Data _ ) -> unsupported
+        --- we could support prefetch via "__builtin_prefetch"
+        --- Not adding it for now
+    where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop
+                            ++ " not supported!")
+
+-- ---------------------------------------------------------------------
+-- Useful #defines
+--
+
+mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc
+
+mkJMP_ i = text "JMP_" <> parens i
+mkFN_  i = text "FN_"  <> parens i -- externally visible function
+mkIF_  i = text "IF_"  <> parens i -- locally visible
+
+-- from includes/Stg.h
+--
+mkC_,mkW_,mkP_ :: SDoc
+
+mkC_  = text "(C_)"        -- StgChar
+mkW_  = text "(W_)"        -- StgWord
+mkP_  = text "(P_)"        -- StgWord*
+
+-- ---------------------------------------------------------------------
+--
+-- Assignments
+--
+-- Generating assignments is what we're all about, here
+--
+pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc
+
+-- dest is a reg, rhs is a reg
+pprAssign _ r1 (CmmReg r2)
+   | isPtrReg r1 && isPtrReg r2
+   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]
+
+-- dest is a reg, rhs is a CmmRegOff
+pprAssign dflags r1 (CmmRegOff r2 off)
+   | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0)
+   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
+  where
+        off1 = off `shiftR` wordShift dflags
+
+        (op,off') | off >= 0  = (char '+', off1)
+                  | otherwise = (char '-', -off1)
+
+-- dest is a reg, rhs is anything.
+-- We can't cast the lvalue, so we have to cast the rhs if necessary.  Casting
+-- the lvalue elicits a warning from new GCC versions (3.4+).
+pprAssign _ r1 r2
+  | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 r2)
+  | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)
+  | otherwise                    = mkAssign (pprExpr r2)
+    where mkAssign x = if r1 == CmmGlobal BaseReg
+                       then text "ASSIGN_BaseReg" <> parens x <> semi
+                       else pprReg r1 <> text " = " <> x <> semi
+
+-- ---------------------------------------------------------------------
+-- Registers
+
+pprCastReg :: CmmReg -> SDoc
+pprCastReg reg
+   | isStrangeTypeReg reg = mkW_ <> pprReg reg
+   | otherwise            = pprReg reg
+
+-- True if (pprReg reg) will give an expression with type StgPtr.  We
+-- need to take care with pointer arithmetic on registers with type
+-- StgPtr.
+isFixedPtrReg :: CmmReg -> Bool
+isFixedPtrReg (CmmLocal _) = False
+isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r
+
+-- True if (pprAsPtrReg reg) will give an expression with type StgPtr
+-- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST.
+-- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT;
+-- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY.
+isPtrReg :: CmmReg -> Bool
+isPtrReg (CmmLocal _)                         = False
+isPtrReg (CmmGlobal (VanillaReg _ VGcPtr))    = True  -- if we print via pprAsPtrReg
+isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg
+isPtrReg (CmmGlobal reg)                      = isFixedPtrGlobalReg reg
+
+-- True if this global reg has type StgPtr
+isFixedPtrGlobalReg :: GlobalReg -> Bool
+isFixedPtrGlobalReg Sp    = True
+isFixedPtrGlobalReg Hp    = True
+isFixedPtrGlobalReg HpLim = True
+isFixedPtrGlobalReg SpLim = True
+isFixedPtrGlobalReg _     = False
+
+-- True if in C this register doesn't have the type given by
+-- (machRepCType (cmmRegType reg)), so it has to be cast.
+isStrangeTypeReg :: CmmReg -> Bool
+isStrangeTypeReg (CmmLocal _)   = False
+isStrangeTypeReg (CmmGlobal g)  = isStrangeTypeGlobal g
+
+isStrangeTypeGlobal :: GlobalReg -> Bool
+isStrangeTypeGlobal CCCS                = True
+isStrangeTypeGlobal CurrentTSO          = True
+isStrangeTypeGlobal CurrentNursery      = True
+isStrangeTypeGlobal BaseReg             = True
+isStrangeTypeGlobal r                   = isFixedPtrGlobalReg r
+
+strangeRegType :: CmmReg -> Maybe SDoc
+strangeRegType (CmmGlobal CCCS) = Just (text "struct CostCentreStack_ *")
+strangeRegType (CmmGlobal CurrentTSO) = Just (text "struct StgTSO_ *")
+strangeRegType (CmmGlobal CurrentNursery) = Just (text "struct bdescr_ *")
+strangeRegType (CmmGlobal BaseReg) = Just (text "struct StgRegTable_ *")
+strangeRegType _ = Nothing
+
+-- pprReg just prints the register name.
+--
+pprReg :: CmmReg -> SDoc
+pprReg r = case r of
+        CmmLocal  local  -> pprLocalReg local
+        CmmGlobal global -> pprGlobalReg global
+
+pprAsPtrReg :: CmmReg -> SDoc
+pprAsPtrReg (CmmGlobal (VanillaReg n gcp))
+  = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> text ".p"
+pprAsPtrReg other_reg = pprReg other_reg
+
+pprGlobalReg :: GlobalReg -> SDoc
+pprGlobalReg gr = case gr of
+    VanillaReg n _ -> char 'R' <> int n  <> text ".w"
+        -- pprGlobalReg prints a VanillaReg as a .w regardless
+        -- Example:     R1.w = R1.w & (-0x8UL);
+        --              JMP_(*R1.p);
+    FloatReg   n   -> char 'F' <> int n
+    DoubleReg  n   -> char 'D' <> int n
+    LongReg    n   -> char 'L' <> int n
+    Sp             -> text "Sp"
+    SpLim          -> text "SpLim"
+    Hp             -> text "Hp"
+    HpLim          -> text "HpLim"
+    CCCS           -> text "CCCS"
+    CurrentTSO     -> text "CurrentTSO"
+    CurrentNursery -> text "CurrentNursery"
+    HpAlloc        -> text "HpAlloc"
+    BaseReg        -> text "BaseReg"
+    EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"
+    GCEnter1       -> text "stg_gc_enter_1"
+    GCFun          -> text "stg_gc_fun"
+    other          -> panic $ "pprGlobalReg: Unsupported register: " ++ show other
+
+pprLocalReg :: LocalReg -> SDoc
+pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
+
+-- -----------------------------------------------------------------------------
+-- Foreign Calls
+
+pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
+pprCall ppr_fn cconv results args
+  | not (is_cishCC cconv)
+  = panic $ "pprCall: unknown calling convention"
+
+  | otherwise
+  =
+    ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
+  where
+     ppr_assign []           rhs = rhs
+     ppr_assign [(one,hint)] rhs
+         = pprLocalReg one <> text " = "
+                 <> pprUnHint hint (localRegType one) <> rhs
+     ppr_assign _other _rhs = panic "pprCall: multiple results"
+
+     pprArg (expr, AddrHint)
+        = cCast (text "void *") expr
+        -- see comment by machRepHintCType below
+     pprArg (expr, SignedHint)
+        = sdocWithDynFlags $ \dflags ->
+          cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr
+     pprArg (expr, _other)
+        = pprExpr expr
+
+     pprUnHint AddrHint   rep = parens (machRepCType rep)
+     pprUnHint SignedHint rep = parens (machRepCType rep)
+     pprUnHint _          _   = empty
+
+-- Currently we only have these two calling conventions, but this might
+-- change in the future...
+is_cishCC :: CCallConv -> Bool
+is_cishCC CCallConv    = True
+is_cishCC CApiConv     = True
+is_cishCC StdCallConv  = True
+is_cishCC PrimCallConv = False
+is_cishCC JavaScriptCallConv = False
+
+-- ---------------------------------------------------------------------
+-- Find and print local and external declarations for a list of
+-- Cmm statements.
+--
+pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})
+pprTempAndExternDecls stmts
+  = (pprUFM (getUniqSet temps) (vcat . map pprTempDecl),
+     vcat (map pprExternDecl (Map.keys lbls)))
+  where (temps, lbls) = runTE (mapM_ te_BB stmts)
+
+pprDataExterns :: [CmmStatic] -> SDoc
+pprDataExterns statics
+  = vcat (map pprExternDecl (Map.keys lbls))
+  where (_, lbls) = runTE (mapM_ te_Static statics)
+
+pprTempDecl :: LocalReg -> SDoc
+pprTempDecl l@(LocalReg _ rep)
+  = hcat [ machRepCType rep, space, pprLocalReg l, semi ]
+
+pprExternDecl :: CLabel -> SDoc
+pprExternDecl lbl
+  -- do not print anything for "known external" things
+  | not (needsCDecl lbl) = empty
+  | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
+  | otherwise =
+        hcat [ visibility, label_type lbl , lparen, ppr lbl, text ");"
+             -- occasionally useful to see label type
+             -- , text "/* ", pprDebugCLabel lbl, text " */"
+             ]
+ where
+  label_type lbl | isBytesLabel lbl         = text "B_"
+                 | isForeignLabel lbl && isCFunctionLabel lbl
+                                            = text "FF_"
+                 | isCFunctionLabel lbl     = text "F_"
+                 | isStaticClosureLabel lbl = text "C_"
+                 -- generic .rodata labels
+                 | isSomeRODataLabel lbl    = text "RO_"
+                 -- generic .data labels (common case)
+                 | otherwise                = text "RW_"
+
+  visibility
+     | externallyVisibleCLabel lbl = char 'E'
+     | otherwise                   = char 'I'
+
+  -- If the label we want to refer to is a stdcall function (on Windows) then
+  -- we must generate an appropriate prototype for it, so that the C compiler will
+  -- add the @n suffix to the label (#2276)
+  stdcall_decl sz = sdocWithDynFlags $ \dflags ->
+        text "extern __attribute__((stdcall)) void " <> ppr lbl
+        <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags))))
+        <> semi
+
+type TEState = (UniqSet LocalReg, Map CLabel ())
+newtype TE a = TE { unTE :: TEState -> (a, TEState) }
+
+instance Functor TE where
+      fmap = liftM
+
+instance Applicative TE where
+      pure a = TE $ \s -> (a, s)
+      (<*>) = ap
+
+instance Monad TE where
+   TE m >>= k  = TE $ \s -> case m s of (a, s') -> unTE (k a) s'
+
+te_lbl :: CLabel -> TE ()
+te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls))
+
+te_temp :: LocalReg -> TE ()
+te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))
+
+runTE :: TE () -> TEState
+runTE (TE m) = snd (m (emptyUniqSet, Map.empty))
+
+te_Static :: CmmStatic -> TE ()
+te_Static (CmmStaticLit lit) = te_Lit lit
+te_Static _ = return ()
+
+te_BB :: CmmBlock -> TE ()
+te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last
+  where (_, mid, last) = blockSplit block
+
+te_Lit :: CmmLit -> TE ()
+te_Lit (CmmLabel l) = te_lbl l
+te_Lit (CmmLabelOff l _) = te_lbl l
+te_Lit (CmmLabelDiffOff l1 _ _ _) = te_lbl l1
+te_Lit _ = return ()
+
+te_Stmt :: CmmNode e x -> TE ()
+te_Stmt (CmmAssign r e)         = te_Reg r >> te_Expr e
+te_Stmt (CmmStore l r)          = te_Expr l >> te_Expr r
+te_Stmt (CmmUnsafeForeignCall target rs es)
+  = do  te_Target target
+        mapM_ te_temp rs
+        mapM_ te_Expr es
+te_Stmt (CmmCondBranch e _ _ _) = te_Expr e
+te_Stmt (CmmSwitch e _)         = te_Expr e
+te_Stmt (CmmCall { cml_target = e }) = te_Expr e
+te_Stmt _                       = return ()
+
+te_Target :: ForeignTarget -> TE ()
+te_Target (ForeignTarget e _)      = te_Expr e
+te_Target (PrimTarget{})           = return ()
+
+te_Expr :: CmmExpr -> TE ()
+te_Expr (CmmLit lit)            = te_Lit lit
+te_Expr (CmmLoad e _)           = te_Expr e
+te_Expr (CmmReg r)              = te_Reg r
+te_Expr (CmmMachOp _ es)        = mapM_ te_Expr es
+te_Expr (CmmRegOff r _)         = te_Reg r
+te_Expr (CmmStackSlot _ _)      = panic "te_Expr: CmmStackSlot not supported!"
+
+te_Reg :: CmmReg -> TE ()
+te_Reg (CmmLocal l) = te_temp l
+te_Reg _            = return ()
+
+
+-- ---------------------------------------------------------------------
+-- C types for MachReps
+
+cCast :: SDoc -> CmmExpr -> SDoc
+cCast ty expr = parens ty <> pprExpr1 expr
+
+cLoad :: CmmExpr -> CmmType -> SDoc
+cLoad expr rep
+    = sdocWithPlatform $ \platform ->
+      if bewareLoadStoreAlignment (platformArch platform)
+      then let decl = machRepCType rep <+> text "x" <> semi
+               struct = text "struct" <+> braces (decl)
+               packed_attr = text "__attribute__((packed))"
+               cast = parens (struct <+> packed_attr <> char '*')
+           in parens (cast <+> pprExpr1 expr) <> text "->x"
+      else char '*' <> parens (cCast (machRepPtrCType rep) expr)
+    where -- On these platforms, unaligned loads are known to cause problems
+          bewareLoadStoreAlignment ArchAlpha    = True
+          bewareLoadStoreAlignment ArchMipseb   = True
+          bewareLoadStoreAlignment ArchMipsel   = True
+          bewareLoadStoreAlignment (ArchARM {}) = True
+          bewareLoadStoreAlignment ArchARM64    = True
+          bewareLoadStoreAlignment ArchSPARC    = True
+          bewareLoadStoreAlignment ArchSPARC64  = True
+          -- Pessimistically assume that they will also cause problems
+          -- on unknown arches
+          bewareLoadStoreAlignment ArchUnknown  = True
+          bewareLoadStoreAlignment _            = False
+
+isCmmWordType :: DynFlags -> CmmType -> Bool
+-- True of GcPtrReg/NonGcReg of native word size
+isCmmWordType dflags ty = not (isFloatType ty)
+                       && typeWidth ty == wordWidth dflags
+
+-- This is for finding the types of foreign call arguments.  For a pointer
+-- argument, we always cast the argument to (void *), to avoid warnings from
+-- the C compiler.
+machRepHintCType :: CmmType -> ForeignHint -> SDoc
+machRepHintCType _   AddrHint   = text "void *"
+machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)
+machRepHintCType rep _other     = machRepCType rep
+
+machRepPtrCType :: CmmType -> SDoc
+machRepPtrCType r
+ = sdocWithDynFlags $ \dflags ->
+   if isCmmWordType dflags r then text "P_"
+                             else machRepCType r <> char '*'
+
+machRepCType :: CmmType -> SDoc
+machRepCType ty | isFloatType ty = machRep_F_CType w
+                | otherwise      = machRep_U_CType w
+                where
+                  w = typeWidth ty
+
+machRep_F_CType :: Width -> SDoc
+machRep_F_CType W32 = text "StgFloat" -- ToDo: correct?
+machRep_F_CType W64 = text "StgDouble"
+machRep_F_CType _   = panic "machRep_F_CType"
+
+machRep_U_CType :: Width -> SDoc
+machRep_U_CType w
+ = sdocWithDynFlags $ \dflags ->
+   case w of
+   _ | w == wordWidth dflags -> text "W_"
+   W8  -> text "StgWord8"
+   W16 -> text "StgWord16"
+   W32 -> text "StgWord32"
+   W64 -> text "StgWord64"
+   _   -> panic "machRep_U_CType"
+
+machRep_S_CType :: Width -> SDoc
+machRep_S_CType w
+ = sdocWithDynFlags $ \dflags ->
+   case w of
+   _ | w == wordWidth dflags -> text "I_"
+   W8  -> text "StgInt8"
+   W16 -> text "StgInt16"
+   W32 -> text "StgInt32"
+   W64 -> text "StgInt64"
+   _   -> panic "machRep_S_CType"
+
+
+-- ---------------------------------------------------------------------
+-- print strings as valid C strings
+
+pprStringInCStyle :: [Word8] -> SDoc
+pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
+
+-- ---------------------------------------------------------------------------
+-- Initialising static objects with floating-point numbers.  We can't
+-- just emit the floating point number, because C will cast it to an int
+-- by rounding it.  We want the actual bit-representation of the float.
+--
+-- Consider a concrete C example:
+--    double d = 2.5e-10;
+--    float f  = 2.5e-10f;
+--
+--    int * i2 = &d;      printf ("i2: %08X %08X\n", i2[0], i2[1]);
+--    long long * l = &d; printf (" l: %016llX\n",   l[0]);
+--    int * i = &f;       printf (" i: %08X\n",      i[0]);
+-- Result on 64-bit LE (x86_64):
+--     i2: E826D695 3DF12E0B
+--      l: 3DF12E0BE826D695
+--      i: 2F89705F
+-- Result on 32-bit BE (m68k):
+--     i2: 3DF12E0B E826D695
+--      l: 3DF12E0BE826D695
+--      i: 2F89705F
+--
+-- The trick here is to notice that binary representation does not
+-- change much: only Word32 values get swapped on LE hosts / targets.
+
+-- This is a hack to turn the floating point numbers into ints that we
+-- can safely initialise to static locations.
+
+castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)
+castFloatToWord32Array = U.castSTUArray
+
+castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)
+castDoubleToWord64Array = U.castSTUArray
+
+floatToWord :: DynFlags -> Rational -> CmmLit
+floatToWord dflags r
+  = runST (do
+        arr <- newArray_ ((0::Int),0)
+        writeArray arr 0 (fromRational r)
+        arr' <- castFloatToWord32Array arr
+        w32 <- readArray arr' 0
+        return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth dflags))
+    )
+    where wo | wordWidth dflags == W64
+             , wORDS_BIGENDIAN dflags    = 32
+             | otherwise                 = 0
+
+floatPairToWord :: DynFlags -> Rational -> Rational -> CmmLit
+floatPairToWord dflags r1 r2
+  = runST (do
+        arr <- newArray_ ((0::Int),1)
+        writeArray arr 0 (fromRational r1)
+        writeArray arr 1 (fromRational r2)
+        arr' <- castFloatToWord32Array arr
+        w32_1 <- readArray arr' 0
+        w32_2 <- readArray arr' 1
+        return (pprWord32Pair w32_1 w32_2)
+    )
+    where pprWord32Pair w32_1 w32_2
+              | wORDS_BIGENDIAN dflags =
+                  CmmInt ((shiftL i1 32) .|. i2) W64
+              | otherwise =
+                  CmmInt ((shiftL i2 32) .|. i1) W64
+              where i1 = toInteger w32_1
+                    i2 = toInteger w32_2
+
+doubleToWords :: DynFlags -> Rational -> [CmmLit]
+doubleToWords dflags r
+  = runST (do
+        arr <- newArray_ ((0::Int),1)
+        writeArray arr 0 (fromRational r)
+        arr' <- castDoubleToWord64Array arr
+        w64 <- readArray arr' 0
+        return (pprWord64 w64)
+    )
+    where targetWidth = wordWidth dflags
+          targetBE    = wORDS_BIGENDIAN dflags
+          pprWord64 w64
+              | targetWidth == W64 =
+                  [ CmmInt (toInteger w64) targetWidth ]
+              | targetWidth == W32 =
+                  [ CmmInt (toInteger targetW1) targetWidth
+                  , CmmInt (toInteger targetW2) targetWidth
+                  ]
+              | otherwise = panic "doubleToWords.pprWord64"
+              where (targetW1, targetW2)
+                        | targetBE  = (wHi, wLo)
+                        | otherwise = (wLo, wHi)
+                    wHi = w64 `shiftR` 32
+                    wLo = w64 .&. 0xFFFFffff
+
+-- ---------------------------------------------------------------------------
+-- Utils
+
+wordShift :: DynFlags -> Int
+wordShift dflags = widthInLog (wordWidth dflags)
+
+commafy :: [SDoc] -> SDoc
+commafy xs = hsep $ punctuate comma xs
+
+-- Print in C hex format: 0x13fa
+pprHexVal :: Integer -> Width -> SDoc
+pprHexVal w rep
+  | w < 0     = parens (char '-' <>
+                    text "0x" <> intToDoc (-w) <> repsuffix rep)
+  | otherwise =     text "0x" <> intToDoc   w  <> repsuffix rep
+  where
+        -- type suffix for literals:
+        -- Integer literals are unsigned in Cmm/C.  We explicitly cast to
+        -- signed values for doing signed operations, but at all other
+        -- times values are unsigned.  This also helps eliminate occasional
+        -- warnings about integer overflow from gcc.
+
+      repsuffix W64 = sdocWithDynFlags $ \dflags ->
+               if cINT_SIZE       dflags == 8 then char 'U'
+          else if cLONG_SIZE      dflags == 8 then text "UL"
+          else if cLONG_LONG_SIZE dflags == 8 then text "ULL"
+          else panic "pprHexVal: Can't find a 64-bit type"
+      repsuffix _ = char 'U'
+
+      intToDoc :: Integer -> SDoc
+      intToDoc i = case truncInt i of
+                       0 -> char '0'
+                       v -> go v
+
+      -- We need to truncate value as Cmm backend does not drop
+      -- redundant bits to ease handling of negative values.
+      -- Thus the following Cmm code on 64-bit arch, like amd64:
+      --     CInt v;
+      --     v = {something};
+      --     if (v == %lobits32(-1)) { ...
+      -- leads to the following C code:
+      --     StgWord64 v = (StgWord32)({something});
+      --     if (v == 0xFFFFffffFFFFffffU) { ...
+      -- Such code is incorrect as it promotes both operands to StgWord64
+      -- and the whole condition is always false.
+      truncInt :: Integer -> Integer
+      truncInt i =
+          case rep of
+              W8  -> i `rem` (2^(8 :: Int))
+              W16 -> i `rem` (2^(16 :: Int))
+              W32 -> i `rem` (2^(32 :: Int))
+              W64 -> i `rem` (2^(64 :: Int))
+              _   -> panic ("pprHexVal/truncInt: C backend can't encode "
+                            ++ show rep ++ " literals")
+
+      go 0 = empty
+      go w' = go q <> dig
+           where
+             (q,r) = w' `quotRem` 16
+             dig | r < 10    = char (chr (fromInteger r + ord '0'))
+                 | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/PprCmm.hs
@@ -0,0 +1,311 @@
+{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+----------------------------------------------------------------------------
+--
+-- Pretty-printing of Cmm as (a superset of) C--
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+--
+-- This is where we walk over CmmNode emitting an external representation,
+-- suitable for parsing, in a syntax strongly reminiscent of C--. This
+-- is the "External Core" for the Cmm layer.
+--
+-- As such, this should be a well-defined syntax: we want it to look nice.
+-- Thus, we try wherever possible to use syntax defined in [1],
+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- than C--'s bits8 .. bits64.
+--
+-- We try to ensure that all information available in the abstract
+-- syntax is reproduced, or reproducible, in the concrete syntax.
+-- Data that is not in printed out can be reconstructed according to
+-- conventions used in the pretty printer. There are at least two such
+-- cases:
+--      1) if a value has wordRep type, the type is not appended in the
+--      output.
+--      2) MachOps that operate over wordRep type are printed in a
+--      C-style, rather than as their internal MachRep name.
+--
+-- These conventions produce much more readable Cmm output.
+--
+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
+
+module PprCmm
+  ( module PprCmmDecl
+  , module PprCmmExpr
+  )
+where
+
+import GhcPrelude hiding (succ)
+
+import BlockId ()
+import CLabel
+import Cmm
+import CmmUtils
+import CmmSwitch
+import DynFlags
+import FastString
+import Outputable
+import PprCmmDecl
+import PprCmmExpr
+import Util
+import PprCore ()
+
+import BasicTypes
+import Hoopl.Block
+import Hoopl.Graph
+
+-------------------------------------------------
+-- Outputable instances
+
+instance Outputable CmmStackInfo where
+    ppr = pprStackInfo
+
+instance Outputable CmmTopInfo where
+    ppr = pprTopInfo
+
+
+instance Outputable (CmmNode e x) where
+    ppr = pprNode
+
+instance Outputable Convention where
+    ppr = pprConvention
+
+instance Outputable ForeignConvention where
+    ppr = pprForeignConvention
+
+instance Outputable ForeignTarget where
+    ppr = pprForeignTarget
+
+instance Outputable CmmReturnInfo where
+    ppr = pprReturnInfo
+
+instance Outputable (Block CmmNode C C) where
+    ppr = pprBlock
+instance Outputable (Block CmmNode C O) where
+    ppr = pprBlock
+instance Outputable (Block CmmNode O C) where
+    ppr = pprBlock
+instance Outputable (Block CmmNode O O) where
+    ppr = pprBlock
+
+instance Outputable (Graph CmmNode e x) where
+    ppr = pprGraph
+
+instance Outputable CmmGraph where
+    ppr = pprCmmGraph
+
+----------------------------------------------------------
+-- Outputting types Cmm contains
+
+pprStackInfo :: CmmStackInfo -> SDoc
+pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
+  text "arg_space: " <> ppr arg_space <+>
+  text "updfr_space: " <> ppr updfr_space
+
+pprTopInfo :: CmmTopInfo -> SDoc
+pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
+  vcat [text "info_tbls: " <> ppr info_tbl,
+        text "stack_info: " <> ppr stack_info]
+
+----------------------------------------------------------
+-- Outputting blocks and graphs
+
+pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
+         => Block CmmNode e x -> IndexedCO e SDoc SDoc
+pprBlock block
+    = foldBlockNodesB3 ( ($$) . ppr
+                       , ($$) . (nest 4) . ppr
+                       , ($$) . (nest 4) . ppr
+                       )
+                       block
+                       empty
+
+pprGraph :: Graph CmmNode e x -> SDoc
+pprGraph GNil = empty
+pprGraph (GUnit block) = ppr block
+pprGraph (GMany entry body exit)
+   = text "{"
+  $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
+  $$ text "}"
+  where pprMaybeO :: Outputable (Block CmmNode e x)
+                  => MaybeO ex (Block CmmNode e x) -> SDoc
+        pprMaybeO NothingO = empty
+        pprMaybeO (JustO block) = ppr block
+
+pprCmmGraph :: CmmGraph -> SDoc
+pprCmmGraph g
+   = text "{" <> text "offset"
+  $$ nest 2 (vcat $ map ppr blocks)
+  $$ text "}"
+  where blocks = revPostorder g
+    -- revPostorder has the side-effect of discarding unreachable code,
+    -- so pretty-printed Cmm will omit any unreachable blocks.  This can
+    -- sometimes be confusing.
+
+---------------------------------------------
+-- Outputting CmmNode and types which it contains
+
+pprConvention :: Convention -> SDoc
+pprConvention (NativeNodeCall   {}) = text "<native-node-call-convention>"
+pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
+pprConvention (NativeReturn {})     = text "<native-ret-convention>"
+pprConvention  Slow                 = text "<slow-convention>"
+pprConvention  GC                   = text "<gc-convention>"
+
+pprForeignConvention :: ForeignConvention -> SDoc
+pprForeignConvention (ForeignConvention c args res ret) =
+          doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
+
+pprReturnInfo :: CmmReturnInfo -> SDoc
+pprReturnInfo CmmMayReturn = empty
+pprReturnInfo CmmNeverReturns = text "never returns"
+
+pprForeignTarget :: ForeignTarget -> SDoc
+pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn
+  where
+        ppr_target :: CmmExpr -> SDoc
+        ppr_target t@(CmmLit _) = ppr t
+        ppr_target fn'          = parens (ppr fn')
+
+pprForeignTarget (PrimTarget op)
+ -- HACK: We're just using a ForeignLabel to get this printed, the label
+ --       might not really be foreign.
+ = ppr
+               (CmmLabel (mkForeignLabel
+                         (mkFastString (show op))
+                         Nothing ForeignLabelInThisPackage IsFunction))
+
+pprNode :: CmmNode e x -> SDoc
+pprNode node = pp_node <+> pp_debug
+  where
+    pp_node :: SDoc
+    pp_node = sdocWithDynFlags $ \dflags -> case node of
+      -- label:
+      CmmEntry id tscope -> lbl <> colon <+>
+         (sdocWithDynFlags $ \dflags ->
+           ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))
+          where
+            lbl = if gopt Opt_SuppressUniques dflags
+                then text "_lbl_"
+                else ppr id
+
+      -- // text
+      CmmComment s -> text "//" <+> ftext s
+
+      -- //tick bla<...>
+      CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $
+                   text "//tick" <+> ppr t
+
+      -- unwind reg = expr;
+      CmmUnwind regs ->
+          text "unwind "
+          <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi
+
+      -- reg = expr;
+      CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
+
+      -- rep[lv] = expr;
+      CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
+          where
+            rep = sdocWithDynFlags $ \dflags ->
+                  ppr ( cmmExprType dflags expr )
+
+      -- call "ccall" foo(x, y)[r1, r2];
+      -- ToDo ppr volatile
+      CmmUnsafeForeignCall target results args ->
+          hsep [ ppUnless (null results) $
+                    parens (commafy $ map ppr results) <+> equals,
+                 text "call",
+                 ppr target <> parens (commafy $ map ppr args) <> semi]
+
+      -- goto label;
+      CmmBranch ident -> text "goto" <+> ppr ident <> semi
+
+      -- if (expr) goto t; else goto f;
+      CmmCondBranch expr t f l ->
+          hsep [ text "if"
+               , parens(ppr expr)
+               , case l of
+                   Nothing -> empty
+                   Just b -> parens (text "likely:" <+> ppr b)
+               , text "goto"
+               , ppr t <> semi
+               , text "else goto"
+               , ppr f <> semi
+               ]
+
+      CmmSwitch expr ids ->
+          hang (hsep [ text "switch"
+                     , range
+                     , if isTrivialCmmExpr expr
+                       then ppr expr
+                       else parens (ppr expr)
+                     , text "{"
+                     ])
+             4 (vcat (map ppCase cases) $$ def) $$ rbrace
+          where
+            (cases, mbdef) = switchTargetsFallThrough ids
+            ppCase (is,l) = hsep
+                            [ text "case"
+                            , commafy $ map integer is
+                            , text ": goto"
+                            , ppr l <> semi
+                            ]
+            def | Just l <- mbdef = hsep
+                            [ text "default:"
+                            , braces (text "goto" <+> ppr l <> semi)
+                            ]
+                | otherwise = empty
+
+            range = brackets $ hsep [integer lo, text "..", integer hi]
+              where (lo,hi) = switchTargetsRange ids
+
+      CmmCall tgt k regs out res updfr_off ->
+          hcat [ text "call", space
+               , pprFun tgt, parens (interpp'SP regs), space
+               , returns <+>
+                 text "args: " <> ppr out <> comma <+>
+                 text "res: " <> ppr res <> comma <+>
+                 text "upd: " <> ppr updfr_off
+               , semi ]
+          where pprFun f@(CmmLit _) = ppr f
+                pprFun f = parens (ppr f)
+
+                returns
+                  | Just r <- k = text "returns to" <+> ppr r <> comma
+                  | otherwise   = empty
+
+      CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
+          hcat $ if i then [text "interruptible", space] else [] ++
+               [ text "foreign call", space
+               , ppr t, text "(...)", space
+               , text "returns to" <+> ppr s
+                    <+> text "args:" <+> parens (ppr as)
+                    <+> text "ress:" <+> parens (ppr rs)
+               , text "ret_args:" <+> ppr a
+               , text "ret_off:" <+> ppr u
+               , semi ]
+
+    pp_debug :: SDoc
+    pp_debug =
+      if not debugIsOn then empty
+      else case node of
+             CmmEntry {}             -> empty -- Looks terrible with text "  // CmmEntry"
+             CmmComment {}           -> empty -- Looks also terrible with text "  // CmmComment"
+             CmmTick {}              -> empty
+             CmmUnwind {}            -> text "  // CmmUnwind"
+             CmmAssign {}            -> text "  // CmmAssign"
+             CmmStore {}             -> text "  // CmmStore"
+             CmmUnsafeForeignCall {} -> text "  // CmmUnsafeForeignCall"
+             CmmBranch {}            -> text "  // CmmBranch"
+             CmmCondBranch {}        -> text "  // CmmCondBranch"
+             CmmSwitch {}            -> text "  // CmmSwitch"
+             CmmCall {}              -> text "  // CmmCall"
+             CmmForeignCall {}       -> text "  // CmmForeignCall"
+
+    commafy :: [SDoc] -> SDoc
+    commafy xs = hsep $ punctuate comma xs
diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/PprCmmDecl.hs
@@ -0,0 +1,170 @@
+----------------------------------------------------------------------------
+--
+-- Pretty-printing of common Cmm types
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+--
+-- This is where we walk over Cmm emitting an external representation,
+-- suitable for parsing, in a syntax strongly reminiscent of C--. This
+-- is the "External Core" for the Cmm layer.
+--
+-- As such, this should be a well-defined syntax: we want it to look nice.
+-- Thus, we try wherever possible to use syntax defined in [1],
+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- than C--'s bits8 .. bits64.
+--
+-- We try to ensure that all information available in the abstract
+-- syntax is reproduced, or reproducible, in the concrete syntax.
+-- Data that is not in printed out can be reconstructed according to
+-- conventions used in the pretty printer. There are at least two such
+-- cases:
+--      1) if a value has wordRep type, the type is not appended in the
+--      output.
+--      2) MachOps that operate over wordRep type are printed in a
+--      C-style, rather than as their internal MachRep name.
+--
+-- These conventions produce much more readable Cmm output.
+--
+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
+--
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module PprCmmDecl
+    ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic
+    )
+where
+
+import GhcPrelude
+
+import PprCmmExpr
+import Cmm
+
+import DynFlags
+import Outputable
+import FastString
+
+import Data.List
+import System.IO
+
+-- Temp Jan08
+import SMRep
+
+
+pprCmms :: (Outputable info, Outputable g)
+        => [GenCmmGroup CmmStatics info g] -> SDoc
+pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
+        where
+          separator = space $$ text "-------------------" $$ space
+
+writeCmms :: (Outputable info, Outputable g)
+          => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO ()
+writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms)
+
+-----------------------------------------------------------------------------
+
+instance (Outputable d, Outputable info, Outputable i)
+      => Outputable (GenCmmDecl d info i) where
+    ppr t = pprTop t
+
+instance Outputable CmmStatics where
+    ppr = pprStatics
+
+instance Outputable CmmStatic where
+    ppr = pprStatic
+
+instance Outputable CmmInfoTable where
+    ppr = pprInfoTable
+
+
+-----------------------------------------------------------------------------
+
+pprCmmGroup :: (Outputable d, Outputable info, Outputable g)
+            => GenCmmGroup d info g -> SDoc
+pprCmmGroup tops
+    = vcat $ intersperse blankLine $ map pprTop tops
+
+-- --------------------------------------------------------------------------
+-- Top level `procedure' blocks.
+--
+pprTop :: (Outputable d, Outputable info, Outputable i)
+       => GenCmmDecl d info i -> SDoc
+
+pprTop (CmmProc info lbl live graph)
+
+  = vcat [ ppr lbl <> lparen <> rparen <+> text "// " <+> ppr live
+         , nest 8 $ lbrace <+> ppr info $$ rbrace
+         , nest 4 $ ppr graph
+         , rbrace ]
+
+-- --------------------------------------------------------------------------
+-- We follow [1], 4.5
+--
+--      section "data" { ... }
+--
+pprTop (CmmData section ds) =
+    (hang (pprSection section <+> lbrace) 4 (ppr ds))
+    $$ rbrace
+
+-- --------------------------------------------------------------------------
+-- Info tables.
+
+pprInfoTable :: CmmInfoTable -> SDoc
+pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
+                           , cit_prof = prof_info
+                           , cit_srt = srt })
+  = vcat [ text "label: " <> ppr lbl
+         , text "rep: " <> ppr rep
+         , case prof_info of
+             NoProfilingInfo -> empty
+             ProfilingInfo ct cd ->
+               vcat [ text "type: " <> pprWord8String ct
+                    , text "desc: " <> pprWord8String cd ]
+         , text "srt: " <> ppr srt ]
+
+instance Outputable ForeignHint where
+  ppr NoHint     = empty
+  ppr SignedHint = quotes(text "signed")
+--  ppr AddrHint   = quotes(text "address")
+-- Temp Jan08
+  ppr AddrHint   = (text "PtrHint")
+
+-- --------------------------------------------------------------------------
+-- Static data.
+--      Strings are printed as C strings, and we print them as I8[],
+--      following C--
+--
+pprStatics :: CmmStatics -> SDoc
+pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)
+
+pprStatic :: CmmStatic -> SDoc
+pprStatic s = case s of
+    CmmStaticLit lit   -> nest 4 $ text "const" <+> pprLit lit <> semi
+    CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
+    CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')
+
+-- --------------------------------------------------------------------------
+-- data sections
+--
+pprSection :: Section -> SDoc
+pprSection (Section t suffix) =
+  section <+> doubleQuotes (pprSectionType t <+> char '.' <+> ppr suffix)
+  where
+    section = text "section"
+
+pprSectionType :: SectionType -> SDoc
+pprSectionType s = doubleQuotes (ptext t)
+ where
+  t = case s of
+    Text              -> sLit "text"
+    Data              -> sLit "data"
+    ReadOnlyData      -> sLit "readonly"
+    ReadOnlyData16    -> sLit "readonly16"
+    RelocatableReadOnlyData
+                      -> sLit "relreadonly"
+    UninitialisedData -> sLit "uninitialised"
+    CString           -> sLit "cstring"
+    OtherSection s'   -> sLit s' -- Not actually a literal though.
diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/PprCmmExpr.hs
@@ -0,0 +1,286 @@
+----------------------------------------------------------------------------
+--
+-- Pretty-printing of common Cmm types
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+--
+-- This is where we walk over Cmm emitting an external representation,
+-- suitable for parsing, in a syntax strongly reminiscent of C--. This
+-- is the "External Core" for the Cmm layer.
+--
+-- As such, this should be a well-defined syntax: we want it to look nice.
+-- Thus, we try wherever possible to use syntax defined in [1],
+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- than C--'s bits8 .. bits64.
+--
+-- We try to ensure that all information available in the abstract
+-- syntax is reproduced, or reproducible, in the concrete syntax.
+-- Data that is not in printed out can be reconstructed according to
+-- conventions used in the pretty printer. There are at least two such
+-- cases:
+--      1) if a value has wordRep type, the type is not appended in the
+--      output.
+--      2) MachOps that operate over wordRep type are printed in a
+--      C-style, rather than as their internal MachRep name.
+--
+-- These conventions produce much more readable Cmm output.
+--
+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
+--
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module PprCmmExpr
+    ( pprExpr, pprLit
+    )
+where
+
+import GhcPrelude
+
+import CmmExpr
+
+import Outputable
+import DynFlags
+
+import Data.Maybe
+import Numeric ( fromRat )
+
+-----------------------------------------------------------------------------
+
+instance Outputable CmmExpr where
+    ppr e = pprExpr e
+
+instance Outputable CmmReg where
+    ppr e = pprReg e
+
+instance Outputable CmmLit where
+    ppr l = pprLit l
+
+instance Outputable LocalReg where
+    ppr e = pprLocalReg e
+
+instance Outputable Area where
+    ppr e = pprArea e
+
+instance Outputable GlobalReg where
+    ppr e = pprGlobalReg e
+
+-- --------------------------------------------------------------------------
+-- Expressions
+--
+
+pprExpr :: CmmExpr -> SDoc
+pprExpr e
+    = sdocWithDynFlags $ \dflags ->
+      case e of
+        CmmRegOff reg i ->
+                pprExpr (CmmMachOp (MO_Add rep)
+                           [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
+                where rep = typeWidth (cmmRegType dflags reg)
+        CmmLit lit -> pprLit lit
+        _other     -> pprExpr1 e
+
+-- Here's the precedence table from CmmParse.y:
+-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
+-- %left '|'
+-- %left '^'
+-- %left '&'
+-- %left '>>' '<<'
+-- %left '-' '+'
+-- %left '/' '*' '%'
+-- %right '~'
+
+-- We just cope with the common operators for now, the rest will get
+-- a default conservative behaviour.
+
+-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
+pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
+pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
+   = pprExpr7 x <+> doc <+> pprExpr7 y
+pprExpr1 e = pprExpr7 e
+
+infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
+
+infixMachOp1 (MO_Eq     _) = Just (text "==")
+infixMachOp1 (MO_Ne     _) = Just (text "!=")
+infixMachOp1 (MO_Shl    _) = Just (text "<<")
+infixMachOp1 (MO_U_Shr  _) = Just (text ">>")
+infixMachOp1 (MO_U_Ge   _) = Just (text ">=")
+infixMachOp1 (MO_U_Le   _) = Just (text "<=")
+infixMachOp1 (MO_U_Gt   _) = Just (char '>')
+infixMachOp1 (MO_U_Lt   _) = Just (char '<')
+infixMachOp1 _             = Nothing
+
+-- %left '-' '+'
+pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
+   = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
+pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
+   = pprExpr7 x <+> doc <+> pprExpr8 y
+pprExpr7 e = pprExpr8 e
+
+infixMachOp7 (MO_Add _)  = Just (char '+')
+infixMachOp7 (MO_Sub _)  = Just (char '-')
+infixMachOp7 _           = Nothing
+
+-- %left '/' '*' '%'
+pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
+   = pprExpr8 x <+> doc <+> pprExpr9 y
+pprExpr8 e = pprExpr9 e
+
+infixMachOp8 (MO_U_Quot _) = Just (char '/')
+infixMachOp8 (MO_Mul _)    = Just (char '*')
+infixMachOp8 (MO_U_Rem _)  = Just (char '%')
+infixMachOp8 _             = Nothing
+
+pprExpr9 :: CmmExpr -> SDoc
+pprExpr9 e =
+   case e of
+        CmmLit    lit       -> pprLit1 lit
+        CmmLoad   expr rep  -> ppr rep <> brackets (ppr expr)
+        CmmReg    reg       -> ppr reg
+        CmmRegOff  reg off  -> parens (ppr reg <+> char '+' <+> int off)
+        CmmStackSlot a off  -> parens (ppr a   <+> char '+' <+> int off)
+        CmmMachOp mop args  -> genMachOp mop args
+
+genMachOp :: MachOp -> [CmmExpr] -> SDoc
+genMachOp mop args
+   | Just doc <- infixMachOp mop = case args of
+        -- dyadic
+        [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
+
+        -- unary
+        [x]   -> doc <> pprExpr9 x
+
+        _     -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
+                          (pprMachOp mop <+>
+                            parens (hcat $ punctuate comma (map pprExpr args)))
+                          empty
+
+   | isJust (infixMachOp1 mop)
+   || isJust (infixMachOp7 mop)
+   || isJust (infixMachOp8 mop)  = parens (pprExpr (CmmMachOp mop args))
+
+   | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
+        where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
+                                 (show mop))
+                -- replace spaces in (show mop) with underscores,
+
+--
+-- Unsigned ops on the word size of the machine get nice symbols.
+-- All else get dumped in their ugly format.
+--
+infixMachOp :: MachOp -> Maybe SDoc
+infixMachOp mop
+        = case mop of
+            MO_And    _ -> Just $ char '&'
+            MO_Or     _ -> Just $ char '|'
+            MO_Xor    _ -> Just $ char '^'
+            MO_Not    _ -> Just $ char '~'
+            MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)
+            _ -> Nothing
+
+-- --------------------------------------------------------------------------
+-- Literals.
+--  To minimise line noise we adopt the convention that if the literal
+--  has the natural machine word size, we do not append the type
+--
+pprLit :: CmmLit -> SDoc
+pprLit lit = sdocWithDynFlags $ \dflags ->
+             case lit of
+    CmmInt i rep ->
+        hcat [ (if i < 0 then parens else id)(integer i)
+             , ppUnless (rep == wordWidth dflags) $
+               space <> dcolon <+> ppr rep ]
+
+    CmmFloat f rep     -> hsep [ double (fromRat f), dcolon, ppr rep ]
+    CmmVec lits        -> char '<' <> commafy (map pprLit lits) <> char '>'
+    CmmLabel clbl      -> ppr clbl
+    CmmLabelOff clbl i -> ppr clbl <> ppr_offset i
+    CmmLabelDiffOff clbl1 clbl2 i _ -> ppr clbl1 <> char '-'
+                                  <> ppr clbl2 <> ppr_offset i
+    CmmBlock id        -> ppr id
+    CmmHighStackMark -> text "<highSp>"
+
+pprLit1 :: CmmLit -> SDoc
+pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
+pprLit1 lit                  = pprLit lit
+
+ppr_offset :: Int -> SDoc
+ppr_offset i
+    | i==0      = empty
+    | i>=0      = char '+' <> int i
+    | otherwise = char '-' <> int (-i)
+
+-- --------------------------------------------------------------------------
+-- Registers, whether local (temps) or global
+--
+pprReg :: CmmReg -> SDoc
+pprReg r
+    = case r of
+        CmmLocal  local  -> pprLocalReg  local
+        CmmGlobal global -> pprGlobalReg global
+
+--
+-- We only print the type of the local reg if it isn't wordRep
+--
+pprLocalReg :: LocalReg -> SDoc
+pprLocalReg (LocalReg uniq rep) = sdocWithDynFlags $ \dflags ->
+--   = ppr rep <> char '_' <> ppr uniq
+-- Temp Jan08
+    char '_' <> pprUnique dflags uniq <>
+       (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh
+                    then dcolon <> ptr <> ppr rep
+                    else dcolon <> ptr <> ppr rep)
+   where
+     pprUnique dflags unique =
+        if gopt Opt_SuppressUniques dflags
+            then text "_locVar_"
+            else ppr unique
+     ptr = empty
+         --if isGcPtrType rep
+         --      then doubleQuotes (text "ptr")
+         --      else empty
+
+-- Stack areas
+pprArea :: Area -> SDoc
+pprArea Old        = text "old"
+pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]
+
+-- needs to be kept in syn with CmmExpr.hs.GlobalReg
+--
+pprGlobalReg :: GlobalReg -> SDoc
+pprGlobalReg gr
+    = case gr of
+        VanillaReg n _ -> char 'R' <> int n
+-- Temp Jan08
+--        VanillaReg n VNonGcPtr -> char 'R' <> int n
+--        VanillaReg n VGcPtr    -> char 'P' <> int n
+        FloatReg   n   -> char 'F' <> int n
+        DoubleReg  n   -> char 'D' <> int n
+        LongReg    n   -> char 'L' <> int n
+        XmmReg     n   -> text "XMM" <> int n
+        YmmReg     n   -> text "YMM" <> int n
+        ZmmReg     n   -> text "ZMM" <> int n
+        Sp             -> text "Sp"
+        SpLim          -> text "SpLim"
+        Hp             -> text "Hp"
+        HpLim          -> text "HpLim"
+        MachSp         -> text "MachSp"
+        UnwindReturnReg-> text "UnwindReturnReg"
+        CCCS           -> text "CCCS"
+        CurrentTSO     -> text "CurrentTSO"
+        CurrentNursery -> text "CurrentNursery"
+        HpAlloc        -> text "HpAlloc"
+        EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"
+        GCEnter1       -> text "stg_gc_enter_1"
+        GCFun          -> text "stg_gc_fun"
+        BaseReg        -> text "BaseReg"
+        PicBaseReg     -> text "PicBaseReg"
+
+-----------------------------------------------------------------------------
+
+commafy :: [SDoc] -> SDoc
+commafy xs = fsep $ punctuate comma xs
diff --git a/compiler/cmm/SMRep.hs b/compiler/cmm/SMRep.hs
new file mode 100644
--- /dev/null
+++ b/compiler/cmm/SMRep.hs
@@ -0,0 +1,574 @@
+-- (c) The University of Glasgow 2006
+-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+--
+-- Storage manager representation of closures
+
+{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-}
+
+module SMRep (
+        -- * Words and bytes
+        WordOff, ByteOff,
+        wordsToBytes, bytesToWordsRoundUp,
+        roundUpToWords, roundUpTo,
+
+        StgWord, fromStgWord, toStgWord,
+        StgHalfWord, fromStgHalfWord, toStgHalfWord,
+        hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS,
+
+        -- * Closure repesentation
+        SMRep(..), -- CmmInfo sees the rep; no one else does
+        IsStatic,
+        ClosureTypeInfo(..), ArgDescr(..), Liveness,
+        ConstrDescription,
+
+        -- ** Construction
+        mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep,
+        smallArrPtrsRep, arrWordsRep,
+
+        -- ** Predicates
+        isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon,
+        isStackRep,
+
+        -- ** Size-related things
+        heapClosureSizeW,
+        fixedHdrSizeW, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize,
+        arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW,
+        smallArrPtrsHdrSize, smallArrPtrsHdrSizeW, hdrSize, hdrSizeW,
+        fixedHdrSize,
+
+        -- ** RTS closure types
+        rtsClosureType, rET_SMALL, rET_BIG,
+        aRG_GEN, aRG_GEN_BIG,
+
+        -- ** Arrays
+        card, cardRoundUp, cardTableSizeB, cardTableSizeW,
+
+        -- * Operations over [Word8] strings that don't belong here
+        pprWord8String, stringToWord8s
+    ) where
+
+import GhcPrelude
+
+import BasicTypes( ConTagZ )
+import DynFlags
+import Outputable
+import Platform
+import FastString
+
+import Data.Char( ord )
+import Data.Word
+import Data.Bits
+
+{-
+************************************************************************
+*                                                                      *
+                Words and bytes
+*                                                                      *
+************************************************************************
+-}
+
+-- | Word offset, or word count
+type WordOff = Int
+
+-- | Byte offset, or byte count
+type ByteOff = Int
+
+-- | Round up the given byte count to the next byte count that's a
+-- multiple of the machine's word size.
+roundUpToWords :: DynFlags -> ByteOff -> ByteOff
+roundUpToWords dflags n = roundUpTo n (wORD_SIZE dflags)
+
+-- | Round up @base@ to a multiple of @size@.
+roundUpTo :: ByteOff -> ByteOff -> ByteOff
+roundUpTo base size = (base + (size - 1)) .&. (complement (size - 1))
+
+-- | Convert the given number of words to a number of bytes.
+--
+-- This function morally has type @WordOff -> ByteOff@, but uses @Num
+-- a@ to allow for overloading.
+wordsToBytes :: Num a => DynFlags -> a -> a
+wordsToBytes dflags n = fromIntegral (wORD_SIZE dflags) * n
+{-# SPECIALIZE wordsToBytes :: DynFlags -> Int -> Int #-}
+{-# SPECIALIZE wordsToBytes :: DynFlags -> Word -> Word #-}
+{-# SPECIALIZE wordsToBytes :: DynFlags -> Integer -> Integer #-}
+
+-- | First round the given byte count up to a multiple of the
+-- machine's word size and then convert the result to words.
+bytesToWordsRoundUp :: DynFlags -> ByteOff -> WordOff
+bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size
+ where word_size = wORD_SIZE dflags
+-- StgWord is a type representing an StgWord on the target platform.
+-- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform
+newtype StgWord = StgWord Word64
+    deriving (Eq, Bits)
+
+fromStgWord :: StgWord -> Integer
+fromStgWord (StgWord i) = toInteger i
+
+toStgWord :: DynFlags -> Integer -> StgWord
+toStgWord dflags i
+    = case platformWordSize (targetPlatform dflags) of
+      -- These conversions mean that things like toStgWord (-1)
+      -- do the right thing
+      4 -> StgWord (fromIntegral (fromInteger i :: Word32))
+      8 -> StgWord (fromInteger i :: Word64)
+      w -> panic ("toStgWord: Unknown platformWordSize: " ++ show w)
+
+instance Outputable StgWord where
+    ppr (StgWord i) = integer (toInteger i)
+
+--
+
+-- A Word32 is large enough to hold half a Word for either a 32bit or
+-- 64bit platform
+newtype StgHalfWord = StgHalfWord Word32
+    deriving Eq
+
+fromStgHalfWord :: StgHalfWord -> Integer
+fromStgHalfWord (StgHalfWord w) = toInteger w
+
+toStgHalfWord :: DynFlags -> Integer -> StgHalfWord
+toStgHalfWord dflags i
+    = case platformWordSize (targetPlatform dflags) of
+      -- These conversions mean that things like toStgHalfWord (-1)
+      -- do the right thing
+      4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16))
+      8 -> StgHalfWord (fromInteger i :: Word32)
+      w -> panic ("toStgHalfWord: Unknown platformWordSize: " ++ show w)
+
+instance Outputable StgHalfWord where
+    ppr (StgHalfWord w) = integer (toInteger w)
+
+hALF_WORD_SIZE :: DynFlags -> ByteOff
+hALF_WORD_SIZE dflags = platformWordSize (targetPlatform dflags) `shiftR` 1
+hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int
+hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection[SMRep-datatype]{@SMRep@---storage manager representation}
+*                                                                      *
+************************************************************************
+-}
+
+-- | A description of the layout of a closure.  Corresponds directly
+-- to the closure types in includes/rts/storage/ClosureTypes.h.
+data SMRep
+  = HeapRep              -- GC routines consult sizes in info tbl
+        IsStatic
+        !WordOff         --  # ptr words
+        !WordOff         --  # non-ptr words INCLUDING SLOP (see mkHeapRep below)
+        ClosureTypeInfo  -- type-specific info
+
+  | ArrayPtrsRep
+        !WordOff        -- # ptr words
+        !WordOff        -- # card table words
+
+  | SmallArrayPtrsRep
+        !WordOff        -- # ptr words
+
+  | ArrayWordsRep
+        !WordOff        -- # bytes expressed in words, rounded up
+
+  | StackRep            -- Stack frame (RET_SMALL or RET_BIG)
+        Liveness
+
+  | RTSRep              -- The RTS needs to declare info tables with specific
+        Int             -- type tags, so this form lets us override the default
+        SMRep           -- tag for an SMRep.
+
+-- | True <=> This is a static closure.  Affects how we garbage-collect it.
+-- Static closure have an extra static link field at the end.
+-- Constructors do not have a static variant; see Note [static constructors]
+type IsStatic = Bool
+
+-- From an SMRep you can get to the closure type defined in
+-- includes/rts/storage/ClosureTypes.h. Described by the function
+-- rtsClosureType below.
+
+data ClosureTypeInfo
+  = Constr        ConTagZ ConstrDescription
+  | Fun           FunArity ArgDescr
+  | Thunk
+  | ThunkSelector SelectorOffset
+  | BlackHole
+  | IndStatic
+
+type ConstrDescription = [Word8] -- result of dataConIdentity
+type FunArity          = Int
+type SelectorOffset    = Int
+
+-------------------------
+-- We represent liveness bitmaps as a Bitmap (whose internal
+-- representation really is a bitmap).  These are pinned onto case return
+-- vectors to indicate the state of the stack for the garbage collector.
+--
+-- In the compiled program, liveness bitmaps that fit inside a single
+-- word (StgWord) are stored as a single word, while larger bitmaps are
+-- stored as a pointer to an array of words.
+
+type Liveness = [Bool]   -- One Bool per word; True  <=> non-ptr or dead
+                         --                    False <=> ptr
+
+-------------------------
+-- An ArgDescr describes the argument pattern of a function
+
+data ArgDescr
+  = ArgSpec             -- Fits one of the standard patterns
+        !Int            -- RTS type identifier ARG_P, ARG_N, ...
+
+  | ArgGen              -- General case
+        Liveness        -- Details about the arguments
+
+
+-----------------------------------------------------------------------------
+-- Construction
+
+mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo
+          -> SMRep
+mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info
+  = HeapRep is_static
+            ptr_wds
+            (nonptr_wds + slop_wds)
+            cl_type_info
+  where
+     slop_wds
+      | is_static = 0
+      | otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size))
+
+     hdr_size     = closureTypeHdrSize dflags cl_type_info
+     payload_size = ptr_wds + nonptr_wds
+
+mkRTSRep :: Int -> SMRep -> SMRep
+mkRTSRep = RTSRep
+
+mkStackRep :: [Bool] -> SMRep
+mkStackRep liveness = StackRep liveness
+
+blackHoleRep :: SMRep
+blackHoleRep = HeapRep False 0 0 BlackHole
+
+indStaticRep :: SMRep
+indStaticRep = HeapRep True 1 0 IndStatic
+
+arrPtrsRep :: DynFlags -> WordOff -> SMRep
+arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems)
+
+smallArrPtrsRep :: WordOff -> SMRep
+smallArrPtrsRep elems = SmallArrayPtrsRep elems
+
+arrWordsRep :: DynFlags -> ByteOff -> SMRep
+arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes)
+
+-----------------------------------------------------------------------------
+-- Predicates
+
+isStaticRep :: SMRep -> IsStatic
+isStaticRep (HeapRep is_static _ _ _) = is_static
+isStaticRep (RTSRep _ rep)            = isStaticRep rep
+isStaticRep _                         = False
+
+isStackRep :: SMRep -> Bool
+isStackRep StackRep{}     = True
+isStackRep (RTSRep _ rep) = isStackRep rep
+isStackRep _              = False
+
+isConRep :: SMRep -> Bool
+isConRep (HeapRep _ _ _ Constr{}) = True
+isConRep _                        = False
+
+isThunkRep :: SMRep -> Bool
+isThunkRep (HeapRep _ _ _ Thunk)           = True
+isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True
+isThunkRep (HeapRep _ _ _ BlackHole)       = True
+isThunkRep (HeapRep _ _ _ IndStatic)       = True
+isThunkRep _                               = False
+
+isFunRep :: SMRep -> Bool
+isFunRep (HeapRep _ _ _ Fun{}) = True
+isFunRep _                     = False
+
+isStaticNoCafCon :: SMRep -> Bool
+-- This should line up exactly with CONSTR_NOCAF below
+-- See Note [Static NoCaf constructors]
+isStaticNoCafCon (HeapRep _ 0 _ Constr{}) = True
+isStaticNoCafCon _                        = False
+
+
+-----------------------------------------------------------------------------
+-- Size-related things
+
+fixedHdrSize :: DynFlags -> ByteOff
+fixedHdrSize dflags = wordsToBytes dflags (fixedHdrSizeW dflags)
+
+-- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h)
+fixedHdrSizeW :: DynFlags -> WordOff
+fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags
+
+-- | Size of the profiling part of a closure header
+-- (StgProfHeader in includes/rts/storage/Closures.h)
+profHdrSize  :: DynFlags -> WordOff
+profHdrSize dflags
+ | gopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE dflags
+ | otherwise                      = 0
+
+-- | The garbage collector requires that every closure is at least as
+--   big as this.
+minClosureSize :: DynFlags -> WordOff
+minClosureSize dflags = fixedHdrSizeW dflags + mIN_PAYLOAD_SIZE dflags
+
+arrWordsHdrSize :: DynFlags -> ByteOff
+arrWordsHdrSize dflags
+ = fixedHdrSize dflags + sIZEOF_StgArrBytes_NoHdr dflags
+
+arrWordsHdrSizeW :: DynFlags -> WordOff
+arrWordsHdrSizeW dflags =
+    fixedHdrSizeW dflags +
+    (sIZEOF_StgArrBytes_NoHdr dflags `quot` wORD_SIZE dflags)
+
+arrPtrsHdrSize :: DynFlags -> ByteOff
+arrPtrsHdrSize dflags
+ = fixedHdrSize dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags
+
+arrPtrsHdrSizeW :: DynFlags -> WordOff
+arrPtrsHdrSizeW dflags =
+    fixedHdrSizeW dflags +
+    (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)
+
+smallArrPtrsHdrSize :: DynFlags -> ByteOff
+smallArrPtrsHdrSize dflags
+ = fixedHdrSize dflags + sIZEOF_StgSmallMutArrPtrs_NoHdr dflags
+
+smallArrPtrsHdrSizeW :: DynFlags -> WordOff
+smallArrPtrsHdrSizeW dflags =
+    fixedHdrSizeW dflags +
+    (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)
+
+-- Thunks have an extra header word on SMP, so the update doesn't
+-- splat the payload.
+thunkHdrSize :: DynFlags -> WordOff
+thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr
+        where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags
+
+hdrSize :: DynFlags -> SMRep -> ByteOff
+hdrSize dflags rep = wordsToBytes dflags (hdrSizeW dflags rep)
+
+hdrSizeW :: DynFlags -> SMRep -> WordOff
+hdrSizeW dflags (HeapRep _ _ _ ty)    = closureTypeHdrSize dflags ty
+hdrSizeW dflags (ArrayPtrsRep _ _)    = arrPtrsHdrSizeW dflags
+hdrSizeW dflags (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW dflags
+hdrSizeW dflags (ArrayWordsRep _)     = arrWordsHdrSizeW dflags
+hdrSizeW _ _                          = panic "SMRep.hdrSizeW"
+
+nonHdrSize :: DynFlags -> SMRep -> ByteOff
+nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep)
+
+nonHdrSizeW :: SMRep -> WordOff
+nonHdrSizeW (HeapRep _ p np _) = p + np
+nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct
+nonHdrSizeW (SmallArrayPtrsRep elems) = elems
+nonHdrSizeW (ArrayWordsRep words) = words
+nonHdrSizeW (StackRep bs)      = length bs
+nonHdrSizeW (RTSRep _ rep)     = nonHdrSizeW rep
+
+-- | The total size of the closure, in words.
+heapClosureSizeW :: DynFlags -> SMRep -> WordOff
+heapClosureSizeW dflags (HeapRep _ p np ty)
+ = closureTypeHdrSize dflags ty + p + np
+heapClosureSizeW dflags (ArrayPtrsRep elems ct)
+ = arrPtrsHdrSizeW dflags + elems + ct
+heapClosureSizeW dflags (SmallArrayPtrsRep elems)
+ = smallArrPtrsHdrSizeW dflags + elems
+heapClosureSizeW dflags (ArrayWordsRep words)
+ = arrWordsHdrSizeW dflags + words
+heapClosureSizeW _ _ = panic "SMRep.heapClosureSize"
+
+closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff
+closureTypeHdrSize dflags ty = case ty of
+                  Thunk           -> thunkHdrSize dflags
+                  ThunkSelector{} -> thunkHdrSize dflags
+                  BlackHole       -> thunkHdrSize dflags
+                  IndStatic       -> thunkHdrSize dflags
+                  _               -> fixedHdrSizeW dflags
+        -- All thunks use thunkHdrSize, even if they are non-updatable.
+        -- this is because we don't have separate closure types for
+        -- updatable vs. non-updatable thunks, so the GC can't tell the
+        -- difference.  If we ever have significant numbers of non-
+        -- updatable thunks, it might be worth fixing this.
+
+-- ---------------------------------------------------------------------------
+-- Arrays
+
+-- | The byte offset into the card table of the card for a given element
+card :: DynFlags -> Int -> Int
+card dflags i = i `shiftR` mUT_ARR_PTRS_CARD_BITS dflags
+
+-- | Convert a number of elements to a number of cards, rounding up
+cardRoundUp :: DynFlags -> Int -> Int
+cardRoundUp dflags i =
+  card dflags (i + ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1))
+
+-- | The size of a card table, in bytes
+cardTableSizeB :: DynFlags -> Int -> ByteOff
+cardTableSizeB dflags elems = cardRoundUp dflags elems
+
+-- | The size of a card table, in words
+cardTableSizeW :: DynFlags -> Int -> WordOff
+cardTableSizeW dflags elems =
+  bytesToWordsRoundUp dflags (cardTableSizeB dflags elems)
+
+-----------------------------------------------------------------------------
+-- deriving the RTS closure type from an SMRep
+
+#include "../includes/rts/storage/ClosureTypes.h"
+#include "../includes/rts/storage/FunTypes.h"
+-- Defines CONSTR, CONSTR_1_0 etc
+
+-- | Derives the RTS closure type from an 'SMRep'
+rtsClosureType :: SMRep -> Int
+rtsClosureType rep
+    = case rep of
+      RTSRep ty _ -> ty
+
+      -- See Note [static constructors]
+      HeapRep _     1 0 Constr{} -> CONSTR_1_0
+      HeapRep _     0 1 Constr{} -> CONSTR_0_1
+      HeapRep _     2 0 Constr{} -> CONSTR_2_0
+      HeapRep _     1 1 Constr{} -> CONSTR_1_1
+      HeapRep _     0 2 Constr{} -> CONSTR_0_2
+      HeapRep _     0 _ Constr{} -> CONSTR_NOCAF
+           -- See Note [Static NoCaf constructors]
+      HeapRep _     _ _ Constr{} -> CONSTR
+
+      HeapRep False 1 0 Fun{} -> FUN_1_0
+      HeapRep False 0 1 Fun{} -> FUN_0_1
+      HeapRep False 2 0 Fun{} -> FUN_2_0
+      HeapRep False 1 1 Fun{} -> FUN_1_1
+      HeapRep False 0 2 Fun{} -> FUN_0_2
+      HeapRep False _ _ Fun{} -> FUN
+
+      HeapRep False 1 0 Thunk -> THUNK_1_0
+      HeapRep False 0 1 Thunk -> THUNK_0_1
+      HeapRep False 2 0 Thunk -> THUNK_2_0
+      HeapRep False 1 1 Thunk -> THUNK_1_1
+      HeapRep False 0 2 Thunk -> THUNK_0_2
+      HeapRep False _ _ Thunk -> THUNK
+
+      HeapRep False _ _ ThunkSelector{} ->  THUNK_SELECTOR
+
+      HeapRep True _ _ Fun{}      -> FUN_STATIC
+      HeapRep True _ _ Thunk      -> THUNK_STATIC
+      HeapRep False _ _ BlackHole -> BLACKHOLE
+      HeapRep False _ _ IndStatic -> IND_STATIC
+
+      _ -> panic "rtsClosureType"
+
+-- We export these ones
+rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: Int
+rET_SMALL   = RET_SMALL
+rET_BIG     = RET_BIG
+aRG_GEN     = ARG_GEN
+aRG_GEN_BIG = ARG_GEN_BIG
+
+{-
+Note [static constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We used to have a CONSTR_STATIC closure type, and each constructor had
+two info tables: one with CONSTR (or CONSTR_1_0 etc.), and one with
+CONSTR_STATIC.
+
+This distinction was removed, because when copying a data structure
+into a compact region, we must copy static constructors into the
+compact region too.  If we didn't do this, we would need to track the
+references from the compact region out to the static constructors,
+because they might (indirectly) refer to CAFs.
+
+Since static constructors will be copied to the heap, if we wanted to
+use different info tables for static and dynamic constructors, we
+would have to switch the info pointer when copying the constructor
+into the compact region, which means we would need an extra field of
+the static info table to point to the dynamic one.
+
+However, since the distinction between static and dynamic closure
+types is never actually needed (other than for assertions), we can
+just drop the distinction and use the same info table for both.
+
+The GC *does* need to distinguish between static and dynamic closures,
+but it does this using the HEAP_ALLOCED() macro which checks whether
+the address of the closure resides within the dynamic heap.
+HEAP_ALLOCED() doesn't read the closure's info table.
+
+Note [Static NoCaf constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we know that a top-level binding 'x' is not Caffy (ie no CAFs are
+reachable from 'x'), then a statically allocated constructor (Just x)
+is also not Caffy, and the garbage collector need not follow its
+argument fields.  Exploiting this would require two static info tables
+for Just, for the two cases where the argument was Caffy or non-Caffy.
+
+Currently we don't do this; instead we treat nullary constructors
+as non-Caffy, and the others as potentially Caffy.
+
+
+************************************************************************
+*                                                                      *
+             Pretty printing of SMRep and friends
+*                                                                      *
+************************************************************************
+-}
+
+instance Outputable ClosureTypeInfo where
+   ppr = pprTypeInfo
+
+instance Outputable SMRep where
+   ppr (HeapRep static ps nps tyinfo)
+     = hang (header <+> lbrace) 2 (ppr tyinfo <+> rbrace)
+     where
+       header = text "HeapRep"
+                <+> if static then text "static" else empty
+                <+> pp_n "ptrs" ps <+> pp_n "nonptrs" nps
+       pp_n :: String -> Int -> SDoc
+       pp_n _ 0 = empty
+       pp_n s n = int n <+> text s
+
+   ppr (ArrayPtrsRep size _) = text "ArrayPtrsRep" <+> ppr size
+
+   ppr (SmallArrayPtrsRep size) = text "SmallArrayPtrsRep" <+> ppr size
+
+   ppr (ArrayWordsRep words) = text "ArrayWordsRep" <+> ppr words
+
+   ppr (StackRep bs) = text "StackRep" <+> ppr bs
+
+   ppr (RTSRep ty rep) = text "tag:" <> ppr ty <+> ppr rep
+
+instance Outputable ArgDescr where
+  ppr (ArgSpec n) = text "ArgSpec" <+> ppr n
+  ppr (ArgGen ls) = text "ArgGen" <+> ppr ls
+
+pprTypeInfo :: ClosureTypeInfo -> SDoc
+pprTypeInfo (Constr tag descr)
+  = text "Con" <+>
+    braces (sep [ text "tag:" <+> ppr tag
+                , text "descr:" <> text (show descr) ])
+
+pprTypeInfo (Fun arity args)
+  = text "Fun" <+>
+    braces (sep [ text "arity:" <+> ppr arity
+                , ptext (sLit ("fun_type:")) <+> ppr args ])
+
+pprTypeInfo (ThunkSelector offset)
+  = text "ThunkSel" <+> ppr offset
+
+pprTypeInfo Thunk     = text "Thunk"
+pprTypeInfo BlackHole = text "BlackHole"
+pprTypeInfo IndStatic = text "IndStatic"
+
+-- XXX Does not belong here!!
+stringToWord8s :: String -> [Word8]
+stringToWord8s s = map (fromIntegral . ord) s
+
+pprWord8String :: [Word8] -> SDoc
+-- Debug printing.  Not very clever right now.
+pprWord8String ws = text (show ws)
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CgUtils.hs
@@ -0,0 +1,182 @@
+{-# LANGUAGE GADTs #-}
+
+-----------------------------------------------------------------------------
+--
+-- Code generator utilities; mostly monadic
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module CgUtils ( fixStgRegisters ) where
+
+import GhcPrelude
+
+import CodeGen.Platform
+import Cmm
+import Hoopl.Block
+import Hoopl.Graph
+import CmmUtils
+import CLabel
+import DynFlags
+import Outputable
+
+-- -----------------------------------------------------------------------------
+-- Information about global registers
+
+baseRegOffset :: DynFlags -> GlobalReg -> Int
+
+baseRegOffset dflags (VanillaReg 1 _)    = oFFSET_StgRegTable_rR1 dflags
+baseRegOffset dflags (VanillaReg 2 _)    = oFFSET_StgRegTable_rR2 dflags
+baseRegOffset dflags (VanillaReg 3 _)    = oFFSET_StgRegTable_rR3 dflags
+baseRegOffset dflags (VanillaReg 4 _)    = oFFSET_StgRegTable_rR4 dflags
+baseRegOffset dflags (VanillaReg 5 _)    = oFFSET_StgRegTable_rR5 dflags
+baseRegOffset dflags (VanillaReg 6 _)    = oFFSET_StgRegTable_rR6 dflags
+baseRegOffset dflags (VanillaReg 7 _)    = oFFSET_StgRegTable_rR7 dflags
+baseRegOffset dflags (VanillaReg 8 _)    = oFFSET_StgRegTable_rR8 dflags
+baseRegOffset dflags (VanillaReg 9 _)    = oFFSET_StgRegTable_rR9 dflags
+baseRegOffset dflags (VanillaReg 10 _)   = oFFSET_StgRegTable_rR10 dflags
+baseRegOffset _      (VanillaReg n _)    = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")
+baseRegOffset dflags (FloatReg  1)       = oFFSET_StgRegTable_rF1 dflags
+baseRegOffset dflags (FloatReg  2)       = oFFSET_StgRegTable_rF2 dflags
+baseRegOffset dflags (FloatReg  3)       = oFFSET_StgRegTable_rF3 dflags
+baseRegOffset dflags (FloatReg  4)       = oFFSET_StgRegTable_rF4 dflags
+baseRegOffset dflags (FloatReg  5)       = oFFSET_StgRegTable_rF5 dflags
+baseRegOffset dflags (FloatReg  6)       = oFFSET_StgRegTable_rF6 dflags
+baseRegOffset _      (FloatReg  n)       = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")
+baseRegOffset dflags (DoubleReg 1)       = oFFSET_StgRegTable_rD1 dflags
+baseRegOffset dflags (DoubleReg 2)       = oFFSET_StgRegTable_rD2 dflags
+baseRegOffset dflags (DoubleReg 3)       = oFFSET_StgRegTable_rD3 dflags
+baseRegOffset dflags (DoubleReg 4)       = oFFSET_StgRegTable_rD4 dflags
+baseRegOffset dflags (DoubleReg 5)       = oFFSET_StgRegTable_rD5 dflags
+baseRegOffset dflags (DoubleReg 6)       = oFFSET_StgRegTable_rD6 dflags
+baseRegOffset _      (DoubleReg n)       = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")
+baseRegOffset dflags (XmmReg 1)          = oFFSET_StgRegTable_rXMM1 dflags
+baseRegOffset dflags (XmmReg 2)          = oFFSET_StgRegTable_rXMM2 dflags
+baseRegOffset dflags (XmmReg 3)          = oFFSET_StgRegTable_rXMM3 dflags
+baseRegOffset dflags (XmmReg 4)          = oFFSET_StgRegTable_rXMM4 dflags
+baseRegOffset dflags (XmmReg 5)          = oFFSET_StgRegTable_rXMM5 dflags
+baseRegOffset dflags (XmmReg 6)          = oFFSET_StgRegTable_rXMM6 dflags
+baseRegOffset _      (XmmReg n)          = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")
+baseRegOffset dflags (YmmReg 1)          = oFFSET_StgRegTable_rYMM1 dflags
+baseRegOffset dflags (YmmReg 2)          = oFFSET_StgRegTable_rYMM2 dflags
+baseRegOffset dflags (YmmReg 3)          = oFFSET_StgRegTable_rYMM3 dflags
+baseRegOffset dflags (YmmReg 4)          = oFFSET_StgRegTable_rYMM4 dflags
+baseRegOffset dflags (YmmReg 5)          = oFFSET_StgRegTable_rYMM5 dflags
+baseRegOffset dflags (YmmReg 6)          = oFFSET_StgRegTable_rYMM6 dflags
+baseRegOffset _      (YmmReg n)          = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")
+baseRegOffset dflags (ZmmReg 1)          = oFFSET_StgRegTable_rZMM1 dflags
+baseRegOffset dflags (ZmmReg 2)          = oFFSET_StgRegTable_rZMM2 dflags
+baseRegOffset dflags (ZmmReg 3)          = oFFSET_StgRegTable_rZMM3 dflags
+baseRegOffset dflags (ZmmReg 4)          = oFFSET_StgRegTable_rZMM4 dflags
+baseRegOffset dflags (ZmmReg 5)          = oFFSET_StgRegTable_rZMM5 dflags
+baseRegOffset dflags (ZmmReg 6)          = oFFSET_StgRegTable_rZMM6 dflags
+baseRegOffset _      (ZmmReg n)          = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")
+baseRegOffset dflags Sp                  = oFFSET_StgRegTable_rSp dflags
+baseRegOffset dflags SpLim               = oFFSET_StgRegTable_rSpLim dflags
+baseRegOffset dflags (LongReg 1)         = oFFSET_StgRegTable_rL1 dflags
+baseRegOffset _      (LongReg n)         = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")
+baseRegOffset dflags Hp                  = oFFSET_StgRegTable_rHp dflags
+baseRegOffset dflags HpLim               = oFFSET_StgRegTable_rHpLim dflags
+baseRegOffset dflags CCCS                = oFFSET_StgRegTable_rCCCS dflags
+baseRegOffset dflags CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO dflags
+baseRegOffset dflags CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery dflags
+baseRegOffset dflags HpAlloc             = oFFSET_StgRegTable_rHpAlloc dflags
+baseRegOffset dflags EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo dflags
+baseRegOffset dflags GCEnter1            = oFFSET_stgGCEnter1 dflags
+baseRegOffset dflags GCFun               = oFFSET_stgGCFun dflags
+baseRegOffset _      BaseReg             = panic "CgUtils.baseRegOffset:BaseReg"
+baseRegOffset _      PicBaseReg          = panic "CgUtils.baseRegOffset:PicBaseReg"
+baseRegOffset _      MachSp              = panic "CgUtils.baseRegOffset:MachSp"
+baseRegOffset _      UnwindReturnReg     = panic "CgUtils.baseRegOffset:UnwindReturnReg"
+
+
+-- -----------------------------------------------------------------------------
+--
+-- STG/Cmm GlobalReg
+--
+-- -----------------------------------------------------------------------------
+
+-- | We map STG registers onto appropriate CmmExprs.  Either they map
+-- to real machine registers or stored as offsets from BaseReg.  Given
+-- a GlobalReg, get_GlobalReg_addr always produces the
+-- register table address for it.
+get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr
+get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0
+get_GlobalReg_addr dflags mid
+    = get_Regtable_addr_from_offset dflags
+                                    (globalRegType dflags mid) (baseRegOffset dflags mid)
+
+-- Calculate a literal representing an offset into the register table.
+-- Used when we don't have an actual BaseReg to offset from.
+regTableOffset :: DynFlags -> Int -> CmmExpr
+regTableOffset dflags n =
+  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))
+
+get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
+get_Regtable_addr_from_offset dflags _ offset =
+    if haveRegBase (targetPlatform dflags)
+    then CmmRegOff baseReg offset
+    else regTableOffset dflags offset
+
+-- | Fixup global registers so that they assign to locations within the
+-- RegTable if they aren't pinned for the current target.
+fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl
+fixStgRegisters _ top@(CmmData _ _) = top
+
+fixStgRegisters dflags (CmmProc info lbl live graph) =
+  let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph
+  in CmmProc info lbl live graph'
+
+fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x
+fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block
+
+fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x
+fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt
+  where
+    platform = targetPlatform dflags
+
+    fixAssign stmt =
+      case stmt of
+        CmmAssign (CmmGlobal reg) src
+          -- MachSp isn't an STG register; it's merely here for tracking unwind
+          -- information
+          | reg == MachSp -> stmt
+          | otherwise ->
+            let baseAddr = get_GlobalReg_addr dflags reg
+            in case reg `elem` activeStgRegs (targetPlatform dflags) of
+                True  -> CmmAssign (CmmGlobal reg) src
+                False -> CmmStore baseAddr src
+        other_stmt -> other_stmt
+
+    fixExpr expr = case expr of
+        -- MachSp isn't an STG; it's merely here for tracking unwind information
+        CmmReg (CmmGlobal MachSp) -> expr
+        CmmReg (CmmGlobal reg) ->
+            -- Replace register leaves with appropriate StixTrees for
+            -- the given target.  MagicIds which map to a reg on this
+            -- arch are left unchanged.  For the rest, BaseReg is taken
+            -- to mean the address of the reg table in MainCapability,
+            -- and for all others we generate an indirection to its
+            -- location in the register table.
+            case reg `elem` activeStgRegs platform of
+                True  -> expr
+                False ->
+                    let baseAddr = get_GlobalReg_addr dflags reg
+                    in case reg of
+                        BaseReg -> baseAddr
+                        _other  -> CmmLoad baseAddr (globalRegType dflags reg)
+
+        CmmRegOff (CmmGlobal reg) offset ->
+            -- RegOf leaves are just a shorthand form. If the reg maps
+            -- to a real reg, we keep the shorthand, otherwise, we just
+            -- expand it and defer to the above code.
+            case reg `elem` activeStgRegs platform of
+                True  -> expr
+                False -> CmmMachOp (MO_Add (wordWidth dflags)) [
+                                    fixExpr (CmmReg (CmmGlobal reg)),
+                                    CmmLit (CmmInt (fromIntegral offset)
+                                                   (wordWidth dflags))]
+
+        other_expr -> other_expr
+
diff --git a/compiler/codeGen/CodeGen/Platform.hs b/compiler/codeGen/CodeGen/Platform.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform.hs
@@ -0,0 +1,107 @@
+
+module CodeGen.Platform
+       (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg)
+       where
+
+import GhcPrelude
+
+import CmmExpr
+import Platform
+import Reg
+
+import qualified CodeGen.Platform.ARM        as ARM
+import qualified CodeGen.Platform.ARM64      as ARM64
+import qualified CodeGen.Platform.PPC        as PPC
+import qualified CodeGen.Platform.SPARC      as SPARC
+import qualified CodeGen.Platform.X86        as X86
+import qualified CodeGen.Platform.X86_64     as X86_64
+import qualified CodeGen.Platform.NoRegs     as NoRegs
+
+-- | Returns 'True' if this global register is stored in a caller-saves
+-- machine register.
+
+callerSaves :: Platform -> GlobalReg -> Bool
+callerSaves platform
+ | platformUnregisterised platform = NoRegs.callerSaves
+ | otherwise
+ = case platformArch platform of
+   ArchX86    -> X86.callerSaves
+   ArchX86_64 -> X86_64.callerSaves
+   ArchSPARC  -> SPARC.callerSaves
+   ArchARM {} -> ARM.callerSaves
+   ArchARM64  -> ARM64.callerSaves
+   arch
+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->
+        PPC.callerSaves
+
+    | otherwise -> NoRegs.callerSaves
+
+-- | Here is where the STG register map is defined for each target arch.
+-- The order matters (for the llvm backend anyway)! We must make sure to
+-- maintain the order here with the order used in the LLVM calling conventions.
+-- Note that also, this isn't all registers, just the ones that are currently
+-- possbily mapped to real registers.
+activeStgRegs :: Platform -> [GlobalReg]
+activeStgRegs platform
+ | platformUnregisterised platform = NoRegs.activeStgRegs
+ | otherwise
+ = case platformArch platform of
+   ArchX86    -> X86.activeStgRegs
+   ArchX86_64 -> X86_64.activeStgRegs
+   ArchSPARC  -> SPARC.activeStgRegs
+   ArchARM {} -> ARM.activeStgRegs
+   ArchARM64  -> ARM64.activeStgRegs
+   arch
+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->
+        PPC.activeStgRegs
+
+    | otherwise -> NoRegs.activeStgRegs
+
+haveRegBase :: Platform -> Bool
+haveRegBase platform
+ | platformUnregisterised platform = NoRegs.haveRegBase
+ | otherwise
+ = case platformArch platform of
+   ArchX86    -> X86.haveRegBase
+   ArchX86_64 -> X86_64.haveRegBase
+   ArchSPARC  -> SPARC.haveRegBase
+   ArchARM {} -> ARM.haveRegBase
+   ArchARM64  -> ARM64.haveRegBase
+   arch
+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->
+        PPC.haveRegBase
+
+    | otherwise -> NoRegs.haveRegBase
+
+globalRegMaybe :: Platform -> GlobalReg -> Maybe RealReg
+globalRegMaybe platform
+ | platformUnregisterised platform = NoRegs.globalRegMaybe
+ | otherwise
+ = case platformArch platform of
+   ArchX86    -> X86.globalRegMaybe
+   ArchX86_64 -> X86_64.globalRegMaybe
+   ArchSPARC  -> SPARC.globalRegMaybe
+   ArchARM {} -> ARM.globalRegMaybe
+   ArchARM64  -> ARM64.globalRegMaybe
+   arch
+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->
+        PPC.globalRegMaybe
+
+    | otherwise -> NoRegs.globalRegMaybe
+
+freeReg :: Platform -> RegNo -> Bool
+freeReg platform
+ | platformUnregisterised platform = NoRegs.freeReg
+ | otherwise
+ = case platformArch platform of
+   ArchX86    -> X86.freeReg
+   ArchX86_64 -> X86_64.freeReg
+   ArchSPARC  -> SPARC.freeReg
+   ArchARM {} -> ARM.freeReg
+   ArchARM64  -> ARM64.freeReg
+   arch
+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->
+        PPC.freeReg
+
+    | otherwise -> NoRegs.freeReg
+
diff --git a/compiler/codeGen/CodeGen/Platform/ARM.hs b/compiler/codeGen/CodeGen/Platform/ARM.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform/ARM.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.ARM where
+
+import GhcPrelude
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_arm 1
+#include "../../../../includes/CodeGen.Platform.hs"
+
diff --git a/compiler/codeGen/CodeGen/Platform/ARM64.hs b/compiler/codeGen/CodeGen/Platform/ARM64.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform/ARM64.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.ARM64 where
+
+import GhcPrelude
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_aarch64 1
+#include "../../../../includes/CodeGen.Platform.hs"
+
diff --git a/compiler/codeGen/CodeGen/Platform/NoRegs.hs b/compiler/codeGen/CodeGen/Platform/NoRegs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform/NoRegs.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.NoRegs where
+
+import GhcPrelude
+
+#define MACHREGS_NO_REGS 1
+#include "../../../../includes/CodeGen.Platform.hs"
+
diff --git a/compiler/codeGen/CodeGen/Platform/PPC.hs b/compiler/codeGen/CodeGen/Platform/PPC.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform/PPC.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.PPC where
+
+import GhcPrelude
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_powerpc 1
+#include "../../../../includes/CodeGen.Platform.hs"
+
diff --git a/compiler/codeGen/CodeGen/Platform/SPARC.hs b/compiler/codeGen/CodeGen/Platform/SPARC.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform/SPARC.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.SPARC where
+
+import GhcPrelude
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_sparc 1
+#include "../../../../includes/CodeGen.Platform.hs"
+
diff --git a/compiler/codeGen/CodeGen/Platform/X86.hs b/compiler/codeGen/CodeGen/Platform/X86.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform/X86.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.X86 where
+
+import GhcPrelude
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_i386 1
+#include "../../../../includes/CodeGen.Platform.hs"
+
diff --git a/compiler/codeGen/CodeGen/Platform/X86_64.hs b/compiler/codeGen/CodeGen/Platform/X86_64.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/CodeGen/Platform/X86_64.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE CPP #-}
+
+module CodeGen.Platform.X86_64 where
+
+import GhcPrelude
+
+#define MACHREGS_NO_REGS 0
+#define MACHREGS_x86_64 1
+#include "../../../../includes/CodeGen.Platform.hs"
+
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmm.hs
@@ -0,0 +1,251 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+
+-----------------------------------------------------------------------------
+--
+-- Stg to C-- code generation
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmm ( codeGen ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude as Prelude
+
+import StgCmmProf (initCostCentres, ldvEnter)
+import StgCmmMonad
+import StgCmmEnv
+import StgCmmBind
+import StgCmmCon
+import StgCmmLayout
+import StgCmmUtils
+import StgCmmClosure
+import StgCmmHpc
+import StgCmmTicky
+
+import Cmm
+import CmmUtils
+import CLabel
+
+import StgSyn
+import DynFlags
+
+import HscTypes
+import CostCentre
+import Id
+import IdInfo
+import RepType
+import DataCon
+import Name
+import TyCon
+import Module
+import Outputable
+import Stream
+import BasicTypes
+import VarSet ( isEmptyDVarSet )
+
+import OrdList
+import MkGraph
+
+import qualified Data.ByteString as BS
+import Data.IORef
+import Control.Monad (when,void)
+import Util
+
+codeGen :: DynFlags
+        -> Module
+        -> [TyCon]
+        -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
+        -> [CgStgTopBinding]           -- Bindings to convert
+        -> HpcInfo
+        -> Stream IO CmmGroup ()       -- Output as a stream, so codegen can
+                                       -- be interleaved with output
+
+codeGen dflags this_mod data_tycons
+        cost_centre_info stg_binds hpc_info
+  = do  {     -- cg: run the code generator, and yield the resulting CmmGroup
+              -- Using an IORef to store the state is a bit crude, but otherwise
+              -- we would need to add a state monad layer.
+        ; cgref <- liftIO $ newIORef =<< initC
+        ; let cg :: FCode () -> Stream IO CmmGroup ()
+              cg fcode = do
+                cmm <- liftIO $ do
+                         st <- readIORef cgref
+                         let (a,st') = runC dflags this_mod st (getCmm fcode)
+
+                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes
+                         -- a big space leak.  DO NOT REMOVE!
+                         writeIORef cgref $! st'{ cgs_tops = nilOL,
+                                                  cgs_stmts = mkNop }
+                         return a
+                yield cmm
+
+               -- Note [codegen-split-init] the cmm_init block must come
+               -- FIRST.  This is because when -split-objs is on we need to
+               -- combine this block with its initialisation routines; see
+               -- Note [pipeline-split-init].
+        ; cg (mkModuleInit cost_centre_info this_mod hpc_info)
+
+        ; mapM_ (cg . cgTopBinding dflags) stg_binds
+
+                -- Put datatype_stuff after code_stuff, because the
+                -- datatype closure table (for enumeration types) to
+                -- (say) PrelBase_True_closure, which is defined in
+                -- code_stuff
+        ; let do_tycon tycon = do
+                -- Generate a table of static closures for an
+                -- enumeration type Note that the closure pointers are
+                -- tagged.
+                 when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)
+                 mapM_ (cg . cgDataCon) (tyConDataCons tycon)
+
+        ; mapM_ do_tycon data_tycons
+        }
+
+---------------------------------------------------------------
+--      Top-level bindings
+---------------------------------------------------------------
+
+{- 'cgTopBinding' is only used for top-level bindings, since they need
+to be allocated statically (not in the heap) and need to be labelled.
+No unboxed bindings can happen at top level.
+
+In the code below, the static bindings are accumulated in the
+@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.
+This is so that we can write the top level processing in a compositional
+style, with the increasing static environment being plumbed as a state
+variable. -}
+
+cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode ()
+cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))
+  = do  { id' <- maybeExternaliseId dflags id
+        ; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs
+        ; fcode
+        ; addBindC info -- Add the *un-externalised* Id to the envt,
+                        -- so we find it when we look up occurrences
+        }
+
+cgTopBinding dflags (StgTopLifted (StgRec pairs))
+  = do  { let (bndrs, rhss) = unzip pairs
+        ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs
+        ; let pairs' = zip bndrs' rhss
+              r = unzipWith (cgTopRhs dflags Recursive) pairs'
+              (infos, fcodes) = unzip r
+        ; addBindsC infos
+        ; sequence_ fcodes
+        }
+
+cgTopBinding dflags (StgTopStringLit id str)
+  = do  { id' <- maybeExternaliseId dflags id
+        ; let label = mkBytesLabel (idName id')
+        ; let (lit, decl) = mkByteStringCLit label (BS.unpack str)
+        ; emitDecl decl
+        ; addBindC (litIdInfo dflags id' mkLFStringLit lit)
+        }
+
+cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())
+        -- The Id is passed along for setting up a binding...
+        -- It's already been externalised if necessary
+
+cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)
+  = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args)
+      -- con args are always non-void,
+      -- see Note [Post-unarisation invariants] in UnariseStg
+
+cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)
+  = ASSERT(isEmptyDVarSet fvs)    -- There should be no free variables
+    cgTopRhsClosure dflags rec bndr cc upd_flag args body
+
+
+---------------------------------------------------------------
+--      Module initialisation code
+---------------------------------------------------------------
+
+mkModuleInit
+        :: CollectedCCs         -- cost centre info
+        -> Module
+        -> HpcInfo
+        -> FCode ()
+
+mkModuleInit cost_centre_info this_mod hpc_info
+  = do  { initHpc this_mod hpc_info
+        ; initCostCentres cost_centre_info
+        }
+
+
+---------------------------------------------------------------
+--      Generating static stuff for algebraic data types
+---------------------------------------------------------------
+
+
+cgEnumerationTyCon :: TyCon -> FCode ()
+cgEnumerationTyCon tycon
+  = do dflags <- getDynFlags
+       emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
+             [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)
+                           (tagForCon dflags con)
+             | con <- tyConDataCons tycon]
+
+
+cgDataCon :: DataCon -> FCode ()
+-- Generate the entry code, info tables, and (for niladic constructor)
+-- the static closure, for a constructor.
+cgDataCon data_con
+  = do  { dflags <- getDynFlags
+        ; let
+            (tot_wds, --  #ptr_wds + #nonptr_wds
+             ptr_wds) --  #ptr_wds
+              = mkVirtConstrSizes dflags arg_reps
+
+            nonptr_wds   = tot_wds - ptr_wds
+
+            dyn_info_tbl =
+              mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds
+
+            -- We're generating info tables, so we don't know and care about
+            -- what the actual arguments are. Using () here as the place holder.
+            arg_reps :: [NonVoid PrimRep]
+            arg_reps = [ NonVoid rep_ty
+                       | ty <- dataConRepArgTys data_con
+                       , rep_ty <- typePrimRep ty
+                       , not (isVoidRep rep_ty) ]
+
+        ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $
+            -- NB: the closure pointer is assumed *untagged* on
+            -- entry to a constructor.  If the pointer is tagged,
+            -- then we should not be entering it.  This assumption
+            -- is used in ldvEnter and when tagging the pointer to
+            -- return it.
+            -- NB 2: We don't set CC when entering data (WDP 94/06)
+            do { tickyEnterDynCon
+               ; ldvEnter (CmmReg nodeReg)
+               ; tickyReturnOldCon (length arg_reps)
+               ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)]
+               }
+                    -- The case continuation code expects a tagged pointer
+        }
+
+---------------------------------------------------------------
+--      Stuff to support splitting
+---------------------------------------------------------------
+
+maybeExternaliseId :: DynFlags -> Id -> FCode Id
+maybeExternaliseId dflags id
+  | gopt Opt_SplitObjs dflags,  -- See Note [Externalise when splitting]
+                                -- in StgCmmMonad
+    isInternalName name = do { mod <- getModuleName
+                             ; return (setIdName id (externalise mod)) }
+  | otherwise           = return id
+  where
+    externalise mod = mkExternalName uniq mod new_occ loc
+    name    = idName id
+    uniq    = nameUnique name
+    new_occ = mkLocalOcc uniq (nameOccName name)
+    loc     = nameSrcSpan name
+        -- We want to conjure up a name that can't clash with any
+        -- existing name.  So we generate
+        --      Mod_$L243foo
+        -- where 243 is the unique.
diff --git a/compiler/codeGen/StgCmmArgRep.hs b/compiler/codeGen/StgCmmArgRep.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmArgRep.hs
@@ -0,0 +1,158 @@
+-----------------------------------------------------------------------------
+--
+-- Argument representations used in StgCmmLayout.
+--
+-- (c) The University of Glasgow 2013
+--
+-----------------------------------------------------------------------------
+
+module StgCmmArgRep (
+        ArgRep(..), toArgRep, argRepSizeW,
+
+        argRepString, isNonV, idArgRep,
+
+        slowCallPattern,
+
+        ) where
+
+import GhcPrelude
+
+import StgCmmClosure    ( idPrimRep )
+
+import SMRep            ( WordOff )
+import Id               ( Id )
+import TyCon            ( PrimRep(..), primElemRepSizeB )
+import BasicTypes       ( RepArity )
+import Constants        ( wORD64_SIZE )
+import DynFlags
+
+import Outputable
+import FastString
+
+-- I extricated this code as this new module in order to avoid a
+-- cyclic dependency between StgCmmLayout and StgCmmTicky.
+--
+-- NSF 18 Feb 2013
+
+-------------------------------------------------------------------------
+--      Classifying arguments: ArgRep
+-------------------------------------------------------------------------
+
+-- ArgRep is re-exported by StgCmmLayout, but only for use in the
+-- byte-code generator which also needs to know about the
+-- classification of arguments.
+
+data ArgRep = P   -- GC Ptr
+            | N   -- Word-sized non-ptr
+            | L   -- 64-bit non-ptr (long)
+            | V   -- Void
+            | F   -- Float
+            | D   -- Double
+            | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc.
+            | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc.
+            | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc.
+instance Outputable ArgRep where ppr = text . argRepString
+
+argRepString :: ArgRep -> String
+argRepString P = "P"
+argRepString N = "N"
+argRepString L = "L"
+argRepString V = "V"
+argRepString F = "F"
+argRepString D = "D"
+argRepString V16 = "V16"
+argRepString V32 = "V32"
+argRepString V64 = "V64"
+
+toArgRep :: PrimRep -> ArgRep
+toArgRep VoidRep           = V
+toArgRep LiftedRep         = P
+toArgRep UnliftedRep       = P
+toArgRep IntRep            = N
+toArgRep WordRep           = N
+toArgRep Int8Rep           = N  -- Gets widened to native word width for calls
+toArgRep Word8Rep          = N  -- Gets widened to native word width for calls
+toArgRep Int16Rep          = N  -- Gets widened to native word width for calls
+toArgRep Word16Rep         = N  -- Gets widened to native word width for calls
+toArgRep AddrRep           = N
+toArgRep Int64Rep          = L
+toArgRep Word64Rep         = L
+toArgRep FloatRep          = F
+toArgRep DoubleRep         = D
+toArgRep (VecRep len elem) = case len*primElemRepSizeB elem of
+                               16 -> V16
+                               32 -> V32
+                               64 -> V64
+                               _  -> error "toArgRep: bad vector primrep"
+
+isNonV :: ArgRep -> Bool
+isNonV V = False
+isNonV _ = True
+
+argRepSizeW :: DynFlags -> ArgRep -> WordOff                -- Size in words
+argRepSizeW _      N   = 1
+argRepSizeW _      P   = 1
+argRepSizeW _      F   = 1
+argRepSizeW dflags L   = wORD64_SIZE        `quot` wORD_SIZE dflags
+argRepSizeW dflags D   = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags
+argRepSizeW _      V   = 0
+argRepSizeW dflags V16 = 16                 `quot` wORD_SIZE dflags
+argRepSizeW dflags V32 = 32                 `quot` wORD_SIZE dflags
+argRepSizeW dflags V64 = 64                 `quot` wORD_SIZE dflags
+
+idArgRep :: Id -> ArgRep
+idArgRep = toArgRep . idPrimRep
+
+-- This list of argument patterns should be kept in sync with at least
+-- the following:
+--
+--  * StgCmmLayout.stdPattern maybe to some degree?
+--
+--  * the RTS_RET(stg_ap_*) and RTS_FUN_DECL(stg_ap_*_fast)
+--  declarations in includes/stg/MiscClosures.h
+--
+--  * the SLOW_CALL_*_ctr declarations in includes/stg/Ticky.h,
+--
+--  * the TICK_SLOW_CALL_*() #defines in includes/Cmm.h,
+--
+--  * the PR_CTR(SLOW_CALL_*_ctr) calls in rts/Ticky.c,
+--
+--  * and the SymI_HasProto(stg_ap_*_{ret,info,fast}) calls and
+--  SymI_HasProto(SLOW_CALL_*_ctr) calls in rts/Linker.c
+--
+-- There may be more places that I haven't found; I merely igrep'd for
+-- pppppp and excluded things that seemed ghci-specific.
+--
+-- Also, it seems at the moment that ticky counters with void
+-- arguments will never be bumped, but I'm still declaring those
+-- counters, defensively.
+--
+-- NSF 6 Mar 2013
+
+slowCallPattern :: [ArgRep] -> (FastString, RepArity)
+-- Returns the generic apply function and arity
+--
+-- The first batch of cases match (some) specialised entries
+-- The last group deals exhaustively with the cases for the first argument
+--   (and the zero-argument case)
+--
+-- In 99% of cases this function will match *all* the arguments in one batch
+
+slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)
+slowCallPattern (P: P: P: P: P: _)    = (fsLit "stg_ap_ppppp", 5)
+slowCallPattern (P: P: P: P: _)       = (fsLit "stg_ap_pppp", 4)
+slowCallPattern (P: P: P: V: _)       = (fsLit "stg_ap_pppv", 4)
+slowCallPattern (P: P: P: _)          = (fsLit "stg_ap_ppp", 3)
+slowCallPattern (P: P: V: _)          = (fsLit "stg_ap_ppv", 3)
+slowCallPattern (P: P: _)             = (fsLit "stg_ap_pp", 2)
+slowCallPattern (P: V: _)             = (fsLit "stg_ap_pv", 2)
+slowCallPattern (P: _)                = (fsLit "stg_ap_p", 1)
+slowCallPattern (V: _)                = (fsLit "stg_ap_v", 1)
+slowCallPattern (N: _)                = (fsLit "stg_ap_n", 1)
+slowCallPattern (F: _)                = (fsLit "stg_ap_f", 1)
+slowCallPattern (D: _)                = (fsLit "stg_ap_d", 1)
+slowCallPattern (L: _)                = (fsLit "stg_ap_l", 1)
+slowCallPattern (V16: _)              = (fsLit "stg_ap_v16", 1)
+slowCallPattern (V32: _)              = (fsLit "stg_ap_v32", 1)
+slowCallPattern (V64: _)              = (fsLit "stg_ap_v64", 1)
+slowCallPattern []                    = (fsLit "stg_ap_0", 0)
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -0,0 +1,751 @@
+-----------------------------------------------------------------------------
+--
+-- Stg to C-- code generation: bindings
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmBind (
+        cgTopRhsClosure,
+        cgBind,
+        emitBlackHoleCode,
+        pushUpdateFrame, emitUpdateFrame
+  ) where
+
+import GhcPrelude hiding ((<*>))
+
+import StgCmmExpr
+import StgCmmMonad
+import StgCmmEnv
+import StgCmmCon
+import StgCmmHeap
+import StgCmmProf (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,
+                   initUpdFrameProf)
+import StgCmmTicky
+import StgCmmLayout
+import StgCmmUtils
+import StgCmmClosure
+import StgCmmForeign    (emitPrimCall)
+
+import MkGraph
+import CoreSyn          ( AltCon(..), tickishIsCode )
+import BlockId
+import SMRep
+import Cmm
+import CmmInfo
+import CmmUtils
+import CLabel
+import StgSyn
+import CostCentre
+import Id
+import IdInfo
+import Name
+import Module
+import ListSetOps
+import Util
+import VarSet
+import BasicTypes
+import Outputable
+import FastString
+import DynFlags
+
+import Control.Monad
+
+------------------------------------------------------------------------
+--              Top-level bindings
+------------------------------------------------------------------------
+
+-- For closures bound at top level, allocate in static space.
+-- They should have no free variables.
+
+cgTopRhsClosure :: DynFlags
+                -> RecFlag              -- member of a recursive group?
+                -> Id
+                -> CostCentreStack      -- Optional cost centre annotation
+                -> UpdateFlag
+                -> [Id]                 -- Args
+                -> CgStgExpr
+                -> (CgIdInfo, FCode ())
+
+cgTopRhsClosure dflags rec id ccs upd_flag args body =
+  let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)
+      cg_id_info    = litIdInfo dflags id lf_info (CmmLabel closure_label)
+      lf_info       = mkClosureLFInfo dflags id TopLevel [] upd_flag args
+  in (cg_id_info, gen_code dflags lf_info closure_label)
+  where
+  -- special case for a indirection (f = g).  We create an IND_STATIC
+  -- closure pointing directly to the indirectee.  This is exactly
+  -- what the CAF will eventually evaluate to anyway, we're just
+  -- shortcutting the whole process, and generating a lot less code
+  -- (#7308)
+  --
+  -- Note: we omit the optimisation when this binding is part of a
+  -- recursive group, because the optimisation would inhibit the black
+  -- hole detection from working in that case.  Test
+  -- concurrent/should_run/4030 fails, for instance.
+  --
+  gen_code dflags _ closure_label
+    | StgApp f [] <- body, null args, isNonRec rec
+    = do
+         cg_info <- getCgIdInfo f
+         let closure_rep   = mkStaticClosureFields dflags
+                                    indStaticInfoTable ccs MayHaveCafRefs
+                                    [unLit (idInfoToAmode cg_info)]
+         emitDataLits closure_label closure_rep
+         return ()
+
+  gen_code dflags lf_info _closure_label
+   = do { let name = idName id
+        ; mod_name <- getModuleName
+        ; let descr         = closureDescription dflags mod_name name
+              closure_info  = mkClosureInfo dflags True id lf_info 0 0 descr
+
+        -- We don't generate the static closure here, because we might
+        -- want to add references to static closures to it later.  The
+        -- static closure is generated by CmmBuildInfoTables.updInfoSRTs,
+        -- See Note [SRTs], specifically the [FUN] optimisation.
+
+        ; let fv_details :: [(NonVoid Id, ByteOff)]
+              header = if isLFThunk lf_info then ThunkHeader else StdHeader
+              (_, _, fv_details) = mkVirtHeapOffsets dflags header []
+        -- Don't drop the non-void args until the closure info has been made
+        ; forkClosureBody (closureCodeBody True id closure_info ccs
+                                (nonVoidIds args) (length args) body fv_details)
+
+        ; return () }
+
+  unLit (CmmLit l) = l
+  unLit _ = panic "unLit"
+
+------------------------------------------------------------------------
+--              Non-top-level bindings
+------------------------------------------------------------------------
+
+cgBind :: CgStgBinding -> FCode ()
+cgBind (StgNonRec name rhs)
+  = do  { (info, fcode) <- cgRhs name rhs
+        ; addBindC info
+        ; init <- fcode
+        ; emit init }
+        -- init cannot be used in body, so slightly better to sink it eagerly
+
+cgBind (StgRec pairs)
+  = do  {  r <- sequence $ unzipWith cgRhs pairs
+        ;  let (id_infos, fcodes) = unzip r
+        ;  addBindsC id_infos
+        ;  (inits, body) <- getCodeR $ sequence fcodes
+        ;  emit (catAGraphs inits <*> body) }
+
+{- Note [cgBind rec]
+
+   Recursive let-bindings are tricky.
+   Consider the following pseudocode:
+
+     let x = \_ ->  ... y ...
+         y = \_ ->  ... z ...
+         z = \_ ->  ... x ...
+     in ...
+
+   For each binding, we need to allocate a closure, and each closure must
+   capture the address of the other closures.
+   We want to generate the following C-- code:
+     // Initialization Code
+     x = hp - 24; // heap address of x's closure
+     y = hp - 40; // heap address of x's closure
+     z = hp - 64; // heap address of x's closure
+     // allocate and initialize x
+     m[hp-8]   = ...
+     m[hp-16]  = y       // the closure for x captures y
+     m[hp-24] = x_info;
+     // allocate and initialize y
+     m[hp-32] = z;       // the closure for y captures z
+     m[hp-40] = y_info;
+     // allocate and initialize z
+     ...
+
+   For each closure, we must generate not only the code to allocate and
+   initialize the closure itself, but also some initialization Code that
+   sets a variable holding the closure pointer.
+
+   We could generate a pair of the (init code, body code), but since
+   the bindings are recursive we also have to initialise the
+   environment with the CgIdInfo for all the bindings before compiling
+   anything.  So we do this in 3 stages:
+
+     1. collect all the CgIdInfos and initialise the environment
+     2. compile each binding into (init, body) code
+     3. emit all the inits, and then all the bodies
+
+   We'd rather not have separate functions to do steps 1 and 2 for
+   each binding, since in pratice they share a lot of code.  So we
+   have just one function, cgRhs, that returns a pair of the CgIdInfo
+   for step 1, and a monadic computation to generate the code in step
+   2.
+
+   The alternative to separating things in this way is to use a
+   fixpoint.  That's what we used to do, but it introduces a
+   maintenance nightmare because there is a subtle dependency on not
+   being too strict everywhere.  Doing things this way means that the
+   FCode monad can be strict, for example.
+ -}
+
+cgRhs :: Id
+      -> CgStgRhs
+      -> FCode (
+                 CgIdInfo         -- The info for this binding
+               , FCode CmmAGraph  -- A computation which will generate the
+                                  -- code for the binding, and return an
+                                  -- assignent of the form "x = Hp - n"
+                                  -- (see above)
+               )
+
+cgRhs id (StgRhsCon cc con args)
+  = withNewTickyCounterCon (idName id) $
+    buildDynCon id True cc con (assertNonVoidStgArgs args)
+      -- con args are always non-void,
+      -- see Note [Post-unarisation invariants] in UnariseStg
+
+{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -}
+cgRhs id (StgRhsClosure fvs cc upd_flag args body)
+  = do dflags <- getDynFlags
+       mkRhsClosure dflags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body
+
+------------------------------------------------------------------------
+--              Non-constructor right hand sides
+------------------------------------------------------------------------
+
+mkRhsClosure :: DynFlags -> Id -> CostCentreStack
+             -> [NonVoid Id]                    -- Free vars
+             -> UpdateFlag
+             -> [Id]                            -- Args
+             -> CgStgExpr
+             -> FCode (CgIdInfo, FCode CmmAGraph)
+
+{- mkRhsClosure looks for two special forms of the right-hand side:
+        a) selector thunks
+        b) AP thunks
+
+If neither happens, it just calls mkClosureLFInfo.  You might think
+that mkClosureLFInfo should do all this, but it seems wrong for the
+latter to look at the structure of an expression
+
+Note [Selectors]
+~~~~~~~~~~~~~~~~
+We look at the body of the closure to see if it's a selector---turgid,
+but nothing deep.  We are looking for a closure of {\em exactly} the
+form:
+
+...  = [the_fv] \ u [] ->
+         case the_fv of
+           con a_1 ... a_n -> a_i
+
+Note [Ap thunks]
+~~~~~~~~~~~~~~~~
+A more generic AP thunk of the form
+
+        x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
+
+A set of these is compiled statically into the RTS, so we just use
+those.  We could extend the idea to thunks where some of the x_i are
+global ids (and hence not free variables), but this would entail
+generating a larger thunk.  It might be an option for non-optimising
+compilation, though.
+
+We only generate an Ap thunk if all the free variables are pointers,
+for semi-obvious reasons.
+
+-}
+
+---------- Note [Selectors] ------------------
+mkRhsClosure    dflags bndr _cc
+                [NonVoid the_fv]                -- Just one free var
+                upd_flag                -- Updatable thunk
+                []                      -- A thunk
+                expr
+  | let strip = snd . stripStgTicksTop (not . tickishIsCode)
+  , StgCase (StgApp scrutinee [{-no args-}])
+         _   -- ignore bndr
+         (AlgAlt _)
+         [(DataAlt _, params, sel_expr)] <- strip expr
+  , StgApp selectee [{-no args-}] <- strip sel_expr
+  , the_fv == scrutinee                -- Scrutinee is the only free variable
+
+  , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params))
+                                   -- pattern binders are always non-void,
+                                   -- see Note [Post-unarisation invariants] in UnariseStg
+  , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee)
+
+  , let offset_into_int = bytesToWordsRoundUp dflags the_offset
+                          - fixedHdrSizeW dflags
+  , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough
+  = -- NOT TRUE: ASSERT(is_single_constructor)
+    -- The simplifier may have statically determined that the single alternative
+    -- is the only possible case and eliminated the others, even if there are
+    -- other constructors in the datatype.  It's still ok to make a selector
+    -- thunk in this case, because we *know* which constructor the scrutinee
+    -- will evaluate to.
+    --
+    -- srt is discarded; it must be empty
+    let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
+    in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
+
+---------- Note [Ap thunks] ------------------
+mkRhsClosure    dflags bndr _cc
+                fvs
+                upd_flag
+                []                      -- No args; a thunk
+                (StgApp fun_id args)
+
+  -- We are looking for an "ApThunk"; see data con ApThunk in StgCmmClosure
+  -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)
+  -- So the xi will all be free variables
+  | args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and
+                               -- args are all distinct local variables
+                               -- The "-1" is for fun_id
+    -- Missed opportunity:   (f x x) is not detected
+  , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs
+  , isUpdatable upd_flag
+  , n_fvs <= mAX_SPEC_AP_SIZE dflags
+  , not (gopt Opt_SccProfilingOn dflags)
+                         -- not when profiling: we don't want to
+                         -- lose information about this particular
+                         -- thunk (e.g. its type) (#949)
+  , idArity fun_id == unknownArity -- don't spoil a known call
+
+          -- Ha! an Ap thunk
+  = cgRhsStdThunk bndr lf_info payload
+
+  where
+    n_fvs   = length fvs
+    lf_info = mkApLFInfo bndr upd_flag n_fvs
+    -- the payload has to be in the correct order, hence we can't
+    -- just use the fvs.
+    payload = StgVarArg fun_id : args
+
+---------- Default case ------------------
+mkRhsClosure dflags bndr cc fvs upd_flag args body
+  = do  { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args
+        ; (id_info, reg) <- rhsIdInfo bndr lf_info
+        ; return (id_info, gen_code lf_info reg) }
+ where
+ gen_code lf_info reg
+  = do  {       -- LAY OUT THE OBJECT
+        -- If the binder is itself a free variable, then don't store
+        -- it in the closure.  Instead, just bind it to Node on entry.
+        -- NB we can be sure that Node will point to it, because we
+        -- haven't told mkClosureLFInfo about this; so if the binder
+        -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
+        -- stored in the closure itself, so it will make sure that
+        -- Node points to it...
+        ; let   reduced_fvs = filter (NonVoid bndr /=) fvs
+
+        -- MAKE CLOSURE INFO FOR THIS CLOSURE
+        ; mod_name <- getModuleName
+        ; dflags <- getDynFlags
+        ; let   name  = idName bndr
+                descr = closureDescription dflags mod_name name
+                fv_details :: [(NonVoid Id, ByteOff)]
+                header = if isLFThunk lf_info then ThunkHeader else StdHeader
+                (tot_wds, ptr_wds, fv_details)
+                   = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs)
+                closure_info = mkClosureInfo dflags False       -- Not static
+                                             bndr lf_info tot_wds ptr_wds
+                                             descr
+
+        -- BUILD ITS INFO TABLE AND CODE
+        ; forkClosureBody $
+                -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
+                --                  (b) ignore Sequel from context; use empty Sequel
+                -- And compile the body
+                closureCodeBody False bndr closure_info cc (nonVoidIds args)
+                                (length args) body fv_details
+
+        -- BUILD THE OBJECT
+--      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
+        ; let use_cc = cccsExpr; blame_cc = cccsExpr
+        ; emit (mkComment $ mkFastString "calling allocDynClosure")
+        ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
+        ; let info_tbl = mkCmmInfo closure_info bndr currentCCS
+        ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc
+                                         (map toVarArg fv_details)
+
+        -- RETURN
+        ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
+
+-------------------------
+cgRhsStdThunk
+        :: Id
+        -> LambdaFormInfo
+        -> [StgArg]             -- payload
+        -> FCode (CgIdInfo, FCode CmmAGraph)
+
+cgRhsStdThunk bndr lf_info payload
+ = do  { (id_info, reg) <- rhsIdInfo bndr lf_info
+       ; return (id_info, gen_code reg)
+       }
+ where
+ gen_code reg  -- AHA!  A STANDARD-FORM THUNK
+  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $
+    do
+  {     -- LAY OUT THE OBJECT
+    mod_name <- getModuleName
+  ; dflags <- getDynFlags
+  ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader
+        (tot_wds, ptr_wds, payload_w_offsets)
+            = mkVirtHeapOffsets dflags header
+                (addArgReps (nonVoidStgArgs payload))
+
+        descr = closureDescription dflags mod_name (idName bndr)
+        closure_info = mkClosureInfo dflags False       -- Not static
+                                     bndr lf_info tot_wds ptr_wds
+                                     descr
+
+--  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
+  ; let use_cc = cccsExpr; blame_cc = cccsExpr
+
+
+        -- BUILD THE OBJECT
+  ; let info_tbl = mkCmmInfo closure_info bndr currentCCS
+  ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info
+                                   use_cc blame_cc payload_w_offsets
+
+        -- RETURN
+  ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
+
+
+mkClosureLFInfo :: DynFlags
+                -> Id           -- The binder
+                -> TopLevelFlag -- True of top level
+                -> [NonVoid Id] -- Free vars
+                -> UpdateFlag   -- Update flag
+                -> [Id]         -- Args
+                -> LambdaFormInfo
+mkClosureLFInfo dflags bndr top fvs upd_flag args
+  | null args =
+        mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag
+  | otherwise =
+        mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr dflags args)
+
+
+------------------------------------------------------------------------
+--              The code for closures
+------------------------------------------------------------------------
+
+closureCodeBody :: Bool            -- whether this is a top-level binding
+                -> Id              -- the closure's name
+                -> ClosureInfo     -- Lots of information about this closure
+                -> CostCentreStack -- Optional cost centre attached to closure
+                -> [NonVoid Id]    -- incoming args to the closure
+                -> Int             -- arity, including void args
+                -> CgStgExpr
+                -> [(NonVoid Id, ByteOff)] -- the closure's free vars
+                -> FCode ()
+
+{- There are two main cases for the code for closures.
+
+* If there are *no arguments*, then the closure is a thunk, and not in
+  normal form. So it should set up an update frame (if it is
+  shared). NB: Thunks cannot have a primitive type!
+
+* If there is *at least one* argument, then this closure is in
+  normal form, so there is no need to set up an update frame.
+-}
+
+closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details
+  | arity == 0 -- No args i.e. thunk
+  = withNewTickyCounterThunk
+        (isStaticClosure cl_info)
+        (closureUpdReqd cl_info)
+        (closureName cl_info) $
+    emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
+      \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
+   where
+     lf_info  = closureLFInfo cl_info
+     info_tbl = mkCmmInfo cl_info bndr cc
+
+closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
+  = -- Note: args may be [], if all args are Void
+    withNewTickyCounterFun
+        (closureSingleEntry cl_info)
+        (closureName cl_info)
+        args $ do {
+
+        ; let
+             lf_info  = closureLFInfo cl_info
+             info_tbl = mkCmmInfo cl_info bndr cc
+
+        -- Emit the main entry code
+        ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $
+            \(_offset, node, arg_regs) -> do
+                -- Emit slow-entry code (for entering a closure through a PAP)
+                { mkSlowEntryCode bndr cl_info arg_regs
+                ; dflags <- getDynFlags
+                ; let node_points = nodeMustPointToIt dflags lf_info
+                      node' = if node_points then Just node else Nothing
+                ; loop_header_id <- newBlockId
+                -- Extend reader monad with information that
+                -- self-recursive tail calls can be optimized into local
+                -- jumps. See Note [Self-recursive tail calls] in StgCmmExpr.
+                ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do
+                {
+                -- Main payload
+                ; entryHeapCheck cl_info node' arity arg_regs $ do
+                { -- emit LDV code when profiling
+                  when node_points (ldvEnterClosure cl_info (CmmLocal node))
+                -- ticky after heap check to avoid double counting
+                ; tickyEnterFun cl_info
+                ; enterCostCentreFun cc
+                    (CmmMachOp (mo_wordSub dflags)
+                         [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
+                         , mkIntExpr dflags (funTag dflags cl_info) ])
+                ; fv_bindings <- mapM bind_fv fv_details
+                -- Load free vars out of closure *after*
+                -- heap check, to reduce live vars over check
+                ; when node_points $ load_fvs node lf_info fv_bindings
+                ; void $ cgExpr body
+                }}}
+
+  }
+
+-- Note [NodeReg clobbered with loopification]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Previously we used to pass nodeReg (aka R1) here. With profiling, upon
+-- entering a closure, enterFunCCS was called with R1 passed to it. But since R1
+-- may get clobbered inside the body of a closure, and since a self-recursive
+-- tail call does not restore R1, a subsequent call to enterFunCCS received a
+-- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to
+-- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores
+-- the original value of R1. This way R1 may get modified but loopification will
+-- not care.
+
+-- A function closure pointer may be tagged, so we
+-- must take it into account when accessing the free variables.
+bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
+bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
+
+load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
+load_fvs node lf_info = mapM_ (\ (reg, off) ->
+   do dflags <- getDynFlags
+      let tag = lfDynTag dflags lf_info
+      emit $ mkTaggedObjectLoad dflags reg node off tag)
+
+-----------------------------------------
+-- The "slow entry" code for a function.  This entry point takes its
+-- arguments on the stack.  It loads the arguments into registers
+-- according to the calling convention, and jumps to the function's
+-- normal entry point.  The function's closure is assumed to be in
+-- R1/node.
+--
+-- The slow entry point is used for unknown calls: eg. stg_PAP_entry
+
+mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
+-- If this function doesn't have a specialised ArgDescr, we need
+-- to generate the function's arg bitmap and slow-entry code.
+-- Here, we emit the slow-entry code.
+mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
+  | Just (_, ArgGen _) <- closureFunInfo cl_info
+  = do dflags <- getDynFlags
+       let node = idToReg dflags (NonVoid bndr)
+           slow_lbl = closureSlowEntryLabel  cl_info
+           fast_lbl = closureLocalEntryLabel dflags cl_info
+           -- mkDirectJump does not clobber `Node' containing function closure
+           jump = mkJump dflags NativeNodeCall
+                                (mkLblExpr fast_lbl)
+                                (map (CmmReg . CmmLocal) (node : arg_regs))
+                                (initUpdFrameOff dflags)
+       tscope <- getTickScope
+       emitProcWithConvention Slow Nothing slow_lbl
+         (node : arg_regs) (jump, tscope)
+  | otherwise = return ()
+
+-----------------------------------------
+thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
+          -> LocalReg -> Int -> CgStgExpr -> FCode ()
+thunkCode cl_info fv_details _cc node arity body
+  = do { dflags <- getDynFlags
+       ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)
+             node'       = if node_points then Just node else Nothing
+        ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling
+
+        -- Heap overflow check
+        ; entryHeapCheck cl_info node' arity [] $ do
+        { -- Overwrite with black hole if necessary
+          -- but *after* the heap-overflow check
+        ; tickyEnterThunk cl_info
+        ; when (blackHoleOnEntry cl_info && node_points)
+                (blackHoleIt node)
+
+          -- Push update frame
+        ; setupUpdate cl_info node $
+            -- We only enter cc after setting up update so
+            -- that cc of enclosing scope will be recorded
+            -- in update frame CAF/DICT functions will be
+            -- subsumed by this enclosing cc
+            do { enterCostCentreThunk (CmmReg nodeReg)
+               ; let lf_info = closureLFInfo cl_info
+               ; fv_bindings <- mapM bind_fv fv_details
+               ; load_fvs node lf_info fv_bindings
+               ; void $ cgExpr body }}}
+
+
+------------------------------------------------------------------------
+--              Update and black-hole wrappers
+------------------------------------------------------------------------
+
+blackHoleIt :: LocalReg -> FCode ()
+-- Only called for closures with no args
+-- Node points to the closure
+blackHoleIt node_reg
+  = emitBlackHoleCode (CmmReg (CmmLocal node_reg))
+
+emitBlackHoleCode :: CmmExpr -> FCode ()
+emitBlackHoleCode node = do
+  dflags <- getDynFlags
+
+  -- Eager blackholing is normally disabled, but can be turned on with
+  -- -feager-blackholing.  When it is on, we replace the info pointer
+  -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.
+
+  -- If we wanted to do eager blackholing with slop filling, we'd need
+  -- to do it at the *end* of a basic block, otherwise we overwrite
+  -- the free variables in the thunk that we still need.  We have a
+  -- patch for this from Andy Cheadle, but not incorporated yet. --SDM
+  -- [6/2004]
+  --
+  -- Previously, eager blackholing was enabled when ticky-ticky was
+  -- on. But it didn't work, and it wasn't strictly necessary to bring
+  -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is
+  -- unconditionally disabled. -- krc 1/2007
+
+  -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,
+  -- because emitBlackHoleCode is called from CmmParse.
+
+  let  eager_blackholing =  not (gopt Opt_SccProfilingOn dflags)
+                         && gopt Opt_EagerBlackHoling dflags
+             -- Profiling needs slop filling (to support LDV
+             -- profiling), so currently eager blackholing doesn't
+             -- work with profiling.
+
+  when eager_blackholing $ do
+    emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr
+    emitPrimCall [] MO_WriteBarrier []
+    emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))
+
+setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
+        -- Nota Bene: this function does not change Node (even if it's a CAF),
+        -- so that the cost centre in the original closure can still be
+        -- extracted by a subsequent enterCostCentre
+setupUpdate closure_info node body
+  | not (lfUpdatable (closureLFInfo closure_info))
+  = body
+
+  | not (isStaticClosure closure_info)
+  = if not (closureUpdReqd closure_info)
+      then do tickyUpdateFrameOmitted; body
+      else do
+          tickyPushUpdateFrame
+          dflags <- getDynFlags
+          let
+              bh = blackHoleOnEntry closure_info &&
+                   not (gopt Opt_SccProfilingOn dflags) &&
+                   gopt Opt_EagerBlackHoling dflags
+
+              lbl | bh        = mkBHUpdInfoLabel
+                  | otherwise = mkUpdInfoLabel
+
+          pushUpdateFrame lbl (CmmReg (CmmLocal node)) body
+
+  | otherwise   -- A static closure
+  = do  { tickyUpdateBhCaf closure_info
+
+        ; if closureUpdReqd closure_info
+          then do       -- Blackhole the (updatable) CAF:
+                { upd_closure <- link_caf node True
+                ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }
+          else do {tickyUpdateFrameOmitted; body}
+    }
+
+-----------------------------------------------------------------------------
+-- Setting up update frames
+
+-- Push the update frame on the stack in the Entry area,
+-- leaving room for the return address that is already
+-- at the old end of the area.
+--
+pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()
+pushUpdateFrame lbl updatee body
+  = do
+       updfr  <- getUpdFrameOff
+       dflags <- getDynFlags
+       let
+           hdr         = fixedHdrSize dflags
+           frame       = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags
+       --
+       emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee
+       withUpdFrameOff frame body
+
+emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()
+emitUpdateFrame dflags frame lbl updatee = do
+  let
+           hdr         = fixedHdrSize dflags
+           off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags
+  --
+  emitStore frame (mkLblExpr lbl)
+  emitStore (cmmOffset dflags frame off_updatee) updatee
+  initUpdFrameProf frame
+
+-----------------------------------------------------------------------------
+-- Entering a CAF
+--
+-- See Note [CAF management] in rts/sm/Storage.c
+
+link_caf :: LocalReg           -- pointer to the closure
+         -> Bool               -- True <=> updatable, False <=> single-entry
+         -> FCode CmmExpr      -- Returns amode for closure to be updated
+-- This function returns the address of the black hole, so it can be
+-- updated with the new value when available.
+link_caf node _is_upd = do
+  { dflags <- getDynFlags
+        -- Call the RTS function newCAF, returning the newly-allocated
+        -- blackhole indirection closure
+  ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing
+                                    ForeignLabelInExternalPackage IsFunction
+  ; bh <- newTemp (bWord dflags)
+  ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl
+      [ (baseExpr,  AddrHint),
+        (CmmReg (CmmLocal node), AddrHint) ]
+      False
+
+  -- see Note [atomic CAF entry] in rts/sm/Storage.c
+  ; updfr  <- getUpdFrameOff
+  ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node)))
+  ; emit =<< mkCmmIfThen
+      (cmmEqWord dflags (CmmReg (CmmLocal bh)) (zeroExpr dflags))
+        -- re-enter the CAF
+       (mkJump dflags NativeNodeCall target [] updfr)
+
+  ; return (CmmReg (CmmLocal bh)) }
+
+------------------------------------------------------------------------
+--              Profiling
+------------------------------------------------------------------------
+
+-- For "global" data constructors the description is simply occurrence
+-- name of the data constructor itself.  Otherwise it is determined by
+-- @closureDescription@ from the let binding information.
+
+closureDescription :: DynFlags
+           -> Module            -- Module
+                   -> Name              -- Id of closure binding
+                   -> String
+        -- Not called for StgRhsCon which have global info tables built in
+        -- CgConTbls.hs with a description generated from the data constructor
+closureDescription dflags mod_name name
+  = showSDocDump dflags (char '<' <>
+                    (if isExternalName name
+                      then ppr name -- ppr will include the module name prefix
+                      else pprModule mod_name <> char '.' <> ppr name) <>
+                    char '>')
+   -- showSDocDump, because we want to see the unique on the Name.
diff --git a/compiler/codeGen/StgCmmBind.hs-boot b/compiler/codeGen/StgCmmBind.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmBind.hs-boot
@@ -0,0 +1,6 @@
+module StgCmmBind where
+
+import StgCmmMonad( FCode )
+import StgSyn( CgStgBinding )
+
+cgBind :: CgStgBinding -> FCode ()
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -0,0 +1,1000 @@
+{-# LANGUAGE CPP, RecordWildCards #-}
+
+-----------------------------------------------------------------------------
+--
+-- Stg to C-- code generation:
+--
+-- The types   LambdaFormInfo
+--             ClosureInfo
+--
+-- Nothing monadic in here!
+--
+-----------------------------------------------------------------------------
+
+module StgCmmClosure (
+        DynTag,  tagForCon, isSmallFamily,
+
+        idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,
+        argPrimRep,
+
+        NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,
+        assertNonVoidIds, assertNonVoidStgArgs,
+
+        -- * LambdaFormInfo
+        LambdaFormInfo,         -- Abstract
+        StandardFormInfo,        -- ...ditto...
+        mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
+        mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
+        mkLFStringLit,
+        lfDynTag,
+        isLFThunk, isLFReEntrant, lfUpdatable,
+
+        -- * Used by other modules
+        CgLoc(..), SelfLoopInfo, CallMethod(..),
+        nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod,
+
+        -- * ClosureInfo
+        ClosureInfo,
+        mkClosureInfo,
+        mkCmmInfo,
+
+        -- ** Inspection
+        closureLFInfo, closureName,
+
+        -- ** Labels
+        -- These just need the info table label
+        closureInfoLabel, staticClosureLabel,
+        closureSlowEntryLabel, closureLocalEntryLabel,
+
+        -- ** Predicates
+        -- These are really just functions on LambdaFormInfo
+        closureUpdReqd, closureSingleEntry,
+        closureReEntrant, closureFunInfo,
+        isToplevClosure,
+
+        blackHoleOnEntry,  -- Needs LambdaFormInfo and SMRep
+        isStaticClosure,   -- Needs SMPre
+
+        -- * InfoTables
+        mkDataConInfoTable,
+        cafBlackHoleInfoTable,
+        indStaticInfoTable,
+        staticClosureNeedsLink,
+    ) where
+
+#include "../includes/MachDeps.h"
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import StgSyn
+import SMRep
+import Cmm
+import PprCmmExpr()
+
+import CostCentre
+import BlockId
+import CLabel
+import Id
+import IdInfo
+import DataCon
+import Name
+import Type
+import TyCoRep
+import TcType
+import TyCon
+import RepType
+import BasicTypes
+import Outputable
+import DynFlags
+import Util
+
+import Data.Coerce (coerce)
+
+-----------------------------------------------------------------------------
+--                Data types and synonyms
+-----------------------------------------------------------------------------
+
+-- These data types are mostly used by other modules, especially StgCmmMonad,
+-- but we define them here because some functions in this module need to
+-- have access to them as well
+
+data CgLoc
+  = CmmLoc CmmExpr      -- A stable CmmExpr; that is, one not mentioning
+                        -- Hp, so that it remains valid across calls
+
+  | LneLoc BlockId [LocalReg]             -- A join point
+        -- A join point (= let-no-escape) should only
+        -- be tail-called, and in a saturated way.
+        -- To tail-call it, assign to these locals,
+        -- and branch to the block id
+
+instance Outputable CgLoc where
+  ppr (CmmLoc e)    = text "cmm" <+> ppr e
+  ppr (LneLoc b rs) = text "lne" <+> ppr b <+> ppr rs
+
+type SelfLoopInfo = (Id, BlockId, [LocalReg])
+
+-- used by ticky profiling
+isKnownFun :: LambdaFormInfo -> Bool
+isKnownFun LFReEntrant{} = True
+isKnownFun LFLetNoEscape = True
+isKnownFun _             = False
+
+
+-------------------------------------
+--        Non-void types
+-------------------------------------
+-- We frequently need the invariant that an Id or a an argument
+-- is of a non-void type. This type is a witness to the invariant.
+
+newtype NonVoid a = NonVoid a
+  deriving (Eq, Show)
+
+fromNonVoid :: NonVoid a -> a
+fromNonVoid (NonVoid a) = a
+
+instance (Outputable a) => Outputable (NonVoid a) where
+  ppr (NonVoid a) = ppr a
+
+nonVoidIds :: [Id] -> [NonVoid Id]
+nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))]
+
+-- | Used in places where some invariant ensures that all these Ids are
+-- non-void; e.g. constructor field binders in case expressions.
+-- See Note [Post-unarisation invariants] in UnariseStg.
+assertNonVoidIds :: [Id] -> [NonVoid Id]
+assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids))
+                       coerce ids
+
+nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
+nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))]
+
+-- | Used in places where some invariant ensures that all these arguments are
+-- non-void; e.g. constructor arguments.
+-- See Note [Post-unarisation invariants] in UnariseStg.
+assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]
+assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))
+                            coerce args
+
+
+-----------------------------------------------------------------------------
+--                Representations
+-----------------------------------------------------------------------------
+
+-- Why are these here?
+
+idPrimRep :: Id -> PrimRep
+idPrimRep id = typePrimRep1 (idType id)
+    -- NB: typePrimRep1 fails on unboxed tuples,
+    --     but by StgCmm no Ids have unboxed tuple type
+
+addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]
+addIdReps = map (\id -> let id' = fromNonVoid id
+                         in NonVoid (idPrimRep id', id'))
+
+addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
+addArgReps = map (\arg -> let arg' = fromNonVoid arg
+                           in NonVoid (argPrimRep arg', arg'))
+
+argPrimRep :: StgArg -> PrimRep
+argPrimRep arg = typePrimRep1 (stgArgType arg)
+
+
+-----------------------------------------------------------------------------
+--                LambdaFormInfo
+-----------------------------------------------------------------------------
+
+-- Information about an identifier, from the code generator's point of
+-- view.  Every identifier is bound to a LambdaFormInfo in the
+-- environment, which gives the code generator enough info to be able to
+-- tail call or return that identifier.
+
+data LambdaFormInfo
+  = LFReEntrant         -- Reentrant closure (a function)
+        TopLevelFlag    -- True if top level
+        OneShotInfo
+        !RepArity       -- Arity. Invariant: always > 0
+        !Bool           -- True <=> no fvs
+        ArgDescr        -- Argument descriptor (should really be in ClosureInfo)
+
+  | LFThunk             -- Thunk (zero arity)
+        TopLevelFlag
+        !Bool           -- True <=> no free vars
+        !Bool           -- True <=> updatable (i.e., *not* single-entry)
+        StandardFormInfo
+        !Bool           -- True <=> *might* be a function type
+
+  | LFCon               -- A saturated constructor application
+        DataCon         -- The constructor
+
+  | LFUnknown           -- Used for function arguments and imported things.
+                        -- We know nothing about this closure.
+                        -- Treat like updatable "LFThunk"...
+                        -- Imported things which we *do* know something about use
+                        -- one of the other LF constructors (eg LFReEntrant for
+                        -- known functions)
+        !Bool           -- True <=> *might* be a function type
+                        --      The False case is good when we want to enter it,
+                        --        because then we know the entry code will do
+                        --        For a function, the entry code is the fast entry point
+
+  | LFUnlifted          -- A value of unboxed type;
+                        -- always a value, needs evaluation
+
+  | LFLetNoEscape       -- See LetNoEscape module for precise description
+
+
+-------------------------
+-- StandardFormInfo tells whether this thunk has one of
+-- a small number of standard forms
+
+data StandardFormInfo
+  = NonStandardThunk
+        -- The usual case: not of the standard forms
+
+  | SelectorThunk
+        -- A SelectorThunk is of form
+        --      case x of
+        --           con a1,..,an -> ak
+        -- and the constructor is from a single-constr type.
+       WordOff          -- 0-origin offset of ak within the "goods" of
+                        -- constructor (Recall that the a1,...,an may be laid
+                        -- out in the heap in a non-obvious order.)
+
+  | ApThunk
+        -- An ApThunk is of form
+        --        x1 ... xn
+        -- The code for the thunk just pushes x2..xn on the stack and enters x1.
+        -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
+        -- in the RTS to save space.
+        RepArity                -- Arity, n
+
+
+------------------------------------------------------
+--                Building LambdaFormInfo
+------------------------------------------------------
+
+mkLFArgument :: Id -> LambdaFormInfo
+mkLFArgument id
+  | isUnliftedType ty      = LFUnlifted
+  | might_be_a_function ty = LFUnknown True
+  | otherwise              = LFUnknown False
+  where
+    ty = idType id
+
+-------------
+mkLFLetNoEscape :: LambdaFormInfo
+mkLFLetNoEscape = LFLetNoEscape
+
+-------------
+mkLFReEntrant :: TopLevelFlag    -- True of top level
+              -> [Id]            -- Free vars
+              -> [Id]            -- Args
+              -> ArgDescr        -- Argument descriptor
+              -> LambdaFormInfo
+
+mkLFReEntrant _ _ [] _
+  = pprPanic "mkLFReEntrant" empty
+mkLFReEntrant top fvs args arg_descr
+  = LFReEntrant top os_info (length args) (null fvs) arg_descr
+  where os_info = idOneShotInfo (head args)
+
+-------------
+mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
+mkLFThunk thunk_ty top fvs upd_flag
+  = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )
+    LFThunk top (null fvs)
+            (isUpdatable upd_flag)
+            NonStandardThunk
+            (might_be_a_function thunk_ty)
+
+--------------
+might_be_a_function :: Type -> Bool
+-- Return False only if we are *sure* it's a data type
+-- Look through newtypes etc as much as poss
+might_be_a_function ty
+  | [LiftedRep] <- typePrimRep ty
+  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)
+  , isDataTyCon tc
+  = False
+  | otherwise
+  = True
+
+-------------
+mkConLFInfo :: DataCon -> LambdaFormInfo
+mkConLFInfo con = LFCon con
+
+-------------
+mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo
+mkSelectorLFInfo id offset updatable
+  = LFThunk NotTopLevel False updatable (SelectorThunk offset)
+        (might_be_a_function (idType id))
+
+-------------
+mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo
+mkApLFInfo id upd_flag arity
+  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
+        (might_be_a_function (idType id))
+
+-------------
+mkLFImported :: Id -> LambdaFormInfo
+mkLFImported id
+  | Just con <- isDataConWorkId_maybe id
+  , isNullaryRepDataCon con
+  = LFCon con   -- An imported nullary constructor
+                -- We assume that the constructor is evaluated so that
+                -- the id really does point directly to the constructor
+
+  | arity > 0
+  = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")
+
+  | otherwise
+  = mkLFArgument id -- Not sure of exact arity
+  where
+    arity = idFunRepArity id
+
+-------------
+mkLFStringLit :: LambdaFormInfo
+mkLFStringLit = LFUnlifted
+
+-----------------------------------------------------
+--                Dynamic pointer tagging
+-----------------------------------------------------
+
+type DynTag = Int       -- The tag on a *pointer*
+                        -- (from the dynamic-tagging paper)
+
+-- Note [Data constructor dynamic tags]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- The family size of a data type (the number of constructors
+-- or the arity of a function) can be either:
+--    * small, if the family size < 2**tag_bits
+--    * big, otherwise.
+--
+-- Small families can have the constructor tag in the tag bits.
+-- Big families only use the tag value 1 to represent evaluatedness.
+-- We don't have very many tag bits: for example, we have 2 bits on
+-- x86-32 and 3 bits on x86-64.
+
+isSmallFamily :: DynFlags -> Int -> Bool
+isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags
+
+tagForCon :: DynFlags -> DataCon -> DynTag
+tagForCon dflags con
+  | isSmallFamily dflags fam_size = con_tag
+  | otherwise                     = 1
+  where
+    con_tag  = dataConTag con -- NB: 1-indexed
+    fam_size = tyConFamilySize (dataConTyCon con)
+
+tagForArity :: DynFlags -> RepArity -> DynTag
+tagForArity dflags arity
+ | isSmallFamily dflags arity = arity
+ | otherwise                  = 0
+
+lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag
+-- Return the tag in the low order bits of a variable bound
+-- to this LambdaForm
+lfDynTag dflags (LFCon con)                 = tagForCon dflags con
+lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity
+lfDynTag _      _other                      = 0
+
+
+-----------------------------------------------------------------------------
+--                Observing LambdaFormInfo
+-----------------------------------------------------------------------------
+
+------------
+isLFThunk :: LambdaFormInfo -> Bool
+isLFThunk (LFThunk {})  = True
+isLFThunk _ = False
+
+isLFReEntrant :: LambdaFormInfo -> Bool
+isLFReEntrant (LFReEntrant {}) = True
+isLFReEntrant _                = False
+
+-----------------------------------------------------------------------------
+--                Choosing SM reps
+-----------------------------------------------------------------------------
+
+lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
+lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd
+lfClosureType (LFCon con)                    = Constr (dataConTagZ con)
+                                                      (dataConIdentity con)
+lfClosureType (LFThunk _ _ _ is_sel _)       = thunkClosureType is_sel
+lfClosureType _                              = panic "lfClosureType"
+
+thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
+thunkClosureType (SelectorThunk off) = ThunkSelector off
+thunkClosureType _                   = Thunk
+
+-- We *do* get non-updatable top-level thunks sometimes.  eg. f = g
+-- gets compiled to a jump to g (if g has non-zero arity), instead of
+-- messing around with update frames and PAPs.  We set the closure type
+-- to FUN_STATIC in this case.
+
+-----------------------------------------------------------------------------
+--                nodeMustPointToIt
+-----------------------------------------------------------------------------
+
+nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool
+-- If nodeMustPointToIt is true, then the entry convention for
+-- this closure has R1 (the "Node" register) pointing to the
+-- closure itself --- the "self" argument
+
+nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)
+  =  not no_fvs          -- Certainly if it has fvs we need to point to it
+  || isNotTopLevel top   -- See Note [GC recovery]
+        -- For lex_profiling we also access the cost centre for a
+        -- non-inherited (i.e. non-top-level) function.
+        -- The isNotTopLevel test above ensures this is ok.
+
+nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)
+  =  not no_fvs            -- Self parameter
+  || isNotTopLevel top     -- Note [GC recovery]
+  || updatable             -- Need to push update frame
+  || gopt Opt_SccProfilingOn dflags
+          -- For the non-updatable (single-entry case):
+          --
+          -- True if has fvs (in which case we need access to them, and we
+          --                    should black-hole it)
+          -- or profiling (in which case we need to recover the cost centre
+          --                 from inside it)  ToDo: do we need this even for
+          --                                    top-level thunks? If not,
+          --                                    isNotTopLevel subsumes this
+
+nodeMustPointToIt _ (LFThunk {})        -- Node must point to a standard-form thunk
+  = True
+
+nodeMustPointToIt _ (LFCon _) = True
+
+        -- Strictly speaking, the above two don't need Node to point
+        -- to it if the arity = 0.  But this is a *really* unlikely
+        -- situation.  If we know it's nil (say) and we are entering
+        -- it. Eg: let x = [] in x then we will certainly have inlined
+        -- x, since nil is a simple atom.  So we gain little by not
+        -- having Node point to known zero-arity things.  On the other
+        -- hand, we do lose something; Patrick's code for figuring out
+        -- when something has been updated but not entered relies on
+        -- having Node point to the result of an update.  SLPJ
+        -- 27/11/92.
+
+nodeMustPointToIt _ (LFUnknown _)   = True
+nodeMustPointToIt _ LFUnlifted      = False
+nodeMustPointToIt _ LFLetNoEscape   = False
+
+{- Note [GC recovery]
+~~~~~~~~~~~~~~~~~~~~~
+If we a have a local let-binding (function or thunk)
+   let f = <body> in ...
+AND <body> allocates, then the heap-overflow check needs to know how
+to re-start the evaluation.  It uses the "self" pointer to do this.
+So even if there are no free variables in <body>, we still make
+nodeMustPointToIt be True for non-top-level bindings.
+
+Why do any such bindings exist?  After all, let-floating should have
+floated them out.  Well, a clever optimiser might leave one there to
+avoid a space leak, deliberately recomputing a thunk.  Also (and this
+really does happen occasionally) let-floating may make a function f smaller
+so it can be inlined, so now (f True) may generate a local no-fv closure.
+This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind
+in TcGenDeriv.) -}
+
+-----------------------------------------------------------------------------
+--                getCallMethod
+-----------------------------------------------------------------------------
+
+{- The entry conventions depend on the type of closure being entered,
+whether or not it has free variables, and whether we're running
+sequentially or in parallel.
+
+Closure                           Node   Argument   Enter
+Characteristics              Par   Req'd  Passing    Via
+---------------------------------------------------------------------------
+Unknown                     & no  & yes & stack     & node
+Known fun (>1 arg), no fvs  & no  & no  & registers & fast entry (enough args)
+                                                    & slow entry (otherwise)
+Known fun (>1 arg), fvs     & no  & yes & registers & fast entry (enough args)
+0 arg, no fvs \r,\s         & no  & no  & n/a       & direct entry
+0 arg, no fvs \u            & no  & yes & n/a       & node
+0 arg, fvs \r,\s,selector   & no  & yes & n/a       & node
+0 arg, fvs \r,\s            & no  & yes & n/a       & direct entry
+0 arg, fvs \u               & no  & yes & n/a       & node
+Unknown                     & yes & yes & stack     & node
+Known fun (>1 arg), no fvs  & yes & no  & registers & fast entry (enough args)
+                                                    & slow entry (otherwise)
+Known fun (>1 arg), fvs     & yes & yes & registers & node
+0 arg, fvs \r,\s,selector   & yes & yes & n/a       & node
+0 arg, no fvs \r,\s         & yes & no  & n/a       & direct entry
+0 arg, no fvs \u            & yes & yes & n/a       & node
+0 arg, fvs \r,\s            & yes & yes & n/a       & node
+0 arg, fvs \u               & yes & yes & n/a       & node
+
+When black-holing, single-entry closures could also be entered via node
+(rather than directly) to catch double-entry. -}
+
+data CallMethod
+  = EnterIt             -- No args, not a function
+
+  | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop
+
+  | ReturnIt            -- It's a value (function, unboxed value,
+                        -- or constructor), so just return it.
+
+  | SlowCall                -- Unknown fun, or known fun with
+                        -- too few args.
+
+  | DirectEntry         -- Jump directly, with args in regs
+        CLabel          --   The code label
+        RepArity        --   Its arity
+
+getCallMethod :: DynFlags
+              -> Name           -- Function being applied
+              -> Id             -- Function Id used to chech if it can refer to
+                                -- CAF's and whether the function is tail-calling
+                                -- itself
+              -> LambdaFormInfo -- Its info
+              -> RepArity       -- Number of available arguments
+              -> RepArity       -- Number of them being void arguments
+              -> CgLoc          -- Passed in from cgIdApp so that we can
+                                -- handle let-no-escape bindings and self-recursive
+                                -- tail calls using the same data constructor,
+                                -- JumpToIt. This saves us one case branch in
+                                -- cgIdApp
+              -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?
+              -> CallMethod
+
+getCallMethod dflags _ id _ n_args v_args _cg_loc
+              (Just (self_loop_id, block_id, args))
+  | gopt Opt_Loopification dflags
+  , id == self_loop_id
+  , args `lengthIs` (n_args - v_args)
+  -- If these patterns match then we know that:
+  --   * loopification optimisation is turned on
+  --   * function is performing a self-recursive call in a tail position
+  --   * number of non-void parameters of the function matches functions arity.
+  -- See Note [Self-recursive tail calls] and Note [Void arguments in
+  -- self-recursive tail calls] in StgCmmExpr for more details
+  = JumpToIt block_id args
+
+getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc
+              _self_loop_info
+  | n_args == 0 -- No args at all
+  && not (gopt Opt_SccProfilingOn dflags)
+     -- See Note [Evaluating functions with profiling] in rts/Apply.cmm
+  = ASSERT( arity /= 0 ) ReturnIt
+  | n_args < arity = SlowCall        -- Not enough args
+  | otherwise      = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity
+
+getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info
+  = ASSERT( n_args == 0 ) ReturnIt
+
+getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info
+  = ASSERT( n_args == 0 ) ReturnIt
+    -- n_args=0 because it'd be ill-typed to apply a saturated
+    --          constructor application to anything
+
+getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)
+              n_args _v_args _cg_loc _self_loop_info
+  | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)
+  = SlowCall    -- We cannot just enter it [in eval/apply, the entry code
+                -- is the fast-entry code]
+
+  -- Since is_fun is False, we are *definitely* looking at a data value
+  | updatable || gopt Opt_Ticky dflags -- to catch double entry
+      {- OLD: || opt_SMP
+         I decided to remove this, because in SMP mode it doesn't matter
+         if we enter the same thunk multiple times, so the optimisation
+         of jumping directly to the entry code is still valid.  --SDM
+        -}
+  = EnterIt
+
+  -- even a non-updatable selector thunk can be updated by the garbage
+  -- collector, so we must enter it. (#8817)
+  | SelectorThunk{} <- std_form_info
+  = EnterIt
+
+    -- We used to have ASSERT( n_args == 0 ), but actually it is
+    -- possible for the optimiser to generate
+    --   let bot :: Int = error Int "urk"
+    --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3
+    -- This happens as a result of the case-of-error transformation
+    -- So the right thing to do is just to enter the thing
+
+  | otherwise        -- Jump direct to code for single-entry thunks
+  = ASSERT( n_args == 0 )
+    DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info
+                updatable) 0
+
+getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info
+  = SlowCall -- might be a function
+
+getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info
+  = ASSERT2( n_args == 0, ppr name <+> ppr n_args )
+    EnterIt -- Not a function
+
+getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)
+              _self_loop_info
+  = JumpToIt blk_id lne_regs
+
+getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"
+
+-----------------------------------------------------------------------------
+--              Data types for closure information
+-----------------------------------------------------------------------------
+
+
+{- ClosureInfo: information about a binding
+
+   We make a ClosureInfo for each let binding (both top level and not),
+   but not bindings for data constructors: for those we build a CmmInfoTable
+   directly (see mkDataConInfoTable).
+
+   To a first approximation:
+       ClosureInfo = (LambdaFormInfo, CmmInfoTable)
+
+   A ClosureInfo has enough information
+     a) to construct the info table itself, and build other things
+        related to the binding (e.g. slow entry points for a function)
+     b) to allocate a closure containing that info pointer (i.e.
+           it knows the info table label)
+-}
+
+data ClosureInfo
+  = ClosureInfo {
+        closureName :: !Name,           -- The thing bound to this closure
+           -- we don't really need this field: it's only used in generating
+           -- code for ticky and profiling, and we could pass the information
+           -- around separately, but it doesn't do much harm to keep it here.
+
+        closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon
+          -- this tells us about what the closure contains: it's right-hand-side.
+
+          -- the rest is just an unpacked CmmInfoTable.
+        closureInfoLabel :: !CLabel,
+        closureSMRep     :: !SMRep,          -- representation used by storage mgr
+        closureProf      :: !ProfilingInfo
+    }
+
+-- | Convert from 'ClosureInfo' to 'CmmInfoTable'.
+mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
+mkCmmInfo ClosureInfo {..} id ccs
+  = CmmInfoTable { cit_lbl  = closureInfoLabel
+                 , cit_rep  = closureSMRep
+                 , cit_prof = closureProf
+                 , cit_srt  = Nothing
+                 , cit_clo  = if isStaticRep closureSMRep
+                                then Just (id,ccs)
+                                else Nothing }
+
+--------------------------------------
+--        Building ClosureInfos
+--------------------------------------
+
+mkClosureInfo :: DynFlags
+              -> Bool                -- Is static
+              -> Id
+              -> LambdaFormInfo
+              -> Int -> Int        -- Total and pointer words
+              -> String         -- String descriptor
+              -> ClosureInfo
+mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr
+  = ClosureInfo { closureName      = name
+                , closureLFInfo    = lf_info
+                , closureInfoLabel = info_lbl   -- These three fields are
+                , closureSMRep     = sm_rep     -- (almost) an info table
+                , closureProf      = prof }     -- (we don't have an SRT yet)
+  where
+    name       = idName id
+    sm_rep     = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
+    prof       = mkProfilingInfo dflags id val_descr
+    nonptr_wds = tot_wds - ptr_wds
+
+    info_lbl = mkClosureInfoTableLabel id lf_info
+
+--------------------------------------
+--   Other functions over ClosureInfo
+--------------------------------------
+
+-- Eager blackholing is normally disabled, but can be turned on with
+-- -feager-blackholing.  When it is on, we replace the info pointer of
+-- the thunk with stg_EAGER_BLACKHOLE_info on entry.
+
+-- If we wanted to do eager blackholing with slop filling,
+-- we'd need to do it at the *end* of a basic block, otherwise
+-- we overwrite the free variables in the thunk that we still
+-- need.  We have a patch for this from Andy Cheadle, but not
+-- incorporated yet. --SDM [6/2004]
+--
+-- Previously, eager blackholing was enabled when ticky-ticky
+-- was on. But it didn't work, and it wasn't strictly necessary
+-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
+-- is unconditionally disabled. -- krc 1/2007
+--
+-- Static closures are never themselves black-holed.
+
+blackHoleOnEntry :: ClosureInfo -> Bool
+blackHoleOnEntry cl_info
+  | isStaticRep (closureSMRep cl_info)
+  = False        -- Never black-hole a static closure
+
+  | otherwise
+  = case closureLFInfo cl_info of
+      LFReEntrant {}            -> False
+      LFLetNoEscape             -> False
+      LFThunk _ _no_fvs upd _ _ -> upd   -- See Note [Black-holing non-updatable thunks]
+      _other -> panic "blackHoleOnEntry"
+
+{- Note [Black-holing non-updatable thunks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must not black-hole non-updatable (single-entry) thunks otherwise
+we run into issues like Trac #10414. Specifically:
+
+  * There is no reason to black-hole a non-updatable thunk: it should
+    not be competed for by multiple threads
+
+  * It could, conceivably, cause a space leak if we don't black-hole
+    it, if there was a live but never-followed pointer pointing to it.
+    Let's hope that doesn't happen.
+
+  * It is dangerous to black-hole a non-updatable thunk because
+     - is not updated (of course)
+     - hence, if it is black-holed and another thread tries to evaluate
+       it, that thread will block forever
+    This actually happened in Trac #10414.  So we do not black-hole
+    non-updatable thunks.
+
+  * How could two threads evaluate the same non-updatable (single-entry)
+    thunk?  See Reid Barton's example below.
+
+  * Only eager blackholing could possibly black-hole a non-updatable
+    thunk, because lazy black-holing only affects thunks with an
+    update frame on the stack.
+
+Here is and example due to Reid Barton (Trac #10414):
+    x = \u []  concat [[1], []]
+with the following definitions,
+
+    concat x = case x of
+        []       -> []
+        (:) x xs -> (++) x (concat xs)
+
+    (++) xs ys = case xs of
+        []         -> ys
+        (:) x rest -> (:) x ((++) rest ys)
+
+Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to
+denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@
+to WHNF and calls @(++)@ the heap will contain the following thunks,
+
+    x = 1 : y
+    y = \u []  (++) [] z
+    z = \s []  concat []
+
+Now that the stage is set, consider the follow evaluations by two racing threads
+A and B,
+
+  1. Both threads enter @y@ before either is able to replace it with an
+     indirection
+
+  2. Thread A does the case analysis in @(++)@ and consequently enters @z@,
+     replacing it with a black-hole
+
+  3. At some later point thread B does the same case analysis and also attempts
+     to enter @z@. However, it finds that it has been replaced with a black-hole
+     so it blocks.
+
+  4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@
+     accordingly. It does *not* update @z@, however, as it is single-entry. This
+     leaves Thread B blocked forever on a black-hole which will never be
+     updated.
+
+To avoid this sort of condition we never black-hole non-updatable thunks.
+-}
+
+isStaticClosure :: ClosureInfo -> Bool
+isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
+
+closureUpdReqd :: ClosureInfo -> Bool
+closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info
+
+lfUpdatable :: LambdaFormInfo -> Bool
+lfUpdatable (LFThunk _ _ upd _ _)  = upd
+lfUpdatable _ = False
+
+closureSingleEntry :: ClosureInfo -> Bool
+closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
+closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True
+closureSingleEntry _ = False
+
+closureReEntrant :: ClosureInfo -> Bool
+closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True
+closureReEntrant _ = False
+
+closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)
+closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info
+
+lfFunInfo :: LambdaFormInfo ->  Maybe (RepArity, ArgDescr)
+lfFunInfo (LFReEntrant _ _ arity _ arg_desc)  = Just (arity, arg_desc)
+lfFunInfo _                                   = Nothing
+
+funTag :: DynFlags -> ClosureInfo -> DynTag
+funTag dflags (ClosureInfo { closureLFInfo = lf_info })
+    = lfDynTag dflags lf_info
+
+isToplevClosure :: ClosureInfo -> Bool
+isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
+  = case lf_info of
+      LFReEntrant TopLevel _ _ _ _ -> True
+      LFThunk TopLevel _ _ _ _     -> True
+      _other                       -> False
+
+--------------------------------------
+--   Label generation
+--------------------------------------
+
+staticClosureLabel :: ClosureInfo -> CLabel
+staticClosureLabel = toClosureLbl .  closureInfoLabel
+
+closureSlowEntryLabel :: ClosureInfo -> CLabel
+closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel
+
+closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel
+closureLocalEntryLabel dflags
+  | tablesNextToCode dflags = toInfoLbl  . closureInfoLabel
+  | otherwise               = toEntryLbl . closureInfoLabel
+
+mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel
+mkClosureInfoTableLabel id lf_info
+  = case lf_info of
+        LFThunk _ _ upd_flag (SelectorThunk offset) _
+                      -> mkSelectorInfoLabel upd_flag offset
+
+        LFThunk _ _ upd_flag (ApThunk arity) _
+                      -> mkApInfoTableLabel upd_flag arity
+
+        LFThunk{}     -> std_mk_lbl name cafs
+        LFReEntrant{} -> std_mk_lbl name cafs
+        _other        -> panic "closureInfoTableLabel"
+
+  where
+    name = idName id
+
+    std_mk_lbl | is_local  = mkLocalInfoTableLabel
+               | otherwise = mkInfoTableLabel
+
+    cafs     = idCafInfo id
+    is_local = isDataConWorkId id
+       -- Make the _info pointer for the implicit datacon worker
+       -- binding local. The reason we can do this is that importing
+       -- code always either uses the _closure or _con_info. By the
+       -- invariants in CorePrep anything else gets eta expanded.
+
+
+thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel
+-- thunkEntryLabel is a local help function, not exported.  It's used from
+-- getCallMethod.
+thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag
+  = enterApLabel dflags upd_flag arity
+thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag
+  = enterSelectorLabel dflags upd_flag offset
+thunkEntryLabel dflags thunk_id c _ _
+  = enterIdLabel dflags thunk_id c
+
+enterApLabel :: DynFlags -> Bool -> Arity -> CLabel
+enterApLabel dflags is_updatable arity
+  | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity
+  | otherwise               = mkApEntryLabel is_updatable arity
+
+enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel
+enterSelectorLabel dflags upd_flag offset
+  | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset
+  | otherwise               = mkSelectorEntryLabel upd_flag offset
+
+enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel
+enterIdLabel dflags id c
+  | tablesNextToCode dflags = mkInfoTableLabel id c
+  | otherwise               = mkEntryLabel id c
+
+
+--------------------------------------
+--   Profiling
+--------------------------------------
+
+-- Profiling requires two pieces of information to be determined for
+-- each closure's info table --- description and type.
+
+-- The description is stored directly in the @CClosureInfoTable@ when the
+-- info table is built.
+
+-- The type is determined from the type information stored with the @Id@
+-- in the closure info using @closureTypeDescr@.
+
+mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo
+mkProfilingInfo dflags id val_descr
+  | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
+  | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8
+  where
+    ty_descr_w8  = stringToWord8s (getTyDescription (idType id))
+    val_descr_w8 = stringToWord8s val_descr
+
+getTyDescription :: Type -> String
+getTyDescription ty
+  = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
+    case tau_ty of
+      TyVarTy _              -> "*"
+      AppTy fun _            -> getTyDescription fun
+      TyConApp tycon _       -> getOccString tycon
+      FunTy _ res            -> '-' : '>' : fun_result res
+      ForAllTy _  ty         -> getTyDescription ty
+      LitTy n                -> getTyLitDescription n
+      CastTy ty _            -> getTyDescription ty
+      CoercionTy co          -> pprPanic "getTyDescription" (ppr co)
+    }
+  where
+    fun_result (FunTy _ res) = '>' : fun_result res
+    fun_result other         = getTyDescription other
+
+getTyLitDescription :: TyLit -> String
+getTyLitDescription l =
+  case l of
+    NumTyLit n -> show n
+    StrTyLit n -> show n
+
+--------------------------------------
+--   CmmInfoTable-related things
+--------------------------------------
+
+mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable
+mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
+ = CmmInfoTable { cit_lbl  = info_lbl
+                , cit_rep  = sm_rep
+                , cit_prof = prof
+                , cit_srt  = Nothing
+                , cit_clo  = Nothing }
+ where
+   name = dataConName data_con
+   info_lbl = mkConInfoTableLabel name NoCafRefs
+   sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type
+   cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)
+                  -- We keep the *zero-indexed* tag in the srt_len field
+                  -- of the info table of a data constructor.
+
+   prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo
+        | otherwise                            = ProfilingInfo ty_descr val_descr
+
+   ty_descr  = stringToWord8s $ occNameString $ getOccName $ dataConTyCon data_con
+   val_descr = stringToWord8s $ occNameString $ getOccName data_con
+
+-- We need a black-hole closure info to pass to @allocDynClosure@ when we
+-- want to allocate the black hole on entry to a CAF.
+
+cafBlackHoleInfoTable :: CmmInfoTable
+cafBlackHoleInfoTable
+  = CmmInfoTable { cit_lbl  = mkCAFBlackHoleInfoTableLabel
+                 , cit_rep  = blackHoleRep
+                 , cit_prof = NoProfilingInfo
+                 , cit_srt  = Nothing
+                 , cit_clo  = Nothing }
+
+indStaticInfoTable :: CmmInfoTable
+indStaticInfoTable
+  = CmmInfoTable { cit_lbl  = mkIndStaticInfoLabel
+                 , cit_rep  = indStaticRep
+                 , cit_prof = NoProfilingInfo
+                 , cit_srt  = Nothing
+                 , cit_clo  = Nothing }
+
+staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
+-- A static closure needs a link field to aid the GC when traversing
+-- the static closure graph.  But it only needs such a field if either
+--        a) it has an SRT
+--        b) it's a constructor with one or more pointer fields
+-- In case (b), the constructor's fields themselves play the role
+-- of the SRT.
+staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }
+  | isConRep smrep         = not (isStaticNoCafCon smrep)
+  | otherwise              = has_srt
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -0,0 +1,285 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Stg to C--: code generation for constructors
+--
+-- This module provides the support code for StgCmm to deal with with
+-- constructors on the RHSs of let(rec)s.
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmCon (
+        cgTopRhsCon, buildDynCon, bindConArgs
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import StgSyn
+import CoreSyn  ( AltCon(..) )
+
+import StgCmmMonad
+import StgCmmEnv
+import StgCmmHeap
+import StgCmmLayout
+import StgCmmUtils
+import StgCmmClosure
+
+import CmmExpr
+import CmmUtils
+import CLabel
+import MkGraph
+import SMRep
+import CostCentre
+import Module
+import DataCon
+import DynFlags
+import FastString
+import Id
+import RepType (countConRepArgs)
+import Literal
+import PrelInfo
+import Outputable
+import Platform
+import Util
+import MonadUtils (mapMaybeM)
+
+import Control.Monad
+import Data.Char
+
+
+
+---------------------------------------------------------------
+--      Top-level constructors
+---------------------------------------------------------------
+
+cgTopRhsCon :: DynFlags
+            -> Id               -- Name of thing bound to this RHS
+            -> DataCon          -- Id
+            -> [NonVoid StgArg] -- Args
+            -> (CgIdInfo, FCode ())
+cgTopRhsCon dflags id con args =
+    let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)
+    in (id_info, gen_code)
+  where
+   name          = idName id
+   caffy         = idCafInfo id -- any stgArgHasCafRefs args
+   closure_label = mkClosureLabel name caffy
+
+   gen_code =
+     do { this_mod <- getModuleName
+        ; when (platformOS (targetPlatform dflags) == OSMinGW32) $
+              -- Windows DLLs have a problem with static cross-DLL refs.
+              MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )
+        ; ASSERT( args `lengthIs` countConRepArgs con ) return ()
+
+        -- LAY IT OUT
+        ; let
+            (tot_wds, --  #ptr_wds + #nonptr_wds
+             ptr_wds, --  #ptr_wds
+             nv_args_w_offsets) =
+                 mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args)
+
+            mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
+            mk_payload (FieldOff arg _) = do
+                amode <- getArgAmode arg
+                case amode of
+                  CmmLit lit -> return lit
+                  _          -> panic "StgCmmCon.cgTopRhsCon"
+
+            nonptr_wds = tot_wds - ptr_wds
+
+             -- we're not really going to emit an info table, so having
+             -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields
+             -- needs to poke around inside it.
+            info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds
+
+
+        ; payload <- mapM mk_payload nv_args_w_offsets
+                -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs
+                -- NB2: all the amodes should be Lits!
+                --      TODO (osa): Why?
+
+        ; let closure_rep = mkStaticClosureFields
+                             dflags
+                             info_tbl
+                             dontCareCCS                -- Because it's static data
+                             caffy                      -- Has CAF refs
+                             payload
+
+                -- BUILD THE OBJECT
+        ; emitDataLits closure_label closure_rep
+
+        ; return () }
+
+
+---------------------------------------------------------------
+--      Lay out and allocate non-top-level constructors
+---------------------------------------------------------------
+
+buildDynCon :: Id                 -- Name of the thing to which this constr will
+                                  -- be bound
+            -> Bool               -- is it genuinely bound to that name, or just
+                                  -- for profiling?
+            -> CostCentreStack    -- Where to grab cost centre from;
+                                  -- current CCS if currentOrSubsumedCCS
+            -> DataCon            -- The data constructor
+            -> [NonVoid StgArg]   -- Its args
+            -> FCode (CgIdInfo, FCode CmmAGraph)
+               -- Return details about how to find it and initialization code
+buildDynCon binder actually_bound cc con args
+    = do dflags <- getDynFlags
+         buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args
+
+
+buildDynCon' :: DynFlags
+             -> Platform
+             -> Id -> Bool
+             -> CostCentreStack
+             -> DataCon
+             -> [NonVoid StgArg]
+             -> FCode (CgIdInfo, FCode CmmAGraph)
+
+{- We used to pass a boolean indicating whether all the
+args were of size zero, so we could use a static
+constructor; but I concluded that it just isn't worth it.
+Now I/O uses unboxed tuples there just aren't any constructors
+with all size-zero args.
+
+The reason for having a separate argument, rather than looking at
+the addr modes of the args is that we may be in a "knot", and
+premature looking at the args will cause the compiler to black-hole!
+-}
+
+
+-------- buildDynCon': Nullary constructors --------------
+-- First we deal with the case of zero-arity constructors.  They
+-- will probably be unfolded, so we don't expect to see this case much,
+-- if at all, but it does no harm, and sets the scene for characters.
+--
+-- In the case of zero-arity constructors, or, more accurately, those
+-- which have exclusively size-zero (VoidRep) args, we generate no code
+-- at all.
+
+buildDynCon' dflags _ binder _ _cc con []
+  | isNullaryRepDataCon con
+  = return (litIdInfo dflags binder (mkConLFInfo con)
+                (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
+            return mkNop)
+
+-------- buildDynCon': Charlike and Intlike constructors -----------
+{- The following three paragraphs about @Char@-like and @Int@-like
+closures are obsolete, but I don't understand the details well enough
+to properly word them, sorry. I've changed the treatment of @Char@s to
+be analogous to @Int@s: only a subset is preallocated, because @Char@
+has now 31 bits. Only literals are handled here. -- Qrczak
+
+Now for @Char@-like closures.  We generate an assignment of the
+address of the closure to a temporary.  It would be possible simply to
+generate no code, and record the addressing mode in the environment,
+but we'd have to be careful if the argument wasn't a constant --- so
+for simplicity we just always assign to a temporary.
+
+Last special case: @Int@-like closures.  We only special-case the
+situation in which the argument is a literal in the range
+@mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can
+work with any old argument, but for @Int@-like ones the argument has
+to be a literal.  Reason: @Char@ like closures have an argument type
+which is guaranteed in range.
+
+Because of this, we use can safely return an addressing mode.
+
+We don't support this optimisation when compiling into Windows DLLs yet
+because they don't support cross package data references well.
+-}
+
+buildDynCon' dflags platform binder _ _cc con [arg]
+  | maybeIntLikeCon con
+  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)
+  , NonVoid (StgLitArg (LitNumber LitNumInt val _)) <- arg
+  , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!
+  , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...
+  = do  { let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE")
+              val_int = fromIntegral val :: Int
+              offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1)
+                -- INTLIKE closures consist of a header and one word payload
+              intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW
+        ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode
+                 , return mkNop) }
+
+buildDynCon' dflags platform binder _ _cc con [arg]
+  | maybeCharLikeCon con
+  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)
+  , NonVoid (StgLitArg (LitChar val)) <- arg
+  , let val_int = ord val :: Int
+  , val_int <= mAX_CHARLIKE dflags
+  , val_int >= mIN_CHARLIKE dflags
+  = do  { let charlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_CHARLIKE")
+              offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1)
+                -- CHARLIKE closures consist of a header and one word payload
+              charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW
+        ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode
+                 , return mkNop) }
+
+-------- buildDynCon': the general case -----------
+buildDynCon' dflags _ binder actually_bound ccs con args
+  = do  { (id_info, reg) <- rhsIdInfo binder lf_info
+        ; return (id_info, gen_code reg)
+        }
+ where
+  lf_info = mkConLFInfo con
+
+  gen_code reg
+    = do  { let (tot_wds, ptr_wds, args_w_offsets)
+                  = mkVirtConstrOffsets dflags (addArgReps args)
+                nonptr_wds = tot_wds - ptr_wds
+                info_tbl = mkDataConInfoTable dflags con False
+                                ptr_wds nonptr_wds
+          ; let ticky_name | actually_bound = Just binder
+                           | otherwise = Nothing
+
+          ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info
+                                          use_cc blame_cc args_w_offsets
+          ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
+    where
+      use_cc      -- cost-centre to stick in the object
+        | isCurrentCCS ccs = cccsExpr
+        | otherwise        = panic "buildDynCon: non-current CCS not implemented"
+
+      blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
+
+
+---------------------------------------------------------------
+--      Binding constructor arguments
+---------------------------------------------------------------
+
+bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
+-- bindConArgs is called from cgAlt of a case
+-- (bindConArgs con args) augments the environment with bindings for the
+-- binders args, assuming that we have just returned from a 'case' which
+-- found a con
+bindConArgs (DataAlt con) base args
+  = ASSERT(not (isUnboxedTupleCon con))
+    do dflags <- getDynFlags
+       let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)
+           tag = tagForCon dflags con
+
+           -- The binding below forces the masking out of the tag bits
+           -- when accessing the constructor field.
+           bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)
+           bind_arg (arg@(NonVoid b), offset)
+             | isDeadBinder b  -- See Note [Dead-binder optimisation] in StgCmmExpr
+             = return Nothing
+             | otherwise
+             = do { emit $ mkTaggedObjectLoad dflags (idToReg dflags arg)
+                                              base offset tag
+                  ; Just <$> bindArgToReg arg }
+
+       mapMaybeM bind_arg args_w_offsets
+
+bindConArgs _other_con _base args
+  = ASSERT( null args ) return []
diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -0,0 +1,208 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Stg to C-- code generation: the binding environment
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+module StgCmmEnv (
+        CgIdInfo,
+
+        litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,
+        idInfoToAmode,
+
+        addBindC, addBindsC,
+
+        bindArgsToRegs, bindToReg, rebindToReg,
+        bindArgToReg, idToReg,
+        getArgAmode, getNonVoidArgAmodes,
+        getCgIdInfo,
+        maybeLetNoEscape,
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TyCon
+import StgCmmMonad
+import StgCmmUtils
+import StgCmmClosure
+
+import CLabel
+
+import BlockId
+import CmmExpr
+import CmmUtils
+import DynFlags
+import Id
+import MkGraph
+import Name
+import Outputable
+import StgSyn
+import Type
+import TysPrim
+import UniqFM
+import Util
+import VarEnv
+
+-------------------------------------
+--        Manipulating CgIdInfo
+-------------------------------------
+
+mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo
+mkCgIdInfo id lf expr
+  = CgIdInfo { cg_id = id, cg_lf = lf
+             , cg_loc = CmmLoc expr }
+
+litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
+litIdInfo dflags id lf lit
+  = CgIdInfo { cg_id = id, cg_lf = lf
+             , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }
+  where
+    tag = lfDynTag dflags lf
+
+lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo
+lneIdInfo dflags id regs
+  = CgIdInfo { cg_id = id, cg_lf = lf
+             , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }
+  where
+    lf     = mkLFLetNoEscape
+    blk_id = mkBlockId (idUnique id)
+
+
+rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
+rhsIdInfo id lf_info
+  = do dflags <- getDynFlags
+       reg <- newTemp (gcWord dflags)
+       return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)
+
+mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
+mkRhsInit dflags reg lf_info expr
+  = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))
+
+idInfoToAmode :: CgIdInfo -> CmmExpr
+-- Returns a CmmExpr for the *tagged* pointer
+idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e
+idInfoToAmode cg_info
+  = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc
+
+addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr
+-- A tag adds a byte offset to the pointer
+addDynTag dflags expr tag = cmmOffsetB dflags expr tag
+
+maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])
+maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)
+maybeLetNoEscape _other                                      = Nothing
+
+
+
+---------------------------------------------------------
+--        The binding environment
+--
+-- There are three basic routines, for adding (addBindC),
+-- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.
+---------------------------------------------------------
+
+addBindC :: CgIdInfo -> FCode ()
+addBindC stuff_to_bind = do
+        binds <- getBinds
+        setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind
+
+addBindsC :: [CgIdInfo] -> FCode ()
+addBindsC new_bindings = do
+        binds <- getBinds
+        let new_binds = foldl' (\ binds info -> extendVarEnv binds (cg_id info) info)
+                               binds
+                               new_bindings
+        setBinds new_binds
+
+getCgIdInfo :: Id -> FCode CgIdInfo
+getCgIdInfo id
+  = do  { dflags <- getDynFlags
+        ; local_binds <- getBinds -- Try local bindings first
+        ; case lookupVarEnv local_binds id of {
+            Just info -> return info ;
+            Nothing   -> do {
+
+                -- Should be imported; make up a CgIdInfo for it
+          let name = idName id
+        ; if isExternalName name then
+              let ext_lbl
+                      | isUnliftedType (idType id) =
+                          -- An unlifted external Id must refer to a top-level
+                          -- string literal. See Note [Bytes label] in CLabel.
+                          ASSERT( idType id `eqType` addrPrimTy )
+                          mkBytesLabel name
+                      | otherwise = mkClosureLabel name $ idCafInfo id
+              in return $
+                  litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl)
+          else
+              cgLookupPanic id -- Bug
+        }}}
+
+cgLookupPanic :: Id -> FCode a
+cgLookupPanic id
+  = do  local_binds <- getBinds
+        pprPanic "StgCmmEnv: variable not found"
+                (vcat [ppr id,
+                text "local binds for:",
+                pprUFM local_binds $ \infos ->
+                  vcat [ ppr (cg_id info) | info <- infos ]
+              ])
+
+
+--------------------
+getArgAmode :: NonVoid StgArg -> FCode CmmExpr
+getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var
+getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit
+
+getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]
+-- NB: Filters out void args,
+--     so the result list may be shorter than the argument list
+getNonVoidArgAmodes [] = return []
+getNonVoidArgAmodes (arg:args)
+  | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args
+  | otherwise = do { amode  <- getArgAmode (NonVoid arg)
+                   ; amodes <- getNonVoidArgAmodes args
+                   ; return ( amode : amodes ) }
+
+
+------------------------------------------------------------------------
+--        Interface functions for binding and re-binding names
+------------------------------------------------------------------------
+
+bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg
+-- Bind an Id to a fresh LocalReg
+bindToReg nvid@(NonVoid id) lf_info
+  = do dflags <- getDynFlags
+       let reg = idToReg dflags nvid
+       addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))
+       return reg
+
+rebindToReg :: NonVoid Id -> FCode LocalReg
+-- Like bindToReg, but the Id is already in scope, so
+-- get its LF info from the envt
+rebindToReg nvid@(NonVoid id)
+  = do  { info <- getCgIdInfo id
+        ; bindToReg nvid (cg_lf info) }
+
+bindArgToReg :: NonVoid Id -> FCode LocalReg
+bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)
+
+bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]
+bindArgsToRegs args = mapM bindArgToReg args
+
+idToReg :: DynFlags -> NonVoid Id -> LocalReg
+-- Make a register from an Id, typically a function argument,
+-- free variable, or case binder
+--
+-- We re-use the Unique from the Id to make it easier to see what is going on
+--
+-- By now the Ids should be uniquely named; else one would worry
+-- about accidental collision
+idToReg dflags (NonVoid id)
+             = LocalReg (idUnique id)
+                        (primRepCmmType dflags (idPrimRep id))
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -0,0 +1,997 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Stg to C-- code generation: expressions
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmExpr ( cgExpr ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude hiding ((<*>))
+
+import {-# SOURCE #-} StgCmmBind ( cgBind )
+
+import StgCmmMonad
+import StgCmmHeap
+import StgCmmEnv
+import StgCmmCon
+import StgCmmProf (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC)
+import StgCmmLayout
+import StgCmmPrim
+import StgCmmHpc
+import StgCmmTicky
+import StgCmmUtils
+import StgCmmClosure
+
+import StgSyn
+
+import MkGraph
+import BlockId
+import Cmm
+import CmmInfo
+import CoreSyn
+import DataCon
+import ForeignCall
+import Id
+import PrimOp
+import TyCon
+import Type             ( isUnliftedType )
+import RepType          ( isVoidTy, countConRepArgs, primRepSlot )
+import CostCentre       ( CostCentreStack, currentCCS )
+import Maybes
+import Util
+import FastString
+import Outputable
+
+import Control.Monad (unless,void)
+import Control.Arrow (first)
+import Data.Function ( on )
+
+------------------------------------------------------------------------
+--              cgExpr: the main function
+------------------------------------------------------------------------
+
+cgExpr  :: CgStgExpr -> FCode ReturnKind
+
+cgExpr (StgApp fun args)     = cgIdApp fun args
+
+-- seq# a s ==> a
+-- See Note [seq# magic] in PrelRules
+cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
+  cgIdApp a []
+
+-- dataToTag# :: a -> Int#
+-- See Note [dataToTag#] in primops.txt.pp
+cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do
+  dflags <- getDynFlags
+  emitComment (mkFastString "dataToTag#")
+  tmp <- newTemp (bWord dflags)
+  _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])
+  -- TODO: For small types look at the tag bits instead of reading info table
+  emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))]
+
+cgExpr (StgOpApp op args ty) = cgOpApp op args ty
+cgExpr (StgConApp con args _)= cgConApp con args
+cgExpr (StgTick t e)         = cgTick t >> cgExpr e
+cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit
+                               emitReturn [CmmLit cmm_lit]
+
+cgExpr (StgLet _ binds expr) = do { cgBind binds;     cgExpr expr }
+cgExpr (StgLetNoEscape _ binds expr) =
+  do { u <- newUnique
+     ; let join_id = mkBlockId u
+     ; cgLneBinds join_id binds
+     ; r <- cgExpr expr
+     ; emitLabel join_id
+     ; return r }
+
+cgExpr (StgCase expr bndr alt_type alts) =
+  cgCase expr bndr alt_type alts
+
+cgExpr (StgLam {}) = panic "cgExpr: StgLam"
+
+------------------------------------------------------------------------
+--              Let no escape
+------------------------------------------------------------------------
+
+{- Generating code for a let-no-escape binding, aka join point is very
+very similar to what we do for a case expression.  The duality is
+between
+        let-no-escape x = b
+        in e
+and
+        case e of ... -> b
+
+That is, the RHS of 'x' (ie 'b') will execute *later*, just like
+the alternative of the case; it needs to be compiled in an environment
+in which all volatile bindings are forgotten, and the free vars are
+bound only to stable things like stack locations..  The 'e' part will
+execute *next*, just like the scrutinee of a case. -}
+
+-------------------------
+cgLneBinds :: BlockId -> CgStgBinding -> FCode ()
+cgLneBinds join_id (StgNonRec bndr rhs)
+  = do  { local_cc <- saveCurrentCostCentre
+                -- See Note [Saving the current cost centre]
+        ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs
+        ; fcode
+        ; addBindC info }
+
+cgLneBinds join_id (StgRec pairs)
+  = do  { local_cc <- saveCurrentCostCentre
+        ; r <- sequence $ unzipWith (cgLetNoEscapeRhs join_id local_cc) pairs
+        ; let (infos, fcodes) = unzip r
+        ; addBindsC infos
+        ; sequence_ fcodes
+        }
+
+-------------------------
+cgLetNoEscapeRhs
+    :: BlockId          -- join point for successor of let-no-escape
+    -> Maybe LocalReg   -- Saved cost centre
+    -> Id
+    -> CgStgRhs
+    -> FCode (CgIdInfo, FCode ())
+
+cgLetNoEscapeRhs join_id local_cc bndr rhs =
+  do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs
+     ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info
+     ; let code = do { (_, body) <- getCodeScoped rhs_code
+                     ; emitOutOfLine bid (first (<*> mkBranch join_id) body) }
+     ; return (info, code)
+     }
+
+cgLetNoEscapeRhsBody
+    :: Maybe LocalReg   -- Saved cost centre
+    -> Id
+    -> CgStgRhs
+    -> FCode (CgIdInfo, FCode ())
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body)
+  = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
+  = cgLetNoEscapeClosure bndr local_cc cc []
+      (StgConApp con args (pprPanic "cgLetNoEscapeRhsBody" $
+                           text "StgRhsCon doesn't have type args"))
+        -- For a constructor RHS we want to generate a single chunk of
+        -- code which can be jumped to from many places, which will
+        -- return the constructor. It's easy; just behave as if it
+        -- was an StgRhsClosure with a ConApp inside!
+
+-------------------------
+cgLetNoEscapeClosure
+        :: Id                   -- binder
+        -> Maybe LocalReg       -- Slot for saved current cost centre
+        -> CostCentreStack      -- XXX: *** NOT USED *** why not?
+        -> [NonVoid Id]         -- Args (as in \ args -> body)
+        -> CgStgExpr            -- Body (as in above)
+        -> FCode (CgIdInfo, FCode ())
+
+cgLetNoEscapeClosure bndr cc_slot _unused_cc args body
+  = do dflags <- getDynFlags
+       return ( lneIdInfo dflags bndr args
+              , code )
+  where
+   code = forkLneBody $ do {
+            ; withNewTickyCounterLNE (idName bndr) args $ do
+            ; restoreCurrentCostCentre cc_slot
+            ; arg_regs <- bindArgsToRegs args
+            ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) }
+
+
+------------------------------------------------------------------------
+--              Case expressions
+------------------------------------------------------------------------
+
+{- Note [Compiling case expressions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It is quite interesting to decide whether to put a heap-check at the
+start of each alternative.  Of course we certainly have to do so if
+the case forces an evaluation, or if there is a primitive op which can
+trigger GC.
+
+A more interesting situation is this (a Plan-B situation)
+
+        !P!;
+        ...P...
+        case x# of
+          0#      -> !Q!; ...Q...
+          default -> !R!; ...R...
+
+where !x! indicates a possible heap-check point. The heap checks
+in the alternatives *can* be omitted, in which case the topmost
+heapcheck will take their worst case into account.
+
+In favour of omitting !Q!, !R!:
+
+ - *May* save a heap overflow test,
+   if ...P... allocates anything.
+
+ - We can use relative addressing from a single Hp to
+   get at all the closures so allocated.
+
+ - No need to save volatile vars etc across heap checks
+   in !Q!, !R!
+
+Against omitting !Q!, !R!
+
+  - May put a heap-check into the inner loop.  Suppose
+        the main loop is P -> R -> P -> R...
+        Q is the loop exit, and only it does allocation.
+    This only hurts us if P does no allocation.  If P allocates,
+    then there is a heap check in the inner loop anyway.
+
+  - May do more allocation than reqd.  This sometimes bites us
+    badly.  For example, nfib (ha!) allocates about 30\% more space if the
+    worst-casing is done, because many many calls to nfib are leaf calls
+    which don't need to allocate anything.
+
+    We can un-allocate, but that costs an instruction
+
+Neither problem hurts us if there is only one alternative.
+
+Suppose the inner loop is P->R->P->R etc.  Then here is
+how many heap checks we get in the *inner loop* under various
+conditions
+
+  Alloc   Heap check in branches (!Q!, !R!)?
+  P Q R      yes     no (absorb to !P!)
+--------------------------------------
+  n n n      0          0
+  n y n      0          1
+  n . y      1          1
+  y . y      2          1
+  y . n      1          1
+
+Best choices: absorb heap checks from Q and R into !P! iff
+  a) P itself does some allocation
+or
+  b) P does allocation, or there is exactly one alternative
+
+We adopt (b) because that is more likely to put the heap check at the
+entry to a function, when not many things are live.  After a bunch of
+single-branch cases, we may have lots of things live
+
+Hence: two basic plans for
+
+        case e of r { alts }
+
+------ Plan A: the general case ---------
+
+        ...save current cost centre...
+
+        ...code for e,
+           with sequel (SetLocals r)
+
+        ...restore current cost centre...
+        ...code for alts...
+        ...alts do their own heap checks
+
+------ Plan B: special case when ---------
+  (i)  e does not allocate or call GC
+  (ii) either upstream code performs allocation
+       or there is just one alternative
+
+  Then heap allocation in the (single) case branch
+  is absorbed by the upstream check.
+  Very common example: primops on unboxed values
+
+        ...code for e,
+           with sequel (SetLocals r)...
+
+        ...code for alts...
+        ...no heap check...
+-}
+
+
+
+-------------------------------------
+data GcPlan
+  = GcInAlts            -- Put a GC check at the start the case alternatives,
+        [LocalReg]      -- which binds these registers
+  | NoGcInAlts          -- The scrutinee is a primitive value, or a call to a
+                        -- primitive op which does no GC.  Absorb the allocation
+                        -- of the case alternative(s) into the upstream check
+
+-------------------------------------
+cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind
+
+cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts
+  | isEnumerationTyCon tycon -- Note [case on bool]
+  = do { tag_expr <- do_enum_primop op args
+
+       -- If the binder is not dead, convert the tag to a constructor
+       -- and assign it. See Note [Dead-binder optimisation]
+       ; unless (isDeadBinder bndr) $ do
+            { dflags <- getDynFlags
+            ; tmp_reg <- bindArgToReg (NonVoid bndr)
+            ; emitAssign (CmmLocal tmp_reg)
+                         (tagToClosure dflags tycon tag_expr) }
+
+       ; (mb_deflt, branches) <- cgAlgAltRhss (NoGcInAlts,AssignedDirectly)
+                                              (NonVoid bndr) alts
+                                 -- See Note [GC for conditionals]
+       ; emitSwitch tag_expr branches mb_deflt 0 (tyConFamilySize tycon - 1)
+       ; return AssignedDirectly
+       }
+  where
+    do_enum_primop :: PrimOp -> [StgArg] -> FCode CmmExpr
+    do_enum_primop TagToEnumOp [arg]  -- No code!
+      = getArgAmode (NonVoid arg)
+    do_enum_primop primop args
+      = do dflags <- getDynFlags
+           tmp <- newTemp (bWord dflags)
+           cgPrimOp [tmp] primop args
+           return (CmmReg (CmmLocal tmp))
+
+{-
+Note [case on bool]
+~~~~~~~~~~~~~~~~~~~
+This special case handles code like
+
+  case a <# b of
+    True ->
+    False ->
+
+-->  case tagToEnum# (a <$# b) of
+        True -> .. ; False -> ...
+
+--> case (a <$# b) of r ->
+    case tagToEnum# r of
+        True -> .. ; False -> ...
+
+If we let the ordinary case code handle it, we'll get something like
+
+ tmp1 = a < b
+ tmp2 = Bool_closure_tbl[tmp1]
+ if (tmp2 & 7 != 0) then ... // normal tagged case
+
+but this junk won't optimise away.  What we really want is just an
+inline comparison:
+
+ if (a < b) then ...
+
+So we add a special case to generate
+
+ tmp1 = a < b
+ if (tmp1 == 0) then ...
+
+and later optimisations will further improve this.
+
+Now that #6135 has been resolved it should be possible to remove that
+special case. The idea behind this special case and pre-6135 implementation
+of Bool-returning primops was that tagToEnum# was added implicitly in the
+codegen and then optimized away. Now the call to tagToEnum# is explicit
+in the source code, which allows to optimize it away at the earlier stages
+of compilation (i.e. at the Core level).
+
+Note [Scrutinising VoidRep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have this STG code:
+   f = \[s : State# RealWorld] ->
+       case s of _ -> blah
+This is very odd.  Why are we scrutinising a state token?  But it
+can arise with bizarre NOINLINE pragmas (Trac #9964)
+    crash :: IO ()
+    crash = IO (\s -> let {-# NOINLINE s' #-}
+                          s' = s
+                      in (# s', () #))
+
+Now the trouble is that 's' has VoidRep, and we do not bind void
+arguments in the environment; they don't live anywhere.  See the
+calls to nonVoidIds in various places.  So we must not look up
+'s' in the environment.  Instead, just evaluate the RHS!  Simple.
+
+Note [Dead-binder optimisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A case-binder, or data-constructor argument, may be marked as dead,
+because we preserve occurrence-info on binders in CoreTidy (see
+CoreTidy.tidyIdBndr).
+
+If the binder is dead, we can sometimes eliminate a load.  While
+CmmSink will eliminate that load, it's very easy to kill it at source
+(giving CmmSink less work to do), and in any case CmmSink only runs
+with -O. Since the majority of case binders are dead, this
+optimisation probably still has a great benefit-cost ratio and we want
+to keep it for -O0. See also Phab:D5358.
+
+This probably also was the reason for occurrence hack in Phab:D5339 to
+exist, perhaps because the occurrence information preserved by
+'CoreTidy.tidyIdBndr' was insufficient.  But now that CmmSink does the
+job we deleted the hacks.
+-}
+
+cgCase (StgApp v []) _ (PrimAlt _) alts
+  | isVoidRep (idPrimRep v)  -- See Note [Scrutinising VoidRep]
+  , [(DEFAULT, _, rhs)] <- alts
+  = cgExpr rhs
+
+{- Note [Dodgy unsafeCoerce 1]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+    case (x :: HValue) |> co of (y :: MutVar# Int)
+        DEFAULT -> ...
+We want to gnerate an assignment
+     y := x
+We want to allow this assignment to be generated in the case when the
+types are compatible, because this allows some slightly-dodgy but
+occasionally-useful casts to be used, such as in RtClosureInspect
+where we cast an HValue to a MutVar# so we can print out the contents
+of the MutVar#.  If instead we generate code that enters the HValue,
+then we'll get a runtime panic, because the HValue really is a
+MutVar#.  The types are compatible though, so we can just generate an
+assignment.
+-}
+cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
+  | isUnliftedType (idType v)  -- Note [Dodgy unsafeCoerce 1]
+  || reps_compatible
+  = -- assignment suffices for unlifted types
+    do { dflags <- getDynFlags
+       ; unless reps_compatible $
+           pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
+                    (pp_bndr v $$ pp_bndr bndr)
+       ; v_info <- getCgIdInfo v
+       ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr)))
+                    (idInfoToAmode v_info)
+       -- Add bndr to the environment
+       ; _ <- bindArgToReg (NonVoid bndr)
+       ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }
+  where
+    reps_compatible = ((==) `on` (primRepSlot . idPrimRep)) v bndr
+      -- Must compare SlotTys, not proper PrimReps, because with unboxed sums,
+      -- the types of the binders are generated from slotPrimRep and might not
+      -- match. Test case:
+      --   swap :: (# Int | Int #) -> (# Int | Int #)
+      --   swap (# x | #) = (# | x #)
+      --   swap (# | y #) = (# y | #)
+
+    pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id))
+
+{- Note [Dodgy unsafeCoerce 2, #3132]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In all other cases of a lifted Id being cast to an unlifted type, the
+Id should be bound to bottom, otherwise this is an unsafe use of
+unsafeCoerce.  We can generate code to enter the Id and assume that
+it will never return.  Hence, we emit the usual enter/return code, and
+because bottom must be untagged, it will be entered.  The Sequel is a
+type-correct assignment, albeit bogus.  The (dead) continuation loops;
+it would be better to invoke some kind of panic function here.
+-}
+cgCase scrut@(StgApp v []) _ (PrimAlt _) _
+  = do { dflags <- getDynFlags
+       ; mb_cc <- maybeSaveCostCentre True
+       ; _ <- withSequel
+                  (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut)
+       ; restoreCurrentCostCentre mb_cc
+       ; emitComment $ mkFastString "should be unreachable code"
+       ; l <- newBlockId
+       ; emitLabel l
+       ; emit (mkBranch l)  -- an infinite loop
+       ; return AssignedDirectly
+       }
+
+{- Note [Handle seq#]
+~~~~~~~~~~~~~~~~~~~~~
+See Note [seq# magic] in PrelRules.
+The special case for seq# in cgCase does this:
+
+  case seq# a s of v
+    (# s', a' #) -> e
+==>
+  case a of v
+    (# s', a' #) -> e
+
+(taking advantage of the fact that the return convention for (# State#, a #)
+is the same as the return convention for just 'a')
+-}
+
+cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts
+  = -- Note [Handle seq#]
+    -- And see Note [seq# magic] in PrelRules
+    -- Use the same return convention as vanilla 'a'.
+    cgCase (StgApp a []) bndr alt_type alts
+
+cgCase scrut bndr alt_type alts
+  = -- the general case
+    do { dflags <- getDynFlags
+       ; up_hp_usg <- getVirtHp        -- Upstream heap usage
+       ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts
+             alt_regs  = map (idToReg dflags) ret_bndrs
+       ; simple_scrut <- isSimpleScrut scrut alt_type
+       ; let do_gc  | is_cmp_op scrut  = False  -- See Note [GC for conditionals]
+                    | not simple_scrut = True
+                    | isSingleton alts = False
+                    | up_hp_usg > 0    = False
+                    | otherwise        = True
+               -- cf Note [Compiling case expressions]
+             gc_plan = if do_gc then GcInAlts alt_regs else NoGcInAlts
+
+       ; mb_cc <- maybeSaveCostCentre simple_scrut
+
+       ; let sequel = AssignTo alt_regs do_gc{- Note [scrut sequel] -}
+       ; ret_kind <- withSequel sequel (cgExpr scrut)
+       ; restoreCurrentCostCentre mb_cc
+       ; _ <- bindArgsToRegs ret_bndrs
+       ; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts
+       }
+  where
+    is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op
+    is_cmp_op _                             = False
+
+{- Note [GC for conditionals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For boolean conditionals it seems that we have always done NoGcInAlts.
+That is, we have always done the GC check before the conditional.
+This is enshrined in the special case for
+   case tagToEnum# (a>b) of ...
+See Note [case on bool]
+
+It's odd, and it's flagrantly inconsistent with the rules described
+Note [Compiling case expressions].  However, after eliminating the
+tagToEnum# (Trac #13397) we will have:
+   case (a>b) of ...
+Rather than make it behave quite differently, I am testing for a
+comparison operator here in in the general case as well.
+
+ToDo: figure out what the Right Rule should be.
+
+Note [scrut sequel]
+~~~~~~~~~~~~~~~~~~~
+The job of the scrutinee is to assign its value(s) to alt_regs.
+Additionally, if we plan to do a heap-check in the alternatives (see
+Note [Compiling case expressions]), then we *must* retreat Hp to
+recover any unused heap before passing control to the sequel.  If we
+don't do this, then any unused heap will become slop because the heap
+check will reset the heap usage. Slop in the heap breaks LDV profiling
+(+RTS -hb) which needs to do a linear sweep through the nursery.
+
+
+Note [Inlining out-of-line primops and heap checks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If shouldInlinePrimOp returns True when called from StgCmmExpr for the
+purpose of heap check placement, we *must* inline the primop later in
+StgCmmPrim. If we don't things will go wrong.
+-}
+
+-----------------
+maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)
+maybeSaveCostCentre simple_scrut
+  | simple_scrut = return Nothing
+  | otherwise    = saveCurrentCostCentre
+
+
+-----------------
+isSimpleScrut :: CgStgExpr -> AltType -> FCode Bool
+-- Simple scrutinee, does not block or allocate; hence safe to amalgamate
+-- heap usage from alternatives into the stuff before the case
+-- NB: if you get this wrong, and claim that the expression doesn't allocate
+--     when it does, you'll deeply mess up allocation
+isSimpleScrut (StgOpApp op args _) _       = isSimpleOp op args
+isSimpleScrut (StgLit _)       _           = return True       -- case 1# of { 0# -> ..; ... }
+isSimpleScrut (StgApp _ [])    (PrimAlt _) = return True       -- case x# of { 0# -> ..; ... }
+isSimpleScrut _                _           = return False
+
+isSimpleOp :: StgOp -> [StgArg] -> FCode Bool
+-- True iff the op cannot block or allocate
+isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)
+-- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp
+isSimpleOp (StgPrimOp DataToTagOp) _ = return False
+isSimpleOp (StgPrimOp op) stg_args                  = do
+    arg_exprs <- getNonVoidArgAmodes stg_args
+    dflags <- getDynFlags
+    -- See Note [Inlining out-of-line primops and heap checks]
+    return $! isJust $ shouldInlinePrimOp dflags op arg_exprs
+isSimpleOp (StgPrimCallOp _) _                           = return False
+
+-----------------
+chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id]
+-- These are the binders of a case that are assigned by the evaluation of the
+-- scrutinee.
+-- They're non-void, see Note [Post-unarisation invariants] in UnariseStg.
+chooseReturnBndrs bndr (PrimAlt _) _alts
+  = assertNonVoidIds [bndr]
+
+chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]
+  = ASSERT2(ids `lengthIs` n, ppr n $$ ppr ids $$ ppr _bndr)
+    assertNonVoidIds ids     -- 'bndr' is not assigned!
+
+chooseReturnBndrs bndr (AlgAlt _) _alts
+  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned
+
+chooseReturnBndrs bndr PolyAlt _alts
+  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned
+
+chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"
+                             -- MultiValAlt has only one alternative
+
+-------------------------------------
+cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]
+       -> FCode ReturnKind
+-- At this point the result of the case are in the binders
+cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)]
+  = maybeAltHeapCheck gc_plan (cgExpr rhs)
+
+cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)]
+  = maybeAltHeapCheck gc_plan (cgExpr rhs)
+        -- Here bndrs are *already* in scope, so don't rebind them
+
+cgAlts gc_plan bndr (PrimAlt _) alts
+  = do  { dflags <- getDynFlags
+
+        ; tagged_cmms <- cgAltRhss gc_plan bndr alts
+
+        ; let bndr_reg = CmmLocal (idToReg dflags bndr)
+              (DEFAULT,deflt) = head tagged_cmms
+                -- PrimAlts always have a DEFAULT case
+                -- and it always comes first
+
+              tagged_cmms' = [(lit,code)
+                             | (LitAlt lit, code) <- tagged_cmms]
+        ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt
+        ; return AssignedDirectly }
+
+cgAlts gc_plan bndr (AlgAlt tycon) alts
+  = do  { dflags <- getDynFlags
+
+        ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts
+
+        ; let fam_sz   = tyConFamilySize tycon
+              bndr_reg = CmmLocal (idToReg dflags bndr)
+
+                    -- Is the constructor tag in the node reg?
+        ; if isSmallFamily dflags fam_sz
+          then do
+                let   -- Yes, bndr_reg has constr. tag in ls bits
+                   tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)
+                   branches' = [(tag+1,branch) | (tag,branch) <- branches]
+                emitSwitch tag_expr branches' mb_deflt 1 fam_sz
+
+           else -- No, get tag from info table
+                let -- Note that ptr _always_ has tag 1
+                    -- when the family size is big enough
+                    untagged_ptr = cmmRegOffB bndr_reg (-1)
+                    tag_expr = getConstrTag dflags (untagged_ptr)
+                in emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
+
+        ; return AssignedDirectly }
+
+cgAlts _ _ _ _ = panic "cgAlts"
+        -- UbxTupAlt and PolyAlt have only one alternative
+
+
+-- Note [alg-alt heap check]
+--
+-- In an algebraic case with more than one alternative, we will have
+-- code like
+--
+-- L0:
+--   x = R1
+--   goto L1
+-- L1:
+--   if (x & 7 >= 2) then goto L2 else goto L3
+-- L2:
+--   Hp = Hp + 16
+--   if (Hp > HpLim) then goto L4
+--   ...
+-- L4:
+--   call gc() returns to L5
+-- L5:
+--   x = R1
+--   goto L1
+
+-------------------
+cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
+             -> FCode ( Maybe CmmAGraphScoped
+                      , [(ConTagZ, CmmAGraphScoped)] )
+cgAlgAltRhss gc_plan bndr alts
+  = do { tagged_cmms <- cgAltRhss gc_plan bndr alts
+
+       ; let { mb_deflt = case tagged_cmms of
+                           ((DEFAULT,rhs) : _) -> Just rhs
+                           _other              -> Nothing
+                            -- DEFAULT is always first, if present
+
+              ; branches = [ (dataConTagZ con, cmm)
+                           | (DataAlt con, cmm) <- tagged_cmms ]
+              }
+
+       ; return (mb_deflt, branches)
+       }
+
+
+-------------------
+cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
+          -> FCode [(AltCon, CmmAGraphScoped)]
+cgAltRhss gc_plan bndr alts = do
+  dflags <- getDynFlags
+  let
+    base_reg = idToReg dflags bndr
+    cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)
+    cg_alt (con, bndrs, rhs)
+      = getCodeScoped             $
+        maybeAltHeapCheck gc_plan $
+        do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs)
+                    -- alt binders are always non-void,
+                    -- see Note [Post-unarisation invariants] in UnariseStg
+           ; _ <- cgExpr rhs
+           ; return con }
+  forkAlts (map cg_alt alts)
+
+maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a
+maybeAltHeapCheck (NoGcInAlts,_)  code = code
+maybeAltHeapCheck (GcInAlts regs, AssignedDirectly) code =
+  altHeapCheck regs code
+maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code =
+  altHeapCheckReturnsTo regs lret off code
+
+-----------------------------------------------------------------------------
+--      Tail calls
+-----------------------------------------------------------------------------
+
+cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind
+cgConApp con stg_args
+  | isUnboxedTupleCon con       -- Unboxed tuple: assign and return
+  = do { arg_exprs <- getNonVoidArgAmodes stg_args
+       ; tickyUnboxedTupleReturn (length arg_exprs)
+       ; emitReturn arg_exprs }
+
+  | otherwise   --  Boxed constructors; allocate and return
+  = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args )
+    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False
+                                     currentCCS con (assertNonVoidStgArgs stg_args)
+                                     -- con args are always non-void,
+                                     -- see Note [Post-unarisation invariants] in UnariseStg
+                -- The first "con" says that the name bound to this
+                -- closure is "con", which is a bit of a fudge, but
+                -- it only affects profiling (hence the False)
+
+        ; emit =<< fcode_init
+        ; tickyReturnNewCon (length stg_args)
+        ; emitReturn [idInfoToAmode idinfo] }
+
+cgIdApp :: Id -> [StgArg] -> FCode ReturnKind
+cgIdApp fun_id args = do
+    dflags         <- getDynFlags
+    fun_info       <- getCgIdInfo fun_id
+    self_loop_info <- getSelfLoop
+    let cg_fun_id   = cg_id fun_info
+           -- NB: use (cg_id fun_info) instead of fun_id, because
+           -- the former may be externalised for -split-objs.
+           -- See Note [Externalise when splitting] in StgCmmMonad
+
+        fun_arg     = StgVarArg cg_fun_id
+        fun_name    = idName    cg_fun_id
+        fun         = idInfoToAmode fun_info
+        lf_info     = cg_lf         fun_info
+        n_args      = length args
+        v_args      = length $ filter (isVoidTy . stgArgType) args
+        node_points dflags = nodeMustPointToIt dflags lf_info
+    case getCallMethod dflags fun_name cg_fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of
+            -- A value in WHNF, so we can just return it.
+        ReturnIt
+          | isVoidTy (idType fun_id) -> emitReturn []
+          | otherwise                -> emitReturn [fun]
+          -- ToDo: does ReturnIt guarantee tagged?
+
+        EnterIt -> ASSERT( null args )  -- Discarding arguments
+                   emitEnter fun
+
+        SlowCall -> do      -- A slow function call via the RTS apply routines
+                { tickySlowCall lf_info args
+                ; emitComment $ mkFastString "slowCall"
+                ; slowCall fun args }
+
+        -- A direct function call (possibly with some left-over arguments)
+        DirectEntry lbl arity -> do
+                { tickyDirectCall arity args
+                ; if node_points dflags
+                     then directCall NativeNodeCall   lbl arity (fun_arg:args)
+                     else directCall NativeDirectCall lbl arity args }
+
+        -- Let-no-escape call or self-recursive tail-call
+        JumpToIt blk_id lne_regs -> do
+          { adjustHpBackwards -- always do this before a tail-call
+          ; cmm_args <- getNonVoidArgAmodes args
+          ; emitMultiAssign lne_regs cmm_args
+          ; emit (mkBranch blk_id)
+          ; return AssignedDirectly }
+
+-- Note [Self-recursive tail calls]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Self-recursive tail calls can be optimized into a local jump in the same
+-- way as let-no-escape bindings (see Note [What is a non-escaping let] in
+-- stgSyn/CoreToStg.hs). Consider this:
+--
+-- foo.info:
+--     a = R1  // calling convention
+--     b = R2
+--     goto L1
+-- L1: ...
+--     ...
+-- ...
+-- L2: R1 = x
+--     R2 = y
+--     call foo(R1,R2)
+--
+-- Instead of putting x and y into registers (or other locations required by the
+-- calling convention) and performing a call we can put them into local
+-- variables a and b and perform jump to L1:
+--
+-- foo.info:
+--     a = R1
+--     b = R2
+--     goto L1
+-- L1: ...
+--     ...
+-- ...
+-- L2: a = x
+--     b = y
+--     goto L1
+--
+-- This can be done only when function is calling itself in a tail position
+-- and only if the call passes number of parameters equal to function's arity.
+-- Note that this cannot be performed if a function calls itself with a
+-- continuation.
+--
+-- This in fact implements optimization known as "loopification". It was
+-- described in "Low-level code optimizations in the Glasgow Haskell Compiler"
+-- by Krzysztof Woś, though we use different approach. Krzysztof performed his
+-- optimization at the Cmm level, whereas we perform ours during code generation
+-- (Stg-to-Cmm pass) essentially making sure that optimized Cmm code is
+-- generated in the first place.
+--
+-- Implementation is spread across a couple of places in the code:
+--
+--   * FCode monad stores additional information in its reader environment
+--     (cgd_self_loop field). This information tells us which function can
+--     tail call itself in an optimized way (it is the function currently
+--     being compiled), what is the label of a loop header (L1 in example above)
+--     and information about local registers in which we should arguments
+--     before making a call (this would be a and b in example above).
+--
+--   * Whenever we are compiling a function, we set that information to reflect
+--     the fact that function currently being compiled can be jumped to, instead
+--     of called. This is done in closureCodyBody in StgCmmBind.
+--
+--   * We also have to emit a label to which we will be jumping. We make sure
+--     that the label is placed after a stack check but before the heap
+--     check. The reason is that making a recursive tail-call does not increase
+--     the stack so we only need to check once. But it may grow the heap, so we
+--     have to repeat the heap check in every self-call. This is done in
+--     do_checks in StgCmmHeap.
+--
+--   * When we begin compilation of another closure we remove the additional
+--     information from the environment. This is done by forkClosureBody
+--     in StgCmmMonad. Other functions that duplicate the environment -
+--     forkLneBody, forkAlts, codeOnly - duplicate that information. In other
+--     words, we only need to clean the environment of the self-loop information
+--     when compiling right hand side of a closure (binding).
+--
+--   * When compiling a call (cgIdApp) we use getCallMethod to decide what kind
+--     of call will be generated. getCallMethod decides to generate a self
+--     recursive tail call when (a) environment stores information about
+--     possible self tail-call; (b) that tail call is to a function currently
+--     being compiled; (c) number of passed non-void arguments is equal to
+--     function's arity. (d) loopification is turned on via -floopification
+--     command-line option.
+--
+--   * Command line option to turn loopification on and off is implemented in
+--     DynFlags.
+--
+--
+-- Note [Void arguments in self-recursive tail calls]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- State# tokens can get in the way of the loopification optimization as seen in
+-- #11372. Consider this:
+--
+-- foo :: [a]
+--     -> (a -> State# s -> (# State s, Bool #))
+--     -> State# s
+--     -> (# State# s, Maybe a #)
+-- foo [] f s = (# s, Nothing #)
+-- foo (x:xs) f s = case f x s of
+--      (# s', b #) -> case b of
+--          True -> (# s', Just x #)
+--          False -> foo xs f s'
+--
+-- We would like to compile the call to foo as a local jump instead of a call
+-- (see Note [Self-recursive tail calls]). However, the generated function has
+-- an arity of 2 while we apply it to 3 arguments, one of them being of void
+-- type. Thus, we mustn't count arguments of void type when checking whether
+-- we can turn a call into a self-recursive jump.
+--
+
+emitEnter :: CmmExpr -> FCode ReturnKind
+emitEnter fun = do
+  { dflags <- getDynFlags
+  ; adjustHpBackwards
+  ; sequel <- getSequel
+  ; updfr_off <- getUpdFrameOff
+  ; case sequel of
+      -- For a return, we have the option of generating a tag-test or
+      -- not.  If the value is tagged, we can return directly, which
+      -- is quicker than entering the value.  This is a code
+      -- size/speed trade-off: when optimising for speed rather than
+      -- size we could generate the tag test.
+      --
+      -- Right now, we do what the old codegen did, and omit the tag
+      -- test, just generating an enter.
+      Return -> do
+        { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg
+        ; emit $ mkJump dflags NativeNodeCall entry
+                        [cmmUntag dflags fun] updfr_off
+        ; return AssignedDirectly
+        }
+
+      -- The result will be scrutinised in the sequel.  This is where
+      -- we generate a tag-test to avoid entering the closure if
+      -- possible.
+      --
+      -- The generated code will be something like this:
+      --
+      --    R1 = fun  -- copyout
+      --    if (fun & 7 != 0) goto Lret else goto Lcall
+      --  Lcall:
+      --    call [fun] returns to Lret
+      --  Lret:
+      --    fun' = R1  -- copyin
+      --    ...
+      --
+      -- Note in particular that the label Lret is used as a
+      -- destination by both the tag-test and the call.  This is
+      -- because Lret will necessarily be a proc-point, and we want to
+      -- ensure that we generate only one proc-point for this
+      -- sequence.
+      --
+      -- Furthermore, we tell the caller that we generated a native
+      -- return continuation by returning (ReturnedTo Lret off), so
+      -- that the continuation can be reused by the heap-check failure
+      -- code in the enclosing case expression.
+      --
+      AssignTo res_regs _ -> do
+       { lret <- newBlockId
+       ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []
+       ; lcall <- newBlockId
+       ; updfr_off <- getUpdFrameOff
+       ; let area = Young lret
+       ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area
+                                          [fun] updfr_off []
+         -- refer to fun via nodeReg after the copyout, to avoid having
+         -- both live simultaneously; this sometimes enables fun to be
+         -- inlined in the RHS of the R1 assignment.
+       ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg))
+             the_call = toCall entry (Just lret) updfr_off off outArgs regs
+       ; tscope <- getTickScope
+       ; emit $
+           copyout <*>
+           mkCbranch (cmmIsTagged dflags (CmmReg nodeReg))
+                     lret lcall Nothing <*>
+           outOfLine lcall (the_call,tscope) <*>
+           mkLabel lret tscope <*>
+           copyin
+       ; return (ReturnedTo lret off)
+       }
+  }
+
+------------------------------------------------------------------------
+--              Ticks
+------------------------------------------------------------------------
+
+-- | Generate Cmm code for a tick. Depending on the type of Tickish,
+-- this will either generate actual Cmm instrumentation code, or
+-- simply pass on the annotation as a @CmmTickish@.
+cgTick :: Tickish Id -> FCode ()
+cgTick tick
+  = do { dflags <- getDynFlags
+       ; case tick of
+           ProfNote   cc t p -> emitSetCCC cc t p
+           HpcTick    m n    -> emit (mkTickBox dflags m n)
+           SourceNote s n    -> emitTick $ SourceNote s n
+           _other            -> return () -- ignore
+       }
diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmExtCode.hs
@@ -0,0 +1,253 @@
+-- | Our extended FCode monad.
+
+-- We add a mapping from names to CmmExpr, to support local variable names in
+-- the concrete C-- code.  The unique supply of the underlying FCode monad
+-- is used to grab a new unique for each local variable.
+
+-- In C--, a local variable can be declared anywhere within a proc,
+-- and it scopes from the beginning of the proc to the end.  Hence, we have
+-- to collect declarations as we parse the proc, and feed the environment
+-- back in circularly (to avoid a two-pass algorithm).
+
+module StgCmmExtCode (
+        CmmParse, unEC,
+        Named(..), Env,
+
+        loopDecls,
+        getEnv,
+
+        withName,
+        getName,
+
+        newLocal,
+        newLabel,
+        newBlockId,
+        newFunctionName,
+        newImport,
+        lookupLabel,
+        lookupName,
+
+        code,
+        emit, emitLabel, emitAssign, emitStore,
+        getCode, getCodeR, getCodeScoped,
+        emitOutOfLine,
+        withUpdFrameOff, getUpdFrameOff
+)
+
+where
+
+import GhcPrelude
+
+import qualified StgCmmMonad as F
+import StgCmmMonad (FCode, newUnique)
+
+import Cmm
+import CLabel
+import MkGraph
+
+import BlockId
+import DynFlags
+import FastString
+import Module
+import UniqFM
+import Unique
+import UniqSupply
+
+import Control.Monad (liftM, ap)
+
+-- | The environment contains variable definitions or blockids.
+data Named
+        = VarN CmmExpr          -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,
+                                --      eg, RtsLabel, ForeignLabel, CmmLabel etc.
+
+        | FunN   UnitId      -- ^ A function name from this package
+        | LabelN BlockId                -- ^ A blockid of some code or data.
+
+-- | An environment of named things.
+type Env        = UniqFM Named
+
+-- | Local declarations that are in scope during code generation.
+type Decls      = [(FastString,Named)]
+
+-- | Does a computation in the FCode monad, with a current environment
+--      and a list of local declarations. Returns the resulting list of declarations.
+newtype CmmParse a
+        = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }
+
+type ExtCode = CmmParse ()
+
+returnExtFC :: a -> CmmParse a
+returnExtFC a   = EC $ \_ _ s -> return (s, a)
+
+thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
+thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'
+
+instance Functor CmmParse where
+      fmap = liftM
+
+instance Applicative CmmParse where
+      pure = returnExtFC
+      (<*>) = ap
+
+instance Monad CmmParse where
+  (>>=) = thenExtFC
+
+instance MonadUnique CmmParse where
+  getUniqueSupplyM = code getUniqueSupplyM
+  getUniqueM = EC $ \_ _ decls -> do
+    u <- getUniqueM
+    return (decls, u)
+
+instance HasDynFlags CmmParse where
+    getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags
+                                   return (d, dflags))
+
+
+-- | Takes the variable decarations and imports from the monad
+--      and makes an environment, which is looped back into the computation.
+--      In this way, we can have embedded declarations that scope over the whole
+--      procedure, and imports that scope over the entire module.
+--      Discards the local declaration contained within decl'
+--
+loopDecls :: CmmParse a -> CmmParse a
+loopDecls (EC fcode) =
+      EC $ \c e globalDecls -> do
+        (_, a) <- F.fixC $ \ ~(decls, _) ->
+          fcode c (addListToUFM e decls) globalDecls
+        return (globalDecls, a)
+
+
+-- | Get the current environment from the monad.
+getEnv :: CmmParse Env
+getEnv  = EC $ \_ e s -> return (s, e)
+
+-- | Get the current context name from the monad
+getName :: CmmParse String
+getName  = EC $ \c _ s -> return (s, c)
+
+-- | Set context name for a sub-parse
+withName :: String -> CmmParse a -> CmmParse a
+withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s
+
+addDecl :: FastString -> Named -> ExtCode
+addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ())
+
+
+-- | Add a new variable to the list of local declarations.
+--      The CmmExpr says where the value is stored.
+addVarDecl :: FastString -> CmmExpr -> ExtCode
+addVarDecl var expr = addDecl var (VarN expr)
+
+-- | Add a new label to the list of local declarations.
+addLabel :: FastString -> BlockId -> ExtCode
+addLabel name block_id = addDecl name (LabelN block_id)
+
+
+-- | Create a fresh local variable of a given type.
+newLocal
+        :: CmmType              -- ^ data type
+        -> FastString           -- ^ name of variable
+        -> CmmParse LocalReg    -- ^ register holding the value
+
+newLocal ty name = do
+   u <- code newUnique
+   let reg = LocalReg u ty
+   addVarDecl name (CmmReg (CmmLocal reg))
+   return reg
+
+
+-- | Allocate a fresh label.
+newLabel :: FastString -> CmmParse BlockId
+newLabel name = do
+   u <- code newUnique
+   addLabel name (mkBlockId u)
+   return (mkBlockId u)
+
+-- | Add add a local function to the environment.
+newFunctionName
+        :: FastString   -- ^ name of the function
+        -> UnitId    -- ^ package of the current module
+        -> ExtCode
+
+newFunctionName name pkg = addDecl name (FunN pkg)
+
+
+-- | Add an imported foreign label to the list of local declarations.
+--      If this is done at the start of the module the declaration will scope
+--      over the whole module.
+newImport
+        :: (FastString, CLabel)
+        -> CmmParse ()
+
+newImport (name, cmmLabel)
+   = addVarDecl name (CmmLit (CmmLabel cmmLabel))
+
+
+-- | Lookup the BlockId bound to the label with this name.
+--      If one hasn't been bound yet, create a fresh one based on the
+--      Unique of the name.
+lookupLabel :: FastString -> CmmParse BlockId
+lookupLabel name = do
+  env <- getEnv
+  return $
+     case lookupUFM env name of
+        Just (LabelN l) -> l
+        _other          -> mkBlockId (newTagUnique (getUnique name) 'L')
+
+
+-- | Lookup the location of a named variable.
+--      Unknown names are treated as if they had been 'import'ed from the runtime system.
+--      This saves us a lot of bother in the RTS sources, at the expense of
+--      deferring some errors to link time.
+lookupName :: FastString -> CmmParse CmmExpr
+lookupName name = do
+  env    <- getEnv
+  return $
+     case lookupUFM env name of
+        Just (VarN e)   -> e
+        Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg          name))
+        _other          -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))
+
+
+-- | Lift an FCode computation into the CmmParse monad
+code :: FCode a -> CmmParse a
+code fc = EC $ \_ _ s -> do
+                r <- fc
+                return (s, r)
+
+emit :: CmmAGraph -> CmmParse ()
+emit = code . F.emit
+
+emitLabel :: BlockId -> CmmParse ()
+emitLabel = code . F.emitLabel
+
+emitAssign :: CmmReg  -> CmmExpr -> CmmParse ()
+emitAssign l r = code (F.emitAssign l r)
+
+emitStore :: CmmExpr  -> CmmExpr -> CmmParse ()
+emitStore l r = code (F.emitStore l r)
+
+getCode :: CmmParse a -> CmmParse CmmAGraph
+getCode (EC ec) = EC $ \c e s -> do
+  ((s',_), gr) <- F.getCodeR (ec c e s)
+  return (s', gr)
+
+getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
+getCodeR (EC ec) = EC $ \c e s -> do
+  ((s', r), gr) <- F.getCodeR (ec c e s)
+  return (s', (r,gr))
+
+getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)
+getCodeScoped (EC ec) = EC $ \c e s -> do
+  ((s', r), gr) <- F.getCodeScoped (ec c e s)
+  return (s', (r,gr))
+
+emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()
+emitOutOfLine l g = code (F.emitOutOfLine l g)
+
+withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
+withUpdFrameOff size inner
+  = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s
+
+getUpdFrameOff :: CmmParse UpdFrameOffset
+getUpdFrameOff = code $ F.getUpdFrameOff
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -0,0 +1,534 @@
+-----------------------------------------------------------------------------
+--
+-- Code generation for foreign calls.
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmForeign (
+  cgForeignCall,
+  emitPrimCall, emitCCall,
+  emitForeignCall,     -- For CmmParse
+  emitSaveThreadState,
+  saveThreadState,
+  emitLoadThreadState,
+  loadThreadState,
+  emitOpenNursery,
+  emitCloseNursery,
+ ) where
+
+import GhcPrelude hiding( succ, (<*>) )
+
+import StgSyn
+import StgCmmProf (storeCurCCS, ccsType)
+import StgCmmEnv
+import StgCmmMonad
+import StgCmmUtils
+import StgCmmClosure
+import StgCmmLayout
+
+import BlockId (newBlockId)
+import Cmm
+import CmmUtils
+import MkGraph
+import Type
+import RepType
+import TysPrim
+import CLabel
+import SMRep
+import ForeignCall
+import DynFlags
+import Maybes
+import Outputable
+import UniqSupply
+import BasicTypes
+
+import Control.Monad
+
+-----------------------------------------------------------------------------
+-- Code generation for Foreign Calls
+-----------------------------------------------------------------------------
+
+-- | emit code for a foreign call, and return the results to the sequel.
+--
+cgForeignCall :: ForeignCall            -- the op
+              -> [StgArg]               -- x,y    arguments
+              -> Type                   -- result type
+              -> FCode ReturnKind
+
+cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
+  = do  { dflags <- getDynFlags
+        ; let -- in the stdcall calling convention, the symbol needs @size appended
+              -- to it, where size is the total number of bytes of arguments.  We
+              -- attach this info to the CLabel here, and the CLabel pretty printer
+              -- will generate the suffix when the label is printed.
+            call_size args
+              | StdCallConv <- cconv = Just (sum (map arg_size args))
+              | otherwise            = Nothing
+
+              -- ToDo: this might not be correct for 64-bit API
+            arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg)
+                                     (wORD_SIZE dflags)
+        ; cmm_args <- getFCallArgs stg_args
+        ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
+        ; let ((call_args, arg_hints), cmm_target)
+                = case target of
+                   StaticTarget _ _   _      False ->
+                       panic "cgForeignCall: unexpected FFI value import"
+                   StaticTarget _ lbl mPkgId True
+                     -> let labelSource
+                                = case mPkgId of
+                                        Nothing         -> ForeignLabelInThisPackage
+                                        Just pkgId      -> ForeignLabelInPackage pkgId
+                            size = call_size cmm_args
+                        in  ( unzip cmm_args
+                            , CmmLit (CmmLabel
+                                        (mkForeignLabel lbl size labelSource IsFunction)))
+
+                   DynamicTarget    ->  case cmm_args of
+                                           (fn,_):rest -> (unzip rest, fn)
+                                           [] -> panic "cgForeignCall []"
+              fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn
+              call_target = ForeignTarget cmm_target fc
+
+        -- we want to emit code for the call, and then emitReturn.
+        -- However, if the sequel is AssignTo, we shortcut a little
+        -- and generate a foreign call that assigns the results
+        -- directly.  Otherwise we end up generating a bunch of
+        -- useless "r = r" assignments, which are not merely annoying:
+        -- they prevent the common block elimination from working correctly
+        -- in the case of a safe foreign call.
+        -- See Note [safe foreign call convention]
+        --
+        ; sequel <- getSequel
+        ; case sequel of
+            AssignTo assign_to_these _ ->
+                emitForeignCall safety assign_to_these call_target call_args
+
+            _something_else ->
+                do { _ <- emitForeignCall safety res_regs call_target call_args
+                   ; emitReturn (map (CmmReg . CmmLocal) res_regs)
+                   }
+         }
+
+{- Note [safe foreign call convention]
+
+The simple thing to do for a safe foreign call would be the same as an
+unsafe one: just
+
+    emitForeignCall ...
+    emitReturn ...
+
+but consider what happens in this case
+
+   case foo x y z of
+     (# s, r #) -> ...
+
+The sequel is AssignTo [r].  The call to newUnboxedTupleRegs picks [r]
+as the result reg, and we generate
+
+  r = foo(x,y,z) returns to L1  -- emitForeignCall
+ L1:
+  r = r  -- emitReturn
+  goto L2
+L2:
+  ...
+
+Now L1 is a proc point (by definition, it is the continuation of the
+safe foreign call).  If L2 does a heap check, then L2 will also be a
+proc point.
+
+Furthermore, the stack layout algorithm has to arrange to save r
+somewhere between the call and the jump to L1, which is annoying: we
+would have to treat r differently from the other live variables, which
+have to be saved *before* the call.
+
+So we adopt a special convention for safe foreign calls: the results
+are copied out according to the NativeReturn convention by the call,
+and the continuation of the call should copyIn the results.  (The
+copyOut code is actually inserted when the safe foreign call is
+lowered later).  The result regs attached to the safe foreign call are
+only used temporarily to hold the results before they are copied out.
+
+We will now generate this:
+
+  r = foo(x,y,z) returns to L1
+ L1:
+  r = R1  -- copyIn, inserted by mkSafeCall
+  goto L2
+ L2:
+  ... r ...
+
+And when the safe foreign call is lowered later (see Note [lower safe
+foreign calls]) we get this:
+
+  suspendThread()
+  r = foo(x,y,z)
+  resumeThread()
+  R1 = r  -- copyOut, inserted by lowerSafeForeignCall
+  jump L1
+ L1:
+  r = R1  -- copyIn, inserted by mkSafeCall
+  goto L2
+ L2:
+  ... r ...
+
+Now consider what happens if L2 does a heap check: the Adams
+optimisation kicks in and commons up L1 with the heap-check
+continuation, resulting in just one proc point instead of two. Yay!
+-}
+
+
+emitCCall :: [(CmmFormal,ForeignHint)]
+          -> CmmExpr
+          -> [(CmmActual,ForeignHint)]
+          -> FCode ()
+emitCCall hinted_results fn hinted_args
+  = void $ emitForeignCall PlayRisky results target args
+  where
+    (args, arg_hints) = unzip hinted_args
+    (results, result_hints) = unzip hinted_results
+    target = ForeignTarget fn fc
+    fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn
+
+
+emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
+emitPrimCall res op args
+  = void $ emitForeignCall PlayRisky res (PrimTarget op) args
+
+-- alternative entry point, used by CmmParse
+emitForeignCall
+        :: Safety
+        -> [CmmFormal]          -- where to put the results
+        -> ForeignTarget        -- the op
+        -> [CmmActual]          -- arguments
+        -> FCode ReturnKind
+emitForeignCall safety results target args
+  | not (playSafe safety) = do
+    dflags <- getDynFlags
+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags
+    emit caller_save
+    target' <- load_target_into_temp target
+    args' <- mapM maybe_assign_temp args
+    emit $ mkUnsafeCall target' results args'
+    emit caller_load
+    return AssignedDirectly
+
+  | otherwise = do
+    dflags <- getDynFlags
+    updfr_off <- getUpdFrameOff
+    target' <- load_target_into_temp target
+    args' <- mapM maybe_assign_temp args
+    k <- newBlockId
+    let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results []
+       -- see Note [safe foreign call convention]
+    tscope <- getTickScope
+    emit $
+           (    mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))
+                        (CmmLit (CmmBlock k))
+            <*> mkLast (CmmForeignCall { tgt  = target'
+                                       , res  = results
+                                       , args = args'
+                                       , succ = k
+                                       , ret_args = off
+                                       , ret_off = updfr_off
+                                       , intrbl = playInterruptible safety })
+            <*> mkLabel k tscope
+            <*> copyout
+           )
+    return (ReturnedTo k off)
+
+load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
+load_target_into_temp (ForeignTarget expr conv) = do
+  tmp <- maybe_assign_temp expr
+  return (ForeignTarget tmp conv)
+load_target_into_temp other_target@(PrimTarget _) =
+  return other_target
+
+-- What we want to do here is create a new temporary for the foreign
+-- call argument if it is not safe to use the expression directly,
+-- because the expression mentions caller-saves GlobalRegs (see
+-- Note [Register Parameter Passing]).
+--
+-- However, we can't pattern-match on the expression here, because
+-- this is used in a loop by CmmParse, and testing the expression
+-- results in a black hole.  So we always create a temporary, and rely
+-- on CmmSink to clean it up later.  (Yuck, ToDo).  The generated code
+-- ends up being the same, at least for the RTS .cmm code.
+--
+maybe_assign_temp :: CmmExpr -> FCode CmmExpr
+maybe_assign_temp e = do
+  dflags <- getDynFlags
+  reg <- newTemp (cmmExprType dflags e)
+  emitAssign (CmmLocal reg) e
+  return (CmmReg (CmmLocal reg))
+
+-- -----------------------------------------------------------------------------
+-- Save/restore the thread state in the TSO
+
+-- This stuff can't be done in suspendThread/resumeThread, because it
+-- refers to global registers which aren't available in the C world.
+
+emitSaveThreadState :: FCode ()
+emitSaveThreadState = do
+  dflags <- getDynFlags
+  code <- saveThreadState dflags
+  emit code
+
+-- | Produce code to save the current thread state to @CurrentTSO@
+saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph
+saveThreadState dflags = do
+  tso <- newTemp (gcWord dflags)
+  close_nursery <- closeNursery dflags tso
+  pure $ catAGraphs [
+    -- tso = CurrentTSO;
+    mkAssign (CmmLocal tso) currentTSOExpr,
+    -- tso->stackobj->sp = Sp;
+    mkStore (cmmOffset dflags
+                       (CmmLoad (cmmOffset dflags
+                                           (CmmReg (CmmLocal tso))
+                                           (tso_stackobj dflags))
+                                (bWord dflags))
+                       (stack_SP dflags))
+            spExpr,
+    close_nursery,
+    -- and save the current cost centre stack in the TSO when profiling:
+    if gopt Opt_SccProfilingOn dflags then
+        mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr
+      else mkNop
+    ]
+
+emitCloseNursery :: FCode ()
+emitCloseNursery = do
+  dflags <- getDynFlags
+  tso <- newTemp (bWord dflags)
+  code <- closeNursery dflags tso
+  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code
+
+{- |
+@closeNursery dflags tso@ produces code to close the nursery.
+A local register holding the value of @CurrentTSO@ is expected for
+efficiency.
+
+Closing the nursery corresponds to the following code:
+
+@
+  tso = CurrentTSO;
+  cn = CurrentNuresry;
+
+  // Update the allocation limit for the current thread.  We don't
+  // check to see whether it has overflowed at this point, that check is
+  // made when we run out of space in the current heap block (stg_gc_noregs)
+  // and in the scheduler when context switching (schedulePostRunThread).
+  tso->alloc_limit -= Hp + WDS(1) - cn->start;
+
+  // Set cn->free to the next unoccupied word in the block
+  cn->free = Hp + WDS(1);
+@
+-}
+closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph
+closeNursery df tso = do
+  let tsoreg  = CmmLocal tso
+  cnreg      <- CmmLocal <$> newTemp (bWord df)
+  pure $ catAGraphs [
+    mkAssign cnreg currentNurseryExpr,
+
+    -- CurrentNursery->free = Hp+1;
+    mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df hpExpr 1),
+
+    let alloc =
+           CmmMachOp (mo_wordSub df)
+              [ cmmOffsetW df hpExpr 1
+              , CmmLoad (nursery_bdescr_start df cnreg) (bWord df)
+              ]
+
+        alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)
+    in
+
+    -- tso->alloc_limit += alloc
+    mkStore alloc_limit (CmmMachOp (MO_Sub W64)
+                               [ CmmLoad alloc_limit b64
+                               , CmmMachOp (mo_WordTo64 df) [alloc] ])
+   ]
+
+emitLoadThreadState :: FCode ()
+emitLoadThreadState = do
+  dflags <- getDynFlags
+  code <- loadThreadState dflags
+  emit code
+
+-- | Produce code to load the current thread state from @CurrentTSO@
+loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph
+loadThreadState dflags = do
+  tso <- newTemp (gcWord dflags)
+  stack <- newTemp (gcWord dflags)
+  open_nursery <- openNursery dflags tso
+  pure $ catAGraphs [
+    -- tso = CurrentTSO;
+    mkAssign (CmmLocal tso) currentTSOExpr,
+    -- stack = tso->stackobj;
+    mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),
+    -- Sp = stack->sp;
+    mkAssign spReg (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),
+    -- SpLim = stack->stack + RESERVED_STACK_WORDS;
+    mkAssign spLimReg (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
+                                (rESERVED_STACK_WORDS dflags)),
+    -- HpAlloc = 0;
+    --   HpAlloc is assumed to be set to non-zero only by a failed
+    --   a heap check, see HeapStackCheck.cmm:GC_GENERIC
+    mkAssign hpAllocReg (zeroExpr dflags),
+    open_nursery,
+    -- and load the current cost centre stack from the TSO when profiling:
+    if gopt Opt_SccProfilingOn dflags
+       then storeCurCCS
+              (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso))
+                 (tso_CCCS dflags)) (ccsType dflags))
+       else mkNop
+   ]
+
+
+emitOpenNursery :: FCode ()
+emitOpenNursery = do
+  dflags <- getDynFlags
+  tso <- newTemp (bWord dflags)
+  code <- openNursery dflags tso
+  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code
+
+{- |
+@openNursery dflags tso@ produces code to open the nursery. A local register
+holding the value of @CurrentTSO@ is expected for efficiency.
+
+Opening the nursery corresponds to the following code:
+
+@
+   tso = CurrentTSO;
+   cn = CurrentNursery;
+   bdfree = CurrentNursery->free;
+   bdstart = CurrentNursery->start;
+
+   // We *add* the currently occupied portion of the nursery block to
+   // the allocation limit, because we will subtract it again in
+   // closeNursery.
+   tso->alloc_limit += bdfree - bdstart;
+
+   // Set Hp to the last occupied word of the heap block.  Why not the
+   // next unocupied word?  Doing it this way means that we get to use
+   // an offset of zero more often, which might lead to slightly smaller
+   // code on some architectures.
+   Hp = bdfree - WDS(1);
+
+   // Set HpLim to the end of the current nursery block (note that this block
+   // might be a block group, consisting of several adjacent blocks.
+   HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1;
+@
+-}
+openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph
+openNursery df tso = do
+  let tsoreg =  CmmLocal tso
+  cnreg      <- CmmLocal <$> newTemp (bWord df)
+  bdfreereg  <- CmmLocal <$> newTemp (bWord df)
+  bdstartreg <- CmmLocal <$> newTemp (bWord df)
+
+  -- These assignments are carefully ordered to reduce register
+  -- pressure and generate not completely awful code on x86.  To see
+  -- what code we generate, look at the assembly for
+  -- stg_returnToStackTop in rts/StgStartup.cmm.
+  pure $ catAGraphs [
+     mkAssign cnreg currentNurseryExpr,
+     mkAssign bdfreereg  (CmmLoad (nursery_bdescr_free df cnreg)  (bWord df)),
+
+     -- Hp = CurrentNursery->free - 1;
+     mkAssign hpReg (cmmOffsetW df (CmmReg bdfreereg) (-1)),
+
+     mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)),
+
+     -- HpLim = CurrentNursery->start +
+     --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;
+     mkAssign hpLimReg
+         (cmmOffsetExpr df
+             (CmmReg bdstartreg)
+             (cmmOffset df
+               (CmmMachOp (mo_wordMul df) [
+                 CmmMachOp (MO_SS_Conv W32 (wordWidth df))
+                   [CmmLoad (nursery_bdescr_blocks df cnreg) b32],
+                 mkIntExpr df (bLOCK_SIZE df)
+                ])
+               (-1)
+             )
+         ),
+
+     -- alloc = bd->free - bd->start
+     let alloc =
+           CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg]
+
+         alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)
+     in
+
+     -- tso->alloc_limit += alloc
+     mkStore alloc_limit (CmmMachOp (MO_Add W64)
+                               [ CmmLoad alloc_limit b64
+                               , CmmMachOp (mo_WordTo64 df) [alloc] ])
+
+   ]
+
+nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks
+  :: DynFlags -> CmmReg -> CmmExpr
+nursery_bdescr_free   dflags cn =
+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags)
+nursery_bdescr_start  dflags cn =
+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags)
+nursery_bdescr_blocks dflags cn =
+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags)
+
+tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff
+tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)
+tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags)
+tso_CCCS     dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)
+stack_STACK  dflags = closureField dflags (oFFSET_StgStack_stack dflags)
+stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)
+
+
+closureField :: DynFlags -> ByteOff -> ByteOff
+closureField dflags off = off + fixedHdrSize dflags
+
+-- -----------------------------------------------------------------------------
+-- For certain types passed to foreign calls, we adjust the actual
+-- value passed to the call.  For ByteArray#/Array# we pass the
+-- address of the actual array, not the address of the heap object.
+
+getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
+-- (a) Drop void args
+-- (b) Add foreign-call shim code
+-- It's (b) that makes this differ from getNonVoidArgAmodes
+
+getFCallArgs args
+  = do  { mb_cmms <- mapM get args
+        ; return (catMaybes mb_cmms) }
+  where
+    get arg | null arg_reps
+            = return Nothing
+            | otherwise
+            = do { cmm <- getArgAmode (NonVoid arg)
+                 ; dflags <- getDynFlags
+                 ; return (Just (add_shim dflags arg_ty cmm, hint)) }
+            where
+              arg_ty   = stgArgType arg
+              arg_reps = typePrimRep arg_ty
+              hint     = typeForeignHint arg_ty
+
+add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr
+add_shim dflags arg_ty expr
+  | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
+  = cmmOffsetB dflags expr (arrPtrsHdrSize dflags)
+
+  | tycon == smallArrayPrimTyCon || tycon == smallMutableArrayPrimTyCon
+  = cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)
+
+  | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
+  = cmmOffsetB dflags expr (arrWordsHdrSize dflags)
+
+  | otherwise = expr
+  where
+    tycon           = tyConAppTyCon (unwrapType arg_ty)
+        -- should be a tycon app, since this is a foreign call
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -0,0 +1,680 @@
+-----------------------------------------------------------------------------
+--
+-- Stg to C--: heap management functions
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmHeap (
+        getVirtHp, setVirtHp, setRealHp,
+        getHpRelOffset,
+
+        entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,
+        heapStackCheckGen,
+        entryHeapCheck',
+
+        mkStaticClosureFields, mkStaticClosure,
+
+        allocDynClosure, allocDynClosureCmm, allocHeapClosure,
+        emitSetDynHdr
+    ) where
+
+import GhcPrelude hiding ((<*>))
+
+import StgSyn
+import CLabel
+import StgCmmLayout
+import StgCmmUtils
+import StgCmmMonad
+import StgCmmProf (profDynAlloc, dynProfHdr, staticProfHdr)
+import StgCmmTicky
+import StgCmmClosure
+import StgCmmEnv
+
+import MkGraph
+
+import Hoopl.Label
+import SMRep
+import BlockId
+import Cmm
+import CmmUtils
+import CostCentre
+import IdInfo( CafInfo(..), mayHaveCafRefs )
+import Id ( Id )
+import Module
+import DynFlags
+import FastString( mkFastString, fsLit )
+import Panic( sorry )
+
+import Control.Monad (when)
+import Data.Maybe (isJust)
+
+-----------------------------------------------------------
+--              Initialise dynamic heap objects
+-----------------------------------------------------------
+
+allocDynClosure
+        :: Maybe Id
+        -> CmmInfoTable
+        -> LambdaFormInfo
+        -> CmmExpr              -- Cost Centre to stick in the object
+        -> CmmExpr              -- Cost Centre to blame for this alloc
+                                -- (usually the same; sometimes "OVERHEAD")
+
+        -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of object
+                                                -- ie Info ptr has offset zero.
+                                                -- No void args in here
+        -> FCode CmmExpr -- returns Hp+n
+
+allocDynClosureCmm
+        :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
+        -> [(CmmExpr, ByteOff)]
+        -> FCode CmmExpr -- returns Hp+n
+
+-- allocDynClosure allocates the thing in the heap,
+-- and modifies the virtual Hp to account for this.
+-- The second return value is the graph that sets the value of the
+-- returned LocalReg, which should point to the closure after executing
+-- the graph.
+
+-- allocDynClosure returns an (Hp+8) CmmExpr, and hence the result is
+-- only valid until Hp is changed.  The caller should assign the
+-- result to a LocalReg if it is required to remain live.
+--
+-- The reason we don't assign it to a LocalReg here is that the caller
+-- is often about to call regIdInfo, which immediately assigns the
+-- result of allocDynClosure to a new temp in order to add the tag.
+-- So by not generating a LocalReg here we avoid a common source of
+-- new temporaries and save some compile time.  This can be quite
+-- significant - see test T4801.
+
+
+allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets = do
+  let (args, offsets) = unzip args_w_offsets
+  cmm_args <- mapM getArgAmode args     -- No void args
+  allocDynClosureCmm mb_id info_tbl lf_info
+                     use_cc _blame_cc (zip cmm_args offsets)
+
+
+allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do
+  -- SAY WHAT WE ARE ABOUT TO DO
+  let rep = cit_rep info_tbl
+  tickyDynAlloc mb_id rep lf_info
+  let info_ptr = CmmLit (CmmLabel (cit_lbl info_tbl))
+  allocHeapClosure rep info_ptr use_cc amodes_w_offsets
+
+
+-- | Low-level heap object allocation.
+allocHeapClosure
+  :: SMRep                            -- ^ representation of the object
+  -> CmmExpr                          -- ^ info pointer
+  -> CmmExpr                          -- ^ cost centre
+  -> [(CmmExpr,ByteOff)]              -- ^ payload
+  -> FCode CmmExpr                    -- ^ returns the address of the object
+allocHeapClosure rep info_ptr use_cc payload = do
+  profDynAlloc rep use_cc
+
+  virt_hp <- getVirtHp
+
+  -- Find the offset of the info-ptr word
+  let info_offset = virt_hp + 1
+            -- info_offset is the VirtualHpOffset of the first
+            -- word of the new object
+            -- Remember, virtHp points to last allocated word,
+            -- ie 1 *before* the info-ptr word of new object.
+
+  base <- getHpRelOffset info_offset
+  emitComment $ mkFastString "allocHeapClosure"
+  emitSetDynHdr base info_ptr use_cc
+
+  -- Fill in the fields
+  hpStore base payload
+
+  -- Bump the virtual heap pointer
+  dflags <- getDynFlags
+  setVirtHp (virt_hp + heapClosureSizeW dflags rep)
+
+  return base
+
+
+emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
+emitSetDynHdr base info_ptr ccs
+  = do dflags <- getDynFlags
+       hpStore base (zip (header dflags) [0, wORD_SIZE dflags ..])
+  where
+    header :: DynFlags -> [CmmExpr]
+    header dflags = [info_ptr] ++ dynProfHdr dflags ccs
+        -- ToDo: Parallel stuff
+        -- No ticky header
+
+-- Store the item (expr,off) in base[off]
+hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode ()
+hpStore base vals = do
+  dflags <- getDynFlags
+  sequence_ $
+    [ emitStore (cmmOffsetB dflags base off) val | (val,off) <- vals ]
+
+-----------------------------------------------------------
+--              Layout of static closures
+-----------------------------------------------------------
+
+-- Make a static closure, adding on any extra padding needed for CAFs,
+-- and adding a static link field if necessary.
+
+mkStaticClosureFields
+        :: DynFlags
+        -> CmmInfoTable
+        -> CostCentreStack
+        -> CafInfo
+        -> [CmmLit]             -- Payload
+        -> [CmmLit]             -- The full closure
+mkStaticClosureFields dflags info_tbl ccs caf_refs payload
+  = mkStaticClosure dflags info_lbl ccs payload padding
+        static_link_field saved_info_field
+  where
+    info_lbl = cit_lbl info_tbl
+
+    -- CAFs must have consistent layout, regardless of whether they
+    -- are actually updatable or not.  The layout of a CAF is:
+    --
+    --        3 saved_info
+    --        2 static_link
+    --        1 indirectee
+    --        0 info ptr
+    --
+    -- the static_link and saved_info fields must always be in the
+    -- same place.  So we use isThunkRep rather than closureUpdReqd
+    -- here:
+
+    is_caf = isThunkRep (cit_rep info_tbl)
+
+    padding
+        | is_caf && null payload = [mkIntCLit dflags 0]
+        | otherwise = []
+
+    static_link_field
+        | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl
+        = [static_link_value]
+        | otherwise
+        = []
+
+    saved_info_field
+        | is_caf     = [mkIntCLit dflags 0]
+        | otherwise  = []
+
+        -- For a static constructor which has NoCafRefs, we set the
+        -- static link field to a non-zero value so the garbage
+        -- collector will ignore it.
+    static_link_value
+        | mayHaveCafRefs caf_refs  = mkIntCLit dflags 0
+        | otherwise                = mkIntCLit dflags 3  -- No CAF refs
+                                      -- See Note [STATIC_LINK fields]
+                                      -- in rts/sm/Storage.h
+
+mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]
+  -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
+mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field
+  =  [CmmLabel info_lbl]
+  ++ staticProfHdr dflags ccs
+  ++ payload
+  ++ padding
+  ++ static_link_field
+  ++ saved_info_field
+
+-----------------------------------------------------------
+--              Heap overflow checking
+-----------------------------------------------------------
+
+{- Note [Heap checks]
+   ~~~~~~~~~~~~~~~~~~
+Heap checks come in various forms.  We provide the following entry
+points to the runtime system, all of which use the native C-- entry
+convention.
+
+  * gc() performs garbage collection and returns
+    nothing to its caller
+
+  * A series of canned entry points like
+        r = gc_1p( r )
+    where r is a pointer.  This performs gc, and
+    then returns its argument r to its caller.
+
+  * A series of canned entry points like
+        gcfun_2p( f, x, y )
+    where f is a function closure of arity 2
+    This performs garbage collection, keeping alive the
+    three argument ptrs, and then tail-calls f(x,y)
+
+These are used in the following circumstances
+
+* entryHeapCheck: Function entry
+    (a) With a canned GC entry sequence
+        f( f_clo, x:ptr, y:ptr ) {
+             Hp = Hp+8
+             if Hp > HpLim goto L
+             ...
+          L: HpAlloc = 8
+             jump gcfun_2p( f_clo, x, y ) }
+     Note the tail call to the garbage collector;
+     it should do no register shuffling
+
+    (b) No canned sequence
+        f( f_clo, x:ptr, y:ptr, ...etc... ) {
+          T: Hp = Hp+8
+             if Hp > HpLim goto L
+             ...
+          L: HpAlloc = 8
+             call gc()  -- Needs an info table
+             goto T }
+
+* altHeapCheck: Immediately following an eval
+  Started as
+        case f x y of r { (p,q) -> rhs }
+  (a) With a canned sequence for the results of f
+       (which is the very common case since
+       all boxed cases return just one pointer
+           ...
+           r = f( x, y )
+        K:      -- K needs an info table
+           Hp = Hp+8
+           if Hp > HpLim goto L
+           ...code for rhs...
+
+        L: r = gc_1p( r )
+           goto K }
+
+        Here, the info table needed by the call
+        to gc_1p should be the *same* as the
+        one for the call to f; the C-- optimiser
+        spots this sharing opportunity)
+
+   (b) No canned sequence for results of f
+       Note second info table
+           ...
+           (r1,r2,r3) = call f( x, y )
+        K:
+           Hp = Hp+8
+           if Hp > HpLim goto L
+           ...code for rhs...
+
+        L: call gc()    -- Extra info table here
+           goto K
+
+* generalHeapCheck: Anywhere else
+  e.g. entry to thunk
+       case branch *not* following eval,
+       or let-no-escape
+  Exactly the same as the previous case:
+
+        K:      -- K needs an info table
+           Hp = Hp+8
+           if Hp > HpLim goto L
+           ...
+
+        L: call gc()
+           goto K
+-}
+
+--------------------------------------------------------------
+-- A heap/stack check at a function or thunk entry point.
+
+entryHeapCheck :: ClosureInfo
+               -> Maybe LocalReg -- Function (closure environment)
+               -> Int            -- Arity -- not same as len args b/c of voids
+               -> [LocalReg]     -- Non-void args (empty for thunk)
+               -> FCode ()
+               -> FCode ()
+
+entryHeapCheck cl_info nodeSet arity args code
+  = entryHeapCheck' is_fastf node arity args code
+  where
+    node = case nodeSet of
+              Just r  -> CmmReg (CmmLocal r)
+              Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)
+
+    is_fastf = case closureFunInfo cl_info of
+                 Just (_, ArgGen _) -> False
+                 _otherwise         -> True
+
+-- | lower-level version for CmmParse
+entryHeapCheck' :: Bool           -- is a known function pattern
+                -> CmmExpr        -- expression for the closure pointer
+                -> Int            -- Arity -- not same as len args b/c of voids
+                -> [LocalReg]     -- Non-void args (empty for thunk)
+                -> FCode ()
+                -> FCode ()
+entryHeapCheck' is_fastf node arity args code
+  = do dflags <- getDynFlags
+       let is_thunk = arity == 0
+
+           args' = map (CmmReg . CmmLocal) args
+           stg_gc_fun    = CmmReg (CmmGlobal GCFun)
+           stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
+
+           {- Thunks:          jump stg_gc_enter_1
+
+              Function (fast): call (NativeNode) stg_gc_fun(fun, args)
+
+              Function (slow): call (slow) stg_gc_fun(fun, args)
+           -}
+           gc_call upd
+               | is_thunk
+                 = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd
+
+               | is_fastf
+                 = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd
+
+               | otherwise
+                 = mkJump dflags Slow stg_gc_fun (node : args') upd
+
+       updfr_sz <- getUpdFrameOff
+
+       loop_id <- newBlockId
+       emitLabel loop_id
+       heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code
+
+-- ------------------------------------------------------------
+-- A heap/stack check in a case alternative
+
+
+-- If there are multiple alts and we need to GC, but don't have a
+-- continuation already (the scrut was simple), then we should
+-- pre-generate the continuation.  (if there are multiple alts it is
+-- always a canned GC point).
+
+-- altHeapCheck:
+-- If we have a return continuation,
+--   then if it is a canned GC pattern,
+--           then we do mkJumpReturnsTo
+--           else we do a normal call to stg_gc_noregs
+--   else if it is a canned GC pattern,
+--           then generate the continuation and do mkCallReturnsTo
+--           else we do a normal call to stg_gc_noregs
+
+altHeapCheck :: [LocalReg] -> FCode a -> FCode a
+altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code
+
+altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a
+altOrNoEscapeHeapCheck checkYield regs code = do
+    dflags <- getDynFlags
+    case cannedGCEntryPoint dflags regs of
+      Nothing -> genericGC checkYield code
+      Just gc -> do
+        lret <- newBlockId
+        let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []
+        lcont <- newBlockId
+        tscope <- getTickScope
+        emitOutOfLine lret (copyin <*> mkBranch lcont, tscope)
+        emitLabel lcont
+        cannedGCReturnsTo checkYield False gc regs lret off code
+
+altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a
+altHeapCheckReturnsTo regs lret off code
+  = do dflags <- getDynFlags
+       case cannedGCEntryPoint dflags regs of
+           Nothing -> genericGC False code
+           Just gc -> cannedGCReturnsTo False True gc regs lret off code
+
+-- noEscapeHeapCheck is implemented identically to altHeapCheck (which
+-- is more efficient), but cannot be optimized away in the non-allocating
+-- case because it may occur in a loop
+noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a
+noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code
+
+cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff
+                  -> FCode a
+                  -> FCode a
+cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code
+  = do dflags <- getDynFlags
+       updfr_sz <- getUpdFrameOff
+       heapCheck False checkYield (gc_call dflags gc updfr_sz) code
+  where
+    reg_exprs = map (CmmReg . CmmLocal) regs
+      -- Note [stg_gc arguments]
+
+      -- NB. we use the NativeReturn convention for passing arguments
+      -- to the canned heap-check routines, because we are in a case
+      -- alternative and hence the [LocalReg] was passed to us in the
+      -- NativeReturn convention.
+    gc_call dflags label sp
+      | cont_on_stack
+      = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp
+      | otherwise
+      = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp []
+
+genericGC :: Bool -> FCode a -> FCode a
+genericGC checkYield code
+  = do updfr_sz <- getUpdFrameOff
+       lretry <- newBlockId
+       emitLabel lretry
+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
+       heapCheck False checkYield (call <*> mkBranch lretry) code
+
+cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr
+cannedGCEntryPoint dflags regs
+  = case map localRegType regs of
+      []  -> Just (mkGcLabel "stg_gc_noregs")
+      [ty]
+          | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1")
+          | isFloatType ty -> case width of
+                                  W32       -> Just (mkGcLabel "stg_gc_f1")
+                                  W64       -> Just (mkGcLabel "stg_gc_d1")
+                                  _         -> Nothing
+
+          | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1")
+          | width == W64              -> Just (mkGcLabel "stg_gc_l1")
+          | otherwise                 -> Nothing
+          where
+              width = typeWidth ty
+      [ty1,ty2]
+          |  isGcPtrType ty1
+          && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp")
+      [ty1,ty2,ty3]
+          |  isGcPtrType ty1
+          && isGcPtrType ty2
+          && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp")
+      [ty1,ty2,ty3,ty4]
+          |  isGcPtrType ty1
+          && isGcPtrType ty2
+          && isGcPtrType ty3
+          && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp")
+      _otherwise -> Nothing
+
+-- Note [stg_gc arguments]
+-- It might seem that we could avoid passing the arguments to the
+-- stg_gc function, because they are already in the right registers.
+-- While this is usually the case, it isn't always.  Sometimes the
+-- code generator has cleverly avoided the eval in a case, e.g. in
+-- ffi/should_run/4221.hs we found
+--
+--   case a_r1mb of z
+--     FunPtr x y -> ...
+--
+-- where a_r1mb is bound a top-level constructor, and is known to be
+-- evaluated.  The codegen just assigns x, y and z, and continues;
+-- R1 is never assigned.
+--
+-- So we'll have to rely on optimisations to eliminatethese
+-- assignments where possible.
+
+
+-- | The generic GC procedure; no params, no results
+generic_gc :: CmmExpr
+generic_gc = mkGcLabel "stg_gc_noregs"
+
+-- | Create a CLabel for calling a garbage collector entry point
+mkGcLabel :: String -> CmmExpr
+mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit s)))
+
+-------------------------------
+heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a
+heapCheck checkStack checkYield do_gc code
+  = getHeapUsage $ \ hpHw ->
+    -- Emit heap checks, but be sure to do it lazily so
+    -- that the conditionals on hpHw don't cause a black hole
+    do  { dflags <- getDynFlags
+        ; let mb_alloc_bytes
+                 | hpHw > mBLOCK_SIZE = sorry $ unlines
+                    [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.",
+                     "",
+                     "This is currently not possible due to a limitation of GHC's code generator.",
+                     "See http://ghc.haskell.org/trac/ghc/ticket/4505 for details.",
+                     "Suggestion: read data from a file instead of having large static data",
+                     "structures in code."]
+                 | hpHw > 0  = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags)))
+                 | otherwise = Nothing
+                 where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags
+              stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)
+                      | otherwise  = Nothing
+        ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc
+        ; tickyAllocHeap True hpHw
+        ; setRealHp hpHw
+        ; code }
+
+heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()
+heapStackCheckGen stk_hwm mb_bytes
+  = do updfr_sz <- getUpdFrameOff
+       lretry <- newBlockId
+       emitLabel lretry
+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
+       do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry)
+
+-- Note [Single stack check]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~
+-- When compiling a function we can determine how much stack space it
+-- will use. We therefore need to perform only a single stack check at
+-- the beginning of a function to see if we have enough stack space.
+--
+-- The check boils down to comparing Sp-N with SpLim, where N is the
+-- amount of stack space needed (see Note [Stack usage] below).  *BUT*
+-- at this stage of the pipeline we are not supposed to refer to Sp
+-- itself, because the stack is not yet manifest, so we don't quite
+-- know where Sp pointing.
+
+-- So instead of referring directly to Sp - as we used to do in the
+-- past - the code generator uses (old + 0) in the stack check. That
+-- is the address of the first word of the old area, so if we add N
+-- we'll get the address of highest used word.
+--
+-- This makes the check robust.  For example, while we need to perform
+-- only one stack check for each function, we could in theory place
+-- more stack checks later in the function. They would be redundant,
+-- but not incorrect (in a sense that they should not change program
+-- behaviour). We need to make sure however that a stack check
+-- inserted after incrementing the stack pointer checks for a
+-- respectively smaller stack space. This would not be the case if the
+-- code generator produced direct references to Sp. By referencing
+-- (old + 0) we make sure that we always check for a correct amount of
+-- stack: when converting (old + 0) to Sp the stack layout phase takes
+-- into account changes already made to stack pointer. The idea for
+-- this change came from observations made while debugging #8275.
+
+-- Note [Stack usage]
+-- ~~~~~~~~~~~~~~~~~~
+-- At the moment we convert from STG to Cmm we don't know N, the
+-- number of bytes of stack that the function will use, so we use a
+-- special late-bound CmmLit, namely
+--       CmmHighStackMark
+-- to stand for the number of bytes needed. When the stack is made
+-- manifest, the number of bytes needed is calculated, and used to
+-- replace occurrences of CmmHighStackMark
+--
+-- The (Maybe CmmExpr) passed to do_checks is usually
+--     Just (CmmLit CmmHighStackMark)
+-- but can also (in certain hand-written RTS functions)
+--     Just (CmmLit 8)  or some other fixed valuet
+-- If it is Nothing, we don't generate a stack check at all.
+
+do_checks :: Maybe CmmExpr    -- Should we check the stack?
+                              -- See Note [Stack usage]
+          -> Bool             -- Should we check for preemption?
+          -> Maybe CmmExpr    -- Heap headroom (bytes)
+          -> CmmAGraph        -- What to do on failure
+          -> FCode ()
+do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
+  dflags <- getDynFlags
+  gc_id <- newBlockId
+
+  let
+    Just alloc_lit = mb_alloc_lit
+
+    bump_hp   = cmmOffsetExprB dflags hpExpr alloc_lit
+
+    -- Sp overflow if ((old + 0) - CmmHighStack < SpLim)
+    -- At the beginning of a function old + 0 = Sp
+    -- See Note [Single stack check]
+    sp_oflo sp_hwm =
+         CmmMachOp (mo_wordULt dflags)
+                  [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))
+                             [CmmStackSlot Old 0, sp_hwm],
+                   CmmReg spLimReg]
+
+    -- Hp overflow if (Hp > HpLim)
+    -- (Hp has been incremented by now)
+    -- HpLim points to the LAST WORD of valid allocation space.
+    hp_oflo = CmmMachOp (mo_wordUGt dflags) [hpExpr, hpLimExpr]
+
+    alloc_n = mkAssign hpAllocReg alloc_lit
+
+  case mb_stk_hwm of
+    Nothing -> return ()
+    Just stk_hwm -> tickyStackCheck
+      >> (emit =<< mkCmmIfGoto' (sp_oflo stk_hwm) gc_id (Just False) )
+
+  -- Emit new label that might potentially be a header
+  -- of a self-recursive tail call.
+  -- See Note [Self-recursive loop header].
+  self_loop_info <- getSelfLoop
+  case self_loop_info of
+    Just (_, loop_header_id, _)
+        | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id
+    _otherwise -> return ()
+
+  if (isJust mb_alloc_lit)
+    then do
+     tickyHeapCheck
+     emitAssign hpReg bump_hp
+     emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False)
+    else do
+      when (checkYield && not (gopt Opt_OmitYields dflags)) $ do
+         -- Yielding if HpLim == 0
+         let yielding = CmmMachOp (mo_wordEq dflags)
+                                  [CmmReg hpLimReg,
+                                   CmmLit (zeroCLit dflags)]
+         emit =<< mkCmmIfGoto' yielding gc_id (Just False)
+
+  tscope <- getTickScope
+  emitOutOfLine gc_id
+   (do_gc, tscope) -- this is expected to jump back somewhere
+
+                -- Test for stack pointer exhaustion, then
+                -- bump heap pointer, and test for heap exhaustion
+                -- Note that we don't move the heap pointer unless the
+                -- stack check succeeds.  Otherwise we might end up
+                -- with slop at the end of the current block, which can
+                -- confuse the LDV profiler.
+
+-- Note [Self-recursive loop header]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Self-recursive loop header is required by loopification optimization (See
+-- Note [Self-recursive tail calls] in StgCmmExpr). We emit it if:
+--
+--  1. There is information about self-loop in the FCode environment. We don't
+--     check the binder (first component of the self_loop_info) because we are
+--     certain that if the self-loop info is present then we are compiling the
+--     binder body. Reason: the only possible way to get here with the
+--     self_loop_info present is from closureCodeBody.
+--
+--  2. checkYield && isJust mb_stk_hwm. checkYield tells us that it is possible
+--     to preempt the heap check (see #367 for motivation behind this check). It
+--     is True for heap checks placed at the entry to a function and
+--     let-no-escape heap checks but false for other heap checks (eg. in case
+--     alternatives or created from hand-written high-level Cmm). The second
+--     check (isJust mb_stk_hwm) is true for heap checks at the entry to a
+--     function and some heap checks created in hand-written Cmm. Otherwise it
+--     is Nothing. In other words the only situation when both conditions are
+--     true is when compiling stack and heap checks at the entry to a
+--     function. This is the only situation when we want to emit a self-loop
+--     label.
diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmHpc.hs
@@ -0,0 +1,48 @@
+-----------------------------------------------------------------------------
+--
+-- Code generation for coverage
+--
+-- (c) Galois Connections, Inc. 2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmHpc ( initHpc, mkTickBox ) where
+
+import GhcPrelude
+
+import StgCmmMonad
+
+import MkGraph
+import CmmExpr
+import CLabel
+import Module
+import CmmUtils
+import StgCmmUtils
+import HscTypes
+import DynFlags
+
+import Control.Monad
+
+mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph
+mkTickBox dflags mod n
+  = mkStore tick_box (CmmMachOp (MO_Add W64)
+                                [ CmmLoad tick_box b64
+                                , CmmLit (CmmInt 1 W64)
+                                ])
+  where
+    tick_box = cmmIndex dflags W64
+                        (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)
+                        n
+
+initHpc :: Module -> HpcInfo -> FCode ()
+-- Emit top-level tables for HPC and return code to initialise
+initHpc _ (NoHpcInfo {})
+  = return ()
+initHpc this_mod (HpcInfo tickCount _hashNo)
+  = do dflags <- getDynFlags
+       when (gopt Opt_Hpc dflags) $
+           do emitDataLits (mkHpcTicksLabel this_mod)
+                           [ (CmmInt 0 W64)
+                           | _ <- take tickCount [0 :: Int ..]
+                           ]
+
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -0,0 +1,623 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Building info tables.
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmLayout (
+        mkArgDescr,
+        emitCall, emitReturn, adjustHpBackwards,
+
+        emitClosureProcAndInfoTable,
+        emitClosureAndInfoTable,
+
+        slowCall, directCall,
+
+        FieldOffOrPadding(..),
+        ClosureHeader(..),
+        mkVirtHeapOffsets,
+        mkVirtHeapOffsetsWithPadding,
+        mkVirtConstrOffsets,
+        mkVirtConstrSizes,
+        getHpRelOffset,
+
+        ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep
+  ) where
+
+
+#include "HsVersions.h"
+
+import GhcPrelude hiding ((<*>))
+
+import StgCmmClosure
+import StgCmmEnv
+import StgCmmArgRep -- notably: ( slowCallPattern )
+import StgCmmTicky
+import StgCmmMonad
+import StgCmmUtils
+
+import MkGraph
+import SMRep
+import BlockId
+import Cmm
+import CmmUtils
+import CmmInfo
+import CLabel
+import StgSyn
+import Id
+import TyCon             ( PrimRep(..), primRepSizeB )
+import BasicTypes        ( RepArity )
+import DynFlags
+import Module
+
+import Util
+import Data.List
+import Outputable
+import FastString
+import Control.Monad
+
+------------------------------------------------------------------------
+--                Call and return sequences
+------------------------------------------------------------------------
+
+-- | Return multiple values to the sequel
+--
+-- If the sequel is @Return@
+--
+-- >     return (x,y)
+--
+-- If the sequel is @AssignTo [p,q]@
+--
+-- >    p=x; q=y;
+--
+emitReturn :: [CmmExpr] -> FCode ReturnKind
+emitReturn results
+  = do { dflags    <- getDynFlags
+       ; sequel    <- getSequel
+       ; updfr_off <- getUpdFrameOff
+       ; case sequel of
+           Return ->
+             do { adjustHpBackwards
+                ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)
+                ; emit (mkReturn dflags (entryCode dflags e) results updfr_off)
+                }
+           AssignTo regs adjust ->
+             do { when adjust adjustHpBackwards
+                ; emitMultiAssign  regs results }
+       ; return AssignedDirectly
+       }
+
+
+-- | @emitCall conv fun args@ makes a call to the entry-code of @fun@,
+-- using the call/return convention @conv@, passing @args@, and
+-- returning the results to the current sequel.
+--
+emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind
+emitCall convs fun args
+  = emitCallWithExtraStack convs fun args noExtraStack
+
+
+-- | @emitCallWithExtraStack conv fun args stack@ makes a call to the
+-- entry-code of @fun@, using the call/return convention @conv@,
+-- passing @args@, pushing some extra stack frames described by
+-- @stack@, and returning the results to the current sequel.
+--
+emitCallWithExtraStack
+   :: (Convention, Convention) -> CmmExpr -> [CmmExpr]
+   -> [CmmExpr] -> FCode ReturnKind
+emitCallWithExtraStack (callConv, retConv) fun args extra_stack
+  = do  { dflags <- getDynFlags
+        ; adjustHpBackwards
+        ; sequel <- getSequel
+        ; updfr_off <- getUpdFrameOff
+        ; case sequel of
+            Return -> do
+              emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack
+              return AssignedDirectly
+            AssignTo res_regs _ -> do
+              k <- newBlockId
+              let area = Young k
+                  (off, _, copyin) = copyInOflow dflags retConv area res_regs []
+                  copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off
+                                   extra_stack
+              tscope <- getTickScope
+              emit (copyout <*> mkLabel k tscope <*> copyin)
+              return (ReturnedTo k off)
+      }
+
+
+adjustHpBackwards :: FCode ()
+-- This function adjusts the heap pointer just before a tail call or
+-- return.  At a call or return, the virtual heap pointer may be less
+-- than the real Hp, because the latter was advanced to deal with
+-- the worst-case branch of the code, and we may be in a better-case
+-- branch.  In that case, move the real Hp *back* and retract some
+-- ticky allocation count.
+--
+-- It *does not* deal with high-water-mark adjustment.  That's done by
+-- functions which allocate heap.
+adjustHpBackwards
+  = do  { hp_usg <- getHpUsage
+        ; let rHp = realHp hp_usg
+              vHp = virtHp hp_usg
+              adjust_words = vHp -rHp
+        ; new_hp <- getHpRelOffset vHp
+
+        ; emit (if adjust_words == 0
+                then mkNop
+                else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp
+
+        ; tickyAllocHeap False adjust_words -- ...ditto
+
+        ; setRealHp vHp
+        }
+
+
+-------------------------------------------------------------------------
+--        Making calls: directCall and slowCall
+-------------------------------------------------------------------------
+
+-- General plan is:
+--   - we'll make *one* fast call, either to the function itself
+--     (directCall) or to stg_ap_<pat>_fast (slowCall)
+--     Any left-over arguments will be pushed on the stack,
+--
+--     e.g. Sp[old+8]  = arg1
+--          Sp[old+16] = arg2
+--          Sp[old+32] = stg_ap_pp_info
+--          R2 = arg3
+--          R3 = arg4
+--          call f() return to Nothing updfr_off: 32
+
+
+directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind
+-- (directCall f n args)
+-- calls f(arg1, ..., argn), and applies the result to the remaining args
+-- The function f has arity n, and there are guaranteed at least n args
+-- Both arity and args include void args
+directCall conv lbl arity stg_args
+  = do  { argreps <- getArgRepsAmodes stg_args
+        ; direct_call "directCall" conv lbl arity argreps }
+
+
+slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind
+-- (slowCall fun args) applies fun to args, returning the results to Sequel
+slowCall fun stg_args
+  = do  dflags <- getDynFlags
+        argsreps <- getArgRepsAmodes stg_args
+        let (rts_fun, arity) = slowCallPattern (map fst argsreps)
+
+        (r, slow_code) <- getCodeR $ do
+           r <- direct_call "slow_call" NativeNodeCall
+                 (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)
+           emitComment $ mkFastString ("slow_call for " ++
+                                      showSDoc dflags (ppr fun) ++
+                                      " with pat " ++ unpackFS rts_fun)
+           return r
+
+        -- Note [avoid intermediate PAPs]
+        let n_args = length stg_args
+        if n_args > arity && optLevel dflags >= 2
+           then do
+             funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun
+             fun_iptr <- (CmmReg . CmmLocal) `fmap`
+                    assignTemp (closureInfoPtr dflags (cmmUntag dflags funv))
+
+             -- ToDo: we could do slightly better here by reusing the
+             -- continuation from the slow call, which we have in r.
+             -- Also we'd like to push the continuation on the stack
+             -- before the branch, so that we only get one copy of the
+             -- code that saves all the live variables across the
+             -- call, but that might need some improvements to the
+             -- special case in the stack layout code to handle this
+             -- (see Note [diamond proc point]).
+
+             fast_code <- getCode $
+                emitCall (NativeNodeCall, NativeReturn)
+                  (entryCode dflags fun_iptr)
+                  (nonVArgs ((P,Just funv):argsreps))
+
+             slow_lbl <- newBlockId
+             fast_lbl <- newBlockId
+             is_tagged_lbl <- newBlockId
+             end_lbl <- newBlockId
+
+             let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr)
+                                                  (mkIntExpr dflags n_args)
+
+             tscope <- getTickScope
+             emit (mkCbranch (cmmIsTagged dflags funv)
+                             is_tagged_lbl slow_lbl (Just True)
+                   <*> mkLabel is_tagged_lbl tscope
+                   <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True)
+                   <*> mkLabel fast_lbl tscope
+                   <*> fast_code
+                   <*> mkBranch end_lbl
+                   <*> mkLabel slow_lbl tscope
+                   <*> slow_code
+                   <*> mkLabel end_lbl tscope)
+             return r
+
+           else do
+             emit slow_code
+             return r
+
+
+-- Note [avoid intermediate PAPs]
+--
+-- A slow call which needs multiple generic apply patterns will be
+-- almost guaranteed to create one or more intermediate PAPs when
+-- applied to a function that takes the correct number of arguments.
+-- We try to avoid this situation by generating code to test whether
+-- we are calling a function with the correct number of arguments
+-- first, i.e.:
+--
+--   if (TAG(f) != 0} {  // f is not a thunk
+--      if (f->info.arity == n) {
+--         ... make a fast call to f ...
+--      }
+--   }
+--   ... otherwise make the slow call ...
+--
+-- We *only* do this when the call requires multiple generic apply
+-- functions, which requires pushing extra stack frames and probably
+-- results in intermediate PAPs.  (I say probably, because it might be
+-- that we're over-applying a function, but that seems even less
+-- likely).
+--
+-- This very rarely applies, but if it does happen in an inner loop it
+-- can have a severe impact on performance (#6084).
+
+
+--------------
+direct_call :: String
+            -> Convention     -- e.g. NativeNodeCall or NativeDirectCall
+            -> CLabel -> RepArity
+            -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind
+direct_call caller call_conv lbl arity args
+  | debugIsOn && args `lengthLessThan` real_arity  -- Too few args
+  = do -- Caller should ensure that there enough args!
+       pprPanic "direct_call" $
+            text caller <+> ppr arity <+>
+            ppr lbl <+> ppr (length args) <+>
+            ppr (map snd args) <+> ppr (map fst args)
+
+  | null rest_args  -- Precisely the right number of arguments
+  = emitCall (call_conv, NativeReturn) target (nonVArgs args)
+
+  | otherwise       -- Note [over-saturated calls]
+  = do dflags <- getDynFlags
+       emitCallWithExtraStack (call_conv, NativeReturn)
+                              target
+                              (nonVArgs fast_args)
+                              (nonVArgs (stack_args dflags))
+  where
+    target = CmmLit (CmmLabel lbl)
+    (fast_args, rest_args) = splitAt real_arity args
+    stack_args dflags = slowArgs dflags rest_args
+    real_arity = case call_conv of
+                   NativeNodeCall -> arity+1
+                   _              -> arity
+
+
+-- When constructing calls, it is easier to keep the ArgReps and the
+-- CmmExprs zipped together.  However, a void argument has no
+-- representation, so we need to use Maybe CmmExpr (the alternative of
+-- using zeroCLit or even undefined would work, but would be ugly).
+--
+getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]
+getArgRepsAmodes = mapM getArgRepAmode
+  where getArgRepAmode arg
+           | V <- rep  = return (V, Nothing)
+           | otherwise = do expr <- getArgAmode (NonVoid arg)
+                            return (rep, Just expr)
+           where rep = toArgRep (argPrimRep arg)
+
+nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]
+nonVArgs [] = []
+nonVArgs ((_,Nothing)  : args) = nonVArgs args
+nonVArgs ((_,Just arg) : args) = arg : nonVArgs args
+
+{-
+Note [over-saturated calls]
+
+The natural thing to do for an over-saturated call would be to call
+the function with the correct number of arguments, and then apply the
+remaining arguments to the value returned, e.g.
+
+  f a b c d   (where f has arity 2)
+  -->
+  r = call f(a,b)
+  call r(c,d)
+
+but this entails
+  - saving c and d on the stack
+  - making a continuation info table
+  - at the continuation, loading c and d off the stack into regs
+  - finally, call r
+
+Note that since there are a fixed number of different r's
+(e.g.  stg_ap_pp_fast), we can also pre-compile continuations
+that correspond to each of them, rather than generating a fresh
+one for each over-saturated call.
+
+Not only does this generate much less code, it is faster too.  We will
+generate something like:
+
+Sp[old+16] = c
+Sp[old+24] = d
+Sp[old+32] = stg_ap_pp_info
+call f(a,b) -- usual calling convention
+
+For the purposes of the CmmCall node, we count this extra stack as
+just more arguments that we are passing on the stack (cml_args).
+-}
+
+-- | 'slowArgs' takes a list of function arguments and prepares them for
+-- pushing on the stack for "extra" arguments to a function which requires
+-- fewer arguments than we currently have.
+slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]
+slowArgs _ [] = []
+slowArgs dflags args -- careful: reps contains voids (V), but args does not
+  | gopt Opt_SccProfilingOn dflags
+              = save_cccs ++ this_pat ++ slowArgs dflags rest_args
+  | otherwise =              this_pat ++ slowArgs dflags rest_args
+  where
+    (arg_pat, n)            = slowCallPattern (map fst args)
+    (call_args, rest_args)  = splitAt n args
+
+    stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat
+    this_pat   = (N, Just (mkLblExpr stg_ap_pat)) : call_args
+    save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)]
+    save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")
+
+-------------------------------------------------------------------------
+----        Laying out objects on the heap and stack
+-------------------------------------------------------------------------
+
+-- The heap always grows upwards, so hpRel is easy to compute
+hpRel :: VirtualHpOffset         -- virtual offset of Hp
+      -> VirtualHpOffset         -- virtual offset of The Thing
+      -> WordOff                -- integer word offset
+hpRel hp off = off - hp
+
+getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr
+-- See Note [Virtual and real heap pointers] in StgCmmMonad
+getHpRelOffset virtual_offset
+  = do dflags <- getDynFlags
+       hp_usg <- getHpUsage
+       return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset))
+
+data FieldOffOrPadding a
+    = FieldOff (NonVoid a) -- Something that needs an offset.
+               ByteOff     -- Offset in bytes.
+    | Padding ByteOff  -- Length of padding in bytes.
+              ByteOff  -- Offset in bytes.
+
+-- | Used to tell the various @mkVirtHeapOffsets@ functions what kind
+-- of header the object has.  This will be accounted for in the
+-- offsets of the fields returned.
+data ClosureHeader
+  = NoHeader
+  | StdHeader
+  | ThunkHeader
+
+mkVirtHeapOffsetsWithPadding
+  :: DynFlags
+  -> ClosureHeader            -- What kind of header to account for
+  -> [NonVoid (PrimRep, a)]   -- Things to make offsets for
+  -> ( WordOff                -- Total number of words allocated
+     , WordOff                -- Number of words allocated for *pointers*
+     , [FieldOffOrPadding a]  -- Either an offset or padding.
+     )
+
+-- Things with their offsets from start of object in order of
+-- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
+-- First in list gets lowest offset, which is initial offset + 1.
+--
+-- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets
+-- than the unboxed things
+
+mkVirtHeapOffsetsWithPadding dflags header things =
+    ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))
+    ( tot_wds
+    , bytesToWordsRoundUp dflags bytes_of_ptrs
+    , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad
+    )
+  where
+    hdr_words = case header of
+      NoHeader -> 0
+      StdHeader -> fixedHdrSizeW dflags
+      ThunkHeader -> thunkHdrSize dflags
+    hdr_bytes = wordsToBytes dflags hdr_words
+
+    (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things
+
+    (bytes_of_ptrs, ptrs_w_offsets) =
+       mapAccumL computeOffset 0 ptrs
+    (tot_bytes, non_ptrs_w_offsets) =
+       mapAccumL computeOffset bytes_of_ptrs non_ptrs
+
+    tot_wds = bytesToWordsRoundUp dflags tot_bytes
+
+    final_pad_size = tot_wds * word_size - tot_bytes
+    final_pad
+        | final_pad_size > 0 = [(Padding final_pad_size
+                                         (hdr_bytes + tot_bytes))]
+        | otherwise          = []
+
+    word_size = wORD_SIZE dflags
+
+    computeOffset bytes_so_far nv_thing =
+        (new_bytes_so_far, with_padding field_off)
+      where
+        (rep, thing) = fromNonVoid nv_thing
+
+        -- Size of the field in bytes.
+        !sizeB = primRepSizeB dflags rep
+
+        -- Align the start offset (eg, 2-byte value should be 2-byte aligned).
+        -- But not more than to a word.
+        !align = min word_size sizeB
+        !start = roundUpTo bytes_so_far align
+        !padding = start - bytes_so_far
+
+        -- Final offset is:
+        --   size of header + bytes_so_far + padding
+        !final_offset = hdr_bytes + bytes_so_far + padding
+        !new_bytes_so_far = start + sizeB
+        field_off = FieldOff (NonVoid thing) final_offset
+
+        with_padding field_off
+            | padding == 0 = [field_off]
+            | otherwise    = [ Padding padding (hdr_bytes + bytes_so_far)
+                             , field_off
+                             ]
+
+
+mkVirtHeapOffsets
+  :: DynFlags
+  -> ClosureHeader            -- What kind of header to account for
+  -> [NonVoid (PrimRep,a)]    -- Things to make offsets for
+  -> (WordOff,                -- _Total_ number of words allocated
+      WordOff,                -- Number of words allocated for *pointers*
+      [(NonVoid a, ByteOff)])
+mkVirtHeapOffsets dflags header things =
+    ( tot_wds
+    , ptr_wds
+    , [ (field, offset) | (FieldOff field offset) <- things_offsets ]
+    )
+  where
+   (tot_wds, ptr_wds, things_offsets) =
+       mkVirtHeapOffsetsWithPadding dflags header things
+
+-- | Just like mkVirtHeapOffsets, but for constructors
+mkVirtConstrOffsets
+  :: DynFlags -> [NonVoid (PrimRep, a)]
+  -> (WordOff, WordOff, [(NonVoid a, ByteOff)])
+mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags StdHeader
+
+-- | Just like mkVirtConstrOffsets, but used when we don't have the actual
+-- arguments. Useful when e.g. generating info tables; we just need to know
+-- sizes of pointer and non-pointer fields.
+mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff)
+mkVirtConstrSizes dflags field_reps
+  = (tot_wds, ptr_wds)
+  where
+    (tot_wds, ptr_wds, _) =
+       mkVirtConstrOffsets dflags
+         (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps)
+
+-------------------------------------------------------------------------
+--
+--        Making argument descriptors
+--
+--  An argument descriptor describes the layout of args on the stack,
+--  both for         * GC (stack-layout) purposes, and
+--                * saving/restoring registers when a heap-check fails
+--
+-- Void arguments aren't important, therefore (contrast constructSlowCall)
+--
+-------------------------------------------------------------------------
+
+-- bring in ARG_P, ARG_N, etc.
+#include "../includes/rts/storage/FunTypes.h"
+
+mkArgDescr :: DynFlags -> [Id] -> ArgDescr
+mkArgDescr dflags args
+  = let arg_bits = argBits dflags arg_reps
+        arg_reps = filter isNonV (map idArgRep args)
+           -- Getting rid of voids eases matching of standard patterns
+    in case stdPattern arg_reps of
+         Just spec_id -> ArgSpec spec_id
+         Nothing      -> ArgGen  arg_bits
+
+argBits :: DynFlags -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr
+argBits _      []           = []
+argBits dflags (P   : args) = False : argBits dflags args
+argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)
+                    ++ argBits dflags args
+
+----------------------
+stdPattern :: [ArgRep] -> Maybe Int
+stdPattern reps
+  = case reps of
+        []    -> Just ARG_NONE        -- just void args, probably
+        [N]   -> Just ARG_N
+        [P]   -> Just ARG_P
+        [F]   -> Just ARG_F
+        [D]   -> Just ARG_D
+        [L]   -> Just ARG_L
+        [V16] -> Just ARG_V16
+        [V32] -> Just ARG_V32
+        [V64] -> Just ARG_V64
+
+        [N,N] -> Just ARG_NN
+        [N,P] -> Just ARG_NP
+        [P,N] -> Just ARG_PN
+        [P,P] -> Just ARG_PP
+
+        [N,N,N] -> Just ARG_NNN
+        [N,N,P] -> Just ARG_NNP
+        [N,P,N] -> Just ARG_NPN
+        [N,P,P] -> Just ARG_NPP
+        [P,N,N] -> Just ARG_PNN
+        [P,N,P] -> Just ARG_PNP
+        [P,P,N] -> Just ARG_PPN
+        [P,P,P] -> Just ARG_PPP
+
+        [P,P,P,P]     -> Just ARG_PPPP
+        [P,P,P,P,P]   -> Just ARG_PPPPP
+        [P,P,P,P,P,P] -> Just ARG_PPPPPP
+
+        _ -> Nothing
+
+-------------------------------------------------------------------------
+--
+--        Generating the info table and code for a closure
+--
+-------------------------------------------------------------------------
+
+-- Here we make an info table of type 'CmmInfo'.  The concrete
+-- representation as a list of 'CmmAddr' is handled later
+-- in the pipeline by 'cmmToRawCmm'.
+-- When loading the free variables, a function closure pointer may be tagged,
+-- so we must take it into account.
+
+emitClosureProcAndInfoTable :: Bool                    -- top-level?
+                            -> Id                      -- name of the closure
+                            -> LambdaFormInfo
+                            -> CmmInfoTable
+                            -> [NonVoid Id]            -- incoming arguments
+                            -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body
+                            -> FCode ()
+emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
+ = do   { dflags <- getDynFlags
+        -- Bind the binder itself, but only if it's not a top-level
+        -- binding. We need non-top let-bindings to refer to the
+        -- top-level binding, which this binding would incorrectly shadow.
+        ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr)
+                  else bindToReg (NonVoid bndr) lf_info
+        ; let node_points = nodeMustPointToIt dflags lf_info
+        ; arg_regs <- bindArgsToRegs args
+        ; let args' = if node_points then (node : arg_regs) else arg_regs
+              conv  = if nodeMustPointToIt dflags lf_info then NativeNodeCall
+                                                          else NativeDirectCall
+              (offset, _, _) = mkCallEntry dflags conv args' []
+        ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)
+        }
+
+-- Data constructors need closures, but not with all the argument handling
+-- needed for functions. The shared part goes here.
+emitClosureAndInfoTable ::
+  CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()
+emitClosureAndInfoTable info_tbl conv args body
+  = do { (_, blks) <- getCodeScoped body
+       ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)
+       ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
+       }
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -0,0 +1,876 @@
+{-# LANGUAGE GADTs, UnboxedTuples #-}
+
+-----------------------------------------------------------------------------
+--
+-- Monad for Stg to C-- code generation
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmMonad (
+        FCode,        -- type
+
+        initC, runC, fixC,
+        newUnique,
+
+        emitLabel,
+
+        emit, emitDecl, emitProc,
+        emitProcWithConvention, emitProcWithStackFrame,
+        emitOutOfLine, emitAssign, emitStore,
+        emitComment, emitTick, emitUnwind,
+
+        getCmm, aGraphToGraph,
+        getCodeR, getCode, getCodeScoped, getHeapUsage,
+
+        mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
+        mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',
+
+        mkCall, mkCmmCall,
+
+        forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,
+
+        ConTagZ,
+
+        Sequel(..), ReturnKind(..),
+        withSequel, getSequel,
+
+        setTickyCtrLabel, getTickyCtrLabel,
+        tickScope, getTickScope,
+
+        withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,
+
+        HeapUsage(..), VirtualHpOffset,        initHpUsage,
+        getHpUsage,  setHpUsage, heapHWM,
+        setVirtHp, getVirtHp, setRealHp,
+
+        getModuleName,
+
+        -- ideally we wouldn't export these, but some other modules access internal state
+        getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, getThisPackage,
+
+        -- more localised access to monad state
+        CgIdInfo(..),
+        getBinds, setBinds,
+
+        -- out of general friendliness, we also export ...
+        CgInfoDownwards(..), CgState(..)        -- non-abstract
+    ) where
+
+import GhcPrelude hiding( sequence, succ )
+
+import Cmm
+import StgCmmClosure
+import DynFlags
+import Hoopl.Collections
+import MkGraph
+import BlockId
+import CLabel
+import SMRep
+import Module
+import Id
+import VarEnv
+import OrdList
+import BasicTypes( ConTagZ )
+import Unique
+import UniqSupply
+import FastString
+import Outputable
+import Util
+
+import Control.Monad
+import Data.List
+
+
+
+--------------------------------------------------------
+-- The FCode monad and its types
+--
+-- FCode is the monad plumbed through the Stg->Cmm code generator, and
+-- the Cmm parser.  It contains the following things:
+--
+--  - A writer monad, collecting:
+--    - code for the current function, in the form of a CmmAGraph.
+--      The function "emit" appends more code to this.
+--    - the top-level CmmDecls accumulated so far
+--
+--  - A state monad with:
+--    - the local bindings in scope
+--    - the current heap usage
+--    - a UniqSupply
+--
+--  - A reader monad, for CgInfoDownwards, containing
+--    - DynFlags,
+--    - the current Module
+--    - the update-frame offset
+--    - the ticky counter label
+--    - the Sequel (the continuation to return to)
+--    - the self-recursive tail call information
+
+--------------------------------------------------------
+
+newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }
+
+instance Functor FCode where
+    fmap f (FCode g) = FCode $ \i s -> case g i s of (a, s') -> (f a, s')
+
+instance Applicative FCode where
+    pure val = FCode (\_info_down state -> (val, state))
+    {-# INLINE pure #-}
+    (<*>) = ap
+
+instance Monad FCode where
+    FCode m >>= k = FCode $
+        \info_down state ->
+            case m info_down state of
+              (m_result, new_state) ->
+                 case k m_result of
+                   FCode kcode -> kcode info_down new_state
+    {-# INLINE (>>=) #-}
+
+instance MonadUnique FCode where
+  getUniqueSupplyM = cgs_uniqs <$> getState
+  getUniqueM = FCode $ \_ st ->
+    let (u, us') = takeUniqFromSupply (cgs_uniqs st)
+    in (u, st { cgs_uniqs = us' })
+
+initC :: IO CgState
+initC  = do { uniqs <- mkSplitUniqSupply 'c'
+            ; return (initCgState uniqs) }
+
+runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
+runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st
+
+fixC :: (a -> FCode a) -> FCode a
+fixC fcode = FCode $
+    \info_down state -> let (v, s) = doFCode (fcode v) info_down state
+                        in (v, s)
+
+--------------------------------------------------------
+--        The code generator environment
+--------------------------------------------------------
+
+-- This monadery has some information that it only passes
+-- *downwards*, as well as some ``state'' which is modified
+-- as we go along.
+
+data CgInfoDownwards        -- information only passed *downwards* by the monad
+  = MkCgInfoDown {
+        cgd_dflags    :: DynFlags,
+        cgd_mod       :: Module,            -- Module being compiled
+        cgd_updfr_off :: UpdFrameOffset,    -- Size of current update frame
+        cgd_ticky     :: CLabel,            -- Current destination for ticky counts
+        cgd_sequel    :: Sequel,            -- What to do at end of basic block
+        cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled
+                                            -- as local jumps? See Note
+                                            -- [Self-recursive tail calls] in
+                                            -- StgCmmExpr
+        cgd_tick_scope:: CmmTickScope       -- Tick scope for new blocks & ticks
+  }
+
+type CgBindings = IdEnv CgIdInfo
+
+data CgIdInfo
+  = CgIdInfo
+        { cg_id :: Id   -- Id that this is the info for
+                        -- Can differ from the Id at occurrence sites by
+                        -- virtue of being externalised, for splittable C
+                        -- See Note [Externalise when splitting]
+        , cg_lf  :: LambdaFormInfo
+        , cg_loc :: CgLoc                     -- CmmExpr for the *tagged* value
+        }
+
+-- Note [Externalise when splitting]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- If we're splitting the object with -fsplit-objs, we need to
+-- externalise *all* the top-level names, and then make sure we only
+-- use the externalised one in any C label we use which refers to this
+-- name.
+
+instance Outputable CgIdInfo where
+  ppr (CgIdInfo { cg_id = id, cg_loc = loc })
+    = ppr id <+> text "-->" <+> ppr loc
+
+-- Sequel tells what to do with the result of this expression
+data Sequel
+  = Return              -- Return result(s) to continuation found on the stack.
+
+  | AssignTo
+        [LocalReg]      -- Put result(s) in these regs and fall through
+                        -- NB: no void arguments here
+                        --
+        Bool            -- Should we adjust the heap pointer back to
+                        -- recover space that's unused on this path?
+                        -- We need to do this only if the expression
+                        -- may allocate (e.g. it's a foreign call or
+                        -- allocating primOp)
+
+instance Outputable Sequel where
+    ppr Return = text "Return"
+    ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b
+
+-- See Note [sharing continuations] below
+data ReturnKind
+  = AssignedDirectly
+  | ReturnedTo BlockId ByteOff
+
+-- Note [sharing continuations]
+--
+-- ReturnKind says how the expression being compiled returned its
+-- results: either by assigning directly to the registers specified
+-- by the Sequel, or by returning to a continuation that does the
+-- assignments.  The point of this is we might be able to re-use the
+-- continuation in a subsequent heap-check.  Consider:
+--
+--    case f x of z
+--      True  -> <True code>
+--      False -> <False code>
+--
+-- Naively we would generate
+--
+--    R2 = x   -- argument to f
+--    Sp[young(L1)] = L1
+--    call f returns to L1
+--  L1:
+--    z = R1
+--    if (z & 1) then Ltrue else Lfalse
+--  Ltrue:
+--    Hp = Hp + 24
+--    if (Hp > HpLim) then L4 else L7
+--  L4:
+--    HpAlloc = 24
+--    goto L5
+--  L5:
+--    R1 = z
+--    Sp[young(L6)] = L6
+--    call stg_gc_unpt_r1 returns to L6
+--  L6:
+--    z = R1
+--    goto L1
+--  L7:
+--    <True code>
+--  Lfalse:
+--    <False code>
+--
+-- We want the gc call in L4 to return to L1, and discard L6.  Note
+-- that not only can we share L1 and L6, but the assignment of the
+-- return address in L4 is unnecessary because the return address for
+-- L1 is already on the stack.  We used to catch the sharing of L1 and
+-- L6 in the common-block-eliminator, but not the unnecessary return
+-- address assignment.
+--
+-- Since this case is so common I decided to make it more explicit and
+-- robust by programming the sharing directly, rather than relying on
+-- the common-block eliminator to catch it.  This makes
+-- common-block-elimination an optional optimisation, and furthermore
+-- generates less code in the first place that we have to subsequently
+-- clean up.
+--
+-- There are some rarer cases of common blocks that we don't catch
+-- this way, but that's ok.  Common-block-elimination is still available
+-- to catch them when optimisation is enabled.  Some examples are:
+--
+--   - when both the True and False branches do a heap check, we
+--     can share the heap-check failure code L4a and maybe L4
+--
+--   - in a case-of-case, there might be multiple continuations that
+--     we can common up.
+--
+-- It is always safe to use AssignedDirectly.  Expressions that jump
+-- to the continuation from multiple places (e.g. case expressions)
+-- fall back to AssignedDirectly.
+--
+
+
+initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
+initCgInfoDown dflags mod
+  = MkCgInfoDown { cgd_dflags    = dflags
+                 , cgd_mod       = mod
+                 , cgd_updfr_off = initUpdFrameOff dflags
+                 , cgd_ticky     = mkTopTickyCtrLabel
+                 , cgd_sequel    = initSequel
+                 , cgd_self_loop = Nothing
+                 , cgd_tick_scope= GlobalScope }
+
+initSequel :: Sequel
+initSequel = Return
+
+initUpdFrameOff :: DynFlags -> UpdFrameOffset
+initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA
+
+
+--------------------------------------------------------
+--        The code generator state
+--------------------------------------------------------
+
+data CgState
+  = MkCgState {
+     cgs_stmts :: CmmAGraph,          -- Current procedure
+
+     cgs_tops  :: OrdList CmmDecl,
+        -- Other procedures and data blocks in this compilation unit
+        -- Both are ordered only so that we can
+        -- reduce forward references, when it's easy to do so
+
+     cgs_binds :: CgBindings,
+
+     cgs_hp_usg  :: HeapUsage,
+
+     cgs_uniqs :: UniqSupply }
+
+data HeapUsage   -- See Note [Virtual and real heap pointers]
+  = HeapUsage {
+        virtHp :: VirtualHpOffset,       -- Virtual offset of highest-allocated word
+                                         --   Incremented whenever we allocate
+        realHp :: VirtualHpOffset        -- realHp: Virtual offset of real heap ptr
+                                         --   Used in instruction addressing modes
+    }
+
+type VirtualHpOffset = WordOff
+
+
+{- Note [Virtual and real heap pointers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The code generator can allocate one or more objects contiguously, performing
+one heap check to cover allocation of all the objects at once.  Let's call
+this little chunk of heap space an "allocation chunk".  The code generator
+will emit code to
+  * Perform a heap-exhaustion check
+  * Move the heap pointer to the end of the allocation chunk
+  * Allocate multiple objects within the chunk
+
+The code generator uses VirtualHpOffsets to address words within a
+single allocation chunk; these start at one and increase positively.
+The first word of the chunk has VirtualHpOffset=1, the second has
+VirtualHpOffset=2, and so on.
+
+ * The field realHp tracks (the VirtualHpOffset) where the real Hp
+   register is pointing.  Typically it'll be pointing to the end of the
+   allocation chunk.
+
+ * The field virtHp gives the VirtualHpOffset of the highest-allocated
+   word so far.  It starts at zero (meaning no word has been allocated),
+   and increases whenever an object is allocated.
+
+The difference between realHp and virtHp gives the offset from the
+real Hp register of a particular word in the allocation chunk. This
+is what getHpRelOffset does.  Since the returned offset is relative
+to the real Hp register, it is valid only until you change the real
+Hp register.  (Changing virtHp doesn't matter.)
+-}
+
+
+initCgState :: UniqSupply -> CgState
+initCgState uniqs
+  = MkCgState { cgs_stmts  = mkNop
+              , cgs_tops   = nilOL
+              , cgs_binds  = emptyVarEnv
+              , cgs_hp_usg = initHpUsage
+              , cgs_uniqs  = uniqs }
+
+stateIncUsage :: CgState -> CgState -> CgState
+-- stateIncUsage@ e1 e2 incorporates in e1
+-- the heap high water mark found in e2.
+stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })
+     = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg }
+       `addCodeBlocksFrom` s2
+
+addCodeBlocksFrom :: CgState -> CgState -> CgState
+-- Add code blocks from the latter to the former
+-- (The cgs_stmts will often be empty, but not always; see codeOnly)
+s1 `addCodeBlocksFrom` s2
+  = s1 { cgs_stmts = cgs_stmts s1 MkGraph.<*> cgs_stmts s2,
+         cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }
+
+
+-- The heap high water mark is the larger of virtHp and hwHp.  The latter is
+-- only records the high water marks of forked-off branches, so to find the
+-- heap high water mark you have to take the max of virtHp and hwHp.  Remember,
+-- virtHp never retreats!
+--
+-- Note Jan 04: ok, so why do we only look at the virtual Hp??
+
+heapHWM :: HeapUsage -> VirtualHpOffset
+heapHWM = virtHp
+
+initHpUsage :: HeapUsage
+initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }
+
+maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
+hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
+
+--------------------------------------------------------
+-- Operators for getting and setting the state and "info_down".
+--------------------------------------------------------
+
+getState :: FCode CgState
+getState = FCode $ \_info_down state -> (state, state)
+
+setState :: CgState -> FCode ()
+setState state = FCode $ \_info_down _ -> ((), state)
+
+getHpUsage :: FCode HeapUsage
+getHpUsage = do
+        state <- getState
+        return $ cgs_hp_usg state
+
+setHpUsage :: HeapUsage -> FCode ()
+setHpUsage new_hp_usg = do
+        state <- getState
+        setState $ state {cgs_hp_usg = new_hp_usg}
+
+setVirtHp :: VirtualHpOffset -> FCode ()
+setVirtHp new_virtHp
+  = do  { hp_usage <- getHpUsage
+        ; setHpUsage (hp_usage {virtHp = new_virtHp}) }
+
+getVirtHp :: FCode VirtualHpOffset
+getVirtHp
+  = do  { hp_usage <- getHpUsage
+        ; return (virtHp hp_usage) }
+
+setRealHp ::  VirtualHpOffset -> FCode ()
+setRealHp new_realHp
+  = do  { hp_usage <- getHpUsage
+        ; setHpUsage (hp_usage {realHp = new_realHp}) }
+
+getBinds :: FCode CgBindings
+getBinds = do
+        state <- getState
+        return $ cgs_binds state
+
+setBinds :: CgBindings -> FCode ()
+setBinds new_binds = do
+        state <- getState
+        setState $ state {cgs_binds = new_binds}
+
+withState :: FCode a -> CgState -> FCode (a,CgState)
+withState (FCode fcode) newstate = FCode $ \info_down state ->
+  case fcode info_down newstate of
+    (retval, state2) -> ((retval,state2), state)
+
+newUniqSupply :: FCode UniqSupply
+newUniqSupply = do
+        state <- getState
+        let (us1, us2) = splitUniqSupply (cgs_uniqs state)
+        setState $ state { cgs_uniqs = us1 }
+        return us2
+
+newUnique :: FCode Unique
+newUnique = do
+        state <- getState
+        let (u,us') = takeUniqFromSupply (cgs_uniqs state)
+        setState $ state { cgs_uniqs = us' }
+        return u
+
+------------------
+getInfoDown :: FCode CgInfoDownwards
+getInfoDown = FCode $ \info_down state -> (info_down,state)
+
+getSelfLoop :: FCode (Maybe SelfLoopInfo)
+getSelfLoop = do
+        info_down <- getInfoDown
+        return $ cgd_self_loop info_down
+
+withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a
+withSelfLoop self_loop code = do
+        info_down <- getInfoDown
+        withInfoDown code (info_down {cgd_self_loop = Just self_loop})
+
+instance HasDynFlags FCode where
+    getDynFlags = liftM cgd_dflags getInfoDown
+
+getThisPackage :: FCode UnitId
+getThisPackage = liftM thisPackage getDynFlags
+
+withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
+withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
+
+-- ----------------------------------------------------------------------------
+-- Get the current module name
+
+getModuleName :: FCode Module
+getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
+
+-- ----------------------------------------------------------------------------
+-- Get/set the end-of-block info
+
+withSequel :: Sequel -> FCode a -> FCode a
+withSequel sequel code
+  = do  { info  <- getInfoDown
+        ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) }
+
+getSequel :: FCode Sequel
+getSequel = do  { info <- getInfoDown
+                ; return (cgd_sequel info) }
+
+-- ----------------------------------------------------------------------------
+-- Get/set the size of the update frame
+
+-- We keep track of the size of the update frame so that we
+-- can set the stack pointer to the proper address on return
+-- (or tail call) from the closure.
+-- There should be at most one update frame for each closure.
+-- Note: I'm including the size of the original return address
+-- in the size of the update frame -- hence the default case on `get'.
+
+withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a
+withUpdFrameOff size code
+  = do  { info  <- getInfoDown
+        ; withInfoDown code (info {cgd_updfr_off = size }) }
+
+getUpdFrameOff :: FCode UpdFrameOffset
+getUpdFrameOff
+  = do  { info  <- getInfoDown
+        ; return $ cgd_updfr_off info }
+
+-- ----------------------------------------------------------------------------
+-- Get/set the current ticky counter label
+
+getTickyCtrLabel :: FCode CLabel
+getTickyCtrLabel = do
+        info <- getInfoDown
+        return (cgd_ticky info)
+
+setTickyCtrLabel :: CLabel -> FCode a -> FCode a
+setTickyCtrLabel ticky code = do
+        info <- getInfoDown
+        withInfoDown code (info {cgd_ticky = ticky})
+
+-- ----------------------------------------------------------------------------
+-- Manage tick scopes
+
+-- | The current tick scope. We will assign this to generated blocks.
+getTickScope :: FCode CmmTickScope
+getTickScope = do
+        info <- getInfoDown
+        return (cgd_tick_scope info)
+
+-- | Places blocks generated by the given code into a fresh
+-- (sub-)scope. This will make sure that Cmm annotations in our scope
+-- will apply to the Cmm blocks generated therein - but not the other
+-- way around.
+tickScope :: FCode a -> FCode a
+tickScope code = do
+        info <- getInfoDown
+        if debugLevel (cgd_dflags info) == 0 then code else do
+          u <- newUnique
+          let scope' = SubScope u (cgd_tick_scope info)
+          withInfoDown code info{ cgd_tick_scope = scope' }
+
+
+--------------------------------------------------------
+--                 Forking
+--------------------------------------------------------
+
+forkClosureBody :: FCode () -> FCode ()
+-- forkClosureBody compiles body_code in environment where:
+--   - sequel, update stack frame and self loop info are
+--     set to fresh values
+--   - state is set to a fresh value, except for local bindings
+--     that are passed in unchanged. It's up to the enclosed code to
+--     re-bind the free variables to a field of the closure.
+
+forkClosureBody body_code
+  = do  { dflags <- getDynFlags
+        ; info   <- getInfoDown
+        ; us     <- newUniqSupply
+        ; state  <- getState
+        ; let body_info_down = info { cgd_sequel    = initSequel
+                                    , cgd_updfr_off = initUpdFrameOff dflags
+                                    , cgd_self_loop = Nothing }
+              fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
+              ((),fork_state_out) = doFCode body_code body_info_down fork_state_in
+        ; setState $ state `addCodeBlocksFrom` fork_state_out }
+
+forkLneBody :: FCode a -> FCode a
+-- 'forkLneBody' takes a body of let-no-escape binding and compiles
+-- it in the *current* environment, returning the graph thus constructed.
+--
+-- The current environment is passed on completely unchanged to
+-- the successor.  In particular, any heap usage from the enclosed
+-- code is discarded; it should deal with its own heap consumption.
+forkLneBody body_code
+  = do  { info_down <- getInfoDown
+        ; us        <- newUniqSupply
+        ; state     <- getState
+        ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
+              (result, fork_state_out) = doFCode body_code info_down fork_state_in
+        ; setState $ state `addCodeBlocksFrom` fork_state_out
+        ; return result }
+
+codeOnly :: FCode () -> FCode ()
+-- Emit any code from the inner thing into the outer thing
+-- Do not affect anything else in the outer state
+-- Used in almost-circular code to prevent false loop dependencies
+codeOnly body_code
+  = do  { info_down <- getInfoDown
+        ; us        <- newUniqSupply
+        ; state     <- getState
+        ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state
+                                                 , cgs_hp_usg  = cgs_hp_usg state }
+                ((), fork_state_out) = doFCode body_code info_down fork_state_in
+        ; setState $ state `addCodeBlocksFrom` fork_state_out }
+
+forkAlts :: [FCode a] -> FCode [a]
+-- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and
+-- an fcode for the default case 'd', and compiles each in the current
+-- environment.  The current environment is passed on unmodified, except
+-- that the virtual Hp is moved on to the worst virtual Hp for the branches
+
+forkAlts branch_fcodes
+  = do  { info_down <- getInfoDown
+        ; us <- newUniqSupply
+        ; state <- getState
+        ; let compile us branch
+                = (us2, doFCode branch info_down branch_state)
+                where
+                  (us1,us2) = splitUniqSupply us
+                  branch_state = (initCgState us1) {
+                                        cgs_binds  = cgs_binds state
+                                      , cgs_hp_usg = cgs_hp_usg state }
+              (_us, results) = mapAccumL compile us branch_fcodes
+              (branch_results, branch_out_states) = unzip results
+        ; setState $ foldl' stateIncUsage state branch_out_states
+                -- NB foldl.  state is the *left* argument to stateIncUsage
+        ; return branch_results }
+
+forkAltPair :: FCode a -> FCode a -> FCode (a,a)
+-- Most common use of 'forkAlts'; having this helper function avoids
+-- accidental use of failible pattern-matches in @do@-notation
+forkAltPair x y = do
+  xy' <- forkAlts [x,y]
+  case xy' of
+    [x',y'] -> return (x',y')
+    _ -> panic "forkAltPair"
+
+-- collect the code emitted by an FCode computation
+getCodeR :: FCode a -> FCode (a, CmmAGraph)
+getCodeR fcode
+  = do  { state1 <- getState
+        ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })
+        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
+        ; return (a, cgs_stmts state2) }
+
+getCode :: FCode a -> FCode CmmAGraph
+getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }
+
+-- | Generate code into a fresh tick (sub-)scope and gather generated code
+getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped)
+getCodeScoped fcode
+  = do  { state1 <- getState
+        ; ((a, tscope), state2) <-
+            tickScope $
+            flip withState state1 { cgs_stmts = mkNop } $
+            do { a   <- fcode
+               ; scp <- getTickScope
+               ; return (a, scp) }
+        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }
+        ; return (a, (cgs_stmts state2, tscope)) }
+
+
+-- 'getHeapUsage' applies a function to the amount of heap that it uses.
+-- It initialises the heap usage to zeros, and passes on an unchanged
+-- heap usage.
+--
+-- It is usually a prelude to performing a GC check, so everything must
+-- be in a tidy and consistent state.
+--
+-- Note the slightly subtle fixed point behaviour needed here
+
+getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a
+getHeapUsage fcode
+  = do  { info_down <- getInfoDown
+        ; state <- getState
+        ; let   fstate_in = state { cgs_hp_usg  = initHpUsage }
+                (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in
+                hp_hw = heapHWM (cgs_hp_usg fstate_out)        -- Loop here!
+
+        ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
+        ; return r }
+
+-- ----------------------------------------------------------------------------
+-- Combinators for emitting code
+
+emitCgStmt :: CgStmt -> FCode ()
+emitCgStmt stmt
+  = do  { state <- getState
+        ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
+        }
+
+emitLabel :: BlockId -> FCode ()
+emitLabel id = do tscope <- getTickScope
+                  emitCgStmt (CgLabel id tscope)
+
+emitComment :: FastString -> FCode ()
+emitComment s
+  | debugIsOn = emitCgStmt (CgStmt (CmmComment s))
+  | otherwise = return ()
+
+emitTick :: CmmTickish -> FCode ()
+emitTick = emitCgStmt . CgStmt . CmmTick
+
+emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode ()
+emitUnwind regs = do
+  dflags <- getDynFlags
+  when (debugLevel dflags > 0) $ do
+     emitCgStmt $ CgStmt $ CmmUnwind regs
+
+emitAssign :: CmmReg  -> CmmExpr -> FCode ()
+emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
+
+emitStore :: CmmExpr  -> CmmExpr -> FCode ()
+emitStore l r = emitCgStmt (CgStmt (CmmStore l r))
+
+emit :: CmmAGraph -> FCode ()
+emit ag
+  = do  { state <- getState
+        ; setState $ state { cgs_stmts = cgs_stmts state MkGraph.<*> ag } }
+
+emitDecl :: CmmDecl -> FCode ()
+emitDecl decl
+  = do  { state <- getState
+        ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
+
+emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()
+emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope)
+
+emitProcWithStackFrame
+   :: Convention                        -- entry convention
+   -> Maybe CmmInfoTable                -- info table?
+   -> CLabel                            -- label for the proc
+   -> [CmmFormal]                       -- stack frame
+   -> [CmmFormal]                       -- arguments
+   -> CmmAGraphScoped                   -- code
+   -> Bool                              -- do stack layout?
+   -> FCode ()
+
+emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
+  = do  { dflags <- getDynFlags
+        ; emitProc_ mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False
+        }
+emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True
+        -- do layout
+  = do  { dflags <- getDynFlags
+        ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args
+              graph' = entry MkGraph.<*> graph
+        ; emitProc_ mb_info lbl live (graph', tscope) offset True
+        }
+emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"
+
+emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
+                       -> [CmmFormal]
+                       -> CmmAGraphScoped
+                       -> FCode ()
+emitProcWithConvention conv mb_info lbl args blocks
+  = emitProcWithStackFrame conv mb_info lbl [] args blocks True
+
+emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
+         -> Int -> FCode ()
+emitProc  mb_info lbl live blocks offset
+ = emitProc_ mb_info lbl live blocks offset True
+
+emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
+          -> Int -> Bool -> FCode ()
+emitProc_ mb_info lbl live blocks offset do_layout
+  = do  { dflags <- getDynFlags
+        ; l <- newBlockId
+        ; let
+              blks = labelAGraph l blocks
+
+              infos | Just info <- mb_info = mapSingleton (g_entry blks) info
+                    | otherwise            = mapEmpty
+
+              sinfo = StackInfo { arg_space = offset
+                                , updfr_space = Just (initUpdFrameOff dflags)
+                                , do_layout = do_layout }
+
+              tinfo = TopInfo { info_tbls = infos
+                              , stack_info=sinfo}
+
+              proc_block = CmmProc tinfo lbl live blks
+
+        ; state <- getState
+        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
+
+getCmm :: FCode () -> FCode CmmGroup
+-- Get all the CmmTops (there should be no stmts)
+-- Return a single Cmm which may be split from other Cmms by
+-- object splitting (at a later stage)
+getCmm code
+  = do  { state1 <- getState
+        ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })
+        ; setState $ state2 { cgs_tops = cgs_tops state1 }
+        ; return (fromOL (cgs_tops state2)) }
+
+
+mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
+mkCmmIfThenElse e tbranch fbranch = mkCmmIfThenElse' e tbranch fbranch Nothing
+
+mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph
+                 -> Maybe Bool -> FCode CmmAGraph
+mkCmmIfThenElse' e tbranch fbranch likely = do
+  tscp  <- getTickScope
+  endif <- newBlockId
+  tid   <- newBlockId
+  fid   <- newBlockId
+
+  let
+    (test, then_, else_, likely') = case likely of
+      Just False | Just e' <- maybeInvertCmmExpr e
+        -- currently NCG doesn't know about likely
+        -- annotations. We manually switch then and
+        -- else branch so the likely false branch
+        -- becomes a fallthrough.
+        -> (e', fbranch, tbranch, Just True)
+      _ -> (e, tbranch, fbranch, likely)
+
+  return $ catAGraphs [ mkCbranch test tid fid likely'
+                      , mkLabel tid tscp, then_, mkBranch endif
+                      , mkLabel fid tscp, else_, mkLabel endif tscp ]
+
+mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph
+mkCmmIfGoto e tid = mkCmmIfGoto' e tid Nothing
+
+mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph
+mkCmmIfGoto' e tid l = do
+  endif <- newBlockId
+  tscp  <- getTickScope
+  return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ]
+
+mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph
+mkCmmIfThen e tbranch = mkCmmIfThen' e tbranch Nothing
+
+mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
+mkCmmIfThen' e tbranch l = do
+  endif <- newBlockId
+  tid   <- newBlockId
+  tscp  <- getTickScope
+  return $ catAGraphs [ mkCbranch e tid endif l
+                      , mkLabel tid tscp, tbranch, mkLabel endif tscp ]
+
+mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr]
+       -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph
+mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
+  dflags <- getDynFlags
+  k      <- newBlockId
+  tscp   <- getTickScope
+  let area = Young k
+      (off, _, copyin) = copyInOflow dflags retConv area results []
+      copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack
+  return $ catAGraphs [copyout, mkLabel k tscp, copyin]
+
+mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset
+          -> FCode CmmAGraph
+mkCmmCall f results actuals updfr_off
+   = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []
+
+
+-- ----------------------------------------------------------------------------
+-- turn CmmAGraph into CmmGraph, for making a new proc.
+
+aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph
+aGraphToGraph stmts
+  = do  { l <- newBlockId
+        ; return (labelAGraph l stmts) }
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -0,0 +1,2545 @@
+{-# LANGUAGE CPP #-}
+-- emitPrimOp is quite large
+{-# OPTIONS_GHC -fmax-pmcheck-iterations=4000000 #-}
+
+----------------------------------------------------------------------------
+--
+-- Stg to C--: primitive operations
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmPrim (
+   cgOpApp,
+   cgPrimOp, -- internal(ish), used by cgCase to get code for a
+             -- comparison without also turning it into a Bool.
+   shouldInlinePrimOp
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude hiding ((<*>))
+
+import StgCmmLayout
+import StgCmmForeign
+import StgCmmEnv
+import StgCmmMonad
+import StgCmmUtils
+import StgCmmTicky
+import StgCmmHeap
+import StgCmmProf ( costCentreFrom )
+
+import DynFlags
+import Platform
+import BasicTypes
+import BlockId
+import MkGraph
+import StgSyn
+import Cmm
+import Type     ( Type, tyConAppTyCon )
+import TyCon
+import CLabel
+import CmmUtils
+import PrimOp
+import SMRep
+import FastString
+import Outputable
+import Util
+
+import Data.Bits ((.&.), bit)
+import Control.Monad (liftM, when, unless)
+
+------------------------------------------------------------------------
+--      Primitive operations and foreign calls
+------------------------------------------------------------------------
+
+{- Note [Foreign call results]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A foreign call always returns an unboxed tuple of results, one
+of which is the state token.  This seems to happen even for pure
+calls.
+
+Even if we returned a single result for pure calls, it'd still be
+right to wrap it in a singleton unboxed tuple, because the result
+might be a Haskell closure pointer, we don't want to evaluate it. -}
+
+----------------------------------
+cgOpApp :: StgOp        -- The op
+        -> [StgArg]     -- Arguments
+        -> Type         -- Result type (always an unboxed tuple)
+        -> FCode ReturnKind
+
+-- Foreign calls
+cgOpApp (StgFCallOp fcall _) stg_args res_ty
+  = cgForeignCall fcall stg_args res_ty
+      -- Note [Foreign call results]
+
+-- tagToEnum# is special: we need to pull the constructor
+-- out of the table, and perform an appropriate return.
+
+cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty
+  = ASSERT(isEnumerationTyCon tycon)
+    do  { dflags <- getDynFlags
+        ; args' <- getNonVoidArgAmodes [arg]
+        ; let amode = case args' of [amode] -> amode
+                                    _ -> panic "TagToEnumOp had void arg"
+        ; emitReturn [tagToClosure dflags tycon amode] }
+   where
+          -- If you're reading this code in the attempt to figure
+          -- out why the compiler panic'ed here, it is probably because
+          -- you used tagToEnum# in a non-monomorphic setting, e.g.,
+          --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#
+          -- That won't work.
+        tycon = tyConAppTyCon res_ty
+
+cgOpApp (StgPrimOp primop) args res_ty = do
+    dflags <- getDynFlags
+    cmm_args <- getNonVoidArgAmodes args
+    case shouldInlinePrimOp dflags primop cmm_args of
+        Nothing -> do  -- out-of-line
+          let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
+          emitCall (NativeNodeCall, NativeReturn) fun cmm_args
+
+        Just f  -- inline
+          | ReturnsPrim VoidRep <- result_info
+          -> do f []
+                emitReturn []
+
+          | ReturnsPrim rep <- result_info
+          -> do dflags <- getDynFlags
+                res <- newTemp (primRepCmmType dflags rep)
+                f [res]
+                emitReturn [CmmReg (CmmLocal res)]
+
+          | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
+          -> do (regs, _hints) <- newUnboxedTupleRegs res_ty
+                f regs
+                emitReturn (map (CmmReg . CmmLocal) regs)
+
+          | otherwise -> panic "cgPrimop"
+          where
+             result_info = getPrimOpResultInfo primop
+
+cgOpApp (StgPrimCallOp primcall) args _res_ty
+  = do  { cmm_args <- getNonVoidArgAmodes args
+        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))
+        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }
+
+-- | Interpret the argument as an unsigned value, assuming the value
+-- is given in two-complement form in the given width.
+--
+-- Example: @asUnsigned W64 (-1)@ is 18446744073709551615.
+--
+-- This function is used to work around the fact that many array
+-- primops take Int# arguments, but we interpret them as unsigned
+-- quantities in the code gen. This means that we have to be careful
+-- every time we work on e.g. a CmmInt literal that corresponds to the
+-- array size, as it might contain a negative Integer value if the
+-- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#
+-- literal.
+asUnsigned :: Width -> Integer -> Integer
+asUnsigned w n = n .&. (bit (widthInBits w) - 1)
+
+-- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use
+--     ByteOff (or some other fixed width signed type) to represent
+--     array sizes or indices. This means that these will overflow for
+--     large enough sizes.
+
+-- | Decide whether an out-of-line primop should be replaced by an
+-- inline implementation. This might happen e.g. if there's enough
+-- static information, such as statically know arguments, to emit a
+-- more efficient implementation inline.
+--
+-- Returns 'Nothing' if this primop should use its out-of-line
+-- implementation (defined elsewhere) and 'Just' together with a code
+-- generating function that takes the output regs as arguments
+-- otherwise.
+shouldInlinePrimOp :: DynFlags
+                   -> PrimOp     -- ^ The primop
+                   -> [CmmExpr]  -- ^ The primop arguments
+                   -> Maybe ([LocalReg] -> FCode ())
+
+shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n w))]
+  | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> doNewByteArrayOp res (fromInteger n)
+
+shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n w)), init]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] ->
+      doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel
+      [ (mkIntExpr dflags (fromInteger n),
+         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)
+      , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),
+         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)
+      ]
+      (fromInteger n) init
+
+shouldInlinePrimOp _ CopyArrayOp
+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
+        Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)
+
+shouldInlinePrimOp _ CopyMutableArrayOp
+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
+        Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)
+
+shouldInlinePrimOp _ CopyArrayArrayOp
+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
+        Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)
+
+shouldInlinePrimOp _ CopyMutableArrayArrayOp
+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
+        Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)
+
+shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n w)), init]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] ->
+      doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel
+      [ (mkIntExpr dflags (fromInteger n),
+         fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)
+      ]
+      (fromInteger n) init
+
+shouldInlinePrimOp _ CopySmallArrayOp
+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
+        Just $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)
+
+shouldInlinePrimOp _ CopySmallMutableArrayOp
+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =
+        Just $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)
+
+shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]
+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =
+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)
+
+shouldInlinePrimOp dflags primop args
+  | primOpOutOfLine primop = Nothing
+  | otherwise = Just $ \ regs -> emitPrimOp dflags regs primop args
+
+-- TODO: Several primops, such as 'copyArray#', only have an inline
+-- implementation (below) but could possibly have both an inline
+-- implementation and an out-of-line implementation, just like
+-- 'newArray#'. This would lower the amount of code generated,
+-- hopefully without a performance impact (needs to be measured).
+
+---------------------------------------------------
+cgPrimOp   :: [LocalReg]        -- where to put the results
+           -> PrimOp            -- the op
+           -> [StgArg]          -- arguments
+           -> FCode ()
+
+cgPrimOp results op args
+  = do dflags <- getDynFlags
+       arg_exprs <- getNonVoidArgAmodes args
+       emitPrimOp dflags results op arg_exprs
+
+
+------------------------------------------------------------------------
+--      Emitting code for a primop
+------------------------------------------------------------------------
+
+emitPrimOp :: DynFlags
+           -> [LocalReg]        -- where to put the results
+           -> PrimOp            -- the op
+           -> [CmmExpr]         -- arguments
+           -> FCode ()
+
+-- First we handle various awkward cases specially.  The remaining
+-- easy cases are then handled by translateOp, defined below.
+
+emitPrimOp _ [res] ParOp [arg]
+  =
+        -- for now, just implement this in a C function
+        -- later, we might want to inline it.
+    emitCCall
+        [(res,NoHint)]
+        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
+        [(baseExpr, AddrHint), (arg,AddrHint)]
+
+emitPrimOp dflags [res] SparkOp [arg]
+  = do
+        -- returns the value of arg in res.  We're going to therefore
+        -- refer to arg twice (once to pass to newSpark(), and once to
+        -- assign to res), so put it in a temporary.
+        tmp <- assignTemp arg
+        tmp2 <- newTemp (bWord dflags)
+        emitCCall
+            [(tmp2,NoHint)]
+            (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
+            [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
+        emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))
+
+emitPrimOp dflags [res] GetCCSOfOp [arg]
+  = emitAssign (CmmLocal res) val
+  where
+    val
+     | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)
+     | otherwise                      = CmmLit (zeroCLit dflags)
+
+emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg]
+   = emitAssign (CmmLocal res) cccsExpr
+
+emitPrimOp _ [res] MyThreadIdOp []
+   = emitAssign (CmmLocal res) currentTSOExpr
+
+emitPrimOp dflags [res] ReadMutVarOp [mutv]
+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))
+
+emitPrimOp dflags res@[] WriteMutVarOp [mutv,var]
+   = do -- Without this write barrier, other CPUs may see this pointer before
+        -- the writes for the closure it points to have occurred.
+        emitPrimCall res MO_WriteBarrier []
+        emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var
+        emitCCall
+                [{-no results-}]
+                (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
+                [(baseExpr, AddrHint), (mutv,AddrHint)]
+
+--  #define sizzeofByteArrayzh(r,a) \
+--     r = ((StgArrBytes *)(a))->bytes
+emitPrimOp dflags [res] SizeofByteArrayOp [arg]
+   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
+
+--  #define sizzeofMutableByteArrayzh(r,a) \
+--      r = ((StgArrBytes *)(a))->bytes
+emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg]
+   = emitPrimOp dflags [res] SizeofByteArrayOp [arg]
+
+--  #define getSizzeofMutableByteArrayzh(r,a) \
+--      r = ((StgArrBytes *)(a))->bytes
+emitPrimOp dflags [res] GetSizeofMutableByteArrayOp [arg]
+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
+
+
+--  #define touchzh(o)                  /* nothing */
+emitPrimOp _ res@[] TouchOp args@[_arg]
+   = do emitPrimCall res MO_Touch args
+
+--  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)
+emitPrimOp dflags [res] ByteArrayContents_Char [arg]
+   = emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))
+
+--  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)
+emitPrimOp dflags [res] StableNameToIntOp [arg]
+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))
+
+emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2]
+   = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])
+
+--  #define addrToHValuezh(r,a) r=(P_)a
+emitPrimOp _      [res] AddrToAnyOp [arg]
+   = emitAssign (CmmLocal res) arg
+
+--  #define hvalueToAddrzh(r, a) r=(W_)a
+emitPrimOp _      [res] AnyToAddrOp [arg]
+   = emitAssign (CmmLocal res) arg
+
+{- Freezing arrays-of-ptrs requires changing an info table, for the
+   benefit of the generational collector.  It needs to scavenge mutable
+   objects, even if they are in old space.  When they become immutable,
+   they can be removed from this scavenge list.  -}
+
+--  #define unsafeFreezzeArrayzh(r,a)
+--      {
+--        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);
+--        r = a;
+--      }
+emitPrimOp _      [res] UnsafeFreezeArrayOp [arg]
+   = emit $ catAGraphs
+   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),
+     mkAssign (CmmLocal res) arg ]
+emitPrimOp _      [res] UnsafeFreezeArrayArrayOp [arg]
+   = emit $ catAGraphs
+   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),
+     mkAssign (CmmLocal res) arg ]
+emitPrimOp _      [res] UnsafeFreezeSmallArrayOp [arg]
+   = emit $ catAGraphs
+   [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),
+     mkAssign (CmmLocal res) arg ]
+
+--  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)
+emitPrimOp _      [res] UnsafeFreezeByteArrayOp [arg]
+   = emitAssign (CmmLocal res) arg
+
+-- Reading/writing pointer arrays
+
+emitPrimOp _      [res] ReadArrayOp  [obj,ix]    = doReadPtrArrayOp res obj ix
+emitPrimOp _      [res] IndexArrayOp [obj,ix]    = doReadPtrArrayOp res obj ix
+emitPrimOp _      []  WriteArrayOp [obj,ix,v]  = doWritePtrArrayOp obj ix v
+
+emitPrimOp _      [res] IndexArrayArrayOp_ByteArray         [obj,ix]   = doReadPtrArrayOp res obj ix
+emitPrimOp _      [res] IndexArrayArrayOp_ArrayArray        [obj,ix]   = doReadPtrArrayOp res obj ix
+emitPrimOp _      [res] ReadArrayArrayOp_ByteArray          [obj,ix]   = doReadPtrArrayOp res obj ix
+emitPrimOp _      [res] ReadArrayArrayOp_MutableByteArray   [obj,ix]   = doReadPtrArrayOp res obj ix
+emitPrimOp _      [res] ReadArrayArrayOp_ArrayArray         [obj,ix]   = doReadPtrArrayOp res obj ix
+emitPrimOp _      [res] ReadArrayArrayOp_MutableArrayArray  [obj,ix]   = doReadPtrArrayOp res obj ix
+emitPrimOp _      []  WriteArrayArrayOp_ByteArray         [obj,ix,v] = doWritePtrArrayOp obj ix v
+emitPrimOp _      []  WriteArrayArrayOp_MutableByteArray  [obj,ix,v] = doWritePtrArrayOp obj ix v
+emitPrimOp _      []  WriteArrayArrayOp_ArrayArray        [obj,ix,v] = doWritePtrArrayOp obj ix v
+emitPrimOp _      []  WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v
+
+emitPrimOp _      [res] ReadSmallArrayOp  [obj,ix] = doReadSmallPtrArrayOp res obj ix
+emitPrimOp _      [res] IndexSmallArrayOp [obj,ix] = doReadSmallPtrArrayOp res obj ix
+emitPrimOp _      []  WriteSmallArrayOp [obj,ix,v] = doWriteSmallPtrArrayOp obj ix v
+
+-- Getting the size of pointer arrays
+
+emitPrimOp dflags [res] SizeofArrayOp [arg]
+   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg
+    (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags))
+        (bWord dflags))
+emitPrimOp dflags [res] SizeofMutableArrayOp [arg]
+   = emitPrimOp dflags [res] SizeofArrayOp [arg]
+emitPrimOp dflags [res] SizeofArrayArrayOp [arg]
+   = emitPrimOp dflags [res] SizeofArrayOp [arg]
+emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg]
+   = emitPrimOp dflags [res] SizeofArrayOp [arg]
+
+emitPrimOp dflags [res] SizeofSmallArrayOp [arg] =
+    emit $ mkAssign (CmmLocal res)
+    (cmmLoadIndexW dflags arg
+     (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags))
+        (bWord dflags))
+emitPrimOp dflags [res] SizeofSmallMutableArrayOp [arg] =
+    emitPrimOp dflags [res] SizeofSmallArrayOp [arg]
+
+-- IndexXXXoffAddr
+
+emitPrimOp dflags res IndexOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp dflags res IndexOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp _      res IndexOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args
+emitPrimOp _      res IndexOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args
+emitPrimOp dflags res IndexOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args
+emitPrimOp dflags res IndexOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args
+emitPrimOp dflags res IndexOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args
+emitPrimOp _      res IndexOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args
+emitPrimOp dflags res IndexOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args
+emitPrimOp dflags res IndexOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args
+emitPrimOp dflags res IndexOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp _      res IndexOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args
+
+-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.
+
+emitPrimOp dflags res ReadOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp dflags res ReadOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp _      res ReadOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args
+emitPrimOp _      res ReadOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args
+emitPrimOp dflags res ReadOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args
+emitPrimOp dflags res ReadOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args
+emitPrimOp dflags res ReadOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args
+emitPrimOp _      res ReadOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args
+emitPrimOp dflags res ReadOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args
+emitPrimOp dflags res ReadOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args
+emitPrimOp dflags res ReadOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp _      res ReadOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args
+
+-- IndexXXXArray
+
+emitPrimOp dflags res IndexByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp dflags res IndexByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp _      res IndexByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args
+emitPrimOp _      res IndexByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args
+emitPrimOp dflags res IndexByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res IndexByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args
+emitPrimOp dflags res IndexByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args
+emitPrimOp dflags res IndexByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args
+emitPrimOp _      res IndexByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args
+emitPrimOp dflags res IndexByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args
+emitPrimOp dflags res IndexByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args
+emitPrimOp dflags res IndexByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args
+emitPrimOp _      res IndexByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args
+
+-- ReadXXXArray, identical to IndexXXXArray.
+
+emitPrimOp dflags res ReadByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args
+emitPrimOp dflags res ReadByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp _      res ReadByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args
+emitPrimOp _      res ReadByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args
+emitPrimOp dflags res ReadByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args
+emitPrimOp dflags res ReadByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args
+emitPrimOp dflags res ReadByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args
+emitPrimOp dflags res ReadByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args
+emitPrimOp _      res ReadByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args
+emitPrimOp dflags res ReadByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args
+emitPrimOp dflags res ReadByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args
+emitPrimOp dflags res ReadByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args
+emitPrimOp _      res ReadByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args
+
+-- IndexWord8ArrayAsXXX
+
+emitPrimOp dflags res IndexByteArrayOp_Word8AsChar      args = doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsWideChar  args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsInt       args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsWord      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsAddr      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp _      res IndexByteArrayOp_Word8AsFloat     args = doIndexByteArrayOpAs   Nothing f32 b8 res args
+emitPrimOp _      res IndexByteArrayOp_Word8AsDouble    args = doIndexByteArrayOpAs   Nothing f64 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsStablePtr args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsInt16     args = doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsInt32     args = doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args
+emitPrimOp _      res IndexByteArrayOp_Word8AsInt64     args = doIndexByteArrayOpAs   Nothing b64 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsWord16    args = doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args
+emitPrimOp dflags res IndexByteArrayOp_Word8AsWord32    args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
+emitPrimOp _      res IndexByteArrayOp_Word8AsWord64    args = doIndexByteArrayOpAs   Nothing b64 b8 res args
+
+-- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX
+
+emitPrimOp dflags res ReadByteArrayOp_Word8AsChar      args = doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsWideChar  args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsInt       args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsWord      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsAddr      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp _      res ReadByteArrayOp_Word8AsFloat     args = doIndexByteArrayOpAs   Nothing f32 b8 res args
+emitPrimOp _      res ReadByteArrayOp_Word8AsDouble    args = doIndexByteArrayOpAs   Nothing f64 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsStablePtr args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsInt16     args = doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsInt32     args = doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args
+emitPrimOp _      res ReadByteArrayOp_Word8AsInt64     args = doIndexByteArrayOpAs   Nothing b64 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsWord16    args = doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args
+emitPrimOp dflags res ReadByteArrayOp_Word8AsWord32    args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args
+emitPrimOp _      res ReadByteArrayOp_Word8AsWord64    args = doIndexByteArrayOpAs   Nothing b64 b8 res args
+
+-- WriteXXXoffAddr
+
+emitPrimOp dflags res WriteOffAddrOp_Char             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteOffAddrOp_WideChar         args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp dflags res WriteOffAddrOp_Int              args = doWriteOffAddrOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteOffAddrOp_Word             args = doWriteOffAddrOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteOffAddrOp_Addr             args = doWriteOffAddrOp Nothing (bWord dflags) res args
+emitPrimOp _      res WriteOffAddrOp_Float            args = doWriteOffAddrOp Nothing f32 res args
+emitPrimOp _      res WriteOffAddrOp_Double           args = doWriteOffAddrOp Nothing f64 res args
+emitPrimOp dflags res WriteOffAddrOp_StablePtr        args = doWriteOffAddrOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteOffAddrOp_Int8             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteOffAddrOp_Int16            args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteOffAddrOp_Int32            args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp _      res WriteOffAddrOp_Int64            args = doWriteOffAddrOp Nothing b64 res args
+emitPrimOp dflags res WriteOffAddrOp_Word8            args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteOffAddrOp_Word16           args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteOffAddrOp_Word32           args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp _      res WriteOffAddrOp_Word64           args = doWriteOffAddrOp Nothing b64 res args
+
+-- WriteXXXArray
+
+emitPrimOp dflags res WriteByteArrayOp_Char             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteByteArrayOp_WideChar         args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp dflags res WriteByteArrayOp_Int              args = doWriteByteArrayOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteByteArrayOp_Word             args = doWriteByteArrayOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteByteArrayOp_Addr             args = doWriteByteArrayOp Nothing (bWord dflags) res args
+emitPrimOp _      res WriteByteArrayOp_Float            args = doWriteByteArrayOp Nothing f32 res args
+emitPrimOp _      res WriteByteArrayOp_Double           args = doWriteByteArrayOp Nothing f64 res args
+emitPrimOp dflags res WriteByteArrayOp_StablePtr        args = doWriteByteArrayOp Nothing (bWord dflags) res args
+emitPrimOp dflags res WriteByteArrayOp_Int8             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Int16            args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteByteArrayOp_Int32            args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp _      res WriteByteArrayOp_Int64            args = doWriteByteArrayOp Nothing b64 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8            args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8  res args
+emitPrimOp dflags res WriteByteArrayOp_Word16           args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args
+emitPrimOp dflags res WriteByteArrayOp_Word32           args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args
+emitPrimOp _      res WriteByteArrayOp_Word64           args = doWriteByteArrayOp Nothing b64 res args
+
+-- WriteInt8ArrayAsXXX
+
+emitPrimOp dflags res WriteByteArrayOp_Word8AsChar       args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8AsWideChar   args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsInt        args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsWord       args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsAddr       args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsFloat      args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsDouble     args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsStablePtr  args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8AsInt16      args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8AsInt32      args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsInt64      args = doWriteByteArrayOp Nothing b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8AsWord16     args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args
+emitPrimOp dflags res WriteByteArrayOp_Word8AsWord32     args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args
+emitPrimOp _      res WriteByteArrayOp_Word8AsWord64     args = doWriteByteArrayOp Nothing b8 res args
+
+-- Copying and setting byte arrays
+emitPrimOp _      [] CopyByteArrayOp [src,src_off,dst,dst_off,n] =
+    doCopyByteArrayOp src src_off dst dst_off n
+emitPrimOp _      [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] =
+    doCopyMutableByteArrayOp src src_off dst dst_off n
+emitPrimOp _      [] CopyByteArrayToAddrOp [src,src_off,dst,n] =
+    doCopyByteArrayToAddrOp src src_off dst n
+emitPrimOp _      [] CopyMutableByteArrayToAddrOp [src,src_off,dst,n] =
+    doCopyMutableByteArrayToAddrOp src src_off dst n
+emitPrimOp _      [] CopyAddrToByteArrayOp [src,dst,dst_off,n] =
+    doCopyAddrToByteArrayOp src dst dst_off n
+emitPrimOp _      [] SetByteArrayOp [ba,off,len,c] =
+    doSetByteArrayOp ba off len c
+
+-- Comparing byte arrays
+emitPrimOp _      [res] CompareByteArraysOp [ba1,ba1_off,ba2,ba2_off,n] =
+    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n
+
+emitPrimOp _      [res] BSwap16Op [w] = emitBSwapCall res w W16
+emitPrimOp _      [res] BSwap32Op [w] = emitBSwapCall res w W32
+emitPrimOp _      [res] BSwap64Op [w] = emitBSwapCall res w W64
+emitPrimOp dflags [res] BSwapOp   [w] = emitBSwapCall res w (wordWidth dflags)
+
+-- Population count
+emitPrimOp _      [res] PopCnt8Op  [w] = emitPopCntCall res w W8
+emitPrimOp _      [res] PopCnt16Op [w] = emitPopCntCall res w W16
+emitPrimOp _      [res] PopCnt32Op [w] = emitPopCntCall res w W32
+emitPrimOp _      [res] PopCnt64Op [w] = emitPopCntCall res w W64
+emitPrimOp dflags [res] PopCntOp   [w] = emitPopCntCall res w (wordWidth dflags)
+
+-- Parallel bit deposit
+emitPrimOp _      [res] Pdep8Op  [src, mask] = emitPdepCall res src mask W8
+emitPrimOp _      [res] Pdep16Op [src, mask] = emitPdepCall res src mask W16
+emitPrimOp _      [res] Pdep32Op [src, mask] = emitPdepCall res src mask W32
+emitPrimOp _      [res] Pdep64Op [src, mask] = emitPdepCall res src mask W64
+emitPrimOp dflags [res] PdepOp   [src, mask] = emitPdepCall res src mask (wordWidth dflags)
+
+-- Parallel bit extract
+emitPrimOp _      [res] Pext8Op  [src, mask] = emitPextCall res src mask W8
+emitPrimOp _      [res] Pext16Op [src, mask] = emitPextCall res src mask W16
+emitPrimOp _      [res] Pext32Op [src, mask] = emitPextCall res src mask W32
+emitPrimOp _      [res] Pext64Op [src, mask] = emitPextCall res src mask W64
+emitPrimOp dflags [res] PextOp   [src, mask] = emitPextCall res src mask (wordWidth dflags)
+
+-- count leading zeros
+emitPrimOp _      [res] Clz8Op  [w] = emitClzCall res w W8
+emitPrimOp _      [res] Clz16Op [w] = emitClzCall res w W16
+emitPrimOp _      [res] Clz32Op [w] = emitClzCall res w W32
+emitPrimOp _      [res] Clz64Op [w] = emitClzCall res w W64
+emitPrimOp dflags [res] ClzOp   [w] = emitClzCall res w (wordWidth dflags)
+
+-- count trailing zeros
+emitPrimOp _      [res] Ctz8Op [w]  = emitCtzCall res w W8
+emitPrimOp _      [res] Ctz16Op [w] = emitCtzCall res w W16
+emitPrimOp _      [res] Ctz32Op [w] = emitCtzCall res w W32
+emitPrimOp _      [res] Ctz64Op [w] = emitCtzCall res w W64
+emitPrimOp dflags [res] CtzOp   [w] = emitCtzCall res w (wordWidth dflags)
+
+-- Unsigned int to floating point conversions
+emitPrimOp _      [res] Word2FloatOp  [w] = emitPrimCall [res]
+                                            (MO_UF_Conv W32) [w]
+emitPrimOp _      [res] Word2DoubleOp [w] = emitPrimCall [res]
+                                            (MO_UF_Conv W64) [w]
+
+-- SIMD primops
+emitPrimOp dflags [res] (VecBroadcastOp vcat n w) [e] = do
+    checkVecCompatibility dflags vcat n w
+    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res
+  where
+    zeros :: CmmExpr
+    zeros = CmmLit $ CmmVec (replicate n zero)
+
+    zero :: CmmLit
+    zero = case vcat of
+             IntVec   -> CmmInt 0 w
+             WordVec  -> CmmInt 0 w
+             FloatVec -> CmmFloat 0 w
+
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags [res] (VecPackOp vcat n w) es = do
+    checkVecCompatibility dflags vcat n w
+    when (es `lengthIsNot` n) $
+        panic "emitPrimOp: VecPackOp has wrong number of arguments"
+    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res
+  where
+    zeros :: CmmExpr
+    zeros = CmmLit $ CmmVec (replicate n zero)
+
+    zero :: CmmLit
+    zero = case vcat of
+             IntVec   -> CmmInt 0 w
+             WordVec  -> CmmInt 0 w
+             FloatVec -> CmmFloat 0 w
+
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecUnpackOp vcat n w) [arg] = do
+    checkVecCompatibility dflags vcat n w
+    when (res `lengthIsNot` n) $
+        panic "emitPrimOp: VecUnpackOp has wrong number of results"
+    doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags [res] (VecInsertOp vcat n w) [v,e,i] = do
+    checkVecCompatibility dflags vcat n w
+    doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecIndexByteArrayOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexByteArrayOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecReadByteArrayOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexByteArrayOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecWriteByteArrayOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doWriteByteArrayOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecIndexOffAddrOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexOffAddrOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecReadOffAddrOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexOffAddrOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecWriteOffAddrOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doWriteOffAddrOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecVmmType vcat n w
+
+emitPrimOp dflags res (VecIndexScalarByteArrayOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexByteArrayOpAs Nothing vecty ty res args
+  where
+    vecty :: CmmType
+    vecty = vecVmmType vcat n w
+
+    ty :: CmmType
+    ty = vecCmmCat vcat w
+
+emitPrimOp dflags res (VecReadScalarByteArrayOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexByteArrayOpAs Nothing vecty ty res args
+  where
+    vecty :: CmmType
+    vecty = vecVmmType vcat n w
+
+    ty :: CmmType
+    ty = vecCmmCat vcat w
+
+emitPrimOp dflags res (VecWriteScalarByteArrayOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doWriteByteArrayOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecCmmCat vcat w
+
+emitPrimOp dflags res (VecIndexScalarOffAddrOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexOffAddrOpAs Nothing vecty ty res args
+  where
+    vecty :: CmmType
+    vecty = vecVmmType vcat n w
+
+    ty :: CmmType
+    ty = vecCmmCat vcat w
+
+emitPrimOp dflags res (VecReadScalarOffAddrOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doIndexOffAddrOpAs Nothing vecty ty res args
+  where
+    vecty :: CmmType
+    vecty = vecVmmType vcat n w
+
+    ty :: CmmType
+    ty = vecCmmCat vcat w
+
+emitPrimOp dflags res (VecWriteScalarOffAddrOp vcat n w) args = do
+    checkVecCompatibility dflags vcat n w
+    doWriteOffAddrOp Nothing ty res args
+  where
+    ty :: CmmType
+    ty = vecCmmCat vcat w
+
+-- Prefetch
+emitPrimOp _ [] PrefetchByteArrayOp3        args = doPrefetchByteArrayOp 3  args
+emitPrimOp _ [] PrefetchMutableByteArrayOp3 args = doPrefetchMutableByteArrayOp 3  args
+emitPrimOp _ [] PrefetchAddrOp3             args = doPrefetchAddrOp  3  args
+emitPrimOp _ [] PrefetchValueOp3            args = doPrefetchValueOp 3 args
+
+emitPrimOp _ [] PrefetchByteArrayOp2        args = doPrefetchByteArrayOp 2  args
+emitPrimOp _ [] PrefetchMutableByteArrayOp2 args = doPrefetchMutableByteArrayOp 2  args
+emitPrimOp _ [] PrefetchAddrOp2             args = doPrefetchAddrOp 2  args
+emitPrimOp _ [] PrefetchValueOp2           args = doPrefetchValueOp 2 args
+
+emitPrimOp _ [] PrefetchByteArrayOp1        args = doPrefetchByteArrayOp 1  args
+emitPrimOp _ [] PrefetchMutableByteArrayOp1 args = doPrefetchMutableByteArrayOp 1  args
+emitPrimOp _ [] PrefetchAddrOp1             args = doPrefetchAddrOp 1  args
+emitPrimOp _ [] PrefetchValueOp1            args = doPrefetchValueOp 1 args
+
+emitPrimOp _ [] PrefetchByteArrayOp0        args = doPrefetchByteArrayOp 0  args
+emitPrimOp _ [] PrefetchMutableByteArrayOp0 args = doPrefetchMutableByteArrayOp 0  args
+emitPrimOp _ [] PrefetchAddrOp0             args = doPrefetchAddrOp 0  args
+emitPrimOp _ [] PrefetchValueOp0            args = doPrefetchValueOp 0 args
+
+-- Atomic read-modify-write
+emitPrimOp dflags [res] FetchAddByteArrayOp_Int [mba, ix, n] =
+    doAtomicRMW res AMO_Add mba ix (bWord dflags) n
+emitPrimOp dflags [res] FetchSubByteArrayOp_Int [mba, ix, n] =
+    doAtomicRMW res AMO_Sub mba ix (bWord dflags) n
+emitPrimOp dflags [res] FetchAndByteArrayOp_Int [mba, ix, n] =
+    doAtomicRMW res AMO_And mba ix (bWord dflags) n
+emitPrimOp dflags [res] FetchNandByteArrayOp_Int [mba, ix, n] =
+    doAtomicRMW res AMO_Nand mba ix (bWord dflags) n
+emitPrimOp dflags [res] FetchOrByteArrayOp_Int [mba, ix, n] =
+    doAtomicRMW res AMO_Or mba ix (bWord dflags) n
+emitPrimOp dflags [res] FetchXorByteArrayOp_Int [mba, ix, n] =
+    doAtomicRMW res AMO_Xor mba ix (bWord dflags) n
+emitPrimOp dflags [res] AtomicReadByteArrayOp_Int [mba, ix] =
+    doAtomicReadByteArray res mba ix (bWord dflags)
+emitPrimOp dflags [] AtomicWriteByteArrayOp_Int [mba, ix, val] =
+    doAtomicWriteByteArray mba ix (bWord dflags) val
+emitPrimOp dflags [res] CasByteArrayOp_Int [mba, ix, old, new] =
+    doCasByteArray res mba ix (bWord dflags) old new
+
+-- The rest just translate straightforwardly
+emitPrimOp dflags [res] op [arg]
+   | nopOp op
+   = emitAssign (CmmLocal res) arg
+
+   | Just (mop,rep) <- narrowOp op
+   = emitAssign (CmmLocal res) $
+           CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]
+
+emitPrimOp dflags r@[res] op args
+   | Just prim <- callishOp op
+   = do emitPrimCall r prim args
+
+   | Just mop <- translateOp dflags op
+   = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in
+     emit stmt
+
+emitPrimOp dflags results op args
+   = case callishPrimOpSupported dflags op of
+          Left op   -> emit $ mkUnsafeCall (PrimTarget op) results args
+          Right gen -> gen results args
+
+type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()
+
+callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp
+callishPrimOpSupported dflags op
+  = case op of
+      IntQuotRemOp   | ncg && (x86ish || ppc) ->
+                         Left (MO_S_QuotRem  (wordWidth dflags))
+                     | otherwise              ->
+                         Right (genericIntQuotRemOp (wordWidth dflags))
+
+      Int8QuotRemOp  | ncg && (x86ish || ppc)
+                                     -> Left (MO_S_QuotRem W8)
+                     | otherwise     -> Right (genericIntQuotRemOp W8)
+
+      Int16QuotRemOp | ncg && (x86ish || ppc)
+                                     -> Left (MO_S_QuotRem W16)
+                     | otherwise     -> Right (genericIntQuotRemOp W16)
+
+
+      WordQuotRemOp  | ncg && (x86ish || ppc) ->
+                         Left (MO_U_QuotRem  (wordWidth dflags))
+                     | otherwise      ->
+                         Right (genericWordQuotRemOp (wordWidth dflags))
+
+      WordQuotRem2Op | (ncg && (x86ish || ppc))
+                          || llvm     -> Left (MO_U_QuotRem2 (wordWidth dflags))
+                     | otherwise      -> Right (genericWordQuotRem2Op dflags)
+
+      Word8QuotRemOp | ncg && (x86ish || ppc)
+                                      -> Left (MO_U_QuotRem W8)
+                     | otherwise      -> Right (genericWordQuotRemOp W8)
+
+      Word16QuotRemOp| ncg && (x86ish || ppc)
+                                     -> Left (MO_U_QuotRem W16)
+                     | otherwise     -> Right (genericWordQuotRemOp W16)
+
+      WordAdd2Op     | (ncg && (x86ish || ppc))
+                         || llvm      -> Left (MO_Add2       (wordWidth dflags))
+                     | otherwise      -> Right genericWordAdd2Op
+
+      WordAddCOp     | (ncg && (x86ish || ppc))
+                         || llvm      -> Left (MO_AddWordC   (wordWidth dflags))
+                     | otherwise      -> Right genericWordAddCOp
+
+      WordSubCOp     | (ncg && (x86ish || ppc))
+                         || llvm      -> Left (MO_SubWordC   (wordWidth dflags))
+                     | otherwise      -> Right genericWordSubCOp
+
+      IntAddCOp      | (ncg && (x86ish || ppc))
+                         || llvm      -> Left (MO_AddIntC    (wordWidth dflags))
+                     | otherwise      -> Right genericIntAddCOp
+
+      IntSubCOp      | (ncg && (x86ish || ppc))
+                         || llvm      -> Left (MO_SubIntC    (wordWidth dflags))
+                     | otherwise      -> Right genericIntSubCOp
+
+      WordMul2Op     | ncg && (x86ish || ppc)
+                         || llvm      -> Left (MO_U_Mul2     (wordWidth dflags))
+                     | otherwise      -> Right genericWordMul2Op
+      FloatFabsOp    | (ncg && x86ish || ppc)
+                         || llvm      -> Left MO_F32_Fabs
+                     | otherwise      -> Right $ genericFabsOp W32
+      DoubleFabsOp   | (ncg && x86ish || ppc)
+                         || llvm      -> Left MO_F64_Fabs
+                     | otherwise      -> Right $ genericFabsOp W64
+
+      _ -> pprPanic "emitPrimOp: can't translate PrimOp " (ppr op)
+ where
+  ncg = case hscTarget dflags of
+           HscAsm -> True
+           _      -> False
+  llvm = case hscTarget dflags of
+           HscLlvm -> True
+           _       -> False
+  x86ish = case platformArch (targetPlatform dflags) of
+             ArchX86    -> True
+             ArchX86_64 -> True
+             _          -> False
+  ppc = case platformArch (targetPlatform dflags) of
+          ArchPPC      -> True
+          ArchPPC_64 _ -> True
+          _            -> False
+
+genericIntQuotRemOp :: Width -> GenericOp
+genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]
+   = emit $ mkAssign (CmmLocal res_q)
+              (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>
+            mkAssign (CmmLocal res_r)
+              (CmmMachOp (MO_S_Rem  width) [arg_x, arg_y])
+genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"
+
+genericWordQuotRemOp :: Width -> GenericOp
+genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]
+    = emit $ mkAssign (CmmLocal res_q)
+               (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>
+             mkAssign (CmmLocal res_r)
+               (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y])
+genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"
+
+genericWordQuotRem2Op :: DynFlags -> GenericOp
+genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y]
+    = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low
+    where    ty = cmmExprType dflags arg_x_high
+             shl   x i = CmmMachOp (MO_Shl   (wordWidth dflags)) [x, i]
+             shr   x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]
+             or    x y = CmmMachOp (MO_Or    (wordWidth dflags)) [x, y]
+             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth dflags)) [x, y]
+             ne    x y = CmmMachOp (MO_Ne    (wordWidth dflags)) [x, y]
+             minus x y = CmmMachOp (MO_Sub   (wordWidth dflags)) [x, y]
+             times x y = CmmMachOp (MO_Mul   (wordWidth dflags)) [x, y]
+             zero   = lit 0
+             one    = lit 1
+             negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)
+             lit i = CmmLit (CmmInt i (wordWidth dflags))
+
+             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph
+             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>
+                                      mkAssign (CmmLocal res_r) high)
+             f i acc high low =
+                 do roverflowedBit <- newTemp ty
+                    rhigh'         <- newTemp ty
+                    rhigh''        <- newTemp ty
+                    rlow'          <- newTemp ty
+                    risge          <- newTemp ty
+                    racc'          <- newTemp ty
+                    let high'         = CmmReg (CmmLocal rhigh')
+                        isge          = CmmReg (CmmLocal risge)
+                        overflowedBit = CmmReg (CmmLocal roverflowedBit)
+                    let this = catAGraphs
+                               [mkAssign (CmmLocal roverflowedBit)
+                                          (shr high negone),
+                                mkAssign (CmmLocal rhigh')
+                                          (or (shl high one) (shr low negone)),
+                                mkAssign (CmmLocal rlow')
+                                          (shl low one),
+                                mkAssign (CmmLocal risge)
+                                          (or (overflowedBit `ne` zero)
+                                              (high' `ge` arg_y)),
+                                mkAssign (CmmLocal rhigh'')
+                                          (high' `minus` (arg_y `times` isge)),
+                                mkAssign (CmmLocal racc')
+                                          (or (shl acc one) isge)]
+                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))
+                                      (CmmReg (CmmLocal rhigh''))
+                                      (CmmReg (CmmLocal rlow'))
+                    return (this <*> rest)
+genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"
+
+genericWordAdd2Op :: GenericOp
+genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]
+  = do dflags <- getDynFlags
+       r1 <- newTemp (cmmExprType dflags arg_x)
+       r2 <- newTemp (cmmExprType dflags arg_x)
+       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
+           toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
+           bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
+           add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
+           or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
+           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
+                                (wordWidth dflags))
+           hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
+       emit $ catAGraphs
+          [mkAssign (CmmLocal r1)
+               (add (bottomHalf arg_x) (bottomHalf arg_y)),
+           mkAssign (CmmLocal r2)
+               (add (topHalf (CmmReg (CmmLocal r1)))
+                    (add (topHalf arg_x) (topHalf arg_y))),
+           mkAssign (CmmLocal res_h)
+               (topHalf (CmmReg (CmmLocal r2))),
+           mkAssign (CmmLocal res_l)
+               (or (toTopHalf (CmmReg (CmmLocal r2)))
+                   (bottomHalf (CmmReg (CmmLocal r1))))]
+genericWordAdd2Op _ _ = panic "genericWordAdd2Op"
+
+-- | Implements branchless recovery of the carry flag @c@ by checking the
+-- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@:
+--
+-- @
+--    c = a&b | (a|b)&~r
+-- @
+--
+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/
+genericWordAddCOp :: GenericOp
+genericWordAddCOp [res_r, res_c] [aa, bb]
+ = do dflags <- getDynFlags
+      emit $ catAGraphs [
+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),
+        mkAssign (CmmLocal res_c) $
+          CmmMachOp (mo_wordUShr dflags) [
+            CmmMachOp (mo_wordOr dflags) [
+              CmmMachOp (mo_wordAnd dflags) [aa,bb],
+              CmmMachOp (mo_wordAnd dflags) [
+                CmmMachOp (mo_wordOr dflags) [aa,bb],
+                CmmMachOp (mo_wordNot dflags) [CmmReg (CmmLocal res_r)]
+              ]
+            ],
+            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
+          ]
+        ]
+genericWordAddCOp _ _ = panic "genericWordAddCOp"
+
+-- | Implements branchless recovery of the carry flag @c@ by checking the
+-- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@:
+--
+-- @
+--    c = ~a&b | (~a|b)&r
+-- @
+--
+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/
+genericWordSubCOp :: GenericOp
+genericWordSubCOp [res_r, res_c] [aa, bb]
+ = do dflags <- getDynFlags
+      emit $ catAGraphs [
+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),
+        mkAssign (CmmLocal res_c) $
+          CmmMachOp (mo_wordUShr dflags) [
+            CmmMachOp (mo_wordOr dflags) [
+              CmmMachOp (mo_wordAnd dflags) [
+                CmmMachOp (mo_wordNot dflags) [aa],
+                bb
+              ],
+              CmmMachOp (mo_wordAnd dflags) [
+                CmmMachOp (mo_wordOr dflags) [
+                  CmmMachOp (mo_wordNot dflags) [aa],
+                  bb
+                ],
+                CmmReg (CmmLocal res_r)
+              ]
+            ],
+            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
+          ]
+        ]
+genericWordSubCOp _ _ = panic "genericWordSubCOp"
+
+genericIntAddCOp :: GenericOp
+genericIntAddCOp [res_r, res_c] [aa, bb]
+{-
+   With some bit-twiddling, we can define int{Add,Sub}Czh portably in
+   C, and without needing any comparisons.  This may not be the
+   fastest way to do it - if you have better code, please send it! --SDM
+
+   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.
+
+   We currently don't make use of the r value if c is != 0 (i.e.
+   overflow), we just convert to big integers and try again.  This
+   could be improved by making r and c the correct values for
+   plugging into a new J#.
+
+   { r = ((I_)(a)) + ((I_)(b));                                 \
+     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \
+         >> (BITS_IN (I_) - 1);                                 \
+   }
+   Wading through the mass of bracketry, it seems to reduce to:
+   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)
+
+-}
+ = do dflags <- getDynFlags
+      emit $ catAGraphs [
+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),
+        mkAssign (CmmLocal res_c) $
+          CmmMachOp (mo_wordUShr dflags) [
+                CmmMachOp (mo_wordAnd dflags) [
+                    CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],
+                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
+                ],
+                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
+          ]
+        ]
+genericIntAddCOp _ _ = panic "genericIntAddCOp"
+
+genericIntSubCOp :: GenericOp
+genericIntSubCOp [res_r, res_c] [aa, bb]
+{- Similarly:
+   #define subIntCzh(r,c,a,b)                                   \
+   { r = ((I_)(a)) - ((I_)(b));                                 \
+     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \
+         >> (BITS_IN (I_) - 1);                                 \
+   }
+
+   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)
+-}
+ = do dflags <- getDynFlags
+      emit $ catAGraphs [
+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),
+        mkAssign (CmmLocal res_c) $
+          CmmMachOp (mo_wordUShr dflags) [
+                CmmMachOp (mo_wordAnd dflags) [
+                    CmmMachOp (mo_wordXor dflags) [aa,bb],
+                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]
+                ],
+                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)
+          ]
+        ]
+genericIntSubCOp _ _ = panic "genericIntSubCOp"
+
+genericWordMul2Op :: GenericOp
+genericWordMul2Op [res_h, res_l] [arg_x, arg_y]
+ = do dflags <- getDynFlags
+      let t = cmmExprType dflags arg_x
+      xlyl <- liftM CmmLocal $ newTemp t
+      xlyh <- liftM CmmLocal $ newTemp t
+      xhyl <- liftM CmmLocal $ newTemp t
+      r    <- liftM CmmLocal $ newTemp t
+      -- This generic implementation is very simple and slow. We might
+      -- well be able to do better, but for now this at least works.
+      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]
+          toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]
+          bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]
+          add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]
+          sum = foldl1 add
+          mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]
+          or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]
+          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))
+                               (wordWidth dflags))
+          hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))
+      emit $ catAGraphs
+             [mkAssign xlyl
+                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),
+              mkAssign xlyh
+                  (mul (bottomHalf arg_x) (topHalf arg_y)),
+              mkAssign xhyl
+                  (mul (topHalf arg_x) (bottomHalf arg_y)),
+              mkAssign r
+                  (sum [topHalf    (CmmReg xlyl),
+                        bottomHalf (CmmReg xhyl),
+                        bottomHalf (CmmReg xlyh)]),
+              mkAssign (CmmLocal res_l)
+                  (or (bottomHalf (CmmReg xlyl))
+                      (toTopHalf (CmmReg r))),
+              mkAssign (CmmLocal res_h)
+                  (sum [mul (topHalf arg_x) (topHalf arg_y),
+                        topHalf (CmmReg xhyl),
+                        topHalf (CmmReg xlyh),
+                        topHalf (CmmReg r)])]
+genericWordMul2Op _ _ = panic "genericWordMul2Op"
+
+-- This replicates what we had in libraries/base/GHC/Float.hs:
+--
+--    abs x    | x == 0    = 0 -- handles (-0.0)
+--             | x >  0    = x
+--             | otherwise = negateFloat x
+genericFabsOp :: Width -> GenericOp
+genericFabsOp w [res_r] [aa]
+ = do dflags <- getDynFlags
+      let zero   = CmmLit (CmmFloat 0 w)
+
+          eq x y = CmmMachOp (MO_F_Eq w) [x, y]
+          gt x y = CmmMachOp (MO_F_Gt w) [x, y]
+
+          neg x  = CmmMachOp (MO_F_Neg w) [x]
+
+          g1 = catAGraphs [mkAssign (CmmLocal res_r) zero]
+          g2 = catAGraphs [mkAssign (CmmLocal res_r) aa]
+
+      res_t <- CmmLocal <$> newTemp (cmmExprType dflags aa)
+      let g3 = catAGraphs [mkAssign res_t aa,
+                           mkAssign (CmmLocal res_r) (neg (CmmReg res_t))]
+
+      g4 <- mkCmmIfThenElse (gt aa zero) g2 g3
+
+      emit =<< mkCmmIfThenElse (eq aa zero) g1 g4
+
+genericFabsOp _ _ _ = panic "genericFabsOp"
+
+-- These PrimOps are NOPs in Cmm
+
+nopOp :: PrimOp -> Bool
+nopOp Int2WordOp     = True
+nopOp Word2IntOp     = True
+nopOp Int2AddrOp     = True
+nopOp Addr2IntOp     = True
+nopOp ChrOp          = True  -- Int# and Char# are rep'd the same
+nopOp OrdOp          = True
+nopOp _              = False
+
+-- These PrimOps turn into double casts
+
+narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width)
+narrowOp Narrow8IntOp   = Just (MO_SS_Conv, W8)
+narrowOp Narrow16IntOp  = Just (MO_SS_Conv, W16)
+narrowOp Narrow32IntOp  = Just (MO_SS_Conv, W32)
+narrowOp Narrow8WordOp  = Just (MO_UU_Conv, W8)
+narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)
+narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)
+narrowOp _              = Nothing
+
+-- Native word signless ops
+
+translateOp :: DynFlags -> PrimOp -> Maybe MachOp
+translateOp dflags IntAddOp       = Just (mo_wordAdd dflags)
+translateOp dflags IntSubOp       = Just (mo_wordSub dflags)
+translateOp dflags WordAddOp      = Just (mo_wordAdd dflags)
+translateOp dflags WordSubOp      = Just (mo_wordSub dflags)
+translateOp dflags AddrAddOp      = Just (mo_wordAdd dflags)
+translateOp dflags AddrSubOp      = Just (mo_wordSub dflags)
+
+translateOp dflags IntEqOp        = Just (mo_wordEq dflags)
+translateOp dflags IntNeOp        = Just (mo_wordNe dflags)
+translateOp dflags WordEqOp       = Just (mo_wordEq dflags)
+translateOp dflags WordNeOp       = Just (mo_wordNe dflags)
+translateOp dflags AddrEqOp       = Just (mo_wordEq dflags)
+translateOp dflags AddrNeOp       = Just (mo_wordNe dflags)
+
+translateOp dflags AndOp          = Just (mo_wordAnd dflags)
+translateOp dflags OrOp           = Just (mo_wordOr dflags)
+translateOp dflags XorOp          = Just (mo_wordXor dflags)
+translateOp dflags NotOp          = Just (mo_wordNot dflags)
+translateOp dflags SllOp          = Just (mo_wordShl dflags)
+translateOp dflags SrlOp          = Just (mo_wordUShr dflags)
+
+translateOp dflags AddrRemOp      = Just (mo_wordURem dflags)
+
+-- Native word signed ops
+
+translateOp dflags IntMulOp        = Just (mo_wordMul dflags)
+translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags))
+translateOp dflags IntQuotOp       = Just (mo_wordSQuot dflags)
+translateOp dflags IntRemOp        = Just (mo_wordSRem dflags)
+translateOp dflags IntNegOp        = Just (mo_wordSNeg dflags)
+
+
+translateOp dflags IntGeOp        = Just (mo_wordSGe dflags)
+translateOp dflags IntLeOp        = Just (mo_wordSLe dflags)
+translateOp dflags IntGtOp        = Just (mo_wordSGt dflags)
+translateOp dflags IntLtOp        = Just (mo_wordSLt dflags)
+
+translateOp dflags AndIOp         = Just (mo_wordAnd dflags)
+translateOp dflags OrIOp          = Just (mo_wordOr dflags)
+translateOp dflags XorIOp         = Just (mo_wordXor dflags)
+translateOp dflags NotIOp         = Just (mo_wordNot dflags)
+translateOp dflags ISllOp         = Just (mo_wordShl dflags)
+translateOp dflags ISraOp         = Just (mo_wordSShr dflags)
+translateOp dflags ISrlOp         = Just (mo_wordUShr dflags)
+
+-- Native word unsigned ops
+
+translateOp dflags WordGeOp       = Just (mo_wordUGe dflags)
+translateOp dflags WordLeOp       = Just (mo_wordULe dflags)
+translateOp dflags WordGtOp       = Just (mo_wordUGt dflags)
+translateOp dflags WordLtOp       = Just (mo_wordULt dflags)
+
+translateOp dflags WordMulOp      = Just (mo_wordMul dflags)
+translateOp dflags WordQuotOp     = Just (mo_wordUQuot dflags)
+translateOp dflags WordRemOp      = Just (mo_wordURem dflags)
+
+translateOp dflags AddrGeOp       = Just (mo_wordUGe dflags)
+translateOp dflags AddrLeOp       = Just (mo_wordULe dflags)
+translateOp dflags AddrGtOp       = Just (mo_wordUGt dflags)
+translateOp dflags AddrLtOp       = Just (mo_wordULt dflags)
+
+-- Int8# signed ops
+
+translateOp dflags Int8Extend     = Just (MO_SS_Conv W8 (wordWidth dflags))
+translateOp dflags Int8Narrow     = Just (MO_SS_Conv (wordWidth dflags) W8)
+translateOp _      Int8NegOp      = Just (MO_S_Neg W8)
+translateOp _      Int8AddOp      = Just (MO_Add W8)
+translateOp _      Int8SubOp      = Just (MO_Sub W8)
+translateOp _      Int8MulOp      = Just (MO_Mul W8)
+translateOp _      Int8QuotOp     = Just (MO_S_Quot W8)
+translateOp _      Int8RemOp      = Just (MO_S_Rem W8)
+
+translateOp _      Int8EqOp       = Just (MO_Eq W8)
+translateOp _      Int8GeOp       = Just (MO_S_Ge W8)
+translateOp _      Int8GtOp       = Just (MO_S_Gt W8)
+translateOp _      Int8LeOp       = Just (MO_S_Le W8)
+translateOp _      Int8LtOp       = Just (MO_S_Lt W8)
+translateOp _      Int8NeOp       = Just (MO_Ne W8)
+
+-- Word8# unsigned ops
+
+translateOp dflags Word8Extend     = Just (MO_UU_Conv W8 (wordWidth dflags))
+translateOp dflags Word8Narrow     = Just (MO_UU_Conv (wordWidth dflags) W8)
+translateOp _      Word8NotOp      = Just (MO_Not W8)
+translateOp _      Word8AddOp      = Just (MO_Add W8)
+translateOp _      Word8SubOp      = Just (MO_Sub W8)
+translateOp _      Word8MulOp      = Just (MO_Mul W8)
+translateOp _      Word8QuotOp     = Just (MO_U_Quot W8)
+translateOp _      Word8RemOp      = Just (MO_U_Rem W8)
+
+translateOp _      Word8EqOp       = Just (MO_Eq W8)
+translateOp _      Word8GeOp       = Just (MO_U_Ge W8)
+translateOp _      Word8GtOp       = Just (MO_U_Gt W8)
+translateOp _      Word8LeOp       = Just (MO_U_Le W8)
+translateOp _      Word8LtOp       = Just (MO_U_Lt W8)
+translateOp _      Word8NeOp       = Just (MO_Ne W8)
+
+-- Int16# signed ops
+
+translateOp dflags Int16Extend     = Just (MO_SS_Conv W16 (wordWidth dflags))
+translateOp dflags Int16Narrow     = Just (MO_SS_Conv (wordWidth dflags) W16)
+translateOp _      Int16NegOp      = Just (MO_S_Neg W16)
+translateOp _      Int16AddOp      = Just (MO_Add W16)
+translateOp _      Int16SubOp      = Just (MO_Sub W16)
+translateOp _      Int16MulOp      = Just (MO_Mul W16)
+translateOp _      Int16QuotOp     = Just (MO_S_Quot W16)
+translateOp _      Int16RemOp      = Just (MO_S_Rem W16)
+
+translateOp _      Int16EqOp       = Just (MO_Eq W16)
+translateOp _      Int16GeOp       = Just (MO_S_Ge W16)
+translateOp _      Int16GtOp       = Just (MO_S_Gt W16)
+translateOp _      Int16LeOp       = Just (MO_S_Le W16)
+translateOp _      Int16LtOp       = Just (MO_S_Lt W16)
+translateOp _      Int16NeOp       = Just (MO_Ne W16)
+
+-- Word16# unsigned ops
+
+translateOp dflags Word16Extend     = Just (MO_UU_Conv W16 (wordWidth dflags))
+translateOp dflags Word16Narrow     = Just (MO_UU_Conv (wordWidth dflags) W16)
+translateOp _      Word16NotOp      = Just (MO_Not W16)
+translateOp _      Word16AddOp      = Just (MO_Add W16)
+translateOp _      Word16SubOp      = Just (MO_Sub W16)
+translateOp _      Word16MulOp      = Just (MO_Mul W16)
+translateOp _      Word16QuotOp     = Just (MO_U_Quot W16)
+translateOp _      Word16RemOp      = Just (MO_U_Rem W16)
+
+translateOp _      Word16EqOp       = Just (MO_Eq W16)
+translateOp _      Word16GeOp       = Just (MO_U_Ge W16)
+translateOp _      Word16GtOp       = Just (MO_U_Gt W16)
+translateOp _      Word16LeOp       = Just (MO_U_Le W16)
+translateOp _      Word16LtOp       = Just (MO_U_Lt W16)
+translateOp _      Word16NeOp       = Just (MO_Ne W16)
+
+-- Char# ops
+
+translateOp dflags CharEqOp       = Just (MO_Eq (wordWidth dflags))
+translateOp dflags CharNeOp       = Just (MO_Ne (wordWidth dflags))
+translateOp dflags CharGeOp       = Just (MO_U_Ge (wordWidth dflags))
+translateOp dflags CharLeOp       = Just (MO_U_Le (wordWidth dflags))
+translateOp dflags CharGtOp       = Just (MO_U_Gt (wordWidth dflags))
+translateOp dflags CharLtOp       = Just (MO_U_Lt (wordWidth dflags))
+
+-- Double ops
+
+translateOp _      DoubleEqOp     = Just (MO_F_Eq W64)
+translateOp _      DoubleNeOp     = Just (MO_F_Ne W64)
+translateOp _      DoubleGeOp     = Just (MO_F_Ge W64)
+translateOp _      DoubleLeOp     = Just (MO_F_Le W64)
+translateOp _      DoubleGtOp     = Just (MO_F_Gt W64)
+translateOp _      DoubleLtOp     = Just (MO_F_Lt W64)
+
+translateOp _      DoubleAddOp    = Just (MO_F_Add W64)
+translateOp _      DoubleSubOp    = Just (MO_F_Sub W64)
+translateOp _      DoubleMulOp    = Just (MO_F_Mul W64)
+translateOp _      DoubleDivOp    = Just (MO_F_Quot W64)
+translateOp _      DoubleNegOp    = Just (MO_F_Neg W64)
+
+-- Float ops
+
+translateOp _      FloatEqOp     = Just (MO_F_Eq W32)
+translateOp _      FloatNeOp     = Just (MO_F_Ne W32)
+translateOp _      FloatGeOp     = Just (MO_F_Ge W32)
+translateOp _      FloatLeOp     = Just (MO_F_Le W32)
+translateOp _      FloatGtOp     = Just (MO_F_Gt W32)
+translateOp _      FloatLtOp     = Just (MO_F_Lt W32)
+
+translateOp _      FloatAddOp    = Just (MO_F_Add  W32)
+translateOp _      FloatSubOp    = Just (MO_F_Sub  W32)
+translateOp _      FloatMulOp    = Just (MO_F_Mul  W32)
+translateOp _      FloatDivOp    = Just (MO_F_Quot W32)
+translateOp _      FloatNegOp    = Just (MO_F_Neg  W32)
+
+-- Vector ops
+
+translateOp _ (VecAddOp FloatVec n w) = Just (MO_VF_Add  n w)
+translateOp _ (VecSubOp FloatVec n w) = Just (MO_VF_Sub  n w)
+translateOp _ (VecMulOp FloatVec n w) = Just (MO_VF_Mul  n w)
+translateOp _ (VecDivOp FloatVec n w) = Just (MO_VF_Quot n w)
+translateOp _ (VecNegOp FloatVec n w) = Just (MO_VF_Neg  n w)
+
+translateOp _ (VecAddOp  IntVec n w) = Just (MO_V_Add   n w)
+translateOp _ (VecSubOp  IntVec n w) = Just (MO_V_Sub   n w)
+translateOp _ (VecMulOp  IntVec n w) = Just (MO_V_Mul   n w)
+translateOp _ (VecQuotOp IntVec n w) = Just (MO_VS_Quot n w)
+translateOp _ (VecRemOp  IntVec n w) = Just (MO_VS_Rem  n w)
+translateOp _ (VecNegOp  IntVec n w) = Just (MO_VS_Neg  n w)
+
+translateOp _ (VecAddOp  WordVec n w) = Just (MO_V_Add   n w)
+translateOp _ (VecSubOp  WordVec n w) = Just (MO_V_Sub   n w)
+translateOp _ (VecMulOp  WordVec n w) = Just (MO_V_Mul   n w)
+translateOp _ (VecQuotOp WordVec n w) = Just (MO_VU_Quot n w)
+translateOp _ (VecRemOp  WordVec n w) = Just (MO_VU_Rem  n w)
+
+-- Conversions
+
+translateOp dflags Int2DoubleOp   = Just (MO_SF_Conv (wordWidth dflags) W64)
+translateOp dflags Double2IntOp   = Just (MO_FS_Conv W64 (wordWidth dflags))
+
+translateOp dflags Int2FloatOp    = Just (MO_SF_Conv (wordWidth dflags) W32)
+translateOp dflags Float2IntOp    = Just (MO_FS_Conv W32 (wordWidth dflags))
+
+translateOp _      Float2DoubleOp = Just (MO_FF_Conv W32 W64)
+translateOp _      Double2FloatOp = Just (MO_FF_Conv W64 W32)
+
+-- Word comparisons masquerading as more exotic things.
+
+translateOp dflags SameMutVarOp           = Just (mo_wordEq dflags)
+translateOp dflags SameMVarOp             = Just (mo_wordEq dflags)
+translateOp dflags SameMutableArrayOp     = Just (mo_wordEq dflags)
+translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags)
+translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags)
+translateOp dflags SameSmallMutableArrayOp= Just (mo_wordEq dflags)
+translateOp dflags SameTVarOp             = Just (mo_wordEq dflags)
+translateOp dflags EqStablePtrOp          = Just (mo_wordEq dflags)
+-- See Note [Comparing stable names]
+translateOp dflags EqStableNameOp         = Just (mo_wordEq dflags)
+
+translateOp _      _ = Nothing
+
+-- Note [Comparing stable names]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- A StableName# is actually a pointer to a stable name object (SNO)
+-- containing an index into the stable name table (SNT). We
+-- used to compare StableName#s by following the pointers to the
+-- SNOs and checking whether they held the same SNT indices. However,
+-- this is not necessary: there is a one-to-one correspondence
+-- between SNOs and entries in the SNT, so simple pointer equality
+-- does the trick.
+
+-- These primops are implemented by CallishMachOps, because they sometimes
+-- turn into foreign calls depending on the backend.
+
+callishOp :: PrimOp -> Maybe CallishMachOp
+callishOp DoublePowerOp  = Just MO_F64_Pwr
+callishOp DoubleSinOp    = Just MO_F64_Sin
+callishOp DoubleCosOp    = Just MO_F64_Cos
+callishOp DoubleTanOp    = Just MO_F64_Tan
+callishOp DoubleSinhOp   = Just MO_F64_Sinh
+callishOp DoubleCoshOp   = Just MO_F64_Cosh
+callishOp DoubleTanhOp   = Just MO_F64_Tanh
+callishOp DoubleAsinOp   = Just MO_F64_Asin
+callishOp DoubleAcosOp   = Just MO_F64_Acos
+callishOp DoubleAtanOp   = Just MO_F64_Atan
+callishOp DoubleAsinhOp  = Just MO_F64_Asinh
+callishOp DoubleAcoshOp  = Just MO_F64_Acosh
+callishOp DoubleAtanhOp  = Just MO_F64_Atanh
+callishOp DoubleLogOp    = Just MO_F64_Log
+callishOp DoubleExpOp    = Just MO_F64_Exp
+callishOp DoubleSqrtOp   = Just MO_F64_Sqrt
+
+callishOp FloatPowerOp  = Just MO_F32_Pwr
+callishOp FloatSinOp    = Just MO_F32_Sin
+callishOp FloatCosOp    = Just MO_F32_Cos
+callishOp FloatTanOp    = Just MO_F32_Tan
+callishOp FloatSinhOp   = Just MO_F32_Sinh
+callishOp FloatCoshOp   = Just MO_F32_Cosh
+callishOp FloatTanhOp   = Just MO_F32_Tanh
+callishOp FloatAsinOp   = Just MO_F32_Asin
+callishOp FloatAcosOp   = Just MO_F32_Acos
+callishOp FloatAtanOp   = Just MO_F32_Atan
+callishOp FloatAsinhOp  = Just MO_F32_Asinh
+callishOp FloatAcoshOp  = Just MO_F32_Acosh
+callishOp FloatAtanhOp  = Just MO_F32_Atanh
+callishOp FloatLogOp    = Just MO_F32_Log
+callishOp FloatExpOp    = Just MO_F32_Exp
+callishOp FloatSqrtOp   = Just MO_F32_Sqrt
+
+callishOp _ = Nothing
+
+------------------------------------------------------------------------------
+-- Helpers for translating various minor variants of array indexing.
+
+doIndexOffAddrOp :: Maybe MachOp
+                 -> CmmType
+                 -> [LocalReg]
+                 -> [CmmExpr]
+                 -> FCode ()
+doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx
+doIndexOffAddrOp _ _ _ _
+   = panic "StgCmmPrim: doIndexOffAddrOp"
+
+doIndexOffAddrOpAs :: Maybe MachOp
+                   -> CmmType
+                   -> CmmType
+                   -> [LocalReg]
+                   -> [CmmExpr]
+                   -> FCode ()
+doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]
+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx
+doIndexOffAddrOpAs _ _ _ _ _
+   = panic "StgCmmPrim: doIndexOffAddrOpAs"
+
+doIndexByteArrayOp :: Maybe MachOp
+                   -> CmmType
+                   -> [LocalReg]
+                   -> [CmmExpr]
+                   -> FCode ()
+doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
+   = do dflags <- getDynFlags
+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx
+doIndexByteArrayOp _ _ _ _
+   = panic "StgCmmPrim: doIndexByteArrayOp"
+
+doIndexByteArrayOpAs :: Maybe MachOp
+                    -> CmmType
+                    -> CmmType
+                    -> [LocalReg]
+                    -> [CmmExpr]
+                    -> FCode ()
+doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]
+   = do dflags <- getDynFlags
+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx
+doIndexByteArrayOpAs _ _ _ _ _
+   = panic "StgCmmPrim: doIndexByteArrayOpAs"
+
+doReadPtrArrayOp :: LocalReg
+                 -> CmmExpr
+                 -> CmmExpr
+                 -> FCode ()
+doReadPtrArrayOp res addr idx
+   = do dflags <- getDynFlags
+        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx
+
+doWriteOffAddrOp :: Maybe MachOp
+                 -> CmmType
+                 -> [LocalReg]
+                 -> [CmmExpr]
+                 -> FCode ()
+doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]
+   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val
+doWriteOffAddrOp _ _ _ _
+   = panic "StgCmmPrim: doWriteOffAddrOp"
+
+doWriteByteArrayOp :: Maybe MachOp
+                   -> CmmType
+                   -> [LocalReg]
+                   -> [CmmExpr]
+                   -> FCode ()
+doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]
+   = do dflags <- getDynFlags
+        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val
+doWriteByteArrayOp _ _ _ _
+   = panic "StgCmmPrim: doWriteByteArrayOp"
+
+doWritePtrArrayOp :: CmmExpr
+                  -> CmmExpr
+                  -> CmmExpr
+                  -> FCode ()
+doWritePtrArrayOp addr idx val
+  = do dflags <- getDynFlags
+       let ty = cmmExprType dflags val
+       -- This write barrier is to ensure that the heap writes to the object
+       -- referred to by val have happened before we write val into the array.
+       -- See #12469 for details.
+       emitPrimCall [] MO_WriteBarrier []
+       mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr ty idx val
+       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
+  -- the write barrier.  We must write a byte into the mark table:
+  -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
+       emit $ mkStore (
+         cmmOffsetExpr dflags
+          (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags))
+                         (loadArrPtrsSize dflags addr))
+          (CmmMachOp (mo_wordUShr dflags) [idx,
+                                           mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)])
+         ) (CmmLit (CmmInt 1 W8))
+
+loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr
+loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)
+ where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags
+
+mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes
+                   -> Maybe MachOp -- Optional result cast
+                   -> CmmType      -- Type of element we are accessing
+                   -> LocalReg     -- Destination
+                   -> CmmExpr      -- Base address
+                   -> CmmType      -- Type of element by which we are indexing
+                   -> CmmExpr      -- Index
+                   -> FCode ()
+mkBasicIndexedRead off Nothing ty res base idx_ty idx
+   = do dflags <- getDynFlags
+        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty base idx_ty idx)
+mkBasicIndexedRead off (Just cast) ty res base idx_ty idx
+   = do dflags <- getDynFlags
+        emitAssign (CmmLocal res) (CmmMachOp cast [
+                                   cmmLoadIndexOffExpr dflags off ty base idx_ty idx])
+
+mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes
+                    -> Maybe MachOp -- Optional value cast
+                    -> CmmExpr      -- Base address
+                    -> CmmType      -- Type of element by which we are indexing
+                    -> CmmExpr      -- Index
+                    -> CmmExpr      -- Value to write
+                    -> FCode ()
+mkBasicIndexedWrite off Nothing base idx_ty idx val
+   = do dflags <- getDynFlags
+        emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val
+mkBasicIndexedWrite off (Just cast) base idx_ty idx val
+   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])
+
+-- ----------------------------------------------------------------------------
+-- Misc utils
+
+cmmIndexOffExpr :: DynFlags
+                -> ByteOff  -- Initial offset in bytes
+                -> Width    -- Width of element by which we are indexing
+                -> CmmExpr  -- Base address
+                -> CmmExpr  -- Index
+                -> CmmExpr
+cmmIndexOffExpr dflags off width base idx
+   = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx
+
+cmmLoadIndexOffExpr :: DynFlags
+                    -> ByteOff  -- Initial offset in bytes
+                    -> CmmType  -- Type of element we are accessing
+                    -> CmmExpr  -- Base address
+                    -> CmmType  -- Type of element by which we are indexing
+                    -> CmmExpr  -- Index
+                    -> CmmExpr
+cmmLoadIndexOffExpr dflags off ty base idx_ty idx
+   = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty
+
+setInfo :: CmmExpr -> CmmExpr -> CmmAGraph
+setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr
+
+------------------------------------------------------------------------------
+-- Helpers for translating vector primops.
+
+vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType
+vecVmmType pocat n w = vec n (vecCmmCat pocat w)
+
+vecCmmCat :: PrimOpVecCat -> Width -> CmmType
+vecCmmCat IntVec   = cmmBits
+vecCmmCat WordVec  = cmmBits
+vecCmmCat FloatVec = cmmFloat
+
+vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp
+vecElemInjectCast _      FloatVec _   =  Nothing
+vecElemInjectCast dflags IntVec   W8  =  Just (mo_WordTo8  dflags)
+vecElemInjectCast dflags IntVec   W16 =  Just (mo_WordTo16 dflags)
+vecElemInjectCast dflags IntVec   W32 =  Just (mo_WordTo32 dflags)
+vecElemInjectCast _      IntVec   W64 =  Nothing
+vecElemInjectCast dflags WordVec  W8  =  Just (mo_WordTo8  dflags)
+vecElemInjectCast dflags WordVec  W16 =  Just (mo_WordTo16 dflags)
+vecElemInjectCast dflags WordVec  W32 =  Just (mo_WordTo32 dflags)
+vecElemInjectCast _      WordVec  W64 =  Nothing
+vecElemInjectCast _      _        _   =  Nothing
+
+vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp
+vecElemProjectCast _      FloatVec _   =  Nothing
+vecElemProjectCast dflags IntVec   W8  =  Just (mo_s_8ToWord  dflags)
+vecElemProjectCast dflags IntVec   W16 =  Just (mo_s_16ToWord dflags)
+vecElemProjectCast dflags IntVec   W32 =  Just (mo_s_32ToWord dflags)
+vecElemProjectCast _      IntVec   W64 =  Nothing
+vecElemProjectCast dflags WordVec  W8  =  Just (mo_u_8ToWord  dflags)
+vecElemProjectCast dflags WordVec  W16 =  Just (mo_u_16ToWord dflags)
+vecElemProjectCast dflags WordVec  W32 =  Just (mo_u_32ToWord dflags)
+vecElemProjectCast _      WordVec  W64 =  Nothing
+vecElemProjectCast _      _        _   =  Nothing
+
+-- Check to make sure that we can generate code for the specified vector type
+-- given the current set of dynamic flags.
+checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode ()
+checkVecCompatibility dflags vcat l w = do
+    when (hscTarget dflags /= HscLlvm) $ do
+        sorry $ unlines ["SIMD vector instructions require the LLVM back-end."
+                         ,"Please use -fllvm."]
+    check vecWidth vcat l w
+  where
+    check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()
+    check W128 FloatVec 4 W32 | not (isSseEnabled dflags) =
+        sorry $ "128-bit wide single-precision floating point " ++
+                "SIMD vector instructions require at least -msse."
+    check W128 _ _ _ | not (isSse2Enabled dflags) =
+        sorry $ "128-bit wide integer and double precision " ++
+                "SIMD vector instructions require at least -msse2."
+    check W256 FloatVec _ _ | not (isAvxEnabled dflags) =
+        sorry $ "256-bit wide floating point " ++
+                "SIMD vector instructions require at least -mavx."
+    check W256 _ _ _ | not (isAvx2Enabled dflags) =
+        sorry $ "256-bit wide integer " ++
+                "SIMD vector instructions require at least -mavx2."
+    check W512 _ _ _ | not (isAvx512fEnabled dflags) =
+        sorry $ "512-bit wide " ++
+                "SIMD vector instructions require -mavx512f."
+    check _ _ _ _ = return ()
+
+    vecWidth = typeWidth (vecVmmType vcat l w)
+
+------------------------------------------------------------------------------
+-- Helpers for translating vector packing and unpacking.
+
+doVecPackOp :: Maybe MachOp  -- Cast from element to vector component
+            -> CmmType       -- Type of vector
+            -> CmmExpr       -- Initial vector
+            -> [CmmExpr]     -- Elements
+            -> CmmFormal     -- Destination for result
+            -> FCode ()
+doVecPackOp maybe_pre_write_cast ty z es res = do
+    dst <- newTemp ty
+    emitAssign (CmmLocal dst) z
+    vecPack dst es 0
+  where
+    vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode ()
+    vecPack src [] _ =
+        emitAssign (CmmLocal res) (CmmReg (CmmLocal src))
+
+    vecPack src (e : es) i = do
+        dst <- newTemp ty
+        if isFloatType (vecElemType ty)
+          then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)
+                                                    [CmmReg (CmmLocal src), cast e, iLit])
+          else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)
+                                                    [CmmReg (CmmLocal src), cast e, iLit])
+        vecPack dst es (i + 1)
+      where
+        -- vector indices are always 32-bits
+        iLit = CmmLit (CmmInt (toInteger i) W32)
+
+    cast :: CmmExpr -> CmmExpr
+    cast val = case maybe_pre_write_cast of
+                 Nothing   -> val
+                 Just cast -> CmmMachOp cast [val]
+
+    len :: Length
+    len = vecLength ty
+
+    wid :: Width
+    wid = typeWidth (vecElemType ty)
+
+doVecUnpackOp :: Maybe MachOp  -- Cast from vector component to element result
+              -> CmmType       -- Type of vector
+              -> CmmExpr       -- Vector
+              -> [CmmFormal]   -- Element results
+              -> FCode ()
+doVecUnpackOp maybe_post_read_cast ty e res =
+    vecUnpack res 0
+  where
+    vecUnpack :: [CmmFormal] -> Int -> FCode ()
+    vecUnpack [] _ =
+        return ()
+
+    vecUnpack (r : rs) i = do
+        if isFloatType (vecElemType ty)
+          then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid)
+                                             [e, iLit]))
+          else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid)
+                                             [e, iLit]))
+        vecUnpack rs (i + 1)
+      where
+        -- vector indices are always 32-bits
+        iLit = CmmLit (CmmInt (toInteger i) W32)
+
+    cast :: CmmExpr -> CmmExpr
+    cast val = case maybe_post_read_cast of
+                 Nothing   -> val
+                 Just cast -> CmmMachOp cast [val]
+
+    len :: Length
+    len = vecLength ty
+
+    wid :: Width
+    wid = typeWidth (vecElemType ty)
+
+doVecInsertOp :: Maybe MachOp  -- Cast from element to vector component
+              -> CmmType       -- Vector type
+              -> CmmExpr       -- Source vector
+              -> CmmExpr       -- Element
+              -> CmmExpr       -- Index at which to insert element
+              -> CmmFormal     -- Destination for result
+              -> FCode ()
+doVecInsertOp maybe_pre_write_cast ty src e idx res = do
+    dflags <- getDynFlags
+    -- vector indices are always 32-bits
+    let idx' :: CmmExpr
+        idx' = CmmMachOp (MO_SS_Conv (wordWidth dflags) W32) [idx]
+    if isFloatType (vecElemType ty)
+      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx'])
+      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx'])
+  where
+    cast :: CmmExpr -> CmmExpr
+    cast val = case maybe_pre_write_cast of
+                 Nothing   -> val
+                 Just cast -> CmmMachOp cast [val]
+
+    len :: Length
+    len = vecLength ty
+
+    wid :: Width
+    wid = typeWidth (vecElemType ty)
+
+------------------------------------------------------------------------------
+-- Helpers for translating prefetching.
+
+
+-- | Translate byte array prefetch operations into proper primcalls.
+doPrefetchByteArrayOp :: Int
+                      -> [CmmExpr]
+                      -> FCode ()
+doPrefetchByteArrayOp locality  [addr,idx]
+   = do dflags <- getDynFlags
+        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx
+doPrefetchByteArrayOp _ _
+   = panic "StgCmmPrim: doPrefetchByteArrayOp"
+
+-- | Translate mutable byte array prefetch operations into proper primcalls.
+doPrefetchMutableByteArrayOp :: Int
+                      -> [CmmExpr]
+                      -> FCode ()
+doPrefetchMutableByteArrayOp locality  [addr,idx]
+   = do dflags <- getDynFlags
+        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx
+doPrefetchMutableByteArrayOp _ _
+   = panic "StgCmmPrim: doPrefetchByteArrayOp"
+
+-- | Translate address prefetch operations into proper primcalls.
+doPrefetchAddrOp ::Int
+                 -> [CmmExpr]
+                 -> FCode ()
+doPrefetchAddrOp locality   [addr,idx]
+   = mkBasicPrefetch locality 0  addr idx
+doPrefetchAddrOp _ _
+   = panic "StgCmmPrim: doPrefetchAddrOp"
+
+-- | Translate value prefetch operations into proper primcalls.
+doPrefetchValueOp :: Int
+                 -> [CmmExpr]
+                 -> FCode ()
+doPrefetchValueOp  locality   [addr]
+  =  do dflags <- getDynFlags
+        mkBasicPrefetch locality 0 addr  (CmmLit (CmmInt 0 (wordWidth dflags)))
+doPrefetchValueOp _ _
+  = panic "StgCmmPrim: doPrefetchValueOp"
+
+-- | helper to generate prefetch primcalls
+mkBasicPrefetch :: Int          -- Locality level 0-3
+                -> ByteOff      -- Initial offset in bytes
+                -> CmmExpr      -- Base address
+                -> CmmExpr      -- Index
+                -> FCode ()
+mkBasicPrefetch locality off base idx
+   = do dflags <- getDynFlags
+        emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr dflags W8 (cmmOffsetB dflags base off) idx]
+        return ()
+
+-- ----------------------------------------------------------------------------
+-- Allocating byte arrays
+
+-- | Takes a register to return the newly allocated array in and the
+-- size of the new array in bytes. Allocates a new
+-- 'MutableByteArray#'.
+doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode ()
+doNewByteArrayOp res_r n = do
+    dflags <- getDynFlags
+
+    let info_ptr = mkLblExpr mkArrWords_infoLabel
+        rep = arrWordsRep dflags n
+
+    tickyAllocPrim (mkIntExpr dflags (arrWordsHdrSize dflags))
+        (mkIntExpr dflags (nonHdrSize dflags rep))
+        (zeroExpr dflags)
+
+    let hdr_size = fixedHdrSize dflags
+
+    base <- allocHeapClosure rep info_ptr cccsExpr
+                     [ (mkIntExpr dflags n,
+                        hdr_size + oFFSET_StgArrBytes_bytes dflags)
+                     ]
+
+    emit $ mkAssign (CmmLocal res_r) base
+
+-- ----------------------------------------------------------------------------
+-- Comparing byte arrays
+
+doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                     -> FCode ()
+doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do
+    dflags <- getDynFlags
+    ba1_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba1 (arrWordsHdrSize dflags)) ba1_off
+    ba2_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba2 (arrWordsHdrSize dflags)) ba2_off
+
+    -- short-cut in case of equal pointers avoiding a costly
+    -- subroutine call to the memcmp(3) routine; the Cmm logic below
+    -- results in assembly code being generated for
+    --
+    --   cmpPrefix10 :: ByteArray# -> ByteArray# -> Int#
+    --   cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10#
+    --
+    -- that looks like
+    --
+    --          leaq 16(%r14),%rax
+    --          leaq 16(%rsi),%rbx
+    --          xorl %ecx,%ecx
+    --          cmpq %rbx,%rax
+    --          je l_ptr_eq
+    --
+    --          ; NB: the common case (unequal pointers) falls-through
+    --          ; the conditional jump, and therefore matches the
+    --          ; usual static branch prediction convention of modern cpus
+    --
+    --          subq $8,%rsp
+    --          movq %rbx,%rsi
+    --          movq %rax,%rdi
+    --          movl $10,%edx
+    --          xorl %eax,%eax
+    --          call memcmp
+    --          addq $8,%rsp
+    --          movslq %eax,%rax
+    --          movq %rax,%rcx
+    --  l_ptr_eq:
+    --          movq %rcx,%rbx
+    --          jmp *(%rbp)
+
+    l_ptr_eq <- newBlockId
+    l_ptr_ne <- newBlockId
+
+    emit (mkAssign (CmmLocal res) (zeroExpr dflags))
+    emit (mkCbranch (cmmEqWord dflags ba1_p ba2_p)
+                    l_ptr_eq l_ptr_ne (Just False))
+
+    emitLabel l_ptr_ne
+    emitMemcmpCall res ba1_p ba2_p n 1
+
+    emitLabel l_ptr_eq
+
+-- ----------------------------------------------------------------------------
+-- Copying byte arrays
+
+-- | Takes a source 'ByteArray#', an offset in the source array, a
+-- destination 'MutableByteArray#', an offset into the destination
+-- array, and the number of bytes to copy.  Copies the given number of
+-- bytes from the source array to the destination array.
+doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                  -> FCode ()
+doCopyByteArrayOp = emitCopyByteArray copy
+  where
+    -- Copy data (we assume the arrays aren't overlapping since
+    -- they're of different types)
+    copy _src _dst dst_p src_p bytes =
+        emitMemcpyCall dst_p src_p bytes 1
+
+-- | Takes a source 'MutableByteArray#', an offset in the source
+-- array, a destination 'MutableByteArray#', an offset into the
+-- destination array, and the number of bytes to copy.  Copies the
+-- given number of bytes from the source array to the destination
+-- array.
+doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                         -> FCode ()
+doCopyMutableByteArrayOp = emitCopyByteArray copy
+  where
+    -- The only time the memory might overlap is when the two arrays
+    -- we were provided are the same array!
+    -- TODO: Optimize branch for common case of no aliasing.
+    copy src dst dst_p src_p bytes = do
+        dflags <- getDynFlags
+        (moveCall, cpyCall) <- forkAltPair
+            (getCode $ emitMemmoveCall dst_p src_p bytes 1)
+            (getCode $ emitMemcpyCall  dst_p src_p bytes 1)
+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
+
+emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                      -> FCode ())
+                  -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                  -> FCode ()
+emitCopyByteArray copy src src_off dst dst_off n = do
+    dflags <- getDynFlags
+    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off
+    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off
+    copy src dst dst_p src_p n
+
+-- | Takes a source 'ByteArray#', an offset in the source array, a
+-- destination 'Addr#', and the number of bytes to copy.  Copies the given
+-- number of bytes from the source array to the destination memory region.
+doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
+doCopyByteArrayToAddrOp src src_off dst_p bytes = do
+    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)
+    dflags <- getDynFlags
+    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off
+    emitMemcpyCall dst_p src_p bytes 1
+
+-- | Takes a source 'MutableByteArray#', an offset in the source array, a
+-- destination 'Addr#', and the number of bytes to copy.  Copies the given
+-- number of bytes from the source array to the destination memory region.
+doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                               -> FCode ()
+doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp
+
+-- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into
+-- the destination array, and the number of bytes to copy.  Copies the given
+-- number of bytes from the source memory region to the destination array.
+doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
+doCopyAddrToByteArrayOp src_p dst dst_off bytes = do
+    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)
+    dflags <- getDynFlags
+    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off
+    emitMemcpyCall dst_p src_p bytes 1
+
+
+-- ----------------------------------------------------------------------------
+-- Setting byte arrays
+
+-- | Takes a 'MutableByteArray#', an offset into the array, a length,
+-- and a byte, and sets each of the selected bytes in the array to the
+-- character.
+doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
+                 -> FCode ()
+doSetByteArrayOp ba off len c
+    = do dflags <- getDynFlags
+         p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off
+         emitMemsetCall p c len 1
+
+-- ----------------------------------------------------------------------------
+-- Allocating arrays
+
+-- | Allocate a new array.
+doNewArrayOp :: CmmFormal             -- ^ return register
+             -> SMRep                 -- ^ representation of the array
+             -> CLabel                -- ^ info pointer
+             -> [(CmmExpr, ByteOff)]  -- ^ header payload
+             -> WordOff               -- ^ array size
+             -> CmmExpr               -- ^ initial element
+             -> FCode ()
+doNewArrayOp res_r rep info payload n init = do
+    dflags <- getDynFlags
+
+    let info_ptr = mkLblExpr info
+
+    tickyAllocPrim (mkIntExpr dflags (hdrSize dflags rep))
+        (mkIntExpr dflags (nonHdrSize dflags rep))
+        (zeroExpr dflags)
+
+    base <- allocHeapClosure rep info_ptr cccsExpr payload
+
+    arr <- CmmLocal `fmap` newTemp (bWord dflags)
+    emit $ mkAssign arr base
+
+    -- Initialise all elements of the array
+    p <- assignTemp $ cmmOffsetB dflags (CmmReg arr) (hdrSize dflags rep)
+    for <- newBlockId
+    emitLabel for
+    let loopBody =
+            [ mkStore (CmmReg (CmmLocal p)) init
+            , mkAssign (CmmLocal p) (cmmOffsetW dflags (CmmReg (CmmLocal p)) 1)
+            , mkBranch for ]
+    emit =<< mkCmmIfThen
+        (cmmULtWord dflags (CmmReg (CmmLocal p))
+         (cmmOffsetW dflags (CmmReg arr)
+          (hdrSizeW dflags rep + n)))
+        (catAGraphs loopBody)
+
+    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
+
+-- ----------------------------------------------------------------------------
+-- Copying pointer arrays
+
+-- EZY: This code has an unusually high amount of assignTemp calls, seen
+-- nowhere else in the code generator.  This is mostly because these
+-- "primitive" ops result in a surprisingly large amount of code.  It
+-- will likely be worthwhile to optimize what is emitted here, so that
+-- our optimization passes don't waste time repeatedly optimizing the
+-- same bits of code.
+
+-- More closely imitates 'assignTemp' from the old code generator, which
+-- returns a CmmExpr rather than a LocalReg.
+assignTempE :: CmmExpr -> FCode CmmExpr
+assignTempE e = do
+    t <- assignTemp e
+    return (CmmReg (CmmLocal t))
+
+-- | Takes a source 'Array#', an offset in the source array, a
+-- destination 'MutableArray#', an offset into the destination array,
+-- and the number of elements to copy.  Copies the given number of
+-- elements from the source array to the destination array.
+doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff
+              -> FCode ()
+doCopyArrayOp = emitCopyArray copy
+  where
+    -- Copy data (we assume the arrays aren't overlapping since
+    -- they're of different types)
+    copy _src _dst dst_p src_p bytes =
+        do dflags <- getDynFlags
+           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
+               (wORD_SIZE dflags)
+
+
+-- | Takes a source 'MutableArray#', an offset in the source array, a
+-- destination 'MutableArray#', an offset into the destination array,
+-- and the number of elements to copy.  Copies the given number of
+-- elements from the source array to the destination array.
+doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff
+                     -> FCode ()
+doCopyMutableArrayOp = emitCopyArray copy
+  where
+    -- The only time the memory might overlap is when the two arrays
+    -- we were provided are the same array!
+    -- TODO: Optimize branch for common case of no aliasing.
+    copy src dst dst_p src_p bytes = do
+        dflags <- getDynFlags
+        (moveCall, cpyCall) <- forkAltPair
+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
+             (wORD_SIZE dflags))
+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)
+             (wORD_SIZE dflags))
+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
+
+emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
+                  -> FCode ())  -- ^ copy function
+              -> CmmExpr        -- ^ source array
+              -> CmmExpr        -- ^ offset in source array
+              -> CmmExpr        -- ^ destination array
+              -> CmmExpr        -- ^ offset in destination array
+              -> WordOff        -- ^ number of elements to copy
+              -> FCode ()
+emitCopyArray copy src0 src_off dst0 dst_off0 n = do
+    dflags <- getDynFlags
+    when (n /= 0) $ do
+        -- Passed as arguments (be careful)
+        src     <- assignTempE src0
+        dst     <- assignTempE dst0
+        dst_off <- assignTempE dst_off0
+
+        -- Set the dirty bit in the header.
+        emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
+
+        dst_elems_p <- assignTempE $ cmmOffsetB dflags dst
+                       (arrPtrsHdrSize dflags)
+        dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off
+        src_p <- assignTempE $ cmmOffsetExprW dflags
+                 (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off
+        let bytes = wordsToBytes dflags n
+
+        copy src dst dst_p src_p bytes
+
+        -- The base address of the destination card table
+        dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p
+                       (loadArrPtrsSize dflags dst)
+
+        emitSetCards dst_off dst_cards_p n
+
+doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff
+                   -> FCode ()
+doCopySmallArrayOp = emitCopySmallArray copy
+  where
+    -- Copy data (we assume the arrays aren't overlapping since
+    -- they're of different types)
+    copy _src _dst dst_p src_p bytes =
+        do dflags <- getDynFlags
+           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)
+               (wORD_SIZE dflags)
+
+
+doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff
+                          -> FCode ()
+doCopySmallMutableArrayOp = emitCopySmallArray copy
+  where
+    -- The only time the memory might overlap is when the two arrays
+    -- we were provided are the same array!
+    -- TODO: Optimize branch for common case of no aliasing.
+    copy src dst dst_p src_p bytes = do
+        dflags <- getDynFlags
+        (moveCall, cpyCall) <- forkAltPair
+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)
+             (wORD_SIZE dflags))
+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)
+             (wORD_SIZE dflags))
+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall
+
+emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff
+                       -> FCode ())  -- ^ copy function
+                   -> CmmExpr        -- ^ source array
+                   -> CmmExpr        -- ^ offset in source array
+                   -> CmmExpr        -- ^ destination array
+                   -> CmmExpr        -- ^ offset in destination array
+                   -> WordOff        -- ^ number of elements to copy
+                   -> FCode ()
+emitCopySmallArray copy src0 src_off dst0 dst_off n = do
+    dflags <- getDynFlags
+
+    -- Passed as arguments (be careful)
+    src     <- assignTempE src0
+    dst     <- assignTempE dst0
+
+    -- Set the dirty bit in the header.
+    emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))
+
+    dst_p <- assignTempE $ cmmOffsetExprW dflags
+             (cmmOffsetB dflags dst (smallArrPtrsHdrSize dflags)) dst_off
+    src_p <- assignTempE $ cmmOffsetExprW dflags
+             (cmmOffsetB dflags src (smallArrPtrsHdrSize dflags)) src_off
+    let bytes = wordsToBytes dflags n
+
+    copy src dst dst_p src_p bytes
+
+-- | Takes an info table label, a register to return the newly
+-- allocated array in, a source array, an offset in the source array,
+-- and the number of elements to copy. Allocates a new array and
+-- initializes it from the source array.
+emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff
+               -> FCode ()
+emitCloneArray info_p res_r src src_off n = do
+    dflags <- getDynFlags
+
+    let info_ptr = mkLblExpr info_p
+        rep = arrPtrsRep dflags n
+
+    tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags))
+        (mkIntExpr dflags (nonHdrSize dflags rep))
+        (zeroExpr dflags)
+
+    let hdr_size = fixedHdrSize dflags
+
+    base <- allocHeapClosure rep info_ptr cccsExpr
+                     [ (mkIntExpr dflags n,
+                        hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)
+                     , (mkIntExpr dflags (nonHdrSizeW rep),
+                        hdr_size + oFFSET_StgMutArrPtrs_size dflags)
+                     ]
+
+    arr <- CmmLocal `fmap` newTemp (bWord dflags)
+    emit $ mkAssign arr base
+
+    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)
+             (arrPtrsHdrSize dflags)
+    src_p <- assignTempE $ cmmOffsetExprW dflags src
+             (cmmAddWord dflags
+              (mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off)
+
+    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))
+        (wORD_SIZE dflags)
+
+    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
+
+-- | Takes an info table label, a register to return the newly
+-- allocated array in, a source array, an offset in the source array,
+-- and the number of elements to copy. Allocates a new array and
+-- initializes it from the source array.
+emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff
+                    -> FCode ()
+emitCloneSmallArray info_p res_r src src_off n = do
+    dflags <- getDynFlags
+
+    let info_ptr = mkLblExpr info_p
+        rep = smallArrPtrsRep n
+
+    tickyAllocPrim (mkIntExpr dflags (smallArrPtrsHdrSize dflags))
+        (mkIntExpr dflags (nonHdrSize dflags rep))
+        (zeroExpr dflags)
+
+    let hdr_size = fixedHdrSize dflags
+
+    base <- allocHeapClosure rep info_ptr cccsExpr
+                     [ (mkIntExpr dflags n,
+                        hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)
+                     ]
+
+    arr <- CmmLocal `fmap` newTemp (bWord dflags)
+    emit $ mkAssign arr base
+
+    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)
+             (smallArrPtrsHdrSize dflags)
+    src_p <- assignTempE $ cmmOffsetExprW dflags src
+             (cmmAddWord dflags
+              (mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off)
+
+    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))
+        (wORD_SIZE dflags)
+
+    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
+
+-- | Takes and offset in the destination array, the base address of
+-- the card table, and the number of elements affected (*not* the
+-- number of cards). The number of elements may not be zero.
+-- Marks the relevant cards as dirty.
+emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode ()
+emitSetCards dst_start dst_cards_start n = do
+    dflags <- getDynFlags
+    start_card <- assignTempE $ cardCmm dflags dst_start
+    let end_card = cardCmm dflags
+                   (cmmSubWord dflags
+                    (cmmAddWord dflags dst_start (mkIntExpr dflags n))
+                    (mkIntExpr dflags 1))
+    emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)
+        (mkIntExpr dflags 1)
+        (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1))
+        1 -- no alignment (1 byte)
+
+-- Convert an element index to a card index
+cardCmm :: DynFlags -> CmmExpr -> CmmExpr
+cardCmm dflags i =
+    cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags))
+
+------------------------------------------------------------------------------
+-- SmallArray PrimOp implementations
+
+doReadSmallPtrArrayOp :: LocalReg
+                      -> CmmExpr
+                      -> CmmExpr
+                      -> FCode ()
+doReadSmallPtrArrayOp res addr idx = do
+    dflags <- getDynFlags
+    mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr
+        (gcWord dflags) idx
+
+doWriteSmallPtrArrayOp :: CmmExpr
+                       -> CmmExpr
+                       -> CmmExpr
+                       -> FCode ()
+doWriteSmallPtrArrayOp addr idx val = do
+    dflags <- getDynFlags
+    let ty = cmmExprType dflags val
+    emitPrimCall [] MO_WriteBarrier [] -- #12469
+    mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val
+    emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))
+
+------------------------------------------------------------------------------
+-- Atomic read-modify-write
+
+-- | Emit an atomic modification to a byte array element. The result
+-- reg contains that previous value of the element. Implies a full
+-- memory barrier.
+doAtomicRMW :: LocalReg      -- ^ Result reg
+            -> AtomicMachOp  -- ^ Atomic op (e.g. add)
+            -> CmmExpr       -- ^ MutableByteArray#
+            -> CmmExpr       -- ^ Index
+            -> CmmType       -- ^ Type of element by which we are indexing
+            -> CmmExpr       -- ^ Op argument (e.g. amount to add)
+            -> FCode ()
+doAtomicRMW res amop mba idx idx_ty n = do
+    dflags <- getDynFlags
+    let width = typeWidth idx_ty
+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)
+                width mba idx
+    emitPrimCall
+        [ res ]
+        (MO_AtomicRMW width amop)
+        [ addr, n ]
+
+-- | Emit an atomic read to a byte array that acts as a memory barrier.
+doAtomicReadByteArray
+    :: LocalReg  -- ^ Result reg
+    -> CmmExpr   -- ^ MutableByteArray#
+    -> CmmExpr   -- ^ Index
+    -> CmmType   -- ^ Type of element by which we are indexing
+    -> FCode ()
+doAtomicReadByteArray res mba idx idx_ty = do
+    dflags <- getDynFlags
+    let width = typeWidth idx_ty
+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)
+                width mba idx
+    emitPrimCall
+        [ res ]
+        (MO_AtomicRead width)
+        [ addr ]
+
+-- | Emit an atomic write to a byte array that acts as a memory barrier.
+doAtomicWriteByteArray
+    :: CmmExpr   -- ^ MutableByteArray#
+    -> CmmExpr   -- ^ Index
+    -> CmmType   -- ^ Type of element by which we are indexing
+    -> CmmExpr   -- ^ Value to write
+    -> FCode ()
+doAtomicWriteByteArray mba idx idx_ty val = do
+    dflags <- getDynFlags
+    let width = typeWidth idx_ty
+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)
+                width mba idx
+    emitPrimCall
+        [ {- no results -} ]
+        (MO_AtomicWrite width)
+        [ addr, val ]
+
+doCasByteArray
+    :: LocalReg  -- ^ Result reg
+    -> CmmExpr   -- ^ MutableByteArray#
+    -> CmmExpr   -- ^ Index
+    -> CmmType   -- ^ Type of element by which we are indexing
+    -> CmmExpr   -- ^ Old value
+    -> CmmExpr   -- ^ New value
+    -> FCode ()
+doCasByteArray res mba idx idx_ty old new = do
+    dflags <- getDynFlags
+    let width = (typeWidth idx_ty)
+        addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)
+               width mba idx
+    emitPrimCall
+        [ res ]
+        (MO_Cmpxchg width)
+        [ addr, old, new ]
+
+------------------------------------------------------------------------------
+-- Helpers for emitting function calls
+
+-- | Emit a call to @memcpy@.
+emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()
+emitMemcpyCall dst src n align = do
+    emitPrimCall
+        [ {-no results-} ]
+        (MO_Memcpy align)
+        [ dst, src, n ]
+
+-- | Emit a call to @memmove@.
+emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()
+emitMemmoveCall dst src n align = do
+    emitPrimCall
+        [ {- no results -} ]
+        (MO_Memmove align)
+        [ dst, src, n ]
+
+-- | Emit a call to @memset@.  The second argument must fit inside an
+-- unsigned char.
+emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()
+emitMemsetCall dst c n align = do
+    emitPrimCall
+        [ {- no results -} ]
+        (MO_Memset align)
+        [ dst, c, n ]
+
+emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()
+emitMemcmpCall res ptr1 ptr2 n align = do
+    -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all
+    -- code-gens currently call out to the @memcmp(3)@ C function.
+    -- This was easier than moving the sign-extensions into
+    -- all the code-gens.
+    dflags <- getDynFlags
+    let is32Bit = typeWidth (localRegType res) == W32
+
+    cres <- if is32Bit
+              then return res
+              else newTemp b32
+
+    emitPrimCall
+        [ cres ]
+        (MO_Memcmp align)
+        [ ptr1, ptr2, n ]
+
+    unless is32Bit $ do
+      emit $ mkAssign (CmmLocal res)
+                      (CmmMachOp
+                         (mo_s_32ToWord dflags)
+                         [(CmmReg (CmmLocal cres))])
+
+emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode ()
+emitBSwapCall res x width = do
+    emitPrimCall
+        [ res ]
+        (MO_BSwap width)
+        [ x ]
+
+emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode ()
+emitPopCntCall res x width = do
+    emitPrimCall
+        [ res ]
+        (MO_PopCnt width)
+        [ x ]
+
+emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()
+emitPdepCall res x y width = do
+    emitPrimCall
+        [ res ]
+        (MO_Pdep width)
+        [ x, y ]
+
+emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()
+emitPextCall res x y width = do
+    emitPrimCall
+        [ res ]
+        (MO_Pext width)
+        [ x, y ]
+
+emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode ()
+emitClzCall res x width = do
+    emitPrimCall
+        [ res ]
+        (MO_Clz width)
+        [ x ]
+
+emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode ()
+emitCtzCall res x width = do
+    emitPrimCall
+        [ res ]
+        (MO_Ctz width)
+        [ x ]
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -0,0 +1,360 @@
+-----------------------------------------------------------------------------
+--
+-- Code generation for profiling
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmProf (
+        initCostCentres, ccType, ccsType,
+        mkCCostCentre, mkCCostCentreStack,
+
+        -- Cost-centre Profiling
+        dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
+        enterCostCentreThunk, enterCostCentreFun,
+        costCentreFrom,
+        storeCurCCS,
+        emitSetCCC,
+
+        saveCurrentCostCentre, restoreCurrentCostCentre,
+
+        -- Lag/drag/void stuff
+        ldvEnter, ldvEnterClosure, ldvRecordCreate
+  ) where
+
+import GhcPrelude
+
+import StgCmmClosure
+import StgCmmUtils
+import StgCmmMonad
+import SMRep
+
+import MkGraph
+import Cmm
+import CmmUtils
+import CLabel
+
+import CostCentre
+import DynFlags
+import FastString
+import Module
+import Outputable
+
+import Control.Monad
+import Data.Char (ord)
+
+-----------------------------------------------------------------------------
+--
+-- Cost-centre-stack Profiling
+--
+-----------------------------------------------------------------------------
+
+-- Expression representing the current cost centre stack
+ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack
+ccsType = bWord
+
+ccType :: DynFlags -> CmmType -- Type of a cost centre
+ccType = bWord
+
+storeCurCCS :: CmmExpr -> CmmAGraph
+storeCurCCS e = mkAssign cccsReg e
+
+mkCCostCentre :: CostCentre -> CmmLit
+mkCCostCentre cc = CmmLabel (mkCCLabel cc)
+
+mkCCostCentreStack :: CostCentreStack -> CmmLit
+mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
+
+costCentreFrom :: DynFlags
+               -> CmmExpr         -- A closure pointer
+               -> CmmExpr        -- The cost centre from that closure
+costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags)
+
+-- | The profiling header words in a static closure
+staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
+staticProfHdr dflags ccs
+ = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]
+
+-- | Profiling header words in a dynamic closure
+dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
+dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]
+
+-- | Initialise the profiling field of an update frame
+initUpdFrameProf :: CmmExpr -> FCode ()
+initUpdFrameProf frame
+  = ifProfiling $        -- frame->header.prof.ccs = CCCS
+    do dflags <- getDynFlags
+       emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) cccsExpr
+        -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
+        -- is unnecessary because it is not used anyhow.
+
+---------------------------------------------------------------------------
+--         Saving and restoring the current cost centre
+---------------------------------------------------------------------------
+
+{-        Note [Saving the current cost centre]
+        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The current cost centre is like a global register.  Like other
+global registers, it's a caller-saves one.  But consider
+        case (f x) of (p,q) -> rhs
+Since 'f' may set the cost centre, we must restore it
+before resuming rhs.  So we want code like this:
+        local_cc = CCC  -- save
+        r = f( x )
+        CCC = local_cc  -- restore
+That is, we explicitly "save" the current cost centre in
+a LocalReg, local_cc; and restore it after the call. The
+C-- infrastructure will arrange to save local_cc across the
+call.
+
+The same goes for join points;
+        let j x = join-stuff
+        in blah-blah
+We want this kind of code:
+        local_cc = CCC  -- save
+        blah-blah
+     J:
+        CCC = local_cc  -- restore
+-}
+
+saveCurrentCostCentre :: FCode (Maybe LocalReg)
+        -- Returns Nothing if profiling is off
+saveCurrentCostCentre
+  = do dflags <- getDynFlags
+       if not (gopt Opt_SccProfilingOn dflags)
+           then return Nothing
+           else do local_cc <- newTemp (ccType dflags)
+                   emitAssign (CmmLocal local_cc) cccsExpr
+                   return (Just local_cc)
+
+restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
+restoreCurrentCostCentre Nothing
+  = return ()
+restoreCurrentCostCentre (Just local_cc)
+  = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))
+
+
+-------------------------------------------------------------------------------
+-- Recording allocation in a cost centre
+-------------------------------------------------------------------------------
+
+-- | Record the allocation of a closure.  The CmmExpr is the cost
+-- centre stack to which to attribute the allocation.
+profDynAlloc :: SMRep -> CmmExpr -> FCode ()
+profDynAlloc rep ccs
+  = ifProfiling $
+    do dflags <- getDynFlags
+       profAlloc (mkIntExpr dflags (heapClosureSizeW dflags rep)) ccs
+
+-- | Record the allocation of a closure (size is given by a CmmExpr)
+-- The size must be in words, because the allocation counter in a CCS counts
+-- in words.
+profAlloc :: CmmExpr -> CmmExpr -> FCode ()
+profAlloc words ccs
+  = ifProfiling $
+        do dflags <- getDynFlags
+           let alloc_rep = rEP_CostCentreStack_mem_alloc dflags
+           emit (addToMemE alloc_rep
+                       (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))
+                       (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $
+                         [CmmMachOp (mo_wordSub dflags) [words,
+                                                         mkIntExpr dflags (profHdrSize dflags)]]))
+                       -- subtract the "profiling overhead", which is the
+                       -- profiling header in a closure.
+
+-- -----------------------------------------------------------------------
+-- Setting the current cost centre on entry to a closure
+
+enterCostCentreThunk :: CmmExpr -> FCode ()
+enterCostCentreThunk closure =
+  ifProfiling $ do
+      dflags <- getDynFlags
+      emit $ storeCurCCS (costCentreFrom dflags closure)
+
+enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()
+enterCostCentreFun ccs closure =
+  ifProfiling $ do
+    if isCurrentCCS ccs
+       then do dflags <- getDynFlags
+               emitRtsCall rtsUnitId (fsLit "enterFunCCS")
+                   [(baseExpr, AddrHint),
+                    (costCentreFrom dflags closure, AddrHint)] False
+       else return () -- top-level function, nothing to do
+
+ifProfiling :: FCode () -> FCode ()
+ifProfiling code
+  = do dflags <- getDynFlags
+       if gopt Opt_SccProfilingOn dflags
+           then code
+           else return ()
+
+ifProfilingL :: DynFlags -> [a] -> [a]
+ifProfilingL dflags xs
+  | gopt Opt_SccProfilingOn dflags = xs
+  | otherwise                      = []
+
+
+---------------------------------------------------------------
+--        Initialising Cost Centres & CCSs
+---------------------------------------------------------------
+
+initCostCentres :: CollectedCCs -> FCode ()
+-- Emit the declarations
+initCostCentres (local_CCs, singleton_CCSs)
+  = do dflags <- getDynFlags
+       when (gopt Opt_SccProfilingOn dflags) $
+           do mapM_ emitCostCentreDecl local_CCs
+              mapM_ emitCostCentreStackDecl singleton_CCSs
+
+
+emitCostCentreDecl :: CostCentre -> FCode ()
+emitCostCentreDecl cc = do
+  { dflags <- getDynFlags
+  ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF
+               | otherwise  = zero dflags
+                        -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
+  ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
+  ; modl  <- newByteStringCLit (bytesFS $ Module.moduleNameFS
+                                        $ Module.moduleName
+                                        $ cc_mod cc)
+  ; loc <- newByteStringCLit $ bytesFS $ mkFastString $
+                   showPpr dflags (costCentreSrcSpan cc)
+           -- XXX going via FastString to get UTF-8 encoding is silly
+  ; let
+     lits = [ zero dflags,           -- StgInt ccID,
+              label,        -- char *label,
+              modl,        -- char *module,
+              loc,      -- char *srcloc,
+              zero64,   -- StgWord64 mem_alloc
+              zero dflags,     -- StgWord time_ticks
+              is_caf,   -- StgInt is_caf
+              zero dflags      -- struct _CostCentre *link
+            ]
+  ; emitDataLits (mkCCLabel cc) lits
+  }
+
+emitCostCentreStackDecl :: CostCentreStack -> FCode ()
+emitCostCentreStackDecl ccs
+  = case maybeSingletonCCS ccs of
+    Just cc ->
+        do dflags <- getDynFlags
+           let mk_lits cc = zero dflags :
+                            mkCCostCentre cc :
+                            replicate (sizeof_ccs_words dflags - 2) (zero dflags)
+                -- Note: to avoid making any assumptions about how the
+                -- C compiler (that compiles the RTS, in particular) does
+                -- layouts of structs containing long-longs, simply
+                -- pad out the struct with zero words until we hit the
+                -- size of the overall struct (which we get via DerivedConstants.h)
+           emitDataLits (mkCCSLabel ccs) (mk_lits cc)
+    Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
+
+zero :: DynFlags -> CmmLit
+zero dflags = mkIntCLit dflags 0
+zero64 :: CmmLit
+zero64 = CmmInt 0 W64
+
+sizeof_ccs_words :: DynFlags -> Int
+sizeof_ccs_words dflags
+    -- round up to the next word.
+  | ms == 0   = ws
+  | otherwise = ws + 1
+  where
+   (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags
+
+-- ---------------------------------------------------------------------------
+-- Set the current cost centre stack
+
+emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
+emitSetCCC cc tick push
+ = do dflags <- getDynFlags
+      if not (gopt Opt_SccProfilingOn dflags)
+          then return ()
+          else do tmp <- newTemp (ccsType dflags)
+                  pushCostCentre tmp cccsExpr cc
+                  when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
+                  when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
+
+pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
+pushCostCentre result ccs cc
+  = emitRtsCallWithResult result AddrHint
+        rtsUnitId
+        (fsLit "pushCostCentre") [(ccs,AddrHint),
+                                (CmmLit (mkCCostCentre cc), AddrHint)]
+        False
+
+bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph
+bumpSccCount dflags ccs
+  = addToMem (rEP_CostCentreStack_scc_count dflags)
+         (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1
+
+-----------------------------------------------------------------------------
+--
+--                Lag/drag/void stuff
+--
+-----------------------------------------------------------------------------
+
+--
+-- Initial value for the LDV field in a static closure
+--
+staticLdvInit :: DynFlags -> CmmLit
+staticLdvInit = zeroCLit
+
+--
+-- Initial value of the LDV field in a dynamic closure
+--
+dynLdvInit :: DynFlags -> CmmExpr
+dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
+  CmmMachOp (mo_wordOr dflags) [
+      CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],
+      CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))
+  ]
+
+--
+-- Initialise the LDV word of a new closure
+--
+ldvRecordCreate :: CmmExpr -> FCode ()
+ldvRecordCreate closure = do
+  dflags <- getDynFlags
+  emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)
+
+--
+-- | Called when a closure is entered, marks the closure as having
+-- been "used".  The closure is not an "inherently used" one.  The
+-- closure is not @IND@ because that is not considered for LDV profiling.
+--
+ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()
+ldvEnterClosure closure_info node_reg = do
+    dflags <- getDynFlags
+    let tag = funTag dflags closure_info
+    -- don't forget to substract node's tag
+    ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag))
+
+ldvEnter :: CmmExpr -> FCode ()
+-- Argument is a closure pointer
+ldvEnter cl_ptr = do
+    dflags <- getDynFlags
+    let -- don't forget to substract node's tag
+        ldv_wd = ldvWord dflags cl_ptr
+        new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
+                                                         (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))
+                                      (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))
+    ifProfiling $
+         -- if (era > 0) {
+         --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
+         --                era | LDV_STATE_USE }
+        emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])
+                     (mkStore ldv_wd new_ldv_wd)
+                     mkNop
+
+loadEra :: DynFlags -> CmmExpr
+loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))
+    [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))
+             (cInt dflags)]
+
+ldvWord :: DynFlags -> CmmExpr -> CmmExpr
+-- Takes the address of a closure, and returns
+-- the address of the LDV word in the closure
+ldvWord dflags closure_ptr
+    = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmTicky.hs
@@ -0,0 +1,682 @@
+{-# LANGUAGE BangPatterns #-}
+
+-----------------------------------------------------------------------------
+--
+-- Code generation for ticky-ticky profiling
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+{- OVERVIEW: ticky ticky profiling
+
+Please see
+http://ghc.haskell.org/trac/ghc/wiki/Debugging/TickyTicky and also
+edit it and the rest of this comment to keep them up-to-date if you
+change ticky-ticky. Thanks!
+
+ *** All allocation ticky numbers are in bytes. ***
+
+Some of the relevant source files:
+
+       ***not necessarily an exhaustive list***
+
+  * some codeGen/ modules import this one
+
+  * this module imports cmm/CLabel.hs to manage labels
+
+  * cmm/CmmParse.y expands some macros using generators defined in
+    this module
+
+  * includes/stg/Ticky.h declares all of the global counters
+
+  * includes/rts/Ticky.h declares the C data type for an
+    STG-declaration's counters
+
+  * some macros defined in includes/Cmm.h (and used within the RTS's
+    CMM code) update the global ticky counters
+
+  * at the end of execution rts/Ticky.c generates the final report
+    +RTS -r<report-file> -RTS
+
+The rts/Ticky.c function that generates the report includes an
+STG-declaration's ticky counters if
+
+  * that declaration was entered, or
+
+  * it was allocated (if -ticky-allocd)
+
+On either of those events, the counter is "registered" by adding it to
+a linked list; cf the CMM generated by registerTickyCtr.
+
+Ticky-ticky profiling has evolved over many years. Many of the
+counters from its most sophisticated days are no longer
+active/accurate. As the RTS has changed, sometimes the ticky code for
+relevant counters was not accordingly updated. Unfortunately, neither
+were the comments.
+
+As of March 2013, there still exist deprecated code and comments in
+the code generator as well as the RTS because:
+
+  * I don't know what is out-of-date versus merely commented out for
+    momentary convenience, and
+
+  * someone else might know how to repair it!
+
+-}
+
+module StgCmmTicky (
+  withNewTickyCounterFun,
+  withNewTickyCounterLNE,
+  withNewTickyCounterThunk,
+  withNewTickyCounterStdThunk,
+  withNewTickyCounterCon,
+
+  tickyDynAlloc,
+  tickyAllocHeap,
+
+  tickyAllocPrim,
+  tickyAllocThunk,
+  tickyAllocPAP,
+  tickyHeapCheck,
+  tickyStackCheck,
+
+  tickyUnknownCall, tickyDirectCall,
+
+  tickyPushUpdateFrame,
+  tickyUpdateFrameOmitted,
+
+  tickyEnterDynCon,
+  tickyEnterStaticCon,
+  tickyEnterViaNode,
+
+  tickyEnterFun,
+  tickyEnterThunk, tickyEnterStdThunk,        -- dynamic non-value
+                                              -- thunks only
+  tickyEnterLNE,
+
+  tickyUpdateBhCaf,
+  tickyBlackHole,
+  tickyUnboxedTupleReturn,
+  tickyReturnOldCon, tickyReturnNewCon,
+
+  tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
+  tickySlowCall, tickySlowCallPat,
+  ) where
+
+import GhcPrelude
+
+import StgCmmArgRep    ( slowCallPattern , toArgRep , argRepString )
+import StgCmmClosure
+import StgCmmUtils
+import StgCmmMonad
+
+import StgSyn
+import CmmExpr
+import MkGraph
+import CmmUtils
+import CLabel
+import SMRep
+
+import Module
+import Name
+import Id
+import BasicTypes
+import FastString
+import Outputable
+import Util
+
+import DynFlags
+
+-- Turgid imports for showTypeCategory
+import PrelNames
+import TcType
+import Type
+import TyCon
+
+import Data.Maybe
+import qualified Data.Char
+import Control.Monad ( when )
+
+-----------------------------------------------------------------------------
+--
+-- Ticky-ticky profiling
+--
+-----------------------------------------------------------------------------
+
+data TickyClosureType
+    = TickyFun
+        Bool -- True <-> single entry
+    | TickyCon
+    | TickyThunk
+        Bool -- True <-> updateable
+        Bool -- True <-> standard thunk (AP or selector), has no entry counter
+    | TickyLNE
+
+withNewTickyCounterFun :: Bool -> Name  -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)
+
+withNewTickyCounterLNE :: Name  -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounterLNE nm args code = do
+  b <- tickyLNEIsOn
+  if not b then code else withNewTickyCounter TickyLNE nm args code
+
+thunkHasCounter :: Bool -> FCode Bool
+thunkHasCounter isStatic = do
+  b <- tickyDynThunkIsOn
+  pure (not isStatic && b)
+
+withNewTickyCounterThunk
+  :: Bool -- ^ static
+  -> Bool -- ^ updateable
+  -> Name
+  -> FCode a
+  -> FCode a
+withNewTickyCounterThunk isStatic isUpdatable name code = do
+    has_ctr <- thunkHasCounter isStatic
+    if not has_ctr
+      then code
+      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code
+
+withNewTickyCounterStdThunk
+  :: Bool -- ^ updateable
+  -> Name
+  -> FCode a
+  -> FCode a
+withNewTickyCounterStdThunk isUpdatable name code = do
+    has_ctr <- thunkHasCounter False
+    if not has_ctr
+      then code
+      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code
+
+withNewTickyCounterCon
+  :: Name
+  -> FCode a
+  -> FCode a
+withNewTickyCounterCon name code = do
+    has_ctr <- thunkHasCounter False
+    if not has_ctr
+      then code
+      else withNewTickyCounter TickyCon name [] code
+
+-- args does not include the void arguments
+withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounter cloType name args m = do
+  lbl <- emitTickyCounter cloType name args
+  setTickyCtrLabel lbl m
+
+emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel
+emitTickyCounter cloType name args
+  = let ctr_lbl = mkRednCountsLabel name in
+    (>> return ctr_lbl) $
+    ifTicky $ do
+        { dflags <- getDynFlags
+        ; parent <- getTickyCtrLabel
+        ; mod_name <- getModuleName
+
+          -- When printing the name of a thing in a ticky file, we
+          -- want to give the module name even for *local* things.  We
+          -- print just "x (M)" rather that "M.x" to distinguish them
+          -- from the global kind.
+        ; let ppr_for_ticky_name :: SDoc
+              ppr_for_ticky_name =
+                let n = ppr name
+                    ext = case cloType of
+                              TickyFun single_entry -> parens $ hcat $ punctuate comma $
+                                  [text "fun"] ++ [text "se"|single_entry]
+                              TickyCon -> parens (text "con")
+                              TickyThunk upd std -> parens $ hcat $ punctuate comma $
+                                  [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]
+                              TickyLNE | isInternalName name -> parens (text "LNE")
+                                       | otherwise -> panic "emitTickyCounter: how is this an external LNE?"
+                    p = case hasHaskellName parent of
+                            -- NB the default "top" ticky ctr does not
+                            -- have a Haskell name
+                          Just pname -> text "in" <+> ppr (nameUnique pname)
+                          _ -> empty
+                in if isInternalName name
+                   then n <+> parens (ppr mod_name) <+> ext <+> p
+                   else n <+> ext <+> p
+
+        ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name
+        ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args
+        ; emitDataLits ctr_lbl
+        -- Must match layout of includes/rts/Ticky.h's StgEntCounter
+        --
+        -- krc: note that all the fields are I32 now; some were I16
+        -- before, but the code generator wasn't handling that
+        -- properly and it led to chaos, panic and disorder.
+            [ mkIntCLit dflags 0,               -- registered?
+              mkIntCLit dflags (length args),   -- Arity
+              mkIntCLit dflags 0,               -- Heap allocated for this thing
+              fun_descr_lit,
+              arg_descr_lit,
+              zeroCLit dflags,          -- Entries into this thing
+              zeroCLit dflags,          -- Heap allocated by this thing
+              zeroCLit dflags                   -- Link to next StgEntCounter
+            ]
+        }
+
+-- -----------------------------------------------------------------------------
+-- Ticky stack frames
+
+tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()
+tickyPushUpdateFrame    = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
+tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
+
+-- -----------------------------------------------------------------------------
+-- Ticky entries
+
+-- NB the name-specific entries are only available for names that have
+-- dedicated Cmm code. As far as I know, this just rules out
+-- constructor thunks. For them, there is no CMM code block to put the
+-- bump of name-specific ticky counter into. On the other hand, we can
+-- still track allocation their allocation.
+
+tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode ()
+tickyEnterDynCon      = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
+tickyEnterStaticCon   = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")
+tickyEnterViaNode     = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")
+
+tickyEnterThunk :: ClosureInfo -> FCode ()
+tickyEnterThunk cl_info
+  = ifTicky $ do
+    { bumpTickyCounter ctr
+    ; has_ctr <- thunkHasCounter static
+    ; when has_ctr $ do
+      ticky_ctr_lbl <- getTickyCtrLabel
+      registerTickyCtrAtEntryDyn ticky_ctr_lbl
+      bumpTickyEntryCount ticky_ctr_lbl }
+  where
+    updatable = closureSingleEntry cl_info
+    static    = isStaticClosure cl_info
+
+    ctr | static    = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr"
+                                   else fsLit "ENT_STATIC_THK_MANY_ctr"
+        | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr"
+                                   else fsLit "ENT_DYN_THK_MANY_ctr"
+
+tickyEnterStdThunk :: ClosureInfo -> FCode ()
+tickyEnterStdThunk = tickyEnterThunk
+
+tickyBlackHole :: Bool{-updatable-} -> FCode ()
+tickyBlackHole updatable
+  = ifTicky (bumpTickyCounter ctr)
+  where
+    ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr")
+        | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr")
+
+tickyUpdateBhCaf :: ClosureInfo -> FCode ()
+tickyUpdateBhCaf cl_info
+  = ifTicky (bumpTickyCounter ctr)
+  where
+    ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")
+        | otherwise              = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")
+
+tickyEnterFun :: ClosureInfo -> FCode ()
+tickyEnterFun cl_info = ifTicky $ do
+  ctr_lbl <- getTickyCtrLabel
+
+  if isStaticClosure cl_info
+    then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr")
+            registerTickyCtr ctr_lbl
+    else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr")
+            registerTickyCtrAtEntryDyn ctr_lbl
+
+  bumpTickyEntryCount ctr_lbl
+
+tickyEnterLNE :: FCode ()
+tickyEnterLNE = ifTicky $ do
+  bumpTickyCounter (fsLit "ENT_LNE_ctr")
+  ifTickyLNE $ do
+    ctr_lbl <- getTickyCtrLabel
+    registerTickyCtr ctr_lbl
+    bumpTickyEntryCount ctr_lbl
+
+-- needn't register a counter upon entry if
+--
+-- 1) it's for a dynamic closure, and
+--
+-- 2) -ticky-allocd is on
+--
+-- since the counter was registered already upon being alloc'd
+registerTickyCtrAtEntryDyn :: CLabel -> FCode ()
+registerTickyCtrAtEntryDyn ctr_lbl = do
+  already_registered <- tickyAllocdIsOn
+  when (not already_registered) $ registerTickyCtr ctr_lbl
+
+registerTickyCtr :: CLabel -> FCode ()
+-- Register a ticky counter
+--   if ( ! f_ct.registeredp ) {
+--          f_ct.link = ticky_entry_ctrs;       /* hook this one onto the front of the list */
+--          ticky_entry_ctrs = & (f_ct);        /* mark it as "registered" */
+--          f_ct.registeredp = 1 }
+registerTickyCtr ctr_lbl = do
+  dflags <- getDynFlags
+  let
+    -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
+    test = CmmMachOp (MO_Eq (wordWidth dflags))
+              [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
+                                (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags),
+               zeroExpr dflags]
+    register_stmts
+      = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))
+                   (CmmLoad ticky_entry_ctrs (bWord dflags))
+        , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
+        , mkStore (CmmLit (cmmLabelOffB ctr_lbl
+                                (oFFSET_StgEntCounter_registeredp dflags)))
+                   (mkIntExpr dflags 1) ]
+    ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))
+  emit =<< mkCmmIfThen test (catAGraphs register_stmts)
+
+tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()
+tickyReturnOldCon arity
+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")
+                 ; bumpHistogram    (fsLit "RET_OLD_hst") arity }
+tickyReturnNewCon arity
+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")
+                 ; bumpHistogram    (fsLit "RET_NEW_hst") arity }
+
+tickyUnboxedTupleReturn :: RepArity -> FCode ()
+tickyUnboxedTupleReturn arity
+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
+                 ; bumpHistogram    (fsLit "RET_UNBOXED_TUP_hst") arity }
+
+-- -----------------------------------------------------------------------------
+-- Ticky calls
+
+-- Ticks at a *call site*:
+tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
+tickyDirectCall arity args
+  | args `lengthIs` arity = tickyKnownCallExact
+  | otherwise = do tickyKnownCallExtraArgs
+                   tickySlowCallPat (map argPrimRep (drop arity args))
+
+tickyKnownCallTooFewArgs :: FCode ()
+tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
+
+tickyKnownCallExact :: FCode ()
+tickyKnownCallExact      = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")
+
+tickyKnownCallExtraArgs :: FCode ()
+tickyKnownCallExtraArgs  = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")
+
+tickyUnknownCall :: FCode ()
+tickyUnknownCall         = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")
+
+-- Tick for the call pattern at slow call site (i.e. in addition to
+-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
+tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
+tickySlowCall _ [] = return ()
+tickySlowCall lf_info args = do
+ -- see Note [Ticky for slow calls]
+ if isKnownFun lf_info
+   then tickyKnownCallTooFewArgs
+   else tickyUnknownCall
+ tickySlowCallPat (map argPrimRep args)
+
+tickySlowCallPat :: [PrimRep] -> FCode ()
+tickySlowCallPat args = ifTicky $
+  let argReps = map toArgRep args
+      (_, n_matched) = slowCallPattern argReps
+  in if n_matched > 0 && args `lengthIs` n_matched
+     then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps
+     else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"
+
+{-
+
+Note [Ticky for slow calls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Terminology is unfortunately a bit mixed up for these calls. codeGen
+uses "slow call" to refer to unknown calls and under-saturated known
+calls.
+
+Nowadays, though (ie as of the eval/apply paper), the significantly
+slower calls are actually just a subset of these: the ones with no
+built-in argument pattern (cf StgCmmArgRep.slowCallPattern)
+
+So for ticky profiling, we split slow calls into
+"SLOW_CALL_fast_<pattern>_ctr" (those matching a built-in pattern) and
+VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very
+bad for both space and time).
+
+-}
+
+-- -----------------------------------------------------------------------------
+-- Ticky allocation
+
+tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
+-- Called when doing a dynamic heap allocation; the LambdaFormInfo
+-- used to distinguish between closure types
+--
+-- TODO what else to count while we're here?
+tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags ->
+  let bytes = wORD_SIZE dflags * heapClosureSizeW dflags rep
+
+      countGlobal tot ctr = do
+        bumpTickyCounterBy tot bytes
+        bumpTickyCounter   ctr
+      countSpecific = ifTickyAllocd $ case mb_id of
+        Nothing -> return ()
+        Just id -> do
+          let ctr_lbl = mkRednCountsLabel (idName id)
+          registerTickyCtr ctr_lbl
+          bumpTickyAllocd ctr_lbl bytes
+
+  -- TODO are we still tracking "good stuff" (_gds) versus
+  -- administrative (_adm) versus slop (_slp)? I'm going with all _gds
+  -- for now, since I don't currently know neither if we do nor how to
+  -- distinguish. NSF Mar 2013
+
+  in case () of
+    _ | isConRep rep   ->
+          ifTickyDynThunk countSpecific >>
+          countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")
+      | isThunkRep rep ->
+          ifTickyDynThunk countSpecific >>
+          if lfUpdatable lf
+          then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr")
+          else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr")
+      | isFunRep   rep ->
+          countSpecific >>
+          countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr")
+      | otherwise      -> panic "How is this heap object not a con, thunk, or fun?"
+
+
+
+tickyAllocHeap ::
+  Bool -> -- is this a genuine allocation? As opposed to
+          -- StgCmmLayout.adjustHpBackwards
+  VirtualHpOffset -> FCode ()
+-- Called when doing a heap check [TICK_ALLOC_HEAP]
+-- Must be lazy in the amount of allocation!
+tickyAllocHeap genuine hp
+  = ifTicky $
+    do  { dflags <- getDynFlags
+        ; ticky_ctr <- getTickyCtrLabel
+        ; emit $ catAGraphs $
+            -- only test hp from within the emit so that the monadic
+            -- computation itself is not strict in hp (cf knot in
+            -- StgCmmMonad.getHeapUsage)
+          if hp == 0 then []
+          else let !bytes = wORD_SIZE dflags * hp in [
+            -- Bump the allocation total in the closure's StgEntCounter
+            addToMem (rEP_StgEntCounter_allocs dflags)
+                     (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))
+                     bytes,
+            -- Bump the global allocation total ALLOC_HEAP_tot
+            addToMemLbl (bWord dflags)
+                        (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))
+                        bytes,
+            -- Bump the global allocation counter ALLOC_HEAP_ctr
+            if not genuine then mkNop
+            else addToMemLbl (bWord dflags)
+                             (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))
+                             1
+            ]}
+
+
+--------------------------------------------------------------------------------
+-- these three are only called from CmmParse.y (ie ultimately from the RTS)
+
+-- the units are bytes
+
+tickyAllocPrim :: CmmExpr  -- ^ size of the full header, in bytes
+               -> CmmExpr  -- ^ size of the payload, in bytes
+               -> CmmExpr -> FCode ()
+tickyAllocPrim _hdr _goods _slop = ifTicky $ do
+  bumpTickyCounter    (fsLit "ALLOC_PRIM_ctr")
+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr
+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods
+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop
+
+tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
+tickyAllocThunk _goods _slop = ifTicky $ do
+    -- TODO is it ever called with a Single-Entry thunk?
+  bumpTickyCounter    (fsLit "ALLOC_UP_THK_ctr")
+  bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods
+  bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop
+
+tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
+tickyAllocPAP _goods _slop = ifTicky $ do
+  bumpTickyCounter    (fsLit "ALLOC_PAP_ctr")
+  bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods
+  bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop
+
+tickyHeapCheck :: FCode ()
+tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr")
+
+tickyStackCheck :: FCode ()
+tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr")
+
+-- -----------------------------------------------------------------------------
+-- Ticky utils
+
+ifTicky :: FCode () -> FCode ()
+ifTicky code =
+  getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code
+
+tickyAllocdIsOn :: FCode Bool
+tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags
+
+tickyLNEIsOn :: FCode Bool
+tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags
+
+tickyDynThunkIsOn :: FCode Bool
+tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags
+
+ifTickyAllocd :: FCode () -> FCode ()
+ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code
+
+ifTickyLNE :: FCode () -> FCode ()
+ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code
+
+ifTickyDynThunk :: FCode () -> FCode ()
+ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code
+
+bumpTickyCounter :: FastString -> FCode ()
+bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)
+
+bumpTickyCounterBy :: FastString -> Int -> FCode ()
+bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)
+
+bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
+bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)
+
+bumpTickyEntryCount :: CLabel -> FCode ()
+bumpTickyEntryCount lbl = do
+  dflags <- getDynFlags
+  bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags))
+
+bumpTickyAllocd :: CLabel -> Int -> FCode ()
+bumpTickyAllocd lbl bytes = do
+  dflags <- getDynFlags
+  bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes
+
+bumpTickyLbl :: CLabel -> FCode ()
+bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1
+
+bumpTickyLblBy :: CLabel -> Int -> FCode ()
+bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0)
+
+bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()
+bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0)
+
+bumpTickyLit :: CmmLit -> FCode ()
+bumpTickyLit lhs = bumpTickyLitBy lhs 1
+
+bumpTickyLitBy :: CmmLit -> Int -> FCode ()
+bumpTickyLitBy lhs n = do
+  dflags <- getDynFlags
+  emit (addToMem (bWord dflags) (CmmLit lhs) n)
+
+bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
+bumpTickyLitByE lhs e = do
+  dflags <- getDynFlags
+  emit (addToMemE (bWord dflags) (CmmLit lhs) e)
+
+bumpHistogram :: FastString -> Int -> FCode ()
+bumpHistogram lbl n = do
+    dflags <- getDynFlags
+    let offset = n `min` (tICKY_BIN_COUNT dflags - 1)
+    emit (addToMem (bWord dflags)
+           (cmmIndexExpr dflags
+                (wordWidth dflags)
+                (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))
+                (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags))))
+           1)
+
+------------------------------------------------------------------
+-- Showing the "type category" for ticky-ticky profiling
+
+showTypeCategory :: Type -> Char
+  {-
+        +           dictionary
+
+        >           function
+
+        {C,I,F,D,W} char, int, float, double, word
+        {c,i,f,d,w} unboxed ditto
+
+        T           tuple
+
+        P           other primitive type
+        p           unboxed ditto
+
+        L           list
+        E           enumeration type
+        S           other single-constructor type
+        M           other multi-constructor data-con type
+
+        .           other type
+
+        -           reserved for others to mark as "uninteresting"
+
+  Accurate as of Mar 2013, but I eliminated the Array category instead
+  of updating it, for simplicity. It's in P/p, I think --NSF
+
+    -}
+showTypeCategory ty
+  | isDictTy ty = '+'
+  | otherwise = case tcSplitTyConApp_maybe ty of
+  Nothing -> '.'
+  Just (tycon, _) ->
+    (if isUnliftedTyCon tycon then Data.Char.toLower else id) $
+    let anyOf us = getUnique tycon `elem` us in
+    case () of
+      _ | anyOf [funTyConKey] -> '>'
+        | anyOf [charPrimTyConKey, charTyConKey] -> 'C'
+        | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D'
+        | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F'
+        | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,
+                 intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
+                ] -> 'I'
+        | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey,
+                 word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
+                ] -> 'W'
+        | anyOf [listTyConKey] -> 'L'
+        | isTupleTyCon tycon       -> 'T'
+        | isPrimTyCon tycon        -> 'P'
+        | isEnumerationTyCon tycon -> 'E'
+        | isJust (tyConSingleDataCon_maybe tycon) -> 'S'
+        | otherwise -> 'M' -- oh, well...
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -0,0 +1,622 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Code generator utilities; mostly monadic
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmUtils (
+        cgLit, mkSimpleLit,
+        emitDataLits, mkDataLits,
+        emitRODataLits, mkRODataLits,
+        emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
+        assignTemp, newTemp,
+
+        newUnboxedTupleRegs,
+
+        emitMultiAssign, emitCmmLitSwitch, emitSwitch,
+
+        tagToClosure, mkTaggedObjectLoad,
+
+        callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
+
+        cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
+        cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
+        cmmOffsetExprW, cmmOffsetExprB,
+        cmmRegOffW, cmmRegOffB,
+        cmmLabelOffW, cmmLabelOffB,
+        cmmOffsetW, cmmOffsetB,
+        cmmOffsetLitW, cmmOffsetLitB,
+        cmmLoadIndexW,
+        cmmConstrTag1,
+
+        cmmUntag, cmmIsTagged,
+
+        addToMem, addToMemE, addToMemLblE, addToMemLbl,
+        mkWordCLit,
+        newStringCLit, newByteStringCLit,
+        blankWord,
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import StgCmmMonad
+import StgCmmClosure
+import Cmm
+import BlockId
+import MkGraph
+import CodeGen.Platform
+import CLabel
+import CmmUtils
+import CmmSwitch
+
+import ForeignCall
+import IdInfo
+import Type
+import TyCon
+import SMRep
+import Module
+import Literal
+import Digraph
+import Util
+import Unique
+import UniqSupply (MonadUnique(..))
+import DynFlags
+import FastString
+import Outputable
+import RepType
+
+import qualified Data.ByteString as BS
+import qualified Data.Map as M
+import Data.Char
+import Data.List
+import Data.Ord
+import Data.Word
+
+
+-------------------------------------------------------------------------
+--
+--      Literals
+--
+-------------------------------------------------------------------------
+
+cgLit :: Literal -> FCode CmmLit
+cgLit (LitString s) = newByteStringCLit (BS.unpack s)
+ -- not unpackFS; we want the UTF-8 byte stream.
+cgLit other_lit     = do dflags <- getDynFlags
+                         return (mkSimpleLit dflags other_lit)
+
+mkSimpleLit :: DynFlags -> Literal -> CmmLit
+mkSimpleLit dflags (LitChar   c)                = CmmInt (fromIntegral (ord c))
+                                                         (wordWidth dflags)
+mkSimpleLit dflags LitNullAddr                  = zeroCLit dflags
+mkSimpleLit dflags (LitNumber LitNumInt i _)    = CmmInt i (wordWidth dflags)
+mkSimpleLit _      (LitNumber LitNumInt64 i _)  = CmmInt i W64
+mkSimpleLit dflags (LitNumber LitNumWord i _)   = CmmInt i (wordWidth dflags)
+mkSimpleLit _      (LitNumber LitNumWord64 i _) = CmmInt i W64
+mkSimpleLit _      (LitFloat r)                 = CmmFloat r W32
+mkSimpleLit _      (LitDouble r)                = CmmFloat r W64
+mkSimpleLit _      (LitLabel fs ms fod)
+  = let -- TODO: Literal labels might not actually be in the current package...
+        labelSrc = ForeignLabelInThisPackage
+    in CmmLabel (mkForeignLabel fs ms labelSrc fod)
+-- NB: LitRubbish should have been lowered in "CoreToStg"
+mkSimpleLit _      other = pprPanic "mkSimpleLit" (ppr other)
+
+--------------------------------------------------------------------------
+--
+-- Incrementing a memory location
+--
+--------------------------------------------------------------------------
+
+addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
+addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
+
+addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
+addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))
+
+addToMem :: CmmType     -- rep of the counter
+         -> CmmExpr     -- Address
+         -> Int         -- What to add (a word)
+         -> CmmAGraph
+addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))
+
+addToMemE :: CmmType    -- rep of the counter
+          -> CmmExpr    -- Address
+          -> CmmExpr    -- What to add (a word-typed expression)
+          -> CmmAGraph
+addToMemE rep ptr n
+  = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])
+
+
+-------------------------------------------------------------------------
+--
+--      Loading a field from an object,
+--      where the object pointer is itself tagged
+--
+-------------------------------------------------------------------------
+
+mkTaggedObjectLoad
+  :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
+-- (loadTaggedObjectField reg base off tag) generates assignment
+--      reg = bitsK[ base + off - tag ]
+-- where K is fixed by 'reg'
+mkTaggedObjectLoad dflags reg base offset tag
+  = mkAssign (CmmLocal reg)
+             (CmmLoad (cmmOffsetB dflags
+                                  (CmmReg (CmmLocal base))
+                                  (offset - tag))
+                      (localRegType reg))
+
+-------------------------------------------------------------------------
+--
+--      Converting a closure tag to a closure for enumeration types
+--      (this is the implementation of tagToEnum#).
+--
+-------------------------------------------------------------------------
+
+tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
+tagToClosure dflags tycon tag
+  = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)
+  where closure_tbl = CmmLit (CmmLabel lbl)
+        lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
+
+-------------------------------------------------------------------------
+--
+--      Conditionals and rts calls
+--
+-------------------------------------------------------------------------
+
+emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
+emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
+
+emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString
+        -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
+emitRtsCallWithResult res hint pkg fun args safe
+   = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe
+
+-- Make a call to an RTS C procedure
+emitRtsCallGen
+   :: [(LocalReg,ForeignHint)]
+   -> CLabel
+   -> [(CmmExpr,ForeignHint)]
+   -> Bool -- True <=> CmmSafe call
+   -> FCode ()
+emitRtsCallGen res lbl args safe
+  = do { dflags <- getDynFlags
+       ; updfr_off <- getUpdFrameOff
+       ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags
+       ; emit caller_save
+       ; call updfr_off
+       ; emit caller_load }
+  where
+    call updfr_off =
+      if safe then
+        emit =<< mkCmmCall fun_expr res' args' updfr_off
+      else do
+        let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
+        emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
+    (args', arg_hints) = unzip args
+    (res',  res_hints) = unzip res
+    fun_expr = mkLblExpr lbl
+
+
+-----------------------------------------------------------------------------
+--
+--      Caller-Save Registers
+--
+-----------------------------------------------------------------------------
+
+-- Here we generate the sequence of saves/restores required around a
+-- foreign call instruction.
+
+-- TODO: reconcile with includes/Regs.h
+--  * Regs.h claims that BaseReg should be saved last and loaded first
+--    * This might not have been tickled before since BaseReg is callee save
+--  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
+--
+-- This code isn't actually used right now, because callerSaves
+-- only ever returns true in the current universe for registers NOT in
+-- system_regs (just do a grep for CALLER_SAVES in
+-- includes/stg/MachRegs.h).  It's all one giant no-op, and for
+-- good reason: having to save system registers on every foreign call
+-- would be very expensive, so we avoid assigning them to those
+-- registers when we add support for an architecture.
+--
+-- Note that the old code generator actually does more work here: it
+-- also saves other global registers.  We can't (nor want) to do that
+-- here, as we don't have liveness information.  And really, we
+-- shouldn't be doing the workaround at this point in the pipeline, see
+-- Note [Register parameter passing] and the ToDo on CmmCall in
+-- cmm/CmmNode.hs.  Right now the workaround is to avoid inlining across
+-- unsafe foreign calls in rewriteAssignments, but this is strictly
+-- temporary.
+callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)
+callerSaveVolatileRegs dflags = (caller_save, caller_load)
+  where
+    platform = targetPlatform dflags
+
+    caller_save = catAGraphs (map callerSaveGlobalReg    regs_to_save)
+    caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
+
+    system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
+                    {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
+                  , BaseReg ]
+
+    regs_to_save = filter (callerSaves platform) system_regs
+
+    callerSaveGlobalReg reg
+        = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
+
+    callerRestoreGlobalReg reg
+        = mkAssign (CmmGlobal reg)
+                   (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))
+
+-- -----------------------------------------------------------------------------
+-- Global registers
+
+-- We map STG registers onto appropriate CmmExprs.  Either they map
+-- to real machine registers or stored as offsets from BaseReg.  Given
+-- a GlobalReg, get_GlobalReg_addr always produces the
+-- register table address for it.
+-- (See also get_GlobalReg_reg_or_addr in MachRegs)
+
+get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr
+get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0
+get_GlobalReg_addr dflags mid
+    = get_Regtable_addr_from_offset dflags
+                                    (globalRegType dflags mid) (baseRegOffset dflags mid)
+
+-- Calculate a literal representing an offset into the register table.
+-- Used when we don't have an actual BaseReg to offset from.
+regTableOffset :: DynFlags -> Int -> CmmExpr
+regTableOffset dflags n =
+  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))
+
+get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
+get_Regtable_addr_from_offset dflags _rep offset =
+    if haveRegBase (targetPlatform dflags)
+    then CmmRegOff baseReg offset
+    else regTableOffset dflags offset
+
+
+-- -----------------------------------------------------------------------------
+-- Information about global registers
+
+baseRegOffset :: DynFlags -> GlobalReg -> Int
+
+baseRegOffset dflags Sp             = oFFSET_StgRegTable_rSp dflags
+baseRegOffset dflags SpLim          = oFFSET_StgRegTable_rSpLim dflags
+baseRegOffset dflags (LongReg 1)    = oFFSET_StgRegTable_rL1 dflags
+baseRegOffset dflags Hp             = oFFSET_StgRegTable_rHp dflags
+baseRegOffset dflags HpLim          = oFFSET_StgRegTable_rHpLim dflags
+baseRegOffset dflags CCCS           = oFFSET_StgRegTable_rCCCS dflags
+baseRegOffset dflags CurrentTSO     = oFFSET_StgRegTable_rCurrentTSO dflags
+baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags
+baseRegOffset dflags HpAlloc        = oFFSET_StgRegTable_rHpAlloc dflags
+baseRegOffset dflags GCEnter1       = oFFSET_stgGCEnter1 dflags
+baseRegOffset dflags GCFun          = oFFSET_stgGCFun dflags
+baseRegOffset _      reg            = pprPanic "StgCmmUtils.baseRegOffset:" (ppr reg)
+
+-------------------------------------------------------------------------
+--
+--      Strings generate a top-level data block
+--
+-------------------------------------------------------------------------
+
+emitDataLits :: CLabel -> [CmmLit] -> FCode ()
+-- Emit a data-segment data block
+emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)
+
+emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
+-- Emit a read-only data block
+emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
+
+newStringCLit :: String -> FCode CmmLit
+-- Make a global definition for the string,
+-- and return its label
+newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str)
+
+newByteStringCLit :: [Word8] -> FCode CmmLit
+newByteStringCLit bytes
+  = do  { uniq <- newUnique
+        ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes
+        ; emitDecl decl
+        ; return lit }
+
+-------------------------------------------------------------------------
+--
+--      Assigning expressions to temporaries
+--
+-------------------------------------------------------------------------
+
+assignTemp :: CmmExpr -> FCode LocalReg
+-- Make sure the argument is in a local register.
+-- We don't bother being particularly aggressive with avoiding
+-- unnecessary local registers, since we can rely on a later
+-- optimization pass to inline as necessary (and skipping out
+-- on things like global registers can be a little dangerous
+-- due to them being trashed on foreign calls--though it means
+-- the optimization pass doesn't have to do as much work)
+assignTemp (CmmReg (CmmLocal reg)) = return reg
+assignTemp e = do { dflags <- getDynFlags
+                  ; uniq <- newUnique
+                  ; let reg = LocalReg uniq (cmmExprType dflags e)
+                  ; emitAssign (CmmLocal reg) e
+                  ; return reg }
+
+newTemp :: MonadUnique m => CmmType -> m LocalReg
+newTemp rep = do { uniq <- getUniqueM
+                 ; return (LocalReg uniq rep) }
+
+newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
+-- Choose suitable local regs to use for the components
+-- of an unboxed tuple that we are about to return to
+-- the Sequel.  If the Sequel is a join point, using the
+-- regs it wants will save later assignments.
+newUnboxedTupleRegs res_ty
+  = ASSERT( isUnboxedTupleType res_ty )
+    do  { dflags <- getDynFlags
+        ; sequel <- getSequel
+        ; regs <- choose_regs dflags sequel
+        ; ASSERT( regs `equalLength` reps )
+          return (regs, map primRepForeignHint reps) }
+  where
+    reps = typePrimRep res_ty
+    choose_regs _ (AssignTo regs _) = return regs
+    choose_regs dflags _            = mapM (newTemp . primRepCmmType dflags) reps
+
+
+
+-------------------------------------------------------------------------
+--      emitMultiAssign
+-------------------------------------------------------------------------
+
+emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
+-- Emit code to perform the assignments in the
+-- input simultaneously, using temporary variables when necessary.
+
+type Key  = Int
+type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
+                        -- for fast comparison
+type Stmt = (LocalReg, CmmExpr) -- r := e
+
+-- We use the strongly-connected component algorithm, in which
+--      * the vertices are the statements
+--      * an edge goes from s1 to s2 iff
+--              s1 assigns to something s2 uses
+--        that is, if s1 should *follow* s2 in the final order
+
+emitMultiAssign []    []    = return ()
+emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs
+emitMultiAssign regs rhss   = do
+  dflags <- getDynFlags
+  ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )
+    unscramble dflags ([1..] `zip` (regs `zip` rhss))
+
+unscramble :: DynFlags -> [Vrtx] -> FCode ()
+unscramble dflags vertices = mapM_ do_component components
+  where
+        edges :: [ Node Key Vrtx ]
+        edges = [ DigraphNode vertex key1 (edges_from stmt1)
+                | vertex@(key1, stmt1) <- vertices ]
+
+        edges_from :: Stmt -> [Key]
+        edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
+                                    stmt1 `mustFollow` stmt2 ]
+
+        components :: [SCC Vrtx]
+        components = stronglyConnCompFromEdgedVerticesUniq edges
+
+        -- do_components deal with one strongly-connected component
+        -- Not cyclic, or singleton?  Just do it
+        do_component :: SCC Vrtx -> FCode ()
+        do_component (AcyclicSCC (_,stmt))  = mk_graph stmt
+        do_component (CyclicSCC [])         = panic "do_component"
+        do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt
+
+                -- Cyclic?  Then go via temporaries.  Pick one to
+                -- break the loop and try again with the rest.
+        do_component (CyclicSCC ((_,first_stmt) : rest)) = do
+            dflags <- getDynFlags
+            u <- newUnique
+            let (to_tmp, from_tmp) = split dflags u first_stmt
+            mk_graph to_tmp
+            unscramble dflags rest
+            mk_graph from_tmp
+
+        split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)
+        split dflags uniq (reg, rhs)
+          = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
+          where
+            rep = cmmExprType dflags rhs
+            tmp = LocalReg uniq rep
+
+        mk_graph :: Stmt -> FCode ()
+        mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs
+
+        mustFollow :: Stmt -> Stmt -> Bool
+        (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs
+
+-------------------------------------------------------------------------
+--      mkSwitch
+-------------------------------------------------------------------------
+
+
+emitSwitch :: CmmExpr                      -- Tag to switch on
+           -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches
+           -> Maybe CmmAGraphScoped        -- Default branch (if any)
+           -> ConTagZ -> ConTagZ           -- Min and Max possible values;
+                                           -- behaviour outside this range is
+                                           -- undefined
+           -> FCode ()
+
+-- First, two rather common cases in which there is no work to do
+emitSwitch _ []         (Just code) _ _ = emit (fst code)
+emitSwitch _ [(_,code)] Nothing     _ _ = emit (fst code)
+
+-- Right, off we go
+emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do
+    join_lbl      <- newBlockId
+    mb_deflt_lbl  <- label_default join_lbl mb_deflt
+    branches_lbls <- label_branches join_lbl branches
+    tag_expr'     <- assignTemp' tag_expr
+
+    -- Sort the branches before calling mk_discrete_switch
+    let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]
+    let range = (fromIntegral lo_tag, fromIntegral hi_tag)
+
+    emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range
+
+    emitLabel join_lbl
+
+mk_discrete_switch :: Bool -- ^ Use signed comparisons
+          -> CmmExpr
+          -> [(Integer, BlockId)]
+          -> Maybe BlockId
+          -> (Integer, Integer)
+          -> CmmAGraph
+
+-- SINGLETON TAG RANGE: no case analysis to do
+mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)
+  | lo_tag == hi_tag
+  = ASSERT( tag == lo_tag )
+    mkBranch lbl
+
+-- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
+mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _
+  = mkBranch lbl
+        -- The simplifier might have eliminated a case
+        --       so we may have e.g. case xs of
+        --                               [] -> e
+        -- In that situation we can be sure the (:) case
+        -- can't happen, so no need to test
+
+-- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans
+-- See Note [Cmm Switches, the general plan] in CmmSwitch
+mk_discrete_switch signed tag_expr branches mb_deflt range
+  = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)
+
+divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])
+divideBranches branches = (lo_branches, mid, hi_branches)
+  where
+    -- 2 branches => n_branches `div` 2 = 1
+    --            => branches !! 1 give the *second* tag
+    -- There are always at least 2 branches here
+    (mid,_) = branches !! (length branches `div` 2)
+    (lo_branches, hi_branches) = span is_lo branches
+    is_lo (t,_) = t < mid
+
+--------------
+emitCmmLitSwitch :: CmmExpr                    -- Tag to switch on
+               -> [(Literal, CmmAGraphScoped)] -- Tagged branches
+               -> CmmAGraphScoped              -- Default branch (always)
+               -> FCode ()                     -- Emit the code
+emitCmmLitSwitch _scrut []       deflt = emit $ fst deflt
+emitCmmLitSwitch scrut  branches deflt = do
+    scrut' <- assignTemp' scrut
+    join_lbl <- newBlockId
+    deflt_lbl <- label_code join_lbl deflt
+    branches_lbls <- label_branches join_lbl branches
+
+    dflags <- getDynFlags
+    let cmm_ty = cmmExprType dflags scrut
+        rep = typeWidth cmm_ty
+
+    -- We find the necessary type information in the literals in the branches
+    let signed = case head branches of
+                    (LitNumber nt _ _, _) -> litNumIsSigned nt
+                    _ -> False
+
+    let range | signed    = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)
+              | otherwise = (0, tARGET_MAX_WORD dflags)
+
+    if isFloatType cmm_ty
+    then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls
+    else emit $ mk_discrete_switch
+        signed
+        scrut'
+        [(litValue lit,l) | (lit,l) <- branches_lbls]
+        (Just deflt_lbl)
+        range
+    emitLabel join_lbl
+
+-- | lower bound (inclusive), upper bound (exclusive)
+type LitBound = (Maybe Literal, Maybe Literal)
+
+noBound :: LitBound
+noBound = (Nothing, Nothing)
+
+mk_float_switch :: Width -> CmmExpr -> BlockId
+              -> LitBound
+              -> [(Literal,BlockId)]
+              -> FCode CmmAGraph
+mk_float_switch rep scrut deflt _bounds [(lit,blk)]
+  = do dflags <- getDynFlags
+       return $ mkCbranch (cond dflags) deflt blk Nothing
+  where
+    cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]
+      where
+        cmm_lit = mkSimpleLit dflags lit
+        ne      = MO_F_Ne rep
+
+mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches
+  = do dflags <- getDynFlags
+       lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches
+       hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches
+       mkCmmIfThenElse (cond dflags) lo_blk hi_blk
+  where
+    (lo_branches, mid_lit, hi_branches) = divideBranches branches
+
+    bounds_lo = (lo_bound, Just mid_lit)
+    bounds_hi = (Just mid_lit, hi_bound)
+
+    cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]
+      where
+        cmm_lit = mkSimpleLit dflags mid_lit
+        lt      = MO_F_Lt rep
+
+
+--------------
+label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
+label_default _ Nothing
+  = return Nothing
+label_default join_lbl (Just code)
+  = do lbl <- label_code join_lbl code
+       return (Just lbl)
+
+--------------
+label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
+label_branches _join_lbl []
+  = return []
+label_branches join_lbl ((tag,code):branches)
+  = do lbl <- label_code join_lbl code
+       branches' <- label_branches join_lbl branches
+       return ((tag,lbl):branches')
+
+--------------
+label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
+--  label_code J code
+--      generates
+--  [L: code; goto J]
+-- and returns L
+label_code join_lbl (code,tsc) = do
+    lbl <- newBlockId
+    emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)
+    return lbl
+
+--------------
+assignTemp' :: CmmExpr -> FCode CmmExpr
+assignTemp' e
+  | isTrivialCmmExpr e = return e
+  | otherwise = do
+       dflags <- getDynFlags
+       lreg <- newTemp (cmmExprType dflags e)
+       let reg = CmmLocal lreg
+       emitAssign reg e
+       return (CmmReg reg)
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
new file mode 100644
--- /dev/null
+++ b/compiler/coreSyn/CoreLint.hs
@@ -0,0 +1,2758 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+
+A ``lint'' pass to check for Core correctness
+-}
+
+{-# LANGUAGE CPP #-}
+
+module CoreLint (
+    lintCoreBindings, lintUnfolding,
+    lintPassResult, lintInteractiveExpr, lintExpr,
+    lintAnnots, lintTypes,
+
+    -- ** Debug output
+    endPass, endPassIO,
+    dumpPassResult,
+    CoreLint.dumpIfSet,
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSyn
+import CoreFVs
+import CoreUtils
+import CoreStats   ( coreBindsStats )
+import CoreMonad
+import Bag
+import Literal
+import DataCon
+import TysWiredIn
+import TysPrim
+import TcType ( isFloatingTy )
+import Var
+import VarEnv
+import VarSet
+import Name
+import Id
+import IdInfo
+import PprCore
+import ErrUtils
+import Coercion
+import SrcLoc
+import Kind
+import Type
+import RepType
+import TyCoRep       -- checks validity of types/coercions
+import TyCon
+import CoAxiom
+import BasicTypes
+import ErrUtils as Err
+import ListSetOps
+import PrelNames
+import Outputable
+import FastString
+import Util
+import InstEnv     ( instanceDFunId )
+import OptCoercion ( checkAxInstCo )
+import UniqSupply
+import CoreArity ( typeArity )
+import Demand ( splitStrictSig, isBotRes )
+
+import HscTypes
+import DynFlags
+import Control.Monad
+import qualified Control.Monad.Fail as MonadFail
+import MonadUtils
+import Data.Foldable      ( toList )
+import Data.List.NonEmpty ( NonEmpty )
+import Data.Maybe
+import Pair
+import qualified GHC.LanguageExtensions as LangExt
+
+{-
+Note [GHC Formalism]
+~~~~~~~~~~~~~~~~~~~~
+This file implements the type-checking algorithm for System FC, the "official"
+name of the Core language. Type safety of FC is heart of the claim that
+executables produced by GHC do not have segmentation faults. Thus, it is
+useful to be able to reason about System FC independently of reading the code.
+To this purpose, there is a document core-spec.pdf built in docs/core-spec that
+contains a formalism of the types and functions dealt with here. If you change
+just about anything in this file or you change other types/functions throughout
+the Core language (all signposted to this note), you should update that
+formalism. See docs/core-spec/README for more info about how to do so.
+
+Note [check vs lint]
+~~~~~~~~~~~~~~~~~~~~
+This file implements both a type checking algorithm and also general sanity
+checking. For example, the "sanity checking" checks for TyConApp on the left
+of an AppTy, which should never happen. These sanity checks don't really
+affect any notion of type soundness. Yet, it is convenient to do the sanity
+checks at the same time as the type checks. So, we use the following naming
+convention:
+
+- Functions that begin with 'lint'... are involved in type checking. These
+  functions might also do some sanity checking.
+
+- Functions that begin with 'check'... are *not* involved in type checking.
+  They exist only for sanity checking.
+
+Issues surrounding variable naming, shadowing, and such are considered *not*
+to be part of type checking, as the formalism omits these details.
+
+Summary of checks
+~~~~~~~~~~~~~~~~~
+Checks that a set of core bindings is well-formed.  The PprStyle and String
+just control what we print in the event of an error.  The Bool value
+indicates whether we have done any specialisation yet (in which case we do
+some extra checks).
+
+We check for
+        (a) type errors
+        (b) Out-of-scope type variables
+        (c) Out-of-scope local variables
+        (d) Ill-kinded types
+        (e) Incorrect unsafe coercions
+
+If we have done specialisation the we check that there are
+        (a) No top-level bindings of primitive (unboxed type)
+
+Outstanding issues:
+
+    -- Things are *not* OK if:
+    --
+    --  * Unsaturated type app before specialisation has been done;
+    --
+    --  * Oversaturated type app after specialisation (eta reduction
+    --   may well be happening...);
+
+
+Note [Linting function types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As described in Note [Representation of function types], all saturated
+applications of funTyCon are represented with the FunTy constructor. We check
+this invariant in lintType.
+
+Note [Linting type lets]
+~~~~~~~~~~~~~~~~~~~~~~~~
+In the desugarer, it's very very convenient to be able to say (in effect)
+        let a = Type Int in <body>
+That is, use a type let.   See Note [Type let] in CoreSyn.
+
+However, when linting <body> we need to remember that a=Int, else we might
+reject a correct program.  So we carry a type substitution (in this example
+[a -> Int]) and apply this substitution before comparing types.  The functin
+        lintInTy :: Type -> LintM (Type, Kind)
+returns a substituted type.
+
+When we encounter a binder (like x::a) we must apply the substitution
+to the type of the binding variable.  lintBinders does this.
+
+For Ids, the type-substituted Id is added to the in_scope set (which
+itself is part of the TCvSubst we are carrying down), and when we
+find an occurrence of an Id, we fetch it from the in-scope set.
+
+Note [Bad unsafe coercion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+For discussion see https://ghc.haskell.org/trac/ghc/wiki/BadUnsafeCoercions
+Linter introduces additional rules that checks improper coercion between
+different types, called bad coercions. Following coercions are forbidden:
+
+  (a) coercions between boxed and unboxed values;
+  (b) coercions between unlifted values of the different sizes, here
+      active size is checked, i.e. size of the actual value but not
+      the space allocated for value;
+  (c) coercions between floating and integral boxed values, this check
+      is not yet supported for unboxed tuples, as no semantics were
+      specified for that;
+  (d) coercions from / to vector type
+  (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be
+      coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules
+      (a-e) holds.
+
+Note [Join points]
+~~~~~~~~~~~~~~~~~~
+We check the rules listed in Note [Invariants on join points] in CoreSyn. The
+only one that causes any difficulty is the first: All occurrences must be tail
+calls. To this end, along with the in-scope set, we remember in le_joins the
+subset of in-scope Ids that are valid join ids. For example:
+
+  join j x = ... in
+  case e of
+    A -> jump j y -- good
+    B -> case (jump j z) of -- BAD
+           C -> join h = jump j w in ... -- good
+           D -> let x = jump j v in ... -- BAD
+
+A join point remains valid in case branches, so when checking the A
+branch, j is still valid. When we check the scrutinee of the inner
+case, however, we set le_joins to empty, and catch the
+error. Similarly, join points can occur free in RHSes of other join
+points but not the RHSes of value bindings (thunks and functions).
+
+************************************************************************
+*                                                                      *
+                 Beginning and ending passes
+*                                                                      *
+************************************************************************
+
+These functions are not CoreM monad stuff, but they probably ought to
+be, and it makes a convenient place for them.  They print out stuff
+before and after core passes, and do Core Lint when necessary.
+-}
+
+endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
+endPass pass binds rules
+  = do { hsc_env <- getHscEnv
+       ; print_unqual <- getPrintUnqualified
+       ; liftIO $ endPassIO hsc_env print_unqual pass binds rules }
+
+endPassIO :: HscEnv -> PrintUnqualified
+          -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
+-- Used by the IO-is CorePrep too
+endPassIO hsc_env print_unqual pass binds rules
+  = do { dumpPassResult dflags print_unqual mb_flag
+                        (ppr pass) (pprPassDetails pass) binds rules
+       ; lintPassResult hsc_env pass binds }
+  where
+    dflags  = hsc_dflags hsc_env
+    mb_flag = case coreDumpFlag pass of
+                Just flag | dopt flag dflags                    -> Just flag
+                          | dopt Opt_D_verbose_core2core dflags -> Just flag
+                _ -> Nothing
+
+dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
+dumpIfSet dflags dump_me pass extra_info doc
+  = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc
+
+dumpPassResult :: DynFlags
+               -> PrintUnqualified
+               -> Maybe DumpFlag        -- Just df => show details in a file whose
+                                        --            name is specified by df
+               -> SDoc                  -- Header
+               -> SDoc                  -- Extra info to appear after header
+               -> CoreProgram -> [CoreRule]
+               -> IO ()
+dumpPassResult dflags unqual mb_flag hdr extra_info binds rules
+  = do { forM_ mb_flag $ \flag ->
+           Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc
+
+         -- Report result size
+         -- This has the side effect of forcing the intermediate to be evaluated
+         -- if it's not already forced by a -ddump flag.
+       ; Err.debugTraceMsg dflags 2 size_doc
+       }
+
+  where
+    size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]
+
+    dump_doc  = vcat [ nest 2 extra_info
+                     , size_doc
+                     , blankLine
+                     , pprCoreBindingsWithSize binds
+                     , ppUnless (null rules) pp_rules ]
+    pp_rules = vcat [ blankLine
+                    , text "------ Local rules for imported ids --------"
+                    , pprRules rules ]
+
+coreDumpFlag :: CoreToDo -> Maybe DumpFlag
+coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_verbose_core2core
+coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core
+coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
+coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoCallArity          = Just Opt_D_dump_call_arity
+coreDumpFlag CoreDoExitify            = Just Opt_D_dump_exitify
+coreDumpFlag CoreDoStrictness         = Just Opt_D_dump_stranal
+coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper
+coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec
+coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec
+coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse
+coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds_preopt
+coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds
+coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl
+coreDumpFlag CorePrep                 = Just Opt_D_dump_prep
+coreDumpFlag CoreOccurAnal            = Just Opt_D_dump_occur_anal
+
+coreDumpFlag CoreDoPrintCore          = Nothing
+coreDumpFlag (CoreDoRuleCheck {})     = Nothing
+coreDumpFlag CoreDoNothing            = Nothing
+coreDumpFlag (CoreDoPasses {})        = Nothing
+
+{-
+************************************************************************
+*                                                                      *
+                 Top-level interfaces
+*                                                                      *
+************************************************************************
+-}
+
+lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()
+lintPassResult hsc_env pass binds
+  | not (gopt Opt_DoCoreLinting dflags)
+  = return ()
+  | otherwise
+  = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds
+       ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)
+       ; displayLintResults dflags pass warns errs binds  }
+  where
+    dflags = hsc_dflags hsc_env
+
+displayLintResults :: DynFlags -> CoreToDo
+                   -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
+                   -> IO ()
+displayLintResults dflags pass warns errs binds
+  | not (isEmptyBag errs)
+  = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan
+           (defaultDumpStyle dflags)
+           (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
+                 , text "*** Offending Program ***"
+                 , pprCoreBindings binds
+                 , text "*** End of Offense ***" ])
+       ; Err.ghcExit dflags 1 }
+
+  | not (isEmptyBag warns)
+  , not (hasNoDebugOutput dflags)
+  , showLintWarnings pass
+  -- If the Core linter encounters an error, output to stderr instead of
+  -- stdout (#13342)
+  = putLogMsg dflags NoReason Err.SevInfo noSrcSpan
+        (defaultDumpStyle dflags)
+        (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))
+
+  | otherwise = return ()
+  where
+
+lint_banner :: String -> SDoc -> SDoc
+lint_banner string pass = text "*** Core Lint"      <+> text string
+                          <+> text ": in result of" <+> pass
+                          <+> text "***"
+
+showLintWarnings :: CoreToDo -> Bool
+-- Disable Lint warnings on the first simplifier pass, because
+-- there may be some INLINE knots still tied, which is tiresomely noisy
+showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
+showLintWarnings _ = True
+
+lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()
+lintInteractiveExpr what hsc_env expr
+  | not (gopt Opt_DoCoreLinting dflags)
+  = return ()
+  | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr
+  = do { display_lint_err err
+       ; Err.ghcExit dflags 1 }
+  | otherwise
+  = return ()
+  where
+    dflags = hsc_dflags hsc_env
+
+    display_lint_err err
+      = do { putLogMsg dflags NoReason Err.SevDump
+               noSrcSpan (defaultDumpStyle dflags)
+               (vcat [ lint_banner "errors" (text what)
+                     , err
+                     , text "*** Offending Program ***"
+                     , pprCoreExpr expr
+                     , text "*** End of Offense ***" ])
+           ; Err.ghcExit dflags 1 }
+
+interactiveInScope :: HscEnv -> [Var]
+-- In GHCi we may lint expressions, or bindings arising from 'deriving'
+-- clauses, that mention variables bound in the interactive context.
+-- These are Local things (see Note [Interactively-bound Ids in GHCi] in HscTypes).
+-- So we have to tell Lint about them, lest it reports them as out of scope.
+--
+-- We do this by find local-named things that may appear free in interactive
+-- context.  This function is pretty revolting and quite possibly not quite right.
+-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty
+-- so this is a (cheap) no-op.
+--
+-- See Trac #8215 for an example
+interactiveInScope hsc_env
+  = tyvars ++ ids
+  where
+    -- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr
+    ictxt                   = hsc_IC hsc_env
+    (cls_insts, _fam_insts) = ic_instances ictxt
+    te1    = mkTypeEnvWithImplicits (ic_tythings ictxt)
+    te     = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)
+    ids    = typeEnvIds te
+    tyvars = tyCoVarsOfTypesList $ map idType ids
+              -- Why the type variables?  How can the top level envt have free tyvars?
+              -- I think it's because of the GHCi debugger, which can bind variables
+              --   f :: [t] -> [t]
+              -- where t is a RuntimeUnk (see TcType)
+
+lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
+--   Returns (warnings, errors)
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintCoreBindings dflags pass local_in_scope binds
+  = initL dflags flags in_scope_set $
+    addLoc TopLevelBindings         $
+    lintLetBndrs TopLevel binders   $
+        -- Put all the top-level binders in scope at the start
+        -- This is because transformation rules can bring something
+        -- into use 'unexpectedly'
+    do { checkL (null dups) (dupVars dups)
+       ; checkL (null ext_dups) (dupExtVars ext_dups)
+       ; mapM lint_bind binds }
+  where
+    in_scope_set = mkInScopeSet (mkVarSet local_in_scope)
+
+    flags = defaultLintFlags
+               { lf_check_global_ids = check_globals
+               , lf_check_inline_loop_breakers = check_lbs
+               , lf_check_static_ptrs = check_static_ptrs }
+
+    -- See Note [Checking for global Ids]
+    check_globals = case pass of
+                      CoreTidy -> False
+                      CorePrep -> False
+                      _        -> True
+
+    -- See Note [Checking for INLINE loop breakers]
+    check_lbs = case pass of
+                      CoreDesugar    -> False
+                      CoreDesugarOpt -> False
+                      _              -> True
+
+    -- See Note [Checking StaticPtrs]
+    check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere
+                      | otherwise = case pass of
+                          CoreDoFloatOutwards _ -> AllowAtTopLevel
+                          CoreTidy              -> RejectEverywhere
+                          CorePrep              -> AllowAtTopLevel
+                          _                     -> AllowAnywhere
+
+    binders = bindersOfBinds binds
+    (_, dups) = removeDups compare binders
+
+    -- dups_ext checks for names with different uniques
+    -- but but the same External name M.n.  We don't
+    -- allow this at top level:
+    --    M.n{r3}  = ...
+    --    M.n{r29} = ...
+    -- because they both get the same linker symbol
+    ext_dups = snd (removeDups ord_ext (map Var.varName binders))
+    ord_ext n1 n2 | Just m1 <- nameModule_maybe n1
+                  , Just m2 <- nameModule_maybe n2
+                  = compare (m1, nameOccName n1) (m2, nameOccName n2)
+                  | otherwise = LT
+
+    -- If you edit this function, you may need to update the GHC formalism
+    -- See Note [GHC Formalism]
+    lint_bind (Rec prs)         = mapM_ (lintSingleBinding TopLevel Recursive) prs
+    lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[lintUnfolding]{lintUnfolding}
+*                                                                      *
+************************************************************************
+
+Note [Linting Unfoldings from Interfaces]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We use this to check all top-level unfoldings that come in from interfaces
+(it is very painful to catch errors otherwise).
+
+We do not need to call lintUnfolding on unfoldings that are nested within
+top-level unfoldings; they are linted when we lint the top-level unfolding;
+hence the `TopLevelFlag` on `tcPragExpr` in TcIface.
+
+-}
+
+lintUnfolding :: DynFlags
+              -> SrcLoc
+              -> VarSet         -- Treat these as in scope
+              -> CoreExpr
+              -> Maybe MsgDoc   -- Nothing => OK
+
+lintUnfolding dflags locn vars expr
+  | isEmptyBag errs = Nothing
+  | otherwise       = Just (pprMessageBag errs)
+  where
+    in_scope = mkInScopeSet vars
+    (_warns, errs) = initL dflags defaultLintFlags in_scope linter
+    linter = addLoc (ImportedUnfolding locn) $
+             lintCoreExpr expr
+
+lintExpr :: DynFlags
+         -> [Var]               -- Treat these as in scope
+         -> CoreExpr
+         -> Maybe MsgDoc        -- Nothing => OK
+
+lintExpr dflags vars expr
+  | isEmptyBag errs = Nothing
+  | otherwise       = Just (pprMessageBag errs)
+  where
+    in_scope = mkInScopeSet (mkVarSet vars)
+    (_warns, errs) = initL dflags defaultLintFlags in_scope linter
+    linter = addLoc TopLevelBindings $
+             lintCoreExpr expr
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[lintCoreBinding]{lintCoreBinding}
+*                                                                      *
+************************************************************************
+
+Check a core binding, returning the list of variables bound.
+-}
+
+lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
+  = addLoc (RhsOf binder) $
+         -- Check the rhs
+    do { ty <- lintRhs binder rhs
+       ; binder_ty <- applySubstTy (idType binder)
+       ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty)
+
+       -- If the binding is for a CoVar, the RHS should be (Coercion co)
+       -- See Note [CoreSyn type and coercion invariant] in CoreSyn
+       ; checkL (not (isCoVar binder) || isCoArg rhs)
+                (mkLetErr binder rhs)
+
+       -- Check that it's not levity-polymorphic
+       -- Do this first, because otherwise isUnliftedType panics
+       -- Annoyingly, this duplicates the test in lintIdBdr,
+       -- because for non-rec lets we call lintSingleBinding first
+       ; checkL (isJoinId binder || not (isTypeLevPoly binder_ty))
+                (badBndrTyMsg binder (text "levity-polymorphic"))
+
+        -- Check the let/app invariant
+        -- See Note [CoreSyn let/app invariant] in CoreSyn
+       ; checkL ( isJoinId binder
+               || not (isUnliftedType binder_ty)
+               || (isNonRec rec_flag && exprOkForSpeculation rhs)
+               || exprIsTickedString rhs)
+           (badBndrTyMsg binder (text "unlifted"))
+
+        -- Check that if the binder is top-level or recursive, it's not
+        -- demanded. Primitive string literals are exempt as there is no
+        -- computation to perform, see Note [CoreSyn top-level string literals].
+       ; checkL (not (isStrictId binder)
+            || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))
+            || exprIsTickedString rhs)
+           (mkStrictMsg binder)
+
+        -- Check that if the binder is at the top level and has type Addr#,
+        -- that it is a string literal, see
+        -- Note [CoreSyn top-level string literals].
+       ; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy)
+                 || exprIsTickedString rhs)
+           (mkTopNonLitStrMsg binder)
+
+       ; flags <- getLintFlags
+
+         -- Check that a join-point binder has a valid type
+         -- NB: lintIdBinder has checked that it is not top-level bound
+       ; case isJoinId_maybe binder of
+            Nothing    -> return ()
+            Just arity ->  checkL (isValidJoinPointType arity binder_ty)
+                                  (mkInvalidJoinPointMsg binder binder_ty)
+
+       ; when (lf_check_inline_loop_breakers flags
+               && isStableUnfolding (realIdUnfolding binder)
+               && isStrongLoopBreaker (idOccInfo binder)
+               && isInlinePragma (idInlinePragma binder))
+              (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))
+              -- Only non-rule loop breakers inhibit inlining
+
+      -- Check whether arity and demand type are consistent (only if demand analysis
+      -- already happened)
+      --
+      -- Note (Apr 2014): this is actually ok.  See Note [Demand analysis for trivial right-hand sides]
+      --                  in DmdAnal.  After eta-expansion in CorePrep the rhs is no longer trivial.
+      --       ; let dmdTy = idStrictness binder
+      --       ; checkL (case dmdTy of
+      --                  StrictSig dmd_ty -> idArity binder >= dmdTypeDepth dmd_ty || exprIsTrivial rhs)
+      --           (mkArityMsg binder)
+
+       -- Check that the binder's arity is within the bounds imposed by
+       -- the type and the strictness signature. See Note [exprArity invariant]
+       -- and Note [Trimming arity]
+       ; checkL (typeArity (idType binder) `lengthAtLeast` idArity binder)
+           (text "idArity" <+> ppr (idArity binder) <+>
+           text "exceeds typeArity" <+>
+           ppr (length (typeArity (idType binder))) <> colon <+>
+           ppr binder)
+
+       ; case splitStrictSig (idStrictness binder) of
+           (demands, result_info) | isBotRes result_info ->
+             checkL (demands `lengthAtLeast` idArity binder)
+               (text "idArity" <+> ppr (idArity binder) <+>
+               text "exceeds arity imposed by the strictness signature" <+>
+               ppr (idStrictness binder) <> colon <+>
+               ppr binder)
+           _ -> return ()
+
+       ; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)
+
+       ; addLoc (UnfoldingOf binder) $
+         lintIdUnfolding binder binder_ty (idUnfolding binder) }
+
+        -- We should check the unfolding, if any, but this is tricky because
+        -- the unfolding is a SimplifiableCoreExpr. Give up for now.
+
+-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr'
+-- in that it doesn't reject occurrences of the function 'makeStatic' when they
+-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and
+-- for join points, it skips the outer lambdas that take arguments to the
+-- join point.
+--
+-- See Note [Checking StaticPtrs].
+lintRhs :: Id -> CoreExpr -> LintM OutType
+lintRhs bndr rhs
+    | Just arity <- isJoinId_maybe bndr
+    = lint_join_lams arity arity True rhs
+    | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)
+    = lint_join_lams arity arity False rhs
+  where
+    lint_join_lams 0 _ _ rhs
+      = lintCoreExpr rhs
+
+    lint_join_lams n tot enforce (Lam var expr)
+      = addLoc (LambdaBodyOf var) $
+        lintBinder LambdaBind var $ \ var' ->
+        do { body_ty <- lint_join_lams (n-1) tot enforce expr
+           ; return $ mkLamType var' body_ty }
+
+    lint_join_lams n tot True _other
+      = failWithL $ mkBadJoinArityMsg bndr tot (tot-n) rhs
+    lint_join_lams _ _ False rhs
+      = markAllJoinsBad $ lintCoreExpr rhs
+          -- Future join point, not yet eta-expanded
+          -- Body is not a tail position
+
+-- Allow applications of the data constructor @StaticPtr@ at the top
+-- but produce errors otherwise.
+lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go
+  where
+    -- Allow occurrences of 'makeStatic' at the top-level but produce errors
+    -- otherwise.
+    go AllowAtTopLevel
+      | (binders0, rhs') <- collectTyBinders rhs
+      , Just (fun, t, info, e) <- collectMakeStaticArgs rhs'
+      = markAllJoinsBad $
+        foldr
+        -- imitate @lintCoreExpr (Lam ...)@
+        (\var loopBinders ->
+          addLoc (LambdaBodyOf var) $
+            lintBinder LambdaBind var $ \var' ->
+              do { body_ty <- loopBinders
+                 ; return $ mkLamType var' body_ty }
+        )
+        -- imitate @lintCoreExpr (App ...)@
+        (do fun_ty <- lintCoreExpr fun
+            addLoc (AnExpr rhs') $ lintCoreArgs fun_ty [Type t, info, e]
+        )
+        binders0
+    go _ = markAllJoinsBad $ lintCoreExpr rhs
+
+lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
+lintIdUnfolding bndr bndr_ty uf
+  | isStableUnfolding uf
+  , Just rhs <- maybeUnfoldingTemplate uf
+  = do { ty <- lintRhs bndr rhs
+       ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }
+lintIdUnfolding  _ _ _
+  = return ()       -- Do not Lint unstable unfoldings, because that leads
+                    -- to exponential behaviour; c.f. CoreFVs.idUnfoldingVars
+
+{-
+Note [Checking for INLINE loop breakers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's very suspicious if a strong loop breaker is marked INLINE.
+
+However, the desugarer generates instance methods with INLINE pragmas
+that form a mutually recursive group.  Only after a round of
+simplification are they unravelled.  So we suppress the test for
+the desugarer.
+
+************************************************************************
+*                                                                      *
+\subsection[lintCoreExpr]{lintCoreExpr}
+*                                                                      *
+************************************************************************
+-}
+
+-- For OutType, OutKind, the substitution has been applied,
+--                       but has not been linted yet
+
+type LintedType  = Type -- Substitution applied, and type is linted
+type LintedKind  = Kind
+
+lintCoreExpr :: CoreExpr -> LintM OutType
+-- The returned type has the substitution from the monad
+-- already applied to it:
+--      lintCoreExpr e subst = exprType (subst e)
+--
+-- The returned "type" can be a kind, if the expression is (Type ty)
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintCoreExpr (Var var)
+  = lintVarOcc var 0
+
+lintCoreExpr (Lit lit)
+  = return (literalType lit)
+
+lintCoreExpr (Cast expr co)
+  = do { expr_ty <- markAllJoinsBad $ lintCoreExpr expr
+       ; co' <- applySubstCo co
+       ; (_, k2, from_ty, to_ty, r) <- lintCoercion co'
+       ; checkValueKind k2 (text "target of cast" <+> quotes (ppr co))
+       ; lintRole co' Representational r
+       ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)
+       ; return to_ty }
+
+lintCoreExpr (Tick tickish expr)
+  = do case tickish of
+         Breakpoint _ ids -> forM_ ids $ \id -> do
+                               checkDeadIdOcc id
+                               lookupIdInScope id
+         _                -> return ()
+       markAllJoinsBadIf block_joins $ lintCoreExpr expr
+  where
+    block_joins = not (tickish `tickishScopesLike` SoftScope)
+      -- TODO Consider whether this is the correct rule. It is consistent with
+      -- the simplifier's behaviour - cost-centre-scoped ticks become part of
+      -- the continuation, and thus they behave like part of an evaluation
+      -- context, but soft-scoped and non-scoped ticks simply wrap the result
+      -- (see Simplify.simplTick).
+
+lintCoreExpr (Let (NonRec tv (Type ty)) body)
+  | isTyVar tv
+  =     -- See Note [Linting type lets]
+    do  { ty' <- applySubstTy ty
+        ; lintTyBndr tv              $ \ tv' ->
+    do  { addLoc (RhsOf tv) $ lintTyKind tv' ty'
+                -- Now extend the substitution so we
+                -- take advantage of it in the body
+        ; extendSubstL tv ty'        $
+          addLoc (BodyOfLetRec [tv]) $
+          lintCoreExpr body } }
+
+lintCoreExpr (Let (NonRec bndr rhs) body)
+  | isId bndr
+  = do  { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
+        ; addLoc (BodyOfLetRec [bndr])
+                 (lintBinder LetBind bndr $ \_ ->
+                  addGoodJoins [bndr] $
+                  lintCoreExpr body) }
+
+  | otherwise
+  = failWithL (mkLetErr bndr rhs)       -- Not quite accurate
+
+lintCoreExpr e@(Let (Rec pairs) body)
+  = lintLetBndrs NotTopLevel bndrs $
+    addGoodJoins bndrs             $
+    do  { -- Check that the list of pairs is non-empty
+          checkL (not (null pairs)) (emptyRec e)
+
+          -- Check that there are no duplicated binders
+        ; checkL (null dups) (dupVars dups)
+
+          -- Check that either all the binders are joins, or none
+        ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $
+            mkInconsistentRecMsg bndrs
+
+        ; mapM_ (lintSingleBinding NotTopLevel Recursive) pairs
+        ; addLoc (BodyOfLetRec bndrs) (lintCoreExpr body) }
+  where
+    bndrs = map fst pairs
+    (_, dups) = removeDups compare bndrs
+
+lintCoreExpr e@(App _ _)
+  = addLoc (AnExpr e) $
+    do { fun_ty <- lintCoreFun fun (length args)
+       ; lintCoreArgs fun_ty args }
+  where
+    (fun, args) = collectArgs e
+
+lintCoreExpr (Lam var expr)
+  = addLoc (LambdaBodyOf var) $
+    markAllJoinsBad $
+    lintBinder LambdaBind var $ \ var' ->
+    do { body_ty <- lintCoreExpr expr
+       ; return $ mkLamType var' body_ty }
+
+lintCoreExpr e@(Case scrut var alt_ty alts) =
+       -- Check the scrutinee
+  do { let scrut_diverges = exprIsBottom scrut
+     ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut
+     ; (alt_ty, _) <- lintInTy alt_ty
+     ; (var_ty, _) <- lintInTy (idType var)
+
+     -- We used to try to check whether a case expression with no
+     -- alternatives was legitimate, but this didn't work.
+     -- See Note [No alternatives lint check] for details.
+
+     -- See Note [Rules for floating-point comparisons] in PrelRules
+     ; let isLitPat (LitAlt _, _ , _) = True
+           isLitPat _                 = False
+     ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)
+         (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++
+                        "expression with literal pattern in case " ++
+                        "analysis (see Trac #9238).")
+          $$ text "scrut" <+> ppr scrut)
+
+     ; case tyConAppTyCon_maybe (idType var) of
+         Just tycon
+              | debugIsOn
+              , isAlgTyCon tycon
+              , not (isAbstractTyCon tycon)
+              , null (tyConDataCons tycon)
+              , not scrut_diverges
+              -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
+                        -- This can legitimately happen for type families
+                      $ return ()
+         _otherwise -> return ()
+
+        -- Don't use lintIdBndr on var, because unboxed tuple is legitimate
+
+     ; subst <- getTCvSubst
+     ; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
+
+     ; lintBinder CaseBind var $ \_ ->
+       do { -- Check the alternatives
+            mapM_ (lintCoreAlt scrut_ty alt_ty) alts
+          ; checkCaseAlts e scrut_ty alts
+          ; return alt_ty } }
+
+-- This case can't happen; linting types in expressions gets routed through
+-- lintCoreArgs
+lintCoreExpr (Type ty)
+  = failWithL (text "Type found as expression" <+> ppr ty)
+
+lintCoreExpr (Coercion co)
+  = do { (k1, k2, ty1, ty2, role) <- lintInCo co
+       ; return (mkHeteroCoercionType role k1 k2 ty1 ty2) }
+
+----------------------
+lintVarOcc :: Var -> Int -- Number of arguments (type or value) being passed
+            -> LintM Type -- returns type of the *variable*
+lintVarOcc var nargs
+  = do  { checkL (isNonCoVarId var)
+                 (text "Non term variable" <+> ppr var)
+                 -- See CoreSyn Note [Variable occurrences in Core]
+
+        -- Cneck that the type of the occurrence is the same
+        -- as the type of the binding site
+        ; ty   <- applySubstTy (idType var)
+        ; var' <- lookupIdInScope var
+        ; let ty' = idType var'
+        ; ensureEqTys ty ty' $ mkBndrOccTypeMismatchMsg var' var ty' ty
+
+          -- Check for a nested occurrence of the StaticPtr constructor.
+          -- See Note [Checking StaticPtrs].
+        ; lf <- getLintFlags
+        ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $
+            checkL (idName var /= makeStaticName) $
+              text "Found makeStatic nested in an expression"
+
+        ; checkDeadIdOcc var
+        ; checkJoinOcc var nargs
+
+        ; return (idType var') }
+
+lintCoreFun :: CoreExpr
+            -> Int        -- Number of arguments (type or val) being passed
+            -> LintM Type -- Returns type of the *function*
+lintCoreFun (Var var) nargs
+  = lintVarOcc var nargs
+
+lintCoreFun (Lam var body) nargs
+  -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad; see
+  -- Note [Beta redexes]
+  | nargs /= 0
+  = addLoc (LambdaBodyOf var) $
+    lintBinder LambdaBind var $ \ var' ->
+    do { body_ty <- lintCoreFun body (nargs - 1)
+       ; return $ mkLamType var' body_ty }
+
+lintCoreFun expr nargs
+  = markAllJoinsBadIf (nargs /= 0) $
+    lintCoreExpr expr
+
+------------------
+checkDeadIdOcc :: Id -> LintM ()
+-- Occurrences of an Id should never be dead....
+-- except when we are checking a case pattern
+checkDeadIdOcc id
+  | isDeadOcc (idOccInfo id)
+  = do { in_case <- inCasePat
+       ; checkL in_case
+                (text "Occurrence of a dead Id" <+> ppr id) }
+  | otherwise
+  = return ()
+
+------------------
+checkJoinOcc :: Id -> JoinArity -> LintM ()
+-- Check that if the occurrence is a JoinId, then so is the
+-- binding site, and it's a valid join Id
+checkJoinOcc var n_args
+  | Just join_arity_occ <- isJoinId_maybe var
+  = do { mb_join_arity_bndr <- lookupJoinId var
+       ; case mb_join_arity_bndr of {
+           Nothing -> -- Binder is not a join point
+                      addErrL (invalidJoinOcc var) ;
+
+           Just join_arity_bndr ->
+
+    do { checkL (join_arity_bndr == join_arity_occ) $
+           -- Arity differs at binding site and occurrence
+         mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ
+
+       ; checkL (n_args == join_arity_occ) $
+           -- Arity doesn't match #args
+         mkBadJumpMsg var join_arity_occ n_args } } }
+
+  | otherwise
+  = return ()
+
+{-
+Note [No alternatives lint check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Case expressions with no alternatives are odd beasts, and it would seem
+like they would worth be looking at in the linter (cf Trac #10180). We
+used to check two things:
+
+* exprIsHNF is false: it would *seem* to be terribly wrong if
+  the scrutinee was already in head normal form.
+
+* exprIsBottom is true: we should be able to see why GHC believes the
+  scrutinee is diverging for sure.
+
+It was already known that the second test was not entirely reliable.
+Unfortunately (Trac #13990), the first test turned out not to be reliable
+either. Getting the checks right turns out to be somewhat complicated.
+
+For example, suppose we have (comment 8)
+
+  data T a where
+    TInt :: T Int
+
+  absurdTBool :: T Bool -> a
+  absurdTBool v = case v of
+
+  data Foo = Foo !(T Bool)
+
+  absurdFoo :: Foo -> a
+  absurdFoo (Foo x) = absurdTBool x
+
+GHC initially accepts the empty case because of the GADT conditions. But then
+we inline absurdTBool, getting
+
+  absurdFoo (Foo x) = case x of
+
+x is in normal form (because the Foo constructor is strict) but the
+case is empty. To avoid this problem, GHC would have to recognize
+that matching on Foo x is already absurd, which is not so easy.
+
+More generally, we don't really know all the ways that GHC can
+lose track of why an expression is bottom, so we shouldn't make too
+much fuss when that happens.
+
+
+Note [Beta redexes]
+~~~~~~~~~~~~~~~~~~~
+Consider:
+
+  join j @x y z = ... in
+  (\@x y z -> jump j @x y z) @t e1 e2
+
+This is clearly ill-typed, since the jump is inside both an application and a
+lambda, either of which is enough to disqualify it as a tail call (see Note
+[Invariants on join points] in CoreSyn). However, strictly from a
+lambda-calculus perspective, the term doesn't go wrong---after the two beta
+reductions, the jump *is* a tail call and everything is fine.
+
+Why would we want to allow this when we have let? One reason is that a compound
+beta redex (that is, one with more than one argument) has different scoping
+rules: naively reducing the above example using lets will capture any free
+occurrence of y in e2. More fundamentally, type lets are tricky; many passes,
+such as Float Out, tacitly assume that the incoming program's type lets have
+all been dealt with by the simplifier. Thus we don't want to let-bind any types
+in, say, CoreSubst.simpleOptPgm, which in some circumstances can run immediately
+before Float Out.
+
+All that said, currently CoreSubst.simpleOptPgm is the only thing using this
+loophole, doing so to avoid re-traversing large functions (beta-reducing a type
+lambda without introducing a type let requires a substitution). TODO: Improve
+simpleOptPgm so that we can forget all this ever happened.
+
+************************************************************************
+*                                                                      *
+\subsection[lintCoreArgs]{lintCoreArgs}
+*                                                                      *
+************************************************************************
+
+The basic version of these functions checks that the argument is a
+subtype of the required type, as one would expect.
+-}
+
+
+lintCoreArgs  :: OutType -> [CoreArg] -> LintM OutType
+lintCoreArgs fun_ty args = foldM lintCoreArg fun_ty args
+
+lintCoreArg  :: OutType -> CoreArg -> LintM OutType
+lintCoreArg fun_ty (Type arg_ty)
+  = do { checkL (not (isCoercionTy arg_ty))
+                (text "Unnecessary coercion-to-type injection:"
+                  <+> ppr arg_ty)
+       ; arg_ty' <- applySubstTy arg_ty
+       ; lintTyApp fun_ty arg_ty' }
+
+lintCoreArg fun_ty arg
+  = do { arg_ty <- markAllJoinsBad $ lintCoreExpr arg
+           -- See Note [Levity polymorphism invariants] in CoreSyn
+       ; lintL (not (isTypeLevPoly arg_ty))
+           (text "Levity-polymorphic argument:" <+>
+             (ppr arg <+> dcolon <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))))
+          -- check for levity polymorphism first, because otherwise isUnliftedType panics
+
+       ; checkL (not (isUnliftedType arg_ty) || exprOkForSpeculation arg)
+                (mkLetAppMsg arg)
+       ; lintValApp arg fun_ty arg_ty }
+
+-----------------
+lintAltBinders :: OutType     -- Scrutinee type
+               -> OutType     -- Constructor type
+               -> [OutVar]    -- Binders
+               -> LintM ()
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintAltBinders scrut_ty con_ty []
+  = ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)
+lintAltBinders scrut_ty con_ty (bndr:bndrs)
+  | isTyVar bndr
+  = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)
+       ; lintAltBinders scrut_ty con_ty' bndrs }
+  | otherwise
+  = do { con_ty' <- lintValApp (Var bndr) con_ty (idType bndr)
+       ; lintAltBinders scrut_ty con_ty' bndrs }
+
+-----------------
+lintTyApp :: OutType -> OutType -> LintM OutType
+lintTyApp fun_ty arg_ty
+  | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty
+  = do  { lintTyKind tv arg_ty
+        ; in_scope <- getInScope
+        -- substTy needs the set of tyvars in scope to avoid generating
+        -- uniques that are already in scope.
+        -- See Note [The substitution invariant] in TyCoRep
+        ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) }
+
+  | otherwise
+  = failWithL (mkTyAppMsg fun_ty arg_ty)
+
+-----------------
+lintValApp :: CoreExpr -> OutType -> OutType -> LintM OutType
+lintValApp arg fun_ty arg_ty
+  | Just (arg,res) <- splitFunTy_maybe fun_ty
+  = do { ensureEqTys arg arg_ty err1
+       ; return res }
+  | otherwise
+  = failWithL err2
+  where
+    err1 = mkAppMsg       fun_ty arg_ty arg
+    err2 = mkNonFunAppMsg fun_ty arg_ty arg
+
+lintTyKind :: OutTyVar -> OutType -> LintM ()
+-- Both args have had substitution applied
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintTyKind tyvar arg_ty
+        -- Arg type might be boxed for a function with an uncommitted
+        -- tyvar; notably this is used so that we can give
+        --      error :: forall a:*. String -> a
+        -- and then apply it to both boxed and unboxed types.
+  = do { arg_kind <- lintType arg_ty
+       ; unless (arg_kind `eqType` tyvar_kind)
+                (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind))) }
+  where
+    tyvar_kind = tyVarKind tyvar
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[lintCoreAlts]{lintCoreAlts}
+*                                                                      *
+************************************************************************
+-}
+
+checkCaseAlts :: CoreExpr -> OutType -> [CoreAlt] -> LintM ()
+-- a) Check that the alts are non-empty
+-- b1) Check that the DEFAULT comes first, if it exists
+-- b2) Check that the others are in increasing order
+-- c) Check that there's a default for infinite types
+-- NB: Algebraic cases are not necessarily exhaustive, because
+--     the simplifier correctly eliminates case that can't
+--     possibly match.
+
+checkCaseAlts e ty alts =
+  do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)
+     ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)
+
+          -- For types Int#, Word# with an infinite (well, large!) number of
+          -- possible values, there should usually be a DEFAULT case
+          -- But (see Note [Empty case alternatives] in CoreSyn) it's ok to
+          -- have *no* case alternatives.
+          -- In effect, this is a kind of partial test. I suppose it's possible
+          -- that we might *know* that 'x' was 1 or 2, in which case
+          --   case x of { 1 -> e1; 2 -> e2 }
+          -- would be fine.
+     ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts)
+              (nonExhaustiveAltsMsg e) }
+  where
+    (con_alts, maybe_deflt) = findDefault alts
+
+        -- Check that successive alternatives have strictly increasing tags
+    increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
+    increasing_tag _                         = True
+
+    non_deflt (DEFAULT, _, _) = False
+    non_deflt _               = True
+
+    is_infinite_ty = case tyConAppTyCon_maybe ty of
+                        Nothing    -> False
+                        Just tycon -> isPrimTyCon tycon
+
+lintAltExpr :: CoreExpr -> OutType -> LintM ()
+lintAltExpr expr ann_ty
+  = do { actual_ty <- lintCoreExpr expr
+       ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty) }
+
+lintCoreAlt :: OutType          -- Type of scrutinee
+            -> OutType          -- Type of the alternative
+            -> CoreAlt
+            -> LintM ()
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintCoreAlt _ alt_ty (DEFAULT, args, rhs) =
+  do { lintL (null args) (mkDefaultArgsMsg args)
+     ; lintAltExpr rhs alt_ty }
+
+lintCoreAlt scrut_ty alt_ty (LitAlt lit, args, rhs)
+  | litIsLifted lit
+  = failWithL integerScrutinisedMsg
+  | otherwise
+  = do { lintL (null args) (mkDefaultArgsMsg args)
+       ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)
+       ; lintAltExpr rhs alt_ty }
+  where
+    lit_ty = literalType lit
+
+lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
+  | isNewTyCon (dataConTyCon con)
+  = addErrL (mkNewTyDataConAltMsg scrut_ty alt)
+  | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty
+  = addLoc (CaseAlt alt) $  do
+    {   -- First instantiate the universally quantified
+        -- type variables of the data constructor
+        -- We've already check
+      lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con)
+    ; let con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys
+
+        -- And now bring the new binders into scope
+    ; lintBinders CasePatBind args $ \ args' -> do
+    { addLoc (CasePat alt) (lintAltBinders scrut_ty con_payload_ty args')
+    ; lintAltExpr rhs alt_ty } }
+
+  | otherwise   -- Scrut-ty is wrong shape
+  = addErrL (mkBadAltMsg scrut_ty alt)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[lint-types]{Types}
+*                                                                      *
+************************************************************************
+-}
+
+-- When we lint binders, we (one at a time and in order):
+--  1. Lint var types or kinds (possibly substituting)
+--  2. Add the binder to the in scope set, and if its a coercion var,
+--     we may extend the substitution to reflect its (possibly) new kind
+lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
+lintBinders _    []         linterF = linterF []
+lintBinders site (var:vars) linterF = lintBinder site var $ \var' ->
+                                      lintBinders site vars $ \ vars' ->
+                                      linterF (var':vars')
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a
+lintBinder site var linterF
+  | isTyVar var = lintTyBndr                  var linterF
+  | isCoVar var = lintCoBndr                  var linterF
+  | otherwise   = lintIdBndr NotTopLevel site var linterF
+
+lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a
+lintTyBndr tv thing_inside
+  = do { subst <- getTCvSubst
+       ; let (subst', tv') = substTyVarBndr subst tv
+       ; lintKind (varType tv')
+       ; updateTCvSubst subst' (thing_inside tv') }
+
+lintCoBndr :: InCoVar -> (OutCoVar -> LintM a) -> LintM a
+lintCoBndr cv thing_inside
+  = do { subst <- getTCvSubst
+       ; let (subst', cv') = substCoVarBndr subst cv
+       ; lintKind (varType cv')
+       ; lintL (isCoVarType (varType cv'))
+               (text "CoVar with non-coercion type:" <+> pprTyVar cv)
+       ; updateTCvSubst subst' (thing_inside cv') }
+
+lintLetBndrs :: TopLevelFlag -> [Var] -> LintM a -> LintM a
+lintLetBndrs top_lvl ids linterF
+  = go ids
+  where
+    go []       = linterF
+    go (id:ids) = lintIdBndr top_lvl LetBind id  $ \_ ->
+                  go ids
+
+lintIdBndr :: TopLevelFlag -> BindingSite
+           -> InVar -> (OutVar -> LintM a) -> LintM a
+-- Do substitution on the type of a binder and add the var with this
+-- new type to the in-scope set of the second argument
+-- ToDo: lint its rules
+lintIdBndr top_lvl bind_site id linterF
+  = ASSERT2( isId id, ppr id )
+    do { flags <- getLintFlags
+       ; checkL (not (lf_check_global_ids flags) || isLocalId id)
+                (text "Non-local Id binder" <+> ppr id)
+                -- See Note [Checking for global Ids]
+
+       -- Check that if the binder is nested, it is not marked as exported
+       ; checkL (not (isExportedId id) || is_top_lvl)
+           (mkNonTopExportedMsg id)
+
+       -- Check that if the binder is nested, it does not have an external name
+       ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl)
+           (mkNonTopExternalNameMsg id)
+
+       ; (ty, k) <- lintInTy (idType id)
+
+          -- See Note [Levity polymorphism invariants] in CoreSyn
+       ; lintL (isJoinId id || not (isKindLevPoly k))
+           (text "Levity-polymorphic binder:" <+>
+                 (ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k)))
+
+       -- Check that a join-id is a not-top-level let-binding
+       ; when (isJoinId id) $
+         checkL (not is_top_lvl && is_let_bind) $
+         mkBadJoinBindMsg id
+
+       -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2);
+       -- if so, it should be a CoVar, and checked by lintCoVarBndr
+       ; lintL (not (isCoVarType ty))
+               (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr ty)
+
+       ; let id' = setIdType id ty
+       ; addInScopeVar id' $ (linterF id') }
+  where
+    is_top_lvl = isTopLevel top_lvl
+    is_let_bind = case bind_site of
+                    LetBind -> True
+                    _       -> False
+
+{-
+%************************************************************************
+%*                                                                      *
+             Types
+%*                                                                      *
+%************************************************************************
+-}
+
+lintTypes :: DynFlags
+          -> [TyCoVar]   -- Treat these as in scope
+          -> [Type]
+          -> Maybe MsgDoc -- Nothing => OK
+lintTypes dflags vars tys
+  | isEmptyBag errs = Nothing
+  | otherwise       = Just (pprMessageBag errs)
+  where
+    in_scope = emptyInScopeSet
+    (_warns, errs) = initL dflags defaultLintFlags in_scope linter
+    linter = lintBinders LambdaBind vars $ \_ ->
+             mapM_ lintInTy tys
+
+lintInTy :: InType -> LintM (LintedType, LintedKind)
+-- Types only, not kinds
+-- Check the type, and apply the substitution to it
+-- See Note [Linting type lets]
+lintInTy ty
+  = addLoc (InType ty) $
+    do  { ty' <- applySubstTy ty
+        ; k  <- lintType ty'
+        ; lintKind k  -- The kind returned by lintType is already
+                      -- a LintedKind but we also want to check that
+                      -- k :: *, which lintKind does
+        ; return (ty', k) }
+
+checkTyCon :: TyCon -> LintM ()
+checkTyCon tc
+  = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc)
+
+-------------------
+lintType :: OutType -> LintM LintedKind
+-- The returned Kind has itself been linted
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintType (TyVarTy tv)
+  = do { checkL (isTyVar tv) (mkBadTyVarMsg tv)
+       ; lintTyCoVarInScope tv
+       ; return (tyVarKind tv) }
+         -- We checked its kind when we added it to the envt
+
+lintType ty@(AppTy t1 t2)
+  | TyConApp {} <- t1
+  = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty
+  | otherwise
+  = do { k1 <- lintType t1
+       ; k2 <- lintType t2
+       ; lint_ty_app ty k1 [(t2,k2)] }
+
+lintType ty@(TyConApp tc tys)
+  | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
+  = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags
+       ; lintTySynFamApp report_unsat ty tc tys }
+
+  | isFunTyCon tc
+  , tys `lengthIs` 4
+    -- We should never see a saturated application of funTyCon; such
+    -- applications should be represented with the FunTy constructor.
+    -- See Note [Linting function types] and
+    -- Note [Representation of function types].
+  = failWithL (hang (text "Saturated application of (->)") 2 (ppr ty))
+
+  | otherwise  -- Data types, data families, primitive types
+  = do { checkTyCon tc
+       ; ks <- mapM lintType tys
+       ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
+
+-- arrows can related *unlifted* kinds, so this has to be separate from
+-- a dependent forall.
+lintType ty@(FunTy t1 t2)
+  = do { k1 <- lintType t1
+       ; k2 <- lintType t2
+       ; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 }
+
+lintType t@(ForAllTy (Bndr tv _vis) ty)
+  -- forall over types
+  | isTyVar tv
+  = lintTyBndr tv $ \tv' ->
+    do { k <- lintType ty
+       ; checkValueKind k (text "the body of forall:" <+> ppr t)
+       ; case occCheckExpand [tv'] k of  -- See Note [Stupid type synonyms]
+           Just k' -> return k'
+           Nothing -> failWithL (hang (text "Variable escape in forall:")
+                                    2 (vcat [ text "type:" <+> ppr t
+                                            , text "kind:" <+> ppr k ]))
+    }
+
+lintType t@(ForAllTy (Bndr cv _vis) ty)
+  -- forall over coercions
+  = do { lintL (isCoVar cv)
+               (text "Non-Tyvar or Non-Covar bound in type:" <+> ppr t)
+       ; lintL (cv `elemVarSet` tyCoVarsOfType ty)
+               (text "Covar does not occur in the body:" <+> ppr t)
+       ; lintCoBndr cv $ \_ ->
+    do { k <- lintType ty
+       ; checkValueKind k (text "the body of forall:" <+> ppr t)
+       ; return liftedTypeKind
+           -- We don't check variable escape here. Namely, k could refer to cv'
+           -- See Note [NthCo and newtypes] in TyCoRep
+    }}
+
+lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)
+
+lintType (CastTy ty co)
+  = do { k1 <- lintType ty
+       ; (k1', k2) <- lintStarCoercion co
+       ; ensureEqTys k1 k1' (mkCastTyErr ty co k1' k1)
+       ; return k2 }
+
+lintType (CoercionTy co)
+  = do { (k1, k2, ty1, ty2, r) <- lintCoercion co
+       ; return $ mkHeteroCoercionType r k1 k2 ty1 ty2 }
+
+{- Note [Stupid type synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #14939)
+   type Alg cls ob = ob
+   f :: forall (cls :: * -> Constraint) (b :: Alg cls *). b
+
+Here 'cls' appears free in b's kind, which would usually be illegal
+(because in (forall a. ty), ty's kind should not mention 'a'). But
+#in this case (Alg cls *) = *, so all is well.  Currently we allow
+this, and make Lint expand synonyms where necessary to make it so.
+
+c.f. TcUnify.occCheckExpand and CoreUtils.coreAltsType which deal
+with the same problem. A single systematic solution eludes me.
+-}
+
+-----------------
+lintTySynFamApp :: Bool -> Type -> TyCon -> [Type] -> LintM LintedKind
+-- The TyCon is a type synonym or a type family (not a data family)
+-- See Note [Linting type synonym applications]
+-- c.f. TcValidity.check_syn_tc_app
+lintTySynFamApp report_unsat ty tc tys
+  | report_unsat   -- Report unsaturated only if report_unsat is on
+  , tys `lengthLessThan` tyConArity tc
+  = failWithL (hang (text "Un-saturated type application") 2 (ppr ty))
+
+  -- Deal with type synonyms
+  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
+  , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'
+  = do { -- Kind-check the argument types, but without reporting
+         -- un-saturated type families/synonyms
+         ks <- setReportUnsat False (mapM lintType tys)
+
+       ; when report_unsat $
+         do { _ <- lintType expanded_ty
+            ; return () }
+
+       ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
+
+  -- Otherwise this must be a type family
+  | otherwise
+  = do { ks <- mapM lintType tys
+       ; lint_ty_app ty (tyConKind tc) (tys `zip` ks) }
+
+-----------------
+lintKind :: OutKind -> LintM ()
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintKind k = do { sk <- lintType k
+                ; unless (classifiesTypeWithValues sk)
+                         (addErrL (hang (text "Ill-kinded kind:" <+> ppr k)
+                                      2 (text "has kind:" <+> ppr sk))) }
+
+-----------------
+-- Confirms that a type is really *, #, Constraint etc
+checkValueKind :: OutKind -> SDoc -> LintM ()
+checkValueKind k doc
+  = lintL (classifiesTypeWithValues k)
+          (text "Non-*-like kind when *-like expected:" <+> ppr k $$
+           text "when checking" <+> doc)
+
+-----------------
+lintArrow :: SDoc -> LintedKind -> LintedKind -> LintM LintedKind
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintArrow what k1 k2   -- Eg lintArrow "type or kind `blah'" k1 k2
+                       -- or lintarrow "coercion `blah'" k1 k2
+  = do { unless (classifiesTypeWithValues k1) (addErrL (msg (text "argument") k1))
+       ; unless (classifiesTypeWithValues k2) (addErrL (msg (text "result")   k2))
+       ; return liftedTypeKind }
+  where
+    msg ar k
+      = vcat [ hang (text "Ill-kinded" <+> ar)
+                  2 (text "in" <+> what)
+             , what <+> text "kind:" <+> ppr k ]
+
+-----------------
+lint_ty_app :: Type -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
+lint_ty_app ty k tys
+  = lint_app (text "type" <+> quotes (ppr ty)) k tys
+
+----------------
+lint_co_app :: Coercion -> LintedKind -> [(LintedType,LintedKind)] -> LintM LintedKind
+lint_co_app ty k tys
+  = lint_app (text "coercion" <+> quotes (ppr ty)) k tys
+
+----------------
+lintTyLit :: TyLit -> LintM ()
+lintTyLit (NumTyLit n)
+  | n >= 0    = return ()
+  | otherwise = failWithL msg
+    where msg = text "Negative type literal:" <+> integer n
+lintTyLit (StrTyLit _) = return ()
+
+lint_app :: SDoc -> LintedKind -> [(LintedType,LintedKind)] -> LintM Kind
+-- (lint_app d fun_kind arg_tys)
+--    We have an application (f arg_ty1 .. arg_tyn),
+--    where f :: fun_kind
+-- Takes care of linting the OutTypes
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lint_app doc kfn kas
+    = do { in_scope <- getInScope
+         -- We need the in_scope set to satisfy the invariant in
+         -- Note [The substitution invariant] in TyCoRep
+         ; foldlM (go_app in_scope) kfn kas }
+  where
+    fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc
+                          , nest 2 (text "Function kind =" <+> ppr kfn)
+                          , nest 2 (text "Arg kinds =" <+> ppr kas)
+                          , extra ]
+
+    go_app in_scope kfn tka
+      | Just kfn' <- coreView kfn
+      = go_app in_scope kfn' tka
+
+    go_app _ (FunTy kfa kfb) tka@(_,ka)
+      = do { unless (ka `eqType` kfa) $
+             addErrL (fail_msg (text "Fun:" <+> (ppr kfa $$ ppr tka)))
+           ; return kfb }
+
+    go_app in_scope (ForAllTy (Bndr kv _vis) kfn) tka@(ta,ka)
+      = do { let kv_kind = varType kv
+           ; unless (ka `eqType` kv_kind) $
+             addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ ppr tka)))
+           ; return $ substTy (extendTCvSubst (mkEmptyTCvSubst in_scope) kv ta) kfn }
+
+    go_app _ kfn ka
+       = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ka)))
+
+{- *********************************************************************
+*                                                                      *
+        Linting rules
+*                                                                      *
+********************************************************************* -}
+
+lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM ()
+lintCoreRule _ _ (BuiltinRule {})
+  = return ()  -- Don't bother
+
+lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs
+                                   , ru_args = args, ru_rhs = rhs })
+  = lintBinders LambdaBind bndrs $ \ _ ->
+    do { lhs_ty <- lintCoreArgs fun_ty args
+       ; rhs_ty <- case isJoinId_maybe fun of
+                     Just join_arity
+                       -> do { checkL (args `lengthIs` join_arity) $
+                                mkBadJoinPointRuleMsg fun join_arity rule
+                               -- See Note [Rules for join points]
+                             ; lintCoreExpr rhs }
+                     _ -> markAllJoinsBad $ lintCoreExpr rhs
+       ; ensureEqTys lhs_ty rhs_ty $
+         (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty
+                            , text "rhs type:" <+> ppr rhs_ty
+                            , text "fun_ty:" <+> ppr fun_ty ])
+       ; let bad_bndrs = filter is_bad_bndr bndrs
+
+       ; checkL (null bad_bndrs)
+                (rule_doc <+> text "unbound" <+> ppr bad_bndrs)
+            -- See Note [Linting rules]
+    }
+  where
+    rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon
+
+    lhs_fvs = exprsFreeVars args
+    rhs_fvs = exprFreeVars rhs
+
+    is_bad_bndr :: Var -> Bool
+    -- See Note [Unbound RULE binders] in Rules
+    is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs)
+                    && bndr `elemVarSet` rhs_fvs
+                    && isNothing (isReflCoVar_maybe bndr)
+
+
+{- Note [Linting rules]
+~~~~~~~~~~~~~~~~~~~~~~~
+It's very bad if simplifying a rule means that one of the template
+variables (ru_bndrs) that /is/ mentioned on the RHS becomes
+not-mentioned in the LHS (ru_args).  How can that happen?  Well, in
+Trac #10602, SpecConstr stupidly constructed a rule like
+
+  forall x,c1,c2.
+     f (x |> c1 |> c2) = ....
+
+But simplExpr collapses those coercions into one.  (Indeed in
+Trac #10602, it collapsed to the identity and was removed altogether.)
+
+We don't have a great story for what to do here, but at least
+this check will nail it.
+
+NB (Trac #11643): it's possible that a variable listed in the
+binders becomes not-mentioned on both LHS and RHS.  Here's a silly
+example:
+   RULE forall x y. f (g x y) = g (x+1) (y-1)
+And suppose worker/wrapper decides that 'x' is Absent.  Then
+we'll end up with
+   RULE forall x y. f ($gw y) = $gw (x+1)
+This seems sufficiently obscure that there isn't enough payoff to
+try to trim the forall'd binder list.
+
+Note [Rules for join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A join point cannot be partially applied. However, the left-hand side of a rule
+for a join point is effectively a *pattern*, not a piece of code, so there's an
+argument to be made for allowing a situation like this:
+
+  join $sj :: Int -> Int -> String
+       $sj n m = ...
+       j :: forall a. Eq a => a -> a -> String
+       {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-}
+       j @a $dEq x y = ...
+
+Applying this rule can't turn a well-typed program into an ill-typed one, so
+conceivably we could allow it. But we can always eta-expand such an
+"undersaturated" rule (see 'CoreArity.etaExpandToJoinPointRule'), and in fact
+the simplifier would have to in order to deal with the RHS. So we take a
+conservative view and don't allow undersaturated rules for join points. See
+Note [Rules and join points] in OccurAnal for further discussion.
+-}
+
+{-
+************************************************************************
+*                                                                      *
+         Linting coercions
+*                                                                      *
+************************************************************************
+-}
+
+lintInCo :: InCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role)
+-- Check the coercion, and apply the substitution to it
+-- See Note [Linting type lets]
+lintInCo co
+  = addLoc (InCo co) $
+    do  { co' <- applySubstCo co
+        ; lintCoercion co' }
+
+-- lints a coercion, confirming that its lh kind and its rh kind are both *
+-- also ensures that the role is Nominal
+lintStarCoercion :: OutCoercion -> LintM (LintedType, LintedType)
+lintStarCoercion g
+  = do { (k1, k2, t1, t2, r) <- lintCoercion g
+       ; checkValueKind k1 (text "the kind of the left type in" <+> ppr g)
+       ; checkValueKind k2 (text "the kind of the right type in" <+> ppr g)
+       ; lintRole g Nominal r
+       ; return (t1, t2) }
+
+lintCoercion :: OutCoercion -> LintM (LintedKind, LintedKind, LintedType, LintedType, Role)
+-- Check the kind of a coercion term, returning the kind
+-- Post-condition: the returned OutTypes are lint-free
+--
+-- If   lintCoercion co = (k1, k2, s1, s2, r)
+-- then co :: s1 ~r s2
+--      s1 :: k1
+--      s2 :: k2
+
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+lintCoercion (Refl ty)
+  = do { k <- lintType ty
+       ; return (k, k, ty, ty, Nominal) }
+
+lintCoercion (GRefl r ty MRefl)
+  = do { k <- lintType ty
+       ; return (k, k, ty, ty, r) }
+
+lintCoercion (GRefl r ty (MCo co))
+  = do { k <- lintType ty
+       ; (_, _, k1, k2, r') <- lintCoercion co
+       ; ensureEqTys k k1
+               (hang (text "GRefl coercion kind mis-match:" <+> ppr co)
+                   2 (vcat [ppr ty, ppr k, ppr k1]))
+       ; lintRole co Nominal r'
+       ; return (k1, k2, ty, mkCastTy ty co, r) }
+
+lintCoercion co@(TyConAppCo r tc cos)
+  | tc `hasKey` funTyConKey
+  , [_rep1,_rep2,_co1,_co2] <- cos
+  = do { failWithL (text "Saturated TyConAppCo (->):" <+> ppr co)
+       } -- All saturated TyConAppCos should be FunCos
+
+  | Just {} <- synTyConDefn_maybe tc
+  = failWithL (text "Synonym in TyConAppCo:" <+> ppr co)
+
+  | otherwise
+  = do { checkTyCon tc
+       ; (k's, ks, ss, ts, rs) <- mapAndUnzip5M lintCoercion cos
+       ; k' <- lint_co_app co (tyConKind tc) (ss `zip` k's)
+       ; k <- lint_co_app co (tyConKind tc) (ts `zip` ks)
+       ; _ <- zipWith3M lintRole cos (tyConRolesX r tc) rs
+       ; return (k', k, mkTyConApp tc ss, mkTyConApp tc ts, r) }
+
+lintCoercion co@(AppCo co1 co2)
+  | TyConAppCo {} <- co1
+  = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co)
+  | Just (TyConApp {}, _) <- isReflCo_maybe co1
+  = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co)
+  | otherwise
+  = do { (k1,  k2,  s1, s2, r1) <- lintCoercion co1
+       ; (k'1, k'2, t1, t2, r2) <- lintCoercion co2
+       ; k3 <- lint_co_app co k1 [(t1,k'1)]
+       ; k4 <- lint_co_app co k2 [(t2,k'2)]
+       ; if r1 == Phantom
+         then lintL (r2 == Phantom || r2 == Nominal)
+                     (text "Second argument in AppCo cannot be R:" $$
+                      ppr co)
+         else lintRole co Nominal r2
+       ; return (k3, k4, mkAppTy s1 t1, mkAppTy s2 t2, r1) }
+
+----------
+lintCoercion (ForAllCo tv1 kind_co co)
+  -- forall over types
+  | isTyVar tv1
+  = do { (_, k2) <- lintStarCoercion kind_co
+       ; let tv2 = setTyVarKind tv1 k2
+       ; addInScopeVar tv1 $
+    do {
+       ; (k3, k4, t1, t2, r) <- lintCoercion co
+       ; in_scope <- getInScope
+       ; let tyl = mkInvForAllTy tv1 t1
+             subst = mkTvSubst in_scope $
+                     -- We need both the free vars of the `t2` and the
+                     -- free vars of the range of the substitution in
+                     -- scope. All the free vars of `t2` and `kind_co` should
+                     -- already be in `in_scope`, because they've been
+                     -- linted and `tv2` has the same unique as `tv1`.
+                     -- See Note [The substitution invariant]
+                     unitVarEnv tv1 (TyVarTy tv2 `mkCastTy` mkSymCo kind_co)
+             tyr = mkInvForAllTy tv2 $
+                   substTy subst t2
+       ; return (k3, k4, tyl, tyr, r) } }
+
+lintCoercion (ForAllCo cv1 kind_co co)
+  -- forall over coercions
+  = ASSERT( isCoVar cv1 )
+    do { lintL (almostDevoidCoVarOfCo cv1 co)
+               (text "Covar can only appear in Refl and GRefl: " <+> ppr co)
+       ; (_, k2) <- lintStarCoercion kind_co
+       ; let cv2 = setVarType cv1 k2
+       ; addInScopeVar cv1 $
+    do {
+       ; (k3, k4, t1, t2, r) <- lintCoercion co
+       ; checkValueKind k3 (text "the body of a ForAllCo over covar:" <+> ppr co)
+       ; checkValueKind k4 (text "the body of a ForAllCo over covar:" <+> ppr co)
+           -- See Note [Weird typing rule for ForAllTy] in Type
+       ; in_scope <- getInScope
+       ; let tyl   = mkTyCoInvForAllTy cv1 t1
+             r2    = coVarRole cv1
+             kind_co' = downgradeRole r2 Nominal kind_co
+             eta1  = mkNthCo r2 2 kind_co'
+             eta2  = mkNthCo r2 3 kind_co'
+             subst = mkCvSubst in_scope $
+                     -- We need both the free vars of the `t2` and the
+                     -- free vars of the range of the substitution in
+                     -- scope. All the free vars of `t2` and `kind_co` should
+                     -- already be in `in_scope`, because they've been
+                     -- linted and `cv2` has the same unique as `cv1`.
+                     -- See Note [The substitution invariant]
+                     unitVarEnv cv1 (eta1 `mkTransCo` (mkCoVarCo cv2)
+                                          `mkTransCo` (mkSymCo eta2))
+             tyr = mkTyCoInvForAllTy cv2 $
+                   substTy subst t2
+       ; return (liftedTypeKind, liftedTypeKind, tyl, tyr, r) } }
+                   -- See Note [Weird typing rule for ForAllTy] in Type
+
+lintCoercion co@(FunCo r co1 co2)
+  = do { (k1,k'1,s1,t1,r1) <- lintCoercion co1
+       ; (k2,k'2,s2,t2,r2) <- lintCoercion co2
+       ; k <- lintArrow (text "coercion" <+> quotes (ppr co)) k1 k2
+       ; k' <- lintArrow (text "coercion" <+> quotes (ppr co)) k'1 k'2
+       ; lintRole co1 r r1
+       ; lintRole co2 r r2
+       ; return (k, k', mkFunTy s1 s2, mkFunTy t1 t2, r) }
+
+lintCoercion (CoVarCo cv)
+  | not (isCoVar cv)
+  = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv)
+                  2 (text "With offending type:" <+> ppr (varType cv)))
+  | otherwise
+  = do { lintTyCoVarInScope cv
+       ; cv' <- lookupIdInScope cv
+       ; lintUnliftedCoVar cv
+       ; return $ coVarKindsTypesRole cv' }
+
+-- See Note [Bad unsafe coercion]
+lintCoercion co@(UnivCo prov r ty1 ty2)
+  = do { k1 <- lintType ty1
+       ; k2 <- lintType ty2
+       ; case prov of
+           UnsafeCoerceProv -> return ()  -- no extra checks
+
+           PhantomProv kco    -> do { lintRole co Phantom r
+                                    ; check_kinds kco k1 k2 }
+
+           ProofIrrelProv kco -> do { lintL (isCoercionTy ty1) $
+                                          mkBadProofIrrelMsg ty1 co
+                                    ; lintL (isCoercionTy ty2) $
+                                          mkBadProofIrrelMsg ty2 co
+                                    ; check_kinds kco k1 k2 }
+
+           PluginProv _     -> return ()  -- no extra checks
+
+       ; when (r /= Phantom && classifiesTypeWithValues k1
+                            && classifiesTypeWithValues k2)
+              (checkTypes ty1 ty2)
+       ; return (k1, k2, ty1, ty2, r) }
+   where
+     report s = hang (text $ "Unsafe coercion: " ++ s)
+                     2 (vcat [ text "From:" <+> ppr ty1
+                             , text "  To:" <+> ppr ty2])
+     isUnBoxed :: PrimRep -> Bool
+     isUnBoxed = not . isGcPtrRep
+
+       -- see #9122 for discussion of these checks
+     checkTypes t1 t2
+       = do { checkWarnL (not lev_poly1)
+                         (report "left-hand type is levity-polymorphic")
+            ; checkWarnL (not lev_poly2)
+                         (report "right-hand type is levity-polymorphic")
+            ; when (not (lev_poly1 || lev_poly2)) $
+              do { checkWarnL (reps1 `equalLength` reps2)
+                              (report "between values with different # of reps")
+                 ; zipWithM_ validateCoercion reps1 reps2 }}
+       where
+         lev_poly1 = isTypeLevPoly t1
+         lev_poly2 = isTypeLevPoly t2
+
+         -- don't look at these unless lev_poly1/2 are False
+         -- Otherwise, we get #13458
+         reps1 = typePrimRep t1
+         reps2 = typePrimRep t2
+
+     validateCoercion :: PrimRep -> PrimRep -> LintM ()
+     validateCoercion rep1 rep2
+       = do { dflags <- getDynFlags
+            ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)
+                         (report "between unboxed and boxed value")
+            ; checkWarnL (TyCon.primRepSizeB dflags rep1
+                           == TyCon.primRepSizeB dflags rep2)
+                         (report "between unboxed values of different size")
+            ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1)
+                                   (TyCon.primRepIsFloat rep2)
+            ; case fl of
+                Nothing    -> addWarnL (report "between vector types")
+                Just False -> addWarnL (report "between float and integral values")
+                _          -> return ()
+            }
+
+     check_kinds kco k1 k2 = do { (k1', k2') <- lintStarCoercion kco
+                                ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft  co)
+                                ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) }
+
+
+lintCoercion (SymCo co)
+  = do { (k1, k2, ty1, ty2, r) <- lintCoercion co
+       ; return (k2, k1, ty2, ty1, r) }
+
+lintCoercion co@(TransCo co1 co2)
+  = do { (k1a, _k1b, ty1a, ty1b, r1) <- lintCoercion co1
+       ; (_k2a, k2b, ty2a, ty2b, r2) <- lintCoercion co2
+       ; ensureEqTys ty1b ty2a
+               (hang (text "Trans coercion mis-match:" <+> ppr co)
+                   2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))
+       ; lintRole co r1 r2
+       ; return (k1a, k2b, ty1a, ty2b, r1) }
+
+lintCoercion the_co@(NthCo r0 n co)
+  = do { (_, _, s, t, r) <- lintCoercion co
+       ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of
+         { (Just (tcv_s, _ty_s), Just (tcv_t, _ty_t))
+             -- works for both tyvar and covar
+             | n == 0
+             ,  (isForAllTy_ty s && isForAllTy_ty t)
+             || (isForAllTy_co s && isForAllTy_co t)
+             -> do { lintRole the_co Nominal r0
+                   ; return (ks, kt, ts, tt, r0) }
+             where
+               ts = varType tcv_s
+               tt = varType tcv_t
+               ks = typeKind ts
+               kt = typeKind tt
+
+         ; _ -> case (splitTyConApp_maybe s, splitTyConApp_maybe t) of
+         { (Just (tc_s, tys_s), Just (tc_t, tys_t))
+             | tc_s == tc_t
+             , isInjectiveTyCon tc_s r
+                 -- see Note [NthCo and newtypes] in TyCoRep
+             , tys_s `equalLength` tys_t
+             , tys_s `lengthExceeds` n
+             -> do { lintRole the_co tr r0
+                   ; return (ks, kt, ts, tt, r0) }
+             where
+               ts = getNth tys_s n
+               tt = getNth tys_t n
+               tr = nthRole r tc_s n
+               ks = typeKind ts
+               kt = typeKind tt
+
+         ; _ -> failWithL (hang (text "Bad getNth:")
+                              2 (ppr the_co $$ ppr s $$ ppr t)) }}}
+
+lintCoercion the_co@(LRCo lr co)
+  = do { (_,_,s,t,r) <- lintCoercion co
+       ; lintRole co Nominal r
+       ; case (splitAppTy_maybe s, splitAppTy_maybe t) of
+           (Just s_pr, Just t_pr)
+             -> return (ks_pick, kt_pick, s_pick, t_pick, Nominal)
+             where
+               s_pick  = pickLR lr s_pr
+               t_pick  = pickLR lr t_pr
+               ks_pick = typeKind s_pick
+               kt_pick = typeKind t_pick
+
+           _ -> failWithL (hang (text "Bad LRCo:")
+                              2 (ppr the_co $$ ppr s $$ ppr t)) }
+
+lintCoercion (InstCo co arg)
+  = do { (k3, k4, t1',t2', r) <- lintCoercion co
+       ; (k1',k2',s1,s2, r') <- lintCoercion arg
+       ; lintRole arg Nominal r'
+       ; in_scope <- getInScope
+       ; case (splitForAllTy_ty_maybe t1', splitForAllTy_ty_maybe t2') of
+         -- forall over tvar
+         { (Just (tv1,t1), Just (tv2,t2))
+             | k1' `eqType` tyVarKind tv1
+             , k2' `eqType` tyVarKind tv2
+             -> return (k3, k4,
+                        substTyWithInScope in_scope [tv1] [s1] t1,
+                        substTyWithInScope in_scope [tv2] [s2] t2, r)
+             | otherwise
+             -> failWithL (text "Kind mis-match in inst coercion")
+         ; _ -> case (splitForAllTy_co_maybe t1', splitForAllTy_co_maybe t2') of
+         -- forall over covar
+         { (Just (cv1, t1), Just (cv2, t2))
+             | k1' `eqType` varType cv1
+             , k2' `eqType` varType cv2
+             , CoercionTy s1' <- s1
+             , CoercionTy s2' <- s2
+             -> do { return $
+                       (liftedTypeKind, liftedTypeKind
+                          -- See Note [Weird typing rule for ForAllTy] in Type
+                       , substTy (mkCvSubst in_scope $ unitVarEnv cv1 s1') t1
+                       , substTy (mkCvSubst in_scope $ unitVarEnv cv2 s2') t2
+                       , r) }
+             | otherwise
+             -> failWithL (text "Kind mis-match in inst coercion")
+         ; _ -> failWithL (text "Bad argument of inst") }}}
+
+lintCoercion co@(AxiomInstCo con ind cos)
+  = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con))
+                (bad_ax (text "index out of range"))
+       ; let CoAxBranch { cab_tvs   = ktvs
+                        , cab_cvs   = cvs
+                        , cab_roles = roles
+                        , cab_lhs   = lhs
+                        , cab_rhs   = rhs } = coAxiomNthBranch con ind
+       ; unless (cos `equalLength` (ktvs ++ cvs)) $
+           bad_ax (text "lengths")
+       ; subst <- getTCvSubst
+       ; let empty_subst = zapTCvSubst subst
+       ; (subst_l, subst_r) <- foldlM check_ki
+                                      (empty_subst, empty_subst)
+                                      (zip3 (ktvs ++ cvs) roles cos)
+       ; let lhs' = substTys subst_l lhs
+             rhs' = substTy  subst_r rhs
+             fam_tc = coAxiomTyCon con
+       ; case checkAxInstCo co of
+           Just bad_branch -> bad_ax $ text "inconsistent with" <+>
+                                       pprCoAxBranch fam_tc bad_branch
+           Nothing -> return ()
+       ; let s2 = mkTyConApp fam_tc lhs'
+       ; return (typeKind s2, typeKind rhs', s2, rhs', coAxiomRole con) }
+  where
+    bad_ax what = addErrL (hang (text  "Bad axiom application" <+> parens what)
+                        2 (ppr co))
+
+    check_ki (subst_l, subst_r) (ktv, role, arg)
+      = do { (k', k'', s', t', r) <- lintCoercion arg
+           ; lintRole arg role r
+           ; let ktv_kind_l = substTy subst_l (tyVarKind ktv)
+                 ktv_kind_r = substTy subst_r (tyVarKind ktv)
+           ; unless (k' `eqType` ktv_kind_l)
+                    (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr k', ppr ktv, ppr ktv_kind_l ] ))
+           ; unless (k'' `eqType` ktv_kind_r)
+                    (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr k'', ppr ktv, ppr ktv_kind_r ] ))
+           ; return (extendTCvSubst subst_l ktv s',
+                     extendTCvSubst subst_r ktv t') }
+
+lintCoercion (KindCo co)
+  = do { (k1, k2, _, _, _) <- lintCoercion co
+       ; return (liftedTypeKind, liftedTypeKind, k1, k2, Nominal) }
+
+lintCoercion (SubCo co')
+  = do { (k1,k2,s,t,r) <- lintCoercion co'
+       ; lintRole co' Nominal r
+       ; return (k1,k2,s,t,Representational) }
+
+lintCoercion this@(AxiomRuleCo co cs)
+  = do { eqs <- mapM lintCoercion cs
+       ; lintRoles 0 (coaxrAsmpRoles co) eqs
+       ; case coaxrProves co [ Pair l r | (_,_,l,r,_) <- eqs ] of
+           Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ]
+           Just (Pair l r) ->
+             return (typeKind l, typeKind r, l, r, coaxrRole co) }
+  where
+  err m xs  = failWithL $
+                hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName co) : xs)
+
+  lintRoles n (e : es) ((_,_,_,_,r) : rs)
+    | e == r    = lintRoles (n+1) es rs
+    | otherwise = err "Argument roles mismatch"
+                      [ text "In argument:" <+> int (n+1)
+                      , text "Expected:" <+> ppr e
+                      , text "Found:" <+> ppr r ]
+  lintRoles _ [] []  = return ()
+  lintRoles n [] rs  = err "Too many coercion arguments"
+                          [ text "Expected:" <+> int n
+                          , text "Provided:" <+> int (n + length rs) ]
+
+  lintRoles n es []  = err "Not enough coercion arguments"
+                          [ text "Expected:" <+> int (n + length es)
+                          , text "Provided:" <+> int n ]
+
+lintCoercion (HoleCo h)
+  = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h
+       ; lintCoercion (CoVarCo (coHoleCoVar h)) }
+
+
+----------
+lintUnliftedCoVar :: CoVar -> LintM ()
+lintUnliftedCoVar cv
+  = when (not (isUnliftedType (coVarKind cv))) $
+    failWithL (text "Bad lifted equality:" <+> ppr cv
+                 <+> dcolon <+> ppr (coVarKind cv))
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[lint-monad]{The Lint monad}
+*                                                                      *
+************************************************************************
+-}
+
+-- If you edit this type, you may need to update the GHC formalism
+-- See Note [GHC Formalism]
+data LintEnv
+  = LE { le_flags :: LintFlags       -- Linting the result of this pass
+       , le_loc   :: [LintLocInfo]   -- Locations
+
+       , le_subst :: TCvSubst  -- Current type substitution
+                               -- We also use le_subst to keep track of
+                               -- /all variables/ in scope, both Ids and TyVars
+
+       , le_joins :: IdSet     -- Join points in scope that are valid
+                               -- A subset of the InScopeSet in le_subst
+                               -- See Note [Join points]
+
+       , le_dynflags :: DynFlags     -- DynamicFlags
+       }
+
+data LintFlags
+  = LF { lf_check_global_ids           :: Bool -- See Note [Checking for global Ids]
+       , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers]
+       , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs]
+       , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications]
+    }
+
+-- See Note [Checking StaticPtrs]
+data StaticPtrCheck
+    = AllowAnywhere
+        -- ^ Allow 'makeStatic' to occur anywhere.
+    | AllowAtTopLevel
+        -- ^ Allow 'makeStatic' calls at the top-level only.
+    | RejectEverywhere
+        -- ^ Reject any 'makeStatic' occurrence.
+  deriving Eq
+
+defaultLintFlags :: LintFlags
+defaultLintFlags = LF { lf_check_global_ids = False
+                      , lf_check_inline_loop_breakers = True
+                      , lf_check_static_ptrs = AllowAnywhere
+                      , lf_report_unsat_syns = True
+                      }
+
+newtype LintM a =
+   LintM { unLintM ::
+            LintEnv ->
+            WarnsAndErrs ->           -- Error and warning messages so far
+            (Maybe a, WarnsAndErrs) } -- Result and messages (if any)
+
+type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)
+
+{- Note [Checking for global Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Before CoreTidy, all locally-bound Ids must be LocalIds, even
+top-level ones. See Note [Exported LocalIds] and Trac #9857.
+
+Note [Checking StaticPtrs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Note [Grand plan for static forms] in StaticPtrTable for an overview.
+
+Every occurrence of the function 'makeStatic' should be moved to the
+top level by the FloatOut pass.  It's vital that we don't have nested
+'makeStatic' occurrences after CorePrep, because we populate the Static
+Pointer Table from the top-level bindings. See SimplCore Note [Grand
+plan for static forms].
+
+The linter checks that no occurrence is left behind, nested within an
+expression. The check is enabled only after the FloatOut, CorePrep,
+and CoreTidy passes and only if the module uses the StaticPointers
+language extension. Checking more often doesn't help since the condition
+doesn't hold until after the first FloatOut pass.
+
+Note [Type substitution]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Why do we need a type substitution?  Consider
+        /\(a:*). \(x:a). /\(a:*). id a x
+This is ill typed, because (renaming variables) it is really
+        /\(a:*). \(x:a). /\(b:*). id b x
+Hence, when checking an application, we can't naively compare x's type
+(at its binding site) with its expected type (at a use site).  So we
+rename type binders as we go, maintaining a substitution.
+
+The same substitution also supports let-type, current expressed as
+        (/\(a:*). body) ty
+Here we substitute 'ty' for 'a' in 'body', on the fly.
+
+Note [Linting type synonym applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When linting a type-synonym, or type-family, application
+  S ty1 .. tyn
+we behave as follows (Trac #15057, #T15664):
+
+* If lf_report_unsat_syns = True, and S has arity < n,
+  complain about an unsaturated type synonym or type family
+
+* Switch off lf_report_unsat_syns, and lint ty1 .. tyn.
+
+  Reason: catch out of scope variables or other ill-kinded gubbins,
+  even if S discards that argument entirely. E.g. (#15012):
+     type FakeOut a = Int
+     type family TF a
+     type instance TF Int = FakeOut a
+  Here 'a' is out of scope; but if we expand FakeOut, we conceal
+  that out-of-scope error.
+
+  Reason for switching off lf_report_unsat_syns: with
+  LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they
+  are saturated when the type is expanded. Example
+     type T f = f Int
+     type S a = a -> a
+     type Z = T S
+  In Z's RHS, S appears unsaturated, but it is saturated when T is expanded.
+
+* If lf_report_unsat_syns is on, expand the synonym application and
+  lint the result.  Reason: want to check that synonyms are saturated
+  when the type is expanded.
+-}
+
+instance Functor LintM where
+      fmap = liftM
+
+instance Applicative LintM where
+      pure x = LintM $ \ _ errs -> (Just x, errs)
+      (<*>) = ap
+
+instance Monad LintM where
+#if !MIN_VERSION_base(4,13,0)
+  fail = MonadFail.fail
+#endif
+  m >>= k  = LintM (\ env errs ->
+                       let (res, errs') = unLintM m env errs in
+                         case res of
+                           Just r -> unLintM (k r) env errs'
+                           Nothing -> (Nothing, errs'))
+
+instance MonadFail.MonadFail LintM where
+    fail err = failWithL (text err)
+
+instance HasDynFlags LintM where
+  getDynFlags = LintM (\ e errs -> (Just (le_dynflags e), errs))
+
+data LintLocInfo
+  = RhsOf Id            -- The variable bound
+  | LambdaBodyOf Id     -- The lambda-binder
+  | UnfoldingOf Id      -- Unfolding of a binder
+  | BodyOfLetRec [Id]   -- One of the binders
+  | CaseAlt CoreAlt     -- Case alternative
+  | CasePat CoreAlt     -- The *pattern* of the case alternative
+  | AnExpr CoreExpr     -- Some expression
+  | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
+  | TopLevelBindings
+  | InType Type         -- Inside a type
+  | InCo   Coercion     -- Inside a coercion
+
+initL :: DynFlags -> LintFlags -> InScopeSet
+       -> LintM a -> WarnsAndErrs    -- Errors and warnings
+initL dflags flags in_scope m
+  = case unLintM m env (emptyBag, emptyBag) of
+      (_, errs) -> errs
+  where
+    env = LE { le_flags = flags
+             , le_subst = mkEmptyTCvSubst in_scope
+             , le_joins = emptyVarSet
+             , le_loc = []
+             , le_dynflags = dflags }
+
+setReportUnsat :: Bool -> LintM a -> LintM a
+-- Switch off lf_report_unsat_syns
+setReportUnsat ru thing_inside
+  = LintM $ \ env errs ->
+    let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } }
+    in unLintM thing_inside env' errs
+
+getLintFlags :: LintM LintFlags
+getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs)
+
+checkL :: Bool -> MsgDoc -> LintM ()
+checkL True  _   = return ()
+checkL False msg = failWithL msg
+
+-- like checkL, but relevant to type checking
+lintL :: Bool -> MsgDoc -> LintM ()
+lintL = checkL
+
+checkWarnL :: Bool -> MsgDoc -> LintM ()
+checkWarnL True   _  = return ()
+checkWarnL False msg = addWarnL msg
+
+failWithL :: MsgDoc -> LintM a
+failWithL msg = LintM $ \ env (warns,errs) ->
+                (Nothing, (warns, addMsg env errs msg))
+
+addErrL :: MsgDoc -> LintM ()
+addErrL msg = LintM $ \ env (warns,errs) ->
+              (Just (), (warns, addMsg env errs msg))
+
+addWarnL :: MsgDoc -> LintM ()
+addWarnL msg = LintM $ \ env (warns,errs) ->
+              (Just (), (addMsg env warns msg, errs))
+
+addMsg :: LintEnv ->  Bag MsgDoc -> MsgDoc -> Bag MsgDoc
+addMsg env msgs msg
+  = ASSERT( notNull locs )
+    msgs `snocBag` mk_msg msg
+  where
+   locs = le_loc env
+   (loc, cxt1) = dumpLoc (head locs)
+   cxts        = [snd (dumpLoc loc) | loc <- locs]
+   context     = ifPprDebug (vcat (reverse cxts) $$ cxt1 $$
+                             text "Substitution:" <+> ppr (le_subst env))
+                            cxt1
+
+   mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg)
+
+addLoc :: LintLocInfo -> LintM a -> LintM a
+addLoc extra_loc m
+  = LintM $ \ env errs ->
+    unLintM m (env { le_loc = extra_loc : le_loc env }) errs
+
+inCasePat :: LintM Bool         -- A slight hack; see the unique call site
+inCasePat = LintM $ \ env errs -> (Just (is_case_pat env), errs)
+  where
+    is_case_pat (LE { le_loc = CasePat {} : _ }) = True
+    is_case_pat _other                           = False
+
+addInScopeVar :: Var -> LintM a -> LintM a
+addInScopeVar var m
+  = LintM $ \ env errs ->
+    unLintM m (env { le_subst = extendTCvInScope (le_subst env) var
+                   , le_joins = delVarSet        (le_joins env) var
+               }) errs
+
+extendSubstL :: TyVar -> Type -> LintM a -> LintM a
+extendSubstL tv ty m
+  = LintM $ \ env errs ->
+    unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs
+
+updateTCvSubst :: TCvSubst -> LintM a -> LintM a
+updateTCvSubst subst' m
+  = LintM $ \ env errs -> unLintM m (env { le_subst = subst' }) errs
+
+markAllJoinsBad :: LintM a -> LintM a
+markAllJoinsBad m
+  = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs
+
+markAllJoinsBadIf :: Bool -> LintM a -> LintM a
+markAllJoinsBadIf True  m = markAllJoinsBad m
+markAllJoinsBadIf False m = m
+
+addGoodJoins :: [Var] -> LintM a -> LintM a
+addGoodJoins vars thing_inside
+  | null join_ids
+  = thing_inside
+  | otherwise
+  = LintM $ \ env errs -> unLintM thing_inside (add_joins env) errs
+  where
+    add_joins env = env { le_joins = le_joins env `extendVarSetList` join_ids }
+    join_ids = filter isJoinId vars
+
+getValidJoins :: LintM IdSet
+getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs))
+
+getTCvSubst :: LintM TCvSubst
+getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs))
+
+getInScope :: LintM InScopeSet
+getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs))
+
+applySubstTy :: InType -> LintM OutType
+applySubstTy ty = do { subst <- getTCvSubst; return (substTy subst ty) }
+
+applySubstCo :: InCoercion -> LintM OutCoercion
+applySubstCo co = do { subst <- getTCvSubst; return (substCo subst co) }
+
+lookupIdInScope :: Id -> LintM Id
+lookupIdInScope id_occ
+  = do { subst <- getTCvSubst
+       ; case lookupInScope (getTCvInScope subst) id_occ of
+           Just id_bnd  -> do { checkL (not (bad_global id_bnd)) global_in_scope
+                              ; return id_bnd }
+           Nothing -> do { checkL (not is_local) local_out_of_scope
+                         ; return id_occ } }
+  where
+    is_local = mustHaveLocalBinding id_occ
+    local_out_of_scope = text "Out of scope:" <+> pprBndr LetBind id_occ
+    global_in_scope    = hang (text "Occurrence is GlobalId, but binding is LocalId")
+                            2 (pprBndr LetBind id_occ)
+    bad_global id_bnd = isGlobalId id_occ
+                     && isLocalId id_bnd
+                     && not (isWiredInName (idName id_occ))
+       -- 'bad_global' checks for the case where an /occurrence/ is
+       -- a GlobalId, but there is an enclosing binding fora a LocalId.
+       -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr,
+       --     but GHCi adds GlobalIds from the interactive context.  These
+       --     are fine; hence the test (isLocalId id == isLocalId v)
+       -- NB: when compiling Control.Exception.Base, things like absentError
+       --     are defined locally, but appear in expressions as (global)
+       --     wired-in Ids after worker/wrapper
+       --     So we simply disable the test in this case
+
+lookupJoinId :: Id -> LintM (Maybe JoinArity)
+-- Look up an Id which should be a join point, valid here
+-- If so, return its arity, if not return Nothing
+lookupJoinId id
+  = do { join_set <- getValidJoins
+       ; case lookupVarSet join_set id of
+            Just id' -> return (isJoinId_maybe id')
+            Nothing  -> return Nothing }
+
+lintTyCoVarInScope :: TyCoVar -> LintM ()
+lintTyCoVarInScope var
+  = do { subst <- getTCvSubst
+       ; lintL (var `isInScope` subst)
+               (pprBndr LetBind var <+> text "is out of scope") }
+
+ensureEqTys :: OutType -> OutType -> MsgDoc -> LintM ()
+-- check ty2 is subtype of ty1 (ie, has same structure but usage
+-- annotations need only be consistent, not equal)
+-- Assumes ty1,ty2 are have already had the substitution applied
+ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg
+
+lintRole :: Outputable thing
+          => thing     -- where the role appeared
+          -> Role      -- expected
+          -> Role      -- actual
+          -> LintM ()
+lintRole co r1 r2
+  = lintL (r1 == r2)
+          (text "Role incompatibility: expected" <+> ppr r1 <> comma <+>
+           text "got" <+> ppr r2 $$
+           text "in" <+> ppr co)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Error messages}
+*                                                                      *
+************************************************************************
+-}
+
+dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)
+
+dumpLoc (RhsOf v)
+  = (getSrcLoc v, brackets (text "RHS of" <+> pp_binders [v]))
+
+dumpLoc (LambdaBodyOf b)
+  = (getSrcLoc b, brackets (text "in body of lambda with binder" <+> pp_binder b))
+
+dumpLoc (UnfoldingOf b)
+  = (getSrcLoc b, brackets (text "in the unfolding of" <+> pp_binder b))
+
+dumpLoc (BodyOfLetRec [])
+  = (noSrcLoc, brackets (text "In body of a letrec with no binders"))
+
+dumpLoc (BodyOfLetRec bs@(_:_))
+  = ( getSrcLoc (head bs), brackets (text "in body of letrec with binders" <+> pp_binders bs))
+
+dumpLoc (AnExpr e)
+  = (noSrcLoc, text "In the expression:" <+> ppr e)
+
+dumpLoc (CaseAlt (con, args, _))
+  = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))
+
+dumpLoc (CasePat (con, args, _))
+  = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))
+
+dumpLoc (ImportedUnfolding locn)
+  = (locn, brackets (text "in an imported unfolding"))
+dumpLoc TopLevelBindings
+  = (noSrcLoc, Outputable.empty)
+dumpLoc (InType ty)
+  = (noSrcLoc, text "In the type" <+> quotes (ppr ty))
+dumpLoc (InCo co)
+  = (noSrcLoc, text "In the coercion" <+> quotes (ppr co))
+
+pp_binders :: [Var] -> SDoc
+pp_binders bs = sep (punctuate comma (map pp_binder bs))
+
+pp_binder :: Var -> SDoc
+pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]
+            | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]
+
+------------------------------------------------------
+--      Messages for case expressions
+
+mkDefaultArgsMsg :: [Var] -> MsgDoc
+mkDefaultArgsMsg args
+  = hang (text "DEFAULT case with binders")
+         4 (ppr args)
+
+mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc
+mkCaseAltMsg e ty1 ty2
+  = hang (text "Type of case alternatives not the same as the annotation on case:")
+         4 (vcat [ text "Actual type:" <+> ppr ty1,
+                   text "Annotation on case:" <+> ppr ty2,
+                   text "Alt Rhs:" <+> ppr e ])
+
+mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> MsgDoc
+mkScrutMsg var var_ty scrut_ty subst
+  = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
+          text "Result binder type:" <+> ppr var_ty,--(idType var),
+          text "Scrutinee type:" <+> ppr scrut_ty,
+     hsep [text "Current TCv subst", ppr subst]]
+
+mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc
+mkNonDefltMsg e
+  = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e)
+mkNonIncreasingAltsMsg e
+  = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)
+
+nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc
+nonExhaustiveAltsMsg e
+  = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
+
+mkBadConMsg :: TyCon -> DataCon -> MsgDoc
+mkBadConMsg tycon datacon
+  = vcat [
+        text "In a case alternative, data constructor isn't in scrutinee type:",
+        text "Scrutinee type constructor:" <+> ppr tycon,
+        text "Data con:" <+> ppr datacon
+    ]
+
+mkBadPatMsg :: Type -> Type -> MsgDoc
+mkBadPatMsg con_result_ty scrut_ty
+  = vcat [
+        text "In a case alternative, pattern result type doesn't match scrutinee type:",
+        text "Pattern result type:" <+> ppr con_result_ty,
+        text "Scrutinee type:" <+> ppr scrut_ty
+    ]
+
+integerScrutinisedMsg :: MsgDoc
+integerScrutinisedMsg
+  = text "In a LitAlt, the literal is lifted (probably Integer)"
+
+mkBadAltMsg :: Type -> CoreAlt -> MsgDoc
+mkBadAltMsg scrut_ty alt
+  = vcat [ text "Data alternative when scrutinee is not a tycon application",
+           text "Scrutinee type:" <+> ppr scrut_ty,
+           text "Alternative:" <+> pprCoreAlt alt ]
+
+mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc
+mkNewTyDataConAltMsg scrut_ty alt
+  = vcat [ text "Data alternative for newtype datacon",
+           text "Scrutinee type:" <+> ppr scrut_ty,
+           text "Alternative:" <+> pprCoreAlt alt ]
+
+
+------------------------------------------------------
+--      Other error messages
+
+mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc
+mkAppMsg fun_ty arg_ty arg
+  = vcat [text "Argument value doesn't match argument type:",
+              hang (text "Fun type:") 4 (ppr fun_ty),
+              hang (text "Arg type:") 4 (ppr arg_ty),
+              hang (text "Arg:") 4 (ppr arg)]
+
+mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc
+mkNonFunAppMsg fun_ty arg_ty arg
+  = vcat [text "Non-function type in function position",
+              hang (text "Fun type:") 4 (ppr fun_ty),
+              hang (text "Arg type:") 4 (ppr arg_ty),
+              hang (text "Arg:") 4 (ppr arg)]
+
+mkLetErr :: TyVar -> CoreExpr -> MsgDoc
+mkLetErr bndr rhs
+  = vcat [text "Bad `let' binding:",
+          hang (text "Variable:")
+                 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)),
+          hang (text "Rhs:")
+                 4 (ppr rhs)]
+
+mkTyAppMsg :: Type -> Type -> MsgDoc
+mkTyAppMsg ty arg_ty
+  = vcat [text "Illegal type application:",
+              hang (text "Exp type:")
+                 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
+              hang (text "Arg type:")
+                 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
+
+emptyRec :: CoreExpr -> MsgDoc
+emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e)
+
+mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc
+mkRhsMsg binder what ty
+  = vcat
+    [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon,
+            ppr binder],
+     hsep [text "Binder's type:", ppr (idType binder)],
+     hsep [text "Rhs type:", ppr ty]]
+
+mkLetAppMsg :: CoreExpr -> MsgDoc
+mkLetAppMsg e
+  = hang (text "This argument does not satisfy the let/app invariant:")
+       2 (ppr e)
+
+badBndrTyMsg :: Id -> SDoc -> MsgDoc
+badBndrTyMsg binder what
+  = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder
+         , text "Binder's type:" <+> ppr (idType binder) ]
+
+mkStrictMsg :: Id -> MsgDoc
+mkStrictMsg binder
+  = vcat [hsep [text "Recursive or top-level binder has strict demand info:",
+                     ppr binder],
+              hsep [text "Binder's demand info:", ppr (idDemandInfo binder)]
+             ]
+
+mkNonTopExportedMsg :: Id -> MsgDoc
+mkNonTopExportedMsg binder
+  = hsep [text "Non-top-level binder is marked as exported:", ppr binder]
+
+mkNonTopExternalNameMsg :: Id -> MsgDoc
+mkNonTopExternalNameMsg binder
+  = hsep [text "Non-top-level binder has an external name:", ppr binder]
+
+mkTopNonLitStrMsg :: Id -> MsgDoc
+mkTopNonLitStrMsg binder
+  = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder]
+
+mkKindErrMsg :: TyVar -> Type -> MsgDoc
+mkKindErrMsg tyvar arg_ty
+  = vcat [text "Kinds don't match in type application:",
+          hang (text "Type variable:")
+                 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
+          hang (text "Arg type:")
+                 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
+
+{- Not needed now
+mkArityMsg :: Id -> MsgDoc
+mkArityMsg binder
+  = vcat [hsep [text "Demand type has",
+                ppr (dmdTypeDepth dmd_ty),
+                text "arguments, rhs has",
+                ppr (idArity binder),
+                text "arguments,",
+                ppr binder],
+              hsep [text "Binder's strictness signature:", ppr dmd_ty]
+
+         ]
+           where (StrictSig dmd_ty) = idStrictness binder
+-}
+mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc
+mkCastErr expr = mk_cast_err "expression" "type" (ppr expr)
+
+mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> MsgDoc
+mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty)
+
+mk_cast_err :: String -- ^ What sort of casted thing this is
+                      --   (\"expression\" or \"type\").
+            -> String -- ^ What sort of coercion is being used
+                      --   (\"type\" or \"kind\").
+            -> SDoc   -- ^ The thing being casted.
+            -> Coercion -> Type -> Type -> MsgDoc
+mk_cast_err thing_str co_str pp_thing co from_ty thing_ty
+  = vcat [from_msg <+> text "of Cast differs from" <+> co_msg
+            <+> text "of" <+> enclosed_msg,
+          from_msg <> colon <+> ppr from_ty,
+          text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon
+            <+> ppr thing_ty,
+          text "Actual" <+> enclosed_msg <> colon <+> pp_thing,
+          text "Coercion used in cast:" <+> ppr co
+         ]
+  where
+    co_msg, from_msg, enclosed_msg :: SDoc
+    co_msg       = text co_str
+    from_msg     = text "From-" <> co_msg
+    enclosed_msg = text "enclosed" <+> text thing_str
+
+mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc
+mkBadUnivCoMsg lr co
+  = text "Kind mismatch on the" <+> pprLeftOrRight lr <+>
+    text "side of a UnivCo:" <+> ppr co
+
+mkBadProofIrrelMsg :: Type -> Coercion -> SDoc
+mkBadProofIrrelMsg ty co
+  = hang (text "Found a non-coercion in a proof-irrelevance UnivCo:")
+       2 (vcat [ text "type:" <+> ppr ty
+               , text "co:" <+> ppr co ])
+
+mkBadTyVarMsg :: Var -> SDoc
+mkBadTyVarMsg tv
+  = text "Non-tyvar used in TyVarTy:"
+      <+> ppr tv <+> dcolon <+> ppr (varType tv)
+
+mkBadJoinBindMsg :: Var -> SDoc
+mkBadJoinBindMsg var
+  = vcat [ text "Bad join point binding:" <+> ppr var
+         , text "Join points can be bound only by a non-top-level let" ]
+
+mkInvalidJoinPointMsg :: Var -> Type -> SDoc
+mkInvalidJoinPointMsg var ty
+  = hang (text "Join point has invalid type:")
+        2 (ppr var <+> dcolon <+> ppr ty)
+
+mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc
+mkBadJoinArityMsg var ar nlams rhs
+  = vcat [ text "Join point has too few lambdas",
+           text "Join var:" <+> ppr var,
+           text "Join arity:" <+> ppr ar,
+           text "Number of lambdas:" <+> ppr nlams,
+           text "Rhs = " <+> ppr rhs
+           ]
+
+invalidJoinOcc :: Var -> SDoc
+invalidJoinOcc var
+  = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var
+         , text "The binder is either not a join point, or not valid here" ]
+
+mkBadJumpMsg :: Var -> Int -> Int -> SDoc
+mkBadJumpMsg var ar nargs
+  = vcat [ text "Join point invoked with wrong number of arguments",
+           text "Join var:" <+> ppr var,
+           text "Join arity:" <+> ppr ar,
+           text "Number of arguments:" <+> int nargs ]
+
+mkInconsistentRecMsg :: [Var] -> SDoc
+mkInconsistentRecMsg bndrs
+  = vcat [ text "Recursive let binders mix values and join points",
+           text "Binders:" <+> hsep (map ppr_with_details bndrs) ]
+  where
+    ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr)
+
+mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc
+mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ
+  = vcat [ text "Mismatch in join point arity between binder and occurrence"
+         , text "Var:" <+> ppr bndr
+         , text "Arity at binding site:" <+> ppr join_arity_bndr
+         , text "Arity at occurrence:  " <+> ppr join_arity_occ ]
+
+mkBndrOccTypeMismatchMsg :: Var -> Var -> OutType -> OutType -> SDoc
+mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty
+  = vcat [ text "Mismatch in type between binder and occurrence"
+         , text "Var:" <+> ppr bndr
+         , text "Binder type:" <+> ppr bndr_ty
+         , text "Occurrence type:" <+> ppr var_ty
+         , text "  Before subst:" <+> ppr (idType var) ]
+
+mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc
+mkBadJoinPointRuleMsg bndr join_arity rule
+  = vcat [ text "Join point has rule with wrong number of arguments"
+         , text "Var:" <+> ppr bndr
+         , text "Join arity:" <+> ppr join_arity
+         , text "Rule:" <+> ppr rule ]
+
+pprLeftOrRight :: LeftOrRight -> MsgDoc
+pprLeftOrRight CLeft  = text "left"
+pprLeftOrRight CRight = text "right"
+
+dupVars :: [NonEmpty Var] -> MsgDoc
+dupVars vars
+  = hang (text "Duplicate variables brought into scope")
+       2 (ppr (map toList vars))
+
+dupExtVars :: [NonEmpty Name] -> MsgDoc
+dupExtVars vars
+  = hang (text "Duplicate top-level variables with the same qualified name")
+       2 (ppr (map toList vars))
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Annotation Linting}
+*                                                                      *
+************************************************************************
+-}
+
+-- | This checks whether a pass correctly looks through debug
+-- annotations (@SourceNote@). This works a bit different from other
+-- consistency checks: We check this by running the given task twice,
+-- noting all differences between the results.
+lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+lintAnnots pname pass guts = do
+  -- Run the pass as we normally would
+  dflags <- getDynFlags
+  when (gopt Opt_DoAnnotationLinting dflags) $
+    liftIO $ Err.showPass dflags "Annotation linting - first run"
+  nguts <- pass guts
+  -- If appropriate re-run it without debug annotations to make sure
+  -- that they made no difference.
+  when (gopt Opt_DoAnnotationLinting dflags) $ do
+    liftIO $ Err.showPass dflags "Annotation linting - second run"
+    nguts' <- withoutAnnots pass guts
+    -- Finally compare the resulting bindings
+    liftIO $ Err.showPass dflags "Annotation linting - comparison"
+    let binds = flattenBinds $ mg_binds nguts
+        binds' = flattenBinds $ mg_binds nguts'
+        (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds'
+    when (not (null diffs)) $ CoreMonad.putMsg $ vcat
+      [ lint_banner "warning" pname
+      , text "Core changes with annotations:"
+      , withPprStyle (defaultDumpStyle dflags) $ nest 2 $ vcat diffs
+      ]
+  -- Return actual new guts
+  return nguts
+
+-- | Run the given pass without annotations. This means that we both
+-- set the debugLevel setting to 0 in the environment as well as all
+-- annotations from incoming modules.
+withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
+withoutAnnots pass guts = do
+  -- Remove debug flag from environment.
+  dflags <- getDynFlags
+  let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} }
+      withoutFlag corem =
+        liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>
+                                getUniqueSupplyM <*> getModule <*>
+                                getVisibleOrphanMods <*>
+                                getPrintUnqualified <*> getSrcSpanM <*>
+                                pure corem
+  -- Nuke existing ticks in module.
+  -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
+  -- them in absence of debugLevel > 0.
+  let nukeTicks = stripTicksE (not . tickishIsCode)
+      nukeAnnotsBind :: CoreBind -> CoreBind
+      nukeAnnotsBind bind = case bind of
+        Rec bs     -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs
+        NonRec b e -> NonRec b $ nukeTicks e
+      nukeAnnotsMod mg@ModGuts{mg_binds=binds}
+        = mg{mg_binds = map nukeAnnotsBind binds}
+  -- Perform pass with all changes applied
+  fmap fst $ withoutFlag $ pass (nukeAnnotsMod guts)
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
new file mode 100644
--- /dev/null
+++ b/compiler/coreSyn/CorePrep.hs
@@ -0,0 +1,1729 @@
+{-
+(c) The University of Glasgow, 1994-2006
+
+
+Core pass to saturate constructors and PrimOps
+-}
+
+{-# LANGUAGE BangPatterns, CPP, MultiWayIf #-}
+
+module CorePrep (
+      corePrepPgm, corePrepExpr, cvtLitInteger, cvtLitNatural,
+      lookupMkIntegerName, lookupIntegerSDataConName,
+      lookupMkNaturalName, lookupNaturalSDataConName
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import OccurAnal
+
+import HscTypes
+import PrelNames
+import MkId             ( realWorldPrimId )
+import CoreUtils
+import CoreArity
+import CoreFVs
+import CoreMonad        ( CoreToDo(..) )
+import CoreLint         ( endPassIO )
+import CoreSyn
+import CoreSubst
+import MkCore hiding( FloatBind(..) )   -- We use our own FloatBind here
+import Type
+import Literal
+import Coercion
+import TcEnv
+import TyCon
+import Demand
+import Var
+import VarSet
+import VarEnv
+import Id
+import IdInfo
+import TysWiredIn
+import DataCon
+import BasicTypes
+import Module
+import UniqSupply
+import Maybes
+import OrdList
+import ErrUtils
+import DynFlags
+import Util
+import Pair
+import Outputable
+import Platform
+import FastString
+import Config
+import Name             ( NamedThing(..), nameSrcSpan )
+import SrcLoc           ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
+import Data.Bits
+import MonadUtils       ( mapAccumLM )
+import Data.List        ( mapAccumL )
+import Control.Monad
+import CostCentre       ( CostCentre, ccFromThisModule )
+import qualified Data.Set as S
+
+{-
+-- ---------------------------------------------------------------------------
+-- Note [CorePrep Overview]
+-- ---------------------------------------------------------------------------
+
+The goal of this pass is to prepare for code generation.
+
+1.  Saturate constructor and primop applications.
+
+2.  Convert to A-normal form; that is, function arguments
+    are always variables.
+
+    * Use case for strict arguments:
+        f E ==> case E of x -> f x
+        (where f is strict)
+
+    * Use let for non-trivial lazy arguments
+        f E ==> let x = E in f x
+        (were f is lazy and x is non-trivial)
+
+3.  Similarly, convert any unboxed lets into cases.
+    [I'm experimenting with leaving 'ok-for-speculation'
+     rhss in let-form right up to this point.]
+
+4.  Ensure that *value* lambdas only occur as the RHS of a binding
+    (The code generator can't deal with anything else.)
+    Type lambdas are ok, however, because the code gen discards them.
+
+5.  [Not any more; nuked Jun 2002] Do the seq/par munging.
+
+6.  Clone all local Ids.
+    This means that all such Ids are unique, rather than the
+    weaker guarantee of no clashes which the simplifier provides.
+    And that is what the code generator needs.
+
+    We don't clone TyVars or CoVars. The code gen doesn't need that,
+    and doing so would be tiresome because then we'd need
+    to substitute in types and coercions.
+
+7.  Give each dynamic CCall occurrence a fresh unique; this is
+    rather like the cloning step above.
+
+8.  Inject bindings for the "implicit" Ids:
+        * Constructor wrappers
+        * Constructor workers
+    We want curried definitions for all of these in case they
+    aren't inlined by some caller.
+
+9.  Replace (lazy e) by e.  See Note [lazyId magic] in MkId.hs
+    Also replace (noinline e) by e.
+
+10. Convert (LitInteger i t) into the core representation
+    for the Integer i. Normally this uses mkInteger, but if
+    we are using the integer-gmp implementation then there is a
+    special case where we use the S# constructor for Integers that
+    are in the range of Int.
+
+11. Same for LitNatural.
+
+12. Uphold tick consistency while doing this: We move ticks out of
+    (non-type) applications where we can, and make sure that we
+    annotate according to scoping rules when floating.
+
+13. Collect cost centres (including cost centres in unfoldings) if we're in
+    profiling mode. We have to do this here beucase we won't have unfoldings
+    after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules].
+
+This is all done modulo type applications and abstractions, so that
+when type erasure is done for conversion to STG, we don't end up with
+any trivial or useless bindings.
+
+
+Note [CorePrep invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is the syntax of the Core produced by CorePrep:
+
+    Trivial expressions
+       arg ::= lit |  var
+              | arg ty  |  /\a. arg
+              | truv co  |  /\c. arg  |  arg |> co
+
+    Applications
+       app ::= lit  |  var  |  app arg  |  app ty  | app co | app |> co
+
+    Expressions
+       body ::= app
+              | let(rec) x = rhs in body     -- Boxed only
+              | case body of pat -> body
+              | /\a. body | /\c. body
+              | body |> co
+
+    Right hand sides (only place where value lambdas can occur)
+       rhs ::= /\a.rhs  |  \x.rhs  |  body
+
+We define a synonym for each of these non-terminals.  Functions
+with the corresponding name produce a result in that syntax.
+-}
+
+type CpeArg  = CoreExpr    -- Non-terminal 'arg'
+type CpeApp  = CoreExpr    -- Non-terminal 'app'
+type CpeBody = CoreExpr    -- Non-terminal 'body'
+type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'
+
+{-
+************************************************************************
+*                                                                      *
+                Top level stuff
+*                                                                      *
+************************************************************************
+-}
+
+corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
+            -> IO (CoreProgram, S.Set CostCentre)
+corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
+    withTiming (pure dflags)
+               (text "CorePrep"<+>brackets (ppr this_mod))
+               (const ()) $ do
+    us <- mkSplitUniqSupply 's'
+    initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
+
+    let cost_centres
+          | WayProf `elem` ways dflags
+          = collectCostCentres this_mod binds
+          | otherwise
+          = S.empty
+
+        implicit_binds = mkDataConWorkers dflags mod_loc data_tycons
+            -- NB: we must feed mkImplicitBinds through corePrep too
+            -- so that they are suitably cloned and eta-expanded
+
+        binds_out = initUs_ us $ do
+                      floats1 <- corePrepTopBinds initialCorePrepEnv binds
+                      floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
+                      return (deFloatTop (floats1 `appendFloats` floats2))
+
+    endPassIO hsc_env alwaysQualify CorePrep binds_out []
+    return (binds_out, cost_centres)
+  where
+    dflags = hsc_dflags hsc_env
+
+corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
+corePrepExpr dflags hsc_env expr =
+    withTiming (pure dflags) (text "CorePrep [expr]") (const ()) $ do
+    us <- mkSplitUniqSupply 's'
+    initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
+    let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)
+    dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)
+    return new_expr
+
+corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats
+-- Note [Floating out of top level bindings]
+corePrepTopBinds initialCorePrepEnv binds
+  = go initialCorePrepEnv binds
+  where
+    go _   []             = return emptyFloats
+    go env (bind : binds) = do (env', floats, maybe_new_bind)
+                                 <- cpeBind TopLevel env bind
+                               MASSERT(isNothing maybe_new_bind)
+                                 -- Only join points get returned this way by
+                                 -- cpeBind, and no join point may float to top
+                               floatss <- go env' binds
+                               return (floats `appendFloats` floatss)
+
+mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]
+-- See Note [Data constructor workers]
+-- c.f. Note [Injecting implicit bindings] in TidyPgm
+mkDataConWorkers dflags mod_loc data_tycons
+  = [ NonRec id (tick_it (getName data_con) (Var id))
+                                -- The ice is thin here, but it works
+    | tycon <- data_tycons,     -- CorePrep will eta-expand it
+      data_con <- tyConDataCons tycon,
+      let id = dataConWorkId data_con
+    ]
+ where
+   -- If we want to generate debug info, we put a source note on the
+   -- worker. This is useful, especially for heap profiling.
+   tick_it name
+     | debugLevel dflags == 0                = id
+     | RealSrcSpan span <- nameSrcSpan name  = tick span
+     | Just file <- ml_hs_file mod_loc       = tick (span1 file)
+     | otherwise                             = tick (span1 "???")
+     where tick span  = Tick (SourceNote span $ showSDoc dflags (ppr name))
+           span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1
+
+{-
+Note [Floating out of top level bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+NB: we do need to float out of top-level bindings
+Consider        x = length [True,False]
+We want to get
+                s1 = False : []
+                s2 = True  : s1
+                x  = length s2
+
+We return a *list* of bindings, because we may start with
+        x* = f (g y)
+where x is demanded, in which case we want to finish with
+        a = g y
+        x* = f a
+And then x will actually end up case-bound
+
+Note [CafInfo and floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What happens when we try to float bindings to the top level?  At this
+point all the CafInfo is supposed to be correct, and we must make certain
+that is true of the new top-level bindings.  There are two cases
+to consider
+
+a) The top-level binding is marked asCafRefs.  In that case we are
+   basically fine.  The floated bindings had better all be lazy lets,
+   so they can float to top level, but they'll all have HasCafRefs
+   (the default) which is safe.
+
+b) The top-level binding is marked NoCafRefs.  This really happens
+   Example.  CoreTidy produces
+      $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah...
+   Now CorePrep has to eta-expand to
+      $fApplicativeSTM = let sat = \xy. retry x y
+                         in D:Alternative sat ...blah...
+   So what we *want* is
+      sat [NoCafRefs] = \xy. retry x y
+      $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah...
+
+   So, gruesomely, we must set the NoCafRefs flag on the sat bindings,
+   *and* substitute the modified 'sat' into the old RHS.
+
+   It should be the case that 'sat' is itself [NoCafRefs] (a value, no
+   cafs) else the original top-level binding would not itself have been
+   marked [NoCafRefs].  The DEBUG check in CoreToStg for
+   consistentCafInfo will find this.
+
+This is all very gruesome and horrible. It would be better to figure
+out CafInfo later, after CorePrep.  We'll do that in due course.
+Meanwhile this horrible hack works.
+
+Note [Join points and floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Join points can float out of other join points but not out of value bindings:
+
+  let z =
+    let  w = ... in -- can float
+    join k = ... in -- can't float
+    ... jump k ...
+  join j x1 ... xn =
+    let  y = ... in -- can float (but don't want to)
+    join h = ... in -- can float (but not much point)
+    ... jump h ...
+  in ...
+
+Here, the jump to h remains valid if h is floated outward, but the jump to k
+does not.
+
+We don't float *out* of join points. It would only be safe to float out of
+nullary join points (or ones where the arguments are all either type arguments
+or dead binders). Nullary join points aren't ever recursive, so they're always
+effectively one-shot functions, which we don't float out of. We *could* float
+join points from nullary join points, but there's no clear benefit at this
+stage.
+
+Note [Data constructor workers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Create any necessary "implicit" bindings for data con workers.  We
+create the rather strange (non-recursive!) binding
+
+        $wC = \x y -> $wC x y
+
+i.e. a curried constructor that allocates.  This means that we can
+treat the worker for a constructor like any other function in the rest
+of the compiler.  The point here is that CoreToStg will generate a
+StgConApp for the RHS, rather than a call to the worker (which would
+give a loop).  As Lennart says: the ice is thin here, but it works.
+
+Hmm.  Should we create bindings for dictionary constructors?  They are
+always fully applied, and the bindings are just there to support
+partial applications. But it's easier to let them through.
+
+
+Note [Dead code in CorePrep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Imagine that we got an input program like this (see Trac #4962):
+
+  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
+  f x = (g True (Just x) + g () (Just x), g)
+    where
+      g :: Show a => a -> Maybe Int -> Int
+      g _ Nothing = x
+      g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown
+
+After specialisation and SpecConstr, we would get something like this:
+
+  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)
+  f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)
+    where
+      {-# RULES g $dBool = g$Bool
+                g $dUnit = g$Unit #-}
+      g = ...
+      {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}
+      g$Bool = ...
+      {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}
+      g$Unit = ...
+      g$Bool_True_Just = ...
+      g$Unit_Unit_Just = ...
+
+Note that the g$Bool and g$Unit functions are actually dead code: they
+are only kept alive by the occurrence analyser because they are
+referred to by the rules of g, which is being kept alive by the fact
+that it is used (unspecialised) in the returned pair.
+
+However, at the CorePrep stage there is no way that the rules for g
+will ever fire, and it really seems like a shame to produce an output
+program that goes to the trouble of allocating a closure for the
+unreachable g$Bool and g$Unit functions.
+
+The way we fix this is to:
+ * In cloneBndr, drop all unfoldings/rules
+
+ * In deFloatTop, run a simple dead code analyser on each top-level
+   RHS to drop the dead local bindings. For that call to OccAnal, we
+   disable the binder swap, else the occurrence analyser sometimes
+   introduces new let bindings for cased binders, which lead to the bug
+   in #5433.
+
+The reason we don't just OccAnal the whole output of CorePrep is that
+the tidier ensures that all top-level binders are GlobalIds, so they
+don't show up in the free variables any longer. So if you run the
+occurrence analyser on the output of CoreTidy (or later) you e.g. turn
+this program:
+
+  Rec {
+  f = ... f ...
+  }
+
+Into this one:
+
+  f = ... f ...
+
+(Since f is not considered to be free in its own RHS.)
+
+
+************************************************************************
+*                                                                      *
+                The main code
+*                                                                      *
+************************************************************************
+-}
+
+cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind
+        -> UniqSM (CorePrepEnv,
+                   Floats,         -- Floating value bindings
+                   Maybe CoreBind) -- Just bind' <=> returned new bind; no float
+                                   -- Nothing <=> added bind' to floats instead
+cpeBind top_lvl env (NonRec bndr rhs)
+  | not (isJoinId bndr)
+  = do { (_, bndr1) <- cpCloneBndr env bndr
+       ; let dmd         = idDemandInfo bndr
+             is_unlifted = isUnliftedType (idType bndr)
+       ; (floats, rhs1) <- cpePair top_lvl NonRecursive
+                                   dmd is_unlifted
+                                   env bndr1 rhs
+       -- See Note [Inlining in CorePrep]
+       ; if exprIsTrivial rhs1 && isNotTopLevel top_lvl
+            then return (extendCorePrepEnvExpr env bndr rhs1, floats, Nothing)
+            else do {
+
+       ; let new_float = mkFloat dmd is_unlifted bndr1 rhs1
+
+       ; return (extendCorePrepEnv env bndr bndr1,
+                 addFloat floats new_float,
+                 Nothing) }}
+
+  | otherwise -- A join point; see Note [Join points and floating]
+  = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point
+    do { (_, bndr1) <- cpCloneBndr env bndr
+       ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs
+       ; return (extendCorePrepEnv env bndr bndr2,
+                 emptyFloats,
+                 Just (NonRec bndr2 rhs1)) }
+
+cpeBind top_lvl env (Rec pairs)
+  | not (isJoinId (head bndrs))
+  = do { (env', bndrs1) <- cpCloneBndrs env bndrs
+       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')
+                           bndrs1 rhss
+
+       ; let (floats_s, rhss1) = unzip stuff
+             all_pairs = foldrOL add_float (bndrs1 `zip` rhss1)
+                                           (concatFloats floats_s)
+
+       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),
+                 unitFloat (FloatLet (Rec all_pairs)),
+                 Nothing) }
+
+  | otherwise -- See Note [Join points and floating]
+  = do { (env', bndrs1) <- cpCloneBndrs env bndrs
+       ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss
+
+       ; let bndrs2 = map fst pairs1
+       ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2),
+                 emptyFloats,
+                 Just (Rec pairs1)) }
+  where
+    (bndrs, rhss) = unzip pairs
+
+        -- Flatten all the floats, and the current
+        -- group into a single giant Rec
+    add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2
+    add_float (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2
+    add_float b                       _    = pprPanic "cpeBind" (ppr b)
+
+---------------
+cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool
+        -> CorePrepEnv -> OutId -> CoreExpr
+        -> UniqSM (Floats, CpeRhs)
+-- Used for all bindings
+-- The binder is already cloned, hence an OutId
+cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
+  = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair
+    do { (floats1, rhs1) <- cpeRhsE env rhs
+
+       -- See if we are allowed to float this stuff out of the RHS
+       ; (floats2, rhs2) <- float_from_rhs floats1 rhs1
+
+       -- Make the arity match up
+       ; (floats3, rhs3)
+            <- if manifestArity rhs1 <= arity
+               then return (floats2, cpeEtaExpand arity rhs2)
+               else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
+                               -- Note [Silly extra arguments]
+                    (do { v <- newVar (idType bndr)
+                        ; let float = mkFloat topDmd False v rhs2
+                        ; return ( addFloat floats2 float
+                                 , cpeEtaExpand arity (Var v)) })
+
+        -- Wrap floating ticks
+       ; let (floats4, rhs4) = wrapTicks floats3 rhs3
+
+       ; return (floats4, rhs4) }
+  where
+    platform = targetPlatform (cpe_dynFlags env)
+
+    arity = idArity bndr        -- We must match this arity
+
+    ---------------------
+    float_from_rhs floats rhs
+      | isEmptyFloats floats = return (emptyFloats, rhs)
+      | isTopLevel top_lvl   = float_top    floats rhs
+      | otherwise            = float_nested floats rhs
+
+    ---------------------
+    float_nested floats rhs
+      | wantFloatNested is_rec dmd is_unlifted floats rhs
+                  = return (floats, rhs)
+      | otherwise = dontFloat floats rhs
+
+    ---------------------
+    float_top floats rhs        -- Urhgh!  See Note [CafInfo and floating]
+      | mayHaveCafRefs (idCafInfo bndr)
+      , allLazyTop floats
+      = return (floats, rhs)
+
+      -- So the top-level binding is marked NoCafRefs
+      | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs
+      = return (floats', rhs')
+
+      | otherwise
+      = dontFloat floats rhs
+
+dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)
+-- Non-empty floats, but do not want to float from rhs
+-- So wrap the rhs in the floats
+-- But: rhs1 might have lambdas, and we can't
+--      put them inside a wrapBinds
+dontFloat floats1 rhs
+  = do { (floats2, body) <- rhsToBody rhs
+        ; return (emptyFloats, wrapBinds floats1 $
+                               wrapBinds floats2 body) }
+
+{- Note [Silly extra arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we had this
+        f{arity=1} = \x\y. e
+We *must* match the arity on the Id, so we have to generate
+        f' = \x\y. e
+        f  = \x. f' x
+
+It's a bizarre case: why is the arity on the Id wrong?  Reason
+(in the days of __inline_me__):
+        f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
+When InlineMe notes go away this won't happen any more.  But
+it seems good for CorePrep to be robust.
+-}
+
+---------------
+cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr
+            -> UniqSM (JoinId, CpeRhs)
+-- Used for all join bindings
+cpeJoinPair env bndr rhs
+  = ASSERT(isJoinId bndr)
+    do { let Just join_arity = isJoinId_maybe bndr
+             (bndrs, body)   = collectNBinders join_arity rhs
+
+       ; (env', bndrs') <- cpCloneBndrs env bndrs
+
+       ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts
+                                      -- with a lambda
+
+       ; let rhs'  = mkCoreLams bndrs' body'
+             bndr' = bndr `setIdUnfolding` evaldUnfolding
+                          `setIdArity` count isId bndrs
+                            -- See Note [Arity and join points]
+
+       ; return (bndr', rhs') }
+
+{-
+Note [Arity and join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Up to now, we've allowed a join point to have an arity greater than its join
+arity (minus type arguments), since this is what's useful for eta expansion.
+However, for code gen purposes, its arity must be exactly the number of value
+arguments it will be called with, and it must have exactly that many value
+lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS:
+
+  join j x y z = \w -> ... in ...
+    =>
+  join j x y z = (let f = \w -> ... in f) in ...
+
+This is also what happens with Note [Silly extra arguments]. Note that it's okay
+for us to mess with the arity because a join point is never exported.
+-}
+
+-- ---------------------------------------------------------------------------
+--              CpeRhs: produces a result satisfying CpeRhs
+-- ---------------------------------------------------------------------------
+
+cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
+-- If
+--      e  ===>  (bs, e')
+-- then
+--      e = let bs in e'        (semantically, that is!)
+--
+-- For example
+--      f (g x)   ===>   ([v = g x], f v)
+
+cpeRhsE _env expr@(Type {})      = return (emptyFloats, expr)
+cpeRhsE _env expr@(Coercion {})  = return (emptyFloats, expr)
+cpeRhsE env (Lit (LitNumber LitNumInteger i _))
+    = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)
+                   (cpe_integerSDataCon env) i)
+cpeRhsE env (Lit (LitNumber LitNumNatural i _))
+    = cpeRhsE env (cvtLitNatural (cpe_dynFlags env) (getMkNaturalId env)
+                   (cpe_naturalSDataCon env) i)
+cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
+cpeRhsE env expr@(Var {})  = cpeApp env expr
+cpeRhsE env expr@(App {}) = cpeApp env expr
+
+cpeRhsE env (Let bind body)
+  = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind
+       ; (body_floats, body') <- cpeRhsE env' body
+       ; let expr' = case maybe_bind' of Just bind' -> Let bind' body'
+                                         Nothing    -> body'
+       ; return (bind_floats `appendFloats` body_floats, expr') }
+
+cpeRhsE env (Tick tickish expr)
+  | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope
+  = do { (floats, body) <- cpeRhsE env expr
+         -- See [Floating Ticks in CorePrep]
+       ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }
+  | otherwise
+  = do { body <- cpeBodyNF env expr
+       ; return (emptyFloats, mkTick tickish' body) }
+  where
+    tickish' | Breakpoint n fvs <- tickish
+             -- See also 'substTickish'
+             = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)
+             | otherwise
+             = tickish
+
+cpeRhsE env (Cast expr co)
+   = do { (floats, expr') <- cpeRhsE env expr
+        ; return (floats, Cast expr' co) }
+
+cpeRhsE env expr@(Lam {})
+   = do { let (bndrs,body) = collectBinders expr
+        ; (env', bndrs') <- cpCloneBndrs env bndrs
+        ; body' <- cpeBodyNF env' body
+        ; return (emptyFloats, mkLams bndrs' body') }
+
+cpeRhsE env (Case scrut bndr ty alts)
+  = do { (floats, scrut') <- cpeBody env scrut
+       ; (env', bndr2) <- cpCloneBndr env bndr
+       ; let alts'
+                 -- This flag is intended to aid in debugging strictness
+                 -- analysis bugs. These are particularly nasty to chase down as
+                 -- they may manifest as segmentation faults. When this flag is
+                 -- enabled we instead produce an 'error' expression to catch
+                 -- the case where a function we think should bottom
+                 -- unexpectedly returns.
+               | gopt Opt_CatchBottoms (cpe_dynFlags env)
+               , not (altsAreExhaustive alts)
+               = addDefault alts (Just err)
+               | otherwise = alts
+               where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty
+                                             "Bottoming expression returned"
+       ; alts'' <- mapM (sat_alt env') alts'
+       ; return (floats, Case scrut' bndr2 ty alts'') }
+  where
+    sat_alt env (con, bs, rhs)
+       = do { (env2, bs') <- cpCloneBndrs env bs
+            ; rhs' <- cpeBodyNF env2 rhs
+            ; return (con, bs', rhs') }
+
+cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr
+-- Here we convert a literal Integer to the low-level
+-- representation. Exactly how we do this depends on the
+-- library that implements Integer.  If it's GMP we
+-- use the S# data constructor for small literals.
+-- See Note [Integer literals] in Literal
+cvtLitInteger dflags _ (Just sdatacon) i
+  | inIntRange dflags i -- Special case for small integers
+    = mkConApp sdatacon [Lit (mkLitInt dflags i)]
+
+cvtLitInteger dflags mk_integer _ i
+    = mkApps (Var mk_integer) [isNonNegative, ints]
+  where isNonNegative = if i < 0 then mkConApp falseDataCon []
+                                 else mkConApp trueDataCon  []
+        ints = mkListExpr intTy (f (abs i))
+        f 0 = []
+        f x = let low  = x .&. mask
+                  high = x `shiftR` bits
+              in mkConApp intDataCon [Lit (mkLitInt dflags low)] : f high
+        bits = 31
+        mask = 2 ^ bits - 1
+
+cvtLitNatural :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr
+-- Here we convert a literal Natural to the low-level
+-- representation.
+-- See Note [Natural literals] in Literal
+cvtLitNatural dflags _ (Just sdatacon) i
+  | inWordRange dflags i -- Special case for small naturals
+    = mkConApp sdatacon [Lit (mkLitWord dflags i)]
+
+cvtLitNatural dflags mk_natural _ i
+    = mkApps (Var mk_natural) [words]
+  where words = mkListExpr wordTy (f i)
+        f 0 = []
+        f x = let low  = x .&. mask
+                  high = x `shiftR` bits
+              in mkConApp wordDataCon [Lit (mkLitWord dflags low)] : f high
+        bits = 32
+        mask = 2 ^ bits - 1
+
+-- ---------------------------------------------------------------------------
+--              CpeBody: produces a result satisfying CpeBody
+-- ---------------------------------------------------------------------------
+
+-- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without
+-- producing any floats (any generated floats are immediately
+-- let-bound using 'wrapBinds').  Generally you want this, esp.
+-- when you've reached a binding form (e.g., a lambda) and
+-- floating any further would be incorrect.
+cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody
+cpeBodyNF env expr
+  = do { (floats, body) <- cpeBody env expr
+       ; return (wrapBinds floats body) }
+
+-- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce
+-- a list of 'Floats' which are being propagated upwards.  In
+-- fact, this function is used in only two cases: to
+-- implement 'cpeBodyNF' (which is what you usually want),
+-- and in the case when a let-binding is in a case scrutinee--here,
+-- we can always float out:
+--
+--      case (let x = y in z) of ...
+--      ==> let x = y in case z of ...
+--
+cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)
+cpeBody env expr
+  = do { (floats1, rhs) <- cpeRhsE env expr
+       ; (floats2, body) <- rhsToBody rhs
+       ; return (floats1 `appendFloats` floats2, body) }
+
+--------
+rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
+-- Remove top level lambdas by let-binding
+
+rhsToBody (Tick t expr)
+  | tickishScoped t == NoScope  -- only float out of non-scoped annotations
+  = do { (floats, expr') <- rhsToBody expr
+       ; return (floats, mkTick t expr') }
+
+rhsToBody (Cast e co)
+        -- You can get things like
+        --      case e of { p -> coerce t (\s -> ...) }
+  = do { (floats, e') <- rhsToBody e
+       ; return (floats, Cast e' co) }
+
+rhsToBody expr@(Lam {})
+  | Just no_lam_result <- tryEtaReducePrep bndrs body
+  = return (emptyFloats, no_lam_result)
+  | all isTyVar bndrs           -- Type lambdas are ok
+  = return (emptyFloats, expr)
+  | otherwise                   -- Some value lambdas
+  = do { fn <- newVar (exprType expr)
+       ; let rhs   = cpeEtaExpand (exprArity expr) expr
+             float = FloatLet (NonRec fn rhs)
+       ; return (unitFloat float, Var fn) }
+  where
+    (bndrs,body) = collectBinders expr
+
+rhsToBody expr = return (emptyFloats, expr)
+
+
+
+-- ---------------------------------------------------------------------------
+--              CpeApp: produces a result satisfying CpeApp
+-- ---------------------------------------------------------------------------
+
+data ArgInfo = CpeApp  CoreArg
+             | CpeCast Coercion
+             | CpeTick (Tickish Id)
+
+{- Note [runRW arg]
+~~~~~~~~~~~~~~~~~~~
+If we got, say
+   runRW# (case bot of {})
+which happened in Trac #11291, we do /not/ want to turn it into
+   (case bot of {}) realWorldPrimId#
+because that gives a panic in CoreToStg.myCollectArgs, which expects
+only variables in function position.  But if we are sure to make
+runRW# strict (which we do in MkId), this can't happen
+-}
+
+cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
+-- May return a CpeRhs because of saturating primops
+cpeApp top_env expr
+  = do { let (terminal, args, depth) = collect_args expr
+       ; cpe_app top_env terminal args depth
+       }
+
+  where
+    -- We have a nested data structure of the form
+    -- e `App` a1 `App` a2 ... `App` an, convert it into
+    -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth)
+    -- We use 'ArgInfo' because we may also need to
+    -- record casts and ticks.  Depth counts the number
+    -- of arguments that would consume strictness information
+    -- (so, no type or coercion arguments.)
+    collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)
+    collect_args e = go e [] 0
+      where
+        go (App fun arg)      as !depth
+            = go fun (CpeApp arg : as)
+                (if isTyCoArg arg then depth else depth + 1)
+        go (Cast fun co)      as depth
+            = go fun (CpeCast co : as) depth
+        go (Tick tickish fun) as depth
+            | tickishPlace tickish == PlaceNonLam
+            && tickish `tickishScopesLike` SoftScope
+            = go fun (CpeTick tickish : as) depth
+        go terminal as depth = (terminal, as, depth)
+
+    cpe_app :: CorePrepEnv
+            -> CoreExpr
+            -> [ArgInfo]
+            -> Int
+            -> UniqSM (Floats, CpeRhs)
+    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth
+        | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and
+       || f `hasKey` noinlineIdKey      -- Replace (noinline a) with a
+        -- Consider the code:
+        --
+        --      lazy (f x) y
+        --
+        -- We need to make sure that we need to recursively collect arguments on
+        -- "f x", otherwise we'll float "f x" out (it's not a variable) and
+        -- end up with this awful -ddump-prep:
+        --
+        --      case f x of f_x {
+        --        __DEFAULT -> f_x y
+        --      }
+        --
+        -- rather than the far superior "f x y".  Test case is par01.
+        = let (terminal, args', depth') = collect_args arg
+          in cpe_app env terminal (args' ++ args) (depth + depth' - 1)
+    cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1
+        | f `hasKey` runRWKey
+        -- See Note [runRW magic]
+        -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this
+        -- is why we return a CorePrepEnv as well)
+        = case arg of
+            Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0
+            _          -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1
+    cpe_app env (Var v) args depth
+      = do { v1 <- fiddleCCall v
+           ; let e2 = lookupCorePrepEnv env v1
+                 hd = getIdFromTrivialExpr_maybe e2
+           -- NB: depth from collect_args is right, because e2 is a trivial expression
+           -- and thus its embedded Id *must* be at the same depth as any
+           -- Apps it is under are type applications only (c.f.
+           -- exprIsTrivial).  But note that we need the type of the
+           -- expression, not the id.
+           ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts
+           ; mb_saturate hd app floats depth }
+        where
+          stricts = case idStrictness v of
+                            StrictSig (DmdType _ demands _)
+                              | listLengthCmp demands depth /= GT -> demands
+                                    -- length demands <= depth
+                              | otherwise                         -> []
+                -- If depth < length demands, then we have too few args to
+                -- satisfy strictness  info so we have to  ignore all the
+                -- strictness info, e.g. + (error "urk")
+                -- Here, we can't evaluate the arg strictly, because this
+                -- partial application might be seq'd
+
+        -- We inlined into something that's not a var and has no args.
+        -- Bounce it back up to cpeRhsE.
+    cpe_app env fun [] _ = cpeRhsE env fun
+
+        -- N-variable fun, better let-bind it
+    cpe_app env fun args depth
+      = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty
+                          -- The evalDmd says that it's sure to be evaluated,
+                          -- so we'll end up case-binding it
+           ; (app, floats) <- rebuild_app args fun' ty fun_floats []
+           ; mb_saturate Nothing app floats depth }
+        where
+          ty = exprType fun
+
+    -- Saturate if necessary
+    mb_saturate head app floats depth =
+       case head of
+         Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth
+                          ; return (floats, sat_app) }
+         _other              -> return (floats, app)
+
+    -- Deconstruct and rebuild the application, floating any non-atomic
+    -- arguments to the outside.  We collect the type of the expression,
+    -- the head of the application, and the number of actual value arguments,
+    -- all of which are used to possibly saturate this application if it
+    -- has a constructor or primop at the head.
+    rebuild_app
+        :: [ArgInfo]                  -- The arguments (inner to outer)
+        -> CpeApp
+        -> Type
+        -> Floats
+        -> [Demand]
+        -> UniqSM (CpeApp, Floats)
+    rebuild_app [] app _ floats ss = do
+      MASSERT(null ss) -- make sure we used all the strictness info
+      return (app, floats)
+    rebuild_app (a : as) fun' fun_ty floats ss = case a of
+      CpeApp arg@(Type arg_ty) ->
+        rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss
+      CpeApp arg@(Coercion {}) ->
+        rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss
+      CpeApp arg -> do
+        let (ss1, ss_rest)  -- See Note [lazyId magic] in MkId
+               = case (ss, isLazyExpr arg) of
+                   (_   : ss_rest, True)  -> (topDmd, ss_rest)
+                   (ss1 : ss_rest, False) -> (ss1,    ss_rest)
+                   ([],            _)     -> (topDmd, [])
+            (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $
+                               splitFunTy_maybe fun_ty
+        (fs, arg') <- cpeArg top_env ss1 arg arg_ty
+        rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest
+      CpeCast co ->
+        let Pair _ty1 ty2 = coercionKind co
+        in rebuild_app as (Cast fun' co) ty2 floats ss
+      CpeTick tickish ->
+        -- See [Floating Ticks in CorePrep]
+        rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss
+
+isLazyExpr :: CoreExpr -> Bool
+-- See Note [lazyId magic] in MkId
+isLazyExpr (Cast e _)              = isLazyExpr e
+isLazyExpr (Tick _ e)              = isLazyExpr e
+isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey
+isLazyExpr _                       = False
+
+{- Note [runRW magic]
+~~~~~~~~~~~~~~~~~~~~~
+Some definitions, for instance @runST@, must have careful control over float out
+of the bindings in their body. Consider this use of @runST@,
+
+    f x = runST ( \ s -> let (a, s')  = newArray# 100 [] s
+                             (_, s'') = fill_in_array_or_something a x s'
+                         in freezeArray# a s'' )
+
+If we inline @runST@, we'll get:
+
+    f x = let (a, s')  = newArray# 100 [] realWorld#{-NB-}
+              (_, s'') = fill_in_array_or_something a x s'
+          in freezeArray# a s''
+
+And now if we allow the @newArray#@ binding to float out to become a CAF,
+we end up with a result that is totally and utterly wrong:
+
+    f = let (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!
+        in \ x ->
+            let (_, s'') = fill_in_array_or_something a x s'
+            in freezeArray# a s''
+
+All calls to @f@ will share a {\em single} array! Clearly this is nonsense and
+must be prevented.
+
+This is what @runRW#@ gives us: by being inlined extremely late in the
+optimization (right before lowering to STG, in CorePrep), we can ensure that
+no further floating will occur. This allows us to safely inline things like
+@runST@, which are otherwise needlessly expensive (see #10678 and #5916).
+
+'runRW' is defined (for historical reasons) in GHC.Magic, with a NOINLINE
+pragma.  It is levity-polymorphic.
+
+    runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)
+           => (State# RealWorld -> (# State# RealWorld, o #))
+                              -> (# State# RealWorld, o #)
+
+It needs no special treatment in GHC except this special inlining here
+in CorePrep (and in ByteCodeGen).
+
+-- ---------------------------------------------------------------------------
+--      CpeArg: produces a result satisfying CpeArg
+-- ---------------------------------------------------------------------------
+
+Note [ANF-ising literal string arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Consider a program like,
+
+    data Foo = Foo Addr#
+
+    foo = Foo "turtle"#
+
+When we go to ANFise this we might think that we want to float the string
+literal like we do any other non-trivial argument. This would look like,
+
+    foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s }
+
+However, this 1) isn't necessary since strings are in a sense "trivial"; and 2)
+wreaks havoc on the CAF annotations that we produce here since we the result
+above is caffy since it is updateable. Ideally at some point in the future we
+would like to just float the literal to the top level as suggested in #11312,
+
+    s = "turtle"#
+    foo = Foo s
+
+However, until then we simply add a special case excluding literals from the
+floating done by cpeArg.
+-}
+
+-- | Is an argument okay to CPE?
+okCpeArg :: CoreExpr -> Bool
+-- Don't float literals. See Note [ANF-ising literal string arguments].
+okCpeArg (Lit _) = False
+-- Do not eta expand a trivial argument
+okCpeArg expr    = not (exprIsTrivial expr)
+
+-- This is where we arrange that a non-trivial argument is let-bound
+cpeArg :: CorePrepEnv -> Demand
+       -> CoreArg -> Type -> UniqSM (Floats, CpeArg)
+cpeArg env dmd arg arg_ty
+  = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda
+       ; (floats2, arg2) <- if want_float floats1 arg1
+                            then return (floats1, arg1)
+                            else dontFloat floats1 arg1
+                -- Else case: arg1 might have lambdas, and we can't
+                --            put them inside a wrapBinds
+
+       ; if okCpeArg arg2
+         then do { v <- newVar arg_ty
+                 ; let arg3      = cpeEtaExpand (exprArity arg2) arg2
+                       arg_float = mkFloat dmd is_unlifted v arg3
+                 ; return (addFloat floats2 arg_float, varToCoreExpr v) }
+         else return (floats2, arg2)
+       }
+  where
+    is_unlifted = isUnliftedType arg_ty
+    want_float  = wantFloatNested NonRecursive dmd is_unlifted
+
+{-
+Note [Floating unlifted arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider    C (let v* = expensive in v)
+
+where the "*" indicates "will be demanded".  Usually v will have been
+inlined by now, but let's suppose it hasn't (see Trac #2756).  Then we
+do *not* want to get
+
+     let v* = expensive in C v
+
+because that has different strictness.  Hence the use of 'allLazy'.
+(NB: the let v* turns into a FloatCase, in mkLocalNonRec.)
+
+
+------------------------------------------------------------------------------
+-- Building the saturated syntax
+-- ---------------------------------------------------------------------------
+
+maybeSaturate deals with saturating primops and constructors
+The type is the type of the entire application
+-}
+
+maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs
+maybeSaturate fn expr n_args
+  | hasNoBinding fn        -- There's no binding
+  = return sat_expr
+
+  | otherwise
+  = return expr
+  where
+    fn_arity     = idArity fn
+    excess_arity = fn_arity - n_args
+    sat_expr     = cpeEtaExpand excess_arity expr
+
+{-
+************************************************************************
+*                                                                      *
+                Simple CoreSyn operations
+*                                                                      *
+************************************************************************
+-}
+
+{-
+-- -----------------------------------------------------------------------------
+--      Eta reduction
+-- -----------------------------------------------------------------------------
+
+Note [Eta expansion]
+~~~~~~~~~~~~~~~~~~~~~
+Eta expand to match the arity claimed by the binder Remember,
+CorePrep must not change arity
+
+Eta expansion might not have happened already, because it is done by
+the simplifier only when there at least one lambda already.
+
+NB1:we could refrain when the RHS is trivial (which can happen
+    for exported things).  This would reduce the amount of code
+    generated (a little) and make things a little words for
+    code compiled without -O.  The case in point is data constructor
+    wrappers.
+
+NB2: we have to be careful that the result of etaExpand doesn't
+   invalidate any of the assumptions that CorePrep is attempting
+   to establish.  One possible cause is eta expanding inside of
+   an SCC note - we're now careful in etaExpand to make sure the
+   SCC is pushed inside any new lambdas that are generated.
+
+Note [Eta expansion and the CorePrep invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It turns out to be much much easier to do eta expansion
+*after* the main CorePrep stuff.  But that places constraints
+on the eta expander: given a CpeRhs, it must return a CpeRhs.
+
+For example here is what we do not want:
+                f = /\a -> g (h 3)      -- h has arity 2
+After ANFing we get
+                f = /\a -> let s = h 3 in g s
+and now we do NOT want eta expansion to give
+                f = /\a -> \ y -> (let s = h 3 in g s) y
+
+Instead CoreArity.etaExpand gives
+                f = /\a -> \y -> let s = h 3 in g s y
+-}
+
+cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
+cpeEtaExpand arity expr
+  | arity == 0 = expr
+  | otherwise  = etaExpand arity expr
+
+{-
+-- -----------------------------------------------------------------------------
+--      Eta reduction
+-- -----------------------------------------------------------------------------
+
+Why try eta reduction?  Hasn't the simplifier already done eta?
+But the simplifier only eta reduces if that leaves something
+trivial (like f, or f Int).  But for deLam it would be enough to
+get to a partial application:
+        case x of { p -> \xs. map f xs }
+    ==> case x of { p -> map f }
+-}
+
+tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr
+tryEtaReducePrep bndrs expr@(App _ _)
+  | ok_to_eta_reduce f
+  , n_remaining >= 0
+  , and (zipWith ok bndrs last_args)
+  , not (any (`elemVarSet` fvs_remaining) bndrs)
+  , exprIsHNF remaining_expr   -- Don't turn value into a non-value
+                               -- else the behaviour with 'seq' changes
+  = Just remaining_expr
+  where
+    (f, args) = collectArgs expr
+    remaining_expr = mkApps f remaining_args
+    fvs_remaining = exprFreeVars remaining_expr
+    (remaining_args, last_args) = splitAt n_remaining args
+    n_remaining = length args - length bndrs
+
+    ok bndr (Var arg) = bndr == arg
+    ok _    _         = False
+
+          -- We can't eta reduce something which must be saturated.
+    ok_to_eta_reduce (Var f) = not (hasNoBinding f)
+    ok_to_eta_reduce _       = False -- Safe. ToDo: generalise
+
+tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
+  | not (any (`elemVarSet` fvs) bndrs)
+  = case tryEtaReducePrep bndrs body of
+        Just e -> Just (Let bind e)
+        Nothing -> Nothing
+  where
+    fvs = exprFreeVars r
+
+-- NB: do not attempt to eta-reduce across ticks
+-- Otherwise we risk reducing
+--       \x. (Tick (Breakpoint {x}) f x)
+--   ==> Tick (breakpoint {x}) f
+-- which is bogus (Trac #17228)
+-- tryEtaReducePrep bndrs (Tick tickish e)
+--   = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e
+
+tryEtaReducePrep _ _ = Nothing
+
+{-
+************************************************************************
+*                                                                      *
+                Floats
+*                                                                      *
+************************************************************************
+
+Note [Pin demand info on floats]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We pin demand info on floated lets, so that we can see the one-shot thunks.
+-}
+
+data FloatingBind
+  = FloatLet CoreBind    -- Rhs of bindings are CpeRhss
+                         -- They are always of lifted type;
+                         -- unlifted ones are done with FloatCase
+
+ | FloatCase
+      Id CpeBody
+      Bool              -- The bool indicates "ok-for-speculation"
+
+ -- | See Note [Floating Ticks in CorePrep]
+ | FloatTick (Tickish Id)
+
+data Floats = Floats OkToSpec (OrdList FloatingBind)
+
+instance Outputable FloatingBind where
+  ppr (FloatLet b) = ppr b
+  ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
+  ppr (FloatTick t) = ppr t
+
+instance Outputable Floats where
+  ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+>
+                         braces (vcat (map ppr (fromOL fs)))
+
+instance Outputable OkToSpec where
+  ppr OkToSpec    = text "OkToSpec"
+  ppr IfUnboxedOk = text "IfUnboxedOk"
+  ppr NotOkToSpec = text "NotOkToSpec"
+
+-- Can we float these binds out of the rhs of a let?  We cache this decision
+-- to avoid having to recompute it in a non-linear way when there are
+-- deeply nested lets.
+data OkToSpec
+   = OkToSpec           -- Lazy bindings of lifted type
+   | IfUnboxedOk        -- A mixture of lazy lifted bindings and n
+                        -- ok-to-speculate unlifted bindings
+   | NotOkToSpec        -- Some not-ok-to-speculate unlifted bindings
+
+mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind
+mkFloat dmd is_unlifted bndr rhs
+  | use_case  = FloatCase bndr rhs (exprOkForSpeculation rhs)
+  | is_hnf    = FloatLet (NonRec bndr                       rhs)
+  | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)
+                   -- See Note [Pin demand info on floats]
+  where
+    is_hnf    = exprIsHNF rhs
+    is_strict = isStrictDmd dmd
+    use_case  = is_unlifted || is_strict && not is_hnf
+                -- Don't make a case for a value binding,
+                -- even if it's strict.  Otherwise we get
+                --      case (\x -> e) of ...!
+
+emptyFloats :: Floats
+emptyFloats = Floats OkToSpec nilOL
+
+isEmptyFloats :: Floats -> Bool
+isEmptyFloats (Floats _ bs) = isNilOL bs
+
+wrapBinds :: Floats -> CpeBody -> CpeBody
+wrapBinds (Floats _ binds) body
+  = foldrOL mk_bind body binds
+  where
+    mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
+    mk_bind (FloatLet bind)        body = Let bind body
+    mk_bind (FloatTick tickish)    body = mkTick tickish body
+
+addFloat :: Floats -> FloatingBind -> Floats
+addFloat (Floats ok_to_spec floats) new_float
+  = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)
+  where
+    check (FloatLet _) = OkToSpec
+    check (FloatCase _ _ ok_for_spec)
+        | ok_for_spec  =  IfUnboxedOk
+        | otherwise    =  NotOkToSpec
+    check FloatTick{}  = OkToSpec
+        -- The ok-for-speculation flag says that it's safe to
+        -- float this Case out of a let, and thereby do it more eagerly
+        -- We need the top-level flag because it's never ok to float
+        -- an unboxed binding to the top level
+
+unitFloat :: FloatingBind -> Floats
+unitFloat = addFloat emptyFloats
+
+appendFloats :: Floats -> Floats -> Floats
+appendFloats (Floats spec1 floats1) (Floats spec2 floats2)
+  = Floats (combine spec1 spec2) (floats1 `appOL` floats2)
+
+concatFloats :: [Floats] -> OrdList FloatingBind
+concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL
+
+combine :: OkToSpec -> OkToSpec -> OkToSpec
+combine NotOkToSpec _ = NotOkToSpec
+combine _ NotOkToSpec = NotOkToSpec
+combine IfUnboxedOk _ = IfUnboxedOk
+combine _ IfUnboxedOk = IfUnboxedOk
+combine _ _           = OkToSpec
+
+deFloatTop :: Floats -> [CoreBind]
+-- For top level only; we don't expect any FloatCases
+deFloatTop (Floats _ floats)
+  = foldrOL get [] floats
+  where
+    get (FloatLet b) bs = occurAnalyseRHSs b : bs
+    get (FloatCase var body _) bs  =
+      occurAnalyseRHSs (NonRec var body) : bs
+    get b _ = pprPanic "corePrepPgm" (ppr b)
+
+    -- See Note [Dead code in CorePrep]
+    occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)
+    occurAnalyseRHSs (Rec xes)    = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes]
+
+---------------------------------------------------------------------------
+
+canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
+       -- Note [CafInfo and floating]
+canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
+  | OkToSpec <- ok_to_spec           -- Worth trying
+  , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)
+  = Just (Floats OkToSpec fs', subst_expr subst rhs)
+  | otherwise
+  = Nothing
+  where
+    subst_expr = substExpr (text "CorePrep")
+
+    go :: (Subst, OrdList FloatingBind) -> [FloatingBind]
+       -> Maybe (Subst, OrdList FloatingBind)
+
+    go (subst, fbs_out) [] = Just (subst, fbs_out)
+
+    go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)
+      | rhs_ok r
+      = go (subst', fbs_out `snocOL` new_fb) fbs_in
+      where
+        (subst', b') = set_nocaf_bndr subst b
+        new_fb = FloatLet (NonRec b' (subst_expr subst r))
+
+    go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)
+      | all rhs_ok rs
+      = go (subst', fbs_out `snocOL` new_fb) fbs_in
+      where
+        (bs,rs) = unzip prs
+        (subst', bs') = mapAccumL set_nocaf_bndr subst bs
+        rs' = map (subst_expr subst') rs
+        new_fb = FloatLet (Rec (bs' `zip` rs'))
+
+    go (subst, fbs_out) (ft@FloatTick{} : fbs_in)
+      = go (subst, fbs_out `snocOL` ft) fbs_in
+
+    go _ _ = Nothing      -- Encountered a caffy binding
+
+    ------------
+    set_nocaf_bndr subst bndr
+      = (extendIdSubst subst bndr (Var bndr'), bndr')
+      where
+        bndr' = bndr `setIdCafInfo` NoCafRefs
+
+    ------------
+    rhs_ok :: CoreExpr -> Bool
+    -- We can only float to top level from a NoCaf thing if
+    -- the new binding is static. However it can't mention
+    -- any non-static things or it would *already* be Caffy
+    rhs_ok = rhsIsStatic platform (\_ -> False)
+                         (\_nt i -> pprPanic "rhsIsStatic" (integer i))
+                         -- Integer or Natural literals should not show up
+
+wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
+wantFloatNested is_rec dmd is_unlifted floats rhs
+  =  isEmptyFloats floats
+  || isStrictDmd dmd
+  || is_unlifted
+  || (allLazyNested is_rec floats && exprIsHNF rhs)
+        -- Why the test for allLazyNested?
+        --      v = f (x `divInt#` y)
+        -- we don't want to float the case, even if f has arity 2,
+        -- because floating the case would make it evaluated too early
+
+allLazyTop :: Floats -> Bool
+allLazyTop (Floats OkToSpec _) = True
+allLazyTop _                   = False
+
+allLazyNested :: RecFlag -> Floats -> Bool
+allLazyNested _      (Floats OkToSpec    _) = True
+allLazyNested _      (Floats NotOkToSpec _) = False
+allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec
+
+{-
+************************************************************************
+*                                                                      *
+                Cloning
+*                                                                      *
+************************************************************************
+-}
+
+-- ---------------------------------------------------------------------------
+--                      The environment
+-- ---------------------------------------------------------------------------
+
+-- Note [Inlining in CorePrep]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- There is a subtle but important invariant that must be upheld in the output
+-- of CorePrep: there are no "trivial" updatable thunks.  Thus, this Core
+-- is impermissible:
+--
+--      let x :: ()
+--          x = y
+--
+-- (where y is a reference to a GLOBAL variable).  Thunks like this are silly:
+-- they can always be profitably replaced by inlining x with y. Consequently,
+-- the code generator/runtime does not bother implementing this properly
+-- (specifically, there is no implementation of stg_ap_0_upd_info, which is the
+-- stack frame that would be used to update this thunk.  The "0" means it has
+-- zero free variables.)
+--
+-- In general, the inliner is good at eliminating these let-bindings.  However,
+-- there is one case where these trivial updatable thunks can arise: when
+-- we are optimizing away 'lazy' (see Note [lazyId magic], and also
+-- 'cpeRhsE'.)  Then, we could have started with:
+--
+--      let x :: ()
+--          x = lazy @ () y
+--
+-- which is a perfectly fine, non-trivial thunk, but then CorePrep will
+-- drop 'lazy', giving us 'x = y' which is trivial and impermissible.
+-- The solution is CorePrep to have a miniature inlining pass which deals
+-- with cases like this.  We can then drop the let-binding altogether.
+--
+-- Why does the removal of 'lazy' have to occur in CorePrep?
+-- The gory details are in Note [lazyId magic] in MkId, but the
+-- main reason is that lazy must appear in unfoldings (optimizer
+-- output) and it must prevent call-by-value for catch# (which
+-- is implemented by CorePrep.)
+--
+-- An alternate strategy for solving this problem is to have the
+-- inliner treat 'lazy e' as a trivial expression if 'e' is trivial.
+-- We decided not to adopt this solution to keep the definition
+-- of 'exprIsTrivial' simple.
+--
+-- There is ONE caveat however: for top-level bindings we have
+-- to preserve the binding so that we float the (hacky) non-recursive
+-- binding for data constructors; see Note [Data constructor workers].
+--
+-- Note [CorePrep inlines trivial CoreExpr not Id]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an
+-- IdEnv Id?  Naively, we might conjecture that trivial updatable thunks
+-- as per Note [Inlining in CorePrep] always have the form
+-- 'lazy @ SomeType gbl_id'.  But this is not true: the following is
+-- perfectly reasonable Core:
+--
+--      let x :: ()
+--          x = lazy @ (forall a. a) y @ Bool
+--
+-- When we inline 'x' after eliminating 'lazy', we need to replace
+-- occurrences of 'x' with 'y @ bool', not just 'y'.  Situations like
+-- this can easily arise with higher-rank types; thus, cpe_env must
+-- map to CoreExprs, not Ids.
+
+data CorePrepEnv
+  = CPE { cpe_dynFlags        :: DynFlags
+        , cpe_env             :: IdEnv CoreExpr   -- Clone local Ids
+        -- ^ This environment is used for three operations:
+        --
+        --      1. To support cloning of local Ids so that they are
+        --      all unique (see item (6) of CorePrep overview).
+        --
+        --      2. To support beta-reduction of runRW, see
+        --      Note [runRW magic] and Note [runRW arg].
+        --
+        --      3. To let us inline trivial RHSs of non top-level let-bindings,
+        --      see Note [lazyId magic], Note [Inlining in CorePrep]
+        --      and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
+        , cpe_mkIntegerId     :: Id
+        , cpe_mkNaturalId     :: Id
+        , cpe_integerSDataCon :: Maybe DataCon
+        , cpe_naturalSDataCon :: Maybe DataCon
+    }
+
+lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
+lookupMkIntegerName dflags hsc_env
+    = guardIntegerUse dflags $ liftM tyThingId $
+      lookupGlobal hsc_env mkIntegerName
+
+lookupMkNaturalName :: DynFlags -> HscEnv -> IO Id
+lookupMkNaturalName dflags hsc_env
+    = guardNaturalUse dflags $ liftM tyThingId $
+      lookupGlobal hsc_env mkNaturalName
+
+-- See Note [The integer library] in PrelNames
+lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
+lookupIntegerSDataConName dflags hsc_env = case integerLibrary dflags of
+    IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $
+                  lookupGlobal hsc_env integerSDataConName
+    IntegerSimple -> return Nothing
+
+lookupNaturalSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
+lookupNaturalSDataConName dflags hsc_env = case integerLibrary dflags of
+    IntegerGMP -> guardNaturalUse dflags $ liftM (Just . tyThingDataCon) $
+                  lookupGlobal hsc_env naturalSDataConName
+    IntegerSimple -> return Nothing
+
+-- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName'
+guardIntegerUse :: DynFlags -> IO a -> IO a
+guardIntegerUse dflags act
+  | thisPackage dflags == primUnitId
+  = return $ panic "Can't use Integer in ghc-prim"
+  | thisPackage dflags == integerUnitId
+  = return $ panic "Can't use Integer in integer-*"
+  | otherwise = act
+
+-- | Helper for 'lookupMkNaturalName', 'lookupNaturalSDataConName'
+--
+-- Just like we can't use Integer literals in `integer-*`, we can't use Natural
+-- literals in `base`. If we do, we get interface loading error for GHC.Natural.
+guardNaturalUse :: DynFlags -> IO a -> IO a
+guardNaturalUse dflags act
+  | thisPackage dflags == primUnitId
+  = return $ panic "Can't use Natural in ghc-prim"
+  | thisPackage dflags == integerUnitId
+  = return $ panic "Can't use Natural in integer-*"
+  | thisPackage dflags == baseUnitId
+  = return $ panic "Can't use Natural in base"
+  | otherwise = act
+
+mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
+mkInitialCorePrepEnv dflags hsc_env
+    = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
+         mkNaturalId <- lookupMkNaturalName dflags hsc_env
+         integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
+         naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env
+         return $ CPE {
+                      cpe_dynFlags = dflags,
+                      cpe_env = emptyVarEnv,
+                      cpe_mkIntegerId = mkIntegerId,
+                      cpe_mkNaturalId = mkNaturalId,
+                      cpe_integerSDataCon = integerSDataCon,
+                      cpe_naturalSDataCon = naturalSDataCon
+                  }
+
+extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
+extendCorePrepEnv cpe id id'
+    = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }
+
+extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv
+extendCorePrepEnvExpr cpe id expr
+    = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr }
+
+extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv
+extendCorePrepEnvList cpe prs
+    = cpe { cpe_env = extendVarEnvList (cpe_env cpe)
+                        (map (\(id, id') -> (id, Var id')) prs) }
+
+lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr
+lookupCorePrepEnv cpe id
+  = case lookupVarEnv (cpe_env cpe) id of
+        Nothing  -> Var id
+        Just exp -> exp
+
+getMkIntegerId :: CorePrepEnv -> Id
+getMkIntegerId = cpe_mkIntegerId
+
+getMkNaturalId :: CorePrepEnv -> Id
+getMkNaturalId = cpe_mkNaturalId
+
+------------------------------------------------------------------------------
+-- Cloning binders
+-- ---------------------------------------------------------------------------
+
+cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])
+cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs
+
+cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)
+cpCloneBndr env bndr
+  | not (isId bndr)
+  = return (env, bndr)
+
+  | otherwise
+  = do { bndr' <- clone_it bndr
+
+       -- Drop (now-useless) rules/unfoldings
+       -- See Note [Drop unfoldings and rules]
+       -- and Note [Preserve evaluatedness] in CoreTidy
+       ; let unfolding' = zapUnfolding (realIdUnfolding bndr)
+                          -- Simplifier will set the Id's unfolding
+
+             bndr'' = bndr' `setIdUnfolding`      unfolding'
+                            `setIdSpecialisation` emptyRuleInfo
+
+       ; return (extendCorePrepEnv env bndr bndr'', bndr'') }
+  where
+    clone_it bndr
+      | isLocalId bndr, not (isCoVar bndr)
+      = do { uniq <- getUniqueM; return (setVarUnique bndr uniq) }
+      | otherwise   -- Top level things, which we don't want
+                    -- to clone, have become GlobalIds by now
+                    -- And we don't clone tyvars, or coercion variables
+      = return bndr
+
+{- Note [Drop unfoldings and rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to drop the unfolding/rules on every Id:
+
+  - We are now past interface-file generation, and in the
+    codegen pipeline, so we really don't need full unfoldings/rules
+
+  - The unfolding/rule may be keeping stuff alive that we'd like
+    to discard.  See  Note [Dead code in CorePrep]
+
+  - Getting rid of unnecessary unfoldings reduces heap usage
+
+  - We are changing uniques, so if we didn't discard unfoldings/rules
+    we'd have to substitute in them
+
+HOWEVER, we want to preserve evaluated-ness;
+see Note [Preserve evaluatedness] in CoreTidy.
+-}
+
+------------------------------------------------------------------------------
+-- Cloning ccall Ids; each must have a unique name,
+-- to give the code generator a handle to hang it on
+-- ---------------------------------------------------------------------------
+
+fiddleCCall :: Id -> UniqSM Id
+fiddleCCall id
+  | isFCallId id = (id `setVarUnique`) <$> getUniqueM
+  | otherwise    = return id
+
+------------------------------------------------------------------------------
+-- Generating new binders
+-- ---------------------------------------------------------------------------
+
+newVar :: Type -> UniqSM Id
+newVar ty
+ = seqType ty `seq` do
+     uniq <- getUniqueM
+     return (mkSysLocalOrCoVar (fsLit "sat") uniq ty)
+
+
+------------------------------------------------------------------------------
+-- Floating ticks
+-- ---------------------------------------------------------------------------
+--
+-- Note [Floating Ticks in CorePrep]
+--
+-- It might seem counter-intuitive to float ticks by default, given
+-- that we don't actually want to move them if we can help it. On the
+-- other hand, nothing gets very far in CorePrep anyway, and we want
+-- to preserve the order of let bindings and tick annotations in
+-- relation to each other. For example, if we just wrapped let floats
+-- when they pass through ticks, we might end up performing the
+-- following transformation:
+--
+--   src<...> let foo = bar in baz
+--   ==>  let foo = src<...> bar in src<...> baz
+--
+-- Because the let-binding would float through the tick, and then
+-- immediately materialize, achieving nothing but decreasing tick
+-- accuracy. The only special case is the following scenario:
+--
+--   let foo = src<...> (let a = b in bar) in baz
+--   ==>  let foo = src<...> bar; a = src<...> b in baz
+--
+-- Here we would not want the source tick to end up covering "baz" and
+-- therefore refrain from pushing ticks outside. Instead, we copy them
+-- into the floating binds (here "a") in cpePair. Note that where "b"
+-- or "bar" are (value) lambdas we have to push the annotations
+-- further inside in order to uphold our rules.
+--
+-- All of this is implemented below in @wrapTicks@.
+
+-- | Like wrapFloats, but only wraps tick floats
+wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
+wrapTicks (Floats flag floats0) expr =
+    (Floats flag (toOL $ reverse floats1), foldr mkTick expr (reverse ticks1))
+  where (floats1, ticks1) = foldlOL go ([], []) $ floats0
+        -- Deeply nested constructors will produce long lists of
+        -- redundant source note floats here. We need to eliminate
+        -- those early, as relying on mkTick to spot it after the fact
+        -- can yield O(n^3) complexity [#11095]
+        go (floats, ticks) (FloatTick t)
+          = ASSERT(tickishPlace t == PlaceNonLam)
+            (floats, if any (flip tickishContains t) ticks
+                     then ticks else t:ticks)
+        go (floats, ticks) f
+          = (foldr wrap f (reverse ticks):floats, ticks)
+
+        wrap t (FloatLet bind)    = FloatLet (wrapBind t bind)
+        wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok
+        wrap _ other              = pprPanic "wrapTicks: unexpected float!"
+                                             (ppr other)
+        wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
+        wrapBind t (Rec pairs)         = Rec (mapSnd (mkTick t) pairs)
+
+------------------------------------------------------------------------------
+-- Collecting cost centres
+-- ---------------------------------------------------------------------------
+
+-- | Collect cost centres defined in the current module, including those in
+-- unfoldings.
+collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre
+collectCostCentres mod_name
+  = foldl' go_bind S.empty
+  where
+    go cs e = case e of
+      Var{} -> cs
+      Lit{} -> cs
+      App e1 e2 -> go (go cs e1) e2
+      Lam _ e -> go cs e
+      Let b e -> go (go_bind cs b) e
+      Case scrt _ _ alts -> go_alts (go cs scrt) alts
+      Cast e _ -> go cs e
+      Tick (ProfNote cc _ _) e ->
+        go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e
+      Tick _ e -> go cs e
+      Type{} -> cs
+      Coercion{} -> cs
+
+    go_alts = foldl' (\cs (_con, _bndrs, e) -> go cs e)
+
+    go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre
+    go_bind cs (NonRec b e) =
+      go (maybe cs (go cs) (get_unf b)) e
+    go_bind cs (Rec bs) =
+      foldl' (\cs' (b, e) -> go (maybe cs' (go cs') (get_unf b)) e) cs bs
+
+    -- Unfoldings may have cost centres that in the original definion are
+    -- optimized away, see #5889.
+    get_unf = maybeUnfoldingTemplate . realIdUnfolding
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/Check.hs
@@ -0,0 +1,2712 @@
+{-
+Author: George Karachalias <george.karachalias@cs.kuleuven.be>
+
+Pattern Matching Coverage Checking.
+-}
+
+{-# LANGUAGE CPP, GADTs, DataKinds, KindSignatures #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns  #-}
+
+module Check (
+        -- Checking and printing
+        checkSingle, checkMatches, checkGuardMatches, isAnyPmCheckEnabled,
+
+        -- See Note [Type and Term Equality Propagation]
+        genCaseTmCs1, genCaseTmCs2
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TmOracle
+import Unify( tcMatchTy )
+import DynFlags
+import HsSyn
+import TcHsSyn
+import Id
+import ConLike
+import Name
+import FamInstEnv
+import TysPrim (tYPETyCon)
+import TysWiredIn
+import TyCon
+import SrcLoc
+import Util
+import Outputable
+import FastString
+import DataCon
+import PatSyn
+import HscTypes (CompleteMatch(..))
+
+import DsMonad
+import TcSimplify    (tcCheckSatisfiability)
+import TcType        (isStringTy)
+import Bag
+import ErrUtils
+import Var           (EvVar)
+import TyCoRep
+import Type
+import UniqSupply
+import DsUtils       (isTrueLHsExpr)
+import Maybes        (expectJust)
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.List     (find)
+import Data.Maybe    (catMaybes, isJust, fromMaybe)
+import Control.Monad (forM, when, forM_, zipWithM)
+import Coercion
+import TcEvidence
+import TcSimplify    (tcNormalise)
+import IOEnv
+import qualified Data.Semigroup as Semi
+
+import ListT (ListT(..), fold, select)
+
+{-
+This module checks pattern matches for:
+\begin{enumerate}
+  \item Equations that are redundant
+  \item Equations with inaccessible right-hand-side
+  \item Exhaustiveness
+\end{enumerate}
+
+The algorithm is based on the paper:
+
+  "GADTs Meet Their Match:
+     Pattern-matching Warnings That Account for GADTs, Guards, and Laziness"
+
+    http://people.cs.kuleuven.be/~george.karachalias/papers/p424-karachalias.pdf
+
+%************************************************************************
+%*                                                                      *
+                     Pattern Match Check Types
+%*                                                                      *
+%************************************************************************
+-}
+
+-- We use the non-determinism monad to apply the algorithm to several
+-- possible sets of constructors. Users can specify complete sets of
+-- constructors by using COMPLETE pragmas.
+-- The algorithm only picks out constructor
+-- sets deep in the bowels which makes a simpler `mapM` more difficult to
+-- implement. The non-determinism is only used in one place, see the ConVar
+-- case in `pmCheckHd`.
+
+type PmM a = ListT DsM a
+
+liftD :: DsM a -> PmM a
+liftD m = ListT $ \sk fk -> m >>= \a -> sk a fk
+
+-- Pick the first match complete covered match or otherwise the "best" match.
+-- The best match is the one with the least uncovered clauses, ties broken
+-- by the number of inaccessible clauses followed by number of redundant
+-- clauses.
+--
+-- This is specified in the
+-- "Disambiguating between multiple ``COMPLETE`` pragmas" section of the
+-- users' guide. If you update the implementation of this function, make sure
+-- to update that section of the users' guide as well.
+getResult :: PmM PmResult -> DsM PmResult
+getResult ls
+  = do { res <- fold ls goM (pure Nothing)
+       ; case res of
+            Nothing -> panic "getResult is empty"
+            Just a  -> return a }
+  where
+    goM :: PmResult -> DsM (Maybe PmResult) -> DsM (Maybe PmResult)
+    goM mpm dpm = do { pmr <- dpm
+                     ; return $ Just $ go pmr mpm }
+
+    -- Careful not to force unecessary results
+    go :: Maybe PmResult -> PmResult -> PmResult
+    go Nothing rs = rs
+    go (Just old@(PmResult prov rs (UncoveredPatterns us) is)) new
+      | null us && null rs && null is = old
+      | otherwise =
+        let PmResult prov' rs' (UncoveredPatterns us') is' = new
+        in case compareLength us us'
+                `mappend` (compareLength is is')
+                `mappend` (compareLength rs rs')
+                `mappend` (compare prov prov') of
+              GT  -> new
+              EQ  -> new
+              LT  -> old
+    go (Just (PmResult _ _ (TypeOfUncovered _) _)) _new
+      = panic "getResult: No inhabitation candidates"
+
+data PatTy = PAT | VA -- Used only as a kind, to index PmPat
+
+-- The *arity* of a PatVec [p1,..,pn] is
+-- the number of p1..pn that are not Guards
+
+data PmPat :: PatTy -> * where
+  PmCon  :: { pm_con_con     :: ConLike
+            , pm_con_arg_tys :: [Type]
+            , pm_con_tvs     :: [TyVar]
+            , pm_con_dicts   :: [EvVar]
+            , pm_con_args    :: [PmPat t] } -> PmPat t
+            -- For PmCon arguments' meaning see @ConPatOut@ in hsSyn/HsPat.hs
+  PmVar  :: { pm_var_id   :: Id } -> PmPat t
+  PmLit  :: { pm_lit_lit  :: PmLit } -> PmPat t -- See Note [Literals in PmPat]
+  PmNLit :: { pm_lit_id   :: Id
+            , pm_lit_not  :: [PmLit] } -> PmPat 'VA
+  PmGrd  :: { pm_grd_pv   :: PatVec
+            , pm_grd_expr :: PmExpr  } -> PmPat 'PAT
+
+instance Outputable (PmPat a) where
+  ppr = pprPmPatDebug
+
+-- data T a where
+--     MkT :: forall p q. (Eq p, Ord q) => p -> q -> T [p]
+-- or  MkT :: forall p q r. (Eq p, Ord q, [p] ~ r) => p -> q -> T r
+
+type Pattern = PmPat 'PAT -- ^ Patterns
+type ValAbs  = PmPat 'VA  -- ^ Value Abstractions
+
+type PatVec = [Pattern]             -- ^ Pattern Vectors
+data ValVec = ValVec [ValAbs] Delta -- ^ Value Vector Abstractions
+
+-- | Term and type constraints to accompany each value vector abstraction.
+-- For efficiency, we store the term oracle state instead of the term
+-- constraints. TODO: Do the same for the type constraints?
+data Delta = MkDelta { delta_ty_cs :: Bag EvVar
+                     , delta_tm_cs :: TmState }
+
+type ValSetAbs = [ValVec]  -- ^ Value Set Abstractions
+type Uncovered = ValSetAbs
+
+-- Instead of keeping the whole sets in memory, we keep a boolean for both the
+-- covered and the divergent set (we store the uncovered set though, since we
+-- want to print it). For both the covered and the divergent we have:
+--
+--   True <=> The set is non-empty
+--
+-- hence:
+--  C = True             ==> Useful clause (no warning)
+--  C = False, D = True  ==> Clause with inaccessible RHS
+--  C = False, D = False ==> Redundant clause
+
+data Covered = Covered | NotCovered
+  deriving Show
+
+instance Outputable Covered where
+  ppr (Covered) = text "Covered"
+  ppr (NotCovered) = text "NotCovered"
+
+-- Like the or monoid for booleans
+-- Covered = True, Uncovered = False
+instance Semi.Semigroup Covered where
+  Covered <> _ = Covered
+  _ <> Covered = Covered
+  NotCovered <> NotCovered = NotCovered
+
+instance Monoid Covered where
+  mempty = NotCovered
+  mappend = (Semi.<>)
+
+data Diverged = Diverged | NotDiverged
+  deriving Show
+
+instance Outputable Diverged where
+  ppr Diverged = text "Diverged"
+  ppr NotDiverged = text "NotDiverged"
+
+instance Semi.Semigroup Diverged where
+  Diverged <> _ = Diverged
+  _ <> Diverged = Diverged
+  NotDiverged <> NotDiverged = NotDiverged
+
+instance Monoid Diverged where
+  mempty = NotDiverged
+  mappend = (Semi.<>)
+
+-- | When we learned that a given match group is complete
+data Provenance =
+                  FromBuiltin -- ^  From the original definition of the type
+                              --    constructor.
+                | FromComplete -- ^ From a user-provided @COMPLETE@ pragma
+  deriving (Show, Eq, Ord)
+
+instance Outputable Provenance where
+  ppr  = text . show
+
+instance Semi.Semigroup Provenance where
+  FromComplete <> _ = FromComplete
+  _ <> FromComplete = FromComplete
+  _ <> _ = FromBuiltin
+
+instance Monoid Provenance where
+  mempty = FromBuiltin
+  mappend = (Semi.<>)
+
+data PartialResult = PartialResult {
+                        presultProvenance :: Provenance
+                         -- keep track of provenance because we don't want
+                         -- to warn about redundant matches if the result
+                         -- is contaminated with a COMPLETE pragma
+                      , presultCovered :: Covered
+                      , presultUncovered :: Uncovered
+                      , presultDivergent :: Diverged }
+
+instance Outputable PartialResult where
+  ppr (PartialResult prov c vsa d)
+           = text "PartialResult" <+> ppr prov <+> ppr c
+                                  <+> ppr d <+> ppr vsa
+
+
+instance Semi.Semigroup PartialResult where
+  (PartialResult prov1 cs1 vsa1 ds1)
+    <> (PartialResult prov2 cs2 vsa2 ds2)
+      = PartialResult (prov1 Semi.<> prov2)
+                      (cs1 Semi.<> cs2)
+                      (vsa1 Semi.<> vsa2)
+                      (ds1 Semi.<> ds2)
+
+
+instance Monoid PartialResult where
+  mempty = PartialResult mempty mempty [] mempty
+  mappend = (Semi.<>)
+
+-- newtype ChoiceOf a = ChoiceOf [a]
+
+-- | Pattern check result
+--
+-- * Redundant clauses
+-- * Not-covered clauses (or their type, if no pattern is available)
+-- * Clauses with inaccessible RHS
+--
+-- More details about the classification of clauses into useful, redundant
+-- and with inaccessible right hand side can be found here:
+--
+--     https://ghc.haskell.org/trac/ghc/wiki/PatternMatchCheck
+--
+data PmResult =
+  PmResult {
+      pmresultProvenance   :: Provenance
+    , pmresultRedundant    :: [Located [LPat GhcTc]]
+    , pmresultUncovered    :: UncoveredCandidates
+    , pmresultInaccessible :: [Located [LPat GhcTc]] }
+
+-- | Either a list of patterns that are not covered, or their type, in case we
+-- have no patterns at hand. Not having patterns at hand can arise when
+-- handling EmptyCase expressions, in two cases:
+--
+-- * The type of the scrutinee is a trivially inhabited type (like Int or Char)
+-- * The type of the scrutinee cannot be reduced to WHNF.
+--
+-- In both these cases we have no inhabitation candidates for the type at hand,
+-- but we don't want to issue just a wildcard as missing. Instead, we print a
+-- type annotated wildcard, so that the user knows what kind of patterns is
+-- expected (e.g. (_ :: Int), or (_ :: F Int), where F Int does not reduce).
+data UncoveredCandidates = UncoveredPatterns Uncovered
+                         | TypeOfUncovered Type
+
+-- | The empty pattern check result
+emptyPmResult :: PmResult
+emptyPmResult = PmResult FromBuiltin [] (UncoveredPatterns []) []
+
+-- | Non-exhaustive empty case with unknown/trivial inhabitants
+uncoveredWithTy :: Type -> PmResult
+uncoveredWithTy ty = PmResult FromBuiltin [] (TypeOfUncovered ty) []
+
+{-
+%************************************************************************
+%*                                                                      *
+       Entry points to the checker: checkSingle and checkMatches
+%*                                                                      *
+%************************************************************************
+-}
+
+-- | Check a single pattern binding (let)
+checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM ()
+checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do
+  tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])
+  mb_pm_res <- tryM (getResult (checkSingle' locn var p))
+  case mb_pm_res of
+    Left  _   -> warnPmIters dflags ctxt
+    Right res -> dsPmWarn dflags ctxt res
+
+-- | Check a single pattern binding (let)
+checkSingle' :: SrcSpan -> Id -> Pat GhcTc -> PmM PmResult
+checkSingle' locn var p = do
+  liftD resetPmIterDs -- set the iter-no to zero
+  fam_insts <- liftD dsGetFamInstEnvs
+  clause    <- liftD $ translatePat fam_insts p
+  missing   <- mkInitialUncovered [var]
+  tracePm "checkSingle: missing" (vcat (map pprValVecDebug missing))
+                                 -- no guards
+  PartialResult prov cs us ds <- runMany (pmcheckI clause []) missing
+  let us' = UncoveredPatterns us
+  return $ case (cs,ds) of
+    (Covered,  _    )         -> PmResult prov [] us' [] -- useful
+    (NotCovered, NotDiverged) -> PmResult prov m  us' [] -- redundant
+    (NotCovered, Diverged )   -> PmResult prov [] us' m  -- inaccessible rhs
+  where m = [cL locn [cL locn p]]
+
+-- | Exhaustive for guard matches, is used for guards in pattern bindings and
+-- in @MultiIf@ expressions.
+checkGuardMatches :: HsMatchContext Name          -- Match context
+                  -> GRHSs GhcTc (LHsExpr GhcTc)  -- Guarded RHSs
+                  -> DsM ()
+checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do
+    dflags <- getDynFlags
+    let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)
+        dsMatchContext = DsMatchContext hs_ctx combinedLoc
+        match = cL combinedLoc $
+                  Match { m_ext = noExt
+                        , m_ctxt = hs_ctx
+                        , m_pats = []
+                        , m_grhss = guards }
+    checkMatches dflags dsMatchContext [] [match]
+checkGuardMatches _ (XGRHSs _) = panic "checkGuardMatches"
+
+-- | Check a matchgroup (case, functions, etc.)
+checkMatches :: DynFlags -> DsMatchContext
+             -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM ()
+checkMatches dflags ctxt vars matches = do
+  tracePmD "checkMatches" (hang (vcat [ppr ctxt
+                               , ppr vars
+                               , text "Matches:"])
+                               2
+                               (vcat (map ppr matches)))
+  mb_pm_res <- tryM $ getResult $ case matches of
+    -- Check EmptyCase separately
+    -- See Note [Checking EmptyCase Expressions]
+    [] | [var] <- vars -> checkEmptyCase' var
+    _normal_match      -> checkMatches' vars matches
+  case mb_pm_res of
+    Left  _   -> warnPmIters dflags ctxt
+    Right res -> dsPmWarn dflags ctxt res
+
+-- | Check a matchgroup (case, functions, etc.). To be called on a non-empty
+-- list of matches. For empty case expressions, use checkEmptyCase' instead.
+checkMatches' :: [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> PmM PmResult
+checkMatches' vars matches
+  | null matches = panic "checkMatches': EmptyCase"
+  | otherwise = do
+      liftD resetPmIterDs -- set the iter-no to zero
+      missing    <- mkInitialUncovered vars
+      tracePm "checkMatches': missing" (vcat (map pprValVecDebug missing))
+      (prov, rs,us,ds) <- go matches missing
+      return $ PmResult {
+                   pmresultProvenance   = prov
+                 , pmresultRedundant    = map hsLMatchToLPats rs
+                 , pmresultUncovered    = UncoveredPatterns us
+                 , pmresultInaccessible = map hsLMatchToLPats ds }
+  where
+    go :: [LMatch GhcTc (LHsExpr GhcTc)] -> Uncovered
+       -> PmM (Provenance
+              , [LMatch GhcTc (LHsExpr GhcTc)]
+              , Uncovered
+              , [LMatch GhcTc (LHsExpr GhcTc)])
+    go []     missing = return (mempty, [], missing, [])
+    go (m:ms) missing = do
+      tracePm "checMatches': go" (ppr m $$ ppr missing)
+      fam_insts          <- liftD dsGetFamInstEnvs
+      (clause, guards)   <- liftD $ translateMatch fam_insts m
+      r@(PartialResult prov cs missing' ds)
+        <- runMany (pmcheckI clause guards) missing
+      tracePm "checMatches': go: res" (ppr r)
+      (ms_prov, rs, final_u, is)  <- go ms missing'
+      let final_prov = prov `mappend` ms_prov
+      return $ case (cs, ds) of
+        -- useful
+        (Covered,  _    )        -> (final_prov,  rs, final_u,   is)
+        -- redundant
+        (NotCovered, NotDiverged) -> (final_prov, m:rs, final_u,is)
+        -- inaccessible
+        (NotCovered, Diverged )   -> (final_prov,  rs, final_u, m:is)
+
+    hsLMatchToLPats :: LMatch id body -> Located [LPat id]
+    hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats
+    hsLMatchToLPats _                                   = panic "checMatches'"
+
+-- | Check an empty case expression. Since there are no clauses to process, we
+--   only compute the uncovered set. See Note [Checking EmptyCase Expressions]
+--   for details.
+checkEmptyCase' :: Id -> PmM PmResult
+checkEmptyCase' var = do
+  tm_ty_css     <- pmInitialTmTyCs
+  mb_candidates <- inhabitationCandidates (delta_ty_cs tm_ty_css) (idType var)
+  case mb_candidates of
+    -- Inhabitation checking failed / the type is trivially inhabited
+    Left ty -> return (uncoveredWithTy ty)
+
+    -- A list of inhabitant candidates is available: Check for each
+    -- one for the satisfiability of the constraints it gives rise to.
+    Right (_, candidates) -> do
+      missing_m <- flip mapMaybeM candidates $
+          \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct
+                                , ic_ty_cs = ty_cs
+                                , ic_strict_arg_tys = strict_arg_tys } -> do
+        mb_sat <- pmIsSatisfiable tm_ty_css tm_ct ty_cs strict_arg_tys
+        pure $ fmap (ValVec [va]) mb_sat
+      return $ if null missing_m
+        then emptyPmResult
+        else PmResult FromBuiltin [] (UncoveredPatterns missing_m) []
+
+-- | Returns 'True' if the argument 'Type' is a fully saturated application of
+-- a closed type constructor.
+--
+-- Closed type constructors are those with a fixed right hand side, as
+-- opposed to e.g. associated types. These are of particular interest for
+-- pattern-match coverage checking, because GHC can exhaustively consider all
+-- possible forms that values of a closed type can take on.
+--
+-- Note that this function is intended to be used to check types of value-level
+-- patterns, so as a consequence, the 'Type' supplied as an argument to this
+-- function should be of kind @Type@.
+pmIsClosedType :: Type -> Bool
+pmIsClosedType ty
+  = case splitTyConApp_maybe ty of
+      Just (tc, ty_args)
+             | is_algebraic_like tc && not (isFamilyTyCon tc)
+             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True
+      _other -> False
+  where
+    -- This returns True for TyCons which /act like/ algebraic types.
+    -- (See "Type#type_classification" for what an algebraic type is.)
+    --
+    -- This is qualified with \"like\" because of a particular special
+    -- case: TYPE (the underlyind kind behind Type, among others). TYPE
+    -- is conceptually a datatype (and thus algebraic), but in practice it is
+    -- a primitive builtin type, so we must check for it specially.
+    --
+    -- NB: it makes sense to think of TYPE as a closed type in a value-level,
+    -- pattern-matching context. However, at the kind level, TYPE is certainly
+    -- not closed! Since this function is specifically tailored towards pattern
+    -- matching, however, it's OK to label TYPE as closed.
+    is_algebraic_like :: TyCon -> Bool
+    is_algebraic_like tc = isAlgTyCon tc || tc == tYPETyCon
+
+pmTopNormaliseType_maybe :: FamInstEnvs -> Bag EvVar -> Type
+                         -> PmM (Maybe (Type, [DataCon], Type))
+-- ^ Get rid of *outermost* (or toplevel)
+--      * type function redex
+--      * data family redex
+--      * newtypes
+--
+-- Behaves exactly like `topNormaliseType_maybe`, but instead of returning a
+-- coercion, it returns useful information for issuing pattern matching
+-- warnings. See Note [Type normalisation for EmptyCase] for details.
+--
+-- NB: Normalisation can potentially change kinds, if the head of the type
+-- is a type family with a variable result kind. I (Richard E) can't think
+-- of a way to cause trouble here, though.
+pmTopNormaliseType_maybe env ty_cs typ
+  = do (_, mb_typ') <- liftD $ initTcDsForSolver $ tcNormalise ty_cs typ
+         -- Before proceeding, we chuck typ into the constraint solver, in case
+         -- solving for given equalities may reduce typ some. See
+         -- "Wrinkle: local equalities" in
+         -- Note [Type normalisation for EmptyCase].
+       pure $ do typ' <- mb_typ'
+                 ((ty_f,tm_f), ty) <- topNormaliseTypeX stepper comb typ'
+                 -- We need to do topNormaliseTypeX in addition to tcNormalise,
+                 -- since topNormaliseX looks through newtypes, which
+                 -- tcNormalise does not do.
+                 Just (eq_src_ty ty (typ' : ty_f [ty]), tm_f [], ty)
+  where
+    -- Find the first type in the sequence of rewrites that is a data type,
+    -- newtype, or a data family application (not the representation tycon!).
+    -- This is the one that is equal (in source Haskell) to the initial type.
+    -- If none is found in the list, then all of them are type family
+    -- applications, so we simply return the last one, which is the *simplest*.
+    eq_src_ty :: Type -> [Type] -> Type
+    eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys)
+
+    is_closed_or_data_family :: Type -> Bool
+    is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty
+
+    -- For efficiency, represent both lists as difference lists.
+    -- comb performs the concatenation, for both lists.
+    comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2)
+
+    stepper = newTypeStepper `composeSteppers` tyFamStepper
+
+    -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into
+    -- a loop. If it would fall into a loop, it produces 'NS_Abort'.
+    newTypeStepper :: NormaliseStepper ([Type] -> [Type],[DataCon] -> [DataCon])
+    newTypeStepper rec_nts tc tys
+      | Just (ty', _co) <- instNewTyCon_maybe tc tys
+      = case checkRecTc rec_nts tc of
+          Just rec_nts' -> let tyf = ((TyConApp tc tys):)
+                               tmf = ((tyConSingleDataCon tc):)
+                           in  NS_Step rec_nts' ty' (tyf, tmf)
+          Nothing       -> NS_Abort
+      | otherwise
+      = NS_Done
+
+    tyFamStepper :: NormaliseStepper ([Type] -> [Type], [DataCon] -> [DataCon])
+    tyFamStepper rec_nts tc tys  -- Try to step a type/data family
+      = let (_args_co, ntys, _res_co) = normaliseTcArgs env Representational tc tys in
+          -- NB: It's OK to use normaliseTcArgs here instead of
+          -- normalise_tc_args (which takes the LiftingContext described
+          -- in Note [Normalising types]) because the reduceTyFamApp below
+          -- works only at top level. We'll never recur in this function
+          -- after reducing the kind of a bound tyvar.
+
+        case reduceTyFamApp_maybe env Representational tc ntys of
+          Just (_co, rhs) -> NS_Step rec_nts rhs ((rhs:), id)
+          _               -> NS_Done
+
+-- | Determine suitable constraints to use at the beginning of pattern-match
+-- coverage checking by consulting the sets of term and type constraints
+-- currently in scope. If one of these sets of constraints is unsatisfiable,
+-- use an empty set in its place. (See
+-- @Note [Recovering from unsatisfiable pattern-matching constraints]@
+-- for why this is done.)
+pmInitialTmTyCs :: PmM Delta
+pmInitialTmTyCs = do
+  ty_cs  <- liftD getDictsDs
+  tm_cs  <- map toComplex . bagToList <$> liftD getTmCsDs
+  sat_ty <- tyOracle ty_cs
+  let initTyCs = if sat_ty then ty_cs else emptyBag
+      initTmState = fromMaybe initialTmState (tmOracle initialTmState tm_cs)
+  pure $ MkDelta{ delta_tm_cs = initTmState, delta_ty_cs = initTyCs }
+
+{-
+Note [Recovering from unsatisfiable pattern-matching constraints]
+~~~~~~~~~~~~~~~~
+Consider the following code (see #12957 and #15450):
+
+  f :: Int ~ Bool => ()
+  f = case True of { False -> () }
+
+We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC
+used not to do this; in fact, it would warn that the match was /redundant/!
+This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the
+coverage checker deems any matches with unsatifiable constraint sets to be
+unreachable.
+
+We decide to better than this. When beginning coverage checking, we first
+check if the constraints in scope are unsatisfiable, and if so, we start
+afresh with an empty set of constraints. This way, we'll get the warnings
+that we expect.
+-}
+
+-- | Given a conlike's term constraints, type constraints, and strict argument
+-- types, check if they are satisfiable.
+-- (In other words, this is the ⊢_Sat oracle judgment from the GADTs Meet
+-- Their Match paper.)
+--
+-- For the purposes of efficiency, this takes as separate arguments the
+-- ambient term and type constraints (which are known beforehand to be
+-- satisfiable), as well as the new term and type constraints (which may not
+-- be satisfiable). This lets us implement two mini-optimizations:
+--
+-- * If there are no new type constraints, then don't bother initializing
+--   the type oracle, since it's redundant to do so.
+-- * Since the new term constraint is a separate argument, we only need to
+--   execute one iteration of the term oracle (instead of traversing the
+--   entire set of term constraints).
+--
+-- Taking strict argument types into account is something which was not
+-- discussed in GADTs Meet Their Match. For an explanation of what role they
+-- serve, see @Note [Extensions to GADTs Meet Their Match]@.
+pmIsSatisfiable
+  :: Delta     -- ^ The ambient term and type constraints
+               --   (known to be satisfiable).
+  -> ComplexEq -- ^ The new term constraint.
+  -> Bag EvVar -- ^ The new type constraints.
+  -> [Type]    -- ^ The strict argument types.
+  -> PmM (Maybe Delta)
+               -- ^ @'Just' delta@ if the constraints (@delta@) are
+               -- satisfiable, and each strict argument type is inhabitable.
+               -- 'Nothing' otherwise.
+pmIsSatisfiable amb_cs new_tm_c new_ty_cs strict_arg_tys = do
+  mb_sat <- tmTyCsAreSatisfiable amb_cs new_tm_c new_ty_cs
+  case mb_sat of
+    Nothing -> pure Nothing
+    Just delta -> do
+      -- We know that the term and type constraints are inhabitable, so now
+      -- check if each strict argument type is inhabitable.
+      all_non_void <- checkAllNonVoid initRecTc delta strict_arg_tys
+      pure $ if all_non_void -- Check if each strict argument type
+                             -- is inhabitable
+                then Just delta
+                else Nothing
+
+-- | Like 'pmIsSatisfiable', but only checks if term and type constraints are
+-- satisfiable, and doesn't bother checking anything related to strict argument
+-- types.
+tmTyCsAreSatisfiable
+  :: Delta     -- ^ The ambient term and type constraints
+               --   (known to be satisfiable).
+  -> ComplexEq -- ^ The new term constraint.
+  -> Bag EvVar -- ^ The new type constraints.
+  -> PmM (Maybe Delta)
+       -- ^ @'Just' delta@ if the constraints (@delta@) are
+       -- satisfiable. 'Nothing' otherwise.
+tmTyCsAreSatisfiable
+    (MkDelta{ delta_tm_cs = amb_tm_cs, delta_ty_cs = amb_ty_cs })
+    new_tm_c new_ty_cs = do
+  let ty_cs = new_ty_cs `unionBags` amb_ty_cs
+  sat_ty <- if isEmptyBag new_ty_cs
+               then pure True
+               else tyOracle ty_cs
+  pure $ case (sat_ty, solveOneEq amb_tm_cs new_tm_c) of
+           (True, Just term_cs) -> Just $ MkDelta{ delta_ty_cs = ty_cs
+                                                 , delta_tm_cs = term_cs }
+           _unsat               -> Nothing
+
+-- | Implements two performance optimizations, as described in the
+-- \"Strict argument type constraints\" section of
+-- @Note [Extensions to GADTs Meet Their Match]@.
+checkAllNonVoid :: RecTcChecker -> Delta -> [Type] -> PmM Bool
+checkAllNonVoid rec_ts amb_cs strict_arg_tys = do
+  fam_insts <- liftD dsGetFamInstEnvs
+  let definitely_inhabited =
+        definitelyInhabitedType fam_insts (delta_ty_cs amb_cs)
+  tys_to_check <- filterOutM definitely_inhabited strict_arg_tys
+  let rec_max_bound | tys_to_check `lengthExceeds` 1
+                    = 1
+                    | otherwise
+                    = defaultRecTcMaxBound
+      rec_ts' = setRecTcMaxBound rec_max_bound rec_ts
+  allM (nonVoid rec_ts' amb_cs) tys_to_check
+
+-- | Checks if a strict argument type of a conlike is inhabitable by a
+-- terminating value (i.e, an 'InhabitationCandidate').
+-- See @Note [Extensions to GADTs Meet Their Match]@.
+nonVoid
+  :: RecTcChecker -- ^ The per-'TyCon' recursion depth limit.
+  -> Delta        -- ^ The ambient term/type constraints (known to be
+                  --   satisfiable).
+  -> Type         -- ^ The strict argument type.
+  -> PmM Bool     -- ^ 'True' if the strict argument type might be inhabited by
+                  --   a terminating value (i.e., an 'InhabitationCandidate').
+                  --   'False' if it is definitely uninhabitable by anything
+                  --   (except bottom).
+nonVoid rec_ts amb_cs strict_arg_ty = do
+  mb_cands <- inhabitationCandidates (delta_ty_cs amb_cs) strict_arg_ty
+  case mb_cands of
+    Right (tc, cands)
+      |  Just rec_ts' <- checkRecTc rec_ts tc
+      -> anyM (cand_is_inhabitable rec_ts' amb_cs) cands
+           -- A strict argument type is inhabitable by a terminating value if
+           -- at least one InhabitationCandidate is inhabitable.
+    _ -> pure True
+           -- Either the type is trivially inhabited or we have exceeded the
+           -- recursion depth for some TyCon (so bail out and conservatively
+           -- claim the type is inhabited).
+  where
+    -- Checks if an InhabitationCandidate for a strict argument type:
+    --
+    -- (1) Has satisfiable term and type constraints.
+    -- (2) Has 'nonVoid' strict argument types (we bail out of this
+    --     check if recursion is detected).
+    --
+    -- See Note [Extensions to GADTs Meet Their Match]
+    cand_is_inhabitable :: RecTcChecker -> Delta
+                        -> InhabitationCandidate -> PmM Bool
+    cand_is_inhabitable rec_ts amb_cs
+      (InhabitationCandidate{ ic_tm_ct          = new_term_c
+                            , ic_ty_cs          = new_ty_cs
+                            , ic_strict_arg_tys = new_strict_arg_tys }) = do
+        mb_sat <- tmTyCsAreSatisfiable amb_cs new_term_c new_ty_cs
+        case mb_sat of
+          Nothing -> pure False
+          Just new_delta -> do
+            checkAllNonVoid rec_ts new_delta new_strict_arg_tys
+
+-- | @'definitelyInhabitedType' ty@ returns 'True' if @ty@ has at least one
+-- constructor @C@ such that:
+--
+-- 1. @C@ has no equality constraints.
+-- 2. @C@ has no strict argument types.
+--
+-- See the \"Strict argument type constraints\" section of
+-- @Note [Extensions to GADTs Meet Their Match]@.
+definitelyInhabitedType :: FamInstEnvs -> Bag EvVar -> Type -> PmM Bool
+definitelyInhabitedType env ty_cs ty = do
+  mb_res <- pmTopNormaliseType_maybe env ty_cs ty
+  pure $ case mb_res of
+           Just (_, cons, _) -> any meets_criteria cons
+           Nothing           -> False
+  where
+    meets_criteria :: DataCon -> Bool
+    meets_criteria con =
+      null (dataConEqSpec con) && -- (1)
+      null (dataConImplBangs con) -- (2)
+
+{- Note [Type normalisation for EmptyCase]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+EmptyCase is an exception for pattern matching, since it is strict. This means
+that it boils down to checking whether the type of the scrutinee is inhabited.
+Function pmTopNormaliseType_maybe gets rid of the outermost type function/data
+family redex and newtypes, in search of an algebraic type constructor, which is
+easier to check for inhabitation.
+
+It returns 3 results instead of one, because there are 2 subtle points:
+1. Newtypes are isomorphic to the underlying type in core but not in the source
+   language,
+2. The representational data family tycon is used internally but should not be
+   shown to the user
+
+Hence, if pmTopNormaliseType_maybe env ty_cs ty = Just (src_ty, dcs, core_ty),
+then
+  (a) src_ty is the rewritten type which we can show to the user. That is, the
+      type we get if we rewrite type families but not data families or
+      newtypes.
+  (b) dcs is the list of data constructors "skipped", every time we normalise a
+      newtype to its core representation, we keep track of the source data
+      constructor.
+  (c) core_ty is the rewritten type. That is,
+        pmTopNormaliseType_maybe env ty_cs ty = Just (src_ty, dcs, core_ty)
+      implies
+        topNormaliseType_maybe env ty = Just (co, core_ty)
+      for some coercion co.
+
+To see how all cases come into play, consider the following example:
+
+  data family T a :: *
+  data instance T Int = T1 | T2 Bool
+  -- Which gives rise to FC:
+  --   data T a
+  --   data R:TInt = T1 | T2 Bool
+  --   axiom ax_ti : T Int ~R R:TInt
+
+  newtype G1 = MkG1 (T Int)
+  newtype G2 = MkG2 G1
+
+  type instance F Int  = F Char
+  type instance F Char = G2
+
+In this case pmTopNormaliseType_maybe env ty_cs (F Int) results in
+
+  Just (G2, [MkG2,MkG1], R:TInt)
+
+Which means that in source Haskell:
+  - G2 is equivalent to F Int (in contrast, G1 isn't).
+  - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int).
+
+-----
+-- Wrinkle: Local equalities
+-----
+
+Given the following type family:
+
+  type family F a
+  type instance F Int = Void
+
+Should the following program (from #14813) be considered exhaustive?
+
+  f :: (i ~ Int) => F i -> a
+  f x = case x of {}
+
+You might think "of course, since `x` is obviously of type Void". But the
+idType of `x` is technically F i, not Void, so if we pass F i to
+inhabitationCandidates, we'll mistakenly conclude that `f` is non-exhaustive.
+In order to avoid this pitfall, we need to normalise the type passed to
+pmTopNormaliseType_maybe, using the constraint solver to solve for any local
+equalities (such as i ~ Int) that may be in scope.
+-}
+
+-- | Generate all 'InhabitationCandidate's for a given type. The result is
+-- either @'Left' ty@, if the type cannot be reduced to a closed algebraic type
+-- (or if it's one trivially inhabited, like 'Int'), or @'Right' candidates@,
+-- if it can. In this case, the candidates are the signature of the tycon, each
+-- one accompanied by the term- and type- constraints it gives rise to.
+-- See also Note [Checking EmptyCase Expressions]
+inhabitationCandidates :: Bag EvVar -> Type
+                       -> PmM (Either Type (TyCon, [InhabitationCandidate]))
+inhabitationCandidates ty_cs ty = do
+  fam_insts   <- liftD dsGetFamInstEnvs
+  mb_norm_res <- pmTopNormaliseType_maybe fam_insts ty_cs ty
+  case mb_norm_res of
+    Just (src_ty, dcs, core_ty) -> alts_to_check src_ty core_ty dcs
+    Nothing                     -> alts_to_check ty     ty      []
+  where
+    -- All these types are trivially inhabited
+    trivially_inhabited = [ charTyCon, doubleTyCon, floatTyCon
+                          , intTyCon, wordTyCon, word8TyCon ]
+
+    -- Note: At the moment we leave all the typing and constraint fields of
+    -- PmCon empty, since we know that they are not gonna be used. Is the
+    -- right-thing-to-do to actually create them, even if they are never used?
+    build_tm :: ValAbs -> [DataCon] -> ValAbs
+    build_tm = foldr (\dc e -> PmCon (RealDataCon dc) [] [] [] [e])
+
+    -- Inhabitation candidates, using the result of pmTopNormaliseType_maybe
+    alts_to_check :: Type -> Type -> [DataCon]
+                  -> PmM (Either Type (TyCon, [InhabitationCandidate]))
+    alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of
+      Just (tc, _)
+        |  tc `elem` trivially_inhabited
+        -> case dcs of
+             []    -> return (Left src_ty)
+             (_:_) -> do var <- liftD $ mkPmId core_ty
+                         let va = build_tm (PmVar var) dcs
+                         return $ Right (tc, [InhabitationCandidate
+                           { ic_val_abs = va, ic_tm_ct = mkIdEq var
+                           , ic_ty_cs = emptyBag, ic_strict_arg_tys = [] }])
+
+        |  pmIsClosedType core_ty && not (isAbstractTyCon tc)
+           -- Don't consider abstract tycons since we don't know what their
+           -- constructors are, which makes the results of coverage checking
+           -- them extremely misleading.
+        -> liftD $ do
+             var  <- mkPmId core_ty -- it would be wrong to unify x
+             alts <- mapM (mkOneConFull var . RealDataCon) (tyConDataCons tc)
+             return $ Right
+               (tc, [ alt{ic_val_abs = build_tm (ic_val_abs alt) dcs}
+                    | alt <- alts ])
+      -- For other types conservatively assume that they are inhabited.
+      _other -> return (Left src_ty)
+
+{- Note [Checking EmptyCase Expressions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Empty case expressions are strict on the scrutinee. That is, `case x of {}`
+will force argument `x`. Hence, `checkMatches` is not sufficient for checking
+empty cases, because it assumes that the match is not strict (which is true
+for all other cases, apart from EmptyCase). This gave rise to #10746. Instead,
+we do the following:
+
+1. We normalise the outermost type family redex, data family redex or newtype,
+   using pmTopNormaliseType_maybe (in types/FamInstEnv.hs). This computes 3
+   things:
+   (a) A normalised type src_ty, which is equal to the type of the scrutinee in
+       source Haskell (does not normalise newtypes or data families)
+   (b) The actual normalised type core_ty, which coincides with the result
+       topNormaliseType_maybe. This type is not necessarily equal to the input
+       type in source Haskell. And this is precicely the reason we compute (a)
+       and (c): the reasoning happens with the underlying types, but both the
+       patterns and types we print should respect newtypes and also show the
+       family type constructors and not the representation constructors.
+
+   (c) A list of all newtype data constructors dcs, each one corresponding to a
+       newtype rewrite performed in (b).
+
+   For an example see also Note [Type normalisation for EmptyCase]
+   in types/FamInstEnv.hs.
+
+2. Function checkEmptyCase' performs the check:
+   - If core_ty is not an algebraic type, then we cannot check for
+     inhabitation, so we emit (_ :: src_ty) as missing, conservatively assuming
+     that the type is inhabited.
+   - If core_ty is an algebraic type, then we unfold the scrutinee to all
+     possible constructor patterns, using inhabitationCandidates, and then
+     check each one for constraint satisfiability, same as we for normal
+     pattern match checking.
+
+%************************************************************************
+%*                                                                      *
+              Transform source syntax to *our* syntax
+%*                                                                      *
+%************************************************************************
+-}
+
+-- -----------------------------------------------------------------------
+-- * Utilities
+
+nullaryConPattern :: ConLike -> Pattern
+-- Nullary data constructor and nullary type constructor
+nullaryConPattern con =
+  PmCon { pm_con_con = con, pm_con_arg_tys = []
+        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = [] }
+{-# INLINE nullaryConPattern #-}
+
+truePattern :: Pattern
+truePattern = nullaryConPattern (RealDataCon trueDataCon)
+{-# INLINE truePattern #-}
+
+-- | A fake guard pattern (True <- _) used to represent cases we cannot handle
+fake_pat :: Pattern
+fake_pat = PmGrd { pm_grd_pv   = [truePattern]
+                 , pm_grd_expr = PmExprOther (EWildPat noExt) }
+{-# INLINE fake_pat #-}
+
+-- | Check whether a guard pattern is generated by the checker (unhandled)
+isFakeGuard :: [Pattern] -> PmExpr -> Bool
+isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _))
+  | c == trueDataCon = True
+  | otherwise        = False
+isFakeGuard _pats _e = False
+
+-- | Generate a `canFail` pattern vector of a specific type
+mkCanFailPmPat :: Type -> DsM PatVec
+mkCanFailPmPat ty = do
+  var <- mkPmVar ty
+  return [var, fake_pat]
+
+vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern
+-- ADT constructor pattern => no existentials, no local constraints
+vanillaConPattern con arg_tys args =
+  PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
+        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = args }
+{-# INLINE vanillaConPattern #-}
+
+-- | Create an empty list pattern of a given type
+nilPattern :: Type -> Pattern
+nilPattern ty =
+  PmCon { pm_con_con = RealDataCon nilDataCon, pm_con_arg_tys = [ty]
+        , pm_con_tvs = [], pm_con_dicts = []
+        , pm_con_args = [] }
+{-# INLINE nilPattern #-}
+
+mkListPatVec :: Type -> PatVec -> PatVec -> PatVec
+mkListPatVec ty xs ys = [PmCon { pm_con_con = RealDataCon consDataCon
+                               , pm_con_arg_tys = [ty]
+                               , pm_con_tvs = [], pm_con_dicts = []
+                               , pm_con_args = xs++ys }]
+{-# INLINE mkListPatVec #-}
+
+-- | Create a (non-overloaded) literal pattern
+mkLitPattern :: HsLit GhcTc -> Pattern
+mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }
+{-# INLINE mkLitPattern #-}
+
+-- -----------------------------------------------------------------------
+-- * Transform (Pat Id) into of (PmPat Id)
+
+translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec
+translatePat fam_insts pat = case pat of
+  WildPat  ty  -> mkPmVars [ty]
+  VarPat _ id  -> return [PmVar (unLoc id)]
+  ParPat _ p   -> translatePat fam_insts (unLoc p)
+  LazyPat _ _  -> mkPmVars [hsPatType pat] -- like a variable
+
+  -- ignore strictness annotations for now
+  BangPat _ p  -> translatePat fam_insts (unLoc p)
+
+  AsPat _ lid p -> do
+     -- Note [Translating As Patterns]
+    ps <- translatePat fam_insts (unLoc p)
+    let [e] = map vaToPmExpr (coercePatVec ps)
+        g   = PmGrd [PmVar (unLoc lid)] e
+    return (ps ++ [g])
+
+  SigPat _ p _ty -> translatePat fam_insts (unLoc p)
+
+  -- See Note [Translate CoPats]
+  CoPat _ wrapper p ty
+    | isIdHsWrapper wrapper                   -> translatePat fam_insts p
+    | WpCast co <-  wrapper, isReflexiveCo co -> translatePat fam_insts p
+    | otherwise -> do
+        ps      <- translatePat fam_insts p
+        (xp,xe) <- mkPmId2Forms ty
+        let g = mkGuard ps (mkHsWrap wrapper (unLoc xe))
+        return [xp,g]
+
+  -- (n + k)  ===>   x (True <- x >= k) (n <- x-k)
+  NPlusKPat ty (dL->L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty
+
+  -- (fun -> pat)   ===>   x (pat <- fun x)
+  ViewPat arg_ty lexpr lpat -> do
+    ps <- translatePat fam_insts (unLoc lpat)
+    -- See Note [Guards and Approximation]
+    case all cantFailPattern ps of
+      True  -> do
+        (xp,xe) <- mkPmId2Forms arg_ty
+        let g = mkGuard ps (HsApp noExt lexpr xe)
+        return [xp,g]
+      False -> mkCanFailPmPat arg_ty
+
+  -- list
+  ListPat (ListPatTc ty Nothing) ps -> do
+    foldr (mkListPatVec ty) [nilPattern ty]
+      <$> translatePatVec fam_insts (map unLoc ps)
+
+  -- overloaded list
+  ListPat (ListPatTc _elem_ty (Just (pat_ty, _to_list))) lpats -> do
+    dflags <- getDynFlags
+    if xopt LangExt.RebindableSyntax dflags
+       then mkCanFailPmPat pat_ty
+       else case splitListTyConApp_maybe pat_ty of
+              Just e_ty -> translatePat fam_insts
+                                        (ListPat (ListPatTc e_ty Nothing) lpats)
+              Nothing   -> mkCanFailPmPat pat_ty
+    -- (a) In the presence of RebindableSyntax, we don't know anything about
+    --     `toList`, we should treat `ListPat` as any other view pattern.
+    --
+    -- (b) In the absence of RebindableSyntax,
+    --     - If the pat_ty is `[a]`, then we treat the overloaded list pattern
+    --       as ordinary list pattern. Although we can give an instance
+    --       `IsList [Int]` (more specific than the default `IsList [a]`), in
+    --       practice, we almost never do that. We assume the `_to_list` is
+    --       the `toList` from `instance IsList [a]`.
+    --
+    --     - Otherwise, we treat the `ListPat` as ordinary view pattern.
+    --
+    -- See Trac #14547, especially comment#9 and comment#10.
+    --
+    -- Here we construct CanFailPmPat directly, rather can construct a view
+    -- pattern and do further translation as an optimization, for the reason,
+    -- see Note [Guards and Approximation].
+
+  ConPatOut { pat_con     = (dL->L _ con)
+            , pat_arg_tys = arg_tys
+            , pat_tvs     = ex_tvs
+            , pat_dicts   = dicts
+            , pat_args    = ps } -> do
+    groups <- allCompleteMatches con arg_tys
+    case groups of
+      [] -> mkCanFailPmPat (conLikeResTy con arg_tys)
+      _  -> do
+        args <- translateConPatVec fam_insts arg_tys ex_tvs con ps
+        return [PmCon { pm_con_con     = con
+                      , pm_con_arg_tys = arg_tys
+                      , pm_con_tvs     = ex_tvs
+                      , pm_con_dicts   = dicts
+                      , pm_con_args    = args }]
+
+  -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]
+  NPat _ (dL->L _ olit) mb_neg _
+    | OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit
+    , isStringTy ty ->
+        foldr (mkListPatVec charTy) [nilPattern charTy] <$>
+          translatePatVec fam_insts
+            (map (LitPat noExt . HsChar src) (unpackFS s))
+    | otherwise -> return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) olit }]
+
+  -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]
+  LitPat _ lit
+    | HsString src s <- lit ->
+        foldr (mkListPatVec charTy) [nilPattern charTy] <$>
+          translatePatVec fam_insts
+            (map (LitPat noExt . HsChar src) (unpackFS s))
+    | otherwise -> return [mkLitPattern lit]
+
+  TuplePat tys ps boxity -> do
+    tidy_ps <- translatePatVec fam_insts (map unLoc ps)
+    let tuple_con = RealDataCon (tupleDataCon boxity (length ps))
+    return [vanillaConPattern tuple_con tys (concat tidy_ps)]
+
+  SumPat ty p alt arity -> do
+    tidy_p <- translatePat fam_insts (unLoc p)
+    let sum_con = RealDataCon (sumDataCon alt arity)
+    return [vanillaConPattern sum_con ty tidy_p]
+
+  -- --------------------------------------------------------------------------
+  -- Not supposed to happen
+  ConPatIn  {} -> panic "Check.translatePat: ConPatIn"
+  SplicePat {} -> panic "Check.translatePat: SplicePat"
+  XPat      {} -> panic "Check.translatePat: XPat"
+
+{- Note [Translate Overloaded Literal for Exhaustiveness Checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The translation of @NPat@ in exhaustiveness checker is a bit different
+from translation in pattern matcher.
+
+  * In pattern matcher (see `tidyNPat' in deSugar/MatchLit.hs), we
+    translate integral literals to HsIntPrim or HsWordPrim and translate
+    overloaded strings to HsString.
+
+  * In exhaustiveness checker, in `genCaseTmCs1/genCaseTmCs2`, we use
+    `lhsExprToPmExpr` to generate uncovered set. In `hsExprToPmExpr`,
+    however we generate `PmOLit` for HsOverLit, rather than refine
+    `HsOverLit` inside `NPat` to HsIntPrim/HsWordPrim. If we do
+    the same thing in `translatePat` as in `tidyNPat`, the exhaustiveness
+    checker will fail to match the literals patterns correctly. See
+    Trac #14546.
+
+  In Note [Undecidable Equality for Overloaded Literals], we say: "treat
+  overloaded literals that look different as different", but previously we
+  didn't do such things.
+
+  Now, we translate the literal value to match and the literal patterns
+  consistently:
+
+  * For integral literals, we parse both the integral literal value and
+    the patterns as OverLit HsIntegral. For example:
+
+      case 0::Int of
+          0 -> putStrLn "A"
+          1 -> putStrLn "B"
+          _ -> putStrLn "C"
+
+    When checking the exhaustiveness of pattern matching, we translate the 0
+    in value position as PmOLit, but translate the 0 and 1 in pattern position
+    as PmSLit. The inconsistency leads to the failure of eqPmLit to detect the
+    equality and report warning of "Pattern match is redundant" on pattern 0,
+    as reported in Trac #14546. In this patch we remove the specialization of
+    OverLit patterns, and keep the overloaded number literal in pattern as it
+    is to maintain the consistency. We know nothing about the `fromInteger`
+    method (see Note [Undecidable Equality for Overloaded Literals]). Now we
+    can capture the exhaustiveness of pattern 0 and the redundancy of pattern
+    1 and _.
+
+  * For string literals, we parse the string literals as HsString. When
+    OverloadedStrings is enabled, it further be turned as HsOverLit HsIsString.
+    For example:
+
+      case "foo" of
+          "foo" -> putStrLn "A"
+          "bar" -> putStrLn "B"
+          "baz" -> putStrLn "C"
+
+    Previously, the overloaded string values are translated to PmOLit and the
+    non-overloaded string values are translated to PmSLit. However the string
+    patterns, both overloaded and non-overloaded, are translated to list of
+    characters. The inconsistency leads to wrong warnings about redundant and
+    non-exhaustive pattern matching warnings, as reported in Trac #14546.
+
+    In order to catch the redundant pattern in following case:
+
+      case "foo" of
+          ('f':_) -> putStrLn "A"
+          "bar" -> putStrLn "B"
+
+    in this patch, we translate non-overloaded string literals, both in value
+    position and pattern position, as list of characters. For overloaded string
+    literals, we only translate it to list of characters only when it's type
+    is stringTy, since we know nothing about the toString methods. But we know
+    that if two overloaded strings are syntax equal, then they are equal. Then
+    if it's type is not stringTy, we just translate it to PmOLit. We can still
+    capture the exhaustiveness of pattern "foo" and the redundancy of pattern
+    "bar" and "baz" in the following code:
+
+      {-# LANGUAGE OverloadedStrings #-}
+      main = do
+        case "foo" of
+            "foo" -> putStrLn "A"
+            "bar" -> putStrLn "B"
+            "baz" -> putStrLn "C"
+
+  We must ensure that doing the same translation to literal values and patterns
+  in `translatePat` and `hsExprToPmExpr`. The previous inconsistent work led to
+  Trac #14546.
+-}
+
+-- | Translate a list of patterns (Note: each pattern is translated
+-- to a pattern vector but we do not concatenate the results).
+translatePatVec :: FamInstEnvs -> [Pat GhcTc] -> DsM [PatVec]
+translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats
+
+-- | Translate a constructor pattern
+translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar]
+                   -> ConLike -> HsConPatDetails GhcTc -> DsM PatVec
+translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps)
+  = concat <$> translatePatVec fam_insts (map unLoc ps)
+translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2)
+  = concat <$> translatePatVec fam_insts (map unLoc [p1,p2])
+translateConPatVec fam_insts  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))
+    -- Nothing matched. Make up some fresh term variables
+  | null fs        = mkPmVars arg_tys
+    -- The data constructor was not defined using record syntax. For the
+    -- pattern to be in record syntax it should be empty (e.g. Just {}).
+    -- So just like the previous case.
+  | null orig_lbls = ASSERT(null matched_lbls) mkPmVars arg_tys
+    -- Some of the fields appear, in the original order (there may be holes).
+    -- Generate a simple constructor pattern and make up fresh variables for
+    -- the rest of the fields
+  | matched_lbls `subsetOf` orig_lbls
+  = ASSERT(orig_lbls `equalLength` arg_tys)
+      let translateOne (lbl, ty) = case lookup lbl matched_pats of
+            Just p  -> translatePat fam_insts p
+            Nothing -> mkPmVars [ty]
+      in  concatMapM translateOne (zip orig_lbls arg_tys)
+    -- The fields that appear are not in the correct order. Make up fresh
+    -- variables for all fields and add guards after matching, to force the
+    -- evaluation in the correct order.
+  | otherwise = do
+      arg_var_pats    <- mkPmVars arg_tys
+      translated_pats <- forM matched_pats $ \(x,pat) -> do
+        pvec <- translatePat fam_insts pat
+        return (x, pvec)
+
+      let zipped = zip orig_lbls [ x | PmVar x <- arg_var_pats ]
+          guards = map (\(name,pvec) -> case lookup name zipped of
+                            Just x  -> PmGrd pvec (PmExprVar (idName x))
+                            Nothing -> panic "translateConPatVec: lookup")
+                       translated_pats
+
+      return (arg_var_pats ++ guards)
+  where
+    -- The actual argument types (instantiated)
+    arg_tys = conLikeInstOrigArgTys c (univ_tys ++ mkTyVarTys ex_tvs)
+
+    -- Some label information
+    orig_lbls    = map flSelector $ conLikeFieldLabels c
+    matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x))
+                   | (dL->L _ x) <- fs]
+    matched_lbls = [ name | (name, _pat) <- matched_pats ]
+
+    subsetOf :: Eq a => [a] -> [a] -> Bool
+    subsetOf []     _  = True
+    subsetOf (_:_)  [] = False
+    subsetOf (x:xs) (y:ys)
+      | x == y    = subsetOf    xs  ys
+      | otherwise = subsetOf (x:xs) ys
+
+-- Translate a single match
+translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc)
+               -> DsM (PatVec,[PatVec])
+translateMatch fam_insts (dL->L _ (Match { m_pats = lpats, m_grhss = grhss })) =
+  do
+  pats'   <- concat <$> translatePatVec fam_insts pats
+  guards' <- mapM (translateGuards fam_insts) guards
+  return (pats', guards')
+  where
+    extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]
+    extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs
+    extractGuards _                       = panic "translateMatch"
+
+    pats   = map unLoc lpats
+    guards = map extractGuards (grhssGRHSs grhss)
+translateMatch _ _ = panic "translateMatch"
+
+-- -----------------------------------------------------------------------
+-- * Transform source guards (GuardStmt Id) to PmPats (Pattern)
+
+-- | Translate a list of guard statements to a pattern vector
+translateGuards :: FamInstEnvs -> [GuardStmt GhcTc] -> DsM PatVec
+translateGuards fam_insts guards = do
+  all_guards <- concat <$> mapM (translateGuard fam_insts) guards
+  return (replace_unhandled all_guards)
+  -- It should have been (return all_guards) but it is too expressive.
+  -- Since the term oracle does not handle all constraints we generate,
+  -- we (hackily) replace all constraints the oracle cannot handle with a
+  -- single one (we need to know if there is a possibility of falure).
+  -- See Note [Guards and Approximation] for all guard-related approximations
+  -- we implement.
+  where
+    replace_unhandled :: PatVec -> PatVec
+    replace_unhandled gv
+      | any_unhandled gv = fake_pat : [ p | p <- gv, shouldKeep p ]
+      | otherwise        = gv
+
+    any_unhandled :: PatVec -> Bool
+    any_unhandled gv = any (not . shouldKeep) gv
+
+    shouldKeep :: Pattern -> Bool
+    shouldKeep p
+      | PmVar {} <- p      = True
+      | PmCon {} <- p      = singleConstructor (pm_con_con p)
+                             && all shouldKeep (pm_con_args p)
+    shouldKeep (PmGrd pv e)
+      | all shouldKeep pv  = True
+      | isNotPmExprOther e = True  -- expensive but we want it
+    shouldKeep _other_pat  = False -- let the rest..
+
+-- | Check whether a pattern can fail to match
+cantFailPattern :: Pattern -> Bool
+cantFailPattern p
+  | PmVar {} <- p = True
+  | PmCon {} <- p = singleConstructor (pm_con_con p)
+                    && all cantFailPattern (pm_con_args p)
+cantFailPattern (PmGrd pv _e)
+                  = all cantFailPattern pv
+cantFailPattern _ = False
+
+-- | Translate a guard statement to Pattern
+translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec
+translateGuard fam_insts guard = case guard of
+  BodyStmt _   e _ _ -> translateBoolGuard e
+  LetStmt  _   binds -> translateLet (unLoc binds)
+  BindStmt _ p e _ _ -> translateBind fam_insts p e
+  LastStmt        {} -> panic "translateGuard LastStmt"
+  ParStmt         {} -> panic "translateGuard ParStmt"
+  TransStmt       {} -> panic "translateGuard TransStmt"
+  RecStmt         {} -> panic "translateGuard RecStmt"
+  ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"
+  XStmtLR         {} -> panic "translateGuard RecStmt"
+
+-- | Translate let-bindings
+translateLet :: HsLocalBinds GhcTc -> DsM PatVec
+translateLet _binds = return []
+
+-- | Translate a pattern guard
+translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec
+translateBind fam_insts (dL->L _ p) e = do
+  ps <- translatePat fam_insts p
+  return [mkGuard ps (unLoc e)]
+
+-- | Translate a boolean guard
+translateBoolGuard :: LHsExpr GhcTc -> DsM PatVec
+translateBoolGuard e
+  | isJust (isTrueLHsExpr e) = return []
+    -- The formal thing to do would be to generate (True <- True)
+    -- but it is trivial to solve so instead we give back an empty
+    -- PatVec for efficiency
+  | otherwise = return [mkGuard [truePattern] (unLoc e)]
+
+{- Note [Guards and Approximation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Even if the algorithm is really expressive, the term oracle we use is not.
+Hence, several features are not translated *properly* but we approximate.
+The list includes:
+
+1. View Patterns
+----------------
+A view pattern @(f -> p)@ should be translated to @x (p <- f x)@. The term
+oracle does not handle function applications so we know that the generated
+constraints will not be handled at the end. Hence, we distinguish between two
+cases:
+  a) Pattern @p@ cannot fail. Then this is just a binding and we do the *right
+     thing*.
+  b) Pattern @p@ can fail. This means that when checking the guard, we will
+     generate several cases, with no useful information. E.g.:
+
+       h (f -> [a,b]) = ...
+       h x ([a,b] <- f x) = ...
+
+       uncovered set = { [x |> { False ~ (f x ~ [])            }]
+                       , [x |> { False ~ (f x ~ (t1:[]))       }]
+                       , [x |> { False ~ (f x ~ (t1:t2:t3:t4)) }] }
+
+     So we have two problems:
+       1) Since we do not print the constraints in the general case (they may
+          be too many), the warning will look like this:
+
+            Pattern match(es) are non-exhaustive
+            In an equation for `h':
+                Patterns not matched:
+                    _
+                    _
+                    _
+          Which is not short and not more useful than a single underscore.
+       2) The size of the uncovered set increases a lot, without gaining more
+          expressivity in our warnings.
+
+     Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy*
+     @fake_pat@: @True <- _@. That is, we record that there is a possibility
+     of failure but we minimize it to a True/False. This generates a single
+     warning and much smaller uncovered sets.
+
+2. Overloaded Lists
+-------------------
+An overloaded list @[...]@ should be translated to @x ([...] <- toList x)@. The
+problem is exactly like above, as its solution. For future reference, the code
+below is the *right thing to do*:
+
+   ListPat (ListPatTc elem_ty (Just (pat_ty, _to_list))) lpats
+     otherwise -> do
+       (xp, xe) <- mkPmId2Forms pat_ty
+       ps       <- translatePatVec (map unLoc lpats)
+       let pats = foldr (mkListPatVec elem_ty) [nilPattern elem_ty] ps
+           g    = mkGuard pats (HsApp (noLoc to_list) xe)
+       return [xp,g]
+
+3. Overloaded Literals
+----------------------
+The case with literals is a bit different. a literal @l@ should be translated
+to @x (True <- x == from l)@. Since we want to have better warnings for
+overloaded literals as it is a very common feature, we treat them differently.
+They are mainly covered in Note [Undecidable Equality for Overloaded Literals]
+in PmExpr.
+
+4. N+K Patterns & Pattern Synonyms
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An n+k pattern (n+k) should be translated to @x (True <- x >= k) (n <- x-k)@.
+Since the only pattern of the three that causes failure is guard @(n <- x-k)@,
+and has two possible outcomes. Hence, there is no benefit in using a dummy and
+we implement the proper thing. Pattern synonyms are simply not implemented yet.
+Hence, to be conservative, we generate a dummy pattern, assuming that the
+pattern can fail.
+
+5. Actual Guards
+----------------
+During translation, boolean guards and pattern guards are translated properly.
+Let bindings though are omitted by function @translateLet@. Since they are lazy
+bindings, we do not actually want to generate a (strict) equality (like we do
+in the pattern bind case). Hence, we safely drop them.
+
+Additionally, top-level guard translation (performed by @translateGuards@)
+replaces guards that cannot be reasoned about (like the ones we described in
+1-4) with a single @fake_pat@ to record the possibility of failure to match.
+
+Note [Translate CoPats]
+~~~~~~~~~~~~~~~~~~~~~~~
+The pattern match checker did not know how to handle coerced patterns `CoPat`
+efficiently, which gave rise to #11276. The original approach translated
+`CoPat`s:
+
+    pat |> co    ===>    x (pat <- (e |> co))
+
+Instead, we now check whether the coercion is a hole or if it is just refl, in
+which case we can drop it. Unfortunately, data families generate useful
+coercions so guards are still generated in these cases and checking data
+families is not really efficient.
+
+%************************************************************************
+%*                                                                      *
+                 Utilities for Pattern Match Checking
+%*                                                                      *
+%************************************************************************
+-}
+
+-- ----------------------------------------------------------------------------
+-- * Basic utilities
+
+-- | Get the type out of a PmPat. For guard patterns (ps <- e) we use the type
+-- of the first (or the single -WHEREVER IT IS- valid to use?) pattern
+pmPatType :: PmPat p -> Type
+pmPatType (PmCon { pm_con_con = con, pm_con_arg_tys = tys })
+  = conLikeResTy con tys
+pmPatType (PmVar  { pm_var_id  = x }) = idType x
+pmPatType (PmLit  { pm_lit_lit = l }) = pmLitType l
+pmPatType (PmNLit { pm_lit_id  = x }) = idType x
+pmPatType (PmGrd  { pm_grd_pv  = pv })
+  = ASSERT(patVecArity pv == 1) (pmPatType p)
+  where Just p = find ((==1) . patternArity) pv
+
+-- | Information about a conlike that is relevant to coverage checking.
+-- It is called an \"inhabitation candidate\" since it is a value which may
+-- possibly inhabit some type, but only if its term constraint ('ic_tm_ct')
+-- and type constraints ('ic_ty_cs') are permitting, and if all of its strict
+-- argument types ('ic_strict_arg_tys') are inhabitable.
+-- See @Note [Extensions to GADTs Meet Their Match]@.
+data InhabitationCandidate =
+  InhabitationCandidate
+  { ic_val_abs        :: ValAbs
+  , ic_tm_ct          :: ComplexEq
+  , ic_ty_cs          :: Bag EvVar
+  , ic_strict_arg_tys :: [Type]
+  }
+
+{-
+Note [Extensions to GADTs Meet Their Match]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The GADTs Meet Their Match paper presents the formalism that GHC's coverage
+checker adheres to. Since the paper's publication, there have been some
+additional features added to the coverage checker which are not described in
+the paper. This Note serves as a reference for these new features.
+
+-----
+-- Strict argument type constraints
+-----
+
+In the ConVar case of clause processing, each conlike K traditionally
+generates two different forms of constraints:
+
+* A term constraint (e.g., x ~ K y1 ... yn)
+* Type constraints from the conlike's context (e.g., if K has type
+  forall bs. Q => s1 .. sn -> T tys, then Q would be its type constraints)
+
+As it turns out, these alone are not enough to detect a certain class of
+unreachable code. Consider the following example (adapted from #15305):
+
+  data K = K1 | K2 !Void
+
+  f :: K -> ()
+  f K1 = ()
+
+Even though `f` doesn't match on `K2`, `f` is exhaustive in its patterns. Why?
+Because it's impossible to construct a terminating value of type `K` using the
+`K2` constructor, and thus it's impossible for `f` to ever successfully match
+on `K2`.
+
+The reason is because `K2`'s field of type `Void` is //strict//. Because there
+are no terminating values of type `Void`, any attempt to construct something
+using `K2` will immediately loop infinitely or throw an exception due to the
+strictness annotation. (If the field were not strict, then `f` could match on,
+say, `K2 undefined` or `K2 (let x = x in x)`.)
+
+Since neither the term nor type constraints mentioned above take strict
+argument types into account, we make use of the `nonVoid` function to
+determine whether a strict type is inhabitable by a terminating value or not.
+
+`nonVoid ty` returns True when either:
+1. `ty` has at least one InhabitationCandidate for which both its term and type
+   constraints are satifiable, and `nonVoid` returns `True` for all of the
+   strict argument types in that InhabitationCandidate.
+2. We're unsure if it's inhabited by a terminating value.
+
+`nonVoid ty` returns False when `ty` is definitely uninhabited by anything
+(except bottom). Some examples:
+
+* `nonVoid Void` returns False, since Void has no InhabitationCandidates.
+  (This is what lets us discard the `K2` constructor in the earlier example.)
+* `nonVoid (Int :~: Int)` returns True, since it has an InhabitationCandidate
+  (through the Refl constructor), and its term constraint (x ~ Refl) and
+  type constraint (Int ~ Int) are satisfiable.
+* `nonVoid (Int :~: Bool)` returns False. Although it has an
+  InhabitationCandidate (by way of Refl), its type constraint (Int ~ Bool) is
+  not satisfiable.
+* Given the following definition of `MyVoid`:
+
+    data MyVoid = MkMyVoid !Void
+
+  `nonVoid MyVoid` returns False. The InhabitationCandidate for the MkMyVoid
+  constructor contains Void as a strict argument type, and since `nonVoid Void`
+  returns False, that InhabitationCandidate is discarded, leaving no others.
+
+* Performance considerations
+
+We must be careful when recursively calling `nonVoid` on the strict argument
+types of an InhabitationCandidate, because doing so naïvely can cause GHC to
+fall into an infinite loop. Consider the following example:
+
+  data Abyss = MkAbyss !Abyss
+
+  stareIntoTheAbyss :: Abyss -> a
+  stareIntoTheAbyss x = case x of {}
+
+In principle, stareIntoTheAbyss is exhaustive, since there is no way to
+construct a terminating value using MkAbyss. However, both the term and type
+constraints for MkAbyss are satisfiable, so the only way one could determine
+that MkAbyss is unreachable is to check if `nonVoid Abyss` returns False.
+There is only one InhabitationCandidate for Abyss—MkAbyss—and both its term
+and type constraints are satisfiable, so we'd need to check if `nonVoid Abyss`
+returns False... and now we've entered an infinite loop!
+
+To avoid this sort of conundrum, `nonVoid` uses a simple test to detect the
+presence of recursive types (through `checkRecTc`), and if recursion is
+detected, we bail out and conservatively assume that the type is inhabited by
+some terminating value. This avoids infinite loops at the expense of making
+the coverage checker incomplete with respect to functions like
+stareIntoTheAbyss above. Then again, the same problem occurs with recursive
+newtypes, like in the following code:
+
+  newtype Chasm = MkChasm Chasm
+
+  gazeIntoTheChasm :: Chasm -> a
+  gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive
+
+So this limitation is somewhat understandable.
+
+Note that even with this recursion detection, there is still a possibility that
+`nonVoid` can run in exponential time. Consider the following data type:
+
+  data T = MkT !T !T !T
+
+If we call `nonVoid` on each of its fields, that will require us to once again
+check if `MkT` is inhabitable in each of those three fields, which in turn will
+require us to check if `MkT` is inhabitable again... As you can see, the
+branching factor adds up quickly, and if the recursion depth limit is, say,
+100, then `nonVoid T` will effectively take forever.
+
+To mitigate this, we check the branching factor every time we are about to call
+`nonVoid` on a list of strict argument types. If the branching factor exceeds 1
+(i.e., if there is potential for exponential runtime), then we limit the
+maximum recursion depth to 1 to mitigate the problem. If the branching factor
+is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay
+to stick with a larger maximum recursion depth.
+
+Another microoptimization applies to data types like this one:
+
+  data S a = ![a] !T
+
+Even though there is a strict field of type [a], it's quite silly to call
+nonVoid on it, since it's "obvious" that it is inhabitable. To make this
+intuition formal, we say that a type is definitely inhabitable (DI) if:
+
+  * It has at least one constructor C such that:
+    1. C has no equality constraints (since they might be unsatisfiable)
+    2. C has no strict argument types (since they might be uninhabitable)
+
+It's relatively cheap to cheap if a type is DI, so before we call `nonVoid`
+on a list of strict argument types, we filter out all of the DI ones.
+-}
+
+instance Outputable InhabitationCandidate where
+  ppr (InhabitationCandidate { ic_val_abs = va, ic_tm_ct = tm_ct
+                             , ic_ty_cs = ty_cs
+                             , ic_strict_arg_tys = strict_arg_tys }) =
+    text "InhabitationCandidate" <+>
+      vcat [ text "ic_val_abs        =" <+> ppr va
+           , text "ic_tm_ct          =" <+> ppr tm_ct
+           , text "ic_ty_cs          =" <+> ppr ty_cs
+           , text "ic_strict_arg_tys =" <+> ppr strict_arg_tys ]
+
+-- | Generate an 'InhabitationCandidate' for a given conlike (generate
+-- fresh variables of the appropriate type for arguments)
+mkOneConFull :: Id -> ConLike -> DsM InhabitationCandidate
+--  *  x :: T tys, where T is an algebraic data type
+--     NB: in the case of a data family, T is the *representation* TyCon
+--     e.g.   data instance T (a,b) = T1 a b
+--       leads to
+--            data TPair a b = T1 a b  -- The "representation" type
+--       It is TPair, not T, that is given to mkOneConFull
+--
+--  * 'con' K is a conlike of data type T
+--
+-- After instantiating the universal tyvars of K we get
+--          K tys :: forall bs. Q => s1 .. sn -> T tys
+--
+-- Suppose y1 is a strict field. Then we get
+-- Results: ic_val_abs:        K (y1::s1) .. (yn::sn)
+--          ic_tm_ct:          x ~ K y1..yn
+--          ic_ty_cs:          Q
+--          ic_strict_arg_tys: [s1]
+mkOneConFull x con = do
+  let res_ty  = idType x
+      (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, con_res_ty)
+        = conLikeFullSig con
+      arg_is_banged = map isBanged $ conLikeImplBangs con
+      tc_args = tyConAppArgs res_ty
+      subst1  = case con of
+                  RealDataCon {} -> zipTvSubst univ_tvs tc_args
+                  PatSynCon {}   -> expectJust "mkOneConFull" (tcMatchTy con_res_ty res_ty)
+                                    -- See Note [Pattern synonym result type] in PatSyn
+
+  (subst, ex_tvs') <- cloneTyVarBndrs subst1 ex_tvs <$> getUniqueSupplyM
+
+  let arg_tys' = substTys subst arg_tys
+  -- Fresh term variables (VAs) as arguments to the constructor
+  arguments <-  mapM mkPmVar arg_tys'
+  -- All constraints bound by the constructor (alpha-renamed)
+  let theta_cs = substTheta subst (eqSpecPreds eq_spec ++ thetas)
+  evvars <- mapM (nameType "pm") theta_cs
+  let con_abs  = PmCon { pm_con_con     = con
+                       , pm_con_arg_tys = tc_args
+                       , pm_con_tvs     = ex_tvs'
+                       , pm_con_dicts   = evvars
+                       , pm_con_args    = arguments }
+      strict_arg_tys = filterByList arg_is_banged arg_tys'
+  return $ InhabitationCandidate
+           { ic_val_abs        = con_abs
+           , ic_tm_ct          = (PmExprVar (idName x), vaToPmExpr con_abs)
+           , ic_ty_cs          = listToBag evvars
+           , ic_strict_arg_tys = strict_arg_tys
+           }
+
+-- ----------------------------------------------------------------------------
+-- * More smart constructors and fresh variable generation
+
+-- | Create a guard pattern
+mkGuard :: PatVec -> HsExpr GhcTc -> Pattern
+mkGuard pv e
+  | all cantFailPattern pv = PmGrd pv expr
+  | PmExprOther {} <- expr = fake_pat
+  | otherwise              = PmGrd pv expr
+  where
+    expr = hsExprToPmExpr e
+
+-- | Create a term equality of the form: `(False ~ (x ~ lit))`
+mkNegEq :: Id -> PmLit -> ComplexEq
+mkNegEq x l = (falsePmExpr, PmExprVar (idName x) `PmExprEq` PmExprLit l)
+{-# INLINE mkNegEq #-}
+
+-- | Create a term equality of the form: `(x ~ lit)`
+mkPosEq :: Id -> PmLit -> ComplexEq
+mkPosEq x l = (PmExprVar (idName x), PmExprLit l)
+{-# INLINE mkPosEq #-}
+
+-- | Create a term equality of the form: `(x ~ x)`
+-- (always discharged by the term oracle)
+mkIdEq :: Id -> ComplexEq
+mkIdEq x = (PmExprVar name, PmExprVar name)
+  where name = idName x
+{-# INLINE mkIdEq #-}
+
+-- | Generate a variable pattern of a given type
+mkPmVar :: Type -> DsM (PmPat p)
+mkPmVar ty = PmVar <$> mkPmId ty
+{-# INLINE mkPmVar #-}
+
+-- | Generate many variable patterns, given a list of types
+mkPmVars :: [Type] -> DsM PatVec
+mkPmVars tys = mapM mkPmVar tys
+{-# INLINE mkPmVars #-}
+
+-- | Generate a fresh `Id` of a given type
+mkPmId :: Type -> DsM Id
+mkPmId ty = getUniqueM >>= \unique ->
+  let occname = mkVarOccFS $ fsLit "$pm"
+      name    = mkInternalName unique occname noSrcSpan
+  in  return (mkLocalId name ty)
+
+-- | Generate a fresh term variable of a given and return it in two forms:
+-- * A variable pattern
+-- * A variable expression
+mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)
+mkPmId2Forms ty = do
+  x <- mkPmId ty
+  return (PmVar x, noLoc (HsVar noExt (noLoc x)))
+
+-- ----------------------------------------------------------------------------
+-- * Converting between Value Abstractions, Patterns and PmExpr
+
+-- | Convert a value abstraction an expression
+vaToPmExpr :: ValAbs -> PmExpr
+vaToPmExpr (PmCon  { pm_con_con = c, pm_con_args = ps })
+  = PmExprCon c (map vaToPmExpr ps)
+vaToPmExpr (PmVar  { pm_var_id  = x }) = PmExprVar (idName x)
+vaToPmExpr (PmLit  { pm_lit_lit = l }) = PmExprLit l
+vaToPmExpr (PmNLit { pm_lit_id  = x }) = PmExprVar (idName x)
+
+-- | Convert a pattern vector to a list of value abstractions by dropping the
+-- guards (See Note [Translating As Patterns])
+coercePatVec :: PatVec -> [ValAbs]
+coercePatVec pv = concatMap coercePmPat pv
+
+-- | Convert a pattern to a list of value abstractions (will be either an empty
+-- list if the pattern is a guard pattern, or a singleton list in all other
+-- cases) by dropping the guards (See Note [Translating As Patterns])
+coercePmPat :: Pattern -> [ValAbs]
+coercePmPat (PmVar { pm_var_id  = x }) = [PmVar { pm_var_id  = x }]
+coercePmPat (PmLit { pm_lit_lit = l }) = [PmLit { pm_lit_lit = l }]
+coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
+                   , pm_con_tvs = tvs, pm_con_dicts = dicts
+                   , pm_con_args = args })
+  = [PmCon { pm_con_con  = con, pm_con_arg_tys = arg_tys
+           , pm_con_tvs  = tvs, pm_con_dicts = dicts
+           , pm_con_args = coercePatVec args }]
+coercePmPat (PmGrd {}) = [] -- drop the guards
+
+-- | Check whether a data constructor is the only way to construct
+-- a data type.
+singleConstructor :: ConLike -> Bool
+singleConstructor (RealDataCon dc) =
+  case tyConDataCons (dataConTyCon dc) of
+    [_] -> True
+    _   -> False
+singleConstructor _ = False
+
+-- | For a given conlike, finds all the sets of patterns which could
+-- be relevant to that conlike by consulting the result type.
+--
+-- These come from two places.
+--  1. From data constructors defined with the result type constructor.
+--  2. From `COMPLETE` pragmas which have the same type as the result
+--     type constructor. Note that we only use `COMPLETE` pragmas
+--     *all* of whose pattern types match. See #14135
+allCompleteMatches :: ConLike -> [Type] -> DsM [(Provenance, [ConLike])]
+allCompleteMatches cl tys = do
+  let fam = case cl of
+           RealDataCon dc ->
+            [(FromBuiltin, map RealDataCon (tyConDataCons (dataConTyCon dc)))]
+           PatSynCon _    -> []
+      ty  = conLikeResTy cl tys
+  pragmas <- case splitTyConApp_maybe ty of
+               Just (tc, _) -> dsGetCompleteMatches tc
+               Nothing      -> return []
+  let fams cm = (FromComplete,) <$>
+                mapM dsLookupConLike (completeMatchConLikes cm)
+  from_pragma <- filter (\(_,m) -> isValidCompleteMatch ty m) <$>
+                mapM fams pragmas
+  let final_groups = fam ++ from_pragma
+  return final_groups
+    where
+      -- Check that all the pattern synonym return types in a `COMPLETE`
+      -- pragma subsume the type we're matching.
+      -- See Note [Filtering out non-matching COMPLETE sets]
+      isValidCompleteMatch :: Type -> [ConLike] -> Bool
+      isValidCompleteMatch ty = all go
+        where
+          go (RealDataCon {}) = True
+          go (PatSynCon psc)  = isJust $ flip tcMatchTy ty $ patSynResTy
+                                       $ patSynSig psc
+
+          patSynResTy (_, _, _, _, _, res_ty) = res_ty
+
+{-
+Note [Filtering out non-matching COMPLETE sets]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Currently, conlikes in a COMPLETE set are simply grouped by the
+type constructor heading the return type. This is nice and simple, but it does
+mean that there are scenarios when a COMPLETE set might be incompatible with
+the type of a scrutinee. For instance, consider (from #14135):
+
+  data Foo a = Foo1 a | Foo2 a
+
+  pattern MyFoo2 :: Int -> Foo Int
+  pattern MyFoo2 i = Foo2 i
+
+  {-# COMPLETE Foo1, MyFoo2 #-}
+
+  f :: Foo a -> a
+  f (Foo1 x) = x
+
+`f` has an incomplete pattern-match, so when choosing which constructors to
+report as unmatched in a warning, GHC must choose between the original set of
+data constructors {Foo1, Foo2} and the COMPLETE set {Foo1, MyFoo2}. But observe
+that GHC shouldn't even consider the COMPLETE set as a possibility: the return
+type of MyFoo2, Foo Int, does not match the type of the scrutinee, Foo a, since
+there's no substitution `s` such that s(Foo Int) = Foo a.
+
+To ensure that GHC doesn't pick this COMPLETE set, it checks each pattern
+synonym constructor's return type matches the type of the scrutinee, and if one
+doesn't, then we remove the whole COMPLETE set from consideration.
+
+One might wonder why GHC only checks /pattern synonym/ constructors, and not
+/data/ constructors as well. The reason is because that the type of a
+GADT constructor very well may not match the type of a scrutinee, and that's
+OK. Consider this example (from #14059):
+
+  data SBool (z :: Bool) where
+    SFalse :: SBool False
+    STrue  :: SBool True
+
+  pattern STooGoodToBeTrue :: forall (z :: Bool). ()
+                           => z ~ True
+                           => SBool z
+  pattern STooGoodToBeTrue = STrue
+  {-# COMPLETE SFalse, STooGoodToBeTrue #-}
+
+  wobble :: SBool z -> Bool
+  wobble STooGoodToBeTrue = True
+
+In the incomplete pattern match for `wobble`, we /do/ want to warn that SFalse
+should be matched against, even though its type, SBool False, does not match
+the scrutinee type, SBool z.
+-}
+
+-- -----------------------------------------------------------------------
+-- * Types and constraints
+
+newEvVar :: Name -> Type -> EvVar
+newEvVar name ty = mkLocalId name ty
+
+nameType :: String -> Type -> DsM EvVar
+nameType name ty = do
+  unique <- getUniqueM
+  let occname = mkVarOccFS (fsLit (name++"_"++show unique))
+      idname  = mkInternalName unique occname noSrcSpan
+  return (newEvVar idname ty)
+
+{-
+%************************************************************************
+%*                                                                      *
+                              The type oracle
+%*                                                                      *
+%************************************************************************
+-}
+
+-- | Check whether a set of type constraints is satisfiable.
+tyOracle :: Bag EvVar -> PmM Bool
+tyOracle evs
+  = liftD $
+    do { ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability evs
+       ; case res of
+            Just sat -> return sat
+            Nothing  -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) }
+
+{-
+%************************************************************************
+%*                                                                      *
+                             Sanity Checks
+%*                                                                      *
+%************************************************************************
+-}
+
+-- | The arity of a pattern/pattern vector is the
+-- number of top-level patterns that are not guards
+type PmArity = Int
+
+-- | Compute the arity of a pattern vector
+patVecArity :: PatVec -> PmArity
+patVecArity = sum . map patternArity
+
+-- | Compute the arity of a pattern
+patternArity :: Pattern -> PmArity
+patternArity (PmGrd {}) = 0
+patternArity _other_pat = 1
+
+{-
+%************************************************************************
+%*                                                                      *
+            Heart of the algorithm: Function pmcheck
+%*                                                                      *
+%************************************************************************
+
+Main functions are:
+
+* mkInitialUncovered :: [Id] -> PmM Uncovered
+
+  Generates the initial uncovered set. Term and type constraints in scope
+  are checked, if they are inconsistent, the set is empty, otherwise, the
+  set contains only a vector of variables with the constraints in scope.
+
+* pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult
+
+  Checks redundancy, coverage and inaccessibility, using auxilary functions
+  `pmcheckGuards` and `pmcheckHd`. Mainly handles the guard case which is
+  common in all three checks (see paper) and calls `pmcheckGuards` when the
+  whole clause is checked, or `pmcheckHd` when the pattern vector does not
+  start with a guard.
+
+* pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult
+
+  Processes the guards.
+
+* pmcheckHd :: Pattern -> PatVec -> [PatVec]
+          -> ValAbs -> ValVec -> PmM PartialResult
+
+  Worker: This function implements functions `covered`, `uncovered` and
+  `divergent` from the paper at once. Slightly different from the paper because
+  it does not even produce the covered and uncovered sets. Since we only care
+  about whether a clause covers SOMETHING or if it may forces ANY argument, we
+  only store a boolean in both cases, for efficiency.
+-}
+
+-- | Lift a pattern matching action from a single value vector abstration to a
+-- value set abstraction, but calling it on every vector and the combining the
+-- results.
+runMany :: (ValVec -> PmM PartialResult) -> (Uncovered -> PmM PartialResult)
+runMany _ [] = return mempty
+runMany pm (m:ms) = mappend <$> pm m <*> runMany pm ms
+
+-- | Generate the initial uncovered set. It initializes the
+-- delta with all term and type constraints in scope.
+mkInitialUncovered :: [Id] -> PmM Uncovered
+mkInitialUncovered vars = do
+  delta <- pmInitialTmTyCs
+  let patterns = map PmVar vars
+  return [ValVec patterns delta]
+
+-- | Increase the counter for elapsed algorithm iterations, check that the
+-- limit is not exceeded and call `pmcheck`
+pmcheckI :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult
+pmcheckI ps guards vva = do
+  n <- liftD incrCheckPmIterDs
+  tracePm "pmCheck" (ppr n <> colon <+> pprPatVec ps
+                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))
+                        $$ pprValVecDebug vva)
+  res <- pmcheck ps guards vva
+  tracePm "pmCheckResult:" (ppr res)
+  return res
+{-# INLINE pmcheckI #-}
+
+-- | Increase the counter for elapsed algorithm iterations, check that the
+-- limit is not exceeded and call `pmcheckGuards`
+pmcheckGuardsI :: [PatVec] -> ValVec -> PmM PartialResult
+pmcheckGuardsI gvs vva = liftD incrCheckPmIterDs >> pmcheckGuards gvs vva
+{-# INLINE pmcheckGuardsI #-}
+
+-- | Increase the counter for elapsed algorithm iterations, check that the
+-- limit is not exceeded and call `pmcheckHd`
+pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec
+           -> PmM PartialResult
+pmcheckHdI p ps guards va vva = do
+  n <- liftD incrCheckPmIterDs
+  tracePm "pmCheckHdI" (ppr n <> colon <+> pprPmPatDebug p
+                        $$ pprPatVec ps
+                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))
+                        $$ pprPmPatDebug va
+                        $$ pprValVecDebug vva)
+
+  res <- pmcheckHd p ps guards va vva
+  tracePm "pmCheckHdI: res" (ppr res)
+  return res
+{-# INLINE pmcheckHdI #-}
+
+-- | Matching function: Check simultaneously a clause (takes separately the
+-- patterns and the list of guards) for exhaustiveness, redundancy and
+-- inaccessibility.
+pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult
+pmcheck [] guards vva@(ValVec [] _)
+  | null guards = return $ mempty { presultCovered = Covered }
+  | otherwise   = pmcheckGuardsI guards vva
+
+-- Guard
+pmcheck (p@(PmGrd pv e) : ps) guards vva@(ValVec vas delta)
+    -- short-circuit if the guard pattern is useless.
+    -- we just have two possible outcomes: fail here or match and recurse
+    -- none of the two contains any useful information about the failure
+    -- though. So just have these two cases but do not do all the boilerplate
+  | isFakeGuard pv e = forces . mkCons vva <$> pmcheckI ps guards vva
+  | otherwise = do
+      y <- liftD $ mkPmId (pmPatType p)
+      let tm_state = extendSubst y e (delta_tm_cs delta)
+          delta'   = delta { delta_tm_cs = tm_state }
+      utail <$> pmcheckI (pv ++ ps) guards (ValVec (PmVar y : vas) delta')
+
+pmcheck [] _ (ValVec (_:_) _) = panic "pmcheck: nil-cons"
+pmcheck (_:_) _ (ValVec [] _) = panic "pmcheck: cons-nil"
+
+pmcheck (p:ps) guards (ValVec (va:vva) delta)
+  = pmcheckHdI p ps guards va (ValVec vva delta)
+
+-- | Check the list of guards
+pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult
+pmcheckGuards []       vva = return (usimple [vva])
+pmcheckGuards (gv:gvs) vva = do
+  (PartialResult prov1 cs vsa ds) <- pmcheckI gv [] vva
+  (PartialResult prov2 css vsas dss) <- runMany (pmcheckGuardsI gvs) vsa
+  return $ PartialResult (prov1 `mappend` prov2)
+                         (cs `mappend` css)
+                         vsas
+                         (ds `mappend` dss)
+
+-- | Worker function: Implements all cases described in the paper for all three
+-- functions (`covered`, `uncovered` and `divergent`) apart from the `Guard`
+-- cases which are handled by `pmcheck`
+pmcheckHd :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec
+          -> PmM PartialResult
+
+-- Var
+pmcheckHd (PmVar x) ps guards va (ValVec vva delta)
+  | Just tm_state <- solveOneEq (delta_tm_cs delta)
+                                (PmExprVar (idName x), vaToPmExpr va)
+  = ucon va <$> pmcheckI ps guards (ValVec vva (delta {delta_tm_cs = tm_state}))
+  | otherwise = return mempty
+
+-- ConCon
+pmcheckHd ( p@(PmCon { pm_con_con = c1, pm_con_tvs = ex_tvs1
+                     , pm_con_args = args1})) ps guards
+          (va@(PmCon { pm_con_con = c2, pm_con_tvs = ex_tvs2
+                     , pm_con_args = args2})) (ValVec vva delta)
+  | c1 /= c2  =
+    return (usimple [ValVec (va:vva) delta])
+  | otherwise = do
+    let to_evvar tv1 tv2 = nameType "pmConCon" $
+                           mkPrimEqPred (mkTyVarTy tv1) (mkTyVarTy tv2)
+        mb_to_evvar tv1 tv2
+            -- If we have identical constructors but different existential
+            -- tyvars, then generate extra equality constraints to ensure the
+            -- existential tyvars.
+            -- See Note [Coverage checking and existential tyvars].
+          | tv1 == tv2 = pure Nothing
+          | otherwise  = Just <$> to_evvar tv1 tv2
+    evvars <- (listToBag . catMaybes) <$>
+              ASSERT(ex_tvs1 `equalLength` ex_tvs2)
+              liftD (zipWithM mb_to_evvar ex_tvs1 ex_tvs2)
+    let delta' = delta { delta_ty_cs = evvars `unionBags` delta_ty_cs delta }
+    kcon c1 (pm_con_arg_tys p) (pm_con_tvs p) (pm_con_dicts p)
+      <$> pmcheckI (args1 ++ ps) guards (ValVec (args2 ++ vva) delta')
+
+-- LitLit
+pmcheckHd (PmLit l1) ps guards (va@(PmLit l2)) vva =
+  case eqPmLit l1 l2 of
+    True  -> ucon va <$> pmcheckI ps guards vva
+    False -> return $ ucon va (usimple [vva])
+
+-- ConVar
+pmcheckHd (p@(PmCon { pm_con_con = con, pm_con_arg_tys = tys }))
+          ps guards
+          (PmVar x) (ValVec vva delta) = do
+  (prov, complete_match) <- select =<< liftD (allCompleteMatches con tys)
+
+  cons_cs <- mapM (liftD . mkOneConFull x) complete_match
+
+  inst_vsa <- flip mapMaybeM cons_cs $
+      \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct
+                            , ic_ty_cs = ty_cs
+                            , ic_strict_arg_tys = strict_arg_tys } -> do
+    mb_sat <- pmIsSatisfiable delta tm_ct ty_cs strict_arg_tys
+    pure $ fmap (ValVec (va:vva)) mb_sat
+
+  set_provenance prov .
+    force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>
+      runMany (pmcheckI (p:ps) guards) inst_vsa
+
+-- LitVar
+pmcheckHd (p@(PmLit l)) ps guards (PmVar x) (ValVec vva delta)
+  = force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>
+      mkUnion non_matched <$>
+        case solveOneEq (delta_tm_cs delta) (mkPosEq x l) of
+          Just tm_state -> pmcheckHdI p ps guards (PmLit l) $
+                             ValVec vva (delta {delta_tm_cs = tm_state})
+          Nothing       -> return mempty
+  where
+    us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)
+       = [ValVec (PmNLit x [l] : vva) (delta { delta_tm_cs = tm_state })]
+       | otherwise = []
+
+    non_matched = usimple us
+
+-- LitNLit
+pmcheckHd (p@(PmLit l)) ps guards
+          (PmNLit { pm_lit_id = x, pm_lit_not = lits }) (ValVec vva delta)
+  | all (not . eqPmLit l) lits
+  , Just tm_state <- solveOneEq (delta_tm_cs delta) (mkPosEq x l)
+    -- Both guards check the same so it would be sufficient to have only
+    -- the second one. Nevertheless, it is much cheaper to check whether
+    -- the literal is in the list so we check it first, to avoid calling
+    -- the term oracle (`solveOneEq`) if possible
+  = mkUnion non_matched <$>
+      pmcheckHdI p ps guards (PmLit l)
+                (ValVec vva (delta { delta_tm_cs = tm_state }))
+  | otherwise = return non_matched
+  where
+    us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)
+       = [ValVec (PmNLit x (l:lits) : vva) (delta { delta_tm_cs = tm_state })]
+       | otherwise = []
+
+    non_matched = usimple us
+
+-- ----------------------------------------------------------------------------
+-- The following three can happen only in cases like #322 where constructors
+-- and overloaded literals appear in the same match. The general strategy is
+-- to replace the literal (positive/negative) by a variable and recurse. The
+-- fact that the variable is equal to the literal is recorded in `delta` so
+-- no information is lost
+
+-- LitCon
+pmcheckHd (PmLit l) ps guards (va@(PmCon {})) (ValVec vva delta)
+  = do y <- liftD $ mkPmId (pmPatType va)
+       let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)
+           delta'   = delta { delta_tm_cs = tm_state }
+       pmcheckHdI (PmVar y) ps guards va (ValVec vva delta')
+
+-- ConLit
+pmcheckHd (p@(PmCon {})) ps guards (PmLit l) (ValVec vva delta)
+  = do y <- liftD $ mkPmId (pmPatType p)
+       let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)
+           delta'   = delta { delta_tm_cs = tm_state }
+       pmcheckHdI p ps guards (PmVar y) (ValVec vva delta')
+
+-- ConNLit
+pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva
+  = pmcheckHdI p ps guards (PmVar x) vva
+
+-- Impossible: handled by pmcheck
+pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard"
+
+{-
+Note [Coverage checking and existential tyvars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHC's implementation of the pattern-match coverage algorithm (as described in
+the GADTs Meet Their Match paper) must take some care to emit enough type
+constraints when handling data constructors with exisentially quantified type
+variables. To better explain what the challenge is, consider a constructor K
+of the form:
+
+  K @e_1 ... @e_m ev_1 ... ev_v ty_1 ... ty_n :: T u_1 ... u_p
+
+Where:
+
+* e_1, ..., e_m are the existentially bound type variables.
+* ev_1, ..., ev_v are evidence variables, which may inhabit a dictionary type
+  (e.g., Eq) or an equality constraint (e.g., e_1 ~ Int).
+* ty_1, ..., ty_n are the types of K's fields.
+* T u_1 ... u_p is the return type, where T is the data type constructor, and
+  u_1, ..., u_p are the universally quantified type variables.
+
+In the ConVar case, the coverage algorithm will have in hand the constructor
+K as well as a pattern variable (pv :: T PV_1 ... PV_p), where PV_1, ..., PV_p
+are some types that instantiate u_1, ... u_p. The idea is that we should
+substitute PV_1 for u_1, ..., and PV_p for u_p when forming a PmCon (the
+mkOneConFull function accomplishes this) and then hand this PmCon off to the
+ConCon case.
+
+The presence of existentially quantified type variables adds a significant
+wrinkle. We always grab e_1, ..., e_m from the definition of K to begin with,
+but we don't want them to appear in the final PmCon, because then
+calling (mkOneConFull K) for other pattern variables might reuse the same
+existential tyvars, which is certainly wrong.
+
+Previously, GHC's solution to this wrinkle was to always create fresh names
+for the existential tyvars and put them into the PmCon. This works well for
+many cases, but it can break down if you nest GADT pattern matches in just
+the right way. For instance, consider the following program:
+
+    data App f a where
+      App :: f a -> App f (Maybe a)
+
+    data Ty a where
+      TBool :: Ty Bool
+      TInt  :: Ty Int
+
+    data T f a where
+      C :: T Ty (Maybe Bool)
+
+    foo :: T f a -> App f a -> ()
+    foo C (App TBool) = ()
+
+foo is a total program, but with the previous approach to handling existential
+tyvars, GHC would mark foo's patterns as non-exhaustive.
+
+When foo is desugared to Core, it looks roughly like so:
+
+    foo @f @a (C co1 _co2) (App @a1 _co3 (TBool |> co1)) = ()
+
+(Where `a1` is an existential tyvar.)
+
+That, in turn, is processed by the coverage checker to become:
+
+    foo @f @a (C co1 _co2) (App @a1 _co3 (pmvar123 :: f a1))
+      | TBool <- pmvar123 |> co1
+      = ()
+
+Note that the type of pmvar123 is `f a1`—this will be important later.
+
+Now, we proceed with coverage-checking as usual. When we come to the
+ConVar case for App, we create a fresh variable `a2` to represent its
+existential tyvar. At this point, we have the equality constraints
+`(a ~ Maybe a2, a ~ Maybe Bool, f ~ Ty)` in scope.
+
+However, when we check the guard, it will use the type of pmvar123, which is
+`f a1`. Thus, when considering if pmvar123 can match the constructor TInt,
+it will generate the constraint `a1 ~ Int`. This means our final set of
+equality constraints would be:
+
+    f  ~ Ty
+    a  ~ Maybe Bool
+    a  ~ Maybe a2
+    a1 ~ Int
+
+Which is satisfiable! Freshening the existential tyvar `a` to `a2` doomed us,
+because GHC is unable to relate `a2` to `a1`, which really should be the same
+tyvar.
+
+Luckily, we can avoid this pitfall. Recall that the ConVar case was where we
+generated a PmCon with too-fresh existentials. But after ConVar, we have the
+ConCon case, which considers whether each constructor of a particular data type
+can be matched on in a particular spot.
+
+In the case of App, when we get to the ConCon case, we will compare our
+original App PmCon (from the source program) to the App PmCon created from the
+ConVar case. In the former PmCon, we have `a1` in hand, which is exactly the
+existential tyvar we want! Thus, we can force `a1` to be the same as `a2` here
+by emitting an additional `a1 ~ a2` constraint. Now our final set of equality
+constraints will be:
+
+    f  ~ Ty
+    a  ~ Maybe Bool
+    a  ~ Maybe a2
+    a1 ~ Int
+    a1 ~ a2
+
+Which is unsatisfiable, as we desired, since we now have that
+Int ~ a1 ~ a2 ~ Bool.
+
+In general, App might have more than one constructor, in which case we
+couldn't reuse the existential tyvar for App for a different constructor. This
+means that we can only use this trick in ConCon when the constructors are the
+same. But this is fine, since this is the only scenario where this situation
+arises in the first place!
+-}
+
+-- ----------------------------------------------------------------------------
+-- * Utilities for main checking
+
+updateVsa :: (ValSetAbs -> ValSetAbs) -> (PartialResult -> PartialResult)
+updateVsa f p@(PartialResult { presultUncovered = old })
+  = p { presultUncovered = f old }
+
+
+-- | Initialise with default values for covering and divergent information.
+usimple :: ValSetAbs -> PartialResult
+usimple vsa = mempty { presultUncovered = vsa }
+
+-- | Take the tail of all value vector abstractions in the uncovered set
+utail :: PartialResult -> PartialResult
+utail = updateVsa upd
+  where upd vsa = [ ValVec vva delta | ValVec (_:vva) delta <- vsa ]
+
+-- | Prepend a value abstraction to all value vector abstractions in the
+-- uncovered set
+ucon :: ValAbs -> PartialResult -> PartialResult
+ucon va = updateVsa upd
+  where
+    upd vsa = [ ValVec (va:vva) delta | ValVec vva delta <- vsa ]
+
+-- | Given a data constructor of arity `a` and an uncovered set containing
+-- value vector abstractions of length `(a+n)`, pass the first `n` value
+-- abstractions to the constructor (Hence, the resulting value vector
+-- abstractions will have length `n+1`)
+kcon :: ConLike -> [Type] -> [TyVar] -> [EvVar]
+     -> PartialResult -> PartialResult
+kcon con arg_tys ex_tvs dicts
+  = let n = conLikeArity con
+        upd vsa =
+          [ ValVec (va:vva) delta
+          | ValVec vva' delta <- vsa
+          , let (args, vva) = splitAt n vva'
+          , let va = PmCon { pm_con_con     = con
+                            , pm_con_arg_tys = arg_tys
+                            , pm_con_tvs     = ex_tvs
+                            , pm_con_dicts   = dicts
+                            , pm_con_args    = args } ]
+    in updateVsa upd
+
+-- | Get the union of two covered, uncovered and divergent value set
+-- abstractions. Since the covered and divergent sets are represented by a
+-- boolean, union means computing the logical or (at least one of the two is
+-- non-empty).
+
+mkUnion :: PartialResult -> PartialResult -> PartialResult
+mkUnion = mappend
+
+-- | Add a value vector abstraction to a value set abstraction (uncovered).
+mkCons :: ValVec -> PartialResult -> PartialResult
+mkCons vva = updateVsa (vva:)
+
+-- | Set the divergent set to not empty
+forces :: PartialResult -> PartialResult
+forces pres = pres { presultDivergent = Diverged }
+
+-- | Set the divergent set to non-empty if the flag is `True`
+force_if :: Bool -> PartialResult -> PartialResult
+force_if True  pres = forces pres
+force_if False pres = pres
+
+set_provenance :: Provenance -> PartialResult -> PartialResult
+set_provenance prov pr = pr { presultProvenance = prov }
+
+-- ----------------------------------------------------------------------------
+-- * Propagation of term constraints inwards when checking nested matches
+
+{- Note [Type and Term Equality Propagation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When checking a match it would be great to have all type and term information
+available so we can get more precise results. For this reason we have functions
+`addDictsDs' and `addTmCsDs' in PmMonad that store in the environment type and
+term constraints (respectively) as we go deeper.
+
+The type constraints we propagate inwards are collected by `collectEvVarsPats'
+in HsPat.hs. This handles bug #4139 ( see example
+  https://ghc.haskell.org/trac/ghc/attachment/ticket/4139/GADTbug.hs )
+where this is needed.
+
+For term equalities we do less, we just generate equalities for HsCase. For
+example we accurately give 2 redundancy warnings for the marked cases:
+
+f :: [a] -> Bool
+f x = case x of
+
+  []    -> case x of        -- brings (x ~ []) in scope
+             []    -> True
+             (_:_) -> False -- can't happen
+
+  (_:_) -> case x of        -- brings (x ~ (_:_)) in scope
+             (_:_) -> True
+             []    -> False -- can't happen
+
+Functions `genCaseTmCs1' and `genCaseTmCs2' are responsible for generating
+these constraints.
+-}
+
+-- | Generate equalities when checking a case expression:
+--     case x of { p1 -> e1; ... pn -> en }
+-- When we go deeper to check e.g. e1 we record two equalities:
+-- (x ~ y), where y is the initial uncovered when checking (p1; .. ; pn)
+-- and (x ~ p1).
+genCaseTmCs2 :: Maybe (LHsExpr GhcTc) -- Scrutinee
+             -> [Pat GhcTc]           -- LHS       (should have length 1)
+             -> [Id]                  -- MatchVars (should have length 1)
+             -> DsM (Bag SimpleEq)
+genCaseTmCs2 Nothing _ _ = return emptyBag
+genCaseTmCs2 (Just scr) [p] [var] = do
+  fam_insts <- dsGetFamInstEnvs
+  [e] <- map vaToPmExpr . coercePatVec <$> translatePat fam_insts p
+  let scr_e = lhsExprToPmExpr scr
+  return $ listToBag [(var, e), (var, scr_e)]
+genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase"
+
+-- | Generate a simple equality when checking a case expression:
+--     case x of { matches }
+-- When checking matches we record that (x ~ y) where y is the initial
+-- uncovered. All matches will have to satisfy this equality.
+genCaseTmCs1 :: Maybe (LHsExpr GhcTc) -> [Id] -> Bag SimpleEq
+genCaseTmCs1 Nothing     _    = emptyBag
+genCaseTmCs1 (Just scr) [var] = unitBag (var, lhsExprToPmExpr scr)
+genCaseTmCs1 _ _              = panic "genCaseTmCs1: HsCase"
+
+{- Note [Literals in PmPat]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Instead of translating a literal to a variable accompanied with a guard, we
+treat them like constructor patterns. The following example from
+"./libraries/base/GHC/IO/Encoding.hs" shows why:
+
+mkTextEncoding' :: CodingFailureMode -> String -> IO TextEncoding
+mkTextEncoding' cfm enc = case [toUpper c | c <- enc, c /= '-'] of
+    "UTF8"    -> return $ UTF8.mkUTF8 cfm
+    "UTF16"   -> return $ UTF16.mkUTF16 cfm
+    "UTF16LE" -> return $ UTF16.mkUTF16le cfm
+    ...
+
+Each clause gets translated to a list of variables with an equal number of
+guards. For every guard we generate two cases (equals True/equals False) which
+means that we generate 2^n cases to feed the oracle with, where n is the sum of
+the length of all strings that appear in the patterns. For this particular
+example this means over 2^40 cases. Instead, by representing them like with
+constructor we get the following:
+  1. We exploit the common prefix with our representation of VSAs
+  2. We prune immediately non-reachable cases
+     (e.g. False == (x == "U"), True == (x == "U"))
+
+Note [Translating As Patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Instead of translating x@p as:  x (p <- x)
+we instead translate it as:     p (x <- coercePattern p)
+for performance reasons. For example:
+
+  f x@True  = 1
+  f y@False = 2
+
+Gives the following with the first translation:
+
+  x |> {x == False, x == y, y == True}
+
+If we use the second translation we get an empty set, independently of the
+oracle. Since the pattern `p' may contain guard patterns though, it cannot be
+used as an expression. That's why we call `coercePatVec' to drop the guard and
+`vaToPmExpr' to transform the value abstraction to an expression in the
+guard pattern (value abstractions are a subset of expressions). We keep the
+guards in the first pattern `p' though.
+
+
+%************************************************************************
+%*                                                                      *
+      Pretty printing of exhaustiveness/redundancy check warnings
+%*                                                                      *
+%************************************************************************
+-}
+
+-- | Check whether any part of pattern match checking is enabled (does not
+-- matter whether it is the redundancy check or the exhaustiveness check).
+isAnyPmCheckEnabled :: DynFlags -> DsMatchContext -> Bool
+isAnyPmCheckEnabled dflags (DsMatchContext kind _loc)
+  = wopt Opt_WarnOverlappingPatterns dflags || exhaustive dflags kind
+
+instance Outputable ValVec where
+  ppr (ValVec vva delta)
+    = let (residual_eqs, subst) = wrapUpTmState (delta_tm_cs delta)
+          vector                = substInValAbs subst vva
+      in  ppr_uncovered (vector, residual_eqs)
+
+-- | Apply a term substitution to a value vector abstraction. All VAs are
+-- transformed to PmExpr (used only before pretty printing).
+substInValAbs :: PmVarEnv -> [ValAbs] -> [PmExpr]
+substInValAbs subst = map (exprDeepLookup subst . vaToPmExpr)
+
+-- | Wrap up the term oracle's state once solving is complete. Drop any
+-- information about unhandled constraints (involving HsExprs) and flatten
+-- (height 1) the substitution.
+wrapUpTmState :: TmState -> ([ComplexEq], PmVarEnv)
+wrapUpTmState (residual, (_, subst)) = (residual, flattenPmVarEnv subst)
+
+-- | Issue all the warnings (coverage, exhaustiveness, inaccessibility)
+dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM ()
+dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result
+  = when (flag_i || flag_u) $ do
+      let exists_r = flag_i && notNull redundant && onlyBuiltin
+          exists_i = flag_i && notNull inaccessible && onlyBuiltin && not is_rec_upd
+          exists_u = flag_u && (case uncovered of
+                                  TypeOfUncovered   _ -> True
+                                  UncoveredPatterns u -> notNull u)
+
+      when exists_r $ forM_ redundant $ \(dL->L l q) -> do
+        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
+                               (pprEqn q "is redundant"))
+      when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do
+        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)
+                               (pprEqn q "has inaccessible right hand side"))
+      when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $
+        case uncovered of
+          TypeOfUncovered ty           -> warnEmptyCase ty
+          UncoveredPatterns candidates -> pprEqns candidates
+  where
+    PmResult
+      { pmresultProvenance = prov
+      , pmresultRedundant = redundant
+      , pmresultUncovered = uncovered
+      , pmresultInaccessible = inaccessible } = pm_result
+
+    flag_i = wopt Opt_WarnOverlappingPatterns dflags
+    flag_u = exhaustive dflags kind
+    flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)
+
+    is_rec_upd = case kind of { RecUpd -> True; _ -> False }
+       -- See Note [Inaccessible warnings for record updates]
+
+    onlyBuiltin = prov == FromBuiltin
+
+    maxPatterns = maxUncoveredPatterns dflags
+
+    -- Print a single clause (for redundant/with-inaccessible-rhs)
+    pprEqn q txt = pp_context True ctx (text txt) $ \f -> ppr_eqn f kind q
+
+    -- Print several clauses (for uncovered clauses)
+    pprEqns qs = pp_context False ctx (text "are non-exhaustive") $ \_ ->
+      case qs of -- See #11245
+           [ValVec [] _]
+                    -> text "Guards do not cover entire pattern space"
+           _missing -> let us = map ppr qs
+                       in  hang (text "Patterns not matched:") 4
+                                (vcat (take maxPatterns us)
+                                 $$ dots maxPatterns us)
+
+    -- Print a type-annotated wildcard (for non-exhaustive `EmptyCase`s for
+    -- which we only know the type and have no inhabitants at hand)
+    warnEmptyCase ty = pp_context False ctx (text "are non-exhaustive") $ \_ ->
+      hang (text "Patterns not matched:") 4 (underscore <+> dcolon <+> ppr ty)
+
+{- Note [Inaccessible warnings for record updates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #12957)
+  data T a where
+    T1 :: { x :: Int } -> T Bool
+    T2 :: { x :: Int } -> T a
+    T3 :: T a
+
+  f :: T Char -> T a
+  f r = r { x = 3 }
+
+The desugarer will (conservatively generate a case for T1 even though
+it's impossible:
+  f r = case r of
+          T1 x -> T1 3   -- Inaccessible branch
+          T2 x -> T2 3
+          _    -> error "Missing"
+
+We don't want to warn about the inaccessible branch because the programmer
+didn't put it there!  So we filter out the warning here.
+-}
+
+-- | Issue a warning when the predefined number of iterations is exceeded
+-- for the pattern match checker
+warnPmIters :: DynFlags -> DsMatchContext -> DsM ()
+warnPmIters dflags (DsMatchContext kind loc)
+  = when (flag_i || flag_u) $ do
+      iters <- maxPmCheckIterations <$> getDynFlags
+      putSrcSpanDs loc (warnDs NoReason (msg iters))
+  where
+    ctxt   = pprMatchContext kind
+    msg is = fsep [ text "Pattern match checker exceeded"
+                  , parens (ppr is), text "iterations in", ctxt <> dot
+                  , text "(Use -fmax-pmcheck-iterations=n"
+                  , text "to set the maximun number of iterations to n)" ]
+
+    flag_i = wopt Opt_WarnOverlappingPatterns dflags
+    flag_u = exhaustive dflags kind
+
+dots :: Int -> [a] -> SDoc
+dots maxPatterns qs
+    | qs `lengthExceeds` maxPatterns = text "..."
+    | otherwise                      = empty
+
+-- | Check whether the exhaustiveness checker should run (exhaustiveness only)
+exhaustive :: DynFlags -> HsMatchContext id -> Bool
+exhaustive  dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag
+
+-- | Denotes whether an exhaustiveness check is supported, and if so,
+-- via which 'WarningFlag' it's controlled.
+-- Returns 'Nothing' if check is not supported.
+exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag
+exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag IfAlt         = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns
+exhaustiveWarningFlag ProcExpr      = Just Opt_WarnIncompleteUniPatterns
+exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd
+exhaustiveWarningFlag ThPatSplice   = Nothing
+exhaustiveWarningFlag PatSyn        = Nothing
+exhaustiveWarningFlag ThPatQuote    = Nothing
+exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns
+                                       -- in list comprehensions, pattern guards
+                                       -- etc. They are often *supposed* to be
+                                       -- incomplete
+
+-- True <==> singular
+pp_context :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
+pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
+  = vcat [text txt <+> msg,
+          sep [ text "In" <+> ppr_match <> char ':'
+              , nest 4 (rest_of_msg_fun pref)]]
+  where
+    txt | singular  = "Pattern match"
+        | otherwise = "Pattern match(es)"
+
+    (ppr_match, pref)
+        = case kind of
+             FunRhs { mc_fun = (dL->L _ fun) }
+                  -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
+             _    -> (pprMatchContext kind, \ pp -> pp)
+
+ppr_pats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc
+ppr_pats kind pats
+  = sep [sep (map ppr pats), matchSeparator kind, text "..."]
+
+ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat GhcTc] -> SDoc
+ppr_eqn prefixF kind eqn = prefixF (ppr_pats kind (map unLoc eqn))
+
+ppr_constraint :: (SDoc,[PmLit]) -> SDoc
+ppr_constraint (var, lits) = var <+> text "is not one of"
+                                 <+> braces (pprWithCommas ppr lits)
+
+ppr_uncovered :: ([PmExpr], [ComplexEq]) -> SDoc
+ppr_uncovered (expr_vec, complex)
+  | null cs   = fsep vec -- there are no literal constraints
+  | otherwise = hang (fsep vec) 4 $
+                  text "where" <+> vcat (map ppr_constraint cs)
+  where
+    sdoc_vec = mapM pprPmExprWithParens expr_vec
+    (vec,cs) = runPmPprM sdoc_vec (filterComplex complex)
+
+{- Note [Representation of Term Equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the paper, term constraints always take the form (x ~ e). Of course, a more
+general constraint of the form (e1 ~ e1) can always be transformed to an
+equivalent set of the former constraints, by introducing a fresh, intermediate
+variable: { y ~ e1, y ~ e1 }. Yet, implementing this representation gave rise
+to #11160 (incredibly bad performance for literal pattern matching). Two are
+the main sources of this problem (the actual problem is how these two interact
+with each other):
+
+1. Pattern matching on literals generates twice as many constraints as needed.
+   Consider the following (tests/ghci/should_run/ghcirun004):
+
+    foo :: Int -> Int
+    foo 1    = 0
+    ...
+    foo 5000 = 4999
+
+   The covered and uncovered set *should* look like:
+     U0 = { x |> {} }
+
+     C1  = { 1  |> { x ~ 1 } }
+     U1  = { x  |> { False ~ (x ~ 1) } }
+     ...
+     C10 = { 10 |> { False ~ (x ~ 1), .., False ~ (x ~ 9), x ~ 10 } }
+     U10 = { x  |> { False ~ (x ~ 1), .., False ~ (x ~ 9), False ~ (x ~ 10) } }
+     ...
+
+     If we replace { False ~ (x ~ 1) } with { y ~ False, y ~ (x ~ 1) }
+     we get twice as many constraints. Also note that half of them are just the
+     substitution [x |-> False].
+
+2. The term oracle (`tmOracle` in deSugar/TmOracle) uses equalities of the form
+   (x ~ e) as substitutions [x |-> e]. More specifically, function
+   `extendSubstAndSolve` applies such substitutions in the residual constraints
+   and partitions them in the affected and non-affected ones, which are the new
+   worklist. Essentially, this gives quadradic behaviour on the number of the
+   residual constraints. (This would not be the case if the term oracle used
+   mutable variables but, since we use it to handle disjunctions on value set
+   abstractions (`Union` case), we chose a pure, incremental interface).
+
+Now the problem becomes apparent (e.g. for clause 300):
+  * Set U300 contains 300 substituting constraints [y_i |-> False] and 300
+    constraints that we know that will not reduce (stay in the worklist).
+  * To check for consistency, we apply the substituting constraints ONE BY ONE
+    (since `tmOracle` is called incrementally, it does not have all of them
+    available at once). Hence, we go through the (non-progressing) constraints
+    over and over, achieving over-quadradic behaviour.
+
+If instead we allow constraints of the form (e ~ e),
+  * All uncovered sets Ui contain no substituting constraints and i
+    non-progressing constraints of the form (False ~ (x ~ lit)) so the oracle
+    behaves linearly.
+  * All covered sets Ci contain exactly (i-1) non-progressing constraints and
+    a single substituting constraint. So the term oracle goes through the
+    constraints only once.
+
+The performance improvement becomes even more important when more arguments are
+involved.
+-}
+
+-- Debugging Infrastructre
+
+tracePm :: String -> SDoc -> PmM ()
+tracePm herald doc = liftD $ tracePmD herald doc
+
+
+tracePmD :: String -> SDoc -> DsM ()
+tracePmD herald doc = do
+  dflags <- getDynFlags
+  printer <- mkPrintUnqualifiedDs
+  liftIO $ dumpIfSet_dyn_printer printer dflags
+            Opt_D_dump_ec_trace (text herald $$ (nest 2 doc))
+
+
+pprPmPatDebug :: PmPat a -> SDoc
+pprPmPatDebug (PmCon cc _arg_tys _con_tvs _con_dicts con_args)
+  = hsep [text "PmCon", ppr cc, hsep (map pprPmPatDebug con_args)]
+pprPmPatDebug (PmVar vid) = text "PmVar" <+> ppr vid
+pprPmPatDebug (PmLit li)  = text "PmLit" <+> ppr li
+pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl
+pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv)
+                                           <+> ppr ge
+
+pprPatVec :: PatVec -> SDoc
+pprPatVec ps = hang (text "Pattern:") 2
+                (brackets $ sep
+                  $ punctuate (comma <> char '\n') (map pprPmPatDebug ps))
+
+pprValAbs :: [ValAbs] -> SDoc
+pprValAbs ps = hang (text "ValAbs:") 2
+                (brackets $ sep
+                  $ punctuate (comma) (map pprPmPatDebug ps))
+
+pprValVecDebug :: ValVec -> SDoc
+pprValVecDebug (ValVec vas _d) = text "ValVec" <+>
+                                  parens (pprValAbs vas)
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/Coverage.hs
@@ -0,0 +1,1363 @@
+{-
+(c) Galois, 2006
+(c) University of Glasgow, 2007
+-}
+
+{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Coverage (addTicksToBinds, hpcInitCode) where
+
+import GhcPrelude as Prelude
+
+import qualified GHCi
+import GHCi.RemoteTypes
+import Data.Array
+import ByteCodeTypes
+import GHC.Stack.CCS
+import Type
+import HsSyn
+import Module
+import Outputable
+import DynFlags
+import ConLike
+import Control.Monad
+import SrcLoc
+import ErrUtils
+import NameSet hiding (FreeVars)
+import Name
+import Bag
+import CostCentre
+import CostCentreState
+import CoreSyn
+import Id
+import VarSet
+import Data.List
+import FastString
+import HscTypes
+import TyCon
+import BasicTypes
+import MonadUtils
+import Maybes
+import CLabel
+import Util
+
+import Data.Time
+import System.Directory
+
+import Trace.Hpc.Mix
+import Trace.Hpc.Util
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+{-
+************************************************************************
+*                                                                      *
+*              The main function: addTicksToBinds
+*                                                                      *
+************************************************************************
+-}
+
+addTicksToBinds
+        :: HscEnv
+        -> Module
+        -> ModLocation          -- ... off the current module
+        -> NameSet              -- Exported Ids.  When we call addTicksToBinds,
+                                -- isExportedId doesn't work yet (the desugarer
+                                -- hasn't set it), so we have to work from this set.
+        -> [TyCon]              -- Type constructor in this module
+        -> LHsBinds GhcTc
+        -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)
+
+addTicksToBinds hsc_env mod mod_loc exports tyCons binds
+  | let dflags = hsc_dflags hsc_env
+        passes = coveragePasses dflags, not (null passes),
+    Just orig_file <- ml_hs_file mod_loc,
+    not ("boot" `isSuffixOf` orig_file) = do
+
+     let  orig_file2 = guessSourceFile binds orig_file
+
+          tickPass tickish (binds,st) =
+            let env = TTE
+                      { fileName     = mkFastString orig_file2
+                      , declPath     = []
+                      , tte_dflags   = dflags
+                      , exports      = exports
+                      , inlines      = emptyVarSet
+                      , inScope      = emptyVarSet
+                      , blackList    = Map.fromList
+                                          [ (getSrcSpan (tyConName tyCon),())
+                                          | tyCon <- tyCons ]
+                      , density      = mkDensity tickish dflags
+                      , this_mod     = mod
+                      , tickishType  = tickish
+                      }
+                (binds',_,st') = unTM (addTickLHsBinds binds) env st
+            in (binds', st')
+
+          initState = TT { tickBoxCount = 0
+                         , mixEntries   = []
+                         , ccIndices    = newCostCentreState
+                         }
+
+          (binds1,st) = foldr tickPass (binds, initState) passes
+
+     let tickCount = tickBoxCount st
+         entries = reverse $ mixEntries st
+     hashNo <- writeMixEntries dflags mod tickCount entries orig_file2
+     modBreaks <- mkModBreaks hsc_env mod tickCount entries
+
+     dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" (pprLHsBinds binds1)
+
+     return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
+
+  | otherwise = return (binds, emptyHpcInfo False, Nothing)
+
+guessSourceFile :: LHsBinds GhcTc -> FilePath -> FilePath
+guessSourceFile binds orig_file =
+     -- Try look for a file generated from a .hsc file to a
+     -- .hs file, by peeking ahead.
+     let top_pos = catMaybes $ foldrBag (\ (dL->L pos _) rest ->
+                                 srcSpanFileName_maybe pos : rest) [] binds
+     in
+     case top_pos of
+        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name
+                      -> unpackFS file_name
+        _ -> orig_file
+
+
+mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO ModBreaks
+mkModBreaks hsc_env mod count entries
+  | HscInterpreted <- hscTarget (hsc_dflags hsc_env) = do
+    breakArray <- GHCi.newBreakArray hsc_env (length entries)
+    ccs <- mkCCSArray hsc_env mod count entries
+    let
+           locsTicks  = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]
+           varsTicks  = listArray (0,count-1) [ vars  | (_,_,vars,_)  <- entries ]
+           declsTicks = listArray (0,count-1) [ decls | (_,decls,_,_) <- entries ]
+    return emptyModBreaks
+                       { modBreaks_flags = breakArray
+                       , modBreaks_locs  = locsTicks
+                       , modBreaks_vars  = varsTicks
+                       , modBreaks_decls = declsTicks
+                       , modBreaks_ccs   = ccs
+                       }
+  | otherwise = return emptyModBreaks
+
+mkCCSArray
+  :: HscEnv -> Module -> Int -> [MixEntry_]
+  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))
+mkCCSArray hsc_env modul count entries = do
+  if interpreterProfiled dflags
+    then do
+      let module_str = moduleNameString (moduleName modul)
+      costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries)
+      return (listArray (0,count-1) costcentres)
+    else do
+      return (listArray (0,-1) [])
+ where
+    dflags = hsc_dflags hsc_env
+    mk_one (srcspan, decl_path, _, _) = (name, src)
+      where name = concat (intersperse "." decl_path)
+            src = showSDoc dflags (ppr srcspan)
+
+
+writeMixEntries
+  :: DynFlags -> Module -> Int -> [MixEntry_] -> FilePath -> IO Int
+writeMixEntries dflags mod count entries filename
+  | not (gopt Opt_Hpc dflags) = return 0
+  | otherwise   = do
+        let
+            hpc_dir = hpcDir dflags
+            mod_name = moduleNameString (moduleName mod)
+
+            hpc_mod_dir
+              | moduleUnitId mod == mainUnitId  = hpc_dir
+              | otherwise = hpc_dir ++ "/" ++ unitIdString (moduleUnitId mod)
+
+            tabStop = 8 -- <tab> counts as a normal char in GHC's
+                        -- location ranges.
+
+        createDirectoryIfMissing True hpc_mod_dir
+        modTime <- getModificationUTCTime filename
+        let entries' = [ (hpcPos, box)
+                       | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
+        when (entries' `lengthIsNot` count) $ do
+          panic "the number of .mix entries are inconsistent"
+        let hashNo = mixHash filename modTime tabStop entries'
+        mixCreate hpc_mod_dir mod_name
+                       $ Mix filename modTime (toHash hashNo) tabStop entries'
+        return hashNo
+
+
+-- -----------------------------------------------------------------------------
+-- TickDensity: where to insert ticks
+
+data TickDensity
+  = TickForCoverage       -- for Hpc
+  | TickForBreakPoints    -- for GHCi
+  | TickAllFunctions      -- for -prof-auto-all
+  | TickTopFunctions      -- for -prof-auto-top
+  | TickExportedFunctions -- for -prof-auto-exported
+  | TickCallSites         -- for stack tracing
+  deriving Eq
+
+mkDensity :: TickishType -> DynFlags -> TickDensity
+mkDensity tickish dflags = case tickish of
+  HpcTicks             -> TickForCoverage
+  SourceNotes          -> TickForCoverage
+  Breakpoints          -> TickForBreakPoints
+  ProfNotes ->
+    case profAuto dflags of
+      ProfAutoAll      -> TickAllFunctions
+      ProfAutoTop      -> TickTopFunctions
+      ProfAutoExports  -> TickExportedFunctions
+      ProfAutoCalls    -> TickCallSites
+      _other           -> panic "mkDensity"
+
+-- | Decide whether to add a tick to a binding or not.
+shouldTickBind  :: TickDensity
+                -> Bool         -- top level?
+                -> Bool         -- exported?
+                -> Bool         -- simple pat bind?
+                -> Bool         -- INLINE pragma?
+                -> Bool
+
+shouldTickBind density top_lev exported _simple_pat inline
+ = case density of
+      TickForBreakPoints    -> False
+        -- we never add breakpoints to simple pattern bindings
+        -- (there's always a tick on the rhs anyway).
+      TickAllFunctions      -> not inline
+      TickTopFunctions      -> top_lev && not inline
+      TickExportedFunctions -> exported && not inline
+      TickForCoverage       -> True
+      TickCallSites         -> False
+
+shouldTickPatBind :: TickDensity -> Bool -> Bool
+shouldTickPatBind density top_lev
+  = case density of
+      TickForBreakPoints    -> False
+      TickAllFunctions      -> True
+      TickTopFunctions      -> top_lev
+      TickExportedFunctions -> False
+      TickForCoverage       -> False
+      TickCallSites         -> False
+
+-- -----------------------------------------------------------------------------
+-- Adding ticks to bindings
+
+addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc)
+addTickLHsBinds = mapBagM addTickLHsBind
+
+addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)
+addTickLHsBind (dL->L pos bind@(AbsBinds { abs_binds   = binds,
+                                       abs_exports = abs_exports })) = do
+  withEnv add_exports $ do
+  withEnv add_inlines $ do
+  binds' <- addTickLHsBinds binds
+  return $ cL pos $ bind { abs_binds = binds' }
+ where
+   -- in AbsBinds, the Id on each binding is not the actual top-level
+   -- Id that we are defining, they are related by the abs_exports
+   -- field of AbsBinds.  So if we're doing TickExportedFunctions we need
+   -- to add the local Ids to the set of exported Names so that we know to
+   -- tick the right bindings.
+   add_exports env =
+     env{ exports = exports env `extendNameSetList`
+                      [ idName mid
+                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
+                      , idName pid `elemNameSet` (exports env) ] }
+
+   -- See Note [inline sccs]
+   add_inlines env =
+     env{ inlines = inlines env `extendVarSetList`
+                      [ mid
+                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports
+                      , isInlinePragma (idInlinePragma pid) ] }
+
+addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id)  }))) = do
+  let name = getOccString id
+  decl_path <- getPathEntry
+  density <- getDensity
+
+  inline_ids <- liftM inlines getEnv
+  -- See Note [inline sccs]
+  let inline   = isInlinePragma (idInlinePragma id)
+                 || id `elemVarSet` inline_ids
+
+  -- See Note [inline sccs]
+  tickish <- tickishType `liftM` getEnv
+  if inline && tickish == ProfNotes then return (cL pos funBind) else do
+
+  (fvs, mg) <-
+        getFreeVars $
+        addPathEntry name $
+        addTickMatchGroup False (fun_matches funBind)
+
+  case mg of
+    MG {} -> return ()
+    _     -> panic "addTickLHsBind"
+
+  blackListed <- isBlackListed pos
+  exported_names <- liftM exports getEnv
+
+  -- We don't want to generate code for blacklisted positions
+  -- We don't want redundant ticks on simple pattern bindings
+  -- We don't want to tick non-exported bindings in TickExportedFunctions
+  let simple = isSimplePatBind funBind
+      toplev = null decl_path
+      exported = idName id `elemNameSet` exported_names
+
+  tick <- if not blackListed &&
+               shouldTickBind density toplev exported simple inline
+             then
+                bindTick density name pos fvs
+             else
+                return Nothing
+
+  let mbCons = maybe Prelude.id (:)
+  return $ cL pos $ funBind { fun_matches = mg
+                            , fun_tick = tick `mbCons` fun_tick funBind }
+
+   where
+   -- a binding is a simple pattern binding if it is a funbind with
+   -- zero patterns
+   isSimplePatBind :: HsBind a -> Bool
+   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0
+
+-- TODO: Revisit this
+addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs
+                                        , pat_rhs = rhs }))) = do
+  let name = "(...)"
+  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs
+  let pat' = pat { pat_rhs = rhs'}
+
+  -- Should create ticks here?
+  density <- getDensity
+  decl_path <- getPathEntry
+  let top_lev = null decl_path
+  if not (shouldTickPatBind density top_lev)
+    then return (cL pos pat')
+    else do
+
+    -- Allocate the ticks
+    rhs_tick <- bindTick density name pos fvs
+    let patvars = map getOccString (collectPatBinders lhs)
+    patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars
+
+    -- Add to pattern
+    let mbCons = maybe id (:)
+        rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat')
+        patvar_tickss = zipWith mbCons patvar_ticks
+                        (snd (pat_ticks pat') ++ repeat [])
+    return $ cL pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }
+
+-- Only internal stuff, not from source, uses VarBind, so we ignore it.
+addTickLHsBind var_bind@(dL->L _ (VarBind {})) = return var_bind
+addTickLHsBind patsyn_bind@(dL->L _ (PatSynBind {})) = return patsyn_bind
+addTickLHsBind bind@(dL->L _ (XHsBindsLR {})) = return bind
+addTickLHsBind _  = panic "addTickLHsBind: Impossible Match" -- due to #15884
+
+
+
+bindTick
+  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))
+bindTick density name pos fvs = do
+  decl_path <- getPathEntry
+  let
+      toplev        = null decl_path
+      count_entries = toplev || density == TickAllFunctions
+      top_only      = density /= TickAllFunctions
+      box_label     = if toplev then TopLevelBox [name]
+                                else LocalBox (decl_path ++ [name])
+  --
+  allocATickBox box_label count_entries top_only pos fvs
+
+
+-- Note [inline sccs]
+--
+-- The reason not to add ticks to INLINE functions is that this is
+-- sometimes handy for avoiding adding a tick to a particular function
+-- (see #6131)
+--
+-- So for now we do not add any ticks to INLINE functions at all.
+--
+-- We used to use isAnyInlinePragma to figure out whether to avoid adding
+-- ticks for this purpose. However, #12962 indicates that this contradicts
+-- the documentation on profiling (which only mentions INLINE pragmas).
+-- So now we're more careful about what we avoid adding ticks to.
+
+-- -----------------------------------------------------------------------------
+-- Decorate an LHsExpr with ticks
+
+-- selectively add ticks to interesting expressions
+addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExpr e@(dL->L pos e0) = do
+  d <- getDensity
+  case d of
+    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it
+    TickForCoverage    -> tick_it
+    TickCallSites      | isCallSite e0      -> tick_it
+    _other             -> dont_tick_it
+ where
+   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
+   dont_tick_it = addTickLHsExprNever e
+
+-- Add a tick to an expression which is the RHS of an equation or a binding.
+-- We always consider these to be breakpoints, unless the expression is a 'let'
+-- (because the body will definitely have a tick somewhere).  ToDo: perhaps
+-- we should treat 'case' and 'if' the same way?
+addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExprRHS e@(dL->L pos e0) = do
+  d <- getDensity
+  case d of
+     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
+                        | otherwise     -> tick_it
+     TickForCoverage -> tick_it
+     TickCallSites   | isCallSite e0 -> tick_it
+     _other          -> dont_tick_it
+ where
+   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
+   dont_tick_it = addTickLHsExprNever e
+
+-- The inner expression of an evaluation context:
+--    let binds in [], ( [] )
+-- we never tick these if we're doing HPC, but otherwise
+-- we treat it like an ordinary expression.
+addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExprEvalInner e = do
+   d <- getDensity
+   case d of
+     TickForCoverage -> addTickLHsExprNever e
+     _otherwise      -> addTickLHsExpr e
+
+-- | A let body is treated differently from addTickLHsExprEvalInner
+-- above with TickForBreakPoints, because for breakpoints we always
+-- want to tick the body, even if it is not a redex.  See test
+-- break012.  This gives the user the opportunity to inspect the
+-- values of the let-bound variables.
+addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExprLetBody e@(dL->L pos e0) = do
+  d <- getDensity
+  case d of
+     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it
+                        | otherwise     -> tick_it
+     _other -> addTickLHsExprEvalInner e
+ where
+   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0
+   dont_tick_it = addTickLHsExprNever e
+
+-- version of addTick that does not actually add a tick,
+-- because the scope of this tick is completely subsumed by
+-- another.
+addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExprNever (dL->L pos e0) = do
+    e1 <- addTickHsExpr e0
+    return $ cL pos e1
+
+-- general heuristic: expressions which do not denote values are good
+-- break points
+isGoodBreakExpr :: HsExpr GhcTc -> Bool
+isGoodBreakExpr (HsApp {})     = True
+isGoodBreakExpr (HsAppType {}) = True
+isGoodBreakExpr (OpApp {})     = True
+isGoodBreakExpr _other         = False
+
+isCallSite :: HsExpr GhcTc -> Bool
+isCallSite HsApp{}     = True
+isCallSite HsAppType{} = True
+isCallSite OpApp{}     = True
+isCallSite _ = False
+
+addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickLHsExprOptAlt oneOfMany (dL->L pos e0)
+  = ifDensity TickForCoverage
+        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)
+        (addTickLHsExpr (cL pos e0))
+
+addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addBinTickLHsExpr boxLabel (dL->L pos e0)
+  = ifDensity TickForCoverage
+        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)
+        (addTickLHsExpr (cL pos e0))
+
+
+-- -----------------------------------------------------------------------------
+-- Decorate the body of an HsExpr with ticks.
+-- (Whether to put a tick around the whole expression was already decided,
+-- in the addTickLHsExpr family of functions.)
+
+addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)
+addTickHsExpr e@(HsVar _ (dL->L _ id)) = do freeVar id; return e
+addTickHsExpr (HsUnboundVar {})    = panic "addTickHsExpr.HsUnboundVar"
+addTickHsExpr e@(HsConLikeOut _ con)
+  | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
+addTickHsExpr e@(HsIPVar {})       = return e
+addTickHsExpr e@(HsOverLit {})     = return e
+addTickHsExpr e@(HsOverLabel{})    = return e
+addTickHsExpr e@(HsLit {})         = return e
+addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x)
+                                           (addTickMatchGroup True matchgroup)
+addTickHsExpr (HsLamCase x mgs)    = liftM (HsLamCase x)
+                                           (addTickMatchGroup True mgs)
+addTickHsExpr (HsApp x e1 e2)      = liftM2 (HsApp x) (addTickLHsExprNever e1)
+                                                      (addTickLHsExpr      e2)
+addTickHsExpr (HsAppType x e ty)   = liftM3 HsAppType (return x)
+                                                      (addTickLHsExprNever e)
+                                                      (return ty)
+
+addTickHsExpr (OpApp fix e1 e2 e3) =
+        liftM4 OpApp
+                (return fix)
+                (addTickLHsExpr e1)
+                (addTickLHsExprNever e2)
+                (addTickLHsExpr e3)
+addTickHsExpr (NegApp x e neg) =
+        liftM2 (NegApp x)
+                (addTickLHsExpr e)
+                (addTickSyntaxExpr hpcSrcSpan neg)
+addTickHsExpr (HsPar x e) =
+        liftM (HsPar x) (addTickLHsExprEvalInner e)
+addTickHsExpr (SectionL x e1 e2) =
+        liftM2 (SectionL x)
+                (addTickLHsExpr e1)
+                (addTickLHsExprNever e2)
+addTickHsExpr (SectionR x e1 e2) =
+        liftM2 (SectionR x)
+                (addTickLHsExprNever e1)
+                (addTickLHsExpr e2)
+addTickHsExpr (ExplicitTuple x es boxity) =
+        liftM2 (ExplicitTuple x)
+                (mapM addTickTupArg es)
+                (return boxity)
+addTickHsExpr (ExplicitSum ty tag arity e) = do
+        e' <- addTickLHsExpr e
+        return (ExplicitSum ty tag arity e')
+addTickHsExpr (HsCase x e mgs) =
+        liftM2 (HsCase x)
+                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily
+                                   -- be evaluated.
+                (addTickMatchGroup False mgs)
+addTickHsExpr (HsIf x cnd e1 e2 e3) =
+        liftM3 (HsIf x cnd)
+                (addBinTickLHsExpr (BinBox CondBinBox) e1)
+                (addTickLHsExprOptAlt True e2)
+                (addTickLHsExprOptAlt True e3)
+addTickHsExpr (HsMultiIf ty alts)
+  = do { let isOneOfMany = case alts of [_] -> False; _ -> True
+       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
+       ; return $ HsMultiIf ty alts' }
+addTickHsExpr (HsLet x (dL->L l binds) e) =
+        bindLocals (collectLocalBinders binds) $
+          liftM2 (HsLet x . cL l)
+                  (addTickHsLocalBinds binds) -- to think about: !patterns.
+                  (addTickLHsExprLetBody e)
+addTickHsExpr (HsDo srcloc cxt (dL->L l stmts))
+  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
+       ; return (HsDo srcloc cxt (cL l stmts')) }
+  where
+        forQual = case cxt of
+                    ListComp -> Just $ BinBox QualBinBox
+                    _        -> Nothing
+addTickHsExpr (ExplicitList ty wit es) =
+        liftM3 ExplicitList
+                (return ty)
+                (addTickWit wit)
+                (mapM (addTickLHsExpr) es)
+             where addTickWit Nothing = return Nothing
+                   addTickWit (Just fln)
+                     = do fln' <- addTickSyntaxExpr hpcSrcSpan fln
+                          return (Just fln')
+
+addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
+
+addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })
+  = do { rec_binds' <- addTickHsRecordBinds rec_binds
+       ; return (expr { rcon_flds = rec_binds' }) }
+
+addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })
+  = do { e' <- addTickLHsExpr e
+       ; flds' <- mapM addTickHsRecField flds
+       ; return (expr { rupd_expr = e', rupd_flds = flds' }) }
+
+addTickHsExpr (ExprWithTySig x e ty) =
+        liftM3 ExprWithTySig
+                (return x)
+                (addTickLHsExprNever e) -- No need to tick the inner expression
+                                        -- for expressions with signatures
+                (return ty)
+addTickHsExpr (ArithSeq ty wit arith_seq) =
+        liftM3 ArithSeq
+                (return ty)
+                (addTickWit wit)
+                (addTickArithSeqInfo arith_seq)
+             where addTickWit Nothing = return Nothing
+                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
+                                             return (Just fl')
+
+-- We might encounter existing ticks (multiple Coverage passes)
+addTickHsExpr (HsTick x t e) =
+        liftM (HsTick x t) (addTickLHsExprNever e)
+addTickHsExpr (HsBinTick x t0 t1 e) =
+        liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)
+
+addTickHsExpr (HsTickPragma _ _ _ _ (dL->L pos e0)) = do
+    e2 <- allocTickBox (ExpBox False) False False pos $
+                addTickHsExpr e0
+    return $ unLoc e2
+addTickHsExpr (HsSCC x src nm e) =
+        liftM3 (HsSCC x)
+                (return src)
+                (return nm)
+                (addTickLHsExpr e)
+addTickHsExpr (HsCoreAnn x src nm e) =
+        liftM3 (HsCoreAnn x)
+                (return src)
+                (return nm)
+                (addTickLHsExpr e)
+addTickHsExpr e@(HsBracket     {})   = return e
+addTickHsExpr e@(HsTcBracketOut  {}) = return e
+addTickHsExpr e@(HsRnBracketOut  {}) = return e
+addTickHsExpr e@(HsSpliceE  {})      = return e
+addTickHsExpr (HsProc x pat cmdtop) =
+        liftM2 (HsProc x)
+                (addTickLPat pat)
+                (liftL (addTickHsCmdTop) cmdtop)
+addTickHsExpr (HsWrap x w e) =
+        liftM2 (HsWrap x)
+                (return w)
+                (addTickHsExpr e)       -- Explicitly no tick on inside
+
+-- Others should never happen in expression content.
+addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)
+
+addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)
+addTickTupArg (dL->L l (Present x e))  = do { e' <- addTickLHsExpr e
+                                            ; return (cL l (Present x e')) }
+addTickTupArg (dL->L l (Missing ty)) = return (cL l (Missing ty))
+addTickTupArg (dL->L _ (XTupArg _)) = panic "addTickTupArg"
+addTickTupArg _  = panic "addTickTupArg: Impossible Match" -- due to #15884
+
+
+addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)
+                  -> TM (MatchGroup GhcTc (LHsExpr GhcTc))
+addTickMatchGroup is_lam mg@(MG { mg_alts = dL->L l matches }) = do
+  let isOneOfMany = matchesOneOfMany matches
+  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
+  return $ mg { mg_alts = cL l matches' }
+addTickMatchGroup _ (XMatchGroup _) = panic "addTickMatchGroup"
+
+addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)
+             -> TM (Match GhcTc (LHsExpr GhcTc))
+addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats
+                                               , m_grhss = gRHSs }) =
+  bindLocals (collectPatsBinders pats) $ do
+    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs
+    return $ match { m_grhss = gRHSs' }
+addTickMatch _ _ (XMatch _) = panic "addTickMatch"
+
+addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)
+             -> TM (GRHSs GhcTc (LHsExpr GhcTc))
+addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (dL->L l local_binds)) = do
+  bindLocals binders $ do
+    local_binds' <- addTickHsLocalBinds local_binds
+    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
+    return $ GRHSs x guarded' (cL l local_binds')
+  where
+    binders = collectLocalBinders local_binds
+addTickGRHSs _ _ (XGRHSs _) = panic "addTickGRHSs"
+
+addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)
+            -> TM (GRHS GhcTc (LHsExpr GhcTc))
+addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do
+  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts
+                        (addTickGRHSBody isOneOfMany isLambda expr)
+  return $ GRHS x stmts' expr'
+addTickGRHS _ _ (XGRHS _) = panic "addTickGRHS"
+
+addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTickGRHSBody isOneOfMany isLambda expr@(dL->L pos e0) = do
+  d <- getDensity
+  case d of
+    TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr
+    TickAllFunctions | isLambda ->
+       addPathEntry "\\" $
+         allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $
+           addTickHsExpr e0
+    _otherwise ->
+       addTickLHsExprRHS expr
+
+addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]
+              -> TM [ExprLStmt GhcTc]
+addTickLStmts isGuard stmts = do
+  (stmts, _) <- addTickLStmts' isGuard stmts (return ())
+  return stmts
+
+addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a
+               -> TM ([ExprLStmt GhcTc], a)
+addTickLStmts' isGuard lstmts res
+  = bindLocals (collectLStmtsBinders lstmts) $
+    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts
+       ; a <- res
+       ; return (lstmts', a) }
+
+addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)
+            -> TM (Stmt GhcTc (LHsExpr GhcTc))
+addTickStmt _isGuard (LastStmt x e noret ret) = do
+        liftM3 (LastStmt x)
+                (addTickLHsExpr e)
+                (pure noret)
+                (addTickSyntaxExpr hpcSrcSpan ret)
+addTickStmt _isGuard (BindStmt x pat e bind fail) = do
+        liftM4 (BindStmt x)
+                (addTickLPat pat)
+                (addTickLHsExprRHS e)
+                (addTickSyntaxExpr hpcSrcSpan bind)
+                (addTickSyntaxExpr hpcSrcSpan fail)
+addTickStmt isGuard (BodyStmt x e bind' guard') = do
+        liftM3 (BodyStmt x)
+                (addTick isGuard e)
+                (addTickSyntaxExpr hpcSrcSpan bind')
+                (addTickSyntaxExpr hpcSrcSpan guard')
+addTickStmt _isGuard (LetStmt x (dL->L l binds)) = do
+        liftM (LetStmt x . cL l)
+                (addTickHsLocalBinds binds)
+addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do
+    liftM3 (ParStmt x)
+        (mapM (addTickStmtAndBinders isGuard) pairs)
+        (unLoc <$> addTickLHsExpr (cL hpcSrcSpan mzipExpr))
+        (addTickSyntaxExpr hpcSrcSpan bindExpr)
+addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do
+    args' <- mapM (addTickApplicativeArg isGuard) args
+    return (ApplicativeStmt body_ty args' mb_join)
+
+addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
+                                    , trS_by = by, trS_using = using
+                                    , trS_ret = returnExpr, trS_bind = bindExpr
+                                    , trS_fmap = liftMExpr }) = do
+    t_s <- addTickLStmts isGuard stmts
+    t_y <- fmapMaybeM  addTickLHsExprRHS by
+    t_u <- addTickLHsExprRHS using
+    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
+    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
+    t_m <- fmap unLoc (addTickLHsExpr (cL hpcSrcSpan liftMExpr))
+    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
+                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
+
+addTickStmt isGuard stmt@(RecStmt {})
+  = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)
+       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
+       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
+       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
+       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
+
+addTickStmt _ (XStmtLR _) = panic "addTickStmt"
+
+addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
+addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e
+                  | otherwise          = addTickLHsExprRHS e
+
+addTickApplicativeArg
+  :: Maybe (Bool -> BoxLabel) -> (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
+  -> TM (SyntaxExpr GhcTc, ApplicativeArg GhcTc)
+addTickApplicativeArg isGuard (op, arg) =
+  liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
+ where
+  addTickArg (ApplicativeArgOne x pat expr isBody) =
+    (ApplicativeArgOne x)
+      <$> addTickLPat pat
+      <*> addTickLHsExpr expr
+      <*> pure isBody
+  addTickArg (ApplicativeArgMany x stmts ret pat) =
+    (ApplicativeArgMany x)
+      <$> addTickLStmts isGuard stmts
+      <*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret))
+      <*> addTickLPat pat
+  addTickArg (XApplicativeArg _) = panic "addTickApplicativeArg"
+
+addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock GhcTc GhcTc
+                      -> TM (ParStmtBlock GhcTc GhcTc)
+addTickStmtAndBinders isGuard (ParStmtBlock x stmts ids returnExpr) =
+    liftM3 (ParStmtBlock x)
+        (addTickLStmts isGuard stmts)
+        (return ids)
+        (addTickSyntaxExpr hpcSrcSpan returnExpr)
+addTickStmtAndBinders _ (XParStmtBlock{}) = panic "addTickStmtAndBinders"
+
+addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)
+addTickHsLocalBinds (HsValBinds x binds) =
+        liftM (HsValBinds x)
+                (addTickHsValBinds binds)
+addTickHsLocalBinds (HsIPBinds x binds)  =
+        liftM (HsIPBinds x)
+                (addTickHsIPBinds binds)
+addTickHsLocalBinds (EmptyLocalBinds x)  = return (EmptyLocalBinds x)
+addTickHsLocalBinds (XHsLocalBindsLR x)  = return (XHsLocalBindsLR x)
+
+addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)
+                  -> TM (HsValBindsLR GhcTc (GhcPass b))
+addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do
+        b <- liftM2 NValBinds
+                (mapM (\ (rec,binds') ->
+                                liftM2 (,)
+                                        (return rec)
+                                        (addTickLHsBinds binds'))
+                        binds)
+                (return sigs)
+        return $ XValBindsLR b
+addTickHsValBinds _ = panic "addTickHsValBinds"
+
+addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)
+addTickHsIPBinds (IPBinds dictbinds ipbinds) =
+        liftM2 IPBinds
+                (return dictbinds)
+                (mapM (liftL (addTickIPBind)) ipbinds)
+addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x)
+
+addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)
+addTickIPBind (IPBind x nm e) =
+        liftM2 (IPBind x)
+                (return nm)
+                (addTickLHsExpr e)
+addTickIPBind (XIPBind x) = return (XIPBind x)
+
+-- There is no location here, so we might need to use a context location??
+addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)
+addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do
+        x' <- fmap unLoc (addTickLHsExpr (cL pos x))
+        return $ syn { syn_expr = x' }
+-- we do not walk into patterns.
+addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)
+addTickLPat pat = return pat
+
+addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)
+addTickHsCmdTop (HsCmdTop x cmd) =
+        liftM2 HsCmdTop
+                (return x)
+                (addTickLHsCmd cmd)
+addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop"
+
+addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)
+addTickLHsCmd (dL->L pos c0) = do
+        c1 <- addTickHsCmd c0
+        return $ cL pos c1
+
+addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)
+addTickHsCmd (HsCmdLam x matchgroup) =
+        liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)
+addTickHsCmd (HsCmdApp x c e) =
+        liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)
+{-
+addTickHsCmd (OpApp e1 c2 fix c3) =
+        liftM4 OpApp
+                (addTickLHsExpr e1)
+                (addTickLHsCmd c2)
+                (return fix)
+                (addTickLHsCmd c3)
+-}
+addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)
+addTickHsCmd (HsCmdCase x e mgs) =
+        liftM2 (HsCmdCase x)
+                (addTickLHsExpr e)
+                (addTickCmdMatchGroup mgs)
+addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
+        liftM3 (HsCmdIf x cnd)
+                (addBinTickLHsExpr (BinBox CondBinBox) e1)
+                (addTickLHsCmd c2)
+                (addTickLHsCmd c3)
+addTickHsCmd (HsCmdLet x (dL->L l binds) c) =
+        bindLocals (collectLocalBinders binds) $
+          liftM2 (HsCmdLet x . cL l)
+                   (addTickHsLocalBinds binds) -- to think about: !patterns.
+                   (addTickLHsCmd c)
+addTickHsCmd (HsCmdDo srcloc (dL->L l stmts))
+  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
+       ; return (HsCmdDo srcloc (cL l stmts')) }
+
+addTickHsCmd (HsCmdArrApp  arr_ty e1 e2 ty1 lr) =
+        liftM5 HsCmdArrApp
+               (return arr_ty)
+               (addTickLHsExpr e1)
+               (addTickLHsExpr e2)
+               (return ty1)
+               (return lr)
+addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =
+        liftM4 (HsCmdArrForm x)
+               (addTickLHsExpr e)
+               (return f)
+               (return fix)
+               (mapM (liftL (addTickHsCmdTop)) cmdtop)
+
+addTickHsCmd (HsCmdWrap x w cmd)
+  = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd)
+
+addTickHsCmd e@(XCmd {})  = pprPanic "addTickHsCmd" (ppr e)
+
+-- Others should never happen in a command context.
+--addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
+
+addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)
+                     -> TM (MatchGroup GhcTc (LHsCmd GhcTc))
+addTickCmdMatchGroup mg@(MG { mg_alts = (dL->L l matches) }) = do
+  matches' <- mapM (liftL addTickCmdMatch) matches
+  return $ mg { mg_alts = cL l matches' }
+addTickCmdMatchGroup (XMatchGroup _) = panic "addTickCmdMatchGroup"
+
+addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))
+addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =
+  bindLocals (collectPatsBinders pats) $ do
+    gRHSs' <- addTickCmdGRHSs gRHSs
+    return $ match { m_grhss = gRHSs' }
+addTickCmdMatch (XMatch _) = panic "addTickCmdMatch"
+
+addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))
+addTickCmdGRHSs (GRHSs x guarded (dL->L l local_binds)) = do
+  bindLocals binders $ do
+    local_binds' <- addTickHsLocalBinds local_binds
+    guarded' <- mapM (liftL addTickCmdGRHS) guarded
+    return $ GRHSs x guarded' (cL l local_binds')
+  where
+    binders = collectLocalBinders local_binds
+addTickCmdGRHSs (XGRHSs _) = panic "addTickCmdGRHSs"
+
+addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc))
+-- The *guards* are *not* Cmds, although the body is
+-- C.f. addTickGRHS for the BinBox stuff
+addTickCmdGRHS (GRHS x stmts cmd)
+  = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox)
+                                   stmts (addTickLHsCmd cmd)
+       ; return $ GRHS x stmts' expr' }
+addTickCmdGRHS (XGRHS _) = panic "addTickCmdGRHS"
+
+addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]
+                 -> TM [LStmt GhcTc (LHsCmd GhcTc)]
+addTickLCmdStmts stmts = do
+  (stmts, _) <- addTickLCmdStmts' stmts (return ())
+  return stmts
+
+addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a
+                  -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)
+addTickLCmdStmts' lstmts res
+  = bindLocals binders $ do
+        lstmts' <- mapM (liftL addTickCmdStmt) lstmts
+        a <- res
+        return (lstmts', a)
+  where
+        binders = collectLStmtsBinders lstmts
+
+addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
+addTickCmdStmt (BindStmt x pat c bind fail) = do
+        liftM4 (BindStmt x)
+                (addTickLPat pat)
+                (addTickLHsCmd c)
+                (return bind)
+                (return fail)
+addTickCmdStmt (LastStmt x c noret ret) = do
+        liftM3 (LastStmt x)
+                (addTickLHsCmd c)
+                (pure noret)
+                (addTickSyntaxExpr hpcSrcSpan ret)
+addTickCmdStmt (BodyStmt x c bind' guard') = do
+        liftM3 (BodyStmt x)
+                (addTickLHsCmd c)
+                (addTickSyntaxExpr hpcSrcSpan bind')
+                (addTickSyntaxExpr hpcSrcSpan guard')
+addTickCmdStmt (LetStmt x (dL->L l binds)) = do
+        liftM (LetStmt x . cL l)
+                (addTickHsLocalBinds binds)
+addTickCmdStmt stmt@(RecStmt {})
+  = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
+       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
+       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
+       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
+       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
+addTickCmdStmt ApplicativeStmt{} =
+  panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
+addTickCmdStmt XStmtLR{} =
+  panic "addTickCmdStmt XStmtLR"
+
+-- Others should never happen in a command context.
+addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)
+
+addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)
+addTickHsRecordBinds (HsRecFields fields dd)
+  = do  { fields' <- mapM addTickHsRecField fields
+        ; return (HsRecFields fields' dd) }
+
+addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc)
+                  -> TM (LHsRecField' id (LHsExpr GhcTc))
+addTickHsRecField (dL->L l (HsRecField id expr pun))
+        = do { expr' <- addTickLHsExpr expr
+             ; return (cL l (HsRecField id expr' pun)) }
+
+
+addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)
+addTickArithSeqInfo (From e1) =
+        liftM From
+                (addTickLHsExpr e1)
+addTickArithSeqInfo (FromThen e1 e2) =
+        liftM2 FromThen
+                (addTickLHsExpr e1)
+                (addTickLHsExpr e2)
+addTickArithSeqInfo (FromTo e1 e2) =
+        liftM2 FromTo
+                (addTickLHsExpr e1)
+                (addTickLHsExpr e2)
+addTickArithSeqInfo (FromThenTo e1 e2 e3) =
+        liftM3 FromThenTo
+                (addTickLHsExpr e1)
+                (addTickLHsExpr e2)
+                (addTickLHsExpr e3)
+
+data TickTransState = TT { tickBoxCount:: Int
+                         , mixEntries  :: [MixEntry_]
+                         , ccIndices   :: CostCentreState
+                         }
+
+data TickTransEnv = TTE { fileName     :: FastString
+                        , density      :: TickDensity
+                        , tte_dflags   :: DynFlags
+                        , exports      :: NameSet
+                        , inlines      :: VarSet
+                        , declPath     :: [String]
+                        , inScope      :: VarSet
+                        , blackList    :: Map SrcSpan ()
+                        , this_mod     :: Module
+                        , tickishType  :: TickishType
+                        }
+
+--      deriving Show
+
+data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes
+                 deriving (Eq)
+
+coveragePasses :: DynFlags -> [TickishType]
+coveragePasses dflags =
+    ifa (hscTarget dflags == HscInterpreted) Breakpoints $
+    ifa (gopt Opt_Hpc dflags)                HpcTicks $
+    ifa (gopt Opt_SccProfilingOn dflags &&
+         profAuto dflags /= NoProfAuto)      ProfNotes $
+    ifa (debugLevel dflags > 0)              SourceNotes []
+  where ifa f x xs | f         = x:xs
+                   | otherwise = xs
+
+-- | Tickishs that only make sense when their source code location
+-- refers to the current file. This might not always be true due to
+-- LINE pragmas in the code - which would confuse at least HPC.
+tickSameFileOnly :: TickishType -> Bool
+tickSameFileOnly HpcTicks = True
+tickSameFileOnly _other   = False
+
+type FreeVars = OccEnv Id
+noFVs :: FreeVars
+noFVs = emptyOccEnv
+
+-- Note [freevars]
+--   For breakpoints we want to collect the free variables of an
+--   expression for pinning on the HsTick.  We don't want to collect
+--   *all* free variables though: in particular there's no point pinning
+--   on free variables that are will otherwise be in scope at the GHCi
+--   prompt, which means all top-level bindings.  Unfortunately detecting
+--   top-level bindings isn't easy (collectHsBindsBinders on the top-level
+--   bindings doesn't do it), so we keep track of a set of "in-scope"
+--   variables in addition to the free variables, and the former is used
+--   to filter additions to the latter.  This gives us complete control
+--   over what free variables we track.
+
+data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }
+        -- a combination of a state monad (TickTransState) and a writer
+        -- monad (FreeVars).
+
+instance Functor TM where
+    fmap = liftM
+
+instance Applicative TM where
+    pure a = TM $ \ _env st -> (a,noFVs,st)
+    (<*>) = ap
+
+instance Monad TM where
+  (TM m) >>= k = TM $ \ env st ->
+                                case m env st of
+                                  (r1,fv1,st1) ->
+                                     case unTM (k r1) env st1 of
+                                       (r2,fv2,st2) ->
+                                          (r2, fv1 `plusOccEnv` fv2, st2)
+
+instance HasDynFlags TM where
+  getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)
+
+-- | Get the next HPC cost centre index for a given centre name
+getCCIndexM :: FastString -> TM CostCentreIndex
+getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $
+                                                 ccIndices st
+                              in (idx, noFVs, st { ccIndices = is' })
+
+getState :: TM TickTransState
+getState = TM $ \ _ st -> (st, noFVs, st)
+
+setState :: (TickTransState -> TickTransState) -> TM ()
+setState f = TM $ \ _ st -> ((), noFVs, f st)
+
+getEnv :: TM TickTransEnv
+getEnv = TM $ \ env st -> (env, noFVs, st)
+
+withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a
+withEnv f (TM m) = TM $ \ env st ->
+                                 case m (f env) st of
+                                   (a, fvs, st') -> (a, fvs, st')
+
+getDensity :: TM TickDensity
+getDensity = TM $ \env st -> (density env, noFVs, st)
+
+ifDensity :: TickDensity -> TM a -> TM a -> TM a
+ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el
+
+getFreeVars :: TM a -> TM (FreeVars, a)
+getFreeVars (TM m)
+  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')
+
+freeVar :: Id -> TM ()
+freeVar id = TM $ \ env st ->
+                if id `elemVarSet` inScope env
+                   then ((), unitOccEnv (nameOccName (idName id)) id, st)
+                   else ((), noFVs, st)
+
+addPathEntry :: String -> TM a -> TM a
+addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })
+
+getPathEntry :: TM [String]
+getPathEntry = declPath `liftM` getEnv
+
+getFileName :: TM FastString
+getFileName = fileName `liftM` getEnv
+
+isGoodSrcSpan' :: SrcSpan -> Bool
+isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
+isGoodSrcSpan' (UnhelpfulSpan _) = False
+
+isGoodTickSrcSpan :: SrcSpan -> TM Bool
+isGoodTickSrcSpan pos = do
+  file_name <- getFileName
+  tickish <- tickishType `liftM` getEnv
+  let need_same_file = tickSameFileOnly tickish
+      same_file      = Just file_name == srcSpanFileName_maybe pos
+  return (isGoodSrcSpan' pos && (not need_same_file || same_file))
+
+ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a
+ifGoodTickSrcSpan pos then_code else_code = do
+  good <- isGoodTickSrcSpan pos
+  if good then then_code else else_code
+
+bindLocals :: [Id] -> TM a -> TM a
+bindLocals new_ids (TM m)
+  = TM $ \ env st ->
+                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of
+                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')
+  where occs = [ nameOccName (idName id) | id <- new_ids ]
+
+isBlackListed :: SrcSpan -> TM Bool
+isBlackListed pos = TM $ \ env st ->
+              case Map.lookup pos (blackList env) of
+                Nothing -> (False,noFVs,st)
+                Just () -> (True,noFVs,st)
+
+-- the tick application inherits the source position of its
+-- expression argument to support nested box allocations
+allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)
+             -> TM (LHsExpr GhcTc)
+allocTickBox boxLabel countEntries topOnly pos m =
+  ifGoodTickSrcSpan pos (do
+    (fvs, e) <- getFreeVars m
+    env <- getEnv
+    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)
+    return (cL pos (HsTick noExt tickish (cL pos e)))
+  ) (do
+    e <- m
+    return (cL pos e)
+  )
+
+-- the tick application inherits the source position of its
+-- expression argument to support nested box allocations
+allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars
+              -> TM (Maybe (Tickish Id))
+allocATickBox boxLabel countEntries topOnly  pos fvs =
+  ifGoodTickSrcSpan pos (do
+    let
+      mydecl_path = case boxLabel of
+                      TopLevelBox x -> x
+                      LocalBox xs  -> xs
+                      _ -> panic "allocATickBox"
+    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path
+    return (Just tickish)
+  ) (return Nothing)
+
+
+mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]
+          -> TM (Tickish Id)
+mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
+
+  let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs
+          -- unlifted types cause two problems here:
+          --   * we can't bind them  at the GHCi prompt
+          --     (bindLocalsAtBreakpoint already fliters them out),
+          --   * the simplifier might try to substitute a literal for
+          --     the Id, and we can't handle that.
+
+      me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)
+
+      cc_name | topOnly   = head decl_path
+              | otherwise = concat (intersperse "." decl_path)
+
+  dflags <- getDynFlags
+  env <- getEnv
+  case tickishType env of
+    HpcTicks -> do
+      c <- liftM tickBoxCount getState
+      setState $ \st -> st { tickBoxCount = c + 1
+                           , mixEntries = me : mixEntries st }
+      return $ HpcTick (this_mod env) c
+
+    ProfNotes -> do
+      let nm = mkFastString cc_name
+      flavour <- HpcCC <$> getCCIndexM nm
+      let cc = mkUserCC nm (this_mod env) pos flavour
+          count = countEntries && gopt Opt_ProfCountEntries dflags
+      return $ ProfNote cc count True{-scopes-}
+
+    Breakpoints -> do
+      c <- liftM tickBoxCount getState
+      setState $ \st -> st { tickBoxCount = c + 1
+                           , mixEntries = me:mixEntries st }
+      return $ Breakpoint c ids
+
+    SourceNotes | RealSrcSpan pos' <- pos ->
+      return $ SourceNote pos' cc_name
+
+    _otherwise -> panic "mkTickish: bad source span!"
+
+
+allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)
+                -> TM (LHsExpr GhcTc)
+allocBinTickBox boxLabel pos m = do
+  env <- getEnv
+  case tickishType env of
+    HpcTicks -> do e <- liftM (cL pos) m
+                   ifGoodTickSrcSpan pos
+                     (mkBinTickBoxHpc boxLabel pos e)
+                     (return e)
+    _other   -> allocTickBox (ExpBox False) False False pos m
+
+mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc
+                -> TM (LHsExpr GhcTc)
+mkBinTickBoxHpc boxLabel pos e =
+ TM $ \ env st ->
+  let meT = (pos,declPath env, [],boxLabel True)
+      meF = (pos,declPath env, [],boxLabel False)
+      meE = (pos,declPath env, [],ExpBox False)
+      c = tickBoxCount st
+      mes = mixEntries st
+  in
+     ( cL pos $ HsTick noExt (HpcTick (this_mod env) c)
+          $ cL pos $ HsBinTick noExt (c+1) (c+2) e
+   -- notice that F and T are reversed,
+   -- because we are building the list in
+   -- reverse...
+     , noFVs
+     , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}
+     )
+
+mkHpcPos :: SrcSpan -> HpcPos
+mkHpcPos pos@(RealSrcSpan s)
+   | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
+                                    srcSpanStartCol s,
+                                    srcSpanEndLine s,
+                                    srcSpanEndCol s - 1)
+                              -- the end column of a SrcSpan is one
+                              -- greater than the last column of the
+                              -- span (see SrcLoc), whereas HPC
+                              -- expects to the column range to be
+                              -- inclusive, hence we subtract one above.
+mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
+
+hpcSrcSpan :: SrcSpan
+hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
+
+matchesOneOfMany :: [LMatch GhcTc body] -> Bool
+matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1
+  where
+        matchCount (dL->L _ (Match { m_grhss = GRHSs _ grhss _ }))
+          = length grhss
+        matchCount (dL->L _ (Match { m_grhss = XGRHSs _ }))
+          = panic "matchesOneOfMany"
+        matchCount (dL->L _ (XMatch _)) = panic "matchesOneOfMany"
+        matchCount _ = panic "matchCount: Impossible Match" -- due to #15884
+
+type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)
+
+-- For the hash value, we hash everything: the file name,
+--  the timestamp of the original source file, the tab stop,
+--  and the mix entries. We cheat, and hash the show'd string.
+-- This hash only has to be hashed at Mix creation time,
+-- and is for sanity checking only.
+
+mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int
+mixHash file tm tabstop entries = fromIntegral $ hashString
+        (show $ Mix file tm 0 tabstop entries)
+
+{-
+************************************************************************
+*                                                                      *
+*              initialisation
+*                                                                      *
+************************************************************************
+
+Each module compiled with -fhpc declares an initialisation function of
+the form `hpc_init_<module>()`, which is emitted into the _stub.c file
+and annotated with __attribute__((constructor)) so that it gets
+executed at startup time.
+
+The function's purpose is to call hs_hpc_module to register this
+module with the RTS, and it looks something like this:
+
+static void hpc_init_Main(void) __attribute__((constructor));
+static void hpc_init_Main(void)
+{extern StgWord64 _hpc_tickboxes_Main_hpc[];
+ hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}
+-}
+
+hpcInitCode :: Module -> HpcInfo -> SDoc
+hpcInitCode _ (NoHpcInfo {}) = Outputable.empty
+hpcInitCode this_mod (HpcInfo tickCount hashNo)
+ = vcat
+    [ text "static void hpc_init_" <> ppr this_mod
+         <> text "(void) __attribute__((constructor));"
+    , text "static void hpc_init_" <> ppr this_mod <> text "(void)"
+    , braces (vcat [
+        text "extern StgWord64 " <> tickboxes <>
+               text "[]" <> semi,
+        text "hs_hpc_module" <>
+          parens (hcat (punctuate comma [
+              doubleQuotes full_name_str,
+              int tickCount, -- really StgWord32
+              int hashNo,    -- really StgWord32
+              tickboxes
+            ])) <> semi
+       ])
+    ]
+  where
+    tickboxes = ppr (mkHpcTicksLabel $ this_mod)
+
+    module_name  = hcat (map (text.charToC) $
+                         bytesFS (moduleNameFS (Module.moduleName this_mod)))
+    package_name = hcat (map (text.charToC) $
+                         bytesFS (unitIdFS  (moduleUnitId this_mod)))
+    full_name_str
+       | moduleUnitId this_mod == mainUnitId
+       = module_name
+       | otherwise
+       = package_name <> char '/' <> module_name
diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/Desugar.hs
@@ -0,0 +1,546 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+The Desugarer: turning HsSyn into Core.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Desugar (
+    -- * Desugaring operations
+    deSugar, deSugarExpr
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import DsUsage
+import DynFlags
+import HscTypes
+import HsSyn
+import TcRnTypes
+import TcRnMonad  ( finalSafeMode, fixSafeInstances )
+import TcRnDriver ( runTcInteractive )
+import Id
+import Name
+import Type
+import Avail
+import CoreSyn
+import CoreFVs     ( exprsSomeFreeVarsList )
+import CoreOpt     ( simpleOptPgm, simpleOptExpr )
+import PprCore
+import DsMonad
+import DsExpr
+import DsBinds
+import DsForeign
+import PrelNames   ( coercibleTyConKey )
+import TysPrim     ( eqReprPrimTyCon )
+import Unique      ( hasKey )
+import Coercion    ( mkCoVarCo )
+import TysWiredIn  ( coercibleDataCon )
+import DataCon     ( dataConWrapId )
+import MkCore      ( mkCoreLet )
+import Module
+import NameSet
+import NameEnv
+import Rules
+import BasicTypes       ( Activation(.. ), competesWith, pprRuleName )
+import CoreMonad        ( CoreToDo(..) )
+import CoreLint         ( endPassIO )
+import VarSet
+import FastString
+import ErrUtils
+import Outputable
+import SrcLoc
+import Coverage
+import Util
+import MonadUtils
+import OrdList
+import ExtractDocs
+
+import Data.List
+import Data.IORef
+import Control.Monad( when )
+import Plugins ( LoadedPlugin(..) )
+
+{-
+************************************************************************
+*                                                                      *
+*              The main function: deSugar
+*                                                                      *
+************************************************************************
+-}
+
+-- | Main entry point to the desugarer.
+deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)
+-- Can modify PCS by faulting in more declarations
+
+deSugar hsc_env
+        mod_loc
+        tcg_env@(TcGblEnv { tcg_mod          = id_mod,
+                            tcg_semantic_mod = mod,
+                            tcg_src          = hsc_src,
+                            tcg_type_env     = type_env,
+                            tcg_imports      = imports,
+                            tcg_exports      = exports,
+                            tcg_keep         = keep_var,
+                            tcg_th_splice_used = tc_splice_used,
+                            tcg_rdr_env      = rdr_env,
+                            tcg_fix_env      = fix_env,
+                            tcg_inst_env     = inst_env,
+                            tcg_fam_inst_env = fam_inst_env,
+                            tcg_merged       = merged,
+                            tcg_warns        = warns,
+                            tcg_anns         = anns,
+                            tcg_binds        = binds,
+                            tcg_imp_specs    = imp_specs,
+                            tcg_dependent_files = dependent_files,
+                            tcg_ev_binds     = ev_binds,
+                            tcg_th_foreign_files = th_foreign_files_var,
+                            tcg_fords        = fords,
+                            tcg_rules        = rules,
+                            tcg_patsyns      = patsyns,
+                            tcg_tcs          = tcs,
+                            tcg_insts        = insts,
+                            tcg_fam_insts    = fam_insts,
+                            tcg_hpc          = other_hpc_info,
+                            tcg_complete_matches = complete_matches
+                            })
+
+  = do { let dflags = hsc_dflags hsc_env
+             print_unqual = mkPrintUnqualified dflags rdr_env
+        ; withTiming (pure dflags)
+                     (text "Desugar"<+>brackets (ppr mod))
+                     (const ()) $
+     do { -- Desugar the program
+        ; let export_set = availsToNameSet exports
+              target     = hscTarget dflags
+              hpcInfo    = emptyHpcInfo other_hpc_info
+
+        ; (binds_cvr, ds_hpc_info, modBreaks)
+                         <- if not (isHsBootOrSig hsc_src)
+                              then addTicksToBinds hsc_env mod mod_loc
+                                       export_set (typeEnvTyCons type_env) binds
+                              else return (binds, hpcInfo, Nothing)
+        ; (msgs, mb_res) <- initDs hsc_env tcg_env $
+                       do { ds_ev_binds <- dsEvBinds ev_binds
+                          ; core_prs <- dsTopLHsBinds binds_cvr
+                          ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
+                          ; (ds_fords, foreign_prs) <- dsForeigns fords
+                          ; ds_rules <- mapMaybeM dsRule rules
+                          ; let hpc_init
+                                  | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
+                                  | otherwise = empty
+                          ; return ( ds_ev_binds
+                                   , foreign_prs `appOL` core_prs `appOL` spec_prs
+                                   , spec_rules ++ ds_rules
+                                   , ds_fords `appendStubC` hpc_init) }
+
+        ; case mb_res of {
+           Nothing -> return (msgs, Nothing) ;
+           Just (ds_ev_binds, all_prs, all_rules, ds_fords) ->
+
+     do {       -- Add export flags to bindings
+          keep_alive <- readIORef keep_var
+        ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules
+              final_prs = addExportFlagsAndRules target export_set keep_alive
+                                                 rules_for_locals (fromOL all_prs)
+
+              final_pgm = combineEvBinds ds_ev_binds final_prs
+        -- Notice that we put the whole lot in a big Rec, even the foreign binds
+        -- When compiling PrelFloat, which defines data Float = F# Float#
+        -- we want F# to be in scope in the foreign marshalling code!
+        -- You might think it doesn't matter, but the simplifier brings all top-level
+        -- things into the in-scope set before simplifying; so we get no unfolding for F#!
+
+        ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
+        ; (ds_binds, ds_rules_for_imps)
+            <- simpleOptPgm dflags mod final_pgm rules_for_imps
+                         -- The simpleOptPgm gets rid of type
+                         -- bindings plus any stupid dead code
+
+        ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
+
+        ; let used_names = mkUsedNames tcg_env
+              pluginModules =
+                map lpModule (cachedPlugins (hsc_dflags hsc_env))
+        ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env))
+                                 (map mi_module pluginModules) tcg_env
+
+        ; used_th <- readIORef tc_splice_used
+        ; dep_files <- readIORef dependent_files
+        ; safe_mode <- finalSafeMode dflags tcg_env
+        ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names
+                      dep_files merged pluginModules
+        -- id_mod /= mod when we are processing an hsig, but hsigs
+        -- never desugared and compiled (there's no code!)
+        -- Consequently, this should hold for any ModGuts that make
+        -- past desugaring. See Note [Identity versus semantic module].
+        ; MASSERT( id_mod == mod )
+
+        ; foreign_files <- readIORef th_foreign_files_var
+
+        ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env
+
+        ; let mod_guts = ModGuts {
+                mg_module       = mod,
+                mg_hsc_src      = hsc_src,
+                mg_loc          = mkFileSrcSpan mod_loc,
+                mg_exports      = exports,
+                mg_usages       = usages,
+                mg_deps         = deps,
+                mg_used_th      = used_th,
+                mg_rdr_env      = rdr_env,
+                mg_fix_env      = fix_env,
+                mg_warns        = warns,
+                mg_anns         = anns,
+                mg_tcs          = tcs,
+                mg_insts        = fixSafeInstances safe_mode insts,
+                mg_fam_insts    = fam_insts,
+                mg_inst_env     = inst_env,
+                mg_fam_inst_env = fam_inst_env,
+                mg_patsyns      = patsyns,
+                mg_rules        = ds_rules_for_imps,
+                mg_binds        = ds_binds,
+                mg_foreign      = ds_fords,
+                mg_foreign_files = foreign_files,
+                mg_hpc_info     = ds_hpc_info,
+                mg_modBreaks    = modBreaks,
+                mg_safe_haskell = safe_mode,
+                mg_trust_pkg    = imp_trust_own_pkg imports,
+                mg_complete_sigs = complete_matches,
+                mg_doc_hdr      = doc_hdr,
+                mg_decl_docs    = decl_docs,
+                mg_arg_docs     = arg_docs
+              }
+        ; return (msgs, Just mod_guts)
+        }}}}
+
+mkFileSrcSpan :: ModLocation -> SrcSpan
+mkFileSrcSpan mod_loc
+  = case ml_hs_file mod_loc of
+      Just file_path -> mkGeneralSrcSpan (mkFastString file_path)
+      Nothing        -> interactiveSrcSpan   -- Presumably
+
+dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])
+dsImpSpecs imp_specs
+ = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs
+      ; let (spec_binds, spec_rules) = unzip spec_prs
+      ; return (concatOL spec_binds, spec_rules) }
+
+combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
+-- Top-level bindings can include coercion bindings, but not via superclasses
+-- See Note [Top-level evidence]
+combineEvBinds [] val_prs
+  = [Rec val_prs]
+combineEvBinds (NonRec b r : bs) val_prs
+  | isId b    = combineEvBinds bs ((b,r):val_prs)
+  | otherwise = NonRec b r : combineEvBinds bs val_prs
+combineEvBinds (Rec prs : bs) val_prs
+  = combineEvBinds bs (prs ++ val_prs)
+
+{-
+Note [Top-level evidence]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Top-level evidence bindings may be mutually recursive with the top-level value
+bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
+because the occurrence analyser doesn't take account of type/coercion variables
+when computing dependencies.
+
+So we pull out the type/coercion variables (which are in dependency order),
+and Rec the rest.
+-}
+
+deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr)
+
+deSugarExpr hsc_env tc_expr = do {
+         let dflags = hsc_dflags hsc_env
+
+       ; showPass dflags "Desugar"
+
+         -- Do desugaring
+       ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $
+                                 dsLExpr tc_expr
+
+       ; case mb_core_expr of
+            Nothing   -> return ()
+            Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared"
+                         (pprCoreExpr expr)
+
+       ; return (msgs, mb_core_expr) }
+
+{-
+************************************************************************
+*                                                                      *
+*              Add rules and export flags to binders
+*                                                                      *
+************************************************************************
+-}
+
+addExportFlagsAndRules
+    :: HscTarget -> NameSet -> NameSet -> [CoreRule]
+    -> [(Id, t)] -> [(Id, t)]
+addExportFlagsAndRules target exports keep_alive rules prs
+  = mapFst add_one prs
+  where
+    add_one bndr = add_rules name (add_export name bndr)
+       where
+         name = idName bndr
+
+    ---------- Rules --------
+        -- See Note [Attach rules to local ids]
+        -- NB: the binder might have some existing rules,
+        -- arising from specialisation pragmas
+    add_rules name bndr
+        | Just rules <- lookupNameEnv rule_base name
+        = bndr `addIdSpecialisations` rules
+        | otherwise
+        = bndr
+    rule_base = extendRuleBaseList emptyRuleBase rules
+
+    ---------- Export flag --------
+    -- See Note [Adding export flags]
+    add_export name bndr
+        | dont_discard name = setIdExported bndr
+        | otherwise         = bndr
+
+    dont_discard :: Name -> Bool
+    dont_discard name = is_exported name
+                     || name `elemNameSet` keep_alive
+
+        -- In interactive mode, we don't want to discard any top-level
+        -- entities at all (eg. do not inline them away during
+        -- simplification), and retain them all in the TypeEnv so they are
+        -- available from the command line.
+        --
+        -- isExternalName separates the user-defined top-level names from those
+        -- introduced by the type checker.
+    is_exported :: Name -> Bool
+    is_exported | targetRetainsAllBindings target = isExternalName
+                | otherwise                       = (`elemNameSet` exports)
+
+{-
+Note [Adding export flags]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Set the no-discard flag if either
+        a) the Id is exported
+        b) it's mentioned in the RHS of an orphan rule
+        c) it's in the keep-alive set
+
+It means that the binding won't be discarded EVEN if the binding
+ends up being trivial (v = w) -- the simplifier would usually just
+substitute w for v throughout, but we don't apply the substitution to
+the rules (maybe we should?), so this substitution would make the rule
+bogus.
+
+You might wonder why exported Ids aren't already marked as such;
+it's just because the type checker is rather busy already and
+I didn't want to pass in yet another mapping.
+
+Note [Attach rules to local ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Find the rules for locally-defined Ids; then we can attach them
+to the binders in the top-level bindings
+
+Reason
+  - It makes the rules easier to look up
+  - It means that transformation rules and specialisations for
+    locally defined Ids are handled uniformly
+  - It keeps alive things that are referred to only from a rule
+    (the occurrence analyser knows about rules attached to Ids)
+  - It makes sure that, when we apply a rule, the free vars
+    of the RHS are more likely to be in scope
+  - The imported rules are carried in the in-scope set
+    which is extended on each iteration by the new wave of
+    local binders; any rules which aren't on the binding will
+    thereby get dropped
+
+
+************************************************************************
+*                                                                      *
+*              Desugaring transformation rules
+*                                                                      *
+************************************************************************
+-}
+
+dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)
+dsRule (dL->L loc (HsRule { rd_name = name
+                          , rd_act  = rule_act
+                          , rd_tmvs = vars
+                          , rd_lhs  = lhs
+                          , rd_rhs  = rhs }))
+  = putSrcSpanDs loc $
+    do  { let bndrs' = [var | (dL->L _ (RuleBndr _ (dL->L _ var))) <- vars]
+
+        ; lhs' <- unsetGOptM Opt_EnableRewriteRules $
+                  unsetWOptM Opt_WarnIdentities $
+                  dsLExpr lhs   -- Note [Desugaring RULE left hand sides]
+
+        ; rhs' <- dsLExpr rhs
+        ; this_mod <- getModule
+
+        ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
+
+        -- Substitute the dict bindings eagerly,
+        -- and take the body apart into a (f args) form
+        ; dflags <- getDynFlags
+        ; case decomposeRuleLhs dflags bndrs'' lhs'' of {
+                Left msg -> do { warnDs NoReason msg; return Nothing } ;
+                Right (final_bndrs, fn_id, args) -> do
+
+        { let is_local = isLocalId fn_id
+                -- NB: isLocalId is False of implicit Ids.  This is good because
+                -- we don't want to attach rules to the bindings of implicit Ids,
+                -- because they don't show up in the bindings until just before code gen
+              fn_name   = idName fn_id
+              final_rhs = simpleOptExpr dflags rhs''    -- De-crap it
+              rule_name = snd (unLoc name)
+              final_bndrs_set = mkVarSet final_bndrs
+              arg_ids = filterOut (`elemVarSet` final_bndrs_set) $
+                        exprsSomeFreeVarsList isId args
+
+        ; rule <- dsMkUserRule this_mod is_local
+                         rule_name rule_act fn_name final_bndrs args
+                         final_rhs
+        ; when (wopt Opt_WarnInlineRuleShadowing dflags) $
+          warnRuleShadowing rule_name rule_act fn_id arg_ids
+
+        ; return (Just rule)
+        } } }
+dsRule (dL->L _ (XRuleDecl _)) = panic "dsRule"
+dsRule _ = panic "dsRule: Impossible Match" -- due to #15884
+
+warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()
+-- See Note [Rules and inlining/other rules]
+warnRuleShadowing rule_name rule_act fn_id arg_ids
+  = do { check False fn_id    -- We often have multiple rules for the same Id in a
+                              -- module. Maybe we should check that they don't overlap
+                              -- but currently we don't
+       ; mapM_ (check True) arg_ids }
+  where
+    check check_rules_too lhs_id
+      | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)
+                       -- If imported with no unfolding, no worries
+      , idInlineActivation lhs_id `competesWith` rule_act
+      = warnDs (Reason Opt_WarnInlineRuleShadowing)
+               (vcat [ hang (text "Rule" <+> pprRuleName rule_name
+                               <+> text "may never fire")
+                            2 (text "because" <+> quotes (ppr lhs_id)
+                               <+> text "might inline first")
+                     , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"
+                       <+> quotes (ppr lhs_id)
+                     , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])
+
+      | check_rules_too
+      , bad_rule : _ <- get_bad_rules lhs_id
+      = warnDs (Reason Opt_WarnInlineRuleShadowing)
+               (vcat [ hang (text "Rule" <+> pprRuleName rule_name
+                               <+> text "may never fire")
+                            2 (text "because rule" <+> pprRuleName (ruleName bad_rule)
+                               <+> text "for"<+> quotes (ppr lhs_id)
+                               <+> text "might fire first")
+                      , text "Probable fix: add phase [n] or [~n] to the competing rule"
+                      , whenPprDebug (ppr bad_rule) ])
+
+      | otherwise
+      = return ()
+
+    get_bad_rules lhs_id
+      = [ rule | rule <- idCoreRules lhs_id
+               , ruleActivation rule `competesWith` rule_act ]
+
+-- See Note [Desugaring coerce as cast]
+unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
+unfold_coerce bndrs lhs rhs = do
+    (bndrs', wrap) <- go bndrs
+    return (bndrs', wrap lhs, wrap rhs)
+  where
+    go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)
+    go []     = return ([], id)
+    go (v:vs)
+        | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v)
+        , tc `hasKey` coercibleTyConKey = do
+            u <- newUnique
+
+            let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2]
+                v'  = mkLocalCoVar
+                        (mkDerivedInternalName mkRepEqOcc u (getName v)) ty'
+                box = Var (dataConWrapId coercibleDataCon) `mkTyApps`
+                      [k, t1, t2] `App`
+                      Coercion (mkCoVarCo v')
+
+            (bndrs, wrap) <- go vs
+            return (v':bndrs, mkCoreLet (NonRec v box) . wrap)
+        | otherwise = do
+            (bndrs,wrap) <- go vs
+            return (v:bndrs, wrap)
+
+{- Note [Desugaring RULE left hand sides]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For the LHS of a RULE we do *not* want to desugar
+    [x]   to    build (\cn. x `c` n)
+We want to leave explicit lists simply as chains
+of cons's. We can achieve that slightly indirectly by
+switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
+
+That keeps the desugaring of list comprehensions simple too.
+
+Nor do we want to warn of conversion identities on the LHS;
+the rule is precisely to optimise them:
+  {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
+
+Note [Desugaring coerce as cast]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want the user to express a rule saying roughly “mapping a coercion over a
+list can be replaced by a coercion”. But the cast operator of Core (▷) cannot
+be written in Haskell. So we use `coerce` for that (#2110). The user writes
+    map coerce = coerce
+as a RULE, and this optimizes any kind of mapped' casts away, including `map
+MkNewtype`.
+
+For that we replace any forall'ed `c :: Coercible a b` value in a RULE by
+corresponding `co :: a ~#R b` and wrap the LHS and the RHS in
+`let c = MkCoercible co in ...`. This is later simplified to the desired form
+by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).
+See also Note [Getting the map/coerce RULE to work] in CoreSubst.
+
+Note [Rules and inlining/other rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If you have
+  f x = ...
+  g x = ...
+  {-# RULES "rule-for-f" forall x. f (g x) = ... #-}
+then there's a good chance that in a potential rule redex
+    ...f (g e)...
+then 'f' or 'g' will inline befor the rule can fire.  Solution: add an
+INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.
+
+Note that this applies to all the free variables on the LHS, both the
+main function and things in its arguments.
+
+We also check if there are Ids on the LHS that have competing RULES.
+In the above example, suppose we had
+  {-# RULES "rule-for-g" forally. g [y] = ... #-}
+Then "rule-for-f" and "rule-for-g" would compete.  Better to add phase
+control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes
+active; or perhpas after "rule-for-g" has become inactive. This is checked
+by 'competesWith'
+
+Class methods have a built-in RULE to select the method from the dictionary,
+so you can't change the phase on this.  That makes id very dubious to
+match on class methods in RULE lhs's.   See Trac #10595.   I'm not happy
+about this. For example in Control.Arrow we have
+
+{-# RULES "compose/arr"   forall f g .
+                          (arr f) . (arr g) = arr (f . g) #-}
+
+and similar, which will elicit exactly these warnings, and risk never
+firing.  But it's not clear what to do instead.  We could make the
+class method rules inactive in phase 2, but that would delay when
+subsequent transformations could fire.
+-}
diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsArrows.hs
@@ -0,0 +1,1270 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Desugaring arrow commands
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module DsArrows ( dsProcExpr ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Match
+import DsUtils
+import DsMonad
+
+import HsSyn    hiding (collectPatBinders, collectPatsBinders,
+                        collectLStmtsBinders, collectLStmtBinders,
+                        collectStmtBinders )
+import TcHsSyn
+import qualified HsUtils
+
+-- NB: The desugarer, which straddles the source and Core worlds, sometimes
+--     needs to see source types (newtypes etc), and sometimes not
+--     So WATCH OUT; check each use of split*Ty functions.
+-- Sigh.  This is a pain.
+
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds,
+                               dsSyntaxExpr )
+
+import TcType
+import Type ( splitPiTy )
+import TcEvidence
+import CoreSyn
+import CoreFVs
+import CoreUtils
+import MkCore
+import DsBinds (dsHsWrapper)
+
+import Name
+import Id
+import ConLike
+import TysWiredIn
+import BasicTypes
+import PrelNames
+import Outputable
+import Bag
+import VarSet
+import SrcLoc
+import ListSetOps( assocMaybe )
+import Data.List
+import Util
+import UniqDSet
+
+data DsCmdEnv = DsCmdEnv {
+        arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
+    }
+
+mkCmdEnv :: CmdSyntaxTable GhcTc -> DsM ([CoreBind], DsCmdEnv)
+-- See Note [CmdSyntaxTable] in HsExpr
+mkCmdEnv tc_meths
+  = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths
+
+       -- NB: Some of these lookups might fail, but that's OK if the
+       -- symbol is never used. That's why we use Maybe first and then
+       -- panic. An eager panic caused trouble in typecheck/should_compile/tc192
+       ; let the_arr_id     = assocMaybe prs arrAName
+             the_compose_id = assocMaybe prs composeAName
+             the_first_id   = assocMaybe prs firstAName
+             the_app_id     = assocMaybe prs appAName
+             the_choice_id  = assocMaybe prs choiceAName
+             the_loop_id    = assocMaybe prs loopAName
+
+           -- used as an argument in, e.g., do_premap
+       ; check_lev_poly 3 the_arr_id
+
+           -- used as an argument in, e.g., dsCmdStmt/BodyStmt
+       ; check_lev_poly 5 the_compose_id
+
+           -- used as an argument in, e.g., dsCmdStmt/BodyStmt
+       ; check_lev_poly 4 the_first_id
+
+           -- the result of the_app_id is used as an argument in, e.g.,
+           -- dsCmd/HsCmdArrApp/HsHigherOrderApp
+       ; check_lev_poly 2 the_app_id
+
+           -- used as an argument in, e.g., HsCmdIf
+       ; check_lev_poly 5 the_choice_id
+
+           -- used as an argument in, e.g., RecStmt
+       ; check_lev_poly 4 the_loop_id
+
+       ; return (meth_binds, DsCmdEnv {
+               arr_id     = Var (unmaybe the_arr_id arrAName),
+               compose_id = Var (unmaybe the_compose_id composeAName),
+               first_id   = Var (unmaybe the_first_id firstAName),
+               app_id     = Var (unmaybe the_app_id appAName),
+               choice_id  = Var (unmaybe the_choice_id choiceAName),
+               loop_id    = Var (unmaybe the_loop_id loopAName)
+             }) }
+  where
+    mk_bind (std_name, expr)
+      = do { rhs <- dsExpr expr
+           ; id <- newSysLocalDs (exprType rhs)
+           -- no check needed; these are functions
+           ; return (NonRec id rhs, (std_name, id)) }
+
+    unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name)
+    unmaybe (Just id) _  = id
+
+      -- returns the result type of a pi-type (that is, a forall or a function)
+      -- Note that this result type may be ill-scoped.
+    res_type :: Type -> Type
+    res_type ty = res_ty
+      where
+        (_, res_ty) = splitPiTy ty
+
+    check_lev_poly :: Int -- arity
+                   -> Maybe Id -> DsM ()
+    check_lev_poly _     Nothing = return ()
+    check_lev_poly arity (Just id)
+      = dsNoLevPoly (nTimes arity res_type (idType id))
+          (text "In the result of the function" <+> quotes (ppr id))
+
+
+-- arr :: forall b c. (b -> c) -> a b c
+do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr
+do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]
+
+-- (>>>) :: forall b c d. a b c -> a c d -> a b d
+do_compose :: DsCmdEnv -> Type -> Type -> Type ->
+                CoreExpr -> CoreExpr -> CoreExpr
+do_compose ids b_ty c_ty d_ty f g
+  = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]
+
+-- first :: forall b c d. a b c -> a (b,d) (c,d)
+do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
+do_first ids b_ty c_ty d_ty f
+  = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]
+
+-- app :: forall b c. a (a b c, b) c
+do_app :: DsCmdEnv -> Type -> Type -> CoreExpr
+do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]
+
+-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d
+-- note the swapping of d and c
+do_choice :: DsCmdEnv -> Type -> Type -> Type ->
+                CoreExpr -> CoreExpr -> CoreExpr
+do_choice ids b_ty c_ty d_ty f g
+  = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]
+
+-- loop :: forall b d c. a (b,d) (c,d) -> a b c
+-- note the swapping of d and c
+do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr
+do_loop ids b_ty c_ty d_ty f
+  = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]
+
+-- premap :: forall b c d. (b -> c) -> a c d -> a b d
+-- premap f g = arr f >>> g
+do_premap :: DsCmdEnv -> Type -> Type -> Type ->
+                CoreExpr -> CoreExpr -> CoreExpr
+do_premap ids b_ty c_ty d_ty f g
+   = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g
+
+mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr
+mkFailExpr ctxt ty
+  = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)
+
+-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a
+mkFstExpr :: Type -> Type -> DsM CoreExpr
+mkFstExpr a_ty b_ty = do
+    a_var <- newSysLocalDs a_ty
+    b_var <- newSysLocalDs b_ty
+    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
+    return (Lam pair_var
+               (coreCasePair pair_var a_var b_var (Var a_var)))
+
+-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b
+mkSndExpr :: Type -> Type -> DsM CoreExpr
+mkSndExpr a_ty b_ty = do
+    a_var <- newSysLocalDs a_ty
+    b_var <- newSysLocalDs b_ty
+    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)
+    return (Lam pair_var
+               (coreCasePair pair_var a_var b_var (Var b_var)))
+
+{-
+Build case analysis of a tuple.  This cannot be done in the DsM monad,
+because the list of variables is typically not yet defined.
+-}
+
+-- coreCaseTuple [u1..] v [x1..xn] body
+--      = case v of v { (x1, .., xn) -> body }
+-- But the matching may be nested if the tuple is very big
+
+coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr
+coreCaseTuple uniqs scrut_var vars body
+  = mkTupleCase uniqs vars body scrut_var (Var scrut_var)
+
+coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr
+coreCasePair scrut_var var1 var2 body
+  = Case (Var scrut_var) scrut_var (exprType body)
+         [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)]
+
+mkCorePairTy :: Type -> Type -> Type
+mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]
+
+mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr
+mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]
+
+mkCoreUnitExpr :: CoreExpr
+mkCoreUnitExpr = mkCoreTup []
+
+{-
+The input is divided into a local environment, which is a flat tuple
+(unless it's too big), and a stack, which is a right-nested pair.
+In general, the input has the form
+
+        ((x1,...,xn), (s1,...(sk,())...))
+
+where xi are the environment values, and si the ones on the stack,
+with s1 being the "top", the first one to be matched with a lambda.
+-}
+
+envStackType :: [Id] -> Type -> Type
+envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty
+
+-- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t)
+splitTypeAt :: Int -> Type -> ([Type], Type)
+splitTypeAt n ty
+  | n == 0 = ([], ty)
+  | otherwise = case tcTyConAppArgs ty of
+      [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r)
+      _ -> pprPanic "splitTypeAt" (ppr ty)
+
+----------------------------------------------
+--              buildEnvStack
+--
+--      ((x1,...,xn),stk)
+
+buildEnvStack :: [Id] -> Id -> CoreExpr
+buildEnvStack env_ids stack_id
+  = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id)
+
+----------------------------------------------
+--              matchEnvStack
+--
+--      \ ((x1,...,xn),stk) -> body
+--      =>
+--      \ pair ->
+--      case pair of (tup,stk) ->
+--      case tup of (x1,...,xn) ->
+--      body
+
+matchEnvStack   :: [Id]         -- x1..xn
+                -> Id           -- stk
+                -> CoreExpr     -- e
+                -> DsM CoreExpr
+matchEnvStack env_ids stack_id body = do
+    uniqs <- newUniqueSupply
+    tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
+    let match_env = coreCaseTuple uniqs tup_var env_ids body
+    pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id))
+    return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))
+
+----------------------------------------------
+--              matchEnv
+--
+--      \ (x1,...,xn) -> body
+--      =>
+--      \ tup ->
+--      case tup of (x1,...,xn) ->
+--      body
+
+matchEnv :: [Id]        -- x1..xn
+         -> CoreExpr    -- e
+         -> DsM CoreExpr
+matchEnv env_ids body = do
+    uniqs <- newUniqueSupply
+    tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids)
+    return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))
+
+----------------------------------------------
+--              matchVarStack
+--
+--      case (x1, ...(xn, s)...) -> e
+--      =>
+--      case z0 of (x1,z1) ->
+--      case zn-1 of (xn,s) ->
+--      e
+matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)
+matchVarStack [] stack_id body = return (stack_id, body)
+matchVarStack (param_id:param_ids) stack_id body = do
+    (tail_id, tail_code) <- matchVarStack param_ids stack_id body
+    pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id))
+    return (pair_id, coreCasePair pair_id param_id tail_id tail_code)
+
+mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc
+mkHsEnvStackExpr env_ids stack_id
+  = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id]
+
+-- Translation of arrow abstraction
+
+-- D; xs |-a c : () --> t'      ---> c'
+-- --------------------------
+-- D |- proc p -> c :: a t t'   ---> premap (\ p -> ((xs),())) c'
+--
+--              where (xs) is the tuple of variables bound by p
+
+dsProcExpr
+        :: LPat GhcTc
+        -> LHsCmdTop GhcTc
+        -> DsM CoreExpr
+dsProcExpr pat (dL->L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
+    (meth_binds, meth_ids) <- mkCmdEnv ids
+    let locals = mkVarSet (collectPatBinders pat)
+    (core_cmd, _free_vars, env_ids)
+       <- dsfixCmd meth_ids locals unitTy cmd_ty cmd
+    let env_ty = mkBigCoreVarTupTy env_ids
+    let env_stk_ty = mkCorePairTy env_ty unitTy
+    let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr
+    fail_expr <- mkFailExpr ProcExpr env_stk_ty
+    var <- selectSimpleMatchVarL pat
+    match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr
+    let pat_ty = hsLPatType pat
+    let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty
+                    (Lam var match_code)
+                    core_cmd
+    return (mkLets meth_binds proc_code)
+dsProcExpr _ _ = panic "dsProcExpr"
+
+{-
+Translation of a command judgement of the form
+
+        D; xs |-a c : stk --> t
+
+to an expression e such that
+
+        D |- e :: a (xs, stk) t
+-}
+
+dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id]
+       -> DsM (CoreExpr, DIdSet)
+dsLCmd ids local_vars stk_ty res_ty cmd env_ids
+  = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids
+
+dsCmd   :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this command
+        -> Type                 -- type of the stack (right-nested tuple)
+        -> Type                 -- return type of the command
+        -> HsCmd GhcTc           -- command to desugar
+        -> [Id]           -- list of vars in the input to this command
+                                -- This is typically fed back,
+                                -- so don't pull on it too early
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet)         -- subset of local vars that occur free
+
+-- D |- fun :: a t1 t2
+-- D, xs |- arg :: t1
+-- -----------------------------
+-- D; xs |-a fun -< arg : stk --> t2
+--
+--              ---> premap (\ ((xs), _stk) -> arg) fun
+
+dsCmd ids local_vars stack_ty res_ty
+        (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _)
+        env_ids = do
+    let
+        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
+        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
+    core_arrow <- dsLExprNoLP arrow
+    core_arg   <- dsLExpr arg
+    stack_id   <- newSysLocalDs stack_ty
+    core_make_arg <- matchEnvStack env_ids stack_id core_arg
+    return (do_premap ids
+              (envStackType env_ids stack_ty)
+              arg_ty
+              res_ty
+              core_make_arg
+              core_arrow,
+            exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars)
+
+-- D, xs |- fun :: a t1 t2
+-- D, xs |- arg :: t1
+-- ------------------------------
+-- D; xs |-a fun -<< arg : stk --> t2
+--
+--              ---> premap (\ ((xs), _stk) -> (fun, arg)) app
+
+dsCmd ids local_vars stack_ty res_ty
+        (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _)
+        env_ids = do
+    let
+        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty
+        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty
+
+    core_arrow <- dsLExpr arrow
+    core_arg   <- dsLExpr arg
+    stack_id   <- newSysLocalDs stack_ty
+    core_make_pair <- matchEnvStack env_ids stack_id
+          (mkCorePairExpr core_arrow core_arg)
+
+    return (do_premap ids
+              (envStackType env_ids stack_ty)
+              (mkCorePairTy arrow_ty arg_ty)
+              res_ty
+              core_make_pair
+              (do_app ids arg_ty res_ty),
+            (exprsFreeIdsDSet [core_arrow, core_arg])
+              `uniqDSetIntersectUniqSet` local_vars)
+
+-- D; ys |-a cmd : (t,stk) --> t'
+-- D, xs |-  exp :: t
+-- ------------------------
+-- D; xs |-a cmd exp : stk --> t'
+--
+--              ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd
+
+dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do
+    core_arg <- dsLExpr arg
+    let
+        arg_ty = exprType core_arg
+        stack_ty' = mkCorePairTy arg_ty stack_ty
+    (core_cmd, free_vars, env_ids')
+             <- dsfixCmd ids local_vars stack_ty' res_ty cmd
+    stack_id <- newSysLocalDs stack_ty
+    arg_id <- newSysLocalDsNoLP arg_ty
+    -- push the argument expression onto the stack
+    let
+        stack' = mkCorePairExpr (Var arg_id) (Var stack_id)
+        core_body = bindNonRec arg_id core_arg
+                        (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')
+
+    -- match the environment and stack against the input
+    core_map <- matchEnvStack env_ids stack_id core_body
+    return (do_premap ids
+                      (envStackType env_ids stack_ty)
+                      (envStackType env_ids' stack_ty')
+                      res_ty
+                      core_map
+                      core_cmd,
+            free_vars `unionDVarSet`
+              (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars))
+
+-- D; ys |-a cmd : stk t'
+-- -----------------------------------------------
+-- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'
+--
+--              ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
+
+dsCmd ids local_vars stack_ty res_ty
+        (HsCmdLam _ (MG { mg_alts
+          = (dL->L _ [dL->L _ (Match { m_pats  = pats
+                       , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] body)] _ })]) }))
+        env_ids = do
+    let pat_vars = mkVarSet (collectPatsBinders pats)
+    let
+        local_vars' = pat_vars `unionVarSet` local_vars
+        (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty
+    (core_body, free_vars, env_ids')
+       <- dsfixCmd ids local_vars' stack_ty' res_ty body
+    param_ids <- mapM newSysLocalDsNoLP pat_tys
+    stack_id' <- newSysLocalDs stack_ty'
+
+    -- the expression is built from the inside out, so the actions
+    -- are presented in reverse order
+
+    let
+        -- build a new environment, plus what's left of the stack
+        core_expr = buildEnvStack env_ids' stack_id'
+        in_ty = envStackType env_ids stack_ty
+        in_ty' = envStackType env_ids' stack_ty'
+
+    fail_expr <- mkFailExpr LambdaExpr in_ty'
+    -- match the patterns against the parameters
+    match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr
+                    fail_expr
+    -- match the parameters against the top of the old stack
+    (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code
+    -- match the old environment and stack against the input
+    select_code <- matchEnvStack env_ids stack_id param_code
+    return (do_premap ids in_ty in_ty' res_ty select_code core_body,
+            free_vars `uniqDSetMinusUniqSet` pat_vars)
+
+dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids
+  = dsLCmd ids local_vars stack_ty res_ty cmd env_ids
+
+-- D, xs |- e :: Bool
+-- D; xs1 |-a c1 : stk --> t
+-- D; xs2 |-a c2 : stk --> t
+-- ----------------------------------------
+-- D; xs |-a if e then c1 else c2 : stk --> t
+--
+--              ---> premap (\ ((xs),stk) ->
+--                       if e then Left ((xs1),stk) else Right ((xs2),stk))
+--                     (c1 ||| c2)
+
+dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd)
+        env_ids = do
+    core_cond <- dsLExpr cond
+    (core_then, fvs_then, then_ids)
+       <- dsfixCmd ids local_vars stack_ty res_ty then_cmd
+    (core_else, fvs_else, else_ids)
+       <- dsfixCmd ids local_vars stack_ty res_ty else_cmd
+    stack_id   <- newSysLocalDs stack_ty
+    either_con <- dsLookupTyCon eitherTyConName
+    left_con   <- dsLookupDataCon leftDataConName
+    right_con  <- dsLookupDataCon rightDataConName
+
+    let mk_left_expr ty1 ty2 e = mkCoreConApps left_con   [Type ty1,Type ty2, e]
+        mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1,Type ty2, e]
+
+        in_ty = envStackType env_ids stack_ty
+        then_ty = envStackType then_ids stack_ty
+        else_ty = envStackType else_ids stack_ty
+        sum_ty = mkTyConApp either_con [then_ty, else_ty]
+        fvs_cond = exprFreeIdsDSet core_cond
+                   `uniqDSetIntersectUniqSet` local_vars
+
+        core_left  = mk_left_expr  then_ty else_ty
+                       (buildEnvStack then_ids stack_id)
+        core_right = mk_right_expr then_ty else_ty
+                       (buildEnvStack else_ids stack_id)
+
+    core_if <- case mb_fun of
+       Just fun -> do { fun_apps <- dsSyntaxExpr fun
+                                      [core_cond, core_left, core_right]
+                      ; matchEnvStack env_ids stack_id fun_apps }
+       Nothing  -> matchEnvStack env_ids stack_id $
+                   mkIfThenElse core_cond core_left core_right
+
+    return (do_premap ids in_ty sum_ty res_ty
+                core_if
+                (do_choice ids then_ty else_ty res_ty core_then core_else),
+        fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else)
+
+{-
+Case commands are treated in much the same way as if commands
+(see above) except that there are more alternatives.  For example
+
+        case e of { p1 -> c1; p2 -> c2; p3 -> c3 }
+
+is translated to
+
+        premap (\ ((xs)*ts) -> case e of
+                p1 -> (Left (Left (xs1)*ts))
+                p2 -> Left ((Right (xs2)*ts))
+                p3 -> Right ((xs3)*ts))
+        ((c1 ||| c2) ||| c3)
+
+The idea is to extract the commands from the case, build a balanced tree
+of choices, and replace the commands with expressions that build tagged
+tuples, obtaining a case expression that can be desugared normally.
+To build all this, we use triples describing segments of the list of
+case bodies, containing the following fields:
+ * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put
+   into the case replacing the commands
+ * a sum type that is the common type of these expressions, and also the
+   input type of the arrow
+ * a CoreExpr for an arrow built by combining the translated command
+   bodies with |||.
+-}
+
+dsCmd ids local_vars stack_ty res_ty
+      (HsCmdCase _ exp (MG { mg_alts = (dL->L l matches)
+                           , mg_ext = MatchGroupTc arg_tys _
+                           , mg_origin = origin }))
+      env_ids = do
+    stack_id <- newSysLocalDs stack_ty
+
+    -- Extract and desugar the leaf commands in the case, building tuple
+    -- expressions that will (after tagging) replace these leaves
+
+    let
+        leaves = concatMap leavesMatch matches
+        make_branch (leaf, bound_vars) = do
+            (core_leaf, _fvs, leaf_ids)
+               <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty
+                    res_ty leaf
+            return ([mkHsEnvStackExpr leaf_ids stack_id],
+                    envStackType leaf_ids stack_ty,
+                    core_leaf)
+
+    branches <- mapM make_branch leaves
+    either_con <- dsLookupTyCon eitherTyConName
+    left_con <- dsLookupDataCon leftDataConName
+    right_con <- dsLookupDataCon rightDataConName
+    let
+        left_id  = HsConLikeOut noExt (RealDataCon left_con)
+        right_id = HsConLikeOut noExt (RealDataCon right_con)
+        left_expr  ty1 ty2 e = noLoc $ HsApp noExt
+                           (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
+        right_expr ty1 ty2 e = noLoc $ HsApp noExt
+                           (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
+
+        -- Prefix each tuple with a distinct series of Left's and Right's,
+        -- in a balanced way, keeping track of the types.
+
+        merge_branches (builds1, in_ty1, core_exp1)
+                       (builds2, in_ty2, core_exp2)
+          = (map (left_expr in_ty1 in_ty2) builds1 ++
+                map (right_expr in_ty1 in_ty2) builds2,
+             mkTyConApp either_con [in_ty1, in_ty2],
+             do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)
+        (leaves', sum_ty, core_choices) = foldb merge_branches branches
+
+        -- Replace the commands in the case with these tagged tuples,
+        -- yielding a HsExpr Id we can feed to dsExpr.
+
+        (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
+        in_ty = envStackType env_ids stack_ty
+
+    core_body <- dsExpr (HsCase noExt exp
+                         (MG { mg_alts = cL l matches'
+                             , mg_ext = MatchGroupTc arg_tys sum_ty
+                             , mg_origin = origin }))
+        -- Note that we replace the HsCase result type by sum_ty,
+        -- which is the type of matches'
+
+    core_matches <- matchEnvStack env_ids stack_id core_body
+    return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,
+            exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars)
+
+-- D; ys |-a cmd : stk --> t
+-- ----------------------------------
+-- D; xs |-a let binds in cmd : stk --> t
+--
+--              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
+
+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->L _ binds) body)
+                                                                    env_ids = do
+    let
+        defined_vars = mkVarSet (collectLocalBinders binds)
+        local_vars' = defined_vars `unionVarSet` local_vars
+
+    (core_body, _free_vars, env_ids')
+       <- dsfixCmd ids local_vars' stack_ty res_ty body
+    stack_id <- newSysLocalDs stack_ty
+    -- build a new environment, plus the stack, using the let bindings
+    core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)
+    -- match the old environment and stack against the input
+    core_map <- matchEnvStack env_ids stack_id core_binds
+    return (do_premap ids
+                        (envStackType env_ids stack_ty)
+                        (envStackType env_ids' stack_ty)
+                        res_ty
+                        core_map
+                        core_body,
+        exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)
+
+-- D; xs |-a ss : t
+-- ----------------------------------
+-- D; xs |-a do { ss } : () --> t
+--
+--              ---> premap (\ (env,stk) -> env) c
+
+dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty
+                                               (dL->L loc stmts))
+                                                                   env_ids = do
+    putSrcSpanDs loc $
+      dsNoLevPoly stmts_ty
+        (text "In the do-command:" <+> ppr do_block)
+    (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
+    let env_ty = mkBigCoreVarTupTy env_ids
+    core_fst <- mkFstExpr env_ty stack_ty
+    return (do_premap ids
+                (mkCorePairTy env_ty stack_ty)
+                env_ty
+                res_ty
+                core_fst
+                core_stmts,
+        env_ids')
+
+-- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t
+-- D; xs |-a ci :: stki --> ti
+-- -----------------------------------
+-- D; xs |-a (|e c1 ... cn|) :: stk --> t       ---> e [t_xs] c1 ... cn
+
+dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do
+    let env_ty = mkBigCoreVarTupTy env_ids
+    core_op <- dsLExpr op
+    (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args
+    return (mkApps (App core_op (Type env_ty)) core_args,
+            unionDVarSets fv_sets)
+
+dsCmd ids local_vars stack_ty res_ty (HsCmdWrap _ wrap cmd) env_ids = do
+    (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
+    core_wrap <- dsHsWrapper wrap
+    return (core_wrap core_cmd, env_ids')
+
+dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
+
+-- D; ys |-a c : stk --> t      (ys <= xs)
+-- ---------------------
+-- D; xs |-a c : stk --> t      ---> premap (\ ((xs),stk) -> ((ys),stk)) c
+
+dsTrimCmdArg
+        :: IdSet                -- set of local vars available to this command
+        -> [Id]           -- list of vars in the input to this command
+        -> LHsCmdTop GhcTc       -- command argument to desugar
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet)         -- subset of local vars that occur free
+dsTrimCmdArg local_vars env_ids
+                       (dL->L _ (HsCmdTop
+                                 (CmdTopTc stack_ty cmd_ty ids) cmd )) = do
+    (meth_binds, meth_ids) <- mkCmdEnv ids
+    (core_cmd, free_vars, env_ids')
+       <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd
+    stack_id <- newSysLocalDs stack_ty
+    trim_code
+      <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)
+    let
+        in_ty = envStackType env_ids stack_ty
+        in_ty' = envStackType env_ids' stack_ty
+        arg_code = if env_ids' == env_ids then core_cmd else
+                do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd
+    return (mkLets meth_binds arg_code, free_vars)
+dsTrimCmdArg _ _ _ = panic "dsTrimCmdArg"
+
+-- Given D; xs |-a c : stk --> t, builds c with xs fed back.
+-- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))
+
+dsfixCmd
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this command
+        -> Type                 -- type of the stack (right-nested tuple)
+        -> Type                 -- return type of the command
+        -> LHsCmd GhcTc         -- command to desugar
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet,         -- subset of local vars that occur free
+                [Id])           -- the same local vars as a list, fed back
+dsfixCmd ids local_vars stk_ty cmd_ty cmd
+  = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty
+           (text "When desugaring the command:" <+> ppr cmd)
+       ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) }
+
+-- Feed back the list of local variables actually used a command,
+-- for use as the input tuple of the generated arrow.
+
+trimInput
+        :: ([Id] -> DsM (CoreExpr, DIdSet))
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet,         -- subset of local vars that occur free
+                [Id])           -- same local vars as a list, fed back to
+                                -- the inner function to form the tuple of
+                                -- inputs to the arrow.
+trimInput build_arrow
+  = fixDs (\ ~(_,_,env_ids) -> do
+        (core_cmd, free_vars) <- build_arrow env_ids
+        return (core_cmd, free_vars, dVarSetElems free_vars))
+
+{-
+Translation of command judgements of the form
+
+        D |-a do { ss } : t
+-}
+
+dsCmdDo :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> Type                 -- return type of the statement
+        -> [CmdLStmt GhcTc]     -- statements to desugar
+        -> [Id]                 -- list of vars in the input to this statement
+                                -- This is typically fed back,
+                                -- so don't pull on it too early
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet)         -- subset of local vars that occur free
+
+dsCmdDo _ _ _ [] _ = panic "dsCmdDo"
+
+-- D; xs |-a c : () --> t
+-- --------------------------
+-- D; xs |-a do { c } : t
+--
+--              ---> premap (\ (xs) -> ((xs), ())) c
+
+dsCmdDo ids local_vars res_ty [dL->L loc (LastStmt _ body _ _)] env_ids = do
+    putSrcSpanDs loc $ dsNoLevPoly res_ty
+                         (text "In the command:" <+> ppr body)
+    (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids
+    let env_ty = mkBigCoreVarTupTy env_ids
+    env_var <- newSysLocalDs env_ty
+    let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)
+    return (do_premap ids
+                        env_ty
+                        (mkCorePairTy env_ty unitTy)
+                        res_ty
+                        core_map
+                        core_body,
+        env_ids')
+
+dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do
+    let bound_vars  = mkVarSet (collectLStmtBinders stmt)
+    let local_vars' = bound_vars `unionVarSet` local_vars
+    (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)
+    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
+    return (do_compose ids
+                (mkBigCoreVarTupTy env_ids)
+                (mkBigCoreVarTupTy env_ids')
+                res_ty
+                core_stmt
+                core_stmts,
+              fv_stmt)
+
+{-
+A statement maps one local environment to another, and is represented
+as an arrow from one tuple type to another.  A statement sequence is
+translated to a composition of such arrows.
+-}
+
+dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id]
+           -> DsM (CoreExpr, DIdSet)
+dsCmdLStmt ids local_vars out_ids cmd env_ids
+  = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids
+
+dsCmdStmt
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> [Id]                 -- list of vars in the output of this statement
+        -> CmdStmt GhcTc        -- statement to desugar
+        -> [Id]                 -- list of vars in the input to this statement
+                                -- This is typically fed back,
+                                -- so don't pull on it too early
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet)         -- subset of local vars that occur free
+
+-- D; xs1 |-a c : () --> t
+-- D; xs' |-a do { ss } : t'
+-- ------------------------------
+-- D; xs  |-a do { c; ss } : t'
+--
+--              ---> premap (\ ((xs)) -> (((xs1),()),(xs')))
+--                      (first c >>> arr snd) >>> ss
+
+dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
+    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd
+    core_mux <- matchEnv env_ids
+        (mkCorePairExpr
+            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
+            (mkBigCoreVarTup out_ids))
+    let
+        in_ty = mkBigCoreVarTupTy env_ids
+        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
+        out_ty = mkBigCoreVarTupTy out_ids
+        before_c_ty = mkCorePairTy in_ty1 out_ty
+        after_c_ty = mkCorePairTy c_ty out_ty
+    dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here
+    snd_fn <- mkSndExpr c_ty out_ty
+    return (do_premap ids in_ty before_c_ty out_ty core_mux $
+                do_compose ids before_c_ty after_c_ty out_ty
+                        (do_first ids in_ty1 c_ty out_ty core_cmd) $
+                do_arr ids after_c_ty out_ty snd_fn,
+              extendDVarSetList fv_cmd out_ids)
+
+-- D; xs1 |-a c : () --> t
+-- D; xs' |-a do { ss } : t'            xs2 = xs' - defs(p)
+-- -----------------------------------
+-- D; xs  |-a do { p <- c; ss } : t'
+--
+--              ---> premap (\ (xs) -> (((xs1),()),(xs2)))
+--                      (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss
+--
+-- It would be simpler and more consistent to do this using second,
+-- but that's likely to be defined in terms of first.
+
+dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do
+    let pat_ty = hsLPatType pat
+    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
+    let pat_vars = mkVarSet (collectPatBinders pat)
+    let
+        env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids
+        env_ty2 = mkBigCoreVarTupTy env_ids2
+
+    -- multiplexing function
+    --          \ (xs) -> (((xs1),()),(xs2))
+
+    core_mux <- matchEnv env_ids
+        (mkCorePairExpr
+            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)
+            (mkBigCoreVarTup env_ids2))
+
+    -- projection function
+    --          \ (p, (xs2)) -> (zs)
+
+    env_id <- newSysLocalDs env_ty2
+    uniqs <- newUniqueSupply
+    let
+       after_c_ty = mkCorePairTy pat_ty env_ty2
+       out_ty = mkBigCoreVarTupTy out_ids
+       body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)
+
+    fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty
+    pat_id    <- selectSimpleMatchVarL pat
+    match_code
+      <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr
+    pair_id   <- newSysLocalDs after_c_ty
+    let
+        proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)
+
+    -- put it all together
+    let
+        in_ty = mkBigCoreVarTupTy env_ids
+        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy
+        in_ty2 = mkBigCoreVarTupTy env_ids2
+        before_c_ty = mkCorePairTy in_ty1 in_ty2
+    return (do_premap ids in_ty before_c_ty out_ty core_mux $
+                do_compose ids before_c_ty after_c_ty out_ty
+                        (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $
+                do_arr ids after_c_ty out_ty proj_expr,
+              fv_cmd `unionDVarSet` (mkDVarSet out_ids
+                                     `uniqDSetMinusUniqSet` pat_vars))
+
+-- D; xs' |-a do { ss } : t
+-- --------------------------------------
+-- D; xs  |-a do { let binds; ss } : t
+--
+--              ---> arr (\ (xs) -> let binds in (xs')) >>> ss
+
+dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do
+    -- build a new environment using the let bindings
+    core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
+    -- match the old environment against the input
+    core_map <- matchEnv env_ids core_binds
+    return (do_arr ids
+                        (mkBigCoreVarTupTy env_ids)
+                        (mkBigCoreVarTupTy out_ids)
+                        core_map,
+            exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)
+
+-- D; ys  |-a do { ss; returnA -< ((xs1), (ys2)) } : ...
+-- D; xs' |-a do { ss' } : t
+-- ------------------------------------
+-- D; xs  |-a do { rec ss; ss' } : t
+--
+--                      xs1 = xs' /\ defs(ss)
+--                      xs2 = xs' - defs(ss)
+--                      ys1 = ys - defs(ss)
+--                      ys2 = ys /\ defs(ss)
+--
+--              ---> arr (\(xs) -> ((ys1),(xs2))) >>>
+--                      first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>
+--                      arr (\((xs1),(xs2)) -> (xs')) >>> ss'
+
+dsCmdStmt ids local_vars out_ids
+        (RecStmt { recS_stmts = stmts
+                 , recS_later_ids = later_ids, recS_rec_ids = rec_ids
+                 , recS_ext = RecStmtTc { recS_later_rets = later_rets
+                                        , recS_rec_rets = rec_rets } })
+        env_ids = do
+    let
+        later_ids_set = mkVarSet later_ids
+        env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids
+        env2_id_set = mkDVarSet env2_ids
+        env2_ty = mkBigCoreVarTupTy env2_ids
+
+    -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)
+
+    uniqs <- newUniqueSupply
+    env2_id <- newSysLocalDs env2_ty
+    let
+        later_ty = mkBigCoreVarTupTy later_ids
+        post_pair_ty = mkCorePairTy later_ty env2_ty
+        post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)
+
+    post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body
+
+    --- loop (...)
+
+    (core_loop, env1_id_set, env1_ids)
+               <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets
+
+    -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))
+
+    let
+        env1_ty = mkBigCoreVarTupTy env1_ids
+        pre_pair_ty = mkCorePairTy env1_ty env2_ty
+        pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)
+                                        (mkBigCoreVarTup env2_ids)
+
+    pre_loop_fn <- matchEnv env_ids pre_loop_body
+
+    -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn
+
+    let
+        env_ty = mkBigCoreVarTupTy env_ids
+        out_ty = mkBigCoreVarTupTy out_ids
+        core_body = do_premap ids env_ty pre_pair_ty out_ty
+                pre_loop_fn
+                (do_compose ids pre_pair_ty post_pair_ty out_ty
+                        (do_first ids env1_ty later_ty env2_ty
+                                core_loop)
+                        (do_arr ids post_pair_ty out_ty
+                                post_loop_fn))
+
+    return (core_body, env1_id_set `unionDVarSet` env2_id_set)
+
+dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)
+
+--      loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))
+--            (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>
+
+dsRecCmd
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> [CmdLStmt GhcTc]     -- list of statements inside the RecCmd
+        -> [Id]                 -- list of vars defined here and used later
+        -> [HsExpr GhcTc]       -- expressions corresponding to later_ids
+        -> [Id]                 -- list of vars fed back through the loop
+        -> [HsExpr GhcTc]       -- expressions corresponding to rec_ids
+        -> DsM (CoreExpr,       -- desugared statement
+                DIdSet,         -- subset of local vars that occur free
+                [Id])           -- same local vars as a list
+
+dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do
+    let
+        later_id_set = mkVarSet later_ids
+        rec_id_set = mkVarSet rec_ids
+        local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars
+
+    -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))
+
+    core_later_rets <- mapM dsExpr later_rets
+    core_rec_rets <- mapM dsExpr rec_rets
+    let
+        -- possibly polymorphic version of vars of later_ids and rec_ids
+        out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets)
+        out_ty = mkBigCoreVarTupTy out_ids
+
+        later_tuple = mkBigCoreTup core_later_rets
+        later_ty = mkBigCoreVarTupTy later_ids
+
+        rec_tuple = mkBigCoreTup core_rec_rets
+        rec_ty = mkBigCoreVarTupTy rec_ids
+
+        out_pair = mkCorePairExpr later_tuple rec_tuple
+        out_pair_ty = mkCorePairTy later_ty rec_ty
+
+    mk_pair_fn <- matchEnv out_ids out_pair
+
+    -- ss
+
+    (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts
+
+    -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)
+
+    rec_id <- newSysLocalDs rec_ty
+    let
+        env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set
+        env1_ids = dVarSetElems env1_id_set
+        env1_ty = mkBigCoreVarTupTy env1_ids
+        in_pair_ty = mkCorePairTy env1_ty rec_ty
+        core_body = mkBigCoreTup (map selectVar env_ids)
+          where
+            selectVar v
+                | v `elemVarSet` rec_id_set
+                  = mkTupleSelector rec_ids v rec_id (Var rec_id)
+                | otherwise = Var v
+
+    squash_pair_fn <- matchEnvStack env1_ids rec_id core_body
+
+    -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))
+
+    let
+        env_ty = mkBigCoreVarTupTy env_ids
+        core_loop = do_loop ids env1_ty later_ty rec_ty
+                (do_premap ids in_pair_ty env_ty out_pair_ty
+                        squash_pair_fn
+                        (do_compose ids env_ty out_ty out_pair_ty
+                                core_stmts
+                                (do_arr ids out_ty out_pair_ty mk_pair_fn)))
+
+    return (core_loop, env1_id_set, env1_ids)
+
+{-
+A sequence of statements (as in a rec) is desugared to an arrow between
+two environments (no stack)
+-}
+
+dsfixCmdStmts
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> [Id]                 -- output vars of these statements
+        -> [CmdLStmt GhcTc]     -- statements to desugar
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet,         -- subset of local vars that occur free
+                [Id])           -- same local vars as a list
+
+dsfixCmdStmts ids local_vars out_ids stmts
+  = trimInput (dsCmdStmts ids local_vars out_ids stmts)
+   -- TODO: Add levity polymorphism check for the resulting expression.
+   -- But I (Richard E.) don't know enough about arrows to do so.
+
+dsCmdStmts
+        :: DsCmdEnv             -- arrow combinators
+        -> IdSet                -- set of local vars available to this statement
+        -> [Id]                 -- output vars of these statements
+        -> [CmdLStmt GhcTc]     -- statements to desugar
+        -> [Id]                 -- list of vars in the input to these statements
+        -> DsM (CoreExpr,       -- desugared expression
+                DIdSet)         -- subset of local vars that occur free
+
+dsCmdStmts ids local_vars out_ids [stmt] env_ids
+  = dsCmdLStmt ids local_vars out_ids stmt env_ids
+
+dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do
+    let bound_vars  = mkVarSet (collectLStmtBinders stmt)
+    let local_vars' = bound_vars `unionVarSet` local_vars
+    (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts
+    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids
+    return (do_compose ids
+                (mkBigCoreVarTupTy env_ids)
+                (mkBigCoreVarTupTy env_ids')
+                (mkBigCoreVarTupTy out_ids)
+                core_stmt
+                core_stmts,
+              fv_stmt)
+
+dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"
+
+-- Match a list of expressions against a list of patterns, left-to-right.
+
+matchSimplys :: [CoreExpr]              -- Scrutinees
+             -> HsMatchContext Name     -- Match kind
+             -> [LPat GhcTc]            -- Patterns they should match
+             -> CoreExpr                -- Return this if they all match
+             -> CoreExpr                -- Return this if they don't
+             -> DsM CoreExpr
+matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr
+matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do
+    match_code <- matchSimplys exps ctxt pats result_expr fail_expr
+    matchSimply exp ctxt pat match_code fail_expr
+matchSimplys _ _ _ _ _ = panic "matchSimplys"
+
+-- List of leaf expressions, with set of variables bound in each
+
+leavesMatch :: LMatch GhcTc (Located (body GhcTc))
+            -> [(Located (body GhcTc), IdSet)]
+leavesMatch (dL->L _ (Match { m_pats = pats
+                            , m_grhss = GRHSs _ grhss (dL->L _ binds) }))
+  = let
+        defined_vars = mkVarSet (collectPatsBinders pats)
+                        `unionVarSet`
+                       mkVarSet (collectLocalBinders binds)
+    in
+    [(body,
+      mkVarSet (collectLStmtsBinders stmts)
+        `unionVarSet` defined_vars)
+    | (dL->L _ (GRHS _ stmts body)) <- grhss]
+leavesMatch _ = panic "leavesMatch"
+
+-- Replace the leaf commands in a match
+
+replaceLeavesMatch
+        :: Type                                 -- new result type
+        -> [Located (body' GhcTc)] -- replacement leaf expressions of that type
+        -> LMatch GhcTc (Located (body GhcTc))  -- the matches of a case command
+        -> ([Located (body' GhcTc)],            -- remaining leaf expressions
+            LMatch GhcTc (Located (body' GhcTc))) -- updated match
+replaceLeavesMatch _res_ty leaves
+                        (dL->L loc
+                          match@(Match { m_grhss = GRHSs x grhss binds }))
+  = let
+        (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss
+    in
+    (leaves', cL loc (match { m_ext = noExt, m_grhss = GRHSs x grhss' binds }))
+replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch"
+
+replaceLeavesGRHS
+        :: [Located (body' GhcTc)]  -- replacement leaf expressions of that type
+        -> LGRHS GhcTc (Located (body GhcTc))     -- rhss of a case command
+        -> ([Located (body' GhcTc)],              -- remaining leaf expressions
+            LGRHS GhcTc (Located (body' GhcTc)))  -- updated GRHS
+replaceLeavesGRHS (leaf:leaves) (dL->L loc (GRHS x stmts _))
+  = (leaves, cL loc (GRHS x stmts leaf))
+replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"
+replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS"
+
+-- Balanced fold of a non-empty list.
+
+foldb :: (a -> a -> a) -> [a] -> a
+foldb _ [] = error "foldb of empty list"
+foldb _ [x] = x
+foldb f xs = foldb f (fold_pairs xs)
+  where
+    fold_pairs [] = []
+    fold_pairs [x] = [x]
+    fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs
+
+{-
+Note [Dictionary binders in ConPatOut] See also same Note in HsUtils
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The following functions to collect value variables from patterns are
+copied from HsUtils, with one change: we also collect the dictionary
+bindings (pat_binds) from ConPatOut.  We need them for cases like
+
+h :: Arrow a => Int -> a (Int,Int) Int
+h x = proc (y,z) -> case compare x y of
+                GT -> returnA -< z+x
+
+The type checker turns the case into
+
+                case compare x y of
+                  GT { p77 = plusInt } -> returnA -< p77 z x
+
+Here p77 is a local binding for the (+) operation.
+
+See comments in HsUtils for why the other version does not include
+these bindings.
+-}
+
+collectPatBinders :: LPat GhcTc -> [Id]
+collectPatBinders pat = collectl pat []
+
+collectPatsBinders :: [LPat GhcTc] -> [Id]
+collectPatsBinders pats = foldr collectl [] pats
+
+---------------------
+collectl :: LPat GhcTc -> [Id] -> [Id]
+-- See Note [Dictionary binders in ConPatOut]
+collectl (dL->L _ pat) bndrs
+  = go pat
+  where
+    go (VarPat _ (dL->L _ var))   = var : bndrs
+    go (WildPat _)                = bndrs
+    go (LazyPat _ pat)            = collectl pat bndrs
+    go (BangPat _ pat)            = collectl pat bndrs
+    go (AsPat _ (dL->L _ a) pat)  = a : collectl pat bndrs
+    go (ParPat _ pat)             = collectl pat bndrs
+
+    go (ListPat _ pats)           = foldr collectl bndrs pats
+    go (TuplePat _ pats _)        = foldr collectl bndrs pats
+    go (SumPat _ pat _ _)         = collectl pat bndrs
+
+    go (ConPatIn _ ps)            = foldr collectl bndrs (hsConPatArgs ps)
+    go (ConPatOut {pat_args=ps, pat_binds=ds}) =
+                                    collectEvBinders ds
+                                    ++ foldr collectl bndrs (hsConPatArgs ps)
+    go (LitPat _ _)               = bndrs
+    go (NPat {})                  = bndrs
+    go (NPlusKPat _ (dL->L _ n) _ _ _ _) = n : bndrs
+
+    go (SigPat _ pat _)           = collectl pat bndrs
+    go (CoPat _ _ pat _)          = collectl (noLoc pat) bndrs
+    go (ViewPat _ _ pat)          = collectl pat bndrs
+    go p@(SplicePat {})           = pprPanic "collectl/go" (ppr p)
+    go p@(XPat {})                = pprPanic "collectl/go" (ppr p)
+
+collectEvBinders :: TcEvBinds -> [Id]
+collectEvBinders (EvBinds bs)   = foldrBag add_ev_bndr [] bs
+collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
+
+add_ev_bndr :: EvBind -> [Id] -> [Id]
+add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b    = b:bs
+                                       | otherwise = bs
+  -- A worry: what about coercion variable binders??
+
+collectLStmtsBinders :: [LStmt GhcTc body] -> [Id]
+collectLStmtsBinders = concatMap collectLStmtBinders
+
+collectLStmtBinders :: LStmt GhcTc body -> [Id]
+collectLStmtBinders = collectStmtBinders . unLoc
+
+collectStmtBinders :: Stmt GhcTc body -> [Id]
+collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
+collectStmtBinders stmt = HsUtils.collectStmtBinders stmt
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsBinds.hs
@@ -0,0 +1,1324 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Pattern-matching bindings (HsBinds and MonoBinds)
+
+Handles @HsBinds@; those at the top level require different handling,
+in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
+lower levels it is preserved with @let@/@letrec@s).
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
+                 dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-}   DsExpr( dsLExpr )
+import {-# SOURCE #-}   Match( matchWrapper )
+
+import DsMonad
+import DsGRHSs
+import DsUtils
+import Check ( checkGuardMatches )
+
+import HsSyn            -- lots of things
+import CoreSyn          -- lots of things
+import CoreOpt          ( simpleOptExpr )
+import OccurAnal        ( occurAnalyseExpr )
+import MkCore
+import CoreUtils
+import CoreArity ( etaExpand )
+import CoreUnfold
+import CoreFVs
+import Digraph
+
+import PrelNames
+import TyCon
+import TcEvidence
+import TcType
+import Type
+import Coercion
+import TysWiredIn ( typeNatKind, typeSymbolKind )
+import Id
+import MkId(proxyHashId)
+import Name
+import VarSet
+import Rules
+import VarEnv
+import Var( EvVar )
+import Outputable
+import Module
+import SrcLoc
+import Maybes
+import OrdList
+import Bag
+import BasicTypes
+import DynFlags
+import FastString
+import Util
+import UniqSet( nonDetEltsUniqSet )
+import MonadUtils
+import qualified GHC.LanguageExtensions as LangExt
+import Control.Monad
+
+{-**********************************************************************
+*                                                                      *
+           Desugaring a MonoBinds
+*                                                                      *
+**********************************************************************-}
+
+-- | Desugar top level binds, strict binds are treated like normal
+-- binds since there is no good time to force before first usage.
+dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))
+dsTopLHsBinds binds
+     -- see Note [Strict binds checks]
+  | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)
+  = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds
+       ; mapBagM_ (top_level_err "strict bindings")             bang_binds
+       ; return nilOL }
+
+  | otherwise
+  = do { (force_vars, prs) <- dsLHsBinds binds
+       ; when debugIsOn $
+         do { xstrict <- xoptM LangExt.Strict
+            ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) }
+              -- with -XStrict, even top-level vars are listed as force vars.
+
+       ; return (toOL prs) }
+
+  where
+    unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds
+    bang_binds     = filterBag (isBangedHsBind   . unLoc) binds
+
+    top_level_err desc (dL->L loc bind)
+      = putSrcSpanDs loc $
+        errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")
+                  2 (ppr bind))
+
+
+-- | Desugar all other kind of bindings, Ids of strict binds are returned to
+-- later be forced in the binding group body, see Note [Desugar Strict binds]
+dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
+dsLHsBinds binds
+  = do { ds_bs <- mapBagM dsLHsBind binds
+       ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))
+                         id ([], []) ds_bs) }
+
+------------------------
+dsLHsBind :: LHsBind GhcTc
+          -> DsM ([Id], [(Id,CoreExpr)])
+dsLHsBind (dL->L loc bind) = do dflags <- getDynFlags
+                                putSrcSpanDs loc $ dsHsBind dflags bind
+
+-- | Desugar a single binding (or group of recursive binds).
+dsHsBind :: DynFlags
+         -> HsBind GhcTc
+         -> DsM ([Id], [(Id,CoreExpr)])
+         -- ^ The Ids of strict binds, to be forced in the body of the
+         -- binding group see Note [Desugar Strict binds] and all
+         -- bindings and their desugared right hand sides.
+
+dsHsBind dflags (VarBind { var_id = var
+                         , var_rhs = expr
+                         , var_inline = inline_regardless })
+  = do  { core_expr <- dsLExpr expr
+                -- Dictionary bindings are always VarBinds,
+                -- so we only need do this here
+        ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr
+                   | otherwise         = var
+        ; let core_bind@(id,_) = makeCorePair dflags var' False 0 core_expr
+              force_var = if xopt LangExt.Strict dflags
+                          then [id]
+                          else []
+        ; return (force_var, [core_bind]) }
+
+dsHsBind dflags b@(FunBind { fun_id = (dL->L _ fun)
+                           , fun_matches = matches
+                           , fun_co_fn = co_fn
+                           , fun_tick = tick })
+ = do   { (args, body) <- matchWrapper
+                           (mkPrefixFunRhs (noLoc $ idName fun))
+                           Nothing matches
+        ; core_wrap <- dsHsWrapper co_fn
+        ; let body' = mkOptTickBox tick body
+              rhs   = core_wrap (mkLams args body')
+              core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
+              force_var
+                  -- Bindings are strict when -XStrict is enabled
+                | xopt LangExt.Strict dflags
+                , matchGroupArity matches == 0 -- no need to force lambdas
+                = [id]
+                | isBangedHsBind b
+                = [id]
+                | otherwise
+                = []
+        ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun)
+          --                          , ppr (mg_alts matches)
+          --                          , ppr args, ppr core_binds]) $
+          return (force_var, [core_binds]) }
+
+dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss
+                         , pat_ext = NPatBindTc _ ty
+                         , pat_ticks = (rhs_tick, var_ticks) })
+  = do  { body_expr <- dsGuarded grhss ty
+        ; checkGuardMatches PatBindGuards grhss
+        ; let body' = mkOptTickBox rhs_tick body_expr
+              pat'  = decideBangHood dflags pat
+        ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'
+          -- We silently ignore inline pragmas; no makeCorePair
+          -- Not so cool, but really doesn't matter
+        ; let force_var' = if isBangedLPat pat'
+                           then [force_var]
+                           else []
+        ; return (force_var', sel_binds) }
+
+dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
+                          , abs_exports = exports
+                          , abs_ev_binds = ev_binds
+                          , abs_binds = binds, abs_sig = has_sig })
+  = do { ds_binds <- addDictsDs (listToBag dicts) $
+                     dsLHsBinds binds
+                         -- addDictsDs: push type constraints deeper
+                         --             for inner pattern match check
+                         -- See Check, Note [Type and Term Equality Propagation]
+
+       ; ds_ev_binds <- dsTcEvBinds_s ev_binds
+
+       -- dsAbsBinds does the hard work
+       ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
+
+dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
+dsHsBind _ (XHsBindsLR{}) = panic "dsHsBind: XHsBindsLR"
+
+
+-----------------------
+dsAbsBinds :: DynFlags
+           -> [TyVar] -> [EvVar] -> [ABExport GhcTc]
+           -> [CoreBind]                -- Desugared evidence bindings
+           -> ([Id], [(Id,CoreExpr)])   -- Desugared value bindings
+           -> Bool                      -- Single binding with signature
+           -> DsM ([Id], [(Id,CoreExpr)])
+
+dsAbsBinds dflags tyvars dicts exports
+           ds_ev_binds (force_vars, bind_prs) has_sig
+
+    -- A very important common case: one exported variable
+    -- Non-recursive bindings come through this way
+    -- So do self-recursive bindings
+  | [export] <- exports
+  , ABE { abe_poly = global_id, abe_mono = local_id
+        , abe_wrap = wrap, abe_prags = prags } <- export
+  , Just force_vars' <- case force_vars of
+                           []                  -> Just []
+                           [v] | v == local_id -> Just [global_id]
+                           _                   -> Nothing
+       -- If there is a variable to force, it's just the
+       -- single variable we are binding here
+  = do { core_wrap <- dsHsWrapper wrap -- Usually the identity
+
+       ; let rhs = core_wrap $
+                   mkLams tyvars $ mkLams dicts $
+                   mkCoreLets ds_ev_binds $
+                   body
+
+             body | has_sig
+                  , [(_, lrhs)] <- bind_prs
+                  = lrhs
+                  | otherwise
+                  = mkLetRec bind_prs (Var local_id)
+
+       ; (spec_binds, rules) <- dsSpecs rhs prags
+
+       ; let global_id' = addIdSpecialisations global_id rules
+             main_bind  = makeCorePair dflags global_id'
+                                       (isDefaultMethod prags)
+                                       (dictArity dicts) rhs
+
+       ; return (force_vars', main_bind : fromOL spec_binds) }
+
+    -- Another common case: no tyvars, no dicts
+    -- In this case we can have a much simpler desugaring
+  | null tyvars, null dicts
+
+  = do { let mk_bind (ABE { abe_wrap = wrap
+                          , abe_poly = global
+                          , abe_mono = local
+                          , abe_prags = prags })
+              = do { core_wrap <- dsHsWrapper wrap
+                   ; return (makeCorePair dflags global
+                                          (isDefaultMethod prags)
+                                          0 (core_wrap (Var local))) }
+             mk_bind (XABExport _) = panic "dsAbsBinds"
+       ; main_binds <- mapM mk_bind exports
+
+       ; return (force_vars, flattenBinds ds_ev_binds ++ bind_prs ++ main_binds) }
+
+    -- The general case
+    -- See Note [Desugaring AbsBinds]
+  | otherwise
+  = do { let core_bind = Rec [ makeCorePair dflags (add_inline lcl_id) False 0 rhs
+                              | (lcl_id, rhs) <- bind_prs ]
+                -- Monomorphic recursion possible, hence Rec
+             new_force_vars = get_new_force_vars force_vars
+             locals       = map abe_mono exports
+             all_locals   = locals ++ new_force_vars
+             tup_expr     = mkBigCoreVarTup all_locals
+             tup_ty       = exprType tup_expr
+       ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $
+                            mkCoreLets ds_ev_binds $
+                            mkLet core_bind $
+                            tup_expr
+
+       ; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
+
+        -- Find corresponding global or make up a new one: sometimes
+        -- we need to make new export to desugar strict binds, see
+        -- Note [Desugar Strict binds]
+       ; (exported_force_vars, extra_exports) <- get_exports force_vars
+
+       ; let mk_bind (ABE { abe_wrap = wrap
+                          , abe_poly = global
+                          , abe_mono = local, abe_prags = spec_prags })
+                          -- See Note [AbsBinds wrappers] in HsBinds
+                = do { tup_id  <- newSysLocalDs tup_ty
+                     ; core_wrap <- dsHsWrapper wrap
+                     ; let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $
+                                 mkTupleSelector all_locals local tup_id $
+                                 mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
+                           rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
+                     ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
+                     ; let global' = (global `setInlinePragma` defaultInlinePragma)
+                                             `addIdSpecialisations` rules
+                           -- Kill the INLINE pragma because it applies to
+                           -- the user written (local) function.  The global
+                           -- Id is just the selector.  Hmm.
+                     ; return ((global', rhs) : fromOL spec_binds) }
+             mk_bind (XABExport _) = panic "dsAbsBinds"
+
+       ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)
+
+       ; return ( exported_force_vars
+                , (poly_tup_id, poly_tup_rhs) :
+                   concat export_binds_s) }
+  where
+    inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with
+                             -- the inline pragma from the source
+                             -- The type checker put the inline pragma
+                             -- on the *global* Id, so we need to transfer it
+    inline_env
+      = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)
+                 | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports
+                 , let prag = idInlinePragma gbl_id ]
+
+    add_inline :: Id -> Id    -- tran
+    add_inline lcl_id = lookupVarEnv inline_env lcl_id
+                        `orElse` lcl_id
+
+    global_env :: IdEnv Id -- Maps local Id to its global exported Id
+    global_env =
+      mkVarEnv [ (local, global)
+               | ABE { abe_mono = local, abe_poly = global } <- exports
+               ]
+
+    -- find variables that are not exported
+    get_new_force_vars lcls =
+      foldr (\lcl acc -> case lookupVarEnv global_env lcl of
+                           Just _ -> acc
+                           Nothing -> lcl:acc)
+            [] lcls
+
+    -- find exports or make up new exports for force variables
+    get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc])
+    get_exports lcls =
+      foldM (\(glbls, exports) lcl ->
+              case lookupVarEnv global_env lcl of
+                Just glbl -> return (glbl:glbls, exports)
+                Nothing   -> do export <- mk_export lcl
+                                let glbl = abe_poly export
+                                return (glbl:glbls, export:exports))
+            ([],[]) lcls
+
+    mk_export local =
+      do global <- newSysLocalDs
+                     (exprType (mkLams tyvars (mkLams dicts (Var local))))
+         return (ABE { abe_ext   = noExt
+                     , abe_poly  = global
+                     , abe_mono  = local
+                     , abe_wrap  = WpHole
+                     , abe_prags = SpecPrags [] })
+
+-- | This is where we apply INLINE and INLINABLE pragmas. All we need to
+-- do is to attach the unfolding information to the Id.
+--
+-- Other decisions about whether to inline are made in
+-- `calcUnfoldingGuidance` but the decision about whether to then expose
+-- the unfolding in the interface file is made in `TidyPgm.addExternal`
+-- using this information.
+------------------------
+makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr
+             -> (Id, CoreExpr)
+makeCorePair dflags gbl_id is_default_method dict_arity rhs
+  | is_default_method    -- Default methods are *always* inlined
+                         -- See Note [INLINE and default methods] in TcInstDcls
+  = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)
+
+  | otherwise
+  = case inlinePragmaSpec inline_prag of
+          NoUserInline -> (gbl_id, rhs)
+          NoInline     -> (gbl_id, rhs)
+          Inlinable    -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)
+          Inline       -> inline_pair
+
+  where
+    inline_prag   = idInlinePragma gbl_id
+    inlinable_unf = mkInlinableUnfolding dflags rhs
+    inline_pair
+       | Just arity <- inlinePragmaSat inline_prag
+        -- Add an Unfolding for an INLINE (but not for NOINLINE)
+        -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]
+       , let real_arity = dict_arity + arity
+        -- NB: The arity in the InlineRule takes account of the dictionaries
+       = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs
+         , etaExpand real_arity rhs)
+
+       | otherwise
+       = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $
+         (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs)
+
+dictArity :: [Var] -> Arity
+-- Don't count coercion variables in arity
+dictArity dicts = count isId dicts
+
+{-
+Note [Desugaring AbsBinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the general AbsBinds case we desugar the binding to this:
+
+       tup a (d:Num a) = let fm = ...gm...
+                             gm = ...fm...
+                         in (fm,gm)
+       f a d = case tup a d of { (fm,gm) -> fm }
+       g a d = case tup a d of { (fm,gm) -> fm }
+
+Note [Rules and inlining]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Common special case: no type or dictionary abstraction
+This is a bit less trivial than you might suppose
+The naive way would be to desugar to something like
+        f_lcl = ...f_lcl...     -- The "binds" from AbsBinds
+        M.f = f_lcl             -- Generated from "exports"
+But we don't want that, because if M.f isn't exported,
+it'll be inlined unconditionally at every call site (its rhs is
+trivial).  That would be ok unless it has RULES, which would
+thereby be completely lost.  Bad, bad, bad.
+
+Instead we want to generate
+        M.f = ...f_lcl...
+        f_lcl = M.f
+Now all is cool. The RULES are attached to M.f (by SimplCore),
+and f_lcl is rapidly inlined away.
+
+This does not happen in the same way to polymorphic binds,
+because they desugar to
+        M.f = /\a. let f_lcl = ...f_lcl... in f_lcl
+Although I'm a bit worried about whether full laziness might
+float the f_lcl binding out and then inline M.f at its call site
+
+Note [Specialising in no-dict case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Even if there are no tyvars or dicts, we may have specialisation pragmas.
+Class methods can generate
+      AbsBinds [] [] [( ... spec-prag]
+         { AbsBinds [tvs] [dicts] ...blah }
+So the overloading is in the nested AbsBinds. A good example is in GHC.Float:
+
+  class  (Real a, Fractional a) => RealFrac a  where
+    round :: (Integral b) => a -> b
+
+  instance  RealFrac Float  where
+    {-# SPECIALIZE round :: Float -> Int #-}
+
+The top-level AbsBinds for $cround has no tyvars or dicts (because the
+instance does not).  But the method is locally overloaded!
+
+Note [Abstracting over tyvars only]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When abstracting over type variable only (not dictionaries), we don't really need to
+built a tuple and select from it, as we do in the general case. Instead we can take
+
+        AbsBinds [a,b] [ ([a,b], fg, fl, _),
+                         ([b],   gg, gl, _) ]
+                { fl = e1
+                  gl = e2
+                   h = e3 }
+
+and desugar it to
+
+        fg = /\ab. let B in e1
+        gg = /\b. let a = () in let B in S(e2)
+        h  = /\ab. let B in e3
+
+where B is the *non-recursive* binding
+        fl = fg a b
+        gl = gg b
+        h  = h a b    -- See (b); note shadowing!
+
+Notice (a) g has a different number of type variables to f, so we must
+             use the mkArbitraryType thing to fill in the gaps.
+             We use a type-let to do that.
+
+         (b) The local variable h isn't in the exports, and rather than
+             clone a fresh copy we simply replace h by (h a b), where
+             the two h's have different types!  Shadowing happens here,
+             which looks confusing but works fine.
+
+         (c) The result is *still* quadratic-sized if there are a lot of
+             small bindings.  So if there are more than some small
+             number (10), we filter the binding set B by the free
+             variables of the particular RHS.  Tiresome.
+
+Why got to this trouble?  It's a common case, and it removes the
+quadratic-sized tuple desugaring.  Less clutter, hopefully faster
+compilation, especially in a case where there are a *lot* of
+bindings.
+
+
+Note [Eta-expanding INLINE things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   foo :: Eq a => a -> a
+   {-# INLINE foo #-}
+   foo x = ...
+
+If (foo d) ever gets floated out as a common sub-expression (which can
+happen as a result of method sharing), there's a danger that we never
+get to do the inlining, which is a Terribly Bad thing given that the
+user said "inline"!
+
+To avoid this we pre-emptively eta-expand the definition, so that foo
+has the arity with which it is declared in the source code.  In this
+example it has arity 2 (one for the Eq and one for x). Doing this
+should mean that (foo d) is a PAP and we don't share it.
+
+Note [Nested arities]
+~~~~~~~~~~~~~~~~~~~~~
+For reasons that are not entirely clear, method bindings come out looking like
+this:
+
+  AbsBinds [] [] [$cfromT <= [] fromT]
+    $cfromT [InlPrag=INLINE] :: T Bool -> Bool
+    { AbsBinds [] [] [fromT <= [] fromT_1]
+        fromT :: T Bool -> Bool
+        { fromT_1 ((TBool b)) = not b } } }
+
+Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be
+gotten from the binding for fromT_1.
+
+It might be better to have just one level of AbsBinds, but that requires more
+thought!
+
+
+Note [Desugar Strict binds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See https://ghc.haskell.org/trac/ghc/wiki/StrictPragma
+
+Desugaring strict variable bindings looks as follows (core below ==>)
+
+  let !x = rhs
+  in  body
+==>
+  let x = rhs
+  in x `seq` body -- seq the variable
+
+and if it is a pattern binding the desugaring looks like
+
+  let !pat = rhs
+  in body
+==>
+  let x = rhs -- bind the rhs to a new variable
+      pat = x
+  in x `seq` body -- seq the new variable
+
+if there is no variable in the pattern desugaring looks like
+
+  let False = rhs
+  in body
+==>
+  let x = case rhs of {False -> (); _ -> error "Match failed"}
+  in x `seq` body
+
+In order to force the Ids in the binding group they are passed around
+in the dsHsBind family of functions, and later seq'ed in DsExpr.ds_val_bind.
+
+Consider a recursive group like this
+
+  letrec
+     f : g = rhs[f,g]
+  in <body>
+
+Without `Strict`, we get a translation like this:
+
+  let t = /\a. letrec tm = rhs[fm,gm]
+                      fm = case t of fm:_ -> fm
+                      gm = case t of _:gm -> gm
+                in
+                (fm,gm)
+
+  in let f = /\a. case t a of (fm,_) -> fm
+  in let g = /\a. case t a of (_,gm) -> gm
+  in <body>
+
+Here `tm` is the monomorphic binding for `rhs`.
+
+With `Strict`, we want to force `tm`, but NOT `fm` or `gm`.
+Alas, `tm` isn't in scope in the `in <body>` part.
+
+The simplest thing is to return it in the polymorphic
+tuple `t`, thus:
+
+  let t = /\a. letrec tm = rhs[fm,gm]
+                      fm = case t of fm:_ -> fm
+                      gm = case t of _:gm -> gm
+                in
+                (tm, fm, gm)
+
+  in let f = /\a. case t a of (_,fm,_) -> fm
+  in let g = /\a. case t a of (_,_,gm) -> gm
+  in let tm = /\a. case t a of (tm,_,_) -> tm
+  in tm `seq` <body>
+
+
+See https://ghc.haskell.org/trac/ghc/wiki/StrictPragma for a more
+detailed explanation of the desugaring of strict bindings.
+
+Note [Strict binds checks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are several checks around properly formed strict bindings. They
+all link to this Note. These checks must be here in the desugarer because
+we cannot know whether or not a type is unlifted until after zonking, due
+to levity polymorphism. These checks all used to be handled in the typechecker
+in checkStrictBinds (before Jan '17).
+
+We define an "unlifted bind" to be any bind that binds an unlifted id. Note that
+
+  x :: Char
+  (# True, x #) = blah
+
+is *not* an unlifted bind. Unlifted binds are detected by HsUtils.isUnliftedHsBind.
+
+Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedHsBind.
+Define a "strict bind" to be either an unlifted bind or a banged bind.
+
+The restrictions are:
+  1. Strict binds may not be top-level. Checked in dsTopLHsBinds.
+
+  2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged
+     unlifted bind, but an unbanged bind looks lazy, and we don't want users to be
+     surprised by the strictness of an unlifted bind.) Checked in first clause
+     of DsExpr.ds_val_bind.
+
+  3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type
+     variables or constraints.) Checked in first clause
+     of DsExpr.ds_val_bind.
+
+  4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind.
+
+-}
+
+------------------------
+dsSpecs :: CoreExpr     -- Its rhs
+        -> TcSpecPrags
+        -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids
+               , [CoreRule] )           -- Rules for the Global Ids
+-- See Note [Handling SPECIALISE pragmas] in TcBinds
+dsSpecs _ IsDefaultMethod = return (nilOL, [])
+dsSpecs poly_rhs (SpecPrags sps)
+  = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps
+       ; let (spec_binds_s, rules) = unzip pairs
+       ; return (concatOL spec_binds_s, rules) }
+
+dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding
+                                -- Nothing => RULE is for an imported Id
+                                --            rhs is in the Id's unfolding
+       -> Located TcSpecPrag
+       -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
+dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl))
+  | isJust (isClassOpId_maybe poly_id)
+  = putSrcSpanDs loc $
+    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"
+                          <+> quotes (ppr poly_id))
+       ; return Nothing  }  -- There is no point in trying to specialise a class op
+                            -- Moreover, classops don't (currently) have an inl_sat arity set
+                            -- (it would be Just 0) and that in turn makes makeCorePair bleat
+
+  | no_act_spec && isNeverActive rule_act
+  = putSrcSpanDs loc $
+    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"
+                          <+> quotes (ppr poly_id))
+       ; return Nothing  }  -- Function is NOINLINE, and the specialisation inherits that
+                            -- See Note [Activation pragmas for SPECIALISE]
+
+  | otherwise
+  = putSrcSpanDs loc $
+    do { uniq <- newUnique
+       ; let poly_name = idName poly_id
+             spec_occ  = mkSpecOcc (getOccName poly_name)
+             spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
+             (spec_bndrs, spec_app) = collectHsWrapBinders spec_co
+               -- spec_co looks like
+               --         \spec_bndrs. [] spec_args
+               -- perhaps with the body of the lambda wrapped in some WpLets
+               -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2
+
+       ; core_app <- dsHsWrapper spec_app
+
+       ; let ds_lhs  = core_app (Var poly_id)
+             spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)
+       ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id
+         --                         , text "spec_co:" <+> ppr spec_co
+         --                         , text "ds_rhs:" <+> ppr ds_lhs ]) $
+         dflags <- getDynFlags
+       ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of {
+           Left msg -> do { warnDs NoReason msg; return Nothing } ;
+           Right (rule_bndrs, _fn, args) -> do
+
+       { this_mod <- getModule
+       ; let fn_unf    = realIdUnfolding poly_id
+             spec_unf  = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf
+             spec_id   = mkLocalId spec_name spec_ty
+                            `setInlinePragma` inl_prag
+                            `setIdUnfolding`  spec_unf
+             arity_decrease = count isValArg args - count isId spec_bndrs
+
+       ; rule <- dsMkUserRule this_mod is_local_id
+                        (mkFastString ("SPEC " ++ showPpr dflags poly_name))
+                        rule_act poly_name
+                        rule_bndrs args
+                        (mkVarApps (Var spec_id) spec_bndrs)
+
+       ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs)
+
+-- Commented out: see Note [SPECIALISE on INLINE functions]
+--       ; when (isInlinePragma id_inl)
+--              (warnDs $ text "SPECIALISE pragma on INLINE function probably won't fire:"
+--                        <+> quotes (ppr poly_name))
+
+       ; return (Just (unitOL (spec_id, spec_rhs), rule))
+            -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
+            --     makeCorePair overwrites the unfolding, which we have
+            --     just created using specUnfolding
+       } } }
+  where
+    is_local_id = isJust mb_poly_rhs
+    poly_rhs | Just rhs <-  mb_poly_rhs
+             = rhs          -- Local Id; this is its rhs
+             | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)
+             = unfolding    -- Imported Id; this is its unfolding
+                            -- Use realIdUnfolding so we get the unfolding
+                            -- even when it is a loop breaker.
+                            -- We want to specialise recursive functions!
+             | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)
+                            -- The type checker has checked that it *has* an unfolding
+
+    id_inl = idInlinePragma poly_id
+
+    -- See Note [Activation pragmas for SPECIALISE]
+    inl_prag | not (isDefaultInlinePragma spec_inl)    = spec_inl
+             | not is_local_id  -- See Note [Specialising imported functions]
+                                 -- in OccurAnal
+             , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma
+             | otherwise                               = id_inl
+     -- Get the INLINE pragma from SPECIALISE declaration, or,
+     -- failing that, from the original Id
+
+    spec_prag_act = inlinePragmaActivation spec_inl
+
+    -- See Note [Activation pragmas for SPECIALISE]
+    -- no_act_spec is True if the user didn't write an explicit
+    -- phase specification in the SPECIALISE pragma
+    no_act_spec = case inlinePragmaSpec spec_inl of
+                    NoInline -> isNeverActive  spec_prag_act
+                    _        -> isAlwaysActive spec_prag_act
+    rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit
+             | otherwise   = spec_prag_act                   -- Specified by user
+
+
+dsMkUserRule :: Module -> Bool -> RuleName -> Activation
+       -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule
+dsMkUserRule this_mod is_local name act fn bndrs args rhs = do
+    let rule = mkRule this_mod False is_local name act fn bndrs args rhs
+    dflags <- getDynFlags
+    when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $
+        warnDs (Reason Opt_WarnOrphans) (ruleOrphWarn rule)
+    return rule
+
+ruleOrphWarn :: CoreRule -> SDoc
+ruleOrphWarn rule = text "Orphan rule:" <+> ppr rule
+
+{- Note [SPECIALISE on INLINE functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to warn that using SPECIALISE for a function marked INLINE
+would be a no-op; but it isn't!  Especially with worker/wrapper split
+we might have
+   {-# INLINE f #-}
+   f :: Ord a => Int -> a -> ...
+   f d x y = case x of I# x' -> $wf d x' y
+
+We might want to specialise 'f' so that we in turn specialise '$wf'.
+We can't even /name/ '$wf' in the source code, so we can't specialise
+it even if we wanted to.  Trac #10721 is a case in point.
+
+Note [Activation pragmas for SPECIALISE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+From a user SPECIALISE pragma for f, we generate
+  a) A top-level binding    spec_fn = rhs
+  b) A RULE                 f dOrd = spec_fn
+
+We need two pragma-like things:
+
+* spec_fn's inline pragma: inherited from f's inline pragma (ignoring
+                           activation on SPEC), unless overriden by SPEC INLINE
+
+* Activation of RULE: from SPECIALISE pragma (if activation given)
+                      otherwise from f's inline pragma
+
+This is not obvious (see Trac #5237)!
+
+Examples      Rule activation   Inline prag on spec'd fn
+---------------------------------------------------------------------
+SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]
+                                  copy f's prag
+
+NOINLINE f
+SPEC [n] f :: ty            [n]   NOINLINE
+                                  copy f's prag
+
+NOINLINE [k] f
+SPEC [n] f :: ty            [n]   NOINLINE [k]
+                                  copy f's prag
+
+INLINE [k] f
+SPEC [n] f :: ty            [n]   INLINE [k]
+                                  copy f's prag
+
+SPEC INLINE [n] f :: ty     [n]   INLINE [n]
+                                  (ignore INLINE prag on f,
+                                  same activation for rule and spec'd fn)
+
+NOINLINE [k] f
+SPEC f :: ty                [n]   INLINE [k]
+
+
+************************************************************************
+*                                                                      *
+\subsection{Adding inline pragmas}
+*                                                                      *
+************************************************************************
+-}
+
+decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr
+                 -> Either SDoc ([Var], Id, [CoreExpr])
+-- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,
+-- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
+-- may add some extra dictionary binders (see Note [Free dictionaries])
+--
+-- Returns an error message if the LHS isn't of the expected shape
+-- Note [Decomposing the left-hand side of a RULE]
+decomposeRuleLhs dflags orig_bndrs orig_lhs
+  | not (null unbound)    -- Check for things unbound on LHS
+                          -- See Note [Unused spec binders]
+  = Left (vcat (map dead_msg unbound))
+  | Var funId <- fun2
+  , Just con <- isDataConId_maybe funId
+  = Left (constructor_msg con) -- See Note [No RULES on datacons]
+  | Just (fn_id, args) <- decompose fun2 args2
+  , let extra_bndrs = mk_extra_bndrs fn_id args
+  = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
+    --                                  , text "orig_lhs:" <+> ppr orig_lhs
+    --                                  , text "lhs1:"     <+> ppr lhs1
+    --                                  , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs
+    --                                  , text "fn_id:" <+> ppr fn_id
+    --                                  , text "args:"   <+> ppr args]) $
+    Right (orig_bndrs ++ extra_bndrs, fn_id, args)
+
+  | otherwise
+  = Left bad_shape_msg
+ where
+   lhs1         = drop_dicts orig_lhs
+   lhs2         = simpleOptExpr dflags lhs1  -- See Note [Simplify rule LHS]
+   (fun2,args2) = collectArgs lhs2
+
+   lhs_fvs    = exprFreeVars lhs2
+   unbound    = filterOut (`elemVarSet` lhs_fvs) orig_bndrs
+
+   orig_bndr_set = mkVarSet orig_bndrs
+
+        -- Add extra tyvar binders: Note [Free tyvars in rule LHS]
+        -- and extra dict binders: Note [Free dictionaries in rule LHS]
+   mk_extra_bndrs fn_id args
+     = scopedSort unbound_tvs ++ unbound_dicts
+     where
+       unbound_tvs   = [ v | v <- unbound_vars, isTyVar v ]
+       unbound_dicts = [ mkLocalId (localiseName (idName d)) (idType d)
+                       | d <- unbound_vars, isDictId d ]
+       unbound_vars  = [ v | v <- exprsFreeVarsList args
+                           , not (v `elemVarSet` orig_bndr_set)
+                           , not (v == fn_id) ]
+         -- fn_id: do not quantify over the function itself, which may
+         -- itself be a dictionary (in pathological cases, Trac #10251)
+
+   decompose (Var fn_id) args
+      | not (fn_id `elemVarSet` orig_bndr_set)
+      = Just (fn_id, args)
+
+   decompose _ _ = Nothing
+
+   bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar")
+                      2 (vcat [ text "Optimised lhs:" <+> ppr lhs2
+                              , text "Orig lhs:" <+> ppr orig_lhs])
+   dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr
+                             , text "is not bound in RULE lhs"])
+                      2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs
+                              , text "Orig lhs:" <+> ppr orig_lhs
+                              , text "optimised lhs:" <+> ppr lhs2 ])
+   pp_bndr bndr
+    | isTyVar bndr = text "type variable" <+> quotes (ppr bndr)
+    | isEvVar bndr = text "constraint"    <+> quotes (ppr (varType bndr))
+    | otherwise    = text "variable"      <+> quotes (ppr bndr)
+
+   constructor_msg con = vcat
+     [ text "A constructor," <+> ppr con <>
+         text ", appears as outermost match in RULE lhs."
+     , text "This rule will be ignored." ]
+
+   drop_dicts :: CoreExpr -> CoreExpr
+   drop_dicts e
+       = wrap_lets needed bnds body
+     where
+       needed = orig_bndr_set `minusVarSet` exprFreeVars body
+       (bnds, body) = split_lets (occurAnalyseExpr e)
+           -- The occurAnalyseExpr drops dead bindings which is
+           -- crucial to ensure that every binding is used later;
+           -- which in turn makes wrap_lets work right
+
+   split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)
+   split_lets (Let (NonRec d r) body)
+     | isDictId d
+     = ((d,r):bs, body')
+     where (bs, body') = split_lets body
+
+    -- handle "unlifted lets" too, needed for "map/coerce"
+   split_lets (Case r d _ [(DEFAULT, _, body)])
+     | isCoVar d
+     = ((d,r):bs, body')
+     where (bs, body') = split_lets body
+
+   split_lets e = ([], e)
+
+   wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr
+   wrap_lets _ [] body = body
+   wrap_lets needed ((d, r) : bs) body
+     | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body)
+     | otherwise                         = wrap_lets needed bs body
+     where
+       rhs_fvs = exprFreeVars r
+       needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d
+
+{-
+Note [Decomposing the left-hand side of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are several things going on here.
+* drop_dicts: see Note [Drop dictionary bindings on rule LHS]
+* simpleOptExpr: see Note [Simplify rule LHS]
+* extra_dict_bndrs: see Note [Free dictionaries]
+
+Note [Free tyvars on rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data T a = C
+
+  foo :: T a -> Int
+  foo C = 1
+
+  {-# RULES "myrule"  foo C = 1 #-}
+
+After type checking the LHS becomes (foo alpha (C alpha)), where alpha
+is an unbound meta-tyvar.  The zonker in TcHsSyn is careful not to
+turn the free alpha into Any (as it usually does).  Instead it turns it
+into a TyVar 'a'.  See TcHsSyn Note [Zonking the LHS of a RULE].
+
+Now we must quantify over that 'a'.  It's /really/ inconvenient to do that
+in the zonker, because the HsExpr data type is very large.  But it's /easy/
+to do it here in the desugarer.
+
+Moreover, we have to do something rather similar for dictionaries;
+see Note [Free dictionaries on rule LHS].   So that's why we look for
+type variables free on the LHS, and quantify over them.
+
+Note [Free dictionaries on rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,
+which is presumably in scope at the function definition site, we can quantify
+over it too.  *Any* dict with that type will do.
+
+So for example when you have
+        f :: Eq a => a -> a
+        f = <rhs>
+        ... SPECIALISE f :: Int -> Int ...
+
+Then we get the SpecPrag
+        SpecPrag (f Int dInt)
+
+And from that we want the rule
+
+        RULE forall dInt. f Int dInt = f_spec
+        f_spec = let f = <rhs> in f Int dInt
+
+But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External
+Name, and you can't bind them in a lambda or forall without getting things
+confused.   Likewise it might have an InlineRule or something, which would be
+utterly bogus. So we really make a fresh Id, with the same unique and type
+as the old one, but with an Internal name and no IdInfo.
+
+Note [Drop dictionary bindings on rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+drop_dicts drops dictionary bindings on the LHS where possible.
+   E.g.  let d:Eq [Int] = $fEqList $fEqInt in f d
+     --> f d
+   Reasoning here is that there is only one d:Eq [Int], and so we can
+   quantify over it. That makes 'd' free in the LHS, but that is later
+   picked up by extra_dict_bndrs (Note [Dead spec binders]).
+
+   NB 1: We can only drop the binding if the RHS doesn't bind
+         one of the orig_bndrs, which we assume occur on RHS.
+         Example
+            f :: (Eq a) => b -> a -> a
+            {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}
+         Here we want to end up with
+            RULE forall d:Eq a.  f ($dfEqList d) = f_spec d
+         Of course, the ($dfEqlist d) in the pattern makes it less likely
+         to match, but there is no other way to get d:Eq a
+
+   NB 2: We do drop_dicts *before* simplOptEpxr, so that we expect all
+         the evidence bindings to be wrapped around the outside of the
+         LHS.  (After simplOptExpr they'll usually have been inlined.)
+         dsHsWrapper does dependency analysis, so that civilised ones
+         will be simple NonRec bindings.  We don't handle recursive
+         dictionaries!
+
+    NB3: In the common case of a non-overloaded, but perhaps-polymorphic
+         specialisation, we don't need to bind *any* dictionaries for use
+         in the RHS. For example (Trac #8331)
+             {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}
+             useAbstractMonad :: MonadAbstractIOST m => m Int
+         Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code
+         but the RHS uses no dictionaries, so we want to end up with
+             RULE forall s (d :: MonadAbstractIOST (ReaderT s)).
+                useAbstractMonad (ReaderT s) d = $suseAbstractMonad s
+
+   Trac #8848 is a good example of where there are some interesting
+   dictionary bindings to discard.
+
+The drop_dicts algorithm is based on these observations:
+
+  * Given (let d = rhs in e) where d is a DictId,
+    matching 'e' will bind e's free variables.
+
+  * So we want to keep the binding if one of the needed variables (for
+    which we need a binding) is in fv(rhs) but not already in fv(e).
+
+  * The "needed variables" are simply the orig_bndrs.  Consider
+       f :: (Eq a, Show b) => a -> b -> String
+       ... SPECIALISE f :: (Show b) => Int -> b -> String ...
+    Then orig_bndrs includes the *quantified* dictionaries of the type
+    namely (dsb::Show b), but not the one for Eq Int
+
+So we work inside out, applying the above criterion at each step.
+
+
+Note [Simplify rule LHS]
+~~~~~~~~~~~~~~~~~~~~~~~~
+simplOptExpr occurrence-analyses and simplifies the LHS:
+
+   (a) Inline any remaining dictionary bindings (which hopefully
+       occur just once)
+
+   (b) Substitute trivial lets, so that they don't get in the way.
+       Note that we substitute the function too; we might
+       have this as a LHS:  let f71 = M.f Int in f71
+
+   (c) Do eta reduction.  To see why, consider the fold/build rule,
+       which without simplification looked like:
+          fold k z (build (/\a. g a))  ==>  ...
+       This doesn't match unless you do eta reduction on the build argument.
+       Similarly for a LHS like
+         augment g (build h)
+       we do not want to get
+         augment (\a. g a) (build h)
+       otherwise we don't match when given an argument like
+          augment (\a. h a a) (build h)
+
+Note [Matching seqId]
+~~~~~~~~~~~~~~~~~~~
+The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
+and this code turns it back into an application of seq!
+See Note [Rules for seq] in MkId for the details.
+
+Note [Unused spec binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+        f :: a -> a
+        ... SPECIALISE f :: Eq a => a -> a ...
+It's true that this *is* a more specialised type, but the rule
+we get is something like this:
+        f_spec d = f
+        RULE: f = f_spec d
+Note that the rule is bogus, because it mentions a 'd' that is
+not bound on the LHS!  But it's a silly specialisation anyway, because
+the constraint is unused.  We could bind 'd' to (error "unused")
+but it seems better to reject the program because it's almost certainly
+a mistake.  That's what the isDeadBinder call detects.
+
+Note [No RULES on datacons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Previously, `RULES` like
+
+    "JustNothing" forall x . Just x = Nothing
+
+were allowed. Simon Peyton Jones says this seems to have been a
+mistake, that such rules have never been supported intentionally,
+and that he doesn't know if they can break in horrible ways.
+Furthermore, Ben Gamari and Reid Barton are considering trying to
+detect the presence of "static data" that the simplifier doesn't
+need to traverse at all. Such rules do not play well with that.
+So for now, we ban them altogether as requested by #13290. See also #7398.
+
+
+************************************************************************
+*                                                                      *
+                Desugaring evidence
+*                                                                      *
+************************************************************************
+
+-}
+
+dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
+dsHsWrapper WpHole            = return $ \e -> e
+dsHsWrapper (WpTyApp ty)      = return $ \e -> App e (Type ty)
+dsHsWrapper (WpEvLam ev)      = return $ Lam ev
+dsHsWrapper (WpTyLam tv)      = return $ Lam tv
+dsHsWrapper (WpLet ev_binds)  = do { bs <- dsTcEvBinds ev_binds
+                                   ; return (mkCoreLets bs) }
+dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1
+                                   ; w2 <- dsHsWrapper c2
+                                   ; return (w1 . w2) }
+ -- See comments on WpFun in TcEvidence for an explanation of what
+ -- the specification of this clause is
+dsHsWrapper (WpFun c1 c2 t1 doc)
+                              = do { x  <- newSysLocalDsNoLP t1
+                                   ; w1 <- dsHsWrapper c1
+                                   ; w2 <- dsHsWrapper c2
+                                   ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a
+                                         arg     = w1 (Var x)
+                                   ; (_, ok) <- askNoErrsDs $ dsNoLevPolyExpr arg doc
+                                   ; if ok
+                                     then return (\e -> (Lam x (w2 (app e arg))))
+                                     else return id }  -- this return is irrelevant
+dsHsWrapper (WpCast co)       = ASSERT(coercionRole co == Representational)
+                                return $ \e -> mkCastDs e co
+dsHsWrapper (WpEvApp tm)      = do { core_tm <- dsEvTerm tm
+                                   ; return (\e -> App e core_tm) }
+
+--------------------------------------
+dsTcEvBinds_s :: [TcEvBinds] -> DsM [CoreBind]
+dsTcEvBinds_s []       = return []
+dsTcEvBinds_s (b:rest) = ASSERT( null rest )  -- Zonker ensures null
+                         dsTcEvBinds b
+
+dsTcEvBinds :: TcEvBinds -> DsM [CoreBind]
+dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"    -- Zonker has got rid of this
+dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
+
+dsEvBinds :: Bag EvBind -> DsM [CoreBind]
+dsEvBinds bs
+  = do { ds_bs <- mapBagM dsEvBind bs
+       ; return (mk_ev_binds ds_bs) }
+
+mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind]
+-- We do SCC analysis of the evidence bindings, /after/ desugaring
+-- them. This is convenient: it means we can use the CoreSyn
+-- free-variable functions rather than having to do accurate free vars
+-- for EvTerm.
+mk_ev_binds ds_binds
+  = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges)
+  where
+    edges :: [ Node EvVar (EvVar,CoreExpr) ]
+    edges = foldrBag ((:) . mk_node) [] ds_binds
+
+    mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)
+    mk_node b@(var, rhs)
+      = DigraphNode { node_payload = b
+                    , node_key = var
+                    , node_dependencies = nonDetEltsUniqSet $
+                                          exprFreeVars rhs `unionVarSet`
+                                          coVarsOfType (varType var) }
+      -- It's OK to use nonDetEltsUniqSet here as stronglyConnCompFromEdgedVertices
+      -- is still deterministic even if the edges are in nondeterministic order
+      -- as explained in Note [Deterministic SCC] in Digraph.
+
+    ds_scc (AcyclicSCC (v,r)) = NonRec v r
+    ds_scc (CyclicSCC prs)    = Rec prs
+
+dsEvBind :: EvBind -> DsM (Id, CoreExpr)
+dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)
+
+
+{-**********************************************************************
+*                                                                      *
+           Desugaring EvTerms
+*                                                                      *
+**********************************************************************-}
+
+dsEvTerm :: EvTerm -> DsM CoreExpr
+dsEvTerm (EvExpr e)          = return e
+dsEvTerm (EvTypeable ty ev)  = dsEvTypeable ty ev
+dsEvTerm (EvFun { et_tvs = tvs, et_given = given
+                , et_binds = ev_binds, et_body = wanted_id })
+  = do { ds_ev_binds <- dsTcEvBinds ev_binds
+       ; return $ (mkLams (tvs ++ given) $
+                   mkCoreLets ds_ev_binds $
+                   Var wanted_id) }
+
+
+{-**********************************************************************
+*                                                                      *
+           Desugaring Typeable dictionaries
+*                                                                      *
+**********************************************************************-}
+
+dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr
+-- Return a CoreExpr :: Typeable ty
+-- This code is tightly coupled to the representation
+-- of TypeRep, in base library Data.Typeable.Internals
+dsEvTypeable ty ev
+  = do { tyCl <- dsLookupTyCon typeableClassName    -- Typeable
+       ; let kind = typeKind ty
+             Just typeable_data_con
+                 = tyConSingleDataCon_maybe tyCl    -- "Data constructor"
+                                                    -- for Typeable
+
+       ; rep_expr <- ds_ev_typeable ty ev           -- :: TypeRep a
+
+       -- Package up the method as `Typeable` dictionary
+       ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] }
+
+type TypeRepExpr = CoreExpr
+
+-- | Returns a @CoreExpr :: TypeRep ty@
+ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr
+ds_ev_typeable ty (EvTypeableTyCon tc kind_ev)
+  = do { mkTrCon <- dsLookupGlobalId mkTrConName
+                    -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a
+       ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName
+       ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName
+                    -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep
+
+       ; tc_rep <- tyConRep tc                      -- :: TyCon
+       ; let ks = tyConAppArgs ty
+             -- Construct a SomeTypeRep
+             toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr
+             toSomeTypeRep t ev = do
+                 rep <- getRep ev t
+                 return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep]
+       ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev   -- :: TypeRep t
+       ; let -- :: [SomeTypeRep]
+             kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps
+
+         -- Note that we use the kind of the type, not the TyCon from which it
+         -- is constructed since the latter may be kind polymorphic whereas the
+         -- former we know is not (we checked in the solver).
+       ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty)
+                                         , Type ty
+                                         , tc_rep
+                                         , kind_args ]
+       -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr
+       ; return expr
+       }
+
+ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
+  | Just (t1,t2) <- splitAppTy_maybe ty
+  = do { e1  <- getRep ev1 t1
+       ; e2  <- getRep ev2 t2
+       ; mkTrApp <- dsLookupGlobalId mkTrAppName
+                    -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
+                    --            TypeRep a -> TypeRep b -> TypeRep (a b)
+       ; let (k1, k2) = splitFunTy (typeKind t1)
+       ; let expr =  mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])
+                            [ e1, e2 ]
+       -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr
+       ; return expr
+       }
+
+ds_ev_typeable ty (EvTypeableTrFun ev1 ev2)
+  | Just (t1,t2) <- splitFunTy_maybe ty
+  = do { e1 <- getRep ev1 t1
+       ; e2 <- getRep ev2 t2
+       ; mkTrFun <- dsLookupGlobalId mkTrFunName
+                    -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2).
+                    --            TypeRep a -> TypeRep b -> TypeRep (a -> b)
+       ; let r1 = getRuntimeRep t1
+             r2 = getRuntimeRep t2
+       ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2])
+                         [ e1, e2 ]
+       }
+
+ds_ev_typeable ty (EvTypeableTyLit ev)
+  = -- See Note [Typeable for Nat and Symbol] in TcInteract
+    do { fun  <- dsLookupGlobalId tr_fun
+       ; dict <- dsEvTerm ev       -- Of type KnownNat/KnownSymbol
+       ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty]
+       ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) }
+  where
+    ty_kind = typeKind ty
+
+    -- tr_fun is the Name of
+    --       typeNatTypeRep    :: KnownNat    a => Proxy# a -> TypeRep a
+    -- of    typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a
+    tr_fun | ty_kind `eqType` typeNatKind    = typeNatTypeRepName
+           | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName
+           | otherwise = panic "dsEvTypeable: unknown type lit kind"
+
+ds_ev_typeable ty ev
+  = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev)
+
+getRep :: EvTerm          -- ^ EvTerm for @Typeable ty@
+       -> Type            -- ^ The type @ty@
+       -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@
+                          -- namely @typeRep# dict@
+-- Remember that
+--   typeRep# :: forall k (a::k). Typeable k a -> TypeRep a
+getRep ev ty
+  = do { typeable_expr <- dsEvTerm ev
+       ; typeRepId     <- dsLookupGlobalId typeRepIdName
+       ; let ty_args = [typeKind ty, ty]
+       ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) }
+
+tyConRep :: TyCon -> DsM CoreExpr
+-- Returns CoreExpr :: TyCon
+tyConRep tc
+  | Just tc_rep_nm <- tyConRepName_maybe tc
+  = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm
+       ; return (Var tc_rep_id) }
+  | otherwise
+  = pprPanic "tyConRep" (ppr tc)
diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsCCall.hs
@@ -0,0 +1,379 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1994-1998
+
+
+Desugaring foreign calls
+-}
+
+{-# LANGUAGE CPP #-}
+module DsCCall
+        ( dsCCall
+        , mkFCall
+        , unboxArg
+        , boxResult
+        , resultWrapper
+        ) where
+
+#include "HsVersions.h"
+
+
+import GhcPrelude
+
+import CoreSyn
+
+import DsMonad
+import CoreUtils
+import MkCore
+import MkId
+import ForeignCall
+import DataCon
+import DsUtils
+
+import TcType
+import Type
+import Id   ( Id )
+import Coercion
+import PrimOp
+import TysPrim
+import TyCon
+import TysWiredIn
+import BasicTypes
+import Literal
+import PrelNames
+import DynFlags
+import Outputable
+import Util
+
+import Data.Maybe
+
+{-
+Desugaring of @ccall@s consists of adding some state manipulation,
+unboxing any boxed primitive arguments and boxing the result if
+desired.
+
+The state stuff just consists of adding in
+@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place.
+
+The unboxing is straightforward, as all information needed to unbox is
+available from the type.  For each boxed-primitive argument, we
+transform:
+\begin{verbatim}
+   _ccall_ foo [ r, t1, ... tm ] e1 ... em
+   |
+   |
+   V
+   case e1 of { T1# x1# ->
+   ...
+   case em of { Tm# xm# -> xm#
+   ccall# foo [ r, t1#, ... tm# ] x1# ... xm#
+   } ... }
+\end{verbatim}
+
+The reboxing of a @_ccall_@ result is a bit tricker: the types don't
+contain information about the state-pairing functions so we have to
+keep a list of \tr{(type, s-p-function)} pairs.  We transform as
+follows:
+\begin{verbatim}
+   ccall# foo [ r, t1#, ... tm# ] e1# ... em#
+   |
+   |
+   V
+   \ s# -> case (ccall# foo [ r, t1#, ... tm# ] s# e1# ... em#) of
+          (StateAnd<r># result# state#) -> (R# result#, realWorld#)
+\end{verbatim}
+-}
+
+dsCCall :: CLabelString -- C routine to invoke
+        -> [CoreExpr]   -- Arguments (desugared)
+                        -- Precondition: none have levity-polymorphic types
+        -> Safety       -- Safety of the call
+        -> Type         -- Type of the result: IO t
+        -> DsM CoreExpr -- Result, of type ???
+
+dsCCall lbl args may_gc result_ty
+  = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
+       (ccall_result_ty, res_wrapper) <- boxResult result_ty
+       uniq <- newUnique
+       dflags <- getDynFlags
+       let
+           target = StaticTarget NoSourceText lbl Nothing True
+           the_fcall    = CCall (CCallSpec target CCallConv may_gc)
+           the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
+       return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
+
+mkFCall :: DynFlags -> Unique -> ForeignCall
+        -> [CoreExpr]     -- Args
+        -> Type           -- Result type
+        -> CoreExpr
+-- Construct the ccall.  The only tricky bit is that the ccall Id should have
+-- no free vars, so if any of the arg tys do we must give it a polymorphic type.
+--      [I forget *why* it should have no free vars!]
+-- For example:
+--      mkCCall ... [s::StablePtr (a->b), x::Addr, c::Char]
+--
+-- Here we build a ccall thus
+--      (ccallid::(forall a b.  StablePtr (a -> b) -> Addr -> Char -> IO Addr))
+--                      a b s x c
+mkFCall dflags uniq the_fcall val_args res_ty
+  = ASSERT( all isTyVar tyvars )  -- this must be true because the type is top-level
+    mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
+  where
+    arg_tys = map exprType val_args
+    body_ty = (mkFunTys arg_tys res_ty)
+    tyvars  = tyCoVarsOfTypeWellScoped body_ty
+    ty      = mkInvForAllTys tyvars body_ty
+    the_fcall_id = mkFCallId dflags uniq the_fcall ty
+
+unboxArg :: CoreExpr                    -- The supplied argument, not levity-polymorphic
+         -> DsM (CoreExpr,              -- To pass as the actual argument
+                 CoreExpr -> CoreExpr   -- Wrapper to unbox the arg
+                )
+-- Example: if the arg is e::Int, unboxArg will return
+--      (x#::Int#, \W. case x of I# x# -> W)
+-- where W is a CoreExpr that probably mentions x#
+
+-- always returns a non-levity-polymorphic expression
+
+unboxArg arg
+  -- Primitive types: nothing to unbox
+  | isPrimitiveType arg_ty
+  = return (arg, \body -> body)
+
+  -- Recursive newtypes
+  | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
+  = unboxArg (mkCastDs arg co)
+
+  -- Booleans
+  | Just tc <- tyConAppTyCon_maybe arg_ty,
+    tc `hasKey` boolTyConKey
+  = do dflags <- getDynFlags
+       prim_arg <- newSysLocalDs intPrimTy
+       return (Var prim_arg,
+              \ body -> Case (mkWildCase arg arg_ty intPrimTy
+                                       [(DataAlt falseDataCon,[],mkIntLit dflags 0),
+                                        (DataAlt trueDataCon, [],mkIntLit dflags 1)])
+                                        -- In increasing tag order!
+                             prim_arg
+                             (exprType body)
+                             [(DEFAULT,[],body)])
+
+  -- Data types with a single constructor, which has a single, primitive-typed arg
+  -- This deals with Int, Float etc; also Ptr, ForeignPtr
+  | is_product_type && data_con_arity == 1
+  = ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty)
+                        -- Typechecker ensures this
+    do case_bndr <- newSysLocalDs arg_ty
+       prim_arg <- newSysLocalDs data_con_arg_ty1
+       return (Var prim_arg,
+               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
+              )
+
+  -- Byte-arrays, both mutable and otherwise; hack warning
+  -- We're looking for values of type ByteArray, MutableByteArray
+  --    data ByteArray          ix = ByteArray        ix ix ByteArray#
+  --    data MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s)
+  | is_product_type &&
+    data_con_arity == 3 &&
+    isJust maybe_arg3_tycon &&
+    (arg3_tycon ==  byteArrayPrimTyCon ||
+     arg3_tycon ==  mutableByteArrayPrimTyCon)
+  = do case_bndr <- newSysLocalDs arg_ty
+       vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs data_con_arg_tys
+       return (Var arr_cts_var,
+               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
+              )
+
+  | otherwise
+  = do l <- getSrcSpanDs
+       pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
+  where
+    arg_ty                                      = exprType arg
+    maybe_product_type                          = splitDataProductType_maybe arg_ty
+    is_product_type                             = isJust maybe_product_type
+    Just (_, _, data_con, data_con_arg_tys)     = maybe_product_type
+    data_con_arity                              = dataConSourceArity data_con
+    (data_con_arg_ty1 : _)                      = data_con_arg_tys
+
+    (_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
+    maybe_arg3_tycon               = tyConAppTyCon_maybe data_con_arg_ty3
+    Just arg3_tycon                = maybe_arg3_tycon
+
+boxResult :: Type
+          -> DsM (Type, CoreExpr -> CoreExpr)
+
+-- Takes the result of the user-level ccall:
+--      either (IO t),
+--      or maybe just t for a side-effect-free call
+-- Returns a wrapper for the primitive ccall itself, along with the
+-- type of the result of the primitive ccall.  This result type
+-- will be of the form
+--      State# RealWorld -> (# State# RealWorld, t' #)
+-- where t' is the unwrapped form of t.  If t is simply (), then
+-- the result type will be
+--      State# RealWorld -> (# State# RealWorld #)
+
+boxResult result_ty
+  | Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
+        -- isIOType_maybe handles the case where the type is a
+        -- simple wrapping of IO.  E.g.
+        --      newtype Wrap a = W (IO a)
+        -- No coercion necessary because its a non-recursive newtype
+        -- (If we wanted to handle a *recursive* newtype too, we'd need
+        -- another case, and a coercion.)
+        -- The result is IO t, so wrap the result in an IO constructor
+  = do  { res <- resultWrapper io_res_ty
+        ; let extra_result_tys
+                = case res of
+                     (Just ty,_)
+                       | isUnboxedTupleType ty
+                       -> let Just ls = tyConAppArgs_maybe ty in tail ls
+                     _ -> []
+
+              return_result state anss
+                = mkCoreUbxTup
+                    (realWorldStatePrimTy : io_res_ty : extra_result_tys)
+                    (state : anss)
+
+        ; (ccall_res_ty, the_alt) <- mk_alt return_result res
+
+        ; state_id <- newSysLocalDs realWorldStatePrimTy
+        ; let io_data_con = head (tyConDataCons io_tycon)
+              toIOCon     = dataConWrapId io_data_con
+
+              wrap the_call =
+                              mkApps (Var toIOCon)
+                                     [ Type io_res_ty,
+                                       Lam state_id $
+                                       mkWildCase (App the_call (Var state_id))
+                                             ccall_res_ty
+                                             (coreAltType the_alt)
+                                             [the_alt]
+                                     ]
+
+        ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
+
+boxResult result_ty
+  = do -- It isn't IO, so do unsafePerformIO
+       -- It's not conveniently available, so we inline it
+       res <- resultWrapper result_ty
+       (ccall_res_ty, the_alt) <- mk_alt return_result res
+       let
+           wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
+                                           ccall_res_ty
+                                           (coreAltType the_alt)
+                                           [the_alt]
+       return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+  where
+    return_result _ [ans] = ans
+    return_result _ _     = panic "return_result: expected single result"
+
+
+mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)
+       -> (Maybe Type, Expr Var -> Expr Var)
+       -> DsM (Type, (AltCon, [Id], Expr Var))
+mk_alt return_result (Nothing, wrap_result)
+  = do -- The ccall returns ()
+       state_id <- newSysLocalDs realWorldStatePrimTy
+       let
+             the_rhs = return_result (Var state_id)
+                                     [wrap_result (panic "boxResult")]
+
+             ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]
+             the_alt      = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs)
+
+       return (ccall_res_ty, the_alt)
+
+mk_alt return_result (Just prim_res_ty, wrap_result)
+  = -- The ccall returns a non-() value
+    ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty )
+             -- True because resultWrapper ensures it is so
+    do { result_id <- newSysLocalDs prim_res_ty
+       ; state_id <- newSysLocalDs realWorldStatePrimTy
+       ; let the_rhs = return_result (Var state_id)
+                                [wrap_result (Var result_id)]
+             ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]
+             the_alt      = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs)
+       ; return (ccall_res_ty, the_alt) }
+
+
+resultWrapper :: Type
+              -> DsM (Maybe Type,               -- Type of the expected result, if any
+                      CoreExpr -> CoreExpr)     -- Wrapper for the result
+-- resultWrapper deals with the result *value*
+-- E.g. foreign import foo :: Int -> IO T
+-- Then resultWrapper deals with marshalling the 'T' part
+-- So if    resultWrapper ty = (Just ty_rep, marshal)
+--  then      marshal (e :: ty_rep) :: ty
+-- That is, 'marshal' wrape the result returned by the foreign call,
+-- of type ty_rep, into the value Haskell expected, of type 'ty'
+--
+-- Invariant: ty_rep is always a primitive type
+--            i.e. (isPrimitiveType ty_rep) is True
+
+resultWrapper result_ty
+  -- Base case 1: primitive types
+  | isPrimitiveType result_ty
+  = return (Just result_ty, \e -> e)
+
+  -- Base case 2: the unit type ()
+  | Just (tc,_) <- maybe_tc_app
+  , tc `hasKey` unitTyConKey
+  = return (Nothing, \_ -> Var unitDataConId)
+
+  -- Base case 3: the boolean type
+  | Just (tc,_) <- maybe_tc_app
+  , tc `hasKey` boolTyConKey
+  = do { dflags <- getDynFlags
+       ; let marshal_bool e
+               = mkWildCase e intPrimTy boolTy
+                   [ (DEFAULT                   ,[],Var trueDataConId )
+                   , (LitAlt (mkLitInt dflags 0),[],Var falseDataConId)]
+       ; return (Just intPrimTy, marshal_bool) }
+
+  -- Newtypes
+  | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
+  = do { (maybe_ty, wrapper) <- resultWrapper rep_ty
+       ; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) }
+
+  -- The type might contain foralls (eg. for dummy type arguments,
+  -- referring to 'Ptr a' is legal).
+  | Just (tyvar, rest) <- splitForAllTy_maybe result_ty
+  = do { (maybe_ty, wrapper) <- resultWrapper rest
+       ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) }
+
+  -- Data types with a single constructor, which has a single arg
+  -- This includes types like Ptr and ForeignPtr
+  | Just (tycon, tycon_arg_tys) <- maybe_tc_app
+  , Just data_con <- isDataProductTyCon_maybe tycon  -- One constructor, no existentials
+  , [unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys  -- One argument
+  = do { dflags <- getDynFlags
+       ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
+       ; let narrow_wrapper = maybeNarrow dflags tycon
+             marshal_con e  = Var (dataConWrapId data_con)
+                              `mkTyApps` tycon_arg_tys
+                              `App` wrapper (narrow_wrapper e)
+       ; return (maybe_ty, marshal_con) }
+
+  | otherwise
+  = pprPanic "resultWrapper" (ppr result_ty)
+  where
+    maybe_tc_app = splitTyConApp_maybe result_ty
+
+-- When the result of a foreign call is smaller than the word size, we
+-- need to sign- or zero-extend the result up to the word size.  The C
+-- standard appears to say that this is the responsibility of the
+-- caller, not the callee.
+
+maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)
+maybeNarrow dflags tycon
+  | tycon `hasKey` int8TyConKey   = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
+  | tycon `hasKey` int16TyConKey  = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
+  | tycon `hasKey` int32TyConKey
+         && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
+
+  | tycon `hasKey` word8TyConKey  = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
+  | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
+  | tycon `hasKey` word32TyConKey
+         && wORD_SIZE dflags > 4         = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
+  | otherwise                     = id
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsExpr.hs
@@ -0,0 +1,1174 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Desugaring expressions.
+-}
+
+{-# LANGUAGE CPP, MultiWayIf #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
+              , dsValBinds, dsLit, dsSyntaxExpr ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Match
+import MatchLit
+import DsBinds
+import DsGRHSs
+import DsListComp
+import DsUtils
+import DsArrows
+import DsMonad
+import Check ( checkGuardMatches )
+import Name
+import NameEnv
+import FamInstEnv( topNormaliseType )
+import DsMeta
+import HsSyn
+
+-- NB: The desugarer, which straddles the source and Core worlds, sometimes
+--     needs to see source types
+import TcType
+import TcEvidence
+import TcRnMonad
+import TcHsSyn
+import Type
+import CoreSyn
+import CoreUtils
+import MkCore
+
+import DynFlags
+import CostCentre
+import Id
+import MkId
+import Module
+import ConLike
+import DataCon
+import TysWiredIn
+import PrelNames
+import BasicTypes
+import Maybes
+import VarEnv
+import SrcLoc
+import Util
+import Bag
+import Outputable
+import PatSyn
+
+import Control.Monad
+
+{-
+************************************************************************
+*                                                                      *
+                dsLocalBinds, dsValBinds
+*                                                                      *
+************************************************************************
+-}
+
+dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
+dsLocalBinds (dL->L _   (EmptyLocalBinds _))  body = return body
+dsLocalBinds (dL->L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $
+                                                   dsValBinds binds body
+dsLocalBinds (dL->L _ (HsIPBinds _ binds))    body = dsIPBinds  binds body
+dsLocalBinds _                                _    = panic "dsLocalBinds"
+
+-------------------------
+-- caller sets location
+dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
+dsValBinds (XValBindsLR (NValBinds binds _)) body
+  = foldrM ds_val_bind body binds
+dsValBinds (ValBinds {})       _    = panic "dsValBinds ValBindsIn"
+
+-------------------------
+dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
+dsIPBinds (IPBinds ev_binds ip_binds) body
+  = do  { ds_binds <- dsTcEvBinds ev_binds
+        ; let inner = mkCoreLets ds_binds body
+                -- The dict bindings may not be in
+                -- dependency order; hence Rec
+        ; foldrM ds_ip_bind inner ip_binds }
+  where
+    ds_ip_bind (dL->L _ (IPBind _ ~(Right n) e)) body
+      = do e' <- dsLExpr e
+           return (Let (NonRec n e') body)
+    ds_ip_bind _ _ = panic "dsIPBinds"
+dsIPBinds (XHsIPBinds _) _ = panic "dsIPBinds"
+
+-------------------------
+-- caller sets location
+ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
+-- Special case for bindings which bind unlifted variables
+-- We need to do a case right away, rather than building
+-- a tuple and doing selections.
+-- Silently ignore INLINE and SPECIALISE pragmas...
+ds_val_bind (NonRecursive, hsbinds) body
+  | [dL->L loc bind] <- bagToList hsbinds
+        -- Non-recursive, non-overloaded bindings only come in ones
+        -- ToDo: in some bizarre case it's conceivable that there
+        --       could be dict binds in the 'binds'.  (See the notes
+        --       below.  Then pattern-match would fail.  Urk.)
+  , isUnliftedHsBind bind
+  = putSrcSpanDs loc $
+     -- see Note [Strict binds checks] in DsBinds
+    if is_polymorphic bind
+    then errDsCoreExpr (poly_bind_err bind)
+            -- data Ptr a = Ptr Addr#
+            -- f x = let p@(Ptr y) = ... in ...
+            -- Here the binding for 'p' is polymorphic, but does
+            -- not mix with an unlifted binding for 'y'.  You should
+            -- use a bang pattern.  Trac #6078.
+
+    else do { when (looksLazyPatBind bind) $
+              warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)
+        -- Complain about a binding that looks lazy
+        --    e.g.    let I# y = x in ...
+        -- Remember, in checkStrictBinds we are going to do strict
+        -- matching, so (for software engineering reasons) we insist
+        -- that the strictness is manifest on each binding
+        -- However, lone (unboxed) variables are ok
+
+
+            ; dsUnliftedBind bind body }
+  where
+    is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })
+                     = not (null tvs && null evs)
+    is_polymorphic _ = False
+
+    unlifted_must_be_bang bind
+      = hang (text "Pattern bindings containing unlifted types should use" $$
+              text "an outermost bang pattern:")
+           2 (ppr bind)
+
+    poly_bind_err bind
+      = hang (text "You can't mix polymorphic and unlifted bindings:")
+           2 (ppr bind) $$
+        text "Probable fix: add a type signature"
+
+ds_val_bind (is_rec, binds) _body
+  | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in DsBinds
+  = ASSERT( isRec is_rec )
+    errDsCoreExpr $
+    hang (text "Recursive bindings for unlifted types aren't allowed:")
+       2 (vcat (map ppr (bagToList binds)))
+
+-- Ordinary case for bindings; none should be unlifted
+ds_val_bind (is_rec, binds) body
+  = do  { MASSERT( isRec is_rec || isSingletonBag binds )
+               -- we should never produce a non-recursive list of multiple binds
+
+        ; (force_vars,prs) <- dsLHsBinds binds
+        ; let body' = foldr seqVar body force_vars
+        ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )
+          case prs of
+            [] -> return body
+            _  -> return (Let (Rec prs) body') }
+        -- Use a Rec regardless of is_rec.
+        -- Why? Because it allows the binds to be all
+        -- mixed up, which is what happens in one rare case
+        -- Namely, for an AbsBind with no tyvars and no dicts,
+        --         but which does have dictionary bindings.
+        -- See notes with TcSimplify.inferLoop [NO TYVARS]
+        -- It turned out that wrapping a Rec here was the easiest solution
+        --
+        -- NB The previous case dealt with unlifted bindings, so we
+        --    only have to deal with lifted ones now; so Rec is ok
+
+------------------
+dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
+dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
+               , abs_exports = exports
+               , abs_ev_binds = ev_binds
+               , abs_binds = lbinds }) body
+  = do { let body1 = foldr bind_export body exports
+             bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
+       ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
+                            body1 lbinds
+       ; ds_binds <- dsTcEvBinds_s ev_binds
+       ; return (mkCoreLets ds_binds body2) }
+
+dsUnliftedBind (FunBind { fun_id = (dL->L l fun)
+                        , fun_matches = matches
+                        , fun_co_fn = co_fn
+                        , fun_tick = tick }) body
+               -- Can't be a bang pattern (that looks like a PatBind)
+               -- so must be simply unboxed
+  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (cL l $ idName fun))
+                                     Nothing matches
+       ; MASSERT( null args ) -- Functions aren't lifted
+       ; MASSERT( isIdHsWrapper co_fn )
+       ; let rhs' = mkOptTickBox tick rhs
+       ; return (bindNonRec fun rhs' body) }
+
+dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
+                        , pat_ext = NPatBindTc _ ty }) body
+  =     -- let C x# y# = rhs in body
+        -- ==> case rhs of C x# y# -> body
+    do { rhs <- dsGuarded grhss ty
+       ; checkGuardMatches PatBindGuards grhss
+       ; let upat = unLoc pat
+             eqn = EqnInfo { eqn_pats = [upat],
+                             eqn_orig = FromSource,
+                             eqn_rhs = cantFailMatchResult body }
+       ; var    <- selectMatchVar upat
+       ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
+       ; return (bindNonRec var rhs result) }
+
+dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
+*                                                                      *
+************************************************************************
+-}
+
+dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
+
+dsLExpr (dL->L loc e)
+  = putSrcSpanDs loc $
+    do { core_expr <- dsExpr e
+   -- uncomment this check to test the hsExprType function in TcHsSyn
+   --    ; MASSERT2( exprType core_expr `eqType` hsExprType e
+   --              , ppr e <+> dcolon <+> ppr (hsExprType e) $$
+   --                ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )
+       ; return core_expr }
+
+-- | Variant of 'dsLExpr' that ensures that the result is not levity
+-- polymorphic. This should be used when the resulting expression will
+-- be an argument to some other function.
+-- See Note [Levity polymorphism checking] in DsMonad
+-- See Note [Levity polymorphism invariants] in CoreSyn
+dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
+dsLExprNoLP (dL->L loc e)
+  = putSrcSpanDs loc $
+    do { e' <- dsExpr e
+       ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)
+       ; return e' }
+
+dsExpr :: HsExpr GhcTc -> DsM CoreExpr
+dsExpr = ds_expr False
+
+ds_expr :: Bool   -- are we directly inside an HsWrap?
+                  -- See Wrinkle in Note [Detecting forced eta expansion]
+        -> HsExpr GhcTc -> DsM CoreExpr
+ds_expr _ (HsPar _ e)            = dsLExpr e
+ds_expr _ (ExprWithTySig _ e _)  = dsLExpr e
+ds_expr w (HsVar _ (dL->L _ var)) = dsHsVar w var
+ds_expr _ (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
+ds_expr w (HsConLikeOut _ con)   = dsConLike w con
+ds_expr _ (HsIPVar {})           = panic "dsExpr: HsIPVar"
+ds_expr _ (HsOverLabel{})        = panic "dsExpr: HsOverLabel"
+
+ds_expr _ (HsLit _ lit)
+  = do { warnAboutOverflowedLit lit
+       ; dsLit (convertLit lit) }
+
+ds_expr _ (HsOverLit _ lit)
+  = do { warnAboutOverflowedOverLit lit
+       ; dsOverLit lit }
+
+ds_expr _ (HsWrap _ co_fn e)
+  = do { e' <- ds_expr True e    -- This is the one place where we recurse to
+                                 -- ds_expr (passing True), rather than dsExpr
+       ; wrap' <- dsHsWrapper co_fn
+       ; dflags <- getDynFlags
+       ; let wrapped_e = wrap' e'
+             wrapped_ty = exprType wrapped_e
+       ; checkForcedEtaExpansion e wrapped_ty -- See Note [Detecting forced eta expansion]
+       ; warnAboutIdentities dflags e' wrapped_ty
+       ; return wrapped_e }
+
+ds_expr _ (NegApp _ (dL->L loc
+                      (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
+                  neg_expr)
+  = do { expr' <- putSrcSpanDs loc $ do
+          { warnAboutOverflowedOverLit
+              (lit { ol_val = HsIntegral (negateIntegralLit i) })
+          ; dsOverLit lit }
+       ; dsSyntaxExpr neg_expr [expr'] }
+
+ds_expr _ (NegApp _ expr neg_expr)
+  = do { expr' <- dsLExpr expr
+       ; dsSyntaxExpr neg_expr [expr'] }
+
+ds_expr _ (HsLam _ a_Match)
+  = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
+
+ds_expr _ (HsLamCase _ matches)
+  = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
+       ; return $ Lam discrim_var matching_code }
+
+ds_expr _ e@(HsApp _ fun arg)
+  = do { fun' <- dsLExpr fun
+       ; dsWhenNoErrs (dsLExprNoLP arg)
+                      (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }
+
+ds_expr _ (HsAppType _ e _)
+    -- ignore type arguments here; they're in the wrappers instead at this point
+  = dsLExpr e
+
+{-
+Note [Desugaring vars]
+~~~~~~~~~~~~~~~~~~~~~~
+In one situation we can get a *coercion* variable in a HsVar, namely
+the support method for an equality superclass:
+   class (a~b) => C a b where ...
+   instance (blah) => C (T a) (T b) where ..
+Then we get
+   $dfCT :: forall ab. blah => C (T a) (T b)
+   $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)
+
+   $c$p1C :: forall ab. blah => (T a ~ T b)
+   $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g
+
+That 'g' in the 'in' part is an evidence variable, and when
+converting to core it must become a CO.
+
+Operator sections.  At first it looks as if we can convert
+\begin{verbatim}
+        (expr op)
+\end{verbatim}
+to
+\begin{verbatim}
+        \x -> op expr x
+\end{verbatim}
+
+But no!  expr might be a redex, and we can lose laziness badly this
+way.  Consider
+\begin{verbatim}
+        map (expr op) xs
+\end{verbatim}
+for example.  So we convert instead to
+\begin{verbatim}
+        let y = expr in \x -> op y x
+\end{verbatim}
+If \tr{expr} is actually just a variable, say, then the simplifier
+will sort it out.
+-}
+
+ds_expr _ e@(OpApp _ e1 op e2)
+  = -- for the type of y, we need the type of op's 2nd argument
+    do { op' <- dsLExpr op
+       ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])
+                      (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }
+
+ds_expr _ (SectionL _ expr op)       -- Desugar (e !) to ((!) e)
+  = do { op' <- dsLExpr op
+       ; dsWhenNoErrs (dsLExprNoLP expr)
+                      (\expr' -> mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr') }
+
+-- dsLExpr (SectionR op expr)   -- \ x -> op x expr
+ds_expr _ e@(SectionR _ op expr) = do
+    core_op <- dsLExpr op
+    -- for the type of x, we need the type of op's 2nd argument
+    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)
+        -- See comment with SectionL
+    y_core <- dsLExpr expr
+    dsWhenNoErrs (mapM newSysLocalDsNoLP [x_ty, y_ty])
+                 (\[x_id, y_id] -> bindNonRec y_id y_core $
+                                   Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)
+                                                          core_op [Var x_id, Var y_id]))
+
+ds_expr _ (ExplicitTuple _ tup_args boxity)
+  = do { let go (lam_vars, args) (dL->L _ (Missing ty))
+                    -- For every missing expression, we need
+                    -- another lambda in the desugaring.
+               = do { lam_var <- newSysLocalDsNoLP ty
+                    ; return (lam_var : lam_vars, Var lam_var : args) }
+             go (lam_vars, args) (dL->L _ (Present _ expr))
+                    -- Expressions that are present don't generate
+                    -- lambdas, just arguments.
+               = do { core_expr <- dsLExprNoLP expr
+                    ; return (lam_vars, core_expr : args) }
+             go _ _ = panic "ds_expr"
+
+       ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))
+                -- The reverse is because foldM goes left-to-right
+                      (\(lam_vars, args) -> mkCoreLams lam_vars $
+                                            mkCoreTupBoxity boxity args) }
+
+ds_expr _ (ExplicitSum types alt arity expr)
+  = do { dsWhenNoErrs (dsLExprNoLP expr)
+                      (\core_expr -> mkCoreConApps (sumDataCon alt arity)
+                                     (map (Type . getRuntimeRep) types ++
+                                      map Type types ++
+                                      [core_expr]) ) }
+
+ds_expr _ (HsSCC _ _ cc expr@(dL->L loc _)) = do
+    dflags <- getDynFlags
+    if gopt Opt_SccProfilingOn dflags
+      then do
+        mod_name <- getModule
+        count <- goptM Opt_ProfCountEntries
+        let nm = sl_fs cc
+        flavour <- ExprCC <$> getCCIndexM nm
+        Tick (ProfNote (mkUserCC nm mod_name loc flavour) count True)
+               <$> dsLExpr expr
+      else dsLExpr expr
+
+ds_expr _ (HsCoreAnn _ _ _ expr)
+  = dsLExpr expr
+
+ds_expr _ (HsCase _ discrim matches)
+  = do { core_discrim <- dsLExpr discrim
+       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
+       ; return (bindNonRec discrim_var core_discrim matching_code) }
+
+-- Pepe: The binds are in scope in the body but NOT in the binding group
+--       This is to avoid silliness in breakpoints
+ds_expr _ (HsLet _ binds body) = do
+    body' <- dsLExpr body
+    dsLocalBinds binds body'
+
+-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
+-- because the interpretation of `stmts' depends on what sort of thing it is.
+--
+ds_expr _ (HsDo res_ty ListComp (dL->L _ stmts)) = dsListComp stmts res_ty
+ds_expr _ (HsDo _ DoExpr        (dL->L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ GhciStmtCtxt  (dL->L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MDoExpr       (dL->L _ stmts)) = dsDo stmts
+ds_expr _ (HsDo _ MonadComp     (dL->L _ stmts)) = dsMonadComp stmts
+
+ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr)
+  = do { pred <- dsLExpr guard_expr
+       ; b1 <- dsLExpr then_expr
+       ; b2 <- dsLExpr else_expr
+       ; case mb_fun of
+           Just fun -> dsSyntaxExpr fun [pred, b1, b2]
+           Nothing  -> return $ mkIfThenElse pred b1 b2 }
+
+ds_expr _ (HsMultiIf res_ty alts)
+  | null alts
+  = mkErrorExpr
+
+  | otherwise
+  = do { match_result <- liftM (foldr1 combineMatchResults)
+                               (mapM (dsGRHS IfAlt res_ty) alts)
+       ; checkGuardMatches IfAlt (GRHSs noExt alts (noLoc emptyLocalBinds))
+       ; error_expr   <- mkErrorExpr
+       ; extractMatchResult match_result error_expr }
+  where
+    mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
+                               (text "multi-way if")
+
+{-
+\noindent
+\underline{\bf Various data construction things}
+             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-}
+
+ds_expr _ (ExplicitList elt_ty wit xs)
+  = dsExplicitList elt_ty wit xs
+
+ds_expr _ (ArithSeq expr witness seq)
+  = case witness of
+     Nothing -> dsArithSeq expr seq
+     Just fl -> do { newArithSeq <- dsArithSeq expr seq
+                   ; dsSyntaxExpr fl [newArithSeq] }
+
+{-
+Static Pointers
+~~~~~~~~~~~~~~~
+
+See Note [Grand plan for static forms] in StaticPtrTable for an overview.
+
+    g = ... static f ...
+==>
+    g = ... makeStatic loc f ...
+-}
+
+ds_expr _ (HsStatic _ expr@(dL->L loc _)) = do
+    expr_ds <- dsLExprNoLP expr
+    let ty = exprType expr_ds
+    makeStaticId <- dsLookupGlobalId makeStaticName
+
+    dflags <- getDynFlags
+    let (line, col) = case loc of
+           RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r
+                            , srcLocCol  $ realSrcSpanStart r
+                            )
+           _             -> (0, 0)
+        srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
+                     [ Type intTy              , Type intTy
+                     , mkIntExprInt dflags line, mkIntExprInt dflags col
+                     ]
+
+    putSrcSpanDs loc $ return $
+      mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]
+
+{-
+\noindent
+\underline{\bf Record construction and update}
+             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For record construction we do this (assuming T has three arguments)
+\begin{verbatim}
+        T { op2 = e }
+==>
+        let err = /\a -> recConErr a
+        T (recConErr t1 "M.hs/230/op1")
+          e
+          (recConErr t1 "M.hs/230/op3")
+\end{verbatim}
+@recConErr@ then converts its argument string into a proper message
+before printing it as
+\begin{verbatim}
+        M.hs, line 230: missing field op1 was evaluated
+\end{verbatim}
+
+We also handle @C{}@ as valid construction syntax for an unlabelled
+constructor @C@, setting all of @C@'s fields to bottom.
+-}
+
+ds_expr _ (RecordCon { rcon_flds = rbinds
+                     , rcon_ext = RecordConTc { rcon_con_expr = con_expr
+                                              , rcon_con_like = con_like }})
+  = do { con_expr' <- dsExpr con_expr
+       ; let
+             (arg_tys, _) = tcSplitFunTys (exprType con_expr')
+             -- A newtype in the corner should be opaque;
+             -- hence TcType.tcSplitFunTys
+
+             mk_arg (arg_ty, fl)
+               = case findField (rec_flds rbinds) (flSelector fl) of
+                   (rhs:rhss) -> ASSERT( null rhss )
+                                 dsLExprNoLP rhs
+                   []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
+             unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
+
+             labels = conLikeFieldLabels con_like
+
+       ; con_args <- if null labels
+                     then mapM unlabelled_bottom arg_tys
+                     else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)
+
+       ; return (mkCoreApps con_expr' con_args) }
+
+{-
+Record update is a little harder. Suppose we have the decl:
+\begin{verbatim}
+        data T = T1 {op1, op2, op3 :: Int}
+               | T2 {op4, op2 :: Int}
+               | T3
+\end{verbatim}
+Then we translate as follows:
+\begin{verbatim}
+        r { op2 = e }
+===>
+        let op2 = e in
+        case r of
+          T1 op1 _ op3 -> T1 op1 op2 op3
+          T2 op4 _     -> T2 op4 op2
+          other        -> recUpdError "M.hs/230"
+\end{verbatim}
+It's important that we use the constructor Ids for @T1@, @T2@ etc on the
+RHSs, and do not generate a Core constructor application directly, because the constructor
+might do some argument-evaluation first; and may have to throw away some
+dictionaries.
+
+Note [Update for GADTs]
+~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   data T a b where
+     T1 :: { f1 :: a } -> T a Int
+
+Then the wrapper function for T1 has type
+   $WT1 :: a -> T a Int
+But if x::T a b, then
+   x { f1 = v } :: T a b   (not T a Int!)
+So we need to cast (T a Int) to (T a b).  Sigh.
+
+-}
+
+ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
+                          , rupd_ext = RecordUpdTc
+                              { rupd_cons = cons_to_upd
+                              , rupd_in_tys = in_inst_tys
+                              , rupd_out_tys = out_inst_tys
+                              , rupd_wrap = dict_req_wrap }} )
+  | null fields
+  = dsLExpr record_expr
+  | otherwise
+  = ASSERT2( notNull cons_to_upd, ppr expr )
+
+    do  { record_expr' <- dsLExpr record_expr
+        ; field_binds' <- mapM ds_field fields
+        ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
+              upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
+
+        -- It's important to generate the match with matchWrapper,
+        -- and the right hand sides with applications of the wrapper Id
+        -- so that everything works when we are doing fancy unboxing on the
+        -- constructor arguments.
+        ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
+        ; ([discrim_var], matching_code)
+                <- matchWrapper RecUpd Nothing
+                                      (MG { mg_alts = noLoc alts
+                                          , mg_ext = MatchGroupTc [in_ty] out_ty
+                                          , mg_origin = FromSource })
+                                     -- FromSource is not strictly right, but we
+                                     -- want incomplete pattern-match warnings
+
+        ; return (add_field_binds field_binds' $
+                  bindNonRec discrim_var record_expr' matching_code) }
+  where
+    ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)
+      -- Clone the Id in the HsRecField, because its Name is that
+      -- of the record selector, and we must not make that a local binder
+      -- else we shadow other uses of the record selector
+      -- Hence 'lcl_id'.  Cf Trac #2735
+    ds_field (dL->L _ rec_field)
+      = do { rhs <- dsLExpr (hsRecFieldArg rec_field)
+           ; let fld_id = unLoc (hsRecUpdFieldId rec_field)
+           ; lcl_id <- newSysLocalDs (idType fld_id)
+           ; return (idName fld_id, lcl_id, rhs) }
+
+    add_field_binds [] expr = expr
+    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
+
+        -- Awkwardly, for families, the match goes
+        -- from instance type to family type
+    (in_ty, out_ty) =
+      case (head cons_to_upd) of
+        RealDataCon data_con ->
+          let tycon = dataConTyCon data_con in
+          (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys)
+        PatSynCon pat_syn ->
+          ( patSynInstResTy pat_syn in_inst_tys
+          , patSynInstResTy pat_syn out_inst_tys)
+    mk_alt upd_fld_env con
+      = do { let (univ_tvs, ex_tvs, eq_spec,
+                  prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
+                 user_tvs =
+                   case con of
+                     RealDataCon data_con -> dataConUserTyVars data_con
+                     PatSynCon _          -> univ_tvs ++ ex_tvs
+                       -- The order here is because of the order in `TcPatSyn`.
+                 in_subst  = zipTvSubst univ_tvs in_inst_tys
+                 out_subst = zipTvSubst univ_tvs out_inst_tys
+
+                -- I'm not bothering to clone the ex_tvs
+           ; eqs_vars   <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec))
+           ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta)
+           ; arg_ids    <- newSysLocalsDs (substTysUnchecked in_subst arg_tys)
+           ; let field_labels = conLikeFieldLabels con
+                 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
+                                         field_labels arg_ids
+                 mk_val_arg fl pat_arg_id
+                     = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
+
+                 inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExt con)
+                        -- Reconstruct with the WrapId so that unpacking happens
+                 wrap = mkWpEvVarApps theta_vars                                <.>
+                        dict_req_wrap                                           <.>
+                        mkWpTyApps    [ lookupTyVar out_subst tv
+                                          `orElse` mkTyVarTy tv
+                                      | tv <- user_tvs
+                                      , not (tv `elemVarEnv` wrap_subst) ]
+                          -- Be sure to use user_tvs (which may be ordered
+                          -- differently than `univ_tvs ++ ex_tvs) above.
+                          -- See Note [DataCon user type variable binders]
+                          -- in DataCon.
+                 rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args
+
+                        -- Tediously wrap the application in a cast
+                        -- Note [Update for GADTs]
+                 wrapped_rhs =
+                  case con of
+                    RealDataCon data_con ->
+                      let
+                        wrap_co =
+                          mkTcTyConAppCo Nominal
+                            (dataConTyCon data_con)
+                            [ lookup tv ty
+                              | (tv,ty) <- univ_tvs `zip` out_inst_tys ]
+                        lookup univ_tv ty =
+                          case lookupVarEnv wrap_subst univ_tv of
+                            Just co' -> co'
+                            Nothing  -> mkTcReflCo Nominal ty
+                        in if null eq_spec
+                             then rhs
+                             else mkLHsWrap (mkWpCastN wrap_co) rhs
+                    -- eq_spec is always null for a PatSynCon
+                    PatSynCon _ -> rhs
+
+                 wrap_subst =
+                  mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))
+                           | (spec, eq_var) <- eq_spec `zip` eqs_vars
+                           , let tv = eqSpecTyVar spec ]
+
+                 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
+
+                 pat = noLoc $ ConPatOut { pat_con = noLoc con
+                                         , pat_tvs = ex_tvs
+                                         , pat_dicts = eqs_vars ++ theta_vars
+                                         , pat_binds = emptyTcEvBinds
+                                         , pat_args = PrefixCon $ map nlVarPat arg_ids
+                                         , pat_arg_tys = in_inst_tys
+                                         , pat_wrap = req_wrap }
+           ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
+
+-- Here is where we desugar the Template Haskell brackets and escapes
+
+-- Template Haskell stuff
+
+ds_expr _ (HsRnBracketOut _ _ _)  = panic "dsExpr HsRnBracketOut"
+ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps
+ds_expr _ (HsSpliceE _ s)         = pprPanic "dsExpr:splice" (ppr s)
+
+-- Arrow notation extension
+ds_expr _ (HsProc _ pat cmd) = dsProcExpr pat cmd
+
+-- Hpc Support
+
+ds_expr _ (HsTick _ tickish e) = do
+  e' <- dsLExpr e
+  return (Tick tickish e')
+
+-- There is a problem here. The then and else branches
+-- have no free variables, so they are open to lifting.
+-- We need someway of stopping this.
+-- This will make no difference to binary coverage
+-- (did you go here: YES or NO), but will effect accurate
+-- tick counting.
+
+ds_expr _ (HsBinTick _ ixT ixF e) = do
+  e2 <- dsLExpr e
+  do { ASSERT(exprType e2 `eqType` boolTy)
+       mkBinaryTickBox ixT ixF e2
+     }
+
+ds_expr _ (HsTickPragma _ _ _ _ expr) = do
+  dflags <- getDynFlags
+  if gopt Opt_Hpc dflags
+    then panic "dsExpr:HsTickPragma"
+    else dsLExpr expr
+
+-- HsSyn constructs that just shouldn't be here:
+ds_expr _ (HsBracket     {})  = panic "dsExpr:HsBracket"
+ds_expr _ (HsArrApp      {})  = panic "dsExpr:HsArrApp"
+ds_expr _ (HsArrForm     {})  = panic "dsExpr:HsArrForm"
+ds_expr _ (EWildPat      {})  = panic "dsExpr:EWildPat"
+ds_expr _ (EAsPat        {})  = panic "dsExpr:EAsPat"
+ds_expr _ (EViewPat      {})  = panic "dsExpr:EViewPat"
+ds_expr _ (ELazyPat      {})  = panic "dsExpr:ELazyPat"
+ds_expr _ (HsDo          {})  = panic "dsExpr:HsDo"
+ds_expr _ (HsRecFld      {})  = panic "dsExpr:HsRecFld"
+ds_expr _ (XExpr         {})  = panic "dsExpr: XExpr"
+
+
+------------------------------
+dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
+dsSyntaxExpr (SyntaxExpr { syn_expr      = expr
+                         , syn_arg_wraps = arg_wraps
+                         , syn_res_wrap  = res_wrap })
+             arg_exprs
+  = do { fun            <- dsExpr expr
+       ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
+       ; core_res_wrap  <- dsHsWrapper res_wrap
+       ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs
+       ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])
+                      (\_ -> core_res_wrap (mkApps fun wrapped_args)) }
+  where
+    mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)
+
+findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
+findField rbinds sel
+  = [hsRecFieldArg fld | (dL->L _ fld) <- rbinds
+                       , sel == idName (unLoc $ hsRecFieldId fld) ]
+
+{-
+%--------------------------------------------------------------------
+
+Note [Desugaring explicit lists]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Explicit lists are desugared in a cleverer way to prevent some
+fruitless allocations.  Essentially, whenever we see a list literal
+[x_1, ..., x_n] we generate the corresponding expression in terms of
+build:
+
+Explicit lists (literals) are desugared to allow build/foldr fusion when
+beneficial. This is a bit of a trade-off,
+
+ * build/foldr fusion can generate far larger code than the corresponding
+   cons-chain (e.g. see #11707)
+
+ * even when it doesn't produce more code, build can still fail to fuse,
+   requiring that the simplifier do more work to bring the expression
+   back into cons-chain form; this costs compile time
+
+ * when it works, fusion can be a significant win. Allocations are reduced
+   by up to 25% in some nofib programs. Specifically,
+
+        Program           Size    Allocs   Runtime  CompTime
+        rewrite          +0.0%    -26.3%      0.02     -1.8%
+           ansi          -0.3%    -13.8%      0.00     +0.0%
+           lift          +0.0%     -8.7%      0.00     -2.3%
+
+At the moment we use a simple heuristic to determine whether build will be
+fruitful: for small lists we assume the benefits of fusion will be worthwhile;
+for long lists we assume that the benefits will be outweighted by the cost of
+code duplication. This magic length threshold is @maxBuildLength@. Also, fusion
+won't work at all if rewrite rules are disabled, so we don't use the build-based
+desugaring in this case.
+
+We used to have a more complex heuristic which would try to break the list into
+"static" and "dynamic" parts and only build-desugar the dynamic part.
+Unfortunately, determining "static-ness" reliably is a bit tricky and the
+heuristic at times produced surprising behavior (see #11710) so it was dropped.
+-}
+
+{- | The longest list length which we will desugar using @build@.
+
+This is essentially a magic number and its setting is unfortunate rather
+arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists],
+is to avoid deforesting large static data into large(r) code. Ideally we'd
+want a smaller threshold with larger consumers and vice-versa, but we have no
+way of knowing what will be consuming our list in the desugaring impossible to
+set generally correctly.
+
+The effect of reducing this number will be that 'build' fusion is applied
+less often. From a runtime performance perspective, applying 'build' more
+liberally on "moderately" sized lists should rarely hurt and will often it can
+only expose further optimization opportunities; if no fusion is possible it will
+eventually get rule-rewritten back to a list). We do, however, pay in compile
+time.
+-}
+maxBuildLength :: Int
+maxBuildLength = 32
+
+dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc]
+               -> DsM CoreExpr
+-- See Note [Desugaring explicit lists]
+dsExplicitList elt_ty Nothing xs
+  = do { dflags <- getDynFlags
+       ; xs' <- mapM dsLExprNoLP xs
+       ; if xs' `lengthExceeds` maxBuildLength
+                -- Don't generate builds if the list is very long.
+         || null xs'
+                -- Don't generate builds when the [] constructor will do
+         || not (gopt Opt_EnableRewriteRules dflags)  -- Rewrite rules off
+                -- Don't generate a build if there are no rules to eliminate it!
+                -- See Note [Desugaring RULE left hand sides] in Desugar
+         then return $ mkListExpr elt_ty xs'
+         else mkBuildExpr elt_ty (mk_build_list xs') }
+  where
+    mk_build_list xs' (cons, _) (nil, _)
+      = return (foldr (App . App (Var cons)) (Var nil) xs')
+
+dsExplicitList elt_ty (Just fln) xs
+  = do { list <- dsExplicitList elt_ty Nothing xs
+       ; dflags <- getDynFlags
+       ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] }
+
+dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr
+dsArithSeq expr (From from)
+  = App <$> dsExpr expr <*> dsLExprNoLP from
+dsArithSeq expr (FromTo from to)
+  = do dflags <- getDynFlags
+       warnAboutEmptyEnumerations dflags from Nothing to
+       expr' <- dsExpr expr
+       from' <- dsLExprNoLP from
+       to'   <- dsLExprNoLP to
+       return $ mkApps expr' [from', to']
+dsArithSeq expr (FromThen from thn)
+  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn]
+dsArithSeq expr (FromThenTo from thn to)
+  = do dflags <- getDynFlags
+       warnAboutEmptyEnumerations dflags from (Just thn) to
+       expr' <- dsExpr expr
+       from' <- dsLExprNoLP from
+       thn'  <- dsLExprNoLP thn
+       to'   <- dsLExprNoLP to
+       return $ mkApps expr' [from', thn', to']
+
+{-
+Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
+handled in DsListComp).  Basically does the translation given in the
+Haskell 98 report:
+-}
+
+dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr
+dsDo stmts
+  = goL stmts
+  where
+    goL [] = panic "dsDo"
+    goL ((dL->L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)
+
+    go _ (LastStmt _ body _ _) stmts
+      = ASSERT( null stmts ) dsLExpr body
+        -- The 'return' op isn't used for 'do' expressions
+
+    go _ (BodyStmt _ rhs then_expr _) stmts
+      = do { rhs2 <- dsLExpr rhs
+           ; warnDiscardedDoBindings rhs (exprType rhs2)
+           ; rest <- goL stmts
+           ; dsSyntaxExpr then_expr [rhs2, rest] }
+
+    go _ (LetStmt _ binds) stmts
+      = do { rest <- goL stmts
+           ; dsLocalBinds binds rest }
+
+    go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts
+      = do  { body     <- goL stmts
+            ; rhs'     <- dsLExpr rhs
+            ; var   <- selectSimpleMatchVarL pat
+            ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
+                                      res1_ty (cantFailMatchResult body)
+            ; match_code <- handle_failure pat match fail_op
+            ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
+
+    go _ (ApplicativeStmt body_ty args mb_join) stmts
+      = do {
+             let
+               (pats, rhss) = unzip (map (do_arg . snd) args)
+
+               do_arg (ApplicativeArgOne _ pat expr _) =
+                 (pat, dsLExpr expr)
+               do_arg (ApplicativeArgMany _ stmts ret pat) =
+                 (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
+               do_arg (XApplicativeArg _) = panic "dsDo"
+
+               arg_tys = map hsLPatType pats
+
+           ; rhss' <- sequence rhss
+
+           ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts)
+
+           ; let fun = cL noSrcSpan $ HsLam noExt $
+                   MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats
+                                                       body']
+                      , mg_ext = MatchGroupTc arg_tys body_ty
+                      , mg_origin = Generated }
+
+           ; fun' <- dsLExpr fun
+           ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
+           ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
+           ; case mb_join of
+               Nothing -> return expr
+               Just join_op -> dsSyntaxExpr join_op [expr] }
+
+    go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
+                    , recS_rec_ids = rec_ids, recS_ret_fn = return_op
+                    , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
+                    , recS_ext = RecStmtTc
+                        { recS_bind_ty = bind_ty
+                        , recS_rec_rets = rec_rets
+                        , recS_ret_ty = body_ty} }) stmts
+      = goL (new_bind_stmt : stmts)  -- rec_ids can be empty; eg  rec { print 'x' }
+      where
+        new_bind_stmt = cL loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)
+                                         mfix_app bind_op
+                                         noSyntaxExpr  -- Tuple cannot fail
+
+        tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
+        tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
+        rec_tup_pats = map nlVarPat tup_ids
+        later_pats   = rec_tup_pats
+        rets         = map noLoc rec_rets
+        mfix_app     = nlHsSyntaxApps mfix_op [mfix_arg]
+        mfix_arg     = noLoc $ HsLam noExt
+                           (MG { mg_alts = noLoc [mkSimpleMatch
+                                                    LambdaExpr
+                                                    [mfix_pat] body]
+                               , mg_ext = MatchGroupTc [tup_ty] body_ty
+                               , mg_origin = Generated })
+        mfix_pat     = noLoc $ LazyPat noExt $ mkBigLHsPatTupId rec_tup_pats
+        body         = noLoc $ HsDo body_ty
+                                DoExpr (noLoc (rec_stmts ++ [ret_stmt]))
+        ret_app      = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
+        ret_stmt     = noLoc $ mkLastStmt ret_app
+                     -- This LastStmt will be desugared with dsDo,
+                     -- which ignores the return_op in the LastStmt,
+                     -- so we must apply the return_op explicitly
+
+    go _ (ParStmt   {}) _ = panic "dsDo ParStmt"
+    go _ (TransStmt {}) _ = panic "dsDo TransStmt"
+    go _ (XStmtLR   {}) _ = panic "dsDo XStmtLR"
+
+handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
+    -- In a do expression, pattern-match failure just calls
+    -- the monadic 'fail' rather than throwing an exception
+handle_failure pat match fail_op
+  | matchCanFail match
+  = do { dflags <- getDynFlags
+       ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
+       ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
+       ; extractMatchResult match fail_expr }
+  | otherwise
+  = extractMatchResult match (error "It can't fail")
+
+mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String
+mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++
+                         showPpr dflags (getLoc pat)
+
+{-
+************************************************************************
+*                                                                      *
+   Desugaring Variables
+*                                                                      *
+************************************************************************
+-}
+
+dsHsVar :: Bool  -- are we directly inside an HsWrap?
+                 -- See Wrinkle in Note [Detecting forced eta expansion]
+        -> Id -> DsM CoreExpr
+dsHsVar w var
+  | not w
+  , let bad_tys = badUseOfLevPolyPrimop var ty
+  , not (null bad_tys)
+  = do { levPolyPrimopErr var ty bad_tys
+       ; return unitExpr }  -- return something eminently safe
+
+  | otherwise
+  = return (varToCoreExpr var)   -- See Note [Desugaring vars]
+
+  where
+    ty = idType var
+
+dsConLike :: Bool  -- as in dsHsVar
+          -> ConLike -> DsM CoreExpr
+dsConLike w (RealDataCon dc) = dsHsVar w (dataConWrapId dc)
+dsConLike _ (PatSynCon ps)   = return $ case patSynBuilder ps of
+  Just (id, add_void)
+    | add_void  -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId)
+    | otherwise -> Var id
+  _ -> pprPanic "dsConLike" (ppr ps)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Errors and contexts}
+*                                                                      *
+************************************************************************
+-}
+
+-- Warn about certain types of values discarded in monadic bindings (#3263)
+warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
+warnDiscardedDoBindings rhs rhs_ty
+  | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
+  = do { warn_unused <- woptM Opt_WarnUnusedDoBind
+       ; warn_wrong <- woptM Opt_WarnWrongDoBind
+       ; when (warn_unused || warn_wrong) $
+    do { fam_inst_envs <- dsGetFamInstEnvs
+       ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
+
+           -- Warn about discarding non-() things in 'monadic' binding
+       ; if warn_unused && not (isUnitTy norm_elt_ty)
+         then warnDs (Reason Opt_WarnUnusedDoBind)
+                     (badMonadBind rhs elt_ty)
+         else
+
+           -- Warn about discarding m a things in 'monadic' binding of the same type,
+           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
+           when warn_wrong $
+                do { case tcSplitAppTy_maybe norm_elt_ty of
+                         Just (elt_m_ty, _)
+                            | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
+                            -> warnDs (Reason Opt_WarnWrongDoBind)
+                                      (badMonadBind rhs elt_ty)
+                         _ -> return () } } }
+
+  | otherwise   -- RHS does have type of form (m ty), which is weird
+  = return ()   -- but at lesat this warning is irrelevant
+
+badMonadBind :: LHsExpr GhcTc -> Type -> SDoc
+badMonadBind rhs elt_ty
+  = vcat [ hang (text "A do-notation statement discarded a result of type")
+              2 (quotes (ppr elt_ty))
+         , hang (text "Suppress this warning by saying")
+              2 (quotes $ text "_ <-" <+> ppr rhs)
+         ]
+
+{-
+************************************************************************
+*                                                                      *
+   Forced eta expansion and levity polymorphism
+*                                                                      *
+************************************************************************
+
+Note [Detecting forced eta expansion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We cannot have levity polymorphic function arguments. See
+Note [Levity polymorphism invariants] in CoreSyn. But we *can* have
+functions that take levity polymorphism arguments, as long as these
+functions are eta-reduced. (See #12708 for an example.)
+
+However, we absolutely cannot do this for functions that have no
+binding (i.e., say True to Id.hasNoBinding), like primops and unboxed
+tuple constructors. These get eta-expanded in CorePrep.maybeSaturate.
+
+Detecting when this is about to happen is a bit tricky, though. When
+the desugarer is looking at the Id itself (let's be concrete and
+suppose we have (#,#)), we don't know whether it will be levity
+polymorphic. So the right spot seems to be to look after the Id has
+been applied to its type arguments. To make the algorithm efficient,
+it's important to be able to spot ((#,#) @a @b @c @d) without looking
+past all the type arguments. We thus require that
+  * The body of an HsWrap is not an HsWrap.
+With that representation invariant, we simply look inside every HsWrap
+to see if its body is an HsVar whose Id hasNoBinding. Then, we look
+at the wrapped type. If it has any levity polymorphic arguments, reject.
+
+Interestingly, this approach does not look to see whether the Id in
+question will be eta expanded. The logic is this:
+  * Either the Id in question is saturated or not.
+  * If it is, then it surely can't have levity polymorphic arguments.
+    If its wrapped type contains levity polymorphic arguments, reject.
+  * If it's not, then it can't be eta expanded with levity polymorphic
+    argument. If its wrapped type contains levity polymorphic arguments, reject.
+So, either way, we're good to reject.
+
+Wrinkle
+~~~~~~~
+Not all polymorphic Ids are wrapped in
+HsWrap, due to the lazy instantiation of TypeApplications. (See "Visible type
+application", ESOP '16.) But if we spot a levity-polymorphic hasNoBinding Id
+without a wrapper, then that is surely problem and we can reject.
+
+We thus have a parameter to `dsExpr` that tracks whether or not we are
+directly in an HsWrap. If we find a levity-polymorphic hasNoBinding Id when
+we're not directly in an HsWrap, reject.
+
+-}
+
+-- | Takes an expression and its instantiated type. If the expression is an
+-- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments,
+-- issue an error. See Note [Detecting forced eta expansion]
+checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM ()
+checkForcedEtaExpansion expr ty
+  | Just var <- case expr of
+                  HsVar _ (dL->L _ var)           -> Just var
+                  HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc)
+                  _                               -> Nothing
+  , let bad_tys = badUseOfLevPolyPrimop var ty
+  , not (null bad_tys)
+  = levPolyPrimopErr var ty bad_tys
+checkForcedEtaExpansion _ _ = return ()
+
+-- | Is this a hasNoBinding Id with a levity-polymorphic type?
+-- Returns the arguments that are levity polymorphic if they are bad;
+-- or an empty list otherwise
+-- See Note [Detecting forced eta expansion]
+badUseOfLevPolyPrimop :: Id -> Type -> [Type]
+badUseOfLevPolyPrimop id ty
+  | hasNoBinding id
+  = filter isTypeLevPoly arg_tys
+  | otherwise
+  = []
+  where
+    (binders, _) = splitPiTys ty
+    arg_tys      = mapMaybe binderRelevantType_maybe binders
+
+levPolyPrimopErr :: Id -> Type -> [Type] -> DsM ()
+levPolyPrimopErr primop ty bad_tys
+  = errDs $ vcat [ hang (text "Cannot use primitive with levity-polymorphic arguments:")
+                      2 (ppr primop <+> dcolon <+> pprWithTYPE ty)
+                 , hang (text "Levity-polymorphic arguments:")
+                      2 (vcat (map (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) bad_tys)) ]
diff --git a/compiler/deSugar/DsExpr.hs-boot b/compiler/deSugar/DsExpr.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsExpr.hs-boot
@@ -0,0 +1,10 @@
+module DsExpr where
+import HsSyn       ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr )
+import DsMonad     ( DsM )
+import CoreSyn     ( CoreExpr )
+import HsExtension ( GhcTc)
+
+dsExpr  :: HsExpr GhcTc -> DsM CoreExpr
+dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
+dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
+dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsForeign.hs
@@ -0,0 +1,820 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1998
+
+
+Desugaring foreign declarations (see also DsCCall).
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module DsForeign ( dsForeigns ) where
+
+#include "HsVersions.h"
+import GhcPrelude
+
+import TcRnMonad        -- temp
+
+import CoreSyn
+
+import DsCCall
+import DsMonad
+
+import HsSyn
+import DataCon
+import CoreUnfold
+import Id
+import Literal
+import Module
+import Name
+import Type
+import RepType
+import TyCon
+import Coercion
+import TcEnv
+import TcType
+
+import CmmExpr
+import CmmUtils
+import HscTypes
+import ForeignCall
+import TysWiredIn
+import TysPrim
+import PrelNames
+import BasicTypes
+import SrcLoc
+import Outputable
+import FastString
+import DynFlags
+import Platform
+import Config
+import OrdList
+import Pair
+import Util
+import Hooks
+import Encoding
+
+import Data.Maybe
+import Data.List
+
+{-
+Desugaring of @foreign@ declarations is naturally split up into
+parts, an @import@ and an @export@  part. A @foreign import@
+declaration
+\begin{verbatim}
+  foreign import cc nm f :: prim_args -> IO prim_res
+\end{verbatim}
+is the same as
+\begin{verbatim}
+  f :: prim_args -> IO prim_res
+  f a1 ... an = _ccall_ nm cc a1 ... an
+\end{verbatim}
+so we reuse the desugaring code in @DsCCall@ to deal with these.
+-}
+
+type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
+                              -- the occurrence analyser will sort it all out
+
+dsForeigns :: [LForeignDecl GhcTc]
+           -> DsM (ForeignStubs, OrdList Binding)
+dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)
+
+dsForeigns' :: [LForeignDecl GhcTc]
+            -> DsM (ForeignStubs, OrdList Binding)
+dsForeigns' []
+  = return (NoStubs, nilOL)
+dsForeigns' fos = do
+    fives <- mapM do_ldecl fos
+    let
+        (hs, cs, idss, bindss) = unzip4 fives
+        fe_ids = concat idss
+        fe_init_code = map foreignExportInitialiser fe_ids
+    --
+    return (ForeignStubs
+             (vcat hs)
+             (vcat cs $$ vcat fe_init_code),
+            foldr (appOL . toOL) nilOL bindss)
+  where
+   do_ldecl (dL->L loc decl) = putSrcSpanDs loc (do_decl decl)
+
+   do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
+      traceIf (text "fi start" <+> ppr id)
+      let id' = unLoc id
+      (bs, h, c) <- dsFImport id' co spec
+      traceIf (text "fi end" <+> ppr id)
+      return (h, c, [], bs)
+
+   do_decl (ForeignExport { fd_name = (dL->L _ id)
+                          , fd_e_ext = co
+                          , fd_fe = CExport
+                              (dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do
+      (h, c, _, _) <- dsFExport id co ext_nm cconv False
+      return (h, c, [id], [])
+   do_decl (XForeignDecl _) = panic "dsForeigns'"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Foreign import}
+*                                                                      *
+************************************************************************
+
+Desugaring foreign imports is just the matter of creating a binding
+that on its RHS unboxes its arguments, performs the external call
+(using the @CCallOp@ primop), before boxing the result up and returning it.
+
+However, we create a worker/wrapper pair, thus:
+
+        foreign import f :: Int -> IO Int
+==>
+        f x = IO ( \s -> case x of { I# x# ->
+                         case fw s x# of { (# s1, y# #) ->
+                         (# s1, I# y# #)}})
+
+        fw s x# = ccall f s x#
+
+The strictness/CPR analyser won't do this automatically because it doesn't look
+inside returned tuples; but inlining this wrapper is a Really Good Idea
+because it exposes the boxing to the call site.
+-}
+
+dsFImport :: Id
+          -> Coercion
+          -> ForeignImport
+          -> DsM ([Binding], SDoc, SDoc)
+dsFImport id co (CImport cconv safety mHeader spec _) =
+    dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
+
+dsCImport :: Id
+          -> Coercion
+          -> CImportSpec
+          -> CCallConv
+          -> Safety
+          -> Maybe Header
+          -> DsM ([Binding], SDoc, SDoc)
+dsCImport id co (CLabel cid) cconv _ _ = do
+   dflags <- getDynFlags
+   let ty  = pFst $ coercionKind co
+       fod = case tyConAppTyCon_maybe (dropForAlls ty) of
+             Just tycon
+              | tyConUnique tycon == funPtrTyConKey ->
+                 IsFunction
+             _ -> IsData
+   (resTy, foRhs) <- resultWrapper ty
+   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
+    let
+        rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
+        rhs' = Cast rhs co
+        stdcall_info = fun_type_arg_stdcall_info dflags cconv ty
+    in
+    return ([(id, rhs')], empty, empty)
+
+dsCImport id co (CFunction target) cconv@PrimCallConv safety _
+  = dsPrimCall id co (CCall (CCallSpec target cconv safety))
+dsCImport id co (CFunction target) cconv safety mHeader
+  = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
+dsCImport id co CWrapper cconv _ _
+  = dsFExportDynamic id co cconv
+
+-- For stdcall labels, if the type was a FunPtr or newtype thereof,
+-- then we need to calculate the size of the arguments in order to add
+-- the @n suffix to the label.
+fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int
+fun_type_arg_stdcall_info dflags StdCallConv ty
+  | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
+    tyConUnique tc == funPtrTyConKey
+  = let
+       (bndrs, _) = tcSplitPiTys arg_ty
+       fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs
+    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys)
+fun_type_arg_stdcall_info _ _other_conv _
+  = Nothing
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Foreign calls}
+*                                                                      *
+************************************************************************
+-}
+
+dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
+        -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
+dsFCall fn_id co fcall mDeclHeader = do
+    let
+        ty                   = pFst $ coercionKind co
+        (tv_bndrs, rho)      = tcSplitForAllVarBndrs ty
+        (arg_tys, io_res_ty) = tcSplitFunTys rho
+
+    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism
+    (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
+
+    let
+        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars
+
+    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
+
+    ccall_uniq <- newUnique
+    work_uniq  <- newUnique
+
+    dflags <- getDynFlags
+    (fcall', cDoc) <-
+              case fcall of
+              CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)
+                               CApiConv safety) ->
+               do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)
+                  let fcall' = CCall (CCallSpec
+                                      (StaticTarget NoSourceText
+                                                    wrapperName mUnitId
+                                                    True)
+                                      CApiConv safety)
+                      c = includes
+                       $$ fun_proto <+> braces (cRet <> semi)
+                      includes = vcat [ text "#include \"" <> ftext h
+                                        <> text "\""
+                                      | Header _ h <- nub headers ]
+                      fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
+                      cRet
+                       | isVoidRes =                   cCall
+                       | otherwise = text "return" <+> cCall
+                      cCall = if isFun
+                              then ppr cName <> parens argVals
+                              else if null arg_tys
+                                    then ppr cName
+                                    else panic "dsFCall: Unexpected arguments to FFI value import"
+                      raw_res_ty = case tcSplitIOType_maybe io_res_ty of
+                                   Just (_ioTyCon, res_ty) -> res_ty
+                                   Nothing                 -> io_res_ty
+                      isVoidRes = raw_res_ty `eqType` unitTy
+                      (mHeader, cResType)
+                       | isVoidRes = (Nothing, text "void")
+                       | otherwise = toCType raw_res_ty
+                      pprCconv = ccallConvAttribute CApiConv
+                      mHeadersArgTypeList
+                          = [ (header, cType <+> char 'a' <> int n)
+                            | (t, n) <- zip arg_tys [1..]
+                            , let (header, cType) = toCType t ]
+                      (mHeaders, argTypeList) = unzip mHeadersArgTypeList
+                      argTypes = if null argTypeList
+                                 then text "void"
+                                 else hsep $ punctuate comma argTypeList
+                      mHeaders' = mDeclHeader : mHeader : mHeaders
+                      headers = catMaybes mHeaders'
+                      argVals = hsep $ punctuate comma
+                                    [ char 'a' <> int n
+                                    | (_, n) <- zip arg_tys [1..] ]
+                  return (fcall', c)
+              _ ->
+                  return (fcall, empty)
+    let
+        -- Build the worker
+        worker_ty     = mkForAllTys tv_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
+        tvs           = map binderVar tv_bndrs
+        the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
+        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
+        work_id       = mkSysLocal (fsLit "$wccall") work_uniq worker_ty
+
+        -- Build the wrapper
+        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
+        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
+        wrap_rhs     = mkLams (tvs ++ args) wrapper_body
+        wrap_rhs'    = Cast wrap_rhs co
+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
+                                                (length args) wrap_rhs'
+
+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Primitive calls}
+*                                                                      *
+************************************************************************
+
+This is for `@foreign import prim@' declarations.
+
+Currently, at the core level we pretend that these primitive calls are
+foreign calls. It may make more sense in future to have them as a distinct
+kind of Id, or perhaps to bundle them with PrimOps since semantically and
+for calling convention they are really prim ops.
+-}
+
+dsPrimCall :: Id -> Coercion -> ForeignCall
+           -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)
+dsPrimCall fn_id co fcall = do
+    let
+        ty                   = pFst $ coercionKind co
+        (tvs, fun_ty)        = tcSplitForAllTys ty
+        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
+
+    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism
+
+    ccall_uniq <- newUnique
+    dflags <- getDynFlags
+    let
+        call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
+        rhs      = mkLams tvs (mkLams args call_app)
+        rhs'     = Cast rhs co
+    return ([(fn_id, rhs')], empty, empty)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Foreign export}
+*                                                                      *
+************************************************************************
+
+The function that does most of the work for `@foreign export@' declarations.
+(see below for the boilerplate code a `@foreign export@' declaration expands
+ into.)
+
+For each `@foreign export foo@' in a module M we generate:
+\begin{itemize}
+\item a C function `@foo@', which calls
+\item a Haskell stub `@M.\$ffoo@', which calls
+\end{itemize}
+the user-written Haskell function `@M.foo@'.
+-}
+
+dsFExport :: Id                 -- Either the exported Id,
+                                -- or the foreign-export-dynamic constructor
+          -> Coercion           -- Coercion between the Haskell type callable
+                                -- from C, and its representation type
+          -> CLabelString       -- The name to export to C land
+          -> CCallConv
+          -> Bool               -- True => foreign export dynamic
+                                --         so invoke IO action that's hanging off
+                                --         the first argument's stable pointer
+          -> DsM ( SDoc         -- contents of Module_stub.h
+                 , SDoc         -- contents of Module_stub.c
+                 , String       -- string describing type to pass to createAdj.
+                 , Int          -- size of args to stub function
+                 )
+
+dsFExport fn_id co ext_name cconv isDyn = do
+    let
+       ty                     = pSnd $ coercionKind co
+       (bndrs, orig_res_ty)   = tcSplitPiTys ty
+       fe_arg_tys'            = mapMaybe binderRelevantType_maybe bndrs
+       -- We must use tcSplits here, because we want to see
+       -- the (IO t) in the corner of the type!
+       fe_arg_tys | isDyn     = tail fe_arg_tys'
+                  | otherwise = fe_arg_tys'
+
+       -- Look at the result type of the exported function, orig_res_ty
+       -- If it's IO t, return         (t, True)
+       -- If it's plain t, return      (t, False)
+       (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
+                                -- The function already returns IO t
+                                Just (_ioTyCon, res_ty) -> (res_ty, True)
+                                -- The function returns t
+                                Nothing                 -> (orig_res_ty, False)
+
+    dflags <- getDynFlags
+    return $
+      mkFExportCBits dflags ext_name
+                     (if isDyn then Nothing else Just fn_id)
+                     fe_arg_tys res_ty is_IO_res_ty cconv
+
+{-
+@foreign import "wrapper"@ (previously "foreign export dynamic") lets
+you dress up Haskell IO actions of some fixed type behind an
+externally callable interface (i.e., as a C function pointer). Useful
+for callbacks and stuff.
+
+\begin{verbatim}
+type Fun = Bool -> Int -> IO Int
+foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
+
+-- Haskell-visible constructor, which is generated from the above:
+-- SUP: No check for NULL from createAdjustor anymore???
+
+f :: Fun -> IO (FunPtr Fun)
+f cback =
+   bindIO (newStablePtr cback)
+          (\StablePtr sp# -> IO (\s1# ->
+              case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
+                 (# s2#, a# #) -> (# s2#, A# a# #)))
+
+foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
+
+-- and the helper in C: (approximately; see `mkFExportCBits` below)
+
+f_helper(StablePtr s, HsBool b, HsInt i)
+{
+        Capability *cap;
+        cap = rts_lock();
+        rts_evalIO(&cap,
+                   rts_apply(rts_apply(deRefStablePtr(s),
+                                       rts_mkBool(b)), rts_mkInt(i)));
+        rts_unlock(cap);
+}
+\end{verbatim}
+-}
+
+dsFExportDynamic :: Id
+                 -> Coercion
+                 -> CCallConv
+                 -> DsM ([Binding], SDoc, SDoc)
+dsFExportDynamic id co0 cconv = do
+    mod <- getModule
+    dflags <- getDynFlags
+    let fe_nm = mkFastString $ zEncodeString
+            (moduleStableString mod ++ "$" ++ toCName dflags id)
+        -- Construct the label based on the passed id, don't use names
+        -- depending on Unique. See #13807 and Note [Unique Determinism].
+    cback <- newSysLocalDs arg_ty
+    newStablePtrId <- dsLookupGlobalId newStablePtrName
+    stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
+    let
+        stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
+        export_ty     = mkFunTy stable_ptr_ty arg_ty
+    bindIOId <- dsLookupGlobalId bindIOName
+    stbl_value <- newSysLocalDs stable_ptr_ty
+    (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True
+    let
+         {-
+          The arguments to the external function which will
+          create a little bit of (template) code on the fly
+          for allowing the (stable pointed) Haskell closure
+          to be entered using an external calling convention
+          (stdcall, ccall).
+         -}
+        adj_args      = [ mkIntLitInt dflags (ccallConvToInt cconv)
+                        , Var stbl_value
+                        , Lit (LitLabel fe_nm mb_sz_args IsFunction)
+                        , Lit (mkLitString typestring)
+                        ]
+          -- name of external entry point providing these services.
+          -- (probably in the RTS.)
+        adjustor   = fsLit "createAdjustor"
+
+          -- Determine the number of bytes of arguments to the stub function,
+          -- so that we can attach the '@N' suffix to its label if it is a
+          -- stdcall on Windows.
+        mb_sz_args = case cconv of
+                        StdCallConv -> Just args_size
+                        _           -> Nothing
+
+    ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
+        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
+
+    let io_app = mkLams tvs                  $
+                 Lam cback                   $
+                 mkApps (Var bindIOId)
+                        [ Type stable_ptr_ty
+                        , Type res_ty
+                        , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
+                        , Lam stbl_value ccall_adj
+                        ]
+
+        fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
+               -- Never inline the f.e.d. function, because the litlit
+               -- might not be in scope in other modules.
+
+    return ([fed], h_code, c_code)
+
+ where
+  ty                       = pFst (coercionKind co0)
+  (tvs,sans_foralls)       = tcSplitForAllTys ty
+  ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls
+  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty
+        -- Must have an IO type; hence Just
+
+
+toCName :: DynFlags -> Id -> String
+toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))
+
+{-
+*
+
+\subsection{Generating @foreign export@ stubs}
+
+*
+
+For each @foreign export@ function, a C stub function is generated.
+The C stub constructs the application of the exported Haskell function
+using the hugs/ghc rts invocation API.
+-}
+
+mkFExportCBits :: DynFlags
+               -> FastString
+               -> Maybe Id      -- Just==static, Nothing==dynamic
+               -> [Type]
+               -> Type
+               -> Bool          -- True <=> returns an IO type
+               -> CCallConv
+               -> (SDoc,
+                   SDoc,
+                   String,      -- the argument reps
+                   Int          -- total size of arguments
+                  )
+mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
+ = (header_bits, c_bits, type_string,
+    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
+         -- NB. the calculation here isn't strictly speaking correct.
+         -- We have a primitive Haskell type (eg. Int#, Double#), and
+         -- we want to know the size, when passed on the C stack, of
+         -- the associated C type (eg. HsInt, HsDouble).  We don't have
+         -- this information to hand, but we know what GHC's conventions
+         -- are for passing around the primitive Haskell types, so we
+         -- use that instead.  I hope the two coincide --SDM
+    )
+ where
+  -- list the arguments to the C function
+  arg_info :: [(SDoc,           -- arg name
+                SDoc,           -- C type
+                Type,           -- Haskell type
+                CmmType)]       -- the CmmType
+  arg_info  = [ let stg_type = showStgType ty in
+                (arg_cname n stg_type,
+                 stg_type,
+                 ty,
+                 typeCmmType dflags (getPrimTyOf ty))
+              | (ty,n) <- zip arg_htys [1::Int ..] ]
+
+  arg_cname n stg_ty
+        | libffi    = char '*' <> parens (stg_ty <> char '*') <>
+                      text "args" <> brackets (int (n-1))
+        | otherwise = text ('a':show n)
+
+  -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
+  libffi = cLibFFI && isNothing maybe_target
+
+  type_string
+      -- libffi needs to know the result type too:
+      | libffi    = primTyDescChar dflags res_hty : arg_type_string
+      | otherwise = arg_type_string
+
+  arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info]
+                -- just the real args
+
+  -- add some auxiliary args; the stable ptr in the wrapper case, and
+  -- a slot for the dummy return address in the wrapper + ccall case
+  aug_arg_info
+    | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info
+    | otherwise              = arg_info
+
+  stable_ptr_arg =
+        (text "the_stableptr", text "StgStablePtr", undefined,
+         typeCmmType dflags (mkStablePtrPrimTy alphaTy))
+
+  -- stuff to do with the return type of the C function
+  res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes
+
+  cResType | res_hty_is_unit = text "void"
+           | otherwise       = showStgType res_hty
+
+  -- when the return type is integral and word-sized or smaller, it
+  -- must be assigned as type ffi_arg (#3516).  To see what type
+  -- libffi is expecting here, take a look in its own testsuite, e.g.
+  -- libffi/testsuite/libffi.call/cls_align_ulonglong.c
+  ffi_cResType
+     | is_ffi_arg_type = text "ffi_arg"
+     | otherwise       = cResType
+     where
+       res_ty_key = getUnique (getName (typeTyCon res_hty))
+       is_ffi_arg_type = res_ty_key `notElem`
+              [floatTyConKey, doubleTyConKey,
+               int64TyConKey, word64TyConKey]
+
+  -- Now we can cook up the prototype for the exported function.
+  pprCconv = ccallConvAttribute cc
+
+  header_bits = text "extern" <+> fun_proto <> semi
+
+  fun_args
+    | null aug_arg_info = text "void"
+    | otherwise         = hsep $ punctuate comma
+                               $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
+
+  fun_proto
+    | libffi
+      = text "void" <+> ftext c_nm <>
+          parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
+    | otherwise
+      = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
+
+  -- the target which will form the root of what we ask rts_evalIO to run
+  the_cfun
+     = case maybe_target of
+          Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
+          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
+
+  cap = text "cap" <> comma
+
+  -- the expression we give to rts_evalIO
+  expr_to_run
+     = foldl' appArg the_cfun arg_info -- NOT aug_arg_info
+       where
+          appArg acc (arg_cname, _, arg_hty, _)
+             = text "rts_apply"
+               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
+
+  -- various other bits for inside the fn
+  declareResult = text "HaskellObj ret;"
+  declareCResult | res_hty_is_unit = empty
+                 | otherwise       = cResType <+> text "cret;"
+
+  assignCResult | res_hty_is_unit = empty
+                | otherwise       =
+                        text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
+
+  -- an extern decl for the fn being called
+  extern_decl
+     = case maybe_target of
+          Nothing -> empty
+          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
+
+
+  -- finally, the whole darn thing
+  c_bits =
+    space $$
+    extern_decl $$
+    fun_proto  $$
+    vcat
+     [ lbrace
+     ,   text "Capability *cap;"
+     ,   declareResult
+     ,   declareCResult
+     ,   text "cap = rts_lock();"
+          -- create the application + perform it.
+     ,   text "rts_evalIO" <> parens (
+                char '&' <> cap <>
+                text "rts_apply" <> parens (
+                    cap <>
+                    text "(HaskellObj)"
+                 <> ptext (if is_IO_res_ty
+                                then (sLit "runIO_closure")
+                                else (sLit "runNonIO_closure"))
+                 <> comma
+                 <> expr_to_run
+                ) <+> comma
+               <> text "&ret"
+             ) <> semi
+     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
+                                                <> comma <> text "cap") <> semi
+     ,   assignCResult
+     ,   text "rts_unlock(cap);"
+     ,   ppUnless res_hty_is_unit $
+         if libffi
+                  then char '*' <> parens (ffi_cResType <> char '*') <>
+                       text "resp = cret;"
+                  else text "return cret;"
+     , rbrace
+     ]
+
+
+foreignExportInitialiser :: Id -> SDoc
+foreignExportInitialiser hs_fn =
+   -- Initialise foreign exports by registering a stable pointer from an
+   -- __attribute__((constructor)) function.
+   -- The alternative is to do this from stginit functions generated in
+   -- codeGen/CodeGen.hs; however, stginit functions have a negative impact
+   -- on binary sizes and link times because the static linker will think that
+   -- all modules that are imported directly or indirectly are actually used by
+   -- the program.
+   -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
+   vcat
+    [ text "static void stginit_export_" <> ppr hs_fn
+         <> text "() __attribute__((constructor));"
+    , text "static void stginit_export_" <> ppr hs_fn <> text "()"
+    , braces (text "foreignExportStablePtr"
+       <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
+       <> semi)
+    ]
+
+
+mkHObj :: Type -> SDoc
+mkHObj t = text "rts_mk" <> text (showFFIType t)
+
+unpackHObj :: Type -> SDoc
+unpackHObj t = text "rts_get" <> text (showFFIType t)
+
+showStgType :: Type -> SDoc
+showStgType t = text "Hs" <> text (showFFIType t)
+
+showFFIType :: Type -> String
+showFFIType t = getOccString (getName (typeTyCon t))
+
+toCType :: Type -> (Maybe Header, SDoc)
+toCType = f False
+    where f voidOK t
+           -- First, if we have (Ptr t) of (FunPtr t), then we need to
+           -- convert t to a C type and put a * after it. If we don't
+           -- know a type for t, then "void" is fine, though.
+           | Just (ptr, [t']) <- splitTyConApp_maybe t
+           , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
+              = case f True t' of
+                (mh, cType') ->
+                    (mh, cType' <> char '*')
+           -- Otherwise, if we have a type constructor application, then
+           -- see if there is a C type associated with that constructor.
+           -- Note that we aren't looking through type synonyms or
+           -- anything, as it may be the synonym that is annotated.
+           | Just tycon <- tyConAppTyConPicky_maybe t
+           , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
+              = (mHeader, ftext cType)
+           -- If we don't know a C type for this type, then try looking
+           -- through one layer of type synonym etc.
+           | Just t' <- coreView t
+              = f voidOK t'
+           -- This may be an 'UnliftedFFITypes'-style ByteArray# argument
+           -- (which is marshalled like a Ptr)
+           | Just byteArrayPrimTyCon        == tyConAppTyConPicky_maybe t
+              = (Nothing, text "const void*")
+           | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t
+              = (Nothing, text "void*")
+           -- Otherwise we don't know the C type. If we are allowing
+           -- void then return that; otherwise something has gone wrong.
+           | voidOK = (Nothing, text "void")
+           | otherwise
+              = pprPanic "toCType" (ppr t)
+
+typeTyCon :: Type -> TyCon
+typeTyCon ty
+  | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)
+  = tc
+  | otherwise
+  = pprPanic "DsForeign.typeTyCon" (ppr ty)
+
+insertRetAddr :: DynFlags -> CCallConv
+              -> [(SDoc, SDoc, Type, CmmType)]
+              -> [(SDoc, SDoc, Type, CmmType)]
+insertRetAddr dflags CCallConv args
+    = case platformArch platform of
+      ArchX86_64
+       | platformOS platform == OSMinGW32 ->
+          -- On other Windows x86_64 we insert the return address
+          -- after the 4th argument, because this is the point
+          -- at which we need to flush a register argument to the stack
+          -- (See rts/Adjustor.c for details).
+          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
+                        -> [(SDoc, SDoc, Type, CmmType)]
+              go 4 args = ret_addr_arg dflags : args
+              go n (arg:args) = arg : go (n+1) args
+              go _ [] = []
+          in go 0 args
+       | otherwise ->
+          -- On other x86_64 platforms we insert the return address
+          -- after the 6th integer argument, because this is the point
+          -- at which we need to flush a register argument to the stack
+          -- (See rts/Adjustor.c for details).
+          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
+                        -> [(SDoc, SDoc, Type, CmmType)]
+              go 6 args = ret_addr_arg dflags : args
+              go n (arg@(_,_,_,rep):args)
+               | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
+               | otherwise  = arg : go n     args
+              go _ [] = []
+          in go 0 args
+      _ ->
+          ret_addr_arg dflags : args
+    where platform = targetPlatform dflags
+insertRetAddr _ _ args = args
+
+ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType)
+ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined,
+                       typeCmmType dflags addrPrimTy)
+
+-- This function returns the primitive type associated with the boxed
+-- type argument to a foreign export (eg. Int ==> Int#).
+getPrimTyOf :: Type -> UnaryType
+getPrimTyOf ty
+  | isBoolTy rep_ty = intPrimTy
+  -- Except for Bool, the types we are interested in have a single constructor
+  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
+  | otherwise =
+  case splitDataProductType_maybe rep_ty of
+     Just (_, _, data_con, [prim_ty]) ->
+        ASSERT(dataConSourceArity data_con == 1)
+        ASSERT2(isUnliftedType prim_ty, ppr prim_ty)
+        prim_ty
+     _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
+  where
+        rep_ty = unwrapType ty
+
+-- represent a primitive type as a Char, for building a string that
+-- described the foreign function type.  The types are size-dependent,
+-- e.g. 'W' is a signed 32-bit integer.
+primTyDescChar :: DynFlags -> Type -> Char
+primTyDescChar dflags ty
+ | ty `eqType` unitTy = 'v'
+ | otherwise
+ = case typePrimRep1 (getPrimTyOf ty) of
+     IntRep      -> signed_word
+     WordRep     -> unsigned_word
+     Int64Rep    -> 'L'
+     Word64Rep   -> 'l'
+     AddrRep     -> 'p'
+     FloatRep    -> 'f'
+     DoubleRep   -> 'd'
+     _           -> pprPanic "primTyDescChar" (ppr ty)
+  where
+    (signed_word, unsigned_word)
+       | wORD_SIZE dflags == 4  = ('W','w')
+       | wORD_SIZE dflags == 8  = ('L','l')
+       | otherwise              = panic "primTyDescChar"
diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsGRHSs.hs
@@ -0,0 +1,150 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Matching guarded right-hand-sides (GRHSs)
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} DsExpr  ( dsLExpr, dsLocalBinds )
+import {-# SOURCE #-} Match   ( matchSinglePatVar )
+
+import HsSyn
+import MkCore
+import CoreSyn
+import CoreUtils (bindNonRec)
+
+import Check (genCaseTmCs2)
+import DsMonad
+import DsUtils
+import Type   ( Type )
+import Name
+import Util
+import SrcLoc
+import Outputable
+
+{-
+@dsGuarded@ is used for pattern bindings.
+It desugars:
+\begin{verbatim}
+        | g1 -> e1
+        ...
+        | gn -> en
+        where binds
+\end{verbatim}
+producing an expression with a runtime error in the corner if
+necessary.  The type argument gives the type of the @ei@.
+-}
+
+dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> DsM CoreExpr
+dsGuarded grhss rhs_ty = do
+    match_result <- dsGRHSs PatBindRhs grhss rhs_ty
+    error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty
+    extractMatchResult match_result error_expr
+
+-- In contrast, @dsGRHSs@ produces a @MatchResult@.
+
+dsGRHSs :: HsMatchContext Name
+        -> GRHSs GhcTc (LHsExpr GhcTc)          -- Guarded RHSs
+        -> Type                                 -- Type of RHS
+        -> DsM MatchResult
+dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty
+  = ASSERT( notNull grhss )
+    do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
+       ; let match_result1 = foldr1 combineMatchResults match_results
+             match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
+                             -- NB: nested dsLet inside matchResult
+       ; return match_result2 }
+dsGRHSs _ (XGRHSs _) _ = panic "dsGRHSs"
+
+dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)
+       -> DsM MatchResult
+dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs))
+  = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty
+dsGRHS _ _ (dL->L _ (XGRHS _)) = panic "dsGRHS"
+dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884
+
+{-
+************************************************************************
+*                                                                      *
+*  matchGuard : make a MatchResult from a guarded RHS                  *
+*                                                                      *
+************************************************************************
+-}
+
+matchGuards :: [GuardStmt GhcTc]     -- Guard
+            -> HsStmtContext Name    -- Context
+            -> LHsExpr GhcTc         -- RHS
+            -> Type                  -- Type of RHS of guard
+            -> DsM MatchResult
+
+-- See comments with HsExpr.Stmt re what a BodyStmt means
+-- Here we must be in a guard context (not do-expression, nor list-comp)
+
+matchGuards [] _ rhs _
+  = do  { core_rhs <- dsLExpr rhs
+        ; return (cantFailMatchResult core_rhs) }
+
+        -- BodyStmts must be guards
+        -- Turn an "otherwise" guard is a no-op.  This ensures that
+        -- you don't get a "non-exhaustive eqns" message when the guards
+        -- finish in "otherwise".
+        -- NB:  The success of this clause depends on the typechecker not
+        --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors
+        --      If it does, you'll get bogus overlap warnings
+matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty
+  | Just addTicks <- isTrueLHsExpr e = do
+    match_result <- matchGuards stmts ctx rhs rhs_ty
+    return (adjustMatchResultDs addTicks match_result)
+matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do
+    match_result <- matchGuards stmts ctx rhs rhs_ty
+    pred_expr <- dsLExpr expr
+    return (mkGuardedMatchResult pred_expr match_result)
+
+matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do
+    match_result <- matchGuards stmts ctx rhs rhs_ty
+    return (adjustMatchResultDs (dsLocalBinds binds) match_result)
+        -- NB the dsLet occurs inside the match_result
+        -- Reason: dsLet takes the body expression as its argument
+        --         so we can't desugar the bindings without the
+        --         body expression in hand
+
+matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
+    let upat = unLoc pat
+        dicts = collectEvVarsPat upat
+    match_var <- selectMatchVar upat
+    tm_cs <- genCaseTmCs2 (Just bind_rhs) [upat] [match_var]
+    match_result <- addDictsDs dicts $
+                    addTmCsDs tm_cs  $
+                      -- See Note [Type and Term Equality Propagation] in Check
+                    matchGuards stmts ctx rhs rhs_ty
+    core_rhs <- dsLExpr bind_rhs
+    match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty
+                                       match_result
+    pure $ adjustMatchResult (bindNonRec match_var core_rhs) match_result'
+
+matchGuards (LastStmt  {} : _) _ _ _ = panic "matchGuards LastStmt"
+matchGuards (ParStmt   {} : _) _ _ _ = panic "matchGuards ParStmt"
+matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"
+matchGuards (RecStmt   {} : _) _ _ _ = panic "matchGuards RecStmt"
+matchGuards (ApplicativeStmt {} : _) _ _ _ =
+  panic "matchGuards ApplicativeLastStmt"
+matchGuards (XStmtLR {} : _) _ _ _ =
+  panic "matchGuards XStmtLR"
+
+{-
+Should {\em fail} if @e@ returns @D@
+\begin{verbatim}
+f x | p <- e', let C y# = e, f y# = r1
+    | otherwise          = r2
+\end{verbatim}
+-}
diff --git a/compiler/deSugar/DsListComp.hs b/compiler/deSugar/DsListComp.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsListComp.hs
@@ -0,0 +1,693 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Desugaring list comprehensions, monad comprehensions and array comprehensions
+-}
+
+{-# LANGUAGE CPP, NamedFieldPuns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module DsListComp ( dsListComp, dsMonadComp ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
+
+import HsSyn
+import TcHsSyn
+import CoreSyn
+import MkCore
+
+import DsMonad          -- the monadery used in the desugarer
+import DsUtils
+
+import DynFlags
+import CoreUtils
+import Id
+import Type
+import TysWiredIn
+import Match
+import PrelNames
+import SrcLoc
+import Outputable
+import TcType
+import ListSetOps( getNth )
+import Util
+
+{-
+List comprehensions may be desugared in one of two ways: ``ordinary''
+(as you would expect if you read SLPJ's book) and ``with foldr/build
+turned on'' (if you read Gill {\em et al.}'s paper on the subject).
+
+There will be at least one ``qualifier'' in the input.
+-}
+
+dsListComp :: [ExprLStmt GhcTc]
+           -> Type              -- Type of entire list
+           -> DsM CoreExpr
+dsListComp lquals res_ty = do
+    dflags <- getDynFlags
+    let quals = map unLoc lquals
+        elt_ty = case tcTyConAppArgs res_ty of
+                   [elt_ty] -> elt_ty
+                   _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals)
+
+    if not (gopt Opt_EnableRewriteRules dflags) || gopt Opt_IgnoreInterfacePragmas dflags
+       -- Either rules are switched off, or we are ignoring what there are;
+       -- Either way foldr/build won't happen, so use the more efficient
+       -- Wadler-style desugaring
+       || isParallelComp quals
+       -- Foldr-style desugaring can't handle parallel list comprehensions
+        then deListComp quals (mkNilExpr elt_ty)
+        else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals)
+             -- Foldr/build should be enabled, so desugar
+             -- into foldrs and builds
+
+  where
+    -- We must test for ParStmt anywhere, not just at the head, because an extension
+    -- to list comprehensions would be to add brackets to specify the associativity
+    -- of qualifier lists. This is really easy to do by adding extra ParStmts into the
+    -- mix of possibly a single element in length, so we do this to leave the possibility open
+    isParallelComp = any isParallelStmt
+
+    isParallelStmt (ParStmt {}) = True
+    isParallelStmt _            = False
+
+
+-- This function lets you desugar a inner list comprehension and a list of the binders
+-- of that comprehension that we need in the outer comprehension into such an expression
+-- and the type of the elements that it outputs (tuples of binders)
+dsInnerListComp :: (ParStmtBlock GhcTc GhcTc) -> DsM (CoreExpr, Type)
+dsInnerListComp (ParStmtBlock _ stmts bndrs _)
+  = do { let bndrs_tuple_type = mkBigCoreVarTupTy bndrs
+             list_ty          = mkListTy bndrs_tuple_type
+
+             -- really use original bndrs below!
+       ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty
+
+       ; return (expr, bndrs_tuple_type) }
+dsInnerListComp (XParStmtBlock{}) = panic "dsInnerListComp"
+
+-- This function factors out commonality between the desugaring strategies for GroupStmt.
+-- Given such a statement it gives you back an expression representing how to compute the transformed
+-- list and the tuple that you need to bind from that list in order to proceed with your desugaring
+dsTransStmt :: ExprStmt GhcTc -> DsM (CoreExpr, LPat GhcTc)
+dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap
+                       , trS_by = by, trS_using = using }) = do
+    let (from_bndrs, to_bndrs) = unzip binderMap
+
+    let from_bndrs_tys  = map idType from_bndrs
+        to_bndrs_tys    = map idType to_bndrs
+
+        to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys
+
+    -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
+    (expr', from_tup_ty) <- dsInnerListComp (ParStmtBlock noExt stmts
+                                                        from_bndrs noSyntaxExpr)
+
+    -- Work out what arguments should be supplied to that expression: i.e. is an extraction
+    -- function required? If so, create that desugared function and add to arguments
+    usingExpr' <- dsLExpr using
+    usingArgs' <- case by of
+                    Nothing   -> return [expr']
+                    Just by_e -> do { by_e' <- dsLExpr by_e
+                                    ; lam' <- matchTuple from_bndrs by_e'
+                                    ; return [lam', expr'] }
+
+    -- Create an unzip function for the appropriate arity and element types and find "map"
+    unzip_stuff' <- mkUnzipBind form from_bndrs_tys
+    map_id <- dsLookupGlobalId mapName
+
+    -- Generate the expressions to build the grouped list
+    let -- First we apply the grouping function to the inner list
+        inner_list_expr' = mkApps usingExpr' usingArgs'
+        -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists
+        -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and
+        -- the "b" to be a tuple of "to" lists!
+        -- Then finally we bind the unzip function around that expression
+        bound_unzipped_inner_list_expr'
+          = case unzip_stuff' of
+              Nothing -> inner_list_expr'
+              Just (unzip_fn', unzip_rhs') ->
+                Let (Rec [(unzip_fn', unzip_rhs')]) $
+                mkApps (Var map_id) $
+                [ Type (mkListTy from_tup_ty)
+                , Type to_bndrs_tup_ty
+                , Var unzip_fn'
+                , inner_list_expr' ]
+
+    dsNoLevPoly (tcFunResultTyN (length usingArgs') (exprType usingExpr'))
+      (text "In the result of a" <+> quotes (text "using") <+> text "function:" <+> ppr using)
+
+    -- Build a pattern that ensures the consumer binds into the NEW binders,
+    -- which hold lists rather than single values
+    let pat = mkBigLHsVarPatTupId to_bndrs  -- NB: no '!
+    return (bound_unzipped_inner_list_expr', pat)
+
+dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
+*                                                                      *
+************************************************************************
+
+Just as in Phil's chapter~7 in SLPJ, using the rules for
+optimally-compiled list comprehensions.  This is what Kevin followed
+as well, and I quite happily do the same.  The TQ translation scheme
+transforms a list of qualifiers (either boolean expressions or
+generators) into a single expression which implements the list
+comprehension.  Because we are generating 2nd-order polymorphic
+lambda-calculus, calls to NIL and CONS must be applied to a type
+argument, as well as their usual value arguments.
+\begin{verbatim}
+TE << [ e | qs ] >>  =  TQ << [ e | qs ] ++ Nil (typeOf e) >>
+
+(Rule C)
+TQ << [ e | ] ++ L >> = Cons (typeOf e) TE <<e>> TE <<L>>
+
+(Rule B)
+TQ << [ e | b , qs ] ++ L >> =
+    if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>
+
+(Rule A')
+TQ << [ e | p <- L1, qs ]  ++  L2 >> =
+  letrec
+    h = \ u1 ->
+          case u1 of
+            []        ->  TE << L2 >>
+            (u2 : u3) ->
+                  (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)
+                    [] (h u3)
+  in
+    h ( TE << L1 >> )
+
+"h", "u1", "u2", and "u3" are new variables.
+\end{verbatim}
+
+@deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@
+is the TE translation scheme.  Note that we carry around the @L@ list
+already desugared.  @dsListComp@ does the top TE rule mentioned above.
+
+To the above, we add an additional rule to deal with parallel list
+comprehensions.  The translation goes roughly as follows:
+     [ e | p1 <- e11, let v1 = e12, p2 <- e13
+         | q1 <- e21, let v2 = e22, q2 <- e23]
+     =>
+     [ e | ((x1, .., xn), (y1, ..., ym)) <-
+               zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]
+                   [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]
+where (x1, .., xn) are the variables bound in p1, v1, p2
+      (y1, .., ym) are the variables bound in q1, v2, q2
+
+In the translation below, the ParStmt branch translates each parallel branch
+into a sub-comprehension, and desugars each independently.  The resulting lists
+are fed to a zip function, we create a binding for all the variables bound in all
+the comprehensions, and then we hand things off the desugarer for bindings.
+The zip function is generated here a) because it's small, and b) because then we
+don't have to deal with arbitrary limits on the number of zip functions in the
+prelude, nor which library the zip function came from.
+The introduced tuples are Boxed, but only because I couldn't get it to work
+with the Unboxed variety.
+-}
+
+deListComp :: [ExprStmt GhcTc] -> CoreExpr -> DsM CoreExpr
+
+deListComp [] _ = panic "deListComp"
+
+deListComp (LastStmt _ body _ _ : quals) list
+  =     -- Figure 7.4, SLPJ, p 135, rule C above
+    ASSERT( null quals )
+    do { core_body <- dsLExpr body
+       ; return (mkConsExpr (exprType core_body) core_body list) }
+
+        -- Non-last: must be a guard
+deListComp (BodyStmt _ guard _ _ : quals) list = do  -- rule B above
+    core_guard <- dsLExpr guard
+    core_rest <- deListComp quals list
+    return (mkIfThenElse core_guard core_rest list)
+
+-- [e | let B, qs] = let B in [e | qs]
+deListComp (LetStmt _ binds : quals) list = do
+    core_rest <- deListComp quals list
+    dsLocalBinds binds core_rest
+
+deListComp (stmt@(TransStmt {}) : quals) list = do
+    (inner_list_expr, pat) <- dsTransStmt stmt
+    deBindComp pat inner_list_expr quals list
+
+deListComp (BindStmt _ pat list1 _ _ : quals) core_list2 = do -- rule A' above
+    core_list1 <- dsLExprNoLP list1
+    deBindComp pat core_list1 quals core_list2
+
+deListComp (ParStmt _ stmtss_w_bndrs _ _ : quals) list
+  = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
+       ; let (exps, qual_tys) = unzip exps_and_qual_tys
+
+       ; (zip_fn, zip_rhs) <- mkZipBind qual_tys
+
+        -- Deal with [e | pat <- zip l1 .. ln] in example above
+       ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps))
+                    quals list }
+  where
+        bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs]
+
+        -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above
+        pat  = mkBigLHsPatTupId pats
+        pats = map mkBigLHsVarPatTupId bndrs_s
+
+deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt"
+
+deListComp (ApplicativeStmt {} : _) _ =
+  panic "deListComp ApplicativeStmt"
+
+deListComp (XStmtLR {} : _) _ =
+  panic "deListComp XStmtLR"
+
+deBindComp :: OutPat GhcTc
+           -> CoreExpr
+           -> [ExprStmt GhcTc]
+           -> CoreExpr
+           -> DsM (Expr Id)
+deBindComp pat core_list1 quals core_list2 = do
+    let u3_ty@u1_ty = exprType core_list1       -- two names, same thing
+
+        -- u1_ty is a [alpha] type, and u2_ty = alpha
+    let u2_ty = hsLPatType pat
+
+    let res_ty = exprType core_list2
+        h_ty   = u1_ty `mkFunTy` res_ty
+
+       -- no levity polymorphism here, as list comprehensions don't work
+       -- with RebindableSyntax. NB: These are *not* monad comps.
+    [h, u1, u2, u3] <- newSysLocalsDs [h_ty, u1_ty, u2_ty, u3_ty]
+
+    -- the "fail" value ...
+    let
+        core_fail   = App (Var h) (Var u3)
+        letrec_body = App (Var h) core_list1
+
+    rest_expr <- deListComp quals core_fail
+    core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail
+
+    let
+        rhs = Lam u1 $
+              Case (Var u1) u1 res_ty
+                   [(DataAlt nilDataCon,  [],       core_list2),
+                    (DataAlt consDataCon, [u2, u3], core_match)]
+                        -- Increasing order of tag
+
+    return (Let (Rec [(h, rhs)]) letrec_body)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
+*                                                                      *
+************************************************************************
+
+@dfListComp@ are the rules used with foldr/build turned on:
+
+\begin{verbatim}
+TE[ e | ]            c n = c e n
+TE[ e | b , q ]      c n = if b then TE[ e | q ] c n else n
+TE[ e | p <- l , q ] c n = let
+                                f = \ x b -> case x of
+                                                  p -> TE[ e | q ] c b
+                                                  _ -> b
+                           in
+                           foldr f n l
+\end{verbatim}
+-}
+
+dfListComp :: Id -> Id            -- 'c' and 'n'
+           -> [ExprStmt GhcTc]    -- the rest of the qual's
+           -> DsM CoreExpr
+
+dfListComp _ _ [] = panic "dfListComp"
+
+dfListComp c_id n_id (LastStmt _ body _ _ : quals)
+  = ASSERT( null quals )
+    do { core_body <- dsLExprNoLP body
+       ; return (mkApps (Var c_id) [core_body, Var n_id]) }
+
+        -- Non-last: must be a guard
+dfListComp c_id n_id (BodyStmt _ guard _ _  : quals) = do
+    core_guard <- dsLExpr guard
+    core_rest <- dfListComp c_id n_id quals
+    return (mkIfThenElse core_guard core_rest (Var n_id))
+
+dfListComp c_id n_id (LetStmt _ binds : quals) = do
+    -- new in 1.3, local bindings
+    core_rest <- dfListComp c_id n_id quals
+    dsLocalBinds binds core_rest
+
+dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
+    (inner_list_expr, pat) <- dsTransStmt stmt
+    -- Anyway, we bind the newly grouped list via the generic binding function
+    dfBindComp c_id n_id (pat, inner_list_expr) quals
+
+dfListComp c_id n_id (BindStmt _ pat list1 _ _ : quals) = do
+    -- evaluate the two lists
+    core_list1 <- dsLExpr list1
+
+    -- Do the rest of the work in the generic binding builder
+    dfBindComp c_id n_id (pat, core_list1) quals
+
+dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt"
+dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"
+dfListComp _ _ (ApplicativeStmt {} : _) =
+  panic "dfListComp ApplicativeStmt"
+dfListComp _ _ (XStmtLR {} : _) =
+  panic "dfListComp XStmtLR"
+
+dfBindComp :: Id -> Id             -- 'c' and 'n'
+           -> (LPat GhcTc, CoreExpr)
+           -> [ExprStmt GhcTc]     -- the rest of the qual's
+           -> DsM CoreExpr
+dfBindComp c_id n_id (pat, core_list1) quals = do
+    -- find the required type
+    let x_ty   = hsLPatType pat
+    let b_ty   = idType n_id
+
+    -- create some new local id's
+    b <- newSysLocalDs b_ty
+    x <- newSysLocalDs x_ty
+
+    -- build rest of the comprehesion
+    core_rest <- dfListComp c_id b quals
+
+    -- build the pattern match
+    core_expr <- matchSimply (Var x) (StmtCtxt ListComp)
+                pat core_rest (Var b)
+
+    -- now build the outermost foldr, and return
+    mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}
+*                                                                      *
+************************************************************************
+-}
+
+mkZipBind :: [Type] -> DsM (Id, CoreExpr)
+-- mkZipBind [t1, t2]
+-- = (zip, \as1:[t1] as2:[t2]
+--         -> case as1 of
+--              [] -> []
+--              (a1:as'1) -> case as2 of
+--                              [] -> []
+--                              (a2:as'2) -> (a1, a2) : zip as'1 as'2)]
+
+mkZipBind elt_tys = do
+    ass  <- mapM newSysLocalDs  elt_list_tys
+    as'  <- mapM newSysLocalDs  elt_tys
+    as's <- mapM newSysLocalDs  elt_list_tys
+
+    zip_fn <- newSysLocalDs zip_fn_ty
+
+    let inner_rhs = mkConsExpr elt_tuple_ty
+                        (mkBigCoreVarTup as')
+                        (mkVarApps (Var zip_fn) as's)
+        zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)
+
+    return (zip_fn, mkLams ass zip_body)
+  where
+    elt_list_tys      = map mkListTy elt_tys
+    elt_tuple_ty      = mkBigCoreTupTy elt_tys
+    elt_tuple_list_ty = mkListTy elt_tuple_ty
+
+    zip_fn_ty         = mkFunTys elt_list_tys elt_tuple_list_ty
+
+    mk_case (as, a', as') rest
+          = Case (Var as) as elt_tuple_list_ty
+                  [(DataAlt nilDataCon,  [],        mkNilExpr elt_tuple_ty),
+                   (DataAlt consDataCon, [a', as'], rest)]
+                        -- Increasing order of tag
+
+
+mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))
+-- mkUnzipBind [t1, t2]
+-- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])
+--     -> case ax of
+--      (x1, x2) -> case axs of
+--                (xs1, xs2) -> (x1 : xs1, x2 : xs2))
+--      ([], [])
+--      ys)
+--
+-- We use foldr here in all cases, even if rules are turned off, because we may as well!
+mkUnzipBind ThenForm _
+ = return Nothing    -- No unzipping for ThenForm
+mkUnzipBind _ elt_tys
+  = do { ax  <- newSysLocalDs elt_tuple_ty
+       ; axs <- newSysLocalDs elt_list_tuple_ty
+       ; ys  <- newSysLocalDs elt_tuple_list_ty
+       ; xs  <- mapM newSysLocalDs elt_tys
+       ; xss <- mapM newSysLocalDs elt_list_tys
+
+       ; unzip_fn <- newSysLocalDs unzip_fn_ty
+
+       ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]
+
+       ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)
+             concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))
+             tupled_concat_expression = mkBigCoreTup concat_expressions
+
+             folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)
+             folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)
+             folder_body = mkLams [ax, axs] folder_body_outer_case
+
+       ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)
+       ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }
+  where
+    elt_tuple_ty       = mkBigCoreTupTy elt_tys
+    elt_tuple_list_ty  = mkListTy elt_tuple_ty
+    elt_list_tys       = map mkListTy elt_tys
+    elt_list_tuple_ty  = mkBigCoreTupTy elt_list_tys
+
+    unzip_fn_ty        = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty
+
+    mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail
+
+-- Translation for monad comprehensions
+
+-- Entry point for monad comprehension desugaring
+dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr
+dsMonadComp stmts = dsMcStmts stmts
+
+dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr
+dsMcStmts []                          = panic "dsMcStmts"
+dsMcStmts ((dL->L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)
+
+---------------
+dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr
+
+dsMcStmt (LastStmt _ body _ ret_op) stmts
+  = ASSERT( null stmts )
+    do { body' <- dsLExpr body
+       ; dsSyntaxExpr ret_op [body'] }
+
+--   [ .. | let binds, stmts ]
+dsMcStmt (LetStmt _ binds) stmts
+  = do { rest <- dsMcStmts stmts
+       ; dsLocalBinds binds rest }
+
+--   [ .. | a <- m, stmts ]
+dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts
+  = do { rhs' <- dsLExpr rhs
+       ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }
+
+-- Apply `guard` to the `exp` expression
+--
+--   [ .. | exp, stmts ]
+--
+dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts
+  = do { exp'       <- dsLExpr exp
+       ; rest       <- dsMcStmts stmts
+       ; guard_exp' <- dsSyntaxExpr guard_exp [exp']
+       ; dsSyntaxExpr then_exp [guard_exp', rest] }
+
+-- Group statements desugar like this:
+--
+--   [| (q, then group by e using f); rest |]
+--   --->  f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->
+--         case unzip n_tup of qv' -> [| rest |]
+--
+-- where   variables (v1:t1, ..., vk:tk) are bound by q
+--         qv = (v1, ..., vk)
+--         qt = (t1, ..., tk)
+--         (>>=) :: m2 a -> (a -> m3 b) -> m3 b
+--         f :: forall a. (a -> t) -> m1 a -> m2 (n a)
+--         n_tup :: n qt
+--         unzip :: n qt -> (n t1, ..., n tk)    (needs Functor n)
+
+dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
+                    , trS_by = by, trS_using = using
+                    , trS_ret = return_op, trS_bind = bind_op
+                    , trS_ext = n_tup_ty'  -- n (a,b,c)
+                    , trS_fmap = fmap_op, trS_form = form }) stmts_rest
+  = do { let (from_bndrs, to_bndrs) = unzip bndrs
+
+       ; let from_bndr_tys = map idType from_bndrs     -- Types ty
+
+
+       -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders
+       ; expr' <- dsInnerMonadComp stmts from_bndrs return_op
+
+       -- Work out what arguments should be supplied to that expression: i.e. is an extraction
+       -- function required? If so, create that desugared function and add to arguments
+       ; usingExpr' <- dsLExpr using
+       ; usingArgs' <- case by of
+                         Nothing   -> return [expr']
+                         Just by_e -> do { by_e' <- dsLExpr by_e
+                                         ; lam' <- matchTuple from_bndrs by_e'
+                                         ; return [lam', expr'] }
+
+       -- Generate the expressions to build the grouped list
+       -- Build a pattern that ensures the consumer binds into the NEW binders,
+       -- which hold monads rather than single values
+       ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs
+
+       ; body        <- dsMcStmts stmts_rest
+       ; n_tup_var'  <- newSysLocalDsNoLP n_tup_ty'
+       ; tup_n_var'  <- newSysLocalDs tup_n_ty'
+       ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys
+       ; us          <- newUniqueSupply
+       ; let rhs'  = mkApps usingExpr' usingArgs'
+             body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr'
+
+       ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] }
+
+-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel
+-- statements, for example:
+--
+--   [ body | qs1 | qs2 | qs3 ]
+--     ->  [ body | (bndrs1, (bndrs2, bndrs3))
+--                     <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]
+--
+-- where `mzip` has type
+--   mzip :: forall a b. m a -> m b -> m (a,b)
+-- NB: we need a polymorphic mzip because we call it several times
+
+dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest
+ = do  { exps_w_tys  <- mapM ds_inner blocks   -- Pairs (exp :: m ty, ty)
+       ; mzip_op'    <- dsExpr mzip_op
+
+       ; let -- The pattern variables
+             pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks]
+             -- Pattern with tuples of variables
+             -- [v1,v2,v3]  =>  (v1, (v2, v3))
+             pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats
+             (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->
+                                 (mkApps mzip_op' [Type t1, Type t2, e1, e2],
+                                  mkBoxedTupleTy [t1,t2]))
+                               exps_w_tys
+
+       ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
+  where
+    ds_inner (ParStmtBlock _ stmts bndrs return_op)
+       = do { exp <- dsInnerMonadComp stmts bndrs return_op
+            ; return (exp, mkBigCoreVarTupTy bndrs) }
+    ds_inner (XParStmtBlock{}) = panic "dsMcStmt"
+
+dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)
+
+
+matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr
+-- (matchTuple [a,b,c] body)
+--       returns the Core term
+--  \x. case x of (a,b,c) -> body
+matchTuple ids body
+  = do { us <- newUniqueSupply
+       ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)
+       ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }
+
+-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a
+-- desugared `CoreExpr`
+dsMcBindStmt :: LPat GhcTc
+             -> CoreExpr        -- ^ the desugared rhs of the bind statement
+             -> SyntaxExpr GhcTc
+             -> SyntaxExpr GhcTc
+             -> Type            -- ^ S in (>>=) :: Q -> (R -> S) -> T
+             -> [ExprLStmt GhcTc]
+             -> DsM CoreExpr
+dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
+  = do  { body     <- dsMcStmts stmts
+        ; var      <- selectSimpleMatchVarL pat
+        ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
+                                  res1_ty (cantFailMatchResult body)
+        ; match_code <- handle_failure pat match fail_op
+        ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
+
+  where
+    -- In a monad comprehension expression, pattern-match failure just calls
+    -- the monadic `fail` rather than throwing an exception
+    handle_failure pat match fail_op
+      | matchCanFail match
+        = do { dflags <- getDynFlags
+             ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
+             ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
+             ; extractMatchResult match fail_expr }
+      | otherwise
+        = extractMatchResult match (error "It can't fail")
+
+    mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String
+    mk_fail_msg dflags pat
+        = "Pattern match failure in monad comprehension at " ++
+          showPpr dflags (getLoc pat)
+
+-- Desugar nested monad comprehensions, for example in `then..` constructs
+--    dsInnerMonadComp quals [a,b,c] ret_op
+-- returns the desugaring of
+--       [ (a,b,c) | quals ]
+
+dsInnerMonadComp :: [ExprLStmt GhcTc]
+                 -> [Id]               -- Return a tuple of these variables
+                 -> SyntaxExpr GhcTc   -- The monomorphic "return" operator
+                 -> DsM CoreExpr
+dsInnerMonadComp stmts bndrs ret_op
+  = dsMcStmts (stmts ++
+                 [noLoc (LastStmt noExt (mkBigLHsVarTupId bndrs) False ret_op)])
+
+
+-- The `unzip` function for `GroupStmt` in a monad comprehensions
+--
+--   unzip :: m (a,b,..) -> (m a,m b,..)
+--   unzip m_tuple = ( liftM selN1 m_tuple
+--                   , liftM selN2 m_tuple
+--                   , .. )
+--
+--   mkMcUnzipM fmap ys [t1, t2]
+--     = ( fmap (selN1 :: (t1, t2) -> t1) ys
+--       , fmap (selN2 :: (t1, t2) -> t2) ys )
+
+mkMcUnzipM :: TransForm
+           -> HsExpr GhcTcId    -- fmap
+           -> Id                -- Of type n (a,b,c)
+           -> [Type]            -- [a,b,c]   (not levity-polymorphic)
+           -> DsM CoreExpr      -- Of type (n a, n b, n c)
+mkMcUnzipM ThenForm _ ys _
+  = return (Var ys) -- No unzipping to do
+
+mkMcUnzipM _ fmap_op ys elt_tys
+  = do { fmap_op' <- dsExpr fmap_op
+       ; xs       <- mapM newSysLocalDs elt_tys
+       ; let tup_ty = mkBigCoreTupTy elt_tys
+       ; tup_xs   <- newSysLocalDs tup_ty
+
+       ; let mk_elt i = mkApps fmap_op'  -- fmap :: forall a b. (a -> b) -> n a -> n b
+                           [ Type tup_ty, Type (getNth elt_tys i)
+                           , mk_sel i, Var ys]
+
+             mk_sel n = Lam tup_xs $
+                        mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)
+
+       ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsMeta.hs
@@ -0,0 +1,2762 @@
+{-# LANGUAGE CPP, TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2006
+--
+-- The purpose of this module is to transform an HsExpr into a CoreExpr which
+-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the
+-- input HsExpr. We do this in the DsM monad, which supplies access to
+-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.
+--
+-- It also defines a bunch of knownKeyNames, in the same way as is done
+-- in prelude/PrelNames.  It's much more convenient to do it here, because
+-- otherwise we have to recompile PrelNames whenever we add a Name, which is
+-- a Royal Pain (triggers other recompilation).
+-----------------------------------------------------------------------------
+
+module DsMeta( dsBracket ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-}   DsExpr ( dsExpr )
+
+import MatchLit
+import DsMonad
+
+import qualified Language.Haskell.TH as TH
+
+import HsSyn
+import PrelNames
+-- To avoid clashes with DsMeta.varName we must make a local alias for
+-- OccName.varName we do this by removing varName from the import of
+-- OccName above, making a qualified instance of OccName and using
+-- OccNameAlias.varName where varName ws previously used in this file.
+import qualified OccName( isDataOcc, isVarOcc, isTcOcc )
+
+import Module
+import Id
+import Name hiding( isVarOcc, isTcOcc, varName, tcName )
+import THNames
+import NameEnv
+import NameSet
+import TcType
+import TyCon
+import TysWiredIn
+import CoreSyn
+import MkCore
+import CoreUtils
+import SrcLoc
+import Unique
+import BasicTypes
+import Outputable
+import Bag
+import DynFlags
+import FastString
+import ForeignCall
+import Util
+import Maybes
+import MonadUtils
+
+import Data.ByteString ( unpack )
+import Control.Monad
+import Data.List
+
+-----------------------------------------------------------------------------
+dsBracket :: HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr
+-- Returns a CoreExpr of type TH.ExpQ
+-- The quoted thing is parameterised over Name, even though it has
+-- been type checked.  We don't want all those type decorations!
+
+dsBracket brack splices
+  = dsExtendMetaEnv new_bit (do_brack brack)
+  where
+    new_bit = mkNameEnv [(n, DsSplice (unLoc e))
+                        | PendingTcSplice n e <- splices]
+
+    do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOcc n ; return e1 }
+    do_brack (ExpBr _ e)   = do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (PatBr _ p)   = do { MkC p1  <- repTopP p   ; return p1 }
+    do_brack (TypBr _ t)   = do { MkC t1  <- repLTy t    ; return t1 }
+    do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }
+    do_brack (DecBrL {})   = panic "dsBracket: unexpected DecBrL"
+    do_brack (TExpBr _ e)  = do { MkC e1  <- repLE e     ; return e1 }
+    do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket"
+
+{- -------------- Examples --------------------
+
+  [| \x -> x |]
+====>
+  gensym (unpackString "x"#) `bindQ` \ x1::String ->
+  lam (pvar x1) (var x1)
+
+
+  [| \x -> $(f [| x |]) |]
+====>
+  gensym (unpackString "x"#) `bindQ` \ x1::String ->
+  lam (pvar x1) (f (var x1))
+-}
+
+
+-------------------------------------------------------
+--                      Declarations
+-------------------------------------------------------
+
+repTopP :: LPat GhcRn -> DsM (Core TH.PatQ)
+repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
+                 ; pat' <- addBinds ss (repLP pat)
+                 ; wrapGenSyms ss pat' }
+
+repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec]))
+repTopDs group@(HsGroup { hs_valds   = valds
+                        , hs_splcds  = splcds
+                        , hs_tyclds  = tyclds
+                        , hs_derivds = derivds
+                        , hs_fixds   = fixds
+                        , hs_defds   = defds
+                        , hs_fords   = fords
+                        , hs_warnds  = warnds
+                        , hs_annds   = annds
+                        , hs_ruleds  = ruleds
+                        , hs_docs    = docs })
+ = do { let { bndrs  = hsScopedTvBinders valds
+                       ++ hsGroupBinders group
+                       ++ hsPatSynSelectors valds
+            ; instds = tyclds >>= group_instds } ;
+        ss <- mkGenSyms bndrs ;
+
+        -- Bind all the names mainly to avoid repeated use of explicit strings.
+        -- Thus we get
+        --      do { t :: String <- genSym "T" ;
+        --           return (Data t [] ...more t's... }
+        -- The other important reason is that the output must mention
+        -- only "T", not "Foo:T" where Foo is the current module
+
+        decls <- addBinds ss (
+                  do { val_ds   <- rep_val_binds valds
+                     ; _        <- mapM no_splice splcds
+                     ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)
+                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)
+                     ; inst_ds  <- mapM repInstD instds
+                     ; deriv_ds <- mapM repStandaloneDerivD derivds
+                     ; fix_ds   <- mapM repFixD fixds
+                     ; _        <- mapM no_default_decl defds
+                     ; for_ds   <- mapM repForD fords
+                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)
+                                                           warnds)
+                     ; ann_ds   <- mapM repAnnD annds
+                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)
+                                                            ruleds)
+                     ; _        <- mapM no_doc docs
+
+                        -- more needed
+                     ;  return (de_loc $ sort_by_loc $
+                                val_ds ++ catMaybes tycl_ds ++ role_ds
+                                       ++ (concat fix_ds)
+                                       ++ inst_ds ++ rule_ds ++ for_ds
+                                       ++ ann_ds ++ deriv_ds) }) ;
+
+        decl_ty <- lookupType decQTyConName ;
+        let { core_list = coreList' decl_ty decls } ;
+
+        dec_ty <- lookupType decTyConName ;
+        q_decs  <- repSequenceQ dec_ty core_list ;
+
+        wrapGenSyms ss q_decs
+      }
+  where
+    no_splice (dL->L loc _)
+      = notHandledL loc "Splices within declaration brackets" empty
+    no_default_decl (dL->L loc decl)
+      = notHandledL loc "Default declarations" (ppr decl)
+    no_warn (dL->L loc (Warning _ thing _))
+      = notHandledL loc "WARNING and DEPRECATION pragmas" $
+                    text "Pragma for declaration of" <+> ppr thing
+    no_warn _ = panic "repTopDs"
+    no_doc (dL->L loc _)
+      = notHandledL loc "Haddock documentation" empty
+repTopDs (XHsGroup _) = panic "repTopDs"
+
+hsScopedTvBinders :: HsValBinds GhcRn -> [Name]
+-- See Note [Scoped type variables in bindings]
+hsScopedTvBinders binds
+  = concatMap get_scoped_tvs sigs
+  where
+    sigs = case binds of
+             ValBinds           _ _ sigs  -> sigs
+             XValBindsLR (NValBinds _ sigs) -> sigs
+
+get_scoped_tvs :: LSig GhcRn -> [Name]
+get_scoped_tvs (dL->L _ signature)
+  | TypeSig _ _ sig <- signature
+  = get_scoped_tvs_from_sig (hswc_body sig)
+  | ClassOpSig _ _ _ sig <- signature
+  = get_scoped_tvs_from_sig sig
+  | PatSynSig _ _ sig <- signature
+  = get_scoped_tvs_from_sig sig
+  | otherwise
+  = []
+  where
+    get_scoped_tvs_from_sig sig
+      -- Both implicit and explicit quantified variables
+      -- We need the implicit ones for   f :: forall (a::k). blah
+      --    here 'k' scopes too
+      | HsIB { hsib_ext = implicit_vars
+             , hsib_body = hs_ty } <- sig
+      , (explicit_vars, _) <- splitLHsForAllTy hs_ty
+      = implicit_vars ++ map hsLTyVarName explicit_vars
+    get_scoped_tvs_from_sig (XHsImplicitBndrs _)
+      = panic "get_scoped_tvs_from_sig"
+
+{- Notes
+
+Note [Scoped type variables in bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f :: forall a. a -> a
+   f x = x::a
+Here the 'forall a' brings 'a' into scope over the binding group.
+To achieve this we
+
+  a) Gensym a binding for 'a' at the same time as we do one for 'f'
+     collecting the relevant binders with hsScopedTvBinders
+
+  b) When processing the 'forall', don't gensym
+
+The relevant places are signposted with references to this Note
+
+Note [Scoped type variables in class and instance declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Scoped type variables may occur in default methods and default
+signatures. We need to bring the type variables in 'foralls'
+into the scope of the method bindings.
+
+Consider
+   class Foo a where
+     foo :: forall (b :: k). a -> Proxy b -> Proxy b
+     foo _ x = (x :: Proxy b)
+
+We want to ensure that the 'b' in the type signature and the default
+implementation are the same, so we do the following:
+
+  a) Before desugaring the signature and binding of 'foo', use
+     get_scoped_tvs to collect type variables in 'forall' and
+     create symbols for them.
+  b) Use 'addBinds' to bring these symbols into the scope of the type
+     signatures and bindings.
+  c) Use these symbols to generate Core for the class/instance declaration.
+
+Note that when desugaring the signatures, we lookup the type variables
+from the scope rather than recreate symbols for them. See more details
+in "rep_ty_sig" and in Trac#14885.
+
+Note [Binders and occurrences]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we desugar [d| data T = MkT |]
+we want to get
+        Data "T" [] [Con "MkT" []] []
+and *not*
+        Data "Foo:T" [] [Con "Foo:MkT" []] []
+That is, the new data decl should fit into whatever new module it is
+asked to fit in.   We do *not* clone, though; no need for this:
+        Data "T79" ....
+
+But if we see this:
+        data T = MkT
+        foo = reifyDecl T
+
+then we must desugar to
+        foo = Data "Foo:T" [] [Con "Foo:MkT" []] []
+
+So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.
+And we use lookupOcc, rather than lookupBinder
+in repTyClD and repC.
+
+Note [Don't quantify implicit type variables in quotes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If you're not careful, it's suprisingly easy to take this quoted declaration:
+
+  [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b
+      idProxy x = x
+    |]
+
+and have Template Haskell turn it into this:
+
+  idProxy :: forall k proxy (b :: k). proxy b -> proxy b
+  idProxy x = x
+
+Notice that we explicitly quantified the variable `k`! The latter declaration
+isn't what the user wrote in the first place.
+
+Usually, the culprit behind these bugs is taking implicitly quantified type
+variables (often from the hsib_vars field of HsImplicitBinders) and putting
+them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.
+-}
+
+-- represent associated family instances
+--
+repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ))
+
+repTyClD (dL->L loc (FamDecl { tcdFam = fam })) = liftM Just $
+                                                  repFamilyDecl (L loc fam)
+
+repTyClD (dL->L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))
+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+                repSynDecl tc1 bndrs rhs
+       ; return (Just (loc, dec)) }
+
+repTyClD (dL->L loc (DataDecl { tcdLName = tc
+                              , tcdTyVars = tvs
+                              , tcdDataDefn = defn }))
+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+                repDataDefn tc1 (Left bndrs) defn
+       ; return (Just (loc, dec)) }
+
+repTyClD (dL->L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
+                             tcdTyVars = tvs, tcdFDs = fds,
+                             tcdSigs = sigs, tcdMeths = meth_binds,
+                             tcdATs = ats, tcdATDefs = atds }))
+  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]
+       ; dec  <- addTyVarBinds tvs $ \bndrs ->
+           do { cxt1   <- repLContext cxt
+          -- See Note [Scoped type variables in class and instance declarations]
+              ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds
+              ; fds1   <- repLFunDeps fds
+              ; ats1   <- repFamilyDecls ats
+              ; atds1  <- repAssocTyFamDefaults atds
+              ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs_binds)
+              ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1
+              ; wrapGenSyms ss decls2 }
+       ; return $ Just (loc, dec)
+       }
+
+repTyClD _ = panic "repTyClD"
+
+-------------------------
+repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repRoleD (dL->L loc (RoleAnnotDecl _ tycon roles))
+  = do { tycon1 <- lookupLOcc tycon
+       ; roles1 <- mapM repRole roles
+       ; roles2 <- coreList roleTyConName roles1
+       ; dec <- repRoleAnnotD tycon1 roles2
+       ; return (loc, dec) }
+repRoleD _ = panic "repRoleD"
+
+-------------------------
+repDataDefn :: Core TH.Name
+            -> Either (Core [TH.TyVarBndrQ])
+                        -- the repTyClD case
+                      (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
+                        -- the repDataFamInstD case
+            -> HsDataDefn GhcRn
+            -> DsM (Core TH.DecQ)
+repDataDefn tc opts
+          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig
+                      , dd_cons = cons, dd_derivs = mb_derivs })
+  = do { cxt1     <- repLContext cxt
+       ; derivs1  <- repDerivs mb_derivs
+       ; case (new_or_data, cons) of
+           (NewType, [con])  -> do { con'  <- repC con
+                                   ; ksig' <- repMaybeLTy ksig
+                                   ; repNewtype cxt1 tc opts ksig' con'
+                                                derivs1 }
+           (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"
+                                       <+> pprQuotedList
+                                       (getConNames $ unLoc $ head cons))
+           (DataType, _) -> do { ksig' <- repMaybeLTy ksig
+                               ; consL <- mapM repC cons
+                               ; cons1 <- coreList conQTyConName consL
+                               ; repData cxt1 tc opts ksig' cons1
+                                         derivs1 }
+       }
+repDataDefn _ _ (XHsDataDefn _) = panic "repDataDefn"
+
+repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]
+           -> LHsType GhcRn
+           -> DsM (Core TH.DecQ)
+repSynDecl tc bndrs ty
+  = do { ty1 <- repLTy ty
+       ; repTySyn tc bndrs ty1 }
+
+repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repFamilyDecl decl@(dL->L loc (FamilyDecl { fdInfo      = info
+                                          , fdLName     = tc
+                                          , fdTyVars    = tvs
+                                          , fdResultSig = dL->L _ resultSig
+                                          , fdInjectivityAnn = injectivity }))
+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]
+       ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn
+             mkHsQTvs tvs = HsQTvs { hsq_ext = HsQTvsRn
+                                                { hsq_implicit = []
+                                                , hsq_dependent = emptyNameSet }
+                                   , hsq_explicit = tvs }
+             resTyVar = case resultSig of
+                     TyVarSig _ bndr -> mkHsQTvs [bndr]
+                     _               -> mkHsQTvs []
+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->
+                addTyClTyVarBinds resTyVar $ \_ ->
+           case info of
+             ClosedTypeFamily Nothing ->
+                 notHandled "abstract closed type family" (ppr decl)
+             ClosedTypeFamily (Just eqns) ->
+               do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns
+                  ; eqns2  <- coreList tySynEqnQTyConName eqns1
+                  ; result <- repFamilyResultSig resultSig
+                  ; inj    <- repInjectivityAnn injectivity
+                  ; repClosedFamilyD tc1 bndrs result inj eqns2 }
+             OpenTypeFamily ->
+               do { result <- repFamilyResultSig resultSig
+                  ; inj    <- repInjectivityAnn injectivity
+                  ; repOpenFamilyD tc1 bndrs result inj }
+             DataFamily ->
+               do { kind <- repFamilyResultSigToMaybeKind resultSig
+                  ; repDataFamilyD tc1 bndrs kind }
+       ; return (loc, dec)
+       }
+repFamilyDecl _ = panic "repFamilyDecl"
+
+-- | Represent result signature of a type family
+repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)
+repFamilyResultSig (NoSig _)         = repNoSig
+repFamilyResultSig (KindSig _ ki)    = do { ki' <- repLTy ki
+                                          ; repKindSig ki' }
+repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr
+                                          ; repTyVarSig bndr' }
+repFamilyResultSig (XFamilyResultSig _) = panic "repFamilyResultSig"
+
+-- | Represent result signature using a Maybe Kind. Used with data families,
+-- where the result signature can be either missing or a kind but never a named
+-- result variable.
+repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn
+                              -> DsM (Core (Maybe TH.KindQ))
+repFamilyResultSigToMaybeKind (NoSig _) =
+    do { coreNothing kindQTyConName }
+repFamilyResultSigToMaybeKind (KindSig _ ki) =
+    do { ki' <- repLTy ki
+       ; coreJust kindQTyConName ki' }
+repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"
+
+-- | Represent injectivity annotation of a type family
+repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)
+                  -> DsM (Core (Maybe TH.InjectivityAnn))
+repInjectivityAnn Nothing =
+    do { coreNothing injAnnTyConName }
+repInjectivityAnn (Just (dL->L _ (InjectivityAnn lhs rhs))) =
+    do { lhs'   <- lookupBinder (unLoc lhs)
+       ; rhs1   <- mapM (lookupBinder . unLoc) rhs
+       ; rhs2   <- coreList nameTyConName rhs1
+       ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2]
+       ; coreJust injAnnTyConName injAnn }
+
+repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ]
+repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)
+
+repAssocTyFamDefaults :: [LTyFamDefltEqn GhcRn] -> DsM [Core TH.DecQ]
+repAssocTyFamDefaults = mapM rep_deflt
+  where
+     -- very like repTyFamEqn, but different in the details
+    rep_deflt :: LTyFamDefltEqn GhcRn -> DsM (Core TH.DecQ)
+    rep_deflt (dL->L _ (FamEqn { feqn_tycon = tc
+                               , feqn_bndrs = bndrs
+                               , feqn_pats  = tys
+                               , feqn_fixity = fixity
+                               , feqn_rhs   = rhs }))
+      = addTyClTyVarBinds tys $ \ _ ->
+        do { tc1  <- lookupLOcc tc
+           ; no_bndrs <- ASSERT( isNothing bndrs )
+                         coreNothingList tyVarBndrQTyConName
+           ; tys1 <- repLTys (hsLTyVarBndrsToTypes tys)
+           ; lhs <- case fixity of
+                      Prefix -> do { head_ty <- repNamedTyCon tc1
+                                   ; repTapps head_ty tys1 }
+                      Infix -> do { (t1:t2:args) <- checkTys tys1
+                                  ; head_ty <- repTInfix t1 tc1 t2
+                                  ; repTapps head_ty args }
+           ; rhs1 <- repLTy rhs
+           ; eqn1 <- repTySynEqn no_bndrs lhs rhs1
+           ; repTySynInst eqn1 }
+    rep_deflt _ = panic "repAssocTyFamDefaults"
+
+    checkTys :: [Core TH.TypeQ] -> DsM [Core TH.TypeQ]
+    checkTys tys@(_:_:_) = return tys
+    checkTys _ = panic "repAssocTyFamDefaults:checkTys"
+
+-------------------------
+-- represent fundeps
+--
+repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep])
+repLFunDeps fds = repList funDepTyConName repLFunDep fds
+
+repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep)
+repLFunDep (dL->L _ (xs, ys))
+   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs
+        ys' <- repList nameTyConName (lookupBinder . unLoc) ys
+        repFunDep xs' ys'
+
+-- Represent instance declarations
+--
+repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repInstD (dL->L loc (TyFamInstD { tfid_inst = fi_decl }))
+  = do { dec <- repTyFamInstD fi_decl
+       ; return (loc, dec) }
+repInstD (dL->L loc (DataFamInstD { dfid_inst = fi_decl }))
+  = do { dec <- repDataFamInstD fi_decl
+       ; return (loc, dec) }
+repInstD (dL->L loc (ClsInstD { cid_inst = cls_decl }))
+  = do { dec <- repClsInstD cls_decl
+       ; return (loc, dec) }
+repInstD _ = panic "repInstD"
+
+repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ)
+repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
+                         , cid_sigs = sigs, cid_tyfam_insts = ats
+                         , cid_datafam_insts = adts
+                         , cid_overlap_mode = overlap
+                         })
+  = addSimpleTyVarBinds tvs $
+            -- We must bring the type variables into scope, so their
+            -- occurrences don't fail, even though the binders don't
+            -- appear in the resulting data structure
+            --
+            -- But we do NOT bring the binders of 'binds' into scope
+            -- because they are properly regarded as occurrences
+            -- For example, the method names should be bound to
+            -- the selector Ids, not to fresh names (Trac #5410)
+            --
+            do { cxt1     <- repLContext cxt
+               ; inst_ty1 <- repLTy inst_ty
+          -- See Note [Scoped type variables in class and instance declarations]
+               ; (ss, sigs_binds) <- rep_sigs_binds sigs binds
+               ; ats1   <- mapM (repTyFamInstD . unLoc) ats
+               ; adts1  <- mapM (repDataFamInstD . unLoc) adts
+               ; decls1 <- coreList decQTyConName (ats1 ++ adts1 ++ sigs_binds)
+               ; rOver  <- repOverlap (fmap unLoc overlap)
+               ; decls2 <- repInst rOver cxt1 inst_ty1 decls1
+               ; wrapGenSyms ss decls2 }
+ where
+   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
+repClsInstD (XClsInstDecl _) = panic "repClsInstD"
+
+repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat
+                                          , deriv_type     = ty }))
+  = do { dec <- addSimpleTyVarBinds tvs $
+                do { cxt'     <- repLContext cxt
+                   ; strat'   <- repDerivStrategy strat
+                   ; inst_ty' <- repLTy inst_ty
+                   ; repDeriv strat' cxt' inst_ty' }
+       ; return (loc, dec) }
+  where
+    (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
+repStandaloneDerivD _ = panic "repStandaloneDerivD"
+
+repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
+repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
+  = do { eqn1 <- repTyFamEqn eqn
+       ; repTySynInst eqn1 }
+
+repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)
+repTyFamEqn (HsIB { hsib_ext = var_names
+                  , hsib_body = FamEqn { feqn_tycon = tc_name
+                                       , feqn_bndrs = mb_bndrs
+                                       , feqn_pats = tys
+                                       , feqn_fixity = fixity
+                                       , feqn_rhs  = rhs }})
+  = do { tc <- lookupLOcc tc_name     -- See note [Binders and occurrences]
+       ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
+                               { hsq_implicit = var_names
+                               , hsq_dependent = emptyNameSet }   -- Yuk
+                             , hsq_explicit = fromMaybe [] mb_bndrs }
+       ; addTyClTyVarBinds hs_tvs $ \ _ ->
+         do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
+                                        repTyVarBndr
+                                        mb_bndrs
+            ; tys1 <- case fixity of
+                        Prefix -> repTyArgs (repNamedTyCon tc) tys
+                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
+                                     ; t1' <- repLTy t1
+                                     ; t2'  <- repLTy t2
+                                     ; repTyArgs (repTInfix t1' tc t2') args }
+            ; rhs1 <- repLTy rhs
+            ; repTySynEqn mb_bndrs1 tys1 rhs1 } }
+     where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]
+           checkTys tys@(HsValArg _:HsValArg _:_) = return tys
+           checkTys _ = panic "repTyFamEqn:checkTys"
+repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"
+repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"
+
+repTyArgs :: DsM (Core TH.TypeQ) -> [LHsTypeArg GhcRn] -> DsM (Core TH.TypeQ)
+repTyArgs f [] = f
+repTyArgs f (HsValArg ty : as) = do { f' <- f
+                                    ; ty' <- repLTy ty
+                                    ; repTyArgs (repTapp f' ty') as }
+repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f
+                                       ; ki' <- repLTy ki
+                                       ; repTyArgs (repTappKind f' ki') as }
+repTyArgs f (HsArgPar _ : as) = repTyArgs f as
+
+repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)
+repDataFamInstD (DataFamInstDecl { dfid_eqn =
+                  (HsIB { hsib_ext = var_names
+                        , hsib_body = FamEqn { feqn_tycon = tc_name
+                                             , feqn_bndrs = mb_bndrs
+                                             , feqn_pats  = tys
+                                             , feqn_fixity = fixity
+                                             , feqn_rhs   = defn }})})
+  = do { tc <- lookupLOcc tc_name         -- See note [Binders and occurrences]
+       ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn
+                                 { hsq_implicit = var_names
+                                 , hsq_dependent = emptyNameSet }   -- Yuk
+                             , hsq_explicit = fromMaybe [] mb_bndrs }
+       ; addTyClTyVarBinds hs_tvs $ \ _ ->
+         do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName
+                                        repTyVarBndr
+                                        mb_bndrs
+            ; tys1 <- case fixity of
+                        Prefix -> repTyArgs (repNamedTyCon tc) tys
+                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys
+                                     ; t1' <- repLTy t1
+                                     ; t2'  <- repLTy t2
+                                     ; repTyArgs (repTInfix t1' tc t2') args }
+            ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }
+
+      where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]
+            checkTys tys@(HsValArg _: HsValArg _: _) = return tys
+            checkTys _ = panic "repDataFamInstD:checkTys"
+
+repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))
+  = panic "repDataFamInstD"
+repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))
+  = panic "repDataFamInstD"
+
+repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)
+repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ
+                                  , fd_fi = CImport (dL->L _ cc)
+                                                    (dL->L _ s) mch cis _ }))
+ = do MkC name' <- lookupLOcc name
+      MkC typ' <- repHsSigType typ
+      MkC cc' <- repCCallConv cc
+      MkC s' <- repSafety s
+      cis' <- conv_cimportspec cis
+      MkC str <- coreStringLit (static ++ chStr ++ cis')
+      dec <- rep2 forImpDName [cc', s', str, name', typ']
+      return (loc, dec)
+ where
+    conv_cimportspec (CLabel cls)
+      = notHandled "Foreign label" (doubleQuotes (ppr cls))
+    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
+    conv_cimportspec (CFunction (StaticTarget _ fs _ True))
+                            = return (unpackFS fs)
+    conv_cimportspec (CFunction (StaticTarget _ _  _ False))
+                            = panic "conv_cimportspec: values not supported yet"
+    conv_cimportspec CWrapper = return "wrapper"
+    -- these calling conventions do not support headers and the static keyword
+    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
+    static = case cis of
+                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
+                 _ -> ""
+    chStr = case mch of
+            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
+            _ -> ""
+repForD decl = notHandled "Foreign declaration" (ppr decl)
+
+repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
+repCCallConv CCallConv          = rep2 cCallName []
+repCCallConv StdCallConv        = rep2 stdCallName []
+repCCallConv CApiConv           = rep2 cApiCallName []
+repCCallConv PrimCallConv       = rep2 primCallName []
+repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
+
+repSafety :: Safety -> DsM (Core TH.Safety)
+repSafety PlayRisky = rep2 unsafeName []
+repSafety PlayInterruptible = rep2 interruptibleName []
+repSafety PlaySafe = rep2 safeName []
+
+repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
+repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir)))
+  = do { MkC prec' <- coreIntLit prec
+       ; let rep_fn = case dir of
+                        InfixL -> infixLDName
+                        InfixR -> infixRDName
+                        InfixN -> infixNDName
+       ; let do_one name
+              = do { MkC name' <- lookupLOcc name
+                   ; dec <- rep2 rep_fn [prec', name']
+                   ; return (loc,dec) }
+       ; mapM do_one names }
+repFixD _ = panic "repFixD"
+
+repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repRuleD (dL->L loc (HsRule { rd_name = n
+                            , rd_act = act
+                            , rd_tyvs = ty_bndrs
+                            , rd_tmvs = tm_bndrs
+                            , rd_lhs = lhs
+                            , rd_rhs = rhs }))
+  = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->
+         do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs
+            ; ss <- mkGenSyms tm_bndr_names
+            ; rule <- addBinds ss $
+                      do { ty_bndrs' <- case ty_bndrs of
+                             Nothing -> coreNothingList tyVarBndrQTyConName
+                             Just _  -> coreJustList tyVarBndrQTyConName
+                                          ex_bndrs
+                         ; tm_bndrs' <- repList ruleBndrQTyConName
+                                                repRuleBndr
+                                                tm_bndrs
+                         ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n
+                         ; act' <- repPhases act
+                         ; lhs' <- repLE lhs
+                         ; rhs' <- repLE rhs
+                         ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }
+           ; wrapGenSyms ss rule  }
+       ; return (loc, rule) }
+repRuleD _ = panic "repRuleD"
+
+ruleBndrNames :: LRuleBndr GhcRn -> [Name]
+ruleBndrNames (dL->L _ (RuleBndr _ n))      = [unLoc n]
+ruleBndrNames (dL->L _ (RuleBndrSig _ n sig))
+  | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig
+  = unLoc n : vars
+ruleBndrNames (dL->L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))
+  = panic "ruleBndrNames"
+ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))
+  = panic "ruleBndrNames"
+ruleBndrNames (dL->L _ (XRuleBndr _)) = panic "ruleBndrNames"
+ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884
+
+repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)
+repRuleBndr (dL->L _ (RuleBndr _ n))
+  = do { MkC n' <- lookupLBinder n
+       ; rep2 ruleVarName [n'] }
+repRuleBndr (dL->L _ (RuleBndrSig _ n sig))
+  = do { MkC n'  <- lookupLBinder n
+       ; MkC ty' <- repLTy (hsSigWcType sig)
+       ; rep2 typedRuleVarName [n', ty'] }
+repRuleBndr _ = panic "repRuleBndr"
+
+repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp)))
+  = do { target <- repAnnProv ann_prov
+       ; exp'   <- repE exp
+       ; dec    <- repPragAnn target exp'
+       ; return (loc, dec) }
+repAnnD _ = panic "repAnnD"
+
+repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)
+repAnnProv (ValueAnnProvenance (dL->L _ n))
+  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level
+       ; rep2 valueAnnotationName [ n' ] }
+repAnnProv (TypeAnnProvenance (dL->L _ n))
+  = do { MkC n' <- globalVar n
+       ; rep2 typeAnnotationName [ n' ] }
+repAnnProv ModuleAnnProvenance
+  = rep2 moduleAnnotationName []
+
+-------------------------------------------------------
+--                      Constructors
+-------------------------------------------------------
+
+repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)
+repC (dL->L _ (ConDeclH98 { con_name   = con
+                          , con_forall = (dL->L _ False)
+                          , con_mb_cxt = Nothing
+                          , con_args   = args }))
+  = repDataCon con args
+
+repC (dL->L _ (ConDeclH98 { con_name = con
+                          , con_forall = (dL->L _ is_existential)
+                          , con_ex_tvs = con_tvs
+                          , con_mb_cxt = mcxt
+                          , con_args = args }))
+  = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->
+         do { c'    <- repDataCon con args
+            ; ctxt' <- repMbContext mcxt
+            ; if not is_existential && isNothing mcxt
+              then return c'
+              else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])
+            }
+       }
+
+repC (dL->L _ (ConDeclGADT { con_names  = cons
+                           , con_qvars  = qtvs
+                           , con_mb_cxt = mcxt
+                           , con_args   = args
+                           , con_res_ty = res_ty }))
+  | isEmptyLHsQTvs qtvs  -- No implicit or explicit variables
+  , Nothing <- mcxt      -- No context
+                         -- ==> no need for a forall
+  = repGadtDataCons cons args res_ty
+
+  | otherwise
+  = addTyVarBinds qtvs $ \ ex_bndrs ->
+             -- See Note [Don't quantify implicit type variables in quotes]
+    do { c'    <- repGadtDataCons cons args res_ty
+       ; ctxt' <- repMbContext mcxt
+       ; if null (hsQTvExplicit qtvs) && isNothing mcxt
+         then return c'
+         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }
+
+repC _ = panic "repC"
+
+
+repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)
+repMbContext Nothing          = repContext []
+repMbContext (Just (dL->L _ cxt)) = repContext cxt
+
+repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
+repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []
+repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName       []
+repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []
+
+repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ)
+repSrcStrictness SrcLazy     = rep2 sourceLazyName         []
+repSrcStrictness SrcStrict   = rep2 sourceStrictName       []
+repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []
+
+repBangTy :: LBangType GhcRn -> DsM (Core (TH.BangTypeQ))
+repBangTy ty = do
+  MkC u <- repSrcUnpackedness su'
+  MkC s <- repSrcStrictness ss'
+  MkC b <- rep2 bangName [u, s]
+  MkC t <- repLTy ty'
+  rep2 bangTypeName [b, t]
+  where
+    (su', ss', ty') = case unLoc ty of
+            HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty)
+            _ -> (NoSrcUnpack, NoSrcStrict, ty)
+
+-------------------------------------------------------
+--                      Deriving clauses
+-------------------------------------------------------
+
+repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ])
+repDerivs (dL->L _ clauses)
+  = repList derivClauseQTyConName repDerivClause clauses
+
+repDerivClause :: LHsDerivingClause GhcRn
+               -> DsM (Core TH.DerivClauseQ)
+repDerivClause (dL->L _ (HsDerivingClause
+                          { deriv_clause_strategy = dcs
+                          , deriv_clause_tys      = (dL->L _ dct) }))
+  = do MkC dcs' <- repDerivStrategy dcs
+       MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct
+       rep2 derivClauseName [dcs',dct']
+  where
+    rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ)
+    rep_deriv_ty ty = repLTy ty
+repDerivClause _ = panic "repDerivClause"
+
+rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
+               -> DsM ([GenSymBind], [Core TH.DecQ])
+-- Represent signatures and methods in class/instance declarations.
+-- See Note [Scoped type variables in class and instance declarations]
+--
+-- Why not use 'repBinds': we have already created symbols for methods in
+-- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate
+-- these fun_id via 'collectHsValBinders decs', which would lead to the
+-- instance declarations failing in TH.
+rep_sigs_binds sigs binds
+  = do { let tvs = concatMap get_scoped_tvs sigs
+       ; ss <- mkGenSyms tvs
+       ; sigs1 <- addBinds ss $ rep_sigs sigs
+       ; binds1 <- addBinds ss $ rep_binds binds
+       ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) }
+
+-------------------------------------------------------
+--   Signatures in a class decl, or a group of bindings
+-------------------------------------------------------
+
+rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]
+        -- We silently ignore ones we don't recognise
+rep_sigs = concatMapM rep_sig
+
+rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_sig (dL->L loc (TypeSig _ nms ty))
+  = mapM (rep_wc_ty_sig sigDName loc ty) nms
+rep_sig (dL->L loc (PatSynSig _ nms ty))
+  = mapM (rep_patsyn_ty_sig loc ty) nms
+rep_sig (dL->L loc (ClassOpSig _ is_deflt nms ty))
+  | is_deflt     = mapM (rep_ty_sig defaultSigDName loc ty) nms
+  | otherwise    = mapM (rep_ty_sig sigDName loc ty) nms
+rep_sig d@(dL->L _ (IdSig {}))           = pprPanic "rep_sig IdSig" (ppr d)
+rep_sig (dL->L _   (FixSig {}))          = return [] -- fixity sigs at top level
+rep_sig (dL->L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc
+rep_sig (dL->L loc (SpecSig _ nm tys ispec))
+  = concatMapM (\t -> rep_specialise nm t ispec loc) tys
+rep_sig (dL->L loc (SpecInstSig _ _ ty))  = rep_specialiseInst ty loc
+rep_sig (dL->L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty
+rep_sig (dL->L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty
+rep_sig (dL->L loc (CompleteMatchSig _ _st cls mty))
+  = rep_complete_sig cls mty loc
+rep_sig _ = panic "rep_sig"
+
+rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name
+           -> DsM (SrcSpan, Core TH.DecQ)
+-- Don't create the implicit and explicit variables when desugaring signatures,
+-- see Note [Scoped type variables in class and instance declarations].
+-- and Note [Don't quantify implicit type variables in quotes]
+rep_ty_sig mk_sig loc sig_ty nm
+  | HsIB { hsib_body = hs_ty } <- sig_ty
+  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
+  = do { nm1 <- lookupLOcc nm
+       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
+                                     ; repTyVarBndrWithKind tv name }
+       ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv
+                                    explicit_tvs
+
+         -- NB: Don't pass any implicit type variables to repList above
+         -- See Note [Don't quantify implicit type variables in quotes]
+
+       ; th_ctxt <- repLContext ctxt
+       ; th_ty   <- repLTy ty
+       ; ty1     <- if null explicit_tvs && null (unLoc ctxt)
+                       then return th_ty
+                       else repTForall th_explicit_tvs th_ctxt th_ty
+       ; sig     <- repProto mk_sig nm1 ty1
+       ; return (loc, sig) }
+rep_ty_sig _ _ (XHsImplicitBndrs _) _ = panic "rep_ty_sig"
+
+rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name
+                  -> DsM (SrcSpan, Core TH.DecQ)
+-- represents a pattern synonym type signature;
+-- see Note [Pattern synonym type signatures and Template Haskell] in Convert
+--
+-- Don't create the implicit and explicit variables when desugaring signatures,
+-- see Note [Scoped type variables in class and instance declarations]
+-- and Note [Don't quantify implicit type variables in quotes]
+rep_patsyn_ty_sig loc sig_ty nm
+  | HsIB { hsib_body = hs_ty } <- sig_ty
+  , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty
+  = do { nm1 <- lookupLOcc nm
+       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
+                                     ; repTyVarBndrWithKind tv name }
+       ; th_univs <- repList tyVarBndrQTyConName rep_in_scope_tv univs
+       ; th_exis  <- repList tyVarBndrQTyConName rep_in_scope_tv exis
+
+         -- NB: Don't pass any implicit type variables to repList above
+         -- See Note [Don't quantify implicit type variables in quotes]
+
+       ; th_reqs  <- repLContext reqs
+       ; th_provs <- repLContext provs
+       ; th_ty    <- repLTy ty
+       ; ty1      <- repTForall th_univs th_reqs =<<
+                       repTForall th_exis th_provs th_ty
+       ; sig      <- repProto patSynSigDName nm1 ty1
+       ; return (loc, sig) }
+rep_patsyn_ty_sig _ (XHsImplicitBndrs _) _ = panic "rep_patsyn_ty_sig"
+
+rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name
+              -> DsM (SrcSpan, Core TH.DecQ)
+rep_wc_ty_sig mk_sig loc sig_ty nm
+  = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm
+
+rep_inline :: Located Name
+           -> InlinePragma      -- Never defaultInlinePragma
+           -> SrcSpan
+           -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_inline nm ispec loc
+  = do { nm1    <- lookupLOcc nm
+       ; inline <- repInline $ inl_inline ispec
+       ; rm     <- repRuleMatch $ inl_rule ispec
+       ; phases <- repPhases $ inl_act ispec
+       ; pragma <- repPragInl nm1 inline rm phases
+       ; return [(loc, pragma)]
+       }
+
+rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma
+               -> SrcSpan
+               -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_specialise nm ty ispec loc
+  = do { nm1 <- lookupLOcc nm
+       ; ty1 <- repHsSigType ty
+       ; phases <- repPhases $ inl_act ispec
+       ; let inline = inl_inline ispec
+       ; pragma <- if noUserInlineSpec inline
+                   then -- SPECIALISE
+                     repPragSpec nm1 ty1 phases
+                   else -- SPECIALISE INLINE
+                     do { inline1 <- repInline inline
+                        ; repPragSpecInl nm1 ty1 inline1 phases }
+       ; return [(loc, pragma)]
+       }
+
+rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan
+                   -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_specialiseInst ty loc
+  = do { ty1    <- repHsSigType ty
+       ; pragma <- repPragSpecInst ty1
+       ; return [(loc, pragma)] }
+
+repInline :: InlineSpec -> DsM (Core TH.Inline)
+repInline NoInline  = dataCon noInlineDataConName
+repInline Inline    = dataCon inlineDataConName
+repInline Inlinable = dataCon inlinableDataConName
+repInline spec      = notHandled "repInline" (ppr spec)
+
+repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)
+repRuleMatch ConLike = dataCon conLikeDataConName
+repRuleMatch FunLike = dataCon funLikeDataConName
+
+repPhases :: Activation -> DsM (Core TH.Phases)
+repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i
+                                  ; dataCon' beforePhaseDataConName [arg] }
+repPhases (ActiveAfter _ i)  = do { MkC arg <- coreIntLit i
+                                  ; dataCon' fromPhaseDataConName [arg] }
+repPhases _                  = dataCon allPhasesDataConName
+
+rep_complete_sig :: Located [Located Name]
+                 -> Maybe (Located Name)
+                 -> SrcSpan
+                 -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_complete_sig (dL->L _ cls) mty loc
+  = do { mty' <- repMaybe nameTyConName lookupLOcc mty
+       ; cls' <- repList nameTyConName lookupLOcc cls
+       ; sig <- repPragComplete cls' mty'
+       ; return [(loc, sig)] }
+
+-------------------------------------------------------
+--                      Types
+-------------------------------------------------------
+
+addSimpleTyVarBinds :: [Name]                -- the binders to be added
+                    -> DsM (Core (TH.Q a))   -- action in the ext env
+                    -> DsM (Core (TH.Q a))
+addSimpleTyVarBinds names thing_inside
+  = do { fresh_names <- mkGenSyms names
+       ; term <- addBinds fresh_names thing_inside
+       ; wrapGenSyms fresh_names term }
+
+addHsTyVarBinds :: [LHsTyVarBndr GhcRn]  -- the binders to be added
+                -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env
+                -> DsM (Core (TH.Q a))
+addHsTyVarBinds exp_tvs thing_inside
+  = do { fresh_exp_names <- mkGenSyms (map hsLTyVarName exp_tvs)
+       ; term <- addBinds fresh_exp_names $
+                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
+                                     (exp_tvs `zip` fresh_exp_names)
+                    ; thing_inside kbs }
+       ; wrapGenSyms fresh_exp_names term }
+  where
+    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
+
+addTyVarBinds :: LHsQTyVars GhcRn                    -- the binders to be added
+              -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env
+              -> DsM (Core (TH.Q a))
+-- gensym a list of type variables and enter them into the meta environment;
+-- the computations passed as the second argument is executed in that extended
+-- meta environment and gets the *new* names on Core-level as an argument
+addTyVarBinds (HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = imp_tvs}
+                      , hsq_explicit = exp_tvs })
+              thing_inside
+  = addSimpleTyVarBinds imp_tvs $
+    addHsTyVarBinds exp_tvs $
+    thing_inside
+addTyVarBinds (XLHsQTyVars _) _ = panic "addTyVarBinds"
+
+addTyClTyVarBinds :: LHsQTyVars GhcRn
+                  -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))
+                  -> DsM (Core (TH.Q a))
+
+-- Used for data/newtype declarations, and family instances,
+-- so that the nested type variables work right
+--    instance C (T a) where
+--      type W (T a) = blah
+-- The 'a' in the type instance is the one bound by the instance decl
+addTyClTyVarBinds tvs m
+  = do { let tv_names = hsAllLTyVarNames tvs
+       ; env <- dsGetMetaEnv
+       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)
+            -- Make fresh names for the ones that are not already in scope
+            -- This makes things work for family declarations
+
+       ; term <- addBinds freshNames $
+                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr
+                                     (hsQTvExplicit tvs)
+                    ; m kbs }
+
+       ; wrapGenSyms freshNames term }
+  where
+    mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
+    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)
+                       ; repTyVarBndrWithKind tv v }
+
+-- Produce kinded binder constructors from the Haskell tyvar binders
+--
+repTyVarBndrWithKind :: LHsTyVarBndr GhcRn
+                     -> Core TH.Name -> DsM (Core TH.TyVarBndrQ)
+repTyVarBndrWithKind (dL->L _ (UserTyVar _ _)) nm
+  = repPlainTV nm
+repTyVarBndrWithKind (dL->L _ (KindedTyVar _ _ ki)) nm
+  = repLTy ki >>= repKindedTV nm
+repTyVarBndrWithKind _ _ = panic "repTyVarBndrWithKind"
+
+-- | Represent a type variable binder
+repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)
+repTyVarBndr (dL->L _ (UserTyVar _ (dL->L _ nm)) )
+  = do { nm' <- lookupBinder nm
+       ; repPlainTV nm' }
+repTyVarBndr (dL->L _ (KindedTyVar _ (dL->L _ nm) ki))
+  = do { nm' <- lookupBinder nm
+       ; ki' <- repLTy ki
+       ; repKindedTV nm' ki' }
+repTyVarBndr _ = panic "repTyVarBndr"
+
+-- represent a type context
+--
+repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ)
+repLContext ctxt = repContext (unLoc ctxt)
+
+repContext :: HsContext GhcRn -> DsM (Core TH.CxtQ)
+repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt
+                     repCtxt preds
+
+repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)
+repHsSigType (HsIB { hsib_ext = implicit_tvs
+                   , hsib_body = body })
+  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy body
+  = addSimpleTyVarBinds implicit_tvs $
+      -- See Note [Don't quantify implicit type variables in quotes]
+    addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->
+    do { th_ctxt <- repLContext ctxt
+       ; th_ty   <- repLTy ty
+       ; if null explicit_tvs && null (unLoc ctxt)
+         then return th_ty
+         else repTForall th_explicit_tvs th_ctxt th_ty }
+repHsSigType (XHsImplicitBndrs _) = panic "repHsSigType"
+
+repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ)
+repHsSigWcType (HsWC { hswc_body = sig1 })
+  = repHsSigType sig1
+repHsSigWcType (XHsWildCardBndrs _) = panic "repHsSigWcType"
+
+-- yield the representation of a list of types
+repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ]
+repLTys tys = mapM repLTy tys
+
+-- represent a type
+repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ)
+repLTy ty = repTy (unLoc ty)
+
+repForall :: HsType GhcRn -> DsM (Core TH.TypeQ)
+-- Arg of repForall is always HsForAllTy or HsQualTy
+repForall ty
+ | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
+ = addHsTyVarBinds tvs $ \bndrs ->
+   do { ctxt1  <- repLContext ctxt
+      ; ty1    <- repLTy tau
+      ; repTForall bndrs ctxt1 ty1 }
+
+repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)
+repTy ty@(HsForAllTy {}) = repForall ty
+repTy ty@(HsQualTy {})   = repForall ty
+
+repTy (HsTyVar _ _ (dL->L _ n))
+  | isLiftedTypeKindTyConName n       = repTStar
+  | n `hasKey` constraintKindTyConKey = repTConstraint
+  | n `hasKey` funTyConKey            = repArrowTyCon
+  | isTvOcc occ   = do tv1 <- lookupOcc n
+                       repTvar tv1
+  | isDataOcc occ = do tc1 <- lookupOcc n
+                       repPromotedDataCon tc1
+  | n == eqTyConName = repTequality
+  | otherwise     = do tc1 <- lookupOcc n
+                       repNamedTyCon tc1
+  where
+    occ = nameOccName n
+
+repTy (HsAppTy _ f a)       = do
+                                f1 <- repLTy f
+                                a1 <- repLTy a
+                                repTapp f1 a1
+repTy (HsAppKindTy _ ty ki) = do
+                                ty1 <- repLTy ty
+                                ki1 <- repLTy ki
+                                repTappKind ty1 ki1
+repTy (HsFunTy _ f a)       = do
+                                f1   <- repLTy f
+                                a1   <- repLTy a
+                                tcon <- repArrowTyCon
+                                repTapps tcon [f1, a1]
+repTy (HsListTy _ t)        = do
+                                t1   <- repLTy t
+                                tcon <- repListTyCon
+                                repTapp tcon t1
+repTy (HsTupleTy _ HsUnboxedTuple tys) = do
+                                tys1 <- repLTys tys
+                                tcon <- repUnboxedTupleTyCon (length tys)
+                                repTapps tcon tys1
+repTy (HsTupleTy _ _ tys)   = do tys1 <- repLTys tys
+                                 tcon <- repTupleTyCon (length tys)
+                                 repTapps tcon tys1
+repTy (HsSumTy _ tys)       = do tys1 <- repLTys tys
+                                 tcon <- repUnboxedSumTyCon (length tys)
+                                 repTapps tcon tys1
+repTy (HsOpTy _ ty1 n ty2)  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)
+                                   `nlHsAppTy` ty2)
+repTy (HsParTy _ t)         = repLTy t
+repTy (HsStarTy _ _) =  repTStar
+repTy (HsKindSig _ t k)     = do
+                                t1 <- repLTy t
+                                k1 <- repLTy k
+                                repTSig t1 k1
+repTy (HsSpliceTy _ splice)      = repSplice splice
+repTy (HsExplicitListTy _ _ tys) = do
+                                    tys1 <- repLTys tys
+                                    repTPromotedList tys1
+repTy (HsExplicitTupleTy _ tys) = do
+                                    tys1 <- repLTys tys
+                                    tcon <- repPromotedTupleTyCon (length tys)
+                                    repTapps tcon tys1
+repTy (HsTyLit _ lit) = do
+                          lit' <- repTyLit lit
+                          repTLit lit'
+repTy (HsWildCardTy _) = repTWildCard
+repTy (HsIParamTy _ n t) = do
+                             n' <- rep_implicit_param_name (unLoc n)
+                             t' <- repLTy t
+                             repTImplicitParam n' t'
+
+repTy ty                      = notHandled "Exotic form of type" (ppr ty)
+
+repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)
+repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i
+                            rep2 numTyLitName [iExpr]
+repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s
+                            ; rep2 strTyLitName [s']
+                            }
+
+-- | Represent a type wrapped in a Maybe
+repMaybeLTy :: Maybe (LHsKind GhcRn)
+            -> DsM (Core (Maybe TH.TypeQ))
+repMaybeLTy = repMaybe kindQTyConName repLTy
+
+repRole :: Located (Maybe Role) -> DsM (Core TH.Role)
+repRole (dL->L _ (Just Nominal))          = rep2 nominalRName []
+repRole (dL->L _ (Just Representational)) = rep2 representationalRName []
+repRole (dL->L _ (Just Phantom))          = rep2 phantomRName []
+repRole (dL->L _ Nothing)                 = rep2 inferRName []
+repRole _ = panic "repRole: Impossible Match" -- due to #15884
+
+-----------------------------------------------------------------------------
+--              Splices
+-----------------------------------------------------------------------------
+
+repSplice :: HsSplice GhcRn -> DsM (Core a)
+-- See Note [How brackets and nested splices are handled] in TcSplice
+-- We return a CoreExpr of any old type; the context should know
+repSplice (HsTypedSplice   _ _ n _) = rep_splice n
+repSplice (HsUntypedSplice _ _ n _) = rep_splice n
+repSplice (HsQuasiQuote _ n _ _ _)  = rep_splice n
+repSplice e@(HsSpliced {})          = pprPanic "repSplice" (ppr e)
+repSplice e@(HsSplicedT {})         = pprPanic "repSpliceT" (ppr e)
+repSplice e@(XSplice {})            = pprPanic "repSplice" (ppr e)
+
+rep_splice :: Name -> DsM (Core a)
+rep_splice splice_name
+ = do { mb_val <- dsLookupMetaEnv splice_name
+       ; case mb_val of
+           Just (DsSplice e) -> do { e' <- dsExpr e
+                                   ; return (MkC e') }
+           _ -> pprPanic "HsSplice" (ppr splice_name) }
+                        -- Should not happen; statically checked
+
+-----------------------------------------------------------------------------
+--              Expressions
+-----------------------------------------------------------------------------
+
+repLEs :: [LHsExpr GhcRn] -> DsM (Core [TH.ExpQ])
+repLEs es = repList expQTyConName repLE es
+
+-- FIXME: some of these panics should be converted into proper error messages
+--        unless we can make sure that constructs, which are plainly not
+--        supported in TH already lead to error messages at an earlier stage
+repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)
+repLE (dL->L loc e) = putSrcSpanDs loc (repE e)
+
+repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)
+repE (HsVar _ (dL->L _ x)) =
+  do { mb_val <- dsLookupMetaEnv x
+     ; case mb_val of
+        Nothing            -> do { str <- globalVar x
+                                 ; repVarOrCon x str }
+        Just (DsBound y)   -> repVarOrCon x (coreVar y)
+        Just (DsSplice e)  -> do { e' <- dsExpr e
+                                 ; return (MkC e') } }
+repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
+repE (HsOverLabel _ _ s) = repOverLabel s
+
+repE e@(HsRecFld _ f) = case f of
+  Unambiguous x _ -> repE (HsVar noExt (noLoc x))
+  Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)
+  XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e)
+
+        -- Remember, we're desugaring renamer output here, so
+        -- HsOverlit can definitely occur
+repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
+repE (HsLit _ l)     = do { a <- repLiteral l;           repLit a }
+repE (HsLam _ (MG { mg_alts = (dL->L _ [m]) })) = repLambda m
+repE (HsLamCase _ (MG { mg_alts = (dL->L _ ms) }))
+                   = do { ms' <- mapM repMatchTup ms
+                        ; core_ms <- coreList matchQTyConName ms'
+                        ; repLamCase core_ms }
+repE (HsApp _ x y)   = do {a <- repLE x; b <- repLE y; repApp a b}
+repE (HsAppType _ e t) = do { a <- repLE e
+                            ; s <- repLTy (hswc_body t)
+                            ; repAppType a s }
+
+repE (OpApp _ e1 op e2) =
+  do { arg1 <- repLE e1;
+       arg2 <- repLE e2;
+       the_op <- repLE op ;
+       repInfixApp arg1 the_op arg2 }
+repE (NegApp _ x _)      = do
+                              a         <- repLE x
+                              negateVar <- lookupOcc negateName >>= repVar
+                              negateVar `repApp` a
+repE (HsPar _ x)            = repLE x
+repE (SectionL _ x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }
+repE (SectionR _ x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }
+repE (HsCase _ e (MG { mg_alts = (dL->L _ ms) }))
+                          = do { arg <- repLE e
+                               ; ms2 <- mapM repMatchTup ms
+                               ; core_ms2 <- coreList matchQTyConName ms2
+                               ; repCaseE arg core_ms2 }
+repE (HsIf _ _ x y z)       = do
+                              a <- repLE x
+                              b <- repLE y
+                              c <- repLE z
+                              repCond a b c
+repE (HsMultiIf _ alts)
+  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
+       ; expr' <- repMultiIf (nonEmptyCoreList alts')
+       ; wrapGenSyms (concat binds) expr' }
+repE (HsLet _ (dL->L _ bs) e)       = do { (ss,ds) <- repBinds bs
+                                     ; e2 <- addBinds ss (repLE e)
+                                     ; z <- repLetE ds e2
+                                     ; wrapGenSyms ss z }
+
+-- FIXME: I haven't got the types here right yet
+repE e@(HsDo _ ctxt (dL->L _ sts))
+ | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
+ = do { (ss,zs) <- repLSts sts;
+        e'      <- repDoE (nonEmptyCoreList zs);
+        wrapGenSyms ss e' }
+
+ | ListComp <- ctxt
+ = do { (ss,zs) <- repLSts sts;
+        e'      <- repComp (nonEmptyCoreList zs);
+        wrapGenSyms ss e' }
+
+ | MDoExpr <- ctxt
+ = do { (ss,zs) <- repLSts sts;
+        e'      <- repMDoE (nonEmptyCoreList zs);
+        wrapGenSyms ss e' }
+
+  | otherwise
+  = notHandled "monad comprehension and [: :]" (ppr e)
+
+repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
+repE e@(ExplicitTuple _ es boxed)
+  | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
+  | isBoxed boxed = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
+                       ; repTup xs }
+  | otherwise     = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]
+                       ; repUnboxedTup xs }
+
+repE (ExplicitSum _ alt arity e)
+ = do { e1 <- repLE e
+      ; repUnboxedSum e1 alt arity }
+
+repE (RecordCon { rcon_con_name = c, rcon_flds = flds })
+ = do { x <- lookupLOcc c;
+        fs <- repFields flds;
+        repRecCon x fs }
+repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
+ = do { x <- repLE e;
+        fs <- repUpdFields flds;
+        repRecUpd x fs }
+
+repE (ExprWithTySig _ e ty)
+  = do { e1 <- repLE e
+       ; t1 <- repHsSigWcType ty
+       ; repSigExp e1 t1 }
+
+repE (ArithSeq _ _ aseq) =
+  case aseq of
+    From e              -> do { ds1 <- repLE e; repFrom ds1 }
+    FromThen e1 e2      -> do
+                             ds1 <- repLE e1
+                             ds2 <- repLE e2
+                             repFromThen ds1 ds2
+    FromTo   e1 e2      -> do
+                             ds1 <- repLE e1
+                             ds2 <- repLE e2
+                             repFromTo ds1 ds2
+    FromThenTo e1 e2 e3 -> do
+                             ds1 <- repLE e1
+                             ds2 <- repLE e2
+                             ds3 <- repLE e3
+                             repFromThenTo ds1 ds2 ds3
+
+repE (HsSpliceE _ splice)  = repSplice splice
+repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC
+repE (HsUnboundVar _ uv)   = do
+                               occ   <- occNameLit (unboundVarOcc uv)
+                               sname <- repNameS occ
+                               repUnboundVar sname
+
+repE e@(HsCoreAnn {})      = notHandled "Core annotations" (ppr e)
+repE e@(HsSCC {})          = notHandled "Cost centres" (ppr e)
+repE e@(HsTickPragma {})   = notHandled "Tick Pragma" (ppr e)
+repE e                     = notHandled "Expression form" (ppr e)
+
+-----------------------------------------------------------------------------
+-- Building representations of auxillary structures like Match, Clause, Stmt,
+
+repMatchTup ::  LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)
+repMatchTup (dL->L _ (Match { m_pats = [p]
+                            , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =
+  do { ss1 <- mkGenSyms (collectPatBinders p)
+     ; addBinds ss1 $ do {
+     ; p1 <- repLP p
+     ; (ss2,ds) <- repBinds wheres
+     ; addBinds ss2 $ do {
+     ; gs    <- repGuards guards
+     ; match <- repMatch p1 gs ds
+     ; wrapGenSyms (ss1++ss2) match }}}
+repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
+
+repClauseTup ::  LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)
+repClauseTup (dL->L _ (Match { m_pats = ps
+                             , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =
+  do { ss1 <- mkGenSyms (collectPatsBinders ps)
+     ; addBinds ss1 $ do {
+       ps1 <- repLPs ps
+     ; (ss2,ds) <- repBinds wheres
+     ; addBinds ss2 $ do {
+       gs <- repGuards guards
+     ; clause <- repClause ps1 gs ds
+     ; wrapGenSyms (ss1++ss2) clause }}}
+repClauseTup (dL->L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup"
+repClauseTup _ = panic "repClauseTup"
+
+repGuards ::  [LGRHS GhcRn (LHsExpr GhcRn)] ->  DsM (Core TH.BodyQ)
+repGuards [dL->L _ (GRHS _ [] e)]
+  = do {a <- repLE e; repNormal a }
+repGuards other
+  = do { zs <- mapM repLGRHS other
+       ; let (xs, ys) = unzip zs
+       ; gd <- repGuarded (nonEmptyCoreList ys)
+       ; wrapGenSyms (concat xs) gd }
+
+repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)
+         -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))
+repLGRHS (dL->L _ (GRHS _ [dL->L _ (BodyStmt _ e1 _ _)] e2))
+  = do { guarded <- repLNormalGE e1 e2
+       ; return ([], guarded) }
+repLGRHS (dL->L _ (GRHS _ ss rhs))
+  = do { (gs, ss') <- repLSts ss
+       ; rhs' <- addBinds gs $ repLE rhs
+       ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'
+       ; return (gs, guarded) }
+repLGRHS _ = panic "repLGRHS"
+
+repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp])
+repFields (HsRecFields { rec_flds = flds })
+  = repList fieldExpQTyConName rep_fld flds
+  where
+    rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)
+            -> DsM (Core (TH.Q TH.FieldExp))
+    rep_fld (dL->L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)
+                               ; e  <- repLE (hsRecFieldArg fld)
+                               ; repFieldExp fn e }
+
+repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp])
+repUpdFields = repList fieldExpQTyConName rep_fld
+  where
+    rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))
+    rep_fld (dL->L l fld) = case unLoc (hsRecFieldLbl fld) of
+      Unambiguous sel_name _ -> do { fn <- lookupLOcc (cL l sel_name)
+                                   ; e  <- repLE (hsRecFieldArg fld)
+                                   ; repFieldExp fn e }
+      _                      -> notHandled "Ambiguous record updates" (ppr fld)
+
+
+
+-----------------------------------------------------------------------------
+-- Representing Stmt's is tricky, especially if bound variables
+-- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]
+-- First gensym new names for every variable in any of the patterns.
+-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))
+-- if variables didn't shaddow, the static gensym wouldn't be necessary
+-- and we could reuse the original names (x and x).
+--
+-- do { x'1 <- gensym "x"
+--    ; x'2 <- gensym "x"
+--    ; doE [ BindSt (pvar x'1) [| f 1 |]
+--          , BindSt (pvar x'2) [| f x |]
+--          , NoBindSt [| g x |]
+--          ]
+--    }
+
+-- The strategy is to translate a whole list of do-bindings by building a
+-- bigger environment, and a bigger set of meta bindings
+-- (like:  x'1 <- gensym "x" ) and then combining these with the translations
+-- of the expressions within the Do
+
+-----------------------------------------------------------------------------
+-- The helper function repSts computes the translation of each sub expression
+-- and a bunch of prefix bindings denoting the dynamic renaming.
+
+repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
+repLSts stmts = repSts (map unLoc stmts)
+
+repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])
+repSts (BindStmt _ p e _ _ : ss) =
+   do { e2 <- repLE e
+      ; ss1 <- mkGenSyms (collectPatBinders p)
+      ; addBinds ss1 $ do {
+      ; p1 <- repLP p;
+      ; (ss2,zs) <- repSts ss
+      ; z <- repBindSt p1 e2
+      ; return (ss1++ss2, z : zs) }}
+repSts (LetStmt _ (dL->L _ bs) : ss) =
+   do { (ss1,ds) <- repBinds bs
+      ; z <- repLetSt ds
+      ; (ss2,zs) <- addBinds ss1 (repSts ss)
+      ; return (ss1++ss2, z : zs) }
+repSts (BodyStmt _ e _ _ : ss) =
+   do { e2 <- repLE e
+      ; z <- repNoBindSt e2
+      ; (ss2,zs) <- repSts ss
+      ; return (ss2, z : zs) }
+repSts (ParStmt _ stmt_blocks _ _ : ss) =
+   do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
+      ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
+            ss1 = concat ss_s
+      ; z <- repParSt stmt_blocks2
+      ; (ss2, zs) <- addBinds ss1 (repSts ss)
+      ; return (ss1++ss2, z : zs) }
+   where
+     rep_stmt_block :: ParStmtBlock GhcRn GhcRn
+                    -> DsM ([GenSymBind], Core [TH.StmtQ])
+     rep_stmt_block (ParStmtBlock _ stmts _ _) =
+       do { (ss1, zs) <- repSts (map unLoc stmts)
+          ; zs1 <- coreList stmtQTyConName zs
+          ; return (ss1, zs1) }
+     rep_stmt_block (XParStmtBlock{}) = panic "repSts"
+repSts [LastStmt _ e _ _]
+  = do { e2 <- repLE e
+       ; z <- repNoBindSt e2
+       ; return ([], [z]) }
+repSts (stmt@RecStmt{} : ss)
+  = do { let binders = collectLStmtsBinders (recS_stmts stmt)
+       ; ss1 <- mkGenSyms binders
+       -- Bring all of binders in the recursive group into scope for the
+       -- whole group.
+       ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt))
+       ; MASSERT(sort ss1 == sort ss1_other)
+       ; z <- repRecSt (nonEmptyCoreList rss)
+       ; (ss2,zs) <- addBinds ss1 (repSts ss)
+       ; return (ss1++ss2, z : zs) }
+repSts []    = return ([],[])
+repSts other = notHandled "Exotic statement" (ppr other)
+
+
+-----------------------------------------------------------
+--                      Bindings
+-----------------------------------------------------------
+
+repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ])
+repBinds (EmptyLocalBinds _)
+  = do  { core_list <- coreList decQTyConName []
+        ; return ([], core_list) }
+
+repBinds (HsIPBinds _ (IPBinds _ decs))
+ = do   { ips <- mapM rep_implicit_param_bind decs
+        ; core_list <- coreList decQTyConName
+                                (de_loc (sort_by_loc ips))
+        ; return ([], core_list)
+        }
+
+repBinds b@(HsIPBinds _ XHsIPBinds {})
+ = notHandled "Implicit parameter binds extension" (ppr b)
+
+repBinds (HsValBinds _ decs)
+ = do   { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }
+                -- No need to worry about detailed scopes within
+                -- the binding group, because we are talking Names
+                -- here, so we can safely treat it as a mutually
+                -- recursive group
+                -- For hsScopedTvBinders see Note [Scoped type variables in bindings]
+        ; ss        <- mkGenSyms bndrs
+        ; prs       <- addBinds ss (rep_val_binds decs)
+        ; core_list <- coreList decQTyConName
+                                (de_loc (sort_by_loc prs))
+        ; return (ss, core_list) }
+repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)
+
+rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+rep_implicit_param_bind (dL->L loc (IPBind _ ename (dL->L _ rhs)))
+ = do { name <- case ename of
+                    Left (dL->L _ n) -> rep_implicit_param_name n
+                    Right _ ->
+                        panic "rep_implicit_param_bind: post typechecking"
+      ; rhs' <- repE rhs
+      ; ipb <- repImplicitParamBind name rhs'
+      ; return (loc, ipb) }
+rep_implicit_param_bind (dL->L _ b@(XIPBind _))
+ = notHandled "Implicit parameter bind extension" (ppr b)
+rep_implicit_param_bind _ = panic "rep_implicit_param_bind: Impossible Match"
+                            -- due to #15884
+
+rep_implicit_param_name :: HsIPName -> DsM (Core String)
+rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)
+
+rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
+-- Assumes: all the binders of the binding are already in the meta-env
+rep_val_binds (XValBindsLR (NValBinds binds sigs))
+ = do { core1 <- rep_binds (unionManyBags (map snd binds))
+      ; core2 <- rep_sigs sigs
+      ; return (core1 ++ core2) }
+rep_val_binds (ValBinds _ _ _)
+ = panic "rep_val_binds: ValBinds"
+
+rep_binds :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]
+rep_binds = mapM rep_bind . bagToList
+
+rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)
+-- Assumes: all the binders of the binding are already in the meta-env
+
+-- Note GHC treats declarations of a variable (not a pattern)
+-- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match
+-- with an empty list of patterns
+rep_bind (dL->L loc (FunBind
+                 { fun_id = fn,
+                   fun_matches = MG { mg_alts
+                           = (dL->L _ [dL->L _ (Match
+                                       { m_pats = []
+                                       , m_grhss = GRHSs _ guards
+                                                     (dL->L _ wheres) }
+                                      )]) } }))
+ = do { (ss,wherecore) <- repBinds wheres
+        ; guardcore <- addBinds ss (repGuards guards)
+        ; fn'  <- lookupLBinder fn
+        ; p    <- repPvar fn'
+        ; ans  <- repVal p guardcore wherecore
+        ; ans' <- wrapGenSyms ss ans
+        ; return (loc, ans') }
+
+rep_bind (dL->L loc (FunBind { fun_id = fn
+                             , fun_matches = MG { mg_alts = (dL->L _ ms) } }))
+ =   do { ms1 <- mapM repClauseTup ms
+        ; fn' <- lookupLBinder fn
+        ; ans <- repFun fn' (nonEmptyCoreList ms1)
+        ; return (loc, ans) }
+
+rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind"
+
+rep_bind (dL->L loc (PatBind { pat_lhs = pat
+                             , pat_rhs = GRHSs _ guards (dL->L _ wheres) }))
+ =   do { patcore <- repLP pat
+        ; (ss,wherecore) <- repBinds wheres
+        ; guardcore <- addBinds ss (repGuards guards)
+        ; ans  <- repVal patcore guardcore wherecore
+        ; ans' <- wrapGenSyms ss ans
+        ; return (loc, ans') }
+rep_bind (dL->L _ (PatBind _ _ (XGRHSs _) _)) = panic "rep_bind"
+
+rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e}))
+ =   do { v' <- lookupBinder v
+        ; e2 <- repLE e
+        ; x <- repNormal e2
+        ; patcore <- repPvar v'
+        ; empty_decls <- coreList decQTyConName []
+        ; ans <- repVal patcore x empty_decls
+        ; return (srcLocSpan (getSrcLoc v), ans) }
+
+rep_bind (dL->L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"
+rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id   = syn
+                                       , psb_args = args
+                                       , psb_def  = pat
+                                       , psb_dir  = dir })))
+  = do { syn'      <- lookupLBinder syn
+       ; dir'      <- repPatSynDir dir
+       ; ss        <- mkGenArgSyms args
+       ; patSynD'  <- addBinds ss (
+         do { args'  <- repPatSynArgs args
+            ; pat'   <- repLP pat
+            ; repPatSynD syn' args' dir' pat' })
+       ; patSynD'' <- wrapGenArgSyms args ss patSynD'
+       ; return (loc, patSynD'') }
+  where
+    mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind]
+    -- for Record Pattern Synonyms we want to conflate the selector
+    -- and the pattern-only names in order to provide a nicer TH
+    -- API. Whereas inside GHC, record pattern synonym selectors and
+    -- their pattern-only bound right hand sides have different names,
+    -- we want to treat them the same in TH. This is the reason why we
+    -- need an adjusted mkGenArgSyms in the `RecCon` case below.
+    mkGenArgSyms (PrefixCon args)     = mkGenSyms (map unLoc args)
+    mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
+    mkGenArgSyms (RecCon fields)
+      = do { let pats = map (unLoc . recordPatSynPatVar) fields
+                 sels = map (unLoc . recordPatSynSelectorId) fields
+           ; ss <- mkGenSyms sels
+           ; return $ replaceNames (zip sels pats) ss }
+
+    replaceNames selsPats genSyms
+      = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats
+                    , sel == sel' ]
+
+    wrapGenArgSyms :: HsPatSynDetails (Located Name)
+                   -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)
+    wrapGenArgSyms (RecCon _) _  dec = return dec
+    wrapGenArgSyms _          ss dec = wrapGenSyms ss dec
+
+rep_bind (dL->L _ (PatSynBind _ (XPatSynBind _)))
+  = panic "rep_bind: XPatSynBind"
+rep_bind (dL->L _ (XHsBindsLR {}))  = panic "rep_bind: XHsBindsLR"
+rep_bind _                          = panic "rep_bind: Impossible match!"
+                                      -- due to #15884
+
+repPatSynD :: Core TH.Name
+           -> Core TH.PatSynArgsQ
+           -> Core TH.PatSynDirQ
+           -> Core TH.PatQ
+           -> DsM (Core TH.DecQ)
+repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
+  = rep2 patSynDName [syn, args, dir, pat]
+
+repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)
+repPatSynArgs (PrefixCon args)
+  = do { args' <- repList nameTyConName lookupLOcc args
+       ; repPrefixPatSynArgs args' }
+repPatSynArgs (InfixCon arg1 arg2)
+  = do { arg1' <- lookupLOcc arg1
+       ; arg2' <- lookupLOcc arg2
+       ; repInfixPatSynArgs arg1' arg2' }
+repPatSynArgs (RecCon fields)
+  = do { sels' <- repList nameTyConName lookupLOcc sels
+       ; repRecordPatSynArgs sels' }
+  where sels = map recordPatSynSelectorId fields
+
+repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ)
+repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]
+
+repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ)
+repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]
+
+repRecordPatSynArgs :: Core [TH.Name]
+                    -> DsM (Core TH.PatSynArgsQ)
+repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]
+
+repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ)
+repPatSynDir Unidirectional        = rep2 unidirPatSynName []
+repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []
+repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) }))
+  = do { clauses' <- mapM repClauseTup clauses
+       ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }
+repPatSynDir (ExplicitBidirectional (XMatchGroup _)) = panic "repPatSynDir"
+
+repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)
+repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]
+
+
+-----------------------------------------------------------------------------
+-- Since everything in a Bind is mutually recursive we need rename all
+-- all the variables simultaneously. For example:
+-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to
+-- do { f'1 <- gensym "f"
+--    ; g'2 <- gensym "g"
+--    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},
+--        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}
+--      ]}
+-- This requires collecting the bindings (f'1 <- gensym "f"), and the
+-- environment ( f |-> f'1 ) from each binding, and then unioning them
+-- together. As we do this we collect GenSymBinds's which represent the renamed
+-- variables bound by the Bindings. In order not to lose track of these
+-- representations we build a shadow datatype MB with the same structure as
+-- MonoBinds, but which has slots for the representations
+
+
+-----------------------------------------------------------------------------
+-- GHC allows a more general form of lambda abstraction than specified
+-- by Haskell 98. In particular it allows guarded lambda's like :
+-- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in
+-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like
+-- (\ p1 .. pn -> exp) by causing an error.
+
+repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)
+repLambda (dL->L _ (Match { m_pats = ps
+                          , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] e)]
+                                              (dL->L _ (EmptyLocalBinds _)) } ))
+ = do { let bndrs = collectPatsBinders ps ;
+      ; ss  <- mkGenSyms bndrs
+      ; lam <- addBinds ss (
+                do { xs <- repLPs ps; body <- repLE e; repLam xs body })
+      ; wrapGenSyms ss lam }
+
+repLambda (dL->L _ m) = notHandled "Guarded labmdas" (pprMatch m)
+
+
+-----------------------------------------------------------------------------
+--                      Patterns
+-- repP deals with patterns.  It assumes that we have already
+-- walked over the pattern(s) once to collect the binders, and
+-- have extended the environment.  So every pattern-bound
+-- variable should already appear in the environment.
+
+-- Process a list of patterns
+repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ])
+repLPs ps = repList patQTyConName repLP ps
+
+repLP :: LPat GhcRn -> DsM (Core TH.PatQ)
+repLP p = repP (unLoc p)
+
+repP :: Pat GhcRn -> DsM (Core TH.PatQ)
+repP (WildPat _)        = repPwild
+repP (LitPat _ l)       = do { l2 <- repLiteral l; repPlit l2 }
+repP (VarPat _ x)       = do { x' <- lookupBinder (unLoc x); repPvar x' }
+repP (LazyPat _ p)      = do { p1 <- repLP p; repPtilde p1 }
+repP (BangPat _ p)      = do { p1 <- repLP p; repPbang p1 }
+repP (AsPat _ x p)      = do { x' <- lookupLBinder x; p1 <- repLP p
+                             ; repPaspat x' p1 }
+repP (ParPat _ p)       = repLP p
+repP (ListPat Nothing ps)  = do { qs <- repLPs ps; repPlist qs }
+repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps)
+                                ; e' <- repE (syn_expr e)
+                                ; repPview e' p}
+repP (TuplePat _ ps boxed)
+  | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }
+  | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }
+repP (SumPat _ p alt arity) = do { p1 <- repLP p
+                                 ; repPunboxedSum p1 alt arity }
+repP (ConPatIn dc details)
+ = do { con_str <- lookupLOcc dc
+      ; case details of
+         PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }
+         RecCon rec   -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)
+                            ; repPrec con_str fps }
+         InfixCon p1 p2 -> do { p1' <- repLP p1;
+                                p2' <- repLP p2;
+                                repPinfix p1' con_str p2' }
+   }
+ where
+   rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ))
+   rep_fld (dL->L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)
+                              ; MkC p <- repLP (hsRecFieldArg fld)
+                              ; rep2 fieldPatName [v,p] }
+
+repP (NPat _ (dL->L _ l) Nothing _) = do { a <- repOverloadedLiteral l
+                                         ; repPlit a }
+repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
+repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
+repP (SigPat _ p t) = do { p' <- repLP p
+                         ; t' <- repLTy (hsSigWcType t)
+                         ; repPsig p' t' }
+repP (SplicePat _ splice) = repSplice splice
+
+repP other = notHandled "Exotic pattern" (ppr other)
+
+----------------------------------------------------------
+-- Declaration ordering helpers
+
+sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]
+sort_by_loc xs = sortBy comp xs
+    where comp x y = compare (fst x) (fst y)
+
+de_loc :: [(a, b)] -> [b]
+de_loc = map snd
+
+----------------------------------------------------------
+--      The meta-environment
+
+-- A name/identifier association for fresh names of locally bound entities
+type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id
+                                -- I.e.         (x, x_id) means
+                                --      let x_id = gensym "x" in ...
+
+-- Generate a fresh name for a locally bound entity
+
+mkGenSyms :: [Name] -> DsM [GenSymBind]
+-- We can use the existing name.  For example:
+--      [| \x_77 -> x_77 + x_77 |]
+-- desugars to
+--      do { x_77 <- genSym "x"; .... }
+-- We use the same x_77 in the desugared program, but with the type Bndr
+-- instead of Int
+--
+-- We do make it an Internal name, though (hence localiseName)
+--
+-- Nevertheless, it's monadic because we have to generate nameTy
+mkGenSyms ns = do { var_ty <- lookupType nameTyConName
+                  ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }
+
+
+addBinds :: [GenSymBind] -> DsM a -> DsM a
+-- Add a list of fresh names for locally bound entities to the
+-- meta environment (which is part of the state carried around
+-- by the desugarer monad)
+addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m
+
+-- Look up a locally bound name
+--
+lookupLBinder :: Located Name -> DsM (Core TH.Name)
+lookupLBinder n = lookupBinder (unLoc n)
+
+lookupBinder :: Name -> DsM (Core TH.Name)
+lookupBinder = lookupOcc
+  -- Binders are brought into scope before the pattern or what-not is
+  -- desugared.  Moreover, in instance declaration the binder of a method
+  -- will be the selector Id and hence a global; so we need the
+  -- globalVar case of lookupOcc
+
+-- Look up a name that is either locally bound or a global name
+--
+--  * If it is a global name, generate the "original name" representation (ie,
+--   the <module>:<name> form) for the associated entity
+--
+lookupLOcc :: Located Name -> DsM (Core TH.Name)
+-- Lookup an occurrence; it can't be a splice.
+-- Use the in-scope bindings if they exist
+lookupLOcc n = lookupOcc (unLoc n)
+
+lookupOcc :: Name -> DsM (Core TH.Name)
+lookupOcc n
+  = do {  mb_val <- dsLookupMetaEnv n ;
+          case mb_val of
+                Nothing           -> globalVar n
+                Just (DsBound x)  -> return (coreVar x)
+                Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)
+    }
+
+globalVar :: Name -> DsM (Core TH.Name)
+-- Not bound by the meta-env
+-- Could be top-level; or could be local
+--      f x = $(g [| x |])
+-- Here the x will be local
+globalVar name
+  | isExternalName name
+  = do  { MkC mod <- coreStringLit name_mod
+        ; MkC pkg <- coreStringLit name_pkg
+        ; MkC occ <- nameLit name
+        ; rep2 mk_varg [pkg,mod,occ] }
+  | otherwise
+  = do  { MkC occ <- nameLit name
+        ; MkC uni <- coreIntLit (getKey (getUnique name))
+        ; rep2 mkNameLName [occ,uni] }
+  where
+      mod = ASSERT( isExternalName name) nameModule name
+      name_mod = moduleNameString (moduleName mod)
+      name_pkg = unitIdString (moduleUnitId mod)
+      name_occ = nameOccName name
+      mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
+              | OccName.isVarOcc  name_occ = mkNameG_vName
+              | OccName.isTcOcc   name_occ = mkNameG_tcName
+              | otherwise                  = pprPanic "DsMeta.globalVar" (ppr name)
+
+lookupType :: Name      -- Name of type constructor (e.g. TH.ExpQ)
+           -> DsM Type  -- The type
+lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;
+                          return (mkTyConApp tc []) }
+
+wrapGenSyms :: [GenSymBind]
+            -> Core (TH.Q a) -> DsM (Core (TH.Q a))
+-- wrapGenSyms [(nm1,id1), (nm2,id2)] y
+--      --> bindQ (gensym nm1) (\ id1 ->
+--          bindQ (gensym nm2 (\ id2 ->
+--          y))
+
+wrapGenSyms binds body@(MkC b)
+  = do  { var_ty <- lookupType nameTyConName
+        ; go var_ty binds }
+  where
+    [elt_ty] = tcTyConAppArgs (exprType b)
+        -- b :: Q a, so we can get the type 'a' by looking at the
+        -- argument type. NB: this relies on Q being a data/newtype,
+        -- not a type synonym
+
+    go _ [] = return body
+    go var_ty ((name,id) : binds)
+      = do { MkC body'  <- go var_ty binds
+           ; lit_str    <- nameLit name
+           ; gensym_app <- repGensym lit_str
+           ; repBindQ var_ty elt_ty
+                      gensym_app (MkC (Lam id body')) }
+
+nameLit :: Name -> DsM (Core String)
+nameLit n = coreStringLit (occNameString (nameOccName n))
+
+occNameLit :: OccName -> DsM (Core String)
+occNameLit name = coreStringLit (occNameString name)
+
+
+-- %*********************************************************************
+-- %*                                                                   *
+--              Constructing code
+-- %*                                                                   *
+-- %*********************************************************************
+
+-----------------------------------------------------------------------------
+-- PHANTOM TYPES for consistency. In order to make sure we do this correct
+-- we invent a new datatype which uses phantom types.
+
+newtype Core a = MkC CoreExpr
+unC :: Core a -> CoreExpr
+unC (MkC x) = x
+
+rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)
+rep2 n xs = do { id <- dsLookupGlobalId n
+               ; return (MkC (foldl' App (Var id) xs)) }
+
+dataCon' :: Name -> [CoreExpr] -> DsM (Core a)
+dataCon' n args = do { id <- dsLookupDataCon n
+                     ; return $ MkC $ mkCoreConApps id args }
+
+dataCon :: Name -> DsM (Core a)
+dataCon n = dataCon' n []
+
+
+-- %*********************************************************************
+-- %*                                                                   *
+--              The 'smart constructors'
+-- %*                                                                   *
+-- %*********************************************************************
+
+--------------- Patterns -----------------
+repPlit   :: Core TH.Lit -> DsM (Core TH.PatQ)
+repPlit (MkC l) = rep2 litPName [l]
+
+repPvar :: Core TH.Name -> DsM (Core TH.PatQ)
+repPvar (MkC s) = rep2 varPName [s]
+
+repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPtup (MkC ps) = rep2 tupPName [ps]
+
+repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]
+
+repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ)
+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
+repPunboxedSum (MkC p) alt arity
+ = do { dflags <- getDynFlags
+      ; rep2 unboxedSumPName [ p
+                             , mkIntExprInt dflags alt
+                             , mkIntExprInt dflags arity ] }
+
+repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]
+
+repPrec   :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)
+repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]
+
+repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]
+
+repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)
+repPtilde (MkC p) = rep2 tildePName [p]
+
+repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)
+repPbang (MkC p) = rep2 bangPName [p]
+
+repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]
+
+repPwild  :: DsM (Core TH.PatQ)
+repPwild = rep2 wildPName []
+
+repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)
+repPlist (MkC ps) = rep2 listPName [ps]
+
+repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)
+repPview (MkC e) (MkC p) = rep2 viewPName [e,p]
+
+repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)
+repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]
+
+--------------- Expressions -----------------
+repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)
+repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str
+                   | otherwise                  = repVar str
+
+repVar :: Core TH.Name -> DsM (Core TH.ExpQ)
+repVar (MkC s) = rep2 varEName [s]
+
+repCon :: Core TH.Name -> DsM (Core TH.ExpQ)
+repCon (MkC s) = rep2 conEName [s]
+
+repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)
+repLit (MkC c) = rep2 litEName [c]
+
+repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repApp (MkC x) (MkC y) = rep2 appEName [x,y]
+
+repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
+repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]
+
+repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]
+
+repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)
+repLamCase (MkC ms) = rep2 lamCaseEName [ms]
+
+repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repTup (MkC es) = rep2 tupEName [es]
+
+repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]
+
+repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)
+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here
+repUnboxedSum (MkC e) alt arity
+ = do { dflags <- getDynFlags
+      ; rep2 unboxedSumEName [ e
+                             , mkIntExprInt dflags alt
+                             , mkIntExprInt dflags arity ] }
+
+repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]
+
+repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)
+repMultiIf (MkC alts) = rep2 multiIfEName [alts]
+
+repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]
+
+repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)
+repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]
+
+repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repDoE (MkC ss) = rep2 doEName [ss]
+
+repMDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repMDoE (MkC ss) = rep2 mdoEName [ss]
+
+repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)
+repComp (MkC ss) = rep2 compEName [ss]
+
+repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)
+repListExp (MkC es) = rep2 listEName [es]
+
+repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)
+repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]
+
+repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)
+repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]
+
+repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)
+repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]
+
+repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))
+repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]
+
+repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]
+
+repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]
+
+repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]
+
+repImplicitParamVar :: Core String -> DsM (Core TH.ExpQ)
+repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]
+
+------------ Right hand sides (guarded expressions) ----
+repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)
+repGuarded (MkC pairs) = rep2 guardedBName [pairs]
+
+repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)
+repNormal (MkC e) = rep2 normalBName [e]
+
+------------ Guards ----
+repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn
+             -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repLNormalGE g e = do g' <- repLE g
+                      e' <- repLE e
+                      repNormalGE g' e'
+
+repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]
+
+repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))
+repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]
+
+------------- Stmts -------------------
+repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]
+
+repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)
+repLetSt (MkC ds) = rep2 letSName [ds]
+
+repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)
+repNoBindSt (MkC e) = rep2 noBindSName [e]
+
+repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)
+repParSt (MkC sss) = rep2 parSName [sss]
+
+repRecSt :: Core [TH.StmtQ] -> DsM (Core TH.StmtQ)
+repRecSt (MkC ss) = rep2 recSName [ss]
+
+-------------- Range (Arithmetic sequences) -----------
+repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFrom (MkC x) = rep2 fromEName [x]
+
+repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]
+
+repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]
+
+repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)
+repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]
+
+------------ Match and Clause Tuples -----------
+repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)
+repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]
+
+repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)
+repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]
+
+-------------- Dec -----------------------------
+repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]
+
+repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)
+repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]
+
+repData :: Core TH.CxtQ -> Core TH.Name
+        -> Either (Core [TH.TyVarBndrQ])
+                  (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
+        -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ]
+        -> DsM (Core TH.DecQ)
+repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)
+  = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]
+repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)
+        (MkC derivs)
+  = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs]
+
+repNewtype :: Core TH.CxtQ -> Core TH.Name
+           -> Either (Core [TH.TyVarBndrQ])
+                     (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)
+           -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ]
+           -> DsM (Core TH.DecQ)
+repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)
+           (MkC derivs)
+  = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]
+repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con)
+           (MkC derivs)
+  = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs]
+
+repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]
+         -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repTySyn (MkC nm) (MkC tvs) (MkC rhs)
+  = rep2 tySynDName [nm, tvs, rhs]
+
+repInst :: Core (Maybe TH.Overlap) ->
+           Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)
+repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
+                                                              [o, cxt, ty, ds]
+
+repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
+                 -> DsM (Core (Maybe TH.DerivStrategyQ))
+repDerivStrategy mds =
+  case mds of
+    Nothing -> nothing
+    Just ds ->
+      case unLoc ds of
+        StockStrategy    -> just =<< repStockStrategy
+        AnyclassStrategy -> just =<< repAnyclassStrategy
+        NewtypeStrategy  -> just =<< repNewtypeStrategy
+        ViaStrategy ty   -> do ty' <- repLTy (hsSigType ty)
+                               via_strat <- repViaStrategy ty'
+                               just via_strat
+  where
+  nothing = coreNothing derivStrategyQTyConName
+  just    = coreJust    derivStrategyQTyConName
+
+repStockStrategy :: DsM (Core TH.DerivStrategyQ)
+repStockStrategy = rep2 stockStrategyName []
+
+repAnyclassStrategy :: DsM (Core TH.DerivStrategyQ)
+repAnyclassStrategy = rep2 anyclassStrategyName []
+
+repNewtypeStrategy :: DsM (Core TH.DerivStrategyQ)
+repNewtypeStrategy = rep2 newtypeStrategyName []
+
+repViaStrategy :: Core TH.TypeQ -> DsM (Core TH.DerivStrategyQ)
+repViaStrategy (MkC t) = rep2 viaStrategyName [t]
+
+repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))
+repOverlap mb =
+  case mb of
+    Nothing -> nothing
+    Just o ->
+      case o of
+        NoOverlap _    -> nothing
+        Overlappable _ -> just =<< dataCon overlappableDataConName
+        Overlapping _  -> just =<< dataCon overlappingDataConName
+        Overlaps _     -> just =<< dataCon overlapsDataConName
+        Incoherent _   -> just =<< dataCon incoherentDataConName
+  where
+  nothing = coreNothing overlapTyConName
+  just    = coreJust overlapTyConName
+
+
+repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]
+         -> Core [TH.FunDep] -> Core [TH.DecQ]
+         -> DsM (Core TH.DecQ)
+repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
+  = rep2 classDName [cxt, cls, tvs, fds, ds]
+
+repDeriv :: Core (Maybe TH.DerivStrategyQ)
+         -> Core TH.CxtQ -> Core TH.TypeQ
+         -> DsM (Core TH.DecQ)
+repDeriv (MkC ds) (MkC cxt) (MkC ty)
+  = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
+
+repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
+           -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)
+  = rep2 pragInlDName [nm, inline, rm, phases]
+
+repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases
+            -> DsM (Core TH.DecQ)
+repPragSpec (MkC nm) (MkC ty) (MkC phases)
+  = rep2 pragSpecDName [nm, ty, phases]
+
+repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline
+               -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)
+  = rep2 pragSpecInlDName [nm, ty, inline, phases]
+
+repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)
+repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]
+
+repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)
+repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]
+
+repPragRule :: Core String -> Core (Maybe [TH.TyVarBndrQ])
+            -> Core [TH.RuleBndrQ] -> Core TH.ExpQ -> Core TH.ExpQ
+            -> Core TH.Phases -> DsM (Core TH.DecQ)
+repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases)
+  = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases]
+
+repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)
+repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
+
+repTySynInst :: Core TH.TySynEqnQ -> DsM (Core TH.DecQ)
+repTySynInst (MkC eqn)
+    = rep2 tySynInstDName [eqn]
+
+repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ]
+               -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ)
+repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)
+    = rep2 dataFamilyDName [nm, tvs, kind]
+
+repOpenFamilyD :: Core TH.Name
+               -> Core [TH.TyVarBndrQ]
+               -> Core TH.FamilyResultSigQ
+               -> Core (Maybe TH.InjectivityAnn)
+               -> DsM (Core TH.DecQ)
+repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)
+    = rep2 openTypeFamilyDName [nm, tvs, result, inj]
+
+repClosedFamilyD :: Core TH.Name
+                 -> Core [TH.TyVarBndrQ]
+                 -> Core TH.FamilyResultSigQ
+                 -> Core (Maybe TH.InjectivityAnn)
+                 -> Core [TH.TySynEqnQ]
+                 -> DsM (Core TH.DecQ)
+repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)
+    = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]
+
+repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) ->
+               Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)
+repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)
+  = rep2 tySynEqnName [mb_bndrs, lhs, rhs]
+
+repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)
+repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]
+
+repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)
+repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]
+
+repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)
+repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]
+
+repImplicitParamBind :: Core String -> Core TH.ExpQ -> DsM (Core TH.DecQ)
+repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]
+
+repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)
+repCtxt (MkC tys) = rep2 cxtName [tys]
+
+repDataCon :: Located Name
+           -> HsConDeclDetails GhcRn
+           -> DsM (Core TH.ConQ)
+repDataCon con details
+    = do con' <- lookupLOcc con -- See Note [Binders and occurrences]
+         repConstr details Nothing [con']
+
+repGadtDataCons :: [Located Name]
+                -> HsConDeclDetails GhcRn
+                -> LHsType GhcRn
+                -> DsM (Core TH.ConQ)
+repGadtDataCons cons details res_ty
+    = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]
+         repConstr details (Just res_ty) cons'
+
+-- Invariant:
+--   * for plain H98 data constructors second argument is Nothing and third
+--     argument is a singleton list
+--   * for GADTs data constructors second argument is (Just return_type) and
+--     third argument is a non-empty list
+repConstr :: HsConDeclDetails GhcRn
+          -> Maybe (LHsType GhcRn)
+          -> [Core TH.Name]
+          -> DsM (Core TH.ConQ)
+repConstr (PrefixCon ps) Nothing [con]
+    = do arg_tys  <- repList bangTypeQTyConName repBangTy ps
+         rep2 normalCName [unC con, unC arg_tys]
+
+repConstr (PrefixCon ps) (Just res_ty) cons
+    = do arg_tys     <- repList bangTypeQTyConName repBangTy ps
+         res_ty' <- repLTy res_ty
+         rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']
+
+repConstr (RecCon ips) resTy cons
+    = do args     <- concatMapM rep_ip (unLoc ips)
+         arg_vtys <- coreList varBangTypeQTyConName args
+         case resTy of
+           Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
+           Just res_ty -> do
+             res_ty' <- repLTy res_ty
+             rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,
+                                unC res_ty']
+
+    where
+      rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)
+
+      rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a)
+      rep_one_ip t n = do { MkC v  <- lookupOcc (extFieldOcc $ unLoc n)
+                          ; MkC ty <- repBangTy  t
+                          ; rep2 varBangTypeName [v,ty] }
+
+repConstr (InfixCon st1 st2) Nothing [con]
+    = do arg1 <- repBangTy st1
+         arg2 <- repBangTy st2
+         rep2 infixCName [unC arg1, unC con, unC arg2]
+
+repConstr (InfixCon {}) (Just _) _ =
+    panic "repConstr: infix GADT constructor should be in a PrefixCon"
+repConstr _ _ _ =
+    panic "repConstr: invariant violated"
+
+------------ Types -------------------
+
+repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ
+           -> DsM (Core TH.TypeQ)
+repTForall (MkC tvars) (MkC ctxt) (MkC ty)
+    = rep2 forallTName [tvars, ctxt, ty]
+
+repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)
+repTvar (MkC s) = rep2 varTName [s]
+
+repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]
+
+repTappKind :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)
+repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki]
+
+repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
+repTapps f []     = return f
+repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }
+
+repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)
+repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]
+
+repTequality :: DsM (Core TH.TypeQ)
+repTequality = rep2 equalityTName []
+
+repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)
+repTPromotedList []     = repPromotedNilTyCon
+repTPromotedList (t:ts) = do  { tcon <- repPromotedConsTyCon
+                              ; f <- repTapp tcon t
+                              ; t' <- repTPromotedList ts
+                              ; repTapp f t'
+                              }
+
+repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)
+repTLit (MkC lit) = rep2 litTName [lit]
+
+repTWildCard :: DsM (Core TH.TypeQ)
+repTWildCard = rep2 wildCardTName []
+
+repTImplicitParam :: Core String -> Core TH.TypeQ -> DsM (Core TH.TypeQ)
+repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]
+
+repTStar :: DsM (Core TH.TypeQ)
+repTStar = rep2 starKName []
+
+repTConstraint :: DsM (Core TH.TypeQ)
+repTConstraint = rep2 constraintKName []
+
+--------- Type constructors --------------
+
+repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)
+repNamedTyCon (MkC s) = rep2 conTName [s]
+
+repTInfix :: Core TH.TypeQ -> Core TH.Name -> Core TH.TypeQ
+             -> DsM (Core TH.TypeQ)
+repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2]
+
+repTupleTyCon :: Int -> DsM (Core TH.TypeQ)
+-- Note: not Core Int; it's easier to be direct here
+repTupleTyCon i = do dflags <- getDynFlags
+                     rep2 tupleTName [mkIntExprInt dflags i]
+
+repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
+-- Note: not Core Int; it's easier to be direct here
+repUnboxedTupleTyCon i = do dflags <- getDynFlags
+                            rep2 unboxedTupleTName [mkIntExprInt dflags i]
+
+repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ)
+-- Note: not Core TH.SumArity; it's easier to be direct here
+repUnboxedSumTyCon arity = do dflags <- getDynFlags
+                              rep2 unboxedSumTName [mkIntExprInt dflags arity]
+
+repArrowTyCon :: DsM (Core TH.TypeQ)
+repArrowTyCon = rep2 arrowTName []
+
+repListTyCon :: DsM (Core TH.TypeQ)
+repListTyCon = rep2 listTName []
+
+repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ)
+repPromotedDataCon (MkC s) = rep2 promotedTName [s]
+
+repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)
+repPromotedTupleTyCon i = do dflags <- getDynFlags
+                             rep2 promotedTupleTName [mkIntExprInt dflags i]
+
+repPromotedNilTyCon :: DsM (Core TH.TypeQ)
+repPromotedNilTyCon = rep2 promotedNilTName []
+
+repPromotedConsTyCon :: DsM (Core TH.TypeQ)
+repPromotedConsTyCon = rep2 promotedConsTName []
+
+------------ TyVarBndrs -------------------
+
+repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ)
+repPlainTV (MkC nm) = rep2 plainTVName [nm]
+
+repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ)
+repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]
+
+----------------------------------------------------------
+--       Type family result signature
+
+repNoSig :: DsM (Core TH.FamilyResultSigQ)
+repNoSig = rep2 noSigName []
+
+repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ)
+repKindSig (MkC ki) = rep2 kindSigName [ki]
+
+repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ)
+repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]
+
+----------------------------------------------------------
+--              Literals
+
+repLiteral :: HsLit GhcRn -> DsM (Core TH.Lit)
+repLiteral (HsStringPrim _ bs)
+  = do dflags   <- getDynFlags
+       word8_ty <- lookupType word8TyConName
+       let w8s = unpack bs
+           w8s_expr = map (\w8 -> mkCoreConApps word8DataCon
+                                  [mkWordLit dflags (toInteger w8)]) w8s
+       rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]
+repLiteral lit
+  = do lit' <- case lit of
+                   HsIntPrim _ i    -> mk_integer i
+                   HsWordPrim _ w   -> mk_integer w
+                   HsInt _ i        -> mk_integer (il_value i)
+                   HsFloatPrim _ r  -> mk_rational r
+                   HsDoublePrim _ r -> mk_rational r
+                   HsCharPrim _ c   -> mk_char c
+                   _ -> return lit
+       lit_expr <- dsLit lit'
+       case mb_lit_name of
+          Just lit_name -> rep2 lit_name [lit_expr]
+          Nothing -> notHandled "Exotic literal" (ppr lit)
+  where
+    mb_lit_name = case lit of
+                 HsInteger _ _ _  -> Just integerLName
+                 HsInt _ _        -> Just integerLName
+                 HsIntPrim _ _    -> Just intPrimLName
+                 HsWordPrim _ _   -> Just wordPrimLName
+                 HsFloatPrim _ _  -> Just floatPrimLName
+                 HsDoublePrim _ _ -> Just doublePrimLName
+                 HsChar _ _       -> Just charLName
+                 HsCharPrim _ _   -> Just charPrimLName
+                 HsString _ _     -> Just stringLName
+                 HsRat _ _ _      -> Just rationalLName
+                 _                -> Nothing
+
+mk_integer :: Integer -> DsM (HsLit GhcRn)
+mk_integer  i = do integer_ty <- lookupType integerTyConName
+                   return $ HsInteger NoSourceText i integer_ty
+
+mk_rational :: FractionalLit -> DsM (HsLit GhcRn)
+mk_rational r = do rat_ty <- lookupType rationalTyConName
+                   return $ HsRat noExt r rat_ty
+mk_string :: FastString -> DsM (HsLit GhcRn)
+mk_string s = return $ HsString NoSourceText s
+
+mk_char :: Char -> DsM (HsLit GhcRn)
+mk_char c = return $ HsChar NoSourceText c
+
+repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit)
+repOverloadedLiteral (OverLit { ol_val = val})
+  = do { lit <- mk_lit val; repLiteral lit }
+        -- The type Rational will be in the environment, because
+        -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
+        -- and rationalL is sucked in when any TH stuff is used
+repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral"
+
+mk_lit :: OverLitVal -> DsM (HsLit GhcRn)
+mk_lit (HsIntegral i)     = mk_integer  (il_value i)
+mk_lit (HsFractional f)   = mk_rational f
+mk_lit (HsIsString _ s)   = mk_string   s
+
+repNameS :: Core String -> DsM (Core TH.Name)
+repNameS (MkC name) = rep2 mkNameSName [name]
+
+--------------- Miscellaneous -------------------
+
+repGensym :: Core String -> DsM (Core (TH.Q TH.Name))
+repGensym (MkC lit_str) = rep2 newNameName [lit_str]
+
+repBindQ :: Type -> Type        -- a and b
+         -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))
+repBindQ ty_a ty_b (MkC x) (MkC y)
+  = rep2 bindQName [Type ty_a, Type ty_b, x, y]
+
+repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))
+repSequenceQ ty_a (MkC list)
+  = rep2 sequenceQName [Type ty_a, list]
+
+repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ)
+repUnboundVar (MkC name) = rep2 unboundVarEName [name]
+
+repOverLabel :: FastString -> DsM (Core TH.ExpQ)
+repOverLabel fs = do
+                    (MkC s) <- coreStringLit $ unpackFS fs
+                    rep2 labelEName [s]
+
+
+------------ Lists -------------------
+-- turn a list of patterns into a single pattern matching a list
+
+repList :: Name -> (a  -> DsM (Core b))
+                    -> [a] -> DsM (Core [b])
+repList tc_name f args
+  = do { args1 <- mapM f args
+       ; coreList tc_name args1 }
+
+coreList :: Name    -- Of the TyCon of the element type
+         -> [Core a] -> DsM (Core [a])
+coreList tc_name es
+  = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }
+
+coreList' :: Type       -- The element type
+          -> [Core a] -> Core [a]
+coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))
+
+nonEmptyCoreList :: [Core a] -> Core [a]
+  -- The list must be non-empty so we can get the element type
+  -- Otherwise use coreList
+nonEmptyCoreList []           = panic "coreList: empty argument"
+nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))
+
+coreStringLit :: String -> DsM (Core String)
+coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }
+
+------------------- Maybe ------------------
+
+repMaybe :: Name -> (a -> DsM (Core b))
+                    -> Maybe a -> DsM (Core (Maybe b))
+repMaybe tc_name _ Nothing   = coreNothing tc_name
+repMaybe tc_name f (Just es) = coreJust tc_name =<< f es
+
+-- | Construct Core expression for Nothing of a given type name
+coreNothing :: Name        -- ^ Name of the TyCon of the element type
+            -> DsM (Core (Maybe a))
+coreNothing tc_name =
+    do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }
+
+-- | Construct Core expression for Nothing of a given type
+coreNothing' :: Type       -- ^ The element type
+             -> Core (Maybe a)
+coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)
+
+-- | Store given Core expression in a Just of a given type name
+coreJust :: Name        -- ^ Name of the TyCon of the element type
+         -> Core a -> DsM (Core (Maybe a))
+coreJust tc_name es
+  = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }
+
+-- | Store given Core expression in a Just of a given type
+coreJust' :: Type       -- ^ The element type
+          -> Core a -> Core (Maybe a)
+coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))
+
+------------------- Maybe Lists ------------------
+
+repMaybeList :: Name -> (a -> DsM (Core b))
+                        -> Maybe [a] -> DsM (Core (Maybe [b]))
+repMaybeList tc_name _ Nothing = coreNothingList tc_name
+repMaybeList tc_name f (Just args)
+  = do { elt_ty <- lookupType tc_name
+       ; args1 <- mapM f args
+       ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }
+
+coreNothingList :: Name -> DsM (Core (Maybe [a]))
+coreNothingList tc_name
+  = do { elt_ty <- lookupType tc_name
+       ; return $ coreNothing' (mkListTy elt_ty) }
+
+coreJustList :: Name -> Core [a] -> DsM (Core (Maybe [a]))
+coreJustList tc_name args
+  = do { elt_ty <- lookupType tc_name
+       ; return $ coreJust' (mkListTy elt_ty) args }
+
+------------ Literals & Variables -------------------
+
+coreIntLit :: Int -> DsM (Core Int)
+coreIntLit i = do dflags <- getDynFlags
+                  return (MkC (mkIntExprInt dflags i))
+
+coreVar :: Id -> Core TH.Name   -- The Id has type Name
+coreVar id = MkC (Var id)
+
+----------------- Failure -----------------------
+notHandledL :: SrcSpan -> String -> SDoc -> DsM a
+notHandledL loc what doc
+  | isGoodSrcSpan loc
+  = putSrcSpanDs loc $ notHandled what doc
+  | otherwise
+  = notHandled what doc
+
+notHandled :: String -> SDoc -> DsM a
+notHandled what doc = failWithDs msg
+  where
+    msg = hang (text what <+> text "not (yet) handled by Template Haskell")
+             2 doc
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsMonad.hs
@@ -0,0 +1,628 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+@DsMonad@: monadery used in desugaring
+-}
+
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan
+{-# LANGUAGE ViewPatterns #-}
+
+module DsMonad (
+        DsM, mapM, mapAndUnzipM,
+        initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
+        foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
+        Applicative(..),(<$>),
+
+        duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs,
+        newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,
+        newFailLocalDs, newPredVarDs,
+        getSrcSpanDs, putSrcSpanDs,
+        mkPrintUnqualifiedDs,
+        newUnique,
+        UniqSupply, newUniqueSupply,
+        getGhcModeDs, dsGetFamInstEnvs,
+        dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
+        dsLookupDataCon, dsLookupConLike,
+
+        DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
+
+        -- Getting and setting EvVars and term constraints in local environment
+        getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,
+
+        -- Iterations for pm checking
+        incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches,
+
+        -- Warnings and errors
+        DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
+        failWithDs, failDs, discardWarningsDs,
+        askNoErrsDs,
+
+        -- Data types
+        DsMatchContext(..),
+        EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
+        CanItFail(..), orFail,
+
+        -- Levity polymorphism
+        dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs,
+
+        -- Trace injection
+        pprRuntimeTrace
+    ) where
+
+import GhcPrelude
+
+import TcRnMonad
+import FamInstEnv
+import CoreSyn
+import MkCore    ( unitExpr )
+import CoreUtils ( exprType, isExprLevPoly )
+import HsSyn
+import TcIface
+import TcMType ( checkForLevPolyX, formatLevPolyErr )
+import PrelNames
+import RdrName
+import HscTypes
+import Bag
+import BasicTypes ( Origin )
+import DataCon
+import ConLike
+import TyCon
+import PmExpr
+import Id
+import Module
+import Outputable
+import SrcLoc
+import Type
+import UniqSupply
+import Name
+import NameEnv
+import DynFlags
+import ErrUtils
+import FastString
+import Var (EvVar)
+import UniqFM ( lookupWithDefaultUFM )
+import Literal ( mkLitString )
+import CostCentreState
+
+import Data.IORef
+
+{-
+************************************************************************
+*                                                                      *
+                Data types for the desugarer
+*                                                                      *
+************************************************************************
+-}
+
+data DsMatchContext
+  = DsMatchContext (HsMatchContext Name) SrcSpan
+  deriving ()
+
+instance Outputable DsMatchContext where
+  ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
+
+data EquationInfo
+  = EqnInfo { eqn_pats :: [Pat GhcTc]
+              -- ^ The patterns for an equation
+              --
+              -- NB: We have /already/ applied 'decideBangHood' to
+              -- these patterns.  See Note [decideBangHood] in "DsUtils"
+
+            , eqn_orig :: Origin
+              -- ^ Was this equation present in the user source?
+              --
+              -- This helps us avoid warnings on patterns that GHC elaborated.
+              --
+              -- For instance, the pattern @-1 :: Word@ gets desugared into
+              -- @W# -1## :: Word@, but we shouldn't warn about an overflowed
+              -- literal for /both/ of these cases.
+
+            , eqn_rhs  :: MatchResult
+              -- ^ What to do after match
+            }
+
+instance Outputable EquationInfo where
+    ppr (EqnInfo pats _ _) = ppr pats
+
+type DsWrapper = CoreExpr -> CoreExpr
+idDsWrapper :: DsWrapper
+idDsWrapper e = e
+
+-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
+--      \fail. wrap (case vs of { pats -> rhs fail })
+-- where vs are not bound by wrap
+
+
+-- A MatchResult is an expression with a hole in it
+data MatchResult
+  = MatchResult
+        CanItFail       -- Tells whether the failure expression is used
+        (CoreExpr -> DsM CoreExpr)
+                        -- Takes a expression to plug in at the
+                        -- failure point(s). The expression should
+                        -- be duplicatable!
+
+data CanItFail = CanFail | CantFail
+
+orFail :: CanItFail -> CanItFail -> CanItFail
+orFail CantFail CantFail = CantFail
+orFail _        _        = CanFail
+
+{-
+************************************************************************
+*                                                                      *
+                Monad functions
+*                                                                      *
+************************************************************************
+-}
+
+-- Compatibility functions
+fixDs :: (a -> DsM a) -> DsM a
+fixDs    = fixM
+
+type DsWarning = (SrcSpan, SDoc)
+        -- Not quite the same as a WarnMsg, we have an SDoc here
+        -- and we'll do the print_unqual stuff later on to turn it
+        -- into a Doc.
+
+-- | Run a 'DsM' action inside the 'TcM' monad.
+initDsTc :: DsM a -> TcM a
+initDsTc thing_inside
+  = do { tcg_env  <- getGblEnv
+       ; msg_var  <- getErrsVar
+       ; hsc_env  <- getTopEnv
+       ; envs     <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
+       ; setEnvs envs thing_inside
+       }
+
+-- | Run a 'DsM' action inside the 'IO' monad.
+initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
+initDs hsc_env tcg_env thing_inside
+  = do { msg_var <- newIORef emptyMessages
+       ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
+       ; runDs hsc_env envs thing_inside
+       }
+
+-- | Build a set of desugarer environments derived from a 'TcGblEnv'.
+mkDsEnvsFromTcGbl :: MonadIO m
+                  => HscEnv -> IORef Messages -> TcGblEnv
+                  -> m (DsGblEnv, DsLclEnv)
+mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
+  = do { pm_iter_var <- liftIO $ newIORef 0
+       ; cc_st_var   <- liftIO $ newIORef newCostCentreState
+       ; let dflags   = hsc_dflags hsc_env
+             this_mod = tcg_mod tcg_env
+             type_env = tcg_type_env tcg_env
+             rdr_env  = tcg_rdr_env tcg_env
+             fam_inst_env = tcg_fam_inst_env tcg_env
+             complete_matches = hptCompleteSigs hsc_env
+                                ++ tcg_complete_matches tcg_env
+       ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
+                           msg_var pm_iter_var cc_st_var complete_matches
+       }
+
+runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
+runDs hsc_env (ds_gbl, ds_lcl) thing_inside
+  = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
+                              (tryM thing_inside)
+       ; msgs   <- readIORef (ds_msgs ds_gbl)
+       ; let final_res
+               | errorsFound dflags msgs = Nothing
+               | Right r <- res          = Just r
+               | otherwise               = panic "initDs"
+       ; return (msgs, final_res)
+       }
+  where dflags = hsc_dflags hsc_env
+
+-- | Run a 'DsM' action in the context of an existing 'ModGuts'
+initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
+initDsWithModGuts hsc_env guts thing_inside
+  = do { pm_iter_var <- newIORef 0
+       ; cc_st_var   <- newIORef newCostCentreState
+       ; msg_var <- newIORef emptyMessages
+       ; let dflags   = hsc_dflags hsc_env
+             type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
+             rdr_env  = mg_rdr_env guts
+             fam_inst_env = mg_fam_inst_env guts
+             this_mod = mg_module guts
+             complete_matches = hptCompleteSigs hsc_env
+                                ++ mg_complete_sigs guts
+
+             bindsToIds (NonRec v _)   = [v]
+             bindsToIds (Rec    binds) = map fst binds
+             ids = concatMap bindsToIds (mg_binds guts)
+
+             envs  = mkDsEnvs dflags this_mod rdr_env type_env
+                              fam_inst_env msg_var pm_iter_var
+                              cc_st_var complete_matches
+       ; runDs hsc_env envs thing_inside
+       }
+
+initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
+-- Spin up a TcM context so that we can run the constraint solver
+-- Returns any error messages generated by the constraint solver
+-- and (Just res) if no error happened; Nothing if an error happened
+--
+-- Simon says: I'm not very happy about this.  We spin up a complete TcM monad
+--             only to immediately refine it to a TcS monad.
+-- Better perhaps to make TcS into its own monad, rather than building on TcS
+-- But that may in turn interact with plugins
+
+initTcDsForSolver thing_inside
+  = do { (gbl, lcl) <- getEnvs
+       ; hsc_env    <- getTopEnv
+
+       ; let DsGblEnv { ds_mod = mod
+                      , ds_fam_inst_env = fam_inst_env } = gbl
+
+             DsLclEnv { dsl_loc = loc }                  = lcl
+
+       ; liftIO $ initTc hsc_env HsSrcFile False mod loc $
+         updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $
+         thing_inside }
+
+mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
+         -> IORef Messages -> IORef Int -> IORef CostCentreState
+         -> [CompleteMatch] -> (DsGblEnv, DsLclEnv)
+mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar cc_st_var
+         complete_matches
+  = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",
+                             if_rec_types = Just (mod, return type_env) }
+        if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
+                             False -- not boot!
+        real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
+        completeMatchMap = mkCompleteMatchMap complete_matches
+        gbl_env = DsGblEnv { ds_mod     = mod
+                           , ds_fam_inst_env = fam_inst_env
+                           , ds_if_env  = (if_genv, if_lenv)
+                           , ds_unqual  = mkPrintUnqualified dflags rdr_env
+                           , ds_msgs    = msg_var
+                           , ds_complete_matches = completeMatchMap
+                           , ds_cc_st   = cc_st_var
+                           }
+        lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv
+                           , dsl_loc     = real_span
+                           , dsl_dicts   = emptyBag
+                           , dsl_tm_cs   = emptyBag
+                           , dsl_pm_iter = pmvar
+                           }
+    in (gbl_env, lcl_env)
+
+
+{-
+************************************************************************
+*                                                                      *
+                Operations in the monad
+*                                                                      *
+************************************************************************
+
+And all this mysterious stuff is so we can occasionally reach out and
+grab one or more names.  @newLocalDs@ isn't exported---exported
+functions are defined with it.  The difference in name-strings makes
+it easier to read debugging output.
+
+Note [Levity polymorphism checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+According to the "Levity Polymorphism" paper (PLDI '17), levity
+polymorphism is forbidden in precisely two places: in the type of a bound
+term-level argument and in the type of an argument to a function. The paper
+explains it more fully, but briefly: expressions in these contexts need to be
+stored in registers, and it's hard (read, impossible) to store something
+that's levity polymorphic.
+
+We cannot check for bad levity polymorphism conveniently in the type checker,
+because we can't tell, a priori, which levity metavariables will be solved.
+At one point, I (Richard) thought we could check in the zonker, but it's hard
+to know where precisely are the abstracted variables and the arguments. So
+we check in the desugarer, the only place where we can see the Core code and
+still report respectable syntax to the user. This covers the vast majority
+of cases; see calls to DsMonad.dsNoLevPoly and friends.
+
+Levity polymorphism is also prohibited in the types of binders, and the
+desugarer checks for this in GHC-generated Ids. (The zonker handles
+the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.
+The newSysLocalDs variant is used in the vast majority of cases where
+the binder is obviously not levity polymorphic, omitting the check.
+It would be nice to ASSERT that there is no levity polymorphism here,
+but we can't, because of the fixM in DsArrows. It's all OK, though:
+Core Lint will catch an error here.
+
+However, the desugarer is the wrong place for certain checks. In particular,
+the desugarer can't report a sensible error message if an HsWrapper is malformed.
+After all, GHC itself produced the HsWrapper. So we store some message text
+in the appropriate HsWrappers (e.g. WpFun) that we can print out in the
+desugarer.
+
+There are a few more checks in places where Core is generated outside the
+desugarer. For example, in datatype and class declarations, where levity
+polymorphism is checked for during validity checking. It would be nice to
+have one central place for all this, but that doesn't seem possible while
+still reporting nice error messages.
+
+-}
+
+-- Make a new Id with the same print name, but different type, and new unique
+newUniqueId :: Id -> Type -> DsM Id
+newUniqueId id = mk_local (occNameFS (nameOccName (idName id)))
+
+duplicateLocalDs :: Id -> DsM Id
+duplicateLocalDs old_local
+  = do  { uniq <- newUnique
+        ; return (setIdUnique old_local uniq) }
+
+newPredVarDs :: PredType -> DsM Var
+newPredVarDs pred
+ = newSysLocalDs pred
+
+newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id
+newSysLocalDsNoLP  = mk_local (fsLit "ds")
+
+-- this variant should be used when the caller can be sure that the variable type
+-- is not levity-polymorphic. It is necessary when the type is knot-tied because
+-- of the fixM used in DsArrows. See Note [Levity polymorphism checking]
+newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds")
+newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")
+  -- the fail variable is used only in a situation where we can tell that
+  -- levity-polymorphism is impossible.
+
+newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]
+newSysLocalsDsNoLP = mapM newSysLocalDsNoLP
+newSysLocalsDs = mapM newSysLocalDs
+
+mk_local :: FastString -> Type -> DsM Id
+mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>
+                                      ppr ty)  -- could improve the msg with another
+                                               -- parameter indicating context
+                    ; mkSysLocalOrCoVarM fs ty }
+
+{-
+We can also reach out and either set/grab location information from
+the @SrcSpan@ being carried around.
+-}
+
+getGhcModeDs :: DsM GhcMode
+getGhcModeDs =  getDynFlags >>= return . ghcMode
+
+-- | Get in-scope type constraints (pm check)
+getDictsDs :: DsM (Bag EvVar)
+getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) }
+
+-- | Add in-scope type constraints (pm check)
+addDictsDs :: Bag EvVar -> DsM a -> DsM a
+addDictsDs ev_vars
+  = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) })
+
+-- | Get in-scope term constraints (pm check)
+getTmCsDs :: DsM (Bag SimpleEq)
+getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) }
+
+-- | Add in-scope term constraints (pm check)
+addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a
+addTmCsDs tm_cs
+  = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })
+
+-- | Increase the counter for elapsed pattern match check iterations.
+-- If the current counter is already over the limit, fail
+incrCheckPmIterDs :: DsM Int
+incrCheckPmIterDs = do
+  env <- getLclEnv
+  cnt <- readTcRef (dsl_pm_iter env)
+  max_iters <- maxPmCheckIterations <$> getDynFlags
+  if cnt >= max_iters
+    then failM
+    else updTcRef (dsl_pm_iter env) (+1)
+  return cnt
+
+-- | Reset the counter for pattern match check iterations to zero
+resetPmIterDs :: DsM ()
+resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 }
+
+getSrcSpanDs :: DsM SrcSpan
+getSrcSpanDs = do { env <- getLclEnv
+                  ; return (RealSrcSpan (dsl_loc env)) }
+
+putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
+putSrcSpanDs (UnhelpfulSpan {}) thing_inside
+  = thing_inside
+putSrcSpanDs (RealSrcSpan real_span) thing_inside
+  = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
+
+-- | Emit a warning for the current source location
+-- NB: Warns whether or not -Wxyz is set
+warnDs :: WarnReason -> SDoc -> DsM ()
+warnDs reason warn
+  = do { env <- getGblEnv
+       ; loc <- getSrcSpanDs
+       ; dflags <- getDynFlags
+       ; let msg = makeIntoWarning reason $
+                   mkWarnMsg dflags loc (ds_unqual env) warn
+       ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
+
+-- | Emit a warning only if the correct WarnReason is set in the DynFlags
+warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
+warnIfSetDs flag warn
+  = whenWOptM flag $
+    warnDs (Reason flag) warn
+
+errDs :: SDoc -> DsM ()
+errDs err
+  = do  { env <- getGblEnv
+        ; loc <- getSrcSpanDs
+        ; dflags <- getDynFlags
+        ; let msg = mkErrMsg dflags loc (ds_unqual env) err
+        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }
+
+-- | Issue an error, but return the expression for (), so that we can continue
+-- reporting errors.
+errDsCoreExpr :: SDoc -> DsM CoreExpr
+errDsCoreExpr err
+  = do { errDs err
+       ; return unitExpr }
+
+failWithDs :: SDoc -> DsM a
+failWithDs err
+  = do  { errDs err
+        ; failM }
+
+failDs :: DsM a
+failDs = failM
+
+-- (askNoErrsDs m) runs m
+-- If m fails,
+--    then (askNoErrsDs m) fails
+-- If m succeeds with result r,
+--    then (askNoErrsDs m) succeeds with result (r, b),
+--         where b is True iff m generated no errors
+-- Regardless of success or failure,
+--   propagate any errors/warnings generated by m
+--
+-- c.f. TcRnMonad.askNoErrs
+askNoErrsDs :: DsM a -> DsM (a, Bool)
+askNoErrsDs thing_inside
+ = do { errs_var <- newMutVar emptyMessages
+      ; env <- getGblEnv
+      ; mb_res <- tryM $  -- Be careful to catch exceptions
+                          -- so that we propagate errors correctly
+                          -- (Trac #13642)
+                  setGblEnv (env { ds_msgs = errs_var }) $
+                  thing_inside
+
+      -- Propagate errors
+      ; msgs@(warns, errs) <- readMutVar errs_var
+      ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))
+
+      -- And return
+      ; case mb_res of
+           Left _    -> failM
+           Right res -> do { dflags <- getDynFlags
+                           ; let errs_found = errorsFound dflags msgs
+                           ; return (res, not errs_found) } }
+
+mkPrintUnqualifiedDs :: DsM PrintUnqualified
+mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
+
+instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
+    lookupThing = dsLookupGlobal
+
+dsLookupGlobal :: Name -> DsM TyThing
+-- Very like TcEnv.tcLookupGlobal
+dsLookupGlobal name
+  = do  { env <- getGblEnv
+        ; setEnvs (ds_if_env env)
+                  (tcIfaceGlobal name) }
+
+dsLookupGlobalId :: Name -> DsM Id
+dsLookupGlobalId name
+  = tyThingId <$> dsLookupGlobal name
+
+dsLookupTyCon :: Name -> DsM TyCon
+dsLookupTyCon name
+  = tyThingTyCon <$> dsLookupGlobal name
+
+dsLookupDataCon :: Name -> DsM DataCon
+dsLookupDataCon name
+  = tyThingDataCon <$> dsLookupGlobal name
+
+dsLookupConLike :: Name -> DsM ConLike
+dsLookupConLike name
+  = tyThingConLike <$> dsLookupGlobal name
+
+
+dsGetFamInstEnvs :: DsM FamInstEnvs
+-- Gets both the external-package inst-env
+-- and the home-pkg inst env (includes module being compiled)
+dsGetFamInstEnvs
+  = do { eps <- getEps; env <- getGblEnv
+       ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
+
+dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
+dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
+
+-- | The @COMPLETE@ pragmas provided by the user for a given `TyCon`.
+dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
+dsGetCompleteMatches tc = do
+  eps <- getEps
+  env <- getGblEnv
+  let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc
+      eps_matches_list = lookup_completes $ eps_complete_matches eps
+      env_matches_list = lookup_completes $ ds_complete_matches env
+  return $ eps_matches_list ++ env_matches_list
+
+dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
+dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
+
+dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
+dsExtendMetaEnv menv thing_inside
+  = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
+
+discardWarningsDs :: DsM a -> DsM a
+-- Ignore warnings inside the thing inside;
+-- used to ignore inaccessable cases etc. inside generated code
+discardWarningsDs thing_inside
+  = do  { env <- getGblEnv
+        ; old_msgs <- readTcRef (ds_msgs env)
+
+        ; result <- thing_inside
+
+        -- Revert messages to old_msgs
+        ; writeTcRef (ds_msgs env) old_msgs
+
+        ; return result }
+
+-- | Fail with an error message if the type is levity polymorphic.
+dsNoLevPoly :: Type -> SDoc -> DsM ()
+-- See Note [Levity polymorphism checking]
+dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty
+
+-- | Check an expression for levity polymorphism, failing if it is
+-- levity polymorphic.
+dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
+-- See Note [Levity polymorphism checking]
+dsNoLevPolyExpr e doc
+  | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)
+  | otherwise       = return ()
+
+-- | Runs the thing_inside. If there are no errors, then returns the expr
+-- given. Otherwise, returns unitExpr. This is useful for doing a bunch
+-- of levity polymorphism checks and then avoiding making a core App.
+-- (If we make a core App on a levity polymorphic argument, detecting how
+-- to handle the let/app invariant might call isUnliftedType, which panics
+-- on a levity polymorphic type.)
+-- See #12709 for an example of why this machinery is necessary.
+dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
+dsWhenNoErrs thing_inside mk_expr
+  = do { (result, no_errs) <- askNoErrsDs thing_inside
+       ; return $ if no_errs
+                  then mk_expr result
+                  else unitExpr }
+
+-- | Inject a trace message into the compiled program. Whereas
+-- pprTrace prints out information *while compiling*, pprRuntimeTrace
+-- captures that information and causes it to be printed *at runtime*
+-- using Debug.Trace.trace.
+--
+--   pprRuntimeTrace hdr doc expr
+--
+-- will produce an expression that looks like
+--
+--   trace (hdr + doc) expr
+--
+-- When using this to debug a module that Debug.Trace depends on,
+-- it is necessary to import {-# SOURCE #-} Debug.Trace () in that
+-- module. We could avoid this inconvenience by wiring in Debug.Trace.trace,
+-- but that doesn't seem worth the effort and maintenance cost.
+pprRuntimeTrace :: String   -- ^ header
+                -> SDoc     -- ^ information to output
+                -> CoreExpr -- ^ expression
+                -> DsM CoreExpr
+pprRuntimeTrace str doc expr = do
+  traceId <- dsLookupGlobalId traceName
+  unpackCStringId <- dsLookupGlobalId unpackCStringName
+  dflags <- getDynFlags
+  let message :: CoreExpr
+      message = App (Var unpackCStringId) $
+                Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc)
+  return $ mkApps (Var traceId) [Type (exprType expr), message, expr]
diff --git a/compiler/deSugar/DsUsage.hs b/compiler/deSugar/DsUsage.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsUsage.hs
@@ -0,0 +1,373 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module DsUsage (
+    -- * Dependency/fingerprinting code (used by MkIface)
+    mkUsageInfo, mkUsedNames, mkDependencies
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import DynFlags
+import HscTypes
+import TcRnTypes
+import Name
+import NameSet
+import Module
+import Outputable
+import Util
+import UniqSet
+import UniqFM
+import Fingerprint
+import Maybes
+import Packages
+import Finder
+
+import Control.Monad (filterM)
+import Data.List
+import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import System.Directory
+import System.FilePath
+
+{- Note [Module self-dependency]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+RnNames.calculateAvails asserts the invariant that a module must not occur in
+its own dep_orphs or dep_finsts. However, if we aren't careful this can occur
+in the presence of hs-boot files: Consider that we have two modules, A and B,
+both with hs-boot files,
+
+    A.hs contains a SOURCE import of B B.hs-boot contains a SOURCE import of A
+    A.hs-boot declares an orphan instance A.hs defines the orphan instance
+
+In this case, B's dep_orphs will contain A due to its SOURCE import of A.
+Consequently, A will contain itself in its imp_orphs due to its import of B.
+This fact would end up being recorded in A's interface file. This would then
+break the invariant asserted by calculateAvails that a module does not itself in
+its dep_orphs. This was the cause of Trac #14128.
+
+-}
+
+-- | Extract information from the rename and typecheck phases to produce
+-- a dependencies information for the module being compiled.
+--
+-- The first argument is additional dependencies from plugins
+mkDependencies :: InstalledUnitId -> [Module] -> TcGblEnv -> IO Dependencies
+mkDependencies iuid pluginModules
+          (TcGblEnv{ tcg_mod = mod,
+                    tcg_imports = imports,
+                    tcg_th_used = th_var
+                  })
+ = do
+      -- Template Haskell used?
+      let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ]
+          plugin_dep_pkgs = filter (/= iuid) (map (toInstalledUnitId . moduleUnitId) ms)
+      th_used <- readIORef th_var
+      let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports)
+                                             (moduleName mod))
+                -- M.hi-boot can be in the imp_dep_mods, but we must remove
+                -- it before recording the modules on which this one depends!
+                -- (We want to retain M.hi-boot in imp_dep_mods so that
+                --  loadHiBootInterface can see if M's direct imports depend
+                --  on M.hi-boot, and hence that we should do the hi-boot consistency
+                --  check.)
+
+          dep_orphs = filter (/= mod) (imp_orphs imports)
+                -- We must also remove self-references from imp_orphs. See
+                -- Note [Module self-dependency]
+
+          raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs
+
+          pkgs | th_used   = Set.insert (toInstalledUnitId thUnitId) raw_pkgs
+               | otherwise = raw_pkgs
+
+          -- Set the packages required to be Safe according to Safe Haskell.
+          -- See Note [RnNames . Tracking Trust Transitively]
+          sorted_pkgs = sort (Set.toList pkgs)
+          trust_pkgs  = imp_trust_pkgs imports
+          dep_pkgs'   = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs
+
+      return Deps { dep_mods   = dep_mods,
+                    dep_pkgs   = dep_pkgs',
+                    dep_orphs  = dep_orphs,
+                    dep_plgins = dep_plgins,
+                    dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }
+                    -- sort to get into canonical order
+                    -- NB. remember to use lexicographic ordering
+
+mkUsedNames :: TcGblEnv -> NameSet
+mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
+
+mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath]
+            -> [(Module, Fingerprint)] -> [ModIface] -> IO [Usage]
+mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged
+  pluginModules
+  = do
+    eps <- hscEPS hsc_env
+    hashes <- mapM getFileHash dependent_files
+    plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules
+    let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod
+                                       dir_imp_mods used_names
+        usages = mod_usages ++ [ UsageFile { usg_file_path = f
+                                           , usg_file_hash = hash }
+                               | (f, hash) <- zip dependent_files hashes ]
+                            ++ [ UsageMergedRequirement
+                                    { usg_mod = mod,
+                                      usg_mod_hash = hash
+                                    }
+                               | (mod, hash) <- merged ]
+                            ++ concat plugin_usages
+    usages `seqList` return usages
+    -- seq the list of Usages returned: occasionally these
+    -- don't get evaluated for a while and we can end up hanging on to
+    -- the entire collection of Ifaces.
+
+{- Note [Plugin dependencies]
+Modules for which plugins were used in the compilation process, should be
+recompiled whenever one of those plugins changes. But how do we know if a
+plugin changed from the previous time a module was compiled?
+
+We could try storing the fingerprints of the interface files of plugins in
+the interface file of the module. And see if there are changes between
+compilation runs. However, this is pretty much a non-option because interface
+fingerprints of plugin modules are fairly stable, unless you compile plugins
+with optimisations turned on, and give basically all binders an INLINE pragma.
+
+So instead:
+
+  * For plugins that were built locally: we store the filepath and hash of the
+    object files of the module with the `plugin` binder, and the object files of
+    modules that are dependencies of the plugin module and belong to the same
+    `UnitId` as the plugin
+  * For plugins in an external package: we store the filepath and hash of
+    the dynamic library containing the plugin module.
+
+During recompilation we then compare the hashes of those files again to see
+if anything has changed.
+
+One issue with this approach is that object files are currently (GHC 8.6.1)
+not created fully deterministicly, which could sometimes induce accidental
+recompilation of a module for which plugins were used in the compile process.
+
+One way to improve this is to either:
+
+  * Have deterministic object file creation
+  * Create and store implementation hashes, which would be based on the Core
+    of the module and the implementation hashes of its dependencies, and then
+    compare implementation hashes for recompilation. Creation of implementation
+    hashes is however potentially expensive.
+-}
+mkPluginUsage :: HscEnv -> ModIface -> IO [Usage]
+mkPluginUsage hsc_env pluginModule
+  = case lookupPluginModuleWithSuggestions dflags pNm Nothing of
+    LookupFound _ pkg -> do
+    -- The plugin is from an external package:
+    -- search for the library files containing the plugin.
+      let searchPaths = collectLibraryPaths dflags [pkg]
+          useDyn = WayDyn `elem` ways dflags
+          suffix = if useDyn then soExt platform else "a"
+          libLocs = [ searchPath </> "lib" ++ libLoc <.> suffix
+                    | searchPath <- searchPaths
+                    , libLoc     <- packageHsLibs dflags pkg
+                    ]
+          -- we also try to find plugin library files by adding WayDyn way,
+          -- if it isn't already present (see trac #15492)
+          paths =
+            if useDyn
+              then libLocs
+              else
+                let dflags'  = updateWays (addWay' WayDyn dflags)
+                    dlibLocs = [ searchPath </> mkHsSOName platform dlibLoc
+                               | searchPath <- searchPaths
+                               , dlibLoc    <- packageHsLibs dflags' pkg
+                               ]
+                in libLocs ++ dlibLocs
+      files <- filterM doesFileExist paths
+      case files of
+        [] ->
+          pprPanic
+             ( "mkPluginUsage: missing plugin library, tried:\n"
+              ++ unlines paths
+             )
+             (ppr pNm)
+        _  -> mapM hashFile (nub files)
+    _ -> do
+      foundM <- findPluginModule hsc_env pNm
+      case foundM of
+      -- The plugin was built locally: look up the object file containing
+      -- the `plugin` binder, and all object files belong to modules that are
+      -- transitive dependencies of the plugin that belong to the same package.
+        Found ml _ -> do
+          pluginObject <- hashFile (ml_obj_file ml)
+          depObjects   <- catMaybes <$> mapM lookupObjectFile deps
+          return (nub (pluginObject : depObjects))
+        _ -> pprPanic "mkPluginUsage: no object file found" (ppr pNm)
+  where
+    dflags   = hsc_dflags hsc_env
+    platform = targetPlatform dflags
+    pNm      = moduleName (mi_module pluginModule)
+    pPkg     = moduleUnitId (mi_module pluginModule)
+    deps     = map fst (dep_mods (mi_deps pluginModule))
+
+    -- Lookup object file for a plugin dependency,
+    -- from the same package as the plugin.
+    lookupObjectFile nm = do
+      foundM <- findImportedModule hsc_env nm Nothing
+      case foundM of
+        Found ml m
+          | moduleUnitId m == pPkg -> Just <$> hashFile (ml_obj_file ml)
+          | otherwise              -> return Nothing
+        _ -> pprPanic "mkPluginUsage: no object for dependency"
+                      (ppr pNm <+> ppr nm)
+
+    hashFile f = do
+      fExist <- doesFileExist f
+      if fExist
+         then do
+            h <- getFileHash f
+            return (UsageFile f h)
+         else pprPanic "mkPluginUsage: file not found" (ppr pNm <+> text f)
+
+mk_mod_usage_info :: PackageIfaceTable
+              -> HscEnv
+              -> Module
+              -> ImportedMods
+              -> NameSet
+              -> [Usage]
+mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
+  = mapMaybe mkUsage usage_mods
+  where
+    hpt = hsc_HPT hsc_env
+    dflags = hsc_dflags hsc_env
+    this_pkg = thisPackage dflags
+
+    used_mods    = moduleEnvKeys ent_map
+    dir_imp_mods = moduleEnvKeys direct_imports
+    all_mods     = used_mods ++ filter (`notElem` used_mods) dir_imp_mods
+    usage_mods   = sortBy stableModuleCmp all_mods
+                        -- canonical order is imported, to avoid interface-file
+                        -- wobblage.
+
+    -- ent_map groups together all the things imported and used
+    -- from a particular module
+    ent_map :: ModuleEnv [OccName]
+    ent_map  = nonDetFoldUniqSet add_mv emptyModuleEnv used_names
+     -- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName
+     -- in ent_hashs
+     where
+      add_mv name mv_map
+        | isWiredInName name = mv_map  -- ignore wired-in names
+        | otherwise
+        = case nameModule_maybe name of
+             Nothing  -> ASSERT2( isSystemName name, ppr name ) mv_map
+                -- See Note [Internal used_names]
+
+             Just mod ->
+                -- See Note [Identity versus semantic module]
+                let mod' = if isHoleModule mod
+                            then mkModule this_pkg (moduleName mod)
+                            else mod
+                -- This lambda function is really just a
+                -- specialised (++); originally came about to
+                -- avoid quadratic behaviour (trac #2680)
+                in extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod' [occ]
+            where occ = nameOccName name
+
+    -- We want to create a Usage for a home module if
+    --  a) we used something from it; has something in used_names
+    --  b) we imported it, even if we used nothing from it
+    --     (need to recompile if its export list changes: export_fprint)
+    mkUsage :: Module -> Maybe Usage
+    mkUsage mod
+      | isNothing maybe_iface           -- We can't depend on it if we didn't
+                                        -- load its interface.
+      || mod == this_mod                -- We don't care about usages of
+                                        -- things in *this* module
+      = Nothing
+
+      | moduleUnitId mod /= this_pkg
+      = Just UsagePackageModule{ usg_mod      = mod,
+                                 usg_mod_hash = mod_hash,
+                                 usg_safe     = imp_safe }
+        -- for package modules, we record the module hash only
+
+      | (null used_occs
+          && isNothing export_hash
+          && not is_direct_import
+          && not finsts_mod)
+      = Nothing                 -- Record no usage info
+        -- for directly-imported modules, we always want to record a usage
+        -- on the orphan hash.  This is what triggers a recompilation if
+        -- an orphan is added or removed somewhere below us in the future.
+
+      | otherwise
+      = Just UsageHomeModule {
+                      usg_mod_name = moduleName mod,
+                      usg_mod_hash = mod_hash,
+                      usg_exports  = export_hash,
+                      usg_entities = Map.toList ent_hashs,
+                      usg_safe     = imp_safe }
+      where
+        maybe_iface  = lookupIfaceByModule dflags hpt pit mod
+                -- In one-shot mode, the interfaces for home-package
+                -- modules accumulate in the PIT not HPT.  Sigh.
+
+        Just iface   = maybe_iface
+        finsts_mod   = mi_finsts    iface
+        hash_env     = mi_hash_fn   iface
+        mod_hash     = mi_mod_hash  iface
+        export_hash | depend_on_exports = Just (mi_exp_hash iface)
+                    | otherwise         = Nothing
+
+        by_is_safe (ImportedByUser imv) = imv_is_safe imv
+        by_is_safe _ = False
+        (is_direct_import, imp_safe)
+            = case lookupModuleEnv direct_imports mod of
+                -- ezyang: I'm not sure if any is the correct
+                -- metric here. If safety was guaranteed to be uniform
+                -- across all imports, why did the old code only look
+                -- at the first import?
+                Just bys -> (True, any by_is_safe bys)
+                Nothing  -> (False, safeImplicitImpsReq dflags)
+                -- Nothing case is for references to entities which were
+                -- not directly imported (NB: the "implicit" Prelude import
+                -- counts as directly imported!  An entity is not directly
+                -- imported if, e.g., we got a reference to it from a
+                -- reexport of another module.)
+
+        used_occs = lookupModuleEnv ent_map mod `orElse` []
+
+        -- Making a Map here ensures that (a) we remove duplicates
+        -- when we have usages on several subordinates of a single parent,
+        -- and (b) that the usages emerge in a canonical order, which
+        -- is why we use Map rather than OccEnv: Map works
+        -- using Ord on the OccNames, which is a lexicographic ordering.
+        ent_hashs :: Map OccName Fingerprint
+        ent_hashs = Map.fromList (map lookup_occ used_occs)
+
+        lookup_occ occ =
+            case hash_env occ of
+                Nothing -> pprPanic "mkUsage" (ppr mod <+> ppr occ <+> ppr used_names)
+                Just r  -> r
+
+        depend_on_exports = is_direct_import
+        {- True
+              Even if we used 'import M ()', we have to register a
+              usage on the export list because we are sensitive to
+              changes in orphan instances/rules.
+           False
+              In GHC 6.8.x we always returned true, and in
+              fact it recorded a dependency on *all* the
+              modules underneath in the dependency tree.  This
+              happens to make orphans work right, but is too
+              expensive: it'll read too many interface files.
+              The 'isNothing maybe_iface' check above saved us
+              from generating many of these usages (at least in
+              one-shot mode), but that's even more bogus!
+        -}
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/DsUtils.hs
@@ -0,0 +1,1001 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Utilities for desugaring
+
+This module exports some utility functions of no great interest.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+-- | Utility functions for constructing Core syntax, principally for desugaring
+module DsUtils (
+        EquationInfo(..),
+        firstPat, shiftEqns,
+
+        MatchResult(..), CanItFail(..), CaseAlt(..),
+        cantFailMatchResult, alwaysFailMatchResult,
+        extractMatchResult, combineMatchResults,
+        adjustMatchResult,  adjustMatchResultDs,
+        mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,
+        matchCanFail, mkEvalMatchResult,
+        mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
+        wrapBind, wrapBinds,
+
+        mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,
+
+        seqVar,
+
+        -- LHs tuples
+        mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat,
+        mkBigLHsVarTupId, mkBigLHsTupId, mkBigLHsVarPatTupId, mkBigLHsPatTupId,
+
+        mkSelectorBinds,
+
+        selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
+        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang,
+        isTrueLHsExpr
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} Match  ( matchSimply )
+import {-# SOURCE #-} DsExpr ( dsLExpr )
+
+import HsSyn
+import TcHsSyn
+import TcType( tcSplitTyConApp )
+import CoreSyn
+import DsMonad
+
+import CoreUtils
+import MkCore
+import MkId
+import Id
+import Literal
+import TyCon
+import DataCon
+import PatSyn
+import Type
+import Coercion
+import TysPrim
+import TysWiredIn
+import BasicTypes
+import ConLike
+import UniqSet
+import UniqSupply
+import Module
+import PrelNames
+import Name( isInternalName )
+import Outputable
+import SrcLoc
+import Util
+import DynFlags
+import FastString
+import qualified GHC.LanguageExtensions as LangExt
+
+import TcEvidence
+
+import Control.Monad    ( zipWithM )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{ Selecting match variables}
+*                                                                      *
+************************************************************************
+
+We're about to match against some patterns.  We want to make some
+@Ids@ to use as match variables.  If a pattern has an @Id@ readily at
+hand, which should indeed be bound to the pattern as a whole, then use it;
+otherwise, make one up.
+-}
+
+selectSimpleMatchVarL :: LPat GhcTc -> DsM Id
+-- Postcondition: the returned Id has an Internal Name
+selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
+
+-- (selectMatchVars ps tys) chooses variables of type tys
+-- to use for matching ps against.  If the pattern is a variable,
+-- we try to use that, to save inventing lots of fresh variables.
+--
+-- OLD, but interesting note:
+--    But even if it is a variable, its type might not match.  Consider
+--      data T a where
+--        T1 :: Int -> T Int
+--        T2 :: a   -> T a
+--
+--      f :: T a -> a -> Int
+--      f (T1 i) (x::Int) = x
+--      f (T2 i) (y::a)   = 0
+--    Then we must not choose (x::Int) as the matching variable!
+-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
+
+selectMatchVars :: [Pat GhcTc] -> DsM [Id]
+-- Postcondition: the returned Ids have Internal Names
+selectMatchVars ps = mapM selectMatchVar ps
+
+selectMatchVar :: Pat GhcTc -> DsM Id
+-- Postcondition: the returned Id has an Internal Name
+selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat)
+selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat)
+selectMatchVar (ParPat _ pat)  = selectMatchVar (unLoc pat)
+selectMatchVar (VarPat _ var)  = return (localiseId (unLoc var))
+                                  -- Note [Localise pattern binders]
+selectMatchVar (AsPat _ var _) = return (unLoc var)
+selectMatchVar other_pat       = newSysLocalDsNoLP (hsPatType other_pat)
+                                  -- OK, better make up one...
+
+{- Note [Localise pattern binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider     module M where
+               [Just a] = e
+After renaming it looks like
+             module M where
+               [Just M.a] = e
+
+We don't generalise, since it's a pattern binding, monomorphic, etc,
+so after desugaring we may get something like
+             M.a = case e of (v:_) ->
+                   case v of Just M.a -> M.a
+Notice the "M.a" in the pattern; after all, it was in the original
+pattern.  However, after optimisation those pattern binders can become
+let-binders, and then end up floated to top level.  They have a
+different *unique* by then (the simplifier is good about maintaining
+proper scoping), but it's BAD to have two top-level bindings with the
+External Name M.a, because that turns into two linker symbols for M.a.
+It's quite rare for this to actually *happen* -- the only case I know
+of is tc003 compiled with the 'hpc' way -- but that only makes it
+all the more annoying.
+
+To avoid this, we craftily call 'localiseId' in the desugarer, which
+simply turns the External Name for the Id into an Internal one, but
+doesn't change the unique.  So the desugarer produces this:
+             M.a{r8} = case e of (v:_) ->
+                       case v of Just a{r8} -> M.a{r8}
+The unique is still 'r8', but the binding site in the pattern
+is now an Internal Name.  Now the simplifier's usual mechanisms
+will propagate that Name to all the occurrence sites, as well as
+un-shadowing it, so we'll get
+             M.a{r8} = case e of (v:_) ->
+                       case v of Just a{s77} -> a{s77}
+In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr
+runs on the output of the desugarer, so all is well by the end of
+the desugaring pass.
+
+See also Note [MatchIds] in Match.hs
+
+************************************************************************
+*                                                                      *
+* type synonym EquationInfo and access functions for its pieces        *
+*                                                                      *
+************************************************************************
+\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}
+
+The ``equation info'' used by @match@ is relatively complicated and
+worthy of a type synonym and a few handy functions.
+-}
+
+firstPat :: EquationInfo -> Pat GhcTc
+firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
+
+shiftEqns :: [EquationInfo] -> [EquationInfo]
+-- Drop the first pattern in each equation
+shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]
+
+-- Functions on MatchResults
+
+matchCanFail :: MatchResult -> Bool
+matchCanFail (MatchResult CanFail _)  = True
+matchCanFail (MatchResult CantFail _) = False
+
+alwaysFailMatchResult :: MatchResult
+alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)
+
+cantFailMatchResult :: CoreExpr -> MatchResult
+cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)
+
+extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr
+extractMatchResult (MatchResult CantFail match_fn) _
+  = match_fn (error "It can't fail!")
+
+extractMatchResult (MatchResult CanFail match_fn) fail_expr = do
+    (fail_bind, if_it_fails) <- mkFailurePair fail_expr
+    body <- match_fn if_it_fails
+    return (mkCoreLet fail_bind body)
+
+
+combineMatchResults :: MatchResult -> MatchResult -> MatchResult
+combineMatchResults (MatchResult CanFail      body_fn1)
+                    (MatchResult can_it_fail2 body_fn2)
+  = MatchResult can_it_fail2 body_fn
+  where
+    body_fn fail = do body2 <- body_fn2 fail
+                      (fail_bind, duplicatable_expr) <- mkFailurePair body2
+                      body1 <- body_fn1 duplicatable_expr
+                      return (Let fail_bind body1)
+
+combineMatchResults match_result1@(MatchResult CantFail _) _
+  = match_result1
+
+adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult
+adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)
+  = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)
+
+adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult
+adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)
+  = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)
+
+wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
+wrapBinds [] e = e
+wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
+
+wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
+wrapBind new old body   -- NB: this function must deal with term
+  | new==old    = body  -- variables, type variables or coercion variables
+  | otherwise   = Let (NonRec new (varToCoreExpr old)) body
+
+seqVar :: Var -> CoreExpr -> CoreExpr
+seqVar var body = Case (Var var) var (exprType body)
+                        [(DEFAULT, [], body)]
+
+mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
+mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
+
+-- (mkViewMatchResult var' viewExpr mr) makes the expression
+-- let var' = viewExpr in mr
+mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult
+mkViewMatchResult var' viewExpr =
+    adjustMatchResult (mkCoreLet (NonRec var' viewExpr))
+
+mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
+mkEvalMatchResult var ty
+  = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])
+
+mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult
+mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
+  = MatchResult CanFail (\fail -> do body <- body_fn fail
+                                     return (mkIfThenElse pred_expr body fail))
+
+mkCoPrimCaseMatchResult :: Id                  -- Scrutinee
+                        -> Type                      -- Type of the case
+                        -> [(Literal, MatchResult)]  -- Alternatives
+                        -> MatchResult               -- Literals are all unlifted
+mkCoPrimCaseMatchResult var ty match_alts
+  = MatchResult CanFail mk_case
+  where
+    mk_case fail = do
+        alts <- mapM (mk_alt fail) sorted_alts
+        return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))
+
+    sorted_alts = sortWith fst match_alts       -- Right order for a Case
+    mk_alt fail (lit, MatchResult _ body_fn)
+       = ASSERT( not (litIsLifted lit) )
+         do body <- body_fn fail
+            return (LitAlt lit, [], body)
+
+data CaseAlt a = MkCaseAlt{ alt_pat :: a,
+                            alt_bndrs :: [Var],
+                            alt_wrapper :: HsWrapper,
+                            alt_result :: MatchResult }
+
+mkCoAlgCaseMatchResult
+  :: Id                 -- Scrutinee
+  -> Type               -- Type of exp
+  -> [CaseAlt DataCon]  -- Alternatives (bndrs *include* tyvars, dicts)
+  -> MatchResult
+mkCoAlgCaseMatchResult var ty match_alts
+  | isNewtype  -- Newtype case; use a let
+  = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
+    mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
+
+  | otherwise
+  = mkDataConCase var ty match_alts
+  where
+    isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))
+
+        -- [Interesting: because of GADTs, we can't rely on the type of
+        --  the scrutinised Id to be sufficiently refined to have a TyCon in it]
+
+    alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 }
+      = ASSERT( notNull match_alts ) head match_alts
+    -- Stuff for newtype
+    arg_id1       = ASSERT( notNull arg_ids1 ) head arg_ids1
+    var_ty        = idType var
+    (tc, ty_args) = tcSplitTyConApp var_ty      -- Don't look through newtypes
+                                                -- (not that splitTyConApp does, these days)
+    newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
+
+mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult
+mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt
+
+sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon]
+sort_alts = sortWith (dataConTag . alt_pat)
+
+mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
+mkPatSynCase var ty alt fail = do
+    matcher <- dsLExpr $ mkLHsWrap wrapper $
+                         nlHsTyApp matcher [getRuntimeRep ty, ty]
+    let MatchResult _ mkCont = match_result
+    cont <- mkCoreLams bndrs <$> mkCont fail
+    return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
+  where
+    MkCaseAlt{ alt_pat = psyn,
+               alt_bndrs = bndrs,
+               alt_wrapper = wrapper,
+               alt_result = match_result} = alt
+    (matcher, needs_void_lam) = patSynMatcher psyn
+
+    -- See Note [Matchers and builders for pattern synonyms] in PatSyns
+    -- on these extra Void# arguments
+    ensure_unstrict cont | needs_void_lam = Lam voidArgId cont
+                         | otherwise      = cont
+
+mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult
+mkDataConCase _   _  []            = panic "mkDataConCase: no alternatives"
+mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case
+  where
+    con1          = alt_pat alt1
+    tycon         = dataConTyCon con1
+    data_cons     = tyConDataCons tycon
+    match_results = map alt_result alts
+
+    sorted_alts :: [CaseAlt DataCon]
+    sorted_alts  = sort_alts alts
+
+    var_ty       = idType var
+    (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes
+                                          -- (not that splitTyConApp does, these days)
+
+    mk_case :: CoreExpr -> DsM CoreExpr
+    mk_case fail = do
+        alts <- mapM (mk_alt fail) sorted_alts
+        return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)
+
+    mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt
+    mk_alt fail MkCaseAlt{ alt_pat = con,
+                           alt_bndrs = args,
+                           alt_result = MatchResult _ body_fn }
+      = do { body <- body_fn fail
+           ; case dataConBoxer con of {
+                Nothing -> return (DataAlt con, args, body) ;
+                Just (DCB boxer) ->
+        do { us <- newUniqueSupply
+           ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)
+           ; return (DataAlt con, rep_ids, mkLets binds body) } } }
+
+    mk_default :: CoreExpr -> [CoreAlt]
+    mk_default fail | exhaustive_case = []
+                    | otherwise       = [(DEFAULT, [], fail)]
+
+    fail_flag :: CanItFail
+    fail_flag | exhaustive_case
+              = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
+              | otherwise
+              = CanFail
+
+    mentioned_constructors = mkUniqSet $ map alt_pat alts
+    un_mentioned_constructors
+        = mkUniqSet data_cons `minusUniqSet` mentioned_constructors
+    exhaustive_case = isEmptyUniqSet un_mentioned_constructors
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Desugarer's versions of some Core functions}
+*                                                                      *
+************************************************************************
+-}
+
+mkErrorAppDs :: Id              -- The error function
+             -> Type            -- Type to which it should be applied
+             -> SDoc            -- The error message string to pass
+             -> DsM CoreExpr
+
+mkErrorAppDs err_id ty msg = do
+    src_loc <- getSrcSpanDs
+    dflags <- getDynFlags
+    let
+        full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
+        core_msg = Lit (mkLitString full_msg)
+        -- mkLitString returns a result of type String#
+    return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])
+
+{-
+'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
+
+Note [Desugaring seq (1)]  cf Trac #1031
+~~~~~~~~~~~~~~~~~~~~~~~~~
+   f x y = x `seq` (y `seq` (# x,y #))
+
+The [CoreSyn let/app invariant] means that, other things being equal, because
+the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:
+
+   f x y = case (y `seq` (# x,y #)) of v -> x `seq` v
+
+But that is bad for two reasons:
+  (a) we now evaluate y before x, and
+  (b) we can't bind v to an unboxed pair
+
+Seq is very, very special!  So we recognise it right here, and desugar to
+        case x of _ -> case y of _ -> (# x,y #)
+
+Note [Desugaring seq (2)]  cf Trac #2273
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   let chp = case b of { True -> fst x; False -> 0 }
+   in chp `seq` ...chp...
+Here the seq is designed to plug the space leak of retaining (snd x)
+for too long.
+
+If we rely on the ordinary inlining of seq, we'll get
+   let chp = case b of { True -> fst x; False -> 0 }
+   case chp of _ { I# -> ...chp... }
+
+But since chp is cheap, and the case is an alluring contet, we'll
+inline chp into the case scrutinee.  Now there is only one use of chp,
+so we'll inline a second copy.  Alas, we've now ruined the purpose of
+the seq, by re-introducing the space leak:
+    case (case b of {True -> fst x; False -> 0}) of
+      I# _ -> ...case b of {True -> fst x; False -> 0}...
+
+We can try to avoid doing this by ensuring that the binder-swap in the
+case happens, so we get his at an early stage:
+   case chp of chp2 { I# -> ...chp2... }
+But this is fragile.  The real culprit is the source program.  Perhaps we
+should have said explicitly
+   let !chp2 = chp in ...chp2...
+
+But that's painful.  So the code here does a little hack to make seq
+more robust: a saturated application of 'seq' is turned *directly* into
+the case expression, thus:
+   x  `seq` e2 ==> case x of x -> e2    -- Note shadowing!
+   e1 `seq` e2 ==> case x of _ -> e2
+
+So we desugar our example to:
+   let chp = case b of { True -> fst x; False -> 0 }
+   case chp of chp { I# -> ...chp... }
+And now all is well.
+
+The reason it's a hack is because if you define mySeq=seq, the hack
+won't work on mySeq.
+
+Note [Desugaring seq (3)] cf Trac #2409
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The isLocalId ensures that we don't turn
+        True `seq` e
+into
+        case True of True { ... }
+which stupidly tries to bind the datacon 'True'.
+-}
+
+-- NB: Make sure the argument is not levity polymorphic
+mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
+mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
+  | f `hasKey` seqIdKey            -- Note [Desugaring seq (1), (2)]
+  = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
+  where
+    case_bndr = case arg1 of
+                   Var v1 | isInternalName (idName v1)
+                          -> v1        -- Note [Desugaring seq (2) and (3)]
+                   _      -> mkWildValBinder ty1
+
+mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in MkCore
+
+-- NB: No argument can be levity polymorphic
+mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
+mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args
+
+mkCastDs :: CoreExpr -> Coercion -> CoreExpr
+-- We define a desugarer-specific version of CoreUtils.mkCast,
+-- because in the immediate output of the desugarer, we can have
+-- apparently-mis-matched coercions:  E.g.
+--     let a = b
+--     in (x :: a) |> (co :: b ~ Int)
+-- Lint know about type-bindings for let and does not complain
+-- So here we do not make the assertion checks that we make in
+-- CoreUtils.mkCast; and we do less peephole optimisation too
+mkCastDs e co | isReflCo co = e
+              | otherwise   = Cast e co
+
+{-
+************************************************************************
+*                                                                      *
+               Tuples and selector bindings
+*                                                                      *
+************************************************************************
+
+This is used in various places to do with lazy patterns.
+For each binder $b$ in the pattern, we create a binding:
+\begin{verbatim}
+    b = case v of pat' -> b'
+\end{verbatim}
+where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.
+
+ToDo: making these bindings should really depend on whether there's
+much work to be done per binding.  If the pattern is complex, it
+should be de-mangled once, into a tuple (and then selected from).
+Otherwise the demangling can be in-line in the bindings (as here).
+
+Boring!  Boring!  One error message per binder.  The above ToDo is
+even more helpful.  Something very similar happens for pattern-bound
+expressions.
+
+Note [mkSelectorBinds]
+~~~~~~~~~~~~~~~~~~~~~~
+mkSelectorBinds is used to desugar a pattern binding {p = e},
+in a binding group:
+  let { ...; p = e; ... } in body
+where p binds x,y (this list of binders can be empty).
+There are two cases.
+
+------ Special case (A) -------
+  For a pattern that is just a variable,
+     let !x = e in body
+  ==>
+     let x = e in x `seq` body
+  So we return the binding, with 'x' as the variable to seq.
+
+------ Special case (B) -------
+  For a pattern that is essentially just a tuple:
+      * A product type, so cannot fail
+      * Only one level, so that
+          - generating multiple matches is fine
+          - seq'ing it evaluates the same as matching it
+  Then instead we generate
+       { v = e
+       ; x = case v of p -> x
+       ; y = case v of p -> y }
+  with 'v' as the variable to force
+
+------ General case (C) -------
+  In the general case we generate these bindings:
+       let { ...; p = e; ... } in body
+  ==>
+       let { t = case e of p -> (x,y)
+           ; x = case t of (x,y) -> x
+           ; y = case t of (x,y) -> y }
+       in t `seq` body
+
+  Note that we return 't' as the variable to force if the pattern
+  is strict (i.e. with -XStrict or an outermost-bang-pattern)
+
+  Note that (A) /includes/ the situation where
+
+   * The pattern binds exactly one variable
+        let !(Just (Just x) = e in body
+     ==>
+       let { t = case e of Just (Just v) -> Unit v
+           ; v = case t of Unit v -> v }
+       in t `seq` body
+    The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn
+    Note that forcing 't' makes the pattern match happen,
+    but does not force 'v'.
+
+  * The pattern binds no variables
+        let !(True,False) = e in body
+    ==>
+        let t = case e of (True,False) -> ()
+        in t `seq` body
+
+
+------ Examples ----------
+  *   !(_, (_, a)) = e
+    ==>
+      t = case e of (_, (_, a)) -> Unit a
+      a = case t of Unit a -> a
+
+    Note that
+     - Forcing 't' will force the pattern to match fully;
+       e.g. will diverge if (snd e) is bottom
+     - But 'a' itself is not forced; it is wrapped in a one-tuple
+       (see Note [One-tuples] in TysWiredIn)
+
+  *   !(Just x) = e
+    ==>
+      t = case e of Just x -> Unit x
+      x = case t of Unit x -> x
+
+    Again, forcing 't' will fail if 'e' yields Nothing.
+
+Note that even though this is rather general, the special cases
+work out well:
+
+* One binder, not -XStrict:
+
+    let Just (Just v) = e in body
+  ==>
+    let t = case e of Just (Just v) -> Unit v
+        v = case t of Unit v -> v
+    in body
+  ==>
+    let v = case (case e of Just (Just v) -> Unit v) of
+              Unit v -> v
+    in body
+  ==>
+    let v = case e of Just (Just v) -> v
+    in body
+
+* Non-recursive, -XStrict
+     let p = e in body
+  ==>
+     let { t = case e of p -> (x,y)
+         ; x = case t of (x,y) -> x
+         ; y = case t of (x,y) -> x }
+     in t `seq` body
+  ==> {inline seq, float x,y bindings inwards}
+     let t = case e of p -> (x,y) in
+     case t of t' ->
+     let { x = case t' of (x,y) -> x
+         ; y = case t' of (x,y) -> x } in
+     body
+  ==> {inline t, do case of case}
+     case e of p ->
+     let t = (x,y) in
+     let { x = case t' of (x,y) -> x
+         ; y = case t' of (x,y) -> x } in
+     body
+  ==> {case-cancellation, drop dead code}
+     case e of p -> body
+
+* Special case (B) is there to avoid fruitlessly taking the tuple
+  apart and rebuilding it. For example, consider
+     { K x y = e }
+  where K is a product constructor.  Then general case (A) does:
+     { t = case e of K x y -> (x,y)
+     ; x = case t of (x,y) -> x
+     ; y = case t of (x,y) -> y }
+  In the lazy case we can't optimise out this fruitless taking apart
+  and rebuilding.  Instead (B) builds
+     { v = e
+     ; x = case v of K x y -> x
+     ; y = case v of K x y -> y }
+  which is better.
+-}
+
+mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
+                -> LPat GhcTc     -- ^ The pattern
+                -> CoreExpr       -- ^ Expression to which the pattern is bound
+                -> DsM (Id,[(Id,CoreExpr)])
+                -- ^ Id the rhs is bound to, for desugaring strict
+                -- binds (see Note [Desugar Strict binds] in DsBinds)
+                -- and all the desugared binds
+
+mkSelectorBinds ticks pat val_expr
+  | (dL->L _ (VarPat _ (dL->L _ v))) <- pat'     -- Special case (A)
+  = return (v, [(v, val_expr)])
+
+  | is_flat_prod_lpat pat'           -- Special case (B)
+  = do { let pat_ty = hsLPatType pat'
+       ; val_var <- newSysLocalDsNoLP pat_ty
+
+       ; let mk_bind tick bndr_var
+               -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }
+               -- Remember, 'pat' binds 'bv'
+               = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'
+                                       (Var bndr_var)
+                                       (Var bndr_var)  -- Neat hack
+                      -- Neat hack: since 'pat' can't fail, the
+                      -- "fail-expr" passed to matchSimply is not
+                      -- used. But it /is/ used for its type, and for
+                      -- that bndr_var is just the ticket.
+                    ; return (bndr_var, mkOptTickBox tick rhs_expr) }
+
+       ; binds <- zipWithM mk_bind ticks' binders
+       ; return ( val_var, (val_var, val_expr) : binds) }
+
+  | otherwise                          -- General case (C)
+  = do { tuple_var  <- newSysLocalDs tuple_ty
+       ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')
+       ; tuple_expr <- matchSimply val_expr PatBindRhs pat
+                                   local_tuple error_expr
+       ; let mk_tup_bind tick binder
+               = (binder, mkOptTickBox tick $
+                          mkTupleSelector1 local_binders binder
+                                           tuple_var (Var tuple_var))
+             tup_binds = zipWith mk_tup_bind ticks' binders
+       ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) }
+  where
+    pat' = strip_bangs pat
+           -- Strip the bangs before looking for case (A) or (B)
+           -- The incoming pattern may well have a bang on it
+
+    binders = collectPatBinders pat'
+    ticks'  = ticks ++ repeat []
+
+    local_binders = map localiseId binders      -- See Note [Localise pattern binders]
+    local_tuple   = mkBigCoreVarTup1 binders
+    tuple_ty      = exprType local_tuple
+
+strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p)
+-- Remove outermost bangs and parens
+strip_bangs (dL->L _ (ParPat _ p))  = strip_bangs p
+strip_bangs (dL->L _ (BangPat _ p)) = strip_bangs p
+strip_bangs lp                      = lp
+
+is_flat_prod_lpat :: LPat (GhcPass p) -> Bool
+is_flat_prod_lpat = is_flat_prod_pat . unLoc
+
+is_flat_prod_pat :: Pat (GhcPass p) -> Bool
+is_flat_prod_pat (ParPat _ p)          = is_flat_prod_lpat p
+is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
+is_flat_prod_pat (ConPatOut { pat_con  = (dL->L _ pcon)
+                            , pat_args = ps})
+  | RealDataCon con <- pcon
+  , isProductTyCon (dataConTyCon con)
+  = all is_triv_lpat (hsConPatArgs ps)
+is_flat_prod_pat _ = False
+
+is_triv_lpat :: LPat (GhcPass p) -> Bool
+is_triv_lpat = is_triv_pat . unLoc
+
+is_triv_pat :: Pat (GhcPass p) -> Bool
+is_triv_pat (VarPat {})  = True
+is_triv_pat (WildPat{})  = True
+is_triv_pat (ParPat _ p) = is_triv_lpat p
+is_triv_pat _            = False
+
+
+{- *********************************************************************
+*                                                                      *
+  Creating big tuples and their types for full Haskell expressions.
+  They work over *Ids*, and create tuples replete with their types,
+  which is whey they are not in HsUtils.
+*                                                                      *
+********************************************************************* -}
+
+mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
+mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed
+mkLHsPatTup [lpat] = lpat
+mkLHsPatTup lpats  = cL (getLoc (head lpats)) $
+                     mkVanillaTuplePat lpats Boxed
+
+mkLHsVarPatTup :: [Id] -> LPat GhcTc
+mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)
+
+mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
+-- A vanilla tuple pattern simply gets its type from its sub-patterns
+mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
+
+-- The Big equivalents for the source tuple expressions
+mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
+mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)
+
+mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc
+mkBigLHsTupId = mkChunkified mkLHsTupleExpr
+
+-- The Big equivalents for the source tuple patterns
+mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc
+mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)
+
+mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc
+mkBigLHsPatTupId = mkChunkified mkLHsPatTup
+
+{-
+************************************************************************
+*                                                                      *
+        Code for pattern-matching and other failures
+*                                                                      *
+************************************************************************
+
+Generally, we handle pattern matching failure like this: let-bind a
+fail-variable, and use that variable if the thing fails:
+\begin{verbatim}
+        let fail.33 = error "Help"
+        in
+        case x of
+                p1 -> ...
+                p2 -> fail.33
+                p3 -> fail.33
+                p4 -> ...
+\end{verbatim}
+Then
+\begin{itemize}
+\item
+If the case can't fail, then there'll be no mention of @fail.33@, and the
+simplifier will later discard it.
+
+\item
+If it can fail in only one way, then the simplifier will inline it.
+
+\item
+Only if it is used more than once will the let-binding remain.
+\end{itemize}
+
+There's a problem when the result of the case expression is of
+unboxed type.  Then the type of @fail.33@ is unboxed too, and
+there is every chance that someone will change the let into a case:
+\begin{verbatim}
+        case error "Help" of
+          fail.33 -> case ....
+\end{verbatim}
+
+which is of course utterly wrong.  Rather than drop the condition that
+only boxed types can be let-bound, we just turn the fail into a function
+for the primitive case:
+\begin{verbatim}
+        let fail.33 :: Void -> Int#
+            fail.33 = \_ -> error "Help"
+        in
+        case x of
+                p1 -> ...
+                p2 -> fail.33 void
+                p3 -> fail.33 void
+                p4 -> ...
+\end{verbatim}
+
+Now @fail.33@ is a function, so it can be let-bound.
+
+We would *like* to use join points here; in fact, these "fail variables" are
+paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as
+CPS functions - i.e. they take "join points" as parameters. It's not impossible
+to imagine extending our type system to allow passing join points around (very
+carefully), but we certainly don't support it now.
+
+99.99% of the time, the fail variables wind up as join points in short order
+anyway, and the Void# doesn't do much harm.
+-}
+
+mkFailurePair :: CoreExpr       -- Result type of the whole case expression
+              -> DsM (CoreBind, -- Binds the newly-created fail variable
+                                -- to \ _ -> expression
+                      CoreExpr) -- Fail variable applied to realWorld#
+-- See Note [Failure thunks and CPR]
+mkFailurePair expr
+  = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkFunTy` ty)
+       ; fail_fun_arg <- newSysLocalDs voidPrimTy
+       ; let real_arg = setOneShotLambda fail_fun_arg
+       ; return (NonRec fail_fun_var (Lam real_arg expr),
+                 App (Var fail_fun_var) (Var voidPrimId)) }
+  where
+    ty = exprType expr
+
+{-
+Note [Failure thunks and CPR]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(This note predates join points as formal entities (hence the quotation marks).
+We can't use actual join points here (see above); if we did, this would also
+solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR
+join points] in WorkWrap.)
+
+When we make a failure point we ensure that it
+does not look like a thunk. Example:
+
+   let fail = \rw -> error "urk"
+   in case x of
+        [] -> fail realWorld#
+        (y:ys) -> case ys of
+                    [] -> fail realWorld#
+                    (z:zs) -> (y,z)
+
+Reason: we know that a failure point is always a "join point" and is
+entered at most once.  Adding a dummy 'realWorld' token argument makes
+it clear that sharing is not an issue.  And that in turn makes it more
+CPR-friendly.  This matters a lot: if you don't get it right, you lose
+the tail call property.  For example, see Trac #3403.
+
+
+************************************************************************
+*                                                                      *
+              Ticks
+*                                                                      *
+********************************************************************* -}
+
+mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
+mkOptTickBox = flip (foldr Tick)
+
+mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr
+mkBinaryTickBox ixT ixF e = do
+       uq <- newUnique
+       this_mod <- getModule
+       let bndr1 = mkSysLocal (fsLit "t1") uq boolTy
+       let
+           falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)
+           trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)
+       --
+       return $ Case e bndr1 boolTy
+                       [ (DataAlt falseDataCon, [], falseBox)
+                       , (DataAlt trueDataCon,  [], trueBox)
+                       ]
+
+
+
+-- *******************************************************************
+
+{- Note [decideBangHood]
+~~~~~~~~~~~~~~~~~~~~~~~~
+With -XStrict we may make /outermost/ patterns more strict.
+E.g.
+       let (Just x) = e in ...
+          ==>
+       let !(Just x) = e in ...
+and
+       f x = e
+          ==>
+       f !x = e
+
+This adjustment is done by decideBangHood,
+
+  * Just before constructing an EqnInfo, in Match
+      (matchWrapper and matchSinglePat)
+
+  * When desugaring a pattern-binding in DsBinds.dsHsBind
+
+Note that it is /not/ done recursively.  See the -XStrict
+spec in the user manual.
+
+Specifically:
+   ~pat    => pat    -- when -XStrict (even if pat = ~pat')
+   !pat    => !pat   -- always
+   pat     => !pat   -- when -XStrict
+   pat     => pat    -- otherwise
+-}
+
+
+-- | Use -XStrict to add a ! or remove a ~
+-- See Note [decideBangHood]
+decideBangHood :: DynFlags
+               -> LPat GhcTc  -- ^ Original pattern
+               -> LPat GhcTc  -- Pattern with bang if necessary
+decideBangHood dflags lpat
+  | not (xopt LangExt.Strict dflags)
+  = lpat
+  | otherwise   --  -XStrict
+  = go lpat
+  where
+    go lp@(dL->L l p)
+      = case p of
+           ParPat x p    -> cL l (ParPat x (go p))
+           LazyPat _ lp' -> lp'
+           BangPat _ _   -> lp
+           _             -> cL l (BangPat noExt lp)
+
+-- | Unconditionally make a 'Pat' strict.
+addBang :: LPat GhcTc -- ^ Original pattern
+        -> LPat GhcTc -- ^ Banged pattern
+addBang = go
+  where
+    go lp@(dL->L l p)
+      = case p of
+           ParPat x p    -> cL l (ParPat x (go p))
+           LazyPat _ lp' -> cL l (BangPat noExt lp')
+                                  -- Should we bring the extension value over?
+           BangPat _ _   -> lp
+           _             -> cL l (BangPat noExt lp)
+
+isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
+
+-- Returns Just {..} if we're sure that the expression is True
+-- I.e.   * 'True' datacon
+--        * 'otherwise' Id
+--        * Trivial wappings of these
+-- The arguments to Just are any HsTicks that we have found,
+-- because we still want to tick then, even it they are always evaluated.
+isTrueLHsExpr (dL->L _ (HsVar _ (dL->L _ v)))
+  |  v `hasKey` otherwiseIdKey
+     || v `hasKey` getUnique trueDataConId
+                                              = Just return
+        -- trueDataConId doesn't have the same unique as trueDataCon
+isTrueLHsExpr (dL->L _ (HsConLikeOut _ con))
+  | con `hasKey` getUnique trueDataCon = Just return
+isTrueLHsExpr (dL->L _ (HsTick _ tickish e))
+    | Just ticks <- isTrueLHsExpr e
+    = Just (\x -> do wrapped <- ticks x
+                     return (Tick tickish wrapped))
+   -- This encodes that the result is constant True for Hpc tick purposes;
+   -- which is specifically what isTrueLHsExpr is trying to find out.
+isTrueLHsExpr (dL->L _ (HsBinTick _ ixT _ e))
+    | Just ticks <- isTrueLHsExpr e
+    = Just (\x -> do e <- ticks x
+                     this_mod <- getModule
+                     return (Tick (HpcTick this_mod ixT) e))
+
+isTrueLHsExpr (dL->L _ (HsPar _ e))   = isTrueLHsExpr e
+isTrueLHsExpr _                       = Nothing
diff --git a/compiler/deSugar/ExtractDocs.hs b/compiler/deSugar/ExtractDocs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/ExtractDocs.hs
@@ -0,0 +1,350 @@
+-- | Extract docs from the renamer output so they can be be serialized.
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module ExtractDocs (extractDocs) where
+
+import GhcPrelude
+import Bag
+import HsBinds
+import HsDoc
+import HsDecls
+import HsExtension
+import HsTypes
+import HsUtils
+import Name
+import NameSet
+import SrcLoc
+import TcRnTypes
+
+import Control.Applicative
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe
+import Data.Semigroup
+
+-- | Extract docs from renamer output.
+extractDocs :: TcGblEnv
+            -> (Maybe HsDocString, DeclDocMap, ArgDocMap)
+            -- ^
+            -- 1. Module header
+            -- 2. Docs on top level declarations
+            -- 3. Docs on arguments
+extractDocs TcGblEnv { tcg_semantic_mod = mod
+                     , tcg_rn_decls = mb_rn_decls
+                     , tcg_insts = insts
+                     , tcg_fam_insts = fam_insts
+                     , tcg_doc_hdr = mb_doc_hdr
+                     } =
+    (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map)
+  where
+    (doc_map, arg_map) = maybe (M.empty, M.empty)
+                               (mkMaps local_insts)
+                               mb_decls_with_docs
+    mb_decls_with_docs = topDecls <$> mb_rn_decls
+    local_insts = filter (nameIsLocalOrFrom mod)
+                         $ map getName insts ++ map getName fam_insts
+
+-- | Create decl and arg doc-maps by looping through the declarations.
+-- For each declaration, find its names, its subordinates, and its doc strings.
+mkMaps :: [Name]
+       -> [(LHsDecl GhcRn, [HsDocString])]
+       -> (Map Name (HsDocString), Map Name (Map Int (HsDocString)))
+mkMaps instances decls =
+    ( f' (map (nubByName fst) decls')
+    , f  (filterMapping (not . M.null) args)
+    )
+  where
+    (decls', args) = unzip (map mappings decls)
+
+    f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b
+    f = M.fromListWith (<>) . concat
+
+    f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString
+    f' = M.fromListWith appendDocs . concat
+
+    filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]
+    filterMapping p = map (filter (p . snd))
+
+    mappings :: (LHsDecl GhcRn, [HsDocString])
+             -> ( [(Name, HsDocString)]
+                , [(Name, Map Int (HsDocString))]
+                )
+    mappings (L l decl, docStrs) =
+           (dm, am)
+      where
+        doc = concatDocs docStrs
+        args = declTypeDocs decl
+
+        subs :: [(Name, [(HsDocString)], Map Int (HsDocString))]
+        subs = subordinates instanceMap decl
+
+        (subDocs, subArgs) =
+          unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs)
+
+        ns = names l decl
+        subNs = [ n | (n, _, _) <- subs ]
+        dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs]
+        am = [(n, args) | n <- ns] ++ zip subNs subArgs
+
+    instanceMap :: Map SrcSpan Name
+    instanceMap = M.fromList [(getSrcSpan n, n) | n <- instances]
+
+    names :: SrcSpan -> HsDecl GhcRn -> [Name]
+    names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See
+                                                                 -- Note [1].
+      where loc = case d of
+              TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only
+                                  -- for TFs
+              _ -> getInstLoc d
+    names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].
+    names _ decl = getMainDeclBinder decl
+
+{-
+Note [1]:
+---------
+We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried
+inside them. That should work for normal user-written instances (from
+looking at GHC sources). We can assume that commented instances are
+user-written. This lets us relate Names (from ClsInsts) to comments
+(associated with InstDecls and DerivDecls).
+-}
+
+getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]
+getMainDeclBinder (TyClD _ d) = [tcdName d]
+getMainDeclBinder (ValD _ d) =
+  case collectHsBindBinders d of
+    []       -> []
+    (name:_) -> [name]
+getMainDeclBinder (SigD _ d) = sigNameNoLoc d
+getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]
+getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []
+getMainDeclBinder _ = []
+
+sigNameNoLoc :: Sig pass -> [IdP pass]
+sigNameNoLoc (TypeSig    _   ns _)         = map unLoc ns
+sigNameNoLoc (ClassOpSig _ _ ns _)         = map unLoc ns
+sigNameNoLoc (PatSynSig  _   ns _)         = map unLoc ns
+sigNameNoLoc (SpecSig    _   n _ _)        = [unLoc n]
+sigNameNoLoc (InlineSig  _   n _)          = [unLoc n]
+sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns
+sigNameNoLoc _                             = []
+
+-- Extract the source location where an instance is defined. This is used
+-- to correlate InstDecls with their Instance/CoAxiom Names, via the
+-- instanceMap.
+getInstLoc :: InstDecl name -> SrcSpan
+getInstLoc = \case
+  ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)
+  DataFamInstD _ (DataFamInstDecl
+    { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = (dL->L l _) }}}) -> l
+  TyFamInstD _ (TyFamInstDecl
+    -- Since CoAxioms' Names refer to the whole line for type family instances
+    -- in particular, we need to dig a bit deeper to pull out the entire
+    -- equation. This does not happen for data family instances, for some
+    -- reason.
+    { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = (dL->L l _) }}}) -> l
+  ClsInstD _ (XClsInstDecl _) -> error "getInstLoc"
+  DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
+  TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"
+  XInstDecl _ -> error "getInstLoc"
+  DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
+  TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"
+
+-- | Get all subordinate declarations inside a declaration, and their docs.
+-- A subordinate declaration is something like the associate type or data
+-- family of a type class.
+subordinates :: Map SrcSpan Name
+             -> HsDecl GhcRn
+             -> [(Name, [(HsDocString)], Map Int (HsDocString))]
+subordinates instMap decl = case decl of
+  InstD _ (ClsInstD _ d) -> do
+    DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+      FamEqn { feqn_tycon = (dL->L l _)
+             , feqn_rhs   = defn }}} <- unLoc <$> cid_datafam_insts d
+    [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn
+
+  InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))
+    -> dataSubs (feqn_rhs d)
+  TyClD _ d | isClassDecl d -> classSubs d
+            | isDataDecl  d -> dataSubs (tcdDataDefn d)
+  _ -> []
+  where
+    classSubs dd = [ (name, doc, declTypeDocs d)
+                   | (dL->L _ d, doc) <- classDecls dd
+                   , name <- getMainDeclBinder d, not (isValD d)
+                   ]
+    dataSubs :: HsDataDefn GhcRn
+             -> [(Name, [HsDocString], Map Int (HsDocString))]
+    dataSubs dd = constrs ++ fields ++ derivs
+      where
+        cons = map unLoc $ (dd_cons dd)
+        constrs = [ ( unLoc cname
+                    , maybeToList $ fmap unLoc $ con_doc c
+                    , conArgDocs c)
+                  | c <- cons, cname <- getConNames c ]
+        fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)
+                  | RecCon flds <- map getConArgs cons
+                  , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
+                  , (dL->L _ n) <- ns ]
+        derivs  = [ (instName, [unLoc doc], M.empty)
+                  | HsIB { hsib_body = (dL->L l (HsDocTy _ _ doc)) }
+                      <- concatMap (unLoc . deriv_clause_tys . unLoc) $
+                           unLoc $ dd_derivs dd
+                  , Just instName <- [M.lookup l instMap] ]
+
+-- | Extract constructor argument docs from inside constructor decls.
+conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString)
+conArgDocs con = case getConArgs con of
+                   PrefixCon args -> go 0 (map unLoc args ++ ret)
+                   InfixCon arg1 arg2 -> go 0 ([unLoc arg1, unLoc arg2] ++ ret)
+                   RecCon _ -> go 1 ret
+  where
+    go n (HsDocTy _ _ (dL->L _ ds) : tys) = M.insert n ds $ go (n+1) tys
+    go n (_ : tys) = go (n+1) tys
+    go _ [] = M.empty
+
+    ret = case con of
+            ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]
+            _ -> []
+
+isValD :: HsDecl a -> Bool
+isValD (ValD _ _) = True
+isValD _ = False
+
+-- | All the sub declarations of a class (that we handle), ordered by
+-- source location, with documentation attached if it exists.
+classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
+classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls
+  where
+    decls = docs ++ defs ++ sigs ++ ats
+    docs  = mkDecls tcdDocs (DocD noExt) class_
+    defs  = mkDecls (bagToList . tcdMeths) (ValD noExt) class_
+    sigs  = mkDecls tcdSigs (SigD noExt) class_
+    ats   = mkDecls tcdATs (TyClD noExt . FamDecl noExt) class_
+
+-- | Extract function argument docs from inside top-level decls.
+declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString)
+declTypeDocs = \case
+  SigD  _ (TypeSig _ _ ty)          -> typeDocs (unLoc (hsSigWcType ty))
+  SigD  _ (ClassOpSig _ _ _ ty)     -> typeDocs (unLoc (hsSigType ty))
+  SigD  _ (PatSynSig _ _ ty)        -> typeDocs (unLoc (hsSigType ty))
+  ForD  _ (ForeignImport _ _ ty _)  -> typeDocs (unLoc (hsSigType ty))
+  TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty)
+  _                                 -> M.empty
+
+nubByName :: (a -> Name) -> [a] -> [a]
+nubByName f ns = go emptyNameSet ns
+  where
+    go _ [] = []
+    go s (x:xs)
+      | y `elemNameSet` s = go s xs
+      | otherwise         = let s' = extendNameSet s y
+                            in x : go s' xs
+      where
+        y = f x
+
+-- | Extract function argument docs from inside types.
+typeDocs :: HsType GhcRn -> Map Int (HsDocString)
+typeDocs = go 0
+  where
+    go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
+    go n (HsQualTy   { hst_body = ty }) = go n (unLoc ty)
+    go n (HsFunTy _ (dL->L _
+                      (HsDocTy _ _ (dL->L _ x))) (dL->L _ ty)) =
+       M.insert n x $ go (n+1) ty
+    go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty)
+    go n (HsDocTy _ _ (dL->L _ doc)) = M.singleton n doc
+    go _ _ = M.empty
+
+-- | The top-level declarations of a module that we care about,
+-- ordered by source location, with documentation attached if it exists.
+topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]
+topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup
+
+-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.
+ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]
+ungroup group_ =
+  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExt)  group_ ++
+  mkDecls hs_derivds             (DerivD noExt) group_ ++
+  mkDecls hs_defds               (DefD noExt)   group_ ++
+  mkDecls hs_fords               (ForD noExt)   group_ ++
+  mkDecls hs_docs                (DocD noExt)   group_ ++
+  mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt)  group_ ++
+  mkDecls (typesigs . hs_valds)  (SigD noExt)   group_ ++
+  mkDecls (valbinds . hs_valds)  (ValD noExt)   group_
+  where
+    typesigs (XValBindsLR (NValBinds _ sigs)) = filter (isUserSig . unLoc) sigs
+    typesigs _ = error "expected ValBindsOut"
+
+    valbinds (XValBindsLR (NValBinds binds _)) =
+      concatMap bagToList . snd . unzip $ binds
+    valbinds _ = error "expected ValBindsOut"
+
+-- | Sort by source location
+sortByLoc :: [Located a] -> [Located a]
+sortByLoc = sortOn getLoc
+
+-- | Collect docs and attach them to the right declarations.
+--
+-- A declaration may have multiple doc strings attached to it.
+collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])]
+-- ^ This is an example.
+collectDocs = go Nothing []
+  where
+    go Nothing _ [] = []
+    go (Just prev) docs [] = finished prev docs []
+    go prev docs ((dL->L _ (DocD _ (DocCommentNext str))) : ds)
+      | Nothing <- prev = go Nothing (str:docs) ds
+      | Just decl <- prev = finished decl docs (go Nothing [str] ds)
+    go prev docs ((dL->L _ (DocD _ (DocCommentPrev str))) : ds) =
+      go prev (str:docs) ds
+    go Nothing docs (d:ds) = go (Just d) docs ds
+    go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)
+
+    finished decl docs rest = (decl, reverse docs) : rest
+
+-- | Filter out declarations that we don't handle in Haddock
+filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
+filterDecls = filter (isHandled . unLoc . fst)
+  where
+    isHandled (ForD _ (ForeignImport {})) = True
+    isHandled (TyClD {})  = True
+    isHandled (InstD {})  = True
+    isHandled (DerivD {}) = True
+    isHandled (SigD _ d)  = isUserSig d
+    isHandled (ValD {})   = True
+    -- we keep doc declarations to be able to get at named docs
+    isHandled (DocD {})   = True
+    isHandled _ = False
+
+
+-- | Go through all class declarations and filter their sub-declarations
+filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]
+filterClasses decls = [ if isClassD d then (cL loc (filterClass d), doc) else x
+                      | x@(dL->L loc d, doc) <- decls ]
+  where
+    filterClass (TyClD x c) =
+      TyClD x $ c { tcdSigs =
+        filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }
+    filterClass _ = error "expected TyClD"
+
+-- | Was this signature given by the user?
+isUserSig :: Sig name -> Bool
+isUserSig TypeSig {}    = True
+isUserSig ClassOpSig {} = True
+isUserSig PatSynSig {}  = True
+isUserSig _             = False
+
+isClassD :: HsDecl a -> Bool
+isClassD (TyClD _ d) = isClassDecl d
+isClassD _ = False
+
+-- | Take a field of declarations from a data structure and create HsDecls
+-- using the given constructor
+mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]
+mkDecls field con struct = [ cL loc (con decl)
+                           | (dL->L loc decl) <- field struct ]
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/Match.hs
@@ -0,0 +1,1129 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+The @match@ function
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Match ( match, matchEquations, matchWrapper, matchSimply
+             , matchSinglePat, matchSinglePatVar ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr)
+
+import BasicTypes ( Origin(..) )
+import DynFlags
+import HsSyn
+import TcHsSyn
+import TcEvidence
+import TcRnMonad
+import Check
+import CoreSyn
+import Literal
+import CoreUtils
+import MkCore
+import DsMonad
+import DsBinds
+import DsGRHSs
+import DsUtils
+import Id
+import ConLike
+import DataCon
+import PatSyn
+import MatchCon
+import MatchLit
+import Type
+import Coercion ( eqCoercion )
+import TyCon( isNewTyCon )
+import TysWiredIn
+import SrcLoc
+import Maybes
+import Util
+import Name
+import Outputable
+import BasicTypes ( isGenerated, il_value, fl_value )
+import FastString
+import Unique
+import UniqDFM
+
+import Control.Monad( when, unless )
+import Data.List ( groupBy )
+import qualified Data.Map as Map
+
+{-
+************************************************************************
+*                                                                      *
+                The main matching function
+*                                                                      *
+************************************************************************
+
+The function @match@ is basically the same as in the Wadler chapter
+from "The Implementation of Functional Programming Languages",
+except it is monadised, to carry around the name supply, info about
+annotations, etc.
+
+Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:
+\begin{enumerate}
+\item
+A list of $n$ variable names, those variables presumably bound to the
+$n$ expressions being matched against the $n$ patterns.  Using the
+list of $n$ expressions as the first argument showed no benefit and
+some inelegance.
+
+\item
+The second argument, a list giving the ``equation info'' for each of
+the $m$ equations:
+\begin{itemize}
+\item
+the $n$ patterns for that equation, and
+\item
+a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on
+the front'' of the matching code, as in:
+\begin{verbatim}
+let <binds>
+in  <matching-code>
+\end{verbatim}
+\item
+and finally: (ToDo: fill in)
+
+The right way to think about the ``after-match function'' is that it
+is an embryonic @CoreExpr@ with a ``hole'' at the end for the
+final ``else expression''.
+\end{itemize}
+
+There is a data type, @EquationInfo@, defined in module @DsMonad@.
+
+An experiment with re-ordering this information about equations (in
+particular, having the patterns available in column-major order)
+showed no benefit.
+
+\item
+A default expression---what to evaluate if the overall pattern-match
+fails.  This expression will (almost?) always be
+a measly expression @Var@, unless we know it will only be used once
+(as we do in @glue_success_exprs@).
+
+Leaving out this third argument to @match@ (and slamming in lots of
+@Var "fail"@s) is a positively {\em bad} idea, because it makes it
+impossible to share the default expressions.  (Also, it stands no
+chance of working in our post-upheaval world of @Locals@.)
+\end{enumerate}
+
+Note: @match@ is often called via @matchWrapper@ (end of this module),
+a function that does much of the house-keeping that goes with a call
+to @match@.
+
+It is also worth mentioning the {\em typical} way a block of equations
+is desugared with @match@.  At each stage, it is the first column of
+patterns that is examined.  The steps carried out are roughly:
+\begin{enumerate}
+\item
+Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add
+bindings to the second component of the equation-info):
+\item
+Now {\em unmix} the equations into {\em blocks} [w\/ local function
+@match_groups@], in which the equations in a block all have the same
+ match group.
+(see ``the mixture rule'' in SLPJ).
+\item
+Call the right match variant on each block of equations; it will do the
+appropriate thing for each kind of column-1 pattern.
+\end{enumerate}
+
+We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)
+than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).
+And gluing the ``success expressions'' together isn't quite so pretty.
+
+This  @match@ uses @tidyEqnInfo@
+to get `as'- and `twiddle'-patterns out of the way (tidying), before
+applying ``the mixture rule'' (SLPJ, p.~88) [which really {\em
+un}mixes the equations], producing a list of equation-info
+blocks, each block having as its first column patterns compatible with each other.
+
+Note [Match Ids]
+~~~~~~~~~~~~~~~~
+Most of the matching functions take an Id or [Id] as argument.  This Id
+is the scrutinee(s) of the match. The desugared expression may
+sometimes use that Id in a local binding or as a case binder.  So it
+should not have an External name; Lint rejects non-top-level binders
+with External names (Trac #13043).
+
+See also Note [Localise pattern binders] in DsUtils
+-}
+
+type MatchId = Id   -- See Note [Match Ids]
+
+match :: [MatchId]        -- ^ Variables rep\'ing the exprs we\'re matching with
+                          -- ^ See Note [Match Ids]
+      -> Type             -- ^ Type of the case expression
+      -> [EquationInfo]   -- ^ Info about patterns, etc. (type synonym below)
+      -> DsM MatchResult  -- ^ Desugared result!
+
+match [] ty eqns
+  = ASSERT2( not (null eqns), ppr ty )
+    return (foldr1 combineMatchResults match_results)
+  where
+    match_results = [ ASSERT( null (eqn_pats eqn) )
+                      eqn_rhs eqn
+                    | eqn <- eqns ]
+
+match vars@(v:_) ty eqns    -- Eqns *can* be empty
+  = ASSERT2( all (isInternalName . idName) vars, ppr vars )
+    do  { dflags <- getDynFlags
+                -- Tidy the first pattern, generating
+                -- auxiliary bindings if necessary
+        ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns
+
+                -- Group the equations and match each group in turn
+        ; let grouped = groupEquations dflags tidy_eqns
+
+         -- print the view patterns that are commoned up to help debug
+        ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
+
+        ; match_results <- match_groups grouped
+        ; return (adjustMatchResult (foldr (.) id aux_binds) $
+                  foldr1 combineMatchResults match_results) }
+  where
+    dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]
+    dropGroup = map snd
+
+    match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult]
+    -- Result list of [MatchResult] is always non-empty
+    match_groups [] = matchEmpty v ty
+    match_groups gs = mapM match_group gs
+
+    match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult
+    match_group [] = panic "match_group"
+    match_group eqns@((group,_) : _)
+        = case group of
+            PgCon {}  -> matchConFamily  vars ty (subGroupUniq [(c,e) | (PgCon c, e) <- eqns])
+            PgSyn {}  -> matchPatSyn     vars ty (dropGroup eqns)
+            PgLit {}  -> matchLiterals   vars ty (subGroupOrd [(l,e) | (PgLit l, e) <- eqns])
+            PgAny     -> matchVariables  vars ty (dropGroup eqns)
+            PgN {}    -> matchNPats      vars ty (dropGroup eqns)
+            PgOverS {}-> matchNPats      vars ty (dropGroup eqns)
+            PgNpK {}  -> matchNPlusKPats vars ty (dropGroup eqns)
+            PgBang    -> matchBangs      vars ty (dropGroup eqns)
+            PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)
+            PgView {} -> matchView       vars ty (dropGroup eqns)
+            PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)
+
+    -- FIXME: we should also warn about view patterns that should be
+    -- commoned up but are not
+
+    -- print some stuff to see what's getting grouped
+    -- use -dppr-debug to see the resolution of overloaded literals
+    debug eqns =
+        let gs = map (\group -> foldr (\ (p,_) -> \acc ->
+                                           case p of PgView e _ -> e:acc
+                                                     _ -> acc) [] group) eqns
+            maybeWarn [] = return ()
+            maybeWarn l = warnDs NoReason (vcat l)
+        in
+          maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))
+                       (filter (not . null) gs))
+
+matchEmpty :: MatchId -> Type -> DsM [MatchResult]
+-- See Note [Empty case expressions]
+matchEmpty var res_ty
+  = return [MatchResult CanFail mk_seq]
+  where
+    mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty
+                                      [(DEFAULT, [], fail)]
+
+matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Real true variables, just like in matchVar, SLPJ p 94
+-- No binding to do: they'll all be wildcards by now (done in tidy)
+matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)
+matchVariables [] _ _ = panic "matchVariables"
+
+matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+matchBangs (var:vars) ty eqns
+  = do  { match_result <- match (var:vars) ty $
+                          map (decomposeFirstPat getBangPat) eqns
+        ; return (mkEvalMatchResult var ty match_result) }
+matchBangs [] _ _ = panic "matchBangs"
+
+matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Apply the coercion to the match variable and then match that
+matchCoercion (var:vars) ty (eqns@(eqn1:_))
+  = do  { let CoPat _ co pat _ = firstPat eqn1
+        ; let pat_ty' = hsPatType pat
+        ; var' <- newUniqueId var pat_ty'
+        ; match_result <- match (var':vars) ty $
+                          map (decomposeFirstPat getCoPat) eqns
+        ; core_wrap <- dsHsWrapper co
+        ; let bind = NonRec var' (core_wrap (Var var))
+        ; return (mkCoLetMatchResult bind match_result) }
+matchCoercion _ _ _ = panic "matchCoercion"
+
+matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+-- Apply the view function to the match variable and then match that
+matchView (var:vars) ty (eqns@(eqn1:_))
+  = do  { -- we could pass in the expr from the PgView,
+         -- but this needs to extract the pat anyway
+         -- to figure out the type of the fresh variable
+         let ViewPat _ viewExpr (dL->L _ pat) = firstPat eqn1
+         -- do the rest of the compilation
+        ; let pat_ty' = hsPatType pat
+        ; var' <- newUniqueId var pat_ty'
+        ; match_result <- match (var':vars) ty $
+                          map (decomposeFirstPat getViewPat) eqns
+         -- compile the view expressions
+        ; viewExpr' <- dsLExpr viewExpr
+        ; return (mkViewMatchResult var'
+                    (mkCoreAppDs (text "matchView") viewExpr' (Var var))
+                    match_result) }
+matchView _ _ _ = panic "matchView"
+
+matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult
+matchOverloadedList (var:vars) ty (eqns@(eqn1:_))
+-- Since overloaded list patterns are treated as view patterns,
+-- the code is roughly the same as for matchView
+  = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1
+       ; var' <- newUniqueId var (mkListTy elt_ty)  -- we construct the overall type by hand
+       ; match_result <- match (var':vars) ty $
+                            map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
+       ; e' <- dsSyntaxExpr e [Var var]
+       ; return (mkViewMatchResult var' e' match_result) }
+matchOverloadedList _ _ _ = panic "matchOverloadedList"
+
+-- decompose the first pattern and leave the rest alone
+decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo
+decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))
+        = eqn { eqn_pats = extractpat pat : pats}
+decomposeFirstPat _ _ = panic "decomposeFirstPat"
+
+getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc
+getCoPat (CoPat _ _ pat _)   = pat
+getCoPat _                   = panic "getCoPat"
+getBangPat (BangPat _ pat  ) = unLoc pat
+getBangPat _                 = panic "getBangPat"
+getViewPat (ViewPat _ _ pat) = unLoc pat
+getViewPat _                 = panic "getViewPat"
+getOLPat (ListPat (ListPatTc ty (Just _)) pats)
+        = ListPat (ListPatTc ty Nothing)  pats
+getOLPat _                   = panic "getOLPat"
+
+{-
+Note [Empty case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The list of EquationInfo can be empty, arising from
+    case x of {}   or    \case {}
+In that situation we desugar to
+    case x of { _ -> error "pattern match failure" }
+The *desugarer* isn't certain whether there really should be no
+alternatives, so it adds a default case, as it always does.  A later
+pass may remove it if it's inaccessible.  (See also Note [Empty case
+alternatives] in CoreSyn.)
+
+We do *not* desugar simply to
+   error "empty case"
+or some such, because 'x' might be bound to (error "hello"), in which
+case we want to see that "hello" exception, not (error "empty case").
+See also Note [Case elimination: lifted case] in Simplify.
+
+
+************************************************************************
+*                                                                      *
+                Tidying patterns
+*                                                                      *
+************************************************************************
+
+Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@
+which will be scrutinised.
+
+This makes desugaring the pattern match simpler by transforming some of
+the patterns to simpler forms. (Tuples to Constructor Patterns)
+
+Among other things in the resulting Pattern:
+* Variables and irrefutable(lazy) patterns are replaced by Wildcards
+* As patterns are replaced by the patterns they wrap.
+
+The bindings created by the above patterns are put into the returned wrapper
+instead.
+
+This means a definition of the form:
+  f x = rhs
+when called with v get's desugared to the equivalent of:
+  let x = v
+  in
+  f _ = rhs
+
+The same principle holds for as patterns (@) and
+irrefutable/lazy patterns (~).
+In the case of irrefutable patterns the irrefutable pattern is pushed into
+the binding.
+
+Pattern Constructors which only represent syntactic sugar are converted into
+their desugared representation.
+This usually means converting them to Constructor patterns but for some
+depends on enabled extensions. (Eg OverloadedLists)
+
+GHC also tries to convert overloaded Literals into regular ones.
+
+The result of this tidying is that the column of patterns will include
+only these which can be assigned a PatternGroup (see patGroup).
+
+-}
+
+tidyEqnInfo :: Id -> EquationInfo
+            -> DsM (DsWrapper, EquationInfo)
+        -- DsM'd because of internal call to dsLHsBinds
+        --      and mkSelectorBinds.
+        -- "tidy1" does the interesting stuff, looking at
+        -- one pattern and fiddling the list of bindings.
+        --
+        -- POST CONDITION: head pattern in the EqnInfo is
+        --      one of these for which patGroup is defined.
+
+tidyEqnInfo _ (EqnInfo { eqn_pats = [] })
+  = panic "tidyEqnInfo"
+
+tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })
+  = do { (wrap, pat') <- tidy1 v orig pat
+       ; return (wrap, eqn { eqn_pats = do pat' : pats }) }
+
+tidy1 :: Id                  -- The Id being scrutinised
+      -> Origin              -- Was this a pattern the user wrote?
+      -> Pat GhcTc           -- The pattern against which it is to be matched
+      -> DsM (DsWrapper,     -- Extra bindings to do before the match
+              Pat GhcTc)     -- Equivalent pattern
+
+-------------------------------------------------------
+--      (pat', mr') = tidy1 v pat mr
+-- tidies the *outer level only* of pat, giving pat'
+-- It eliminates many pattern forms (as-patterns, variable patterns,
+-- list patterns, etc) and returns any created bindings in the wrapper.
+
+tidy1 v o (ParPat _ pat)      = tidy1 v o (unLoc pat)
+tidy1 v o (SigPat _ pat _)    = tidy1 v o (unLoc pat)
+tidy1 _ _ (WildPat ty)        = return (idDsWrapper, WildPat ty)
+tidy1 v o (BangPat _ (dL->L l p)) = tidy_bang_pat v o l p
+
+        -- case v of { x -> mr[] }
+        -- = case v of { _ -> let x=v in mr[] }
+tidy1 v _ (VarPat _ (dL->L _ var))
+  = return (wrapBind var v, WildPat (idType var))
+
+        -- case v of { x@p -> mr[] }
+        -- = case v of { p -> let x=v in mr[] }
+tidy1 v o (AsPat _ (dL->L _ var) pat)
+  = do  { (wrap, pat') <- tidy1 v o (unLoc pat)
+        ; return (wrapBind var v . wrap, pat') }
+
+{- now, here we handle lazy patterns:
+    tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
+                        v2 = case v of p -> v2 : ... : bs )
+
+    where the v_i's are the binders in the pattern.
+
+    ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?
+
+    The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr
+-}
+
+tidy1 v _ (LazyPat _ pat)
+    -- This is a convenient place to check for unlifted types under a lazy pattern.
+    -- Doing this check during type-checking is unsatisfactory because we may
+    -- not fully know the zonked types yet. We sure do here.
+  = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat)
+        ; unless (null unlifted_bndrs) $
+          putSrcSpanDs (getLoc pat) $
+          errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$
+                       text "Unlifted variables:")
+                    2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id))
+                                 unlifted_bndrs)))
+
+        ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
+        ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]
+        ; return (mkCoreLets sel_binds, WildPat (idType v)) }
+
+tidy1 _ _ (ListPat (ListPatTc ty Nothing) pats )
+  = return (idDsWrapper, unLoc list_ConPat)
+  where
+    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])
+                        (mkNilPat ty)
+                        pats
+
+tidy1 _ _ (TuplePat tys pats boxity)
+  = return (idDsWrapper, unLoc tuple_ConPat)
+  where
+    arity = length pats
+    tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys
+
+tidy1 _ _ (SumPat tys pat alt arity)
+  = return (idDsWrapper, unLoc sum_ConPat)
+  where
+    sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys
+
+-- LitPats: we *might* be able to replace these w/ a simpler form
+tidy1 _ o (LitPat _ lit)
+  = do { unless (isGenerated o) $
+           warnAboutOverflowedLit lit
+       ; return (idDsWrapper, tidyLitPat lit) }
+
+-- NPats: we *might* be able to replace these w/ a simpler form
+tidy1 _ o (NPat ty (dL->L _ lit@OverLit { ol_val = v }) mb_neg eq)
+  = do { unless (isGenerated o) $
+           let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }
+                    | otherwise = lit
+           in warnAboutOverflowedOverLit lit'
+       ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }
+
+-- NPlusKPat: we may want to warn about the literals
+tidy1 _ o n@(NPlusKPat _ _ (dL->L _ lit1) lit2 _ _)
+  = do { unless (isGenerated o) $ do
+           warnAboutOverflowedOverLit lit1
+           warnAboutOverflowedOverLit lit2
+       ; return (idDsWrapper, n) }
+
+-- Everything else goes through unchanged...
+tidy1 _ _ non_interesting_pat
+  = return (idDsWrapper, non_interesting_pat)
+
+--------------------
+tidy_bang_pat :: Id -> Origin -> SrcSpan -> Pat GhcTc
+              -> DsM (DsWrapper, Pat GhcTc)
+
+-- Discard par/sig under a bang
+tidy_bang_pat v o _ (ParPat _ (dL->L l p)) = tidy_bang_pat v o l p
+tidy_bang_pat v o _ (SigPat _ (dL->L l p) _) = tidy_bang_pat v o l p
+
+-- Push the bang-pattern inwards, in the hope that
+-- it may disappear next time
+tidy_bang_pat v o l (AsPat x v' p)
+  = tidy1 v o (AsPat x v' (cL l (BangPat noExt p)))
+tidy_bang_pat v o l (CoPat x w p t)
+  = tidy1 v o (CoPat x w (BangPat noExt (cL l p)) t)
+
+-- Discard bang around strict pattern
+tidy_bang_pat v o _ p@(LitPat {})    = tidy1 v o p
+tidy_bang_pat v o _ p@(ListPat {})   = tidy1 v o p
+tidy_bang_pat v o _ p@(TuplePat {})  = tidy1 v o p
+tidy_bang_pat v o _ p@(SumPat {})    = tidy1 v o p
+
+-- Data/newtype constructors
+tidy_bang_pat v o l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc))
+                                 , pat_args = args
+                                 , pat_arg_tys = arg_tys })
+  -- Newtypes: push bang inwards (Trac #9844)
+  =
+    if isNewTyCon (dataConTyCon dc)
+      then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l ty args })
+      else tidy1 v o p  -- Data types: discard the bang
+    where
+      (ty:_) = dataConInstArgTys dc arg_tys
+
+-------------------
+-- Default case, leave the bang there:
+--    VarPat,
+--    LazyPat,
+--    WildPat,
+--    ViewPat,
+--    pattern synonyms (ConPatOut with PatSynCon)
+--    NPat,
+--    NPlusKPat
+--
+-- For LazyPat, remember that it's semantically like a VarPat
+--  i.e.  !(~p) is not like ~p, or p!  (Trac #8952)
+--
+-- NB: SigPatIn, ConPatIn should not happen
+
+tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExt (cL l p))
+
+-------------------
+push_bang_into_newtype_arg :: SrcSpan
+                           -> Type -- The type of the argument we are pushing
+                                   -- onto
+                           -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc
+-- See Note [Bang patterns and newtypes]
+-- We are transforming   !(N p)   into   (N !p)
+push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))
+  = ASSERT( null args)
+    PrefixCon [cL l (BangPat noExt arg)]
+push_bang_into_newtype_arg l _ty (RecCon rf)
+  | HsRecFields { rec_flds = (dL->L lf fld) : flds } <- rf
+  , HsRecField { hsRecFieldArg = arg } <- fld
+  = ASSERT( null flds)
+    RecCon (rf { rec_flds = [cL lf (fld { hsRecFieldArg
+                                           = cL l (BangPat noExt arg) })] })
+push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})
+  | HsRecFields { rec_flds = [] } <- rf
+  = PrefixCon [cL l (BangPat noExt (noLoc (WildPat ty)))]
+push_bang_into_newtype_arg _ _ cd
+  = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd)
+
+{-
+Note [Bang patterns and newtypes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For the pattern  !(Just pat)  we can discard the bang, because
+the pattern is strict anyway. But for !(N pat), where
+  newtype NT = N Int
+we definitely can't discard the bang.  Trac #9844.
+
+So what we do is to push the bang inwards, in the hope that it will
+get discarded there.  So we transform
+   !(N pat)   into    (N !pat)
+
+But what if there is nothing to push the bang onto? In at least one instance
+a user has written !(N {}) which we translate into (N !_). See #13215
+
+
+\noindent
+{\bf Previous @matchTwiddled@ stuff:}
+
+Now we get to the only interesting part; note: there are choices for
+translation [from Simon's notes]; translation~1:
+\begin{verbatim}
+deTwiddle [s,t] e
+\end{verbatim}
+returns
+\begin{verbatim}
+[ w = e,
+  s = case w of [s,t] -> s
+  t = case w of [s,t] -> t
+]
+\end{verbatim}
+
+Here \tr{w} is a fresh variable, and the \tr{w}-binding prevents multiple
+evaluation of \tr{e}.  An alternative translation (No.~2):
+\begin{verbatim}
+[ w = case e of [s,t] -> (s,t)
+  s = case w of (s,t) -> s
+  t = case w of (s,t) -> t
+]
+\end{verbatim}
+
+************************************************************************
+*                                                                      *
+\subsubsection[improved-unmixing]{UNIMPLEMENTED idea for improved unmixing}
+*                                                                      *
+************************************************************************
+
+We might be able to optimise unmixing when confronted by
+only-one-constructor-possible, of which tuples are the most notable
+examples.  Consider:
+\begin{verbatim}
+f (a,b,c) ... = ...
+f d ... (e:f) = ...
+f (g,h,i) ... = ...
+f j ...       = ...
+\end{verbatim}
+This definition would normally be unmixed into four equation blocks,
+one per equation.  But it could be unmixed into just one equation
+block, because if the one equation matches (on the first column),
+the others certainly will.
+
+You have to be careful, though; the example
+\begin{verbatim}
+f j ...       = ...
+-------------------
+f (a,b,c) ... = ...
+f d ... (e:f) = ...
+f (g,h,i) ... = ...
+\end{verbatim}
+{\em must} be broken into two blocks at the line shown; otherwise, you
+are forcing unnecessary evaluation.  In any case, the top-left pattern
+always gives the cue.  You could then unmix blocks into groups of...
+\begin{description}
+\item[all variables:]
+As it is now.
+\item[constructors or variables (mixed):]
+Need to make sure the right names get bound for the variable patterns.
+\item[literals or variables (mixed):]
+Presumably just a variant on the constructor case (as it is now).
+\end{description}
+
+************************************************************************
+*                                                                      *
+*  matchWrapper: a convenient way to call @match@                      *
+*                                                                      *
+************************************************************************
+\subsection[matchWrapper]{@matchWrapper@: a convenient interface to @match@}
+
+Calls to @match@ often involve similar (non-trivial) work; that work
+is collected here, in @matchWrapper@.  This function takes as
+arguments:
+\begin{itemize}
+\item
+Typechecked @Matches@ (of a function definition, or a case or lambda
+expression)---the main input;
+\item
+An error message to be inserted into any (runtime) pattern-matching
+failure messages.
+\end{itemize}
+
+As results, @matchWrapper@ produces:
+\begin{itemize}
+\item
+A list of variables (@Locals@) that the caller must ``promise'' to
+bind to appropriate values; and
+\item
+a @CoreExpr@, the desugared output (main result).
+\end{itemize}
+
+The main actions of @matchWrapper@ include:
+\begin{enumerate}
+\item
+Flatten the @[TypecheckedMatch]@ into a suitable list of
+@EquationInfo@s.
+\item
+Create as many new variables as there are patterns in a pattern-list
+(in any one of the @EquationInfo@s).
+\item
+Create a suitable ``if it fails'' expression---a call to @error@ using
+the error-string input; the {\em type} of this fail value can be found
+by examining one of the RHS expressions in one of the @EquationInfo@s.
+\item
+Call @match@ with all of this information!
+\end{enumerate}
+-}
+
+matchWrapper
+  :: HsMatchContext Name               -- ^ For shadowing warning messages
+  -> Maybe (LHsExpr GhcTc)             -- ^ Scrutinee, if we check a case expr
+  -> MatchGroup GhcTc (LHsExpr GhcTc)  -- ^ Matches being desugared
+  -> DsM ([Id], CoreExpr)              -- ^ Results (usually passed to 'match')
+
+{-
+ There is one small problem with the Lambda Patterns, when somebody
+ writes something similar to:
+\begin{verbatim}
+    (\ (x:xs) -> ...)
+\end{verbatim}
+ he/she don't want a warning about incomplete patterns, that is done with
+ the flag @opt_WarnSimplePatterns@.
+ This problem also appears in the:
+\begin{itemize}
+\item @do@ patterns, but if the @do@ can fail
+      it creates another equation if the match can fail
+      (see @DsExpr.doDo@ function)
+\item @let@ patterns, are treated by @matchSimply@
+   List Comprension Patterns, are treated by @matchSimply@ also
+\end{itemize}
+
+We can't call @matchSimply@ with Lambda patterns,
+due to the fact that lambda patterns can have more than
+one pattern, and match simply only accepts one pattern.
+
+JJQC 30-Nov-1997
+-}
+
+matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches)
+                             , mg_ext = MatchGroupTc arg_tys rhs_ty
+                             , mg_origin = origin })
+  = do  { dflags <- getDynFlags
+        ; locn   <- getSrcSpanDs
+
+        ; new_vars    <- case matches of
+                           []    -> mapM newSysLocalDsNoLP arg_tys
+                           (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
+
+        ; eqns_info   <- mapM (mk_eqn_info new_vars) matches
+
+        -- pattern match check warnings
+        ; unless (isGenerated origin) $
+          when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $
+          addTmCsDs (genCaseTmCs1 mb_scr new_vars) $
+              -- See Note [Type and Term Equality Propagation]
+          checkMatches dflags (DsMatchContext ctxt locn) new_vars matches
+
+        ; result_expr <- handleWarnings $
+                         matchEquations ctxt new_vars eqns_info rhs_ty
+        ; return (new_vars, result_expr) }
+  where
+    mk_eqn_info vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }))
+      = do { dflags <- getDynFlags
+           ; let upats = map (unLoc . decideBangHood dflags) pats
+                 dicts = collectEvVarsPats upats
+           ; tm_cs <- genCaseTmCs2 mb_scr upats vars
+           ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation]
+                             addTmCsDs tm_cs  $ -- See Note [Type and Term Equality Propagation]
+                             dsGRHSs ctxt grhss rhs_ty
+           ; return (EqnInfo { eqn_pats = upats
+                             , eqn_orig = FromSource
+                             , eqn_rhs = match_result }) }
+    mk_eqn_info _ (dL->L _ (XMatch _)) = panic "matchWrapper"
+    mk_eqn_info _ _  = panic "mk_eqn_info: Impossible Match" -- due to #15884
+
+    handleWarnings = if isGenerated origin
+                     then discardWarningsDs
+                     else id
+matchWrapper _ _ (XMatchGroup _) = panic "matchWrapper"
+
+matchEquations  :: HsMatchContext Name
+                -> [MatchId] -> [EquationInfo] -> Type
+                -> DsM CoreExpr
+matchEquations ctxt vars eqns_info rhs_ty
+  = do  { let error_doc = matchContextErrString ctxt
+
+        ; match_result <- match vars rhs_ty eqns_info
+
+        ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
+        ; extractMatchResult match_result fail_expr }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}
+*                                                                      *
+************************************************************************
+
+@mkSimpleMatch@ is a wrapper for @match@ which deals with the
+situation where we want to match a single expression against a single
+pattern. It returns an expression.
+-}
+
+matchSimply :: CoreExpr                 -- ^ Scrutinee
+            -> HsMatchContext Name      -- ^ Match kind
+            -> LPat GhcTc               -- ^ Pattern it should match
+            -> CoreExpr                 -- ^ Return this if it matches
+            -> CoreExpr                 -- ^ Return this if it doesn't
+            -> DsM CoreExpr
+-- Do not warn about incomplete patterns; see matchSinglePat comments
+matchSimply scrut hs_ctx pat result_expr fail_expr = do
+    let
+      match_result = cantFailMatchResult result_expr
+      rhs_ty       = exprType fail_expr
+        -- Use exprType of fail_expr, because won't refine in the case of failure!
+    match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result
+    extractMatchResult match_result' fail_expr
+
+matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat GhcTc
+               -> Type -> MatchResult -> DsM MatchResult
+-- matchSinglePat ensures that the scrutinee is a variable
+-- and then calls matchSinglePatVar
+--
+-- matchSinglePat does not warn about incomplete patterns
+-- Used for things like [ e | pat <- stuff ], where
+-- incomplete patterns are just fine
+
+matchSinglePat (Var var) ctx pat ty match_result
+  | not (isExternalName (idName var))
+  = matchSinglePatVar var ctx pat ty match_result
+
+matchSinglePat scrut hs_ctx pat ty match_result
+  = do { var           <- selectSimpleMatchVarL pat
+       ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result
+       ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
+
+matchSinglePatVar :: Id   -- See Note [Match Ids]
+                  -> HsMatchContext Name -> LPat GhcTc
+                  -> Type -> MatchResult -> DsM MatchResult
+matchSinglePatVar var ctx pat ty match_result
+  = ASSERT2( isInternalName (idName var), ppr var )
+    do { dflags <- getDynFlags
+       ; locn   <- getSrcSpanDs
+
+                    -- Pattern match check warnings
+       ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)
+
+       ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
+                                , eqn_orig = FromSource
+                                , eqn_rhs  = match_result }
+       ; match [var] ty [eqn_info] }
+
+
+{-
+************************************************************************
+*                                                                      *
+                Pattern classification
+*                                                                      *
+************************************************************************
+-}
+
+data PatGroup
+  = PgAny               -- Immediate match: variables, wildcards,
+                        --                  lazy patterns
+  | PgCon DataCon       -- Constructor patterns (incl list, tuple)
+  | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]
+  | PgLit Literal       -- Literal patterns
+  | PgN   Rational      -- Overloaded numeric literals;
+                        -- see Note [Don't use Literal for PgN]
+  | PgOverS FastString  -- Overloaded string literals
+  | PgNpK Integer       -- n+k patterns
+  | PgBang              -- Bang patterns
+  | PgCo Type           -- Coercion patterns; the type is the type
+                        --      of the pattern *inside*
+  | PgView (LHsExpr GhcTc) -- view pattern (e -> p):
+                        -- the LHsExpr is the expression e
+           Type         -- the Type is the type of p (equivalently, the result type of e)
+  | PgOverloadedList
+
+{- Note [Don't use Literal for PgN]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Previously we had, as PatGroup constructors
+
+  | ...
+  | PgN   Literal       -- Overloaded literals
+  | PgNpK Literal       -- n+k patterns
+  | ...
+
+But Literal is really supposed to represent an *unboxed* literal, like Int#.
+We were sticking the literal from, say, an overloaded numeric literal pattern
+into a LitInt constructor. This didn't really make sense; and we now have
+the invariant that value in a LitInt must be in the range of the target
+machine's Int# type, and an overloaded literal could meaningfully be larger.
+
+Solution: For pattern grouping purposes, just store the literal directly in
+the PgN constructor as a Rational if numeric, and add a PgOverStr constructor
+for overloaded strings.
+-}
+
+groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]
+-- If the result is of form [g1, g2, g3],
+-- (a) all the (pg,eq) pairs in g1 have the same pg
+-- (b) none of the gi are empty
+-- The ordering of equations is unchanged
+groupEquations dflags eqns
+  = groupBy same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]
+  where
+    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
+    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2
+
+subGroup :: (m -> [[EquationInfo]]) -- Map.elems
+         -> m -- Map.empty
+         -> (a -> m -> Maybe [EquationInfo]) -- Map.lookup
+         -> (a -> [EquationInfo] -> m -> m) -- Map.insert
+         -> [(a, EquationInfo)] -> [[EquationInfo]]
+-- Input is a particular group.  The result sub-groups the
+-- equations by with particular constructor, literal etc they match.
+-- Each sub-list in the result has the same PatGroup
+-- See Note [Take care with pattern order]
+-- Parameterized by map operations to allow different implementations
+-- and constraints, eg. types without Ord instance.
+subGroup elems empty lookup insert group
+    = map reverse $ elems $ foldl' accumulate empty group
+  where
+    accumulate pg_map (pg, eqn)
+      = case lookup pg pg_map of
+          Just eqns -> insert pg (eqn:eqns) pg_map
+          Nothing   -> insert pg [eqn]      pg_map
+    -- pg_map :: Map a [EquationInfo]
+    -- Equations seen so far in reverse order of appearance
+
+subGroupOrd :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
+subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert
+
+subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [[EquationInfo]]
+subGroupUniq =
+  subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v)
+
+{- Note [Pattern synonym groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see
+  f (P a) = e1
+  f (P b) = e2
+    ...
+where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the
+same group?  We can if P is a constructor, but /not/ if P is a pattern synonym.
+Consider (Trac #11224)
+   -- readMaybe :: Read a => String -> Maybe a
+   pattern PRead :: Read a => () => a -> String
+   pattern PRead a <- (readMaybe -> Just a)
+
+   f (PRead (x::Int))  = e1
+   f (PRead (y::Bool)) = e2
+This is all fine: we match the string by trying to read an Int; if that
+fails we try to read a Bool. But clearly we can't combine the two into a single
+match.
+
+Conclusion: we can combine when we invoke PRead /at the same type/.  Hence
+in PgSyn we record the instantiaing types, and use them in sameGroup.
+
+Note [Take care with pattern order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the subGroup function we must be very careful about pattern re-ordering,
+Consider the patterns [ (True, Nothing), (False, x), (True, y) ]
+Then in bringing together the patterns for True, we must not
+swap the Nothing and y!
+-}
+
+sameGroup :: PatGroup -> PatGroup -> Bool
+-- Same group means that a single case expression
+-- or test will suffice to match both, *and* the order
+-- of testing within the group is insignificant.
+sameGroup PgAny         PgAny         = True
+sameGroup PgBang        PgBang        = True
+sameGroup (PgCon _)     (PgCon _)     = True    -- One case expression
+sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2
+                                                -- eqTypes: See Note [Pattern synonym groups]
+sameGroup (PgLit _)     (PgLit _)     = True    -- One case expression
+sameGroup (PgN l1)      (PgN l2)      = l1==l2  -- Order is significant
+sameGroup (PgOverS s1)  (PgOverS s2)  = s1==s2
+sameGroup (PgNpK l1)    (PgNpK l2)    = l1==l2  -- See Note [Grouping overloaded literal patterns]
+sameGroup (PgCo t1)     (PgCo t2)     = t1 `eqType` t2
+        -- CoPats are in the same goup only if the type of the
+        -- enclosed pattern is the same. The patterns outside the CoPat
+        -- always have the same type, so this boils down to saying that
+        -- the two coercions are identical.
+sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)
+       -- ViewPats are in the same group iff the expressions
+       -- are "equal"---conservatively, we use syntactic equality
+sameGroup _          _          = False
+
+-- An approximation of syntactic equality used for determining when view
+-- exprs are in the same group.
+-- This function can always safely return false;
+-- but doing so will result in the application of the view function being repeated.
+--
+-- Currently: compare applications of literals and variables
+--            and anything else that we can do without involving other
+--            HsSyn types in the recursion
+--
+-- NB we can't assume that the two view expressions have the same type.  Consider
+--   f (e1 -> True) = ...
+--   f (e2 -> "hi") = ...
+viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool
+viewLExprEq (e1,_) (e2,_) = lexp e1 e2
+  where
+    lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool
+    lexp e e' = exp (unLoc e) (unLoc e')
+
+    ---------
+    exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
+    -- real comparison is on HsExpr's
+    -- strip parens
+    exp (HsPar _ (dL->L _ e)) e'   = exp e e'
+    exp e (HsPar _ (dL->L _ e'))   = exp e e'
+    -- because the expressions do not necessarily have the same type,
+    -- we have to compare the wrappers
+    exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e'
+    exp (HsVar _ i) (HsVar _ i') =  i == i'
+    exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'
+    -- the instance for IPName derives using the id, so this works if the
+    -- above does
+    exp (HsIPVar _ i) (HsIPVar _ i') = i == i'
+    exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x'
+    exp (HsOverLit _ l) (HsOverLit _ l') =
+        -- Overloaded lits are equal if they have the same type
+        -- and the data is the same.
+        -- this is coarser than comparing the SyntaxExpr's in l and l',
+        -- which resolve the overloading (e.g., fromInteger 1),
+        -- because these expressions get written as a bunch of different variables
+        -- (presumably to improve sharing)
+        eqType (overLitType l) (overLitType l') && l == l'
+    exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
+    -- the fixities have been straightened out by now, so it's safe
+    -- to ignore them?
+    exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
+        lexp l l' && lexp o o' && lexp ri ri'
+    exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
+    exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
+        lexp e1 e1' && lexp e2 e2'
+    exp (SectionR _ e1 e2) (SectionR _ e1' e2') =
+        lexp e1 e1' && lexp e2 e2'
+    exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) =
+        eq_list tup_arg es1 es2
+    exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'
+    exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') =
+        lexp e e' && lexp e1 e1' && lexp e2 e2'
+
+    -- Enhancement: could implement equality for more expressions
+    --   if it seems useful
+    -- But no need for HsLit, ExplicitList, ExplicitTuple,
+    -- because they cannot be functions
+    exp _ _  = False
+
+    ---------
+    syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool
+    syn_exp (SyntaxExpr { syn_expr      = expr1
+                        , syn_arg_wraps = arg_wraps1
+                        , syn_res_wrap  = res_wrap1 })
+            (SyntaxExpr { syn_expr      = expr2
+                        , syn_arg_wraps = arg_wraps2
+                        , syn_res_wrap  = res_wrap2 })
+      = exp expr1 expr2 &&
+        and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&
+        wrap res_wrap1 res_wrap2
+
+    ---------
+    tup_arg (dL->L _ (Present _ e1)) (dL->L _ (Present _ e2)) = lexp e1 e2
+    tup_arg (dL->L _ (Missing t1))   (dL->L _ (Missing t2))   = eqType t1 t2
+    tup_arg _ _ = False
+
+    ---------
+    wrap :: HsWrapper -> HsWrapper -> Bool
+    -- Conservative, in that it demands that wrappers be
+    -- syntactically identical and doesn't look under binders
+    --
+    -- Coarser notions of equality are possible
+    -- (e.g., reassociating compositions,
+    --        equating different ways of writing a coercion)
+    wrap WpHole WpHole = True
+    wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
+    wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2'
+    wrap (WpCast co)       (WpCast co')        = co `eqCoercion` co'
+    wrap (WpEvApp et1)     (WpEvApp et2)       = et1 `ev_term` et2
+    wrap (WpTyApp t)       (WpTyApp t')        = eqType t t'
+    -- Enhancement: could implement equality for more wrappers
+    --   if it seems useful (lams and lets)
+    wrap _ _ = False
+
+    ---------
+    ev_term :: EvTerm -> EvTerm -> Bool
+    ev_term (EvExpr (Var a)) (EvExpr  (Var b)) = a==b
+    ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b
+    ev_term _ _ = False
+
+    ---------
+    eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool
+    eq_list _  []     []     = True
+    eq_list _  []     (_:_)  = False
+    eq_list _  (_:_)  []     = False
+    eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys
+
+patGroup :: DynFlags -> Pat GhcTc -> PatGroup
+patGroup _ (ConPatOut { pat_con = (dL->L _ con)
+                      , pat_arg_tys = tys })
+ | RealDataCon dcon <- con              = PgCon dcon
+ | PatSynCon psyn <- con                = PgSyn psyn tys
+patGroup _ (WildPat {})                 = PgAny
+patGroup _ (BangPat {})                 = PgBang
+patGroup _ (NPat _ (dL->L _ (OverLit {ol_val=oval})) mb_neg _) =
+  case (oval, isJust mb_neg) of
+   (HsIntegral   i, False) -> PgN (fromInteger (il_value i))
+   (HsIntegral   i, True ) -> PgN (-fromInteger (il_value i))
+   (HsFractional r, False) -> PgN (fl_value r)
+   (HsFractional r, True ) -> PgN (-fl_value r)
+   (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)
+                          PgOverS s
+patGroup _ (NPlusKPat _ _ (dL->L _ (OverLit {ol_val=oval})) _ _ _) =
+  case oval of
+   HsIntegral i -> PgNpK (il_value i)
+   _ -> pprPanic "patGroup NPlusKPat" (ppr oval)
+patGroup _ (CoPat _ _ p _)              = PgCo  (hsPatType p)
+                                                    -- Type of innelexp pattern
+patGroup _ (ViewPat _ expr p)           = PgView expr (hsPatType (unLoc p))
+patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList
+patGroup dflags (LitPat _ lit)          = PgLit (hsLitKey dflags lit)
+patGroup _ pat                          = pprPanic "patGroup" (ppr pat)
+
+{-
+Note [Grouping overloaded literal patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+WATCH OUT!  Consider
+
+        f (n+1) = ...
+        f (n+2) = ...
+        f (n+1) = ...
+
+We can't group the first and third together, because the second may match
+the same thing as the first.  Same goes for *overloaded* literal patterns
+        f 1 True = ...
+        f 2 False = ...
+        f 1 False = ...
+If the first arg matches '1' but the second does not match 'True', we
+cannot jump to the third equation!  Because the same argument might
+match '2'!
+Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
+-}
diff --git a/compiler/deSugar/Match.hs-boot b/compiler/deSugar/Match.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/Match.hs-boot
@@ -0,0 +1,37 @@
+module Match where
+
+import GhcPrelude
+import Var      ( Id )
+import TcType   ( Type )
+import DsMonad  ( DsM, EquationInfo, MatchResult )
+import CoreSyn  ( CoreExpr )
+import HsSyn    ( LPat, HsMatchContext, MatchGroup, LHsExpr )
+import Name     ( Name )
+import HsExtension ( GhcTc )
+
+match   :: [Id]
+        -> Type
+        -> [EquationInfo]
+        -> DsM MatchResult
+
+matchWrapper
+        :: HsMatchContext Name
+        -> Maybe (LHsExpr GhcTc)
+        -> MatchGroup GhcTc (LHsExpr GhcTc)
+        -> DsM ([Id], CoreExpr)
+
+matchSimply
+        :: CoreExpr
+        -> HsMatchContext Name
+        -> LPat GhcTc
+        -> CoreExpr
+        -> CoreExpr
+        -> DsM CoreExpr
+
+matchSinglePatVar
+        :: Id
+        -> HsMatchContext Name
+        -> LPat GhcTc
+        -> Type
+        -> MatchResult
+        -> DsM MatchResult
diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/MatchCon.hs
@@ -0,0 +1,296 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Pattern-matching constructors
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module MatchCon ( matchConFamily, matchPatSyn ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} Match     ( match )
+
+import HsSyn
+import DsBinds
+import ConLike
+import BasicTypes ( Origin(..) )
+import TcType
+import DsMonad
+import DsUtils
+import MkCore   ( mkCoreLets )
+import Util
+import Id
+import NameEnv
+import FieldLabel ( flSelector )
+import SrcLoc
+import Outputable
+import Control.Monad(liftM)
+import Data.List (groupBy)
+
+{-
+We are confronted with the first column of patterns in a set of
+equations, all beginning with constructors from one ``family'' (e.g.,
+@[]@ and @:@ make up the @List@ ``family'').  We want to generate the
+alternatives for a @Case@ expression.  There are several choices:
+\begin{enumerate}
+\item
+Generate an alternative for every constructor in the family, whether
+they are used in this set of equations or not; this is what the Wadler
+chapter does.
+\begin{description}
+\item[Advantages:]
+(a)~Simple.  (b)~It may also be that large sparsely-used constructor
+families are mainly handled by the code for literals.
+\item[Disadvantages:]
+(a)~Not practical for large sparsely-used constructor families, e.g.,
+the ASCII character set.  (b)~Have to look up a list of what
+constructors make up the whole family.
+\end{description}
+
+\item
+Generate an alternative for each constructor used, then add a default
+alternative in case some constructors in the family weren't used.
+\begin{description}
+\item[Advantages:]
+(a)~Alternatives aren't generated for unused constructors.  (b)~The
+STG is quite happy with defaults.  (c)~No lookup in an environment needed.
+\item[Disadvantages:]
+(a)~A spurious default alternative may be generated.
+\end{description}
+
+\item
+``Do it right:'' generate an alternative for each constructor used,
+and add a default alternative if all constructors in the family
+weren't used.
+\begin{description}
+\item[Advantages:]
+(a)~You will get cases with only one alternative (and no default),
+which should be amenable to optimisation.  Tuples are a common example.
+\item[Disadvantages:]
+(b)~Have to look up constructor families in TDE (as above).
+\end{description}
+\end{enumerate}
+
+We are implementing the ``do-it-right'' option for now.  The arguments
+to @matchConFamily@ are the same as to @match@; the extra @Int@
+returned is the number of constructors in the family.
+
+The function @matchConFamily@ is concerned with this
+have-we-used-all-the-constructors? question; the local function
+@match_cons_used@ does all the real work.
+-}
+
+matchConFamily :: [Id]
+               -> Type
+               -> [[EquationInfo]]
+               -> DsM MatchResult
+-- Each group of eqns is for a single constructor
+matchConFamily (var:vars) ty groups
+  = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups
+       return (mkCoAlgCaseMatchResult var ty alts)
+  where
+    toRealAlt alt = case alt_pat alt of
+        RealDataCon dcon -> alt{ alt_pat = dcon }
+        _ -> panic "matchConFamily: not RealDataCon"
+matchConFamily [] _ _ = panic "matchConFamily []"
+
+matchPatSyn :: [Id]
+            -> Type
+            -> [EquationInfo]
+            -> DsM MatchResult
+matchPatSyn (var:vars) ty eqns
+  = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns
+       return (mkCoSynCaseMatchResult var ty alt)
+  where
+    toSynAlt alt = case alt_pat alt of
+        PatSynCon psyn -> alt{ alt_pat = psyn }
+        _ -> panic "matchPatSyn: not PatSynCon"
+matchPatSyn _ _ _ = panic "matchPatSyn []"
+
+type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc))
+
+matchOneConLike :: [Id]
+                -> Type
+                -> [EquationInfo]
+                -> DsM (CaseAlt ConLike)
+matchOneConLike vars ty (eqn1 : eqns)   -- All eqns for a single constructor
+  = do  { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs )
+                           -- ex_tvs can only be tyvars as data types in source
+                           -- Haskell cannot mention covar yet (Aug 2018).
+                         ASSERT( tvs1 `equalLength` ex_tvs )
+                         arg_tys ++ mkTyVarTys tvs1
+
+              val_arg_tys = conLikeInstOrigArgTys con1 inst_tys
+        -- dataConInstOrigArgTys takes the univ and existential tyvars
+        -- and returns the types of the *value* args, which is what we want
+
+              match_group :: [Id]
+                          -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
+              -- All members of the group have compatible ConArgPats
+              match_group arg_vars arg_eqn_prs
+                = ASSERT( notNull arg_eqn_prs )
+                  do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
+                     ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
+                     ; match_result <- match (group_arg_vars ++ vars) ty eqns'
+                     ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }
+
+              shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
+                                                             pat_binds = bind, pat_args = args
+                                                  } : pats }))
+                = do ds_bind <- dsTcEvBinds bind
+                     return ( wrapBinds (tvs `zip` tvs1)
+                            . wrapBinds (ds  `zip` dicts1)
+                            . mkCoreLets ds_bind
+                            , eqn { eqn_orig = Generated
+                                  , eqn_pats = conArgPats val_arg_tys args ++ pats }
+                            )
+              shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
+
+        ; arg_vars <- selectConMatchVars val_arg_tys args1
+                -- Use the first equation as a source of
+                -- suggestions for the new variables
+
+        -- Divide into sub-groups; see Note [Record patterns]
+        ; let groups :: [[(ConArgPats, EquationInfo)]]
+              groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn)
+                                               | eqn <- eqn1:eqns ]
+
+        ; match_results <- mapM (match_group arg_vars) groups
+
+        ; return $ MkCaseAlt{ alt_pat = con1,
+                              alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,
+                              alt_wrapper = wrapper1,
+                              alt_result = foldr1 combineMatchResults match_results } }
+  where
+    ConPatOut { pat_con = (dL->L _ con1)
+              , pat_arg_tys = arg_tys, pat_wrap = wrapper1,
+                pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }
+              = firstPat eqn1
+    fields1 = map flSelector (conLikeFieldLabels con1)
+
+    ex_tvs = conLikeExTyCoVars con1
+
+    -- Choose the right arg_vars in the right order for this group
+    -- Note [Record patterns]
+    select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id]
+    select_arg_vars arg_vars ((arg_pats, _) : _)
+      | RecCon flds <- arg_pats
+      , let rpats = rec_flds flds
+      , not (null rpats)     -- Treated specially; cf conArgPats
+      = ASSERT2( fields1 `equalLength` arg_vars,
+                 ppr con1 $$ ppr fields1 $$ ppr arg_vars )
+        map lookup_fld rpats
+      | otherwise
+      = arg_vars
+      where
+        fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars
+        lookup_fld (dL->L _ rpat) = lookupNameEnv_NF fld_var_env
+                                            (idName (unLoc (hsRecFieldId rpat)))
+    select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"
+matchOneConLike _ _ [] = panic "matchOneCon []"
+
+-----------------
+compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool
+-- Two constructors have compatible argument patterns if the number
+-- and order of sub-matches is the same in both cases
+compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2
+compatible_pats (RecCon flds1, _) _                 = null (rec_flds flds1)
+compatible_pats _                 (RecCon flds2, _) = null (rec_flds flds2)
+compatible_pats _                 _                 = True -- Prefix or infix con
+
+same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc)
+            -> Bool
+same_fields flds1 flds2
+  = all2 (\(dL->L _ f1) (dL->L _ f2)
+                          -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))
+         (rec_flds flds1) (rec_flds flds2)
+
+
+-----------------
+selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id]
+selectConMatchVars arg_tys (RecCon {})      = newSysLocalsDsNoLP arg_tys
+selectConMatchVars _       (PrefixCon ps)   = selectMatchVars (map unLoc ps)
+selectConMatchVars _       (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2]
+
+conArgPats :: [Type]      -- Instantiated argument types
+                          -- Used only to fill in the types of WildPats, which
+                          -- are probably never looked at anyway
+           -> ConArgPats
+           -> [Pat GhcTc]
+conArgPats _arg_tys (PrefixCon ps)   = map unLoc ps
+conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
+conArgPats  arg_tys (RecCon (HsRecFields { rec_flds = rpats }))
+  | null rpats = map WildPat arg_tys
+        -- Important special case for C {}, which can be used for a
+        -- datacon that isn't declared to have fields at all
+  | otherwise  = map (unLoc . hsRecFieldArg . unLoc) rpats
+
+{-
+Note [Record patterns]
+~~~~~~~~~~~~~~~~~~~~~~
+Consider
+         data T = T { x,y,z :: Bool }
+
+         f (T { y=True, x=False }) = ...
+
+We must match the patterns IN THE ORDER GIVEN, thus for the first
+one we match y=True before x=False.  See Trac #246; or imagine
+matching against (T { y=False, x=undefined }): should fail without
+touching the undefined.
+
+Now consider:
+
+         f (T { y=True, x=False }) = ...
+         f (T { x=True, y= False}) = ...
+
+In the first we must test y first; in the second we must test x
+first.  So we must divide even the equations for a single constructor
+T into sub-goups, based on whether they match the same field in the
+same order.  That's what the (groupBy compatible_pats) grouping.
+
+All non-record patterns are "compatible" in this sense, because the
+positional patterns (T a b) and (a `T` b) all match the arguments
+in order.  Also T {} is special because it's equivalent to (T _ _).
+Hence the (null rpats) checks here and there.
+
+
+Note [Existentials in shift_con_pat]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+        data T = forall a. Ord a => T a (a->Int)
+
+        f (T x f) True  = ...expr1...
+        f (T y g) False = ...expr2..
+
+When we put in the tyvars etc we get
+
+        f (T a (d::Ord a) (x::a) (f::a->Int)) True =  ...expr1...
+        f (T b (e::Ord b) (y::a) (g::a->Int)) True =  ...expr2...
+
+After desugaring etc we'll get a single case:
+
+        f = \t::T b::Bool ->
+            case t of
+               T a (d::Ord a) (x::a) (f::a->Int)) ->
+            case b of
+                True  -> ...expr1...
+                False -> ...expr2...
+
+*** We have to substitute [a/b, d/e] in expr2! **
+Hence
+                False -> ....((/\b\(e:Ord b).expr2) a d)....
+
+Originally I tried to use
+        (\b -> let e = d in expr2) a
+to do this substitution.  While this is "correct" in a way, it fails
+Lint, because e::Ord b but d::Ord a.
+
+-}
diff --git a/compiler/deSugar/MatchLit.hs b/compiler/deSugar/MatchLit.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/MatchLit.hs
@@ -0,0 +1,521 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Pattern-matching literal patterns
+-}
+
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module MatchLit ( dsLit, dsOverLit, hsLitKey
+                , tidyLitPat, tidyNPat
+                , matchLiterals, matchNPlusKPats, matchNPats
+                , warnAboutIdentities
+                , warnAboutOverflowedOverLit, warnAboutOverflowedLit
+                , warnAboutEmptyEnumerations
+                ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} Match  ( match )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr )
+
+import DsMonad
+import DsUtils
+
+import HsSyn
+
+import Id
+import CoreSyn
+import MkCore
+import TyCon
+import DataCon
+import TcHsSyn ( shortCutLit )
+import TcType
+import Name
+import Type
+import PrelNames
+import TysWiredIn
+import TysPrim
+import Literal
+import SrcLoc
+import Data.Ratio
+import Outputable
+import BasicTypes
+import DynFlags
+import Util
+import FastString
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Data.Int
+import Data.Word
+import Data.Proxy
+
+{-
+************************************************************************
+*                                                                      *
+                Desugaring literals
+        [used to be in DsExpr, but DsMeta needs it,
+         and it's nice to avoid a loop]
+*                                                                      *
+************************************************************************
+
+We give int/float literals type @Integer@ and @Rational@, respectively.
+The typechecker will (presumably) have put \tr{from{Integer,Rational}s}
+around them.
+
+ToDo: put in range checks for when converting ``@i@''
+(or should that be in the typechecker?)
+
+For numeric literals, we try to detect there use at a standard type
+(@Int@, @Float@, etc.) are directly put in the right constructor.
+[NB: down with the @App@ conversion.]
+
+See also below where we look for @DictApps@ for \tr{plusInt}, etc.
+-}
+
+dsLit :: HsLit GhcRn -> DsM CoreExpr
+dsLit l = do
+  dflags <- getDynFlags
+  case l of
+    HsStringPrim _ s -> return (Lit (LitString s))
+    HsCharPrim   _ c -> return (Lit (LitChar c))
+    HsIntPrim    _ i -> return (Lit (mkLitIntWrap dflags i))
+    HsWordPrim   _ w -> return (Lit (mkLitWordWrap dflags w))
+    HsInt64Prim  _ i -> return (Lit (mkLitInt64Wrap dflags i))
+    HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap dflags w))
+    HsFloatPrim  _ f -> return (Lit (LitFloat (fl_value f)))
+    HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d)))
+    HsChar _ c       -> return (mkCharExpr c)
+    HsString _ str   -> mkStringExprFS str
+    HsInteger _ i _  -> mkIntegerExpr i
+    HsInt _ i        -> return (mkIntExpr dflags (il_value i))
+    XLit x           -> pprPanic "dsLit" (ppr x)
+    HsRat _ (FL _ _ val) ty -> do
+      num   <- mkIntegerExpr (numerator val)
+      denom <- mkIntegerExpr (denominator val)
+      return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
+      where
+        (ratio_data_con, integer_ty)
+            = case tcSplitTyConApp ty of
+                    (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
+                                       (head (tyConDataCons tycon), i_ty)
+                    x -> pprPanic "dsLit" (ppr x)
+
+dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
+-- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains
+-- (an expression for) the literal value itself.
+dsOverLit (OverLit { ol_val = val, ol_ext = OverLitTc rebindable ty
+                   , ol_witness = witness }) = do
+  dflags <- getDynFlags
+  case shortCutLit dflags val ty of
+    Just expr | not rebindable -> dsExpr expr        -- Note [Literal short cut]
+    _                          -> dsExpr witness
+dsOverLit XOverLit{} = panic "dsOverLit"
+{-
+Note [Literal short cut]
+~~~~~~~~~~~~~~~~~~~~~~~~
+The type checker tries to do this short-cutting as early as possible, but
+because of unification etc, more information is available to the desugarer.
+And where it's possible to generate the correct literal right away, it's
+much better to do so.
+
+
+************************************************************************
+*                                                                      *
+                 Warnings about overflowed literals
+*                                                                      *
+************************************************************************
+
+Warn about functions like toInteger, fromIntegral, that convert
+between one type and another when the to- and from- types are the
+same.  Then it's probably (albeit not definitely) the identity
+-}
+
+warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()
+warnAboutIdentities dflags (Var conv_fn) type_of_conv
+  | wopt Opt_WarnIdentities dflags
+  , idName conv_fn `elem` conversionNames
+  , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv
+  , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
+  = warnDs (Reason Opt_WarnIdentities)
+           (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv
+                 , nest 2 $ text "can probably be omitted"
+           ])
+warnAboutIdentities _ _ _ = return ()
+
+conversionNames :: [Name]
+conversionNames
+  = [ toIntegerName, toRationalName
+    , fromIntegralName, realToFracName ]
+ -- We can't easily add fromIntegerName, fromRationalName,
+ -- because they are generated by literals
+
+
+-- | Emit warnings on overloaded integral literals which overflow the bounds
+-- implied by their type.
+warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()
+warnAboutOverflowedOverLit hsOverLit = do
+  dflags <- getDynFlags
+  warnAboutOverflowedLiterals dflags (getIntegralLit hsOverLit)
+
+-- | Emit warnings on integral literals which overflow the boudns implied by
+-- their type.
+warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()
+warnAboutOverflowedLit hsLit = do
+  dflags <- getDynFlags
+  warnAboutOverflowedLiterals dflags (getSimpleIntegralLit hsLit)
+
+-- | Emit warnings on integral literals which overflow the bounds implied by
+-- their type.
+warnAboutOverflowedLiterals
+  :: DynFlags
+  -> Maybe (Integer, Name)  -- ^ the literal value and name of its tycon
+  -> DsM ()
+warnAboutOverflowedLiterals dflags lit
+ | wopt Opt_WarnOverflowedLiterals dflags
+ , Just (i, tc) <- lit
+ =  if      tc == intTyConName     then check i tc (Proxy :: Proxy Int)
+
+    -- These only show up via the 'HsOverLit' route
+    else if tc == int8TyConName    then check i tc (Proxy :: Proxy Int8)
+    else if tc == int16TyConName   then check i tc (Proxy :: Proxy Int16)
+    else if tc == int32TyConName   then check i tc (Proxy :: Proxy Int32)
+    else if tc == int64TyConName   then check i tc (Proxy :: Proxy Int64)
+    else if tc == wordTyConName    then check i tc (Proxy :: Proxy Word)
+    else if tc == word8TyConName   then check i tc (Proxy :: Proxy Word8)
+    else if tc == word16TyConName  then check i tc (Proxy :: Proxy Word16)
+    else if tc == word32TyConName  then check i tc (Proxy :: Proxy Word32)
+    else if tc == word64TyConName  then check i tc (Proxy :: Proxy Word64)
+    else if tc == naturalTyConName then checkPositive i tc
+
+    -- These only show up via the 'HsLit' route
+    else if tc == intPrimTyConName    then check i tc (Proxy :: Proxy Int)
+    else if tc == int8PrimTyConName   then check i tc (Proxy :: Proxy Int8)
+    else if tc == int32PrimTyConName  then check i tc (Proxy :: Proxy Int32)
+    else if tc == int64PrimTyConName  then check i tc (Proxy :: Proxy Int64)
+    else if tc == wordPrimTyConName   then check i tc (Proxy :: Proxy Word)
+    else if tc == word8PrimTyConName  then check i tc (Proxy :: Proxy Word8)
+    else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32)
+    else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64)
+
+    else return ()
+
+  | otherwise = return ()
+  where
+
+    checkPositive :: Integer -> Name -> DsM ()
+    checkPositive i tc
+      = when (i < 0) $ do
+        warnDs (Reason Opt_WarnOverflowedLiterals)
+               (vcat [ text "Literal" <+> integer i
+                       <+> text "is negative but" <+> ppr tc
+                       <+> ptext (sLit "only supports positive numbers")
+                     ])
+
+    check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM ()
+    check i tc _proxy
+      = when (i < minB || i > maxB) $ do
+        warnDs (Reason Opt_WarnOverflowedLiterals)
+               (vcat [ text "Literal" <+> integer i
+                       <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")
+                       <+> integer minB <> text ".." <> integer maxB
+                     , sug ])
+      where
+        minB = toInteger (minBound :: a)
+        maxB = toInteger (maxBound :: a)
+        sug | minB == -i   -- Note [Suggest NegativeLiterals]
+            , i > 0
+            , not (xopt LangExt.NegativeLiterals dflags)
+            = text "If you are trying to write a large negative literal, use NegativeLiterals"
+            | otherwise = Outputable.empty
+
+{-
+Note [Suggest NegativeLiterals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If you write
+  x :: Int8
+  x = -128
+it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.
+We get an erroneous suggestion for
+  x = 128
+but perhaps that does not matter too much.
+-}
+
+warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)
+                           -> LHsExpr GhcTc -> DsM ()
+-- ^ Warns about @[2,3 .. 1]@ which returns the empty list.
+-- Only works for integral types, not floating point.
+warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
+  | wopt Opt_WarnEmptyEnumerations dflags
+  , Just (from,tc) <- getLHsIntegralLit fromExpr
+  , Just mThn      <- traverse getLHsIntegralLit mThnExpr
+  , Just (to,_)    <- getLHsIntegralLit toExpr
+  , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM ()
+        check _proxy
+          = when (null enumeration) $
+            warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")
+          where
+            enumeration :: [a]
+            enumeration = case mThn of
+                            Nothing      -> [fromInteger from                    .. fromInteger to]
+                            Just (thn,_) -> [fromInteger from, fromInteger thn   .. fromInteger to]
+
+  = if      tc == intTyConName    then check (Proxy :: Proxy Int)
+    else if tc == int8TyConName   then check (Proxy :: Proxy Int8)
+    else if tc == int16TyConName  then check (Proxy :: Proxy Int16)
+    else if tc == int32TyConName  then check (Proxy :: Proxy Int32)
+    else if tc == int64TyConName  then check (Proxy :: Proxy Int64)
+    else if tc == wordTyConName   then check (Proxy :: Proxy Word)
+    else if tc == word8TyConName  then check (Proxy :: Proxy Word8)
+    else if tc == word16TyConName then check (Proxy :: Proxy Word16)
+    else if tc == word32TyConName then check (Proxy :: Proxy Word32)
+    else if tc == word64TyConName then check (Proxy :: Proxy Word64)
+    else if tc == integerTyConName then check (Proxy :: Proxy Integer)
+    else if tc == naturalTyConName then check (Proxy :: Proxy Integer)
+      -- We use 'Integer' because otherwise a negative 'Natural' literal
+      -- could cause a compile time crash (instead of a runtime one).
+      -- See the T10930b test case for an example of where this matters.
+    else return ()
+
+  | otherwise = return ()
+
+getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
+-- ^ See if the expression is an 'Integral' literal.
+-- Remember to look through automatically-added tick-boxes! (Trac #8384)
+getLHsIntegralLit (dL->L _ (HsPar _ e))            = getLHsIntegralLit e
+getLHsIntegralLit (dL->L _ (HsTick _ _ e))         = getLHsIntegralLit e
+getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e))    = getLHsIntegralLit e
+getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
+getLHsIntegralLit (dL->L _ (HsLit _ lit))          = getSimpleIntegralLit lit
+getLHsIntegralLit _ = Nothing
+
+-- | If 'Integral', extract the value and type name of the overloaded literal.
+getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
+getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })
+  | Just tc <- tyConAppTyCon_maybe ty
+  = Just (il_value i, tyConName tc)
+getIntegralLit _ = Nothing
+
+-- | If 'Integral', extract the value and type name of the non-overloaded
+-- literal.
+getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name)
+getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTyConName)
+getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTyConName)
+getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTyConName)
+getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTyConName)
+getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTyConName)
+getSimpleIntegralLit (HsInteger _ i ty)
+  | Just tc <- tyConAppTyCon_maybe ty
+  = Just (i, tyConName tc)
+getSimpleIntegralLit _ = Nothing
+
+{-
+************************************************************************
+*                                                                      *
+        Tidying lit pats
+*                                                                      *
+************************************************************************
+-}
+
+tidyLitPat :: HsLit GhcTc -> Pat GhcTc
+-- Result has only the following HsLits:
+--      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim
+--      HsDoublePrim, HsStringPrim, HsString
+--  * HsInteger, HsRat, HsInt can't show up in LitPats
+--  * We get rid of HsChar right here
+tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)
+tidyLitPat (HsString src s)
+  | lengthFS s <= 1     -- Short string literals only
+  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon
+                                             [mkCharLitPat src c, pat] [charTy])
+                  (mkNilPat charTy) (unpackFS s)
+        -- The stringTy is the type of the whole pattern, not
+        -- the type to instantiate (:) or [] with!
+tidyLitPat lit = LitPat noExt lit
+
+----------------
+tidyNPat :: HsOverLit GhcTc -> Maybe (SyntaxExpr GhcTc) -> SyntaxExpr GhcTc
+         -> Type
+         -> Pat GhcTc
+tidyNPat (OverLit (OverLitTc False ty) val _) mb_neg _eq outer_ty
+        -- False: Take short cuts only if the literal is not using rebindable syntax
+        --
+        -- Once that is settled, look for cases where the type of the
+        -- entire overloaded literal matches the type of the underlying literal,
+        -- and in that case take the short cut
+        -- NB: Watch out for weird cases like Trac #3382
+        --        f :: Int -> Int
+        --        f "blah" = 4
+        --     which might be ok if we have 'instance IsString Int'
+        --
+  | not type_change, isIntTy ty,    Just int_lit <- mb_int_lit
+                 = mk_con_pat intDataCon    (HsIntPrim    NoSourceText int_lit)
+  | not type_change, isWordTy ty,   Just int_lit <- mb_int_lit
+                 = mk_con_pat wordDataCon   (HsWordPrim   NoSourceText int_lit)
+  | not type_change, isStringTy ty, Just str_lit <- mb_str_lit
+                 = tidyLitPat (HsString NoSourceText str_lit)
+     -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
+     -- If we do convert to the constructor form, we'll generate a case
+     -- expression on a Float# or Double# and that's not allowed in Core; see
+     -- Trac #9238 and Note [Rules for floating-point comparisons] in PrelRules
+  where
+    -- Sometimes (like in test case
+    -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include
+    -- type-changing wrappers (for example, from Id Int to Int, for the identity
+    -- type family Id). In these cases, we can't do the short-cut.
+    type_change = not (outer_ty `eqType` ty)
+
+    mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc
+    mk_con_pat con lit
+      = unLoc (mkPrefixConPat con [noLoc $ LitPat noExt lit] [])
+
+    mb_int_lit :: Maybe Integer
+    mb_int_lit = case (mb_neg, val) of
+                   (Nothing, HsIntegral i) -> Just (il_value i)
+                   (Just _,  HsIntegral i) -> Just (-(il_value i))
+                   _ -> Nothing
+
+    mb_str_lit :: Maybe FastString
+    mb_str_lit = case (mb_neg, val) of
+                   (Nothing, HsIsString _ s) -> Just s
+                   _ -> Nothing
+
+tidyNPat over_lit mb_neg eq outer_ty
+  = NPat outer_ty (noLoc over_lit) mb_neg eq
+
+{-
+************************************************************************
+*                                                                      *
+                Pattern matching on LitPat
+*                                                                      *
+************************************************************************
+-}
+
+matchLiterals :: [Id]
+              -> Type                   -- Type of the whole case expression
+              -> [[EquationInfo]]       -- All PgLits
+              -> DsM MatchResult
+
+matchLiterals (var:vars) ty sub_groups
+  = ASSERT( notNull sub_groups && all notNull sub_groups )
+    do  {       -- Deal with each group
+        ; alts <- mapM match_group sub_groups
+
+                -- Combine results.  For everything except String
+                -- we can use a case expression; for String we need
+                -- a chain of if-then-else
+        ; if isStringTy (idType var) then
+            do  { eq_str <- dsLookupGlobalId eqStringName
+                ; mrs <- mapM (wrap_str_guard eq_str) alts
+                ; return (foldr1 combineMatchResults mrs) }
+          else
+            return (mkCoPrimCaseMatchResult var ty alts)
+        }
+  where
+    match_group :: [EquationInfo] -> DsM (Literal, MatchResult)
+    match_group eqns
+        = do { dflags <- getDynFlags
+             ; let LitPat _ hs_lit = firstPat (head eqns)
+             ; match_result <- match vars ty (shiftEqns eqns)
+             ; return (hsLitKey dflags hs_lit, match_result) }
+
+    wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult
+        -- Equality check for string literals
+    wrap_str_guard eq_str (LitString s, mr)
+        = do { -- We now have to convert back to FastString. Perhaps there
+               -- should be separate LitBytes and LitString constructors?
+               let s'  = mkFastStringByteString s
+             ; lit    <- mkStringExprFS s'
+             ; let pred = mkApps (Var eq_str) [Var var, lit]
+             ; return (mkGuardedMatchResult pred mr) }
+    wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)
+
+matchLiterals [] _ _ = panic "matchLiterals []"
+
+---------------------------
+hsLitKey :: DynFlags -> HsLit GhcTc -> Literal
+-- Get the Core literal corresponding to a HsLit.
+-- It only works for primitive types and strings;
+-- others have been removed by tidy
+-- For HsString, it produces a LitString, which really represents an _unboxed_
+-- string literal; and we deal with it in matchLiterals above. Otherwise, it
+-- produces a primitive Literal of type matching the original HsLit.
+-- In the case of the fixed-width numeric types, we need to wrap here
+-- because Literal has an invariant that the literal is in range, while
+-- HsLit does not.
+hsLitKey dflags (HsIntPrim    _ i) = mkLitIntWrap  dflags i
+hsLitKey dflags (HsWordPrim   _ w) = mkLitWordWrap dflags w
+hsLitKey dflags (HsInt64Prim  _ i) = mkLitInt64Wrap  dflags i
+hsLitKey dflags (HsWord64Prim _ w) = mkLitWord64Wrap dflags w
+hsLitKey _      (HsCharPrim   _ c) = mkLitChar            c
+hsLitKey _      (HsFloatPrim  _ f) = mkLitFloat           (fl_value f)
+hsLitKey _      (HsDoublePrim _ d) = mkLitDouble          (fl_value d)
+hsLitKey _      (HsString _ s)     = LitString (fastStringToByteString s)
+hsLitKey _      l                  = pprPanic "hsLitKey" (ppr l)
+
+{-
+************************************************************************
+*                                                                      *
+                Pattern matching on NPat
+*                                                                      *
+************************************************************************
+-}
+
+matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal
+  = do  { let NPat _ (dL->L _ lit) mb_neg eq_chk = firstPat eqn1
+        ; lit_expr <- dsOverLit lit
+        ; neg_lit <- case mb_neg of
+                            Nothing  -> return lit_expr
+                            Just neg -> dsSyntaxExpr neg [lit_expr]
+        ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]
+        ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
+        ; return (mkGuardedMatchResult pred_expr match_result) }
+matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
+
+{-
+************************************************************************
+*                                                                      *
+                Pattern matching on n+k patterns
+*                                                                      *
+************************************************************************
+
+For an n+k pattern, we use the various magic expressions we've been given.
+We generate:
+\begin{verbatim}
+    if ge var lit then
+        let n = sub var lit
+        in  <expr-for-a-successful-match>
+    else
+        <try-next-pattern-or-whatever>
+\end{verbatim}
+-}
+
+matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
+-- All NPlusKPats, for the *same* literal k
+matchNPlusKPats (var:vars) ty (eqn1:eqns)
+  = do  { let NPlusKPat _ (dL->L _ n1) (dL->L _ lit1) lit2 ge minus
+                = firstPat eqn1
+        ; lit1_expr   <- dsOverLit lit1
+        ; lit2_expr   <- dsOverLit lit2
+        ; pred_expr   <- dsSyntaxExpr ge    [Var var, lit1_expr]
+        ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]
+        ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
+        ; match_result <- match vars ty eqns'
+        ; return  (mkGuardedMatchResult pred_expr               $
+                   mkCoLetMatchResult (NonRec n1 minusk_expr)   $
+                   adjustMatchResult (foldr1 (.) wraps)         $
+                   match_result) }
+  where
+    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (dL->L _ n) _ _ _ _ : pats })
+        = (wrapBind n n1, eqn { eqn_pats = pats })
+        -- The wrapBind is a no-op for the first equation
+    shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
+
+matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
diff --git a/compiler/deSugar/TmOracle.hs b/compiler/deSugar/TmOracle.hs
new file mode 100644
--- /dev/null
+++ b/compiler/deSugar/TmOracle.hs
@@ -0,0 +1,263 @@
+{-
+Author: George Karachalias <george.karachalias@cs.kuleuven.be>
+
+The term equality oracle. The main export of the module is function `tmOracle'.
+-}
+
+{-# LANGUAGE CPP, MultiWayIf #-}
+
+module TmOracle (
+
+        -- re-exported from PmExpr
+        PmExpr(..), PmLit(..), SimpleEq, ComplexEq, PmVarEnv, falsePmExpr,
+        eqPmLit, filterComplex, isNotPmExprOther, runPmPprM, lhsExprToPmExpr,
+        hsExprToPmExpr, pprPmExprWithParens,
+
+        -- the term oracle
+        tmOracle, TmState, initialTmState, solveOneEq, extendSubst, canDiverge,
+
+        -- misc.
+        toComplex, exprDeepLookup, pmLitType, flattenPmVarEnv
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import PmExpr
+
+import Id
+import Name
+import Type
+import HsLit
+import TcHsSyn
+import MonadUtils
+import Util
+
+import NameEnv
+
+{-
+%************************************************************************
+%*                                                                      *
+                      The term equality oracle
+%*                                                                      *
+%************************************************************************
+-}
+
+-- | The type of substitutions.
+type PmVarEnv = NameEnv PmExpr
+
+-- | The environment of the oracle contains
+--     1. A Bool (are there any constraints we cannot handle? (PmExprOther)).
+--     2. A substitution we extend with every step and return as a result.
+type TmOracleEnv = (Bool, PmVarEnv)
+
+-- | Check whether a constraint (x ~ BOT) can succeed,
+-- given the resulting state of the term oracle.
+canDiverge :: Name -> TmState -> Bool
+canDiverge x (standby, (_unhandled, env))
+  -- If the variable seems not evaluated, there is a possibility for
+  -- constraint x ~ BOT to be satisfiable.
+  | PmExprVar y <- varDeepLookup env x -- seems not forced
+  -- If it is involved (directly or indirectly) in any equality in the
+  -- worklist, we can assume that it is already indirectly evaluated,
+  -- as a side-effect of equality checking. If not, then we can assume
+  -- that the constraint is satisfiable.
+  = not $ any (isForcedByEq x) standby || any (isForcedByEq y) standby
+  -- Variable x is already in WHNF so the constraint is non-satisfiable
+  | otherwise = False
+
+  where
+    isForcedByEq :: Name -> ComplexEq -> Bool
+    isForcedByEq y (e1, e2) = varIn y e1 || varIn y e2
+
+-- | Check whether a variable is in the free variables of an expression
+varIn :: Name -> PmExpr -> Bool
+varIn x e = case e of
+  PmExprVar y    -> x == y
+  PmExprCon _ es -> any (x `varIn`) es
+  PmExprLit _    -> False
+  PmExprEq e1 e2 -> (x `varIn` e1) || (x `varIn` e2)
+  PmExprOther _  -> False
+
+-- | Flatten the DAG (Could be improved in terms of performance.).
+flattenPmVarEnv :: PmVarEnv -> PmVarEnv
+flattenPmVarEnv env = mapNameEnv (exprDeepLookup env) env
+
+-- | The state of the term oracle (includes complex constraints that cannot
+-- progress unless we get more information).
+type TmState = ([ComplexEq], TmOracleEnv)
+
+-- | Initial state of the oracle.
+initialTmState :: TmState
+initialTmState = ([], (False, emptyNameEnv))
+
+-- | Solve a complex equality (top-level).
+solveOneEq :: TmState -> ComplexEq -> Maybe TmState
+solveOneEq solver_env@(_,(_,env)) complex
+  = solveComplexEq solver_env -- do the actual *merging* with existing state
+  $ simplifyComplexEq               -- simplify as much as you can
+  $ applySubstComplexEq env complex -- replace everything we already know
+
+-- | Solve a complex equality.
+-- Nothing => definitely unsatisfiable
+-- Just tms => I have added the complex equality and added
+--             it to the tmstate; the result may or may not be
+--             satisfiable
+solveComplexEq :: TmState -> ComplexEq -> Maybe TmState
+solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of
+  -- We cannot do a thing about these cases
+  (PmExprOther _,_)            -> Just (standby, (True, env))
+  (_,PmExprOther _)            -> Just (standby, (True, env))
+
+  (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of
+    -- See Note [Undecidable Equality for Overloaded Literals]
+    True  -> Just solver_state
+    False -> Nothing
+
+  (PmExprCon c1 ts1, PmExprCon c2 ts2)
+    | c1 == c2  -> foldlM solveComplexEq solver_state (zip ts1 ts2)
+    | otherwise -> Nothing
+  (PmExprCon _ [], PmExprEq t1 t2)
+    | isTruePmExpr e1  -> solveComplexEq solver_state (t1, t2)
+    | isFalsePmExpr e1 -> Just (eq:standby, (unhandled, env))
+  (PmExprEq t1 t2, PmExprCon _ [])
+    | isTruePmExpr e2   -> solveComplexEq solver_state (t1, t2)
+    | isFalsePmExpr e2  -> Just (eq:standby, (unhandled, env))
+
+  (PmExprVar x, PmExprVar y)
+    | x == y    -> Just solver_state
+    | otherwise -> extendSubstAndSolve x e2 solver_state
+
+  (PmExprVar x, _) -> extendSubstAndSolve x e2 solver_state
+  (_, PmExprVar x) -> extendSubstAndSolve x e1 solver_state
+
+  (PmExprEq _ _, PmExprEq _ _) -> Just (eq:standby, (unhandled, env))
+
+  _ -> Just (standby, (True, env)) -- I HATE CATCH-ALLS
+
+-- | Extend the substitution and solve the (possibly updated) constraints.
+extendSubstAndSolve :: Name -> PmExpr -> TmState -> Maybe TmState
+extendSubstAndSolve x e (standby, (unhandled, env))
+  = foldlM solveComplexEq new_incr_state (map simplifyComplexEq changed)
+  where
+    -- Apply the substitution to the worklist and partition them to the ones
+    -- that had some progress and the rest. Then, recurse over the ones that
+    -- had some progress. Careful about performance:
+    -- See Note [Representation of Term Equalities] in deSugar/Check.hs
+    (changed, unchanged) = partitionWith (substComplexEq x e) standby
+    new_incr_state       = (unchanged, (unhandled, extendNameEnv env x e))
+
+-- | When we know that a variable is fresh, we do not actually have to
+-- check whether anything changes, we know that nothing does. Hence,
+-- `extendSubst` simply extends the substitution, unlike what
+-- `extendSubstAndSolve` does.
+extendSubst :: Id -> PmExpr -> TmState -> TmState
+extendSubst y e (standby, (unhandled, env))
+  | isNotPmExprOther simpl_e
+  = (standby, (unhandled, extendNameEnv env x simpl_e))
+  | otherwise = (standby, (True, env))
+  where
+    x = idName y
+    simpl_e = fst $ simplifyPmExpr $ exprDeepLookup env e
+
+-- | Simplify a complex equality.
+simplifyComplexEq :: ComplexEq -> ComplexEq
+simplifyComplexEq (e1, e2) = (fst $ simplifyPmExpr e1, fst $ simplifyPmExpr e2)
+
+-- | Simplify an expression. The boolean indicates if there has been any
+-- simplification or if the operation was a no-op.
+simplifyPmExpr :: PmExpr -> (PmExpr, Bool)
+-- See Note [Deep equalities]
+simplifyPmExpr e = case e of
+  PmExprCon c ts -> case mapAndUnzip simplifyPmExpr ts of
+                      (ts', bs) -> (PmExprCon c ts', or bs)
+  PmExprEq t1 t2 -> simplifyEqExpr t1 t2
+  _other_expr    -> (e, False) -- the others are terminals
+
+-- | Simplify an equality expression. The equality is given in parts.
+simplifyEqExpr :: PmExpr -> PmExpr -> (PmExpr, Bool)
+-- See Note [Deep equalities]
+simplifyEqExpr e1 e2 = case (e1, e2) of
+  -- Varables
+  (PmExprVar x, PmExprVar y)
+    | x == y -> (truePmExpr, True)
+
+  -- Literals
+  (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of
+    -- See Note [Undecidable Equality for Overloaded Literals]
+    True  -> (truePmExpr,  True)
+    False -> (falsePmExpr, True)
+
+  -- Can potentially be simplified
+  (PmExprEq {}, _) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of
+    ((e1', True ), (e2', _    )) -> simplifyEqExpr e1' e2'
+    ((e1', _    ), (e2', True )) -> simplifyEqExpr e1' e2'
+    ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress
+  (_, PmExprEq {}) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of
+    ((e1', True ), (e2', _    )) -> simplifyEqExpr e1' e2'
+    ((e1', _    ), (e2', True )) -> simplifyEqExpr e1' e2'
+    ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress
+
+  -- Constructors
+  (PmExprCon c1 ts1, PmExprCon c2 ts2)
+    | c1 == c2 ->
+        let (ts1', bs1) = mapAndUnzip simplifyPmExpr ts1
+            (ts2', bs2) = mapAndUnzip simplifyPmExpr ts2
+            (tss, _bss) = zipWithAndUnzip simplifyEqExpr ts1' ts2'
+            worst_case  = PmExprEq (PmExprCon c1 ts1') (PmExprCon c2 ts2')
+        in  if | not (or bs1 || or bs2) -> (worst_case, False) -- no progress
+               | all isTruePmExpr  tss  -> (truePmExpr, True)
+               | any isFalsePmExpr tss  -> (falsePmExpr, True)
+               | otherwise              -> (worst_case, False)
+    | otherwise -> (falsePmExpr, True)
+
+  -- We cannot do anything about the rest..
+  _other_equality -> (original, False)
+
+  where
+    original = PmExprEq e1 e2 -- reconstruct equality
+
+-- | Apply an (un-flattened) substitution to a simple equality.
+applySubstComplexEq :: PmVarEnv -> ComplexEq -> ComplexEq
+applySubstComplexEq env (e1,e2) = (exprDeepLookup env e1, exprDeepLookup env e2)
+
+-- | Apply an (un-flattened) substitution to a variable.
+varDeepLookup :: PmVarEnv -> Name -> PmExpr
+varDeepLookup env x
+  | Just e <- lookupNameEnv env x = exprDeepLookup env e -- go deeper
+  | otherwise                  = PmExprVar x          -- terminal
+{-# INLINE varDeepLookup #-}
+
+-- | Apply an (un-flattened) substitution to an expression.
+exprDeepLookup :: PmVarEnv -> PmExpr -> PmExpr
+exprDeepLookup env (PmExprVar x)    = varDeepLookup env x
+exprDeepLookup env (PmExprCon c es) = PmExprCon c (map (exprDeepLookup env) es)
+exprDeepLookup env (PmExprEq e1 e2) = PmExprEq (exprDeepLookup env e1)
+                                               (exprDeepLookup env e2)
+exprDeepLookup _   other_expr       = other_expr -- PmExprLit, PmExprOther
+
+-- | External interface to the term oracle.
+tmOracle :: TmState -> [ComplexEq] -> Maybe TmState
+tmOracle tm_state eqs = foldlM solveOneEq tm_state eqs
+
+-- | Type of a PmLit
+pmLitType :: PmLit -> Type -- should be in PmExpr but gives cyclic imports :(
+pmLitType (PmSLit   lit) = hsLitType   lit
+pmLitType (PmOLit _ lit) = overLitType lit
+
+{- Note [Deep equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Solving nested equalities is the most difficult part. The general strategy
+is the following:
+
+  * Equalities of the form (True ~ (e1 ~ e2)) are transformed to just
+    (e1 ~ e2) and then treated recursively.
+
+  * Equalities of the form (False ~ (e1 ~ e2)) cannot be analyzed unless
+    we know more about the inner equality (e1 ~ e2). That's exactly what
+    `simplifyEqExpr' tries to do: It takes e1 and e2 and either returns
+    truePmExpr, falsePmExpr or (e1' ~ e2') in case it is uncertain. Note
+    that it is not e but rather e', since it may perform some
+    simplifications deeper.
+-}
diff --git a/compiler/ghc-llvm-version.h b/compiler/ghc-llvm-version.h
deleted file mode 100644
--- a/compiler/ghc-llvm-version.h
+++ /dev/null
@@ -1,11 +0,0 @@
-/* compiler/ghc-llvm-version.h.  Generated from ghc-llvm-version.h.in by configure.  */
-#if !defined(__GHC_LLVM_VERSION_H__)
-#define __GHC_LLVM_VERSION_H__
-
-/* The maximum supported LLVM version number */
-#define sUPPORTED_LLVM_VERSION_MAX (15)
-
-/* The minimum supported LLVM version number */
-#define sUPPORTED_LLVM_VERSION_MIN (10)
-
-#endif /* __GHC_LLVM_VERSION_H__ */
diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/ByteCodeAsm.hs
@@ -0,0 +1,564 @@
+{-# LANGUAGE BangPatterns, CPP, MagicHash, RecordWildCards #-}
+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
+--
+--  (c) The University of Glasgow 2002-2006
+--
+
+-- | ByteCodeLink: Bytecode assembler and linker
+module ByteCodeAsm (
+        assembleBCOs, assembleOneBCO,
+
+        bcoFreeNames,
+        SizedSeq, sizeSS, ssElts,
+        iNTERP_STACK_CHECK_THRESH
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import ByteCodeInstr
+import ByteCodeItbls
+import ByteCodeTypes
+import GHCi.RemoteTypes
+import GHCi
+
+import HscTypes
+import Name
+import NameSet
+import Literal
+import TyCon
+import FastString
+import StgCmmLayout     ( ArgRep(..) )
+import SMRep
+import DynFlags
+import Outputable
+import Platform
+import Util
+import Unique
+import UniqDSet
+
+-- From iserv
+import SizedSeq
+
+import Control.Monad
+import Control.Monad.ST ( runST )
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.State.Strict
+
+import Data.Array.MArray
+
+import qualified Data.Array.Unboxed as Array
+import Data.Array.Base  ( UArray(..) )
+
+import Data.Array.Unsafe( castSTUArray )
+
+import Foreign
+import Data.Char        ( ord )
+import Data.List
+import Data.Map (Map)
+import Data.Maybe (fromMaybe)
+import qualified Data.Map as Map
+
+-- -----------------------------------------------------------------------------
+-- Unlinked BCOs
+
+-- CompiledByteCode represents the result of byte-code
+-- compiling a bunch of functions and data types
+
+-- | Finds external references.  Remember to remove the names
+-- defined by this group of BCOs themselves
+bcoFreeNames :: UnlinkedBCO -> UniqDSet Name
+bcoFreeNames bco
+  = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco]
+  where
+    bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs)
+        = unionManyUniqDSets (
+             mkUniqDSet [ n | BCOPtrName n <- ssElts ptrs ] :
+             mkUniqDSet [ n | BCONPtrItbl n <- ssElts nonptrs ] :
+             map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
+          )
+
+-- -----------------------------------------------------------------------------
+-- The bytecode assembler
+
+-- The object format for bytecodes is: 16 bits for the opcode, and 16
+-- for each field -- so the code can be considered a sequence of
+-- 16-bit ints.  Each field denotes either a stack offset or number of
+-- items on the stack (eg SLIDE), and index into the pointer table (eg
+-- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a
+-- bytecode address in this BCO.
+
+-- Top level assembler fn.
+assembleBCOs
+  :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()]
+  -> Maybe ModBreaks
+  -> IO CompiledByteCode
+assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do
+  itblenv <- mkITbls hsc_env tycons
+  bcos    <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos
+  (bcos',ptrs) <- mallocStrings hsc_env bcos
+  return CompiledByteCode
+    { bc_bcos = bcos'
+    , bc_itbls =  itblenv
+    , bc_ffis = concat (map protoBCOFFIs proto_bcos)
+    , bc_strs = top_strs ++ ptrs
+    , bc_breaks = modbreaks
+    }
+
+-- Find all the literal strings and malloc them together.  We want to
+-- do this because:
+--
+--  a) It should be done when we compile the module, not each time we relink it
+--  b) For -fexternal-interpreter It's more efficient to malloc the strings
+--     as a single batch message, especially when compiling in parallel.
+--
+mallocStrings :: HscEnv -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])
+mallocStrings hsc_env ulbcos = do
+  let bytestrings = reverse (execState (mapM_ collect ulbcos) [])
+  ptrs <- iservCmd hsc_env (MallocStrings bytestrings)
+  return (evalState (mapM splice ulbcos) ptrs, ptrs)
+ where
+  splice bco@UnlinkedBCO{..} = do
+    lits <- mapM spliceLit unlinkedBCOLits
+    ptrs <- mapM splicePtr unlinkedBCOPtrs
+    return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs }
+
+  spliceLit (BCONPtrStr _) = do
+    rptrs <- get
+    case rptrs of
+      (RemotePtr p : rest) -> do
+        put rest
+        return (BCONPtrWord (fromIntegral p))
+      _ -> panic "mallocStrings:spliceLit"
+  spliceLit other = return other
+
+  splicePtr (BCOPtrBCO bco) = BCOPtrBCO <$> splice bco
+  splicePtr other = return other
+
+  collect UnlinkedBCO{..} = do
+    mapM_ collectLit unlinkedBCOLits
+    mapM_ collectPtr unlinkedBCOPtrs
+
+  collectLit (BCONPtrStr bs) = do
+    strs <- get
+    put (bs:strs)
+  collectLit _ = return ()
+
+  collectPtr (BCOPtrBCO bco) = collect bco
+  collectPtr _ = return ()
+
+
+assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO
+assembleOneBCO hsc_env pbco = do
+  ubco <- assembleBCO (hsc_dflags hsc_env) pbco
+  ([ubco'], _ptrs) <- mallocStrings hsc_env [ubco]
+  return ubco'
+
+assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
+assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do
+  -- pass 1: collect up the offsets of the local labels.
+  let asm = mapM_ (assembleI dflags) instrs
+
+      initial_offset = 0
+
+      -- Jump instructions are variable-sized, there are long and short variants
+      -- depending on the magnitude of the offset.  However, we can't tell what
+      -- size instructions we will need until we have calculated the offsets of
+      -- the labels, which depends on the size of the instructions...  So we
+      -- first create the label environment assuming that all jumps are short,
+      -- and if the final size is indeed small enough for short jumps, we are
+      -- done.  Otherwise, we repeat the calculation, and we force all jumps in
+      -- this BCO to be long.
+      (n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm
+      ((n_insns, lbl_map), long_jumps)
+        | isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True)
+        | otherwise = ((n_insns0, lbl_map0), False)
+
+      env :: Word16 -> Word
+      env lbl = fromMaybe
+        (pprPanic "assembleBCO.findLabel" (ppr lbl))
+        (Map.lookup lbl lbl_map)
+
+  -- pass 2: run assembler and generate instructions, literals and pointers
+  let initial_state = (emptySS, emptySS, emptySS)
+  (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm dflags long_jumps env asm
+
+  -- precomputed size should be equal to final size
+  ASSERT(n_insns == sizeSS final_insns) return ()
+
+  let asm_insns = ssElts final_insns
+      insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns
+      bitmap_arr = mkBitmapArray bsize bitmap
+      ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs
+
+  -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
+  -- objects, since they might get run too early.  Disable this until
+  -- we figure out what to do.
+  -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
+
+  return ul_bco
+
+mkBitmapArray :: Word16 -> [StgWord] -> UArray Int Word64
+-- Here the return type must be an array of Words, not StgWords,
+-- because the underlying ByteArray# will end up as a component
+-- of a BCO object.
+mkBitmapArray bsize bitmap
+  = Array.listArray (0, length bitmap) $
+      fromIntegral bsize : map (fromInteger . fromStgWord) bitmap
+
+-- instrs nonptrs ptrs
+type AsmState = (SizedSeq Word16,
+                 SizedSeq BCONPtr,
+                 SizedSeq BCOPtr)
+
+data Operand
+  = Op Word
+  | SmallOp Word16
+  | LabelOp Word16
+-- (unused)  | LargeOp Word
+
+data Assembler a
+  = AllocPtr (IO BCOPtr) (Word -> Assembler a)
+  | AllocLit [BCONPtr] (Word -> Assembler a)
+  | AllocLabel Word16 (Assembler a)
+  | Emit Word16 [Operand] (Assembler a)
+  | NullAsm a
+
+instance Functor Assembler where
+    fmap = liftM
+
+instance Applicative Assembler where
+    pure = NullAsm
+    (<*>) = ap
+
+instance Monad Assembler where
+  NullAsm x >>= f = f x
+  AllocPtr p k >>= f = AllocPtr p (k >=> f)
+  AllocLit l k >>= f = AllocLit l (k >=> f)
+  AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f)
+  Emit w ops k >>= f = Emit w ops (k >>= f)
+
+ioptr :: IO BCOPtr -> Assembler Word
+ioptr p = AllocPtr p return
+
+ptr :: BCOPtr -> Assembler Word
+ptr = ioptr . return
+
+lit :: [BCONPtr] -> Assembler Word
+lit l = AllocLit l return
+
+label :: Word16 -> Assembler ()
+label w = AllocLabel w (return ())
+
+emit :: Word16 -> [Operand] -> Assembler ()
+emit w ops = Emit w ops (return ())
+
+type LabelEnv = Word16 -> Word
+
+largeOp :: Bool -> Operand -> Bool
+largeOp long_jumps op = case op of
+   SmallOp _ -> False
+   Op w      -> isLarge w
+   LabelOp _ -> long_jumps
+-- LargeOp _ -> True
+
+runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
+runAsm dflags long_jumps e = go
+  where
+    go (NullAsm x) = return x
+    go (AllocPtr p_io k) = do
+      p <- lift p_io
+      w <- state $ \(st_i0,st_l0,st_p0) ->
+        let st_p1 = addToSS st_p0 p
+        in (sizeSS st_p0, (st_i0,st_l0,st_p1))
+      go $ k w
+    go (AllocLit lits k) = do
+      w <- state $ \(st_i0,st_l0,st_p0) ->
+        let st_l1 = addListToSS st_l0 lits
+        in (sizeSS st_l0, (st_i0,st_l1,st_p0))
+      go $ k w
+    go (AllocLabel _ k) = go k
+    go (Emit w ops k) = do
+      let largeOps = any (largeOp long_jumps) ops
+          opcode
+            | largeOps = largeArgInstr w
+            | otherwise = w
+          words = concatMap expand ops
+          expand (SmallOp w) = [w]
+          expand (LabelOp w) = expand (Op (e w))
+          expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w]
+--        expand (LargeOp w) = largeArg dflags w
+      state $ \(st_i0,st_l0,st_p0) ->
+        let st_i1 = addListToSS st_i0 (opcode : words)
+        in ((), (st_i1,st_l0,st_p0))
+      go k
+
+type LabelEnvMap = Map Word16 Word
+
+data InspectState = InspectState
+  { instrCount :: !Word
+  , ptrCount :: !Word
+  , litCount :: !Word
+  , lblEnv :: LabelEnvMap
+  }
+
+inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
+inspectAsm dflags long_jumps initial_offset
+  = go (InspectState initial_offset 0 0 Map.empty)
+  where
+    go s (NullAsm _) = (instrCount s, lblEnv s)
+    go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n)
+      where n = ptrCount s
+    go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n)
+      where n = litCount s
+    go s (AllocLabel lbl k) = go s' k
+      where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) }
+    go s (Emit _ ops k) = go s' k
+      where
+        s' = s { instrCount = instrCount s + size }
+        size = sum (map count ops) + 1
+        largeOps = any (largeOp long_jumps) ops
+        count (SmallOp _) = 1
+        count (LabelOp _) = count (Op 0)
+        count (Op _) = if largeOps then largeArg16s dflags else 1
+--      count (LargeOp _) = largeArg16s dflags
+
+-- Bring in all the bci_ bytecode constants.
+#include "rts/Bytecodes.h"
+
+largeArgInstr :: Word16 -> Word16
+largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
+
+largeArg :: DynFlags -> Word -> [Word16]
+largeArg dflags w
+ | wORD_SIZE_IN_BITS dflags == 64
+           = [fromIntegral (w `shiftR` 48),
+              fromIntegral (w `shiftR` 32),
+              fromIntegral (w `shiftR` 16),
+              fromIntegral w]
+ | wORD_SIZE_IN_BITS dflags == 32
+           = [fromIntegral (w `shiftR` 16),
+              fromIntegral w]
+ | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
+
+largeArg16s :: DynFlags -> Word
+largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4
+                   | otherwise                      = 2
+
+assembleI :: DynFlags
+          -> BCInstr
+          -> Assembler ()
+assembleI dflags i = case i of
+  STKCHECK n               -> emit bci_STKCHECK [Op n]
+  PUSH_L o1                -> emit bci_PUSH_L [SmallOp o1]
+  PUSH_LL o1 o2            -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2]
+  PUSH_LLL o1 o2 o3        -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3]
+  PUSH8 o1                 -> emit bci_PUSH8 [SmallOp o1]
+  PUSH16 o1                -> emit bci_PUSH16 [SmallOp o1]
+  PUSH32 o1                -> emit bci_PUSH32 [SmallOp o1]
+  PUSH8_W o1               -> emit bci_PUSH8_W [SmallOp o1]
+  PUSH16_W o1              -> emit bci_PUSH16_W [SmallOp o1]
+  PUSH32_W o1              -> emit bci_PUSH32_W [SmallOp o1]
+  PUSH_G nm                -> do p <- ptr (BCOPtrName nm)
+                                 emit bci_PUSH_G [Op p]
+  PUSH_PRIMOP op           -> do p <- ptr (BCOPtrPrimOp op)
+                                 emit bci_PUSH_G [Op p]
+  PUSH_BCO proto           -> do let ul_bco = assembleBCO dflags proto
+                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
+                                 emit bci_PUSH_G [Op p]
+  PUSH_ALTS proto          -> do let ul_bco = assembleBCO dflags proto
+                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
+                                 emit bci_PUSH_ALTS [Op p]
+  PUSH_ALTS_UNLIFTED proto pk
+                           -> do let ul_bco = assembleBCO dflags proto
+                                 p <- ioptr (liftM BCOPtrBCO ul_bco)
+                                 emit (push_alts pk) [Op p]
+  PUSH_PAD8                -> emit bci_PUSH_PAD8 []
+  PUSH_PAD16               -> emit bci_PUSH_PAD16 []
+  PUSH_PAD32               -> emit bci_PUSH_PAD32 []
+  PUSH_UBX8 lit            -> do np <- literal lit
+                                 emit bci_PUSH_UBX8 [Op np]
+  PUSH_UBX16 lit           -> do np <- literal lit
+                                 emit bci_PUSH_UBX16 [Op np]
+  PUSH_UBX32 lit           -> do np <- literal lit
+                                 emit bci_PUSH_UBX32 [Op np]
+  PUSH_UBX lit nws         -> do np <- literal lit
+                                 emit bci_PUSH_UBX [Op np, SmallOp nws]
+
+  PUSH_APPLY_N             -> emit bci_PUSH_APPLY_N []
+  PUSH_APPLY_V             -> emit bci_PUSH_APPLY_V []
+  PUSH_APPLY_F             -> emit bci_PUSH_APPLY_F []
+  PUSH_APPLY_D             -> emit bci_PUSH_APPLY_D []
+  PUSH_APPLY_L             -> emit bci_PUSH_APPLY_L []
+  PUSH_APPLY_P             -> emit bci_PUSH_APPLY_P []
+  PUSH_APPLY_PP            -> emit bci_PUSH_APPLY_PP []
+  PUSH_APPLY_PPP           -> emit bci_PUSH_APPLY_PPP []
+  PUSH_APPLY_PPPP          -> emit bci_PUSH_APPLY_PPPP []
+  PUSH_APPLY_PPPPP         -> emit bci_PUSH_APPLY_PPPPP []
+  PUSH_APPLY_PPPPPP        -> emit bci_PUSH_APPLY_PPPPPP []
+
+  SLIDE     n by           -> emit bci_SLIDE [SmallOp n, SmallOp by]
+  ALLOC_AP  n              -> emit bci_ALLOC_AP [SmallOp n]
+  ALLOC_AP_NOUPD n         -> emit bci_ALLOC_AP_NOUPD [SmallOp n]
+  ALLOC_PAP arity n        -> emit bci_ALLOC_PAP [SmallOp arity, SmallOp n]
+  MKAP      off sz         -> emit bci_MKAP [SmallOp off, SmallOp sz]
+  MKPAP     off sz         -> emit bci_MKPAP [SmallOp off, SmallOp sz]
+  UNPACK    n              -> emit bci_UNPACK [SmallOp n]
+  PACK      dcon sz        -> do itbl_no <- lit [BCONPtrItbl (getName dcon)]
+                                 emit bci_PACK [Op itbl_no, SmallOp sz]
+  LABEL     lbl            -> label lbl
+  TESTLT_I  i l            -> do np <- int i
+                                 emit bci_TESTLT_I [Op np, LabelOp l]
+  TESTEQ_I  i l            -> do np <- int i
+                                 emit bci_TESTEQ_I [Op np, LabelOp l]
+  TESTLT_W  w l            -> do np <- word w
+                                 emit bci_TESTLT_W [Op np, LabelOp l]
+  TESTEQ_W  w l            -> do np <- word w
+                                 emit bci_TESTEQ_W [Op np, LabelOp l]
+  TESTLT_F  f l            -> do np <- float f
+                                 emit bci_TESTLT_F [Op np, LabelOp l]
+  TESTEQ_F  f l            -> do np <- float f
+                                 emit bci_TESTEQ_F [Op np, LabelOp l]
+  TESTLT_D  d l            -> do np <- double d
+                                 emit bci_TESTLT_D [Op np, LabelOp l]
+  TESTEQ_D  d l            -> do np <- double d
+                                 emit bci_TESTEQ_D [Op np, LabelOp l]
+  TESTLT_P  i l            -> emit bci_TESTLT_P [SmallOp i, LabelOp l]
+  TESTEQ_P  i l            -> emit bci_TESTEQ_P [SmallOp i, LabelOp l]
+  CASEFAIL                 -> emit bci_CASEFAIL []
+  SWIZZLE   stkoff n       -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n]
+  JMP       l              -> emit bci_JMP [LabelOp l]
+  ENTER                    -> emit bci_ENTER []
+  RETURN                   -> emit bci_RETURN []
+  RETURN_UBX rep           -> emit (return_ubx rep) []
+  CCALL off m_addr i       -> do np <- addr m_addr
+                                 emit bci_CCALL [SmallOp off, Op np, SmallOp i]
+  BRK_FUN index uniq cc    -> do p1 <- ptr BCOPtrBreakArray
+                                 q <- int (getKey uniq)
+                                 np <- addr cc
+                                 emit bci_BRK_FUN [Op p1, SmallOp index,
+                                                   Op q, Op np]
+
+  where
+    literal (LitLabel fs (Just sz) _)
+     | platformOS (targetPlatform dflags) == OSMinGW32
+         = litlabel (appendFS fs (mkFastString ('@':show sz)))
+     -- On Windows, stdcall labels have a suffix indicating the no. of
+     -- arg words, e.g. foo@8.  testcase: ffi012(ghci)
+    literal (LitLabel fs _ _) = litlabel fs
+    literal LitNullAddr       = int 0
+    literal (LitFloat r)      = float (fromRational r)
+    literal (LitDouble r)     = double (fromRational r)
+    literal (LitChar c)       = int (ord c)
+    literal (LitString bs)    = lit [BCONPtrStr bs]
+       -- LitString requires a zero-terminator when emitted
+    literal (LitNumber nt i _) = case nt of
+      LitNumInt     -> int (fromIntegral i)
+      LitNumWord    -> int (fromIntegral i)
+      LitNumInt64   -> int64 (fromIntegral i)
+      LitNumWord64  -> int64 (fromIntegral i)
+      LitNumInteger -> panic "ByteCodeAsm.literal: LitNumInteger"
+      LitNumNatural -> panic "ByteCodeAsm.literal: LitNumNatural"
+    -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most
+    -- likely to elicit a crash (rather than corrupt memory) in case absence
+    -- analysis messed up.
+    literal LitRubbish         = int 0
+
+    litlabel fs = lit [BCONPtrLbl fs]
+    addr (RemotePtr a) = words [fromIntegral a]
+    float = words . mkLitF
+    double = words . mkLitD dflags
+    int = words . mkLitI
+    int64 = words . mkLitI64 dflags
+    words ws = lit (map BCONPtrWord ws)
+    word w = words [w]
+
+isLarge :: Word -> Bool
+isLarge n = n > 65535
+
+push_alts :: ArgRep -> Word16
+push_alts V   = bci_PUSH_ALTS_V
+push_alts P   = bci_PUSH_ALTS_P
+push_alts N   = bci_PUSH_ALTS_N
+push_alts L   = bci_PUSH_ALTS_L
+push_alts F   = bci_PUSH_ALTS_F
+push_alts D   = bci_PUSH_ALTS_D
+push_alts V16 = error "push_alts: vector"
+push_alts V32 = error "push_alts: vector"
+push_alts V64 = error "push_alts: vector"
+
+return_ubx :: ArgRep -> Word16
+return_ubx V   = bci_RETURN_V
+return_ubx P   = bci_RETURN_P
+return_ubx N   = bci_RETURN_N
+return_ubx L   = bci_RETURN_L
+return_ubx F   = bci_RETURN_F
+return_ubx D   = bci_RETURN_D
+return_ubx V16 = error "return_ubx: vector"
+return_ubx V32 = error "return_ubx: vector"
+return_ubx V64 = error "return_ubx: vector"
+
+-- Make lists of host-sized words for literals, so that when the
+-- words are placed in memory at increasing addresses, the
+-- bit pattern is correct for the host's word size and endianness.
+mkLitI   ::             Int    -> [Word]
+mkLitF   ::             Float  -> [Word]
+mkLitD   :: DynFlags -> Double -> [Word]
+mkLitI64 :: DynFlags -> Int64  -> [Word]
+
+mkLitF f
+   = runST (do
+        arr <- newArray_ ((0::Int),0)
+        writeArray arr 0 f
+        f_arr <- castSTUArray arr
+        w0 <- readArray f_arr 0
+        return [w0 :: Word]
+     )
+
+mkLitD dflags d
+   | wORD_SIZE dflags == 4
+   = runST (do
+        arr <- newArray_ ((0::Int),1)
+        writeArray arr 0 d
+        d_arr <- castSTUArray arr
+        w0 <- readArray d_arr 0
+        w1 <- readArray d_arr 1
+        return [w0 :: Word, w1]
+     )
+   | wORD_SIZE dflags == 8
+   = runST (do
+        arr <- newArray_ ((0::Int),0)
+        writeArray arr 0 d
+        d_arr <- castSTUArray arr
+        w0 <- readArray d_arr 0
+        return [w0 :: Word]
+     )
+   | otherwise
+   = panic "mkLitD: Bad wORD_SIZE"
+
+mkLitI64 dflags ii
+   | wORD_SIZE dflags == 4
+   = runST (do
+        arr <- newArray_ ((0::Int),1)
+        writeArray arr 0 ii
+        d_arr <- castSTUArray arr
+        w0 <- readArray d_arr 0
+        w1 <- readArray d_arr 1
+        return [w0 :: Word,w1]
+     )
+   | wORD_SIZE dflags == 8
+   = runST (do
+        arr <- newArray_ ((0::Int),0)
+        writeArray arr 0 ii
+        d_arr <- castSTUArray arr
+        w0 <- readArray d_arr 0
+        return [w0 :: Word]
+     )
+   | otherwise
+   = panic "mkLitI64: Bad wORD_SIZE"
+
+mkLitI i = [fromIntegral i :: Word]
+
+iNTERP_STACK_CHECK_THRESH :: Int
+iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -0,0 +1,1960 @@
+{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# OPTIONS_GHC -fprof-auto-top #-}
+--
+--  (c) The University of Glasgow 2002-2006
+--
+
+-- | ByteCodeGen: Generate bytecode from Core
+module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import ByteCodeInstr
+import ByteCodeAsm
+import ByteCodeTypes
+
+import GHCi
+import GHCi.FFI
+import GHCi.RemoteTypes
+import BasicTypes
+import DynFlags
+import Outputable
+import Platform
+import Name
+import MkId
+import Id
+import ForeignCall
+import HscTypes
+import CoreUtils
+import CoreSyn
+import PprCore
+import Literal
+import PrimOp
+import CoreFVs
+import Type
+import RepType
+import Kind            ( isLiftedTypeKind )
+import DataCon
+import TyCon
+import Util
+import VarSet
+import TysPrim
+import ErrUtils
+import Unique
+import FastString
+import Panic
+import StgCmmClosure    ( NonVoid(..), fromNonVoid, nonVoidIds )
+import StgCmmLayout
+import SMRep hiding (WordOff, ByteOff, wordsToBytes)
+import Bitmap
+import OrdList
+import Maybes
+import VarEnv
+
+import Data.List
+import Foreign
+import Control.Monad
+import Data.Char
+
+import UniqSupply
+import Module
+import Control.Arrow ( second )
+
+import Control.Exception
+import Data.Array
+import Data.ByteString (ByteString)
+import Data.Map (Map)
+import Data.IntMap (IntMap)
+import qualified Data.Map as Map
+import qualified Data.IntMap as IntMap
+import qualified FiniteMap as Map
+import Data.Ord
+import GHC.Stack.CCS
+import Data.Either ( partitionEithers )
+
+-- -----------------------------------------------------------------------------
+-- Generating byte code for a complete module
+
+byteCodeGen :: HscEnv
+            -> Module
+            -> CoreProgram
+            -> [TyCon]
+            -> Maybe ModBreaks
+            -> IO CompiledByteCode
+byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
+   = withTiming (pure dflags)
+                (text "ByteCodeGen"<+>brackets (ppr this_mod))
+                (const ()) $ do
+        -- Split top-level binds into strings and others.
+        -- See Note [generating code for top-level string literal bindings].
+        let (strings, flatBinds) = partitionEithers $ do
+                (bndr, rhs) <- flattenBinds binds
+                return $ case exprIsTickedString_maybe rhs of
+                    Just str -> Left (bndr, str)
+                    _ -> Right (bndr, simpleFreeVars rhs)
+        stringPtrs <- allocateTopStrings hsc_env strings
+
+        us <- mkSplitUniqSupply 'y'
+        (BcM_State{..}, proto_bcos) <-
+           runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $
+             mapM schemeTopBind flatBinds
+
+        when (notNull ffis)
+             (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
+
+        dumpIfSet_dyn dflags Opt_D_dump_BCOs
+           "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
+
+        cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs)
+          (case modBreaks of
+             Nothing -> Nothing
+             Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
+
+        -- Squash space leaks in the CompiledByteCode.  This is really
+        -- important, because when loading a set of modules into GHCi
+        -- we don't touch the CompiledByteCode until the end when we
+        -- do linking.  Forcing out the thunks here reduces space
+        -- usage by more than 50% when loading a large number of
+        -- modules.
+        evaluate (seqCompiledByteCode cbc)
+
+        return cbc
+
+  where dflags = hsc_dflags hsc_env
+
+allocateTopStrings
+  :: HscEnv
+  -> [(Id, ByteString)]
+  -> IO [(Var, RemotePtr ())]
+allocateTopStrings hsc_env topStrings = do
+  let !(bndrs, strings) = unzip topStrings
+  ptrs <- iservCmd hsc_env $ MallocStrings strings
+  return $ zip bndrs ptrs
+
+{-
+Note [generating code for top-level string literal bindings]
+
+Here is a summary on how the byte code generator deals with top-level string
+literals:
+
+1. Top-level string literal bindings are separated from the rest of the module.
+
+2. The strings are allocated via iservCmd, in allocateTopStrings
+
+3. The mapping from binders to allocated strings (topStrings) are maintained in
+   BcM and used when generating code for variable references.
+-}
+
+-- -----------------------------------------------------------------------------
+-- Generating byte code for an expression
+
+-- Returns: the root BCO for this expression
+coreExprToBCOs :: HscEnv
+               -> Module
+               -> CoreExpr
+               -> IO UnlinkedBCO
+coreExprToBCOs hsc_env this_mod expr
+ = withTiming (pure dflags)
+              (text "ByteCodeGen"<+>brackets (ppr this_mod))
+              (const ()) $ do
+      -- create a totally bogus name for the top-level BCO; this
+      -- should be harmless, since it's never used for anything
+      let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")
+          invented_id    = Id.mkLocalId invented_name (panic "invented_id's type")
+
+      -- the uniques are needed to generate fresh variables when we introduce new
+      -- let bindings for ticked expressions
+      us <- mkSplitUniqSupply 'y'
+      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)
+         <- runBc hsc_env us this_mod Nothing emptyVarEnv $
+              schemeTopBind (invented_id, simpleFreeVars expr)
+
+      when (notNull mallocd)
+           (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
+
+      dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)
+
+      assembleOneBCO hsc_env proto_bco
+  where dflags = hsc_dflags hsc_env
+
+-- The regular freeVars function gives more information than is useful to
+-- us here. simpleFreeVars does the impedance matching.
+simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet
+simpleFreeVars = go . freeVars
+  where
+    go :: AnnExpr Id FVAnn -> AnnExpr Id DVarSet
+    go (ann, e) = (freeVarsOfAnn ann, go' e)
+
+    go' :: AnnExpr' Id FVAnn -> AnnExpr' Id DVarSet
+    go' (AnnVar id)                  = AnnVar id
+    go' (AnnLit lit)                 = AnnLit lit
+    go' (AnnLam bndr body)           = AnnLam bndr (go body)
+    go' (AnnApp fun arg)             = AnnApp (go fun) (go arg)
+    go' (AnnCase scrut bndr ty alts) = AnnCase (go scrut) bndr ty (map go_alt alts)
+    go' (AnnLet bind body)           = AnnLet (go_bind bind) (go body)
+    go' (AnnCast expr (ann, co))     = AnnCast (go expr) (freeVarsOfAnn ann, co)
+    go' (AnnTick tick body)          = AnnTick tick (go body)
+    go' (AnnType ty)                 = AnnType ty
+    go' (AnnCoercion co)             = AnnCoercion co
+
+    go_alt (con, args, expr) = (con, args, go expr)
+
+    go_bind (AnnNonRec bndr rhs) = AnnNonRec bndr (go rhs)
+    go_bind (AnnRec pairs)       = AnnRec (map (second go) pairs)
+
+-- -----------------------------------------------------------------------------
+-- Compilation schema for the bytecode generator
+
+type BCInstrList = OrdList BCInstr
+
+newtype ByteOff = ByteOff Int
+    deriving (Enum, Eq, Integral, Num, Ord, Real)
+
+newtype WordOff = WordOff Int
+    deriving (Enum, Eq, Integral, Num, Ord, Real)
+
+wordsToBytes :: DynFlags -> WordOff -> ByteOff
+wordsToBytes dflags = fromIntegral . (* wORD_SIZE dflags) . fromIntegral
+
+-- Used when we know we have a whole number of words
+bytesToWords :: DynFlags -> ByteOff -> WordOff
+bytesToWords dflags (ByteOff bytes) =
+    let (q, r) = bytes `quotRem` (wORD_SIZE dflags)
+    in if r == 0
+           then fromIntegral q
+           else panic $ "ByteCodeGen.bytesToWords: bytes=" ++ show bytes
+
+wordSize :: DynFlags -> ByteOff
+wordSize dflags = ByteOff (wORD_SIZE dflags)
+
+type Sequel = ByteOff -- back off to this depth before ENTER
+
+type StackDepth = ByteOff
+
+-- | Maps Ids to their stack depth. This allows us to avoid having to mess with
+-- it after each push/pop.
+type BCEnv = Map Id StackDepth -- To find vars on the stack
+
+{-
+ppBCEnv :: BCEnv -> SDoc
+ppBCEnv p
+   = text "begin-env"
+     $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))
+     $$ text "end-env"
+     where
+        pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var)
+        cmp_snd x y = compare (snd x) (snd y)
+-}
+
+-- Create a BCO and do a spot of peephole optimisation on the insns
+-- at the same time.
+mkProtoBCO
+   :: DynFlags
+   -> name
+   -> BCInstrList
+   -> Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
+   -> Int
+   -> Word16
+   -> [StgWord]
+   -> Bool      -- True <=> is a return point, rather than a function
+   -> [FFIInfo]
+   -> ProtoBCO name
+mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
+   = ProtoBCO {
+        protoBCOName = nm,
+        protoBCOInstrs = maybe_with_stack_check,
+        protoBCOBitmap = bitmap,
+        protoBCOBitmapSize = bitmap_size,
+        protoBCOArity = arity,
+        protoBCOExpr = origin,
+        protoBCOFFIs = ffis
+      }
+     where
+        -- Overestimate the stack usage (in words) of this BCO,
+        -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
+        -- stack check.  (The interpreter always does a stack check
+        -- for iNTERP_STACK_CHECK_THRESH words at the start of each
+        -- BCO anyway, so we only need to add an explicit one in the
+        -- (hopefully rare) cases when the (overestimated) stack use
+        -- exceeds iNTERP_STACK_CHECK_THRESH.
+        maybe_with_stack_check
+           | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d
+                -- don't do stack checks at return points,
+                -- everything is aggregated up to the top BCO
+                -- (which must be a function).
+                -- That is, unless the stack usage is >= AP_STACK_SPLIM,
+                -- see bug #1466.
+           | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH
+           = STKCHECK stack_usage : peep_d
+           | otherwise
+           = peep_d     -- the supposedly common case
+
+        -- We assume that this sum doesn't wrap
+        stack_usage = sum (map bciStackUse peep_d)
+
+        -- Merge local pushes
+        peep_d = peep (fromOL instrs_ordlist)
+
+        peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)
+           = PUSH_LLL off1 (off2-1) (off3-2) : peep rest
+        peep (PUSH_L off1 : PUSH_L off2 : rest)
+           = PUSH_LL off1 (off2-1) : peep rest
+        peep (i:rest)
+           = i : peep rest
+        peep []
+           = []
+
+argBits :: DynFlags -> [ArgRep] -> [Bool]
+argBits _      [] = []
+argBits dflags (rep : args)
+  | isFollowableArg rep  = False : argBits dflags args
+  | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args
+
+-- -----------------------------------------------------------------------------
+-- schemeTopBind
+
+-- Compile code for the right-hand side of a top-level binding
+
+schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)
+schemeTopBind (id, rhs)
+  | Just data_con <- isDataConWorkId_maybe id,
+    isNullaryRepDataCon data_con = do
+    dflags <- getDynFlags
+        -- Special case for the worker of a nullary data con.
+        -- It'll look like this:        Nil = /\a -> Nil a
+        -- If we feed it into schemeR, we'll get
+        --      Nil = Nil
+        -- because mkConAppCode treats nullary constructor applications
+        -- by just re-using the single top-level definition.  So
+        -- for the worker itself, we must allocate it directly.
+    -- ioToBc (putStrLn $ "top level BCO")
+    emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER])
+                       (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
+
+  | otherwise
+  = schemeR [{- No free variables -}] (id, rhs)
+
+
+-- -----------------------------------------------------------------------------
+-- schemeR
+
+-- Compile code for a right-hand side, to give a BCO that,
+-- when executed with the free variables and arguments on top of the stack,
+-- will return with a pointer to the result on top of the stack, after
+-- removing the free variables and arguments.
+--
+-- Park the resulting BCO in the monad.  Also requires the
+-- variable to which this value was bound, so as to give the
+-- resulting BCO a name.
+
+schemeR :: [Id]                 -- Free vars of the RHS, ordered as they
+                                -- will appear in the thunk.  Empty for
+                                -- top-level things, which have no free vars.
+        -> (Id, AnnExpr Id DVarSet)
+        -> BcM (ProtoBCO Name)
+schemeR fvs (nm, rhs)
+{-
+   | trace (showSDoc (
+              (char ' '
+               $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs
+               $$ pprCoreExpr (deAnnotate rhs)
+               $$ char ' '
+              ))) False
+   = undefined
+   | otherwise
+-}
+   = schemeR_wrk fvs nm rhs (collect rhs)
+
+collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)
+collect (_, e) = go [] e
+  where
+    go xs e | Just e' <- bcView e = go xs e'
+    go xs (AnnLam x (_,e))
+      | typePrimRep (idType x) `lengthExceeds` 1
+      = multiValException
+      | otherwise
+      = go (x:xs) e
+    go xs not_lambda = (reverse xs, not_lambda)
+
+schemeR_wrk
+    :: [Id]
+    -> Id
+    -> AnnExpr Id DVarSet
+    -> ([Var], AnnExpr' Var DVarSet)
+    -> BcM (ProtoBCO Name)
+schemeR_wrk fvs nm original_body (args, body)
+   = do
+     dflags <- getDynFlags
+     let
+         all_args  = reverse args ++ fvs
+         arity     = length all_args
+         -- all_args are the args in reverse order.  We're compiling a function
+         -- \fv1..fvn x1..xn -> e
+         -- i.e. the fvs come first
+
+         -- Stack arguments always take a whole number of words, we never pack
+         -- them unlike constructor fields.
+         szsb_args = map (wordsToBytes dflags . idSizeW dflags) all_args
+         sum_szsb_args  = sum szsb_args
+         p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))
+
+         -- make the arg bitmap
+         bits = argBits dflags (reverse (map bcIdArgRep all_args))
+         bitmap_size = genericLength bits
+         bitmap = mkBitmap dflags bits
+     body_code <- schemeER_wrk sum_szsb_args p_init body
+
+     emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body)
+                 arity bitmap_size bitmap False{-not alts-})
+
+-- introduce break instructions for ticked expressions
+schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
+schemeER_wrk d p rhs
+  | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs
+  = do  code <- schemeE d 0 p newRhs
+        cc_arr <- getCCArray
+        this_mod <- moduleName <$> getCurrentModule
+        dflags <- getDynFlags
+        let idOffSets = getVarOffSets dflags d p fvs
+        let breakInfo = CgBreakInfo
+                        { cgb_vars = idOffSets
+                        , cgb_resty = exprType (deAnnotate' newRhs)
+                        }
+        newBreakInfo tick_no breakInfo
+        dflags <- getDynFlags
+        let cc | interpreterProfiled dflags = cc_arr ! tick_no
+               | otherwise = toRemotePtr nullPtr
+        let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc
+        return $ breakInstr `consOL` code
+   | otherwise = schemeE d 0 p rhs
+
+getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [(Id, Word16)]
+getVarOffSets dflags depth env = catMaybes . map getOffSet
+  where
+    getOffSet id = case lookupBCEnv_maybe id env of
+        Nothing     -> Nothing
+        Just offset ->
+            -- michalt: I'm not entirely sure why we need the stack
+            -- adjustment by 2 here. I initially thought that there's
+            -- something off with getIdValFromApStack (the only user of this
+            -- value), but it looks ok to me. My current hypothesis is that
+            -- this "adjustment" is needed due to stack manipulation for
+            -- BRK_FUN in Interpreter.c In any case, this is used only when
+            -- we trigger a breakpoint.
+            let !var_depth_ws =
+                    trunc16W $ bytesToWords dflags (depth - offset) + 2
+            in Just (id, var_depth_ws)
+
+truncIntegral16 :: Integral a => a -> Word16
+truncIntegral16 w
+    | w > fromIntegral (maxBound :: Word16)
+    = panic "stack depth overflow"
+    | otherwise
+    = fromIntegral w
+
+trunc16B :: ByteOff -> Word16
+trunc16B = truncIntegral16
+
+trunc16W :: WordOff -> Word16
+trunc16W = truncIntegral16
+
+fvsToEnv :: BCEnv -> DVarSet -> [Id]
+-- Takes the free variables of a right-hand side, and
+-- delivers an ordered list of the local variables that will
+-- be captured in the thunk for the RHS
+-- The BCEnv argument tells which variables are in the local
+-- environment: these are the ones that should be captured
+--
+-- The code that constructs the thunk, and the code that executes
+-- it, have to agree about this layout
+fvsToEnv p fvs = [v | v <- dVarSetElems fvs,
+                      isId v,           -- Could be a type variable
+                      v `Map.member` p]
+
+-- -----------------------------------------------------------------------------
+-- schemeE
+
+returnUnboxedAtom
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> AnnExpr' Id DVarSet
+    -> ArgRep
+    -> BcM BCInstrList
+-- Returning an unlifted value.
+-- Heave it on the stack, SLIDE, and RETURN.
+returnUnboxedAtom d s p e e_rep = do
+    dflags <- getDynFlags
+    (push, szb) <- pushAtom d p e
+    return (push                                 -- value onto stack
+           `appOL`  mkSlideB dflags szb (d - s)  -- clear to sequel
+           `snocOL` RETURN_UBX e_rep)            -- go
+
+-- Compile code to apply the given expression to the remaining args
+-- on the stack, returning a HNF.
+schemeE
+    :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
+schemeE d s p e
+   | Just e' <- bcView e
+   = schemeE d s p e'
+
+-- Delegate tail-calls to schemeT.
+schemeE d s p e@(AnnApp _ _) = schemeT d s p e
+
+schemeE d s p e@(AnnLit lit)     = returnUnboxedAtom d s p e (typeArgRep (literalType lit))
+schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V
+
+schemeE d s p e@(AnnVar v)
+    | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)
+    | otherwise                 = schemeT d s p e
+
+schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
+   | (AnnVar v, args_r_to_l) <- splitApp rhs,
+     Just data_con <- isDataConWorkId_maybe v,
+     dataConRepArity data_con == length args_r_to_l
+   = do -- Special case for a non-recursive let whose RHS is a
+        -- saturated constructor application.
+        -- Just allocate the constructor and carry on
+        alloc_code <- mkConAppCode d s p data_con args_r_to_l
+        dflags <- getDynFlags
+        let !d2 = d + wordSize dflags
+        body_code <- schemeE d2 s (Map.insert x d2 p) body
+        return (alloc_code `appOL` body_code)
+
+-- General case for let.  Generates correct, if inefficient, code in
+-- all situations.
+schemeE d s p (AnnLet binds (_,body)) = do
+     dflags <- getDynFlags
+     let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])
+                                   AnnRec xs_n_rhss -> unzip xs_n_rhss
+         n_binds = genericLength xs
+
+         fvss  = map (fvsToEnv p' . fst) rhss
+
+         -- Sizes of free vars
+         size_w = trunc16W . idSizeW dflags
+         sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
+
+         -- the arity of each rhs
+         arities = map (genericLength . fst . collect) rhss
+
+         -- This p', d' defn is safe because all the items being pushed
+         -- are ptrs, so all have size 1 word.  d' and p' reflect the stack
+         -- after the closures have been allocated in the heap (but not
+         -- filled in), and pointers to them parked on the stack.
+         offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags))
+         p' = Map.insertList (zipE xs offsets) p
+         d' = d + wordsToBytes dflags n_binds
+         zipE = zipEqual "schemeE"
+
+         -- ToDo: don't build thunks for things with no free variables
+         build_thunk
+             :: StackDepth
+             -> [Id]
+             -> Word16
+             -> ProtoBCO Name
+             -> Word16
+             -> Word16
+             -> BcM BCInstrList
+         build_thunk _ [] size bco off arity
+            = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))
+           where
+                mkap | arity == 0 = MKAP
+                     | otherwise  = MKPAP
+         build_thunk dd (fv:fvs) size bco off arity = do
+              (push_code, pushed_szb) <- pushAtom dd p' (AnnVar fv)
+              more_push_code <-
+                  build_thunk (dd + pushed_szb) fvs size bco off arity
+              return (push_code `appOL` more_push_code)
+
+         alloc_code = toOL (zipWith mkAlloc sizes arities)
+           where mkAlloc sz 0
+                    | is_tick     = ALLOC_AP_NOUPD sz
+                    | otherwise   = ALLOC_AP sz
+                 mkAlloc sz arity = ALLOC_PAP arity sz
+
+         is_tick = case binds of
+                     AnnNonRec id _ -> occNameFS (getOccName id) == tickFS
+                     _other -> False
+
+         compile_bind d' fvs x rhs size arity off = do
+                bco <- schemeR fvs (x,rhs)
+                build_thunk d' fvs size bco off arity
+
+         compile_binds =
+            [ compile_bind d' fvs x rhs size arity (trunc16W n)
+            | (fvs, x, rhs, size, arity, n) <-
+                zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]
+            ]
+     body_code <- schemeE d' s p' body
+     thunk_codes <- sequence compile_binds
+     return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)
+
+-- Introduce a let binding for a ticked case expression. This rule
+-- *should* only fire when the expression was not already let-bound
+-- (the code gen for let bindings should take care of that).  Todo: we
+-- call exprFreeVars on a deAnnotated expression, this may not be the
+-- best way to calculate the free vars but it seemed like the least
+-- intrusive thing to do
+schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
+   | isLiftedTypeKind (typeKind ty)
+   = do   id <- newId ty
+          -- Todo: is emptyVarSet correct on the next line?
+          let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id)
+          schemeE d s p letExp
+
+   | otherwise
+   = do   -- If the result type is not definitely lifted, then we must generate
+          --   let f = \s . tick<n> e
+          --   in  f realWorld#
+          -- When we stop at the breakpoint, _result will have an unlifted
+          -- type and hence won't be bound in the environment, but the
+          -- breakpoint will otherwise work fine.
+          --
+          -- NB (Trac #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 (mkFunTy realWorldStatePrimTy ty)
+          st <- newId realWorldStatePrimTy
+          let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))
+                              (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)
+                                                    (emptyDVarSet, AnnVar realWorldPrimId)))
+          schemeE d s p letExp
+
+   where
+     exp' = deAnnotate' exp
+     fvs  = exprFreeVarsDSet exp'
+     ty   = exprType exp'
+
+-- ignore other kinds of tick
+schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs
+
+schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
+        -- no alts: scrut is guaranteed to diverge
+
+schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
+   | isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token)
+        -- Convert
+        --      case .... of x { (# V'd-thing, a #) -> ... }
+        -- to
+        --      case .... of a { DEFAULT -> ... }
+        -- because the return convention for both are identical.
+        --
+        -- Note that it does not matter losing the void-rep thing from the
+        -- envt (it won't be bound now) because we never look such things up.
+   , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of
+                   ([], [_])
+                     -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr)
+                   ([_], [])
+                     -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
+                   _ -> Nothing
+   = res
+
+schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
+   | isUnboxedTupleCon dc
+   , typePrimRep (idType bndr) `lengthAtMost` 1 -- handles unit tuples
+   = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
+
+schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])
+   | isUnboxedTupleType (idType bndr)
+   , Just ty <- case typePrimRep (idType bndr) of
+       [_]  -> Just (unwrapType (idType bndr))
+       []   -> Just voidPrimTy
+       _    -> Nothing
+       -- handles any pattern with a single non-void binder; in particular I/O
+       -- monad returns (# RealWorld#, a #)
+   = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr)
+
+schemeE d s p (AnnCase scrut bndr _ alts)
+   = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-}
+
+schemeE _ _ _ expr
+   = pprPanic "ByteCodeGen.schemeE: unhandled case"
+               (pprCoreExpr (deAnnotate' expr))
+
+{-
+   Ticked Expressions
+   ------------------
+
+  The idea is that the "breakpoint<n,fvs> E" is really just an annotation on
+  the code. When we find such a thing, we pull out the useful information,
+  and then compile the code as if it was just the expression E.
+
+-}
+
+-- Compile code to do a tail call.  Specifically, push the fn,
+-- slide the on-stack app back down to the sequel depth,
+-- and enter.  Four cases:
+--
+-- 0.  (Nasty hack).
+--     An application "GHC.Prim.tagToEnum# <type> unboxed-int".
+--     The int will be on the stack.  Generate a code sequence
+--     to convert it to the relevant constructor, SLIDE and ENTER.
+--
+-- 1.  The fn denotes a ccall.  Defer to generateCCall.
+--
+-- 2.  (Another nasty hack).  Spot (# a::V, b #) and treat
+--     it simply as  b  -- since the representations are identical
+--     (the V takes up zero stack space).  Also, spot
+--     (# b #) and treat it as  b.
+--
+-- 3.  Application of a constructor, by defn saturated.
+--     Split the args into ptrs and non-ptrs, and push the nonptrs,
+--     then the ptrs, and then do PACK and RETURN.
+--
+-- 4.  Otherwise, it must be a function call.  Push the args
+--     right to left, SLIDE and ENTER.
+
+schemeT :: StackDepth   -- Stack depth
+        -> Sequel       -- Sequel depth
+        -> BCEnv        -- stack env
+        -> AnnExpr' Id DVarSet
+        -> BcM BCInstrList
+
+schemeT d s p app
+
+   -- Case 0
+   | Just (arg, constr_names) <- maybe_is_tagToEnum_call app
+   = implement_tagToId d s p arg constr_names
+
+   -- Case 1
+   | Just (CCall ccall_spec) <- isFCallId_maybe fn
+   = if isSupportedCConv ccall_spec
+      then generateCCall d s p ccall_spec fn args_r_to_l
+      else unsupportedCConvException
+
+
+   -- Case 2: Constructor application
+   | Just con <- maybe_saturated_dcon
+   , isUnboxedTupleCon con
+   = case args_r_to_l of
+        [arg1,arg2] | isVAtom arg1 ->
+                  unboxedTupleReturn d s p arg2
+        [arg1,arg2] | isVAtom arg2 ->
+                  unboxedTupleReturn d s p arg1
+        _other -> multiValException
+
+   -- Case 3: Ordinary data constructor
+   | Just con <- maybe_saturated_dcon
+   = do alloc_con <- mkConAppCode d s p con args_r_to_l
+        dflags <- getDynFlags
+        return (alloc_con         `appOL`
+                mkSlideW 1 (bytesToWords dflags $ d - s) `snocOL`
+                ENTER)
+
+   -- Case 4: Tail call of function
+   | otherwise
+   = doTailCall d s p fn args_r_to_l
+
+   where
+        -- Extract the args (R->L) and fn
+        -- The function will necessarily be a variable,
+        -- because we are compiling a tail call
+      (AnnVar fn, args_r_to_l) = splitApp app
+
+      -- Only consider this to be a constructor application iff it is
+      -- saturated.  Otherwise, we'll call the constructor wrapper.
+      n_args = length args_r_to_l
+      maybe_saturated_dcon
+        = case isDataConWorkId_maybe fn of
+                Just con | dataConRepArity con == n_args -> Just con
+                _ -> Nothing
+
+-- -----------------------------------------------------------------------------
+-- Generate code to build a constructor application,
+-- leaving it on top of the stack
+
+mkConAppCode
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> DataCon                  -- The data constructor
+    -> [AnnExpr' Id DVarSet]    -- Args, in *reverse* order
+    -> BcM BCInstrList
+mkConAppCode _ _ _ con []       -- Nullary constructor
+  = ASSERT( isNullaryRepDataCon con )
+    return (unitOL (PUSH_G (getName (dataConWorkId con))))
+        -- Instead of doing a PACK, which would allocate a fresh
+        -- copy of this constructor, use the single shared version.
+
+mkConAppCode orig_d _ p con args_r_to_l =
+    ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code
+  where
+    app_code = do
+        dflags <- getDynFlags
+
+        -- The args are initially in reverse order, but mkVirtHeapOffsets
+        -- expects them to be left-to-right.
+        let non_voids =
+                [ NonVoid (prim_rep, arg)
+                | arg <- reverse args_r_to_l
+                , let prim_rep = atomPrimRep arg
+                , not (isVoidRep prim_rep)
+                ]
+            (_, _, args_offsets) =
+                mkVirtHeapOffsetsWithPadding dflags StdHeader non_voids
+
+            do_pushery !d (arg : args) = do
+                (push, arg_bytes) <- case arg of
+                    (Padding l _) -> return $! pushPadding l
+                    (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)
+                more_push_code <- do_pushery (d + arg_bytes) args
+                return (push `appOL` more_push_code)
+            do_pushery !d [] = do
+                let !n_arg_words = trunc16W $ bytesToWords dflags (d - orig_d)
+                return (unitOL (PACK con n_arg_words))
+
+        -- Push on the stack in the reverse order.
+        do_pushery orig_d (reverse args_offsets)
+
+
+-- -----------------------------------------------------------------------------
+-- Returning an unboxed tuple with one non-void component (the only
+-- case we can handle).
+--
+-- Remember, we don't want to *evaluate* the component that is being
+-- returned, even if it is a pointed type.  We always just return.
+
+unboxedTupleReturn
+    :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList
+unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)
+
+-- -----------------------------------------------------------------------------
+-- Generate code for a tail-call
+
+doTailCall
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> Id
+    -> [AnnExpr' Id DVarSet]
+    -> BcM BCInstrList
+doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args)
+  where
+  do_pushes !d [] reps = do
+        ASSERT( null reps ) return ()
+        (push_fn, sz) <- pushAtom d p (AnnVar fn)
+        dflags <- getDynFlags
+        ASSERT( sz == wordSize dflags ) return ()
+        let slide = mkSlideB dflags (d - init_d + wordSize dflags) (init_d - s)
+        return (push_fn `appOL` (slide `appOL` unitOL ENTER))
+  do_pushes !d args reps = do
+      let (push_apply, n, rest_of_reps) = findPushSeq reps
+          (these_args, rest_of_args) = splitAt n args
+      (next_d, push_code) <- push_seq d these_args
+      dflags <- getDynFlags
+      instrs <- do_pushes (next_d + wordSize dflags) rest_of_args rest_of_reps
+      --                          ^^^ for the PUSH_APPLY_ instruction
+      return (push_code `appOL` (push_apply `consOL` instrs))
+
+  push_seq d [] = return (d, nilOL)
+  push_seq d (arg:args) = do
+    (push_code, sz) <- pushAtom d p arg
+    (final_d, more_push_code) <- push_seq (d + sz) args
+    return (final_d, push_code `appOL` more_push_code)
+
+-- v. similar to CgStackery.findMatch, ToDo: merge
+findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
+findPushSeq (P: P: P: P: P: P: rest)
+  = (PUSH_APPLY_PPPPPP, 6, rest)
+findPushSeq (P: P: P: P: P: rest)
+  = (PUSH_APPLY_PPPPP, 5, rest)
+findPushSeq (P: P: P: P: rest)
+  = (PUSH_APPLY_PPPP, 4, rest)
+findPushSeq (P: P: P: rest)
+  = (PUSH_APPLY_PPP, 3, rest)
+findPushSeq (P: P: rest)
+  = (PUSH_APPLY_PP, 2, rest)
+findPushSeq (P: rest)
+  = (PUSH_APPLY_P, 1, rest)
+findPushSeq (V: rest)
+  = (PUSH_APPLY_V, 1, rest)
+findPushSeq (N: rest)
+  = (PUSH_APPLY_N, 1, rest)
+findPushSeq (F: rest)
+  = (PUSH_APPLY_F, 1, rest)
+findPushSeq (D: rest)
+  = (PUSH_APPLY_D, 1, rest)
+findPushSeq (L: rest)
+  = (PUSH_APPLY_L, 1, rest)
+findPushSeq _
+  = panic "ByteCodeGen.findPushSeq"
+
+-- -----------------------------------------------------------------------------
+-- Case expressions
+
+doCase
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> AnnExpr Id DVarSet
+    -> Id
+    -> [AnnAlt Id DVarSet]
+    -> Maybe Id  -- Just x <=> is an unboxed tuple case with scrut binder,
+                 -- don't enter the result
+    -> BcM BCInstrList
+doCase d s p (_,scrut) bndr alts is_unboxed_tuple
+  | typePrimRep (idType bndr) `lengthExceeds` 1
+  = multiValException
+  | otherwise
+  = do
+     dflags <- getDynFlags
+     let
+        profiling
+          | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags
+          | otherwise = rtsIsProfiled
+
+        -- Top of stack is the return itbl, as usual.
+        -- underneath it is the pointer to the alt_code BCO.
+        -- When an alt is entered, it assumes the returned value is
+        -- on top of the itbl.
+        ret_frame_size_b :: StackDepth
+        ret_frame_size_b = 2 * wordSize dflags
+
+        -- The extra frame we push to save/restor the CCCS when profiling
+        save_ccs_size_b | profiling = 2 * wordSize dflags
+                        | otherwise = 0
+
+        -- An unlifted value gets an extra info table pushed on top
+        -- when it is returned.
+        unlifted_itbl_size_b :: StackDepth
+        unlifted_itbl_size_b | isAlgCase = 0
+                            | otherwise = wordSize dflags
+
+        -- depth of stack after the return value has been pushed
+        d_bndr =
+            d + ret_frame_size_b + wordsToBytes dflags (idSizeW dflags bndr)
+
+        -- depth of stack after the extra info table for an unboxed return
+        -- has been pushed, if any.  This is the stack depth at the
+        -- continuation.
+        d_alts = d_bndr + unlifted_itbl_size_b
+
+        -- Env in which to compile the alts, not including
+        -- any vars bound by the alts themselves
+        p_alts0 = Map.insert bndr d_bndr p
+
+        p_alts = case is_unboxed_tuple of
+                   Just ubx_bndr -> Map.insert ubx_bndr d_bndr p_alts0
+                   Nothing       -> p_alts0
+
+        bndr_ty = idType bndr
+        isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple
+
+        -- given an alt, return a discr and code for it.
+        codeAlt (DEFAULT, _, (_,rhs))
+           = do rhs_code <- schemeE d_alts s p_alts rhs
+                return (NoDiscr, rhs_code)
+
+        codeAlt alt@(_, bndrs, (_,rhs))
+           -- primitive or nullary constructor alt: no need to UNPACK
+           | null real_bndrs = do
+                rhs_code <- schemeE d_alts s p_alts rhs
+                return (my_discr alt, rhs_code)
+           -- If an alt attempts to match on an unboxed tuple or sum, we must
+           -- bail out, as the bytecode compiler can't handle them.
+           -- (See Trac #14608.)
+           | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs
+           = multiValException
+           -- algebraic alt with some binders
+           | otherwise =
+             let (tot_wds, _ptrs_wds, args_offsets) =
+                     mkVirtHeapOffsets dflags NoHeader
+                         [ NonVoid (bcIdPrimRep id, id)
+                         | NonVoid id <- nonVoidIds real_bndrs
+                         ]
+                 size = WordOff tot_wds
+
+                 stack_bot = d_alts + wordsToBytes dflags size
+
+                 -- convert offsets from Sp into offsets into the virtual stack
+                 p' = Map.insertList
+                        [ (arg, stack_bot - ByteOff offset)
+                        | (NonVoid arg, offset) <- args_offsets ]
+                        p_alts
+             in do
+             MASSERT(isAlgCase)
+             rhs_code <- schemeE stack_bot s p' rhs
+             return (my_discr alt,
+                     unitOL (UNPACK (trunc16W size)) `appOL` rhs_code)
+           where
+             real_bndrs = filterOut isTyVar bndrs
+
+        my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
+        my_discr (DataAlt dc, _, _)
+           | isUnboxedTupleCon dc || isUnboxedSumCon dc
+           = multiValException
+           | otherwise
+           = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
+        my_discr (LitAlt l, _, _)
+           = case l of LitNumber LitNumInt i  _  -> DiscrI (fromInteger i)
+                       LitNumber LitNumWord w _  -> DiscrW (fromInteger w)
+                       LitFloat r   -> DiscrF (fromRational r)
+                       LitDouble r  -> DiscrD (fromRational r)
+                       LitChar i    -> DiscrI (ord i)
+                       _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)
+
+        maybe_ncons
+           | not isAlgCase = Nothing
+           | otherwise
+           = case [dc | (DataAlt dc, _, _) <- alts] of
+                []     -> Nothing
+                (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))
+
+        -- the bitmap is relative to stack depth d, i.e. before the
+        -- BCO, info table and return value are pushed on.
+        -- This bit of code is v. similar to buildLivenessMask in CgBindery,
+        -- except that here we build the bitmap from the known bindings of
+        -- things that are pointers, whereas in CgBindery the code builds the
+        -- bitmap from the free slots and unboxed bindings.
+        -- (ToDo: merge?)
+        --
+        -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.
+        -- The bitmap must cover the portion of the stack up to the sequel only.
+        -- Previously we were building a bitmap for the whole depth (d), but we
+        -- really want a bitmap up to depth (d-s).  This affects compilation of
+        -- case-of-case expressions, which is the only time we can be compiling a
+        -- case expression with s /= 0.
+        bitmap_size = trunc16W $ bytesToWords dflags (d - s)
+        bitmap_size' :: Int
+        bitmap_size' = fromIntegral bitmap_size
+        bitmap = intsToReverseBitmap dflags bitmap_size'{-size-}
+                        (sort (filter (< bitmap_size') rel_slots))
+          where
+          binds = Map.toList p
+          -- NB: unboxed tuple cases bind the scrut binder to the same offset
+          -- as one of the alt binders, so we have to remove any duplicates here:
+          rel_slots = nub $ map fromIntegral $ concat (map spread binds)
+          spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]
+                              | otherwise                      = []
+                where rel_offset = trunc16W $ bytesToWords dflags (d - offset)
+
+     alt_stuff <- mapM codeAlt alts
+     alt_final <- mkMultiBranch maybe_ncons alt_stuff
+
+     let
+         alt_bco_name = getName bndr
+         alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts)
+                       0{-no arity-} bitmap_size bitmap True{-is alts-}
+--     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++
+--            "\n      bitmap = " ++ show bitmap) $ do
+
+     scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)
+                           (d + ret_frame_size_b + save_ccs_size_b)
+                           p scrut
+     alt_bco' <- emitBc alt_bco
+     let push_alts
+            | isAlgCase = PUSH_ALTS alt_bco'
+            | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)
+     return (push_alts `consOL` scrut_code)
+
+
+-- -----------------------------------------------------------------------------
+-- Deal with a CCall.
+
+-- Taggedly push the args onto the stack R->L,
+-- deferencing ForeignObj#s and adjusting addrs to point to
+-- payloads in Ptr/Byte arrays.  Then, generate the marshalling
+-- (machine) code for the ccall, and create bytecodes to call that and
+-- then return in the right way.
+
+generateCCall
+    :: StackDepth
+    -> Sequel
+    -> BCEnv
+    -> CCallSpec               -- where to call
+    -> Id                      -- of target, for type info
+    -> [AnnExpr' Id DVarSet]   -- args (atoms)
+    -> BcM BCInstrList
+generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
+ = do
+     dflags <- getDynFlags
+
+     let
+         -- useful constants
+         addr_size_b :: ByteOff
+         addr_size_b = wordSize dflags
+
+         -- Get the args on the stack, with tags and suitably
+         -- dereferenced for the CCall.  For each arg, return the
+         -- depth to the first word of the bits for that arg, and the
+         -- ArgRep of what was actually pushed.
+
+         pargs
+             :: ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]
+         pargs _ [] = return []
+         pargs d (a:az)
+            = let arg_ty = unwrapType (exprType (deAnnotate' a))
+
+              in case tyConAppTyCon_maybe arg_ty of
+                    -- Don't push the FO; instead push the Addr# it
+                    -- contains.
+                    Just t
+                     | t == arrayPrimTyCon || t == mutableArrayPrimTyCon
+                       -> do rest <- pargs (d + addr_size_b) az
+                             code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a
+                             return ((code,AddrRep):rest)
+
+                     | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon
+                       -> do rest <- pargs (d + addr_size_b) az
+                             code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a
+                             return ((code,AddrRep):rest)
+
+                     | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon
+                       -> do rest <- pargs (d + addr_size_b) az
+                             code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a
+                             return ((code,AddrRep):rest)
+
+                    -- Default case: push taggedly, but otherwise intact.
+                    _
+                       -> do (code_a, sz_a) <- pushAtom d p a
+                             rest <- pargs (d + sz_a) az
+                             return ((code_a, atomPrimRep a) : rest)
+
+         -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on
+         -- the stack but then advance it over the headers, so as to
+         -- point to the payload.
+         parg_ArrayishRep
+             :: Word16
+             -> StackDepth
+             -> BCEnv
+             -> AnnExpr' Id DVarSet
+             -> BcM BCInstrList
+         parg_ArrayishRep hdrSize d p a
+            = do (push_fo, _) <- pushAtom d p a
+                 -- The ptr points at the header.  Advance it over the
+                 -- header and then pretend this is an Addr#.
+                 return (push_fo `snocOL` SWIZZLE 0 hdrSize)
+
+     code_n_reps <- pargs d0 args_r_to_l
+     let
+         (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
+         a_reps_sizeW = sum (map (repSizeWords dflags) a_reps_pushed_r_to_l)
+
+         push_args    = concatOL pushs_arg
+         !d_after_args = d0 + wordsToBytes dflags a_reps_sizeW
+         a_reps_pushed_RAW
+            | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
+            = panic "ByteCodeGen.generateCCall: missing or invalid World token?"
+            | otherwise
+            = reverse (tail a_reps_pushed_r_to_l)
+
+         -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
+         -- push_args is the code to do that.
+         -- d_after_args is the stack depth once the args are on.
+
+         -- Get the result rep.
+         (returns_void, r_rep)
+            = case maybe_getCCallReturnRep (idType fn) of
+                 Nothing -> (True,  VoidRep)
+                 Just rr -> (False, rr)
+         {-
+         Because the Haskell stack grows down, the a_reps refer to
+         lowest to highest addresses in that order.  The args for the call
+         are on the stack.  Now push an unboxed Addr# indicating
+         the C function to call.  Then push a dummy placeholder for the
+         result.  Finally, emit a CCALL insn with an offset pointing to the
+         Addr# just pushed, and a literal field holding the mallocville
+         address of the piece of marshalling code we generate.
+         So, just prior to the CCALL insn, the stack looks like this
+         (growing down, as usual):
+
+            <arg_n>
+            ...
+            <arg_1>
+            Addr# address_of_C_fn
+            <placeholder-for-result#> (must be an unboxed type)
+
+         The interpreter then calls the marshall code mentioned
+         in the CCALL insn, passing it (& <placeholder-for-result#>),
+         that is, the addr of the topmost word in the stack.
+         When this returns, the placeholder will have been
+         filled in.  The placeholder is slid down to the sequel
+         depth, and we RETURN.
+
+         This arrangement makes it simple to do f-i-dynamic since the Addr#
+         value is the first arg anyway.
+
+         The marshalling code is generated specifically for this
+         call site, and so knows exactly the (Haskell) stack
+         offsets of the args, fn address and placeholder.  It
+         copies the args to the C stack, calls the stacked addr,
+         and parks the result back in the placeholder.  The interpreter
+         calls it as a normal C call, assuming it has a signature
+            void marshall_code ( StgWord* ptr_to_top_of_stack )
+         -}
+         -- resolve static address
+         maybe_static_target :: Maybe Literal
+         maybe_static_target =
+             case target of
+                 DynamicTarget -> Nothing
+                 StaticTarget _ _ _ False ->
+                   panic "generateCCall: unexpected FFI value import"
+                 StaticTarget _ target _ True ->
+                   Just (LitLabel target mb_size IsFunction)
+                   where
+                      mb_size
+                          | OSMinGW32 <- platformOS (targetPlatform dflags)
+                          , StdCallConv <- cconv
+                          = Just (fromIntegral a_reps_sizeW * wORD_SIZE dflags)
+                          | otherwise
+                          = Nothing
+
+     let
+         is_static = isJust maybe_static_target
+
+         -- Get the arg reps, zapping the leading Addr# in the dynamic case
+         a_reps --  | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
+                | is_static = a_reps_pushed_RAW
+                | otherwise = if null a_reps_pushed_RAW
+                              then panic "ByteCodeGen.generateCCall: dyn with no args"
+                              else tail a_reps_pushed_RAW
+
+         -- push the Addr#
+         (push_Addr, d_after_Addr)
+            | Just machlabel <- maybe_static_target
+            = (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b)
+            | otherwise -- is already on the stack
+            = (nilOL, d_after_args)
+
+         -- Push the return placeholder.  For a call returning nothing,
+         -- this is a V (tag).
+         r_sizeW   = repSizeWords dflags r_rep
+         d_after_r = d_after_Addr + wordsToBytes dflags r_sizeW
+         push_r =
+             if returns_void
+                then nilOL
+                else unitOL (PUSH_UBX (mkDummyLiteral dflags r_rep) (trunc16W r_sizeW))
+
+         -- generate the marshalling code we're going to call
+
+         -- Offset of the next stack frame down the stack.  The CCALL
+         -- instruction needs to describe the chunk of stack containing
+         -- the ccall args to the GC, so it needs to know how large it
+         -- is.  See comment in Interpreter.c with the CCALL instruction.
+         stk_offset   = trunc16W $ bytesToWords dflags (d_after_r - s)
+
+         conv = case cconv of
+           CCallConv -> FFICCall
+           StdCallConv -> FFIStdCall
+           _ -> panic "ByteCodeGen: unexpected calling convention"
+
+     -- the only difference in libffi mode is that we prepare a cif
+     -- describing the call type by calling libffi, and we attach the
+     -- address of this to the CCALL instruction.
+
+
+     let ffires = primRepToFFIType dflags r_rep
+         ffiargs = map (primRepToFFIType dflags) a_reps
+     hsc_env <- getHscEnv
+     token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)
+     recordFFIBc token
+
+     let
+         -- do the call
+         do_call      = unitOL (CCALL stk_offset token flags)
+           where flags = case safety of
+                           PlaySafe          -> 0x0
+                           PlayInterruptible -> 0x1
+                           PlayRisky         -> 0x2
+
+         -- slide and return
+         d_after_r_min_s = bytesToWords dflags (d_after_r - s)
+         wrapup       = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)
+                        `snocOL` RETURN_UBX (toArgRep r_rep)
+         --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $
+     return (
+         push_args `appOL`
+         push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
+         )
+
+primRepToFFIType :: DynFlags -> PrimRep -> FFIType
+primRepToFFIType dflags r
+  = case r of
+     VoidRep     -> FFIVoid
+     IntRep      -> signed_word
+     WordRep     -> unsigned_word
+     Int64Rep    -> FFISInt64
+     Word64Rep   -> FFIUInt64
+     AddrRep     -> FFIPointer
+     FloatRep    -> FFIFloat
+     DoubleRep   -> FFIDouble
+     _           -> panic "primRepToFFIType"
+  where
+    (signed_word, unsigned_word)
+       | wORD_SIZE dflags == 4  = (FFISInt32, FFIUInt32)
+       | wORD_SIZE dflags == 8  = (FFISInt64, FFIUInt64)
+       | otherwise              = panic "primTyDescChar"
+
+-- Make a dummy literal, to be used as a placeholder for FFI return
+-- values on the stack.
+mkDummyLiteral :: DynFlags -> PrimRep -> Literal
+mkDummyLiteral dflags pr
+   = case pr of
+        IntRep    -> mkLitInt dflags 0
+        WordRep   -> mkLitWord dflags 0
+        Int64Rep  -> mkLitInt64 0
+        Word64Rep -> mkLitWord64 0
+        AddrRep   -> LitNullAddr
+        DoubleRep -> LitDouble 0
+        FloatRep  -> LitFloat 0
+        _         -> pprPanic "mkDummyLiteral" (ppr pr)
+
+
+-- Convert (eg)
+--     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
+--                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)
+--
+-- to  Just IntRep
+-- and check that an unboxed pair is returned wherein the first arg is V'd.
+--
+-- Alternatively, for call-targets returning nothing, convert
+--
+--     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld
+--                   -> (# GHC.Prim.State# GHC.Prim.RealWorld #)
+--
+-- to  Nothing
+
+maybe_getCCallReturnRep :: Type -> Maybe PrimRep
+maybe_getCCallReturnRep fn_ty
+   = let
+       (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)
+       r_reps = typePrimRepArgs r_ty
+
+       blargh :: a -- Used at more than one type
+       blargh = pprPanic "maybe_getCCallReturn: can't handle:"
+                         (pprType fn_ty)
+     in
+       case r_reps of
+         []            -> panic "empty typePrimRepArgs"
+         [VoidRep]     -> Nothing
+         [rep]
+           | isGcPtrRep rep -> blargh
+           | otherwise      -> Just rep
+
+                 -- if it was, it would be impossible to create a
+                 -- valid return value placeholder on the stack
+         _             -> blargh
+
+maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])
+-- Detect and extract relevant info for the tagToEnum kludge.
+maybe_is_tagToEnum_call app
+  | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app
+  , Just TagToEnumOp <- isPrimOpId_maybe v
+  = Just (snd arg, extract_constr_Names t)
+  | otherwise
+  = Nothing
+  where
+    extract_constr_Names ty
+           | rep_ty <- unwrapType ty
+           , Just tyc <- tyConAppTyCon_maybe rep_ty
+           , isDataTyCon tyc
+           = map (getName . dataConWorkId) (tyConDataCons tyc)
+           -- NOTE: use the worker name, not the source name of
+           -- the DataCon.  See DataCon.hs for details.
+           | otherwise
+           = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)
+
+{- -----------------------------------------------------------------------------
+Note [Implementing tagToEnum#]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(implement_tagToId arg names) compiles code which takes an argument
+'arg', (call it i), and enters the i'th closure in the supplied list
+as a consequence.  The [Name] is a list of the constructors of this
+(enumeration) type.
+
+The code we generate is this:
+                push arg
+                push bogus-word
+
+                TESTEQ_I 0 L1
+                  PUSH_G <lbl for first data con>
+                  JMP L_Exit
+
+        L1:     TESTEQ_I 1 L2
+                  PUSH_G <lbl for second data con>
+                  JMP L_Exit
+        ...etc...
+        Ln:     TESTEQ_I n L_fail
+                  PUSH_G <lbl for last data con>
+                  JMP L_Exit
+
+        L_fail: CASEFAIL
+
+        L_exit: SLIDE 1 n
+                ENTER
+
+The 'bogus-word' push is because TESTEQ_I expects the top of the stack
+to have an info-table, and the next word to have the value to be
+tested.  This is very weird, but it's the way it is right now.  See
+Interpreter.c.  We don't acutally need an info-table here; we just
+need to have the argument to be one-from-top on the stack, hence pushing
+a 1-word null. See Trac #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)
+
+-- Trac #12128:
+-- A case expression can be an atom because empty cases evaluate to bottom.
+-- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs
+atomPrimRep (AnnCase _ _ ty _)      = ASSERT(typePrimRep ty == [LiftedRep]) LiftedRep
+atomPrimRep (AnnCoercion {})        = VoidRep
+atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))
+
+atomRep :: AnnExpr' Id ann -> ArgRep
+atomRep e = toArgRep (atomPrimRep e)
+
+-- | Let szsw be the sizes in bytes of some items pushed onto the stack, which
+-- has initial depth @original_depth@.  Return the values which the stack
+-- environment should map these items to.
+mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]
+mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)
+
+typeArgRep :: Type -> ArgRep
+typeArgRep = toArgRep . typePrimRep1
+
+-- -----------------------------------------------------------------------------
+-- The bytecode generator's monad
+
+data BcM_State
+   = BcM_State
+        { bcm_hsc_env :: HscEnv
+        , uniqSupply  :: UniqSupply      -- for generating fresh variable names
+        , thisModule  :: Module          -- current module (for breakpoints)
+        , nextlabel   :: Word16          -- for generating local labels
+        , ffis        :: [FFIInfo]       -- ffi info blocks, to free later
+                                         -- Should be free()d when it is GCd
+        , modBreaks   :: Maybe ModBreaks -- info about breakpoints
+        , breakInfo   :: IntMap CgBreakInfo
+        , topStrings  :: IdEnv (RemotePtr ()) -- top-level string literals
+          -- See Note [generating code for top-level string literal bindings].
+        }
+
+newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
+
+ioToBc :: IO a -> BcM a
+ioToBc io = BcM $ \st -> do
+  x <- io
+  return (st, x)
+
+runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks
+      -> IdEnv (RemotePtr ())
+      -> BcM r
+      -> IO (BcM_State, r)
+runBc hsc_env us this_mod modBreaks topStrings (BcM m)
+   = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings)
+
+thenBc :: BcM a -> (a -> BcM b) -> BcM b
+thenBc (BcM expr) cont = BcM $ \st0 -> do
+  (st1, q) <- expr st0
+  let BcM k = cont q
+  (st2, r) <- k st1
+  return (st2, r)
+
+thenBc_ :: BcM a -> BcM b -> BcM b
+thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do
+  (st1, _) <- expr st0
+  (st2, r) <- cont st1
+  return (st2, r)
+
+returnBc :: a -> BcM a
+returnBc result = BcM $ \st -> (return (st, result))
+
+instance Functor BcM where
+    fmap = liftM
+
+instance Applicative BcM where
+    pure = returnBc
+    (<*>) = ap
+    (*>) = thenBc_
+
+instance Monad BcM where
+  (>>=) = thenBc
+  (>>)  = (*>)
+
+instance HasDynFlags BcM where
+    getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))
+
+getHscEnv :: BcM HscEnv
+getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)
+
+emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
+emitBc bco
+  = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
+
+recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
+recordFFIBc a
+  = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
+
+getLabelBc :: BcM Word16
+getLabelBc
+  = BcM $ \st -> do let nl = nextlabel st
+                    when (nl == maxBound) $
+                        panic "getLabelBc: Ran out of labels"
+                    return (st{nextlabel = nl + 1}, nl)
+
+getLabelsBc :: Word16 -> BcM [Word16]
+getLabelsBc n
+  = BcM $ \st -> let ctr = nextlabel st
+                 in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
+
+getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))
+getCCArray = BcM $ \st ->
+  let breaks = expectJust "ByteCodeGen.getCCArray" $ modBreaks st in
+  return (st, modBreaks_ccs breaks)
+
+
+newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()
+newBreakInfo ix info = BcM $ \st ->
+  return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())
+
+newUnique :: BcM Unique
+newUnique = BcM $
+   \st -> case takeUniqFromSupply (uniqSupply st) of
+             (uniq, us) -> let newState = st { uniqSupply = us }
+                           in  return (newState, uniq)
+
+getCurrentModule :: BcM Module
+getCurrentModule = BcM $ \st -> return (st, thisModule st)
+
+getTopStrings :: BcM (IdEnv (RemotePtr ()))
+getTopStrings = BcM $ \st -> return (st, topStrings st)
+
+newId :: Type -> BcM Id
+newId ty = do
+    uniq <- newUnique
+    return $ mkSysLocal tickFS uniq ty
+
+tickFS :: FastString
+tickFS = fsLit "ticked"
diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/ByteCodeInstr.hs
@@ -0,0 +1,368 @@
+{-# LANGUAGE CPP, MagicHash #-}
+{-# OPTIONS_GHC -funbox-strict-fields #-}
+--
+--  (c) The University of Glasgow 2002-2006
+--
+
+-- | ByteCodeInstrs: Bytecode instruction definitions
+module ByteCodeInstr (
+        BCInstr(..), ProtoBCO(..), bciStackUse,
+  ) where
+
+#include "HsVersions.h"
+#include "../includes/MachDeps.h"
+
+import GhcPrelude
+
+import ByteCodeTypes
+import GHCi.RemoteTypes
+import GHCi.FFI (C_ffi_cif)
+import StgCmmLayout     ( ArgRep(..) )
+import PprCore
+import Outputable
+import FastString
+import Name
+import Unique
+import Id
+import CoreSyn
+import Literal
+import DataCon
+import VarSet
+import PrimOp
+import SMRep
+
+import Data.Word
+import GHC.Stack.CCS (CostCentre)
+
+-- ----------------------------------------------------------------------------
+-- Bytecode instructions
+
+data ProtoBCO a
+   = ProtoBCO {
+        protoBCOName       :: a,          -- name, in some sense
+        protoBCOInstrs     :: [BCInstr],  -- instrs
+        -- arity and GC info
+        protoBCOBitmap     :: [StgWord],
+        protoBCOBitmapSize :: Word16,
+        protoBCOArity      :: Int,
+        -- what the BCO came from
+        protoBCOExpr       :: Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),
+        -- malloc'd pointers
+        protoBCOFFIs       :: [FFIInfo]
+   }
+
+type LocalLabel = Word16
+
+data BCInstr
+   -- Messing with the stack
+   = STKCHECK  Word
+
+   -- Push locals (existing bits of the stack)
+   | PUSH_L    !Word16{-offset-}
+   | PUSH_LL   !Word16 !Word16{-2 offsets-}
+   | PUSH_LLL  !Word16 !Word16 !Word16{-3 offsets-}
+
+   -- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e.,
+   -- the stack will grow by 8, 16 or 32 bits)
+   | PUSH8  !Word16
+   | PUSH16 !Word16
+   | PUSH32 !Word16
+
+   -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the
+   -- value will take the whole word on the stack (i.e., the stack will gorw by
+   -- a word)
+   -- This is useful when extracting a packed constructor field for further use.
+   -- Currently we expect all values on the stack to take full words, except for
+   -- the ones used for PACK (i.e., actually constracting new data types, in
+   -- which case we use PUSH{8,16,32})
+   | PUSH8_W  !Word16
+   | PUSH16_W !Word16
+   | PUSH32_W !Word16
+
+   -- Push a ptr  (these all map to PUSH_G really)
+   | PUSH_G       Name
+   | PUSH_PRIMOP  PrimOp
+   | PUSH_BCO     (ProtoBCO Name)
+
+   -- Push an alt continuation
+   | PUSH_ALTS          (ProtoBCO Name)
+   | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
+
+   -- Pushing 8, 16 and 32 bits of padding (for constructors).
+   | PUSH_PAD8
+   | PUSH_PAD16
+   | PUSH_PAD32
+
+   -- Pushing literals
+   | PUSH_UBX8  Literal
+   | PUSH_UBX16 Literal
+   | PUSH_UBX32 Literal
+   | PUSH_UBX   Literal Word16
+        -- push this int/float/double/addr, on the stack. Word16
+        -- is # of words to copy from literal pool.  Eitherness reflects
+        -- the difficulty of dealing with MachAddr here, mostly due to
+        -- the excessive (and unnecessary) restrictions imposed by the
+        -- designers of the new Foreign library.  In particular it is
+        -- quite impossible to convert an Addr to any other integral
+        -- type, and it appears impossible to get hold of the bits of
+        -- an addr, even though we need to assemble BCOs.
+
+   -- various kinds of application
+   | PUSH_APPLY_N
+   | PUSH_APPLY_V
+   | PUSH_APPLY_F
+   | PUSH_APPLY_D
+   | PUSH_APPLY_L
+   | PUSH_APPLY_P
+   | PUSH_APPLY_PP
+   | PUSH_APPLY_PPP
+   | PUSH_APPLY_PPPP
+   | PUSH_APPLY_PPPPP
+   | PUSH_APPLY_PPPPPP
+
+   | SLIDE     Word16{-this many-} Word16{-down by this much-}
+
+   -- To do with the heap
+   | ALLOC_AP  !Word16 -- make an AP with this many payload words
+   | ALLOC_AP_NOUPD !Word16 -- make an AP_NOUPD with this many payload words
+   | ALLOC_PAP !Word16 !Word16 -- make a PAP with this arity / payload words
+   | MKAP      !Word16{-ptr to AP is this far down stack-} !Word16{-number of words-}
+   | MKPAP     !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-}
+   | UNPACK    !Word16 -- unpack N words from t.o.s Constr
+   | PACK      DataCon !Word16
+                        -- after assembly, the DataCon is an index into the
+                        -- itbl array
+   -- For doing case trees
+   | LABEL     LocalLabel
+   | TESTLT_I  Int    LocalLabel
+   | TESTEQ_I  Int    LocalLabel
+   | TESTLT_W  Word   LocalLabel
+   | TESTEQ_W  Word   LocalLabel
+   | TESTLT_F  Float  LocalLabel
+   | TESTEQ_F  Float  LocalLabel
+   | TESTLT_D  Double LocalLabel
+   | TESTEQ_D  Double LocalLabel
+
+   -- The Word16 value is a constructor number and therefore
+   -- stored in the insn stream rather than as an offset into
+   -- the literal pool.
+   | TESTLT_P  Word16 LocalLabel
+   | TESTEQ_P  Word16 LocalLabel
+
+   | CASEFAIL
+   | JMP              LocalLabel
+
+   -- For doing calls to C (via glue code generated by libffi)
+   | CCALL            Word16    -- stack frame size
+                      (RemotePtr C_ffi_cif) -- addr of the glue code
+                      Word16    -- flags.
+                                --
+                                -- 0x1: call is interruptible
+                                -- 0x2: call is unsafe
+                                --
+                                -- (XXX: inefficient, but I don't know
+                                -- what the alignment constraints are.)
+
+   -- For doing magic ByteArray passing to foreign calls
+   | SWIZZLE          Word16 -- to the ptr N words down the stack,
+                      Word16 -- add M (interpreted as a signed 16-bit entity)
+
+   -- To Infinity And Beyond
+   | ENTER
+   | RETURN             -- return a lifted value
+   | RETURN_UBX ArgRep -- return an unlifted value, here's its rep
+
+   -- Breakpoints
+   | BRK_FUN          Word16 Unique (RemotePtr CostCentre)
+
+-- -----------------------------------------------------------------------------
+-- Printing bytecode instructions
+
+instance Outputable a => Outputable (ProtoBCO a) where
+   ppr (ProtoBCO name instrs bitmap bsize arity origin ffis)
+      = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
+                <+> text (show ffis) <> colon)
+        $$ nest 3 (case origin of
+                      Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';'))
+                                                       (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}'
+                      Right rhs -> pprCoreExprShort (deAnnotate rhs))
+        $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap)
+        $$ nest 3 (vcat (map ppr instrs))
+
+-- Print enough of the Core expression to enable the reader to find
+-- the expression in the -ddump-prep output.  That is, we need to
+-- include at least a binder.
+
+pprCoreExprShort :: CoreExpr -> SDoc
+pprCoreExprShort expr@(Lam _ _)
+  = let
+        (bndrs, _) = collectBinders expr
+    in
+    char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..."
+
+pprCoreExprShort (Case _expr var _ty _alts)
+ = text "case of" <+> ppr var
+
+pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ..."))
+pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ..."))
+
+pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e
+pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T"
+
+pprCoreExprShort e = pprCoreExpr e
+
+pprCoreAltShort :: CoreAlt -> SDoc
+pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr
+
+instance Outputable BCInstr where
+   ppr (STKCHECK n)          = text "STKCHECK" <+> ppr n
+   ppr (PUSH_L offset)       = text "PUSH_L  " <+> ppr offset
+   ppr (PUSH_LL o1 o2)       = text "PUSH_LL " <+> ppr o1 <+> ppr o2
+   ppr (PUSH_LLL o1 o2 o3)   = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3
+   ppr (PUSH8  offset)       = text "PUSH8  " <+> ppr offset
+   ppr (PUSH16 offset)       = text "PUSH16  " <+> ppr offset
+   ppr (PUSH32 offset)       = text "PUSH32  " <+> ppr offset
+   ppr (PUSH8_W  offset)     = text "PUSH8_W  " <+> ppr offset
+   ppr (PUSH16_W offset)     = text "PUSH16_W  " <+> ppr offset
+   ppr (PUSH32_W offset)     = text "PUSH32_W  " <+> ppr offset
+   ppr (PUSH_G nm)           = text "PUSH_G  " <+> ppr nm
+   ppr (PUSH_PRIMOP op)      = text "PUSH_G  " <+> text "GHC.PrimopWrappers."
+                                               <> ppr op
+   ppr (PUSH_BCO bco)        = hang (text "PUSH_BCO") 2 (ppr bco)
+   ppr (PUSH_ALTS bco)       = hang (text "PUSH_ALTS") 2 (ppr bco)
+   ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)
+
+   ppr PUSH_PAD8             = text "PUSH_PAD8"
+   ppr PUSH_PAD16            = text "PUSH_PAD16"
+   ppr PUSH_PAD32            = text "PUSH_PAD32"
+
+   ppr (PUSH_UBX8  lit)      = text "PUSH_UBX8" <+> ppr lit
+   ppr (PUSH_UBX16 lit)      = text "PUSH_UBX16" <+> ppr lit
+   ppr (PUSH_UBX32 lit)      = text "PUSH_UBX32" <+> ppr lit
+   ppr (PUSH_UBX lit nw)     = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
+   ppr PUSH_APPLY_N          = text "PUSH_APPLY_N"
+   ppr PUSH_APPLY_V          = text "PUSH_APPLY_V"
+   ppr PUSH_APPLY_F          = text "PUSH_APPLY_F"
+   ppr PUSH_APPLY_D          = text "PUSH_APPLY_D"
+   ppr PUSH_APPLY_L          = text "PUSH_APPLY_L"
+   ppr PUSH_APPLY_P          = text "PUSH_APPLY_P"
+   ppr PUSH_APPLY_PP         = text "PUSH_APPLY_PP"
+   ppr PUSH_APPLY_PPP        = text "PUSH_APPLY_PPP"
+   ppr PUSH_APPLY_PPPP       = text "PUSH_APPLY_PPPP"
+   ppr PUSH_APPLY_PPPPP      = text "PUSH_APPLY_PPPPP"
+   ppr PUSH_APPLY_PPPPPP     = text "PUSH_APPLY_PPPPPP"
+
+   ppr (SLIDE n d)           = text "SLIDE   " <+> ppr n <+> ppr d
+   ppr (ALLOC_AP sz)         = text "ALLOC_AP   " <+> ppr sz
+   ppr (ALLOC_AP_NOUPD sz)   = text "ALLOC_AP_NOUPD   " <+> ppr sz
+   ppr (ALLOC_PAP arity sz)  = text "ALLOC_PAP   " <+> ppr arity <+> ppr sz
+   ppr (MKAP offset sz)      = text "MKAP    " <+> ppr sz <+> text "words,"
+                                               <+> ppr offset <+> text "stkoff"
+   ppr (MKPAP offset sz)     = text "MKPAP   " <+> ppr sz <+> text "words,"
+                                               <+> ppr offset <+> text "stkoff"
+   ppr (UNPACK sz)           = text "UNPACK  " <+> ppr sz
+   ppr (PACK dcon sz)        = text "PACK    " <+> ppr dcon <+> ppr sz
+   ppr (LABEL     lab)       = text "__"       <> ppr lab <> colon
+   ppr (TESTLT_I  i lab)     = text "TESTLT_I" <+> int i <+> text "__" <> ppr lab
+   ppr (TESTEQ_I  i lab)     = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab
+   ppr (TESTLT_W  i lab)     = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab
+   ppr (TESTEQ_W  i lab)     = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab
+   ppr (TESTLT_F  f lab)     = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab
+   ppr (TESTEQ_F  f lab)     = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab
+   ppr (TESTLT_D  d lab)     = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab
+   ppr (TESTEQ_D  d lab)     = text "TESTEQ_D" <+> double d <+> text "__" <> ppr lab
+   ppr (TESTLT_P  i lab)     = text "TESTLT_P" <+> ppr i <+> text "__" <> ppr lab
+   ppr (TESTEQ_P  i lab)     = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab
+   ppr CASEFAIL              = text "CASEFAIL"
+   ppr (JMP lab)             = text "JMP"      <+> ppr lab
+   ppr (CCALL off marshall_addr flags) = text "CCALL   " <+> ppr off
+                                                <+> text "marshall code at"
+                                               <+> text (show marshall_addr)
+                                               <+> (case flags of
+                                                      0x1 -> text "(interruptible)"
+                                                      0x2 -> text "(unsafe)"
+                                                      _   -> empty)
+   ppr (SWIZZLE stkoff n)    = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
+                                               <+> text "by" <+> ppr n
+   ppr ENTER                 = text "ENTER"
+   ppr RETURN                = text "RETURN"
+   ppr (RETURN_UBX pk)       = text "RETURN_UBX  " <+> ppr pk
+   ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"
+
+-- -----------------------------------------------------------------------------
+-- The stack use, in words, of each bytecode insn.  These _must_ be
+-- correct, or overestimates of reality, to be safe.
+
+-- NOTE: we aggregate the stack use from case alternatives too, so that
+-- we can do a single stack check at the beginning of a function only.
+
+-- This could all be made more accurate by keeping track of a proper
+-- stack high water mark, but it doesn't seem worth the hassle.
+
+protoBCOStackUse :: ProtoBCO a -> Word
+protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))
+
+bciStackUse :: BCInstr -> Word
+bciStackUse STKCHECK{}            = 0
+bciStackUse PUSH_L{}              = 1
+bciStackUse PUSH_LL{}             = 2
+bciStackUse PUSH_LLL{}            = 3
+bciStackUse PUSH8{}               = 1  -- overapproximation
+bciStackUse PUSH16{}              = 1  -- overapproximation
+bciStackUse PUSH32{}              = 1  -- overapproximation on 64bit arch
+bciStackUse PUSH8_W{}             = 1  -- takes exactly 1 word
+bciStackUse PUSH16_W{}            = 1  -- takes exactly 1 word
+bciStackUse PUSH32_W{}            = 1  -- takes exactly 1 word
+bciStackUse PUSH_G{}              = 1
+bciStackUse PUSH_PRIMOP{}         = 1
+bciStackUse PUSH_BCO{}            = 1
+bciStackUse (PUSH_ALTS bco)       = 2 + protoBCOStackUse bco
+bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
+bciStackUse (PUSH_PAD8)           = 1  -- overapproximation
+bciStackUse (PUSH_PAD16)          = 1  -- overapproximation
+bciStackUse (PUSH_PAD32)          = 1  -- overapproximation on 64bit arch
+bciStackUse (PUSH_UBX8 _)         = 1  -- overapproximation
+bciStackUse (PUSH_UBX16 _)        = 1  -- overapproximation
+bciStackUse (PUSH_UBX32 _)        = 1  -- overapproximation on 64bit arch
+bciStackUse (PUSH_UBX _ nw)       = fromIntegral nw
+bciStackUse PUSH_APPLY_N{}        = 1
+bciStackUse PUSH_APPLY_V{}        = 1
+bciStackUse PUSH_APPLY_F{}        = 1
+bciStackUse PUSH_APPLY_D{}        = 1
+bciStackUse PUSH_APPLY_L{}        = 1
+bciStackUse PUSH_APPLY_P{}        = 1
+bciStackUse PUSH_APPLY_PP{}       = 1
+bciStackUse PUSH_APPLY_PPP{}      = 1
+bciStackUse PUSH_APPLY_PPPP{}     = 1
+bciStackUse PUSH_APPLY_PPPPP{}    = 1
+bciStackUse PUSH_APPLY_PPPPPP{}   = 1
+bciStackUse ALLOC_AP{}            = 1
+bciStackUse ALLOC_AP_NOUPD{}      = 1
+bciStackUse ALLOC_PAP{}           = 1
+bciStackUse (UNPACK sz)           = fromIntegral sz
+bciStackUse LABEL{}               = 0
+bciStackUse TESTLT_I{}            = 0
+bciStackUse TESTEQ_I{}            = 0
+bciStackUse TESTLT_W{}            = 0
+bciStackUse TESTEQ_W{}            = 0
+bciStackUse TESTLT_F{}            = 0
+bciStackUse TESTEQ_F{}            = 0
+bciStackUse TESTLT_D{}            = 0
+bciStackUse TESTEQ_D{}            = 0
+bciStackUse TESTLT_P{}            = 0
+bciStackUse TESTEQ_P{}            = 0
+bciStackUse CASEFAIL{}            = 0
+bciStackUse JMP{}                 = 0
+bciStackUse ENTER{}               = 0
+bciStackUse RETURN{}              = 0
+bciStackUse RETURN_UBX{}          = 1
+bciStackUse CCALL{}               = 0
+bciStackUse SWIZZLE{}             = 0
+bciStackUse BRK_FUN{}             = 0
+
+-- These insns actually reduce stack use, but we need the high-tide level,
+-- so can't use this info.  Not that it matters much.
+bciStackUse SLIDE{}               = 0
+bciStackUse MKAP{}                = 0
+bciStackUse MKPAP{}               = 0
+bciStackUse PACK{}                = 1 -- worst case is PACK 0 words
diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/ghci/ByteCodeItbls.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/ByteCodeItbls.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}
+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
+--
+--  (c) The University of Glasgow 2002-2006
+--
+
+-- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes
+module ByteCodeItbls ( mkITbls ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import ByteCodeTypes
+import GHCi
+import DynFlags
+import HscTypes
+import Name             ( Name, getName )
+import NameEnv
+import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )
+import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
+import RepType
+import StgCmmLayout     ( mkVirtConstrSizes )
+import StgCmmClosure    ( tagForCon, NonVoid (..) )
+import Util
+import Panic
+
+{-
+  Manufacturing of info tables for DataCons
+-}
+
+-- Make info tables for the data decls in this module
+mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv
+mkITbls hsc_env tcs =
+  foldr plusNameEnv emptyNameEnv <$>
+    mapM (mkITbl hsc_env) (filter isDataTyCon tcs)
+ where
+  mkITbl :: HscEnv -> TyCon -> IO ItblEnv
+  mkITbl hsc_env tc
+    | dcs `lengthIs` n -- paranoia; this is an assertion.
+    = make_constr_itbls hsc_env dcs
+       where
+          dcs = tyConDataCons tc
+          n   = tyConFamilySize tc
+  mkITbl _ _ = panic "mkITbl"
+
+mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv
+mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]
+
+-- Assumes constructors are numbered from zero, not one
+make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv
+make_constr_itbls hsc_env cons =
+  mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])
+ where
+  dflags = hsc_dflags hsc_env
+
+  mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)
+  mk_itbl dcon conNo = do
+     let rep_args = [ NonVoid prim_rep
+                    | arg <- dataConRepArgTys dcon
+                    , prim_rep <- typePrimRep arg ]
+
+         (tot_wds, ptr_wds) =
+             mkVirtConstrSizes dflags rep_args
+
+         ptrs'  = ptr_wds
+         nptrs' = tot_wds - ptr_wds
+         nptrs_really
+            | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs'
+            | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs'
+
+         descr = dataConIdentity dcon
+
+     r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really
+                              conNo (tagForCon dflags dcon) descr)
+     return (getName dcon, ItblPtr r)
diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/ByteCodeLink.hs
@@ -0,0 +1,185 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# 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 send a bug report to:"
+                , "  glasgow-haskell-bugs@haskell.org"
+                ])
+
+
+nameToCLabel :: Name -> String -> FastString
+nameToCLabel n suffix = mkFastString label
+  where
+    encodeZ = zString . zEncodeFS
+    (Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n
+    packagePart = encodeZ (unitIdFS pkgKey)
+    modulePart  = encodeZ (moduleNameFS modName)
+    occPart     = encodeZ (occNameFS (nameOccName n))
+
+    label = concat
+        [ if pkgKey == mainUnitId then "" else packagePart ++ "_"
+        , modulePart
+        , '_':occPart
+        , '_':suffix
+        ]
+
+
+primopToCLabel :: PrimOp -> String -> String
+primopToCLabel primop suffix = concat
+    [ "ghczmprim_GHCziPrimopWrappers_"
+    , zString (zEncodeFS (occNameFS (primOpOcc primop)))
+    , '_':suffix
+    ]
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/Debugger.hs
@@ -0,0 +1,232 @@
+{-# LANGUAGE MagicHash #-}
+
+-----------------------------------------------------------------------------
+--
+-- GHCi Interactive debugging commands
+--
+-- Pepe Iborra (supported by Google SoC) 2006
+--
+-- ToDo: lots of violation of layering here.  This module should
+-- decide whether it is above the GHC API (import GHC and nothing
+-- else) or below it.
+--
+-----------------------------------------------------------------------------
+
+module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
+
+import GhcPrelude
+
+import Linker
+import RtClosureInspect
+
+import GHCi
+import GHCi.RemoteTypes
+import GhcMonad
+import HscTypes
+import Id
+import IfaceSyn ( showToHeader )
+import IfaceEnv( newInteractiveBinder )
+import Name
+import Var hiding ( varName )
+import VarSet
+import UniqSet
+import Type
+import GHC
+import Outputable
+import PprTyThing
+import ErrUtils
+import MonadUtils
+import DynFlags
+import Exception
+
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Data.IORef
+
+-------------------------------------
+-- | The :print & friends commands
+-------------------------------------
+pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()
+pprintClosureCommand bindThings force str = do
+  tythings <- (catMaybes . concat) `liftM`
+                 mapM (\w -> GHC.parseName w >>=
+                                mapM GHC.lookupName)
+                      (words str)
+  let ids = [id | AnId id <- tythings]
+
+  -- Obtain the terms and the recovered type information
+  (subst, terms) <- mapAccumLM go emptyTCvSubst ids
+
+  -- Apply the substitutions obtained after recovering the types
+  modifySession $ \hsc_env ->
+    hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}
+
+  -- Finally, print the Terms
+  unqual  <- GHC.getPrintUnqual
+  docterms <- mapM showTerm terms
+  dflags <- getDynFlags
+  liftIO $ (printOutputForUser dflags unqual . vcat)
+           (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
+                    ids
+                    docterms)
+ where
+   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
+   go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term)
+   go subst id = do
+       let id' = id `setIdType` substTy subst (idType id)
+       term_    <- GHC.obtainTermFromId maxBound force id'
+       term     <- tidyTermTyVars term_
+       term'    <- if bindThings &&
+                      (not (isUnliftedType (termType term)))
+                     then bindSuspensions term
+                     else return term
+     -- Before leaving, we compare the type obtained to see if it's more specific
+     --  Then, we extract a substitution,
+     --  mapping the old tyvars to the reconstructed types.
+       let reconstructed_type = termType term
+       hsc_env <- getSession
+       case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of
+         Nothing     -> return (subst, term')
+         Just subst' -> do { dflags <- GHC.getSessionDynFlags
+                           ; liftIO $
+                               dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"
+                                 (fsep $ [text "RTTI Improvement for", ppr id,
+                                  text "is the substitution:" , ppr subst'])
+                           ; return (subst `unionTCvSubst` subst', term')}
+
+   tidyTermTyVars :: GhcMonad m => Term -> m Term
+   tidyTermTyVars t =
+     withSession $ \hsc_env -> do
+     let env_tvs      = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env
+         my_tvs       = termTyCoVars t
+         tvs          = env_tvs `minusVarSet` my_tvs
+         tyvarOccName = nameOccName . tyVarName
+         tidyEnv      = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs))
+           -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv
+           -- forgets the ordering immediately by creating an env
+                        , getUniqSet $ env_tvs `intersectVarSet` my_tvs)
+     return $ mapTermType (snd . tidyOpenType tidyEnv) t
+
+-- | Give names, and bind in the interactive environment, to all the suspensions
+--   included (inductively) in a term
+bindSuspensions :: GhcMonad m => Term -> m Term
+bindSuspensions t = do
+      hsc_env <- getSession
+      inScope <- GHC.getBindings
+      let ictxt        = hsc_IC hsc_env
+          prefix       = "_t"
+          alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
+          availNames   = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
+      availNames_var  <- liftIO $ newIORef availNames
+      (t', stuff)     <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t
+      let (names, tys, fhvs) = unzip3 stuff
+      let ids = [ mkVanillaGlobal name ty
+                | (name,ty) <- zip names tys]
+          new_ic = extendInteractiveContextWithIds ictxt ids
+      liftIO $ extendLinkEnv (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"
+           _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
+           txt_ <- withExtendedLinkEnv [(bname, fhv)]
+                                       (GHC.compileExprRemote expr)
+           let myprec = 10 -- application precedence. TODO Infix constructors
+           txt <- liftIO $ evalString hsc_env txt_
+           if not (null txt) then
+             return $ Just $ cparen (prec >= myprec && needsParens txt)
+                                    (text txt)
+            else return Nothing
+         `gfinally` do
+           setSession hsc_env
+           GHC.setSessionDynFlags dflags
+  cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
+      cPprShowable prec t{ty=new_ty}
+  cPprShowable _ _ = return Nothing
+
+  needsParens ('"':_) = False   -- some simple heuristics to see whether parens
+                                -- are redundant in an arbitrary Show output
+  needsParens ('(':_) = False
+  needsParens txt = ' ' `elem` txt
+
+
+  bindToFreshName hsc_env ty userName = do
+    name <- newGrimName hsc_env userName
+    let id       = mkVanillaGlobal name ty
+        new_ic   = extendInteractiveContextWithIds (hsc_IC hsc_env) [id]
+    return (hsc_env {hsc_IC = new_ic }, name)
+
+--    Create new uniques and give them sequentially numbered names
+newGrimName :: MonadIO m => HscEnv -> String -> m Name
+newGrimName hsc_env userName
+  = liftIO (newInteractiveBinder hsc_env occ noSrcSpan)
+  where
+    occ = mkOccName varName userName
+
+pprTypeAndContents :: GhcMonad m => Id -> m SDoc
+pprTypeAndContents id = do
+  dflags  <- GHC.getSessionDynFlags
+  let pcontents = gopt Opt_PrintBindContents dflags
+      pprdId    = (pprTyThing showToHeader . AnId) id
+  if pcontents
+    then do
+      let depthBound = 100
+      -- If the value is an exception, make sure we catch it and
+      -- show the exception, rather than propagating the exception out.
+      e_term <- gtry $ GHC.obtainTermFromId depthBound False id
+      docs_term <- case e_term of
+                      Right term -> showTerm term
+                      Left  exn  -> return (text "*** Exception:" <+>
+                                            text (show (exn :: SomeException)))
+      return $ pprdId <+> equals <+> docs_term
+    else return pprdId
diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/GHCi.hs
@@ -0,0 +1,667 @@
+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-}
+
+--
+-- | Interacting with the interpreter, whether it is running on an
+-- external process or in the current process.
+--
+module GHCi
+  ( -- * High-level interface to the interpreter
+    evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)
+  , resumeStmt
+  , abandonStmt
+  , evalIO
+  , evalString
+  , evalStringToIOString
+  , mallocData
+  , createBCOs
+  , addSptEntry
+  , mkCostCentres
+  , costCentreStackInfo
+  , newBreakArray
+  , enableBreakpoint
+  , breakpointStatus
+  , getBreakpointVar
+  , getClosure
+  , seqHValue
+
+  -- * The object-code linker
+  , initObjLinker
+  , lookupSymbol
+  , lookupClosure
+  , loadDLL
+  , loadArchive
+  , loadObj
+  , unloadObj
+  , addLibrarySearchPath
+  , removeLibrarySearchPath
+  , resolveObjs
+  , findSystemLibrary
+
+  -- * Lower-level API using messages
+  , iservCmd, Message(..), withIServ, stopIServ
+  , iservCall, readIServ, writeIServ
+  , purgeLookupSymbolCache
+  , freeHValueRefs
+  , mkFinalizedHValue
+  , wormhole, wormholeRef
+  , mkEvalOpts
+  , fromEvalResult
+  ) where
+
+import GhcPrelude
+
+import GHCi.Message
+#if defined(GHCI)
+import GHCi.Run
+#endif
+import GHCi.RemoteTypes
+import GHCi.ResolvedBCO
+import GHCi.BreakArray (BreakArray)
+import Fingerprint
+import HscTypes
+import UniqFM
+import Panic
+import DynFlags
+import ErrUtils
+import Outputable
+import Exception
+import BasicTypes
+import FastString
+import Util
+import Hooks
+
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Binary
+import Data.Binary.Put
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as LB
+import Data.IORef
+import Foreign hiding (void)
+import GHC.Exts.Heap
+import GHC.Stack.CCS (CostCentre,CostCentreStack)
+import System.Exit
+import Data.Maybe
+import GHC.IO.Handle.Types (Handle)
+#if defined(mingw32_HOST_OS)
+import Foreign.C
+import GHC.IO.Handle.FD (fdToHandle)
+#else
+import System.Posix as Posix
+#endif
+import System.Directory
+import System.Process
+import GHC.Conc (getNumProcessors, pseq, par)
+
+{- Note [Remote GHCi]
+
+When the flag -fexternal-interpreter is given to GHC, interpreted code
+is run in a separate process called iserv, and we communicate with the
+external process over a pipe using Binary-encoded messages.
+
+Motivation
+~~~~~~~~~~
+
+When the interpreted code is running in a separate process, it can
+use a different "way", e.g. profiled or dynamic.  This means
+
+- compiling Template Haskell code with -prof does not require
+  building the code without -prof first
+
+- when GHC itself is profiled, it can interpret unprofiled code,
+  and the same applies to dynamic linking.
+
+- An unprofiled GHCi can load and run profiled code, which means it
+  can use the stack-trace functionality provided by profiling without
+  taking the performance hit on the compiler that profiling would
+  entail.
+
+For other reasons see RemoteGHCi 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://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/ExternalInterpreter
+  * Note [External GHCi pointers] in compiler/ghci/GHCi.hs
+  * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs
+-}
+
+#if !defined(GHCI)
+needExtInt :: IO a
+needExtInt = throwIO
+  (InstallationError "this operation requires -fexternal-interpreter")
+#endif
+
+-- | Run a command in the interpreter's context.  With
+-- @-fexternal-interpreter@, the command is serialized and sent to an
+-- external iserv process, and the response is deserialized (hence the
+-- @Binary@ constraint).  With @-fno-external-interpreter@ we execute
+-- the command directly here.
+iservCmd :: Binary a => HscEnv -> Message a -> IO a
+iservCmd hsc_env@HscEnv{..} msg
+ | gopt Opt_ExternalInterpreter hsc_dflags =
+     withIServ hsc_env $ \iserv ->
+       uninterruptibleMask_ $ do -- Note [uninterruptibleMask_]
+         iservCall iserv msg
+ | otherwise = -- Just run it directly
+#if defined(GHCI)
+   run msg
+#else
+   needExtInt
+#endif
+
+-- Note [uninterruptibleMask_ and iservCmd]
+--
+-- If we receive an async exception, such as ^C, while communicating
+-- with the iserv process then we will be out-of-sync and not be able
+-- to recoever.  Thus we use uninterruptibleMask_ during
+-- communication.  A ^C will be delivered to the iserv process (because
+-- signals get sent to the whole process group) which will interrupt
+-- the running computation and return an EvalException result.
+
+-- | Grab a lock on the 'IServ' and do something with it.
+-- Overloaded because this is used from TcM as well as IO.
+withIServ
+  :: (MonadIO m, ExceptionMonad m)
+  => HscEnv -> (IServ -> m a) -> m a
+withIServ HscEnv{..} action =
+  gmask $ \restore -> do
+    m <- liftIO $ takeMVar hsc_iserv
+      -- start the iserv process if we haven't done so yet
+    iserv <- maybe (liftIO $ startIServ hsc_dflags) return m
+               `gonException` (liftIO $ putMVar hsc_iserv Nothing)
+      -- free any ForeignHValues that have been garbage collected.
+    let iserv' = iserv{ iservPendingFrees = [] }
+    a <- (do
+      liftIO $ when (not (null (iservPendingFrees iserv))) $
+        iservCall iserv (FreeHValueRefs (iservPendingFrees iserv))
+        -- run the inner action
+      restore $ action iserv)
+          `gonException` (liftIO $ putMVar hsc_iserv (Just iserv'))
+    liftIO $ putMVar hsc_iserv (Just iserv')
+    return a
+
+
+-- -----------------------------------------------------------------------------
+-- Wrappers around messages
+
+-- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for
+-- each of the results.
+evalStmt
+  :: HscEnv -> Bool -> EvalExpr ForeignHValue
+  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
+evalStmt hsc_env step foreign_expr = do
+  let dflags = hsc_dflags hsc_env
+  status <- withExpr foreign_expr $ \expr ->
+    iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr)
+  handleEvalStatus hsc_env status
+ where
+  withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a
+  withExpr (EvalThis fhv) cont =
+    withForeignRef fhv $ \hvref -> cont (EvalThis hvref)
+  withExpr (EvalApp fl fr) cont =
+    withExpr fl $ \fl' ->
+    withExpr fr $ \fr' ->
+    cont (EvalApp fl' fr')
+
+resumeStmt
+  :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef])
+  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
+resumeStmt hsc_env step resume_ctxt = do
+  let dflags = hsc_dflags hsc_env
+  status <- withForeignRef resume_ctxt $ \rhv ->
+    iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv)
+  handleEvalStatus hsc_env status
+
+abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO ()
+abandonStmt hsc_env resume_ctxt = do
+  withForeignRef resume_ctxt $ \rhv ->
+    iservCmd hsc_env (AbandonStmt rhv)
+
+handleEvalStatus
+  :: HscEnv -> EvalStatus [HValueRef]
+  -> IO (EvalStatus_ [ForeignHValue] [HValueRef])
+handleEvalStatus hsc_env status =
+  case status of
+    EvalBreak a b c d e f -> return (EvalBreak a b c d e f)
+    EvalComplete alloc res ->
+      EvalComplete alloc <$> addFinalizer res
+ where
+  addFinalizer (EvalException e) = return (EvalException e)
+  addFinalizer (EvalSuccess rs) = do
+    EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs
+
+-- | Execute an action of type @IO ()@
+evalIO :: HscEnv -> ForeignHValue -> IO ()
+evalIO hsc_env fhv = do
+  liftIO $ withForeignRef fhv $ \fhv ->
+    iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult
+
+-- | Execute an action of type @IO String@
+evalString :: HscEnv -> ForeignHValue -> IO String
+evalString hsc_env fhv = do
+  liftIO $ withForeignRef fhv $ \fhv ->
+    iservCmd hsc_env (EvalString fhv) >>= fromEvalResult
+
+-- | Execute an action of type @String -> IO String@
+evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String
+evalStringToIOString hsc_env fhv str = do
+  liftIO $ withForeignRef fhv $ \fhv ->
+    iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult
+
+
+-- | Allocate and store the given bytes in memory, returning a pointer
+-- to the memory in the remote process.
+mallocData :: HscEnv -> ByteString -> IO (RemotePtr ())
+mallocData hsc_env bs = iservCmd hsc_env (MallocData bs)
+
+mkCostCentres
+  :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre]
+mkCostCentres hsc_env mod ccs =
+  iservCmd hsc_env (MkCostCentres mod ccs)
+
+-- | Create a set of BCOs that may be mutually recursive.
+createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef]
+createBCOs hsc_env rbcos = do
+  n_jobs <- case parMakeCount (hsc_dflags hsc_env) of
+              Nothing -> liftIO getNumProcessors
+              Just n  -> return n
+  -- Serializing ResolvedBCO is expensive, so if we're in parallel mode
+  -- (-j<n>) parallelise the serialization.
+  if (n_jobs == 1)
+    then
+      iservCmd hsc_env (CreateBCOs [runPut (put rbcos)])
+
+    else do
+      old_caps <- getNumCapabilities
+      if old_caps == n_jobs
+         then void $ evaluate puts
+         else bracket_ (setNumCapabilities n_jobs)
+                       (setNumCapabilities old_caps)
+                       (void $ evaluate puts)
+      iservCmd hsc_env (CreateBCOs puts)
+ where
+  puts = parMap doChunk (chunkList 100 rbcos)
+
+  -- make sure we force the whole lazy ByteString
+  doChunk c = pseq (LB.length bs) bs
+    where bs = runPut (put c)
+
+  -- We don't have the parallel package, so roll our own simple parMap
+  parMap _ [] = []
+  parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs))
+    where fx = f x; fxs = parMap f xs
+
+addSptEntry :: HscEnv -> Fingerprint -> ForeignHValue -> IO ()
+addSptEntry hsc_env fpr ref =
+  withForeignRef ref $ \val ->
+    iservCmd hsc_env (AddSptEntry fpr val)
+
+costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]
+costCentreStackInfo hsc_env ccs =
+  iservCmd hsc_env (CostCentreStackInfo ccs)
+
+newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray)
+newBreakArray hsc_env size = do
+  breakArray <- iservCmd hsc_env (NewBreakArray size)
+  mkFinalizedHValue hsc_env breakArray
+
+enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO ()
+enableBreakpoint hsc_env ref ix b = do
+  withForeignRef ref $ \breakarray ->
+    iservCmd hsc_env (EnableBreakpoint breakarray ix b)
+
+breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool
+breakpointStatus hsc_env ref ix = do
+  withForeignRef ref $ \breakarray ->
+    iservCmd hsc_env (BreakpointStatus breakarray ix)
+
+getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)
+getBreakpointVar hsc_env ref ix =
+  withForeignRef ref $ \apStack -> do
+    mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)
+    mapM (mkFinalizedHValue hsc_env) mb
+
+getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
+getClosure hsc_env ref =
+  withForeignRef ref $ \hval -> do
+    mb <- iservCmd hsc_env (GetClosure hval)
+    mapM (mkFinalizedHValue hsc_env) mb
+
+seqHValue :: HscEnv -> ForeignHValue -> IO ()
+seqHValue hsc_env ref =
+  withForeignRef ref $ \hval ->
+    iservCmd hsc_env (Seq hval) >>= fromEvalResult
+
+-- -----------------------------------------------------------------------------
+-- Interface to the object-code linker
+
+initObjLinker :: HscEnv -> IO ()
+initObjLinker hsc_env = iservCmd hsc_env InitLinker
+
+lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbol hsc_env@HscEnv{..} str
+ | gopt Opt_ExternalInterpreter hsc_dflags =
+     -- Profiling of GHCi showed a lot of time and allocation spent
+     -- making cross-process LookupSymbol calls, so I added a GHC-side
+     -- cache which sped things up quite a lot.  We have to be careful
+     -- to purge this cache when unloading code though.
+     withIServ hsc_env $ \iserv@IServ{..} -> do
+       cache <- readIORef iservLookupSymbolCache
+       case lookupUFM cache str of
+         Just p -> return (Just p)
+         Nothing -> do
+           m <- uninterruptibleMask_ $
+                    iservCall iserv (LookupSymbol (unpackFS str))
+           case m of
+             Nothing -> return Nothing
+             Just r -> do
+               let p = fromRemotePtr r
+               writeIORef iservLookupSymbolCache $! addToUFM cache str p
+               return (Just p)
+ | otherwise =
+#if defined(GHCI)
+   fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
+#else
+   needExtInt
+#endif
+
+lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef)
+lookupClosure hsc_env str =
+  iservCmd hsc_env (LookupClosure str)
+
+purgeLookupSymbolCache :: HscEnv -> IO ()
+purgeLookupSymbolCache hsc_env@HscEnv{..} =
+ when (gopt Opt_ExternalInterpreter hsc_dflags) $
+   withIServ hsc_env $ \IServ{..} ->
+     writeIORef iservLookupSymbolCache emptyUFM
+
+
+-- | loadDLL loads a dynamic library using the OS's native linker
+-- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either
+-- an absolute pathname to the file, or a relative filename
+-- (e.g. "libfoo.so" or "foo.dll").  In the latter case, loadDLL
+-- searches the standard locations for the appropriate library.
+--
+-- Returns:
+--
+-- Nothing      => success
+-- Just err_msg => failure
+loadDLL :: HscEnv -> String -> IO (Maybe String)
+loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str)
+
+loadArchive :: HscEnv -> String -> IO ()
+loadArchive hsc_env path = do
+  path' <- canonicalizePath path -- Note [loadObj and relative paths]
+  iservCmd hsc_env (LoadArchive path')
+
+loadObj :: HscEnv -> String -> IO ()
+loadObj hsc_env path = do
+  path' <- canonicalizePath path -- Note [loadObj and relative paths]
+  iservCmd hsc_env (LoadObj path')
+
+unloadObj :: HscEnv -> String -> IO ()
+unloadObj hsc_env path = do
+  path' <- canonicalizePath path -- Note [loadObj and relative paths]
+  iservCmd hsc_env (UnloadObj path')
+
+-- Note [loadObj and relative paths]
+-- the iserv process might have a different current directory from the
+-- GHC process, so we must make paths absolute before sending them
+-- over.
+
+addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ())
+addLibrarySearchPath hsc_env str =
+  fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str)
+
+removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool
+removeLibrarySearchPath hsc_env p =
+  iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p))
+
+resolveObjs :: HscEnv -> IO SuccessFlag
+resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs
+
+findSystemLibrary :: HscEnv -> String -> IO (Maybe String)
+findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str)
+
+
+-- -----------------------------------------------------------------------------
+-- Raw calls and messages
+
+-- | Send a 'Message' and receive the response from the iserv process
+iservCall :: Binary a => IServ -> Message a -> IO a
+iservCall iserv@IServ{..} msg =
+  remoteCall iservPipe msg
+    `catch` \(e :: SomeException) -> handleIServFailure iserv e
+
+-- | Read a value from the iserv process
+readIServ :: IServ -> Get a -> IO a
+readIServ iserv@IServ{..} get =
+  readPipe iservPipe get
+    `catch` \(e :: SomeException) -> handleIServFailure iserv e
+
+-- | Send a value to the iserv process
+writeIServ :: IServ -> Put -> IO ()
+writeIServ iserv@IServ{..} put =
+  writePipe iservPipe put
+    `catch` \(e :: SomeException) -> handleIServFailure iserv e
+
+handleIServFailure :: IServ -> SomeException -> IO a
+handleIServFailure IServ{..} e = do
+  ex <- getProcessExitCode iservProcess
+  case ex of
+    Just (ExitFailure n) ->
+      throw (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")"))
+    _ -> do
+      terminateProcess iservProcess
+      _ <- waitForProcess iservProcess
+      throw e
+
+-- -----------------------------------------------------------------------------
+-- Starting and stopping the iserv process
+
+startIServ :: DynFlags -> IO IServ
+startIServ dflags = do
+  let flavour
+        | WayProf `elem` ways dflags = "-prof"
+        | WayDyn `elem` ways dflags = "-dyn"
+        | otherwise = ""
+      prog = pgm_i dflags ++ flavour
+      opts = getOpts dflags opt_i
+  debugTraceMsg dflags 3 $ text "Starting " <> text prog
+  let createProc = lookupHook createIservProcessHook
+                              (\cp -> do { (_,_,_,ph) <- createProcess cp
+                                         ; return ph })
+                              dflags
+  (ph, rh, wh) <- runWithPipes createProc prog opts
+  lo_ref <- newIORef Nothing
+  cache_ref <- newIORef emptyUFM
+  return $ IServ
+    { iservPipe = Pipe { pipeRead = rh
+                       , pipeWrite = wh
+                       , pipeLeftovers = lo_ref }
+    , iservProcess = ph
+    , iservLookupSymbolCache = cache_ref
+    , iservPendingFrees = []
+    }
+
+stopIServ :: HscEnv -> IO ()
+stopIServ HscEnv{..} =
+  gmask $ \_restore -> do
+    m <- takeMVar hsc_iserv
+    maybe (return ()) stop m
+    putMVar hsc_iserv Nothing
+ where
+  stop iserv = do
+    ex <- getProcessExitCode (iservProcess iserv)
+    if isJust ex
+       then return ()
+       else iservCall iserv Shutdown
+
+runWithPipes :: (CreateProcess -> IO ProcessHandle)
+             -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)
+#if defined(mingw32_HOST_OS)
+foreign import ccall "io.h _close"
+   c__close :: CInt -> IO CInt
+
+foreign import ccall unsafe "io.h _get_osfhandle"
+   _get_osfhandle :: CInt -> IO CInt
+
+runWithPipes createProc prog opts = do
+    (rfd1, wfd1) <- createPipeFd -- we read on rfd1
+    (rfd2, wfd2) <- createPipeFd -- we write on wfd2
+    wh_client    <- _get_osfhandle wfd1
+    rh_client    <- _get_osfhandle rfd2
+    let args = show wh_client : show rh_client : opts
+    ph <- createProc (proc prog args)
+    rh <- mkHandle rfd1
+    wh <- mkHandle wfd2
+    return (ph, rh, wh)
+      where mkHandle :: CInt -> IO Handle
+            mkHandle fd = (fdToHandle fd) `onException` (c__close fd)
+
+#else
+runWithPipes createProc prog opts = do
+    (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1
+    (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2
+    setFdOption rfd1 CloseOnExec True
+    setFdOption wfd2 CloseOnExec True
+    let args = show wfd1 : show rfd2 : opts
+    ph <- createProc (proc prog args)
+    closeFd wfd1
+    closeFd rfd2
+    rh <- fdToHandle rfd1
+    wh <- fdToHandle wfd2
+    return (ph, rh, wh)
+#endif
+
+-- -----------------------------------------------------------------------------
+{- Note [External GHCi pointers]
+
+We have the following ways to reference things in GHCi:
+
+HValue
+------
+
+HValue is a direct reference to a value in the local heap.  Obviously
+we cannot use this to refer to things in the external process.
+
+
+RemoteRef
+---------
+
+RemoteRef is a StablePtr to a heap-resident value.  When
+-fexternal-interpreter is used, this value resides in the external
+process's heap.  RemoteRefs are mostly used to send pointers in
+messages between GHC and iserv.
+
+A RemoteRef must be explicitly freed when no longer required, using
+freeHValueRefs, or by attaching a finalizer with mkForeignHValue.
+
+To get from a RemoteRef to an HValue you can use 'wormholeRef', which
+fails with an error message if -fexternal-interpreter is in use.
+
+ForeignRef
+----------
+
+A ForeignRef is a RemoteRef with a finalizer that will free the
+'RemoteRef' when it is garbage collected.  We mostly use ForeignHValue
+on the GHC side.
+
+The finalizer adds the RemoteRef to the iservPendingFrees list in the
+IServ record.  The next call to iservCmd will free any RemoteRefs in
+the list.  It was done this way rather than calling iservCmd directly,
+because I didn't want to have arbitrary threads calling iservCmd.  In
+principle it would probably be ok, but it seems less hairy this way.
+-}
+
+-- | Creates a 'ForeignRef' that will automatically release the
+-- 'RemoteRef' when it is no longer referenced.
+mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a)
+mkFinalizedHValue HscEnv{..} rref = mkForeignRef rref free
+ where
+  !external = gopt Opt_ExternalInterpreter hsc_dflags
+  hvref = toHValueRef rref
+
+  free :: IO ()
+  free
+    | not external = freeRemoteRef hvref
+    | otherwise =
+      modifyMVar_ hsc_iserv $ \mb_iserv ->
+        case mb_iserv of
+          Nothing -> return Nothing -- already shut down
+          Just iserv@IServ{..} ->
+            return (Just iserv{iservPendingFrees = hvref : iservPendingFrees})
+
+freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()
+freeHValueRefs _ [] = return ()
+freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs)
+
+-- | Convert a 'ForeignRef' to the value it references directly.  This
+-- only works when the interpreter is running in the same process as
+-- the compiler, so it fails when @-fexternal-interpreter@ is on.
+wormhole :: DynFlags -> ForeignRef a -> IO a
+wormhole dflags r = wormholeRef dflags (unsafeForeignRefToRemoteRef r)
+
+-- | Convert an 'RemoteRef' to the value it references directly.  This
+-- only works when the interpreter is running in the same process as
+-- the compiler, so it fails when @-fexternal-interpreter@ is on.
+wormholeRef :: DynFlags -> RemoteRef a -> IO a
+wormholeRef dflags _r
+  | gopt Opt_ExternalInterpreter dflags
+  = throwIO (InstallationError
+      "this operation requires -fno-external-interpreter")
+#if defined(GHCI)
+  | otherwise
+  = localRef _r
+#else
+  | otherwise
+  = throwIO (InstallationError
+      "can't wormhole a value in a stage1 compiler")
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Misc utils
+
+mkEvalOpts :: DynFlags -> Bool -> EvalOpts
+mkEvalOpts dflags step =
+  EvalOpts
+    { useSandboxThread = gopt Opt_GhciSandbox dflags
+    , singleStep = step
+    , breakOnException = gopt Opt_BreakOnException dflags
+    , breakOnError = gopt Opt_BreakOnError dflags }
+
+fromEvalResult :: EvalResult a -> IO a
+fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
+fromEvalResult (EvalSuccess a) = return a
diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/Linker.hs
@@ -0,0 +1,1693 @@
+{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-}
+{-# LANGUAGE BangPatterns #-}
+{-# OPTIONS_GHC -fno-cse #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
+
+--
+--  (c) The University of Glasgow 2002-2006
+--
+-- | The dynamic linker for GHCi.
+--
+-- This module deals with the top-level issues of dynamic linking,
+-- calling the object-code linker and the byte-code linker where
+-- necessary.
+module Linker ( getHValue, showLinkerState,
+                linkExpr, linkDecls, unload, withExtendedLinkEnv,
+                extendLinkEnv, deleteFromLinkEnv,
+                extendLoadedPkgs,
+                linkPackages,initDynLinker,linkModule,
+                linkCmdLineLibs
+        ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHCi
+import GHCi.RemoteTypes
+import LoadIface
+import ByteCodeLink
+import ByteCodeAsm
+import ByteCodeTypes
+import TcRnMonad
+import Packages
+import DriverPhases
+import Finder
+import HscTypes
+import Name
+import NameEnv
+import Module
+import ListSetOps
+import DynFlags
+import BasicTypes
+import Outputable
+import Panic
+import Util
+import ErrUtils
+import SrcLoc
+import qualified Maybes
+import UniqDSet
+import FastString
+import Platform
+import SysTools
+import FileCleanup
+
+-- Standard libraries
+import Control.Monad
+
+import Data.Char (isSpace)
+import Data.IORef
+import Data.List
+import Data.Maybe
+import Control.Concurrent.MVar
+
+import System.FilePath
+import System.Directory
+import System.IO.Unsafe
+import System.Environment (lookupEnv)
+
+#if defined(mingw32_HOST_OS)
+import System.Win32.Info (getSystemDirectory)
+#endif
+
+import Exception
+
+-- needed for 2nd stage
+#if STAGE >= 2
+import Foreign (Ptr)
+#endif
+
+{- **********************************************************************
+
+                        The Linker's state
+
+  ********************************************************************* -}
+
+{-
+The persistent linker state *must* match the actual state of the
+C dynamic linker at all times, so we keep it in a private global variable.
+
+The global IORef used for PersistentLinkerState actually contains another MVar,
+which in turn 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.
+-}
+#if STAGE < 2
+GLOBAL_VAR_M( v_PersistentLinkerState
+            , newMVar Nothing
+            , MVar (Maybe PersistentLinkerState))
+#else
+SHARED_GLOBAL_VAR_M( v_PersistentLinkerState
+                   , getOrSetLibHSghcPersistentLinkerState
+                   , "getOrSetLibHSghcPersistentLinkerState"
+                   , newMVar Nothing
+                   , MVar (Maybe PersistentLinkerState))
+#endif
+
+uninitialised :: a
+uninitialised = panic "Dynamic linker not initialised"
+
+modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()
+modifyPLS_ f = readIORef v_PersistentLinkerState
+  >>= flip modifyMVar_ (fmap pure . f . fromMaybe uninitialised)
+
+modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a
+modifyPLS f = readIORef v_PersistentLinkerState
+  >>= flip modifyMVar (fmapFst pure . f . fromMaybe uninitialised)
+  where fmapFst f = fmap (\(x, y) -> (f x, y))
+
+readPLS :: IO PersistentLinkerState
+readPLS = readIORef v_PersistentLinkerState
+  >>= fmap (fromMaybe uninitialised) . readMVar
+
+modifyMbPLS_
+  :: (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()
+modifyMbPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f
+
+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)] }
+
+
+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 :: [InstalledUnitId] -> IO ()
+extendLoadedPkgs pkgs =
+  modifyPLS_ $ \s ->
+      return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
+
+extendLinkEnv :: [(Name,ForeignHValue)] -> IO ()
+extendLinkEnv new_bindings =
+  modifyPLS_ $ \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 :: [Name] -> IO ()
+deleteFromLinkEnv to_remove =
+  modifyPLS_ $ \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
+  initDynLinker hsc_env
+  pls <- modifyPLS $ \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)
+   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) =>
+                       [(Name,ForeignHValue)] -> m a -> m a
+withExtendedLinkEnv new_env action
+    = gbracket (liftIO $ extendLinkEnv 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_ $ \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 :: DynFlags -> IO ()
+showLinkerState dflags
+  = do pls <- readPLS
+       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 =
+  modifyMbPLS_ $ \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
+  initDynLinker hsc_env
+  modifyPLS_ $ \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 Trac #13210.
+      let platform = targetPlatform dflags
+          os       = platformOS platform
+          minus_ls = case os of
+                       OSMinGW32 -> "pthread" : minus_ls_1
+                       _         -> minus_ls_1
+      -- See Note [Fork/Exec Windows]
+      gcc_paths <- getGCCPaths dflags os
+
+      lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base
+
+      maybePutStrLn dflags "Search directories (user):"
+      maybePutStr dflags (unlines $ map ("  "++) lib_paths_env)
+      maybePutStrLn dflags "Search directories (gcc):"
+      maybePutStr dflags (unlines $ map ("  "++) gcc_paths)
+
+      libspecs
+        <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls
+
+      -- (d) Link .o files from the command-line
+      classified_ld_inputs <- mapM (classifyLdInput dflags)
+                                [ f | FileOption _ f <- cmdline_ld_inputs ]
+
+      -- (e) Link any MacOS frameworks
+      let platform = targetPlatform dflags
+      let (framework_paths, frameworks) =
+            if platformUsesFrameworks platform
+             then (frameworkPaths dflags, cmdlineFrameworks dflags)
+              else ([],[])
+
+      -- Finally do (c),(d),(e)
+      let cmdline_lib_specs = catMaybes classified_ld_inputs
+                           ++ libspecs
+                           ++ map Framework frameworks
+      if null cmdline_lib_specs then return pls
+                                else do
+
+      -- Add directories to library search paths, this only has an effect
+      -- on Windows. On Unix OSes this function is a NOP.
+      let all_paths = let paths = takeDirectory (fst $ sPgm_c $ settings dflags)
+                                : framework_paths
+                               ++ lib_paths_base
+                               ++ [ takeDirectory dll | DLLPath dll <- libspecs ]
+                      in nub $ map normalise paths
+      let lib_paths = nub $ lib_paths_base ++ gcc_paths
+      all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
+      pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
+
+      pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls
+                    cmdline_lib_specs
+      maybePutStr dflags "final link ... "
+      ok <- resolveObjs hsc_env
+
+      -- DLLs are loaded, reset the search paths
+      mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
+
+      if succeeded ok then maybePutStrLn dflags "done"
+      else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")
+
+      return pls1
+
+{- Note [preload packages]
+
+Why do we need to preload packages from the command line?  This is an
+explanation copied from #2437:
+
+I tried to implement the suggestion from #3560, thinking it would be
+easy, but there are two reasons we link in packages eagerly when they
+are mentioned on the command line:
+
+  * So that you can link in extra object files or libraries that
+    depend on the packages. e.g. ghc -package foo -lbar where bar is a
+    C library that depends on something in foo. So we could link in
+    foo eagerly if and only if there are extra C libs or objects to
+    link in, but....
+
+  * Haskell code can depend on a C function exported by a package, and
+    the normal dependency tracking that TH uses can't know about these
+    dependencies. The test ghcilink004 relies on this, for example.
+
+I conclude that we need two -package flags: one that says "this is a
+package I want to make available", and one that says "this is a
+package I want to link in eagerly". Would that be too complicated for
+users?
+-}
+
+classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec)
+classifyLdInput dflags f
+  | isObjectFilename platform f = return (Just (Object f))
+  | isDynLibFilename platform f = return (Just (DLLPath f))
+  | otherwise          = do
+        putLogMsg dflags NoReason SevInfo noSrcSpan
+            (defaultUserStyle dflags)
+            (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
+        return Nothing
+    where platform = targetPlatform dflags
+
+preloadLib
+  :: HscEnv -> [String] -> [String] -> PersistentLinkerState
+  -> LibrarySpec -> IO PersistentLinkerState
+preloadLib hsc_env lib_paths framework_paths pls lib_spec = do
+  maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
+  case lib_spec of
+    Object static_ish -> do
+      (b, pls1) <- preload_static lib_paths static_ish
+      maybePutStrLn dflags (if b  then "done" else "not found")
+      return pls1
+
+    Archive static_ish -> do
+      b <- preload_static_archive lib_paths static_ish
+      maybePutStrLn dflags (if b  then "done" else "not found")
+      return pls
+
+    DLL dll_unadorned -> do
+      maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned)
+      case maybe_errstr of
+         Nothing -> maybePutStrLn dflags "done"
+         Just mm | platformOS platform /= OSDarwin ->
+           preloadFailed mm lib_paths lib_spec
+         Just mm | otherwise -> do
+           -- As a backup, on Darwin, try to also load a .so file
+           -- since (apparently) some things install that way - see
+           -- ticket #8770.
+           let libfile = ("lib" ++ dll_unadorned) <.> "so"
+           err2 <- loadDLL hsc_env libfile
+           case err2 of
+             Nothing -> maybePutStrLn dflags "done"
+             Just _  -> preloadFailed mm lib_paths lib_spec
+      return pls
+
+    DLLPath dll_path -> do
+      do maybe_errstr <- loadDLL hsc_env dll_path
+         case maybe_errstr of
+            Nothing -> maybePutStrLn dflags "done"
+            Just mm -> preloadFailed mm lib_paths lib_spec
+         return pls
+
+    Framework framework ->
+      if platformUsesFrameworks (targetPlatform dflags)
+      then do maybe_errstr <- loadFramework hsc_env framework_paths framework
+              case maybe_errstr of
+                 Nothing -> maybePutStrLn dflags "done"
+                 Just mm -> preloadFailed mm framework_paths lib_spec
+              return pls
+      else panic "preloadLib Framework"
+
+  where
+    dflags = hsc_dflags hsc_env
+
+    platform = targetPlatform dflags
+
+    preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
+    preloadFailed sys_errmsg paths spec
+       = do maybePutStr dflags "failed.\n"
+            throwGhcExceptionIO $
+              CmdLineError (
+                    "user specified .o/.so/.DLL could not be loaded ("
+                    ++ sys_errmsg ++ ")\nWhilst trying to load:  "
+                    ++ showLS spec ++ "\nAdditional directories searched:"
+                    ++ (if null paths then " (none)" else
+                        intercalate "\n" (map ("   "++) paths)))
+
+    -- Not interested in the paths in the static case.
+    preload_static _paths name
+       = do b <- doesFileExist name
+            if not b then return (False, pls)
+                     else if dynamicGhc
+                             then  do pls1 <- dynLoadObjs hsc_env pls [name]
+                                      return (True, pls1)
+                             else  do loadObj hsc_env name
+                                      return (True, pls)
+
+    preload_static_archive _paths name
+       = do b <- doesFileExist name
+            if not b then return False
+                     else do if dynamicGhc
+                                 then throwGhcExceptionIO $
+                                      CmdLineError dynamic_msg
+                                 else loadArchive hsc_env name
+                             return True
+      where
+        dynamic_msg = unlines
+          [ "User-specified static library could not be loaded ("
+            ++ name ++ ")"
+          , "Loading static libraries is not supported in this configuration."
+          , "Try using a dynamic library instead."
+          ]
+
+
+{- **********************************************************************
+
+                        Link a byte-code expression
+
+  ********************************************************************* -}
+
+-- | Link a single expression, /including/ first linking packages and
+-- modules that this expression depends on.
+--
+-- Raises an IO exception ('ProgramError') if it can't find a compiled
+-- version of the dependents to link.
+--
+linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue
+linkExpr hsc_env span root_ul_bco
+  = do {
+     -- Initialise the linker (if it's not been done already)
+   ; initDynLinker hsc_env
+
+     -- Take lock for the actual work.
+   ; modifyPLS $ \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
+
+    -- Take lock for the actual work.
+    modifyPLS $ \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
+  modifyPLS_ $ \pls -> do
+    (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]
+    if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")
+      else return pls'
+
+{- **********************************************************************
+
+                Link some linkables
+        The linkables may consist of a mixture of
+        byte-code modules and object modules
+
+  ********************************************************************* -}
+
+linkModules :: HscEnv -> PersistentLinkerState -> [Linkable]
+            -> IO (PersistentLinkerState, SuccessFlag)
+linkModules hsc_env pls linkables
+  = mask_ $ do  -- don't want to be interrupted by ^C in here
+
+        let (objs, bcos) = partition isObjectLinkable
+                              (concatMap partitionLinkable linkables)
+
+                -- Load objects first; they can't depend on BCOs
+        (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs
+
+        if failed ok_flag then
+                return (pls1, Failed)
+          else do
+                pls2 <- dynLinkBCOs hsc_env pls1 bcos
+                return (pls2, Succeeded)
+
+
+-- HACK to support f-x-dynamic in the interpreter; no other purpose
+partitionLinkable :: Linkable -> [Linkable]
+partitionLinkable li
+   = let li_uls = linkableUnlinked li
+         li_uls_obj = filter isObject li_uls
+         li_uls_bco = filter isInterpretable li_uls
+     in
+         case (li_uls_obj, li_uls_bco) of
+            (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
+                           li {linkableUnlinked=li_uls_bco}]
+            _ -> [li]
+
+findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
+findModuleLinkable_maybe lis mod
+   = case [LM time nm us | LM time nm us <- lis, nm == mod] of
+        []   -> Nothing
+        [li] -> Just li
+        _    -> pprPanic "findModuleLinkable" (ppr mod)
+
+linkableInSet :: Linkable -> [Linkable] -> Bool
+linkableInSet l objs_loaded =
+  case findModuleLinkable_maybe objs_loaded (linkableModule l) of
+        Nothing -> False
+        Just m  -> linkableTime l == linkableTime m
+
+
+{- **********************************************************************
+
+                The object-code linker
+
+  ********************************************************************* -}
+
+dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable]
+            -> IO (PersistentLinkerState, SuccessFlag)
+dynLinkObjs hsc_env pls objs = do
+        -- Load the object files and link them
+        let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
+            pls1                     = pls { objs_loaded = objs_loaded' }
+            unlinkeds                = concatMap linkableUnlinked new_objs
+            wanted_objs              = map nameOfObject unlinkeds
+
+        if interpreterDynamic (hsc_dflags hsc_env)
+            then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs
+                    return (pls2, Succeeded)
+            else do mapM_ (loadObj hsc_env) wanted_objs
+
+                    -- Link them all together
+                    ok <- resolveObjs hsc_env
+
+                    -- If resolving failed, unload all our
+                    -- object modules and carry on
+                    if succeeded ok then do
+                            return (pls1, Succeeded)
+                      else do
+                            pls2 <- unload_wkr hsc_env [] pls1
+                            return (pls2, Failed)
+
+
+dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath]
+            -> IO PersistentLinkerState
+dynLoadObjs _       pls []   = return pls
+dynLoadObjs hsc_env pls objs = do
+    let dflags = hsc_dflags hsc_env
+    let platform = targetPlatform dflags
+    let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]
+    let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]
+    (soFile, libPath , libName) <-
+      newTempLibName dflags TFL_CurrentModule (soExt platform)
+    let
+        dflags2 = dflags {
+                      -- We don't want the original ldInputs in
+                      -- (they're already linked in), but we do want
+                      -- to link against previous dynLoadObjs
+                      -- libraries if there were any, so that the linker
+                      -- can resolve dependencies when it loads this
+                      -- library.
+                      ldInputs =
+                           concatMap (\l -> [ Option ("-l" ++ l) ])
+                                     (nub $ snd <$> temp_sos pls)
+                        ++ concatMap (\lp -> [ Option ("-L" ++ lp)
+                                                    , Option "-Xlinker"
+                                                    , Option "-rpath"
+                                                    , Option "-Xlinker"
+                                                    , Option lp ])
+                                     (nub $ fst <$> temp_sos pls)
+                        ++ concatMap
+                             (\lp ->
+                                 [ Option ("-L" ++ lp)
+                                 , Option "-Xlinker"
+                                 , Option "-rpath"
+                                 , Option "-Xlinker"
+                                 , Option lp
+                                 ])
+                             minus_big_ls
+                        -- See Note [-Xlinker -rpath vs -Wl,-rpath]
+                        ++ map (\l -> Option ("-l" ++ l)) minus_ls,
+                      -- Add -l options and -L options from dflags.
+                      --
+                      -- When running TH for a non-dynamic way, we still
+                      -- need to make -l flags to link against the dynamic
+                      -- libraries, so we need to add WayDyn to ways.
+                      --
+                      -- Even if we're e.g. profiling, we still want
+                      -- the vanilla dynamic libraries, so we set the
+                      -- ways / build tag to be just WayDyn.
+                      ways = [WayDyn],
+                      buildTag = mkBuildTag [WayDyn],
+                      outputFile = Just soFile
+                  }
+    -- link all "loaded packages" so symbols in those can be resolved
+    -- Note: We are loading packages with local scope, so to see the
+    -- symbols in this link we must link all loaded packages again.
+    linkDynLib dflags2 objs (pkgs_loaded pls)
+
+    -- if we got this far, extend the lifetime of the library file
+    changeTempFilesLifetime dflags TFL_GhcSession [soFile]
+    m <- loadDLL hsc_env soFile
+    case m of
+        Nothing -> return pls { temp_sos = (libPath, libName) : temp_sos pls }
+        Just err -> panic ("Loading temp shared object failed: " ++ err)
+
+rmDupLinkables :: [Linkable]    -- Already loaded
+               -> [Linkable]    -- New linkables
+               -> ([Linkable],  -- New loaded set (including new ones)
+                   [Linkable])  -- New linkables (excluding dups)
+rmDupLinkables already ls
+  = go already [] ls
+  where
+    go already extras [] = (already, extras)
+    go already extras (l:ls)
+        | linkableInSet l already = go already     extras     ls
+        | otherwise               = go (l:already) (l:extras) ls
+
+{- **********************************************************************
+
+                The byte-code linker
+
+  ********************************************************************* -}
+
+
+dynLinkBCOs :: HscEnv -> PersistentLinkerState -> [Linkable]
+            -> IO PersistentLinkerState
+dynLinkBCOs hsc_env pls bcos = do
+
+        let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
+            pls1                     = pls { bcos_loaded = bcos_loaded' }
+            unlinkeds :: [Unlinked]
+            unlinkeds                = concatMap linkableUnlinked new_bcos
+
+            cbcs :: [CompiledByteCode]
+            cbcs      = map byteCodeOfObject unlinkeds
+
+
+            ies        = map bc_itbls cbcs
+            gce       = closure_env pls
+            final_ie  = foldr plusNameEnv (itbl_env pls) ies
+
+        names_and_refs <- linkSomeBCOs hsc_env final_ie gce cbcs
+
+        -- We only want to add the external ones to the ClosureEnv
+        let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
+
+        -- Immediately release any HValueRefs we're not going to add
+        freeHValueRefs hsc_env (map snd to_drop)
+        -- Wrap finalizers on the ones we want to keep
+        new_binds <- makeForeignNamedHValueRefs hsc_env to_add
+
+        return pls1 { closure_env = extendClosureEnv gce new_binds,
+                      itbl_env    = final_ie }
+
+-- Link a bunch of BCOs and return references to their values
+linkSomeBCOs :: HscEnv
+             -> ItblEnv
+             -> ClosureEnv
+             -> [CompiledByteCode]
+             -> IO [(Name,HValueRef)]
+                        -- The returned HValueRefs are associated 1-1 with
+                        -- the incoming unlinked BCOs.  Each gives the
+                        -- value of the corresponding unlinked BCO
+
+linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods []
+ where
+  fun CompiledByteCode{..} inner accum =
+    case bc_breaks of
+      Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum)
+      Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray ->
+                   inner ((breakarray, bc_bcos) : accum)
+
+  do_link [] = return []
+  do_link mods = do
+    let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ]
+        names = map (unlinkedBCOName . snd) flat
+        bco_ix = mkNameEnv (zip names [0..])
+    resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco
+                         | (breakarray, bco) <- flat ]
+    hvrefs <- createBCOs hsc_env resolved
+    return (zip names hvrefs)
+
+-- | Useful to apply to the result of 'linkSomeBCOs'
+makeForeignNamedHValueRefs
+  :: HscEnv -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)]
+makeForeignNamedHValueRefs hsc_env bindings =
+  mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue hsc_env hvref) bindings
+
+{- **********************************************************************
+
+                Unload some object modules
+
+  ********************************************************************* -}
+
+-- ---------------------------------------------------------------------------
+-- | Unloading old objects ready for a new compilation sweep.
+--
+-- The compilation manager provides us with a list of linkables that it
+-- considers \"stable\", i.e. won't be recompiled this time around.  For
+-- each of the modules current linked in memory,
+--
+--   * if the linkable is stable (and it's the same one -- the user may have
+--     recompiled the module on the side), we keep it,
+--
+--   * otherwise, we unload it.
+--
+--   * we also implicitly unload all temporary bindings at this point.
+--
+unload :: HscEnv
+       -> [Linkable] -- ^ The linkables to *keep*.
+       -> IO ()
+unload hsc_env linkables
+  = mask_ $ do -- mask, so we're safe from Ctrl-C in here
+
+        -- Initialise the linker (if it's not been done already)
+        initDynLinker hsc_env
+
+        new_pls
+            <- modifyPLS $ \pls -> do
+                 pls1 <- unload_wkr hsc_env linkables pls
+                 return (pls1, pls1)
+
+        let dflags = hsc_dflags hsc_env
+        debugTraceMsg dflags 3 $
+          text "unload: retaining objs" <+> ppr (objs_loaded new_pls)
+        debugTraceMsg dflags 3 $
+          text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)
+        return ()
+
+unload_wkr :: HscEnv
+           -> [Linkable]                -- stable linkables
+           -> PersistentLinkerState
+           -> IO PersistentLinkerState
+-- Does the core unload business
+-- (the wrapper blocks exceptions and deals with the PLS get and put)
+
+unload_wkr hsc_env keep_linkables pls@PersistentLinkerState{..}  = do
+  -- NB. careful strictness here to avoid keeping the old PLS when
+  -- we're unloading some code.  -fghci-leak-check with the tests in
+  -- testsuite/ghci can detect space leaks here.
+
+  let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables
+
+      discard keep l = not (linkableInSet l keep)
+
+      (objs_to_unload, remaining_objs_loaded) =
+         partition (discard objs_to_keep) objs_loaded
+      (bcos_to_unload, remaining_bcos_loaded) =
+         partition (discard bcos_to_keep) bcos_loaded
+
+  mapM_ unloadObjs objs_to_unload
+  mapM_ unloadObjs bcos_to_unload
+
+  -- If we unloaded any object files at all, we need to purge the cache
+  -- of lookupSymbol results.
+  when (not (null (objs_to_unload ++
+                   filter (not . null . linkableObjs) bcos_to_unload))) $
+    purgeLookupSymbolCache hsc_env
+
+  let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded
+
+      -- Note that we want to remove all *local*
+      -- (i.e. non-isExternal) names too (these are the
+      -- temporary bindings from the command line).
+      keep_name (n,_) = isExternalName n &&
+                        nameModule n `elemModuleSet` bcos_retained
+
+      itbl_env'     = filterNameEnv keep_name itbl_env
+      closure_env'  = filterNameEnv keep_name closure_env
+
+      !new_pls = pls { itbl_env = itbl_env',
+                       closure_env = closure_env',
+                       bcos_loaded = remaining_bcos_loaded,
+                       objs_loaded = remaining_objs_loaded }
+
+  return new_pls
+  where
+    unloadObjs :: Linkable -> IO ()
+    unloadObjs lnk
+      | dynamicGhc = return ()
+        -- We don't do any cleanup when linking objects with the
+        -- dynamic linker.  Doing so introduces extra complexity for
+        -- not much benefit.
+      | otherwise
+      = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk]
+                -- The components of a BCO linkable may contain
+                -- dot-o files.  Which is very confusing.
+                --
+                -- But the BCO parts can be unlinked just by
+                -- letting go of them (plus of course depopulating
+                -- the symbol table which is done in the main body)
+
+{- **********************************************************************
+
+                Loading packages
+
+  ********************************************************************* -}
+
+data LibrarySpec
+   = Object FilePath    -- Full path name of a .o file, including trailing .o
+                        -- For dynamic objects only, try to find the object
+                        -- file in all the directories specified in
+                        -- v_Library_paths before giving up.
+
+   | Archive FilePath   -- Full path name of a .a file, including trailing .a
+
+   | DLL String         -- "Unadorned" name of a .DLL/.so
+                        --  e.g.    On unix     "qt"  denotes "libqt.so"
+                        --          On Windows  "burble"  denotes "burble.DLL" or "libburble.dll"
+                        --  loadDLL is platform-specific and adds the lib/.so/.DLL
+                        --  suffixes platform-dependently
+
+   | DLLPath FilePath   -- Absolute or relative pathname to a dynamic library
+                        -- (ends with .dll or .so).
+
+   | Framework String   -- Only used for darwin, but does no harm
+
+-- If this package is already part of the GHCi binary, we'll already
+-- have the right DLLs for this package loaded, so don't try to
+-- load them again.
+--
+-- But on Win32 we must load them 'again'; doing so is a harmless no-op
+-- as far as the loader is concerned, but it does initialise the list
+-- of DLL handles that rts/Linker.c maintains, and that in turn is
+-- used by lookupSymbol.  So we must call addDLL for each library
+-- just to get the DLL handle into the list.
+partOfGHCi :: [PackageName]
+partOfGHCi
+ | isWindowsHost || isDarwinHost = []
+ | otherwise = map (PackageName . mkFastString)
+                   ["base", "template-haskell", "editline"]
+
+showLS :: LibrarySpec -> String
+showLS (Object nm)    = "(static) " ++ nm
+showLS (Archive nm)   = "(static archive) " ++ nm
+showLS (DLL nm)       = "(dynamic) " ++ nm
+showLS (DLLPath nm)   = "(dynamic) " ++ nm
+showLS (Framework nm) = "(framework) " ++ nm
+
+-- TODO: Make this type more precise
+type LinkerUnitId = InstalledUnitId
+
+-- | 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
+  modifyPLS_ $ \pls -> do
+    linkPackages' hsc_env new_pkgs pls
+
+linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState
+             -> IO PersistentLinkerState
+linkPackages' hsc_env new_pks pls = do
+    pkgs' <- link (pkgs_loaded pls) new_pks
+    return $! pls { pkgs_loaded = pkgs' }
+  where
+     dflags = hsc_dflags hsc_env
+
+     link :: [LinkerUnitId] -> [LinkerUnitId] -> IO [LinkerUnitId]
+     link pkgs new_pkgs =
+         foldM link_one pkgs new_pkgs
+
+     link_one pkgs new_pkg
+        | new_pkg `elem` pkgs   -- Already linked
+        = return pkgs
+
+        | Just pkg_cfg <- lookupInstalledPackage dflags new_pkg
+        = do {  -- Link dependents first
+               pkgs' <- link pkgs (depends pkg_cfg)
+                -- Now link the package itself
+             ; linkPackage hsc_env pkg_cfg
+             ; return (new_pkg : pkgs') }
+
+        | otherwise
+        = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (installedUnitIdFS new_pkg)))
+
+
+linkPackage :: HscEnv -> PackageConfig -> IO ()
+linkPackage hsc_env pkg
+   = do
+        let dflags    = hsc_dflags hsc_env
+            platform  = targetPlatform dflags
+            is_dyn = interpreterDynamic dflags
+            dirs | is_dyn    = Packages.libraryDynDirs pkg
+                 | otherwise = Packages.libraryDirs pkg
+
+        let hs_libs   =  Packages.hsLibraries pkg
+            -- The FFI GHCi import lib isn't needed as
+            -- compiler/ghci/Linker.hs + rts/Linker.c link the
+            -- interpreted references to FFI to the compiled FFI.
+            -- We therefore filter it out so that we don't get
+            -- duplicate symbol errors.
+            hs_libs'  =  filter ("HSffi" /=) hs_libs
+
+        -- Because of slight differences between the GHC dynamic linker and
+        -- the native system linker some packages have to link with a
+        -- different list of libraries when using GHCi. Examples include: libs
+        -- that are actually gnu ld scripts, and the possibility that the .a
+        -- libs do not exactly match the .so/.dll equivalents. So if the
+        -- package file provides an "extra-ghci-libraries" field then we use
+        -- that instead of the "extra-libraries" field.
+            extra_libs =
+                      (if null (Packages.extraGHCiLibraries pkg)
+                            then Packages.extraLibraries pkg
+                            else Packages.extraGHCiLibraries pkg)
+                      ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
+        -- See Note [Fork/Exec Windows]
+        gcc_paths <- getGCCPaths dflags (platformOS platform)
+        dirs_env <- addEnvPaths "LIBRARY_PATH" dirs
+
+        hs_classifieds
+           <- mapM (locateLib hsc_env True  dirs_env gcc_paths) hs_libs'
+        extra_classifieds
+           <- mapM (locateLib hsc_env False dirs_env gcc_paths) extra_libs
+        let classifieds = hs_classifieds ++ extra_classifieds
+
+        -- Complication: all the .so's must be loaded before any of the .o's.
+        let known_dlls = [ dll  | DLLPath dll    <- classifieds ]
+            dlls       = [ dll  | DLL dll        <- classifieds ]
+            objs       = [ obj  | Object obj     <- classifieds ]
+            archs      = [ arch | Archive arch   <- classifieds ]
+
+        -- Add directories to library search paths
+        let dll_paths  = map takeDirectory known_dlls
+            all_paths  = nub $ map normalise $ dll_paths ++ dirs
+        all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
+        pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env
+
+        maybePutStr dflags
+            ("Loading package " ++ sourcePackageIdString pkg ++ " ... ")
+
+        -- See comments with partOfGHCi
+        when (packageName pkg `notElem` partOfGHCi) $ do
+            loadFrameworks hsc_env platform pkg
+            -- See Note [Crash early load_dyn and locateLib]
+            -- Crash early if can't load any of `known_dlls`
+            mapM_ (load_dyn hsc_env True) known_dlls
+            -- For remaining `dlls` crash early only when there is surely
+            -- no package's DLL around ... (not is_dyn)
+            mapM_ (load_dyn hsc_env (not is_dyn) . mkSOName platform) dlls
+
+        -- After loading all the DLLs, we can load the static objects.
+        -- Ordering isn't important here, because we do one final link
+        -- step to resolve everything.
+        mapM_ (loadObj hsc_env) objs
+        mapM_ (loadArchive hsc_env) archs
+
+        maybePutStr dflags "linking ... "
+        ok <- resolveObjs hsc_env
+
+        -- DLLs are loaded, reset the search paths
+        -- Import libraries will be loaded via loadArchive so only
+        -- reset the DLL search path after all archives are loaded
+        -- as well.
+        mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache
+
+        if succeeded ok
+           then maybePutStrLn dflags "done."
+           else let errmsg = "unable to load package `"
+                             ++ sourcePackageIdString pkg ++ "'"
+                 in throwGhcExceptionIO (InstallationError errmsg)
+
+{-
+Note [Crash early load_dyn and locateLib]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a package is "normal" (exposes it's code from more than zero Haskell
+modules, unlike e.g. that in ghcilink004) and is built "dyn" way, then
+it has it's code compiled and linked into the DLL, which GHCi linker picks
+when loading the package's code (see the big comment in the beginning of
+`locateLib`).
+
+When loading DLLs, GHCi linker simply calls the system's `dlopen` or
+`LoadLibrary` APIs. This is quite different from the case when GHCi linker
+loads an object file or static library. When loading an object file or static
+library GHCi linker parses them and resolves all symbols "manually".
+These object file or static library may reference some external symbols
+defined in some external DLLs. And GHCi should know which these
+external DLLs are.
+
+But when GHCi loads a DLL, it's the *system* linker who manages all
+the necessary dependencies, and it is able to load this DLL not having
+any extra info. Thus we don't *have to* crash in this case even if we
+are unable to load any supposed dependencies explicitly.
+
+Suppose during GHCi session a client of the package wants to
+`foreign import` a symbol which isn't exposed by the package DLL, but
+is exposed by such an external (dependency) DLL.
+If the DLL isn't *explicitly* loaded because `load_dyn` failed to do
+this, then the client code eventually crashes because the GHCi linker
+isn't able to locate this symbol (GHCi linker maintains a list of
+explicitly loaded DLLs it looks into when trying to find a symbol).
+
+This is why we still should try to load all the dependency DLLs
+even though we know that the system linker loads them implicitly when
+loading the package DLL.
+
+Why we still keep the `crash_early` opportunity then not allowing such
+a permissive behaviour for any DLLs? Well, we, perhaps, improve a user
+experience in some cases slightly.
+
+But if it happens there exist other corner cases where our current
+usage of `crash_early` flag is overly restrictive, we may lift the
+restriction very easily.
+-}
+
+-- we have already searched the filesystem; the strings passed to load_dyn
+-- can be passed directly to loadDLL.  They are either fully-qualified
+-- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so").  In the latter case,
+-- loadDLL is going to search the system paths to find the library.
+load_dyn :: HscEnv -> Bool -> FilePath -> IO ()
+load_dyn hsc_env crash_early dll = do
+  r <- loadDLL hsc_env dll
+  case r of
+    Nothing  -> return ()
+    Just err ->
+      if crash_early
+        then cmdLineErrorIO err
+        else let dflags = hsc_dflags hsc_env in
+          when (wopt Opt_WarnMissedExtraSharedLib dflags)
+            $ putLogMsg dflags
+                (Reason Opt_WarnMissedExtraSharedLib) SevWarning
+                  noSrcSpan (defaultUserStyle dflags)(note err)
+  where
+    note err = vcat $ map text
+      [ err
+      , "It's OK if you don't want to use symbols from it directly."
+      , "(the package DLL is loaded by the system linker"
+      , " which manages dependencies by itself)." ]
+
+loadFrameworks :: HscEnv -> Platform -> PackageConfig -> IO ()
+loadFrameworks hsc_env platform pkg
+    = when (platformUsesFrameworks platform) $ mapM_ load frameworks
+  where
+    fw_dirs    = Packages.frameworkDirs pkg
+    frameworks = Packages.frameworks pkg
+
+    load fw = do  r <- loadFramework hsc_env fw_dirs fw
+                  case r of
+                    Nothing  -> return ()
+                    Just err -> cmdLineErrorIO ("can't load framework: "
+                                                ++ fw ++ " (" ++ err ++ ")" )
+
+-- Try to find an object file for a given library in the given paths.
+-- If it isn't present, we assume that addDLL in the RTS can find it,
+-- which generally means that it should be a dynamic library in the
+-- standard system search path.
+-- For GHCi we tend to prefer dynamic libraries over static ones as
+-- they are easier to load and manage, have less overhead.
+locateLib :: HscEnv -> Bool -> [FilePath] -> [FilePath] -> String
+          -> IO LibrarySpec
+locateLib hsc_env is_hs lib_dirs gcc_dirs lib
+  | not is_hs
+    -- For non-Haskell libraries (e.g. gmp, iconv):
+    --   first look in library-dirs for a dynamic library (on User paths only)
+    --   (libfoo.so)
+    --   then  try looking for import libraries on Windows (on User paths only)
+    --   (.dll.a, .lib)
+    --   first look in library-dirs for a dynamic library (on GCC paths only)
+    --   (libfoo.so)
+    --   then  check for system dynamic libraries (e.g. kernel32.dll on windows)
+    --   then  try looking for import libraries on Windows (on GCC paths only)
+    --   (.dll.a, .lib)
+    --   then  look in library-dirs for a static library (libfoo.a)
+    --   then look in library-dirs and inplace GCC for a dynamic library (libfoo.so)
+    --   then  try looking for import libraries on Windows (.dll.a, .lib)
+    --   then  look in library-dirs and inplace GCC for a static library (libfoo.a)
+    --   then  try "gcc --print-file-name" to search gcc's search path
+    --       for a dynamic library (#5289)
+    --   otherwise, assume loadDLL can find it
+    --
+    --   The logic is a bit complicated, but the rationale behind it is that
+    --   loading a shared library for us is O(1) while loading an archive is
+    --   O(n). Loading an import library is also O(n) so in general we prefer
+    --   shared libraries because they are simpler and faster.
+    --
+  = findDll   user `orElse`
+    tryImpLib user `orElse`
+    findDll   gcc  `orElse`
+    findSysDll     `orElse`
+    tryImpLib gcc  `orElse`
+    findArchive    `orElse`
+    tryGcc         `orElse`
+    assumeDll
+
+  | loading_dynamic_hs_libs -- search for .so libraries first.
+  = findHSDll     `orElse`
+    findDynObject `orElse`
+    assumeDll
+
+  | otherwise
+    -- use HSfoo.{o,p_o} if it exists, otherwise fallback to libHSfoo{,_p}.a
+  = findObject  `orElse`
+    findArchive `orElse`
+    assumeDll
+
+   where
+     dflags = hsc_dflags hsc_env
+     dirs   = lib_dirs ++ gcc_dirs
+     gcc    = False
+     user   = True
+
+     obj_file
+       | is_hs && loading_profiled_hs_libs = lib <.> "p_o"
+       | otherwise = lib <.> "o"
+     dyn_obj_file = lib <.> "dyn_o"
+     arch_files = [ "lib" ++ lib ++ lib_tag <.> "a"
+                  , lib <.> "a" -- native code has no lib_tag
+                  , "lib" ++ lib, lib
+                  ]
+     lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""
+
+     loading_profiled_hs_libs = interpreterProfiled dflags
+     loading_dynamic_hs_libs  = interpreterDynamic dflags
+
+     import_libs  = [ lib <.> "lib"           , "lib" ++ lib <.> "lib"
+                    , "lib" ++ lib <.> "dll.a", lib <.> "dll.a"
+                    ]
+
+     hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags
+     hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name
+
+     so_name     = mkSOName platform lib
+     lib_so_name = "lib" ++ so_name
+     dyn_lib_file = case (arch, os) of
+                             (ArchX86_64, OSSolaris2) -> "64" </> so_name
+                             _ -> so_name
+
+     findObject    = liftM (fmap Object)  $ findFile dirs obj_file
+     findDynObject = liftM (fmap Object)  $ findFile dirs dyn_obj_file
+     findArchive   = let local name = liftM (fmap Archive) $ findFile dirs name
+                     in  apply (map local arch_files)
+     findHSDll     = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file
+     findDll    re = let dirs' = if re == user then lib_dirs else gcc_dirs
+                     in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file
+     findSysDll    = fmap (fmap $ DLL . dropExtension . takeFileName) $
+                        findSystemLibrary hsc_env so_name
+     tryGcc        = let search   = searchForLibUsingGcc dflags
+                         dllpath  = liftM (fmap DLLPath)
+                         short    = dllpath $ search so_name lib_dirs
+                         full     = dllpath $ search lib_so_name lib_dirs
+                         gcc name = liftM (fmap Archive) $ search name lib_dirs
+                         files    = import_libs ++ arch_files
+                     in apply $ short : full : map gcc files
+     tryImpLib re = case os of
+                       OSMinGW32 ->
+                        let dirs' = if re == user then lib_dirs else gcc_dirs
+                            implib name = liftM (fmap Archive) $
+                                            findFile dirs' name
+                        in apply (map implib import_libs)
+                       _         -> return Nothing
+
+     assumeDll   = return (DLL lib)
+     infixr `orElse`
+     f `orElse` g = f >>= maybe g return
+
+     apply []     = return Nothing
+     apply (x:xs) = do x' <- x
+                       if isJust x'
+                          then return x'
+                          else apply xs
+
+     platform = targetPlatform dflags
+     arch = platformArch platform
+     os = platformOS platform
+
+searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)
+searchForLibUsingGcc dflags so dirs = do
+   -- GCC does not seem to extend the library search path (using -L) when using
+   -- --print-file-name. So instead pass it a new base location.
+   str <- askLd dflags (map (FileOption "-B") dirs
+                          ++ [Option "--print-file-name", Option so])
+   let file = case lines str of
+                []  -> ""
+                l:_ -> l
+   if (file == so)
+      then return Nothing
+      else do b <- doesFileExist file -- file could be a folder (see #16063)
+              return (if b then Just file else Nothing)
+
+-- | Retrieve the list of search directory GCC and the System use to find
+--   libraries and components. See Note [Fork/Exec Windows].
+getGCCPaths :: DynFlags -> OS -> IO [FilePath]
+getGCCPaths dflags os
+  = case os of
+      OSMinGW32 ->
+        do gcc_dirs <- getGccSearchDirectory dflags "libraries"
+           sys_dirs <- getSystemDirectories
+           return $ nub $ gcc_dirs ++ sys_dirs
+      _         -> return []
+
+-- | Cache for the GCC search directories as this can't easily change
+--   during an invocation of GHC. (Maybe with some env. variable but we'll)
+--   deal with that highly unlikely scenario then.
+{-# NOINLINE gccSearchDirCache #-}
+gccSearchDirCache :: IORef [(String, [String])]
+gccSearchDirCache = unsafePerformIO $ newIORef []
+
+-- Note [Fork/Exec Windows]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~
+-- fork/exec is expensive on Windows, for each time we ask GCC for a library we
+-- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1.
+-- So instead get a list of location that GCC would search and use findDirs
+-- which hopefully is written in an optimized mannor to take advantage of
+-- caching. At the very least we remove the overhead of the fork/exec and waits
+-- which dominate a large percentage of startup time on Windows.
+getGccSearchDirectory :: DynFlags -> String -> IO [FilePath]
+getGccSearchDirectory dflags key = do
+    cache <- readIORef gccSearchDirCache
+    case lookup key cache of
+      Just x  -> return x
+      Nothing -> do
+        str <- askLd dflags [Option "--print-search-dirs"]
+        let line = dropWhile isSpace str
+            name = key ++ ": ="
+        if null line
+          then return []
+          else do let val = split $ find name line
+                  dirs <- filterM doesDirectoryExist val
+                  modifyIORef' gccSearchDirCache ((key, dirs):)
+                  return val
+      where split :: FilePath -> [FilePath]
+            split r = case break (==';') r of
+                        (s, []    ) -> [s]
+                        (s, (_:xs)) -> s : split xs
+
+            find :: String -> String -> String
+            find r x = let lst = lines x
+                           val = filter (r `isPrefixOf`) lst
+                       in if null val
+                             then []
+                             else case break (=='=') (head val) of
+                                     (_ , [])    -> []
+                                     (_, (_:xs)) -> xs
+
+-- | Get a list of system search directories, this to alleviate pressure on
+-- the findSysDll function.
+getSystemDirectories :: IO [FilePath]
+#if defined(mingw32_HOST_OS)
+getSystemDirectories = fmap (:[]) getSystemDirectory
+#else
+getSystemDirectories = return []
+#endif
+
+-- | Merge the given list of paths with those in the environment variable
+--   given. If the variable does not exist then just return the identity.
+addEnvPaths :: String -> [String] -> IO [String]
+addEnvPaths name list
+  = do -- According to POSIX (chapter 8.3) a zero-length prefix means current
+       -- working directory. Replace empty strings in the env variable with
+       -- `working_dir` (see also #14695).
+       working_dir <- getCurrentDirectory
+       values <- lookupEnv name
+       case values of
+         Nothing  -> return list
+         Just arr -> return $ list ++ splitEnv working_dir arr
+    where
+      splitEnv :: FilePath -> String -> [String]
+      splitEnv working_dir value =
+        case break (== envListSep) value of
+          (x, []    ) ->
+            [if null x then working_dir else x]
+          (x, (_:xs)) ->
+            (if null x then working_dir else x) : splitEnv working_dir xs
+#if defined(mingw32_HOST_OS)
+      envListSep = ';'
+#else
+      envListSep = ':'
+#endif
+
+-- ----------------------------------------------------------------------------
+-- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
+
+-- Darwin / MacOS X only: load a framework
+-- a framework is a dynamic library packaged inside a directory of the same
+-- name. They are searched for in different paths than normal libraries.
+loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String)
+loadFramework hsc_env extraPaths rootname
+   = do { either_dir <- tryIO getHomeDirectory
+        ; let homeFrameworkPath = case either_dir of
+                                  Left _ -> []
+                                  Right dir -> [dir </> "Library/Frameworks"]
+              ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
+        ; mb_fwk <- findFile ps fwk_file
+        ; case mb_fwk of
+            Just fwk_path -> loadDLL hsc_env fwk_path
+            Nothing       -> return (Just "not found") }
+                -- Tried all our known library paths, but dlopen()
+                -- has no built-in paths for frameworks: give up
+   where
+     fwk_file = rootname <.> "framework" </> rootname
+        -- sorry for the hardcoded paths, I hope they won't change anytime soon:
+     defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
+
+{- **********************************************************************
+
+                Helper functions
+
+  ********************************************************************* -}
+
+maybePutStr :: DynFlags -> String -> IO ()
+maybePutStr dflags s
+    = when (verbosity dflags > 1) $
+          putLogMsg dflags
+              NoReason
+              SevInteractive
+              noSrcSpan
+              (defaultUserStyle dflags)
+              (text s)
+
+maybePutStrLn :: DynFlags -> String -> IO ()
+maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n")
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
new file mode 100644
--- /dev/null
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -0,0 +1,1355 @@
+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash, UnboxedTuples #-}
+
+-----------------------------------------------------------------------------
+--
+-- GHC Interactive support for inspecting arbitrary closures at runtime
+--
+-- Pepe Iborra (supported by Google SoC) 2006
+--
+-----------------------------------------------------------------------------
+module RtClosureInspect(
+     -- * Entry points and types
+     cvObtainTerm,
+     cvReconstructType,
+     improveRTTIType,
+     Term(..),
+
+     -- * Utils
+     isFullyEvaluatedTerm,
+     termType, mapTermType, termTyCoVars,
+     foldTerm, TermFold(..),
+     cPprTerm, cPprTermBase,
+
+     constrClosToName -- exported to use in test T4891
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import GHCi
+import GHCi.RemoteTypes
+import HscTypes
+
+import DataCon
+import Type
+import RepType
+import qualified Unify as U
+import Var
+import TcRnMonad
+import TcType
+import TcMType
+import TcHsSyn ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) )
+import TcUnify
+import TcEnv
+
+import TyCon
+import Name
+import OccName
+import Module
+import IfaceEnv
+import Util
+import VarSet
+import BasicTypes       ( Boxity(..) )
+import TysPrim
+import PrelNames
+import TysWiredIn
+import DynFlags
+import Outputable as Ppr
+import GHC.Char
+import GHC.Exts.Heap
+import SMRep ( roundUpTo )
+
+import Control.Monad
+import Data.Maybe
+import Data.List
+#if defined(INTEGER_GMP)
+import GHC.Exts
+import Data.Array.Base
+import GHC.Integer.GMP.Internals
+#elif defined(INTEGER_SIMPLE)
+import GHC.Exts
+import GHC.Integer.Simple.Internals
+#endif
+import qualified Data.Sequence as Seq
+import Data.Sequence (viewl, ViewL(..))
+import Foreign
+import System.IO.Unsafe
+
+
+---------------------------------------------
+-- * A representation of semi evaluated Terms
+---------------------------------------------
+
+data Term = Term { ty        :: RttiType
+                 , dc        :: Either String DataCon
+                               -- Carries a text representation if the datacon is
+                               -- not exported by the .hi file, which is the case
+                               -- for private constructors in -O0 compiled libraries
+                 , val       :: ForeignHValue
+                 , subTerms  :: [Term] }
+
+          | Prim { ty        :: RttiType
+                 , valRaw    :: [Word] }
+
+          | Suspension { ctype    :: ClosureType
+                       , ty       :: RttiType
+                       , val      :: ForeignHValue
+                       , bound_to :: Maybe Name   -- Useful for printing
+                       }
+          | NewtypeWrap{       -- At runtime there are no newtypes, and hence no
+                               -- newtype constructors. A NewtypeWrap is just a
+                               -- made-up tag saying "heads up, there used to be
+                               -- a newtype constructor here".
+                         ty           :: RttiType
+                       , dc           :: Either String DataCon
+                       , wrapped_term :: Term }
+          | RefWrap    {       -- The contents of a reference
+                         ty           :: RttiType
+                       , wrapped_term :: Term }
+
+termType :: Term -> RttiType
+termType t = ty t
+
+isFullyEvaluatedTerm :: Term -> Bool
+isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
+isFullyEvaluatedTerm Prim {}            = True
+isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
+isFullyEvaluatedTerm RefWrap{wrapped_term=t}     = isFullyEvaluatedTerm t
+isFullyEvaluatedTerm _                  = False
+
+instance Outputable (Term) where
+ ppr t | Just doc <- cPprTerm cPprTermBase t = doc
+       | otherwise = panic "Outputable Term instance"
+
+----------------------------------------
+-- Runtime Closure information functions
+----------------------------------------
+
+isThunk :: GenClosure a -> Bool
+isThunk ThunkClosure{} = True
+isThunk APClosure{} = True
+isThunk APStackClosure{} = True
+isThunk _             = False
+
+-- Lookup the name in a constructor closure
+constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name)
+constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do
+   let occName = mkOccName OccName.dataName occ
+       modName = mkModule (stringToUnitId pkg) (mkModuleName mod)
+   Right `fmap` lookupOrigIO hsc_env modName occName
+constrClosToName _hsc_env clos =
+   return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos)))
+
+-----------------------------------
+-- * Traversals for Terms
+-----------------------------------
+type TermProcessor a b = RttiType -> Either String DataCon -> ForeignHValue -> [a] -> b
+
+data TermFold a = TermFold { fTerm        :: TermProcessor a a
+                           , fPrim        :: RttiType -> [Word] -> a
+                           , fSuspension  :: ClosureType -> RttiType -> ForeignHValue
+                                            -> Maybe Name -> a
+                           , fNewtypeWrap :: RttiType -> Either String DataCon
+                                            -> a -> a
+                           , fRefWrap     :: RttiType -> a -> a
+                           }
+
+
+data TermFoldM m a =
+                   TermFoldM {fTermM        :: TermProcessor a (m a)
+                            , fPrimM        :: RttiType -> [Word] -> m a
+                            , fSuspensionM  :: ClosureType -> RttiType -> ForeignHValue
+                                             -> Maybe Name -> m a
+                            , fNewtypeWrapM :: RttiType -> Either String DataCon
+                                            -> a -> m a
+                            , fRefWrapM     :: RttiType -> a -> m a
+                           }
+
+foldTerm :: TermFold a -> Term -> a
+foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
+foldTerm tf (Prim ty    v   ) = fPrim tf ty v
+foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
+foldTerm tf (NewtypeWrap ty dc t)  = fNewtypeWrap tf ty dc (foldTerm tf t)
+foldTerm tf (RefWrap ty t)         = fRefWrap tf ty (foldTerm tf t)
+
+
+foldTermM :: Monad m => TermFoldM m a -> Term -> m a
+foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v
+foldTermM tf (Prim ty    v   ) = fPrimM tf ty v
+foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b
+foldTermM tf (NewtypeWrap ty dc t)  = foldTermM tf t >>=  fNewtypeWrapM tf ty dc
+foldTermM tf (RefWrap ty t)         = foldTermM tf t >>= fRefWrapM tf ty
+
+idTermFold :: TermFold Term
+idTermFold = TermFold {
+              fTerm = Term,
+              fPrim = Prim,
+              fSuspension  = Suspension,
+              fNewtypeWrap = NewtypeWrap,
+              fRefWrap = RefWrap
+                      }
+
+mapTermType :: (RttiType -> Type) -> Term -> Term
+mapTermType f = foldTerm idTermFold {
+          fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,
+          fSuspension = \ct ty hval n ->
+                          Suspension ct (f ty) hval n,
+          fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,
+          fRefWrap    = \ty t -> RefWrap (f ty) t}
+
+mapTermTypeM :: Monad m =>  (RttiType -> m Type) -> Term -> m Term
+mapTermTypeM f = foldTermM TermFoldM {
+          fTermM       = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty'  dc hval tt,
+          fPrimM       = (return.) . Prim,
+          fSuspensionM = \ct ty hval n ->
+                          f ty >>= \ty' -> return $ Suspension ct ty' hval n,
+          fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,
+          fRefWrapM    = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}
+
+termTyCoVars :: Term -> TyCoVarSet
+termTyCoVars = foldTerm TermFold {
+            fTerm       = \ty _ _ tt   ->
+                          tyCoVarsOfType ty `unionVarSet` concatVarEnv tt,
+            fSuspension = \_ ty _ _ -> tyCoVarsOfType ty,
+            fPrim       = \ _ _ -> emptyVarSet,
+            fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t,
+            fRefWrap    = \ty t -> tyCoVarsOfType ty `unionVarSet` t}
+    where concatVarEnv = foldr unionVarSet emptyVarSet
+
+----------------------------------
+-- Pretty printing of terms
+----------------------------------
+
+type Precedence        = Int
+type TermPrinterM m    = Precedence -> Term -> m SDoc
+
+app_prec,cons_prec, max_prec ::Int
+max_prec  = 10
+app_prec  = max_prec
+cons_prec = 5 -- TODO Extract this info from GHC itself
+
+pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m
+pprTermM y p t = pprDeeper `liftM` ppr_termM y p t
+
+ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
+  tt_docs <- mapM (y app_prec) tt
+  return $ cparen (not (null tt) && p >= app_prec)
+                  (text dc_tag <+> pprDeeperList fsep tt_docs)
+
+ppr_termM y p Term{dc=Right dc, subTerms=tt}
+{-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
+  = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
+    <+> hsep (map (ppr_term1 True) tt)
+-} -- TODO Printing infix constructors properly
+  = do { tt_docs' <- mapM (y app_prec) tt
+       ; return $ ifPprDebug (show_tm tt_docs')
+                             (show_tm (dropList (dataConTheta dc) tt_docs'))
+                  -- Don't show the dictionary arguments to
+                  -- constructors unless -dppr-debug is on
+       }
+  where
+    show_tm tt_docs
+      | null tt_docs = ppr dc
+      | otherwise    = cparen (p >= app_prec) $
+                       sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)]
+
+ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
+ppr_termM y p RefWrap{wrapped_term=t}  = do
+  contents <- y app_prec t
+  return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)
+  -- The constructor name is wired in here ^^^ for the sake of simplicity.
+  -- I don't think mutvars are going to change in a near future.
+  -- In any case this is solely a presentation matter: MutVar# is
+  -- a datatype with no constructors, implemented by the RTS
+  -- (hence there is no way to obtain a datacon and print it).
+ppr_termM _ _ t = ppr_termM1 t
+
+
+ppr_termM1 :: Monad m => Term -> m SDoc
+ppr_termM1 Prim{valRaw=words, ty=ty} =
+    return $ repPrim (tyConAppTyCon ty) words
+ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =
+    return (char '_' <+> whenPprDebug (text "::" <> ppr ty))
+ppr_termM1 Suspension{ty=ty, bound_to=Just n}
+--  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")
+  | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty
+ppr_termM1 Term{}        = panic "ppr_termM1 - Term"
+ppr_termM1 RefWrap{}     = panic "ppr_termM1 - RefWrap"
+ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"
+
+pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t}
+  | Just (tc,_) <- tcSplitTyConApp_maybe ty
+  , ASSERT(isNewTyCon tc) True
+  , Just new_dc <- tyConSingleDataCon_maybe tc = do
+             real_term <- y max_prec t
+             return $ cparen (p >= app_prec) (ppr new_dc <+> real_term)
+pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap"
+
+-------------------------------------------------------
+-- Custom Term Pretty Printers
+-------------------------------------------------------
+
+-- We can want to customize the representation of a
+--  term depending on its type.
+-- However, note that custom printers have to work with
+--  type representations, instead of directly with types.
+-- We cannot use type classes here, unless we employ some
+--  typerep trickery (e.g. Weirich's RepLib tricks),
+--  which I didn't. Therefore, this code replicates a lot
+--  of what type classes provide for free.
+
+type CustomTermPrinter m = TermPrinterM m
+                         -> [Precedence -> Term -> (m (Maybe SDoc))]
+
+-- | Takes a list of custom printers with a explicit recursion knot and a term,
+-- and returns the output of the first successful printer, or the default printer
+cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc
+cPprTerm printers_ = go 0 where
+  printers = printers_ go
+  go prec t = do
+    let default_ = Just `liftM` pprTermM go prec t
+        mb_customDocs = [pp prec t | pp <- printers] ++ [default_]
+    mdoc <- firstJustM mb_customDocs
+    case mdoc of
+      Nothing -> panic "cPprTerm"
+      Just doc -> return $ cparen (prec>app_prec+1) doc
+
+  firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
+  firstJustM [] = return Nothing
+
+-- Default set of custom printers. Note that the recursion knot is explicit
+cPprTermBase :: forall m. Monad m => CustomTermPrinter m
+cPprTermBase y =
+  [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
+                                      . mapM (y (-1))
+                                      . subTerms)
+  , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
+           ppr_list
+  , ifTerm' (isTyCon intTyCon    . ty) ppr_int
+  , ifTerm' (isTyCon charTyCon   . ty) ppr_char
+  , ifTerm' (isTyCon floatTyCon  . ty) ppr_float
+  , ifTerm' (isTyCon doubleTyCon . ty) ppr_double
+  , ifTerm' (isIntegerTy         . ty) ppr_integer
+  ]
+ where
+   ifTerm :: (Term -> Bool)
+          -> (Precedence -> Term -> m SDoc)
+          -> Precedence -> Term -> m (Maybe SDoc)
+   ifTerm pred f = ifTerm' pred (\prec t -> Just <$> f prec t)
+
+   ifTerm' :: (Term -> Bool)
+          -> (Precedence -> Term -> m (Maybe SDoc))
+          -> Precedence -> Term -> m (Maybe SDoc)
+   ifTerm' pred f prec t@Term{}
+       | pred t    = f prec t
+   ifTerm' _ _ _ _  = return Nothing
+
+   isTupleTy ty    = fromMaybe False $ do
+     (tc,_) <- tcSplitTyConApp_maybe ty
+     return (isBoxedTupleTyCon tc)
+
+   isTyCon a_tc ty = fromMaybe False $ do
+     (tc,_) <- tcSplitTyConApp_maybe ty
+     return (a_tc == tc)
+
+   isIntegerTy ty = fromMaybe False $ do
+     (tc,_) <- tcSplitTyConApp_maybe ty
+     return (tyConName tc == integerTyConName)
+
+   ppr_int, ppr_char, ppr_float, ppr_double
+      :: Precedence -> Term -> m (Maybe SDoc)
+   ppr_int _ Term{subTerms=[Prim{valRaw=[w]}]} =
+      return (Just (Ppr.int (fromIntegral w)))
+   ppr_int _ _ = return Nothing
+
+   ppr_char _ Term{subTerms=[Prim{valRaw=[w]}]} =
+      return (Just (Ppr.pprHsChar (chr (fromIntegral w))))
+   ppr_char _ _ = return Nothing
+
+   ppr_float   _ Term{subTerms=[Prim{valRaw=[w]}]} = do
+      let f = unsafeDupablePerformIO $
+                alloca $ \p -> poke p w >> peek (castPtr p)
+      return (Just (Ppr.float f))
+   ppr_float _ _ = return Nothing
+
+   ppr_double  _ Term{subTerms=[Prim{valRaw=[w]}]} = do
+      let f = unsafeDupablePerformIO $
+                alloca $ \p -> poke p w >> peek (castPtr p)
+      return (Just (Ppr.double f))
+   -- let's assume that if we get two words, we're on a 32-bit
+   -- machine. There's no good way to get a DynFlags to check the word
+   -- size here.
+   ppr_double  _ Term{subTerms=[Prim{valRaw=[w1,w2]}]} = do
+      let f = unsafeDupablePerformIO $
+                alloca $ \p -> do
+                  poke p (fromIntegral w1 :: Word32)
+                  poke (p `plusPtr` 4) (fromIntegral w2 :: Word32)
+                  peek (castPtr p)
+      return (Just (Ppr.double f))
+   ppr_double _ _ = return Nothing
+
+   ppr_integer :: Precedence -> Term -> m (Maybe SDoc)
+#if defined(INTEGER_GMP)
+   -- Reconstructing Integers is a bit of a pain. This depends deeply
+   -- on the integer-gmp representation, so it'll break if that
+   -- changes (but there are several tests in
+   -- tests/ghci.debugger/scripts that will tell us if this is wrong).
+   --
+   --   data Integer
+   --     = S# Int#
+   --     | Jp# {-# UNPACK #-} !BigNat
+   --     | Jn# {-# UNPACK #-} !BigNat
+   --
+   --   data BigNat = BN# ByteArray#
+   --
+   ppr_integer _ Term{subTerms=[Prim{valRaw=[W# w]}]} =
+      return (Just (Ppr.integer (S# (word2Int# w))))
+   ppr_integer _ Term{dc=Right con,
+                      subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} = do
+      -- We don't need to worry about sizes that are not an integral
+      -- number of words, because luckily GMP uses arrays of words
+      -- (see GMP_LIMB_SHIFT).
+      let
+        !(UArray _ _ _ arr#) = listArray (0,length ws-1) ws
+        constr
+          | "Jp#" <- getOccString (dataConName con) = Jp#
+          | otherwise = Jn#
+      return (Just (Ppr.integer (constr (BN# arr#))))
+#elif defined(INTEGER_SIMPLE)
+   -- As with the GMP case, this depends deeply on the integer-simple
+   -- representation.
+   --
+   -- @
+   -- data Integer = Positive !Digits | Negative !Digits | Naught
+   --
+   -- data Digits = Some !Word# !Digits
+   --             | None
+   -- @
+   --
+   -- NB: the above has some type synonyms expanded out for the sake of brevity
+   ppr_integer _ Term{subTerms=[]} =
+      return (Just (Ppr.integer Naught))
+   ppr_integer _ Term{dc=Right con, subTerms=[digitTerm]}
+        | Just digits <- get_digits digitTerm
+        = return (Just (Ppr.integer (constr digits)))
+      where
+        get_digits :: Term -> Maybe Digits
+        get_digits Term{subTerms=[]} = Just None
+        get_digits Term{subTerms=[Prim{valRaw=[W# w]},t]}
+          = Some w <$> get_digits t
+        get_digits _ = Nothing
+
+        constr
+          | "Positive" <- getOccString (dataConName con) = Positive
+          | otherwise = Negative
+#endif
+   ppr_integer _ _ = return Nothing
+
+   --Note pprinting of list terms is not lazy
+   ppr_list :: Precedence -> Term -> m SDoc
+   ppr_list p (Term{subTerms=[h,t]}) = do
+       let elems      = h : getListTerms t
+           isConsLast = not (termType (last elems) `eqType` termType h)
+           is_string  = all (isCharTy . ty) elems
+           chars = [ chr (fromIntegral w)
+                   | Term{subTerms=[Prim{valRaw=[w]}]} <- elems ]
+
+       print_elems <- mapM (y cons_prec) elems
+       if is_string
+        then return (Ppr.doubleQuotes (Ppr.text chars))
+        else if isConsLast
+        then return $ cparen (p >= cons_prec)
+                    $ pprDeeperList fsep
+                    $ punctuate (space<>colon) print_elems
+        else return $ brackets
+                    $ pprDeeperList fcat
+                    $ punctuate comma print_elems
+
+        where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
+              getListTerms Term{subTerms=[]}    = []
+              getListTerms t@Suspension{}       = [t]
+              getListTerms t = pprPanic "getListTerms" (ppr t)
+   ppr_list _ _ = panic "doList"
+
+
+repPrim :: TyCon -> [Word] -> SDoc
+repPrim t = rep where
+   rep x
+    -- Char# uses native machine words, whereas Char's Storable instance uses
+    -- Int32, so we have to read it as an Int.
+    | t == charPrimTyCon             = text $ show (chr (build x :: Int))
+    | t == intPrimTyCon              = text $ show (build x :: Int)
+    | t == wordPrimTyCon             = text $ show (build x :: Word)
+    | t == floatPrimTyCon            = text $ show (build x :: Float)
+    | t == doublePrimTyCon           = text $ show (build x :: Double)
+    | t == int32PrimTyCon            = text $ show (build x :: Int32)
+    | t == word32PrimTyCon           = text $ show (build x :: Word32)
+    | t == int64PrimTyCon            = text $ show (build x :: Int64)
+    | t == word64PrimTyCon           = text $ show (build x :: Word64)
+    | t == addrPrimTyCon             = text $ show (nullPtr `plusPtr` build x)
+    | t == stablePtrPrimTyCon        = text "<stablePtr>"
+    | t == stableNamePrimTyCon       = text "<stableName>"
+    | t == statePrimTyCon            = text "<statethread>"
+    | t == proxyPrimTyCon            = text "<proxy>"
+    | t == realWorldTyCon            = text "<realworld>"
+    | t == threadIdPrimTyCon         = text "<ThreadId>"
+    | t == weakPrimTyCon             = text "<Weak>"
+    | t == arrayPrimTyCon            = text "<array>"
+    | t == smallArrayPrimTyCon       = text "<smallArray>"
+    | t == byteArrayPrimTyCon        = text "<bytearray>"
+    | t == mutableArrayPrimTyCon     = text "<mutableArray>"
+    | t == smallMutableArrayPrimTyCon = text "<smallMutableArray>"
+    | t == mutableByteArrayPrimTyCon = text "<mutableByteArray>"
+    | t == mutVarPrimTyCon           = text "<mutVar>"
+    | t == mVarPrimTyCon             = text "<mVar>"
+    | t == tVarPrimTyCon             = text "<tVar>"
+    | otherwise                      = char '<' <> ppr t <> char '>'
+    where build ww = unsafePerformIO $ withArray ww (peek . castPtr)
+--   This ^^^ relies on the representation of Haskell heap values being
+--   the same as in a C array.
+
+-----------------------------------
+-- Type Reconstruction
+-----------------------------------
+{-
+Type Reconstruction is type inference done on heap closures.
+The algorithm walks the heap generating a set of equations, which
+are solved with syntactic unification.
+A type reconstruction equation looks like:
+
+  <datacon reptype>  =  <actual heap contents>
+
+The full equation set is generated by traversing all the subterms, starting
+from a given term.
+
+The only difficult part is that newtypes are only found in the lhs of equations.
+Right hand sides are missing them. We can either (a) drop them from the lhs, or
+(b) reconstruct them in the rhs when possible.
+
+The function congruenceNewtypes takes a shot at (b)
+-}
+
+
+-- A (non-mutable) tau type containing
+-- existentially quantified tyvars.
+--    (since GHC type language currently does not support
+--     existentials, we leave these variables unquantified)
+type RttiType = Type
+
+-- An incomplete type as stored in GHCi:
+--  no polymorphism: no quantifiers & all tyvars are skolem.
+type GhciType = Type
+
+
+-- The Type Reconstruction monad
+--------------------------------
+type TR a = TcM a
+
+runTR :: HscEnv -> TR a -> IO a
+runTR hsc_env thing = do
+  mb_val <- runTR_maybe hsc_env thing
+  case mb_val of
+    Nothing -> error "unable to :print the term"
+    Just x  -> return x
+
+runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
+runTR_maybe hsc_env thing_inside
+  = do { (_errs, res) <- initTcInteractive hsc_env thing_inside
+       ; return res }
+
+-- | Term Reconstruction trace
+traceTR :: SDoc -> TR ()
+traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
+
+
+-- Semantically different to recoverM in TcRnMonad
+-- recoverM retains the errors in the first action,
+--  whereas recoverTc here does not
+recoverTR :: TR a -> TR a -> TR a
+recoverTR = tryTcDiscardingErrs
+
+trIO :: IO a -> TR a
+trIO = liftTcM . liftIO
+
+liftTcM :: TcM a -> TR a
+liftTcM = id
+
+newVar :: Kind -> TR TcType
+newVar = liftTcM . newFlexiTyVarTy
+
+newOpenVar :: TR TcType
+newOpenVar = liftTcM newOpenFlexiTyVarTy
+
+instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar])
+-- Instantiate fresh mutable type variables from some TyVars
+-- This function preserves the print-name, which helps error messages
+instTyVars tvs
+  = liftTcM $ fst <$> captureConstraints (newMetaTyVars tvs)
+
+type RttiInstantiation = [(TcTyVar, TyVar)]
+   -- Associates the typechecker-world meta type variables
+   -- (which are mutable and may be refined), to their
+   -- debugger-world RuntimeUnk counterparts.
+   -- If the TcTyVar has not been refined by the runtime type
+   -- elaboration, then we want to turn it back into the
+   -- original RuntimeUnk
+
+-- | Returns the instantiated type scheme ty', and the
+--   mapping from new (instantiated) -to- old (skolem) type variables
+instScheme :: QuantifiedType -> TR (TcType, RttiInstantiation)
+instScheme (tvs, ty)
+  = do { (subst, tvs') <- instTyVars tvs
+       ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]
+       ; return (substTy subst ty, rtti_inst) }
+
+applyRevSubst :: RttiInstantiation -> TR ()
+-- Apply the *reverse* substitution in-place to any un-filled-in
+-- meta tyvars.  This recovers the original debugger-world variable
+-- unless it has been refined by new information from the heap
+applyRevSubst pairs = liftTcM (mapM_ do_pair pairs)
+  where
+    do_pair (tc_tv, rtti_tv)
+      = do { tc_ty <- zonkTcTyVar tc_tv
+           ; case tcGetTyVar_maybe tc_ty of
+               Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv)
+               _                        -> return () }
+
+-- Adds a constraint of the form t1 == t2
+-- t1 is expected to come from walking the heap
+-- t2 is expected to come from a datacon signature
+-- Before unification, congruenceNewtypes needs to
+-- do its magic.
+addConstraint :: TcType -> TcType -> TR ()
+addConstraint actual expected = do
+    traceTR (text "add constraint:" <+> fsep [ppr actual, equals, ppr expected])
+    recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
+                                    text "with", ppr expected]) $
+      discardResult $
+      captureConstraints $
+      do { (ty1, ty2) <- congruenceNewtypes actual expected
+         ; unifyType Nothing ty1 ty2 }
+     -- TOMDO: what about the coercion?
+     -- we should consider family instances
+
+
+-- | Term reconstruction
+--
+-- Given a pointer to a heap object (`HValue`) and its type, build a `Term`
+-- representation of the object. Subterms (objects in the payload) are also
+-- built up to the given `max_depth`. After `max_depth` any subterms will appear
+-- as `Suspension`s. Any thunks found while traversing the object will be forced
+-- based on `force` parameter.
+--
+-- Types of terms will be refined based on constructors we find during term
+-- reconstruction. See `cvReconstructType` for an overview of how type
+-- reconstruction works.
+--
+cvObtainTerm
+    :: HscEnv
+    -> Int      -- ^ How many times to recurse for subterms
+    -> Bool     -- ^ Force thunks
+    -> RttiType -- ^ Type of the object to reconstruct
+    -> ForeignHValue   -- ^ Object to reconstruct
+    -> IO Term
+cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
+  -- we quantify existential tyvars as universal,
+  -- as this is needed to be able to manipulate
+  -- them properly
+   let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty
+       sigma_old_ty = mkInvForAllTys old_tvs old_tau
+   traceTR (text "Term reconstruction started with initial type " <> ppr old_ty)
+   term <-
+     if null old_tvs
+      then do
+        term  <- go max_depth sigma_old_ty sigma_old_ty hval
+        term' <- zonkTerm term
+        return $ fixFunDictionaries $ expandNewtypes term'
+      else do
+              (old_ty', rev_subst) <- instScheme quant_old_ty
+              my_ty <- newOpenVar
+              when (check1 quant_old_ty) (traceTR (text "check1 passed") >>
+                                          addConstraint my_ty old_ty')
+              term  <- go max_depth my_ty sigma_old_ty hval
+              new_ty <- zonkTcType (termType term)
+              if isMonomorphic new_ty || check2 (quantifyType new_ty) quant_old_ty
+                 then do
+                      traceTR (text "check2 passed")
+                      addConstraint new_ty old_ty'
+                      applyRevSubst rev_subst
+                      zterm' <- zonkTerm term
+                      return ((fixFunDictionaries . expandNewtypes) zterm')
+                 else do
+                      traceTR (text "check2 failed" <+> parens
+                                       (ppr term <+> text "::" <+> ppr new_ty))
+                      -- we have unsound types. Replace constructor types in
+                      -- subterms with tyvars
+                      zterm' <- mapTermTypeM
+                                 (\ty -> case tcSplitTyConApp_maybe ty of
+                                           Just (tc, _:_) | tc /= funTyCon
+                                               -> newOpenVar
+                                           _   -> return ty)
+                                 term
+                      zonkTerm zterm'
+   traceTR (text "Term reconstruction completed." $$
+            text "Term obtained: " <> ppr term $$
+            text "Type obtained: " <> ppr (termType term))
+   return term
+    where
+  go :: Int -> Type -> Type -> ForeignHValue -> TcM Term
+   -- I believe that my_ty should not have any enclosing
+   -- foralls, nor any free RuntimeUnk skolems;
+   -- that is partly what the quantifyType stuff achieved
+   --
+   -- [SPJ May 11] I don't understand the difference between my_ty and old_ty
+
+  go 0 my_ty _old_ty a = do
+    traceTR (text "Gave up reconstructing a term after" <>
+                  int max_depth <> text " steps")
+    clos <- trIO $ GHCi.getClosure hsc_env a
+    return (Suspension (tipe (info clos)) my_ty a Nothing)
+  go !max_depth my_ty old_ty a = do
+    let monomorphic = not(isTyVarTy my_ty)
+    -- This ^^^ is a convention. The ancestor tests for
+    -- monomorphism and passes a type instead of a tv
+    clos <- trIO $ GHCi.getClosure hsc_env a
+    case clos of
+-- Thunks we may want to force
+      t | isThunk t && force -> do
+         traceTR (text "Forcing a " <> text (show (fmap (const ()) t)))
+         liftIO $ GHCi.seqHValue hsc_env a
+         go (pred max_depth) my_ty old_ty a
+-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. If
+-- the indirection is a TSO or BLOCKING_QUEUE, we return the BLACKHOLE itself as
+-- the suspension so that entering it in GHCi will enter the BLACKHOLE instead
+-- of entering the TSO or BLOCKING_QUEUE (which leads to runtime panic).
+      BlackholeClosure{indirectee=ind} -> do
+         traceTR (text "Following a BLACKHOLE")
+         ind_clos <- trIO (GHCi.getClosure hsc_env ind)
+         let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing)
+         case ind_clos of
+           -- TSO and BLOCKING_QUEUE cases
+           BlockingQueueClosure{} -> return_bh_value
+           OtherClosure info _ _
+             | tipe info == TSO -> return_bh_value
+           UnsupportedClosure info
+             | tipe info == TSO -> return_bh_value
+           -- Otherwise follow the indirectee
+           -- (NOTE: This code will break if we support TSO in ghc-heap one day)
+           _ -> go max_depth my_ty old_ty ind
+-- We always follow indirections
+      IndClosure{indirectee=ind} -> do
+         traceTR (text "Following an indirection" )
+         go max_depth my_ty old_ty ind
+-- We also follow references
+      MutVarClosure{var=contents}
+         | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
+             -> do
+                  -- Deal with the MutVar# primitive
+                  -- It does not have a constructor at all,
+                  -- so we simulate the following one
+                  -- MutVar# :: contents_ty -> MutVar# s contents_ty
+         traceTR (text "Following a MutVar")
+         contents_tv <- newVar liftedTypeKind
+         MASSERT(isUnliftedType my_ty)
+         (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
+                            contents_ty (mkTyConApp tycon [world,contents_ty])
+         addConstraint (mkFunTy contents_tv my_ty) mutvar_ty
+         x <- go (pred max_depth) contents_tv contents_ty contents
+         return (RefWrap my_ty x)
+
+ -- The interesting case
+      ConstrClosure{ptrArgs=pArgs,dataArgs=dArgs} -> do
+        traceTR (text "entering a constructor " <> ppr dArgs <+>
+                      if monomorphic
+                        then parens (text "already monomorphic: " <> ppr my_ty)
+                        else Ppr.empty)
+        Right dcname <- liftIO $ constrClosToName hsc_env clos
+        (_,mb_dc)    <- tryTc (tcLookupDataCon dcname)
+        case mb_dc of
+          Nothing -> do -- This can happen for private constructors compiled -O0
+                        -- where the .hi descriptor does not export them
+                        -- In such case, we return a best approximation:
+                        --  ignore the unpointed args, and recover the pointeds
+                        -- This preserves laziness, and should be safe.
+                       traceTR (text "Not constructor" <+> ppr dcname)
+                       let dflags = hsc_dflags hsc_env
+                           tag = showPpr dflags dcname
+                       vars     <- replicateM (length pArgs)
+                                              (newVar liftedTypeKind)
+                       subTerms <- sequence $ zipWith (\x tv ->
+                           go (pred max_depth) tv tv x) pArgs vars
+                       return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
+          Just dc -> do
+            traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))
+            subTtypes <- getDataConArgTys dc my_ty
+            subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
+            return (Term my_ty (Right dc) a subTerms)
+
+      -- This is to support printing of Integers. It's not a general
+      -- mechanism by any means; in particular we lose the size in
+      -- bytes of the array.
+      ArrWordsClosure{bytes=b, arrWords=ws} -> do
+         traceTR (text "ByteArray# closure, size " <> ppr b)
+         return (Term my_ty (Left "ByteArray#") a [Prim my_ty ws])
+
+-- The otherwise case: can be a Thunk,AP,PAP,etc.
+      _ -> do
+         traceTR (text "Unknown closure:" <+>
+                  text (show (fmap (const ()) clos)))
+         return (Suspension (tipe (info clos)) my_ty a Nothing)
+
+  -- insert NewtypeWraps around newtypes
+  expandNewtypes = foldTerm idTermFold { fTerm = worker } where
+   worker ty dc hval tt
+     | Just (tc, args) <- tcSplitTyConApp_maybe ty
+     , isNewTyCon tc
+     , wrapped_type    <- newTyConInstRhs tc args
+     , Just dc'        <- tyConSingleDataCon_maybe tc
+     , t'              <- worker wrapped_type dc hval tt
+     = NewtypeWrap ty (Right dc') t'
+     | otherwise = Term ty dc hval tt
+
+
+   -- Avoid returning types where predicates have been expanded to dictionaries.
+  fixFunDictionaries = foldTerm idTermFold {fSuspension = worker} where
+      worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
+                          | otherwise  = Suspension ct ty hval n
+
+extractSubTerms :: (Type -> ForeignHValue -> TcM Term)
+                -> GenClosure ForeignHValue -> [Type] -> TcM [Term]
+extractSubTerms recurse clos = liftM thdOf3 . go 0 0
+  where
+    array = dataArgs clos
+
+    go ptr_i arr_i [] = return (ptr_i, arr_i, [])
+    go ptr_i arr_i (ty:tys)
+      | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
+      , isUnboxedTupleTyCon tc
+                -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+      = do (ptr_i, arr_i, terms0) <-
+               go ptr_i arr_i (dropRuntimeRepArgs elem_tys)
+           (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
+           return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
+      | otherwise
+      = case typePrimRepArgs ty of
+          [rep_ty] ->  do
+            (ptr_i, arr_i, term0)  <- go_rep ptr_i arr_i ty rep_ty
+            (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
+            return (ptr_i, arr_i, term0 : terms1)
+          rep_tys -> do
+           (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys
+           (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
+           return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
+
+    go_unary_types ptr_i arr_i [] = return (ptr_i, arr_i, [])
+    go_unary_types ptr_i arr_i (rep_ty:rep_tys) = do
+      tv <- newVar liftedTypeKind
+      (ptr_i, arr_i, term0)  <- go_rep ptr_i arr_i tv rep_ty
+      (ptr_i, arr_i, terms1) <- go_unary_types ptr_i arr_i rep_tys
+      return (ptr_i, arr_i, term0 : terms1)
+
+    go_rep ptr_i arr_i ty rep
+      | isGcPtrRep rep = do
+          t <- recurse ty $ (ptrArgs clos)!!ptr_i
+          return (ptr_i + 1, arr_i, t)
+      | otherwise = do
+          -- This is a bit involved since we allow packing multiple fields
+          -- within a single word. See also
+          -- StgCmmLayout.mkVirtHeapOffsetsWithPadding
+          dflags <- getDynFlags
+          let word_size = wORD_SIZE dflags
+              big_endian = wORDS_BIGENDIAN dflags
+              size_b = primRepSizeB dflags rep
+              -- Align the start offset (eg, 2-byte value should be 2-byte
+              -- aligned). But not more than to a word. The offset calculation
+              -- should be the same with the offset calculation in
+              -- StgCmmLayout.mkVirtHeapOffsetsWithPadding.
+              !aligned_idx = roundUpTo arr_i (min word_size size_b)
+              !new_arr_i = aligned_idx + size_b
+              ws | size_b < word_size =
+                     [index size_b aligned_idx word_size big_endian]
+                 | otherwise =
+                     let (q, r) = size_b `quotRem` word_size
+                     in ASSERT( r == 0 )
+                        [ array!!i
+                        | o <- [0.. q - 1]
+                        , let i = (aligned_idx `quot` word_size) + o
+                        ]
+          return (ptr_i, new_arr_i, Prim ty ws)
+
+    unboxedTupleTerm ty terms
+      = Term ty (Right (tupleDataCon Unboxed (length terms)))
+                (error "unboxedTupleTerm: no HValue for unboxed tuple") terms
+
+    -- Extract a sub-word sized field from a word
+    index item_size_b index_b word_size big_endian =
+        (word .&. (mask `shiftL` moveBytes)) `shiftR` moveBytes
+      where
+        mask :: Word
+        mask = case item_size_b of
+            1 -> 0xFF
+            2 -> 0xFFFF
+            4 -> 0xFFFFFFFF
+            _ -> panic ("Weird byte-index: " ++ show index_b)
+        (q,r) = index_b `quotRem` word_size
+        word = array!!q
+        moveBytes = if big_endian
+                    then word_size - (r + item_size_b) * 8
+                    else r * 8
+
+
+-- | Fast, breadth-first Type reconstruction
+--
+-- Given a heap object (`HValue`) and its (possibly polymorphic) type (usually
+-- obtained in GHCi), try to reconstruct a more monomorphic type of the object.
+-- This is used for improving type information in debugger. For example, if we
+-- have a polymorphic function:
+--
+--     sumNumList :: Num a => [a] -> a
+--     sumNumList [] = 0
+--     sumNumList (x : xs) = x + sumList xs
+--
+-- and add a breakpoint to it:
+--
+--     ghci> break sumNumList
+--     ghci> sumNumList ([0 .. 9] :: [Int])
+--
+-- ghci shows us more precise types than just `a`s:
+--
+--     Stopped in Main.sumNumList, debugger.hs:3:23-39
+--     _result :: Int = _
+--     x :: Int = 0
+--     xs :: [Int] = _
+--
+cvReconstructType
+    :: HscEnv
+    -> Int       -- ^ How many times to recurse for subterms
+    -> GhciType  -- ^ Type to refine
+    -> ForeignHValue  -- ^ Refine the type using this value
+    -> IO (Maybe Type)
+cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
+   traceTR (text "RTTI started with initial type " <> ppr old_ty)
+   let sigma_old_ty@(old_tvs, _) = quantifyType old_ty
+   new_ty <-
+       if null old_tvs
+        then return old_ty
+        else do
+          (old_ty', rev_subst) <- instScheme sigma_old_ty
+          my_ty <- newOpenVar
+          when (check1 sigma_old_ty) (traceTR (text "check1 passed") >>
+                                      addConstraint my_ty old_ty')
+          search (isMonomorphic `fmap` zonkTcType my_ty)
+                 (\(ty,a) -> go ty a)
+                 (Seq.singleton (my_ty, hval))
+                 max_depth
+          new_ty <- zonkTcType my_ty
+          if isMonomorphic new_ty || check2 (quantifyType new_ty) sigma_old_ty
+            then do
+                 traceTR (text "check2 passed" <+> ppr old_ty $$ ppr new_ty)
+                 addConstraint my_ty old_ty'
+                 applyRevSubst rev_subst
+                 zonkRttiType new_ty
+            else traceTR (text "check2 failed" <+> parens (ppr new_ty)) >>
+                 return old_ty
+   traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)
+   return new_ty
+    where
+--  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
+  search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>
+                                int max_depth <> text " steps")
+  search stop expand l d =
+    case viewl l of
+      EmptyL  -> return ()
+      x :< xx -> unlessM stop $ do
+                  new <- expand x
+                  search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
+
+   -- returns unification tasks,since we are going to want a breadth-first search
+  go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)]
+  go my_ty a = do
+    traceTR (text "go" <+> ppr my_ty)
+    clos <- trIO $ GHCi.getClosure hsc_env a
+    case clos of
+      BlackholeClosure{indirectee=ind} -> go my_ty ind
+      IndClosure{indirectee=ind} -> go my_ty ind
+      MutVarClosure{var=contents} -> do
+         tv'   <- newVar liftedTypeKind
+         world <- newVar liftedTypeKind
+         addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
+         return [(tv', contents)]
+      ConstrClosure{ptrArgs=pArgs} -> do
+        Right dcname <- liftIO $ constrClosToName hsc_env clos
+        traceTR (text "Constr1" <+> ppr dcname)
+        (_,mb_dc) <- tryTc (tcLookupDataCon dcname)
+        case mb_dc of
+          Nothing-> do
+            forM pArgs $ \x -> do
+              tv <- newVar liftedTypeKind
+              return (tv, x)
+
+          Just dc -> do
+            arg_tys <- getDataConArgTys dc my_ty
+            (_, itys) <- findPtrTyss 0 arg_tys
+            traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
+            return $ zipWith (\(_,ty) x -> (ty, x)) itys pArgs
+      _ -> return []
+
+findPtrTys :: Int  -- Current pointer index
+           -> Type -- Type
+           -> TR (Int, [(Int, Type)])
+findPtrTys i ty
+  | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
+  , isUnboxedTupleTyCon tc
+  = findPtrTyss i elem_tys
+
+  | otherwise
+  = case typePrimRep ty of
+      [rep] | isGcPtrRep rep -> return (i + 1, [(i, ty)])
+            | otherwise      -> return (i,     [])
+      prim_reps              ->
+        foldM (\(i, extras) prim_rep ->
+                if isGcPtrRep prim_rep
+                  then newVar liftedTypeKind >>= \tv -> return (i + 1, extras ++ [(i, tv)])
+                  else return (i, extras))
+              (i, []) prim_reps
+
+findPtrTyss :: Int
+            -> [Type]
+            -> TR (Int, [(Int, Type)])
+findPtrTyss i tys = foldM step (i, []) tys
+  where step (i, discovered) elem_ty = do
+          (i, extras) <- findPtrTys i elem_ty
+          return (i, discovered ++ extras)
+
+
+-- Compute the difference between a base type and the type found by RTTI
+-- improveType <base_type> <rtti_type>
+-- The types can contain skolem type variables, which need to be treated as normal vars.
+-- In particular, we want them to unify with things.
+improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TCvSubst
+improveRTTIType _ base_ty new_ty = U.tcUnifyTyKi base_ty new_ty
+
+getDataConArgTys :: DataCon -> Type -> TR [Type]
+-- Given the result type ty of a constructor application (D a b c :: ty)
+-- return the types of the arguments.  This is RTTI-land, so 'ty' might
+-- not be fully known.  Moreover, the arg types might involve existentials;
+-- if so, make up fresh RTTI type variables for them
+--
+-- I believe that con_app_ty should not have any enclosing foralls
+getDataConArgTys dc con_app_ty
+  = do { let rep_con_app_ty = unwrapType con_app_ty
+       ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty
+                   $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty)))
+       ; ASSERT( all isTyVar ex_tvs ) return ()
+                 -- ex_tvs can only be tyvars as data types in source
+                 -- Haskell cannot mention covar yet (Aug 2018)
+       ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs)
+       ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc))
+              -- See Note [Constructor arg types]
+       ; let con_arg_tys = substTys subst (dataConRepArgTys dc)
+       ; traceTR (text "getDataConArgTys 2" <+> (ppr rep_con_app_ty $$ ppr con_arg_tys $$ ppr subst))
+       ; return con_arg_tys }
+  where
+    univ_tvs = dataConUnivTyVars dc
+    ex_tvs   = dataConExTyCoVars dc
+
+{- Note [Constructor arg types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider a GADT (cf Trac #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 (mkFunTy r1' r2')
+-- TyconApp Inductive case; this is the interesting bit.
+    | Just (tycon_l, _) <- tcSplitTyConApp_maybe lhs
+    , Just (tycon_r, _) <- tcSplitTyConApp_maybe rhs
+    , tycon_l /= tycon_r
+    = upgrade tycon_l r
+
+    | otherwise = return r
+
+    where upgrade :: TyCon -> Type -> TR Type
+          upgrade new_tycon ty
+            | not (isNewTyCon new_tycon) = do
+              traceTR (text "(Upgrade) Not matching newtype evidence: " <>
+                       ppr new_tycon <> text " for " <> ppr ty)
+              return ty
+            | otherwise = do
+               traceTR (text "(Upgrade) upgraded " <> ppr ty <>
+                        text " in presence of newtype evidence " <> ppr new_tycon)
+               (_, vars) <- instTyVars (tyConTyVars new_tycon)
+               let ty' = mkTyConApp new_tycon (mkTyVarTys vars)
+                   rep_ty = unwrapType ty'
+               _ <- liftTcM (unifyType Nothing ty rep_ty)
+        -- assumes that reptype doesn't ^^^^ touch tyconApp args
+               return ty'
+
+
+zonkTerm :: Term -> TcM Term
+zonkTerm = foldTermM (TermFoldM
+             { fTermM = \ty dc v tt -> zonkRttiType ty    >>= \ty' ->
+                                       return (Term ty' dc v tt)
+             , fSuspensionM  = \ct ty v b -> zonkRttiType ty >>= \ty ->
+                                             return (Suspension ct ty v b)
+             , fNewtypeWrapM = \ty dc t -> zonkRttiType ty >>= \ty' ->
+                                           return$ NewtypeWrap ty' dc t
+             , fRefWrapM     = \ty t -> return RefWrap  `ap`
+                                        zonkRttiType ty `ap` return t
+             , fPrimM        = (return.) . Prim })
+
+zonkRttiType :: TcType -> TcM Type
+-- Zonk the type, replacing any unbound Meta tyvars
+-- by RuntimeUnk skolems, safely out of Meta-tyvar-land
+zonkRttiType ty= do { ze <- mkEmptyZonkEnv RuntimeUnkFlexi
+                    ; zonkTcTypeToTypeX ze ty }
+
+--------------------------------------------------------------------------------
+-- Restore Class predicates out of a representation type
+dictsView :: Type -> Type
+dictsView ty = ty
+
+
+-- Use only for RTTI types
+isMonomorphic :: RttiType -> Bool
+isMonomorphic ty = noExistentials && noUniversals
+ where (tvs, _, ty')  = tcSplitSigmaTy ty
+       noExistentials = noFreeVarsOfType ty'
+       noUniversals   = null tvs
+
+-- Use only for RTTI types
+isMonomorphicOnNonPhantomArgs :: RttiType -> Bool
+isMonomorphicOnNonPhantomArgs ty
+  | Just (tc, all_args) <- tcSplitTyConApp_maybe (unwrapType ty)
+  , phantom_vars  <- tyConPhantomTyVars tc
+  , concrete_args <- [ arg | (tyv,arg) <- tyConTyVars tc `zip` all_args
+                           , tyv `notElem` phantom_vars]
+  = all isMonomorphicOnNonPhantomArgs concrete_args
+  | Just (ty1, ty2) <- splitFunTy_maybe ty
+  = all isMonomorphicOnNonPhantomArgs [ty1,ty2]
+  | otherwise = isMonomorphic ty
+
+tyConPhantomTyVars :: TyCon -> [TyVar]
+tyConPhantomTyVars tc
+  | isAlgTyCon tc
+  , Just dcs <- tyConDataCons_maybe tc
+  , dc_vars  <- concatMap dataConUnivTyVars dcs
+  = tyConTyVars tc \\ dc_vars
+tyConPhantomTyVars _ = []
+
+type QuantifiedType = ([TyVar], Type)
+   -- Make the free type variables explicit
+   -- The returned Type should have no top-level foralls (I believe)
+
+quantifyType :: Type -> QuantifiedType
+-- Generalize the type: find all free and forall'd tyvars
+-- and return them, together with the type inside, which
+-- should not be a forall type.
+--
+-- Thus (quantifyType (forall a. a->[b]))
+-- returns ([a,b], a -> [b])
+
+quantifyType ty = ( filter isTyVar $
+                    tyCoVarsOfTypeWellScoped rho
+                  , rho)
+  where
+    (_tvs, rho) = tcSplitForAllTys ty
diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs
new file mode 100644
--- /dev/null
+++ b/compiler/hieFile/HieAst.hs
@@ -0,0 +1,1786 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+module HieAst ( mkHieFile ) where
+
+import GhcPrelude
+
+import Avail                      ( Avails )
+import Bag                        ( Bag, bagToList )
+import BasicTypes
+import BooleanFormula
+import Class                      ( FunDep )
+import CoreUtils                  ( exprType )
+import ConLike                    ( conLikeName )
+import Config                     ( cProjectVersion )
+import Desugar                    ( deSugarExpr )
+import FieldLabel
+import HsSyn
+import HscTypes
+import Module                     ( ModuleName, ml_hs_file )
+import MonadUtils                 ( concatMapM, liftIO )
+import Name                       ( Name, nameSrcSpan, setNameLoc )
+import SrcLoc
+import TcHsSyn                    ( hsLitType, hsPatType )
+import Type                       ( mkFunTys, Type )
+import TysWiredIn                 ( mkListTy, mkSumTy )
+import Var                        ( Id, Var, setVarName, varName, varType )
+import TcRnTypes
+import MkIface                    ( mkIfaceExports )
+
+import HieTypes
+import HieUtils
+
+import qualified Data.Array as A
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BSC
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Data                  ( Data, Typeable )
+import Data.List                  ( foldl1' )
+import Data.Maybe                 ( listToMaybe )
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.Class  ( lift )
+
+-- These synonyms match those defined in main/GHC.hs
+type RenamedSource     = ( HsGroup GhcRn, [LImportDecl GhcRn]
+                         , Maybe [(LIE GhcRn, Avails)]
+                         , Maybe LHsDocString )
+type TypecheckedSource = LHsBinds GhcTc
+
+
+{- Note [Name Remapping]
+The Typechecker introduces new names for mono names in AbsBinds.
+We don't care about the distinction between mono and poly bindings,
+so we replace all occurrences of the mono name with the poly name.
+-}
+newtype HieState = HieState
+  { name_remapping :: M.Map Name Id
+  }
+
+initState :: HieState
+initState = HieState M.empty
+
+class ModifyState a where -- See Note [Name Remapping]
+  addSubstitution :: a -> a -> HieState -> HieState
+
+instance ModifyState Name where
+  addSubstitution _ _ hs = hs
+
+instance ModifyState Id where
+  addSubstitution mono poly hs =
+    hs{name_remapping = M.insert (varName mono) poly (name_remapping hs)}
+
+modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState
+modifyState = foldr go id
+  where
+    go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f
+    go _ f = f
+
+type HieM = ReaderT HieState Hsc
+
+-- | Construct an 'HieFile' from the outputs of the typechecker.
+mkHieFile :: ModSummary
+          -> TcGblEnv
+          -> RenamedSource -> Hsc HieFile
+mkHieFile ms ts rs = do
+  let tc_binds = tcg_binds ts
+  (asts', arr) <- getCompressedAsts tc_binds rs
+  let Just src_file = ml_hs_file $ ms_location ms
+  src <- liftIO $ BS.readFile src_file
+  return $ HieFile
+      { hie_version = curHieVersion
+      , hie_ghc_version = BSC.pack cProjectVersion
+      , hie_hs_file = src_file
+      , hie_module = ms_mod ms
+      , hie_types = arr
+      , hie_asts = asts'
+      -- mkIfaceExports sorts the AvailInfos for stability
+      , hie_exports = mkIfaceExports (tcg_exports ts)
+      , hie_hs_src = src
+      }
+
+getCompressedAsts :: TypecheckedSource -> RenamedSource
+  -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
+getCompressedAsts ts rs = do
+  asts <- enrichHie ts rs
+  return $ compressTypes asts
+
+enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)
+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do
+    tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
+    rasts <- processGrp hsGrp
+    imps <- toHie $ filter (not . ideclImplicit . unLoc) imports
+    exps <- toHie $ fmap (map $ IEC Export . fst) exports
+    let spanFile children = case children of
+          [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)
+          _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)
+                             (realSrcSpanEnd   $ nodeSpan $ last children)
+
+        modulify xs =
+          Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs
+
+        asts = HieASTs
+          $ resolveTyVarScopes
+          $ M.map (modulify . mergeSortAsts)
+          $ M.fromListWith (++)
+          $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts
+
+        flat_asts = concat
+          [ tasts
+          , rasts
+          , imps
+          , exps
+          ]
+    return asts
+  where
+    processGrp grp = concatM
+      [ toHie $ fmap (RS ModuleScope ) hs_valds grp
+      , toHie $ hs_splcds grp
+      , toHie $ hs_tyclds grp
+      , toHie $ hs_derivds grp
+      , toHie $ hs_fixds grp
+      , toHie $ hs_defds grp
+      , toHie $ hs_fords grp
+      , toHie $ hs_warnds grp
+      , toHie $ hs_annds grp
+      , toHie $ hs_ruleds grp
+      ]
+
+getRealSpan :: SrcSpan -> Maybe Span
+getRealSpan (RealSrcSpan sp) = Just sp
+getRealSpan _ = Nothing
+
+grhss_span :: GRHSs p body -> SrcSpan
+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
+grhss_span (XGRHSs _) = error "XGRHS has no span"
+
+bindingsOnly :: [Context Name] -> [HieAST a]
+bindingsOnly [] = []
+bindingsOnly (C c n : xs) = case nameSrcSpan n of
+  RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs
+    where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)
+          info = mempty{identInfo = S.singleton c}
+  _ -> bindingsOnly xs
+
+concatM :: Monad m => [m [a]] -> m [a]
+concatM xs = concat <$> sequence xs
+
+{- Note [Capturing Scopes and other non local information]
+toHie is a local tranformation, but scopes of bindings cannot be known locally,
+hence we have to push the relevant info down into the binding nodes.
+We use the following types (*Context and *Scoped) to wrap things and
+carry the required info
+(Maybe Span) always carries the span of the entire binding, including rhs
+-}
+data Context a = C ContextInfo a -- Used for names and bindings
+
+data RContext a = RC RecFieldContext a
+data RFContext a = RFC RecFieldContext (Maybe Span) a
+-- ^ context for record fields
+
+data IEContext a = IEC IEType a
+-- ^ context for imports/exports
+
+data BindContext a = BC BindType Scope a
+-- ^ context for imports/exports
+
+data PatSynFieldContext a = PSC (Maybe Span) a
+-- ^ context for pattern synonym fields.
+
+data SigContext a = SC SigInfo a
+-- ^ context for type signatures
+
+data SigInfo = SI SigType (Maybe Span)
+
+data SigType = BindSig | ClassSig | InstSig
+
+data RScoped a = RS Scope a
+-- ^ Scope spans over everything to the right of a, (mostly) not
+-- including a itself
+-- (Includes a in a few special cases like recursive do bindings) or
+-- let/where bindings
+
+-- | Pattern scope
+data PScoped a = PS (Maybe Span)
+                    Scope       -- ^ use site of the pattern
+                    Scope       -- ^ pattern to the right of a, not including a
+                    a
+  deriving (Typeable, Data) -- Pattern Scope
+
+{- Note [TyVar Scopes]
+Due to -XScopedTypeVariables, type variables can be in scope quite far from
+their original binding. We resolve the scope of these type variables
+in a separate pass
+-}
+data TScoped a = TS TyVarScope a -- TyVarScope
+
+data TVScoped a = TVS TyVarScope Scope a -- TyVarScope
+-- ^ First scope remains constant
+-- Second scope is used to build up the scope of a tyvar over
+-- things to its right, ala RScoped
+
+-- | Each element scopes over the elements to the right
+listScopes :: Scope -> [Located a] -> [RScoped (Located a)]
+listScopes _ [] = []
+listScopes rhsScope [pat] = [RS rhsScope pat]
+listScopes rhsScope (pat : pats) = RS sc pat : pats'
+  where
+    pats'@((RS scope p):_) = listScopes rhsScope pats
+    sc = combineScopes scope $ mkScope $ getLoc p
+
+-- | 'listScopes' specialised to 'PScoped' things
+patScopes
+  :: Maybe Span
+  -> Scope
+  -> Scope
+  -> [LPat (GhcPass p)]
+  -> [PScoped (LPat (GhcPass p))]
+patScopes rsp useScope patScope xs =
+  map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $
+    listScopes patScope (map dL xs)
+
+-- | 'listScopes' specialised to 'TVScoped' things
+tvScopes
+  :: TyVarScope
+  -> Scope
+  -> [LHsTyVarBndr a]
+  -> [TVScoped (LHsTyVarBndr a)]
+tvScopes tvScope rhsScope xs =
+  map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs
+
+{- Note [Scoping Rules for SigPat]
+Explicitly quantified variables in pattern type signatures are not
+brought into scope in the rhs, but implicitly quantified variables
+are (HsWC and HsIB).
+This is unlike other signatures, where explicitly quantified variables
+are brought into the RHS Scope
+For example
+foo :: forall a. ...;
+foo = ... -- a is in scope here
+
+bar (x :: forall a. a -> a) = ... -- a is not in scope here
+--   ^ a is in scope here (pattern body)
+
+bax (x :: a) = ... -- a is in scope here
+Because of HsWC and HsIB pass on their scope to their children
+we must wrap the LHsType in pattern signatures in a
+Shielded explictly, so that the HsWC/HsIB scope is not passed
+on the the LHsType
+-}
+
+data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead
+
+type family ProtectedSig a where
+  ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs
+                                                GhcRn
+                                                (Shielded (LHsType GhcRn)))
+  ProtectedSig GhcTc = NoExt
+
+class ProtectSig a where
+  protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a
+
+instance (HasLoc a) => HasLoc (Shielded a) where
+  loc (SH _ a) = loc a
+
+instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where
+  toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)
+
+instance ProtectSig GhcTc where
+  protectSig _ _ = NoExt
+
+instance ProtectSig GhcRn where
+  protectSig sc (HsWC a (HsIB b sig)) =
+    HsWC a (HsIB b (SH sc sig))
+  protectSig _ _ = error "protectSig not given HsWC (HsIB)"
+
+class HasLoc a where
+  -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
+  -- know what their implicit bindings are scoping over
+  loc :: a -> SrcSpan
+
+instance HasLoc thing => HasLoc (TScoped thing) where
+  loc (TS _ a) = loc a
+
+instance HasLoc thing => HasLoc (PScoped thing) where
+  loc (PS _ _ _ a) = loc a
+
+instance HasLoc (LHsQTyVars GhcRn) where
+  loc (HsQTvs _ vs) = loc vs
+  loc _ = noSrcSpan
+
+instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where
+  loc (HsIB _ a) = loc a
+  loc _ = noSrcSpan
+
+instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where
+  loc (HsWC _ a) = loc a
+  loc _ = noSrcSpan
+
+instance HasLoc (Located a) where
+  loc (L l _) = l
+
+instance HasLoc a => HasLoc [a] where
+  loc [] = noSrcSpan
+  loc xs = foldl1' combineSrcSpans $ map loc xs
+
+instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where
+  loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]
+  loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans
+                                              [loc a, loc tvs, loc b, loc c]
+  loc _ = noSrcSpan
+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
+  loc (HsValArg tm) = loc tm
+  loc (HsTypeArg _ ty) = loc ty
+  loc (HsArgPar sp)  = sp
+
+instance HasLoc (HsDataDefn GhcRn) where
+  loc def@(HsDataDefn{}) = loc $ dd_cons def
+    -- Only used for data family instances, so we only need rhs
+    -- Most probably the rest will be unhelpful anyway
+  loc _ = noSrcSpan
+
+instance HasLoc (Pat (GhcPass a)) where
+  loc (dL -> L l _) = l
+
+-- | The main worker class
+class ToHie a where
+  toHie :: a -> HieM [HieAST Type]
+
+-- | Used to collect type info
+class Data a => HasType a where
+  getTypeNode :: a -> HieM [HieAST Type]
+
+instance (ToHie a) => ToHie [a] where
+  toHie = concatMapM toHie
+
+instance (ToHie a) => ToHie (Bag a) where
+  toHie = toHie . bagToList
+
+instance (ToHie a) => ToHie (Maybe a) where
+  toHie = maybe (pure []) toHie
+
+instance ToHie (Context (Located NoExt)) where
+  toHie _ = pure []
+
+instance ToHie (TScoped NoExt) where
+  toHie _ = pure []
+
+instance ToHie (IEContext (Located ModuleName)) where
+  toHie (IEC c (L (RealSrcSpan span) mname)) =
+      pure $ [Node (NodeInfo S.empty [] idents) span []]
+    where details = mempty{identInfo = S.singleton (IEThing c)}
+          idents = M.singleton (Left mname) details
+  toHie _ = pure []
+
+instance ToHie (Context (Located Var)) where
+  toHie c = case c of
+      C context (L (RealSrcSpan span) name')
+        -> do
+        m <- asks name_remapping
+        let name = M.findWithDefault name' (varName name') m
+        pure
+          [Node
+            (NodeInfo S.empty [] $
+              M.singleton (Right $ varName name)
+                          (IdentifierDetails (Just $ varType name')
+                                             (S.singleton context)))
+            span
+            []]
+      _ -> pure []
+
+instance ToHie (Context (Located Name)) where
+  toHie c = case c of
+      C context (L (RealSrcSpan span) name') -> do
+        m <- asks name_remapping
+        let name = case M.lookup name' m of
+              Just var -> varName var
+              Nothing -> name'
+        pure
+          [Node
+            (NodeInfo S.empty [] $
+              M.singleton (Right name)
+                          (IdentifierDetails Nothing
+                                             (S.singleton context)))
+            span
+            []]
+      _ -> pure []
+
+-- | Dummy instances - never called
+instance ToHie (TScoped (LHsSigWcType GhcTc)) where
+  toHie _ = pure []
+instance ToHie (TScoped (LHsWcType GhcTc)) where
+  toHie _ = pure []
+instance ToHie (SigContext (LSig GhcTc)) where
+  toHie _ = pure []
+instance ToHie (TScoped Type) where
+  toHie _ = pure []
+
+instance HasType (LHsBind GhcRn) where
+  getTypeNode (L spn bind) = makeNode bind spn
+
+instance HasType (LHsBind GhcTc) where
+  getTypeNode (L spn bind) = case bind of
+      FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)
+      _ -> makeNode bind spn
+
+instance HasType (LPat GhcRn) where
+  getTypeNode (dL -> L spn pat) = makeNode pat spn
+
+instance HasType (LPat GhcTc) where
+  getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)
+
+instance HasType (LHsExpr GhcRn) where
+  getTypeNode (L spn e) = makeNode e spn
+
+-- | This instance tries to construct 'HieAST' nodes which include the type of
+-- the expression. It is not yet possible to do this efficiently for all
+-- expression forms, so we skip filling in the type for those inputs.
+--
+-- 'HsApp', for example, doesn't have any type information available directly on
+-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then
+-- query the type of that. Yet both the desugaring call and the type query both
+-- involve recursive calls to the function and argument! This is particularly
+-- problematic when you realize that the HIE traversal will eventually visit
+-- those nodes too and ask for their types again.
+--
+-- Since the above is quite costly, we just skip cases where computing the
+-- expression's type is going to be expensive.
+--
+-- See #16233
+instance HasType (LHsExpr GhcTc) where
+  getTypeNode e@(L spn e') = lift $
+    -- Some expression forms have their type immediately available
+    let tyOpt = case e' of
+          HsLit _ l -> Just (hsLitType l)
+          HsOverLit _ o -> Just (overLitType o)
+
+          HsLam     _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
+          HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)
+          HsCase _  _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)
+
+          ExplicitList  ty _ _   -> Just (mkListTy ty)
+          ExplicitSum   ty _ _ _ -> Just (mkSumTy ty)
+          HsDo          ty _ _   -> Just ty
+          HsMultiIf     ty _     -> Just ty
+
+          _ -> Nothing
+
+    in
+    case tyOpt of
+      _ | skipDesugaring e' -> fallback
+        | otherwise -> do
+            hs_env <- Hsc $ \e w -> return (e,w)
+            (_,mbe) <- liftIO $ deSugarExpr hs_env e
+            maybe fallback (makeTypeNode e' spn . exprType) mbe
+    where
+      fallback = makeNode e' spn
+
+      matchGroupType :: MatchGroupTc -> Type
+      matchGroupType (MatchGroupTc args res) = mkFunTys args res
+
+      -- | Skip desugaring of these expressions for performance reasons.
+      --
+      -- See impact on Haddock output (esp. missing type annotations or links)
+      -- before marking more things here as 'False'. See impact on Haddock
+      -- performance before marking more things as 'True'.
+      skipDesugaring :: HsExpr a -> Bool
+      skipDesugaring e = case e of
+        HsVar{}        -> False
+        HsUnboundVar{} -> False
+        HsConLikeOut{} -> False
+        HsRecFld{}     -> False
+        HsOverLabel{}  -> False
+        HsIPVar{}      -> False
+        HsWrap{}       -> False
+        _              -> True
+
+instance ( ToHie (Context (Located (IdP a)))
+         , ToHie (MatchGroup a (LHsExpr a))
+         , ToHie (PScoped (LPat a))
+         , ToHie (GRHSs a (LHsExpr a))
+         , ToHie (LHsExpr a)
+         , ToHie (Located (PatSynBind a a))
+         , HasType (LHsBind a)
+         , ModifyState (IdP a)
+         , Data (HsBind a)
+         ) => ToHie (BindContext (LHsBind a)) where
+  toHie (BC context scope b@(L span bind)) =
+    concatM $ getTypeNode b : case bind of
+      FunBind{fun_id = name, fun_matches = matches} ->
+        [ toHie $ C (ValBind context scope $ getRealSpan span) name
+        , toHie matches
+        ]
+      PatBind{pat_lhs = lhs, pat_rhs = rhs} ->
+        [ toHie $ PS (getRealSpan span) scope NoScope lhs
+        , toHie rhs
+        ]
+      VarBind{var_rhs = expr} ->
+        [ toHie expr
+        ]
+      AbsBinds{abs_exports = xs, abs_binds = binds} ->
+        [ local (modifyState xs) $ -- Note [Name Remapping]
+            toHie $ fmap (BC context scope) binds
+        ]
+      PatSynBind _ psb ->
+        [ toHie $ L span psb -- PatSynBinds only occur at the top level
+        ]
+      XHsBindsLR _ -> []
+
+instance ( ToHie (LMatch a body)
+         ) => ToHie (MatchGroup a body) where
+  toHie mg = concatM $ case mg of
+    MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->
+      [ pure $ locOnly span
+      , toHie alts
+      ]
+    MG{} -> []
+    XMatchGroup _ -> []
+
+instance ( ToHie (Context (Located (IdP a)))
+         , ToHie (PScoped (LPat a))
+         , ToHie (HsPatSynDir a)
+         ) => ToHie (Located (PatSynBind a a)) where
+    toHie (L sp psb) = concatM $ case psb of
+      PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->
+        [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var
+        , toHie $ toBind dets
+        , toHie $ PS Nothing lhsScope NoScope pat
+        , toHie dir
+        ]
+        where
+          lhsScope = combineScopes varScope detScope
+          varScope = mkLScope var
+          detScope = case dets of
+            (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args
+            (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)
+            (RecCon r) -> foldr go NoScope r
+          go (RecordPatSynField a b) c = combineScopes c
+            $ combineScopes (mkLScope a) (mkLScope b)
+          detSpan = case detScope of
+            LocalScope a -> Just a
+            _ -> Nothing
+          toBind (PrefixCon args) = PrefixCon $ map (C Use) args
+          toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)
+          toBind (RecCon r) = RecCon $ map (PSC detSpan) r
+      XPatSynBind _ -> []
+
+instance ( ToHie (MatchGroup a (LHsExpr a))
+         ) => ToHie (HsPatSynDir a) where
+  toHie dir = case dir of
+    ExplicitBidirectional mg -> toHie mg
+    _ -> pure []
+
+instance ( a ~ GhcPass p
+         , ToHie body
+         , ToHie (HsMatchContext (NameOrRdrName (IdP a)))
+         , ToHie (PScoped (LPat a))
+         , ToHie (GRHSs a body)
+         , Data (Match a body)
+         ) => ToHie (LMatch (GhcPass p) body) where
+  toHie (L span m ) = concatM $ makeNode m span : case m of
+    Match{m_ctxt=mctx, m_pats = pats, m_grhss =  grhss } ->
+      [ toHie mctx
+      , let rhsScope = mkScope $ grhss_span grhss
+          in toHie $ patScopes Nothing rhsScope NoScope pats
+      , toHie grhss
+      ]
+    XMatch _ -> []
+
+instance ( ToHie (Context (Located a))
+         ) => ToHie (HsMatchContext a) where
+  toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name
+  toHie (StmtCtxt a) = toHie a
+  toHie _ = pure []
+
+instance ( ToHie (HsMatchContext a)
+         ) => ToHie (HsStmtContext a) where
+  toHie (PatGuard a) = toHie a
+  toHie (ParStmtCtxt a) = toHie a
+  toHie (TransStmtCtxt a) = toHie a
+  toHie _ = pure []
+
+instance ( a ~ GhcPass p
+         , ToHie (Context (Located (IdP a)))
+         , ToHie (RContext (HsRecFields a (PScoped (LPat a))))
+         , ToHie (LHsExpr a)
+         , ToHie (TScoped (LHsSigWcType a))
+         , ProtectSig a
+         , ToHie (TScoped (ProtectedSig a))
+         , HasType (LPat a)
+         , Data (HsSplice a)
+         ) => ToHie (PScoped (LPat (GhcPass p))) where
+  toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =
+    concatM $ getTypeNode lpat : case opat of
+      WildPat _ ->
+        []
+      VarPat _ lname ->
+        [ toHie $ C (PatternBind scope pscope rsp) lname
+        ]
+      LazyPat _ p ->
+        [ toHie $ PS rsp scope pscope p
+        ]
+      AsPat _ lname pat ->
+        [ toHie $ C (PatternBind scope
+                                 (combineScopes (mkLScope (dL pat)) pscope)
+                                 rsp)
+                    lname
+        , toHie $ PS rsp scope pscope pat
+        ]
+      ParPat _ pat ->
+        [ toHie $ PS rsp scope pscope pat
+        ]
+      BangPat _ pat ->
+        [ toHie $ PS rsp scope pscope pat
+        ]
+      ListPat _ pats ->
+        [ toHie $ patScopes rsp scope pscope pats
+        ]
+      TuplePat _ pats _ ->
+        [ toHie $ patScopes rsp scope pscope pats
+        ]
+      SumPat _ pat _ _ ->
+        [ toHie $ PS rsp scope pscope pat
+        ]
+      ConPatIn c dets ->
+        [ toHie $ C Use c
+        , toHie $ contextify dets
+        ]
+      ConPatOut {pat_con = con, pat_args = dets}->
+        [ toHie $ C Use $ fmap conLikeName con
+        , toHie $ contextify dets
+        ]
+      ViewPat _ expr pat ->
+        [ toHie expr
+        , toHie $ PS rsp scope pscope pat
+        ]
+      SplicePat _ sp ->
+        [ toHie $ L ospan sp
+        ]
+      LitPat _ _ ->
+        []
+      NPat _ _ _ _ ->
+        []
+      NPlusKPat _ n _ _ _ _ ->
+        [ toHie $ C (PatternBind scope pscope rsp) n
+        ]
+      SigPat _ pat sig ->
+        [ toHie $ PS rsp scope pscope pat
+        , let cscope = mkLScope (dL pat) in
+            toHie $ TS (ResolvedScopes [cscope, scope, pscope])
+                       (protectSig @a cscope sig)
+              -- See Note [Scoping Rules for SigPat]
+        ]
+      CoPat _ _ _ _ ->
+        []
+      XPat _ -> []
+    where
+      contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args
+      contextify (InfixCon a b) = InfixCon a' b'
+        where [a', b'] = patScopes rsp scope pscope [a,b]
+      contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r
+      contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a
+        where
+          go (RS fscope (L spn (HsRecField lbl pat pun))) =
+            L spn $ HsRecField lbl (PS rsp scope fscope pat) pun
+          scoped_fds = listScopes pscope fds
+
+instance ( ToHie body
+         , ToHie (LGRHS a body)
+         , ToHie (RScoped (LHsLocalBinds a))
+         ) => ToHie (GRHSs a body) where
+  toHie grhs = concatM $ case grhs of
+    GRHSs _ grhss binds ->
+     [ toHie grhss
+     , toHie $ RS (mkScope $ grhss_span grhs) binds
+     ]
+    XGRHSs _ -> []
+
+instance ( ToHie (Located body)
+         , ToHie (RScoped (GuardLStmt a))
+         , Data (GRHS a (Located body))
+         ) => ToHie (LGRHS a (Located body)) where
+  toHie (L span g) = concatM $ makeNode g span : case g of
+    GRHS _ guards body ->
+      [ toHie $ listScopes (mkLScope body) guards
+      , toHie body
+      ]
+    XGRHS _ -> []
+
+instance ( a ~ GhcPass p
+         , ToHie (Context (Located (IdP a)))
+         , HasType (LHsExpr a)
+         , ToHie (PScoped (LPat a))
+         , ToHie (MatchGroup a (LHsExpr a))
+         , ToHie (LGRHS a (LHsExpr a))
+         , ToHie (RContext (HsRecordBinds a))
+         , ToHie (RFContext (Located (AmbiguousFieldOcc a)))
+         , ToHie (ArithSeqInfo a)
+         , ToHie (LHsCmdTop a)
+         , ToHie (RScoped (GuardLStmt a))
+         , ToHie (RScoped (LHsLocalBinds a))
+         , ToHie (TScoped (LHsWcType (NoGhcTc a)))
+         , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))
+         , Data (HsExpr a)
+         , Data (HsSplice a)
+         , Data (HsTupArg a)
+         , Data (AmbiguousFieldOcc a)
+         ) => ToHie (LHsExpr (GhcPass p)) where
+  toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
+      HsVar _ (L _ var) ->
+        [ toHie $ C Use (L mspan var)
+             -- Patch up var location since typechecker removes it
+        ]
+      HsUnboundVar _ _ ->
+        []
+      HsConLikeOut _ con ->
+        [ toHie $ C Use $ L mspan $ conLikeName con
+        ]
+      HsRecFld _ fld ->
+        [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)
+        ]
+      HsOverLabel _ _ _ -> []
+      HsIPVar _ _ -> []
+      HsOverLit _ _ -> []
+      HsLit _ _ -> []
+      HsLam _ mg ->
+        [ toHie mg
+        ]
+      HsLamCase _ mg ->
+        [ toHie mg
+        ]
+      HsApp _ a b ->
+        [ toHie a
+        , toHie b
+        ]
+      HsAppType _ expr sig ->
+        [ toHie expr
+        , toHie $ TS (ResolvedScopes []) sig
+        ]
+      OpApp _ a b c ->
+        [ toHie a
+        , toHie b
+        , toHie c
+        ]
+      NegApp _ a _ ->
+        [ toHie a
+        ]
+      HsPar _ a ->
+        [ toHie a
+        ]
+      SectionL _ a b ->
+        [ toHie a
+        , toHie b
+        ]
+      SectionR _ a b ->
+        [ toHie a
+        , toHie b
+        ]
+      ExplicitTuple _ args _ ->
+        [ toHie args
+        ]
+      ExplicitSum _ _ _ expr ->
+        [ toHie expr
+        ]
+      HsCase _ expr matches ->
+        [ toHie expr
+        , toHie matches
+        ]
+      HsIf _ _ a b c ->
+        [ toHie a
+        , toHie b
+        , toHie c
+        ]
+      HsMultiIf _ grhss ->
+        [ toHie grhss
+        ]
+      HsLet _ binds expr ->
+        [ toHie $ RS (mkLScope expr) binds
+        , toHie expr
+        ]
+      HsDo _ _ (L ispan stmts) ->
+        [ pure $ locOnly ispan
+        , toHie $ listScopes NoScope stmts
+        ]
+      ExplicitList _ _ exprs ->
+        [ toHie exprs
+        ]
+      RecordCon {rcon_con_name = name, rcon_flds = binds}->
+        [ toHie $ C Use name
+        , toHie $ RC RecFieldAssign $ binds
+        ]
+      RecordUpd {rupd_expr = expr, rupd_flds = upds}->
+        [ toHie expr
+        , toHie $ map (RC RecFieldAssign) upds
+        ]
+      ExprWithTySig _ expr sig ->
+        [ toHie expr
+        , toHie $ TS (ResolvedScopes [mkLScope expr]) sig
+        ]
+      ArithSeq _ _ info ->
+        [ toHie info
+        ]
+      HsSCC _ _ _ expr ->
+        [ toHie expr
+        ]
+      HsCoreAnn _ _ _ expr ->
+        [ toHie expr
+        ]
+      HsProc _ pat cmdtop ->
+        [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat
+        , toHie cmdtop
+        ]
+      HsStatic _ expr ->
+        [ toHie expr
+        ]
+      HsArrApp _ a b _ _ ->
+        [ toHie a
+        , toHie b
+        ]
+      HsArrForm _ expr _ cmds ->
+        [ toHie expr
+        , toHie cmds
+        ]
+      HsTick _ _ expr ->
+        [ toHie expr
+        ]
+      HsBinTick _ _ _ expr ->
+        [ toHie expr
+        ]
+      HsTickPragma _ _ _ _ expr ->
+        [ toHie expr
+        ]
+      HsWrap _ _ a ->
+        [ toHie $ L mspan a
+        ]
+      HsBracket _ b ->
+        [ toHie b
+        ]
+      HsRnBracketOut _ b p ->
+        [ toHie b
+        , toHie p
+        ]
+      HsTcBracketOut _ b p ->
+        [ toHie b
+        , toHie p
+        ]
+      HsSpliceE _ x ->
+        [ toHie $ L mspan x
+        ]
+      EWildPat _ -> []
+      EAsPat _ a b ->
+        [ toHie $ C Use a
+        , toHie b
+        ]
+      EViewPat _ a b ->
+        [ toHie a
+        , toHie b
+        ]
+      ELazyPat _ a ->
+        [ toHie a
+        ]
+      XExpr _ -> []
+
+instance ( a ~ GhcPass p
+         , ToHie (LHsExpr a)
+         , Data (HsTupArg a)
+         ) => ToHie (LHsTupArg (GhcPass p)) where
+  toHie (L span arg) = concatM $ makeNode arg span : case arg of
+    Present _ expr ->
+      [ toHie expr
+      ]
+    Missing _ -> []
+    XTupArg _ -> []
+
+instance ( a ~ GhcPass p
+         , ToHie (PScoped (LPat a))
+         , ToHie (LHsExpr a)
+         , ToHie (SigContext (LSig a))
+         , ToHie (RScoped (LHsLocalBinds a))
+         , ToHie (RScoped (ApplicativeArg a))
+         , ToHie (Located body)
+         , Data (StmtLR a a (Located body))
+         , Data (StmtLR a a (Located (HsExpr a)))
+         ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where
+  toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of
+      LastStmt _ body _ _ ->
+        [ toHie body
+        ]
+      BindStmt _ pat body _ _ ->
+        [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat
+        , toHie body
+        ]
+      ApplicativeStmt _ stmts _ ->
+        [ concatMapM (toHie . RS scope . snd) stmts
+        ]
+      BodyStmt _ body _ _ ->
+        [ toHie body
+        ]
+      LetStmt _ binds ->
+        [ toHie $ RS scope binds
+        ]
+      ParStmt _ parstmts _ _ ->
+        [ concatMapM (\(ParStmtBlock _ stmts _ _) ->
+                          toHie $ listScopes NoScope stmts)
+                     parstmts
+        ]
+      TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->
+        [ toHie $ listScopes scope stmts
+        , toHie using
+        , toHie by
+        ]
+      RecStmt {recS_stmts = stmts} ->
+        [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts
+        ]
+      XStmtLR _ -> []
+
+instance ( ToHie (LHsExpr a)
+         , ToHie (PScoped (LPat a))
+         , ToHie (BindContext (LHsBind a))
+         , ToHie (SigContext (LSig a))
+         , ToHie (RScoped (HsValBindsLR a a))
+         , Data (HsLocalBinds a)
+         ) => ToHie (RScoped (LHsLocalBinds a)) where
+  toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of
+      EmptyLocalBinds _ -> []
+      HsIPBinds _ _ -> []
+      HsValBinds _ valBinds ->
+        [ toHie $ RS (combineScopes scope $ mkScope sp)
+                      valBinds
+        ]
+      XHsLocalBindsLR _ -> []
+
+instance ( ToHie (BindContext (LHsBind a))
+         , ToHie (SigContext (LSig a))
+         , ToHie (RScoped (XXValBindsLR a a))
+         ) => ToHie (RScoped (HsValBindsLR a a)) where
+  toHie (RS sc v) = concatM $ case v of
+    ValBinds _ binds sigs ->
+      [ toHie $ fmap (BC RegularBind sc) binds
+      , toHie $ fmap (SC (SI BindSig Nothing)) sigs
+      ]
+    XValBindsLR x -> [ toHie $ RS sc x ]
+
+instance ToHie (RScoped (NHsValBindsLR GhcTc)) where
+  toHie (RS sc (NValBinds binds sigs)) = concatM $
+    [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
+    , toHie $ fmap (SC (SI BindSig Nothing)) sigs
+    ]
+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where
+  toHie (RS sc (NValBinds binds sigs)) = concatM $
+    [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)
+    , toHie $ fmap (SC (SI BindSig Nothing)) sigs
+    ]
+
+instance ( ToHie (RContext (LHsRecField a arg))
+         ) => ToHie (RContext (HsRecFields a arg)) where
+  toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields
+
+instance ( ToHie (RFContext (Located label))
+         , ToHie arg
+         , HasLoc arg
+         , Data label
+         , Data arg
+         ) => ToHie (RContext (LHsRecField' label arg)) where
+  toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of
+    HsRecField label expr _ ->
+      [ toHie $ RFC c (getRealSpan $ loc expr) label
+      , toHie expr
+      ]
+
+removeDefSrcSpan :: Name -> Name
+removeDefSrcSpan n = setNameLoc n noSrcSpan
+
+instance ToHie (RFContext (LFieldOcc GhcRn)) where
+  toHie (RFC c rhs (L nspan f)) = concatM $ case f of
+    FieldOcc name _ ->
+      [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)
+      ]
+    XFieldOcc _ -> []
+
+instance ToHie (RFContext (LFieldOcc GhcTc)) where
+  toHie (RFC c rhs (L nspan f)) = concatM $ case f of
+    FieldOcc var _ ->
+      let var' = setVarName var (removeDefSrcSpan $ varName var)
+      in [ toHie $ C (RecField c rhs) (L nspan var')
+         ]
+    XFieldOcc _ -> []
+
+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where
+  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
+    Unambiguous name _ ->
+      [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name
+      ]
+    Ambiguous _name _ ->
+      [ ]
+    XAmbiguousFieldOcc _ -> []
+
+instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where
+  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
+    Unambiguous var _ ->
+      let var' = setVarName var (removeDefSrcSpan $ varName var)
+      in [ toHie $ C (RecField c rhs) (L nspan var')
+         ]
+    Ambiguous var _ ->
+      let var' = setVarName var (removeDefSrcSpan $ varName var)
+      in [ toHie $ C (RecField c rhs) (L nspan var')
+         ]
+    XAmbiguousFieldOcc _ -> []
+
+instance ( a ~ GhcPass p
+         , ToHie (PScoped (LPat a))
+         , ToHie (BindContext (LHsBind a))
+         , ToHie (LHsExpr a)
+         , ToHie (SigContext (LSig a))
+         , ToHie (RScoped (HsValBindsLR a a))
+         , Data (StmtLR a a (Located (HsExpr a)))
+         , Data (HsLocalBinds a)
+         ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where
+  toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM
+    [ toHie $ PS Nothing sc NoScope pat
+    , toHie expr
+    ]
+  toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM
+    [ toHie $ listScopes NoScope stmts
+    , toHie $ PS Nothing sc NoScope pat
+    ]
+  toHie (RS _ (XApplicativeArg _)) = pure []
+
+instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where
+  toHie (PrefixCon args) = toHie args
+  toHie (RecCon rec) = toHie rec
+  toHie (InfixCon a b) = concatM [ toHie a, toHie b]
+
+instance ( ToHie (LHsCmd a)
+         , Data  (HsCmdTop a)
+         ) => ToHie (LHsCmdTop a) where
+  toHie (L span top) = concatM $ makeNode top span : case top of
+    HsCmdTop _ cmd ->
+      [ toHie cmd
+      ]
+    XCmdTop _ -> []
+
+instance ( a ~ GhcPass p
+         , ToHie (PScoped (LPat a))
+         , ToHie (BindContext (LHsBind a))
+         , ToHie (LHsExpr a)
+         , ToHie (MatchGroup a (LHsCmd a))
+         , ToHie (SigContext (LSig a))
+         , ToHie (RScoped (HsValBindsLR a a))
+         , Data (HsCmd a)
+         , Data (HsCmdTop a)
+         , Data (StmtLR a a (Located (HsCmd a)))
+         , Data (HsLocalBinds a)
+         , Data (StmtLR a a (Located (HsExpr a)))
+         ) => ToHie (LHsCmd (GhcPass p)) where
+  toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of
+      HsCmdArrApp _ a b _ _ ->
+        [ toHie a
+        , toHie b
+        ]
+      HsCmdArrForm _ a _ _ cmdtops ->
+        [ toHie a
+        , toHie cmdtops
+        ]
+      HsCmdApp _ a b ->
+        [ toHie a
+        , toHie b
+        ]
+      HsCmdLam _ mg ->
+        [ toHie mg
+        ]
+      HsCmdPar _ a ->
+        [ toHie a
+        ]
+      HsCmdCase _ expr alts ->
+        [ toHie expr
+        , toHie alts
+        ]
+      HsCmdIf _ _ a b c ->
+        [ toHie a
+        , toHie b
+        , toHie c
+        ]
+      HsCmdLet _ binds cmd' ->
+        [ toHie $ RS (mkLScope cmd') binds
+        , toHie cmd'
+        ]
+      HsCmdDo _ (L ispan stmts) ->
+        [ pure $ locOnly ispan
+        , toHie $ listScopes NoScope stmts
+        ]
+      HsCmdWrap _ _ _ -> []
+      XCmd _ -> []
+
+instance ToHie (TyClGroup GhcRn) where
+  toHie (TyClGroup _ classes roles instances) = concatM
+    [ toHie classes
+    , toHie roles
+    , toHie instances
+    ]
+  toHie (XTyClGroup _) = pure []
+
+instance ToHie (LTyClDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      FamDecl {tcdFam = fdecl} ->
+        [ toHie (L span fdecl)
+        ]
+      SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->
+        [ toHie $ C (Decl SynDec $ getRealSpan span) name
+        , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars
+        , toHie typ
+        ]
+      DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->
+        [ toHie $ C (Decl DataDec $ getRealSpan span) name
+        , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars
+        , toHie defn
+        ]
+        where
+          quant_scope = mkLScope $ dd_ctxt defn
+          rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc
+          sig_sc = maybe NoScope mkLScope $ dd_kindSig defn
+          con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn
+          deriv_sc = mkLScope $ dd_derivs defn
+      ClassDecl { tcdCtxt = context
+                , tcdLName = name
+                , tcdTyVars = vars
+                , tcdFDs = deps
+                , tcdSigs = sigs
+                , tcdMeths = meths
+                , tcdATs = typs
+                , tcdATDefs = deftyps
+                } ->
+        [ toHie $ C (Decl ClassDec $ getRealSpan span) name
+        , toHie context
+        , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars
+        , toHie deps
+        , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs
+        , toHie $ fmap (BC InstanceBind ModuleScope) meths
+        , toHie typs
+        , concatMapM (pure . locOnly . getLoc) deftyps
+        , toHie $ map (go . unLoc) deftyps
+        ]
+        where
+          context_scope = mkLScope context
+          rhs_scope = foldl1' combineScopes $ map mkScope
+            [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
+
+          go :: TyFamDefltEqn GhcRn
+             -> FamEqn GhcRn (TScoped (LHsQTyVars GhcRn)) (LHsType GhcRn)
+          go (FamEqn a var bndrs pat b rhs) =
+             FamEqn a var bndrs (TS (ResolvedScopes [mkLScope rhs]) pat) b rhs
+          go (XFamEqn NoExt) = XFamEqn NoExt
+      XTyClDecl _ -> []
+
+instance ToHie (LFamilyDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      FamilyDecl _ info name vars _ sig inj ->
+        [ toHie $ C (Decl FamDec $ getRealSpan span) name
+        , toHie $ TS (ResolvedScopes [rhsSpan]) vars
+        , toHie info
+        , toHie $ RS injSpan sig
+        , toHie inj
+        ]
+        where
+          rhsSpan = sigSpan `combineScopes` injSpan
+          sigSpan = mkScope $ getLoc sig
+          injSpan = maybe NoScope (mkScope . getLoc) inj
+      XFamilyDecl _ -> []
+
+instance ToHie (FamilyInfo GhcRn) where
+  toHie (ClosedTypeFamily (Just eqns)) = concatM $
+    [ concatMapM (pure . locOnly . getLoc) eqns
+    , toHie $ map go eqns
+    ]
+    where
+      go (L l ib) = TS (ResolvedScopes [mkScope l]) ib
+  toHie _ = pure []
+
+instance ToHie (RScoped (LFamilyResultSig GhcRn)) where
+  toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of
+      NoSig _ ->
+        []
+      KindSig _ k ->
+        [ toHie k
+        ]
+      TyVarSig _ bndr ->
+        [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr
+        ]
+      XFamilyResultSig _ -> []
+
+instance ToHie (Located (FunDep (Located Name))) where
+  toHie (L span fd@(lhs, rhs)) = concatM $
+    [ makeNode fd span
+    , toHie $ map (C Use) lhs
+    , toHie $ map (C Use) rhs
+    ]
+
+instance (ToHie pats, ToHie rhs, HasLoc pats, HasLoc rhs)
+    => ToHie (TScoped (FamEqn GhcRn pats rhs)) where
+  toHie (TS _ f) = toHie f
+
+instance ( ToHie pats
+         , ToHie rhs
+         , HasLoc pats
+         , HasLoc rhs
+         ) => ToHie (FamEqn GhcRn pats rhs) where
+  toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $
+    [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var
+    , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
+    , toHie pats
+    , toHie rhs
+    ]
+    where scope = combineScopes patsScope rhsScope
+          patsScope = mkScope (loc pats)
+          rhsScope = mkScope (loc rhs)
+  toHie (XFamEqn _) = pure []
+
+instance ToHie (LInjectivityAnn GhcRn) where
+  toHie (L span ann) = concatM $ makeNode ann span : case ann of
+      InjectivityAnn lhs rhs ->
+        [ toHie $ C Use lhs
+        , toHie $ map (C Use) rhs
+        ]
+
+instance ToHie (HsDataDefn GhcRn) where
+  toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM
+    [ toHie ctx
+    , toHie mkind
+    , toHie cons
+    , toHie derivs
+    ]
+  toHie (XHsDataDefn _) = pure []
+
+instance ToHie (HsDeriving GhcRn) where
+  toHie (L span clauses) = concatM
+    [ pure $ locOnly span
+    , toHie clauses
+    ]
+
+instance ToHie (LHsDerivingClause GhcRn) where
+  toHie (L span cl) = concatM $ makeNode cl span : case cl of
+      HsDerivingClause _ strat (L ispan tys) ->
+        [ toHie strat
+        , pure $ locOnly ispan
+        , toHie $ map (TS (ResolvedScopes [])) tys
+        ]
+      XHsDerivingClause _ -> []
+
+instance ToHie (Located (DerivStrategy GhcRn)) where
+  toHie (L span strat) = concatM $ makeNode strat span : case strat of
+      StockStrategy -> []
+      AnyclassStrategy -> []
+      NewtypeStrategy -> []
+      ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]
+
+instance ToHie (Located OverlapMode) where
+  toHie (L span _) = pure $ locOnly span
+
+instance ToHie (LConDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      ConDeclGADT { con_names = names, con_qvars = qvars
+                  , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->
+        [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names
+        , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars
+        , toHie ctx
+        , toHie args
+        , toHie typ
+        ]
+        where
+          rhsScope = combineScopes argsScope tyScope
+          ctxScope = maybe NoScope mkLScope ctx
+          argsScope = condecl_scope args
+          tyScope = mkLScope typ
+      ConDeclH98 { con_name = name, con_ex_tvs = qvars
+                 , con_mb_cxt = ctx, con_args = dets } ->
+        [ toHie $ C (Decl ConDec $ getRealSpan span) name
+        , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars
+        , toHie ctx
+        , toHie dets
+        ]
+        where
+          rhsScope = combineScopes ctxScope argsScope
+          ctxScope = maybe NoScope mkLScope ctx
+          argsScope = condecl_scope dets
+      XConDecl _ -> []
+    where condecl_scope args = case args of
+            PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs
+            InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)
+            RecCon x -> mkLScope x
+
+instance ToHie (Located [LConDeclField GhcRn]) where
+  toHie (L span decls) = concatM $
+    [ pure $ locOnly span
+    , toHie decls
+    ]
+
+instance ( HasLoc thing
+         , ToHie (TScoped thing)
+         ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where
+  toHie (TS sc (HsIB ibrn a)) = concatM $
+      [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn
+      , toHie $ TS sc a
+      ]
+    where span = loc a
+  toHie (TS _ (XHsImplicitBndrs _)) = pure []
+
+instance ( HasLoc thing
+         , ToHie (TScoped thing)
+         ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where
+  toHie (TS sc (HsWC names a)) = concatM $
+      [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names
+      , toHie $ TS sc a
+      ]
+    where span = loc a
+  toHie (TS _ (XHsWildCardBndrs _)) = pure []
+
+instance ToHie (SigContext (LSig GhcRn)) where
+  toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of
+      TypeSig _ names typ ->
+        [ toHie $ map (C TyDecl) names
+        , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
+        ]
+      PatSynSig _ names typ ->
+        [ toHie $ map (C TyDecl) names
+        , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ
+        ]
+      ClassOpSig _ _ names typ ->
+        [ case styp of
+            ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names
+            _  -> toHie $ map (C $ TyDecl) names
+        , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ
+        ]
+      IdSig _ _ -> []
+      FixSig _ fsig ->
+        [ toHie $ L sp fsig
+        ]
+      InlineSig _ name _ ->
+        [ toHie $ (C Use) name
+        ]
+      SpecSig _ name typs _ ->
+        [ toHie $ (C Use) name
+        , toHie $ map (TS (ResolvedScopes [])) typs
+        ]
+      SpecInstSig _ _ typ ->
+        [ toHie $ TS (ResolvedScopes []) typ
+        ]
+      MinimalSig _ _ form ->
+        [ toHie form
+        ]
+      SCCFunSig _ _ name mtxt ->
+        [ toHie $ (C Use) name
+        , pure $ maybe [] (locOnly . getLoc) mtxt
+        ]
+      CompleteMatchSig _ _ (L ispan names) typ ->
+        [ pure $ locOnly ispan
+        , toHie $ map (C Use) names
+        , toHie $ fmap (C Use) typ
+        ]
+      XSig _ -> []
+
+instance ToHie (LHsType GhcRn) where
+  toHie x = toHie $ TS (ResolvedScopes []) x
+
+instance ToHie (TScoped (LHsType GhcRn)) where
+  toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of
+      HsForAllTy _ bndrs body ->
+        [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs
+        , toHie body
+        ]
+      HsQualTy _ ctx body ->
+        [ toHie ctx
+        , toHie body
+        ]
+      HsTyVar _ _ var ->
+        [ toHie $ C Use var
+        ]
+      HsAppTy _ a b ->
+        [ toHie a
+        , toHie b
+        ]
+      HsAppKindTy _ ty ki ->
+        [ toHie ty
+        , toHie $ TS (ResolvedScopes []) ki
+        ]
+      HsFunTy _ a b ->
+        [ toHie a
+        , toHie b
+        ]
+      HsListTy _ a ->
+        [ toHie a
+        ]
+      HsTupleTy _ _ tys ->
+        [ toHie tys
+        ]
+      HsSumTy _ tys ->
+        [ toHie tys
+        ]
+      HsOpTy _ a op b ->
+        [ toHie a
+        , toHie $ C Use op
+        , toHie b
+        ]
+      HsParTy _ a ->
+        [ toHie a
+        ]
+      HsIParamTy _ ip ty ->
+        [ toHie ip
+        , toHie ty
+        ]
+      HsKindSig _ a b ->
+        [ toHie a
+        , toHie b
+        ]
+      HsSpliceTy _ a ->
+        [ toHie $ L span a
+        ]
+      HsDocTy _ a _ ->
+        [ toHie a
+        ]
+      HsBangTy _ _ ty ->
+        [ toHie ty
+        ]
+      HsRecTy _ fields ->
+        [ toHie fields
+        ]
+      HsExplicitListTy _ _ tys ->
+        [ toHie tys
+        ]
+      HsExplicitTupleTy _ tys ->
+        [ toHie tys
+        ]
+      HsTyLit _ _ -> []
+      HsWildCardTy _ -> []
+      HsStarTy _ _ -> []
+      XHsType _ -> []
+
+instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
+  toHie (HsValArg tm) = toHie tm
+  toHie (HsTypeArg _ ty) = toHie ty
+  toHie (HsArgPar sp) = pure $ locOnly sp
+
+instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
+  toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
+      UserTyVar _ var ->
+        [ toHie $ C (TyVarBind sc tsc) var
+        ]
+      KindedTyVar _ var kind ->
+        [ toHie $ C (TyVarBind sc tsc) var
+        , toHie kind
+        ]
+      XTyVarBndr _ -> []
+
+instance ToHie (TScoped (LHsQTyVars GhcRn)) where
+  toHie (TS sc (HsQTvs (HsQTvsRn implicits _) vars)) = concatM $
+    [ pure $ bindingsOnly bindings
+    , toHie $ tvScopes sc NoScope vars
+    ]
+    where
+      varLoc = loc vars
+      bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits
+  toHie (TS _ (XLHsQTyVars _)) = pure []
+
+instance ToHie (LHsContext GhcRn) where
+  toHie (L span tys) = concatM $
+      [ pure $ locOnly span
+      , toHie tys
+      ]
+
+instance ToHie (LConDeclField GhcRn) where
+  toHie (L span field) = concatM $ makeNode field span : case field of
+      ConDeclField _ fields typ _ ->
+        [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields
+        , toHie typ
+        ]
+      XConDeclField _ -> []
+
+instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where
+  toHie (From expr) = toHie expr
+  toHie (FromThen a b) = concatM $
+    [ toHie a
+    , toHie b
+    ]
+  toHie (FromTo a b) = concatM $
+    [ toHie a
+    , toHie b
+    ]
+  toHie (FromThenTo a b c) = concatM $
+    [ toHie a
+    , toHie b
+    , toHie c
+    ]
+
+instance ToHie (LSpliceDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      SpliceDecl _ splice _ ->
+        [ toHie splice
+        ]
+      XSpliceDecl _ -> []
+
+instance ToHie (HsBracket a) where
+  toHie _ = pure []
+
+instance ToHie PendingRnSplice where
+  toHie _ = pure []
+
+instance ToHie PendingTcSplice where
+  toHie _ = pure []
+
+instance ToHie (LBooleanFormula (Located Name)) where
+  toHie (L span form) = concatM $ makeNode form span : case form of
+      Var a ->
+        [ toHie $ C Use a
+        ]
+      And forms ->
+        [ toHie forms
+        ]
+      Or forms ->
+        [ toHie forms
+        ]
+      Parens f ->
+        [ toHie f
+        ]
+
+instance ToHie (Located HsIPName) where
+  toHie (L span e) = makeNode e span
+
+instance ( ToHie (LHsExpr a)
+         , Data (HsSplice a)
+         ) => ToHie (Located (HsSplice a)) where
+  toHie (L span sp) = concatM $ makeNode sp span : case sp of
+      HsTypedSplice _ _ _ expr ->
+        [ toHie expr
+        ]
+      HsUntypedSplice _ _ _ expr ->
+        [ toHie expr
+        ]
+      HsQuasiQuote _ _ _ ispan _ ->
+        [ pure $ locOnly ispan
+        ]
+      HsSpliced _ _ _ ->
+        []
+      HsSplicedT _ ->
+        []
+      XSplice _ -> []
+
+instance ToHie (LRoleAnnotDecl GhcRn) where
+  toHie (L span annot) = concatM $ makeNode annot span : case annot of
+      RoleAnnotDecl _ var roles ->
+        [ toHie $ C Use var
+        , concatMapM (pure . locOnly . getLoc) roles
+        ]
+      XRoleAnnotDecl _ -> []
+
+instance ToHie (LInstDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      ClsInstD _ d ->
+        [ toHie $ L span d
+        ]
+      DataFamInstD _ d ->
+        [ toHie $ L span d
+        ]
+      TyFamInstD _ d ->
+        [ toHie $ L span d
+        ]
+      XInstDecl _ -> []
+
+instance ToHie (LClsInstDecl GhcRn) where
+  toHie (L span decl) = concatM
+    [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl
+    , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl
+    , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl
+    , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl
+    , toHie $ cid_tyfam_insts decl
+    , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl
+    , toHie $ cid_datafam_insts decl
+    , toHie $ cid_overlap_mode decl
+    ]
+
+instance ToHie (LDataFamInstDecl GhcRn) where
+  toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
+
+instance ToHie (LTyFamInstDecl GhcRn) where
+  toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d
+
+instance ToHie (Context a)
+         => ToHie (PatSynFieldContext (RecordPatSynField a)) where
+  toHie (PSC sp (RecordPatSynField a b)) = concatM $
+    [ toHie $ C (RecField RecFieldDecl sp) a
+    , toHie $ C Use b
+    ]
+
+instance ToHie (LDerivDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      DerivDecl _ typ strat overlap ->
+        [ toHie $ TS (ResolvedScopes []) typ
+        , toHie strat
+        , toHie overlap
+        ]
+      XDerivDecl _ -> []
+
+instance ToHie (LFixitySig GhcRn) where
+  toHie (L span sig) = concatM $ makeNode sig span : case sig of
+      FixitySig _ vars _ ->
+        [ toHie $ map (C Use) vars
+        ]
+      XFixitySig _ -> []
+
+instance ToHie (LDefaultDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      DefaultDecl _ typs ->
+        [ toHie typs
+        ]
+      XDefaultDecl _ -> []
+
+instance ToHie (LForeignDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->
+        [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name
+        , toHie $ TS (ResolvedScopes []) sig
+        , toHie fi
+        ]
+      ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->
+        [ toHie $ C Use name
+        , toHie $ TS (ResolvedScopes []) sig
+        , toHie fe
+        ]
+      XForeignDecl _ -> []
+
+instance ToHie ForeignImport where
+  toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $
+    [ locOnly a
+    , locOnly b
+    , locOnly c
+    ]
+
+instance ToHie ForeignExport where
+  toHie (CExport (L a _) (L b _)) = pure $ concat $
+    [ locOnly a
+    , locOnly b
+    ]
+
+instance ToHie (LWarnDecls GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      Warnings _ _ warnings ->
+        [ toHie warnings
+        ]
+      XWarnDecls _ -> []
+
+instance ToHie (LWarnDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      Warning _ vars _ ->
+        [ toHie $ map (C Use) vars
+        ]
+      XWarnDecl _ -> []
+
+instance ToHie (LAnnDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      HsAnnotation _ _ prov expr ->
+        [ toHie prov
+        , toHie expr
+        ]
+      XAnnDecl _ -> []
+
+instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where
+  toHie (ValueAnnProvenance a) = toHie $ C Use a
+  toHie (TypeAnnProvenance a) = toHie $ C Use a
+  toHie ModuleAnnProvenance = pure []
+
+instance ToHie (LRuleDecls GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      HsRules _ _ rules ->
+        [ toHie rules
+        ]
+      XRuleDecls _ -> []
+
+instance ToHie (LRuleDecl GhcRn) where
+  toHie (L _ (XRuleDecl _)) = pure []
+  toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
+        [ makeNode r span
+        , pure $ locOnly $ getLoc rname
+        , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
+        , toHie $ map (RS $ mkScope span) bndrs
+        , toHie exprA
+        , toHie exprB
+        ]
+    where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
+          bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)
+          exprA_sc = mkLScope exprA
+          exprB_sc = mkLScope exprB
+
+instance ToHie (RScoped (LRuleBndr GhcRn)) where
+  toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of
+      RuleBndr _ var ->
+        [ toHie $ C (ValBind RegularBind sc Nothing) var
+        ]
+      RuleBndrSig _ var typ ->
+        [ toHie $ C (ValBind RegularBind sc Nothing) var
+        , toHie $ TS (ResolvedScopes [sc]) typ
+        ]
+      XRuleBndr _ -> []
+
+instance ToHie (LImportDecl GhcRn) where
+  toHie (L span decl) = concatM $ makeNode decl span : case decl of
+      ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->
+        [ toHie $ IEC Import name
+        , toHie $ fmap (IEC ImportAs) as
+        , maybe (pure []) goIE hidden
+        ]
+      XImportDecl _ -> []
+    where
+      goIE (hiding, (L sp liens)) = concatM $
+        [ pure $ locOnly sp
+        , toHie $ map (IEC c) liens
+        ]
+        where
+         c = if hiding then ImportHiding else Import
+
+instance ToHie (IEContext (LIE GhcRn)) where
+  toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of
+      IEVar _ n ->
+        [ toHie $ IEC c n
+        ]
+      IEThingAbs _ n ->
+        [ toHie $ IEC c n
+        ]
+      IEThingAll _ n ->
+        [ toHie $ IEC c n
+        ]
+      IEThingWith _ n _ ns flds ->
+        [ toHie $ IEC c n
+        , toHie $ map (IEC c) ns
+        , toHie $ map (IEC c) flds
+        ]
+      IEModuleContents _ n ->
+        [ toHie $ IEC c n
+        ]
+      IEGroup _ _ _ -> []
+      IEDoc _ _ -> []
+      IEDocNamed _ _ -> []
+      XIE _ -> []
+
+instance ToHie (IEContext (LIEWrappedName Name)) where
+  toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of
+      IEName n ->
+        [ toHie $ C (IEThing c) n
+        ]
+      IEPattern p ->
+        [ toHie $ C (IEThing c) p
+        ]
+      IEType n ->
+        [ toHie $ C (IEThing c) n
+        ]
+
+instance ToHie (IEContext (Located (FieldLbl Name))) where
+  toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of
+      FieldLabel _ _ n ->
+        [ toHie $ C (IEThing c) $ L span n
+        ]
diff --git a/compiler/hieFile/HieBin.hs b/compiler/hieFile/HieBin.hs
new file mode 100644
--- /dev/null
+++ b/compiler/hieFile/HieBin.hs
@@ -0,0 +1,273 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module HieBin ( readHieFile, writeHieFile, HieName(..), toHieName ) where
+
+import GhcPrelude
+
+import Binary
+import BinIface                   ( getDictFastString )
+import FastMutInt
+import FastString                 ( FastString )
+import Module                     ( Module )
+import Name
+import NameCache
+import Outputable
+import PrelInfo
+import SrcLoc
+import UniqSupply                 ( takeUniqFromSupply )
+import Unique
+import UniqFM
+
+import qualified Data.Array as A
+import Data.IORef
+import Data.List                  ( mapAccumR )
+import Data.Word                  ( Word32 )
+import Control.Monad              ( replicateM )
+import System.Directory           ( createDirectoryIfMissing )
+import System.FilePath            ( takeDirectory )
+
+-- | `Name`'s get converted into `HieName`'s before being written into @.hie@
+-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between
+-- these two types.
+data HieName
+  = ExternalName !Module !OccName !SrcSpan
+  | LocalName !OccName !SrcSpan
+  | KnownKeyName !Unique
+  deriving (Eq)
+
+instance Ord HieName where
+  compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)
+  compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)
+  compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b
+    -- Not actually non determinstic as it is a KnownKey
+  compare ExternalName{} _ = LT
+  compare LocalName{} ExternalName{} = GT
+  compare LocalName{} _ = LT
+  compare KnownKeyName{} _ = GT
+
+instance Outputable HieName where
+  ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp
+  ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
+  ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
+
+
+data HieSymbolTable = HieSymbolTable
+  { hie_symtab_next :: !FastMutInt
+  , hie_symtab_map  :: !(IORef (UniqFM (Int, HieName)))
+  }
+
+data HieDictionary = HieDictionary
+  { hie_dict_next :: !FastMutInt -- The next index to use
+  , hie_dict_map  :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString
+  }
+
+initBinMemSize :: Int
+initBinMemSize = 1024*1024
+
+writeHieFile :: Binary a => FilePath -> a -> IO ()
+writeHieFile hie_file_path hiefile = do
+  bh0 <- openBinMem initBinMemSize
+
+  -- remember where the dictionary pointer will go
+  dict_p_p <- tellBin bh0
+  put_ bh0 dict_p_p
+
+  -- remember where the symbol table pointer will go
+  symtab_p_p <- tellBin bh0
+  put_ bh0 symtab_p_p
+
+  -- Make some intial state
+  symtab_next <- newFastMutInt
+  writeFastMutInt symtab_next 0
+  symtab_map <- newIORef emptyUFM
+  let hie_symtab = HieSymbolTable {
+                      hie_symtab_next = symtab_next,
+                      hie_symtab_map  = symtab_map }
+  dict_next_ref <- newFastMutInt
+  writeFastMutInt dict_next_ref 0
+  dict_map_ref <- newIORef emptyUFM
+  let hie_dict = HieDictionary {
+                      hie_dict_next = dict_next_ref,
+                      hie_dict_map  = dict_map_ref }
+
+  -- put the main thing
+  let bh = setUserData bh0 $ newWriteState (putName hie_symtab)
+                                           (putName hie_symtab)
+                                           (putFastString hie_dict)
+  put_ bh hiefile
+
+  -- write the symtab pointer at the front of the file
+  symtab_p <- tellBin bh
+  putAt bh symtab_p_p symtab_p
+  seekBin bh symtab_p
+
+  -- write the symbol table itself
+  symtab_next' <- readFastMutInt symtab_next
+  symtab_map'  <- readIORef symtab_map
+  putSymbolTable bh symtab_next' symtab_map'
+
+  -- write the dictionary pointer at the fornt of the file
+  dict_p <- tellBin bh
+  putAt bh dict_p_p dict_p
+  seekBin bh dict_p
+
+  -- write the dictionary itself
+  dict_next <- readFastMutInt dict_next_ref
+  dict_map  <- readIORef dict_map_ref
+  putDictionary bh dict_next dict_map
+
+  -- and send the result to the file
+  createDirectoryIfMissing True (takeDirectory hie_file_path)
+  writeBinMem bh hie_file_path
+  return ()
+
+readHieFile :: Binary a => NameCache -> FilePath -> IO (a, NameCache)
+readHieFile nc file = do
+  bh0 <- readBinMem file
+
+  dict  <- get_dictionary bh0
+
+  -- read the symbol table so we are capable of reading the actual data
+  (bh1, nc') <- do
+      let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
+                                               (getDictFastString dict)
+      (nc', symtab) <- get_symbol_table bh1
+      let bh1' = setUserData bh1
+               $ newReadState (getSymTabName symtab)
+                              (getDictFastString dict)
+      return (bh1', nc')
+
+  -- load the actual data
+  hiefile <- get bh1
+  return (hiefile, nc')
+  where
+    get_dictionary bin_handle = do
+      dict_p <- get bin_handle
+      data_p <- tellBin bin_handle
+      seekBin bin_handle dict_p
+      dict <- getDictionary bin_handle
+      seekBin bin_handle data_p
+      return dict
+
+    get_symbol_table bh1 = do
+      symtab_p <- get bh1
+      data_p'  <- tellBin bh1
+      seekBin bh1 symtab_p
+      (nc', symtab) <- getSymbolTable bh1 nc
+      seekBin bh1 data_p'
+      return (nc', symtab)
+
+putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()
+putFastString HieDictionary { hie_dict_next = j_r,
+                              hie_dict_map  = out_r}  bh f
+  = do
+    out <- readIORef out_r
+    let unique = getUnique f
+    case lookupUFM out unique of
+        Just (j, _)  -> put_ bh (fromIntegral j :: Word32)
+        Nothing -> do
+           j <- readFastMutInt j_r
+           put_ bh (fromIntegral j :: Word32)
+           writeFastMutInt j_r (j + 1)
+           writeIORef out_r $! addToUFM out unique (j, f)
+
+putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()
+putSymbolTable bh next_off symtab = do
+  put_ bh next_off
+  let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))
+  mapM_ (putHieName bh) names
+
+getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, SymbolTable)
+getSymbolTable bh namecache = do
+  sz <- get bh
+  od_names <- replicateM sz (getHieName bh)
+  let arr = A.listArray (0,sz-1) names
+      (namecache', names) = mapAccumR fromHieName namecache od_names
+  return (namecache', arr)
+
+getSymTabName :: SymbolTable -> BinHandle -> IO Name
+getSymTabName st bh = do
+  i :: Word32 <- get bh
+  return $ st A.! (fromIntegral i)
+
+putName :: HieSymbolTable -> BinHandle -> Name -> IO ()
+putName (HieSymbolTable next ref) bh name = do
+  symmap <- readIORef ref
+  case lookupUFM symmap name of
+    Just (off, ExternalName mod occ (UnhelpfulSpan _))
+      | isGoodSrcSpan (nameSrcSpan name) -> do
+      let hieName = ExternalName mod occ (nameSrcSpan name)
+      writeIORef ref $! addToUFM symmap name (off, hieName)
+      put_ bh (fromIntegral off :: Word32)
+    Just (off, LocalName _occ span)
+      | notLocal (toHieName name) || nameSrcSpan name /= span -> do
+      writeIORef ref $! addToUFM symmap name (off, toHieName name)
+      put_ bh (fromIntegral off :: Word32)
+    Just (off, _) -> put_ bh (fromIntegral off :: Word32)
+    Nothing -> do
+        off <- readFastMutInt next
+        writeFastMutInt next (off+1)
+        writeIORef ref $! addToUFM symmap name (off, toHieName name)
+        put_ bh (fromIntegral off :: Word32)
+
+  where
+    notLocal :: HieName -> Bool
+    notLocal LocalName{} = False
+    notLocal _ = True
+
+
+-- ** Converting to and from `HieName`'s
+
+toHieName :: Name -> HieName
+toHieName name
+  | isKnownKeyName name = KnownKeyName (nameUnique name)
+  | isExternalName name = ExternalName (nameModule name)
+                                       (nameOccName name)
+                                       (nameSrcSpan name)
+  | otherwise = LocalName (nameOccName name) (nameSrcSpan name)
+
+fromHieName :: NameCache -> HieName -> (NameCache, Name)
+fromHieName nc (ExternalName mod occ span) =
+    let cache = nsNames nc
+    in case lookupOrigNameCache cache mod occ of
+         Just name -> (nc, name)
+         Nothing ->
+           let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
+               name       = mkExternalName uniq mod occ span
+               new_cache  = extendNameCache cache mod occ name
+           in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
+fromHieName nc (LocalName occ span) =
+    let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
+        name       = mkInternalName uniq occ span
+    in ( nc{ nsUniqs = us }, name )
+fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of
+    Nothing -> pprPanic "fromHieName:unknown known-key unique"
+                        (ppr (unpkUnique u))
+    Just n -> (nc, n)
+
+-- ** Reading and writing `HieName`'s
+
+putHieName :: BinHandle -> HieName -> IO ()
+putHieName bh (ExternalName mod occ span) = do
+  putByte bh 0
+  put_ bh (mod, occ, span)
+putHieName bh (LocalName occName span) = do
+  putByte bh 1
+  put_ bh (occName, span)
+putHieName bh (KnownKeyName uniq) = do
+  putByte bh 2
+  put_ bh $ unpkUnique uniq
+
+getHieName :: BinHandle -> IO HieName
+getHieName bh = do
+  t <- getByte bh
+  case t of
+    0 -> do
+      (modu, occ, span) <- get bh
+      return $ ExternalName modu occ span
+    1 -> do
+      (occ, span) <- get bh
+      return $ LocalName occ span
+    2 -> do
+      (c,i) <- get bh
+      return $ KnownKeyName $ mkUnique c i
+    _ -> panic "HieBin.getHieName: invalid tag"
diff --git a/compiler/hieFile/HieDebug.hs b/compiler/hieFile/HieDebug.hs
new file mode 100644
--- /dev/null
+++ b/compiler/hieFile/HieDebug.hs
@@ -0,0 +1,143 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
+module HieDebug where
+
+import GhcPrelude
+
+import SrcLoc
+import Module
+import FastString
+import Outputable
+
+import HieTypes
+import HieBin
+import HieUtils
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Function    ( on )
+import Data.List        ( sortOn )
+import Data.Foldable    ( toList )
+
+ppHies :: Outputable a => (HieASTs a) -> SDoc
+ppHies (HieASTs asts) = M.foldrWithKey go "" asts
+  where
+    go k a rest = vcat $
+      [ "File: " <> ppr k
+      , ppHie a
+      , rest
+      ]
+
+ppHie :: Outputable a => HieAST a -> SDoc
+ppHie = go 0
+  where
+    go n (Node inf sp children) = hang header n rest
+      where
+        rest = vcat $ map (go (n+2)) children
+        header = hsep
+          [ "Node"
+          , ppr sp
+          , ppInfo inf
+          ]
+
+ppInfo :: Outputable a => NodeInfo a -> SDoc
+ppInfo ni = hsep
+  [ ppr $ toList $ nodeAnnotations ni
+  , ppr $ nodeType ni
+  , ppr $ M.toList $ nodeIdentifiers ni
+  ]
+
+type Diff a = a -> a -> [SDoc]
+
+diffFile :: Diff HieFile
+diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)
+
+diffAsts :: (Outputable a, Eq a) => Diff a -> Diff (M.Map FastString (HieAST a))
+diffAsts f = diffList (diffAst f) `on` M.elems
+
+diffAst :: (Outputable a, Eq a) => Diff a -> Diff (HieAST a)
+diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =
+    infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2
+  where
+    spanDiff
+      | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]]
+      | otherwise = []
+    infoDiff
+      = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2
+     ++ (diffList diffType `on` nodeType) info1 info2
+     ++ (diffIdents `on` nodeIdentifiers) info1 info2
+    diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b
+    diffIdent (a,b) (c,d) = diffName a c
+                         ++ eqDiff b d
+    diffName (Right a) (Right b) = case (a,b) of
+      (ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o')
+      (LocalName o _, ExternalName _ o' _) -> eqDiff o o'
+      _ -> eqDiff a b
+    diffName a b = eqDiff a b
+
+type DiffIdent = Either ModuleName HieName
+
+normalizeIdents :: NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]
+normalizeIdents = sortOn fst . map (first toHieName) . M.toList
+  where
+    first f (a,b) = (fmap f a, b)
+
+diffList :: Diff a -> Diff [a]
+diffList f xs ys
+  | length xs == length ys = concat $ zipWith f xs ys
+  | otherwise = ["length of lists doesn't match"]
+
+eqDiff :: (Outputable a, Eq a) => Diff a
+eqDiff a b
+  | a == b = []
+  | otherwise = [hsep [ppr a, "and", ppr b, "do not match"]]
+
+validAst :: HieAST a -> Either SDoc ()
+validAst (Node _ span children) = do
+  checkContainment children
+  checkSorted children
+  mapM_ validAst children
+  where
+    checkSorted [] = return ()
+    checkSorted [_] = return ()
+    checkSorted (x:y:xs)
+      | nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs)
+      | otherwise = Left $ hsep
+          [ ppr $ nodeSpan x
+          , "is not to the left of"
+          , ppr $ nodeSpan y
+          ]
+    checkContainment [] = return ()
+    checkContainment (x:xs)
+      | span `containsSpan` (nodeSpan x) = checkContainment xs
+      | otherwise = Left $ hsep
+          [ ppr $ span
+          , "does not contain"
+          , ppr $ nodeSpan x
+          ]
+
+-- | Look for any identifiers which occur outside of their supposed scopes.
+-- Returns a list of error messages.
+validateScopes :: M.Map FastString (HieAST a) -> [SDoc]
+validateScopes asts = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap
+  where
+    refMap = generateReferencesMap asts
+    valid (Left _) _ = []
+    valid (Right n) refs = concatMap inScope refs
+      where
+        mapRef = foldMap getScopeFromContext . identInfo . snd
+        scopes = case foldMap mapRef refs of
+          Just xs -> xs
+          Nothing -> []
+        inScope (sp, dets)
+          |  definedInAsts asts n
+          && any isOccurrence (identInfo dets)
+            = case scopes of
+              [] -> []
+              _ -> if any (`scopeContainsSpan` sp) scopes
+                   then []
+                   else return $ hsep $
+                     [ "Name", ppr n, "at position", ppr sp
+                     , "doesn't occur in calculated scope", ppr scopes]
+          | otherwise = []
diff --git a/compiler/hieFile/HieTypes.hs b/compiler/hieFile/HieTypes.hs
new file mode 100644
--- /dev/null
+++ b/compiler/hieFile/HieTypes.hs
@@ -0,0 +1,514 @@
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module HieTypes where
+
+import GhcPrelude
+
+import Binary
+import FastString                 ( FastString )
+import IfaceType
+import Module                     ( ModuleName, Module )
+import Name                       ( Name )
+import Outputable hiding ( (<>) )
+import SrcLoc                     ( RealSrcSpan )
+import Avail
+
+import qualified Data.Array as A
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.ByteString            ( ByteString )
+import Data.Data                  ( Typeable, Data )
+import Data.Semigroup             ( Semigroup(..) )
+import Data.Word                  ( Word8 )
+import Control.Applicative        ( (<|>) )
+
+type Span = RealSrcSpan
+
+-- | Current version of @.hie@ files
+curHieVersion :: Word8
+curHieVersion = 0
+
+{- |
+GHC builds up a wealth of information about Haskell source as it compiles it.
+@.hie@ files are a way of persisting some of this information to disk so that
+external tools that need to work with haskell source don't need to parse,
+typecheck, and rename all over again. These files contain:
+
+  * a simplified AST
+
+       * nodes are annotated with source positions and types
+       * identifiers are annotated with scope information
+
+  * the raw bytes of the initial Haskell source
+
+Besides saving compilation cycles, @.hie@ files also offer a more stable
+interface than the GHC API.
+-}
+data HieFile = HieFile
+    { hie_version :: Word8
+    -- ^ version of the HIE format
+
+    , hie_ghc_version :: ByteString
+    -- ^ Version of GHC that produced this file
+
+    , hie_hs_file :: FilePath
+    -- ^ Initial Haskell source file path
+
+    , hie_module :: Module
+    -- ^ The module this HIE file is for
+
+    , hie_types :: A.Array TypeIndex HieTypeFlat
+    -- ^ Types referenced in the 'hie_asts'.
+    --
+    -- See Note [Efficient serialization of redundant type info]
+
+    , hie_asts :: HieASTs TypeIndex
+    -- ^ Type-annotated abstract syntax trees
+
+    , hie_exports :: [AvailInfo]
+    -- ^ The names that this module exports
+
+    , hie_hs_src :: ByteString
+    -- ^ Raw bytes of the initial Haskell source
+    }
+
+instance Binary HieFile where
+  put_ bh hf = do
+    put_ bh $ hie_version hf
+    put_ bh $ hie_ghc_version hf
+    put_ bh $ hie_hs_file hf
+    put_ bh $ hie_module hf
+    put_ bh $ hie_types hf
+    put_ bh $ hie_asts hf
+    put_ bh $ hie_exports hf
+    put_ bh $ hie_hs_src hf
+
+  get bh = HieFile
+    <$> get bh
+    <*> get bh
+    <*> get bh
+    <*> get bh
+    <*> get bh
+    <*> get bh
+    <*> get bh
+    <*> get bh
+
+
+{-
+Note [Efficient serialization of redundant type info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The type information in .hie files is highly repetitive and redundant. For
+example, consider the expression
+
+    const True 'a'
+
+There is a lot of shared structure between the types of subterms:
+
+  * const True 'a' ::                 Bool
+  * const True     ::         Char -> Bool
+  * const          :: Bool -> Char -> Bool
+
+Since all 3 of these types need to be stored in the .hie file, it is worth
+making an effort to deduplicate this shared structure. The trick is to define
+a new data type that is a flattened version of 'Type':
+
+    data HieType a = HAppTy a a  -- data Type = AppTy Type Type
+                   | HFunTy a a  --           | FunTy Type Type
+                   | ...
+
+    type TypeIndex = Int
+
+Types in the final AST are stored in an 'A.Array TypeIndex (HieType TypeIndex)',
+where the 'TypeIndex's in the 'HieType' are references to other elements of the
+array. Types recovered from GHC are deduplicated and stored in this compressed
+form with sharing of subtrees.
+-}
+
+type TypeIndex = Int
+
+-- | A flattened version of 'Type'.
+--
+-- See Note [Efficient serialization of redundant type info]
+data HieType a
+  = HTyVarTy Name
+  | HAppTy a (HieArgs a)
+  | HTyConApp IfaceTyCon (HieArgs a)
+  | HForAllTy ((Name, a),ArgFlag) a
+  | HFunTy  a a
+  | HQualTy a a           -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy')
+  | HLitTy IfaceTyLit
+  | HCastTy a
+  | HCoercionTy
+    deriving (Functor, Foldable, Traversable, Eq)
+
+type HieTypeFlat = HieType TypeIndex
+
+-- | Roughly isomorphic to the original core 'Type'.
+newtype HieTypeFix = Roll (HieType (HieTypeFix))
+
+instance Binary (HieType TypeIndex) where
+  put_ bh (HTyVarTy n) = do
+    putByte bh 0
+    put_ bh n
+  put_ bh (HAppTy a b) = do
+    putByte bh 1
+    put_ bh a
+    put_ bh b
+  put_ bh (HTyConApp n xs) = do
+    putByte bh 2
+    put_ bh n
+    put_ bh xs
+  put_ bh (HForAllTy bndr a) = do
+    putByte bh 3
+    put_ bh bndr
+    put_ bh a
+  put_ bh (HFunTy a b) = do
+    putByte bh 4
+    put_ bh a
+    put_ bh b
+  put_ bh (HQualTy a b) = do
+    putByte bh 5
+    put_ bh a
+    put_ bh b
+  put_ bh (HLitTy l) = do
+    putByte bh 6
+    put_ bh l
+  put_ bh (HCastTy a) = do
+    putByte bh 7
+    put_ bh a
+  put_ bh (HCoercionTy) = putByte bh 8
+
+  get bh = do
+    (t :: Word8) <- get bh
+    case t of
+      0 -> HTyVarTy <$> get bh
+      1 -> HAppTy <$> get bh <*> get bh
+      2 -> HTyConApp <$> get bh <*> get bh
+      3 -> HForAllTy <$> get bh <*> get bh
+      4 -> HFunTy <$> get bh <*> get bh
+      5 -> HQualTy <$> get bh <*> get bh
+      6 -> HLitTy <$> get bh
+      7 -> HCastTy <$> get bh
+      8 -> return HCoercionTy
+      _ -> panic "Binary (HieArgs Int): invalid tag"
+
+
+-- | A list of type arguments along with their respective visibilities (ie. is
+-- this an argument that would return 'True' for 'isVisibleArgFlag'?).
+newtype HieArgs a = HieArgs [(Bool,a)]
+  deriving (Functor, Foldable, Traversable, Eq)
+
+instance Binary (HieArgs TypeIndex) where
+  put_ bh (HieArgs xs) = put_ bh xs
+  get bh = HieArgs <$> get bh
+
+-- | Mapping from filepaths (represented using 'FastString') to the
+-- corresponding AST
+newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) }
+  deriving (Functor, Foldable, Traversable)
+
+instance Binary (HieASTs TypeIndex) where
+  put_ bh asts = put_ bh $ M.toAscList $ getAsts asts
+  get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh)
+
+
+data HieAST a =
+  Node
+    { nodeInfo :: NodeInfo a
+    , nodeSpan :: Span
+    , nodeChildren :: [HieAST a]
+    } deriving (Functor, Foldable, Traversable)
+
+instance Binary (HieAST TypeIndex) where
+  put_ bh ast = do
+    put_ bh $ nodeInfo ast
+    put_ bh $ nodeSpan ast
+    put_ bh $ nodeChildren ast
+
+  get bh = Node
+    <$> get bh
+    <*> get bh
+    <*> get bh
+
+
+-- | The information stored in one AST node.
+--
+-- The type parameter exists to provide flexibility in representation of types
+-- (see Note [Efficient serialization of redundant type info]).
+data NodeInfo a = NodeInfo
+    { nodeAnnotations :: S.Set (FastString,FastString)
+    -- ^ (name of the AST node constructor, name of the AST node Type)
+
+    , nodeType :: [a]
+    -- ^ The Haskell types of this node, if any.
+
+    , nodeIdentifiers :: NodeIdentifiers a
+    -- ^ All the identifiers and their details
+    } deriving (Functor, Foldable, Traversable)
+
+instance Binary (NodeInfo TypeIndex) where
+  put_ bh ni = do
+    put_ bh $ S.toAscList $ nodeAnnotations ni
+    put_ bh $ nodeType ni
+    put_ bh $ M.toList $ nodeIdentifiers ni
+  get bh = NodeInfo
+    <$> fmap (S.fromDistinctAscList) (get bh)
+    <*> get bh
+    <*> fmap (M.fromList) (get bh)
+
+type Identifier = Either ModuleName Name
+
+type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a)
+
+-- | Information associated with every identifier
+--
+-- We need to include types with identifiers because sometimes multiple
+-- identifiers occur in the same span(Overloaded Record Fields and so on)
+data IdentifierDetails a = IdentifierDetails
+  { identType :: Maybe a
+  , identInfo :: S.Set ContextInfo
+  } deriving (Eq, Functor, Foldable, Traversable)
+
+instance Outputable a => Outputable (IdentifierDetails a) where
+  ppr x = text "IdentifierDetails" <+> ppr (identType x) <+> ppr (identInfo x)
+
+instance Semigroup (IdentifierDetails a) where
+  d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2)
+                               (S.union (identInfo d1) (identInfo d2))
+
+instance Monoid (IdentifierDetails a) where
+  mempty = IdentifierDetails Nothing S.empty
+
+instance Binary (IdentifierDetails TypeIndex) where
+  put_ bh dets = do
+    put_ bh $ identType dets
+    put_ bh $ S.toAscList $ identInfo dets
+  get bh =  IdentifierDetails
+    <$> get bh
+    <*> fmap (S.fromDistinctAscList) (get bh)
+
+
+-- | Different contexts under which identifiers exist
+data ContextInfo
+  = Use                -- ^ regular variable
+  | MatchBind
+  | IEThing IEType     -- ^ import/export
+  | TyDecl
+
+  -- | Value binding
+  | ValBind
+      BindType     -- ^ whether or not the binding is in an instance
+      Scope        -- ^ scope over which the value is bound
+      (Maybe Span) -- ^ span of entire binding
+
+  -- | Pattern binding
+  --
+  -- This case is tricky because the bound identifier can be used in two
+  -- distinct scopes. Consider the following example (with @-XViewPatterns@)
+  --
+  -- @
+  -- do (b, a, (a -> True)) <- bar
+  --    foo a
+  -- @
+  --
+  -- The identifier @a@ has two scopes: in the view pattern @(a -> True)@ and
+  -- in the rest of the @do@-block in @foo a@.
+  | PatternBind
+      Scope        -- ^ scope /in the pattern/ (the variable bound can be used
+                   -- further in the pattern)
+      Scope        -- ^ rest of the scope outside the pattern
+      (Maybe Span) -- ^ span of entire binding
+
+  | ClassTyDecl (Maybe Span)
+
+  -- | Declaration
+  | Decl
+      DeclType     -- ^ type of declaration
+      (Maybe Span) -- ^ span of entire binding
+
+  -- | Type variable
+  | TyVarBind Scope TyVarScope
+
+  -- | Record field
+  | RecField RecFieldContext (Maybe Span)
+    deriving (Eq, Ord, Show)
+
+instance Outputable ContextInfo where
+  ppr = text . show
+
+instance Binary ContextInfo where
+  put_ bh Use = putByte bh 0
+  put_ bh (IEThing t) = do
+    putByte bh 1
+    put_ bh t
+  put_ bh TyDecl = putByte bh 2
+  put_ bh (ValBind bt sc msp) = do
+    putByte bh 3
+    put_ bh bt
+    put_ bh sc
+    put_ bh msp
+  put_ bh (PatternBind a b c) = do
+    putByte bh 4
+    put_ bh a
+    put_ bh b
+    put_ bh c
+  put_ bh (ClassTyDecl sp) = do
+    putByte bh 5
+    put_ bh sp
+  put_ bh (Decl a b) = do
+    putByte bh 6
+    put_ bh a
+    put_ bh b
+  put_ bh (TyVarBind a b) = do
+    putByte bh 7
+    put_ bh a
+    put_ bh b
+  put_ bh (RecField a b) = do
+    putByte bh 8
+    put_ bh a
+    put_ bh b
+  put_ bh MatchBind = putByte bh 9
+
+  get bh = do
+    (t :: Word8) <- get bh
+    case t of
+      0 -> return Use
+      1 -> IEThing <$> get bh
+      2 -> return TyDecl
+      3 -> ValBind <$> get bh <*> get bh <*> get bh
+      4 -> PatternBind <$> get bh <*> get bh <*> get bh
+      5 -> ClassTyDecl <$> get bh
+      6 -> Decl <$> get bh <*> get bh
+      7 -> TyVarBind <$> get bh <*> get bh
+      8 -> RecField <$> get bh <*> get bh
+      9 -> return MatchBind
+      _ -> panic "Binary ContextInfo: invalid tag"
+
+
+-- | Types of imports and exports
+data IEType
+  = Import
+  | ImportAs
+  | ImportHiding
+  | Export
+    deriving (Eq, Enum, Ord, Show)
+
+instance Binary IEType where
+  put_ bh b = putByte bh (fromIntegral (fromEnum b))
+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
+
+
+data RecFieldContext
+  = RecFieldDecl
+  | RecFieldAssign
+  | RecFieldMatch
+  | RecFieldOcc
+    deriving (Eq, Enum, Ord, Show)
+
+instance Binary RecFieldContext where
+  put_ bh b = putByte bh (fromIntegral (fromEnum b))
+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
+
+
+data BindType
+  = RegularBind
+  | InstanceBind
+    deriving (Eq, Ord, Show, Enum)
+
+instance Binary BindType where
+  put_ bh b = putByte bh (fromIntegral (fromEnum b))
+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
+
+
+data DeclType
+  = FamDec     -- ^ type or data family
+  | SynDec     -- ^ type synonym
+  | DataDec    -- ^ data declaration
+  | ConDec     -- ^ constructor declaration
+  | PatSynDec  -- ^ pattern synonym
+  | ClassDec   -- ^ class declaration
+  | InstDec    -- ^ instance declaration
+    deriving (Eq, Ord, Show, Enum)
+
+instance Binary DeclType where
+  put_ bh b = putByte bh (fromIntegral (fromEnum b))
+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
+
+
+data Scope
+  = NoScope
+  | LocalScope Span
+  | ModuleScope
+    deriving (Eq, Ord, Show, Typeable, Data)
+
+instance Outputable Scope where
+  ppr NoScope = text "NoScope"
+  ppr (LocalScope sp) = text "LocalScope" <+> ppr sp
+  ppr ModuleScope = text "ModuleScope"
+
+instance Binary Scope where
+  put_ bh NoScope = putByte bh 0
+  put_ bh (LocalScope span) = do
+    putByte bh 1
+    put_ bh span
+  put_ bh ModuleScope = putByte bh 2
+
+  get bh = do
+    (t :: Word8) <- get bh
+    case t of
+      0 -> return NoScope
+      1 -> LocalScope <$> get bh
+      2 -> return ModuleScope
+      _ -> panic "Binary Scope: invalid tag"
+
+
+-- | Scope of a type variable.
+--
+-- This warrants a data type apart from 'Scope' because of complexities
+-- introduced by features like @-XScopedTypeVariables@ and @-XInstanceSigs@. For
+-- example, consider:
+--
+-- @
+-- foo, bar, baz :: forall a. a -> a
+-- @
+--
+-- Here @a@ is in scope in all the definitions of @foo@, @bar@, and @baz@, so we
+-- need a list of scopes to keep track of this. Furthermore, this list cannot be
+-- computed until we resolve the binding sites of @foo@, @bar@, and @baz@.
+--
+-- Consequently, @a@ starts with an @'UnresolvedScope' [foo, bar, baz] Nothing@
+-- which later gets resolved into a 'ResolvedScopes'.
+data TyVarScope
+  = ResolvedScopes [Scope]
+
+  -- | Unresolved scopes should never show up in the final @.hie@ file
+  | UnresolvedScope
+        [Name]        -- ^ names of the definitions over which the scope spans
+        (Maybe Span)  -- ^ the location of the instance/class declaration for
+                      -- the case where the type variable is declared in a
+                      -- method type signature
+    deriving (Eq, Ord)
+
+instance Show TyVarScope where
+  show (ResolvedScopes sc) = show sc
+  show _ = error "UnresolvedScope"
+
+instance Binary TyVarScope where
+  put_ bh (ResolvedScopes xs) = do
+    putByte bh 0
+    put_ bh xs
+  put_ bh (UnresolvedScope ns span) = do
+    putByte bh 1
+    put_ bh ns
+    put_ bh span
+
+  get bh = do
+    (t :: Word8) <- get bh
+    case t of
+      0 -> ResolvedScopes <$> get bh
+      1 -> UnresolvedScope <$> get bh <*> get bh
+      _ -> panic "Binary TyVarScope: invalid tag"
diff --git a/compiler/hieFile/HieUtils.hs b/compiler/hieFile/HieUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/hieFile/HieUtils.hs
@@ -0,0 +1,455 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
+module HieUtils where
+
+import GhcPrelude
+
+import CoreMap
+import DynFlags                   ( DynFlags )
+import FastString                 ( FastString, mkFastString )
+import IfaceType
+import Name hiding (varName)
+import Outputable                 ( renderWithStyle, ppr, defaultUserStyle )
+import SrcLoc
+import ToIface
+import TyCon
+import TyCoRep
+import Type
+import Var
+import VarEnv
+
+import HieTypes
+
+import qualified Data.Map as M
+import qualified Data.Set as S
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Array as A
+import Data.Data                  ( typeOf, typeRepTyCon, Data(toConstr) )
+import Data.Maybe                 ( maybeToList )
+import Data.Monoid
+import Data.Traversable           ( for )
+import Control.Monad.Trans.State.Strict hiding (get)
+
+
+generateReferencesMap
+  :: Foldable f
+  => f (HieAST a)
+  -> M.Map Identifier [(Span, IdentifierDetails a)]
+generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty
+  where
+    go ast = M.unionsWith (++) (this : map go (nodeChildren ast))
+      where
+        this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast
+
+renderHieType :: DynFlags -> HieTypeFix -> String
+renderHieType df ht = renderWithStyle df (ppr $ hieTypeToIface ht) sty
+  where sty = defaultUserStyle df
+
+resolveVisibility :: Type -> [Type] -> [(Bool,Type)]
+resolveVisibility kind ty_args
+  = go (mkEmptyTCvSubst in_scope) kind ty_args
+  where
+    in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)
+
+    go _   _                   []     = []
+    go env ty                  ts
+      | Just ty' <- coreView ty
+      = go env ty' ts
+    go env (ForAllTy (Bndr tv vis) res) (t:ts)
+      | isVisibleArgFlag vis = (True , t) : ts'
+      | otherwise            = (False, t) : ts'
+      where
+        ts' = go (extendTvSubst env tv t) res ts
+
+    go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps
+      = (True,t) : (go env res ts)
+
+    go env (TyVarTy tv) ts
+      | Just ki <- lookupTyVar env tv = go env ki ts
+    go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded
+
+foldType :: (HieType a -> a) -> HieTypeFix -> a
+foldType f (Roll t) = f $ fmap (foldType f) t
+
+hieTypeToIface :: HieTypeFix -> IfaceType
+hieTypeToIface = foldType go
+  where
+    go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n
+    go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)
+    go (HLitTy l) = IfaceLitTy l
+    go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)
+                                  in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
+    go (HFunTy a b) = IfaceFunTy a b
+    go (HQualTy pred b) = IfaceDFunTy pred b
+    go (HCastTy a) = a
+    go HCoercionTy = IfaceTyVar "<coercion type>"
+    go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)
+
+    -- This isn't fully faithful - we can't produce the 'Inferred' case
+    hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs
+    hieToIfaceArgs (HieArgs xs) = go' xs
+      where
+        go' [] = IA_Nil
+        go' ((True ,x):xs) = IA_Arg x Required $ go' xs
+        go' ((False,x):xs) = IA_Arg x Specified $ go' xs
+
+data HieTypeState
+  = HTS
+    { tyMap      :: !(TypeMap TypeIndex)
+    , htyTable   :: !(IM.IntMap HieTypeFlat)
+    , freshIndex :: !TypeIndex
+    }
+
+initialHTS :: HieTypeState
+initialHTS = HTS emptyTypeMap IM.empty 0
+
+freshTypeIndex :: State HieTypeState TypeIndex
+freshTypeIndex = do
+  index <- gets freshIndex
+  modify' $ \hts -> hts { freshIndex = index+1 }
+  return index
+
+compressTypes
+  :: HieASTs Type
+  -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)
+compressTypes asts = (a, arr)
+  where
+    (a, (HTS _ m i)) = flip runState initialHTS $
+      for asts $ \typ -> do
+        i <- getTypeIndex typ
+        return i
+    arr = A.array (0,i-1) (IM.toList m)
+
+recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix
+recoverFullType i m = go i
+  where
+    go i = Roll $ fmap go (m A.! i)
+
+getTypeIndex :: Type -> State HieTypeState TypeIndex
+getTypeIndex t
+  | otherwise = do
+      tm <- gets tyMap
+      case lookupTypeMap tm t of
+        Just i -> return i
+        Nothing -> do
+          ht <- go t
+          extendHTS t ht
+  where
+    extendHTS t ht = do
+      i <- freshTypeIndex
+      modify' $ \(HTS tm tt fi) ->
+        HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi
+      return i
+
+    go (TyVarTy v) = return $ HTyVarTy $ varName v
+    go ty@(AppTy _ _) = do
+      let (head,args) = splitAppTys ty
+          visArgs = HieArgs $ resolveVisibility (typeKind head) args
+      ai <- getTypeIndex head
+      argsi <- mapM getTypeIndex visArgs
+      return $ HAppTy ai argsi
+    go (TyConApp f xs) = do
+      let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs
+      is <- mapM getTypeIndex visArgs
+      return $ HTyConApp (toIfaceTyCon f) is
+    go (ForAllTy (Bndr v a) t) = do
+      k <- getTypeIndex (varType v)
+      i <- getTypeIndex t
+      return $ HForAllTy ((varName v,k),a) i
+    go (FunTy a b) = do
+      ai <- getTypeIndex a
+      bi <- getTypeIndex b
+      return $ if isPredTy a
+                  then HQualTy ai bi
+                  else HFunTy ai bi
+    go (LitTy a) = return $ HLitTy $ toIfaceTyLit a
+    go (CastTy t _) = do
+      i <- getTypeIndex t
+      return $ HCastTy i
+    go (CoercionTy _) = return HCoercionTy
+
+resolveTyVarScopes :: M.Map FastString (HieAST a) -> M.Map FastString (HieAST a)
+resolveTyVarScopes asts = M.map go asts
+  where
+    go ast = resolveTyVarScopeLocal ast asts
+
+resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a
+resolveTyVarScopeLocal ast asts = go ast
+  where
+    resolveNameScope dets = dets{identInfo =
+      S.map resolveScope (identInfo dets)}
+    resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) =
+      TyVarBind sc $ ResolvedScopes
+        [ LocalScope binding
+        | name <- names
+        , Just binding <- [getNameBinding name asts]
+        ]
+    resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) =
+      TyVarBind sc $ ResolvedScopes
+        [ LocalScope binding
+        | name <- names
+        , Just binding <- [getNameBindingInClass name sp asts]
+        ]
+    resolveScope scope = scope
+    go (Node info span children) = Node info' span $ map go children
+      where
+        info' = info { nodeIdentifiers = idents }
+        idents = M.map resolveNameScope $ nodeIdentifiers info
+
+getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span
+getNameBinding n asts = do
+  (_,msp) <- getNameScopeAndBinding n asts
+  msp
+
+getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope]
+getNameScope n asts = do
+  (scopes,_) <- getNameScopeAndBinding n asts
+  return scopes
+
+getNameBindingInClass
+  :: Name
+  -> Span
+  -> M.Map FastString (HieAST a)
+  -> Maybe Span
+getNameBindingInClass n sp asts = do
+  ast <- M.lookup (srcSpanFile sp) asts
+  getFirst $ foldMap First $ do
+    child <- flattenAst ast
+    dets <- maybeToList
+      $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child
+    let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
+    return (getFirst binding)
+
+getNameScopeAndBinding
+  :: Name
+  -> M.Map FastString (HieAST a)
+  -> Maybe ([Scope], Maybe Span)
+getNameScopeAndBinding n asts = case nameSrcSpan n of
+  RealSrcSpan sp -> do -- @Maybe
+    ast <- M.lookup (srcSpanFile sp) asts
+    defNode <- selectLargestContainedBy sp ast
+    getFirst $ foldMap First $ do -- @[]
+      node <- flattenAst defNode
+      dets <- maybeToList
+        $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo node
+      scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)
+      let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
+      return $ Just (scopes, getFirst binding)
+  _ -> Nothing
+
+getScopeFromContext :: ContextInfo -> Maybe [Scope]
+getScopeFromContext (ValBind _ sc _) = Just [sc]
+getScopeFromContext (PatternBind a b _) = Just [a, b]
+getScopeFromContext (ClassTyDecl _) = Just [ModuleScope]
+getScopeFromContext (Decl _ _) = Just [ModuleScope]
+getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs
+getScopeFromContext (TyVarBind a _) = Just [a]
+getScopeFromContext _ = Nothing
+
+getBindSiteFromContext :: ContextInfo -> Maybe Span
+getBindSiteFromContext (ValBind _ _ sp) = sp
+getBindSiteFromContext (PatternBind _ _ sp) = sp
+getBindSiteFromContext _ = Nothing
+
+flattenAst :: HieAST a -> [HieAST a]
+flattenAst n =
+  n : concatMap flattenAst (nodeChildren n)
+
+smallestContainingSatisfying
+  :: Span
+  -> (HieAST a -> Bool)
+  -> HieAST a
+  -> Maybe (HieAST a)
+smallestContainingSatisfying sp cond node
+  | nodeSpan node `containsSpan` sp = getFirst $ mconcat
+      [ foldMap (First . smallestContainingSatisfying sp cond) $
+          nodeChildren node
+      , First $ if cond node then Just node else Nothing
+      ]
+  | sp `containsSpan` nodeSpan node = Nothing
+  | otherwise = Nothing
+
+selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a)
+selectLargestContainedBy sp node
+  | sp `containsSpan` nodeSpan node = Just node
+  | nodeSpan node `containsSpan` sp =
+      getFirst $ foldMap (First . selectLargestContainedBy sp) $
+        nodeChildren node
+  | otherwise = Nothing
+
+selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a)
+selectSmallestContaining sp node
+  | nodeSpan node `containsSpan` sp = getFirst $ mconcat
+      [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node
+      , First (Just node)
+      ]
+  | sp `containsSpan` nodeSpan node = Nothing
+  | otherwise = Nothing
+
+definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool
+definedInAsts asts n = case nameSrcSpan n of
+  RealSrcSpan sp -> srcSpanFile sp `elem` M.keys asts
+  _ -> False
+
+isOccurrence :: ContextInfo -> Bool
+isOccurrence Use = True
+isOccurrence _ = False
+
+scopeContainsSpan :: Scope -> Span -> Bool
+scopeContainsSpan NoScope _ = False
+scopeContainsSpan ModuleScope _ = True
+scopeContainsSpan (LocalScope a) b = a `containsSpan` b
+
+-- | One must contain the other. Leaf nodes cannot contain anything
+combineAst :: HieAST Type -> HieAST Type -> HieAST Type
+combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys)
+  | aSpn == bSpn = Node (aInf `combineNodeInfo` bInf) aSpn (mergeAsts xs ys)
+  | aSpn `containsSpan` bSpn = combineAst b a
+combineAst a (Node xs span children) = Node xs span (insertAst a children)
+
+-- | Insert an AST in a sorted list of disjoint Asts
+insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]
+insertAst x = mergeAsts [x]
+
+-- | Merge two nodes together.
+--
+-- Precondition and postcondition: elements in 'nodeType' are ordered.
+combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type
+(NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) =
+  NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd)
+  where
+    mergeSorted :: [Type] -> [Type] -> [Type]
+    mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of
+                                        LT -> a : mergeSorted as lb
+                                        EQ -> a : mergeSorted as bs
+                                        GT -> b : mergeSorted la bs
+    mergeSorted as [] = as
+    mergeSorted [] bs = bs
+
+
+{- | Merge two sorted, disjoint lists of ASTs, combining when necessary.
+
+In the absence of position-altering pragmas (ex: @# line "file.hs" 3@),
+different nodes in an AST tree should either have disjoint spans (in
+which case you can say for sure which one comes first) or one span
+should be completely contained in the other (in which case the contained
+span corresponds to some child node).
+
+However, since Haskell does have position-altering pragmas it /is/
+possible for spans to be overlapping. Here is an example of a source file
+in which @foozball@ and @quuuuuux@ have overlapping spans:
+
+@
+module Baz where
+
+# line 3 "Baz.hs"
+foozball :: Int
+foozball = 0
+
+# line 3 "Baz.hs"
+bar, quuuuuux :: Int
+bar = 1
+quuuuuux = 2
+@
+
+In these cases, we just do our best to produce sensible `HieAST`'s. The blame
+should be laid at the feet of whoever wrote the line pragmas in the first place
+(usually the C preprocessor...).
+-}
+mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type]
+mergeAsts xs [] = xs
+mergeAsts [] ys = ys
+mergeAsts xs@(a:as) ys@(b:bs)
+  | span_a `containsSpan`   span_b = mergeAsts (combineAst a b : as) bs
+  | span_b `containsSpan`   span_a = mergeAsts as (combineAst a b : bs)
+  | span_a `rightOf`        span_b = b : mergeAsts xs bs
+  | span_a `leftOf`         span_b = a : mergeAsts as ys
+
+  -- These cases are to work around ASTs that are not fully disjoint
+  | span_a `startsRightOf`  span_b = b : mergeAsts as ys
+  | otherwise                      = a : mergeAsts as ys
+  where
+    span_a = nodeSpan a
+    span_b = nodeSpan b
+
+rightOf :: Span -> Span -> Bool
+rightOf s1 s2
+  = (srcSpanStartLine s1, srcSpanStartCol s1)
+       >= (srcSpanEndLine s2, srcSpanEndCol s2)
+    && (srcSpanFile s1 == srcSpanFile s2)
+
+leftOf :: Span -> Span -> Bool
+leftOf s1 s2
+  = (srcSpanEndLine s1, srcSpanEndCol s1)
+       <= (srcSpanStartLine s2, srcSpanStartCol s2)
+    && (srcSpanFile s1 == srcSpanFile s2)
+
+startsRightOf :: Span -> Span -> Bool
+startsRightOf s1 s2
+  = (srcSpanStartLine s1, srcSpanStartCol s1)
+       >= (srcSpanStartLine s2, srcSpanStartCol s2)
+
+-- | combines and sorts ASTs using a merge sort
+mergeSortAsts :: [HieAST Type] -> [HieAST Type]
+mergeSortAsts = go . map pure
+  where
+    go [] = []
+    go [xs] = xs
+    go xss = go (mergePairs xss)
+    mergePairs [] = []
+    mergePairs [xs] = [xs]
+    mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss
+
+simpleNodeInfo :: FastString -> FastString -> NodeInfo a
+simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty
+
+locOnly :: SrcSpan -> [HieAST a]
+locOnly (RealSrcSpan span) =
+  [Node e span []]
+    where e = NodeInfo S.empty [] M.empty
+locOnly _ = []
+
+mkScope :: SrcSpan -> Scope
+mkScope (RealSrcSpan sp) = LocalScope sp
+mkScope _ = NoScope
+
+mkLScope :: Located a -> Scope
+mkLScope = mkScope . getLoc
+
+combineScopes :: Scope -> Scope -> Scope
+combineScopes ModuleScope _ = ModuleScope
+combineScopes _ ModuleScope = ModuleScope
+combineScopes NoScope x = x
+combineScopes x NoScope = x
+combineScopes (LocalScope a) (LocalScope b) =
+  mkScope $ combineSrcSpans (RealSrcSpan a) (RealSrcSpan b)
+
+{-# INLINEABLE makeNode #-}
+makeNode
+  :: (Applicative m, Data a)
+  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')
+  -> SrcSpan                 -- ^ return an empty list if this is unhelpful
+  -> m [HieAST b]
+makeNode x spn = pure $ case spn of
+  RealSrcSpan span -> [Node (simpleNodeInfo cons typ) span []]
+  _ -> []
+  where
+    cons = mkFastString . show . toConstr $ x
+    typ = mkFastString . show . typeRepTyCon . typeOf $ x
+
+{-# INLINEABLE makeTypeNode #-}
+makeTypeNode
+  :: (Applicative m, Data a)
+  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')
+  -> SrcSpan                 -- ^ return an empty list if this is unhelpful
+  -> Type                    -- ^ type to associate with the node
+  -> m [HieAST Type]
+makeTypeNode x spn etyp = pure $ case spn of
+  RealSrcSpan span ->
+    [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]
+  _ -> []
+  where
+    cons = mkFastString . show . toConstr $ x
+    typ = mkFastString . show . typeRepTyCon . typeOf $ x
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
new file mode 100644
--- /dev/null
+++ b/compiler/hsSyn/Convert.hs
@@ -0,0 +1,1973 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+This module converts Template Haskell syntax into HsSyn
+-}
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
+                convertToHsType,
+                thRdrNameGuesses ) where
+
+import GhcPrelude
+
+import HsSyn as Hs
+import PrelNames
+import RdrName
+import qualified Name
+import Module
+import RdrHsSyn
+import OccName
+import SrcLoc
+import Type
+import qualified Coercion ( Role(..) )
+import TysWiredIn
+import BasicTypes as Hs
+import ForeignCall
+import Unique
+import ErrUtils
+import Bag
+import Lexeme
+import Util
+import FastString
+import Outputable
+import MonadUtils ( foldrM )
+
+import qualified Data.ByteString as BS
+import Control.Monad( unless, liftM, ap )
+
+import Data.Maybe( catMaybes, isNothing )
+import Language.Haskell.TH as TH hiding (sigP)
+import Language.Haskell.TH.Syntax as TH
+
+-------------------------------------------------------------------
+--              The external interface
+
+convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]
+convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))
+  where
+    cvt_dec d = wrapMsg "declaration" d (cvtDec d)
+
+convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)
+convertToHsExpr loc e
+  = initCvt loc $ wrapMsg "expression" e $ cvtl e
+
+convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)
+convertToPat loc p
+  = initCvt loc $ wrapMsg "pattern" p $ cvtPat p
+
+convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)
+convertToHsType loc t
+  = initCvt loc $ wrapMsg "type" t $ cvtType t
+
+-------------------------------------------------------------------
+newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
+        -- Push down the source location;
+        -- Can fail, with a single error message
+
+-- NB: If the conversion succeeds with (Right x), there should
+--     be no exception values hiding in x
+-- Reason: so a (head []) in TH code doesn't subsequently
+--         make GHC crash when it tries to walk the generated tree
+
+-- Use the loc everywhere, for lack of anything better
+-- In particular, we want it on binding locations, so that variables bound in
+-- the spliced-in declarations get a location that at least relates to the splice point
+
+instance Functor CvtM where
+    fmap = liftM
+
+instance Applicative CvtM where
+    pure x = CvtM $ \loc -> Right (loc,x)
+    (<*>) = ap
+
+instance Monad CvtM where
+  (CvtM m) >>= k = CvtM $ \loc -> case m loc of
+                                  Left err -> Left err
+                                  Right (loc',v) -> unCvtM (k v) loc'
+
+initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
+initCvt loc (CvtM m) = fmap snd (m loc)
+
+force :: a -> CvtM ()
+force a = a `seq` return ()
+
+failWith :: MsgDoc -> CvtM a
+failWith m = CvtM (\_ -> Left m)
+
+getL :: CvtM SrcSpan
+getL = CvtM (\loc -> Right (loc,loc))
+
+setL :: SrcSpan -> CvtM ()
+setL loc = CvtM (\_ -> Right (loc, ()))
+
+returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a
+returnL x = CvtM (\loc -> Right (loc, cL loc x))
+
+returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
+returnJustL = fmap Just . returnL
+
+wrapParL :: HasSrcSpan a =>
+            (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess  a)
+wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x)))
+
+wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
+-- E.g  wrapMsg "declaration" dec thing
+wrapMsg what item (CvtM m)
+  = CvtM (\loc -> case m loc of
+                     Left err -> Left (err $$ getPprStyle msg)
+                     Right v  -> Right v)
+  where
+        -- Show the item in pretty syntax normally,
+        -- but with all its constructors if you say -dppr-debug
+    msg sty = hang (text "When splicing a TH" <+> text what <> colon)
+                 2 (if debugStyle sty
+                    then text (show item)
+                    else text (pprint item))
+
+wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
+wrapL (CvtM m) = CvtM (\loc -> case m loc of
+                               Left err -> Left err
+                               Right (loc',v) -> Right (loc',cL loc v))
+
+-------------------------------------------------------------------
+cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
+cvtDecs = fmap catMaybes . mapM cvtDec
+
+cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))
+cvtDec (TH.ValD pat body ds)
+  | TH.VarP s <- pat
+  = do  { s' <- vNameL s
+        ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
+        ; returnJustL $ Hs.ValD noExt $ mkFunBind s' [cl'] }
+
+  | otherwise
+  = do  { pat' <- cvtPat pat
+        ; body' <- cvtGuard body
+        ; ds' <- cvtLocalDecs (text "a where clause") ds
+        ; returnJustL $ Hs.ValD noExt $
+          PatBind { pat_lhs = pat'
+                  , pat_rhs = GRHSs noExt body' (noLoc ds')
+                  , pat_ext = noExt
+                  , pat_ticks = ([],[]) } }
+
+cvtDec (TH.FunD nm cls)
+  | null cls
+  = failWith (text "Function binding for"
+                 <+> quotes (text (TH.pprint nm))
+                 <+> text "has no equations")
+  | otherwise
+  = do  { nm' <- vNameL nm
+        ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
+        ; returnJustL $ Hs.ValD noExt $ mkFunBind nm' cls' }
+
+cvtDec (TH.SigD nm typ)
+  = do  { nm' <- vNameL nm
+        ; ty' <- cvtType typ
+        ; returnJustL $ Hs.SigD noExt
+                                    (TypeSig noExt [nm'] (mkLHsSigWcType ty')) }
+
+cvtDec (TH.InfixD fx nm)
+  -- Fixity signatures are allowed for variables, constructors, and types
+  -- the renamer automatically looks for types during renaming, even when
+  -- the RdrName says it's a variable or a constructor. So, just assume
+  -- it's a variable or constructor and proceed.
+  = do { nm' <- vcNameL nm
+       ; returnJustL (Hs.SigD noExt (FixSig noExt
+                                      (FixitySig noExt [nm'] (cvtFixity fx)))) }
+
+cvtDec (PragmaD prag)
+  = cvtPragmaD prag
+
+cvtDec (TySynD tc tvs rhs)
+  = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
+        ; rhs' <- cvtType rhs
+        ; returnJustL $ TyClD noExt $
+          SynDecl { tcdSExt = noExt, tcdLName = tc', tcdTyVars = tvs'
+                  , tcdFixity = Prefix
+                  , tcdRhs = rhs' } }
+
+cvtDec (DataD ctxt tc tvs ksig constrs derivs)
+  = do  { let isGadtCon (GadtC    _ _ _) = True
+              isGadtCon (RecGadtC _ _ _) = True
+              isGadtCon (ForallC  _ _ c) = isGadtCon c
+              isGadtCon _                = False
+              isGadtDecl  = all isGadtCon constrs
+              isH98Decl   = all (not . isGadtCon) constrs
+        ; unless (isGadtDecl || isH98Decl)
+                 (failWith (text "Cannot mix GADT constructors with Haskell 98"
+                        <+> text "constructors"))
+        ; unless (isNothing ksig || isGadtDecl)
+                 (failWith (text "Kind signatures are only allowed on GADTs"))
+        ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
+        ; ksig' <- cvtKind `traverse` ksig
+        ; cons' <- mapM cvtConstr constrs
+        ; derivs' <- cvtDerivs derivs
+        ; let defn = HsDataDefn { dd_ext = noExt
+                                , dd_ND = DataType, dd_cType = Nothing
+                                , dd_ctxt = ctxt'
+                                , dd_kindSig = ksig'
+                                , dd_cons = cons', dd_derivs = derivs' }
+        ; returnJustL $ TyClD noExt (DataDecl
+                                        { tcdDExt = noExt
+                                        , tcdLName = tc', tcdTyVars = tvs'
+                                        , tcdFixity = Prefix
+                                        , tcdDataDefn = defn }) }
+
+cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
+  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
+        ; ksig' <- cvtKind `traverse` ksig
+        ; con' <- cvtConstr constr
+        ; derivs' <- cvtDerivs derivs
+        ; let defn = HsDataDefn { dd_ext = noExt
+                                , dd_ND = NewType, dd_cType = Nothing
+                                , dd_ctxt = ctxt'
+                                , dd_kindSig = ksig'
+                                , dd_cons = [con']
+                                , dd_derivs = derivs' }
+        ; returnJustL $ TyClD noExt (DataDecl
+                                    { tcdDExt = noExt
+                                    , tcdLName = tc', tcdTyVars = tvs'
+                                    , tcdFixity = Prefix
+                                    , tcdDataDefn = defn }) }
+
+cvtDec (ClassD ctxt cl tvs fds decs)
+  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
+        ; fds'  <- mapM cvt_fundep fds
+        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (text "a class declaration") decs
+        ; unless (null adts')
+            (failWith $ (text "Default data instance declarations"
+                     <+> text "are not allowed:")
+                   $$ (Outputable.ppr adts'))
+        ; at_defs <- mapM cvt_at_def ats'
+        ; returnJustL $ TyClD noExt $
+          ClassDecl { tcdCExt = noExt
+                    , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
+                    , tcdFixity = Prefix
+                    , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
+                    , tcdMeths = binds'
+                    , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] }
+                              -- no docs in TH ^^
+        }
+  where
+    cvt_at_def :: LTyFamInstDecl GhcPs -> CvtM (LTyFamDefltEqn GhcPs)
+    -- Very similar to what happens in RdrHsSyn.mkClassDecl
+    cvt_at_def decl = case RdrHsSyn.mkATDefault decl of
+                        Right (def, _) -> return def
+                        Left (_, msg) -> failWith msg
+
+cvtDec (InstanceD o ctxt ty decs)
+  = do  { let doc = text "an instance declaration"
+        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
+        ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
+        ; ctxt' <- cvtContext ctxt
+        ; (dL->L loc ty') <- cvtType ty
+        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'
+        ; returnJustL $ InstD noExt $ ClsInstD noExt $
+          ClsInstDecl { cid_ext = noExt, cid_poly_ty = mkLHsSigType inst_ty'
+                      , cid_binds = binds'
+                      , cid_sigs = Hs.mkClassOpSigs sigs'
+                      , cid_tyfam_insts = ats', cid_datafam_insts = adts'
+                      , cid_overlap_mode = fmap (cL loc . overlap) o } }
+  where
+  overlap pragma =
+    case pragma of
+      TH.Overlaps      -> Hs.Overlaps     (SourceText "OVERLAPS")
+      TH.Overlappable  -> Hs.Overlappable (SourceText "OVERLAPPABLE")
+      TH.Overlapping   -> Hs.Overlapping  (SourceText "OVERLAPPING")
+      TH.Incoherent    -> Hs.Incoherent   (SourceText "INCOHERENT")
+
+
+
+
+cvtDec (ForeignD ford)
+  = do { ford' <- cvtForD ford
+       ; returnJustL $ ForD noExt ford' }
+
+cvtDec (DataFamilyD tc tvs kind)
+  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
+       ; result <- cvtMaybeKindToFamilyResultSig kind
+       ; returnJustL $ TyClD noExt $ FamDecl noExt $
+         FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing }
+
+cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
+  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
+       ; ksig' <- cvtKind `traverse` ksig
+       ; cons' <- mapM cvtConstr constrs
+       ; derivs' <- cvtDerivs derivs
+       ; let defn = HsDataDefn { dd_ext = noExt
+                               , dd_ND = DataType, dd_cType = Nothing
+                               , dd_ctxt = ctxt'
+                               , dd_kindSig = ksig'
+                               , dd_cons = cons', dd_derivs = derivs' }
+
+       ; returnJustL $ InstD noExt $ DataFamInstD
+           { dfid_ext = noExt
+           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
+                           FamEqn { feqn_ext = noExt
+                                  , feqn_tycon = tc'
+                                  , feqn_bndrs = bndrs'
+                                  , feqn_pats = typats'
+                                  , feqn_rhs = defn
+                                  , feqn_fixity = Prefix } }}}
+
+cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
+  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
+       ; ksig' <- cvtKind `traverse` ksig
+       ; con' <- cvtConstr constr
+       ; derivs' <- cvtDerivs derivs
+       ; let defn = HsDataDefn { dd_ext = noExt
+                               , dd_ND = NewType, dd_cType = Nothing
+                               , dd_ctxt = ctxt'
+                               , dd_kindSig = ksig'
+                               , dd_cons = [con'], dd_derivs = derivs' }
+       ; returnJustL $ InstD noExt $ DataFamInstD
+           { dfid_ext = noExt
+           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
+                           FamEqn { feqn_ext = noExt
+                                  , feqn_tycon = tc'
+                                  , feqn_bndrs = bndrs'
+                                  , feqn_pats = typats'
+                                  , feqn_rhs = defn
+                                  , feqn_fixity = Prefix } }}}
+
+cvtDec (TySynInstD eqn)
+  = do  { (dL->L _ eqn') <- cvtTySynEqn eqn
+        ; returnJustL $ InstD noExt $ TyFamInstD
+            { tfid_ext = noExt
+            , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
+
+cvtDec (OpenTypeFamilyD head)
+  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
+       ; returnJustL $ TyClD noExt $ FamDecl noExt $
+         FamilyDecl noExt OpenTypeFamily tc' tyvars' Prefix result' injectivity'
+       }
+
+cvtDec (ClosedTypeFamilyD head eqns)
+  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
+       ; eqns' <- mapM cvtTySynEqn eqns
+       ; returnJustL $ TyClD noExt $ FamDecl noExt $
+         FamilyDecl noExt (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix
+                           result' injectivity' }
+
+cvtDec (TH.RoleAnnotD tc roles)
+  = do { tc' <- tconNameL tc
+       ; let roles' = map (noLoc . cvtRole) roles
+       ; returnJustL $ Hs.RoleAnnotD noExt (RoleAnnotDecl noExt tc' roles') }
+
+cvtDec (TH.StandaloneDerivD ds cxt ty)
+  = do { cxt' <- cvtContext cxt
+       ; ds'  <- traverse cvtDerivStrategy ds
+       ; (dL->L loc ty') <- cvtType ty
+       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'
+       ; returnJustL $ DerivD noExt $
+         DerivDecl { deriv_ext =noExt
+                   , deriv_strategy = ds'
+                   , deriv_type = mkLHsSigWcType inst_ty'
+                   , deriv_overlap_mode = Nothing } }
+
+cvtDec (TH.DefaultSigD nm typ)
+  = do { nm' <- vNameL nm
+       ; ty' <- cvtType typ
+       ; returnJustL $ Hs.SigD noExt
+                     $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')}
+
+cvtDec (TH.PatSynD nm args dir pat)
+  = do { nm'   <- cNameL nm
+       ; args' <- cvtArgs args
+       ; dir'  <- cvtDir nm' dir
+       ; pat'  <- cvtPat pat
+       ; returnJustL $ Hs.ValD noExt $ PatSynBind noExt $
+           PSB noExt nm' args' pat' dir' }
+  where
+    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args
+    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2
+    cvtArgs (TH.RecordPatSyn sels)
+      = do { sels' <- mapM vNameL sels
+           ; vars' <- mapM (vNameL . mkNameS . nameBase) sels
+           ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }
+
+    cvtDir _ Unidir          = return Unidirectional
+    cvtDir _ ImplBidir       = return ImplicitBidirectional
+    cvtDir n (ExplBidir cls) =
+      do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
+         ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
+
+cvtDec (TH.PatSynSigD nm ty)
+  = do { nm' <- cNameL nm
+       ; ty' <- cvtPatSynSigTy ty
+       ; returnJustL $ Hs.SigD noExt $ PatSynSig noExt [nm'] (mkLHsSigType ty')}
+
+-- Implicit parameter bindings are handled in cvtLocalDecs and
+-- cvtImplicitParamBind. They are not allowed in any other scope, so
+-- reaching this case indicates an error.
+cvtDec (TH.ImplicitParamBindD _ _)
+  = failWith (text "Implicit parameter binding only allowed in let or where")
+
+----------------
+cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
+cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)
+  = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs
+       ; (head_ty, args) <- split_ty_app lhs
+       ; case head_ty of
+           ConT nm -> do { nm' <- tconNameL nm
+                         ; rhs' <- cvtType rhs
+                         ; let args' = map wrap_tyarg args
+                         ; returnL $ mkHsImplicitBndrs
+                            $ FamEqn { feqn_ext    = noExt
+                                     , feqn_tycon  = nm'
+                                     , feqn_bndrs  = mb_bndrs'
+                                     , feqn_pats   = args'
+                                     , feqn_fixity = Prefix
+                                     , feqn_rhs    = rhs' } }
+           InfixT t1 nm t2 -> do { nm' <- tconNameL nm
+                                 ; args' <- mapM cvtType [t1,t2]
+                                 ; rhs' <- cvtType rhs
+                                 ; returnL $ mkHsImplicitBndrs
+                                      $ FamEqn { feqn_ext    = noExt
+                                               , feqn_tycon  = nm'
+                                               , feqn_bndrs  = mb_bndrs'
+                                               , feqn_pats   =
+                                                (map HsValArg args') ++ args
+                                               , feqn_fixity = Hs.Infix
+                                               , feqn_rhs    = rhs' } }
+           _ -> failWith $ text "Invalid type family instance LHS:"
+                          <+> text (show lhs)
+        }
+
+----------------
+cvt_ci_decs :: MsgDoc -> [TH.Dec]
+            -> CvtM (LHsBinds GhcPs,
+                     [LSig GhcPs],
+                     [LFamilyDecl GhcPs],
+                     [LTyFamInstDecl GhcPs],
+                     [LDataFamInstDecl GhcPs])
+-- Convert the declarations inside a class or instance decl
+-- ie signatures, bindings, and associated types
+cvt_ci_decs doc decs
+  = do  { decs' <- cvtDecs decs
+        ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
+        ; let (adts', no_ats')       = partitionWith is_datafam_inst bind_sig_decs'
+        ; let (sigs', prob_binds')   = partitionWith is_sig no_ats'
+        ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
+        ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
+        ; unless (null bads) (failWith (mkBadDecMsg doc bads))
+          --We use FromSource as the origin of the bind
+          -- because the TH declaration is user-written
+        ; return (listToBag binds', sigs', fams', ats', adts') }
+
+----------------
+cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
+             -> CvtM ( LHsContext GhcPs
+                     , Located RdrName
+                     , LHsQTyVars GhcPs)
+cvt_tycl_hdr cxt tc tvs
+  = do { cxt' <- cvtContext cxt
+       ; tc'  <- tconNameL tc
+       ; tvs' <- cvtTvs tvs
+       ; return (cxt', tc', tvs')
+       }
+
+cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type
+               -> CvtM ( LHsContext GhcPs
+                       , Located RdrName
+                       , Maybe [LHsTyVarBndr GhcPs]
+                       , HsTyPats GhcPs)
+cvt_datainst_hdr cxt bndrs tys
+  = do { cxt' <- cvtContext cxt
+       ; bndrs' <- traverse (mapM cvt_tv) bndrs
+       ; (head_ty, args) <- split_ty_app tys
+       ; case head_ty of
+          ConT nm -> do { nm' <- tconNameL nm
+                        ; let args' = map wrap_tyarg args
+                        ; return (cxt', nm', bndrs', args') }
+          InfixT t1 nm t2 -> do { nm' <- tconNameL nm
+                                ; args' <- mapM cvtType [t1,t2]
+                                ; return (cxt', nm', bndrs',
+                                         ((map HsValArg args') ++ args)) }
+          _ -> failWith $ text "Invalid type instance header:"
+                          <+> text (show tys) }
+
+----------------
+cvt_tyfam_head :: TypeFamilyHead
+               -> CvtM ( Located RdrName
+                       , LHsQTyVars GhcPs
+                       , Hs.LFamilyResultSig GhcPs
+                       , Maybe (Hs.LInjectivityAnn GhcPs))
+
+cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
+  = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars
+       ; result' <- cvtFamilyResultSig result
+       ; injectivity' <- traverse cvtInjectivityAnnotation injectivity
+       ; return (tc', tyvars', result', injectivity') }
+
+-------------------------------------------------------------------
+--              Partitioning declarations
+-------------------------------------------------------------------
+
+is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
+is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d)
+is_fam_decl decl = Right decl
+
+is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
+is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
+  = Left (cL loc d)
+is_tyfam_inst decl
+  = Right decl
+
+is_datafam_inst :: LHsDecl GhcPs
+                -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
+is_datafam_inst (dL->L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))
+  = Left (cL loc d)
+is_datafam_inst decl
+  = Right decl
+
+is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
+is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig)
+is_sig decl                        = Right decl
+
+is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
+is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind)
+is_bind decl                         = Right decl
+
+is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec
+is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)
+is_ip_bind decl             = Right decl
+
+mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
+mkBadDecMsg doc bads
+  = sep [ text "Illegal declaration(s) in" <+> doc <> colon
+        , nest 2 (vcat (map Outputable.ppr bads)) ]
+
+---------------------------------------------------
+--      Data types
+---------------------------------------------------
+
+cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)
+
+cvtConstr (NormalC c strtys)
+  = do  { c'   <- cNameL c
+        ; tys' <- mapM cvt_arg strtys
+        ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') }
+
+cvtConstr (RecC c varstrtys)
+  = do  { c'    <- cNameL c
+        ; args' <- mapM cvt_id_arg varstrtys
+        ; returnL $ mkConDeclH98 c' Nothing Nothing
+                                   (RecCon (noLoc args')) }
+
+cvtConstr (InfixC st1 c st2)
+  = do  { c'   <- cNameL c
+        ; st1' <- cvt_arg st1
+        ; st2' <- cvt_arg st2
+        ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') }
+
+cvtConstr (ForallC tvs ctxt con)
+  = do  { tvs'      <- cvtTvs tvs
+        ; ctxt'     <- cvtContext ctxt
+        ; (dL->L _ con')  <- cvtConstr con
+        ; returnL $ add_forall tvs' ctxt' con' }
+  where
+    add_cxt lcxt         Nothing           = Just lcxt
+    add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2))
+      = Just (cL loc (cxt1 ++ cxt2))
+
+    add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
+      = con { con_forall = noLoc $ not (null all_tvs)
+            , con_qvars  = mkHsQTvs all_tvs
+            , con_mb_cxt = add_cxt cxt' cxt }
+      where
+        all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars
+
+    add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })
+      = con { con_forall = noLoc $ not (null all_tvs)
+            , con_ex_tvs = all_tvs
+            , con_mb_cxt = add_cxt cxt' cxt }
+      where
+        all_tvs = hsQTvExplicit tvs' ++ ex_tvs
+
+    add_forall _ _ (XConDecl _) = panic "cvtConstr"
+
+cvtConstr (GadtC c strtys ty)
+  = do  { c'      <- mapM cNameL c
+        ; args    <- mapM cvt_arg strtys
+        ; (dL->L _ ty') <- cvtType ty
+        ; c_ty    <- mk_arr_apps args ty'
+        ; returnL $ fst $ mkGadtDecl c' c_ty}
+
+cvtConstr (RecGadtC c varstrtys ty)
+  = do  { c'       <- mapM cNameL c
+        ; ty'      <- cvtType ty
+        ; rec_flds <- mapM cvt_id_arg varstrtys
+        ; let rec_ty = noLoc (HsFunTy noExt
+                                           (noLoc $ HsRecTy noExt rec_flds) ty')
+        ; returnL $ fst $ mkGadtDecl c' rec_ty }
+
+cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
+cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
+cvtSrcUnpackedness SourceNoUnpack       = SrcNoUnpack
+cvtSrcUnpackedness SourceUnpack         = SrcUnpack
+
+cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness
+cvtSrcStrictness NoSourceStrictness = NoSrcStrict
+cvtSrcStrictness SourceLazy         = SrcLazy
+cvtSrcStrictness SourceStrict       = SrcStrict
+
+cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)
+cvt_arg (Bang su ss, ty)
+  = do { ty'' <- cvtType ty
+       ; let ty' = parenthesizeHsType appPrec ty''
+             su' = cvtSrcUnpackedness su
+             ss' = cvtSrcStrictness ss
+       ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' }
+
+cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
+cvt_id_arg (i, str, ty)
+  = do  { (dL->L li i') <- vNameL i
+        ; ty' <- cvt_arg (str,ty)
+        ; return $ noLoc (ConDeclField
+                          { cd_fld_ext = noExt
+                          , cd_fld_names
+                              = [cL li $ FieldOcc noExt (cL li i')]
+                          , cd_fld_type =  ty'
+                          , cd_fld_doc = Nothing}) }
+
+cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
+cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs
+                  ; returnL cs' }
+
+cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)
+cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
+                               ; ys' <- mapM tNameL ys
+                               ; returnL (xs', ys') }
+
+
+------------------------------------------
+--      Foreign declarations
+------------------------------------------
+
+cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
+cvtForD (ImportF callconv safety from nm ty)
+  -- the prim and javascript calling conventions do not support headers
+  -- and are inserted verbatim, analogous to mkImport in RdrHsSyn
+  | callconv == TH.Prim || callconv == TH.JavaScript
+  = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing
+                    (CFunction (StaticTarget (SourceText from)
+                                             (mkFastString from) Nothing
+                                             True))
+                    (noLoc $ quotedSourceText from))
+  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
+                                 (mkFastString (TH.nameBase nm))
+                                 from (noLoc $ quotedSourceText from)
+  = mk_imp impspec
+  | otherwise
+  = failWith $ text (show from) <+> text "is not a valid ccall impent"
+  where
+    mk_imp impspec
+      = do { nm' <- vNameL nm
+           ; ty' <- cvtType ty
+           ; return (ForeignImport { fd_i_ext = noExt
+                                   , fd_name = nm'
+                                   , fd_sig_ty = mkLHsSigType ty'
+                                   , fd_fi = impspec })
+           }
+    safety' = case safety of
+                     Unsafe     -> PlayRisky
+                     Safe       -> PlaySafe
+                     Interruptible -> PlayInterruptible
+
+cvtForD (ExportF callconv as nm ty)
+  = do  { nm' <- vNameL nm
+        ; ty' <- cvtType ty
+        ; let e = CExport (noLoc (CExportStatic (SourceText as)
+                                                (mkFastString as)
+                                                (cvt_conv callconv)))
+                                                (noLoc (SourceText as))
+        ; return $ ForeignExport { fd_e_ext = noExt
+                                 , fd_name = nm'
+                                 , fd_sig_ty = mkLHsSigType ty'
+                                 , fd_fe = e } }
+
+cvt_conv :: TH.Callconv -> CCallConv
+cvt_conv TH.CCall      = CCallConv
+cvt_conv TH.StdCall    = StdCallConv
+cvt_conv TH.CApi       = CApiConv
+cvt_conv TH.Prim       = PrimCallConv
+cvt_conv TH.JavaScript = JavaScriptCallConv
+
+------------------------------------------
+--              Pragmas
+------------------------------------------
+
+cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
+cvtPragmaD (InlineP nm inline rm phases)
+  = do { nm' <- vNameL nm
+       ; let dflt = dfltActivation inline
+       ; let src TH.NoInline  = "{-# NOINLINE"
+             src TH.Inline    = "{-# INLINE"
+             src TH.Inlinable = "{-# INLINABLE"
+       ; let ip   = InlinePragma { inl_src    = SourceText $ src inline
+                                 , inl_inline = cvtInline inline
+                                 , inl_rule   = cvtRuleMatch rm
+                                 , inl_act    = cvtPhases phases dflt
+                                 , inl_sat    = Nothing }
+       ; returnJustL $ Hs.SigD noExt $ InlineSig noExt nm' ip }
+
+cvtPragmaD (SpecialiseP nm ty inline phases)
+  = do { nm' <- vNameL nm
+       ; ty' <- cvtType ty
+       ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"
+             src TH.Inline    = "{-# SPECIALISE INLINE"
+             src TH.Inlinable = "{-# SPECIALISE INLINE"
+       ; let (inline', dflt,srcText) = case inline of
+               Just inline1 -> (cvtInline inline1, dfltActivation inline1,
+                                src inline1)
+               Nothing      -> (NoUserInline,   AlwaysActive,
+                                "{-# SPECIALISE")
+       ; let ip = InlinePragma { inl_src    = SourceText srcText
+                               , inl_inline = inline'
+                               , inl_rule   = Hs.FunLike
+                               , inl_act    = cvtPhases phases dflt
+                               , inl_sat    = Nothing }
+       ; returnJustL $ Hs.SigD noExt $ SpecSig noExt nm' [mkLHsSigType ty'] ip }
+
+cvtPragmaD (SpecialiseInstP ty)
+  = do { ty' <- cvtType ty
+       ; returnJustL $ Hs.SigD noExt $
+         SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
+
+cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
+  = do { let nm' = mkFastString nm
+       ; let act = cvtPhases phases AlwaysActive
+       ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs
+       ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs
+       ; lhs'   <- cvtl lhs
+       ; rhs'   <- cvtl rhs
+       ; returnJustL $ Hs.RuleD noExt
+            $ HsRules { rds_ext = noExt
+                      , rds_src = SourceText "{-# RULES"
+                      , rds_rules = [noLoc $
+                          HsRule { rd_ext  = noExt
+                                 , rd_name = (noLoc (quotedSourceText nm,nm'))
+                                 , rd_act  = act
+                                 , rd_tyvs = ty_bndrs'
+                                 , rd_tmvs = tm_bndrs'
+                                 , rd_lhs  = lhs'
+                                 , rd_rhs  = rhs' }] }
+
+          }
+
+cvtPragmaD (AnnP target exp)
+  = do { exp' <- cvtl exp
+       ; target' <- case target of
+         ModuleAnnotation  -> return ModuleAnnProvenance
+         TypeAnnotation n  -> do
+           n' <- tconName n
+           return (TypeAnnProvenance  (noLoc n'))
+         ValueAnnotation n -> do
+           n' <- vcName n
+           return (ValueAnnProvenance (noLoc n'))
+       ; returnJustL $ Hs.AnnD noExt
+                     $ HsAnnotation noExt (SourceText "{-# ANN") target' exp'
+       }
+
+cvtPragmaD (LineP line file)
+  = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))
+       ; return Nothing
+       }
+cvtPragmaD (CompleteP cls mty)
+  = do { cls' <- noLoc <$> mapM cNameL cls
+       ; mty'  <- traverse tconNameL mty
+       ; returnJustL $ Hs.SigD noExt
+                   $ CompleteMatchSig noExt NoSourceText cls' mty' }
+
+dfltActivation :: TH.Inline -> Activation
+dfltActivation TH.NoInline = NeverActive
+dfltActivation _           = AlwaysActive
+
+cvtInline :: TH.Inline -> Hs.InlineSpec
+cvtInline TH.NoInline  = Hs.NoInline
+cvtInline TH.Inline    = Hs.Inline
+cvtInline TH.Inlinable = Hs.Inlinable
+
+cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
+cvtRuleMatch TH.ConLike = Hs.ConLike
+cvtRuleMatch TH.FunLike = Hs.FunLike
+
+cvtPhases :: TH.Phases -> Activation -> Activation
+cvtPhases AllPhases       dflt = dflt
+cvtPhases (FromPhase i)   _    = ActiveAfter NoSourceText i
+cvtPhases (BeforePhase i) _    = ActiveBefore NoSourceText i
+
+cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
+cvtRuleBndr (RuleVar n)
+  = do { n' <- vNameL n
+       ; return $ noLoc $ Hs.RuleBndr noExt n' }
+cvtRuleBndr (TypedRuleVar n ty)
+  = do { n'  <- vNameL n
+       ; ty' <- cvtType ty
+       ; return $ noLoc $ Hs.RuleBndrSig noExt n' $ mkLHsSigWcType ty' }
+
+---------------------------------------------------
+--              Declarations
+---------------------------------------------------
+
+cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)
+cvtLocalDecs doc ds
+  = case partitionWith is_ip_bind ds of
+      ([], []) -> return (EmptyLocalBinds noExt)
+      ([], _) -> do
+        ds' <- cvtDecs ds
+        let (binds, prob_sigs) = partitionWith is_bind ds'
+        let (sigs, bads) = partitionWith is_sig prob_sigs
+        unless (null bads) (failWith (mkBadDecMsg doc bads))
+        return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs))
+      (ip_binds, []) -> do
+        binds <- mapM (uncurry cvtImplicitParamBind) ip_binds
+        return (HsIPBinds noExt (IPBinds noExt binds))
+      ((_:_), (_:_)) ->
+        failWith (text "Implicit parameters mixed with other bindings")
+
+cvtClause :: HsMatchContext RdrName
+          -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
+cvtClause ctxt (Clause ps body wheres)
+  = do  { ps' <- cvtPats ps
+        ; let pps = map (parenthesizePat appPrec) ps'
+        ; g'  <- cvtGuard body
+        ; ds' <- cvtLocalDecs (text "a where clause") wheres
+        ; returnL $ Hs.Match noExt ctxt pps (GRHSs noExt g' (noLoc ds')) }
+
+cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
+cvtImplicitParamBind n e = do
+    n' <- wrapL (ipName n)
+    e' <- cvtl e
+    returnL (IPBind noExt (Left n') e')
+
+-------------------------------------------------------------------
+--              Expressions
+-------------------------------------------------------------------
+
+cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
+cvtl e = wrapL (cvt e)
+  where
+    cvt (VarE s)        = do { s' <- vName s; return $ HsVar noExt (noLoc s') }
+    cvt (ConE s)        = do { s' <- cName s; return $ HsVar noExt (noLoc s') }
+    cvt (LitE l)
+      | overloadedLit l = go cvtOverLit (HsOverLit noExt)
+                             (hsOverLitNeedsParens appPrec)
+      | otherwise       = go cvtLit (HsLit noExt)
+                             (hsLitNeedsParens appPrec)
+      where
+        go :: (Lit -> CvtM (l GhcPs))
+           -> (l GhcPs -> HsExpr GhcPs)
+           -> (l GhcPs -> Bool)
+           -> CvtM (HsExpr GhcPs)
+        go cvt_lit mk_expr is_compound_lit = do
+          l' <- cvt_lit l
+          let e' = mk_expr l'
+          return $ if is_compound_lit l' then HsPar noExt (noLoc e') else e'
+    cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
+                                   ; return $ HsApp noExt (mkLHsPar x')
+                                                          (mkLHsPar y')}
+    cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y
+                                   ; return $ HsApp noExt (mkLHsPar x')
+                                                          (mkLHsPar y')}
+    cvt (AppTypeE e t) = do { e' <- cvtl e
+                            ; t' <- cvtType t
+                            ; let tp = parenthesizeHsType appPrec t'
+                            ; return $ HsAppType noExt e'
+                                     $ mkHsWildCardBndrs tp }
+    cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its
+                               -- own expression to avoid pretty-printing
+                               -- oddities that can result from zero-argument
+                               -- lambda expressions. See #13856.
+    cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
+                            ; let pats = map (parenthesizePat appPrec) ps'
+                            ; return $ HsLam noExt (mkMatchGroup FromSource
+                                             [mkSimpleMatch LambdaExpr
+                                             pats e'])}
+    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms
+                            ; return $ HsLamCase noExt
+                                                   (mkMatchGroup FromSource ms')
+                            }
+    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar noExt e' }
+                                 -- Note [Dropping constructors]
+                                 -- Singleton tuples treated like nothing (just parens)
+    cvt (TupE es)      = do { es' <- mapM cvtl es
+                            ; return $ ExplicitTuple noExt
+                                             (map (noLoc . (Present noExt)) es')
+                                                                         Boxed }
+    cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es
+                                   ; return $ ExplicitTuple noExt
+                                           (map (noLoc . (Present noExt)) es')
+                                                                       Unboxed }
+    cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
+                                       ; unboxedSumChecks alt arity
+                                       ; return $ ExplicitSum noExt
+                                                                   alt arity e'}
+    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
+                            ; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' }
+    cvt (MultiIfE alts)
+      | null alts      = failWith (text "Multi-way if-expression with no alternatives")
+      | otherwise      = do { alts' <- mapM cvtpair alts
+                            ; return $ HsMultiIf noExt alts' }
+    cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds
+                            ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'}
+    cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
+                            ; return $ HsCase noExt e'
+                                                 (mkMatchGroup FromSource ms') }
+    cvt (DoE ss)       = cvtHsDo DoExpr ss
+    cvt (MDoE ss)      = cvtHsDo MDoExpr ss
+    cvt (CompE ss)     = cvtHsDo ListComp ss
+    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd
+                            ; return $ ArithSeq noExt Nothing dd' }
+    cvt (ListE xs)
+      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s)
+                                          ; return (HsLit noExt l') }
+             -- Note [Converting strings]
+      | otherwise       = do { xs' <- mapM cvtl xs
+                             ; return $ ExplicitList noExt Nothing xs'
+                             }
+
+    -- Infix expressions
+    cvt (InfixE (Just x) s (Just y)) =
+      do { x' <- cvtl x
+         ; s' <- cvtl s
+         ; y' <- cvtl y
+         ; let px = parenthesizeHsExpr opPrec x'
+               py = parenthesizeHsExpr opPrec y'
+         ; wrapParL (HsPar noExt)
+           $ OpApp noExt px s' py }
+           -- Parenthesise both arguments and result,
+           -- to ensure this operator application does
+           -- does not get re-associated
+           -- See Note [Operator association]
+    cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
+                                          ; wrapParL (HsPar noExt) $
+                                                          SectionR noExt s' y' }
+                                            -- See Note [Sections in HsSyn] in HsExpr
+    cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
+                                          ; wrapParL (HsPar noExt) $
+                                                          SectionL noExt x' s' }
+
+    cvt (InfixE Nothing  s Nothing ) = do { s' <- cvtl s
+                                          ; return $ HsPar noExt s' }
+                                       -- Can I indicate this is an infix thing?
+                                       -- Note [Dropping constructors]
+
+    cvt (UInfixE x s y)  = do { x' <- cvtl x
+                              ; let x'' = case unLoc x' of
+                                            OpApp {} -> x'
+                                            _ -> mkLHsPar x'
+                              ; cvtOpApp x'' s y } --  Note [Converting UInfix]
+
+    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noExt e' }
+    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
+                              ; let pe = parenthesizeHsExpr sigPrec e'
+                              ; return $ ExprWithTySig noExt pe (mkLHsSigWcType t') }
+    cvt (RecConE c flds) = do { c' <- cNameL c
+                              ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
+                              ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
+    cvt (RecUpdE e flds) = do { e' <- cvtl e
+                              ; flds'
+                                  <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
+                                           flds
+                              ; return $ mkRdrRecordUpd e' flds' }
+    cvt (StaticE e)      = fmap (HsStatic noExt) $ cvtl e
+    cvt (UnboundVarE s)  = do -- Use of 'vcName' here instead of 'vName' is
+                              -- important, because UnboundVarE may contain
+                              -- constructor names - see #14627.
+                              { s' <- vcName s
+                              ; return $ HsVar noExt (noLoc s') }
+    cvt (LabelE s)       = do { return $ HsOverLabel noExt Nothing (fsLit s) }
+    cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExt n' }
+
+{- Note [Dropping constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
+we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@
+could meet @UInfix@ constructors containing the @TupE [e]@. For example:
+
+  UInfixE x * (TupE [UInfixE y + z])
+
+If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet
+and the above expression would be reassociated to
+
+  OpApp (OpApp x * y) + z
+
+which we don't want.
+-}
+
+cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)
+       -> CvtM (LHsRecField' t (LHsExpr GhcPs))
+cvtFld f (v,e)
+  = do  { v' <- vNameL v; e' <- cvtl e
+        ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'
+                                     , hsRecFieldArg = e'
+                                     , hsRecPun      = False}) }
+
+cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)
+cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
+cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
+cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
+cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
+
+{- Note [Operator assocation]
+We must be quite careful about adding parens:
+  * Infix (UInfix ...) op arg      Needs parens round the first arg
+  * Infix (Infix ...) op arg       Needs parens round the first arg
+  * UInfix (UInfix ...) op arg     No parens for first arg
+  * UInfix (Infix ...) op arg      Needs parens round first arg
+
+
+Note [Converting UInfix]
+~~~~~~~~~~~~~~~~~~~~~~~~
+When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust
+the trees to reflect the fixities of the underlying operators:
+
+  UInfixE x * (UInfixE y + z) ---> (x * y) + z
+
+This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
+@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely
+right-biased for types and left-biased for everything else. So we left-bias the
+trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.
+
+Sample input:
+
+  UInfixE
+   (UInfixE x op1 y)
+   op2
+   (UInfixE z op3 w)
+
+Sample output:
+
+  OpApp
+    (OpApp
+      (OpApp x op1 y)
+      op2
+      z)
+    op3
+    w
+
+The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this
+biasing.
+-}
+
+{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
+The produced tree of infix expressions will be left-biased, provided @x@ is.
+
+We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis
+is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that
+this holds for both branches (of @cvtOpApp@), provided we assume it holds for
+the recursive calls to @cvtOpApp@.
+
+When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
+since we have already run @cvtl@ on it.
+-}
+cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs)
+cvtOpApp x op1 (UInfixE y op2 z)
+  = do { l <- wrapL $ cvtOpApp x op1 y
+       ; cvtOpApp l op2 z }
+cvtOpApp x op y
+  = do { op' <- cvtl op
+       ; y' <- cvtl y
+       ; return (OpApp noExt x op' y') }
+
+-------------------------------------
+--      Do notation and statements
+-------------------------------------
+
+cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs)
+cvtHsDo do_or_lc stmts
+  | null stmts = failWith (text "Empty stmt list in do-block")
+  | otherwise
+  = do  { stmts' <- cvtStmts stmts
+        ; let Just (stmts'', last') = snocView stmts'
+
+        ; last'' <- case last' of
+                    (dL->L loc (BodyStmt _ body _ _))
+                      -> return (cL loc (mkLastStmt body))
+                    _ -> failWith (bad_last last')
+
+        ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) }
+  where
+    bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon
+                         , nest 2 $ Outputable.ppr stmt
+                         , text "(It should be an expression.)" ]
+
+cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)]
+cvtStmts = mapM cvtStmt
+
+cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))
+cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
+cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
+cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (text "a let binding") ds
+                            ; returnL $ LetStmt noExt (noLoc ds') }
+cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss
+                            ; returnL $ ParStmt noExt dss' noExpr noSyntaxExpr }
+  where
+    cvt_one ds = do { ds' <- cvtStmts ds
+                    ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) }
+cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') }
+
+cvtMatch :: HsMatchContext RdrName
+         -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))
+cvtMatch ctxt (TH.Match p body decs)
+  = do  { p' <- cvtPat p
+        ; let lp = case p' of
+                     (dL->L loc SigPat{}) -> cL loc (ParPat NoExt p') -- #14875
+                     _                    -> p'
+        ; g' <- cvtGuard body
+        ; decs' <- cvtLocalDecs (text "a where clause") decs
+        ; returnL $ Hs.Match noExt ctxt [lp] (GRHSs noExt g' (noLoc decs')) }
+
+cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]
+cvtGuard (GuardedB pairs) = mapM cvtpair pairs
+cvtGuard (NormalB e)      = do { e' <- cvtl e
+                               ; g' <- returnL $ GRHS noExt [] e'; return [g'] }
+
+cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))
+cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
+                              ; g' <- returnL $ mkBodyStmt ge'
+                              ; returnL $ GRHS noExt [g'] rhs' }
+cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
+                              ; returnL $ GRHS noExt gs' rhs' }
+
+cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)
+cvtOverLit (IntegerL i)
+  = do { force i; return $ mkHsIntegral   (mkIntegralLit i) }
+cvtOverLit (RationalL r)
+  = do { force r; return $ mkHsFractional (mkFractionalLit r) }
+cvtOverLit (StringL s)
+  = do { let { s' = mkFastString s }
+       ; force s'
+       ; return $ mkHsIsString (quotedSourceText s) s'
+       }
+cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
+-- An Integer is like an (overloaded) '3' in a Haskell source program
+-- Similarly 3.5 for fractionals
+
+{- Note [Converting strings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
+a string literal for "xy".  Of course, we might hope to get
+(LitE (StringL "xy")), but not always, and allCharLs fails quickly
+if it isn't a literal string
+-}
+
+allCharLs :: [TH.Exp] -> Maybe String
+-- Note [Converting strings]
+-- NB: only fire up this setup for a non-empty list, else
+--     there's a danger of returning "" for [] :: [Int]!
+allCharLs xs
+  = case xs of
+      LitE (CharL c) : ys -> go [c] ys
+      _                   -> Nothing
+  where
+    go cs []                    = Just (reverse cs)
+    go cs (LitE (CharL c) : ys) = go (c:cs) ys
+    go _  _                     = Nothing
+
+cvtLit :: Lit -> CvtM (HsLit GhcPs)
+cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim NoSourceText i }
+cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim NoSourceText w }
+cvtLit (FloatPrimL f)
+  = do { force f; return $ HsFloatPrim noExt (mkFractionalLit f) }
+cvtLit (DoublePrimL f)
+  = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) }
+cvtLit (CharL c)       = do { force c; return $ HsChar NoSourceText c }
+cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim NoSourceText c }
+cvtLit (StringL s)     = do { let { s' = mkFastString s }
+                            ; force s'
+                            ; return $ HsString (quotedSourceText s) s' }
+cvtLit (StringPrimL s) = do { let { s' = BS.pack s }
+                            ; force s'
+                            ; return $ HsStringPrim NoSourceText s' }
+cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
+        -- cvtLit should not be called on IntegerL, RationalL
+        -- That precondition is established right here in
+        -- Convert.hs, hence panic
+
+quotedSourceText :: String -> SourceText
+quotedSourceText s = SourceText $ "\"" ++ s ++ "\""
+
+cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]
+cvtPats pats = mapM cvtPat pats
+
+cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)
+cvtPat pat = wrapL (cvtp pat)
+
+cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)
+cvtp (TH.LitP l)
+  | overloadedLit l    = do { l' <- cvtOverLit l
+                            ; return (mkNPat (noLoc l') Nothing) }
+                                  -- Not right for negative patterns;
+                                  -- need to think about that!
+  | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat noExt l' }
+cvtp (TH.VarP s)       = do { s' <- vName s
+                            ; return $ Hs.VarPat noExt (noLoc s') }
+cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat noExt p' }
+                                         -- Note [Dropping constructors]
+cvtp (TupP ps)         = do { ps' <- cvtPats ps
+                            ; return $ TuplePat noExt ps' Boxed }
+cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps
+                            ; return $ TuplePat noExt ps' Unboxed }
+cvtp (UnboxedSumP p alt arity)
+                       = do { p' <- cvtPat p
+                            ; unboxedSumChecks alt arity
+                            ; return $ SumPat noExt p' alt arity }
+cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps
+                            ; let pps = map (parenthesizePat appPrec) ps'
+                            ; return $ ConPatIn s' (PrefixCon pps) }
+cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
+                            ; wrapParL (ParPat noExt) $
+                              ConPatIn s' $
+                              InfixCon (parenthesizePat opPrec p1')
+                                       (parenthesizePat opPrec p2') }
+                            -- See Note [Operator association]
+cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
+cvtp (ParensP p)       = do { p' <- cvtPat p;
+                            ; case unLoc p' of  -- may be wrapped ConPatIn
+                                ParPat {} -> return $ unLoc p'
+                                _         -> return $ ParPat noExt p' }
+cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noExt p' }
+cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noExt p' }
+cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p
+                            ; return $ AsPat noExt s' p' }
+cvtp TH.WildP          = return $ WildPat noExt
+cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
+                            ; return $ ConPatIn c'
+                                     $ Hs.RecCon (HsRecFields fs' Nothing) }
+cvtp (ListP ps)        = do { ps' <- cvtPats ps
+                            ; return
+                                   $ ListPat noExt ps'}
+cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
+                            ; return $ SigPat noExt p' (mkLHsSigWcType t') }
+cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
+                            ; return $ ViewPat noExt e' p'}
+
+cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))
+cvtPatFld (s,p)
+  = do  { (dL->L ls s') <- vNameL s
+        ; p' <- cvtPat p
+        ; return (noLoc $ HsRecField { hsRecFieldLbl
+                                         = cL ls $ mkFieldOcc (cL ls s')
+                                     , hsRecFieldArg = p'
+                                     , hsRecPun      = False}) }
+
+{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
+The produced tree of infix patterns will be left-biased, provided @x@ is.
+
+See the @cvtOpApp@ documentation for how this function works.
+-}
+cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs)
+cvtOpAppP x op1 (UInfixP y op2 z)
+  = do { l <- wrapL $ cvtOpAppP x op1 y
+       ; cvtOpAppP l op2 z }
+cvtOpAppP x op y
+  = do { op' <- cNameL op
+       ; y' <- cvtPat y
+       ; return (ConPatIn op' (InfixCon x y')) }
+
+-----------------------------------------------------------
+--      Types and type variables
+
+cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs)
+cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
+
+cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)
+cvt_tv (TH.PlainTV nm)
+  = do { nm' <- tNameL nm
+       ; returnL $ UserTyVar noExt nm' }
+cvt_tv (TH.KindedTV nm ki)
+  = do { nm' <- tNameL nm
+       ; ki' <- cvtKind ki
+       ; returnL $ KindedTyVar noExt nm' ki' }
+
+cvtRole :: TH.Role -> Maybe Coercion.Role
+cvtRole TH.NominalR          = Just Coercion.Nominal
+cvtRole TH.RepresentationalR = Just Coercion.Representational
+cvtRole TH.PhantomR          = Just Coercion.Phantom
+cvtRole TH.InferR            = Nothing
+
+cvtContext :: TH.Cxt -> CvtM (LHsContext GhcPs)
+cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
+
+cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)
+cvtPred = cvtType
+
+cvtDerivClause :: TH.DerivClause
+               -> CvtM (LHsDerivingClause GhcPs)
+cvtDerivClause (TH.DerivClause ds ctxt)
+  = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext ctxt
+       ; ds'   <- traverse cvtDerivStrategy ds
+       ; returnL $ HsDerivingClause noExt ds' ctxt' }
+
+cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
+cvtDerivStrategy TH.StockStrategy    = returnL Hs.StockStrategy
+cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy
+cvtDerivStrategy TH.NewtypeStrategy  = returnL Hs.NewtypeStrategy
+cvtDerivStrategy (TH.ViaStrategy ty) = do
+  ty' <- cvtType ty
+  returnL $ Hs.ViaStrategy (mkLHsSigType ty')
+
+cvtType :: TH.Type -> CvtM (LHsType GhcPs)
+cvtType = cvtTypeKind "type"
+
+cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs)
+cvtTypeKind ty_str ty
+  = do { (head_ty, tys') <- split_ty_app ty
+       ; let m_normals = mapM extract_normal tys'
+                                where extract_normal (HsValArg ty) = Just ty
+                                      extract_normal _ = Nothing
+
+       ; case head_ty of
+           TupleT n
+            | Just normals <- m_normals
+            , normals `lengthIs` n         -- Saturated
+               -> if n==1 then return (head normals) -- Singleton tuples treated
+                                                     -- like nothing (ie just parens)
+                          else returnL (HsTupleTy noExt
+                                        HsBoxedOrConstraintTuple normals)
+            | n == 1
+               -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
+            | otherwise
+            -> mk_apps
+               (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))
+               tys'
+           UnboxedTupleT n
+             | Just normals <- m_normals
+             , normals `lengthIs` n               -- Saturated
+             -> returnL (HsTupleTy noExt HsUnboxedTuple normals)
+             | otherwise
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n))))
+                tys'
+           UnboxedSumT n
+             | n < 2
+            -> failWith $
+                   vcat [ text "Illegal sum arity:" <+> text (show n)
+                        , nest 2 $
+                            text "Sums must have an arity of at least 2" ]
+             | Just normals <- m_normals
+             , normals `lengthIs` n -- Saturated
+             -> returnL (HsSumTy noExt normals)
+             | otherwise
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName (sumTyCon n))))
+                tys'
+           ArrowT
+             | Just normals <- m_normals
+             , [x',y'] <- normals -> do
+                 x'' <- case unLoc x' of
+                          HsFunTy{}    -> returnL (HsParTy noExt x')
+                          HsForAllTy{} -> returnL (HsParTy noExt x') -- #14646
+                          HsQualTy{}   -> returnL (HsParTy noExt x') -- #15324
+                          _            -> return $
+                                          parenthesizeHsType sigPrec x'
+                 let y'' = parenthesizeHsType sigPrec y'
+                 returnL (HsFunTy noExt x'' y'')
+             | otherwise
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName funTyCon)))
+                tys'
+           ListT
+             | Just normals <- m_normals
+             , [x'] <- normals -> do
+                returnL (HsListTy noExt x')
+             | otherwise
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName listTyCon)))
+                tys'
+
+           VarT nm -> do { nm' <- tNameL nm
+                         ; mk_apps (HsTyVar noExt NotPromoted nm') tys' }
+           ConT nm -> do { nm' <- tconName nm
+                         ; -- ConT can contain both data constructor (i.e.,
+                           -- promoted) names and other (i.e, unpromoted)
+                           -- names, as opposed to PromotedT, which can only
+                           -- contain data constructor names. See #15572.
+                           let prom = if isRdrDataCon nm'
+                                      then IsPromoted
+                                      else NotPromoted
+                         ; mk_apps (HsTyVar noExt prom (noLoc nm')) tys'}
+
+           ForallT tvs cxt ty
+             | null tys'
+             -> do { tvs' <- cvtTvs tvs
+                   ; cxt' <- cvtContext cxt
+                   ; let pcxt = parenthesizeHsContext funPrec cxt'
+                   ; ty'  <- cvtType ty
+                   ; loc <- getL
+                   ; let hs_ty  = mkHsForAllTy tvs loc tvs' rho_ty
+                         rho_ty = mkHsQualTy cxt loc pcxt ty'
+
+                   ; return hs_ty }
+
+           SigT ty ki
+             -> do { ty' <- cvtType ty
+                   ; ki' <- cvtKind ki
+                   ; mk_apps (HsKindSig noExt ty' ki') tys'
+                   }
+
+           LitT lit
+             -> mk_apps (HsTyLit noExt (cvtTyLit lit)) tys'
+
+           WildCardT
+             -> mk_apps mkAnonWildCardTy tys'
+
+           InfixT t1 s t2
+             -> do { s'  <- tconName s
+                   ; t1' <- cvtType t1
+                   ; t2' <- cvtType t2
+                   ; mk_apps
+                      (HsTyVar noExt NotPromoted (noLoc s'))
+                      ([HsValArg t1', HsValArg t2'] ++ tys')
+                   }
+
+           UInfixT t1 s t2
+             -> do { t2' <- cvtType t2
+                   ; t <- cvtOpAppT t1 s t2'
+                   ; mk_apps (unLoc t) tys'
+                   } -- Note [Converting UInfix]
+
+           ParensT t
+             -> do { t' <- cvtType t
+                   ; mk_apps (HsParTy noExt t') tys'
+                   }
+
+           PromotedT nm -> do { nm' <- cName nm
+                              ; mk_apps (HsTyVar noExt IsPromoted (noLoc nm'))
+                                        tys' }
+                 -- Promoted data constructor; hence cName
+
+           PromotedTupleT n
+              | n == 1
+              -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
+              | Just normals <- m_normals
+              , normals `lengthIs` n   -- Saturated
+              -> returnL (HsExplicitTupleTy noExt normals)
+              | otherwise
+              -> mk_apps
+                 (HsTyVar noExt IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n))))
+                 tys'
+
+           PromotedNilT
+             -> mk_apps (HsExplicitListTy noExt IsPromoted []) tys'
+
+           PromotedConsT  -- See Note [Representing concrete syntax in types]
+                          -- in Language.Haskell.TH.Syntax
+              | Just normals <- m_normals
+              , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals
+              -> do
+                  returnL (HsExplicitListTy noExt ip (ty1:tys2))
+              | otherwise
+              -> mk_apps
+                 (HsTyVar noExt IsPromoted (noLoc (getRdrName consDataCon)))
+                 tys'
+
+           StarT
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName liftedTypeKindTyCon)))
+                tys'
+
+           ConstraintT
+             -> mk_apps
+                (HsTyVar noExt NotPromoted (noLoc (getRdrName constraintKindTyCon)))
+                tys'
+
+           EqualityT
+             | Just normals <- m_normals
+             , [x',y'] <- normals ->
+                   let px = parenthesizeHsType opPrec x'
+                       py = parenthesizeHsType opPrec y'
+                   in returnL (HsOpTy noExt px (noLoc eqTyCon_RDR) py)
+               -- The long-term goal is to remove the above case entirely and
+               -- subsume it under the case for InfixT. See #15815, comment:6,
+               -- for more details.
+
+             | otherwise ->
+                   mk_apps (HsTyVar noExt NotPromoted
+                            (noLoc eqTyCon_RDR)) tys'
+           ImplicitParamT n t
+             -> do { n' <- wrapL $ ipName n
+                   ; t' <- cvtType t
+                   ; returnL (HsIParamTy noExt n' t')
+                   }
+
+           _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
+    }
+
+-- | Constructs an application of a type to arguments passed in a list.
+mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
+mk_apps head_ty type_args = do
+  head_ty' <- returnL head_ty
+  -- We must parenthesize the function type in case of an explicit
+  -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there
+  -- _must_ be parentheses around `Maybe :: Type -> Type`.
+  let phead_ty :: LHsType GhcPs
+      phead_ty = parenthesizeHsType sigPrec head_ty'
+
+      go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)
+      go [] = pure head_ty'
+      go (arg:args) =
+        case arg of
+          HsValArg ty  -> do p_ty <- add_parens ty
+                             mk_apps (HsAppTy noExt phead_ty p_ty) args
+          HsTypeArg l ki -> do p_ki <- add_parens ki
+                               mk_apps (HsAppKindTy l phead_ty p_ki) args
+          HsArgPar _   -> mk_apps (HsParTy noExt phead_ty) args
+
+  go type_args
+   where
+    -- See Note [Adding parens for splices]
+    add_parens lt@(dL->L _ t)
+      | hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt)
+      | otherwise                   = return lt
+
+wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs
+wrap_tyarg (HsValArg ty)    = HsValArg  $ parenthesizeHsType appPrec ty
+wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki
+wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized
+
+-- ---------------------------------------------------------------------
+-- Note [Adding parens for splices]
+{-
+The hsSyn representation of parsed source explicitly contains all the original
+parens, as written in the source.
+
+When a Template Haskell (TH) splice is evaluated, the original splice is first
+renamed and type checked and then finally converted to core in DsMeta. This core
+is then run in the TH engine, and the result comes back as a TH AST.
+
+In the process, all parens are stripped out, as they are not needed.
+
+This Convert module then converts the TH AST back to hsSyn AST.
+
+In order to pretty-print this hsSyn AST, parens need to be adde back at certain
+points so that the code is readable with its original meaning.
+
+So scattered through Convert.hs are various points where parens are added.
+
+See (among other closed issued) https://ghc.haskell.org/trac/ghc/ticket/14289
+-}
+-- ---------------------------------------------------------------------
+
+-- | Constructs an arrow type with a specified return type
+mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)
+mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
+    where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)
+          go arg ret_ty = do { ret_ty_l <- returnL ret_ty
+                             ; return (HsFunTy noExt arg ret_ty_l) }
+
+split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])
+split_ty_app ty = go ty []
+  where
+    go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') }
+    go (AppKindT ty ki) as' = do { ki' <- cvtKind ki
+                                 ; go ty (HsTypeArg noSrcSpan ki':as') }
+    go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') }
+    go f as           = return (f,as)
+
+cvtTyLit :: TH.TyLit -> HsTyLit
+cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i
+cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
+
+{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator
+application @x `op` y@. The produced tree of infix types will be right-biased,
+provided @y@ is.
+
+See the @cvtOpApp@ documentation for how this function works.
+-}
+cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)
+cvtOpAppT (UInfixT x op2 y) op1 z
+  = do { l <- cvtOpAppT y op1 z
+       ; cvtOpAppT x op2 l }
+cvtOpAppT x op y
+  = do { op' <- tconNameL op
+       ; x' <- cvtType x
+       ; returnL (mkHsOpTy x' op' y) }
+
+cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)
+cvtKind = cvtTypeKind "kind"
+
+-- | Convert Maybe Kind to a type family result signature. Used with data
+-- families where naming of the result is not possible (thus only kind or no
+-- signature is possible).
+cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
+                              -> CvtM (LFamilyResultSig GhcPs)
+cvtMaybeKindToFamilyResultSig Nothing   = returnL (Hs.NoSig noExt)
+cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki
+                                             ; returnL (Hs.KindSig noExt ki') }
+
+-- | Convert type family result signature. Used with both open and closed type
+-- families.
+cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)
+cvtFamilyResultSig TH.NoSig           = returnL (Hs.NoSig noExt)
+cvtFamilyResultSig (TH.KindSig ki)    = do { ki' <- cvtKind ki
+                                           ; returnL (Hs.KindSig noExt  ki') }
+cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr
+                                           ; returnL (Hs.TyVarSig noExt tv) }
+
+-- | Convert injectivity annotation of a type family.
+cvtInjectivityAnnotation :: TH.InjectivityAnn
+                         -> CvtM (Hs.LInjectivityAnn GhcPs)
+cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
+  = do { annLHS' <- tNameL annLHS
+       ; annRHS' <- mapM tNameL annRHS
+       ; returnL (Hs.InjectivityAnn annLHS' annRHS') }
+
+cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs)
+-- pattern synonym types are of peculiar shapes, which is why we treat
+-- them separately from regular types;
+-- see Note [Pattern synonym type signatures and Template Haskell]
+cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
+  | null exis, null provs = cvtType (ForallT univs reqs ty)
+  | null univs, null reqs = do { l   <- getL
+                               ; ty' <- cvtType (ForallT exis provs ty)
+                               ; return $ cL l (HsQualTy { hst_ctxt = cL l []
+                                                         , hst_xqual = noExt
+                                                         , hst_body = ty' }) }
+  | null reqs             = do { l      <- getL
+                               ; univs' <- hsQTvExplicit <$> cvtTvs univs
+                               ; ty'    <- cvtType (ForallT exis provs ty)
+                               ; let forTy = HsForAllTy
+                                              { hst_bndrs = univs'
+                                              , hst_xforall = noExt
+                                              , hst_body = cL l cxtTy }
+                                     cxtTy = HsQualTy { hst_ctxt = cL l []
+                                                      , hst_xqual = noExt
+                                                      , hst_body = ty' }
+                               ; return $ cL l forTy }
+  | otherwise             = cvtType (ForallT univs reqs (ForallT exis provs ty))
+cvtPatSynSigTy ty         = cvtType ty
+
+-----------------------------------------------------------
+cvtFixity :: TH.Fixity -> Hs.Fixity
+cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)
+   where
+     cvt_dir TH.InfixL = Hs.InfixL
+     cvt_dir TH.InfixR = Hs.InfixR
+     cvt_dir TH.InfixN = Hs.InfixN
+
+-----------------------------------------------------------
+
+
+-----------------------------------------------------------
+-- some useful things
+
+overloadedLit :: Lit -> Bool
+-- True for literals that Haskell treats as overloaded
+overloadedLit (IntegerL  _) = True
+overloadedLit (RationalL _) = True
+overloadedLit _             = False
+
+-- Checks that are performed when converting unboxed sum expressions and
+-- patterns alike.
+unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()
+unboxedSumChecks alt arity
+    | alt > arity
+    = failWith $ text "Sum alternative"    <+> text (show alt)
+             <+> text "exceeds its arity," <+> text (show arity)
+    | alt <= 0
+    = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt)
+                      , nest 2 $ text "Sum alternatives must start from 1" ]
+    | arity < 2
+    = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity)
+                      , nest 2 $ text "Sums must have an arity of at least 2" ]
+    | otherwise
+    = return ()
+
+-- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the
+-- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'
+-- using the provided 'LHsQTyVars' and 'LHsType'.
+mkHsForAllTy :: [TH.TyVarBndr]
+             -- ^ The original Template Haskell type variable binders
+             -> SrcSpan
+             -- ^ The location of the returned 'LHsType' if it needs an
+             --   explicit forall
+             -> LHsQTyVars GhcPs
+             -- ^ The converted type variable binders
+             -> LHsType GhcPs
+             -- ^ The converted rho type
+             -> LHsType GhcPs
+             -- ^ The complete type, quantified with a forall if necessary
+mkHsForAllTy tvs loc tvs' rho_ty
+  | null tvs  = rho_ty
+  | otherwise = cL loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
+                                    , hst_xforall = noExt
+                                    , hst_body = rho_ty }
+
+-- | If passed an empty 'TH.Cxt', this simply returns the third argument
+-- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided
+-- 'LHsContext' and 'LHsType'.
+
+-- It's important that we don't build an HsQualTy if the context is empty,
+-- as the pretty-printer for HsType _always_ prints contexts, even if
+-- they're empty. See Trac #13183.
+mkHsQualTy :: TH.Cxt
+           -- ^ The original Template Haskell context
+           -> SrcSpan
+           -- ^ The location of the returned 'LHsType' if it needs an
+           --   explicit context
+           -> LHsContext GhcPs
+           -- ^ The converted context
+           -> LHsType GhcPs
+           -- ^ The converted tau type
+           -> LHsType GhcPs
+           -- ^ The complete type, qualified with a context if necessary
+mkHsQualTy ctxt loc ctxt' ty
+  | null ctxt = ty
+  | otherwise = cL loc $ HsQualTy { hst_xqual = noExt
+                                  , hst_ctxt  = ctxt'
+                                  , hst_body  = ty }
+
+--------------------------------------------------------------------
+--      Turning Name back into RdrName
+--------------------------------------------------------------------
+
+-- variable names
+vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
+vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName
+
+-- Variable names
+vNameL n = wrapL (vName n)
+vName n = cvtName OccName.varName n
+
+-- Constructor function names; this is Haskell source, hence srcDataName
+cNameL n = wrapL (cName n)
+cName n = cvtName OccName.dataName n
+
+-- Variable *or* constructor names; check by looking at the first char
+vcNameL n = wrapL (vcName n)
+vcName n = if isVarName n then vName n else cName n
+
+-- Type variable names
+tNameL n = wrapL (tName n)
+tName n = cvtName OccName.tvName n
+
+-- Type Constructor names
+tconNameL n = wrapL (tconName n)
+tconName n = cvtName OccName.tcClsName n
+
+ipName :: String -> CvtM HsIPName
+ipName n
+  = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n))
+       ; return (HsIPName (fsLit n)) }
+
+cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
+cvtName ctxt_ns (TH.Name occ flavour)
+  | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
+  | otherwise
+  = do { loc <- getL
+       ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour
+       ; force rdr_name
+       ; return rdr_name }
+  where
+    occ_str = TH.occString occ
+
+okOcc :: OccName.NameSpace -> String -> Bool
+okOcc ns str
+  | OccName.isVarNameSpace ns     = okVarOcc str
+  | OccName.isDataConNameSpace ns = okConOcc str
+  | otherwise                     = okTcOcc  str
+
+-- Determine the name space of a name in a type
+--
+isVarName :: TH.Name -> Bool
+isVarName (TH.Name occ _)
+  = case TH.occString occ of
+      ""    -> False
+      (c:_) -> startsVarId c || startsVarSym c
+
+badOcc :: OccName.NameSpace -> String -> SDoc
+badOcc ctxt_ns occ
+  = text "Illegal" <+> pprNameSpace ctxt_ns
+        <+> text "name:" <+> quotes (text occ)
+
+thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
+-- This turns a TH Name into a RdrName; used for both binders and occurrences
+-- See Note [Binders in Template Haskell]
+-- The passed-in name space tells what the context is expecting;
+--      use it unless the TH name knows what name-space it comes
+--      from, in which case use the latter
+--
+-- We pass in a SrcSpan (gotten from the monad) because this function
+-- is used for *binders* and if we make an Exact Name we want it
+-- to have a binding site inside it.  (cf Trac #5434)
+--
+-- ToDo: we may generate silly RdrNames, by passing a name space
+--       that doesn't match the string, like VarName ":+",
+--       which will give confusing error messages later
+--
+-- The strict applications ensure that any buried exceptions get forced
+thRdrName loc ctxt_ns th_occ th_name
+  = case th_name of
+     TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod
+     TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ
+     TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)
+     TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)
+     TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name
+              | otherwise                           -> mkRdrUnqual $! occ
+              -- We check for built-in syntax here, because the TH
+              -- user might have written a (NameS "(,,)"), for example
+  where
+    occ :: OccName.OccName
+    occ = mk_occ ctxt_ns th_occ
+
+-- Return an unqualified exact RdrName if we're dealing with built-in syntax.
+-- See Trac #13776.
+thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
+thOrigRdrName occ th_ns pkg mod =
+  let occ' = mk_occ (mk_ghc_ns th_ns) occ
+  in case isBuiltInOcc_maybe occ' of
+       Just name -> nameRdrName name
+       Nothing   -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ'
+
+thRdrNameGuesses :: TH.Name -> [RdrName]
+thRdrNameGuesses (TH.Name occ flavour)
+  -- This special case for NameG ensures that we don't generate duplicates in the output list
+  | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]
+  | otherwise                         = [ thRdrName noSrcSpan gns occ_str flavour
+                                        | gns <- guessed_nss]
+  where
+    -- guessed_ns are the name spaces guessed from looking at the TH name
+    guessed_nss
+      | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]
+      | otherwise                       = [OccName.varName, OccName.tvName]
+    occ_str = TH.occString occ
+
+-- The packing and unpacking is rather turgid :-(
+mk_occ :: OccName.NameSpace -> String -> OccName.OccName
+mk_occ ns occ = OccName.mkOccName ns occ
+
+mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
+mk_ghc_ns TH.DataName  = OccName.dataName
+mk_ghc_ns TH.TcClsName = OccName.tcClsName
+mk_ghc_ns TH.VarName   = OccName.varName
+
+mk_mod :: TH.ModName -> ModuleName
+mk_mod mod = mkModuleName (TH.modString mod)
+
+mk_pkg :: TH.PkgName -> UnitId
+mk_pkg pkg = stringToUnitId (TH.pkgString pkg)
+
+mk_uniq :: Int -> Unique
+mk_uniq u = mkUniqueGrimily u
+
+{-
+Note [Binders in Template Haskell]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this TH term construction:
+  do { x1 <- TH.newName "x"   -- newName :: String -> Q TH.Name
+     ; x2 <- TH.newName "x"   -- Builds a NameU
+     ; x3 <- TH.newName "x"
+
+     ; let x = mkName "x"     -- mkName :: String -> TH.Name
+                              -- Builds a NameS
+
+     ; return (LamE (..pattern [x1,x2]..) $
+               LamE (VarPat x3) $
+               ..tuple (x1,x2,x3,x)) }
+
+It represents the term   \[x1,x2]. \x3. (x1,x2,x3,x)
+
+a) We don't want to complain about "x" being bound twice in
+   the pattern [x1,x2]
+b) We don't want x3 to shadow the x1,x2
+c) We *do* want 'x' (dynamically bound with mkName) to bind
+   to the innermost binding of "x", namely x3.
+d) When pretty printing, we want to print a unique with x1,x2
+   etc, else they'll all print as "x" which isn't very helpful
+
+When we convert all this to HsSyn, the TH.Names are converted with
+thRdrName.  To achieve (b) we want the binders to be Exact RdrNames.
+Achieving (a) is a bit awkward, because
+   - We must check for duplicate and shadowed names on Names,
+     not RdrNames, *after* renaming.
+     See Note [Collect binders only after renaming] in HsUtils
+
+   - But to achieve (a) we must distinguish between the Exact
+     RdrNames arising from TH and the Unqual RdrNames that would
+     come from a user writing \[x,x] -> blah
+
+So in Convert.thRdrName we translate
+   TH Name                          RdrName
+   --------------------------------------------------------
+   NameU (arising from newName) --> Exact (Name{ System })
+   NameS (arising from mkName)  --> Unqual
+
+Notice that the NameUs generate *System* Names.  Then, when
+figuring out shadowing and duplicates, we can filter out
+System Names.
+
+This use of System Names fits with other uses of System Names, eg for
+temporary variables "a". Since there are lots of things called "a" we
+usually want to print the name with the unique, and that is indeed
+the way System Names are printed.
+
+There's a small complication of course; see Note [Looking up Exact
+RdrNames] in RnEnv.
+-}
+
+{-
+Note [Pattern synonym type signatures and Template Haskell]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In general, the type signature of a pattern synonym
+
+  pattern P x1 x2 .. xn = <some-pattern>
+
+is of the form
+
+   forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
+
+with the following parts:
+
+   1) the (possibly empty lists of) universally quantified type
+      variables `univs` and required constraints `reqs` on them.
+   2) the (possibly empty lists of) existentially quantified type
+      variables `exis` and the provided constraints `provs` on them.
+   3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,
+      x2, .., xn, respectively
+   4) the type `t` of <some-pattern>, mentioning only universals from `univs`.
+
+Due to the two forall quantifiers and constraint contexts (either of
+which might be empty), pattern synonym type signatures are treated
+specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and
+`typecheck/TcSplice.hs`:
+
+   (a) When desugaring a pattern synonym from HsSyn to TH.Dec in
+       `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.:
+
+           ForallT univs reqs (ForallT exis provs ty)
+              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
+
+   (b) When converting pattern synonyms from TH.Dec to HsSyn in
+       `hsSyn/Convert.hs`, we convert their TH type signatures back to an
+       appropriate Haskell pattern synonym type of the form
+
+         forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
+
+       where initial empty `univs` type variables or an empty `reqs`
+       constraint context are represented *explicitly* as `() =>`.
+
+   (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always
+       return its *full* type, i.e.:
+
+           ForallT univs reqs (ForallT exis provs ty)
+              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
+
+The key point is to always represent a pattern synonym's *full* type
+in cases (a) and (c) to make it clear which of the two forall
+quantifiers and/or constraint contexts are specified, and which are
+not. See GHC's user's guide on pattern synonyms for more information
+about pattern synonym type signatures.
+
+-}
diff --git a/compiler/hsSyn/HsDumpAst.hs b/compiler/hsSyn/HsDumpAst.hs
new file mode 100644
--- /dev/null
+++ b/compiler/hsSyn/HsDumpAst.hs
@@ -0,0 +1,220 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Contains a debug function to dump parts of the hsSyn AST. It uses a syb
+-- traversal which falls back to displaying based on the constructor name, so
+-- can be used to dump anything having a @Data.Data@ instance.
+
+module HsDumpAst (
+        -- * Dumping ASTs
+        showAstData,
+        BlankSrcSpan(..),
+    ) where
+
+import GhcPrelude
+
+import Data.Data hiding (Fixity)
+import Bag
+import BasicTypes
+import FastString
+import NameSet
+import Name
+import DataCon
+import SrcLoc
+import HsSyn
+import OccName hiding (occName)
+import Var
+import Module
+import Outputable
+
+import qualified Data.ByteString as B
+
+data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan
+                  deriving (Eq,Show)
+
+-- | Show a GHC syntax tree. This parameterised because it is also used for
+-- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked
+-- out, to avoid comparing locations, only structure
+showAstData :: Data a => BlankSrcSpan -> a -> SDoc
+showAstData b a0 = blankLine $$ showAstData' a0
+  where
+    showAstData' :: Data a => a -> SDoc
+    showAstData' =
+      generic
+              `ext1Q` list
+              `extQ` string `extQ` fastString `extQ` srcSpan
+              `extQ` lit `extQ` litr `extQ` litt
+              `extQ` bytestring
+              `extQ` name `extQ` occName `extQ` moduleName `extQ` var
+              `extQ` dataCon
+              `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
+              `extQ` fixity
+              `ext2Q` located
+
+      where generic :: Data a => a -> SDoc
+            generic t = parens $ text (showConstr (toConstr t))
+                                  $$ vcat (gmapQ showAstData' t)
+
+            string :: String -> SDoc
+            string     = text . normalize_newlines . show
+
+            fastString :: FastString -> SDoc
+            fastString s = braces $
+                            text "FastString: "
+                         <> text (normalize_newlines . show $ s)
+
+            bytestring :: B.ByteString -> SDoc
+            bytestring = text . normalize_newlines . show
+
+            list []    = brackets empty
+            list [x]   = brackets (showAstData' x)
+            list (x1 : x2 : xs) =  (text "[" <> showAstData' x1)
+                                $$ go x2 xs
+              where
+                go y [] = text "," <> showAstData' y <> text "]"
+                go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys
+
+            -- Eliminate word-size dependence
+            lit :: HsLit GhcPs -> SDoc
+            lit (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s
+            lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
+            lit (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s
+            lit (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s
+            lit l                  = generic l
+
+            litr :: HsLit GhcRn -> SDoc
+            litr (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s
+            litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
+            litr (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s
+            litr (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s
+            litr l                  = generic l
+
+            litt :: HsLit GhcTc -> SDoc
+            litt (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s
+            litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
+            litt (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s
+            litt (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s
+            litt l                  = generic l
+
+            numericLit :: String -> Integer -> SourceText -> SDoc
+            numericLit tag x s = braces $ hsep [ text tag
+                                               , generic x
+                                               , generic s ]
+
+            name :: Name -> SDoc
+            name nm    = braces $ text "Name: " <> ppr nm
+
+            occName n  =  braces $
+                          text "OccName: "
+                       <> text (OccName.occNameString n)
+
+            moduleName :: ModuleName -> SDoc
+            moduleName m = braces $ text "ModuleName: " <> ppr m
+
+            srcSpan :: SrcSpan -> SDoc
+            srcSpan ss = case b of
+             BlankSrcSpan -> text "{ ss }"
+             NoBlankSrcSpan -> braces $ char ' ' <>
+                             (hang (ppr ss) 1
+                                   -- TODO: show annotations here
+                                   (text ""))
+
+            var  :: Var -> SDoc
+            var v      = braces $ text "Var: " <> ppr v
+
+            dataCon :: DataCon -> SDoc
+            dataCon c  = braces $ text "DataCon: " <> ppr c
+
+            bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc
+            bagRdrName bg =  braces $
+                             text "Bag(Located (HsBind GhcPs)):"
+                          $$ (list . bagToList $ bg)
+
+            bagName   :: Bag (Located (HsBind GhcRn)) -> SDoc
+            bagName bg  =  braces $
+                           text "Bag(Located (HsBind Name)):"
+                        $$ (list . bagToList $ bg)
+
+            bagVar    :: Bag (Located (HsBind GhcTc)) -> SDoc
+            bagVar bg  =  braces $
+                          text "Bag(Located (HsBind Var)):"
+                       $$ (list . bagToList $ bg)
+
+            nameSet ns =  braces $
+                          text "NameSet:"
+                       $$ (list . nameSetElemsStable $ ns)
+
+            fixity :: Fixity -> SDoc
+            fixity fx =  braces $
+                         text "Fixity: "
+                      <> ppr fx
+
+            located :: (Data b,Data loc) => GenLocated loc b -> SDoc
+            located (L ss a) = parens $
+                   case cast ss of
+                        Just (s :: SrcSpan) ->
+                          srcSpan s
+                        Nothing -> text "nnnnnnnn"
+                      $$ showAstData' a
+
+normalize_newlines :: String -> String
+normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs
+normalize_newlines (x:xs)                 = x:normalize_newlines xs
+normalize_newlines []                     = []
+
+{-
+************************************************************************
+*                                                                      *
+* Copied from syb
+*                                                                      *
+************************************************************************
+-}
+
+
+-- | The type constructor for queries
+newtype Q q x = Q { unQ :: x -> q }
+
+-- | Extend a generic query by a type-specific case
+extQ :: ( Typeable a
+        , Typeable b
+        )
+     => (a -> q)
+     -> (b -> q)
+     -> a
+     -> q
+extQ f g a = maybe (f a) g (cast a)
+
+-- | Type extension of queries for type constructors
+ext1Q :: (Data d, Typeable t)
+      => (d -> q)
+      -> (forall e. Data e => t e -> q)
+      -> d -> q
+ext1Q def ext = unQ ((Q def) `ext1` (Q ext))
+
+
+-- | Type extension of queries for type constructors
+ext2Q :: (Data d, Typeable t)
+      => (d -> q)
+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
+      -> d -> q
+ext2Q def ext = unQ ((Q def) `ext2` (Q ext))
+
+-- | Flexible type extension
+ext1 :: (Data a, Typeable t)
+     => c a
+     -> (forall d. Data d => c (t d))
+     -> c a
+ext1 def ext = maybe def id (dataCast1 ext)
+
+
+
+-- | Flexible type extension
+ext2 :: (Data a, Typeable t)
+     => c a
+     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
+     -> c a
+ext2 def ext = maybe def id (dataCast2 ext)
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
new file mode 100644
--- /dev/null
+++ b/compiler/iface/BinIface.hs
@@ -0,0 +1,424 @@
+{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}
+
+--
+--  (c) The University of Glasgow 2002-2006
+--
+
+{-# OPTIONS_GHC -O2 #-}
+-- We always optimise this, otherwise performance of a non-optimised
+-- compiler is severely affected
+
+-- | Binary interface file support.
+module BinIface (
+        writeBinIface,
+        readBinIface,
+        getSymtabName,
+        getDictFastString,
+        CheckHiWay(..),
+        TraceBinIFaceReading(..),
+        getWithUserData,
+        putWithUserData
+
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnMonad
+import PrelInfo   ( isKnownKeyName, lookupKnownKeyName )
+import IfaceEnv
+import HscTypes
+import Module
+import Name
+import DynFlags
+import UniqFM
+import UniqSupply
+import Panic
+import Binary
+import SrcLoc
+import ErrUtils
+import FastMutInt
+import Unique
+import Outputable
+import NameCache
+import Platform
+import FastString
+import Constants
+import Util
+
+import Data.Array
+import Data.Array.ST
+import Data.Array.Unsafe
+import Data.Bits
+import Data.Char
+import Data.Word
+import Data.IORef
+import Data.Foldable
+import Control.Monad
+import Control.Monad.ST
+import Control.Monad.Trans.Class
+import qualified Control.Monad.Trans.State.Strict as State
+
+-- ---------------------------------------------------------------------------
+-- Reading and writing binary interface files
+--
+
+data CheckHiWay = CheckHiWay | IgnoreHiWay
+    deriving Eq
+
+data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
+    deriving Eq
+
+-- | Read an interface file
+readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
+             -> TcRnIf a b ModIface
+readBinIface checkHiWay traceBinIFaceReading hi_path = do
+    ncu <- mkNameCacheUpdater
+    dflags <- getDynFlags
+    liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu
+
+readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
+              -> NameCacheUpdater
+              -> IO ModIface
+readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
+    let printer :: SDoc -> IO ()
+        printer = case traceBinIFaceReading of
+                      TraceBinIFaceReading -> \sd ->
+                          putLogMsg dflags
+                                    NoReason
+                                    SevOutput
+                                    noSrcSpan
+                                    (defaultDumpStyle dflags)
+                                    sd
+                      QuietBinIFaceReading -> \_ -> return ()
+        wantedGot :: Outputable a => String -> a -> a -> IO ()
+        wantedGot what wanted got =
+            printer (text what <> text ": " <>
+                     vcat [text "Wanted " <> ppr wanted <> text ",",
+                           text "got    " <> ppr got])
+
+        errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
+        errorOnMismatch what wanted got =
+            -- This will be caught by readIface which will emit an error
+            -- msg containing the iface module name.
+            when (wanted /= got) $ throwGhcExceptionIO $ ProgramError
+                         (what ++ " (wanted " ++ show wanted
+                               ++ ", got "    ++ show got ++ ")")
+    bh <- Binary.readBinMem hi_path
+
+    -- Read the magic number to check that this really is a GHC .hi file
+    -- (This magic number does not change when we change
+    --  GHC interface file format)
+    magic <- get bh
+    wantedGot "Magic" (binaryInterfaceMagic dflags) magic
+    errorOnMismatch "magic number mismatch: old/corrupt interface file?"
+        (binaryInterfaceMagic dflags) magic
+
+    -- Note [dummy iface field]
+    -- read a dummy 32/64 bit value.  This field used to hold the
+    -- dictionary pointer in old interface file formats, but now
+    -- the dictionary pointer is after the version (where it
+    -- should be).  Also, the serialisation of value of type "Bin
+    -- a" used to depend on the word size of the machine, now they
+    -- are always 32 bits.
+    if wORD_SIZE dflags == 4
+        then do _ <- Binary.get bh :: IO Word32; return ()
+        else do _ <- Binary.get bh :: IO Word64; return ()
+
+    -- Check the interface file version and ways.
+    check_ver  <- get bh
+    let our_ver = show hiVersion
+    wantedGot "Version" our_ver check_ver
+    errorOnMismatch "mismatched interface file versions" our_ver check_ver
+
+    check_way <- get bh
+    let way_descr = getWayDescr dflags
+    wantedGot "Way" way_descr check_way
+    when (checkHiWay == CheckHiWay) $
+        errorOnMismatch "mismatched interface file ways" way_descr check_way
+    getWithUserData ncu bh
+
+
+-- | This performs a get action after reading the dictionary and symbol
+-- table. It is necessary to run this before trying to deserialise any
+-- Names or FastStrings.
+getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a
+getWithUserData ncu bh = do
+    -- Read the dictionary
+    -- The next word in the file is a pointer to where the dictionary is
+    -- (probably at the end of the file)
+    dict_p <- Binary.get bh
+    data_p <- tellBin bh          -- Remember where we are now
+    seekBin bh dict_p
+    dict   <- getDictionary bh
+    seekBin bh data_p             -- Back to where we were before
+
+    -- Initialise the user-data field of bh
+    bh <- do
+        bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
+                                                     (getDictFastString dict)
+        symtab_p <- Binary.get bh     -- Get the symtab ptr
+        data_p <- tellBin bh          -- Remember where we are now
+        seekBin bh symtab_p
+        symtab <- getSymbolTable bh ncu
+        seekBin bh data_p             -- Back to where we were before
+
+        -- It is only now that we know how to get a Name
+        return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)
+                                               (getDictFastString dict)
+
+    -- Read the interface file
+    get bh
+
+-- | Write an interface file
+writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
+writeBinIface dflags hi_path mod_iface = do
+    bh <- openBinMem initBinMemSize
+    put_ bh (binaryInterfaceMagic dflags)
+
+   -- dummy 32/64-bit field before the version/way for
+   -- compatibility with older interface file formats.
+   -- See Note [dummy iface field] above.
+    if wORD_SIZE dflags == 4
+        then Binary.put_ bh (0 :: Word32)
+        else Binary.put_ bh (0 :: Word64)
+
+    -- The version and way descriptor go next
+    put_ bh (show hiVersion)
+    let way_descr = getWayDescr dflags
+    put_  bh way_descr
+
+
+    putWithUserData (debugTraceMsg dflags 3) bh mod_iface
+    -- And send the result to the file
+    writeBinMem bh hi_path
+
+-- | Put a piece of data with an initialised `UserData` field. This
+-- is necessary if you want to serialise Names or FastStrings.
+-- It also writes a symbol table and the dictionary.
+-- This segment should be read using `getWithUserData`.
+putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO ()
+putWithUserData log_action bh payload = do
+    -- Remember where the dictionary pointer will go
+    dict_p_p <- tellBin bh
+    -- Placeholder for ptr to dictionary
+    put_ bh dict_p_p
+
+    -- Remember where the symbol table pointer will go
+    symtab_p_p <- tellBin bh
+    put_ bh symtab_p_p
+    -- Make some initial state
+    symtab_next <- newFastMutInt
+    writeFastMutInt symtab_next 0
+    symtab_map <- newIORef emptyUFM
+    let bin_symtab = BinSymbolTable {
+                         bin_symtab_next = symtab_next,
+                         bin_symtab_map  = symtab_map }
+    dict_next_ref <- newFastMutInt
+    writeFastMutInt dict_next_ref 0
+    dict_map_ref <- newIORef emptyUFM
+    let bin_dict = BinDictionary {
+                       bin_dict_next = dict_next_ref,
+                       bin_dict_map  = dict_map_ref }
+
+    -- Put the main thing,
+    bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
+                                                  (putName bin_dict bin_symtab)
+                                                  (putFastString bin_dict)
+    put_ bh payload
+
+    -- Write the symtab pointer at the front of the file
+    symtab_p <- tellBin bh        -- This is where the symtab will start
+    putAt bh symtab_p_p symtab_p  -- Fill in the placeholder
+    seekBin bh symtab_p           -- Seek back to the end of the file
+
+    -- Write the symbol table itself
+    symtab_next <- readFastMutInt symtab_next
+    symtab_map  <- readIORef symtab_map
+    putSymbolTable bh symtab_next symtab_map
+    log_action (text "writeBinIface:" <+> int symtab_next
+                                <+> text "Names")
+
+    -- NB. write the dictionary after the symbol table, because
+    -- writing the symbol table may create more dictionary entries.
+
+    -- Write the dictionary pointer at the front of the file
+    dict_p <- tellBin bh          -- This is where the dictionary will start
+    putAt bh dict_p_p dict_p      -- Fill in the placeholder
+    seekBin bh dict_p             -- Seek back to the end of the file
+
+    -- Write the dictionary itself
+    dict_next <- readFastMutInt dict_next_ref
+    dict_map  <- readIORef dict_map_ref
+    putDictionary bh dict_next dict_map
+    log_action (text "writeBinIface:" <+> int dict_next
+                                <+> text "dict entries")
+
+
+
+-- | Initial ram buffer to allocate for writing interface files
+initBinMemSize :: Int
+initBinMemSize = 1024 * 1024
+
+binaryInterfaceMagic :: DynFlags -> Word32
+binaryInterfaceMagic dflags
+ | target32Bit (targetPlatform dflags) = 0x1face
+ | otherwise                           = 0x1face64
+
+
+-- -----------------------------------------------------------------------------
+-- The symbol table
+--
+
+putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
+putSymbolTable bh next_off symtab = do
+    put_ bh next_off
+    let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))
+      -- It's OK to use nonDetEltsUFM here because the elements have
+      -- indices that array uses to create order
+    mapM_ (\n -> serialiseName bh n symtab) names
+
+getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
+getSymbolTable bh ncu = do
+    sz <- get bh
+    od_names <- sequence (replicate sz (get bh))
+    updateNameCache ncu $ \namecache ->
+        runST $ flip State.evalStateT namecache $ do
+            mut_arr <- lift $ newSTArray_ (0, sz-1)
+            for_ (zip [0..] od_names) $ \(i, odn) -> do
+                (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn
+                lift $ writeArray mut_arr i n
+                State.put nc
+            arr <- lift $ unsafeFreeze mut_arr
+            namecache' <- State.get
+            return (namecache', arr)
+  where
+    -- This binding is required because the type of newArray_ cannot be inferred
+    newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)
+    newSTArray_ = newArray_
+
+type OnDiskName = (UnitId, ModuleName, OccName)
+
+fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)
+fromOnDiskName nc (pid, mod_name, occ) =
+    let mod   = mkModule pid mod_name
+        cache = nsNames nc
+    in case lookupOrigNameCache cache  mod occ of
+           Just name -> (nc, name)
+           Nothing   ->
+               let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
+                   name       = mkExternalName uniq mod occ noSrcSpan
+                   new_cache  = extendNameCache cache mod occ name
+               in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
+
+serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
+serialiseName bh name _ = do
+    let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
+    put_ bh (moduleUnitId mod, moduleName mod, nameOccName name)
+
+
+-- Note [Symbol table representation of names]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- An occurrence of a name in an interface file is serialized as a single 32-bit
+-- word. The format of this word is:
+--  00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx
+--   A normal name. x is an index into the symbol table
+--  10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy
+--   A known-key name. x is the Unique's Char, y is the int part. We assume that
+--   all known-key uniques fit in this space. This is asserted by
+--   PrelInfo.knownKeyNamesOkay.
+--
+-- During serialization we check for known-key things using isKnownKeyName.
+-- During deserialization we use lookupKnownKeyName to get from the unique back
+-- to its corresponding Name.
+
+
+-- See Note [Symbol table representation of names]
+putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
+putName _dict BinSymbolTable{
+               bin_symtab_map = symtab_map_ref,
+               bin_symtab_next = symtab_next }
+        bh name
+  | isKnownKeyName name
+  , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
+  = -- ASSERT(u < 2^(22 :: Int))
+    put_ bh (0x80000000
+             .|. (fromIntegral (ord c) `shiftL` 22)
+             .|. (fromIntegral u :: Word32))
+
+  | otherwise
+  = do symtab_map <- readIORef symtab_map_ref
+       case lookupUFM symtab_map name of
+         Just (off,_) -> put_ bh (fromIntegral off :: Word32)
+         Nothing -> do
+            off <- readFastMutInt symtab_next
+            -- MASSERT(off < 2^(30 :: Int))
+            writeFastMutInt symtab_next (off+1)
+            writeIORef symtab_map_ref
+                $! addToUFM symtab_map name (off,name)
+            put_ bh (fromIntegral off :: Word32)
+
+-- See Note [Symbol table representation of names]
+getSymtabName :: NameCacheUpdater
+              -> Dictionary -> SymbolTable
+              -> BinHandle -> IO Name
+getSymtabName _ncu _dict symtab bh = do
+    i :: Word32 <- get bh
+    case i .&. 0xC0000000 of
+      0x00000000 -> return $! symtab ! fromIntegral i
+
+      0x80000000 ->
+        let
+          tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
+          ix  = fromIntegral i .&. 0x003FFFFF
+          u   = mkUnique tag ix
+        in
+          return $! case lookupKnownKeyName u of
+                      Nothing -> pprPanic "getSymtabName:unknown known-key unique"
+                                          (ppr i $$ ppr (unpkUnique u))
+                      Just n  -> n
+
+      _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
+
+data BinSymbolTable = BinSymbolTable {
+        bin_symtab_next :: !FastMutInt, -- The next index to use
+        bin_symtab_map  :: !(IORef (UniqFM (Int,Name)))
+                                -- indexed by Name
+  }
+
+putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
+putFastString dict bh fs = allocateFastString dict fs >>= put_ bh
+
+allocateFastString :: BinDictionary -> FastString -> IO Word32
+allocateFastString BinDictionary { bin_dict_next = j_r,
+                                   bin_dict_map  = out_r} f = do
+    out <- readIORef out_r
+    let uniq = getUnique f
+    case lookupUFM out uniq of
+        Just (j, _)  -> return (fromIntegral j :: Word32)
+        Nothing -> do
+           j <- readFastMutInt j_r
+           writeFastMutInt j_r (j + 1)
+           writeIORef out_r $! addToUFM out uniq (j, f)
+           return (fromIntegral j :: Word32)
+
+getDictFastString :: Dictionary -> BinHandle -> IO FastString
+getDictFastString dict bh = do
+    j <- get bh
+    return $! (dict ! fromIntegral (j :: Word32))
+
+data BinDictionary = BinDictionary {
+        bin_dict_next :: !FastMutInt, -- The next index to use
+        bin_dict_map  :: !(IORef (UniqFM (Int,FastString)))
+                                -- indexed by FastString
+  }
+
+getWayDescr :: DynFlags -> String
+getWayDescr dflags
+  | platformUnregisterised (targetPlatform dflags) = 'u':tag
+  | otherwise                                      =     tag
+  where tag = buildTag dflags
+        -- if this is an unregisterised build, make sure our interfaces
+        -- can't be used by a registerised build.
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
new file mode 100644
--- /dev/null
+++ b/compiler/iface/BuildTyCl.hs
@@ -0,0 +1,415 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+
+{-# LANGUAGE CPP #-}
+
+module BuildTyCl (
+        buildDataCon,
+        buildPatSyn,
+        TcMethInfo, MethInfo, buildClass,
+        mkNewTyConRhs,
+        newImplicitBinder, newTyConRepName
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import IfaceEnv
+import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
+import TysWiredIn( isCTupleTyConName )
+import TysPrim ( voidPrimTy )
+import DataCon
+import PatSyn
+import Var
+import VarSet
+import BasicTypes
+import Name
+import NameEnv
+import MkId
+import Class
+import TyCon
+import Type
+import Id
+import TcType
+
+import SrcLoc( SrcSpan, noSrcSpan )
+import DynFlags
+import TcRnMonad
+import UniqSupply
+import Util
+import Outputable
+
+
+mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
+-- ^ Monadic because it makes a Name for the coercion TyCon
+--   We pass the Name of the parent TyCon, as well as the TyCon itself,
+--   because the latter is part of a knot, whereas the former is not.
+mkNewTyConRhs tycon_name tycon con
+  = do  { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
+        ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs
+        ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)
+        ; return (NewTyCon { data_con    = con,
+                             nt_rhs      = rhs_ty,
+                             nt_etad_rhs = (etad_tvs, etad_rhs),
+                             nt_co       = nt_ax } ) }
+                             -- Coreview looks through newtypes with a Nothing
+                             -- for nt_co, or uses explicit coercions otherwise
+  where
+    tvs    = tyConTyVars tycon
+    roles  = tyConRoles tycon
+    con_arg_ty = case dataConRepArgTys con of
+                   [arg_ty] -> arg_ty
+                   tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys)
+    rhs_ty = substTyWith (dataConUnivTyVars con)
+                         (mkTyVarTys tvs) con_arg_ty
+        -- Instantiate the newtype's RHS with the
+        -- type variables from the tycon
+        -- NB: a newtype DataCon has a type that must look like
+        --        forall tvs.  <arg-ty> -> T tvs
+        -- Note that we *can't* use dataConInstOrigArgTys here because
+        -- the newtype arising from   class Foo a => Bar a where {}
+        -- has a single argument (Foo a) that is a *type class*, so
+        -- dataConInstOrigArgTys returns [].
+
+    etad_tvs   :: [TyVar]  -- Matched lazily, so that mkNewTypeCo can
+    etad_roles :: [Role]   -- return a TyCon without pulling on rhs_ty
+    etad_rhs   :: Type     -- See Note [Tricky iface loop] in LoadIface
+    (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty
+
+    eta_reduce :: [TyVar]       -- Reversed
+               -> [Role]        -- also reversed
+               -> Type          -- Rhs type
+               -> ([TyVar], [Role], Type)  -- Eta-reduced version
+                                           -- (tyvars in normal order)
+    eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,
+                                  Just tv <- getTyVar_maybe arg,
+                                  tv == a,
+                                  not (a `elemVarSet` tyCoVarsOfType fun)
+                                = eta_reduce as rs fun
+    eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)
+
+------------------------------------------------------
+buildDataCon :: FamInstEnvs
+            -> Name
+            -> Bool                     -- Declared infix
+            -> TyConRepName
+            -> [HsSrcBang]
+            -> Maybe [HsImplBang]
+                -- See Note [Bangs on imported data constructors] in MkId
+           -> [FieldLabel]             -- Field labels
+           -> [TyVar]                  -- Universals
+           -> [TyCoVar]                -- Existentials
+           -> [TyVarBinder]            -- User-written 'TyVarBinder's
+           -> [EqSpec]                 -- Equality spec
+           -> KnotTied ThetaType       -- Does not include the "stupid theta"
+                                       -- or the GADT equalities
+           -> [KnotTied Type]          -- Arguments
+           -> KnotTied Type            -- Result types
+           -> KnotTied TyCon           -- Rep tycon
+           -> NameEnv ConTag           -- Maps the Name of each DataCon to its
+                                       -- ConTag
+           -> TcRnIf m n DataCon
+-- A wrapper for DataCon.mkDataCon that
+--   a) makes the worker Id
+--   b) makes the wrapper Id if necessary, including
+--      allocating its unique (hence monadic)
+buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs
+             field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty
+             rep_tycon tag_map
+  = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
+        ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
+        -- This last one takes the name of the data constructor in the source
+        -- code, which (for Haskell source anyway) will be in the DataName name
+        -- space, and puts it into the VarName name space
+
+        ; traceIf (text "buildDataCon 1" <+> ppr src_name)
+        ; us <- newUniqueSupply
+        ; dflags <- getDynFlags
+        ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
+              tag = lookupNameEnv_NF tag_map src_name
+              -- See Note [Constructor tag allocation], fixes #14657
+              data_con = mkDataCon src_name declared_infix prom_info
+                                   src_bangs field_lbls
+                                   univ_tvs ex_tvs user_tvbs eq_spec ctxt
+                                   arg_tys res_ty NoRRI rep_tycon tag
+                                   stupid_ctxt dc_wrk dc_rep
+              dc_wrk = mkDataConWorkId work_name data_con
+              dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
+                                                impl_bangs data_con)
+
+        ; traceIf (text "buildDataCon 2" <+> ppr src_name)
+        ; return data_con }
+
+
+-- The stupid context for a data constructor should be limited to
+-- the type variables mentioned in the arg_tys
+-- ToDo: Or functionally dependent on?
+--       This whole stupid theta thing is, well, stupid.
+mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
+mkDataConStupidTheta tycon arg_tys univ_tvs
+  | null stupid_theta = []      -- The common case
+  | otherwise         = filter in_arg_tys stupid_theta
+  where
+    tc_subst     = zipTvSubst (tyConTyVars tycon)
+                              (mkTyVarTys univ_tvs)
+    stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
+        -- Start by instantiating the master copy of the
+        -- stupid theta, taken from the TyCon
+
+    arg_tyvars      = tyCoVarsOfTypes arg_tys
+    in_arg_tys pred = not $ isEmptyVarSet $
+                      tyCoVarsOfType pred `intersectVarSet` arg_tyvars
+
+
+------------------------------------------------------
+buildPatSyn :: Name -> Bool
+            -> (Id,Bool) -> Maybe (Id, Bool)
+            -> ([TyVarBinder], ThetaType) -- ^ Univ and req
+            -> ([TyVarBinder], ThetaType) -- ^ Ex and prov
+            -> [Type]               -- ^ Argument types
+            -> Type                 -- ^ Result type
+            -> [FieldLabel]         -- ^ Field labels for
+                                    --   a record pattern synonym
+            -> PatSyn
+buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
+            (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
+            pat_ty field_labels
+  = -- The assertion checks that the matcher is
+    -- compatible with the pattern synonym
+    ASSERT2((and [ univ_tvs `equalLength` univ_tvs1
+                 , ex_tvs `equalLength` ex_tvs1
+                 , pat_ty `eqType` substTy subst pat_ty1
+                 , prov_theta `eqTypes` substTys subst prov_theta1
+                 , req_theta `eqTypes` substTys subst req_theta1
+                 , compareArgTys arg_tys (substTys subst arg_tys1)
+                 ])
+            , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
+                    , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
+                    , ppr pat_ty <+> twiddle <+> ppr pat_ty1
+                    , ppr prov_theta <+> twiddle <+> ppr prov_theta1
+                    , ppr req_theta <+> twiddle <+> ppr req_theta1
+                    , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
+    mkPatSyn src_name declared_infix
+             (univ_tvs, req_theta) (ex_tvs, prov_theta)
+             arg_tys pat_ty
+             matcher builder field_labels
+  where
+    ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id
+    ([pat_ty1, cont_sigma, _], _)      = tcSplitFunTys tau
+    (ex_tvs1, prov_theta1, cont_tau)   = tcSplitSigmaTy cont_sigma
+    (arg_tys1, _) = (tcSplitFunTys cont_tau)
+    twiddle = char '~'
+    subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)
+                       (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs)))
+
+    -- For a nullary pattern synonym we add a single void argument to the
+    -- matcher to preserve laziness in the case of unlifted types.
+    -- See #12746
+    compareArgTys :: [Type] -> [Type] -> Bool
+    compareArgTys [] [x] = x `eqType` voidPrimTy
+    compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys
+
+
+------------------------------------------------------
+type TcMethInfo = MethInfo  -- this variant needs zonking
+type MethInfo       -- A temporary intermediate, to communicate
+                    -- between tcClassSigs and buildClass.
+  = ( Name   -- Name of the class op
+    , Type   -- Type of the class op
+    , Maybe (DefMethSpec (SrcSpan, Type)))
+         -- Nothing                    => no default method
+         --
+         -- Just VanillaDM             => There is an ordinary
+         --                               polymorphic default method
+         --
+         -- Just (GenericDM (loc, ty)) => There is a generic default metho
+         --                               Here is its type, and the location
+         --                               of the type signature
+         --    We need that location /only/ to attach it to the
+         --    generic default method's Name; and we need /that/
+         --    only to give the right location of an ambiguity error
+         --    for the generic default method, spat out by checkValidClass
+
+buildClass :: Name  -- Name of the class/tycon (they have the same Name)
+           -> [TyConBinder]                -- Of the tycon
+           -> [Role]
+           -> [FunDep TyVar]               -- Functional dependencies
+           -- Super classes, associated types, method info, minimal complete def.
+           -- This is Nothing if the class is abstract.
+           -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef)
+           -> TcRnIf m n Class
+
+buildClass tycon_name binders roles fds Nothing
+  = fixM  $ \ rec_clas ->       -- Only name generation inside loop
+    do  { traceIf (text "buildClass")
+
+        ; tc_rep_name  <- newTyConRepName tycon_name
+        ; let univ_bndrs = tyConTyVarBinders binders
+              univ_tvs   = binderVars univ_bndrs
+              tycon = mkClassTyCon tycon_name binders roles
+                                   AbstractTyCon rec_clas tc_rep_name
+              result = mkAbstractClass tycon_name univ_tvs fds tycon
+        ; traceIf (text "buildClass" <+> ppr tycon)
+        ; return result }
+
+buildClass tycon_name binders roles fds
+           (Just (sc_theta, at_items, sig_stuff, mindef))
+  = fixM  $ \ rec_clas ->       -- Only name generation inside loop
+    do  { traceIf (text "buildClass")
+
+        ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
+        ; tc_rep_name  <- newTyConRepName tycon_name
+
+        ; op_items <- mapM (mk_op_item rec_clas) sig_stuff
+                        -- Build the selector id and default method id
+
+              -- Make selectors for the superclasses
+        ; sc_sel_names <- mapM  (newImplicitBinder tycon_name . mkSuperDictSelOcc)
+                                (takeList sc_theta [fIRST_TAG..])
+        ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
+                           | sc_name <- sc_sel_names]
+              -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
+              -- can construct names for the selectors. Thus
+              --      class (C a, C b) => D a b where ...
+              -- gives superclass selectors
+              --      D_sc1, D_sc2
+              -- (We used to call them D_C, but now we can have two different
+              --  superclasses both called C!)
+
+        ; let use_newtype = isSingleton arg_tys
+                -- Use a newtype if the data constructor
+                --   (a) has exactly one value field
+                --       i.e. exactly one operation or superclass taken together
+                --   (b) that value is of lifted type (which they always are, because
+                --       we box equality superclasses)
+                -- See note [Class newtypes and equality predicates]
+
+                -- We treat the dictionary superclasses as ordinary arguments.
+                -- That means that in the case of
+                --     class C a => D a
+                -- we don't get a newtype with no arguments!
+              args       = sc_sel_names ++ op_names
+              op_tys     = [ty | (_,ty,_) <- sig_stuff]
+              op_names   = [op | (op,_,_) <- sig_stuff]
+              arg_tys    = sc_theta ++ op_tys
+              rec_tycon  = classTyCon rec_clas
+              univ_bndrs = tyConTyVarBinders binders
+              univ_tvs   = binderVars univ_bndrs
+
+        ; rep_nm   <- newTyConRepName datacon_name
+        ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
+                                   datacon_name
+                                   False        -- Not declared infix
+                                   rep_nm
+                                   (map (const no_bang) args)
+                                   (Just (map (const HsLazy) args))
+                                   [{- No fields -}]
+                                   univ_tvs
+                                   [{- no existentials -}]
+                                   univ_bndrs
+                                   [{- No GADT equalities -}]
+                                   [{- No theta -}]
+                                   arg_tys
+                                   (mkTyConApp rec_tycon (mkTyVarTys univ_tvs))
+                                   rec_tycon
+                                   (mkTyConTagMap rec_tycon)
+
+        ; rhs <- case () of
+                  _ | use_newtype
+                    -> mkNewTyConRhs tycon_name rec_tycon dict_con
+                    | isCTupleTyConName tycon_name
+                    -> return (TupleTyCon { data_con = dict_con
+                                          , tup_sort = ConstraintTuple })
+                    | otherwise
+                    -> return (mkDataTyConRhs [dict_con])
+
+        ; let { tycon = mkClassTyCon tycon_name binders roles
+                                     rhs rec_clas tc_rep_name
+                -- A class can be recursive, and in the case of newtypes
+                -- this matters.  For example
+                --      class C a where { op :: C b => a -> b -> Int }
+                -- Because C has only one operation, it is represented by
+                -- a newtype, and it should be a *recursive* newtype.
+                -- [If we don't make it a recursive newtype, we'll expand the
+                -- newtype like a synonym, but that will lead to an infinite
+                -- type]
+
+              ; result = mkClass tycon_name univ_tvs fds
+                                 sc_theta sc_sel_ids at_items
+                                 op_items mindef tycon
+              }
+        ; traceIf (text "buildClass" <+> ppr tycon)
+        ; return result }
+  where
+    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
+
+    mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
+    mk_op_item rec_clas (op_name, _, dm_spec)
+      = do { dm_info <- mk_dm_info op_name dm_spec
+           ; return (mkDictSelId op_name rec_clas, dm_info) }
+
+    mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type))
+               -> TcRnIf n m (Maybe (Name, DefMethSpec Type))
+    mk_dm_info _ Nothing
+      = return Nothing
+    mk_dm_info op_name (Just VanillaDM)
+      = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
+           ; return (Just (dm_name, VanillaDM)) }
+    mk_dm_info op_name (Just (GenericDM (loc, dm_ty)))
+      = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc
+           ; return (Just (dm_name, GenericDM dm_ty)) }
+
+{-
+Note [Class newtypes and equality predicates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+        class (a ~ F b) => C a b where
+          op :: a -> b
+
+We cannot represent this by a newtype, even though it's not
+existential, because there are two value fields (the equality
+predicate and op. See Trac #2238
+
+Moreover,
+          class (a ~ F b) => C a b where {}
+Here we can't use a newtype either, even though there is only
+one field, because equality predicates are unboxed, and classes
+are boxed.
+-}
+
+newImplicitBinder :: Name                       -- Base name
+                  -> (OccName -> OccName)       -- Occurrence name modifier
+                  -> TcRnIf m n Name            -- Implicit name
+-- Called in BuildTyCl to allocate the implicit binders of type/class decls
+-- For source type/class decls, this is the first occurrence
+-- For iface ones, the LoadIface has already allocated a suitable name in the cache
+newImplicitBinder base_name mk_sys_occ
+  = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name)
+
+newImplicitBinderLoc :: Name                       -- Base name
+                     -> (OccName -> OccName)       -- Occurrence name modifier
+                     -> SrcSpan
+                     -> TcRnIf m n Name            -- Implicit name
+-- Just the same, but lets you specify the SrcSpan
+newImplicitBinderLoc base_name mk_sys_occ loc
+  | Just mod <- nameModule_maybe base_name
+  = newGlobalBinder mod occ loc
+  | otherwise           -- When typechecking a [d| decl bracket |],
+                        -- TH generates types, classes etc with Internal names,
+                        -- so we follow suit for the implicit binders
+  = do  { uniq <- newUnique
+        ; return (mkInternalName uniq occ loc) }
+  where
+    occ = mk_sys_occ (nameOccName base_name)
+
+-- | Make the 'TyConRepName' for this 'TyCon'
+newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
+newTyConRepName tc_name
+  | Just mod <- nameModule_maybe tc_name
+  , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
+  = newGlobalBinder mod occ noSrcSpan
+  | otherwise
+  = newImplicitBinder tc_name mkTyConRepOcc
diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs
new file mode 100644
--- /dev/null
+++ b/compiler/iface/FlagChecker.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE RecordWildCards #-}
+
+-- | This module manages storing the various GHC option flags in a modules
+-- interface file as part of the recompilation checking infrastructure.
+module FlagChecker (
+        fingerprintDynFlags
+      , fingerprintOptFlags
+      , fingerprintHpcFlags
+    ) where
+
+import GhcPrelude
+
+import Binary
+import BinIface ()
+import DynFlags
+import HscTypes
+import Module
+import Name
+import Fingerprint
+import BinFingerprint
+-- import Outputable
+
+import qualified EnumSet
+import System.FilePath (normalise)
+
+-- | Produce a fingerprint of a @DynFlags@ value. We only base
+-- the finger print on important fields in @DynFlags@ so that
+-- the recompilation checker can use this fingerprint.
+--
+-- NB: The 'Module' parameter is the 'Module' recorded by the
+-- *interface* file, not the actual 'Module' according to our
+-- 'DynFlags'.
+fingerprintDynFlags :: DynFlags -> Module
+                    -> (BinHandle -> Name -> IO ())
+                    -> IO Fingerprint
+
+fingerprintDynFlags dflags@DynFlags{..} this_mod nameio =
+    let mainis   = if mainModIs == this_mod then Just mainFunIs else Nothing
+                      -- see #5878
+        -- pkgopts  = (thisPackage dflags, sort $ packageFlags dflags)
+        safeHs   = setSafeMode safeHaskell
+        -- oflags   = sort $ filter filterOFlags $ flags dflags
+
+        -- *all* the extension flags and the language
+        lang = (fmap fromEnum language,
+                map fromEnum $ EnumSet.toList extensionFlags)
+
+        -- -I, -D and -U flags affect CPP
+        cpp = ( map normalise $ flattenIncludes includePaths
+            -- normalise: eliminate spurious differences due to "./foo" vs "foo"
+              , picPOpts dflags
+              , opt_P_signature dflags)
+            -- See Note [Repeated -optP hashing]
+
+        -- Note [path flags and recompilation]
+        paths = [ hcSuf ]
+
+        -- -fprof-auto etc.
+        prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0
+
+        flags = (mainis, safeHs, lang, cpp, paths, prof)
+
+    in -- pprTrace "flags" (ppr flags) $
+       computeFingerprint nameio flags
+
+-- Fingerprint the optimisation info. We keep this separate from the rest of
+-- the flags because GHCi users (especially) may wish to ignore changes in
+-- optimisation level or optimisation flags so as to use as many pre-existing
+-- object files as they can.
+-- See Note [Ignoring some flag changes]
+fingerprintOptFlags :: DynFlags
+                      -> (BinHandle -> Name -> IO ())
+                      -> IO Fingerprint
+fingerprintOptFlags DynFlags{..} nameio =
+      let
+        -- See https://ghc.haskell.org/trac/ghc/ticket/10923
+        -- We used to fingerprint the optimisation level, but as Joachim
+        -- Breitner pointed out in comment 9 on that ticket, it's better
+        -- to ignore that and just look at the individual optimisation flags.
+        opt_flags = map fromEnum $ filter (`EnumSet.member` optimisationFlags)
+                                          (EnumSet.toList generalFlags)
+
+      in computeFingerprint nameio opt_flags
+
+-- Fingerprint the HPC info. We keep this separate from the rest of
+-- the flags because GHCi users (especially) may wish to use an object
+-- file compiled for HPC when not actually using HPC.
+-- See Note [Ignoring some flag changes]
+fingerprintHpcFlags :: DynFlags
+                      -> (BinHandle -> Name -> IO ())
+                      -> IO Fingerprint
+fingerprintHpcFlags dflags@DynFlags{..} nameio =
+      let
+        -- -fhpc, see https://ghc.haskell.org/trac/ghc/ticket/11798
+        -- hpcDir is output-only, so we should recompile if it changes
+        hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing
+
+      in computeFingerprint nameio hpc
+
+
+{- Note [path flags and recompilation]
+
+There are several flags that we deliberately omit from the
+recompilation check; here we explain why.
+
+-osuf, -odir, -hisuf, -hidir
+  If GHC decides that it does not need to recompile, then
+  it must have found an up-to-date .hi file and .o file.
+  There is no point recording these flags - the user must
+  have passed the correct ones.  Indeed, the user may
+  have compiled the source file in one-shot mode using
+  -o to specify the .o file, and then loaded it in GHCi
+  using -odir.
+
+-stubdir
+  We omit this one because it is automatically set by -outputdir, and
+  we don't want changes in -outputdir to automatically trigger
+  recompilation.  This could be wrong, but only in very rare cases.
+
+-i (importPaths)
+  For the same reason as -osuf etc. above: if GHC decides not to
+  recompile, then it must have already checked all the .hi files on
+  which the current module depends, so it must have found them
+  successfully.  It is occasionally useful to be able to cd to a
+  different directory and use -i flags to enable GHC to find the .hi
+  files; we don't want this to force recompilation.
+
+The only path-related flag left is -hcsuf.
+-}
+
+{- Note [Ignoring some flag changes]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Normally, --make tries to reuse only compilation products that are
+the same as those that would have been produced compiling from
+scratch. Sometimes, however, users would like to be more aggressive
+about recompilation avoidance. This is particularly likely when
+developing using GHCi (see #13604). Currently, we allow users to
+ignore optimisation changes using -fignore-optim-changes, and to
+ignore HPC option changes using -fignore-hpc-changes. If there's a
+demand for it, we could also allow changes to -fprof-auto-* flags
+(although we can't allow -prof flags to differ). The key thing about
+these options is that we can still successfully link a library or
+executable when some of its components differ in these ways.
+
+The way we accomplish this is to leave the optimization and HPC
+options out of the flag hash, hashing them separately.
+-}
+
+{- Note [Repeated -optP hashing]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We invoke fingerprintDynFlags for each compiled module to include
+the hash of relevant DynFlags in the resulting interface file.
+-optP (preprocessor) flags are part of that hash.
+-optP flags can come from multiple places:
+
+  1. -optP flags directly passed on command line.
+  2. -optP flags implied by other flags. Eg. -DPROFILING implied by -prof.
+  3. -optP flags added with {-# OPTIONS -optP-D__F__ #-} in a file.
+
+When compiling many modules at once with many -optP command line arguments
+the work of hashing -optP flags would be repeated. This can get expensive
+and as noted on #14697 it can take 7% of time and 14% of allocations on
+a real codebase.
+
+The obvious solution is to cache the hash of -optP flags per GHC invocation.
+However, one has to be careful there, as the flags that were added in 3. way
+have to be accounted for.
+
+The current strategy is as follows:
+
+  1. Lazily compute the hash of sOpt_p in sOpt_P_fingerprint whenever sOpt_p
+     is modified. This serves dual purpose. It ensures correctness for when
+     we add per file -optP flags and lets us save work for when we don't.
+  2. When computing the fingerprint in fingerprintDynFlags use the cached
+     value *and* fingerprint the additional implied (see 2. above) -optP flags.
+     This is relatively cheap and saves the headache of fingerprinting all
+     the -optP flags and tracking all the places that could invalidate the
+     cache.
+-}
diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/iface/IfaceEnv.hs
@@ -0,0 +1,298 @@
+-- (c) The University of Glasgow 2002-2006
+
+{-# LANGUAGE CPP, RankNTypes, BangPatterns #-}
+
+module IfaceEnv (
+        newGlobalBinder, newInteractiveBinder,
+        externaliseName,
+        lookupIfaceTop,
+        lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache,
+        newIfaceName, newIfaceNames,
+        extendIfaceIdEnv, extendIfaceTyVarEnv,
+        tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,
+        lookupIfaceTyVar, extendIfaceEnvs,
+        setNameModule,
+
+        ifaceExportNames,
+
+        -- Name-cache stuff
+        allocateGlobalBinder, updNameCacheTc,
+        mkNameCacheUpdater, NameCacheUpdater(..),
+   ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnMonad
+import HscTypes
+import Type
+import Var
+import Name
+import Avail
+import Module
+import FastString
+import FastStringEnv
+import IfaceType
+import NameCache
+import UniqSupply
+import SrcLoc
+
+import Outputable
+import Data.List     ( partition )
+
+{-
+*********************************************************
+*                                                      *
+        Allocating new Names in the Name Cache
+*                                                      *
+*********************************************************
+
+See Also: Note [The Name Cache] in NameCache
+-}
+
+newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
+-- Used for source code and interface files, to make the
+-- Name for a thing, given its Module and OccName
+-- See Note [The Name Cache]
+--
+-- The cache may already already have a binding for this thing,
+-- because we may have seen an occurrence before, but now is the
+-- moment when we know its Module and SrcLoc in their full glory
+
+newGlobalBinder mod occ loc
+  = do { name <- updNameCacheTc mod occ $ \name_cache ->
+                 allocateGlobalBinder name_cache mod occ loc
+       ; traceIf (text "newGlobalBinder" <+>
+                  (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))
+       ; return name }
+
+newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name
+-- Works in the IO monad, and gets the Module
+-- from the interactive context
+newInteractiveBinder hsc_env occ loc
+ = do { let mod = icInteractiveModule (hsc_IC hsc_env)
+       ; updNameCacheIO hsc_env mod occ $ \name_cache ->
+         allocateGlobalBinder name_cache mod occ loc }
+
+allocateGlobalBinder
+  :: NameCache
+  -> Module -> OccName -> SrcSpan
+  -> (NameCache, Name)
+-- See Note [The Name Cache]
+allocateGlobalBinder name_supply mod occ loc
+  = case lookupOrigNameCache (nsNames name_supply) mod occ of
+        -- A hit in the cache!  We are at the binding site of the name.
+        -- This is the moment when we know the SrcLoc
+        -- of the Name, so we set this field in the Name we return.
+        --
+        -- Then (bogus) multiple bindings of the same Name
+        -- get different SrcLocs can can be reported as such.
+        --
+        -- Possible other reason: it might be in the cache because we
+        --      encountered an occurrence before the binding site for an
+        --      implicitly-imported Name.  Perhaps the current SrcLoc is
+        --      better... but not really: it'll still just say 'imported'
+        --
+        -- IMPORTANT: Don't mess with wired-in names.
+        --            Their wired-in-ness is in their NameSort
+        --            and their Module is correct.
+
+        Just name | isWiredInName name
+                  -> (name_supply, name)
+                  | otherwise
+                  -> (new_name_supply, name')
+                  where
+                    uniq            = nameUnique name
+                    name'           = mkExternalName uniq mod occ loc
+                                      -- name' is like name, but with the right SrcSpan
+                    new_cache       = extendNameCache (nsNames name_supply) mod occ name'
+                    new_name_supply = name_supply {nsNames = new_cache}
+
+        -- Miss in the cache!
+        -- Build a completely new Name, and put it in the cache
+        _ -> (new_name_supply, name)
+                  where
+                    (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)
+                    name            = mkExternalName uniq mod occ loc
+                    new_cache       = extendNameCache (nsNames name_supply) mod occ name
+                    new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
+
+ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
+ifaceExportNames exports = return exports
+
+-- | A function that atomically updates the name cache given a modifier
+-- function.  The second result of the modifier function will be the result
+-- of the IO action.
+newtype NameCacheUpdater
+      = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c }
+
+mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater
+mkNameCacheUpdater = do { hsc_env <- getTopEnv
+                        ; let !ncRef = hsc_NC hsc_env
+                        ; return (NCU (updNameCache ncRef)) }
+
+updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c))
+               -> TcRnIf a b c
+updNameCacheTc mod occ upd_fn = do {
+    hsc_env <- getTopEnv
+  ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn }
+
+
+updNameCacheIO ::  HscEnv -> Module -> OccName
+               -> (NameCache -> (NameCache, c))
+               -> IO c
+updNameCacheIO hsc_env mod occ upd_fn = do {
+
+    -- First ensure that mod and occ are evaluated
+    -- If not, chaos can ensue:
+    --      we read the name-cache
+    --      then pull on mod (say)
+    --      which does some stuff that modifies the name cache
+    -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)
+
+    mod `seq` occ `seq` return ()
+  ; updNameCache (hsc_NC hsc_env) upd_fn }
+
+
+{-
+************************************************************************
+*                                                                      *
+                Name cache access
+*                                                                      *
+************************************************************************
+-}
+
+-- | Look up the 'Name' for a given 'Module' and 'OccName'.
+-- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad
+-- and 'Module' is simply that of the 'ModIface' you are typechecking.
+lookupOrig :: Module -> OccName -> TcRnIf a b Name
+lookupOrig mod occ
+  = do  { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
+
+        ; updNameCacheTc mod occ $ lookupNameCache mod occ }
+
+lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name
+lookupOrigIO hsc_env mod occ
+  = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ
+
+lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)
+-- Lookup up the (Module,OccName) in the NameCache
+-- If you find it, return it; if not, allocate a fresh original name and extend
+-- the NameCache.
+-- Reason: this may the first occurrence of (say) Foo.bar we have encountered.
+-- If we need to explore its value we will load Foo.hi; but meanwhile all we
+-- need is a Name for it.
+lookupNameCache mod occ name_cache =
+  case lookupOrigNameCache (nsNames name_cache) mod occ of {
+    Just name -> (name_cache, name);
+    Nothing   ->
+        case takeUniqFromSupply (nsUniqs name_cache) of {
+          (uniq, us) ->
+              let
+                name      = mkExternalName uniq mod occ noSrcSpan
+                new_cache = extendNameCache (nsNames name_cache) mod occ name
+              in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}
+
+externaliseName :: Module -> Name -> TcRnIf m n Name
+-- Take an Internal Name and make it an External one,
+-- with the same unique
+externaliseName mod name
+  = do { let occ = nameOccName name
+             loc = nameSrcSpan name
+             uniq = nameUnique name
+       ; occ `seq` return ()  -- c.f. seq in newGlobalBinder
+       ; updNameCacheTc mod occ $ \ ns ->
+         let name' = mkExternalName uniq mod occ loc
+             ns'   = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }
+         in (ns', name') }
+
+-- | Set the 'Module' of a 'Name'.
+setNameModule :: Maybe Module -> Name -> TcRnIf m n Name
+setNameModule Nothing n = return n
+setNameModule (Just m) n =
+    newGlobalBinder m (nameOccName n) (nameSrcSpan n)
+
+{-
+************************************************************************
+*                                                                      *
+                Type variables and local Ids
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceLclId :: FastString -> IfL Id
+tcIfaceLclId occ
+  = do  { lcl <- getLclEnv
+        ; case (lookupFsEnv (if_id_env lcl) occ) of
+            Just ty_var -> return ty_var
+            Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)
+        }
+
+extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
+extendIfaceIdEnv ids thing_inside
+  = do  { env <- getLclEnv
+        ; let { id_env' = extendFsEnvList (if_id_env env) pairs
+              ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }
+        ; setLclEnv (env { if_id_env = id_env' }) thing_inside }
+
+
+tcIfaceTyVar :: FastString -> IfL TyVar
+tcIfaceTyVar occ
+  = do  { lcl <- getLclEnv
+        ; case (lookupFsEnv (if_tv_env lcl) occ) of
+            Just ty_var -> return ty_var
+            Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
+        }
+
+lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)
+lookupIfaceTyVar (occ, _)
+  = do  { lcl <- getLclEnv
+        ; return (lookupFsEnv (if_tv_env lcl) occ) }
+
+lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)
+lookupIfaceVar (IfaceIdBndr (occ, _))
+  = do  { lcl <- getLclEnv
+        ; return (lookupFsEnv (if_id_env lcl) occ) }
+lookupIfaceVar (IfaceTvBndr (occ, _))
+  = do  { lcl <- getLclEnv
+        ; return (lookupFsEnv (if_tv_env lcl) occ) }
+
+extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
+extendIfaceTyVarEnv tyvars thing_inside
+  = do  { env <- getLclEnv
+        ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs
+              ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
+        ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
+
+extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a
+extendIfaceEnvs tcvs thing_inside
+  = extendIfaceTyVarEnv tvs $
+    extendIfaceIdEnv    cvs $
+    thing_inside
+  where
+    (tvs, cvs) = partition isTyVar tcvs
+
+{-
+************************************************************************
+*                                                                      *
+                Getting from RdrNames to Names
+*                                                                      *
+************************************************************************
+-}
+
+-- | Look up a top-level name from the current Iface module
+lookupIfaceTop :: OccName -> IfL Name
+lookupIfaceTop occ
+  = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }
+
+newIfaceName :: OccName -> IfL Name
+newIfaceName occ
+  = do  { uniq <- newUnique
+        ; return $! mkInternalName uniq occ noSrcSpan }
+
+newIfaceNames :: [OccName] -> IfL [Name]
+newIfaceNames occs
+  = do  { uniqs <- newUniqueSupply
+        ; return [ mkInternalName uniq occ noSrcSpan
+                 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
diff --git a/compiler/iface/IfaceEnv.hs-boot b/compiler/iface/IfaceEnv.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/iface/IfaceEnv.hs-boot
@@ -0,0 +1,9 @@
+module IfaceEnv where
+
+import Module
+import OccName
+import TcRnMonad
+import Name
+import SrcLoc
+
+newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
new file mode 100644
--- /dev/null
+++ b/compiler/iface/LoadIface.hs
@@ -0,0 +1,1286 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Loading interface files
+-}
+
+{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module LoadIface (
+        -- Importing one thing
+        tcLookupImported_maybe, importDecl,
+        checkWiredInTyCon, ifCheckWiredInThing,
+
+        -- RnM/TcM functions
+        loadModuleInterface, loadModuleInterfaces,
+        loadSrcInterface, loadSrcInterface_maybe,
+        loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule,
+
+        -- IfM functions
+        loadInterface,
+        loadSysInterface, loadUserInterface, loadPluginInterface,
+        findAndReadIface, readIface,    -- Used when reading the module's old interface
+        loadDecls,      -- Should move to TcIface and be renamed
+        initExternalPackageState,
+        moduleFreeHolesPrecise,
+        needWiredInHomeIface, loadWiredInHomeIface,
+
+        pprModIfaceSimple,
+        ifaceStats, pprModIface, showIface
+   ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-}   TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,
+                                 tcIfaceFamInst,
+                                 tcIfaceAnnotations, tcIfaceCompleteSigs )
+
+import DynFlags
+import IfaceSyn
+import IfaceEnv
+import HscTypes
+
+import BasicTypes hiding (SuccessFlag(..))
+import TcRnMonad
+
+import Constants
+import PrelNames
+import PrelInfo
+import PrimOp   ( allThePrimOps, primOpFixity, primOpOcc )
+import MkId     ( seqId )
+import TysPrim  ( funTyConName )
+import Rules
+import TyCon
+import Annotations
+import InstEnv
+import FamInstEnv
+import Name
+import NameEnv
+import Avail
+import Module
+import Maybes
+import ErrUtils
+import Finder
+import UniqFM
+import SrcLoc
+import Outputable
+import BinIface
+import Panic
+import Util
+import FastString
+import Fingerprint
+import Hooks
+import FieldLabel
+import RnModIface
+import UniqDSet
+import Plugins
+
+import Control.Monad
+import Control.Exception
+import Data.IORef
+import System.FilePath
+
+{-
+************************************************************************
+*                                                                      *
+*      tcImportDecl is the key function for "faulting in"              *
+*      imported things
+*                                                                      *
+************************************************************************
+
+The main idea is this.  We are chugging along type-checking source code, and
+find a reference to GHC.Base.map.  We call tcLookupGlobal, which doesn't find
+it in the EPS type envt.  So it
+        1 loads GHC.Base.hi
+        2 gets the decl for GHC.Base.map
+        3 typechecks it via tcIfaceDecl
+        4 and adds it to the type env in the EPS
+
+Note that DURING STEP 4, we may find that map's type mentions a type
+constructor that also
+
+Notice that for imported things we read the current version from the EPS
+mutable variable.  This is important in situations like
+        ...$(e1)...$(e2)...
+where the code that e1 expands to might import some defns that
+also turn out to be needed by the code that e2 expands to.
+-}
+
+tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)
+-- Returns (Failed err) if we can't find the interface file for the thing
+tcLookupImported_maybe name
+  = do  { hsc_env <- getTopEnv
+        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
+        ; case mb_thing of
+            Just thing -> return (Succeeded thing)
+            Nothing    -> tcImportDecl_maybe name }
+
+tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)
+-- Entry point for *source-code* uses of importDecl
+tcImportDecl_maybe name
+  | Just thing <- wiredInNameTyThing_maybe name
+  = do  { when (needWiredInHomeIface thing)
+               (initIfaceTcRn (loadWiredInHomeIface name))
+                -- See Note [Loading instances for wired-in things]
+        ; return (Succeeded thing) }
+  | otherwise
+  = initIfaceTcRn (importDecl name)
+
+importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing)
+-- Get the TyThing for this Name from an interface file
+-- It's not a wired-in thing -- the caller caught that
+importDecl name
+  = ASSERT( not (isWiredInName name) )
+    do  { traceIf nd_doc
+
+        -- Load the interface, which should populate the PTE
+        ; mb_iface <- ASSERT2( isExternalName name, ppr name )
+                      loadInterface nd_doc (nameModule name) ImportBySystem
+        ; case mb_iface of {
+                Failed err_msg  -> return (Failed err_msg) ;
+                Succeeded _ -> do
+
+        -- Now look it up again; this time we should find it
+        { eps <- getEps
+        ; case lookupTypeEnv (eps_PTE eps) name of
+            Just thing -> return $ Succeeded thing
+            Nothing    -> let doc = whenPprDebug (found_things_msg eps $$ empty)
+                                    $$ not_found_msg
+                          in return $ Failed doc
+    }}}
+  where
+    nd_doc = text "Need decl for" <+> ppr name
+    not_found_msg = hang (text "Can't find interface-file declaration for" <+>
+                                pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)
+                       2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file",
+                                text "Use -ddump-if-trace to get an idea of which file caused the error"])
+    found_things_msg eps =
+        hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon)
+           2 (vcat (map ppr $ filter is_interesting $ nameEnvElts $ eps_PTE eps))
+      where
+        is_interesting thing = nameModule name == nameModule (getName thing)
+
+
+{-
+************************************************************************
+*                                                                      *
+           Checks for wired-in things
+*                                                                      *
+************************************************************************
+
+Note [Loading instances for wired-in things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to make sure that we have at least *read* the interface files
+for any module with an instance decl or RULE that we might want.
+
+* If the instance decl is an orphan, we have a whole separate mechanism
+  (loadOrphanModules)
+
+* If the instance decl is not an orphan, then the act of looking at the
+  TyCon or Class will force in the defining module for the
+  TyCon/Class, and hence the instance decl
+
+* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface;
+  but we must make sure we read its interface in case it has instances or
+  rules.  That is what LoadIface.loadWiredInHomeIface does.  It's called
+  from TcIface.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing}
+
+* HOWEVER, only do this for TyCons.  There are no wired-in Classes.  There
+  are some wired-in Ids, but we don't want to load their interfaces. For
+  example, Control.Exception.Base.recSelError is wired in, but that module
+  is compiled late in the base library, and we don't want to force it to
+  load before it's been compiled!
+
+All of this is done by the type checker. The renamer plays no role.
+(It used to, but no longer.)
+-}
+
+checkWiredInTyCon :: TyCon -> TcM ()
+-- Ensure that the home module of the TyCon (and hence its instances)
+-- are loaded. See Note [Loading instances for wired-in things]
+-- It might not be a wired-in tycon (see the calls in TcUnify),
+-- in which case this is a no-op.
+checkWiredInTyCon tc
+  | not (isWiredInName tc_name)
+  = return ()
+  | otherwise
+  = do  { mod <- getModule
+        ; traceIf (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)
+        ; ASSERT( isExternalName tc_name )
+          when (mod /= nameModule tc_name)
+               (initIfaceTcRn (loadWiredInHomeIface tc_name))
+                -- Don't look for (non-existent) Float.hi when
+                -- compiling Float.hs, which mentions Float of course
+                -- A bit yukky to call initIfaceTcRn here
+        }
+  where
+    tc_name = tyConName tc
+
+ifCheckWiredInThing :: TyThing -> IfL ()
+-- Even though we are in an interface file, we want to make
+-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double)
+-- Ditto want to ensure that RULES are loaded too
+-- See Note [Loading instances for wired-in things]
+ifCheckWiredInThing thing
+  = do  { mod <- getIfModule
+                -- Check whether we are typechecking the interface for this
+                -- very module.  E.g when compiling the base library in --make mode
+                -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in
+                -- the HPT, so without the test we'll demand-load it into the PIT!
+                -- C.f. the same test in checkWiredInTyCon above
+        ; let name = getName thing
+        ; ASSERT2( isExternalName name, ppr name )
+          when (needWiredInHomeIface thing && mod /= nameModule name)
+               (loadWiredInHomeIface name) }
+
+needWiredInHomeIface :: TyThing -> Bool
+-- Only for TyCons; see Note [Loading instances for wired-in things]
+needWiredInHomeIface (ATyCon {}) = True
+needWiredInHomeIface _           = False
+
+
+{-
+************************************************************************
+*                                                                      *
+        loadSrcInterface, loadOrphanModules, loadInterfaceForName
+
+                These three are called from TcM-land
+*                                                                      *
+************************************************************************
+-}
+
+-- | Load the interface corresponding to an @import@ directive in
+-- source code.  On a failure, fail in the monad with an error message.
+loadSrcInterface :: SDoc
+                 -> ModuleName
+                 -> IsBootInterface     -- {-# SOURCE #-} ?
+                 -> Maybe FastString    -- "package", if any
+                 -> RnM ModIface
+
+loadSrcInterface doc mod want_boot maybe_pkg
+  = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg
+       ; case res of
+           Failed err      -> failWithTc err
+           Succeeded iface -> return iface }
+
+-- | Like 'loadSrcInterface', but returns a 'MaybeErr'.
+loadSrcInterface_maybe :: SDoc
+                       -> ModuleName
+                       -> IsBootInterface     -- {-# SOURCE #-} ?
+                       -> Maybe FastString    -- "package", if any
+                       -> RnM (MaybeErr MsgDoc ModIface)
+
+loadSrcInterface_maybe doc mod want_boot maybe_pkg
+  -- We must first find which Module this import refers to.  This involves
+  -- calling the Finder, which as a side effect will search the filesystem
+  -- and create a ModLocation.  If successful, loadIface will read the
+  -- interface; it will call the Finder again, but the ModLocation will be
+  -- cached from the first search.
+  = do { hsc_env <- getTopEnv
+       ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg
+       ; case res of
+           Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)
+           -- TODO: Make sure this error message is good
+           err         -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) }
+
+-- | Load interface directly for a fully qualified 'Module'.  (This is a fairly
+-- rare operation, but in particular it is used to load orphan modules
+-- in order to pull their instances into the global package table and to
+-- handle some operations in GHCi).
+loadModuleInterface :: SDoc -> Module -> TcM ModIface
+loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod)
+
+-- | Load interfaces for a collection of modules.
+loadModuleInterfaces :: SDoc -> [Module] -> TcM ()
+loadModuleInterfaces doc mods
+  | null mods = return ()
+  | otherwise = initIfaceTcRn (mapM_ load mods)
+  where
+    load mod = loadSysInterface (doc <+> parens (ppr mod)) mod
+
+-- | Loads the interface for a given Name.
+-- Should only be called for an imported name;
+-- otherwise loadSysInterface may not find the interface
+loadInterfaceForName :: SDoc -> Name -> TcRn ModIface
+loadInterfaceForName doc name
+  = do { when debugIsOn $  -- Check pre-condition
+         do { this_mod <- getModule
+            ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) }
+      ; ASSERT2( isExternalName name, ppr name )
+        initIfaceTcRn $ loadSysInterface doc (nameModule name) }
+
+-- | Only loads the interface for external non-local names.
+loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface)
+loadInterfaceForNameMaybe doc name
+  = do { this_mod <- getModule
+       ; if nameIsLocalOrFrom this_mod name || not (isExternalName name)
+         then return Nothing
+         else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name))
+       }
+
+-- | Loads the interface for a given Module.
+loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface
+loadInterfaceForModule doc m
+  = do
+    -- Should not be called with this module
+    when debugIsOn $ do
+      this_mod <- getModule
+      MASSERT2( this_mod /= m, ppr m <+> parens doc )
+    initIfaceTcRn $ loadSysInterface doc m
+
+{-
+*********************************************************
+*                                                      *
+                loadInterface
+
+        The main function to load an interface
+        for an imported module, and put it in
+        the External Package State
+*                                                      *
+*********************************************************
+-}
+
+-- | An 'IfM' function to load the home interface for a wired-in thing,
+-- so that we're sure that we see its instance declarations and rules
+-- See Note [Loading instances for wired-in things]
+loadWiredInHomeIface :: Name -> IfM lcl ()
+loadWiredInHomeIface name
+  = ASSERT( isWiredInName name )
+    do _ <- loadSysInterface doc (nameModule name); return ()
+  where
+    doc = text "Need home interface for wired-in thing" <+> ppr name
+
+------------------
+-- | Loads a system interface and throws an exception if it fails
+loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
+loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem
+
+------------------
+-- | Loads a user interface and throws an exception if it fails. The first parameter indicates
+-- whether we should import the boot variant of the module
+loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface
+loadUserInterface is_boot doc mod_name
+  = loadInterfaceWithException doc mod_name (ImportByUser is_boot)
+
+loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface
+loadPluginInterface doc mod_name
+  = loadInterfaceWithException doc mod_name ImportByPlugin
+
+------------------
+-- | A wrapper for 'loadInterface' that throws an exception if it fails
+loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface
+loadInterfaceWithException doc mod_name where_from
+  = withException (loadInterface doc mod_name where_from)
+
+------------------
+loadInterface :: SDoc -> Module -> WhereFrom
+              -> IfM lcl (MaybeErr MsgDoc ModIface)
+
+-- loadInterface looks in both the HPT and PIT for the required interface
+-- If not found, it loads it, and puts it in the PIT (always).
+
+-- If it can't find a suitable interface file, we
+--      a) modify the PackageIfaceTable to have an empty entry
+--              (to avoid repeated complaints)
+--      b) return (Left message)
+--
+-- It's not necessarily an error for there not to be an interface
+-- file -- perhaps the module has changed, and that interface
+-- is no longer used
+
+loadInterface doc_str mod from
+  | isHoleModule mod
+  -- Hole modules get special treatment
+  = do dflags <- getDynFlags
+       -- Redo search for our local hole module
+       loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from
+  | otherwise
+  = do  {       -- Read the state
+          (eps,hpt) <- getEpsAndHpt
+        ; gbl_env <- getGblEnv
+
+        ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)
+
+                -- Check whether we have the interface already
+        ; dflags <- getDynFlags
+        ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of {
+            Just iface
+                -> return (Succeeded iface) ;   -- Already loaded
+                        -- The (src_imp == mi_boot iface) test checks that the already-loaded
+                        -- interface isn't a boot iface.  This can conceivably happen,
+                        -- if an earlier import had a before we got to real imports.   I think.
+            _ -> do {
+
+        -- READ THE MODULE IN
+        ; read_result <- case (wantHiBootFile dflags eps mod from) of
+                           Failed err             -> return (Failed err)
+                           Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod
+        ; case read_result of {
+            Failed err -> do
+                { let fake_iface = emptyModIface mod
+
+                ; updateEps_ $ \eps ->
+                        eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }
+                        -- Not found, so add an empty iface to
+                        -- the EPS map so that we don't look again
+
+                ; return (Failed err) } ;
+
+        -- Found and parsed!
+        -- We used to have a sanity check here that looked for:
+        --  * System importing ..
+        --  * a home package module ..
+        --  * that we know nothing about (mb_dep == Nothing)!
+        --
+        -- But this is no longer valid because thNameToGhcName allows users to
+        -- cause the system to load arbitrary interfaces (by supplying an appropriate
+        -- Template Haskell original-name).
+            Succeeded (iface, loc) ->
+        let
+            loc_doc = text loc
+        in
+        initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do
+
+        dontLeakTheHPT $ do
+
+        --      Load the new ModIface into the External Package State
+        -- Even home-package interfaces loaded by loadInterface
+        --      (which only happens in OneShot mode; in Batch/Interactive
+        --      mode, home-package modules are loaded one by one into the HPT)
+        -- are put in the EPS.
+        --
+        -- The main thing is to add the ModIface to the PIT, but
+        -- we also take the
+        --      IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules,
+        -- out of the ModIface and put them into the big EPS pools
+
+        -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined
+        ---    names is done correctly (notably, whether this is an .hi file or .hi-boot file).
+        --     If we do loadExport first the wrong info gets into the cache (unless we
+        --      explicitly tag each export which seems a bit of a bore)
+
+        ; ignore_prags      <- goptM Opt_IgnoreInterfacePragmas
+        ; new_eps_decls     <- loadDecls ignore_prags (mi_decls iface)
+        ; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)
+        ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
+        ; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)
+        ; new_eps_anns      <- tcIfaceAnnotations (mi_anns iface)
+        ; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
+
+        ; let { final_iface = iface {
+                                mi_decls     = panic "No mi_decls in PIT",
+                                mi_insts     = panic "No mi_insts in PIT",
+                                mi_fam_insts = panic "No mi_fam_insts in PIT",
+                                mi_rules     = panic "No mi_rules in PIT",
+                                mi_anns      = panic "No mi_anns in PIT"
+                              }
+               }
+
+        ; let bad_boot = mi_boot iface && fmap fst (if_rec_types gbl_env) == Just mod
+                            -- Warn warn against an EPS-updating import
+                            -- of one's own boot file! (one-shot only)
+                            -- See Note [Loading your own hi-boot file]
+                            -- in MkIface.
+
+        ; WARN( bad_boot, ppr mod )
+          updateEps_  $ \ eps ->
+           if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface
+                then eps
+           else if bad_boot
+                -- See Note [Loading your own hi-boot file]
+                then eps { eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls }
+           else
+                eps {
+                  eps_PIT          = extendModuleEnv (eps_PIT eps) mod final_iface,
+                  eps_PTE          = addDeclsToPTE   (eps_PTE eps) new_eps_decls,
+                  eps_rule_base    = extendRuleBaseList (eps_rule_base eps)
+                                                        new_eps_rules,
+                  eps_complete_matches
+                                   = extendCompleteMatchMap
+                                         (eps_complete_matches eps)
+                                         new_eps_complete_sigs,
+                  eps_inst_env     = extendInstEnvList (eps_inst_env eps)
+                                                       new_eps_insts,
+                  eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)
+                                                          new_eps_fam_insts,
+                  eps_ann_env      = extendAnnEnvList (eps_ann_env eps)
+                                                      new_eps_anns,
+                  eps_mod_fam_inst_env
+                                   = let
+                                       fam_inst_env =
+                                         extendFamInstEnvList emptyFamInstEnv
+                                                              new_eps_fam_insts
+                                     in
+                                     extendModuleEnv (eps_mod_fam_inst_env eps)
+                                                     mod
+                                                     fam_inst_env,
+                  eps_stats        = addEpsInStats (eps_stats eps)
+                                                   (length new_eps_decls)
+                                                   (length new_eps_insts)
+                                                   (length new_eps_rules) }
+
+        ; -- invoke plugins
+          res <- withPlugins dflags interfaceLoadAction final_iface
+        ; return (Succeeded res)
+    }}}}
+
+{- Note [Loading your own hi-boot file]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally speaking, when compiling module M, we should not
+load M.hi boot into the EPS.  After all, we are very shortly
+going to have full information about M.  Moreover, see
+Note [Do not update EPS with your own hi-boot] in MkIface.
+
+But there is a HORRIBLE HACK here.
+
+* At the end of tcRnImports, we call checkFamInstConsistency to
+  check consistency of imported type-family instances
+  See Note [The type family instance consistency story] in FamInst
+
+* Alas, those instances may refer to data types defined in M,
+  if there is a M.hs-boot.
+
+* And that means we end up loading M.hi-boot, because those
+  data types are not yet in the type environment.
+
+But in this wierd case, /all/ we need is the types. We don't need
+instances, rules etc.  And if we put the instances in the EPS
+we get "duplicate instance" warnings when we compile the "real"
+instance in M itself.  Hence the strange business of just updateing
+the eps_PTE.
+
+This really happens in practice.  The module HsExpr.hs gets
+"duplicate instance" errors if this hack is not present.
+
+This is a mess.
+
+
+Note [HPT space leak] (#15111)
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In IfL, we defer some work until it is demanded using forkM, such
+as building TyThings from IfaceDecls. These thunks are stored in
+the ExternalPackageState, and they might never be poked.  If we're
+not careful, these thunks will capture the state of the loaded
+program when we read an interface file, and retain all that data
+for ever.
+
+Therefore, when loading a package interface file , we use a "clean"
+version of the HscEnv with all the data about the currently loaded
+program stripped out. Most of the fields can be panics because
+we'll never read them, but hsc_HPT needs to be empty because this
+interface will cause other interfaces to be loaded recursively, and
+when looking up those interfaces we use the HPT in loadInterface.
+We know that none of the interfaces below here can refer to
+home-package modules however, so it's safe for the HPT to be empty.
+-}
+
+dontLeakTheHPT :: IfL a -> IfL a
+dontLeakTheHPT thing_inside = do
+  let
+    cleanTopEnv HscEnv{..} =
+       let
+         -- wrinkle: when we're typechecking in --backpack mode, the
+         -- instantiation of a signature might reside in the HPT, so
+         -- this case breaks the assumption that EPS interfaces only
+         -- refer to other EPS interfaces. We can detect when we're in
+         -- typechecking-only mode by using hscTarget==HscNothing, and
+         -- in that case we don't empty the HPT.  (admittedly this is
+         -- a bit of a hack, better suggestions welcome). A number of
+         -- tests in testsuite/tests/backpack break without this
+         -- tweak.
+         !hpt | hscTarget hsc_dflags == HscNothing = hsc_HPT
+              | otherwise = emptyHomePackageTable
+       in
+       HscEnv {  hsc_targets      = panic "cleanTopEnv: hsc_targets"
+              ,  hsc_mod_graph    = panic "cleanTopEnv: hsc_mod_graph"
+              ,  hsc_IC           = panic "cleanTopEnv: hsc_IC"
+              ,  hsc_HPT          = hpt
+              , .. }
+
+  updTopEnv cleanTopEnv $ do
+  !_ <- getTopEnv        -- force the updTopEnv
+  thing_inside
+
+
+-- | Returns @True@ if a 'ModIface' comes from an external package.
+-- In this case, we should NOT load it into the EPS; the entities
+-- should instead come from the local merged signature interface.
+is_external_sig :: DynFlags -> ModIface -> Bool
+is_external_sig dflags iface =
+    -- It's a signature iface...
+    mi_semantic_module iface /= mi_module iface &&
+    -- and it's not from the local package
+    moduleUnitId (mi_module iface) /= thisPackage dflags
+
+-- | This is an improved version of 'findAndReadIface' which can also
+-- handle the case when a user requests @p[A=<B>]:M@ but we only
+-- have an interface for @p[A=<A>]:M@ (the indefinite interface.
+-- If we are not trying to build code, we load the interface we have,
+-- *instantiating it* according to how the holes are specified.
+-- (Of course, if we're actually building code, this is a hard error.)
+--
+-- In the presence of holes, 'computeInterface' has an important invariant:
+-- to load module M, its set of transitively reachable requirements must
+-- have an up-to-date local hi file for that requirement.  Note that if
+-- we are loading the interface of a requirement, this does not
+-- apply to the requirement itself; e.g., @p[A=<A>]:A@ does not require
+-- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless
+-- we are actually typechecking p.)
+computeInterface ::
+       SDoc -> IsBootInterface -> Module
+    -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
+computeInterface doc_str hi_boot_file mod0 = do
+    MASSERT( not (isHoleModule mod0) )
+    dflags <- getDynFlags
+    case splitModuleInsts mod0 of
+        (imod, Just indef) | not (unitIdIsDefinite (thisPackage dflags)) -> do
+            r <- findAndReadIface doc_str imod mod0 hi_boot_file
+            case r of
+                Succeeded (iface0, path) -> do
+                    hsc_env <- getTopEnv
+                    r <- liftIO $
+                        rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef))
+                                   Nothing iface0
+                    case r of
+                        Right x -> return (Succeeded (x, path))
+                        Left errs -> liftIO . throwIO . mkSrcErr $ errs
+                Failed err -> return (Failed err)
+        (mod, _) ->
+            findAndReadIface doc_str mod mod0 hi_boot_file
+
+-- | Compute the signatures which must be compiled in order to
+-- load the interface for a 'Module'.  The output of this function
+-- is always a subset of 'moduleFreeHoles'; it is more precise
+-- because in signature @p[A=<A>,B=<B>]:B@, although the free holes
+-- are A and B, B might not depend on A at all!
+--
+-- If this is invoked on a signature, this does NOT include the
+-- signature itself; e.g. precise free module holes of
+-- @p[A=<A>,B=<B>]:B@ never includes B.
+moduleFreeHolesPrecise
+    :: SDoc -> Module
+    -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName))
+moduleFreeHolesPrecise doc_str mod
+ | moduleIsDefinite mod = return (Succeeded emptyUniqDSet)
+ | otherwise =
+   case splitModuleInsts mod of
+    (imod, Just indef) -> do
+        let insts = indefUnitIdInsts (indefModuleUnitId indef)
+        traceIf (text "Considering whether to load" <+> ppr mod <+>
+                 text "to compute precise free module holes")
+        (eps, hpt) <- getEpsAndHpt
+        dflags <- getDynFlags
+        case tryEpsAndHpt dflags eps hpt `firstJust` tryDepsCache eps imod insts of
+            Just r -> return (Succeeded r)
+            Nothing -> readAndCache imod insts
+    (_, Nothing) -> return (Succeeded emptyUniqDSet)
+  where
+    tryEpsAndHpt dflags eps hpt =
+        fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod)
+    tryDepsCache eps imod insts =
+        case lookupInstalledModuleEnv (eps_free_holes eps) imod of
+            Just ifhs  -> Just (renameFreeHoles ifhs insts)
+            _otherwise -> Nothing
+    readAndCache imod insts = do
+        mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod False
+        case mb_iface of
+            Succeeded (iface, _) -> do
+                let ifhs = mi_free_holes iface
+                -- Cache it
+                updateEps_ (\eps ->
+                    eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs })
+                return (Succeeded (renameFreeHoles ifhs insts))
+            Failed err -> return (Failed err)
+
+wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom
+               -> MaybeErr MsgDoc IsBootInterface
+-- Figure out whether we want Foo.hi or Foo.hi-boot
+wantHiBootFile dflags eps mod from
+  = case from of
+       ImportByUser usr_boot
+          | usr_boot && not this_package
+          -> Failed (badSourceImport mod)
+          | otherwise -> Succeeded usr_boot
+
+       ImportByPlugin
+          -> Succeeded False
+
+       ImportBySystem
+          | not this_package   -- If the module to be imported is not from this package
+          -> Succeeded False   -- don't look it up in eps_is_boot, because that is keyed
+                               -- on the ModuleName of *home-package* modules only.
+                               -- We never import boot modules from other packages!
+
+          | otherwise
+          -> case lookupUFM (eps_is_boot eps) (moduleName mod) of
+                Just (_, is_boot) -> Succeeded is_boot
+                Nothing           -> Succeeded False
+                     -- The boot-ness of the requested interface,
+                     -- based on the dependencies in directly-imported modules
+  where
+    this_package = thisPackage dflags == moduleUnitId mod
+
+badSourceImport :: Module -> SDoc
+badSourceImport mod
+  = hang (text "You cannot {-# SOURCE #-} import a module from another package")
+       2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package")
+          <+> quotes (ppr (moduleUnitId mod)))
+
+-----------------------------------------------------
+--      Loading type/class/value decls
+-- We pass the full Module name here, replete with
+-- its package info, so that we can build a Name for
+-- each binder with the right package info in it
+-- All subsequent lookups, including crucially lookups during typechecking
+-- the declaration itself, will find the fully-glorious Name
+--
+-- We handle ATs specially.  They are not main declarations, but also not
+-- implicit things (in particular, adding them to `implicitTyThings' would mess
+-- things up in the renaming/type checking of source programs).
+-----------------------------------------------------
+
+addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv
+addDeclsToPTE pte things = extendNameEnvList pte things
+
+loadDecls :: Bool
+          -> [(Fingerprint, IfaceDecl)]
+          -> IfL [(Name,TyThing)]
+loadDecls ignore_prags ver_decls
+   = do { thingss <- mapM (loadDecl ignore_prags) ver_decls
+        ; return (concat thingss)
+        }
+
+loadDecl :: Bool                    -- Don't load pragmas into the decl pool
+          -> (Fingerprint, IfaceDecl)
+          -> IfL [(Name,TyThing)]   -- The list can be poked eagerly, but the
+                                    -- TyThings are forkM'd thunks
+loadDecl ignore_prags (_version, decl)
+  = do  {       -- Populate the name cache with final versions of all
+                -- the names associated with the decl
+          let main_name = ifName decl
+
+        -- Typecheck the thing, lazily
+        -- NB. Firstly, the laziness is there in case we never need the
+        -- declaration (in one-shot mode), and secondly it is there so that
+        -- we don't look up the occurrence of a name before calling mk_new_bndr
+        -- on the binder.  This is important because we must get the right name
+        -- which includes its nameParent.
+
+        ; thing <- forkM doc $ do { bumpDeclStats main_name
+                                  ; tcIfaceDecl ignore_prags decl }
+
+        -- Populate the type environment with the implicitTyThings too.
+        --
+        -- Note [Tricky iface loop]
+        -- ~~~~~~~~~~~~~~~~~~~~~~~~
+        -- Summary: The delicate point here is that 'mini-env' must be
+        -- buildable from 'thing' without demanding any of the things
+        -- 'forkM'd by tcIfaceDecl.
+        --
+        -- In more detail: Consider the example
+        --      data T a = MkT { x :: T a }
+        -- The implicitTyThings of T are:  [ <datacon MkT>, <selector x>]
+        -- (plus their workers, wrappers, coercions etc etc)
+        --
+        -- We want to return an environment
+        --      [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ]
+        -- (where the "MkT" is the *Name* associated with MkT, etc.)
+        --
+        -- We do this by mapping the implicit_names to the associated
+        -- TyThings.  By the invariant on ifaceDeclImplicitBndrs and
+        -- implicitTyThings, we can use getOccName on the implicit
+        -- TyThings to make this association: each Name's OccName should
+        -- be the OccName of exactly one implicitTyThing.  So the key is
+        -- to define a "mini-env"
+        --
+        -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ]
+        -- where the 'MkT' here is the *OccName* associated with MkT.
+        --
+        -- However, there is a subtlety: due to how type checking needs
+        -- to be staged, we can't poke on the forkM'd thunks inside the
+        -- implicitTyThings while building this mini-env.
+        -- If we poke these thunks too early, two problems could happen:
+        --    (1) When processing mutually recursive modules across
+        --        hs-boot boundaries, poking too early will do the
+        --        type-checking before the recursive knot has been tied,
+        --        so things will be type-checked in the wrong
+        --        environment, and necessary variables won't be in
+        --        scope.
+        --
+        --    (2) Looking up one OccName in the mini_env will cause
+        --        others to be looked up, which might cause that
+        --        original one to be looked up again, and hence loop.
+        --
+        -- The code below works because of the following invariant:
+        -- getOccName on a TyThing does not force the suspended type
+        -- checks in order to extract the name. For example, we don't
+        -- poke on the "T a" type of <selector x> on the way to
+        -- extracting <selector x>'s OccName. Of course, there is no
+        -- reason in principle why getting the OccName should force the
+        -- thunks, but this means we need to be careful in
+        -- implicitTyThings and its helper functions.
+        --
+        -- All a bit too finely-balanced for my liking.
+
+        -- This mini-env and lookup function mediates between the
+        --'Name's n and the map from 'OccName's to the implicit TyThings
+        ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]
+              lookup n = case lookupOccEnv mini_env (getOccName n) of
+                           Just thing -> thing
+                           Nothing    ->
+                             pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))
+
+        ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl)
+
+--         ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names)
+        ; return $ (main_name, thing) :
+                      -- uses the invariant that implicit_names and
+                      -- implicitTyThings are bijective
+                      [(n, lookup n) | n <- implicit_names]
+        }
+  where
+    doc = text "Declaration for" <+> ppr (ifName decl)
+
+bumpDeclStats :: Name -> IfL ()         -- Record that one more declaration has actually been used
+bumpDeclStats name
+  = do  { traceIf (text "Loading decl for" <+> ppr name)
+        ; updateEps_ (\eps -> let stats = eps_stats eps
+                              in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })
+        }
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Reading an interface file}
+*                                                      *
+*********************************************************
+
+Note [Home module load error]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the sought-for interface is in the current package (as determined
+by -package-name flag) then it jolly well should already be in the HPT
+because we process home-package modules in dependency order.  (Except
+in one-shot mode; see notes with hsc_HPT decl in HscTypes).
+
+It is possible (though hard) to get this error through user behaviour.
+  * Suppose package P (modules P1, P2) depends on package Q (modules Q1,
+    Q2, with Q2 importing Q1)
+  * We compile both packages.
+  * Now we edit package Q so that it somehow depends on P
+  * Now recompile Q with --make (without recompiling P).
+  * Then Q1 imports, say, P1, which in turn depends on Q2. So Q2
+    is a home-package module which is not yet in the HPT!  Disaster.
+
+This actually happened with P=base, Q=ghc-prim, via the AMP warnings.
+See Trac #8320.
+-}
+
+findAndReadIface :: SDoc
+                 -- The unique identifier of the on-disk module we're
+                 -- looking for
+                 -> InstalledModule
+                 -- The *actual* module we're looking for.  We use
+                 -- this to check the consistency of the requirements
+                 -- of the module we read out.
+                 -> Module
+                 -> IsBootInterface     -- True  <=> Look for a .hi-boot file
+                                        -- False <=> Look for .hi file
+                 -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))
+        -- Nothing <=> file not found, or unreadable, or illegible
+        -- Just x  <=> successfully found and parsed
+
+        -- It *doesn't* add an error to the monad, because
+        -- sometimes it's ok to fail... see notes with loadInterface
+findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file
+  = do traceIf (sep [hsep [text "Reading",
+                           if hi_boot_file
+                             then text "[boot]"
+                             else Outputable.empty,
+                           text "interface for",
+                           ppr mod <> semi],
+                     nest 4 (text "reason:" <+> doc_str)])
+
+       -- Check for GHC.Prim, and return its static interface
+       -- TODO: make this check a function
+       if mod `installedModuleEq` gHC_PRIM
+           then do
+               iface <- getHooked ghcPrimIfaceHook ghcPrimIface
+               return (Succeeded (iface,
+                                   "<built in interface for GHC.Prim>"))
+           else do
+               dflags <- getDynFlags
+               -- Look for the file
+               hsc_env <- getTopEnv
+               mb_found <- liftIO (findExactModule hsc_env mod)
+               case mb_found of
+                   InstalledFound loc mod -> do
+                       -- Found file, so read it
+                       let file_path = addBootSuffix_maybe hi_boot_file
+                                                           (ml_hi_file loc)
+
+                       -- See Note [Home module load error]
+                       if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags &&
+                          not (isOneShot (ghcMode dflags))
+                           then return (Failed (homeModError mod loc))
+                           else do r <- read_file file_path
+                                   checkBuildDynamicToo r
+                                   return r
+                   err -> do
+                       traceIf (text "...not found")
+                       dflags <- getDynFlags
+                       return (Failed (cannotFindInterface dflags
+                                           (installedModuleName mod) err))
+    where read_file file_path = do
+              traceIf (text "readIFace" <+> text file_path)
+              -- Figure out what is recorded in mi_module.  If this is
+              -- a fully definite interface, it'll match exactly, but
+              -- if it's indefinite, the inside will be uninstantiated!
+              dflags <- getDynFlags
+              let wanted_mod =
+                    case splitModuleInsts wanted_mod_with_insts of
+                        (_, Nothing) -> wanted_mod_with_insts
+                        (_, Just indef_mod) ->
+                          indefModuleToModule dflags
+                            (generalizeIndefModule indef_mod)
+              read_result <- readIface wanted_mod file_path
+              case read_result of
+                Failed err -> return (Failed (badIfaceFile file_path err))
+                Succeeded iface -> return (Succeeded (iface, file_path))
+                            -- Don't forget to fill in the package name...
+          checkBuildDynamicToo (Succeeded (iface, filePath)) = do
+              dflags <- getDynFlags
+              -- Indefinite interfaces are ALWAYS non-dynamic, and
+              -- that's OK.
+              let is_definite_iface = moduleIsDefinite (mi_module iface)
+              when is_definite_iface $
+                whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do
+                  let ref = canGenerateDynamicToo dflags
+                      dynFilePath = addBootSuffix_maybe hi_boot_file
+                                  $ replaceExtension filePath (dynHiSuf dflags)
+                  r <- read_file dynFilePath
+                  case r of
+                      Succeeded (dynIface, _)
+                       | mi_mod_hash iface == mi_mod_hash dynIface ->
+                          return ()
+                       | otherwise ->
+                          do traceIf (text "Dynamic hash doesn't match")
+                             liftIO $ writeIORef ref False
+                      Failed err ->
+                          do traceIf (text "Failed to load dynamic interface file:" $$ err)
+                             liftIO $ writeIORef ref False
+          checkBuildDynamicToo _ = return ()
+
+-- @readIface@ tries just the one file.
+
+readIface :: Module -> FilePath
+          -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)
+        -- Failed err    <=> file not found, or unreadable, or illegible
+        -- Succeeded iface <=> successfully found and parsed
+
+readIface wanted_mod file_path
+  = do  { res <- tryMostM $
+                 readBinIface CheckHiWay QuietBinIFaceReading file_path
+        ; dflags <- getDynFlags
+        ; case res of
+            Right iface
+                -- NB: This check is NOT just a sanity check, it is
+                -- critical for correctness of recompilation checking
+                -- (it lets us tell when -this-unit-id has changed.)
+                | wanted_mod == actual_mod
+                                -> return (Succeeded iface)
+                | otherwise     -> return (Failed err)
+                where
+                  actual_mod = mi_module iface
+                  err = hiModuleNameMismatchWarn dflags wanted_mod actual_mod
+
+            Left exn    -> return (Failed (text (showException exn)))
+    }
+
+{-
+*********************************************************
+*                                                       *
+        Wired-in interface for GHC.Prim
+*                                                       *
+*********************************************************
+-}
+
+initExternalPackageState :: ExternalPackageState
+initExternalPackageState
+  = EPS {
+      eps_is_boot          = emptyUFM,
+      eps_PIT              = emptyPackageIfaceTable,
+      eps_free_holes       = emptyInstalledModuleEnv,
+      eps_PTE              = emptyTypeEnv,
+      eps_inst_env         = emptyInstEnv,
+      eps_fam_inst_env     = emptyFamInstEnv,
+      eps_rule_base        = mkRuleBase builtinRules,
+        -- Initialise the EPS rule pool with the built-in rules
+      eps_mod_fam_inst_env
+                           = emptyModuleEnv,
+      eps_complete_matches = emptyUFM,
+      eps_ann_env          = emptyAnnEnv,
+      eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0
+                           , n_insts_in = 0, n_insts_out = 0
+                           , n_rules_in = length builtinRules, n_rules_out = 0 }
+    }
+
+{-
+*********************************************************
+*                                                       *
+        Wired-in interface for GHC.Prim
+*                                                       *
+*********************************************************
+-}
+
+ghcPrimIface :: ModIface
+ghcPrimIface
+  = (emptyModIface gHC_PRIM) {
+        mi_exports  = ghcPrimExports,
+        mi_decls    = [],
+        mi_fixities = fixities,
+        mi_fix_fn  = mkIfaceFixCache fixities
+    }
+  where
+    -- The fixities listed here for @`seq`@ or @->@ should match
+    -- those in primops.txt.pp (from which Haddock docs are generated).
+    fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)
+             : (occName funTyConName, funTyFixity)  -- trac #10145
+             : mapMaybe mkFixity allThePrimOps
+    mkFixity op = (,) (primOpOcc op) <$> primOpFixity op
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Statistics}
+*                                                      *
+*********************************************************
+-}
+
+ifaceStats :: ExternalPackageState -> SDoc
+ifaceStats eps
+  = hcat [text "Renamer stats: ", msg]
+  where
+    stats = eps_stats eps
+    msg = vcat
+        [int (n_ifaces_in stats) <+> text "interfaces read",
+         hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",
+                int (n_decls_in stats), text "read"],
+         hsep [ int (n_insts_out stats), text "instance decls imported, out of",
+                int (n_insts_in stats), text "read"],
+         hsep [ int (n_rules_out stats), text "rule decls imported, out of",
+                int (n_rules_in stats), text "read"]
+        ]
+
+{-
+************************************************************************
+*                                                                      *
+                Printing interfaces
+*                                                                      *
+************************************************************************
+
+Note [Name qualification with --show-iface]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In order to disambiguate between identifiers from different modules, we qualify
+all names that don't originate in the current module. In order to keep visual
+noise as low as possible, we keep local names unqualified.
+
+For some background on this choice see trac #15269.
+-}
+
+-- | Read binary interface, and print it out
+showIface :: HscEnv -> FilePath -> IO ()
+showIface hsc_env filename = do
+   -- skip the hi way check; we don't want to worry about profiled vs.
+   -- non-profiled interfaces, for example.
+   iface <- initTcRnIf 's' hsc_env () () $
+       readBinIface IgnoreHiWay TraceBinIFaceReading filename
+   let dflags = hsc_dflags hsc_env
+       -- See Note [Name qualification with --show-iface]
+       qualifyImportedNames mod _
+           | mod == mi_module iface = NameUnqual
+           | otherwise              = NameNotInScope1
+       print_unqual = QueryQualify qualifyImportedNames
+                                   neverQualifyModules
+                                   neverQualifyPackages
+   putLogMsg dflags NoReason SevDump noSrcSpan
+      (mkDumpStyle dflags print_unqual) (pprModIface iface)
+
+-- Show a ModIface but don't display details; suitable for ModIfaces stored in
+-- the EPT.
+pprModIfaceSimple :: ModIface -> SDoc
+pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface)))
+
+pprModIface :: ModIface -> SDoc
+-- Show a ModIface
+pprModIface iface
+ = vcat [ text "interface"
+                <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface)
+                <+> (if mi_orphan iface then text "[orphan module]" else Outputable.empty)
+                <+> (if mi_finsts iface then text "[family instance module]" else Outputable.empty)
+                <+> (if mi_hpc    iface then text "[hpc]" else Outputable.empty)
+                <+> integer hiVersion
+        , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface))
+        , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))
+        , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))
+        , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))
+        , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface))
+        , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash iface))
+        , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash iface))
+        , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash iface))
+        , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))
+        , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))
+        , nest 2 (text "where")
+        , text "exports:"
+        , nest 2 (vcat (map pprExport (mi_exports iface)))
+        , pprDeps (mi_deps iface)
+        , vcat (map pprUsage (mi_usages iface))
+        , vcat (map pprIfaceAnnotation (mi_anns iface))
+        , pprFixities (mi_fixities iface)
+        , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface]
+        , vcat (map ppr (mi_insts iface))
+        , vcat (map ppr (mi_fam_insts iface))
+        , vcat (map ppr (mi_rules iface))
+        , ppr (mi_warns iface)
+        , pprTrustInfo (mi_trust iface)
+        , pprTrustPkg (mi_trust_pkg iface)
+        , vcat (map ppr (mi_complete_sigs iface))
+        , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))
+        , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))
+        , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))
+        ]
+  where
+    pp_hsc_src HsBootFile = text "[boot]"
+    pp_hsc_src HsigFile = text "[hsig]"
+    pp_hsc_src HsSrcFile = Outputable.empty
+
+{-
+When printing export lists, we print like this:
+        Avail   f               f
+        AvailTC C [C, x, y]     C(x,y)
+        AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C
+-}
+
+pprExport :: IfaceExport -> SDoc
+pprExport (Avail n)         = ppr n
+pprExport (AvailTC _ [] []) = Outputable.empty
+pprExport (AvailTC n ns0 fs)
+  = case ns0 of
+      (n':ns) | n==n' -> ppr n <> pp_export ns fs
+      _               -> ppr n <> vbar <> pp_export ns0 fs
+  where
+    pp_export []    [] = Outputable.empty
+    pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs))
+
+pprUsage :: Usage -> SDoc
+pprUsage usage@UsagePackageModule{}
+  = pprUsageImport usage usg_mod
+pprUsage usage@UsageHomeModule{}
+  = pprUsageImport usage usg_mod_name $$
+    nest 2 (
+        maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
+        vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
+        )
+pprUsage usage@UsageFile{}
+  = hsep [text "addDependentFile",
+          doubleQuotes (text (usg_file_path usage)),
+          ppr (usg_file_hash usage)]
+pprUsage usage@UsageMergedRequirement{}
+  = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
+
+pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc
+pprUsageImport usage usg_mod'
+  = hsep [text "import", safe, ppr (usg_mod' usage),
+                       ppr (usg_mod_hash usage)]
+    where
+        safe | usg_safe usage = text "safe"
+             | otherwise      = text " -/ "
+
+pprDeps :: Dependencies -> SDoc
+pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
+                dep_finsts = finsts })
+  = vcat [text "module dependencies:" <+> fsep (map ppr_mod mods),
+          text "package dependencies:" <+> fsep (map ppr_pkg pkgs),
+          text "orphans:" <+> fsep (map ppr orphs),
+          text "family instance modules:" <+> fsep (map ppr finsts)
+        ]
+  where
+    ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
+    ppr_pkg (pkg,trust_req)  = ppr pkg <>
+                               (if trust_req then text "*" else Outputable.empty)
+    ppr_boot True  = text "[boot]"
+    ppr_boot False = Outputable.empty
+
+pprFixities :: [(OccName, Fixity)] -> SDoc
+pprFixities []    = Outputable.empty
+pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes
+                  where
+                    pprFix (occ,fix) = ppr fix <+> ppr occ
+
+pprTrustInfo :: IfaceTrustInfo -> SDoc
+pprTrustInfo trust = text "trusted:" <+> ppr trust
+
+pprTrustPkg :: Bool -> SDoc
+pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg
+
+instance Outputable Warnings where
+    ppr = pprWarns
+
+pprWarns :: Warnings -> SDoc
+pprWarns NoWarnings         = Outputable.empty
+pprWarns (WarnAll txt)  = text "Warn all" <+> ppr txt
+pprWarns (WarnSome prs) = text "Warnings"
+                        <+> vcat (map pprWarning prs)
+    where pprWarning (name, txt) = ppr name <+> ppr txt
+
+pprIfaceAnnotation :: IfaceAnnotation -> SDoc
+pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })
+  = ppr target <+> text "annotated by" <+> ppr serialized
+
+{-
+*********************************************************
+*                                                       *
+\subsection{Errors}
+*                                                       *
+*********************************************************
+-}
+
+badIfaceFile :: String -> SDoc -> SDoc
+badIfaceFile file err
+  = vcat [text "Bad interface file:" <+> text file,
+          nest 4 err]
+
+hiModuleNameMismatchWarn :: DynFlags -> Module -> Module -> MsgDoc
+hiModuleNameMismatchWarn dflags requested_mod read_mod
+ | moduleUnitId requested_mod == moduleUnitId read_mod =
+    sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,
+         text "but we were expecting module" <+> quotes (ppr requested_mod),
+         sep [text "Probable cause: the source code which generated interface file",
+             text "has an incompatible module name"
+            ]
+        ]
+ | otherwise =
+  -- ToDo: This will fail to have enough qualification when the package IDs
+  -- are the same
+  withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $
+    -- we want the Modules below to be qualified with package names,
+    -- so reset the PrintUnqualified setting.
+    hsep [ text "Something is amiss; requested module "
+         , ppr requested_mod
+         , text "differs from name found in the interface file"
+         , ppr read_mod
+         , parens (text "if these names look the same, try again with -dppr-debug")
+         ]
+
+homeModError :: InstalledModule -> ModLocation -> SDoc
+-- See Note [Home module load error]
+homeModError mod location
+  = text "attempting to use module " <> quotes (ppr mod)
+    <> (case ml_hs_file location of
+           Just file -> space <> parens (text file)
+           Nothing   -> Outputable.empty)
+    <+> text "which is not loaded"
diff --git a/compiler/iface/LoadIface.hs-boot b/compiler/iface/LoadIface.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/iface/LoadIface.hs-boot
@@ -0,0 +1,7 @@
+module LoadIface where
+import Module (Module)
+import TcRnMonad (IfM)
+import HscTypes (ModIface)
+import Outputable (SDoc)
+
+loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
new file mode 100644
--- /dev/null
+++ b/compiler/iface/MkIface.hs
@@ -0,0 +1,2034 @@
+{-
+(c) The University of Glasgow 2006-2008
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+-}
+
+{-# LANGUAGE CPP, NondecreasingIndentation #-}
+{-# LANGUAGE MultiWayIf #-}
+
+-- | Module for constructing @ModIface@ values (interface files),
+-- writing them to disk and comparing two versions to see if
+-- recompilation is required.
+module MkIface (
+        mkIface,        -- Build a ModIface from a ModGuts,
+                        -- including computing version information
+
+        mkIfaceTc,
+
+        writeIfaceFile, -- Write the interface file
+
+        checkOldIface,  -- See if recompilation is required, by
+                        -- comparing version information
+        RecompileRequired(..), recompileRequired,
+        mkIfaceExports,
+
+        coAxiomToIfaceDecl,
+        tyThingToIfaceDecl -- Converting things to their Iface equivalents
+ ) where
+
+{-
+  -----------------------------------------------
+          Recompilation checking
+  -----------------------------------------------
+
+A complete description of how recompilation checking works can be
+found in the wiki commentary:
+
+ http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
+
+Please read the above page for a top-down description of how this all
+works.  Notes below cover specific issues related to the implementation.
+
+Basic idea:
+
+  * In the mi_usages information in an interface, we record the
+    fingerprint of each free variable of the module
+
+  * In mkIface, we compute the fingerprint of each exported thing A.f.
+    For each external thing that A.f refers to, we include the fingerprint
+    of the external reference when computing the fingerprint of A.f.  So
+    if anything that A.f depends on changes, then A.f's fingerprint will
+    change.
+    Also record any dependent files added with
+      * addDependentFile
+      * #include
+      * -optP-include
+
+  * In checkOldIface we compare the mi_usages for the module with
+    the actual fingerprint for all each thing recorded in mi_usages
+-}
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import IfaceSyn
+import BinFingerprint
+import LoadIface
+import ToIface
+import FlagChecker
+
+import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies )
+import Id
+import Annotations
+import CoreSyn
+import Class
+import TyCon
+import CoAxiom
+import ConLike
+import DataCon
+import Type
+import TcType
+import InstEnv
+import FamInstEnv
+import TcRnMonad
+import HsSyn
+import HscTypes
+import Finder
+import DynFlags
+import VarEnv
+import Var
+import Name
+import Avail
+import RdrName
+import NameEnv
+import NameSet
+import Module
+import BinIface
+import ErrUtils
+import Digraph
+import SrcLoc
+import Outputable
+import BasicTypes       hiding ( SuccessFlag(..) )
+import Unique
+import Util             hiding ( eqListBy )
+import FastString
+import Maybes
+import Binary
+import Fingerprint
+import Exception
+import UniqSet
+import Packages
+import ExtractDocs
+
+import Control.Monad
+import Data.Function
+import Data.List
+import qualified Data.Map as Map
+import Data.Ord
+import Data.IORef
+import System.Directory
+import System.FilePath
+import Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..),
+                 pluginRecompile', plugins )
+
+--Qualified import so we can define a Semigroup instance
+-- but it doesn't clash with Outputable.<>
+import qualified Data.Semigroup
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Completing an interface}
+*                                                                      *
+************************************************************************
+-}
+
+mkIface :: HscEnv
+        -> Maybe Fingerprint    -- The old fingerprint, if we have it
+        -> ModDetails           -- The trimmed, tidied interface
+        -> ModGuts              -- Usages, deprecations, etc
+        -> IO (ModIface, -- The new one
+               Bool)     -- True <=> there was an old Iface, and the
+                         --          new one is identical, so no need
+                         --          to write it
+
+mkIface hsc_env maybe_old_fingerprint mod_details
+         ModGuts{     mg_module       = this_mod,
+                      mg_hsc_src      = hsc_src,
+                      mg_usages       = usages,
+                      mg_used_th      = used_th,
+                      mg_deps         = deps,
+                      mg_rdr_env      = rdr_env,
+                      mg_fix_env      = fix_env,
+                      mg_warns        = warns,
+                      mg_hpc_info     = hpc_info,
+                      mg_safe_haskell = safe_mode,
+                      mg_trust_pkg    = self_trust,
+                      mg_doc_hdr      = doc_hdr,
+                      mg_decl_docs    = decl_docs,
+                      mg_arg_docs     = arg_docs
+                    }
+        = mkIface_ hsc_env maybe_old_fingerprint
+                   this_mod hsc_src used_th deps rdr_env fix_env
+                   warns hpc_info self_trust
+                   safe_mode usages
+                   doc_hdr decl_docs arg_docs
+                   mod_details
+
+-- | make an interface from the results of typechecking only.  Useful
+-- for non-optimising compilation, or where we aren't generating any
+-- object code at all ('HscNothing').
+mkIfaceTc :: HscEnv
+          -> Maybe Fingerprint  -- The old fingerprint, if we have it
+          -> SafeHaskellMode    -- The safe haskell mode
+          -> ModDetails         -- gotten from mkBootModDetails, probably
+          -> TcGblEnv           -- Usages, deprecations, etc
+          -> IO (ModIface, Bool)
+mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
+  tc_result@TcGblEnv{ tcg_mod = this_mod,
+                      tcg_src = hsc_src,
+                      tcg_imports = imports,
+                      tcg_rdr_env = rdr_env,
+                      tcg_fix_env = fix_env,
+                      tcg_merged = merged,
+                      tcg_warns = warns,
+                      tcg_hpc = other_hpc_info,
+                      tcg_th_splice_used = tc_splice_used,
+                      tcg_dependent_files = dependent_files
+                    }
+  = do
+          let used_names = mkUsedNames tc_result
+          let pluginModules =
+                map lpModule (cachedPlugins (hsc_dflags hsc_env))
+          deps <- mkDependencies
+                    (thisInstalledUnitId (hsc_dflags hsc_env))
+                    (map mi_module pluginModules) tc_result
+          let hpc_info = emptyHpcInfo other_hpc_info
+          used_th <- readIORef tc_splice_used
+          dep_files <- (readIORef dependent_files)
+          -- Do NOT use semantic module here; this_mod in mkUsageInfo
+          -- is used solely to decide if we should record a dependency
+          -- or not.  When we instantiate a signature, the semantic
+          -- module is something we want to record dependencies for,
+          -- but if you pass that in here, we'll decide it's the local
+          -- module and does not need to be recorded as a dependency.
+          -- See Note [Identity versus semantic module]
+          usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names
+                      dep_files merged pluginModules
+
+          let (doc_hdr', doc_map, arg_map) = extractDocs tc_result
+
+          mkIface_ hsc_env maybe_old_fingerprint
+                   this_mod hsc_src
+                   used_th deps rdr_env
+                   fix_env warns hpc_info
+                   (imp_trust_own_pkg imports) safe_mode usages
+                   doc_hdr' doc_map arg_map
+                   mod_details
+
+
+
+mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource
+         -> Bool -> Dependencies -> GlobalRdrEnv
+         -> NameEnv FixItem -> Warnings -> HpcInfo
+         -> Bool
+         -> SafeHaskellMode
+         -> [Usage]
+         -> Maybe HsDocString
+         -> DeclDocMap
+         -> ArgDocMap
+         -> ModDetails
+         -> IO (ModIface, Bool)
+mkIface_ hsc_env maybe_old_fingerprint
+         this_mod hsc_src used_th deps rdr_env fix_env src_warns
+         hpc_info pkg_trust_req safe_mode usages
+         doc_hdr decl_docs arg_docs
+         ModDetails{  md_insts     = insts,
+                      md_fam_insts = fam_insts,
+                      md_rules     = rules,
+                      md_anns      = anns,
+                      md_types     = type_env,
+                      md_exports   = exports,
+                      md_complete_sigs = complete_sigs }
+-- NB:  notice that mkIface does not look at the bindings
+--      only at the TypeEnv.  The previous Tidy phase has
+--      put exactly the info into the TypeEnv that we want
+--      to expose in the interface
+
+  = do
+    let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)
+        entities = typeEnvElts type_env
+        decls  = [ tyThingToIfaceDecl entity
+                 | entity <- entities,
+                   let name = getName entity,
+                   not (isImplicitTyThing entity),
+                      -- No implicit Ids and class tycons in the interface file
+                   not (isWiredInName name),
+                      -- Nor wired-in things; the compiler knows about them anyhow
+                   nameIsLocalOrFrom semantic_mod name  ]
+                      -- Sigh: see Note [Root-main Id] in TcRnDriver
+                      -- NB: ABSOLUTELY need to check against semantic_mod,
+                      -- because all of the names in an hsig p[H=<H>]:H
+                      -- are going to be for <H>, not the former id!
+                      -- See Note [Identity versus semantic module]
+
+        fixities    = sortBy (comparing fst)
+          [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
+          -- The order of fixities returned from nameEnvElts is not
+          -- deterministic, so we sort by OccName to canonicalize it.
+          -- See Note [Deterministic UniqFM] in UniqDFM for more details.
+        warns       = src_warns
+        iface_rules = map coreRuleToIfaceRule rules
+        iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts
+        iface_fam_insts = map famInstToIfaceFamInst fam_insts
+        trust_info  = setSafeMode safe_mode
+        annotations = map mkIfaceAnnotation anns
+        icomplete_sigs = map mkIfaceCompleteSig complete_sigs
+
+        intermediate_iface = ModIface {
+              mi_module      = this_mod,
+              -- Need to record this because it depends on the -instantiated-with flag
+              -- which could change
+              mi_sig_of      = if semantic_mod == this_mod
+                                then Nothing
+                                else Just semantic_mod,
+              mi_hsc_src     = hsc_src,
+              mi_deps        = deps,
+              mi_usages      = usages,
+              mi_exports     = mkIfaceExports exports,
+
+              -- Sort these lexicographically, so that
+              -- the result is stable across compilations
+              mi_insts       = sortBy cmp_inst     iface_insts,
+              mi_fam_insts   = sortBy cmp_fam_inst iface_fam_insts,
+              mi_rules       = sortBy cmp_rule     iface_rules,
+
+              mi_fixities    = fixities,
+              mi_warns       = warns,
+              mi_anns        = annotations,
+              mi_globals     = maybeGlobalRdrEnv rdr_env,
+
+              -- Left out deliberately: filled in by addFingerprints
+              mi_iface_hash  = fingerprint0,
+              mi_mod_hash    = fingerprint0,
+              mi_flag_hash   = fingerprint0,
+              mi_opt_hash    = fingerprint0,
+              mi_hpc_hash    = fingerprint0,
+              mi_exp_hash    = fingerprint0,
+              mi_plugin_hash = fingerprint0,
+              mi_used_th     = used_th,
+              mi_orphan_hash = fingerprint0,
+              mi_orphan      = False, -- Always set by addFingerprints, but
+                                      -- it's a strict field, so we can't omit it.
+              mi_finsts      = False, -- Ditto
+              mi_decls       = deliberatelyOmitted "decls",
+              mi_hash_fn     = deliberatelyOmitted "hash_fn",
+              mi_hpc         = isHpcUsed hpc_info,
+              mi_trust       = trust_info,
+              mi_trust_pkg   = pkg_trust_req,
+
+              -- And build the cached values
+              mi_warn_fn     = mkIfaceWarnCache warns,
+              mi_fix_fn      = mkIfaceFixCache fixities,
+              mi_complete_sigs = icomplete_sigs,
+              mi_doc_hdr     = doc_hdr,
+              mi_decl_docs   = decl_docs,
+              mi_arg_docs    = arg_docs }
+
+    (new_iface, no_change_at_all)
+          <- {-# SCC "versioninfo" #-}
+                   addFingerprints hsc_env maybe_old_fingerprint
+                                   intermediate_iface decls
+
+    -- Debug printing
+    dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"
+                  (pprModIface new_iface)
+
+    -- bug #1617: on reload we weren't updating the PrintUnqualified
+    -- correctly.  This stems from the fact that the interface had
+    -- not changed, so addFingerprints returns the old ModIface
+    -- with the old GlobalRdrEnv (mi_globals).
+    let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }
+
+    return (final_iface, no_change_at_all)
+  where
+     cmp_rule     = comparing ifRuleName
+     -- Compare these lexicographically by OccName, *not* by unique,
+     -- because the latter is not stable across compilations:
+     cmp_inst     = comparing (nameOccName . ifDFun)
+     cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)
+
+     dflags = hsc_dflags hsc_env
+
+     -- We only fill in mi_globals if the module was compiled to byte
+     -- code.  Otherwise, the compiler may not have retained all the
+     -- top-level bindings and they won't be in the TypeEnv (see
+     -- Desugar.addExportFlagsAndRules).  The mi_globals field is used
+     -- by GHCi to decide whether the module has its full top-level
+     -- scope available. (#5534)
+     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv
+     maybeGlobalRdrEnv rdr_env
+         | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env
+         | otherwise                                   = Nothing
+
+     deliberatelyOmitted :: String -> a
+     deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
+
+     ifFamInstTcName = ifFamInstFam
+
+-----------------------------
+writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()
+writeIfaceFile dflags hi_file_path new_iface
+    = do createDirectoryIfMissing True (takeDirectory hi_file_path)
+         writeBinIface dflags hi_file_path new_iface
+
+
+-- -----------------------------------------------------------------------------
+-- Look up parents and versions of Names
+
+-- This is like a global version of the mi_hash_fn field in each ModIface.
+-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get
+-- the parent and version info.
+
+mkHashFun
+        :: HscEnv                       -- needed to look up versions
+        -> ExternalPackageState         -- ditto
+        -> (Name -> IO Fingerprint)
+mkHashFun hsc_env eps name
+  | isHoleModule orig_mod
+  = lookup (mkModule (thisPackage dflags) (moduleName orig_mod))
+  | otherwise
+  = lookup orig_mod
+  where
+      dflags = hsc_dflags hsc_env
+      hpt = hsc_HPT hsc_env
+      pit = eps_PIT eps
+      occ = nameOccName name
+      orig_mod = nameModule name
+      lookup mod = do
+        MASSERT2( isExternalName name, ppr name )
+        iface <- case lookupIfaceByModule dflags hpt pit mod of
+                  Just iface -> return iface
+                  Nothing -> do
+                      -- This can occur when we're writing out ifaces for
+                      -- requirements; we didn't do any /real/ typechecking
+                      -- so there's no guarantee everything is loaded.
+                      -- Kind of a heinous hack.
+                      iface <- initIfaceLoad hsc_env . withException
+                            $ loadInterface (text "lookupVers2") mod ImportBySystem
+                      return iface
+        return $ snd (mi_hash_fn iface occ `orElse`
+                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))
+
+-- ---------------------------------------------------------------------------
+-- Compute fingerprints for the interface
+
+{-
+Note [Fingerprinting IfaceDecls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The general idea here is that we first examine the 'IfaceDecl's and determine
+the recursive groups of them. We then walk these groups in dependency order,
+serializing each contained 'IfaceDecl' to a "Binary" buffer which we then
+hash using MD5 to produce a fingerprint for the group.
+
+However, the serialization that we use is a bit funny: we override the @putName@
+operation with our own which serializes the hash of a 'Name' instead of the
+'Name' itself. This ensures that the fingerprint of a decl changes if anything
+in its transitive closure changes. This trick is why we must be careful about
+traversing in dependency order: we need to ensure that we have hashes for
+everything referenced by the decl which we are fingerprinting.
+
+Moreover, we need to be careful to distinguish between serialization of binding
+Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls
+field of a IfaceClsInst): only in the non-binding case should we include the
+fingerprint; in the binding case we shouldn't since it is merely the name of the
+thing that we are currently fingerprinting.
+-}
+
+-- | Add fingerprints for top-level declarations to a 'ModIface'.
+--
+-- See Note [Fingerprinting IfaceDecls]
+addFingerprints
+        :: HscEnv
+        -> Maybe Fingerprint -- the old fingerprint, if any
+        -> ModIface          -- The new interface (lacking decls)
+        -> [IfaceDecl]       -- The new decls
+        -> IO (ModIface,     -- Updated interface
+               Bool)         -- True <=> no changes at all;
+                             -- no need to write Iface
+
+addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
+ = do
+   eps <- hscEPS hsc_env
+   let
+        -- The ABI of a declaration represents everything that is made
+        -- visible about the declaration that a client can depend on.
+        -- see IfaceDeclABI below.
+       declABI :: IfaceDecl -> IfaceDeclABI
+       -- TODO: I'm not sure if this should be semantic_mod or this_mod.
+       -- See also Note [Identity versus semantic module]
+       declABI decl = (this_mod, decl, extras)
+        where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts
+                                  non_orph_fis top_lvl_name_env decl
+
+       -- This is used for looking up the Name of a default method
+       -- from its OccName. See Note [default method Name]
+       top_lvl_name_env =
+         mkOccEnv [ (nameOccName nm, nm)
+                  | IfaceId { ifName = nm } <- new_decls ]
+
+       -- Dependency edges between declarations in the current module.
+       -- This is computed by finding the free external names of each
+       -- declaration, including IfaceDeclExtras (things that a
+       -- declaration implicitly depends on).
+       edges :: [ Node Unique IfaceDeclABI ]
+       edges = [ DigraphNode abi (getUnique (getOccName decl)) out
+               | decl <- new_decls
+               , let abi = declABI decl
+               , let out = localOccs $ freeNamesDeclABI abi
+               ]
+
+       name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n
+       localOccs =
+         map (getUnique . getParent . getOccName)
+                        -- NB: names always use semantic module, so
+                        -- filtering must be on the semantic module!
+                        -- See Note [Identity versus semantic module]
+                        . filter ((== semantic_mod) . name_module)
+                        . nonDetEltsUniqSet
+                   -- It's OK to use nonDetEltsUFM as localOccs is only
+                   -- used to construct the edges and
+                   -- stronglyConnCompFromEdgedVertices is deterministic
+                   -- even with non-deterministic order of edges as
+                   -- explained in Note [Deterministic SCC] in Digraph.
+          where getParent :: OccName -> OccName
+                getParent occ = lookupOccEnv parent_map occ `orElse` occ
+
+        -- maps OccNames to their parents in the current module.
+        -- e.g. a reference to a constructor must be turned into a reference
+        -- to the TyCon for the purposes of calculating dependencies.
+       parent_map :: OccEnv OccName
+       parent_map = foldl' extend emptyOccEnv new_decls
+          where extend env d =
+                  extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]
+                  where n = getOccName d
+
+        -- Strongly-connected groups of declarations, in dependency order
+       groups :: [SCC IfaceDeclABI]
+       groups = stronglyConnCompFromEdgedVerticesUniq edges
+
+       global_hash_fn = mkHashFun hsc_env eps
+
+        -- How to output Names when generating the data to fingerprint.
+        -- Here we want to output the fingerprint for each top-level
+        -- Name, whether it comes from the current module or another
+        -- module.  In this way, the fingerprint for a declaration will
+        -- change if the fingerprint for anything it refers to (transitively)
+        -- changes.
+       mk_put_name :: OccEnv (OccName,Fingerprint)
+                   -> BinHandle -> Name -> IO  ()
+       mk_put_name local_env bh name
+          | isWiredInName name  =  putNameLiterally bh name
+           -- wired-in names don't have fingerprints
+          | otherwise
+          = ASSERT2( isExternalName name, ppr name )
+            let hash | nameModule name /= semantic_mod =  global_hash_fn name
+                     -- Get it from the REAL interface!!
+                     -- This will trigger when we compile an hsig file
+                     -- and we know a backing impl for it.
+                     -- See Note [Identity versus semantic module]
+                     | semantic_mod /= this_mod
+                     , not (isHoleModule semantic_mod) = global_hash_fn name
+                     | otherwise = return (snd (lookupOccEnv local_env (getOccName name)
+                           `orElse` pprPanic "urk! lookup local fingerprint"
+                                       (ppr name $$ ppr local_env)))
+                -- This panic indicates that we got the dependency
+                -- analysis wrong, because we needed a fingerprint for
+                -- an entity that wasn't in the environment.  To debug
+                -- it, turn the panic into a trace, uncomment the
+                -- pprTraces below, run the compile again, and inspect
+                -- the output and the generated .hi file with
+                -- --show-iface.
+            in hash >>= put_ bh
+
+        -- take a strongly-connected group of declarations and compute
+        -- its fingerprint.
+
+       fingerprint_group :: (OccEnv (OccName,Fingerprint),
+                             [(Fingerprint,IfaceDecl)])
+                         -> SCC IfaceDeclABI
+                         -> IO (OccEnv (OccName,Fingerprint),
+                                [(Fingerprint,IfaceDecl)])
+
+       fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)
+          = do let hash_fn = mk_put_name local_env
+                   decl = abiDecl abi
+               --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do
+               hash <- computeFingerprint hash_fn abi
+               env' <- extend_hash_env local_env (hash,decl)
+               return (env', (hash,decl) : decls_w_hashes)
+
+       fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)
+          = do let decls = map abiDecl abis
+               local_env1 <- foldM extend_hash_env local_env
+                                   (zip (repeat fingerprint0) decls)
+               let hash_fn = mk_put_name local_env1
+               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do
+               let stable_abis = sortBy cmp_abiNames abis
+                -- put the cycle in a canonical order
+               hash <- computeFingerprint hash_fn stable_abis
+               let pairs = zip (repeat hash) decls
+               local_env2 <- foldM extend_hash_env local_env pairs
+               return (local_env2, pairs ++ decls_w_hashes)
+
+       -- we have fingerprinted the whole declaration, but we now need
+       -- to assign fingerprints to all the OccNames that it binds, to
+       -- use when referencing those OccNames in later declarations.
+       --
+       extend_hash_env :: OccEnv (OccName,Fingerprint)
+                       -> (Fingerprint,IfaceDecl)
+                       -> IO (OccEnv (OccName,Fingerprint))
+       extend_hash_env env0 (hash,d) = do
+          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0
+                 (ifaceDeclFingerprints hash d))
+
+   --
+   (local_env, decls_w_hashes) <-
+       foldM fingerprint_group (emptyOccEnv, []) groups
+
+   -- when calculating fingerprints, we always need to use canonical
+   -- ordering for lists of things.  In particular, the mi_deps has various
+   -- lists of modules and suchlike, so put these all in canonical order:
+   let sorted_deps = sortDependencies (mi_deps iface0)
+
+   -- The export hash of a module depends on the orphan hashes of the
+   -- orphan modules below us in the dependency tree.  This is the way
+   -- that changes in orphans get propagated all the way up the
+   -- dependency tree.
+   --
+   -- Note [A bad dep_orphs optimization]
+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   -- In a previous version of this code, we filtered out orphan modules which
+   -- were not from the home package, justifying it by saying that "we'd
+   -- pick up the ABI hashes of the external module instead".  This is wrong.
+   -- Suppose that we have:
+   --
+   --       module External where
+   --           instance Show (a -> b)
+   --
+   --       module Home1 where
+   --           import External
+   --
+   --       module Home2 where
+   --           import Home1
+   --
+   -- The export hash of Home1 needs to reflect the orphan instances of
+   -- External. It's true that Home1 will get rebuilt if the orphans
+   -- of External, but we also need to make sure Home2 gets rebuilt
+   -- as well.  See #12733 for more details.
+   let orph_mods
+        = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]
+        $ dep_orphs sorted_deps
+   dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods
+
+   -- Note [Do not update EPS with your own hi-boot]
+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   -- (See also Trac #10182).  When your hs-boot file includes an orphan
+   -- instance declaration, you may find that the dep_orphs of a module you
+   -- import contains reference to yourself.  DO NOT actually load this module
+   -- or add it to the orphan hashes: you're going to provide the orphan
+   -- instances yourself, no need to consult hs-boot; if you do load the
+   -- interface into EPS, you will see a duplicate orphan instance.
+
+   orphan_hash <- computeFingerprint (mk_put_name local_env)
+                                     (map ifDFun orph_insts, orph_rules, orph_fis)
+
+   -- the export list hash doesn't depend on the fingerprints of
+   -- the Names it mentions, only the Names themselves, hence putNameLiterally.
+   export_hash <- computeFingerprint putNameLiterally
+                      (mi_exports iface0,
+                       orphan_hash,
+                       dep_orphan_hashes,
+                       dep_pkgs (mi_deps iface0),
+                       -- See Note [Export hash depends on non-orphan family instances]
+                       dep_finsts (mi_deps iface0),
+                        -- dep_pkgs: see "Package Version Changes" on
+                        -- wiki/Commentary/Compiler/RecompilationAvoidance
+                       mi_trust iface0)
+                        -- Make sure change of Safe Haskell mode causes recomp.
+
+   -- Note [Export hash depends on non-orphan family instances]
+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   --
+   -- Suppose we have:
+   --
+   --   module A where
+   --       type instance F Int = Bool
+   --
+   --   module B where
+   --       import A
+   --
+   --   module C where
+   --       import B
+   --
+   -- The family instance consistency check for C depends on the dep_finsts of
+   -- B.  If we rename module A to A2, when the dep_finsts of B changes, we need
+   -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of
+   -- the exports of B, because C always considers them when checking
+   -- consistency.
+   --
+   -- A full discussion is in #12723.
+   --
+   -- We do NOT need to hash dep_orphs, because this is implied by
+   -- dep_orphan_hashes, and we do not need to hash ordinary class instances,
+   -- because there is no eager consistency check as there is with type families
+   -- (also we didn't store it anywhere!)
+   --
+
+   -- put the declarations in a canonical order, sorted by OccName
+   let sorted_decls = Map.elems $ Map.fromList $
+                          [(getOccName d, e) | e@(_, d) <- decls_w_hashes]
+
+   -- the flag hash depends on:
+   --   - (some of) dflags
+   -- it returns two hashes, one that shouldn't change
+   -- the abi hash and one that should
+   flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally
+
+   opt_hash <- fingerprintOptFlags dflags putNameLiterally
+
+   hpc_hash <- fingerprintHpcFlags dflags putNameLiterally
+
+   plugin_hash <- fingerprintPlugins hsc_env
+
+   -- the ABI hash depends on:
+   --   - decls
+   --   - export list
+   --   - orphans
+   --   - deprecations
+   --   - flag abi hash
+   mod_hash <- computeFingerprint putNameLiterally
+                      (map fst sorted_decls,
+                       export_hash,  -- includes orphan_hash
+                       mi_warns iface0)
+
+   -- The interface hash depends on:
+   --   - the ABI hash, plus
+   --   - the module level annotations,
+   --   - usages
+   --   - deps (home and external packages, dependent files)
+   --   - hpc
+   iface_hash <- computeFingerprint putNameLiterally
+                      (mod_hash,
+                       ann_fn (mkVarOcc "module"),  -- See mkIfaceAnnCache
+                       mi_usages iface0,
+                       sorted_deps,
+                       mi_hpc iface0)
+
+   let
+    no_change_at_all = Just iface_hash == mb_old_fingerprint
+
+    final_iface = iface0 {
+                mi_mod_hash    = mod_hash,
+                mi_iface_hash  = iface_hash,
+                mi_exp_hash    = export_hash,
+                mi_orphan_hash = orphan_hash,
+                mi_flag_hash   = flag_hash,
+                mi_opt_hash    = opt_hash,
+                mi_hpc_hash    = hpc_hash,
+                mi_plugin_hash = plugin_hash,
+                mi_orphan      = not (   all ifRuleAuto orph_rules
+                                           -- See Note [Orphans and auto-generated rules]
+                                      && null orph_insts
+                                      && null orph_fis),
+                mi_finsts      = not . null $ mi_fam_insts iface0,
+                mi_decls       = sorted_decls,
+                mi_hash_fn     = lookupOccEnv local_env }
+   --
+   return (final_iface, no_change_at_all)
+
+  where
+    this_mod = mi_module iface0
+    semantic_mod = mi_semantic_module iface0
+    dflags = hsc_dflags hsc_env
+    (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    (mi_insts iface0)
+    (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    (mi_rules iface0)
+    (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)
+    fix_fn = mi_fix_fn iface0
+    ann_fn = mkIfaceAnnCache (mi_anns iface0)
+
+-- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules
+-- (in particular, the orphan modules which are transitively imported by the
+-- current module).
+--
+-- Q: Why do we need the hash at all, doesn't the list of transitively
+-- imported orphan modules suffice?
+--
+-- A: If one of our transitive imports adds a new orphan instance, our
+-- export hash must change so that modules which import us rebuild.  If we just
+-- hashed the [Module], the hash would not change even when a new instance was
+-- added to a module that already had an orphan instance.
+--
+-- Q: Why don't we just hash the orphan hashes of our direct dependencies?
+-- Why the full transitive closure?
+--
+-- A: Suppose we have these modules:
+--
+--      module A where
+--          instance Show (a -> b) where
+--      module B where
+--          import A -- **
+--      module C where
+--          import A
+--          import B
+--
+-- Whether or not we add or remove the import to A in B affects the
+-- orphan hash of B.  But it shouldn't really affect the orphan hash
+-- of C.  If we hashed only direct dependencies, there would be no
+-- way to tell that the net effect was a wash, and we'd be forced
+-- to recompile C and everything else.
+getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]
+getOrphanHashes hsc_env mods = do
+  eps <- hscEPS hsc_env
+  let
+    hpt        = hsc_HPT hsc_env
+    pit        = eps_PIT eps
+    dflags     = hsc_dflags hsc_env
+    get_orph_hash mod =
+          case lookupIfaceByModule dflags hpt pit mod of
+            Just iface -> return (mi_orphan_hash iface)
+            Nothing    -> do -- similar to 'mkHashFun'
+                iface <- initIfaceLoad hsc_env . withException
+                            $ loadInterface (text "getOrphanHashes") mod ImportBySystem
+                return (mi_orphan_hash iface)
+
+  --
+  mapM get_orph_hash mods
+
+
+sortDependencies :: Dependencies -> Dependencies
+sortDependencies d
+ = Deps { dep_mods   = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),
+          dep_pkgs   = sortBy (compare `on` fst) (dep_pkgs d),
+          dep_orphs  = sortBy stableModuleCmp (dep_orphs d),
+          dep_finsts = sortBy stableModuleCmp (dep_finsts d),
+          dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) }
+
+-- | Creates cached lookup for the 'mi_anns' field of ModIface
+-- Hackily, we use "module" as the OccName for any module-level annotations
+mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]
+mkIfaceAnnCache anns
+  = \n -> lookupOccEnv env n `orElse` []
+  where
+    pair (IfaceAnnotation target value) =
+      (case target of
+          NamedTarget occn -> occn
+          ModuleTarget _   -> mkVarOcc "module"
+      , [value])
+    -- flipping (++), so the first argument is always short
+    env = mkOccEnv_C (flip (++)) (map pair anns)
+
+{-
+************************************************************************
+*                                                                      *
+          The ABI of an IfaceDecl
+*                                                                      *
+************************************************************************
+
+Note [The ABI of an IfaceDecl]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The ABI of a declaration consists of:
+
+   (a) the full name of the identifier (inc. module and package,
+       because these are used to construct the symbol name by which
+       the identifier is known externally).
+
+   (b) the declaration itself, as exposed to clients.  That is, the
+       definition of an Id is included in the fingerprint only if
+       it is made available as an unfolding in the interface.
+
+   (c) the fixity of the identifier (if it exists)
+   (d) for Ids: rules
+   (e) for classes: instances, fixity & rules for methods
+   (f) for datatypes: instances, fixity & rules for constrs
+
+Items (c)-(f) are not stored in the IfaceDecl, but instead appear
+elsewhere in the interface file.  But they are *fingerprinted* with
+the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,
+and fingerprinting that as part of the declaration.
+-}
+
+type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)
+
+data IfaceDeclExtras
+  = IfaceIdExtras IfaceIdExtras
+
+  | IfaceDataExtras
+       (Maybe Fixity)           -- Fixity of the tycon itself (if it exists)
+       [IfaceInstABI]           -- Local class and family instances of this tycon
+                                -- See Note [Orphans] in InstEnv
+       [AnnPayload]             -- Annotations of the type itself
+       [IfaceIdExtras]          -- For each constructor: fixity, RULES and annotations
+
+  | IfaceClassExtras
+       (Maybe Fixity)           -- Fixity of the class itself (if it exists)
+       [IfaceInstABI]           -- Local instances of this class *or*
+                                --   of its associated data types
+                                -- See Note [Orphans] in InstEnv
+       [AnnPayload]             -- Annotations of the type itself
+       [IfaceIdExtras]          -- For each class method: fixity, RULES and annotations
+       [IfExtName]              -- Default methods. If a module
+                                -- mentions a class, then it can
+                                -- instantiate the class and thereby
+                                -- use the default methods, so we must
+                                -- include these in the fingerprint of
+                                -- a class.
+
+  | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]
+
+  | IfaceFamilyExtras   (Maybe Fixity) [IfaceInstABI] [AnnPayload]
+
+  | IfaceOtherDeclExtras
+
+data IfaceIdExtras
+  = IdExtras
+       (Maybe Fixity)           -- Fixity of the Id (if it exists)
+       [IfaceRule]              -- Rules for the Id
+       [AnnPayload]             -- Annotations for the Id
+
+-- When hashing a class or family instance, we hash only the
+-- DFunId or CoAxiom, because that depends on all the
+-- information about the instance.
+--
+type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance
+
+abiDecl :: IfaceDeclABI -> IfaceDecl
+abiDecl (_, decl, _) = decl
+
+cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering
+cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare`
+                         getOccName (abiDecl abi2)
+
+freeNamesDeclABI :: IfaceDeclABI -> NameSet
+freeNamesDeclABI (_mod, decl, extras) =
+  freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras
+
+freeNamesDeclExtras :: IfaceDeclExtras -> NameSet
+freeNamesDeclExtras (IfaceIdExtras id_extras)
+  = freeNamesIdExtras id_extras
+freeNamesDeclExtras (IfaceDataExtras  _ insts _ subs)
+  = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)
+freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms)
+  = unionNameSets $
+      mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs
+freeNamesDeclExtras (IfaceSynonymExtras _ _)
+  = emptyNameSet
+freeNamesDeclExtras (IfaceFamilyExtras _ insts _)
+  = mkNameSet insts
+freeNamesDeclExtras IfaceOtherDeclExtras
+  = emptyNameSet
+
+freeNamesIdExtras :: IfaceIdExtras -> NameSet
+freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules)
+
+instance Outputable IfaceDeclExtras where
+  ppr IfaceOtherDeclExtras       = Outputable.empty
+  ppr (IfaceIdExtras  extras)    = ppr_id_extras extras
+  ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]
+  ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]
+  ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
+                                                ppr_id_extras_s stuff]
+  ppr (IfaceClassExtras fix insts anns stuff defms) =
+    vcat [ppr fix, ppr_insts insts, ppr anns,
+          ppr_id_extras_s stuff, ppr defms]
+
+ppr_insts :: [IfaceInstABI] -> SDoc
+ppr_insts _ = text "<insts>"
+
+ppr_id_extras_s :: [IfaceIdExtras] -> SDoc
+ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)
+
+ppr_id_extras :: IfaceIdExtras -> SDoc
+ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)
+
+-- This instance is used only to compute fingerprints
+instance Binary IfaceDeclExtras where
+  get _bh = panic "no get for IfaceDeclExtras"
+  put_ bh (IfaceIdExtras extras) = do
+   putByte bh 1; put_ bh extras
+  put_ bh (IfaceDataExtras fix insts anns cons) = do
+   putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons
+  put_ bh (IfaceClassExtras fix insts anns methods defms) = do
+   putByte bh 3
+   put_ bh fix
+   put_ bh insts
+   put_ bh anns
+   put_ bh methods
+   put_ bh defms
+  put_ bh (IfaceSynonymExtras fix anns) = do
+   putByte bh 4; put_ bh fix; put_ bh anns
+  put_ bh (IfaceFamilyExtras fix finsts anns) = do
+   putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns
+  put_ bh IfaceOtherDeclExtras = putByte bh 6
+
+instance Binary IfaceIdExtras where
+  get _bh = panic "no get for IfaceIdExtras"
+  put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }
+
+declExtras :: (OccName -> Maybe Fixity)
+           -> (OccName -> [AnnPayload])
+           -> OccEnv [IfaceRule]
+           -> OccEnv [IfaceClsInst]
+           -> OccEnv [IfaceFamInst]
+           -> OccEnv IfExtName          -- lookup default method names
+           -> IfaceDecl
+           -> IfaceDeclExtras
+
+declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env decl
+  = case decl of
+      IfaceId{} -> IfaceIdExtras (id_extras n)
+      IfaceData{ifCons=cons} ->
+                     IfaceDataExtras (fix_fn n)
+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++
+                         map ifDFun         (lookupOccEnvL inst_env n))
+                        (ann_fn n)
+                        (map (id_extras . occName . ifConName) (visibleIfConDecls cons))
+      IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->
+                     IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms
+          where
+            insts = (map ifDFun $ (concatMap at_extras ats)
+                                    ++ lookupOccEnvL inst_env n)
+                           -- Include instances of the associated types
+                           -- as well as instances of the class (Trac #5147)
+            meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]
+            -- Names of all the default methods (see Note [default method Name])
+            defms = [ dmName
+                    | IfaceClassOp bndr _ (Just _) <- sigs
+                    , let dmOcc = mkDefaultMethodOcc (nameOccName bndr)
+                    , Just dmName <- [lookupOccEnv dm_env dmOcc] ]
+      IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)
+                                           (ann_fn n)
+      IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)
+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n))
+                        (ann_fn n)
+      _other -> IfaceOtherDeclExtras
+  where
+        n = getOccName decl
+        id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)
+        at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl)
+
+
+{- Note [default method Name] (see also #15970)
+
+The Names for the default methods aren't available in the IfaceSyn.
+
+* We originally start with a DefMethInfo from the class, contain a
+  Name for the default method
+
+* We turn that into IfaceSyn as a DefMethSpec which lacks a Name
+  entirely. Why? Because the Name can be derived from the method name
+  (in TcIface), so doesn't need to be serialised into the interface
+  file.
+
+But now we have to get the Name back, because the class declaration's
+fingerprint needs to depend on it (this was the bug in #15970).  This
+is done in a slightly convoluted way:
+
+* Then, in addFingerprints we build a map that maps OccNames to Names
+
+* We pass that map to declExtras which laboriously looks up in the map
+  (using the derived occurrence name) to recover the Name we have just
+  thrown away.
+-}
+
+lookupOccEnvL :: OccEnv [v] -> OccName -> [v]
+lookupOccEnvL env k = lookupOccEnv env k `orElse` []
+
+{-
+-- for testing: use the md5sum command to generate fingerprints and
+-- compare the results against our built-in version.
+  fp' <- oldMD5 dflags bh
+  if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')
+               else return fp
+
+oldMD5 dflags bh = do
+  tmp <- newTempName dflags CurrentModule "bin"
+  writeBinMem bh tmp
+  tmp2 <- newTempName dflags CurrentModule "md5"
+  let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2
+  r <- system cmd
+  case r of
+    ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)
+    ExitSuccess -> do
+        hash_str <- readFile tmp2
+        return $! readHexFingerprint hash_str
+-}
+
+----------------------
+-- mkOrphMap partitions instance decls or rules into
+--      (a) an OccEnv for ones that are not orphans,
+--          mapping the local OccName to a list of its decls
+--      (b) a list of orphan decls
+mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl
+          -> [decl]             -- Sorted into canonical order
+          -> (OccEnv [decl],    -- Non-orphan decls associated with their key;
+                                --      each sublist in canonical order
+              [decl])           -- Orphan decls; in canonical order
+mkOrphMap get_key decls
+  = foldl' go (emptyOccEnv, []) decls
+  where
+    go (non_orphs, orphs) d
+        | NotOrphan occ <- get_key d
+        = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)
+        | otherwise = (non_orphs, d:orphs)
+
+{-
+************************************************************************
+*                                                                      *
+       COMPLETE Pragmas
+*                                                                      *
+************************************************************************
+-}
+
+mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch
+mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc
+
+
+{-
+************************************************************************
+*                                                                      *
+       Keeping track of what we've slurped, and fingerprints
+*                                                                      *
+************************************************************************
+-}
+
+
+mkIfaceAnnotation :: Annotation -> IfaceAnnotation
+mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload })
+  = IfaceAnnotation {
+        ifAnnotatedTarget = fmap nameOccName target,
+        ifAnnotatedValue = payload
+    }
+
+mkIfaceExports :: [AvailInfo] -> [IfaceExport]  -- Sort to make canonical
+mkIfaceExports exports
+  = sortBy stableAvailCmp (map sort_subs exports)
+  where
+    sort_subs :: AvailInfo -> AvailInfo
+    sort_subs (Avail n) = Avail n
+    sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)
+    sort_subs (AvailTC n (m:ms) fs)
+       | n==m      = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)
+       | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)
+       -- Maintain the AvailTC Invariant
+
+    sort_flds = sortBy (stableNameCmp `on` flSelector)
+
+{-
+Note [Original module]
+~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+        module X where { data family T }
+        module Y( T(..) ) where { import X; data instance T Int = MkT Int }
+The exported Avail from Y will look like
+        X.T{X.T, Y.MkT}
+That is, in Y,
+  - only MkT is brought into scope by the data instance;
+  - but the parent (used for grouping and naming in T(..) exports) is X.T
+  - and in this case we export X.T too
+
+In the result of MkIfaceExports, the names are grouped by defining module,
+so we may need to split up a single Avail into multiple ones.
+
+Note [Internal used_names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Most of the used_names are External Names, but we can have Internal
+Names too: see Note [Binders in Template Haskell] in Convert, and
+Trac #5362 for an example.  Such Names are always
+  - Such Names are always for locally-defined things, for which we
+    don't gather usage info, so we can just ignore them in ent_map
+  - They are always System Names, hence the assert, just as a double check.
+
+
+************************************************************************
+*                                                                      *
+        Load the old interface file for this module (unless
+        we have it already), and check whether it is up to date
+*                                                                      *
+************************************************************************
+-}
+
+data RecompileRequired
+  = UpToDate
+       -- ^ everything is up to date, recompilation is not required
+  | MustCompile
+       -- ^ The .hs file has been touched, or the .o/.hi file does not exist
+  | RecompBecause String
+       -- ^ The .o/.hi files are up to date, but something else has changed
+       -- to force recompilation; the String says what (one-line summary)
+   deriving Eq
+
+instance Semigroup RecompileRequired where
+  UpToDate <> r = r
+  mc <> _       = mc
+
+instance Monoid RecompileRequired where
+  mempty = UpToDate
+
+recompileRequired :: RecompileRequired -> Bool
+recompileRequired UpToDate = False
+recompileRequired _ = True
+
+
+
+-- | Top level function to check if the version of an old interface file
+-- is equivalent to the current source file the user asked us to compile.
+-- If the same, we can avoid recompilation. We return a tuple where the
+-- first element is a bool saying if we should recompile the object file
+-- and the second is maybe the interface file, where Nothng means to
+-- rebuild the interface file not use the exisitng one.
+checkOldIface
+  :: HscEnv
+  -> ModSummary
+  -> SourceModified
+  -> Maybe ModIface         -- Old interface from compilation manager, if any
+  -> IO (RecompileRequired, Maybe ModIface)
+
+checkOldIface hsc_env mod_summary source_modified maybe_iface
+  = do  let dflags = hsc_dflags hsc_env
+        showPass dflags $
+            "Checking old interface for " ++
+              (showPpr dflags $ ms_mod mod_summary) ++
+              " (use -ddump-hi-diffs for more details)"
+        initIfaceCheck (text "checkOldIface") hsc_env $
+            check_old_iface hsc_env mod_summary source_modified maybe_iface
+
+check_old_iface
+  :: HscEnv
+  -> ModSummary
+  -> SourceModified
+  -> Maybe ModIface
+  -> IfG (RecompileRequired, Maybe ModIface)
+
+check_old_iface hsc_env mod_summary src_modified maybe_iface
+  = let dflags = hsc_dflags hsc_env
+        getIface =
+            case maybe_iface of
+                Just _  -> do
+                    traceIf (text "We already have the old interface for" <+>
+                      ppr (ms_mod mod_summary))
+                    return maybe_iface
+                Nothing -> loadIface
+
+        loadIface = do
+             let iface_path = msHiFilePath mod_summary
+             read_result <- readIface (ms_mod mod_summary) iface_path
+             case read_result of
+                 Failed err -> do
+                     traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)
+                     traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err)
+                     return Nothing
+                 Succeeded iface -> do
+                     traceIf (text "Read the interface file" <+> text iface_path)
+                     return $ Just iface
+
+        src_changed
+            | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True
+            | SourceModified <- src_modified = True
+            | otherwise = False
+    in do
+        when src_changed $
+            traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")
+
+        case src_changed of
+            -- If the source has changed and we're in interactive mode,
+            -- avoid reading an interface; just return the one we might
+            -- have been supplied with.
+            True | not (isObjectTarget $ hscTarget dflags) ->
+                return (MustCompile, maybe_iface)
+
+            -- Try and read the old interface for the current module
+            -- from the .hi file left from the last time we compiled it
+            True -> do
+                maybe_iface' <- getIface
+                return (MustCompile, maybe_iface')
+
+            False -> do
+                maybe_iface' <- getIface
+                case maybe_iface' of
+                    -- We can't retrieve the iface
+                    Nothing    -> return (MustCompile, Nothing)
+
+                    -- We have got the old iface; check its versions
+                    -- even in the SourceUnmodifiedAndStable case we
+                    -- should check versions because some packages
+                    -- might have changed or gone away.
+                    Just iface -> checkVersions hsc_env mod_summary iface
+
+-- | Check if a module is still the same 'version'.
+--
+-- This function is called in the recompilation checker after we have
+-- determined that the module M being checked hasn't had any changes
+-- to its source file since we last compiled M. So at this point in general
+-- two things may have changed that mean we should recompile M:
+--   * The interface export by a dependency of M has changed.
+--   * The compiler flags specified this time for M have changed
+--     in a manner that is significant for recompilation.
+-- We return not just if we should recompile the object file but also
+-- if we should rebuild the interface file.
+checkVersions :: HscEnv
+              -> ModSummary
+              -> ModIface       -- Old interface
+              -> IfG (RecompileRequired, Maybe ModIface)
+checkVersions hsc_env mod_summary iface
+  = do { traceHiDiffs (text "Considering whether compilation is required for" <+>
+                        ppr (mi_module iface) <> colon)
+
+       -- readIface will have verified that the InstalledUnitId matches,
+       -- but we ALSO must make sure the instantiation matches up.  See
+       -- test case bkpcabal04!
+       ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env)
+            then return (RecompBecause "-this-unit-id changed", Nothing) else do {
+       ; recomp <- checkFlagHash hsc_env iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; recomp <- checkOptimHash hsc_env iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; recomp <- checkHpcHash hsc_env iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; recomp <- checkMergedSignatures mod_summary iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; recomp <- checkHsig mod_summary iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; recomp <- checkHie mod_summary
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+       ; recomp <- checkDependencies hsc_env mod_summary iface
+       ; if recompileRequired recomp then return (recomp, Just iface) else do {
+       ; recomp <- checkPlugins hsc_env iface
+       ; if recompileRequired recomp then return (recomp, Nothing) else do {
+
+
+       -- Source code unchanged and no errors yet... carry on
+       --
+       -- First put the dependent-module info, read from the old
+       -- interface, into the envt, so that when we look for
+       -- interfaces we look for the right one (.hi or .hi-boot)
+       --
+       -- It's just temporary because either the usage check will succeed
+       -- (in which case we are done with this module) or it'll fail (in which
+       -- case we'll compile the module from scratch anyhow).
+       --
+       -- We do this regardless of compilation mode, although in --make mode
+       -- all the dependent modules should be in the HPT already, so it's
+       -- quite redundant
+       ; updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }
+       ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]
+       ; return (recomp, Just iface)
+    }}}}}}}}}}
+  where
+    this_pkg = thisPackage (hsc_dflags hsc_env)
+    -- This is a bit of a hack really
+    mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)
+    mod_deps = mkModDeps (dep_mods (mi_deps iface))
+
+-- | Check if any plugins are requesting recompilation
+checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired
+checkPlugins hsc iface = liftIO $ do
+  new_fingerprint <- fingerprintPlugins hsc
+  let old_fingerprint = mi_plugin_hash iface
+  pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc))
+  return $
+    pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr
+
+fingerprintPlugins :: HscEnv -> IO Fingerprint
+fingerprintPlugins hsc_env = do
+  fingerprintPlugins' $ plugins (hsc_dflags hsc_env)
+
+fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint
+fingerprintPlugins' plugins = do
+  res <- mconcat <$> mapM pluginRecompile' plugins
+  return $ case res of
+      NoForceRecompile ->  fingerprintString "NoForceRecompile"
+      ForceRecompile   -> fingerprintString "ForceRecompile"
+      -- is the chance of collision worth worrying about?
+      -- An alternative is to fingerprintFingerprints [fingerprintString
+      -- "maybeRecompile", fp]
+      (MaybeRecompile fp) -> fp
+
+
+pluginRecompileToRecompileRequired
+    :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired
+pluginRecompileToRecompileRequired old_fp new_fp pr
+  | old_fp == new_fp =
+    case pr of
+      NoForceRecompile  -> UpToDate
+
+      -- we already checked the fingerprint above so a mismatch is not possible
+      -- here, remember that: `fingerprint (MaybeRecomp x) == x`.
+      MaybeRecompile _  -> UpToDate
+
+      -- when we have an impure plugin in the stack we have to unconditionally
+      -- recompile since it might integrate all sorts of crazy IO results into
+      -- its compilation output.
+      ForceRecompile    -> RecompBecause "Impure plugin forced recompilation"
+
+  | old_fp `elem` magic_fingerprints ||
+    new_fp `elem` magic_fingerprints
+    -- The fingerprints do not match either the old or new one is a magic
+    -- fingerprint. This happens when non-pure plugins are added for the first
+    -- time or when we go from one recompilation strategy to another: (force ->
+    -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.)
+    --
+    -- For example when we go from from ForceRecomp to NoForceRecomp
+    -- recompilation is triggered since the old impure plugins could have
+    -- changed the build output which is now back to normal.
+    = RecompBecause "Plugins changed"
+
+  | otherwise =
+    let reason = "Plugin fingerprint changed" in
+    case pr of
+      -- even though a plugin is forcing recompilation the fingerprint changed
+      -- which would cause recompilation anyways so we report the fingerprint
+      -- change instead.
+      ForceRecompile   -> RecompBecause reason
+
+      _                -> RecompBecause reason
+
+ where
+   magic_fingerprints =
+       [ fingerprintString "NoForceRecompile"
+       , fingerprintString "ForceRecompile"
+       ]
+
+
+-- | Check if an hsig file needs recompilation because its
+-- implementing module has changed.
+checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired
+checkHsig mod_summary iface = do
+    dflags <- getDynFlags
+    let outer_mod = ms_mod mod_summary
+        inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)
+    MASSERT( moduleUnitId outer_mod == thisPackage dflags )
+    case inner_mod == mi_semantic_module iface of
+        True -> up_to_date (text "implementing module unchanged")
+        False -> return (RecompBecause "implementing module changed")
+
+-- | Check if @.hie@ file is out of date or missing.
+checkHie :: ModSummary -> IfG RecompileRequired
+checkHie mod_summary = do
+    dflags <- getDynFlags
+    let hie_date_opt = ms_hie_date mod_summary
+        hs_date = ms_hs_date mod_summary
+    pure $ case gopt Opt_WriteHie dflags of
+               False -> UpToDate
+               True -> case hie_date_opt of
+                           Nothing -> RecompBecause "HIE file is missing"
+                           Just hie_date
+                               | hie_date < hs_date
+                               -> RecompBecause "HIE file is out of date"
+                               | otherwise
+                               -> UpToDate
+
+-- | Check the flags haven't changed
+checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired
+checkFlagHash hsc_env iface = do
+    let old_hash = mi_flag_hash iface
+    new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)
+                                             (mi_module iface)
+                                             putNameLiterally
+    case old_hash == new_hash of
+        True  -> up_to_date (text "Module flags unchanged")
+        False -> out_of_date_hash "flags changed"
+                     (text "  Module flags have changed")
+                     old_hash new_hash
+
+-- | Check the optimisation flags haven't changed
+checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired
+checkOptimHash hsc_env iface = do
+    let old_hash = mi_opt_hash iface
+    new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)
+                                               putNameLiterally
+    if | old_hash == new_hash
+         -> up_to_date (text "Optimisation flags unchanged")
+       | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)
+         -> up_to_date (text "Optimisation flags changed; ignoring")
+       | otherwise
+         -> out_of_date_hash "Optimisation flags changed"
+                     (text "  Optimisation flags have changed")
+                     old_hash new_hash
+
+-- | Check the HPC flags haven't changed
+checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired
+checkHpcHash hsc_env iface = do
+    let old_hash = mi_hpc_hash iface
+    new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)
+                                               putNameLiterally
+    if | old_hash == new_hash
+         -> up_to_date (text "HPC flags unchanged")
+       | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)
+         -> up_to_date (text "HPC flags changed; ignoring")
+       | otherwise
+         -> out_of_date_hash "HPC flags changed"
+                     (text "  HPC flags have changed")
+                     old_hash new_hash
+
+-- Check that the set of signatures we are merging in match.
+-- If the -unit-id flags change, this can change too.
+checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired
+checkMergedSignatures mod_summary iface = do
+    dflags <- getDynFlags
+    let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]
+        new_merged = case Map.lookup (ms_mod_name mod_summary)
+                                     (requirementContext (pkgState dflags)) of
+                        Nothing -> []
+                        Just r -> sort $ map (indefModuleToModule dflags) r
+    if old_merged == new_merged
+        then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)
+        else return (RecompBecause "signatures to merge in changed")
+
+-- If the direct imports of this module are resolved to targets that
+-- are not among the dependencies of the previous interface file,
+-- then we definitely need to recompile.  This catches cases like
+--   - an exposed package has been upgraded
+--   - we are compiling with different package flags
+--   - a home module that was shadowing a package module has been removed
+--   - a new home module has been added that shadows a package module
+-- See bug #1372.
+--
+-- Returns (RecompBecause <textual reason>) if recompilation is required.
+checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired
+checkDependencies hsc_env summary iface
+ = checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))
+  where
+   prev_dep_mods = dep_mods (mi_deps iface)
+   prev_dep_plgn = dep_plgins (mi_deps iface)
+   prev_dep_pkgs = dep_pkgs (mi_deps iface)
+
+   this_pkg = thisPackage (hsc_dflags hsc_env)
+
+   dep_missing (mb_pkg, L _ mod) = do
+     find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)
+     let reason = moduleNameString mod ++ " changed"
+     case find_res of
+        Found _ mod
+          | pkg == this_pkg
+           -> if moduleName mod `notElem` map fst prev_dep_mods ++ prev_dep_plgn
+                 then do traceHiDiffs $
+                           text "imported module " <> quotes (ppr mod) <>
+                           text " not among previous dependencies"
+                         return (RecompBecause reason)
+                 else
+                         return UpToDate
+          | otherwise
+           -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs)
+                 then do traceHiDiffs $
+                           text "imported module " <> quotes (ppr mod) <>
+                           text " is from package " <> quotes (ppr pkg) <>
+                           text ", which is not among previous dependencies"
+                         return (RecompBecause reason)
+                 else
+                         return UpToDate
+           where pkg = moduleUnitId mod
+        _otherwise  -> return (RecompBecause reason)
+
+needInterface :: Module -> (ModIface -> IfG RecompileRequired)
+              -> IfG RecompileRequired
+needInterface mod continue
+  = do  -- Load the imported interface if possible
+    let doc_str = sep [text "need version info for", ppr mod]
+    traceHiDiffs (text "Checking usages for module" <+> ppr mod)
+
+    mb_iface <- loadInterface doc_str mod ImportBySystem
+        -- Load the interface, but don't complain on failure;
+        -- Instead, get an Either back which we can test
+
+    case mb_iface of
+      Failed _ -> do
+        traceHiDiffs (sep [text "Couldn't load interface for module",
+                           ppr mod])
+        return MustCompile
+                  -- Couldn't find or parse a module mentioned in the
+                  -- old interface file.  Don't complain: it might
+                  -- just be that the current module doesn't need that
+                  -- import and it's been deleted
+      Succeeded iface -> continue iface
+
+-- | Given the usage information extracted from the old
+-- M.hi file for the module being compiled, figure out
+-- whether M needs to be recompiled.
+checkModUsage :: UnitId -> Usage -> IfG RecompileRequired
+checkModUsage _this_pkg UsagePackageModule{
+                                usg_mod = mod,
+                                usg_mod_hash = old_mod_hash }
+  = needInterface mod $ \iface -> do
+    let reason = moduleNameString (moduleName mod) ++ " changed"
+    checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)
+        -- We only track the ABI hash of package modules, rather than
+        -- individual entity usages, so if the ABI hash changes we must
+        -- recompile.  This is safe but may entail more recompilation when
+        -- a dependent package has changed.
+
+checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash }
+  = needInterface mod $ \iface -> do
+    let reason = moduleNameString (moduleName mod) ++ " changed (raw)"
+    checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)
+
+checkModUsage this_pkg UsageHomeModule{
+                                usg_mod_name = mod_name,
+                                usg_mod_hash = old_mod_hash,
+                                usg_exports = maybe_old_export_hash,
+                                usg_entities = old_decl_hash }
+  = do
+    let mod = mkModule this_pkg mod_name
+    needInterface mod $ \iface -> do
+
+    let
+        new_mod_hash    = mi_mod_hash    iface
+        new_decl_hash   = mi_hash_fn     iface
+        new_export_hash = mi_exp_hash    iface
+
+        reason = moduleNameString mod_name ++ " changed"
+
+        -- CHECK MODULE
+    recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash
+    if not (recompileRequired recompile)
+      then return UpToDate
+      else do
+
+        -- CHECK EXPORT LIST
+        checkMaybeHash reason maybe_old_export_hash new_export_hash
+            (text "  Export list changed") $ do
+
+        -- CHECK ITEMS ONE BY ONE
+        recompile <- checkList [ checkEntityUsage reason new_decl_hash u
+                               | u <- old_decl_hash]
+        if recompileRequired recompile
+          then return recompile     -- This one failed, so just bail out now
+          else up_to_date (text "  Great!  The bits I use are up to date")
+
+
+checkModUsage _this_pkg UsageFile{ usg_file_path = file,
+                                   usg_file_hash = old_hash } =
+  liftIO $
+    handleIO handle $ do
+      new_hash <- getFileHash file
+      if (old_hash /= new_hash)
+         then return recomp
+         else return UpToDate
+ where
+   recomp = RecompBecause (file ++ " changed")
+   handle =
+#if defined(DEBUG)
+       \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
+#else
+       \_ -> return recomp -- if we can't find the file, just recompile, don't fail
+#endif
+
+------------------------
+checkModuleFingerprint :: String -> Fingerprint -> Fingerprint
+                       -> IfG RecompileRequired
+checkModuleFingerprint reason old_mod_hash new_mod_hash
+  | new_mod_hash == old_mod_hash
+  = up_to_date (text "Module fingerprint unchanged")
+
+  | otherwise
+  = out_of_date_hash reason (text "  Module fingerprint has changed")
+                     old_mod_hash new_mod_hash
+
+------------------------
+checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc
+               -> IfG RecompileRequired -> IfG RecompileRequired
+checkMaybeHash reason maybe_old_hash new_hash doc continue
+  | Just hash <- maybe_old_hash, hash /= new_hash
+  = out_of_date_hash reason doc hash new_hash
+  | otherwise
+  = continue
+
+------------------------
+checkEntityUsage :: String
+                 -> (OccName -> Maybe (OccName, Fingerprint))
+                 -> (OccName, Fingerprint)
+                 -> IfG RecompileRequired
+checkEntityUsage reason new_hash (name,old_hash)
+  = case new_hash name of
+
+        Nothing       ->        -- We used it before, but it ain't there now
+                          out_of_date reason (sep [text "No longer exported:", ppr name])
+
+        Just (_, new_hash)      -- It's there, but is it up to date?
+          | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))
+                                       return UpToDate
+          | otherwise            -> out_of_date_hash reason (text "  Out of date:" <+> ppr name)
+                                                     old_hash new_hash
+
+up_to_date :: SDoc -> IfG RecompileRequired
+up_to_date  msg = traceHiDiffs msg >> return UpToDate
+
+out_of_date :: String -> SDoc -> IfG RecompileRequired
+out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)
+
+out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired
+out_of_date_hash reason msg old_hash new_hash
+  = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])
+
+----------------------
+checkList :: [IfG RecompileRequired] -> IfG RecompileRequired
+-- This helper is used in two places
+checkList []             = return UpToDate
+checkList (check:checks) = do recompile <- check
+                              if recompileRequired recompile
+                                then return recompile
+                                else checkList checks
+
+{-
+************************************************************************
+*                                                                      *
+                Converting things to their Iface equivalents
+*                                                                      *
+************************************************************************
+-}
+
+tyThingToIfaceDecl :: TyThing -> IfaceDecl
+tyThingToIfaceDecl (AnId id)      = idToIfaceDecl id
+tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)
+tyThingToIfaceDecl (ACoAxiom ax)  = coAxiomToIfaceDecl ax
+tyThingToIfaceDecl (AConLike cl)  = case cl of
+    RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only
+    PatSynCon ps   -> patSynToIfaceDecl ps
+
+--------------------------
+idToIfaceDecl :: Id -> IfaceDecl
+-- The Id is already tidied, so that locally-bound names
+-- (lambdas, for-alls) already have non-clashing OccNames
+-- We can't tidy it here, locally, because it may have
+-- free variables in its type or IdInfo
+idToIfaceDecl id
+  = IfaceId { ifName      = getName id,
+              ifType      = toIfaceType (idType id),
+              ifIdDetails = toIfaceIdDetails (idDetails id),
+              ifIdInfo    = toIfaceIdInfo (idInfo id) }
+
+--------------------------
+dataConToIfaceDecl :: DataCon -> IfaceDecl
+dataConToIfaceDecl dataCon
+  = IfaceId { ifName      = getName dataCon,
+              ifType      = toIfaceType (dataConUserType dataCon),
+              ifIdDetails = IfVanillaId,
+              ifIdInfo    = NoInfo }
+
+--------------------------
+coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl
+-- We *do* tidy Axioms, because they are not (and cannot
+-- conveniently be) built in tidy form
+coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
+                               , co_ax_role = role })
+ = IfaceAxiom { ifName       = getName ax
+              , ifTyCon      = toIfaceTyCon tycon
+              , ifRole       = role
+              , ifAxBranches = map (coAxBranchToIfaceBranch tycon
+                                     (map coAxBranchLHS branch_list))
+                                   branch_list }
+ where
+   branch_list = fromBranches branches
+
+-- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches
+-- to incompatible indices
+-- See Note [Storing compatibility] in CoAxiom
+coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch
+coAxBranchToIfaceBranch tc lhs_s
+                        branch@(CoAxBranch { cab_incomps = incomps })
+  = (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps }
+  where
+    iface_incomps = map (expectJust "iface_incomps"
+                        . (flip findIndex lhs_s
+                          . eqTypes)
+                        . coAxBranchLHS) incomps
+
+-- use this one for standalone branches without incompatibles
+coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch
+coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
+                                        , cab_eta_tvs = eta_tvs
+                                        , cab_lhs = lhs
+                                        , cab_roles = roles, cab_rhs = rhs })
+  = IfaceAxBranch { ifaxbTyVars    = toIfaceTvBndrs tvs
+                  , ifaxbCoVars    = map toIfaceIdBndr cvs
+                  , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs
+                  , ifaxbLHS       = toIfaceTcArgs tc lhs
+                  , ifaxbRoles     = roles
+                  , ifaxbRHS       = toIfaceType rhs
+                  , ifaxbIncomps   = [] }
+
+-----------------
+tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)
+-- We *do* tidy TyCons, because they are not (and cannot
+-- conveniently be) built in tidy form
+-- The returned TidyEnv is the one after tidying the tyConTyVars
+tyConToIfaceDecl env tycon
+  | Just clas <- tyConClass_maybe tycon
+  = classToIfaceDecl env clas
+
+  | Just syn_rhs <- synTyConRhs_maybe tycon
+  = ( tc_env1
+    , IfaceSynonym { ifName    = getName tycon,
+                     ifRoles   = tyConRoles tycon,
+                     ifSynRhs  = if_syn_type syn_rhs,
+                     ifBinders = if_binders,
+                     ifResKind = if_res_kind
+                   })
+
+  | Just fam_flav <- famTyConFlav_maybe tycon
+  = ( tc_env1
+    , IfaceFamily { ifName    = getName tycon,
+                    ifResVar  = if_res_var,
+                    ifFamFlav = to_if_fam_flav fam_flav,
+                    ifBinders = if_binders,
+                    ifResKind = if_res_kind,
+                    ifFamInj  = tyConInjectivityInfo tycon
+                  })
+
+  | isAlgTyCon tycon
+  = ( tc_env1
+    , IfaceData { ifName    = getName tycon,
+                  ifBinders = if_binders,
+                  ifResKind = if_res_kind,
+                  ifCType   = tyConCType tycon,
+                  ifRoles   = tyConRoles tycon,
+                  ifCtxt    = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
+                  ifCons    = ifaceConDecls (algTyConRhs tycon),
+                  ifGadtSyntax = isGadtSyntaxTyCon tycon,
+                  ifParent  = parent })
+
+  | otherwise  -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
+  -- We only convert these TyCons to IfaceTyCons when we are
+  -- just about to pretty-print them, not because we are going
+  -- to put them into interface files
+  = ( env
+    , IfaceData { ifName       = getName tycon,
+                  ifBinders    = if_binders,
+                  ifResKind    = if_res_kind,
+                  ifCType      = Nothing,
+                  ifRoles      = tyConRoles tycon,
+                  ifCtxt       = [],
+                  ifCons       = IfDataTyCon [],
+                  ifGadtSyntax = False,
+                  ifParent     = IfNoParent })
+  where
+    -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon`
+    -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause
+    -- an error.
+    (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
+    tc_tyvars      = binderVars tc_binders
+    if_binders     = toIfaceTyCoVarBinders tc_binders
+                     -- No tidying of the binders; they are already tidy
+    if_res_kind    = tidyToIfaceType tc_env1 (tyConResKind tycon)
+    if_syn_type ty = tidyToIfaceType tc_env1 ty
+    if_res_var     = getOccFS `fmap` tyConFamilyResVar_maybe tycon
+
+    parent = case tyConFamInstSig_maybe tycon of
+               Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)
+                                                   (toIfaceTyCon tc)
+                                                   (tidyToIfaceTcArgs tc_env1 tc ty)
+               Nothing           -> IfNoParent
+
+    to_if_fam_flav OpenSynFamilyTyCon             = IfaceOpenSynFamilyTyCon
+    to_if_fam_flav AbstractClosedSynFamilyTyCon   = IfaceAbstractClosedSynFamilyTyCon
+    to_if_fam_flav (DataFamilyTyCon {})           = IfaceDataFamilyTyCon
+    to_if_fam_flav (BuiltInSynFamTyCon {})        = IfaceBuiltInSynFamTyCon
+    to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing
+    to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))
+      = IfaceClosedSynFamilyTyCon (Just (axn, ibr))
+      where defs = fromBranches $ coAxiomBranches ax
+            ibr  = map (coAxBranchToIfaceBranch' tycon) defs
+            axn  = coAxiomName ax
+
+    ifaceConDecls (NewTyCon { data_con = con })    = IfNewTyCon  (ifaceConDecl con)
+    ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
+    ifaceConDecls (TupleTyCon { data_con = con })  = IfDataTyCon [ifaceConDecl con]
+    ifaceConDecls (SumTyCon { data_cons = cons })  = IfDataTyCon (map ifaceConDecl cons)
+    ifaceConDecls AbstractTyCon                    = IfAbstractTyCon
+        -- The AbstractTyCon case happens when a TyCon has been trimmed
+        -- during tidying.
+        -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver
+        -- for GHCi, when browsing a module, in which case the
+        -- AbstractTyCon and TupleTyCon cases are perfectly sensible.
+        -- (Tuple declarations are not serialised into interface files.)
+
+    ifaceConDecl data_con
+        = IfCon   { ifConName    = dataConName data_con,
+                    ifConInfix   = dataConIsInfix data_con,
+                    ifConWrapper = isJust (dataConWrapId_maybe data_con),
+                    ifConExTCvs  = map toIfaceBndr ex_tvs',
+                    ifConUserTvBinders = map toIfaceForAllBndr user_bndrs',
+                    ifConEqSpec  = map (to_eq_spec . eqSpecPair) eq_spec,
+                    ifConCtxt    = tidyToIfaceContext con_env2 theta,
+                    ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,
+                    ifConFields  = dataConFieldLabels data_con,
+                    ifConStricts = map (toIfaceBang con_env2)
+                                       (dataConImplBangs data_con),
+                    ifConSrcStricts = map toIfaceSrcBang
+                                          (dataConSrcBangs data_con)}
+        where
+          (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
+            = dataConFullSig data_con
+          user_bndrs = dataConUserTyVarBinders data_con
+
+          -- Tidy the univ_tvs of the data constructor to be identical
+          -- to the tyConTyVars of the type constructor.  This means
+          -- (a) we don't need to redundantly put them into the interface file
+          -- (b) when pretty-printing an Iface data declaration in H98-style syntax,
+          --     we know that the type variables will line up
+          -- The latter (b) is important because we pretty-print type constructors
+          -- by converting to IfaceSyn and pretty-printing that
+          con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
+                     -- A bit grimy, perhaps, but it's simple!
+
+          (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs
+          user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs
+          to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)
+
+          -- By this point, we have tidied every universal and existential
+          -- tyvar. Because of the dcUserTyCoVarBinders invariant
+          -- (see Note [DataCon user type variable binders]), *every*
+          -- user-written tyvar must be contained in the substitution that
+          -- tidying produced. Therefore, tidying the user-written tyvars is a
+          -- simple matter of looking up each variable in the substitution,
+          -- which tidyTyCoVarOcc accomplishes.
+          tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder
+          tidyUserTyCoVarBinder env (Bndr tv vis) =
+            Bndr (tidyTyCoVarOcc env tv) vis
+
+classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
+classToIfaceDecl env clas
+  = ( env1
+    , IfaceClass { ifName   = getName tycon,
+                   ifRoles  = tyConRoles (classTyCon clas),
+                   ifBinders = toIfaceTyCoVarBinders tc_binders,
+                   ifBody   = body,
+                   ifFDs    = map toIfaceFD clas_fds })
+  where
+    (_, clas_fds, sc_theta, _, clas_ats, op_stuff)
+      = classExtraBigSig clas
+    tycon = classTyCon clas
+
+    body | isAbstractTyCon tycon = IfAbstractClass
+         | otherwise
+         = IfConcreteClass {
+                ifClassCtxt   = tidyToIfaceContext env1 sc_theta,
+                ifATs    = map toIfaceAT clas_ats,
+                ifSigs   = map toIfaceClassOp op_stuff,
+                ifMinDef = fmap getOccFS (classMinimalDef clas)
+            }
+
+    (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)
+
+    toIfaceAT :: ClassATItem -> IfaceAT
+    toIfaceAT (ATI tc def)
+      = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)
+      where
+        (env2, if_decl) = tyConToIfaceDecl env1 tc
+
+    toIfaceClassOp (sel_id, def_meth)
+        = ASSERT( sel_tyvars == binderVars tc_binders )
+          IfaceClassOp (getName sel_id)
+                       (tidyToIfaceType env1 op_ty)
+                       (fmap toDmSpec def_meth)
+        where
+                -- Be careful when splitting the type, because of things
+                -- like         class Foo a where
+                --                op :: (?x :: String) => a -> a
+                -- and          class Baz a where
+                --                op :: (Ord a) => a -> a
+          (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
+          op_ty                = funResultTy rho_ty
+
+    toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType
+    toDmSpec (_, VanillaDM)       = VanillaDM
+    toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)
+
+    toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1
+                             ,map (tidyTyVar env1) tvs2)
+
+--------------------------
+
+tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)
+-- If the type variable "binder" is in scope, don't re-bind it
+-- In a class decl, for example, the ATD binders mention
+-- (amd must mention) the class tyvars
+tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)
+ = case lookupVarEnv subst tv of
+     Just tv' -> (env,  Bndr tv' vis)
+     Nothing  -> tidyTyCoVarBinder env tvb
+
+tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])
+tidyTyConBinders = mapAccumL tidyTyConBinder
+
+tidyTyVar :: TidyEnv -> TyVar -> FastString
+tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)
+
+--------------------------
+instanceToIfaceInst :: ClsInst -> IfaceClsInst
+instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
+                             , is_cls_nm = cls_name, is_cls = cls
+                             , is_tcs = mb_tcs
+                             , is_orphan = orph })
+  = ASSERT( cls_name == className cls )
+    IfaceClsInst { ifDFun    = dfun_name,
+                ifOFlag   = oflag,
+                ifInstCls = cls_name,
+                ifInstTys = map do_rough mb_tcs,
+                ifInstOrph = orph }
+  where
+    do_rough Nothing  = Nothing
+    do_rough (Just n) = Just (toIfaceTyCon_name n)
+
+    dfun_name = idName dfun_id
+
+
+--------------------------
+famInstToIfaceFamInst :: FamInst -> IfaceFamInst
+famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,
+                                 fi_fam      = fam,
+                                 fi_tcs      = roughs })
+  = IfaceFamInst { ifFamInstAxiom    = coAxiomName axiom
+                 , ifFamInstFam      = fam
+                 , ifFamInstTys      = map do_rough roughs
+                 , ifFamInstOrph     = orph }
+  where
+    do_rough Nothing  = Nothing
+    do_rough (Just n) = Just (toIfaceTyCon_name n)
+
+    fam_decl = tyConName $ coAxiomTyCon axiom
+    mod = ASSERT( isExternalName (coAxiomName axiom) )
+          nameModule (coAxiomName axiom)
+    is_local name = nameIsLocalOrFrom mod name
+
+    lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)
+
+    orph | is_local fam_decl
+         = NotOrphan (nameOccName fam_decl)
+         | otherwise
+         = chooseOrphanAnchor lhs_names
+
+--------------------------
+coreRuleToIfaceRule :: CoreRule -> IfaceRule
+coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})
+  = pprTrace "toHsRule: builtin" (ppr fn) $
+    bogusIfaceRule fn
+
+coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,
+                            ru_act = act, ru_bndrs = bndrs,
+                            ru_args = args, ru_rhs = rhs,
+                            ru_orphan = orph, ru_auto = auto })
+  = IfaceRule { ifRuleName  = name, ifActivation = act,
+                ifRuleBndrs = map toIfaceBndr bndrs,
+                ifRuleHead  = fn,
+                ifRuleArgs  = map do_arg args,
+                ifRuleRhs   = toIfaceExpr rhs,
+                ifRuleAuto  = auto,
+                ifRuleOrph  = orph }
+  where
+        -- For type args we must remove synonyms from the outermost
+        -- level.  Reason: so that when we read it back in we'll
+        -- construct the same ru_rough field as we have right now;
+        -- see tcIfaceRule
+    do_arg (Type ty)     = IfaceType (toIfaceType (deNoteType ty))
+    do_arg (Coercion co) = IfaceCo   (toIfaceCoercion co)
+    do_arg arg           = toIfaceExpr arg
+
+bogusIfaceRule :: Name -> IfaceRule
+bogusIfaceRule id_name
+  = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
+        ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
+        ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,
+        ifRuleAuto = True }
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
new file mode 100644
--- /dev/null
+++ b/compiler/iface/TcIface.hs
@@ -0,0 +1,1822 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Type checking of type signatures in interface files
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+
+module TcIface (
+        tcLookupImported_maybe,
+        importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
+        typecheckIfacesForMerging,
+        typecheckIfaceForInstantiate,
+        tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
+        tcIfaceAnnotations, tcIfaceCompleteSigs,
+        tcIfaceExpr,    -- Desired by HERMIT (Trac #7683)
+        tcIfaceGlobal
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcTypeNats(typeNatCoAxiomRules)
+import IfaceSyn
+import LoadIface
+import IfaceEnv
+import BuildTyCl
+import TcRnMonad
+import TcType
+import Type
+import Coercion
+import CoAxiom
+import TyCoRep    -- needs to build types & coercions in a knot
+import HscTypes
+import Annotations
+import InstEnv
+import FamInstEnv
+import CoreSyn
+import CoreUtils
+import CoreUnfold
+import CoreLint
+import MkCore
+import Id
+import MkId
+import IdInfo
+import Class
+import TyCon
+import ConLike
+import DataCon
+import PrelNames
+import TysWiredIn
+import Literal
+import Var
+import VarSet
+import Name
+import NameEnv
+import NameSet
+import OccurAnal        ( occurAnalyseExpr )
+import Demand
+import Module
+import UniqFM
+import UniqSupply
+import Outputable
+import Maybes
+import SrcLoc
+import DynFlags
+import Util
+import FastString
+import BasicTypes hiding ( SuccessFlag(..) )
+import ListSetOps
+import GHC.Fingerprint
+import qualified BooleanFormula as BF
+
+import Control.Monad
+import qualified Data.Map as Map
+
+{-
+This module takes
+
+        IfaceDecl -> TyThing
+        IfaceType -> Type
+        etc
+
+An IfaceDecl is populated with RdrNames, and these are not renamed to
+Names before typechecking, because there should be no scope errors etc.
+
+        -- For (b) consider: f = \$(...h....)
+        -- where h is imported, and calls f via an hi-boot file.
+        -- This is bad!  But it is not seen as a staging error, because h
+        -- is indeed imported.  We don't want the type-checker to black-hole
+        -- when simplifying and compiling the splice!
+        --
+        -- Simple solution: discard any unfolding that mentions a variable
+        -- bound in this module (and hence not yet processed).
+        -- The discarding happens when forkM finds a type error.
+
+
+************************************************************************
+*                                                                      *
+                Type-checking a complete interface
+*                                                                      *
+************************************************************************
+
+Suppose we discover we don't need to recompile.  Then we must type
+check the old interface file.  This is a bit different to the
+incremental type checking we do as we suck in interface files.  Instead
+we do things similarly as when we are typechecking source decls: we
+bring into scope the type envt for the interface all at once, using a
+knot.  Remember, the decls aren't necessarily in dependency order --
+and even if they were, the type decls might be mutually recursive.
+
+Note [Knot-tying typecheckIface]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are typechecking an interface A.hi, and we come across
+a Name for another entity defined in A.hi.  How do we get the
+'TyCon', in this case?  There are three cases:
+
+    1) tcHiBootIface in TcIface: We're typechecking an hi-boot file in
+    preparation of checking if the hs file we're building
+    is compatible.  In this case, we want all of the internal
+    TyCons to MATCH the ones that we just constructed during
+    typechecking: the knot is thus tied through if_rec_types.
+
+    2) retypecheckLoop in GhcMake: We are retypechecking a
+    mutually recursive cluster of hi files, in order to ensure
+    that all of the references refer to each other correctly.
+    In this case, the knot is tied through the HPT passed in,
+    which contains all of the interfaces we are in the process
+    of typechecking.
+
+    3) genModDetails in HscMain: We are typechecking an
+    old interface to generate the ModDetails.  In this case,
+    we do the same thing as (2) and pass in an HPT with
+    the HomeModInfo being generated to tie knots.
+
+The upshot is that the CLIENT of this function is responsible
+for making sure that the knot is tied correctly.  If you don't,
+then you'll get a message saying that we couldn't load the
+declaration you wanted.
+
+BTW, in one-shot mode we never call typecheckIface; instead,
+loadInterface handles type-checking interface.  In that case,
+knots are tied through the EPS.  No problem!
+-}
+
+-- Clients of this function be careful, see Note [Knot-tying typecheckIface]
+typecheckIface :: ModIface      -- Get the decls from here
+               -> IfG ModDetails
+typecheckIface iface
+  = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do
+        {       -- Get the right set of decls and rules.  If we are compiling without -O
+                -- we discard pragmas before typechecking, so that we don't "see"
+                -- information that we shouldn't.  From a versioning point of view
+                -- It's not actually *wrong* to do so, but in fact GHCi is unable
+                -- to handle unboxed tuples, so it must not see unfoldings.
+          ignore_prags <- goptM Opt_IgnoreInterfacePragmas
+
+                -- Typecheck the decls.  This is done lazily, so that the knot-tying
+                -- within this single module works out right.  It's the callers
+                -- job to make sure the knot is tied.
+        ; names_w_things <- loadDecls ignore_prags (mi_decls iface)
+        ; let type_env = mkNameEnv names_w_things
+
+                -- Now do those rules, instances and annotations
+        ; insts     <- mapM tcIfaceInst (mi_insts iface)
+        ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
+        ; rules     <- tcIfaceRules ignore_prags (mi_rules iface)
+        ; anns      <- tcIfaceAnnotations (mi_anns iface)
+
+                -- Exports
+        ; exports <- ifaceExportNames (mi_exports iface)
+
+                -- Complete Sigs
+        ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
+
+                -- Finished
+        ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),
+                         -- Careful! If we tug on the TyThing thunks too early
+                         -- we'll infinite loop with hs-boot.  See #10083 for
+                         -- an example where this would cause non-termination.
+                         text "Type envt:" <+> ppr (map fst names_w_things)])
+        ; return $ ModDetails { md_types     = type_env
+                              , md_insts     = insts
+                              , md_fam_insts = fam_insts
+                              , md_rules     = rules
+                              , md_anns      = anns
+                              , md_exports   = exports
+                              , md_complete_sigs = complete_sigs
+                              }
+    }
+
+{-
+************************************************************************
+*                                                                      *
+                Typechecking for merging
+*                                                                      *
+************************************************************************
+-}
+
+-- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type)
+isAbstractIfaceDecl :: IfaceDecl -> Bool
+isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True
+isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True
+isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True
+isAbstractIfaceDecl _ = False
+
+ifMaybeRoles :: IfaceDecl -> Maybe [Role]
+ifMaybeRoles IfaceData    { ifRoles = rs } = Just rs
+ifMaybeRoles IfaceSynonym { ifRoles = rs } = Just rs
+ifMaybeRoles IfaceClass   { ifRoles = rs } = Just rs
+ifMaybeRoles _ = Nothing
+
+-- | Merge two 'IfaceDecl's together, preferring a non-abstract one.  If
+-- both are non-abstract we pick one arbitrarily (and check for consistency
+-- later.)
+mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl
+mergeIfaceDecl d1 d2
+    | isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1
+    | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2
+    | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1
+    , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2
+    = let ops = nameEnvElts $
+                  plusNameEnv_C mergeIfaceClassOp
+                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])
+                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])
+      in d1 { ifBody = (ifBody d1) {
+                ifSigs  = ops,
+                ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2]
+                }
+            } `withRolesFrom` d2
+    -- It doesn't matter; we'll check for consistency later when
+    -- we merge, see 'mergeSignatures'
+    | otherwise              = d1 `withRolesFrom` d2
+
+-- Note [Role merging]
+-- ~~~~~~~~~~~~~~~~~~~
+-- First, why might it be necessary to do a non-trivial role
+-- merge?  It may rescue a merge that might otherwise fail:
+--
+--      signature A where
+--          type role T nominal representational
+--          data T a b
+--
+--      signature A where
+--          type role T representational nominal
+--          data T a b
+--
+-- A module that defines T as representational in both arguments
+-- would successfully fill both signatures, so it would be better
+-- if we merged the roles of these types in some nontrivial
+-- way.
+--
+-- However, we have to be very careful about how we go about
+-- doing this, because role subtyping is *conditional* on
+-- the supertype being NOT representationally injective, e.g.,
+-- if we have instead:
+--
+--      signature A where
+--          type role T nominal representational
+--          data T a b = T a b
+--
+--      signature A where
+--          type role T representational nominal
+--          data T a b = T a b
+--
+-- Should we merge the definitions of T so that the roles are R/R (or N/N)?
+-- Absolutely not: neither resulting type is a subtype of the original
+-- types (see Note [Role subtyping]), because data is not representationally
+-- injective.
+--
+-- Thus, merging only occurs when BOTH TyCons in question are
+-- representationally injective.  If they're not, no merge.
+
+withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl
+d1 `withRolesFrom` d2
+    | Just roles1 <- ifMaybeRoles d1
+    , Just roles2 <- ifMaybeRoles d2
+    , not (isRepInjectiveIfaceDecl d1 || isRepInjectiveIfaceDecl d2)
+    = d1 { ifRoles = mergeRoles roles1 roles2 }
+    | otherwise = d1
+  where
+    mergeRoles roles1 roles2 = zipWith max roles1 roles2
+
+isRepInjectiveIfaceDecl :: IfaceDecl -> Bool
+isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True
+isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True
+isRepInjectiveIfaceDecl _ = False
+
+mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp
+mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1
+mergeIfaceClassOp _ op2 = op2
+
+-- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'.
+mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl
+mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl
+
+-- | This is a very interesting function.  Like typecheckIface, we want
+-- to type check an interface file into a ModDetails.  However, the use-case
+-- for these ModDetails is different: we want to compare all of the
+-- ModDetails to ensure they define compatible declarations, and then
+-- merge them together.  So in particular, we have to take a different
+-- strategy for knot-tying: we first speculatively merge the declarations
+-- to get the "base" truth for what we believe the types will be
+-- (this is "type computation.")  Then we read everything in relative
+-- to this truth and check for compatibility.
+--
+-- During the merge process, we may need to nondeterministically
+-- pick a particular declaration to use, if multiple signatures define
+-- the declaration ('mergeIfaceDecl').  If, for all choices, there
+-- are no type synonym cycles in the resulting merged graph, then
+-- we can show that our choice cannot matter. Consider the
+-- set of entities which the declarations depend on: by assumption
+-- of acyclicity, we can assume that these have already been shown to be equal
+-- to each other (otherwise merging will fail).  Then it must
+-- be the case that all candidate declarations here are type-equal
+-- (the choice doesn't matter) or there is an inequality (in which
+-- case merging will fail.)
+--
+-- Unfortunately, the choice can matter if there is a cycle.  Consider the
+-- following merge:
+--
+--      signature H where { type A = C;  type B = A; data C      }
+--      signature H where { type A = (); data B;     type C = B  }
+--
+-- If we pick @type A = C@ as our representative, there will be
+-- a cycle and merging will fail. But if we pick @type A = ()@ as
+-- our representative, no cycle occurs, and we instead conclude
+-- that all of the types are unit.  So it seems that we either
+-- (a) need a stronger acyclicity check which considers *all*
+-- possible choices from a merge, or (b) we must find a selection
+-- of declarations which is acyclic, and show that this is always
+-- the "best" choice we could have made (ezyang conjectures this
+-- is the case but does not have a proof).  For now this is
+-- not implemented.
+--
+-- It's worth noting that at the moment, a data constructor and a
+-- type synonym are never compatible.  Consider:
+--
+--      signature H where { type Int=C;         type B = Int; data C = Int}
+--      signature H where { export Prelude.Int; data B;       type C = B; }
+--
+-- This will be rejected, because the reexported Int in the second
+-- signature (a proper data type) is never considered equal to a
+-- type synonym.  Perhaps this should be relaxed, where a type synonym
+-- in a signature is considered implemented by a data type declaration
+-- which matches the reference of the type synonym.
+typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])
+typecheckIfacesForMerging mod ifaces tc_env_var =
+  -- cannot be boot (False)
+  initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do
+    ignore_prags <- goptM Opt_IgnoreInterfacePragmas
+    -- Build the initial environment
+    -- NB: Don't include dfuns here, because we don't want to
+    -- serialize them out.  See Note [rnIfaceNeverExported] in RnModIface
+    -- NB: But coercions are OK, because they will have the right OccName.
+    let mk_decl_env decls
+            = mkOccEnv [ (getOccName decl, decl)
+                       | decl <- decls
+                       , case decl of
+                            IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns
+                            _ -> True ]
+        decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces
+                        :: [OccEnv IfaceDecl]
+        decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs
+                        ::  OccEnv IfaceDecl
+    -- TODO: change loadDecls to accept w/o Fingerprint
+    names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x))
+                                                  (occEnvElts decl_env))
+    let global_type_env = mkNameEnv names_w_things
+    writeMutVar tc_env_var global_type_env
+
+    -- OK, now typecheck each ModIface using this environment
+    details <- forM ifaces $ \iface -> do
+        -- See Note [Resolving never-exported Names in TcIface]
+        type_env <- fixM $ \type_env -> do
+            setImplicitEnvM type_env $ do
+                decls <- loadDecls ignore_prags (mi_decls iface)
+                return (mkNameEnv decls)
+        -- But note that we use this type_env to typecheck references to DFun
+        -- in 'IfaceInst'
+        setImplicitEnvM type_env $ do
+        insts     <- mapM tcIfaceInst (mi_insts iface)
+        fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
+        rules     <- tcIfaceRules ignore_prags (mi_rules iface)
+        anns      <- tcIfaceAnnotations (mi_anns iface)
+        exports   <- ifaceExportNames (mi_exports iface)
+        complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
+        return $ ModDetails { md_types     = type_env
+                            , md_insts     = insts
+                            , md_fam_insts = fam_insts
+                            , md_rules     = rules
+                            , md_anns      = anns
+                            , md_exports   = exports
+                            , md_complete_sigs = complete_sigs
+                            }
+    return (global_type_env, details)
+
+-- | Typecheck a signature 'ModIface' under the assumption that we have
+-- instantiated it under some implementation (recorded in 'mi_semantic_module')
+-- and want to check if the implementation fills the signature.
+--
+-- This needs to operate slightly differently than 'typecheckIface'
+-- because (1) we have a 'NameShape', from the exports of the
+-- implementing module, which we will use to give our top-level
+-- declarations the correct 'Name's even when the implementor
+-- provided them with a reexport, and (2) we have to deal with
+-- DFun silliness (see Note [rnIfaceNeverExported])
+typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails
+typecheckIfaceForInstantiate nsubst iface =
+  initIfaceLclWithSubst (mi_semantic_module iface)
+                        (text "typecheckIfaceForInstantiate")
+                        (mi_boot iface) nsubst $ do
+    ignore_prags <- goptM Opt_IgnoreInterfacePragmas
+    -- See Note [Resolving never-exported Names in TcIface]
+    type_env <- fixM $ \type_env -> do
+        setImplicitEnvM type_env $ do
+            decls     <- loadDecls ignore_prags (mi_decls iface)
+            return (mkNameEnv decls)
+    -- See Note [rnIfaceNeverExported]
+    setImplicitEnvM type_env $ do
+    insts     <- mapM tcIfaceInst (mi_insts iface)
+    fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
+    rules     <- tcIfaceRules ignore_prags (mi_rules iface)
+    anns      <- tcIfaceAnnotations (mi_anns iface)
+    exports   <- ifaceExportNames (mi_exports iface)
+    complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)
+    return $ ModDetails { md_types     = type_env
+                        , md_insts     = insts
+                        , md_fam_insts = fam_insts
+                        , md_rules     = rules
+                        , md_anns      = anns
+                        , md_exports   = exports
+                        , md_complete_sigs = complete_sigs
+                        }
+
+-- Note [Resolving never-exported Names in TcIface]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- For the high-level overview, see
+-- Note [Handling never-exported TyThings under Backpack]
+--
+-- As described in 'typecheckIfacesForMerging', the splendid innovation
+-- of signature merging is to rewrite all Names in each of the signatures
+-- we are merging together to a pre-merged structure; this is the key
+-- ingredient that lets us solve some problems when merging type
+-- synonyms.
+--
+-- However, when a 'Name' refers to a NON-exported entity, as is the
+-- case with the DFun of a ClsInst, or a CoAxiom of a type family,
+-- this strategy causes problems: if we pick one and rewrite all
+-- references to a shared 'Name', we will accidentally fail to check
+-- if the DFun or CoAxioms are compatible, as they will never be
+-- checked--only exported entities are checked for compatibility,
+-- and a non-exported TyThing is checked WHEN we are checking the
+-- ClsInst or type family for compatibility in checkBootDeclM.
+-- By virtue of the fact that everything's been pointed to the merged
+-- declaration, you'll never notice there's a difference even if there
+-- is one.
+--
+-- Fortunately, there are only a few places in the interface declarations
+-- where this can occur, so we replace those calls with 'tcIfaceImplicit',
+-- which will consult a local TypeEnv that records any never-exported
+-- TyThings which we should wire up with.
+--
+-- Note that we actually knot-tie this local TypeEnv (the 'fixM'), because a
+-- type family can refer to a coercion axiom, all of which are done in one go
+-- when we typecheck 'mi_decls'.  An alternate strategy would be to typecheck
+-- coercions first before type families, but that seemed more fragile.
+--
+
+{-
+************************************************************************
+*                                                                      *
+                Type and class declarations
+*                                                                      *
+************************************************************************
+-}
+
+tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo
+-- Load the hi-boot iface for the module being compiled,
+-- if it indeed exists in the transitive closure of imports
+-- Return the ModDetails; Nothing if no hi-boot iface
+tcHiBootIface hsc_src mod
+  | HsBootFile <- hsc_src            -- Already compiling a hs-boot file
+  = return NoSelfBoot
+  | otherwise
+  = do  { traceIf (text "loadHiBootInterface" <+> ppr mod)
+
+        ; mode <- getGhcMode
+        ; if not (isOneShot mode)
+                -- In --make and interactive mode, if this module has an hs-boot file
+                -- we'll have compiled it already, and it'll be in the HPT
+                --
+                -- We check wheher the interface is a *boot* interface.
+                -- It can happen (when using GHC from Visual Studio) that we
+                -- compile a module in TypecheckOnly mode, with a stable,
+                -- fully-populated HPT.  In that case the boot interface isn't there
+                -- (it's been replaced by the mother module) so we can't check it.
+                -- And that's fine, because if M's ModInfo is in the HPT, then
+                -- it's been compiled once, and we don't need to check the boot iface
+          then do { hpt <- getHpt
+                 ; case lookupHpt hpt (moduleName mod) of
+                      Just info | mi_boot (hm_iface info)
+                                -> mkSelfBootInfo (hm_iface info) (hm_details info)
+                      _ -> return NoSelfBoot }
+          else do
+
+        -- OK, so we're in one-shot mode.
+        -- Re #9245, we always check if there is an hi-boot interface
+        -- to check consistency against, rather than just when we notice
+        -- that an hi-boot is necessary due to a circular import.
+        { read_result <- findAndReadIface
+                                need (fst (splitModuleInsts mod)) mod
+                                True    -- Hi-boot file
+
+        ; case read_result of {
+            Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface
+                                           ; mkSelfBootInfo iface tc_iface } ;
+            Failed err               ->
+
+        -- There was no hi-boot file. But if there is circularity in
+        -- the module graph, there really should have been one.
+        -- Since we've read all the direct imports by now,
+        -- eps_is_boot will record if any of our imports mention the
+        -- current module, which either means a module loop (not
+        -- a SOURCE import) or that our hi-boot file has mysteriously
+        -- disappeared.
+    do  { eps <- getEps
+        ; case lookupUFM (eps_is_boot eps) (moduleName mod) of
+            Nothing -> return NoSelfBoot -- The typical case
+
+            Just (_, False) -> failWithTc moduleLoop
+                -- Someone below us imported us!
+                -- This is a loop with no hi-boot in the way
+
+            Just (_mod, True) -> failWithTc (elaborate err)
+                -- The hi-boot file has mysteriously disappeared.
+    }}}}
+  where
+    need = text "Need the hi-boot interface for" <+> ppr mod
+                 <+> text "to compare against the Real Thing"
+
+    moduleLoop = text "Circular imports: module" <+> quotes (ppr mod)
+                     <+> text "depends on itself"
+
+    elaborate err = hang (text "Could not find hi-boot interface for" <+>
+                          quotes (ppr mod) <> colon) 4 err
+
+
+mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo
+mkSelfBootInfo iface mds
+  = do -- NB: This is computed DIRECTLY from the ModIface rather
+       -- than from the ModDetails, so that we can query 'sb_tcs'
+       -- WITHOUT forcing the contents of the interface.
+       let tcs = map ifName
+                 . filter isIfaceTyCon
+                 . map snd
+                 $ mi_decls iface
+       return $ SelfBoot { sb_mds = mds
+                         , sb_tcs = mkNameSet tcs }
+  where
+    -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on
+    -- this 'IfaceDecl', an ATyCon would be returned.
+    -- NB: This code assumes that a TyCon cannot be implicit.
+    isIfaceTyCon IfaceId{}      = False
+    isIfaceTyCon IfaceData{}    = True
+    isIfaceTyCon IfaceSynonym{} = True
+    isIfaceTyCon IfaceFamily{}  = True
+    isIfaceTyCon IfaceClass{}   = True
+    isIfaceTyCon IfaceAxiom{}   = False
+    isIfaceTyCon IfacePatSyn{}  = False
+
+{-
+************************************************************************
+*                                                                      *
+                Type and class declarations
+*                                                                      *
+************************************************************************
+
+When typechecking a data type decl, we *lazily* (via forkM) typecheck
+the constructor argument types.  This is in the hope that we may never
+poke on those argument types, and hence may never need to load the
+interface files for types mentioned in the arg types.
+
+E.g.
+        data Foo.S = MkS Baz.T
+Maybe we can get away without even loading the interface for Baz!
+
+This is not just a performance thing.  Suppose we have
+        data Foo.S = MkS Baz.T
+        data Baz.T = MkT Foo.S
+(in different interface files, of course).
+Now, first we load and typecheck Foo.S, and add it to the type envt.
+If we do explore MkS's argument, we'll load and typecheck Baz.T.
+If we explore MkT's argument we'll find Foo.S already in the envt.
+
+If we typechecked constructor args eagerly, when loading Foo.S we'd try to
+typecheck the type Baz.T.  So we'd fault in Baz.T... and then need Foo.S...
+which isn't done yet.
+
+All very cunning. However, there is a rather subtle gotcha which bit
+me when developing this stuff.  When we typecheck the decl for S, we
+extend the type envt with S, MkS, and all its implicit Ids.  Suppose
+(a bug, but it happened) that the list of implicit Ids depended in
+turn on the constructor arg types.  Then the following sequence of
+events takes place:
+        * we build a thunk <t> for the constructor arg tys
+        * we build a thunk for the extended type environment (depends on <t>)
+        * we write the extended type envt into the global EPS mutvar
+
+Now we look something up in the type envt
+        * that pulls on <t>
+        * which reads the global type envt out of the global EPS mutvar
+        * but that depends in turn on <t>
+
+It's subtle, because, it'd work fine if we typechecked the constructor args
+eagerly -- they don't need the extended type envt.  They just get the extended
+type envt by accident, because they look at it later.
+
+What this means is that the implicitTyThings MUST NOT DEPEND on any of
+the forkM stuff.
+-}
+
+tcIfaceDecl :: Bool     -- ^ True <=> discard IdInfo on IfaceId bindings
+            -> IfaceDecl
+            -> IfL TyThing
+tcIfaceDecl = tc_iface_decl Nothing
+
+tc_iface_decl :: Maybe Class  -- ^ For associated type/data family declarations
+              -> Bool         -- ^ True <=> discard IdInfo on IfaceId bindings
+              -> IfaceDecl
+              -> IfL TyThing
+tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,
+                                       ifIdDetails = details, ifIdInfo = info})
+  = do  { ty <- tcIfaceType iface_type
+        ; details <- tcIdDetails ty details
+        ; info <- tcIdInfo ignore_prags TopLevel name ty info
+        ; return (AnId (mkGlobalId details name ty info)) }
+
+tc_iface_decl _ _ (IfaceData {ifName = tc_name,
+                          ifCType = cType,
+                          ifBinders = binders,
+                          ifResKind = res_kind,
+                          ifRoles = roles,
+                          ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
+                          ifCons = rdr_cons,
+                          ifParent = mb_parent })
+  = bindIfaceTyConBinders_AT binders $ \ binders' -> do
+    { res_kind' <- tcIfaceType res_kind
+
+    ; tycon <- fixM $ \ tycon -> do
+            { stupid_theta <- tcIfaceCtxt ctxt
+            ; parent' <- tc_parent tc_name mb_parent
+            ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons
+            ; return (mkAlgTyCon tc_name binders' res_kind'
+                                 roles cType stupid_theta
+                                 cons parent' gadt_syn) }
+    ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
+    ; return (ATyCon tycon) }
+  where
+    tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav
+    tc_parent tc_name IfNoParent
+      = do { tc_rep_name <- newTyConRepName tc_name
+           ; return (VanillaAlgTyCon tc_rep_name) }
+    tc_parent _ (IfDataInstance ax_name _ arg_tys)
+      = do { ax <- tcIfaceCoAxiom ax_name
+           ; let fam_tc  = coAxiomTyCon ax
+                 ax_unbr = toUnbranchedAxiom ax
+           ; lhs_tys <- tcIfaceAppArgs arg_tys
+           ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }
+
+tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name,
+                                      ifRoles = roles,
+                                      ifSynRhs = rhs_ty,
+                                      ifBinders = binders,
+                                      ifResKind = res_kind })
+   = bindIfaceTyConBinders_AT binders $ \ binders' -> do
+     { res_kind' <- tcIfaceType res_kind     -- Note [Synonym kind loop]
+     ; rhs      <- forkM (mk_doc tc_name) $
+                   tcIfaceType rhs_ty
+     ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs
+     ; return (ATyCon tycon) }
+   where
+     mk_doc n = text "Type synonym" <+> ppr n
+
+tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,
+                                     ifFamFlav = fam_flav,
+                                     ifBinders = binders,
+                                     ifResKind = res_kind,
+                                     ifResVar = res, ifFamInj = inj })
+   = bindIfaceTyConBinders_AT binders $ \ binders' -> do
+     { res_kind' <- tcIfaceType res_kind    -- Note [Synonym kind loop]
+     ; rhs      <- forkM (mk_doc tc_name) $
+                   tc_fam_flav tc_name fam_flav
+     ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
+     ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj
+     ; return (ATyCon tycon) }
+   where
+     mk_doc n = text "Type synonym" <+> ppr n
+
+     tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav
+     tc_fam_flav tc_name IfaceDataFamilyTyCon
+       = do { tc_rep_name <- newTyConRepName tc_name
+            ; return (DataFamilyTyCon tc_rep_name) }
+     tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon
+     tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)
+       = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches
+            ; return (ClosedSynFamilyTyCon ax) }
+     tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon
+         = return AbstractClosedSynFamilyTyCon
+     tc_fam_flav _ IfaceBuiltInSynFamTyCon
+         = pprPanic "tc_iface_decl"
+                    (text "IfaceBuiltInSynFamTyCon in interface file")
+
+tc_iface_decl _parent _ignore_prags
+            (IfaceClass {ifName = tc_name,
+                         ifRoles = roles,
+                         ifBinders = binders,
+                         ifFDs = rdr_fds,
+                         ifBody = IfAbstractClass})
+  = bindIfaceTyConBinders binders $ \ binders' -> do
+    { fds  <- mapM tc_fd rdr_fds
+    ; cls  <- buildClass tc_name binders' roles fds Nothing
+    ; return (ATyCon (classTyCon cls)) }
+
+tc_iface_decl _parent ignore_prags
+            (IfaceClass {ifName = tc_name,
+                         ifRoles = roles,
+                         ifBinders = binders,
+                         ifFDs = rdr_fds,
+                         ifBody = IfConcreteClass {
+                             ifClassCtxt = rdr_ctxt,
+                             ifATs = rdr_ats, ifSigs = rdr_sigs,
+                             ifMinDef = mindef_occ
+                         }})
+  = bindIfaceTyConBinders binders $ \ binders' -> do
+    { traceIf (text "tc-iface-class1" <+> ppr tc_name)
+    ; ctxt <- mapM tc_sc rdr_ctxt
+    ; traceIf (text "tc-iface-class2" <+> ppr tc_name)
+    ; sigs <- mapM tc_sig rdr_sigs
+    ; fds  <- mapM tc_fd rdr_fds
+    ; traceIf (text "tc-iface-class3" <+> ppr tc_name)
+    ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ
+    ; cls  <- fixM $ \ cls -> do
+              { ats  <- mapM (tc_at cls) rdr_ats
+              ; traceIf (text "tc-iface-class4" <+> ppr tc_name)
+              ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) }
+    ; return (ATyCon (classTyCon cls)) }
+  where
+   tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
+        -- The *length* of the superclasses is used by buildClass, and hence must
+        -- not be inside the thunk.  But the *content* maybe recursive and hence
+        -- must be lazy (via forkM).  Example:
+        --     class C (T a) => D a where
+        --       data T a
+        -- Here the associated type T is knot-tied with the class, and
+        -- so we must not pull on T too eagerly.  See Trac #5970
+
+   tc_sig :: IfaceClassOp -> IfL TcMethInfo
+   tc_sig (IfaceClassOp op_name rdr_ty dm)
+     = do { let doc = mk_op_doc op_name rdr_ty
+          ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty
+                -- Must be done lazily for just the same reason as the
+                -- type of a data con; to avoid sucking in types that
+                -- it mentions unless it's necessary to do so
+          ; dm'   <- tc_dm doc dm
+          ; return (op_name, op_ty, dm') }
+
+   tc_dm :: SDoc
+         -> Maybe (DefMethSpec IfaceType)
+         -> IfL (Maybe (DefMethSpec (SrcSpan, Type)))
+   tc_dm _   Nothing               = return Nothing
+   tc_dm _   (Just VanillaDM)      = return (Just VanillaDM)
+   tc_dm doc (Just (GenericDM ty))
+        = do { -- Must be done lazily to avoid sucking in types
+             ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty
+             ; return (Just (GenericDM (noSrcSpan, ty'))) }
+
+   tc_at cls (IfaceAT tc_decl if_def)
+     = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl
+          mb_def <- case if_def of
+                      Nothing  -> return Nothing
+                      Just def -> forkM (mk_at_doc tc)                 $
+                                  extendIfaceTyVarEnv (tyConTyVars tc) $
+                                  do { tc_def <- tcIfaceType def
+                                     ; return (Just (tc_def, noSrcSpan)) }
+                  -- Must be done lazily in case the RHS of the defaults mention
+                  -- the type constructor being defined here
+                  -- e.g.   type AT a; type AT b = AT [b]   Trac #8002
+          return (ATI tc mb_def)
+
+   mk_sc_doc pred = text "Superclass" <+> ppr pred
+   mk_at_doc tc = text "Associated type" <+> ppr tc
+   mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty]
+
+tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc
+                              , ifAxBranches = branches, ifRole = role })
+  = do { tc_tycon    <- tcIfaceTyCon tc
+       -- Must be done lazily, because axioms are forced when checking
+       -- for family instance consistency, and the RHS may mention
+       -- a hs-boot declared type constructor that is going to be
+       -- defined by this module.
+       -- e.g. type instance F Int = ToBeDefined
+       -- See Trac #13803
+       ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name)
+                      $ tc_ax_branches branches
+       ; let axiom = CoAxiom { co_ax_unique   = nameUnique tc_name
+                             , co_ax_name     = tc_name
+                             , co_ax_tc       = tc_tycon
+                             , co_ax_role     = role
+                             , co_ax_branches = manyBranches tc_branches
+                             , co_ax_implicit = False }
+       ; return (ACoAxiom axiom) }
+
+tc_iface_decl _ _ (IfacePatSyn{ ifName = name
+                              , ifPatMatcher = if_matcher
+                              , ifPatBuilder = if_builder
+                              , ifPatIsInfix = is_infix
+                              , ifPatUnivBndrs = univ_bndrs
+                              , ifPatExBndrs = ex_bndrs
+                              , ifPatProvCtxt = prov_ctxt
+                              , ifPatReqCtxt = req_ctxt
+                              , ifPatArgs = args
+                              , ifPatTy = pat_ty
+                              , ifFieldLabels = field_labels })
+  = do { traceIf (text "tc_iface_decl" <+> ppr name)
+       ; matcher <- tc_pr if_matcher
+       ; builder <- fmapMaybeM tc_pr if_builder
+       ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do
+       { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do
+       { patsyn <- forkM (mk_doc name) $
+             do { prov_theta <- tcIfaceCtxt prov_ctxt
+                ; req_theta  <- tcIfaceCtxt req_ctxt
+                ; pat_ty     <- tcIfaceType pat_ty
+                ; arg_tys    <- mapM tcIfaceType args
+                ; return $ buildPatSyn name is_infix matcher builder
+                                       (univ_tvs, req_theta)
+                                       (ex_tvs, prov_theta)
+                                       arg_tys pat_ty field_labels }
+       ; return $ AConLike . PatSynCon $ patsyn }}}
+  where
+     mk_doc n = text "Pattern synonym" <+> ppr n
+     tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool)
+     tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)
+                        ; return (id, b) }
+
+tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar)
+tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1
+                        ; tvs2' <- mapM tcIfaceTyVar tvs2
+                        ; return (tvs1', tvs2') }
+
+tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
+tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
+
+tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
+tc_ax_branch prev_branches
+             (IfaceAxBranch { ifaxbTyVars = tv_bndrs
+                            , ifaxbEtaTyVars = eta_tv_bndrs
+                            , ifaxbCoVars = cv_bndrs
+                            , ifaxbLHS = lhs, ifaxbRHS = rhs
+                            , ifaxbRoles = roles, ifaxbIncomps = incomps })
+  = bindIfaceTyConBinders_AT
+      (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->
+         -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom
+    bindIfaceIds cv_bndrs $ \ cvs -> do
+    { tc_lhs   <- tcIfaceAppArgs lhs
+    ; tc_rhs   <- tcIfaceType rhs
+    ; eta_tvs  <- bindIfaceTyVars eta_tv_bndrs return
+    ; this_mod <- getIfModule
+    ; let loc = mkGeneralSrcSpan (fsLit "module " `appendFS`
+                                  moduleNameFS (moduleName this_mod))
+          br = CoAxBranch { cab_loc     = loc
+                          , cab_tvs     = binderVars tvs
+                          , cab_eta_tvs = eta_tvs
+                          , cab_cvs     = cvs
+                          , cab_lhs     = tc_lhs
+                          , cab_roles   = roles
+                          , cab_rhs     = tc_rhs
+                          , cab_incomps = map (prev_branches `getNth`) incomps }
+    ; return (prev_branches ++ [br]) }
+
+tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs
+tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
+  = case if_cons of
+        IfAbstractTyCon  -> return AbstractTyCon
+        IfDataTyCon cons -> do  { data_cons  <- mapM tc_con_decl cons
+                                ; return (mkDataTyConRhs data_cons) }
+        IfNewTyCon  con  -> do  { data_con  <- tc_con_decl con
+                                ; mkNewTyConRhs tycon_name tycon data_con }
+  where
+    univ_tvs :: [TyVar]
+    univ_tvs = binderVars (tyConTyVarBinders tc_tybinders)
+
+    tag_map :: NameEnv ConTag
+    tag_map = mkTyConTagMap tycon
+
+    tc_con_decl (IfCon { ifConInfix = is_infix,
+                         ifConExTCvs = ex_bndrs,
+                         ifConUserTvBinders = user_bndrs,
+                         ifConName = dc_name,
+                         ifConCtxt = ctxt, ifConEqSpec = spec,
+                         ifConArgTys = args, ifConFields = lbl_names,
+                         ifConStricts = if_stricts,
+                         ifConSrcStricts = if_src_stricts})
+     = -- Universally-quantified tyvars are shared with
+       -- parent TyCon, and are already in scope
+       bindIfaceBndrs ex_bndrs    $ \ ex_tvs -> do
+        { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name)
+
+          -- By this point, we have bound every universal and existential
+          -- tyvar. Because of the dcUserTyVarBinders invariant
+          -- (see Note [DataCon user type variable binders]), *every* tyvar in
+          -- ifConUserTvBinders has a matching counterpart somewhere in the
+          -- bound universals/existentials. As a result, calling tcIfaceTyVar
+          -- below is always guaranteed to succeed.
+        ; user_tv_bndrs <- mapM (\(Bndr bd vis) ->
+                                   case bd of
+                                     IfaceIdBndr (name, _) ->
+                                       Bndr <$> tcIfaceLclId name <*> pure vis
+                                     IfaceTvBndr (name, _) ->
+                                       Bndr <$> tcIfaceTyVar name <*> pure vis)
+                                user_bndrs
+
+        -- Read the context and argument types, but lazily for two reasons
+        -- (a) to avoid looking tugging on a recursive use of
+        --     the type itself, which is knot-tied
+        -- (b) to avoid faulting in the component types unless
+        --     they are really needed
+        ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $
+             do { eq_spec <- tcIfaceEqSpec spec
+                ; theta   <- tcIfaceCtxt ctxt
+                -- This fixes #13710.  The enclosing lazy thunk gets
+                -- forced when typechecking record wildcard pattern
+                -- matching (it's not completely clear why this
+                -- tuple is needed), which causes trouble if one of
+                -- the argument types was recursively defined.
+                -- See also Note [Tying the knot]
+                ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys")
+                           $ mapM tcIfaceType args
+                ; stricts <- mapM tc_strict if_stricts
+                        -- The IfBang field can mention
+                        -- the type itself; hence inside forkM
+                ; return (eq_spec, theta, arg_tys, stricts) }
+
+        -- Remember, tycon is the representation tycon
+        ; let orig_res_ty = mkFamilyTyConApp tycon
+                              (substTyCoVars (mkTvSubstPrs (map eqSpecPair eq_spec))
+                                             (binderVars tc_tybinders))
+
+        ; prom_rep_name <- newTyConRepName dc_name
+
+        ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))
+                       dc_name is_infix prom_rep_name
+                       (map src_strict if_src_stricts)
+                       (Just stricts)
+                       -- Pass the HsImplBangs (i.e. final
+                       -- decisions) to buildDataCon; it'll use
+                       -- these to guide the construction of a
+                       -- worker.
+                       -- See Note [Bangs on imported data constructors] in MkId
+                       lbl_names
+                       univ_tvs ex_tvs user_tv_bndrs
+                       eq_spec theta
+                       arg_tys orig_res_ty tycon tag_map
+        ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
+        ; return con }
+    mk_doc con_name = text "Constructor" <+> ppr con_name
+
+    tc_strict :: IfaceBang -> IfL HsImplBang
+    tc_strict IfNoBang = return (HsLazy)
+    tc_strict IfStrict = return (HsStrict)
+    tc_strict IfUnpack = return (HsUnpack Nothing)
+    tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
+                                      ; return (HsUnpack (Just co)) }
+
+    src_strict :: IfaceSrcBang -> HsSrcBang
+    src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang
+
+tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]
+tcIfaceEqSpec spec
+  = mapM do_item spec
+  where
+    do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ
+                              ; ty <- tcIfaceType if_ty
+                              ; return (mkEqSpec tv ty) }
+
+{-
+Note [Synonym kind loop]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Notice that we eagerly grab the *kind* from the interface file, but
+build a forkM thunk for the *rhs* (and family stuff).  To see why,
+consider this (Trac #2412)
+
+M.hs:       module M where { import X; data T = MkT S }
+X.hs:       module X where { import {-# SOURCE #-} M; type S = T }
+M.hs-boot:  module M where { data T }
+
+When kind-checking M.hs we need S's kind.  But we do not want to
+find S's kind from (typeKind S-rhs), because we don't want to look at
+S-rhs yet!  Since S is imported from X.hi, S gets just one chance to
+be defined, and we must not do that until we've finished with M.T.
+
+Solution: record S's kind in the interface file; now we can safely
+look at it.
+
+************************************************************************
+*                                                                      *
+                Instances
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceInst :: IfaceClsInst -> IfL ClsInst
+tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
+                          , ifInstCls = cls, ifInstTys = mb_tcs
+                          , ifInstOrph = orph })
+  = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $
+                    fmap tyThingId (tcIfaceImplicit dfun_name)
+       ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+       ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }
+
+tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
+tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
+                             , ifFamInstAxiom = axiom_name } )
+    = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $
+                     tcIfaceCoAxiom axiom_name
+             -- will panic if branched, but that's OK
+         ; let axiom'' = toUnbranchedAxiom axiom'
+               mb_tcs' = map (fmap ifaceTyConName) mb_tcs
+         ; return (mkImportedFamInst fam mb_tcs' axiom'') }
+
+{-
+************************************************************************
+*                                                                      *
+                Rules
+*                                                                      *
+************************************************************************
+
+We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars
+are in the type environment.  However, remember that typechecking a Rule may
+(as a side effect) augment the type envt, and so we may need to iterate the process.
+-}
+
+tcIfaceRules :: Bool            -- True <=> ignore rules
+             -> [IfaceRule]
+             -> IfL [CoreRule]
+tcIfaceRules ignore_prags if_rules
+  | ignore_prags = return []
+  | otherwise    = mapM tcIfaceRule if_rules
+
+tcIfaceRule :: IfaceRule -> IfL CoreRule
+tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
+                        ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
+                        ifRuleAuto = auto, ifRuleOrph = orph })
+  = do  { ~(bndrs', args', rhs') <-
+                -- Typecheck the payload lazily, in the hope it'll never be looked at
+                forkM (text "Rule" <+> pprRuleName name) $
+                bindIfaceBndrs bndrs                      $ \ bndrs' ->
+                do { args' <- mapM tcIfaceExpr args
+                   ; rhs'  <- tcIfaceExpr rhs
+                   ; return (bndrs', args', rhs') }
+        ; let mb_tcs = map ifTopFreeName args
+        ; this_mod <- getIfModule
+        ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
+                          ru_bndrs = bndrs', ru_args = args',
+                          ru_rhs = occurAnalyseExpr rhs',
+                          ru_rough = mb_tcs,
+                          ru_origin = this_mod,
+                          ru_orphan = orph,
+                          ru_auto = auto,
+                          ru_local = False }) } -- An imported RULE is never for a local Id
+                                                -- or, even if it is (module loop, perhaps)
+                                                -- we'll just leave it in the non-local set
+  where
+        -- This function *must* mirror exactly what Rules.roughTopNames does
+        -- We could have stored the ru_rough field in the iface file
+        -- but that would be redundant, I think.
+        -- The only wrinkle is that we must not be deceived by
+        -- type synonyms at the top of a type arg.  Since
+        -- we can't tell at this point, we are careful not
+        -- to write them out in coreRuleToIfaceRule
+    ifTopFreeName :: IfaceExpr -> Maybe Name
+    ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)
+    ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))
+    ifTopFreeName (IfaceApp f _)                    = ifTopFreeName f
+    ifTopFreeName (IfaceExt n)                      = Just n
+    ifTopFreeName _                                 = Nothing
+
+{-
+************************************************************************
+*                                                                      *
+                Annotations
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
+tcIfaceAnnotations = mapM tcIfaceAnnotation
+
+tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation
+tcIfaceAnnotation (IfaceAnnotation target serialized) = do
+    target' <- tcIfaceAnnTarget target
+    return $ Annotation {
+        ann_target = target',
+        ann_value = serialized
+    }
+
+tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)
+tcIfaceAnnTarget (NamedTarget occ) = do
+    name <- lookupIfaceTop occ
+    return $ NamedTarget name
+tcIfaceAnnTarget (ModuleTarget mod) = do
+    return $ ModuleTarget mod
+
+{-
+************************************************************************
+*                                                                      *
+                Complete Match Pragmas
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
+tcIfaceCompleteSigs = mapM tcIfaceCompleteSig
+
+tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch
+tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)
+
+{-
+************************************************************************
+*                                                                      *
+                        Types
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceType :: IfaceType -> IfL Type
+tcIfaceType = go
+  where
+    go (IfaceTyVar n)         = TyVarTy <$> tcIfaceTyVar n
+    go (IfaceFreeTyVar n)     = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)
+    go (IfaceLitTy l)         = LitTy <$> tcIfaceTyLit l
+    go (IfaceFunTy t1 t2)     = FunTy <$> go t1 <*> go t2
+    go (IfaceDFunTy t1 t2)    = FunTy <$> go t1 <*> go t2
+    go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks
+    go (IfaceAppTy t ts)
+      = do { t'  <- go t
+           ; ts' <- traverse go (appArgsIfaceTypes ts)
+           ; pure (foldl' AppTy t' ts') }
+    go (IfaceTyConApp tc tks)
+      = do { tc' <- tcIfaceTyCon tc
+           ; tks' <- mapM go (appArgsIfaceTypes tks)
+           ; return (mkTyConApp tc' tks') }
+    go (IfaceForAllTy bndr t)
+      = bindIfaceForAllBndr bndr $ \ tv' vis ->
+        ForAllTy (Bndr tv' vis) <$> go t
+    go (IfaceCastTy ty co)   = CastTy <$> go ty <*> tcIfaceCo co
+    go (IfaceCoercionTy co)  = CoercionTy <$> tcIfaceCo co
+
+tcIfaceTupleTy :: TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type
+tcIfaceTupleTy sort is_promoted args
+ = do { args' <- tcIfaceAppArgs args
+      ; let arity = length args'
+      ; base_tc <- tcTupleTyCon True sort arity
+      ; case is_promoted of
+          NotPromoted
+            -> return (mkTyConApp base_tc args')
+
+          IsPromoted
+            -> do { let tc        = promoteDataCon (tyConSingleDataCon base_tc)
+                        kind_args = map typeKind args'
+                  ; return (mkTyConApp tc (kind_args ++ args')) } }
+
+-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+tcTupleTyCon :: Bool    -- True <=> typechecking a *type* (vs. an expr)
+             -> TupleSort
+             -> Arity   -- the number of args. *not* the tuple arity.
+             -> IfL TyCon
+tcTupleTyCon in_type sort arity
+  = case sort of
+      ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity)
+                            ; return (tyThingTyCon thing) }
+      BoxedTuple   -> return (tupleTyCon Boxed   arity)
+      UnboxedTuple -> return (tupleTyCon Unboxed arity')
+        where arity' | in_type   = arity `div` 2
+                     | otherwise = arity
+                      -- in expressions, we only have term args
+
+tcIfaceAppArgs :: IfaceAppArgs -> IfL [Type]
+tcIfaceAppArgs = mapM tcIfaceType . appArgsIfaceTypes
+
+-----------------------------------------
+tcIfaceCtxt :: IfaceContext -> IfL ThetaType
+tcIfaceCtxt sts = mapM tcIfaceType sts
+
+-----------------------------------------
+tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
+tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
+tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
+
+{-
+%************************************************************************
+%*                                                                      *
+                        Coercions
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceCo :: IfaceCoercion -> IfL Coercion
+tcIfaceCo = go
+  where
+    go_mco IfaceMRefl    = pure MRefl
+    go_mco (IfaceMCo co) = MCo <$> (go co)
+
+    go (IfaceReflCo t)           = Refl <$> tcIfaceType t
+    go (IfaceGReflCo r t mco)    = GRefl r <$> tcIfaceType t <*> go_mco mco
+    go (IfaceFunCo r c1 c2)      = mkFunCo r <$> go c1 <*> go c2
+    go (IfaceTyConAppCo r tc cs)
+      = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
+    go (IfaceAppCo c1 c2)        = AppCo <$> go c1 <*> go c2
+    go (IfaceForAllCo tv k c)  = do { k' <- go k
+                                      ; bindIfaceBndr tv $ \ tv' ->
+                                        ForAllCo tv' k' <$> go c }
+    go (IfaceCoVarCo n)          = CoVarCo <$> go_var n
+    go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs
+    go (IfaceUnivCo p r t1 t2)   = UnivCo <$> tcIfaceUnivCoProv p <*> pure r
+                                          <*> tcIfaceType t1 <*> tcIfaceType t2
+    go (IfaceSymCo c)            = SymCo    <$> go c
+    go (IfaceTransCo c1 c2)      = TransCo  <$> go c1
+                                            <*> go c2
+    go (IfaceInstCo c1 t2)       = InstCo   <$> go c1
+                                            <*> go t2
+    go (IfaceNthCo d c)          = do { c' <- go c
+                                      ; return $ mkNthCo (nthCoRole d c') d c' }
+    go (IfaceLRCo lr c)          = LRCo lr  <$> go c
+    go (IfaceKindCo c)           = KindCo   <$> go c
+    go (IfaceSubCo c)            = SubCo    <$> go c
+    go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax
+                                               <*> mapM go cos
+    go (IfaceFreeCoVar c)        = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)
+    go (IfaceHoleCo c)           = pprPanic "tcIfaceCo:IfaceHoleCo"    (ppr c)
+
+    go_var :: FastString -> IfL CoVar
+    go_var = tcIfaceLclId
+
+tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
+tcIfaceUnivCoProv IfaceUnsafeCoerceProv     = return UnsafeCoerceProv
+tcIfaceUnivCoProv (IfacePhantomProv kco)    = PhantomProv <$> tcIfaceCo kco
+tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
+tcIfaceUnivCoProv (IfacePluginProv str)     = return $ PluginProv str
+
+{-
+************************************************************************
+*                                                                      *
+                        Core
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
+tcIfaceExpr (IfaceType ty)
+  = Type <$> tcIfaceType ty
+
+tcIfaceExpr (IfaceCo co)
+  = Coercion <$> tcIfaceCo co
+
+tcIfaceExpr (IfaceCast expr co)
+  = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
+
+tcIfaceExpr (IfaceLcl name)
+  = Var <$> tcIfaceLclId name
+
+tcIfaceExpr (IfaceExt gbl)
+  = Var <$> tcIfaceExtId gbl
+
+tcIfaceExpr (IfaceLit lit)
+  = do lit' <- tcIfaceLit lit
+       return (Lit lit')
+
+tcIfaceExpr (IfaceFCall cc ty) = do
+    ty' <- tcIfaceType ty
+    u <- newUnique
+    dflags <- getDynFlags
+    return (Var (mkFCallId dflags u cc ty'))
+
+tcIfaceExpr (IfaceTuple sort args)
+  = do { args' <- mapM tcIfaceExpr args
+       ; tc <- tcTupleTyCon False sort arity
+       ; let con_tys = map exprType args'
+             some_con_args = map Type con_tys ++ args'
+             con_args = case sort of
+               UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args
+               _            -> some_con_args
+                        -- Put the missing type arguments back in
+             con_id   = dataConWorkId (tyConSingleDataCon tc)
+       ; return (mkApps (Var con_id) con_args) }
+  where
+    arity = length args
+
+tcIfaceExpr (IfaceLam (bndr, os) body)
+  = bindIfaceBndr bndr $ \bndr' ->
+    Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body
+  where
+    tcIfaceOneShot IfaceOneShot b = setOneShotLambda b
+    tcIfaceOneShot _            b = b
+
+tcIfaceExpr (IfaceApp fun arg)
+  = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
+
+tcIfaceExpr (IfaceECase scrut ty)
+  = do { scrut' <- tcIfaceExpr scrut
+       ; ty' <- tcIfaceType ty
+       ; return (castBottomExpr scrut' ty') }
+
+tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do
+    scrut' <- tcIfaceExpr scrut
+    case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
+    let
+        scrut_ty   = exprType scrut'
+        case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty
+        tc_app     = splitTyConApp scrut_ty
+                -- NB: Won't always succeed (polymorphic case)
+                --     but won't be demanded in those cases
+                -- NB: not tcSplitTyConApp; we are looking at Core here
+                --     look through non-rec newtypes to find the tycon that
+                --     corresponds to the datacon in this case alternative
+
+    extendIfaceIdEnv [case_bndr'] $ do
+     alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
+     return (Case scrut' case_bndr' (coreAltsType alts') alts')
+
+tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
+  = do  { name    <- newIfaceName (mkVarOccFS fs)
+        ; ty'     <- tcIfaceType ty
+        ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
+                              NotTopLevel name ty' info
+        ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info
+                     `asJoinId_maybe` tcJoinInfo ji
+        ; rhs' <- tcIfaceExpr rhs
+        ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
+        ; return (Let (NonRec id rhs') body') }
+
+tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
+  = do { ids <- mapM tc_rec_bndr (map fst pairs)
+       ; extendIfaceIdEnv ids $ do
+       { pairs' <- zipWithM tc_pair pairs ids
+       ; body' <- tcIfaceExpr body
+       ; return (Let (Rec pairs') body') } }
+ where
+   tc_rec_bndr (IfLetBndr fs ty _ ji)
+     = do { name <- newIfaceName (mkVarOccFS fs)
+          ; ty'  <- tcIfaceType ty
+          ; return (mkLocalIdOrCoVar name ty' `asJoinId_maybe` tcJoinInfo ji) }
+   tc_pair (IfLetBndr _ _ info _, rhs) id
+     = do { rhs' <- tcIfaceExpr rhs
+          ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
+                                NotTopLevel (idName id) (idType id) info
+          ; return (setIdInfo id id_info, rhs') }
+
+tcIfaceExpr (IfaceTick tickish expr) = do
+    expr' <- tcIfaceExpr expr
+    -- If debug flag is not set: Ignore source notes
+    dbgLvl <- fmap debugLevel getDynFlags
+    case tickish of
+      IfaceSource{} | dbgLvl > 0
+                    -> return expr'
+      _otherwise    -> do
+        tickish' <- tcIfaceTickish tickish
+        return (Tick tickish' expr')
+
+-------------------------
+tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)
+tcIfaceTickish (IfaceHpcTick modl ix)   = return (HpcTick modl ix)
+tcIfaceTickish (IfaceSCC  cc tick push) = return (ProfNote cc tick push)
+tcIfaceTickish (IfaceSource src name)   = return (SourceNote src name)
+
+-------------------------
+tcIfaceLit :: Literal -> IfL Literal
+-- Integer literals deserialise to (LitInteger i <error thunk>)
+-- so tcIfaceLit just fills in the type.
+-- See Note [Integer literals] in Literal
+tcIfaceLit (LitNumber LitNumInteger i _)
+  = do t <- tcIfaceTyConByName integerTyConName
+       return (mkLitInteger i (mkTyConTy t))
+-- Natural literals deserialise to (LitNatural i <error thunk>)
+-- so tcIfaceLit just fills in the type.
+-- See Note [Natural literals] in Literal
+tcIfaceLit (LitNumber LitNumNatural i _)
+  = do t <- tcIfaceTyConByName naturalTyConName
+       return (mkLitNatural i (mkTyConTy t))
+tcIfaceLit lit = return lit
+
+-------------------------
+tcIfaceAlt :: CoreExpr -> (TyCon, [Type])
+           -> (IfaceConAlt, [FastString], IfaceExpr)
+           -> IfL (AltCon, [TyVar], CoreExpr)
+tcIfaceAlt _ _ (IfaceDefault, names, rhs)
+  = ASSERT( null names ) do
+    rhs' <- tcIfaceExpr rhs
+    return (DEFAULT, [], rhs')
+
+tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)
+  = ASSERT( null names ) do
+    lit' <- tcIfaceLit lit
+    rhs' <- tcIfaceExpr rhs
+    return (LitAlt lit', [], rhs')
+
+-- A case alternative is made quite a bit more complicated
+-- by the fact that we omit type annotations because we can
+-- work them out.  True enough, but its not that easy!
+tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
+  = do  { con <- tcIfaceDataCon data_occ
+        ; when (debugIsOn && not (con `elem` tyConDataCons tycon))
+               (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
+        ; tcIfaceDataAlt con inst_tys arg_strs rhs }
+
+tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
+               -> IfL (AltCon, [TyVar], CoreExpr)
+tcIfaceDataAlt con inst_tys arg_strs rhs
+  = do  { us <- newUniqueSupply
+        ; let uniqs = uniqsFromSupply us
+        ; let (ex_tvs, arg_ids)
+                      = dataConRepFSInstPat arg_strs uniqs con inst_tys
+
+        ; rhs' <- extendIfaceEnvs  ex_tvs       $
+                  extendIfaceIdEnv arg_ids      $
+                  tcIfaceExpr rhs
+        ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
+
+{-
+************************************************************************
+*                                                                      *
+                IdInfo
+*                                                                      *
+************************************************************************
+-}
+
+tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails
+tcIdDetails _  IfVanillaId = return VanillaId
+tcIdDetails ty IfDFunId
+  = return (DFunId (isNewTyCon (classTyCon cls)))
+  where
+    (_, _, cls, _) = tcSplitDFunTy ty
+
+tcIdDetails _ (IfRecSelId tc naughty)
+  = do { tc' <- either (fmap RecSelData . tcIfaceTyCon)
+                       (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)
+                       tc
+       ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }
+  where
+    tyThingPatSyn (AConLike (PatSynCon ps)) = ps
+    tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"
+
+tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo
+tcIdInfo ignore_prags toplvl name ty info = do
+    lcl_env <- getLclEnv
+    -- Set the CgInfo to something sensible but uninformative before
+    -- we start; default assumption is that it has CAFs
+    let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
+                  | otherwise       = vanillaIdInfo
+    if ignore_prags
+        then return init_info
+        else case info of
+                NoInfo -> return init_info
+                HasInfo info -> foldlM tcPrag init_info info
+  where
+    tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
+    tcPrag info HsNoCafRefs        = return (info `setCafInfo`   NoCafRefs)
+    tcPrag info (HsArity arity)    = return (info `setArityInfo` arity)
+    tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)
+    tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)
+    tcPrag info HsLevity           = return (info `setNeverLevPoly` ty)
+
+        -- The next two are lazy, so they don't transitively suck stuff in
+    tcPrag info (HsUnfold lb if_unf)
+      = do { unf <- tcUnfolding toplvl name ty info if_unf
+           ; let info1 | lb        = info `setOccInfo` strongLoopBreaker
+                       | otherwise = info
+           ; return (info1 `setUnfoldingInfo` unf) }
+
+tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity
+tcJoinInfo (IfaceJoinPoint ar) = Just ar
+tcJoinInfo IfaceNotJoinPoint   = Nothing
+
+tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
+tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
+  = do  { dflags <- getDynFlags
+        ; mb_expr <- tcPragExpr toplvl name if_expr
+        ; let unf_src | stable    = InlineStable
+                      | otherwise = InlineRhs
+        ; return $ case mb_expr of
+            Nothing -> NoUnfolding
+            Just expr -> mkUnfolding dflags unf_src
+                           True {- Top level -}
+                           (isBottomingSig strict_sig)
+                           expr
+        }
+  where
+     -- Strictness should occur before unfolding!
+    strict_sig = strictnessInfo info
+tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
+  = do  { mb_expr <- tcPragExpr toplvl name if_expr
+        ; return (case mb_expr of
+                    Nothing   -> NoUnfolding
+                    Just expr -> mkCompulsoryUnfolding expr) }
+
+tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
+  = do  { mb_expr <- tcPragExpr toplvl name if_expr
+        ; return (case mb_expr of
+                    Nothing   -> NoUnfolding
+                    Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
+  where
+    guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }
+
+tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)
+  = bindIfaceBndrs bs $ \ bs' ->
+    do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops
+       ; return (case mb_ops1 of
+                    Nothing   -> noUnfolding
+                    Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }
+  where
+    doc = text "Class ops for dfun" <+> ppr name
+    (_, _, cls, _) = tcSplitDFunTy dfun_ty
+
+{-
+For unfoldings we try to do the job lazily, so that we never type check
+an unfolding that isn't going to be looked at.
+-}
+
+tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
+tcPragExpr toplvl name expr
+  = forkM_maybe doc $ do
+    core_expr' <- tcIfaceExpr expr
+
+    -- Check for type consistency in the unfolding
+    -- See Note [Linting Unfoldings from Interfaces]
+    when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do
+        in_scope <- get_in_scope
+        dflags   <- getDynFlags
+        case lintUnfolding dflags noSrcLoc in_scope core_expr' of
+          Nothing       -> return ()
+          Just fail_msg -> do { mod <- getIfModule
+                              ; pprPanic "Iface Lint failure"
+                                  (vcat [ text "In interface for" <+> ppr mod
+                                        , hang doc 2 fail_msg
+                                        , ppr name <+> equals <+> ppr core_expr'
+                                        , text "Iface expr =" <+> ppr expr ]) }
+    return core_expr'
+  where
+    doc = text "Unfolding of" <+> ppr name
+
+    get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting
+    get_in_scope
+        = do { (gbl_env, lcl_env) <- getEnvs
+             ; rec_ids <- case if_rec_types gbl_env of
+                            Nothing -> return []
+                            Just (_, get_env) -> do
+                               { type_env <- setLclEnv () get_env
+                               ; return (typeEnvIds type_env) }
+             ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`
+                       bindingsVars (if_id_env lcl_env) `unionVarSet`
+                       mkVarSet rec_ids) }
+
+    bindingsVars :: FastStringEnv Var -> VarSet
+    bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm
+      -- It's OK to use nonDetEltsUFM here because we immediately forget
+      -- the ordering by creating a set
+
+{-
+************************************************************************
+*                                                                      *
+                Getting from Names to TyThings
+*                                                                      *
+************************************************************************
+-}
+
+tcIfaceGlobal :: Name -> IfL TyThing
+tcIfaceGlobal name
+  | Just thing <- wiredInNameTyThing_maybe name
+        -- Wired-in things include TyCons, DataCons, and Ids
+        -- Even though we are in an interface file, we want to make
+        -- sure the instances and RULES of this thing (particularly TyCon) are loaded
+        -- Imagine: f :: Double -> Double
+  = do { ifCheckWiredInThing thing; return thing }
+
+  | otherwise
+  = do  { env <- getGblEnv
+        ; case if_rec_types env of {    -- Note [Tying the knot]
+            Just (mod, get_type_env)
+                | nameIsLocalOrFrom mod name
+                -> do           -- It's defined in the module being compiled
+                { type_env <- setLclEnv () get_type_env         -- yuk
+                ; case lookupNameEnv type_env name of
+                    Just thing -> return thing
+                    -- See Note [Knot-tying fallback on boot]
+                    Nothing   -> via_external
+                }
+
+          ; _ -> via_external }}
+  where
+    via_external =  do
+        { hsc_env <- getTopEnv
+        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
+        ; case mb_thing of {
+            Just thing -> return thing ;
+            Nothing    -> do
+
+        { mb_thing <- importDecl name   -- It's imported; go get it
+        ; case mb_thing of
+            Failed err      -> failIfM err
+            Succeeded thing -> return thing
+        }}}
+
+-- Note [Tying the knot]
+-- ~~~~~~~~~~~~~~~~~~~~~
+-- The if_rec_types field is used when we are compiling M.hs, which indirectly
+-- imports Foo.hi, which mentions M.T Then we look up M.T in M's type
+-- environment, which is splatted into if_rec_types after we've built M's type
+-- envt.
+--
+-- This is a dark and complicated part of GHC type checking, with a lot
+-- of moving parts.  Interested readers should also look at:
+--
+--      * Note [Knot-tying typecheckIface]
+--      * Note [DFun knot-tying]
+--      * Note [hsc_type_env_var hack]
+--      * Note [Knot-tying fallback on boot]
+--
+-- There is also a wiki page on the subject, see:
+--
+--      https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TyingTheKnot
+
+-- Note [Knot-tying fallback on boot]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Suppose that you are typechecking A.hs, which transitively imports,
+-- via B.hs, A.hs-boot. When we poke on B.hs and discover that it
+-- has a reference to a type T from A, what TyThing should we wire
+-- it up with? Clearly, if we have already typechecked T and
+-- added it into the type environment, we should go ahead and use that
+-- type. But what if we haven't typechecked it yet?
+--
+-- For the longest time, GHC adopted the policy that this was
+-- *an error condition*; that you MUST NEVER poke on B.hs's reference
+-- to a T defined in A.hs until A.hs has gotten around to kind-checking
+-- T and adding it to the env. However, actually ensuring this is the
+-- case has proven to be a bug farm, because it's really difficult to
+-- actually ensure this never happens. The problem was especially poignant
+-- with type family consistency checks, which eagerly happen before any
+-- typechecking takes place.
+--
+-- Today, we take a different strategy: if we ever try to access
+-- an entity from A which doesn't exist, we just fall back on the
+-- definition of A from the hs-boot file. This is complicated in
+-- its own way: it means that you may end up with a mix of A.hs and
+-- A.hs-boot TyThings during the course of typechecking.  We don't
+-- think (and have not observed) any cases where this would cause
+-- problems, but the hypothetical situation one might worry about
+-- is something along these lines in Core:
+--
+--    case x of
+--        A -> e1
+--        B -> e2
+--
+-- If, when typechecking this, we find x :: T, and the T we are hooked
+-- up with is the abstract one from the hs-boot file, rather than the
+-- one defined in this module with constructors A and B.  But it's hard
+-- to see how this could happen, especially because the reference to
+-- the constructor (A and B) means that GHC will always typecheck
+-- this expression *after* typechecking T.
+
+tcIfaceTyConByName :: IfExtName -> IfL TyCon
+tcIfaceTyConByName name
+  = do { thing <- tcIfaceGlobal name
+       ; return (tyThingTyCon thing) }
+
+tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
+tcIfaceTyCon (IfaceTyCon name info)
+  = do { thing <- tcIfaceGlobal name
+       ; return $ case ifaceTyConIsPromoted info of
+           NotPromoted -> tyThingTyCon thing
+           IsPromoted    -> promoteDataCon $ tyThingDataCon thing }
+
+tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
+tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
+                         ; return (tyThingCoAxiom thing) }
+
+
+tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule
+-- Unlike CoAxioms, which arise form user 'type instance' declarations,
+-- there are a fixed set of CoAxiomRules,
+-- currently enumerated in typeNatCoAxiomRules
+tcIfaceCoAxiomRule n
+  = case Map.lookup n typeNatCoAxiomRules of
+        Just ax -> return ax
+        _  -> pprPanic "tcIfaceCoAxiomRule" (ppr n)
+
+tcIfaceDataCon :: Name -> IfL DataCon
+tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
+                         ; case thing of
+                                AConLike (RealDataCon dc) -> return dc
+                                _       -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }
+
+tcIfaceExtId :: Name -> IfL Id
+tcIfaceExtId name = do { thing <- tcIfaceGlobal name
+                       ; case thing of
+                          AnId id -> return id
+                          _       -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }
+
+-- See Note [Resolving never-exported Names in TcIface]
+tcIfaceImplicit :: Name -> IfL TyThing
+tcIfaceImplicit n = do
+    lcl_env <- getLclEnv
+    case if_implicits_env lcl_env of
+        Nothing -> tcIfaceGlobal n
+        Just tenv ->
+            case lookupTypeEnv tenv n of
+                Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv)
+                Just tything -> return tything
+
+{-
+************************************************************************
+*                                                                      *
+                Bindings
+*                                                                      *
+************************************************************************
+-}
+
+bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
+bindIfaceId (fs, ty) thing_inside
+  = do  { name <- newIfaceName (mkVarOccFS fs)
+        ; ty' <- tcIfaceType ty
+        ; let id = mkLocalIdOrCoVar name ty'
+        ; extendIfaceIdEnv [id] (thing_inside id) }
+
+bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
+bindIfaceIds [] thing_inside = thing_inside []
+bindIfaceIds (b:bs) thing_inside
+  = bindIfaceId b   $ \b'  ->
+    bindIfaceIds bs $ \bs' ->
+    thing_inside (b':bs')
+
+bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
+bindIfaceBndr (IfaceIdBndr bndr) thing_inside
+  = bindIfaceId bndr thing_inside
+bindIfaceBndr (IfaceTvBndr bndr) thing_inside
+  = bindIfaceTyVar bndr thing_inside
+
+bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a
+bindIfaceBndrs []     thing_inside = thing_inside []
+bindIfaceBndrs (b:bs) thing_inside
+  = bindIfaceBndr b     $ \ b' ->
+    bindIfaceBndrs bs   $ \ bs' ->
+    thing_inside (b':bs')
+
+-----------------------
+bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyCoVarBinder] -> IfL a) -> IfL a
+bindIfaceForAllBndrs [] thing_inside = thing_inside []
+bindIfaceForAllBndrs (bndr:bndrs) thing_inside
+  = bindIfaceForAllBndr bndr $ \tv vis ->
+    bindIfaceForAllBndrs bndrs $ \bndrs' ->
+    thing_inside (mkTyCoVarBinder vis tv : bndrs')
+
+bindIfaceForAllBndr :: IfaceForAllBndr -> (TyCoVar -> ArgFlag -> IfL a) -> IfL a
+bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside
+  = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis
+bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside
+  = bindIfaceId tv $ \tv' -> thing_inside tv' vis
+
+bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
+bindIfaceTyVar (occ,kind) thing_inside
+  = do  { name <- newIfaceName (mkTyVarOccFS occ)
+        ; tyvar <- mk_iface_tyvar name kind
+        ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
+
+bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
+bindIfaceTyVars [] thing_inside = thing_inside []
+bindIfaceTyVars (bndr:bndrs) thing_inside
+  = bindIfaceTyVar bndr   $ \tv  ->
+    bindIfaceTyVars bndrs $ \tvs ->
+    thing_inside (tv : tvs)
+
+mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
+mk_iface_tyvar name ifKind
+   = do { kind <- tcIfaceType ifKind
+        ; return (Var.mkTyVar name kind) }
+
+bindIfaceTyConBinders :: [IfaceTyConBinder]
+                      -> ([TyConBinder] -> IfL a) -> IfL a
+bindIfaceTyConBinders [] thing_inside = thing_inside []
+bindIfaceTyConBinders (b:bs) thing_inside
+  = bindIfaceTyConBinderX bindIfaceBndr b $ \ b'  ->
+    bindIfaceTyConBinders bs              $ \ bs' ->
+    thing_inside (b':bs')
+
+bindIfaceTyConBinders_AT :: [IfaceTyConBinder]
+                         -> ([TyConBinder] -> IfL a) -> IfL a
+-- Used for type variable in nested associated data/type declarations
+-- where some of the type variables are already in scope
+--    class C a where { data T a b }
+-- Here 'a' is in scope when we look at the 'data T'
+bindIfaceTyConBinders_AT [] thing_inside
+  = thing_inside []
+bindIfaceTyConBinders_AT (b : bs) thing_inside
+  = bindIfaceTyConBinderX bind_tv b  $ \b'  ->
+    bindIfaceTyConBinders_AT      bs $ \bs' ->
+    thing_inside (b':bs')
+  where
+    bind_tv tv thing
+      = do { mb_tv <- lookupIfaceVar tv
+           ; case mb_tv of
+               Just b' -> thing b'
+               Nothing -> bindIfaceBndr tv thing }
+
+bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a)
+                      -> IfaceTyConBinder
+                      -> (TyConBinder -> IfL a) -> IfL a
+bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside
+  = bind_tv tv $ \tv' ->
+    thing_inside (Bndr tv' vis)
diff --git a/compiler/iface/TcIface.hs-boot b/compiler/iface/TcIface.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/iface/TcIface.hs-boot
@@ -0,0 +1,19 @@
+module TcIface where
+
+import GhcPrelude
+import IfaceSyn    ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule,
+                     IfaceAnnotation, IfaceCompleteMatch )
+import TyCoRep     ( TyThing )
+import TcRnTypes   ( IfL )
+import InstEnv     ( ClsInst )
+import FamInstEnv  ( FamInst )
+import CoreSyn     ( CoreRule )
+import HscTypes    ( CompleteMatch )
+import Annotations ( Annotation )
+
+tcIfaceDecl         :: Bool -> IfaceDecl -> IfL TyThing
+tcIfaceRules        :: Bool -> [IfaceRule] -> IfL [CoreRule]
+tcIfaceInst         :: IfaceClsInst -> IfL ClsInst
+tcIfaceFamInst      :: IfaceFamInst -> IfL FamInst
+tcIfaceAnnotations  :: [IfaceAnnotation] -> IfL [Annotation]
+tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/Llvm.hs
@@ -0,0 +1,64 @@
+-- ----------------------------------------------------------------------------
+-- | This module supplies bindings to generate Llvm IR from Haskell
+-- (<http://www.llvm.org/docs/LangRef.html>).
+--
+-- Note: this module is developed in a demand driven way. It is no complete
+-- LLVM binding library in Haskell, but enough to generate code for GHC.
+--
+-- This code is derived from code taken from the Essential Haskell Compiler
+-- (EHC) project (<http://www.cs.uu.nl/wiki/Ehc/WebHome>).
+--
+
+module Llvm (
+
+        -- * Modules, Functions and Blocks
+        LlvmModule(..),
+
+        LlvmFunction(..), LlvmFunctionDecl(..),
+        LlvmFunctions, LlvmFunctionDecls,
+        LlvmStatement(..), LlvmExpression(..),
+        LlvmBlocks, LlvmBlock(..), LlvmBlockId,
+        LlvmParamAttr(..), LlvmParameter,
+
+        -- * Atomic operations
+        LlvmAtomicOp(..),
+
+        -- * Fence synchronization
+        LlvmSyncOrdering(..),
+
+        -- * Call Handling
+        LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..),
+        LlvmLinkageType(..), LlvmFuncAttr(..),
+
+        -- * Operations and Comparisons
+        LlvmCmpOp(..), LlvmMachOp(..), LlvmCastOp(..),
+
+        -- * Variables and Type System
+        LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..),
+        LlvmAlias, LMGlobal(..), LMString, LMSection, LMAlign,
+        LMConst(..),
+
+        -- ** Some basic types
+        i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr,
+
+        -- ** Metadata types
+        MetaExpr(..), MetaAnnot(..), MetaDecl(..), MetaId(..),
+
+        -- ** Operations on the type system.
+        isGlobal, getLitType, getVarType,
+        getLink, getStatType, pVarLift, pVarLower,
+        pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits,
+
+        -- * Pretty Printing
+        ppLit, ppName, ppPlainName,
+        ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
+        ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,
+        ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,
+
+    ) where
+
+import Llvm.AbsSyn
+import Llvm.MetaData
+import Llvm.PpLlvm
+import Llvm.Types
+
diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/Llvm/AbsSyn.hs
@@ -0,0 +1,352 @@
+--------------------------------------------------------------------------------
+-- | The LLVM abstract syntax.
+--
+
+module Llvm.AbsSyn where
+
+import GhcPrelude
+
+import Llvm.MetaData
+import Llvm.Types
+
+import Unique
+
+-- | Block labels
+type LlvmBlockId = Unique
+
+-- | A block of LLVM code.
+data LlvmBlock = LlvmBlock {
+    -- | The code label for this block
+    blockLabel :: LlvmBlockId,
+
+    -- | A list of LlvmStatement's representing the code for this block.
+    -- This list must end with a control flow statement.
+    blockStmts :: [LlvmStatement]
+  }
+
+type LlvmBlocks = [LlvmBlock]
+
+-- | An LLVM Module. This is a top level container in LLVM.
+data LlvmModule = LlvmModule  {
+    -- | Comments to include at the start of the module.
+    modComments  :: [LMString],
+
+    -- | LLVM Alias type definitions.
+    modAliases   :: [LlvmAlias],
+
+    -- | LLVM meta data.
+    modMeta      :: [MetaDecl],
+
+    -- | Global variables to include in the module.
+    modGlobals   :: [LMGlobal],
+
+    -- | LLVM Functions used in this module but defined in other modules.
+    modFwdDecls  :: LlvmFunctionDecls,
+
+    -- | LLVM Functions defined in this module.
+    modFuncs     :: LlvmFunctions
+  }
+
+-- | An LLVM Function
+data LlvmFunction = LlvmFunction {
+    -- | The signature of this declared function.
+    funcDecl      :: LlvmFunctionDecl,
+
+    -- | The functions arguments
+    funcArgs      :: [LMString],
+
+    -- | The function attributes.
+    funcAttrs     :: [LlvmFuncAttr],
+
+    -- | The section to put the function into,
+    funcSect      :: LMSection,
+
+    -- | Prefix data
+    funcPrefix    :: Maybe LlvmStatic,
+
+    -- | The body of the functions.
+    funcBody      :: LlvmBlocks
+  }
+
+type LlvmFunctions = [LlvmFunction]
+
+type SingleThreaded = Bool
+
+-- | LLVM ordering types for synchronization purposes. (Introduced in LLVM
+-- 3.0). Please see the LLVM documentation for a better description.
+data LlvmSyncOrdering
+  -- | Some partial order of operations exists.
+  = SyncUnord
+  -- | A single total order for operations at a single address exists.
+  | SyncMonotonic
+  -- | Acquire synchronization operation.
+  | SyncAcquire
+  -- | Release synchronization operation.
+  | SyncRelease
+  -- | Acquire + Release synchronization operation.
+  | SyncAcqRel
+  -- | Full sequential Consistency operation.
+  | SyncSeqCst
+  deriving (Show, Eq)
+
+-- | LLVM atomic operations. Please see the @atomicrmw@ instruction in
+-- the LLVM documentation for a complete description.
+data LlvmAtomicOp
+  = LAO_Xchg
+  | LAO_Add
+  | LAO_Sub
+  | LAO_And
+  | LAO_Nand
+  | LAO_Or
+  | LAO_Xor
+  | LAO_Max
+  | LAO_Min
+  | LAO_Umax
+  | LAO_Umin
+  deriving (Show, Eq)
+
+-- | Llvm Statements
+data LlvmStatement
+  {- |
+    Assign an expression to a variable:
+      * dest:   Variable to assign to
+      * source: Source expression
+  -}
+  = Assignment LlvmVar LlvmExpression
+
+  {- |
+    Memory fence operation
+  -}
+  | Fence Bool LlvmSyncOrdering
+
+  {- |
+    Always branch to the target label
+  -}
+  | Branch LlvmVar
+
+  {- |
+    Branch to label targetTrue if cond is true otherwise to label targetFalse
+      * cond:        condition that will be tested, must be of type i1
+      * targetTrue:  label to branch to if cond is true
+      * targetFalse: label to branch to if cond is false
+  -}
+  | BranchIf LlvmVar LlvmVar LlvmVar
+
+  {- |
+    Comment
+    Plain comment.
+  -}
+  | Comment [LMString]
+
+  {- |
+    Set a label on this position.
+      * name: Identifier of this label, unique for this module
+  -}
+  | MkLabel LlvmBlockId
+
+  {- |
+    Store variable value in pointer ptr. If value is of type t then ptr must
+    be of type t*.
+      * value: Variable/Constant to store.
+      * ptr:   Location to store the value in
+  -}
+  | Store LlvmVar LlvmVar
+
+  {- |
+    Multiway branch
+      * scrutinee: Variable or constant which must be of integer type that is
+                   determines which arm is chosen.
+      * def:       The default label if there is no match in target.
+      * target:    A list of (value,label) where the value is an integer
+                   constant and label the corresponding label to jump to if the
+                   scrutinee matches the value.
+  -}
+  | Switch LlvmVar LlvmVar [(LlvmVar, LlvmVar)]
+
+  {- |
+    Return a result.
+      * result: The variable or constant to return
+  -}
+  | Return (Maybe LlvmVar)
+
+  {- |
+    An instruction for the optimizer that the code following is not reachable
+  -}
+  | Unreachable
+
+  {- |
+    Raise an expression to a statement (if don't want result or want to use
+    Llvm unnamed values.
+  -}
+  | Expr LlvmExpression
+
+  {- |
+    A nop LLVM statement. Useful as its often more efficient to use this
+    then to wrap LLvmStatement in a Just or [].
+  -}
+  | Nop
+
+  {- |
+    A LLVM statement with metadata attached to it.
+  -}
+  | MetaStmt [MetaAnnot] LlvmStatement
+
+  deriving (Eq)
+
+
+-- | Llvm Expressions
+data LlvmExpression
+  {- |
+    Allocate amount * sizeof(tp) bytes on the stack
+      * tp:     LlvmType to reserve room for
+      * amount: The nr of tp's which must be allocated
+  -}
+  = Alloca LlvmType Int
+
+  {- |
+    Perform the machine operator op on the operands left and right
+      * op:    operator
+      * left:  left operand
+      * right: right operand
+  -}
+  | LlvmOp LlvmMachOp LlvmVar LlvmVar
+
+  {- |
+    Perform a compare operation on the operands left and right
+      * op:    operator
+      * left:  left operand
+      * right: right operand
+  -}
+  | Compare LlvmCmpOp LlvmVar LlvmVar
+
+  {- |
+    Extract a scalar element from a vector
+      * val: The vector
+      * idx: The index of the scalar within the vector
+  -}
+  | Extract LlvmVar LlvmVar
+
+  {- |
+    Extract a scalar element from a structure
+      * val: The structure
+      * idx: The index of the scalar within the structure
+    Corresponds to "extractvalue" instruction.
+  -}
+  | ExtractV LlvmVar Int
+
+  {- |
+    Insert a scalar element into a vector
+      * val:   The source vector
+      * elt:   The scalar to insert
+      * index: The index at which to insert the scalar
+  -}
+  | Insert LlvmVar LlvmVar LlvmVar
+
+  {- |
+    Allocate amount * sizeof(tp) bytes on the heap
+      * tp:     LlvmType to reserve room for
+      * amount: The nr of tp's which must be allocated
+  -}
+  | Malloc LlvmType Int
+
+  {- |
+    Load the value at location ptr
+  -}
+  | Load LlvmVar
+
+  {- |
+    Atomic load of the value at location ptr
+  -}
+  | ALoad LlvmSyncOrdering SingleThreaded LlvmVar
+
+  {- |
+    Navigate in a structure, selecting elements
+      * inbound: Is the pointer inbounds? (computed pointer doesn't overflow)
+      * ptr:     Location of the structure
+      * indexes: A list of indexes to select the correct value.
+  -}
+  | GetElemPtr Bool LlvmVar [LlvmVar]
+
+  {- |
+    Cast the variable from to the to type. This is an abstraction of three
+    cast operators in Llvm, inttoptr, ptrtoint and bitcast.
+       * cast: Cast type
+       * from: Variable to cast
+       * to:   type to cast to
+  -}
+  | Cast LlvmCastOp LlvmVar LlvmType
+
+  {- |
+    Atomic read-modify-write operation
+       * op:       Atomic operation
+       * addr:     Address to modify
+       * operand:  Operand to operation
+       * ordering: Ordering requirement
+  -}
+  | AtomicRMW LlvmAtomicOp LlvmVar LlvmVar LlvmSyncOrdering
+
+  {- |
+    Compare-and-exchange operation
+       * addr:     Address to modify
+       * old:      Expected value
+       * new:      New value
+       * suc_ord:  Ordering required in success case
+       * fail_ord: Ordering required in failure case, can be no stronger than
+                   suc_ord
+
+    Result is an @i1@, true if store was successful.
+  -}
+  | CmpXChg LlvmVar LlvmVar LlvmVar LlvmSyncOrdering LlvmSyncOrdering
+
+  {- |
+    Call a function. The result is the value of the expression.
+      * tailJumps: CallType to signal if the function should be tail called
+      * fnptrval:  An LLVM value containing a pointer to a function to be
+                   invoked. Can be indirect. Should be LMFunction type.
+      * args:      Concrete arguments for the parameters
+      * attrs:     A list of function attributes for the call. Only NoReturn,
+                   NoUnwind, ReadOnly and ReadNone are valid here.
+  -}
+  | Call LlvmCallType LlvmVar [LlvmVar] [LlvmFuncAttr]
+
+  {- |
+    Call a function as above but potentially taking metadata as arguments.
+      * tailJumps: CallType to signal if the function should be tail called
+      * fnptrval:  An LLVM value containing a pointer to a function to be
+                   invoked. Can be indirect. Should be LMFunction type.
+      * args:      Arguments that may include metadata.
+      * attrs:     A list of function attributes for the call. Only NoReturn,
+                   NoUnwind, ReadOnly and ReadNone are valid here.
+  -}
+  | CallM LlvmCallType LlvmVar [MetaExpr] [LlvmFuncAttr]
+
+  {- |
+    Merge variables from different basic blocks which are predecessors of this
+    basic block in a new variable of type tp.
+      * tp:         type of the merged variable, must match the types of the
+                    predecessor variables.
+      * predecessors: A list of variables and the basic block that they originate
+                      from.
+  -}
+  | Phi LlvmType [(LlvmVar,LlvmVar)]
+
+  {- |
+    Inline assembly expression. Syntax is very similar to the style used by GCC.
+      * assembly:    Actual inline assembly code.
+      * constraints: Operand constraints.
+      * return ty:   Return type of function.
+      * vars:        Any variables involved in the assembly code.
+      * sideeffect:  Does the expression have side effects not visible from the
+                     constraints list.
+      * alignstack:  Should the stack be conservatively aligned before this
+                     expression is executed.
+  -}
+  | Asm LMString LMString LlvmType [LlvmVar] Bool Bool
+
+  {- |
+    A LLVM expression with metadata attached to it.
+  -}
+  | MExpr [MetaAnnot] LlvmExpression
+
+  deriving (Eq)
+
diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/Llvm/MetaData.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Llvm.MetaData where
+
+import GhcPrelude
+
+import Llvm.Types
+import Outputable
+
+-- The LLVM Metadata System.
+--
+-- The LLVM metadata feature is poorly documented but roughly follows the
+-- following design:
+-- * Metadata can be constructed in a few different ways (See below).
+-- * After which it can either be attached to LLVM statements to pass along
+-- extra information to the optimizer and code generator OR specifically named
+-- metadata has an affect on the whole module (i.e., linking behaviour).
+--
+--
+-- # Constructing metadata
+-- Metadata comes largely in three forms:
+--
+-- * Metadata expressions -- these are the raw metadata values that encode
+--   information. They consist of metadata strings, metadata nodes, regular
+--   LLVM values (both literals and references to global variables) and
+--   metadata expressions (i.e., recursive data type). Some examples:
+--     !{ !"hello", !0, i32 0 }
+--     !{ !1, !{ i32 0 } }
+--
+-- * Metadata nodes -- global metadata variables that attach a metadata
+--   expression to a number. For example:
+--     !0 = !{ [<metadata expressions>] !}
+--
+-- * Named metadata -- global metadata variables that attach a metadata nodes
+--   to a name. Used ONLY to communicated module level information to LLVM
+--   through a meaningful name. For example:
+--     !llvm.module.linkage = !{ !0, !1 }
+--
+--
+-- # Using Metadata
+-- Using metadata depends on the form it is in:
+--
+-- * Attach to instructions -- metadata can be attached to LLVM instructions
+--   using a specific reference as follows:
+--     %l = load i32* @glob, !nontemporal !10
+--     %m = load i32* @glob, !nontemporal !{ i32 0, !{ i32 0 } }
+--   Only metadata nodes or expressions can be attached, named metadata cannot.
+--   Refer to LLVM documentation for which instructions take metadata and its
+--   meaning.
+--
+-- * As arguments -- llvm functions can take metadata as arguments, for
+--   example:
+--     call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1)
+--   As with instructions, only metadata nodes or expressions can be attached.
+--
+-- * As a named metadata -- Here the metadata is simply declared in global
+--   scope using a specific name to communicate module level information to LLVM.
+--   For example:
+--     !llvm.module.linkage = !{ !0, !1 }
+--
+
+-- | A reference to an un-named metadata node.
+newtype MetaId = MetaId Int
+               deriving (Eq, Ord, Enum)
+
+instance Outputable MetaId where
+    ppr (MetaId n) = char '!' <> int n
+
+-- | LLVM metadata expressions
+data MetaExpr = MetaStr !LMString
+              | MetaNode !MetaId
+              | MetaVar !LlvmVar
+              | MetaStruct [MetaExpr]
+              deriving (Eq)
+
+instance Outputable MetaExpr where
+  ppr (MetaVar (LMLitVar (LMNullLit _))) = text "null"
+  ppr (MetaStr    s ) = char '!' <> doubleQuotes (ftext s)
+  ppr (MetaNode   n ) = ppr n
+  ppr (MetaVar    v ) = ppr v
+  ppr (MetaStruct es) = char '!' <> braces (ppCommaJoin es)
+
+-- | Associates some metadata with a specific label for attaching to an
+-- instruction.
+data MetaAnnot = MetaAnnot LMString MetaExpr
+               deriving (Eq)
+
+-- | Metadata declarations. Metadata can only be declared in global scope.
+data MetaDecl
+    -- | Named metadata. Only used for communicating module information to
+    -- LLVM. ('!name = !{ [!<n>] }' form).
+    = MetaNamed !LMString [MetaId]
+    -- | Metadata node declaration.
+    -- ('!0 = metadata !{ <metadata expression> }' form).
+    | MetaUnnamed !MetaId !MetaExpr
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -0,0 +1,499 @@
+{-# LANGUAGE CPP #-}
+
+--------------------------------------------------------------------------------
+-- | Pretty print LLVM IR Code.
+--
+
+module Llvm.PpLlvm (
+
+    -- * Top level LLVM objects.
+    ppLlvmModule,
+    ppLlvmComments,
+    ppLlvmComment,
+    ppLlvmGlobals,
+    ppLlvmGlobal,
+    ppLlvmAliases,
+    ppLlvmAlias,
+    ppLlvmMetas,
+    ppLlvmMeta,
+    ppLlvmFunctionDecls,
+    ppLlvmFunctionDecl,
+    ppLlvmFunctions,
+    ppLlvmFunction,
+
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Llvm.AbsSyn
+import Llvm.MetaData
+import Llvm.Types
+
+import Data.List ( intersperse )
+import Outputable
+import Unique
+import FastString ( sLit )
+
+--------------------------------------------------------------------------------
+-- * Top Level Print functions
+--------------------------------------------------------------------------------
+
+-- | Print out a whole LLVM module.
+ppLlvmModule :: LlvmModule -> SDoc
+ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)
+  = ppLlvmComments comments $+$ newLine
+    $+$ ppLlvmAliases aliases $+$ newLine
+    $+$ ppLlvmMetas meta $+$ newLine
+    $+$ ppLlvmGlobals globals $+$ newLine
+    $+$ ppLlvmFunctionDecls decls $+$ newLine
+    $+$ ppLlvmFunctions funcs
+
+-- | Print out a multi-line comment, can be inside a function or on its own
+ppLlvmComments :: [LMString] -> SDoc
+ppLlvmComments comments = vcat $ map ppLlvmComment comments
+
+-- | Print out a comment, can be inside a function or on its own
+ppLlvmComment :: LMString -> SDoc
+ppLlvmComment com = semi <+> ftext com
+
+
+-- | Print out a list of global mutable variable definitions
+ppLlvmGlobals :: [LMGlobal] -> SDoc
+ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
+
+-- | Print out a global mutable variable definition
+ppLlvmGlobal :: LMGlobal -> SDoc
+ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
+    let sect = case x of
+            Just x' -> text ", section" <+> doubleQuotes (ftext x')
+            Nothing -> empty
+
+        align = case a of
+            Just a' -> text ", align" <+> int a'
+            Nothing -> empty
+
+        rhs = case dat of
+            Just stat -> pprSpecialStatic stat
+            Nothing   -> ppr (pLower $ getVarType var)
+
+        -- Position of linkage is different for aliases.
+        const = case c of
+          Global   -> "global"
+          Constant -> "constant"
+          Alias    -> "alias"
+
+    in ppAssignment var $ ppr link <+> text const <+> rhs <> sect <> align
+       $+$ newLine
+
+ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags ->
+  error $ "Non Global var ppr as global! "
+          ++ showSDoc dflags (ppr var) ++ " " ++ showSDoc dflags (ppr val)
+
+
+-- | Print out a list of LLVM type aliases.
+ppLlvmAliases :: [LlvmAlias] -> SDoc
+ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
+
+-- | Print out an LLVM type alias.
+ppLlvmAlias :: LlvmAlias -> SDoc
+ppLlvmAlias (name, ty)
+  = char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty
+
+
+-- | Print out a list of LLVM metadata.
+ppLlvmMetas :: [MetaDecl] -> SDoc
+ppLlvmMetas metas = vcat $ map ppLlvmMeta metas
+
+-- | Print out an LLVM metadata definition.
+ppLlvmMeta :: MetaDecl -> SDoc
+ppLlvmMeta (MetaUnnamed n m)
+  = ppr n <+> equals <+> ppr m
+
+ppLlvmMeta (MetaNamed n m)
+  = exclamation <> ftext n <+> equals <+> exclamation <> braces nodes
+  where
+    nodes = hcat $ intersperse comma $ map ppr m
+
+
+-- | Print out a list of function definitions.
+ppLlvmFunctions :: LlvmFunctions -> SDoc
+ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
+
+-- | Print out a function definition.
+ppLlvmFunction :: LlvmFunction -> SDoc
+ppLlvmFunction fun =
+    let attrDoc = ppSpaceJoin (funcAttrs fun)
+        secDoc = case funcSect fun of
+                      Just s' -> text "section" <+> (doubleQuotes $ ftext s')
+                      Nothing -> empty
+        prefixDoc = case funcPrefix fun of
+                        Just v  -> text "prefix" <+> ppr v
+                        Nothing -> empty
+    in text "define" <+> ppLlvmFunctionHeader (funcDecl fun) (funcArgs fun)
+        <+> attrDoc <+> secDoc <+> prefixDoc
+        $+$ lbrace
+        $+$ ppLlvmBlocks (funcBody fun)
+        $+$ rbrace
+        $+$ newLine
+        $+$ newLine
+
+-- | Print out a function definition header.
+ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc
+ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
+  = let varg' = case varg of
+                      VarArgs | null p    -> sLit "..."
+                              | otherwise -> sLit ", ..."
+                      _otherwise          -> sLit ""
+        align = case a of
+                     Just a' -> text " align " <> ppr a'
+                     Nothing -> empty
+        args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%'
+                                    <> ftext n)
+                    (zip p args)
+    in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <>
+        (hsep $ punctuate comma args') <> ptext varg' <> rparen <> align
+
+-- | Print out a list of function declaration.
+ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
+ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
+
+-- | Print out a function declaration.
+-- Declarations define the function type but don't define the actual body of
+-- the function.
+ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc
+ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
+  = let varg' = case varg of
+                      VarArgs | null p    -> sLit "..."
+                              | otherwise -> sLit ", ..."
+                      _otherwise          -> sLit ""
+        align = case a of
+                     Just a' -> text " align" <+> ppr a'
+                     Nothing -> empty
+        args = hcat $ intersperse (comma <> space) $
+                  map (\(t,a) -> ppr t <+> ppSpaceJoin a) p
+    in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <>
+        ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine
+
+
+-- | Print out a list of LLVM blocks.
+ppLlvmBlocks :: LlvmBlocks -> SDoc
+ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks
+
+-- | Print out an LLVM block.
+-- It must be part of a function definition.
+ppLlvmBlock :: LlvmBlock -> SDoc
+ppLlvmBlock (LlvmBlock blockId stmts) =
+  let isLabel (MkLabel _) = True
+      isLabel _           = False
+      (block, rest)       = break isLabel stmts
+      ppRest = case rest of
+        MkLabel id:xs -> ppLlvmBlock (LlvmBlock id xs)
+        _             -> empty
+  in ppLlvmBlockLabel blockId
+           $+$ (vcat $ map ppLlvmStatement block)
+           $+$ newLine
+           $+$ ppRest
+
+-- | Print out an LLVM block label.
+ppLlvmBlockLabel :: LlvmBlockId -> SDoc
+ppLlvmBlockLabel id = pprUniqueAlways id <> colon
+
+
+-- | Print out an LLVM statement.
+ppLlvmStatement :: LlvmStatement -> SDoc
+ppLlvmStatement stmt =
+  let ind = (text "  " <>)
+  in case stmt of
+        Assignment  dst expr      -> ind $ ppAssignment dst (ppLlvmExpression expr)
+        Fence       st ord        -> ind $ ppFence st ord
+        Branch      target        -> ind $ ppBranch target
+        BranchIf    cond ifT ifF  -> ind $ ppBranchIf cond ifT ifF
+        Comment     comments      -> ind $ ppLlvmComments comments
+        MkLabel     label         -> ppLlvmBlockLabel label
+        Store       value ptr     -> ind $ ppStore value ptr
+        Switch      scrut def tgs -> ind $ ppSwitch scrut def tgs
+        Return      result        -> ind $ ppReturn result
+        Expr        expr          -> ind $ ppLlvmExpression expr
+        Unreachable               -> ind $ text "unreachable"
+        Nop                       -> empty
+        MetaStmt    meta s        -> ppMetaStatement meta s
+
+
+-- | Print out an LLVM expression.
+ppLlvmExpression :: LlvmExpression -> SDoc
+ppLlvmExpression expr
+  = case expr of
+        Alloca     tp amount        -> ppAlloca tp amount
+        LlvmOp     op left right    -> ppMachOp op left right
+        Call       tp fp args attrs -> ppCall tp fp (map MetaVar args) attrs
+        CallM      tp fp args attrs -> ppCall tp fp args attrs
+        Cast       op from to       -> ppCast op from to
+        Compare    op left right    -> ppCmpOp op left right
+        Extract    vec idx          -> ppExtract vec idx
+        ExtractV   struct idx       -> ppExtractV struct idx
+        Insert     vec elt idx      -> ppInsert vec elt idx
+        GetElemPtr inb ptr indexes  -> ppGetElementPtr inb ptr indexes
+        Load       ptr              -> ppLoad ptr
+        ALoad      ord st ptr       -> ppALoad ord st ptr
+        Malloc     tp amount        -> ppMalloc tp amount
+        AtomicRMW  aop tgt src ordering -> ppAtomicRMW aop tgt src ordering
+        CmpXChg    addr old new s_ord f_ord -> ppCmpXChg addr old new s_ord f_ord
+        Phi        tp predecessors  -> ppPhi tp predecessors
+        Asm        asm c ty v se sk -> ppAsm asm c ty v se sk
+        MExpr      meta expr        -> ppMetaExpr meta expr
+
+
+--------------------------------------------------------------------------------
+-- * Individual print functions
+--------------------------------------------------------------------------------
+
+-- | Should always be a function pointer. So a global var of function type
+-- (since globals are always pointers) or a local var of pointer function type.
+ppCall :: LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
+ppCall ct fptr args attrs = case fptr of
+                           --
+    -- if local var function pointer, unwrap
+    LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
+
+    -- should be function type otherwise
+    LMGlobalVar _ (LMFunction d) _ _ _ _    -> ppCall' d
+
+    -- not pointer or function, so error
+    _other -> error $ "ppCall called with non LMFunction type!\nMust be "
+                ++ " called with either global var of function type or "
+                ++ "local var of pointer function type."
+
+    where
+        ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
+            let tc = if ct == TailCall then text "tail " else empty
+                ppValues = hsep $ punctuate comma $ map ppCallMetaExpr args
+                ppArgTy  = (ppCommaJoin $ map fst params) <>
+                           (case argTy of
+                               VarArgs   -> text ", ..."
+                               FixedArgs -> empty)
+                fnty = space <> lparen <> ppArgTy <> rparen
+                attrDoc = ppSpaceJoin attrs
+            in  tc <> text "call" <+> ppr cc <+> ppr ret
+                    <> fnty <+> ppName fptr <> lparen <+> ppValues
+                    <+> rparen <+> attrDoc
+
+        -- Metadata needs to be marked as having the `metadata` type when used
+        -- in a call argument
+        ppCallMetaExpr (MetaVar v) = ppr v
+        ppCallMetaExpr v           = text "metadata" <+> ppr v
+
+ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
+ppMachOp op left right =
+  (ppr op) <+> (ppr (getVarType left)) <+> ppName left
+        <> comma <+> ppName right
+
+
+ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
+ppCmpOp op left right =
+  let cmpOp
+        | isInt (getVarType left) && isInt (getVarType right) = text "icmp"
+        | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"
+        | otherwise = text "icmp" -- Just continue as its much easier to debug
+        {-
+        | otherwise = error ("can't compare different types, left = "
+                ++ (show $ getVarType left) ++ ", right = "
+                ++ (show $ getVarType right))
+        -}
+  in cmpOp <+> ppr op <+> ppr (getVarType left)
+        <+> ppName left <> comma <+> ppName right
+
+
+ppAssignment :: LlvmVar -> SDoc -> SDoc
+ppAssignment var expr = ppName var <+> equals <+> expr
+
+ppFence :: Bool -> LlvmSyncOrdering -> SDoc
+ppFence st ord =
+  let singleThread = case st of True  -> text "singlethread"
+                                False -> empty
+  in text "fence" <+> singleThread <+> ppSyncOrdering ord
+
+ppSyncOrdering :: LlvmSyncOrdering -> SDoc
+ppSyncOrdering SyncUnord     = text "unordered"
+ppSyncOrdering SyncMonotonic = text "monotonic"
+ppSyncOrdering SyncAcquire   = text "acquire"
+ppSyncOrdering SyncRelease   = text "release"
+ppSyncOrdering SyncAcqRel    = text "acq_rel"
+ppSyncOrdering SyncSeqCst    = text "seq_cst"
+
+ppAtomicOp :: LlvmAtomicOp -> SDoc
+ppAtomicOp LAO_Xchg = text "xchg"
+ppAtomicOp LAO_Add  = text "add"
+ppAtomicOp LAO_Sub  = text "sub"
+ppAtomicOp LAO_And  = text "and"
+ppAtomicOp LAO_Nand = text "nand"
+ppAtomicOp LAO_Or   = text "or"
+ppAtomicOp LAO_Xor  = text "xor"
+ppAtomicOp LAO_Max  = text "max"
+ppAtomicOp LAO_Min  = text "min"
+ppAtomicOp LAO_Umax = text "umax"
+ppAtomicOp LAO_Umin = text "umin"
+
+ppAtomicRMW :: LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
+ppAtomicRMW aop tgt src ordering =
+  text "atomicrmw" <+> ppAtomicOp aop <+> ppr tgt <> comma
+  <+> ppr src <+> ppSyncOrdering ordering
+
+ppCmpXChg :: LlvmVar -> LlvmVar -> LlvmVar
+          -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc
+ppCmpXChg addr old new s_ord f_ord =
+  text "cmpxchg" <+> ppr addr <> comma <+> ppr old <> comma <+> ppr new
+  <+> ppSyncOrdering s_ord <+> ppSyncOrdering f_ord
+
+-- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but
+-- we have no way of guaranteeing that this is true with GHC (we would need to
+-- modify the layout of the stack and closures, change the storage manager,
+-- etc.). So, we blindly tell LLVM that *any* vector store or load could be
+-- unaligned. In the future we may be able to guarantee that certain vector
+-- access patterns are aligned, in which case we will need a more granular way
+-- of specifying alignment.
+
+ppLoad :: LlvmVar -> SDoc
+ppLoad var = text "load" <+> ppr derefType <> comma <+> ppr var <> align
+  where
+    derefType = pLower $ getVarType var
+    align | isVector . pLower . getVarType $ var = text ", align 1"
+          | otherwise = empty
+
+ppALoad :: LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc
+ppALoad ord st var = sdocWithDynFlags $ \dflags ->
+  let alignment = (llvmWidthInBits dflags $ getVarType var) `quot` 8
+      align     = text ", align" <+> ppr alignment
+      sThreaded | st        = text " singlethread"
+                | otherwise = empty
+      derefType = pLower $ getVarType var
+  in text "load atomic" <+> ppr derefType <> comma <+> ppr var <> sThreaded
+            <+> ppSyncOrdering ord <> align
+
+ppStore :: LlvmVar -> LlvmVar -> SDoc
+ppStore val dst
+    | isVecPtrVar dst = text "store" <+> ppr val <> comma <+> ppr dst <>
+                        comma <+> text "align 1"
+    | otherwise       = text "store" <+> ppr val <> comma <+> ppr dst
+  where
+    isVecPtrVar :: LlvmVar -> Bool
+    isVecPtrVar = isVector . pLower . getVarType
+
+
+ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
+ppCast op from to
+    =   ppr op
+    <+> ppr (getVarType from) <+> ppName from
+    <+> text "to"
+    <+> ppr to
+
+
+ppMalloc :: LlvmType -> Int -> SDoc
+ppMalloc tp amount =
+  let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
+  in text "malloc" <+> ppr tp <> comma <+> ppr amount'
+
+
+ppAlloca :: LlvmType -> Int -> SDoc
+ppAlloca tp amount =
+  let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
+  in text "alloca" <+> ppr tp <> comma <+> ppr amount'
+
+
+ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc
+ppGetElementPtr inb ptr idx =
+  let indexes = comma <+> ppCommaJoin idx
+      inbound = if inb then text "inbounds" else empty
+      derefType = pLower $ getVarType ptr
+  in text "getelementptr" <+> inbound <+> ppr derefType <> comma <+> ppr ptr
+                            <> indexes
+
+
+ppReturn :: Maybe LlvmVar -> SDoc
+ppReturn (Just var) = text "ret" <+> ppr var
+ppReturn Nothing    = text "ret" <+> ppr LMVoid
+
+
+ppBranch :: LlvmVar -> SDoc
+ppBranch var = text "br" <+> ppr var
+
+
+ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
+ppBranchIf cond trueT falseT
+  = text "br" <+> ppr cond <> comma <+> ppr trueT <> comma <+> ppr falseT
+
+
+ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
+ppPhi tp preds =
+  let ppPreds (val, label) = brackets $ ppName val <> comma <+> ppName label
+  in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds)
+
+
+ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
+ppSwitch scrut dflt targets =
+  let ppTarget  (val, lab) = ppr val <> comma <+> ppr lab
+      ppTargets  xs        = brackets $ vcat (map ppTarget xs)
+  in text "switch" <+> ppr scrut <> comma <+> ppr dflt
+        <+> ppTargets targets
+
+
+ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
+ppAsm asm constraints rty vars sideeffect alignstack =
+  let asm'  = doubleQuotes $ ftext asm
+      cons  = doubleQuotes $ ftext constraints
+      rty'  = ppr rty
+      vars' = lparen <+> ppCommaJoin vars <+> rparen
+      side  = if sideeffect then text "sideeffect" else empty
+      align = if alignstack then text "alignstack" else empty
+  in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma
+        <+> cons <> vars'
+
+ppExtract :: LlvmVar -> LlvmVar -> SDoc
+ppExtract vec idx =
+    text "extractelement"
+    <+> ppr (getVarType vec) <+> ppName vec <> comma
+    <+> ppr idx
+
+ppExtractV :: LlvmVar -> Int -> SDoc
+ppExtractV struct idx =
+    text "extractvalue"
+    <+> ppr (getVarType struct) <+> ppName struct <> comma
+    <+> ppr idx
+
+ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
+ppInsert vec elt idx =
+    text "insertelement"
+    <+> ppr (getVarType vec) <+> ppName vec <> comma
+    <+> ppr (getVarType elt) <+> ppName elt <> comma
+    <+> ppr idx
+
+
+ppMetaStatement :: [MetaAnnot] -> LlvmStatement -> SDoc
+ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetaAnnots meta
+
+ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc
+ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetaAnnots meta
+
+ppMetaAnnots :: [MetaAnnot] -> SDoc
+ppMetaAnnots meta = hcat $ map ppMeta meta
+  where
+    ppMeta (MetaAnnot name e)
+        = comma <+> exclamation <> ftext name <+>
+          case e of
+            MetaNode n    -> ppr n
+            MetaStruct ms -> exclamation <> braces (ppCommaJoin ms)
+            other         -> exclamation <> braces (ppr other) -- possible?
+
+
+--------------------------------------------------------------------------------
+-- * Misc functions
+--------------------------------------------------------------------------------
+
+-- | Blank line.
+newLine :: SDoc
+newLine = empty
+
+-- | Exclamation point.
+exclamation :: SDoc
+exclamation = char '!'
diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -0,0 +1,893 @@
+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
+
+--------------------------------------------------------------------------------
+-- | The LLVM Type System.
+--
+
+module Llvm.Types where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Data.Char
+import Data.Int
+import Numeric
+
+import DynFlags
+import FastString
+import Outputable
+import Unique
+
+-- from NCG
+import PprBase
+
+import GHC.Float
+
+-- -----------------------------------------------------------------------------
+-- * LLVM Basic Types and Variables
+--
+
+-- | A global mutable variable. Maybe defined or external
+data LMGlobal = LMGlobal {
+  getGlobalVar :: LlvmVar,          -- ^ Returns the variable of the 'LMGlobal'
+  getGlobalValue :: Maybe LlvmStatic -- ^ Return the value of the 'LMGlobal'
+  }
+
+-- | A String in LLVM
+type LMString = FastString
+
+-- | A type alias
+type LlvmAlias = (LMString, LlvmType)
+
+-- | Llvm Types
+data LlvmType
+  = LMInt Int             -- ^ An integer with a given width in bits.
+  | LMFloat               -- ^ 32 bit floating point
+  | LMDouble              -- ^ 64 bit floating point
+  | LMFloat80             -- ^ 80 bit (x86 only) floating point
+  | LMFloat128            -- ^ 128 bit floating point
+  | LMPointer LlvmType    -- ^ A pointer to a 'LlvmType'
+  | LMArray Int LlvmType  -- ^ An array of 'LlvmType'
+  | LMVector Int LlvmType -- ^ A vector of 'LlvmType'
+  | LMLabel               -- ^ A 'LlvmVar' can represent a label (address)
+  | LMVoid                -- ^ Void type
+  | LMStruct [LlvmType]   -- ^ Packed structure type
+  | LMStructU [LlvmType]  -- ^ Unpacked structure type
+  | LMAlias LlvmAlias     -- ^ A type alias
+  | LMMetadata            -- ^ LLVM Metadata
+
+  -- | Function type, used to create pointers to functions
+  | LMFunction LlvmFunctionDecl
+  deriving (Eq)
+
+instance Outputable LlvmType where
+  ppr (LMInt size     ) = char 'i' <> ppr size
+  ppr (LMFloat        ) = text "float"
+  ppr (LMDouble       ) = text "double"
+  ppr (LMFloat80      ) = text "x86_fp80"
+  ppr (LMFloat128     ) = text "fp128"
+  ppr (LMPointer x    ) = ppr x <> char '*'
+  ppr (LMArray nr tp  ) = char '[' <> ppr nr <> text " x " <> ppr tp <> char ']'
+  ppr (LMVector nr tp ) = char '<' <> ppr nr <> text " x " <> ppr tp <> char '>'
+  ppr (LMLabel        ) = text "label"
+  ppr (LMVoid         ) = text "void"
+  ppr (LMStruct tys   ) = text "<{" <> ppCommaJoin tys <> text "}>"
+  ppr (LMStructU tys  ) = text "{" <> ppCommaJoin tys <> text "}"
+  ppr (LMMetadata     ) = text "metadata"
+
+  ppr (LMFunction (LlvmFunctionDecl _ _ _ r varg p _))
+    = ppr r <+> lparen <> ppParams varg p <> rparen
+
+  ppr (LMAlias (s,_)) = char '%' <> ftext s
+
+ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc
+ppParams varg p
+  = let varg' = case varg of
+          VarArgs | null args -> sLit "..."
+                  | otherwise -> sLit ", ..."
+          _otherwise          -> sLit ""
+        -- by default we don't print param attributes
+        args = map fst p
+    in ppCommaJoin args <> ptext varg'
+
+-- | An LLVM section definition. If Nothing then let LLVM decide the section
+type LMSection = Maybe LMString
+type LMAlign = Maybe Int
+
+data LMConst = Global      -- ^ Mutable global variable
+             | Constant    -- ^ Constant global variable
+             | Alias       -- ^ Alias of another variable
+             deriving (Eq)
+
+-- | LLVM Variables
+data LlvmVar
+  -- | Variables with a global scope.
+  = LMGlobalVar LMString LlvmType LlvmLinkageType LMSection LMAlign LMConst
+  -- | Variables local to a function or parameters.
+  | LMLocalVar Unique LlvmType
+  -- | Named local variables. Sometimes we need to be able to explicitly name
+  -- variables (e.g for function arguments).
+  | LMNLocalVar LMString LlvmType
+  -- | A constant variable
+  | LMLitVar LlvmLit
+  deriving (Eq)
+
+instance Outputable LlvmVar where
+  ppr (LMLitVar x)  = ppr x
+  ppr (x         )  = ppr (getVarType x) <+> ppName x
+
+
+-- | Llvm Literal Data.
+--
+-- These can be used inline in expressions.
+data LlvmLit
+  -- | Refers to an integer constant (i64 42).
+  = LMIntLit Integer LlvmType
+  -- | Floating point literal
+  | LMFloatLit Double LlvmType
+  -- | Literal NULL, only applicable to pointer types
+  | LMNullLit LlvmType
+  -- | Vector literal
+  | LMVectorLit [LlvmLit]
+  -- | Undefined value, random bit pattern. Useful for optimisations.
+  | LMUndefLit LlvmType
+  deriving (Eq)
+
+instance Outputable LlvmLit where
+  ppr l@(LMVectorLit {}) = ppLit l
+  ppr l                  = ppr (getLitType l) <+> ppLit l
+
+
+-- | Llvm Static Data.
+--
+-- These represent the possible global level variables and constants.
+data LlvmStatic
+  = LMComment LMString                  -- ^ A comment in a static section
+  | LMStaticLit LlvmLit                 -- ^ A static variant of a literal value
+  | LMUninitType LlvmType               -- ^ For uninitialised data
+  | LMStaticStr LMString LlvmType       -- ^ Defines a static 'LMString'
+  | LMStaticArray [LlvmStatic] LlvmType -- ^ A static array
+  | LMStaticStruc [LlvmStatic] LlvmType -- ^ A static structure type
+  | LMStaticPointer LlvmVar             -- ^ A pointer to other data
+
+  -- static expressions, could split out but leave
+  -- for moment for ease of use. Not many of them.
+
+  | LMTrunc LlvmStatic LlvmType        -- ^ Truncate
+  | LMBitc LlvmStatic LlvmType         -- ^ Pointer to Pointer conversion
+  | LMPtoI LlvmStatic LlvmType         -- ^ Pointer to Integer conversion
+  | LMAdd LlvmStatic LlvmStatic        -- ^ Constant addition operation
+  | LMSub LlvmStatic LlvmStatic        -- ^ Constant subtraction operation
+
+instance Outputable LlvmStatic where
+  ppr (LMComment       s) = text "; " <> ftext s
+  ppr (LMStaticLit   l  ) = ppr l
+  ppr (LMUninitType    t) = ppr t <> text " undef"
+  ppr (LMStaticStr   s t) = ppr t <> text " c\"" <> ftext s <> text "\\00\""
+  ppr (LMStaticArray d t) = ppr t <> text " [" <> ppCommaJoin d <> char ']'
+  ppr (LMStaticStruc d t) = ppr t <> text "<{" <> ppCommaJoin d <> text "}>"
+  ppr (LMStaticPointer v) = ppr v
+  ppr (LMTrunc v t)
+      = ppr t <> text " trunc (" <> ppr v <> text " to " <> ppr t <> char ')'
+  ppr (LMBitc v t)
+      = ppr t <> text " bitcast (" <> ppr v <> text " to " <> ppr t <> char ')'
+  ppr (LMPtoI v t)
+      = ppr t <> text " ptrtoint (" <> ppr v <> text " to " <> ppr t <> char ')'
+
+  ppr (LMAdd s1 s2)
+      = pprStaticArith s1 s2 (sLit "add") (sLit "fadd") "LMAdd"
+  ppr (LMSub s1 s2)
+      = pprStaticArith s1 s2 (sLit "sub") (sLit "fsub") "LMSub"
+
+
+pprSpecialStatic :: LlvmStatic -> SDoc
+pprSpecialStatic (LMBitc v t) =
+    ppr (pLower t) <> text ", bitcast (" <> ppr v <> text " to " <> ppr t
+        <> char ')'
+pprSpecialStatic stat = ppr stat
+
+
+pprStaticArith :: LlvmStatic -> LlvmStatic -> PtrString -> PtrString
+                  -> String -> SDoc
+pprStaticArith s1 s2 int_op float_op op_name =
+  let ty1 = getStatType s1
+      op  = if isFloat ty1 then float_op else int_op
+  in if ty1 == getStatType s2
+     then ppr ty1 <+> ptext op <+> lparen <> ppr s1 <> comma <> ppr s2 <> rparen
+     else sdocWithDynFlags $ \dflags ->
+            error $ op_name ++ " with different types! s1: "
+                    ++ showSDoc dflags (ppr s1) ++ ", s2: " ++ showSDoc dflags (ppr s2)
+
+-- -----------------------------------------------------------------------------
+-- ** Operations on LLVM Basic Types and Variables
+--
+
+-- | Return the variable name or value of the 'LlvmVar'
+-- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).
+ppName :: LlvmVar -> SDoc
+ppName v@(LMGlobalVar {}) = char '@' <> ppPlainName v
+ppName v@(LMLocalVar  {}) = char '%' <> ppPlainName v
+ppName v@(LMNLocalVar {}) = char '%' <> ppPlainName v
+ppName v@(LMLitVar    {}) =             ppPlainName v
+
+-- | Return the variable name or value of the 'LlvmVar'
+-- in a plain textual representation (e.g. @x@, @y@ or @42@).
+ppPlainName :: LlvmVar -> SDoc
+ppPlainName (LMGlobalVar x _ _ _ _ _) = ftext x
+ppPlainName (LMLocalVar  x LMLabel  ) = text (show x)
+ppPlainName (LMLocalVar  x _        ) = text ('l' : show x)
+ppPlainName (LMNLocalVar x _        ) = ftext x
+ppPlainName (LMLitVar    x          ) = ppLit x
+
+-- | Print a literal value. No type.
+ppLit :: LlvmLit -> SDoc
+ppLit (LMIntLit i (LMInt 32))  = ppr (fromInteger i :: Int32)
+ppLit (LMIntLit i (LMInt 64))  = ppr (fromInteger i :: Int64)
+ppLit (LMIntLit   i _       )  = ppr ((fromInteger i)::Int)
+ppLit (LMFloatLit r LMFloat )  = ppFloat $ narrowFp r
+ppLit (LMFloatLit r LMDouble)  = ppDouble r
+ppLit f@(LMFloatLit _ _)       = sdocWithDynFlags (\dflags ->
+                                   error $ "Can't print this float literal!" ++ showSDoc dflags (ppr f))
+ppLit (LMVectorLit ls  )       = char '<' <+> ppCommaJoin ls <+> char '>'
+ppLit (LMNullLit _     )       = text "null"
+-- Trac 11487 was an issue where we passed undef for some arguments
+-- that were actually live. By chance the registers holding those
+-- arguments usually happened to have the right values anyways, but
+-- that was not guaranteed. To find such bugs reliably, we set the
+-- flag below when validating, which replaces undef literals (at
+-- common types) with values that are likely to cause a crash or test
+-- failure.
+ppLit (LMUndefLit t    )       = sdocWithDynFlags f
+  where f dflags
+          | gopt Opt_LlvmFillUndefWithGarbage dflags,
+            Just lit <- garbageLit t   = ppLit lit
+          | otherwise                  = text "undef"
+
+garbageLit :: LlvmType -> Maybe LlvmLit
+garbageLit t@(LMInt w)     = Just (LMIntLit (0xbbbbbbbbbbbbbbb0 `mod` (2^w)) t)
+  -- Use a value that looks like an untagged pointer, so we are more
+  -- likely to try to enter it
+garbageLit t
+  | isFloat t              = Just (LMFloatLit 12345678.9 t)
+garbageLit t@(LMPointer _) = Just (LMNullLit t)
+  -- Using null isn't totally ideal, since some functions may check for null.
+  -- But producing another value is inconvenient since it needs a cast,
+  -- and the knowledge for how to format casts is in PpLlvm.
+garbageLit _               = Nothing
+  -- More cases could be added, but this should do for now.
+
+-- | Return the 'LlvmType' of the 'LlvmVar'
+getVarType :: LlvmVar -> LlvmType
+getVarType (LMGlobalVar _ y _ _ _ _) = y
+getVarType (LMLocalVar  _ y        ) = y
+getVarType (LMNLocalVar _ y        ) = y
+getVarType (LMLitVar    l          ) = getLitType l
+
+-- | Return the 'LlvmType' of a 'LlvmLit'
+getLitType :: LlvmLit -> LlvmType
+getLitType (LMIntLit   _ t) = t
+getLitType (LMFloatLit _ t) = t
+getLitType (LMVectorLit [])  = panic "getLitType"
+getLitType (LMVectorLit ls)  = LMVector (length ls) (getLitType (head ls))
+getLitType (LMNullLit    t) = t
+getLitType (LMUndefLit   t) = t
+
+-- | Return the 'LlvmType' of the 'LlvmStatic'
+getStatType :: LlvmStatic -> LlvmType
+getStatType (LMStaticLit   l  ) = getLitType l
+getStatType (LMUninitType    t) = t
+getStatType (LMStaticStr   _ t) = t
+getStatType (LMStaticArray _ t) = t
+getStatType (LMStaticStruc _ t) = t
+getStatType (LMStaticPointer v) = getVarType v
+getStatType (LMTrunc       _ t) = t
+getStatType (LMBitc        _ t) = t
+getStatType (LMPtoI        _ t) = t
+getStatType (LMAdd         t _) = getStatType t
+getStatType (LMSub         t _) = getStatType t
+getStatType (LMComment       _) = error "Can't call getStatType on LMComment!"
+
+-- | Return the 'LlvmLinkageType' for a 'LlvmVar'
+getLink :: LlvmVar -> LlvmLinkageType
+getLink (LMGlobalVar _ _ l _ _ _) = l
+getLink _                         = Internal
+
+-- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid'
+-- cannot be lifted.
+pLift :: LlvmType -> LlvmType
+pLift LMLabel    = error "Labels are unliftable"
+pLift LMVoid     = error "Voids are unliftable"
+pLift LMMetadata = error "Metadatas are unliftable"
+pLift x          = LMPointer x
+
+-- | Lift a variable to 'LMPointer' type.
+pVarLift :: LlvmVar -> LlvmVar
+pVarLift (LMGlobalVar s t l x a c) = LMGlobalVar s (pLift t) l x a c
+pVarLift (LMLocalVar  s t        ) = LMLocalVar  s (pLift t)
+pVarLift (LMNLocalVar s t        ) = LMNLocalVar s (pLift t)
+pVarLift (LMLitVar    _          ) = error $ "Can't lower a literal type!"
+
+-- | Remove the pointer indirection of the supplied type. Only 'LMPointer'
+-- constructors can be lowered.
+pLower :: LlvmType -> LlvmType
+pLower (LMPointer x) = x
+pLower x  = pprPanic "llvmGen(pLower)"
+            $ ppr x <+> text " is a unlowerable type, need a pointer"
+
+-- | Lower a variable of 'LMPointer' type.
+pVarLower :: LlvmVar -> LlvmVar
+pVarLower (LMGlobalVar s t l x a c) = LMGlobalVar s (pLower t) l x a c
+pVarLower (LMLocalVar  s t        ) = LMLocalVar  s (pLower t)
+pVarLower (LMNLocalVar s t        ) = LMNLocalVar s (pLower t)
+pVarLower (LMLitVar    _          ) = error $ "Can't lower a literal type!"
+
+-- | Test if the given 'LlvmType' is an integer
+isInt :: LlvmType -> Bool
+isInt (LMInt _) = True
+isInt _         = False
+
+-- | Test if the given 'LlvmType' is a floating point type
+isFloat :: LlvmType -> Bool
+isFloat LMFloat    = True
+isFloat LMDouble   = True
+isFloat LMFloat80  = True
+isFloat LMFloat128 = True
+isFloat _          = False
+
+-- | Test if the given 'LlvmType' is an 'LMPointer' construct
+isPointer :: LlvmType -> Bool
+isPointer (LMPointer _) = True
+isPointer _             = False
+
+-- | Test if the given 'LlvmType' is an 'LMVector' construct
+isVector :: LlvmType -> Bool
+isVector (LMVector {}) = True
+isVector _             = False
+
+-- | Test if a 'LlvmVar' is global.
+isGlobal :: LlvmVar -> Bool
+isGlobal (LMGlobalVar _ _ _ _ _ _) = True
+isGlobal _                         = False
+
+-- | Width in bits of an 'LlvmType', returns 0 if not applicable
+llvmWidthInBits :: DynFlags -> LlvmType -> Int
+llvmWidthInBits _      (LMInt n)       = n
+llvmWidthInBits _      (LMFloat)       = 32
+llvmWidthInBits _      (LMDouble)      = 64
+llvmWidthInBits _      (LMFloat80)     = 80
+llvmWidthInBits _      (LMFloat128)    = 128
+-- Could return either a pointer width here or the width of what
+-- it points to. We will go with the former for now.
+-- PMW: At least judging by the way LLVM outputs constants, pointers
+--      should use the former, but arrays the latter.
+llvmWidthInBits dflags (LMPointer _)   = llvmWidthInBits dflags (llvmWord dflags)
+llvmWidthInBits dflags (LMArray n t)   = n * llvmWidthInBits dflags t
+llvmWidthInBits dflags (LMVector n ty) = n * llvmWidthInBits dflags ty
+llvmWidthInBits _      LMLabel         = 0
+llvmWidthInBits _      LMVoid          = 0
+llvmWidthInBits dflags (LMStruct tys)  = sum $ map (llvmWidthInBits dflags) tys
+llvmWidthInBits _      (LMStructU _)   =
+    -- It's not trivial to calculate the bit width of the unpacked structs,
+    -- since they will be aligned depending on the specified datalayout (
+    -- http://llvm.org/docs/LangRef.html#data-layout ). One way we could support
+    -- this could be to make the LlvmCodeGen.Ppr.moduleLayout be a data type
+    -- that exposes the alignment information. However, currently the only place
+    -- we use unpacked structs is LLVM intrinsics that return them (e.g.,
+    -- llvm.sadd.with.overflow.*), so we don't actually need to compute their
+    -- bit width.
+    panic "llvmWidthInBits: not implemented for LMStructU"
+llvmWidthInBits _      (LMFunction  _) = 0
+llvmWidthInBits dflags (LMAlias (_,t)) = llvmWidthInBits dflags t
+llvmWidthInBits _      LMMetadata      = panic "llvmWidthInBits: Meta-data has no runtime representation!"
+
+
+-- -----------------------------------------------------------------------------
+-- ** Shortcut for Common Types
+--
+
+i128, i64, i32, i16, i8, i1, i8Ptr :: LlvmType
+i128  = LMInt 128
+i64   = LMInt  64
+i32   = LMInt  32
+i16   = LMInt  16
+i8    = LMInt   8
+i1    = LMInt   1
+i8Ptr = pLift i8
+
+-- | The target architectures word size
+llvmWord, llvmWordPtr :: DynFlags -> LlvmType
+llvmWord    dflags = LMInt (wORD_SIZE dflags * 8)
+llvmWordPtr dflags = pLift (llvmWord dflags)
+
+-- -----------------------------------------------------------------------------
+-- * LLVM Function Types
+--
+
+-- | An LLVM Function
+data LlvmFunctionDecl = LlvmFunctionDecl {
+        -- | Unique identifier of the function
+        decName       :: LMString,
+        -- | LinkageType of the function
+        funcLinkage   :: LlvmLinkageType,
+        -- | The calling convention of the function
+        funcCc        :: LlvmCallConvention,
+        -- | Type of the returned value
+        decReturnType :: LlvmType,
+        -- | Indicates if this function uses varargs
+        decVarargs    :: LlvmParameterListType,
+        -- | Parameter types and attributes
+        decParams     :: [LlvmParameter],
+        -- | Function align value, must be power of 2
+        funcAlign     :: LMAlign
+  }
+  deriving (Eq)
+
+instance Outputable LlvmFunctionDecl where
+  ppr (LlvmFunctionDecl n l c r varg p a)
+    = let align = case a of
+                       Just a' -> text " align " <> ppr a'
+                       Nothing -> empty
+      in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <>
+             lparen <> ppParams varg p <> rparen <> align
+
+type LlvmFunctionDecls = [LlvmFunctionDecl]
+
+type LlvmParameter = (LlvmType, [LlvmParamAttr])
+
+-- | LLVM Parameter Attributes.
+--
+-- Parameter attributes are used to communicate additional information about
+-- the result or parameters of a function
+data LlvmParamAttr
+  -- | This indicates to the code generator that the parameter or return value
+  -- should be zero-extended to a 32-bit value by the caller (for a parameter)
+  -- or the callee (for a return value).
+  = ZeroExt
+  -- | This indicates to the code generator that the parameter or return value
+  -- should be sign-extended to a 32-bit value by the caller (for a parameter)
+  -- or the callee (for a return value).
+  | SignExt
+  -- | This indicates that this parameter or return value should be treated in
+  -- a special target-dependent fashion during while emitting code for a
+  -- function call or return (usually, by putting it in a register as opposed
+  -- to memory).
+  | InReg
+  -- | This indicates that the pointer parameter should really be passed by
+  -- value to the function.
+  | ByVal
+  -- | This indicates that the pointer parameter specifies the address of a
+  -- structure that is the return value of the function in the source program.
+  | SRet
+  -- | This indicates that the pointer does not alias any global or any other
+  -- parameter.
+  | NoAlias
+  -- | This indicates that the callee does not make any copies of the pointer
+  -- that outlive the callee itself
+  | NoCapture
+  -- | This indicates that the pointer parameter can be excised using the
+  -- trampoline intrinsics.
+  | Nest
+  deriving (Eq)
+
+instance Outputable LlvmParamAttr where
+  ppr ZeroExt   = text "zeroext"
+  ppr SignExt   = text "signext"
+  ppr InReg     = text "inreg"
+  ppr ByVal     = text "byval"
+  ppr SRet      = text "sret"
+  ppr NoAlias   = text "noalias"
+  ppr NoCapture = text "nocapture"
+  ppr Nest      = text "nest"
+
+-- | Llvm Function Attributes.
+--
+-- Function attributes are set to communicate additional information about a
+-- function. Function attributes are considered to be part of the function,
+-- not of the function type, so functions with different parameter attributes
+-- can have the same function type. Functions can have multiple attributes.
+--
+-- Descriptions taken from <http://llvm.org/docs/LangRef.html#fnattrs>
+data LlvmFuncAttr
+  -- | This attribute indicates that the inliner should attempt to inline this
+  -- function into callers whenever possible, ignoring any active inlining
+  -- size threshold for this caller.
+  = AlwaysInline
+  -- | This attribute indicates that the source code contained a hint that
+  -- inlining this function is desirable (such as the \"inline\" keyword in
+  -- C/C++). It is just a hint; it imposes no requirements on the inliner.
+  | InlineHint
+  -- | This attribute indicates that the inliner should never inline this
+  -- function in any situation. This attribute may not be used together
+  -- with the alwaysinline attribute.
+  | NoInline
+  -- | This attribute suggests that optimization passes and code generator
+  -- passes make choices that keep the code size of this function low, and
+  -- otherwise do optimizations specifically to reduce code size.
+  | OptSize
+  -- | This function attribute indicates that the function never returns
+  -- normally. This produces undefined behavior at runtime if the function
+  -- ever does dynamically return.
+  | NoReturn
+  -- | This function attribute indicates that the function never returns with
+  -- an unwind or exceptional control flow. If the function does unwind, its
+  -- runtime behavior is undefined.
+  | NoUnwind
+  -- | This attribute indicates that the function computes its result (or
+  -- decides to unwind an exception) based strictly on its arguments, without
+  -- dereferencing any pointer arguments or otherwise accessing any mutable
+  -- state (e.g. memory, control registers, etc) visible to caller functions.
+  -- It does not write through any pointer arguments (including byval
+  -- arguments) and never changes any state visible to callers. This means
+  -- that it cannot unwind exceptions by calling the C++ exception throwing
+  -- methods, but could use the unwind instruction.
+  | ReadNone
+  -- | This attribute indicates that the function does not write through any
+  -- pointer arguments (including byval arguments) or otherwise modify any
+  -- state (e.g. memory, control registers, etc) visible to caller functions.
+  -- It may dereference pointer arguments and read state that may be set in
+  -- the caller. A readonly function always returns the same value (or unwinds
+  -- an exception identically) when called with the same set of arguments and
+  -- global state. It cannot unwind an exception by calling the C++ exception
+  -- throwing methods, but may use the unwind instruction.
+  | ReadOnly
+  -- | This attribute indicates that the function should emit a stack smashing
+  -- protector. It is in the form of a \"canary\"—a random value placed on the
+  -- stack before the local variables that's checked upon return from the
+  -- function to see if it has been overwritten. A heuristic is used to
+  -- determine if a function needs stack protectors or not.
+  --
+  -- If a function that has an ssp attribute is inlined into a function that
+  -- doesn't have an ssp attribute, then the resulting function will have an
+  -- ssp attribute.
+  | Ssp
+  -- | This attribute indicates that the function should always emit a stack
+  -- smashing protector. This overrides the ssp function attribute.
+  --
+  -- If a function that has an sspreq attribute is inlined into a function
+  -- that doesn't have an sspreq attribute or which has an ssp attribute,
+  -- then the resulting function will have an sspreq attribute.
+  | SspReq
+  -- | This attribute indicates that the code generator should not use a red
+  -- zone, even if the target-specific ABI normally permits it.
+  | NoRedZone
+  -- | This attributes disables implicit floating point instructions.
+  | NoImplicitFloat
+  -- | This attribute disables prologue / epilogue emission for the function.
+  -- This can have very system-specific consequences.
+  | Naked
+  deriving (Eq)
+
+instance Outputable LlvmFuncAttr where
+  ppr AlwaysInline       = text "alwaysinline"
+  ppr InlineHint         = text "inlinehint"
+  ppr NoInline           = text "noinline"
+  ppr OptSize            = text "optsize"
+  ppr NoReturn           = text "noreturn"
+  ppr NoUnwind           = text "nounwind"
+  ppr ReadNone           = text "readnon"
+  ppr ReadOnly           = text "readonly"
+  ppr Ssp                = text "ssp"
+  ppr SspReq             = text "ssqreq"
+  ppr NoRedZone          = text "noredzone"
+  ppr NoImplicitFloat    = text "noimplicitfloat"
+  ppr Naked              = text "naked"
+
+
+-- | Different types to call a function.
+data LlvmCallType
+  -- | Normal call, allocate a new stack frame.
+  = StdCall
+  -- | Tail call, perform the call in the current stack frame.
+  | TailCall
+  deriving (Eq,Show)
+
+-- | Different calling conventions a function can use.
+data LlvmCallConvention
+  -- | The C calling convention.
+  -- This calling convention (the default if no other calling convention is
+  -- specified) matches the target C calling conventions. This calling
+  -- convention supports varargs function calls and tolerates some mismatch in
+  -- the declared prototype and implemented declaration of the function (as
+  -- does normal C).
+  = CC_Ccc
+  -- | This calling convention attempts to make calls as fast as possible
+  -- (e.g. by passing things in registers). This calling convention allows
+  -- the target to use whatever tricks it wants to produce fast code for the
+  -- target, without having to conform to an externally specified ABI
+  -- (Application Binary Interface). Implementations of this convention should
+  -- allow arbitrary tail call optimization to be supported. This calling
+  -- convention does not support varargs and requires the prototype of al
+  -- callees to exactly match the prototype of the function definition.
+  | CC_Fastcc
+  -- | This calling convention attempts to make code in the caller as efficient
+  -- as possible under the assumption that the call is not commonly executed.
+  -- As such, these calls often preserve all registers so that the call does
+  -- not break any live ranges in the caller side. This calling convention
+  -- does not support varargs and requires the prototype of all callees to
+  -- exactly match the prototype of the function definition.
+  | CC_Coldcc
+  -- | The GHC-specific 'registerised' calling convention.
+  | CC_Ghc
+  -- | Any calling convention may be specified by number, allowing
+  -- target-specific calling conventions to be used. Target specific calling
+  -- conventions start at 64.
+  | CC_Ncc Int
+  -- | X86 Specific 'StdCall' convention. LLVM includes a specific alias for it
+  -- rather than just using CC_Ncc.
+  | CC_X86_Stdcc
+  deriving (Eq)
+
+instance Outputable LlvmCallConvention where
+  ppr CC_Ccc       = text "ccc"
+  ppr CC_Fastcc    = text "fastcc"
+  ppr CC_Coldcc    = text "coldcc"
+  ppr CC_Ghc       = text "ghccc"
+  ppr (CC_Ncc i)   = text "cc " <> ppr i
+  ppr CC_X86_Stdcc = text "x86_stdcallcc"
+
+
+-- | Functions can have a fixed amount of parameters, or a variable amount.
+data LlvmParameterListType
+  -- Fixed amount of arguments.
+  = FixedArgs
+  -- Variable amount of arguments.
+  | VarArgs
+  deriving (Eq,Show)
+
+
+-- | Linkage type of a symbol.
+--
+-- The description of the constructors is copied from the Llvm Assembly Language
+-- Reference Manual <http://www.llvm.org/docs/LangRef.html#linkage>, because
+-- they correspond to the Llvm linkage types.
+data LlvmLinkageType
+  -- | Global values with internal linkage are only directly accessible by
+  -- objects in the current module. In particular, linking code into a module
+  -- with an internal global value may cause the internal to be renamed as
+  -- necessary to avoid collisions. Because the symbol is internal to the
+  -- module, all references can be updated. This corresponds to the notion
+  -- of the @static@ keyword in C.
+  = Internal
+  -- | Globals with @linkonce@ linkage are merged with other globals of the
+  -- same name when linkage occurs. This is typically used to implement
+  -- inline functions, templates, or other code which must be generated
+  -- in each translation unit that uses it. Unreferenced linkonce globals are
+  -- allowed to be discarded.
+  | LinkOnce
+  -- | @weak@ linkage is exactly the same as linkonce linkage, except that
+  -- unreferenced weak globals may not be discarded. This is used for globals
+  -- that may be emitted in multiple translation units, but that are not
+  -- guaranteed to be emitted into every translation unit that uses them. One
+  -- example of this are common globals in C, such as @int X;@ at global
+  -- scope.
+  | Weak
+  -- | @appending@ linkage may only be applied to global variables of pointer
+  -- to array type. When two global variables with appending linkage are
+  -- linked together, the two global arrays are appended together. This is
+  -- the Llvm, typesafe, equivalent of having the system linker append
+  -- together @sections@ with identical names when .o files are linked.
+  | Appending
+  -- | The semantics of this linkage follow the ELF model: the symbol is weak
+  -- until linked, if not linked, the symbol becomes null instead of being an
+  -- undefined reference.
+  | ExternWeak
+  -- | The symbol participates in linkage and can be used to resolve external
+  --  symbol references.
+  | ExternallyVisible
+  -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM
+  --  assembly.
+  | External
+  -- | Symbol is private to the module and should not appear in the symbol table
+  | Private
+  deriving (Eq)
+
+instance Outputable LlvmLinkageType where
+  ppr Internal          = text "internal"
+  ppr LinkOnce          = text "linkonce"
+  ppr Weak              = text "weak"
+  ppr Appending         = text "appending"
+  ppr ExternWeak        = text "extern_weak"
+  -- ExternallyVisible does not have a textual representation, it is
+  -- the linkage type a function resolves to if no other is specified
+  -- in Llvm.
+  ppr ExternallyVisible = empty
+  ppr External          = text "external"
+  ppr Private           = text "private"
+
+-- -----------------------------------------------------------------------------
+-- * LLVM Operations
+--
+
+-- | Llvm binary operators machine operations.
+data LlvmMachOp
+  = LM_MO_Add  -- ^ add two integer, floating point or vector values.
+  | LM_MO_Sub  -- ^ subtract two ...
+  | LM_MO_Mul  -- ^ multiply ..
+  | LM_MO_UDiv -- ^ unsigned integer or vector division.
+  | LM_MO_SDiv -- ^ signed integer ..
+  | LM_MO_URem -- ^ unsigned integer or vector remainder (mod)
+  | LM_MO_SRem -- ^ signed ...
+
+  | LM_MO_FAdd -- ^ add two floating point or vector values.
+  | LM_MO_FSub -- ^ subtract two ...
+  | LM_MO_FMul -- ^ multiply ...
+  | LM_MO_FDiv -- ^ divide ...
+  | LM_MO_FRem -- ^ remainder ...
+
+  -- | Left shift
+  | LM_MO_Shl
+  -- | Logical shift right
+  -- Shift right, filling with zero
+  | LM_MO_LShr
+  -- | Arithmetic shift right
+  -- The most significant bits of the result will be equal to the sign bit of
+  -- the left operand.
+  | LM_MO_AShr
+
+  | LM_MO_And -- ^ AND bitwise logical operation.
+  | LM_MO_Or  -- ^ OR bitwise logical operation.
+  | LM_MO_Xor -- ^ XOR bitwise logical operation.
+  deriving (Eq)
+
+instance Outputable LlvmMachOp where
+  ppr LM_MO_Add  = text "add"
+  ppr LM_MO_Sub  = text "sub"
+  ppr LM_MO_Mul  = text "mul"
+  ppr LM_MO_UDiv = text "udiv"
+  ppr LM_MO_SDiv = text "sdiv"
+  ppr LM_MO_URem = text "urem"
+  ppr LM_MO_SRem = text "srem"
+  ppr LM_MO_FAdd = text "fadd"
+  ppr LM_MO_FSub = text "fsub"
+  ppr LM_MO_FMul = text "fmul"
+  ppr LM_MO_FDiv = text "fdiv"
+  ppr LM_MO_FRem = text "frem"
+  ppr LM_MO_Shl  = text "shl"
+  ppr LM_MO_LShr = text "lshr"
+  ppr LM_MO_AShr = text "ashr"
+  ppr LM_MO_And  = text "and"
+  ppr LM_MO_Or   = text "or"
+  ppr LM_MO_Xor  = text "xor"
+
+
+-- | Llvm compare operations.
+data LlvmCmpOp
+  = LM_CMP_Eq  -- ^ Equal (Signed and Unsigned)
+  | LM_CMP_Ne  -- ^ Not equal (Signed and Unsigned)
+  | LM_CMP_Ugt -- ^ Unsigned greater than
+  | LM_CMP_Uge -- ^ Unsigned greater than or equal
+  | LM_CMP_Ult -- ^ Unsigned less than
+  | LM_CMP_Ule -- ^ Unsigned less than or equal
+  | LM_CMP_Sgt -- ^ Signed greater than
+  | LM_CMP_Sge -- ^ Signed greater than or equal
+  | LM_CMP_Slt -- ^ Signed less than
+  | LM_CMP_Sle -- ^ Signed less than or equal
+
+  -- Float comparisons. GHC uses a mix of ordered and unordered float
+  -- comparisons.
+  | LM_CMP_Feq -- ^ Float equal
+  | LM_CMP_Fne -- ^ Float not equal
+  | LM_CMP_Fgt -- ^ Float greater than
+  | LM_CMP_Fge -- ^ Float greater than or equal
+  | LM_CMP_Flt -- ^ Float less than
+  | LM_CMP_Fle -- ^ Float less than or equal
+  deriving (Eq)
+
+instance Outputable LlvmCmpOp where
+  ppr LM_CMP_Eq  = text "eq"
+  ppr LM_CMP_Ne  = text "ne"
+  ppr LM_CMP_Ugt = text "ugt"
+  ppr LM_CMP_Uge = text "uge"
+  ppr LM_CMP_Ult = text "ult"
+  ppr LM_CMP_Ule = text "ule"
+  ppr LM_CMP_Sgt = text "sgt"
+  ppr LM_CMP_Sge = text "sge"
+  ppr LM_CMP_Slt = text "slt"
+  ppr LM_CMP_Sle = text "sle"
+  ppr LM_CMP_Feq = text "oeq"
+  ppr LM_CMP_Fne = text "une"
+  ppr LM_CMP_Fgt = text "ogt"
+  ppr LM_CMP_Fge = text "oge"
+  ppr LM_CMP_Flt = text "olt"
+  ppr LM_CMP_Fle = text "ole"
+
+
+-- | Llvm cast operations.
+data LlvmCastOp
+  = LM_Trunc    -- ^ Integer truncate
+  | LM_Zext     -- ^ Integer extend (zero fill)
+  | LM_Sext     -- ^ Integer extend (sign fill)
+  | LM_Fptrunc  -- ^ Float truncate
+  | LM_Fpext    -- ^ Float extend
+  | LM_Fptoui   -- ^ Float to unsigned Integer
+  | LM_Fptosi   -- ^ Float to signed Integer
+  | LM_Uitofp   -- ^ Unsigned Integer to Float
+  | LM_Sitofp   -- ^ Signed Int to Float
+  | LM_Ptrtoint -- ^ Pointer to Integer
+  | LM_Inttoptr -- ^ Integer to Pointer
+  | LM_Bitcast  -- ^ Cast between types where no bit manipulation is needed
+  deriving (Eq)
+
+instance Outputable LlvmCastOp where
+  ppr LM_Trunc    = text "trunc"
+  ppr LM_Zext     = text "zext"
+  ppr LM_Sext     = text "sext"
+  ppr LM_Fptrunc  = text "fptrunc"
+  ppr LM_Fpext    = text "fpext"
+  ppr LM_Fptoui   = text "fptoui"
+  ppr LM_Fptosi   = text "fptosi"
+  ppr LM_Uitofp   = text "uitofp"
+  ppr LM_Sitofp   = text "sitofp"
+  ppr LM_Ptrtoint = text "ptrtoint"
+  ppr LM_Inttoptr = text "inttoptr"
+  ppr LM_Bitcast  = text "bitcast"
+
+
+-- -----------------------------------------------------------------------------
+-- * Floating point conversion
+--
+
+-- | Convert a Haskell Double to an LLVM hex encoded floating point form. In
+-- Llvm float literals can be printed in a big-endian hexadecimal format,
+-- regardless of underlying architecture.
+--
+-- See Note [LLVM Float Types].
+ppDouble :: Double -> SDoc
+ppDouble d
+  = let bs     = doubleToBytes d
+        hex d' = case showHex d' "" of
+                     []    -> error "dToStr: too few hex digits for float"
+                     [x]   -> ['0',x]
+                     [x,y] -> [x,y]
+                     _     -> error "dToStr: too many hex digits for float"
+
+        str  = map toUpper $ concat $ fixEndian $ map hex bs
+    in  text "0x" <> text str
+
+-- Note [LLVM Float Types]
+-- ~~~~~~~~~~~~~~~~~~~~~~~
+-- We use 'ppDouble' for both printing Float and Double floating point types. This is
+-- as LLVM expects all floating point constants (single & double) to be in IEEE
+-- 754 Double precision format. However, for single precision numbers (Float)
+-- they should be *representable* in IEEE 754 Single precision format. So the
+-- easiest way to do this is to narrow and widen again.
+-- (i.e., Double -> Float -> Double). We must be careful doing this that GHC
+-- doesn't optimize that away.
+
+-- Note [narrowFp & widenFp]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~
+-- NOTE: we use float2Double & co directly as GHC likes to optimize away
+-- successive calls of 'realToFrac', defeating the narrowing. (Bug #7600).
+-- 'realToFrac' has inconsistent behaviour with optimisation as well that can
+-- also cause issues, these methods don't.
+
+narrowFp :: Double -> Float
+{-# NOINLINE narrowFp #-}
+narrowFp = double2Float
+
+widenFp :: Float -> Double
+{-# NOINLINE widenFp #-}
+widenFp = float2Double
+
+ppFloat :: Float -> SDoc
+ppFloat = ppDouble . widenFp
+
+-- | Reverse or leave byte data alone to fix endianness on this target.
+fixEndian :: [a] -> [a]
+#if defined(WORDS_BIGENDIAN)
+fixEndian = id
+#else
+fixEndian = reverse
+#endif
+
+
+--------------------------------------------------------------------------------
+-- * Misc functions
+--------------------------------------------------------------------------------
+
+ppCommaJoin :: (Outputable a) => [a] -> SDoc
+ppCommaJoin strs = hsep $ punctuate comma (map ppr strs)
+
+ppSpaceJoin :: (Outputable a) => [a] -> SDoc
+ppSpaceJoin strs = hsep (map ppr strs)
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -0,0 +1,235 @@
+{-# LANGUAGE CPP, TypeFamilies, ViewPatterns #-}
+
+-- -----------------------------------------------------------------------------
+-- | This is the top-level module in the LLVM code generator.
+--
+module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Llvm
+import LlvmCodeGen.Base
+import LlvmCodeGen.CodeGen
+import LlvmCodeGen.Data
+import LlvmCodeGen.Ppr
+import LlvmCodeGen.Regs
+import LlvmMangler
+
+import BlockId
+import CgUtils ( fixStgRegisters )
+import Cmm
+import CmmUtils
+import Hoopl.Block
+import Hoopl.Collections
+import PprCmm
+
+import BufWrite
+import DynFlags
+import ErrUtils
+import FastString
+import Outputable
+import UniqSupply
+import SysTools ( figureLlvmVersion )
+import qualified Stream
+
+import Control.Monad ( when )
+import Data.Maybe ( fromMaybe, catMaybes )
+import System.IO
+
+-- -----------------------------------------------------------------------------
+-- | Top-level of the LLVM Code generator
+--
+llvmCodeGen :: DynFlags -> Handle -> UniqSupply
+               -> Stream.Stream IO RawCmmGroup ()
+               -> IO ()
+llvmCodeGen dflags h us cmm_stream
+  = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do
+       bufh <- newBufHandle h
+
+       -- Pass header
+       showPass dflags "LLVM CodeGen"
+
+       -- get llvm version, cache for later use
+       ver <- (fromMaybe supportedLlvmVersion) `fmap` figureLlvmVersion dflags
+
+       -- warn if unsupported
+       debugTraceMsg dflags 2
+            (text "Using LLVM version:" <+> text (show ver))
+       let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
+       when (ver /= supportedLlvmVersion && doWarn) $
+           putMsg dflags (text "You are using an unsupported version of LLVM!"
+                            $+$ text ("Currently only " ++
+                                      llvmVersionStr supportedLlvmVersion ++
+                                      " is supported.")
+                            $+$ text "We will try though...")
+
+       -- run code generation
+       runLlvm dflags ver bufh us $
+         llvmCodeGen' (liftStream cmm_stream)
+
+       bFlush bufh
+
+llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM ()
+llvmCodeGen' cmm_stream
+  = do  -- Preamble
+        renderLlvm header
+        ghcInternalFunctions
+        cmmMetaLlvmPrelude
+
+        -- Procedures
+        let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream
+        _ <- Stream.collect llvmStream
+
+        -- Declare aliases for forward references
+        renderLlvm . pprLlvmData =<< generateExternDecls
+
+        -- Postamble
+        cmmUsedLlvmGens
+  where
+    header :: SDoc
+    header = sdocWithDynFlags $ \dflags ->
+      let target = LLVM_TARGET
+          layout = case lookup target (llvmTargets dflags) of
+            Just (LlvmTarget dl _ _) -> dl
+            Nothing -> error $ "Failed to lookup the datalayout for " ++ target ++ "; available targets: " ++ show (map fst $ llvmTargets dflags)
+      in     text ("target datalayout = \"" ++ layout ++ "\"")
+         $+$ text ("target triple = \"" ++ target ++ "\"")
+
+llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
+llvmGroupLlvmGens cmm = do
+
+        -- Insert functions into map, collect data
+        let split (CmmData s d' )     = return $ Just (s, d')
+            split (CmmProc h l live g) = do
+              -- Set function type
+              let l' = case mapLookup (g_entry g) h of
+                         Nothing                   -> l
+                         Just (Statics info_lbl _) -> info_lbl
+              lml <- strCLabel_llvm l'
+              funInsert lml =<< llvmFunTy live
+              return Nothing
+        cdata <- fmap catMaybes $ mapM split cmm
+
+        {-# SCC "llvm_datas_gen" #-}
+          cmmDataLlvmGens cdata
+        {-# SCC "llvm_procs_gen" #-}
+          mapM_ cmmLlvmGen cmm
+
+-- -----------------------------------------------------------------------------
+-- | Do LLVM code generation on all these Cmms data sections.
+--
+cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM ()
+
+cmmDataLlvmGens statics
+  = do lmdatas <- mapM genLlvmData statics
+
+       let (concat -> gs, tss) = unzip lmdatas
+
+       let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)
+                        = funInsert l ty
+           regGlobal _  = pure ()
+       mapM_ regGlobal gs
+       gss' <- mapM aliasify $ gs
+
+       renderLlvm $ pprLlvmData (concat gss', concat tss)
+
+-- | LLVM can't handle entry blocks which loop back to themselves (could be
+-- seen as an LLVM bug) so we rearrange the code to keep the original entry
+-- label which branches to a newly generated second label that branches back
+-- to itself. See: Trac #11649
+fixBottom :: RawCmmDecl -> LlvmM RawCmmDecl
+fixBottom cp@(CmmProc hdr entry_lbl live g) =
+    maybe (pure cp) fix_block $ mapLookup (g_entry g) blk_map
+  where
+    blk_map = toBlockMap g
+
+    fix_block :: CmmBlock -> LlvmM RawCmmDecl
+    fix_block blk
+        | (CmmEntry e_lbl tickscp, middle, CmmBranch b_lbl) <- blockSplit blk
+        , isEmptyBlock middle
+        , e_lbl == b_lbl = do
+            new_lbl <- mkBlockId <$> getUniqueM
+
+            let fst_blk =
+                    BlockCC (CmmEntry e_lbl tickscp) BNil (CmmBranch new_lbl)
+                snd_blk =
+                    BlockCC (CmmEntry new_lbl tickscp) BNil (CmmBranch new_lbl)
+
+            pure . CmmProc hdr entry_lbl live . ofBlockMap (g_entry g)
+                $ mapFromList [(e_lbl, fst_blk), (new_lbl, snd_blk)]
+
+    fix_block _ = pure cp
+
+fixBottom rcd = pure rcd
+
+-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
+cmmLlvmGen ::RawCmmDecl -> LlvmM ()
+cmmLlvmGen cmm@CmmProc{} = do
+
+    -- rewrite assignments to global regs
+    dflags <- getDynFlag id
+    fixed_cmm <- fixBottom $
+                    {-# SCC "llvm_fix_regs" #-}
+                    fixStgRegisters dflags cmm
+
+    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])
+
+    -- generate llvm code from cmm
+    llvmBC <- withClearVars $ genLlvmProc fixed_cmm
+
+    -- pretty print
+    (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC
+
+    -- Output, note down used variables
+    renderLlvm (vcat docs)
+    mapM_ markUsedVar $ concat ivars
+
+cmmLlvmGen _ = return ()
+
+-- -----------------------------------------------------------------------------
+-- | Generate meta data nodes
+--
+
+cmmMetaLlvmPrelude :: LlvmM ()
+cmmMetaLlvmPrelude = do
+  metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do
+    -- Generate / lookup meta data IDs
+    tbaaId <- getMetaUniqueId
+    setUniqMeta uniq tbaaId
+    parentId <- maybe (return Nothing) getUniqMeta parent
+    -- Build definition
+    return $ MetaUnnamed tbaaId $ MetaStruct $
+          case parentId of
+              Just p  -> [ MetaStr name, MetaNode p ]
+              -- As of LLVM 4.0, a node without parents should be rendered as
+              -- just a name on its own. Previously `null` was accepted as the
+              -- name.
+              Nothing -> [ MetaStr name ]
+  renderLlvm $ ppLlvmMetas metas
+
+-- -----------------------------------------------------------------------------
+-- | Marks variables as used where necessary
+--
+
+cmmUsedLlvmGens :: LlvmM ()
+cmmUsedLlvmGens = do
+
+  -- LLVM would discard variables that are internal and not obviously
+  -- used if we didn't provide these hints. This will generate a
+  -- definition of the form
+  --
+  --   @llvm.used = appending global [42 x i8*] [i8* bitcast <var> to i8*, ...]
+  --
+  -- Which is the LLVM way of protecting them against getting removed.
+  ivars <- getUsedVars
+  let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
+      ty     = (LMArray (length ivars) i8Ptr)
+      usedArray = LMStaticArray (map cast ivars) ty
+      sectName  = Just $ fsLit "llvm.metadata"
+      lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant
+      lmUsed    = LMGlobal lmUsedVar (Just usedArray)
+  if null ivars
+     then return ()
+     else renderLlvm $ pprLlvmData ([lmUsed], [])
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -0,0 +1,551 @@
+{-# LANGUAGE CPP #-}
+
+-- ----------------------------------------------------------------------------
+-- | Base LLVM Code Generation module
+--
+-- Contains functions useful through out the code generator.
+--
+
+module LlvmCodeGen.Base (
+
+        LlvmCmmDecl, LlvmBasicBlock,
+        LiveGlobalRegs,
+        LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
+
+        LlvmVersion, supportedLlvmVersion, llvmVersionStr,
+
+        LlvmM,
+        runLlvm, liftStream, withClearVars, varLookup, varInsert,
+        markStackReg, checkStackReg,
+        funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
+        dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
+        ghcInternalFunctions,
+
+        getMetaUniqueId,
+        setUniqMeta, getUniqMeta,
+
+        cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
+        llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
+        llvmPtrBits, tysToParams, llvmFunSection,
+
+        strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
+        getGlobalPtr, generateExternDecls,
+
+        aliasify,
+    ) where
+
+#include "HsVersions.h"
+#include "ghcautoconf.h"
+
+import GhcPrelude
+
+import Llvm
+import LlvmCodeGen.Regs
+
+import CLabel
+import CodeGen.Platform ( activeStgRegs )
+import DynFlags
+import FastString
+import Cmm              hiding ( succ )
+import Outputable as Outp
+import Platform
+import UniqFM
+import Unique
+import BufWrite   ( BufHandle )
+import UniqSet
+import UniqSupply
+import ErrUtils
+import qualified Stream
+
+import Control.Monad (ap)
+
+-- ----------------------------------------------------------------------------
+-- * Some Data Types
+--
+
+type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement)
+type LlvmBasicBlock = GenBasicBlock LlvmStatement
+
+-- | Global registers live on proc entry
+type LiveGlobalRegs = [GlobalReg]
+
+-- | Unresolved code.
+-- Of the form: (data label, data type, unresolved data)
+type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
+
+-- | Top level LLVM Data (globals and type aliases)
+type LlvmData = ([LMGlobal], [LlvmType])
+
+-- | An unresolved Label.
+--
+-- Labels are unresolved when we haven't yet determined if they are defined in
+-- the module we are currently compiling, or an external one.
+type UnresLabel  = CmmLit
+type UnresStatic = Either UnresLabel LlvmStatic
+
+-- ----------------------------------------------------------------------------
+-- * Type translations
+--
+
+-- | Translate a basic CmmType to an LlvmType.
+cmmToLlvmType :: CmmType -> LlvmType
+cmmToLlvmType ty | isVecType ty   = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty))
+                 | isFloatType ty = widthToLlvmFloat $ typeWidth ty
+                 | otherwise      = widthToLlvmInt   $ typeWidth ty
+
+-- | Translate a Cmm Float Width to a LlvmType.
+widthToLlvmFloat :: Width -> LlvmType
+widthToLlvmFloat W32  = LMFloat
+widthToLlvmFloat W64  = LMDouble
+widthToLlvmFloat W80  = LMFloat80
+widthToLlvmFloat W128 = LMFloat128
+widthToLlvmFloat w    = panic $ "widthToLlvmFloat: Bad float size: " ++ show w
+
+-- | Translate a Cmm Bit Width to a LlvmType.
+widthToLlvmInt :: Width -> LlvmType
+widthToLlvmInt w = LMInt $ widthInBits w
+
+-- | GHC Call Convention for LLVM
+llvmGhcCC :: DynFlags -> LlvmCallConvention
+llvmGhcCC dflags
+ | platformUnregisterised (targetPlatform dflags) = CC_Ccc
+ | otherwise                                      = CC_Ghc
+
+-- | Llvm Function type for Cmm function
+llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
+llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible
+
+-- | Llvm Function signature
+llvmFunSig :: LiveGlobalRegs ->  CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
+llvmFunSig live lbl link = do
+  lbl' <- strCLabel_llvm lbl
+  llvmFunSig' live lbl' link
+
+llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
+llvmFunSig' live lbl link
+  = do let toParams x | isPointer x = (x, [NoAlias, NoCapture])
+                      | otherwise   = (x, [])
+       dflags <- getDynFlags
+       return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
+                                 (map (toParams . getVarType) (llvmFunArgs dflags live))
+                                 (llvmFunAlign dflags)
+
+-- | Alignment to use for functions
+llvmFunAlign :: DynFlags -> LMAlign
+llvmFunAlign dflags = Just (wORD_SIZE dflags)
+
+-- | Alignment to use for into tables
+llvmInfAlign :: DynFlags -> LMAlign
+llvmInfAlign dflags = Just (wORD_SIZE dflags)
+
+-- | Section to use for a function
+llvmFunSection :: DynFlags -> LMString -> LMSection
+llvmFunSection dflags lbl
+    | gopt Opt_SplitSections dflags = Just (concatFS [fsLit ".text.", lbl])
+    | otherwise                     = Nothing
+
+-- | A Function's arguments
+llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
+llvmFunArgs dflags live =
+    map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform))
+    where platform = targetPlatform dflags
+          isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live
+          isPassed r = not (isSSE r) || isLive r
+          isSSE (FloatReg _)  = True
+          isSSE (DoubleReg _) = True
+          isSSE (XmmReg _)    = True
+          isSSE (YmmReg _)    = True
+          isSSE (ZmmReg _)    = True
+          isSSE _             = False
+
+-- | Llvm standard fun attributes
+llvmStdFunAttrs :: [LlvmFuncAttr]
+llvmStdFunAttrs = [NoUnwind]
+
+-- | Convert a list of types to a list of function parameters
+-- (each with no parameter attributes)
+tysToParams :: [LlvmType] -> [LlvmParameter]
+tysToParams = map (\ty -> (ty, []))
+
+-- | Pointer width
+llvmPtrBits :: DynFlags -> Int
+llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags
+
+-- ----------------------------------------------------------------------------
+-- * Llvm Version
+--
+
+-- | LLVM Version Number
+type LlvmVersion = (Int, Int)
+
+-- | The LLVM Version that is currently supported.
+supportedLlvmVersion :: LlvmVersion
+supportedLlvmVersion = sUPPORTED_LLVM_VERSION
+
+llvmVersionStr :: LlvmVersion -> String
+llvmVersionStr (major, minor) = show major ++ "." ++ show minor
+
+-- ----------------------------------------------------------------------------
+-- * Environment Handling
+--
+
+data LlvmEnv = LlvmEnv
+  { envVersion :: LlvmVersion      -- ^ LLVM version
+  , envDynFlags :: DynFlags        -- ^ Dynamic flags
+  , envOutput :: BufHandle         -- ^ Output buffer
+  , envUniq :: UniqSupply          -- ^ Supply of unique values
+  , envFreshMeta :: MetaId         -- ^ Supply of fresh metadata IDs
+  , envUniqMeta :: UniqFM MetaId   -- ^ Global metadata nodes
+  , envFunMap :: LlvmEnvMap        -- ^ Global functions so far, with type
+  , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
+  , envUsedVars :: [LlvmVar]       -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)
+
+    -- the following get cleared for every function (see @withClearVars@)
+  , envVarMap :: LlvmEnvMap        -- ^ Local variables so far, with type
+  , envStackRegs :: [GlobalReg]    -- ^ Non-constant registers (alloca'd in the function prelude)
+  }
+
+type LlvmEnvMap = UniqFM LlvmType
+
+-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
+newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
+
+instance Functor LlvmM where
+    fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env
+                                  return (f x, env')
+
+instance Applicative LlvmM where
+    pure x = LlvmM $ \env -> return (x, env)
+    (<*>) = ap
+
+instance Monad LlvmM where
+    m >>= f  = LlvmM $ \env -> do (x, env') <- runLlvmM m env
+                                  runLlvmM (f x) env'
+
+instance HasDynFlags LlvmM where
+    getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)
+
+instance MonadUnique LlvmM where
+    getUniqueSupplyM = do
+        us <- getEnv envUniq
+        let (us1, us2) = splitUniqSupply us
+        modifyEnv (\s -> s { envUniq = us2 })
+        return us1
+
+    getUniqueM = do
+        us <- getEnv envUniq
+        let (u,us') = takeUniqFromSupply us
+        modifyEnv (\s -> s { envUniq = us' })
+        return u
+
+-- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
+liftIO :: IO a -> LlvmM a
+liftIO m = LlvmM $ \env -> do x <- m
+                              return (x, env)
+
+-- | Get initial Llvm environment.
+runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()
+runLlvm dflags ver out us m = do
+    _ <- runLlvmM m env
+    return ()
+  where env = LlvmEnv { envFunMap = emptyUFM
+                      , envVarMap = emptyUFM
+                      , envStackRegs = []
+                      , envUsedVars = []
+                      , envAliases = emptyUniqSet
+                      , envVersion = ver
+                      , envDynFlags = dflags
+                      , envOutput = out
+                      , envUniq = us
+                      , envFreshMeta = MetaId 0
+                      , envUniqMeta = emptyUFM
+                      }
+
+-- | Get environment (internal)
+getEnv :: (LlvmEnv -> a) -> LlvmM a
+getEnv f = LlvmM (\env -> return (f env, env))
+
+-- | Modify environment (internal)
+modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()
+modifyEnv f = LlvmM (\env -> return ((), f env))
+
+-- | Lift a stream into the LlvmM monad
+liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x
+liftStream s = Stream.Stream $ do
+  r <- liftIO $ Stream.runStream s
+  case r of
+    Left b        -> return (Left b)
+    Right (a, r2) -> return (Right (a, liftStream r2))
+
+-- | Clear variables from the environment for a subcomputation
+withClearVars :: LlvmM a -> LlvmM a
+withClearVars m = LlvmM $ \env -> do
+    (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] }
+    return (x, env' { envVarMap = emptyUFM, envStackRegs = [] })
+
+-- | Insert variables or functions into the environment.
+varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM ()
+varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t }
+funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t }
+
+-- | Lookup variables or functions in the environment.
+varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)
+varLookup s = getEnv (flip lookupUFM s . envVarMap)
+funLookup s = getEnv (flip lookupUFM s . envFunMap)
+
+-- | Set a register as allocated on the stack
+markStackReg :: GlobalReg -> LlvmM ()
+markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env }
+
+-- | Check whether a register is allocated on the stack
+checkStackReg :: GlobalReg -> LlvmM Bool
+checkStackReg r = getEnv ((elem r) . envStackRegs)
+
+-- | Allocate a new global unnamed metadata identifier
+getMetaUniqueId :: LlvmM MetaId
+getMetaUniqueId = LlvmM $ \env ->
+    return (envFreshMeta env, env { envFreshMeta = succ $ envFreshMeta env })
+
+-- | Get the LLVM version we are generating code for
+getLlvmVer :: LlvmM LlvmVersion
+getLlvmVer = getEnv envVersion
+
+-- | Get the platform we are generating code for
+getDynFlag :: (DynFlags -> a) -> LlvmM a
+getDynFlag f = getEnv (f . envDynFlags)
+
+-- | Get the platform we are generating code for
+getLlvmPlatform :: LlvmM Platform
+getLlvmPlatform = getDynFlag targetPlatform
+
+-- | Dumps the document if the corresponding flag has been set by the user
+dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM ()
+dumpIfSetLlvm flag hdr doc = do
+  dflags <- getDynFlags
+  liftIO $ dumpIfSet_dyn dflags flag hdr doc
+
+-- | Prints the given contents to the output handle
+renderLlvm :: Outp.SDoc -> LlvmM ()
+renderLlvm sdoc = do
+
+    -- Write to output
+    dflags <- getDynFlags
+    out <- getEnv envOutput
+    liftIO $ Outp.bufLeftRenderSDoc dflags out
+               (Outp.mkCodeStyle Outp.CStyle) sdoc
+
+    -- Dump, if requested
+    dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc
+    return ()
+
+-- | Marks a variable as "used"
+markUsedVar :: LlvmVar -> LlvmM ()
+markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env }
+
+-- | Return all variables marked as "used" so far
+getUsedVars :: LlvmM [LlvmVar]
+getUsedVars = getEnv envUsedVars
+
+-- | Saves that at some point we didn't know the type of the label and
+-- generated a reference to a type variable instead
+saveAlias :: LMString -> LlvmM ()
+saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl }
+
+-- | Sets metadata node for a given unique
+setUniqMeta :: Unique -> MetaId -> LlvmM ()
+setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m }
+
+-- | Gets metadata node for given unique
+getUniqMeta :: Unique -> LlvmM (Maybe MetaId)
+getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)
+
+-- ----------------------------------------------------------------------------
+-- * Internal functions
+--
+
+-- | Here we pre-initialise some functions that are used internally by GHC
+-- so as to make sure they have the most general type in the case that
+-- user code also uses these functions but with a different type than GHC
+-- internally. (Main offender is treating return type as 'void' instead of
+-- 'void *'). Fixes trac #5486.
+ghcInternalFunctions :: LlvmM ()
+ghcInternalFunctions = do
+    dflags <- getDynFlags
+    mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
+    mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
+    mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags]
+    mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]
+  where
+    mk n ret args = do
+      let n' = fsLit n `appendFS` fsLit "$def"
+          decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
+                                 FixedArgs (tysToParams args) Nothing
+      renderLlvm $ ppLlvmFunctionDecl decl
+      funInsert n' (LMFunction decl)
+
+-- ----------------------------------------------------------------------------
+-- * Label handling
+--
+
+-- | Pretty print a 'CLabel'.
+strCLabel_llvm :: CLabel -> LlvmM LMString
+strCLabel_llvm lbl = do
+    platform <- getLlvmPlatform
+    dflags <- getDynFlags
+    let sdoc = pprCLabel platform lbl
+        str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle)
+    return (fsLit str)
+
+strDisplayName_llvm :: CLabel -> LlvmM LMString
+strDisplayName_llvm lbl = do
+    platform <- getLlvmPlatform
+    dflags <- getDynFlags
+    let sdoc = pprCLabel platform lbl
+        depth = Outp.PartWay 1
+        style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth
+        str = Outp.renderWithStyle dflags sdoc style
+    return (fsLit (dropInfoSuffix str))
+
+dropInfoSuffix :: String -> String
+dropInfoSuffix = go
+  where go "_info"        = []
+        go "_static_info" = []
+        go "_con_info"    = []
+        go (x:xs)         = x:go xs
+        go []             = []
+
+strProcedureName_llvm :: CLabel -> LlvmM LMString
+strProcedureName_llvm lbl = do
+    platform <- getLlvmPlatform
+    dflags <- getDynFlags
+    let sdoc = pprCLabel platform lbl
+        depth = Outp.PartWay 1
+        style = Outp.mkUserStyle dflags Outp.neverQualify depth
+        str = Outp.renderWithStyle dflags sdoc style
+    return (fsLit str)
+
+-- ----------------------------------------------------------------------------
+-- * Global variables / forward references
+--
+
+-- | Create/get a pointer to a global value. Might return an alias if
+-- the value in question hasn't been defined yet. We especially make
+-- no guarantees on the type of the returned pointer.
+getGlobalPtr :: LMString -> LlvmM LlvmVar
+getGlobalPtr llvmLbl = do
+  m_ty <- funLookup llvmLbl
+  let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing
+  case m_ty of
+    -- Directly reference if we have seen it already
+    Just ty -> return $ mkGlbVar (llvmLbl `appendFS` fsLit "$def") ty Global
+    -- Otherwise use a forward alias of it
+    Nothing -> do
+      saveAlias llvmLbl
+      return $ mkGlbVar llvmLbl i8 Alias
+
+-- | Generate definitions for aliases forward-referenced by @getGlobalPtr@.
+--
+-- Must be called at a point where we are sure that no new global definitions
+-- will be generated anymore!
+generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
+generateExternDecls = do
+  delayed <- fmap nonDetEltsUniqSet $ getEnv envAliases
+  -- This is non-deterministic but we do not
+  -- currently support deterministic code-generation.
+  -- See Note [Unique Determinism and code generation]
+  defss <- flip mapM delayed $ \lbl -> do
+    m_ty <- funLookup lbl
+    case m_ty of
+      -- If we have a definition we've already emitted the proper aliases
+      -- when the symbol itself was emitted by @aliasify@
+      Just _ -> return []
+
+      -- If we don't have a definition this is an external symbol and we
+      -- need to emit a declaration
+      Nothing ->
+        let var = LMGlobalVar lbl i8Ptr External Nothing Nothing Global
+        in return [LMGlobal var Nothing]
+
+  -- Reset forward list
+  modifyEnv $ \env -> env { envAliases = emptyUniqSet }
+  return (concat defss, [])
+
+-- | Here we take a global variable definition, rename it with a
+-- @$def@ suffix, and generate the appropriate alias.
+aliasify :: LMGlobal -> LlvmM [LMGlobal]
+aliasify (LMGlobal var val) = do
+    let LMGlobalVar lbl ty link sect align const = var
+
+        defLbl = lbl `appendFS` fsLit "$def"
+        defVar = LMGlobalVar defLbl ty Internal sect align const
+
+        defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const
+        aliasVar = LMGlobalVar lbl i8Ptr link Nothing Nothing Alias
+        aliasVal = LMBitc (LMStaticPointer defPtrVar) i8Ptr
+
+    -- we need to mark the $def symbols as used so LLVM doesn't forget which
+    -- section they need to go in. This will vanish once we switch away from
+    -- mangling sections for TNTC.
+    markUsedVar defVar
+
+    return [ LMGlobal defVar val
+           , LMGlobal aliasVar (Just aliasVal)
+           ]
+
+-- Note [Llvm Forward References]
+--
+-- The issue here is that LLVM insists on being strongly typed at
+-- every corner, so the first time we mention something, we have to
+-- settle what type we assign to it. That makes things awkward, as Cmm
+-- will often reference things before their definition, and we have no
+-- idea what (LLVM) type it is going to be before that point.
+--
+-- Our work-around is to define "aliases" of a standard type (i8 *) in
+-- these kind of situations, which we later tell LLVM to be either
+-- references to their actual local definitions (involving a cast) or
+-- an external reference. This obviously only works for pointers.
+--
+-- In particular when we encounter a reference to a symbol in a chunk of
+-- C-- there are three possible scenarios,
+--
+--   1. We have already seen a definition for the referenced symbol. This
+--      means we already know its type.
+--
+--   2. We have not yet seen a definition but we will find one later in this
+--      compilation unit. Since we want to be a good consumer of the
+--      C-- streamed to us from upstream, we don't know the type of the
+--      symbol at the time when we must emit the reference.
+--
+--   3. We have not yet seen a definition nor will we find one in this
+--      compilation unit. In this case the reference refers to an
+--      external symbol for which we do not know the type.
+--
+-- Let's consider case (2) for a moment: say we see a reference to
+-- the symbol @fooBar@ for which we have not seen a definition. As we
+-- do not know the symbol's type, we assume it is of type @i8*@ and emit
+-- the appropriate casts in @getSymbolPtr@. Later on, when we
+-- encounter the definition of @fooBar@ we emit it but with a modified
+-- name, @fooBar$def@ (which we'll call the definition symbol), to
+-- since we have already had to assume that the symbol @fooBar@
+-- is of type @i8*@. We then emit @fooBar@ itself as an alias
+-- of @fooBar$def@ with appropriate casts. This all happens in
+-- @aliasify@.
+--
+-- Case (3) is quite similar to (2): References are emitted assuming
+-- the referenced symbol is of type @i8*@. When we arrive at the end of
+-- the compilation unit and realize that the symbol is external, we emit
+-- an LLVM @external global@ declaration for the symbol @fooBar@
+-- (handled in @generateExternDecls@). This takes advantage of the
+-- fact that the aliases produced by @aliasify@ for exported symbols
+-- have external linkage and can therefore be used as normal symbols.
+--
+-- Historical note: As of release 3.5 LLVM does not allow aliases to
+-- refer to declarations. This the reason why aliases are produced at the
+-- point of definition instead of the point of usage, as was previously
+-- done. See #9142 for details.
+--
+-- Finally, case (1) is trival. As we already have a definition for
+-- and therefore know the type of the referenced symbol, we can do
+-- away with casting the alias to the desired type in @getSymbolPtr@
+-- and instead just emit a reference to the definition symbol directly.
+-- This is the @Just@ case in @getSymbolPtr@.
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -0,0 +1,2008 @@
+{-# LANGUAGE CPP, GADTs #-}
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+-- ----------------------------------------------------------------------------
+-- | Handle conversion of CmmProc to LLVM code.
+--
+module LlvmCodeGen.CodeGen ( genLlvmProc ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Llvm
+import LlvmCodeGen.Base
+import LlvmCodeGen.Regs
+
+import BlockId
+import CodeGen.Platform ( activeStgRegs, callerSaves )
+import CLabel
+import Cmm
+import PprCmm
+import CmmUtils
+import CmmSwitch
+import Hoopl.Block
+import Hoopl.Graph
+import Hoopl.Collections
+
+import DynFlags
+import FastString
+import ForeignCall
+import Outputable hiding (panic, pprPanic)
+import qualified Outputable
+import Platform
+import OrdList
+import UniqSupply
+import Unique
+import Util
+
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Writer
+
+import qualified Data.Semigroup as Semigroup
+import Data.List ( nub )
+import Data.Maybe ( catMaybes )
+
+type Atomic = Bool
+type LlvmStatements = OrdList LlvmStatement
+
+data Signage = Signed | Unsigned deriving (Eq, Show)
+
+-- -----------------------------------------------------------------------------
+-- | Top-level of the LLVM proc Code generator
+--
+genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]
+genLlvmProc (CmmProc infos lbl live graph) = do
+    let blocks = toBlockListEntryFirstFalseFallthrough graph
+    (lmblocks, lmdata) <- basicBlocksCodeGen live blocks
+    let info = mapLookup (g_entry graph) infos
+        proc = CmmProc info lbl live (ListGraph lmblocks)
+    return (proc:lmdata)
+
+genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!"
+
+-- -----------------------------------------------------------------------------
+-- * Block code generation
+--
+
+-- | Generate code for a list of blocks that make up a complete
+-- procedure. The first block in the list is expected to be the entry
+-- point and will get the prologue.
+basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock]
+                      -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
+basicBlocksCodeGen _    []                     = panic "no entry block!"
+basicBlocksCodeGen live (entryBlock:cmmBlocks)
+  = do (prologue, prologueTops) <- funPrologue live (entryBlock:cmmBlocks)
+
+       -- Generate code
+       (BasicBlock bid entry, entryTops) <- basicBlockCodeGen entryBlock
+       (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks
+
+       -- Compose
+       let entryBlock = BasicBlock bid (fromOL prologue ++ entry)
+       return (entryBlock : blocks, prologueTops ++ entryTops ++ concat topss)
+
+
+-- | Generate code for one block
+basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )
+basicBlockCodeGen block
+  = do let (_, nodes, tail)  = blockSplit block
+           id = entryLabel block
+       (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes
+       (tail_instrs, top')  <- stmtToInstrs tail
+       let instrs = fromOL (mid_instrs `appOL` tail_instrs)
+       return (BasicBlock id instrs, top' ++ top)
+
+-- -----------------------------------------------------------------------------
+-- * CmmNode code generation
+--
+
+-- A statement conversion return data.
+--   * LlvmStatements: The compiled LLVM statements.
+--   * LlvmCmmDecl: Any global data needed.
+type StmtData = (LlvmStatements, [LlvmCmmDecl])
+
+
+-- | Convert a list of CmmNode's to LlvmStatement's
+stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData
+stmtsToInstrs stmts
+   = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts
+        return (concatOL instrss, concat topss)
+
+
+-- | Convert a CmmStmt to a list of LlvmStatement's
+stmtToInstrs :: CmmNode e x -> LlvmM StmtData
+stmtToInstrs stmt = case stmt of
+
+    CmmComment _         -> return (nilOL, []) -- nuke comments
+    CmmTick    _         -> return (nilOL, [])
+    CmmUnwind  {}        -> return (nilOL, [])
+
+    CmmAssign reg src    -> genAssign reg src
+    CmmStore addr src    -> genStore addr src
+
+    CmmBranch id         -> genBranch id
+    CmmCondBranch arg true false likely
+                         -> genCondBranch arg true false likely
+    CmmSwitch arg ids    -> genSwitch arg ids
+
+    -- Foreign Call
+    CmmUnsafeForeignCall target res args
+        -> genCall target res args
+
+    -- Tail call
+    CmmCall { cml_target = arg,
+              cml_args_regs = live } -> genJump arg live
+
+    _ -> panic "Llvm.CodeGen.stmtToInstrs"
+
+-- | Wrapper function to declare an instrinct function by function type
+getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData
+getInstrinct2 fname fty@(LMFunction funSig) = do
+
+    let fv   = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant
+
+    fn <- funLookup fname
+    tops <- case fn of
+      Just _  ->
+        return []
+      Nothing -> do
+        funInsert fname fty
+        un <- getUniqueM
+        let lbl = mkAsmTempLabel un
+        return [CmmData (Section Data lbl) [([],[fty])]]
+
+    return (fv, nilOL, tops)
+
+getInstrinct2 _ _ = error "getInstrinct2: Non-function type!"
+
+-- | Declares an instrinct function by return and parameter types
+getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData
+getInstrinct fname retTy parTys =
+    let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy
+                    FixedArgs (tysToParams parTys) Nothing
+        fty = LMFunction funSig
+    in getInstrinct2 fname fty
+
+-- | Memory barrier instruction for LLVM >= 3.0
+barrier :: LlvmM StmtData
+barrier = do
+    let s = Fence False SyncSeqCst
+    return (unitOL s, [])
+
+-- | Foreign Calls
+genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]
+              -> LlvmM StmtData
+
+-- Write barrier needs to be handled specially as it is implemented as an LLVM
+-- intrinsic function.
+genCall (PrimTarget MO_WriteBarrier) _ _ = do
+    platform <- getLlvmPlatform
+    if platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC]
+       then return (nilOL, [])
+       else barrier
+
+genCall (PrimTarget MO_Touch) _ _
+ = return (nilOL, [])
+
+genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do
+    dstV <- getCmmRegW (CmmLocal dst)
+    let ty = cmmToLlvmType $ localRegType dst
+        width = widthToLlvmFloat w
+    castV <- lift $ mkLocalVar ty
+    ve <- exprToVarW e
+    statement $ Assignment castV $ Cast LM_Uitofp ve width
+    statement $ Store castV dstV
+
+genCall (PrimTarget (MO_UF_Conv _)) [_] args =
+    panic $ "genCall: Too many arguments to MO_UF_Conv. " ++
+    "Can only handle 1, given" ++ show (length args) ++ "."
+
+-- Handle prefetching data
+genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args
+  | 0 <= localityInt && localityInt <= 3 = runStmtsDecls $ do
+    let argTy = [i8Ptr, i32, i32, i32]
+        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
+                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
+
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints' = zip args arg_hints
+    argVars <- arg_varsW args_hints' ([], nilOL, [])
+    fptr    <- liftExprData $ getFunPtr funTy t
+    argVars' <- castVarsW Signed $ zip argVars argTy
+
+    doTrashStmts
+    let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1]
+    statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) []
+  | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt)
+
+-- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg
+-- and return types
+genCall t@(PrimTarget (MO_PopCnt w)) dsts args =
+    genCallSimpleCast w t dsts args
+
+genCall t@(PrimTarget (MO_Pdep w)) dsts args =
+    genCallSimpleCast2 w t dsts args
+genCall t@(PrimTarget (MO_Pext w)) dsts args =
+    genCallSimpleCast2 w t dsts args
+genCall t@(PrimTarget (MO_Clz w)) dsts args =
+    genCallSimpleCast w t dsts args
+genCall t@(PrimTarget (MO_Ctz w)) dsts args =
+    genCallSimpleCast w t dsts args
+genCall t@(PrimTarget (MO_BSwap w)) dsts args =
+    genCallSimpleCast w t dsts args
+
+genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do
+    addrVar <- exprToVarW addr
+    nVar <- exprToVarW n
+    let targetTy = widthToLlvmInt width
+        ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)
+    ptrVar <- doExprW (pLift targetTy) ptrExpr
+    dstVar <- getCmmRegW (CmmLocal dst)
+    let op = case amop of
+               AMO_Add  -> LAO_Add
+               AMO_Sub  -> LAO_Sub
+               AMO_And  -> LAO_And
+               AMO_Nand -> LAO_Nand
+               AMO_Or   -> LAO_Or
+               AMO_Xor  -> LAO_Xor
+    retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst
+    statement $ Store retVar dstVar
+
+genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do
+    dstV <- getCmmRegW (CmmLocal dst)
+    v1 <- genLoadW True addr (localRegType dst)
+    statement $ Store v1 dstV
+
+genCall (PrimTarget (MO_Cmpxchg _width))
+        [dst] [addr, old, new] = runStmtsDecls $ do
+    addrVar <- exprToVarW addr
+    oldVar <- exprToVarW old
+    newVar <- exprToVarW new
+    let targetTy = getVarType oldVar
+        ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)
+    ptrVar <- doExprW (pLift targetTy) ptrExpr
+    dstVar <- getCmmRegW (CmmLocal dst)
+    retVar <- doExprW (LMStructU [targetTy,i1])
+              $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst
+    retVar' <- doExprW targetTy $ ExtractV retVar 0
+    statement $ Store retVar' dstVar
+
+genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do
+    addrVar <- exprToVarW addr
+    valVar <- exprToVarW val
+    let ptrTy = pLift $ getVarType valVar
+        ptrExpr = Cast LM_Inttoptr addrVar ptrTy
+    ptrVar <- doExprW ptrTy ptrExpr
+    statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst
+
+-- Handle memcpy function specifically since llvm's intrinsic version takes
+-- some extra parameters.
+genCall t@(PrimTarget op) [] args
+ | Just align <- machOpMemcpyishAlign op = runStmtsDecls $ do
+    dflags <- getDynFlags
+    let isVolTy = [i1]
+        isVolVal = [mkIntLit i1 0]
+        argTy | MO_Memset _ <- op = [i8Ptr, i8,    llvmWord dflags, i32] ++ isVolTy
+              | otherwise         = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy
+        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
+                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
+
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints = zip args arg_hints
+    argVars       <- arg_varsW args_hints ([], nilOL, [])
+    fptr          <- getFunPtrW funTy t
+    argVars' <- castVarsW Signed $ zip argVars argTy
+
+    doTrashStmts
+    let alignVal = mkIntLit i32 align
+        arguments = argVars' ++ (alignVal:isVolVal)
+    statement $ Expr $ Call StdCall fptr arguments []
+
+-- We handle MO_U_Mul2 by simply using a 'mul' instruction, but with operands
+-- twice the width (we first zero-extend them), e.g., on 64-bit arch we will
+-- generate 'mul' on 128-bit operands. Then we only need some plumbing to
+-- extract the two 64-bit values out of 128-bit result.
+genCall (PrimTarget (MO_U_Mul2 w)) [dstH, dstL] [lhs, rhs] = runStmtsDecls $ do
+    let width = widthToLlvmInt w
+        bitWidth = widthInBits w
+        width2x = LMInt (bitWidth * 2)
+    -- First zero-extend the operands ('mul' instruction requires the operands
+    -- and the result to be of the same type). Note that we don't use 'castVars'
+    -- because it tries to do LM_Sext.
+    lhsVar <- exprToVarW lhs
+    rhsVar <- exprToVarW rhs
+    lhsExt <- doExprW width2x $ Cast LM_Zext lhsVar width2x
+    rhsExt <- doExprW width2x $ Cast LM_Zext rhsVar width2x
+    -- Do the actual multiplication (note that the result is also 2x width).
+    retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt
+    -- Extract the lower bits of the result into retL.
+    retL <- doExprW width $ Cast LM_Trunc retV width
+    -- Now we right-shift the higher bits by width.
+    let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width
+    retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit
+    -- And extract them into retH.
+    retH <- doExprW width $ Cast LM_Trunc retShifted width
+    dstRegL <- getCmmRegW (CmmLocal dstL)
+    dstRegH <- getCmmRegW (CmmLocal dstH)
+    statement $ Store retL dstRegL
+    statement $ Store retH dstRegH
+
+-- MO_U_QuotRem2 is another case we handle by widening the registers to double
+-- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The
+-- main difference here is that we need to combine two words into one register
+-- and then use both 'udiv' and 'urem' instructions to compute the result.
+genCall (PrimTarget (MO_U_QuotRem2 w))
+        [dstQ, dstR] [lhsH, lhsL, rhs] = runStmtsDecls $ do
+    let width = widthToLlvmInt w
+        bitWidth = widthInBits w
+        width2x = LMInt (bitWidth * 2)
+    -- First zero-extend all parameters to double width.
+    let zeroExtend expr = do
+            var <- exprToVarW expr
+            doExprW width2x $ Cast LM_Zext var width2x
+    lhsExtH <- zeroExtend lhsH
+    lhsExtL <- zeroExtend lhsL
+    rhsExt <- zeroExtend rhs
+    -- Now we combine the first two parameters (that represent the high and low
+    -- bits of the value). So first left-shift the high bits to their position
+    -- and then bit-or them with the low bits.
+    let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width
+    lhsExtHShifted <- doExprW width2x $ LlvmOp LM_MO_Shl lhsExtH widthLlvmLit
+    lhsExt <- doExprW width2x $ LlvmOp LM_MO_Or lhsExtHShifted lhsExtL
+    -- Finally, we can call 'udiv' and 'urem' to compute the results.
+    retExtDiv <- doExprW width2x $ LlvmOp LM_MO_UDiv lhsExt rhsExt
+    retExtRem <- doExprW width2x $ LlvmOp LM_MO_URem lhsExt rhsExt
+    -- And since everything is in 2x width, we need to truncate the results and
+    -- then return them.
+    let narrow var = doExprW width $ Cast LM_Trunc var width
+    retDiv <- narrow retExtDiv
+    retRem <- narrow retExtRem
+    dstRegQ <- lift $ getCmmReg (CmmLocal dstQ)
+    dstRegR <- lift $ getCmmReg (CmmLocal dstR)
+    statement $ Store retDiv dstRegQ
+    statement $ Store retRem dstRegR
+
+-- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from
+-- which we need to extract the actual values.
+genCall t@(PrimTarget (MO_AddIntC w)) [dstV, dstO] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+genCall t@(PrimTarget (MO_SubIntC w)) [dstV, dstO] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+
+-- Similar to MO_{Add,Sub}IntC, but MO_Add2 expects the first element of the
+-- return tuple to be the overflow bit and the second element to contain the
+-- actual result of the addition. So we still use genCallWithOverflow but swap
+-- the return registers.
+genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+
+genCall t@(PrimTarget (MO_AddWordC w)) [dstV, dstO] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+
+genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] =
+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]
+
+-- Handle all other foreign calls and prim ops.
+genCall target res args = runStmtsDecls $ do
+    dflags <- getDynFlags
+
+    -- parameter types
+    let arg_type (_, AddrHint) = i8Ptr
+        -- cast pointers to i8*. Llvm equivalent of void*
+        arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr
+
+    -- ret type
+    let ret_type [] = LMVoid
+        ret_type [(_, AddrHint)] = i8Ptr
+        ret_type [(reg, _)]      = cmmToLlvmType $ localRegType reg
+        ret_type t = panic $ "genCall: Too many return values! Can only handle"
+                        ++ " 0 or 1, given " ++ show (length t) ++ "."
+
+    -- extract Cmm call convention, and translate to LLVM call convention
+    platform <- lift $ getLlvmPlatform
+    let lmconv = case target of
+            ForeignTarget _ (ForeignConvention conv _ _ _) ->
+              case conv of
+                 StdCallConv  -> case platformArch platform of
+                                 ArchX86    -> CC_X86_Stdcc
+                                 ArchX86_64 -> CC_X86_Stdcc
+                                 _          -> CC_Ccc
+                 CCallConv    -> CC_Ccc
+                 CApiConv     -> CC_Ccc
+                 PrimCallConv -> panic "LlvmCodeGen.CodeGen.genCall: PrimCallConv"
+                 JavaScriptCallConv -> panic "LlvmCodeGen.CodeGen.genCall: JavaScriptCallConv"
+
+            PrimTarget   _ -> CC_Ccc
+
+    {-
+        CC_Ccc of the possibilities here are a worry with the use of a custom
+        calling convention for passing STG args. In practice the more
+        dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
+
+        The native code generator only handles StdCall and CCallConv.
+    -}
+
+    -- call attributes
+    let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs
+                | otherwise     = llvmStdFunAttrs
+
+        never_returns = case target of
+             ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True
+             _ -> False
+
+    -- fun type
+    let (res_hints, arg_hints) = foreignTargetHints target
+    let args_hints = zip args arg_hints
+    let ress_hints = zip res  res_hints
+    let ccTy  = StdCall -- tail calls should be done through CmmJump
+    let retTy = ret_type ress_hints
+    let argTy = tysToParams $ map arg_type args_hints
+    let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
+                             lmconv retTy FixedArgs argTy (llvmFunAlign dflags)
+
+
+    argVars <- arg_varsW args_hints ([], nilOL, [])
+    fptr    <- getFunPtrW funTy target
+
+    let doReturn | ccTy == TailCall  = statement $ Return Nothing
+                 | never_returns     = statement $ Unreachable
+                 | otherwise         = return ()
+
+    doTrashStmts
+
+    -- make the actual call
+    case retTy of
+        LMVoid -> do
+            statement $ Expr $ Call ccTy fptr argVars fnAttrs
+
+        _ -> do
+            v1 <- doExprW retTy $ Call ccTy fptr argVars fnAttrs
+            -- get the return register
+            let ret_reg [reg] = reg
+                ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
+                                ++ " 1, given " ++ show (length t) ++ "."
+            let creg = ret_reg res
+            vreg <- getCmmRegW (CmmLocal creg)
+            if retTy == pLower (getVarType vreg)
+                then do
+                    statement $ Store v1 vreg
+                    doReturn
+                else do
+                    let ty = pLower $ getVarType vreg
+                    let op = case ty of
+                            vt | isPointer vt -> LM_Bitcast
+                               | isInt     vt -> LM_Ptrtoint
+                               | otherwise    ->
+                                   panic $ "genCall: CmmReg bad match for"
+                                        ++ " returned type!"
+
+                    v2 <- doExprW ty $ Cast op v1 ty
+                    statement $ Store v2 vreg
+                    doReturn
+
+-- | Generate a call to an LLVM intrinsic that performs arithmetic operation
+-- with overflow bit (i.e., returns a struct containing the actual result of the
+-- operation and an overflow bit). This function will also extract the overflow
+-- bit and zero-extend it (all the corresponding Cmm PrimOps represent the
+-- overflow "bit" as a usual Int# or Word#).
+genCallWithOverflow
+  :: ForeignTarget -> Width -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData
+genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do
+    -- So far this was only tested for the following four CallishMachOps.
+    let valid = op `elem`   [ MO_Add2 w
+                            , MO_AddIntC w
+                            , MO_SubIntC w
+                            , MO_AddWordC w
+                            , MO_SubWordC w
+                            ]
+    MASSERT(valid)
+    let width = widthToLlvmInt w
+    -- This will do most of the work of generating the call to the intrinsic and
+    -- extracting the values from the struct.
+    (value, overflowBit, (stmts, top)) <-
+      genCallExtract t w (lhs, rhs) (width, i1)
+    -- value is i<width>, but overflowBit is i1, so we need to cast (Cmm expects
+    -- both to be i<width>)
+    (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width
+    dstRegV <- getCmmReg (CmmLocal dstV)
+    dstRegO <- getCmmReg (CmmLocal dstO)
+    let storeV = Store value dstRegV
+        storeO = Store overflow dstRegO
+    return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top)
+genCallWithOverflow _ _ _ _ =
+    panic "genCallExtract: wrong ForeignTarget or number of arguments"
+
+-- | A helper function for genCallWithOverflow that handles generating the call
+-- to the LLVM intrinsic and extracting the result from the struct to LlvmVars.
+genCallExtract
+    :: ForeignTarget           -- ^ PrimOp
+    -> Width                   -- ^ Width of the operands.
+    -> (CmmActual, CmmActual)  -- ^ Actual arguments.
+    -> (LlvmType, LlvmType)    -- ^ LLVM types of the returned struct.
+    -> LlvmM (LlvmVar, LlvmVar, StmtData)
+genCallExtract target@(PrimTarget op) w (argA, argB) (llvmTypeA, llvmTypeB) = do
+    let width = widthToLlvmInt w
+        argTy = [width, width]
+        retTy = LMStructU [llvmTypeA, llvmTypeB]
+
+    -- Process the arguments.
+    let args_hints = zip [argA, argB] (snd $ foreignTargetHints target)
+    (argsV1, args1, top1) <- arg_vars args_hints ([], nilOL, [])
+    (argsV2, args2) <- castVars Signed $ zip argsV1 argTy
+
+    -- Get the function and make the call.
+    fname <- cmmPrimOpFunctions op
+    (fptr, _, top2) <- getInstrinct fname retTy argTy
+    -- We use StdCall for primops. See also the last case of genCall.
+    (retV, call) <- doExpr retTy $ Call StdCall fptr argsV2 []
+
+    -- This will result in a two element struct, we need to use "extractvalue"
+    -- to get them out of it.
+    (res1, ext1) <- doExpr llvmTypeA (ExtractV retV 0)
+    (res2, ext2) <- doExpr llvmTypeB (ExtractV retV 1)
+
+    let stmts = args1 `appOL` args2 `snocOL` call `snocOL` ext1 `snocOL` ext2
+        tops = top1 ++ top2
+    return (res1, res2, (stmts, tops))
+
+genCallExtract _ _ _ _ =
+    panic "genCallExtract: unsupported ForeignTarget"
+
+-- Handle simple function call that only need simple type casting, of the form:
+--   truncate arg >>= \a -> call(a) >>= zext
+--
+-- since GHC only really has i32 and i64 types and things like Word8 are backed
+-- by an i32 and just present a logical i8 range. So we must handle conversions
+-- from i32 to i8 explicitly as LLVM is strict about types.
+genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
+              -> LlvmM StmtData
+genCallSimpleCast w t@(PrimTarget op) [dst] args = do
+    let width = widthToLlvmInt w
+        dstTy = cmmToLlvmType $ localRegType dst
+
+    fname                       <- cmmPrimOpFunctions op
+    (fptr, _, top3)             <- getInstrinct fname width [width]
+
+    dstV                        <- getCmmReg (CmmLocal dst)
+
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints = zip args arg_hints
+    (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])
+    (argsV', stmts4)            <- castVars Signed $ zip argsV [width]
+    (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []
+    (retVs', stmts5)            <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
+    let retV'                    = singletonPanic "genCallSimpleCast" retVs'
+    let s2                       = Store retV' dstV
+
+    let stmts = stmts2 `appOL` stmts4 `snocOL`
+                s1 `appOL` stmts5 `snocOL` s2
+    return (stmts, top2 ++ top3)
+genCallSimpleCast _ _ dsts _ =
+    panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts")
+
+-- Handle simple function call that only need simple type casting, of the form:
+--   truncate arg >>= \a -> call(a) >>= zext
+--
+-- since GHC only really has i32 and i64 types and things like Word8 are backed
+-- by an i32 and just present a logical i8 range. So we must handle conversions
+-- from i32 to i8 explicitly as LLVM is strict about types.
+genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
+              -> LlvmM StmtData
+genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do
+    let width = widthToLlvmInt w
+        dstTy = cmmToLlvmType $ localRegType dst
+
+    fname                       <- cmmPrimOpFunctions op
+    (fptr, _, top3)             <- getInstrinct fname width (const width <$> args)
+
+    dstV                        <- getCmmReg (CmmLocal dst)
+
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints = zip args arg_hints
+    (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])
+    (argsV', stmts4)            <- castVars Signed $ zip argsV (const width <$> argsV)
+    (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []
+    (retVs', stmts5)             <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]
+    let retV'                    = singletonPanic "genCallSimpleCast2" retVs'
+    let s2                       = Store retV' dstV
+
+    let stmts = stmts2 `appOL` stmts4 `snocOL`
+                s1 `appOL` stmts5 `snocOL` s2
+    return (stmts, top2 ++ top3)
+genCallSimpleCast2 _ _ dsts _ =
+    panic ("genCallSimpleCast2: " ++ show (length dsts) ++ " dsts")
+
+-- | Create a function pointer from a target.
+getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget
+           -> WriterT LlvmAccum LlvmM LlvmVar
+getFunPtrW funTy targ = liftExprData $ getFunPtr funTy targ
+
+-- | Create a function pointer from a target.
+getFunPtr :: (LMString -> LlvmType) -> ForeignTarget
+          -> LlvmM ExprData
+getFunPtr funTy targ = case targ of
+    ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do
+        name <- strCLabel_llvm lbl
+        getHsFunc' name (funTy name)
+
+    ForeignTarget expr _ -> do
+        (v1, stmts, top) <- exprToVar expr
+        dflags <- getDynFlags
+        let fty = funTy $ fsLit "dynamic"
+            cast = case getVarType v1 of
+                ty | isPointer ty -> LM_Bitcast
+                ty | isInt ty     -> LM_Inttoptr
+
+                ty -> panic $ "genCall: Expr is of bad type for function"
+                              ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")"
+
+        (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
+        return (v2, stmts `snocOL` s1, top)
+
+    PrimTarget mop -> do
+        name <- cmmPrimOpFunctions mop
+        let fty = funTy name
+        getInstrinct2 name fty
+
+-- | Conversion of call arguments.
+arg_varsW :: [(CmmActual, ForeignHint)]
+          -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
+          -> WriterT LlvmAccum LlvmM [LlvmVar]
+arg_varsW xs ys = do
+    (vars, stmts, decls) <- lift $ arg_vars xs ys
+    tell $ LlvmAccum stmts decls
+    return vars
+
+-- | Conversion of call arguments.
+arg_vars :: [(CmmActual, ForeignHint)]
+         -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
+         -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
+
+arg_vars [] (vars, stmts, tops)
+  = return (vars, stmts, tops)
+
+arg_vars ((e, AddrHint):rest) (vars, stmts, tops)
+  = do (v1, stmts', top') <- exprToVar e
+       dflags <- getDynFlags
+       let op = case getVarType v1 of
+               ty | isPointer ty -> LM_Bitcast
+               ty | isInt ty     -> LM_Inttoptr
+
+               a  -> panic $ "genCall: Can't cast llvmType to i8*! ("
+                           ++ showSDoc dflags (ppr a) ++ ")"
+
+       (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
+       arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
+                               tops ++ top')
+
+arg_vars ((e, _):rest) (vars, stmts, tops)
+  = do (v1, stmts', top') <- exprToVar e
+       arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
+
+
+-- | Cast a collection of LLVM variables to specific types.
+castVarsW :: Signage
+          -> [(LlvmVar, LlvmType)]
+          -> WriterT LlvmAccum LlvmM [LlvmVar]
+castVarsW signage vars = do
+    (vars, stmts) <- lift $ castVars signage vars
+    tell $ LlvmAccum stmts mempty
+    return vars
+
+-- | Cast a collection of LLVM variables to specific types.
+castVars :: Signage -> [(LlvmVar, LlvmType)]
+         -> LlvmM ([LlvmVar], LlvmStatements)
+castVars signage vars = do
+                done <- mapM (uncurry (castVar signage)) vars
+                let (vars', stmts) = unzip done
+                return (vars', toOL stmts)
+
+-- | Cast an LLVM variable to a specific type, panicing if it can't be done.
+castVar :: Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
+castVar signage v t | getVarType v == t
+            = return (v, Nop)
+
+            | otherwise
+            = do dflags <- getDynFlags
+                 let op = case (getVarType v, t) of
+                      (LMInt n, LMInt m)
+                          -> if n < m then extend else LM_Trunc
+                      (vt, _) | isFloat vt && isFloat t
+                          -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t
+                                then LM_Fpext else LM_Fptrunc
+                      (vt, _) | isInt vt && isFloat t       -> LM_Sitofp
+                      (vt, _) | isFloat vt && isInt t       -> LM_Fptosi
+                      (vt, _) | isInt vt && isPointer t     -> LM_Inttoptr
+                      (vt, _) | isPointer vt && isInt t     -> LM_Ptrtoint
+                      (vt, _) | isPointer vt && isPointer t -> LM_Bitcast
+                      (vt, _) | isVector vt && isVector t   -> LM_Bitcast
+
+                      (vt, _) -> panic $ "castVars: Can't cast this type ("
+                                  ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")"
+                 doExpr t $ Cast op v t
+    where extend = case signage of
+            Signed      -> LM_Sext
+            Unsigned    -> LM_Zext
+
+
+cmmPrimOpRetValSignage :: CallishMachOp -> Signage
+cmmPrimOpRetValSignage mop = case mop of
+    MO_Pdep _   -> Unsigned
+    MO_Pext _   -> Unsigned
+    _           -> Signed
+
+-- | Decide what C function to use to implement a CallishMachOp
+cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
+cmmPrimOpFunctions mop = do
+
+  dflags <- getDynFlags
+  let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags)
+      intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags)
+      unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
+                        ++ " not supported here")
+
+  return $ case mop of
+    MO_F32_Exp    -> fsLit "expf"
+    MO_F32_Log    -> fsLit "logf"
+    MO_F32_Sqrt   -> fsLit "llvm.sqrt.f32"
+    MO_F32_Fabs   -> fsLit "llvm.fabs.f32"
+    MO_F32_Pwr    -> fsLit "llvm.pow.f32"
+
+    MO_F32_Sin    -> fsLit "llvm.sin.f32"
+    MO_F32_Cos    -> fsLit "llvm.cos.f32"
+    MO_F32_Tan    -> fsLit "tanf"
+
+    MO_F32_Asin   -> fsLit "asinf"
+    MO_F32_Acos   -> fsLit "acosf"
+    MO_F32_Atan   -> fsLit "atanf"
+
+    MO_F32_Sinh   -> fsLit "sinhf"
+    MO_F32_Cosh   -> fsLit "coshf"
+    MO_F32_Tanh   -> fsLit "tanhf"
+
+    MO_F32_Asinh  -> fsLit "asinhf"
+    MO_F32_Acosh  -> fsLit "acoshf"
+    MO_F32_Atanh  -> fsLit "atanhf"
+
+    MO_F64_Exp    -> fsLit "exp"
+    MO_F64_Log    -> fsLit "log"
+    MO_F64_Sqrt   -> fsLit "llvm.sqrt.f64"
+    MO_F64_Fabs   -> fsLit "llvm.fabs.f64"
+    MO_F64_Pwr    -> fsLit "llvm.pow.f64"
+
+    MO_F64_Sin    -> fsLit "llvm.sin.f64"
+    MO_F64_Cos    -> fsLit "llvm.cos.f64"
+    MO_F64_Tan    -> fsLit "tan"
+
+    MO_F64_Asin   -> fsLit "asin"
+    MO_F64_Acos   -> fsLit "acos"
+    MO_F64_Atan   -> fsLit "atan"
+
+    MO_F64_Sinh   -> fsLit "sinh"
+    MO_F64_Cosh   -> fsLit "cosh"
+    MO_F64_Tanh   -> fsLit "tanh"
+
+    MO_F64_Asinh  -> fsLit "asinh"
+    MO_F64_Acosh  -> fsLit "acosh"
+    MO_F64_Atanh  -> fsLit "atanh"
+
+    MO_Memcpy _   -> fsLit $ "llvm.memcpy."  ++ intrinTy1
+    MO_Memmove _  -> fsLit $ "llvm.memmove." ++ intrinTy1
+    MO_Memset _   -> fsLit $ "llvm.memset."  ++ intrinTy2
+    MO_Memcmp _   -> fsLit $ "memcmp"
+
+    (MO_PopCnt w) -> fsLit $ "llvm.ctpop."  ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    (MO_BSwap w)  -> fsLit $ "llvm.bswap."  ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    (MO_Clz w)    -> fsLit $ "llvm.ctlz."   ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    (MO_Ctz w)    -> fsLit $ "llvm.cttz."   ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+
+    (MO_Pdep w)   ->  let w' = showSDoc dflags (ppr $ widthInBits w)
+                      in  if isBmi2Enabled dflags
+                            then fsLit $ "llvm.x86.bmi.pdep."   ++ w'
+                            else fsLit $ "hs_pdep"              ++ w'
+    (MO_Pext w)   ->  let w' = showSDoc dflags (ppr $ widthInBits w)
+                      in  if isBmi2Enabled dflags
+                            then fsLit $ "llvm.x86.bmi.pext."   ++ w'
+                            else fsLit $ "hs_pext"              ++ w'
+
+    (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch"
+
+    MO_AddIntC w    -> fsLit $ "llvm.sadd.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    MO_SubIntC w    -> fsLit $ "llvm.ssub.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    MO_Add2 w       -> fsLit $ "llvm.uadd.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    MO_AddWordC w   -> fsLit $ "llvm.uadd.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+    MO_SubWordC w   -> fsLit $ "llvm.usub.with.overflow."
+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+
+    MO_S_QuotRem {}  -> unsupported
+    MO_U_QuotRem {}  -> unsupported
+    MO_U_QuotRem2 {} -> unsupported
+    -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the
+    -- appropriate case of genCall.
+    MO_U_Mul2 {}     -> unsupported
+    MO_WriteBarrier  -> unsupported
+    MO_Touch         -> unsupported
+    MO_UF_Conv _     -> unsupported
+
+    MO_AtomicRead _  -> unsupported
+    MO_AtomicRMW _ _ -> unsupported
+    MO_AtomicWrite _ -> unsupported
+    MO_Cmpxchg _     -> unsupported
+
+-- | Tail function calls
+genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData
+
+-- Call to known function
+genJump (CmmLit (CmmLabel lbl)) live = do
+    (vf, stmts, top) <- getHsFunc live lbl
+    (stgRegs, stgStmts) <- funEpilogue live
+    let s1  = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
+    let s2  = Return Nothing
+    return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
+
+
+-- Call to unknown function / address
+genJump expr live = do
+    fty <- llvmFunTy live
+    (vf, stmts, top) <- exprToVar expr
+    dflags <- getDynFlags
+
+    let cast = case getVarType vf of
+         ty | isPointer ty -> LM_Bitcast
+         ty | isInt ty     -> LM_Inttoptr
+
+         ty -> panic $ "genJump: Expr is of bad type for function call! ("
+                     ++ showSDoc dflags (ppr ty) ++ ")"
+
+    (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
+    (stgRegs, stgStmts) <- funEpilogue live
+    let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
+    let s3 = Return Nothing
+    return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
+            top)
+
+
+-- | CmmAssign operation
+--
+-- We use stack allocated variables for CmmReg. The optimiser will replace
+-- these with registers when possible.
+genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData
+genAssign reg val = do
+    vreg <- getCmmReg reg
+    (vval, stmts2, top2) <- exprToVar val
+    let stmts = stmts2
+
+    let ty = (pLower . getVarType) vreg
+    dflags <- getDynFlags
+    case ty of
+      -- Some registers are pointer types, so need to cast value to pointer
+      LMPointer _ | getVarType vval == llvmWord dflags -> do
+          (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
+          let s2 = Store v vreg
+          return (stmts `snocOL` s1 `snocOL` s2, top2)
+
+      LMVector _ _ -> do
+          (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty
+          let s2 = Store v vreg
+          return (stmts `snocOL` s1 `snocOL` s2, top2)
+
+      _ -> do
+          let s1 = Store vval vreg
+          return (stmts `snocOL` s1, top2)
+
+
+-- | CmmStore operation
+genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData
+
+-- First we try to detect a few common cases and produce better code for
+-- these then the default case. We are mostly trying to detect Cmm code
+-- like I32[Sp + n] and use 'getelementptr' operations instead of the
+-- generic case that uses casts and pointer arithmetic
+genStore addr@(CmmReg (CmmGlobal r)) val
+    = genStore_fast addr r 0 val
+
+genStore addr@(CmmRegOff (CmmGlobal r) n) val
+    = genStore_fast addr r n val
+
+genStore addr@(CmmMachOp (MO_Add _) [
+                            (CmmReg (CmmGlobal r)),
+                            (CmmLit (CmmInt n _))])
+                val
+    = genStore_fast addr r (fromInteger n) val
+
+genStore addr@(CmmMachOp (MO_Sub _) [
+                            (CmmReg (CmmGlobal r)),
+                            (CmmLit (CmmInt n _))])
+                val
+    = genStore_fast addr r (negate $ fromInteger n) val
+
+-- generic case
+genStore addr val
+    = getTBAAMeta topN >>= genStore_slow addr val
+
+-- | CmmStore operation
+-- This is a special case for storing to a global register pointer
+-- offset such as I32[Sp+8].
+genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr
+              -> LlvmM StmtData
+genStore_fast addr r n val
+  = do dflags <- getDynFlags
+       (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
+       meta          <- getTBAARegMeta r
+       let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)
+       case isPointer grt && rem == 0 of
+            True -> do
+                (vval,  stmts, top) <- exprToVar val
+                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
+                -- We might need a different pointer type, so check
+                case pLower grt == getVarType vval of
+                     -- were fine
+                     True  -> do
+                         let s3 = MetaStmt meta $ Store vval ptr
+                         return (stmts `appOL` s1 `snocOL` s2
+                                 `snocOL` s3, top)
+
+                     -- cast to pointer type needed
+                     False -> do
+                         let ty = (pLift . getVarType) vval
+                         (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
+                         let s4 = MetaStmt meta $ Store vval ptr'
+                         return (stmts `appOL` s1 `snocOL` s2
+                                 `snocOL` s3 `snocOL` s4, top)
+
+            -- If its a bit type then we use the slow method since
+            -- we can't avoid casting anyway.
+            False -> genStore_slow addr val meta
+
+
+-- | CmmStore operation
+-- Generic case. Uses casts and pointer arithmetic if needed.
+genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData
+genStore_slow addr val meta = do
+    (vaddr, stmts1, top1) <- exprToVar addr
+    (vval,  stmts2, top2) <- exprToVar val
+
+    let stmts = stmts1 `appOL` stmts2
+    dflags <- getDynFlags
+    case getVarType vaddr of
+        -- sometimes we need to cast an int to a pointer before storing
+        LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do
+            (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
+            let s2 = MetaStmt meta $ Store v vaddr
+            return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
+
+        LMPointer _ -> do
+            let s1 = MetaStmt meta $ Store vval vaddr
+            return (stmts `snocOL` s1, top1 ++ top2)
+
+        i@(LMInt _) | i == llvmWord dflags -> do
+            let vty = pLift $ getVarType vval
+            (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
+            let s2 = MetaStmt meta $ Store vval vptr
+            return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
+
+        other ->
+            pprPanic "genStore: ptr not right type!"
+                    (PprCmm.pprExpr addr <+> text (
+                        "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
+                        ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
+                        ", Var: " ++ showSDoc dflags (ppr vaddr)))
+
+
+-- | Unconditional branch
+genBranch :: BlockId -> LlvmM StmtData
+genBranch id =
+    let label = blockIdToLlvm id
+    in return (unitOL $ Branch label, [])
+
+
+-- | Conditional branch
+genCondBranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> LlvmM StmtData
+genCondBranch cond idT idF likely = do
+    let labelT = blockIdToLlvm idT
+    let labelF = blockIdToLlvm idF
+    -- See Note [Literals and branch conditions].
+    (vc, stmts1, top1) <- exprToVarOpt i1Option cond
+    if getVarType vc == i1
+        then do
+            (vc', (stmts2, top2)) <- case likely of
+              Just b -> genExpectLit (if b then 1 else 0) i1  vc
+              _      -> pure (vc, (nilOL, []))
+            let s1 = BranchIf vc' labelT labelF
+            return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)
+        else do
+            dflags <- getDynFlags
+            panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")"
+
+
+-- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var.
+genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData)
+genExpectLit expLit expTy var = do
+  dflags <- getDynFlags
+
+  let
+    lit = LMLitVar $ LMIntLit expLit expTy
+
+    llvmExpectName
+      | isInt expTy = fsLit $ "llvm.expect." ++ showSDoc dflags (ppr expTy)
+      | otherwise   = panic $ "genExpectedLit: Type not an int!"
+
+  (llvmExpect, stmts, top) <-
+    getInstrinct llvmExpectName expTy [expTy, expTy]
+  (var', call) <- doExpr expTy $ Call StdCall llvmExpect [var, lit] []
+  return (var', (stmts `snocOL` call, top))
+
+{- Note [Literals and branch conditions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+It is important that whenever we generate branch conditions for
+literals like '1', they are properly narrowed to an LLVM expression of
+type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert
+a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt
+must be certain to return a properly narrowed type. genLit is
+responsible for this, in the case of literal integers.
+
+Often, we won't see direct statements like:
+
+    if(1) {
+      ...
+    } else {
+      ...
+    }
+
+at this point in the pipeline, because the Glorious Code Generator
+will do trivial branch elimination in the sinking pass (among others,)
+which will eliminate the expression entirely.
+
+However, it's certainly possible and reasonable for this to occur in
+hand-written C-- code. Consider something like:
+
+    #if !defined(SOME_CONDITIONAL)
+    #define CHECK_THING(x) 1
+    #else
+    #define CHECK_THING(x) some_operation((x))
+    #endif
+
+    f() {
+
+      if (CHECK_THING(xyz)) {
+        ...
+      } else {
+        ...
+      }
+
+    }
+
+In such an instance, CHECK_THING might result in an *expression* in
+one case, and a *literal* in the other, depending on what in
+particular was #define'd. So we must be sure to properly narrow the
+literal in this case to i1 as it won't be eliminated beforehand.
+
+For a real example of this, see ./rts/StgStdThunks.cmm
+
+-}
+
+
+
+-- | Switch branch
+genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData
+genSwitch cond ids = do
+    (vc, stmts, top) <- exprToVar cond
+    let ty = getVarType vc
+
+    let labels = [ (mkIntLit ty ix, blockIdToLlvm b)
+                 | (ix, b) <- switchTargetsCases ids ]
+    -- out of range is undefined, so let's just branch to first label
+    let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l
+               | otherwise                          = snd (head labels)
+
+    let s1 = Switch vc defLbl labels
+    return $ (stmts `snocOL` s1, top)
+
+
+-- -----------------------------------------------------------------------------
+-- * CmmExpr code generation
+--
+
+-- | An expression conversion return data:
+--   * LlvmVar: The var holding the result of the expression
+--   * LlvmStatements: Any statements needed to evaluate the expression
+--   * LlvmCmmDecl: Any global data needed for this expression
+type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl])
+
+-- | Values which can be passed to 'exprToVar' to configure its
+-- behaviour in certain circumstances.
+--
+-- Currently just used for determining if a comparison should return
+-- a boolean (i1) or a word. See Note [Literals and branch conditions].
+newtype EOption = EOption { i1Expected :: Bool }
+-- XXX: EOption is an ugly and inefficient solution to this problem.
+
+-- | i1 type expected (condition scrutinee).
+i1Option :: EOption
+i1Option = EOption True
+
+-- | Word type expected (usual).
+wordOption :: EOption
+wordOption = EOption False
+
+-- | Convert a CmmExpr to a list of LlvmStatements with the result of the
+-- expression being stored in the returned LlvmVar.
+exprToVar :: CmmExpr -> LlvmM ExprData
+exprToVar = exprToVarOpt wordOption
+
+exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData
+exprToVarOpt opt e = case e of
+
+    CmmLit lit
+        -> genLit opt lit
+
+    CmmLoad e' ty
+        -> genLoad False e' ty
+
+    -- Cmmreg in expression is the value, so must load. If you want actual
+    -- reg pointer, call getCmmReg directly.
+    CmmReg r -> do
+        (v1, ty, s1) <- getCmmRegVal r
+        case isPointer ty of
+             True  -> do
+                 -- Cmm wants the value, so pointer types must be cast to ints
+                 dflags <- getDynFlags
+                 (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags)
+                 return (v2, s1 `snocOL` s2, [])
+
+             False -> return (v1, s1, [])
+
+    CmmMachOp op exprs
+        -> genMachOp opt op exprs
+
+    CmmRegOff r i
+        -> do dflags <- getDynFlags
+              exprToVar $ expandCmmReg dflags (r, i)
+
+    CmmStackSlot _ _
+        -> panic "exprToVar: CmmStackSlot not supported!"
+
+
+-- | Handle CmmMachOp expressions
+genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
+
+-- Unary Machop
+genMachOp _ op [x] = case op of
+
+    MO_Not w ->
+        let all1 = mkIntLit (widthToLlvmInt w) (-1)
+        in negate (widthToLlvmInt w) all1 LM_MO_Xor
+
+    MO_S_Neg w ->
+        let all0 = mkIntLit (widthToLlvmInt w) 0
+        in negate (widthToLlvmInt w) all0 LM_MO_Sub
+
+    MO_F_Neg w ->
+        let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)
+        in negate (widthToLlvmFloat w) all0 LM_MO_FSub
+
+    MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp
+    MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi
+
+    MO_SS_Conv from to
+        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext
+
+    MO_UU_Conv from to
+        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
+
+    MO_XX_Conv from to
+        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext
+
+    MO_FF_Conv from to
+        -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext
+
+    MO_VS_Neg len w ->
+        let ty    = widthToLlvmInt w
+            vecty = LMVector len ty
+            all0  = LMIntLit (-0) ty
+            all0s = LMLitVar $ LMVectorLit (replicate len all0)
+        in negateVec vecty all0s LM_MO_Sub
+
+    MO_VF_Neg len w ->
+        let ty    = widthToLlvmFloat w
+            vecty = LMVector len ty
+            all0  = LMFloatLit (-0) ty
+            all0s = LMLitVar $ LMVectorLit (replicate len all0)
+        in negateVec vecty all0s LM_MO_FSub
+
+    MO_AlignmentCheck _ _ -> panic "-falignment-sanitisation is not supported by -fllvm"
+
+    -- Handle unsupported cases explicitly so we get a warning
+    -- of missing case when new MachOps added
+    MO_Add _          -> panicOp
+    MO_Mul _          -> panicOp
+    MO_Sub _          -> panicOp
+    MO_S_MulMayOflo _ -> panicOp
+    MO_S_Quot _       -> panicOp
+    MO_S_Rem _        -> panicOp
+    MO_U_MulMayOflo _ -> panicOp
+    MO_U_Quot _       -> panicOp
+    MO_U_Rem _        -> panicOp
+
+    MO_Eq  _          -> panicOp
+    MO_Ne  _          -> panicOp
+    MO_S_Ge _         -> panicOp
+    MO_S_Gt _         -> panicOp
+    MO_S_Le _         -> panicOp
+    MO_S_Lt _         -> panicOp
+    MO_U_Ge _         -> panicOp
+    MO_U_Gt _         -> panicOp
+    MO_U_Le _         -> panicOp
+    MO_U_Lt _         -> panicOp
+
+    MO_F_Add        _ -> panicOp
+    MO_F_Sub        _ -> panicOp
+    MO_F_Mul        _ -> panicOp
+    MO_F_Quot       _ -> panicOp
+    MO_F_Eq         _ -> panicOp
+    MO_F_Ne         _ -> panicOp
+    MO_F_Ge         _ -> panicOp
+    MO_F_Gt         _ -> panicOp
+    MO_F_Le         _ -> panicOp
+    MO_F_Lt         _ -> panicOp
+
+    MO_And          _ -> panicOp
+    MO_Or           _ -> panicOp
+    MO_Xor          _ -> panicOp
+    MO_Shl          _ -> panicOp
+    MO_U_Shr        _ -> panicOp
+    MO_S_Shr        _ -> panicOp
+
+    MO_V_Insert   _ _ -> panicOp
+    MO_V_Extract  _ _ -> panicOp
+
+    MO_V_Add      _ _ -> panicOp
+    MO_V_Sub      _ _ -> panicOp
+    MO_V_Mul      _ _ -> panicOp
+
+    MO_VS_Quot    _ _ -> panicOp
+    MO_VS_Rem     _ _ -> panicOp
+
+    MO_VU_Quot    _ _ -> panicOp
+    MO_VU_Rem     _ _ -> panicOp
+
+    MO_VF_Insert  _ _ -> panicOp
+    MO_VF_Extract _ _ -> panicOp
+
+    MO_VF_Add     _ _ -> panicOp
+    MO_VF_Sub     _ _ -> panicOp
+    MO_VF_Mul     _ _ -> panicOp
+    MO_VF_Quot    _ _ -> panicOp
+
+    where
+        negate ty v2 negOp = do
+            (vx, stmts, top) <- exprToVar x
+            (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
+            return (v1, stmts `snocOL` s1, top)
+
+        negateVec ty v2 negOp = do
+            (vx, stmts1, top) <- exprToVar x
+            (vxs', stmts2) <- castVars Signed [(vx, ty)]
+            let vx' = singletonPanic "genMachOp: negateVec" vxs'
+            (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'
+            return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
+
+        fiConv ty convOp = do
+            (vx, stmts, top) <- exprToVar x
+            (v1, s1) <- doExpr ty $ Cast convOp vx ty
+            return (v1, stmts `snocOL` s1, top)
+
+        sameConv from ty reduce expand = do
+            x'@(vx, stmts, top) <- exprToVar x
+            let sameConv' op = do
+                    (v1, s1) <- doExpr ty $ Cast op vx ty
+                    return (v1, stmts `snocOL` s1, top)
+            dflags <- getDynFlags
+            let toWidth = llvmWidthInBits dflags ty
+            -- LLVM doesn't like trying to convert to same width, so
+            -- need to check for that as we do get Cmm code doing it.
+            case widthInBits from  of
+                 w | w < toWidth -> sameConv' expand
+                 w | w > toWidth -> sameConv' reduce
+                 _w              -> return x'
+
+        panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encountered"
+                       ++ "with one argument! (" ++ show op ++ ")"
+
+-- Handle GlobalRegs pointers
+genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
+    = genMachOp_fast opt o r (fromInteger n) e
+
+genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
+    = genMachOp_fast opt o r (negate . fromInteger $ n) e
+
+-- Generic case
+genMachOp opt op e = genMachOp_slow opt op e
+
+
+-- | Handle CmmMachOp expressions
+-- This is a specialised method that handles Global register manipulations like
+-- 'Sp - 16', using the getelementptr instruction.
+genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
+               -> LlvmM ExprData
+genMachOp_fast opt op r n e
+  = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
+       dflags <- getDynFlags
+       let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)
+       case isPointer grt && rem == 0 of
+            True -> do
+                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
+                (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags)
+                return (var, s1 `snocOL` s2 `snocOL` s3, [])
+
+            False -> genMachOp_slow opt op e
+
+
+-- | Handle CmmMachOp expressions
+-- This handles all the cases not handle by the specialised genMachOp_fast.
+genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
+
+-- Element extraction
+genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do
+    vval <- exprToVarW val
+    vidx <- exprToVarW idx
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, LMVector l ty)]
+    doExprW ty $ Extract vval' vidx
+  where
+    ty = widthToLlvmInt w
+
+genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do
+    vval <- exprToVarW val
+    vidx <- exprToVarW idx
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, LMVector l ty)]
+    doExprW ty $ Extract vval' vidx
+  where
+    ty = widthToLlvmFloat w
+
+-- Element insertion
+genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do
+    vval <- exprToVarW val
+    velt <- exprToVarW elt
+    vidx <- exprToVarW idx
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, ty)]
+    doExprW ty $ Insert vval' velt vidx
+  where
+    ty = LMVector l (widthToLlvmInt w)
+
+genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do
+    vval <- exprToVarW val
+    velt <- exprToVarW elt
+    vidx <- exprToVarW idx
+    vval' <- singletonPanic "genMachOp_slow" <$>
+             castVarsW Signed [(vval, ty)]
+    doExprW ty $ Insert vval' velt vidx
+  where
+    ty = LMVector l (widthToLlvmFloat w)
+
+-- Binary MachOp
+genMachOp_slow opt op [x, y] = case op of
+
+    MO_Eq _   -> genBinComp opt LM_CMP_Eq
+    MO_Ne _   -> genBinComp opt LM_CMP_Ne
+
+    MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt
+    MO_S_Ge _ -> genBinComp opt LM_CMP_Sge
+    MO_S_Lt _ -> genBinComp opt LM_CMP_Slt
+    MO_S_Le _ -> genBinComp opt LM_CMP_Sle
+
+    MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt
+    MO_U_Ge _ -> genBinComp opt LM_CMP_Uge
+    MO_U_Lt _ -> genBinComp opt LM_CMP_Ult
+    MO_U_Le _ -> genBinComp opt LM_CMP_Ule
+
+    MO_Add _ -> genBinMach LM_MO_Add
+    MO_Sub _ -> genBinMach LM_MO_Sub
+    MO_Mul _ -> genBinMach LM_MO_Mul
+
+    MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"
+
+    MO_S_MulMayOflo w -> isSMulOK w x y
+
+    MO_S_Quot _ -> genBinMach LM_MO_SDiv
+    MO_S_Rem  _ -> genBinMach LM_MO_SRem
+
+    MO_U_Quot _ -> genBinMach LM_MO_UDiv
+    MO_U_Rem  _ -> genBinMach LM_MO_URem
+
+    MO_F_Eq _ -> genBinComp opt LM_CMP_Feq
+    MO_F_Ne _ -> genBinComp opt LM_CMP_Fne
+    MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt
+    MO_F_Ge _ -> genBinComp opt LM_CMP_Fge
+    MO_F_Lt _ -> genBinComp opt LM_CMP_Flt
+    MO_F_Le _ -> genBinComp opt LM_CMP_Fle
+
+    MO_F_Add  _ -> genBinMach LM_MO_FAdd
+    MO_F_Sub  _ -> genBinMach LM_MO_FSub
+    MO_F_Mul  _ -> genBinMach LM_MO_FMul
+    MO_F_Quot _ -> genBinMach LM_MO_FDiv
+
+    MO_And _   -> genBinMach LM_MO_And
+    MO_Or  _   -> genBinMach LM_MO_Or
+    MO_Xor _   -> genBinMach LM_MO_Xor
+    MO_Shl _   -> genBinMach LM_MO_Shl
+    MO_U_Shr _ -> genBinMach LM_MO_LShr
+    MO_S_Shr _ -> genBinMach LM_MO_AShr
+
+    MO_V_Add l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add
+    MO_V_Sub l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub
+    MO_V_Mul l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul
+
+    MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv
+    MO_VS_Rem  l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem
+
+    MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv
+    MO_VU_Rem  l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem
+
+    MO_VF_Add  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd
+    MO_VF_Sub  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub
+    MO_VF_Mul  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul
+    MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv
+
+    MO_Not _       -> panicOp
+    MO_S_Neg _     -> panicOp
+    MO_F_Neg _     -> panicOp
+
+    MO_SF_Conv _ _ -> panicOp
+    MO_FS_Conv _ _ -> panicOp
+    MO_SS_Conv _ _ -> panicOp
+    MO_UU_Conv _ _ -> panicOp
+    MO_XX_Conv _ _ -> panicOp
+    MO_FF_Conv _ _ -> panicOp
+
+    MO_V_Insert  {} -> panicOp
+    MO_V_Extract {} -> panicOp
+
+    MO_VS_Neg {} -> panicOp
+
+    MO_VF_Insert  {} -> panicOp
+    MO_VF_Extract {} -> panicOp
+
+    MO_VF_Neg {} -> panicOp
+
+    MO_AlignmentCheck {} -> panicOp
+
+    where
+        binLlvmOp ty binOp = runExprData $ do
+            vx <- exprToVarW x
+            vy <- exprToVarW y
+            if getVarType vx == getVarType vy
+                then do
+                    doExprW (ty vx) $ binOp vx vy
+
+                else do
+                    -- Error. Continue anyway so we can debug the generated ll file.
+                    dflags <- getDynFlags
+                    let style = mkCodeStyle CStyle
+                        toString doc = renderWithStyle dflags doc style
+                        cmmToStr = (lines . toString . PprCmm.pprExpr)
+                    statement $ Comment $ map fsLit $ cmmToStr x
+                    statement $ Comment $ map fsLit $ cmmToStr y
+                    doExprW (ty vx) $ binOp vx vy
+
+        binCastLlvmOp ty binOp = runExprData $ do
+            vx <- exprToVarW x
+            vy <- exprToVarW y
+            vxy' <- castVarsW Signed [(vx, ty), (vy, ty)]
+            case vxy' of
+              [vx',vy'] -> doExprW ty $ binOp vx' vy'
+              _         -> panic "genMachOp_slow: binCastLlvmOp"
+
+        -- | Need to use EOption here as Cmm expects word size results from
+        -- comparisons while LLVM return i1. Need to extend to llvmWord type
+        -- if expected. See Note [Literals and branch conditions].
+        genBinComp opt cmp = do
+            ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)
+            dflags <- getDynFlags
+            if getVarType v1 == i1
+                then case i1Expected opt of
+                    True  -> return ed
+                    False -> do
+                        let w_ = llvmWord dflags
+                        (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_
+                        return (v2, stmts `snocOL` s1, top)
+                else
+                    panic $ "genBinComp: Compare returned type other then i1! "
+                        ++ (showSDoc dflags $ ppr $ getVarType v1)
+
+        genBinMach op = binLlvmOp getVarType (LlvmOp op)
+
+        genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op)
+
+        -- | Detect if overflow will occur in signed multiply of the two
+        -- CmmExpr's. This is the LLVM assembly equivalent of the NCG
+        -- implementation. Its much longer due to type information/safety.
+        -- This should actually compile to only about 3 asm instructions.
+        isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData
+        isSMulOK _ x y = runExprData $ do
+            vx <- exprToVarW x
+            vy <- exprToVarW y
+
+            dflags <- getDynFlags
+            let word  = getVarType vx
+            let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)
+            let shift = llvmWidthInBits dflags word
+            let shift1 = toIWord dflags (shift - 1)
+            let shift2 = toIWord dflags shift
+
+            if isInt word
+                then do
+                    x1     <- doExprW word2 $ Cast LM_Sext vx word2
+                    y1     <- doExprW word2 $ Cast LM_Sext vy word2
+                    r1     <- doExprW word2 $ LlvmOp LM_MO_Mul x1 y1
+                    rlow1  <- doExprW word $ Cast LM_Trunc r1 word
+                    rlow2  <- doExprW word $ LlvmOp LM_MO_AShr rlow1 shift1
+                    rhigh1 <- doExprW word2 $ LlvmOp LM_MO_AShr r1 shift2
+                    rhigh2 <- doExprW word $ Cast LM_Trunc rhigh1 word
+                    doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2
+
+                else
+                    panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")"
+
+        panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"
+                       ++ "with two arguments! (" ++ show op ++ ")"
+
+-- More than two expression, invalid!
+genMachOp_slow _ _ _ = panic "genMachOp: More than 2 expressions in MachOp!"
+
+
+-- | Handle CmmLoad expression.
+genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData
+
+-- First we try to detect a few common cases and produce better code for
+-- these then the default case. We are mostly trying to detect Cmm code
+-- like I32[Sp + n] and use 'getelementptr' operations instead of the
+-- generic case that uses casts and pointer arithmetic
+genLoad atomic e@(CmmReg (CmmGlobal r)) ty
+    = genLoad_fast atomic e r 0 ty
+
+genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty
+    = genLoad_fast atomic e r n ty
+
+genLoad atomic e@(CmmMachOp (MO_Add _) [
+                            (CmmReg (CmmGlobal r)),
+                            (CmmLit (CmmInt n _))])
+                ty
+    = genLoad_fast atomic e r (fromInteger n) ty
+
+genLoad atomic e@(CmmMachOp (MO_Sub _) [
+                            (CmmReg (CmmGlobal r)),
+                            (CmmLit (CmmInt n _))])
+                ty
+    = genLoad_fast atomic e r (negate $ fromInteger n) ty
+
+-- generic case
+genLoad atomic e ty
+    = getTBAAMeta topN >>= genLoad_slow atomic e ty
+
+-- | Handle CmmLoad expression.
+-- This is a special case for loading from a global register pointer
+-- offset such as I32[Sp+8].
+genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType
+             -> LlvmM ExprData
+genLoad_fast atomic e r n ty = do
+    dflags <- getDynFlags
+    (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
+    meta          <- getTBAARegMeta r
+    let ty'      = cmmToLlvmType ty
+        (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)
+    case isPointer grt && rem == 0 of
+            True  -> do
+                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
+                -- We might need a different pointer type, so check
+                case grt == ty' of
+                     -- were fine
+                     True -> do
+                         (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr)
+                         return (var, s1 `snocOL` s2 `snocOL` s3,
+                                     [])
+
+                     -- cast to pointer type needed
+                     False -> do
+                         let pty = pLift ty'
+                         (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
+                         (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr')
+                         return (var, s1 `snocOL` s2 `snocOL` s3
+                                    `snocOL` s4, [])
+
+            -- If its a bit type then we use the slow method since
+            -- we can't avoid casting anyway.
+            False -> genLoad_slow atomic  e ty meta
+  where
+    loadInstr ptr | atomic    = ALoad SyncSeqCst False ptr
+                  | otherwise = Load ptr
+
+-- | Handle Cmm load expression.
+-- Generic case. Uses casts and pointer arithmetic if needed.
+genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
+genLoad_slow atomic e ty meta = runExprData $ do
+    iptr <- exprToVarW e
+    dflags <- getDynFlags
+    case getVarType iptr of
+         LMPointer _ -> do
+                    doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr)
+
+         i@(LMInt _) | i == llvmWord dflags -> do
+                    let pty = LMPointer $ cmmToLlvmType ty
+                    ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty
+                    doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr)
+
+         other -> do pprPanic "exprToVar: CmmLoad expression is not right type!"
+                        (PprCmm.pprExpr e <+> text (
+                            "Size of Ptr: " ++ show (llvmPtrBits dflags) ++
+                            ", Size of var: " ++ show (llvmWidthInBits dflags other) ++
+                            ", Var: " ++ showSDoc dflags (ppr iptr)))
+  where
+    loadInstr ptr | atomic    = ALoad SyncSeqCst False ptr
+                  | otherwise = Load ptr
+
+
+-- | Handle CmmReg expression. This will return a pointer to the stack
+-- location of the register. Throws an error if it isn't allocated on
+-- the stack.
+getCmmReg :: CmmReg -> LlvmM LlvmVar
+getCmmReg (CmmLocal (LocalReg un _))
+  = do exists <- varLookup un
+       dflags <- getDynFlags
+       case exists of
+         Just ety -> return (LMLocalVar un $ pLift ety)
+         Nothing  -> panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!"
+           -- This should never happen, as every local variable should
+           -- have been assigned a value at some point, triggering
+           -- "funPrologue" to allocate it on the stack.
+
+getCmmReg (CmmGlobal g)
+  = do onStack <- checkStackReg g
+       dflags <- getDynFlags
+       if onStack
+         then return (lmGlobalRegVar dflags g)
+         else panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!"
+
+-- | Return the value of a given register, as well as its type. Might
+-- need to be load from stack.
+getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
+getCmmRegVal reg =
+  case reg of
+    CmmGlobal g -> do
+      onStack <- checkStackReg g
+      dflags <- getDynFlags
+      if onStack then loadFromStack else do
+        let r = lmGlobalRegArg dflags g
+        return (r, getVarType r, nilOL)
+    _ -> loadFromStack
+ where loadFromStack = do
+         ptr <- getCmmReg reg
+         let ty = pLower $ getVarType ptr
+         (v, s) <- doExpr ty (Load ptr)
+         return (v, ty, unitOL s)
+
+-- | Allocate a local CmmReg on the stack
+allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
+allocReg (CmmLocal (LocalReg un ty))
+  = let ty' = cmmToLlvmType ty
+        var = LMLocalVar un (LMPointer ty')
+        alc = Alloca ty' 1
+    in (var, unitOL $ Assignment var alc)
+
+allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
+                    ++ " have been handled elsewhere!"
+
+
+-- | Generate code for a literal
+genLit :: EOption -> CmmLit -> LlvmM ExprData
+genLit opt (CmmInt i w)
+  -- See Note [Literals and branch conditions].
+  = let width | i1Expected opt = i1
+              | otherwise      = LMInt (widthInBits w)
+        -- comm  = Comment [ fsLit $ "EOption: " ++ show opt
+        --                 , fsLit $ "Width  : " ++ show w
+        --                 , fsLit $ "Width' : " ++ show (widthInBits w)
+        --                 ]
+    in return (mkIntLit width i, nilOL, [])
+
+genLit _ (CmmFloat r w)
+  = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
+              nilOL, [])
+
+genLit opt (CmmVec ls)
+  = do llvmLits <- mapM toLlvmLit ls
+       return (LMLitVar $ LMVectorLit llvmLits, nilOL, [])
+  where
+    toLlvmLit :: CmmLit -> LlvmM LlvmLit
+    toLlvmLit lit = do
+        (llvmLitVar, _, _) <- genLit opt lit
+        case llvmLitVar of
+          LMLitVar llvmLit -> return llvmLit
+          _ -> panic "genLit"
+
+genLit _ cmm@(CmmLabel l)
+  = do var <- getGlobalPtr =<< strCLabel_llvm l
+       dflags <- getDynFlags
+       let lmty = cmmToLlvmType $ cmmLitType dflags cmm
+       (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
+       return (v1, unitOL s1, [])
+
+genLit opt (CmmLabelOff label off) = do
+    dflags <- getDynFlags
+    (vlbl, stmts, stat) <- genLit opt (CmmLabel label)
+    let voff = toIWord dflags off
+    (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
+    return (v1, stmts `snocOL` s1, stat)
+
+genLit opt (CmmLabelDiffOff l1 l2 off w) = do
+    dflags <- getDynFlags
+    (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1)
+    (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2)
+    let voff = toIWord dflags off
+    let ty1 = getVarType vl1
+    let ty2 = getVarType vl2
+    if (isInt ty1) && (isInt ty2)
+       && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2)
+       then do
+            (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
+            (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
+            let ty = widthToLlvmInt w
+            let stmts = stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2
+            if w /= wordWidth dflags
+              then do
+                (v3, s3) <- doExpr ty $ Cast LM_Trunc v2 ty
+                return (v3, stmts `snocOL` s3, stat1 ++ stat2)
+              else
+                return (v2, stmts, stat1 ++ stat2)
+        else
+            panic "genLit: CmmLabelDiffOff encountered with different label ty!"
+
+genLit opt (CmmBlock b)
+  = genLit opt (CmmLabel $ infoTblLbl b)
+
+genLit _ CmmHighStackMark
+  = panic "genStaticLit - CmmHighStackMark unsupported!"
+
+
+-- -----------------------------------------------------------------------------
+-- * Misc
+--
+
+-- | Find CmmRegs that get assigned and allocate them on the stack
+--
+-- Any register that gets written needs to be allcoated on the
+-- stack. This avoids having to map a CmmReg to an equivalent SSA form
+-- and avoids having to deal with Phi node insertion.  This is also
+-- the approach recommended by LLVM developers.
+--
+-- On the other hand, this is unnecessarily verbose if the register in
+-- question is never written. Therefore we skip it where we can to
+-- save a few lines in the output and hopefully speed compilation up a
+-- bit.
+funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData
+funPrologue live cmmBlocks = do
+
+  trash <- getTrashRegs
+  let getAssignedRegs :: CmmNode O O -> [CmmReg]
+      getAssignedRegs (CmmAssign reg _)  = [reg]
+      -- Calls will trash all registers. Unfortunately, this needs them to
+      -- be stack-allocated in the first place.
+      getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs
+      getAssignedRegs _                  = []
+      getRegsBlock (_, body, _)          = concatMap getAssignedRegs $ blockToList body
+      assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks
+      isLive r     = r `elem` alwaysLive || r `elem` live
+
+  dflags <- getDynFlags
+  stmtss <- flip mapM assignedRegs $ \reg ->
+    case reg of
+      CmmLocal (LocalReg un _) -> do
+        let (newv, stmts) = allocReg reg
+        varInsert un (pLower $ getVarType newv)
+        return stmts
+      CmmGlobal r -> do
+        let reg   = lmGlobalRegVar dflags r
+            arg   = lmGlobalRegArg dflags r
+            ty    = (pLower . getVarType) reg
+            trash = LMLitVar $ LMUndefLit ty
+            rval  = if isLive r then arg else trash
+            alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
+        markStackReg r
+        return $ toOL [alloc, Store rval reg]
+
+  return (concatOL stmtss, [])
+
+-- | Function epilogue. Load STG variables to use as argument for call.
+-- STG Liveness optimisation done here.
+funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)
+funEpilogue live = do
+
+    -- Have information and liveness optimisation is enabled?
+    let liveRegs = alwaysLive ++ live
+        isSSE (FloatReg _)  = True
+        isSSE (DoubleReg _) = True
+        isSSE (XmmReg _)    = True
+        isSSE (YmmReg _)    = True
+        isSSE (ZmmReg _)    = True
+        isSSE _             = False
+
+    -- Set to value or "undef" depending on whether the register is
+    -- actually live
+    dflags <- getDynFlags
+    let loadExpr r = do
+          (v, _, s) <- getCmmRegVal (CmmGlobal r)
+          return (Just $ v, s)
+        loadUndef r = do
+          let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)
+          return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
+    platform <- getDynFlag targetPlatform
+    loads <- flip mapM (activeStgRegs platform) $ \r -> case () of
+      _ | r `elem` liveRegs  -> loadExpr r
+        | not (isSSE r)      -> loadUndef r
+        | otherwise          -> return (Nothing, nilOL)
+
+    let (vars, stmts) = unzip loads
+    return (catMaybes vars, concatOL stmts)
+
+
+-- | A series of statements to trash all the STG registers.
+--
+-- In LLVM we pass the STG registers around everywhere in function calls.
+-- So this means LLVM considers them live across the entire function, when
+-- in reality they usually aren't. For Caller save registers across C calls
+-- the saving and restoring of them is done by the Cmm code generator,
+-- using Cmm local vars. So to stop LLVM saving them as well (and saving
+-- all of them since it thinks they're always live, we trash them just
+-- before the call by assigning the 'undef' value to them. The ones we
+-- need are restored from the Cmm local var and the ones we don't need
+-- are fine to be trashed.
+getTrashStmts :: LlvmM LlvmStatements
+getTrashStmts = do
+  regs <- getTrashRegs
+  stmts <- flip mapM regs $ \ r -> do
+    reg <- getCmmReg (CmmGlobal r)
+    let ty = (pLower . getVarType) reg
+    return $ Store (LMLitVar $ LMUndefLit ty) reg
+  return $ toOL stmts
+
+getTrashRegs :: LlvmM [GlobalReg]
+getTrashRegs = do plat <- getLlvmPlatform
+                  return $ filter (callerSaves plat) (activeStgRegs plat)
+
+-- | Get a function pointer to the CLabel specified.
+--
+-- This is for Haskell functions, function type is assumed, so doesn't work
+-- with foreign functions.
+getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData
+getHsFunc live lbl
+  = do fty <- llvmFunTy live
+       name <- strCLabel_llvm lbl
+       getHsFunc' name fty
+
+getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData
+getHsFunc' name fty
+  = do fun <- getGlobalPtr name
+       if getVarType fun == fty
+         then return (fun, nilOL, [])
+         else do (v1, s1) <- doExpr (pLift fty)
+                               $ Cast LM_Bitcast fun (pLift fty)
+                 return  (v1, unitOL s1, [])
+
+-- | Create a new local var
+mkLocalVar :: LlvmType -> LlvmM LlvmVar
+mkLocalVar ty = do
+    un <- getUniqueM
+    return $ LMLocalVar un ty
+
+
+-- | Execute an expression, assigning result to a var
+doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
+doExpr ty expr = do
+    v <- mkLocalVar ty
+    return (v, Assignment v expr)
+
+
+-- | Expand CmmRegOff
+expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr
+expandCmmReg dflags (reg, off)
+  = let width = typeWidth (cmmRegType dflags reg)
+        voff  = CmmLit $ CmmInt (fromIntegral off) width
+    in CmmMachOp (MO_Add width) [CmmReg reg, voff]
+
+
+-- | Convert a block id into a appropriate Llvm label
+blockIdToLlvm :: BlockId -> LlvmVar
+blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel
+
+-- | Create Llvm int Literal
+mkIntLit :: Integral a => LlvmType -> a -> LlvmVar
+mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty
+
+-- | Convert int type to a LLvmVar of word or i32 size
+toI32 :: Integral a => a -> LlvmVar
+toI32 = mkIntLit i32
+
+toIWord :: Integral a => DynFlags -> a -> LlvmVar
+toIWord dflags = mkIntLit (llvmWord dflags)
+
+
+-- | Error functions
+panic :: String -> a
+panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
+
+pprPanic :: String -> SDoc -> a
+pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d
+
+
+-- | Returns TBAA meta data by unique
+getTBAAMeta :: Unique -> LlvmM [MetaAnnot]
+getTBAAMeta u = do
+    mi <- getUniqMeta u
+    return [MetaAnnot tbaa (MetaNode i) | let Just i = mi]
+
+-- | Returns TBAA meta data for given register
+getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot]
+getTBAARegMeta = getTBAAMeta . getTBAA
+
+
+-- | A more convenient way of accumulating LLVM statements and declarations.
+data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl]
+
+instance Semigroup LlvmAccum where
+  LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB =
+        LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB)
+
+instance Monoid LlvmAccum where
+    mempty = LlvmAccum nilOL []
+    mappend = (Semigroup.<>)
+
+liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar
+liftExprData action = do
+    (var, stmts, decls) <- lift action
+    tell $ LlvmAccum stmts decls
+    return var
+
+statement :: LlvmStatement -> WriterT LlvmAccum LlvmM ()
+statement stmt = tell $ LlvmAccum (unitOL stmt) []
+
+doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar
+doExprW a b = do
+    (var, stmt) <- lift $ doExpr a b
+    statement stmt
+    return var
+
+exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar
+exprToVarW = liftExprData . exprToVar
+
+runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData
+runExprData action = do
+    (var, LlvmAccum stmts decls) <- runWriterT action
+    return (var, stmts, decls)
+
+runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])
+runStmtsDecls action = do
+    LlvmAccum stmts decls <- execWriterT action
+    return (stmts, decls)
+
+getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar
+getCmmRegW = lift . getCmmReg
+
+genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar
+genLoadW atomic e ty = liftExprData $ genLoad atomic e ty
+
+doTrashStmts :: WriterT LlvmAccum LlvmM ()
+doTrashStmts = do
+    stmts <- lift getTrashStmts
+    tell $ LlvmAccum stmts mempty
+
+-- | Return element of single-element list; 'panic' if list is not a single-element list
+singletonPanic :: String -> [a] -> a
+singletonPanic _ [x] = x
+singletonPanic s _ = panic s
diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -0,0 +1,164 @@
+{-# LANGUAGE CPP #-}
+-- ----------------------------------------------------------------------------
+-- | Handle conversion of CmmData to LLVM code.
+--
+
+module LlvmCodeGen.Data (
+        genLlvmData, genData
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Llvm
+import LlvmCodeGen.Base
+
+import BlockId
+import CLabel
+import Cmm
+import DynFlags
+import Platform
+
+import FastString
+import Outputable
+
+-- ----------------------------------------------------------------------------
+-- * Constants
+--
+
+-- | The string appended to a variable name to create its structure type alias
+structStr :: LMString
+structStr = fsLit "_struct"
+
+-- ----------------------------------------------------------------------------
+-- * Top level
+--
+
+-- | Pass a CmmStatic section to an equivalent Llvm code.
+genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData
+genLlvmData (sec, Statics lbl xs) = do
+    label <- strCLabel_llvm lbl
+    static <- mapM genData xs
+    lmsec <- llvmSection sec
+    let types   = map getStatType static
+
+        strucTy = LMStruct types
+        tyAlias = LMAlias ((label `appendFS` structStr), strucTy)
+
+        struct         = Just $ LMStaticStruc static tyAlias
+        link           = if (externallyVisibleCLabel lbl)
+                            then ExternallyVisible else Internal
+        align          = case sec of
+                            Section CString _ -> Just 1
+                            _                 -> Nothing
+        const          = if isSecConstant sec then Constant else Global
+        varDef         = LMGlobalVar label tyAlias link lmsec align const
+        globDef        = LMGlobal varDef struct
+
+    return ([globDef], [tyAlias])
+
+-- | Format the section type part of a Cmm Section
+llvmSectionType :: Platform -> SectionType -> FastString
+llvmSectionType p t = case t of
+    Text                    -> fsLit ".text"
+    ReadOnlyData            -> case platformOS p of
+                                 OSMinGW32 -> fsLit ".rdata"
+                                 _         -> fsLit ".rodata"
+    RelocatableReadOnlyData -> case platformOS p of
+                                 OSMinGW32 -> fsLit ".rdata$rel.ro"
+                                 _         -> fsLit ".data.rel.ro"
+    ReadOnlyData16          -> case platformOS p of
+                                 OSMinGW32 -> fsLit ".rdata$cst16"
+                                 _         -> fsLit ".rodata.cst16"
+    Data                    -> fsLit ".data"
+    UninitialisedData       -> fsLit ".bss"
+    CString                 -> case platformOS p of
+                                 OSMinGW32 -> fsLit ".rdata$str"
+                                 _         -> fsLit ".rodata.str"
+    (OtherSection _)        -> panic "llvmSectionType: unknown section type"
+
+-- | Format a Cmm Section into a LLVM section name
+llvmSection :: Section -> LlvmM LMSection
+llvmSection (Section t suffix) = do
+  dflags <- getDynFlags
+  let splitSect = gopt Opt_SplitSections dflags
+      platform  = targetPlatform dflags
+  if not splitSect
+  then return Nothing
+  else do
+    lmsuffix <- strCLabel_llvm suffix
+    let result sep = Just (concatFS [llvmSectionType platform t
+                                    , fsLit sep, lmsuffix])
+    case platformOS platform of
+      OSMinGW32 -> return (result "$")
+      _         -> return (result ".")
+
+-- ----------------------------------------------------------------------------
+-- * Generate static data
+--
+
+-- | Handle static data
+genData :: CmmStatic -> LlvmM LlvmStatic
+
+genData (CmmString str) = do
+    let v  = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) str
+        ve = v ++ [LMStaticLit $ LMIntLit 0 i8]
+    return $ LMStaticArray ve (LMArray (length ve) i8)
+
+genData (CmmUninitialised bytes)
+    = return $ LMUninitType (LMArray bytes i8)
+
+genData (CmmStaticLit lit)
+    = genStaticLit lit
+
+-- | Generate Llvm code for a static literal.
+--
+-- Will either generate the code or leave it unresolved if it is a 'CLabel'
+-- which isn't yet known.
+genStaticLit :: CmmLit -> LlvmM LlvmStatic
+genStaticLit (CmmInt i w)
+    = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w))
+
+genStaticLit (CmmFloat r w)
+    = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w))
+
+genStaticLit (CmmVec ls)
+    = do sls <- mapM toLlvmLit ls
+         return $ LMStaticLit (LMVectorLit sls)
+  where
+    toLlvmLit :: CmmLit -> LlvmM LlvmLit
+    toLlvmLit lit = do
+      slit <- genStaticLit lit
+      case slit of
+        LMStaticLit llvmLit -> return llvmLit
+        _ -> panic "genStaticLit"
+
+-- Leave unresolved, will fix later
+genStaticLit cmm@(CmmLabel l) = do
+    var <- getGlobalPtr =<< strCLabel_llvm l
+    dflags <- getDynFlags
+    let ptr = LMStaticPointer var
+        lmty = cmmToLlvmType $ cmmLitType dflags cmm
+    return $ LMPtoI ptr lmty
+
+genStaticLit (CmmLabelOff label off) = do
+    dflags <- getDynFlags
+    var <- genStaticLit (CmmLabel label)
+    let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
+    return $ LMAdd var offset
+
+genStaticLit (CmmLabelDiffOff l1 l2 off w) = do
+    dflags <- getDynFlags
+    var1 <- genStaticLit (CmmLabel l1)
+    var2 <- genStaticLit (CmmLabel l2)
+    let var
+          | w == wordWidth dflags = LMSub var1 var2
+          | otherwise = LMTrunc (LMSub var1 var2) (widthToLlvmInt w)
+        offset = LMStaticLit $ LMIntLit (toInteger off) (LMInt $ widthInBits w)
+    return $ LMAdd var offset
+
+genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b
+
+genStaticLit (CmmHighStackMark)
+    = panic "genStaticLit: CmmHighStackMark unsupported!"
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE CPP #-}
+
+-- ----------------------------------------------------------------------------
+-- | Pretty print helpers for the LLVM Code generator.
+--
+module LlvmCodeGen.Ppr (
+        pprLlvmCmmDecl, pprLlvmData, infoSection
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Llvm
+import LlvmCodeGen.Base
+import LlvmCodeGen.Data
+
+import CLabel
+import Cmm
+
+import FastString
+import Outputable
+import Unique
+
+-- ----------------------------------------------------------------------------
+-- * Top level
+--
+
+-- | Pretty print LLVM data code
+pprLlvmData :: LlvmData -> SDoc
+pprLlvmData (globals, types) =
+    let ppLlvmTys (LMAlias    a) = ppLlvmAlias a
+        ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f
+        ppLlvmTys _other         = empty
+
+        types'   = vcat $ map ppLlvmTys types
+        globals' = ppLlvmGlobals globals
+    in types' $+$ globals'
+
+
+-- | Pretty print LLVM code
+pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
+pprLlvmCmmDecl (CmmData _ lmdata)
+  = return (vcat $ map pprLlvmData lmdata, [])
+
+pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
+  = do let lbl = case mb_info of
+                     Nothing                   -> entry_lbl
+                     Just (Statics info_lbl _) -> info_lbl
+           link = if externallyVisibleCLabel lbl
+                      then ExternallyVisible
+                      else Internal
+           lmblocks = map (\(BasicBlock id stmts) ->
+                                LlvmBlock (getUnique id) stmts) blks
+
+       funDec <- llvmFunSig live lbl link
+       dflags <- getDynFlags
+       let buildArg = fsLit . showSDoc dflags . ppPlainName
+           funArgs = map buildArg (llvmFunArgs dflags live)
+           funSect = llvmFunSection dflags (decName funDec)
+
+       -- generate the info table
+       prefix <- case mb_info of
+                     Nothing -> return Nothing
+                     Just (Statics _ statics) -> do
+                       infoStatics <- mapM genData statics
+                       let infoTy = LMStruct $ map getStatType infoStatics
+                       return $ Just $ LMStaticStruc infoStatics infoTy
+
+
+       let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect
+                              prefix lmblocks
+           name = decName $ funcDecl fun
+           defName = name `appendFS` fsLit "$def"
+           funcDecl' = (funcDecl fun) { decName = defName }
+           fun' = fun { funcDecl = funcDecl' }
+           funTy = LMFunction funcDecl'
+           funVar = LMGlobalVar name
+                                (LMPointer funTy)
+                                link
+                                Nothing
+                                Nothing
+                                Alias
+           defVar = LMGlobalVar defName
+                                (LMPointer funTy)
+                                (funcLinkage funcDecl')
+                                (funcSect fun)
+                                (funcAlign funcDecl')
+                                Alias
+           alias = LMGlobal funVar
+                            (Just $ LMBitc (LMStaticPointer defVar)
+                                           i8Ptr)
+
+       return (ppLlvmGlobal alias $+$ ppLlvmFunction fun', [])
+
+
+-- | The section we are putting info tables and their entry code into, should
+-- be unique since we process the assembly pattern matching this.
+infoSection :: String
+infoSection = "X98A__STRIP,__me"
diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs
@@ -0,0 +1,136 @@
+{-# LANGUAGE CPP #-}
+
+--------------------------------------------------------------------------------
+-- | Deal with Cmm registers
+--
+
+module LlvmCodeGen.Regs (
+        lmGlobalRegArg, lmGlobalRegVar, alwaysLive,
+        stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Llvm
+
+import CmmExpr
+import DynFlags
+import FastString
+import Outputable ( panic )
+import Unique
+
+-- | Get the LlvmVar function variable storing the real register
+lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar
+lmGlobalRegVar dflags = pVarLift . lmGlobalReg dflags "_Var"
+
+-- | Get the LlvmVar function argument storing the real register
+lmGlobalRegArg :: DynFlags -> GlobalReg -> LlvmVar
+lmGlobalRegArg dflags = lmGlobalReg dflags "_Arg"
+
+{- Need to make sure the names here can't conflict with the unique generated
+   names. Uniques generated names containing only base62 chars. So using say
+   the '_' char guarantees this.
+-}
+lmGlobalReg :: DynFlags -> String -> GlobalReg -> LlvmVar
+lmGlobalReg dflags suf reg
+  = case reg of
+        BaseReg        -> ptrGlobal $ "Base" ++ suf
+        Sp             -> ptrGlobal $ "Sp" ++ suf
+        Hp             -> ptrGlobal $ "Hp" ++ suf
+        VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf
+        VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf
+        VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf
+        VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf
+        VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf
+        VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf
+        VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf
+        VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf
+        SpLim          -> wordGlobal $ "SpLim" ++ suf
+        FloatReg 1     -> floatGlobal $"F1" ++ suf
+        FloatReg 2     -> floatGlobal $"F2" ++ suf
+        FloatReg 3     -> floatGlobal $"F3" ++ suf
+        FloatReg 4     -> floatGlobal $"F4" ++ suf
+        FloatReg 5     -> floatGlobal $"F5" ++ suf
+        FloatReg 6     -> floatGlobal $"F6" ++ suf
+        DoubleReg 1    -> doubleGlobal $ "D1" ++ suf
+        DoubleReg 2    -> doubleGlobal $ "D2" ++ suf
+        DoubleReg 3    -> doubleGlobal $ "D3" ++ suf
+        DoubleReg 4    -> doubleGlobal $ "D4" ++ suf
+        DoubleReg 5    -> doubleGlobal $ "D5" ++ suf
+        DoubleReg 6    -> doubleGlobal $ "D6" ++ suf
+        XmmReg 1       -> xmmGlobal $ "XMM1" ++ suf
+        XmmReg 2       -> xmmGlobal $ "XMM2" ++ suf
+        XmmReg 3       -> xmmGlobal $ "XMM3" ++ suf
+        XmmReg 4       -> xmmGlobal $ "XMM4" ++ suf
+        XmmReg 5       -> xmmGlobal $ "XMM5" ++ suf
+        XmmReg 6       -> xmmGlobal $ "XMM6" ++ suf
+        YmmReg 1       -> ymmGlobal $ "YMM1" ++ suf
+        YmmReg 2       -> ymmGlobal $ "YMM2" ++ suf
+        YmmReg 3       -> ymmGlobal $ "YMM3" ++ suf
+        YmmReg 4       -> ymmGlobal $ "YMM4" ++ suf
+        YmmReg 5       -> ymmGlobal $ "YMM5" ++ suf
+        YmmReg 6       -> ymmGlobal $ "YMM6" ++ suf
+        ZmmReg 1       -> zmmGlobal $ "ZMM1" ++ suf
+        ZmmReg 2       -> zmmGlobal $ "ZMM2" ++ suf
+        ZmmReg 3       -> zmmGlobal $ "ZMM3" ++ suf
+        ZmmReg 4       -> zmmGlobal $ "ZMM4" ++ suf
+        ZmmReg 5       -> zmmGlobal $ "ZMM5" ++ suf
+        ZmmReg 6       -> zmmGlobal $ "ZMM6" ++ suf
+        MachSp         -> wordGlobal $ "MachSp" ++ suf
+        _other         -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg)
+                                ++ ") not supported!"
+        -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc
+        -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg
+    where
+        wordGlobal   name = LMNLocalVar (fsLit name) (llvmWord dflags)
+        ptrGlobal    name = LMNLocalVar (fsLit name) (llvmWordPtr dflags)
+        floatGlobal  name = LMNLocalVar (fsLit name) LMFloat
+        doubleGlobal name = LMNLocalVar (fsLit name) LMDouble
+        xmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 4 (LMInt 32))
+        ymmGlobal    name = LMNLocalVar (fsLit name) (LMVector 8 (LMInt 32))
+        zmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 16 (LMInt 32))
+
+-- | A list of STG Registers that should always be considered alive
+alwaysLive :: [GlobalReg]
+alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node]
+
+-- | STG Type Based Alias Analysis hierarchy
+stgTBAA :: [(Unique, LMString, Maybe Unique)]
+stgTBAA
+  = [ (rootN,  fsLit "root",   Nothing)
+    , (topN,   fsLit "top",   Just rootN)
+    , (stackN, fsLit "stack", Just topN)
+    , (heapN,  fsLit "heap",  Just topN)
+    , (rxN,    fsLit "rx",    Just heapN)
+    , (baseN,  fsLit "base",  Just topN)
+    -- FIX: Not 100% sure if this hierarchy is complete.  I think the big thing
+    -- is Sp is never aliased, so might want to change the hierarchy to have Sp
+    -- on its own branch that is never aliased (e.g never use top as a TBAA
+    -- node).
+    ]
+
+-- | Id values
+-- The `rootN` node is the root (there can be more than one) of the TBAA
+-- hierarchy and as of LLVM 4.0 should *only* be referenced by other nodes. It
+-- should never occur in any LLVM instruction statement.
+rootN, topN, stackN, heapN, rxN, baseN :: Unique
+rootN  = getUnique (fsLit "LlvmCodeGen.Regs.rootN")
+topN   = getUnique (fsLit "LlvmCodeGen.Regs.topN")
+stackN = getUnique (fsLit "LlvmCodeGen.Regs.stackN")
+heapN  = getUnique (fsLit "LlvmCodeGen.Regs.heapN")
+rxN    = getUnique (fsLit "LlvmCodeGen.Regs.rxN")
+baseN  = getUnique (fsLit "LlvmCodeGen.Regs.baseN")
+
+-- | The TBAA metadata identifier
+tbaa :: LMString
+tbaa = fsLit "tbaa"
+
+-- | Get the correct TBAA metadata information for this register type
+getTBAA :: GlobalReg -> Unique
+getTBAA BaseReg          = baseN
+getTBAA Sp               = stackN
+getTBAA Hp               = heapN
+getTBAA (VanillaReg _ _) = rxN
+getTBAA _                = topN
diff --git a/compiler/llvmGen/LlvmMangler.hs b/compiler/llvmGen/LlvmMangler.hs
new file mode 100644
--- /dev/null
+++ b/compiler/llvmGen/LlvmMangler.hs
@@ -0,0 +1,129 @@
+-- -----------------------------------------------------------------------------
+-- | GHC LLVM Mangler
+--
+-- This script processes the assembly produced by LLVM, rewriting all symbols
+-- of type @function to @object. This keeps them from going through the PLT,
+-- which would be bad due to tables-next-to-code. On x86_64,
+-- it also rewrites AVX instructions that require alignment to their
+-- unaligned counterparts, since the stack is only 16-byte aligned but these
+-- instructions require 32-byte alignment.
+--
+
+module LlvmMangler ( llvmFixupAsm ) where
+
+import GhcPrelude
+
+import DynFlags ( DynFlags, targetPlatform )
+import Platform ( platformArch, Arch(..) )
+import ErrUtils ( withTiming )
+import Outputable ( text )
+
+import Control.Exception
+import qualified Data.ByteString.Char8 as B
+import System.IO
+
+-- | Read in assembly file and process
+llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()
+llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-}
+    withTiming (pure dflags) (text "LLVM Mangler") id $
+    withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do
+        go r w
+        hClose r
+        hClose w
+        return ()
+  where
+    go :: Handle -> Handle -> IO ()
+    go r w = do
+      e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString)
+      let writeline a = B.hPutStrLn w (rewriteLine dflags rewrites a) >> go r w
+      case e_l of
+        Right l -> writeline l
+        Left _  -> return ()
+
+-- | These are the rewrites that the mangler will perform
+rewrites :: [Rewrite]
+rewrites = [rewriteSymType, rewriteAVX]
+
+type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString
+
+-- | Rewrite a line of assembly source with the given rewrites,
+-- taking the first rewrite that applies.
+rewriteLine :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString
+rewriteLine dflags rewrites l
+  -- We disable .subsections_via_symbols on darwin and ios, as the llvm code
+  -- gen uses prefix data for the info table.  This however does not prevent
+  -- llvm from generating .subsections_via_symbols, which in turn with
+  -- -dead_strip, strips the info tables, and therefore breaks ghc.
+  | isSubsectionsViaSymbols l =
+    (B.pack "## no .subsection_via_symbols for ghc. We need our info tables!")
+  | otherwise =
+    case firstJust $ map (\rewrite -> rewrite dflags rest) rewrites of
+      Nothing        -> l
+      Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten]
+  where
+    isSubsectionsViaSymbols = B.isPrefixOf (B.pack ".subsections_via_symbols")
+
+    (symbol, rest) = splitLine l
+
+    firstJust :: [Maybe a] -> Maybe a
+    firstJust (Just x:_) = Just x
+    firstJust []         = Nothing
+    firstJust (_:rest)   = firstJust rest
+
+-- | This rewrites @.type@ annotations of function symbols to @%object@.
+-- This is done as the linker can relocate @%functions@ through the
+-- Procedure Linking Table (PLT). This is bad since we expect that the
+-- info table will appear directly before the symbol's location. In the
+-- case that the PLT is used, this will be not an info table but instead
+-- some random PLT garbage.
+rewriteSymType :: Rewrite
+rewriteSymType _ l
+  | isType l  = Just $ rewrite '@' $ rewrite '%' l
+  | otherwise = Nothing
+  where
+    isType = B.isPrefixOf (B.pack ".type")
+
+    rewrite :: Char -> B.ByteString -> B.ByteString
+    rewrite prefix = replaceOnce funcType objType
+      where
+        funcType = prefix `B.cons` B.pack "function"
+        objType  = prefix `B.cons` B.pack "object"
+
+-- | This rewrites aligned AVX instructions to their unaligned counterparts on
+-- x86-64. This is necessary because the stack is not adequately aligned for
+-- aligned AVX spills, so LLVM would emit code that adjusts the stack pointer
+-- and disable tail call optimization. Both would be catastrophic here so GHC
+-- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then
+-- rewrites the instructions in the mangler.
+rewriteAVX :: Rewrite
+rewriteAVX dflags s
+  | not isX86_64 = Nothing
+  | isVmovdqa s  = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s
+  | isVmovap s   = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s
+  | otherwise    = Nothing
+  where
+    isX86_64 = platformArch (targetPlatform dflags) == ArchX86_64
+    isVmovdqa = B.isPrefixOf (B.pack "vmovdqa")
+    isVmovap = B.isPrefixOf (B.pack "vmovap")
+
+-- | @replaceOnce match replace bs@ replaces the first occurrence of the
+-- substring @match@ in @bs@ with @replace@.
+replaceOnce :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
+replaceOnce matchBS replaceOnceBS = loop
+  where
+    loop :: B.ByteString -> B.ByteString
+    loop cts =
+        case B.breakSubstring matchBS cts of
+          (hd,tl) | B.null tl -> hd
+                  | otherwise -> hd `B.append` replaceOnceBS `B.append`
+                                 B.drop (B.length matchBS) tl
+
+-- | This function splits a line of assembly code into the label and the
+-- rest of the code.
+splitLine :: B.ByteString -> (B.ByteString, B.ByteString)
+splitLine l = (symbol, B.dropWhile isSpace rest)
+  where
+    isSpace ' ' = True
+    isSpace '\t' = True
+    isSpace _ = False
+    (symbol, rest) = B.span (not . isSpace) l
diff --git a/compiler/main/Ar.hs b/compiler/main/Ar.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/Ar.hs
@@ -0,0 +1,268 @@
+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-}
+{- Note: [The need for Ar.hs]
+Building `-staticlib` required the presence of libtool, and was a such
+restricted to mach-o only. As libtool on macOS and gnu libtool are very
+different, there was no simple portable way to support this.
+
+libtool for static archives does essentially: concatinate the input archives,
+add the input objects, and create a symbol index. Using `ar` for this task
+fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same
+features across platforms (e.g. index prefixed retrieval of objects with
+the same name.)
+
+As Archives are rather simple structurally, we can just build the archives
+with Haskell directly and use ranlib on the final result to get the symbol
+index. This should allow us to work around with the differences/abailability
+of libtool across differet platforms.
+-}
+module Ar
+  (ArchiveEntry(..)
+  ,Archive(..)
+  ,afilter
+
+  ,parseAr
+
+  ,loadAr
+  ,loadObj
+  ,writeBSDAr
+  ,writeGNUAr
+
+  ,isBSDSymdef
+  ,isGNUSymdef
+  )
+   where
+
+import GhcPrelude
+
+import Data.List (mapAccumL, isPrefixOf)
+import Data.Monoid ((<>))
+import Data.Binary.Get
+import Data.Binary.Put
+import Control.Monad
+import Control.Applicative
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString.Lazy as L
+#if !defined(mingw32_HOST_OS)
+import qualified System.Posix.Files as POSIX
+#endif
+import System.FilePath (takeFileName)
+
+data ArchiveEntry = ArchiveEntry
+    { filename :: String       -- ^ File name.
+    , filetime :: Int          -- ^ File modification time.
+    , fileown  :: Int          -- ^ File owner.
+    , filegrp  :: Int          -- ^ File group.
+    , filemode :: Int          -- ^ File mode.
+    , filesize :: Int          -- ^ File size.
+    , filedata :: B.ByteString -- ^ File bytes.
+    } deriving (Eq, Show)
+
+newtype Archive = Archive [ArchiveEntry]
+        deriving (Eq, Show, Semigroup, Monoid)
+
+afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive
+afilter f (Archive xs) = Archive (filter f xs)
+
+isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool
+isBSDSymdef a = "__.SYMDEF" `isPrefixOf` (filename a)
+isGNUSymdef a = "/" == (filename a)
+
+-- | Archives have numeric values padded with '\x20' to the right.
+getPaddedInt :: B.ByteString -> Int
+getPaddedInt = read . C.unpack . C.takeWhile (/= '\x20')
+
+putPaddedInt :: Int -> Int -> Put
+putPaddedInt padding i = putPaddedString '\x20' padding (show i)
+
+putPaddedString :: Char -> Int -> String -> Put
+putPaddedString pad padding s = putByteString . C.pack . take padding $ s `mappend` (repeat pad)
+
+getBSDArchEntries :: Get [ArchiveEntry]
+getBSDArchEntries = do
+    empty <- isEmpty
+    if empty then
+        return []
+     else do
+        name    <- getByteString 16
+        when ('/' `C.elem` name && C.take 3 name /= "#1/") $
+          fail "Looks like GNU Archive"
+        time    <- getPaddedInt <$> getByteString 12
+        own     <- getPaddedInt <$> getByteString 6
+        grp     <- getPaddedInt <$> getByteString 6
+        mode    <- getPaddedInt <$> getByteString 8
+        st_size <- getPaddedInt <$> getByteString 10
+        end     <- getByteString 2
+        when (end /= "\x60\x0a") $
+          fail ("[BSD Archive] Invalid archive header end marker for name: " ++
+                C.unpack name)
+        off1    <- liftM fromIntegral bytesRead :: Get Int
+        -- BSD stores extended filenames, by writing #1/<length> into the
+        -- name field, the first @length@ bytes then represent the file name
+        -- thus the payload size is filesize + file name length.
+        name    <- if C.unpack (C.take 3 name) == "#1/" then
+                        liftM (C.unpack . C.takeWhile (/= '\0')) (getByteString $ read $ C.unpack $ C.drop 3 name)
+                    else
+                        return $ C.unpack $ C.takeWhile (/= ' ') name
+        off2    <- liftM fromIntegral bytesRead :: Get Int
+        file    <- getByteString (st_size - (off2 - off1))
+        -- data sections are two byte aligned (see Trac #15396)
+        when (odd st_size) $
+          void (getByteString 1)
+
+        rest    <- getBSDArchEntries
+        return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest
+
+-- | GNU Archives feature a special '//' entry that contains the
+-- extended names. Those are referred to as /<num>, where num is the
+-- offset into the '//' entry.
+-- In addition, filenames are terminated with '/' in the archive.
+getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry]
+getGNUArchEntries extInfo = do
+  empty <- isEmpty
+  if empty
+    then return []
+    else
+    do
+      name    <- getByteString 16
+      time    <- getPaddedInt <$> getByteString 12
+      own     <- getPaddedInt <$> getByteString 6
+      grp     <- getPaddedInt <$> getByteString 6
+      mode    <- getPaddedInt <$> getByteString 8
+      st_size <- getPaddedInt <$> getByteString 10
+      end     <- getByteString 2
+      when (end /= "\x60\x0a") $
+        fail ("[BSD Archive] Invalid archive header end marker for name: " ++
+              C.unpack name)
+      file <- getByteString st_size
+      -- data sections are two byte aligned (see Trac #15396)
+      when (odd st_size) $
+        void (getByteString 1)
+      name <- return . C.unpack $
+        if C.unpack (C.take 1 name) == "/"
+        then case C.takeWhile (/= ' ') name of
+               name@"/"  -> name               -- symbol table
+               name@"//" -> name               -- extendedn file names table
+               name      -> getExtName extInfo (read . C.unpack $ C.drop 1 name)
+        else C.takeWhile (/= '/') name
+      case name of
+        "/"  -> getGNUArchEntries extInfo
+        "//" -> getGNUArchEntries (Just (ArchiveEntry name time own grp mode st_size file))
+        _    -> (ArchiveEntry name time own grp mode st_size file :) <$> getGNUArchEntries extInfo
+
+  where
+   getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString
+   getExtName Nothing _ = error "Invalid extended filename reference."
+   getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info
+
+-- | put an Archive Entry. This assumes that the entries
+-- have been preprocessed to account for the extenden file name
+-- table section "//" e.g. for GNU Archives. Or that the names
+-- have been move into the payload for BSD Archives.
+putArchEntry :: ArchiveEntry -> PutM ()
+putArchEntry (ArchiveEntry name time own grp mode st_size file) = do
+  putPaddedString ' '  16 name
+  putPaddedInt         12 time
+  putPaddedInt          6 own
+  putPaddedInt          6 grp
+  putPaddedInt          8 mode
+  putPaddedInt         10 (st_size + pad)
+  putByteString           "\x60\x0a"
+  putByteString           file
+  when (pad == 1) $
+    putWord8              0x0a
+  where
+    pad         = st_size `mod` 2
+
+getArchMagic :: Get ()
+getArchMagic = do
+  magic <- liftM C.unpack $ getByteString 8
+  if magic /= "!<arch>\n"
+    then fail $ "Invalid magic number " ++ show magic
+    else return ()
+
+putArchMagic :: Put
+putArchMagic = putByteString $ C.pack "!<arch>\n"
+
+getArch :: Get Archive
+getArch = Archive <$> do
+  getArchMagic
+  getBSDArchEntries <|> getGNUArchEntries Nothing
+
+putBSDArch :: Archive -> PutM ()
+putBSDArch (Archive as) = do
+  putArchMagic
+  mapM_ putArchEntry (processEntries as)
+
+  where
+    padStr pad size str = take size $ str <> repeat pad
+    nameSize name = case length name `divMod` 4 of
+      (n, 0) -> 4 * n
+      (n, _) -> 4 * (n + 1)
+    needExt name = length name > 16 || ' ' `elem` name
+    processEntry :: ArchiveEntry -> ArchiveEntry
+    processEntry archive@(ArchiveEntry name _ _ _ _ st_size _)
+      | needExt name = archive { filename = "#1/" <> show sz
+                               , filedata = C.pack (padStr '\0' sz name) <> filedata archive
+                               , filesize = st_size + sz }
+      | otherwise    = archive
+
+      where sz = nameSize name
+
+    processEntries = map processEntry
+
+putGNUArch :: Archive -> PutM ()
+putGNUArch (Archive as) = do
+  putArchMagic
+  mapM_ putArchEntry (processEntries as)
+
+  where
+    processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry)
+    processEntry extInfo archive@(ArchiveEntry name _ _ _ _ _ _)
+      | length name > 15 = ( extInfo { filesize = filesize extInfo + length name + 2
+                                    ,  filedata = filedata extInfo <>  C.pack name <> "/\n" }
+                           , archive { filename = "/" <> show (filesize extInfo) } )
+      | otherwise        = ( extInfo, archive { filename = name <> "/" } )
+
+    processEntries :: [ArchiveEntry] -> [ArchiveEntry]
+    processEntries =
+      uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty)
+
+parseAr :: B.ByteString -> Archive
+parseAr = runGet getArch . L.fromChunks . pure
+
+writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO ()
+writeBSDAr fp = L.writeFile fp . runPut . putBSDArch
+writeGNUAr fp = L.writeFile fp . runPut . putGNUArch
+
+loadAr :: FilePath -> IO Archive
+loadAr fp = parseAr <$> B.readFile fp
+
+loadObj :: FilePath -> IO ArchiveEntry
+loadObj fp = do
+  payload <- B.readFile fp
+  (modt, own, grp, mode) <- fileInfo fp
+  return $ ArchiveEntry
+    (takeFileName fp) modt own grp mode
+    (B.length payload) payload
+
+-- | Take a filePath and return (mod time, own, grp, mode in decimal)
+fileInfo :: FilePath -> IO ( Int, Int, Int, Int) -- ^ mod time, own, grp, mode (in decimal)
+#if defined(mingw32_HOST_OS)
+-- on windows mod time, owner group and mode are zero.
+fileInfo _ = pure (0,0,0,0)
+#else
+fileInfo fp = go <$> POSIX.getFileStatus fp
+  where go status = ( fromEnum $ POSIX.modificationTime status
+                    , fromIntegral $ POSIX.fileOwner status
+                    , fromIntegral $ POSIX.fileGroup status
+                    , oct2dec . fromIntegral $ POSIX.fileMode status
+                    )
+
+oct2dec :: Int -> Int
+oct2dec = foldl' (\a b -> a * 10 + b) 0 . reverse . dec 8
+  where dec _ 0 = []
+        dec b i = let (rest, last) = i `quotRem` b
+                  in last:dec b rest
+
+#endif
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/CodeOutput.hs
@@ -0,0 +1,267 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+\section{Code output phase}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module CodeOutput( codeOutput, outputForeignStubs ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import AsmCodeGen ( nativeCodeGen )
+import LlvmCodeGen ( llvmCodeGen )
+
+import UniqSupply       ( mkSplitUniqSupply )
+
+import Finder           ( mkStubPaths )
+import PprC             ( writeCs )
+import CmmLint          ( cmmLint )
+import Packages
+import Cmm              ( RawCmmGroup )
+import HscTypes
+import DynFlags
+import Config
+import Stream           (Stream)
+import qualified Stream
+import FileCleanup
+
+import ErrUtils
+import Outputable
+import Module
+import SrcLoc
+
+import Control.Exception
+import System.Directory
+import System.FilePath
+import System.IO
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Steering}
+*                                                                      *
+************************************************************************
+-}
+
+codeOutput :: DynFlags
+           -> Module
+           -> FilePath
+           -> ModLocation
+           -> ForeignStubs
+           -> [(ForeignSrcLang, FilePath)]
+           -- ^ additional files to be compiled with with the C compiler
+           -> [InstalledUnitId]
+           -> Stream IO RawCmmGroup ()                       -- Compiled C--
+           -> IO (FilePath,
+                  (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),
+                  [(ForeignSrcLang, FilePath)]{-foreign_fps-})
+
+codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps
+  cmm_stream
+  =
+    do  {
+        -- Lint each CmmGroup as it goes past
+        ; let linted_cmm_stream =
+                 if gopt Opt_DoCmmLinting dflags
+                    then Stream.mapM do_lint cmm_stream
+                    else cmm_stream
+
+              do_lint cmm = withTiming (pure dflags)
+                                       (text "CmmLint"<+>brackets (ppr this_mod))
+                                       (const ()) $ do
+                { case cmmLint dflags cmm of
+                        Just err -> do { log_action dflags
+                                                   dflags
+                                                   NoReason
+                                                   SevDump
+                                                   noSrcSpan
+                                                   (defaultDumpStyle dflags)
+                                                   err
+                                       ; ghcExit dflags 1
+                                       }
+                        Nothing  -> return ()
+                ; return cmm
+                }
+
+        ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs
+        ; case hscTarget dflags of {
+             HscAsm         -> outputAsm dflags this_mod location filenm
+                                         linted_cmm_stream;
+             HscC           -> outputC dflags filenm linted_cmm_stream pkg_deps;
+             HscLlvm        -> outputLlvm dflags filenm linted_cmm_stream;
+             HscInterpreted -> panic "codeOutput: HscInterpreted";
+             HscNothing     -> panic "codeOutput: HscNothing"
+          }
+        ; return (filenm, stubs_exist, foreign_fps)
+        }
+
+doOutput :: String -> (Handle -> IO a) -> IO a
+doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{C}
+*                                                                      *
+************************************************************************
+-}
+
+outputC :: DynFlags
+        -> FilePath
+        -> Stream IO RawCmmGroup ()
+        -> [InstalledUnitId]
+        -> IO ()
+
+outputC dflags filenm cmm_stream packages
+  = do
+       -- ToDo: make the C backend consume the C-- incrementally, by
+       -- pushing the cmm_stream inside (c.f. nativeCodeGen)
+       rawcmms <- Stream.collect cmm_stream
+
+       -- figure out which header files to #include in the generated .hc file:
+       --
+       --   * extra_includes from packages
+       --   * -#include options from the cmdline and OPTIONS pragmas
+       --   * the _stub.h file, if there is one.
+       --
+       let rts = getPackageDetails dflags rtsUnitId
+
+       let cc_injects = unlines (map mk_include (includes rts))
+           mk_include h_file =
+            case h_file of
+               '"':_{-"-} -> "#include "++h_file
+               '<':_      -> "#include "++h_file
+               _          -> "#include \""++h_file++"\""
+
+       let pkg_names = map installedUnitIdString packages
+
+       doOutput filenm $ \ h -> do
+          hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")
+          hPutStr h cc_injects
+          writeCs dflags h rawcmms
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Assembler}
+*                                                                      *
+************************************************************************
+-}
+
+outputAsm :: DynFlags -> Module -> ModLocation -> FilePath
+          -> Stream IO RawCmmGroup ()
+          -> IO ()
+outputAsm dflags this_mod location filenm cmm_stream
+ | cGhcWithNativeCodeGen == "YES"
+  = do ncg_uniqs <- mkSplitUniqSupply 'n'
+
+       debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm)
+
+       _ <- {-# SCC "OutputAsm" #-} doOutput filenm $
+           \h -> {-# SCC "NativeCodeGen" #-}
+                 nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream
+       return ()
+
+ | otherwise
+  = panic "This compiler was built without a native code generator"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{LLVM}
+*                                                                      *
+************************************************************************
+-}
+
+outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()
+outputLlvm dflags filenm cmm_stream
+  = do ncg_uniqs <- mkSplitUniqSupply 'n'
+
+       {-# SCC "llvm_output" #-} doOutput filenm $
+           \f -> {-# SCC "llvm_CodeGen" #-}
+                 llvmCodeGen dflags f ncg_uniqs cmm_stream
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Foreign import/export}
+*                                                                      *
+************************************************************************
+-}
+
+outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
+                   -> IO (Bool,         -- Header file created
+                          Maybe FilePath) -- C file created
+outputForeignStubs dflags mod location stubs
+ = do
+   let stub_h = mkStubPaths dflags (moduleName mod) location
+   stub_c <- newTempName dflags TFL_CurrentModule "c"
+
+   case stubs of
+     NoStubs ->
+        return (False, Nothing)
+
+     ForeignStubs h_code c_code -> do
+        let
+            stub_c_output_d = pprCode CStyle c_code
+            stub_c_output_w = showSDoc dflags stub_c_output_d
+
+            -- Header file protos for "foreign export"ed functions.
+            stub_h_output_d = pprCode CStyle h_code
+            stub_h_output_w = showSDoc dflags stub_h_output_d
+
+        createDirectoryIfMissing True (takeDirectory stub_h)
+
+        dumpIfSet_dyn dflags Opt_D_dump_foreign
+                      "Foreign export header file" stub_h_output_d
+
+        -- we need the #includes from the rts package for the stub files
+        let rts_includes =
+               let rts_pkg = getPackageDetails dflags rtsUnitId in
+               concatMap mk_include (includes rts_pkg)
+            mk_include i = "#include \"" ++ i ++ "\"\n"
+
+            -- wrapper code mentions the ffi_arg type, which comes from ffi.h
+            ffi_includes | cLibFFI   = "#include \"ffi.h\"\n"
+                         | otherwise = ""
+
+        stub_h_file_exists
+           <- outputForeignStubs_help stub_h stub_h_output_w
+                ("#include \"HsFFI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr
+
+        dumpIfSet_dyn dflags Opt_D_dump_foreign
+                      "Foreign export stubs" stub_c_output_d
+
+        stub_c_file_exists
+           <- outputForeignStubs_help stub_c stub_c_output_w
+                ("#define IN_STG_CODE 0\n" ++
+                 "#include \"Rts.h\"\n" ++
+                 rts_includes ++
+                 ffi_includes ++
+                 cplusplus_hdr)
+                 cplusplus_ftr
+           -- We're adding the default hc_header to the stub file, but this
+           -- isn't really HC code, so we need to define IN_STG_CODE==0 to
+           -- avoid the register variables etc. being enabled.
+
+        return (stub_h_file_exists, if stub_c_file_exists
+                                       then Just stub_c
+                                       else Nothing )
+ where
+   cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
+   cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
+
+
+-- Don't use doOutput for dumping the f. export stubs
+-- since it is more than likely that the stubs file will
+-- turn out to be empty, in which case no file should be created.
+outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool
+outputForeignStubs_help _fname ""      _header _footer = return False
+outputForeignStubs_help fname doc_str header footer
+   = do writeFile fname (header ++ doc_str ++ '\n':footer ++ "\n")
+        return True
+
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/DriverMkDepend.hs
@@ -0,0 +1,410 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Makefile Dependency Generation
+--
+-- (c) The University of Glasgow 2005
+--
+-----------------------------------------------------------------------------
+
+module DriverMkDepend (
+        doMkDependHS
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import qualified GHC
+import GhcMonad
+import DynFlags
+import Util
+import HscTypes
+import qualified SysTools
+import Module
+import Digraph          ( SCC(..) )
+import Finder
+import Outputable
+import Panic
+import SrcLoc
+import Data.List
+import FastString
+import FileCleanup
+
+import Exception
+import ErrUtils
+
+import System.Directory
+import System.FilePath
+import System.IO
+import System.IO.Error  ( isEOFError )
+import Control.Monad    ( when )
+import Data.Maybe       ( isJust )
+
+-----------------------------------------------------------------
+--
+--              The main function
+--
+-----------------------------------------------------------------
+
+doMkDependHS :: GhcMonad m => [FilePath] -> m ()
+doMkDependHS srcs = do
+    -- Initialisation
+    dflags0 <- GHC.getSessionDynFlags
+
+    -- We kludge things a bit for dependency generation. Rather than
+    -- generating dependencies for each way separately, we generate
+    -- them once and then duplicate them for each way's osuf/hisuf.
+    -- We therefore do the initial dependency generation with an empty
+    -- way and .o/.hi extensions, regardless of any flags that might
+    -- be specified.
+    let dflags = dflags0 {
+                     ways = [],
+                     buildTag = mkBuildTag [],
+                     hiSuf = "hi",
+                     objectSuf = "o"
+                 }
+    _ <- GHC.setSessionDynFlags dflags
+
+    when (null (depSuffixes dflags)) $ liftIO $
+        throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")
+
+    files <- liftIO $ beginMkDependHS dflags
+
+    -- Do the downsweep to find all the modules
+    targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs
+    GHC.setTargets targets
+    let excl_mods = depExcludeMods dflags
+    module_graph <- GHC.depanal excl_mods True {- Allow dup roots -}
+
+    -- Sort into dependency order
+    -- There should be no cycles
+    let sorted = GHC.topSortModuleGraph False module_graph Nothing
+
+    -- Print out the dependencies if wanted
+    liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted)
+
+    -- Prcess them one by one, dumping results into makefile
+    -- and complaining about cycles
+    hsc_env <- getSession
+    root <- liftIO getCurrentDirectory
+    mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted
+
+    -- If -ddump-mod-cycles, show cycles in the module graph
+    liftIO $ dumpModCycles dflags module_graph
+
+    -- Tidy up
+    liftIO $ endMkDependHS dflags files
+
+    -- Unconditional exiting is a bad idea.  If an error occurs we'll get an
+    --exception; if that is not caught it's fine, but at least we have a
+    --chance to find out exactly what went wrong.  Uncomment the following
+    --line if you disagree.
+
+    --`GHC.ghcCatch` \_ -> io $ exitWith (ExitFailure 1)
+
+-----------------------------------------------------------------
+--
+--              beginMkDependHs
+--      Create a temporary file,
+--      find the Makefile,
+--      slurp through it, etc
+--
+-----------------------------------------------------------------
+
+data MkDepFiles
+  = MkDep { mkd_make_file :: FilePath,          -- Name of the makefile
+            mkd_make_hdl  :: Maybe Handle,      -- Handle for the open makefile
+            mkd_tmp_file  :: FilePath,          -- Name of the temporary file
+            mkd_tmp_hdl   :: Handle }           -- Handle of the open temporary file
+
+beginMkDependHS :: DynFlags -> IO MkDepFiles
+beginMkDependHS dflags = do
+        -- open a new temp file in which to stuff the dependency info
+        -- as we go along.
+  tmp_file <- newTempName dflags TFL_CurrentModule "dep"
+  tmp_hdl <- openFile tmp_file WriteMode
+
+        -- open the makefile
+  let makefile = depMakefile dflags
+  exists <- doesFileExist makefile
+  mb_make_hdl <-
+        if not exists
+        then return Nothing
+        else do
+           makefile_hdl <- openFile makefile ReadMode
+
+                -- slurp through until we get the magic start string,
+                -- copying the contents into dep_makefile
+           let slurp = do
+                l <- hGetLine makefile_hdl
+                if (l == depStartMarker)
+                        then return ()
+                        else do hPutStrLn tmp_hdl l; slurp
+
+                -- slurp through until we get the magic end marker,
+                -- throwing away the contents
+           let chuck = do
+                l <- hGetLine makefile_hdl
+                if (l == depEndMarker)
+                        then return ()
+                        else chuck
+
+           catchIO slurp
+                (\e -> if isEOFError e then return () else ioError e)
+           catchIO chuck
+                (\e -> if isEOFError e then return () else ioError e)
+
+           return (Just makefile_hdl)
+
+
+        -- write the magic marker into the tmp file
+  hPutStrLn tmp_hdl depStartMarker
+
+  return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl,
+                  mkd_tmp_file  = tmp_file, mkd_tmp_hdl  = tmp_hdl})
+
+
+-----------------------------------------------------------------
+--
+--              processDeps
+--
+-----------------------------------------------------------------
+
+processDeps :: DynFlags
+            -> HscEnv
+            -> [ModuleName]
+            -> FilePath
+            -> Handle           -- Write dependencies to here
+            -> SCC ModSummary
+            -> IO ()
+-- Write suitable dependencies to handle
+-- Always:
+--                      this.o : this.hs
+--
+-- If the dependency is on something other than a .hi file:
+--                      this.o this.p_o ... : dep
+-- otherwise
+--                      this.o ...   : dep.hi
+--                      this.p_o ... : dep.p_hi
+--                      ...
+-- (where .o is $osuf, and the other suffixes come from
+-- the cmdline -s options).
+--
+-- For {-# SOURCE #-} imports the "hi" will be "hi-boot".
+
+processDeps dflags _ _ _ _ (CyclicSCC nodes)
+  =     -- There shouldn't be any cycles; report them
+    throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))
+
+processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)
+  = do  { let extra_suffixes = depSuffixes dflags
+              include_pkg_deps = depIncludePkgDeps dflags
+              src_file  = msHsFilePath node
+              obj_file  = msObjFilePath node
+              obj_files = insertSuffixes obj_file extra_suffixes
+
+              do_imp loc is_boot pkg_qual imp_mod
+                = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod
+                                               is_boot include_pkg_deps
+                     ; case mb_hi of {
+                           Nothing      -> return () ;
+                           Just hi_file -> do
+                     { let hi_files = insertSuffixes hi_file extra_suffixes
+                           write_dep (obj,hi) = writeDependency root hdl [obj] hi
+
+                        -- Add one dependency for each suffix;
+                        -- e.g.         A.o   : B.hi
+                        --              A.x_o : B.x_hi
+                     ; mapM_ write_dep (obj_files `zip` hi_files) }}}
+
+
+                -- Emit std dependency of the object(s) on the source file
+                -- Something like       A.o : A.hs
+        ; writeDependency root hdl obj_files src_file
+
+                -- Emit a dependency for each import
+
+        ; let do_imps is_boot idecls = sequence_
+                    [ do_imp loc is_boot mb_pkg mod
+                    | (mb_pkg, L loc mod) <- idecls,
+                      mod `notElem` excl_mods ]
+
+        ; do_imps True  (ms_srcimps node)
+        ; do_imps False (ms_imps node)
+        }
+
+
+findDependency  :: HscEnv
+                -> SrcSpan
+                -> Maybe FastString     -- package qualifier, if any
+                -> ModuleName           -- Imported module
+                -> IsBootInterface      -- Source import
+                -> Bool                 -- Record dependency on package modules
+                -> IO (Maybe FilePath)  -- Interface file file
+findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
+  = do  {       -- Find the module; this will be fast because
+                -- we've done it once during downsweep
+          r <- findImportedModule hsc_env imp pkg
+        ; case r of
+            Found loc _
+                -- Home package: just depend on the .hi or hi-boot file
+                | isJust (ml_hs_file loc) || include_pkg_deps
+                -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
+
+                -- Not in this package: we don't need a dependency
+                | otherwise
+                -> return Nothing
+
+            fail ->
+                let dflags = hsc_dflags hsc_env
+                in throwOneError $ mkPlainErrMsg dflags srcloc $
+                        cannotFindModule dflags imp fail
+        }
+
+-----------------------------
+writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()
+-- (writeDependency r h [t1,t2] dep) writes to handle h the dependency
+--      t1 t2 : dep
+writeDependency root hdl targets dep
+  = do let -- We need to avoid making deps on
+           --     c:/foo/...
+           -- on cygwin as make gets confused by the :
+           -- Making relative deps avoids some instances of this.
+           dep' = makeRelative root dep
+           forOutput = escapeSpaces . reslash Forwards . normalise
+           output = unwords (map forOutput targets) ++ " : " ++ forOutput dep'
+       hPutStrLn hdl output
+
+-----------------------------
+insertSuffixes
+        :: FilePath     -- Original filename;   e.g. "foo.o"
+        -> [String]     -- Suffix prefixes      e.g. ["x_", "y_"]
+        -> [FilePath]   -- Zapped filenames     e.g. ["foo.x_o", "foo.y_o"]
+        -- Note that that the extra bit gets inserted *before* the old suffix
+        -- We assume the old suffix contains no dots, so we know where to
+        -- split it
+insertSuffixes file_name extras
+  = [ basename <.> (extra ++ suffix) | extra <- extras ]
+  where
+    (basename, suffix) = case splitExtension file_name of
+                         -- Drop the "." from the extension
+                         (b, s) -> (b, drop 1 s)
+
+
+-----------------------------------------------------------------
+--
+--              endMkDependHs
+--      Complete the makefile, close the tmp file etc
+--
+-----------------------------------------------------------------
+
+endMkDependHS :: DynFlags -> MkDepFiles -> IO ()
+
+endMkDependHS dflags
+   (MkDep { mkd_make_file = makefile, mkd_make_hdl =  makefile_hdl,
+            mkd_tmp_file  = tmp_file, mkd_tmp_hdl  =  tmp_hdl })
+  = do
+  -- write the magic marker into the tmp file
+  hPutStrLn tmp_hdl depEndMarker
+
+  case makefile_hdl of
+     Nothing  -> return ()
+     Just hdl -> do
+
+          -- slurp the rest of the original makefile and copy it into the output
+        let slurp = do
+                l <- hGetLine hdl
+                hPutStrLn tmp_hdl l
+                slurp
+
+        catchIO slurp
+                (\e -> if isEOFError e then return () else ioError e)
+
+        hClose hdl
+
+  hClose tmp_hdl  -- make sure it's flushed
+
+        -- Create a backup of the original makefile
+  when (isJust makefile_hdl)
+       (SysTools.copy dflags ("Backing up " ++ makefile)
+          makefile (makefile++".bak"))
+
+        -- Copy the new makefile in place
+  SysTools.copy dflags "Installing new makefile" tmp_file makefile
+
+
+-----------------------------------------------------------------
+--              Module cycles
+-----------------------------------------------------------------
+
+dumpModCycles :: DynFlags -> ModuleGraph -> IO ()
+dumpModCycles dflags module_graph
+  | not (dopt Opt_D_dump_mod_cycles dflags)
+  = return ()
+
+  | null cycles
+  = putMsg dflags (text "No module cycles")
+
+  | otherwise
+  = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles)
+  where
+
+    cycles :: [[ModSummary]]
+    cycles =
+      [ c | CyclicSCC c <- GHC.topSortModuleGraph True module_graph Nothing ]
+
+    pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------"))
+                        $$ pprCycle c $$ blankLine
+                     | (n,c) <- [1..] `zip` cycles ]
+
+pprCycle :: [ModSummary] -> SDoc
+-- Print a cycle, but show only the imports within the cycle
+pprCycle summaries = pp_group (CyclicSCC summaries)
+  where
+    cycle_mods :: [ModuleName]  -- The modules in this cycle
+    cycle_mods = map (moduleName . ms_mod) summaries
+
+    pp_group (AcyclicSCC ms) = pp_ms ms
+    pp_group (CyclicSCC mss)
+        = ASSERT( not (null boot_only) )
+                -- The boot-only list must be non-empty, else there would
+                -- be an infinite chain of non-boot imoprts, and we've
+                -- already checked for that in processModDeps
+          pp_ms loop_breaker $$ vcat (map pp_group groups)
+        where
+          (boot_only, others) = partition is_boot_only mss
+          is_boot_only ms = not (any in_group (map snd (ms_imps ms)))
+          in_group (L _ m) = m `elem` group_mods
+          group_mods = map (moduleName . ms_mod) mss
+
+          loop_breaker = head boot_only
+          all_others   = tail boot_only ++ others
+          groups =
+            GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing
+
+    pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))
+                       <+> (pp_imps empty (map snd (ms_imps summary)) $$
+                            pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary)))
+        where
+          mod_str = moduleNameString (moduleName (ms_mod summary))
+
+    pp_imps :: SDoc -> [Located ModuleName] -> SDoc
+    pp_imps _    [] = empty
+    pp_imps what lms
+        = case [m | L _ m <- lms, m `elem` cycle_mods] of
+            [] -> empty
+            ms -> what <+> text "imports" <+>
+                                pprWithCommas ppr ms
+
+-----------------------------------------------------------------
+--
+--              Flags
+--
+-----------------------------------------------------------------
+
+depStartMarker, depEndMarker :: String
+depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
+depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"
+
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/DriverPipeline.hs
@@ -0,0 +1,2402 @@
+{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns #-}
+{-# OPTIONS_GHC -fno-cse #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
+
+-----------------------------------------------------------------------------
+--
+-- GHC Driver
+--
+-- (c) The University of Glasgow 2005
+--
+-----------------------------------------------------------------------------
+
+module DriverPipeline (
+        -- Run a series of compilation steps in a pipeline, for a
+        -- collection of source files.
+   oneShot, compileFile,
+
+        -- Interfaces for the batch-mode driver
+   linkBinary,
+
+        -- Interfaces for the compilation manager (interpreted/batch-mode)
+   preprocess,
+   compileOne, compileOne',
+   link,
+
+        -- Exports for hooks to override runPhase and link
+   PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),
+   phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,
+   hscPostBackendPhase, getLocation, setModLocation, setDynFlags,
+   runPhase, exeFileName,
+   maybeCreateManifest,
+   linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import PipelineMonad
+import Packages
+import HeaderInfo
+import DriverPhases
+import SysTools
+import SysTools.ExtraObj
+import HscMain
+import Finder
+import HscTypes hiding ( Hsc )
+import Outputable
+import Module
+import ErrUtils
+import DynFlags
+import Config
+import Panic
+import Util
+import StringBuffer     ( hGetStringBuffer )
+import BasicTypes       ( SuccessFlag(..) )
+import Maybes           ( expectJust )
+import SrcLoc
+import LlvmCodeGen      ( llvmFixupAsm )
+import MonadUtils
+import Platform
+import TcRnTypes
+import Hooks
+import qualified GHC.LanguageExtensions as LangExt
+import FileCleanup
+import Ar
+
+import Exception
+import System.Directory
+import System.FilePath
+import System.IO
+import Control.Monad
+import Data.List        ( isInfixOf, isSuffixOf, intercalate )
+import Data.Maybe
+import Data.Version
+import Data.Either      ( partitionEithers )
+
+import Data.Time        ( UTCTime )
+
+-- ---------------------------------------------------------------------------
+-- Pre-process
+
+-- | Just preprocess a file, put the result in a temp. file (used by the
+-- compilation manager during the summary phase).
+--
+-- We return the augmented DynFlags, because they contain the result
+-- of slurping in the OPTIONS pragmas
+
+preprocess :: HscEnv
+           -> (FilePath, Maybe Phase) -- ^ filename and starting phase
+           -> IO (DynFlags, FilePath)
+preprocess hsc_env (filename, mb_phase) =
+  ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
+  runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase)
+        Nothing
+        -- We keep the processed file for the whole session to save on
+        -- duplicated work in ghci.
+        (Temporary TFL_GhcSession)
+        Nothing{-no ModLocation-}
+        []{-no foreign objects-}
+
+-- ---------------------------------------------------------------------------
+
+-- | Compile
+--
+-- Compile a single module, under the control of the compilation manager.
+--
+-- This is the interface between the compilation manager and the
+-- compiler proper (hsc), where we deal with tedious details like
+-- reading the OPTIONS pragma from the source file, converting the
+-- C or assembly that GHC produces into an object file, and compiling
+-- FFI stub files.
+--
+-- NB.  No old interface can also mean that the source has changed.
+
+compileOne :: HscEnv
+           -> ModSummary      -- ^ summary for module being compiled
+           -> Int             -- ^ module N ...
+           -> Int             -- ^ ... of M
+           -> Maybe ModIface  -- ^ old interface, if we have one
+           -> Maybe Linkable  -- ^ old linkable, if we have one
+           -> SourceModified
+           -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful
+
+compileOne = compileOne' Nothing (Just batchMsg)
+
+compileOne' :: Maybe TcGblEnv
+            -> Maybe Messager
+            -> HscEnv
+            -> ModSummary      -- ^ summary for module being compiled
+            -> Int             -- ^ module N ...
+            -> Int             -- ^ ... of M
+            -> Maybe ModIface  -- ^ old interface, if we have one
+            -> Maybe Linkable  -- ^ old linkable, if we have one
+            -> SourceModified
+            -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful
+
+compileOne' m_tc_result mHscMessage
+            hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
+            source_modified0
+ = do
+
+   debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)
+
+   (status, hmi0) <- hscIncrementalCompile
+                        always_do_basic_recompilation_check
+                        m_tc_result mHscMessage
+                        hsc_env summary source_modified mb_old_iface (mod_index, nmods)
+
+   let flags = hsc_dflags hsc_env0
+     in do unless (gopt Opt_KeepHiFiles flags) $
+               addFilesToClean flags TFL_CurrentModule $
+                   [ml_hi_file $ ms_location summary]
+           unless (gopt Opt_KeepOFiles flags) $
+               addFilesToClean flags TFL_GhcSession $
+                   [ml_obj_file $ ms_location summary]
+
+   case (status, hsc_lang) of
+        (HscUpToDate, _) ->
+            -- TODO recomp014 triggers this assert. What's going on?!
+            -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )
+            return hmi0 { hm_linkable = maybe_old_linkable }
+        (HscNotGeneratingCode, HscNothing) ->
+            let mb_linkable = if isHsBootOrSig src_flavour
+                                then Nothing
+                                -- TODO: Questionable.
+                                else Just (LM (ms_hs_date summary) this_mod [])
+            in return hmi0 { hm_linkable = mb_linkable }
+        (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode"
+        (_, HscNothing) -> panic "compileOne HscNothing"
+        (HscUpdateBoot, HscInterpreted) -> do
+            return hmi0
+        (HscUpdateBoot, _) -> do
+            touchObjectFile dflags object_filename
+            return hmi0
+        (HscUpdateSig, HscInterpreted) ->
+            let linkable = LM (ms_hs_date summary) this_mod []
+            in return hmi0 { hm_linkable = Just linkable }
+        (HscUpdateSig, _) -> do
+            output_fn <- getOutputFilename next_phase
+                            (Temporary TFL_CurrentModule) basename dflags
+                            next_phase (Just location)
+
+            -- #10660: Use the pipeline instead of calling
+            -- compileEmptyStub directly, so -dynamic-too gets
+            -- handled properly
+            _ <- runPipeline StopLn hsc_env
+                              (output_fn,
+                               Just (HscOut src_flavour
+                                            mod_name HscUpdateSig))
+                              (Just basename)
+                              Persistent
+                              (Just location)
+                              []
+            o_time <- getModificationUTCTime object_filename
+            let linkable = LM o_time this_mod [DotO object_filename]
+            return hmi0 { hm_linkable = Just linkable }
+        (HscRecomp cgguts summary, HscInterpreted) -> do
+            (hasStub, comp_bc, spt_entries) <-
+                hscInteractive hsc_env cgguts summary
+
+            stub_o <- case hasStub of
+                      Nothing -> return []
+                      Just stub_c -> do
+                          stub_o <- compileStub hsc_env stub_c
+                          return [DotO stub_o]
+
+            let hs_unlinked = [BCOs comp_bc spt_entries]
+                unlinked_time = ms_hs_date summary
+              -- Why do we use the timestamp of the source file here,
+              -- rather than the current time?  This works better in
+              -- the case where the local clock is out of sync
+              -- with the filesystem's clock.  It's just as accurate:
+              -- if the source is modified, then the linkable will
+              -- be out of date.
+            let linkable = LM unlinked_time (ms_mod summary)
+                           (hs_unlinked ++ stub_o)
+            return hmi0 { hm_linkable = Just linkable }
+        (HscRecomp cgguts summary, _) -> do
+            output_fn <- getOutputFilename next_phase
+                            (Temporary TFL_CurrentModule)
+                            basename dflags next_phase (Just location)
+            -- We're in --make mode: finish the compilation pipeline.
+            _ <- runPipeline StopLn hsc_env
+                              (output_fn,
+                               Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))
+                              (Just basename)
+                              Persistent
+                              (Just location)
+                              []
+                  -- The object filename comes from the ModLocation
+            o_time <- getModificationUTCTime object_filename
+            let linkable = LM o_time this_mod [DotO object_filename]
+            return hmi0 { hm_linkable = Just linkable }
+
+ where dflags0     = ms_hspp_opts summary
+
+       this_mod    = ms_mod summary
+       location    = ms_location summary
+       input_fn    = expectJust "compile:hs" (ml_hs_file location)
+       input_fnpp  = ms_hspp_file summary
+       mod_graph   = hsc_mod_graph hsc_env0
+       needsLinker = needsTemplateHaskellOrQQ mod_graph
+       isDynWay    = any (== WayDyn) (ways dflags0)
+       isProfWay   = any (== WayProf) (ways dflags0)
+       internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0)
+
+       src_flavour = ms_hsc_src summary
+       mod_name = ms_mod_name summary
+       next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
+       object_filename = ml_obj_file location
+
+       -- #8180 - when using TemplateHaskell, switch on -dynamic-too so
+       -- the linker can correctly load the object files.  This isn't necessary
+       -- when using -fexternal-interpreter.
+       dflags1 = if dynamicGhc && internalInterpreter &&
+                    not isDynWay && not isProfWay && needsLinker
+                  then gopt_set dflags0 Opt_BuildDynamicToo
+                  else dflags0
+
+       basename = dropExtension input_fn
+
+       -- We add the directory in which the .hs files resides) to the import
+       -- path.  This is needed when we try to compile the .hc file later, if it
+       -- imports a _stub.h file that we created here.
+       current_dir = takeDirectory basename
+       old_paths   = includePaths dflags1
+       !prevailing_dflags = hsc_dflags hsc_env0
+       dflags =
+          dflags1 { includePaths = addQuoteInclude old_paths [current_dir]
+                  , log_action = log_action prevailing_dflags }
+                  -- use the prevailing log_action / log_finaliser,
+                  -- not the one cached in the summary.  This is so
+                  -- that we can change the log_action without having
+                  -- to re-summarize all the source files.
+       hsc_env     = hsc_env0 {hsc_dflags = dflags}
+
+       -- Figure out what lang we're generating
+       hsc_lang = hscTarget dflags
+
+       -- -fforce-recomp should also work with --make
+       force_recomp = gopt Opt_ForceRecomp dflags
+       source_modified
+         | force_recomp = SourceModified
+         | otherwise = source_modified0
+
+       always_do_basic_recompilation_check = case hsc_lang of
+                                             HscInterpreted -> True
+                                             _ -> False
+
+-----------------------------------------------------------------------------
+-- stub .h and .c files (for foreign export support), and cc files.
+
+-- The _stub.c file is derived from the haskell source file, possibly taking
+-- into account the -stubdir option.
+--
+-- The object file created by compiling the _stub.c file is put into a
+-- temporary file, which will be later combined with the main .o file
+-- (see the MergeForeigns phase).
+--
+-- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files
+-- from TH, that are then compiled and linked to the module. This is
+-- useful to implement facilities such as inline-c.
+
+compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
+compileForeign _ RawObject object_file = return object_file
+compileForeign hsc_env lang stub_c = do
+        let phase = case lang of
+              LangC      -> Cc
+              LangCxx    -> Ccxx
+              LangObjc   -> Cobjc
+              LangObjcxx -> Cobjcxx
+              LangAsm    -> As True -- allow CPP
+              RawObject  -> panic "compileForeign: should be unreachable"
+        (_, stub_o) <- runPipeline StopLn hsc_env
+                       (stub_c, Just (RealPhase phase))
+                       Nothing (Temporary TFL_GhcSession)
+                       Nothing{-no ModLocation-}
+                       []
+        return stub_o
+
+compileStub :: HscEnv -> FilePath -> IO FilePath
+compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c
+
+compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()
+compileEmptyStub dflags hsc_env basename location mod_name = do
+  -- To maintain the invariant that every Haskell file
+  -- compiles to object code, we make an empty (but
+  -- valid) stub object file for signatures.  However,
+  -- we make sure this object file has a unique symbol,
+  -- so that ranlib on OS X doesn't complain, see
+  -- http://ghc.haskell.org/trac/ghc/ticket/12673
+  -- and https://github.com/haskell/cabal/issues/2257
+  empty_stub <- newTempName dflags TFL_CurrentModule "c"
+  let src = text "int" <+> ppr (mkModule (thisPackage dflags) mod_name) <+> text "= 0;"
+  writeFile empty_stub (showSDoc dflags (pprCode CStyle src))
+  _ <- runPipeline StopLn hsc_env
+                  (empty_stub, Nothing)
+                  (Just basename)
+                  Persistent
+                  (Just location)
+                  []
+  return ()
+
+-- ---------------------------------------------------------------------------
+-- Link
+
+link :: GhcLink                 -- interactive or batch
+     -> DynFlags                -- dynamic flags
+     -> Bool                    -- attempt linking in batch mode?
+     -> HomePackageTable        -- what to link
+     -> IO SuccessFlag
+
+-- For the moment, in the batch linker, we don't bother to tell doLink
+-- which packages to link -- it just tries all that are available.
+-- batch_attempt_linking should only be *looked at* in batch mode.  It
+-- should only be True if the upsweep was successful and someone
+-- exports main, i.e., we have good reason to believe that linking
+-- will succeed.
+
+link ghcLink dflags
+  = lookupHook linkHook l dflags ghcLink dflags
+  where
+    l LinkInMemory _ _ _
+      = if cGhcWithInterpreter == "YES"
+        then -- Not Linking...(demand linker will do the job)
+             return Succeeded
+        else panicBadLink LinkInMemory
+
+    l NoLink _ _ _
+      = return Succeeded
+
+    l LinkBinary dflags batch_attempt_linking hpt
+      = link' dflags batch_attempt_linking hpt
+
+    l LinkStaticLib dflags batch_attempt_linking hpt
+      = link' dflags batch_attempt_linking hpt
+
+    l LinkDynLib dflags batch_attempt_linking hpt
+      = link' dflags batch_attempt_linking hpt
+
+panicBadLink :: GhcLink -> a
+panicBadLink other = panic ("link: GHC not built to link this way: " ++
+                            show other)
+
+link' :: DynFlags                -- dynamic flags
+      -> Bool                    -- attempt linking in batch mode?
+      -> HomePackageTable        -- what to link
+      -> IO SuccessFlag
+
+link' dflags batch_attempt_linking hpt
+   | batch_attempt_linking
+   = do
+        let
+            staticLink = case ghcLink dflags of
+                          LinkStaticLib -> True
+                          _ -> False
+
+            home_mod_infos = eltsHpt hpt
+
+            -- the packages we depend on
+            pkg_deps  = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos
+
+            -- the linkables to link
+            linkables = map (expectJust "link".hm_linkable) home_mod_infos
+
+        debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
+
+        -- check for the -no-link flag
+        if isNoLink (ghcLink dflags)
+          then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).")
+                  return Succeeded
+          else do
+
+        let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
+            obj_files = concatMap getOfiles linkables
+
+            exe_file = exeFileName staticLink dflags
+
+        linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps
+
+        if not (gopt Opt_ForceRecomp dflags) && not linking_needed
+           then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.")
+                   return Succeeded
+           else do
+
+        compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...")
+
+        -- Don't showPass in Batch mode; doLink will do that for us.
+        let link = case ghcLink dflags of
+                LinkBinary    -> linkBinary
+                LinkStaticLib -> linkStaticLib
+                LinkDynLib    -> linkDynLibCheck
+                other         -> panicBadLink other
+        link dflags obj_files pkg_deps
+
+        debugTraceMsg dflags 3 (text "link: done")
+
+        -- linkBinary only returns if it succeeds
+        return Succeeded
+
+   | otherwise
+   = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$
+                                text "   Main.main not exported; not linking.")
+        return Succeeded
+
+
+linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [InstalledUnitId] -> IO Bool
+linkingNeeded dflags staticLink linkables pkg_deps = do
+        -- if the modification time on the executable is later than the
+        -- modification times on all of the objects and libraries, then omit
+        -- linking (unless the -fforce-recomp flag was given).
+  let exe_file = exeFileName staticLink dflags
+  e_exe_time <- tryIO $ getModificationUTCTime exe_file
+  case e_exe_time of
+    Left _  -> return True
+    Right t -> do
+        -- first check object files and extra_ld_inputs
+        let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
+        e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs
+        let (errs,extra_times) = partitionEithers e_extra_times
+        let obj_times =  map linkableTime linkables ++ extra_times
+        if not (null errs) || any (t <) obj_times
+            then return True
+            else do
+
+        -- next, check libraries. XXX this only checks Haskell libraries,
+        -- not extra_libraries or -l things from the command line.
+        let pkg_hslibs  = [ (collectLibraryPaths dflags [c], lib)
+                          | Just c <- map (lookupInstalledPackage dflags) pkg_deps,
+                            lib <- packageHsLibs dflags c ]
+
+        pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs
+        if any isNothing pkg_libfiles then return True else do
+        e_lib_times <- mapM (tryIO . getModificationUTCTime)
+                          (catMaybes pkg_libfiles)
+        let (lib_errs,lib_times) = partitionEithers e_lib_times
+        if not (null lib_errs) || any (t <) lib_times
+           then return True
+           else checkLinkInfo dflags pkg_deps exe_file
+
+findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath)
+findHSLib dflags dirs lib = do
+  let batch_lib_file = if WayDyn `notElem` ways dflags
+                      then "lib" ++ lib <.> "a"
+                      else mkSOName (targetPlatform dflags) lib
+  found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
+  case found of
+    [] -> return Nothing
+    (x:_) -> return (Just x)
+
+-- -----------------------------------------------------------------------------
+-- Compile files in one-shot mode.
+
+oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
+oneShot hsc_env stop_phase srcs = do
+  o_files <- mapM (compileFile hsc_env stop_phase) srcs
+  doLink (hsc_dflags hsc_env) stop_phase o_files
+
+compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
+compileFile hsc_env stop_phase (src, mb_phase) = do
+   exists <- doesFileExist src
+   when (not exists) $
+        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))
+
+   let
+        dflags    = hsc_dflags hsc_env
+        split     = gopt Opt_SplitObjs dflags
+        mb_o_file = outputFile dflags
+        ghc_link  = ghcLink dflags      -- Set by -c or -no-link
+
+        -- When linking, the -o argument refers to the linker's output.
+        -- otherwise, we use it as the name for the pipeline's output.
+        output
+         -- If we are doing -fno-code, then act as if the output is
+         -- 'Temporary'. This stops GHC trying to copy files to their
+         -- final location.
+         | HscNothing <- hscTarget dflags = Temporary TFL_CurrentModule
+         | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
+                -- -o foo applies to linker
+         | isJust mb_o_file = SpecificFile
+                -- -o foo applies to the file we are compiling now
+         | otherwise = Persistent
+
+        stop_phase' = case stop_phase of
+                        As _ | split -> SplitAs
+                        _            -> stop_phase
+
+   ( _, out_file) <- runPipeline stop_phase' hsc_env
+                            (src, fmap RealPhase mb_phase) Nothing output
+                            Nothing{-no ModLocation-} []
+   return out_file
+
+
+doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
+doLink dflags stop_phase o_files
+  | not (isStopLn stop_phase)
+  = return ()           -- We stopped before the linking phase
+
+  | otherwise
+  = case ghcLink dflags of
+        NoLink        -> return ()
+        LinkBinary    -> linkBinary         dflags o_files []
+        LinkStaticLib -> linkStaticLib      dflags o_files []
+        LinkDynLib    -> linkDynLibCheck    dflags o_files []
+        other         -> panicBadLink other
+
+
+-- ---------------------------------------------------------------------------
+
+-- | Run a compilation pipeline, consisting of multiple phases.
+--
+-- This is the interface to the compilation pipeline, which runs
+-- a series of compilation steps on a single source file, specifying
+-- at which stage to stop.
+--
+-- The DynFlags can be modified by phases in the pipeline (eg. by
+-- OPTIONS_GHC pragmas), and the changes affect later phases in the
+-- pipeline.
+runPipeline
+  :: Phase                      -- ^ When to stop
+  -> HscEnv                     -- ^ Compilation environment
+  -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix)
+  -> Maybe FilePath             -- ^ original basename (if different from ^^^)
+  -> PipelineOutput             -- ^ Output filename
+  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
+  -> [FilePath]                 -- ^ foreign objects
+  -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)
+runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
+             mb_basename output maybe_loc foreign_os
+
+    = do let
+             dflags0 = hsc_dflags hsc_env0
+
+             -- Decide where dump files should go based on the pipeline output
+             dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
+             hsc_env = hsc_env0 {hsc_dflags = dflags}
+
+             (input_basename, suffix) = splitExtension input_fn
+             suffix' = drop 1 suffix -- strip off the .
+             basename | Just b <- mb_basename = b
+                      | otherwise             = input_basename
+
+             -- If we were given a -x flag, then use that phase to start from
+             start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase
+
+             isHaskell (RealPhase (Unlit _)) = True
+             isHaskell (RealPhase (Cpp   _)) = True
+             isHaskell (RealPhase (HsPp  _)) = True
+             isHaskell (RealPhase (Hsc   _)) = True
+             isHaskell (HscOut {})           = True
+             isHaskell _                     = False
+
+             isHaskellishFile = isHaskell start_phase
+
+             env = PipeEnv{ stop_phase,
+                            src_filename = input_fn,
+                            src_basename = basename,
+                            src_suffix = suffix',
+                            output_spec = output }
+
+         when (isBackpackishSuffix suffix') $
+           throwGhcExceptionIO (UsageError
+                       ("use --backpack to process " ++ input_fn))
+
+         -- We want to catch cases of "you can't get there from here" before
+         -- we start the pipeline, because otherwise it will just run off the
+         -- end.
+         let happensBefore' = happensBefore dflags
+         case start_phase of
+             RealPhase start_phase' ->
+                 -- See Note [Partial ordering on phases]
+                 -- Not the same as: (stop_phase `happensBefore` start_phase')
+                 when (not (start_phase' `happensBefore'` stop_phase ||
+                            start_phase' `eqPhase` stop_phase)) $
+                       throwGhcExceptionIO (UsageError
+                                   ("cannot compile this file to desired target: "
+                                      ++ input_fn))
+             HscOut {} -> return ()
+
+         debugTraceMsg dflags 4 (text "Running the pipeline")
+         r <- runPipeline' start_phase hsc_env env input_fn
+                           maybe_loc foreign_os
+
+         -- If we are compiling a Haskell module, and doing
+         -- -dynamic-too, but couldn't do the -dynamic-too fast
+         -- path, then rerun the pipeline for the dyn way
+         let dflags = hsc_dflags hsc_env
+         -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)
+         when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do
+           when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do
+               debugTraceMsg dflags 4
+                   (text "Running the pipeline again for -dynamic-too")
+               let dflags' = dynamicTooMkDynamicDynFlags dflags
+               hsc_env' <- newHscEnv dflags'
+               _ <- runPipeline' start_phase hsc_env' env input_fn
+                                 maybe_loc foreign_os
+               return ()
+         return r
+
+runPipeline'
+  :: PhasePlus                  -- ^ When to start
+  -> HscEnv                     -- ^ Compilation environment
+  -> PipeEnv
+  -> FilePath                   -- ^ Input filename
+  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
+  -> [FilePath]                 -- ^ foreign objects, if we have one
+  -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)
+runPipeline' start_phase hsc_env env input_fn
+             maybe_loc foreign_os
+  = do
+  -- Execute the pipeline...
+  let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os }
+
+  evalP (pipeLoop start_phase input_fn) env state
+
+-- ---------------------------------------------------------------------------
+-- outer pipeline loop
+
+-- | pipeLoop runs phases until we reach the stop phase
+pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
+pipeLoop phase input_fn = do
+  env <- getPipeEnv
+  dflags <- getDynFlags
+  -- See Note [Partial ordering on phases]
+  let happensBefore' = happensBefore dflags
+      stopPhase = stop_phase env
+  case phase of
+   RealPhase realPhase | realPhase `eqPhase` stopPhase            -- All done
+     -> -- Sometimes, a compilation phase doesn't actually generate any output
+        -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
+        -- stage, but we wanted to keep the output, then we have to explicitly
+        -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
+        -- further compilation stages can tell what the original filename was.
+        case output_spec env of
+        Temporary _ ->
+            return (dflags, input_fn)
+        output ->
+            do pst <- getPipeState
+               final_fn <- liftIO $ getOutputFilename
+                                        stopPhase output (src_basename env)
+                                        dflags stopPhase (maybe_loc pst)
+               when (final_fn /= input_fn) $ do
+                  let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")
+                      line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")
+                  liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn
+               return (dflags, final_fn)
+
+
+     | not (realPhase `happensBefore'` stopPhase)
+        -- Something has gone wrong.  We'll try to cover all the cases when
+        -- this could happen, so if we reach here it is a panic.
+        -- eg. it might happen if the -C flag is used on a source file that
+        -- has {-# OPTIONS -fasm #-}.
+     -> panic ("pipeLoop: at phase " ++ show realPhase ++
+           " but I wanted to stop at phase " ++ show stopPhase)
+
+   _
+     -> do liftIO $ debugTraceMsg dflags 4
+                                  (text "Running phase" <+> ppr phase)
+           (next_phase, output_fn) <- runHookedPhase phase input_fn dflags
+           r <- pipeLoop next_phase output_fn
+           case phase of
+               HscOut {} ->
+                   whenGeneratingDynamicToo dflags $ do
+                       setDynFlags $ dynamicTooMkDynamicDynFlags dflags
+                       -- TODO shouldn't ignore result:
+                       _ <- pipeLoop phase input_fn
+                       return ()
+               _ ->
+                   return ()
+           return r
+
+runHookedPhase :: PhasePlus -> FilePath -> DynFlags
+               -> CompPipeline (PhasePlus, FilePath)
+runHookedPhase pp input dflags =
+  lookupHook runPhaseHook runPhase dflags pp input dflags
+
+-- -----------------------------------------------------------------------------
+-- In each phase, we need to know into what filename to generate the
+-- output.  All the logic about which filenames we generate output
+-- into is embodied in the following function.
+
+-- | Computes the next output filename after we run @next_phase@.
+-- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad
+-- (which specifies all of the ambient information.)
+phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
+phaseOutputFilename next_phase = do
+  PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
+  PipeState{maybe_loc, hsc_env} <- getPipeState
+  let dflags = hsc_dflags hsc_env
+  liftIO $ getOutputFilename stop_phase output_spec
+                             src_basename dflags next_phase maybe_loc
+
+-- | Computes the next output filename for something in the compilation
+-- pipeline.  This is controlled by several variables:
+--
+--      1. 'Phase': the last phase to be run (e.g. 'stopPhase').  This
+--         is used to tell if we're in the last phase or not, because
+--         in that case flags like @-o@ may be important.
+--      2. 'PipelineOutput': is this intended to be a 'Temporary' or
+--         'Persistent' build output?  Temporary files just go in
+--         a fresh temporary name.
+--      3. 'String': what was the basename of the original input file?
+--      4. 'DynFlags': the obvious thing
+--      5. 'Phase': the phase we want to determine the output filename of.
+--      6. @Maybe ModLocation@: the 'ModLocation' of the module we're
+--         compiling; this can be used to override the default output
+--         of an object file.  (TODO: do we actually need this?)
+getOutputFilename
+  :: Phase -> PipelineOutput -> String
+  -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
+getOutputFilename stop_phase output basename dflags next_phase maybe_location
+ | is_last_phase, Persistent   <- output = persistent_fn
+ | is_last_phase, SpecificFile <- output = case outputFile dflags of
+                                           Just f -> return f
+                                           Nothing ->
+                                               panic "SpecificFile: No filename"
+ | keep_this_output                      = persistent_fn
+ | Temporary lifetime <- output          = newTempName dflags lifetime suffix
+ | otherwise                             = newTempName dflags TFL_CurrentModule
+   suffix
+    where
+          hcsuf      = hcSuf dflags
+          odir       = objectDir dflags
+          osuf       = objectSuf dflags
+          keep_hc    = gopt Opt_KeepHcFiles dflags
+          keep_hscpp = gopt Opt_KeepHscppFiles dflags
+          keep_s     = gopt Opt_KeepSFiles dflags
+          keep_bc    = gopt Opt_KeepLlvmFiles dflags
+
+          myPhaseInputExt HCc       = hcsuf
+          myPhaseInputExt MergeForeign = osuf
+          myPhaseInputExt StopLn    = osuf
+          myPhaseInputExt other     = phaseInputExt other
+
+          is_last_phase = next_phase `eqPhase` stop_phase
+
+          -- sometimes, we keep output from intermediate stages
+          keep_this_output =
+               case next_phase of
+                       As _    | keep_s     -> True
+                       LlvmOpt | keep_bc    -> True
+                       HCc     | keep_hc    -> True
+                       HsPp _  | keep_hscpp -> True   -- See Trac #10869
+                       _other               -> False
+
+          suffix = myPhaseInputExt next_phase
+
+          -- persistent object files get put in odir
+          persistent_fn
+             | StopLn <- next_phase = return odir_persistent
+             | otherwise            = return persistent
+
+          persistent = basename <.> suffix
+
+          odir_persistent
+             | Just loc <- maybe_location = ml_obj_file loc
+             | Just d <- odir = d </> persistent
+             | otherwise      = persistent
+
+
+-- | The fast LLVM Pipeline skips the mangler and assembler,
+-- emitting object code directly from llc.
+--
+-- slow: opt -> llc -> .s -> mangler -> as -> .o
+-- fast: opt -> llc -> .o
+--
+-- hidden flag: -ffast-llvm
+--
+-- if keep-s-files is specified, we need to go through
+-- the slow pipeline (Kavon Farvardin requested this).
+fastLlvmPipeline :: DynFlags -> Bool
+fastLlvmPipeline dflags
+  = not (gopt Opt_KeepSFiles dflags) && gopt Opt_FastLlvm dflags
+
+-- | LLVM Options. These are flags to be passed to opt and llc, to ensure
+-- consistency we list them in pairs, so that they form groups.
+llvmOptions :: DynFlags
+            -> [(String, String)]  -- ^ pairs of (opt, llc) arguments
+llvmOptions dflags =
+       [("-enable-tbaa -tbaa",  "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]
+    ++ [("-relocation-model=" ++ rmodel
+        ,"-relocation-model=" ++ rmodel) | not (null rmodel)]
+    ++ [("-stack-alignment=" ++ (show align)
+        ,"-stack-alignment=" ++ (show align)) | align > 0 ]
+    ++ [("", "-filetype=obj") | fastLlvmPipeline dflags ]
+
+    -- Additional llc flags
+    ++ [("", "-mcpu=" ++ mcpu)   | not (null mcpu)
+                                 , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]
+    ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]
+
+  where target = LLVM_TARGET
+        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets dflags)
+
+        -- Relocation models
+        rmodel | gopt Opt_PIC dflags        = "pic"
+               | positionIndependent dflags = "pic"
+               | WayDyn `elem` ways dflags  = "dynamic-no-pic"
+               | otherwise                  = "static"
+
+        align :: Int
+        align = case platformArch (targetPlatform dflags) of
+                  ArchX86_64 | isAvxEnabled dflags -> 32
+                  _                                -> 0
+
+        attrs :: String
+        attrs = intercalate "," $ mattr
+              ++ ["+sse42"   | isSse4_2Enabled dflags   ]
+              ++ ["+sse2"    | isSse2Enabled dflags     ]
+              ++ ["+sse"     | isSseEnabled dflags      ]
+              ++ ["+avx512f" | isAvx512fEnabled dflags  ]
+              ++ ["+avx2"    | isAvx2Enabled dflags     ]
+              ++ ["+avx"     | isAvxEnabled dflags      ]
+              ++ ["+avx512cd"| isAvx512cdEnabled dflags ]
+              ++ ["+avx512er"| isAvx512erEnabled dflags ]
+              ++ ["+avx512pf"| isAvx512pfEnabled dflags ]
+              ++ ["+bmi"     | isBmiEnabled dflags      ]
+              ++ ["+bmi2"    | isBmi2Enabled dflags     ]
+
+-- -----------------------------------------------------------------------------
+-- | Each phase in the pipeline returns the next phase to execute, and the
+-- name of the file in which the output was placed.
+--
+-- We must do things dynamically this way, because we often don't know
+-- what the rest of the phases will be until part-way through the
+-- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
+-- of a source file can change the latter stages of the pipeline from
+-- taking the LLVM route to using the native code generator.
+--
+runPhase :: PhasePlus   -- ^ Run this phase
+         -> FilePath    -- ^ name of the input file
+         -> DynFlags    -- ^ for convenience, we pass the current dflags in
+         -> CompPipeline (PhasePlus,           -- next phase to run
+                          FilePath)            -- output filename
+
+        -- Invariant: the output filename always contains the output
+        -- Interesting case: Hsc when there is no recompilation to do
+        --                   Then the output filename is still a .o file
+
+
+-------------------------------------------------------------------------------
+-- Unlit phase
+
+runPhase (RealPhase (Unlit sf)) input_fn dflags
+  = do
+       output_fn <- phaseOutputFilename (Cpp sf)
+
+       let flags = [ -- The -h option passes the file name for unlit to
+                     -- put in a #line directive
+                     SysTools.Option     "-h"
+                     -- See Note [Don't normalise input filenames].
+                   , SysTools.Option $ escape input_fn
+                   , SysTools.FileOption "" input_fn
+                   , SysTools.FileOption "" output_fn
+                   ]
+
+       liftIO $ SysTools.runUnlit dflags flags
+
+       return (RealPhase (Cpp sf), output_fn)
+  where
+       -- escape the characters \, ", and ', but don't try to escape
+       -- Unicode or anything else (so we don't use Util.charToC
+       -- here).  If we get this wrong, then in
+       -- Coverage.isGoodTickSrcSpan where we check that the filename in
+       -- a SrcLoc is the same as the source filenaame, the two will
+       -- look bogusly different. See test:
+       -- libraries/hpc/tests/function/subdir/tough2.hs
+       escape ('\\':cs) = '\\':'\\': escape cs
+       escape ('\"':cs) = '\\':'\"': escape cs
+       escape ('\'':cs) = '\\':'\'': escape cs
+       escape (c:cs)    = c : escape cs
+       escape []        = []
+
+-------------------------------------------------------------------------------
+-- Cpp phase : (a) gets OPTIONS out of file
+--             (b) runs cpp if necessary
+
+runPhase (RealPhase (Cpp sf)) input_fn dflags0
+  = do
+       src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn
+       (dflags1, unhandled_flags, warns)
+           <- liftIO $ parseDynamicFilePragma dflags0 src_opts
+       setDynFlags dflags1
+       liftIO $ checkProcessArgsResult dflags1 unhandled_flags
+
+       if not (xopt LangExt.Cpp dflags1) then do
+           -- we have to be careful to emit warnings only once.
+           unless (gopt Opt_Pp dflags1) $
+               liftIO $ handleFlagWarnings dflags1 warns
+
+           -- no need to preprocess CPP, just pass input file along
+           -- to the next phase of the pipeline.
+           return (RealPhase (HsPp sf), input_fn)
+        else do
+            output_fn <- phaseOutputFilename (HsPp sf)
+            liftIO $ doCpp dflags1 True{-raw-}
+                           input_fn output_fn
+            -- re-read the pragmas now that we've preprocessed the file
+            -- See #2464,#3457
+            src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn
+            (dflags2, unhandled_flags, warns)
+                <- liftIO $ parseDynamicFilePragma dflags0 src_opts
+            liftIO $ checkProcessArgsResult dflags2 unhandled_flags
+            unless (gopt Opt_Pp dflags2) $
+                liftIO $ handleFlagWarnings dflags2 warns
+            -- the HsPp pass below will emit warnings
+
+            setDynFlags dflags2
+
+            return (RealPhase (HsPp sf), output_fn)
+
+-------------------------------------------------------------------------------
+-- HsPp phase
+
+runPhase (RealPhase (HsPp sf)) input_fn dflags
+  = do
+       if not (gopt Opt_Pp dflags) then
+           -- no need to preprocess, just pass input file along
+           -- to the next phase of the pipeline.
+          return (RealPhase (Hsc sf), input_fn)
+        else do
+            PipeEnv{src_basename, src_suffix} <- getPipeEnv
+            let orig_fn = src_basename <.> src_suffix
+            output_fn <- phaseOutputFilename (Hsc sf)
+            liftIO $ SysTools.runPp dflags
+                           ( [ SysTools.Option     orig_fn
+                             , SysTools.Option     input_fn
+                             , SysTools.FileOption "" output_fn
+                             ]
+                           )
+
+            -- re-read pragmas now that we've parsed the file (see #3674)
+            src_opts <- liftIO $ getOptionsFromFile dflags output_fn
+            (dflags1, unhandled_flags, warns)
+                <- liftIO $ parseDynamicFilePragma dflags src_opts
+            setDynFlags dflags1
+            liftIO $ checkProcessArgsResult dflags1 unhandled_flags
+            liftIO $ handleFlagWarnings dflags1 warns
+
+            return (RealPhase (Hsc sf), output_fn)
+
+-----------------------------------------------------------------------------
+-- Hsc phase
+
+-- Compilation of a single module, in "legacy" mode (_not_ under
+-- the direction of the compilation manager).
+runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
+ = do   -- normal Hsc mode, not mkdependHS
+
+        PipeEnv{ stop_phase=stop,
+                 src_basename=basename,
+                 src_suffix=suff } <- getPipeEnv
+
+  -- we add the current directory (i.e. the directory in which
+  -- the .hs files resides) to the include path, since this is
+  -- what gcc does, and it's probably what you want.
+        let current_dir = takeDirectory basename
+            new_includes = addQuoteInclude paths [current_dir]
+            paths = includePaths dflags0
+            dflags = dflags0 { includePaths = new_includes }
+
+        setDynFlags dflags
+
+  -- gather the imports and module name
+        (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do
+          do
+            buf <- hGetStringBuffer input_fn
+            (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
+            return (Just buf, mod_name, imps, src_imps)
+
+  -- Take -o into account if present
+  -- Very like -ohi, but we must *only* do this if we aren't linking
+  -- (If we're linking then the -o applies to the linked thing, not to
+  -- the object file for one module.)
+  -- Note the nasty duplication with the same computation in compileFile above
+        location <- getLocation src_flavour mod_name
+
+        let o_file = ml_obj_file location -- The real object file
+            hi_file = ml_hi_file location
+            hie_file = ml_hie_file location
+            dest_file | writeInterfaceOnlyMode dflags
+                            = hi_file
+                      | otherwise
+                            = o_file
+
+  -- Figure out if the source has changed, for recompilation avoidance.
+  --
+  -- Setting source_unchanged to True means that M.o (or M.hie) seems
+  -- to be up to date wrt M.hs; so no need to recompile unless imports have
+  -- changed (which the compiler itself figures out).
+  -- Setting source_unchanged to False tells the compiler that M.o is out of
+  -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
+        src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)
+
+        source_unchanged <- liftIO $
+          if not (isStopLn stop)
+                -- SourceModified unconditionally if
+                --      (a) recompilation checker is off, or
+                --      (b) we aren't going all the way to .o file (e.g. ghc -S)
+             then return SourceModified
+                -- Otherwise look at file modification dates
+             else do dest_file_mod <- sourceModified dest_file src_timestamp
+                     hie_file_mod <- if gopt Opt_WriteHie dflags
+                                        then sourceModified hie_file
+                                                            src_timestamp
+                                        else pure False
+                     if dest_file_mod || hie_file_mod
+                        then return SourceModified
+                        else return SourceUnmodified
+
+        PipeState{hsc_env=hsc_env'} <- getPipeState
+
+  -- Tell the finder cache about this module
+        mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location
+
+  -- Make the ModSummary to hand to hscMain
+        let
+            mod_summary = ModSummary {  ms_mod       = mod,
+                                        ms_hsc_src   = src_flavour,
+                                        ms_hspp_file = input_fn,
+                                        ms_hspp_opts = dflags,
+                                        ms_hspp_buf  = hspp_buf,
+                                        ms_location  = location,
+                                        ms_hs_date   = src_timestamp,
+                                        ms_obj_date  = Nothing,
+                                        ms_parsed_mod   = Nothing,
+                                        ms_iface_date   = Nothing,
+                                        ms_hie_date     = Nothing,
+                                        ms_textual_imps = imps,
+                                        ms_srcimps      = src_imps }
+
+  -- run the compiler!
+        let msg hsc_env _ what _ = oneShotMsg hsc_env what
+        (result, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'
+                            mod_summary source_unchanged Nothing (1,1)
+
+        return (HscOut src_flavour mod_name result,
+                panic "HscOut doesn't have an input filename")
+
+runPhase (HscOut src_flavour mod_name result) _ dflags = do
+        location <- getLocation src_flavour mod_name
+        setModLocation location
+
+        let o_file = ml_obj_file location -- The real object file
+            hsc_lang = hscTarget dflags
+            next_phase = hscPostBackendPhase dflags src_flavour hsc_lang
+
+        case result of
+            HscNotGeneratingCode ->
+                return (RealPhase StopLn,
+                        panic "No output filename from Hsc when no-code")
+            HscUpToDate ->
+                do liftIO $ touchObjectFile dflags o_file
+                   -- The .o file must have a later modification date
+                   -- than the source file (else we wouldn't get Nothing)
+                   -- but we touch it anyway, to keep 'make' happy (we think).
+                   return (RealPhase StopLn, o_file)
+            HscUpdateBoot ->
+                do -- In the case of hs-boot files, generate a dummy .o-boot
+                   -- stamp file for the benefit of Make
+                   liftIO $ touchObjectFile dflags o_file
+                   return (RealPhase StopLn, o_file)
+            HscUpdateSig ->
+                do -- We need to create a REAL but empty .o file
+                   -- because we are going to attempt to put it in a library
+                   PipeState{hsc_env=hsc_env'} <- getPipeState
+                   let input_fn = expectJust "runPhase" (ml_hs_file location)
+                       basename = dropExtension input_fn
+                   liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name
+                   return (RealPhase StopLn, o_file)
+            HscRecomp cgguts mod_summary
+              -> do output_fn <- phaseOutputFilename next_phase
+
+                    PipeState{hsc_env=hsc_env'} <- getPipeState
+
+                    (outputFilename, mStub, foreign_files) <- liftIO $
+                      hscGenHardCode hsc_env' cgguts mod_summary output_fn
+                    stub_o <- liftIO (mapM (compileStub hsc_env') mStub)
+                    foreign_os <- liftIO $
+                      mapM (uncurry (compileForeign hsc_env')) foreign_files
+                    setForeignOs (maybe [] return stub_o ++ foreign_os)
+
+                    return (RealPhase next_phase, outputFilename)
+
+-----------------------------------------------------------------------------
+-- Cmm phase
+
+runPhase (RealPhase CmmCpp) input_fn dflags
+  = do
+       output_fn <- phaseOutputFilename Cmm
+       liftIO $ doCpp dflags False{-not raw-}
+                      input_fn output_fn
+       return (RealPhase Cmm, output_fn)
+
+runPhase (RealPhase Cmm) input_fn dflags
+  = do
+        let hsc_lang = hscTarget dflags
+
+        let next_phase = hscPostBackendPhase dflags HsSrcFile hsc_lang
+
+        output_fn <- phaseOutputFilename next_phase
+
+        PipeState{hsc_env} <- getPipeState
+
+        liftIO $ hscCompileCmmFile hsc_env input_fn output_fn
+
+        return (RealPhase next_phase, output_fn)
+
+-----------------------------------------------------------------------------
+-- Cc phase
+
+-- we don't support preprocessing .c files (with -E) now.  Doing so introduces
+-- way too many hacks, and I can't say I've ever used it anyway.
+
+runPhase (RealPhase cc_phase) input_fn dflags
+   | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx]
+   = do
+        let platform = targetPlatform dflags
+            hcc = cc_phase `eqPhase` HCc
+
+        let cmdline_include_paths = includePaths dflags
+
+        -- HC files have the dependent packages stamped into them
+        pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return []
+
+        -- add package include paths even if we're just compiling .c
+        -- files; this is the Value Add(TM) that using ghc instead of
+        -- gcc gives you :)
+        pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
+        let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
+              (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
+        let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
+              (includePathsQuote cmdline_include_paths)
+        let include_paths = include_paths_quote ++ include_paths_global
+
+        let gcc_extra_viac_flags = extraGccViaCFlags dflags
+        let pic_c_flags = picCCOpts dflags
+
+        let verbFlags = getVerbFlags dflags
+
+        -- cc-options are not passed when compiling .hc files.  Our
+        -- hc code doesn't not #include any header files anyway, so these
+        -- options aren't necessary.
+        pkg_extra_cc_opts <- liftIO $
+          if cc_phase `eqPhase` HCc
+             then return []
+             else getPackageExtraCcOpts dflags pkgs
+
+        framework_paths <-
+            if platformUsesFrameworks platform
+            then do pkgFrameworkPaths <- liftIO $ getPackageFrameworkPath dflags pkgs
+                    let cmdlineFrameworkPaths = frameworkPaths dflags
+                    return $ map ("-F"++)
+                                 (cmdlineFrameworkPaths ++ pkgFrameworkPaths)
+            else return []
+
+        let cc_opt | optLevel dflags >= 2 = [ "-O2" ]
+                   | optLevel dflags >= 1 = [ "-O" ]
+                   | otherwise            = []
+
+        -- Decide next phase
+        let next_phase = As False
+        output_fn <- phaseOutputFilename next_phase
+
+        let
+          more_hcc_opts =
+                -- on x86 the floating point regs have greater precision
+                -- than a double, which leads to unpredictable results.
+                -- By default, we turn this off with -ffloat-store unless
+                -- the user specified -fexcess-precision.
+                (if platformArch platform == ArchX86 &&
+                    not (gopt Opt_ExcessPrecision dflags)
+                        then [ "-ffloat-store" ]
+                        else []) ++
+
+                -- gcc's -fstrict-aliasing allows two accesses to memory
+                -- to be considered non-aliasing if they have different types.
+                -- This interacts badly with the C code we generate, which is
+                -- very weakly typed, being derived from C--.
+                ["-fno-strict-aliasing"]
+
+        ghcVersionH <- liftIO $ getGhcVersionPathName dflags
+
+        let gcc_lang_opt | cc_phase `eqPhase` Ccxx    = "c++"
+                         | cc_phase `eqPhase` Cobjc   = "objective-c"
+                         | cc_phase `eqPhase` Cobjcxx = "objective-c++"
+                         | otherwise                  = "c"
+        liftIO $ SysTools.runCc dflags (
+                -- force the C compiler to interpret this file as C when
+                -- compiling .hc files, by adding the -x c option.
+                -- Also useful for plain .c files, just in case GHC saw a
+                -- -x c option.
+                        [ SysTools.Option "-x", SysTools.Option gcc_lang_opt
+                        , SysTools.FileOption "" input_fn
+                        , SysTools.Option "-o"
+                        , SysTools.FileOption "" output_fn
+                        ]
+                       ++ map SysTools.Option (
+                          pic_c_flags
+
+                -- Stub files generated for foreign exports references the runIO_closure
+                -- and runNonIO_closure symbols, which are defined in the base package.
+                -- These symbols are imported into the stub.c file via RtsAPI.h, and the
+                -- way we do the import depends on whether we're currently compiling
+                -- the base package or not.
+                       ++ (if platformOS platform == OSMinGW32 &&
+                              thisPackage dflags == baseUnitId
+                                then [ "-DCOMPILING_BASE_PACKAGE" ]
+                                else [])
+
+        -- We only support SparcV9 and better because V8 lacks an atomic CAS
+        -- instruction. Note that the user can still override this
+        -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
+        -- regardless of the ordering.
+        --
+        -- This is a temporary hack. See #2872, commit
+        -- 5bd3072ac30216a505151601884ac88bf404c9f2
+                       ++ (if platformArch platform == ArchSPARC
+                           then ["-mcpu=v9"]
+                           else [])
+
+                       -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.
+                       ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)
+                             then ["-Wimplicit"]
+                             else [])
+
+                       ++ (if hcc
+                             then gcc_extra_viac_flags ++ more_hcc_opts
+                             else [])
+                       ++ verbFlags
+                       ++ [ "-S" ]
+                       ++ cc_opt
+                       ++ [ "-include", ghcVersionH ]
+                       ++ framework_paths
+                       ++ include_paths
+                       ++ pkg_extra_cc_opts
+                       ))
+
+        return (RealPhase next_phase, output_fn)
+
+-----------------------------------------------------------------------------
+-- Splitting phase
+
+runPhase (RealPhase Splitter) input_fn dflags
+  = do  -- tmp_pfx is the prefix used for the split .s files
+
+        split_s_prefix <-
+          liftIO $ newTempName dflags TFL_CurrentModule "split"
+        let n_files_fn = split_s_prefix
+
+        liftIO $ SysTools.runSplit dflags
+                          [ SysTools.FileOption "" input_fn
+                          , SysTools.FileOption "" split_s_prefix
+                          , SysTools.FileOption "" n_files_fn
+                          ]
+
+        -- Save the number of split files for future references
+        s <- liftIO $ readFile n_files_fn
+        let n_files = read s :: Int
+            dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }
+
+        setDynFlags dflags'
+
+        -- Remember to delete all these files
+        liftIO $ addFilesToClean dflags' TFL_CurrentModule $
+                                 [ split_s_prefix ++ "__" ++ show n ++ ".s"
+                                 | n <- [1..n_files]]
+
+        return (RealPhase SplitAs,
+                "**splitter**") -- we don't use the filename in SplitAs
+
+-----------------------------------------------------------------------------
+-- As, SpitAs phase : Assembler
+
+-- This is for calling the assembler on a regular assembly file (not split).
+runPhase (RealPhase (As with_cpp)) input_fn dflags
+  = do
+        -- LLVM from version 3.0 onwards doesn't support the OS X system
+        -- assembler, so we use clang as the assembler instead. (#5636)
+        let whichAsProg | hscTarget dflags == HscLlvm &&
+                          platformOS (targetPlatform dflags) == OSDarwin
+                        = return SysTools.runClang
+                        | otherwise = return SysTools.runAs
+
+        as_prog <- whichAsProg
+        let cmdline_include_paths = includePaths dflags
+        let pic_c_flags = picCCOpts dflags
+
+        next_phase <- maybeMergeForeign
+        output_fn <- phaseOutputFilename next_phase
+
+        -- we create directories for the object file, because it
+        -- might be a hierarchical module.
+        liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
+
+        ccInfo <- liftIO $ getCompilerInfo dflags
+        let global_includes = [ SysTools.Option ("-I" ++ p)
+                              | p <- includePathsGlobal cmdline_include_paths ]
+        let local_includes = [ SysTools.Option ("-iquote" ++ p)
+                             | p <- includePathsQuote cmdline_include_paths ]
+        let runAssembler inputFilename outputFilename
+                = liftIO $ as_prog dflags
+                       (local_includes ++ global_includes
+                       -- See Note [-fPIC for assembler]
+                       ++ map SysTools.Option pic_c_flags
+                       -- See Note [Produce big objects on Windows]
+                       ++ [ SysTools.Option "-Wa,-mbig-obj"
+                          | platformOS (targetPlatform dflags) == OSMinGW32
+                          , not $ target32Bit (targetPlatform dflags)
+                          ]
+
+        -- We only support SparcV9 and better because V8 lacks an atomic CAS
+        -- instruction so we have to make sure that the assembler accepts the
+        -- instruction set. Note that the user can still override this
+        -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
+        -- regardless of the ordering.
+        --
+        -- This is a temporary hack.
+                       ++ (if platformArch (targetPlatform dflags) == ArchSPARC
+                           then [SysTools.Option "-mcpu=v9"]
+                           else [])
+                       ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51]
+                            then [SysTools.Option "-Qunused-arguments"]
+                            else [])
+                       ++ [ SysTools.Option "-x"
+                          , if with_cpp
+                              then SysTools.Option "assembler-with-cpp"
+                              else SysTools.Option "assembler"
+                          , SysTools.Option "-c"
+                          , SysTools.FileOption "" inputFilename
+                          , SysTools.Option "-o"
+                          , SysTools.FileOption "" outputFilename
+                          ])
+
+        liftIO $ debugTraceMsg dflags 4 (text "Running the assembler")
+        runAssembler input_fn output_fn
+        return (RealPhase next_phase, output_fn)
+
+
+-- This is for calling the assembler on a split assembly file (so a collection
+-- of assembly files)
+runPhase (RealPhase SplitAs) _input_fn dflags
+  = do
+        -- we'll handle the stub_o file in this phase, so don't MergeForeign,
+        -- just jump straight to StopLn afterwards.
+        let next_phase = StopLn
+        output_fn <- phaseOutputFilename next_phase
+
+        let base_o = dropExtension output_fn
+            osuf = objectSuf dflags
+            split_odir  = base_o ++ "_" ++ osuf ++ "_split"
+
+        let pic_c_flags = picCCOpts dflags
+
+        -- this also creates the hierarchy
+        liftIO $ createDirectoryIfMissing True split_odir
+
+        -- remove M_split/ *.o, because we're going to archive M_split/ *.o
+        -- later and we don't want to pick up any old objects.
+        fs <- liftIO $ getDirectoryContents split_odir
+        liftIO $ mapM_ removeFile $
+                map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
+
+        let (split_s_prefix, n) = case splitInfo dflags of
+                                  Nothing -> panic "No split info"
+                                  Just x -> x
+
+        let split_s   n = split_s_prefix ++ "__" ++ show n <.> "s"
+
+            split_obj :: Int -> FilePath
+            split_obj n = split_odir </>
+                          takeFileName base_o ++ "__" ++ show n <.> osuf
+
+        let assemble_file n
+              = SysTools.runAs dflags (
+
+        -- We only support SparcV9 and better because V8 lacks an atomic CAS
+        -- instruction so we have to make sure that the assembler accepts the
+        -- instruction set. Note that the user can still override this
+        -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
+        -- regardless of the ordering.
+        --
+        -- This is a temporary hack.
+                          (if platformArch (targetPlatform dflags) == ArchSPARC
+                           then [SysTools.Option "-mcpu=v9"]
+                           else []) ++
+
+                          -- See Note [-fPIC for assembler]
+                          map SysTools.Option pic_c_flags ++
+
+                          [ SysTools.Option "-c"
+                          , SysTools.Option "-o"
+                          , SysTools.FileOption "" (split_obj n)
+                          , SysTools.FileOption "" (split_s n)
+                          ])
+
+        liftIO $ mapM_ assemble_file [1..n]
+
+        -- Note [pipeline-split-init]
+        -- If we have a stub file -- which will be part of foreign_os --
+        --  it may contain constructor
+        -- functions for initialisation of this module.  We can't
+        -- simply leave the stub as a separate object file, because it
+        -- will never be linked in: nothing refers to it.  We need to
+        -- ensure that if we ever refer to the data in this module
+        -- that needs initialisation, then we also pull in the
+        -- initialisation routine.
+        --
+        -- To that end, we make a DANGEROUS ASSUMPTION here: the data
+        -- that needs to be initialised is all in the FIRST split
+        -- object.  See Note [codegen-split-init].
+        --
+        -- We also merge in all the foreign objects since we're at it.
+
+        PipeState{foreign_os} <- getPipeState
+        if null foreign_os
+          then return ()
+          else liftIO $ do
+             tmp_split_1 <- newTempName dflags TFL_CurrentModule osuf
+             let split_1 = split_obj 1
+             copyFile split_1 tmp_split_1
+             removeFile split_1
+             joinObjectFiles dflags (tmp_split_1 : foreign_os) split_1
+
+        -- join them into a single .o file
+        liftIO $ joinObjectFiles dflags (map split_obj [1..n]) output_fn
+
+        return (RealPhase next_phase, output_fn)
+
+-----------------------------------------------------------------------------
+-- LlvmOpt phase
+runPhase (RealPhase LlvmOpt) input_fn dflags
+  = do
+    output_fn <- phaseOutputFilename LlvmLlc
+
+    liftIO $ SysTools.runLlvmOpt dflags
+               (   optFlag
+                ++ defaultOptions ++
+                [ SysTools.FileOption "" input_fn
+                , SysTools.Option "-o"
+                , SysTools.FileOption "" output_fn]
+                )
+
+    return (RealPhase LlvmLlc, output_fn)
+  where
+        -- we always (unless -optlo specified) run Opt since we rely on it to
+        -- fix up some pretty big deficiencies in the code we generate
+        optIdx = max 0 $ min 2 $ optLevel dflags  -- ensure we're in [0,2]
+        llvmOpts = case lookup optIdx $ llvmPasses dflags of
+                    Just passes -> passes
+                    Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "
+                                      ++ "is missing passes for level "
+                                      ++ show optIdx)
+
+        -- don't specify anything if user has specified commands. We do this
+        -- for opt but not llc since opt is very specifically for optimisation
+        -- passes only, so if the user is passing us extra options we assume
+        -- they know what they are doing and don't get in the way.
+        optFlag = if null (getOpts dflags opt_lo)
+                  then map SysTools.Option $ words llvmOpts
+                  else []
+
+        defaultOptions = map SysTools.Option . concat . fmap words . fst
+                       $ unzip (llvmOptions dflags)
+
+-----------------------------------------------------------------------------
+-- LlvmLlc phase
+
+runPhase (RealPhase LlvmLlc) input_fn dflags
+  = do
+    next_phase <- if fastLlvmPipeline dflags
+                  then maybeMergeForeign
+                  -- hidden debugging flag '-dno-llvm-mangler' to skip mangling
+                  else case gopt Opt_NoLlvmMangler dflags of
+                         False                            -> return LlvmMangle
+                         True | gopt Opt_SplitObjs dflags -> return Splitter
+                         True                             -> return (As False)
+
+    output_fn <- phaseOutputFilename next_phase
+
+    liftIO $ SysTools.runLlvmLlc dflags
+                (  optFlag
+                ++ defaultOptions
+                ++ [ SysTools.FileOption "" input_fn
+                   , SysTools.Option "-o"
+                   , SysTools.FileOption "" output_fn
+                   ]
+                )
+
+    return (RealPhase next_phase, output_fn)
+  where
+    -- Note [Clamping of llc optimizations]
+    --
+    -- See #13724
+    --
+    -- we clamp the llc optimization between [1,2]. This is because passing -O0
+    -- to llc 3.9 or llc 4.0, the naive register allocator can fail with
+    --
+    --   Error while trying to spill R1 from class GPR: Cannot scavenge register
+    --   without an emergency spill slot!
+    --
+    -- Observed at least with target 'arm-unknown-linux-gnueabihf'.
+    --
+    --
+    -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile
+    --   rts/HeapStackCheck.cmm
+    --
+    -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s
+    -- 0  llc                      0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40
+    -- 1  llc                      0x0000000102ae69a6 SignalHandler(int) + 358
+    -- 2  libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26
+    -- 3  libsystem_c.dylib        0x00007fffc226498b __vfprintf + 17876
+    -- 4  llc                      0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699
+    -- 5  llc                      0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381
+    -- 6  llc                      0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457
+    -- 7  llc                      0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20
+    -- 8  llc                      0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134
+    -- 9  llc                      0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498
+    -- 10 llc                      0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67
+    -- 11 llc                      0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920
+    -- 12 llc                      0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133
+    -- 13 llc                      0x000000010195bf0b main + 491
+    -- 14 libdyld.dylib            0x00007fffc21e5235 start + 1
+    -- Stack dump:
+    -- 0.  Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s
+    -- 1.  Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'.
+    -- 2.  Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"'
+    --
+    -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa
+    --
+    llvmOpts = case optLevel dflags of
+      0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.
+      1 -> "-O1"
+      _ -> "-O2"
+
+    optFlag = if null (getOpts dflags opt_lc)
+              then map SysTools.Option $ words llvmOpts
+              else []
+
+    defaultOptions = map SysTools.Option . concat . fmap words . snd
+                   $ unzip (llvmOptions dflags)
+
+
+-----------------------------------------------------------------------------
+-- LlvmMangle phase
+
+runPhase (RealPhase LlvmMangle) input_fn dflags
+  = do
+      let next_phase = if gopt Opt_SplitObjs dflags then Splitter else As False
+      output_fn <- phaseOutputFilename next_phase
+      liftIO $ llvmFixupAsm dflags input_fn output_fn
+      return (RealPhase next_phase, output_fn)
+
+-----------------------------------------------------------------------------
+-- merge in stub objects
+
+runPhase (RealPhase MergeForeign) input_fn dflags
+ = do
+     PipeState{foreign_os} <- getPipeState
+     output_fn <- phaseOutputFilename StopLn
+     liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)
+     if null foreign_os
+       then panic "runPhase(MergeForeign): no foreign objects"
+       else do
+         liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn
+         return (RealPhase StopLn, output_fn)
+
+-- warning suppression
+runPhase (RealPhase other) _input_fn _dflags =
+   panic ("runPhase: don't know how to run phase " ++ show other)
+
+maybeMergeForeign :: CompPipeline Phase
+maybeMergeForeign
+ = do
+     PipeState{foreign_os} <- getPipeState
+     if null foreign_os then return StopLn else return MergeForeign
+
+getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation
+getLocation src_flavour mod_name = do
+    dflags <- getDynFlags
+
+    PipeEnv{ src_basename=basename,
+             src_suffix=suff } <- getPipeEnv
+    PipeState { maybe_loc=maybe_loc} <- getPipeState
+    case maybe_loc of
+        -- Build a ModLocation to pass to hscMain.
+        -- The source filename is rather irrelevant by now, but it's used
+        -- by hscMain for messages.  hscMain also needs
+        -- the .hi and .o filenames. If we already have a ModLocation
+        -- then simply update the extensions of the interface and object
+        -- files to match the DynFlags, otherwise use the logic in Finder.
+      Just l -> return $ l
+        { ml_hs_file = Just $ basename <.> suff
+        , ml_hi_file = ml_hi_file l -<.> hiSuf dflags
+        , ml_obj_file = ml_obj_file l -<.> objectSuf dflags
+        }
+      _ -> do
+        location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
+
+        -- Boot-ify it if necessary
+        let location2
+              | HsBootFile <- src_flavour = addBootSuffixLocnOut location1
+              | otherwise                 = location1
+
+
+        -- Take -ohi into account if present
+        -- This can't be done in mkHomeModuleLocation because
+        -- it only applies to the module being compiles
+        let ohi = outputHi dflags
+            location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
+                      | otherwise      = location2
+
+        -- Take -o into account if present
+        -- Very like -ohi, but we must *only* do this if we aren't linking
+        -- (If we're linking then the -o applies to the linked thing, not to
+        -- the object file for one module.)
+        -- Note the nasty duplication with the same computation in compileFile
+        -- above
+        let expl_o_file = outputFile dflags
+            location4 | Just ofile <- expl_o_file
+                      , isNoLink (ghcLink dflags)
+                      = location3 { ml_obj_file = ofile }
+                      | otherwise = location3
+        return location4
+
+-----------------------------------------------------------------------------
+-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
+
+getHCFilePackages :: FilePath -> IO [InstalledUnitId]
+getHCFilePackages filename =
+  Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
+    l <- hGetLine h
+    case l of
+      '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
+          return (map stringToInstalledUnitId (words rest))
+      _other ->
+          return []
+
+-----------------------------------------------------------------------------
+-- Static linking, of .o files
+
+-- The list of packages passed to link is the list of packages on
+-- which this program depends, as discovered by the compilation
+-- manager.  It is combined with the list of packages that the user
+-- specifies on the command line with -package flags.
+--
+-- In one-shot linking mode, we can't discover the package
+-- dependencies (because we haven't actually done any compilation or
+-- read any interface files), so the user must explicitly specify all
+-- the packages.
+
+{-
+Note [-Xlinker -rpath vs -Wl,-rpath]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+-Wl takes a comma-separated list of options which in the case of
+-Wl,-rpath -Wl,some,path,with,commas parses the path with commas
+as separate options.
+Buck, the build system, produces paths with commas in them.
+
+-Xlinker doesn't have this disadvantage and as far as I can tell
+it is supported by both gcc and clang. Anecdotally nvcc supports
+-Xlinker, but not -Wl.
+-}
+
+linkBinary :: DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
+linkBinary = linkBinary' False
+
+linkBinary' :: Bool -> DynFlags -> [FilePath] -> [InstalledUnitId] -> IO ()
+linkBinary' staticLink dflags o_files dep_packages = do
+    let platform = targetPlatform dflags
+        mySettings = settings dflags
+        verbFlags = getVerbFlags dflags
+        output_fn = exeFileName staticLink dflags
+
+    -- get the full list of packages to link with, by combining the
+    -- explicit packages with the auto packages and all of their
+    -- dependencies, and eliminating duplicates.
+
+    full_output_fn <- if isAbsolute output_fn
+                      then return output_fn
+                      else do d <- getCurrentDirectory
+                              return $ normalise (d </> output_fn)
+    pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
+    let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
+        get_pkg_lib_path_opts l
+         | osElfTarget (platformOS platform) &&
+           dynLibLoader dflags == SystemDependent &&
+           WayDyn `elem` ways dflags
+            = let libpath = if gopt Opt_RelativeDynlibPaths dflags
+                            then "$ORIGIN" </>
+                                 (l `makeRelativeTo` full_output_fn)
+                            else l
+                  -- See Note [-Xlinker -rpath vs -Wl,-rpath]
+                  rpath = if gopt Opt_RPath dflags
+                          then ["-Xlinker", "-rpath", "-Xlinker", libpath]
+                          else []
+                  -- Solaris 11's linker does not support -rpath-link option. It silently
+                  -- ignores it and then complains about next option which is -l<some
+                  -- dir> as being a directory and not expected object file, E.g
+                  -- ld: elf error: file
+                  -- /tmp/ghc-src/libraries/base/dist-install/build:
+                  -- elf_begin: I/O error: region read: Is a directory
+                  rpathlink = if (platformOS platform) == OSSolaris2
+                              then []
+                              else ["-Xlinker", "-rpath-link", "-Xlinker", l]
+              in ["-L" ++ l] ++ rpathlink ++ rpath
+         | osMachOTarget (platformOS platform) &&
+           dynLibLoader dflags == SystemDependent &&
+           WayDyn `elem` ways dflags &&
+           gopt Opt_RPath dflags
+            = let libpath = if gopt Opt_RelativeDynlibPaths dflags
+                            then "@loader_path" </>
+                                 (l `makeRelativeTo` full_output_fn)
+                            else l
+              in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]
+         | otherwise = ["-L" ++ l]
+
+    pkg_lib_path_opts <-
+      if gopt Opt_SingleLibFolder dflags
+      then do
+        libs <- getLibs dflags dep_packages
+        tmpDir <- newTempDir dflags
+        sequence_ [ copyFile lib (tmpDir </> basename)
+                  | (lib, basename) <- libs]
+        return [ "-L" ++ tmpDir ]
+      else pure pkg_lib_path_opts
+
+    let
+      dead_strip
+        | gopt Opt_WholeArchiveHsLibs dflags = []
+        | otherwise = if osSubsectionsViaSymbols (platformOS platform)
+                        then ["-Wl,-dead_strip"]
+                        else []
+    let lib_paths = libraryPaths dflags
+    let lib_path_opts = map ("-L"++) lib_paths
+
+    extraLinkObj <- mkExtraObjToLinkIntoBinary dflags
+    noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_packages
+
+    let
+      (pre_hs_libs, post_hs_libs)
+        | gopt Opt_WholeArchiveHsLibs dflags
+        = if platformOS platform == OSDarwin
+            then (["-Wl,-all_load"], [])
+              -- OS X does not have a flag to turn off -all_load
+            else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])
+        | otherwise
+        = ([],[])
+
+    pkg_link_opts <- do
+        (package_hs_libs, extra_libs, other_flags) <- getPackageLinkOpts dflags dep_packages
+        return $ if staticLink
+            then package_hs_libs -- If building an executable really means making a static
+                                 -- library (e.g. iOS), then we only keep the -l options for
+                                 -- HS packages, because libtool doesn't accept other options.
+                                 -- In the case of iOS these need to be added by hand to the
+                                 -- final link in Xcode.
+            else other_flags ++ dead_strip
+                  ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs
+                  ++ extra_libs
+                 -- -Wl,-u,<sym> contained in other_flags
+                 -- needs to be put before -l<package>,
+                 -- otherwise Solaris linker fails linking
+                 -- a binary with unresolved symbols in RTS
+                 -- which are defined in base package
+                 -- the reason for this is a note in ld(1) about
+                 -- '-u' option: "The placement of this option
+                 -- on the command line is significant.
+                 -- This option must be placed before the library
+                 -- that defines the symbol."
+
+    -- frameworks
+    pkg_framework_opts <- getPkgFrameworkOpts dflags platform dep_packages
+    let framework_opts = getFrameworkOpts dflags platform
+
+        -- probably _stub.o files
+    let extra_ld_inputs = ldInputs dflags
+
+    -- Here are some libs that need to be linked at the *end* of
+    -- the command line, because they contain symbols that are referred to
+    -- by the RTS.  We can't therefore use the ordinary way opts for these.
+    let debug_opts | WayDebug `elem` ways dflags = [
+#if defined(HAVE_LIBBFD)
+                        "-lbfd", "-liberty"
+#endif
+                         ]
+                   | otherwise                   = []
+
+        thread_opts | WayThreaded `elem` ways dflags = [
+#if NEED_PTHREAD_LIB
+                        "-lpthread"
+#endif
+                        ]
+                    | otherwise                      = []
+
+    rc_objs <- maybeCreateManifest dflags output_fn
+
+    let link = if staticLink
+                   then SysTools.runLibtool
+                   else SysTools.runLink
+    link dflags (
+                       map SysTools.Option verbFlags
+                      ++ [ SysTools.Option "-o"
+                         , SysTools.FileOption "" output_fn
+                         ]
+                      ++ libmLinkOpts
+                      ++ map SysTools.Option (
+                         []
+
+                      -- See Note [No PIE when linking]
+                      ++ picCCOpts dflags
+
+                      -- Permit the linker to auto link _symbol to _imp_symbol.
+                      -- This lets us link against DLLs without needing an "import library".
+                      ++ (if platformOS platform == OSMinGW32
+                          then ["-Wl,--enable-auto-import"]
+                          else [])
+
+                      -- '-no_compact_unwind'
+                      -- C++/Objective-C exceptions cannot use optimised
+                      -- stack unwinding code. The optimised form is the
+                      -- default in Xcode 4 on at least x86_64, and
+                      -- without this flag we're also seeing warnings
+                      -- like
+                      --     ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog
+                      -- on x86.
+                      ++ (if sLdSupportsCompactUnwind mySettings &&
+                             not staticLink &&
+                             (platformOS platform == OSDarwin) &&
+                             case platformArch platform of
+                               ArchX86 -> True
+                               ArchX86_64 -> True
+                               ArchARM {} -> True
+                               ArchARM64  -> True
+                               _ -> False
+                          then ["-Wl,-no_compact_unwind"]
+                          else [])
+
+                      -- '-Wl,-read_only_relocs,suppress'
+                      -- ld gives loads of warnings like:
+                      --     ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure
+                      -- when linking any program. We're not sure
+                      -- whether this is something we ought to fix, but
+                      -- for now this flags silences them.
+                      ++ (if platformOS   platform == OSDarwin &&
+                             platformArch platform == ArchX86 &&
+                             not staticLink
+                          then ["-Wl,-read_only_relocs,suppress"]
+                          else [])
+
+                      ++ (if sLdIsGnuLd mySettings &&
+                             not (gopt Opt_WholeArchiveHsLibs dflags)
+                          then ["-Wl,--gc-sections"]
+                          else [])
+
+                      ++ o_files
+                      ++ lib_path_opts)
+                      ++ extra_ld_inputs
+                      ++ map SysTools.Option (
+                         rc_objs
+                      ++ framework_opts
+                      ++ pkg_lib_path_opts
+                      ++ extraLinkObj:noteLinkObjs
+                      ++ pkg_link_opts
+                      ++ pkg_framework_opts
+                      ++ debug_opts
+                      ++ thread_opts
+                      ++ (if platformOS platform == OSDarwin
+                          then [ "-Wl,-dead_strip_dylibs" ]
+                          else [])
+                    ))
+
+exeFileName :: Bool -> DynFlags -> FilePath
+exeFileName staticLink dflags
+  | Just s <- outputFile dflags =
+      case platformOS (targetPlatform dflags) of
+          OSMinGW32 -> s <?.> "exe"
+          _         -> if staticLink
+                         then s <?.> "a"
+                         else s
+  | otherwise =
+      if platformOS (targetPlatform dflags) == OSMinGW32
+      then "main.exe"
+      else if staticLink
+           then "liba.a"
+           else "a.out"
+ where s <?.> ext | null (takeExtension s) = s <.> ext
+                  | otherwise              = s
+
+maybeCreateManifest
+   :: DynFlags
+   -> FilePath                          -- filename of executable
+   -> IO [FilePath]                     -- extra objects to embed, maybe
+maybeCreateManifest dflags exe_filename
+ | platformOS (targetPlatform dflags) == OSMinGW32 &&
+   gopt Opt_GenManifest dflags
+    = do let manifest_filename = exe_filename <.> "manifest"
+
+         writeFile manifest_filename $
+             "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
+             "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
+             "  <assemblyIdentity version=\"1.0.0.0\"\n"++
+             "     processorArchitecture=\"X86\"\n"++
+             "     name=\"" ++ dropExtension exe_filename ++ "\"\n"++
+             "     type=\"win32\"/>\n\n"++
+             "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
+             "    <security>\n"++
+             "      <requestedPrivileges>\n"++
+             "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
+             "        </requestedPrivileges>\n"++
+             "       </security>\n"++
+             "  </trustInfo>\n"++
+             "</assembly>\n"
+
+         -- Windows will find the manifest file if it is named
+         -- foo.exe.manifest. However, for extra robustness, and so that
+         -- we can move the binary around, we can embed the manifest in
+         -- the binary itself using windres:
+         if not (gopt Opt_EmbedManifest dflags) then return [] else do
+
+         rc_filename <- newTempName dflags TFL_CurrentModule "rc"
+         rc_obj_filename <-
+           newTempName dflags TFL_GhcSession (objectSuf dflags)
+
+         writeFile rc_filename $
+             "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
+               -- magic numbers :-)
+               -- show is a bit hackish above, but we need to escape the
+               -- backslashes in the path.
+
+         runWindres dflags $ map SysTools.Option $
+               ["--input="++rc_filename,
+                "--output="++rc_obj_filename,
+                "--output-format=coff"]
+               -- no FileOptions here: windres doesn't like seeing
+               -- backslashes, apparently
+
+         removeFile manifest_filename
+
+         return [rc_obj_filename]
+ | otherwise = return []
+
+
+linkDynLibCheck :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
+linkDynLibCheck dflags o_files dep_packages
+ = do
+    when (haveRtsOptsFlags dflags) $ do
+      putLogMsg dflags NoReason SevInfo noSrcSpan
+          (defaultUserStyle dflags)
+          (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
+           text "    Call hs_init_ghc() from your main() function to set these options.")
+
+    linkDynLib dflags o_files dep_packages
+
+-- | Linking a static lib will not really link anything. It will merely produce
+-- a static archive of all dependent static libraries. The resulting library
+-- will still need to be linked with any remaining link flags.
+linkStaticLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
+linkStaticLib dflags o_files dep_packages = do
+  let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]
+      modules = o_files ++ extra_ld_inputs
+      output_fn = exeFileName True dflags
+
+  full_output_fn <- if isAbsolute output_fn
+                    then return output_fn
+                    else do d <- getCurrentDirectory
+                            return $ normalise (d </> output_fn)
+  output_exists <- doesFileExist full_output_fn
+  (when output_exists) $ removeFile full_output_fn
+
+  pkg_cfgs <- getPreloadPackagesAnd dflags dep_packages
+  archives <- concat <$> mapM (collectArchives dflags) pkg_cfgs
+
+  ar <- foldl mappend
+        <$> (Archive <$> mapM loadObj modules)
+        <*> mapM loadAr archives
+
+  if sLdIsGnuLd (settings dflags)
+    then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar
+    else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar
+
+  -- run ranlib over the archive. write*Ar does *not* create the symbol index.
+  runRanlib dflags [SysTools.FileOption "" output_fn]
+
+-- -----------------------------------------------------------------------------
+-- Running CPP
+
+doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()
+doCpp dflags raw input_fn output_fn = do
+    let hscpp_opts = picPOpts dflags
+    let cmdline_include_paths = includePaths dflags
+
+    pkg_include_dirs <- getPackageIncludePath dflags []
+    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
+          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)
+    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
+          (includePathsQuote cmdline_include_paths)
+    let include_paths = include_paths_quote ++ include_paths_global
+
+    let verbFlags = getVerbFlags dflags
+
+    let cpp_prog args | raw       = SysTools.runCpp dflags args
+                      | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
+
+    let target_defs =
+          [ "-D" ++ HOST_OS     ++ "_BUILD_OS",
+            "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",
+            "-D" ++ TARGET_OS   ++ "_HOST_OS",
+            "-D" ++ TARGET_ARCH ++ "_HOST_ARCH" ]
+        -- remember, in code we *compile*, the HOST is the same our TARGET,
+        -- and BUILD is the same as our HOST.
+
+    let sse_defs =
+          [ "-D__SSE__"      | isSseEnabled      dflags ] ++
+          [ "-D__SSE2__"     | isSse2Enabled     dflags ] ++
+          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]
+
+    let avx_defs =
+          [ "-D__AVX__"      | isAvxEnabled      dflags ] ++
+          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] ++
+          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++
+          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++
+          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] ++
+          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]
+
+    backend_defs <- getBackendDefs dflags
+
+    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]
+    -- Default CPP defines in Haskell source
+    ghcVersionH <- getGhcVersionPathName dflags
+    let hsSourceCppOpts = [ "-include", ghcVersionH ]
+
+    -- MIN_VERSION macros
+    let uids = explicitPackages (pkgState dflags)
+        pkgs = catMaybes (map (lookupPackage dflags) uids)
+    mb_macro_include <-
+        if not (null pkgs) && gopt Opt_VersionMacros dflags
+            then do macro_stub <- newTempName dflags TFL_CurrentModule "h"
+                    writeFile macro_stub (generatePackageVersionMacros pkgs)
+                    -- Include version macros for every *exposed* package.
+                    -- Without -hide-all-packages and with a package database
+                    -- size of 1000 packages, it takes cpp an estimated 2
+                    -- milliseconds to process this file. See Trac #10970
+                    -- comment 8.
+                    return [SysTools.FileOption "-include" macro_stub]
+            else return []
+
+    cpp_prog       (   map SysTools.Option verbFlags
+                    ++ map SysTools.Option include_paths
+                    ++ map SysTools.Option hsSourceCppOpts
+                    ++ map SysTools.Option target_defs
+                    ++ map SysTools.Option backend_defs
+                    ++ map SysTools.Option th_defs
+                    ++ map SysTools.Option hscpp_opts
+                    ++ map SysTools.Option sse_defs
+                    ++ map SysTools.Option avx_defs
+                    ++ mb_macro_include
+        -- Set the language mode to assembler-with-cpp when preprocessing. This
+        -- alleviates some of the C99 macro rules relating to whitespace and the hash
+        -- operator, which we tend to abuse. Clang in particular is not very happy
+        -- about this.
+                    ++ [ SysTools.Option     "-x"
+                       , SysTools.Option     "assembler-with-cpp"
+                       , SysTools.Option     input_fn
+        -- We hackily use Option instead of FileOption here, so that the file
+        -- name is not back-slashed on Windows.  cpp is capable of
+        -- dealing with / in filenames, so it works fine.  Furthermore
+        -- if we put in backslashes, cpp outputs #line directives
+        -- with *double* backslashes.   And that in turn means that
+        -- our error messages get double backslashes in them.
+        -- In due course we should arrange that the lexer deals
+        -- with these \\ escapes properly.
+                       , SysTools.Option     "-o"
+                       , SysTools.FileOption "" output_fn
+                       ])
+
+getBackendDefs :: DynFlags -> IO [String]
+getBackendDefs dflags | hscTarget dflags == HscLlvm = do
+    llvmVer <- figureLlvmVersion dflags
+    return $ case llvmVer of
+               Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]
+               _      -> []
+  where
+    format (major, minor)
+      | minor >= 100 = error "getBackendDefs: Unsupported minor version"
+      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int
+
+getBackendDefs _ =
+    return []
+
+-- ---------------------------------------------------------------------------
+-- Macros (cribbed from Cabal)
+
+generatePackageVersionMacros :: [PackageConfig] -> String
+generatePackageVersionMacros pkgs = concat
+  -- Do not add any C-style comments. See Trac #3389.
+  [ generateMacros "" pkgname version
+  | pkg <- pkgs
+  , let version = packageVersion pkg
+        pkgname = map fixchar (packageNameString pkg)
+  ]
+
+fixchar :: Char -> Char
+fixchar '-' = '_'
+fixchar c   = c
+
+generateMacros :: String -> String -> Version -> String
+generateMacros prefix name version =
+  concat
+  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"
+  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"
+  ,"  (major1) <  ",major1," || \\\n"
+  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"
+  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"
+  ,"\n\n"
+  ]
+  where
+    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)
+
+-- ---------------------------------------------------------------------------
+-- join object files into a single relocatable object file, using ld -r
+
+{-
+Note [Produce big objects on Windows]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The Windows Portable Executable object format has a limit of 32k sections, which
+we tend to blow through pretty easily. Thankfully, there is a "big object"
+extension, which raises this limit to 2^32. However, it must be explicitly
+enabled in the toolchain:
+
+ * the assembler accepts the -mbig-obj flag, which causes it to produce a
+   bigobj-enabled COFF object.
+
+ * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name
+   suggests, this tells the linker to produce a bigobj-enabled COFF object, no a
+   PE executable.
+
+We must enable bigobj output in a few places:
+
+ * When merging object files (DriverPipeline.joinObjectFiles)
+
+ * When assembling (DriverPipeline.runPhase (RealPhase As ...))
+
+Unfortunately the big object format is not supported on 32-bit targets so
+none of this can be used in that case.
+-}
+
+joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
+joinObjectFiles dflags o_files output_fn = do
+  let mySettings = settings dflags
+      ldIsGnuLd = sLdIsGnuLd mySettings
+      osInfo = platformOS (targetPlatform dflags)
+      ld_r args cc = SysTools.runLink dflags ([
+                       SysTools.Option "-nostdlib",
+                       SysTools.Option "-Wl,-r"
+                     ]
+                        -- See Note [No PIE while linking] in DynFlags
+                     ++ (if sGccSupportsNoPie mySettings
+                          then [SysTools.Option "-no-pie"]
+                          else [])
+
+                     ++ (if any (cc ==) [Clang, AppleClang, AppleClang51]
+                          then []
+                          else [SysTools.Option "-nodefaultlibs"])
+                     ++ (if osInfo == OSFreeBSD
+                          then [SysTools.Option "-L/usr/lib"]
+                          else [])
+                        -- gcc on sparc sets -Wl,--relax implicitly, but
+                        -- -r and --relax are incompatible for ld, so
+                        -- disable --relax explicitly.
+                     ++ (if platformArch (targetPlatform dflags)
+                                `elem` [ArchSPARC, ArchSPARC64]
+                         && ldIsGnuLd
+                            then [SysTools.Option "-Wl,-no-relax"]
+                            else [])
+                        -- See Note [Produce big objects on Windows]
+                     ++ [ SysTools.Option "-Wl,--oformat,pe-bigobj-x86-64"
+                        | OSMinGW32 == osInfo
+                        , not $ target32Bit (targetPlatform dflags)
+                        ]
+                     ++ map SysTools.Option ld_build_id
+                     ++ [ SysTools.Option "-o",
+                          SysTools.FileOption "" output_fn ]
+                     ++ args)
+
+      -- suppress the generation of the .note.gnu.build-id section,
+      -- which we don't need and sometimes causes ld to emit a
+      -- warning:
+      ld_build_id | sLdSupportsBuildId mySettings = ["-Wl,--build-id=none"]
+                  | otherwise                     = []
+
+  ccInfo <- getCompilerInfo dflags
+  if ldIsGnuLd
+     then do
+          script <- newTempName dflags TFL_CurrentModule "ldscript"
+          cwd <- getCurrentDirectory
+          let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files
+          writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"
+          ld_r [SysTools.FileOption "" script] ccInfo
+     else if sLdSupportsFilelist mySettings
+     then do
+          filelist <- newTempName dflags TFL_CurrentModule "filelist"
+          writeFile filelist $ unlines o_files
+          ld_r [SysTools.Option "-Wl,-filelist",
+                SysTools.FileOption "-Wl," filelist] ccInfo
+     else do
+          ld_r (map (SysTools.FileOption "") o_files) ccInfo
+
+-- -----------------------------------------------------------------------------
+-- Misc.
+
+writeInterfaceOnlyMode :: DynFlags -> Bool
+writeInterfaceOnlyMode dflags =
+ gopt Opt_WriteInterface dflags &&
+ HscNothing == hscTarget dflags
+
+-- | Figure out if a source file was modified after an output file (or if we
+-- anyways need to consider the source file modified since the output is gone).
+sourceModified :: FilePath -- ^ destination file we are looking for
+               -> UTCTime  -- ^ last time of modification of source file
+               -> IO Bool  -- ^ do we need to regenerate the output?
+sourceModified dest_file src_timestamp = do
+  dest_file_exists <- doesFileExist dest_file
+  if not dest_file_exists
+    then return True       -- Need to recompile
+     else do t2 <- getModificationUTCTime dest_file
+             return (t2 <= src_timestamp)
+
+-- | What phase to run after one of the backend code generators has run
+hscPostBackendPhase :: DynFlags -> HscSource -> HscTarget -> Phase
+hscPostBackendPhase _ HsBootFile _    =  StopLn
+hscPostBackendPhase _ HsigFile _      =  StopLn
+hscPostBackendPhase dflags _ hsc_lang =
+  case hsc_lang of
+        HscC -> HCc
+        HscAsm | gopt Opt_SplitObjs dflags -> Splitter
+               | otherwise                 -> As False
+        HscLlvm        -> LlvmOpt
+        HscNothing     -> StopLn
+        HscInterpreted -> StopLn
+
+touchObjectFile :: DynFlags -> FilePath -> IO ()
+touchObjectFile dflags path = do
+  createDirectoryIfMissing True $ takeDirectory path
+  SysTools.touch dflags "Touching object file" path
+
+-- | Find out path to @ghcversion.h@ file
+getGhcVersionPathName :: DynFlags -> IO FilePath
+getGhcVersionPathName dflags = do
+  candidates <- case ghcVersionFile dflags of
+    Just path -> return [path]
+    Nothing -> (map (</> "ghcversion.h")) <$>
+               (getPackageIncludePath dflags [toInstalledUnitId rtsUnitId])
+
+  found <- filterM doesFileExist candidates
+  case found of
+      []    -> throwGhcExceptionIO (InstallationError
+                                    ("ghcversion.h missing; tried: "
+                                      ++ intercalate ", " candidates))
+      (x:_) -> return x
+
+-- Note [-fPIC for assembler]
+-- When compiling .c source file GHC's driver pipeline basically
+-- does the following two things:
+--   1. ${CC}              -S 'PIC_CFLAGS' source.c
+--   2. ${CC} -x assembler -c 'PIC_CFLAGS' source.S
+--
+-- Why do we need to pass 'PIC_CFLAGS' both to C compiler and assembler?
+-- Because on some architectures (at least sparc32) assembler also chooses
+-- the relocation type!
+-- Consider the following C module:
+--
+--     /* pic-sample.c */
+--     int v;
+--     void set_v (int n) { v = n; }
+--     int  get_v (void)  { return v; }
+--
+--     $ gcc -S -fPIC pic-sample.c
+--     $ gcc -c       pic-sample.s -o pic-sample.no-pic.o # incorrect binary
+--     $ gcc -c -fPIC pic-sample.s -o pic-sample.pic.o    # correct binary
+--
+--     $ objdump -r -d pic-sample.pic.o    > pic-sample.pic.o.od
+--     $ objdump -r -d pic-sample.no-pic.o > pic-sample.no-pic.o.od
+--     $ diff -u pic-sample.pic.o.od pic-sample.no-pic.o.od
+--
+-- Most of architectures won't show any difference in this test, but on sparc32
+-- the following assembly snippet:
+--
+--    sethi   %hi(_GLOBAL_OFFSET_TABLE_-8), %l7
+--
+-- generates two kinds or relocations, only 'R_SPARC_PC22' is correct:
+--
+--       3c:  2f 00 00 00     sethi  %hi(0), %l7
+--    -                       3c: R_SPARC_PC22        _GLOBAL_OFFSET_TABLE_-0x8
+--    +                       3c: R_SPARC_HI22        _GLOBAL_OFFSET_TABLE_-0x8
+
+{- Note [Don't normalise input filenames]
+
+Summary
+  We used to normalise input filenames when starting the unlit phase. This
+  broke hpc in `--make` mode with imported literate modules (#2991).
+
+Introduction
+  1) --main
+  When compiling a module with --main, GHC scans its imports to find out which
+  other modules it needs to compile too. It turns out that there is a small
+  difference between saying `ghc --make A.hs`, when `A` imports `B`, and
+  specifying both modules on the command line with `ghc --make A.hs B.hs`. In
+  the former case, the filename for B is inferred to be './B.hs' instead of
+  'B.hs'.
+
+  2) unlit
+  When GHC compiles a literate haskell file, the source code first needs to go
+  through unlit, which turns it into normal Haskell source code. At the start
+  of the unlit phase, in `Driver.Pipeline.runPhase`, we call unlit with the
+  option `-h` and the name of the original file. We used to normalise this
+  filename using System.FilePath.normalise, which among other things removes
+  an initial './'. unlit then uses that filename in #line directives that it
+  inserts in the transformed source code.
+
+  3) SrcSpan
+  A SrcSpan represents a portion of a source code file. It has fields
+  linenumber, start column, end column, and also a reference to the file it
+  originated from. The SrcSpans for a literate haskell file refer to the
+  filename that was passed to unlit -h.
+
+  4) -fhpc
+  At some point during compilation with -fhpc, in the function
+  `deSugar.Coverage.isGoodTickSrcSpan`, we compare the filename that a
+  `SrcSpan` refers to with the name of the file we are currently compiling.
+  For some reason I don't yet understand, they can sometimes legitimally be
+  different, and then hpc ignores that SrcSpan.
+
+Problem
+  When running `ghc --make -fhpc A.hs`, where `A.hs` imports the literate
+  module `B.lhs`, `B` is inferred to be in the file `./B.lhs` (1). At the
+  start of the unlit phase, the name `./B.lhs` is normalised to `B.lhs` (2).
+  Therefore the SrcSpans of `B` refer to the file `B.lhs` (3), but we are
+  still compiling `./B.lhs`. Hpc thinks these two filenames are different (4),
+  doesn't include ticks for B, and we have unhappy customers (#2991).
+
+Solution
+  Do not normalise `input_fn` when starting the unlit phase.
+
+Alternative solution
+  Another option would be to not compare the two filenames on equality, but to
+  use System.FilePath.equalFilePath. That function first normalises its
+  arguments. The problem is that by the time we need to do the comparison, the
+  filenames have been turned into FastStrings, probably for performance
+  reasons, so System.FilePath.equalFilePath can not be used directly.
+
+Archeology
+  The call to `normalise` was added in a commit called "Fix slash
+  direction on Windows with the new filePath code" (c9b6b5e8). The problem
+  that commit was addressing has since been solved in a different manner, in a
+  commit called "Fix the filename passed to unlit" (1eedbc6b). So the
+  `normalise` is no longer necessary.
+-}
diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/DynamicLoading.hs
@@ -0,0 +1,316 @@
+{-# LANGUAGE CPP, MagicHash #-}
+
+-- | Dynamically lookup up values from modules and loading them.
+module DynamicLoading (
+        initializePlugins,
+#if defined(GHCI)
+        -- * Loading plugins
+        loadFrontendPlugin,
+
+        -- * Force loading information
+        forceLoadModuleInterfaces,
+        forceLoadNameModuleInterface,
+        forceLoadTyCon,
+
+        -- * Finding names
+        lookupRdrNameInModuleForPlugins,
+
+        -- * Loading values
+        getValueSafely,
+        getHValueSafely,
+        lessUnsafeCoerce
+#else
+        pluginError
+#endif
+    ) where
+
+import GhcPrelude
+import DynFlags
+
+#if defined(GHCI)
+import Linker           ( linkModule, getHValue )
+import GHCi             ( wormhole )
+import SrcLoc           ( noSrcSpan )
+import Finder           ( findPluginModule, cannotFindModule )
+import TcRnMonad        ( initTcInteractive, initIfaceTcRn )
+import LoadIface        ( loadPluginInterface )
+import RdrName          ( RdrName, ImportSpec(..), ImpDeclSpec(..)
+                        , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName
+                        , gre_name, mkRdrQual )
+import OccName          ( OccName, mkVarOcc )
+import RnNames          ( gresFromAvails )
+import Plugins
+import PrelNames        ( pluginTyConName, frontendPluginTyConName )
+
+import HscTypes
+import GHCi.RemoteTypes ( HValue )
+import Type             ( Type, eqType, mkTyConTy, pprTyThingCategory )
+import TyCon            ( TyCon )
+import Name             ( Name, nameModule_maybe )
+import Id               ( idType )
+import Module           ( Module, ModuleName )
+import Panic
+import FastString
+import ErrUtils
+import Outputable
+import Exception
+import Hooks
+
+import Control.Monad     ( when, unless )
+import Data.Maybe        ( mapMaybe )
+import GHC.Exts          ( unsafeCoerce# )
+
+#else
+
+import HscTypes         ( HscEnv )
+import Module           ( ModuleName, moduleNameString )
+import Panic
+
+import Data.List        ( intercalate )
+import Control.Monad    ( unless )
+
+#endif
+
+-- | Loads the plugins specified in the pluginModNames field of the dynamic
+-- flags. Should be called after command line arguments are parsed, but before
+-- actual compilation starts. Idempotent operation. Should be re-called if
+-- pluginModNames or pluginModNameOpts changes.
+initializePlugins :: HscEnv -> DynFlags -> IO DynFlags
+#if !defined(GHCI)
+initializePlugins _ df
+  = do let pluginMods = pluginModNames df
+       unless (null pluginMods) (pluginError pluginMods)
+       return df
+#else
+initializePlugins hsc_env df
+  | map lpModuleName (cachedPlugins df)
+         == pluginModNames df -- plugins not changed
+     && all (\p -> paArguments (lpPlugin p)
+                       == argumentsForPlugin p (pluginModNameOpts df))
+            (cachedPlugins df) -- arguments not changed
+  = return df -- no need to reload plugins
+  | otherwise
+  = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df })
+       return $ df { cachedPlugins = loadedPlugins }
+  where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)
+#endif
+
+
+#if defined(GHCI)
+
+loadPlugins :: HscEnv -> IO [LoadedPlugin]
+loadPlugins hsc_env
+  = do { unless (null to_load) $
+           checkExternalInterpreter hsc_env
+       ; plugins <- mapM loadPlugin to_load
+       ; return $ zipWith attachOptions to_load plugins }
+  where
+    dflags  = hsc_dflags hsc_env
+    to_load = pluginModNames dflags
+
+    attachOptions mod_nm (plug, mod) =
+        LoadedPlugin (PluginWithArgs plug (reverse options)) mod
+      where
+        options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
+                            , opt_mod_nm == mod_nm ]
+    loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName hsc_env
+
+
+loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin
+loadFrontendPlugin hsc_env mod_name = do
+    checkExternalInterpreter hsc_env
+    fst <$> loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName
+                hsc_env mod_name
+
+-- #14335
+checkExternalInterpreter :: HscEnv -> IO ()
+checkExternalInterpreter hsc_env =
+    when (gopt Opt_ExternalInterpreter dflags) $
+      throwCmdLineError $ showSDoc dflags $
+        text "Plugins require -fno-external-interpreter"
+  where
+    dflags = hsc_dflags hsc_env
+
+loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface)
+loadPlugin' occ_name plugin_name hsc_env mod_name
+  = do { let plugin_rdr_name = mkRdrQual mod_name occ_name
+             dflags = hsc_dflags hsc_env
+       ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name
+                        plugin_rdr_name
+       ; case mb_name of {
+            Nothing ->
+                throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
+                          [ text "The module", ppr mod_name
+                          , text "did not export the plugin name"
+                          , ppr plugin_rdr_name ]) ;
+            Just (name, mod_iface) ->
+
+     do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name
+        ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
+        ; case mb_plugin of
+            Nothing ->
+                throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
+                          [ text "The value", ppr name
+                          , text "did not have the type"
+                          , ppr pluginTyConName, text "as required"])
+            Just plugin -> return (plugin, mod_iface) } } }
+
+
+-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used
+-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
+forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO ()
+forceLoadModuleInterfaces hsc_env doc modules
+    = (initTcInteractive hsc_env $
+       initIfaceTcRn $
+       mapM_ (loadPluginInterface doc) modules)
+      >> return ()
+
+-- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used
+-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
+forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO ()
+forceLoadNameModuleInterface hsc_env reason name = do
+    let name_modules = mapMaybe nameModule_maybe [name]
+    forceLoadModuleInterfaces hsc_env reason name_modules
+
+-- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if:
+--
+-- * The interface could not be loaded
+-- * The name is not that of a 'TyCon'
+-- * The name did not exist in the loaded module
+forceLoadTyCon :: HscEnv -> Name -> IO TyCon
+forceLoadTyCon hsc_env con_name = do
+    forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name
+
+    mb_con_thing <- lookupTypeHscEnv hsc_env con_name
+    case mb_con_thing of
+        Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name
+        Just (ATyCon tycon) -> return tycon
+        Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing
+  where dflags = hsc_dflags hsc_env
+
+-- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety
+-- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at!
+--
+-- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception:
+--
+-- * If we could not load the names module
+-- * If the thing being loaded is not a value
+-- * If the Name does not exist in the module
+-- * If the link failed
+
+getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)
+getValueSafely hsc_env val_name expected_type = do
+  mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type
+  case mb_hval of
+    Nothing   -> return Nothing
+    Just hval -> do
+      value <- lessUnsafeCoerce dflags "getValueSafely" hval
+      return (Just value)
+  where
+    dflags = hsc_dflags hsc_env
+
+getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue)
+getHValueSafely hsc_env val_name expected_type = do
+    forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name
+    -- Now look up the names for the value and type constructor in the type environment
+    mb_val_thing <- lookupTypeHscEnv hsc_env val_name
+    case mb_val_thing of
+        Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name
+        Just (AnId id) -> do
+            -- Check the value type in the interface against the type recovered from the type constructor
+            -- before finally casting the value to the type we assume corresponds to that constructor
+            if expected_type `eqType` idType id
+             then do
+                -- Link in the module that contains the value, if it has such a module
+                case nameModule_maybe val_name of
+                    Just mod -> do linkModule hsc_env mod
+                                   return ()
+                    Nothing ->  return ()
+                -- Find the value that we just linked in and cast it given that we have proved it's type
+                hval <- getHValue hsc_env val_name >>= wormhole dflags
+                return (Just hval)
+             else return Nothing
+        Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
+   where dflags = hsc_dflags hsc_env
+
+-- | Coerce a value as usual, but:
+--
+-- 1) Evaluate it immediately to get a segfault early if the coercion was wrong
+--
+-- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened
+--    if it /does/ segfault
+lessUnsafeCoerce :: DynFlags -> String -> a -> IO b
+lessUnsafeCoerce dflags context what = do
+    debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <>
+                             (text "...")
+    output <- evaluate (unsafeCoerce# what)
+    debugTraceMsg dflags 3 (text "Successfully evaluated coercion")
+    return output
+
+
+-- | Finds the 'Name' corresponding to the given 'RdrName' in the
+-- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name'
+-- could be found. Any other condition results in an exception:
+--
+-- * If the module could not be found
+-- * If we could not determine the imports of the module
+--
+-- Can only be used for looking up names while loading plugins (and is
+-- *not* suitable for use within plugins).  The interface file is
+-- loaded very partially: just enough that it can be used, without its
+-- rules and instances affecting (and being linked from!) the module
+-- being compiled.  This was introduced by 57d6798.
+--
+-- Need the module as well to record information in the interface file
+lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName
+                                -> IO (Maybe (Name, ModIface))
+lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
+    -- First find the package the module resides in by searching exposed packages and home modules
+    found_module <- findPluginModule hsc_env mod_name
+    case found_module of
+        Found _ mod -> do
+            -- Find the exports of the module
+            (_, mb_iface) <- initTcInteractive hsc_env $
+                             initIfaceTcRn $
+                             loadPluginInterface doc mod
+            case mb_iface of
+                Just iface -> do
+                    -- Try and find the required name in the exports
+                    let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name
+                                                , is_qual = False, is_dloc = noSrcSpan }
+                        imp_spec = ImpSpec decl_spec ImpAll
+                        env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface))
+                    case lookupGRE_RdrName rdr_name env of
+                        [gre] -> return (Just (gre_name gre, iface))
+                        []    -> return Nothing
+                        _     -> panic "lookupRdrNameInModule"
+
+                Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name]
+        err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err
+  where
+    dflags = hsc_dflags hsc_env
+    doc = text "contains a name used in an invocation of lookupRdrNameInModule"
+
+wrongTyThingError :: Name -> TyThing -> SDoc
+wrongTyThingError name got_thing = hsep [text "The name", ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing]
+
+missingTyThingError :: Name -> SDoc
+missingTyThingError name = hsep [text "The name", ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")]
+
+throwCmdLineErrorS :: DynFlags -> SDoc -> IO a
+throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags
+
+throwCmdLineError :: String -> IO a
+throwCmdLineError = throwGhcExceptionIO . CmdLineError
+
+#else
+
+pluginError :: [ModuleName] -> a
+pluginError modnames = throwGhcException (CmdLineError msg)
+  where
+    msg = "not built for interactive use - can't load plugins ("
+            -- module names are not z-encoded
+          ++ intercalate ", " (map moduleNameString modnames)
+          ++ ")"
+
+#endif
diff --git a/compiler/main/Elf.hs b/compiler/main/Elf.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/Elf.hs
@@ -0,0 +1,467 @@
+{-
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2015
+--
+-- ELF format tools
+--
+-----------------------------------------------------------------------------
+-}
+
+module Elf (
+    readElfSectionByName,
+    readElfNoteAsString,
+    makeElfNote
+  ) where
+
+import GhcPrelude
+
+import AsmUtils
+import Exception
+import DynFlags
+import ErrUtils
+import Maybes     (MaybeT(..),runMaybeT)
+import Util       (charToC)
+import Outputable (text,hcat,SDoc)
+
+import Control.Monad (when)
+import Data.Binary.Get
+import Data.Word
+import Data.Char (ord)
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Char8 as B8
+
+{- Note [ELF specification]
+   ~~~~~~~~~~~~~~~~~~~~~~~~
+
+   ELF (Executable and Linking Format) is described in the System V Application
+   Binary Interface (or ABI). The latter is composed of two parts: a generic
+   part and a processor specific part. The generic ABI describes the parts of
+   the interface that remain constant across all hardware implementations of
+   System V.
+
+   The latest release of the specification of the generic ABI is the version
+   4.1 from March 18, 1997:
+
+     - http://www.sco.com/developers/devspecs/gabi41.pdf
+
+   Since 1997, snapshots of the draft for the "next" version are published:
+
+     - http://www.sco.com/developers/gabi/
+
+   Quoting the notice on the website: "There is more than one instance of these
+   chapters to permit references to older instances to remain valid. All
+   modifications to these chapters are forward-compatible, so that correct use
+   of an older specification will not be invalidated by a newer instance.
+   Approximately on a yearly basis, a new instance will be saved, as it reaches
+   what appears to be a stable state."
+
+   Nevertheless we will see that since 1998 it is not true for Note sections.
+
+   Many ELF sections
+   -----------------
+
+   ELF-4.1: the normal section number fields in ELF are limited to 16 bits,
+   which runs out of bits when you try to cram in more sections than that. Two
+   fields are concerned: the one containing the number of the sections and the
+   one containing the index of the section that contains section's names. (The
+   same thing applies to the field containing the number of segments, but we
+   don't care about it here).
+
+   ELF-next: to solve this, theses fields in the ELF header have an escape
+   value (different for each case), and the actual section number is stashed
+   into unused fields in the first section header.
+
+   We support this extension as it is forward-compatible with ELF-4.1.
+   Moreover, GHC may generate objects with a lot of sections with the
+   "function-sections" feature (one section per function).
+
+   Note sections
+   -------------
+
+   Sections with type "note" (SHT_NOTE in the specification) are used to add
+   arbitrary data into an ELF file. An entry in a note section is composed of a
+   name, a type and a value.
+
+   ELF-4.1: "The note information in sections and program header elements holds
+   any number of entries, each of which is an array of 4-byte words in the
+   format of the target processor." Each entry has the following format:
+         | namesz |   Word32: size of the name string (including the ending \0)
+         | descsz |   Word32: size of the value
+         |  type  |   Word32: type of the note
+         |  name  |   Name string (with \0 padding to ensure 4-byte alignment)
+         |  ...   |
+         |  desc  |   Value (with \0 padding to ensure 4-byte alignment)
+         |  ...   |
+
+   ELF-next: "The note information in sections and program header elements
+   holds a variable amount of entries. In 64-bit objects (files with
+   e_ident[EI_CLASS] equal to ELFCLASS64), each entry is an array of 8-byte
+   words in the format of the target processor. In 32-bit objects (files with
+   e_ident[EI_CLASS] equal to ELFCLASS32), each entry is an array of 4-byte
+   words in the format of the target processor." (from 1998-2015 snapshots)
+
+   This is not forward-compatible with ELF-4.1. In practice, for almost all
+   platforms namesz, descz and type fields are 4-byte words for both 32-bit and
+   64-bit objects (see elf.h and readelf source code).
+
+   The only exception in readelf source code is for IA_64 machines with OpenVMS
+   OS: "This OS has so many departures from the ELF standard that we test it at
+   many places" (comment for is_ia64_vms() in readelf.c). In this case, namesz,
+   descsz and type fields are 8-byte words and name and value fields are padded
+   to ensure 8-byte alignment.
+
+   We don't support this platform in the following code. Reading a note section
+   could be done easily (by testing Machine and OS fields in the ELF header).
+   Writing a note section, however, requires that we generate a different
+   assembly code for GAS depending on the target platform and this is a little
+   bit more involved.
+
+-}
+
+
+-- | ELF header
+--
+-- The ELF header indicates the native word size (32-bit or 64-bit) and the
+-- endianness of the target machine. We directly store getters for words of
+-- different sizes as it is more convenient to use. We also store the word size
+-- as it is useful to skip some uninteresting fields.
+--
+-- Other information such as the target machine and OS are left out as we don't
+-- use them yet. We could add them in the future if we ever need them.
+data ElfHeader = ElfHeader
+   { gw16     :: Get Word16   -- ^ Get a Word16 with the correct endianness
+   , gw32     :: Get Word32   -- ^ Get a Word32 with the correct endianness
+   , gwN      :: Get Word64   -- ^ Get a Word with the correct word size
+                              --   and endianness
+   , wordSize :: Int          -- ^ Word size in bytes
+   }
+
+
+-- | Read the ELF header
+readElfHeader :: DynFlags -> ByteString -> IO (Maybe ElfHeader)
+readElfHeader dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do
+    debugTraceMsg dflags 3 $
+      text ("Unable to read ELF header")
+    return Nothing
+  where
+    getHeader = do
+      magic    <- getWord32be
+      ws       <- getWord8
+      endian   <- getWord8
+      version  <- getWord8
+      skip 9  -- skip OSABI, ABI version and padding
+      when (magic /= 0x7F454C46 || version /= 1) $ fail "Invalid ELF header"
+
+      case (ws, endian) of
+          -- ELF 32, little endian
+          (1,1) -> return . Just $ ElfHeader
+                           getWord16le
+                           getWord32le
+                           (fmap fromIntegral getWord32le) 4
+          -- ELF 32, big endian
+          (1,2) -> return . Just $ ElfHeader
+                           getWord16be
+                           getWord32be
+                           (fmap fromIntegral getWord32be) 4
+          -- ELF 64, little endian
+          (2,1) -> return . Just $ ElfHeader
+                           getWord16le
+                           getWord32le
+                           (fmap fromIntegral getWord64le) 8
+          -- ELF 64, big endian
+          (2,2) -> return . Just $ ElfHeader
+                           getWord16be
+                           getWord32be
+                           (fmap fromIntegral getWord64be) 8
+          _     -> fail "Invalid ELF header"
+
+
+------------------
+-- SECTIONS
+------------------
+
+
+-- | Description of the section table
+data SectionTable = SectionTable
+  { sectionTableOffset :: Word64  -- ^ offset of the table describing sections
+  , sectionEntrySize   :: Word16  -- ^ size of an entry in the section table
+  , sectionEntryCount  :: Word64  -- ^ number of sections
+  , sectionNameIndex   :: Word32  -- ^ index of a special section which
+                                  --   contains section's names
+  }
+
+-- | Read the ELF section table
+readElfSectionTable :: DynFlags
+                    -> ElfHeader
+                    -> ByteString
+                    -> IO (Maybe SectionTable)
+
+readElfSectionTable dflags hdr bs = action `catchIO` \_ -> do
+    debugTraceMsg dflags 3 $
+      text ("Unable to read ELF section table")
+    return Nothing
+  where
+    getSectionTable :: Get SectionTable
+    getSectionTable = do
+      skip (24 + 2*wordSize hdr) -- skip header and some other fields
+      secTableOffset <- gwN hdr
+      skip 10
+      entrySize      <- gw16 hdr
+      entryCount     <- gw16 hdr
+      secNameIndex   <- gw16 hdr
+      return (SectionTable secTableOffset entrySize
+                           (fromIntegral entryCount)
+                           (fromIntegral secNameIndex))
+
+    action = do
+      secTable <- runGetOrThrow getSectionTable bs
+      -- In some cases, the number of entries and the index of the section
+      -- containing section's names must be found in unused fields of the first
+      -- section entry (see Note [ELF specification])
+      let
+        offSize0 = fromIntegral $ sectionTableOffset secTable + 8
+                                  + 3 * fromIntegral (wordSize hdr)
+        offLink0 = fromIntegral $ offSize0 + fromIntegral (wordSize hdr)
+
+      entryCount'     <- if sectionEntryCount secTable /= 0
+                          then return (sectionEntryCount secTable)
+                          else runGetOrThrow (gwN hdr) (LBS.drop offSize0 bs)
+      entryNameIndex' <- if sectionNameIndex secTable /= 0xffff
+                          then return (sectionNameIndex secTable)
+                          else runGetOrThrow (gw32 hdr) (LBS.drop offLink0 bs)
+      return (Just $ secTable
+        { sectionEntryCount = entryCount'
+        , sectionNameIndex  = entryNameIndex'
+        })
+
+
+-- | A section
+data Section = Section
+  { entryName :: ByteString   -- ^ Name of the section
+  , entryBS   :: ByteString   -- ^ Content of the section
+  }
+
+-- | Read a ELF section
+readElfSectionByIndex :: DynFlags
+                      -> ElfHeader
+                      -> SectionTable
+                      -> Word64
+                      -> ByteString
+                      -> IO (Maybe Section)
+
+readElfSectionByIndex dflags hdr secTable i bs = action `catchIO` \_ -> do
+    debugTraceMsg dflags 3 $
+      text ("Unable to read ELF section")
+    return Nothing
+  where
+    -- read an entry from the section table
+    getEntry = do
+      nameIndex <- gw32 hdr
+      skip (4+2*wordSize hdr)
+      offset    <- fmap fromIntegral $ gwN hdr
+      size      <- fmap fromIntegral $ gwN hdr
+      let bs' = LBS.take size (LBS.drop offset bs)
+      return (nameIndex,bs')
+
+    -- read the entry with the given index in the section table
+    getEntryByIndex x = runGetOrThrow getEntry bs'
+      where
+        bs' = LBS.drop off bs
+        off = fromIntegral $ sectionTableOffset secTable +
+                             x * fromIntegral (sectionEntrySize secTable)
+
+    -- Get the name of a section
+    getEntryName nameIndex = do
+      let idx = fromIntegral (sectionNameIndex secTable)
+      (_,nameTable) <- getEntryByIndex idx
+      let bs' = LBS.drop nameIndex nameTable
+      runGetOrThrow getLazyByteStringNul bs'
+
+    action = do
+      (nameIndex,bs') <- getEntryByIndex (fromIntegral i)
+      name            <- getEntryName (fromIntegral nameIndex)
+      return (Just $ Section name bs')
+
+
+-- | Find a section from its name. Return the section contents.
+--
+-- We do not perform any check on the section type.
+findSectionFromName :: DynFlags
+                    -> ElfHeader
+                    -> SectionTable
+                    -> String
+                    -> ByteString
+                    -> IO (Maybe ByteString)
+findSectionFromName dflags hdr secTable name bs =
+    rec [0..sectionEntryCount secTable - 1]
+  where
+    -- convert the required section name into a ByteString to perform
+    -- ByteString comparison instead of String comparison
+    name' = B8.pack name
+
+    -- compare recursively each section name and return the contents of
+    -- the matching one, if any
+    rec []     = return Nothing
+    rec (x:xs) = do
+      me <- readElfSectionByIndex dflags hdr secTable x bs
+      case me of
+        Just e | entryName e == name' -> return (Just (entryBS e))
+        _                             -> rec xs
+
+
+-- | Given a section name, read its contents as a ByteString.
+--
+-- If the section isn't found or if there is any parsing error, we return
+-- Nothing
+readElfSectionByName :: DynFlags
+                     -> ByteString
+                     -> String
+                     -> IO (Maybe LBS.ByteString)
+
+readElfSectionByName dflags bs name = action `catchIO` \_ -> do
+    debugTraceMsg dflags 3 $
+      text ("Unable to read ELF section \"" ++ name ++ "\"")
+    return Nothing
+  where
+    action = runMaybeT $ do
+      hdr      <- MaybeT $ readElfHeader dflags bs
+      secTable <- MaybeT $ readElfSectionTable dflags hdr bs
+      MaybeT $ findSectionFromName dflags hdr secTable name bs
+
+------------------
+-- NOTE SECTIONS
+------------------
+
+-- | read a Note as a ByteString
+--
+-- If you try to read a note from a section which does not support the Note
+-- format, the parsing is likely to fail and Nothing will be returned
+readElfNoteBS :: DynFlags
+              -> ByteString
+              -> String
+              -> String
+              -> IO (Maybe LBS.ByteString)
+
+readElfNoteBS dflags bs sectionName noteId = action `catchIO`  \_ -> do
+    debugTraceMsg dflags 3 $
+         text ("Unable to read ELF note \"" ++ noteId ++
+               "\" in section \"" ++ sectionName ++ "\"")
+    return Nothing
+  where
+    -- align the getter on n bytes
+    align n = do
+      m <- bytesRead
+      if m `mod` n == 0
+        then return ()
+        else skip 1 >> align n
+
+    -- noteId as a bytestring
+    noteId' = B8.pack noteId
+
+    -- read notes recursively until the one with a valid identifier is found
+    findNote hdr = do
+      align 4
+      namesz <- gw32 hdr
+      descsz <- gw32 hdr
+      _      <- gw32 hdr -- we don't use the note type
+      name   <- if namesz == 0
+                  then return LBS.empty
+                  else getLazyByteStringNul
+      align 4
+      desc  <- if descsz == 0
+                  then return LBS.empty
+                  else getLazyByteString (fromIntegral descsz)
+      if name == noteId'
+        then return $ Just desc
+        else findNote hdr
+
+
+    action = runMaybeT $ do
+      hdr  <- MaybeT $ readElfHeader dflags bs
+      sec  <- MaybeT $ readElfSectionByName dflags bs sectionName
+      MaybeT $ runGetOrThrow (findNote hdr) sec
+
+-- | read a Note as a String
+--
+-- If you try to read a note from a section which does not support the Note
+-- format, the parsing is likely to fail and Nothing will be returned
+readElfNoteAsString :: DynFlags
+                    -> FilePath
+                    -> String
+                    -> String
+                    -> IO (Maybe String)
+
+readElfNoteAsString dflags path sectionName noteId = action `catchIO`  \_ -> do
+    debugTraceMsg dflags 3 $
+         text ("Unable to read ELF note \"" ++ noteId ++
+               "\" in section \"" ++ sectionName ++ "\"")
+    return Nothing
+  where
+    action = do
+      bs   <- LBS.readFile path
+      note <- readElfNoteBS dflags bs sectionName noteId
+      return (fmap B8.unpack note)
+
+
+-- | Generate the GAS code to create a Note section
+--
+-- Header fields for notes are 32-bit long (see Note [ELF specification]).
+--
+-- It seems there is no easy way to force GNU AS to generate a 32-bit word in
+-- every case. Hence we use .int directive to create them: however "The byte
+-- order and bit size of the number depends on what kind of target the assembly
+-- is for." (https://sourceware.org/binutils/docs/as/Int.html#Int)
+--
+-- If we add new target platforms, we need to check that the generated words
+-- are 32-bit long, otherwise we need to use platform specific directives to
+-- force 32-bit .int in asWord32.
+makeElfNote :: String -> String -> Word32 -> String -> SDoc
+makeElfNote sectionName noteName typ contents = hcat [
+    text "\t.section ",
+    text sectionName,
+    text ",\"\",",
+    sectionType "note",
+    text "\n",
+
+    -- note name length (+ 1 for ending \0)
+    asWord32 (length noteName + 1),
+
+    -- note contents size
+    asWord32 (length contents),
+
+    -- note type
+    asWord32 typ,
+
+    -- note name (.asciz for \0 ending string) + padding
+    text "\t.asciz \"",
+    text noteName,
+    text "\"\n",
+    text "\t.align 4\n",
+
+    -- note contents (.ascii to avoid ending \0) + padding
+    text "\t.ascii \"",
+    text (escape contents),
+    text "\"\n",
+    text "\t.align 4\n"]
+  where
+    escape :: String -> String
+    escape = concatMap (charToC.fromIntegral.ord)
+
+    asWord32 :: Show a => a -> SDoc
+    asWord32 x = hcat [
+      text "\t.int ",
+      text (show x),
+      text "\n"]
+
+
+------------------
+-- Helpers
+------------------
+
+-- | runGet in IO monad that throws an IOException on failure
+runGetOrThrow :: Get a -> LBS.ByteString -> IO a
+runGetOrThrow g bs = case runGetOrFail g bs of
+  Left _        -> fail "Error while reading file"
+  Right (_,_,a) -> return a
diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/Finder.hs
@@ -0,0 +1,833 @@
+{-
+(c) The University of Glasgow, 2000-2006
+
+\section[Finder]{Module Finder}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module Finder (
+    flushFinderCaches,
+    FindResult(..),
+    findImportedModule,
+    findPluginModule,
+    findExactModule,
+    findHomeModule,
+    findExposedPackageModule,
+    mkHomeModLocation,
+    mkHomeModLocation2,
+    mkHiOnlyModLocation,
+    mkHiPath,
+    mkObjPath,
+    addHomeModuleToFinder,
+    uncacheModule,
+    mkStubPaths,
+
+    findObjectLinkableMaybe,
+    findObjectLinkable,
+
+    cannotFindModule,
+    cannotFindInterface,
+
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Module
+import HscTypes
+import Packages
+import FastString
+import Util
+import PrelNames        ( gHC_PRIM )
+import DynFlags
+import Outputable
+import Maybes           ( expectJust )
+
+import Data.IORef       ( IORef, readIORef, atomicModifyIORef' )
+import System.Directory
+import System.FilePath
+import Control.Monad
+import Data.Time
+
+
+type FileExt = String   -- Filename extension
+type BaseName = String  -- Basename of file
+
+-- -----------------------------------------------------------------------------
+-- The Finder
+
+-- The Finder provides a thin filesystem abstraction to the rest of
+-- the compiler.  For a given module, it can tell you where the
+-- source, interface, and object files for that module live.
+
+-- It does *not* know which particular package a module lives in.  Use
+-- Packages.lookupModuleInAllPackages for that.
+
+-- -----------------------------------------------------------------------------
+-- The finder's cache
+
+-- remove all the home modules from the cache; package modules are
+-- assumed to not move around during a session.
+flushFinderCaches :: HscEnv -> IO ()
+flushFinderCaches hsc_env =
+  atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
+ where
+        this_pkg = thisPackage (hsc_dflags hsc_env)
+        fc_ref = hsc_FC hsc_env
+        is_ext mod _ | not (installedModuleUnitId mod `installedUnitIdEq` this_pkg) = True
+                     | otherwise = False
+
+addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()
+addToFinderCache ref key val =
+  atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())
+
+removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO ()
+removeFromFinderCache ref key =
+  atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())
+
+lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)
+lookupFinderCache ref key = do
+   c <- readIORef ref
+   return $! lookupInstalledModuleEnv c key
+
+-- -----------------------------------------------------------------------------
+-- The three external entry points
+
+-- | Locate a module that was imported by the user.  We have the
+-- module's name, and possibly a package name.  Without a package
+-- name, this function will use the search path and the known exposed
+-- packages to find the module, if a package is specified then only
+-- that package is searched for the module.
+
+findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
+findImportedModule hsc_env mod_name mb_pkg =
+  case mb_pkg of
+        Nothing                        -> unqual_import
+        Just pkg | pkg == fsLit "this" -> home_import -- "this" is special
+                 | otherwise           -> pkg_import
+  where
+    home_import   = findHomeModule hsc_env mod_name
+
+    pkg_import    = findExposedPackageModule hsc_env mod_name mb_pkg
+
+    unqual_import = home_import
+                    `orIfNotFound`
+                    findExposedPackageModule hsc_env mod_name Nothing
+
+-- | Locate a plugin module requested by the user, for a compiler
+-- plugin.  This consults the same set of exposed packages as
+-- 'findImportedModule', unless @-hide-all-plugin-packages@ or
+-- @-plugin-package@ are specified.
+findPluginModule :: HscEnv -> ModuleName -> IO FindResult
+findPluginModule hsc_env mod_name =
+  findHomeModule hsc_env mod_name
+  `orIfNotFound`
+  findExposedPluginPackageModule hsc_env mod_name
+
+-- | Locate a specific 'Module'.  The purpose of this function is to
+-- create a 'ModLocation' for a given 'Module', that is to find out
+-- where the files associated with this module live.  It is used when
+-- reading the interface for a module mentioned by another interface,
+-- for example (a "system import").
+
+findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
+findExactModule hsc_env mod =
+    let dflags = hsc_dflags hsc_env
+    in if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags
+       then findInstalledHomeModule hsc_env (installedModuleName mod)
+       else findPackageModule hsc_env mod
+
+-- -----------------------------------------------------------------------------
+-- Helpers
+
+-- | Given a monadic actions @this@ and @or_this@, first execute
+-- @this@.  If the returned 'FindResult' is successful, return
+-- it; otherwise, execute @or_this@.  If both failed, this function
+-- also combines their failure messages in a reasonable way.
+orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult
+orIfNotFound this or_this = do
+  res <- this
+  case res of
+    NotFound { fr_paths = paths1, fr_mods_hidden = mh1
+             , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 }
+     -> do res2 <- or_this
+           case res2 of
+             NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2
+                      , fr_pkgs_hidden = ph2, fr_unusables = u2
+                      , fr_suggestions = s2 }
+              -> return (NotFound { fr_paths = paths1 ++ paths2
+                                  , fr_pkg = mb_pkg2 -- snd arg is the package search
+                                  , fr_mods_hidden = mh1 ++ mh2
+                                  , fr_pkgs_hidden = ph1 ++ ph2
+                                  , fr_unusables = u1 ++ u2
+                                  , fr_suggestions = s1  ++ s2 })
+             _other -> return res2
+    _other -> return res
+
+-- | Helper function for 'findHomeModule': this function wraps an IO action
+-- which would look up @mod_name@ in the file system (the home package),
+-- and first consults the 'hsc_FC' cache to see if the lookup has already
+-- been done.  Otherwise, do the lookup (with the IO action) and save
+-- the result in the finder cache and the module location cache (if it
+-- was successful.)
+homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult
+homeSearchCache hsc_env mod_name do_this = do
+  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
+  modLocationCache hsc_env mod do_this
+
+findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString
+                         -> IO FindResult
+findExposedPackageModule hsc_env mod_name mb_pkg
+  = findLookupResult hsc_env
+  $ lookupModuleWithSuggestions
+        (hsc_dflags hsc_env) mod_name mb_pkg
+
+findExposedPluginPackageModule :: HscEnv -> ModuleName
+                               -> IO FindResult
+findExposedPluginPackageModule hsc_env mod_name
+  = findLookupResult hsc_env
+  $ lookupPluginModuleWithSuggestions
+        (hsc_dflags hsc_env) mod_name Nothing
+
+findLookupResult :: HscEnv -> LookupResult -> IO FindResult
+findLookupResult hsc_env r = case r of
+     LookupFound m pkg_conf -> do
+       let im = fst (splitModuleInsts m)
+       r' <- findPackageModule_ hsc_env im pkg_conf
+       case r' of
+        -- TODO: ghc -M is unlikely to do the right thing
+        -- with just the location of the thing that was
+        -- instantiated; you probably also need all of the
+        -- implicit locations from the instances
+        InstalledFound loc   _ -> return (Found loc m)
+        InstalledNoPackage   _ -> return (NoPackage (moduleUnitId m))
+        InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnitId m)
+                                         , fr_pkgs_hidden = []
+                                         , fr_mods_hidden = []
+                                         , fr_unusables = []
+                                         , fr_suggestions = []})
+     LookupMultiple rs ->
+       return (FoundMultiple rs)
+     LookupHidden pkg_hiddens mod_hiddens ->
+       return (NotFound{ fr_paths = [], fr_pkg = Nothing
+                       , fr_pkgs_hidden = map (moduleUnitId.fst) pkg_hiddens
+                       , fr_mods_hidden = map (moduleUnitId.fst) mod_hiddens
+                       , fr_unusables = []
+                       , fr_suggestions = [] })
+     LookupUnusable unusable ->
+       let unusables' = map get_unusable unusable
+           get_unusable (m, ModUnusable r) = (moduleUnitId m, r)
+           get_unusable (_, r)             =
+             pprPanic "findLookupResult: unexpected origin" (ppr r)
+       in return (NotFound{ fr_paths = [], fr_pkg = Nothing
+                          , fr_pkgs_hidden = []
+                          , fr_mods_hidden = []
+                          , fr_unusables = unusables'
+                          , fr_suggestions = [] })
+     LookupNotFound suggest ->
+       return (NotFound{ fr_paths = [], fr_pkg = Nothing
+                       , fr_pkgs_hidden = []
+                       , fr_mods_hidden = []
+                       , fr_unusables = []
+                       , fr_suggestions = suggest })
+
+modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
+modLocationCache hsc_env mod do_this = do
+  m <- lookupFinderCache (hsc_FC hsc_env) mod
+  case m of
+    Just result -> return result
+    Nothing     -> do
+        result <- do_this
+        addToFinderCache (hsc_FC hsc_env) mod result
+        return result
+
+mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule
+mkHomeInstalledModule dflags mod_name =
+  let iuid = fst (splitUnitIdInsts (thisPackage dflags))
+  in InstalledModule iuid mod_name
+
+-- This returns a module because it's more convenient for users
+addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
+addHomeModuleToFinder hsc_env mod_name loc = do
+  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
+  addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)
+  return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name)
+
+uncacheModule :: HscEnv -> ModuleName -> IO ()
+uncacheModule hsc_env mod_name = do
+  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
+  removeFromFinderCache (hsc_FC hsc_env) mod
+
+-- -----------------------------------------------------------------------------
+--      The internal workers
+
+findHomeModule :: HscEnv -> ModuleName -> IO FindResult
+findHomeModule hsc_env mod_name = do
+  r <- findInstalledHomeModule hsc_env mod_name
+  return $ case r of
+    InstalledFound loc _ -> Found loc (mkModule uid mod_name)
+    InstalledNoPackage _ -> NoPackage uid -- impossible
+    InstalledNotFound fps _ -> NotFound {
+        fr_paths = fps,
+        fr_pkg = Just uid,
+        fr_mods_hidden = [],
+        fr_pkgs_hidden = [],
+        fr_unusables = [],
+        fr_suggestions = []
+      }
+ where
+  dflags = hsc_dflags hsc_env
+  uid = thisPackage dflags
+
+-- | Implements the search for a module name in the home package only.  Calling
+-- this function directly is usually *not* what you want; currently, it's used
+-- as a building block for the following operations:
+--
+--  1. When you do a normal package lookup, we first check if the module
+--  is available in the home module, before looking it up in the package
+--  database.
+--
+--  2. When you have a package qualified import with package name "this",
+--  we shortcut to the home module.
+--
+--  3. When we look up an exact 'Module', if the unit id associated with
+--  the module is the current home module do a look up in the home module.
+--
+--  4. Some special-case code in GHCi (ToDo: Figure out why that needs to
+--  call this.)
+findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult
+findInstalledHomeModule hsc_env mod_name =
+   homeSearchCache hsc_env mod_name $
+   let
+     dflags = hsc_dflags hsc_env
+     home_path = importPaths dflags
+     hisuf = hiSuf dflags
+     mod = mkHomeInstalledModule dflags mod_name
+
+     source_exts =
+      [ ("hs",   mkHomeModLocationSearched dflags mod_name "hs")
+      , ("lhs",  mkHomeModLocationSearched dflags mod_name "lhs")
+      , ("hsig",  mkHomeModLocationSearched dflags mod_name "hsig")
+      , ("lhsig",  mkHomeModLocationSearched dflags mod_name "lhsig")
+      ]
+
+     hi_exts = [ (hisuf,                mkHiOnlyModLocation dflags hisuf)
+               , (addBootSuffix hisuf,  mkHiOnlyModLocation dflags hisuf)
+               ]
+
+        -- In compilation manager modes, we look for source files in the home
+        -- package because we can compile these automatically.  In one-shot
+        -- compilation mode we look for .hi and .hi-boot files only.
+     exts | isOneShot (ghcMode dflags) = hi_exts
+          | otherwise                  = source_exts
+   in
+
+  -- special case for GHC.Prim; we won't find it in the filesystem.
+  -- This is important only when compiling the base package (where GHC.Prim
+  -- is a home module).
+  if mod `installedModuleEq` gHC_PRIM
+        then return (InstalledFound (error "GHC.Prim ModLocation") mod)
+        else searchPathExts home_path mod exts
+
+
+-- | Search for a module in external packages only.
+findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
+findPackageModule hsc_env mod = do
+  let
+        dflags = hsc_dflags hsc_env
+        pkg_id = installedModuleUnitId mod
+  --
+  case lookupInstalledPackage dflags pkg_id of
+     Nothing -> return (InstalledNoPackage pkg_id)
+     Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf
+
+-- | Look up the interface file associated with module @mod@.  This function
+-- requires a few invariants to be upheld: (1) the 'Module' in question must
+-- be the module identifier of the *original* implementation of a module,
+-- not a reexport (this invariant is upheld by @Packages.hs@) and (2)
+-- the 'PackageConfig' must be consistent with the unit id in the 'Module'.
+-- The redundancy is to avoid an extra lookup in the package state
+-- for the appropriate config.
+findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult
+findPackageModule_ hsc_env mod pkg_conf =
+  ASSERT2( installedModuleUnitId mod == installedPackageConfigId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedPackageConfigId pkg_conf) )
+  modLocationCache hsc_env mod $
+
+  -- special case for GHC.Prim; we won't find it in the filesystem.
+  if mod `installedModuleEq` gHC_PRIM
+        then return (InstalledFound (error "GHC.Prim ModLocation") mod)
+        else
+
+  let
+     dflags = hsc_dflags hsc_env
+     tag = buildTag dflags
+
+           -- hi-suffix for packages depends on the build tag.
+     package_hisuf | null tag  = "hi"
+                   | otherwise = tag ++ "_hi"
+
+     mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf
+
+     import_dirs = importDirs pkg_conf
+      -- we never look for a .hi-boot file in an external package;
+      -- .hi-boot files only make sense for the home package.
+  in
+  case import_dirs of
+    [one] | MkDepend <- ghcMode dflags -> do
+          -- there's only one place that this .hi file can be, so
+          -- don't bother looking for it.
+          let basename = moduleNameSlashes (installedModuleName mod)
+          loc <- mk_hi_loc one basename
+          return (InstalledFound loc mod)
+    _otherwise ->
+          searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]
+
+-- -----------------------------------------------------------------------------
+-- General path searching
+
+searchPathExts
+  :: [FilePath]         -- paths to search
+  -> InstalledModule             -- module name
+  -> [ (
+        FileExt,                                -- suffix
+        FilePath -> BaseName -> IO ModLocation  -- action
+       )
+     ]
+  -> IO InstalledFindResult
+
+searchPathExts paths mod exts
+   = do result <- search to_search
+{-
+        hPutStrLn stderr (showSDoc $
+                vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts)
+                    , nest 2 (vcat (map text paths))
+                    , case result of
+                        Succeeded (loc, p) -> text "Found" <+> ppr loc
+                        Failed fs          -> text "not found"])
+-}
+        return result
+
+  where
+    basename = moduleNameSlashes (installedModuleName mod)
+
+    to_search :: [(FilePath, IO ModLocation)]
+    to_search = [ (file, fn path basename)
+                | path <- paths,
+                  (ext,fn) <- exts,
+                  let base | path == "." = basename
+                           | otherwise   = path </> basename
+                      file = base <.> ext
+                ]
+
+    search [] = return (InstalledNotFound (map fst to_search) (Just (installedModuleUnitId mod)))
+
+    search ((file, mk_result) : rest) = do
+      b <- doesFileExist file
+      if b
+        then do { loc <- mk_result; return (InstalledFound loc mod) }
+        else search rest
+
+mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt
+                          -> FilePath -> BaseName -> IO ModLocation
+mkHomeModLocationSearched dflags mod suff path basename = do
+   mkHomeModLocation2 dflags mod (path </> basename) suff
+
+-- -----------------------------------------------------------------------------
+-- Constructing a home module location
+
+-- This is where we construct the ModLocation for a module in the home
+-- package, for which we have a source file.  It is called from three
+-- places:
+--
+--  (a) Here in the finder, when we are searching for a module to import,
+--      using the search path (-i option).
+--
+--  (b) The compilation manager, when constructing the ModLocation for
+--      a "root" module (a source file named explicitly on the command line
+--      or in a :load command in GHCi).
+--
+--  (c) The driver in one-shot mode, when we need to construct a
+--      ModLocation for a source file named on the command-line.
+--
+-- Parameters are:
+--
+-- mod
+--      The name of the module
+--
+-- path
+--      (a): The search path component where the source file was found.
+--      (b) and (c): "."
+--
+-- src_basename
+--      (a): (moduleNameSlashes mod)
+--      (b) and (c): The filename of the source file, minus its extension
+--
+-- ext
+--      The filename extension of the source file (usually "hs" or "lhs").
+
+mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation
+mkHomeModLocation dflags mod src_filename = do
+   let (basename,extension) = splitExtension src_filename
+   mkHomeModLocation2 dflags mod basename extension
+
+mkHomeModLocation2 :: DynFlags
+                   -> ModuleName
+                   -> FilePath  -- Of source module, without suffix
+                   -> String    -- Suffix
+                   -> IO ModLocation
+mkHomeModLocation2 dflags mod src_basename ext = do
+   let mod_basename = moduleNameSlashes mod
+
+       obj_fn = mkObjPath  dflags src_basename mod_basename
+       hi_fn  = mkHiPath   dflags src_basename mod_basename
+       hie_fn = mkHiePath  dflags src_basename mod_basename
+
+   return (ModLocation{ ml_hs_file   = Just (src_basename <.> ext),
+                        ml_hi_file   = hi_fn,
+                        ml_obj_file  = obj_fn,
+                        ml_hie_file  = hie_fn })
+
+mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String
+                    -> IO ModLocation
+mkHiOnlyModLocation dflags hisuf path basename
+ = do let full_basename = path </> basename
+          obj_fn = mkObjPath  dflags full_basename basename
+          hie_fn = mkHiePath  dflags full_basename basename
+      return ModLocation{    ml_hs_file   = Nothing,
+                             ml_hi_file   = full_basename <.> hisuf,
+                                -- Remove the .hi-boot suffix from
+                                -- hi_file, if it had one.  We always
+                                -- want the name of the real .hi file
+                                -- in the ml_hi_file field.
+                             ml_obj_file  = obj_fn,
+                             ml_hie_file  = hie_fn
+                  }
+
+-- | Constructs the filename of a .o file for a given source file.
+-- Does /not/ check whether the .o file exists
+mkObjPath
+  :: DynFlags
+  -> FilePath           -- the filename of the source file, minus the extension
+  -> String             -- the module name with dots replaced by slashes
+  -> FilePath
+mkObjPath dflags basename mod_basename = obj_basename <.> osuf
+  where
+                odir = objectDir dflags
+                osuf = objectSuf dflags
+
+                obj_basename | Just dir <- odir = dir </> mod_basename
+                             | otherwise        = basename
+
+
+-- | Constructs the filename of a .hi file for a given source file.
+-- Does /not/ check whether the .hi file exists
+mkHiPath
+  :: DynFlags
+  -> FilePath           -- the filename of the source file, minus the extension
+  -> String             -- the module name with dots replaced by slashes
+  -> FilePath
+mkHiPath dflags basename mod_basename = hi_basename <.> hisuf
+ where
+                hidir = hiDir dflags
+                hisuf = hiSuf dflags
+
+                hi_basename | Just dir <- hidir = dir </> mod_basename
+                            | otherwise         = basename
+
+-- | Constructs the filename of a .hie file for a given source file.
+-- Does /not/ check whether the .hie file exists
+mkHiePath
+  :: DynFlags
+  -> FilePath           -- the filename of the source file, minus the extension
+  -> String             -- the module name with dots replaced by slashes
+  -> FilePath
+mkHiePath dflags basename mod_basename = hie_basename <.> hiesuf
+ where
+                hiedir = hieDir dflags
+                hiesuf = hieSuf dflags
+
+                hie_basename | Just dir <- hiedir = dir </> mod_basename
+                             | otherwise          = basename
+
+
+
+-- -----------------------------------------------------------------------------
+-- Filenames of the stub files
+
+-- We don't have to store these in ModLocations, because they can be derived
+-- from other available information, and they're only rarely needed.
+
+mkStubPaths
+  :: DynFlags
+  -> ModuleName
+  -> ModLocation
+  -> FilePath
+
+mkStubPaths dflags mod location
+  = let
+        stubdir = stubDir dflags
+
+        mod_basename = moduleNameSlashes mod
+        src_basename = dropExtension $ expectJust "mkStubPaths"
+                                                  (ml_hs_file location)
+
+        stub_basename0
+            | Just dir <- stubdir = dir </> mod_basename
+            | otherwise           = src_basename
+
+        stub_basename = stub_basename0 ++ "_stub"
+     in
+        stub_basename <.> "h"
+
+-- -----------------------------------------------------------------------------
+-- findLinkable isn't related to the other stuff in here,
+-- but there's no other obvious place for it
+
+findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)
+findObjectLinkableMaybe mod locn
+   = do let obj_fn = ml_obj_file locn
+        maybe_obj_time <- modificationTimeIfExists obj_fn
+        case maybe_obj_time of
+          Nothing -> return Nothing
+          Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time)
+
+-- Make an object linkable when we know the object file exists, and we know
+-- its modification time.
+findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable
+findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])
+  -- We used to look for _stub.o files here, but that was a bug (#706)
+  -- Now GHC merges the stub.o into the main .o (#3687)
+
+-- -----------------------------------------------------------------------------
+-- Error messages
+
+cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc
+cannotFindModule flags mod res =
+  cantFindErr (sLit cannotFindMsg)
+              (sLit "Ambiguous module name")
+              flags mod res
+  where
+    cannotFindMsg =
+      case res of
+        NotFound { fr_mods_hidden = hidden_mods
+                 , fr_pkgs_hidden = hidden_pkgs
+                 , fr_unusables = unusables }
+          | not (null hidden_mods && null hidden_pkgs && null unusables)
+          -> "Could not load module"
+        _ -> "Could not find module"
+
+cannotFindInterface  :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc
+cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")
+                                           (sLit "Ambiguous interface for")
+
+cantFindErr :: PtrString -> PtrString -> DynFlags -> ModuleName -> FindResult
+            -> SDoc
+cantFindErr _ multiple_found _ mod_name (FoundMultiple mods)
+  | Just pkgs <- unambiguousPackages
+  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (
+       sep [text "it was found in multiple packages:",
+                hsep (map ppr pkgs) ]
+    )
+  | otherwise
+  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (
+       vcat (map pprMod mods)
+    )
+  where
+    unambiguousPackages = foldl' unambiguousPackage (Just []) mods
+    unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)
+        = Just (moduleUnitId m : xs)
+    unambiguousPackage _ _ = Nothing
+
+    pprMod (m, o) = text "it is bound as" <+> ppr m <+>
+                                text "by" <+> pprOrigin m o
+    pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"
+    pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"
+    pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (
+      if e == Just True
+          then [text "package" <+> ppr (moduleUnitId m)]
+          else [] ++
+      map ((text "a reexport in package" <+>)
+                .ppr.packageConfigId) res ++
+      if f then [text "a package flag"] else []
+      )
+
+cantFindErr cannot_find _ dflags mod_name find_result
+  = ptext cannot_find <+> quotes (ppr mod_name)
+    $$ more_info
+  where
+    more_info
+      = case find_result of
+            NoPackage pkg
+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>
+                   text "was found"
+
+            NotFound { fr_paths = files, fr_pkg = mb_pkg
+                     , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens
+                     , fr_unusables = unusables, fr_suggestions = suggest }
+                | Just pkg <- mb_pkg, pkg /= thisPackage dflags
+                -> not_found_in_package pkg files
+
+                | not (null suggest)
+                -> pp_suggestions suggest $$ tried_these files dflags
+
+                | null files && null mod_hiddens &&
+                  null pkg_hiddens && null unusables
+                -> text "It is not a module in the current program, or in any known package."
+
+                | otherwise
+                -> vcat (map pkg_hidden pkg_hiddens) $$
+                   vcat (map mod_hidden mod_hiddens) $$
+                   vcat (map unusable unusables) $$
+                   tried_these files dflags
+
+            _ -> panic "cantFindErr"
+
+    build_tag = buildTag dflags
+
+    not_found_in_package pkg files
+       | build_tag /= ""
+       = let
+            build = if build_tag == "p" then "profiling"
+                                        else "\"" ++ build_tag ++ "\""
+         in
+         text "Perhaps you haven't installed the " <> text build <>
+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$
+         tried_these files dflags
+
+       | otherwise
+       = text "There are files missing in the " <> quotes (ppr pkg) <>
+         text " package," $$
+         text "try running 'ghc-pkg check'." $$
+         tried_these files dflags
+
+    pkg_hidden :: UnitId -> SDoc
+    pkg_hidden pkgid =
+        text "It is a member of the hidden package"
+        <+> quotes (ppr pkgid)
+        --FIXME: we don't really want to show the unit id here we should
+        -- show the source package id or installed package id if it's ambiguous
+        <> dot $$ pkg_hidden_hint pkgid
+    pkg_hidden_hint pkgid
+     | gopt Opt_BuildingCabalPackage dflags
+        = let pkg = expectJust "pkg_hidden" (lookupPackage dflags pkgid)
+           in text "Perhaps you need to add" <+>
+              quotes (ppr (packageName pkg)) <+>
+              text "to the build-depends in your .cabal file."
+     | Just pkg <- lookupPackage dflags pkgid
+         = text "You can run" <+>
+           quotes (text ":set -package " <> ppr (packageName pkg)) <+>
+           text "to expose it." $$
+           text "(Note: this unloads all the modules in the current scope.)"
+     | otherwise = Outputable.empty
+
+    mod_hidden pkg =
+        text "it is a hidden module in the package" <+> quotes (ppr pkg)
+
+    unusable (pkg, reason)
+      = text "It is a member of the package"
+      <+> quotes (ppr pkg)
+      $$ pprReason (text "which is") reason
+
+    pp_suggestions :: [ModuleSuggestion] -> SDoc
+    pp_suggestions sugs
+      | null sugs = Outputable.empty
+      | otherwise = hang (text "Perhaps you meant")
+                       2 (vcat (map pp_sugg sugs))
+
+    -- NB: Prefer the *original* location, and then reexports, and then
+    -- package flags when making suggestions.  ToDo: if the original package
+    -- also has a reexport, prefer that one
+    pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o
+      where provenance ModHidden = Outputable.empty
+            provenance (ModUnusable _) = Outputable.empty
+            provenance (ModOrigin{ fromOrigPackage = e,
+                                   fromExposedReexport = res,
+                                   fromPackageFlag = f })
+              | Just True <- e
+                 = parens (text "from" <+> ppr (moduleUnitId mod))
+              | f && moduleName mod == m
+                 = parens (text "from" <+> ppr (moduleUnitId mod))
+              | (pkg:_) <- res
+                 = parens (text "from" <+> ppr (packageConfigId pkg)
+                    <> comma <+> text "reexporting" <+> ppr mod)
+              | f
+                 = parens (text "defined via package flags to be"
+                    <+> ppr mod)
+              | otherwise = Outputable.empty
+    pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o
+      where provenance ModHidden =  Outputable.empty
+            provenance (ModUnusable _) = Outputable.empty
+            provenance (ModOrigin{ fromOrigPackage = e,
+                                   fromHiddenReexport = rhs })
+              | Just False <- e
+                 = parens (text "needs flag -package-key"
+                    <+> ppr (moduleUnitId mod))
+              | (pkg:_) <- rhs
+                 = parens (text "needs flag -package-id"
+                    <+> ppr (packageConfigId pkg))
+              | otherwise = Outputable.empty
+
+cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName
+                     -> InstalledFindResult -> SDoc
+cantFindInstalledErr cannot_find _ dflags mod_name find_result
+  = ptext cannot_find <+> quotes (ppr mod_name)
+    $$ more_info
+  where
+    more_info
+      = case find_result of
+            InstalledNoPackage pkg
+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>
+                   text "was found" $$ looks_like_srcpkgid pkg
+
+            InstalledNotFound files mb_pkg
+                | Just pkg <- mb_pkg, not (pkg `installedUnitIdEq` thisPackage dflags)
+                -> not_found_in_package pkg files
+
+                | null files
+                -> text "It is not a module in the current program, or in any known package."
+
+                | otherwise
+                -> tried_these files dflags
+
+            _ -> panic "cantFindInstalledErr"
+
+    build_tag = buildTag dflags
+
+    looks_like_srcpkgid :: InstalledUnitId -> SDoc
+    looks_like_srcpkgid pk
+     -- Unsafely coerce a unit id FastString into a source package ID
+     -- FastString and see if it means anything.
+     | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (installedUnitIdFS pk))
+     = parens (text "This unit ID looks like the source package ID;" $$
+       text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$
+       (if null pkgs then Outputable.empty
+        else text "and" <+> int (length pkgs) <+> text "other candidates"))
+     -- Todo: also check if it looks like a package name!
+     | otherwise = Outputable.empty
+
+    not_found_in_package pkg files
+       | build_tag /= ""
+       = let
+            build = if build_tag == "p" then "profiling"
+                                        else "\"" ++ build_tag ++ "\""
+         in
+         text "Perhaps you haven't installed the " <> text build <>
+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$
+         tried_these files dflags
+
+       | otherwise
+       = text "There are files missing in the " <> quotes (ppr pkg) <>
+         text " package," $$
+         text "try running 'ghc-pkg check'." $$
+         tried_these files dflags
+
+tried_these :: [FilePath] -> DynFlags -> SDoc
+tried_these files dflags
+    | null files = Outputable.empty
+    | verbosity dflags < 3 =
+          text "Use -v (or `:set -v` in ghci) " <>
+              text "to see a list of the files searched for."
+    | otherwise =
+          hang (text "Locations searched:") 2 $ vcat (map text files)
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/GHC.hs
@@ -0,0 +1,1562 @@
+{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections, NamedFieldPuns #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2005-2012
+--
+-- The GHC API
+--
+-- -----------------------------------------------------------------------------
+
+module GHC (
+        -- * Initialisation
+        defaultErrorHandler,
+        defaultCleanupHandler,
+        prettyPrintGhcErrors,
+        withSignalHandlers,
+        withCleanupSession,
+
+        -- * GHC Monad
+        Ghc, GhcT, GhcMonad(..), HscEnv,
+        runGhc, runGhcT, initGhcMonad,
+        gcatch, gbracket, gfinally,
+        printException,
+        handleSourceError,
+        needsTemplateHaskellOrQQ,
+
+        -- * Flags and settings
+        DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt,
+        GhcMode(..), GhcLink(..), defaultObjectTarget,
+        parseDynamicFlags,
+        getSessionDynFlags, setSessionDynFlags,
+        getProgramDynFlags, setProgramDynFlags, setLogAction,
+        getInteractiveDynFlags, setInteractiveDynFlags,
+
+        -- * Targets
+        Target(..), TargetId(..), Phase,
+        setTargets,
+        getTargets,
+        addTarget,
+        removeTarget,
+        guessTarget,
+
+        -- * Loading\/compiling the program
+        depanal,
+        load, LoadHowMuch(..), InteractiveImport(..),
+        SuccessFlag(..), succeeded, failed,
+        defaultWarnErrLogger, WarnErrLogger,
+        workingDirectoryChanged,
+        parseModule, typecheckModule, desugarModule, loadModule,
+        ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),
+        TypecheckedSource, ParsedSource, RenamedSource,   -- ditto
+        TypecheckedMod, ParsedMod,
+        moduleInfo, renamedSource, typecheckedSource,
+        parsedSource, coreModule,
+
+        -- ** Compiling to Core
+        CoreModule(..),
+        compileToCoreModule, compileToCoreSimplified,
+
+        -- * Inspecting the module structure of the program
+        ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
+        mgLookupModule,
+        ModSummary(..), ms_mod_name, ModLocation(..),
+        getModSummary,
+        getModuleGraph,
+        isLoaded,
+        topSortModuleGraph,
+
+        -- * Inspecting modules
+        ModuleInfo,
+        getModuleInfo,
+        modInfoTyThings,
+        modInfoTopLevelScope,
+        modInfoExports,
+        modInfoExportsWithSelectors,
+        modInfoInstances,
+        modInfoIsExportedName,
+        modInfoLookupName,
+        modInfoIface,
+        modInfoSafe,
+        lookupGlobalName,
+        findGlobalAnns,
+        mkPrintUnqualifiedForModule,
+        ModIface(..),
+        SafeHaskellMode(..),
+
+        -- * Querying the environment
+        -- packageDbModules,
+
+        -- * Printing
+        PrintUnqualified, alwaysQualify,
+
+        -- * Interactive evaluation
+
+        -- ** Executing statements
+        execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..),
+        resumeExec,
+
+        -- ** Adding new declarations
+        runDecls, runDeclsWithLocation, runParsedDecls,
+
+        -- ** Get/set the current context
+        parseImportDecl,
+        setContext, getContext,
+        setGHCiMonad, getGHCiMonad,
+
+        -- ** Inspecting the current context
+        getBindings, getInsts, getPrintUnqual,
+        findModule, lookupModule,
+        isModuleTrusted, moduleTrustReqs,
+        getNamesInScope,
+        getRdrNamesInScope,
+        getGRE,
+        moduleIsInterpreted,
+        getInfo,
+        showModule,
+        moduleIsBootOrNotObjectLinkable,
+        getNameToInstancesIndex,
+
+        -- ** Inspecting types and kinds
+        exprType, TcRnExprMode(..),
+        typeKind,
+
+        -- ** Looking up a Name
+        parseName,
+        lookupName,
+
+        -- ** Compiling expressions
+        HValue, parseExpr, compileParsedExpr,
+        InteractiveEval.compileExpr, dynCompileExpr,
+        ForeignHValue,
+        compileExprRemote, compileParsedExprRemote,
+
+        -- ** Docs
+        getDocs, GetDocsFailure(..),
+
+        -- ** Other
+        runTcInteractive,   -- Desired by some clients (Trac #8878)
+        isStmt, hasImport, isImport, isDecl,
+
+        -- ** The debugger
+        SingleStep(..),
+        Resume(..),
+        History(historyBreakInfo, historyEnclosingDecls),
+        GHC.getHistorySpan, getHistoryModule,
+        abandon, abandonAll,
+        getResumeContext,
+        GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,
+        modInfoModBreaks,
+        ModBreaks(..), BreakIndex,
+        BreakInfo(breakInfo_number, breakInfo_module),
+        InteractiveEval.back,
+        InteractiveEval.forward,
+
+        -- * Abstract syntax elements
+
+        -- ** Packages
+        UnitId,
+
+        -- ** Modules
+        Module, mkModule, pprModule, moduleName, moduleUnitId,
+        ModuleName, mkModuleName, moduleNameString,
+
+        -- ** Names
+        Name,
+        isExternalName, nameModule, pprParenSymName, nameSrcSpan,
+        NamedThing(..),
+        RdrName(Qual,Unqual),
+
+        -- ** Identifiers
+        Id, idType,
+        isImplicitId, isDeadBinder,
+        isExportedId, isLocalId, isGlobalId,
+        isRecordSelector,
+        isPrimOpId, isFCallId, isClassOpId_maybe,
+        isDataConWorkId, idDataCon,
+        isBottomingId, isDictonaryId,
+        recordSelectorTyCon,
+
+        -- ** Type constructors
+        TyCon,
+        tyConTyVars, tyConDataCons, tyConArity,
+        isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon,
+        isPrimTyCon, isFunTyCon,
+        isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon,
+        tyConClass_maybe,
+        synTyConRhs_maybe, synTyConDefn_maybe, tyConKind,
+
+        -- ** Type variables
+        TyVar,
+        alphaTyVars,
+
+        -- ** Data constructors
+        DataCon,
+        dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
+        dataConIsInfix, isVanillaDataCon, dataConUserType,
+        dataConSrcBangs,
+        StrictnessMark(..), isMarkedStrict,
+
+        -- ** Classes
+        Class,
+        classMethods, classSCTheta, classTvsFds, classATs,
+        pprFundeps,
+
+        -- ** Instances
+        ClsInst,
+        instanceDFunId,
+        pprInstance, pprInstanceHdr,
+        pprFamInst,
+
+        FamInst,
+
+        -- ** Types and Kinds
+        Type, splitForAllTys, funResultTy,
+        pprParendType, pprTypeApp,
+        Kind,
+        PredType,
+        ThetaType, pprForAll, pprThetaArrowTy,
+
+        -- ** Entities
+        TyThing(..),
+
+        -- ** Syntax
+        module HsSyn, -- ToDo: remove extraneous bits
+
+        -- ** Fixities
+        FixityDirection(..),
+        defaultFixity, maxPrecedence,
+        negateFixity,
+        compareFixity,
+        LexicalFixity(..),
+
+        -- ** Source locations
+        SrcLoc(..), RealSrcLoc,
+        mkSrcLoc, noSrcLoc,
+        srcLocFile, srcLocLine, srcLocCol,
+        SrcSpan(..), RealSrcSpan,
+        mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
+        srcSpanStart, srcSpanEnd,
+        srcSpanFile,
+        srcSpanStartLine, srcSpanEndLine,
+        srcSpanStartCol, srcSpanEndCol,
+
+        -- ** Located
+        GenLocated(..), Located,
+
+        -- *** Constructing Located
+        noLoc, mkGeneralLocated,
+
+        -- *** Deconstructing Located
+        getLoc, unLoc,
+        getRealSrcSpan, unRealSrcSpan,
+
+        -- ** HasSrcSpan
+        HasSrcSpan(..), SrcSpanLess, dL, cL,
+
+        -- *** Combining and comparing Located values
+        eqLocated, cmpLocated, combineLocs, addCLoc,
+        leftmost_smallest, leftmost_largest, rightmost,
+        spans, isSubspanOf,
+
+        -- * Exceptions
+        GhcException(..), showGhcException,
+
+        -- * Token stream manipulations
+        Token,
+        getTokenStream, getRichTokenStream,
+        showRichTokenStream, addSourceToTokens,
+
+        -- * Pure interface to the parser
+        parser,
+
+        -- * API Annotations
+        ApiAnns,AnnKeywordId(..),AnnotationComment(..),
+        getAnnotation, getAndRemoveAnnotation,
+        getAnnotationComments, getAndRemoveAnnotationComments,
+        unicodeAnn,
+
+        -- * Miscellaneous
+        --sessionHscEnv,
+        cyclicModuleErr,
+  ) where
+
+{-
+ ToDo:
+
+  * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
+-}
+
+#include "HsVersions.h"
+
+import GhcPrelude hiding (init)
+
+import ByteCodeTypes
+import InteractiveEval
+import InteractiveEvalTypes
+import GHCi
+import GHCi.RemoteTypes
+
+import PprTyThing       ( pprFamInst )
+import HscMain
+import GhcMake
+import DriverPipeline   ( compileOne' )
+import GhcMonad
+import TcRnMonad        ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
+import LoadIface        ( loadSysInterface )
+import TcRnTypes
+import Packages
+import NameSet
+import RdrName
+import HsSyn
+import Type     hiding( typeKind )
+import TcType           hiding( typeKind )
+import Id
+import TysPrim          ( alphaTyVars )
+import TyCon
+import Class
+import DataCon
+import Name             hiding ( varName )
+import Avail
+import InstEnv
+import FamInstEnv ( FamInst )
+import SrcLoc
+import CoreSyn
+import TidyPgm
+import DriverPhases     ( Phase(..), isHaskellSrcFilename )
+import Finder
+import HscTypes
+import CmdLineParser
+import DynFlags hiding (WarnReason(..))
+import SysTools
+import SysTools.BaseDir
+import Annotations
+import Module
+import Panic
+import Platform
+import Bag              ( listToBag, unitBag )
+import ErrUtils
+import MonadUtils
+import Util
+import StringBuffer
+import Outputable
+import BasicTypes
+import Maybes           ( expectJust )
+import FastString
+import qualified Parser
+import Lexer
+import ApiAnnotation
+import qualified GHC.LanguageExtensions as LangExt
+import NameEnv
+import CoreFVs          ( orphNamesOfFamInst )
+import FamInstEnv       ( famInstEnvElts )
+import TcRnDriver
+import Inst
+import FamInst
+import FileCleanup
+
+import Data.Foldable
+import qualified Data.Map.Strict as Map
+import Data.Set (Set)
+import qualified Data.Sequence as Seq
+import System.Directory ( doesFileExist )
+import Data.Maybe
+import Data.Time
+import Data.Typeable    ( Typeable )
+import Data.Word        ( Word8 )
+import Control.Monad
+import System.Exit      ( exitWith, ExitCode(..) )
+import Exception
+import Data.IORef
+import System.FilePath
+
+
+-- %************************************************************************
+-- %*                                                                      *
+--             Initialisation: exception handlers
+-- %*                                                                      *
+-- %************************************************************************
+
+
+-- | Install some default exception handlers and run the inner computation.
+-- Unless you want to handle exceptions yourself, you should wrap this around
+-- the top level of your program.  The default handlers output the error
+-- message(s) to stderr and exit cleanly.
+defaultErrorHandler :: (ExceptionMonad m)
+                    => FatalMessager -> FlushOut -> m a -> m a
+defaultErrorHandler fm (FlushOut flushOut) inner =
+  -- top-level exception handler: any unrecognised exception is a compiler bug.
+  ghandle (\exception -> liftIO $ do
+           flushOut
+           case fromException exception of
+                -- an IO exception probably isn't our fault, so don't panic
+                Just (ioe :: IOException) ->
+                  fatalErrorMsg'' fm (show ioe)
+                _ -> case fromException exception of
+                     Just UserInterrupt ->
+                         -- Important to let this one propagate out so our
+                         -- calling process knows we were interrupted by ^C
+                         liftIO $ throwIO UserInterrupt
+                     Just StackOverflow ->
+                         fatalErrorMsg'' fm "stack overflow: use +RTS -K<size> to increase it"
+                     _ -> case fromException exception of
+                          Just (ex :: ExitCode) -> liftIO $ throwIO ex
+                          _ ->
+                              fatalErrorMsg'' fm
+                                  (show (Panic (show exception)))
+           exitWith (ExitFailure 1)
+         ) $
+
+  -- error messages propagated as exceptions
+  handleGhcException
+            (\ge -> liftIO $ do
+                flushOut
+                case ge of
+                     Signal _ -> exitWith (ExitFailure 1)
+                     _ -> do fatalErrorMsg'' fm (show ge)
+                             exitWith (ExitFailure 1)
+            ) $
+  inner
+
+-- | This function is no longer necessary, cleanup is now done by
+-- runGhc/runGhcT.
+{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-}
+defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a
+defaultCleanupHandler _ m = m
+ where _warning_suppression = m `gonException` undefined
+
+
+-- %************************************************************************
+-- %*                                                                      *
+--             The Ghc Monad
+-- %*                                                                      *
+-- %************************************************************************
+
+-- | Run function for the 'Ghc' monad.
+--
+-- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call
+-- to this function will create a new session which should not be shared among
+-- several threads.
+--
+-- Any errors not handled inside the 'Ghc' action are propagated as IO
+-- exceptions.
+
+runGhc :: Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
+       -> Ghc a           -- ^ The action to perform.
+       -> IO a
+runGhc mb_top_dir ghc = do
+  ref <- newIORef (panic "empty session")
+  let session = Session ref
+  flip unGhc session $ withSignalHandlers $ do -- catch ^C
+    initGhcMonad mb_top_dir
+    withCleanupSession ghc
+
+-- | Run function for 'GhcT' monad transformer.
+--
+-- It initialises the GHC session and warnings via 'initGhcMonad'.  Each call
+-- to this function will create a new session which should not be shared among
+-- several threads.
+
+runGhcT :: ExceptionMonad m =>
+           Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
+        -> GhcT m a        -- ^ The action to perform.
+        -> m a
+runGhcT mb_top_dir ghct = do
+  ref <- liftIO $ newIORef (panic "empty session")
+  let session = Session ref
+  flip unGhcT session $ withSignalHandlers $ do -- catch ^C
+    initGhcMonad mb_top_dir
+    withCleanupSession ghct
+
+withCleanupSession :: GhcMonad m => m a -> m a
+withCleanupSession ghc = ghc `gfinally` cleanup
+  where
+   cleanup = do
+      hsc_env <- getSession
+      let dflags = hsc_dflags hsc_env
+      liftIO $ do
+          cleanTempFiles dflags
+          cleanTempDirs dflags
+          stopIServ hsc_env -- shut down the IServ
+          --  exceptions will be blocked while we clean the temporary files,
+          -- so there shouldn't be any difficulty if we receive further
+          -- signals.
+
+-- | Initialise a GHC session.
+--
+-- If you implement a custom 'GhcMonad' you must call this function in the
+-- monad run function.  It will initialise the session variable and clear all
+-- warnings.
+--
+-- The first argument should point to the directory where GHC's library files
+-- reside.  More precisely, this should be the output of @ghc --print-libdir@
+-- of the version of GHC the module using this API is compiled with.  For
+-- portability, you should use the @ghc-paths@ package, available at
+-- <http://hackage.haskell.org/package/ghc-paths>.
+
+initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()
+initGhcMonad mb_top_dir
+  = do { env <- liftIO $
+                do { top_dir <- findTopDir mb_top_dir
+                   ; mySettings <- initSysTools top_dir
+                   ; myLlvmConfig <- initLlvmConfig top_dir
+                   ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)
+                   ; checkBrokenTablesNextToCode dflags
+                   ; setUnsafeGlobalDynFlags dflags
+                      -- c.f. DynFlags.parseDynamicFlagsFull, which
+                      -- creates DynFlags and sets the UnsafeGlobalDynFlags
+                   ; newHscEnv dflags }
+       ; setSession env }
+
+-- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which
+-- breaks tables-next-to-code in dynamically linked modules. This
+-- check should be more selective but there is currently no released
+-- version where this bug is fixed.
+-- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and
+-- https://ghc.haskell.org/trac/ghc/ticket/4210#comment:29
+checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m ()
+checkBrokenTablesNextToCode dflags
+  = do { broken <- checkBrokenTablesNextToCode' dflags
+       ; when broken
+         $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr
+              ; liftIO $ fail "unsupported linker"
+              }
+       }
+  where
+    invalidLdErr = text "Tables-next-to-code not supported on ARM" <+>
+                   text "when using binutils ld (please see:" <+>
+                   text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"
+
+checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool
+checkBrokenTablesNextToCode' dflags
+  | not (isARM arch)              = return False
+  | WayDyn `notElem` ways dflags  = return False
+  | not (tablesNextToCode dflags) = return False
+  | otherwise                     = do
+    linkerInfo <- liftIO $ getLinkerInfo dflags
+    case linkerInfo of
+      GnuLD _  -> return True
+      _        -> return False
+  where platform = targetPlatform dflags
+        arch = platformArch platform
+
+
+-- %************************************************************************
+-- %*                                                                      *
+--             Flags & settings
+-- %*                                                                      *
+-- %************************************************************************
+
+-- $DynFlags
+--
+-- The GHC session maintains two sets of 'DynFlags':
+--
+--   * The "interactive" @DynFlags@, which are used for everything
+--     related to interactive evaluation, including 'runStmt',
+--     'runDecls', 'exprType', 'lookupName' and so on (everything
+--     under \"Interactive evaluation\" in this module).
+--
+--   * The "program" @DynFlags@, which are used when loading
+--     whole modules with 'load'
+--
+-- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the
+-- interactive @DynFlags@.
+--
+-- 'setProgramDynFlags', 'getProgramDynFlags' work with the
+-- program @DynFlags@.
+--
+-- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags'
+-- retrieves the program @DynFlags@ (for backwards compatibility).
+
+
+-- | Updates both the interactive and program DynFlags in a Session.
+-- This also reads the package database (unless it has already been
+-- read), and prepares the compilers knowledge about packages.  It can
+-- be called again to load new packages: just add new package flags to
+-- (packageFlags dflags).
+--
+-- Returns a list of new packages that may need to be linked in using
+-- the dynamic linker (see 'linkPackages') as a result of new package
+-- flags.  If you are not doing linking or doing static linking, you
+-- can ignore the list of packages returned.
+--
+setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
+setSessionDynFlags dflags = do
+  dflags' <- checkNewDynFlags dflags
+  (dflags'', preload) <- liftIO $ initPackages dflags'
+  modifySession $ \h -> h{ hsc_dflags = dflags''
+                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } }
+  invalidateModSummaryCache
+  return preload
+
+-- | Sets the program 'DynFlags'.  Note: this invalidates the internal
+-- cached module graph, causing more work to be done the next time
+-- 'load' is called.
+setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
+setProgramDynFlags dflags = setProgramDynFlags_ True dflags
+
+-- | Set the action taken when the compiler produces a message.  This
+-- can also be accomplished using 'setProgramDynFlags', but using
+-- 'setLogAction' avoids invalidating the cached module graph.
+setLogAction :: GhcMonad m => LogAction -> m ()
+setLogAction action = do
+  dflags' <- getProgramDynFlags
+  void $ setProgramDynFlags_ False $
+    dflags' { log_action = action }
+
+setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId]
+setProgramDynFlags_ invalidate_needed dflags = do
+  dflags' <- checkNewDynFlags dflags
+  dflags_prev <- getProgramDynFlags
+  (dflags'', preload) <-
+    if (packageFlagsChanged dflags_prev dflags')
+       then liftIO $ initPackages dflags'
+       else return (dflags', [])
+  modifySession $ \h -> h{ hsc_dflags = dflags'' }
+  when invalidate_needed $ invalidateModSummaryCache
+  return preload
+
+
+-- When changing the DynFlags, we want the changes to apply to future
+-- loads, but without completely discarding the program.  But the
+-- DynFlags are cached in each ModSummary in the hsc_mod_graph, so
+-- after a change to DynFlags, the changes would apply to new modules
+-- but not existing modules; this seems undesirable.
+--
+-- Furthermore, the GHC API client might expect that changing
+-- log_action would affect future compilation messages, but for those
+-- modules we have cached ModSummaries for, we'll continue to use the
+-- old log_action.  This is definitely wrong (#7478).
+--
+-- Hence, we invalidate the ModSummary cache after changing the
+-- DynFlags.  We do this by tweaking the date on each ModSummary, so
+-- that the next downsweep will think that all the files have changed
+-- and preprocess them again.  This won't necessarily cause everything
+-- to be recompiled, because by the time we check whether we need to
+-- recopmile a module, we'll have re-summarised the module and have a
+-- correct ModSummary.
+--
+invalidateModSummaryCache :: GhcMonad m => m ()
+invalidateModSummaryCache =
+  modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) }
+ where
+  inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) }
+
+-- | Returns the program 'DynFlags'.
+getProgramDynFlags :: GhcMonad m => m DynFlags
+getProgramDynFlags = getSessionDynFlags
+
+-- | Set the 'DynFlags' used to evaluate interactive expressions.
+-- Note: this cannot be used for changes to packages.  Use
+-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the
+-- 'pkgState' into the interactive @DynFlags@.
+setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
+setInteractiveDynFlags dflags = do
+  dflags' <- checkNewDynFlags dflags
+  dflags'' <- checkNewInteractiveDynFlags dflags'
+  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }}
+
+-- | Get the 'DynFlags' used to evaluate interactive expressions.
+getInteractiveDynFlags :: GhcMonad m => m DynFlags
+getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))
+
+
+parseDynamicFlags :: MonadIO m =>
+                     DynFlags -> [Located String]
+                  -> m (DynFlags, [Located String], [Warn])
+parseDynamicFlags = parseDynamicFlagsCmdLine
+
+-- | Checks the set of new DynFlags for possibly erroneous option
+-- combinations when invoking 'setSessionDynFlags' and friends, and if
+-- found, returns a fixed copy (if possible).
+checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags
+checkNewDynFlags dflags = do
+  -- See Note [DynFlags consistency]
+  let (dflags', warnings) = makeDynFlagsConsistent dflags
+  liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings)
+  return dflags'
+
+checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags
+checkNewInteractiveDynFlags dflags0 = do
+  -- We currently don't support use of StaticPointers in expressions entered on
+  -- the REPL. See #12356.
+  dflags1 <-
+      if xopt LangExt.StaticPointers dflags0
+      then do liftIO $ printOrThrowWarnings dflags0 $ listToBag
+                [mkPlainWarnMsg dflags0 interactiveSrcSpan
+                 $ text "StaticPointers is not supported in GHCi interactive expressions."]
+              return $ xopt_unset dflags0 LangExt.StaticPointers
+      else return dflags0
+  return dflags1
+
+
+-- %************************************************************************
+-- %*                                                                      *
+--             Setting, getting, and modifying the targets
+-- %*                                                                      *
+-- %************************************************************************
+
+-- ToDo: think about relative vs. absolute file paths. And what
+-- happens when the current directory changes.
+
+-- | Sets the targets for this session.  Each target may be a module name
+-- or a filename.  The targets correspond to the set of root modules for
+-- the program\/library.  Unloading the current program is achieved by
+-- setting the current set of targets to be empty, followed by 'load'.
+setTargets :: GhcMonad m => [Target] -> m ()
+setTargets targets = modifySession (\h -> h{ hsc_targets = targets })
+
+-- | Returns the current set of targets
+getTargets :: GhcMonad m => m [Target]
+getTargets = withSession (return . hsc_targets)
+
+-- | Add another target.
+addTarget :: GhcMonad m => Target -> m ()
+addTarget target
+  = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })
+
+-- | Remove a target
+removeTarget :: GhcMonad m => TargetId -> m ()
+removeTarget target_id
+  = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })
+  where
+   filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]
+
+-- | Attempts to guess what Target a string refers to.  This function
+-- implements the @--make@/GHCi command-line syntax for filenames:
+--
+--   - if the string looks like a Haskell source filename, then interpret it
+--     as such
+--
+--   - if adding a .hs or .lhs suffix yields the name of an existing file,
+--     then use that
+--
+--   - otherwise interpret the string as a module name
+--
+guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target
+guessTarget str (Just phase)
+   = return (Target (TargetFile str (Just phase)) True Nothing)
+guessTarget str Nothing
+   | isHaskellSrcFilename file
+   = return (target (TargetFile file Nothing))
+   | otherwise
+   = do exists <- liftIO $ doesFileExist hs_file
+        if exists
+           then return (target (TargetFile hs_file Nothing))
+           else do
+        exists <- liftIO $ doesFileExist lhs_file
+        if exists
+           then return (target (TargetFile lhs_file Nothing))
+           else do
+        if looksLikeModuleName file
+           then return (target (TargetModule (mkModuleName file)))
+           else do
+        dflags <- getDynFlags
+        liftIO $ throwGhcExceptionIO
+                 (ProgramError (showSDoc dflags $
+                 text "target" <+> quotes (text file) <+>
+                 text "is not a module name or a source file"))
+     where
+         (file,obj_allowed)
+                | '*':rest <- str = (rest, False)
+                | otherwise       = (str,  True)
+
+         hs_file  = file <.> "hs"
+         lhs_file = file <.> "lhs"
+
+         target tid = Target tid obj_allowed Nothing
+
+
+-- | Inform GHC that the working directory has changed.  GHC will flush
+-- its cache of module locations, since it may no longer be valid.
+--
+-- Note: Before changing the working directory make sure all threads running
+-- in the same session have stopped.  If you change the working directory,
+-- you should also unload the current program (set targets to empty,
+-- followed by load).
+workingDirectoryChanged :: GhcMonad m => m ()
+workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)
+
+
+-- %************************************************************************
+-- %*                                                                      *
+--             Running phases one at a time
+-- %*                                                                      *
+-- %************************************************************************
+
+class ParsedMod m where
+  modSummary   :: m -> ModSummary
+  parsedSource :: m -> ParsedSource
+
+class ParsedMod m => TypecheckedMod m where
+  renamedSource     :: m -> Maybe RenamedSource
+  typecheckedSource :: m -> TypecheckedSource
+  moduleInfo        :: m -> ModuleInfo
+  tm_internals      :: m -> (TcGblEnv, ModDetails)
+        -- ToDo: improvements that could be made here:
+        --  if the module succeeded renaming but not typechecking,
+        --  we can still get back the GlobalRdrEnv and exports, so
+        --  perhaps the ModuleInfo should be split up into separate
+        --  fields.
+
+class TypecheckedMod m => DesugaredMod m where
+  coreModule :: m -> ModGuts
+
+-- | The result of successful parsing.
+data ParsedModule =
+  ParsedModule { pm_mod_summary   :: ModSummary
+               , pm_parsed_source :: ParsedSource
+               , pm_extra_src_files :: [FilePath]
+               , pm_annotations :: ApiAnns }
+               -- See Note [Api annotations] in ApiAnnotation.hs
+
+instance ParsedMod ParsedModule where
+  modSummary m    = pm_mod_summary m
+  parsedSource m = pm_parsed_source m
+
+-- | The result of successful typechecking.  It also contains the parser
+--   result.
+data TypecheckedModule =
+  TypecheckedModule { tm_parsed_module       :: ParsedModule
+                    , tm_renamed_source      :: Maybe RenamedSource
+                    , tm_typechecked_source  :: TypecheckedSource
+                    , tm_checked_module_info :: ModuleInfo
+                    , tm_internals_          :: (TcGblEnv, ModDetails)
+                    }
+
+instance ParsedMod TypecheckedModule where
+  modSummary m   = modSummary (tm_parsed_module m)
+  parsedSource m = parsedSource (tm_parsed_module m)
+
+instance TypecheckedMod TypecheckedModule where
+  renamedSource m     = tm_renamed_source m
+  typecheckedSource m = tm_typechecked_source m
+  moduleInfo m        = tm_checked_module_info m
+  tm_internals m      = tm_internals_ m
+
+-- | The result of successful desugaring (i.e., translation to core).  Also
+--  contains all the information of a typechecked module.
+data DesugaredModule =
+  DesugaredModule { dm_typechecked_module :: TypecheckedModule
+                  , dm_core_module        :: ModGuts
+             }
+
+instance ParsedMod DesugaredModule where
+  modSummary m   = modSummary (dm_typechecked_module m)
+  parsedSource m = parsedSource (dm_typechecked_module m)
+
+instance TypecheckedMod DesugaredModule where
+  renamedSource m     = renamedSource (dm_typechecked_module m)
+  typecheckedSource m = typecheckedSource (dm_typechecked_module m)
+  moduleInfo m        = moduleInfo (dm_typechecked_module m)
+  tm_internals m      = tm_internals_ (dm_typechecked_module m)
+
+instance DesugaredMod DesugaredModule where
+  coreModule m = dm_core_module m
+
+type ParsedSource      = Located (HsModule GhcPs)
+type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
+                          Maybe LHsDocString)
+type TypecheckedSource = LHsBinds GhcTc
+
+-- NOTE:
+--   - things that aren't in the output of the typechecker right now:
+--     - the export list
+--     - the imports
+--     - type signatures
+--     - type/data/newtype declarations
+--     - class declarations
+--     - instances
+--   - extra things in the typechecker's output:
+--     - default methods are turned into top-level decls.
+--     - dictionary bindings
+
+-- | Return the 'ModSummary' of a module with the given name.
+--
+-- The module must be part of the module graph (see 'hsc_mod_graph' and
+-- 'ModuleGraph').  If this is not the case, this function will throw a
+-- 'GhcApiError'.
+--
+-- This function ignores boot modules and requires that there is only one
+-- non-boot module with the given name.
+getModSummary :: GhcMonad m => ModuleName -> m ModSummary
+getModSummary mod = do
+   mg <- liftM hsc_mod_graph getSession
+   let mods_by_name = [ ms | ms <- mgModSummaries mg
+                      , ms_mod_name ms == mod
+                      , not (isBootSummary ms) ]
+   case mods_by_name of
+     [] -> do dflags <- getDynFlags
+              liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")
+     [ms] -> return ms
+     multiple -> do dflags <- getDynFlags
+                    liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)
+
+-- | Parse a module.
+--
+-- Throws a 'SourceError' on parse error.
+parseModule :: GhcMonad m => ModSummary -> m ParsedModule
+parseModule ms = do
+   hsc_env <- getSession
+   let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
+   hpm <- liftIO $ hscParse hsc_env_tmp ms
+   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)
+                           (hpm_annotations hpm))
+               -- See Note [Api annotations] in ApiAnnotation.hs
+
+-- | Typecheck and rename a parsed module.
+--
+-- Throws a 'SourceError' if either fails.
+typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule
+typecheckModule pmod = do
+ let ms = modSummary pmod
+ hsc_env <- getSession
+ let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
+ (tc_gbl_env, rn_info)
+       <- liftIO $ hscTypecheckRename hsc_env_tmp ms $
+                      HsParsedModule { hpm_module = parsedSource pmod,
+                                       hpm_src_files = pm_extra_src_files pmod,
+                                       hpm_annotations = pm_annotations pmod }
+ details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env
+ safe    <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env
+
+ return $
+     TypecheckedModule {
+       tm_internals_          = (tc_gbl_env, details),
+       tm_parsed_module       = pmod,
+       tm_renamed_source      = rn_info,
+       tm_typechecked_source  = tcg_binds tc_gbl_env,
+       tm_checked_module_info =
+         ModuleInfo {
+           minf_type_env  = md_types details,
+           minf_exports   = md_exports details,
+           minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),
+           minf_instances = fixSafeInstances safe $ md_insts details,
+           minf_iface     = Nothing,
+           minf_safe      = safe,
+           minf_modBreaks = emptyModBreaks
+         }}
+
+-- | Desugar a typechecked module.
+desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule
+desugarModule tcm = do
+ let ms = modSummary tcm
+ let (tcg, _) = tm_internals tcm
+ hsc_env <- getSession
+ let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }
+ guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg
+ return $
+     DesugaredModule {
+       dm_typechecked_module = tcm,
+       dm_core_module        = guts
+     }
+
+-- | Load a module.  Input doesn't need to be desugared.
+--
+-- A module must be loaded before dependent modules can be typechecked.  This
+-- always includes generating a 'ModIface' and, depending on the
+-- 'DynFlags.hscTarget', may also include code generation.
+--
+-- This function will always cause recompilation and will always overwrite
+-- previous compilation results (potentially files on disk).
+--
+loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod
+loadModule tcm = do
+   let ms = modSummary tcm
+   let mod = ms_mod_name ms
+   let loc = ms_location ms
+   let (tcg, _details) = tm_internals tcm
+
+   mb_linkable <- case ms_obj_date ms of
+                     Just t | t > ms_hs_date ms  -> do
+                         l <- liftIO $ findObjectLinkable (ms_mod ms)
+                                                  (ml_obj_file loc) t
+                         return (Just l)
+                     _otherwise -> return Nothing
+
+   let source_modified | isNothing mb_linkable = SourceModified
+                       | otherwise             = SourceUnmodified
+                       -- we can't determine stability here
+
+   -- compile doesn't change the session
+   hsc_env <- getSession
+   mod_info <- liftIO $ compileOne' (Just tcg) Nothing
+                                    hsc_env ms 1 1 Nothing mb_linkable
+                                    source_modified
+
+   modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }
+   return tcm
+
+
+-- %************************************************************************
+-- %*                                                                      *
+--             Dealing with Core
+-- %*                                                                      *
+-- %************************************************************************
+
+-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for
+-- the 'GHC.compileToCoreModule' interface.
+data CoreModule
+  = CoreModule {
+      -- | Module name
+      cm_module   :: !Module,
+      -- | Type environment for types declared in this module
+      cm_types    :: !TypeEnv,
+      -- | Declarations
+      cm_binds    :: CoreProgram,
+      -- | Safe Haskell mode
+      cm_safe     :: SafeHaskellMode
+    }
+
+instance Outputable CoreModule where
+   ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb,
+                    cm_safe = sf})
+    = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te
+      $$ vcat (map ppr cb)
+
+-- | This is the way to get access to the Core bindings corresponding
+-- to a module. 'compileToCore' parses, typechecks, and
+-- desugars the module, then returns the resulting Core module (consisting of
+-- the module name, type declarations, and function declarations) if
+-- successful.
+compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule
+compileToCoreModule = compileCore False
+
+-- | Like compileToCoreModule, but invokes the simplifier, so
+-- as to return simplified and tidied Core.
+compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule
+compileToCoreSimplified = compileCore True
+
+compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule
+compileCore simplify fn = do
+   -- First, set the target to the desired filename
+   target <- guessTarget fn Nothing
+   addTarget target
+   _ <- load LoadAllTargets
+   -- Then find dependencies
+   modGraph <- depanal [] True
+   case find ((== fn) . msHsFilePath) (mgModSummaries modGraph) of
+     Just modSummary -> do
+       -- Now we have the module name;
+       -- parse, typecheck and desugar the module
+       (tcg, mod_guts) <- -- TODO: space leaky: call hsc* directly?
+         do tm <- typecheckModule =<< parseModule modSummary
+            let tcg = fst (tm_internals tm)
+            (,) tcg . coreModule <$> desugarModule tm
+       liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $
+         if simplify
+          then do
+             -- If simplify is true: simplify (hscSimplify), then tidy
+             -- (tidyProgram).
+             hsc_env <- getSession
+             simpl_guts <- liftIO $ do
+               plugins <- readIORef (tcg_th_coreplugins tcg)
+               hscSimplify hsc_env plugins mod_guts
+             tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
+             return $ Left tidy_guts
+          else
+             return $ Right mod_guts
+
+     Nothing -> panic "compileToCoreModule: target FilePath not found in\
+                           module dependency graph"
+  where -- two versions, based on whether we simplify (thus run tidyProgram,
+        -- which returns a (CgGuts, ModDetails) pair, or not (in which case
+        -- we just have a ModGuts.
+        gutsToCoreModule :: SafeHaskellMode
+                         -> Either (CgGuts, ModDetails) ModGuts
+                         -> CoreModule
+        gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule {
+          cm_module = cg_module cg,
+          cm_types  = md_types md,
+          cm_binds  = cg_binds cg,
+          cm_safe   = safe_mode
+        }
+        gutsToCoreModule safe_mode (Right mg) = CoreModule {
+          cm_module  = mg_module mg,
+          cm_types   = typeEnvFromEntities (bindersOfBinds (mg_binds mg))
+                                           (mg_tcs mg)
+                                           (mg_fam_insts mg),
+          cm_binds   = mg_binds mg,
+          cm_safe    = safe_mode
+         }
+
+-- %************************************************************************
+-- %*                                                                      *
+--             Inspecting the session
+-- %*                                                                      *
+-- %************************************************************************
+
+-- | Get the module dependency graph.
+getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
+getModuleGraph = liftM hsc_mod_graph getSession
+
+-- | Return @True@ <==> module is loaded.
+isLoaded :: GhcMonad m => ModuleName -> m Bool
+isLoaded m = withSession $ \hsc_env ->
+  return $! isJust (lookupHpt (hsc_HPT hsc_env) m)
+
+-- | Return the bindings for the current interactive session.
+getBindings :: GhcMonad m => m [TyThing]
+getBindings = withSession $ \hsc_env ->
+    return $ icInScopeTTs $ hsc_IC hsc_env
+
+-- | Return the instances for the current interactive session.
+getInsts :: GhcMonad m => m ([ClsInst], [FamInst])
+getInsts = withSession $ \hsc_env ->
+    return $ ic_instances (hsc_IC hsc_env)
+
+getPrintUnqual :: GhcMonad m => m PrintUnqualified
+getPrintUnqual = withSession $ \hsc_env ->
+  return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))
+
+-- | Container for information about a 'Module'.
+data ModuleInfo = ModuleInfo {
+        minf_type_env  :: TypeEnv,
+        minf_exports   :: [AvailInfo],
+        minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod
+        minf_instances :: [ClsInst],
+        minf_iface     :: Maybe ModIface,
+        minf_safe      :: SafeHaskellMode,
+        minf_modBreaks :: ModBreaks
+  }
+        -- We don't want HomeModInfo here, because a ModuleInfo applies
+        -- to package modules too.
+
+-- | Request information about a loaded 'Module'
+getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X
+getModuleInfo mdl = withSession $ \hsc_env -> do
+  let mg = hsc_mod_graph hsc_env
+  if mgElemModule mg mdl
+        then liftIO $ getHomeModuleInfo hsc_env mdl
+        else do
+  {- if isHomeModule (hsc_dflags hsc_env) mdl
+        then return Nothing
+        else -} liftIO $ getPackageModuleInfo hsc_env mdl
+   -- ToDo: we don't understand what the following comment means.
+   --    (SDM, 19/7/2011)
+   -- getPackageModuleInfo will attempt to find the interface, so
+   -- we don't want to call it for a home module, just in case there
+   -- was a problem loading the module and the interface doesn't
+   -- exist... hence the isHomeModule test here.  (ToDo: reinstate)
+
+getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
+getPackageModuleInfo hsc_env mdl
+  = do  eps <- hscEPS hsc_env
+        iface <- hscGetModuleInterface hsc_env mdl
+        let
+            avails = mi_exports iface
+            pte    = eps_PTE eps
+            tys    = [ ty | name <- concatMap availNames avails,
+                            Just ty <- [lookupTypeEnv pte name] ]
+        --
+        return (Just (ModuleInfo {
+                        minf_type_env  = mkTypeEnv tys,
+                        minf_exports   = avails,
+                        minf_rdr_env   = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
+                        minf_instances = error "getModuleInfo: instances for package module unimplemented",
+                        minf_iface     = Just iface,
+                        minf_safe      = getSafeMode $ mi_trust iface,
+                        minf_modBreaks = emptyModBreaks
+                }))
+
+getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
+getHomeModuleInfo hsc_env mdl =
+  case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of
+    Nothing  -> return Nothing
+    Just hmi -> do
+      let details = hm_details hmi
+          iface   = hm_iface hmi
+      return (Just (ModuleInfo {
+                        minf_type_env  = md_types details,
+                        minf_exports   = md_exports details,
+                        minf_rdr_env   = mi_globals $! hm_iface hmi,
+                        minf_instances = md_insts details,
+                        minf_iface     = Just iface,
+                        minf_safe      = getSafeMode $ mi_trust iface
+                       ,minf_modBreaks = getModBreaks hmi
+                        }))
+
+-- | The list of top-level entities defined in a module
+modInfoTyThings :: ModuleInfo -> [TyThing]
+modInfoTyThings minf = typeEnvElts (minf_type_env minf)
+
+modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]
+modInfoTopLevelScope minf
+  = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)
+
+modInfoExports :: ModuleInfo -> [Name]
+modInfoExports minf = concatMap availNames $! minf_exports minf
+
+modInfoExportsWithSelectors :: ModuleInfo -> [Name]
+modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf
+
+-- | Returns the instances defined by the specified module.
+-- Warning: currently unimplemented for package modules.
+modInfoInstances :: ModuleInfo -> [ClsInst]
+modInfoInstances = minf_instances
+
+modInfoIsExportedName :: ModuleInfo -> Name -> Bool
+modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf))
+
+mkPrintUnqualifiedForModule :: GhcMonad m =>
+                               ModuleInfo
+                            -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X
+mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do
+  return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))
+
+modInfoLookupName :: GhcMonad m =>
+                     ModuleInfo -> Name
+                  -> m (Maybe TyThing) -- XXX: returns a Maybe X
+modInfoLookupName minf name = withSession $ \hsc_env -> do
+   case lookupTypeEnv (minf_type_env minf) name of
+     Just tyThing -> return (Just tyThing)
+     Nothing      -> do
+       eps <- liftIO $ readIORef (hsc_EPS hsc_env)
+       return $! lookupType (hsc_dflags hsc_env)
+                            (hsc_HPT hsc_env) (eps_PTE eps) name
+
+modInfoIface :: ModuleInfo -> Maybe ModIface
+modInfoIface = minf_iface
+
+-- | Retrieve module safe haskell mode
+modInfoSafe :: ModuleInfo -> SafeHaskellMode
+modInfoSafe = minf_safe
+
+modInfoModBreaks :: ModuleInfo -> ModBreaks
+modInfoModBreaks = minf_modBreaks
+
+isDictonaryId :: Id -> Bool
+isDictonaryId id
+  = case tcSplitSigmaTy (idType id) of {
+      (_tvs, _theta, tau) -> isDictTy tau }
+
+-- | Looks up a global name: that is, any top-level name in any
+-- visible module.  Unlike 'lookupName', lookupGlobalName does not use
+-- the interactive context, and therefore does not require a preceding
+-- 'setContext'.
+lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)
+lookupGlobalName name = withSession $ \hsc_env -> do
+   liftIO $ lookupTypeHscEnv hsc_env name
+
+findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]
+findGlobalAnns deserialize target = withSession $ \hsc_env -> do
+    ann_env <- liftIO $ prepareAnnotations hsc_env Nothing
+    return (findAnns deserialize ann_env target)
+
+-- | get the GlobalRdrEnv for a session
+getGRE :: GhcMonad m => m GlobalRdrEnv
+getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)
+
+-- | Retrieve all type and family instances in the environment, indexed
+-- by 'Name'. Each name's lists will contain every instance in which that name
+-- is mentioned in the instance head.
+getNameToInstancesIndex :: GhcMonad m
+  => [Module]        -- ^ visible modules. An orphan instance will be returned
+                     -- if it is visible from at least one module in the list.
+  -> Maybe [Module]  -- ^ modules to load. If this is not specified, we load
+                     -- modules for everything that is in scope unqualified.
+  -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))
+getNameToInstancesIndex visible_mods mods_to_load = do
+  hsc_env <- getSession
+  liftIO $ runTcInteractive hsc_env $
+    do { case mods_to_load of
+           Nothing -> loadUnqualIfaces hsc_env (hsc_IC hsc_env)
+           Just mods ->
+             let doc = text "Need interface for reporting instances in scope"
+             in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods
+
+       ; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs
+       ; let visible_mods' = mkModuleSet visible_mods
+       ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
+       -- We use Data.Sequence.Seq because we are creating left associated
+       -- mappends.
+       -- cls_index and fam_index below are adapted from TcRnDriver.lookupInsts
+       ; let cls_index = Map.fromListWith mappend
+                 [ (n, Seq.singleton ispec)
+                 | ispec <- instEnvElts ie_local ++ instEnvElts ie_global
+                 , instIsVisible visible_mods' ispec
+                 , n <- nameSetElemsStable $ orphNamesOfClsInst ispec
+                 ]
+       ; let fam_index = Map.fromListWith mappend
+                 [ (n, Seq.singleton fispec)
+                 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
+                 , n <- nameSetElemsStable $ orphNamesOfFamInst fispec
+                 ]
+       ; return $ mkNameEnv $
+           [ (nm, (toList clss, toList fams))
+           | (nm, (clss, fams)) <- Map.toList $ Map.unionWith mappend
+               (fmap (,Seq.empty) cls_index)
+               (fmap (Seq.empty,) fam_index)
+           ] }
+
+-- -----------------------------------------------------------------------------
+
+{- ToDo: Move the primary logic here to compiler/main/Packages.hs
+-- | Return all /external/ modules available in the package database.
+-- Modules from the current session (i.e., from the 'HomePackageTable') are
+-- not included.  This includes module names which are reexported by packages.
+packageDbModules :: GhcMonad m =>
+                    Bool  -- ^ Only consider exposed packages.
+                 -> m [Module]
+packageDbModules only_exposed = do
+   dflags <- getSessionDynFlags
+   let pkgs = eltsUFM (pkgIdMap (pkgState dflags))
+   return $
+     [ mkModule pid modname
+     | p <- pkgs
+     , not only_exposed || exposed p
+     , let pid = packageConfigId p
+     , modname <- exposedModules p
+               ++ map exportName (reexportedModules p) ]
+               -}
+
+-- -----------------------------------------------------------------------------
+-- Misc exported utils
+
+dataConType :: DataCon -> Type
+dataConType dc = idType (dataConWrapId dc)
+
+-- | print a 'NamedThing', adding parentheses if the name is an operator.
+pprParenSymName :: NamedThing a => a -> SDoc
+pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
+
+-- ----------------------------------------------------------------------------
+
+
+-- ToDo:
+--   - Data and Typeable instances for HsSyn.
+
+-- ToDo: check for small transformations that happen to the syntax in
+-- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
+
+-- ToDo: maybe use TH syntax instead of IfaceSyn?  There's already a way
+-- to get from TyCons, Ids etc. to TH syntax (reify).
+
+-- :browse will use either lm_toplev or inspect lm_interface, depending
+-- on whether the module is interpreted or not.
+
+
+-- Extract the filename, stringbuffer content and dynflags associed to a module
+--
+-- XXX: Explain pre-conditions
+getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)
+getModuleSourceAndFlags mod = do
+  m <- getModSummary (moduleName mod)
+  case ml_hs_file $ ms_location m of
+    Nothing -> do dflags <- getDynFlags
+                  liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod)
+    Just sourceFile -> do
+        source <- liftIO $ hGetStringBuffer sourceFile
+        return (sourceFile, source, ms_hspp_opts m)
+
+
+-- | Return module source as token stream, including comments.
+--
+-- The module must be in the module graph and its source must be available.
+-- Throws a 'HscTypes.SourceError' on parse error.
+getTokenStream :: GhcMonad m => Module -> m [Located Token]
+getTokenStream mod = do
+  (sourceFile, source, flags) <- getModuleSourceAndFlags mod
+  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
+  case lexTokenStream source startLoc flags of
+    POk _ ts  -> return ts
+    PFailed _ span err ->
+        do dflags <- getDynFlags
+           liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
+
+-- | Give even more information on the source than 'getTokenStream'
+-- This function allows reconstructing the source completely with
+-- 'showRichTokenStream'.
+getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
+getRichTokenStream mod = do
+  (sourceFile, source, flags) <- getModuleSourceAndFlags mod
+  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
+  case lexTokenStream source startLoc flags of
+    POk _ ts -> return $ addSourceToTokens startLoc source ts
+    PFailed _ span err ->
+        do dflags <- getDynFlags
+           liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
+
+-- | Given a source location and a StringBuffer corresponding to this
+-- location, return a rich token stream with the source associated to the
+-- tokens.
+addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
+                  -> [(Located Token, String)]
+addSourceToTokens _ _ [] = []
+addSourceToTokens loc buf (t@(dL->L span _) : ts)
+    = case span of
+      UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
+      RealSrcSpan s   -> (t,str) : addSourceToTokens newLoc newBuf ts
+        where
+          (newLoc, newBuf, str) = go "" loc buf
+          start = realSrcSpanStart s
+          end = realSrcSpanEnd s
+          go acc loc buf | loc < start = go acc nLoc nBuf
+                         | start <= loc && loc < end = go (ch:acc) nLoc nBuf
+                         | otherwise = (loc, buf, reverse acc)
+              where (ch, nBuf) = nextChar buf
+                    nLoc = advanceSrcLoc loc ch
+
+
+-- | Take a rich token stream such as produced from 'getRichTokenStream' and
+-- return source code almost identical to the original code (except for
+-- insignificant whitespace.)
+showRichTokenStream :: [(Located Token, String)] -> String
+showRichTokenStream ts = go startLoc ts ""
+    where sourceFile = getFile $ map (getLoc . fst) ts
+          getFile [] = panic "showRichTokenStream: No source file found"
+          getFile (UnhelpfulSpan _ : xs) = getFile xs
+          getFile (RealSrcSpan s : _) = srcSpanFile s
+          startLoc = mkRealSrcLoc sourceFile 1 1
+          go _ [] = id
+          go loc ((dL->L span _, str):ts)
+              = case span of
+                UnhelpfulSpan _ -> go loc ts
+                RealSrcSpan s
+                 | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)
+                                       . (str ++)
+                                       . go tokEnd ts
+                 | otherwise -> ((replicate (tokLine - locLine) '\n') ++)
+                               . ((replicate (tokCol - 1) ' ') ++)
+                              . (str ++)
+                              . go tokEnd ts
+                  where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
+                        (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s)
+                        tokEnd = realSrcSpanEnd s
+
+-- -----------------------------------------------------------------------------
+-- Interactive evaluation
+
+-- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the
+-- filesystem and package database to find the corresponding 'Module',
+-- using the algorithm that is used for an @import@ declaration.
+findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
+findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
+  let
+    dflags   = hsc_dflags hsc_env
+    this_pkg = thisPackage dflags
+  --
+  case maybe_pkg of
+    Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
+      res <- findImportedModule hsc_env mod_name maybe_pkg
+      case res of
+        Found _ m -> return m
+        err       -> throwOneError $ noModError dflags noSrcSpan mod_name err
+    _otherwise -> do
+      home <- lookupLoadedHomeModule mod_name
+      case home of
+        Just m  -> return m
+        Nothing -> liftIO $ do
+           res <- findImportedModule hsc_env mod_name maybe_pkg
+           case res of
+             Found loc m | moduleUnitId m /= this_pkg -> return m
+                         | otherwise -> modNotLoadedError dflags m loc
+             err -> throwOneError $ noModError dflags noSrcSpan mod_name err
+
+modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a
+modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $
+   text "module is not loaded:" <+>
+   quotes (ppr (moduleName m)) <+>
+   parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
+
+-- | Like 'findModule', but differs slightly when the module refers to
+-- a source file, and the file has not been loaded via 'load'.  In
+-- this case, 'findModule' will throw an error (module not loaded),
+-- but 'lookupModule' will check to see whether the module can also be
+-- found in a package, and if so, that package 'Module' will be
+-- returned.  If not, the usual module-not-found error will be thrown.
+--
+lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
+lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)
+lookupModule mod_name Nothing = withSession $ \hsc_env -> do
+  home <- lookupLoadedHomeModule mod_name
+  case home of
+    Just m  -> return m
+    Nothing -> liftIO $ do
+      res <- findExposedPackageModule hsc_env mod_name Nothing
+      case res of
+        Found _ m -> return m
+        err       -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err
+
+lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)
+lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->
+  case lookupHpt (hsc_HPT hsc_env) mod_name of
+    Just mod_info      -> return (Just (mi_module (hm_iface mod_info)))
+    _not_a_home_module -> return Nothing
+
+-- | Check that a module is safe to import (according to Safe Haskell).
+--
+-- We return True to indicate the import is safe and False otherwise
+-- although in the False case an error may be thrown first.
+isModuleTrusted :: GhcMonad m => Module -> m Bool
+isModuleTrusted m = withSession $ \hsc_env ->
+    liftIO $ hscCheckSafe hsc_env m noSrcSpan
+
+-- | Return if a module is trusted and the pkgs it depends on to be trusted.
+moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set InstalledUnitId)
+moduleTrustReqs m = withSession $ \hsc_env ->
+    liftIO $ hscGetSafe hsc_env m noSrcSpan
+
+-- | Set the monad GHCi lifts user statements into.
+--
+-- Checks that a type (in string form) is an instance of the
+-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is,
+-- throws an error otherwise.
+setGHCiMonad :: GhcMonad m => String -> m ()
+setGHCiMonad name = withSession $ \hsc_env -> do
+    ty <- liftIO $ hscIsGHCiMonad hsc_env name
+    modifySession $ \s ->
+        let ic = (hsc_IC s) { ic_monad = ty }
+        in s { hsc_IC = ic }
+
+-- | Get the monad GHCi lifts user statements into.
+getGHCiMonad :: GhcMonad m => m Name
+getGHCiMonad = fmap (ic_monad . hsc_IC) getSession
+
+getHistorySpan :: GhcMonad m => History -> m SrcSpan
+getHistorySpan h = withSession $ \hsc_env ->
+    return $ InteractiveEval.getHistorySpan hsc_env h
+
+obtainTermFromVal :: GhcMonad m => Int ->  Bool -> Type -> a -> m Term
+obtainTermFromVal bound force ty a = withSession $ \hsc_env ->
+    liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
+
+obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
+obtainTermFromId bound force id = withSession $ \hsc_env ->
+    liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
+
+
+-- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any
+-- entity known to GHC, including 'Name's defined using 'runStmt'.
+lookupName :: GhcMonad m => Name -> m (Maybe TyThing)
+lookupName name =
+     withSession $ \hsc_env ->
+       liftIO $ hscTcRcLookupName hsc_env name
+
+-- -----------------------------------------------------------------------------
+-- Pure API
+
+-- | A pure interface to the module parser.
+--
+parser :: String         -- ^ Haskell module source text (full Unicode is supported)
+       -> DynFlags       -- ^ the flags
+       -> FilePath       -- ^ the filename (for source locations)
+       -> (WarningMessages, Either ErrorMessages (Located (HsModule GhcPs)))
+
+parser str dflags filename =
+   let
+       loc  = mkRealSrcLoc (mkFastString filename) 1 1
+       buf  = stringToStringBuffer str
+   in
+   case unP Parser.parseModule (mkPState dflags buf loc) of
+
+     PFailed warnFn span err   ->
+         let (warns,_) = warnFn dflags in
+         (warns, Left $ unitBag (mkPlainErrMsg dflags span err))
+
+     POk pst rdr_module ->
+         let (warns,_) = getMessages pst dflags in
+         (warns, Right rdr_module)
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/GhcMake.hs
@@ -0,0 +1,2518 @@
+{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2011
+--
+-- This module implements multi-module compilation, and is used
+-- by --make and GHCi.
+--
+-- -----------------------------------------------------------------------------
+module GhcMake(
+        depanal,
+        load, load', LoadHowMuch(..),
+
+        topSortModuleGraph,
+
+        ms_home_srcimps, ms_home_imps,
+
+        IsBoot(..),
+        summariseModule,
+        hscSourceToIsBoot,
+        findExtraSigImports,
+        implicitRequirements,
+
+        noModError, cyclicModuleErr,
+        moduleGraphNodes, SummaryNode
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import qualified Linker         ( unload )
+
+import DriverPhases
+import DriverPipeline
+import DynFlags
+import ErrUtils
+import Finder
+import GhcMonad
+import HeaderInfo
+import HscTypes
+import Module
+import TcIface          ( typecheckIface )
+import TcRnMonad        ( initIfaceCheck )
+import HscMain
+
+import Bag              ( listToBag )
+import BasicTypes
+import Digraph
+import Exception        ( tryIO, gbracket, gfinally )
+import FastString
+import Maybes           ( expectJust )
+import Name
+import MonadUtils       ( allM, MonadIO )
+import Outputable
+import Panic
+import SrcLoc
+import StringBuffer
+import UniqFM
+import UniqDSet
+import TcBackpack
+import Packages
+import UniqSet
+import Util
+import qualified GHC.LanguageExtensions as LangExt
+import NameEnv
+import FileCleanup
+
+import Data.Either ( rights, partitionEithers )
+import qualified Data.Map as Map
+import Data.Map (Map)
+import qualified Data.Set as Set
+import qualified FiniteMap as Map ( insertListWith )
+
+import Control.Concurrent ( forkIOWithUnmask, killThread )
+import qualified GHC.Conc as CC
+import Control.Concurrent.MVar
+import Control.Concurrent.QSem
+import Control.Exception
+import Control.Monad
+import Data.IORef
+import Data.List
+import qualified Data.List as List
+import Data.Foldable (toList)
+import Data.Maybe
+import Data.Ord ( comparing )
+import Data.Time
+import System.Directory
+import System.FilePath
+import System.IO        ( fixIO )
+import System.IO.Error  ( isDoesNotExistError )
+
+import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
+
+label_self :: String -> IO ()
+label_self thread_name = do
+    self_tid <- CC.myThreadId
+    CC.labelThread self_tid thread_name
+
+-- -----------------------------------------------------------------------------
+-- Loading the program
+
+-- | Perform a dependency analysis starting from the current targets
+-- and update the session with the new module graph.
+--
+-- Dependency analysis entails parsing the @import@ directives and may
+-- therefore require running certain preprocessors.
+--
+-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
+-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
+-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want
+-- changes to the 'DynFlags' to take effect you need to call this function
+-- again.
+--
+depanal :: GhcMonad m =>
+           [ModuleName]  -- ^ excluded modules
+        -> Bool          -- ^ allow duplicate roots
+        -> m ModuleGraph
+depanal excluded_mods allow_dup_roots = do
+  hsc_env <- getSession
+  let
+         dflags  = hsc_dflags hsc_env
+         targets = hsc_targets hsc_env
+         old_graph = hsc_mod_graph hsc_env
+
+  withTiming (pure dflags) (text "Chasing dependencies") (const ()) $ do
+    liftIO $ debugTraceMsg dflags 2 (hcat [
+              text "Chasing modules from: ",
+              hcat (punctuate comma (map pprTarget targets))])
+
+    -- Home package modules may have been moved or deleted, and new
+    -- source files may have appeared in the home package that shadow
+    -- external package modules, so we have to discard the existing
+    -- cached finder data.
+    liftIO $ flushFinderCaches hsc_env
+
+    mod_summariesE <- liftIO $ downsweep hsc_env (mgModSummaries old_graph)
+                                     excluded_mods allow_dup_roots
+    mod_summaries <- reportImportErrors mod_summariesE
+
+    let mod_graph = mkModuleGraph mod_summaries
+
+    warnMissingHomeModules hsc_env mod_graph
+
+    setSession hsc_env { hsc_mod_graph = mod_graph }
+    return mod_graph
+
+-- Note [Missing home modules]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Sometimes user doesn't want GHC to pick up modules, not explicitly listed
+-- in a command line. For example, cabal may want to enable this warning
+-- when building a library, so that GHC warns user about modules, not listed
+-- neither in `exposed-modules`, nor in `other-modules`.
+--
+-- Here "home module" means a module, that doesn't come from an other package.
+--
+-- For example, if GHC is invoked with modules "A" and "B" as targets,
+-- but "A" imports some other module "C", then GHC will issue a warning
+-- about module "C" not being listed in a command line.
+--
+-- The warning in enabled by `-Wmissing-home-modules`. See Trac #13129
+warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m ()
+warnMissingHomeModules hsc_env mod_graph =
+    when (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) $
+        logWarnings (listToBag [warn])
+  where
+    dflags = hsc_dflags hsc_env
+    targets = map targetId (hsc_targets hsc_env)
+
+    is_known_module mod = any (is_my_target mod) targets
+
+    -- We need to be careful to handle the case where (possibly
+    -- path-qualified) filenames (aka 'TargetFile') rather than module
+    -- names are being passed on the GHC command-line.
+    --
+    -- For instance, `ghc --make src-exe/Main.hs` and
+    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.
+    -- Note also that we can't always infer the associated module name
+    -- directly from the filename argument.  See Trac #13727.
+    is_my_target mod (TargetModule name)
+      = moduleName (ms_mod mod) == name
+    is_my_target mod (TargetFile target_file _)
+      | Just mod_file <- ml_hs_file (ms_location mod)
+      = target_file == mod_file ||
+           --  We can get a file target even if a module name was
+           --  originally specified in a command line because it can
+           --  be converted in guessTarget (by appending .hs/.lhs).
+           --  So let's convert it back and compare with module name
+           mkModuleName (fst $ splitExtension target_file)
+            == moduleName (ms_mod mod)
+    is_my_target _ _ = False
+
+    missing = map (moduleName . ms_mod) $
+      filter (not . is_known_module) (mgModSummaries mod_graph)
+
+    msg
+      | gopt Opt_BuildingCabalPackage dflags
+      = hang
+          (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ")
+          4
+          (sep (map ppr missing))
+      | otherwise
+      =
+        hang
+          (text "Modules are not listed in command line but needed for compilation: ")
+          4
+          (sep (map ppr missing))
+    warn = makeIntoWarning
+      (Reason Opt_WarnMissingHomeModules)
+      (mkPlainErrMsg dflags noSrcSpan msg)
+
+-- | Describes which modules of the module graph need to be loaded.
+data LoadHowMuch
+   = LoadAllTargets
+     -- ^ Load all targets and its dependencies.
+   | LoadUpTo ModuleName
+     -- ^ Load only the given module and its dependencies.
+   | LoadDependenciesOf ModuleName
+     -- ^ Load only the dependencies of the given module, but not the module
+     -- itself.
+
+-- | Try to load the program.  See 'LoadHowMuch' for the different modes.
+--
+-- This function implements the core of GHC's @--make@ mode.  It preprocesses,
+-- compiles and loads the specified modules, avoiding re-compilation wherever
+-- possible.  Depending on the target (see 'DynFlags.hscTarget') compiling
+-- and loading may result in files being created on disk.
+--
+-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether
+-- successful or not.
+--
+-- Throw a 'SourceError' if errors are encountered before the actual
+-- compilation starts (e.g., during dependency analysis).  All other errors
+-- are reported using the 'defaultWarnErrLogger'.
+--
+load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
+load how_much = do
+    mod_graph <- depanal [] False
+    load' how_much (Just batchMsg) mod_graph
+
+-- | Generalized version of 'load' which also supports a custom
+-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
+-- produced by calling 'depanal'.
+load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
+load' how_much mHscMessage mod_graph = do
+    modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }
+    guessOutputFile
+    hsc_env <- getSession
+
+    let hpt1   = hsc_HPT hsc_env
+    let dflags = hsc_dflags hsc_env
+
+    -- The "bad" boot modules are the ones for which we have
+    -- B.hs-boot in the module graph, but no B.hs
+    -- The downsweep should have ensured this does not happen
+    -- (see msDeps)
+    let all_home_mods =
+          mkUniqSet [ ms_mod_name s
+                    | s <- mgModSummaries mod_graph, not (isBootSummary s)]
+    -- TODO: Figure out what the correct form of this assert is. It's violated
+    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot
+    -- files without corresponding hs files.
+    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,
+    --                              not (ms_mod_name s `elem` all_home_mods)]
+    -- ASSERT( null bad_boot_mods ) return ()
+
+    -- check that the module given in HowMuch actually exists, otherwise
+    -- topSortModuleGraph will bomb later.
+    let checkHowMuch (LoadUpTo m)           = checkMod m
+        checkHowMuch (LoadDependenciesOf m) = checkMod m
+        checkHowMuch _ = id
+
+        checkMod m and_then
+            | m `elementOfUniqSet` all_home_mods = and_then
+            | otherwise = do
+                    liftIO $ errorMsg dflags (text "no such module:" <+>
+                                     quotes (ppr m))
+                    return Failed
+
+    checkHowMuch how_much $ do
+
+    -- mg2_with_srcimps drops the hi-boot nodes, returning a
+    -- graph with cycles.  Among other things, it is used for
+    -- backing out partially complete cycles following a failed
+    -- upsweep, and for removing from hpt all the modules
+    -- not in strict downwards closure, during calls to compile.
+    let mg2_with_srcimps :: [SCC ModSummary]
+        mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
+
+    -- If we can determine that any of the {-# SOURCE #-} imports
+    -- are definitely unnecessary, then emit a warning.
+    warnUnnecessarySourceImports mg2_with_srcimps
+
+    let
+        -- check the stability property for each module.
+        stable_mods@(stable_obj,stable_bco)
+            = checkStability hpt1 mg2_with_srcimps all_home_mods
+
+        -- prune bits of the HPT which are definitely redundant now,
+        -- to save space.
+        pruned_hpt = pruneHomePackageTable hpt1
+                            (flattenSCCs mg2_with_srcimps)
+                            stable_mods
+
+    _ <- liftIO $ evaluate pruned_hpt
+
+    -- before we unload anything, make sure we don't leave an old
+    -- interactive context around pointing to dead bindings.  Also,
+    -- write the pruned HPT to allow the old HPT to be GC'd.
+    setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt }
+
+    liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
+                            text "Stable BCO:" <+> ppr stable_bco)
+
+    -- Unload any modules which are going to be re-linked this time around.
+    let stable_linkables = [ linkable
+                           | m <- nonDetEltsUniqSet stable_obj ++
+                                  nonDetEltsUniqSet stable_bco,
+                             -- It's OK to use nonDetEltsUniqSet here
+                             -- because it only affects linking. Besides
+                             -- this list only serves as a poor man's set.
+                             Just hmi <- [lookupHpt pruned_hpt m],
+                             Just linkable <- [hm_linkable hmi] ]
+    liftIO $ unload hsc_env stable_linkables
+
+    -- We could at this point detect cycles which aren't broken by
+    -- a source-import, and complain immediately, but it seems better
+    -- to let upsweep_mods do this, so at least some useful work gets
+    -- done before the upsweep is abandoned.
+    --hPutStrLn stderr "after tsort:\n"
+    --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
+
+    -- Now do the upsweep, calling compile for each module in
+    -- turn.  Final result is version 3 of everything.
+
+    -- Topologically sort the module graph, this time including hi-boot
+    -- nodes, and possibly just including the portion of the graph
+    -- reachable from the module specified in the 2nd argument to load.
+    -- This graph should be cycle-free.
+    -- If we're restricting the upsweep to a portion of the graph, we
+    -- also want to retain everything that is still stable.
+    let full_mg :: [SCC ModSummary]
+        full_mg    = topSortModuleGraph False mod_graph Nothing
+
+        maybe_top_mod = case how_much of
+                            LoadUpTo m           -> Just m
+                            LoadDependenciesOf m -> Just m
+                            _                    -> Nothing
+
+        partial_mg0 :: [SCC ModSummary]
+        partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
+
+        -- LoadDependenciesOf m: we want the upsweep to stop just
+        -- short of the specified module (unless the specified module
+        -- is stable).
+        partial_mg
+            | LoadDependenciesOf _mod <- how_much
+            = ASSERT( case last partial_mg0 of
+                        AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
+              List.init partial_mg0
+            | otherwise
+            = partial_mg0
+
+        stable_mg =
+            [ AcyclicSCC ms
+            | AcyclicSCC ms <- full_mg,
+              stable_mod_summary ms ]
+
+        stable_mod_summary ms =
+          ms_mod_name ms `elementOfUniqSet` stable_obj ||
+          ms_mod_name ms `elementOfUniqSet` stable_bco
+
+        -- the modules from partial_mg that are not also stable
+        -- NB. also keep cycles, we need to emit an error message later
+        unstable_mg = filter not_stable partial_mg
+          where not_stable (CyclicSCC _) = True
+                not_stable (AcyclicSCC ms)
+                   = not $ stable_mod_summary ms
+
+        -- Load all the stable modules first, before attempting to load
+        -- an unstable module (#7231).
+        mg = stable_mg ++ unstable_mg
+
+    -- clean up between compilations
+    let cleanup = cleanCurrentModuleTempFiles . hsc_dflags
+    liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
+                               2 (ppr mg))
+
+    n_jobs <- case parMakeCount dflags of
+                    Nothing -> liftIO getNumProcessors
+                    Just n  -> return n
+    let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs
+                   | otherwise  = upsweep
+
+    setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
+    (upsweep_ok, modsUpswept)
+       <- upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg
+
+    -- Make modsDone be the summaries for each home module now
+    -- available; this should equal the domain of hpt3.
+    -- Get in in a roughly top .. bottom order (hence reverse).
+
+    let modsDone = reverse modsUpswept
+
+    -- Try and do linking in some form, depending on whether the
+    -- upsweep was completely or only partially successful.
+
+    if succeeded upsweep_ok
+
+     then
+       -- Easy; just relink it all.
+       do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
+
+          -- Clean up after ourselves
+          hsc_env1 <- getSession
+          liftIO $ cleanCurrentModuleTempFiles dflags
+
+          -- Issue a warning for the confusing case where the user
+          -- said '-o foo' but we're not going to do any linking.
+          -- We attempt linking if either (a) one of the modules is
+          -- called Main, or (b) the user said -no-hs-main, indicating
+          -- that main() is going to come from somewhere else.
+          --
+          let ofile = outputFile dflags
+          let no_hs_main = gopt Opt_NoHsMain dflags
+          let
+            main_mod = mainModIs dflags
+            a_root_is_Main = mgElemModule mod_graph main_mod
+            do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib
+
+          -- link everything together
+          linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
+
+          if ghcLink dflags == LinkBinary && isJust ofile && not do_linking
+             then do
+                liftIO $ errorMsg dflags $ text
+                   ("output was redirected with -o, " ++
+                    "but no output will be generated\n" ++
+                    "because there is no " ++
+                    moduleNameString (moduleName main_mod) ++ " module.")
+                -- This should be an error, not a warning (#10895).
+                loadFinish Failed linkresult
+             else
+                loadFinish Succeeded linkresult
+
+     else
+       -- Tricky.  We need to back out the effects of compiling any
+       -- half-done cycles, both so as to clean up the top level envs
+       -- and to avoid telling the interactive linker to link them.
+       do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
+
+          let modsDone_names
+                 = map ms_mod modsDone
+          let mods_to_zap_names
+                 = findPartiallyCompletedCycles modsDone_names
+                      mg2_with_srcimps
+          let (mods_to_clean, mods_to_keep) =
+                partition ((`Set.member` mods_to_zap_names).ms_mod) modsDone
+          hsc_env1 <- getSession
+          let hpt4 = hsc_HPT hsc_env1
+              -- We must change the lifetime to TFL_CurrentModule for any temp
+              -- file created for an element of mod_to_clean during the upsweep.
+              -- These include preprocessed files and object files for loaded
+              -- modules.
+              unneeded_temps = concat
+                [ms_hspp_file : object_files
+                | ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean
+                , let object_files = maybe [] linkableObjs $
+                        lookupHpt hpt4 (moduleName ms_mod)
+                        >>= hm_linkable
+                ]
+          liftIO $
+            changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps
+          liftIO $ cleanCurrentModuleTempFiles dflags
+
+          let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
+                                          hpt4
+
+          -- Clean up after ourselves
+
+          -- there should be no Nothings where linkables should be, now
+          let just_linkables =
+                    isNoLink (ghcLink dflags)
+                 || allHpt (isJust.hm_linkable)
+                        (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)
+                                hpt5)
+          ASSERT( just_linkables ) do
+
+          -- Link everything together
+          linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5
+
+          modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }
+          loadFinish Failed linkresult
+
+
+-- | Finish up after a load.
+loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag
+
+-- If the link failed, unload everything and return.
+loadFinish _all_ok Failed
+  = do hsc_env <- getSession
+       liftIO $ unload hsc_env []
+       modifySession discardProg
+       return Failed
+
+-- Empty the interactive context and set the module context to the topmost
+-- newly loaded module, or the Prelude if none were loaded.
+loadFinish all_ok Succeeded
+  = do modifySession discardIC
+       return all_ok
+
+
+-- | Forget the current program, but retain the persistent info in HscEnv
+discardProg :: HscEnv -> HscEnv
+discardProg hsc_env
+  = discardIC $ hsc_env { hsc_mod_graph = emptyMG
+                        , hsc_HPT = emptyHomePackageTable }
+
+-- | Discard the contents of the InteractiveContext, but keep the DynFlags.
+-- It will also keep ic_int_print and ic_monad if their names are from
+-- external packages.
+discardIC :: HscEnv -> HscEnv
+discardIC hsc_env
+  = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print
+                                , ic_monad = new_ic_monad } }
+  where
+  -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic
+  !new_ic_int_print = keep_external_name ic_int_print
+  !new_ic_monad = keep_external_name ic_monad
+  dflags = ic_dflags old_ic
+  old_ic = hsc_IC hsc_env
+  empty_ic = emptyInteractiveContext dflags
+  keep_external_name ic_name
+    | nameIsFromExternalPackage this_pkg old_name = old_name
+    | otherwise = ic_name empty_ic
+    where
+    this_pkg = thisPackage dflags
+    old_name = ic_name old_ic
+
+-- | If there is no -o option, guess the name of target executable
+-- by using top-level source file name as a base.
+guessOutputFile :: GhcMonad m => m ()
+guessOutputFile = modifySession $ \env ->
+    let dflags = hsc_dflags env
+        -- Force mod_graph to avoid leaking env
+        !mod_graph = hsc_mod_graph env
+        mainModuleSrcPath :: Maybe String
+        mainModuleSrcPath = do
+            ms <- mgLookupModule mod_graph (mainModIs dflags)
+            ml_hs_file (ms_location ms)
+        name = fmap dropExtension mainModuleSrcPath
+
+        name_exe = do
+#if defined(mingw32_HOST_OS)
+          -- we must add the .exe extension unconditionally here, otherwise
+          -- when name has an extension of its own, the .exe extension will
+          -- not be added by DriverPipeline.exeFileName.  See #2248
+          name' <- fmap (<.> "exe") name
+#else
+          name' <- name
+#endif
+          mainModuleSrcPath' <- mainModuleSrcPath
+          -- #9930: don't clobber input files (unless they ask for it)
+          if name' == mainModuleSrcPath'
+            then throwGhcException . UsageError $
+                 "default output name would overwrite the input file; " ++
+                 "must specify -o explicitly"
+            else Just name'
+    in
+    case outputFile dflags of
+        Just _ -> env
+        Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
+
+-- -----------------------------------------------------------------------------
+--
+-- | Prune the HomePackageTable
+--
+-- Before doing an upsweep, we can throw away:
+--
+--   - For non-stable modules:
+--      - all ModDetails, all linked code
+--   - all unlinked code that is out of date with respect to
+--     the source file
+--
+-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
+-- space at the end of the upsweep, because the topmost ModDetails of the
+-- old HPT holds on to the entire type environment from the previous
+-- compilation.
+pruneHomePackageTable :: HomePackageTable
+                      -> [ModSummary]
+                      -> StableModules
+                      -> HomePackageTable
+pruneHomePackageTable hpt summ (stable_obj, stable_bco)
+  = mapHpt prune hpt
+  where prune hmi
+          | is_stable modl = hmi'
+          | otherwise      = hmi'{ hm_details = emptyModDetails }
+          where
+           modl = moduleName (mi_module (hm_iface hmi))
+           hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
+                = hmi{ hm_linkable = Nothing }
+                | otherwise
+                = hmi
+                where ms = expectJust "prune" (lookupUFM ms_map modl)
+
+        ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
+
+        is_stable m =
+          m `elementOfUniqSet` stable_obj ||
+          m `elementOfUniqSet` stable_bco
+
+-- -----------------------------------------------------------------------------
+--
+-- | Return (names of) all those in modsDone who are part of a cycle as defined
+-- by theGraph.
+findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module
+findPartiallyCompletedCycles modsDone theGraph
+   = Set.unions
+       [mods_in_this_cycle
+       | CyclicSCC vs <- theGraph  -- Acyclic? Not interesting.
+       , let names_in_this_cycle = Set.fromList (map ms_mod vs)
+             mods_in_this_cycle =
+                    Set.intersection (Set.fromList modsDone) names_in_this_cycle
+         -- If size mods_in_this_cycle == size names_in_this_cycle,
+         -- then this cycle has already been completed and we're not
+         -- interested.
+       , Set.size mods_in_this_cycle < Set.size names_in_this_cycle]
+
+
+-- ---------------------------------------------------------------------------
+--
+-- | Unloading
+unload :: HscEnv -> [Linkable] -> IO ()
+unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
+  = case ghcLink (hsc_dflags hsc_env) of
+        LinkInMemory -> Linker.unload hsc_env stable_linkables
+        _other -> return ()
+
+-- -----------------------------------------------------------------------------
+{- |
+
+  Stability tells us which modules definitely do not need to be recompiled.
+  There are two main reasons for having stability:
+
+   - avoid doing a complete upsweep of the module graph in GHCi when
+     modules near the bottom of the tree have not changed.
+
+   - to tell GHCi when it can load object code: we can only load object code
+     for a module when we also load object code fo  all of the imports of the
+     module.  So we need to know that we will definitely not be recompiling
+     any of these modules, and we can use the object code.
+
+  The stability check is as follows.  Both stableObject and
+  stableBCO are used during the upsweep phase later.
+
+@
+  stable m = stableObject m || stableBCO m
+
+  stableObject m =
+        all stableObject (imports m)
+        && old linkable does not exist, or is == on-disk .o
+        && date(on-disk .o) > date(.hs)
+
+  stableBCO m =
+        all stable (imports m)
+        && date(BCO) > date(.hs)
+@
+
+  These properties embody the following ideas:
+
+    - if a module is stable, then:
+
+        - if it has been compiled in a previous pass (present in HPT)
+          then it does not need to be compiled or re-linked.
+
+        - if it has not been compiled in a previous pass,
+          then we only need to read its .hi file from disk and
+          link it to produce a 'ModDetails'.
+
+    - if a modules is not stable, we will definitely be at least
+      re-linking, and possibly re-compiling it during the 'upsweep'.
+      All non-stable modules can (and should) therefore be unlinked
+      before the 'upsweep'.
+
+    - Note that objects are only considered stable if they only depend
+      on other objects.  We can't link object code against byte code.
+
+    - Note that even if an object is stable, we may end up recompiling
+      if the interface is out of date because an *external* interface
+      has changed.  The current code in GhcMake handles this case
+      fairly poorly, so be careful.
+-}
+
+type StableModules =
+  ( UniqSet ModuleName  -- stableObject
+  , UniqSet ModuleName  -- stableBCO
+  )
+
+
+checkStability
+        :: HomePackageTable   -- HPT from last compilation
+        -> [SCC ModSummary]   -- current module graph (cyclic)
+        -> UniqSet ModuleName -- all home modules
+        -> StableModules
+
+checkStability hpt sccs all_home_mods =
+  foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs
+  where
+   checkSCC :: StableModules -> SCC ModSummary -> StableModules
+   checkSCC (stable_obj, stable_bco) scc0
+     | stableObjects = (addListToUniqSet stable_obj scc_mods, stable_bco)
+     | stableBCOs    = (stable_obj, addListToUniqSet stable_bco scc_mods)
+     | otherwise     = (stable_obj, stable_bco)
+     where
+        scc = flattenSCC scc0
+        scc_mods = map ms_mod_name scc
+        home_module m =
+          m `elementOfUniqSet` all_home_mods && m `notElem` scc_mods
+
+        scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))
+            -- all imports outside the current SCC, but in the home pkg
+
+        stable_obj_imps = map (`elementOfUniqSet` stable_obj) scc_allimps
+        stable_bco_imps = map (`elementOfUniqSet` stable_bco) scc_allimps
+
+        stableObjects =
+           and stable_obj_imps
+           && all object_ok scc
+
+        stableBCOs =
+           and (zipWith (||) stable_obj_imps stable_bco_imps)
+           && all bco_ok scc
+
+        object_ok ms
+          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False
+          | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms
+                                         && same_as_prev t
+          | otherwise = False
+          where
+             same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of
+                                Just hmi  | Just l <- hm_linkable hmi
+                                 -> isObjectLinkable l && t == linkableTime l
+                                _other  -> True
+                -- why '>=' rather than '>' above?  If the filesystem stores
+                -- times to the nearset second, we may occasionally find that
+                -- the object & source have the same modification time,
+                -- especially if the source was automatically generated
+                -- and compiled.  Using >= is slightly unsafe, but it matches
+                -- make's behaviour.
+                --
+                -- But see #5527, where someone ran into this and it caused
+                -- a problem.
+
+        bco_ok ms
+          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False
+          | otherwise = case lookupHpt hpt (ms_mod_name ms) of
+                Just hmi  | Just l <- hm_linkable hmi ->
+                        not (isObjectLinkable l) &&
+                        linkableTime l >= ms_hs_date ms
+                _other  -> False
+
+{- Parallel Upsweep
+ -
+ - The parallel upsweep attempts to concurrently compile the modules in the
+ - compilation graph using multiple Haskell threads.
+ -
+ - The Algorithm
+ -
+ - A Haskell thread is spawned for each module in the module graph, waiting for
+ - its direct dependencies to finish building before it itself begins to build.
+ -
+ - Each module is associated with an initially empty MVar that stores the
+ - result of that particular module's compile. If the compile succeeded, then
+ - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that
+ - module, and the module's HMI is deleted from the old HPT (synchronized by an
+ - IORef) to save space.
+ -
+ - Instead of immediately outputting messages to the standard handles, all
+ - compilation output is deferred to a per-module TQueue. A QSem is used to
+ - limit the number of workers that are compiling simultaneously.
+ -
+ - Meanwhile, the main thread sequentially loops over all the modules in the
+ - module graph, outputting the messages stored in each module's TQueue.
+-}
+
+-- | Each module is given a unique 'LogQueue' to redirect compilation messages
+-- to. A 'Nothing' value contains the result of compilation, and denotes the
+-- end of the message queue.
+data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)])
+                         !(MVar ())
+
+-- | The graph of modules to compile and their corresponding result 'MVar' and
+-- 'LogQueue'.
+type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)]
+
+-- | Build a 'CompilationGraph' out of a list of strongly-connected modules,
+-- also returning the first, if any, encountered module cycle.
+buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])
+buildCompGraph [] = return ([], Nothing)
+buildCompGraph (scc:sccs) = case scc of
+    AcyclicSCC ms -> do
+        mvar <- newEmptyMVar
+        log_queue <- do
+            ref <- newIORef []
+            sem <- newEmptyMVar
+            return (LogQueue ref sem)
+        (rest,cycle) <- buildCompGraph sccs
+        return ((ms,mvar,log_queue):rest, cycle)
+    CyclicSCC mss -> return ([], Just mss)
+
+-- A Module and whether it is a boot module.
+type BuildModule = (Module, IsBoot)
+
+-- | 'Bool' indicating if a module is a boot module or not.  We need to treat
+-- boot modules specially when building compilation graphs, since they break
+-- cycles.  Regular source files and signature files are treated equivalently.
+data IsBoot = IsBoot | NotBoot
+    deriving (Ord, Eq, Show, Read)
+
+-- | Tests if an 'HscSource' is a boot file, primarily for constructing
+-- elements of 'BuildModule'.
+hscSourceToIsBoot :: HscSource -> IsBoot
+hscSourceToIsBoot HsBootFile = IsBoot
+hscSourceToIsBoot _ = NotBoot
+
+mkBuildModule :: ModSummary -> BuildModule
+mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot)
+
+-- | The entry point to the parallel upsweep.
+--
+-- See also the simpler, sequential 'upsweep'.
+parUpsweep
+    :: GhcMonad m
+    => Int
+    -- ^ The number of workers we wish to run in parallel
+    -> Maybe Messager
+    -> HomePackageTable
+    -> StableModules
+    -> (HscEnv -> IO ())
+    -> [SCC ModSummary]
+    -> m (SuccessFlag,
+          [ModSummary])
+parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
+    hsc_env <- getSession
+    let dflags = hsc_dflags hsc_env
+
+    when (not (null (unitIdsToCheck dflags))) $
+      throwGhcException (ProgramError "Backpack typechecking not supported with -j")
+
+    -- The bits of shared state we'll be using:
+
+    -- The global HscEnv is updated with the module's HMI when a module
+    -- successfully compiles.
+    hsc_env_var <- liftIO $ newMVar hsc_env
+
+    -- The old HPT is used for recompilation checking in upsweep_mod. When a
+    -- module successfully gets compiled, its HMI is pruned from the old HPT.
+    old_hpt_var <- liftIO $ newIORef old_hpt
+
+    -- What we use to limit parallelism with.
+    par_sem <- liftIO $ newQSem n_jobs
+
+
+    let updNumCapabilities = liftIO $ do
+            n_capabilities <- getNumCapabilities
+            n_cpus <- getNumProcessors
+            -- Setting number of capabilities more than
+            -- CPU count usually leads to high userspace
+            -- lock contention. Trac #9221
+            let n_caps = min n_jobs n_cpus
+            unless (n_capabilities /= 1) $ setNumCapabilities n_caps
+            return n_capabilities
+    -- Reset the number of capabilities once the upsweep ends.
+    let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n
+
+    gbracket updNumCapabilities resetNumCapabilities $ \_ -> do
+
+    -- Sync the global session with the latest HscEnv once the upsweep ends.
+    let finallySyncSession io = io `gfinally` do
+            hsc_env <- liftIO $ readMVar hsc_env_var
+            setSession hsc_env
+
+    finallySyncSession $ do
+
+    -- Build the compilation graph out of the list of SCCs. Module cycles are
+    -- handled at the very end, after some useful work gets done. Note that
+    -- this list is topologically sorted (by virtue of 'sccs' being sorted so).
+    (comp_graph,cycle) <- liftIO $ buildCompGraph sccs
+    let comp_graph_w_idx = zip comp_graph [1..]
+
+    -- The list of all loops in the compilation graph.
+    -- NB: For convenience, the last module of each loop (aka the module that
+    -- finishes the loop) is prepended to the beginning of the loop.
+    let graph = map fstOf3 (reverse comp_graph)
+        boot_modules = mkModuleSet [ms_mod ms | ms <- graph, isBootSummary ms]
+        comp_graph_loops = go graph boot_modules
+          where
+            remove ms bm
+              | isBootSummary ms = delModuleSet bm (ms_mod ms)
+              | otherwise = bm
+            go [] _ = []
+            go mg@(ms:mss) boot_modules
+              | Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules)
+              = map mkBuildModule (ms:loop) : go mss (remove ms boot_modules)
+              | otherwise
+              = go mss (remove ms boot_modules)
+
+    -- Build a Map out of the compilation graph with which we can efficiently
+    -- look up the result MVar associated with a particular home module.
+    let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
+        home_mod_map =
+            Map.fromList [ (mkBuildModule ms, (mvar, idx))
+                         | ((ms,mvar,_),idx) <- comp_graph_w_idx ]
+
+
+    liftIO $ label_self "main --make thread"
+    -- For each module in the module graph, spawn a worker thread that will
+    -- compile this module.
+    let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->
+            forkIOWithUnmask $ \unmask -> do
+                liftIO $ label_self $ unwords
+                    [ "worker --make thread"
+                    , "for module"
+                    , show (moduleNameString (ms_mod_name mod))
+                    , "number"
+                    , show mod_idx
+                    ]
+                -- Replace the default log_action with one that writes each
+                -- message to the module's log_queue. The main thread will
+                -- deal with synchronously printing these messages.
+                --
+                -- Use a local filesToClean var so that we can clean up
+                -- intermediate files in a timely fashion (as soon as
+                -- compilation for that module is finished) without having to
+                -- worry about accidentally deleting a simultaneous compile's
+                -- important files.
+                lcl_files_to_clean <- newIORef emptyFilesToClean
+                let lcl_dflags = dflags { log_action = parLogAction log_queue
+                                        , filesToClean = lcl_files_to_clean }
+
+                -- Unmask asynchronous exceptions and perform the thread-local
+                -- work to compile the module (see parUpsweep_one).
+                m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $
+                        parUpsweep_one mod home_mod_map comp_graph_loops
+                                       lcl_dflags mHscMessage cleanup
+                                       par_sem hsc_env_var old_hpt_var
+                                       stable_mods mod_idx (length sccs)
+
+                res <- case m_res of
+                    Right flag -> return flag
+                    Left exc -> do
+                        -- Don't print ThreadKilled exceptions: they are used
+                        -- to kill the worker thread in the event of a user
+                        -- interrupt, and the user doesn't have to be informed
+                        -- about that.
+                        when (fromException exc /= Just ThreadKilled)
+                             (errorMsg lcl_dflags (text (show exc)))
+                        return Failed
+
+                -- Populate the result MVar.
+                putMVar mvar res
+
+                -- Write the end marker to the message queue, telling the main
+                -- thread that it can stop waiting for messages from this
+                -- particular compile.
+                writeLogQueue log_queue Nothing
+
+                -- Add the remaining files that weren't cleaned up to the
+                -- global filesToClean ref, for cleanup later.
+                FilesToClean
+                  { ftcCurrentModule = cm_files
+                  , ftcGhcSession = gs_files
+                  } <- readIORef (filesToClean lcl_dflags)
+                addFilesToClean dflags TFL_CurrentModule $ Set.toList cm_files
+                addFilesToClean dflags TFL_GhcSession $ Set.toList gs_files
+
+        -- Kill all the workers, masking interrupts (since killThread is
+        -- interruptible). XXX: This is not ideal.
+        ; killWorkers = uninterruptibleMask_ . mapM_ killThread }
+
+
+    -- Spawn the workers, making sure to kill them later. Collect the results
+    -- of each compile.
+    results <- liftIO $ bracket spawnWorkers killWorkers $ \_ ->
+        -- Loop over each module in the compilation graph in order, printing
+        -- each message from its log_queue.
+        forM comp_graph $ \(mod,mvar,log_queue) -> do
+            printLogs dflags log_queue
+            result <- readMVar mvar
+            if succeeded result then return (Just mod) else return Nothing
+
+
+    -- Collect and return the ModSummaries of all the successful compiles.
+    -- NB: Reverse this list to maintain output parity with the sequential upsweep.
+    let ok_results = reverse (catMaybes results)
+
+    -- Handle any cycle in the original compilation graph and return the result
+    -- of the upsweep.
+    case cycle of
+        Just mss -> do
+            liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss)
+            return (Failed,ok_results)
+        Nothing  -> do
+            let success_flag = successIf (all isJust results)
+            return (success_flag,ok_results)
+
+  where
+    writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()
+    writeLogQueue (LogQueue ref sem) msg = do
+        atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
+        _ <- tryPutMVar sem ()
+        return ()
+
+    -- The log_action callback that is used to synchronize messages from a
+    -- worker thread.
+    parLogAction :: LogQueue -> LogAction
+    parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do
+        writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg))
+
+    -- Print each message from the log_queue using the log_action from the
+    -- session's DynFlags.
+    printLogs :: DynFlags -> LogQueue -> IO ()
+    printLogs !dflags (LogQueue ref sem) = read_msgs
+      where read_msgs = do
+                takeMVar sem
+                msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)
+                print_loop msgs
+
+            print_loop [] = read_msgs
+            print_loop (x:xs) = case x of
+                Just (reason,severity,srcSpan,style,msg) -> do
+                    putLogMsg dflags reason severity srcSpan style msg
+                    print_loop xs
+                -- Exit the loop once we encounter the end marker.
+                Nothing -> return ()
+
+-- The interruptible subset of the worker threads' work.
+parUpsweep_one
+    :: ModSummary
+    -- ^ The module we wish to compile
+    -> Map BuildModule (MVar SuccessFlag, Int)
+    -- ^ The map of home modules and their result MVar
+    -> [[BuildModule]]
+    -- ^ The list of all module loops within the compilation graph.
+    -> DynFlags
+    -- ^ The thread-local DynFlags
+    -> Maybe Messager
+    -- ^ The messager
+    -> (HscEnv -> IO ())
+    -- ^ The callback for cleaning up intermediate files
+    -> QSem
+    -- ^ The semaphore for limiting the number of simultaneous compiles
+    -> MVar HscEnv
+    -- ^ The MVar that synchronizes updates to the global HscEnv
+    -> IORef HomePackageTable
+    -- ^ The old HPT
+    -> StableModules
+    -- ^ Sets of stable objects and BCOs
+    -> Int
+    -- ^ The index of this module
+    -> Int
+    -- ^ The total number of modules
+    -> IO SuccessFlag
+    -- ^ The result of this compile
+parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem
+               hsc_env_var old_hpt_var stable_mods mod_index num_mods = do
+
+    let this_build_mod = mkBuildModule mod
+
+    let home_imps     = map unLoc $ ms_home_imps mod
+    let home_src_imps = map unLoc $ ms_home_srcimps mod
+
+    -- All the textual imports of this module.
+    let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $
+                            zip home_imps     (repeat NotBoot) ++
+                            zip home_src_imps (repeat IsBoot)
+
+    -- Dealing with module loops
+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~
+    --
+    -- Not only do we have to deal with explicit textual dependencies, we also
+    -- have to deal with implicit dependencies introduced by import cycles that
+    -- are broken by an hs-boot file. We have to ensure that:
+    --
+    -- 1. A module that breaks a loop must depend on all the modules in the
+    --    loop (transitively or otherwise). This is normally always fulfilled
+    --    by the module's textual dependencies except in degenerate loops,
+    --    e.g.:
+    --
+    --    A.hs imports B.hs-boot
+    --    B.hs doesn't import A.hs
+    --    C.hs imports A.hs, B.hs
+    --
+    --    In this scenario, getModLoop will detect the module loop [A,B] but
+    --    the loop finisher B doesn't depend on A. So we have to explicitly add
+    --    A in as a dependency of B when we are compiling B.
+    --
+    -- 2. A module that depends on a module in an external loop can't proceed
+    --    until the entire loop is re-typechecked.
+    --
+    -- These two invariants have to be maintained to correctly build a
+    -- compilation graph with one or more loops.
+
+
+    -- The loop that this module will finish. After this module successfully
+    -- compiles, this loop is going to get re-typechecked.
+    let finish_loop = listToMaybe
+            [ tail loop | loop <- comp_graph_loops
+                        , head loop == this_build_mod ]
+
+    -- If this module finishes a loop then it must depend on all the other
+    -- modules in that loop because the entire module loop is going to be
+    -- re-typechecked once this module gets compiled. These extra dependencies
+    -- are this module's "internal" loop dependencies, because this module is
+    -- inside the loop in question.
+    let int_loop_deps = Set.fromList $
+            case finish_loop of
+                Nothing   -> []
+                Just loop -> filter (/= this_build_mod) loop
+
+    -- If this module depends on a module within a loop then it must wait for
+    -- that loop to get re-typechecked, i.e. it must wait on the module that
+    -- finishes that loop. These extra dependencies are this module's
+    -- "external" loop dependencies, because this module is outside of the
+    -- loop(s) in question.
+    let ext_loop_deps = Set.fromList
+            [ head loop | loop <- comp_graph_loops
+                        , any (`Set.member` textual_deps) loop
+                        , this_build_mod `notElem` loop ]
+
+
+    let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps]
+
+    -- All of the module's home-module dependencies.
+    let home_deps_with_idx =
+            [ home_dep | dep <- Set.toList all_deps
+                       , Just home_dep <- [Map.lookup dep home_mod_map] ]
+
+    -- Sort the list of dependencies in reverse-topological order. This way, by
+    -- the time we get woken up by the result of an earlier dependency,
+    -- subsequent dependencies are more likely to have finished. This step
+    -- effectively reduces the number of MVars that each thread blocks on.
+    let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx
+
+    -- Wait for the all the module's dependencies to finish building.
+    deps_ok <- allM (fmap succeeded . readMVar) home_deps
+
+    -- We can't build this module if any of its dependencies failed to build.
+    if not deps_ok
+      then return Failed
+      else do
+        -- Any hsc_env at this point is OK to use since we only really require
+        -- that the HPT contains the HMIs of our dependencies.
+        hsc_env <- readMVar hsc_env_var
+        old_hpt <- readIORef old_hpt_var
+
+        let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err)
+
+        -- Limit the number of parallel compiles.
+        let withSem sem = bracket_ (waitQSem sem) (signalQSem sem)
+        mb_mod_info <- withSem par_sem $
+            handleSourceError (\err -> do logger err; return Nothing) $ do
+                -- Have the ModSummary and HscEnv point to our local log_action
+                -- and filesToClean var.
+                let lcl_mod = localize_mod mod
+                let lcl_hsc_env = localize_hsc_env hsc_env
+
+                -- Re-typecheck the loop
+                -- This is necessary to make sure the knot is tied when
+                -- we close a recursive module loop, see bug #12035.
+                type_env_var <- liftIO $ newIORef emptyNameEnv
+                let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var =
+                                    Just (ms_mod lcl_mod, type_env_var) }
+                lcl_hsc_env'' <- case finish_loop of
+                    Nothing   -> return lcl_hsc_env'
+                    -- In the non-parallel case, the retypecheck prior to
+                    -- typechecking the loop closer includes all modules
+                    -- EXCEPT the loop closer.  However, our precomputed
+                    -- SCCs include the loop closer, so we have to filter
+                    -- it out.
+                    Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $
+                                 filter (/= moduleName (fst this_build_mod)) $
+                                 map (moduleName . fst) loop
+
+                -- Compile the module.
+                mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods
+                                        lcl_mod mod_index num_mods
+                return (Just mod_info)
+
+        case mb_mod_info of
+            Nothing -> return Failed
+            Just mod_info -> do
+                let this_mod = ms_mod_name mod
+
+                -- Prune the old HPT unless this is an hs-boot module.
+                unless (isBootSummary mod) $
+                    atomicModifyIORef' old_hpt_var $ \old_hpt ->
+                        (delFromHpt old_hpt this_mod, ())
+
+                -- Update and fetch the global HscEnv.
+                lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do
+                    let hsc_env' = hsc_env
+                                     { hsc_HPT = addToHpt (hsc_HPT hsc_env)
+                                                           this_mod mod_info }
+                    -- We've finished typechecking the module, now we must
+                    -- retypecheck the loop AGAIN to ensure unfoldings are
+                    -- updated.  This time, however, we include the loop
+                    -- closer!
+                    hsc_env'' <- case finish_loop of
+                        Nothing   -> return hsc_env'
+                        Just loop -> typecheckLoop lcl_dflags hsc_env' $
+                                     map (moduleName . fst) loop
+                    return (hsc_env'', localize_hsc_env hsc_env'')
+
+                -- Clean up any intermediate files.
+                cleanup lcl_hsc_env'
+                return Succeeded
+
+  where
+    localize_mod mod
+        = mod { ms_hspp_opts = (ms_hspp_opts mod)
+                 { log_action = log_action lcl_dflags
+                 , filesToClean = filesToClean lcl_dflags } }
+
+    localize_hsc_env hsc_env
+        = hsc_env { hsc_dflags = (hsc_dflags hsc_env)
+                     { log_action = log_action lcl_dflags
+                     , filesToClean = filesToClean lcl_dflags } }
+
+-- -----------------------------------------------------------------------------
+--
+-- | The upsweep
+--
+-- This is where we compile each module in the module graph, in a pass
+-- from the bottom to the top of the graph.
+--
+-- There better had not be any cyclic groups here -- we check for them.
+upsweep
+    :: GhcMonad m
+    => Maybe Messager
+    -> HomePackageTable            -- ^ HPT from last time round (pruned)
+    -> StableModules               -- ^ stable modules (see checkStability)
+    -> (HscEnv -> IO ())           -- ^ How to clean up unwanted tmp files
+    -> [SCC ModSummary]            -- ^ Mods to do (the worklist)
+    -> m (SuccessFlag,
+          [ModSummary])
+       -- ^ Returns:
+       --
+       --  1. A flag whether the complete upsweep was successful.
+       --  2. The 'HscEnv' in the monad has an updated HPT
+       --  3. A list of modules which succeeded loading.
+
+upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
+   dflags <- getSessionDynFlags
+   (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs)
+                           (unitIdsToCheck dflags) done_holes
+   return (res, reverse $ mgModSummaries done)
+ where
+  done_holes = emptyUniqSet
+
+  upsweep'
+    :: GhcMonad m
+    => HomePackageTable
+    -> ModuleGraph
+    -> [SCC ModSummary]
+    -> Int
+    -> Int
+    -> [UnitId]
+    -> UniqSet ModuleName
+    -> m (SuccessFlag, ModuleGraph)
+  upsweep' _old_hpt done
+     [] _ _ uids_to_check _
+   = do hsc_env <- getSession
+        liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check
+        return (Succeeded, done)
+
+  upsweep' _old_hpt done
+     (CyclicSCC ms:_) _ _ _ _
+   = do dflags <- getSessionDynFlags
+        liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
+        return (Failed, done)
+
+  upsweep' old_hpt done
+     (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes
+   = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
+        --           show (map (moduleUserString.moduleName.mi_module.hm_iface)
+        --                     (moduleEnvElts (hsc_HPT hsc_env)))
+        let logger _mod = defaultWarnErrLogger
+
+        hsc_env <- getSession
+
+        -- TODO: Cache this, so that we don't repeatedly re-check
+        -- our imports when you run --make.
+        let (ready_uids, uids_to_check')
+                = partition (\uid -> isEmptyUniqDSet
+                    (unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes))
+                     uids_to_check
+            done_holes'
+                | ms_hsc_src mod == HsigFile
+                = addOneToUniqSet done_holes (ms_mod_name mod)
+                | otherwise = done_holes
+        liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids
+
+        -- Remove unwanted tmp files between compilations
+        liftIO (cleanup hsc_env)
+
+        -- Get ready to tie the knot
+        type_env_var <- liftIO $ newIORef emptyNameEnv
+        let hsc_env1 = hsc_env { hsc_type_env_var =
+                                    Just (ms_mod mod, type_env_var) }
+        setSession hsc_env1
+
+        -- Lazily reload the HPT modules participating in the loop.
+        -- See Note [Tying the knot]--if we don't throw out the old HPT
+        -- and reinitalize the knot-tying process, anything that was forced
+        -- while we were previously typechecking won't get updated, this
+        -- was bug #12035.
+        hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done
+        setSession hsc_env2
+
+        mb_mod_info
+            <- handleSourceError
+                   (\err -> do logger mod (Just err); return Nothing) $ do
+                 mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods
+                                                  mod mod_index nmods
+                 logger mod Nothing -- log warnings
+                 return (Just mod_info)
+
+        case mb_mod_info of
+          Nothing -> return (Failed, done)
+          Just mod_info -> do
+                let this_mod = ms_mod_name mod
+
+                        -- Add new info to hsc_env
+                    hpt1     = addToHpt (hsc_HPT hsc_env2) this_mod mod_info
+                    hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing }
+
+                        -- Space-saving: delete the old HPT entry
+                        -- for mod BUT if mod is a hs-boot
+                        -- node, don't delete it.  For the
+                        -- interface, the HPT entry is probaby for the
+                        -- main Haskell source file.  Deleting it
+                        -- would force the real module to be recompiled
+                        -- every time.
+                    old_hpt1 | isBootSummary mod = old_hpt
+                             | otherwise = delFromHpt old_hpt this_mod
+
+                    done' = extendMG done mod
+
+                        -- fixup our HomePackageTable after we've finished compiling
+                        -- a mutually-recursive loop.  We have to do this again
+                        -- to make sure we have the final unfoldings, which may
+                        -- not have been computed accurately in the previous
+                        -- retypecheck.
+                hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done'
+                setSession hsc_env4
+
+                        -- Add any necessary entries to the static pointer
+                        -- table. See Note [Grand plan for static forms] in
+                        -- StaticPtrTable.
+                when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $
+                    liftIO $ hscAddSptEntries hsc_env4
+                                 [ spt
+                                 | Just linkable <- pure $ hm_linkable mod_info
+                                 , unlinked <- linkableUnlinked linkable
+                                 , BCOs _ spts <- pure unlinked
+                                 , spt <- spts
+                                 ]
+
+                upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes'
+
+unitIdsToCheck :: DynFlags -> [UnitId]
+unitIdsToCheck dflags =
+  nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags))
+ where
+  goUnitId uid =
+    case splitUnitIdInsts uid of
+      (_, Just indef) ->
+        let insts = indefUnitIdInsts indef
+        in uid : concatMap (goUnitId . moduleUnitId . snd) insts
+      _ -> []
+
+maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)
+maybeGetIfaceDate dflags location
+ | writeInterfaceOnlyMode dflags
+    -- Minor optimization: it should be harmless to check the hi file location
+    -- always, but it's better to avoid hitting the filesystem if possible.
+    = modificationTimeIfExists (ml_hi_file location)
+ | otherwise
+    = return Nothing
+
+-- | Compile a single module.  Always produce a Linkable for it if
+-- successful.  If no compilation happened, return the old Linkable.
+upsweep_mod :: HscEnv
+            -> Maybe Messager
+            -> HomePackageTable
+            -> StableModules
+            -> ModSummary
+            -> Int  -- index of module
+            -> Int  -- total number of modules
+            -> IO HomeModInfo
+upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods
+   =    let
+            this_mod_name = ms_mod_name summary
+            this_mod    = ms_mod summary
+            mb_obj_date = ms_obj_date summary
+            mb_if_date  = ms_iface_date summary
+            obj_fn      = ml_obj_file (ms_location summary)
+            hs_date     = ms_hs_date summary
+
+            is_stable_obj = this_mod_name `elementOfUniqSet` stable_obj
+            is_stable_bco = this_mod_name `elementOfUniqSet` stable_bco
+
+            old_hmi = lookupHpt old_hpt this_mod_name
+
+            -- We're using the dflags for this module now, obtained by
+            -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
+            dflags = ms_hspp_opts summary
+            prevailing_target = hscTarget (hsc_dflags hsc_env)
+            local_target      = hscTarget dflags
+
+            -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that
+            -- we don't do anything dodgy: these should only work to change
+            -- from -fllvm to -fasm and vice-versa, or away from -fno-code,
+            -- otherwise we could end up trying to link object code to byte
+            -- code.
+            target = if prevailing_target /= local_target
+                        && (not (isObjectTarget prevailing_target)
+                            || not (isObjectTarget local_target))
+                        && not (prevailing_target == HscNothing)
+                        then prevailing_target
+                        else local_target
+
+            -- store the corrected hscTarget into the summary
+            summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
+
+            -- The old interface is ok if
+            --  a) we're compiling a source file, and the old HPT
+            --     entry is for a source file
+            --  b) we're compiling a hs-boot file
+            -- Case (b) allows an hs-boot file to get the interface of its
+            -- real source file on the second iteration of the compilation
+            -- manager, but that does no harm.  Otherwise the hs-boot file
+            -- will always be recompiled
+
+            mb_old_iface
+                = case old_hmi of
+                     Nothing                              -> Nothing
+                     Just hm_info | isBootSummary summary -> Just iface
+                                  | not (mi_boot iface)   -> Just iface
+                                  | otherwise             -> Nothing
+                                   where
+                                     iface = hm_iface hm_info
+
+            compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo
+            compile_it  mb_linkable src_modified =
+                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods
+                             mb_old_iface mb_linkable src_modified
+
+            compile_it_discard_iface :: Maybe Linkable -> SourceModified
+                                     -> IO HomeModInfo
+            compile_it_discard_iface mb_linkable  src_modified =
+                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods
+                             Nothing mb_linkable src_modified
+
+            -- With the HscNothing target we create empty linkables to avoid
+            -- recompilation.  We have to detect these to recompile anyway if
+            -- the target changed since the last compile.
+            is_fake_linkable
+               | Just hmi <- old_hmi, Just l <- hm_linkable hmi =
+                  null (linkableUnlinked l)
+               | otherwise =
+                   -- we have no linkable, so it cannot be fake
+                   False
+
+            implies False _ = True
+            implies True x  = x
+
+        in
+        case () of
+         _
+                -- Regardless of whether we're generating object code or
+                -- byte code, we can always use an existing object file
+                -- if it is *stable* (see checkStability).
+          | is_stable_obj, Just hmi <- old_hmi -> do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "skipping stable obj mod:" <+> ppr this_mod_name)
+                return hmi
+                -- object is stable, and we have an entry in the
+                -- old HPT: nothing to do
+
+          | is_stable_obj, isNothing old_hmi -> do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
+                linkable <- liftIO $ findObjectLinkable this_mod obj_fn
+                              (expectJust "upsweep1" mb_obj_date)
+                compile_it (Just linkable) SourceUnmodifiedAndStable
+                -- object is stable, but we need to load the interface
+                -- off disk to make a HMI.
+
+          | not (isObjectTarget target), is_stable_bco,
+            (target /= HscNothing) `implies` not is_fake_linkable ->
+                ASSERT(isJust old_hmi) -- must be in the old_hpt
+                let Just hmi = old_hmi in do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "skipping stable BCO mod:" <+> ppr this_mod_name)
+                return hmi
+                -- BCO is stable: nothing to do
+
+          | not (isObjectTarget target),
+            Just hmi <- old_hmi,
+            Just l <- hm_linkable hmi,
+            not (isObjectLinkable l),
+            (target /= HscNothing) `implies` not is_fake_linkable,
+            linkableTime l >= ms_hs_date summary -> do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
+                compile_it (Just l) SourceUnmodified
+                -- we have an old BCO that is up to date with respect
+                -- to the source: do a recompilation check as normal.
+
+          -- When generating object code, if there's an up-to-date
+          -- object file on the disk, then we can use it.
+          -- However, if the object file is new (compared to any
+          -- linkable we had from a previous compilation), then we
+          -- must discard any in-memory interface, because this
+          -- means the user has compiled the source file
+          -- separately and generated a new interface, that we must
+          -- read from the disk.
+          --
+          | isObjectTarget target,
+            Just obj_date <- mb_obj_date,
+            obj_date >= hs_date -> do
+                case old_hmi of
+                  Just hmi
+                    | Just l <- hm_linkable hmi,
+                      isObjectLinkable l && linkableTime l == obj_date -> do
+                          liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                                     (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
+                          compile_it (Just l) SourceUnmodified
+                  _otherwise -> do
+                          liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                                     (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
+                          linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
+                          compile_it_discard_iface (Just linkable) SourceUnmodified
+
+          -- See Note [Recompilation checking in -fno-code mode]
+          | writeInterfaceOnlyMode dflags,
+            Just if_date <- mb_if_date,
+            if_date >= hs_date -> do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "skipping tc'd mod:" <+> ppr this_mod_name)
+                compile_it Nothing SourceUnmodified
+
+         _otherwise -> do
+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+                           (text "compiling mod:" <+> ppr this_mod_name)
+                compile_it Nothing SourceModified
+
+
+{- Note [-fno-code mode]
+~~~~~~~~~~~~~~~~~~~~~~~~
+GHC offers the flag -fno-code for the purpose of parsing and typechecking a
+program without generating object files. This is intended to be used by tooling
+and IDEs to provide quick feedback on any parser or type errors as cheaply as
+possible.
+
+When GHC is invoked with -fno-code no object files or linked output will be
+generated. As many errors and warnings as possible will be generated, as if
+-fno-code had not been passed. The session DynFlags will have
+hscTarget == HscNothing.
+
+-fwrite-interface
+~~~~~~~~~~~~~~~~
+Whether interface files are generated in -fno-code mode is controlled by the
+-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
+not also passed. Recompilation avoidance requires interface files, so passing
+-fno-code without -fwrite-interface should be avoided. If -fno-code were
+re-implemented today, -fwrite-interface would be discarded and it would be
+considered always on; this behaviour is as it is for backwards compatibility.
+
+================================================================
+IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
+================================================================
+
+Template Haskell
+~~~~~~~~~~~~~~~~
+A module using template haskell may invoke an imported function from inside a
+splice. This will cause the type-checker to attempt to execute that code, which
+would fail if no object files had been generated. See #8025. To rectify this,
+during the downsweep we patch the DynFlags in the ModSummary of any home module
+that is imported by a module that uses template haskell, to generate object
+code.
+
+The flavour of generated object code is chosen by defaultObjectTarget for the
+target platform. It would likely be faster to generate bytecode, but this is not
+supported on all platforms(?Please Confirm?), and does not support the entirety
+of GHC haskell. See #1257.
+
+The object files (and interface files if -fwrite-interface is disabled) produced
+for template haskell are written to temporary files.
+
+Note that since template haskell can run arbitrary IO actions, -fno-code mode
+is no more secure than running without it.
+
+Potential TODOS:
+~~~~~
+* Remove -fwrite-interface and have interface files always written in -fno-code
+  mode
+* Both .o and .dyn_o files are generated for template haskell, but we only need
+  .dyn_o. Fix it.
+* In make mode, a message like
+  Compiling A (A.hs, /tmp/ghc_123.o)
+  is shown if downsweep enabled object code generation for A. Perhaps we should
+  show "nothing" or "temporary object file" instead. Note that one
+  can currently use -keep-tmp-files and inspect the generated file with the
+  current behaviour.
+* Offer a -no-codedir command line option, and write what were temporary
+  object files there. This would speed up recompilation.
+* Use existing object files (if they are up to date) instead of always
+  generating temporary ones.
+-}
+
+-- Note [Recompilation checking in -fno-code mode]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- If we are compiling with -fno-code -fwrite-interface, there won't
+-- be any object code that we can compare against, nor should there
+-- be: we're *just* generating interface files.  In this case, we
+-- want to check if the interface file is new, in lieu of the object
+-- file.  See also Trac #9243.
+
+-- Filter modules in the HPT
+retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
+retainInTopLevelEnvs keep_these hpt
+   = listToHpt   [ (mod, expectJust "retain" mb_mod_info)
+                 | mod <- keep_these
+                 , let mb_mod_info = lookupHpt hpt mod
+                 , isJust mb_mod_info ]
+
+-- ---------------------------------------------------------------------------
+-- Typecheck module loops
+{-
+See bug #930.  This code fixes a long-standing bug in --make.  The
+problem is that when compiling the modules *inside* a loop, a data
+type that is only defined at the top of the loop looks opaque; but
+after the loop is done, the structure of the data type becomes
+apparent.
+
+The difficulty is then that two different bits of code have
+different notions of what the data type looks like.
+
+The idea is that after we compile a module which also has an .hs-boot
+file, we re-generate the ModDetails for each of the modules that
+depends on the .hs-boot file, so that everyone points to the proper
+TyCons, Ids etc. defined by the real module, not the boot module.
+Fortunately re-generating a ModDetails from a ModIface is easy: the
+function TcIface.typecheckIface does exactly that.
+
+Picking the modules to re-typecheck is slightly tricky.  Starting from
+the module graph consisting of the modules that have already been
+compiled, we reverse the edges (so they point from the imported module
+to the importing module), and depth-first-search from the .hs-boot
+node.  This gives us all the modules that depend transitively on the
+.hs-boot module, and those are exactly the modules that we need to
+re-typecheck.
+
+Following this fix, GHC can compile itself with --make -O2.
+-}
+
+reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
+reTypecheckLoop hsc_env ms graph
+  | Just loop <- getModLoop ms mss appearsAsBoot
+  -- SOME hs-boot files should still
+  -- get used, just not the loop-closer.
+  , let non_boot = filter (\l -> not (isBootSummary l &&
+                                 ms_mod l == ms_mod ms)) loop
+  = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot)
+  | otherwise
+  = return hsc_env
+  where
+  mss = mgModSummaries graph
+  appearsAsBoot = (`elemModuleSet` mgBootModules graph)
+
+-- | Given a non-boot ModSummary @ms@ of a module, for which there exists a
+-- corresponding boot file in @graph@, return the set of modules which
+-- transitively depend on this boot file.  This function is slightly misnamed,
+-- but its name "getModLoop" alludes to the fact that, when getModLoop is called
+-- with a graph that does not contain @ms@ (non-parallel case) or is an
+-- SCC with hs-boot nodes dropped (parallel-case), the modules which
+-- depend on the hs-boot file are typically (but not always) the
+-- modules participating in the recursive module loop.  The returned
+-- list includes the hs-boot file.
+--
+-- Example:
+--      let g represent the module graph:
+--          C.hs
+--          A.hs-boot imports C.hs
+--          B.hs imports A.hs-boot
+--          A.hs imports B.hs
+--      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs]
+--
+--      It would also be permissible to omit A.hs from the graph,
+--      in which case the result is [A.hs-boot, B.hs]
+--
+-- Example:
+--      A counter-example to the claim that modules returned
+--      by this function participate in the loop occurs here:
+--
+--      let g represent the module graph:
+--          C.hs
+--          A.hs-boot imports C.hs
+--          B.hs imports A.hs-boot
+--          A.hs imports B.hs
+--          D.hs imports A.hs-boot
+--      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs, D.hs]
+--
+--      Arguably, D.hs should import A.hs, not A.hs-boot, but
+--      a dependency on the boot file is not illegal.
+--
+getModLoop
+  :: ModSummary
+  -> [ModSummary]
+  -> (Module -> Bool) -- check if a module appears as a boot module in 'graph'
+  -> Maybe [ModSummary]
+getModLoop ms graph appearsAsBoot
+  | not (isBootSummary ms)
+  , appearsAsBoot this_mod
+  , let mss = reachableBackwards (ms_mod_name ms) graph
+  = Just mss
+  | otherwise
+  = Nothing
+ where
+  this_mod = ms_mod ms
+
+-- NB: sometimes mods has duplicates; this is harmless because
+-- any duplicates get clobbered in addListToHpt and never get forced.
+typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv
+typecheckLoop dflags hsc_env mods = do
+  debugTraceMsg dflags 2 $
+     text "Re-typechecking loop: " <> ppr mods
+  new_hpt <-
+    fixIO $ \new_hpt -> do
+      let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
+      mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $
+                mapM (typecheckIface . hm_iface) hmis
+      let new_hpt = addListToHpt old_hpt
+                        (zip mods [ hmi{ hm_details = details }
+                                  | (hmi,details) <- zip hmis mds ])
+      return new_hpt
+  return hsc_env{ hsc_HPT = new_hpt }
+  where
+    old_hpt = hsc_HPT hsc_env
+    hmis    = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods
+
+reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
+reachableBackwards mod summaries
+  = [ node_payload node | node <- reachableG (transposeG graph) root ]
+  where -- the rest just sets up the graph:
+        (graph, lookup_node) = moduleGraphNodes False summaries
+        root  = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
+
+-- ---------------------------------------------------------------------------
+--
+-- | Topological sort of the module graph
+topSortModuleGraph
+          :: Bool
+          -- ^ Drop hi-boot nodes? (see below)
+          -> ModuleGraph
+          -> Maybe ModuleName
+             -- ^ Root module name.  If @Nothing@, use the full graph.
+          -> [SCC ModSummary]
+-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
+-- The resulting list of strongly-connected-components is in topologically
+-- sorted order, starting with the module(s) at the bottom of the
+-- dependency graph (ie compile them first) and ending with the ones at
+-- the top.
+--
+-- Drop hi-boot nodes (first boolean arg)?
+--
+-- - @False@:   treat the hi-boot summaries as nodes of the graph,
+--              so the graph must be acyclic
+--
+-- - @True@:    eliminate the hi-boot nodes, and instead pretend
+--              the a source-import of Foo is an import of Foo
+--              The resulting graph has no hi-boot nodes, but can be cyclic
+
+topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod
+  = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
+  where
+    summaries = mgModSummaries module_graph
+    -- stronglyConnCompG flips the original order, so if we reverse
+    -- the summaries we get a stable topological sort.
+    (graph, lookup_node) =
+      moduleGraphNodes drop_hs_boot_nodes (reverse summaries)
+
+    initial_graph = case mb_root_mod of
+        Nothing -> graph
+        Just root_mod ->
+            -- restrict the graph to just those modules reachable from
+            -- the specified module.  We do this by building a graph with
+            -- the full set of nodes, and determining the reachable set from
+            -- the specified node.
+            let root | Just node <- lookup_node HsSrcFile root_mod
+                     , graph `hasVertexG` node
+                     = node
+                     | otherwise
+                     = throwGhcException (ProgramError "module does not exist")
+            in graphFromEdgedVerticesUniq (seq root (reachableG graph root))
+
+type SummaryNode = Node Int ModSummary
+
+summaryNodeKey :: SummaryNode -> Int
+summaryNodeKey = node_key
+
+summaryNodeSummary :: SummaryNode -> ModSummary
+summaryNodeSummary = node_payload
+
+moduleGraphNodes :: Bool -> [ModSummary]
+  -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
+moduleGraphNodes drop_hs_boot_nodes summaries =
+  (graphFromEdgedVerticesUniq nodes, lookup_node)
+  where
+    numbered_summaries = zip summaries [1..]
+
+    lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
+    lookup_node hs_src mod = Map.lookup (mod, hscSourceToIsBoot hs_src) node_map
+
+    lookup_key :: HscSource -> ModuleName -> Maybe Int
+    lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
+
+    node_map :: NodeMap SummaryNode
+    node_map = Map.fromList [ ((moduleName (ms_mod s),
+                                hscSourceToIsBoot (ms_hsc_src s)), node)
+                            | node <- nodes
+                            , let s = summaryNodeSummary node ]
+
+    -- We use integers as the keys for the SCC algorithm
+    nodes :: [SummaryNode]
+    nodes = [ DigraphNode s key out_keys
+            | (s, key) <- numbered_summaries
+             -- Drop the hi-boot ones if told to do so
+            , not (isBootSummary s && drop_hs_boot_nodes)
+            , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
+                             out_edge_keys HsSrcFile   (map unLoc (ms_home_imps s)) ++
+                             (-- see [boot-edges] below
+                              if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
+                              then []
+                              else case lookup_key HsBootFile (ms_mod_name s) of
+                                    Nothing -> []
+                                    Just k  -> [k]) ]
+
+    -- [boot-edges] if this is a .hs and there is an equivalent
+    -- .hs-boot, add a link from the former to the latter.  This
+    -- has the effect of detecting bogus cases where the .hs-boot
+    -- depends on the .hs, by introducing a cycle.  Additionally,
+    -- it ensures that we will always process the .hs-boot before
+    -- the .hs, and so the HomePackageTable will always have the
+    -- most up to date information.
+
+    -- Drop hs-boot nodes by using HsSrcFile as the key
+    hs_boot_key | drop_hs_boot_nodes = HsSrcFile
+                | otherwise          = HsBootFile
+
+    out_edge_keys :: HscSource -> [ModuleName] -> [Int]
+    out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms
+        -- If we want keep_hi_boot_nodes, then we do lookup_key with
+        -- IsBoot; else NotBoot
+
+-- The nodes of the graph are keyed by (mod, is boot?) pairs
+-- NB: hsig files show up as *normal* nodes (not boot!), since they don't
+-- participate in cycles (for now)
+type NodeKey   = (ModuleName, IsBoot)
+type NodeMap a = Map.Map NodeKey a
+
+msKey :: ModSummary -> NodeKey
+msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot })
+    = (moduleName mod, hscSourceToIsBoot boot)
+
+mkNodeMap :: [ModSummary] -> NodeMap ModSummary
+mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
+
+nodeMapElts :: NodeMap a -> [a]
+nodeMapElts = Map.elems
+
+-- | If there are {-# SOURCE #-} imports between strongly connected
+-- components in the topological sort, then those imports can
+-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
+-- were necessary, then the edge would be part of a cycle.
+warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
+warnUnnecessarySourceImports sccs = do
+  dflags <- getDynFlags
+  when (wopt Opt_WarnUnusedImports dflags)
+    (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)))
+  where check dflags ms =
+           let mods_in_this_cycle = map ms_mod_name ms in
+           [ warn dflags i | m <- ms, i <- ms_home_srcimps m,
+                             unLoc i `notElem`  mods_in_this_cycle ]
+
+        warn :: DynFlags -> Located ModuleName -> WarnMsg
+        warn dflags (L loc mod) =
+           mkPlainErrMsg dflags loc
+                (text "Warning: {-# SOURCE #-} unnecessary in import of "
+                 <+> quotes (ppr mod))
+
+
+reportImportErrors :: MonadIO m => [Either ErrMsg b] -> m [b]
+reportImportErrors xs | null errs = return oks
+                      | otherwise = throwManyErrors errs
+  where (errs, oks) = partitionEithers xs
+
+throwManyErrors :: MonadIO m => [ErrMsg] -> m ab
+throwManyErrors errs = liftIO $ throwIO $ mkSrcErr $ listToBag errs
+
+
+-----------------------------------------------------------------------------
+--
+-- | Downsweep (dependency analysis)
+--
+-- Chase downwards from the specified root set, returning summaries
+-- for all home modules encountered.  Only follow source-import
+-- links.
+--
+-- We pass in the previous collection of summaries, which is used as a
+-- cache to avoid recalculating a module summary if the source is
+-- unchanged.
+--
+-- The returned list of [ModSummary] nodes has one node for each home-package
+-- module, plus one for any hs-boot files.  The imports of these nodes
+-- are all there, including the imports of non-home-package modules.
+downsweep :: HscEnv
+          -> [ModSummary]       -- Old summaries
+          -> [ModuleName]       -- Ignore dependencies on these; treat
+                                -- them as if they were package modules
+          -> Bool               -- True <=> allow multiple targets to have
+                                --          the same module name; this is
+                                --          very useful for ghc -M
+          -> IO [Either ErrMsg ModSummary]
+                -- The elts of [ModSummary] all have distinct
+                -- (Modules, IsBoot) identifiers, unless the Bool is true
+                -- in which case there can be repeats
+downsweep hsc_env old_summaries excl_mods allow_dup_roots
+   = do
+       rootSummaries <- mapM getRootSummary roots
+       rootSummariesOk <- reportImportErrors rootSummaries
+       let root_map = mkRootMap rootSummariesOk
+       checkDuplicates root_map
+       map0 <- loop (concatMap calcDeps rootSummariesOk) root_map
+       -- if we have been passed -fno-code, we enable code generation
+       -- for dependencies of modules that have -XTemplateHaskell,
+       -- otherwise those modules will fail to compile.
+       -- See Note [-fno-code mode] #8025
+       map1 <- if hscTarget dflags == HscNothing
+         then enableCodeGenForTH
+           (defaultObjectTarget (targetPlatform dflags))
+           map0
+         else return map0
+       return $ concat $ nodeMapElts map1
+     where
+        calcDeps = msDeps
+
+        dflags = hsc_dflags hsc_env
+        roots = hsc_targets hsc_env
+
+        old_summary_map :: NodeMap ModSummary
+        old_summary_map = mkNodeMap old_summaries
+
+        getRootSummary :: Target -> IO (Either ErrMsg ModSummary)
+        getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
+           = do exists <- liftIO $ doesFileExist file
+                if exists
+                    then Right `fmap` summariseFile hsc_env old_summaries file mb_phase
+                                       obj_allowed maybe_buf
+                    else return $ Left $ mkPlainErrMsg dflags noSrcSpan $
+                           text "can't find file:" <+> text file
+        getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
+           = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot
+                                           (L rootLoc modl) obj_allowed
+                                           maybe_buf excl_mods
+                case maybe_summary of
+                   Nothing -> return $ Left $ moduleNotFoundErr dflags modl
+                   Just s  -> return s
+
+        rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
+
+        -- In a root module, the filename is allowed to diverge from the module
+        -- name, so we have to check that there aren't multiple root files
+        -- defining the same module (otherwise the duplicates will be silently
+        -- ignored, leading to confusing behaviour).
+        checkDuplicates :: NodeMap [Either ErrMsg ModSummary] -> IO ()
+        checkDuplicates root_map
+           | allow_dup_roots = return ()
+           | null dup_roots  = return ()
+           | otherwise       = liftIO $ multiRootsErr dflags (head dup_roots)
+           where
+             dup_roots :: [[ModSummary]]        -- Each at least of length 2
+             dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map
+
+        loop :: [(Located ModuleName,IsBoot)]
+                        -- Work list: process these modules
+             -> NodeMap [Either ErrMsg ModSummary]
+                        -- Visited set; the range is a list because
+                        -- the roots can have the same module names
+                        -- if allow_dup_roots is True
+             -> IO (NodeMap [Either ErrMsg ModSummary])
+                        -- The result is the completed NodeMap
+        loop [] done = return done
+        loop ((wanted_mod, is_boot) : ss) done
+          | Just summs <- Map.lookup key done
+          = if isSingleton summs then
+                loop ss done
+            else
+                do { multiRootsErr dflags (rights summs); return Map.empty }
+          | otherwise
+          = do mb_s <- summariseModule hsc_env old_summary_map
+                                       is_boot wanted_mod True
+                                       Nothing excl_mods
+               case mb_s of
+                   Nothing -> loop ss done
+                   Just (Left e) -> loop ss (Map.insert key [Left e] done)
+                   Just (Right s)-> do
+                     new_map <-
+                       loop (calcDeps s) (Map.insert key [Right s] done)
+                     loop ss new_map
+          where
+            key = (unLoc wanted_mod, is_boot)
+
+-- | Update the every ModSummary that is depended on
+-- by a module that needs template haskell. We enable codegen to
+-- the specified target, disable optimization and change the .hi
+-- and .o file locations to be temporary files.
+-- See Note [-fno-code mode]
+enableCodeGenForTH :: HscTarget
+  -> NodeMap [Either ErrMsg ModSummary]
+  -> IO (NodeMap [Either ErrMsg ModSummary])
+enableCodeGenForTH target nodemap =
+  traverse (traverse (traverse enable_code_gen)) nodemap
+  where
+    enable_code_gen ms
+      | ModSummary
+        { ms_mod = ms_mod
+        , ms_location = ms_location
+        , ms_hsc_src = HsSrcFile
+        , ms_hspp_opts = dflags@DynFlags
+          {hscTarget = HscNothing}
+        } <- ms
+      -- Don't enable codegen for TH on indefinite packages; we
+      -- can't compile anything anyway! See #16219.
+      , not (isIndefinite dflags)
+      , ms_mod `Set.member` needs_codegen_set
+      = do
+        let new_temp_file suf dynsuf = do
+              tn <- newTempName dflags TFL_CurrentModule suf
+              let dyn_tn = tn -<.> dynsuf
+              addFilesToClean dflags TFL_GhcSession [dyn_tn]
+              return tn
+          -- We don't want to create .o or .hi files unless we have been asked
+          -- to by the user. But we need them, so we patch their locations in
+          -- the ModSummary with temporary files.
+          --
+        hi_file <-
+          if gopt Opt_WriteInterface dflags
+            then return $ ml_hi_file ms_location
+            else new_temp_file (hiSuf dflags) (dynHiSuf dflags)
+        o_temp_file <- new_temp_file (objectSuf dflags) (dynObjectSuf dflags)
+        return $
+          ms
+          { ms_location =
+              ms_location {ml_hi_file = hi_file, ml_obj_file = o_temp_file}
+          , ms_hspp_opts = updOptLevel 0 $ dflags {hscTarget = target}
+          }
+      | otherwise = return ms
+
+    needs_codegen_set = transitive_deps_set
+      [ ms
+      | mss <- Map.elems nodemap
+      , Right ms <- mss
+      , isTemplateHaskellOrQQNonBoot ms
+      ]
+
+    -- find the set of all transitive dependencies of a list of modules.
+    transitive_deps_set modSums = foldl' go Set.empty modSums
+      where
+        go marked_mods ms@ModSummary{ms_mod}
+          | ms_mod `Set.member` marked_mods = marked_mods
+          | otherwise =
+            let deps =
+                  [ dep_ms
+                  -- If a module imports a boot module, msDeps helpfully adds a
+                  -- dependency to that non-boot module in it's result. This
+                  -- means we don't have to think about boot modules here.
+                  | (L _ mn, NotBoot) <- msDeps ms
+                  , dep_ms <-
+                      toList (Map.lookup (mn, NotBoot) nodemap) >>= toList >>=
+                      toList
+                  ]
+                new_marked_mods = Set.insert ms_mod marked_mods
+            in foldl' go new_marked_mods deps
+
+mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary]
+mkRootMap summaries = Map.insertListWith (flip (++))
+                                         [ (msKey s, [Right s]) | s <- summaries ]
+                                         Map.empty
+
+-- | Returns the dependencies of the ModSummary s.
+-- A wrinkle is that for a {-# SOURCE #-} import we return
+--      *both* the hs-boot file
+--      *and* the source file
+-- as "dependencies".  That ensures that the list of all relevant
+-- modules always contains B.hs if it contains B.hs-boot.
+-- Remember, this pass isn't doing the topological sort.  It's
+-- just gathering the list of all relevant ModSummaries
+msDeps :: ModSummary -> [(Located ModuleName, IsBoot)]
+msDeps s =
+    concat [ [(m,IsBoot), (m,NotBoot)] | m <- ms_home_srcimps s ]
+        ++ [ (m,NotBoot) | m <- ms_home_imps s ]
+
+home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]
+home_imps imps = [ lmodname |  (mb_pkg, lmodname) <- imps,
+                                  isLocal mb_pkg ]
+  where isLocal Nothing = True
+        isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
+        isLocal _ = False
+
+ms_home_allimps :: ModSummary -> [ModuleName]
+ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
+
+-- | Like 'ms_home_imps', but for SOURCE imports.
+ms_home_srcimps :: ModSummary -> [Located ModuleName]
+ms_home_srcimps = home_imps . ms_srcimps
+
+-- | All of the (possibly) home module imports from a
+-- 'ModSummary'; that is to say, each of these module names
+-- could be a home import if an appropriately named file
+-- existed.  (This is in contrast to package qualified
+-- imports, which are guaranteed not to be home imports.)
+ms_home_imps :: ModSummary -> [Located ModuleName]
+ms_home_imps = home_imps . ms_imps
+
+-----------------------------------------------------------------------------
+-- Summarising modules
+
+-- We have two types of summarisation:
+--
+--    * Summarise a file.  This is used for the root module(s) passed to
+--      cmLoadModules.  The file is read, and used to determine the root
+--      module name.  The module name may differ from the filename.
+--
+--    * Summarise a module.  We are given a module name, and must provide
+--      a summary.  The finder is used to locate the file in which the module
+--      resides.
+
+summariseFile
+        :: HscEnv
+        -> [ModSummary]                 -- old summaries
+        -> FilePath                     -- source file name
+        -> Maybe Phase                  -- start phase
+        -> Bool                         -- object code allowed?
+        -> Maybe (StringBuffer,UTCTime)
+        -> IO ModSummary
+
+summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
+        -- we can use a cached summary if one is available and the
+        -- source file hasn't changed,  But we have to look up the summary
+        -- by source file, rather than module name as we do in summarise.
+   | Just old_summary <- findSummaryBySourceFile old_summaries file
+   = do
+        let location = ms_location old_summary
+            dflags = hsc_dflags hsc_env
+
+        src_timestamp <- get_src_timestamp
+                -- The file exists; we checked in getRootSummary above.
+                -- If it gets removed subsequently, then this
+                -- getModificationUTCTime may fail, but that's the right
+                -- behaviour.
+
+                -- return the cached summary if the source didn't change
+        if ms_hs_date old_summary == src_timestamp &&
+           not (gopt Opt_ForceRecomp (hsc_dflags hsc_env))
+           then do -- update the object-file timestamp
+                  obj_timestamp <-
+                    if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+                        || obj_allowed -- bug #1205
+                        then liftIO $ getObjTimestamp location NotBoot
+                        else return Nothing
+                  hi_timestamp <- maybeGetIfaceDate dflags location
+                  let hie_location = ml_hie_file location
+                  hie_timestamp <- modificationTimeIfExists hie_location
+
+                  -- We have to repopulate the Finder's cache because it
+                  -- was flushed before the downsweep.
+                  _ <- liftIO $ addHomeModuleToFinder hsc_env
+                    (moduleName (ms_mod old_summary)) (ms_location old_summary)
+
+                  return old_summary{ ms_obj_date = obj_timestamp
+                                    , ms_iface_date = hi_timestamp
+                                    , ms_hie_date = hie_timestamp }
+           else
+                new_summary src_timestamp
+
+   | otherwise
+   = do src_timestamp <- get_src_timestamp
+        new_summary src_timestamp
+  where
+    get_src_timestamp = case maybe_buf of
+                           Just (_,t) -> return t
+                           Nothing    -> liftIO $ getModificationUTCTime file
+                        -- getModificationUTCTime may fail
+
+    new_summary src_timestamp = do
+        let dflags = hsc_dflags hsc_env
+
+        let hsc_src = if isHaskellSigFilename file then HsigFile else HsSrcFile
+
+        (dflags', hspp_fn, buf)
+            <- preprocessFile hsc_env file mb_phase maybe_buf
+
+        (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
+
+        -- Make a ModLocation for this file
+        location <- liftIO $ mkHomeModLocation dflags mod_name file
+
+        -- Tell the Finder cache where it is, so that subsequent calls
+        -- to findModule will find it, even if it's not on any search path
+        mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
+
+        -- when the user asks to load a source file by name, we only
+        -- use an object file if -fobject-code is on.  See #1205.
+        obj_timestamp <-
+            if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+               || obj_allowed -- bug #1205
+                then liftIO $ modificationTimeIfExists (ml_obj_file location)
+                else return Nothing
+
+        hi_timestamp <- maybeGetIfaceDate dflags location
+        hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
+
+        extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name
+        required_by_imports <- implicitRequirements hsc_env the_imps
+
+        return (ModSummary { ms_mod = mod,
+                             ms_hsc_src = hsc_src,
+                             ms_location = location,
+                             ms_hspp_file = hspp_fn,
+                             ms_hspp_opts = dflags',
+                             ms_hspp_buf  = Just buf,
+                             ms_parsed_mod = Nothing,
+                             ms_srcimps = srcimps,
+                             ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,
+                             ms_hs_date = src_timestamp,
+                             ms_iface_date = hi_timestamp,
+                             ms_hie_date = hie_timestamp,
+                             ms_obj_date = obj_timestamp })
+
+findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
+findSummaryBySourceFile summaries file
+  = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
+                                 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
+        [] -> Nothing
+        (x:_) -> Just x
+
+-- Summarise a module, and pick up source and timestamp.
+summariseModule
+          :: HscEnv
+          -> NodeMap ModSummary -- Map of old summaries
+          -> IsBoot             -- IsBoot <=> a {-# SOURCE #-} import
+          -> Located ModuleName -- Imported module to be summarised
+          -> Bool               -- object code allowed?
+          -> Maybe (StringBuffer, UTCTime)
+          -> [ModuleName]               -- Modules to exclude
+          -> IO (Maybe (Either ErrMsg ModSummary))      -- Its new summary
+
+summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
+                obj_allowed maybe_buf excl_mods
+  | wanted_mod `elem` excl_mods
+  = return Nothing
+
+  | Just old_summary <- Map.lookup (wanted_mod, is_boot) old_summary_map
+  = do          -- Find its new timestamp; all the
+                -- ModSummaries in the old map have valid ml_hs_files
+        let location = ms_location old_summary
+            src_fn = expectJust "summariseModule" (ml_hs_file location)
+
+                -- check the modification time on the source file, and
+                -- return the cached summary if it hasn't changed.  If the
+                -- file has disappeared, we need to call the Finder again.
+        case maybe_buf of
+           Just (_,t) -> check_timestamp old_summary location src_fn t
+           Nothing    -> do
+                m <- tryIO (getModificationUTCTime src_fn)
+                case m of
+                   Right t -> check_timestamp old_summary location src_fn t
+                   Left e | isDoesNotExistError e -> find_it
+                          | otherwise             -> ioError e
+
+  | otherwise  = find_it
+  where
+    dflags = hsc_dflags hsc_env
+
+    check_timestamp old_summary location src_fn src_timestamp
+        | ms_hs_date old_summary == src_timestamp &&
+          not (gopt Opt_ForceRecomp dflags) = do
+                -- update the object-file timestamp
+                obj_timestamp <-
+                    if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+                       || obj_allowed -- bug #1205
+                       then getObjTimestamp location is_boot
+                       else return Nothing
+                hi_timestamp <- maybeGetIfaceDate dflags location
+                hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
+                return (Just (Right old_summary{ ms_obj_date = obj_timestamp
+                                               , ms_iface_date = hi_timestamp
+                                               , ms_hie_date = hie_timestamp }))
+        | otherwise =
+                -- source changed: re-summarise.
+                new_summary location (ms_mod old_summary) src_fn src_timestamp
+
+    find_it = do
+        found <- findImportedModule hsc_env wanted_mod Nothing
+        case found of
+             Found location mod
+                | isJust (ml_hs_file location) ->
+                        -- Home package
+                         just_found location mod
+
+             _ -> return Nothing
+                        -- Not found
+                        -- (If it is TRULY not found at all, we'll
+                        -- error when we actually try to compile)
+
+    just_found location mod = do
+                -- Adjust location to point to the hs-boot source file,
+                -- hi file, object file, when is_boot says so
+        let location' | IsBoot <- is_boot = addBootSuffixLocn location
+                      | otherwise         = location
+            src_fn = expectJust "summarise2" (ml_hs_file location')
+
+                -- Check that it exists
+                -- It might have been deleted since the Finder last found it
+        maybe_t <- modificationTimeIfExists src_fn
+        case maybe_t of
+          Nothing -> return $ Just $ Left $ noHsFileErr dflags loc src_fn
+          Just t  -> new_summary location' mod src_fn t
+
+
+    new_summary location mod src_fn src_timestamp
+      = do
+        -- Preprocess the source file and get its imports
+        -- The dflags' contains the OPTIONS pragmas
+        (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
+        (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
+
+        -- NB: Despite the fact that is_boot is a top-level parameter, we
+        -- don't actually know coming into this function what the HscSource
+        -- of the module in question is.  This is because we may be processing
+        -- this module because another module in the graph imported it: in this
+        -- case, we know if it's a boot or not because of the {-# SOURCE #-}
+        -- annotation, but we don't know if it's a signature or a regular
+        -- module until we actually look it up on the filesystem.
+        let hsc_src = case is_boot of
+                IsBoot -> HsBootFile
+                _ | isHaskellSigFilename src_fn -> HsigFile
+                  | otherwise -> HsSrcFile
+
+        when (mod_name /= wanted_mod) $
+                throwOneError $ mkPlainErrMsg dflags' mod_loc $
+                              text "File name does not match module name:"
+                              $$ text "Saw:" <+> quotes (ppr mod_name)
+                              $$ text "Expected:" <+> quotes (ppr wanted_mod)
+
+        when (hsc_src == HsigFile && isNothing (lookup mod_name (thisUnitIdInsts dflags))) $
+            let suggested_instantiated_with =
+                    hcat (punctuate comma $
+                        [ ppr k <> text "=" <> ppr v
+                        | (k,v) <- ((mod_name, mkHoleModule mod_name)
+                                : thisUnitIdInsts dflags)
+                        ])
+            in throwOneError $ mkPlainErrMsg dflags' mod_loc $
+                text "Unexpected signature:" <+> quotes (ppr mod_name)
+                $$ if gopt Opt_BuildingCabalPackage dflags
+                    then parens (text "Try adding" <+> quotes (ppr mod_name)
+                            <+> text "to the"
+                            <+> quotes (text "signatures")
+                            <+> text "field in your Cabal file.")
+                    else parens (text "Try passing -instantiated-with=\"" <>
+                                 suggested_instantiated_with <> text "\"" $$
+                                text "replacing <" <> ppr mod_name <> text "> as necessary.")
+
+                -- Find the object timestamp, and return the summary
+        obj_timestamp <-
+           if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+              || obj_allowed -- bug #1205
+              then getObjTimestamp location is_boot
+              else return Nothing
+
+        hi_timestamp <- maybeGetIfaceDate dflags location
+        hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
+
+        extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name
+        required_by_imports <- implicitRequirements hsc_env the_imps
+
+        return (Just (Right (ModSummary { ms_mod       = mod,
+                              ms_hsc_src   = hsc_src,
+                              ms_location  = location,
+                              ms_hspp_file = hspp_fn,
+                              ms_hspp_opts = dflags',
+                              ms_hspp_buf  = Just buf,
+                              ms_parsed_mod = Nothing,
+                              ms_srcimps      = srcimps,
+                              ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,
+                              ms_hs_date   = src_timestamp,
+                              ms_iface_date = hi_timestamp,
+                              ms_hie_date = hie_timestamp,
+                              ms_obj_date  = obj_timestamp })))
+
+
+getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime)
+getObjTimestamp location is_boot
+  = if is_boot == IsBoot then return Nothing
+                         else modificationTimeIfExists (ml_obj_file location)
+
+
+preprocessFile :: HscEnv
+               -> FilePath
+               -> Maybe Phase -- ^ Starting phase
+               -> Maybe (StringBuffer,UTCTime)
+               -> IO (DynFlags, FilePath, StringBuffer)
+preprocessFile hsc_env src_fn mb_phase Nothing
+  = do
+        (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
+        buf <- hGetStringBuffer hspp_fn
+        return (dflags', hspp_fn, buf)
+
+preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
+  = do
+        let dflags = hsc_dflags hsc_env
+        let local_opts = getOptions dflags buf src_fn
+
+        (dflags', leftovers, warns)
+            <- parseDynamicFilePragma dflags local_opts
+        checkProcessArgsResult dflags leftovers
+        handleFlagWarnings dflags' warns
+
+        let needs_preprocessing
+                | Just (Unlit _) <- mb_phase    = True
+                | Nothing <- mb_phase, Unlit _ <- startPhase src_fn  = True
+                  -- note: local_opts is only required if there's no Unlit phase
+                | xopt LangExt.Cpp dflags'      = True
+                | gopt Opt_Pp  dflags'          = True
+                | otherwise                     = False
+
+        when needs_preprocessing $
+           throwGhcExceptionIO (ProgramError "buffer needs preprocesing; interactive check disabled")
+
+        return (dflags', src_fn, buf)
+
+
+-----------------------------------------------------------------------------
+--                      Error messages
+-----------------------------------------------------------------------------
+
+noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg
+-- ToDo: we don't have a proper line number for this error
+noModError dflags loc wanted_mod err
+  = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err
+
+noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg
+noHsFileErr dflags loc path
+  = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path
+
+moduleNotFoundErr :: DynFlags -> ModuleName -> ErrMsg
+moduleNotFoundErr dflags mod
+  = mkPlainErrMsg dflags noSrcSpan $
+        text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"
+
+multiRootsErr :: DynFlags -> [ModSummary] -> IO ()
+multiRootsErr _      [] = panic "multiRootsErr"
+multiRootsErr dflags summs@(summ1:_)
+  = throwOneError $ mkPlainErrMsg dflags noSrcSpan $
+        text "module" <+> quotes (ppr mod) <+>
+        text "is defined in multiple files:" <+>
+        sep (map text files)
+  where
+    mod = ms_mod summ1
+    files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
+
+cyclicModuleErr :: [ModSummary] -> SDoc
+-- From a strongly connected component we find
+-- a single cycle to report
+cyclicModuleErr mss
+  = ASSERT( not (null mss) )
+    case findCycle graph of
+       Nothing   -> text "Unexpected non-cycle" <+> ppr mss
+       Just path -> vcat [ text "Module imports form a cycle:"
+                         , nest 2 (show_path path) ]
+  where
+    graph :: [Node NodeKey ModSummary]
+    graph = [ DigraphNode ms (msKey ms) (get_deps ms) | ms <- mss]
+
+    get_deps :: ModSummary -> [NodeKey]
+    get_deps ms = ([ (unLoc m, IsBoot)  | m <- ms_home_srcimps ms ] ++
+                   [ (unLoc m, NotBoot) | m <- ms_home_imps    ms ])
+
+    show_path []         = panic "show_path"
+    show_path [m]        = text "module" <+> ppr_ms m
+                           <+> text "imports itself"
+    show_path (m1:m2:ms) = vcat ( nest 7 (text "module" <+> ppr_ms m1)
+                                : nest 6 (text "imports" <+> ppr_ms m2)
+                                : go ms )
+       where
+         go []     = [text "which imports" <+> ppr_ms m1]
+         go (m:ms) = (text "which imports" <+> ppr_ms m) : go ms
+
+
+    ppr_ms :: ModSummary -> SDoc
+    ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>
+                (parens (text (msHsFilePath ms)))
diff --git a/compiler/main/GhcPlugins.hs b/compiler/main/GhcPlugins.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/GhcPlugins.hs
@@ -0,0 +1,132 @@
+{-# OPTIONS_GHC -fno-warn-duplicate-exports -fno-warn-orphans #-}
+
+-- | This module is not used by GHC itself.  Rather, it exports all of
+-- the functions and types you are likely to need when writing a
+-- plugin for GHC. So authors of plugins can probably get away simply
+-- with saying "import GhcPlugins".
+--
+-- Particularly interesting modules for plugin writers include
+-- "CoreSyn" and "CoreMonad".
+module GhcPlugins(
+        module Plugins,
+        module RdrName, module OccName, module Name, module Var, module Id, module IdInfo,
+        module CoreMonad, module CoreSyn, module Literal, module DataCon,
+        module CoreUtils, module MkCore, module CoreFVs, module CoreSubst,
+        module Rules, module Annotations,
+        module DynFlags, module Packages,
+        module Module, module Type, module TyCon, module Coercion,
+        module TysWiredIn, module HscTypes, module BasicTypes,
+        module VarSet, module VarEnv, module NameSet, module NameEnv,
+        module UniqSet, module UniqFM, module FiniteMap,
+        module Util, module GHC.Serialized, module SrcLoc, module Outputable,
+        module UniqSupply, module Unique, module FastString,
+
+        -- * Getting 'Name's
+        thNameToGhcName
+    ) where
+
+-- Plugin stuff itself
+import Plugins
+
+-- Variable naming
+import RdrName
+import OccName  hiding  ( varName {- conflicts with Var.varName -} )
+import Name     hiding  ( varName {- reexport from OccName, conflicts with Var.varName -} )
+import Var
+import Id       hiding  ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} )
+import IdInfo
+
+-- Core
+import CoreMonad
+import CoreSyn
+import Literal
+import DataCon
+import CoreUtils
+import MkCore
+import CoreFVs
+import CoreSubst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst )
+       -- These names are also exported by Type
+
+-- Core "extras"
+import Rules
+import Annotations
+
+-- Pipeline-related stuff
+import DynFlags
+import Packages
+
+-- Important GHC types
+import Module
+import Type     hiding {- conflict with CoreSubst -}
+                ( substTy, extendTvSubst, extendTvSubstList, isInScope )
+import Coercion hiding {- conflict with CoreSubst -}
+                ( substCo )
+import TyCon
+import TysWiredIn
+import HscTypes
+import BasicTypes hiding ( Version {- conflicts with Packages.Version -} )
+
+-- Collections and maps
+import VarSet
+import VarEnv
+import NameSet
+import NameEnv
+import UniqSet
+import UniqFM
+-- Conflicts with UniqFM:
+--import LazyUniqFM
+import FiniteMap
+
+-- Common utilities
+import Util
+import GHC.Serialized
+import SrcLoc
+import Outputable
+import UniqSupply
+import Unique           ( Unique, Uniquable(..) )
+import FastString
+import Data.Maybe
+
+import IfaceEnv         ( lookupOrigIO )
+import GhcPrelude
+import MonadUtils       ( mapMaybeM )
+import Convert          ( thRdrNameGuesses )
+import TcEnv            ( lookupGlobal )
+
+import qualified Language.Haskell.TH as TH
+
+{- This instance is defined outside CoreMonad.hs so that
+   CoreMonad does not depend on TcEnv -}
+instance MonadThings CoreM where
+    lookupThing name = do { hsc_env <- getHscEnv
+                          ; liftIO $ lookupGlobal hsc_env name }
+
+{-
+************************************************************************
+*                                                                      *
+               Template Haskell interoperability
+*                                                                      *
+************************************************************************
+-}
+
+-- | Attempt to convert a Template Haskell name to one that GHC can
+-- understand. Original TH names such as those you get when you use
+-- the @'foo@ syntax will be translated to their equivalent GHC name
+-- exactly. Qualified or unqualified TH names will be dynamically bound
+-- to names in the module being compiled, if possible. Exact TH names
+-- will be bound to the name they represent, exactly.
+thNameToGhcName :: TH.Name -> CoreM (Maybe Name)
+thNameToGhcName th_name
+  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
+          -- Pick the first that works
+          -- E.g. reify (mkName "A") will pick the class A in preference
+          -- to the data constructor A
+        ; return (listToMaybe names) }
+  where
+    lookup rdr_name
+      | Just n <- isExact_maybe rdr_name   -- This happens in derived code
+      = return $ if isExternalName n then Just n else Nothing
+      | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+      = do { hsc_env <- getHscEnv
+           ; Just <$> liftIO (lookupOrigIO hsc_env rdr_mod rdr_occ) }
+      | otherwise = return Nothing
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/HscMain.hs
@@ -0,0 +1,1876 @@
+{-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-}
+{-# OPTIONS_GHC -fprof-auto-top #-}
+
+-------------------------------------------------------------------------------
+--
+-- | Main API for compiling plain Haskell source code.
+--
+-- This module implements compilation of a Haskell source. It is
+-- /not/ concerned with preprocessing of source files; this is handled
+-- in "DriverPipeline".
+--
+-- There are various entry points depending on what mode we're in:
+-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and
+-- "interactive" mode (GHCi). There are also entry points for
+-- individual passes: parsing, typechecking/renaming, desugaring, and
+-- simplification.
+--
+-- All the functions here take an 'HscEnv' as a parameter, but none of
+-- them return a new one: 'HscEnv' is treated as an immutable value
+-- from here on in (although it has mutable components, for the
+-- caches).
+--
+-- We use the Hsc monad to deal with warning messages consistently:
+-- specifically, while executing within an Hsc monad, warnings are
+-- collected. When a Hsc monad returns to an IO monad, the
+-- warnings are printed, or compilation aborts if the @-Werror@
+-- flag is enabled.
+--
+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
+--
+-------------------------------------------------------------------------------
+
+module HscMain
+    (
+    -- * Making an HscEnv
+      newHscEnv
+
+    -- * Compiling complete source files
+    , Messager, batchMsg
+    , HscStatus (..)
+    , hscIncrementalCompile
+    , hscCompileCmmFile
+
+    , hscGenHardCode
+    , hscInteractive
+
+    -- * Running passes separately
+    , hscParse
+    , hscTypecheckRename
+    , hscDesugar
+    , makeSimpleDetails
+    , hscSimplify -- ToDo, shouldn't really export this
+
+    -- * Safe Haskell
+    , hscCheckSafe
+    , hscGetSafe
+
+    -- * Support for interactive evaluation
+    , hscParseIdentifier
+    , hscTcRcLookupName
+    , hscTcRnGetInfo
+    , hscIsGHCiMonad
+    , hscGetModuleInterface
+    , hscRnImportDecls
+    , hscTcRnLookupRdrName
+    , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt
+    , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls
+    , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
+    , hscParseExpr
+    , hscCompileCoreExpr
+    -- * Low-level exports for hooks
+    , hscCompileCoreExpr'
+      -- We want to make sure that we export enough to be able to redefine
+      -- hscFileFrontEnd in client code
+    , hscParse', hscSimplify', hscDesugar', tcRnModule'
+    , getHscEnv
+    , hscSimpleIface', hscNormalIface'
+    , oneShotMsg
+    , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats
+    , ioMsgMaybe
+    , showModuleIndex
+    , hscAddSptEntries
+    ) where
+
+import GhcPrelude
+
+import Data.Data hiding (Fixity, TyCon)
+import Data.Maybe       ( fromJust )
+import Id
+import GHCi             ( addSptEntry )
+import GHCi.RemoteTypes ( ForeignHValue )
+import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
+import Linker
+import CoreTidy         ( tidyExpr )
+import Type             ( Type )
+import {- Kind parts of -} Type         ( Kind )
+import CoreLint         ( lintInteractiveExpr )
+import VarEnv           ( emptyTidyEnv )
+import Panic
+import ConLike
+import Control.Concurrent
+
+import Module
+import Packages
+import RdrName
+import HsSyn
+import HsDumpAst
+import CoreSyn
+import StringBuffer
+import Parser
+import Lexer
+import SrcLoc
+import TcRnDriver
+import TcIface          ( typecheckIface )
+import TcRnMonad
+import NameCache        ( initNameCache )
+import LoadIface        ( ifaceStats, initExternalPackageState )
+import PrelInfo
+import MkIface
+import Desugar
+import SimplCore
+import TidyPgm
+import CorePrep
+import CoreToStg        ( coreToStg )
+import qualified StgCmm ( codeGen )
+import StgSyn
+import StgFVs           ( annTopBindingsFreeVars )
+import CostCentre
+import ProfInit
+import TyCon
+import Name
+import SimplStg         ( stg2stg )
+import Cmm
+import CmmParse         ( parseCmmFile )
+import CmmBuildInfoTables
+import CmmPipeline
+import CmmInfo
+import CodeOutput
+import InstEnv
+import FamInstEnv
+import Fingerprint      ( Fingerprint )
+import Hooks
+import TcEnv
+import PrelNames
+import Plugins
+import DynamicLoading   ( initializePlugins )
+
+import DynFlags
+import ErrUtils
+import Platform ( platformOS, osSubsectionsViaSymbols )
+
+import Outputable
+import NameEnv
+import HscStats         ( ppSourceStats )
+import HscTypes
+import FastString
+import UniqSupply
+import Bag
+import Exception
+import qualified Stream
+import Stream (Stream)
+
+import Util
+
+import Data.List
+import Control.Monad
+import Data.IORef
+import System.FilePath as FilePath
+import System.Directory
+import System.IO (fixIO)
+import qualified Data.Map as M
+import qualified Data.Set as S
+import Data.Set (Set)
+
+import HieAst           ( mkHieFile )
+import HieTypes         ( getAsts, hie_asts )
+import HieBin           ( readHieFile, writeHieFile )
+import HieDebug         ( diffFile, validateScopes )
+
+#include "HsVersions.h"
+
+
+{- **********************************************************************
+%*                                                                      *
+                Initialisation
+%*                                                                      *
+%********************************************************************* -}
+
+newHscEnv :: DynFlags -> IO HscEnv
+newHscEnv dflags = do
+    eps_var <- newIORef initExternalPackageState
+    us      <- mkSplitUniqSupply 'r'
+    nc_var  <- newIORef (initNameCache us knownKeyNames)
+    fc_var  <- newIORef emptyInstalledModuleEnv
+    iserv_mvar <- newMVar Nothing
+    return HscEnv {  hsc_dflags       = dflags
+                  ,  hsc_targets      = []
+                  ,  hsc_mod_graph    = emptyMG
+                  ,  hsc_IC           = emptyInteractiveContext dflags
+                  ,  hsc_HPT          = emptyHomePackageTable
+                  ,  hsc_EPS          = eps_var
+                  ,  hsc_NC           = nc_var
+                  ,  hsc_FC           = fc_var
+                  ,  hsc_type_env_var = Nothing
+                  , hsc_iserv        = iserv_mvar
+                  }
+
+-- -----------------------------------------------------------------------------
+
+getWarnings :: Hsc WarningMessages
+getWarnings = Hsc $ \_ w -> return (w, w)
+
+clearWarnings :: Hsc ()
+clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)
+
+logWarnings :: WarningMessages -> Hsc ()
+logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
+
+getHscEnv :: Hsc HscEnv
+getHscEnv = Hsc $ \e w -> return (e, w)
+
+handleWarnings :: Hsc ()
+handleWarnings = do
+    dflags <- getDynFlags
+    w <- getWarnings
+    liftIO $ printOrThrowWarnings dflags w
+    clearWarnings
+
+-- | log warning in the monad, and if there are errors then
+-- throw a SourceError exception.
+logWarningsReportErrors :: Messages -> Hsc ()
+logWarningsReportErrors (warns,errs) = do
+    logWarnings warns
+    when (not $ isEmptyBag errs) $ throwErrors errs
+
+-- | Throw some errors.
+throwErrors :: ErrorMessages -> Hsc a
+throwErrors = liftIO . throwIO . mkSrcErr
+
+-- | Deal with errors and warnings returned by a compilation step
+--
+-- In order to reduce dependencies to other parts of the compiler, functions
+-- outside the "main" parts of GHC return warnings and errors as a parameter
+-- and signal success via by wrapping the result in a 'Maybe' type. This
+-- function logs the returned warnings and propagates errors as exceptions
+-- (of type 'SourceError').
+--
+-- This function assumes the following invariants:
+--
+--  1. If the second result indicates success (is of the form 'Just x'),
+--     there must be no error messages in the first result.
+--
+--  2. If there are no error messages, but the second result indicates failure
+--     there should be warnings in the first result. That is, if the action
+--     failed, it must have been due to the warnings (i.e., @-Werror@).
+ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
+ioMsgMaybe ioA = do
+    ((warns,errs), mb_r) <- liftIO ioA
+    logWarnings warns
+    case mb_r of
+        Nothing -> throwErrors errs
+        Just r  -> ASSERT( isEmptyBag errs ) return r
+
+-- | like ioMsgMaybe, except that we ignore error messages and return
+-- 'Nothing' instead.
+ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
+ioMsgMaybe' ioA = do
+    ((warns,_errs), mb_r) <- liftIO $ ioA
+    logWarnings warns
+    return mb_r
+
+-- -----------------------------------------------------------------------------
+-- | Lookup things in the compiler's environment
+
+hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]
+hscTcRnLookupRdrName hsc_env0 rdr_name
+  = runInteractiveHsc hsc_env0 $
+    do { hsc_env <- getHscEnv
+       ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }
+
+hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
+hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
+  hsc_env <- getHscEnv
+  ioMsgMaybe' $ tcRnLookupName hsc_env name
+      -- ignore errors: the only error we're likely to get is
+      -- "name not found", and the Maybe in the return type
+      -- is used to indicate that.
+
+hscTcRnGetInfo :: HscEnv -> Name
+               -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
+hscTcRnGetInfo hsc_env0 name
+  = runInteractiveHsc hsc_env0 $
+    do { hsc_env <- getHscEnv
+       ; ioMsgMaybe' $ tcRnGetInfo hsc_env name }
+
+hscIsGHCiMonad :: HscEnv -> String -> IO Name
+hscIsGHCiMonad hsc_env name
+  = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name
+
+hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
+hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
+  hsc_env <- getHscEnv
+  ioMsgMaybe $ getModuleInterface hsc_env mod
+
+-- -----------------------------------------------------------------------------
+-- | Rename some import declarations
+hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
+hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do
+  hsc_env <- getHscEnv
+  ioMsgMaybe $ tcRnImportDecls hsc_env import_decls
+
+-- -----------------------------------------------------------------------------
+-- | parse a file, returning the abstract syntax
+
+hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
+hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
+
+-- internal version, that doesn't fail due to -Werror
+hscParse' :: ModSummary -> Hsc HsParsedModule
+hscParse' mod_summary
+ | Just r <- ms_parsed_mod mod_summary = return r
+ | otherwise = {-# SCC "Parser" #-}
+    withTiming getDynFlags
+               (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
+               (const ()) $ do
+    dflags <- getDynFlags
+    let src_filename  = ms_hspp_file mod_summary
+        maybe_src_buf = ms_hspp_buf  mod_summary
+
+    --------------------------  Parser  ----------------
+    -- sometimes we already have the buffer in memory, perhaps
+    -- because we needed to parse the imports out of it, or get the
+    -- module name.
+    buf <- case maybe_src_buf of
+               Just b  -> return b
+               Nothing -> liftIO $ hGetStringBuffer src_filename
+
+    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
+    let parseMod | HsigFile == ms_hsc_src mod_summary
+                 = parseSignature
+                 | otherwise = parseModule
+
+    case unP parseMod (mkPState dflags buf loc) of
+        PFailed warnFn span err -> do
+            logWarningsReportErrors (warnFn dflags)
+            handleWarnings
+            liftIO $ throwOneError (mkPlainErrMsg dflags span err)
+
+        POk pst rdr_module -> do
+            logWarningsReportErrors (getMessages pst dflags)
+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
+                                   ppr rdr_module
+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
+                                   showAstData NoBlankSrcSpan rdr_module
+            liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
+                                   ppSourceStats False rdr_module
+
+            -- To get the list of extra source files, we take the list
+            -- that the parser gave us,
+            --   - eliminate files beginning with '<'.  gcc likes to use
+            --     pseudo-filenames like "<built-in>" and "<command-line>"
+            --   - normalise them (eliminate differences between ./f and f)
+            --   - filter out the preprocessed source file
+            --   - filter out anything beginning with tmpdir
+            --   - remove duplicates
+            --   - filter out the .hs/.lhs source filename if we have one
+            --
+            let n_hspp  = FilePath.normalise src_filename
+                srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))
+                            $ filter (not . (== n_hspp))
+                            $ map FilePath.normalise
+                            $ filter (not . isPrefixOf "<")
+                            $ map unpackFS
+                            $ srcfiles pst
+                srcs1 = case ml_hs_file (ms_location mod_summary) of
+                          Just f  -> filter (/= FilePath.normalise f) srcs0
+                          Nothing -> srcs0
+
+            -- sometimes we see source files from earlier
+            -- preprocessing stages that cannot be found, so just
+            -- filter them out:
+            srcs2 <- liftIO $ filterM doesFileExist srcs1
+
+            let res = HsParsedModule {
+                      hpm_module    = rdr_module,
+                      hpm_src_files = srcs2,
+                      hpm_annotations
+                              = (M.fromListWith (++) $ annotations pst,
+                                 M.fromList $ ((noSrcSpan,comment_q pst)
+                                                 :(annotations_comments pst)))
+                   }
+
+            -- apply parse transformation of plugins
+            let applyPluginAction p opts
+                  = parsedResultAction p opts mod_summary
+            withPlugins dflags applyPluginAction res
+
+
+-- -----------------------------------------------------------------------------
+-- | If the renamed source has been kept, extract it. Dump it if requested.
+extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
+extract_renamed_stuff mod_summary tc_result = do
+    let rn_info = getRenamedStuff tc_result
+
+    dflags <- getDynFlags
+    liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $
+                           showAstData NoBlankSrcSpan rn_info
+
+    -- Create HIE files
+    when (gopt Opt_WriteHie dflags) $ do
+        -- I assume this fromJust is safe because `-fwrite-hie-file`
+        -- enables the option which keeps the renamed source.
+        hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
+        let out_file = ml_hie_file $ ms_location mod_summary
+        liftIO $ writeHieFile out_file hieFile
+
+        -- Validate HIE files
+        when (gopt Opt_ValidateHie dflags) $ do
+            hs_env <- Hsc $ \e w -> return (e, w)
+            liftIO $ do
+              -- Validate Scopes
+              case validateScopes $ getAsts $ hie_asts hieFile of
+                  [] -> putMsg dflags $ text "Got valid scopes"
+                  xs -> do
+                    putMsg dflags $ text "Got invalid scopes"
+                    mapM_ (putMsg dflags) xs
+              -- Roundtrip testing
+              nc <- readIORef $ hsc_NC hs_env
+              (file', _) <- readHieFile nc out_file
+              case diffFile hieFile file' of
+                [] ->
+                  putMsg dflags $ text "Got no roundtrip errors"
+                xs -> do
+                  putMsg dflags $ text "Got roundtrip errors"
+                  mapM_ (putMsg dflags) xs
+    return rn_info
+
+
+-- -----------------------------------------------------------------------------
+-- | Rename and typecheck a module, additionally returning the renamed syntax
+hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
+                   -> IO (TcGblEnv, RenamedStuff)
+hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
+    tc_result <- hsc_typecheck True mod_summary (Just rdr_module)
+    rn_info <- extract_renamed_stuff mod_summary tc_result
+    return (tc_result, rn_info)
+
+-- | Rename and typecheck a module, but don't return the renamed syntax
+hscTypecheck :: Bool -- ^ Keep renamed source?
+             -> ModSummary -> Maybe HsParsedModule
+             -> Hsc TcGblEnv
+hscTypecheck keep_rn mod_summary mb_rdr_module = do
+    tc_result <- hsc_typecheck keep_rn mod_summary mb_rdr_module
+    _ <- extract_renamed_stuff mod_summary tc_result
+    return tc_result
+
+hsc_typecheck :: Bool -- ^ Keep renamed source?
+              -> ModSummary -> Maybe HsParsedModule
+              -> Hsc TcGblEnv
+hsc_typecheck keep_rn mod_summary mb_rdr_module = do
+    hsc_env <- getHscEnv
+    let hsc_src = ms_hsc_src mod_summary
+        dflags = hsc_dflags hsc_env
+        outer_mod = ms_mod mod_summary
+        mod_name = moduleName outer_mod
+        outer_mod' = mkModule (thisPackage dflags) mod_name
+        inner_mod = canonicalizeHomeModule dflags mod_name
+        src_filename  = ms_hspp_file mod_summary
+        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
+        keep_rn' = gopt Opt_WriteHie dflags || keep_rn
+    MASSERT( moduleUnitId outer_mod == thisPackage dflags )
+    if hsc_src == HsigFile && not (isHoleModule inner_mod)
+        then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
+        else
+         do hpm <- case mb_rdr_module of
+                    Just hpm -> return hpm
+                    Nothing -> hscParse' mod_summary
+            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm
+            if hsc_src == HsigFile
+                then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing
+                        ioMsgMaybe $
+                            tcRnMergeSignatures hsc_env hpm tc_result0 iface
+                else return tc_result0
+
+-- wrapper around tcRnModule to handle safe haskell extras
+tcRnModule' :: ModSummary -> Bool -> HsParsedModule
+            -> Hsc TcGblEnv
+tcRnModule' sum save_rn_syntax mod = do
+    hsc_env <- getHscEnv
+    dflags   <- getDynFlags
+
+    tcg_res <- {-# SCC "Typecheck-Rename" #-}
+               ioMsgMaybe $
+                   tcRnModule hsc_env sum
+                     save_rn_syntax mod
+
+    -- See Note [Safe Haskell Overlapping Instances Implementation]
+    -- although this is used for more than just that failure case.
+    (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)
+    let allSafeOK = safeInferred dflags && tcSafeOK
+
+    -- end of the safe haskell line, how to respond to user?
+    res <- if not (safeHaskellOn dflags)
+                || (safeInferOn dflags && not allSafeOK)
+             -- if safe Haskell off or safe infer failed, mark unsafe
+             then markUnsafeInfer tcg_res whyUnsafe
+
+             -- module (could be) safe, throw warning if needed
+             else do
+                 tcg_res' <- hscCheckSafeImports tcg_res
+                 safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
+                 when safe $ do
+                   case wopt Opt_WarnSafe dflags of
+                     True -> (logWarnings $ unitBag $
+                              makeIntoWarning (Reason Opt_WarnSafe) $
+                              mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $
+                              errSafe tcg_res')
+                     False | safeHaskell dflags == Sf_Trustworthy &&
+                             wopt Opt_WarnTrustworthySafe dflags ->
+                             (logWarnings $ unitBag $
+                              makeIntoWarning (Reason Opt_WarnTrustworthySafe) $
+                              mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $
+                              errTwthySafe tcg_res')
+                     False -> return ()
+                 return tcg_res'
+
+    -- apply plugins to the type checking result
+
+
+    return res
+  where
+    pprMod t  = ppr $ moduleName $ tcg_mod t
+    errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"
+    errTwthySafe t = quotes (pprMod t)
+      <+> text "is marked as Trustworthy but has been inferred as safe!"
+
+-- | Convert a typechecked module to Core
+hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
+hscDesugar hsc_env mod_summary tc_result =
+    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
+
+hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
+hscDesugar' mod_location tc_result = do
+    hsc_env <- getHscEnv
+    r <- ioMsgMaybe $
+      {-# SCC "deSugar" #-}
+      deSugar hsc_env mod_location tc_result
+
+    -- always check -Werror after desugaring, this is the last opportunity for
+    -- warnings to arise before the backend.
+    handleWarnings
+    return r
+
+-- | Make a 'ModDetails' from the results of typechecking. Used when
+-- typechecking only, as opposed to full compilation.
+makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
+makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
+
+
+{- **********************************************************************
+%*                                                                      *
+                The main compiler pipeline
+%*                                                                      *
+%********************************************************************* -}
+
+{-
+                   --------------------------------
+                        The compilation proper
+                   --------------------------------
+
+It's the task of the compilation proper to compile Haskell, hs-boot and core
+files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all
+(the module is still parsed and type-checked. This feature is mostly used by
+IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',
+'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'
+mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
+targets byte-code.
+
+The modes are kept separate because of their different types and meanings:
+
+ * In 'one-shot' mode, we're only compiling a single file and can therefore
+ discard the new ModIface and ModDetails. This is also the reason it only
+ targets hard-code; compiling to byte-code or nothing doesn't make sense when
+ we discard the result.
+
+ * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
+ and ModDetails. 'Batch' mode doesn't target byte-code since that require us to
+ return the newly compiled byte-code.
+
+ * 'Nothing' mode has exactly the same type as 'batch' mode but they're still
+ kept separate. This is because compiling to nothing is fairly special: We
+ don't output any interface files, we don't run the simplifier and we don't
+ generate any code.
+
+ * 'Interactive' mode is similar to 'batch' mode except that we return the
+ compiled byte-code together with the ModIface and ModDetails.
+
+Trying to compile a hs-boot file to byte-code will result in a run-time error.
+This is the only thing that isn't caught by the type-system.
+-}
+
+
+type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()
+
+-- | This function runs GHC's frontend with recompilation
+-- avoidance. Specifically, it checks if recompilation is needed,
+-- and if it is, it parses and typechecks the input module.
+-- It does not write out the results of typechecking (See
+-- compileOne and hscIncrementalCompile).
+hscIncrementalFrontend :: Bool -- always do basic recompilation check?
+                       -> Maybe TcGblEnv
+                       -> Maybe Messager
+                       -> ModSummary
+                       -> SourceModified
+                       -> Maybe ModIface  -- Old interface, if available
+                       -> (Int,Int)       -- (i,n) = module i of n (for msgs)
+                       -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
+
+hscIncrementalFrontend
+  always_do_basic_recompilation_check m_tc_result
+  mHscMessage mod_summary source_modified mb_old_iface mod_index
+    = do
+    hsc_env <- getHscEnv
+
+    let msg what = case mHscMessage of
+                   Just hscMessage -> hscMessage hsc_env mod_index what mod_summary
+                   Nothing -> return ()
+
+        skip iface = do
+            liftIO $ msg UpToDate
+            return $ Left iface
+
+        compile mb_old_hash reason = do
+            liftIO $ msg reason
+            result <- genericHscFrontend mod_summary
+            return $ Right (result, mb_old_hash)
+
+        stable = case source_modified of
+                     SourceUnmodifiedAndStable -> True
+                     _                         -> False
+
+    case m_tc_result of
+         Just tc_result
+          | not always_do_basic_recompilation_check ->
+             return $ Right (FrontendTypecheck tc_result, Nothing)
+         _ -> do
+            (recomp_reqd, mb_checked_iface)
+                <- {-# SCC "checkOldIface" #-}
+                   liftIO $ checkOldIface hsc_env mod_summary
+                                source_modified mb_old_iface
+            -- save the interface that comes back from checkOldIface.
+            -- In one-shot mode we don't have the old iface until this
+            -- point, when checkOldIface reads it from the disk.
+            let mb_old_hash = fmap mi_iface_hash mb_checked_iface
+
+            case mb_checked_iface of
+                Just iface | not (recompileRequired recomp_reqd) ->
+                    -- If the module used TH splices when it was last
+                    -- compiled, then the recompilation check is not
+                    -- accurate enough (#481) and we must ignore
+                    -- it.  However, if the module is stable (none of
+                    -- the modules it depends on, directly or
+                    -- indirectly, changed), then we *can* skip
+                    -- recompilation. This is why the SourceModified
+                    -- type contains SourceUnmodifiedAndStable, and
+                    -- it's pretty important: otherwise ghc --make
+                    -- would always recompile TH modules, even if
+                    -- nothing at all has changed. Stability is just
+                    -- the same check that make is doing for us in
+                    -- one-shot mode.
+                    case m_tc_result of
+                    Nothing
+                     | mi_used_th iface && not stable ->
+                        compile mb_old_hash (RecompBecause "TH")
+                    _ ->
+                        skip iface
+                _ ->
+                    case m_tc_result of
+                    Nothing -> compile mb_old_hash recomp_reqd
+                    Just tc_result ->
+                        return $ Right (FrontendTypecheck tc_result, mb_old_hash)
+
+genericHscFrontend :: ModSummary -> Hsc FrontendResult
+genericHscFrontend mod_summary =
+  getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary)
+
+genericHscFrontend' :: ModSummary -> Hsc FrontendResult
+genericHscFrontend' mod_summary
+    = FrontendTypecheck `fmap` hscFileFrontEnd mod_summary
+
+--------------------------------------------------------------
+-- Compilers
+--------------------------------------------------------------
+
+-- Compile Haskell/boot in OneShot mode.
+hscIncrementalCompile :: Bool
+                      -> Maybe TcGblEnv
+                      -> Maybe Messager
+                      -> HscEnv
+                      -> ModSummary
+                      -> SourceModified
+                      -> Maybe ModIface
+                      -> (Int,Int)
+                      -- HomeModInfo does not contain linkable, since we haven't
+                      -- code-genned yet
+                      -> IO (HscStatus, HomeModInfo)
+hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
+    mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index
+  = do
+    dflags <- initializePlugins hsc_env' (hsc_dflags hsc_env')
+    let hsc_env'' = hsc_env' { hsc_dflags = dflags }
+
+    -- One-shot mode needs a knot-tying mutable variable for interface
+    -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var.
+    -- See also Note [hsc_type_env_var hack]
+    type_env_var <- newIORef emptyNameEnv
+    let mod = ms_mod mod_summary
+        hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env''))
+                = hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) }
+                | otherwise
+                = hsc_env''
+
+    -- NB: enter Hsc monad here so that we don't bail out early with
+    -- -Werror on typechecker warnings; we also want to run the desugarer
+    -- to get those warnings too. (But we'll always exit at that point
+    -- because the desugarer runs ioMsgMaybe.)
+    runHsc hsc_env $ do
+    e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage
+            mod_summary source_modified mb_old_iface mod_index
+    case e of
+        -- We didn't need to do any typechecking; the old interface
+        -- file on disk was good enough.
+        Left iface -> do
+            -- Knot tying!  See Note [Knot-tying typecheckIface]
+            hmi <- liftIO . fixIO $ \hmi' -> do
+                let hsc_env' =
+                        hsc_env {
+                            hsc_HPT = addToHpt (hsc_HPT hsc_env)
+                                        (ms_mod_name mod_summary) hmi'
+                        }
+                -- NB: This result is actually not that useful
+                -- in one-shot mode, since we're not going to do
+                -- any further typechecking.  It's much more useful
+                -- in make mode, since this HMI will go into the HPT.
+                details <- genModDetails hsc_env' iface
+                return HomeModInfo{
+                    hm_details = details,
+                    hm_iface = iface,
+                    hm_linkable = Nothing }
+            return (HscUpToDate, hmi)
+        -- We finished type checking.  (mb_old_hash is the hash of
+        -- the interface that existed on disk; it's possible we had
+        -- to retypecheck but the resulting interface is exactly
+        -- the same.)
+        Right (FrontendTypecheck tc_result, mb_old_hash) ->
+            finish mod_summary tc_result mb_old_hash
+
+-- Runs the post-typechecking frontend (desugar and simplify),
+-- and then generates and writes out the final interface. We want
+-- to write the interface AFTER simplification so we can get
+-- as up-to-date and good unfoldings and other info as possible
+-- in the interface file.
+finish :: ModSummary
+       -> TcGblEnv
+       -> Maybe Fingerprint
+       -> Hsc (HscStatus, HomeModInfo)
+finish summary tc_result mb_old_hash = do
+  hsc_env <- getHscEnv
+  let dflags = hsc_dflags hsc_env
+      target = hscTarget dflags
+      hsc_src = ms_hsc_src summary
+      should_desugar =
+        ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile
+      mk_simple_iface = do
+        let hsc_status =
+              case (target, hsc_src) of
+                (HscNothing, _) -> HscNotGeneratingCode
+                (_, HsBootFile) -> HscUpdateBoot
+                (_, HsigFile) -> HscUpdateSig
+                _ -> panic "finish"
+        (iface, no_change, details) <- liftIO $
+          hscSimpleIface hsc_env tc_result mb_old_hash
+        return (iface, no_change, details, hsc_status)
+  (iface, no_change, details, hsc_status) <-
+    -- we usually desugar even when we are not generating code, otherwise
+    -- we would miss errors thrown by the desugaring (see #10600). The only
+    -- exceptions are when the Module is Ghc.Prim or when
+    -- it is not a HsSrcFile Module.
+    if should_desugar
+      then do
+        desugared_guts0 <- hscDesugar' (ms_location summary) tc_result
+        if target == HscNothing
+          -- We are not generating code, so we can skip simplification
+          -- and generate a simple interface.
+          then mk_simple_iface
+          else do
+            plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
+            desugared_guts <- hscSimplify' plugins desugared_guts0
+            (iface, no_change, details, cgguts) <-
+              liftIO $ hscNormalIface hsc_env desugared_guts mb_old_hash
+            return (iface, no_change, details, HscRecomp cgguts summary)
+      else mk_simple_iface
+  liftIO $ hscMaybeWriteIface dflags iface no_change summary
+  return
+    ( hsc_status
+    , HomeModInfo
+      {hm_details = details, hm_iface = iface, hm_linkable = Nothing})
+
+hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
+hscMaybeWriteIface dflags iface no_change summary =
+    let force_write_interface = gopt Opt_WriteInterface dflags
+        write_interface = case hscTarget dflags of
+                            HscNothing      -> False
+                            HscInterpreted  -> False
+                            _               -> True
+    in when (write_interface || force_write_interface) $
+            hscWriteIface dflags iface no_change summary
+
+--------------------------------------------------------------
+-- NoRecomp handlers
+--------------------------------------------------------------
+
+-- NB: this must be knot-tied appropriately, see hscIncrementalCompile
+genModDetails :: HscEnv -> ModIface -> IO ModDetails
+genModDetails hsc_env old_iface
+  = do
+    new_details <- {-# SCC "tcRnIface" #-}
+                   initIfaceLoad hsc_env (typecheckIface old_iface)
+    dumpIfaceStats hsc_env
+    return new_details
+
+--------------------------------------------------------------
+-- Progress displayers.
+--------------------------------------------------------------
+
+oneShotMsg :: HscEnv -> RecompileRequired -> IO ()
+oneShotMsg hsc_env recomp =
+    case recomp of
+        UpToDate ->
+            compilationProgressMsg (hsc_dflags hsc_env) $
+                   "compilation IS NOT required"
+        _ ->
+            return ()
+
+batchMsg :: Messager
+batchMsg hsc_env mod_index recomp mod_summary =
+    case recomp of
+        MustCompile -> showMsg "Compiling " ""
+        UpToDate
+            | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping  " ""
+            | otherwise -> return ()
+        RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
+    where
+        dflags = hsc_dflags hsc_env
+        showMsg msg reason =
+            compilationProgressMsg dflags $
+            (showModuleIndex mod_index ++
+            msg ++ showModMsg dflags (hscTarget dflags)
+                              (recompileRequired recomp) mod_summary)
+                ++ reason
+
+--------------------------------------------------------------
+-- FrontEnds
+--------------------------------------------------------------
+
+-- | Given a 'ModSummary', parses and typechecks it, returning the
+-- 'TcGblEnv' resulting from type-checking.
+hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
+hscFileFrontEnd mod_summary = hscTypecheck False mod_summary Nothing
+
+--------------------------------------------------------------
+-- Safe Haskell
+--------------------------------------------------------------
+
+-- Note [Safe Haskell Trust Check]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Safe Haskell checks that an import is trusted according to the following
+-- rules for an import of module M that resides in Package P:
+--
+--   * If M is recorded as Safe and all its trust dependencies are OK
+--     then M is considered safe.
+--   * If M is recorded as Trustworthy and P is considered trusted and
+--     all M's trust dependencies are OK then M is considered safe.
+--
+-- By trust dependencies we mean that the check is transitive. So if
+-- a module M that is Safe relies on a module N that is trustworthy,
+-- importing module M will first check (according to the second case)
+-- that N is trusted before checking M is trusted.
+--
+-- This is a minimal description, so please refer to the user guide
+-- for more details. The user guide is also considered the authoritative
+-- source in this matter, not the comments or code.
+
+
+-- Note [Safe Haskell Inference]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Safe Haskell does Safe inference on modules that don't have any specific
+-- safe haskell mode flag. The basic approach to this is:
+--   * When deciding if we need to do a Safe language check, treat
+--     an unmarked module as having -XSafe mode specified.
+--   * For checks, don't throw errors but return them to the caller.
+--   * Caller checks if there are errors:
+--     * For modules explicitly marked -XSafe, we throw the errors.
+--     * For unmarked modules (inference mode), we drop the errors
+--       and mark the module as being Unsafe.
+--
+-- It used to be that we only did safe inference on modules that had no Safe
+-- Haskell flags, but now we perform safe inference on all modules as we want
+-- to allow users to set the `-Wsafe`, `-Wunsafe` and
+-- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a
+-- user can ensure their assumptions are correct and see reasons for why a
+-- module is safe or unsafe.
+--
+-- This is tricky as we must be careful when we should throw an error compared
+-- to just warnings. For checking safe imports we manage it as two steps. First
+-- we check any imports that are required to be safe, then we check all other
+-- imports to see if we can infer them to be safe.
+
+
+-- | Check that the safe imports of the module being compiled are valid.
+-- If not we either issue a compilation error if the module is explicitly
+-- using Safe Haskell, or mark the module as unsafe if we're in safe
+-- inference mode.
+hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
+hscCheckSafeImports tcg_env = do
+    dflags   <- getDynFlags
+    tcg_env' <- checkSafeImports tcg_env
+    checkRULES dflags tcg_env'
+
+  where
+    checkRULES dflags tcg_env' = do
+      case safeLanguageOn dflags of
+          True -> do
+              -- XSafe: we nuke user written RULES
+              logWarnings $ warns dflags (tcg_rules tcg_env')
+              return tcg_env' { tcg_rules = [] }
+          False
+                -- SafeInferred: user defined RULES, so not safe
+              | safeInferOn dflags && not (null $ tcg_rules tcg_env')
+              -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env')
+
+                -- Trustworthy OR SafeInferred: with no RULES
+              | otherwise
+              -> return tcg_env'
+
+    warns dflags rules = listToBag $ map (warnRules dflags) rules
+    warnRules dflags (L loc (HsRule { rd_name = n })) =
+        mkPlainWarnMsg dflags loc $
+            text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
+            text "User defined rules are disabled under Safe Haskell"
+    warnRules _ (L _ (XRuleDecl _)) = panic "hscCheckSafeImports"
+
+-- | Validate that safe imported modules are actually safe.  For modules in the
+-- HomePackage (the package the module we are compiling in resides) this just
+-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
+-- that reside in another package we also must check that the external package
+-- is trusted. See the Note [Safe Haskell Trust Check] above for more
+-- information.
+--
+-- The code for this is quite tricky as the whole algorithm is done in a few
+-- distinct phases in different parts of the code base. See
+-- RnNames.rnImportDecl for where package trust dependencies for a module are
+-- collected and unioned.  Specifically see the Note [RnNames . Tracking Trust
+-- Transitively] and the Note [RnNames . Trust Own Package].
+checkSafeImports :: TcGblEnv -> Hsc TcGblEnv
+checkSafeImports tcg_env
+    = do
+        dflags <- getDynFlags
+        imps <- mapM condense imports'
+        let (safeImps, regImps) = partition (\(_,_,s) -> s) imps
+
+        -- We want to use the warning state specifically for detecting if safe
+        -- inference has failed, so store and clear any existing warnings.
+        oldErrs <- getWarnings
+        clearWarnings
+
+        -- Check safe imports are correct
+        safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps
+        safeErrs <- getWarnings
+        clearWarnings
+
+        -- Check non-safe imports are correct if inferring safety
+        -- See the Note [Safe Haskell Inference]
+        (infErrs, infPkgs) <- case (safeInferOn dflags) of
+          False -> return (emptyBag, S.empty)
+          True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps
+                     infErrs <- getWarnings
+                     clearWarnings
+                     return (infErrs, infPkgs)
+
+        -- restore old errors
+        logWarnings oldErrs
+
+        case (isEmptyBag safeErrs) of
+          -- Failed safe check
+          False -> liftIO . throwIO . mkSrcErr $ safeErrs
+
+          -- Passed safe check
+          True -> do
+            let infPassed = isEmptyBag infErrs
+            tcg_env' <- case (not infPassed) of
+              True  -> markUnsafeInfer tcg_env infErrs
+              False -> return tcg_env
+            when (packageTrustOn dflags) $ checkPkgTrust pkgReqs
+            let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed
+            return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }
+
+  where
+    impInfo  = tcg_imports tcg_env     -- ImportAvails
+    imports  = imp_mods impInfo        -- ImportedMods
+    imports1 = moduleEnvToList imports -- (Module, [ImportedBy])
+    imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])
+    pkgReqs  = imp_trust_pkgs impInfo  -- [UnitId]
+
+    condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
+    condense (_, [])   = panic "HscMain.condense: Pattern match failure!"
+    condense (m, x:xs) = do imv <- foldlM cond' x xs
+                            return (m, imv_span imv, imv_is_safe imv)
+
+    -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
+    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
+    cond' v1 v2
+        | imv_is_safe v1 /= imv_is_safe v2
+        = do
+            dflags <- getDynFlags
+            throwErrors $ unitBag $ mkPlainErrMsg dflags (imv_span v1)
+              (text "Module" <+> ppr (imv_name v1) <+>
+              (text $ "is imported both as a safe and unsafe import!"))
+        | otherwise
+        = return v1
+
+    -- easier interface to work with
+    checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
+    checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l
+
+    -- what pkg's to add to our trust requirements
+    pkgTrustReqs :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId ->
+          Bool -> ImportAvails
+    pkgTrustReqs dflags req inf infPassed | safeInferOn dflags
+                                  && not (safeHaskellModeEnabled dflags) && infPassed
+                                   = emptyImportAvails {
+                                       imp_trust_pkgs = req `S.union` inf
+                                   }
+    pkgTrustReqs dflags _   _ _ | safeHaskell dflags == Sf_Unsafe
+                         = emptyImportAvails
+    pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }
+
+-- | Check that a module is safe to import.
+--
+-- We return True to indicate the import is safe and False otherwise
+-- although in the False case an exception may be thrown first.
+hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
+hscCheckSafe hsc_env m l = runHsc hsc_env $ do
+    dflags <- getDynFlags
+    pkgs <- snd `fmap` hscCheckSafe' m l
+    when (packageTrustOn dflags) $ checkPkgTrust pkgs
+    errs <- getWarnings
+    return $ isEmptyBag errs
+
+-- | Return if a module is trusted and the pkgs it depends on to be trusted.
+hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)
+hscGetSafe hsc_env m l = runHsc hsc_env $ do
+    (self, pkgs) <- hscCheckSafe' m l
+    good         <- isEmptyBag `fmap` getWarnings
+    clearWarnings -- don't want them printed...
+    let pkgs' | Just p <- self = S.insert p pkgs
+              | otherwise      = pkgs
+    return (good, pkgs')
+
+-- | Is a module trusted? If not, throw or log errors depending on the type.
+-- Return (regardless of trusted or not) if the trust type requires the modules
+-- own package be trusted and a list of other packages required to be trusted
+-- (these later ones haven't been checked) but the own package trust has been.
+hscCheckSafe' :: Module -> SrcSpan
+  -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
+hscCheckSafe' m l = do
+    dflags <- getDynFlags
+    (tw, pkgs) <- isModSafe m l
+    case tw of
+        False                     -> return (Nothing, pkgs)
+        True | isHomePkg dflags m -> return (Nothing, pkgs)
+             -- TODO: do we also have to check the trust of the instantiation?
+             -- Not necessary if that is reflected in dependencies
+             | otherwise   -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs)
+  where
+    isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)
+    isModSafe m l = do
+        dflags <- getDynFlags
+        iface <- lookup' m
+        case iface of
+            -- can't load iface to check trust!
+            Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l
+                         $ text "Can't load the interface file for" <+> ppr m
+                           <> text ", to check that it can be safely imported"
+
+            -- got iface, check trust
+            Just iface' ->
+                let trust = getSafeMode $ mi_trust iface'
+                    trust_own_pkg = mi_trust_pkg iface'
+                    -- check module is trusted
+                    safeM = trust `elem` [Sf_Safe, Sf_Trustworthy]
+                    -- check package is trusted
+                    safeP = packageTrusted dflags trust trust_own_pkg m
+                    -- pkg trust reqs
+                    pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'
+                    -- General errors we throw but Safe errors we log
+                    errs = case (safeM, safeP) of
+                        (True, True ) -> emptyBag
+                        (True, False) -> pkgTrustErr
+                        (False, _   ) -> modTrustErr
+                in do
+                    logWarnings errs
+                    return (trust == Sf_Trustworthy, pkgRs)
+
+                where
+                    pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
+                        sep [ ppr (moduleName m)
+                                <> text ": Can't be safely imported!"
+                            , text "The package (" <> ppr (moduleUnitId m)
+                                <> text ") the module resides in isn't trusted."
+                            ]
+                    modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
+                        sep [ ppr (moduleName m)
+                                <> text ": Can't be safely imported!"
+                            , text "The module itself isn't safe." ]
+
+    -- | Check the package a module resides in is trusted. Safe compiled
+    -- modules are trusted without requiring that their package is trusted. For
+    -- trustworthy modules, modules in the home package are trusted but
+    -- otherwise we check the package trust flag.
+    packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool
+    packageTrusted _ Sf_None      _ _ = False -- shouldn't hit these cases
+    packageTrusted _ Sf_Ignore    _ _ = False -- shouldn't hit these cases
+    packageTrusted _ Sf_Unsafe    _ _ = False -- prefer for completeness.
+    packageTrusted dflags _ _ _
+        | not (packageTrustOn dflags) = True
+    packageTrusted _ Sf_Safe  False _ = True
+    packageTrusted dflags _ _ m
+        | isHomePkg dflags m = True
+        | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m)
+
+    lookup' :: Module -> Hsc (Maybe ModIface)
+    lookup' m = do
+        dflags <- getDynFlags
+        hsc_env <- getHscEnv
+        hsc_eps <- liftIO $ hscEPS hsc_env
+        let pkgIfaceT = eps_PIT hsc_eps
+            homePkgT  = hsc_HPT hsc_env
+            iface     = lookupIfaceByModule dflags homePkgT pkgIfaceT m
+        -- the 'lookupIfaceByModule' method will always fail when calling from GHCi
+        -- as the compiler hasn't filled in the various module tables
+        -- so we need to call 'getModuleInterface' to load from disk
+        iface' <- case iface of
+            Just _  -> return iface
+            Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
+        return iface'
+
+
+    isHomePkg :: DynFlags -> Module -> Bool
+    isHomePkg dflags m
+        | thisPackage dflags == moduleUnitId m = True
+        | otherwise                               = False
+
+-- | Check the list of packages are trusted.
+checkPkgTrust :: Set InstalledUnitId -> Hsc ()
+checkPkgTrust pkgs = do
+    dflags <- getDynFlags
+    let errors = S.foldr go [] pkgs
+        go pkg acc
+            | trusted $ getInstalledPackageDetails dflags pkg
+            = acc
+            | otherwise
+            = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
+                     $ text "The package (" <> ppr pkg <> text ") is required" <>
+                       text " to be trusted but it isn't!"
+    case errors of
+        [] -> return ()
+        _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors
+
+-- | Set module to unsafe and (potentially) wipe trust information.
+--
+-- Make sure to call this method to set a module to inferred unsafe, it should
+-- be a central and single failure method. We only wipe the trust information
+-- when we aren't in a specific Safe Haskell mode.
+--
+-- While we only use this for recording that a module was inferred unsafe, we
+-- may call it on modules using Trustworthy or Unsafe flags so as to allow
+-- warning flags for safety to function correctly. See Note [Safe Haskell
+-- Inference].
+markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
+markUnsafeInfer tcg_env whyUnsafe = do
+    dflags <- getDynFlags
+
+    when (wopt Opt_WarnUnsafe dflags)
+         (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $
+             mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
+
+    liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)
+    -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other
+    -- times inference may be on but we are in Trustworthy mode -- so we want
+    -- to record safe-inference failed but not wipe the trust dependencies.
+    case not (safeHaskellModeEnabled dflags) of
+      True  -> return $ tcg_env { tcg_imports = wiped_trust }
+      False -> return tcg_env
+
+  where
+    wiped_trust   = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }
+    pprMod        = ppr $ moduleName $ tcg_mod tcg_env
+    whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
+                         , text "Reason:"
+                         , nest 4 $ (vcat $ badFlags df) $+$
+                                    (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$
+                                    (vcat $ badInsts $ tcg_insts tcg_env)
+                         ]
+    badFlags df   = concat $ map (badFlag df) unsafeFlagsForInfer
+    badFlag df (str,loc,on,_)
+        | on df     = [mkLocMessage SevOutput (loc df) $
+                            text str <+> text "is not allowed in Safe Haskell"]
+        | otherwise = []
+    badInsts insts = concat $ map badInst insts
+
+    checkOverlap (NoOverlap _) = False
+    checkOverlap _             = True
+
+    badInst ins | checkOverlap (overlapMode (is_flag ins))
+                = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $
+                      ppr (overlapMode $ is_flag ins) <+>
+                      text "overlap mode isn't allowed in Safe Haskell"]
+                | otherwise = []
+
+
+-- | Figure out the final correct safe haskell mode
+hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
+hscGetSafeMode tcg_env = do
+    dflags  <- getDynFlags
+    liftIO $ finalSafeMode dflags tcg_env
+
+--------------------------------------------------------------
+-- Simplifiers
+--------------------------------------------------------------
+
+hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
+hscSimplify hsc_env plugins modguts =
+    runHsc hsc_env $ hscSimplify' plugins modguts
+
+hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
+hscSimplify' plugins ds_result = do
+    hsc_env <- getHscEnv
+    let hsc_env_with_plugins = hsc_env
+          { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins
+          }
+    {-# SCC "Core2Core" #-}
+      liftIO $ core2core hsc_env_with_plugins ds_result
+
+--------------------------------------------------------------
+-- Interface generators
+--------------------------------------------------------------
+
+hscSimpleIface :: HscEnv
+               -> TcGblEnv
+               -> Maybe Fingerprint
+               -> IO (ModIface, Bool, ModDetails)
+hscSimpleIface hsc_env tc_result mb_old_iface
+    = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface
+
+hscSimpleIface' :: TcGblEnv
+                -> Maybe Fingerprint
+                -> Hsc (ModIface, Bool, ModDetails)
+hscSimpleIface' tc_result mb_old_iface = do
+    hsc_env   <- getHscEnv
+    details   <- liftIO $ mkBootModDetailsTc hsc_env tc_result
+    safe_mode <- hscGetSafeMode tc_result
+    (new_iface, no_change)
+        <- {-# SCC "MkFinalIface" #-}
+           liftIO $
+               mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result
+    -- And the answer is ...
+    liftIO $ dumpIfaceStats hsc_env
+    return (new_iface, no_change, details)
+
+hscNormalIface :: HscEnv
+               -> ModGuts
+               -> Maybe Fingerprint
+               -> IO (ModIface, Bool, ModDetails, CgGuts)
+hscNormalIface hsc_env simpl_result mb_old_iface =
+    runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface
+
+hscNormalIface' :: ModGuts
+                -> Maybe Fingerprint
+                -> Hsc (ModIface, Bool, ModDetails, CgGuts)
+hscNormalIface' simpl_result mb_old_iface = do
+    hsc_env <- getHscEnv
+    (cg_guts, details) <- {-# SCC "CoreTidy" #-}
+                          liftIO $ tidyProgram hsc_env simpl_result
+
+    -- BUILD THE NEW ModIface and ModDetails
+    --  and emit external core if necessary
+    -- This has to happen *after* code gen so that the back-end
+    -- info has been set. Not yet clear if it matters waiting
+    -- until after code output
+    (new_iface, no_change)
+        <- {-# SCC "MkFinalIface" #-}
+           liftIO $
+               mkIface hsc_env mb_old_iface details simpl_result
+
+    liftIO $ dumpIfaceStats hsc_env
+
+    -- Return the prepared code.
+    return (new_iface, no_change, details, cg_guts)
+
+--------------------------------------------------------------
+-- BackEnd combinators
+--------------------------------------------------------------
+
+hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
+hscWriteIface dflags iface no_change mod_summary = do
+    let ifaceFile = ml_hi_file (ms_location mod_summary)
+    unless no_change $
+        {-# SCC "writeIface" #-}
+        writeIfaceFile dflags ifaceFile iface
+    whenGeneratingDynamicToo dflags $ do
+        -- TODO: We should do a no_change check for the dynamic
+        --       interface file too
+        -- TODO: Should handle the dynamic hi filename properly
+        let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)
+            dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile
+            dynDflags = dynamicTooMkDynamicDynFlags dflags
+        writeIfaceFile dynDflags dynIfaceFile' iface
+
+-- | Compile to hard-code.
+hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath
+               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
+               -- ^ @Just f@ <=> _stub.c is f
+hscGenHardCode hsc_env cgguts mod_summary output_filename = do
+        let CgGuts{ -- This is the last use of the ModGuts in a compilation.
+                    -- From now on, we just use the bits we need.
+                    cg_module   = this_mod,
+                    cg_binds    = core_binds,
+                    cg_tycons   = tycons,
+                    cg_foreign  = foreign_stubs0,
+                    cg_foreign_files = foreign_files,
+                    cg_dep_pkgs = dependencies,
+                    cg_hpc_info = hpc_info } = cgguts
+            dflags = hsc_dflags hsc_env
+            location = ms_location mod_summary
+            data_tycons = filter isDataTyCon tycons
+            -- cg_tycons includes newtypes, for the benefit of External Core,
+            -- but we don't generate any code for newtypes
+
+        -------------------
+        -- PREPARE FOR CODE GENERATION
+        -- Do saturation and convert to A-normal form
+        (prepd_binds, local_ccs) <- {-# SCC "CorePrep" #-}
+                       corePrepPgm hsc_env this_mod location
+                                   core_binds data_tycons
+        -----------------  Convert to STG ------------------
+        (stg_binds, (caf_ccs, caf_cc_stacks))
+            <- {-# SCC "CoreToStg" #-}
+               myCoreToStg dflags this_mod prepd_binds
+
+        let cost_centre_info =
+              (S.toList local_ccs ++ caf_ccs, caf_cc_stacks)
+            prof_init = profilingInitCode this_mod cost_centre_info
+            foreign_stubs = foreign_stubs0 `appendStubC` prof_init
+
+        ------------------  Code generation ------------------
+
+        -- The back-end is streamed: each top-level function goes
+        -- from Stg all the way to asm before dealing with the next
+        -- top-level function, so showPass isn't very useful here.
+        -- Hence we have one showPass for the whole backend, the
+        -- next showPass after this will be "Assembler".
+        withTiming (pure dflags)
+                   (text "CodeGen"<+>brackets (ppr this_mod))
+                   (const ()) $ do
+            cmms <- {-# SCC "StgCmm" #-}
+                            doCodeGen hsc_env this_mod data_tycons
+                                cost_centre_info
+                                stg_binds hpc_info
+
+            ------------------  Code output -----------------------
+            rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
+                      cmmToRawCmm dflags cmms
+
+            let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"
+                              (ppr a)
+                            return a
+                rawcmms1 = Stream.mapM dump rawcmms0
+
+            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps)
+                <- {-# SCC "codeOutput" #-}
+                  codeOutput dflags this_mod output_filename location
+                  foreign_stubs foreign_files dependencies rawcmms1
+            return (output_filename, stub_c_exists, foreign_fps)
+
+
+hscInteractive :: HscEnv
+               -> CgGuts
+               -> ModSummary
+               -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
+hscInteractive hsc_env cgguts mod_summary = do
+    let dflags = hsc_dflags hsc_env
+    let CgGuts{ -- This is the last use of the ModGuts in a compilation.
+                -- From now on, we just use the bits we need.
+               cg_module   = this_mod,
+               cg_binds    = core_binds,
+               cg_tycons   = tycons,
+               cg_foreign  = foreign_stubs,
+               cg_modBreaks = mod_breaks,
+               cg_spt_entries = spt_entries } = cgguts
+
+        location = ms_location mod_summary
+        data_tycons = filter isDataTyCon tycons
+        -- cg_tycons includes newtypes, for the benefit of External Core,
+        -- but we don't generate any code for newtypes
+
+    -------------------
+    -- PREPARE FOR CODE GENERATION
+    -- Do saturation and convert to A-normal form
+    (prepd_binds, _) <- {-# SCC "CorePrep" #-}
+                   corePrepPgm hsc_env this_mod location core_binds data_tycons
+    -----------------  Generate byte code ------------------
+    comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks
+    ------------------ Create f-x-dynamic C-side stuff -----
+    (_istub_h_exists, istub_c_exists)
+        <- outputForeignStubs dflags this_mod location foreign_stubs
+    return (istub_c_exists, comp_bc, spt_entries)
+
+------------------------------
+
+hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()
+hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
+    let dflags = hsc_dflags hsc_env
+    cmm <- ioMsgMaybe $ parseCmmFile dflags filename
+    liftIO $ do
+        dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose "Parsed Cmm" (ppr cmm)
+        let -- Make up a module name to give the NCG. We can't pass bottom here
+            -- lest we reproduce #11784.
+            mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
+            cmm_mod = mkModule (thisPackage dflags) mod_name
+        (_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm
+        dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" (ppr cmmgroup)
+        rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
+        _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []
+             rawCmms
+        return ()
+  where
+    no_loc = ModLocation{ ml_hs_file  = Just filename,
+                          ml_hi_file  = panic "hscCompileCmmFile: no hi file",
+                          ml_obj_file = panic "hscCompileCmmFile: no obj file",
+                          ml_hie_file = panic "hscCompileCmmFile: no hie file"}
+
+-------------------- Stuff for new code gen ---------------------
+
+doCodeGen   :: HscEnv -> Module -> [TyCon]
+            -> CollectedCCs
+            -> [StgTopBinding]
+            -> HpcInfo
+            -> IO (Stream IO CmmGroup ())
+         -- Note we produce a 'Stream' of CmmGroups, so that the
+         -- backend can be run incrementally.  Otherwise it generates all
+         -- the C-- up front, which has a significant space cost.
+doCodeGen hsc_env this_mod data_tycons
+              cost_centre_info stg_binds hpc_info = do
+    let dflags = hsc_dflags hsc_env
+
+    let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds
+    let cmm_stream :: Stream IO CmmGroup ()
+        cmm_stream = {-# SCC "StgCmm" #-}
+            StgCmm.codeGen dflags this_mod data_tycons
+                           cost_centre_info stg_binds_w_fvs hpc_info
+
+        -- codegen consumes a stream of CmmGroup, and produces a new
+        -- stream of CmmGroup (not necessarily synchronised: one
+        -- CmmGroup on input may produce many CmmGroups on output due
+        -- to proc-point splitting).
+
+    let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg
+                       "Cmm produced by codegen" (ppr a)
+                     return a
+
+        ppr_stream1 = Stream.mapM dump1 cmm_stream
+
+    -- We are building a single SRT for the entire module, so
+    -- we must thread it through all the procedures as we cps-convert them.
+    us <- mkSplitUniqSupply 'S'
+
+    -- When splitting, we generate one SRT per split chunk, otherwise
+    -- we generate one SRT for the whole module.
+    let
+     pipeline_stream
+      | gopt Opt_SplitObjs dflags || gopt Opt_SplitSections dflags ||
+        osSubsectionsViaSymbols (platformOS (targetPlatform dflags))
+        = {-# SCC "cmmPipeline" #-}
+          let run_pipeline us cmmgroup = do
+                (_topSRT, cmmgroup) <-
+                  cmmPipeline hsc_env (emptySRT this_mod) cmmgroup
+                return (us, cmmgroup)
+
+          in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1
+                return ()
+
+      | otherwise
+        = {-# SCC "cmmPipeline" #-}
+          let run_pipeline = cmmPipeline hsc_env
+          in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1
+
+    let
+        dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
+                        "Output Cmm" (ppr a)
+                     return a
+
+        ppr_stream2 = Stream.mapM dump2 pipeline_stream
+
+    return ppr_stream2
+
+
+
+myCoreToStg :: DynFlags -> Module -> CoreProgram
+            -> IO ( [StgTopBinding] -- output program
+                  , CollectedCCs )  -- CAF cost centre info (declared and used)
+myCoreToStg dflags this_mod prepd_binds = do
+    let (stg_binds, cost_centre_info)
+         = {-# SCC "Core2Stg" #-}
+           coreToStg dflags this_mod prepd_binds
+
+    stg_binds2
+        <- {-# SCC "Stg2Stg" #-}
+           stg2stg dflags this_mod stg_binds
+
+    return (stg_binds2, cost_centre_info)
+
+
+{- **********************************************************************
+%*                                                                      *
+\subsection{Compiling a do-statement}
+%*                                                                      *
+%********************************************************************* -}
+
+{-
+When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
+you run it you get a list of HValues that should be the same length as the list
+of names; add them to the ClosureEnv.
+
+A naked expression returns a singleton Name [it]. The stmt is lifted into the
+IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes
+-}
+
+-- | Compile a stmt all the way to an HValue, but don't run it
+--
+-- We return Nothing to indicate an empty statement (or comment only), not a
+-- parse error.
+hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
+hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
+
+-- | Compile a stmt all the way to an HValue, but don't run it
+--
+-- We return Nothing to indicate an empty statement (or comment only), not a
+-- parse error.
+hscStmtWithLocation :: HscEnv
+                    -> String -- ^ The statement
+                    -> String -- ^ The source
+                    -> Int    -- ^ Starting line
+                    -> IO ( Maybe ([Id]
+                          , ForeignHValue {- IO [HValue] -}
+                          , FixityEnv))
+hscStmtWithLocation hsc_env0 stmt source linenumber =
+  runInteractiveHsc hsc_env0 $ do
+    maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
+    case maybe_stmt of
+      Nothing -> return Nothing
+
+      Just parsed_stmt -> do
+        hsc_env <- getHscEnv
+        liftIO $ hscParsedStmt hsc_env parsed_stmt
+
+hscParsedStmt :: HscEnv
+              -> GhciLStmt GhcPs  -- ^ The parsed statement
+              -> IO ( Maybe ([Id]
+                    , ForeignHValue {- IO [HValue] -}
+                    , FixityEnv))
+hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
+  -- Rename and typecheck it
+  (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt
+
+  -- Desugar it
+  ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
+  liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
+  handleWarnings
+
+  -- Then code-gen, and link it
+  -- It's important NOT to have package 'interactive' as thisUnitId
+  -- for linking, else we try to link 'main' and can't find it.
+  -- Whereas the linker already knows to ignore 'interactive'
+  let src_span = srcLocSpan interactiveSrcLoc
+  hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
+
+  return $ Just (ids, hval, fix_env)
+
+-- | Compile a decls
+hscDecls :: HscEnv
+         -> String -- ^ The statement
+         -> IO ([TyThing], InteractiveContext)
+hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
+
+hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]
+hscParseDeclsWithLocation hsc_env source line_num str = do
+    L _ (HsModule{ hsmodDecls = decls }) <-
+      runInteractiveHsc hsc_env $
+        hscParseThingWithLocation source line_num parseModule str
+    return decls
+
+-- | Compile a decls
+hscDeclsWithLocation :: HscEnv
+                     -> String -- ^ The statement
+                     -> String -- ^ The source
+                     -> Int    -- ^ Starting line
+                     -> IO ([TyThing], InteractiveContext)
+hscDeclsWithLocation hsc_env str source linenumber = do
+    L _ (HsModule{ hsmodDecls = decls }) <-
+      runInteractiveHsc hsc_env $
+        hscParseThingWithLocation source linenumber parseModule str
+    hscParsedDecls hsc_env decls
+
+hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
+hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
+    {- Rename and typecheck it -}
+    hsc_env <- getHscEnv
+    tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls
+
+    {- Grab the new instances -}
+    -- We grab the whole environment because of the overlapping that may have
+    -- been done. See the notes at the definition of InteractiveContext
+    -- (ic_instances) for more details.
+    let defaults = tcg_default tc_gblenv
+
+    {- Desugar it -}
+    -- We use a basically null location for iNTERACTIVE
+    let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,
+                                      ml_hi_file   = panic "hsDeclsWithLocation:ml_hi_file",
+                                      ml_obj_file  = panic "hsDeclsWithLocation:ml_obj_file",
+                                      ml_hie_file  = panic "hsDeclsWithLocation:ml_hie_file" }
+    ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
+
+    {- Simplify -}
+    simpl_mg <- liftIO $ do
+      plugins <- readIORef (tcg_th_coreplugins tc_gblenv)
+      hscSimplify hsc_env plugins ds_result
+
+    {- Tidy -}
+    (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
+
+    let !CgGuts{ cg_module    = this_mod,
+                 cg_binds     = core_binds,
+                 cg_tycons    = tycons,
+                 cg_modBreaks = mod_breaks } = tidy_cg
+
+        !ModDetails { md_insts     = cls_insts
+                    , md_fam_insts = fam_insts } = mod_details
+            -- Get the *tidied* cls_insts and fam_insts
+
+        data_tycons = filter isDataTyCon tycons
+
+    {- Prepare For Code Generation -}
+    -- Do saturation and convert to A-normal form
+    (prepd_binds, _) <- {-# SCC "CorePrep" #-}
+      liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
+
+    {- Generate byte code -}
+    cbc <- liftIO $ byteCodeGen hsc_env this_mod
+                                prepd_binds data_tycons mod_breaks
+
+    let src_span = srcLocSpan interactiveSrcLoc
+    liftIO $ linkDecls hsc_env src_span cbc
+
+    {- Load static pointer table entries -}
+    liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)
+
+    let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
+        patsyns = mg_patsyns simpl_mg
+
+        ext_ids = [ id | id <- bindersOfBinds core_binds
+                       , isExternalName (idName id)
+                       , not (isDFunId id || isImplicitId id) ]
+            -- We only need to keep around the external bindings
+            -- (as decided by TidyPgm), since those are the only ones
+            -- that might later be looked up by name.  But we can exclude
+            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in HscTypes
+            --    - Implicit Ids, which are implicit in tcs
+            -- c.f. TcRnDriver.runTcInteractive, which reconstructs the TypeEnv
+
+        new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
+        ictxt        = hsc_IC hsc_env
+        -- See Note [Fixity declarations in GHCi]
+        fix_env      = tcg_fix_env tc_gblenv
+        new_ictxt    = extendInteractiveContext ictxt new_tythings cls_insts
+                                                fam_insts defaults fix_env
+    return (new_tythings, new_ictxt)
+
+-- | Load the given static-pointer table entries into the interpreter.
+-- See Note [Grand plan for static forms] in StaticPtrTable.
+hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()
+hscAddSptEntries hsc_env entries = do
+    let add_spt_entry :: SptEntry -> IO ()
+        add_spt_entry (SptEntry i fpr) = do
+            val <- getHValue hsc_env (idName i)
+            addSptEntry hsc_env fpr val
+    mapM_ add_spt_entry entries
+
+{-
+  Note [Fixity declarations in GHCi]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  To support fixity declarations on types defined within GHCi (as requested
+  in #10018) we record the fixity environment in InteractiveContext.
+  When we want to evaluate something TcRnDriver.runTcInteractive pulls out this
+  fixity environment and uses it to initialize the global typechecker environment.
+  After the typechecker has finished its business, an updated fixity environment
+  (reflecting whatever fixity declarations were present in the statements we
+  passed it) will be returned from hscParsedStmt. This is passed to
+  updateFixityEnv, which will stuff it back into InteractiveContext, to be
+  used in evaluating the next statement.
+
+-}
+
+hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)
+hscImport hsc_env str = runInteractiveHsc hsc_env $ do
+    (L _ (HsModule{hsmodImports=is})) <-
+       hscParseThing parseModule str
+    case is of
+        [L _ i] -> return i
+        _ -> liftIO $ throwOneError $
+                 mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $
+                     text "parse error in import declaration"
+
+-- | Typecheck an expression (but don't run it)
+hscTcExpr :: HscEnv
+          -> TcRnExprMode
+          -> String -- ^ The expression
+          -> IO Type
+hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do
+  hsc_env <- getHscEnv
+  parsed_expr <- hscParseExpr expr
+  ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr
+
+-- | Find the kind of a type, after generalisation
+hscKcType
+  :: HscEnv
+  -> Bool            -- ^ Normalise the type
+  -> String          -- ^ The type as a string
+  -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
+hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
+    hsc_env <- getHscEnv
+    ty <- hscParseType str
+    ioMsgMaybe $ tcRnType hsc_env normalise ty
+
+hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
+hscParseExpr expr = do
+  hsc_env <- getHscEnv
+  maybe_stmt <- hscParseStmt expr
+  case maybe_stmt of
+    Just (L _ (BodyStmt _ expr _ _)) -> return expr
+    _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
+      (text "not an expression:" <+> quotes (text expr))
+
+hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
+hscParseStmt = hscParseThing parseStmt
+
+hscParseStmtWithLocation :: String -> Int -> String
+                         -> Hsc (Maybe (GhciLStmt GhcPs))
+hscParseStmtWithLocation source linenumber stmt =
+    hscParseThingWithLocation source linenumber parseStmt stmt
+
+hscParseType :: String -> Hsc (LHsType GhcPs)
+hscParseType = hscParseThing parseType
+
+hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
+hscParseIdentifier hsc_env str =
+    runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
+
+hscParseThing :: (Outputable thing, Data thing)
+              => Lexer.P thing -> String -> Hsc thing
+hscParseThing = hscParseThingWithLocation "<interactive>" 1
+
+hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
+                          -> Lexer.P thing -> String -> Hsc thing
+hscParseThingWithLocation source linenumber parser str
+  = withTiming getDynFlags
+               (text "Parser [source]")
+               (const ()) $ {-# SCC "Parser" #-} do
+    dflags <- getDynFlags
+
+    let buf = stringToStringBuffer str
+        loc = mkRealSrcLoc (fsLit source) linenumber 1
+
+    case unP parser (mkPState dflags buf loc) of
+        PFailed warnFn span err -> do
+            logWarningsReportErrors (warnFn dflags)
+            handleWarnings
+            let msg = mkPlainErrMsg dflags span err
+            throwErrors $ unitBag msg
+
+        POk pst thing -> do
+            logWarningsReportErrors (getMessages pst dflags)
+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
+                                   showAstData NoBlankSrcSpan thing
+            return thing
+
+
+{- **********************************************************************
+%*                                                                      *
+        Desugar, simplify, convert to bytecode, and link an expression
+%*                                                                      *
+%********************************************************************* -}
+
+hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
+hscCompileCoreExpr hsc_env =
+  lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env
+
+hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
+hscCompileCoreExpr' hsc_env srcspan ds_expr
+    = do { let dflags = hsc_dflags hsc_env
+
+           {- Simplify it -}
+         ; simpl_expr <- simplifyExpr dflags ds_expr
+
+           {- Tidy it (temporary, until coreSat does cloning) -}
+         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
+
+           {- Prepare for codegen -}
+         ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
+
+           {- Lint if necessary -}
+         ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
+
+           {- Convert to BCOs -}
+         ; bcos <- coreExprToBCOs hsc_env
+                     (icInteractiveModule (hsc_IC hsc_env)) prepd_expr
+
+           {- link it -}
+         ; hval <- linkExpr hsc_env srcspan bcos
+
+         ; return hval }
+
+
+{- **********************************************************************
+%*                                                                      *
+        Statistics on reading interfaces
+%*                                                                      *
+%********************************************************************* -}
+
+dumpIfaceStats :: HscEnv -> IO ()
+dumpIfaceStats hsc_env = do
+    eps <- readIORef (hsc_EPS hsc_env)
+    dumpIfSet dflags (dump_if_trace || dump_rn_stats)
+              "Interface statistics"
+              (ifaceStats eps)
+  where
+    dflags = hsc_dflags hsc_env
+    dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
+    dump_if_trace = dopt Opt_D_dump_if_trace dflags
+
+
+{- **********************************************************************
+%*                                                                      *
+        Progress Messages: Module i of n
+%*                                                                      *
+%********************************************************************* -}
+
+showModuleIndex :: (Int, Int) -> String
+showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "
+  where
+    n_str = show n
+    i_str = show i
+    padded = replicate (length n_str - length i_str) ' ' ++ i_str
diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/HscStats.hs
@@ -0,0 +1,189 @@
+-- |
+-- Statistics for per-module compilations
+--
+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+--
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module HscStats ( ppSourceStats ) where
+
+import GhcPrelude
+
+import Bag
+import HsSyn
+import Outputable
+import SrcLoc
+import Util
+
+import Data.Char
+
+-- | Source Statistics
+ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc
+ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _))
+  = (if short then hcat else vcat)
+        (map pp_val
+            [("ExportAll        ", export_all), -- 1 if no export list
+             ("ExportDecls      ", export_ds),
+             ("ExportModules    ", export_ms),
+             ("Imports          ", imp_no),
+             ("  ImpSafe        ", imp_safe),
+             ("  ImpQual        ", imp_qual),
+             ("  ImpAs          ", imp_as),
+             ("  ImpAll         ", imp_all),
+             ("  ImpPartial     ", imp_partial),
+             ("  ImpHiding      ", imp_hiding),
+             ("FixityDecls      ", fixity_sigs),
+             ("DefaultDecls     ", default_ds),
+             ("TypeDecls        ", type_ds),
+             ("DataDecls        ", data_ds),
+             ("NewTypeDecls     ", newt_ds),
+             ("TypeFamilyDecls  ", type_fam_ds),
+             ("DataConstrs      ", data_constrs),
+             ("DataDerivings    ", data_derivs),
+             ("ClassDecls       ", class_ds),
+             ("ClassMethods     ", class_method_ds),
+             ("DefaultMethods   ", default_method_ds),
+             ("InstDecls        ", inst_ds),
+             ("InstMethods      ", inst_method_ds),
+             ("InstType         ", inst_type_ds),
+             ("InstData         ", inst_data_ds),
+             ("TypeSigs         ", bind_tys),
+             ("ClassOpSigs      ", generic_sigs),
+             ("ValBinds         ", val_bind_ds),
+             ("FunBinds         ", fn_bind_ds),
+             ("PatSynBinds      ", patsyn_ds),
+             ("InlineMeths      ", method_inlines),
+             ("InlineBinds      ", bind_inlines),
+             ("SpecialisedMeths ", method_specs),
+             ("SpecialisedBinds ", bind_specs)
+            ])
+  where
+    decls = map unLoc ldecls
+
+    pp_val (_, 0) = empty
+    pp_val (str, n)
+      | not short   = hcat [text str, int n]
+      | otherwise   = hcat [text (trim str), equals, int n, semi]
+
+    trim ls    = takeWhile (not.isSpace) (dropWhile isSpace ls)
+
+    (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs)
+        = count_sigs [d | SigD _ d <- decls]
+                -- NB: this omits fixity decls on local bindings and
+                -- in class decls. ToDo
+
+    tycl_decls = [d | TyClD _ d <- decls]
+    (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) =
+      countTyClDecls tycl_decls
+
+    inst_decls = [d | InstD _ d <- decls]
+    inst_ds    = length inst_decls
+    default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls
+    val_decls  = [d | ValD _ d <- decls]
+
+    real_exports = case exports of { Nothing -> []; Just (dL->L _ es) -> es }
+    n_exports    = length real_exports
+    export_ms    = count (\ e -> case unLoc e of { IEModuleContents{} -> True
+                                                 ; _ -> False})
+                         real_exports
+    export_ds    = n_exports - export_ms
+    export_all   = case exports of { Nothing -> 1; _ -> 0 }
+
+    (val_bind_ds, fn_bind_ds, patsyn_ds)
+        = sum3 (map count_bind val_decls)
+
+    (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding)
+        = sum7 (map import_info imports)
+    (data_constrs, data_derivs)
+        = sum2 (map data_info tycl_decls)
+    (class_method_ds, default_method_ds)
+        = sum2 (map class_info tycl_decls)
+    (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds)
+        = sum5 (map inst_info inst_decls)
+
+    count_bind (PatBind { pat_lhs = (dL->L _ (VarPat{})) }) = (1,0,0)
+    count_bind (PatBind {})                           = (0,1,0)
+    count_bind (FunBind {})                           = (0,1,0)
+    count_bind (PatSynBind {})                        = (0,0,1)
+    count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b)
+
+    count_sigs sigs = sum5 (map sig_info sigs)
+
+    sig_info (FixSig {})     = (1,0,0,0,0)
+    sig_info (TypeSig {})    = (0,1,0,0,0)
+    sig_info (SpecSig {})    = (0,0,1,0,0)
+    sig_info (InlineSig {})  = (0,0,0,1,0)
+    sig_info (ClassOpSig {}) = (0,0,0,0,1)
+    sig_info _               = (0,0,0,0,0)
+
+    import_info (dL->L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
+                                     , ideclAs = as, ideclHiding = spec }))
+        = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)
+    import_info (dL->L _ (XImportDecl _)) = panic "import_info"
+    import_info _ = panic " import_info: Impossible Match"
+                             -- due to #15884
+
+    safe_info = qual_info
+    qual_info False  = 0
+    qual_info True   = 1
+    as_info Nothing  = 0
+    as_info (Just _) = 1
+    spec_info Nothing           = (0,0,0,0,1,0,0)
+    spec_info (Just (False, _)) = (0,0,0,0,0,1,0)
+    spec_info (Just (True, _))  = (0,0,0,0,0,0,1)
+
+    data_info (DataDecl { tcdDataDefn = HsDataDefn
+                                          { dd_cons = cs
+                                          , dd_derivs = (dL->L _ derivs)}})
+        = ( length cs
+          , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s)
+                   0 derivs )
+    data_info _ = (0,0)
+
+    class_info decl@(ClassDecl {})
+        = (classops, addpr (sum3 (map count_bind methods)))
+      where
+        methods = map unLoc $ bagToList (tcdMeths decl)
+        (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl))
+    class_info _ = (0,0)
+
+    inst_info (TyFamInstD {}) = (0,0,0,1,0)
+    inst_info (DataFamInstD {}) = (0,0,0,0,1)
+    inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths
+                                                 , cid_sigs = inst_sigs
+                                                 , cid_tyfam_insts = ats
+                                                 , cid_datafam_insts = adts } })
+        = case count_sigs (map unLoc inst_sigs) of
+            (_,_,ss,is,_) ->
+                  (addpr (sum3 (map count_bind methods)),
+                   ss, is, length ats, length adts)
+      where
+        methods = map unLoc $ bagToList inst_meths
+    inst_info (ClsInstD _ (XClsInstDecl _)) = panic "inst_info"
+    inst_info (XInstDecl _)                 = panic "inst_info"
+
+    -- TODO: use Sum monoid
+    addpr :: (Int,Int,Int) -> Int
+    sum2 :: [(Int, Int)] -> (Int, Int)
+    sum3 :: [(Int, Int, Int)] -> (Int, Int, Int)
+    sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int)
+    sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int)
+    add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int)
+         -> (Int, Int, Int, Int, Int, Int, Int)
+
+    addpr (x,y,z) = x+y+z
+    sum2 = foldr add2 (0,0)
+      where
+        add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
+    sum3 = foldr add3 (0,0,0)
+      where
+        add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3)
+    sum5 = foldr add5 (0,0,0,0,0)
+      where
+        add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
+    sum7 = foldr add7 (0,0,0,0,0,0,0)
+
+    add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7)
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/InteractiveEval.hs
@@ -0,0 +1,1042 @@
+{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples,
+    RecordWildCards, BangPatterns #-}
+
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2005-2007
+--
+-- Running statements interactively
+--
+-- -----------------------------------------------------------------------------
+
+module InteractiveEval (
+        Resume(..), History(..),
+        execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), resumeExec,
+        runDecls, runDeclsWithLocation, runParsedDecls,
+        isStmt, hasImport, isImport, isDecl,
+        parseImportDecl, SingleStep(..),
+        abandon, abandonAll,
+        getResumeContext,
+        getHistorySpan,
+        getModBreaks,
+        getHistoryModule,
+        back, forward,
+        setContext, getContext,
+        availsToGlobalRdrEnv,
+        getNamesInScope,
+        getRdrNamesInScope,
+        moduleIsInterpreted,
+        getInfo,
+        exprType,
+        typeKind,
+        parseName,
+        getDocs,
+        GetDocsFailure(..),
+        showModule,
+        moduleIsBootOrNotObjectLinkable,
+        parseExpr, compileParsedExpr,
+        compileExpr, dynCompileExpr,
+        compileExprRemote, compileParsedExprRemote,
+        Term(..), obtainTermFromId, obtainTermFromVal, reconstructType
+        ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import InteractiveEvalTypes
+
+import GHCi
+import GHCi.Message
+import GHCi.RemoteTypes
+import GhcMonad
+import HscMain
+import HsSyn
+import HscTypes
+import InstEnv
+import IfaceEnv   ( newInteractiveBinder )
+import FamInstEnv ( FamInst )
+import CoreFVs    ( orphNamesOfFamInst )
+import TyCon
+import Type             hiding( typeKind )
+import RepType
+import TcType           hiding( typeKind )
+import Var
+import Id
+import Name             hiding ( varName )
+import NameSet
+import Avail
+import RdrName
+import VarEnv
+import ByteCodeTypes
+import Linker
+import DynFlags
+import Unique
+import UniqSupply
+import MonadUtils
+import Module
+import PrelNames  ( toDynName, pretendNameIsInScope )
+import TysWiredIn ( isCTupleTyConName )
+import Panic
+import Maybes
+import ErrUtils
+import SrcLoc
+import RtClosureInspect
+import Outputable
+import FastString
+import Bag
+import Util
+import qualified Lexer (P (..), ParseResult(..), unP, mkPState)
+import qualified Parser (parseStmt, parseModule, parseDeclaration, parseImport)
+
+import System.Directory
+import Data.Dynamic
+import Data.Either
+import qualified Data.IntMap as IntMap
+import Data.List (find,intercalate)
+import Data.Map (Map)
+import qualified Data.Map as Map
+import StringBuffer (stringToStringBuffer)
+import Control.Monad
+import GHC.Exts
+import Data.Array
+import Exception
+
+-- -----------------------------------------------------------------------------
+-- running a statement interactively
+
+getResumeContext :: GhcMonad m => m [Resume]
+getResumeContext = withSession (return . ic_resume . hsc_IC)
+
+mkHistory :: HscEnv -> ForeignHValue -> BreakInfo -> History
+mkHistory hsc_env hval bi = History hval bi (findEnclosingDecls hsc_env bi)
+
+getHistoryModule :: History -> Module
+getHistoryModule = breakInfo_module . historyBreakInfo
+
+getHistorySpan :: HscEnv -> History -> SrcSpan
+getHistorySpan hsc_env History{..} =
+  let BreakInfo{..} = historyBreakInfo in
+  case lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module) of
+    Just hmi -> modBreaks_locs (getModBreaks hmi) ! breakInfo_number
+    _ -> panic "getHistorySpan"
+
+getModBreaks :: HomeModInfo -> ModBreaks
+getModBreaks hmi
+  | Just linkable <- hm_linkable hmi,
+    [BCOs cbc _] <- linkableUnlinked linkable
+  = fromMaybe emptyModBreaks (bc_breaks cbc)
+  | otherwise
+  = emptyModBreaks -- probably object code
+
+{- | Finds the enclosing top level function name -}
+-- ToDo: a better way to do this would be to keep hold of the decl_path computed
+-- by the coverage pass, which gives the list of lexically-enclosing bindings
+-- for each tick.
+findEnclosingDecls :: HscEnv -> BreakInfo -> [String]
+findEnclosingDecls hsc_env (BreakInfo modl ix) =
+   let hmi = expectJust "findEnclosingDecls" $
+             lookupHpt (hsc_HPT hsc_env) (moduleName modl)
+       mb = getModBreaks hmi
+   in modBreaks_decls mb ! ix
+
+-- | Update fixity environment in the current interactive context.
+updateFixityEnv :: GhcMonad m => FixityEnv -> m ()
+updateFixityEnv fix_env = do
+  hsc_env <- getSession
+  let ic = hsc_IC hsc_env
+  setSession $ hsc_env { hsc_IC = ic { ic_fix_env = fix_env } }
+
+-- -----------------------------------------------------------------------------
+-- execStmt
+
+-- | default ExecOptions
+execOptions :: ExecOptions
+execOptions = ExecOptions
+  { execSingleStep = RunToCompletion
+  , execSourceFile = "<interactive>"
+  , execLineNumber = 1
+  , execWrap = EvalThis -- just run the statement, don't wrap it in anything
+  }
+
+-- | Run a statement in the current interactive context.
+execStmt
+  :: GhcMonad m
+  => String             -- ^ a statement (bind or expression)
+  -> ExecOptions
+  -> m ExecResult
+execStmt input exec_opts@ExecOptions{..} = do
+    hsc_env <- getSession
+
+    mb_stmt <-
+      liftIO $
+      runInteractiveHsc hsc_env $
+      hscParseStmtWithLocation execSourceFile execLineNumber input
+
+    case mb_stmt of
+      -- empty statement / comment
+      Nothing -> return (ExecComplete (Right []) 0)
+      Just stmt -> execStmt' stmt input exec_opts
+
+-- | Like `execStmt`, but takes a parsed statement as argument. Useful when
+-- doing preprocessing on the AST before execution, e.g. in GHCi (see
+-- GHCi.UI.runStmt).
+execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
+execStmt' stmt stmt_text ExecOptions{..} = do
+    hsc_env <- getSession
+
+    -- Turn off -fwarn-unused-local-binds when running a statement, to hide
+    -- warnings about the implicit bindings we introduce.
+    -- (This is basically `mkInteractiveHscEnv hsc_env`, except we unset
+    -- -wwarn-unused-local-binds)
+    let ic       = hsc_IC hsc_env -- use the interactive dflags
+        idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds
+        hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } })
+
+    r <- liftIO $ hscParsedStmt hsc_env' stmt
+
+    case r of
+      Nothing ->
+        -- empty statement / comment
+        return (ExecComplete (Right []) 0)
+      Just (ids, hval, fix_env) -> do
+        updateFixityEnv fix_env
+
+        status <-
+          withVirtualCWD $
+            liftIO $
+              evalStmt hsc_env' (isStep execSingleStep) (execWrap hval)
+
+        let ic = hsc_IC hsc_env
+            bindings = (ic_tythings ic, ic_rn_gbl_env ic)
+
+            size = ghciHistSize idflags'
+
+        handleRunStatus execSingleStep stmt_text bindings ids
+                        status (emptyHistory size)
+
+runDecls :: GhcMonad m => String -> m [Name]
+runDecls = runDeclsWithLocation "<interactive>" 1
+
+-- | Run some declarations and return any user-visible names that were brought
+-- into scope.
+runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name]
+runDeclsWithLocation source line_num input = do
+    hsc_env <- getSession
+    decls <- liftIO (hscParseDeclsWithLocation hsc_env source line_num input)
+    runParsedDecls decls
+
+-- | Like `runDeclsWithLocation`, but takes parsed declarations as argument.
+-- Useful when doing preprocessing on the AST before execution, e.g. in GHCi
+-- (see GHCi.UI.runStmt).
+runParsedDecls :: GhcMonad m => [LHsDecl GhcPs] -> m [Name]
+runParsedDecls decls = do
+    hsc_env <- getSession
+    (tyThings, ic) <- liftIO (hscParsedDecls hsc_env decls)
+
+    setSession $ hsc_env { hsc_IC = ic }
+    hsc_env <- getSession
+    hsc_env' <- liftIO $ rttiEnvironment hsc_env
+    setSession hsc_env'
+    return $ filter (not . isDerivedOccName . nameOccName)
+             -- For this filter, see Note [What to show to users]
+           $ map getName tyThings
+
+{- Note [What to show to users]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't want to display internally-generated bindings to users.
+Things like the coercion axiom for newtypes. These bindings all get
+OccNames that users can't write, to avoid the possibility of name
+clashes (in linker symbols).  That gives a convenient way to suppress
+them. The relevant predicate is OccName.isDerivedOccName.
+See Trac #11051 for more background and examples.
+-}
+
+withVirtualCWD :: GhcMonad m => m a -> m a
+withVirtualCWD m = do
+  hsc_env <- getSession
+
+    -- a virtual CWD is only necessary when we're running interpreted code in
+    -- the same process as the compiler.
+  if gopt Opt_ExternalInterpreter (hsc_dflags hsc_env) then m else do
+
+  let ic = hsc_IC hsc_env
+  let set_cwd = do
+        dir <- liftIO $ getCurrentDirectory
+        case ic_cwd ic of
+           Just dir -> liftIO $ setCurrentDirectory dir
+           Nothing  -> return ()
+        return dir
+
+      reset_cwd orig_dir = do
+        virt_dir <- liftIO $ getCurrentDirectory
+        hsc_env <- getSession
+        let old_IC = hsc_IC hsc_env
+        setSession hsc_env{  hsc_IC = old_IC{ ic_cwd = Just virt_dir } }
+        liftIO $ setCurrentDirectory orig_dir
+
+  gbracket set_cwd reset_cwd $ \_ -> m
+
+parseImportDecl :: GhcMonad m => String -> m (ImportDecl GhcPs)
+parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr
+
+emptyHistory :: Int -> BoundedList History
+emptyHistory size = nilBL size
+
+handleRunStatus :: GhcMonad m
+                => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]
+                -> EvalStatus_ [ForeignHValue] [HValueRef]
+                -> BoundedList History
+                -> m ExecResult
+
+handleRunStatus step expr bindings final_ids status history
+  | RunAndLogSteps <- step = tracing
+  | otherwise              = not_tracing
+ where
+  tracing
+    | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt _ccs <- status
+    , not is_exception
+    = do
+       hsc_env <- getSession
+       let hmi = expectJust "handleRunStatus" $
+                   lookupHptDirectly (hsc_HPT hsc_env)
+                                     (mkUniqueGrimily mod_uniq)
+           modl = mi_module (hm_iface hmi)
+           breaks = getModBreaks hmi
+
+       b <- liftIO $
+              breakpointStatus hsc_env (modBreaks_flags breaks) ix
+       if b
+         then not_tracing
+           -- This breakpoint is explicitly enabled; we want to stop
+           -- instead of just logging it.
+         else do
+           apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
+           let bi = BreakInfo modl ix
+               !history' = mkHistory hsc_env apStack_fhv bi `consBL` history
+                 -- history is strict, otherwise our BoundedList is pointless.
+           fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
+           status <- liftIO $ GHCi.resumeStmt hsc_env True fhv
+           handleRunStatus RunAndLogSteps expr bindings final_ids
+                           status history'
+    | otherwise
+    = not_tracing
+
+  not_tracing
+    -- Hit a breakpoint
+    | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status
+    = do
+         hsc_env <- getSession
+         resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt
+         apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref
+         let hmi = expectJust "handleRunStatus" $
+                     lookupHptDirectly (hsc_HPT hsc_env)
+                                       (mkUniqueGrimily mod_uniq)
+             modl = mi_module (hm_iface hmi)
+             bp | is_exception = Nothing
+                | otherwise = Just (BreakInfo modl ix)
+         (hsc_env1, names, span, decl) <- liftIO $
+           bindLocalsAtBreakpoint hsc_env apStack_fhv bp
+         let
+           resume = Resume
+             { resumeStmt = expr, resumeContext = resume_ctxt_fhv
+             , resumeBindings = bindings, resumeFinalIds = final_ids
+             , resumeApStack = apStack_fhv
+             , resumeBreakInfo = bp
+             , resumeSpan = span, resumeHistory = toListBL history
+             , resumeDecl = decl
+             , resumeCCS = ccs
+             , resumeHistoryIx = 0 }
+           hsc_env2 = pushResume hsc_env1 resume
+
+         setSession hsc_env2
+         return (ExecBreak names bp)
+
+    -- Completed successfully
+    | EvalComplete allocs (EvalSuccess hvals) <- status
+    = do hsc_env <- getSession
+         let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
+             final_names = map getName final_ids
+         liftIO $ Linker.extendLinkEnv (zip final_names hvals)
+         hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
+         setSession hsc_env'
+         return (ExecComplete (Right final_names) allocs)
+
+    -- Completed with an exception
+    | EvalComplete alloc (EvalException e) <- status
+    = return (ExecComplete (Left (fromSerializableException e)) alloc)
+
+    | otherwise
+    = panic "not_tracing" -- actually exhaustive, but GHC can't tell
+
+
+resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult
+resumeExec canLogSpan step
+ = do
+   hsc_env <- getSession
+   let ic = hsc_IC hsc_env
+       resume = ic_resume ic
+
+   case resume of
+     [] -> liftIO $
+           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
+     (r:rs) -> do
+        -- unbind the temporary locals by restoring the TypeEnv from
+        -- before the breakpoint, and drop this Resume from the
+        -- InteractiveContext.
+        let (resume_tmp_te,resume_rdr_env) = resumeBindings r
+            ic' = ic { ic_tythings = resume_tmp_te,
+                       ic_rn_gbl_env = resume_rdr_env,
+                       ic_resume   = rs }
+        setSession hsc_env{ hsc_IC = ic' }
+
+        -- remove any bindings created since the breakpoint from the
+        -- linker's environment
+        let old_names = map getName resume_tmp_te
+            new_names = [ n | thing <- ic_tythings ic
+                            , let n = getName thing
+                            , not (n `elem` old_names) ]
+        liftIO $ Linker.deleteFromLinkEnv new_names
+
+        case r of
+          Resume { resumeStmt = expr, resumeContext = fhv
+                 , resumeBindings = bindings, resumeFinalIds = final_ids
+                 , resumeApStack = apStack, resumeBreakInfo = mb_brkpt
+                 , resumeSpan = span
+                 , resumeHistory = hist } -> do
+               withVirtualCWD $ do
+                status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv
+                let prevHistoryLst = fromListBL 50 hist
+                    hist' = case mb_brkpt of
+                       Nothing -> prevHistoryLst
+                       Just bi
+                         | not $canLogSpan span -> prevHistoryLst
+                         | otherwise -> mkHistory hsc_env apStack bi `consBL`
+                                                        fromListBL 50 hist
+                handleRunStatus step expr bindings final_ids status hist'
+
+back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
+back n = moveHist (+n)
+
+forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)
+forward n = moveHist (subtract n)
+
+moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)
+moveHist fn = do
+  hsc_env <- getSession
+  case ic_resume (hsc_IC hsc_env) of
+     [] -> liftIO $
+           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")
+     (r:rs) -> do
+        let ix = resumeHistoryIx r
+            history = resumeHistory r
+            new_ix = fn ix
+        --
+        when (history `lengthLessThan` new_ix) $ liftIO $
+           throwGhcExceptionIO (ProgramError "no more logged breakpoints")
+        when (new_ix < 0) $ liftIO $
+           throwGhcExceptionIO (ProgramError "already at the beginning of the history")
+
+        let
+          update_ic apStack mb_info = do
+            (hsc_env1, names, span, decl) <-
+              liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info
+            let ic = hsc_IC hsc_env1
+                r' = r { resumeHistoryIx = new_ix }
+                ic' = ic { ic_resume = r':rs }
+
+            setSession hsc_env1{ hsc_IC = ic' }
+
+            return (names, new_ix, span, decl)
+
+        -- careful: we want apStack to be the AP_STACK itself, not a thunk
+        -- around it, hence the cases are carefully constructed below to
+        -- make this the case.  ToDo: this is v. fragile, do something better.
+        if new_ix == 0
+           then case r of
+                   Resume { resumeApStack = apStack,
+                            resumeBreakInfo = mb_brkpt } ->
+                          update_ic apStack mb_brkpt
+           else case history !! (new_ix - 1) of
+                   History{..} ->
+                     update_ic historyApStack (Just historyBreakInfo)
+
+
+-- -----------------------------------------------------------------------------
+-- After stopping at a breakpoint, add free variables to the environment
+
+result_fs :: FastString
+result_fs = fsLit "_result"
+
+bindLocalsAtBreakpoint
+        :: HscEnv
+        -> ForeignHValue
+        -> Maybe BreakInfo
+        -> IO (HscEnv, [Name], SrcSpan, String)
+
+-- Nothing case: we stopped when an exception was raised, not at a
+-- breakpoint.  We have no location information or local variables to
+-- bind, all we can do is bind a local variable to the exception
+-- value.
+bindLocalsAtBreakpoint hsc_env apStack Nothing = do
+   let exn_occ = mkVarOccFS (fsLit "_exception")
+       span    = mkGeneralSrcSpan (fsLit "<unknown>")
+   exn_name <- newInteractiveBinder hsc_env exn_occ span
+
+   let e_fs    = fsLit "e"
+       e_name  = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span
+       e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind
+       exn_id  = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar)
+
+       ictxt0 = hsc_IC hsc_env
+       ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
+   --
+   Linker.extendLinkEnv [(exn_name, apStack)]
+   return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")
+
+-- Just case: we stopped at a breakpoint, we have information about the location
+-- of the breakpoint and the free variables of the expression.
+bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do
+   let
+       hmi       = expectJust "bindLocalsAtBreakpoint" $
+                     lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module)
+       breaks    = getModBreaks hmi
+       info      = expectJust "bindLocalsAtBreakpoint2" $
+                     IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)
+       vars      = cgb_vars info
+       result_ty = cgb_resty info
+       occs      = modBreaks_vars breaks ! breakInfo_number
+       span      = modBreaks_locs breaks ! breakInfo_number
+       decl      = intercalate "." $ modBreaks_decls breaks ! breakInfo_number
+
+           -- Filter out any unboxed ids;
+           -- we can't bind these at the prompt
+       pointers = filter (\(id,_) -> isPointer id) vars
+       isPointer id | [rep] <- typePrimRep (idType id)
+                    , isGcPtrRep rep                   = True
+                    | otherwise                        = False
+
+       (ids, offsets) = unzip pointers
+
+       free_tvs = tyCoVarsOfTypesList (result_ty:map idType ids)
+
+   -- It might be that getIdValFromApStack fails, because the AP_STACK
+   -- has been accidentally evaluated, or something else has gone wrong.
+   -- So that we don't fall over in a heap when this happens, just don't
+   -- bind any free variables instead, and we emit a warning.
+   mb_hValues <-
+      mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets
+   when (any isNothing mb_hValues) $
+      debugTraceMsg (hsc_dflags hsc_env) 1 $
+          text "Warning: _result has been evaluated, some bindings have been lost"
+
+   us <- mkSplitUniqSupply 'I'   -- Dodgy; will give the same uniques every time
+   let tv_subst     = newTyVars us free_tvs
+       filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ]
+       (_,tidy_tys) = tidyOpenTypes emptyTidyEnv $
+                      map (substTy tv_subst . idType) filtered_ids
+
+   new_ids     <- zipWith3M mkNewId occs tidy_tys filtered_ids
+   result_name <- newInteractiveBinder hsc_env (mkVarOccFS result_fs) span
+
+   let result_id = Id.mkVanillaGlobal result_name
+                     (substTy tv_subst result_ty)
+       result_ok = isPointer result_id
+
+       final_ids | result_ok = result_id : new_ids
+                 | otherwise = new_ids
+       ictxt0 = hsc_IC hsc_env
+       ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids
+       names  = map idName new_ids
+
+   let fhvs = catMaybes mb_hValues
+   Linker.extendLinkEnv (zip names fhvs)
+   when result_ok $ Linker.extendLinkEnv [(result_name, apStack_fhv)]
+   hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
+   return (hsc_env1, if result_ok then result_name:names else names, span, decl)
+  where
+        -- We need a fresh Unique for each Id we bind, because the linker
+        -- state is single-threaded and otherwise we'd spam old bindings
+        -- whenever we stop at a breakpoint.  The InteractveContext is properly
+        -- saved/restored, but not the linker state.  See #1743, test break026.
+   mkNewId :: OccName -> Type -> Id -> IO Id
+   mkNewId occ ty old_id
+     = do { name <- newInteractiveBinder hsc_env occ (getSrcSpan old_id)
+          ; return (Id.mkVanillaGlobalWithInfo name ty (idInfo old_id)) }
+
+   newTyVars :: UniqSupply -> [TcTyVar] -> TCvSubst
+     -- Similarly, clone the type variables mentioned in the types
+     -- we have here, *and* make them all RuntimeUnk tyvars
+   newTyVars us tvs
+     = mkTvSubstPrs [ (tv, mkTyVarTy (mkRuntimeUnkTyVar name (tyVarKind tv)))
+                    | (tv, uniq) <- tvs `zip` uniqsFromSupply us
+                    , let name = setNameUnique (tyVarName tv) uniq ]
+
+rttiEnvironment :: HscEnv -> IO HscEnv
+rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
+   let tmp_ids = [id | AnId id <- ic_tythings ic]
+       incompletelyTypedIds =
+           [id | id <- tmp_ids
+               , not $ noSkolems id
+               , (occNameFS.nameOccName.idName) id /= result_fs]
+   hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)
+   return hsc_env'
+    where
+     noSkolems = noFreeVarsOfType . idType
+     improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do
+      let tmp_ids = [id | AnId id <- ic_tythings ic]
+          Just id = find (\i -> idName i == name) tmp_ids
+      if noSkolems id
+         then return hsc_env
+         else do
+           mb_new_ty <- reconstructType hsc_env 10 id
+           let old_ty = idType id
+           case mb_new_ty of
+             Nothing -> return hsc_env
+             Just new_ty -> do
+              case improveRTTIType hsc_env old_ty new_ty of
+               Nothing -> return $
+                        WARN(True, text (":print failed to calculate the "
+                                           ++ "improvement for a type")) hsc_env
+               Just subst -> do
+                 let dflags = hsc_dflags hsc_env
+                 dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"
+                   (fsep [text "RTTI Improvement for", ppr id, equals,
+                          ppr subst])
+
+                 let ic' = substInteractiveContext ic subst
+                 return hsc_env{hsc_IC=ic'}
+
+pushResume :: HscEnv -> Resume -> HscEnv
+pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
+  where
+        ictxt0 = hsc_IC hsc_env
+        ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }
+
+-- -----------------------------------------------------------------------------
+-- Abandoning a resume context
+
+abandon :: GhcMonad m => m Bool
+abandon = do
+   hsc_env <- getSession
+   let ic = hsc_IC hsc_env
+       resume = ic_resume ic
+   case resume of
+      []    -> return False
+      r:rs  -> do
+         setSession hsc_env{ hsc_IC = ic { ic_resume = rs } }
+         liftIO $ abandonStmt hsc_env (resumeContext r)
+         return True
+
+abandonAll :: GhcMonad m => m Bool
+abandonAll = do
+   hsc_env <- getSession
+   let ic = hsc_IC hsc_env
+       resume = ic_resume ic
+   case resume of
+      []  -> return False
+      rs  -> do
+         setSession hsc_env{ hsc_IC = ic { ic_resume = [] } }
+         liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs
+         return True
+
+-- -----------------------------------------------------------------------------
+-- Bounded list, optimised for repeated cons
+
+data BoundedList a = BL
+                        {-# UNPACK #-} !Int  -- length
+                        {-# UNPACK #-} !Int  -- bound
+                        [a] -- left
+                        [a] -- right,  list is (left ++ reverse right)
+
+nilBL :: Int -> BoundedList a
+nilBL bound = BL 0 bound [] []
+
+consBL :: a -> BoundedList a -> BoundedList a
+consBL a (BL len bound left right)
+  | len < bound = BL (len+1) bound (a:left) right
+  | null right  = BL len     bound [a]      $! tail (reverse left)
+  | otherwise   = BL len     bound (a:left) $! tail right
+
+toListBL :: BoundedList a -> [a]
+toListBL (BL _ _ left right) = left ++ reverse right
+
+fromListBL :: Int -> [a] -> BoundedList a
+fromListBL bound l = BL (length l) bound l []
+
+-- lenBL (BL len _ _ _) = len
+
+-- -----------------------------------------------------------------------------
+-- | Set the interactive evaluation context.
+--
+-- (setContext imports) sets the ic_imports field (which in turn
+-- determines what is in scope at the prompt) to 'imports', and
+-- constructs the ic_rn_glb_env environment to reflect it.
+--
+-- We retain in scope all the things defined at the prompt, and kept
+-- in ic_tythings.  (Indeed, they shadow stuff from ic_imports.)
+
+setContext :: GhcMonad m => [InteractiveImport] -> m ()
+setContext imports
+  = do { hsc_env <- getSession
+       ; let dflags = hsc_dflags hsc_env
+       ; all_env_err <- liftIO $ findGlobalRdrEnv hsc_env imports
+       ; case all_env_err of
+           Left (mod, err) ->
+               liftIO $ throwGhcExceptionIO (formatError dflags mod err)
+           Right all_env -> do {
+       ; let old_ic         = hsc_IC hsc_env
+             !final_rdr_env = all_env `icExtendGblRdrEnv` ic_tythings old_ic
+       ; setSession
+         hsc_env{ hsc_IC = old_ic { ic_imports    = imports
+                                  , ic_rn_gbl_env = final_rdr_env }}}}
+  where
+    formatError dflags mod err = ProgramError . showSDoc dflags $
+      text "Cannot add module" <+> ppr mod <+>
+      text "to context:" <+> text err
+
+findGlobalRdrEnv :: HscEnv -> [InteractiveImport]
+                 -> IO (Either (ModuleName, String) GlobalRdrEnv)
+-- Compute the GlobalRdrEnv for the interactive context
+findGlobalRdrEnv hsc_env imports
+  = do { idecls_env <- hscRnImportDecls hsc_env idecls
+                    -- This call also loads any orphan modules
+       ; return $ case partitionEithers (map mkEnv imods) of
+           ([], imods_env) -> Right (foldr plusGlobalRdrEnv idecls_env imods_env)
+           (err : _, _)    -> Left err }
+  where
+    idecls :: [LImportDecl GhcPs]
+    idecls = [noLoc d | IIDecl d <- imports]
+
+    imods :: [ModuleName]
+    imods = [m | IIModule m <- imports]
+
+    mkEnv mod = case mkTopLevEnv (hsc_HPT hsc_env) mod of
+      Left err -> Left (mod, err)
+      Right env -> Right env
+
+availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv
+availsToGlobalRdrEnv mod_name avails
+  = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)
+  where
+      -- We're building a GlobalRdrEnv as if the user imported
+      -- all the specified modules into the global interactive module
+    imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}
+    decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,
+                         is_qual = False,
+                         is_dloc = srcLocSpan interactiveSrcLoc }
+
+mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv
+mkTopLevEnv hpt modl
+  = case lookupHpt hpt modl of
+      Nothing -> Left "not a home module"
+      Just details ->
+         case mi_globals (hm_iface details) of
+                Nothing  -> Left "not interpreted"
+                Just env -> Right env
+
+-- | Get the interactive evaluation context, consisting of a pair of the
+-- set of modules from which we take the full top-level scope, and the set
+-- of modules from which we take just the exports respectively.
+getContext :: GhcMonad m => m [InteractiveImport]
+getContext = withSession $ \HscEnv{ hsc_IC=ic } ->
+             return (ic_imports ic)
+
+-- | Returns @True@ if the specified module is interpreted, and hence has
+-- its full top-level scope available.
+moduleIsInterpreted :: GhcMonad m => Module -> m Bool
+moduleIsInterpreted modl = withSession $ \h ->
+ if moduleUnitId modl /= thisPackage (hsc_dflags h)
+        then return False
+        else case lookupHpt (hsc_HPT h) (moduleName modl) of
+                Just details       -> return (isJust (mi_globals (hm_iface details)))
+                _not_a_home_module -> return False
+
+-- | Looks up an identifier in the current interactive context (for :info)
+-- Filter the instances by the ones whose tycons (or clases resp)
+-- are in scope (qualified or otherwise).  Otherwise we list a whole lot too many!
+-- The exact choice of which ones to show, and which to hide, is a judgement call.
+--      (see Trac #1581)
+getInfo :: GhcMonad m => Bool -> Name
+        -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst], SDoc))
+getInfo allInfo name
+  = withSession $ \hsc_env ->
+    do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name
+       case mb_stuff of
+         Nothing -> return Nothing
+         Just (thing, fixity, cls_insts, fam_insts, docs) -> do
+           let rdr_env = ic_rn_gbl_env (hsc_IC hsc_env)
+
+           -- Filter the instances based on whether the constituent names of their
+           -- instance heads are all in scope.
+           let cls_insts' = filter (plausible rdr_env . orphNamesOfClsInst) cls_insts
+               fam_insts' = filter (plausible rdr_env . orphNamesOfFamInst) fam_insts
+           return (Just (thing, fixity, cls_insts', fam_insts', docs))
+  where
+    plausible rdr_env names
+          -- Dfun involving only names that are in ic_rn_glb_env
+        = allInfo
+       || nameSetAll ok names
+        where   -- A name is ok if it's in the rdr_env,
+                -- whether qualified or not
+          ok n | n == name              = True
+                       -- The one we looked for in the first place!
+               | pretendNameIsInScope n = True
+               | isBuiltInSyntax n      = True
+               | isCTupleTyConName n    = True
+               | isExternalName n       = isJust (lookupGRE_Name rdr_env n)
+               | otherwise              = True
+
+-- | Returns all names in scope in the current interactive context
+getNamesInScope :: GhcMonad m => m [Name]
+getNamesInScope = withSession $ \hsc_env -> do
+  return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))
+
+-- | Returns all 'RdrName's in scope in the current interactive
+-- context, excluding any that are internally-generated.
+getRdrNamesInScope :: GhcMonad m => m [RdrName]
+getRdrNamesInScope = withSession $ \hsc_env -> do
+  let
+      ic = hsc_IC hsc_env
+      gbl_rdrenv = ic_rn_gbl_env ic
+      gbl_names = concatMap greRdrNames $ globalRdrEnvElts gbl_rdrenv
+  -- Exclude internally generated names; see e.g. Trac #11328
+  return (filter (not . isDerivedOccName . rdrNameOcc) gbl_names)
+
+
+-- | Parses a string as an identifier, and returns the list of 'Name's that
+-- the identifier can refer to in the current interactive context.
+parseName :: GhcMonad m => String -> m [Name]
+parseName str = withSession $ \hsc_env -> liftIO $
+   do { lrdr_name <- hscParseIdentifier hsc_env str
+      ; hscTcRnLookupRdrName hsc_env lrdr_name }
+
+-- | Returns @True@ if passed string is a statement.
+isStmt :: DynFlags -> String -> Bool
+isStmt dflags stmt =
+  case parseThing Parser.parseStmt dflags stmt of
+    Lexer.POk _ _ -> True
+    Lexer.PFailed _ _ _ -> False
+
+-- | Returns @True@ if passed string has an import declaration.
+hasImport :: DynFlags -> String -> Bool
+hasImport dflags stmt =
+  case parseThing Parser.parseModule dflags stmt of
+    Lexer.POk _ thing -> hasImports thing
+    Lexer.PFailed _ _ _ -> False
+  where
+    hasImports = not . null . hsmodImports . unLoc
+
+-- | Returns @True@ if passed string is an import declaration.
+isImport :: DynFlags -> String -> Bool
+isImport dflags stmt =
+  case parseThing Parser.parseImport dflags stmt of
+    Lexer.POk _ _ -> True
+    Lexer.PFailed _ _ _ -> False
+
+-- | Returns @True@ if passed string is a declaration but __/not a splice/__.
+isDecl :: DynFlags -> String -> Bool
+isDecl dflags stmt = do
+  case parseThing Parser.parseDeclaration dflags stmt of
+    Lexer.POk _ thing ->
+      case unLoc thing of
+        SpliceD _ _ -> False
+        _ -> True
+    Lexer.PFailed _ _ _ -> False
+
+parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing
+parseThing parser dflags stmt = do
+  let buf = stringToStringBuffer stmt
+      loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
+
+  Lexer.unP parser (Lexer.mkPState dflags buf loc)
+
+getDocs :: GhcMonad m
+        => Name
+        -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString))
+           -- TODO: What about docs for constructors etc.?
+getDocs name =
+  withSession $ \hsc_env -> do
+     case nameModule_maybe name of
+       Nothing -> pure (Left (NameHasNoModule name))
+       Just mod -> do
+         if isInteractiveModule mod
+           then pure (Left InteractiveName)
+           else do
+             ModIface { mi_doc_hdr = mb_doc_hdr
+                      , mi_decl_docs = DeclDocMap dmap
+                      , mi_arg_docs = ArgDocMap amap
+                      } <- liftIO $ hscGetModuleInterface hsc_env mod
+             if isNothing mb_doc_hdr && Map.null dmap && Map.null amap
+               then pure (Left (NoDocsInIface mod compiled))
+               else pure (Right ( Map.lookup name dmap
+                                , Map.findWithDefault Map.empty name amap))
+  where
+    compiled =
+      -- TODO: Find a more direct indicator.
+      case nameSrcLoc name of
+        RealSrcLoc {} -> False
+        UnhelpfulLoc {} -> True
+
+-- | Failure modes for 'getDocs'.
+
+-- TODO: Find a way to differentiate between modules loaded without '-haddock'
+-- and modules that contain no docs.
+data GetDocsFailure
+
+    -- | 'nameModule_maybe' returned 'Nothing'.
+  = NameHasNoModule Name
+
+    -- | This is probably because the module was loaded without @-haddock@,
+    -- but it's also possible that the entire module contains no documentation.
+  | NoDocsInIface
+      Module
+      Bool -- ^ 'True': The module was compiled.
+           -- 'False': The module was :loaded.
+
+    -- | The 'Name' was defined interactively.
+  | InteractiveName
+
+instance Outputable GetDocsFailure where
+  ppr (NameHasNoModule name) =
+    quotes (ppr name) <+> text "has no module where we could look for docs."
+  ppr (NoDocsInIface mod compiled) = vcat
+    [ text "Can't find any documentation for" <+> ppr mod <> char '.'
+    , text "This is probably because the module was"
+        <+> text (if compiled then "compiled" else "loaded")
+        <+> text "without '-haddock',"
+    , text "but it's also possible that the module contains no documentation."
+    , text ""
+    , if compiled
+        then text "Try re-compiling with '-haddock'."
+        else text "Try running ':set -haddock' and :load the file again."
+        -- TODO: Figure out why :reload doesn't load the docs and maybe fix it.
+    ]
+  ppr InteractiveName =
+    text "Docs are unavailable for interactive declarations."
+
+-- -----------------------------------------------------------------------------
+-- Getting the type of an expression
+
+-- | Get the type of an expression
+-- Returns the type as described by 'TcRnExprMode'
+exprType :: GhcMonad m => TcRnExprMode -> String -> m Type
+exprType mode expr = withSession $ \hsc_env -> do
+   ty <- liftIO $ hscTcExpr hsc_env mode expr
+   return $ tidyType emptyTidyEnv ty
+
+-- -----------------------------------------------------------------------------
+-- Getting the kind of a type
+
+-- | Get the kind of a  type
+typeKind  :: GhcMonad m => Bool -> String -> m (Type, Kind)
+typeKind normalise str = withSession $ \hsc_env -> do
+   liftIO $ hscKcType hsc_env normalise str
+
+-----------------------------------------------------------------------------
+-- Compile an expression, run it, and deliver the result
+
+-- | Parse an expression, the parsed expression can be further processed and
+-- passed to compileParsedExpr.
+parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs)
+parseExpr expr = withSession $ \hsc_env -> do
+  liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr
+
+-- | Compile an expression, run it, and deliver the resulting HValue.
+compileExpr :: GhcMonad m => String -> m HValue
+compileExpr expr = do
+  parsed_expr <- parseExpr expr
+  compileParsedExpr parsed_expr
+
+-- | Compile an expression, run it, and deliver the resulting HValue.
+compileExprRemote :: GhcMonad m => String -> m ForeignHValue
+compileExprRemote expr = do
+  parsed_expr <- parseExpr expr
+  compileParsedExprRemote parsed_expr
+
+-- | Compile a parsed expression (before renaming), run it, and deliver
+-- the resulting HValue.
+compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue
+compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do
+  -- > let _compileParsedExpr = expr
+  -- Create let stmt from expr to make hscParsedStmt happy.
+  -- We will ignore the returned [Id], namely [expr_id], and not really
+  -- create a new binding.
+  let expr_fs = fsLit "_compileParsedExpr"
+      expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc
+      let_stmt = L loc . LetStmt noExt . L loc . (HsValBinds noExt) $
+        ValBinds noExt
+                     (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []
+
+  pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt
+  let (hvals_io, fix_env) = case pstmt of
+        Just ([_id], hvals_io', fix_env') -> (hvals_io', fix_env')
+        _ -> panic "compileParsedExprRemote"
+
+  updateFixityEnv fix_env
+  status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io)
+  case status of
+    EvalComplete _ (EvalSuccess [hval]) -> return hval
+    EvalComplete _ (EvalException e) ->
+      liftIO $ throwIO (fromSerializableException e)
+    _ -> panic "compileParsedExpr"
+
+compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue
+compileParsedExpr expr = do
+   fhv <- compileParsedExprRemote expr
+   dflags <- getDynFlags
+   liftIO $ wormhole dflags fhv
+
+-- | Compile an expression, run it and return the result as a Dynamic.
+dynCompileExpr :: GhcMonad m => String -> m Dynamic
+dynCompileExpr expr = do
+  parsed_expr <- parseExpr expr
+  -- > Data.Dynamic.toDyn expr
+  let loc = getLoc parsed_expr
+      to_dyn_expr = mkHsApp (L loc . HsVar noExt . L loc $ getRdrName toDynName)
+                            parsed_expr
+  hval <- compileParsedExpr to_dyn_expr
+  return (unsafeCoerce# hval :: Dynamic)
+
+-----------------------------------------------------------------------------
+-- show a module and it's source/object filenames
+
+showModule :: GhcMonad m => ModSummary -> m String
+showModule mod_summary =
+    withSession $ \hsc_env -> do
+        interpreted <- moduleIsBootOrNotObjectLinkable mod_summary
+        let dflags = hsc_dflags hsc_env
+        return (showModMsg dflags (hscTarget dflags) interpreted mod_summary)
+
+moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool
+moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
+  case lookupHpt (hsc_HPT hsc_env) (ms_mod_name mod_summary) of
+        Nothing       -> panic "missing linkable"
+        Just mod_info -> return $ case hm_linkable mod_info of
+          Nothing       -> True
+          Just linkable -> not (isObjectLinkable linkable)
+
+----------------------------------------------------------------------------
+-- RTTI primitives
+
+obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
+obtainTermFromVal hsc_env bound force ty x
+  | gopt Opt_ExternalInterpreter (hsc_dflags hsc_env)
+  = throwIO (InstallationError
+      "this operation requires -fno-external-interpreter")
+  | otherwise
+  = cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
+
+obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
+obtainTermFromId hsc_env bound force id =  do
+  hv <- Linker.getHValue hsc_env (varName id)
+  cvObtainTerm hsc_env bound force (idType id) hv
+
+-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
+reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
+reconstructType hsc_env bound id = do
+  hv <- Linker.getHValue hsc_env (varName id)
+  cvReconstructType hsc_env bound (idType id) hv
+
+mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
+mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/PprTyThing.hs
@@ -0,0 +1,206 @@
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing TyThings
+--
+-- (c) The GHC Team 2005
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP #-}
+module PprTyThing (
+        pprTyThing,
+        pprTyThingInContext,
+        pprTyThingLoc,
+        pprTyThingInContextLoc,
+        pprTyThingHdr,
+        pprTypeForUser,
+        pprFamInst
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Type    ( ArgFlag(..), TyThing(..), mkTyVarBinders, pprUserForAll )
+import IfaceSyn ( ShowSub(..), ShowHowMuch(..), AltPpr(..)
+  , showToHeader, pprIfaceDecl )
+import CoAxiom ( coAxiomTyCon )
+import HscTypes( tyThingParent_maybe )
+import MkIface ( tyThingToIfaceDecl )
+import Type ( tidyOpenType )
+import FamInstEnv( FamInst(..), FamFlavor(..) )
+import Type( Type, pprTypeApp, pprSigmaType )
+import Name
+import VarEnv( emptyTidyEnv )
+import Outputable
+
+-- -----------------------------------------------------------------------------
+-- Pretty-printing entities that we get from the GHC API
+
+{- Note [Pretty printing via IfaceSyn]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Our general plan for prett-printing
+  - Types
+  - TyCons
+  - Classes
+  - Pattern synonyms
+  ...etc...
+
+is to convert them to IfaceSyn, and pretty-print that. For example
+  - pprType converts a Type to an IfaceType, and pretty prints that.
+  - pprTyThing converts the TyThing to an IfaceDecl,
+    and pretty prints that.
+
+So IfaceSyn play a dual role:
+  - it's the internal version of an interface files
+  - it's used for pretty-printing
+
+Why do this?
+
+* A significant reason is that we need to be able
+  to pretty-print IfaceSyn (to display Foo.hi), and it was a
+  pain to duplicate masses of pretty-printing goop, esp for
+  Type and IfaceType.
+
+* When pretty-printing (a type, say), we want to tidy (with
+  tidyType) to avoids having (forall a a. blah) where the two
+  a's have different uniques.
+
+  Alas, for type constructors, TyCon, tidying does not work well,
+  because a TyCon includes DataCons which include Types, which mention
+  TyCons. And tidying can't tidy a mutually recursive data structure
+  graph, only trees.
+
+* Interface files contains fast-strings, not uniques, so the very same
+  tidying must take place when we convert to IfaceDecl. E.g.
+  MkIface.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,
+  Class etc) to an IfaceDecl.
+
+  Bottom line: IfaceDecls are already 'tidy', so it's straightforward
+  to print them.
+
+* An alternative I once explored was to ensure that TyCons get type
+  variables with distinct print-names. That's ok for type variables
+  but less easy for kind variables. Processing data type declarations
+  is already so complicated that I don't think it's sensible to add
+  the extra requirement that it generates only "pretty" types and
+  kinds.
+
+Consequences:
+
+- IfaceSyn (and IfaceType) must contain enough information to
+  print nicely.  Hence, for example, the IfaceAppArgs type, which
+  allows us to suppress invisible kind arguments in types
+  (see Note [Suppressing invisible arguments] in IfaceType)
+
+- In a few places we have info that is used only for pretty-printing,
+  and is totally ignored when turning IfaceSyn back into TyCons
+  etc (in TcIface). For example, IfaceClosedSynFamilyTyCon
+  stores a [IfaceAxBranch] that is used only for pretty-printing.
+
+- See Note [Free tyvars in IfaceType] in IfaceType
+
+See #7730, #8776 for details   -}
+
+--------------------
+-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location.
+pprFamInst :: FamInst -> SDoc
+--  * For data instances we go via pprTyThing of the representational TyCon,
+--    because there is already much cleverness associated with printing
+--    data type declarations that I don't want to duplicate
+--  * For type instances we print directly here; there is no TyCon
+--    to give to pprTyThing
+--
+-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes
+
+pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc })
+  = pprTyThingInContextLoc (ATyCon rep_tc)
+
+pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom
+                    , fi_tvs = tvs, fi_tys = lhs_tys, fi_rhs = rhs })
+  = showWithLoc (pprDefinedAt (getName axiom)) $
+    hang (text "type instance"
+            <+> pprUserForAll (mkTyVarBinders Specified tvs)
+                -- See Note [Printing foralls in type family instances]
+                -- in IfaceType
+            <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)
+       2 (equals <+> ppr rhs)
+
+----------------------------
+-- | Pretty-prints a 'TyThing' with its defining location.
+pprTyThingLoc :: TyThing -> SDoc
+pprTyThingLoc tyThing
+  = showWithLoc (pprDefinedAt (getName tyThing))
+                (pprTyThing showToHeader tyThing)
+
+-- | Pretty-prints the 'TyThing' header. For functions and data constructors
+-- the function is equivalent to 'pprTyThing' but for type constructors
+-- and classes it prints only the header part of the declaration.
+pprTyThingHdr :: TyThing -> SDoc
+pprTyThingHdr = pprTyThing showToHeader
+
+-- | Pretty-prints a 'TyThing' in context: that is, if the entity
+-- is a data constructor, record selector, or class method, then
+-- the entity's parent declaration is pretty-printed with irrelevant
+-- parts omitted.
+pprTyThingInContext :: ShowSub -> TyThing -> SDoc
+pprTyThingInContext show_sub thing
+  = go [] thing
+  where
+    go ss thing
+      = case tyThingParent_maybe thing of
+          Just parent ->
+            go (getOccName thing : ss) parent
+          Nothing ->
+            pprTyThing
+              (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) })
+              thing
+
+-- | Like 'pprTyThingInContext', but adds the defining location.
+pprTyThingInContextLoc :: TyThing -> SDoc
+pprTyThingInContextLoc tyThing
+  = showWithLoc (pprDefinedAt (getName tyThing))
+                (pprTyThingInContext showToHeader tyThing)
+
+-- | Pretty-prints a 'TyThing'.
+pprTyThing :: ShowSub -> TyThing -> SDoc
+-- We pretty-print 'TyThing' via 'IfaceDecl'
+-- See Note [Pretty-printing TyThings]
+pprTyThing ss ty_thing
+  = pprIfaceDecl ss' (tyThingToIfaceDecl ty_thing)
+  where
+    ss' = case ss_how_much ss of
+      ShowHeader (AltPpr Nothing)  -> ss { ss_how_much = ShowHeader ppr' }
+      ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' }
+      _                   -> ss
+
+    ppr' = AltPpr $ ppr_bndr $ getName ty_thing
+
+    ppr_bndr :: Name -> Maybe (OccName -> SDoc)
+    ppr_bndr name
+      | isBuiltInSyntax name
+         = Nothing
+      | otherwise
+         = case nameModule_maybe name of
+             Just mod -> Just $ \occ -> getPprStyle $ \sty ->
+               pprModulePrefix sty mod occ <> ppr occ
+             Nothing  -> WARN( True, ppr name ) Nothing
+             -- Nothing is unexpected here; TyThings have External names
+
+pprTypeForUser :: Type -> SDoc
+-- The type is tidied
+pprTypeForUser ty
+  = pprSigmaType tidy_ty
+  where
+    (_, tidy_ty)     = tidyOpenType emptyTidyEnv ty
+     -- Often the types/kinds we print in ghci are fully generalised
+     -- and have no free variables, but it turns out that we sometimes
+     -- print un-generalised kinds (eg when doing :k T), so it's
+     -- better to use tidyOpenType here
+
+showWithLoc :: SDoc -> SDoc -> SDoc
+showWithLoc loc doc
+    = hang doc 2 (char '\t' <> comment <+> loc)
+                -- The tab tries to make them line up a bit
+  where
+    comment = text "--"
diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/StaticPtrTable.hs
@@ -0,0 +1,292 @@
+-- | Code generation for the Static Pointer Table
+--
+-- (c) 2014 I/O Tweag
+--
+-- Each module that uses 'static' keyword declares an initialization function of
+-- the form hs_spt_init_<module>() which is emitted into the _stub.c file and
+-- annotated with __attribute__((constructor)) so that it gets executed at
+-- startup time.
+--
+-- The function's purpose is to call hs_spt_insert to insert the static
+-- pointers of this module in the hashtable of the RTS, and it looks something
+-- like this:
+--
+-- > static void hs_hpc_init_Main(void) __attribute__((constructor));
+-- > static void hs_hpc_init_Main(void) {
+-- >
+-- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
+-- >   extern StgPtr Main_r2wb_closure;
+-- >   hs_spt_insert(k0, &Main_r2wb_closure);
+-- >
+-- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
+-- >   extern StgPtr Main_r2wc_closure;
+-- >   hs_spt_insert(k1, &Main_r2wc_closure);
+-- >
+-- > }
+--
+-- where the constants are fingerprints produced from the static forms.
+--
+-- The linker must find the definitions matching the @extern StgPtr <name>@
+-- declarations. For this to work, the identifiers of static pointers need to be
+-- exported. This is done in SetLevels.newLvlVar.
+--
+-- There is also a finalization function for the time when the module is
+-- unloaded.
+--
+-- > static void hs_hpc_fini_Main(void) __attribute__((destructor));
+-- > static void hs_hpc_fini_Main(void) {
+-- >
+-- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
+-- >   hs_spt_remove(k0);
+-- >
+-- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
+-- >   hs_spt_remove(k1);
+-- >
+-- > }
+--
+
+{-# LANGUAGE ViewPatterns, TupleSections #-}
+module StaticPtrTable
+    ( sptCreateStaticBinds
+    , sptModuleInitCode
+    ) where
+
+{- Note [Grand plan for static forms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Static forms go through the compilation phases as follows.
+Here is a running example:
+
+   f x = let k = map toUpper
+         in ...(static k)...
+
+* The renamer looks for out-of-scope names in the body of the static
+  form, as always. If all names are in scope, the free variables of the
+  body are stored in AST at the location of the static form.
+
+* The typechecker verifies that all free variables occurring in the
+  static form are floatable to top level (see Note [Meaning of
+  IdBindingInfo] in TcRnTypes).  In our example, 'k' is floatable.
+  Even though it is bound in a nested let, we are fine.
+
+* The desugarer replaces the static form with an application of the
+  function 'makeStatic' (defined in module GHC.StaticPtr.Internal of
+  base).  So we get
+
+   f x = let k = map toUpper
+         in ...fromStaticPtr (makeStatic location k)...
+
+* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic'
+  to the top level. Thus the FloatOut pass is always executed, even when
+  optimizations are disabled.  So we get
+
+   k = map toUpper
+   static_ptr = makeStatic location k
+   f x = ...fromStaticPtr static_ptr...
+
+  The FloatOut pass is careful to produce an /exported/ Id for a floated
+  'makeStatic' call, so the binding is not removed or inlined by the
+  simplifier.
+  E.g. the code for `f` above might look like
+
+    static_ptr = makeStatic location k
+    f x = ...(case static_ptr of ...)...
+
+  which might be simplified to
+
+    f x = ...(case makeStatic location k of ...)...
+
+  BUT the top-level binding for static_ptr must remain, so that it can be
+  collected to populate the Static Pointer Table.
+
+  Making the binding exported also has a necessary effect during the
+  CoreTidy pass.
+
+* The CoreTidy pass replaces all bindings of the form
+
+  b = /\ ... -> makeStatic location value
+
+  with
+
+  b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value
+
+  where a distinct key is generated for each binding.
+
+* If we are compiling to object code we insert a C stub (generated by
+  sptModuleInitCode) into the final object which runs when the module is loaded,
+  inserting the static forms defined by the module into the RTS's static pointer
+  table.
+
+* If we are compiling for the byte-code interpreter, we instead explicitly add
+  the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter
+  process' SPT table using the addSptEntry interpreter message. This happens
+  in upsweep after we have compiled the module (see GhcMake.upsweep').
+-}
+
+import GhcPrelude
+
+import CLabel
+import CoreSyn
+import CoreUtils (collectMakeStaticArgs)
+import DataCon
+import DynFlags
+import HscTypes
+import Id
+import MkCore (mkStringExprFSWith)
+import Module
+import Name
+import Outputable
+import Platform
+import PrelNames
+import TcEnv (lookupGlobal)
+import Type
+
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.State
+import Data.List
+import Data.Maybe
+import GHC.Fingerprint
+import qualified GHC.LanguageExtensions as LangExt
+
+-- | Replaces all bindings of the form
+--
+-- > b = /\ ... -> makeStatic location value
+--
+--  with
+--
+-- > b = /\ ... ->
+-- >   StaticPtr key (StaticPtrInfo "pkg key" "module" location) value
+--
+--  where a distinct key is generated for each binding.
+--
+-- It also yields the C stub that inserts these bindings into the static
+-- pointer table.
+sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram
+                     -> IO ([SptEntry], CoreProgram)
+sptCreateStaticBinds hsc_env this_mod binds
+    | not (xopt LangExt.StaticPointers dflags) =
+      return ([], binds)
+    | otherwise = do
+      -- Make sure the required interface files are loaded.
+      _ <- lookupGlobal hsc_env unpackCStringName
+      (fps, binds') <- evalStateT (go [] [] binds) 0
+      return (fps, binds')
+  where
+    go fps bs xs = case xs of
+      []        -> return (reverse fps, reverse bs)
+      bnd : xs' -> do
+        (fps', bnd') <- replaceStaticBind bnd
+        go (reverse fps' ++ fps) (bnd' : bs) xs'
+
+    dflags = hsc_dflags hsc_env
+
+    -- Generates keys and replaces 'makeStatic' with 'StaticPtr'.
+    --
+    -- The 'Int' state is used to produce a different key for each binding.
+    replaceStaticBind :: CoreBind
+                      -> StateT Int IO ([SptEntry], CoreBind)
+    replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e
+                                        return (maybeToList mfp, NonRec b' e')
+    replaceStaticBind (Rec rbs) = do
+      (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs
+      return (catMaybes mfps, Rec rbs')
+
+    replaceStatic :: Id -> CoreExpr
+                  -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr))
+    replaceStatic b e@(collectTyBinders -> (tvs, e0)) =
+      case collectMakeStaticArgs e0 of
+        Nothing      -> return (Nothing, (b, e))
+        Just (_, t, info, arg) -> do
+          (fp, e') <- mkStaticBind t info arg
+          return (Just (SptEntry b fp), (b, foldr Lam e' tvs))
+
+    mkStaticBind :: Type -> CoreExpr -> CoreExpr
+                 -> StateT Int IO (Fingerprint, CoreExpr)
+    mkStaticBind t srcLoc e = do
+      i <- get
+      put (i + 1)
+      staticPtrInfoDataCon <-
+        lift $ lookupDataConHscEnv staticPtrInfoDataConName
+      let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i
+      info <- mkConApp staticPtrInfoDataCon <$>
+            (++[srcLoc]) <$>
+            mapM (mkStringExprFSWith (lift . lookupIdHscEnv))
+                 [ unitIdFS $ moduleUnitId this_mod
+                 , moduleNameFS $ moduleName this_mod
+                 ]
+
+      -- The module interface of GHC.StaticPtr should be loaded at least
+      -- when looking up 'fromStatic' during type-checking.
+      staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName
+      return (fp, mkConApp staticPtrDataCon
+                               [ Type t
+                               , mkWord64LitWordRep dflags w0
+                               , mkWord64LitWordRep dflags w1
+                               , info
+                               , e ])
+
+    mkStaticPtrFingerprint :: Int -> Fingerprint
+    mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"
+        [ unitIdString $ moduleUnitId this_mod
+        , moduleNameString $ moduleName this_mod
+        , show n
+        ]
+
+    -- Choose either 'Word64#' or 'Word#' to represent the arguments of the
+    -- 'Fingerprint' data constructor.
+    mkWord64LitWordRep dflags
+      | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64
+      | otherwise = mkWordLit dflags . toInteger
+
+    lookupIdHscEnv :: Name -> IO Id
+    lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>=
+                         maybe (getError n) (return . tyThingId)
+
+    lookupDataConHscEnv :: Name -> IO DataCon
+    lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>=
+                              maybe (getError n) (return . tyThingDataCon)
+
+    getError n = pprPanic "sptCreateStaticBinds.get: not found" $
+      text "Couldn't find" <+> ppr n
+
+-- | @sptModuleInitCode module fps@ is a C stub to insert the static entries
+-- of @module@ into the static pointer table.
+--
+-- @fps@ is a list associating each binding corresponding to a static entry with
+-- its fingerprint.
+sptModuleInitCode :: Module -> [SptEntry] -> SDoc
+sptModuleInitCode _ [] = Outputable.empty
+sptModuleInitCode this_mod entries = vcat
+    [ text "static void hs_spt_init_" <> ppr this_mod
+           <> text "(void) __attribute__((constructor));"
+    , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"
+    , braces $ vcat $
+        [  text "static StgWord64 k" <> int i <> text "[2] = "
+           <> pprFingerprint fp <> semi
+        $$ text "extern StgPtr "
+           <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
+        $$ text "hs_spt_insert" <> parens
+             (hcat $ punctuate comma
+                [ char 'k' <> int i
+                , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n))
+                ]
+             )
+        <> semi
+        |  (i, SptEntry n fp) <- zip [0..] entries
+        ]
+    , text "static void hs_spt_fini_" <> ppr this_mod
+           <> text "(void) __attribute__((destructor));"
+    , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"
+    , braces $ vcat $
+        [  text "StgWord64 k" <> int i <> text "[2] = "
+           <> pprFingerprint fp <> semi
+        $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
+        | (i, (SptEntry _ fp)) <- zip [0..] entries
+        ]
+    ]
+  where
+    pprFingerprint :: Fingerprint -> SDoc
+    pprFingerprint (Fingerprint w1 w2) =
+      braces $ hcat $ punctuate comma
+                 [ integer (fromIntegral w1) <> text "ULL"
+                 , integer (fromIntegral w2) <> text "ULL"
+                 ]
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/SysTools.hs
@@ -0,0 +1,634 @@
+{-
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2001-2003
+--
+-- Access to system tools: gcc, cp, rm etc
+--
+-----------------------------------------------------------------------------
+-}
+
+{-# LANGUAGE CPP, MultiWayIf, ScopedTypeVariables #-}
+
+module SysTools (
+        -- * Initialisation
+        initSysTools,
+        initLlvmConfig,
+
+        -- * Interface to system tools
+        module SysTools.Tasks,
+        module SysTools.Info,
+
+        linkDynLib,
+
+        copy,
+        copyWithHeader,
+
+        -- * General utilities
+        Option(..),
+        expandTopDir,
+
+        -- * Platform-specifics
+        libmLinkOpts,
+
+        -- * Mac OS X frameworks
+        getPkgFrameworkOpts,
+        getFrameworkOpts
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Module
+import Packages
+import Config
+import Outputable
+import ErrUtils
+import Platform
+import Util
+import DynFlags
+import Fingerprint
+
+import System.FilePath
+import System.IO
+import System.Directory
+import SysTools.ExtraObj
+import SysTools.Info
+import SysTools.Tasks
+import SysTools.BaseDir
+
+{-
+Note [How GHC finds toolchain utilities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+SysTools.initSysProgs figures out exactly where all the auxiliary programs
+are, and initialises mutable variables to make it easy to call them.
+To do this, it makes use of definitions in Config.hs, which is a Haskell
+file containing variables whose value is figured out by the build system.
+
+Config.hs contains two sorts of things
+
+  cGCC,         The *names* of the programs
+  cCPP            e.g.  cGCC = gcc
+  cUNLIT                cCPP = gcc -E
+  etc           They do *not* include paths
+
+
+  cUNLIT_DIR   The *path* to the directory containing unlit, split etc
+  cSPLIT_DIR   *relative* to the root of the build tree,
+                   for use when running *in-place* in a build tree (only)
+
+
+---------------------------------------------
+NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):
+
+Another hair-brained scheme for simplifying the current tool location
+nightmare in GHC: Simon originally suggested using another
+configuration file along the lines of GCC's specs file - which is fine
+except that it means adding code to read yet another configuration
+file.  What I didn't notice is that the current package.conf is
+general enough to do this:
+
+Package
+    {name = "tools",    import_dirs = [],  source_dirs = [],
+     library_dirs = [], hs_libraries = [], extra_libraries = [],
+     include_dirs = [], c_includes = [],   package_deps = [],
+     extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],
+     extra_cc_opts = [], extra_ld_opts = []}
+
+Which would have the advantage that we get to collect together in one
+place the path-specific package stuff with the path-specific tool
+stuff.
+                End of NOTES
+---------------------------------------------
+
+************************************************************************
+*                                                                      *
+\subsection{Initialisation}
+*                                                                      *
+************************************************************************
+-}
+
+initLlvmConfig :: String
+               -> IO LlvmConfig
+initLlvmConfig top_dir
+  = do
+      targets <- readAndParse "llvm-targets" mkLlvmTarget
+      passes <- readAndParse "llvm-passes" id
+      return (targets, passes)
+  where
+    readAndParse name builder =
+      do let llvmConfigFile = top_dir </> name
+         llvmConfigStr <- readFile llvmConfigFile
+         case maybeReadFuzzy llvmConfigStr of
+           Just s -> return (fmap builder <$> s)
+           Nothing -> pgmError ("Can't parse " ++ show llvmConfigFile)
+
+    mkLlvmTarget :: (String, String, String) -> LlvmTarget
+    mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs)
+
+
+initSysTools :: String          -- TopDir path
+             -> IO Settings     -- Set all the mutable variables above, holding
+                                --      (a) the system programs
+                                --      (b) the package-config file
+                                --      (c) the GHC usage message
+initSysTools top_dir
+  = do       -- see Note [topdir: How GHC finds its files]
+             -- NB: top_dir is assumed to be in standard Unix
+             -- format, '/' separated
+       mtool_dir <- findToolDir top_dir
+             -- see Note [tooldir: How GHC finds mingw and perl on Windows]
+
+       let installed :: FilePath -> FilePath
+           installed file = top_dir </> file
+           libexec :: FilePath -> FilePath
+           libexec file = top_dir </> "bin" </> file
+           settingsFile = installed "settings"
+           platformConstantsFile = installed "platformConstants"
+
+       settingsStr <- readFile settingsFile
+       platformConstantsStr <- readFile platformConstantsFile
+       mySettings <- case maybeReadFuzzy settingsStr of
+                     Just s ->
+                         return s
+                     Nothing ->
+                         pgmError ("Can't parse " ++ show settingsFile)
+       platformConstants <- case maybeReadFuzzy platformConstantsStr of
+                            Just s ->
+                                return s
+                            Nothing ->
+                                pgmError ("Can't parse " ++
+                                          show platformConstantsFile)
+       let getSetting key = case lookup key mySettings of
+                            Just xs -> return $ expandTopDir top_dir xs
+                            Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
+           getToolSetting key = expandToolDir mtool_dir <$> getSetting key
+           getBooleanSetting key = case lookup key mySettings of
+                                   Just "YES" -> return True
+                                   Just "NO" -> return False
+                                   Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs)
+                                   Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
+           readSetting key = case lookup key mySettings of
+                             Just xs ->
+                                 case maybeRead xs of
+                                 Just v -> return v
+                                 Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)
+                             Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)
+       crossCompiling <- getBooleanSetting "cross compiling"
+       targetArch <- readSetting "target arch"
+       targetOS <- readSetting "target os"
+       targetWordSize <- readSetting "target word size"
+       targetUnregisterised <- getBooleanSetting "Unregisterised"
+       targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"
+       targetHasIdentDirective <- readSetting "target has .ident directive"
+       targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"
+       myExtraGccViaCFlags <- getSetting "GCC extra via C opts"
+       -- On Windows, mingw is distributed with GHC,
+       -- so we look in TopDir/../mingw/bin,
+       -- as well as TopDir/../../mingw/bin for hadrian.
+       -- It would perhaps be nice to be able to override this
+       -- with the settings file, but it would be a little fiddly
+       -- to make that possible, so for now you can't.
+       gcc_prog <- getToolSetting "C compiler command"
+       gcc_args_str <- getSetting "C compiler flags"
+       gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"
+       cpp_prog <- getToolSetting "Haskell CPP command"
+       cpp_args_str <- getSetting "Haskell CPP flags"
+       let unreg_gcc_args = if targetUnregisterised
+                            then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]
+                            else []
+           -- TABLES_NEXT_TO_CODE affects the info table layout.
+           tntc_gcc_args
+            | mkTablesNextToCode targetUnregisterised
+               = ["-DTABLES_NEXT_TO_CODE"]
+            | otherwise = []
+           cpp_args= map Option (words cpp_args_str)
+           gcc_args = map Option (words gcc_args_str
+                               ++ unreg_gcc_args
+                               ++ tntc_gcc_args)
+       ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"
+       ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"
+       ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"
+       ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"
+       perl_path <- getToolSetting "perl command"
+
+       let pkgconfig_path = installed "package.conf.d"
+           ghc_usage_msg_path  = installed "ghc-usage.txt"
+           ghci_usage_msg_path = installed "ghci-usage.txt"
+
+             -- For all systems, unlit, split, mangle are GHC utilities
+             -- architecture-specific stuff is done when building Config.hs
+           unlit_path = libexec cGHC_UNLIT_PGM
+
+             -- split is a Perl script
+           split_script  = libexec cGHC_SPLIT_PGM
+
+       windres_path <- getToolSetting "windres command"
+       libtool_path <- getToolSetting "libtool command"
+       ar_path <- getToolSetting "ar command"
+       ranlib_path <- getToolSetting "ranlib command"
+
+       tmpdir <- getTemporaryDirectory
+
+       touch_path <- getToolSetting "touch command"
+
+       let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend
+           -- a call to Perl to get the invocation of split.
+           -- On Unix, scripts are invoked using the '#!' method.  Binary
+           -- installations of GHC on Unix place the correct line on the
+           -- front of the script at installation time, so we don't want
+           -- to wire-in our knowledge of $(PERL) on the host system here.
+           (split_prog,  split_args)
+             | isWindowsHost = (perl_path,    [Option split_script])
+             | otherwise     = (split_script, [])
+       mkdll_prog <- getToolSetting "dllwrap command"
+       let mkdll_args = []
+
+       -- cpp is derived from gcc on all platforms
+       -- HACK, see setPgmP below. We keep 'words' here to remember to fix
+       -- Config.hs one day.
+
+
+       -- Other things being equal, as and ld are simply gcc
+       gcc_link_args_str <- getSetting "C compiler link flags"
+       let   as_prog  = gcc_prog
+             as_args  = gcc_args
+             ld_prog  = gcc_prog
+             ld_args  = gcc_args ++ map Option (words gcc_link_args_str)
+
+       -- We just assume on command line
+       lc_prog <- getSetting "LLVM llc command"
+       lo_prog <- getSetting "LLVM opt command"
+       lcc_prog <- getSetting "LLVM clang command"
+
+       let iserv_prog = libexec "ghc-iserv"
+
+       let platform = Platform {
+                          platformArch = targetArch,
+                          platformOS   = targetOS,
+                          platformWordSize = targetWordSize,
+                          platformUnregisterised = targetUnregisterised,
+                          platformHasGnuNonexecStack = targetHasGnuNonexecStack,
+                          platformHasIdentDirective = targetHasIdentDirective,
+                          platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols,
+                          platformIsCrossCompiling = crossCompiling
+                      }
+
+       return $ Settings {
+                    sTargetPlatform = platform,
+                    sTmpDir         = normalise tmpdir,
+                    sGhcUsagePath   = ghc_usage_msg_path,
+                    sGhciUsagePath  = ghci_usage_msg_path,
+                    sToolDir        = mtool_dir,
+                    sTopDir         = top_dir,
+                    sRawSettings    = mySettings,
+                    sExtraGccViaCFlags = words myExtraGccViaCFlags,
+                    sSystemPackageConfig = pkgconfig_path,
+                    sLdSupportsCompactUnwind = ldSupportsCompactUnwind,
+                    sLdSupportsBuildId       = ldSupportsBuildId,
+                    sLdSupportsFilelist      = ldSupportsFilelist,
+                    sLdIsGnuLd               = ldIsGnuLd,
+                    sGccSupportsNoPie        = gccSupportsNoPie,
+                    sProgramName             = "ghc",
+                    sProjectVersion          = cProjectVersion,
+                    sPgm_L   = unlit_path,
+                    sPgm_P   = (cpp_prog, cpp_args),
+                    sPgm_F   = "",
+                    sPgm_c   = (gcc_prog, gcc_args),
+                    sPgm_s   = (split_prog,split_args),
+                    sPgm_a   = (as_prog, as_args),
+                    sPgm_l   = (ld_prog, ld_args),
+                    sPgm_dll = (mkdll_prog,mkdll_args),
+                    sPgm_T   = touch_path,
+                    sPgm_windres = windres_path,
+                    sPgm_libtool = libtool_path,
+                    sPgm_ar = ar_path,
+                    sPgm_ranlib = ranlib_path,
+                    sPgm_lo  = (lo_prog,[]),
+                    sPgm_lc  = (lc_prog,[]),
+                    sPgm_lcc = (lcc_prog,[]),
+                    sPgm_i   = iserv_prog,
+                    sOpt_L       = [],
+                    sOpt_P       = [],
+                    sOpt_P_fingerprint = fingerprint0,
+                    sOpt_F       = [],
+                    sOpt_c       = [],
+                    sOpt_a       = [],
+                    sOpt_l       = [],
+                    sOpt_windres = [],
+                    sOpt_lcc     = [],
+                    sOpt_lo      = [],
+                    sOpt_lc      = [],
+                    sOpt_i       = [],
+                    sPlatformConstants = platformConstants
+             }
+
+
+{- Note [Windows stack usage]
+
+See: Trac #8870 (and #8834 for related info) and #12186
+
+On Windows, occasionally we need to grow the stack. In order to do
+this, we would normally just bump the stack pointer - but there's a
+catch on Windows.
+
+If the stack pointer is bumped by more than a single page, then the
+pages between the initial pointer and the resulting location must be
+properly committed by the Windows virtual memory subsystem. This is
+only needed in the event we bump by more than one page (i.e 4097 bytes
+or more).
+
+Windows compilers solve this by emitting a call to a special function
+called _chkstk, which does this committing of the pages for you.
+
+The reason this was causing a segfault was because due to the fact the
+new code generator tends to generate larger functions, we needed more
+stack space in GHC itself. In the x86 codegen, we needed approximately
+~12kb of stack space in one go, which caused the process to segfault,
+as the intervening pages were not committed.
+
+GCC can emit such a check for us automatically but only when the flag
+-fstack-check is used.
+
+See https://gcc.gnu.org/onlinedocs/gnat_ugn/Stack-Overflow-Checking.html
+for more information.
+
+-}
+
+copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()
+copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to
+
+copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath
+               -> IO ()
+copyWithHeader dflags purpose maybe_header from to = do
+  showPass dflags purpose
+
+  hout <- openBinaryFile to   WriteMode
+  hin  <- openBinaryFile from ReadMode
+  ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up
+  maybe (return ()) (header hout) maybe_header
+  hPutStr hout ls
+  hClose hout
+  hClose hin
+ where
+  -- write the header string in UTF-8.  The header is something like
+  --   {-# LINE "foo.hs" #-}
+  -- and we want to make sure a Unicode filename isn't mangled.
+  header h str = do
+   hSetEncoding h utf8
+   hPutStr h str
+   hSetBinaryMode h True
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Support code}
+*                                                                      *
+************************************************************************
+-}
+
+linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()
+linkDynLib dflags0 o_files dep_packages
+ = do
+    let -- This is a rather ugly hack to fix dynamically linked
+        -- GHC on Windows. If GHC is linked with -threaded, then
+        -- it links against libHSrts_thr. But if base is linked
+        -- against libHSrts, then both end up getting loaded,
+        -- and things go wrong. We therefore link the libraries
+        -- with the same RTS flags that we link GHC with.
+        dflags1 = if cGhcThreaded then addWay' WayThreaded dflags0
+                                  else                     dflags0
+        dflags2 = if cGhcDebugged then addWay' WayDebug dflags1
+                                  else                  dflags1
+        dflags = updateWays dflags2
+
+        verbFlags = getVerbFlags dflags
+        o_file = outputFile dflags
+
+    pkgs <- getPreloadPackagesAnd dflags dep_packages
+
+    let pkg_lib_paths = collectLibraryPaths dflags pkgs
+    let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
+        get_pkg_lib_path_opts l
+         | ( osElfTarget (platformOS (targetPlatform dflags)) ||
+             osMachOTarget (platformOS (targetPlatform dflags)) ) &&
+           dynLibLoader dflags == SystemDependent &&
+           WayDyn `elem` ways dflags
+            = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]
+              -- See Note [-Xlinker -rpath vs -Wl,-rpath]
+         | otherwise = ["-L" ++ l]
+
+    let lib_paths = libraryPaths dflags
+    let lib_path_opts = map ("-L"++) lib_paths
+
+    -- We don't want to link our dynamic libs against the RTS package,
+    -- because the RTS lib comes in several flavours and we want to be
+    -- able to pick the flavour when a binary is linked.
+    -- On Windows we need to link the RTS import lib as Windows does
+    -- not allow undefined symbols.
+    -- The RTS library path is still added to the library search path
+    -- above in case the RTS is being explicitly linked in (see #3807).
+    let platform = targetPlatform dflags
+        os = platformOS platform
+        pkgs_no_rts = case os of
+                      OSMinGW32 ->
+                          pkgs
+                      _ ->
+                          filter ((/= rtsUnitId) . packageConfigId) pkgs
+    let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts
+                        in  package_hs_libs ++ extra_libs ++ other_flags
+
+        -- probably _stub.o files
+        -- and last temporary shared object file
+    let extra_ld_inputs = ldInputs dflags
+
+    -- frameworks
+    pkg_framework_opts <- getPkgFrameworkOpts dflags platform
+                                              (map unitId pkgs)
+    let framework_opts = getFrameworkOpts dflags platform
+
+    case os of
+        OSMinGW32 -> do
+            -------------------------------------------------------------
+            -- Making a DLL
+            -------------------------------------------------------------
+            let output_fn = case o_file of
+                            Just s -> s
+                            Nothing -> "HSdll.dll"
+
+            runLink dflags (
+                    map Option verbFlags
+                 ++ [ Option "-o"
+                    , FileOption "" output_fn
+                    , Option "-shared"
+                    ] ++
+                    [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
+                    | gopt Opt_SharedImplib dflags
+                    ]
+                 ++ map (FileOption "") o_files
+
+                 -- Permit the linker to auto link _symbol to _imp_symbol
+                 -- This lets us link against DLLs without needing an "import library"
+                 ++ [Option "-Wl,--enable-auto-import"]
+
+                 ++ extra_ld_inputs
+                 ++ map Option (
+                    lib_path_opts
+                 ++ pkg_lib_path_opts
+                 ++ pkg_link_opts
+                ))
+        _ | os == OSDarwin -> do
+            -------------------------------------------------------------------
+            -- Making a darwin dylib
+            -------------------------------------------------------------------
+            -- About the options used for Darwin:
+            -- -dynamiclib
+            --   Apple's way of saying -shared
+            -- -undefined dynamic_lookup:
+            --   Without these options, we'd have to specify the correct
+            --   dependencies for each of the dylibs. Note that we could
+            --   (and should) do without this for all libraries except
+            --   the RTS; all we need to do is to pass the correct
+            --   HSfoo_dyn.dylib files to the link command.
+            --   This feature requires Mac OS X 10.3 or later; there is
+            --   a similar feature, -flat_namespace -undefined suppress,
+            --   which works on earlier versions, but it has other
+            --   disadvantages.
+            -- -single_module
+            --   Build the dynamic library as a single "module", i.e. no
+            --   dynamic binding nonsense when referring to symbols from
+            --   within the library. The NCG assumes that this option is
+            --   specified (on i386, at least).
+            -- -install_name
+            --   Mac OS/X stores the path where a dynamic library is (to
+            --   be) installed in the library itself.  It's called the
+            --   "install name" of the library. Then any library or
+            --   executable that links against it before it's installed
+            --   will search for it in its ultimate install location.
+            --   By default we set the install name to the absolute path
+            --   at build time, but it can be overridden by the
+            --   -dylib-install-name option passed to ghc. Cabal does
+            --   this.
+            -------------------------------------------------------------------
+
+            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
+
+            instName <- case dylibInstallName dflags of
+                Just n -> return n
+                Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)
+            runLink dflags (
+                    map Option verbFlags
+                 ++ [ Option "-dynamiclib"
+                    , Option "-o"
+                    , FileOption "" output_fn
+                    ]
+                 ++ map Option o_files
+                 ++ [ Option "-undefined",
+                      Option "dynamic_lookup",
+                      Option "-single_module" ]
+                 ++ (if platformArch platform == ArchX86_64
+                     then [ ]
+                     else [ Option "-Wl,-read_only_relocs,suppress" ])
+                 ++ [ Option "-install_name", Option instName ]
+                 ++ map Option lib_path_opts
+                 ++ extra_ld_inputs
+                 ++ map Option framework_opts
+                 ++ map Option pkg_lib_path_opts
+                 ++ map Option pkg_link_opts
+                 ++ map Option pkg_framework_opts
+                 ++ [ Option "-Wl,-dead_strip_dylibs" ]
+              )
+        _ -> do
+            -------------------------------------------------------------------
+            -- Making a DSO
+            -------------------------------------------------------------------
+
+            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
+                unregisterised = platformUnregisterised (targetPlatform dflags)
+            let bsymbolicFlag = -- we need symbolic linking to resolve
+                                -- non-PIC intra-package-relocations for
+                                -- performance (where symbolic linking works)
+                                -- See Note [-Bsymbolic assumptions by GHC]
+                                ["-Wl,-Bsymbolic" | not unregisterised]
+
+            runLink dflags (
+                    map Option verbFlags
+                 ++ libmLinkOpts
+                 ++ [ Option "-o"
+                    , FileOption "" output_fn
+                    ]
+                 ++ map Option o_files
+                 ++ [ Option "-shared" ]
+                 ++ map Option bsymbolicFlag
+                    -- Set the library soname. We use -h rather than -soname as
+                    -- Solaris 10 doesn't support the latter:
+                 ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]
+                 ++ extra_ld_inputs
+                 ++ map Option lib_path_opts
+                 ++ map Option pkg_lib_path_opts
+                 ++ map Option pkg_link_opts
+              )
+
+-- | Some platforms require that we explicitly link against @libm@ if any
+-- math-y things are used (which we assume to include all programs). See #14022.
+libmLinkOpts :: [Option]
+libmLinkOpts =
+#if defined(HAVE_LIBM)
+  [Option "-lm"]
+#else
+  []
+#endif
+
+getPkgFrameworkOpts :: DynFlags -> Platform -> [InstalledUnitId] -> IO [String]
+getPkgFrameworkOpts dflags platform dep_packages
+  | platformUsesFrameworks platform = do
+    pkg_framework_path_opts <- do
+        pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
+        return $ map ("-F" ++) pkg_framework_paths
+
+    pkg_framework_opts <- do
+        pkg_frameworks <- getPackageFrameworks dflags dep_packages
+        return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]
+
+    return (pkg_framework_path_opts ++ pkg_framework_opts)
+
+  | otherwise = return []
+
+getFrameworkOpts :: DynFlags -> Platform -> [String]
+getFrameworkOpts dflags platform
+  | platformUsesFrameworks platform = framework_path_opts ++ framework_opts
+  | otherwise = []
+  where
+    framework_paths     = frameworkPaths dflags
+    framework_path_opts = map ("-F" ++) framework_paths
+
+    frameworks     = cmdlineFrameworks dflags
+    -- reverse because they're added in reverse order from the cmd line:
+    framework_opts = concat [ ["-framework", fw]
+                            | fw <- reverse frameworks ]
+
+{-
+Note [-Bsymbolic assumptions by GHC]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+GHC has a few assumptions about interaction of relocations in NCG and linker:
+
+1. -Bsymbolic resolves internal references when the shared library is linked,
+   which is important for performance.
+2. When there is a reference to data in a shared library from the main program,
+   the runtime linker relocates the data object into the main program using an
+   R_*_COPY relocation.
+3. If we used -Bsymbolic, then this results in multiple copies of the data
+   object, because some references have already been resolved to point to the
+   original instance. This is bad!
+
+We work around [3.] for native compiled code by avoiding the generation of
+R_*_COPY relocations.
+
+Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable
+-Bsymbolic linking there.
+
+See related Trac tickets: #4210, #15338
+-}
diff --git a/compiler/main/SysTools/ExtraObj.hs b/compiler/main/SysTools/ExtraObj.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/SysTools/ExtraObj.hs
@@ -0,0 +1,243 @@
+-----------------------------------------------------------------------------
+--
+-- GHC Extra object linking code
+--
+-- (c) The GHC Team 2017
+--
+-----------------------------------------------------------------------------
+
+module SysTools.ExtraObj (
+  mkExtraObj, mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary,
+  checkLinkInfo, getLinkInfo, getCompilerInfo,
+  ghcLinkInfoSectionName, ghcLinkInfoNoteName, platformSupportsSavingLinkOpts,
+  haveRtsOptsFlags
+) where
+
+import AsmUtils
+import ErrUtils
+import DynFlags
+import Packages
+import Platform
+import Outputable
+import SrcLoc           ( noSrcSpan )
+import Module
+import Elf
+import Util
+import GhcPrelude
+
+import Control.Monad
+import Data.Maybe
+
+import Control.Monad.IO.Class
+
+import FileCleanup
+import SysTools.Tasks
+import SysTools.Info
+
+mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath
+mkExtraObj dflags extn xs
+ = do cFile <- newTempName dflags TFL_CurrentModule extn
+      oFile <- newTempName dflags TFL_GhcSession "o"
+      writeFile cFile xs
+      ccInfo <- liftIO $ getCompilerInfo dflags
+      runCc dflags
+            ([Option        "-c",
+              FileOption "" cFile,
+              Option        "-o",
+              FileOption "" oFile]
+              ++ if extn /= "s"
+                    then cOpts
+                    else asmOpts ccInfo)
+      return oFile
+    where
+      -- Pass a different set of options to the C compiler depending one whether
+      -- we're compiling C or assembler. When compiling C, we pass the usual
+      -- set of include directories and PIC flags.
+      cOpts = map Option (picCCOpts dflags)
+                    ++ map (FileOption "-I")
+                            (includeDirs $ getPackageDetails dflags rtsUnitId)
+
+      -- When compiling assembler code, we drop the usual C options, and if the
+      -- compiler is Clang, we add an extra argument to tell Clang to ignore
+      -- unused command line options. See trac #11684.
+      asmOpts ccInfo =
+            if any (ccInfo ==) [Clang, AppleClang, AppleClang51]
+                then [Option "-Qunused-arguments"]
+                else []
+
+-- When linking a binary, we need to create a C main() function that
+-- starts everything off.  This used to be compiled statically as part
+-- of the RTS, but that made it hard to change the -rtsopts setting,
+-- so now we generate and compile a main() stub as part of every
+-- binary and pass the -rtsopts setting directly to the RTS (#5373)
+--
+-- On Windows, when making a shared library we also may need a DllMain.
+--
+mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath
+mkExtraObjToLinkIntoBinary dflags = do
+  when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do
+     putLogMsg dflags NoReason SevInfo noSrcSpan
+         (defaultUserStyle dflags)
+         (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
+          text "    Call hs_init_ghc() from your main() function to set these options.")
+
+  mkExtraObj dflags "c" (showSDoc dflags main)
+  where
+    main
+      | gopt Opt_NoHsMain dflags = Outputable.empty
+      | otherwise
+          = case ghcLink dflags of
+                  LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32
+                                    then dllMain
+                                    else Outputable.empty
+                  _                      -> exeMain
+
+    exeMain = vcat [
+        text "#include \"Rts.h\"",
+        text "extern StgClosure ZCMain_main_closure;",
+        text "int main(int argc, char *argv[])",
+        char '{',
+        text " RtsConfig __conf = defaultRtsConfig;",
+        text " __conf.rts_opts_enabled = "
+            <> text (show (rtsOptsEnabled dflags)) <> semi,
+        text " __conf.rts_opts_suggestions = "
+            <> text (if rtsOptsSuggestions dflags
+                        then "true"
+                        else "false") <> semi,
+        text "__conf.keep_cafs = "
+            <> text (if gopt Opt_KeepCAFs dflags
+                       then "true"
+                       else "false") <> semi,
+        case rtsOpts dflags of
+            Nothing   -> Outputable.empty
+            Just opts -> text "    __conf.rts_opts= " <>
+                          text (show opts) <> semi,
+        text " __conf.rts_hs_main = true;",
+        text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);",
+        char '}',
+        char '\n' -- final newline, to keep gcc happy
+        ]
+
+    dllMain = vcat [
+        text "#include \"Rts.h\"",
+        text "#include <windows.h>",
+        text "#include <stdbool.h>",
+        char '\n',
+        text "bool",
+        text "WINAPI",
+        text "DllMain ( HINSTANCE hInstance STG_UNUSED",
+        text "        , DWORD reason STG_UNUSED",
+        text "        , LPVOID reserved STG_UNUSED",
+        text "        )",
+        text "{",
+        text "  return true;",
+        text "}",
+        char '\n' -- final newline, to keep gcc happy
+        ]
+
+-- Write out the link info section into a new assembly file. Previously
+-- this was included as inline assembly in the main.c file but this
+-- is pretty fragile. gas gets upset trying to calculate relative offsets
+-- that span the .note section (notably .text) when debug info is present
+mkNoteObjsToLinkIntoBinary :: DynFlags -> [InstalledUnitId] -> IO [FilePath]
+mkNoteObjsToLinkIntoBinary dflags dep_packages = do
+   link_info <- getLinkInfo dflags dep_packages
+
+   if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
+     then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))
+     else return []
+
+  where
+    link_opts info = hcat [
+      -- "link info" section (see Note [LinkInfo section])
+      makeElfNote ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info,
+
+      -- ALL generated assembly must have this section to disable
+      -- executable stacks.  See also
+      -- compiler/nativeGen/AsmCodeGen.hs for another instance
+      -- where we need to do this.
+      if platformHasGnuNonexecStack (targetPlatform dflags)
+        then text ".section .note.GNU-stack,\"\","
+             <> sectionType "progbits" <> char '\n'
+        else Outputable.empty
+      ]
+
+-- | Return the "link info" string
+--
+-- See Note [LinkInfo section]
+getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String
+getLinkInfo dflags dep_packages = do
+   package_link_opts <- getPackageLinkOpts dflags dep_packages
+   pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)
+                     then getPackageFrameworks dflags dep_packages
+                     else return []
+   let extra_ld_inputs = ldInputs dflags
+   let
+      link_info = (package_link_opts,
+                   pkg_frameworks,
+                   rtsOpts dflags,
+                   rtsOptsEnabled dflags,
+                   gopt Opt_NoHsMain dflags,
+                   map showOpt extra_ld_inputs,
+                   getOpts dflags opt_l)
+   --
+   return (show link_info)
+
+platformSupportsSavingLinkOpts :: OS -> Bool
+platformSupportsSavingLinkOpts os
+ | os == OSSolaris2 = False -- see #5382
+ | otherwise        = osElfTarget os
+
+-- See Note [LinkInfo section]
+ghcLinkInfoSectionName :: String
+ghcLinkInfoSectionName = ".debug-ghc-link-info"
+  -- if we use the ".debug" prefix, then strip will strip it by default
+
+-- Identifier for the note (see Note [LinkInfo section])
+ghcLinkInfoNoteName :: String
+ghcLinkInfoNoteName = "GHC link info"
+
+-- Returns 'False' if it was, and we can avoid linking, because the
+-- previous binary was linked with "the same options".
+checkLinkInfo :: DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool
+checkLinkInfo dflags pkg_deps exe_file
+ | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))
+ -- ToDo: Windows and OS X do not use the ELF binary format, so
+ -- readelf does not work there.  We need to find another way to do
+ -- this.
+ = return False -- conservatively we should return True, but not
+                -- linking in this case was the behaviour for a long
+                -- time so we leave it as-is.
+ | otherwise
+ = do
+   link_info <- getLinkInfo dflags pkg_deps
+   debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info)
+   m_exe_link_info <- readElfNoteAsString dflags exe_file
+                          ghcLinkInfoSectionName ghcLinkInfoNoteName
+   let sameLinkInfo = (Just link_info == m_exe_link_info)
+   debugTraceMsg dflags 3 $ case m_exe_link_info of
+     Nothing -> text "Exe link info: Not found"
+     Just s
+       | sameLinkInfo -> text ("Exe link info is the same")
+       | otherwise    -> text ("Exe link info is different: " ++ s)
+   return (not sameLinkInfo)
+
+{- Note [LinkInfo section]
+   ~~~~~~~~~~~~~~~~~~~~~~~
+
+The "link info" is a string representing the parameters of the link. We save
+this information in the binary, and the next time we link, if nothing else has
+changed, we use the link info stored in the existing binary to decide whether
+to re-link or not.
+
+The "link info" string is stored in a ELF section called ".debug-ghc-link-info"
+(see ghcLinkInfoSectionName) with the SHT_NOTE type.  For some time, it used to
+not follow the specified record-based format (see #11022).
+
+-}
+
+haveRtsOptsFlags :: DynFlags -> Bool
+haveRtsOptsFlags dflags =
+        isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of
+                                       RtsOptsSafeOnly -> False
+                                       _ -> True
diff --git a/compiler/main/SysTools/Info.hs b/compiler/main/SysTools/Info.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/SysTools/Info.hs
@@ -0,0 +1,262 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+-----------------------------------------------------------------------------
+--
+-- Compiler information functions
+--
+-- (c) The GHC Team 2017
+--
+-----------------------------------------------------------------------------
+module SysTools.Info where
+
+import Exception
+import ErrUtils
+import DynFlags
+import Outputable
+import Util
+
+import Data.List
+import Data.IORef
+
+import System.IO
+
+import Platform
+import GhcPrelude
+
+import SysTools.Process
+
+{- Note [Run-time linker info]
+
+See also: Trac #5240, Trac #6063, Trac #10110
+
+Before 'runLink', we need to be sure to get the relevant information
+about the linker we're using at runtime to see if we need any extra
+options. For example, GNU ld requires '--reduce-memory-overheads' and
+'--hash-size=31' in order to use reasonable amounts of memory (see
+trac #5240.) But this isn't supported in GNU gold.
+
+Generally, the linker changing from what was detected at ./configure
+time has always been possible using -pgml, but on Linux it can happen
+'transparently' by installing packages like binutils-gold, which
+change what /usr/bin/ld actually points to.
+
+Clang vs GCC notes:
+
+For gcc, 'gcc -Wl,--version' gives a bunch of output about how to
+invoke the linker before the version information string. For 'clang',
+the version information for 'ld' is all that's output. For this
+reason, we typically need to slurp up all of the standard error output
+and look through it.
+
+Other notes:
+
+We cache the LinkerInfo inside DynFlags, since clients may link
+multiple times. The definition of LinkerInfo is there to avoid a
+circular dependency.
+
+-}
+
+{- Note [ELF needed shared libs]
+
+Some distributions change the link editor's default handling of
+ELF DT_NEEDED tags to include only those shared objects that are
+needed to resolve undefined symbols. For Template Haskell we need
+the last temporary shared library also if it is not needed for the
+currently linked temporary shared library. We specify --no-as-needed
+to override the default. This flag exists in GNU ld and GNU gold.
+
+The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
+(Mach-O) the flag is not needed.
+
+-}
+
+{- Note [Windows static libGCC]
+
+The GCC versions being upgraded to in #10726 are configured with
+dynamic linking of libgcc supported. This results in libgcc being
+linked dynamically when a shared library is created.
+
+This introduces thus an extra dependency on GCC dll that was not
+needed before by shared libraries created with GHC. This is a particular
+issue on Windows because you get a non-obvious error due to this missing
+dependency. This dependent dll is also not commonly on your path.
+
+For this reason using the static libgcc is preferred as it preserves
+the same behaviour that existed before. There are however some very good
+reasons to have the shared version as well as described on page 181 of
+https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf :
+
+"There are several situations in which an application should use the
+ shared ‘libgcc’ instead of the static version. The most common of these
+ is when the application wishes to throw and catch exceptions across different
+ shared libraries. In that case, each of the libraries as well as the application
+ itself should use the shared ‘libgcc’. "
+
+-}
+
+neededLinkArgs :: LinkerInfo -> [Option]
+neededLinkArgs (GnuLD o)     = o
+neededLinkArgs (GnuGold o)   = o
+neededLinkArgs (LlvmLLD o)   = o
+neededLinkArgs (DarwinLD o)  = o
+neededLinkArgs (SolarisLD o) = o
+neededLinkArgs (AixLD o)     = o
+neededLinkArgs UnknownLD     = []
+
+-- Grab linker info and cache it in DynFlags.
+getLinkerInfo :: DynFlags -> IO LinkerInfo
+getLinkerInfo dflags = do
+  info <- readIORef (rtldInfo dflags)
+  case info of
+    Just v  -> return v
+    Nothing -> do
+      v <- getLinkerInfo' dflags
+      writeIORef (rtldInfo dflags) (Just v)
+      return v
+
+-- See Note [Run-time linker info].
+getLinkerInfo' :: DynFlags -> IO LinkerInfo
+getLinkerInfo' dflags = do
+  let platform = targetPlatform dflags
+      os = platformOS platform
+      (pgm,args0) = pgm_l dflags
+      args1     = map Option (getOpts dflags opt_l)
+      args2     = args0 ++ args1
+      args3     = filter notNull (map showOpt args2)
+
+      -- Try to grab the info from the process output.
+      parseLinkerInfo stdo _stde _exitc
+        | any ("GNU ld" `isPrefixOf`) stdo =
+          -- GNU ld specifically needs to use less memory. This especially
+          -- hurts on small object files. Trac #5240.
+          -- Set DT_NEEDED for all shared libraries. Trac #10110.
+          -- TODO: Investigate if these help or hurt when using split sections.
+          return (GnuLD $ map Option ["-Wl,--hash-size=31",
+                                      "-Wl,--reduce-memory-overheads",
+                                      -- ELF specific flag
+                                      -- see Note [ELF needed shared libs]
+                                      "-Wl,--no-as-needed"])
+
+        | any ("GNU gold" `isPrefixOf`) stdo =
+          -- GNU gold only needs --no-as-needed. Trac #10110.
+          -- ELF specific flag, see Note [ELF needed shared libs]
+          return (GnuGold [Option "-Wl,--no-as-needed"])
+
+        | any ("LLD" `isPrefixOf`) stdo =
+          return (LlvmLLD $ map Option [
+                                      -- see Note [ELF needed shared libs]
+                                      "-Wl,--no-as-needed"])
+
+         -- Unknown linker.
+        | otherwise = fail "invalid --version output, or linker is unsupported"
+
+  -- Process the executable call
+  info <- catchIO (do
+             case os of
+               OSSolaris2 ->
+                 -- Solaris uses its own Solaris linker. Even all
+                 -- GNU C are recommended to configure with Solaris
+                 -- linker instead of using GNU binutils linker. Also
+                 -- all GCC distributed with Solaris follows this rule
+                 -- precisely so we assume here, the Solaris linker is
+                 -- used.
+                 return $ SolarisLD []
+               OSAIX ->
+                 -- IBM AIX uses its own non-binutils linker as well
+                 return $ AixLD []
+               OSDarwin ->
+                 -- Darwin has neither GNU Gold or GNU LD, but a strange linker
+                 -- that doesn't support --version. We can just assume that's
+                 -- what we're using.
+                 return $ DarwinLD []
+               OSMinGW32 ->
+                 -- GHC doesn't support anything but GNU ld on Windows anyway.
+                 -- Process creation is also fairly expensive on win32, so
+                 -- we short-circuit here.
+                 return $ GnuLD $ map Option
+                   [ -- Reduce ld memory usage
+                     "-Wl,--hash-size=31"
+                   , "-Wl,--reduce-memory-overheads"
+                     -- Emit gcc stack checks
+                     -- Note [Windows stack usage]
+                   , "-fstack-check"
+                     -- Force static linking of libGCC
+                     -- Note [Windows static libGCC]
+                   , "-static-libgcc" ]
+               _ -> do
+                 -- In practice, we use the compiler as the linker here. Pass
+                 -- -Wl,--version to get linker version info.
+                 (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm
+                                        (["-Wl,--version"] ++ args3)
+                                        c_locale_env
+                 -- Split the output by lines to make certain kinds
+                 -- of processing easier. In particular, 'clang' and 'gcc'
+                 -- have slightly different outputs for '-Wl,--version', but
+                 -- it's still easy to figure out.
+                 parseLinkerInfo (lines stdo) (lines stde) exitc
+            )
+            (\err -> do
+                debugTraceMsg dflags 2
+                    (text "Error (figuring out linker information):" <+>
+                     text (show err))
+                errorMsg dflags $ hang (text "Warning:") 9 $
+                  text "Couldn't figure out linker information!" $$
+                  text "Make sure you're using GNU ld, GNU gold" <+>
+                  text "or the built in OS X linker, etc."
+                return UnknownLD)
+  return info
+
+-- Grab compiler info and cache it in DynFlags.
+getCompilerInfo :: DynFlags -> IO CompilerInfo
+getCompilerInfo dflags = do
+  info <- readIORef (rtccInfo dflags)
+  case info of
+    Just v  -> return v
+    Nothing -> do
+      v <- getCompilerInfo' dflags
+      writeIORef (rtccInfo dflags) (Just v)
+      return v
+
+-- See Note [Run-time linker info].
+getCompilerInfo' :: DynFlags -> IO CompilerInfo
+getCompilerInfo' dflags = do
+  let (pgm,_) = pgm_c dflags
+      -- Try to grab the info from the process output.
+      parseCompilerInfo _stdo stde _exitc
+        -- Regular GCC
+        | any ("gcc version" `isInfixOf`) stde =
+          return GCC
+        -- Regular clang
+        | any ("clang version" `isInfixOf`) stde =
+          return Clang
+        -- FreeBSD clang
+        | any ("FreeBSD clang version" `isInfixOf`) stde =
+          return Clang
+        -- XCode 5.1 clang
+        | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =
+          return AppleClang51
+        -- XCode 5 clang
+        | any ("Apple LLVM version" `isPrefixOf`) stde =
+          return AppleClang
+        -- XCode 4.1 clang
+        | any ("Apple clang version" `isPrefixOf`) stde =
+          return AppleClang
+         -- Unknown linker.
+        | otherwise = fail "invalid -v output, or compiler is unsupported"
+
+  -- Process the executable call
+  info <- catchIO (do
+                (exitc, stdo, stde) <-
+                    readProcessEnvWithExitCode pgm ["-v"] c_locale_env
+                -- Split the output by lines to make certain kinds
+                -- of processing easier.
+                parseCompilerInfo (lines stdo) (lines stde) exitc
+            )
+            (\err -> do
+                debugTraceMsg dflags 2
+                    (text "Error (figuring out C compiler information):" <+>
+                     text (show err))
+                errorMsg dflags $ hang (text "Warning:") 9 $
+                  text "Couldn't figure out C compiler information!" $$
+                  text "Make sure you're using GNU gcc, or clang"
+                return UnknownCC)
+  return info
diff --git a/compiler/main/SysTools/Process.hs b/compiler/main/SysTools/Process.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/SysTools/Process.hs
@@ -0,0 +1,347 @@
+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+--
+-- Misc process handling code for SysTools
+--
+-- (c) The GHC Team 2017
+--
+-----------------------------------------------------------------------------
+module SysTools.Process where
+
+#include "HsVersions.h"
+
+import Exception
+import ErrUtils
+import DynFlags
+import FastString
+import Outputable
+import Panic
+import GhcPrelude
+import Util
+import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
+
+import Control.Concurrent
+import Data.Char
+
+import System.Exit
+import System.Environment
+import System.FilePath
+import System.IO
+import System.IO.Error as IO
+import System.Process
+
+import FileCleanup
+
+-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is
+-- inherited from the parent process, and output to stderr is not captured.
+readCreateProcessWithExitCode'
+    :: CreateProcess
+    -> IO (ExitCode, String)    -- ^ stdout
+readCreateProcessWithExitCode' proc = do
+    (_, Just outh, _, pid) <-
+        createProcess proc{ std_out = CreatePipe }
+
+    -- fork off a thread to start consuming the output
+    output  <- hGetContents outh
+    outMVar <- newEmptyMVar
+    _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()
+
+    -- wait on the output
+    takeMVar outMVar
+    hClose outh
+
+    -- wait on the process
+    ex <- waitForProcess pid
+
+    return (ex, output)
+
+replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]
+replaceVar (var, value) env =
+    (var, value) : filter (\(var',_) -> var /= var') env
+
+-- | Version of @System.Process.readProcessWithExitCode@ that takes a
+-- key-value tuple to insert into the environment.
+readProcessEnvWithExitCode
+    :: String -- ^ program path
+    -> [String] -- ^ program args
+    -> (String, String) -- ^ addition to the environment
+    -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)
+readProcessEnvWithExitCode prog args env_update = do
+    current_env <- getEnvironment
+    readCreateProcessWithExitCode (proc prog args) {
+        env = Just (replaceVar env_update current_env) } ""
+
+-- Don't let gcc localize version info string, #8825
+c_locale_env :: (String, String)
+c_locale_env = ("LANGUAGE", "C")
+
+-- If the -B<dir> option is set, add <dir> to PATH.  This works around
+-- a bug in gcc on Windows Vista where it can't find its auxiliary
+-- binaries (see bug #1110).
+getGccEnv :: [Option] -> IO (Maybe [(String,String)])
+getGccEnv opts =
+  if null b_dirs
+     then return Nothing
+     else do env <- getEnvironment
+             return (Just (map mangle_path env))
+ where
+  (b_dirs, _) = partitionWith get_b_opt opts
+
+  get_b_opt (Option ('-':'B':dir)) = Left dir
+  get_b_opt other = Right other
+
+  mangle_path (path,paths) | map toUpper path == "PATH"
+        = (path, '\"' : head b_dirs ++ "\";" ++ paths)
+  mangle_path other = other
+
+
+-----------------------------------------------------------------------------
+-- Running an external program
+
+runSomething :: DynFlags
+             -> String          -- For -v message
+             -> String          -- Command name (possibly a full path)
+                                --      assumed already dos-ified
+             -> [Option]        -- Arguments
+                                --      runSomething will dos-ify them
+             -> IO ()
+
+runSomething dflags phase_name pgm args =
+  runSomethingFiltered dflags id phase_name pgm args Nothing Nothing
+
+-- | Run a command, placing the arguments in an external response file.
+--
+-- This command is used in order to avoid overlong command line arguments on
+-- Windows. The command line arguments are first written to an external,
+-- temporary response file, and then passed to the linker via @filepath.
+-- response files for passing them in. See:
+--
+--     https://gcc.gnu.org/wiki/Response_Files
+--     https://ghc.haskell.org/trac/ghc/ticket/10777
+runSomethingResponseFile
+  :: DynFlags -> (String->String) -> String -> String -> [Option]
+  -> Maybe [(String,String)] -> IO ()
+
+runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =
+    runSomethingWith dflags phase_name pgm args $ \real_args -> do
+        fp <- getResponseFile real_args
+        let args = ['@':fp]
+        r <- builderMainLoop dflags filter_fn pgm args Nothing mb_env
+        return (r,())
+  where
+    getResponseFile args = do
+      fp <- newTempName dflags TFL_CurrentModule "rsp"
+      withFile fp WriteMode $ \h -> do
+#if defined(mingw32_HOST_OS)
+          hSetEncoding h latin1
+#else
+          hSetEncoding h utf8
+#endif
+          hPutStr h $ unlines $ map escape args
+      return fp
+
+    -- Note: Response files have backslash-escaping, double quoting, and are
+    -- whitespace separated (some implementations use newline, others any
+    -- whitespace character). Therefore, escape any backslashes, newlines, and
+    -- double quotes in the argument, and surround the content with double
+    -- quotes.
+    --
+    -- Another possibility that could be considered would be to convert
+    -- backslashes in the argument to forward slashes. This would generally do
+    -- the right thing, since backslashes in general only appear in arguments
+    -- as part of file paths on Windows, and the forward slash is accepted for
+    -- those. However, escaping is more reliable, in case somehow a backslash
+    -- appears in a non-file.
+    escape x = concat
+        [ "\""
+        , concatMap
+            (\c ->
+                case c of
+                    '\\' -> "\\\\"
+                    '\n' -> "\\n"
+                    '\"' -> "\\\""
+                    _    -> [c])
+            x
+        , "\""
+        ]
+
+runSomethingFiltered
+  :: DynFlags -> (String->String) -> String -> String -> [Option]
+  -> Maybe FilePath -> Maybe [(String,String)] -> IO ()
+
+runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = do
+    runSomethingWith dflags phase_name pgm args $ \real_args -> do
+        r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env
+        return (r,())
+
+runSomethingWith
+  :: DynFlags -> String -> String -> [Option]
+  -> ([String] -> IO (ExitCode, a))
+  -> IO a
+
+runSomethingWith dflags phase_name pgm args io = do
+  let real_args = filter notNull (map showOpt args)
+      cmdLine = showCommandForUser pgm real_args
+  traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args
+
+handleProc :: String -> String -> IO (ExitCode, r) -> IO r
+handleProc pgm phase_name proc = do
+    (rc, r) <- proc `catchIO` handler
+    case rc of
+      ExitSuccess{} -> return r
+      ExitFailure n -> throwGhcExceptionIO (
+            ProgramError ("`" ++ takeFileName pgm ++ "'" ++
+                          " failed in phase `" ++ phase_name ++ "'." ++
+                          " (Exit code: " ++ show n ++ ")"))
+  where
+    handler err =
+       if IO.isDoesNotExistError err
+          then does_not_exist
+          else throwGhcExceptionIO (ProgramError $ show err)
+
+    does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))
+
+
+builderMainLoop :: DynFlags -> (String -> String) -> FilePath
+                -> [String] -> Maybe FilePath -> Maybe [(String, String)]
+                -> IO ExitCode
+builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do
+  chan <- newChan
+
+  -- We use a mask here rather than a bracket because we want
+  -- to distinguish between cleaning up with and without an
+  -- exception. This is to avoid calling terminateProcess
+  -- unless an exception was raised.
+  let safely inner = mask $ \restore -> do
+        -- acquire
+        (hStdIn, hStdOut, hStdErr, hProcess) <- restore $
+          runInteractiveProcess pgm real_args mb_cwd mb_env
+        let cleanup_handles = do
+              hClose hStdIn
+              hClose hStdOut
+              hClose hStdErr
+        r <- try $ restore $ do
+          hSetBuffering hStdOut LineBuffering
+          hSetBuffering hStdErr LineBuffering
+          let make_reader_proc h = forkIO $ readerProc chan h filter_fn
+          bracketOnError (make_reader_proc hStdOut) killThread $ \_ ->
+            bracketOnError (make_reader_proc hStdErr) killThread $ \_ ->
+            inner hProcess
+        case r of
+          -- onException
+          Left (SomeException e) -> do
+            terminateProcess hProcess
+            cleanup_handles
+            throw e
+          -- cleanup when there was no exception
+          Right s -> do
+            cleanup_handles
+            return s
+  safely $ \h -> do
+    -- we don't want to finish until 2 streams have been complete
+    -- (stdout and stderr)
+    log_loop chan (2 :: Integer)
+    -- after that, we wait for the process to finish and return the exit code.
+    waitForProcess h
+  where
+    -- t starts at the number of streams we're listening to (2) decrements each
+    -- time a reader process sends EOF. We are safe from looping forever if a
+    -- reader thread dies, because they send EOF in a finally handler.
+    log_loop _ 0 = return ()
+    log_loop chan t = do
+      msg <- readChan chan
+      case msg of
+        BuildMsg msg -> do
+          putLogMsg dflags NoReason SevInfo noSrcSpan
+              (defaultUserStyle dflags) msg
+          log_loop chan t
+        BuildError loc msg -> do
+          putLogMsg dflags NoReason SevError (mkSrcSpan loc loc)
+              (defaultUserStyle dflags) msg
+          log_loop chan t
+        EOF ->
+          log_loop chan  (t-1)
+
+readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()
+readerProc chan hdl filter_fn =
+    (do str <- hGetContents hdl
+        loop (linesPlatform (filter_fn str)) Nothing)
+    `finally`
+       writeChan chan EOF
+        -- ToDo: check errors more carefully
+        -- ToDo: in the future, the filter should be implemented as
+        -- a stream transformer.
+    where
+        loop []     Nothing    = return ()
+        loop []     (Just err) = writeChan chan err
+        loop (l:ls) in_err     =
+                case in_err of
+                  Just err@(BuildError srcLoc msg)
+                    | leading_whitespace l -> do
+                        loop ls (Just (BuildError srcLoc (msg $$ text l)))
+                    | otherwise -> do
+                        writeChan chan err
+                        checkError l ls
+                  Nothing -> do
+                        checkError l ls
+                  _ -> panic "readerProc/loop"
+
+        checkError l ls
+           = case parseError l of
+                Nothing -> do
+                    writeChan chan (BuildMsg (text l))
+                    loop ls Nothing
+                Just (file, lineNum, colNum, msg) -> do
+                    let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum
+                    loop ls (Just (BuildError srcLoc (text msg)))
+
+        leading_whitespace []    = False
+        leading_whitespace (x:_) = isSpace x
+
+parseError :: String -> Maybe (String, Int, Int, String)
+parseError s0 = case breakColon s0 of
+                Just (filename, s1) ->
+                    case breakIntColon s1 of
+                    Just (lineNum, s2) ->
+                        case breakIntColon s2 of
+                        Just (columnNum, s3) ->
+                            Just (filename, lineNum, columnNum, s3)
+                        Nothing ->
+                            Just (filename, lineNum, 0, s2)
+                    Nothing -> Nothing
+                Nothing -> Nothing
+
+breakColon :: String -> Maybe (String, String)
+breakColon xs = case break (':' ==) xs of
+                    (ys, _:zs) -> Just (ys, zs)
+                    _ -> Nothing
+
+breakIntColon :: String -> Maybe (Int, String)
+breakIntColon xs = case break (':' ==) xs of
+                       (ys, _:zs)
+                        | not (null ys) && all isAscii ys && all isDigit ys ->
+                           Just (read ys, zs)
+                       _ -> Nothing
+
+data BuildMessage
+  = BuildMsg   !SDoc
+  | BuildError !SrcLoc !SDoc
+  | EOF
+
+-- Divvy up text stream into lines, taking platform dependent
+-- line termination into account.
+linesPlatform :: String -> [String]
+#if !defined(mingw32_HOST_OS)
+linesPlatform ls = lines ls
+#else
+linesPlatform "" = []
+linesPlatform xs =
+  case lineBreak xs of
+    (as,xs1) -> as : linesPlatform xs1
+  where
+   lineBreak "" = ("","")
+   lineBreak ('\r':'\n':xs) = ([],xs)
+   lineBreak ('\n':xs) = ([],xs)
+   lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)
+
+#endif
diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/SysTools/Tasks.hs
@@ -0,0 +1,347 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+-----------------------------------------------------------------------------
+--
+-- Tasks running external programs for SysTools
+--
+-- (c) The GHC Team 2017
+--
+-----------------------------------------------------------------------------
+module SysTools.Tasks where
+
+import Exception
+import ErrUtils
+import DynFlags
+import Outputable
+import Platform
+import Util
+
+import Data.Char
+import Data.List
+
+import System.IO
+import System.Process
+import GhcPrelude
+
+import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion)
+
+import SysTools.Process
+import SysTools.Info
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Running an external program}
+*                                                                      *
+************************************************************************
+-}
+
+runUnlit :: DynFlags -> [Option] -> IO ()
+runUnlit dflags args = do
+  let prog = pgm_L dflags
+      opts = getOpts dflags opt_L
+  runSomething dflags "Literate pre-processor" prog
+               (map Option opts ++ args)
+
+runCpp :: DynFlags -> [Option] -> IO ()
+runCpp dflags args =   do
+  let (p,args0) = pgm_P dflags
+      args1 = map Option (getOpts dflags opt_P)
+      args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]
+                ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]
+  mb_env <- getGccEnv args2
+  runSomethingFiltered dflags id  "C pre-processor" p
+                       (args0 ++ args1 ++ args2 ++ args) Nothing mb_env
+
+runPp :: DynFlags -> [Option] -> IO ()
+runPp dflags args =   do
+  let prog = pgm_F dflags
+      opts = map Option (getOpts dflags opt_F)
+  runSomething dflags "Haskell pre-processor" prog (args ++ opts)
+
+runCc :: DynFlags -> [Option] -> IO ()
+runCc dflags args =   do
+  let (p,args0) = pgm_c dflags
+      args1 = map Option (getOpts dflags opt_c)
+      args2 = args0 ++ args ++ args1
+      -- We take care to pass -optc flags in args1 last to ensure that the
+      -- user can override flags passed by GHC. See #14452.
+  mb_env <- getGccEnv args2
+  runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env
+ where
+  -- discard some harmless warnings from gcc that we can't turn off
+  cc_filter = unlines . doFilter . lines
+
+  {-
+  gcc gives warnings in chunks like so:
+      In file included from /foo/bar/baz.h:11,
+                       from /foo/bar/baz2.h:22,
+                       from wibble.c:33:
+      /foo/flibble:14: global register variable ...
+      /foo/flibble:15: warning: call-clobbered r...
+  We break it up into its chunks, remove any call-clobbered register
+  warnings from each chunk, and then delete any chunks that we have
+  emptied of warnings.
+  -}
+  doFilter = unChunkWarnings . filterWarnings . chunkWarnings []
+  -- We can't assume that the output will start with an "In file inc..."
+  -- line, so we start off expecting a list of warnings rather than a
+  -- location stack.
+  chunkWarnings :: [String] -- The location stack to use for the next
+                            -- list of warnings
+                -> [String] -- The remaining lines to look at
+                -> [([String], [String])]
+  chunkWarnings loc_stack [] = [(loc_stack, [])]
+  chunkWarnings loc_stack xs
+      = case break loc_stack_start xs of
+        (warnings, lss:xs') ->
+            case span loc_start_continuation xs' of
+            (lsc, xs'') ->
+                (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''
+        _ -> [(loc_stack, xs)]
+
+  filterWarnings :: [([String], [String])] -> [([String], [String])]
+  filterWarnings [] = []
+  -- If the warnings are already empty then we are probably doing
+  -- something wrong, so don't delete anything
+  filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs
+  filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of
+                                       [] -> filterWarnings zs
+                                       ys' -> (xs, ys') : filterWarnings zs
+
+  unChunkWarnings :: [([String], [String])] -> [String]
+  unChunkWarnings [] = []
+  unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs
+
+  loc_stack_start        s = "In file included from " `isPrefixOf` s
+  loc_start_continuation s = "                 from " `isPrefixOf` s
+  wantedWarning w
+   | "warning: call-clobbered register used" `isContainedIn` w = False
+   | otherwise = True
+
+isContainedIn :: String -> String -> Bool
+xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)
+
+-- | Run the linker with some arguments and return the output
+askLd :: DynFlags -> [Option] -> IO String
+askLd dflags args = do
+  let (p,args0) = pgm_l dflags
+      args1     = map Option (getOpts dflags opt_l)
+      args2     = args0 ++ args1 ++ args
+  mb_env <- getGccEnv args2
+  runSomethingWith dflags "gcc" p args2 $ \real_args ->
+    readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }
+
+runSplit :: DynFlags -> [Option] -> IO ()
+runSplit dflags args = do
+  let (p,args0) = pgm_s dflags
+  runSomething dflags "Splitter" p (args0++args)
+
+runAs :: DynFlags -> [Option] -> IO ()
+runAs dflags args = do
+  let (p,args0) = pgm_a dflags
+      args1 = map Option (getOpts dflags opt_a)
+      args2 = args0 ++ args1 ++ args
+  mb_env <- getGccEnv args2
+  runSomethingFiltered dflags id "Assembler" p args2 Nothing mb_env
+
+-- | Run the LLVM Optimiser
+runLlvmOpt :: DynFlags -> [Option] -> IO ()
+runLlvmOpt dflags args = do
+  let (p,args0) = pgm_lo dflags
+      args1 = map Option (getOpts dflags opt_lo)
+      -- We take care to pass -optlo flags (e.g. args0) last to ensure that the
+      -- user can override flags passed by GHC. See #14821.
+  runSomething dflags "LLVM Optimiser" p (args1 ++ args ++ args0)
+
+-- | Run the LLVM Compiler
+runLlvmLlc :: DynFlags -> [Option] -> IO ()
+runLlvmLlc dflags args = do
+  let (p,args0) = pgm_lc dflags
+      args1 = map Option (getOpts dflags opt_lc)
+  runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)
+
+-- | Run the clang compiler (used as an assembler for the LLVM
+-- backend on OS X as LLVM doesn't support the OS X system
+-- assembler)
+runClang :: DynFlags -> [Option] -> IO ()
+runClang dflags args = do
+  let (clang,_) = pgm_lcc dflags
+      -- be careful what options we call clang with
+      -- see #5903 and #7617 for bugs caused by this.
+      (_,args0) = pgm_a dflags
+      args1 = map Option (getOpts dflags opt_a)
+      args2 = args0 ++ args1 ++ args
+  mb_env <- getGccEnv args2
+  Exception.catch (do
+        runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env
+    )
+    (\(err :: SomeException) -> do
+        errorMsg dflags $
+            text ("Error running clang! you need clang installed to use the" ++
+                  " LLVM backend") $+$
+            text "(or GHC tried to execute clang incorrectly)"
+        throwIO err
+    )
+
+-- | Figure out which version of LLVM we are running this session
+figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int))
+figureLlvmVersion dflags = do
+  let (pgm,opts) = pgm_lc dflags
+      args = filter notNull (map showOpt opts)
+      -- we grab the args even though they should be useless just in
+      -- case the user is using a customised 'llc' that requires some
+      -- of the options they've specified. llc doesn't care what other
+      -- options are specified when '-version' is used.
+      args' = args ++ ["-version"]
+  ver <- catchIO (do
+              (pin, pout, perr, _) <- runInteractiveProcess pgm args'
+                                              Nothing Nothing
+              {- > llc -version
+                  LLVM (http://llvm.org/):
+                    LLVM version 3.5.2
+                    ...
+              -}
+              hSetBinaryMode pout False
+              _     <- hGetLine pout
+              vline <- dropWhile (not . isDigit) `fmap` hGetLine pout
+              v     <- case span (/= '.') vline of
+                        ("",_)  -> fail "no digits!"
+                        (x,y) -> return (read x
+                                        , read $ takeWhile isDigit $ drop 1 y)
+
+              hClose pin
+              hClose pout
+              hClose perr
+              return $ Just v
+            )
+            (\err -> do
+                debugTraceMsg dflags 2
+                    (text "Error (figuring out LLVM version):" <+>
+                      text (show err))
+                errorMsg dflags $ vcat
+                    [ text "Warning:", nest 9 $
+                          text "Couldn't figure out LLVM version!" $$
+                          text ("Make sure you have installed LLVM " ++
+                                llvmVersionStr supportedLlvmVersion) ]
+                return Nothing)
+  return ver
+
+
+runLink :: DynFlags -> [Option] -> IO ()
+runLink dflags args = do
+  -- See Note [Run-time linker info]
+  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
+  let (p,args0) = pgm_l dflags
+      args1     = map Option (getOpts dflags opt_l)
+      args2     = args0 ++ linkargs ++ args1 ++ args
+  mb_env <- getGccEnv args2
+  runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env
+  where
+    ld_filter = case (platformOS (targetPlatform dflags)) of
+                  OSSolaris2 -> sunos_ld_filter
+                  _ -> id
+{-
+  SunOS/Solaris ld emits harmless warning messages about unresolved
+  symbols in case of compiling into shared library when we do not
+  link against all the required libs. That is the case of GHC which
+  does not link against RTS library explicitly in order to be able to
+  choose the library later based on binary application linking
+  parameters. The warnings look like:
+
+Undefined                       first referenced
+  symbol                             in file
+stg_ap_n_fast                       ./T2386_Lib.o
+stg_upd_frame_info                  ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o
+newCAF                              ./T2386_Lib.o
+stg_bh_upd_frame_info               ./T2386_Lib.o
+stg_ap_ppp_fast                     ./T2386_Lib.o
+templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o
+stg_ap_p_fast                       ./T2386_Lib.o
+stg_ap_pp_fast                      ./T2386_Lib.o
+ld: warning: symbol referencing errors
+
+  this is actually coming from T2386 testcase. The emitting of those
+  warnings is also a reason why so many TH testcases fail on Solaris.
+
+  Following filter code is SunOS/Solaris linker specific and should
+  filter out only linker warnings. Please note that the logic is a
+  little bit more complex due to the simple reason that we need to preserve
+  any other linker emitted messages. If there are any. Simply speaking
+  if we see "Undefined" and later "ld: warning:..." then we omit all
+  text between (including) the marks. Otherwise we copy the whole output.
+-}
+    sunos_ld_filter :: String -> String
+    sunos_ld_filter = unlines . sunos_ld_filter' . lines
+    sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)
+                          then (ld_prefix x) ++ (ld_postfix x)
+                          else x
+    breakStartsWith x y = break (isPrefixOf x) y
+    ld_prefix = fst . breakStartsWith "Undefined"
+    undefined_found = not . null . snd . breakStartsWith "Undefined"
+    ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"
+    ld_postfix = tail . snd . ld_warn_break
+    ld_warning_found = not . null . snd . ld_warn_break
+
+
+runLibtool :: DynFlags -> [Option] -> IO ()
+runLibtool dflags args = do
+  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
+  let args1      = map Option (getOpts dflags opt_l)
+      args2      = [Option "-static"] ++ args1 ++ args ++ linkargs
+      libtool    = pgm_libtool dflags
+  mb_env <- getGccEnv args2
+  runSomethingFiltered dflags id "Linker" libtool args2 Nothing mb_env
+
+runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO ()
+runAr dflags cwd args = do
+  let ar = pgm_ar dflags
+  runSomethingFiltered dflags id "Ar" ar args cwd Nothing
+
+askAr :: DynFlags -> Maybe FilePath -> [Option] -> IO String
+askAr dflags mb_cwd args = do
+  let ar = pgm_ar dflags
+  runSomethingWith dflags "Ar" ar args $ \real_args ->
+    readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd }
+
+runRanlib :: DynFlags -> [Option] -> IO ()
+runRanlib dflags args = do
+  let ranlib = pgm_ranlib dflags
+  runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing
+
+runMkDLL :: DynFlags -> [Option] -> IO ()
+runMkDLL dflags args = do
+  let (p,args0) = pgm_dll dflags
+      args1 = args0 ++ args
+  mb_env <- getGccEnv (args0++args)
+  runSomethingFiltered dflags id "Make DLL" p args1 Nothing mb_env
+
+runWindres :: DynFlags -> [Option] -> IO ()
+runWindres dflags args = do
+  let (gcc, gcc_args) = pgm_c dflags
+      windres = pgm_windres dflags
+      opts = map Option (getOpts dflags opt_windres)
+      quote x = "\"" ++ x ++ "\""
+      args' = -- If windres.exe and gcc.exe are in a directory containing
+              -- spaces then windres fails to run gcc. We therefore need
+              -- to tell it what command to use...
+              Option ("--preprocessor=" ++
+                      unwords (map quote (gcc :
+                                          map showOpt gcc_args ++
+                                          map showOpt opts ++
+                                          ["-E", "-xc", "-DRC_INVOKED"])))
+              -- ...but if we do that then if windres calls popen then
+              -- it can't understand the quoting, so we have to use
+              -- --use-temp-file so that it interprets it correctly.
+              -- See #1828.
+            : Option "--use-temp-file"
+            : args
+  mb_env <- getGccEnv gcc_args
+  runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env
+
+touch :: DynFlags -> String -> String -> IO ()
+touch dflags purpose arg =
+  runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/main/TidyPgm.hs
@@ -0,0 +1,1463 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section{Tidying up Core}
+-}
+
+{-# LANGUAGE CPP, ViewPatterns #-}
+
+module TidyPgm (
+       mkBootModDetailsTc, tidyProgram, globaliseAndTidyId
+   ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnTypes
+import DynFlags
+import CoreSyn
+import CoreUnfold
+import CoreFVs
+import CoreTidy
+import CoreMonad
+import CorePrep
+import CoreUtils        (rhsIsStatic)
+import CoreStats        (coreBindsStats, CoreStats(..))
+import CoreSeq          (seqBinds)
+import CoreLint
+import Literal
+import Rules
+import PatSyn
+import ConLike
+import CoreArity        ( exprArity, exprBotStrictness_maybe )
+import StaticPtrTable
+import VarEnv
+import VarSet
+import Var
+import Id
+import MkId             ( mkDictSelRhs )
+import IdInfo
+import InstEnv
+import FamInstEnv
+import Type             ( tidyTopType )
+import Demand           ( appIsBottom, isTopSig, isBottomingSig )
+import BasicTypes
+import Name hiding (varName)
+import NameSet
+import NameEnv
+import NameCache
+import Avail
+import IfaceEnv
+import TcEnv
+import TcRnMonad
+import DataCon
+import TyCon
+import Class
+import Module
+import Packages( isDllName )
+import HscTypes
+import Maybes
+import UniqSupply
+import Outputable
+import qualified ErrUtils as Err
+
+import Control.Monad
+import Data.Function
+import Data.List        ( sortBy )
+import Data.IORef       ( atomicModifyIORef' )
+
+{-
+Constructing the TypeEnv, Instances, Rules from which the
+ModIface is constructed, and which goes on to subsequent modules in
+--make mode.
+
+Most of the interface file is obtained simply by serialising the
+TypeEnv.  One important consequence is that if the *interface file*
+has pragma info if and only if the final TypeEnv does. This is not so
+important for *this* module, but it's essential for ghc --make:
+subsequent compilations must not see (e.g.) the arity if the interface
+file does not contain arity If they do, they'll exploit the arity;
+then the arity might change, but the iface file doesn't change =>
+recompilation does not happen => disaster.
+
+For data types, the final TypeEnv will have a TyThing for the TyCon,
+plus one for each DataCon; the interface file will contain just one
+data type declaration, but it is de-serialised back into a collection
+of TyThings.
+
+************************************************************************
+*                                                                      *
+                Plan A: simpleTidyPgm
+*                                                                      *
+************************************************************************
+
+
+Plan A: mkBootModDetails: omit pragmas, make interfaces small
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Ignore the bindings
+
+* Drop all WiredIn things from the TypeEnv
+        (we never want them in interface files)
+
+* Retain all TyCons and Classes in the TypeEnv, to avoid
+        having to find which ones are mentioned in the
+        types of exported Ids
+
+* Trim off the constructors of non-exported TyCons, both
+        from the TyCon and from the TypeEnv
+
+* Drop non-exported Ids from the TypeEnv
+
+* Tidy the types of the DFunIds of Instances,
+  make them into GlobalIds, (they already have External Names)
+  and add them to the TypeEnv
+
+* Tidy the types of the (exported) Ids in the TypeEnv,
+  make them into GlobalIds (they already have External Names)
+
+* Drop rules altogether
+
+* Tidy the bindings, to ensure that the Caf and Arity
+  information is correct for each top-level binder; the
+  code generator needs it. And to ensure that local names have
+  distinct OccNames in case of object-file splitting
+
+* If this an hsig file, drop the instances altogether too (they'll
+  get pulled in by the implicit module import.
+-}
+
+-- This is Plan A: make a small type env when typechecking only,
+-- or when compiling a hs-boot file, or simply when not using -O
+--
+-- We don't look at the bindings at all -- there aren't any
+-- for hs-boot files
+
+mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails
+mkBootModDetailsTc hsc_env
+        TcGblEnv{ tcg_exports   = exports,
+                  tcg_type_env  = type_env, -- just for the Ids
+                  tcg_tcs       = tcs,
+                  tcg_patsyns   = pat_syns,
+                  tcg_insts     = insts,
+                  tcg_fam_insts = fam_insts,
+                  tcg_mod       = this_mod
+                }
+  = -- This timing isn't terribly useful since the result isn't forced, but
+    -- the message is useful to locating oneself in the compilation process.
+    Err.withTiming (pure dflags)
+                   (text "CoreTidy"<+>brackets (ppr this_mod))
+                   (const ()) $
+    do  { let { insts'     = map (tidyClsInstDFun globaliseAndTidyId) insts
+              ; pat_syns'  = map (tidyPatSynIds   globaliseAndTidyId) pat_syns
+              ; type_env1  = mkBootTypeEnv (availsToNameSet exports)
+                                           (typeEnvIds type_env) tcs fam_insts
+              ; type_env2  = extendTypeEnvWithPatSyns pat_syns' type_env1
+              ; dfun_ids   = map instanceDFunId insts'
+              ; type_env'  = extendTypeEnvWithIds type_env2 dfun_ids
+              }
+        ; return (ModDetails { md_types     = type_env'
+                             , md_insts     = insts'
+                             , md_fam_insts = fam_insts
+                             , md_rules     = []
+                             , md_anns      = []
+                             , md_exports   = exports
+                             , md_complete_sigs = []
+                             })
+        }
+  where
+    dflags = hsc_dflags hsc_env
+
+mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv
+mkBootTypeEnv exports ids tcs fam_insts
+  = tidyTypeEnv True $
+       typeEnvFromEntities final_ids tcs fam_insts
+  where
+        -- Find the LocalIds in the type env that are exported
+        -- Make them into GlobalIds, and tidy their types
+        --
+        -- It's very important to remove the non-exported ones
+        -- because we don't tidy the OccNames, and if we don't remove
+        -- the non-exported ones we'll get many things with the
+        -- same name in the interface file, giving chaos.
+        --
+        -- Do make sure that we keep Ids that are already Global.
+        -- When typechecking an .hs-boot file, the Ids come through as
+        -- GlobalIds.
+    final_ids = [ (if isLocalId id then globaliseAndTidyId id
+                                   else id)
+                        `setIdUnfolding` BootUnfolding
+                | id <- ids
+                , keep_it id ]
+
+        -- default methods have their export flag set, but everything
+        -- else doesn't (yet), because this is pre-desugaring, so we
+        -- must test both.
+    keep_it id = isExportedId id || idName id `elemNameSet` exports
+
+
+
+globaliseAndTidyId :: Id -> Id
+-- Takes a LocalId with an External Name,
+-- makes it into a GlobalId
+--     * unchanged Name (might be Internal or External)
+--     * unchanged details
+--     * VanillaIdInfo (makes a conservative assumption about Caf-hood)
+globaliseAndTidyId id
+  = Id.setIdType (globaliseId id) tidy_type
+  where
+    tidy_type = tidyTopType (idType id)
+
+{-
+************************************************************************
+*                                                                      *
+        Plan B: tidy bindings, make TypeEnv full of IdInfo
+*                                                                      *
+************************************************************************
+
+Plan B: include pragmas, make interfaces
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Step 1: Figure out which Ids are externally visible
+          See Note [Choosing external Ids]
+
+* Step 2: Gather the externally visible rules, separately from
+          the top-level bindings.
+          See Note [Finding external rules]
+
+* Step 3: Tidy the bindings, externalising appropriate Ids
+          See Note [Tidy the top-level bindings]
+
+* Drop all Ids from the TypeEnv, and add all the External Ids from
+  the bindings.  (This adds their IdInfo to the TypeEnv; and adds
+  floated-out Ids that weren't even in the TypeEnv before.)
+
+Note [Choosing external Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also the section "Interface stability" in the
+RecompilationAvoidance commentary:
+  http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
+
+First we figure out which Ids are "external" Ids.  An
+"external" Id is one that is visible from outside the compilation
+unit.  These are
+  a) the user exported ones
+  b) the ones bound to static forms
+  c) ones mentioned in the unfoldings, workers, or
+     rules of externally-visible ones
+
+While figuring out which Ids are external, we pick a "tidy" OccName
+for each one.  That is, we make its OccName distinct from the other
+external OccNames in this module, so that in interface files and
+object code we can refer to it unambiguously by its OccName.  The
+OccName for each binder is prefixed by the name of the exported Id
+that references it; e.g. if "f" references "x" in its unfolding, then
+"x" is renamed to "f_x".  This helps distinguish the different "x"s
+from each other, and means that if "f" is later removed, things that
+depend on the other "x"s will not need to be recompiled.  Of course,
+if there are multiple "f_x"s, then we have to disambiguate somehow; we
+use "f_x0", "f_x1" etc.
+
+As far as possible we should assign names in a deterministic fashion.
+Each time this module is compiled with the same options, we should end
+up with the same set of external names with the same types.  That is,
+the ABI hash in the interface should not change.  This turns out to be
+quite tricky, since the order of the bindings going into the tidy
+phase is already non-deterministic, as it is based on the ordering of
+Uniques, which are assigned unpredictably.
+
+To name things in a stable way, we do a depth-first-search of the
+bindings, starting from the exports sorted by name.  This way, as long
+as the bindings themselves are deterministic (they sometimes aren't!),
+the order in which they are presented to the tidying phase does not
+affect the names we assign.
+
+Note [Tidy the top-level bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Next we traverse the bindings top to bottom.  For each *top-level*
+binder
+
+ 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal,
+    reflecting the fact that from now on we regard it as a global,
+    not local, Id
+
+ 2. Give it a system-wide Unique.
+    [Even non-exported things need system-wide Uniques because the
+    byte-code generator builds a single Name->BCO symbol table.]
+
+    We use the NameCache kept in the HscEnv as the
+    source of such system-wide uniques.
+
+    For external Ids, use the original-name cache in the NameCache
+    to ensure that the unique assigned is the same as the Id had
+    in any previous compilation run.
+
+ 3. Rename top-level Ids according to the names we chose in step 1.
+    If it's an external Id, make it have a External Name, otherwise
+    make it have an Internal Name.  This is used by the code generator
+    to decide whether to make the label externally visible
+
+ 4. Give it its UTTERLY FINAL IdInfo; in ptic,
+        * its unfolding, if it should have one
+
+        * its arity, computed from the number of visible lambdas
+
+        * its CAF info, computed from what is free in its RHS
+
+
+Finally, substitute these new top-level binders consistently
+throughout, including in unfoldings.  We also tidy binders in
+RHSs, so that they print nicely in interfaces.
+-}
+
+tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
+tidyProgram hsc_env  (ModGuts { mg_module    = mod
+                              , mg_exports   = exports
+                              , mg_rdr_env   = rdr_env
+                              , mg_tcs       = tcs
+                              , mg_insts     = cls_insts
+                              , mg_fam_insts = fam_insts
+                              , mg_binds     = binds
+                              , mg_patsyns   = patsyns
+                              , mg_rules     = imp_rules
+                              , mg_anns      = anns
+                              , mg_complete_sigs = complete_sigs
+                              , mg_deps      = deps
+                              , mg_foreign   = foreign_stubs
+                              , mg_foreign_files = foreign_files
+                              , mg_hpc_info  = hpc_info
+                              , mg_modBreaks = modBreaks
+                              })
+
+  = Err.withTiming (pure dflags)
+                   (text "CoreTidy"<+>brackets (ppr mod))
+                   (const ()) $
+    do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags
+              ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags
+              ; print_unqual = mkPrintUnqualified dflags rdr_env
+              }
+
+        ; let { type_env = typeEnvFromEntities [] tcs fam_insts
+
+              ; implicit_binds
+                  = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++
+                    concatMap getTyConImplicitBinds (typeEnvTyCons type_env)
+              }
+
+        ; (unfold_env, tidy_occ_env)
+              <- chooseExternalIds hsc_env mod omit_prags expose_all
+                                   binds implicit_binds imp_rules
+        ; let { (trimmed_binds, trimmed_rules)
+                    = findExternalRules omit_prags binds imp_rules unfold_env }
+
+        ; (tidy_env, tidy_binds)
+                 <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds
+
+        ; let { final_ids  = [ id | id <- bindersOfBinds tidy_binds,
+                                    isExternalName (idName id)]
+              ; type_env1  = extendTypeEnvWithIds type_env final_ids
+
+              ; tidy_cls_insts = map (tidyClsInstDFun (tidyVarOcc tidy_env)) cls_insts
+                -- A DFunId will have a binding in tidy_binds, and so will now be in
+                -- tidy_type_env, replete with IdInfo.  Its name will be unchanged since
+                -- it was born, but we want Global, IdInfo-rich (or not) DFunId in the
+                -- tidy_cls_insts.  Similarly the Ids inside a PatSyn.
+
+              ; tidy_rules = tidyRules tidy_env trimmed_rules
+                -- You might worry that the tidy_env contains IdInfo-rich stuff
+                -- and indeed it does, but if omit_prags is on, ext_rules is
+                -- empty
+
+                -- Tidy the Ids inside each PatSyn, very similarly to DFunIds
+                -- and then override the PatSyns in the type_env with the new tidy ones
+                -- This is really the only reason we keep mg_patsyns at all; otherwise
+                -- they could just stay in type_env
+              ; tidy_patsyns = map (tidyPatSynIds (tidyVarOcc tidy_env)) patsyns
+              ; type_env2    = extendTypeEnvWithPatSyns tidy_patsyns type_env1
+
+              ; tidy_type_env = tidyTypeEnv omit_prags type_env2
+              }
+          -- See Note [Grand plan for static forms] in StaticPtrTable.
+        ; (spt_entries, tidy_binds') <-
+             sptCreateStaticBinds hsc_env mod tidy_binds
+        ; let { spt_init_code = sptModuleInitCode mod spt_entries
+              ; add_spt_init_code =
+                  case hscTarget dflags of
+                    -- If we are compiling for the interpreter we will insert
+                    -- any necessary SPT entries dynamically
+                    HscInterpreted -> id
+                    -- otherwise add a C stub to do so
+                    _              -> (`appendStubC` spt_init_code)
+              }
+
+        ; let { -- See Note [Injecting implicit bindings]
+                all_tidy_binds = implicit_binds ++ tidy_binds'
+
+              -- Get the TyCons to generate code for.  Careful!  We must use
+              -- the untidied TypeEnv here, because we need
+              --  (a) implicit TyCons arising from types and classes defined
+              --      in this module
+              --  (b) wired-in TyCons, which are normally removed from the
+              --      TypeEnv we put in the ModDetails
+              --  (c) Constructors even if they are not exported (the
+              --      tidied TypeEnv has trimmed these away)
+              ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
+              }
+
+        ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules
+
+          -- If the endPass didn't print the rules, but ddump-rules is
+          -- on, print now
+        ; unless (dopt Opt_D_dump_simpl dflags) $
+            Err.dumpIfSet_dyn dflags Opt_D_dump_rules
+              (showSDoc dflags (ppr CoreTidy <+> text "rules"))
+              (pprRulesForUser dflags tidy_rules)
+
+          -- Print one-line size info
+        ; let cs = coreBindsStats tidy_binds
+        ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats"
+            (text "Tidy size (terms,types,coercions)"
+             <+> ppr (moduleName mod) <> colon
+             <+> int (cs_tm cs)
+             <+> int (cs_ty cs)
+             <+> int (cs_co cs) )
+
+        ; return (CgGuts { cg_module   = mod,
+                           cg_tycons   = alg_tycons,
+                           cg_binds    = all_tidy_binds,
+                           cg_foreign  = add_spt_init_code foreign_stubs,
+                           cg_foreign_files = foreign_files,
+                           cg_dep_pkgs = map fst $ dep_pkgs deps,
+                           cg_hpc_info = hpc_info,
+                           cg_modBreaks = modBreaks,
+                           cg_spt_entries = spt_entries },
+
+                   ModDetails { md_types     = tidy_type_env,
+                                md_rules     = tidy_rules,
+                                md_insts     = tidy_cls_insts,
+                                md_fam_insts = fam_insts,
+                                md_exports   = exports,
+                                md_anns      = anns,      -- are already tidy
+                                md_complete_sigs = complete_sigs
+                              })
+        }
+  where
+    dflags = hsc_dflags hsc_env
+
+tidyTypeEnv :: Bool       -- Compiling without -O, so omit prags
+            -> TypeEnv -> TypeEnv
+
+-- The completed type environment is gotten from
+--      a) the types and classes defined here (plus implicit things)
+--      b) adding Ids with correct IdInfo, including unfoldings,
+--              gotten from the bindings
+-- From (b) we keep only those Ids with External names;
+--          the CoreTidy pass makes sure these are all and only
+--          the externally-accessible ones
+-- This truncates the type environment to include only the
+-- exported Ids and things needed from them, which saves space
+--
+-- See Note [Don't attempt to trim data types]
+
+tidyTypeEnv omit_prags type_env
+ = let
+        type_env1 = filterNameEnv (not . isWiredInName . getName) type_env
+          -- (1) remove wired-in things
+        type_env2 | omit_prags = mapNameEnv trimThing type_env1
+                  | otherwise  = type_env1
+          -- (2) trimmed if necessary
+    in
+    type_env2
+
+--------------------------
+trimThing :: TyThing -> TyThing
+-- Trim off inessentials, for boot files and no -O
+trimThing (AnId id)
+   | not (isImplicitId id)
+   = AnId (id `setIdInfo` vanillaIdInfo)
+
+trimThing other_thing
+  = other_thing
+
+extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv
+extendTypeEnvWithPatSyns tidy_patsyns type_env
+  = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]
+
+{-
+Note [Don't attempt to trim data types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For some time GHC tried to avoid exporting the data constructors
+of a data type if it wasn't strictly necessary to do so; see Trac #835.
+But "strictly necessary" accumulated a longer and longer list
+of exceptions, and finally I gave up the battle:
+
+    commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11
+    Author: Simon Peyton Jones <simonpj@microsoft.com>
+    Date:   Thu Dec 6 16:03:16 2012 +0000
+
+    Stop attempting to "trim" data types in interface files
+
+    Without -O, we previously tried to make interface files smaller
+    by not including the data constructors of data types.  But
+    there are a lot of exceptions, notably when Template Haskell is
+    involved or, more recently, DataKinds.
+
+    However Trac #7445 shows that even without TemplateHaskell, using
+    the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ
+    is enough to require us to expose the data constructors.
+
+    So I've given up on this "optimisation" -- it's probably not
+    important anyway.  Now I'm simply not attempting to trim off
+    the data constructors.  The gain in simplicity is worth the
+    modest cost in interface file growth, which is limited to the
+    bits reqd to describe those data constructors.
+
+************************************************************************
+*                                                                      *
+        Implicit bindings
+*                                                                      *
+************************************************************************
+
+Note [Injecting implicit bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We inject the implicit bindings right at the end, in CoreTidy.
+Some of these bindings, notably record selectors, are not
+constructed in an optimised form.  E.g. record selector for
+        data T = MkT { x :: {-# UNPACK #-} !Int }
+Then the unfolding looks like
+        x = \t. case t of MkT x1 -> let x = I# x1 in x
+This generates bad code unless it's first simplified a bit.  That is
+why CoreUnfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of
+optimisation first.  (Only matters when the selector is used curried;
+eg map x ys.)  See Trac #2070.
+
+[Oct 09: in fact, record selectors are no longer implicit Ids at all,
+because we really do want to optimise them properly. They are treated
+much like any other Id.  But doing "light" optimisation on an implicit
+Id still makes sense.]
+
+At one time I tried injecting the implicit bindings *early*, at the
+beginning of SimplCore.  But that gave rise to real difficulty,
+because GlobalIds are supposed to have *fixed* IdInfo, but the
+simplifier and other core-to-core passes mess with IdInfo all the
+time.  The straw that broke the camels back was when a class selector
+got the wrong arity -- ie the simplifier gave it arity 2, whereas
+importing modules were expecting it to have arity 1 (Trac #2844).
+It's much safer just to inject them right at the end, after tidying.
+
+Oh: two other reasons for injecting them late:
+
+  - If implicit Ids are already in the bindings when we start TidyPgm,
+    we'd have to be careful not to treat them as external Ids (in
+    the sense of chooseExternalIds); else the Ids mentioned in *their*
+    RHSs will be treated as external and you get an interface file
+    saying      a18 = <blah>
+    but nothing referring to a18 (because the implicit Id is the
+    one that does, and implicit Ids don't appear in interface files).
+
+  - More seriously, the tidied type-envt will include the implicit
+    Id replete with a18 in its unfolding; but we won't take account
+    of a18 when computing a fingerprint for the class; result chaos.
+
+There is one sort of implicit binding that is injected still later,
+namely those for data constructor workers. Reason (I think): it's
+really just a code generation trick.... binding itself makes no sense.
+See Note [Data constructor workers] in CorePrep.
+-}
+
+getTyConImplicitBinds :: TyCon -> [CoreBind]
+getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))
+
+getClassImplicitBinds :: Class -> [CoreBind]
+getClassImplicitBinds cls
+  = [ NonRec op (mkDictSelRhs cls val_index)
+    | (op, val_index) <- classAllSelIds cls `zip` [0..] ]
+
+get_defn :: Id -> CoreBind
+get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Step 1: finding externals}
+*                                                                      *
+************************************************************************
+
+See Note [Choosing external Ids].
+-}
+
+type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})
+  -- Maps each top-level Id to its new Name (the Id is tidied in step 2)
+  -- The Unique is unchanged.  If the new Name is external, it will be
+  -- visible in the interface file.
+  --
+  -- Bool => expose unfolding or not.
+
+chooseExternalIds :: HscEnv
+                  -> Module
+                  -> Bool -> Bool
+                  -> [CoreBind]
+                  -> [CoreBind]
+                  -> [CoreRule]
+                  -> IO (UnfoldEnv, TidyOccEnv)
+                  -- Step 1 from the notes above
+
+chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules
+  = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env
+       ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders
+       ; tidy_internal internal_ids unfold_env1 occ_env1 }
+ where
+  nc_var = hsc_NC hsc_env
+
+  -- init_ext_ids is the initial list of Ids that should be
+  -- externalised.  It serves as the starting point for finding a
+  -- deterministic, tidy, renaming for all external Ids in this
+  -- module.
+  --
+  -- It is sorted, so that it has a deterministic order (i.e. it's the
+  -- same list every time this module is compiled), in contrast to the
+  -- bindings, which are ordered non-deterministically.
+  init_work_list = zip init_ext_ids init_ext_ids
+  init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders
+
+  -- An Id should be external if either (a) it is exported,
+  -- (b) it appears in the RHS of a local rule for an imported Id, or
+  -- See Note [Which rules to expose]
+  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars
+
+  rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules
+
+  binders          = map fst $ flattenBinds binds
+  implicit_binders = bindersOfBinds implicit_binds
+  binder_set       = mkVarSet binders
+
+  avoids   = [getOccName name | bndr <- binders ++ implicit_binders,
+                                let name = idName bndr,
+                                isExternalName name ]
+                -- In computing our "avoids" list, we must include
+                --      all implicit Ids
+                --      all things with global names (assigned once and for
+                --                                      all by the renamer)
+                -- since their names are "taken".
+                -- The type environment is a convenient source of such things.
+                -- In particular, the set of binders doesn't include
+                -- implicit Ids at this stage.
+
+        -- We also make sure to avoid any exported binders.  Consider
+        --      f{-u1-} = 1     -- Local decl
+        --      ...
+        --      f{-u2-} = 2     -- Exported decl
+        --
+        -- The second exported decl must 'get' the name 'f', so we
+        -- have to put 'f' in the avoids list before we get to the first
+        -- decl.  tidyTopId then does a no-op on exported binders.
+  init_occ_env = initTidyOccEnv avoids
+
+
+  search :: [(Id,Id)]    -- The work-list: (external id, referring id)
+                         -- Make a tidy, external Name for the external id,
+                         --   add it to the UnfoldEnv, and do the same for the
+                         --   transitive closure of Ids it refers to
+                         -- The referring id is used to generate a tidy
+                         ---  name for the external id
+         -> UnfoldEnv    -- id -> (new Name, show_unfold)
+         -> TidyOccEnv   -- occ env for choosing new Names
+         -> IO (UnfoldEnv, TidyOccEnv)
+
+  search [] unfold_env occ_env = return (unfold_env, occ_env)
+
+  search ((idocc,referrer) : rest) unfold_env occ_env
+    | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env
+    | otherwise = do
+      (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc
+      let
+          (new_ids, show_unfold)
+                | omit_prags = ([], False)
+                | otherwise  = addExternal expose_all refined_id
+
+                -- 'idocc' is an *occurrence*, but we need to see the
+                -- unfolding in the *definition*; so look up in binder_set
+          refined_id = case lookupVarSet binder_set idocc of
+                         Just id -> id
+                         Nothing -> WARN( True, ppr idocc ) idocc
+
+          unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)
+          referrer' | isExportedId refined_id = refined_id
+                    | otherwise               = referrer
+      --
+      search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env'
+
+  tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv
+                -> IO (UnfoldEnv, TidyOccEnv)
+  tidy_internal []       unfold_env occ_env = return (unfold_env,occ_env)
+  tidy_internal (id:ids) unfold_env occ_env = do
+      (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id
+      let unfold_env' = extendVarEnv unfold_env id (name',False)
+      tidy_internal ids unfold_env' occ_env'
+
+addExternal :: Bool -> Id -> ([Id], Bool)
+addExternal expose_all id = (new_needed_ids, show_unfold)
+  where
+    new_needed_ids = bndrFvsInOrder show_unfold id
+    idinfo         = idInfo id
+    show_unfold    = show_unfolding (unfoldingInfo idinfo)
+    never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
+    loop_breaker   = isStrongLoopBreaker (occInfo idinfo)
+    bottoming_fn   = isBottomingSig (strictnessInfo idinfo)
+
+        -- Stuff to do with the Id's unfolding
+        -- We leave the unfolding there even if there is a worker
+        -- In GHCi the unfolding is used by importers
+
+    show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })
+       =  expose_all         -- 'expose_all' says to expose all
+                             -- unfoldings willy-nilly
+
+       || isStableSource src     -- Always expose things whose
+                                 -- source is an inline rule
+
+       || not (bottoming_fn      -- No need to inline bottom functions
+           || never_active       -- Or ones that say not to
+           || loop_breaker       -- Or that are loop breakers
+           || neverUnfoldGuidance guidance)
+    show_unfolding (DFunUnfolding {}) = True
+    show_unfolding _                  = False
+
+{-
+************************************************************************
+*                                                                      *
+               Deterministic free variables
+*                                                                      *
+************************************************************************
+
+We want a deterministic free-variable list.  exprFreeVars gives us
+a VarSet, which is in a non-deterministic order when converted to a
+list.  Hence, here we define a free-variable finder that returns
+the free variables in the order that they are encountered.
+
+See Note [Choosing external Ids]
+-}
+
+bndrFvsInOrder :: Bool -> Id -> [Id]
+bndrFvsInOrder show_unfold id
+  = run (dffvLetBndr show_unfold id)
+
+run :: DFFV () -> [Id]
+run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of
+                 ((_,ids),_) -> ids
+
+newtype DFFV a
+  = DFFV (VarSet              -- Envt: non-top-level things that are in scope
+                              -- we don't want to record these as free vars
+      -> (VarSet, [Var])      -- Input State: (set, list) of free vars so far
+      -> ((VarSet,[Var]),a))  -- Output state
+
+instance Functor DFFV where
+    fmap = liftM
+
+instance Applicative DFFV where
+    pure a = DFFV $ \_ st -> (st, a)
+    (<*>) = ap
+
+instance Monad DFFV where
+  (DFFV m) >>= k = DFFV $ \env st ->
+    case m env st of
+       (st',a) -> case k a of
+                     DFFV f -> f env st'
+
+extendScope :: Var -> DFFV a -> DFFV a
+extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st)
+
+extendScopeList :: [Var] -> DFFV a -> DFFV a
+extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st)
+
+insert :: Var -> DFFV ()
+insert v = DFFV $ \ env (set, ids) ->
+           let keep_me = isLocalId v &&
+                         not (v `elemVarSet` env) &&
+                           not (v `elemVarSet` set)
+           in if keep_me
+              then ((extendVarSet set v, v:ids), ())
+              else ((set,                ids),   ())
+
+
+dffvExpr :: CoreExpr -> DFFV ()
+dffvExpr (Var v)              = insert v
+dffvExpr (App e1 e2)          = dffvExpr e1 >> dffvExpr e2
+dffvExpr (Lam v e)            = extendScope v (dffvExpr e)
+dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e
+dffvExpr (Tick _other e)    = dffvExpr e
+dffvExpr (Cast e _)           = dffvExpr e
+dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e)
+dffvExpr (Let (Rec prs) e)    = extendScopeList (map fst prs) $
+                                (mapM_ dffvBind prs >> dffvExpr e)
+dffvExpr (Case e b _ as)      = dffvExpr e >> extendScope b (mapM_ dffvAlt as)
+dffvExpr _other               = return ()
+
+dffvAlt :: (t, [Var], CoreExpr) -> DFFV ()
+dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r)
+
+dffvBind :: (Id, CoreExpr) -> DFFV ()
+dffvBind(x,r)
+  | not (isId x) = dffvExpr r
+  | otherwise    = dffvLetBndr False x >> dffvExpr r
+                -- Pass False because we are doing the RHS right here
+                -- If you say True you'll get *exponential* behaviour!
+
+dffvLetBndr :: Bool -> Id -> DFFV ()
+-- Gather the free vars of the RULES and unfolding of a binder
+-- We always get the free vars of a *stable* unfolding, but
+-- for a *vanilla* one (InlineRhs), the flag controls what happens:
+--   True <=> get fvs of even a *vanilla* unfolding
+--   False <=> ignore an InlineRhs
+-- For nested bindings (call from dffvBind) we always say "False" because
+--       we are taking the fvs of the RHS anyway
+-- For top-level bindings (call from addExternal, via bndrFvsInOrder)
+--       we say "True" if we are exposing that unfolding
+dffvLetBndr vanilla_unfold id
+  = do { go_unf (unfoldingInfo idinfo)
+       ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) }
+  where
+    idinfo = idInfo id
+
+    go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
+       = case src of
+           InlineRhs | vanilla_unfold -> dffvExpr rhs
+                     | otherwise      -> return ()
+           _                          -> dffvExpr rhs
+
+    go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args })
+             = extendScopeList bndrs $ mapM_ dffvExpr args
+    go_unf _ = return ()
+
+    go_rule (BuiltinRule {}) = return ()
+    go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs })
+      = extendScopeList bndrs (dffvExpr rhs)
+
+{-
+************************************************************************
+*                                                                      *
+               findExternalRules
+*                                                                      *
+************************************************************************
+
+Note [Finding external rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The complete rules are gotten by combining
+   a) local rules for imported Ids
+   b) rules embedded in the top-level Ids
+
+There are two complications:
+  * Note [Which rules to expose]
+  * Note [Trimming auto-rules]
+
+Note [Which rules to expose]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The function 'expose_rule' filters out rules that mention, on the LHS,
+Ids that aren't externally visible; these rules can't fire in a client
+module.
+
+The externally-visible binders are computed (by chooseExternalIds)
+assuming that all orphan rules are externalised (see init_ext_ids in
+function 'search'). So in fact it's a bit conservative and we may
+export more than we need.  (It's a sort of mutual recursion.)
+
+Note [Trimming auto-rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Second, with auto-specialisation we may specialise local or imported
+dfuns or INLINE functions, and then later inline them.  That may leave
+behind something like
+   RULE "foo" forall d. f @ Int d = f_spec
+where f is either local or imported, and there is no remaining
+reference to f_spec except from the RULE.
+
+Now that RULE *might* be useful to an importing module, but that is
+purely speculative, and meanwhile the code is taking up space and
+codegen time.  I found that binary sizes jumped by 6-10% when I
+started to specialise INLINE functions (again, Note [Inline
+specialisations] in Specialise).
+
+So it seems better to drop the binding for f_spec, and the rule
+itself, if the auto-generated rule is the *only* reason that it is
+being kept alive.
+
+(The RULE still might have been useful in the past; that is, it was
+the right thing to have generated it in the first place.  See Note
+[Inline specialisations] in Specialise.  But now it has served its
+purpose, and can be discarded.)
+
+So findExternalRules does this:
+  * Remove all bindings that are kept alive *only* by isAutoRule rules
+      (this is done in trim_binds)
+  * Remove all auto rules that mention bindings that have been removed
+      (this is done by filtering by keep_rule)
+
+NB: if a binding is kept alive for some *other* reason (e.g. f_spec is
+called in the final code), we keep the rule too.
+
+This stuff is the only reason for the ru_auto field in a Rule.
+-}
+
+findExternalRules :: Bool       -- Omit pragmas
+                  -> [CoreBind]
+                  -> [CoreRule] -- Local rules for imported fns
+                  -> UnfoldEnv  -- Ids that are exported, so we need their rules
+                  -> ([CoreBind], [CoreRule])
+-- See Note [Finding external rules]
+findExternalRules omit_prags binds imp_id_rules unfold_env
+  = (trimmed_binds, filter keep_rule all_rules)
+  where
+    imp_rules         = filter expose_rule imp_id_rules
+    imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules
+
+    user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet
+                           | otherwise       = ruleRhsFreeVars rule
+
+    (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds
+
+    keep_rule rule = ruleFreeVars rule `subVarSet` local_bndrs
+        -- Remove rules that make no sense, because they mention a
+        -- local binder (on LHS or RHS) that we have now discarded.
+        -- (NB: ruleFreeVars only includes LocalIds)
+        --
+        -- LHS: we have already filtered out rules that mention internal Ids
+        --     on LHS but that isn't enough because we might have by now
+        --     discarded a binding with an external Id. (How?
+        --     chooseExternalIds is a bit conservative.)
+        --
+        -- RHS: the auto rules that might mention a binder that has
+        --      been discarded; see Note [Trimming auto-rules]
+
+    expose_rule rule
+        | omit_prags = False
+        | otherwise  = all is_external_id (ruleLhsFreeIdsList rule)
+                -- Don't expose a rule whose LHS mentions a locally-defined
+                -- Id that is completely internal (i.e. not visible to an
+                -- importing module).  NB: ruleLhsFreeIds only returns LocalIds.
+                -- See Note [Which rules to expose]
+
+    is_external_id id = case lookupVarEnv unfold_env id of
+                          Just (name, _) -> isExternalName name
+                          Nothing        -> False
+
+    trim_binds :: [CoreBind]
+               -> ( [CoreBind]   -- Trimmed bindings
+                  , VarSet       -- Binders of those bindings
+                  , VarSet       -- Free vars of those bindings + rhs of user rules
+                                 -- (we don't bother to delete the binders)
+                  , [CoreRule])  -- All rules, imported + from the bindings
+    -- This function removes unnecessary bindings, and gathers up rules from
+    -- the bindings we keep.  See Note [Trimming auto-rules]
+    trim_binds []  -- Base case, start with imp_user_rule_fvs
+       = ([], emptyVarSet, imp_user_rule_fvs, imp_rules)
+
+    trim_binds (bind:binds)
+       | any needed bndrs    -- Keep binding
+       = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules )
+       | otherwise           -- Discard binding altogether
+       = stuff
+       where
+         stuff@(binds', bndr_set, needed_fvs, rules)
+                       = trim_binds binds
+         needed bndr   = isExportedId bndr || bndr `elemVarSet` needed_fvs
+
+         bndrs         = bindersOf  bind
+         rhss          = rhssOfBind bind
+         bndr_set'     = bndr_set `extendVarSetList` bndrs
+
+         needed_fvs'   = needed_fvs                                   `unionVarSet`
+                         mapUnionVarSet idUnfoldingVars   bndrs       `unionVarSet`
+                              -- Ignore type variables in the type of bndrs
+                         mapUnionVarSet exprFreeVars      rhss        `unionVarSet`
+                         mapUnionVarSet user_rule_rhs_fvs local_rules
+            -- In needed_fvs', we don't bother to delete binders from the fv set
+
+         local_rules  = [ rule
+                        | id <- bndrs
+                        , is_external_id id   -- Only collect rules for external Ids
+                        , rule <- idCoreRules id
+                        , expose_rule rule ]  -- and ones that can fire in a client
+
+{-
+************************************************************************
+*                                                                      *
+               tidyTopName
+*                                                                      *
+************************************************************************
+
+This is where we set names to local/global based on whether they really are
+externally visible (see comment at the top of this module).  If the name
+was previously local, we have to give it a unique occurrence name if
+we intend to externalise it.
+-}
+
+tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv
+            -> Id -> IO (TidyOccEnv, Name)
+tidyTopName mod nc_var maybe_ref occ_env id
+  | global && internal = return (occ_env, localiseName name)
+
+  | global && external = return (occ_env, name)
+        -- Global names are assumed to have been allocated by the renamer,
+        -- so they already have the "right" unique
+        -- And it's a system-wide unique too
+
+  -- Now we get to the real reason that all this is in the IO Monad:
+  -- we have to update the name cache in a nice atomic fashion
+
+  | local  && internal = do { new_local_name <- atomicModifyIORef' nc_var mk_new_local
+                            ; return (occ_env', new_local_name) }
+        -- Even local, internal names must get a unique occurrence, because
+        -- if we do -split-objs we externalise the name later, in the code generator
+        --
+        -- Similarly, we must make sure it has a system-wide Unique, because
+        -- the byte-code generator builds a system-wide Name->BCO symbol table
+
+  | local  && external = do { new_external_name <- atomicModifyIORef' nc_var mk_new_external
+                            ; return (occ_env', new_external_name) }
+
+  | otherwise = panic "tidyTopName"
+  where
+    name        = idName id
+    external    = isJust maybe_ref
+    global      = isExternalName name
+    local       = not global
+    internal    = not external
+    loc         = nameSrcSpan name
+
+    old_occ     = nameOccName name
+    new_occ | Just ref <- maybe_ref
+            , ref /= id
+            = mkOccName (occNameSpace old_occ) $
+                   let
+                       ref_str = occNameString (getOccName ref)
+                       occ_str = occNameString old_occ
+                   in
+                   case occ_str of
+                     '$':'w':_ -> occ_str
+                        -- workers: the worker for a function already
+                        -- includes the occname for its parent, so there's
+                        -- no need to prepend the referrer.
+                     _other | isSystemName name -> ref_str
+                            | otherwise         -> ref_str ++ '_' : occ_str
+                        -- If this name was system-generated, then don't bother
+                        -- to retain its OccName, just use the referrer.  These
+                        -- system-generated names will become "f1", "f2", etc. for
+                        -- a referrer "f".
+            | otherwise = old_occ
+
+    (occ_env', occ') = tidyOccName occ_env new_occ
+
+    mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc)
+                    where
+                      (uniq, us) = takeUniqFromSupply (nsUniqs nc)
+
+    mk_new_external nc = allocateGlobalBinder nc mod occ' loc
+        -- If we want to externalise a currently-local name, check
+        -- whether we have already assigned a unique for it.
+        -- If so, use it; if not, extend the table.
+        -- All this is done by allcoateGlobalBinder.
+        -- This is needed when *re*-compiling a module in GHCi; we must
+        -- use the same name for externally-visible things as we did before.
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Step 2: top-level tidying}
+*                                                                      *
+************************************************************************
+-}
+
+-- TopTidyEnv: when tidying we need to know
+--   * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.
+--        These may have arisen because the
+--        renamer read in an interface file mentioning M.$wf, say,
+--        and assigned it unique r77.  If, on this compilation, we've
+--        invented an Id whose name is $wf (but with a different unique)
+--        we want to rename it to have unique r77, so that we can do easy
+--        comparisons with stuff from the interface file
+--
+--   * occ_env: The TidyOccEnv, which tells us which local occurrences
+--     are 'used'
+--
+--   * subst_env: A Var->Var mapping that substitutes the new Var for the old
+
+tidyTopBinds :: HscEnv
+             -> Module
+             -> UnfoldEnv
+             -> TidyOccEnv
+             -> CoreProgram
+             -> IO (TidyEnv, CoreProgram)
+
+tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
+  = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
+       mkNaturalId <- lookupMkNaturalName dflags hsc_env
+       integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
+       naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env
+       let cvt_literal nt i = case nt of
+             LitNumInteger -> Just (cvtLitInteger dflags mkIntegerId integerSDataCon i)
+             LitNumNatural -> Just (cvtLitNatural dflags mkNaturalId naturalSDataCon i)
+             _             -> Nothing
+           result      = tidy cvt_literal init_env binds
+       seqBinds (snd result) `seq` return result
+       -- This seqBinds avoids a spike in space usage (see #13564)
+  where
+    dflags = hsc_dflags hsc_env
+
+    init_env = (init_occ_env, emptyVarEnv)
+
+    tidy _           env []     = (env, [])
+    tidy cvt_literal env (b:bs)
+        = let (env1, b')  = tidyTopBind dflags this_mod cvt_literal unfold_env
+                                        env b
+              (env2, bs') = tidy cvt_literal env1 bs
+          in  (env2, b':bs')
+
+------------------------
+tidyTopBind  :: DynFlags
+             -> Module
+             -> (LitNumType -> Integer -> Maybe CoreExpr)
+             -> UnfoldEnv
+             -> TidyEnv
+             -> CoreBind
+             -> (TidyEnv, CoreBind)
+
+tidyTopBind dflags this_mod cvt_literal unfold_env
+            (occ_env,subst1) (NonRec bndr rhs)
+  = (tidy_env2,  NonRec bndr' rhs')
+  where
+    Just (name',show_unfold) = lookupVarEnv unfold_env bndr
+    caf_info      = hasCafRefs dflags this_mod
+                               (subst1, cvt_literal)
+                               (idArity bndr) rhs
+    (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name'
+                                (bndr, rhs)
+    subst2        = extendVarEnv subst1 bndr bndr'
+    tidy_env2     = (occ_env, subst2)
+
+tidyTopBind dflags this_mod cvt_literal unfold_env
+            (occ_env, subst1) (Rec prs)
+  = (tidy_env2, Rec prs')
+  where
+    prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs)
+           | (id,rhs) <- prs,
+             let (name',show_unfold) =
+                    expectJust "tidyTopBind" $ lookupVarEnv unfold_env id
+           ]
+
+    subst2    = extendVarEnvList subst1 (bndrs `zip` map fst prs')
+    tidy_env2 = (occ_env, subst2)
+
+    bndrs = map fst prs
+
+        -- the CafInfo for a recursive group says whether *any* rhs in
+        -- the group may refer indirectly to a CAF (because then, they all do).
+    caf_info
+        | or [ mayHaveCafRefs (hasCafRefs dflags this_mod
+                                          (subst1, cvt_literal)
+                                          (idArity bndr) rhs)
+             | (bndr,rhs) <- prs ] = MayHaveCafRefs
+        | otherwise                = NoCafRefs
+
+-----------------------------------------------------------
+tidyTopPair :: DynFlags
+            -> Bool  -- show unfolding
+            -> TidyEnv  -- The TidyEnv is used to tidy the IdInfo
+                        -- It is knot-tied: don't look at it!
+            -> CafInfo
+            -> Name             -- New name
+            -> (Id, CoreExpr)   -- Binder and RHS before tidying
+            -> (Id, CoreExpr)
+        -- This function is the heart of Step 2
+        -- The rec_tidy_env is the one to use for the IdInfo
+        -- It's necessary because when we are dealing with a recursive
+        -- group, a variable late in the group might be mentioned
+        -- in the IdInfo of one early in the group
+
+tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs)
+  = (bndr1, rhs1)
+  where
+    bndr1    = mkGlobalId details name' ty' idinfo'
+    details  = idDetails bndr   -- Preserve the IdDetails
+    ty'      = tidyTopType (idType bndr)
+    rhs1     = tidyExpr rhs_tidy_env rhs
+    idinfo'  = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr)
+                             show_unfold caf_info
+
+-- tidyTopIdInfo creates the final IdInfo for top-level
+-- binders.  There are two delicate pieces:
+--
+--  * Arity.  After CoreTidy, this arity must not change any more.
+--      Indeed, CorePrep must eta expand where necessary to make
+--      the manifest arity equal to the claimed arity.
+--
+--  * CAF info.  This must also remain valid through to code generation.
+--      We add the info here so that it propagates to all
+--      occurrences of the binders in RHSs, and hence to occurrences in
+--      unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
+--      CoreToStg makes use of this when constructing SRTs.
+tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr
+              -> IdInfo -> Bool -> CafInfo -> IdInfo
+tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info
+  | not is_external     -- For internal Ids (not externally visible)
+  = vanillaIdInfo       -- we only need enough info for code generation
+                        -- Arity and strictness info are enough;
+                        --      c.f. CoreTidy.tidyLetBndr
+        `setCafInfo`        caf_info
+        `setArityInfo`      arity
+        `setStrictnessInfo` final_sig
+        `setUnfoldingInfo`  minimal_unfold_info  -- See note [Preserve evaluatedness]
+                                                 -- in CoreTidy
+
+  | otherwise           -- Externally-visible Ids get the whole lot
+  = vanillaIdInfo
+        `setCafInfo`           caf_info
+        `setArityInfo`         arity
+        `setStrictnessInfo`    final_sig
+        `setOccInfo`           robust_occ_info
+        `setInlinePragInfo`    (inlinePragInfo idinfo)
+        `setUnfoldingInfo`     unfold_info
+                -- NB: we throw away the Rules
+                -- They have already been extracted by findExternalRules
+  where
+    is_external = isExternalName name
+
+    --------- OccInfo ------------
+    robust_occ_info = zapFragileOcc (occInfo idinfo)
+    -- It's important to keep loop-breaker information
+    -- when we are doing -fexpose-all-unfoldings
+
+    --------- Strictness ------------
+    mb_bot_str = exprBotStrictness_maybe orig_rhs
+
+    sig = strictnessInfo idinfo
+    final_sig | not $ isTopSig sig
+              = WARN( _bottom_hidden sig , ppr name ) sig
+              -- try a cheap-and-cheerful bottom analyser
+              | Just (_, nsig) <- mb_bot_str = nsig
+              | otherwise                    = sig
+
+    _bottom_hidden id_sig = case mb_bot_str of
+                                  Nothing         -> False
+                                  Just (arity, _) -> not (appIsBottom id_sig arity)
+
+    --------- Unfolding ------------
+    unf_info = unfoldingInfo idinfo
+    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
+                | otherwise   = minimal_unfold_info
+    minimal_unfold_info = zapUnfolding unf_info
+    unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs
+    is_bot = isBottomingSig final_sig
+    -- NB: do *not* expose the worker if show_unfold is off,
+    --     because that means this thing is a loop breaker or
+    --     marked NOINLINE or something like that
+    -- This is important: if you expose the worker for a loop-breaker
+    -- then you can make the simplifier go into an infinite loop, because
+    -- in effect the unfolding is exposed.  See Trac #1709
+    --
+    -- You might think that if show_unfold is False, then the thing should
+    -- not be w/w'd in the first place.  But a legitimate reason is this:
+    --    the function returns bottom
+    -- In this case, show_unfold will be false (we don't expose unfoldings
+    -- for bottoming functions), but we might still have a worker/wrapper
+    -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.hs
+
+
+    --------- Arity ------------
+    -- Usually the Id will have an accurate arity on it, because
+    -- the simplifier has just run, but not always.
+    -- One case I found was when the last thing the simplifier
+    -- did was to let-bind a non-atomic argument and then float
+    -- it to the top level. So it seems more robust just to
+    -- fix it here.
+    arity = exprArity orig_rhs
+
+{-
+************************************************************************
+*                                                                      *
+           Figuring out CafInfo for an expression
+*                                                                      *
+************************************************************************
+
+hasCafRefs decides whether a top-level closure can point into the dynamic heap.
+We mark such things as `MayHaveCafRefs' because this information is
+used to decide whether a particular closure needs to be referenced
+in an SRT or not.
+
+There are two reasons for setting MayHaveCafRefs:
+        a) The RHS is a CAF: a top-level updatable thunk.
+        b) The RHS refers to something that MayHaveCafRefs
+
+Possible improvement: In an effort to keep the number of CAFs (and
+hence the size of the SRTs) down, we could also look at the expression and
+decide whether it requires a small bounded amount of heap, so we can ignore
+it as a CAF.  In these cases however, we would need to use an additional
+CAF list to keep track of non-collectable CAFs.
+
+Note [Disgusting computation of CafRefs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We compute hasCafRefs here, because IdInfo is supposed to be finalised
+after TidyPgm.  But CorePrep does some transformations that affect CAF-hood.
+So we have to *predict* the result here, which is revolting.
+
+In particular CorePrep expands Integer and Natural literals. So in the
+prediction code here we resort to applying the same expansion (cvt_literal).
+Ugh!
+-}
+
+type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr)
+  -- The env finds the Caf-ness of the Id
+  -- The LitNumType -> Integer -> CoreExpr is the desugaring functions for
+  -- Integer and Natural literals
+  -- See Note [Disgusting computation of CafRefs]
+
+hasCafRefs :: DynFlags -> Module
+           -> CafRefEnv -> Arity -> CoreExpr
+           -> CafInfo
+hasCafRefs dflags this_mod (subst, cvt_literal) arity expr
+  | is_caf || mentions_cafs = MayHaveCafRefs
+  | otherwise               = NoCafRefs
+ where
+  mentions_cafs   = cafRefsE expr
+  is_dynamic_name = isDllName dflags this_mod
+  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name
+                                         cvt_literal expr)
+
+  -- NB. we pass in the arity of the expression, which is expected
+  -- to be calculated by exprArity.  This is because exprArity
+  -- knows how much eta expansion is going to be done by
+  -- CorePrep later on, and we don't want to duplicate that
+  -- knowledge in rhsIsStatic below.
+
+  cafRefsE :: Expr a -> Bool
+  cafRefsE (Var id)            = cafRefsV id
+  cafRefsE (Lit lit)           = cafRefsL lit
+  cafRefsE (App f a)           = cafRefsE f || cafRefsE a
+  cafRefsE (Lam _ e)           = cafRefsE e
+  cafRefsE (Let b e)           = cafRefsEs (rhssOfBind b) || cafRefsE e
+  cafRefsE (Case e _ _ alts)   = cafRefsE e || cafRefsEs (rhssOfAlts alts)
+  cafRefsE (Tick _n e)         = cafRefsE e
+  cafRefsE (Cast e _co)        = cafRefsE e
+  cafRefsE (Type _)            = False
+  cafRefsE (Coercion _)        = False
+
+  cafRefsEs :: [Expr a] -> Bool
+  cafRefsEs []     = False
+  cafRefsEs (e:es) = cafRefsE e || cafRefsEs es
+
+  cafRefsL :: Literal -> Bool
+  -- Don't forget that mk_integer id might have Caf refs!
+  -- We first need to convert the Integer into its final form, to
+  -- see whether mkInteger is used. Same for LitNatural.
+  cafRefsL (LitNumber nt i _) = case cvt_literal nt i of
+    Just e  -> cafRefsE e
+    Nothing -> False
+  cafRefsL _                = False
+
+  cafRefsV :: Id -> Bool
+  cafRefsV id
+    | not (isLocalId id)                = mayHaveCafRefs (idCafInfo id)
+    | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id')
+    | otherwise                         = False
+
+
+{-
+************************************************************************
+*                                                                      *
+                  Old, dead, type-trimming code
+*                                                                      *
+************************************************************************
+
+We used to try to "trim off" the constructors of data types that are
+not exported, to reduce the size of interface files, at least without
+-O.  But that is not always possible: see the old Note [When we can't
+trim types] below for exceptions.
+
+Then (Trac #7445) I realised that the TH problem arises for any data type
+that we have deriving( Data ), because we can invoke
+   Language.Haskell.TH.Quote.dataToExpQ
+to get a TH Exp representation of a value built from that data type.
+You don't even need {-# LANGUAGE TemplateHaskell #-}.
+
+At this point I give up. The pain of trimming constructors just
+doesn't seem worth the gain.  So I've dumped all the code, and am just
+leaving it here at the end of the module in case something like this
+is ever resurrected.
+
+
+Note [When we can't trim types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The basic idea of type trimming is to export algebraic data types
+abstractly (without their data constructors) when compiling without
+-O, unless of course they are explicitly exported by the user.
+
+We always export synonyms, because they can be mentioned in the type
+of an exported Id.  We could do a full dependency analysis starting
+from the explicit exports, but that's quite painful, and not done for
+now.
+
+But there are some times we can't do that, indicated by the 'no_trim_types' flag.
+
+First, Template Haskell.  Consider (Trac #2386) this
+        module M(T, makeOne) where
+          data T = Yay String
+          makeOne = [| Yay "Yep" |]
+Notice that T is exported abstractly, but makeOne effectively exports it too!
+A module that splices in $(makeOne) will then look for a declaration of Yay,
+so it'd better be there.  Hence, brutally but simply, we switch off type
+constructor trimming if TH is enabled in this module.
+
+Second, data kinds.  Consider (Trac #5912)
+     {-# LANGUAGE DataKinds #-}
+     module M() where
+     data UnaryTypeC a = UnaryDataC a
+     type Bug = 'UnaryDataC
+We always export synonyms, so Bug is exposed, and that means that
+UnaryTypeC must be too, even though it's not explicitly exported.  In
+effect, DataKinds means that we'd need to do a full dependency analysis
+to see what data constructors are mentioned.  But we don't do that yet.
+
+In these two cases we just switch off type trimming altogether.
+
+mustExposeTyCon :: Bool         -- Type-trimming flag
+                -> NameSet      -- Exports
+                -> TyCon        -- The tycon
+                -> Bool         -- Can its rep be hidden?
+-- We are compiling without -O, and thus trying to write as little as
+-- possible into the interface file.  But we must expose the details of
+-- any data types whose constructors or fields are exported
+mustExposeTyCon no_trim_types exports tc
+  | no_trim_types               -- See Note [When we can't trim types]
+  = True
+
+  | not (isAlgTyCon tc)         -- Always expose synonyms (otherwise we'd have to
+                                -- figure out whether it was mentioned in the type
+                                -- of any other exported thing)
+  = True
+
+  | isEnumerationTyCon tc       -- For an enumeration, exposing the constructors
+  = True                        -- won't lead to the need for further exposure
+
+  | isFamilyTyCon tc            -- Open type family
+  = True
+
+  -- Below here we just have data/newtype decls or family instances
+
+  | null data_cons              -- Ditto if there are no data constructors
+  = True                        -- (NB: empty data types do not count as enumerations
+                                -- see Note [Enumeration types] in TyCon
+
+  | any exported_con data_cons  -- Expose rep if any datacon or field is exported
+  = True
+
+  | isNewTyCon tc && isFFITy (snd (newTyConRhs tc))
+  = True   -- Expose the rep for newtypes if the rep is an FFI type.
+           -- For a very annoying reason.  'Foreign import' is meant to
+           -- be able to look through newtypes transparently, but it
+           -- can only do that if it can "see" the newtype representation
+
+  | otherwise
+  = False
+  where
+    data_cons = tyConDataCons tc
+    exported_con con = any (`elemNameSet` exports)
+                           (dataConName con : dataConFieldLabels con)
+-}
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -0,0 +1,1224 @@
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 1993-2004
+--
+-- This is the top-level module in the native code generator.
+--
+-- -----------------------------------------------------------------------------
+
+{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, UnboxedTuples #-}
+
+module AsmCodeGen (
+                    -- * Module entry point
+                    nativeCodeGen
+
+                    -- * Test-only exports: see trac #12744
+                    -- used by testGraphNoSpills, which needs to access
+                    -- the register allocator intermediate data structures
+                    -- cmmNativeGen emits
+                  , cmmNativeGen
+                  , NcgImpl(..)
+                  , x86NcgImpl
+                  ) where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+
+import GhcPrelude
+
+import qualified X86.CodeGen
+import qualified X86.Regs
+import qualified X86.Instr
+import qualified X86.Ppr
+
+import qualified SPARC.CodeGen
+import qualified SPARC.Regs
+import qualified SPARC.Instr
+import qualified SPARC.Ppr
+import qualified SPARC.ShortcutJump
+import qualified SPARC.CodeGen.Expand
+
+import qualified PPC.CodeGen
+import qualified PPC.Regs
+import qualified PPC.RegInfo
+import qualified PPC.Instr
+import qualified PPC.Ppr
+
+import RegAlloc.Liveness
+import qualified RegAlloc.Linear.Main           as Linear
+
+import qualified GraphColor                     as Color
+import qualified RegAlloc.Graph.Main            as Color
+import qualified RegAlloc.Graph.Stats           as Color
+import qualified RegAlloc.Graph.TrivColorable   as Color
+
+import AsmUtils
+import TargetReg
+import Platform
+import BlockLayout
+import Config
+import Instruction
+import PIC
+import Reg
+import NCGMonad
+import CFG
+import Dwarf
+import Debug
+
+import BlockId
+import CgUtils          ( fixStgRegisters )
+import Cmm
+import CmmUtils
+import Hoopl.Collections
+import Hoopl.Label
+import Hoopl.Block
+import CmmOpt           ( cmmMachOpFold )
+import PprCmm
+import CLabel
+
+import UniqFM
+import UniqSupply
+import DynFlags
+import Util
+
+import BasicTypes       ( Alignment )
+import qualified Pretty
+import BufWrite
+import Outputable
+import FastString
+import UniqSet
+import ErrUtils
+import Module
+import Stream (Stream)
+import qualified Stream
+
+-- DEBUGGING ONLY
+--import OrdList
+
+import Data.List
+import Data.Maybe
+import Data.Ord         ( comparing )
+import Control.Exception
+import Control.Monad
+import System.IO
+
+{-
+The native-code generator has machine-independent and
+machine-dependent modules.
+
+This module ("AsmCodeGen") is the top-level machine-independent
+module.  Before entering machine-dependent land, we do some
+machine-independent optimisations (defined below) on the
+'CmmStmts's.
+
+We convert to the machine-specific 'Instr' datatype with
+'cmmCodeGen', assuming an infinite supply of registers.  We then use
+a machine-independent register allocator ('regAlloc') to rejoin
+reality.  Obviously, 'regAlloc' has machine-specific helper
+functions (see about "RegAllocInfo" below).
+
+Finally, we order the basic blocks of the function so as to minimise
+the number of jumps between blocks, by utilising fallthrough wherever
+possible.
+
+The machine-dependent bits break down as follows:
+
+  * ["MachRegs"]  Everything about the target platform's machine
+    registers (and immediate operands, and addresses, which tend to
+    intermingle/interact with registers).
+
+  * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should
+    have a module of its own), plus a miscellany of other things
+    (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)
+
+  * ["MachCodeGen"]  is where 'Cmm' stuff turns into
+    machine instructions.
+
+  * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
+    a 'SDoc').
+
+  * ["RegAllocInfo"] In the register allocator, we manipulate
+    'MRegsState's, which are 'BitSet's, one bit per machine register.
+    When we want to say something about a specific machine register
+    (e.g., ``it gets clobbered by this instruction''), we set/unset
+    its bit.  Obviously, we do this 'BitSet' thing for efficiency
+    reasons.
+
+    The 'RegAllocInfo' module collects together the machine-specific
+    info needed to do register allocation.
+
+   * ["RegisterAlloc"] The (machine-independent) register allocator.
+-}
+
+--------------------
+nativeCodeGen :: DynFlags -> Module -> ModLocation -> Handle -> UniqSupply
+              -> Stream IO RawCmmGroup ()
+              -> IO UniqSupply
+nativeCodeGen dflags this_mod modLoc h us cmms
+ = let platform = targetPlatform dflags
+       nCG' :: ( Outputable statics, Outputable instr
+               , Outputable jumpDest, Instruction instr)
+            => NcgImpl statics instr jumpDest -> IO UniqSupply
+       nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
+   in case platformArch platform of
+      ArchX86       -> nCG' (x86NcgImpl    dflags)
+      ArchX86_64    -> nCG' (x86_64NcgImpl dflags)
+      ArchPPC       -> nCG' (ppcNcgImpl    dflags)
+      ArchSPARC     -> nCG' (sparcNcgImpl  dflags)
+      ArchSPARC64   -> panic "nativeCodeGen: No NCG for SPARC64"
+      ArchARM {}    -> panic "nativeCodeGen: No NCG for ARM"
+      ArchARM64     -> panic "nativeCodeGen: No NCG for ARM64"
+      ArchPPC_64 _  -> nCG' (ppcNcgImpl    dflags)
+      ArchAlpha     -> panic "nativeCodeGen: No NCG for Alpha"
+      ArchMipseb    -> panic "nativeCodeGen: No NCG for mipseb"
+      ArchMipsel    -> panic "nativeCodeGen: No NCG for mipsel"
+      ArchUnknown   -> panic "nativeCodeGen: No NCG for unknown arch"
+      ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"
+
+x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics)
+                                  X86.Instr.Instr X86.Instr.JumpDest
+x86NcgImpl dflags
+ = (x86_64NcgImpl dflags) { ncg_x86fp_kludge = map x86fp_kludge }
+
+x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics)
+                                  X86.Instr.Instr X86.Instr.JumpDest
+x86_64NcgImpl dflags
+ = NcgImpl {
+        cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen
+       ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags
+       ,getJumpDestBlockId        = X86.Instr.getJumpDestBlockId
+       ,canShortcut               = X86.Instr.canShortcut
+       ,shortcutStatics           = X86.Instr.shortcutStatics
+       ,shortcutJump              = X86.Instr.shortcutJump
+       ,pprNatCmmDecl             = X86.Ppr.pprNatCmmDecl
+       ,maxSpillSlots             = X86.Instr.maxSpillSlots dflags
+       ,allocatableRegs           = X86.Regs.allocatableRegs platform
+       ,ncg_x86fp_kludge          = id
+       ,ncgAllocMoreStack         = X86.Instr.allocMoreStack platform
+       ,ncgExpandTop              = id
+       ,ncgMakeFarBranches        = const id
+       ,extractUnwindPoints       = X86.CodeGen.extractUnwindPoints
+       ,invertCondBranches        = X86.CodeGen.invertCondBranches
+   }
+    where platform = targetPlatform dflags
+
+ppcNcgImpl :: DynFlags -> NcgImpl CmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest
+ppcNcgImpl dflags
+ = NcgImpl {
+        cmmTopCodeGen             = PPC.CodeGen.cmmTopCodeGen
+       ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags
+       ,getJumpDestBlockId        = PPC.RegInfo.getJumpDestBlockId
+       ,canShortcut               = PPC.RegInfo.canShortcut
+       ,shortcutStatics           = PPC.RegInfo.shortcutStatics
+       ,shortcutJump              = PPC.RegInfo.shortcutJump
+       ,pprNatCmmDecl             = PPC.Ppr.pprNatCmmDecl
+       ,maxSpillSlots             = PPC.Instr.maxSpillSlots dflags
+       ,allocatableRegs           = PPC.Regs.allocatableRegs platform
+       ,ncg_x86fp_kludge          = id
+       ,ncgAllocMoreStack         = PPC.Instr.allocMoreStack platform
+       ,ncgExpandTop              = id
+       ,ncgMakeFarBranches        = PPC.Instr.makeFarBranches
+       ,extractUnwindPoints       = const []
+       ,invertCondBranches        = \_ _ -> id
+   }
+    where platform = targetPlatform dflags
+
+sparcNcgImpl :: DynFlags -> NcgImpl CmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest
+sparcNcgImpl dflags
+ = NcgImpl {
+        cmmTopCodeGen             = SPARC.CodeGen.cmmTopCodeGen
+       ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags
+       ,getJumpDestBlockId        = SPARC.ShortcutJump.getJumpDestBlockId
+       ,canShortcut               = SPARC.ShortcutJump.canShortcut
+       ,shortcutStatics           = SPARC.ShortcutJump.shortcutStatics
+       ,shortcutJump              = SPARC.ShortcutJump.shortcutJump
+       ,pprNatCmmDecl             = SPARC.Ppr.pprNatCmmDecl
+       ,maxSpillSlots             = SPARC.Instr.maxSpillSlots dflags
+       ,allocatableRegs           = SPARC.Regs.allocatableRegs
+       ,ncg_x86fp_kludge          = id
+       ,ncgAllocMoreStack         = noAllocMoreStack
+       ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop
+       ,ncgMakeFarBranches        = const id
+       ,extractUnwindPoints       = const []
+       ,invertCondBranches        = \_ _ -> id
+   }
+
+--
+-- Allocating more stack space for spilling is currently only
+-- supported for the linear register allocator on x86/x86_64, the rest
+-- default to the panic below.  To support allocating extra stack on
+-- more platforms provide a definition of ncgAllocMoreStack.
+--
+noAllocMoreStack :: Int -> NatCmmDecl statics instr
+                 -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)])
+noAllocMoreStack amount _
+  = panic $   "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"
+        ++  "   If you are trying to compile SHA1.hs from the crypto library then this\n"
+        ++  "   is a known limitation in the linear allocator.\n"
+        ++  "\n"
+        ++  "   Try enabling the graph colouring allocator with -fregs-graph instead."
+        ++  "   You can still file a bug report if you like.\n"
+
+
+-- | Data accumulated during code generation. Mostly about statistics,
+-- but also collects debug data for DWARF generation.
+data NativeGenAcc statics instr
+  = NGS { ngs_imports     :: ![[CLabel]]
+        , ngs_natives     :: ![[NatCmmDecl statics instr]]
+             -- ^ Native code generated, for statistics. This might
+             -- hold a lot of data, so it is important to clear this
+             -- field as early as possible if it isn't actually
+             -- required.
+        , ngs_colorStats  :: ![[Color.RegAllocStats statics instr]]
+        , ngs_linearStats :: ![[Linear.RegAllocStats]]
+        , ngs_labels      :: ![Label]
+        , ngs_debug       :: ![DebugBlock]
+        , ngs_dwarfFiles  :: !DwarfFiles
+        , ngs_unwinds     :: !(LabelMap [UnwindPoint])
+             -- ^ see Note [Unwinding information in the NCG]
+             -- and Note [What is this unwinding business?] in Debug.
+        }
+
+{-
+Note [Unwinding information in the NCG]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Unwind information is a type of metadata which allows a debugging tool
+to reconstruct the values of machine registers at the time a procedure was
+entered. For the most part, the production of unwind information is handled by
+the Cmm stage, where it is represented by CmmUnwind nodes.
+
+Unfortunately, the Cmm stage doesn't know everything necessary to produce
+accurate unwinding information. For instance, the x86-64 calling convention
+requires that the stack pointer be aligned to 16 bytes, which in turn means that
+GHC must sometimes add padding to $sp prior to performing a foreign call. When
+this happens unwind information must be updated accordingly.
+For this reason, we make the NCG backends responsible for producing
+unwinding tables (with the extractUnwindPoints function in NcgImpl).
+
+We accumulate the produced unwind tables over CmmGroups in the ngs_unwinds
+field of NativeGenAcc. This is a label map which contains an entry for each
+procedure, containing a list of unwinding points (e.g. a label and an associated
+unwinding table).
+
+See also Note [What is this unwinding business?] in Debug.
+-}
+
+nativeCodeGen' :: (Outputable statics, Outputable instr,Outputable jumpDest,
+                   Instruction instr)
+               => DynFlags
+               -> Module -> ModLocation
+               -> NcgImpl statics instr jumpDest
+               -> Handle
+               -> UniqSupply
+               -> Stream IO RawCmmGroup ()
+               -> IO UniqSupply
+nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
+ = do
+        -- BufHandle is a performance hack.  We could hide it inside
+        -- Pretty if it weren't for the fact that we do lots of little
+        -- printDocs here (in order to do codegen in constant space).
+        bufh <- newBufHandle h
+        let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty
+        (ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us
+                                         cmms ngs0
+        finishNativeGen dflags modLoc bufh us' ngs
+
+finishNativeGen :: Instruction instr
+                => DynFlags
+                -> ModLocation
+                -> BufHandle
+                -> UniqSupply
+                -> NativeGenAcc statics instr
+                -> IO UniqSupply
+finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
+ = do
+        -- Write debug data and finish
+        let emitDw = debugLevel dflags > 0 && not (gopt Opt_SplitObjs dflags)
+        us' <- if not emitDw then return us else do
+          (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs)
+          emitNativeCode dflags bufh dwarf
+          return us'
+        bFlush bufh
+
+        -- dump global NCG stats for graph coloring allocator
+        let stats = concat (ngs_colorStats ngs)
+        when (not (null stats)) $ do
+
+          -- build the global register conflict graph
+          let graphGlobal
+                  = foldl' Color.union Color.initGraph
+                  $ [ Color.raGraph stat
+                          | stat@Color.RegAllocStatsStart{} <- stats]
+
+          dump_stats (Color.pprStats stats graphGlobal)
+
+          let platform = targetPlatform dflags
+          dumpIfSet_dyn dflags
+                  Opt_D_dump_asm_conflicts "Register conflict graph"
+                  $ Color.dotGraph
+                          (targetRegDotColor platform)
+                          (Color.trivColorable platform
+                                  (targetVirtualRegSqueeze platform)
+                                  (targetRealRegSqueeze platform))
+                  $ graphGlobal
+
+
+        -- dump global NCG stats for linear allocator
+        let linearStats = concat (ngs_linearStats ngs)
+        when (not (null linearStats)) $
+          dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)
+
+        -- write out the imports
+        printSDocLn Pretty.LeftMode dflags h (mkCodeStyle AsmStyle)
+                $ makeImportsDoc dflags (concat (ngs_imports ngs))
+        return us'
+  where
+    dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats"
+
+cmmNativeGenStream :: (Outputable statics, Outputable instr
+                      ,Outputable jumpDest, Instruction instr)
+              => DynFlags
+              -> Module -> ModLocation
+              -> NcgImpl statics instr jumpDest
+              -> BufHandle
+              -> UniqSupply
+              -> Stream IO RawCmmGroup ()
+              -> NativeGenAcc statics instr
+              -> IO (NativeGenAcc statics instr, UniqSupply)
+
+cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
+ = do r <- Stream.runStream cmm_stream
+      case r of
+        Left () ->
+          return (ngs { ngs_imports = reverse $ ngs_imports ngs
+                      , ngs_natives = reverse $ ngs_natives ngs
+                      , ngs_colorStats = reverse $ ngs_colorStats ngs
+                      , ngs_linearStats = reverse $ ngs_linearStats ngs
+                      },
+                  us)
+        Right (cmms, cmm_stream') -> do
+
+          -- Generate debug information
+          let debugFlag = debugLevel dflags > 0
+              !ndbgs | debugFlag = cmmDebugGen modLoc cmms
+                     | otherwise = []
+              dbgMap = debugToMap ndbgs
+
+          -- Insert split marker, generate native code
+          let splitObjs = gopt Opt_SplitObjs dflags
+              split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] $
+                             ofBlockList (panic "split_marker_entry") []
+              cmms' | splitObjs  = split_marker : cmms
+                    | otherwise  = cmms
+          (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h
+                                             dbgMap us cmms' ngs 0
+
+          -- Link native code information into debug blocks
+          -- See Note [What is this unwinding business?] in Debug.
+          let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
+          dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
+            (vcat $ map ppr ldbgs)
+
+          -- Emit & clear DWARF information when generating split
+          -- object files, as we need it to land in the same object file
+          -- When using split sections, note that we do not split the debug
+          -- info but emit all the info at once in finishNativeGen.
+          (ngs'', us'') <-
+            if debugFlag && splitObjs
+            then do (dwarf, us'') <- dwarfGen dflags modLoc us ldbgs
+                    emitNativeCode dflags h dwarf
+                    return (ngs' { ngs_debug = []
+                                 , ngs_dwarfFiles = emptyUFM
+                                 , ngs_labels = [] },
+                            us'')
+            else return (ngs' { ngs_debug  = ngs_debug ngs' ++ ldbgs
+                              , ngs_labels = [] },
+                         us')
+
+          cmmNativeGenStream dflags this_mod modLoc ncgImpl h us''
+              cmm_stream' ngs''
+
+-- | Do native code generation on all these cmms.
+--
+cmmNativeGens :: forall statics instr jumpDest.
+                 (Outputable statics, Outputable instr
+                 ,Outputable jumpDest, Instruction instr)
+              => DynFlags
+              -> Module -> ModLocation
+              -> NcgImpl statics instr jumpDest
+              -> BufHandle
+              -> LabelMap DebugBlock
+              -> UniqSupply
+              -> [RawCmmDecl]
+              -> NativeGenAcc statics instr
+              -> Int
+              -> IO (NativeGenAcc statics instr, UniqSupply)
+
+cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
+  where
+    go :: UniqSupply -> [RawCmmDecl]
+       -> NativeGenAcc statics instr -> Int
+       -> IO (NativeGenAcc statics instr, UniqSupply)
+
+    go us [] ngs !_ =
+        return (ngs, us)
+
+    go us (cmm : cmms) ngs count = do
+        let fileIds = ngs_dwarfFiles ngs
+        (us', fileIds', native, imports, colorStats, linearStats, unwinds)
+          <- {-# SCC "cmmNativeGen" #-}
+             cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap
+                          cmm count
+
+        -- Generate .file directives for every new file that has been
+        -- used. Note that it is important that we generate these in
+        -- ascending order, as Clang's 3.6 assembler complains.
+        let newFileIds = sortBy (comparing snd) $
+                         nonDetEltsUFM $ fileIds' `minusUFM` fileIds
+            -- See Note [Unique Determinism and code generation]
+            pprDecl (f,n) = text "\t.file " <> ppr n <+>
+                            doubleQuotes (ftext f)
+
+        emitNativeCode dflags h $ vcat $
+          map pprDecl newFileIds ++
+          map (pprNatCmmDecl ncgImpl) native
+
+        -- force evaluation all this stuff to avoid space leaks
+        {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports)
+
+        let !labels' = if debugLevel dflags > 0
+                       then cmmDebugLabels isMetaInstr native else []
+            !natives' = if dopt Opt_D_dump_asm_stats dflags
+                        then native : ngs_natives ngs else []
+
+            mCon = maybe id (:)
+            ngs' = ngs{ ngs_imports     = imports : ngs_imports ngs
+                      , ngs_natives     = natives'
+                      , ngs_colorStats  = colorStats `mCon` ngs_colorStats ngs
+                      , ngs_linearStats = linearStats `mCon` ngs_linearStats ngs
+                      , ngs_labels      = ngs_labels ngs ++ labels'
+                      , ngs_dwarfFiles  = fileIds'
+                      , ngs_unwinds     = ngs_unwinds ngs `mapUnion` unwinds
+                      }
+        go us' cmms ngs' (count + 1)
+
+    seqString []            = ()
+    seqString (x:xs)        = x `seq` seqString xs
+
+
+emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()
+emitNativeCode dflags h sdoc = do
+
+        {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc dflags h
+                                      (mkCodeStyle AsmStyle) sdoc
+
+        -- dump native code
+        dumpIfSet_dyn dflags
+                Opt_D_dump_asm "Asm code"
+                sdoc
+
+-- | Complete native code generation phase for a single top-level chunk of Cmm.
+--      Dumping the output of each stage along the way.
+--      Global conflict graph and NGC stats
+cmmNativeGen
+    :: forall statics instr jumpDest. (Instruction instr,
+        Outputable statics, Outputable instr, Outputable jumpDest)
+    => DynFlags
+    -> Module -> ModLocation
+    -> NcgImpl statics instr jumpDest
+        -> UniqSupply
+        -> DwarfFiles
+        -> LabelMap DebugBlock
+        -> RawCmmDecl                                   -- ^ the cmm to generate code for
+        -> Int                                          -- ^ sequence number of this top thing
+        -> IO   ( UniqSupply
+                , DwarfFiles
+                , [NatCmmDecl statics instr]                -- native code
+                , [CLabel]                                  -- things imported by this cmm
+                , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
+                , Maybe [Linear.RegAllocStats]              -- stats for the linear register allocators
+                , LabelMap [UnwindPoint]                    -- unwinding information for blocks
+                )
+
+cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
+ = do
+        let platform = targetPlatform dflags
+
+        -- rewrite assignments to global regs
+        let fixed_cmm =
+                {-# SCC "fixStgRegisters" #-}
+                fixStgRegisters dflags cmm
+
+        -- cmm to cmm optimisations
+        let (opt_cmm, imports) =
+                {-# SCC "cmmToCmm" #-}
+                cmmToCmm dflags this_mod fixed_cmm
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_opt_cmm "Optimised Cmm"
+                (pprCmmGroup [opt_cmm])
+
+        let cmmCfg = {-# SCC "getCFG" #-}
+                     getCfgProc (cfgWeightInfo dflags) opt_cmm
+
+        -- generate native code from cmm
+        let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) =
+                {-# SCC "genMachCode" #-}
+                initUs us $ genMachCode dflags this_mod modLoc
+                                        (cmmTopCodeGen ncgImpl)
+                                        fileIds dbgMap opt_cmm cmmCfg
+
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_asm_native "Native code"
+                (vcat $ map (pprNatCmmDecl ncgImpl) native)
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_cfg_weights "CFG Weights"
+                (pprEdgeWeights nativeCfgWeights)
+
+        -- tag instructions with register liveness information
+        -- also drops dead code
+        let livenessCfg = if (backendMaintainsCfg dflags)
+                                then Just nativeCfgWeights
+                                else Nothing
+        let (withLiveness, usLive) =
+                {-# SCC "regLiveness" #-}
+                initUs usGen
+                        $ mapM (regLiveness platform)
+                        -- TODO: Only use CFG for x86
+                        $ map (natCmmTopToLive livenessCfg) native
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_asm_liveness "Liveness annotations added"
+                (vcat $ map ppr withLiveness)
+
+        -- allocate registers
+        (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear, raStats, stack_updt_blks) <-
+         if ( gopt Opt_RegsGraph dflags
+           || gopt Opt_RegsIterative dflags )
+          then do
+                -- the regs usable for allocation
+                let (alloc_regs :: UniqFM (UniqSet RealReg))
+                        = foldr (\r -> plusUFM_C unionUniqSets
+                                        $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
+                                emptyUFM
+                        $ allocatableRegs ncgImpl
+
+                -- do the graph coloring register allocation
+                let ((alloced, maybe_more_stack, regAllocStats), usAlloc)
+                        = {-# SCC "RegAlloc-color" #-}
+                          initUs usLive
+                          $ Color.regAlloc
+                                dflags
+                                alloc_regs
+                                (mkUniqSet [0 .. maxSpillSlots ncgImpl])
+                                (maxSpillSlots ncgImpl)
+                                withLiveness
+                                livenessCfg
+
+                let ((alloced', stack_updt_blks), usAlloc')
+                        = initUs usAlloc $
+                                case maybe_more_stack of
+                                Nothing     -> return (alloced, [])
+                                Just amount -> do
+                                    (alloced',stack_updt_blks) <- unzip <$>
+                                                (mapM ((ncgAllocMoreStack ncgImpl) amount) alloced)
+                                    return (alloced', concat stack_updt_blks )
+
+
+                -- dump out what happened during register allocation
+                dumpIfSet_dyn dflags
+                        Opt_D_dump_asm_regalloc "Registers allocated"
+                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
+
+                dumpIfSet_dyn dflags
+                        Opt_D_dump_asm_regalloc_stages "Build/spill stages"
+                        (vcat   $ map (\(stage, stats)
+                                        -> text "# --------------------------"
+                                        $$ text "#  cmm " <> int count <> text " Stage " <> int stage
+                                        $$ ppr stats)
+                                $ zip [0..] regAllocStats)
+
+                let mPprStats =
+                        if dopt Opt_D_dump_asm_stats dflags
+                         then Just regAllocStats else Nothing
+
+                -- force evaluation of the Maybe to avoid space leak
+                mPprStats `seq` return ()
+
+                return  ( alloced', usAlloc'
+                        , mPprStats
+                        , Nothing
+                        , [], stack_updt_blks)
+
+          else do
+                -- do linear register allocation
+                let reg_alloc proc = do
+                       (alloced, maybe_more_stack, ra_stats) <-
+                               Linear.regAlloc dflags proc
+                       case maybe_more_stack of
+                         Nothing -> return ( alloced, ra_stats, [] )
+                         Just amount -> do
+                           (alloced',stack_updt_blks) <-
+                               ncgAllocMoreStack ncgImpl amount alloced
+                           return (alloced', ra_stats, stack_updt_blks )
+
+                let ((alloced, regAllocStats, stack_updt_blks), usAlloc)
+                        = {-# SCC "RegAlloc-linear" #-}
+                          initUs usLive
+                          $ liftM unzip3
+                          $ mapM reg_alloc withLiveness
+
+                dumpIfSet_dyn dflags
+                        Opt_D_dump_asm_regalloc "Registers allocated"
+                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
+
+                let mPprStats =
+                        if dopt Opt_D_dump_asm_stats dflags
+                         then Just (catMaybes regAllocStats) else Nothing
+
+                -- force evaluation of the Maybe to avoid space leak
+                mPprStats `seq` return ()
+
+                return  ( alloced, usAlloc
+                        , Nothing
+                        , mPprStats, (catMaybes regAllocStats)
+                        , concat stack_updt_blks )
+
+        -- Fixupblocks the register allocator inserted (from, regMoves, to)
+        let cfgRegAllocUpdates :: [(BlockId,BlockId,BlockId)]
+            cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)
+
+        let cfgWithFixupBlks =
+                addNodesBetween nativeCfgWeights cfgRegAllocUpdates
+
+        -- Insert stack update blocks
+        let postRegCFG =
+                foldl' (\m (from,to) -> addImmediateSuccessor from to m )
+                       cfgWithFixupBlks stack_updt_blks
+
+        ---- x86fp_kludge.  This pass inserts ffree instructions to clear
+        ---- the FPU stack on x86.  The x86 ABI requires that the FPU stack
+        ---- is clear, and library functions can return odd results if it
+        ---- isn't.
+        ----
+        ---- NB. must happen before shortcutBranches, because that
+        ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
+        let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced
+
+        ---- generate jump tables
+        let tabled      =
+                {-# SCC "generateJumpTables" #-}
+                generateJumpTables ncgImpl kludged
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_cfg_weights "CFG Update information"
+                ( text "stack:" <+> ppr stack_updt_blks $$
+                  text "linearAlloc:" <+> ppr cfgRegAllocUpdates )
+
+        ---- shortcut branches
+        let (shorted, postShortCFG)     =
+                {-# SCC "shortcutBranches" #-}
+                shortcutBranches dflags ncgImpl tabled postRegCFG
+
+        let optimizedCFG =
+                optimizeCFG (cfgWeightInfo dflags) cmm postShortCFG
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_cfg_weights "CFG Final Weights"
+                ( pprEdgeWeights optimizedCFG )
+
+        --TODO: Partially check validity of the cfg.
+        let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks
+            getBlks _ = []
+
+        when ( backendMaintainsCfg dflags &&
+                (gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do
+                let blocks = concatMap getBlks shorted
+                let labels = setFromList $ fmap blockId blocks :: LabelSet
+                return $! seq (sanityCheckCfg optimizedCFG labels $
+                                text "cfg not in lockstep") ()
+
+        ---- sequence blocks
+        let sequenced :: [NatCmmDecl statics instr]
+            sequenced =
+                checkLayout shorted $
+                {-# SCC "sequenceBlocks" #-}
+                map (BlockLayout.sequenceTop
+                        dflags
+                        ncgImpl optimizedCFG)
+                    shorted
+
+        let branchOpt :: [NatCmmDecl statics instr]
+            branchOpt =
+                {-# SCC "invertCondBranches" #-}
+                map invert sequenced
+              where
+                invertConds = (invertCondBranches ncgImpl) optimizedCFG
+                invert top@CmmData {} = top
+                invert (CmmProc info lbl live (ListGraph blocks)) =
+                    CmmProc info lbl live (ListGraph $ invertConds info blocks)
+
+        ---- expansion of SPARC synthetic instrs
+        let expanded =
+                {-# SCC "sparc_expand" #-}
+                ncgExpandTop ncgImpl branchOpt
+                --ncgExpandTop ncgImpl sequenced
+
+        dumpIfSet_dyn dflags
+                Opt_D_dump_asm_expanded "Synthetic instructions expanded"
+                (vcat $ map (pprNatCmmDecl ncgImpl) expanded)
+
+        -- generate unwinding information from cmm
+        let unwinds :: BlockMap [UnwindPoint]
+            unwinds =
+                {-# SCC "unwindingInfo" #-}
+                foldl' addUnwind mapEmpty expanded
+              where
+                addUnwind acc proc =
+                    acc `mapUnion` computeUnwinding dflags ncgImpl proc
+
+        return  ( usAlloc
+                , fileIds'
+                , expanded
+                , lastMinuteImports ++ imports
+                , ppr_raStatsColor
+                , ppr_raStatsLinear
+                , unwinds )
+
+-- | Make sure all blocks we want the layout algorithm to place have been placed.
+checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
+            -> [NatCmmDecl statics instr]
+checkLayout procsUnsequenced procsSequenced =
+        ASSERT2(setNull diff,
+                ppr "Block sequencing dropped blocks:" <> ppr diff)
+        procsSequenced
+  where
+        blocks1 = foldl' (setUnion) setEmpty $
+                        map getBlockIds procsUnsequenced :: LabelSet
+        blocks2 = foldl' (setUnion) setEmpty $
+                        map getBlockIds procsSequenced
+        diff = setDifference blocks1 blocks2
+
+        getBlockIds (CmmData _ _) = setEmpty
+        getBlockIds (CmmProc _ _ _ (ListGraph blocks)) =
+                setFromList $ map blockId blocks
+
+
+x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr
+x86fp_kludge top@(CmmData _ _) = top
+x86fp_kludge (CmmProc info lbl live (ListGraph code)) =
+        CmmProc info lbl live (ListGraph $ X86.Instr.i386_insert_ffrees code)
+
+-- | Compute unwinding tables for the blocks of a procedure
+computeUnwinding :: Instruction instr
+                 => DynFlags -> NcgImpl statics instr jumpDest
+                 -> NatCmmDecl statics instr
+                    -- ^ the native code generated for the procedure
+                 -> LabelMap [UnwindPoint]
+                    -- ^ unwinding tables for all points of all blocks of the
+                    -- procedure
+computeUnwinding dflags _ _
+  | debugLevel dflags == 0         = mapEmpty
+computeUnwinding _ _ (CmmData _ _) = mapEmpty
+computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) =
+    -- In general we would need to push unwinding information down the
+    -- block-level call-graph to ensure that we fully account for all
+    -- relevant register writes within a procedure.
+    --
+    -- However, the only unwinding information that we care about in GHC is for
+    -- Sp. The fact that CmmLayoutStack already ensures that we have unwind
+    -- information at the beginning of every block means that there is no need
+    -- to perform this sort of push-down.
+    mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs)
+                | BasicBlock blk_lbl instrs <- blks ]
+
+-- | Build a doc for all the imports.
+--
+makeImportsDoc :: DynFlags -> [CLabel] -> SDoc
+makeImportsDoc dflags imports
+ = dyld_stubs imports
+            $$
+            -- On recent versions of Darwin, the linker supports
+            -- dead-stripping of code and data on a per-symbol basis.
+            -- There's a hack to make this work in PprMach.pprNatCmmDecl.
+            (if platformHasSubsectionsViaSymbols platform
+             then text ".subsections_via_symbols"
+             else Outputable.empty)
+            $$
+                -- On recent GNU ELF systems one can mark an object file
+                -- as not requiring an executable stack. If all objects
+                -- linked into a program have this note then the program
+                -- will not use an executable stack, which is good for
+                -- security. GHC generated code does not need an executable
+                -- stack so add the note in:
+            (if platformHasGnuNonexecStack platform
+             then text ".section .note.GNU-stack,\"\"," <> sectionType "progbits"
+             else Outputable.empty)
+            $$
+                -- And just because every other compiler does, let's stick in
+                -- an identifier directive: .ident "GHC x.y.z"
+            (if platformHasIdentDirective platform
+             then let compilerIdent = text "GHC" <+> text cProjectVersion
+                   in text ".ident" <+> doubleQuotes compilerIdent
+             else Outputable.empty)
+
+ where
+        platform = targetPlatform dflags
+        arch = platformArch platform
+        os   = platformOS   platform
+
+        -- Generate "symbol stubs" for all external symbols that might
+        -- come from a dynamic library.
+        dyld_stubs :: [CLabel] -> SDoc
+{-      dyld_stubs imps = vcat $ map pprDyldSymbolStub $
+                                    map head $ group $ sort imps-}
+        -- (Hack) sometimes two Labels pretty-print the same, but have
+        -- different uniques; so we compare their text versions...
+        dyld_stubs imps
+                | needImportedSymbols dflags arch os
+                = vcat $
+                        (pprGotDeclaration dflags arch os :) $
+                        map ( pprImportedSymbol dflags platform . fst . head) $
+                        groupBy (\(_,a) (_,b) -> a == b) $
+                        sortBy (\(_,a) (_,b) -> compare a b) $
+                        map doPpr $
+                        imps
+                | otherwise
+                = Outputable.empty
+
+        doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle)
+        astyle = mkCodeStyle AsmStyle
+
+-- -----------------------------------------------------------------------------
+-- Generate jump tables
+
+-- Analyzes all native code and generates data sections for all jump
+-- table instructions.
+generateJumpTables
+        :: NcgImpl statics instr jumpDest
+        -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
+generateJumpTables ncgImpl xs = concatMap f xs
+    where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs
+          f p = [p]
+          g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
+
+-- -----------------------------------------------------------------------------
+-- Shortcut branches
+
+shortcutBranches
+        :: forall statics instr jumpDest. (Outputable jumpDest) => DynFlags
+        -> NcgImpl statics instr jumpDest
+        -> [NatCmmDecl statics instr]
+        -> CFG
+        -> ([NatCmmDecl statics instr],CFG)
+
+shortcutBranches dflags ncgImpl tops weights
+  | gopt Opt_AsmShortcutting dflags
+  = ( map (apply_mapping ncgImpl mapping) tops'
+    , shortcutWeightMap weights mappingBid )
+  | otherwise
+  = (tops, weights)
+  where
+    (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops
+    mapping = mapUnions mappings :: LabelMap jumpDest
+    mappingBid = fmap (getJumpDestBlockId ncgImpl) mapping
+
+build_mapping :: forall instr t d statics jumpDest.
+                 NcgImpl statics instr jumpDest
+              -> GenCmmDecl d (LabelMap t) (ListGraph instr)
+              -> (GenCmmDecl d (LabelMap t) (ListGraph instr)
+                 ,LabelMap jumpDest)
+build_mapping _ top@(CmmData _ _) = (top, mapEmpty)
+build_mapping _ (CmmProc info lbl live (ListGraph []))
+  = (CmmProc info lbl live (ListGraph []), mapEmpty)
+build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks)))
+  = (CmmProc info lbl live (ListGraph (head:others)), mapping)
+        -- drop the shorted blocks, but don't ever drop the first one,
+        -- because it is pointed to by a global label.
+  where
+    -- find all the blocks that just consist of a jump that can be
+    -- shorted.
+    -- Don't completely eliminate loops here -- that can leave a dangling jump!
+    shortcut_blocks :: [(BlockId, jumpDest)]
+    (_, shortcut_blocks, others) =
+        foldl' split (setEmpty :: LabelSet, [], []) blocks
+    split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
+        | Just jd <- canShortcut ncgImpl insn
+        , Just dest <- getJumpDestBlockId ncgImpl jd
+        , not (has_info id)
+        , (setMember dest s) || dest == id -- loop checks
+        = (s, shortcut_blocks, b : others)
+    split (s, shortcut_blocks, others) (BasicBlock id [insn])
+        | Just dest <- canShortcut ncgImpl insn
+        , not (has_info id)
+        = (setInsert id s, (id,dest) : shortcut_blocks, others)
+    split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
+
+    -- do not eliminate blocks that have an info table
+    has_info l = mapMember l info
+
+    -- build a mapping from BlockId to JumpDest for shorting branches
+    mapping = mapFromList shortcut_blocks
+
+apply_mapping :: NcgImpl statics instr jumpDest
+              -> LabelMap jumpDest
+              -> GenCmmDecl statics h (ListGraph instr)
+              -> GenCmmDecl statics h (ListGraph instr)
+apply_mapping ncgImpl ufm (CmmData sec statics)
+  = CmmData sec (shortcutStatics ncgImpl (\bid -> mapLookup bid ufm) statics)
+apply_mapping ncgImpl ufm (CmmProc info lbl live (ListGraph blocks))
+  = CmmProc info lbl live (ListGraph $ map short_bb blocks)
+  where
+    short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
+    short_insn i = shortcutJump ncgImpl (\bid -> mapLookup bid ufm) i
+                 -- shortcutJump should apply the mapping repeatedly,
+                 -- just in case we can short multiple branches.
+
+-- -----------------------------------------------------------------------------
+-- Instruction selection
+
+-- Native code instruction selection for a chunk of stix code.  For
+-- this part of the computation, we switch from the UniqSM monad to
+-- the NatM monad.  The latter carries not only a Unique, but also an
+-- Int denoting the current C stack pointer offset in the generated
+-- code; this is needed for creating correct spill offsets on
+-- architectures which don't offer, or for which it would be
+-- prohibitively expensive to employ, a frame pointer register.  Viz,
+-- x86.
+
+-- The offset is measured in bytes, and indicates the difference
+-- between the current (simulated) C stack-ptr and the value it was at
+-- the beginning of the block.  For stacks which grow down, this value
+-- should be either zero or negative.
+
+-- Along with the stack pointer offset, we also carry along a LabelMap of
+-- DebugBlocks, which we read to generate .location directives.
+--
+-- Switching between the two monads whilst carrying along the same
+-- Unique supply breaks abstraction.  Is that bad?
+
+genMachCode
+        :: DynFlags
+        -> Module -> ModLocation
+        -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
+        -> DwarfFiles
+        -> LabelMap DebugBlock
+        -> RawCmmDecl
+        -> CFG
+        -> UniqSM
+                ( [NatCmmDecl statics instr]
+                , [CLabel]
+                , DwarfFiles
+                , CFG
+                )
+
+genMachCode dflags this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg
+  = do  { initial_us <- getUniqueSupplyM
+        ; let initial_st           = mkNatM_State initial_us 0 dflags this_mod
+                                                  modLoc fileIds dbgMap cmm_cfg
+              (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
+              final_delta          = natm_delta final_st
+              final_imports        = natm_imports final_st
+              final_cfg            = natm_cfg final_st
+        ; if   final_delta == 0
+          then return (new_tops, final_imports
+                      , natm_fileid final_st, final_cfg)
+          else pprPanic "genMachCode: nonzero final delta" (int final_delta)
+    }
+
+-- -----------------------------------------------------------------------------
+-- Generic Cmm optimiser
+
+{-
+Here we do:
+
+  (a) Constant folding
+  (c) Position independent code and dynamic linking
+        (i)  introduce the appropriate indirections
+             and position independent refs
+        (ii) compile a list of imported symbols
+  (d) Some arch-specific optimizations
+
+(a) will be moving to the new Hoopl pipeline, however, (c) and
+(d) are only needed by the native backend and will continue to live
+here.
+
+Ideas for other things we could do (put these in Hoopl please!):
+
+  - shortcut jumps-to-jumps
+  - simple CSE: if an expr is assigned to a temp, then replace later occs of
+    that expr with the temp, until the expr is no longer valid (can push through
+    temp assignments, and certain assigns to mem...)
+-}
+
+cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
+cmmToCmm _ _ top@(CmmData _ _) = (top, [])
+cmmToCmm dflags this_mod (CmmProc info lbl live graph)
+    = runCmmOpt dflags this_mod $
+      do blocks' <- mapM cmmBlockConFold (toBlockList graph)
+         return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')
+
+newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> (# a, [CLabel] #))
+
+instance Functor CmmOptM where
+    fmap = liftM
+
+instance Applicative CmmOptM where
+    pure x = CmmOptM $ \_ _ imports -> (# x, imports #)
+    (<*>) = ap
+
+instance Monad CmmOptM where
+  (CmmOptM f) >>= g =
+    CmmOptM $ \dflags this_mod imports ->
+                case f dflags this_mod imports of
+                  (# x, imports' #) ->
+                    case g x of
+                      CmmOptM g' -> g' dflags this_mod imports'
+
+instance CmmMakeDynamicReferenceM CmmOptM where
+    addImport = addImportCmmOpt
+    getThisModule = CmmOptM $ \_ this_mod imports -> (# this_mod, imports #)
+
+addImportCmmOpt :: CLabel -> CmmOptM ()
+addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> (# (), lbl:imports #)
+
+instance HasDynFlags CmmOptM where
+    getDynFlags = CmmOptM $ \dflags _ imports -> (# dflags, imports #)
+
+runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel])
+runCmmOpt dflags this_mod (CmmOptM f) = case f dflags this_mod [] of
+                        (# result, imports #) -> (result, imports)
+
+cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
+cmmBlockConFold block = do
+  let (entry, middle, last) = blockSplit block
+      stmts = blockToList middle
+  stmts' <- mapM cmmStmtConFold stmts
+  last' <- cmmStmtConFold last
+  return $ blockJoin entry (blockFromList stmts') last'
+
+-- This does three optimizations, but they're very quick to check, so we don't
+-- bother turning them off even when the Hoopl code is active.  Since
+-- this is on the old Cmm representation, we can't reuse the code either:
+--  * reg = reg      --> nop
+--  * if 0 then jump --> nop
+--  * if 1 then jump --> jump
+-- We might be tempted to skip this step entirely of not Opt_PIC, but
+-- there is some PowerPC code for the non-PIC case, which would also
+-- have to be separated.
+cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x)
+cmmStmtConFold stmt
+   = case stmt of
+        CmmAssign reg src
+           -> do src' <- cmmExprConFold DataReference src
+                 return $ case src' of
+                   CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop")
+                   new_src -> CmmAssign reg new_src
+
+        CmmStore addr src
+           -> do addr' <- cmmExprConFold DataReference addr
+                 src'  <- cmmExprConFold DataReference src
+                 return $ CmmStore addr' src'
+
+        CmmCall { cml_target = addr }
+           -> do addr' <- cmmExprConFold JumpReference addr
+                 return $ stmt { cml_target = addr' }
+
+        CmmUnsafeForeignCall target regs args
+           -> do target' <- case target of
+                              ForeignTarget e conv -> do
+                                e' <- cmmExprConFold CallReference e
+                                return $ ForeignTarget e' conv
+                              PrimTarget _ ->
+                                return target
+                 args' <- mapM (cmmExprConFold DataReference) args
+                 return $ CmmUnsafeForeignCall target' regs args'
+
+        CmmCondBranch test true false likely
+           -> do test' <- cmmExprConFold DataReference test
+                 return $ case test' of
+                   CmmLit (CmmInt 0 _) -> CmmBranch false
+                   CmmLit (CmmInt _ _) -> CmmBranch true
+                   _other -> CmmCondBranch test' true false likely
+
+        CmmSwitch expr ids
+           -> do expr' <- cmmExprConFold DataReference expr
+                 return $ CmmSwitch expr' ids
+
+        other
+           -> return other
+
+cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
+cmmExprConFold referenceKind expr = do
+    dflags <- getDynFlags
+
+    -- With -O1 and greater, the cmmSink pass does constant-folding, so
+    -- we don't need to do it again here.
+    let expr' = if optLevel dflags >= 1
+                    then expr
+                    else cmmExprCon dflags expr
+
+    cmmExprNative referenceKind expr'
+
+cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr
+cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep
+cmmExprCon dflags (CmmMachOp mop args)
+    = cmmMachOpFold dflags mop (map (cmmExprCon dflags) args)
+cmmExprCon _ other = other
+
+-- handles both PIC and non-PIC cases... a very strange mixture
+-- of things to do.
+cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
+cmmExprNative referenceKind expr = do
+     dflags <- getDynFlags
+     let platform = targetPlatform dflags
+         arch = platformArch platform
+     case expr of
+        CmmLoad addr rep
+           -> do addr' <- cmmExprNative DataReference addr
+                 return $ CmmLoad addr' rep
+
+        CmmMachOp mop args
+           -> do args' <- mapM (cmmExprNative DataReference) args
+                 return $ CmmMachOp mop args'
+
+        CmmLit (CmmBlock id)
+           -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))
+           -- we must convert block Ids to CLabels here, because we
+           -- might have to do the PIC transformation.  Hence we must
+           -- not modify BlockIds beyond this point.
+
+        CmmLit (CmmLabel lbl)
+           -> do
+                cmmMakeDynamicReference dflags referenceKind lbl
+        CmmLit (CmmLabelOff lbl off)
+           -> do
+                 dynRef <- cmmMakeDynamicReference dflags referenceKind lbl
+                 -- need to optimize here, since it's late
+                 return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [
+                     dynRef,
+                     (CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags))
+                   ]
+
+        -- On powerpc (non-PIC), it's easier to jump directly to a label than
+        -- to use the register table, so we replace these registers
+        -- with the corresponding labels:
+        CmmReg (CmmGlobal EagerBlackholeInfo)
+          | arch == ArchPPC && not (positionIndependent dflags)
+          -> cmmExprNative referenceKind $
+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))
+        CmmReg (CmmGlobal GCEnter1)
+          | arch == ArchPPC && not (positionIndependent dflags)
+          -> cmmExprNative referenceKind $
+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))
+        CmmReg (CmmGlobal GCFun)
+          | arch == ArchPPC && not (positionIndependent dflags)
+          -> cmmExprNative referenceKind $
+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))
+
+        other
+           -> return other
diff --git a/compiler/nativeGen/BlockLayout.hs b/compiler/nativeGen/BlockLayout.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/BlockLayout.hs
@@ -0,0 +1,819 @@
+--
+-- Copyright (c) 2018 Andreas Klebinger
+--
+
+{-# LANGUAGE TypeFamilies, ScopedTypeVariables, CPP #-}
+
+{-# OPTIONS_GHC -fprof-auto #-}
+--{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -ddump-cmm #-}
+
+module BlockLayout
+    ( sequenceTop )
+where
+
+#include "HsVersions.h"
+import GhcPrelude
+
+import Instruction
+import NCGMonad
+import CFG
+
+import BlockId
+import Cmm
+import Hoopl.Collections
+import Hoopl.Label
+import Hoopl.Block
+
+import DynFlags (gopt, GeneralFlag(..), DynFlags, backendMaintainsCfg)
+import UniqFM
+import Util
+import Unique
+
+import Digraph
+import Outputable
+import Maybes
+
+-- DEBUGGING ONLY
+--import Debug
+--import Debug.Trace
+import ListSetOps (removeDups)
+import PprCmm ()
+
+import OrdList
+import Data.List
+import Data.Foldable (toList)
+import Hoopl.Graph
+
+import qualified Data.Set as Set
+import Control.Applicative
+
+{-
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  ~~~ Note [Chain based CFG serialization]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  For additional information also look at
+  https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/CodeLayout
+
+  We have a CFG with edge weights based on which we try to place blocks next to
+  each other.
+
+  Edge weights not only represent likelyhood of control transfer between blocks
+  but also how much a block would benefit from being placed sequentially after
+  it's predecessor.
+  For example blocks which are preceeded by an info table are more likely to end
+  up in a different cache line than their predecessor. So there is less benefit
+  in placing them sequentially.
+
+  For example consider this example:
+
+  A:  ...
+      jmp cond D (weak successor)
+      jmp B
+  B:  ...
+      jmp C
+  C:  ...
+      jmp X
+  D:  ...
+      jmp B (weak successor)
+
+  We determine a block layout by building up chunks (calling them chains) of
+  possible control flows for which blocks will be placed sequentially.
+
+  Eg for our example we might end up with two chains like:
+  [A->B->C->X],[D]. Blocks inside chains will always be placed sequentially.
+  However there is no particular order in which chains are placed since
+  (hopefully) the blocks for which sequentially is important have already
+  been placed in the same chain.
+
+  -----------------------------------------------------------------------------
+      First try to create a lists of good chains.
+  -----------------------------------------------------------------------------
+
+  We do so by taking a block not yet placed in a chain and
+  looking at these cases:
+
+  *)  Check if the best predecessor of the block is at the end of a chain.
+      If so add the current block to the end of that chain.
+
+      Eg if we look at block C and already have the chain (A -> B)
+      then we extend the chain to (A -> B -> C).
+
+      Combined with the fact that we process blocks in reverse post order
+      this means loop bodies and trivially sequential control flow already
+      ends up as a single chain.
+
+  *)  Otherwise we create a singleton chain from the block we are looking at.
+      Eg if we have from the example above already constructed (A->B)
+      and look at D we create the chain (D) resulting in the chains [A->B, D]
+
+  -----------------------------------------------------------------------------
+      We then try to fuse chains.
+  -----------------------------------------------------------------------------
+
+  There are edge cases which result in two chains being created which trivially
+  represent linear control flow. For example we might have the chains
+  [(A-B-C),(D-E)] with an cfg triangle:
+
+      A----->C->D->E
+       \->B-/
+
+  We also get three independent chains if two branches end with a jump
+  to a common successor.
+
+  We take care of these cases by fusing chains which are connected by an
+  edge.
+
+  We do so by looking at the list of edges sorted by weight.
+  Given the edge (C -> D) we try to find two chains such that:
+      * C is at the end of chain one.
+      * D is in front of chain two.
+      * If two such chains exist we fuse them.
+  We then remove the edge and repeat the process for the rest of the edges.
+
+  -----------------------------------------------------------------------------
+      Place indirect successors (neighbours) after each other
+  -----------------------------------------------------------------------------
+
+  We might have chains [A,B,C,X],[E] in a CFG of the sort:
+
+    A ---> B ---> C --------> X(exit)
+                   \- ->E- -/
+
+  While E does not follow X it's still beneficial to place them near each other.
+  This can be advantageous if eg C,X,E will end up in the same cache line.
+
+  TODO: If we remove edges as we use them (eg if we build up A->B remove A->B
+        from the list) we could save some more work in later phases.
+
+
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  ~~~ Note [Triangle Control Flow]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  Checking if an argument is already evaluating leads to a somewhat
+  special case  which looks like this:
+
+    A:
+        if (R1 & 7 != 0) goto Leval; else goto Lwork;
+    Leval: // global
+        call (I64[R1])(R1) returns to Lwork, args: 8, res: 8, upd: 8;
+    Lwork: // global
+        ...
+
+        A
+        |\
+        | Leval
+        |/ - (This edge can be missing because of optimizations)
+        Lwork
+
+  Once we hit the metal the call instruction is just 2-3 bytes large
+  depending on the register used. So we lay out the assembly like this:
+
+        movq %rbx,%rax
+        andl $7,%eax
+        cmpq $1,%rax
+        jne Lwork
+    Leval:
+        jmp *(%rbx) # encoded in 2-3 bytes.
+    <info table>
+    Lwork:
+        ...
+
+  We could explicitly check for this control flow pattern.
+
+  This is advantageous because:
+  * It's optimal if the argument isn't evaluated.
+  * If it's evaluated we only have the extra cost of jumping over
+    the 2-3 bytes for the call.
+  * Guarantees the smaller encoding for the conditional jump.
+
+  However given that Lwork usually has an info table we
+  penalize this edge. So Leval should get placed first
+  either way and things work out for the best.
+
+  Optimizing for the evaluated case instead would penalize
+  the other code path. It adds an jump as we can't fall through
+  to Lwork because of the info table.
+  Assuming that Lwork is large the chance that the "call" ends up
+  in the same cache line is also fairly small.
+
+-}
+
+
+-- | Look at X number of blocks in two chains to determine
+--   if they are "neighbours".
+neighbourOverlapp :: Int
+neighbourOverlapp = 2
+
+-- | Only edges heavier than this are considered
+--   for fusing two chains into a single chain.
+fuseEdgeThreshold :: EdgeWeight
+fuseEdgeThreshold = 0
+
+
+-- | A non empty ordered sequence of basic blocks.
+--   It is suitable for serialization in this order.
+data BlockChain
+    = BlockChain
+    { chainMembers :: !LabelSet
+    , chainBlocks :: !BlockSequence
+    }
+
+instance Eq (BlockChain) where
+    (BlockChain s1 _) == (BlockChain s2 _)
+        = s1 == s2
+
+instance Outputable (BlockChain) where
+    ppr (BlockChain _ blks) =
+        parens (text "Chain:" <+> ppr (seqToList $ blks) )
+
+data WeightedEdge = WeightedEdge !BlockId !BlockId EdgeWeight deriving (Eq)
+
+-- Useful for things like sets and debugging purposes, sorts by blocks
+-- in the chain.
+instance Ord (BlockChain) where
+   (BlockChain lbls1 _) `compare` (BlockChain lbls2 _)
+       = lbls1 `compare` lbls2
+
+-- | Non deterministic! (Uniques) Sorts edges by weight and nodes.
+instance Ord WeightedEdge where
+  compare (WeightedEdge from1 to1 weight1)
+          (WeightedEdge from2 to2 weight2)
+    | weight1 < weight2 || weight1 == weight2 && from1 < from2 ||
+      weight1 == weight2 && from1 == from2 && to1 < to2
+    = LT
+    | from1 == from2 && to1 == to2 && weight1 == weight2
+    = EQ
+    | otherwise
+    = GT
+
+instance Outputable WeightedEdge where
+    ppr (WeightedEdge from to info) =
+        ppr from <> text "->" <> ppr to <> brackets (ppr info)
+
+type WeightedEdgeList = [WeightedEdge]
+
+noDups :: [BlockChain] -> Bool
+noDups chains =
+    let chainBlocks = concatMap chainToBlocks chains :: [BlockId]
+        (_blocks, dups) = removeDups compare chainBlocks
+    in if null dups then True
+        else pprTrace "Duplicates:" (ppr (map toList dups) $$ text "chains" <+> ppr chains ) False
+
+inFront :: BlockId -> BlockChain -> Bool
+inFront bid (BlockChain _ seq)
+  = seqFront seq == bid
+
+chainMember :: BlockId -> BlockChain -> Bool
+chainMember bid chain
+  = setMember bid . chainMembers $ chain
+
+chainSingleton :: BlockId -> BlockChain
+chainSingleton lbl
+    = BlockChain (setSingleton lbl) (Singleton lbl)
+
+chainSnoc :: BlockChain -> BlockId -> BlockChain
+chainSnoc (BlockChain lbls blks) lbl
+  = BlockChain (setInsert lbl lbls) (seqSnoc blks lbl)
+
+chainConcat :: BlockChain -> BlockChain -> BlockChain
+chainConcat (BlockChain lbls1 blks1) (BlockChain lbls2 blks2)
+  = BlockChain (setUnion lbls1 lbls2) (blks1 `seqConcat` blks2)
+
+chainToBlocks :: BlockChain -> [BlockId]
+chainToBlocks (BlockChain _ blks) = seqToList blks
+
+-- | Given the Chain A -> B -> C -> D and we break at C
+--   we get the two Chains (A -> B, C -> D) as result.
+breakChainAt :: BlockId -> BlockChain
+             -> (BlockChain,BlockChain)
+breakChainAt bid (BlockChain lbls blks)
+    | not (setMember bid lbls)
+    = panic "Block not in chain"
+    | otherwise
+    = let (lblks, rblks) = break (\lbl -> lbl == bid)
+                                 (seqToList blks)
+          --TODO: Remove old
+          --lblSet :: [GenBasicBlock i] -> BlockChain
+          --lblSet blks =
+          --  setFromList
+                --(map (\(BasicBlock lbl _) -> lbl) $ toList blks)
+      in
+      (BlockChain (setFromList lblks) (seqFromBids lblks),
+       BlockChain (setFromList rblks) (seqFromBids rblks))
+
+takeR :: Int -> BlockChain -> [BlockId]
+takeR n (BlockChain _ blks) =
+    take n . seqToRList $ blks
+
+
+takeL :: Int -> BlockChain -> [BlockId]
+takeL n (BlockChain _ blks) = --error "TODO: takeLn"
+    take n . seqToList $ blks
+
+-- | For a given list of chains try to fuse chains with strong
+--   edges between them into a single chain.
+--   Returns the list of fused chains together with a set of
+--   used edges. The set of edges is indirectly encoded in the
+--   chains so doesn't need to be considered for later passes.
+fuseChains :: WeightedEdgeList -> LabelMap BlockChain
+           -> (LabelMap BlockChain, Set.Set WeightedEdge)
+fuseChains weights chains
+    = let fronts = mapFromList $
+                    map (\chain -> (head $ takeL 1 chain,chain)) $
+                    mapElems chains :: LabelMap BlockChain
+          (chains', used, _) = applyEdges weights chains fronts Set.empty
+      in (chains', used)
+    where
+        applyEdges :: WeightedEdgeList -> LabelMap BlockChain
+                   -> LabelMap BlockChain -> Set.Set WeightedEdge
+                   -> (LabelMap BlockChain, Set.Set WeightedEdge, LabelMap BlockChain)
+        applyEdges [] chainsEnd chainsFront used
+            = (chainsEnd, used, chainsFront)
+        applyEdges (edge@(WeightedEdge from to w):edges) chainsEnd chainsFront used
+            --Since we order edges descending by weight we can stop here
+            | w <= fuseEdgeThreshold
+            = ( chainsEnd, used, chainsFront)
+            --Fuse the two chains
+            | Just c1 <- mapLookup from chainsEnd
+            , Just c2 <- mapLookup to chainsFront
+            , c1 /= c2
+            = let newChain = chainConcat c1 c2
+                  front = head $ takeL 1 newChain
+                  end = head $ takeR 1 newChain
+                  chainsFront' = mapInsert front newChain $
+                                 mapDelete to chainsFront
+                  chainsEnd'   = mapInsert end newChain $
+                                 mapDelete from chainsEnd
+              in applyEdges edges chainsEnd' chainsFront'
+                            (Set.insert edge used)
+            | otherwise
+            --Check next edge
+            = applyEdges edges chainsEnd chainsFront used
+
+
+-- See also Note [Chain based CFG serialization]
+-- We have the chains (A-B-C-D) and (E-F) and an Edge C->E.
+--
+-- While placing the later after the former doesn't result in sequential
+-- control flow it is still be benefical since block C and E might end
+-- up in the same cache line.
+--
+-- So we place these chains next to each other even if we can't fuse them.
+--
+--   A -> B -> C -> D
+--             v
+--             - -> E -> F ...
+--
+-- Simple heuristic to chose which chains we want to combine:
+--   * Process edges in descending priority.
+--   * Check if there is a edge near the end of one chain which goes
+--     to a block near the start of another edge.
+--
+-- While we could take into account the space between the two blocks which
+-- share an edge this blows up compile times quite a bit. It requires
+-- us to find all edges between two chains, check the distance for all edges,
+-- rank them based on the distance and and only then we can select two chains
+-- to combine. Which would add a lot of complexity for little gain.
+
+-- | For a given list of chains and edges try to combine chains with strong
+--   edges between them.
+combineNeighbourhood :: WeightedEdgeList -> [BlockChain]
+                     -> [BlockChain]
+combineNeighbourhood edges chains
+    = -- pprTraceIt "Neigbours" $
+      applyEdges edges endFrontier startFrontier
+    where
+        --Build maps from chain ends to chains
+        endFrontier, startFrontier :: FrontierMap
+        endFrontier =
+            mapFromList $ concatMap (\chain ->
+                                let ends = getEnds chain
+                                    entry = (ends,chain)
+                                in map (\x -> (x,entry)) ends ) chains
+        startFrontier =
+            mapFromList $ concatMap (\chain ->
+                                let front = getFronts chain
+                                    entry = (front,chain)
+                                in map (\x -> (x,entry)) front) chains
+        applyEdges :: WeightedEdgeList -> FrontierMap -> FrontierMap
+                   -> [BlockChain]
+        applyEdges [] chainEnds _chainFronts =
+            ordNub $ map snd $ mapElems chainEnds
+        applyEdges ((WeightedEdge from to _w):edges) chainEnds chainFronts
+            | Just (c1_e,c1) <- mapLookup from chainEnds
+            , Just (c2_f,c2) <- mapLookup to chainFronts
+            , c1 /= c2 -- Avoid trying to concat a short chain with itself.
+            = let newChain = chainConcat c1 c2
+                  newChainFrontier = getFronts newChain
+                  newChainEnds = getEnds newChain
+                  newFronts :: FrontierMap
+                  newFronts =
+                    let withoutOld =
+                            foldl' (\m b -> mapDelete b m :: FrontierMap) chainFronts (c2_f ++ getFronts c1)
+                        entry =
+                            (newChainFrontier,newChain) --let bound to ensure sharing
+                    in foldl' (\m x -> mapInsert x entry m)
+                              withoutOld newChainFrontier
+
+                  newEnds =
+                    let withoutOld = foldl' (\m b -> mapDelete b m) chainEnds (c1_e ++ getEnds c2)
+                        entry = (newChainEnds,newChain) --let bound to ensure sharing
+                    in foldl' (\m x -> mapInsert x entry m)
+                              withoutOld newChainEnds
+              in
+                -- pprTrace "ApplyEdges"
+                --  (text "before" $$
+                --   text "fronts" <+> ppr chainFronts $$
+                --   text "ends" <+> ppr chainEnds $$
+
+                --   text "various" $$
+                --   text "newChain" <+> ppr newChain $$
+                --   text "newChainFrontier" <+> ppr newChainFrontier $$
+                --   text "newChainEnds" <+> ppr newChainEnds $$
+                --   text "drop" <+> ppr ((c2_f ++ getFronts c1) ++ (c1_e ++ getEnds c2)) $$
+
+                --   text "after" $$
+                --   text "fronts" <+> ppr newFronts $$
+                --   text "ends" <+> ppr newEnds
+                --   )
+                 applyEdges edges newEnds newFronts
+            | otherwise
+            = --pprTrace "noNeigbours" (ppr ()) $
+              applyEdges edges chainEnds chainFronts
+         where
+
+        getFronts chain = takeL neighbourOverlapp chain
+        getEnds chain = takeR neighbourOverlapp chain
+
+
+
+-- See [Chain based CFG serialization]
+buildChains :: CFG -> [BlockId]
+            -> ( LabelMap BlockChain  -- Resulting chains.
+               , Set.Set (BlockId, BlockId)) --List of fused edges.
+buildChains succWeights blocks
+  = let (_, fusedEdges, chains) = buildNext setEmpty mapEmpty blocks Set.empty
+    in (chains, fusedEdges)
+  where
+    -- We keep a map from the last block in a chain to the chain itself.
+    -- This we we can easily check if an block should be appened to an
+    -- existing chain!
+    buildNext :: LabelSet
+              -> LabelMap BlockChain -- Map from last element to chain.
+              -> [BlockId] -- Blocks to place
+              -> Set.Set (BlockId, BlockId)
+              -> ( [BlockChain]  -- Placed Blocks
+                 , Set.Set (BlockId, BlockId) --List of fused edges
+                 , LabelMap BlockChain
+                 )
+    buildNext _placed chains [] linked =
+        ([], linked, chains)
+    buildNext placed chains (block:todo) linked
+        | setMember block placed
+        = buildNext placed chains todo linked
+        | otherwise
+        = buildNext placed' chains' todo linked'
+      where
+        placed' = (foldl' (flip setInsert) placed placedBlocks)
+        linked' = Set.union linked linkedEdges
+        (placedBlocks, chains', linkedEdges) = findChain block
+
+        --Add the block to a existing or new chain
+        --Returns placed blocks, list of resulting chains
+        --and fused edges
+        findChain :: BlockId
+                -> ([BlockId],LabelMap BlockChain, Set.Set (BlockId, BlockId))
+        findChain block
+        -- B) place block at end of existing chain if
+        -- there is no better block to append.
+          | (pred:_) <- preds
+          , alreadyPlaced pred
+          , Just predChain <- mapLookup pred chains
+          , (best:_) <- filter (not . alreadyPlaced) $ getSuccs pred
+          , best == lbl
+          = --pprTrace "B.2)" (ppr (pred,lbl)) $
+            let newChain = chainSnoc predChain block
+                chainMap = mapInsert lbl newChain $ mapDelete pred chains
+            in  ( [lbl]
+                , chainMap
+                , Set.singleton (pred,lbl) )
+
+          | otherwise
+          = --pprTrace "single" (ppr lbl)
+            ( [lbl]
+            , mapInsert lbl (chainSingleton lbl) chains
+            , Set.empty)
+            where
+              alreadyPlaced blkId = (setMember blkId placed)
+              lbl = block
+              getSuccs = map fst . getSuccEdgesSorted succWeights
+              preds = map fst $ getSuccEdgesSorted predWeights lbl
+    --For efficiency we also create the map to look up predecessors here
+    predWeights = reverseEdges succWeights
+
+
+
+-- We make the CFG a Hoopl Graph, so we can reuse revPostOrder.
+newtype BlockNode e x = BN (BlockId,[BlockId])
+instance NonLocal (BlockNode) where
+  entryLabel (BN (lbl,_))   = lbl
+  successors (BN (_,succs)) = succs
+
+fromNode :: BlockNode C C -> BlockId
+fromNode (BN x) = fst x
+
+sequenceChain :: forall a i. (Instruction i, Outputable i) => LabelMap a -> CFG
+            -> [GenBasicBlock i] -> [GenBasicBlock i]
+sequenceChain _info _weights    [] = []
+sequenceChain _info _weights    [x] = [x]
+sequenceChain  info weights'     blocks@((BasicBlock entry _):_) =
+    --Optimization, delete edges of weight <= 0.
+    --This significantly improves performance whenever
+    --we iterate over all edges, which is a few times!
+    let weights :: CFG
+        weights
+            = filterEdges (\_f _t edgeInfo -> edgeWeight edgeInfo > 0) weights'
+        blockMap :: LabelMap (GenBasicBlock i)
+        blockMap
+            = foldl' (\m blk@(BasicBlock lbl _ins) ->
+                        mapInsert lbl blk m)
+                     mapEmpty blocks
+
+        toNode :: BlockId -> BlockNode C C
+        toNode bid =
+            -- sorted such that heavier successors come first.
+            BN (bid,map fst . getSuccEdgesSorted weights' $ bid)
+
+        orderedBlocks :: [BlockId]
+        orderedBlocks
+            = map fromNode $
+              revPostorderFrom (fmap (toNode . blockId) blockMap) entry
+
+        (builtChains, builtEdges)
+            = {-# SCC "buildChains" #-}
+              --pprTraceIt "generatedChains" $
+              --pprTrace "orderedBlocks" (ppr orderedBlocks) $
+              buildChains weights orderedBlocks
+
+        rankedEdges :: WeightedEdgeList
+        -- Sort edges descending, remove fused eges
+        rankedEdges =
+            map (\(from, to, weight) -> WeightedEdge from to weight) .
+            filter (\(from, to, _)
+                        -> not (Set.member (from,to) builtEdges)) .
+            sortWith (\(_,_,w) -> - w) $ weightedEdgeList weights
+
+        (fusedChains, fusedEdges)
+            = ASSERT(noDups $ mapElems builtChains)
+              {-# SCC "fuseChains" #-}
+              --(pprTrace "RankedEdges" $ ppr rankedEdges) $
+              --pprTraceIt "FusedChains" $
+              fuseChains rankedEdges builtChains
+
+        rankedEdges' =
+            filter (\edge -> not $ Set.member edge fusedEdges) $ rankedEdges
+
+        neighbourChains
+            = ASSERT(noDups $ mapElems fusedChains)
+              {-# SCC "groupNeighbourChains" #-}
+              --pprTraceIt "ResultChains" $
+              combineNeighbourhood rankedEdges' (mapElems fusedChains)
+
+        --Make sure the first block stays first
+        ([entryChain],chains')
+            = ASSERT(noDups $ neighbourChains)
+              partition (chainMember entry) neighbourChains
+        (entryChain':entryRest)
+            | inFront entry entryChain = [entryChain]
+            | (rest,entry) <- breakChainAt entry entryChain
+            = [entry,rest]
+            | otherwise = pprPanic "Entry point eliminated" $
+                            ppr ([entryChain],chains')
+
+        prepedChains
+            = entryChain':(entryRest++chains') :: [BlockChain]
+        blockList
+            -- = (concatMap chainToBlocks prepedChains)
+            = (concatMap seqToList $ map chainBlocks prepedChains)
+
+        --chainPlaced = setFromList $ map blockId blockList :: LabelSet
+        chainPlaced = setFromList $ blockList :: LabelSet
+        unplaced =
+            let blocks = mapKeys blockMap
+                isPlaced b = setMember (b) chainPlaced
+            in filter (\block -> not (isPlaced block)) blocks
+
+        placedBlocks =
+            --pprTraceIt "placedBlocks" $
+            blockList ++ unplaced
+        getBlock bid = expectJust "Block placment" $ mapLookup bid blockMap
+    in
+        --Assert we placed all blocks given as input
+        ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks)
+        dropJumps info $ map getBlock placedBlocks
+
+dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i]
+          -> [GenBasicBlock i]
+dropJumps _    [] = []
+dropJumps info ((BasicBlock lbl ins):todo)
+    | not . null $ ins --This can happen because of shortcutting
+    , [dest] <- jumpDestsOfInstr (last ins)
+    , ((BasicBlock nextLbl _) : _) <- todo
+    , not (mapMember dest info)
+    , nextLbl == dest
+    = BasicBlock lbl (init ins) : dropJumps info todo
+    | otherwise
+    = BasicBlock lbl ins : dropJumps info todo
+
+
+-- -----------------------------------------------------------------------------
+-- Sequencing the basic blocks
+
+-- Cmm BasicBlocks are self-contained entities: they always end in a
+-- jump, either non-local or to another basic block in the same proc.
+-- In this phase, we attempt to place the basic blocks in a sequence
+-- such that as many of the local jumps as possible turn into
+-- fallthroughs.
+
+sequenceTop
+    :: (Instruction instr, Outputable instr)
+    => DynFlags --Use new layout code
+    -> NcgImpl statics instr jumpDest -> CFG
+    -> NatCmmDecl statics instr -> NatCmmDecl statics instr
+
+sequenceTop _     _       _           top@(CmmData _ _) = top
+sequenceTop dflags ncgImpl edgeWeights
+            (CmmProc info lbl live (ListGraph blocks))
+  | (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg dflags
+  --Use chain based algorithm
+  = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
+                            sequenceChain info edgeWeights blocks )
+  | otherwise
+  --Use old algorithm
+  = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
+                            sequenceBlocks cfg info blocks)
+  where
+    cfg
+      | (gopt Opt_WeightlessBlocklayout dflags) ||
+        (not $ backendMaintainsCfg dflags)
+      -- Don't make use of cfg in the old algorithm
+      = Nothing
+      -- Use cfg in the old algorithm
+      | otherwise = Just edgeWeights
+
+-- The old algorithm:
+-- It is very simple (and stupid): We make a graph out of
+-- the blocks where there is an edge from one block to another iff the
+-- first block ends by jumping to the second.  Then we topologically
+-- sort this graph.  Then traverse the list: for each block, we first
+-- output the block, then if it has an out edge, we move the
+-- destination of the out edge to the front of the list, and continue.
+
+-- FYI, the classic layout for basic blocks uses postorder DFS; this
+-- algorithm is implemented in Hoopl.
+
+sequenceBlocks :: Instruction inst => Maybe CFG -> LabelMap a
+               -> [GenBasicBlock inst] -> [GenBasicBlock inst]
+sequenceBlocks _edgeWeight _ [] = []
+sequenceBlocks edgeWeights infos (entry:blocks) =
+    let entryNode = mkNode edgeWeights entry
+        bodyNodes = reverse
+                    (flattenSCCs (sccBlocks edgeWeights blocks))
+    in dropJumps infos . seqBlocks infos $ ( entryNode : bodyNodes)
+  -- the first block is the entry point ==> it must remain at the start.
+
+sccBlocks
+        :: Instruction instr
+        => Maybe CFG -> [NatBasicBlock instr]
+        -> [SCC (Node BlockId (NatBasicBlock instr))]
+sccBlocks edgeWeights blocks =
+    stronglyConnCompFromEdgedVerticesUniqR
+        (map (mkNode edgeWeights) blocks)
+
+mkNode :: (Instruction t)
+       => Maybe CFG -> GenBasicBlock t
+       -> Node BlockId (GenBasicBlock t)
+mkNode edgeWeights block@(BasicBlock id instrs) =
+    DigraphNode block id outEdges
+  where
+    outEdges :: [BlockId]
+    outEdges
+      --Select the heaviest successor, ignore weights <= zero
+      = successor
+      where
+        successor
+          | Just successors <- fmap (`getSuccEdgesSorted` id)
+                                    edgeWeights -- :: Maybe [(Label, EdgeInfo)]
+          = case successors of
+            [] -> []
+            ((target,info):_)
+              | length successors > 2 || edgeWeight info <= 0 -> []
+              | otherwise -> [target]
+          | otherwise
+          = case jumpDestsOfInstr (last instrs) of
+                [one] -> [one]
+                _many -> []
+
+
+seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)]
+                        -> [GenBasicBlock t1]
+seqBlocks infos blocks = placeNext pullable0 todo0
+  where
+    -- pullable: Blocks that are not yet placed
+    -- todo:     Original order of blocks, to be followed if we have no good
+    --           reason not to;
+    --           may include blocks that have already been placed, but then
+    --           these are not in pullable
+    pullable0 = listToUFM [ (i,(b,n)) | DigraphNode b i n <- blocks ]
+    todo0     = map node_key blocks
+
+    placeNext _ [] = []
+    placeNext pullable (i:rest)
+        | Just (block, pullable') <- lookupDeleteUFM pullable i
+        = place pullable' rest block
+        | otherwise
+        -- We already placed this block, so ignore
+        = placeNext pullable rest
+
+    place pullable todo (block,[])
+                          = block : placeNext pullable todo
+    place pullable todo (block@(BasicBlock id instrs),[next])
+        | mapMember next infos
+        = block : placeNext pullable todo
+        | Just (nextBlock, pullable') <- lookupDeleteUFM pullable next
+        = BasicBlock id instrs : place pullable' todo nextBlock
+        | otherwise
+        = block : placeNext pullable todo
+    place _ _ (_,tooManyNextNodes)
+        = pprPanic "seqBlocks" (ppr tooManyNextNodes)
+
+
+lookupDeleteUFM :: Uniquable key => UniqFM elt -> key
+                -> Maybe (elt, UniqFM elt)
+lookupDeleteUFM m k = do -- Maybe monad
+    v <- lookupUFM m k
+    return (v, delFromUFM m k)
+
+-- -------------------------------------------------------------------
+-- Some specialized data structures to speed things up:
+--  * BlockSequence: A specialized version of Data.Sequence.
+--    Better at indexing at the front/end but lacks ability
+--    to do lookup by position.
+
+type FrontierMap = LabelMap ([BlockId],BlockChain)
+
+-- | A "reverse zipper" of sorts.
+-- We store a list of blocks in two parts, the initial part from left to right
+-- and the remaining part stored in reverse order. This makes it easy to look
+-- the last/first element and append on both sides.
+data BlockSequence
+  = Singleton !BlockId
+  | Pair (OrdList BlockId) (OrdList BlockId)
+    -- ^ For a non empty pair there is at least one element in the left part.
+  | Empty
+
+seqFront :: BlockSequence -> BlockId
+seqFront Empty = panic "Empty sequence"
+seqFront (Singleton bid) = bid
+seqFront (Pair lefts rights) = expectJust "Seq invariant" $
+    listToMaybe (fromOL lefts) <|> listToMaybe (fromOL $ reverseOL rights)
+
+-- seqEnd :: BlockSequence -> BlockId
+-- seqEnd Empty = panic "Empty sequence"
+-- seqEnd (Singleton bid) = bid
+-- seqEnd (Pair lefts rights) = expectJust "Seq invariant" $
+--     listToMaybe (fromOL rights) <|> listToMaybe (fromOL $ reverseOL lefts)
+
+seqToList :: BlockSequence -> [BlockId]
+seqToList Empty = []
+seqToList (Singleton bid) = [bid]
+seqToList (Pair lefts rights) = fromOL $ lefts `appOL` reverseOL rights
+
+
+seqToRList :: BlockSequence -> [BlockId]
+seqToRList Empty = []
+seqToRList (Singleton bid) = [bid]
+seqToRList (Pair lefts rights) = fromOL $ rights `appOL` reverseOL lefts
+
+seqSnoc :: BlockSequence -> BlockId -> BlockSequence
+seqSnoc (Empty) bid = Singleton bid
+seqSnoc (Singleton s) bid= Pair (unitOL s) (unitOL bid)
+seqSnoc (Pair lefts rights) bid = Pair lefts (bid `consOL` rights)
+
+seqConcat :: BlockSequence -> BlockSequence -> BlockSequence
+seqConcat (Empty) x2 = x2
+seqConcat (Singleton b1) (Singleton b2) = Pair (unitOL b1) (unitOL b2)
+seqConcat x1 (Empty) = x1
+seqConcat (Singleton b1) (Pair lefts rights) = Pair (b1 `consOL` lefts) rights
+seqConcat (Pair lefts rights) (Singleton b2) = Pair lefts (b2 `consOL` rights)
+seqConcat (Pair lefts1 rights1) (Pair lefts2 rights2) =
+    Pair (lefts1 `appOL` (reverseOL rights1) `appOL` lefts2) rights2
+
+seqFromBids :: [BlockId] -> BlockSequence
+seqFromBids [] = Empty
+seqFromBids [b1] = Singleton b1
+seqFromBids [b1,b2] = Pair (unitOL b1) (unitOL b2)
+seqFromBids [b1,b2,b3] = Pair (consOL b1 $ unitOL b2) (unitOL b3)
+seqFromBids (b1:b2:b3:bs) = Pair (toOL [b1,b2,b3]) (toOL bs)
diff --git a/compiler/nativeGen/CFG.hs b/compiler/nativeGen/CFG.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/CFG.hs
@@ -0,0 +1,656 @@
+--
+-- Copyright (c) 2018 Andreas Klebinger
+--
+
+{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
+
+module CFG
+    ( CFG, CfgEdge(..), EdgeInfo(..), EdgeWeight(..)
+    , TransitionSource(..)
+
+    --Modify the CFG
+    , addWeightEdge, addEdge, delEdge
+    , addNodesBetween, shortcutWeightMap
+    , reverseEdges, filterEdges
+    , addImmediateSuccessor
+    , mkWeightInfo, adjustEdgeWeight
+
+    --Query the CFG
+    , infoEdgeList, edgeList
+    , getSuccessorEdges, getSuccessors
+    , getSuccEdgesSorted, weightedEdgeList
+    , getEdgeInfo
+    , getCfgNodes, hasNode
+    , loopMembers
+
+    --Construction/Misc
+    , getCfg, getCfgProc, pprEdgeWeights, sanityCheckCfg
+
+    --Find backedges and update their weight
+    , optimizeCFG )
+where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import BlockId
+import Cmm ( RawCmmDecl, GenCmmDecl( .. ), CmmBlock, succ, g_entry
+           , CmmGraph )
+import CmmNode
+import CmmUtils
+import CmmSwitch
+import Hoopl.Collections
+import Hoopl.Label
+import Hoopl.Block
+import qualified Hoopl.Graph as G
+
+import Util
+import Digraph
+
+import Outputable
+-- DEBUGGING ONLY
+--import Debug
+--import OrdList
+--import Debug.Trace
+import PprCmm ()
+import qualified DynFlags as D
+
+import Data.List
+
+-- import qualified Data.IntMap.Strict as M --TODO: LabelMap
+
+type Edge = (BlockId, BlockId)
+type Edges = [Edge]
+
+newtype EdgeWeight
+  = EdgeWeight Int
+  deriving (Eq,Ord,Enum,Num,Real,Integral)
+
+instance Outputable EdgeWeight where
+  ppr (EdgeWeight w) = ppr w
+
+type EdgeInfoMap edgeInfo = LabelMap (LabelMap edgeInfo)
+
+-- | A control flow graph where edges have been annotated with a weight.
+type CFG = EdgeInfoMap EdgeInfo
+
+data CfgEdge
+  = CfgEdge
+  { edgeFrom :: !BlockId
+  , edgeTo :: !BlockId
+  , edgeInfo :: !EdgeInfo
+  }
+
+-- | Careful! Since we assume there is at most one edge from A to B
+--   the Eq instance does not consider weight.
+instance Eq CfgEdge where
+  (==) (CfgEdge from1 to1 _) (CfgEdge from2 to2 _)
+    = from1 == from2 && to1 == to2
+
+-- | Edges are sorted ascending pointwise by weight, source and destination
+instance Ord CfgEdge where
+  compare (CfgEdge from1 to1 (EdgeInfo {edgeWeight = weight1}))
+          (CfgEdge from2 to2 (EdgeInfo {edgeWeight = weight2}))
+    | weight1 < weight2 || weight1 == weight2 && from1 < from2 ||
+      weight1 == weight2 && from1 == from2 && to1 < to2
+    = LT
+    | from1 == from2 && to1 == to2 && weight1 == weight2
+    = EQ
+    | otherwise
+    = GT
+
+instance Outputable CfgEdge where
+  ppr (CfgEdge from1 to1 edgeInfo)
+    = parens (ppr from1 <+> text "-(" <> ppr edgeInfo <> text ")->" <+> ppr to1)
+
+-- | Can we trace back a edge to a specific Cmm Node
+-- or has it been introduced for codegen. We use this to maintain
+-- some information which would otherwise be lost during the
+-- Cmm <-> asm transition.
+-- See also Note [Inverting Conditional Branches]
+data TransitionSource
+  = CmmSource (CmmNode O C)
+  | AsmCodeGen
+  deriving (Eq)
+
+-- | Information about edges
+data EdgeInfo
+  = EdgeInfo
+  { transitionSource :: !TransitionSource
+  , edgeWeight :: !EdgeWeight
+  } deriving (Eq)
+
+instance Outputable EdgeInfo where
+  ppr edgeInfo = text "weight:" <+> ppr (edgeWeight edgeInfo)
+
+-- Allow specialization
+{-# INLINEABLE mkWeightInfo #-}
+-- | Convenience function, generate edge info based
+--   on weight not originating from cmm.
+mkWeightInfo :: Integral n => n -> EdgeInfo
+mkWeightInfo = EdgeInfo AsmCodeGen . fromIntegral
+
+-- | Adjust the weight between the blocks using the given function.
+--   If there is no such edge returns the original map.
+adjustEdgeWeight :: CFG -> (EdgeWeight -> EdgeWeight)
+                 -> BlockId -> BlockId -> CFG
+adjustEdgeWeight cfg f from to
+  | Just info <- getEdgeInfo from to cfg
+  , weight <- edgeWeight info
+  = addEdge from to (info { edgeWeight = f weight}) cfg
+  | otherwise = cfg
+
+getCfgNodes :: CFG -> LabelSet
+getCfgNodes m = mapFoldMapWithKey (\k v -> setFromList (k:mapKeys v)) m
+
+hasNode :: CFG -> BlockId -> Bool
+hasNode m node = mapMember node m || any (mapMember node) m
+
+-- | Check if the nodes in the cfg and the set of blocks are the same.
+--   In a case of a missmatch we panic and show the difference.
+sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool
+sanityCheckCfg m blockSet msg
+    | blockSet == cfgNodes
+    = True
+    | otherwise =
+        pprPanic "Block list and cfg nodes don't match" (
+            text "difference:" <+> ppr diff $$
+            text "blocks:" <+> ppr blockSet $$
+            text "cfg:" <+> ppr m $$
+            msg )
+            False
+    where
+      cfgNodes = getCfgNodes m :: LabelSet
+      diff = (setUnion cfgNodes blockSet) `setDifference` (setIntersection cfgNodes blockSet) :: LabelSet
+
+-- | Filter the CFG with a custom function f.
+--   Paramaeters are `f from to edgeInfo`
+filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG
+filterEdges f cfg =
+    mapMapWithKey filterSources cfg
+    where
+      filterSources from m =
+        mapFilterWithKey (\to w -> f from to w) m
+
+
+{- Note [Updating the CFG during shortcutting]
+
+See Note [What is shortcutting] in the control flow optimization
+code (CmmContFlowOpt.hs) for a slightly more in depth explanation on shortcutting.
+
+In the native backend we shortcut jumps at the assembly level. (AsmCodeGen.hs)
+This means we remove blocks containing only one jump from the code
+and instead redirecting all jumps targeting this block to the deleted
+blocks jump target.
+
+However we want to have an accurate representation of control
+flow in the CFG. So we add/remove edges accordingly to account
+for the eliminated blocks and new edges.
+
+If we shortcut A -> B -> C to A -> C:
+* We delete edges A -> B and B -> C
+* Replacing them with the edge A -> C
+
+We also try to preserve jump weights while doing so.
+
+Note that:
+* The edge B -> C can't have interesting weights since
+  the block B consists of a single unconditional jump without branching.
+* We delete the edge A -> B and add the edge A -> C.
+* The edge A -> B can be one of many edges originating from A so likely
+  has edge weights we want to preserve.
+
+For this reason we simply store the edge info from the original A -> B
+edge and apply this information to the new edge A -> C.
+
+Sometimes we have a scenario where jump target C is not represented by an
+BlockId but an immediate value. I'm only aware of this happening without
+tables next to code currently.
+
+Then we go from A ---> B - -> IMM   to   A - -> IMM where the dashed arrows
+are not stored in the CFG.
+
+In that case we simply delete the edge A -> B.
+
+In terms of implementation the native backend first builds a mapping
+from blocks suitable for shortcutting to their jump targets.
+Then it redirects all jump instructions to these blocks using the
+built up mapping.
+This function (shortcutWeightMap) takes the same mapping and
+applies the mapping to the CFG in the way layed out above.
+
+-}
+shortcutWeightMap :: CFG -> LabelMap (Maybe BlockId) -> CFG
+shortcutWeightMap cfg cuts =
+  foldl' applyMapping cfg $ mapToList cuts
+    where
+-- takes the tuple (B,C) from the notation in [Updating the CFG during shortcutting]
+      applyMapping :: CFG -> (BlockId,Maybe BlockId) -> CFG
+      --Shortcut immediate
+      applyMapping m (from, Nothing) =
+        mapDelete from .
+        fmap (mapDelete from) $ m
+      --Regular shortcut
+      applyMapping m (from, Just to) =
+        let updatedMap :: CFG
+            updatedMap
+              = fmap (shortcutEdge (from,to)) $
+                (mapDelete from m :: CFG )
+        --Sometimes we can shortcut multiple blocks like so:
+        -- A -> B -> C -> D -> E => A -> E
+        -- so we check for such chains.
+        in case mapLookup to cuts of
+            Nothing -> updatedMap
+            Just dest -> applyMapping updatedMap (to, dest)
+      --Redirect edge from B to C
+      shortcutEdge :: (BlockId, BlockId) -> LabelMap EdgeInfo -> LabelMap EdgeInfo
+      shortcutEdge (from, to) m =
+        case mapLookup from m of
+          Just info -> mapInsert to info $ mapDelete from m
+          Nothing   -> m
+
+-- | Sometimes we insert a block which should unconditionally be executed
+--   after a given block. This function updates the CFG for these cases.
+--  So we get A -> B    => A -> A' -> B
+--             \                  \
+--              -> C    =>         -> C
+--
+addImmediateSuccessor :: BlockId -> BlockId -> CFG -> CFG
+addImmediateSuccessor node follower cfg
+    = updateEdges . addWeightEdge node follower uncondWeight $ cfg
+    where
+        uncondWeight = fromIntegral . D.uncondWeight .
+                       D.cfgWeightInfo $ D.unsafeGlobalDynFlags
+        targets = getSuccessorEdges cfg node
+        successors = map fst targets :: [BlockId]
+        updateEdges = addNewSuccs . remOldSuccs
+        remOldSuccs m = foldl' (flip (delEdge node)) m successors
+        addNewSuccs m =
+          foldl' (\m' (t,info) -> addEdge follower t info m') m targets
+
+-- | Adds a new edge, overwrites existing edges if present
+addEdge :: BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
+addEdge from to info cfg =
+    mapAlter addDest from cfg
+    where
+        addDest Nothing = Just $ mapSingleton to info
+        addDest (Just wm) = Just $ mapInsert to info wm
+
+-- | Adds a edge with the given weight to the cfg
+--   If there already existed an edge it is overwritten.
+--   `addWeightEdge from to weight cfg`
+addWeightEdge :: BlockId -> BlockId -> EdgeWeight -> CFG -> CFG
+addWeightEdge from to weight cfg =
+    addEdge from to (mkWeightInfo weight) cfg
+
+delEdge :: BlockId -> BlockId -> CFG -> CFG
+delEdge from to m =
+    mapAlter remDest from m
+    where
+        remDest Nothing = Nothing
+        remDest (Just wm) = Just $ mapDelete to wm
+
+-- | Destinations from bid ordered by weight (descending)
+getSuccEdgesSorted :: CFG -> BlockId -> [(BlockId,EdgeInfo)]
+getSuccEdgesSorted m bid =
+    let destMap = mapFindWithDefault mapEmpty bid m
+        cfgEdges = mapToList destMap
+        sortedEdges = sortWith (negate . edgeWeight . snd) cfgEdges
+    in  --pprTrace "getSuccEdgesSorted" (ppr bid <+> text "map:" <+> ppr m)
+        sortedEdges
+
+-- | Get successors of a given node with edge weights.
+getSuccessorEdges :: CFG -> BlockId -> [(BlockId,EdgeInfo)]
+getSuccessorEdges m bid = maybe [] mapToList $ mapLookup bid m
+
+getEdgeInfo :: BlockId -> BlockId -> CFG -> Maybe EdgeInfo
+getEdgeInfo from to m
+    | Just wm <- mapLookup from m
+    , Just info <- mapLookup to wm
+    = Just $! info
+    | otherwise
+    = Nothing
+
+reverseEdges :: CFG -> CFG
+reverseEdges cfg = foldr add mapEmpty flatElems
+  where
+    elems = mapToList $ fmap mapToList cfg :: [(BlockId,[(BlockId,EdgeInfo)])]
+    flatElems =
+        concatMap (\(from,ws) -> map (\(to,info) -> (to,from,info)) ws ) elems
+    add (to,from,info) m = addEdge to from info m
+
+-- | Returns a unordered list of all edges with info
+infoEdgeList :: CFG -> [CfgEdge]
+infoEdgeList m =
+  mapFoldMapWithKey
+    (\from toMap ->
+      map (\(to,info) -> CfgEdge from to info) (mapToList toMap))
+    m
+
+-- | Unordered list of edges with weight as Tuple (from,to,weight)
+weightedEdgeList :: CFG -> [(BlockId,BlockId,EdgeWeight)]
+weightedEdgeList m =
+  mapFoldMapWithKey
+    (\from toMap ->
+      map (\(to,info) ->
+        (from,to, edgeWeight info)) (mapToList toMap))
+    m
+      --  (\(from, tos) -> map (\(to,info) -> (from,to, edgeWeight info)) tos )
+
+-- | Returns a unordered list of all edges without weights
+edgeList :: CFG -> [Edge]
+edgeList m =
+        mapFoldMapWithKey (\from toMap -> fmap (from,) (mapKeys toMap)) m
+
+-- | Get successors of a given node without edge weights.
+getSuccessors :: CFG -> BlockId -> [BlockId]
+getSuccessors m bid
+    | Just wm <- mapLookup bid m
+    = mapKeys wm
+    | otherwise = []
+
+pprEdgeWeights :: CFG -> SDoc
+pprEdgeWeights m =
+    let edges = sort $ weightedEdgeList m
+        printEdge (from, to, weight)
+            = text "\t" <> ppr from <+> text "->" <+> ppr to <>
+              text "[label=\"" <> ppr weight <> text "\",weight=\"" <>
+              ppr weight <> text "\"];\n"
+        --for the case that there are no edges from/to this node.
+        --This should rarely happen but it can save a lot of time
+        --to immediately see it when it does.
+        printNode node
+            = text "\t" <> ppr node <> text ";\n"
+        getEdgeNodes (from, to, _weight) = [from,to]
+        edgeNodes = setFromList $ concatMap getEdgeNodes edges :: LabelSet
+        nodes = filter (\n -> (not . setMember n) edgeNodes) . mapKeys $ mapFilter null m
+    in
+    text "digraph {\n" <>
+        (foldl' (<>) empty (map printEdge edges)) <>
+        (foldl' (<>) empty (map printNode nodes)) <>
+    text "}\n"
+
+{-# INLINE updateEdgeWeight #-} --Allows eliminating the tuple when possible
+updateEdgeWeight :: (EdgeWeight -> EdgeWeight) -> Edge -> CFG -> CFG
+updateEdgeWeight f (from, to) cfg
+    | Just oldInfo <- getEdgeInfo from to cfg
+    = let oldWeight = edgeWeight oldInfo
+          newWeight = f oldWeight
+      in addEdge from to (oldInfo {edgeWeight = newWeight}) cfg
+    | otherwise
+    = panic "Trying to update invalid edge"
+
+-- from to oldWeight => newWeight
+mapWeights :: (BlockId -> BlockId -> EdgeWeight -> EdgeWeight) -> CFG -> CFG
+mapWeights f cfg =
+  foldl' (\cfg (CfgEdge from to info) ->
+            let oldWeight = edgeWeight info
+                newWeight = f from to oldWeight
+            in addEdge from to (info {edgeWeight = newWeight}) cfg)
+          cfg (infoEdgeList cfg)
+
+
+-- | Insert a block in the control flow between two other blocks.
+-- We pass a list of tuples (A,B,C) where
+-- * A -> C: Old edge
+-- * A -> B -> C : New Arc, where B is the new block.
+-- It's possible that a block has two jumps to the same block
+-- in the assembly code. However we still only store a single edge for
+-- these cases.
+-- We assign the old edge info to the edge A -> B and assign B -> C the
+-- weight of an unconditional jump.
+addNodesBetween :: CFG -> [(BlockId,BlockId,BlockId)] -> CFG
+addNodesBetween m updates =
+  foldl'  updateWeight m .
+          weightUpdates $ updates
+    where
+      weight = fromIntegral . D.uncondWeight .
+                D.cfgWeightInfo $ D.unsafeGlobalDynFlags
+      -- We might add two blocks for different jumps along a single
+      -- edge. So we end up with edges:   A -> B -> C   ,   A -> D -> C
+      -- in this case after applying the first update the weight for A -> C
+      -- is no longer available. So we calculate future weights before updates.
+      weightUpdates = map getWeight
+      getWeight :: (BlockId,BlockId,BlockId) -> (BlockId,BlockId,BlockId,EdgeInfo)
+      getWeight (from,between,old)
+        | Just edgeInfo <- getEdgeInfo from old m
+        = (from,between,old,edgeInfo)
+        | otherwise
+        = pprPanic "Can't find weight for edge that should have one" (
+            text "triple" <+> ppr (from,between,old) $$
+            text "updates" <+> ppr updates )
+      updateWeight :: CFG -> (BlockId,BlockId,BlockId,EdgeInfo) -> CFG
+      updateWeight m (from,between,old,edgeInfo)
+        = addEdge from between edgeInfo .
+          addWeightEdge between old weight .
+          delEdge from old $ m
+
+{-
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  ~~~       Note [CFG Edge Weights]    ~~~
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+  Edge weights assigned do not currently represent a specific
+  cost model and rather just a ranking of which blocks should
+  be placed next to each other given their connection type in
+  the CFG.
+  This is especially relevant if we whenever two blocks will
+  jump to the same target.
+
+                     A   B
+                      \ /
+                       C
+
+  Should A or B be placed in front of C? The block layout algorithm
+  decides this based on which edge (A,C)/(B,C) is heavier. So we
+  make a educated guess how often execution will transer control
+  along each edge as well as how much we gain by placing eg A before
+  C.
+
+  We rank edges in this order:
+  * Unconditional Control Transfer - They will always
+    transfer control to their target. Unless there is a info table
+    we can turn the jump into a fallthrough as well.
+    We use 20k as default, so it's easy to spot if values have been
+    modified but unlikely that we run into issues with overflow.
+  * If branches (likely) - We assume branches marked as likely
+    are taken more than 80% of the time.
+    By ranking them below unconditional jumps we make sure we
+    prefer the unconditional if there is a conditional and
+    unconditional edge towards a block.
+  * If branches (regular) - The false branch can potentially be turned
+    into a fallthrough so we prefer it slightly over the true branch.
+  * Unlikely branches - These can be assumed to be taken less than 20%
+    of the time. So we given them one of the lowest priorities.
+  * Switches - Switches at this level are implemented as jump tables
+    so have a larger number of successors. So without more information
+    we can only say that each individual successor is unlikely to be
+    jumped to and we rank them accordingly.
+  * Calls - We currently ignore calls completly:
+        * By the time we return from a call there is a good chance
+          that the address we return to has already been evicted from
+          cache eliminating a main advantage sequential placement brings.
+        * Calls always require a info table in front of their return
+          address. This reduces the chance that we return to the same
+          cache line further.
+
+
+-}
+-- | Generate weights for a Cmm proc based on some simple heuristics.
+getCfgProc :: D.CfgWeights -> RawCmmDecl -> CFG
+getCfgProc _       (CmmData {}) = mapEmpty
+-- Sometimes GHC generates dummy procs which don't actually contain code.
+-- But they might contain bottoms in some fields so we check for an empty
+-- body first. In particular this happens with SplitObjs enabled.
+getCfgProc weights (CmmProc _info _lab _live graph)
+  | null (toBlockList graph) = mapEmpty
+  | otherwise                = getCfg weights graph
+
+getCfg :: D.CfgWeights -> CmmGraph -> CFG
+getCfg weights graph =
+  foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks
+  where
+    D.CFGWeights
+            { D.uncondWeight = uncondWeight
+            , D.condBranchWeight = condBranchWeight
+            , D.switchWeight = switchWeight
+            , D.callWeight = callWeight
+            , D.likelyCondWeight = likelyCondWeight
+            , D.unlikelyCondWeight = unlikelyCondWeight
+            --  Last two are used in other places
+            --, D.infoTablePenalty = infoTablePenalty
+            --, D.backEdgeBonus = backEdgeBonus
+            } = weights
+    -- Explicitly add all nodes to the cfg to ensure they are part of the
+    -- CFG.
+    edgelessCfg = mapFromList $ zip (map G.entryLabel blocks) (repeat mapEmpty)
+    insertEdge :: CFG -> ((BlockId,BlockId),EdgeInfo) -> CFG
+    insertEdge m ((from,to),weight) =
+      mapAlter f from m
+        where
+          f :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
+          f Nothing = Just $ mapSingleton to weight
+          f (Just destMap) = Just $ mapInsert to weight destMap
+    getBlockEdges :: CmmBlock -> [((BlockId,BlockId),EdgeInfo)]
+    getBlockEdges block =
+      case branch of
+        CmmBranch dest -> [mkEdge dest uncondWeight]
+        CmmCondBranch _c t f l
+          | l == Nothing ->
+              [mkEdge f condBranchWeight,   mkEdge t condBranchWeight]
+          | l == Just True ->
+              [mkEdge f unlikelyCondWeight, mkEdge t likelyCondWeight]
+          | l == Just False ->
+              [mkEdge f likelyCondWeight,   mkEdge t unlikelyCondWeight]
+        (CmmSwitch _e ids) ->
+          let switchTargets = switchTargetsToList ids
+              --Compiler performance hack - for very wide switches don't
+              --consider targets for layout.
+              adjustedWeight =
+                if (length switchTargets > 10) then -1 else switchWeight
+          in map (\x -> mkEdge x adjustedWeight) switchTargets
+        (CmmCall { cml_cont = Just cont})  -> [mkEdge cont callWeight]
+        (CmmForeignCall {Cmm.succ = cont}) -> [mkEdge cont callWeight]
+        (CmmCall { cml_cont = Nothing })   -> []
+        other ->
+            panic "Foo" $
+            ASSERT2(False, ppr "Unkown successor cause:" <>
+              (ppr branch <+> text "=>" <> ppr (G.successors other)))
+            map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other
+      where
+        bid = G.entryLabel block
+        mkEdgeInfo = EdgeInfo (CmmSource branch) . fromIntegral
+        mkEdge target weight = ((bid,target), mkEdgeInfo weight)
+        branch = lastNode block :: CmmNode O C
+
+    blocks = revPostorder graph :: [CmmBlock]
+
+--Find back edges by BFS
+findBackEdges :: BlockId -> CFG -> Edges
+findBackEdges root cfg =
+    --pprTraceIt "Backedges:" $
+    map fst .
+    filter (\x -> snd x == Backward) $ typedEdges
+  where
+    edges = edgeList cfg :: [(BlockId,BlockId)]
+    getSuccs = getSuccessors cfg :: BlockId -> [BlockId]
+    typedEdges =
+      classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)]
+
+
+optimizeCFG :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG
+optimizeCFG _ (CmmData {}) cfg = cfg
+optimizeCFG weights (CmmProc info _lab _live graph) cfg =
+    favourFewerPreds  .
+    penalizeInfoTables info .
+    increaseBackEdgeWeight (g_entry graph) $ cfg
+  where
+
+    -- | Increase the weight of all backedges in the CFG
+    -- this helps to make loop jumpbacks the heaviest edges
+    increaseBackEdgeWeight :: BlockId -> CFG -> CFG
+    increaseBackEdgeWeight root cfg =
+        let backedges = findBackEdges root cfg
+            update weight
+              --Keep irrelevant edges irrelevant
+              | weight <= 0 = 0
+              | otherwise
+              = weight + fromIntegral (D.backEdgeBonus weights)
+        in  foldl'  (\cfg edge -> updateEdgeWeight update edge cfg)
+                    cfg backedges
+
+    -- | Since we cant fall through info tables we penalize these.
+    penalizeInfoTables :: LabelMap a -> CFG -> CFG
+    penalizeInfoTables info cfg =
+        mapWeights fupdate cfg
+      where
+        fupdate :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight
+        fupdate _ to weight
+          | mapMember to info
+          = weight - (fromIntegral $ D.infoTablePenalty weights)
+          | otherwise = weight
+
+
+{- Note [Optimize for Fallthrough]
+
+-}
+    -- | If a block has two successors, favour the one with fewer
+    -- predecessors. (As that one is more likely to become a fallthrough)
+    favourFewerPreds :: CFG -> CFG
+    favourFewerPreds cfg =
+        let
+            revCfg =
+              reverseEdges $ filterEdges
+                              (\_from -> fallthroughTarget)  cfg
+
+            predCount n = length $ getSuccessorEdges revCfg n
+            nodes = getCfgNodes cfg
+
+            modifiers :: Int -> Int -> (EdgeWeight, EdgeWeight)
+            modifiers preds1 preds2
+              | preds1 <  preds2 = ( 1,-1)
+              | preds1 == preds2 = ( 0, 0)
+              | otherwise        = (-1, 1)
+
+            update cfg node
+              | [(s1,e1),(s2,e2)] <- getSuccessorEdges cfg node
+              , w1 <- edgeWeight e1
+              , w2 <- edgeWeight e2
+              --Only change the weights if there isn't already a ordering.
+              , w1 == w2
+              , (mod1,mod2) <- modifiers (predCount s1) (predCount s2)
+              = (\cfg' ->
+                  (adjustEdgeWeight cfg' (+mod2) node s2))
+                  (adjustEdgeWeight cfg  (+mod1) node s1)
+              | otherwise
+              = cfg
+        in setFoldl update cfg nodes
+      where
+        fallthroughTarget :: BlockId -> EdgeInfo -> Bool
+        fallthroughTarget to (EdgeInfo source _weight)
+          | mapMember to info = False
+          | AsmCodeGen <- source = True
+          | CmmSource (CmmBranch {}) <- source = True
+          | CmmSource (CmmCondBranch {}) <- source = True
+          | otherwise = False
+
+-- | Determine loop membership of blocks based on SCC analysis
+--   Ideally we would replace this with a variant giving us loop
+--   levels instead but the SCC code will do for now.
+loopMembers :: CFG -> LabelMap Bool
+loopMembers cfg =
+    foldl' (flip setLevel) mapEmpty sccs
+  where
+    mkNode :: BlockId -> Node BlockId BlockId
+    mkNode bid = DigraphNode bid bid (getSuccessors cfg bid)
+    nodes = map mkNode (setElems $ getCfgNodes cfg)
+
+    sccs = stronglyConnCompFromEdgedVerticesOrd nodes
+
+    setLevel :: SCC BlockId -> LabelMap Bool -> LabelMap Bool
+    setLevel (AcyclicSCC bid) m = mapInsert bid False m
+    setLevel (CyclicSCC bids) m = foldl' (\m k -> mapInsert k True m) m bids
diff --git a/compiler/nativeGen/CPrim.hs b/compiler/nativeGen/CPrim.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/CPrim.hs
@@ -0,0 +1,123 @@
+-- | Generating C symbol names emitted by the compiler.
+module CPrim
+    ( atomicReadLabel
+    , atomicWriteLabel
+    , atomicRMWLabel
+    , cmpxchgLabel
+    , popCntLabel
+    , pdepLabel
+    , pextLabel
+    , bSwapLabel
+    , clzLabel
+    , ctzLabel
+    , word2FloatLabel
+    ) where
+
+import GhcPrelude
+
+import CmmType
+import CmmMachOp
+import Outputable
+
+popCntLabel :: Width -> String
+popCntLabel w = "hs_popcnt" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "popCntLabel: Unsupported word width " (ppr w)
+
+pdepLabel :: Width -> String
+pdepLabel w = "hs_pdep" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "pdepLabel: Unsupported word width " (ppr w)
+
+pextLabel :: Width -> String
+pextLabel w = "hs_pext" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "pextLabel: Unsupported word width " (ppr w)
+
+bSwapLabel :: Width -> String
+bSwapLabel w = "hs_bswap" ++ pprWidth w
+  where
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "bSwapLabel: Unsupported word width " (ppr w)
+
+clzLabel :: Width -> String
+clzLabel w = "hs_clz" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "clzLabel: Unsupported word width " (ppr w)
+
+ctzLabel :: Width -> String
+ctzLabel w = "hs_ctz" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "ctzLabel: Unsupported word width " (ppr w)
+
+word2FloatLabel :: Width -> String
+word2FloatLabel w = "hs_word2float" ++ pprWidth w
+  where
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "word2FloatLabel: Unsupported word width " (ppr w)
+
+atomicRMWLabel :: Width -> AtomicMachOp -> String
+atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)
+
+    pprFunName AMO_Add  = "add"
+    pprFunName AMO_Sub  = "sub"
+    pprFunName AMO_And  = "and"
+    pprFunName AMO_Nand = "nand"
+    pprFunName AMO_Or   = "or"
+    pprFunName AMO_Xor  = "xor"
+
+cmpxchgLabel :: Width -> String
+cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w)
+
+atomicReadLabel :: Width -> String
+atomicReadLabel w = "hs_atomicread" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "atomicReadLabel: Unsupported word width " (ppr w)
+
+atomicWriteLabel :: Width -> String
+atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w
+  where
+    pprWidth W8  = "8"
+    pprWidth W16 = "16"
+    pprWidth W32 = "32"
+    pprWidth W64 = "64"
+    pprWidth w   = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w)
diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/Dwarf.hs
@@ -0,0 +1,269 @@
+module Dwarf (
+  dwarfGen
+  ) where
+
+import GhcPrelude
+
+import CLabel
+import CmmExpr         ( GlobalReg(..) )
+import Config          ( cProjectName, cProjectVersion )
+import CoreSyn         ( Tickish(..) )
+import Debug
+import DynFlags
+import Module
+import Outputable
+import Platform
+import Unique
+import UniqSupply
+
+import Dwarf.Constants
+import Dwarf.Types
+
+import Control.Arrow    ( first )
+import Control.Monad    ( mfilter )
+import Data.Maybe
+import Data.List        ( sortBy )
+import Data.Ord         ( comparing )
+import qualified Data.Map as Map
+import System.FilePath
+import System.Directory ( getCurrentDirectory )
+
+import qualified Hoopl.Label as H
+import qualified Hoopl.Collections as H
+
+-- | Generate DWARF/debug information
+dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
+            -> IO (SDoc, UniqSupply)
+dwarfGen _  _      us [] = return (empty, us)
+dwarfGen df modLoc us blocks = do
+
+  -- Convert debug data structures to DWARF info records
+  -- We strip out block information when running with -g0 or -g1.
+  let procs = debugSplitProcs blocks
+      stripBlocks dbg
+        | debugLevel df < 2 = dbg { dblBlocks = [] }
+        | otherwise         = dbg
+  compPath <- getCurrentDirectory
+  let lowLabel = dblCLabel $ head procs
+      highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs
+      dwarfUnit = DwarfCompileUnit
+        { dwChildren = map (procToDwarf df) (map stripBlocks procs)
+        , dwName = fromMaybe "" (ml_hs_file modLoc)
+        , dwCompDir = addTrailingPathSeparator compPath
+        , dwProducer = cProjectName ++ " " ++ cProjectVersion
+        , dwLowLabel = lowLabel
+        , dwHighLabel = highLabel
+        , dwLineLabel = dwarfLineLabel
+        }
+
+  -- Check whether we have any source code information, so we do not
+  -- end up writing a pointer to an empty .debug_line section
+  -- (dsymutil on Mac Os gets confused by this).
+  let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)
+                      || any haveSrcIn (dblBlocks blk)
+      haveSrc = any haveSrcIn procs
+
+  -- .debug_abbrev section: Declare the format we're using
+  let abbrevSct = pprAbbrevDecls haveSrc
+
+  -- .debug_info section: Information records on procedures and blocks
+  let -- unique to identify start and end compilation unit .debug_inf
+      (unitU, us') = takeUniqFromSupply us
+      infoSct = vcat [ ptext dwarfInfoLabel <> colon
+                     , dwarfInfoSection
+                     , compileUnitHeader unitU
+                     , pprDwarfInfo haveSrc dwarfUnit
+                     , compileUnitFooter unitU
+                     ]
+
+  -- .debug_line section: Generated mainly by the assembler, but we
+  -- need to label it
+  let lineSct = dwarfLineSection $$
+                ptext dwarfLineLabel <> colon
+
+  -- .debug_frame section: Information about the layout of the GHC stack
+  let (framesU, us'') = takeUniqFromSupply us'
+      frameSct = dwarfFrameSection $$
+                 ptext dwarfFrameLabel <> colon $$
+                 pprDwarfFrame (debugFrame framesU procs)
+
+  -- .aranges section: Information about the bounds of compilation units
+  let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs
+               | otherwise                 = [DwarfARange lowLabel highLabel]
+  let aranges = dwarfARangesSection $$ pprDwarfARanges aranges' unitU
+
+  return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
+
+-- | Build an address range entry for one proc.
+-- With split sections, each proc needs its own entry, since they may get
+-- scattered in the final binary. Without split sections, we could make a
+-- single arange based on the first/last proc.
+mkDwarfARange :: DebugBlock -> DwarfARange
+mkDwarfARange proc = DwarfARange start end
+  where
+    start = dblCLabel proc
+    end = mkAsmTempEndLabel start
+
+-- | Header for a compilation unit, establishing global format
+-- parameters
+compileUnitHeader :: Unique -> SDoc
+compileUnitHeader unitU = sdocWithPlatform $ \plat ->
+  let cuLabel = mkAsmTempLabel unitU  -- sits right before initialLength field
+      length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel
+               <> text "-4"       -- length of initialLength field
+  in vcat [ ppr cuLabel <> colon
+          , text "\t.long " <> length  -- compilation unit size
+          , pprHalf 3                          -- DWARF version
+          , sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)
+                                               -- abbrevs offset
+          , text "\t.byte " <> ppr (platformWordSize plat) -- word size
+          ]
+
+-- | Compilation unit footer, mainly establishing size of debug sections
+compileUnitFooter :: Unique -> SDoc
+compileUnitFooter unitU =
+  let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU
+  in ppr cuEndLabel <> colon
+
+-- | Splits the blocks by procedures. In the result all nested blocks
+-- will come from the same procedure as the top-level block. See
+-- Note [Splitting DebugBlocks] for details.
+debugSplitProcs :: [DebugBlock] -> [DebugBlock]
+debugSplitProcs b = concat $ H.mapElems $ mergeMaps $ map (split Nothing) b
+  where mergeMaps = foldr (H.mapUnionWithKey (const (++))) H.mapEmpty
+        split :: Maybe DebugBlock -> DebugBlock -> H.LabelMap [DebugBlock]
+        split parent blk = H.mapInsert prc [blk'] nested
+          where prc = dblProcedure blk
+                blk' = blk { dblBlocks = own_blks
+                           , dblParent = parent
+                           }
+                own_blks = fromMaybe [] $ H.mapLookup prc nested
+                nested = mergeMaps $ map (split parent') $ dblBlocks blk
+                -- Figure out who should be the parent of nested blocks.
+                -- If @blk@ is optimized out then it isn't a good choice
+                -- and we just use its parent.
+                parent'
+                  | Nothing <- dblPosition blk = parent
+                  | otherwise                  = Just blk
+
+{-
+Note [Splitting DebugBlocks]
+
+DWARF requires that we break up the nested DebugBlocks produced from
+the C-- AST. For instance, we begin with tick trees containing nested procs.
+For example,
+
+    proc A [tick1, tick2]
+      block B [tick3]
+        proc C [tick4]
+
+when producing DWARF we need to procs (which are represented in DWARF as
+TAG_subprogram DIEs) to be top-level DIEs. debugSplitProcs is responsible for
+this transform, pulling out the nested procs into top-level procs.
+
+However, in doing this we need to be careful to preserve the parentage of the
+nested procs. This is the reason DebugBlocks carry the dblParent field, allowing
+us to reorganize the above tree as,
+
+    proc A [tick1, tick2]
+      block B [tick3]
+    proc C [tick4] parent=B
+
+Here we have annotated the new proc C with an attribute giving its original
+parent, B.
+-}
+
+-- | Generate DWARF info for a procedure debug block
+procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
+procToDwarf df prc
+  = DwarfSubprogram { dwChildren = map (blockToDwarf df) (dblBlocks prc)
+                    , dwName     = case dblSourceTick prc of
+                         Just s@SourceNote{} -> sourceName s
+                         _otherwise -> showSDocDump df $ ppr $ dblLabel prc
+                    , dwLabel    = dblCLabel prc
+                    , dwParent   = fmap mkAsmTempDieLabel
+                                   $ mfilter goodParent
+                                   $ fmap dblCLabel (dblParent prc)
+                    }
+  where
+  goodParent a | a == dblCLabel prc = False
+               -- Omit parent if it would be self-referential
+  goodParent a | not (externallyVisibleCLabel a)
+               , debugLevel df < 2 = False
+               -- We strip block information when running -g0 or -g1, don't
+               -- refer to blocks in that case. Fixes #14894.
+  goodParent _ = True
+
+-- | Generate DWARF info for a block
+blockToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
+blockToDwarf df blk
+  = DwarfBlock { dwChildren = concatMap (tickToDwarf df) (dblTicks blk)
+                              ++ map (blockToDwarf df) (dblBlocks blk)
+               , dwLabel    = dblCLabel blk
+               , dwMarker   = marker
+               }
+  where
+    marker
+      | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk
+      | otherwise                 = Nothing   -- block was optimized out
+
+tickToDwarf :: DynFlags -> Tickish () -> [DwarfInfo]
+tickToDwarf _  (SourceNote ss _) = [DwarfSrcNote ss]
+tickToDwarf _ _ = []
+
+-- | Generates the data for the debug frame section, which encodes the
+-- desired stack unwind behaviour for the debugger
+debugFrame :: Unique -> [DebugBlock] -> DwarfFrame
+debugFrame u procs
+  = DwarfFrame { dwCieLabel = mkAsmTempLabel u
+               , dwCieInit  = initUws
+               , dwCieProcs = map (procToFrame initUws) procs
+               }
+  where
+    initUws :: UnwindTable
+    initUws = Map.fromList [(Sp, Just (UwReg Sp 0))]
+
+-- | Generates unwind information for a procedure debug block
+procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
+procToFrame initUws blk
+  = DwarfFrameProc { dwFdeProc    = dblCLabel blk
+                   , dwFdeHasInfo = dblHasInfoTbl blk
+                   , dwFdeBlocks  = map (uncurry blockToFrame)
+                                        (setHasInfo blockUws)
+                   }
+  where blockUws :: [(DebugBlock, [UnwindPoint])]
+        blockUws = map snd $ sortBy (comparing fst) $ flatten blk
+
+        flatten :: DebugBlock
+                -> [(Int, (DebugBlock, [UnwindPoint]))]
+        flatten b@DebugBlock{ dblPosition=pos, dblUnwind=uws, dblBlocks=blocks }
+          | Just p <- pos  = (p, (b, uws')):nested
+          | otherwise      = nested -- block was optimized out
+          where uws'   = addDefaultUnwindings initUws uws
+                nested = concatMap flatten blocks
+
+        -- | If the current procedure has an info table, then we also say that
+        -- its first block has one to ensure that it gets the necessary -1
+        -- offset applied to its start address.
+        -- See Note [Info Offset] in Dwarf.Types.
+        setHasInfo :: [(DebugBlock, [UnwindPoint])]
+                   -> [(DebugBlock, [UnwindPoint])]
+        setHasInfo [] = []
+        setHasInfo (c0:cs) = first setIt c0 : cs
+          where
+            setIt child =
+              child { dblHasInfoTbl = dblHasInfoTbl child
+                                      || dblHasInfoTbl blk }
+
+blockToFrame :: DebugBlock -> [UnwindPoint] -> DwarfFrameBlock
+blockToFrame blk uws
+  = DwarfFrameBlock { dwFdeBlkHasInfo = dblHasInfoTbl blk
+                    , dwFdeUnwind     = uws
+                    }
+
+addDefaultUnwindings :: UnwindTable -> [UnwindPoint] -> [UnwindPoint]
+addDefaultUnwindings tbl pts =
+    [ UnwindPoint lbl (tbl' `mappend` tbl)
+      -- mappend is left-biased
+    | UnwindPoint lbl tbl' <- pts
+    ]
diff --git a/compiler/nativeGen/Dwarf/Constants.hs b/compiler/nativeGen/Dwarf/Constants.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/Dwarf/Constants.hs
@@ -0,0 +1,229 @@
+-- | Constants describing the DWARF format. Most of this simply
+-- mirrors /usr/include/dwarf.h.
+
+module Dwarf.Constants where
+
+import GhcPrelude
+
+import AsmUtils
+import FastString
+import Platform
+import Outputable
+
+import Reg
+import X86.Regs
+
+import Data.Word
+
+-- | Language ID used for Haskell.
+dW_LANG_Haskell :: Word
+dW_LANG_Haskell = 0x18
+  -- Thanks to Nathan Howell for getting us our very own language ID!
+
+-- * Dwarf tags
+dW_TAG_compile_unit, dW_TAG_subroutine_type,
+  dW_TAG_file_type, dW_TAG_subprogram, dW_TAG_lexical_block,
+  dW_TAG_base_type, dW_TAG_structure_type, dW_TAG_pointer_type,
+  dW_TAG_array_type, dW_TAG_subrange_type, dW_TAG_typedef,
+  dW_TAG_variable, dW_TAG_arg_variable, dW_TAG_auto_variable,
+  dW_TAG_ghc_src_note :: Word
+dW_TAG_array_type      = 1
+dW_TAG_lexical_block   = 11
+dW_TAG_pointer_type    = 15
+dW_TAG_compile_unit    = 17
+dW_TAG_structure_type  = 19
+dW_TAG_typedef         = 22
+dW_TAG_subroutine_type = 32
+dW_TAG_subrange_type   = 33
+dW_TAG_base_type       = 36
+dW_TAG_file_type       = 41
+dW_TAG_subprogram      = 46
+dW_TAG_variable        = 52
+dW_TAG_auto_variable   = 256
+dW_TAG_arg_variable    = 257
+
+dW_TAG_ghc_src_note    = 0x5b00
+
+-- * Dwarf attributes
+dW_AT_name, dW_AT_stmt_list, dW_AT_low_pc, dW_AT_high_pc, dW_AT_language,
+  dW_AT_comp_dir, dW_AT_producer, dW_AT_external, dW_AT_frame_base,
+  dW_AT_use_UTF8, dW_AT_MIPS_linkage_name :: Word
+dW_AT_name              = 0x03
+dW_AT_stmt_list         = 0x10
+dW_AT_low_pc            = 0x11
+dW_AT_high_pc           = 0x12
+dW_AT_language          = 0x13
+dW_AT_comp_dir          = 0x1b
+dW_AT_producer          = 0x25
+dW_AT_external          = 0x3f
+dW_AT_frame_base        = 0x40
+dW_AT_use_UTF8          = 0x53
+dW_AT_MIPS_linkage_name = 0x2007
+
+-- * Custom DWARF attributes
+-- Chosen a more or less random section of the vendor-extensible region
+
+-- ** Describing C-- blocks
+-- These appear in DW_TAG_lexical_scope DIEs corresponding to C-- blocks
+dW_AT_ghc_tick_parent :: Word
+dW_AT_ghc_tick_parent     = 0x2b20
+
+-- ** Describing source notes
+-- These appear in DW_TAG_ghc_src_note DIEs
+dW_AT_ghc_span_file, dW_AT_ghc_span_start_line,
+  dW_AT_ghc_span_start_col, dW_AT_ghc_span_end_line,
+  dW_AT_ghc_span_end_col :: Word
+dW_AT_ghc_span_file       = 0x2b00
+dW_AT_ghc_span_start_line = 0x2b01
+dW_AT_ghc_span_start_col  = 0x2b02
+dW_AT_ghc_span_end_line   = 0x2b03
+dW_AT_ghc_span_end_col    = 0x2b04
+
+
+-- * Abbrev declarations
+dW_CHILDREN_no, dW_CHILDREN_yes :: Word8
+dW_CHILDREN_no  = 0
+dW_CHILDREN_yes = 1
+
+dW_FORM_addr, dW_FORM_data2, dW_FORM_data4, dW_FORM_string, dW_FORM_flag,
+  dW_FORM_block1, dW_FORM_ref4, dW_FORM_ref_addr, dW_FORM_flag_present :: Word
+dW_FORM_addr   = 0x01
+dW_FORM_data2  = 0x05
+dW_FORM_data4  = 0x06
+dW_FORM_string = 0x08
+dW_FORM_flag   = 0x0c
+dW_FORM_block1 = 0x0a
+dW_FORM_ref_addr     = 0x10
+dW_FORM_ref4         = 0x13
+dW_FORM_flag_present = 0x19
+
+-- * Dwarf native types
+dW_ATE_address, dW_ATE_boolean, dW_ATE_float, dW_ATE_signed,
+  dW_ATE_signed_char, dW_ATE_unsigned, dW_ATE_unsigned_char :: Word
+dW_ATE_address       = 1
+dW_ATE_boolean       = 2
+dW_ATE_float         = 4
+dW_ATE_signed        = 5
+dW_ATE_signed_char   = 6
+dW_ATE_unsigned      = 7
+dW_ATE_unsigned_char = 8
+
+-- * Call frame information
+dW_CFA_set_loc, dW_CFA_undefined, dW_CFA_same_value,
+  dW_CFA_def_cfa, dW_CFA_def_cfa_offset, dW_CFA_def_cfa_expression,
+  dW_CFA_expression, dW_CFA_offset_extended_sf, dW_CFA_def_cfa_offset_sf,
+  dW_CFA_def_cfa_sf, dW_CFA_val_offset, dW_CFA_val_expression,
+  dW_CFA_offset :: Word8
+dW_CFA_set_loc            = 0x01
+dW_CFA_undefined          = 0x07
+dW_CFA_same_value         = 0x08
+dW_CFA_def_cfa            = 0x0c
+dW_CFA_def_cfa_offset     = 0x0e
+dW_CFA_def_cfa_expression = 0x0f
+dW_CFA_expression         = 0x10
+dW_CFA_offset_extended_sf = 0x11
+dW_CFA_def_cfa_sf         = 0x12
+dW_CFA_def_cfa_offset_sf  = 0x13
+dW_CFA_val_offset         = 0x14
+dW_CFA_val_expression     = 0x16
+dW_CFA_offset             = 0x80
+
+-- * Operations
+dW_OP_addr, dW_OP_deref, dW_OP_consts,
+  dW_OP_minus, dW_OP_mul, dW_OP_plus,
+  dW_OP_lit0, dW_OP_breg0, dW_OP_call_frame_cfa :: Word8
+dW_OP_addr           = 0x03
+dW_OP_deref          = 0x06
+dW_OP_consts         = 0x11
+dW_OP_minus          = 0x1c
+dW_OP_mul            = 0x1e
+dW_OP_plus           = 0x22
+dW_OP_lit0           = 0x30
+dW_OP_breg0          = 0x70
+dW_OP_call_frame_cfa = 0x9c
+
+-- * Dwarf section declarations
+dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection,
+  dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: SDoc
+dwarfInfoSection    = dwarfSection "info"
+dwarfAbbrevSection  = dwarfSection "abbrev"
+dwarfLineSection    = dwarfSection "line"
+dwarfFrameSection   = dwarfSection "frame"
+dwarfGhcSection     = dwarfSection "ghc"
+dwarfARangesSection = dwarfSection "aranges"
+
+dwarfSection :: String -> SDoc
+dwarfSection name = sdocWithPlatform $ \plat ->
+  case platformOS plat of
+    os | osElfTarget os
+       -> text "\t.section .debug_" <> text name <> text ",\"\","
+          <> sectionType "progbits"
+       | osMachOTarget os
+       -> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug"
+       | otherwise
+       -> text "\t.section .debug_" <> text name <> text ",\"dr\""
+
+-- * Dwarf section labels
+dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: PtrString
+dwarfInfoLabel   = sLit ".Lsection_info"
+dwarfAbbrevLabel = sLit ".Lsection_abbrev"
+dwarfLineLabel   = sLit ".Lsection_line"
+dwarfFrameLabel  = sLit ".Lsection_frame"
+
+-- | Mapping of registers to DWARF register numbers
+dwarfRegNo :: Platform -> Reg -> Word8
+dwarfRegNo p r = case platformArch p of
+  ArchX86
+    | r == eax  -> 0
+    | r == ecx  -> 1  -- yes, no typo
+    | r == edx  -> 2
+    | r == ebx  -> 3
+    | r == esp  -> 4
+    | r == ebp  -> 5
+    | r == esi  -> 6
+    | r == edi  -> 7
+  ArchX86_64
+    | r == rax  -> 0
+    | r == rdx  -> 1 -- this neither. The order GCC allocates registers in?
+    | r == rcx  -> 2
+    | r == rbx  -> 3
+    | r == rsi  -> 4
+    | r == rdi  -> 5
+    | r == rbp  -> 6
+    | r == rsp  -> 7
+    | r == r8   -> 8
+    | r == r9   -> 9
+    | r == r10  -> 10
+    | r == r11  -> 11
+    | r == r12  -> 12
+    | r == r13  -> 13
+    | r == r14  -> 14
+    | r == r15  -> 15
+    | r == xmm0 -> 17
+    | r == xmm1 -> 18
+    | r == xmm2 -> 19
+    | r == xmm3 -> 20
+    | r == xmm4 -> 21
+    | r == xmm5 -> 22
+    | r == xmm6 -> 23
+    | r == xmm7 -> 24
+    | r == xmm8 -> 25
+    | r == xmm9 -> 26
+    | r == xmm10 -> 27
+    | r == xmm11 -> 28
+    | r == xmm12 -> 29
+    | r == xmm13 -> 30
+    | r == xmm14 -> 31
+    | r == xmm15 -> 32
+  _other -> error "dwarfRegNo: Unsupported platform or unknown register!"
+
+-- | Virtual register number to use for return address.
+dwarfReturnRegNo :: Platform -> Word8
+dwarfReturnRegNo p
+  -- We "overwrite" IP with our pseudo register - that makes sense, as
+  -- when using this mechanism gdb already knows the IP anyway. Clang
+  -- does this too, so it must be safe.
+  = case platformArch p of
+    ArchX86    -> 8  -- eip
+    ArchX86_64 -> 16 -- rip
+    _other     -> error "dwarfReturnRegNo: Unsupported platform!"
diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/Dwarf/Types.hs
@@ -0,0 +1,613 @@
+module Dwarf.Types
+  ( -- * Dwarf information
+    DwarfInfo(..)
+  , pprDwarfInfo
+  , pprAbbrevDecls
+    -- * Dwarf address range table
+  , DwarfARange(..)
+  , pprDwarfARanges
+    -- * Dwarf frame
+  , DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..)
+  , pprDwarfFrame
+    -- * Utilities
+  , pprByte
+  , pprHalf
+  , pprData4'
+  , pprDwWord
+  , pprWord
+  , pprLEBWord
+  , pprLEBInt
+  , wordAlign
+  , sectionOffset
+  )
+  where
+
+import GhcPrelude
+
+import Debug
+import CLabel
+import CmmExpr         ( GlobalReg(..) )
+import Encoding
+import FastString
+import Outputable
+import Platform
+import Unique
+import Reg
+import SrcLoc
+import Util
+
+import Dwarf.Constants
+
+import qualified Control.Monad.Trans.State.Strict as S
+import Control.Monad (zipWithM, join)
+import Data.Bits
+import qualified Data.Map as Map
+import Data.Word
+import Data.Char
+
+import CodeGen.Platform
+
+-- | Individual dwarf records. Each one will be encoded as an entry in
+-- the @.debug_info@ section.
+data DwarfInfo
+  = DwarfCompileUnit { dwChildren :: [DwarfInfo]
+                     , dwName :: String
+                     , dwProducer :: String
+                     , dwCompDir :: String
+                     , dwLowLabel :: CLabel
+                     , dwHighLabel :: CLabel
+                     , dwLineLabel :: PtrString }
+  | DwarfSubprogram { dwChildren :: [DwarfInfo]
+                    , dwName :: String
+                    , dwLabel :: CLabel
+                    , dwParent :: Maybe CLabel
+                      -- ^ label of DIE belonging to the parent tick
+                    }
+  | DwarfBlock { dwChildren :: [DwarfInfo]
+               , dwLabel :: CLabel
+               , dwMarker :: Maybe CLabel
+               }
+  | DwarfSrcNote { dwSrcSpan :: RealSrcSpan
+                 }
+
+-- | Abbreviation codes used for encoding above records in the
+-- @.debug_info@ section.
+data DwarfAbbrev
+  = DwAbbrNull          -- ^ Pseudo, used for marking the end of lists
+  | DwAbbrCompileUnit
+  | DwAbbrSubprogram
+  | DwAbbrSubprogramWithParent
+  | DwAbbrBlockWithoutCode
+  | DwAbbrBlock
+  | DwAbbrGhcSrcNote
+  deriving (Eq, Enum)
+
+-- | Generate assembly for the given abbreviation code
+pprAbbrev :: DwarfAbbrev -> SDoc
+pprAbbrev = pprLEBWord . fromIntegral . fromEnum
+
+-- | Abbreviation declaration. This explains the binary encoding we
+-- use for representing 'DwarfInfo'. Be aware that this must be updated
+-- along with 'pprDwarfInfo'.
+pprAbbrevDecls :: Bool -> SDoc
+pprAbbrevDecls haveDebugLine =
+  let mkAbbrev abbr tag chld flds =
+        let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form
+        in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$
+           vcat (map fld flds) $$ pprByte 0 $$ pprByte 0
+      -- These are shared between DwAbbrSubprogram and
+      -- DwAbbrSubprogramWithParent
+      subprogramAttrs =
+           [ (dW_AT_name, dW_FORM_string)
+           , (dW_AT_MIPS_linkage_name, dW_FORM_string)
+           , (dW_AT_external, dW_FORM_flag)
+           , (dW_AT_low_pc, dW_FORM_addr)
+           , (dW_AT_high_pc, dW_FORM_addr)
+           , (dW_AT_frame_base, dW_FORM_block1)
+           ]
+  in dwarfAbbrevSection $$
+     ptext dwarfAbbrevLabel <> colon $$
+     mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes
+       ([(dW_AT_name,     dW_FORM_string)
+       , (dW_AT_producer, dW_FORM_string)
+       , (dW_AT_language, dW_FORM_data4)
+       , (dW_AT_comp_dir, dW_FORM_string)
+       , (dW_AT_use_UTF8, dW_FORM_flag_present)  -- not represented in body
+       , (dW_AT_low_pc,   dW_FORM_addr)
+       , (dW_AT_high_pc,  dW_FORM_addr)
+       ] ++
+       (if haveDebugLine
+        then [ (dW_AT_stmt_list, dW_FORM_data4) ]
+        else [])) $$
+     mkAbbrev DwAbbrSubprogram dW_TAG_subprogram dW_CHILDREN_yes
+       subprogramAttrs $$
+     mkAbbrev DwAbbrSubprogramWithParent dW_TAG_subprogram dW_CHILDREN_yes
+       (subprogramAttrs ++ [(dW_AT_ghc_tick_parent, dW_FORM_ref_addr)]) $$
+     mkAbbrev DwAbbrBlockWithoutCode dW_TAG_lexical_block dW_CHILDREN_yes
+       [ (dW_AT_name, dW_FORM_string)
+       ] $$
+     mkAbbrev DwAbbrBlock dW_TAG_lexical_block dW_CHILDREN_yes
+       [ (dW_AT_name, dW_FORM_string)
+       , (dW_AT_low_pc, dW_FORM_addr)
+       , (dW_AT_high_pc, dW_FORM_addr)
+       ] $$
+     mkAbbrev DwAbbrGhcSrcNote dW_TAG_ghc_src_note dW_CHILDREN_no
+       [ (dW_AT_ghc_span_file, dW_FORM_string)
+       , (dW_AT_ghc_span_start_line, dW_FORM_data4)
+       , (dW_AT_ghc_span_start_col, dW_FORM_data2)
+       , (dW_AT_ghc_span_end_line, dW_FORM_data4)
+       , (dW_AT_ghc_span_end_col, dW_FORM_data2)
+       ] $$
+     pprByte 0
+
+-- | Generate assembly for DWARF data
+pprDwarfInfo :: Bool -> DwarfInfo -> SDoc
+pprDwarfInfo haveSrc d
+  = case d of
+      DwarfCompileUnit {}  -> hasChildren
+      DwarfSubprogram {}   -> hasChildren
+      DwarfBlock {}        -> hasChildren
+      DwarfSrcNote {}      -> noChildren
+  where
+    hasChildren =
+        pprDwarfInfoOpen haveSrc d $$
+        vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$
+        pprDwarfInfoClose
+    noChildren = pprDwarfInfoOpen haveSrc d
+
+-- | Prints assembler data corresponding to DWARF info records. Note
+-- that the binary format of this is parameterized in @abbrevDecls@ and
+-- has to be kept in synch.
+pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc
+pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
+                                           highLabel lineLbl) =
+  pprAbbrev DwAbbrCompileUnit
+  $$ pprString name
+  $$ pprString producer
+  $$ pprData4 dW_LANG_Haskell
+  $$ pprString compDir
+  $$ pprWord (ppr lowLabel)
+  $$ pprWord (ppr highLabel)
+  $$ if haveSrc
+     then sectionOffset (ptext lineLbl) (ptext dwarfLineLabel)
+     else empty
+pprDwarfInfoOpen _ (DwarfSubprogram _ name label
+                                    parent) = sdocWithDynFlags $ \df ->
+  ppr (mkAsmTempDieLabel label) <> colon
+  $$ pprAbbrev abbrev
+  $$ pprString name
+  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
+  $$ pprFlag (externallyVisibleCLabel label)
+  $$ pprWord (ppr label)
+  $$ pprWord (ppr $ mkAsmTempEndLabel label)
+  $$ pprByte 1
+  $$ pprByte dW_OP_call_frame_cfa
+  $$ parentValue
+  where
+    abbrev = case parent of Nothing -> DwAbbrSubprogram
+                            Just _  -> DwAbbrSubprogramWithParent
+    parentValue = maybe empty pprParentDie parent
+    pprParentDie sym = sectionOffset (ppr sym) (ptext dwarfInfoLabel)
+pprDwarfInfoOpen _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->
+  ppr (mkAsmTempDieLabel label) <> colon
+  $$ pprAbbrev DwAbbrBlockWithoutCode
+  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
+pprDwarfInfoOpen _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->
+  ppr (mkAsmTempDieLabel label) <> colon
+  $$ pprAbbrev DwAbbrBlock
+  $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
+  $$ pprWord (ppr marker)
+  $$ pprWord (ppr $ mkAsmTempEndLabel marker)
+pprDwarfInfoOpen _ (DwarfSrcNote ss) =
+  pprAbbrev DwAbbrGhcSrcNote
+  $$ pprString' (ftext $ srcSpanFile ss)
+  $$ pprData4 (fromIntegral $ srcSpanStartLine ss)
+  $$ pprHalf (fromIntegral $ srcSpanStartCol ss)
+  $$ pprData4 (fromIntegral $ srcSpanEndLine ss)
+  $$ pprHalf (fromIntegral $ srcSpanEndCol ss)
+
+-- | Close a DWARF info record with children
+pprDwarfInfoClose :: SDoc
+pprDwarfInfoClose = pprAbbrev DwAbbrNull
+
+-- | A DWARF address range. This is used by the debugger to quickly locate
+-- which compilation unit a given address belongs to. This type assumes
+-- a non-segmented address-space.
+data DwarfARange
+  = DwarfARange
+    { dwArngStartLabel :: CLabel
+    , dwArngEndLabel   :: CLabel
+    }
+
+-- | Print assembler directives corresponding to a DWARF @.debug_aranges@
+-- address table entry.
+pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc
+pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->
+  let wordSize = platformWordSize plat
+      paddingSize = 4 :: Int
+      -- header is 12 bytes long.
+      -- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).
+      -- pad such that first entry begins at multiple of entry size.
+      pad n = vcat $ replicate n $ pprByte 0
+      initialLength = 8 + paddingSize + 2*2*wordSize
+  in pprDwWord (ppr initialLength)
+     $$ pprHalf 2
+     $$ sectionOffset (ppr $ mkAsmTempLabel $ unitU)
+                      (ptext dwarfInfoLabel)
+     $$ pprByte (fromIntegral wordSize)
+     $$ pprByte 0
+     $$ pad paddingSize
+     -- body
+     $$ vcat (map pprDwarfARange arngs)
+     -- terminus
+     $$ pprWord (char '0')
+     $$ pprWord (char '0')
+
+pprDwarfARange :: DwarfARange -> SDoc
+pprDwarfARange arng = pprWord (ppr $ dwArngStartLabel arng) $$ pprWord length
+  where
+    length = ppr (dwArngEndLabel arng)
+             <> char '-' <> ppr (dwArngStartLabel arng)
+
+-- | Information about unwind instructions for a procedure. This
+-- corresponds to a "Common Information Entry" (CIE) in DWARF.
+data DwarfFrame
+  = DwarfFrame
+    { dwCieLabel :: CLabel
+    , dwCieInit  :: UnwindTable
+    , dwCieProcs :: [DwarfFrameProc]
+    }
+
+-- | Unwind instructions for an individual procedure. Corresponds to a
+-- "Frame Description Entry" (FDE) in DWARF.
+data DwarfFrameProc
+  = DwarfFrameProc
+    { dwFdeProc    :: CLabel
+    , dwFdeHasInfo :: Bool
+    , dwFdeBlocks  :: [DwarfFrameBlock]
+      -- ^ List of blocks. Order must match asm!
+    }
+
+-- | Unwind instructions for a block. Will become part of the
+-- containing FDE.
+data DwarfFrameBlock
+  = DwarfFrameBlock
+    { dwFdeBlkHasInfo :: Bool
+    , dwFdeUnwind     :: [UnwindPoint]
+      -- ^ these unwind points must occur in the same order as they occur
+      -- in the block
+    }
+
+instance Outputable DwarfFrameBlock where
+  ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds
+
+-- | Header for the @.debug_frame@ section. Here we emit the "Common
+-- Information Entry" record that etablishes general call frame
+-- parameters and the default stack layout.
+pprDwarfFrame :: DwarfFrame -> SDoc
+pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
+  = sdocWithPlatform $ \plat ->
+    let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")
+        cieEndLabel = mkAsmTempEndLabel cieLabel
+        length      = ppr cieEndLabel <> char '-' <> ppr cieStartLabel
+        spReg       = dwarfGlobalRegNo plat Sp
+        retReg      = dwarfReturnRegNo plat
+        wordSize    = platformWordSize plat
+        pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc
+        pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw)
+
+        -- Preserve C stack pointer: This necessary to override that default
+        -- unwinding behavior of setting $sp = CFA.
+        preserveSp = case platformArch plat of
+          ArchX86    -> pprByte dW_CFA_same_value $$ pprLEBWord 4
+          ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7
+          _          -> empty
+    in vcat [ ppr cieLabel <> colon
+            , pprData4' length -- Length of CIE
+            , ppr cieStartLabel <> colon
+            , pprData4' (text "-1")
+                               -- Common Information Entry marker (-1 = 0xf..f)
+            , pprByte 3        -- CIE version (we require DWARF 3)
+            , pprByte 0        -- Augmentation (none)
+            , pprByte 1        -- Code offset multiplicator
+            , pprByte (128-fromIntegral wordSize)
+                               -- Data offset multiplicator
+                               -- (stacks grow down => "-w" in signed LEB128)
+            , pprByte retReg   -- virtual register holding return address
+            ] $$
+       -- Initial unwind table
+       vcat (map pprInit $ Map.toList cieInit) $$
+       vcat [ -- RET = *CFA
+              pprByte (dW_CFA_offset+retReg)
+            , pprByte 0
+
+              -- Preserve C stack pointer
+            , preserveSp
+
+              -- Sp' = CFA
+              -- (we need to set this manually as our (STG) Sp register is
+              -- often not the architecture's default stack register)
+            , pprByte dW_CFA_val_offset
+            , pprLEBWord (fromIntegral spReg)
+            , pprLEBWord 0
+            ] $$
+       wordAlign $$
+       ppr cieEndLabel <> colon $$
+       -- Procedure unwind tables
+       vcat (map (pprFrameProc cieLabel cieInit) procs)
+
+-- | Writes a "Frame Description Entry" for a procedure. This consists
+-- mainly of referencing the CIE and writing state machine
+-- instructions to describe how the frame base (CFA) changes.
+pprFrameProc :: CLabel -> UnwindTable -> DwarfFrameProc -> SDoc
+pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
+  = let fdeLabel    = mkAsmTempDerivedLabel procLbl (fsLit "_fde")
+        fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end")
+        procEnd     = mkAsmTempEndLabel procLbl
+        ifInfo str  = if hasInfo then text str else empty
+                      -- see [Note: Info Offset]
+    in vcat [ whenPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon
+            , pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel)
+            , ppr fdeLabel <> colon
+            , pprData4' (ppr frameLbl <> char '-' <>
+                         ptext dwarfFrameLabel)    -- Reference to CIE
+            , pprWord (ppr procLbl <> ifInfo "-1") -- Code pointer
+            , pprWord (ppr procEnd <> char '-' <>
+                       ppr procLbl <> ifInfo "+1") -- Block byte length
+            ] $$
+       vcat (S.evalState (mapM pprFrameBlock blocks) initUw) $$
+       wordAlign $$
+       ppr fdeEndLabel <> colon
+
+-- | Generates unwind information for a block. We only generate
+-- instructions where unwind information actually changes. This small
+-- optimisations saves a lot of space, as subsequent blocks often have
+-- the same unwind information.
+pprFrameBlock :: DwarfFrameBlock -> S.State UnwindTable SDoc
+pprFrameBlock (DwarfFrameBlock hasInfo uws0) =
+    vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0
+  where
+    pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc
+    pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws ->
+        let -- Did a register's unwind expression change?
+            isChanged :: GlobalReg -> Maybe UnwindExpr
+                      -> Maybe (Maybe UnwindExpr, Maybe UnwindExpr)
+            isChanged g new
+                -- the value didn't change
+              | Just new == old = Nothing
+                -- the value was and still is undefined
+              | Nothing <- old
+              , Nothing <- new  = Nothing
+                -- the value changed
+              | otherwise       = Just (join old, new)
+              where
+                old = Map.lookup g oldUws
+
+            changed = Map.toList $ Map.mapMaybeWithKey isChanged uws
+
+        in if oldUws == uws
+             then (empty, oldUws)
+             else let -- see [Note: Info Offset]
+                      needsOffset = firstDecl && hasInfo
+                      lblDoc = ppr lbl <>
+                               if needsOffset then text "-1" else empty
+                      doc = sdocWithPlatform $ \plat ->
+                           pprByte dW_CFA_set_loc $$ pprWord lblDoc $$
+                           vcat (map (uncurry $ pprSetUnwind plat) changed)
+                  in (doc, uws)
+
+-- Note [Info Offset]
+--
+-- GDB was pretty much written with C-like programs in mind, and as a
+-- result they assume that once you have a return address, it is a
+-- good idea to look at (PC-1) to unwind further - as that's where the
+-- "call" instruction is supposed to be.
+--
+-- Now on one hand, code generated by GHC looks nothing like what GDB
+-- expects, and in fact going up from a return pointer is guaranteed
+-- to land us inside an info table! On the other hand, that actually
+-- gives us some wiggle room, as we expect IP to never *actually* end
+-- up inside the info table, so we can "cheat" by putting whatever GDB
+-- expects to see there. This is probably pretty safe, as GDB cannot
+-- assume (PC-1) to be a valid code pointer in the first place - and I
+-- have seen no code trying to correct this.
+--
+-- Note that this will not prevent GDB from failing to look-up the
+-- correct function name for the frame, as that uses the symbol table,
+-- which we can not manipulate as easily.
+--
+-- There's a GDB patch to address this at [1]. At the moment of writing
+-- it's not merged, so I recommend building GDB with the patch if you
+-- care about unwinding. The hack above doesn't cover every case.
+--
+-- [1] https://sourceware.org/ml/gdb-patches/2018-02/msg00055.html
+
+-- | Get DWARF register ID for a given GlobalReg
+dwarfGlobalRegNo :: Platform -> GlobalReg -> Word8
+dwarfGlobalRegNo p UnwindReturnReg = dwarfReturnRegNo p
+dwarfGlobalRegNo p reg = maybe 0 (dwarfRegNo p . RegReal) $ globalRegMaybe p reg
+
+-- | Generate code for setting the unwind information for a register,
+-- optimized using its known old value in the table. Note that "Sp" is
+-- special: We see it as synonym for the CFA.
+pprSetUnwind :: Platform
+             -> GlobalReg
+                -- ^ the register to produce an unwinding table entry for
+             -> (Maybe UnwindExpr, Maybe UnwindExpr)
+                -- ^ the old and new values of the register
+             -> SDoc
+pprSetUnwind plat g  (_, Nothing)
+  = pprUndefUnwind plat g
+pprSetUnwind _    Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s'
+  = if o' >= 0
+    then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o')
+    else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o'
+pprSetUnwind plat Sp (_, Just (UwReg s' o'))
+  = if o' >= 0
+    then pprByte dW_CFA_def_cfa $$
+         pprLEBRegNo plat s' $$
+         pprLEBWord (fromIntegral o')
+    else pprByte dW_CFA_def_cfa_sf $$
+         pprLEBRegNo plat s' $$
+         pprLEBInt o'
+pprSetUnwind _    Sp (_, Just uw)
+  = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr False uw
+pprSetUnwind plat g  (_, Just (UwDeref (UwReg Sp o)))
+  | o < 0 && ((-o) `mod` platformWordSize plat) == 0 -- expected case
+  = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$
+    pprLEBWord (fromIntegral ((-o) `div` platformWordSize plat))
+  | otherwise
+  = pprByte dW_CFA_offset_extended_sf $$
+    pprLEBRegNo plat g $$
+    pprLEBInt o
+pprSetUnwind plat g  (_, Just (UwDeref uw))
+  = pprByte dW_CFA_expression $$
+    pprLEBRegNo plat g $$
+    pprUnwindExpr True uw
+pprSetUnwind plat g  (_, Just (UwReg g' 0))
+  | g == g'
+  = pprByte dW_CFA_same_value $$
+    pprLEBRegNo plat g
+pprSetUnwind plat g  (_, Just uw)
+  = pprByte dW_CFA_val_expression $$
+    pprLEBRegNo plat g $$
+    pprUnwindExpr True uw
+
+-- | Print the register number of the given 'GlobalReg' as an unsigned LEB128
+-- encoded number.
+pprLEBRegNo :: Platform -> GlobalReg -> SDoc
+pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat
+
+-- | Generates a DWARF expression for the given unwind expression. If
+-- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets
+-- mentioned.
+pprUnwindExpr :: Bool -> UnwindExpr -> SDoc
+pprUnwindExpr spIsCFA expr
+  = sdocWithPlatform $ \plat ->
+    let pprE (UwConst i)
+          | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i)
+          | otherwise        = pprByte dW_OP_consts $$ pprLEBInt i -- lazy...
+        pprE (UwReg Sp i) | spIsCFA
+                             = if i == 0
+                               then pprByte dW_OP_call_frame_cfa
+                               else pprE (UwPlus (UwReg Sp 0) (UwConst i))
+        pprE (UwReg g i)      = pprByte (dW_OP_breg0+dwarfGlobalRegNo plat g) $$
+                               pprLEBInt i
+        pprE (UwDeref u)      = pprE u $$ pprByte dW_OP_deref
+        pprE (UwLabel l)      = pprByte dW_OP_addr $$ pprWord (ppr l)
+        pprE (UwPlus u1 u2)   = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus
+        pprE (UwMinus u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus
+        pprE (UwTimes u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul
+    in text "\t.uleb128 2f-1f" $$ -- DW_FORM_block length
+       -- computed as the difference of the following local labels 2: and 1:
+       text "1:" $$
+       pprE expr $$
+       text "2:"
+
+-- | Generate code for re-setting the unwind information for a
+-- register to @undefined@
+pprUndefUnwind :: Platform -> GlobalReg -> SDoc
+pprUndefUnwind plat g  = pprByte dW_CFA_undefined $$
+                         pprLEBRegNo plat g
+
+
+-- | Align assembly at (machine) word boundary
+wordAlign :: SDoc
+wordAlign = sdocWithPlatform $ \plat ->
+  text "\t.align " <> case platformOS plat of
+    OSDarwin -> case platformWordSize plat of
+      8      -> text "3"
+      4      -> text "2"
+      _other -> error "wordAlign: Unsupported word size!"
+    _other   -> ppr (platformWordSize plat)
+
+-- | Assembly for a single byte of constant DWARF data
+pprByte :: Word8 -> SDoc
+pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word)
+
+-- | Assembly for a two-byte constant integer
+pprHalf :: Word16 -> SDoc
+pprHalf x = text "\t.short" <+> ppr (fromIntegral x :: Word)
+
+-- | Assembly for a constant DWARF flag
+pprFlag :: Bool -> SDoc
+pprFlag f = pprByte (if f then 0xff else 0x00)
+
+-- | Assembly for 4 bytes of dynamic DWARF data
+pprData4' :: SDoc -> SDoc
+pprData4' x = text "\t.long " <> x
+
+-- | Assembly for 4 bytes of constant DWARF data
+pprData4 :: Word -> SDoc
+pprData4 = pprData4' . ppr
+
+-- | Assembly for a DWARF word of dynamic data. This means 32 bit, as
+-- we are generating 32 bit DWARF.
+pprDwWord :: SDoc -> SDoc
+pprDwWord = pprData4'
+
+-- | Assembly for a machine word of dynamic data. Depends on the
+-- architecture we are currently generating code for.
+pprWord :: SDoc -> SDoc
+pprWord s = (<> s) . sdocWithPlatform $ \plat ->
+  case platformWordSize plat of
+    4 -> text "\t.long "
+    8 -> text "\t.quad "
+    n -> panic $ "pprWord: Unsupported target platform word length " ++
+                 show n ++ "!"
+
+-- | Prints a number in "little endian base 128" format. The idea is
+-- to optimize for small numbers by stopping once all further bytes
+-- would be 0. The highest bit in every byte signals whether there
+-- are further bytes to read.
+pprLEBWord :: Word -> SDoc
+pprLEBWord x | x < 128   = pprByte (fromIntegral x)
+             | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
+                           pprLEBWord (x `shiftR` 7)
+
+-- | Same as @pprLEBWord@, but for a signed number
+pprLEBInt :: Int -> SDoc
+pprLEBInt x | x >= -64 && x < 64
+                        = pprByte (fromIntegral (x .&. 127))
+            | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$
+                          pprLEBInt (x `shiftR` 7)
+
+-- | Generates a dynamic null-terminated string. If required the
+-- caller needs to make sure that the string is escaped properly.
+pprString' :: SDoc -> SDoc
+pprString' str = text "\t.asciz \"" <> str <> char '"'
+
+-- | Generate a string constant. We take care to escape the string.
+pprString :: String -> SDoc
+pprString str
+  = pprString' $ hcat $ map escapeChar $
+    if str `lengthIs` utf8EncodedLength str
+    then str
+    else map (chr . fromIntegral) $ bytesFS $ mkFastString str
+
+-- | Escape a single non-unicode character
+escapeChar :: Char -> SDoc
+escapeChar '\\' = text "\\\\"
+escapeChar '\"' = text "\\\""
+escapeChar '\n' = text "\\n"
+escapeChar c
+  | isAscii c && isPrint c && c /= '?' -- prevents trigraph warnings
+  = char c
+  | otherwise
+  = char '\\' <> char (intToDigit (ch `div` 64)) <>
+                 char (intToDigit ((ch `div` 8) `mod` 8)) <>
+                 char (intToDigit (ch `mod` 8))
+  where ch = ord c
+
+-- | Generate an offset into another section. This is tricky because
+-- this is handled differently depending on platform: Mac Os expects
+-- us to calculate the offset using assembler arithmetic. Linux expects
+-- us to just reference the target directly, and will figure out on
+-- their own that we actually need an offset. Finally, Windows has
+-- a special directive to refer to relative offsets. Fun.
+sectionOffset :: SDoc -> SDoc -> SDoc
+sectionOffset target section = sdocWithPlatform $ \plat ->
+  case platformOS plat of
+    OSDarwin  -> pprDwWord (target <> char '-' <> section)
+    OSMinGW32 -> text "\t.secrel32 " <> target
+    _other    -> pprDwWord target
diff --git a/compiler/nativeGen/Format.hs b/compiler/nativeGen/Format.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/Format.hs
@@ -0,0 +1,107 @@
+-- | Formats on this architecture
+--      A Format is a combination of width and class
+--
+--      TODO:   Signed vs unsigned?
+--
+--      TODO:   This module is currenly shared by all architectures because
+--              NCGMonad need to know about it to make a VReg. It would be better
+--              to have architecture specific formats, and do the overloading
+--              properly. eg SPARC doesn't care about FF80.
+--
+module Format (
+    Format(..),
+    intFormat,
+    floatFormat,
+    isFloatFormat,
+    cmmTypeFormat,
+    formatToWidth,
+    formatInBytes
+)
+
+where
+
+import GhcPrelude
+
+import Cmm
+import Outputable
+
+-- It looks very like the old MachRep, but it's now of purely local
+-- significance, here in the native code generator.  You can change it
+-- without global consequences.
+--
+-- A major use is as an opcode qualifier; thus the opcode
+--      mov.l a b
+-- might be encoded
+--      MOV II32 a b
+-- where the Format field encodes the ".l" part.
+
+-- ToDo: it's not clear to me that we need separate signed-vs-unsigned formats
+--        here.  I've removed them from the x86 version, we'll see what happens --SDM
+
+-- ToDo: quite a few occurrences of Format could usefully be replaced by Width
+
+data Format
+        = II8
+        | II16
+        | II32
+        | II64
+        | FF32
+        | FF64
+        | FF80
+        deriving (Show, Eq)
+
+
+-- | Get the integer format of this width.
+intFormat :: Width -> Format
+intFormat width
+ = case width of
+        W8      -> II8
+        W16     -> II16
+        W32     -> II32
+        W64     -> II64
+        other   -> sorry $ "The native code generator cannot " ++
+            "produce code for Format.intFormat " ++ show other
+            ++ "\n\tConsider using the llvm backend with -fllvm"
+
+
+-- | Get the float format of this width.
+floatFormat :: Width -> Format
+floatFormat width
+ = case width of
+        W32     -> FF32
+        W64     -> FF64
+        W80     -> FF80
+        other   -> pprPanic "Format.floatFormat" (ppr other)
+
+
+-- | Check if a format represents a floating point value.
+isFloatFormat :: Format -> Bool
+isFloatFormat format
+ = case format of
+        FF32    -> True
+        FF64    -> True
+        FF80    -> True
+        _       -> False
+
+
+-- | Convert a Cmm type to a Format.
+cmmTypeFormat :: CmmType -> Format
+cmmTypeFormat ty
+        | isFloatType ty        = floatFormat (typeWidth ty)
+        | otherwise             = intFormat (typeWidth ty)
+
+
+-- | Get the Width of a Format.
+formatToWidth :: Format -> Width
+formatToWidth format
+ = case format of
+        II8             -> W8
+        II16            -> W16
+        II32            -> W32
+        II64            -> W64
+        FF32            -> W32
+        FF64            -> W64
+        FF80            -> W80
+
+formatInBytes :: Format -> Int
+formatInBytes = widthInBytes . formatToWidth
diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/Instruction.hs
@@ -0,0 +1,202 @@
+
+module Instruction (
+        RegUsage(..),
+        noUsage,
+        GenBasicBlock(..), blockId,
+        ListGraph(..),
+        NatCmm,
+        NatCmmDecl,
+        NatBasicBlock,
+        topInfoTable,
+        entryBlocks,
+        Instruction(..)
+)
+
+where
+
+import GhcPrelude
+
+import Reg
+
+import BlockId
+import Hoopl.Collections
+import Hoopl.Label
+import DynFlags
+import Cmm hiding (topInfoTable)
+import Platform
+
+-- | Holds a list of source and destination registers used by a
+--      particular instruction.
+--
+--   Machine registers that are pre-allocated to stgRegs are filtered
+--      out, because they are uninteresting from a register allocation
+--      standpoint.  (We wouldn't want them to end up on the free list!)
+--
+--   As far as we are concerned, the fixed registers simply don't exist
+--      (for allocation purposes, anyway).
+--
+data RegUsage
+        = RU [Reg] [Reg]
+
+-- | No regs read or written to.
+noUsage :: RegUsage
+noUsage  = RU [] []
+
+-- Our flavours of the Cmm types
+-- Type synonyms for Cmm populated with native code
+type NatCmm instr
+        = GenCmmGroup
+                CmmStatics
+                (LabelMap CmmStatics)
+                (ListGraph instr)
+
+type NatCmmDecl statics instr
+        = GenCmmDecl
+                statics
+                (LabelMap CmmStatics)
+                (ListGraph instr)
+
+
+type NatBasicBlock instr
+        = GenBasicBlock instr
+
+
+-- | Returns the info table associated with the CmmDecl's entry point,
+-- if any.
+topInfoTable :: GenCmmDecl a (LabelMap i) (ListGraph b) -> Maybe i
+topInfoTable (CmmProc infos _ _ (ListGraph (b:_)))
+  = mapLookup (blockId b) infos
+topInfoTable _
+  = Nothing
+
+-- | Return the list of BlockIds in a CmmDecl that are entry points
+-- for this proc (i.e. they may be jumped to from outside this proc).
+entryBlocks :: GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId]
+entryBlocks (CmmProc info _ _ (ListGraph code)) = entries
+  where
+        infos = mapKeys info
+        entries = case code of
+                    [] -> infos
+                    BasicBlock entry _ : _ -- first block is the entry point
+                       | entry `elem` infos -> infos
+                       | otherwise          -> entry : infos
+entryBlocks _ = []
+
+-- | Common things that we can do with instructions, on all architectures.
+--      These are used by the shared parts of the native code generator,
+--      specifically the register allocators.
+--
+class   Instruction instr where
+
+        -- | Get the registers that are being used by this instruction.
+        --      regUsage doesn't need to do any trickery for jumps and such.
+        --      Just state precisely the regs read and written by that insn.
+        --      The consequences of control flow transfers, as far as register
+        --      allocation goes, are taken care of by the register allocator.
+        --
+        regUsageOfInstr
+                :: Platform
+                -> instr
+                -> RegUsage
+
+
+        -- | Apply a given mapping to all the register references in this
+        --      instruction.
+        patchRegsOfInstr
+                :: instr
+                -> (Reg -> Reg)
+                -> instr
+
+
+        -- | Checks whether this instruction is a jump/branch instruction.
+        --      One that can change the flow of control in a way that the
+        --      register allocator needs to worry about.
+        isJumpishInstr
+                :: instr -> Bool
+
+
+        -- | Give the possible destinations of this jump instruction.
+        --      Must be defined for all jumpish instructions.
+        jumpDestsOfInstr
+                :: instr -> [BlockId]
+
+
+        -- | Change the destination of this jump instruction.
+        --      Used in the linear allocator when adding fixup blocks for join
+        --      points.
+        patchJumpInstr
+                :: instr
+                -> (BlockId -> BlockId)
+                -> instr
+
+
+        -- | An instruction to spill a register into a spill slot.
+        mkSpillInstr
+                :: DynFlags
+                -> Reg          -- ^ the reg to spill
+                -> Int          -- ^ the current stack delta
+                -> Int          -- ^ spill slot to use
+                -> instr
+
+
+        -- | An instruction to reload a register from a spill slot.
+        mkLoadInstr
+                :: DynFlags
+                -> Reg          -- ^ the reg to reload.
+                -> Int          -- ^ the current stack delta
+                -> Int          -- ^ the spill slot to use
+                -> instr
+
+        -- | See if this instruction is telling us the current C stack delta
+        takeDeltaInstr
+                :: instr
+                -> Maybe Int
+
+        -- | Check whether this instruction is some meta thing inserted into
+        --      the instruction stream for other purposes.
+        --
+        --      Not something that has to be treated as a real machine instruction
+        --      and have its registers allocated.
+        --
+        --      eg, comments, delta, ldata, etc.
+        isMetaInstr
+                :: instr
+                -> Bool
+
+
+
+        -- | Copy the value in a register to another one.
+        --      Must work for all register classes.
+        mkRegRegMoveInstr
+                :: Platform
+                -> Reg          -- ^ source register
+                -> Reg          -- ^ destination register
+                -> instr
+
+        -- | Take the source and destination from this reg -> reg move instruction
+        --      or Nothing if it's not one
+        takeRegRegMoveInstr
+                :: instr
+                -> Maybe (Reg, Reg)
+
+        -- | Make an unconditional jump instruction.
+        --      For architectures with branch delay slots, its ok to put
+        --      a NOP after the jump. Don't fill the delay slot with an
+        --      instruction that references regs or you'll confuse the
+        --      linear allocator.
+        mkJumpInstr
+                :: BlockId
+                -> [instr]
+
+
+        -- Subtract an amount from the C stack pointer
+        mkStackAllocInstr
+                :: Platform
+                -> Int
+                -> [instr]
+
+        -- Add an amount to the C stack pointer
+        mkStackDeallocInstr
+                :: Platform
+                -> Int
+                -> [instr]
diff --git a/compiler/nativeGen/NCG.h b/compiler/nativeGen/NCG.h
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/NCG.h
@@ -0,0 +1,11 @@
+/* -----------------------------------------------------------------------------
+
+   (c) The University of Glasgow, 1994-2004
+
+   Native-code generator header file - just useful macros for now.
+
+   -------------------------------------------------------------------------- */
+
+#pragma once
+
+#include "ghc_boot_platform.h"
diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/NCGMonad.hs
@@ -0,0 +1,294 @@
+{-# LANGUAGE CPP #-}
+
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 1993-2004
+--
+-- The native code generator's monad.
+--
+-- -----------------------------------------------------------------------------
+
+module NCGMonad (
+        NcgImpl(..),
+        NatM_State(..), mkNatM_State,
+
+        NatM, -- instance Monad
+        initNat,
+        addImportNat,
+        addNodeBetweenNat,
+        addImmediateSuccessorNat,
+        updateCfgNat,
+        getUniqueNat,
+        mapAccumLNat,
+        setDeltaNat,
+        getDeltaNat,
+        getThisModuleNat,
+        getBlockIdNat,
+        getNewLabelNat,
+        getNewRegNat,
+        getNewRegPairNat,
+        getPicBaseMaybeNat,
+        getPicBaseNat,
+        getDynFlags,
+        getModLoc,
+        getFileId,
+        getDebugBlock,
+
+        DwarfFiles
+)
+
+where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Reg
+import Format
+import TargetReg
+
+import BlockId
+import Hoopl.Collections
+import Hoopl.Label
+import CLabel           ( CLabel )
+import Debug
+import FastString       ( FastString )
+import UniqFM
+import UniqSupply
+import Unique           ( Unique )
+import DynFlags
+import Module
+
+import Control.Monad    ( liftM, ap )
+
+import Instruction
+import Outputable (SDoc, pprPanic, ppr)
+import Cmm (RawCmmDecl, CmmStatics)
+import CFG
+
+data NcgImpl statics instr jumpDest = NcgImpl {
+    cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
+    generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
+    getJumpDestBlockId        :: jumpDest -> Maybe BlockId,
+    canShortcut               :: instr -> Maybe jumpDest,
+    shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,
+    shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,
+    pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,
+    maxSpillSlots             :: Int,
+    allocatableRegs           :: [RealReg],
+    ncg_x86fp_kludge          :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
+    ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
+    ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr
+                              -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),
+    -- ^ The list of block ids records the redirected jumps to allow us to update
+    -- the CFG.
+    ncgMakeFarBranches        :: LabelMap CmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr],
+    extractUnwindPoints       :: [instr] -> [UnwindPoint],
+    -- ^ given the instruction sequence of a block, produce a list of
+    -- the block's 'UnwindPoint's
+    -- See Note [What is this unwinding business?] in Debug
+    -- and Note [Unwinding information in the NCG] in this module.
+    invertCondBranches        :: CFG -> LabelMap CmmStatics -> [NatBasicBlock instr]
+                              -> [NatBasicBlock instr]
+    -- ^ Turn the sequence of `jcc l1; jmp l2` into `jncc l2; <block_l1>`
+    -- when possible.
+    }
+
+data NatM_State
+        = NatM_State {
+                natm_us          :: UniqSupply,
+                natm_delta       :: Int,
+                natm_imports     :: [(CLabel)],
+                natm_pic         :: Maybe Reg,
+                natm_dflags      :: DynFlags,
+                natm_this_module :: Module,
+                natm_modloc      :: ModLocation,
+                natm_fileid      :: DwarfFiles,
+                natm_debug_map   :: LabelMap DebugBlock,
+                natm_cfg         :: CFG
+        -- ^ Having a CFG with additional information is essential for some
+        -- operations. However we can't reconstruct all information once we
+        -- generated instructions. So instead we update the CFG as we go.
+        }
+
+type DwarfFiles = UniqFM (FastString, Int)
+
+newtype NatM result = NatM (NatM_State -> (result, NatM_State))
+
+unNat :: NatM a -> NatM_State -> (a, NatM_State)
+unNat (NatM a) = a
+
+mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation ->
+                DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State
+mkNatM_State us delta dflags this_mod
+        = \loc dwf dbg cfg ->
+                NatM_State
+                        { natm_us = us
+                        , natm_delta = delta
+                        , natm_imports = []
+                        , natm_pic = Nothing
+                        , natm_dflags = dflags
+                        , natm_this_module = this_mod
+                        , natm_modloc = loc
+                        , natm_fileid = dwf
+                        , natm_debug_map = dbg
+                        , natm_cfg = cfg
+                        }
+
+initNat :: NatM_State -> NatM a -> (a, NatM_State)
+initNat init_st m
+        = case unNat m init_st of { (r,st) -> (r,st) }
+
+instance Functor NatM where
+      fmap = liftM
+
+instance Applicative NatM where
+      pure = returnNat
+      (<*>) = ap
+
+instance Monad NatM where
+  (>>=) = thenNat
+
+instance MonadUnique NatM where
+  getUniqueSupplyM = NatM $ \st ->
+      case splitUniqSupply (natm_us st) of
+          (us1, us2) -> (us1, st {natm_us = us2})
+
+  getUniqueM = NatM $ \st ->
+      case takeUniqFromSupply (natm_us st) of
+          (uniq, us') -> (uniq, st {natm_us = us'})
+
+thenNat :: NatM a -> (a -> NatM b) -> NatM b
+thenNat expr cont
+        = NatM $ \st -> case unNat expr st of
+                        (result, st') -> unNat (cont result) st'
+
+returnNat :: a -> NatM a
+returnNat result
+        = NatM $ \st ->  (result, st)
+
+mapAccumLNat :: (acc -> x -> NatM (acc, y))
+                -> acc
+                -> [x]
+                -> NatM (acc, [y])
+
+mapAccumLNat _ b []
+  = return (b, [])
+mapAccumLNat f b (x:xs)
+  = do (b__2, x__2)  <- f b x
+       (b__3, xs__2) <- mapAccumLNat f b__2 xs
+       return (b__3, x__2:xs__2)
+
+getUniqueNat :: NatM Unique
+getUniqueNat = NatM $ \ st ->
+    case takeUniqFromSupply $ natm_us st of
+    (uniq, us') -> (uniq, st {natm_us = us'})
+
+instance HasDynFlags NatM where
+    getDynFlags = NatM $ \ st -> (natm_dflags st, st)
+
+
+getDeltaNat :: NatM Int
+getDeltaNat = NatM $ \ st -> (natm_delta st, st)
+
+
+setDeltaNat :: Int -> NatM ()
+setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta})
+
+
+getThisModuleNat :: NatM Module
+getThisModuleNat = NatM $ \ st -> (natm_this_module st, st)
+
+
+addImportNat :: CLabel -> NatM ()
+addImportNat imp
+        = NatM $ \ st -> ((), st {natm_imports = imp : natm_imports st})
+
+updateCfgNat :: (CFG -> CFG) -> NatM ()
+updateCfgNat f
+        = NatM $ \ st -> ((), st { natm_cfg = f (natm_cfg st) })
+
+-- | Record that we added a block between `from` and `old`.
+addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()
+addNodeBetweenNat from between to
+ = do   df <- getDynFlags
+        let jmpWeight = fromIntegral . uncondWeight .
+                        cfgWeightInfo $ df
+        updateCfgNat (updateCfg jmpWeight from between to)
+  where
+    -- When transforming A -> B to A -> A' -> B
+    -- A -> A' keeps the old edge info while
+    -- A' -> B gets the info for an unconditional
+    -- jump.
+    updateCfg weight from between old m
+        | Just info <- getEdgeInfo from old m
+        = addEdge from between info .
+          addWeightEdge between old weight .
+          delEdge from old $ m
+        | otherwise
+        = pprPanic "Faild to update cfg: Untracked edge" (ppr (from,to))
+
+
+-- | Place `succ` after `block` and change any edges
+--   block -> X to `succ` -> X
+addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()
+addImmediateSuccessorNat block succ
+        = updateCfgNat (addImmediateSuccessor block succ)
+
+getBlockIdNat :: NatM BlockId
+getBlockIdNat
+ = do   u <- getUniqueNat
+        return (mkBlockId u)
+
+
+getNewLabelNat :: NatM CLabel
+getNewLabelNat
+ = blockLbl <$> getBlockIdNat
+
+
+getNewRegNat :: Format -> NatM Reg
+getNewRegNat rep
+ = do u <- getUniqueNat
+      dflags <- getDynFlags
+      return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep)
+
+
+getNewRegPairNat :: Format -> NatM (Reg,Reg)
+getNewRegPairNat rep
+ = do u <- getUniqueNat
+      dflags <- getDynFlags
+      let vLo = targetMkVirtualReg (targetPlatform dflags) u rep
+      let lo  = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep
+      let hi  = RegVirtual $ getHiVirtualRegFromLo vLo
+      return (lo, hi)
+
+
+getPicBaseMaybeNat :: NatM (Maybe Reg)
+getPicBaseMaybeNat
+        = NatM (\state -> (natm_pic state, state))
+
+
+getPicBaseNat :: Format -> NatM Reg
+getPicBaseNat rep
+ = do   mbPicBase <- getPicBaseMaybeNat
+        case mbPicBase of
+                Just picBase -> return picBase
+                Nothing
+                 -> do
+                        reg <- getNewRegNat rep
+                        NatM (\state -> (reg, state { natm_pic = Just reg }))
+
+getModLoc :: NatM ModLocation
+getModLoc
+        = NatM $ \ st -> (natm_modloc st, st)
+
+getFileId :: FastString -> NatM Int
+getFileId f = NatM $ \st ->
+  case lookupUFM (natm_fileid st) f of
+    Just (_,n) -> (n, st)
+    Nothing    -> let n = 1 + sizeUFM (natm_fileid st)
+                      fids = addToUFM (natm_fileid st) f (f,n)
+                  in n `seq` fids `seq` (n, st { natm_fileid = fids  })
+
+getDebugBlock :: Label -> NatM (Maybe DebugBlock)
+getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st)
diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PIC.hs
@@ -0,0 +1,840 @@
+{-
+  This module handles generation of position independent code and
+  dynamic-linking related issues for the native code generator.
+
+  This depends both the architecture and OS, so we define it here
+  instead of in one of the architecture specific modules.
+
+  Things outside this module which are related to this:
+
+  + module CLabel
+    - PIC base label (pretty printed as local label 1)
+    - DynamicLinkerLabels - several kinds:
+        CodeStub, SymbolPtr, GotSymbolPtr, GotSymbolOffset
+    - labelDynamic predicate
+  + module Cmm
+    - The GlobalReg datatype has a PicBaseReg constructor
+    - The CmmLit datatype has a CmmLabelDiffOff constructor
+  + codeGen & RTS
+    - When tablesNextToCode, no absolute addresses are stored in info tables
+      any more. Instead, offsets from the info label are used.
+    - For Win32 only, SRTs might contain addresses of __imp_ symbol pointers
+      because Win32 doesn't support external references in data sections.
+      TODO: make sure this still works, it might be bitrotted
+  + NCG
+    - The cmmToCmm pass in AsmCodeGen calls cmmMakeDynamicReference for all
+      labels.
+    - nativeCodeGen calls pprImportedSymbol and pprGotDeclaration to output
+      all the necessary stuff for imported symbols.
+    - The NCG monad keeps track of a list of imported symbols.
+    - MachCodeGen invokes initializePicBase to generate code to initialize
+      the PIC base register when needed.
+    - MachCodeGen calls cmmMakeDynamicReference whenever it uses a CLabel
+      that wasn't in the original Cmm code (e.g. floating point literals).
+-}
+
+module PIC (
+        cmmMakeDynamicReference,
+        CmmMakeDynamicReferenceM(..),
+        ReferenceKind(..),
+        needImportedSymbols,
+        pprImportedSymbol,
+        pprGotDeclaration,
+
+        initializePicBase_ppc,
+        initializePicBase_x86
+)
+
+where
+
+import GhcPrelude
+
+import qualified PPC.Instr      as PPC
+import qualified PPC.Regs       as PPC
+
+import qualified X86.Instr      as X86
+
+import Platform
+import Instruction
+import Reg
+import NCGMonad
+
+
+import Hoopl.Collections
+import Cmm
+import CLabel           ( CLabel, ForeignLabelSource(..), pprCLabel,
+                          mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..),
+                          dynamicLinkerLabelInfo, mkPicBaseLabel,
+                          labelDynamic, externallyVisibleCLabel )
+
+import CLabel           ( mkForeignLabel )
+
+
+import BasicTypes
+import Module
+
+import Outputable
+
+import DynFlags
+import FastString
+
+
+
+--------------------------------------------------------------------------------
+-- It gets called by the cmmToCmm pass for every CmmLabel in the Cmm
+-- code. It does The Right Thing(tm) to convert the CmmLabel into a
+-- position-independent, dynamic-linking-aware reference to the thing
+-- in question.
+-- Note that this also has to be called from MachCodeGen in order to
+-- access static data like floating point literals (labels that were
+-- created after the cmmToCmm pass).
+-- The function must run in a monad that can keep track of imported symbols
+-- A function for recording an imported symbol must be passed in:
+-- - addImportCmmOpt for the CmmOptM monad
+-- - addImportNat for the NatM monad.
+
+data ReferenceKind
+        = DataReference
+        | CallReference
+        | JumpReference
+        deriving(Eq)
+
+class Monad m => CmmMakeDynamicReferenceM m where
+    addImport :: CLabel -> m ()
+    getThisModule :: m Module
+
+instance CmmMakeDynamicReferenceM NatM where
+    addImport = addImportNat
+    getThisModule = getThisModuleNat
+
+cmmMakeDynamicReference
+  :: CmmMakeDynamicReferenceM m
+  => DynFlags
+  -> ReferenceKind     -- whether this is the target of a jump
+  -> CLabel            -- the label
+  -> m CmmExpr
+
+cmmMakeDynamicReference dflags referenceKind lbl
+  | Just _ <- dynamicLinkerLabelInfo lbl
+  = return $ CmmLit $ CmmLabel lbl   -- already processed it, pass through
+
+  | otherwise
+  = do this_mod <- getThisModule
+       case howToAccessLabel
+                dflags
+                (platformArch $ targetPlatform dflags)
+                (platformOS   $ targetPlatform dflags)
+                this_mod
+                referenceKind lbl of
+
+        AccessViaStub -> do
+              let stub = mkDynamicLinkerLabel CodeStub lbl
+              addImport stub
+              return $ CmmLit $ CmmLabel stub
+
+        AccessViaSymbolPtr -> do
+              let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl
+              addImport symbolPtr
+              return $ CmmLoad (cmmMakePicReference dflags symbolPtr) (bWord dflags)
+
+        AccessDirectly -> case referenceKind of
+                -- for data, we might have to make some calculations:
+              DataReference -> return $ cmmMakePicReference dflags lbl
+                -- all currently supported processors support
+                -- PC-relative branch and call instructions,
+                -- so just jump there if it's a call or a jump
+              _ -> return $ CmmLit $ CmmLabel lbl
+
+
+-- -----------------------------------------------------------------------------
+-- Create a position independent reference to a label.
+-- (but do not bother with dynamic linking).
+-- We calculate the label's address by adding some (platform-dependent)
+-- offset to our base register; this offset is calculated by
+-- the function picRelative in the platform-dependent part below.
+
+cmmMakePicReference :: DynFlags -> CLabel -> CmmExpr
+cmmMakePicReference dflags lbl
+
+        -- Windows doesn't need PIC,
+        -- everything gets relocated at runtime
+        | OSMinGW32 <- platformOS $ targetPlatform dflags
+        = CmmLit $ CmmLabel lbl
+
+        | OSAIX <- platformOS $ targetPlatform dflags
+        = CmmMachOp (MO_Add W32)
+                [ CmmReg (CmmGlobal PicBaseReg)
+                , CmmLit $ picRelative dflags
+                                (platformArch   $ targetPlatform dflags)
+                                (platformOS     $ targetPlatform dflags)
+                                lbl ]
+
+        -- both ABI versions default to medium code model
+        | ArchPPC_64 _ <- platformArch $ targetPlatform dflags
+        = CmmMachOp (MO_Add W32) -- code model medium
+                [ CmmReg (CmmGlobal PicBaseReg)
+                , CmmLit $ picRelative dflags
+                                (platformArch   $ targetPlatform dflags)
+                                (platformOS     $ targetPlatform dflags)
+                                lbl ]
+
+        | (positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags)
+            && absoluteLabel lbl
+        = CmmMachOp (MO_Add (wordWidth dflags))
+                [ CmmReg (CmmGlobal PicBaseReg)
+                , CmmLit $ picRelative dflags
+                                (platformArch   $ targetPlatform dflags)
+                                (platformOS     $ targetPlatform dflags)
+                                lbl ]
+
+        | otherwise
+        = CmmLit $ CmmLabel lbl
+
+
+absoluteLabel :: CLabel -> Bool
+absoluteLabel lbl
+ = case dynamicLinkerLabelInfo lbl of
+        Just (GotSymbolPtr, _)    -> False
+        Just (GotSymbolOffset, _) -> False
+        _                         -> True
+
+
+--------------------------------------------------------------------------------
+-- Knowledge about how special dynamic linker labels like symbol
+-- pointers, code stubs and GOT offsets look like is located in the
+-- module CLabel.
+
+-- We have to decide which labels need to be accessed
+-- indirectly or via a piece of stub code.
+data LabelAccessStyle
+        = AccessViaStub
+        | AccessViaSymbolPtr
+        | AccessDirectly
+
+howToAccessLabel
+        :: DynFlags -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle
+
+
+-- Windows
+-- In Windows speak, a "module" is a set of objects linked into the
+-- same Portable Exectuable (PE) file. (both .exe and .dll files are PEs).
+--
+-- If we're compiling a multi-module program then symbols from other modules
+-- are accessed by a symbol pointer named __imp_SYMBOL. At runtime we have the
+-- following.
+--
+--   (in the local module)
+--     __imp_SYMBOL: addr of SYMBOL
+--
+--   (in the other module)
+--     SYMBOL: the real function / data.
+--
+-- To access the function at SYMBOL from our local module, we just need to
+-- dereference the local __imp_SYMBOL.
+--
+-- If not compiling with -dynamic we assume that all our code will be linked
+-- into the same .exe file. In this case we always access symbols directly,
+-- and never use __imp_SYMBOL.
+--
+howToAccessLabel dflags _ OSMinGW32 this_mod _ lbl
+
+        -- Assume all symbols will be in the same PE, so just access them directly.
+        | not (gopt Opt_ExternalDynamicRefs dflags)
+        = AccessDirectly
+
+        -- If the target symbol is in another PE we need to access it via the
+        --      appropriate __imp_SYMBOL pointer.
+        | labelDynamic dflags this_mod lbl
+        = AccessViaSymbolPtr
+
+        -- Target symbol is in the same PE as the caller, so just access it directly.
+        | otherwise
+        = AccessDirectly
+
+
+-- Mach-O (Darwin, Mac OS X)
+--
+-- Indirect access is required in the following cases:
+--  * things imported from a dynamic library
+--  * (not on x86_64) data from a different module, if we're generating PIC code
+-- It is always possible to access something indirectly,
+-- even when it's not necessary.
+--
+howToAccessLabel dflags arch OSDarwin this_mod DataReference lbl
+        -- data access to a dynamic library goes via a symbol pointer
+        | labelDynamic dflags this_mod lbl
+        = AccessViaSymbolPtr
+
+        -- when generating PIC code, all cross-module data references must
+        -- must go via a symbol pointer, too, because the assembler
+        -- cannot generate code for a label difference where one
+        -- label is undefined. Doesn't apply t x86_64.
+        -- Unfortunately, we don't know whether it's cross-module,
+        -- so we do it for all externally visible labels.
+        -- This is a slight waste of time and space, but otherwise
+        -- we'd need to pass the current Module all the way in to
+        -- this function.
+        | arch /= ArchX86_64
+        , positionIndependent dflags && externallyVisibleCLabel lbl
+        = AccessViaSymbolPtr
+
+        | otherwise
+        = AccessDirectly
+
+howToAccessLabel dflags arch OSDarwin this_mod JumpReference lbl
+        -- dyld code stubs don't work for tailcalls because the
+        -- stack alignment is only right for regular calls.
+        -- Therefore, we have to go via a symbol pointer:
+        | arch == ArchX86 || arch == ArchX86_64
+        , labelDynamic dflags this_mod lbl
+        = AccessViaSymbolPtr
+
+
+howToAccessLabel dflags arch OSDarwin this_mod _ lbl
+        -- Code stubs are the usual method of choice for imported code;
+        -- not needed on x86_64 because Apple's new linker, ld64, generates
+        -- them automatically.
+        | arch /= ArchX86_64
+        , labelDynamic dflags this_mod lbl
+        = AccessViaStub
+
+        | otherwise
+        = AccessDirectly
+
+
+----------------------------------------------------------------------------
+-- AIX
+
+-- quite simple (for now)
+howToAccessLabel _dflags _arch OSAIX _this_mod kind _lbl
+        = case kind of
+            DataReference -> AccessViaSymbolPtr
+            CallReference -> AccessDirectly
+            JumpReference -> AccessDirectly
+
+-- ELF (Linux)
+--
+-- ELF tries to pretend to the main application code that dynamic linking does
+-- not exist. While this may sound convenient, it tends to mess things up in
+-- very bad ways, so we have to be careful when we generate code for a non-PIE
+-- main program (-dynamic but no -fPIC).
+--
+-- Indirect access is required for references to imported symbols
+-- from position independent code. It is also required from the main program
+-- when dynamic libraries containing Haskell code are used.
+
+howToAccessLabel _ (ArchPPC_64 _) os _ kind _
+        | osElfTarget os
+        = case kind of
+          -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC
+          DataReference -> AccessViaSymbolPtr
+          -- RTLD does not generate stubs for function descriptors
+          -- in tail calls. Create a symbol pointer and generate
+          -- the code to load the function descriptor at the call site.
+          JumpReference -> AccessViaSymbolPtr
+          -- regular calls are handled by the runtime linker
+          _             -> AccessDirectly
+
+howToAccessLabel dflags _ os _ _ _
+        -- no PIC -> the dynamic linker does everything for us;
+        --           if we don't dynamically link to Haskell code,
+        --           it actually manages to do so without messing things up.
+        | osElfTarget os
+        , not (positionIndependent dflags) &&
+          not (gopt Opt_ExternalDynamicRefs dflags)
+        = AccessDirectly
+
+howToAccessLabel dflags arch os this_mod DataReference lbl
+        | osElfTarget os
+        = case () of
+            -- A dynamic label needs to be accessed via a symbol pointer.
+          _ | labelDynamic dflags this_mod lbl
+            -> AccessViaSymbolPtr
+
+            -- For PowerPC32 -fPIC, we have to access even static data
+            -- via a symbol pointer (see below for an explanation why
+            -- PowerPC32 Linux is especially broken).
+            | arch == ArchPPC
+            , positionIndependent dflags
+            -> AccessViaSymbolPtr
+
+            | otherwise
+            -> AccessDirectly
+
+
+        -- In most cases, we have to avoid symbol stubs on ELF, for the following reasons:
+        --   on i386, the position-independent symbol stubs in the Procedure Linkage Table
+        --   require the address of the GOT to be loaded into register %ebx on entry.
+        --   The linker will take any reference to the symbol stub as a hint that
+        --   the label in question is a code label. When linking executables, this
+        --   will cause the linker to replace even data references to the label with
+        --   references to the symbol stub.
+
+        -- This leaves calling a (foreign) function from non-PIC code
+        -- (AccessDirectly, because we get an implicit symbol stub)
+        -- and calling functions from PIC code on non-i386 platforms (via a symbol stub)
+
+howToAccessLabel dflags arch os this_mod CallReference lbl
+        | osElfTarget os
+        , labelDynamic dflags this_mod lbl && not (positionIndependent dflags)
+        = AccessDirectly
+
+        | osElfTarget os
+        , arch /= ArchX86
+        , labelDynamic dflags this_mod lbl
+        , positionIndependent dflags
+        = AccessViaStub
+
+howToAccessLabel dflags _ os this_mod _ lbl
+        | osElfTarget os
+        = if labelDynamic dflags this_mod lbl
+            then AccessViaSymbolPtr
+            else AccessDirectly
+
+-- all other platforms
+howToAccessLabel dflags _ _ _ _ _
+        | not (positionIndependent dflags)
+        = AccessDirectly
+
+        | otherwise
+        = panic "howToAccessLabel: PIC not defined for this platform"
+
+
+
+-- -------------------------------------------------------------------
+-- | Says what we have to add to our 'PIC base register' in order to
+--      get the address of a label.
+
+picRelative :: DynFlags -> Arch -> OS -> CLabel -> CmmLit
+
+-- Darwin, but not x86_64:
+-- The PIC base register points to the PIC base label at the beginning
+-- of the current CmmDecl. We just have to use a label difference to
+-- get the offset.
+-- We have already made sure that all labels that are not from the current
+-- module are accessed indirectly ('as' can't calculate differences between
+-- undefined labels).
+picRelative dflags arch OSDarwin lbl
+        | arch /= ArchX86_64
+        = CmmLabelDiffOff lbl mkPicBaseLabel 0 (wordWidth dflags)
+
+-- On AIX we use an indirect local TOC anchored by 'gotLabel'.
+-- This way we use up only one global TOC entry per compilation-unit
+-- (this is quite similiar to GCC's @-mminimal-toc@ compilation mode)
+picRelative dflags _ OSAIX lbl
+        = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags)
+
+-- PowerPC Linux:
+-- The PIC base register points to our fake GOT. Use a label difference
+-- to get the offset.
+-- We have made sure that *everything* is accessed indirectly, so this
+-- is only used for offsets from the GOT to symbol pointers inside the
+-- GOT.
+picRelative dflags ArchPPC os lbl
+        | osElfTarget os
+        = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags)
+
+
+-- Most Linux versions:
+-- The PIC base register points to the GOT. Use foo@got for symbol
+-- pointers, and foo@gotoff for everything else.
+-- Linux and Darwin on x86_64:
+-- The PIC base register is %rip, we use foo@gotpcrel for symbol pointers,
+-- and a GotSymbolOffset label for other things.
+-- For reasons of tradition, the symbol offset label is written as a plain label.
+picRelative _ arch os lbl
+        | osElfTarget os || (os == OSDarwin && arch == ArchX86_64)
+        = let   result
+                        | Just (SymbolPtr, lbl') <- dynamicLinkerLabelInfo lbl
+                        = CmmLabel $ mkDynamicLinkerLabel GotSymbolPtr lbl'
+
+                        | otherwise
+                        = CmmLabel $ mkDynamicLinkerLabel GotSymbolOffset lbl
+
+          in    result
+
+picRelative _ _ _ _
+        = panic "PositionIndependentCode.picRelative undefined for this platform"
+
+
+
+--------------------------------------------------------------------------------
+
+needImportedSymbols :: DynFlags -> Arch -> OS -> Bool
+needImportedSymbols dflags arch os
+        | os    == OSDarwin
+        , arch  /= ArchX86_64
+        = True
+
+        | os    == OSAIX
+        = True
+
+        -- PowerPC Linux: -fPIC or -dynamic
+        | osElfTarget os
+        , arch  == ArchPPC
+        = positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags
+
+        -- PowerPC 64 Linux: always
+        | osElfTarget os
+        , arch == ArchPPC_64 ELF_V1 || arch == ArchPPC_64 ELF_V2
+        = True
+
+        -- i386 (and others?): -dynamic but not -fPIC
+        | osElfTarget os
+        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
+        = gopt Opt_ExternalDynamicRefs dflags &&
+          not (positionIndependent dflags)
+
+        | otherwise
+        = False
+
+-- gotLabel
+-- The label used to refer to our "fake GOT" from
+-- position-independent code.
+gotLabel :: CLabel
+gotLabel
+        -- HACK: this label isn't really foreign
+        = mkForeignLabel
+                (fsLit ".LCTOC1")
+                Nothing ForeignLabelInThisPackage IsData
+
+
+
+--------------------------------------------------------------------------------
+-- We don't need to declare any offset tables.
+-- However, for PIC on x86, we need a small helper function.
+pprGotDeclaration :: DynFlags -> Arch -> OS -> SDoc
+pprGotDeclaration dflags ArchX86 OSDarwin
+        | positionIndependent dflags
+        = vcat [
+                text ".section __TEXT,__textcoal_nt,coalesced,no_toc",
+                text ".weak_definition ___i686.get_pc_thunk.ax",
+                text ".private_extern ___i686.get_pc_thunk.ax",
+                text "___i686.get_pc_thunk.ax:",
+                text "\tmovl (%esp), %eax",
+                text "\tret" ]
+
+pprGotDeclaration _ _ OSDarwin
+        = empty
+
+-- Emit XCOFF TOC section
+pprGotDeclaration _ _ OSAIX
+        = vcat $ [ text ".toc"
+                 , text ".tc ghc_toc_table[TC],.LCTOC1"
+                 , text ".csect ghc_toc_table[RW]"
+                   -- See Note [.LCTOC1 in PPC PIC code]
+                 , text ".set .LCTOC1,$+0x8000"
+                 ]
+
+
+-- PPC 64 ELF v1 needs a Table Of Contents (TOC)
+pprGotDeclaration _ (ArchPPC_64 ELF_V1) _
+        = text ".section \".toc\",\"aw\""
+-- In ELF v2 we also need to tell the assembler that we want ABI
+-- version 2. This would normally be done at the top of the file
+-- right after a file directive, but I could not figure out how
+-- to do that.
+pprGotDeclaration _ (ArchPPC_64 ELF_V2) _
+        = vcat [ text ".abiversion 2",
+                 text ".section \".toc\",\"aw\""
+               ]
+
+-- Emit GOT declaration
+-- Output whatever needs to be output once per .s file.
+pprGotDeclaration dflags arch os
+        | osElfTarget os
+        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
+        , not (positionIndependent dflags)
+        = empty
+
+        | osElfTarget os
+        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2
+        = vcat [
+                -- See Note [.LCTOC1 in PPC PIC code]
+                text ".section \".got2\",\"aw\"",
+                text ".LCTOC1 = .+32768" ]
+
+pprGotDeclaration _ _ _
+        = panic "pprGotDeclaration: no match"
+
+
+--------------------------------------------------------------------------------
+-- On Darwin, we have to generate our own stub code for lazy binding..
+-- For each processor architecture, there are two versions, one for PIC
+-- and one for non-PIC.
+--
+-- Whenever you change something in this assembler output, make sure
+-- the splitter in driver/split/ghc-split.pl recognizes the new output
+
+pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc
+pprImportedSymbol dflags platform@(Platform { platformArch = ArchX86, platformOS = OSDarwin }) importedLbl
+        | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl
+        = case positionIndependent dflags of
+           False ->
+            vcat [
+                text ".symbol_stub",
+                text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"),
+                    text "\t.indirect_symbol" <+> pprCLabel platform lbl,
+                    text "\tjmp *L" <> pprCLabel platform lbl
+                        <> text "$lazy_ptr",
+                text "L" <> pprCLabel platform lbl
+                    <> text "$stub_binder:",
+                    text "\tpushl $L" <> pprCLabel platform lbl
+                        <> text "$lazy_ptr",
+                    text "\tjmp dyld_stub_binding_helper"
+            ]
+           True ->
+            vcat [
+                text ".section __TEXT,__picsymbolstub2,"
+                    <> text "symbol_stubs,pure_instructions,25",
+                text "L" <> pprCLabel platform lbl <> ptext (sLit "$stub:"),
+                    text "\t.indirect_symbol" <+> pprCLabel platform lbl,
+                    text "\tcall ___i686.get_pc_thunk.ax",
+                text "1:",
+                    text "\tmovl L" <> pprCLabel platform lbl
+                        <> text "$lazy_ptr-1b(%eax),%edx",
+                    text "\tjmp *%edx",
+                text "L" <> pprCLabel platform lbl
+                    <> text "$stub_binder:",
+                    text "\tlea L" <> pprCLabel platform lbl
+                        <> text "$lazy_ptr-1b(%eax),%eax",
+                    text "\tpushl %eax",
+                    text "\tjmp dyld_stub_binding_helper"
+            ]
+          $+$ vcat [        text ".section __DATA, __la_sym_ptr"
+                    <> (if positionIndependent dflags then int 2 else int 3)
+                    <> text ",lazy_symbol_pointers",
+                text "L" <> pprCLabel platform lbl <> ptext (sLit "$lazy_ptr:"),
+                    text "\t.indirect_symbol" <+> pprCLabel platform lbl,
+                    text "\t.long L" <> pprCLabel platform lbl
+                    <> text "$stub_binder"]
+
+        | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl
+        = vcat [
+                text ".non_lazy_symbol_pointer",
+                char 'L' <> pprCLabel platform lbl <> text "$non_lazy_ptr:",
+                text "\t.indirect_symbol" <+> pprCLabel platform lbl,
+                text "\t.long\t0"]
+
+        | otherwise
+        = empty
+
+
+pprImportedSymbol _ (Platform { platformOS = OSDarwin }) _
+        = empty
+
+-- XCOFF / AIX
+--
+-- Similiar to PPC64 ELF v1, there's dedicated TOC register (r2). To
+-- workaround the limitation of a global TOC we use an indirect TOC
+-- with the label `ghc_toc_table`.
+--
+-- See also GCC's `-mminimal-toc` compilation mode or
+-- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/
+--
+-- NB: No DSO-support yet
+
+pprImportedSymbol _ platform@(Platform { platformOS = OSAIX }) importedLbl
+        = case dynamicLinkerLabelInfo importedLbl of
+            Just (SymbolPtr, lbl)
+              -> vcat [
+                   text "LC.." <> pprCLabel platform lbl <> char ':',
+                   text "\t.long" <+> pprCLabel platform lbl ]
+            _ -> empty
+
+-- ELF / Linux
+--
+-- In theory, we don't need to generate any stubs or symbol pointers
+-- by hand for Linux.
+--
+-- Reality differs from this in two areas.
+--
+-- 1) If we just use a dynamically imported symbol directly in a read-only
+--    section of the main executable (as GCC does), ld generates R_*_COPY
+--    relocations, which are fundamentally incompatible with reversed info
+--    tables. Therefore, we need a table of imported addresses in a writable
+--    section.
+--    The "official" GOT mechanism (label@got) isn't intended to be used
+--    in position dependent code, so we have to create our own "fake GOT"
+--    when not Opt_PIC && WayDyn `elem` ways dflags.
+--
+-- 2) PowerPC Linux is just plain broken.
+--    While it's theoretically possible to use GOT offsets larger
+--    than 16 bit, the standard crt*.o files don't, which leads to
+--    linker errors as soon as the GOT size exceeds 16 bit.
+--    Also, the assembler doesn't support @gotoff labels.
+--    In order to be able to use a larger GOT, we have to circumvent the
+--    entire GOT mechanism and do it ourselves (this is also what GCC does).
+
+
+-- When needImportedSymbols is defined,
+-- the NCG will keep track of all DynamicLinkerLabels it uses
+-- and output each of them using pprImportedSymbol.
+
+pprImportedSymbol _ platform@(Platform { platformArch = ArchPPC_64 _ })
+                  importedLbl
+        | osElfTarget (platformOS platform)
+        = case dynamicLinkerLabelInfo importedLbl of
+            Just (SymbolPtr, lbl)
+              -> vcat [
+                   text ".section \".toc\", \"aw\"",
+                   text ".LC_" <> pprCLabel platform lbl <> char ':',
+                   text "\t.quad" <+> pprCLabel platform lbl ]
+            _ -> empty
+
+pprImportedSymbol dflags platform importedLbl
+        | osElfTarget (platformOS platform)
+        = case dynamicLinkerLabelInfo importedLbl of
+            Just (SymbolPtr, lbl)
+              -> let symbolSize = case wordWidth dflags of
+                         W32 -> sLit "\t.long"
+                         W64 -> sLit "\t.quad"
+                         _ -> panic "Unknown wordRep in pprImportedSymbol"
+
+                 in vcat [
+                      text ".section \".got2\", \"aw\"",
+                      text ".LC_" <> pprCLabel platform lbl <> char ':',
+                      ptext symbolSize <+> pprCLabel platform lbl ]
+
+            -- PLT code stubs are generated automatically by the dynamic linker.
+            _ -> empty
+
+pprImportedSymbol _ _ _
+        = panic "PIC.pprImportedSymbol: no match"
+
+--------------------------------------------------------------------------------
+-- Generate code to calculate the address that should be put in the
+-- PIC base register.
+-- This is called by MachCodeGen for every CmmProc that accessed the
+-- PIC base register. It adds the appropriate instructions to the
+-- top of the CmmProc.
+
+-- It is assumed that the first NatCmmDecl in the input list is a Proc
+-- and the rest are CmmDatas.
+
+-- Darwin is simple: just fetch the address of a local label.
+-- The FETCHPC pseudo-instruction is expanded to multiple instructions
+-- during pretty-printing so that we don't have to deal with the
+-- local label:
+
+-- PowerPC version:
+--          bcl 20,31,1f.
+--      1:  mflr picReg
+
+-- i386 version:
+--          call 1f
+--      1:  popl %picReg
+
+
+
+-- Get a pointer to our own fake GOT, which is defined on a per-module basis.
+-- This is exactly how GCC does it in linux.
+
+initializePicBase_ppc
+        :: Arch -> OS -> Reg
+        -> [NatCmmDecl CmmStatics PPC.Instr]
+        -> NatM [NatCmmDecl CmmStatics PPC.Instr]
+
+initializePicBase_ppc ArchPPC os picReg
+    (CmmProc info lab live (ListGraph blocks) : statics)
+    | osElfTarget os
+    = do
+        let
+            gotOffset = PPC.ImmConstantDiff
+                                (PPC.ImmCLbl gotLabel)
+                                (PPC.ImmCLbl mkPicBaseLabel)
+
+            blocks' = case blocks of
+                       [] -> []
+                       (b:bs) -> fetchPC b : map maybeFetchPC bs
+
+            maybeFetchPC b@(BasicBlock bID _)
+              | bID `mapMember` info = fetchPC b
+              | otherwise            = b
+
+            -- GCC does PIC prologs thusly:
+            --     bcl 20,31,.L1
+            -- .L1:
+            --     mflr 30
+            --     addis 30,30,.LCTOC1-.L1@ha
+            --     addi 30,30,.LCTOC1-.L1@l
+            -- TODO: below we use it over temporary register,
+            -- it can and should be optimised by picking
+            -- correct PIC reg.
+            fetchPC (BasicBlock bID insns) =
+              BasicBlock bID (PPC.FETCHPC picReg
+                              : PPC.ADDIS picReg picReg (PPC.HA gotOffset)
+                              : PPC.ADD picReg picReg
+                                        (PPC.RIImm (PPC.LO gotOffset))
+                              : PPC.MR PPC.r30 picReg
+                              : insns)
+
+        return (CmmProc info lab live (ListGraph blocks') : statics)
+
+-------------------------------------------------------------------------
+-- Load TOC into register 2
+-- PowerPC 64-bit ELF ABI 2.0 requires the address of the callee
+-- in register 12.
+-- We pass the label to FETCHTOC and create a .localentry too.
+-- TODO: Explain this better and refer to ABI spec!
+{-
+We would like to do approximately this, but spill slot allocation
+might be added before the first BasicBlock. That violates the ABI.
+
+For now we will emit the prologue code in the pretty printer,
+which is also what we do for ELF v1.
+initializePicBase_ppc (ArchPPC_64 ELF_V2) OSLinux picReg
+        (CmmProc info lab live (ListGraph (entry:blocks)) : statics)
+        = do
+           bID <-getUniqueM
+           return (CmmProc info lab live (ListGraph (b':entry:blocks))
+                                         : statics)
+        where   BasicBlock entryID _ = entry
+                b' = BasicBlock bID [PPC.FETCHTOC picReg lab,
+                                     PPC.BCC PPC.ALWAYS entryID]
+-}
+
+initializePicBase_ppc _ _ _ _
+        = panic "initializePicBase_ppc: not needed"
+
+
+-- We cheat a bit here by defining a pseudo-instruction named FETCHGOT
+-- which pretty-prints as:
+--              call 1f
+-- 1:           popl %picReg
+--              addl __GLOBAL_OFFSET_TABLE__+.-1b, %picReg
+-- (See PprMach.hs)
+
+initializePicBase_x86
+        :: Arch -> OS -> Reg
+        -> [NatCmmDecl (Alignment, CmmStatics) X86.Instr]
+        -> NatM [NatCmmDecl (Alignment, CmmStatics) X86.Instr]
+
+initializePicBase_x86 ArchX86 os picReg
+        (CmmProc info lab live (ListGraph blocks) : statics)
+    | osElfTarget os
+    = return (CmmProc info lab live (ListGraph blocks') : statics)
+    where blocks' = case blocks of
+                     [] -> []
+                     (b:bs) -> fetchGOT b : map maybeFetchGOT bs
+
+          -- we want to add a FETCHGOT instruction to the beginning of
+          -- every block that is an entry point, which corresponds to
+          -- the blocks that have entries in the info-table mapping.
+          maybeFetchGOT b@(BasicBlock bID _)
+            | bID `mapMember` info = fetchGOT b
+            | otherwise            = b
+
+          fetchGOT (BasicBlock bID insns) =
+             BasicBlock bID (X86.FETCHGOT picReg : insns)
+
+initializePicBase_x86 ArchX86 OSDarwin picReg
+        (CmmProc info lab live (ListGraph (entry:blocks)) : statics)
+        = return (CmmProc info lab live (ListGraph (block':blocks)) : statics)
+
+    where BasicBlock bID insns = entry
+          block' = BasicBlock bID (X86.FETCHPC picReg : insns)
+
+initializePicBase_x86 _ _ _ _
+        = panic "initializePicBase_x86: not needed"
+
diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -0,0 +1,2441 @@
+{-# LANGUAGE CPP, GADTs #-}
+
+-----------------------------------------------------------------------------
+--
+-- Generating machine code (instruction selection)
+--
+-- (c) The University of Glasgow 1996-2004
+--
+-----------------------------------------------------------------------------
+
+-- This is a big module, but, if you pay attention to
+-- (a) the sectioning, and (b) the type signatures,
+-- the structure should not be too overwhelming.
+
+module PPC.CodeGen (
+        cmmTopCodeGen,
+        generateJumpTableForInstr,
+        InstrBlock
+)
+
+where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+#include "../includes/MachDeps.h"
+
+-- NCG stuff:
+import GhcPrelude
+
+import CodeGen.Platform
+import PPC.Instr
+import PPC.Cond
+import PPC.Regs
+import CPrim
+import NCGMonad   ( NatM, getNewRegNat, getNewLabelNat
+                  , getBlockIdNat, getPicBaseNat, getNewRegPairNat
+                  , getPicBaseMaybeNat )
+import Instruction
+import PIC
+import Format
+import RegClass
+import Reg
+import TargetReg
+import Platform
+
+-- Our intermediate code:
+import BlockId
+import PprCmm           ( pprExpr )
+import Cmm
+import CmmUtils
+import CmmSwitch
+import CLabel
+import Hoopl.Block
+import Hoopl.Graph
+
+-- The rest:
+import OrdList
+import Outputable
+import DynFlags
+
+import Control.Monad    ( mapAndUnzipM, when )
+import Data.Bits
+import Data.Word
+
+import BasicTypes
+import FastString
+import Util
+
+-- -----------------------------------------------------------------------------
+-- Top-level of the instruction selector
+
+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
+-- They are really trees of insns to facilitate fast appending, where a
+-- left-to-right traversal (pre-order?) yields the insns in the correct
+-- order.
+
+cmmTopCodeGen
+        :: RawCmmDecl
+        -> NatM [NatCmmDecl CmmStatics Instr]
+
+cmmTopCodeGen (CmmProc info lab live graph) = do
+  let blocks = toBlockListEntryFirst graph
+  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
+  dflags <- getDynFlags
+  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
+      tops = proc : concat statics
+      os   = platformOS $ targetPlatform dflags
+      arch = platformArch $ targetPlatform dflags
+  case arch of
+    ArchPPC | os == OSAIX -> return tops
+            | otherwise -> do
+      picBaseMb <- getPicBaseMaybeNat
+      case picBaseMb of
+           Just picBase -> initializePicBase_ppc arch os picBase tops
+           Nothing -> return tops
+    ArchPPC_64 ELF_V1 -> fixup_entry tops
+                      -- generating function descriptor is handled in
+                      -- pretty printer
+    ArchPPC_64 ELF_V2 -> fixup_entry tops
+                      -- generating function prologue is handled in
+                      -- pretty printer
+    _          -> panic "PPC.cmmTopCodeGen: unknown arch"
+    where
+      fixup_entry (CmmProc info lab live (ListGraph (entry:blocks)) : statics)
+        = do
+        let BasicBlock bID insns = entry
+        bID' <- if lab == (blockLbl bID)
+                then newBlockId
+                else return bID
+        let b' = BasicBlock bID' insns
+        return (CmmProc info lab live (ListGraph (b':blocks)) : statics)
+      fixup_entry _ = panic "cmmTopCodegen: Broken CmmProc"
+
+cmmTopCodeGen (CmmData sec dat) = do
+  return [CmmData sec dat]  -- no translation, we just use CmmStatic
+
+basicBlockCodeGen
+        :: Block CmmNode C C
+        -> NatM ( [NatBasicBlock Instr]
+                , [NatCmmDecl CmmStatics Instr])
+
+basicBlockCodeGen block = do
+  let (_, nodes, tail)  = blockSplit block
+      id = entryLabel block
+      stmts = blockToList nodes
+  mid_instrs <- stmtsToInstrs stmts
+  tail_instrs <- stmtToInstrs tail
+  let instrs = mid_instrs `appOL` tail_instrs
+  -- code generation may introduce new basic block boundaries, which
+  -- are indicated by the NEWBLOCK instruction.  We must split up the
+  -- instruction stream into basic blocks again.  Also, we extract
+  -- LDATAs here too.
+  let
+        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
+
+        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
+          = ([], BasicBlock id instrs : blocks, statics)
+        mkBlocks (LDATA sec dat) (instrs,blocks,statics)
+          = (instrs, blocks, CmmData sec dat:statics)
+        mkBlocks instr (instrs,blocks,statics)
+          = (instr:instrs, blocks, statics)
+  return (BasicBlock id top : other_blocks, statics)
+
+stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
+stmtsToInstrs stmts
+   = do instrss <- mapM stmtToInstrs stmts
+        return (concatOL instrss)
+
+stmtToInstrs :: CmmNode e x -> NatM InstrBlock
+stmtToInstrs stmt = do
+  dflags <- getDynFlags
+  case stmt of
+    CmmComment s   -> return (unitOL (COMMENT s))
+    CmmTick {}     -> return nilOL
+    CmmUnwind {}   -> return nilOL
+
+    CmmAssign reg src
+      | isFloatType ty -> assignReg_FltCode format reg src
+      | target32Bit (targetPlatform dflags) &&
+        isWord64 ty    -> assignReg_I64Code      reg src
+      | otherwise      -> assignReg_IntCode format reg src
+        where ty = cmmRegType dflags reg
+              format = cmmTypeFormat ty
+
+    CmmStore addr src
+      | isFloatType ty -> assignMem_FltCode format addr src
+      | target32Bit (targetPlatform dflags) &&
+        isWord64 ty    -> assignMem_I64Code      addr src
+      | otherwise      -> assignMem_IntCode format addr src
+        where ty = cmmExprType dflags src
+              format = cmmTypeFormat ty
+
+    CmmUnsafeForeignCall target result_regs args
+       -> genCCall target result_regs args
+
+    CmmBranch id          -> genBranch id
+    CmmCondBranch arg true false prediction -> do
+      b1 <- genCondJump true arg prediction
+      b2 <- genBranch false
+      return (b1 `appOL` b2)
+    CmmSwitch arg ids -> do dflags <- getDynFlags
+                            genSwitch dflags arg ids
+    CmmCall { cml_target = arg } -> genJump arg
+    _ ->
+      panic "stmtToInstrs: statement should have been cps'd away"
+
+
+--------------------------------------------------------------------------------
+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
+--      They are really trees of insns to facilitate fast appending, where a
+--      left-to-right traversal yields the insns in the correct order.
+--
+type InstrBlock
+        = OrdList Instr
+
+
+-- | Register's passed up the tree.  If the stix code forces the register
+--      to live in a pre-decided machine register, it comes out as @Fixed@;
+--      otherwise, it comes out as @Any@, and the parent can decide which
+--      register to put it in.
+--
+data Register
+        = Fixed Format Reg InstrBlock
+        | Any   Format (Reg -> InstrBlock)
+
+
+swizzleRegisterRep :: Register -> Format -> Register
+swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code
+swizzleRegisterRep (Any _ codefn)     format = Any   format codefn
+
+
+-- | Grab the Reg for a CmmReg
+getRegisterReg :: Platform -> CmmReg -> Reg
+
+getRegisterReg _ (CmmLocal (LocalReg u pk))
+  = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)
+
+getRegisterReg platform (CmmGlobal mid)
+  = case globalRegMaybe platform mid of
+        Just reg -> RegReal reg
+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
+        -- By this stage, the only MagicIds remaining should be the
+        -- ones which map to a real machine register on this
+        -- platform.  Hence ...
+
+-- | Convert a BlockId to some CmmStatic data
+jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
+jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))
+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
+    where blockLabel = blockLbl blockid
+
+
+
+-- -----------------------------------------------------------------------------
+-- General things for putting together code sequences
+
+-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
+-- CmmExprs into CmmRegOff?
+mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr
+mangleIndexTree dflags (CmmRegOff reg off)
+  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
+  where width = typeWidth (cmmRegType dflags reg)
+
+mangleIndexTree _ _
+        = panic "PPC.CodeGen.mangleIndexTree: no match"
+
+-- -----------------------------------------------------------------------------
+--  Code gen for 64-bit arithmetic on 32-bit platforms
+
+{-
+Simple support for generating 64-bit code (ie, 64 bit values and 64
+bit assignments) on 32-bit platforms.  Unlike the main code generator
+we merely shoot for generating working code as simply as possible, and
+pay little attention to code quality.  Specifically, there is no
+attempt to deal cleverly with the fixed-vs-floating register
+distinction; all values are generated into (pairs of) floating
+registers, even if this would mean some redundant reg-reg moves as a
+result.  Only one of the VRegUniques is returned, since it will be
+of the VRegUniqueLo form, and the upper-half VReg can be determined
+by applying getHiVRegFromLo to it.
+-}
+
+data ChildCode64        -- a.k.a "Register64"
+      = ChildCode64
+           InstrBlock   -- code
+           Reg          -- the lower 32-bit temporary which contains the
+                        -- result; use getHiVRegFromLo to find the other
+                        -- VRegUnique.  Rules of this simplified insn
+                        -- selection game are therefore that the returned
+                        -- Reg may be modified
+
+
+-- | Compute an expression into a register, but
+--      we don't mind which one it is.
+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
+getSomeReg expr = do
+  r <- getRegister expr
+  case r of
+    Any rep code -> do
+        tmp <- getNewRegNat rep
+        return (tmp, code tmp)
+    Fixed _ reg code ->
+        return (reg, code)
+
+getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)
+getI64Amodes addrTree = do
+    Amode hi_addr addr_code <- getAmode D addrTree
+    case addrOffset hi_addr 4 of
+        Just lo_addr -> return (hi_addr, lo_addr, addr_code)
+        Nothing      -> do (hi_ptr, code) <- getSomeReg addrTree
+                           return (AddrRegImm hi_ptr (ImmInt 0),
+                                   AddrRegImm hi_ptr (ImmInt 4),
+                                   code)
+
+
+assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
+assignMem_I64Code addrTree valueTree = do
+        (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
+        ChildCode64 vcode rlo <- iselExpr64 valueTree
+        let
+                rhi = getHiVRegFromLo rlo
+
+                -- Big-endian store
+                mov_hi = ST II32 rhi hi_addr
+                mov_lo = ST II32 rlo lo_addr
+        return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
+
+
+assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
+assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do
+   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
+   let
+         r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32
+         r_dst_hi = getHiVRegFromLo r_dst_lo
+         r_src_hi = getHiVRegFromLo r_src_lo
+         mov_lo = MR r_dst_lo r_src_lo
+         mov_hi = MR r_dst_hi r_src_hi
+   return (
+        vcode `snocOL` mov_lo `snocOL` mov_hi
+     )
+
+assignReg_I64Code _ _
+   = panic "assignReg_I64Code(powerpc): invalid lvalue"
+
+
+iselExpr64        :: CmmExpr -> NatM ChildCode64
+iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do
+    (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
+    (rlo, rhi) <- getNewRegPairNat II32
+    let mov_hi = LD II32 rhi hi_addr
+        mov_lo = LD II32 rlo lo_addr
+    return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
+                         rlo
+
+iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty
+   = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))
+
+iselExpr64 (CmmLit (CmmInt i _)) = do
+  (rlo,rhi) <- getNewRegPairNat II32
+  let
+        half0 = fromIntegral (fromIntegral i :: Word16)
+        half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)
+        half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16)
+        half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16)
+
+        code = toOL [
+                LIS rlo (ImmInt half1),
+                OR rlo rlo (RIImm $ ImmInt half0),
+                LIS rhi (ImmInt half3),
+                OR rhi rhi (RIImm $ ImmInt half2)
+                ]
+  return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
+   ChildCode64 code1 r1lo <- iselExpr64 e1
+   ChildCode64 code2 r2lo <- iselExpr64 e2
+   (rlo,rhi) <- getNewRegPairNat II32
+   let
+        r1hi = getHiVRegFromLo r1lo
+        r2hi = getHiVRegFromLo r2lo
+        code =  code1 `appOL`
+                code2 `appOL`
+                toOL [ ADDC rlo r1lo r2lo,
+                       ADDE rhi r1hi r2hi ]
+   return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do
+   ChildCode64 code1 r1lo <- iselExpr64 e1
+   ChildCode64 code2 r2lo <- iselExpr64 e2
+   (rlo,rhi) <- getNewRegPairNat II32
+   let
+        r1hi = getHiVRegFromLo r1lo
+        r2hi = getHiVRegFromLo r2lo
+        code =  code1 `appOL`
+                code2 `appOL`
+                toOL [ SUBFC rlo r2lo (RIReg r1lo),
+                       SUBFE rhi r2hi r1hi ]
+   return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do
+    (expr_reg,expr_code) <- getSomeReg expr
+    (rlo, rhi) <- getNewRegPairNat II32
+    let mov_hi = LI rhi (ImmInt 0)
+        mov_lo = MR rlo expr_reg
+    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
+                         rlo
+
+iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do
+    (expr_reg,expr_code) <- getSomeReg expr
+    (rlo, rhi) <- getNewRegPairNat II32
+    let mov_hi = SRA II32 rhi expr_reg (RIImm (ImmInt 31))
+        mov_lo = MR rlo expr_reg
+    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
+                         rlo
+iselExpr64 expr
+   = pprPanic "iselExpr64(powerpc)" (pprExpr expr)
+
+
+
+getRegister :: CmmExpr -> NatM Register
+getRegister e = do dflags <- getDynFlags
+                   getRegister' dflags e
+
+getRegister' :: DynFlags -> CmmExpr -> NatM Register
+
+getRegister' dflags (CmmReg (CmmGlobal PicBaseReg))
+  | OSAIX <- platformOS (targetPlatform dflags) = do
+        let code dst = toOL [ LD II32 dst tocAddr ]
+            tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]"))
+        return (Any II32 code)
+  | target32Bit (targetPlatform dflags) = do
+      reg <- getPicBaseNat $ archWordFormat (target32Bit (targetPlatform dflags))
+      return (Fixed (archWordFormat (target32Bit (targetPlatform dflags)))
+                    reg nilOL)
+  | otherwise = return (Fixed II64 toc nilOL)
+
+getRegister' dflags (CmmReg reg)
+  = return (Fixed (cmmTypeFormat (cmmRegType dflags reg))
+                  (getRegisterReg (targetPlatform dflags) reg) nilOL)
+
+getRegister' dflags tree@(CmmRegOff _ _)
+  = getRegister' dflags (mangleIndexTree dflags tree)
+
+    -- for 32-bit architectuers, support some 64 -> 32 bit conversions:
+    -- TO_W_(x), TO_W_(x >> 32)
+
+getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32)
+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
+ | target32Bit (targetPlatform dflags) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32)
+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
+ | target32Bit (targetPlatform dflags) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) [x])
+ | target32Bit (targetPlatform dflags) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code
+
+getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x])
+ | target32Bit (targetPlatform dflags) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code
+
+getRegister' dflags (CmmLoad mem pk)
+ | not (isWord64 pk) = do
+        let platform = targetPlatform dflags
+        Amode addr addr_code <- getAmode D mem
+        let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk)
+                       addr_code `snocOL` LD format dst addr
+        return (Any format code)
+ | not (target32Bit (targetPlatform dflags)) = do
+        Amode addr addr_code <- getAmode DS mem
+        let code dst = addr_code `snocOL` LD II64 dst addr
+        return (Any II64 code)
+
+          where format = cmmTypeFormat pk
+
+-- catch simple cases of zero- or sign-extended load
+getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
+
+getRegister' _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
+
+getRegister' _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))
+
+getRegister' _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))
+
+-- Note: there is no Load Byte Arithmetic instruction, so no signed case here
+
+getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr))
+
+getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr))
+
+getRegister' _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr))
+
+getRegister' _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr))
+
+getRegister' _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _]) = do
+    Amode addr addr_code <- getAmode D mem
+    return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr))
+
+getRegister' _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do
+    -- lwa is DS-form. See Note [Power instruction format]
+    Amode addr addr_code <- getAmode DS mem
+    return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr))
+
+getRegister' dflags (CmmMachOp mop [x]) -- unary MachOps
+  = case mop of
+      MO_Not rep   -> triv_ucode_int rep NOT
+
+      MO_F_Neg w   -> triv_ucode_float w FNEG
+      MO_S_Neg w   -> triv_ucode_int   w NEG
+
+      MO_FF_Conv W64 W32 -> trivialUCode  FF32 FRSP x
+      MO_FF_Conv W32 W64 -> conversionNop FF64 x
+
+      MO_FS_Conv from to -> coerceFP2Int from to x
+      MO_SF_Conv from to -> coerceInt2FP from to x
+
+      MO_SS_Conv from to
+        | from >= to -> conversionNop (intFormat to) x
+        | otherwise  -> triv_ucode_int to (EXTS (intFormat from))
+
+      MO_UU_Conv from to
+        | from >= to -> conversionNop (intFormat to) x
+        | otherwise  -> clearLeft from to
+
+      MO_XX_Conv _ to -> conversionNop (intFormat to) x
+
+      _ -> panic "PPC.CodeGen.getRegister: no match"
+
+    where
+        triv_ucode_int   width instr = trivialUCode (intFormat    width) instr x
+        triv_ucode_float width instr = trivialUCode (floatFormat  width) instr x
+
+        conversionNop new_format expr
+            = do e_code <- getRegister' dflags expr
+                 return (swizzleRegisterRep e_code new_format)
+
+        clearLeft from to
+            = do (src1, code1) <- getSomeReg x
+                 let arch_fmt  = intFormat (wordWidth dflags)
+                     arch_bits = widthInBits (wordWidth dflags)
+                     size      = widthInBits from
+                     code dst  = code1 `snocOL`
+                                 CLRLI arch_fmt dst src1 (arch_bits - size)
+                 return (Any (intFormat to) code)
+
+getRegister' _ (CmmMachOp mop [x, y]) -- dyadic PrimOps
+  = case mop of
+      MO_F_Eq _ -> condFltReg EQQ x y
+      MO_F_Ne _ -> condFltReg NE  x y
+      MO_F_Gt _ -> condFltReg GTT x y
+      MO_F_Ge _ -> condFltReg GE  x y
+      MO_F_Lt _ -> condFltReg LTT x y
+      MO_F_Le _ -> condFltReg LE  x y
+
+      MO_Eq rep -> condIntReg EQQ rep x y
+      MO_Ne rep -> condIntReg NE  rep x y
+
+      MO_S_Gt rep -> condIntReg GTT rep x y
+      MO_S_Ge rep -> condIntReg GE  rep x y
+      MO_S_Lt rep -> condIntReg LTT rep x y
+      MO_S_Le rep -> condIntReg LE  rep x y
+
+      MO_U_Gt rep -> condIntReg GU  rep x y
+      MO_U_Ge rep -> condIntReg GEU rep x y
+      MO_U_Lt rep -> condIntReg LU  rep x y
+      MO_U_Le rep -> condIntReg LEU rep x y
+
+      MO_F_Add w  -> triv_float w FADD
+      MO_F_Sub w  -> triv_float w FSUB
+      MO_F_Mul w  -> triv_float w FMUL
+      MO_F_Quot w -> triv_float w FDIV
+
+         -- optimize addition with 32-bit immediate
+         -- (needed for PIC)
+      MO_Add W32 ->
+        case y of
+          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate W32 True imm
+            -> trivialCode W32 True ADD x (CmmLit $ CmmInt imm immrep)
+          CmmLit lit
+            -> do
+                (src, srcCode) <- getSomeReg x
+                let imm = litToImm lit
+                    code dst = srcCode `appOL` toOL [
+                                    ADDIS dst src (HA imm),
+                                    ADD dst dst (RIImm (LO imm))
+                                ]
+                return (Any II32 code)
+          _ -> trivialCode W32 True ADD x y
+
+      MO_Add rep -> trivialCode rep True ADD x y
+      MO_Sub rep ->
+        case y of
+          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm)
+            -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep)
+          _ -> case x of
+                 CmmLit (CmmInt imm _)
+                   | Just _ <- makeImmediate rep True imm
+                   -- subfi ('substract from' with immediate) doesn't exist
+                   -> trivialCode rep True SUBFC y x
+                 _ -> trivialCodeNoImm' (intFormat rep) SUBF y x
+
+      MO_Mul rep -> shiftMulCode rep True MULL x y
+      MO_S_MulMayOflo rep -> do
+        (src1, code1) <- getSomeReg x
+        (src2, code2) <- getSomeReg y
+        let
+          format = intFormat rep
+          code dst = code1 `appOL` code2
+                       `appOL` toOL [ MULLO format dst src1 src2
+                                    , MFOV  format dst
+                                    ]
+        return (Any format code)
+
+      MO_S_Quot rep -> divCode rep True x y
+      MO_U_Quot rep -> divCode rep False x y
+
+      MO_S_Rem rep -> remainder rep True x y
+      MO_U_Rem rep -> remainder rep False x y
+
+      MO_And rep   -> case y of
+        (CmmLit (CmmInt imm _)) | imm == -8 || imm == -4
+            -> do
+                (src, srcCode) <- getSomeReg x
+                let clear_mask = if imm == -4 then 2 else 3
+                    fmt = intFormat rep
+                    code dst = srcCode
+                               `appOL` unitOL (CLRRI fmt dst src clear_mask)
+                return (Any fmt code)
+        _ -> trivialCode rep False AND x y
+      MO_Or rep    -> trivialCode rep False OR x y
+      MO_Xor rep   -> trivialCode rep False XOR x y
+
+      MO_Shl rep   -> shiftMulCode rep False SL x y
+      MO_S_Shr rep -> srCode rep True SRA x y
+      MO_U_Shr rep -> srCode rep False SR x y
+      _         -> panic "PPC.CodeGen.getRegister: no match"
+
+  where
+    triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
+    triv_float width instr = trivialCodeNoImm (floatFormat width) instr x y
+
+    remainder :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
+    remainder rep sgn x y = do
+      let fmt = intFormat rep
+      tmp <- getNewRegNat fmt
+      code <- remainderCode rep sgn tmp x y
+      return (Any fmt code)
+
+
+getRegister' _ (CmmLit (CmmInt i rep))
+  | Just imm <- makeImmediate rep True i
+  = let
+        code dst = unitOL (LI dst imm)
+    in
+        return (Any (intFormat rep) code)
+
+getRegister' _ (CmmLit (CmmFloat f frep)) = do
+    lbl <- getNewLabelNat
+    dflags <- getDynFlags
+    dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+    Amode addr addr_code <- getAmode D dynRef
+    let format = floatFormat frep
+        code dst =
+            LDATA (Section ReadOnlyData lbl)
+                  (Statics lbl [CmmStaticLit (CmmFloat f frep)])
+            `consOL` (addr_code `snocOL` LD format dst addr)
+    return (Any format code)
+
+getRegister' dflags (CmmLit lit)
+  | target32Bit (targetPlatform dflags)
+  = let rep = cmmLitType dflags lit
+        imm = litToImm lit
+        code dst = toOL [
+              LIS dst (HA imm),
+              ADD dst dst (RIImm (LO imm))
+          ]
+    in return (Any (cmmTypeFormat rep) code)
+  | otherwise
+  = do lbl <- getNewLabelNat
+       dflags <- getDynFlags
+       dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+       Amode addr addr_code <- getAmode D dynRef
+       let rep = cmmLitType dflags lit
+           format = cmmTypeFormat rep
+           code dst =
+            LDATA (Section ReadOnlyData lbl) (Statics lbl [CmmStaticLit lit])
+            `consOL` (addr_code `snocOL` LD format dst addr)
+       return (Any format code)
+
+getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other)
+
+    -- extend?Rep: wrap integer expression of type `from`
+    -- in a conversion to `to`
+extendSExpr :: Width -> Width -> CmmExpr -> CmmExpr
+extendSExpr from to x = CmmMachOp (MO_SS_Conv from to) [x]
+
+extendUExpr :: Width -> Width -> CmmExpr -> CmmExpr
+extendUExpr from to x = CmmMachOp (MO_UU_Conv from to) [x]
+
+-- -----------------------------------------------------------------------------
+--  The 'Amode' type: Memory addressing modes passed up the tree.
+
+data Amode
+        = Amode AddrMode InstrBlock
+
+{-
+Now, given a tree (the argument to a CmmLoad) that references memory,
+produce a suitable addressing mode.
+
+A Rule of the Game (tm) for Amodes: use of the addr bit must
+immediately follow use of the code part, since the code part puts
+values in registers which the addr then refers to.  So you can't put
+anything in between, lest it overwrite some of those registers.  If
+you need to do some other computation between the code part and use of
+the addr bit, first store the effective address from the amode in a
+temporary, then do the other computation, and then use the temporary:
+
+    code
+    LEA amode, tmp
+    ... other computation ...
+    ... (tmp) ...
+-}
+
+{- Note [Power instruction format]
+In some instructions the 16 bit offset must be a multiple of 4, i.e.
+the two least significant bits must be zero. The "Power ISA" specification
+calls these instruction formats "DS-FORM" and the instructions with
+arbitrary 16 bit offsets are "D-FORM".
+
+The Power ISA specification document can be obtained from www.power.org.
+-}
+data InstrForm = D | DS
+
+getAmode :: InstrForm -> CmmExpr -> NatM Amode
+getAmode inf tree@(CmmRegOff _ _)
+  = do dflags <- getDynFlags
+       getAmode inf (mangleIndexTree dflags tree)
+
+getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)])
+  | Just off <- makeImmediate W32 True (-i)
+  = do
+        (reg, code) <- getSomeReg x
+        return (Amode (AddrRegImm reg off) code)
+
+
+getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)])
+  | Just off <- makeImmediate W32 True i
+  = do
+        (reg, code) <- getSomeReg x
+        return (Amode (AddrRegImm reg off) code)
+
+getAmode D (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])
+  | Just off <- makeImmediate W64 True (-i)
+  = do
+        (reg, code) <- getSomeReg x
+        return (Amode (AddrRegImm reg off) code)
+
+
+getAmode D (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])
+  | Just off <- makeImmediate W64 True i
+  = do
+        (reg, code) <- getSomeReg x
+        return (Amode (AddrRegImm reg off) code)
+
+getAmode DS (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])
+  | Just off <- makeImmediate W64 True (-i)
+  = do
+        (reg, code) <- getSomeReg x
+        (reg', off', code')  <-
+                     if i `mod` 4 == 0
+                      then do return (reg, off, code)
+                      else do
+                           tmp <- getNewRegNat II64
+                           return (tmp, ImmInt 0,
+                                  code `snocOL` ADD tmp reg (RIImm off))
+        return (Amode (AddrRegImm reg' off') code')
+
+getAmode DS (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])
+  | Just off <- makeImmediate W64 True i
+  = do
+        (reg, code) <- getSomeReg x
+        (reg', off', code')  <-
+                     if i `mod` 4 == 0
+                      then do return (reg, off, code)
+                      else do
+                           tmp <- getNewRegNat II64
+                           return (tmp, ImmInt 0,
+                                  code `snocOL` ADD tmp reg (RIImm off))
+        return (Amode (AddrRegImm reg' off') code')
+
+   -- optimize addition with 32-bit immediate
+   -- (needed for PIC)
+getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit])
+  = do
+        dflags <- getDynFlags
+        (src, srcCode) <- getSomeReg x
+        let imm = litToImm lit
+        case () of
+            _ | OSAIX <- platformOS (targetPlatform dflags)
+              , isCmmLabelType lit ->
+                    -- HA16/LO16 relocations on labels not supported on AIX
+                    return (Amode (AddrRegImm src imm) srcCode)
+              | otherwise -> do
+                    tmp <- getNewRegNat II32
+                    let code = srcCode `snocOL` ADDIS tmp src (HA imm)
+                    return (Amode (AddrRegImm tmp (LO imm)) code)
+  where
+      isCmmLabelType (CmmLabel {})        = True
+      isCmmLabelType (CmmLabelOff {})     = True
+      isCmmLabelType (CmmLabelDiffOff {}) = True
+      isCmmLabelType _                    = False
+
+getAmode _ (CmmLit lit)
+  = do
+        dflags <- getDynFlags
+        case platformArch $ targetPlatform dflags of
+             ArchPPC -> do
+                 tmp <- getNewRegNat II32
+                 let imm = litToImm lit
+                     code = unitOL (LIS tmp (HA imm))
+                 return (Amode (AddrRegImm tmp (LO imm)) code)
+             _        -> do -- TODO: Load from TOC,
+                            -- see getRegister' _ (CmmLit lit)
+                 tmp <- getNewRegNat II64
+                 let imm = litToImm lit
+                     code =  toOL [
+                          LIS tmp (HIGHESTA imm),
+                          OR tmp tmp (RIImm (HIGHERA imm)),
+                          SL  II64 tmp tmp (RIImm (ImmInt 32)),
+                          ORIS tmp tmp (HA imm)
+                          ]
+                 return (Amode (AddrRegImm tmp (LO imm)) code)
+
+getAmode _ (CmmMachOp (MO_Add W32) [x, y])
+  = do
+        (regX, codeX) <- getSomeReg x
+        (regY, codeY) <- getSomeReg y
+        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
+
+getAmode _ (CmmMachOp (MO_Add W64) [x, y])
+  = do
+        (regX, codeX) <- getSomeReg x
+        (regY, codeY) <- getSomeReg y
+        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
+
+getAmode _ other
+  = do
+        (reg, code) <- getSomeReg other
+        let
+            off  = ImmInt 0
+        return (Amode (AddrRegImm reg off) code)
+
+
+--  The 'CondCode' type:  Condition codes passed up the tree.
+data CondCode
+        = CondCode Bool Cond InstrBlock
+
+-- Set up a condition code for a conditional branch.
+
+getCondCode :: CmmExpr -> NatM CondCode
+
+-- almost the same as everywhere else - but we need to
+-- extend small integers to 32 bit or 64 bit first
+
+getCondCode (CmmMachOp mop [x, y])
+  = do
+    case mop of
+      MO_F_Eq W32 -> condFltCode EQQ x y
+      MO_F_Ne W32 -> condFltCode NE  x y
+      MO_F_Gt W32 -> condFltCode GTT x y
+      MO_F_Ge W32 -> condFltCode GE  x y
+      MO_F_Lt W32 -> condFltCode LTT x y
+      MO_F_Le W32 -> condFltCode LE  x y
+
+      MO_F_Eq W64 -> condFltCode EQQ x y
+      MO_F_Ne W64 -> condFltCode NE  x y
+      MO_F_Gt W64 -> condFltCode GTT x y
+      MO_F_Ge W64 -> condFltCode GE  x y
+      MO_F_Lt W64 -> condFltCode LTT x y
+      MO_F_Le W64 -> condFltCode LE  x y
+
+      MO_Eq rep -> condIntCode EQQ rep x y
+      MO_Ne rep -> condIntCode NE  rep x y
+
+      MO_S_Gt rep -> condIntCode GTT rep x y
+      MO_S_Ge rep -> condIntCode GE  rep x y
+      MO_S_Lt rep -> condIntCode LTT rep x y
+      MO_S_Le rep -> condIntCode LE  rep x y
+
+      MO_U_Gt rep -> condIntCode GU  rep x y
+      MO_U_Ge rep -> condIntCode GEU rep x y
+      MO_U_Lt rep -> condIntCode LU  rep x y
+      MO_U_Le rep -> condIntCode LEU rep x y
+
+      _ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop)
+
+getCondCode _ = panic "getCondCode(2)(powerpc)"
+
+
+-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
+-- passed back up the tree.
+
+condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
+condIntCode cond width x y = do
+  dflags <- getDynFlags
+  condIntCode' (target32Bit (targetPlatform dflags)) cond width x y
+
+condIntCode' :: Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
+
+-- simple code for 64-bit on 32-bit platforms
+condIntCode' True cond W64 x y
+  | condUnsigned cond
+  = do
+      ChildCode64 code_x x_lo <- iselExpr64 x
+      ChildCode64 code_y y_lo <- iselExpr64 y
+      let x_hi = getHiVRegFromLo x_lo
+          y_hi = getHiVRegFromLo y_lo
+      end_lbl <- getBlockIdNat
+      let code = code_x `appOL` code_y `appOL` toOL
+                 [ CMPL II32 x_hi (RIReg y_hi)
+                 , BCC NE end_lbl Nothing
+                 , CMPL II32 x_lo (RIReg y_lo)
+                 , BCC ALWAYS end_lbl Nothing
+
+                 , NEWBLOCK end_lbl
+                 ]
+      return (CondCode False cond code)
+  | otherwise
+  = do
+      ChildCode64 code_x x_lo <- iselExpr64 x
+      ChildCode64 code_y y_lo <- iselExpr64 y
+      let x_hi = getHiVRegFromLo x_lo
+          y_hi = getHiVRegFromLo y_lo
+      end_lbl <- getBlockIdNat
+      cmp_lo  <- getBlockIdNat
+      let code = code_x `appOL` code_y `appOL` toOL
+                 [ CMP II32 x_hi (RIReg y_hi)
+                 , BCC NE end_lbl Nothing
+                 , CMP II32 x_hi (RIImm (ImmInt 0))
+                 , BCC LE cmp_lo Nothing
+                 , CMPL II32 x_lo (RIReg y_lo)
+                 , BCC ALWAYS end_lbl Nothing
+                 , CMPL II32 y_lo (RIReg x_lo)
+                 , BCC ALWAYS end_lbl Nothing
+
+                 , NEWBLOCK end_lbl
+                 ]
+      return (CondCode False cond code)
+
+-- optimize pointer tag checks. Operation andi. sets condition register
+-- so cmpi ..., 0 is redundant.
+condIntCode' _ cond _ (CmmMachOp (MO_And _) [x, CmmLit (CmmInt imm rep)])
+                 (CmmLit (CmmInt 0 _))
+  | not $ condUnsigned cond,
+    Just src2 <- makeImmediate rep False imm
+  = do
+      (src1, code) <- getSomeReg x
+      let code' = code `snocOL` AND r0 src1 (RIImm src2)
+      return (CondCode False cond code')
+
+condIntCode' _ cond width x (CmmLit (CmmInt y rep))
+  | Just src2 <- makeImmediate rep (not $ condUnsigned cond) y
+  = do
+      let op_len = max W32 width
+      let extend = extendSExpr width op_len
+      (src1, code) <- getSomeReg (extend x)
+      let format = intFormat op_len
+          code' = code `snocOL`
+            (if condUnsigned cond then CMPL else CMP) format src1 (RIImm src2)
+      return (CondCode False cond code')
+
+condIntCode' _ cond width x y = do
+  let op_len = max W32 width
+  let extend = if condUnsigned cond then extendUExpr width op_len
+               else extendSExpr width op_len
+  (src1, code1) <- getSomeReg (extend x)
+  (src2, code2) <- getSomeReg (extend y)
+  let format = intFormat op_len
+      code' = code1 `appOL` code2 `snocOL`
+        (if condUnsigned cond then CMPL else CMP) format src1 (RIReg src2)
+  return (CondCode False cond code')
+
+condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
+condFltCode cond x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let
+        code'  = code1 `appOL` code2 `snocOL` FCMP src1 src2
+        code'' = case cond of -- twiddle CR to handle unordered case
+                    GE -> code' `snocOL` CRNOR ltbit eqbit gtbit
+                    LE -> code' `snocOL` CRNOR gtbit eqbit ltbit
+                    _ -> code'
+                 where
+                    ltbit = 0 ; eqbit = 2 ; gtbit = 1
+    return (CondCode True cond code'')
+
+
+
+-- -----------------------------------------------------------------------------
+-- Generating assignments
+
+-- Assignments are really at the heart of the whole code generation
+-- business.  Almost all top-level nodes of any real importance are
+-- assignments, which correspond to loads, stores, or register
+-- transfers.  If we're really lucky, some of the register transfers
+-- will go away, because we can use the destination register to
+-- complete the code generation for the right hand side.  This only
+-- fails when the right hand side is forced into a fixed register
+-- (e.g. the result of a call).
+
+assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
+
+assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
+
+assignMem_IntCode pk addr src = do
+    (srcReg, code) <- getSomeReg src
+    Amode dstAddr addr_code <- case pk of
+                                II64 -> getAmode DS addr
+                                _    -> getAmode D  addr
+    return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
+
+-- dst is a reg, but src could be anything
+assignReg_IntCode _ reg src
+    = do
+        dflags <- getDynFlags
+        let dst = getRegisterReg (targetPlatform dflags) reg
+        r <- getRegister src
+        return $ case r of
+            Any _ code         -> code dst
+            Fixed _ freg fcode -> fcode `snocOL` MR dst freg
+
+
+
+-- Easy, isn't it?
+assignMem_FltCode = assignMem_IntCode
+assignReg_FltCode = assignReg_IntCode
+
+
+
+genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
+
+genJump (CmmLit (CmmLabel lbl))
+  = return (unitOL $ JMP lbl)
+
+genJump tree
+  = do
+        dflags <- getDynFlags
+        genJump' tree (platformToGCP (targetPlatform dflags))
+
+genJump' :: CmmExpr -> GenCCallPlatform -> NatM InstrBlock
+
+genJump' tree (GCP64ELF 1)
+  = do
+        (target,code) <- getSomeReg tree
+        return (code
+               `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 0))
+               `snocOL` LD II64 toc (AddrRegImm target (ImmInt 8))
+               `snocOL` MTCTR r11
+               `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 16))
+               `snocOL` BCTR [] Nothing)
+
+genJump' tree (GCP64ELF 2)
+  = do
+        (target,code) <- getSomeReg tree
+        return (code
+               `snocOL` MR r12 target
+               `snocOL` MTCTR r12
+               `snocOL` BCTR [] Nothing)
+
+genJump' tree _
+  = do
+        (target,code) <- getSomeReg tree
+        return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing)
+
+-- -----------------------------------------------------------------------------
+--  Unconditional branches
+genBranch :: BlockId -> NatM InstrBlock
+genBranch = return . toOL . mkJumpInstr
+
+
+-- -----------------------------------------------------------------------------
+--  Conditional jumps
+
+{-
+Conditional jumps are always to local labels, so we can use branch
+instructions.  We peek at the arguments to decide what kind of
+comparison to do.
+-}
+
+
+genCondJump
+    :: BlockId      -- the branch target
+    -> CmmExpr      -- the condition on which to branch
+    -> Maybe Bool
+    -> NatM InstrBlock
+
+genCondJump id bool prediction = do
+  CondCode _ cond code <- getCondCode bool
+  return (code `snocOL` BCC cond id prediction)
+
+
+
+-- -----------------------------------------------------------------------------
+--  Generating C calls
+
+-- Now the biggest nightmare---calls.  Most of the nastiness is buried in
+-- @get_arg@, which moves the arguments to the correct registers/stack
+-- locations.  Apart from that, the code is easy.
+
+genCCall :: ForeignTarget      -- function to call
+         -> [CmmFormal]        -- where to put the result
+         -> [CmmActual]        -- arguments (of mixed type)
+         -> NatM InstrBlock
+genCCall (PrimTarget MO_WriteBarrier) _ _
+ = return $ unitOL LWSYNC
+
+genCCall (PrimTarget MO_Touch) _ _
+ = return $ nilOL
+
+genCCall (PrimTarget (MO_Prefetch_Data _)) _ _
+ = return $ nilOL
+
+genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n]
+ = do dflags <- getDynFlags
+      let platform = targetPlatform dflags
+          fmt      = intFormat width
+          reg_dst  = getRegisterReg platform (CmmLocal dst)
+      (instr, n_code) <- case amop of
+            AMO_Add  -> getSomeRegOrImm ADD True reg_dst
+            AMO_Sub  -> case n of
+                CmmLit (CmmInt i _)
+                  | Just imm <- makeImmediate width True (-i)
+                   -> return (ADD reg_dst reg_dst (RIImm imm), nilOL)
+                _
+                   -> do
+                         (n_reg, n_code) <- getSomeReg n
+                         return  (SUBF reg_dst n_reg reg_dst, n_code)
+            AMO_And  -> getSomeRegOrImm AND False reg_dst
+            AMO_Nand -> do (n_reg, n_code) <- getSomeReg n
+                           return (NAND reg_dst reg_dst n_reg, n_code)
+            AMO_Or   -> getSomeRegOrImm OR False reg_dst
+            AMO_Xor  -> getSomeRegOrImm XOR False reg_dst
+      Amode addr_reg addr_code <- getAmodeIndex addr
+      lbl_retry <- getBlockIdNat
+      return $ n_code `appOL` addr_code
+        `appOL` toOL [ HWSYNC
+                     , BCC ALWAYS lbl_retry Nothing
+
+                     , NEWBLOCK lbl_retry
+                     , LDR fmt reg_dst addr_reg
+                     , instr
+                     , STC fmt reg_dst addr_reg
+                     , BCC NE lbl_retry (Just False)
+                     , ISYNC
+                     ]
+         where
+           getAmodeIndex (CmmMachOp (MO_Add _) [x, y])
+             = do
+                 (regX, codeX) <- getSomeReg x
+                 (regY, codeY) <- getSomeReg y
+                 return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
+           getAmodeIndex other
+             = do
+                 (reg, code) <- getSomeReg other
+                 return (Amode (AddrRegReg r0 reg) code) -- NB: r0 is 0 here!
+           getSomeRegOrImm op sign dst
+             = case n of
+                 CmmLit (CmmInt i _) | Just imm <- makeImmediate width sign i
+                    -> return (op dst dst (RIImm imm), nilOL)
+                 _
+                    -> do
+                          (n_reg, n_code) <- getSomeReg n
+                          return  (op dst dst (RIReg n_reg), n_code)
+
+genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr]
+ = do dflags <- getDynFlags
+      let platform = targetPlatform dflags
+          fmt      = intFormat width
+          reg_dst  = getRegisterReg platform (CmmLocal dst)
+          form     = if widthInBits width == 64 then DS else D
+      Amode addr_reg addr_code <- getAmode form addr
+      lbl_end <- getBlockIdNat
+      return $ addr_code `appOL` toOL [ HWSYNC
+                                      , LD fmt reg_dst addr_reg
+                                      , CMP fmt reg_dst (RIReg reg_dst)
+                                      , BCC NE lbl_end (Just False)
+                                      , BCC ALWAYS lbl_end Nothing
+                            -- See Note [Seemingly useless cmp and bne]
+                                      , NEWBLOCK lbl_end
+                                      , ISYNC
+                                      ]
+
+-- Note [Seemingly useless cmp and bne]
+-- In Power ISA, Book II, Section 4.4.1, Instruction Synchronize Instruction
+-- the second paragraph says that isync may complete before storage accesses
+-- "associated" with a preceding instruction have been performed. The cmp
+-- operation and the following bne introduce a data and control dependency
+-- on the load instruction (See also Power ISA, Book II, Appendix B.2.3, Safe
+-- Fetch).
+-- This is also what gcc does.
+
+
+genCCall (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do
+    code <- assignMem_IntCode (intFormat width) addr val
+    return $ unitOL(HWSYNC) `appOL` code
+
+genCCall (PrimTarget (MO_Clz width)) [dst] [src]
+ = do dflags <- getDynFlags
+      let platform = targetPlatform dflags
+          reg_dst = getRegisterReg platform (CmmLocal dst)
+      if target32Bit platform && width == W64
+        then do
+          ChildCode64 code vr_lo <- iselExpr64 src
+          lbl1 <- getBlockIdNat
+          lbl2 <- getBlockIdNat
+          lbl3 <- getBlockIdNat
+          let vr_hi = getHiVRegFromLo vr_lo
+              cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0))
+                           , BCC NE lbl2 Nothing
+                           , BCC ALWAYS lbl1 Nothing
+
+                           , NEWBLOCK lbl1
+                           , CNTLZ II32 reg_dst vr_lo
+                           , ADD reg_dst reg_dst (RIImm (ImmInt 32))
+                           , BCC ALWAYS lbl3 Nothing
+
+                           , NEWBLOCK lbl2
+                           , CNTLZ II32 reg_dst vr_hi
+                           , BCC ALWAYS lbl3 Nothing
+
+                           , NEWBLOCK lbl3
+                           ]
+          return $ code `appOL` cntlz
+        else do
+          let format = if width == W64 then II64 else II32
+          (s_reg, s_code) <- getSomeReg src
+          (pre, reg , post) <-
+            case width of
+              W64 -> return (nilOL, s_reg, nilOL)
+              W32 -> return (nilOL, s_reg, nilOL)
+              W16 -> do
+                reg_tmp <- getNewRegNat format
+                return
+                  ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 65535))
+                  , reg_tmp
+                  , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-16)))
+                  )
+              W8  -> do
+                reg_tmp <- getNewRegNat format
+                return
+                  ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 255))
+                  , reg_tmp
+                  , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-24)))
+                  )
+              _   -> panic "genCall: Clz wrong format"
+          let cntlz = unitOL (CNTLZ format reg_dst reg)
+          return $ s_code `appOL` pre `appOL` cntlz `appOL` post
+
+genCCall (PrimTarget (MO_Ctz width)) [dst] [src]
+ = do dflags <- getDynFlags
+      let platform = targetPlatform dflags
+          reg_dst = getRegisterReg platform (CmmLocal dst)
+      if target32Bit platform && width == W64
+        then do
+          let format = II32
+          ChildCode64 code vr_lo <- iselExpr64 src
+          lbl1 <- getBlockIdNat
+          lbl2 <- getBlockIdNat
+          lbl3 <- getBlockIdNat
+          x' <- getNewRegNat format
+          x'' <- getNewRegNat format
+          r' <- getNewRegNat format
+          cnttzlo <- cnttz format reg_dst vr_lo
+          let vr_hi = getHiVRegFromLo vr_lo
+              cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0))
+                             , BCC NE lbl2 Nothing
+                             , BCC ALWAYS lbl1 Nothing
+
+                             , NEWBLOCK lbl1
+                             , ADD x' vr_hi (RIImm (ImmInt (-1)))
+                             , ANDC x'' x' vr_hi
+                             , CNTLZ format r' x''
+                               -- 32 + (32 - clz(x''))
+                             , SUBFC reg_dst r' (RIImm (ImmInt 64))
+                             , BCC ALWAYS lbl3 Nothing
+
+                             , NEWBLOCK lbl2
+                             ]
+                        `appOL` cnttzlo `appOL`
+                        toOL [ BCC ALWAYS lbl3 Nothing
+
+                             , NEWBLOCK lbl3
+                             ]
+          return $ code `appOL` cnttz64
+        else do
+          let format = if width == W64 then II64 else II32
+          (s_reg, s_code) <- getSomeReg src
+          (reg_ctz, pre_code) <-
+            case width of
+              W64 -> return (s_reg, nilOL)
+              W32 -> return (s_reg, nilOL)
+              W16 -> do
+                reg_tmp <- getNewRegNat format
+                return (reg_tmp, unitOL $ ORIS reg_tmp s_reg (ImmInt 1))
+              W8  -> do
+                reg_tmp <- getNewRegNat format
+                return (reg_tmp, unitOL $ OR reg_tmp s_reg (RIImm (ImmInt 256)))
+              _   -> panic "genCall: Ctz wrong format"
+          ctz_code <- cnttz format reg_dst reg_ctz
+          return $ s_code `appOL` pre_code `appOL` ctz_code
+        where
+          -- cnttz(x) = sizeof(x) - cntlz(~x & (x - 1))
+          -- see Henry S. Warren, Hacker's Delight, p 107
+          cnttz format dst src = do
+            let format_bits = 8 * formatInBytes format
+            x' <- getNewRegNat format
+            x'' <- getNewRegNat format
+            r' <- getNewRegNat format
+            return $ toOL [ ADD x' src (RIImm (ImmInt (-1)))
+                          , ANDC x'' x' src
+                          , CNTLZ format r' x''
+                          , SUBFC dst r' (RIImm (ImmInt (format_bits)))
+                          ]
+
+genCCall target dest_regs argsAndHints
+ = do dflags <- getDynFlags
+      let platform = targetPlatform dflags
+      case target of
+        PrimTarget (MO_S_QuotRem  width) -> divOp1 platform True  width
+                                                   dest_regs argsAndHints
+        PrimTarget (MO_U_QuotRem  width) -> divOp1 platform False width
+                                                   dest_regs argsAndHints
+        PrimTarget (MO_U_QuotRem2 width) -> divOp2 platform width dest_regs
+                                                   argsAndHints
+        PrimTarget (MO_U_Mul2 width) -> multOp2 platform width dest_regs
+                                                argsAndHints
+        PrimTarget (MO_Add2 _) -> add2Op platform dest_regs argsAndHints
+        PrimTarget (MO_AddWordC _) -> addcOp platform dest_regs argsAndHints
+        PrimTarget (MO_SubWordC _) -> subcOp platform dest_regs argsAndHints
+        PrimTarget (MO_AddIntC width) -> addSubCOp ADDO platform width
+                                                   dest_regs argsAndHints
+        PrimTarget (MO_SubIntC width) -> addSubCOp SUBFO platform width
+                                                   dest_regs argsAndHints
+        PrimTarget MO_F64_Fabs -> fabs platform dest_regs argsAndHints
+        PrimTarget MO_F32_Fabs -> fabs platform dest_regs argsAndHints
+        _ -> genCCall' dflags (platformToGCP platform)
+                       target dest_regs argsAndHints
+        where divOp1 platform signed width [res_q, res_r] [arg_x, arg_y]
+                = do let reg_q = getRegisterReg platform (CmmLocal res_q)
+                         reg_r = getRegisterReg platform (CmmLocal res_r)
+                     remainderCode width signed reg_q arg_x arg_y
+                       <*> pure reg_r
+
+              divOp1 _ _ _ _ _
+                = panic "genCCall: Wrong number of arguments for divOp1"
+              divOp2 platform width [res_q, res_r]
+                                    [arg_x_high, arg_x_low, arg_y]
+                = do let reg_q = getRegisterReg platform (CmmLocal res_q)
+                         reg_r = getRegisterReg platform (CmmLocal res_r)
+                         fmt   = intFormat width
+                         half  = 4 * (formatInBytes fmt)
+                     (xh_reg, xh_code) <- getSomeReg arg_x_high
+                     (xl_reg, xl_code) <- getSomeReg arg_x_low
+                     (y_reg, y_code) <- getSomeReg arg_y
+                     s <- getNewRegNat fmt
+                     b <- getNewRegNat fmt
+                     v <- getNewRegNat fmt
+                     vn1 <- getNewRegNat fmt
+                     vn0 <- getNewRegNat fmt
+                     un32 <- getNewRegNat fmt
+                     tmp  <- getNewRegNat fmt
+                     un10 <- getNewRegNat fmt
+                     un1 <- getNewRegNat fmt
+                     un0 <- getNewRegNat fmt
+                     q1 <- getNewRegNat fmt
+                     rhat <- getNewRegNat fmt
+                     tmp1 <- getNewRegNat fmt
+                     q0 <- getNewRegNat fmt
+                     un21 <- getNewRegNat fmt
+                     again1 <- getBlockIdNat
+                     no1 <- getBlockIdNat
+                     then1 <- getBlockIdNat
+                     endif1 <- getBlockIdNat
+                     again2 <- getBlockIdNat
+                     no2 <- getBlockIdNat
+                     then2 <- getBlockIdNat
+                     endif2 <- getBlockIdNat
+                     return $ y_code `appOL` xl_code `appOL` xh_code `appOL`
+                              -- see Hacker's Delight p 196 Figure 9-3
+                              toOL [ -- b = 2 ^ (bits_in_word / 2)
+                                     LI b (ImmInt 1)
+                                   , SL fmt b b (RIImm (ImmInt half))
+                                     -- s = clz(y)
+                                   , CNTLZ fmt s y_reg
+                                     -- v = y << s
+                                   , SL fmt v y_reg (RIReg s)
+                                     -- vn1 = upper half of v
+                                   , SR fmt vn1 v (RIImm (ImmInt half))
+                                     -- vn0 = lower half of v
+                                   , CLRLI fmt vn0 v half
+                                     -- un32 = (u1 << s)
+                                     --      | (u0 >> (bits_in_word - s))
+                                   , SL fmt un32 xh_reg (RIReg s)
+                                   , SUBFC tmp s
+                                        (RIImm (ImmInt (8 * formatInBytes fmt)))
+                                   , SR fmt tmp xl_reg (RIReg tmp)
+                                   , OR un32 un32 (RIReg tmp)
+                                     -- un10 = u0 << s
+                                   , SL fmt un10 xl_reg (RIReg s)
+                                     -- un1 = upper half of un10
+                                   , SR fmt un1 un10 (RIImm (ImmInt half))
+                                     -- un0 = lower half of un10
+                                   , CLRLI fmt un0 un10 half
+                                     -- q1 = un32/vn1
+                                   , DIV fmt False q1 un32 vn1
+                                     -- rhat = un32 - q1*vn1
+                                   , MULL fmt tmp q1 (RIReg vn1)
+                                   , SUBF rhat tmp un32
+                                   , BCC ALWAYS again1 Nothing
+
+                                   , NEWBLOCK again1
+                                     -- if (q1 >= b || q1*vn0 > b*rhat + un1)
+                                   , CMPL fmt q1 (RIReg b)
+                                   , BCC GEU then1 Nothing
+                                   , BCC ALWAYS no1 Nothing
+
+                                   , NEWBLOCK no1
+                                   , MULL fmt tmp q1 (RIReg vn0)
+                                   , SL fmt tmp1 rhat (RIImm (ImmInt half))
+                                   , ADD tmp1 tmp1 (RIReg un1)
+                                   , CMPL fmt tmp (RIReg tmp1)
+                                   , BCC LEU endif1 Nothing
+                                   , BCC ALWAYS then1 Nothing
+
+                                   , NEWBLOCK then1
+                                     -- q1 = q1 - 1
+                                   , ADD q1 q1 (RIImm (ImmInt (-1)))
+                                     -- rhat = rhat + vn1
+                                   , ADD rhat rhat (RIReg vn1)
+                                     -- if (rhat < b) goto again1
+                                   , CMPL fmt rhat (RIReg b)
+                                   , BCC LTT again1 Nothing
+                                   , BCC ALWAYS endif1 Nothing
+
+                                   , NEWBLOCK endif1
+                                     -- un21 = un32*b + un1 - q1*v
+                                   , SL fmt un21 un32 (RIImm (ImmInt half))
+                                   , ADD un21 un21 (RIReg un1)
+                                   , MULL fmt tmp q1 (RIReg v)
+                                   , SUBF un21 tmp un21
+                                     -- compute second quotient digit
+                                     -- q0 = un21/vn1
+                                   , DIV fmt False q0 un21 vn1
+                                     -- rhat = un21- q0*vn1
+                                   , MULL fmt tmp q0 (RIReg vn1)
+                                   , SUBF rhat tmp un21
+                                   , BCC ALWAYS again2 Nothing
+
+                                   , NEWBLOCK again2
+                                     -- if (q0>b || q0*vn0 > b*rhat + un0)
+                                   , CMPL fmt q0 (RIReg b)
+                                   , BCC GEU then2 Nothing
+                                   , BCC ALWAYS no2 Nothing
+
+                                   , NEWBLOCK no2
+                                   , MULL fmt tmp q0 (RIReg vn0)
+                                   , SL fmt tmp1 rhat (RIImm (ImmInt half))
+                                   , ADD tmp1 tmp1 (RIReg un0)
+                                   , CMPL fmt tmp (RIReg tmp1)
+                                   , BCC LEU endif2 Nothing
+                                   , BCC ALWAYS then2 Nothing
+
+                                   , NEWBLOCK then2
+                                     -- q0 = q0 - 1
+                                   , ADD q0 q0 (RIImm (ImmInt (-1)))
+                                     -- rhat = rhat + vn1
+                                   , ADD rhat rhat (RIReg vn1)
+                                     -- if (rhat<b) goto again2
+                                   , CMPL fmt rhat (RIReg b)
+                                   , BCC LTT again2 Nothing
+                                   , BCC ALWAYS endif2 Nothing
+
+                                   , NEWBLOCK endif2
+                                     -- compute remainder
+                                     -- r = (un21*b + un0 - q0*v) >> s
+                                   , SL fmt reg_r un21 (RIImm (ImmInt half))
+                                   , ADD reg_r reg_r (RIReg un0)
+                                   , MULL fmt tmp q0 (RIReg v)
+                                   , SUBF reg_r tmp reg_r
+                                   , SR fmt reg_r reg_r (RIReg s)
+                                     -- compute quotient
+                                     -- q = q1*b + q0
+                                   , SL fmt reg_q q1 (RIImm (ImmInt half))
+                                   , ADD reg_q reg_q (RIReg q0)
+                                   ]
+              divOp2 _ _ _ _
+                = panic "genCCall: Wrong number of arguments for divOp2"
+              multOp2 platform width [res_h, res_l] [arg_x, arg_y]
+                = do let reg_h = getRegisterReg platform (CmmLocal res_h)
+                         reg_l = getRegisterReg platform (CmmLocal res_l)
+                         fmt = intFormat width
+                     (x_reg, x_code) <- getSomeReg arg_x
+                     (y_reg, y_code) <- getSomeReg arg_y
+                     return $ y_code `appOL` x_code
+                            `appOL` toOL [ MULL fmt reg_l x_reg (RIReg y_reg)
+                                         , MULHU fmt reg_h x_reg y_reg
+                                         ]
+              multOp2 _ _ _ _
+                = panic "genCall: Wrong number of arguments for multOp2"
+              add2Op platform [res_h, res_l] [arg_x, arg_y]
+                = do let reg_h = getRegisterReg platform (CmmLocal res_h)
+                         reg_l = getRegisterReg platform (CmmLocal res_l)
+                     (x_reg, x_code) <- getSomeReg arg_x
+                     (y_reg, y_code) <- getSomeReg arg_y
+                     return $ y_code `appOL` x_code
+                            `appOL` toOL [ LI reg_h (ImmInt 0)
+                                         , ADDC reg_l x_reg y_reg
+                                         , ADDZE reg_h reg_h
+                                         ]
+              add2Op _ _ _
+                = panic "genCCall: Wrong number of arguments/results for add2"
+
+              addcOp platform [res_r, res_c] [arg_x, arg_y]
+                = add2Op platform [res_c {-hi-}, res_r {-lo-}] [arg_x, arg_y]
+              addcOp _ _ _
+                = panic "genCCall: Wrong number of arguments/results for addc"
+
+              -- PowerPC subfc sets the carry for rT = ~(rA) + rB + 1,
+              -- which is 0 for borrow and 1 otherwise. We need 1 and 0
+              -- so xor with 1.
+              subcOp platform [res_r, res_c] [arg_x, arg_y]
+                = do let reg_r = getRegisterReg platform (CmmLocal res_r)
+                         reg_c = getRegisterReg platform (CmmLocal res_c)
+                     (x_reg, x_code) <- getSomeReg arg_x
+                     (y_reg, y_code) <- getSomeReg arg_y
+                     return $ y_code `appOL` x_code
+                            `appOL` toOL [ LI reg_c (ImmInt 0)
+                                         , SUBFC reg_r y_reg (RIReg x_reg)
+                                         , ADDZE reg_c reg_c
+                                         , XOR reg_c reg_c (RIImm (ImmInt 1))
+                                         ]
+              subcOp _ _ _
+                = panic "genCCall: Wrong number of arguments/results for subc"
+              addSubCOp instr platform width [res_r, res_c] [arg_x, arg_y]
+                = do let reg_r = getRegisterReg platform (CmmLocal res_r)
+                         reg_c = getRegisterReg platform (CmmLocal res_c)
+                     (x_reg, x_code) <- getSomeReg arg_x
+                     (y_reg, y_code) <- getSomeReg arg_y
+                     return $ y_code `appOL` x_code
+                            `appOL` toOL [ instr reg_r y_reg x_reg,
+                                           -- SUBFO argument order reversed!
+                                           MFOV (intFormat width) reg_c
+                                         ]
+              addSubCOp _ _ _ _ _
+                = panic "genCall: Wrong number of arguments/results for addC"
+              fabs platform [res] [arg]
+                = do let res_r = getRegisterReg platform (CmmLocal res)
+                     (arg_reg, arg_code) <- getSomeReg arg
+                     return $ arg_code `snocOL` FABS res_r arg_reg
+              fabs _ _ _
+                = panic "genCall: Wrong number of arguments/results for fabs"
+
+-- TODO: replace 'Int' by an enum such as 'PPC_64ABI'
+data GenCCallPlatform = GCP32ELF | GCP64ELF !Int | GCPAIX
+
+platformToGCP :: Platform -> GenCCallPlatform
+platformToGCP platform
+  = case platformOS platform of
+      OSAIX    -> GCPAIX
+      _ -> case platformArch platform of
+             ArchPPC           -> GCP32ELF
+             ArchPPC_64 ELF_V1 -> GCP64ELF 1
+             ArchPPC_64 ELF_V2 -> GCP64ELF 2
+             _ -> panic "platformToGCP: Not PowerPC"
+
+
+genCCall'
+    :: DynFlags
+    -> GenCCallPlatform
+    -> ForeignTarget            -- function to call
+    -> [CmmFormal]        -- where to put the result
+    -> [CmmActual]        -- arguments (of mixed type)
+    -> NatM InstrBlock
+
+{- 
+    PowerPC Linux uses the System V Release 4 Calling Convention
+    for PowerPC. It is described in the
+    "System V Application Binary Interface PowerPC Processor Supplement".
+
+    PowerPC 64 Linux uses the System V Release 4 Calling Convention for
+    64-bit PowerPC. It is specified in
+    "64-bit PowerPC ELF Application Binary Interface Supplement 1.9"
+    (PPC64 ELF v1.9).
+
+    PowerPC 64 Linux in little endian mode uses the "Power Architecture 64-Bit
+    ELF V2 ABI Specification -- OpenPOWER ABI for Linux Supplement"
+    (PPC64 ELF v2).
+
+    AIX follows the "PowerOpen ABI: Application Binary Interface Big-Endian
+    32-Bit Hardware Implementation"
+
+    All four conventions are similar:
+    Parameters may be passed in general-purpose registers starting at r3, in
+    floating point registers starting at f1, or on the stack.
+
+    But there are substantial differences:
+    * The number of registers used for parameter passing and the exact set of
+      nonvolatile registers differs (see MachRegs.hs).
+    * On AIX and 64-bit ELF, stack space is always reserved for parameters,
+      even if they are passed in registers. The called routine may choose to
+      save parameters from registers to the corresponding space on the stack.
+    * On AIX and 64-bit ELF, a corresponding amount of GPRs is skipped when
+      a floating point parameter is passed in an FPR.
+    * SysV insists on either passing I64 arguments on the stack, or in two GPRs,
+      starting with an odd-numbered GPR. It may skip a GPR to achieve this.
+      AIX just treats an I64 likt two separate I32s (high word first).
+    * I64 and FF64 arguments are 8-byte aligned on the stack for SysV, but only
+      4-byte aligned like everything else on AIX.
+    * The SysV spec claims that FF32 is represented as FF64 on the stack. GCC on
+      PowerPC Linux does not agree, so neither do we.
+
+    According to all conventions, the parameter area should be part of the
+    caller's stack frame, allocated in the caller's prologue code (large enough
+    to hold the parameter lists for all called routines). The NCG already
+    uses the stack for register spilling, leaving 64 bytes free at the top.
+    If we need a larger parameter area than that, we increase the size
+    of the stack frame just before ccalling.
+-}
+
+
+genCCall' dflags gcp target dest_regs args
+  = do
+        (finalStack,passArgumentsCode,usedRegs) <- passArguments
+                                                   (zip3 args argReps argHints)
+                                                   allArgRegs
+                                                   (allFPArgRegs platform)
+                                                   initialStackOffset
+                                                   nilOL []
+
+        (labelOrExpr, reduceToFF32) <- case target of
+            ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do
+                uses_pic_base_implicitly
+                return (Left lbl, False)
+            ForeignTarget expr _ -> do
+                uses_pic_base_implicitly
+                return (Right expr, False)
+            PrimTarget mop -> outOfLineMachOp mop
+
+        let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
+            codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32
+
+        case labelOrExpr of
+            Left lbl -> do -- the linker does all the work for us
+                return (         codeBefore
+                        `snocOL` BL lbl usedRegs
+                        `appOL`  maybeNOP -- some ABI require a NOP after BL
+                        `appOL`  codeAfter)
+            Right dyn -> do -- implement call through function pointer
+                (dynReg, dynCode) <- getSomeReg dyn
+                case gcp of
+                     GCP64ELF 1      -> return ( dynCode
+                       `appOL`  codeBefore
+                       `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 40))
+                       `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 0))
+                       `snocOL` LD II64 toc (AddrRegImm dynReg (ImmInt 8))
+                       `snocOL` MTCTR r11
+                       `snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 16))
+                       `snocOL` BCTRL usedRegs
+                       `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 40))
+                       `appOL`  codeAfter)
+                     GCP64ELF 2      -> return ( dynCode
+                       `appOL`  codeBefore
+                       `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 24))
+                       `snocOL` MR r12 dynReg
+                       `snocOL` MTCTR r12
+                       `snocOL` BCTRL usedRegs
+                       `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 24))
+                       `appOL`  codeAfter)
+                     GCPAIX          -> return ( dynCode
+                       -- AIX/XCOFF follows the PowerOPEN ABI
+                       -- which is quite similiar to LinuxPPC64/ELFv1
+                       `appOL`  codeBefore
+                       `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 20))
+                       `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 0))
+                       `snocOL` LD II32 toc (AddrRegImm dynReg (ImmInt 4))
+                       `snocOL` MTCTR r11
+                       `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 8))
+                       `snocOL` BCTRL usedRegs
+                       `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 20))
+                       `appOL`  codeAfter)
+                     _               -> return ( dynCode
+                       `snocOL` MTCTR dynReg
+                       `appOL`  codeBefore
+                       `snocOL` BCTRL usedRegs
+                       `appOL`  codeAfter)
+    where
+        platform = targetPlatform dflags
+
+        uses_pic_base_implicitly = do
+            -- See Note [implicit register in PPC PIC code]
+            -- on why we claim to use PIC register here
+            when (positionIndependent dflags && target32Bit platform) $ do
+                _ <- getPicBaseNat $ archWordFormat True
+                return ()
+
+        initialStackOffset = case gcp of
+                             GCPAIX     -> 24
+                             GCP32ELF   -> 8
+                             GCP64ELF 1 -> 48
+                             GCP64ELF 2 -> 32
+                             _ -> panic "genCall': unknown calling convention"
+            -- size of linkage area + size of arguments, in bytes
+        stackDelta finalStack = case gcp of
+                                GCPAIX ->
+                                    roundTo 16 $ (24 +) $ max 32 $ sum $
+                                    map (widthInBytes . typeWidth) argReps
+                                GCP32ELF -> roundTo 16 finalStack
+                                GCP64ELF 1 ->
+                                    roundTo 16 $ (48 +) $ max 64 $ sum $
+                                    map (roundTo 8 . widthInBytes . typeWidth)
+                                        argReps
+                                GCP64ELF 2 ->
+                                    roundTo 16 $ (32 +) $ max 64 $ sum $
+                                    map (roundTo 8 . widthInBytes . typeWidth)
+                                        argReps
+                                _ -> panic "genCall': unknown calling conv."
+
+        argReps = map (cmmExprType dflags) args
+        (argHints, _) = foreignTargetHints target
+
+        roundTo a x | x `mod` a == 0 = x
+                    | otherwise = x + a - (x `mod` a)
+
+        spFormat = if target32Bit platform then II32 else II64
+
+        -- TODO: Do not create a new stack frame if delta is too large.
+        move_sp_down finalStack
+               | delta > stackFrameHeaderSize dflags =
+                        toOL [STU spFormat sp (AddrRegImm sp (ImmInt (-delta))),
+                              DELTA (-delta)]
+               | otherwise = nilOL
+               where delta = stackDelta finalStack
+        move_sp_up finalStack
+               | delta > stackFrameHeaderSize dflags =
+                        toOL [ADD sp sp (RIImm (ImmInt delta)),
+                              DELTA 0]
+               | otherwise = nilOL
+               where delta = stackDelta finalStack
+
+        -- A NOP instruction is required after a call (bl instruction)
+        -- on AIX and 64-Bit Linux.
+        -- If the call is to a function with a different TOC (r2) the
+        -- link editor replaces the NOP instruction with a load of the TOC
+        -- from the stack to restore the TOC.
+        maybeNOP = case gcp of
+           GCP32ELF        -> nilOL
+           -- See Section 3.9.4 of OpenPower ABI
+           GCPAIX          -> unitOL NOP
+           -- See Section 3.5.11 of PPC64 ELF v1.9
+           GCP64ELF 1      -> unitOL NOP
+           -- See Section 2.3.6 of PPC64 ELF v2
+           GCP64ELF 2      -> unitOL NOP
+           _               -> panic "maybeNOP: Unknown PowerPC 64-bit ABI"
+
+        passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed)
+        passArguments ((arg,arg_ty,_):args) gprs fprs stackOffset
+               accumCode accumUsed | isWord64 arg_ty
+                                     && target32Bit (targetPlatform dflags) =
+            do
+                ChildCode64 code vr_lo <- iselExpr64 arg
+                let vr_hi = getHiVRegFromLo vr_lo
+
+                case gcp of
+                    GCPAIX ->
+                        do let storeWord vr (gpr:_) _ = MR gpr vr
+                               storeWord vr [] offset
+                                   = ST II32 vr (AddrRegImm sp (ImmInt offset))
+                           passArguments args
+                                         (drop 2 gprs)
+                                         fprs
+                                         (stackOffset+8)
+                                         (accumCode `appOL` code
+                                               `snocOL` storeWord vr_hi gprs stackOffset
+                                               `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
+                                         ((take 2 gprs) ++ accumUsed)
+                    GCP32ELF ->
+                        do let stackOffset' = roundTo 8 stackOffset
+                               stackCode = accumCode `appOL` code
+                                   `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset'))
+                                   `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4)))
+                               regCode hireg loreg =
+                                   accumCode `appOL` code
+                                       `snocOL` MR hireg vr_hi
+                                       `snocOL` MR loreg vr_lo
+
+                           case gprs of
+                               hireg : loreg : regs | even (length gprs) ->
+                                   passArguments args regs fprs stackOffset
+                                                 (regCode hireg loreg) (hireg : loreg : accumUsed)
+                               _skipped : hireg : loreg : regs ->
+                                   passArguments args regs fprs stackOffset
+                                                 (regCode hireg loreg) (hireg : loreg : accumUsed)
+                               _ -> -- only one or no regs left
+                                   passArguments args [] fprs (stackOffset'+8)
+                                                 stackCode accumUsed
+                    GCP64ELF _ -> panic "passArguments: 32 bit code"
+
+        passArguments ((arg,rep,hint):args) gprs fprs stackOffset accumCode accumUsed
+            | reg : _ <- regs = do
+                register <- getRegister arg_pro
+                let code = case register of
+                            Fixed _ freg fcode -> fcode `snocOL` MR reg freg
+                            Any _ acode -> acode reg
+                    stackOffsetRes = case gcp of
+                                     -- The PowerOpen ABI requires that we
+                                     -- reserve stack slots for register
+                                     -- parameters
+                                     GCPAIX    -> stackOffset + stackBytes
+                                     -- ... the SysV ABI 32-bit doesn't.
+                                     GCP32ELF -> stackOffset
+                                     -- ... but SysV ABI 64-bit does.
+                                     GCP64ELF _ -> stackOffset + stackBytes
+                passArguments args
+                              (drop nGprs gprs)
+                              (drop nFprs fprs)
+                              stackOffsetRes
+                              (accumCode `appOL` code)
+                              (reg : accumUsed)
+            | otherwise = do
+                (vr, code) <- getSomeReg arg_pro
+                passArguments args
+                              (drop nGprs gprs)
+                              (drop nFprs fprs)
+                              (stackOffset' + stackBytes)
+                              (accumCode `appOL` code
+                                         `snocOL` ST format_pro vr stackSlot)
+                              accumUsed
+            where
+                arg_pro
+                   | isBitsType rep = CmmMachOp (conv_op (typeWidth rep) (wordWidth dflags)) [arg]
+                   | otherwise      = arg
+                format_pro
+                   | isBitsType rep = intFormat (wordWidth dflags)
+                   | otherwise      = cmmTypeFormat rep
+                conv_op = case hint of
+                            SignedHint -> MO_SS_Conv
+                            _          -> MO_UU_Conv
+
+                stackOffset' = case gcp of
+                               GCPAIX ->
+                                   -- The 32bit PowerOPEN ABI is happy with
+                                   -- 32bit-alignment ...
+                                   stackOffset
+                               GCP32ELF
+                                   -- ... the SysV ABI requires 8-byte
+                                   -- alignment for doubles.
+                                | isFloatType rep && typeWidth rep == W64 ->
+                                   roundTo 8 stackOffset
+                                | otherwise ->
+                                   stackOffset
+                               GCP64ELF _ ->
+                                   -- Everything on the stack is mapped to
+                                   -- 8-byte aligned doublewords
+                                   stackOffset
+                stackOffset''
+                     | isFloatType rep && typeWidth rep == W32 =
+                         case gcp of
+                         -- The ELF v1 ABI Section 3.2.3 requires:
+                         -- "Single precision floating point values
+                         -- are mapped to the second word in a single
+                         -- doubleword"
+                         GCP64ELF 1      -> stackOffset' + 4
+                         _               -> stackOffset'
+                     | otherwise = stackOffset'
+
+                stackSlot = AddrRegImm sp (ImmInt stackOffset'')
+                (nGprs, nFprs, stackBytes, regs)
+                    = case gcp of
+                      GCPAIX ->
+                          case cmmTypeFormat rep of
+                          II8  -> (1, 0, 4, gprs)
+                          II16 -> (1, 0, 4, gprs)
+                          II32 -> (1, 0, 4, gprs)
+                          -- The PowerOpen ABI requires that we skip a
+                          -- corresponding number of GPRs when we use
+                          -- the FPRs.
+                          --
+                          -- E.g. for a `double` two GPRs are skipped,
+                          -- whereas for a `float` one GPR is skipped
+                          -- when parameters are assigned to
+                          -- registers.
+                          --
+                          -- The PowerOpen ABI specification can be found at
+                          -- ftp://www.sourceware.org/pub/binutils/ppc-docs/ppc-poweropen/
+                          FF32 -> (1, 1, 4, fprs)
+                          FF64 -> (2, 1, 8, fprs)
+                          II64 -> panic "genCCall' passArguments II64"
+                          FF80 -> panic "genCCall' passArguments FF80"
+                      GCP32ELF ->
+                          case cmmTypeFormat rep of
+                          II8  -> (1, 0, 4, gprs)
+                          II16 -> (1, 0, 4, gprs)
+                          II32 -> (1, 0, 4, gprs)
+                          -- ... the SysV ABI doesn't.
+                          FF32 -> (0, 1, 4, fprs)
+                          FF64 -> (0, 1, 8, fprs)
+                          II64 -> panic "genCCall' passArguments II64"
+                          FF80 -> panic "genCCall' passArguments FF80"
+                      GCP64ELF _ ->
+                          case cmmTypeFormat rep of
+                          II8  -> (1, 0, 8, gprs)
+                          II16 -> (1, 0, 8, gprs)
+                          II32 -> (1, 0, 8, gprs)
+                          II64 -> (1, 0, 8, gprs)
+                          -- The ELFv1 ABI requires that we skip a
+                          -- corresponding number of GPRs when we use
+                          -- the FPRs.
+                          FF32 -> (1, 1, 8, fprs)
+                          FF64 -> (1, 1, 8, fprs)
+                          FF80 -> panic "genCCall' passArguments FF80"
+
+        moveResult reduceToFF32 =
+            case dest_regs of
+                [] -> nilOL
+                [dest]
+                    | reduceToFF32 && isFloat32 rep   -> unitOL (FRSP r_dest f1)
+                    | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1)
+                    | isWord64 rep && target32Bit (targetPlatform dflags)
+                       -> toOL [MR (getHiVRegFromLo r_dest) r3,
+                                MR r_dest r4]
+                    | otherwise -> unitOL (MR r_dest r3)
+                    where rep = cmmRegType dflags (CmmLocal dest)
+                          r_dest = getRegisterReg platform (CmmLocal dest)
+                _ -> panic "genCCall' moveResult: Bad dest_regs"
+
+        outOfLineMachOp mop =
+            do
+                dflags <- getDynFlags
+                mopExpr <- cmmMakeDynamicReference dflags CallReference $
+                              mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction
+                let mopLabelOrExpr = case mopExpr of
+                        CmmLit (CmmLabel lbl) -> Left lbl
+                        _ -> Right mopExpr
+                return (mopLabelOrExpr, reduce)
+            where
+                (functionName, reduce) = case mop of
+                    MO_F32_Exp   -> (fsLit "exp", True)
+                    MO_F32_Log   -> (fsLit "log", True)
+                    MO_F32_Sqrt  -> (fsLit "sqrt", True)
+                    MO_F32_Fabs  -> unsupported
+
+                    MO_F32_Sin   -> (fsLit "sin", True)
+                    MO_F32_Cos   -> (fsLit "cos", True)
+                    MO_F32_Tan   -> (fsLit "tan", True)
+
+                    MO_F32_Asin  -> (fsLit "asin", True)
+                    MO_F32_Acos  -> (fsLit "acos", True)
+                    MO_F32_Atan  -> (fsLit "atan", True)
+
+                    MO_F32_Sinh  -> (fsLit "sinh", True)
+                    MO_F32_Cosh  -> (fsLit "cosh", True)
+                    MO_F32_Tanh  -> (fsLit "tanh", True)
+                    MO_F32_Pwr   -> (fsLit "pow", True)
+
+                    MO_F32_Asinh -> (fsLit "asinh", True)
+                    MO_F32_Acosh -> (fsLit "acosh", True)
+                    MO_F32_Atanh -> (fsLit "atanh", True)
+
+                    MO_F64_Exp   -> (fsLit "exp", False)
+                    MO_F64_Log   -> (fsLit "log", False)
+                    MO_F64_Sqrt  -> (fsLit "sqrt", False)
+                    MO_F64_Fabs  -> unsupported
+
+                    MO_F64_Sin   -> (fsLit "sin", False)
+                    MO_F64_Cos   -> (fsLit "cos", False)
+                    MO_F64_Tan   -> (fsLit "tan", False)
+
+                    MO_F64_Asin  -> (fsLit "asin", False)
+                    MO_F64_Acos  -> (fsLit "acos", False)
+                    MO_F64_Atan  -> (fsLit "atan", False)
+
+                    MO_F64_Sinh  -> (fsLit "sinh", False)
+                    MO_F64_Cosh  -> (fsLit "cosh", False)
+                    MO_F64_Tanh  -> (fsLit "tanh", False)
+                    MO_F64_Pwr   -> (fsLit "pow", False)
+
+                    MO_F64_Asinh -> (fsLit "asinh", False)
+                    MO_F64_Acosh -> (fsLit "acosh", False)
+                    MO_F64_Atanh -> (fsLit "atanh", False)
+
+                    MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False)
+
+                    MO_Memcpy _  -> (fsLit "memcpy", False)
+                    MO_Memset _  -> (fsLit "memset", False)
+                    MO_Memmove _ -> (fsLit "memmove", False)
+                    MO_Memcmp _  -> (fsLit "memcmp", False)
+
+                    MO_BSwap w   -> (fsLit $ bSwapLabel w, False)
+                    MO_PopCnt w  -> (fsLit $ popCntLabel w, False)
+                    MO_Pdep w    -> (fsLit $ pdepLabel w, False)
+                    MO_Pext w    -> (fsLit $ pextLabel w, False)
+                    MO_Clz _     -> unsupported
+                    MO_Ctz _     -> unsupported
+                    MO_AtomicRMW {} -> unsupported
+                    MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False)
+                    MO_AtomicRead _  -> unsupported
+                    MO_AtomicWrite _ -> unsupported
+
+                    MO_S_QuotRem {}  -> unsupported
+                    MO_U_QuotRem {}  -> unsupported
+                    MO_U_QuotRem2 {} -> unsupported
+                    MO_Add2 {}       -> unsupported
+                    MO_AddWordC {}   -> unsupported
+                    MO_SubWordC {}   -> unsupported
+                    MO_AddIntC {}    -> unsupported
+                    MO_SubIntC {}    -> unsupported
+                    MO_U_Mul2 {}     -> unsupported
+                    MO_WriteBarrier  -> unsupported
+                    MO_Touch         -> unsupported
+                    MO_Prefetch_Data _ -> unsupported
+                unsupported = panic ("outOfLineCmmOp: " ++ show mop
+                                  ++ " not supported")
+
+-- -----------------------------------------------------------------------------
+-- Generating a table-branch
+
+genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
+genSwitch dflags expr targets
+  | OSAIX <- platformOS (targetPlatform dflags)
+  = do
+        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
+        let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
+            sha = if target32Bit $ targetPlatform dflags then 2 else 3
+        tmp <- getNewRegNat fmt
+        lbl <- getNewLabelNat
+        dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+        (tableReg,t_code) <- getSomeReg $ dynRef
+        let code = e_code `appOL` t_code `appOL` toOL [
+                            SL fmt tmp reg (RIImm (ImmInt sha)),
+                            LD fmt tmp (AddrRegReg tableReg tmp),
+                            MTCTR tmp,
+                            BCTR ids (Just lbl)
+                    ]
+        return code
+
+  | (positionIndependent dflags) || (not $ target32Bit $ targetPlatform dflags)
+  = do
+        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
+        let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
+            sha = if target32Bit $ targetPlatform dflags then 2 else 3
+        tmp <- getNewRegNat fmt
+        lbl <- getNewLabelNat
+        dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+        (tableReg,t_code) <- getSomeReg $ dynRef
+        let code = e_code `appOL` t_code `appOL` toOL [
+                            SL fmt tmp reg (RIImm (ImmInt sha)),
+                            LD fmt tmp (AddrRegReg tableReg tmp),
+                            ADD tmp tmp (RIReg tableReg),
+                            MTCTR tmp,
+                            BCTR ids (Just lbl)
+                    ]
+        return code
+  | otherwise
+  = do
+        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
+        let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
+            sha = if target32Bit $ targetPlatform dflags then 2 else 3
+        tmp <- getNewRegNat fmt
+        lbl <- getNewLabelNat
+        let code = e_code `appOL` toOL [
+                            SL fmt tmp reg (RIImm (ImmInt sha)),
+                            ADDIS tmp tmp (HA (ImmCLbl lbl)),
+                            LD fmt tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
+                            MTCTR tmp,
+                            BCTR ids (Just lbl)
+                    ]
+        return code
+  where (offset, ids) = switchTargetsToTable targets
+
+generateJumpTableForInstr :: DynFlags -> Instr
+                          -> Maybe (NatCmmDecl CmmStatics Instr)
+generateJumpTableForInstr dflags (BCTR ids (Just lbl)) =
+    let jumpTable
+            | (positionIndependent dflags)
+              || (not $ target32Bit $ targetPlatform dflags)
+            = map jumpTableEntryRel ids
+            | otherwise = map (jumpTableEntry dflags) ids
+                where jumpTableEntryRel Nothing
+                        = CmmStaticLit (CmmInt 0 (wordWidth dflags))
+                      jumpTableEntryRel (Just blockid)
+                        = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0
+                                         (wordWidth dflags))
+                            where blockLabel = blockLbl blockid
+    in Just (CmmData (Section ReadOnlyData lbl) (Statics lbl jumpTable))
+generateJumpTableForInstr _ _ = Nothing
+
+-- -----------------------------------------------------------------------------
+-- 'condIntReg' and 'condFltReg': condition codes into registers
+
+-- Turn those condition codes into integers now (when they appear on
+-- the right hand side of an assignment).
+
+
+
+condReg :: NatM CondCode -> NatM Register
+condReg getCond = do
+    CondCode _ cond cond_code <- getCond
+    dflags <- getDynFlags
+    let
+        code dst = cond_code
+            `appOL` negate_code
+            `appOL` toOL [
+                MFCR dst,
+                RLWINM dst dst (bit + 1) 31 31
+            ]
+
+        negate_code | do_negate = unitOL (CRNOR bit bit bit)
+                    | otherwise = nilOL
+
+        (bit, do_negate) = case cond of
+            LTT -> (0, False)
+            LE  -> (1, True)
+            EQQ -> (2, False)
+            GE  -> (0, True)
+            GTT -> (1, False)
+
+            NE  -> (2, True)
+
+            LU  -> (0, False)
+            LEU -> (1, True)
+            GEU -> (0, True)
+            GU  -> (1, False)
+            _   -> panic "PPC.CodeGen.codeReg: no match"
+
+        format = archWordFormat $ target32Bit $ targetPlatform dflags
+    return (Any format code)
+
+condIntReg :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
+condIntReg cond width x y = condReg (condIntCode cond width x y)
+condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
+condFltReg cond x y = condReg (condFltCode cond x y)
+
+
+
+-- -----------------------------------------------------------------------------
+-- 'trivial*Code': deal with trivial instructions
+
+-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
+-- Only look for constants on the right hand side, because that's
+-- where the generic optimizer will have put them.
+
+-- Similarly, for unary instructions, we don't have to worry about
+-- matching an StInt as the argument, because genericOpt will already
+-- have handled the constant-folding.
+
+
+
+{-
+Wolfgang's PowerPC version of The Rules:
+
+A slightly modified version of The Rules to take advantage of the fact
+that PowerPC instructions work on all registers and don't implicitly
+clobber any fixed registers.
+
+* The only expression for which getRegister returns Fixed is (CmmReg reg).
+
+* If getRegister returns Any, then the code it generates may modify only:
+        (a) fresh temporaries
+        (b) the destination register
+  It may *not* modify global registers, unless the global
+  register happens to be the destination register.
+  It may not clobber any other registers. In fact, only ccalls clobber any
+  fixed registers.
+  Also, it may not modify the counter register (used by genCCall).
+
+  Corollary: If a getRegister for a subexpression returns Fixed, you need
+  not move it to a fresh temporary before evaluating the next subexpression.
+  The Fixed register won't be modified.
+  Therefore, we don't need a counterpart for the x86's getStableReg on PPC.
+
+* SDM's First Rule is valid for PowerPC, too: subexpressions can depend on
+  the value of the destination register.
+-}
+
+trivialCode
+        :: Width
+        -> Bool
+        -> (Reg -> Reg -> RI -> Instr)
+        -> CmmExpr
+        -> CmmExpr
+        -> NatM Register
+
+trivialCode rep signed instr x (CmmLit (CmmInt y _))
+    | Just imm <- makeImmediate rep signed y
+    = do
+        (src1, code1) <- getSomeReg x
+        let code dst = code1 `snocOL` instr dst src1 (RIImm imm)
+        return (Any (intFormat rep) code)
+
+trivialCode rep _ instr x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2)
+    return (Any (intFormat rep) code)
+
+shiftMulCode
+        :: Width
+        -> Bool
+        -> (Format-> Reg -> Reg -> RI -> Instr)
+        -> CmmExpr
+        -> CmmExpr
+        -> NatM Register
+shiftMulCode width sign instr x (CmmLit (CmmInt y _))
+    | Just imm <- makeImmediate width sign y
+    = do
+        (src1, code1) <- getSomeReg x
+        let format = intFormat width
+        let ins_fmt = intFormat (max W32 width)
+        let code dst = code1 `snocOL` instr ins_fmt dst src1 (RIImm imm)
+        return (Any format code)
+
+shiftMulCode width _ instr x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let format = intFormat width
+    let ins_fmt = intFormat (max W32 width)
+    let code dst = code1 `appOL` code2
+                   `snocOL` instr ins_fmt dst src1 (RIReg src2)
+    return (Any format code)
+
+trivialCodeNoImm' :: Format -> (Reg -> Reg -> Reg -> Instr)
+                 -> CmmExpr -> CmmExpr -> NatM Register
+trivialCodeNoImm' format instr x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2
+    return (Any format code)
+
+trivialCodeNoImm :: Format -> (Format -> Reg -> Reg -> Reg -> Instr)
+                 -> CmmExpr -> CmmExpr -> NatM Register
+trivialCodeNoImm format instr x y
+  = trivialCodeNoImm' format (instr format) x y
+
+srCode :: Width -> Bool -> (Format-> Reg -> Reg -> RI -> Instr)
+       -> CmmExpr -> CmmExpr -> NatM Register
+srCode width sgn instr x (CmmLit (CmmInt y _))
+    | Just imm <- makeImmediate width sgn y
+    = do
+        let op_len = max W32 width
+            extend = if sgn then extendSExpr else extendUExpr
+        (src1, code1) <- getSomeReg (extend width op_len x)
+        let code dst = code1 `snocOL`
+                       instr (intFormat op_len) dst src1 (RIImm imm)
+        return (Any (intFormat width) code)
+
+srCode width sgn instr x y = do
+  let op_len = max W32 width
+      extend = if sgn then extendSExpr else extendUExpr
+  (src1, code1) <- getSomeReg (extend width op_len x)
+  (src2, code2) <- getSomeReg (extendUExpr width op_len y)
+  -- Note: Shift amount `y` is unsigned
+  let code dst = code1 `appOL` code2 `snocOL`
+                 instr (intFormat op_len) dst src1 (RIReg src2)
+  return (Any (intFormat width) code)
+
+divCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
+divCode width sgn x y = do
+  let op_len = max W32 width
+      extend = if sgn then extendSExpr else extendUExpr
+  (src1, code1) <- getSomeReg (extend width op_len x)
+  (src2, code2) <- getSomeReg (extend width op_len y)
+  let code dst = code1 `appOL` code2 `snocOL`
+                 DIV (intFormat op_len) sgn dst src1 src2
+  return (Any (intFormat width) code)
+
+
+trivialUCode :: Format
+             -> (Reg -> Reg -> Instr)
+             -> CmmExpr
+             -> NatM Register
+trivialUCode rep instr x = do
+    (src, code) <- getSomeReg x
+    let code' dst = code `snocOL` instr dst src
+    return (Any rep code')
+
+-- There is no "remainder" instruction on the PPC, so we have to do
+-- it the hard way.
+-- The "sgn" parameter is the signedness for the division instruction
+
+remainderCode :: Width -> Bool -> Reg -> CmmExpr -> CmmExpr
+               -> NatM (Reg -> InstrBlock)
+remainderCode rep sgn reg_q arg_x arg_y = do
+  let op_len = max W32 rep
+      fmt    = intFormat op_len
+      extend = if sgn then extendSExpr else extendUExpr
+  (x_reg, x_code) <- getSomeReg (extend rep op_len arg_x)
+  (y_reg, y_code) <- getSomeReg (extend rep op_len arg_y)
+  return $ \reg_r -> y_code `appOL` x_code
+                     `appOL` toOL [ DIV fmt sgn reg_q x_reg y_reg
+                                  , MULL fmt reg_r reg_q (RIReg y_reg)
+                                  , SUBF reg_r reg_r x_reg
+                                  ]
+
+
+coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
+coerceInt2FP fromRep toRep x = do
+    dflags <- getDynFlags
+    let arch =  platformArch $ targetPlatform dflags
+    coerceInt2FP' arch fromRep toRep x
+
+coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
+coerceInt2FP' ArchPPC fromRep toRep x = do
+    (src, code) <- getSomeReg x
+    lbl <- getNewLabelNat
+    itmp <- getNewRegNat II32
+    ftmp <- getNewRegNat FF64
+    dflags <- getDynFlags
+    dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+    Amode addr addr_code <- getAmode D dynRef
+    let
+        code' dst = code `appOL` maybe_exts `appOL` toOL [
+                LDATA (Section ReadOnlyData lbl) $ Statics lbl
+                                 [CmmStaticLit (CmmInt 0x43300000 W32),
+                                  CmmStaticLit (CmmInt 0x80000000 W32)],
+                XORIS itmp src (ImmInt 0x8000),
+                ST II32 itmp (spRel dflags 3),
+                LIS itmp (ImmInt 0x4330),
+                ST II32 itmp (spRel dflags 2),
+                LD FF64 ftmp (spRel dflags 2)
+            ] `appOL` addr_code `appOL` toOL [
+                LD FF64 dst addr,
+                FSUB FF64 dst ftmp dst
+            ] `appOL` maybe_frsp dst
+
+        maybe_exts = case fromRep of
+                        W8 ->  unitOL $ EXTS II8 src src
+                        W16 -> unitOL $ EXTS II16 src src
+                        W32 -> nilOL
+                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"
+
+        maybe_frsp dst
+                = case toRep of
+                        W32 -> unitOL $ FRSP dst dst
+                        W64 -> nilOL
+                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"
+
+    return (Any (floatFormat toRep) code')
+
+-- On an ELF v1 Linux we use the compiler doubleword in the stack frame
+-- this is the TOC pointer doubleword on ELF v2 Linux. The latter is only
+-- set right before a call and restored right after return from the call.
+-- So it is fine.
+coerceInt2FP' (ArchPPC_64 _) fromRep toRep x = do
+    (src, code) <- getSomeReg x
+    dflags <- getDynFlags
+    let
+        code' dst = code `appOL` maybe_exts `appOL` toOL [
+                ST II64 src (spRel dflags 3),
+                LD FF64 dst (spRel dflags 3),
+                FCFID dst dst
+            ] `appOL` maybe_frsp dst
+
+        maybe_exts = case fromRep of
+                        W8 ->  unitOL $ EXTS II8 src src
+                        W16 -> unitOL $ EXTS II16 src src
+                        W32 -> unitOL $ EXTS II32 src src
+                        W64 -> nilOL
+                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"
+
+        maybe_frsp dst
+                = case toRep of
+                        W32 -> unitOL $ FRSP dst dst
+                        W64 -> nilOL
+                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"
+
+    return (Any (floatFormat toRep) code')
+
+coerceInt2FP' _ _ _ _ = panic "PPC.CodeGen.coerceInt2FP: unknown arch"
+
+
+coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
+coerceFP2Int fromRep toRep x = do
+    dflags <- getDynFlags
+    let arch =  platformArch $ targetPlatform dflags
+    coerceFP2Int' arch fromRep toRep x
+
+coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
+coerceFP2Int' ArchPPC _ toRep x = do
+    dflags <- getDynFlags
+    -- the reps don't really matter: F*->FF64 and II32->I* are no-ops
+    (src, code) <- getSomeReg x
+    tmp <- getNewRegNat FF64
+    let
+        code' dst = code `appOL` toOL [
+                -- convert to int in FP reg
+            FCTIWZ tmp src,
+                -- store value (64bit) from FP to stack
+            ST FF64 tmp (spRel dflags 2),
+                -- read low word of value (high word is undefined)
+            LD II32 dst (spRel dflags 3)]
+    return (Any (intFormat toRep) code')
+
+coerceFP2Int' (ArchPPC_64 _) _ toRep x = do
+    dflags <- getDynFlags
+    -- the reps don't really matter: F*->FF64 and II64->I* are no-ops
+    (src, code) <- getSomeReg x
+    tmp <- getNewRegNat FF64
+    let
+        code' dst = code `appOL` toOL [
+                -- convert to int in FP reg
+            FCTIDZ tmp src,
+                -- store value (64bit) from FP to compiler word on stack
+            ST FF64 tmp (spRel dflags 3),
+            LD II64 dst (spRel dflags 3)]
+    return (Any (intFormat toRep) code')
+
+coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch"
+
+-- Note [.LCTOC1 in PPC PIC code]
+-- The .LCTOC1 label is defined to point 32768 bytes into the GOT table
+-- to make the most of the PPC's 16-bit displacements.
+-- As 16-bit signed offset is used (usually via addi/lwz instructions)
+-- first element will have '-32768' offset against .LCTOC1.
+
+-- Note [implicit register in PPC PIC code]
+-- PPC generates calls by labels in assembly
+-- in form of:
+--     bl puts+32768@plt
+-- in this form it's not seen directly (by GHC NCG)
+-- that r30 (PicBaseReg) is used,
+-- but r30 is a required part of PLT code setup:
+--   puts+32768@plt:
+--       lwz     r11,-30484(r30) ; offset in .LCTOC1
+--       mtctr   r11
+--       bctr
diff --git a/compiler/nativeGen/PPC/Cond.hs b/compiler/nativeGen/PPC/Cond.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PPC/Cond.hs
@@ -0,0 +1,63 @@
+module PPC.Cond (
+        Cond(..),
+        condNegate,
+        condUnsigned,
+        condToSigned,
+        condToUnsigned,
+)
+
+where
+
+import GhcPrelude
+
+import Panic
+
+data Cond
+        = ALWAYS
+        | EQQ
+        | GE
+        | GEU
+        | GTT
+        | GU
+        | LE
+        | LEU
+        | LTT
+        | LU
+        | NE
+        deriving Eq
+
+
+condNegate :: Cond -> Cond
+condNegate ALWAYS  = panic "condNegate: ALWAYS"
+condNegate EQQ     = NE
+condNegate GE      = LTT
+condNegate GEU     = LU
+condNegate GTT     = LE
+condNegate GU      = LEU
+condNegate LE      = GTT
+condNegate LEU     = GU
+condNegate LTT     = GE
+condNegate LU      = GEU
+condNegate NE      = EQQ
+
+-- Condition utils
+condUnsigned :: Cond -> Bool
+condUnsigned GU  = True
+condUnsigned LU  = True
+condUnsigned GEU = True
+condUnsigned LEU = True
+condUnsigned _   = False
+
+condToSigned :: Cond -> Cond
+condToSigned GU  = GTT
+condToSigned LU  = LTT
+condToSigned GEU = GE
+condToSigned LEU = LE
+condToSigned x   = x
+
+condToUnsigned :: Cond -> Cond
+condToUnsigned GTT = GU
+condToUnsigned LTT = LU
+condToUnsigned GE  = GEU
+condToUnsigned LE  = LEU
+condToUnsigned x   = x
diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PPC/Instr.hs
@@ -0,0 +1,707 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Machine-dependent assembly language
+--
+-- (c) The University of Glasgow 1993-2004
+--
+-----------------------------------------------------------------------------
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+module PPC.Instr (
+    archWordFormat,
+    RI(..),
+    Instr(..),
+    stackFrameHeaderSize,
+    maxSpillSlots,
+    allocMoreStack,
+    makeFarBranches
+)
+
+where
+
+import GhcPrelude
+
+import PPC.Regs
+import PPC.Cond
+import Instruction
+import Format
+import TargetReg
+import RegClass
+import Reg
+
+import CodeGen.Platform
+import BlockId
+import Hoopl.Collections
+import Hoopl.Label
+import DynFlags
+import Cmm
+import CmmInfo
+import FastString
+import CLabel
+import Outputable
+import Platform
+import UniqFM (listToUFM, lookupUFM)
+import UniqSupply
+
+import Control.Monad (replicateM)
+import Data.Maybe (fromMaybe)
+
+--------------------------------------------------------------------------------
+-- Format of a PPC memory address.
+--
+archWordFormat :: Bool -> Format
+archWordFormat is32Bit
+ | is32Bit   = II32
+ | otherwise = II64
+
+
+-- | Instruction instance for powerpc
+instance Instruction Instr where
+        regUsageOfInstr         = ppc_regUsageOfInstr
+        patchRegsOfInstr        = ppc_patchRegsOfInstr
+        isJumpishInstr          = ppc_isJumpishInstr
+        jumpDestsOfInstr        = ppc_jumpDestsOfInstr
+        patchJumpInstr          = ppc_patchJumpInstr
+        mkSpillInstr            = ppc_mkSpillInstr
+        mkLoadInstr             = ppc_mkLoadInstr
+        takeDeltaInstr          = ppc_takeDeltaInstr
+        isMetaInstr             = ppc_isMetaInstr
+        mkRegRegMoveInstr _     = ppc_mkRegRegMoveInstr
+        takeRegRegMoveInstr     = ppc_takeRegRegMoveInstr
+        mkJumpInstr             = ppc_mkJumpInstr
+        mkStackAllocInstr       = ppc_mkStackAllocInstr
+        mkStackDeallocInstr     = ppc_mkStackDeallocInstr
+
+
+ppc_mkStackAllocInstr :: Platform -> Int -> [Instr]
+ppc_mkStackAllocInstr platform amount
+  = ppc_mkStackAllocInstr' platform (-amount)
+
+ppc_mkStackDeallocInstr :: Platform -> Int -> [Instr]
+ppc_mkStackDeallocInstr platform amount
+  = ppc_mkStackAllocInstr' platform amount
+
+ppc_mkStackAllocInstr' :: Platform -> Int -> [Instr]
+ppc_mkStackAllocInstr' platform amount
+  | fits16Bits amount
+  = [ LD fmt r0 (AddrRegImm sp zero)
+    , STU fmt r0 (AddrRegImm sp immAmount)
+    ]
+  | otherwise
+  = [ LD fmt r0 (AddrRegImm sp zero)
+    , ADDIS tmp sp (HA immAmount)
+    , ADD tmp tmp (RIImm (LO immAmount))
+    , STU fmt r0 (AddrRegReg sp tmp)
+    ]
+  where
+    fmt = intFormat $ widthFromBytes ((platformWordSize platform) `quot` 8)
+    zero = ImmInt 0
+    tmp = tmpReg platform
+    immAmount = ImmInt amount
+
+--
+-- See note [extra spill slots] in X86/Instr.hs
+--
+allocMoreStack
+  :: Platform
+  -> Int
+  -> NatCmmDecl statics PPC.Instr.Instr
+  -> UniqSM (NatCmmDecl statics PPC.Instr.Instr, [(BlockId,BlockId)])
+
+allocMoreStack _ _ top@(CmmData _ _) = return (top,[])
+allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do
+    let
+        infos   = mapKeys info
+        entries = case code of
+                    [] -> infos
+                    BasicBlock entry _ : _ -- first block is the entry point
+                        | entry `elem` infos -> infos
+                        | otherwise          -> entry : infos
+
+    uniqs <- replicateM (length entries) getUniqueM
+
+    let
+        delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
+            where x = slots * spillSlotSize -- sp delta
+
+        alloc   = mkStackAllocInstr   platform delta
+        dealloc = mkStackDeallocInstr platform delta
+
+        retargetList = (zip entries (map mkBlockId uniqs))
+
+        new_blockmap :: LabelMap BlockId
+        new_blockmap = mapFromList retargetList
+
+        insert_stack_insns (BasicBlock id insns)
+            | Just new_blockid <- mapLookup id new_blockmap
+                = [ BasicBlock id $ alloc ++ [BCC ALWAYS new_blockid Nothing]
+                  , BasicBlock new_blockid block'
+                  ]
+            | otherwise
+                = [ BasicBlock id block' ]
+            where
+              block' = foldr insert_dealloc [] insns
+
+        insert_dealloc insn r
+            -- BCTR might or might not be a non-local jump. For
+            -- "labeled-goto" we use JMP, and for "computed-goto" we
+            -- use MTCTR followed by BCTR. See 'PPC.CodeGen.genJump'.
+            = case insn of
+                JMP _           -> dealloc ++ (insn : r)
+                BCTR [] Nothing -> dealloc ++ (insn : r)
+                BCTR ids label  -> BCTR (map (fmap retarget) ids) label : r
+                BCCFAR cond b p -> BCCFAR cond (retarget b) p : r
+                BCC    cond b p -> BCC    cond (retarget b) p : r
+                _               -> insn : r
+            -- BL and BCTRL are call-like instructions rather than
+            -- jumps, and are used only for C calls.
+
+        retarget :: BlockId -> BlockId
+        retarget b
+            = fromMaybe b (mapLookup b new_blockmap)
+
+        new_code
+            = concatMap insert_stack_insns code
+
+    -- in
+    return (CmmProc info lbl live (ListGraph new_code),retargetList)
+
+
+-- -----------------------------------------------------------------------------
+-- Machine's assembly language
+
+-- We have a few common "instructions" (nearly all the pseudo-ops) but
+-- mostly all of 'Instr' is machine-specific.
+
+-- Register or immediate
+data RI
+    = RIReg Reg
+    | RIImm Imm
+
+data Instr
+    -- comment pseudo-op
+    = COMMENT FastString
+
+    -- some static data spat out during code
+    -- generation.  Will be extracted before
+    -- pretty-printing.
+    | LDATA   Section CmmStatics
+
+    -- start a new basic block.  Useful during
+    -- codegen, removed later.  Preceding
+    -- instruction should be a jump, as per the
+    -- invariants for a BasicBlock (see Cmm).
+    | NEWBLOCK BlockId
+
+    -- specify current stack offset for
+    -- benefit of subsequent passes
+    | DELTA   Int
+
+    -- Loads and stores.
+    | LD      Format Reg AddrMode   -- Load format, dst, src
+    | LDFAR   Format Reg AddrMode   -- Load format, dst, src 32 bit offset
+    | LDR     Format Reg AddrMode   -- Load and reserve format, dst, src
+    | LA      Format Reg AddrMode   -- Load arithmetic format, dst, src
+    | ST      Format Reg AddrMode   -- Store format, src, dst
+    | STFAR   Format Reg AddrMode   -- Store format, src, dst 32 bit offset
+    | STU     Format Reg AddrMode   -- Store with Update format, src, dst
+    | STC     Format Reg AddrMode   -- Store conditional format, src, dst
+    | LIS     Reg Imm               -- Load Immediate Shifted dst, src
+    | LI      Reg Imm               -- Load Immediate dst, src
+    | MR      Reg Reg               -- Move Register dst, src -- also for fmr
+
+    | CMP     Format Reg RI         -- format, src1, src2
+    | CMPL    Format Reg RI         -- format, src1, src2
+
+    | BCC     Cond BlockId (Maybe Bool) -- cond, block, hint
+    | BCCFAR  Cond BlockId (Maybe Bool) -- cond, block, hint
+                                    --   hint:
+                                    --    Just True:  branch likely taken
+                                    --    Just False: branch likely not taken
+                                    --    Nothing:    no hint
+    | JMP     CLabel                -- same as branch,
+                                    -- but with CLabel instead of block ID
+    | MTCTR   Reg
+    | BCTR    [Maybe BlockId] (Maybe CLabel) -- with list of local destinations, and jump table location if necessary
+    | BL      CLabel [Reg]          -- with list of argument regs
+    | BCTRL   [Reg]
+
+    | ADD     Reg Reg RI            -- dst, src1, src2
+    | ADDO    Reg Reg Reg           -- add and set overflow
+    | ADDC    Reg Reg Reg           -- (carrying) dst, src1, src2
+    | ADDE    Reg Reg Reg           -- (extended) dst, src1, src2
+    | ADDZE   Reg Reg               -- (to zero extended) dst, src
+    | ADDIS   Reg Reg Imm           -- Add Immediate Shifted dst, src1, src2
+    | SUBF    Reg Reg Reg           -- dst, src1, src2 ; dst = src2 - src1
+    | SUBFO   Reg Reg Reg           -- subtract from and set overflow
+    | SUBFC   Reg Reg RI            -- (carrying) dst, src1, src2 ;
+                                    -- dst = src2 - src1
+    | SUBFE   Reg Reg Reg           -- (extended) dst, src1, src2 ;
+                                    -- dst = src2 - src1
+    | MULL    Format Reg Reg RI
+    | MULLO   Format Reg Reg Reg    -- multiply and set overflow
+    | MFOV    Format Reg            -- move overflow bit (1|33) to register
+                                    -- pseudo-instruction; pretty printed as
+                                    -- mfxer dst
+                                    -- extr[w|d]i dst, dst, 1, [1|33]
+    | MULHU   Format Reg Reg Reg
+    | DIV     Format Bool Reg Reg Reg
+    | AND     Reg Reg RI            -- dst, src1, src2
+    | ANDC    Reg Reg Reg           -- AND with complement, dst = src1 & ~ src2
+    | NAND    Reg Reg Reg           -- dst, src1, src2
+    | OR      Reg Reg RI            -- dst, src1, src2
+    | ORIS    Reg Reg Imm           -- OR Immediate Shifted dst, src1, src2
+    | XOR     Reg Reg RI            -- dst, src1, src2
+    | XORIS   Reg Reg Imm           -- XOR Immediate Shifted dst, src1, src2
+
+    | EXTS    Format Reg Reg
+    | CNTLZ   Format Reg Reg
+
+    | NEG     Reg Reg
+    | NOT     Reg Reg
+
+    | SL      Format Reg Reg RI            -- shift left
+    | SR      Format Reg Reg RI            -- shift right
+    | SRA     Format Reg Reg RI            -- shift right arithmetic
+
+    | RLWINM  Reg Reg Int Int Int   -- Rotate Left Word Immediate then AND with Mask
+    | CLRLI   Format Reg Reg Int    -- clear left immediate (extended mnemonic)
+    | CLRRI   Format Reg Reg Int    -- clear right immediate (extended mnemonic)
+
+    | FADD    Format Reg Reg Reg
+    | FSUB    Format Reg Reg Reg
+    | FMUL    Format Reg Reg Reg
+    | FDIV    Format Reg Reg Reg
+    | FABS    Reg Reg               -- abs is the same for single and double
+    | FNEG    Reg Reg               -- negate is the same for single and double prec.
+
+    | FCMP    Reg Reg
+
+    | FCTIWZ  Reg Reg           -- convert to integer word
+    | FCTIDZ  Reg Reg           -- convert to integer double word
+    | FCFID   Reg Reg           -- convert from integer double word
+    | FRSP    Reg Reg           -- reduce to single precision
+                                -- (but destination is a FP register)
+
+    | CRNOR   Int Int Int       -- condition register nor
+    | MFCR    Reg               -- move from condition register
+
+    | MFLR    Reg               -- move from link register
+    | FETCHPC Reg               -- pseudo-instruction:
+                                -- bcl to next insn, mflr reg
+    | HWSYNC                    -- heavy weight sync
+    | ISYNC                     -- instruction synchronize
+    | LWSYNC                    -- memory barrier
+    | NOP                       -- no operation, PowerPC 64 bit
+                                -- needs this as place holder to
+                                -- reload TOC pointer
+
+-- | Get the registers that are being used by this instruction.
+-- regUsage doesn't need to do any trickery for jumps and such.
+-- Just state precisely the regs read and written by that insn.
+-- The consequences of control flow transfers, as far as register
+-- allocation goes, are taken care of by the register allocator.
+--
+ppc_regUsageOfInstr :: Platform -> Instr -> RegUsage
+ppc_regUsageOfInstr platform instr
+ = case instr of
+    LD      _ reg addr       -> usage (regAddr addr, [reg])
+    LDFAR   _ reg addr       -> usage (regAddr addr, [reg])
+    LDR     _ reg addr       -> usage (regAddr addr, [reg])
+    LA      _ reg addr       -> usage (regAddr addr, [reg])
+    ST      _ reg addr       -> usage (reg : regAddr addr, [])
+    STFAR   _ reg addr       -> usage (reg : regAddr addr, [])
+    STU     _ reg addr       -> usage (reg : regAddr addr, [])
+    STC     _ reg addr       -> usage (reg : regAddr addr, [])
+    LIS     reg _            -> usage ([], [reg])
+    LI      reg _            -> usage ([], [reg])
+    MR      reg1 reg2        -> usage ([reg2], [reg1])
+    CMP     _ reg ri         -> usage (reg : regRI ri,[])
+    CMPL    _ reg ri         -> usage (reg : regRI ri,[])
+    BCC     _ _ _            -> noUsage
+    BCCFAR  _ _ _            -> noUsage
+    MTCTR   reg              -> usage ([reg],[])
+    BCTR    _ _              -> noUsage
+    BL      _ params         -> usage (params, callClobberedRegs platform)
+    BCTRL   params           -> usage (params, callClobberedRegs platform)
+
+    ADD     reg1 reg2 ri     -> usage (reg2 : regRI ri, [reg1])
+    ADDO    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
+    ADDC    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
+    ADDE    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
+    ADDZE   reg1 reg2        -> usage ([reg2], [reg1])
+    ADDIS   reg1 reg2 _      -> usage ([reg2], [reg1])
+    SUBF    reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
+    SUBFO   reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
+    SUBFC   reg1 reg2 ri     -> usage (reg2 : regRI ri, [reg1])
+    SUBFE   reg1 reg2 reg3   -> usage ([reg2,reg3], [reg1])
+    MULL    _ reg1 reg2 ri   -> usage (reg2 : regRI ri, [reg1])
+    MULLO   _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
+    MFOV    _ reg            -> usage ([], [reg])
+    MULHU   _ reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
+    DIV     _ _ reg1 reg2 reg3
+                             -> usage ([reg2,reg3], [reg1])
+
+    AND     reg1 reg2 ri    -> usage (reg2 : regRI ri, [reg1])
+    ANDC    reg1 reg2 reg3  -> usage ([reg2,reg3], [reg1])
+    NAND    reg1 reg2 reg3  -> usage ([reg2,reg3], [reg1])
+    OR      reg1 reg2 ri    -> usage (reg2 : regRI ri, [reg1])
+    ORIS    reg1 reg2 _     -> usage ([reg2], [reg1])
+    XOR     reg1 reg2 ri    -> usage (reg2 : regRI ri, [reg1])
+    XORIS   reg1 reg2 _     -> usage ([reg2], [reg1])
+    EXTS    _  reg1 reg2    -> usage ([reg2], [reg1])
+    CNTLZ   _  reg1 reg2    -> usage ([reg2], [reg1])
+    NEG     reg1 reg2       -> usage ([reg2], [reg1])
+    NOT     reg1 reg2       -> usage ([reg2], [reg1])
+    SL      _ reg1 reg2 ri  -> usage (reg2 : regRI ri, [reg1])
+    SR      _ reg1 reg2 ri  -> usage (reg2 : regRI ri, [reg1])
+    SRA     _ reg1 reg2 ri  -> usage (reg2 : regRI ri, [reg1])
+    RLWINM  reg1 reg2 _ _ _ -> usage ([reg2], [reg1])
+    CLRLI   _ reg1 reg2 _   -> usage ([reg2], [reg1])
+    CLRRI   _ reg1 reg2 _   -> usage ([reg2], [reg1])
+
+    FADD    _ r1 r2 r3      -> usage ([r2,r3], [r1])
+    FSUB    _ r1 r2 r3      -> usage ([r2,r3], [r1])
+    FMUL    _ r1 r2 r3      -> usage ([r2,r3], [r1])
+    FDIV    _ r1 r2 r3      -> usage ([r2,r3], [r1])
+    FABS    r1 r2           -> usage ([r2], [r1])
+    FNEG    r1 r2           -> usage ([r2], [r1])
+    FCMP    r1 r2           -> usage ([r1,r2], [])
+    FCTIWZ  r1 r2           -> usage ([r2], [r1])
+    FCTIDZ  r1 r2           -> usage ([r2], [r1])
+    FCFID   r1 r2           -> usage ([r2], [r1])
+    FRSP    r1 r2           -> usage ([r2], [r1])
+    MFCR    reg             -> usage ([], [reg])
+    MFLR    reg             -> usage ([], [reg])
+    FETCHPC reg             -> usage ([], [reg])
+    _                       -> noUsage
+  where
+    usage (src, dst) = RU (filter (interesting platform) src)
+                          (filter (interesting platform) dst)
+    regAddr (AddrRegReg r1 r2) = [r1, r2]
+    regAddr (AddrRegImm r1 _)  = [r1]
+
+    regRI (RIReg r) = [r]
+    regRI  _        = []
+
+interesting :: Platform -> Reg -> Bool
+interesting _        (RegVirtual _)              = True
+interesting platform (RegReal (RealRegSingle i)) = freeReg platform i
+interesting _        (RegReal (RealRegPair{}))
+    = panic "PPC.Instr.interesting: no reg pairs on this arch"
+
+
+
+-- | Apply a given mapping to all the register references in this
+-- instruction.
+ppc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
+ppc_patchRegsOfInstr instr env
+ = case instr of
+    LD      fmt reg addr    -> LD fmt (env reg) (fixAddr addr)
+    LDFAR   fmt reg addr    -> LDFAR fmt (env reg) (fixAddr addr)
+    LDR     fmt reg addr    -> LDR fmt (env reg) (fixAddr addr)
+    LA      fmt reg addr    -> LA fmt (env reg) (fixAddr addr)
+    ST      fmt reg addr    -> ST fmt (env reg) (fixAddr addr)
+    STFAR   fmt reg addr    -> STFAR fmt (env reg) (fixAddr addr)
+    STU     fmt reg addr    -> STU fmt (env reg) (fixAddr addr)
+    STC     fmt reg addr    -> STC fmt (env reg) (fixAddr addr)
+    LIS     reg imm         -> LIS (env reg) imm
+    LI      reg imm         -> LI (env reg) imm
+    MR      reg1 reg2       -> MR (env reg1) (env reg2)
+    CMP     fmt reg ri      -> CMP fmt (env reg) (fixRI ri)
+    CMPL    fmt reg ri      -> CMPL fmt (env reg) (fixRI ri)
+    BCC     cond lbl p      -> BCC cond lbl p
+    BCCFAR  cond lbl p      -> BCCFAR cond lbl p
+    MTCTR   reg             -> MTCTR (env reg)
+    BCTR    targets lbl     -> BCTR targets lbl
+    BL      imm argRegs     -> BL imm argRegs    -- argument regs
+    BCTRL   argRegs         -> BCTRL argRegs     -- cannot be remapped
+    ADD     reg1 reg2 ri    -> ADD (env reg1) (env reg2) (fixRI ri)
+    ADDO    reg1 reg2 reg3  -> ADDO (env reg1) (env reg2) (env reg3)
+    ADDC    reg1 reg2 reg3  -> ADDC (env reg1) (env reg2) (env reg3)
+    ADDE    reg1 reg2 reg3  -> ADDE (env reg1) (env reg2) (env reg3)
+    ADDZE   reg1 reg2       -> ADDZE (env reg1) (env reg2)
+    ADDIS   reg1 reg2 imm   -> ADDIS (env reg1) (env reg2) imm
+    SUBF    reg1 reg2 reg3  -> SUBF (env reg1) (env reg2) (env reg3)
+    SUBFO   reg1 reg2 reg3  -> SUBFO (env reg1) (env reg2) (env reg3)
+    SUBFC   reg1 reg2 ri    -> SUBFC (env reg1) (env reg2) (fixRI ri)
+    SUBFE   reg1 reg2 reg3  -> SUBFE (env reg1) (env reg2) (env reg3)
+    MULL    fmt reg1 reg2 ri
+                            -> MULL fmt (env reg1) (env reg2) (fixRI ri)
+    MULLO   fmt reg1 reg2 reg3
+                            -> MULLO fmt (env reg1) (env reg2) (env reg3)
+    MFOV    fmt reg         -> MFOV fmt (env reg)
+    MULHU   fmt reg1 reg2 reg3
+                            -> MULHU fmt (env reg1) (env reg2) (env reg3)
+    DIV     fmt sgn reg1 reg2 reg3
+                            -> DIV fmt sgn (env reg1) (env reg2) (env reg3)
+
+    AND     reg1 reg2 ri    -> AND (env reg1) (env reg2) (fixRI ri)
+    ANDC    reg1 reg2 reg3  -> ANDC (env reg1) (env reg2) (env reg3)
+    NAND    reg1 reg2 reg3  -> NAND (env reg1) (env reg2) (env reg3)
+    OR      reg1 reg2 ri    -> OR  (env reg1) (env reg2) (fixRI ri)
+    ORIS    reg1 reg2 imm   -> ORIS (env reg1) (env reg2) imm
+    XOR     reg1 reg2 ri    -> XOR (env reg1) (env reg2) (fixRI ri)
+    XORIS   reg1 reg2 imm   -> XORIS (env reg1) (env reg2) imm
+    EXTS    fmt reg1 reg2   -> EXTS fmt (env reg1) (env reg2)
+    CNTLZ   fmt reg1 reg2   -> CNTLZ fmt (env reg1) (env reg2)
+    NEG     reg1 reg2       -> NEG (env reg1) (env reg2)
+    NOT     reg1 reg2       -> NOT (env reg1) (env reg2)
+    SL      fmt reg1 reg2 ri
+                            -> SL fmt (env reg1) (env reg2) (fixRI ri)
+    SR      fmt reg1 reg2 ri
+                            -> SR fmt (env reg1) (env reg2) (fixRI ri)
+    SRA     fmt reg1 reg2 ri
+                            -> SRA fmt (env reg1) (env reg2) (fixRI ri)
+    RLWINM  reg1 reg2 sh mb me
+                            -> RLWINM (env reg1) (env reg2) sh mb me
+    CLRLI   fmt reg1 reg2 n -> CLRLI fmt (env reg1) (env reg2) n
+    CLRRI   fmt reg1 reg2 n -> CLRRI fmt (env reg1) (env reg2) n
+    FADD    fmt r1 r2 r3    -> FADD fmt (env r1) (env r2) (env r3)
+    FSUB    fmt r1 r2 r3    -> FSUB fmt (env r1) (env r2) (env r3)
+    FMUL    fmt r1 r2 r3    -> FMUL fmt (env r1) (env r2) (env r3)
+    FDIV    fmt r1 r2 r3    -> FDIV fmt (env r1) (env r2) (env r3)
+    FABS    r1 r2           -> FABS (env r1) (env r2)
+    FNEG    r1 r2           -> FNEG (env r1) (env r2)
+    FCMP    r1 r2           -> FCMP (env r1) (env r2)
+    FCTIWZ  r1 r2           -> FCTIWZ (env r1) (env r2)
+    FCTIDZ  r1 r2           -> FCTIDZ (env r1) (env r2)
+    FCFID   r1 r2           -> FCFID (env r1) (env r2)
+    FRSP    r1 r2           -> FRSP (env r1) (env r2)
+    MFCR    reg             -> MFCR (env reg)
+    MFLR    reg             -> MFLR (env reg)
+    FETCHPC reg             -> FETCHPC (env reg)
+    _                       -> instr
+  where
+    fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
+    fixAddr (AddrRegImm r1 i)  = AddrRegImm (env r1) i
+
+    fixRI (RIReg r) = RIReg (env r)
+    fixRI other     = other
+
+
+--------------------------------------------------------------------------------
+-- | Checks whether this instruction is a jump/branch instruction.
+-- One that can change the flow of control in a way that the
+-- register allocator needs to worry about.
+ppc_isJumpishInstr :: Instr -> Bool
+ppc_isJumpishInstr instr
+ = case instr of
+    BCC{}       -> True
+    BCCFAR{}    -> True
+    BCTR{}      -> True
+    BCTRL{}     -> True
+    BL{}        -> True
+    JMP{}       -> True
+    _           -> False
+
+
+-- | Checks whether this instruction is a jump/branch instruction.
+-- One that can change the flow of control in a way that the
+-- register allocator needs to worry about.
+ppc_jumpDestsOfInstr :: Instr -> [BlockId]
+ppc_jumpDestsOfInstr insn
+  = case insn of
+        BCC _ id _      -> [id]
+        BCCFAR _ id _   -> [id]
+        BCTR targets _  -> [id | Just id <- targets]
+        _               -> []
+
+
+-- | Change the destination of this jump instruction.
+-- Used in the linear allocator when adding fixup blocks for join
+-- points.
+ppc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
+ppc_patchJumpInstr insn patchF
+  = case insn of
+        BCC cc id p     -> BCC cc (patchF id) p
+        BCCFAR cc id p  -> BCCFAR cc (patchF id) p
+        BCTR ids lbl    -> BCTR (map (fmap patchF) ids) lbl
+        _               -> insn
+
+
+-- -----------------------------------------------------------------------------
+
+-- | An instruction to spill a register into a spill slot.
+ppc_mkSpillInstr
+   :: DynFlags
+   -> Reg       -- register to spill
+   -> Int       -- current stack delta
+   -> Int       -- spill slot to use
+   -> Instr
+
+ppc_mkSpillInstr dflags reg delta slot
+  = let platform = targetPlatform dflags
+        off      = spillSlotToOffset dflags slot
+        arch     = platformArch platform
+    in
+    let fmt = case targetClassOfReg platform reg of
+                RcInteger -> case arch of
+                                ArchPPC -> II32
+                                _       -> II64
+                RcDouble  -> FF64
+                _         -> panic "PPC.Instr.mkSpillInstr: no match"
+        instr = case makeImmediate W32 True (off-delta) of
+                Just _  -> ST
+                Nothing -> STFAR -- pseudo instruction: 32 bit offsets
+
+    in instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))
+
+
+ppc_mkLoadInstr
+   :: DynFlags
+   -> Reg       -- register to load
+   -> Int       -- current stack delta
+   -> Int       -- spill slot to use
+   -> Instr
+
+ppc_mkLoadInstr dflags reg delta slot
+  = let platform = targetPlatform dflags
+        off      = spillSlotToOffset dflags slot
+        arch     = platformArch platform
+    in
+    let fmt = case targetClassOfReg platform reg of
+                RcInteger ->  case arch of
+                                 ArchPPC -> II32
+                                 _       -> II64
+                RcDouble  -> FF64
+                _         -> panic "PPC.Instr.mkLoadInstr: no match"
+        instr = case makeImmediate W32 True (off-delta) of
+                Just _  -> LD
+                Nothing -> LDFAR -- pseudo instruction: 32 bit offsets
+
+    in instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))
+
+
+-- | The size of a minimal stackframe header including minimal
+-- parameter save area.
+stackFrameHeaderSize :: DynFlags -> Int
+stackFrameHeaderSize dflags
+  = case platformOS platform of
+      OSAIX    -> 24 + 8 * 4
+      _ -> case platformArch platform of
+                             -- header + parameter save area
+             ArchPPC           -> 64 -- TODO: check ABI spec
+             ArchPPC_64 ELF_V1 -> 48 + 8 * 8
+             ArchPPC_64 ELF_V2 -> 32 + 8 * 8
+             _ -> panic "PPC.stackFrameHeaderSize: not defined for this OS"
+     where platform = targetPlatform dflags
+
+-- | The maximum number of bytes required to spill a register. PPC32
+-- has 32-bit GPRs and 64-bit FPRs, while PPC64 has 64-bit GPRs and
+-- 64-bit FPRs. So the maximum is 8 regardless of platforms unlike
+-- x86. Note that AltiVec's vector registers are 128-bit wide so we
+-- must not use this to spill them.
+spillSlotSize :: Int
+spillSlotSize = 8
+
+-- | The number of spill slots available without allocating more.
+maxSpillSlots :: DynFlags -> Int
+maxSpillSlots dflags
+    = ((rESERVED_C_STACK_BYTES dflags - stackFrameHeaderSize dflags)
+       `div` spillSlotSize) - 1
+--     = 0 -- useful for testing allocMoreStack
+
+-- | The number of bytes that the stack pointer should be aligned
+-- to. This is 16 both on PPC32 and PPC64 ELF (see ELF processor
+-- specific supplements).
+stackAlign :: Int
+stackAlign = 16
+
+-- | Convert a spill slot number to a *byte* offset, with no sign.
+spillSlotToOffset :: DynFlags -> Int -> Int
+spillSlotToOffset dflags slot
+   = stackFrameHeaderSize dflags + spillSlotSize * slot
+
+
+--------------------------------------------------------------------------------
+-- | See if this instruction is telling us the current C stack delta
+ppc_takeDeltaInstr
+    :: Instr
+    -> Maybe Int
+
+ppc_takeDeltaInstr instr
+ = case instr of
+     DELTA i  -> Just i
+     _        -> Nothing
+
+
+ppc_isMetaInstr
+    :: Instr
+    -> Bool
+
+ppc_isMetaInstr instr
+ = case instr of
+    COMMENT{}   -> True
+    LDATA{}     -> True
+    NEWBLOCK{}  -> True
+    DELTA{}     -> True
+    _           -> False
+
+
+-- | Copy the value in a register to another one.
+-- Must work for all register classes.
+ppc_mkRegRegMoveInstr
+    :: Reg
+    -> Reg
+    -> Instr
+
+ppc_mkRegRegMoveInstr src dst
+    = MR dst src
+
+
+-- | Make an unconditional jump instruction.
+ppc_mkJumpInstr
+    :: BlockId
+    -> [Instr]
+
+ppc_mkJumpInstr id
+    = [BCC ALWAYS id Nothing]
+
+
+-- | Take the source and destination from this reg -> reg move instruction
+-- or Nothing if it's not one
+ppc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)
+ppc_takeRegRegMoveInstr (MR dst src) = Just (src,dst)
+ppc_takeRegRegMoveInstr _  = Nothing
+
+-- -----------------------------------------------------------------------------
+-- Making far branches
+
+-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
+-- big, we have to work around this limitation.
+
+makeFarBranches
+        :: LabelMap CmmStatics
+        -> [NatBasicBlock Instr]
+        -> [NatBasicBlock Instr]
+makeFarBranches info_env blocks
+    | last blockAddresses < nearLimit = blocks
+    | otherwise = zipWith handleBlock blockAddresses blocks
+    where
+        blockAddresses = scanl (+) 0 $ map blockLen blocks
+        blockLen (BasicBlock _ instrs) = length instrs
+
+        handleBlock addr (BasicBlock id instrs)
+                = BasicBlock id (zipWith makeFar [addr..] instrs)
+
+        makeFar _ (BCC ALWAYS tgt _) = BCC ALWAYS tgt Nothing
+        makeFar addr (BCC cond tgt p)
+            | abs (addr - targetAddr) >= nearLimit
+            = BCCFAR cond tgt p
+            | otherwise
+            = BCC cond tgt p
+            where Just targetAddr = lookupUFM blockAddressMap tgt
+        makeFar _ other            = other
+
+        -- 8192 instructions are allowed; let's keep some distance, as
+        -- we have a few pseudo-insns that are pretty-printed as
+        -- multiple instructions, and it's just not worth the effort
+        -- to calculate things exactly
+        nearLimit = 7000 - mapSize info_env * maxRetInfoTableSizeW
+
+        blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -0,0 +1,990 @@
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing assembly language
+--
+-- (c) The University of Glasgow 1993-2005
+--
+-----------------------------------------------------------------------------
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module PPC.Ppr (pprNatCmmDecl) where
+
+import GhcPrelude
+
+import PPC.Regs
+import PPC.Instr
+import PPC.Cond
+import PprBase
+import Instruction
+import Format
+import Reg
+import RegClass
+import TargetReg
+
+import Cmm hiding (topInfoTable)
+import Hoopl.Collections
+import Hoopl.Label
+
+import BlockId
+import CLabel
+
+import Unique                ( pprUniqueAlways, getUnique )
+import Platform
+import FastString
+import Outputable
+import DynFlags
+
+import Data.Word
+import Data.Int
+import Data.Bits
+
+-- -----------------------------------------------------------------------------
+-- Printing this stuff out
+
+pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
+pprNatCmmDecl (CmmData section dats) =
+  pprSectionAlign section $$ pprDatas dats
+
+pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
+  case topInfoTable proc of
+    Nothing ->
+       sdocWithPlatform $ \platform ->
+       case blocks of
+         []     -> -- special case for split markers:
+           pprLabel lbl
+         blocks -> -- special case for code without info table:
+           pprSectionAlign (Section Text lbl) $$
+           (case platformArch platform of
+              ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl
+              ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl
+              _ -> pprLabel lbl) $$ -- blocks guaranteed not null,
+                                     -- so label needed
+           vcat (map (pprBasicBlock top_info) blocks)
+
+    Just (Statics info_lbl _) ->
+      sdocWithPlatform $ \platform ->
+      pprSectionAlign (Section Text info_lbl) $$
+      (if platformHasSubsectionsViaSymbols platform
+          then ppr (mkDeadStripPreventer info_lbl) <> char ':'
+          else empty) $$
+      vcat (map (pprBasicBlock top_info) blocks) $$
+      -- above: Even the first block gets a label, because with branch-chain
+      -- elimination, it might be the target of a goto.
+      (if platformHasSubsectionsViaSymbols platform
+       then
+       -- See Note [Subsections Via Symbols] in X86/Ppr.hs
+                text "\t.long "
+            <+> ppr info_lbl
+            <+> char '-'
+            <+> ppr (mkDeadStripPreventer info_lbl)
+       else empty)
+
+pprFunctionDescriptor :: CLabel -> SDoc
+pprFunctionDescriptor lab = pprGloblDecl lab
+                        $$  text "\t.section \".opd\", \"aw\""
+                        $$  text "\t.align 3"
+                        $$  ppr lab <> char ':'
+                        $$  text "\t.quad ."
+                        <>  ppr lab
+                        <>  text ",.TOC.@tocbase,0"
+                        $$  text "\t.previous"
+                        $$  text "\t.type"
+                        <+> ppr lab
+                        <>  text ", @function"
+                        $$  char '.' <> ppr lab <> char ':'
+
+pprFunctionPrologue :: CLabel ->SDoc
+pprFunctionPrologue lab =  pprGloblDecl lab
+                        $$  text ".type "
+                        <> ppr lab
+                        <> text ", @function"
+                        $$ ppr lab <> char ':'
+                        $$ text "0:\taddis\t" <> pprReg toc
+                        <> text ",12,.TOC.-0b@ha"
+                        $$ text "\taddi\t" <> pprReg toc
+                        <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"
+                        $$ text "\t.localentry\t" <> ppr lab
+                        <> text ",.-" <> ppr lab
+
+pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc
+pprBasicBlock info_env (BasicBlock blockid instrs)
+  = maybe_infotable $$
+    pprLabel (blockLbl blockid) $$
+    vcat (map pprInstr instrs)
+  where
+    maybe_infotable = case mapLookup blockid info_env of
+       Nothing   -> empty
+       Just (Statics info_lbl info) ->
+           pprAlignForSection Text $$
+           vcat (map pprData info) $$
+           pprLabel info_lbl
+
+
+
+pprDatas :: CmmStatics -> SDoc
+pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)
+
+pprData :: CmmStatic -> SDoc
+pprData (CmmString str)
+  = text "\t.string" <+> doubleQuotes (pprASCII str)
+pprData (CmmUninitialised bytes) = text ".space " <> int bytes
+pprData (CmmStaticLit lit)       = pprDataItem lit
+
+pprGloblDecl :: CLabel -> SDoc
+pprGloblDecl lbl
+  | not (externallyVisibleCLabel lbl) = empty
+  | otherwise = text ".globl " <> ppr lbl
+
+pprTypeAndSizeDecl :: CLabel -> SDoc
+pprTypeAndSizeDecl lbl
+  = sdocWithPlatform $ \platform ->
+    if platformOS platform == OSLinux && externallyVisibleCLabel lbl
+    then text ".type " <>
+         ppr lbl <> text ", @object"
+    else empty
+
+pprLabel :: CLabel -> SDoc
+pprLabel lbl = pprGloblDecl lbl
+            $$ pprTypeAndSizeDecl lbl
+            $$ (ppr lbl <> char ':')
+
+-- -----------------------------------------------------------------------------
+-- pprInstr: print an 'Instr'
+
+instance Outputable Instr where
+    ppr instr = pprInstr instr
+
+
+pprReg :: Reg -> SDoc
+
+pprReg r
+  = case r of
+      RegReal    (RealRegSingle i) -> ppr_reg_no i
+      RegReal    (RealRegPair{})   -> panic "PPC.pprReg: no reg pairs on this arch"
+      RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u
+      RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u
+      RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u
+      RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u
+      RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUniqueAlways u
+  where
+    ppr_reg_no :: Int -> SDoc
+    ppr_reg_no i
+         | i <= 31   = int i      -- GPRs
+         | i <= 63   = int (i-32) -- FPRs
+         | otherwise = text "very naughty powerpc register"
+
+
+
+pprFormat :: Format -> SDoc
+pprFormat x
+ = ptext (case x of
+                II8  -> sLit "b"
+                II16 -> sLit "h"
+                II32 -> sLit "w"
+                II64 -> sLit "d"
+                FF32 -> sLit "fs"
+                FF64 -> sLit "fd"
+                _    -> panic "PPC.Ppr.pprFormat: no match")
+
+
+pprCond :: Cond -> SDoc
+pprCond c
+ = ptext (case c of {
+                ALWAYS  -> sLit "";
+                EQQ     -> sLit "eq";  NE    -> sLit "ne";
+                LTT     -> sLit "lt";  GE    -> sLit "ge";
+                GTT     -> sLit "gt";  LE    -> sLit "le";
+                LU      -> sLit "lt";  GEU   -> sLit "ge";
+                GU      -> sLit "gt";  LEU   -> sLit "le"; })
+
+
+pprImm :: Imm -> SDoc
+
+pprImm (ImmInt i)     = int i
+pprImm (ImmInteger i) = integer i
+pprImm (ImmCLbl l)    = ppr l
+pprImm (ImmIndex l i) = ppr l <> char '+' <> int i
+pprImm (ImmLit s)     = s
+
+pprImm (ImmFloat _)  = text "naughty float immediate"
+pprImm (ImmDouble _) = text "naughty double immediate"
+
+pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
+pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
+                   <> lparen <> pprImm b <> rparen
+
+pprImm (LO (ImmInt i))     = pprImm (LO (ImmInteger (toInteger i)))
+pprImm (LO (ImmInteger i)) = pprImm (ImmInteger (toInteger lo16))
+  where
+    lo16 = fromInteger (i .&. 0xffff) :: Int16
+
+pprImm (LO i)
+  = pprImm i <> text "@l"
+
+pprImm (HI i)
+  = pprImm i <> text "@h"
+
+pprImm (HA (ImmInt i))     = pprImm (HA (ImmInteger (toInteger i)))
+pprImm (HA (ImmInteger i)) = pprImm (ImmInteger ha16)
+  where
+    ha16 = if lo16 >= 0x8000 then hi16+1 else hi16
+    hi16 = (i `shiftR` 16)
+    lo16 = i .&. 0xffff
+
+pprImm (HA i)
+  = pprImm i <> text "@ha"
+
+pprImm (HIGHERA i)
+  = pprImm i <> text "@highera"
+
+pprImm (HIGHESTA i)
+  = pprImm i <> text "@highesta"
+
+
+pprAddr :: AddrMode -> SDoc
+pprAddr (AddrRegReg r1 r2)
+  = pprReg r1 <> char ',' <+> pprReg r2
+pprAddr (AddrRegImm r1 (ImmInt i))
+  = hcat [ int i, char '(', pprReg r1, char ')' ]
+pprAddr (AddrRegImm r1 (ImmInteger i))
+  = hcat [ integer i, char '(', pprReg r1, char ')' ]
+pprAddr (AddrRegImm r1 imm)
+  = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]
+
+
+pprSectionAlign :: Section -> SDoc
+pprSectionAlign sec@(Section seg _) =
+ sdocWithPlatform $ \platform ->
+   pprSectionHeader platform sec $$
+   pprAlignForSection seg
+
+-- | Print appropriate alignment for the given section type.
+pprAlignForSection :: SectionType -> SDoc
+pprAlignForSection seg =
+ sdocWithPlatform $ \platform ->
+ let ppc64    = not $ target32Bit platform
+ in ptext $ case seg of
+       Text              -> sLit ".align 2"
+       Data
+        | ppc64          -> sLit ".align 3"
+        | otherwise      -> sLit ".align 2"
+       ReadOnlyData
+        | ppc64          -> sLit ".align 3"
+        | otherwise      -> sLit ".align 2"
+       RelocatableReadOnlyData
+        | ppc64          -> sLit ".align 3"
+        | otherwise      -> sLit ".align 2"
+       UninitialisedData
+        | ppc64          -> sLit ".align 3"
+        | otherwise      -> sLit ".align 2"
+       ReadOnlyData16    -> sLit ".align 4"
+       -- TODO: This is copied from the ReadOnlyData case, but it can likely be
+       -- made more efficient.
+       CString
+        | ppc64          -> sLit ".align 3"
+        | otherwise      -> sLit ".align 2"
+       OtherSection _    -> panic "PprMach.pprSectionAlign: unknown section"
+
+pprDataItem :: CmmLit -> SDoc
+pprDataItem lit
+  = sdocWithDynFlags $ \dflags ->
+    vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit dflags)
+    where
+        imm = litToImm lit
+        archPPC_64 dflags = not $ target32Bit $ targetPlatform dflags
+
+        ppr_item II8   _ _ = [text "\t.byte\t" <> pprImm imm]
+
+        ppr_item II32  _ _ = [text "\t.long\t" <> pprImm imm]
+
+        ppr_item II64 _ dflags
+           | archPPC_64 dflags = [text "\t.quad\t" <> pprImm imm]
+
+
+        ppr_item FF32 (CmmFloat r _) _
+           = let bs = floatToBytes (fromRational r)
+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+
+        ppr_item FF64 (CmmFloat r _) _
+           = let bs = doubleToBytes (fromRational r)
+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+
+        ppr_item II16 _ _      = [text "\t.short\t" <> pprImm imm]
+
+        ppr_item II64 (CmmInt x _) dflags
+           | not(archPPC_64 dflags) =
+                [text "\t.long\t"
+                    <> int (fromIntegral
+                        (fromIntegral (x `shiftR` 32) :: Word32)),
+                 text "\t.long\t"
+                    <> int (fromIntegral (fromIntegral x :: Word32))]
+
+        ppr_item _ _ _
+                = panic "PPC.Ppr.pprDataItem: no match"
+
+
+pprInstr :: Instr -> SDoc
+
+pprInstr (COMMENT _) = empty -- nuke 'em
+{-
+pprInstr (COMMENT s) =
+     if platformOS platform == OSLinux
+     then text "# " <> ftext s
+     else text "; " <> ftext s
+-}
+pprInstr (DELTA d)
+   = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
+
+pprInstr (NEWBLOCK _)
+   = panic "PprMach.pprInstr: NEWBLOCK"
+
+pprInstr (LDATA _ _)
+   = panic "PprMach.pprInstr: LDATA"
+
+{-
+pprInstr (SPILL reg slot)
+   = hcat [
+           text "\tSPILL",
+        char '\t',
+        pprReg reg,
+        comma,
+        text "SLOT" <> parens (int slot)]
+
+pprInstr (RELOAD slot reg)
+   = hcat [
+           text "\tRELOAD",
+        char '\t',
+        text "SLOT" <> parens (int slot),
+        comma,
+        pprReg reg]
+-}
+
+pprInstr (LD fmt reg addr) = hcat [
+        char '\t',
+        text "l",
+        ptext (case fmt of
+            II8  -> sLit "bz"
+            II16 -> sLit "hz"
+            II32 -> sLit "wz"
+            II64 -> sLit "d"
+            FF32 -> sLit "fs"
+            FF64 -> sLit "fd"
+            _         -> panic "PPC.Ppr.pprInstr: no match"
+            ),
+        case addr of AddrRegImm _ _ -> empty
+                     AddrRegReg _ _ -> char 'x',
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprAddr addr
+    ]
+
+pprInstr (LDFAR fmt reg (AddrRegImm source off)) =
+   sdocWithPlatform $ \platform -> vcat [
+         pprInstr (ADDIS (tmpReg platform) source (HA off)),
+         pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off)))
+    ]
+pprInstr (LDFAR _ _ _) =
+   panic "PPC.Ppr.pprInstr LDFAR: no match"
+
+pprInstr (LDR fmt reg1 addr) = hcat [
+  text "\tl",
+  case fmt of
+    II32 -> char 'w'
+    II64 -> char 'd'
+    _    -> panic "PPC.Ppr.Instr LDR: no match",
+  text "arx\t",
+  pprReg reg1,
+  text ", ",
+  pprAddr addr
+  ]
+
+pprInstr (LA fmt reg addr) = hcat [
+        char '\t',
+        text "l",
+        ptext (case fmt of
+            II8  -> sLit "ba"
+            II16 -> sLit "ha"
+            II32 -> sLit "wa"
+            II64 -> sLit "d"
+            FF32 -> sLit "fs"
+            FF64 -> sLit "fd"
+            _         -> panic "PPC.Ppr.pprInstr: no match"
+            ),
+        case addr of AddrRegImm _ _ -> empty
+                     AddrRegReg _ _ -> char 'x',
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprAddr addr
+    ]
+pprInstr (ST fmt reg addr) = hcat [
+        char '\t',
+        text "st",
+        pprFormat fmt,
+        case addr of AddrRegImm _ _ -> empty
+                     AddrRegReg _ _ -> char 'x',
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprAddr addr
+    ]
+pprInstr (STFAR fmt reg (AddrRegImm source off)) =
+   sdocWithPlatform $ \platform -> vcat [
+         pprInstr (ADDIS (tmpReg platform) source (HA off)),
+         pprInstr (ST fmt reg (AddrRegImm (tmpReg platform) (LO off)))
+    ]
+pprInstr (STFAR _ _ _) =
+   panic "PPC.Ppr.pprInstr STFAR: no match"
+pprInstr (STU fmt reg addr) = hcat [
+        char '\t',
+        text "st",
+        pprFormat fmt,
+        char 'u',
+        case addr of AddrRegImm _ _ -> empty
+                     AddrRegReg _ _ -> char 'x',
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprAddr addr
+    ]
+pprInstr (STC fmt reg1 addr) = hcat [
+  text "\tst",
+  case fmt of
+    II32 -> char 'w'
+    II64 -> char 'd'
+    _    -> panic "PPC.Ppr.Instr STC: no match",
+  text "cx.\t",
+  pprReg reg1,
+  text ", ",
+  pprAddr addr
+  ]
+pprInstr (LIS reg imm) = hcat [
+        char '\t',
+        text "lis",
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprImm imm
+    ]
+pprInstr (LI reg imm) = hcat [
+        char '\t',
+        text "li",
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprImm imm
+    ]
+pprInstr (MR reg1 reg2)
+    | reg1 == reg2 = empty
+    | otherwise = hcat [
+        char '\t',
+        sdocWithPlatform $ \platform ->
+        case targetClassOfReg platform reg1 of
+            RcInteger -> text "mr"
+            _ -> text "fmr",
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2
+    ]
+pprInstr (CMP fmt reg ri) = hcat [
+        char '\t',
+        op,
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprRI ri
+    ]
+    where
+        op = hcat [
+                text "cmp",
+                pprFormat fmt,
+                case ri of
+                    RIReg _ -> empty
+                    RIImm _ -> char 'i'
+            ]
+pprInstr (CMPL fmt reg ri) = hcat [
+        char '\t',
+        op,
+        char '\t',
+        pprReg reg,
+        text ", ",
+        pprRI ri
+    ]
+    where
+        op = hcat [
+                text "cmpl",
+                pprFormat fmt,
+                case ri of
+                    RIReg _ -> empty
+                    RIImm _ -> char 'i'
+            ]
+pprInstr (BCC cond blockid prediction) = hcat [
+        char '\t',
+        text "b",
+        pprCond cond,
+        pprPrediction prediction,
+        char '\t',
+        ppr lbl
+    ]
+    where lbl = mkLocalBlockLabel (getUnique blockid)
+          pprPrediction p = case p of
+            Nothing    -> empty
+            Just True  -> char '+'
+            Just False -> char '-'
+
+pprInstr (BCCFAR cond blockid prediction) = vcat [
+        hcat [
+            text "\tb",
+            pprCond (condNegate cond),
+            neg_prediction,
+            text "\t$+8"
+        ],
+        hcat [
+            text "\tb\t",
+            ppr lbl
+        ]
+    ]
+    where lbl = mkLocalBlockLabel (getUnique blockid)
+          neg_prediction = case prediction of
+            Nothing    -> empty
+            Just True  -> char '-'
+            Just False -> char '+'
+
+pprInstr (JMP lbl)
+  -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL"
+  | isForeignLabel lbl = panic "PPC.Ppr.pprInstr: JMP to ForeignLabel"
+  | otherwise =
+    hcat [ -- an alias for b that takes a CLabel
+        char '\t',
+        text "b",
+        char '\t',
+        ppr lbl
+    ]
+
+pprInstr (MTCTR reg) = hcat [
+        char '\t',
+        text "mtctr",
+        char '\t',
+        pprReg reg
+    ]
+pprInstr (BCTR _ _) = hcat [
+        char '\t',
+        text "bctr"
+    ]
+pprInstr (BL lbl _) = do
+    sdocWithPlatform $ \platform -> case platformOS platform of
+        OSAIX ->
+          -- On AIX, "printf" denotes a function-descriptor (for use
+          -- by function pointers), whereas the actual entry-code
+          -- address is denoted by the dot-prefixed ".printf" label.
+          -- Moreover, the PPC NCG only ever emits a BL instruction
+          -- for calling C ABI functions. Most of the time these calls
+          -- originate from FFI imports and have a 'ForeignLabel',
+          -- but when profiling the codegen inserts calls via
+          -- 'emitRtsCallGen' which are 'CmmLabel's even though
+          -- they'd technically be more like 'ForeignLabel's.
+          hcat [
+            text "\tbl\t.",
+            ppr lbl
+          ]
+        _ ->
+          hcat [
+            text "\tbl\t",
+            ppr lbl
+          ]
+pprInstr (BCTRL _) = hcat [
+        char '\t',
+        text "bctrl"
+    ]
+pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri
+pprInstr (ADDIS reg1 reg2 imm) = hcat [
+        char '\t',
+        text "addis",
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprImm imm
+    ]
+
+pprInstr (ADDO reg1 reg2 reg3) = pprLogic (sLit "addo") reg1 reg2 (RIReg reg3)
+pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)
+pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)
+pprInstr (ADDZE reg1 reg2) = pprUnary (sLit "addze") reg1 reg2
+pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)
+pprInstr (SUBFO reg1 reg2 reg3) = pprLogic (sLit "subfo") reg1 reg2 (RIReg reg3)
+pprInstr (SUBFC reg1 reg2 ri) = hcat [
+        char '\t',
+        text "subf",
+        case ri of
+            RIReg _ -> empty
+            RIImm _ -> char 'i',
+        text "c\t",
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprRI ri
+    ]
+pprInstr (SUBFE reg1 reg2 reg3) = pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3)
+pprInstr (MULL fmt reg1 reg2 ri) = pprMul fmt reg1 reg2 ri
+pprInstr (MULLO fmt reg1 reg2 reg3) = hcat [
+        char '\t',
+        text "mull",
+        case fmt of
+          II32 -> char 'w'
+          II64 -> char 'd'
+          _    -> panic "PPC: illegal format",
+        text "o\t",
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprReg reg3
+    ]
+pprInstr (MFOV fmt reg) = vcat [
+        hcat [
+            char '\t',
+            text "mfxer",
+            char '\t',
+            pprReg reg
+            ],
+        hcat [
+            char '\t',
+            text "extr",
+            case fmt of
+              II32 -> char 'w'
+              II64 -> char 'd'
+              _    -> panic "PPC: illegal format",
+            text "i\t",
+            pprReg reg,
+            text ", ",
+            pprReg reg,
+            text ", 1, ",
+            case fmt of
+              II32 -> text "1"
+              II64 -> text "33"
+              _    -> panic "PPC: illegal format"
+            ]
+        ]
+
+pprInstr (MULHU fmt reg1 reg2 reg3) = hcat [
+        char '\t',
+        text "mulh",
+        case fmt of
+          II32 -> char 'w'
+          II64 -> char 'd'
+          _    -> panic "PPC: illegal format",
+        text "u\t",
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprReg reg3
+    ]
+
+pprInstr (DIV fmt sgn reg1 reg2 reg3) = pprDiv fmt sgn reg1 reg2 reg3
+
+        -- for some reason, "andi" doesn't exist.
+        -- we'll use "andi." instead.
+pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [
+        char '\t',
+        text "andi.",
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprImm imm
+    ]
+pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri
+pprInstr (ANDC reg1 reg2 reg3) = pprLogic (sLit "andc") reg1 reg2 (RIReg reg3)
+pprInstr (NAND reg1 reg2 reg3) = pprLogic (sLit "nand") reg1 reg2 (RIReg reg3)
+
+pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri
+pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri
+
+pprInstr (ORIS reg1 reg2 imm) = hcat [
+        char '\t',
+        text "oris",
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprImm imm
+    ]
+
+pprInstr (XORIS reg1 reg2 imm) = hcat [
+        char '\t',
+        text "xoris",
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprImm imm
+    ]
+
+pprInstr (EXTS fmt reg1 reg2) = hcat [
+        char '\t',
+        text "exts",
+        pprFormat fmt,
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2
+    ]
+pprInstr (CNTLZ fmt reg1 reg2) = hcat [
+        char '\t',
+        text "cntlz",
+        case fmt of
+          II32 -> char 'w'
+          II64 -> char 'd'
+          _    -> panic "PPC: illegal format",
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2
+    ]
+
+pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
+pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
+
+pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0  || i > 31 =
+    -- Handle the case where we are asked to shift a 32 bit register by
+    -- less than zero or more than 31 bits. We convert this into a clear
+    -- of the destination register.
+    -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/5900
+    pprInstr (XOR reg1 reg2 (RIReg reg2))
+
+pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0  || i > 31 =
+    -- As above for SR, but for left shifts.
+    -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/10870
+    pprInstr (XOR reg1 reg2 (RIReg reg2))
+
+pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 =
+    -- PT: I don't know what to do for negative shift amounts:
+    -- For now just panic.
+    --
+    -- For shift amounts greater than 31 set all bit to the
+    -- value of the sign bit, this also what sraw does.
+    pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt 31)))
+
+pprInstr (SL fmt reg1 reg2 ri) =
+         let op = case fmt of
+                       II32 -> "slw"
+                       II64 -> "sld"
+                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"
+         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
+
+pprInstr (SR fmt reg1 reg2 ri) =
+         let op = case fmt of
+                       II32 -> "srw"
+                       II64 -> "srd"
+                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"
+         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
+
+pprInstr (SRA fmt reg1 reg2 ri) =
+         let op = case fmt of
+                       II32 -> "sraw"
+                       II64 -> "srad"
+                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"
+         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
+
+pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
+        text "\trlwinm\t",
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        int sh,
+        text ", ",
+        int mb,
+        text ", ",
+        int me
+    ]
+
+pprInstr (CLRLI fmt reg1 reg2 n) = hcat [
+        text "\tclrl",
+        pprFormat fmt,
+        text "i ",
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        int n
+    ]
+pprInstr (CLRRI fmt reg1 reg2 n) = hcat [
+        text "\tclrr",
+        pprFormat fmt,
+        text "i ",
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        int n
+    ]
+
+pprInstr (FADD fmt reg1 reg2 reg3) = pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3
+pprInstr (FSUB fmt reg1 reg2 reg3) = pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3
+pprInstr (FMUL fmt reg1 reg2 reg3) = pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3
+pprInstr (FDIV fmt reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3
+pprInstr (FABS reg1 reg2) = pprUnary (sLit "fabs") reg1 reg2
+pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2
+
+pprInstr (FCMP reg1 reg2) = hcat [
+        char '\t',
+        text "fcmpu\t0, ",
+            -- Note: we're using fcmpu, not fcmpo
+            -- The difference is with fcmpo, compare with NaN is an invalid operation.
+            -- We don't handle invalid fp ops, so we don't care.
+            -- Morever, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for
+            -- better portability since some non-GNU assembler (such as
+            -- IBM's `as`) tend not to support the symbolic register name cr0.
+            -- This matches the syntax that GCC seems to emit for PPC targets.
+        pprReg reg1,
+        text ", ",
+        pprReg reg2
+    ]
+
+pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2
+pprInstr (FCTIDZ reg1 reg2) = pprUnary (sLit "fctidz") reg1 reg2
+pprInstr (FCFID reg1 reg2) = pprUnary (sLit "fcfid") reg1 reg2
+pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2
+
+pprInstr (CRNOR dst src1 src2) = hcat [
+        text "\tcrnor\t",
+        int dst,
+        text ", ",
+        int src1,
+        text ", ",
+        int src2
+    ]
+
+pprInstr (MFCR reg) = hcat [
+        char '\t',
+        text "mfcr",
+        char '\t',
+        pprReg reg
+    ]
+
+pprInstr (MFLR reg) = hcat [
+        char '\t',
+        text "mflr",
+        char '\t',
+        pprReg reg
+    ]
+
+pprInstr (FETCHPC reg) = vcat [
+        text "\tbcl\t20,31,1f",
+        hcat [ text "1:\tmflr\t", pprReg reg ]
+    ]
+
+pprInstr HWSYNC = text "\tsync"
+
+pprInstr ISYNC  = text "\tisync"
+
+pprInstr LWSYNC = text "\tlwsync"
+
+pprInstr NOP = text "\tnop"
+
+
+pprLogic :: PtrString -> Reg -> Reg -> RI -> SDoc
+pprLogic op reg1 reg2 ri = hcat [
+        char '\t',
+        ptext op,
+        case ri of
+            RIReg _ -> empty
+            RIImm _ -> char 'i',
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprRI ri
+    ]
+
+
+pprMul :: Format -> Reg -> Reg -> RI -> SDoc
+pprMul fmt reg1 reg2 ri = hcat [
+        char '\t',
+        text "mull",
+        case ri of
+            RIReg _ -> case fmt of
+              II32 -> char 'w'
+              II64 -> char 'd'
+              _    -> panic "PPC: illegal format"
+            RIImm _ -> char 'i',
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprRI ri
+    ]
+
+
+pprDiv :: Format -> Bool -> Reg -> Reg -> Reg -> SDoc
+pprDiv fmt sgn reg1 reg2 reg3 = hcat [
+        char '\t',
+        text "div",
+        case fmt of
+          II32 -> char 'w'
+          II64 -> char 'd'
+          _    -> panic "PPC: illegal format",
+        if sgn then empty else char 'u',
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprReg reg3
+    ]
+
+
+pprUnary :: PtrString -> Reg -> Reg -> SDoc
+pprUnary op reg1 reg2 = hcat [
+        char '\t',
+        ptext op,
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2
+    ]
+
+
+pprBinaryF :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc
+pprBinaryF op fmt reg1 reg2 reg3 = hcat [
+        char '\t',
+        ptext op,
+        pprFFormat fmt,
+        char '\t',
+        pprReg reg1,
+        text ", ",
+        pprReg reg2,
+        text ", ",
+        pprReg reg3
+    ]
+
+pprRI :: RI -> SDoc
+pprRI (RIReg r) = pprReg r
+pprRI (RIImm r) = pprImm r
+
+
+pprFFormat :: Format -> SDoc
+pprFFormat FF64     = empty
+pprFFormat FF32     = char 's'
+pprFFormat _        = panic "PPC.Ppr.pprFFormat: no match"
+
+    -- limit immediate argument for shift instruction to range 0..63
+    -- for 64 bit size and 0..32 otherwise
+limitShiftRI :: Format -> RI -> RI
+limitShiftRI II64 (RIImm (ImmInt i)) | i > 63 || i < 0 =
+  panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed."
+limitShiftRI II32 (RIImm (ImmInt i)) | i > 31 || i < 0 =
+  panic $ "PPC.Ppr: 32 bit: Shift by " ++ show i ++ " bits is not allowed."
+limitShiftRI _ x = x
diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PPC/RegInfo.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Machine-specific parts of the register allocator
+--
+-- (c) The University of Glasgow 1996-2004
+--
+-----------------------------------------------------------------------------
+module PPC.RegInfo (
+        JumpDest( DestBlockId ), getJumpDestBlockId,
+        canShortcut,
+        shortcutJump,
+
+        shortcutStatics
+)
+
+where
+
+#include "nativeGen/NCG.h"
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import PPC.Instr
+
+import BlockId
+import Cmm
+import CLabel
+
+import Unique
+import Outputable (ppr, text, Outputable, (<>))
+
+data JumpDest = DestBlockId BlockId
+
+-- Debug Instance
+instance Outputable JumpDest where
+  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid
+
+getJumpDestBlockId :: JumpDest -> Maybe BlockId
+getJumpDestBlockId (DestBlockId bid) = Just bid
+
+canShortcut :: Instr -> Maybe JumpDest
+canShortcut _ = Nothing
+
+shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
+shortcutJump _ other = other
+
+
+-- Here because it knows about JumpDest
+shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics
+shortcutStatics fn (Statics lbl statics)
+  = Statics lbl $ map (shortcutStatic fn) statics
+  -- we need to get the jump tables, so apply the mapping to the entries
+  -- of a CmmData too.
+
+shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
+shortcutLabel fn lab
+  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId
+  | otherwise                              = lab
+
+shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
+shortcutStatic fn (CmmStaticLit (CmmLabel lab))
+  = CmmStaticLit (CmmLabel (shortcutLabel fn lab))
+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w))
+  = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w)
+        -- slightly dodgy, we're ignoring the second label, but this
+        -- works with the way we use CmmLabelDiffOff for jump tables now.
+shortcutStatic _ other_static
+        = other_static
+
+shortBlockId
+        :: (BlockId -> Maybe JumpDest)
+        -> BlockId
+        -> CLabel
+
+shortBlockId fn blockid =
+   case fn blockid of
+      Nothing -> mkLocalBlockLabel uq
+      Just (DestBlockId blockid')  -> shortBlockId fn blockid'
+   where uq = getUnique blockid
diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PPC/Regs.hs
@@ -0,0 +1,338 @@
+{-# LANGUAGE CPP #-}
+
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 1994-2004
+--
+-- -----------------------------------------------------------------------------
+
+module PPC.Regs (
+        -- squeeze functions
+        virtualRegSqueeze,
+        realRegSqueeze,
+
+        mkVirtualReg,
+        regDotColor,
+
+        -- immediates
+        Imm(..),
+        strImmLit,
+        litToImm,
+
+        -- addressing modes
+        AddrMode(..),
+        addrOffset,
+
+        -- registers
+        spRel,
+        argRegs,
+        allArgRegs,
+        callClobberedRegs,
+        allMachRegNos,
+        classOfRealReg,
+        showReg,
+
+        -- machine specific
+        allFPArgRegs,
+        fits16Bits,
+        makeImmediate,
+        fReg,
+        r0, sp, toc, r3, r4, r11, r12, r27, r28, r30,
+        tmpReg,
+        f1, f20, f21,
+
+        allocatableRegs
+
+)
+
+where
+
+#include "nativeGen/NCG.h"
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Reg
+import RegClass
+import Format
+
+import Cmm
+import CLabel           ( CLabel )
+import Unique
+
+import CodeGen.Platform
+import DynFlags
+import Outputable
+import Platform
+
+import Data.Word        ( Word8, Word16, Word32, Word64 )
+import Data.Int         ( Int8, Int16, Int32, Int64 )
+
+
+-- squeese functions for the graph allocator -----------------------------------
+
+-- | regSqueeze_class reg
+--      Calculate the maximum number of register colors that could be
+--      denied to a node of this class due to having this reg
+--      as a neighbour.
+--
+{-# INLINE virtualRegSqueeze #-}
+virtualRegSqueeze :: RegClass -> VirtualReg -> Int
+virtualRegSqueeze cls vr
+ = case cls of
+        RcInteger
+         -> case vr of
+                VirtualRegI{}           -> 1
+                VirtualRegHi{}          -> 1
+                _other                  -> 0
+
+        RcDouble
+         -> case vr of
+                VirtualRegD{}           -> 1
+                VirtualRegF{}           -> 0
+                _other                  -> 0
+
+        _other -> 0
+
+{-# INLINE realRegSqueeze #-}
+realRegSqueeze :: RegClass -> RealReg -> Int
+realRegSqueeze cls rr
+ = case cls of
+        RcInteger
+         -> case rr of
+                RealRegSingle regNo
+                        | regNo < 32    -> 1     -- first fp reg is 32
+                        | otherwise     -> 0
+
+                RealRegPair{}           -> 0
+
+        RcDouble
+         -> case rr of
+                RealRegSingle regNo
+                        | regNo < 32    -> 0
+                        | otherwise     -> 1
+
+                RealRegPair{}           -> 0
+
+        _other -> 0
+
+mkVirtualReg :: Unique -> Format -> VirtualReg
+mkVirtualReg u format
+   | not (isFloatFormat format) = VirtualRegI u
+   | otherwise
+   = case format of
+        FF32    -> VirtualRegD u
+        FF64    -> VirtualRegD u
+        _       -> panic "mkVirtualReg"
+
+regDotColor :: RealReg -> SDoc
+regDotColor reg
+ = case classOfRealReg reg of
+        RcInteger       -> text "blue"
+        RcFloat         -> text "red"
+        RcDouble        -> text "green"
+        RcDoubleSSE     -> text "yellow"
+
+
+-- immediates ------------------------------------------------------------------
+data Imm
+        = ImmInt        Int
+        | ImmInteger    Integer     -- Sigh.
+        | ImmCLbl       CLabel      -- AbstractC Label (with baggage)
+        | ImmLit        SDoc        -- Simple string
+        | ImmIndex    CLabel Int
+        | ImmFloat      Rational
+        | ImmDouble     Rational
+        | ImmConstantSum Imm Imm
+        | ImmConstantDiff Imm Imm
+        | LO Imm
+        | HI Imm
+        | HA Imm        {- high halfword adjusted -}
+        | HIGHERA Imm
+        | HIGHESTA Imm
+
+
+strImmLit :: String -> Imm
+strImmLit s = ImmLit (text s)
+
+
+litToImm :: CmmLit -> Imm
+litToImm (CmmInt i w)        = ImmInteger (narrowS w i)
+                -- narrow to the width: a CmmInt might be out of
+                -- range, but we assume that ImmInteger only contains
+                -- in-range values.  A signed value should be fine here.
+litToImm (CmmFloat f W32)    = ImmFloat f
+litToImm (CmmFloat f W64)    = ImmDouble f
+litToImm (CmmLabel l)        = ImmCLbl l
+litToImm (CmmLabelOff l off) = ImmIndex l off
+litToImm (CmmLabelDiffOff l1 l2 off _)
+                             = ImmConstantSum
+                               (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
+                               (ImmInt off)
+litToImm _                   = panic "PPC.Regs.litToImm: no match"
+
+
+-- addressing modes ------------------------------------------------------------
+
+data AddrMode
+        = AddrRegReg    Reg Reg
+        | AddrRegImm    Reg Imm
+
+
+addrOffset :: AddrMode -> Int -> Maybe AddrMode
+addrOffset addr off
+  = case addr of
+      AddrRegImm r (ImmInt n)
+       | fits16Bits n2 -> Just (AddrRegImm r (ImmInt n2))
+       | otherwise     -> Nothing
+       where n2 = n + off
+
+      AddrRegImm r (ImmInteger n)
+       | fits16Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2)))
+       | otherwise     -> Nothing
+       where n2 = n + toInteger off
+
+      _ -> Nothing
+
+
+-- registers -------------------------------------------------------------------
+-- @spRel@ gives us a stack relative addressing mode for volatile
+-- temporaries and for excess call arguments.  @fpRel@, where
+-- applicable, is the same but for the frame pointer.
+
+spRel :: DynFlags
+      -> Int    -- desired stack offset in words, positive or negative
+      -> AddrMode
+
+spRel dflags n = AddrRegImm sp (ImmInt (n * wORD_SIZE dflags))
+
+
+-- argRegs is the set of regs which are read for an n-argument call to C.
+-- For archs which pass all args on the stack (x86), is empty.
+-- Sparc passes up to the first 6 args in regs.
+argRegs :: RegNo -> [Reg]
+argRegs 0 = []
+argRegs 1 = map regSingle [3]
+argRegs 2 = map regSingle [3,4]
+argRegs 3 = map regSingle [3..5]
+argRegs 4 = map regSingle [3..6]
+argRegs 5 = map regSingle [3..7]
+argRegs 6 = map regSingle [3..8]
+argRegs 7 = map regSingle [3..9]
+argRegs 8 = map regSingle [3..10]
+argRegs _ = panic "MachRegs.argRegs(powerpc): don't know about >8 arguments!"
+
+
+allArgRegs :: [Reg]
+allArgRegs = map regSingle [3..10]
+
+
+-- these are the regs which we cannot assume stay alive over a C call.
+callClobberedRegs :: Platform -> [Reg]
+callClobberedRegs _platform
+  = map regSingle (0:[2..12] ++ map fReg [0..13])
+
+
+allMachRegNos   :: [RegNo]
+allMachRegNos   = [0..63]
+
+
+{-# INLINE classOfRealReg      #-}
+classOfRealReg :: RealReg -> RegClass
+classOfRealReg (RealRegSingle i)
+        | i < 32        = RcInteger
+        | otherwise     = RcDouble
+
+classOfRealReg (RealRegPair{})
+        = panic "regClass(ppr): no reg pairs on this architecture"
+
+showReg :: RegNo -> String
+showReg n
+    | n >= 0 && n <= 31   = "%r" ++ show n
+    | n >= 32 && n <= 63  = "%f" ++ show (n - 32)
+    | otherwise           = "%unknown_powerpc_real_reg_" ++ show n
+
+
+
+-- machine specific ------------------------------------------------------------
+
+allFPArgRegs :: Platform -> [Reg]
+allFPArgRegs platform
+    = case platformOS platform of
+      OSAIX    -> map (regSingle . fReg) [1..13]
+      _        -> case platformArch platform of
+        ArchPPC      -> map (regSingle . fReg) [1..8]
+        ArchPPC_64 _ -> map (regSingle . fReg) [1..13]
+        _            -> panic "PPC.Regs.allFPArgRegs: unknown PPC Linux"
+
+fits16Bits :: Integral a => a -> Bool
+fits16Bits x = x >= -32768 && x < 32768
+
+makeImmediate :: Integral a => Width -> Bool -> a -> Maybe Imm
+makeImmediate rep signed x = fmap ImmInt (toI16 rep signed)
+    where
+        narrow W64 False = fromIntegral (fromIntegral x :: Word64)
+        narrow W32 False = fromIntegral (fromIntegral x :: Word32)
+        narrow W16 False = fromIntegral (fromIntegral x :: Word16)
+        narrow W8  False = fromIntegral (fromIntegral x :: Word8)
+        narrow W64 True  = fromIntegral (fromIntegral x :: Int64)
+        narrow W32 True  = fromIntegral (fromIntegral x :: Int32)
+        narrow W16 True  = fromIntegral (fromIntegral x :: Int16)
+        narrow W8  True  = fromIntegral (fromIntegral x :: Int8)
+        narrow _   _     = panic "PPC.Regs.narrow: no match"
+
+        narrowed = narrow rep signed
+
+        toI16 W32 True
+            | narrowed >= -32768 && narrowed < 32768 = Just narrowed
+            | otherwise = Nothing
+        toI16 W32 False
+            | narrowed >= 0 && narrowed < 65536 = Just narrowed
+            | otherwise = Nothing
+        toI16 W64 True
+            | narrowed >= -32768 && narrowed < 32768 = Just narrowed
+            | otherwise = Nothing
+        toI16 W64 False
+            | narrowed >= 0 && narrowed < 65536 = Just narrowed
+            | otherwise = Nothing
+        toI16 _ _  = Just narrowed
+
+
+{-
+The PowerPC has 64 registers of interest; 32 integer registers and 32 floating
+point registers.
+-}
+
+fReg :: Int -> RegNo
+fReg x = (32 + x)
+
+r0, sp, toc, r3, r4, r11, r12, r27, r28, r30, f1, f20, f21 :: Reg
+r0      = regSingle 0
+sp      = regSingle 1
+toc     = regSingle 2
+r3      = regSingle 3
+r4      = regSingle 4
+r11     = regSingle 11
+r12     = regSingle 12
+r27     = regSingle 27
+r28     = regSingle 28
+r30     = regSingle 30
+f1      = regSingle $ fReg 1
+f20     = regSingle $ fReg 20
+f21     = regSingle $ fReg 21
+
+-- allocatableRegs is allMachRegNos with the fixed-use regs removed.
+-- i.e., these are the regs for which we are prepared to allow the
+-- register allocator to attempt to map VRegs to.
+allocatableRegs :: Platform -> [RealReg]
+allocatableRegs platform
+   = let isFree i = freeReg platform i
+     in  map RealRegSingle $ filter isFree allMachRegNos
+
+-- temporary register for compiler use
+tmpReg :: Platform -> Reg
+tmpReg platform =
+       case platformArch platform of
+       ArchPPC      -> regSingle 13
+       ArchPPC_64 _ -> regSingle 30
+       _            -> panic "PPC.Regs.tmpReg: unknowm arch"
diff --git a/compiler/nativeGen/PprBase.hs b/compiler/nativeGen/PprBase.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/PprBase.hs
@@ -0,0 +1,212 @@
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing assembly language
+--
+-- (c) The University of Glasgow 1993-2005
+--
+-----------------------------------------------------------------------------
+
+module PprBase (
+        castFloatToWord8Array,
+        castDoubleToWord8Array,
+        floatToBytes,
+        doubleToBytes,
+        pprASCII,
+        pprSectionHeader
+)
+
+where
+
+import GhcPrelude
+
+import AsmUtils
+import CLabel
+import Cmm
+import DynFlags
+import FastString
+import Outputable
+import Platform
+
+import qualified Data.Array.Unsafe as U ( castSTUArray )
+import Data.Array.ST
+
+import Control.Monad.ST
+
+import Data.Word
+import Data.Char
+
+
+
+-- -----------------------------------------------------------------------------
+-- Converting floating-point literals to integrals for printing
+
+castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)
+castFloatToWord8Array = U.castSTUArray
+
+castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)
+castDoubleToWord8Array = U.castSTUArray
+
+-- floatToBytes and doubleToBytes convert to the host's byte
+-- order.  Providing that we're not cross-compiling for a
+-- target with the opposite endianness, this should work ok
+-- on all targets.
+
+-- ToDo: this stuff is very similar to the shenanigans in PprAbs,
+-- could they be merged?
+
+floatToBytes :: Float -> [Int]
+floatToBytes f
+   = runST (do
+        arr <- newArray_ ((0::Int),3)
+        writeArray arr 0 f
+        arr <- castFloatToWord8Array arr
+        i0 <- readArray arr 0
+        i1 <- readArray arr 1
+        i2 <- readArray arr 2
+        i3 <- readArray arr 3
+        return (map fromIntegral [i0,i1,i2,i3])
+     )
+
+doubleToBytes :: Double -> [Int]
+doubleToBytes d
+   = runST (do
+        arr <- newArray_ ((0::Int),7)
+        writeArray arr 0 d
+        arr <- castDoubleToWord8Array arr
+        i0 <- readArray arr 0
+        i1 <- readArray arr 1
+        i2 <- readArray arr 2
+        i3 <- readArray arr 3
+        i4 <- readArray arr 4
+        i5 <- readArray arr 5
+        i6 <- readArray arr 6
+        i7 <- readArray arr 7
+        return (map fromIntegral [i0,i1,i2,i3,i4,i5,i6,i7])
+     )
+
+-- ---------------------------------------------------------------------------
+-- Printing ASCII strings.
+--
+-- Print as a string and escape non-printable characters.
+-- This is similar to charToC in Utils.
+
+pprASCII :: [Word8] -> SDoc
+pprASCII str
+  -- Transform this given literal bytestring to escaped string and construct
+  -- the literal SDoc directly.
+  -- See Trac #14741
+  -- and Note [Pretty print ASCII when AsmCodeGen]
+  = text $ foldr (\w s -> (do1 . fromIntegral) w ++ s) "" str
+    where
+       do1 :: Int -> String
+       do1 w | '\t' <- chr w = "\\t"
+             | '\n' <- chr w = "\\n"
+             | '"'  <- chr w = "\\\""
+             | '\\' <- chr w = "\\\\"
+             | isPrint (chr w) = [chr w]
+             | otherwise = '\\' : octal w
+
+       octal :: Int -> String
+       octal w = [ chr (ord '0' + (w `div` 64) `mod` 8)
+                 , chr (ord '0' + (w `div` 8) `mod` 8)
+                 , chr (ord '0' + w `mod` 8)
+                 ]
+
+{-
+Note [Pretty print ASCII when AsmCodeGen]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Previously, when generating assembly code, we created SDoc with
+`(ptext . sLit)` for every bytes in literal bytestring, then
+combine them using `hcat`.
+
+When handling literal bytestrings with millions of bytes,
+millions of SDoc would be created and to combine, leading to
+high memory usage.
+
+Now we escape the given bytestring to string directly and construct
+SDoc only once. This improvement could dramatically decrease the
+memory allocation from 4.7GB to 1.3GB when embedding a 3MB literal
+string in source code. See Trac #14741 for profiling results.
+-}
+
+-- ----------------------------------------------------------------------------
+-- Printing section headers.
+--
+-- If -split-section was specified, include the suffix label, otherwise just
+-- print the section type. For Darwin, where subsections-for-symbols are
+-- used instead, only print section type.
+--
+-- For string literals, additional flags are specified to enable merging of
+-- identical strings in the linker. With -split-sections each string also gets
+-- a unique section to allow strings from unused code to be GC'd.
+
+pprSectionHeader :: Platform -> Section -> SDoc
+pprSectionHeader platform (Section t suffix) =
+ case platformOS platform of
+   OSAIX     -> pprXcoffSectionHeader t
+   OSDarwin  -> pprDarwinSectionHeader t
+   OSMinGW32 -> pprGNUSectionHeader (char '$') t suffix
+   _         -> pprGNUSectionHeader (char '.') t suffix
+
+pprGNUSectionHeader :: SDoc -> SectionType -> CLabel -> SDoc
+pprGNUSectionHeader sep t suffix = sdocWithDynFlags $ \dflags ->
+  let splitSections = gopt Opt_SplitSections dflags
+      subsection | splitSections = sep <> ppr suffix
+                 | otherwise     = empty
+  in  text ".section " <> ptext (header dflags) <> subsection <>
+      flags dflags
+  where
+    header dflags = case t of
+      Text -> sLit ".text"
+      Data -> sLit ".data"
+      ReadOnlyData  | OSMinGW32 <- platformOS (targetPlatform dflags)
+                                -> sLit ".rdata"
+                    | otherwise -> sLit ".rodata"
+      RelocatableReadOnlyData | OSMinGW32 <- platformOS (targetPlatform dflags)
+                                -- Concept does not exist on Windows,
+                                -- So map these to R/O data.
+                                          -> sLit ".rdata$rel.ro"
+                              | otherwise -> sLit ".data.rel.ro"
+      UninitialisedData -> sLit ".bss"
+      ReadOnlyData16 | OSMinGW32 <- platformOS (targetPlatform dflags)
+                                 -> sLit ".rdata$cst16"
+                     | otherwise -> sLit ".rodata.cst16"
+      CString
+        | OSMinGW32 <- platformOS (targetPlatform dflags)
+                    -> sLit ".rdata"
+        | otherwise -> sLit ".rodata.str"
+      OtherSection _ ->
+        panic "PprBase.pprGNUSectionHeader: unknown section type"
+    flags dflags = case t of
+      CString
+        | OSMinGW32 <- platformOS (targetPlatform dflags)
+                    -> empty
+        | otherwise -> text ",\"aMS\"," <> sectionType "progbits" <> text ",1"
+      _ -> empty
+
+-- XCOFF doesn't support relocating label-differences, so we place all
+-- RO sections into .text[PR] sections
+pprXcoffSectionHeader :: SectionType -> SDoc
+pprXcoffSectionHeader t = text $ case t of
+     Text                    -> ".csect .text[PR]"
+     Data                    -> ".csect .data[RW]"
+     ReadOnlyData            -> ".csect .text[PR] # ReadOnlyData"
+     RelocatableReadOnlyData -> ".csect .text[PR] # RelocatableReadOnlyData"
+     ReadOnlyData16          -> ".csect .text[PR] # ReadOnlyData16"
+     CString                 -> ".csect .text[PR] # CString"
+     UninitialisedData       -> ".csect .data[BS]"
+     OtherSection _          ->
+       panic "PprBase.pprXcoffSectionHeader: unknown section type"
+
+pprDarwinSectionHeader :: SectionType -> SDoc
+pprDarwinSectionHeader t =
+  ptext $ case t of
+     Text -> sLit ".text"
+     Data -> sLit ".data"
+     ReadOnlyData -> sLit ".const"
+     RelocatableReadOnlyData -> sLit ".const_data"
+     UninitialisedData -> sLit ".data"
+     ReadOnlyData16 -> sLit ".const"
+     CString -> sLit ".section\t__TEXT,__cstring,cstring_literals"
+     OtherSection _ ->
+       panic "PprBase.pprDarwinSectionHeader: unknown section type"
diff --git a/compiler/nativeGen/Reg.hs b/compiler/nativeGen/Reg.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/Reg.hs
@@ -0,0 +1,241 @@
+-- | An architecture independent description of a register.
+--      This needs to stay architecture independent because it is used
+--      by NCGMonad and the register allocators, which are shared
+--      by all architectures.
+--
+module Reg (
+        RegNo,
+        Reg(..),
+        regPair,
+        regSingle,
+        isRealReg,      takeRealReg,
+        isVirtualReg,   takeVirtualReg,
+
+        VirtualReg(..),
+        renameVirtualReg,
+        classOfVirtualReg,
+        getHiVirtualRegFromLo,
+        getHiVRegFromLo,
+
+        RealReg(..),
+        regNosOfRealReg,
+        realRegsAlias,
+
+        liftPatchFnToRegReg
+)
+
+where
+
+import GhcPrelude
+
+import Outputable
+import Unique
+import RegClass
+import Data.List
+
+-- | An identifier for a primitive real machine register.
+type RegNo
+        = Int
+
+-- VirtualRegs are virtual registers.  The register allocator will
+--      eventually have to map them into RealRegs, or into spill slots.
+--
+--      VirtualRegs are allocated on the fly, usually to represent a single
+--      value in the abstract assembly code (i.e. dynamic registers are
+--      usually single assignment).
+--
+--      The  single assignment restriction isn't necessary to get correct code,
+--      although a better register allocation will result if single
+--      assignment is used -- because the allocator maps a VirtualReg into
+--      a single RealReg, even if the VirtualReg has multiple live ranges.
+--
+--      Virtual regs can be of either class, so that info is attached.
+--
+data VirtualReg
+        = VirtualRegI  {-# UNPACK #-} !Unique
+        | VirtualRegHi {-# UNPACK #-} !Unique  -- High part of 2-word register
+        | VirtualRegF  {-# UNPACK #-} !Unique
+        | VirtualRegD  {-# UNPACK #-} !Unique
+        | VirtualRegSSE {-# UNPACK #-} !Unique
+        deriving (Eq, Show)
+
+-- This is laborious, but necessary. We can't derive Ord because
+-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the
+-- implementation. See Note [No Ord for Unique]
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+instance Ord VirtualReg where
+  compare (VirtualRegI a) (VirtualRegI b) = nonDetCmpUnique a b
+  compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b
+  compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b
+  compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b
+  compare (VirtualRegSSE a) (VirtualRegSSE b) = nonDetCmpUnique a b
+  compare VirtualRegI{} _ = LT
+  compare _ VirtualRegI{} = GT
+  compare VirtualRegHi{} _ = LT
+  compare _ VirtualRegHi{} = GT
+  compare VirtualRegF{} _ = LT
+  compare _ VirtualRegF{} = GT
+  compare VirtualRegD{} _ = LT
+  compare _ VirtualRegD{} = GT
+
+
+instance Uniquable VirtualReg where
+        getUnique reg
+         = case reg of
+                VirtualRegI u   -> u
+                VirtualRegHi u  -> u
+                VirtualRegF u   -> u
+                VirtualRegD u   -> u
+                VirtualRegSSE u -> u
+
+instance Outputable VirtualReg where
+        ppr reg
+         = case reg of
+                VirtualRegI  u  -> text "%vI_"   <> pprUniqueAlways u
+                VirtualRegHi u  -> text "%vHi_"  <> pprUniqueAlways u
+                VirtualRegF  u  -> text "%vF_"   <> pprUniqueAlways u
+                VirtualRegD  u  -> text "%vD_"   <> pprUniqueAlways u
+                VirtualRegSSE u -> text "%vSSE_" <> pprUniqueAlways u
+
+
+renameVirtualReg :: Unique -> VirtualReg -> VirtualReg
+renameVirtualReg u r
+ = case r of
+        VirtualRegI _   -> VirtualRegI  u
+        VirtualRegHi _  -> VirtualRegHi u
+        VirtualRegF _   -> VirtualRegF  u
+        VirtualRegD _   -> VirtualRegD  u
+        VirtualRegSSE _ -> VirtualRegSSE u
+
+
+classOfVirtualReg :: VirtualReg -> RegClass
+classOfVirtualReg vr
+ = case vr of
+        VirtualRegI{}   -> RcInteger
+        VirtualRegHi{}  -> RcInteger
+        VirtualRegF{}   -> RcFloat
+        VirtualRegD{}   -> RcDouble
+        VirtualRegSSE{} -> RcDoubleSSE
+
+
+-- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform
+-- when supplied with the vreg for the lower-half of the quantity.
+-- (NB. Not reversible).
+getHiVirtualRegFromLo :: VirtualReg -> VirtualReg
+getHiVirtualRegFromLo reg
+ = case reg of
+        -- makes a pseudo-unique with tag 'H'
+        VirtualRegI u   -> VirtualRegHi (newTagUnique u 'H')
+        _               -> panic "Reg.getHiVirtualRegFromLo"
+
+getHiVRegFromLo :: Reg -> Reg
+getHiVRegFromLo reg
+ = case reg of
+        RegVirtual  vr  -> RegVirtual (getHiVirtualRegFromLo vr)
+        RegReal _       -> panic "Reg.getHiVRegFromLo"
+
+
+------------------------------------------------------------------------------------
+-- | RealRegs are machine regs which are available for allocation, in
+--      the usual way.  We know what class they are, because that's part of
+--      the processor's architecture.
+--
+--      RealRegPairs are pairs of real registers that are allocated together
+--      to hold a larger value, such as with Double regs on SPARC.
+--
+data RealReg
+        = RealRegSingle {-# UNPACK #-} !RegNo
+        | RealRegPair   {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo
+        deriving (Eq, Show, Ord)
+
+instance Uniquable RealReg where
+        getUnique reg
+         = case reg of
+                RealRegSingle i         -> mkRegSingleUnique i
+                RealRegPair r1 r2       -> mkRegPairUnique (r1 * 65536 + r2)
+
+instance Outputable RealReg where
+        ppr reg
+         = case reg of
+                RealRegSingle i         -> text "%r"  <> int i
+                RealRegPair r1 r2       -> text "%r(" <> int r1
+                                           <> vbar <> int r2 <> text ")"
+
+regNosOfRealReg :: RealReg -> [RegNo]
+regNosOfRealReg rr
+ = case rr of
+        RealRegSingle r1        -> [r1]
+        RealRegPair   r1 r2     -> [r1, r2]
+
+
+realRegsAlias :: RealReg -> RealReg -> Bool
+realRegsAlias rr1 rr2
+        = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2)
+
+--------------------------------------------------------------------------------
+-- | A register, either virtual or real
+data Reg
+        = RegVirtual !VirtualReg
+        | RegReal    !RealReg
+        deriving (Eq, Ord)
+
+regSingle :: RegNo -> Reg
+regSingle regNo         = RegReal $ RealRegSingle regNo
+
+regPair :: RegNo -> RegNo -> Reg
+regPair regNo1 regNo2   = RegReal $ RealRegPair regNo1 regNo2
+
+
+-- We like to have Uniques for Reg so that we can make UniqFM and UniqSets
+-- in the register allocator.
+instance Uniquable Reg where
+        getUnique reg
+         = case reg of
+                RegVirtual vr   -> getUnique vr
+                RegReal    rr   -> getUnique rr
+
+-- | Print a reg in a generic manner
+--      If you want the architecture specific names, then use the pprReg
+--      function from the appropriate Ppr module.
+instance Outputable Reg where
+        ppr reg
+         = case reg of
+                RegVirtual vr   -> ppr vr
+                RegReal    rr   -> ppr rr
+
+
+isRealReg :: Reg -> Bool
+isRealReg reg
+ = case reg of
+        RegReal _       -> True
+        RegVirtual _    -> False
+
+takeRealReg :: Reg -> Maybe RealReg
+takeRealReg reg
+ = case reg of
+        RegReal rr      -> Just rr
+        _               -> Nothing
+
+
+isVirtualReg :: Reg -> Bool
+isVirtualReg reg
+ = case reg of
+        RegReal _       -> False
+        RegVirtual _    -> True
+
+takeVirtualReg :: Reg -> Maybe VirtualReg
+takeVirtualReg reg
+ = case reg of
+        RegReal _       -> Nothing
+        RegVirtual vr   -> Just vr
+
+
+-- | The patch function supplied by the allocator maps VirtualReg to RealReg
+--      regs, but sometimes we want to apply it to plain old Reg.
+--
+liftPatchFnToRegReg  :: (VirtualReg -> RealReg) -> (Reg -> Reg)
+liftPatchFnToRegReg patchF reg
+ = case reg of
+        RegVirtual vr   -> RegReal (patchF vr)
+        RegReal _       -> reg
diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/ArchBase.hs
@@ -0,0 +1,161 @@
+
+-- | Utils for calculating general worst, bound, squeese and free, functions.
+--
+--   as per: "A Generalized Algorithm for Graph-Coloring Register Allocation"
+--           Michael Smith, Normal Ramsey, Glenn Holloway.
+--           PLDI 2004
+--
+--   These general versions are not used in GHC proper because they are too slow.
+--   Instead, hand written optimised versions are provided for each architecture
+--   in MachRegs*.hs
+--
+--   This code is here because we can test the architecture specific code against
+--   it.
+--
+module RegAlloc.Graph.ArchBase (
+        RegClass(..),
+        Reg(..),
+        RegSub(..),
+
+        worst,
+        bound,
+        squeese
+) where
+import GhcPrelude
+
+import UniqSet
+import UniqFM
+import Unique
+
+
+-- Some basic register classes.
+--      These aren't necessarily in 1-to-1 correspondence with the allocatable
+--      RegClasses in MachRegs.hs
+data RegClass
+        -- general purpose regs
+        = ClassG32      -- 32 bit GPRs
+        | ClassG16      -- 16 bit GPRs
+        | ClassG8       -- 8  bit GPRs
+
+        -- floating point regs
+        | ClassF64      -- 64 bit FPRs
+        deriving (Show, Eq, Enum)
+
+
+-- | A register of some class
+data Reg
+        -- a register of some class
+        = Reg RegClass Int
+
+        -- a sub-component of one of the other regs
+        | RegSub RegSub Reg
+        deriving (Show, Eq)
+
+
+-- | so we can put regs in UniqSets
+instance Uniquable Reg where
+        getUnique (Reg c i)
+         = mkRegSingleUnique
+         $ fromEnum c * 1000 + i
+
+        getUnique (RegSub s (Reg c i))
+         = mkRegSubUnique
+         $ fromEnum s * 10000 + fromEnum c * 1000 + i
+
+        getUnique (RegSub _ (RegSub _ _))
+          = error "RegArchBase.getUnique: can't have a sub-reg of a sub-reg."
+
+
+-- | A subcomponent of another register
+data RegSub
+        = SubL16        -- lowest 16 bits
+        | SubL8         -- lowest  8 bits
+        | SubL8H        -- second lowest 8 bits
+        deriving (Show, Enum, Ord, Eq)
+
+
+-- | Worst case displacement
+--
+--      a node N of classN has some number of neighbors,
+--      all of which are from classC.
+--
+--      (worst neighbors classN classC) is the maximum number of potential
+--      colors for N that can be lost by coloring its neighbors.
+--
+-- This should be hand coded/cached for each particular architecture,
+--      because the compute time is very long..
+worst   :: (RegClass    -> UniqSet Reg)
+        -> (Reg         -> UniqSet Reg)
+        -> Int -> RegClass -> RegClass -> Int
+
+worst regsOfClass regAlias neighbors classN classC
+ = let  regAliasS regs  = unionManyUniqSets
+                        $ map regAlias
+                        $ nonDetEltsUniqSet regs
+                        -- This is non-deterministic but we do not
+                        -- currently support deterministic code-generation.
+                        -- See Note [Unique Determinism and code generation]
+
+        -- all the regs in classes N, C
+        regsN           = regsOfClass classN
+        regsC           = regsOfClass classC
+
+        -- all the possible subsets of c which have size < m
+        regsS           = filter (\s -> sizeUniqSet s >= 1
+                                     && sizeUniqSet s <= neighbors)
+                        $ powersetLS regsC
+
+        -- for each of the subsets of C, the regs which conflict
+        -- with posiblities for N
+        regsS_conflict
+                = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS
+
+  in    maximum $ map sizeUniqSet $ regsS_conflict
+
+
+-- | For a node N of classN and neighbors of classesC
+--      (bound classN classesC) is the maximum number of potential
+--      colors for N that can be lost by coloring its neighbors.
+bound   :: (RegClass    -> UniqSet Reg)
+        -> (Reg         -> UniqSet Reg)
+        -> RegClass -> [RegClass] -> Int
+
+bound regsOfClass regAlias classN classesC
+ = let  regAliasS regs  = unionManyUniqSets
+                        $ map regAlias
+                        $ nonDetEltsUFM regs
+                        -- See Note [Unique Determinism and code generation]
+
+        regsC_aliases
+                = unionManyUniqSets
+                $ map (regAliasS . getUniqSet . regsOfClass) classesC
+
+        overlap = intersectUniqSets (regsOfClass classN) regsC_aliases
+
+   in   sizeUniqSet overlap
+
+
+-- | The total squeese on a particular node with a list of neighbors.
+--
+--   A version of this should be constructed for each particular architecture,
+--   possibly including uses of bound, so that alised registers don't get
+--   counted twice, as per the paper.
+squeese :: (RegClass    -> UniqSet Reg)
+        -> (Reg         -> UniqSet Reg)
+        -> RegClass -> [(Int, RegClass)] -> Int
+
+squeese regsOfClass regAlias classN countCs
+        = sum
+        $ map (\(i, classC) -> worst regsOfClass regAlias i classN classC)
+        $ countCs
+
+
+-- | powerset (for lists)
+powersetL :: [a] -> [[a]]
+powersetL       = map concat . mapM (\x -> [[],[x]])
+
+
+-- | powersetLS (list of sets)
+powersetLS :: Uniquable a => UniqSet a -> [UniqSet a]
+powersetLS s    = map mkUniqSet $ powersetL $ nonDetEltsUniqSet s
+  -- See Note [Unique Determinism and code generation]
diff --git a/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs b/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/ArchX86.hs
@@ -0,0 +1,161 @@
+
+-- | A description of the register set of the X86.
+--
+--   This isn't used directly in GHC proper.
+--
+--   See RegArchBase.hs for the reference.
+--   See MachRegs.hs for the actual trivColorable function used in GHC.
+--
+module RegAlloc.Graph.ArchX86 (
+        classOfReg,
+        regsOfClass,
+        regName,
+        regAlias,
+        worst,
+        squeese,
+) where
+
+import GhcPrelude
+
+import RegAlloc.Graph.ArchBase  (Reg(..), RegSub(..), RegClass(..))
+import UniqSet
+
+import qualified Data.Array as A
+
+
+-- | Determine the class of a register
+classOfReg :: Reg -> RegClass
+classOfReg reg
+ = case reg of
+        Reg c _         -> c
+
+        RegSub SubL16 _ -> ClassG16
+        RegSub SubL8  _ -> ClassG8
+        RegSub SubL8H _ -> ClassG8
+
+
+-- | Determine all the regs that make up a certain class.
+regsOfClass :: RegClass -> UniqSet Reg
+regsOfClass c
+ = case c of
+        ClassG32
+         -> mkUniqSet   [ Reg ClassG32  i
+                        | i <- [0..7] ]
+
+        ClassG16
+         -> mkUniqSet   [ RegSub SubL16 (Reg ClassG32 i)
+                        | i <- [0..7] ]
+
+        ClassG8
+         -> unionUniqSets
+                (mkUniqSet [ RegSub SubL8  (Reg ClassG32 i) | i <- [0..3] ])
+                (mkUniqSet [ RegSub SubL8H (Reg ClassG32 i) | i <- [0..3] ])
+
+        ClassF64
+         -> mkUniqSet   [ Reg ClassF64  i
+                        | i <- [0..5] ]
+
+
+-- | Determine the common name of a reg
+--      returns Nothing if this reg is not part of the machine.
+regName :: Reg -> Maybe String
+regName reg
+ = case reg of
+        Reg ClassG32 i
+         | i <= 7 ->
+           let names = A.listArray (0,8)
+                       [ "eax", "ebx", "ecx", "edx"
+                       , "ebp", "esi", "edi", "esp" ]
+           in Just $ names A.! i
+
+        RegSub SubL16 (Reg ClassG32 i)
+         | i <= 7 ->
+           let names = A.listArray (0,8)
+                       [ "ax", "bx", "cx", "dx"
+                       , "bp", "si", "di", "sp"]
+           in Just $ names A.! i
+
+        RegSub SubL8  (Reg ClassG32 i)
+         | i <= 3 ->
+           let names = A.listArray (0,4) [ "al", "bl", "cl", "dl"]
+           in Just $ names A.! i
+
+        RegSub SubL8H (Reg ClassG32 i)
+         | i <= 3 ->
+           let names = A.listArray (0,4) [ "ah", "bh", "ch", "dh"]
+           in Just $ names A.! i
+
+        _         -> Nothing
+
+
+-- | Which regs alias what other regs.
+regAlias :: Reg -> UniqSet Reg
+regAlias reg
+ = case reg of
+
+        -- 32 bit regs alias all of the subregs
+        Reg ClassG32 i
+
+         -- for eax, ebx, ecx, eds
+         |  i <= 3
+         -> mkUniqSet
+         $ [ Reg ClassG32 i,   RegSub SubL16 reg
+           , RegSub SubL8 reg, RegSub SubL8H reg ]
+
+         -- for esi, edi, esp, ebp
+         | 4 <= i && i <= 7
+         -> mkUniqSet
+         $ [ Reg ClassG32 i,   RegSub SubL16 reg ]
+
+        -- 16 bit subregs alias the whole reg
+        RegSub SubL16 r@(Reg ClassG32 _)
+         ->     regAlias r
+
+        -- 8 bit subregs alias the 32 and 16, but not the other 8 bit subreg
+        RegSub SubL8  r@(Reg ClassG32 _)
+         -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8 r ]
+
+        RegSub SubL8H r@(Reg ClassG32 _)
+         -> mkUniqSet $ [ r, RegSub SubL16 r, RegSub SubL8H r ]
+
+        -- fp
+        Reg ClassF64 _
+         -> unitUniqSet reg
+
+        _ -> error "regAlias: invalid register"
+
+
+-- | Optimised versions of RegColorBase.{worst, squeese} specific to x86
+worst :: Int -> RegClass -> RegClass -> Int
+worst n classN classC
+ = case classN of
+        ClassG32
+         -> case classC of
+                ClassG32        -> min n 8
+                ClassG16        -> min n 8
+                ClassG8         -> min n 4
+                ClassF64        -> 0
+
+        ClassG16
+         -> case classC of
+                ClassG32        -> min n 8
+                ClassG16        -> min n 8
+                ClassG8         -> min n 4
+                ClassF64        -> 0
+
+        ClassG8
+         -> case classC of
+                ClassG32        -> min (n*2) 8
+                ClassG16        -> min (n*2) 8
+                ClassG8         -> min n 8
+                ClassF64        -> 0
+
+        ClassF64
+         -> case classC of
+                ClassF64        -> min n 6
+                _               -> 0
+
+squeese :: RegClass -> [(Int, RegClass)] -> Int
+squeese classN countCs
+        = sum (map (\(i, classC) -> worst i classN classC) countCs)
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs
@@ -0,0 +1,99 @@
+-- | Register coalescing.
+module RegAlloc.Graph.Coalesce (
+        regCoalesce,
+        slurpJoinMovs
+) where
+import GhcPrelude
+
+import RegAlloc.Liveness
+import Instruction
+import Reg
+
+import Cmm
+import Bag
+import Digraph
+import UniqFM
+import UniqSet
+import UniqSupply
+
+
+-- | Do register coalescing on this top level thing
+--
+--   For Reg -> Reg moves, if the first reg dies at the same time the
+--   second reg is born then the mov only serves to join live ranges.
+--   The two regs can be renamed to be the same and the move instruction
+--   safely erased.
+regCoalesce
+        :: Instruction instr
+        => [LiveCmmDecl statics instr]
+        -> UniqSM [LiveCmmDecl statics instr]
+
+regCoalesce code
+ = do
+        let joins       = foldl' unionBags emptyBag
+                        $ map slurpJoinMovs code
+
+        let alloc       = foldl' buildAlloc emptyUFM
+                        $ bagToList joins
+
+        let patched     = map (patchEraseLive (sinkReg alloc)) code
+
+        return patched
+
+
+-- | Add a v1 = v2 register renaming to the map.
+--   The register with the lowest lexical name is set as the
+--   canonical version.
+buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg
+buildAlloc fm (r1, r2)
+ = let  rmin    = min r1 r2
+        rmax    = max r1 r2
+   in   addToUFM fm rmax rmin
+
+
+-- | Determine the canonical name for a register by following
+--   v1 = v2 renamings in this map.
+sinkReg :: UniqFM Reg -> Reg -> Reg
+sinkReg fm r
+ = case lookupUFM fm r of
+        Nothing -> r
+        Just r' -> sinkReg fm r'
+
+
+-- | Slurp out mov instructions that only serve to join live ranges.
+--
+--   During a mov, if the source reg dies and the destination reg is
+--   born then we can rename the two regs to the same thing and
+--   eliminate the move.
+slurpJoinMovs
+        :: Instruction instr
+        => LiveCmmDecl statics instr
+        -> Bag (Reg, Reg)
+
+slurpJoinMovs live
+        = slurpCmm emptyBag live
+ where
+        slurpCmm   rs  CmmData{}
+         = rs
+
+        slurpCmm   rs (CmmProc _ _ _ sccs)
+         = foldl' slurpBlock rs (flattenSCCs sccs)
+
+        slurpBlock rs (BasicBlock _ instrs)
+         = foldl' slurpLI    rs instrs
+
+        slurpLI    rs (LiveInstr _      Nothing)    = rs
+        slurpLI    rs (LiveInstr instr (Just live))
+                | Just (r1, r2) <- takeRegRegMoveInstr instr
+                , elementOfUniqSet r1 $ liveDieRead live
+                , elementOfUniqSet r2 $ liveBorn live
+
+                -- only coalesce movs between two virtuals for now,
+                -- else we end up with allocatable regs in the live
+                -- regs list..
+                , isVirtualReg r1 && isVirtualReg r2
+                = consBag (r1, r2) rs
+
+                | otherwise
+                = rs
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/Main.hs b/compiler/nativeGen/RegAlloc/Graph/Main.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/Main.hs
@@ -0,0 +1,468 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Graph coloring register allocator.
+module RegAlloc.Graph.Main (
+        regAlloc
+) where
+import GhcPrelude
+
+import qualified GraphColor as Color
+import RegAlloc.Liveness
+import RegAlloc.Graph.Spill
+import RegAlloc.Graph.SpillClean
+import RegAlloc.Graph.SpillCost
+import RegAlloc.Graph.Stats
+import RegAlloc.Graph.TrivColorable
+import Instruction
+import TargetReg
+import RegClass
+import Reg
+
+import Bag
+import DynFlags
+import Outputable
+import Platform
+import UniqFM
+import UniqSet
+import UniqSupply
+import Util (seqList)
+import CFG
+
+import Data.Maybe
+import Control.Monad
+
+
+-- | The maximum number of build\/spill cycles we'll allow.
+--
+--   It should only take 3 or 4 cycles for the allocator to converge.
+--   If it takes any longer than this it's probably in an infinite loop,
+--   so it's better just to bail out and report a bug.
+maxSpinCount    :: Int
+maxSpinCount    = 10
+
+
+-- | The top level of the graph coloring register allocator.
+regAlloc
+        :: (Outputable statics, Outputable instr, Instruction instr)
+        => DynFlags
+        -> UniqFM (UniqSet RealReg)     -- ^ registers we can use for allocation
+        -> UniqSet Int                  -- ^ set of available spill slots.
+        -> Int                          -- ^ current number of spill slots
+        -> [LiveCmmDecl statics instr]  -- ^ code annotated with liveness information.
+        -> Maybe CFG                    -- ^ CFG of basic blocks if available
+        -> UniqSM ( [NatCmmDecl statics instr]
+                  , Maybe Int, [RegAllocStats statics instr] )
+           -- ^ code with registers allocated, additional stacks required
+           -- and stats for each stage of allocation
+
+regAlloc dflags regsFree slotsFree slotsCount code cfg
+ = do
+        -- TODO: the regClass function is currently hard coded to the default
+        --       target architecture. Would prefer to determine this from dflags.
+        --       There are other uses of targetRegClass later in this module.
+        let platform = targetPlatform dflags
+            triv = trivColorable platform
+                        (targetVirtualRegSqueeze platform)
+                        (targetRealRegSqueeze platform)
+
+        (code_final, debug_codeGraphs, slotsCount', _)
+                <- regAlloc_spin dflags 0
+                        triv
+                        regsFree slotsFree slotsCount [] code cfg
+
+        let needStack
+                | slotsCount == slotsCount'
+                = Nothing
+                | otherwise
+                = Just slotsCount'
+
+        return  ( code_final
+                , needStack
+                , reverse debug_codeGraphs )
+
+
+-- | Perform solver iterations for the graph coloring allocator.
+--
+--   We extract a register confict graph from the provided cmm code,
+--   and try to colour it. If that works then we use the solution rewrite
+--   the code with real hregs. If coloring doesn't work we add spill code
+--   and try to colour it again. After `maxSpinCount` iterations we give up.
+--
+regAlloc_spin
+        :: (Instruction instr,
+            Outputable instr,
+            Outputable statics)
+        => DynFlags
+        -> Int  -- ^ Number of solver iterations we've already performed.
+        -> Color.Triv VirtualReg RegClass RealReg
+                -- ^ Function for calculating whether a register is trivially
+                --   colourable.
+        -> UniqFM (UniqSet RealReg)      -- ^ Free registers that we can allocate.
+        -> UniqSet Int                   -- ^ Free stack slots that we can use.
+        -> Int                           -- ^ Number of spill slots in use
+        -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to.
+        -> [LiveCmmDecl statics instr]   -- ^ Liveness annotated code to allocate.
+        -> Maybe CFG
+        -> UniqSM ( [NatCmmDecl statics instr]
+                  , [RegAllocStats statics instr]
+                  , Int                  -- Slots in use
+                  , Color.Graph VirtualReg RegClass RealReg)
+
+regAlloc_spin dflags spinCount triv regsFree slotsFree slotsCount debug_codeGraphs code cfg
+ = do
+        let platform = targetPlatform dflags
+
+        -- If any of these dump flags are turned on we want to hang on to
+        -- intermediate structures in the allocator - otherwise tell the
+        -- allocator to ditch them early so we don't end up creating space leaks.
+        let dump = or
+                [ dopt Opt_D_dump_asm_regalloc_stages dflags
+                , dopt Opt_D_dump_asm_stats dflags
+                , dopt Opt_D_dump_asm_conflicts dflags ]
+
+        -- Check that we're not running off down the garden path.
+        when (spinCount > maxSpinCount)
+         $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."
+           (  text "It looks like the register allocator is stuck in an infinite loop."
+           $$ text "max cycles  = " <> int maxSpinCount
+           $$ text "regsFree    = " <> (hcat $ punctuate space $ map ppr
+                                             $ nonDetEltsUniqSet $ unionManyUniqSets
+                                             $ nonDetEltsUFM regsFree)
+              -- This is non-deterministic but we do not
+              -- currently support deterministic code-generation.
+              -- See Note [Unique Determinism and code generation]
+           $$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))
+
+        -- Build the register conflict graph from the cmm code.
+        (graph  :: Color.Graph VirtualReg RegClass RealReg)
+                <- {-# SCC "BuildGraph" #-} buildGraph code
+
+        -- VERY IMPORTANT:
+        --   We really do want the graph to be fully evaluated _before_ we
+        --   start coloring. If we don't do this now then when the call to
+        --   Color.colorGraph forces bits of it, the heap will be filled with
+        --   half evaluated pieces of graph and zillions of apply thunks.
+        seqGraph graph `seq` return ()
+
+        -- Build a map of the cost of spilling each instruction.
+        -- This is a lazy binding, so the map will only be computed if we
+        -- actually have to spill to the stack.
+        let spillCosts  = foldl' plusSpillCostInfo zeroSpillCostInfo
+                        $ map (slurpSpillCostInfo platform cfg) code
+
+        -- The function to choose regs to leave uncolored.
+        let spill       = chooseSpill spillCosts
+
+        -- Record startup state in our log.
+        let stat1
+             = if spinCount == 0
+                 then   Just $ RegAllocStatsStart
+                        { raLiveCmm     = code
+                        , raGraph       = graph
+                        , raSpillCosts  = spillCosts }
+                 else   Nothing
+
+        -- Try and color the graph.
+        let (graph_colored, rsSpill, rmCoalesce)
+                = {-# SCC "ColorGraph" #-}
+                  Color.colorGraph
+                       (gopt Opt_RegsIterative dflags)
+                       spinCount
+                       regsFree triv spill graph
+
+        -- Rewrite registers in the code that have been coalesced.
+        let patchF reg
+                | RegVirtual vr <- reg
+                = case lookupUFM rmCoalesce vr of
+                        Just vr'        -> patchF (RegVirtual vr')
+                        Nothing         -> reg
+
+                | otherwise
+                = reg
+
+        let code_coalesced
+                = map (patchEraseLive patchF) code
+
+        -- Check whether we've found a coloring.
+        if isEmptyUniqSet rsSpill
+
+         -- Coloring was successful because no registers needed to be spilled.
+         then do
+                -- if -fasm-lint is turned on then validate the graph.
+                -- This checks for bugs in the graph allocator itself.
+                let graph_colored_lint  =
+                        if gopt Opt_DoAsmLinting dflags
+                                then Color.validateGraph (text "")
+                                        True    -- Require all nodes to be colored.
+                                        graph_colored
+                                else graph_colored
+
+                -- Rewrite the code to use real hregs, using the colored graph.
+                let code_patched
+                        = map (patchRegsFromGraph platform graph_colored_lint)
+                              code_coalesced
+
+                -- Clean out unneeded SPILL/RELOAD meta instructions.
+                --   The spill code generator just spills the entire live range
+                --   of a vreg, but it might not need to be on the stack for
+                --   its entire lifetime.
+                let code_spillclean
+                        = map (cleanSpills platform) code_patched
+
+                -- Strip off liveness information from the allocated code.
+                -- Also rewrite SPILL/RELOAD meta instructions into real machine
+                -- instructions along the way
+                let code_final
+                        = map (stripLive dflags) code_spillclean
+
+                -- Record what happened in this stage for debugging
+                let stat
+                     =  RegAllocStatsColored
+                        { raCode                = code
+                        , raGraph               = graph
+                        , raGraphColored        = graph_colored_lint
+                        , raCoalesced           = rmCoalesce
+                        , raCodeCoalesced       = code_coalesced
+                        , raPatched             = code_patched
+                        , raSpillClean          = code_spillclean
+                        , raFinal               = code_final
+                        , raSRMs                = foldl' addSRM (0, 0, 0)
+                                                $ map countSRMs code_spillclean }
+
+                -- Bundle up all the register allocator statistics.
+                --   .. but make sure to drop them on the floor if they're not
+                --      needed, otherwise we'll get a space leak.
+                let statList =
+                        if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+                                else []
+
+                -- Ensure all the statistics are evaluated, to avoid space leaks.
+                seqList statList (return ())
+
+                return  ( code_final
+                        , statList
+                        , slotsCount
+                        , graph_colored_lint)
+
+         -- Coloring was unsuccessful. We need to spill some register to the
+         -- stack, make a new graph, and try to color it again.
+         else do
+                -- if -fasm-lint is turned on then validate the graph
+                let graph_colored_lint  =
+                        if gopt Opt_DoAsmLinting dflags
+                                then Color.validateGraph (text "")
+                                        False   -- don't require nodes to be colored
+                                        graph_colored
+                                else graph_colored
+
+                -- Spill uncolored regs to the stack.
+                (code_spilled, slotsFree', slotsCount', spillStats)
+                        <- regSpill platform code_coalesced slotsFree slotsCount rsSpill
+
+                -- Recalculate liveness information.
+                -- NOTE: we have to reverse the SCCs here to get them back into
+                --       the reverse-dependency order required by computeLiveness.
+                --       If they're not in the correct order that function will panic.
+                code_relive     <- mapM (regLiveness platform . reverseBlocksInTops)
+                                        code_spilled
+
+                -- Record what happened in this stage for debugging.
+                let stat        =
+                        RegAllocStatsSpill
+                        { raCode        = code
+                        , raGraph       = graph_colored_lint
+                        , raCoalesced   = rmCoalesce
+                        , raSpillStats  = spillStats
+                        , raSpillCosts  = spillCosts
+                        , raSpilled     = code_spilled }
+
+                -- Bundle up all the register allocator statistics.
+                --   .. but make sure to drop them on the floor if they're not
+                --      needed, otherwise we'll get a space leak.
+                let statList =
+                        if dump
+                                then [stat] ++ maybeToList stat1 ++ debug_codeGraphs
+                                else []
+
+                -- Ensure all the statistics are evaluated, to avoid space leaks.
+                seqList statList (return ())
+
+                regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'
+                              slotsCount' statList code_relive cfg
+
+
+-- | Build a graph from the liveness and coalesce information in this code.
+buildGraph
+        :: Instruction instr
+        => [LiveCmmDecl statics instr]
+        -> UniqSM (Color.Graph VirtualReg RegClass RealReg)
+
+buildGraph code
+ = do
+        -- Slurp out the conflicts and reg->reg moves from this code.
+        let (conflictList, moveList) =
+                unzip $ map slurpConflicts code
+
+        -- Slurp out the spill/reload coalesces.
+        let moveList2           = map slurpReloadCoalesce code
+
+        -- Add the reg-reg conflicts to the graph.
+        let conflictBag         = unionManyBags conflictList
+        let graph_conflict
+                = foldrBag graphAddConflictSet Color.initGraph conflictBag
+
+        -- Add the coalescences edges to the graph.
+        let moveBag
+                = unionBags (unionManyBags moveList2)
+                            (unionManyBags moveList)
+
+        let graph_coalesce
+                = foldrBag graphAddCoalesce graph_conflict moveBag
+
+        return  graph_coalesce
+
+
+-- | Add some conflict edges to the graph.
+--   Conflicts between virtual and real regs are recorded as exclusions.
+graphAddConflictSet
+        :: UniqSet Reg
+        -> Color.Graph VirtualReg RegClass RealReg
+        -> Color.Graph VirtualReg RegClass RealReg
+
+graphAddConflictSet set graph
+ = let  virtuals        = mkUniqSet
+                        [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]
+
+        graph1  = Color.addConflicts virtuals classOfVirtualReg graph
+
+        graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2)
+                        graph1
+                        [ (vr, rr)
+                                | RegVirtual vr <- nonDetEltsUniqSet set
+                                , RegReal    rr <- nonDetEltsUniqSet set]
+                          -- See Note [Unique Determinism and code generation]
+
+   in   graph2
+
+
+-- | Add some coalesence edges to the graph
+--   Coalesences between virtual and real regs are recorded as preferences.
+graphAddCoalesce
+        :: (Reg, Reg)
+        -> Color.Graph VirtualReg RegClass RealReg
+        -> Color.Graph VirtualReg RegClass RealReg
+
+graphAddCoalesce (r1, r2) graph
+        | RegReal rr            <- r1
+        , RegVirtual vr         <- r2
+        = Color.addPreference (vr, classOfVirtualReg vr) rr graph
+
+        | RegReal rr            <- r2
+        , RegVirtual vr         <- r1
+        = Color.addPreference (vr, classOfVirtualReg vr) rr graph
+
+        | RegVirtual vr1        <- r1
+        , RegVirtual vr2        <- r2
+        = Color.addCoalesce
+                (vr1, classOfVirtualReg vr1)
+                (vr2, classOfVirtualReg vr2)
+                graph
+
+        -- We can't coalesce two real regs, but there could well be existing
+        --      hreg,hreg moves in the input code. We'll just ignore these
+        --      for coalescing purposes.
+        | RegReal _             <- r1
+        , RegReal _             <- r2
+        = graph
+
+        | otherwise
+        = panic "graphAddCoalesce"
+
+
+-- | Patch registers in code using the reg -> reg mapping in this graph.
+patchRegsFromGraph
+        :: (Outputable statics, Outputable instr, Instruction instr)
+        => Platform -> Color.Graph VirtualReg RegClass RealReg
+        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
+
+patchRegsFromGraph platform graph code
+ = patchEraseLive patchF code
+ where
+        -- Function to lookup the hardreg for a virtual reg from the graph.
+        patchF reg
+                -- leave real regs alone.
+                | RegReal{}     <- reg
+                = reg
+
+                -- this virtual has a regular node in the graph.
+                | RegVirtual vr <- reg
+                , Just node     <- Color.lookupNode graph vr
+                = case Color.nodeColor node of
+                        Just color      -> RegReal    color
+                        Nothing         -> RegVirtual vr
+
+                -- no node in the graph for this virtual, bad news.
+                | otherwise
+                = pprPanic "patchRegsFromGraph: register mapping failed."
+                        (  text "There is no node in the graph for register "
+                                <> ppr reg
+                        $$ ppr code
+                        $$ Color.dotGraph
+                                (\_ -> text "white")
+                                (trivColorable platform
+                                        (targetVirtualRegSqueeze platform)
+                                        (targetRealRegSqueeze platform))
+                                graph)
+
+
+-----
+-- for when laziness just isn't what you wanted...
+--  We need to deepSeq the whole graph before trying to colour it to avoid
+--  space leaks.
+seqGraph :: Color.Graph VirtualReg RegClass RealReg -> ()
+seqGraph graph          = seqNodes (nonDetEltsUFM (Color.graphMap graph))
+   -- See Note [Unique Determinism and code generation]
+
+seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> ()
+seqNodes ns
+ = case ns of
+        []              -> ()
+        (n : ns)        -> seqNode n `seq` seqNodes ns
+
+seqNode :: Color.Node VirtualReg RegClass RealReg -> ()
+seqNode node
+        =     seqVirtualReg     (Color.nodeId node)
+        `seq` seqRegClass       (Color.nodeClass node)
+        `seq` seqMaybeRealReg   (Color.nodeColor node)
+        `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeConflicts node)))
+        `seq` (seqRealRegList    (nonDetEltsUniqSet (Color.nodeExclusions node)))
+        `seq` (seqRealRegList (Color.nodePreference node))
+        `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeCoalesce node)))
+              -- It's OK to use nonDetEltsUniqSet for seq
+
+seqVirtualReg :: VirtualReg -> ()
+seqVirtualReg reg = reg `seq` ()
+
+seqRealReg :: RealReg -> ()
+seqRealReg reg = reg `seq` ()
+
+seqRegClass :: RegClass -> ()
+seqRegClass c = c `seq` ()
+
+seqMaybeRealReg :: Maybe RealReg -> ()
+seqMaybeRealReg mr
+ = case mr of
+        Nothing         -> ()
+        Just r          -> seqRealReg r
+
+seqVirtualRegList :: [VirtualReg] -> ()
+seqVirtualRegList rs
+ = case rs of
+        []              -> ()
+        (r : rs)        -> seqVirtualReg r `seq` seqVirtualRegList rs
+
+seqRealRegList :: [RealReg] -> ()
+seqRealRegList rs
+ = case rs of
+        []              -> ()
+        (r : rs)        -> seqRealReg r `seq` seqRealRegList rs
diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs
@@ -0,0 +1,386 @@
+
+-- | When there aren't enough registers to hold all the vregs we have to spill
+--   some of those vregs to slots on the stack. This module is used modify the
+--   code to use those slots.
+module RegAlloc.Graph.Spill (
+        regSpill,
+        SpillStats(..),
+        accSpillSL
+) where
+import GhcPrelude
+
+import RegAlloc.Liveness
+import Instruction
+import Reg
+import Cmm hiding (RegSet)
+import BlockId
+import Hoopl.Collections
+
+import MonadUtils
+import State
+import Unique
+import UniqFM
+import UniqSet
+import UniqSupply
+import Outputable
+import Platform
+
+import Data.List
+import Data.Maybe
+import Data.IntSet              (IntSet)
+import qualified Data.IntSet    as IntSet
+
+
+-- | Spill all these virtual regs to stack slots.
+--
+--   Bumps the number of required stack slots if required.
+--
+--
+--   TODO: See if we can split some of the live ranges instead of just globally
+--         spilling the virtual reg. This might make the spill cleaner's job easier.
+--
+--   TODO: On CISCy x86 and x86_64 we don't necessarily have to add a mov instruction
+--         when making spills. If an instr is using a spilled virtual we may be able to
+--         address the spill slot directly.
+--
+regSpill
+        :: Instruction instr
+        => Platform
+        -> [LiveCmmDecl statics instr]  -- ^ the code
+        -> UniqSet Int                  -- ^ available stack slots
+        -> Int                          -- ^ current number of spill slots.
+        -> UniqSet VirtualReg           -- ^ the regs to spill
+        -> UniqSM
+            ([LiveCmmDecl statics instr]
+                 -- code with SPILL and RELOAD meta instructions added.
+            , UniqSet Int               -- left over slots
+            , Int                       -- slot count in use now.
+            , SpillStats )              -- stats about what happened during spilling
+
+regSpill platform code slotsFree slotCount regs
+
+        -- Not enough slots to spill these regs.
+        | sizeUniqSet slotsFree < sizeUniqSet regs
+        = -- pprTrace "Bumping slot count:" (ppr slotCount <> text " -> " <> ppr (slotCount+512)) $
+          let slotsFree' = (addListToUniqSet slotsFree [slotCount+1 .. slotCount+512])
+          in regSpill platform code slotsFree' (slotCount+512) regs
+
+        | otherwise
+        = do
+                -- Allocate a slot for each of the spilled regs.
+                let slots       = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree
+                let regSlotMap  = listToUFM
+                                $ zip (nonDetEltsUniqSet regs) slots
+                    -- This is non-deterministic but we do not
+                    -- currently support deterministic code-generation.
+                    -- See Note [Unique Determinism and code generation]
+
+                -- Grab the unique supply from the monad.
+                us      <- getUniqueSupplyM
+
+                -- Run the spiller on all the blocks.
+                let (code', state')     =
+                        runState (mapM (regSpill_top platform regSlotMap) code)
+                                 (initSpillS us)
+
+                return  ( code'
+                        , minusUniqSet slotsFree (mkUniqSet slots)
+                        , slotCount
+                        , makeSpillStats state')
+
+
+-- | Spill some registers to stack slots in a top-level thing.
+regSpill_top
+        :: Instruction instr
+        => Platform
+        -> RegMap Int
+                -- ^ map of vregs to slots they're being spilled to.
+        -> LiveCmmDecl statics instr
+                -- ^ the top level thing.
+        -> SpillM (LiveCmmDecl statics instr)
+
+regSpill_top platform regSlotMap cmm
+ = case cmm of
+        CmmData{}
+         -> return cmm
+
+        CmmProc info label live sccs
+         |  LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info
+         -> do
+                -- We should only passed Cmms with the liveness maps filled in,
+                -- but we'll create empty ones if they're not there just in case.
+                let liveVRegsOnEntry    = fromMaybe mapEmpty mLiveVRegsOnEntry
+
+                -- The liveVRegsOnEntry contains the set of vregs that are live
+                -- on entry to each basic block. If we spill one of those vregs
+                -- we remove it from that set and add the corresponding slot
+                -- number to the liveSlotsOnEntry set. The spill cleaner needs
+                -- this information to erase unneeded spill and reload instructions
+                -- after we've done a successful allocation.
+                let liveSlotsOnEntry' :: BlockMap IntSet
+                    liveSlotsOnEntry'
+                        = mapFoldlWithKey patchLiveSlot
+                                          liveSlotsOnEntry liveVRegsOnEntry
+
+                let info'
+                        = LiveInfo static firstId
+                                (Just liveVRegsOnEntry)
+                                liveSlotsOnEntry'
+
+                -- Apply the spiller to all the basic blocks in the CmmProc.
+                sccs'   <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs
+
+                return  $ CmmProc info' label live sccs'
+
+ where  -- Given a BlockId and the set of registers live in it,
+        -- if registers in this block are being spilled to stack slots,
+        -- then record the fact that these slots are now live in those blocks
+        -- in the given slotmap.
+        patchLiveSlot
+                :: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet
+
+        patchLiveSlot slotMap blockId regsLive
+         = let
+                -- Slots that are already recorded as being live.
+                curSlotsLive    = fromMaybe IntSet.empty
+                                $ mapLookup blockId slotMap
+
+                moreSlotsLive   = IntSet.fromList
+                                $ catMaybes
+                                $ map (lookupUFM regSlotMap)
+                                $ nonDetEltsUniqSet regsLive
+                    -- See Note [Unique Determinism and code generation]
+
+                slotMap'
+                 = mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive)
+                             slotMap
+
+           in   slotMap'
+
+
+-- | Spill some registers to stack slots in a basic block.
+regSpill_block
+        :: Instruction instr
+        => Platform
+        -> UniqFM Int   -- ^ map of vregs to slots they're being spilled to.
+        -> LiveBasicBlock instr
+        -> SpillM (LiveBasicBlock instr)
+
+regSpill_block platform regSlotMap (BasicBlock i instrs)
+ = do   instrss'        <- mapM (regSpill_instr platform regSlotMap) instrs
+        return  $ BasicBlock i (concat instrss')
+
+
+-- | Spill some registers to stack slots in a single instruction.
+--   If the instruction uses registers that need to be spilled, then it is
+--   prefixed (or postfixed) with the appropriate RELOAD or SPILL meta
+--   instructions.
+regSpill_instr
+        :: Instruction instr
+        => Platform
+        -> UniqFM Int -- ^ map of vregs to slots they're being spilled to.
+        -> LiveInstr instr
+        -> SpillM [LiveInstr instr]
+
+regSpill_instr _ _ li@(LiveInstr _ Nothing)
+ = do   return [li]
+
+regSpill_instr platform regSlotMap
+        (LiveInstr instr (Just _))
+ = do
+        -- work out which regs are read and written in this instr
+        let RU rlRead rlWritten = regUsageOfInstr platform instr
+
+        -- sometimes a register is listed as being read more than once,
+        --      nub this so we don't end up inserting two lots of spill code.
+        let rsRead_             = nub rlRead
+        let rsWritten_          = nub rlWritten
+
+        -- if a reg is modified, it appears in both lists, want to undo this..
+        let rsRead              = rsRead_    \\ rsWritten_
+        let rsWritten           = rsWritten_ \\ rsRead_
+        let rsModify            = intersect rsRead_ rsWritten_
+
+        -- work out if any of the regs being used are currently being spilled.
+        let rsSpillRead         = filter (\r -> elemUFM r regSlotMap) rsRead
+        let rsSpillWritten      = filter (\r -> elemUFM r regSlotMap) rsWritten
+        let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify
+
+        -- rewrite the instr and work out spill code.
+        (instr1, prepost1)      <- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead
+        (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten
+        (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify
+
+        let (mPrefixes, mPostfixes)     = unzip (prepost1 ++ prepost2 ++ prepost3)
+        let prefixes                    = concat mPrefixes
+        let postfixes                   = concat mPostfixes
+
+        -- final code
+        let instrs'     =  prefixes
+                        ++ [LiveInstr instr3 Nothing]
+                        ++ postfixes
+
+        return $ instrs'
+
+
+-- | Add a RELOAD met a instruction to load a value for an instruction that
+--   writes to a vreg that is being spilled.
+spillRead
+        :: Instruction instr
+        => UniqFM Int
+        -> instr
+        -> Reg
+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
+
+spillRead regSlotMap instr reg
+ | Just slot     <- lookupUFM regSlotMap reg
+ = do    (instr', nReg)  <- patchInstr reg instr
+
+         modify $ \s -> s
+                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
+
+         return  ( instr'
+                 , ( [LiveInstr (RELOAD slot nReg) Nothing]
+                 , []) )
+
+ | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"
+
+
+-- | Add a SPILL meta instruction to store a value for an instruction that
+--   writes to a vreg that is being spilled.
+spillWrite
+        :: Instruction instr
+        => UniqFM Int
+        -> instr
+        -> Reg
+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
+
+spillWrite regSlotMap instr reg
+ | Just slot     <- lookupUFM regSlotMap reg
+ = do    (instr', nReg)  <- patchInstr reg instr
+
+         modify $ \s -> s
+                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
+
+         return  ( instr'
+                 , ( []
+                   , [LiveInstr (SPILL nReg slot) Nothing]))
+
+ | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg"
+
+
+-- | Add both RELOAD and SPILL meta instructions for an instruction that
+--   both reads and writes to a vreg that is being spilled.
+spillModify
+        :: Instruction instr
+        => UniqFM Int
+        -> instr
+        -> Reg
+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
+
+spillModify regSlotMap instr reg
+ | Just slot     <- lookupUFM regSlotMap reg
+ = do    (instr', nReg)  <- patchInstr reg instr
+
+         modify $ \s -> s
+                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
+
+         return  ( instr'
+                 , ( [LiveInstr (RELOAD slot nReg) Nothing]
+                   , [LiveInstr (SPILL nReg slot) Nothing]))
+
+ | otherwise     = panic "RegSpill.spillModify: no slot defined for spilled reg"
+
+
+-- | Rewrite uses of this virtual reg in an instr to use a different
+--   virtual reg.
+patchInstr
+        :: Instruction instr
+        => Reg -> instr -> SpillM (instr, Reg)
+
+patchInstr reg instr
+ = do   nUnique         <- newUnique
+
+        -- The register we're rewriting is suppoed to be virtual.
+        -- If it's not then something has gone horribly wrong.
+        let nReg
+             = case reg of
+                RegVirtual vr
+                 -> RegVirtual (renameVirtualReg nUnique vr)
+
+                RegReal{}
+                 -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg"
+
+        let instr'      = patchReg1 reg nReg instr
+        return          (instr', nReg)
+
+
+patchReg1
+        :: Instruction instr
+        => Reg -> Reg -> instr -> instr
+
+patchReg1 old new instr
+ = let  patchF r
+                | r == old      = new
+                | otherwise     = r
+   in   patchRegsOfInstr instr patchF
+
+
+-- Spiller monad --------------------------------------------------------------
+-- | State monad for the spill code generator.
+type SpillM a
+        = State SpillS a
+
+-- | Spill code generator state.
+data SpillS
+        = SpillS
+        { -- | Unique supply for generating fresh vregs.
+          stateUS       :: UniqSupply
+
+          -- | Spilled vreg vs the number of times it was loaded, stored.
+        , stateSpillSL  :: UniqFM (Reg, Int, Int) }
+
+
+-- | Create a new spiller state.
+initSpillS :: UniqSupply -> SpillS
+initSpillS uniqueSupply
+        = SpillS
+        { stateUS       = uniqueSupply
+        , stateSpillSL  = emptyUFM }
+
+
+-- | Allocate a new unique in the spiller monad.
+newUnique :: SpillM Unique
+newUnique
+ = do   us      <- gets stateUS
+        case takeUniqFromSupply us of
+         (uniq, us')
+          -> do modify $ \s -> s { stateUS = us' }
+                return uniq
+
+
+-- | Add a spill/reload count to a stats record for a register.
+accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)
+accSpillSL (r1, s1, l1) (_, s2, l2)
+        = (r1, s1 + s2, l1 + l2)
+
+
+-- Spiller stats --------------------------------------------------------------
+-- | Spiller statistics.
+--   Tells us what registers were spilled.
+data SpillStats
+        = SpillStats
+        { spillStoreLoad        :: UniqFM (Reg, Int, Int) }
+
+
+-- | Extract spiller statistics from the spiller state.
+makeSpillStats :: SpillS -> SpillStats
+makeSpillStats s
+        = SpillStats
+        { spillStoreLoad        = stateSpillSL s }
+
+
+instance Outputable SpillStats where
+ ppr stats
+        = pprUFM (spillStoreLoad stats)
+                 (vcat . map (\(r, s, l) -> ppr r <+> int s <+> int l))
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
@@ -0,0 +1,614 @@
+
+-- | Clean out unneeded spill\/reload instructions.
+--
+--   Handling of join points
+--   ~~~~~~~~~~~~~~~~~~~~~~~
+--
+--   B1:                          B2:
+--    ...                          ...
+--       RELOAD SLOT(0), %r1          RELOAD SLOT(0), %r1
+--       ... A ...                    ... B ...
+--       jump B3                      jump B3
+--
+--                B3: ... C ...
+--                    RELOAD SLOT(0), %r1
+--                    ...
+--
+--   The Plan
+--   ~~~~~~~~
+--   As long as %r1 hasn't been written to in A, B or C then we don't need
+--   the reload in B3.
+--
+--   What we really care about here is that on the entry to B3, %r1 will
+--   always have the same value that is in SLOT(0) (ie, %r1 is _valid_)
+--
+--   This also works if the reloads in B1\/B2 were spills instead, because
+--   spilling %r1 to a slot makes that slot have the same value as %r1.
+--
+module RegAlloc.Graph.SpillClean (
+        cleanSpills
+) where
+import GhcPrelude
+
+import RegAlloc.Liveness
+import Instruction
+import Reg
+
+import BlockId
+import Cmm
+import UniqSet
+import UniqFM
+import Unique
+import State
+import Outputable
+import Platform
+import Hoopl.Collections
+
+import Data.List
+import Data.Maybe
+import Data.IntSet              (IntSet)
+import qualified Data.IntSet    as IntSet
+
+
+-- | The identification number of a spill slot.
+--   A value is stored in a spill slot when we don't have a free
+--   register to hold it.
+type Slot = Int
+
+
+-- | Clean out unneeded spill\/reloads from this top level thing.
+cleanSpills
+        :: Instruction instr
+        => Platform
+        -> LiveCmmDecl statics instr
+        -> LiveCmmDecl statics instr
+
+cleanSpills platform cmm
+        = evalState (cleanSpin platform 0 cmm) initCleanS
+
+
+-- | Do one pass of cleaning.
+cleanSpin
+        :: Instruction instr
+        => Platform
+        -> Int                              -- ^ Iteration number for the cleaner.
+        -> LiveCmmDecl statics instr        -- ^ Liveness annotated code to clean.
+        -> CleanM (LiveCmmDecl statics instr)
+
+cleanSpin platform spinCount code
+ = do
+        -- Initialise count of cleaned spill and reload instructions.
+        modify $ \s -> s
+                { sCleanedSpillsAcc     = 0
+                , sCleanedReloadsAcc    = 0
+                , sReloadedBy           = emptyUFM }
+
+        code_forward    <- mapBlockTopM (cleanBlockForward platform) code
+        code_backward   <- cleanTopBackward code_forward
+
+        -- During the cleaning of each block we collected information about
+        -- what regs were valid across each jump. Based on this, work out
+        -- whether it will be safe to erase reloads after join points for
+        -- the next pass.
+        collateJoinPoints
+
+        -- Remember how many spill and reload instructions we cleaned in this pass.
+        spills          <- gets sCleanedSpillsAcc
+        reloads         <- gets sCleanedReloadsAcc
+        modify $ \s -> s
+                { sCleanedCount = (spills, reloads) : sCleanedCount s }
+
+        -- If nothing was cleaned in this pass or the last one
+        --      then we're done and it's time to bail out.
+        cleanedCount    <- gets sCleanedCount
+        if take 2 cleanedCount == [(0, 0), (0, 0)]
+           then return code
+
+        -- otherwise go around again
+           else cleanSpin platform (spinCount + 1) code_backward
+
+
+-------------------------------------------------------------------------------
+-- | Clean out unneeded reload instructions,
+--   while walking forward over the code.
+cleanBlockForward
+        :: Instruction instr
+        => Platform
+        -> LiveBasicBlock instr
+        -> CleanM (LiveBasicBlock instr)
+
+cleanBlockForward platform (BasicBlock blockId instrs)
+ = do
+        -- See if we have a valid association for the entry to this block.
+        jumpValid       <- gets sJumpValid
+        let assoc       = case lookupUFM jumpValid blockId of
+                                Just assoc      -> assoc
+                                Nothing         -> emptyAssoc
+
+        instrs_reload   <- cleanForward platform blockId assoc [] instrs
+        return  $ BasicBlock blockId instrs_reload
+
+
+
+-- | Clean out unneeded reload instructions.
+--
+--   Walking forwards across the code
+--     On a reload, if we know a reg already has the same value as a slot
+--     then we don't need to do the reload.
+--
+cleanForward
+        :: Instruction instr
+        => Platform
+        -> BlockId                  -- ^ the block that we're currently in
+        -> Assoc Store              -- ^ two store locations are associated if
+                                    --     they have the same value
+        -> [LiveInstr instr]        -- ^ acc
+        -> [LiveInstr instr]        -- ^ instrs to clean (in backwards order)
+        -> CleanM [LiveInstr instr] -- ^ cleaned instrs  (in forward   order)
+
+cleanForward _ _ _ acc []
+        = return acc
+
+-- Rewrite live range joins via spill slots to just a spill and a reg-reg move
+-- hopefully the spill will be also be cleaned in the next pass
+cleanForward platform blockId assoc acc (li1 : li2 : instrs)
+
+        | LiveInstr (SPILL  reg1  slot1) _      <- li1
+        , LiveInstr (RELOAD slot2 reg2)  _      <- li2
+        , slot1 == slot2
+        = do
+                modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
+                cleanForward platform blockId assoc acc
+                 $ li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing
+                       : instrs
+
+cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs)
+        | Just (r1, r2) <- takeRegRegMoveInstr i1
+        = if r1 == r2
+                -- Erase any left over nop reg reg moves while we're here
+                -- this will also catch any nop moves that the previous case
+                -- happens to add.
+                then cleanForward platform blockId assoc acc instrs
+
+                -- If r1 has the same value as some slots and we copy r1 to r2,
+                --      then r2 is now associated with those slots instead
+                else do let assoc'      = addAssoc (SReg r1) (SReg r2)
+                                        $ delAssoc (SReg r2)
+                                        $ assoc
+
+                        cleanForward platform blockId assoc' (li : acc) instrs
+
+
+cleanForward platform blockId assoc acc (li : instrs)
+
+        -- Update association due to the spill.
+        | LiveInstr (SPILL reg slot) _  <- li
+        = let   assoc'  = addAssoc (SReg reg)  (SSlot slot)
+                        $ delAssoc (SSlot slot)
+                        $ assoc
+          in    cleanForward platform blockId assoc' (li : acc) instrs
+
+        -- Clean a reload instr.
+        | LiveInstr (RELOAD{}) _        <- li
+        = do    (assoc', mli)   <- cleanReload platform blockId assoc li
+                case mli of
+                 Nothing        -> cleanForward platform blockId assoc' acc
+                                                instrs
+
+                 Just li'       -> cleanForward platform blockId assoc' (li' : acc)
+                                                instrs
+
+        -- Remember the association over a jump.
+        | LiveInstr instr _     <- li
+        , targets               <- jumpDestsOfInstr instr
+        , not $ null targets
+        = do    mapM_ (accJumpValid assoc) targets
+                cleanForward platform blockId assoc (li : acc) instrs
+
+        -- Writing to a reg changes its value.
+        | LiveInstr instr _     <- li
+        , RU _ written          <- regUsageOfInstr platform instr
+        = let assoc'    = foldr delAssoc assoc (map SReg $ nub written)
+          in  cleanForward platform blockId assoc' (li : acc) instrs
+
+
+
+-- | Try and rewrite a reload instruction to something more pleasing
+cleanReload
+        :: Instruction instr
+        => Platform
+        -> BlockId
+        -> Assoc Store
+        -> LiveInstr instr
+        -> CleanM (Assoc Store, Maybe (LiveInstr instr))
+
+cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _)
+
+        -- If the reg we're reloading already has the same value as the slot
+        --      then we can erase the instruction outright.
+        | elemAssoc (SSlot slot) (SReg reg) assoc
+        = do    modify  $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
+                return  (assoc, Nothing)
+
+        -- If we can find another reg with the same value as this slot then
+        --      do a move instead of a reload.
+        | Just reg2     <- findRegOfSlot assoc slot
+        = do    modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }
+
+                let assoc'      = addAssoc (SReg reg) (SReg reg2)
+                                $ delAssoc (SReg reg)
+                                $ assoc
+
+                return  ( assoc'
+                        , Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing)
+
+        -- Gotta keep this instr.
+        | otherwise
+        = do    -- Update the association.
+                let assoc'
+                        = addAssoc (SReg reg)  (SSlot slot)
+                                -- doing the reload makes reg and slot the same value
+                        $ delAssoc (SReg reg)
+                                -- reg value changes on reload
+                        $ assoc
+
+                -- Remember that this block reloads from this slot.
+                accBlockReloadsSlot blockId slot
+
+                return  (assoc', Just li)
+
+cleanReload _ _ _ _
+        = panic "RegSpillClean.cleanReload: unhandled instr"
+
+
+-------------------------------------------------------------------------------
+-- | Clean out unneeded spill instructions,
+--   while walking backwards over the code.
+--
+--      If there were no reloads from a slot between a spill and the last one
+--      then the slot was never read and we don't need the spill.
+--
+--      SPILL   r0 -> s1
+--      RELOAD  s1 -> r2
+--      SPILL   r3 -> s1        <--- don't need this spill
+--      SPILL   r4 -> s1
+--      RELOAD  s1 -> r5
+--
+--      Maintain a set of
+--              "slots which were spilled to but not reloaded from yet"
+--
+--      Walking backwards across the code:
+--       a) On a reload from a slot, remove it from the set.
+--
+--       a) On a spill from a slot
+--              If the slot is in set then we can erase the spill,
+--               because it won't be reloaded from until after the next spill.
+--
+--              otherwise
+--               keep the spill and add the slot to the set
+--
+-- TODO: This is mostly inter-block
+--       we should really be updating the noReloads set as we cross jumps also.
+--
+-- TODO: generate noReloads from liveSlotsOnEntry
+--
+cleanTopBackward
+        :: Instruction instr
+        => LiveCmmDecl statics instr
+        -> CleanM (LiveCmmDecl statics instr)
+
+cleanTopBackward cmm
+ = case cmm of
+        CmmData{}
+         -> return cmm
+
+        CmmProc info label live sccs
+         | LiveInfo _ _ _ liveSlotsOnEntry <- info
+         -> do  sccs'   <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs
+                return  $ CmmProc info label live sccs'
+
+
+cleanBlockBackward
+        :: Instruction instr
+        => BlockMap IntSet
+        -> LiveBasicBlock instr
+        -> CleanM (LiveBasicBlock instr)
+
+cleanBlockBackward liveSlotsOnEntry (BasicBlock blockId instrs)
+ = do   instrs_spill    <- cleanBackward liveSlotsOnEntry  emptyUniqSet  [] instrs
+        return  $ BasicBlock blockId instrs_spill
+
+
+
+cleanBackward
+        :: Instruction instr
+        => BlockMap IntSet          -- ^ Slots live on entry to each block
+        -> UniqSet Int              -- ^ Slots that have been spilled, but not reloaded from
+        -> [LiveInstr instr]        -- ^ acc
+        -> [LiveInstr instr]        -- ^ Instrs to clean (in forwards order)
+        -> CleanM [LiveInstr instr] -- ^ Cleaned instrs  (in backwards order)
+
+cleanBackward liveSlotsOnEntry noReloads acc lis
+ = do   reloadedBy      <- gets sReloadedBy
+        cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc lis
+
+
+cleanBackward'
+        :: Instruction instr
+        => BlockMap IntSet
+        -> UniqFM [BlockId]
+        -> UniqSet Int
+        -> [LiveInstr instr]
+        -> [LiveInstr instr]
+        -> State CleanS [LiveInstr instr]
+
+cleanBackward' _ _ _      acc []
+        = return  acc
+
+cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs)
+
+        -- If nothing ever reloads from this slot then we don't need the spill.
+        | LiveInstr (SPILL _ slot) _    <- li
+        , Nothing       <- lookupUFM reloadedBy (SSlot slot)
+        = do    modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
+                cleanBackward liveSlotsOnEntry noReloads acc instrs
+
+        | LiveInstr (SPILL _ slot) _    <- li
+        = if elementOfUniqSet slot noReloads
+
+           -- We can erase this spill because the slot won't be read until
+           -- after the next one
+           then do
+                modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }
+                cleanBackward liveSlotsOnEntry noReloads acc instrs
+
+           else do
+                -- This slot is being spilled to, but we haven't seen any reloads yet.
+                let noReloads'  = addOneToUniqSet noReloads slot
+                cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
+
+        -- if we reload from a slot then it's no longer unused
+        | LiveInstr (RELOAD slot _) _   <- li
+        , noReloads'            <- delOneFromUniqSet noReloads slot
+        = cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
+
+        -- If a slot is live in a jump target then assume it's reloaded there.
+        --
+        -- TODO: A real dataflow analysis would do a better job here.
+        --       If the target block _ever_ used the slot then we assume
+        --       it always does, but if those reloads are cleaned the slot
+        --       liveness map doesn't get updated.
+        | LiveInstr instr _     <- li
+        , targets               <- jumpDestsOfInstr instr
+        = do
+                let slotsReloadedByTargets
+                        = IntSet.unions
+                        $ catMaybes
+                        $ map (flip mapLookup liveSlotsOnEntry)
+                        $ targets
+
+                let noReloads'
+                        = foldl' delOneFromUniqSet noReloads
+                        $ IntSet.toList slotsReloadedByTargets
+
+                cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs
+
+        -- some other instruction
+        | otherwise
+        = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs
+
+
+-- | Combine the associations from all the inward control flow edges.
+--
+collateJoinPoints :: CleanM ()
+collateJoinPoints
+ = modify $ \s -> s
+        { sJumpValid    = mapUFM intersects (sJumpValidAcc s)
+        , sJumpValidAcc = emptyUFM }
+
+intersects :: [Assoc Store]     -> Assoc Store
+intersects []           = emptyAssoc
+intersects assocs       = foldl1' intersectAssoc assocs
+
+
+-- | See if we have a reg with the same value as this slot in the association table.
+findRegOfSlot :: Assoc Store -> Int -> Maybe Reg
+findRegOfSlot assoc slot
+        | close                 <- closeAssoc (SSlot slot) assoc
+        , Just (SReg reg)       <- find isStoreReg $ nonDetEltsUniqSet close
+           -- See Note [Unique Determinism and code generation]
+        = Just reg
+
+        | otherwise
+        = Nothing
+
+
+-------------------------------------------------------------------------------
+-- | Cleaner monad.
+type CleanM
+        = State CleanS
+
+-- | Cleaner state.
+data CleanS
+        = CleanS
+        { -- | Regs which are valid at the start of each block.
+          sJumpValid            :: UniqFM (Assoc Store)
+
+          -- | Collecting up what regs were valid across each jump.
+          --    in the next pass we can collate these and write the results
+          --    to sJumpValid.
+        , sJumpValidAcc         :: UniqFM [Assoc Store]
+
+          -- | Map of (slot -> blocks which reload from this slot)
+          --    used to decide if whether slot spilled to will ever be
+          --    reloaded from on this path.
+        , sReloadedBy           :: UniqFM [BlockId]
+
+          -- | Spills and reloads cleaned each pass (latest at front)
+        , sCleanedCount         :: [(Int, Int)]
+
+          -- | Spills and reloads that have been cleaned in this pass so far.
+        , sCleanedSpillsAcc     :: Int
+        , sCleanedReloadsAcc    :: Int }
+
+
+-- | Construct the initial cleaner state.
+initCleanS :: CleanS
+initCleanS
+        = CleanS
+        { sJumpValid            = emptyUFM
+        , sJumpValidAcc         = emptyUFM
+
+        , sReloadedBy           = emptyUFM
+
+        , sCleanedCount         = []
+
+        , sCleanedSpillsAcc     = 0
+        , sCleanedReloadsAcc    = 0 }
+
+
+-- | Remember the associations before a jump.
+accJumpValid :: Assoc Store -> BlockId -> CleanM ()
+accJumpValid assocs target
+ = modify $ \s -> s {
+        sJumpValidAcc = addToUFM_C (++)
+                                (sJumpValidAcc s)
+                                target
+                                [assocs] }
+
+
+accBlockReloadsSlot :: BlockId -> Slot -> CleanM ()
+accBlockReloadsSlot blockId slot
+ = modify $ \s -> s {
+        sReloadedBy = addToUFM_C (++)
+                                (sReloadedBy s)
+                                (SSlot slot)
+                                [blockId] }
+
+
+-------------------------------------------------------------------------------
+-- A store location can be a stack slot or a register
+data Store
+        = SSlot Int
+        | SReg  Reg
+
+
+-- | Check if this is a reg store.
+isStoreReg :: Store -> Bool
+isStoreReg ss
+ = case ss of
+        SSlot _ -> False
+        SReg  _ -> True
+
+
+-- Spill cleaning is only done once all virtuals have been allocated to realRegs
+instance Uniquable Store where
+    getUnique (SReg  r)
+        | RegReal (RealRegSingle i)     <- r
+        = mkRegSingleUnique i
+
+        | RegReal (RealRegPair r1 r2)   <- r
+        = mkRegPairUnique (r1 * 65535 + r2)
+
+        | otherwise
+        = error $ "RegSpillClean.getUnique: found virtual reg during spill clean,"
+                ++ "only real regs expected."
+
+    getUnique (SSlot i) = mkRegSubUnique i    -- [SLPJ] I hope "SubUnique" is ok
+
+
+instance Outputable Store where
+        ppr (SSlot i)   = text "slot" <> int i
+        ppr (SReg  r)   = ppr r
+
+
+-------------------------------------------------------------------------------
+-- Association graphs.
+-- In the spill cleaner, two store locations are associated if they are known
+-- to hold the same value.
+--
+type Assoc a    = UniqFM (UniqSet a)
+
+-- | An empty association
+emptyAssoc :: Assoc a
+emptyAssoc      = emptyUFM
+
+
+-- | Add an association between these two things.
+addAssoc :: Uniquable a
+         => a -> a -> Assoc a -> Assoc a
+
+addAssoc a b m
+ = let  m1      = addToUFM_C unionUniqSets m  a (unitUniqSet b)
+        m2      = addToUFM_C unionUniqSets m1 b (unitUniqSet a)
+   in   m2
+
+
+-- | Delete all associations to a node.
+delAssoc :: (Uniquable a)
+         => a -> Assoc a -> Assoc a
+
+delAssoc a m
+        | Just aSet     <- lookupUFM  m a
+        , m1            <- delFromUFM m a
+        = nonDetFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet
+          -- It's OK to use nonDetFoldUFM here because deletion is commutative
+
+        | otherwise     = m
+
+
+-- | Delete a single association edge (a -> b).
+delAssoc1 :: Uniquable a
+          => a -> a -> Assoc a -> Assoc a
+
+delAssoc1 a b m
+        | Just aSet     <- lookupUFM m a
+        = addToUFM m a (delOneFromUniqSet aSet b)
+
+        | otherwise     = m
+
+
+-- | Check if these two things are associated.
+elemAssoc :: (Uniquable a)
+          => a -> a -> Assoc a -> Bool
+
+elemAssoc a b m
+        = elementOfUniqSet b (closeAssoc a m)
+
+
+-- | Find the refl. trans. closure of the association from this point.
+closeAssoc :: (Uniquable a)
+        => a -> Assoc a -> UniqSet a
+
+closeAssoc a assoc
+ =      closeAssoc' assoc emptyUniqSet (unitUniqSet a)
+ where
+        closeAssoc' assoc visited toVisit
+         = case nonDetEltsUniqSet toVisit of
+             -- See Note [Unique Determinism and code generation]
+
+                -- nothing else to visit, we're done
+                []      -> visited
+
+                (x:_)
+                 -- we've already seen this node
+                 |  elementOfUniqSet x visited
+                 -> closeAssoc' assoc visited (delOneFromUniqSet toVisit x)
+
+                 -- haven't seen this node before,
+                 --     remember to visit all its neighbors
+                 |  otherwise
+                 -> let neighbors
+                         = case lookupUFM assoc x of
+                                Nothing         -> emptyUniqSet
+                                Just set        -> set
+
+                   in closeAssoc' assoc
+                        (addOneToUniqSet visited x)
+                        (unionUniqSets   toVisit neighbors)
+
+-- | Intersect two associations.
+intersectAssoc :: Assoc a -> Assoc a -> Assoc a
+intersectAssoc a b
+        = intersectUFM_C (intersectUniqSets) a b
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs
@@ -0,0 +1,310 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module RegAlloc.Graph.SpillCost (
+        SpillCostRecord,
+        plusSpillCostRecord,
+        pprSpillCostRecord,
+
+        SpillCostInfo,
+        zeroSpillCostInfo,
+        plusSpillCostInfo,
+
+        slurpSpillCostInfo,
+        chooseSpill,
+
+        lifeMapFromSpillCostInfo
+) where
+import GhcPrelude
+
+import RegAlloc.Liveness
+import Instruction
+import RegClass
+import Reg
+
+import GraphBase
+
+import Hoopl.Collections (mapLookup)
+import Cmm
+import UniqFM
+import UniqSet
+import Digraph          (flattenSCCs)
+import Outputable
+import Platform
+import State
+import CFG
+
+import Data.List        (nub, minimumBy)
+import Data.Maybe
+import Control.Monad (join)
+
+
+-- | Records the expected cost to spill some regster.
+type SpillCostRecord
+ =      ( VirtualReg    -- register name
+        , Int           -- number of writes to this reg
+        , Int           -- number of reads from this reg
+        , Int)          -- number of instrs this reg was live on entry to
+
+
+-- | Map of `SpillCostRecord`
+type SpillCostInfo
+        = UniqFM SpillCostRecord
+
+-- | Block membership in a loop
+type LoopMember = Bool
+
+type SpillCostState = State (UniqFM SpillCostRecord) ()
+
+-- | An empty map of spill costs.
+zeroSpillCostInfo :: SpillCostInfo
+zeroSpillCostInfo       = emptyUFM
+
+
+-- | Add two spill cost infos.
+plusSpillCostInfo :: SpillCostInfo -> SpillCostInfo -> SpillCostInfo
+plusSpillCostInfo sc1 sc2
+        = plusUFM_C plusSpillCostRecord sc1 sc2
+
+
+-- | Add two spill cost records.
+plusSpillCostRecord :: SpillCostRecord -> SpillCostRecord -> SpillCostRecord
+plusSpillCostRecord (r1, a1, b1, c1) (r2, a2, b2, c2)
+        | r1 == r2      = (r1, a1 + a2, b1 + b2, c1 + c2)
+        | otherwise     = error "RegSpillCost.plusRegInt: regs don't match"
+
+
+-- | Slurp out information used for determining spill costs.
+--
+--   For each vreg, the number of times it was written to, read from,
+--   and the number of instructions it was live on entry to (lifetime)
+--
+slurpSpillCostInfo :: forall instr statics. (Outputable instr, Instruction instr)
+                   => Platform
+                   -> Maybe CFG
+                   -> LiveCmmDecl statics instr
+                   -> SpillCostInfo
+
+slurpSpillCostInfo platform cfg cmm
+        = execState (countCmm cmm) zeroSpillCostInfo
+ where
+        countCmm CmmData{}              = return ()
+        countCmm (CmmProc info _ _ sccs)
+                = mapM_ (countBlock info)
+                $ flattenSCCs sccs
+
+        -- Lookup the regs that are live on entry to this block in
+        --      the info table from the CmmProc.
+        countBlock info (BasicBlock blockId instrs)
+                | LiveInfo _ _ (Just blockLive) _ <- info
+                , Just rsLiveEntry  <- mapLookup blockId blockLive
+                , rsLiveEntry_virt  <- takeVirtuals rsLiveEntry
+                = countLIs (loopMember blockId) rsLiveEntry_virt instrs
+
+                | otherwise
+                = error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block"
+
+        countLIs :: LoopMember -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState
+        countLIs _      _      []
+                = return ()
+
+        -- Skip over comment and delta pseudo instrs.
+        countLIs inLoop rsLive (LiveInstr instr Nothing : lis)
+                | isMetaInstr instr
+                = countLIs inLoop rsLive lis
+
+                | otherwise
+                = pprPanic "RegSpillCost.slurpSpillCostInfo"
+                $ text "no liveness information on instruction " <> ppr instr
+
+        countLIs inLoop rsLiveEntry (LiveInstr instr (Just live) : lis)
+         = do
+                -- Increment the lifetime counts for regs live on entry to this instr.
+                mapM_ (incLifetime (loopCount inLoop)) $ nonDetEltsUniqSet rsLiveEntry
+                    -- This is non-deterministic but we do not
+                    -- currently support deterministic code-generation.
+                    -- See Note [Unique Determinism and code generation]
+
+                -- Increment counts for what regs were read/written from.
+                let (RU read written)   = regUsageOfInstr platform instr
+                mapM_ (incUses (loopCount inLoop)) $ catMaybes $ map takeVirtualReg $ nub read
+                mapM_ (incDefs (loopCount inLoop)) $ catMaybes $ map takeVirtualReg $ nub written
+
+                -- Compute liveness for entry to next instruction.
+                let liveDieRead_virt    = takeVirtuals (liveDieRead  live)
+                let liveDieWrite_virt   = takeVirtuals (liveDieWrite live)
+                let liveBorn_virt       = takeVirtuals (liveBorn     live)
+
+                let rsLiveAcross
+                        = rsLiveEntry `minusUniqSet` liveDieRead_virt
+
+                let rsLiveNext
+                        = (rsLiveAcross `unionUniqSets` liveBorn_virt)
+                                        `minusUniqSet`  liveDieWrite_virt
+
+                countLIs inLoop rsLiveNext lis
+
+        loopCount inLoop
+          | inLoop = 10
+          | otherwise = 1
+        incDefs     count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, count, 0, 0)
+        incUses     count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, count, 0)
+        incLifetime count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, count)
+
+        loopBlocks = CFG.loopMembers <$> cfg
+        loopMember bid
+          | Just isMember <- join (mapLookup bid <$> loopBlocks)
+          = isMember
+          | otherwise
+          = False
+
+-- | Take all the virtual registers from this set.
+takeVirtuals :: UniqSet Reg -> UniqSet VirtualReg
+takeVirtuals set = mkUniqSet
+  [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]
+  -- See Note [Unique Determinism and code generation]
+
+
+-- | Choose a node to spill from this graph
+chooseSpill
+        :: SpillCostInfo
+        -> Graph VirtualReg RegClass RealReg
+        -> VirtualReg
+
+chooseSpill info graph
+ = let  cost    = spillCost_length info graph
+        node    = minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2))
+                $ nonDetEltsUFM $ graphMap graph
+                -- See Note [Unique Determinism and code generation]
+
+   in   nodeId node
+
+
+-------------------------------------------------------------------------------
+-- | Chaitins spill cost function is:
+--
+--   cost =     sum         loadCost * freq (u)  +    sum        storeCost * freq (d)
+--          u <- uses (v)                         d <- defs (v)
+--
+--   There are no loops in our code at the moment, so we can set the freq's to 1.
+--
+--  If we don't have live range splitting then Chaitins function performs badly
+--  if we have lots of nested live ranges and very few registers.
+--
+--               v1 v2 v3
+--      def v1   .
+--      use v1   .
+--      def v2   .  .
+--      def v3   .  .  .
+--      use v1   .  .  .
+--      use v3   .  .  .
+--      use v2   .  .
+--      use v1   .
+--
+--           defs uses degree   cost
+--      v1:  1     3     3      1.5
+--      v2:  1     2     3      1.0
+--      v3:  1     1     3      0.666
+--
+--   v3 has the lowest cost, but if we only have 2 hardregs and we insert
+--   spill code for v3 then this isn't going to improve the colorability of
+--   the graph.
+--
+--  When compiling SHA1, which as very long basic blocks and some vregs
+--  with very long live ranges the allocator seems to try and spill from
+--  the inside out and eventually run out of stack slots.
+--
+--  Without live range splitting, its's better to spill from the outside
+--  in so set the cost of very long live ranges to zero
+--
+{-
+spillCost_chaitin
+        :: SpillCostInfo
+        -> Graph Reg RegClass Reg
+        -> Reg
+        -> Float
+
+spillCost_chaitin info graph reg
+        -- Spilling a live range that only lives for 1 instruction
+        -- isn't going to help us at all - and we definitely want to avoid
+        -- trying to re-spill previously inserted spill code.
+        | lifetime <= 1         = 1/0
+
+        -- It's unlikely that we'll find a reg for a live range this long
+        -- better to spill it straight up and not risk trying to keep it around
+        -- and have to go through the build/color cycle again.
+        | lifetime > allocatableRegsInClass (regClass reg) * 10
+        = 0
+
+        -- Otherwise revert to chaitin's regular cost function.
+        | otherwise     = fromIntegral (uses + defs)
+                        / fromIntegral (nodeDegree graph reg)
+        where (_, defs, uses, lifetime)
+                = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg
+-}
+
+-- Just spill the longest live range.
+spillCost_length
+        :: SpillCostInfo
+        -> Graph VirtualReg RegClass RealReg
+        -> VirtualReg
+        -> Float
+
+spillCost_length info _ reg
+        | lifetime <= 1         = 1/0
+        | otherwise             = 1 / fromIntegral lifetime
+        where (_, _, _, lifetime)
+                = fromMaybe (reg, 0, 0, 0)
+                $ lookupUFM info reg
+
+
+-- | Extract a map of register lifetimes from a `SpillCostInfo`.
+lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (VirtualReg, Int)
+lifeMapFromSpillCostInfo info
+        = listToUFM
+        $ map (\(r, _, _, life) -> (r, (r, life)))
+        $ nonDetEltsUFM info
+        -- See Note [Unique Determinism and code generation]
+
+
+-- | Determine the degree (number of neighbors) of this node which
+--   have the same class.
+nodeDegree
+        :: (VirtualReg -> RegClass)
+        -> Graph VirtualReg RegClass RealReg
+        -> VirtualReg
+        -> Int
+
+nodeDegree classOfVirtualReg graph reg
+        | Just node     <- lookupUFM (graphMap graph) reg
+
+        , virtConflicts
+           <- length
+           $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg)
+           $ nonDetEltsUniqSet
+           -- See Note [Unique Determinism and code generation]
+           $ nodeConflicts node
+
+        = virtConflicts + sizeUniqSet (nodeExclusions node)
+
+        | otherwise
+        = 0
+
+
+-- | Show a spill cost record, including the degree from the graph
+--   and final calulated spill cost.
+pprSpillCostRecord
+        :: (VirtualReg -> RegClass)
+        -> (Reg -> SDoc)
+        -> Graph VirtualReg RegClass RealReg
+        -> SpillCostRecord
+        -> SDoc
+
+pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life)
+        =  hsep
+        [ pprReg (RegVirtual reg)
+        , ppr uses
+        , ppr defs
+        , ppr life
+        , ppr $ nodeDegree regClass graph reg
+        , text $ show $ (fromIntegral (uses + defs)
+                       / fromIntegral (nodeDegree regClass graph reg) :: Float) ]
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs
@@ -0,0 +1,347 @@
+{-# LANGUAGE BangPatterns, CPP #-}
+
+-- | Carries interesting info for debugging / profiling of the
+--   graph coloring register allocator.
+module RegAlloc.Graph.Stats (
+        RegAllocStats (..),
+
+        pprStats,
+        pprStatsSpills,
+        pprStatsLifetimes,
+        pprStatsConflict,
+        pprStatsLifeConflict,
+
+        countSRMs, addSRM
+) where
+
+#include "nativeGen/NCG.h"
+
+import GhcPrelude
+
+import qualified GraphColor as Color
+import RegAlloc.Liveness
+import RegAlloc.Graph.Spill
+import RegAlloc.Graph.SpillCost
+import RegAlloc.Graph.TrivColorable
+import Instruction
+import RegClass
+import Reg
+import TargetReg
+
+import PprCmm()
+import Outputable
+import UniqFM
+import UniqSet
+import State
+
+-- | Holds interesting statistics from the register allocator.
+data RegAllocStats statics instr
+
+        -- Information about the initial conflict graph.
+        = RegAllocStatsStart
+        { -- | Initial code, with liveness.
+          raLiveCmm     :: [LiveCmmDecl statics instr]
+
+          -- | The initial, uncolored graph.
+        , raGraph       :: Color.Graph VirtualReg RegClass RealReg
+
+          -- | Information to help choose which regs to spill.
+        , raSpillCosts  :: SpillCostInfo }
+
+
+        -- Information about an intermediate graph.
+        -- This is one that we couldn't color, so had to insert spill code
+        -- instruction stream.
+        | RegAllocStatsSpill
+        { -- | Code we tried to allocate registers for.
+          raCode        :: [LiveCmmDecl statics instr]
+
+          -- | Partially colored graph.
+        , raGraph       :: Color.Graph VirtualReg RegClass RealReg
+
+          -- | The regs that were coalesced.
+        , raCoalesced   :: UniqFM VirtualReg
+
+          -- | Spiller stats.
+        , raSpillStats  :: SpillStats
+
+          -- | Number of instructions each reg lives for.
+        , raSpillCosts  :: SpillCostInfo
+
+          -- | Code with spill instructions added.
+        , raSpilled     :: [LiveCmmDecl statics instr] }
+
+
+        -- a successful coloring
+        | RegAllocStatsColored
+        { -- | Code we tried to allocate registers for.
+          raCode          :: [LiveCmmDecl statics instr]
+
+          -- | Uncolored graph.
+        , raGraph         :: Color.Graph VirtualReg RegClass RealReg
+
+          -- | Coalesced and colored graph.
+        , raGraphColored  :: Color.Graph VirtualReg RegClass RealReg
+
+          -- | Regs that were coalesced.
+        , raCoalesced     :: UniqFM VirtualReg
+
+          -- | Code with coalescings applied.
+        , raCodeCoalesced :: [LiveCmmDecl statics instr]
+
+          -- | Code with vregs replaced by hregs.
+        , raPatched       :: [LiveCmmDecl statics instr]
+
+          -- | Code with unneeded spill\/reloads cleaned out.
+        , raSpillClean    :: [LiveCmmDecl statics instr]
+
+          -- | Final code.
+        , raFinal         :: [NatCmmDecl statics instr]
+
+          -- | Spill\/reload\/reg-reg moves present in this code.
+        , raSRMs          :: (Int, Int, Int) }
+
+
+instance (Outputable statics, Outputable instr)
+       => Outputable (RegAllocStats statics instr) where
+
+ ppr (s@RegAllocStatsStart{}) = sdocWithPlatform $ \platform ->
+           text "#  Start"
+        $$ text "#  Native code with liveness information."
+        $$ ppr (raLiveCmm s)
+        $$ text ""
+        $$ text "#  Initial register conflict graph."
+        $$ Color.dotGraph
+                (targetRegDotColor platform)
+                (trivColorable platform
+                        (targetVirtualRegSqueeze platform)
+                        (targetRealRegSqueeze platform))
+                (raGraph s)
+
+
+ ppr (s@RegAllocStatsSpill{}) =
+           text "#  Spill"
+
+        $$ text "#  Code with liveness information."
+        $$ ppr (raCode s)
+        $$ text ""
+
+        $$ (if (not $ isNullUFM $ raCoalesced s)
+                then    text "#  Registers coalesced."
+                        $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr)
+                        $$ text ""
+                else empty)
+
+        $$ text "#  Spills inserted."
+        $$ ppr (raSpillStats s)
+        $$ text ""
+
+        $$ text "#  Code with spills inserted."
+        $$ ppr (raSpilled s)
+
+
+ ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) })
+    = sdocWithPlatform $ \platform ->
+           text "#  Colored"
+
+        $$ text "#  Code with liveness information."
+        $$ ppr (raCode s)
+        $$ text ""
+
+        $$ text "#  Register conflict graph (colored)."
+        $$ Color.dotGraph
+                (targetRegDotColor platform)
+                (trivColorable platform
+                        (targetVirtualRegSqueeze platform)
+                        (targetRealRegSqueeze platform))
+                (raGraphColored s)
+        $$ text ""
+
+        $$ (if (not $ isNullUFM $ raCoalesced s)
+                then    text "#  Registers coalesced."
+                        $$ pprUFMWithKeys (raCoalesced s) (vcat . map ppr)
+                        $$ text ""
+                else empty)
+
+        $$ text "#  Native code after coalescings applied."
+        $$ ppr (raCodeCoalesced s)
+        $$ text ""
+
+        $$ text "#  Native code after register allocation."
+        $$ ppr (raPatched s)
+        $$ text ""
+
+        $$ text "#  Clean out unneeded spill/reloads."
+        $$ ppr (raSpillClean s)
+        $$ text ""
+
+        $$ text "#  Final code, after rewriting spill/rewrite pseudo instrs."
+        $$ ppr (raFinal s)
+        $$ text ""
+        $$  text "#  Score:"
+        $$ (text "#          spills  inserted: " <> int spills)
+        $$ (text "#          reloads inserted: " <> int reloads)
+        $$ (text "#   reg-reg moves remaining: " <> int moves)
+        $$ text ""
+
+
+-- | Do all the different analysis on this list of RegAllocStats
+pprStats
+        :: [RegAllocStats statics instr]
+        -> Color.Graph VirtualReg RegClass RealReg
+        -> SDoc
+
+pprStats stats graph
+ = let  outSpills       = pprStatsSpills    stats
+        outLife         = pprStatsLifetimes stats
+        outConflict     = pprStatsConflict  stats
+        outScatter      = pprStatsLifeConflict stats graph
+
+  in    vcat [outSpills, outLife, outConflict, outScatter]
+
+
+-- | Dump a table of how many spill loads \/ stores were inserted for each vreg.
+pprStatsSpills
+        :: [RegAllocStats statics instr] -> SDoc
+
+pprStatsSpills stats
+ = let
+        finals  = [ s   | s@RegAllocStatsColored{} <- stats]
+
+        -- sum up how many stores\/loads\/reg-reg-moves were left in the code
+        total   = foldl' addSRM (0, 0, 0)
+                $ map raSRMs finals
+
+    in  (  text "-- spills-added-total"
+        $$ text "--    (stores, loads, reg_reg_moves_remaining)"
+        $$ ppr total
+        $$ text "")
+
+
+-- | Dump a table of how long vregs tend to live for in the initial code.
+pprStatsLifetimes
+        :: [RegAllocStats statics instr] -> SDoc
+
+pprStatsLifetimes stats
+ = let  info            = foldl' plusSpillCostInfo zeroSpillCostInfo
+                                [ raSpillCosts s
+                                        | s@RegAllocStatsStart{} <- stats ]
+
+        lifeBins        = binLifetimeCount $ lifeMapFromSpillCostInfo info
+
+   in   (  text "-- vreg-population-lifetimes"
+        $$ text "--   (instruction_count, number_of_vregs_that_lived_that_long)"
+        $$ pprUFM lifeBins (vcat . map ppr)
+        $$ text "\n")
+
+
+binLifetimeCount :: UniqFM (VirtualReg, Int) -> UniqFM (Int, Int)
+binLifetimeCount fm
+ = let  lifes   = map (\l -> (l, (l, 1)))
+                $ map snd
+                $ nonDetEltsUFM fm
+                -- See Note [Unique Determinism and code generation]
+
+   in   addListToUFM_C
+                (\(l1, c1) (_, c2) -> (l1, c1 + c2))
+                emptyUFM
+                lifes
+
+
+-- | Dump a table of how many conflicts vregs tend to have in the initial code.
+pprStatsConflict
+        :: [RegAllocStats statics instr] -> SDoc
+
+pprStatsConflict stats
+ = let  confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2)))
+                        emptyUFM
+                $ map Color.slurpNodeConflictCount
+                        [ raGraph s | s@RegAllocStatsStart{} <- stats ]
+
+   in   (  text "-- vreg-conflicts"
+        $$ text "--   (conflict_count, number_of_vregs_that_had_that_many_conflicts)"
+        $$ pprUFM confMap (vcat . map ppr)
+        $$ text "\n")
+
+
+-- | For every vreg, dump how many conflicts it has, and its lifetime.
+--      Good for making a scatter plot.
+pprStatsLifeConflict
+        :: [RegAllocStats statics instr]
+        -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph
+        -> SDoc
+
+pprStatsLifeConflict stats graph
+ = let  lifeMap = lifeMapFromSpillCostInfo
+                $ foldl' plusSpillCostInfo zeroSpillCostInfo
+                $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]
+
+        scatter = map   (\r ->  let lifetime  = case lookupUFM lifeMap r of
+                                                      Just (_, l) -> l
+                                                      Nothing     -> 0
+                                    Just node = Color.lookupNode graph r
+                                in parens $ hcat $ punctuate (text ", ")
+                                        [ doubleQuotes $ ppr $ Color.nodeId node
+                                        , ppr $ sizeUniqSet (Color.nodeConflicts node)
+                                        , ppr $ lifetime ])
+                $ map Color.nodeId
+                $ nonDetEltsUFM
+                -- See Note [Unique Determinism and code generation]
+                $ Color.graphMap graph
+
+   in   (  text "-- vreg-conflict-lifetime"
+        $$ text "--   (vreg, vreg_conflicts, vreg_lifetime)"
+        $$ (vcat scatter)
+        $$ text "\n")
+
+
+-- | Count spill/reload/reg-reg moves.
+--      Lets us see how well the register allocator has done.
+countSRMs
+        :: Instruction instr
+        => LiveCmmDecl statics instr -> (Int, Int, Int)
+
+countSRMs cmm
+        = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)
+
+
+countSRM_block
+        :: Instruction instr
+        => GenBasicBlock (LiveInstr instr)
+        -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr))
+
+countSRM_block (BasicBlock i instrs)
+ = do   instrs' <- mapM countSRM_instr instrs
+        return  $ BasicBlock i instrs'
+
+
+countSRM_instr
+        :: Instruction instr
+        => LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)
+
+countSRM_instr li
+        | LiveInstr SPILL{} _    <- li
+        = do    modify  $ \(s, r, m)    -> (s + 1, r, m)
+                return li
+
+        | LiveInstr RELOAD{} _  <- li
+        = do    modify  $ \(s, r, m)    -> (s, r + 1, m)
+                return li
+
+        | LiveInstr instr _     <- li
+        , Just _        <- takeRegRegMoveInstr instr
+        = do    modify  $ \(s, r, m)    -> (s, r, m + 1)
+                return li
+
+        | otherwise
+        =       return li
+
+
+-- sigh..
+addSRM :: (Int, Int, Int) -> (Int, Int, Int) -> (Int, Int, Int)
+addSRM (s1, r1, m1) (s2, r2, m2)
+ = let  !s = s1 + s2
+        !r = r1 + r2
+        !m = m1 + m2
+   in   (s, r, m)
+
diff --git a/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs
@@ -0,0 +1,285 @@
+{-# LANGUAGE CPP #-}
+
+module RegAlloc.Graph.TrivColorable (
+        trivColorable,
+)
+
+where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import RegClass
+import Reg
+
+import GraphBase
+
+import UniqSet
+import Platform
+import Panic
+
+-- trivColorable ---------------------------------------------------------------
+
+-- trivColorable function for the graph coloring allocator
+--
+--      This gets hammered by scanGraph during register allocation,
+--      so needs to be fairly efficient.
+--
+--      NOTE:   This only works for arcitectures with just RcInteger and RcDouble
+--              (which are disjoint) ie. x86, x86_64 and ppc
+--
+--      The number of allocatable regs is hard coded in here so we can do
+--              a fast comparison in trivColorable.
+--
+--      It's ok if these numbers are _less_ than the actual number of free
+--              regs, but they can't be more or the register conflict
+--              graph won't color.
+--
+--      If the graph doesn't color then the allocator will panic, but it won't
+--              generate bad object code or anything nasty like that.
+--
+--      There is an allocatableRegsInClass :: RegClass -> Int, but doing
+--      the unboxing is too slow for us here.
+--      TODO: Is that still true? Could we use allocatableRegsInClass
+--      without losing performance now?
+--
+--      Look at includes/stg/MachRegs.h to get the numbers.
+--
+
+
+-- Disjoint registers ----------------------------------------------------------
+--
+--      The definition has been unfolded into individual cases for speed.
+--      Each architecture has a different register setup, so we use a
+--      different regSqueeze function for each.
+--
+accSqueeze
+        :: Int
+        -> Int
+        -> (reg -> Int)
+        -> UniqSet reg
+        -> Int
+
+accSqueeze count maxCount squeeze us = acc count (nonDetEltsUniqSet us)
+  -- See Note [Unique Determinism and code generation]
+  where acc count [] = count
+        acc count _ | count >= maxCount = count
+        acc count (r:rs) = acc (count + squeeze r) rs
+
+{- Note [accSqueeze]
+~~~~~~~~~~~~~~~~~~~~
+BL 2007/09
+Doing a nice fold over the UniqSet makes trivColorable use
+32% of total compile time and 42% of total alloc when compiling SHA1.hs from darcs.
+Therefore the UniqFM is made non-abstract and we use custom fold.
+
+MS 2010/04
+When converting UniqFM to use Data.IntMap, the fold cannot use UniqFM internal
+representation any more. But it is imperative that the accSqueeze stops
+the folding if the count gets greater or equal to maxCount. We thus convert
+UniqFM to a (lazy) list, do the fold and stops if necessary, which was
+the most efficient variant tried. Benchmark compiling 10-times SHA1.hs follows.
+(original = previous implementation, folding = fold of the whole UFM,
+ lazyFold = the current implementation,
+ hackFold = using internal representation of Data.IntMap)
+
+                                 original  folding   hackFold  lazyFold
+ -O -fasm (used everywhere)      31.509s   30.387s   30.791s   30.603s
+                                 100.00%   96.44%    97.72%    97.12%
+ -fregs-graph                    67.938s   74.875s   62.673s   64.679s
+                                 100.00%   110.21%   92.25%    95.20%
+ -fregs-iterative                89.761s   143.913s  81.075s   86.912s
+                                 100.00%   160.33%   90.32%    96.83%
+ -fnew-codegen                   38.225s   37.142s   37.551s   37.119s
+                                 100.00%   97.17%    98.24%    97.11%
+ -fnew-codegen -fregs-graph      91.786s   91.51s    87.368s   86.88s
+                                 100.00%   99.70%    95.19%    94.65%
+ -fnew-codegen -fregs-iterative  206.72s   343.632s  194.694s  208.677s
+                                 100.00%   166.23%   94.18%    100.95%
+-}
+
+trivColorable
+        :: Platform
+        -> (RegClass -> VirtualReg -> Int)
+        -> (RegClass -> RealReg    -> Int)
+        -> Triv VirtualReg RegClass RealReg
+
+trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions
+        | let cALLOCATABLE_REGS_INTEGER
+                  =        (case platformArch platform of
+                            ArchX86       -> 3
+                            ArchX86_64    -> 5
+                            ArchPPC       -> 16
+                            ArchSPARC     -> 14
+                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"
+                            ArchPPC_64 _  -> 15
+                            ArchARM _ _ _ -> panic "trivColorable ArchARM"
+                            ArchARM64     -> panic "trivColorable ArchARM64"
+                            ArchAlpha     -> panic "trivColorable ArchAlpha"
+                            ArchMipseb    -> panic "trivColorable ArchMipseb"
+                            ArchMipsel    -> panic "trivColorable ArchMipsel"
+                            ArchJavaScript-> panic "trivColorable ArchJavaScript"
+                            ArchUnknown   -> panic "trivColorable ArchUnknown")
+        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_INTEGER
+                                (virtualRegSqueeze RcInteger)
+                                conflicts
+
+        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_INTEGER
+                                (realRegSqueeze   RcInteger)
+                                exclusions
+
+        = count3 < cALLOCATABLE_REGS_INTEGER
+
+trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions
+        | let cALLOCATABLE_REGS_FLOAT
+                  =        (case platformArch platform of
+                            ArchX86       -> 0
+                            ArchX86_64    -> 0
+                            ArchPPC       -> 0
+                            ArchSPARC     -> 22
+                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"
+                            ArchPPC_64 _  -> 0
+                            ArchARM _ _ _ -> panic "trivColorable ArchARM"
+                            ArchARM64     -> panic "trivColorable ArchARM64"
+                            ArchAlpha     -> panic "trivColorable ArchAlpha"
+                            ArchMipseb    -> panic "trivColorable ArchMipseb"
+                            ArchMipsel    -> panic "trivColorable ArchMipsel"
+                            ArchJavaScript-> panic "trivColorable ArchJavaScript"
+                            ArchUnknown   -> panic "trivColorable ArchUnknown")
+        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_FLOAT
+                                (virtualRegSqueeze RcFloat)
+                                conflicts
+
+        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_FLOAT
+                                (realRegSqueeze   RcFloat)
+                                exclusions
+
+        = count3 < cALLOCATABLE_REGS_FLOAT
+
+trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions
+        | let cALLOCATABLE_REGS_DOUBLE
+                  =        (case platformArch platform of
+                            ArchX86       -> 6
+                            ArchX86_64    -> 0
+                            ArchPPC       -> 26
+                            ArchSPARC     -> 11
+                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"
+                            ArchPPC_64 _  -> 20
+                            ArchARM _ _ _ -> panic "trivColorable ArchARM"
+                            ArchARM64     -> panic "trivColorable ArchARM64"
+                            ArchAlpha     -> panic "trivColorable ArchAlpha"
+                            ArchMipseb    -> panic "trivColorable ArchMipseb"
+                            ArchMipsel    -> panic "trivColorable ArchMipsel"
+                            ArchJavaScript-> panic "trivColorable ArchJavaScript"
+                            ArchUnknown   -> panic "trivColorable ArchUnknown")
+        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_DOUBLE
+                                (virtualRegSqueeze RcDouble)
+                                conflicts
+
+        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_DOUBLE
+                                (realRegSqueeze   RcDouble)
+                                exclusions
+
+        = count3 < cALLOCATABLE_REGS_DOUBLE
+
+trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions
+        | let cALLOCATABLE_REGS_SSE
+                  =        (case platformArch platform of
+                            ArchX86       -> 8
+                            ArchX86_64    -> 10
+                            ArchPPC       -> 0
+                            ArchSPARC     -> 0
+                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"
+                            ArchPPC_64 _  -> 0
+                            ArchARM _ _ _ -> panic "trivColorable ArchARM"
+                            ArchARM64     -> panic "trivColorable ArchARM64"
+                            ArchAlpha     -> panic "trivColorable ArchAlpha"
+                            ArchMipseb    -> panic "trivColorable ArchMipseb"
+                            ArchMipsel    -> panic "trivColorable ArchMipsel"
+                            ArchJavaScript-> panic "trivColorable ArchJavaScript"
+                            ArchUnknown   -> panic "trivColorable ArchUnknown")
+        , count2        <- accSqueeze 0 cALLOCATABLE_REGS_SSE
+                                (virtualRegSqueeze RcDoubleSSE)
+                                conflicts
+
+        , count3        <- accSqueeze  count2    cALLOCATABLE_REGS_SSE
+                                (realRegSqueeze   RcDoubleSSE)
+                                exclusions
+
+        = count3 < cALLOCATABLE_REGS_SSE
+
+
+-- Specification Code ----------------------------------------------------------
+--
+--      The trivColorable function for each particular architecture should
+--      implement the following function, but faster.
+--
+
+{-
+trivColorable :: RegClass -> UniqSet Reg -> UniqSet Reg -> Bool
+trivColorable classN conflicts exclusions
+ = let
+
+        acc :: Reg -> (Int, Int) -> (Int, Int)
+        acc r (cd, cf)
+         = case regClass r of
+                RcInteger       -> (cd+1, cf)
+                RcFloat         -> (cd,   cf+1)
+                _               -> panic "Regs.trivColorable: reg class not handled"
+
+        tmp                     = nonDetFoldUFM acc (0, 0) conflicts
+        (countInt,  countFloat) = nonDetFoldUFM acc tmp    exclusions
+
+        squeese         = worst countInt   classN RcInteger
+                        + worst countFloat classN RcFloat
+
+   in   squeese < allocatableRegsInClass classN
+
+-- | Worst case displacement
+--      node N of classN has n neighbors of class C.
+--
+--      We currently only have RcInteger and RcDouble, which don't conflict at all.
+--      This is a bit boring compared to what's in RegArchX86.
+--
+worst :: Int -> RegClass -> RegClass -> Int
+worst n classN classC
+ = case classN of
+        RcInteger
+         -> case classC of
+                RcInteger       -> min n (allocatableRegsInClass RcInteger)
+                RcFloat         -> 0
+
+        RcDouble
+         -> case classC of
+                RcFloat         -> min n (allocatableRegsInClass RcFloat)
+                RcInteger       -> 0
+
+-- allocatableRegs is allMachRegNos with the fixed-use regs removed.
+-- i.e., these are the regs for which we are prepared to allow the
+-- register allocator to attempt to map VRegs to.
+allocatableRegs :: [RegNo]
+allocatableRegs
+   = let isFree i = freeReg i
+     in  filter isFree allMachRegNos
+
+
+-- | The number of regs in each class.
+--      We go via top level CAFs to ensure that we're not recomputing
+--      the length of these lists each time the fn is called.
+allocatableRegsInClass :: RegClass -> Int
+allocatableRegsInClass cls
+ = case cls of
+        RcInteger       -> allocatableRegsInteger
+        RcFloat         -> allocatableRegsDouble
+
+allocatableRegsInteger :: Int
+allocatableRegsInteger
+        = length $ filter (\r -> regClass r == RcInteger)
+                 $ map RealReg allocatableRegs
+
+allocatableRegsFloat :: Int
+allocatableRegsFloat
+        = length $ filter (\r -> regClass r == RcFloat
+                 $ map RealReg allocatableRegs
+-}
diff --git a/compiler/nativeGen/RegAlloc/Linear/Base.hs b/compiler/nativeGen/RegAlloc/Linear/Base.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/Base.hs
@@ -0,0 +1,141 @@
+
+-- | Put common type definitions here to break recursive module dependencies.
+
+module RegAlloc.Linear.Base (
+        BlockAssignment,
+
+        Loc(..),
+        regsOfLoc,
+
+        -- for stats
+        SpillReason(..),
+        RegAllocStats(..),
+
+        -- the allocator monad
+        RA_State(..),
+)
+
+where
+
+import GhcPrelude
+
+import RegAlloc.Linear.StackMap
+import RegAlloc.Liveness
+import Reg
+
+import DynFlags
+import Outputable
+import Unique
+import UniqFM
+import UniqSupply
+import BlockId
+
+
+-- | Used to store the register assignment on entry to a basic block.
+--      We use this to handle join points, where multiple branch instructions
+--      target a particular label. We have to insert fixup code to make
+--      the register assignments from the different sources match up.
+--
+type BlockAssignment freeRegs
+        = BlockMap (freeRegs, RegMap Loc)
+
+
+-- | Where a vreg is currently stored
+--      A temporary can be marked as living in both a register and memory
+--      (InBoth), for example if it was recently loaded from a spill location.
+--      This makes it cheap to spill (no save instruction required), but we
+--      have to be careful to turn this into InReg if the value in the
+--      register is changed.
+
+--      This is also useful when a temporary is about to be clobbered.  We
+--      save it in a spill location, but mark it as InBoth because the current
+--      instruction might still want to read it.
+--
+data Loc
+        -- | vreg is in a register
+        = InReg   !RealReg
+
+        -- | vreg is held in a stack slot
+        | InMem   {-# UNPACK #-}  !StackSlot
+
+
+        -- | vreg is held in both a register and a stack slot
+        | InBoth   !RealReg
+                   {-# UNPACK #-} !StackSlot
+        deriving (Eq, Show, Ord)
+
+instance Outputable Loc where
+        ppr l = text (show l)
+
+
+-- | Get the reg numbers stored in this Loc.
+regsOfLoc :: Loc -> [RealReg]
+regsOfLoc (InReg r)    = [r]
+regsOfLoc (InBoth r _) = [r]
+regsOfLoc (InMem _)    = []
+
+
+-- | Reasons why instructions might be inserted by the spiller.
+--      Used when generating stats for -ddrop-asm-stats.
+--
+data SpillReason
+        -- | vreg was spilled to a slot so we could use its
+        --      current hreg for another vreg
+        = SpillAlloc    !Unique
+
+        -- | vreg was moved because its hreg was clobbered
+        | SpillClobber  !Unique
+
+        -- | vreg was loaded from a spill slot
+        | SpillLoad     !Unique
+
+        -- | reg-reg move inserted during join to targets
+        | SpillJoinRR   !Unique
+
+        -- | reg-mem move inserted during join to targets
+        | SpillJoinRM   !Unique
+
+
+-- | Used to carry interesting stats out of the register allocator.
+data RegAllocStats
+        = RegAllocStats
+        { ra_spillInstrs        :: UniqFM [Int]
+        , ra_fixupList     :: [(BlockId,BlockId,BlockId)]
+        -- ^ (from,fixup,to) : We inserted fixup code between from and to
+        }
+
+
+-- | The register allocator state
+data RA_State freeRegs
+        = RA_State
+
+        {
+        -- | the current mapping from basic blocks to
+        --      the register assignments at the beginning of that block.
+          ra_blockassig :: BlockAssignment freeRegs
+
+        -- | free machine registers
+        , ra_freeregs   :: !freeRegs
+
+        -- | assignment of temps to locations
+        , ra_assig      :: RegMap Loc
+
+        -- | current stack delta
+        , ra_delta      :: Int
+
+        -- | free stack slots for spilling
+        , ra_stack      :: StackMap
+
+        -- | unique supply for generating names for join point fixup blocks.
+        , ra_us         :: UniqSupply
+
+        -- | Record why things were spilled, for -ddrop-asm-stats.
+        --      Just keep a list here instead of a map of regs -> reasons.
+        --      We don't want to slow down the allocator if we're not going to emit the stats.
+        , ra_spills     :: [SpillReason]
+        , ra_DynFlags   :: DynFlags
+
+        -- | (from,fixup,to) : We inserted fixup code between from and to
+        , ra_fixups     :: [(BlockId,BlockId,BlockId)] }
+
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE CPP #-}
+
+module RegAlloc.Linear.FreeRegs (
+    FR(..),
+    maxSpillSlots
+)
+
+#include "HsVersions.h"
+
+where
+
+import GhcPrelude
+
+import Reg
+import RegClass
+
+import DynFlags
+import Panic
+import Platform
+
+-- -----------------------------------------------------------------------------
+-- The free register set
+-- This needs to be *efficient*
+-- Here's an inefficient 'executable specification' of the FreeRegs data type:
+--
+--      type FreeRegs = [RegNo]
+--      noFreeRegs = 0
+--      releaseReg n f = if n `elem` f then f else (n : f)
+--      initFreeRegs = allocatableRegs
+--      getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f
+--      allocateReg f r = filter (/= r) f
+
+import qualified RegAlloc.Linear.PPC.FreeRegs    as PPC
+import qualified RegAlloc.Linear.SPARC.FreeRegs  as SPARC
+import qualified RegAlloc.Linear.X86.FreeRegs    as X86
+import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64
+
+import qualified PPC.Instr
+import qualified SPARC.Instr
+import qualified X86.Instr
+
+class Show freeRegs => FR freeRegs where
+    frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs
+    frGetFreeRegs :: Platform -> RegClass -> freeRegs -> [RealReg]
+    frInitFreeRegs :: Platform -> freeRegs
+    frReleaseReg :: Platform -> RealReg -> freeRegs -> freeRegs
+
+instance FR X86.FreeRegs where
+    frAllocateReg  = \_ -> X86.allocateReg
+    frGetFreeRegs  = X86.getFreeRegs
+    frInitFreeRegs = X86.initFreeRegs
+    frReleaseReg   = \_ -> X86.releaseReg
+
+instance FR X86_64.FreeRegs where
+    frAllocateReg  = \_ -> X86_64.allocateReg
+    frGetFreeRegs  = X86_64.getFreeRegs
+    frInitFreeRegs = X86_64.initFreeRegs
+    frReleaseReg   = \_ -> X86_64.releaseReg
+
+instance FR PPC.FreeRegs where
+    frAllocateReg  = \_ -> PPC.allocateReg
+    frGetFreeRegs  = \_ -> PPC.getFreeRegs
+    frInitFreeRegs = PPC.initFreeRegs
+    frReleaseReg   = \_ -> PPC.releaseReg
+
+instance FR SPARC.FreeRegs where
+    frAllocateReg  = SPARC.allocateReg
+    frGetFreeRegs  = \_ -> SPARC.getFreeRegs
+    frInitFreeRegs = SPARC.initFreeRegs
+    frReleaseReg   = SPARC.releaseReg
+
+maxSpillSlots :: DynFlags -> Int
+maxSpillSlots dflags
+              = case platformArch (targetPlatform dflags) of
+                ArchX86       -> X86.Instr.maxSpillSlots dflags
+                ArchX86_64    -> X86.Instr.maxSpillSlots dflags
+                ArchPPC       -> PPC.Instr.maxSpillSlots dflags
+                ArchSPARC     -> SPARC.Instr.maxSpillSlots dflags
+                ArchSPARC64   -> panic "maxSpillSlots ArchSPARC64"
+                ArchARM _ _ _ -> panic "maxSpillSlots ArchARM"
+                ArchARM64     -> panic "maxSpillSlots ArchARM64"
+                ArchPPC_64 _  -> PPC.Instr.maxSpillSlots dflags
+                ArchAlpha     -> panic "maxSpillSlots ArchAlpha"
+                ArchMipseb    -> panic "maxSpillSlots ArchMipseb"
+                ArchMipsel    -> panic "maxSpillSlots ArchMipsel"
+                ArchJavaScript-> panic "maxSpillSlots ArchJavaScript"
+                ArchUnknown   -> panic "maxSpillSlots ArchUnknown"
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
@@ -0,0 +1,377 @@
+
+-- | Handles joining of a jump instruction to its targets.
+
+--      The first time we encounter a jump to a particular basic block, we
+--      record the assignment of temporaries.  The next time we encounter a
+--      jump to the same block, we compare our current assignment to the
+--      stored one.  They might be different if spilling has occurred in one
+--      branch; so some fixup code will be required to match up the assignments.
+--
+module RegAlloc.Linear.JoinToTargets (joinToTargets) where
+
+import GhcPrelude
+
+import RegAlloc.Linear.State
+import RegAlloc.Linear.Base
+import RegAlloc.Linear.FreeRegs
+import RegAlloc.Liveness
+import Instruction
+import Reg
+
+import BlockId
+import Hoopl.Collections
+import Digraph
+import DynFlags
+import Outputable
+import Unique
+import UniqFM
+import UniqSet
+
+-- | For a jump instruction at the end of a block, generate fixup code so its
+--      vregs are in the correct regs for its destination.
+--
+joinToTargets
+        :: (FR freeRegs, Instruction instr, Outputable instr)
+        => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs
+                                        --      that are known to be live on the entry to each block.
+
+        -> BlockId                      -- ^ id of the current block
+        -> instr                        -- ^ branch instr on the end of the source block.
+
+        -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code.
+                         , instr)               -- the original branch
+                                                -- instruction, but maybe
+                                                -- patched to jump
+                                                -- to a fixup block first.
+
+joinToTargets block_live id instr
+
+        -- we only need to worry about jump instructions.
+        | not $ isJumpishInstr instr
+        = return ([], instr)
+
+        | otherwise
+        = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr)
+
+-----
+joinToTargets'
+        :: (FR freeRegs, Instruction instr, Outputable instr)
+        => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs
+                                        --      that are known to be live on the entry to each block.
+
+        -> [NatBasicBlock instr]        -- ^ acc blocks of fixup code.
+
+        -> BlockId                      -- ^ id of the current block
+        -> instr                        -- ^ branch instr on the end of the source block.
+
+        -> [BlockId]                    -- ^ branch destinations still to consider.
+
+        -> RegM freeRegs ([NatBasicBlock instr], instr)
+
+-- no more targets to consider. all done.
+joinToTargets' _          new_blocks _ instr []
+        = return (new_blocks, instr)
+
+-- handle a branch target.
+joinToTargets' block_live new_blocks block_id instr (dest:dests)
+ = do
+        -- get the map of where the vregs are stored on entry to each basic block.
+        block_assig     <- getBlockAssigR
+
+        -- get the assignment on entry to the branch instruction.
+        assig           <- getAssigR
+
+        -- adjust the current assignment to remove any vregs that are not live
+        -- on entry to the destination block.
+        let Just live_set       = mapLookup dest block_live
+        let still_live uniq _   = uniq `elemUniqSet_Directly` live_set
+        let adjusted_assig      = filterUFM_Directly still_live assig
+
+        -- and free up those registers which are now free.
+        let to_free =
+                [ r     | (reg, loc) <- nonDetUFMToList assig
+                        -- This is non-deterministic but we do not
+                        -- currently support deterministic code-generation.
+                        -- See Note [Unique Determinism and code generation]
+                        , not (elemUniqSet_Directly reg live_set)
+                        , r          <- regsOfLoc loc ]
+
+        case mapLookup dest block_assig of
+         Nothing
+          -> joinToTargets_first
+                        block_live new_blocks block_id instr dest dests
+                        block_assig adjusted_assig to_free
+
+         Just (_, dest_assig)
+          -> joinToTargets_again
+                        block_live new_blocks block_id instr dest dests
+                        adjusted_assig dest_assig
+
+
+-- this is the first time we jumped to this block.
+joinToTargets_first :: (FR freeRegs, Instruction instr, Outputable instr)
+                    => BlockMap RegSet
+                    -> [NatBasicBlock instr]
+                    -> BlockId
+                    -> instr
+                    -> BlockId
+                    -> [BlockId]
+                    -> BlockAssignment freeRegs
+                    -> RegMap Loc
+                    -> [RealReg]
+                    -> RegM freeRegs ([NatBasicBlock instr], instr)
+joinToTargets_first block_live new_blocks block_id instr dest dests
+        block_assig src_assig
+        to_free
+
+ = do   dflags <- getDynFlags
+        let platform = targetPlatform dflags
+
+        -- free up the regs that are not live on entry to this block.
+        freeregs        <- getFreeRegsR
+        let freeregs' = foldl' (flip $ frReleaseReg platform) freeregs to_free
+
+        -- remember the current assignment on entry to this block.
+        setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig)
+
+        joinToTargets' block_live new_blocks block_id instr dests
+
+
+-- we've jumped to this block before
+joinToTargets_again :: (Instruction instr, FR freeRegs, Outputable instr)
+                    => BlockMap RegSet
+                    -> [NatBasicBlock instr]
+                    -> BlockId
+                    -> instr
+                    -> BlockId
+                    -> [BlockId]
+                    -> UniqFM Loc
+                    -> UniqFM Loc
+                    -> RegM freeRegs ([NatBasicBlock instr], instr)
+joinToTargets_again
+    block_live new_blocks block_id instr dest dests
+    src_assig dest_assig
+
+        -- the assignments already match, no problem.
+        | nonDetUFMToList dest_assig == nonDetUFMToList src_assig
+        -- This is non-deterministic but we do not
+        -- currently support deterministic code-generation.
+        -- See Note [Unique Determinism and code generation]
+        = joinToTargets' block_live new_blocks block_id instr dests
+
+        -- assignments don't match, need fixup code
+        | otherwise
+        = do
+
+                -- make a graph of what things need to be moved where.
+                let graph = makeRegMovementGraph src_assig dest_assig
+
+                -- look for cycles in the graph. This can happen if regs need to be swapped.
+                -- Note that we depend on the fact that this function does a
+                --      bottom up traversal of the tree-like portions of the graph.
+                --
+                --  eg, if we have
+                --      R1 -> R2 -> R3
+                --
+                --  ie move value in R1 to R2 and value in R2 to R3.
+                --
+                -- We need to do the R2 -> R3 move before R1 -> R2.
+                --
+                let sccs  = stronglyConnCompFromEdgedVerticesOrdR graph
+
+              -- debugging
+                {-
+                pprTrace
+                        ("joinToTargets: making fixup code")
+                        (vcat   [ text "        in block: "     <> ppr block_id
+                                , text " jmp instruction: "     <> ppr instr
+                                , text "  src assignment: "     <> ppr src_assig
+                                , text " dest assignment: "     <> ppr dest_assig
+                                , text "  movement graph: "     <> ppr graph
+                                , text "   sccs of graph: "     <> ppr sccs
+                                , text ""])
+                        (return ())
+                -}
+                delta           <- getDeltaR
+                fixUpInstrs_    <- mapM (handleComponent delta instr) sccs
+                let fixUpInstrs = concat fixUpInstrs_
+
+                -- make a new basic block containing the fixup code.
+                --      A the end of the current block we will jump to the fixup one,
+                --      then that will jump to our original destination.
+                fixup_block_id <- mkBlockId <$> getUniqueR
+                let block = BasicBlock fixup_block_id
+                                $ fixUpInstrs ++ mkJumpInstr dest
+
+                -- if we didn't need any fixups, then don't include the block
+                case fixUpInstrs of
+                 []     -> joinToTargets' block_live new_blocks block_id instr dests
+
+                 -- patch the original branch instruction so it goes to our
+                 --     fixup block instead.
+                 _      -> let  instr'  =  patchJumpInstr instr
+                                            (\bid -> if bid == dest
+                                                        then fixup_block_id
+                                                        else bid) -- no change!
+
+                           in do
+                                {- --debugging
+                                pprTrace "FixUpEdge info:"
+                                    (
+                                    text "inBlock:" <> ppr block_id $$
+                                    text "instr:" <> ppr instr $$
+                                    text "instr':" <> ppr instr' $$
+                                    text "fixup_block_id':" <>
+                                        ppr fixup_block_id $$
+                                    text "dest:" <> ppr dest
+                                    ) (return ())
+                                -}
+                                recordFixupBlock block_id fixup_block_id dest
+                                joinToTargets' block_live (block : new_blocks)
+                                               block_id instr' dests
+
+
+-- | Construct a graph of register\/spill movements.
+--
+--      Cyclic components seem to occur only very rarely.
+--
+--      We cut some corners by not handling memory-to-memory moves.
+--      This shouldn't happen because every temporary gets its own stack slot.
+--
+makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [Node Loc Unique]
+makeRegMovementGraph adjusted_assig dest_assig
+ = [ node       | (vreg, src) <- nonDetUFMToList adjusted_assig
+                    -- This is non-deterministic but we do not
+                    -- currently support deterministic code-generation.
+                    -- See Note [Unique Determinism and code generation]
+                    -- source reg might not be needed at the dest:
+                , Just loc <- [lookupUFM_Directly dest_assig vreg]
+                , node <- expandNode vreg src loc ]
+
+
+-- | Expand out the destination, so InBoth destinations turn into
+--      a combination of InReg and InMem.
+
+--      The InBoth handling is a little tricky here.  If the destination is
+--      InBoth, then we must ensure that the value ends up in both locations.
+--      An InBoth  destination must conflict with an InReg or InMem source, so
+--      we expand an InBoth destination as necessary.
+--
+--      An InBoth source is slightly different: we only care about the register
+--      that the source value is in, so that we can move it to the destinations.
+--
+expandNode
+        :: a
+        -> Loc                  -- ^ source of move
+        -> Loc                  -- ^ destination of move
+        -> [Node Loc a ]
+
+expandNode vreg loc@(InReg src) (InBoth dst mem)
+        | src == dst = [DigraphNode vreg loc [InMem mem]]
+        | otherwise  = [DigraphNode vreg loc [InReg dst, InMem mem]]
+
+expandNode vreg loc@(InMem src) (InBoth dst mem)
+        | src == mem = [DigraphNode vreg loc [InReg dst]]
+        | otherwise  = [DigraphNode vreg loc [InReg dst, InMem mem]]
+
+expandNode _        (InBoth _ src) (InMem dst)
+        | src == dst = [] -- guaranteed to be true
+
+expandNode _        (InBoth src _) (InReg dst)
+        | src == dst = []
+
+expandNode vreg     (InBoth src _) dst
+        = expandNode vreg (InReg src) dst
+
+expandNode vreg src dst
+        | src == dst = []
+        | otherwise  = [DigraphNode vreg src [dst]]
+
+
+-- | Generate fixup code for a particular component in the move graph
+--      This component tells us what values need to be moved to what
+--      destinations. We have eliminated any possibility of single-node
+--      cycles in expandNode above.
+--
+handleComponent
+        :: Instruction instr
+        => Int -> instr -> SCC (Node Loc Unique)
+        -> RegM freeRegs [instr]
+
+-- If the graph is acyclic then we won't get the swapping problem below.
+--      In this case we can just do the moves directly, and avoid having to
+--      go via a spill slot.
+--
+handleComponent delta _  (AcyclicSCC (DigraphNode vreg src dsts))
+        = mapM (makeMove delta vreg src) dsts
+
+
+-- Handle some cyclic moves.
+--      This can happen if we have two regs that need to be swapped.
+--      eg:
+--           vreg   source loc   dest loc
+--          (vreg1, InReg r1,    [InReg r2])
+--          (vreg2, InReg r2,    [InReg r1])
+--
+--      To avoid needing temp register, we just spill all the source regs, then
+--      reaload them into their destination regs.
+--
+--      Note that we can not have cycles that involve memory locations as
+--      sources as single destination because memory locations (stack slots)
+--      are allocated exclusively for a virtual register and therefore can not
+--      require a fixup.
+--
+handleComponent delta instr
+        (CyclicSCC ((DigraphNode vreg (InReg sreg) ((InReg dreg: _))) : rest))
+        -- dest list may have more than one element, if the reg is also InMem.
+ = do
+        -- spill the source into its slot
+        (instrSpill, slot)
+                        <- spillR (RegReal sreg) vreg
+
+        -- reload into destination reg
+        instrLoad       <- loadR (RegReal dreg) slot
+
+        remainingFixUps <- mapM (handleComponent delta instr)
+                                (stronglyConnCompFromEdgedVerticesOrdR rest)
+
+        -- make sure to do all the reloads after all the spills,
+        --      so we don't end up clobbering the source values.
+        return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad])
+
+handleComponent _ _ (CyclicSCC _)
+ = panic "Register Allocator: handleComponent cyclic"
+
+
+-- | Move a vreg between these two locations.
+--
+makeMove
+    :: Instruction instr
+    => Int      -- ^ current C stack delta.
+    -> Unique   -- ^ unique of the vreg that we're moving.
+    -> Loc      -- ^ source location.
+    -> Loc      -- ^ destination location.
+    -> RegM freeRegs instr  -- ^ move instruction.
+
+makeMove delta vreg src dst
+ = do dflags <- getDynFlags
+      let platform = targetPlatform dflags
+
+      case (src, dst) of
+          (InReg s, InReg d) ->
+              do recordSpill (SpillJoinRR vreg)
+                 return $ mkRegRegMoveInstr platform (RegReal s) (RegReal d)
+          (InMem s, InReg d) ->
+              do recordSpill (SpillJoinRM vreg)
+                 return $ mkLoadInstr dflags (RegReal d) delta s
+          (InReg s, InMem d) ->
+              do recordSpill (SpillJoinRM vreg)
+                 return $ mkSpillInstr dflags (RegReal s) delta d
+          _ ->
+              -- we don't handle memory to memory moves.
+              -- they shouldn't happen because we don't share
+              -- stack slots between vregs.
+              panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("
+                  ++ show dst ++ ")"
+                  ++ " we don't handle mem->mem moves.")
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -0,0 +1,917 @@
+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}
+
+-----------------------------------------------------------------------------
+--
+-- The register allocator
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+{-
+The algorithm is roughly:
+
+  1) Compute strongly connected components of the basic block list.
+
+  2) Compute liveness (mapping from pseudo register to
+     point(s) of death?).
+
+  3) Walk instructions in each basic block.  We keep track of
+        (a) Free real registers (a bitmap?)
+        (b) Current assignment of temporaries to machine registers and/or
+            spill slots (call this the "assignment").
+        (c) Partial mapping from basic block ids to a virt-to-loc mapping.
+            When we first encounter a branch to a basic block,
+            we fill in its entry in this table with the current mapping.
+
+     For each instruction:
+        (a) For each temporary *read* by the instruction:
+            If the temporary does not have a real register allocation:
+                - Allocate a real register from the free list.  If
+                  the list is empty:
+                  - Find a temporary to spill.  Pick one that is
+                    not used in this instruction (ToDo: not
+                    used for a while...)
+                  - generate a spill instruction
+                - If the temporary was previously spilled,
+                  generate an instruction to read the temp from its spill loc.
+            (optimisation: if we can see that a real register is going to
+            be used soon, then don't use it for allocation).
+
+        (b) For each real register clobbered by this instruction:
+            If a temporary resides in it,
+                If the temporary is live after this instruction,
+                    Move the temporary to another (non-clobbered & free) reg,
+                    or spill it to memory.  Mark the temporary as residing
+                    in both memory and a register if it was spilled (it might
+                    need to be read by this instruction).
+
+            (ToDo: this is wrong for jump instructions?)
+
+            We do this after step (a), because if we start with
+               movq v1, %rsi
+            which is an instruction that clobbers %rsi, if v1 currently resides
+            in %rsi we want to get
+               movq %rsi, %freereg
+               movq %rsi, %rsi     -- will disappear
+            instead of
+               movq %rsi, %freereg
+               movq %freereg, %rsi
+
+        (c) Update the current assignment
+
+        (d) If the instruction is a branch:
+              if the destination block already has a register assignment,
+                Generate a new block with fixup code and redirect the
+                jump to the new block.
+              else,
+                Update the block id->assignment mapping with the current
+                assignment.
+
+        (e) Delete all register assignments for temps which are read
+            (only) and die here.  Update the free register list.
+
+        (f) Mark all registers clobbered by this instruction as not free,
+            and mark temporaries which have been spilled due to clobbering
+            as in memory (step (a) marks then as in both mem & reg).
+
+        (g) For each temporary *written* by this instruction:
+            Allocate a real register as for (b), spilling something
+            else if necessary.
+                - except when updating the assignment, drop any memory
+                  locations that the temporary was previously in, since
+                  they will be no longer valid after this instruction.
+
+        (h) Delete all register assignments for temps which are
+            written and die here (there should rarely be any).  Update
+            the free register list.
+
+        (i) Rewrite the instruction with the new mapping.
+
+        (j) For each spilled reg known to be now dead, re-add its stack slot
+            to the free list.
+
+-}
+
+module RegAlloc.Linear.Main (
+        regAlloc,
+        module  RegAlloc.Linear.Base,
+        module  RegAlloc.Linear.Stats
+  ) where
+
+#include "HsVersions.h"
+
+
+import GhcPrelude
+
+import RegAlloc.Linear.State
+import RegAlloc.Linear.Base
+import RegAlloc.Linear.StackMap
+import RegAlloc.Linear.FreeRegs
+import RegAlloc.Linear.Stats
+import RegAlloc.Linear.JoinToTargets
+import qualified RegAlloc.Linear.PPC.FreeRegs    as PPC
+import qualified RegAlloc.Linear.SPARC.FreeRegs  as SPARC
+import qualified RegAlloc.Linear.X86.FreeRegs    as X86
+import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64
+import TargetReg
+import RegAlloc.Liveness
+import Instruction
+import Reg
+
+import BlockId
+import Hoopl.Collections
+import Cmm hiding (RegSet)
+
+import Digraph
+import DynFlags
+import Unique
+import UniqSet
+import UniqFM
+import UniqSupply
+import Outputable
+import Platform
+
+import Data.Maybe
+import Data.List
+import Control.Monad
+
+-- -----------------------------------------------------------------------------
+-- Top level of the register allocator
+
+-- Allocate registers
+regAlloc
+        :: (Outputable instr, Instruction instr)
+        => DynFlags
+        -> LiveCmmDecl statics instr
+        -> UniqSM ( NatCmmDecl statics instr
+                  , Maybe Int  -- number of extra stack slots required,
+                               -- beyond maxSpillSlots
+                  , Maybe RegAllocStats
+                  )
+
+regAlloc _ (CmmData sec d)
+        = return
+                ( CmmData sec d
+                , Nothing
+                , Nothing )
+
+regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl live [])
+        = return ( CmmProc info lbl live (ListGraph [])
+                 , Nothing
+                 , Nothing )
+
+regAlloc dflags (CmmProc static lbl live sccs)
+        | LiveInfo info entry_ids@(first_id:_) (Just block_live) _ <- static
+        = do
+                -- do register allocation on each component.
+                (final_blocks, stats, stack_use)
+                        <- linearRegAlloc dflags entry_ids block_live sccs
+
+                -- make sure the block that was first in the input list
+                --      stays at the front of the output
+                let ((first':_), rest')
+                                = partition ((== first_id) . blockId) final_blocks
+
+                let max_spill_slots = maxSpillSlots dflags
+                    extra_stack
+                      | stack_use > max_spill_slots
+                      = Just (stack_use - max_spill_slots)
+                      | otherwise
+                      = Nothing
+
+                return  ( CmmProc info lbl live (ListGraph (first' : rest'))
+                        , extra_stack
+                        , Just stats)
+
+-- bogus. to make non-exhaustive match warning go away.
+regAlloc _ (CmmProc _ _ _ _)
+        = panic "RegAllocLinear.regAlloc: no match"
+
+
+-- -----------------------------------------------------------------------------
+-- Linear sweep to allocate registers
+
+
+-- | Do register allocation on some basic blocks.
+--   But be careful to allocate a block in an SCC only if it has
+--   an entry in the block map or it is the first block.
+--
+linearRegAlloc
+        :: (Outputable instr, Instruction instr)
+        => DynFlags
+        -> [BlockId] -- ^ entry points
+        -> BlockMap RegSet
+              -- ^ live regs on entry to each basic block
+        -> [SCC (LiveBasicBlock instr)]
+              -- ^ instructions annotated with "deaths"
+        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
+
+linearRegAlloc dflags entry_ids block_live sccs
+ = case platformArch platform of
+      ArchX86        -> go $ (frInitFreeRegs platform :: X86.FreeRegs)
+      ArchX86_64     -> go $ (frInitFreeRegs platform :: X86_64.FreeRegs)
+      ArchSPARC      -> go $ (frInitFreeRegs platform :: SPARC.FreeRegs)
+      ArchSPARC64    -> panic "linearRegAlloc ArchSPARC64"
+      ArchPPC        -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)
+      ArchARM _ _ _  -> panic "linearRegAlloc ArchARM"
+      ArchARM64      -> panic "linearRegAlloc ArchARM64"
+      ArchPPC_64 _   -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)
+      ArchAlpha      -> panic "linearRegAlloc ArchAlpha"
+      ArchMipseb     -> panic "linearRegAlloc ArchMipseb"
+      ArchMipsel     -> panic "linearRegAlloc ArchMipsel"
+      ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"
+      ArchUnknown    -> panic "linearRegAlloc ArchUnknown"
+ where
+  go f = linearRegAlloc' dflags f entry_ids block_live sccs
+  platform = targetPlatform dflags
+
+linearRegAlloc'
+        :: (FR freeRegs, Outputable instr, Instruction instr)
+        => DynFlags
+        -> freeRegs
+        -> [BlockId]                    -- ^ entry points
+        -> BlockMap RegSet              -- ^ live regs on entry to each basic block
+        -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"
+        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)
+
+linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs
+ = do   us      <- getUniqueSupplyM
+        let (_, stack, stats, blocks) =
+                runR dflags mapEmpty initFreeRegs emptyRegMap (emptyStackMap dflags) us
+                    $ linearRA_SCCs entry_ids block_live [] sccs
+        return  (blocks, stats, getStackUse stack)
+
+
+linearRA_SCCs :: (FR freeRegs, Instruction instr, Outputable instr)
+              => [BlockId]
+              -> BlockMap RegSet
+              -> [NatBasicBlock instr]
+              -> [SCC (LiveBasicBlock instr)]
+              -> RegM freeRegs [NatBasicBlock instr]
+
+linearRA_SCCs _ _ blocksAcc []
+        = return $ reverse blocksAcc
+
+linearRA_SCCs entry_ids block_live blocksAcc (AcyclicSCC block : sccs)
+ = do   blocks' <- processBlock block_live block
+        linearRA_SCCs entry_ids block_live
+                ((reverse blocks') ++ blocksAcc)
+                sccs
+
+linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs)
+ = do
+        blockss' <- process entry_ids block_live blocks [] (return []) False
+        linearRA_SCCs entry_ids block_live
+                (reverse (concat blockss') ++ blocksAcc)
+                sccs
+
+{- from John Dias's patch 2008/10/16:
+   The linear-scan allocator sometimes allocates a block
+   before allocating one of its predecessors, which could lead to
+   inconsistent allocations. Make it so a block is only allocated
+   if a predecessor has set the "incoming" assignments for the block, or
+   if it's the procedure's entry block.
+
+   BL 2009/02: Careful. If the assignment for a block doesn't get set for
+   some reason then this function will loop. We should probably do some
+   more sanity checking to guard against this eventuality.
+-}
+
+process :: (FR freeRegs, Instruction instr, Outputable instr)
+        => [BlockId]
+        -> BlockMap RegSet
+        -> [GenBasicBlock (LiveInstr instr)]
+        -> [GenBasicBlock (LiveInstr instr)]
+        -> [[NatBasicBlock instr]]
+        -> Bool
+        -> RegM freeRegs [[NatBasicBlock instr]]
+
+process _ _ [] []         accum _
+        = return $ reverse accum
+
+process entry_ids block_live [] next_round accum madeProgress
+        | not madeProgress
+
+          {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.
+             pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."
+                (  text "Unreachable blocks:"
+                $$ vcat (map ppr next_round)) -}
+        = return $ reverse accum
+
+        | otherwise
+        = process entry_ids block_live
+                  next_round [] accum False
+
+process entry_ids block_live (b@(BasicBlock id _) : blocks)
+        next_round accum madeProgress
+ = do
+        block_assig <- getBlockAssigR
+
+        if isJust (mapLookup id block_assig)
+             || id `elem` entry_ids
+         then do
+                b'  <- processBlock block_live b
+                process entry_ids block_live blocks
+                        next_round (b' : accum) True
+
+         else   process entry_ids block_live blocks
+                        (b : next_round) accum madeProgress
+
+
+-- | Do register allocation on this basic block
+--
+processBlock
+        :: (FR freeRegs, Outputable instr, Instruction instr)
+        => BlockMap RegSet              -- ^ live regs on entry to each basic block
+        -> LiveBasicBlock instr         -- ^ block to do register allocation on
+        -> RegM freeRegs [NatBasicBlock instr]   -- ^ block with registers allocated
+
+processBlock block_live (BasicBlock id instrs)
+ = do   initBlock id block_live
+        (instrs', fixups)
+                <- linearRA block_live [] [] id instrs
+        return  $ BasicBlock id instrs' : fixups
+
+
+-- | Load the freeregs and current reg assignment into the RegM state
+--      for the basic block with this BlockId.
+initBlock :: FR freeRegs
+          => BlockId -> BlockMap RegSet -> RegM freeRegs ()
+initBlock id block_live
+ = do   dflags <- getDynFlags
+        let platform = targetPlatform dflags
+        block_assig     <- getBlockAssigR
+        case mapLookup id block_assig of
+                -- no prior info about this block: we must consider
+                -- any fixed regs to be allocated, but we can ignore
+                -- virtual regs (presumably this is part of a loop,
+                -- and we'll iterate again).  The assignment begins
+                -- empty.
+                Nothing
+                 -> do  -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ())
+                        case mapLookup id block_live of
+                          Nothing ->
+                            setFreeRegsR    (frInitFreeRegs platform)
+                          Just live ->
+                            setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform)
+                                                  [ r | RegReal r <- nonDetEltsUniqSet live ]
+                            -- See Note [Unique Determinism and code generation]
+                        setAssigR       emptyRegMap
+
+                -- load info about register assignments leading into this block.
+                Just (freeregs, assig)
+                 -> do  setFreeRegsR    freeregs
+                        setAssigR       assig
+
+
+-- | Do allocation for a sequence of instructions.
+linearRA
+        :: (FR freeRegs, Outputable instr, Instruction instr)
+        => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.
+        -> [instr]                              -- ^ accumulator for instructions already processed.
+        -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.
+        -> BlockId                              -- ^ id of the current block, for debugging.
+        -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.
+
+        -> RegM freeRegs
+                ( [instr]                       --   instructions after register allocation
+                , [NatBasicBlock instr])        --   fresh blocks of fixup code.
+
+
+linearRA _          accInstr accFixup _ []
+        = return
+                ( reverse accInstr              -- instrs need to be returned in the correct order.
+                , accFixup)                     -- it doesn't matter what order the fixup blocks are returned in.
+
+
+linearRA block_live accInstr accFixups id (instr:instrs)
+ = do
+        (accInstr', new_fixups) <- raInsn block_live accInstr id instr
+
+        linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs
+
+
+-- | Do allocation for a single instruction.
+raInsn
+        :: (FR freeRegs, Outputable instr, Instruction instr)
+        => BlockMap RegSet                      -- ^ map of what vregs are love on entry to each block.
+        -> [instr]                              -- ^ accumulator for instructions already processed.
+        -> BlockId                              -- ^ the id of the current block, for debugging
+        -> LiveInstr instr                      -- ^ the instr to have its regs allocated, with liveness info.
+        -> RegM freeRegs
+                ( [instr]                       -- new instructions
+                , [NatBasicBlock instr])        -- extra fixup blocks
+
+raInsn _     new_instrs _ (LiveInstr ii Nothing)
+        | Just n        <- takeDeltaInstr ii
+        = do    setDeltaR n
+                return (new_instrs, [])
+
+raInsn _     new_instrs _ (LiveInstr ii@(Instr i) Nothing)
+        | isMetaInstr ii
+        = return (i : new_instrs, [])
+
+
+raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
+ = do
+    assig    <- getAssigR
+
+    -- If we have a reg->reg move between virtual registers, where the
+    -- src register is not live after this instruction, and the dst
+    -- register does not already have an assignment,
+    -- and the source register is assigned to a register, not to a spill slot,
+    -- then we can eliminate the instruction.
+    -- (we can't eliminate it if the source register is on the stack, because
+    --  we do not want to use one spill slot for different virtual registers)
+    case takeRegRegMoveInstr instr of
+        Just (src,dst)  | src `elementOfUniqSet` (liveDieRead live),
+                          isVirtualReg dst,
+                          not (dst `elemUFM` assig),
+                          isRealReg src || isInReg src assig -> do
+           case src of
+              (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr))
+                -- if src is a fixed reg, then we just map dest to this
+                -- reg in the assignment.  src must be an allocatable reg,
+                -- otherwise it wouldn't be in r_dying.
+              _virt -> case lookupUFM assig src of
+                         Nothing -> panic "raInsn"
+                         Just loc ->
+                           setAssigR (addToUFM (delFromUFM assig src) dst loc)
+
+           -- we have eliminated this instruction
+          {-
+          freeregs <- getFreeRegsR
+          assig <- getAssigR
+          pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr)
+                        $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do
+          -}
+           return (new_instrs, [])
+
+        _ -> genRaInsn block_live new_instrs id instr
+                        (nonDetEltsUniqSet $ liveDieRead live)
+                        (nonDetEltsUniqSet $ liveDieWrite live)
+                        -- See Note [Unique Determinism and code generation]
+
+raInsn _ _ _ instr
+        = pprPanic "raInsn" (text "no match for:" <> ppr instr)
+
+-- ToDo: what can we do about
+--
+--     R1 = x
+--     jump I64[x] // [R1]
+--
+-- where x is mapped to the same reg as R1.  We want to coalesce x and
+-- R1, but the register allocator doesn't know whether x will be
+-- assigned to again later, in which case x and R1 should be in
+-- different registers.  Right now we assume the worst, and the
+-- assignment to R1 will clobber x, so we'll spill x into another reg,
+-- generating another reg->reg move.
+
+
+isInReg :: Reg -> RegMap Loc -> Bool
+isInReg src assig | Just (InReg _) <- lookupUFM assig src = True
+                  | otherwise = False
+
+
+genRaInsn :: (FR freeRegs, Instruction instr, Outputable instr)
+          => BlockMap RegSet
+          -> [instr]
+          -> BlockId
+          -> instr
+          -> [Reg]
+          -> [Reg]
+          -> RegM freeRegs ([instr], [NatBasicBlock instr])
+
+genRaInsn block_live new_instrs block_id instr r_dying w_dying = do
+  dflags <- getDynFlags
+  let platform = targetPlatform dflags
+  case regUsageOfInstr platform instr of { RU read written ->
+    do
+    let real_written    = [ rr  | (RegReal     rr) <- written ]
+    let virt_written    = [ vr  | (RegVirtual  vr) <- written ]
+
+    -- we don't need to do anything with real registers that are
+    -- only read by this instr.  (the list is typically ~2 elements,
+    -- so using nub isn't a problem).
+    let virt_read       = nub [ vr      | (RegVirtual vr) <- read ]
+
+    -- debugging
+{-    freeregs <- getFreeRegsR
+    assig    <- getAssigR
+    pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform } undefined) trace "genRaInsn"
+        (ppr instr
+                $$ text "r_dying      = " <+> ppr r_dying
+                $$ text "w_dying      = " <+> ppr w_dying
+                $$ text "virt_read    = " <+> ppr virt_read
+                $$ text "virt_written = " <+> ppr virt_written
+                $$ text "freeregs     = " <+> text (show freeregs)
+                $$ text "assig        = " <+> ppr assig)
+        $ do
+-}
+
+    -- (a), (b) allocate real regs for all regs read by this instruction.
+    (r_spills, r_allocd) <-
+        allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read
+
+    -- (c) save any temporaries which will be clobbered by this instruction
+    clobber_saves <- saveClobberedTemps real_written r_dying
+
+    -- (d) Update block map for new destinations
+    -- NB. do this before removing dead regs from the assignment, because
+    -- these dead regs might in fact be live in the jump targets (they're
+    -- only dead in the code that follows in the current basic block).
+    (fixup_blocks, adjusted_instr)
+        <- joinToTargets block_live block_id instr
+
+    -- Debugging - show places where the reg alloc inserted
+    -- assignment fixup blocks.
+    -- when (not $ null fixup_blocks) $
+    --    pprTrace "fixup_blocks" (ppr fixup_blocks) (return ())
+
+    -- (e) Delete all register assignments for temps which are read
+    --     (only) and die here.  Update the free register list.
+    releaseRegs r_dying
+
+    -- (f) Mark regs which are clobbered as unallocatable
+    clobberRegs real_written
+
+    -- (g) Allocate registers for temporaries *written* (only)
+    (w_spills, w_allocd) <-
+        allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written
+
+    -- (h) Release registers for temps which are written here and not
+    -- used again.
+    releaseRegs w_dying
+
+    let
+        -- (i) Patch the instruction
+        patch_map
+                = listToUFM
+                        [ (t, RegReal r)
+                                | (t, r) <- zip virt_read    r_allocd
+                                         ++ zip virt_written w_allocd ]
+
+        patched_instr
+                = patchRegsOfInstr adjusted_instr patchLookup
+
+        patchLookup x
+                = case lookupUFM patch_map x of
+                        Nothing -> x
+                        Just y  -> y
+
+
+    -- (j) free up stack slots for dead spilled regs
+    -- TODO (can't be bothered right now)
+
+    -- erase reg->reg moves where the source and destination are the same.
+    --  If the src temp didn't die in this instr but happened to be allocated
+    --  to the same real reg as the destination, then we can erase the move anyway.
+    let squashed_instr  = case takeRegRegMoveInstr patched_instr of
+                                Just (src, dst)
+                                 | src == dst   -> []
+                                _               -> [patched_instr]
+
+    let code = squashed_instr ++ w_spills ++ reverse r_spills
+                ++ clobber_saves ++ new_instrs
+
+--    pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do
+--    pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do
+
+    return (code, fixup_blocks)
+
+  }
+
+-- -----------------------------------------------------------------------------
+-- releaseRegs
+
+releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs ()
+releaseRegs regs = do
+  dflags <- getDynFlags
+  let platform = targetPlatform dflags
+  assig <- getAssigR
+  free <- getFreeRegsR
+  let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return ()
+      loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs
+      loop assig !free (r:rs) =
+         case lookupUFM assig r of
+         Just (InBoth real _) -> loop (delFromUFM assig r)
+                                      (frReleaseReg platform real free) rs
+         Just (InReg real)    -> loop (delFromUFM assig r)
+                                      (frReleaseReg platform real free) rs
+         _                    -> loop (delFromUFM assig r) free rs
+  loop assig free regs
+
+
+-- -----------------------------------------------------------------------------
+-- Clobber real registers
+
+-- For each temp in a register that is going to be clobbered:
+--      - if the temp dies after this instruction, do nothing
+--      - otherwise, put it somewhere safe (another reg if possible,
+--              otherwise spill and record InBoth in the assignment).
+--      - for allocateRegs on the temps *read*,
+--      - clobbered regs are allocatable.
+--
+--      for allocateRegs on the temps *written*,
+--        - clobbered regs are not allocatable.
+--
+
+saveClobberedTemps
+        :: (Instruction instr, FR freeRegs)
+        => [RealReg]            -- real registers clobbered by this instruction
+        -> [Reg]                -- registers which are no longer live after this insn
+        -> RegM freeRegs [instr]         -- return: instructions to spill any temps that will
+                                -- be clobbered.
+
+saveClobberedTemps [] _
+        = return []
+
+saveClobberedTemps clobbered dying
+ = do
+        assig   <- getAssigR
+        let to_spill
+                = [ (temp,reg)
+                        | (temp, InReg reg) <- nonDetUFMToList assig
+                        -- This is non-deterministic but we do not
+                        -- currently support deterministic code-generation.
+                        -- See Note [Unique Determinism and code generation]
+                        , any (realRegsAlias reg) clobbered
+                        , temp `notElem` map getUnique dying  ]
+
+        (instrs,assig') <- clobber assig [] to_spill
+        setAssigR assig'
+        return instrs
+
+   where
+     clobber assig instrs []
+            = return (instrs, assig)
+
+     clobber assig instrs ((temp, reg) : rest)
+       = do dflags <- getDynFlags
+            let platform = targetPlatform dflags
+
+            freeRegs <- getFreeRegsR
+            let regclass = targetClassOfRealReg platform reg
+                freeRegs_thisClass = frGetFreeRegs platform regclass freeRegs
+
+            case filter (`notElem` clobbered) freeRegs_thisClass of
+
+              -- (1) we have a free reg of the right class that isn't
+              -- clobbered by this instruction; use it to save the
+              -- clobbered value.
+              (my_reg : _) -> do
+                  setFreeRegsR (frAllocateReg platform my_reg freeRegs)
+
+                  let new_assign = addToUFM assig temp (InReg my_reg)
+                  let instr = mkRegRegMoveInstr platform
+                                  (RegReal reg) (RegReal my_reg)
+
+                  clobber new_assign (instr : instrs) rest
+
+              -- (2) no free registers: spill the value
+              [] -> do
+                  (spill, slot)   <- spillR (RegReal reg) temp
+
+                  -- record why this reg was spilled for profiling
+                  recordSpill (SpillClobber temp)
+
+                  let new_assign  = addToUFM assig temp (InBoth reg slot)
+
+                  clobber new_assign (spill : instrs) rest
+
+
+
+-- | Mark all these real regs as allocated,
+--      and kick out their vreg assignments.
+--
+clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs ()
+clobberRegs []
+        = return ()
+
+clobberRegs clobbered
+ = do   dflags <- getDynFlags
+        let platform = targetPlatform dflags
+
+        freeregs        <- getFreeRegsR
+        setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered
+
+        assig           <- getAssigR
+        setAssigR $! clobber assig (nonDetUFMToList assig)
+          -- This is non-deterministic but we do not
+          -- currently support deterministic code-generation.
+          -- See Note [Unique Determinism and code generation]
+
+   where
+        -- if the temp was InReg and clobbered, then we will have
+        -- saved it in saveClobberedTemps above.  So the only case
+        -- we have to worry about here is InBoth.  Note that this
+        -- also catches temps which were loaded up during allocation
+        -- of read registers, not just those saved in saveClobberedTemps.
+
+        clobber assig []
+                = assig
+
+        clobber assig ((temp, InBoth reg slot) : rest)
+                | any (realRegsAlias reg) clobbered
+                = clobber (addToUFM assig temp (InMem slot)) rest
+
+        clobber assig (_:rest)
+                = clobber assig rest
+
+-- -----------------------------------------------------------------------------
+-- allocateRegsAndSpill
+
+-- Why are we performing a spill?
+data SpillLoc = ReadMem StackSlot  -- reading from register only in memory
+              | WriteNew           -- writing to a new variable
+              | WriteMem           -- writing to register only in memory
+-- Note that ReadNew is not valid, since you don't want to be reading
+-- from an uninitialized register.  We also don't need the location of
+-- the register in memory, since that will be invalidated by the write.
+-- Technically, we could coalesce WriteNew and WriteMem into a single
+-- entry as well. -- EZY
+
+-- This function does several things:
+--   For each temporary referred to by this instruction,
+--   we allocate a real register (spilling another temporary if necessary).
+--   We load the temporary up from memory if necessary.
+--   We also update the register assignment in the process, and
+--   the list of free registers and free stack slots.
+
+allocateRegsAndSpill
+        :: (FR freeRegs, Outputable instr, Instruction instr)
+        => Bool                 -- True <=> reading (load up spilled regs)
+        -> [VirtualReg]         -- don't push these out
+        -> [instr]              -- spill insns
+        -> [RealReg]            -- real registers allocated (accum.)
+        -> [VirtualReg]         -- temps to allocate
+        -> RegM freeRegs ( [instr] , [RealReg])
+
+allocateRegsAndSpill _       _    spills alloc []
+        = return (spills, reverse alloc)
+
+allocateRegsAndSpill reading keep spills alloc (r:rs)
+ = do   assig <- getAssigR
+        let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig
+        case lookupUFM assig r of
+                -- case (1a): already in a register
+                Just (InReg my_reg) ->
+                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
+
+                -- case (1b): already in a register (and memory)
+                -- NB1. if we're writing this register, update its assignment to be
+                -- InReg, because the memory value is no longer valid.
+                -- NB2. This is why we must process written registers here, even if they
+                -- are also read by the same instruction.
+                Just (InBoth my_reg _)
+                 -> do  when (not reading) (setAssigR (addToUFM assig r (InReg my_reg)))
+                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
+
+                -- Not already in a register, so we need to find a free one...
+                Just (InMem slot) | reading   -> doSpill (ReadMem slot)
+                                  | otherwise -> doSpill WriteMem
+                Nothing | reading   ->
+                   pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)
+                   -- NOTE: if the input to the NCG contains some
+                   -- unreachable blocks with junk code, this panic
+                   -- might be triggered.  Make sure you only feed
+                   -- sensible code into the NCG.  In CmmPipeline we
+                   -- call removeUnreachableBlocks at the end for this
+                   -- reason.
+
+                        | otherwise -> doSpill WriteNew
+
+
+-- reading is redundant with reason, but we keep it around because it's
+-- convenient and it maintains the recursive structure of the allocator. -- EZY
+allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)
+                        => Bool
+                        -> [VirtualReg]
+                        -> [instr]
+                        -> [RealReg]
+                        -> VirtualReg
+                        -> [VirtualReg]
+                        -> UniqFM Loc
+                        -> SpillLoc
+                        -> RegM freeRegs ([instr], [RealReg])
+allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
+ = do   dflags <- getDynFlags
+        let platform = targetPlatform dflags
+        freeRegs                <- getFreeRegsR
+        let freeRegs_thisClass  = frGetFreeRegs platform (classOfVirtualReg r) freeRegs
+
+        case freeRegs_thisClass of
+
+         -- case (2): we have a free register
+         (my_reg : _) ->
+           do   spills'   <- loadTemp r spill_loc my_reg spills
+
+                setAssigR       (addToUFM assig r $! newLocation spill_loc my_reg)
+                setFreeRegsR $  frAllocateReg platform my_reg freeRegs
+
+                allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs
+
+
+          -- case (3): we need to push something out to free up a register
+         [] ->
+           do   let inRegOrBoth (InReg _) = True
+                    inRegOrBoth (InBoth _ _) = True
+                    inRegOrBoth _ = False
+                let candidates' =
+                      flip delListFromUFM keep $
+                      filterUFM inRegOrBoth $
+                      assig
+                      -- This is non-deterministic but we do not
+                      -- currently support deterministic code-generation.
+                      -- See Note [Unique Determinism and code generation]
+                let candidates = nonDetUFMToList candidates'
+
+                -- the vregs we could kick out that are already in a slot
+                let candidates_inBoth
+                        = [ (temp, reg, mem)
+                          | (temp, InBoth reg mem) <- candidates
+                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]
+
+                -- the vregs we could kick out that are only in a reg
+                --      this would require writing the reg to a new slot before using it.
+                let candidates_inReg
+                        = [ (temp, reg)
+                          | (temp, InReg reg) <- candidates
+                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]
+
+                let result
+
+                        -- we have a temporary that is in both register and mem,
+                        -- just free up its register for use.
+                        | (temp, my_reg, slot) : _      <- candidates_inBoth
+                        = do    spills' <- loadTemp r spill_loc my_reg spills
+                                let assig1  = addToUFM assig temp (InMem slot)
+                                let assig2  = addToUFM assig1 r $! newLocation spill_loc my_reg
+
+                                setAssigR assig2
+                                allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
+
+                        -- otherwise, we need to spill a temporary that currently
+                        -- resides in a register.
+                        | (temp_to_push_out, (my_reg :: RealReg)) : _
+                                        <- candidates_inReg
+                        = do
+                                (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out
+                                let spill_store  = (if reading then id else reverse)
+                                                        [ -- COMMENT (fsLit "spill alloc")
+                                                           spill_insn ]
+
+                                -- record that this temp was spilled
+                                recordSpill (SpillAlloc temp_to_push_out)
+
+                                -- update the register assignment
+                                let assig1  = addToUFM assig temp_to_push_out   (InMem slot)
+                                let assig2  = addToUFM assig1 r                 $! newLocation spill_loc my_reg
+                                setAssigR assig2
+
+                                -- if need be, load up a spilled temp into the reg we've just freed up.
+                                spills' <- loadTemp r spill_loc my_reg spills
+
+                                allocateRegsAndSpill reading keep
+                                        (spill_store ++ spills')
+                                        (my_reg:alloc) rs
+
+
+                        -- there wasn't anything to spill, so we're screwed.
+                        | otherwise
+                        = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")
+                        $ vcat
+                                [ text "allocating vreg:  " <> text (show r)
+                                , text "assignment:       " <> ppr assig
+                                , text "freeRegs:         " <> text (show freeRegs)
+                                , text "initFreeRegs:     " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ]
+
+                result
+
+
+-- | Calculate a new location after a register has been loaded.
+newLocation :: SpillLoc -> RealReg -> Loc
+-- if the tmp was read from a slot, then now its in a reg as well
+newLocation (ReadMem slot) my_reg = InBoth my_reg slot
+-- writes will always result in only the register being available
+newLocation _ my_reg = InReg my_reg
+
+-- | Load up a spilled temporary if we need to (read from memory).
+loadTemp
+        :: (Instruction instr)
+        => VirtualReg   -- the temp being loaded
+        -> SpillLoc     -- the current location of this temp
+        -> RealReg      -- the hreg to load the temp into
+        -> [instr]
+        -> RegM freeRegs [instr]
+
+loadTemp vreg (ReadMem slot) hreg spills
+ = do
+        insn <- loadR (RegReal hreg) slot
+        recordSpill (SpillLoad $ getUnique vreg)
+        return  $  {- COMMENT (fsLit "spill load") : -} insn : spills
+
+loadTemp _ _ _ spills =
+   return spills
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs
@@ -0,0 +1,61 @@
+-- | Free regs map for PowerPC
+module RegAlloc.Linear.PPC.FreeRegs
+where
+
+import GhcPrelude
+
+import PPC.Regs
+import RegClass
+import Reg
+
+import Outputable
+import Platform
+
+import Data.Word
+import Data.Bits
+
+-- The PowerPC has 32 integer and 32 floating point registers.
+-- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much
+-- better.
+-- Note that when getFreeRegs scans for free registers, it starts at register
+-- 31 and counts down. This is a hack for the PowerPC - the higher-numbered
+-- registers are callee-saves, while the lower regs are caller-saves, so it
+-- makes sense to start at the high end.
+-- Apart from that, the code does nothing PowerPC-specific, so feel free to
+-- add your favourite platform to the #if (if you have 64 registers but only
+-- 32-bit words).
+
+data FreeRegs = FreeRegs !Word32 !Word32
+              deriving( Show )  -- The Show is used in an ASSERT
+
+noFreeRegs :: FreeRegs
+noFreeRegs = FreeRegs 0 0
+
+releaseReg :: RealReg -> FreeRegs -> FreeRegs
+releaseReg (RealRegSingle r) (FreeRegs g f)
+    | r > 31    = FreeRegs g (f .|. (1 `shiftL` (r - 32)))
+    | otherwise = FreeRegs (g .|. (1 `shiftL` r)) f
+
+releaseReg _ _
+        = panic "RegAlloc.Linear.PPC.releaseReg: bad reg"
+
+initFreeRegs :: Platform -> FreeRegs
+initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)
+
+getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily
+getFreeRegs cls (FreeRegs g f)
+    | RcDouble <- cls = go f (0x80000000) 63
+    | RcInteger <- cls = go g (0x80000000) 31
+    | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (ppr cls)
+    where
+        go _ 0 _ = []
+        go x m i | x .&. m /= 0 = RealRegSingle i : (go x (m `shiftR` 1) $! i-1)
+                 | otherwise    = go x (m `shiftR` 1) $! i-1
+
+allocateReg :: RealReg -> FreeRegs -> FreeRegs
+allocateReg (RealRegSingle r) (FreeRegs g f)
+    | r > 31    = FreeRegs g (f .&. complement (1 `shiftL` (r - 32)))
+    | otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f
+
+allocateReg _ _
+        = panic "RegAlloc.Linear.PPC.allocateReg: bad reg"
diff --git a/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs
@@ -0,0 +1,187 @@
+
+-- | Free regs map for SPARC
+module RegAlloc.Linear.SPARC.FreeRegs
+where
+
+import GhcPrelude
+
+import SPARC.Regs
+import RegClass
+import Reg
+
+import CodeGen.Platform
+import Outputable
+import Platform
+
+import Data.Word
+import Data.Bits
+
+
+--------------------------------------------------------------------------------
+-- SPARC is like PPC, except for twinning of floating point regs.
+--      When we allocate a double reg we must take an even numbered
+--      float reg, as well as the one after it.
+
+
+-- Holds bitmaps showing what registers are currently allocated.
+--      The float and double reg bitmaps overlap, but we only alloc
+--      float regs into the float map, and double regs into the double map.
+--
+--      Free regs have a bit set in the corresponding bitmap.
+--
+data FreeRegs
+        = FreeRegs
+                !Word32         -- int    reg bitmap    regs  0..31
+                !Word32         -- float  reg bitmap    regs 32..63
+                !Word32         -- double reg bitmap    regs 32..63
+
+instance Show FreeRegs where
+        show = showFreeRegs
+
+-- | A reg map where no regs are free to be allocated.
+noFreeRegs :: FreeRegs
+noFreeRegs = FreeRegs 0 0 0
+
+
+-- | The initial set of free regs.
+initFreeRegs :: Platform -> FreeRegs
+initFreeRegs platform
+ =      foldl' (flip $ releaseReg platform) noFreeRegs allocatableRegs
+
+
+-- | Get all the free registers of this class.
+getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily
+getFreeRegs cls (FreeRegs g f d)
+        | RcInteger <- cls = map RealRegSingle                  $ go 1 g 1 0
+        | RcFloat   <- cls = map RealRegSingle                  $ go 1 f 1 32
+        | RcDouble  <- cls = map (\i -> RealRegPair i (i+1))    $ go 2 d 1 32
+        | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls)
+        where
+                go _    _      0    _
+                        = []
+
+                go step bitmap mask ix
+                        | bitmap .&. mask /= 0
+                        = ix : (go step bitmap (mask `shiftL` step) $! ix + step)
+
+                        | otherwise
+                        = go step bitmap (mask `shiftL` step) $! ix + step
+
+
+-- | Grab a register.
+allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs
+allocateReg platform
+         reg@(RealRegSingle r)
+             (FreeRegs g f d)
+
+        -- can't allocate free regs
+        | not $ freeReg platform r
+        = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg)
+
+        -- a general purpose reg
+        | r <= 31
+        = let   mask    = complement (bitMask r)
+          in    FreeRegs
+                        (g .&. mask)
+                        f
+                        d
+
+        -- a float reg
+        | r >= 32, r <= 63
+        = let   mask    = complement (bitMask (r - 32))
+
+                -- the mask of the double this FP reg aliases
+                maskLow = if r `mod` 2 == 0
+                                then complement (bitMask (r - 32))
+                                else complement (bitMask (r - 32 - 1))
+          in    FreeRegs
+                        g
+                        (f .&. mask)
+                        (d .&. maskLow)
+
+        | otherwise
+        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)
+
+allocateReg _
+         reg@(RealRegPair r1 r2)
+             (FreeRegs g f d)
+
+        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0
+        , r2 >= 32, r2 <= 63
+        = let   mask1   = complement (bitMask (r1 - 32))
+                mask2   = complement (bitMask (r2 - 32))
+          in
+                FreeRegs
+                        g
+                        ((f .&. mask1) .&. mask2)
+                        (d .&. mask1)
+
+        | otherwise
+        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)
+
+
+
+-- | Release a register from allocation.
+--      The register liveness information says that most regs die after a C call,
+--      but we still don't want to allocate to some of them.
+--
+releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs
+releaseReg platform
+         reg@(RealRegSingle r)
+        regs@(FreeRegs g f d)
+
+        -- don't release pinned reg
+        | not $ freeReg platform r
+        = regs
+
+        -- a general purpose reg
+        | r <= 31
+        = let   mask    = bitMask r
+          in    FreeRegs (g .|. mask) f d
+
+        -- a float reg
+        | r >= 32, r <= 63
+        = let   mask    = bitMask (r - 32)
+
+                -- the mask of the double this FP reg aliases
+                maskLow = if r `mod` 2 == 0
+                                then bitMask (r - 32)
+                                else bitMask (r - 32 - 1)
+          in    FreeRegs
+                        g
+                        (f .|. mask)
+                        (d .|. maskLow)
+
+        | otherwise
+        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)
+
+releaseReg _
+         reg@(RealRegPair r1 r2)
+             (FreeRegs g f d)
+
+        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0
+        , r2 >= 32, r2 <= 63
+        = let   mask1   = bitMask (r1 - 32)
+                mask2   = bitMask (r2 - 32)
+          in
+                FreeRegs
+                        g
+                        ((f .|. mask1) .|. mask2)
+                        (d .|. mask1)
+
+        | otherwise
+        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)
+
+
+
+bitMask :: Int -> Word32
+bitMask n       = 1 `shiftL` n
+
+
+showFreeRegs :: FreeRegs -> String
+showFreeRegs regs
+        =  "FreeRegs\n"
+        ++ "    integer: " ++ (show $ getFreeRegs RcInteger regs)       ++ "\n"
+        ++ "      float: " ++ (show $ getFreeRegs RcFloat   regs)       ++ "\n"
+        ++ "     double: " ++ (show $ getFreeRegs RcDouble  regs)       ++ "\n"
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/StackMap.hs b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/StackMap.hs
@@ -0,0 +1,61 @@
+
+-- | The assignment of virtual registers to stack slots
+
+--      We have lots of stack slots. Memory-to-memory moves are a pain on most
+--      architectures. Therefore, we avoid having to generate memory-to-memory moves
+--      by simply giving every virtual register its own stack slot.
+
+--      The StackMap stack map keeps track of virtual register - stack slot
+--      associations and of which stack slots are still free. Once it has been
+--      associated, a stack slot is never "freed" or removed from the StackMap again,
+--      it remains associated until we are done with the current CmmProc.
+--
+module RegAlloc.Linear.StackMap (
+        StackSlot,
+        StackMap(..),
+        emptyStackMap,
+        getStackSlotFor,
+        getStackUse
+)
+
+where
+
+import GhcPrelude
+
+import DynFlags
+import UniqFM
+import Unique
+
+
+-- | Identifier for a stack slot.
+type StackSlot = Int
+
+data StackMap
+        = StackMap
+        { -- | The slots that are still available to be allocated.
+          stackMapNextFreeSlot  :: !Int
+
+          -- | Assignment of vregs to stack slots.
+        , stackMapAssignment    :: UniqFM StackSlot }
+
+
+-- | An empty stack map, with all slots available.
+emptyStackMap :: DynFlags -> StackMap
+emptyStackMap _ = StackMap 0 emptyUFM
+
+
+-- | If this vreg unique already has a stack assignment then return the slot number,
+--      otherwise allocate a new slot, and update the map.
+--
+getStackSlotFor :: StackMap -> Unique -> (StackMap, Int)
+
+getStackSlotFor fs@(StackMap _ reserved) reg
+  | Just slot <- lookupUFM reserved reg  =  (fs, slot)
+
+getStackSlotFor (StackMap freeSlot reserved) reg =
+    (StackMap (freeSlot+1) (addToUFM reserved reg freeSlot), freeSlot)
+
+-- | Return the number of stack slots that were allocated
+getStackUse :: StackMap -> Int
+getStackUse (StackMap freeSlot _) = freeSlot
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/State.hs
@@ -0,0 +1,171 @@
+{-# LANGUAGE UnboxedTuples #-}
+
+-- | State monad for the linear register allocator.
+
+--      Here we keep all the state that the register allocator keeps track
+--      of as it walks the instructions in a basic block.
+
+module RegAlloc.Linear.State (
+        RA_State(..),
+        RegM,
+        runR,
+
+        spillR,
+        loadR,
+
+        getFreeRegsR,
+        setFreeRegsR,
+
+        getAssigR,
+        setAssigR,
+
+        getBlockAssigR,
+        setBlockAssigR,
+
+        setDeltaR,
+        getDeltaR,
+
+        getUniqueR,
+
+        recordSpill,
+        recordFixupBlock
+)
+where
+
+import GhcPrelude
+
+import RegAlloc.Linear.Stats
+import RegAlloc.Linear.StackMap
+import RegAlloc.Linear.Base
+import RegAlloc.Liveness
+import Instruction
+import Reg
+import BlockId
+
+import DynFlags
+import Unique
+import UniqSupply
+
+import Control.Monad (liftM, ap)
+
+-- | The register allocator monad type.
+newtype RegM freeRegs a
+        = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) }
+
+instance Functor (RegM freeRegs) where
+      fmap = liftM
+
+instance Applicative (RegM freeRegs) where
+      pure a  =  RegM $ \s -> (# s, a #)
+      (<*>) = ap
+
+instance Monad (RegM freeRegs) where
+  m >>= k   =  RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
+
+instance HasDynFlags (RegM a) where
+    getDynFlags = RegM $ \s -> (# s, ra_DynFlags s #)
+
+
+-- | Run a computation in the RegM register allocator monad.
+runR    :: DynFlags
+        -> BlockAssignment freeRegs
+        -> freeRegs
+        -> RegMap Loc
+        -> StackMap
+        -> UniqSupply
+        -> RegM freeRegs a
+        -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)
+
+runR dflags block_assig freeregs assig stack us thing =
+  case unReg thing
+        (RA_State
+                { ra_blockassig = block_assig
+                , ra_freeregs   = freeregs
+                , ra_assig      = assig
+                , ra_delta      = 0{-???-}
+                , ra_stack      = stack
+                , ra_us         = us
+                , ra_spills     = []
+                , ra_DynFlags   = dflags
+                , ra_fixups     = [] })
+   of
+        (# state'@RA_State
+                { ra_blockassig = block_assig
+                , ra_stack      = stack' }
+                , returned_thing #)
+
+         ->     (block_assig, stack', makeRAStats state', returned_thing)
+
+
+-- | Make register allocator stats from its final state.
+makeRAStats :: RA_State freeRegs -> RegAllocStats
+makeRAStats state
+        = RegAllocStats
+        { ra_spillInstrs        = binSpillReasons (ra_spills state)
+        , ra_fixupList          = ra_fixups state }
+
+
+spillR :: Instruction instr
+       => Reg -> Unique -> RegM freeRegs (instr, Int)
+
+spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
+  let dflags = ra_DynFlags s
+      (stack',slot) = getStackSlotFor stack temp
+      instr  = mkSpillInstr dflags reg delta slot
+  in
+  (# s{ra_stack=stack'}, (instr,slot) #)
+
+
+loadR :: Instruction instr
+      => Reg -> Int -> RegM freeRegs instr
+
+loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
+  let dflags = ra_DynFlags s
+  in (# s, mkLoadInstr dflags reg delta slot #)
+
+getFreeRegsR :: RegM freeRegs freeRegs
+getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
+  (# s, freeregs #)
+
+setFreeRegsR :: freeRegs -> RegM freeRegs ()
+setFreeRegsR regs = RegM $ \ s ->
+  (# s{ra_freeregs = regs}, () #)
+
+getAssigR :: RegM freeRegs (RegMap Loc)
+getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
+  (# s, assig #)
+
+setAssigR :: RegMap Loc -> RegM freeRegs ()
+setAssigR assig = RegM $ \ s ->
+  (# s{ra_assig=assig}, () #)
+
+getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
+getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
+  (# s, assig #)
+
+setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()
+setBlockAssigR assig = RegM $ \ s ->
+  (# s{ra_blockassig = assig}, () #)
+
+setDeltaR :: Int -> RegM freeRegs ()
+setDeltaR n = RegM $ \ s ->
+  (# s{ra_delta = n}, () #)
+
+getDeltaR :: RegM freeRegs Int
+getDeltaR = RegM $ \s -> (# s, ra_delta s #)
+
+getUniqueR :: RegM freeRegs Unique
+getUniqueR = RegM $ \s ->
+  case takeUniqFromSupply (ra_us s) of
+    (uniq, us) -> (# s{ra_us = us}, uniq #)
+
+
+-- | Record that a spill instruction was inserted, for profiling.
+recordSpill :: SpillReason -> RegM freeRegs ()
+recordSpill spill
+    = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)
+
+-- | Record a created fixup block
+recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs ()
+recordFixupBlock from between to
+    = RegM $ \s -> (# s { ra_fixups = (from,between,to) : ra_fixups s}, () #)
diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs
@@ -0,0 +1,87 @@
+module RegAlloc.Linear.Stats (
+        binSpillReasons,
+        countRegRegMovesNat,
+        pprStats
+)
+
+where
+
+import GhcPrelude
+
+import RegAlloc.Linear.Base
+import RegAlloc.Liveness
+import Instruction
+
+import UniqFM
+import Outputable
+
+import State
+
+-- | Build a map of how many times each reg was alloced, clobbered, loaded etc.
+binSpillReasons
+        :: [SpillReason] -> UniqFM [Int]
+
+binSpillReasons reasons
+        = addListToUFM_C
+                (zipWith (+))
+                emptyUFM
+                (map (\reason -> case reason of
+                        SpillAlloc r    -> (r, [1, 0, 0, 0, 0])
+                        SpillClobber r  -> (r, [0, 1, 0, 0, 0])
+                        SpillLoad r     -> (r, [0, 0, 1, 0, 0])
+                        SpillJoinRR r   -> (r, [0, 0, 0, 1, 0])
+                        SpillJoinRM r   -> (r, [0, 0, 0, 0, 1])) reasons)
+
+
+-- | Count reg-reg moves remaining in this code.
+countRegRegMovesNat
+        :: Instruction instr
+        => NatCmmDecl statics instr -> Int
+
+countRegRegMovesNat cmm
+        = execState (mapGenBlockTopM countBlock cmm) 0
+ where
+        countBlock b@(BasicBlock _ instrs)
+         = do   mapM_ countInstr instrs
+                return  b
+
+        countInstr instr
+                | Just _        <- takeRegRegMoveInstr instr
+                = do    modify (+ 1)
+                        return instr
+
+                | otherwise
+                =       return instr
+
+
+-- | Pretty print some RegAllocStats
+pprStats
+        :: Instruction instr
+        => [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc
+
+pprStats code statss
+ = let  -- sum up all the instrs inserted by the spiller
+        spills          = foldl' (plusUFM_C (zipWith (+)))
+                                emptyUFM
+                        $ map ra_spillInstrs statss
+
+        spillTotals     = foldl' (zipWith (+))
+                                [0, 0, 0, 0, 0]
+                        $ nonDetEltsUFM spills
+                        -- See Note [Unique Determinism and code generation]
+
+        -- count how many reg-reg-moves remain in the code
+        moves           = sum $ map countRegRegMovesNat code
+
+        pprSpill (reg, spills)
+                = parens $ (hcat $ punctuate (text ", ")  (doubleQuotes (ppr reg) : map ppr spills))
+
+   in   (  text "-- spills-added-total"
+        $$ text "--    (allocs, clobbers, loads, joinRR, joinRM, reg_reg_moves_remaining)"
+        $$ (parens $ (hcat $ punctuate (text ", ") (map ppr spillTotals ++ [ppr moves])))
+        $$ text ""
+        $$ text "-- spills-added"
+        $$ text "--    (reg_name, allocs, clobbers, loads, joinRR, joinRM)"
+        $$ (pprUFMWithKeys spills (vcat . map pprSpill))
+        $$ text "")
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs
@@ -0,0 +1,53 @@
+
+-- | Free regs map for i386
+module RegAlloc.Linear.X86.FreeRegs
+where
+
+import GhcPrelude
+
+import X86.Regs
+import RegClass
+import Reg
+import Panic
+import Platform
+
+import Data.Word
+import Data.Bits
+
+newtype FreeRegs = FreeRegs Word32
+    deriving Show
+
+noFreeRegs :: FreeRegs
+noFreeRegs = FreeRegs 0
+
+releaseReg :: RealReg -> FreeRegs -> FreeRegs
+releaseReg (RealRegSingle n) (FreeRegs f)
+        = FreeRegs (f .|. (1 `shiftL` n))
+
+releaseReg _ _
+        = panic "RegAlloc.Linear.X86.FreeRegs.releaseReg: no reg"
+
+initFreeRegs :: Platform -> FreeRegs
+initFreeRegs platform
+        = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)
+
+getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily
+getFreeRegs platform cls (FreeRegs f) = go f 0
+
+  where go 0 _ = []
+        go n m
+          | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls
+          = RealRegSingle m : (go (n `shiftR` 1) $! (m+1))
+
+          | otherwise
+          = go (n `shiftR` 1) $! (m+1)
+        -- ToDo: there's no point looking through all the integer registers
+        -- in order to find a floating-point one.
+
+allocateReg :: RealReg -> FreeRegs -> FreeRegs
+allocateReg (RealRegSingle r) (FreeRegs f)
+        = FreeRegs (f .&. complement (1 `shiftL` r))
+
+allocateReg _ _
+        = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg"
+
diff --git a/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs
@@ -0,0 +1,54 @@
+
+-- | Free regs map for x86_64
+module RegAlloc.Linear.X86_64.FreeRegs
+where
+
+import GhcPrelude
+
+import X86.Regs
+import RegClass
+import Reg
+import Panic
+import Platform
+
+import Data.Word
+import Data.Bits
+
+newtype FreeRegs = FreeRegs Word64
+    deriving Show
+
+noFreeRegs :: FreeRegs
+noFreeRegs = FreeRegs 0
+
+releaseReg :: RealReg -> FreeRegs -> FreeRegs
+releaseReg (RealRegSingle n) (FreeRegs f)
+        = FreeRegs (f .|. (1 `shiftL` n))
+
+releaseReg _ _
+        = panic "RegAlloc.Linear.X86_64.FreeRegs.releaseReg: no reg"
+
+initFreeRegs :: Platform -> FreeRegs
+initFreeRegs platform
+        = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)
+
+getFreeRegs :: Platform -> RegClass -> FreeRegs -> [RealReg] -- lazily
+getFreeRegs platform cls (FreeRegs f) = go f 0
+
+  where go 0 _ = []
+        go n m
+          | n .&. 1 /= 0 && classOfRealReg platform (RealRegSingle m) == cls
+          = RealRegSingle m : (go (n `shiftR` 1) $! (m+1))
+
+          | otherwise
+          = go (n `shiftR` 1) $! (m+1)
+        -- ToDo: there's no point looking through all the integer registers
+        -- in order to find a floating-point one.
+
+allocateReg :: RealReg -> FreeRegs -> FreeRegs
+allocateReg (RealRegSingle r) (FreeRegs f)
+        = FreeRegs (f .&. complement (1 `shiftL` r))
+
+allocateReg _ _
+        = panic "RegAlloc.Linear.X86_64.FreeRegs.allocateReg: no reg"
+
+
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -0,0 +1,1022 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-----------------------------------------------------------------------------
+--
+-- The register liveness determinator
+--
+-- (c) The University of Glasgow 2004-2013
+--
+-----------------------------------------------------------------------------
+
+module RegAlloc.Liveness (
+        RegSet,
+        RegMap, emptyRegMap,
+        BlockMap, mapEmpty,
+        LiveCmmDecl,
+        InstrSR   (..),
+        LiveInstr (..),
+        Liveness (..),
+        LiveInfo (..),
+        LiveBasicBlock,
+
+        mapBlockTop,    mapBlockTopM,   mapSCCM,
+        mapGenBlockTop, mapGenBlockTopM,
+        stripLive,
+        stripLiveBlock,
+        slurpConflicts,
+        slurpReloadCoalesce,
+        eraseDeltasLive,
+        patchEraseLive,
+        patchRegsLiveInstr,
+        reverseBlocksInTops,
+        regLiveness,
+        natCmmTopToLive
+  ) where
+import GhcPrelude
+
+import Reg
+import Instruction
+
+import BlockId
+import CFG
+import Hoopl.Collections
+import Hoopl.Label
+import Cmm hiding (RegSet, emptyRegSet)
+import PprCmm()
+
+import Digraph
+import DynFlags
+import MonadUtils
+import Outputable
+import Platform
+import UniqSet
+import UniqFM
+import UniqSupply
+import Bag
+import State
+
+import Data.List
+import Data.Maybe
+import Data.IntSet              (IntSet)
+
+-----------------------------------------------------------------------------
+type RegSet = UniqSet Reg
+
+type RegMap a = UniqFM a
+
+emptyRegMap :: UniqFM a
+emptyRegMap = emptyUFM
+
+emptyRegSet :: RegSet
+emptyRegSet = emptyUniqSet
+
+type BlockMap a = LabelMap a
+
+
+-- | A top level thing which carries liveness information.
+type LiveCmmDecl statics instr
+        = GenCmmDecl
+                statics
+                LiveInfo
+                [SCC (LiveBasicBlock instr)]
+
+
+-- | The register allocator also wants to use SPILL/RELOAD meta instructions,
+--   so we'll keep those here.
+data InstrSR instr
+        -- | A real machine instruction
+        = Instr  instr
+
+        -- | spill this reg to a stack slot
+        | SPILL  Reg Int
+
+        -- | reload this reg from a stack slot
+        | RELOAD Int Reg
+
+instance Instruction instr => Instruction (InstrSR instr) where
+        regUsageOfInstr platform i
+         = case i of
+                Instr  instr    -> regUsageOfInstr platform instr
+                SPILL  reg _    -> RU [reg] []
+                RELOAD _ reg    -> RU [] [reg]
+
+        patchRegsOfInstr i f
+         = case i of
+                Instr instr     -> Instr (patchRegsOfInstr instr f)
+                SPILL  reg slot -> SPILL (f reg) slot
+                RELOAD slot reg -> RELOAD slot (f reg)
+
+        isJumpishInstr i
+         = case i of
+                Instr instr     -> isJumpishInstr instr
+                _               -> False
+
+        jumpDestsOfInstr i
+         = case i of
+                Instr instr     -> jumpDestsOfInstr instr
+                _               -> []
+
+        patchJumpInstr i f
+         = case i of
+                Instr instr     -> Instr (patchJumpInstr instr f)
+                _               -> i
+
+        mkSpillInstr            = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr"
+        mkLoadInstr             = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr"
+
+        takeDeltaInstr i
+         = case i of
+                Instr instr     -> takeDeltaInstr instr
+                _               -> Nothing
+
+        isMetaInstr i
+         = case i of
+                Instr instr     -> isMetaInstr instr
+                _               -> False
+
+        mkRegRegMoveInstr platform r1 r2
+            = Instr (mkRegRegMoveInstr platform r1 r2)
+
+        takeRegRegMoveInstr i
+         = case i of
+                Instr instr     -> takeRegRegMoveInstr instr
+                _               -> Nothing
+
+        mkJumpInstr target      = map Instr (mkJumpInstr target)
+
+        mkStackAllocInstr platform amount =
+             Instr <$> mkStackAllocInstr platform amount
+
+        mkStackDeallocInstr platform amount =
+             Instr <$> mkStackDeallocInstr platform amount
+
+
+-- | An instruction with liveness information.
+data LiveInstr instr
+        = LiveInstr (InstrSR instr) (Maybe Liveness)
+
+-- | Liveness information.
+--   The regs which die are ones which are no longer live in the *next* instruction
+--   in this sequence.
+--   (NB. if the instruction is a jump, these registers might still be live
+--   at the jump target(s) - you have to check the liveness at the destination
+--   block to find out).
+
+data Liveness
+        = Liveness
+        { liveBorn      :: RegSet       -- ^ registers born in this instruction (written to for first time).
+        , liveDieRead   :: RegSet       -- ^ registers that died because they were read for the last time.
+        , liveDieWrite  :: RegSet }     -- ^ registers that died because they were clobbered by something.
+
+
+-- | Stash regs live on entry to each basic block in the info part of the cmm code.
+data LiveInfo
+        = LiveInfo
+                (LabelMap CmmStatics)     -- cmm info table static stuff
+                [BlockId]                 -- entry points (first one is the
+                                          -- entry point for the proc).
+                (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block
+                (BlockMap IntSet)         -- stack slots live on entry to this block
+
+
+-- | A basic block with liveness information.
+type LiveBasicBlock instr
+        = GenBasicBlock (LiveInstr instr)
+
+
+instance Outputable instr
+      => Outputable (InstrSR instr) where
+
+        ppr (Instr realInstr)
+           = ppr realInstr
+
+        ppr (SPILL reg slot)
+           = hcat [
+                text "\tSPILL",
+                char ' ',
+                ppr reg,
+                comma,
+                text "SLOT" <> parens (int slot)]
+
+        ppr (RELOAD slot reg)
+           = hcat [
+                text "\tRELOAD",
+                char ' ',
+                text "SLOT" <> parens (int slot),
+                comma,
+                ppr reg]
+
+instance Outputable instr
+      => Outputable (LiveInstr instr) where
+
+        ppr (LiveInstr instr Nothing)
+         = ppr instr
+
+        ppr (LiveInstr instr (Just live))
+         =  ppr instr
+                $$ (nest 8
+                        $ vcat
+                        [ pprRegs (text "# born:    ") (liveBorn live)
+                        , pprRegs (text "# r_dying: ") (liveDieRead live)
+                        , pprRegs (text "# w_dying: ") (liveDieWrite live) ]
+                    $+$ space)
+
+         where  pprRegs :: SDoc -> RegSet -> SDoc
+                pprRegs name regs
+                 | isEmptyUniqSet regs  = empty
+                 | otherwise            = name <>
+                     (pprUFM (getUniqSet regs) (hcat . punctuate space . map ppr))
+
+instance Outputable LiveInfo where
+    ppr (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry)
+        =  (ppr mb_static)
+        $$ text "# entryIds         = " <> ppr entryIds
+        $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry
+        $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)
+
+
+
+-- | map a function across all the basic blocks in this code
+--
+mapBlockTop
+        :: (LiveBasicBlock instr -> LiveBasicBlock instr)
+        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
+
+mapBlockTop f cmm
+        = evalState (mapBlockTopM (\x -> return $ f x) cmm) ()
+
+
+-- | map a function across all the basic blocks in this code (monadic version)
+--
+mapBlockTopM
+        :: Monad m
+        => (LiveBasicBlock instr -> m (LiveBasicBlock instr))
+        -> LiveCmmDecl statics instr -> m (LiveCmmDecl statics instr)
+
+mapBlockTopM _ cmm@(CmmData{})
+        = return cmm
+
+mapBlockTopM f (CmmProc header label live sccs)
+ = do   sccs'   <- mapM (mapSCCM f) sccs
+        return  $ CmmProc header label live sccs'
+
+mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
+mapSCCM f (AcyclicSCC x)
+ = do   x'      <- f x
+        return  $ AcyclicSCC x'
+
+mapSCCM f (CyclicSCC xs)
+ = do   xs'     <- mapM f xs
+        return  $ CyclicSCC xs'
+
+
+-- map a function across all the basic blocks in this code
+mapGenBlockTop
+        :: (GenBasicBlock             i -> GenBasicBlock            i)
+        -> (GenCmmDecl d h (ListGraph i) -> GenCmmDecl d h (ListGraph i))
+
+mapGenBlockTop f cmm
+        = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
+
+
+-- | map a function across all the basic blocks in this code (monadic version)
+mapGenBlockTopM
+        :: Monad m
+        => (GenBasicBlock            i  -> m (GenBasicBlock            i))
+        -> (GenCmmDecl d h (ListGraph i) -> m (GenCmmDecl d h (ListGraph i)))
+
+mapGenBlockTopM _ cmm@(CmmData{})
+        = return cmm
+
+mapGenBlockTopM f (CmmProc header label live (ListGraph blocks))
+ = do   blocks' <- mapM f blocks
+        return  $ CmmProc header label live (ListGraph blocks')
+
+
+-- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
+--   Slurping of conflicts and moves is wrapped up together so we don't have
+--   to make two passes over the same code when we want to build the graph.
+--
+slurpConflicts
+        :: Instruction instr
+        => LiveCmmDecl statics instr
+        -> (Bag (UniqSet Reg), Bag (Reg, Reg))
+
+slurpConflicts live
+        = slurpCmm (emptyBag, emptyBag) live
+
+ where  slurpCmm   rs  CmmData{}                = rs
+        slurpCmm   rs (CmmProc info _ _ sccs)
+                = foldl' (slurpSCC info) rs sccs
+
+        slurpSCC  info rs (AcyclicSCC b)
+                = slurpBlock info rs b
+
+        slurpSCC  info rs (CyclicSCC bs)
+                = foldl'  (slurpBlock info) rs bs
+
+        slurpBlock info rs (BasicBlock blockId instrs)
+                | LiveInfo _ _ (Just blockLive) _ <- info
+                , Just rsLiveEntry                <- mapLookup blockId blockLive
+                , (conflicts, moves)              <- slurpLIs rsLiveEntry rs instrs
+                = (consBag rsLiveEntry conflicts, moves)
+
+                | otherwise
+                = panic "Liveness.slurpConflicts: bad block"
+
+        slurpLIs rsLive (conflicts, moves) []
+                = (consBag rsLive conflicts, moves)
+
+        slurpLIs rsLive rs (LiveInstr _ Nothing     : lis)
+                = slurpLIs rsLive rs lis
+
+        slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis)
+         = let
+                -- regs that die because they are read for the last time at the start of an instruction
+                --      are not live across it.
+                rsLiveAcross    = rsLiveEntry `minusUniqSet` (liveDieRead live)
+
+                -- regs live on entry to the next instruction.
+                --      be careful of orphans, make sure to delete dying regs _after_ unioning
+                --      in the ones that are born here.
+                rsLiveNext      = (rsLiveAcross `unionUniqSets` (liveBorn     live))
+                                                `minusUniqSet`  (liveDieWrite live)
+
+                -- orphan vregs are the ones that die in the same instruction they are born in.
+                --      these are likely to be results that are never used, but we still
+                --      need to assign a hreg to them..
+                rsOrphans       = intersectUniqSets
+                                        (liveBorn live)
+                                        (unionUniqSets (liveDieWrite live) (liveDieRead live))
+
+                --
+                rsConflicts     = unionUniqSets rsLiveNext rsOrphans
+
+          in    case takeRegRegMoveInstr instr of
+                 Just rr        -> slurpLIs rsLiveNext
+                                        ( consBag rsConflicts conflicts
+                                        , consBag rr moves) lis
+
+                 Nothing        -> slurpLIs rsLiveNext
+                                        ( consBag rsConflicts conflicts
+                                        , moves) lis
+
+
+-- | For spill\/reloads
+--
+--   SPILL  v1, slot1
+--   ...
+--   RELOAD slot1, v2
+--
+--   If we can arrange that v1 and v2 are allocated to the same hreg it's more likely
+--   the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move.
+--
+--
+slurpReloadCoalesce
+        :: forall statics instr. Instruction instr
+        => LiveCmmDecl statics instr
+        -> Bag (Reg, Reg)
+
+slurpReloadCoalesce live
+        = slurpCmm emptyBag live
+
+ where
+        slurpCmm :: Bag (Reg, Reg)
+                 -> GenCmmDecl t t1 [SCC (LiveBasicBlock instr)]
+                 -> Bag (Reg, Reg)
+        slurpCmm cs CmmData{}   = cs
+        slurpCmm cs (CmmProc _ _ _ sccs)
+                = slurpComp cs (flattenSCCs sccs)
+
+        slurpComp :: Bag (Reg, Reg)
+                     -> [LiveBasicBlock instr]
+                     -> Bag (Reg, Reg)
+        slurpComp  cs blocks
+         = let  (moveBags, _)   = runState (slurpCompM blocks) emptyUFM
+           in   unionManyBags (cs : moveBags)
+
+        slurpCompM :: [LiveBasicBlock instr]
+                   -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
+        slurpCompM blocks
+         = do   -- run the analysis once to record the mapping across jumps.
+                mapM_   (slurpBlock False) blocks
+
+                -- run it a second time while using the information from the last pass.
+                --      We /could/ run this many more times to deal with graphical control
+                --      flow and propagating info across multiple jumps, but it's probably
+                --      not worth the trouble.
+                mapM    (slurpBlock True) blocks
+
+        slurpBlock :: Bool -> LiveBasicBlock instr
+                   -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
+        slurpBlock propagate (BasicBlock blockId instrs)
+         = do   -- grab the slot map for entry to this block
+                slotMap         <- if propagate
+                                        then getSlotMap blockId
+                                        else return emptyUFM
+
+                (_, mMoves)     <- mapAccumLM slurpLI slotMap instrs
+                return $ listToBag $ catMaybes mMoves
+
+        slurpLI :: UniqFM Reg                           -- current slotMap
+                -> LiveInstr instr
+                -> State (UniqFM [UniqFM Reg])          -- blockId -> [slot -> reg]
+                                                        --      for tracking slotMaps across jumps
+
+                         ( UniqFM Reg                   -- new slotMap
+                         , Maybe (Reg, Reg))            -- maybe a new coalesce edge
+
+        slurpLI slotMap li
+
+                -- remember what reg was stored into the slot
+                | LiveInstr (SPILL reg slot) _  <- li
+                , slotMap'                      <- addToUFM slotMap slot reg
+                = return (slotMap', Nothing)
+
+                -- add an edge between the this reg and the last one stored into the slot
+                | LiveInstr (RELOAD slot reg) _ <- li
+                = case lookupUFM slotMap slot of
+                        Just reg2
+                         | reg /= reg2  -> return (slotMap, Just (reg, reg2))
+                         | otherwise    -> return (slotMap, Nothing)
+
+                        Nothing         -> return (slotMap, Nothing)
+
+                -- if we hit a jump, remember the current slotMap
+                | LiveInstr (Instr instr) _     <- li
+                , targets                       <- jumpDestsOfInstr instr
+                , not $ null targets
+                = do    mapM_   (accSlotMap slotMap) targets
+                        return  (slotMap, Nothing)
+
+                | otherwise
+                = return (slotMap, Nothing)
+
+        -- record a slotmap for an in edge to this block
+        accSlotMap slotMap blockId
+                = modify (\s -> addToUFM_C (++) s blockId [slotMap])
+
+        -- work out the slot map on entry to this block
+        --      if we have slot maps for multiple in-edges then we need to merge them.
+        getSlotMap blockId
+         = do   map             <- get
+                let slotMaps    = fromMaybe [] (lookupUFM map blockId)
+                return          $ foldr mergeSlotMaps emptyUFM slotMaps
+
+        mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg
+        mergeSlotMaps map1 map2
+                = listToUFM
+                $ [ (k, r1)
+                  | (k, r1) <- nonDetUFMToList map1
+                  -- This is non-deterministic but we do not
+                  -- currently support deterministic code-generation.
+                  -- See Note [Unique Determinism and code generation]
+                  , case lookupUFM map2 k of
+                          Nothing -> False
+                          Just r2 -> r1 == r2 ]
+
+
+-- | Strip away liveness information, yielding NatCmmDecl
+stripLive
+        :: (Outputable statics, Outputable instr, Instruction instr)
+        => DynFlags
+        -> LiveCmmDecl statics instr
+        -> NatCmmDecl statics instr
+
+stripLive dflags live
+        = stripCmm live
+
+ where  stripCmm :: (Outputable statics, Outputable instr, Instruction instr)
+                 => LiveCmmDecl statics instr -> NatCmmDecl statics instr
+        stripCmm (CmmData sec ds)       = CmmData sec ds
+        stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs)
+         = let  final_blocks    = flattenSCCs sccs
+
+                -- make sure the block that was first in the input list
+                --      stays at the front of the output. This is the entry point
+                --      of the proc, and it needs to come first.
+                ((first':_), rest')
+                                = partition ((== first_id) . blockId) final_blocks
+
+           in   CmmProc info label live
+                          (ListGraph $ map (stripLiveBlock dflags) $ first' : rest')
+
+        -- procs used for stg_split_markers don't contain any blocks, and have no first_id.
+        stripCmm (CmmProc (LiveInfo info [] _ _) label live [])
+         =      CmmProc info label live (ListGraph [])
+
+        -- If the proc has blocks but we don't know what the first one was, then we're dead.
+        stripCmm proc
+                 = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)
+
+-- | Strip away liveness information from a basic block,
+--   and make real spill instructions out of SPILL, RELOAD pseudos along the way.
+
+stripLiveBlock
+        :: Instruction instr
+        => DynFlags
+        -> LiveBasicBlock instr
+        -> NatBasicBlock instr
+
+stripLiveBlock dflags (BasicBlock i lis)
+ =      BasicBlock i instrs'
+
+ where  (instrs', _)
+                = runState (spillNat [] lis) 0
+
+        spillNat acc []
+         =      return (reverse acc)
+
+        spillNat acc (LiveInstr (SPILL reg slot) _ : instrs)
+         = do   delta   <- get
+                spillNat (mkSpillInstr dflags reg delta slot : acc) instrs
+
+        spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs)
+         = do   delta   <- get
+                spillNat (mkLoadInstr dflags reg delta slot : acc) instrs
+
+        spillNat acc (LiveInstr (Instr instr) _ : instrs)
+         | Just i <- takeDeltaInstr instr
+         = do   put i
+                spillNat acc instrs
+
+        spillNat acc (LiveInstr (Instr instr) _ : instrs)
+         =      spillNat (instr : acc) instrs
+
+
+-- | Erase Delta instructions.
+
+eraseDeltasLive
+        :: Instruction instr
+        => LiveCmmDecl statics instr
+        -> LiveCmmDecl statics instr
+
+eraseDeltasLive cmm
+        = mapBlockTop eraseBlock cmm
+ where
+        eraseBlock (BasicBlock id lis)
+                = BasicBlock id
+                $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i)
+                $ lis
+
+
+-- | Patch the registers in this code according to this register mapping.
+--   also erase reg -> reg moves when the reg is the same.
+--   also erase reg -> reg moves when the destination dies in this instr.
+patchEraseLive
+        :: Instruction instr
+        => (Reg -> Reg)
+        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
+
+patchEraseLive patchF cmm
+        = patchCmm cmm
+ where
+        patchCmm cmm@CmmData{}  = cmm
+
+        patchCmm (CmmProc info label live sccs)
+         | LiveInfo static id (Just blockMap) mLiveSlots <- info
+         = let
+                patchRegSet set = mkUniqSet $ map patchF $ nonDetEltsUFM set
+                  -- See Note [Unique Determinism and code generation]
+                blockMap'       = mapMap (patchRegSet . getUniqSet) blockMap
+
+                info'           = LiveInfo static id (Just blockMap') mLiveSlots
+           in   CmmProc info' label live $ map patchSCC sccs
+
+         | otherwise
+         = panic "RegAlloc.Liveness.patchEraseLive: no blockMap"
+
+        patchSCC (AcyclicSCC b)  = AcyclicSCC (patchBlock b)
+        patchSCC (CyclicSCC  bs) = CyclicSCC  (map patchBlock bs)
+
+        patchBlock (BasicBlock id lis)
+                = BasicBlock id $ patchInstrs lis
+
+        patchInstrs []          = []
+        patchInstrs (li : lis)
+
+                | LiveInstr i (Just live)       <- li'
+                , Just (r1, r2) <- takeRegRegMoveInstr i
+                , eatMe r1 r2 live
+                = patchInstrs lis
+
+                | otherwise
+                = li' : patchInstrs lis
+
+                where   li'     = patchRegsLiveInstr patchF li
+
+        eatMe   r1 r2 live
+                -- source and destination regs are the same
+                | r1 == r2      = True
+
+                -- destination reg is never used
+                | elementOfUniqSet r2 (liveBorn live)
+                , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)
+                = True
+
+                | otherwise     = False
+
+
+-- | Patch registers in this LiveInstr, including the liveness information.
+--
+patchRegsLiveInstr
+        :: Instruction instr
+        => (Reg -> Reg)
+        -> LiveInstr instr -> LiveInstr instr
+
+patchRegsLiveInstr patchF li
+ = case li of
+        LiveInstr instr Nothing
+         -> LiveInstr (patchRegsOfInstr instr patchF) Nothing
+
+        LiveInstr instr (Just live)
+         -> LiveInstr
+                (patchRegsOfInstr instr patchF)
+                (Just live
+                        { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg
+                          liveBorn      = mapUniqSet patchF $ liveBorn live
+                        , liveDieRead   = mapUniqSet patchF $ liveDieRead live
+                        , liveDieWrite  = mapUniqSet patchF $ liveDieWrite live })
+                          -- See Note [Unique Determinism and code generation]
+
+
+--------------------------------------------------------------------------------
+-- | Convert a NatCmmDecl to a LiveCmmDecl, with empty liveness information
+
+natCmmTopToLive
+        :: (Instruction instr, Outputable instr)
+        => Maybe CFG -> NatCmmDecl statics instr
+        -> LiveCmmDecl statics instr
+
+natCmmTopToLive _ (CmmData i d)
+        = CmmData i d
+
+natCmmTopToLive _ (CmmProc info lbl live (ListGraph []))
+        = CmmProc (LiveInfo info [] Nothing mapEmpty) lbl live []
+
+natCmmTopToLive mCfg proc@(CmmProc info lbl live (ListGraph blocks@(first : _)))
+        = CmmProc (LiveInfo info' (first_id : entry_ids) Nothing mapEmpty)
+                lbl live sccsLive
+   where
+        first_id        = blockId first
+        all_entry_ids   = entryBlocks proc
+        sccs            = sccBlocks blocks all_entry_ids mCfg
+        sccsLive        = map (fmap (\(BasicBlock l instrs) ->
+                                       BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
+                        $ sccs
+
+        entry_ids       = filter (reachable_node) .
+                          filter (/= first_id) $ all_entry_ids
+        info'           = mapFilterWithKey (\node _ -> reachable_node node) info
+        reachable_node
+          | Just cfg <- mCfg
+          = hasNode cfg
+          | otherwise
+          = const True
+
+--
+-- Compute the liveness graph of the set of basic blocks.  Important:
+-- we also discard any unreachable code here, starting from the entry
+-- points (the first block in the list, and any blocks with info
+-- tables).  Unreachable code arises when code blocks are orphaned in
+-- earlier optimisation passes, and may confuse the register allocator
+-- by referring to registers that are not initialised.  It's easy to
+-- discard the unreachable code as part of the SCC pass, so that's
+-- exactly what we do. (#7574)
+--
+sccBlocks
+        :: forall instr . Instruction instr
+        => [NatBasicBlock instr]
+        -> [BlockId]
+        -> Maybe CFG
+        -> [SCC (NatBasicBlock instr)]
+
+sccBlocks blocks entries mcfg = map (fmap node_payload) sccs
+  where
+        nodes :: [ Node BlockId (NatBasicBlock instr) ]
+        nodes = [ DigraphNode block id (getOutEdges instrs)
+                | block@(BasicBlock id instrs) <- blocks ]
+
+        g1 = graphFromEdgedVerticesUniq nodes
+
+        reachable :: LabelSet
+        reachable
+            | Just cfg <- mcfg
+            -- Our CFG only contains reachable nodes by construction.
+            = getCfgNodes cfg
+            | otherwise
+            = setFromList $ [ node_key node | node <- reachablesG g1 roots ]
+
+        g2 = graphFromEdgedVerticesUniq [ node | node <- nodes
+                                               , node_key node
+                                                  `setMember` reachable ]
+
+        sccs = stronglyConnCompG g2
+
+        getOutEdges :: Instruction instr => [instr] -> [BlockId]
+        getOutEdges instrs = concat $ map jumpDestsOfInstr instrs
+
+        -- This is truly ugly, but I don't see a good alternative.
+        -- Digraph just has the wrong API.  We want to identify nodes
+        -- by their keys (BlockId), but Digraph requires the whole
+        -- node: (NatBasicBlock, BlockId, [BlockId]).  This takes
+        -- advantage of the fact that Digraph only looks at the key,
+        -- even though it asks for the whole triple.
+        roots = [DigraphNode (panic "sccBlocks") b (panic "sccBlocks")
+                | b <- entries ]
+
+--------------------------------------------------------------------------------
+-- Annotate code with register liveness information
+--
+regLiveness
+        :: (Outputable instr, Instruction instr)
+        => Platform
+        -> LiveCmmDecl statics instr
+        -> UniqSM (LiveCmmDecl statics instr)
+
+regLiveness _ (CmmData i d)
+        = return $ CmmData i d
+
+regLiveness _ (CmmProc info lbl live [])
+        | LiveInfo static mFirst _ _    <- info
+        = return $ CmmProc
+                        (LiveInfo static mFirst (Just mapEmpty) mapEmpty)
+                        lbl live []
+
+regLiveness platform (CmmProc info lbl live sccs)
+        | LiveInfo static mFirst _ liveSlotsOnEntry     <- info
+        = let   (ann_sccs, block_live)  = computeLiveness platform sccs
+
+          in    return $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)
+                           lbl live ann_sccs
+
+
+-- -----------------------------------------------------------------------------
+-- | Check ordering of Blocks
+--   The computeLiveness function requires SCCs to be in reverse
+--   dependent order.  If they're not the liveness information will be
+--   wrong, and we'll get a bad allocation.  Better to check for this
+--   precondition explicitly or some other poor sucker will waste a
+--   day staring at bad assembly code..
+--
+checkIsReverseDependent
+        :: Instruction instr
+        => [SCC (LiveBasicBlock instr)]         -- ^ SCCs of blocks that we're about to run the liveness determinator on.
+        -> Maybe BlockId                        -- ^ BlockIds that fail the test (if any)
+
+checkIsReverseDependent sccs'
+ = go emptyUniqSet sccs'
+
+ where  go _ []
+         = Nothing
+
+        go blocksSeen (AcyclicSCC block : sccs)
+         = let  dests           = slurpJumpDestsOfBlock block
+                blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet [blockId block]
+                badDests        = dests `minusUniqSet` blocksSeen'
+           in   case nonDetEltsUniqSet badDests of
+                 -- See Note [Unique Determinism and code generation]
+                 []             -> go blocksSeen' sccs
+                 bad : _        -> Just bad
+
+        go blocksSeen (CyclicSCC blocks : sccs)
+         = let  dests           = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks
+                blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks
+                badDests        = dests `minusUniqSet` blocksSeen'
+           in   case nonDetEltsUniqSet badDests of
+                 -- See Note [Unique Determinism and code generation]
+                 []             -> go blocksSeen' sccs
+                 bad : _        -> Just bad
+
+        slurpJumpDestsOfBlock (BasicBlock _ instrs)
+                = unionManyUniqSets
+                $ map (mkUniqSet . jumpDestsOfInstr)
+                        [ i | LiveInstr i _ <- instrs]
+
+
+-- | If we've compute liveness info for this code already we have to reverse
+--   the SCCs in each top to get them back to the right order so we can do it again.
+reverseBlocksInTops :: LiveCmmDecl statics instr -> LiveCmmDecl statics instr
+reverseBlocksInTops top
+ = case top of
+        CmmData{}                       -> top
+        CmmProc info lbl live sccs      -> CmmProc info lbl live (reverse sccs)
+
+
+-- | Computing liveness
+--
+--  On entry, the SCCs must be in "reverse" order: later blocks may transfer
+--  control to earlier ones only, else `panic`.
+--
+--  The SCCs returned are in the *opposite* order, which is exactly what we
+--  want for the next pass.
+--
+computeLiveness
+        :: (Outputable instr, Instruction instr)
+        => Platform
+        -> [SCC (LiveBasicBlock instr)]
+        -> ([SCC (LiveBasicBlock instr)],       -- instructions annotated with list of registers
+                                                -- which are "dead after this instruction".
+               BlockMap RegSet)                 -- blocks annotated with set of live registers
+                                                -- on entry to the block.
+
+computeLiveness platform sccs
+ = case checkIsReverseDependent sccs of
+        Nothing         -> livenessSCCs platform mapEmpty [] sccs
+        Just bad        -> pprPanic "RegAlloc.Liveness.computeLiveness"
+                                (vcat   [ text "SCCs aren't in reverse dependent order"
+                                        , text "bad blockId" <+> ppr bad
+                                        , ppr sccs])
+
+livenessSCCs
+       :: Instruction instr
+       => Platform
+       -> BlockMap RegSet
+       -> [SCC (LiveBasicBlock instr)]          -- accum
+       -> [SCC (LiveBasicBlock instr)]
+       -> ( [SCC (LiveBasicBlock instr)]
+          , BlockMap RegSet)
+
+livenessSCCs _ blockmap done []
+        = (done, blockmap)
+
+livenessSCCs platform blockmap done (AcyclicSCC block : sccs)
+ = let  (blockmap', block')     = livenessBlock platform blockmap block
+   in   livenessSCCs platform blockmap' (AcyclicSCC block' : done) sccs
+
+livenessSCCs platform blockmap done
+        (CyclicSCC blocks : sccs) =
+        livenessSCCs platform blockmap' (CyclicSCC blocks':done) sccs
+ where      (blockmap', blocks')
+                = iterateUntilUnchanged linearLiveness equalBlockMaps
+                                      blockmap blocks
+
+            iterateUntilUnchanged
+                :: (a -> b -> (a,c)) -> (a -> a -> Bool)
+                -> a -> b
+                -> (a,c)
+
+            iterateUntilUnchanged f eq a b
+                = head $
+                  concatMap tail $
+                  groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
+                  iterate (\(a, _) -> f a b) $
+                  (a, panic "RegLiveness.livenessSCCs")
+
+
+            linearLiveness
+                :: Instruction instr
+                => BlockMap RegSet -> [LiveBasicBlock instr]
+                -> (BlockMap RegSet, [LiveBasicBlock instr])
+
+            linearLiveness = mapAccumL (livenessBlock platform)
+
+                -- probably the least efficient way to compare two
+                -- BlockMaps for equality.
+            equalBlockMaps a b
+                = a' == b'
+              where a' = map f $ mapToList a
+                    b' = map f $ mapToList b
+                    f (key,elt) = (key, nonDetEltsUniqSet elt)
+                    -- See Note [Unique Determinism and code generation]
+
+
+
+-- | Annotate a basic block with register liveness information.
+--
+livenessBlock
+        :: Instruction instr
+        => Platform
+        -> BlockMap RegSet
+        -> LiveBasicBlock instr
+        -> (BlockMap RegSet, LiveBasicBlock instr)
+
+livenessBlock platform blockmap (BasicBlock block_id instrs)
+ = let
+        (regsLiveOnEntry, instrs1)
+            = livenessBack platform emptyUniqSet blockmap [] (reverse instrs)
+        blockmap'       = mapInsert block_id regsLiveOnEntry blockmap
+
+        instrs2         = livenessForward platform regsLiveOnEntry instrs1
+
+        output          = BasicBlock block_id instrs2
+
+   in   ( blockmap', output)
+
+-- | Calculate liveness going forwards,
+--   filling in when regs are born
+
+livenessForward
+        :: Instruction instr
+        => Platform
+        -> RegSet                       -- regs live on this instr
+        -> [LiveInstr instr] -> [LiveInstr instr]
+
+livenessForward _        _           []  = []
+livenessForward platform rsLiveEntry (li@(LiveInstr instr mLive) : lis)
+        | Just live <- mLive
+        = let
+                RU _ written  = regUsageOfInstr platform instr
+                -- Regs that are written to but weren't live on entry to this instruction
+                --      are recorded as being born here.
+                rsBorn          = mkUniqSet
+                                $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written
+
+                rsLiveNext      = (rsLiveEntry `unionUniqSets` rsBorn)
+                                        `minusUniqSet` (liveDieRead live)
+                                        `minusUniqSet` (liveDieWrite live)
+
+        in LiveInstr instr (Just live { liveBorn = rsBorn })
+                : livenessForward platform rsLiveNext lis
+
+        | otherwise
+        = li : livenessForward platform rsLiveEntry lis
+
+
+-- | Calculate liveness going backwards,
+--   filling in when regs die, and what regs are live across each instruction
+
+livenessBack
+        :: Instruction instr
+        => Platform
+        -> RegSet                       -- regs live on this instr
+        -> BlockMap RegSet              -- regs live on entry to other BBs
+        -> [LiveInstr instr]            -- instructions (accum)
+        -> [LiveInstr instr]            -- instructions
+        -> (RegSet, [LiveInstr instr])
+
+livenessBack _        liveregs _        done []  = (liveregs, done)
+
+livenessBack platform liveregs blockmap acc (instr : instrs)
+ = let  (liveregs', instr')     = liveness1 platform liveregs blockmap instr
+   in   livenessBack platform liveregs' blockmap (instr' : acc) instrs
+
+
+-- don't bother tagging comments or deltas with liveness
+liveness1
+        :: Instruction instr
+        => Platform
+        -> RegSet
+        -> BlockMap RegSet
+        -> LiveInstr instr
+        -> (RegSet, LiveInstr instr)
+
+liveness1 _ liveregs _ (LiveInstr instr _)
+        | isMetaInstr instr
+        = (liveregs, LiveInstr instr Nothing)
+
+liveness1 platform liveregs blockmap (LiveInstr instr _)
+
+        | not_a_branch
+        = (liveregs1, LiveInstr instr
+                        (Just $ Liveness
+                        { liveBorn      = emptyUniqSet
+                        , liveDieRead   = mkUniqSet r_dying
+                        , liveDieWrite  = mkUniqSet w_dying }))
+
+        | otherwise
+        = (liveregs_br, LiveInstr instr
+                        (Just $ Liveness
+                        { liveBorn      = emptyUniqSet
+                        , liveDieRead   = mkUniqSet r_dying_br
+                        , liveDieWrite  = mkUniqSet w_dying }))
+
+        where
+            !(RU read written) = regUsageOfInstr platform instr
+
+            -- registers that were written here are dead going backwards.
+            -- registers that were read here are live going backwards.
+            liveregs1   = (liveregs `delListFromUniqSet` written)
+                                    `addListToUniqSet` read
+
+            -- registers that are not live beyond this point, are recorded
+            --  as dying here.
+            r_dying     = [ reg | reg <- read, reg `notElem` written,
+                              not (elementOfUniqSet reg liveregs) ]
+
+            w_dying     = [ reg | reg <- written,
+                             not (elementOfUniqSet reg liveregs) ]
+
+            -- union in the live regs from all the jump destinations of this
+            -- instruction.
+            targets      = jumpDestsOfInstr instr -- where we go from here
+            not_a_branch = null targets
+
+            targetLiveRegs target
+                  = case mapLookup target blockmap of
+                                Just ra -> ra
+                                Nothing -> emptyRegSet
+
+            live_from_branch = unionManyUniqSets (map targetLiveRegs targets)
+
+            liveregs_br = liveregs1 `unionUniqSets` live_from_branch
+
+            -- registers that are live only in the branch targets should
+            -- be listed as dying here.
+            live_branch_only = live_from_branch `minusUniqSet` liveregs
+            r_dying_br  = nonDetEltsUniqSet (mkUniqSet r_dying `unionUniqSets`
+                                             live_branch_only)
+                          -- See Note [Unique Determinism and code generation]
diff --git a/compiler/nativeGen/RegClass.hs b/compiler/nativeGen/RegClass.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/RegClass.hs
@@ -0,0 +1,35 @@
+-- | An architecture independent description of a register's class.
+module RegClass
+        ( RegClass (..) )
+
+where
+
+import GhcPrelude
+
+import  Outputable
+import  Unique
+
+
+-- | The class of a register.
+--      Used in the register allocator.
+--      We treat all registers in a class as being interchangable.
+--
+data RegClass
+        = RcInteger
+        | RcFloat
+        | RcDouble
+        | RcDoubleSSE -- x86 only: the SSE regs are a separate class
+        deriving Eq
+
+
+instance Uniquable RegClass where
+    getUnique RcInteger = mkRegClassUnique 0
+    getUnique RcFloat   = mkRegClassUnique 1
+    getUnique RcDouble  = mkRegClassUnique 2
+    getUnique RcDoubleSSE = mkRegClassUnique 3
+
+instance Outputable RegClass where
+    ppr RcInteger       = Outputable.text "I"
+    ppr RcFloat         = Outputable.text "F"
+    ppr RcDouble        = Outputable.text "D"
+    ppr RcDoubleSSE     = Outputable.text "S"
diff --git a/compiler/nativeGen/SPARC/AddrMode.hs b/compiler/nativeGen/SPARC/AddrMode.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/AddrMode.hs
@@ -0,0 +1,44 @@
+
+module SPARC.AddrMode (
+        AddrMode(..),
+        addrOffset
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.Imm
+import SPARC.Base
+import Reg
+
+-- addressing modes ------------------------------------------------------------
+
+-- | Represents a memory address in an instruction.
+--      Being a RISC machine, the SPARC addressing modes are very regular.
+--
+data AddrMode
+        = AddrRegReg    Reg Reg         -- addr = r1 + r2
+        | AddrRegImm    Reg Imm         -- addr = r1 + imm
+
+
+-- | Add an integer offset to the address in an AddrMode.
+--
+addrOffset :: AddrMode -> Int -> Maybe AddrMode
+addrOffset addr off
+  = case addr of
+      AddrRegImm r (ImmInt n)
+       | fits13Bits n2 -> Just (AddrRegImm r (ImmInt n2))
+       | otherwise     -> Nothing
+       where n2 = n + off
+
+      AddrRegImm r (ImmInteger n)
+       | fits13Bits n2 -> Just (AddrRegImm r (ImmInt (fromInteger n2)))
+       | otherwise     -> Nothing
+       where n2 = n + toInteger off
+
+      AddrRegReg r (RegReal (RealRegSingle 0))
+       | fits13Bits off -> Just (AddrRegImm r (ImmInt off))
+       | otherwise     -> Nothing
+
+      _ -> Nothing
diff --git a/compiler/nativeGen/SPARC/Base.hs b/compiler/nativeGen/SPARC/Base.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/Base.hs
@@ -0,0 +1,77 @@
+
+-- | Bits and pieces on the bottom of the module dependency tree.
+--      Also import the required constants, so we know what we're using.
+--
+--      In the interests of cross-compilation, we want to free ourselves
+--      from the autoconf generated modules like main/Constants
+
+module SPARC.Base (
+        wordLength,
+        wordLengthInBits,
+        spillAreaLength,
+        spillSlotSize,
+        extraStackArgsHere,
+        fits13Bits,
+        is32BitInteger,
+        largeOffsetError
+)
+
+where
+
+import GhcPrelude
+
+import DynFlags
+import Panic
+
+import Data.Int
+
+
+-- On 32 bit SPARC, pointers are 32 bits.
+wordLength :: Int
+wordLength = 4
+
+wordLengthInBits :: Int
+wordLengthInBits
+        = wordLength * 8
+
+-- Size of the available spill area
+spillAreaLength :: DynFlags -> Int
+spillAreaLength
+        = rESERVED_C_STACK_BYTES
+
+-- | We need 8 bytes because our largest registers are 64 bit.
+spillSlotSize :: Int
+spillSlotSize = 8
+
+
+-- | We (allegedly) put the first six C-call arguments in registers;
+--      where do we start putting the rest of them?
+extraStackArgsHere :: Int
+extraStackArgsHere = 23
+
+
+{-# SPECIALIZE fits13Bits :: Int -> Bool, Integer -> Bool #-}
+-- | Check whether an offset is representable with 13 bits.
+fits13Bits :: Integral a => a -> Bool
+fits13Bits x = x >= -4096 && x < 4096
+
+-- | Check whether an integer will fit in 32 bits.
+--      A CmmInt is intended to be truncated to the appropriate
+--      number of bits, so here we truncate it to Int64.  This is
+--      important because e.g. -1 as a CmmInt might be either
+--      -1 or 18446744073709551615.
+--
+is32BitInteger :: Integer -> Bool
+is32BitInteger i
+        = i64 <= 0x7fffffff && i64 >= -0x80000000
+        where i64 = fromIntegral i :: Int64
+
+
+-- | Sadness.
+largeOffsetError :: (Show a) => a -> b
+largeOffsetError i
+  = panic ("ERROR: SPARC native-code generator cannot handle large offset ("
+                ++ show i ++ ");\nprobably because of large constant data structures;" ++
+                "\nworkaround: use -fllvm on this module.\n")
+
+
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -0,0 +1,694 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Generating machine code (instruction selection)
+--
+-- (c) The University of Glasgow 1996-2013
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE GADTs #-}
+module SPARC.CodeGen (
+        cmmTopCodeGen,
+        generateJumpTableForInstr,
+        InstrBlock
+)
+
+where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+#include "../includes/MachDeps.h"
+
+-- NCG stuff:
+import GhcPrelude
+
+import SPARC.Base
+import SPARC.CodeGen.Sanity
+import SPARC.CodeGen.Amode
+import SPARC.CodeGen.CondCode
+import SPARC.CodeGen.Gen64
+import SPARC.CodeGen.Gen32
+import SPARC.CodeGen.Base
+import SPARC.Ppr        ()
+import SPARC.Instr
+import SPARC.Imm
+import SPARC.AddrMode
+import SPARC.Regs
+import SPARC.Stack
+import Instruction
+import Format
+import NCGMonad   ( NatM, getNewRegNat, getNewLabelNat )
+
+-- Our intermediate code:
+import BlockId
+import Cmm
+import CmmUtils
+import CmmSwitch
+import Hoopl.Block
+import Hoopl.Graph
+import PIC
+import Reg
+import CLabel
+import CPrim
+
+-- The rest:
+import BasicTypes
+import DynFlags
+import FastString
+import OrdList
+import Outputable
+import Platform
+
+import Control.Monad    ( mapAndUnzipM )
+
+-- | Top level code generation
+cmmTopCodeGen :: RawCmmDecl
+              -> NatM [NatCmmDecl CmmStatics Instr]
+
+cmmTopCodeGen (CmmProc info lab live graph)
+ = do let blocks = toBlockListEntryFirst graph
+      (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
+
+      let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
+      let tops = proc : concat statics
+
+      return tops
+
+cmmTopCodeGen (CmmData sec dat) = do
+  return [CmmData sec dat]  -- no translation, we just use CmmStatic
+
+
+-- | Do code generation on a single block of CMM code.
+--      code generation may introduce new basic block boundaries, which
+--      are indicated by the NEWBLOCK instruction.  We must split up the
+--      instruction stream into basic blocks again.  Also, we extract
+--      LDATAs here too.
+basicBlockCodeGen :: CmmBlock
+                  -> NatM ( [NatBasicBlock Instr]
+                          , [NatCmmDecl CmmStatics Instr])
+
+basicBlockCodeGen block = do
+  let (_, nodes, tail)  = blockSplit block
+      id = entryLabel block
+      stmts = blockToList nodes
+  mid_instrs <- stmtsToInstrs stmts
+  tail_instrs <- stmtToInstrs tail
+  let instrs = mid_instrs `appOL` tail_instrs
+  let
+        (top,other_blocks,statics)
+                = foldrOL mkBlocks ([],[],[]) instrs
+
+        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
+          = ([], BasicBlock id instrs : blocks, statics)
+
+        mkBlocks (LDATA sec dat) (instrs,blocks,statics)
+          = (instrs, blocks, CmmData sec dat:statics)
+
+        mkBlocks instr (instrs,blocks,statics)
+          = (instr:instrs, blocks, statics)
+
+        -- do intra-block sanity checking
+        blocksChecked
+                = map (checkBlock block)
+                $ BasicBlock id top : other_blocks
+
+  return (blocksChecked, statics)
+
+
+-- | Convert some Cmm statements to SPARC instructions.
+stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
+stmtsToInstrs stmts
+   = do instrss <- mapM stmtToInstrs stmts
+        return (concatOL instrss)
+
+
+stmtToInstrs :: CmmNode e x -> NatM InstrBlock
+stmtToInstrs stmt = do
+  dflags <- getDynFlags
+  case stmt of
+    CmmComment s   -> return (unitOL (COMMENT s))
+    CmmTick {}     -> return nilOL
+    CmmUnwind {}   -> return nilOL
+
+    CmmAssign reg src
+      | isFloatType ty  -> assignReg_FltCode format reg src
+      | isWord64 ty     -> assignReg_I64Code        reg src
+      | otherwise       -> assignReg_IntCode format reg src
+        where ty = cmmRegType dflags reg
+              format = cmmTypeFormat ty
+
+    CmmStore addr src
+      | isFloatType ty  -> assignMem_FltCode format addr src
+      | isWord64 ty     -> assignMem_I64Code      addr src
+      | otherwise       -> assignMem_IntCode format addr src
+        where ty = cmmExprType dflags src
+              format = cmmTypeFormat ty
+
+    CmmUnsafeForeignCall target result_regs args
+       -> genCCall target result_regs args
+
+    CmmBranch   id              -> genBranch id
+    CmmCondBranch arg true false _ -> do
+      b1 <- genCondJump true arg
+      b2 <- genBranch false
+      return (b1 `appOL` b2)
+    CmmSwitch arg ids   -> do dflags <- getDynFlags
+                              genSwitch dflags arg ids
+    CmmCall { cml_target = arg } -> genJump arg
+
+    _
+     -> panic "stmtToInstrs: statement should have been cps'd away"
+
+
+{-
+Now, given a tree (the argument to a CmmLoad) that references memory,
+produce a suitable addressing mode.
+
+A Rule of the Game (tm) for Amodes: use of the addr bit must
+immediately follow use of the code part, since the code part puts
+values in registers which the addr then refers to.  So you can't put
+anything in between, lest it overwrite some of those registers.  If
+you need to do some other computation between the code part and use of
+the addr bit, first store the effective address from the amode in a
+temporary, then do the other computation, and then use the temporary:
+
+    code
+    LEA amode, tmp
+    ... other computation ...
+    ... (tmp) ...
+-}
+
+
+
+-- | Convert a BlockId to some CmmStatic data
+jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
+jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))
+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
+    where blockLabel = blockLbl blockid
+
+
+
+-- -----------------------------------------------------------------------------
+-- Generating assignments
+
+-- Assignments are really at the heart of the whole code generation
+-- business.  Almost all top-level nodes of any real importance are
+-- assignments, which correspond to loads, stores, or register
+-- transfers.  If we're really lucky, some of the register transfers
+-- will go away, because we can use the destination register to
+-- complete the code generation for the right hand side.  This only
+-- fails when the right hand side is forced into a fixed register
+-- (e.g. the result of a call).
+
+assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignMem_IntCode pk addr src = do
+    (srcReg, code) <- getSomeReg src
+    Amode dstAddr addr_code <- getAmode addr
+    return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
+
+
+assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
+assignReg_IntCode _ reg src = do
+    dflags <- getDynFlags
+    r <- getRegister src
+    let dst = getRegisterReg (targetPlatform dflags) reg
+    return $ case r of
+        Any _ code         -> code dst
+        Fixed _ freg fcode -> fcode `snocOL` OR False g0 (RIReg freg) dst
+
+
+
+-- Floating point assignment to memory
+assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignMem_FltCode pk addr src = do
+    dflags <- getDynFlags
+    Amode dst__2 code1 <- getAmode addr
+    (src__2, code2) <- getSomeReg src
+    tmp1 <- getNewRegNat pk
+    let
+        pk__2   = cmmExprType dflags src
+        code__2 = code1 `appOL` code2 `appOL`
+            if   formatToWidth pk == typeWidth pk__2
+            then unitOL (ST pk src__2 dst__2)
+            else toOL   [ FxTOy (cmmTypeFormat pk__2) pk src__2 tmp1
+                        , ST    pk tmp1 dst__2]
+    return code__2
+
+-- Floating point assignment to a register/temporary
+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
+assignReg_FltCode pk dstCmmReg srcCmmExpr = do
+    dflags <- getDynFlags
+    let platform = targetPlatform dflags
+    srcRegister <- getRegister srcCmmExpr
+    let dstReg  = getRegisterReg platform dstCmmReg
+
+    return $ case srcRegister of
+        Any _ code                  -> code dstReg
+        Fixed _ srcFixedReg srcCode -> srcCode `snocOL` FMOV pk srcFixedReg dstReg
+
+
+
+
+genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
+
+genJump (CmmLit (CmmLabel lbl))
+  = return (toOL [CALL (Left target) 0 True, NOP])
+  where
+    target = ImmCLbl lbl
+
+genJump tree
+  = do
+        (target, code) <- getSomeReg tree
+        return (code `snocOL` JMP (AddrRegReg target g0)  `snocOL` NOP)
+
+-- -----------------------------------------------------------------------------
+--  Unconditional branches
+
+genBranch :: BlockId -> NatM InstrBlock
+genBranch = return . toOL . mkJumpInstr
+
+
+-- -----------------------------------------------------------------------------
+--  Conditional jumps
+
+{-
+Conditional jumps are always to local labels, so we can use branch
+instructions.  We peek at the arguments to decide what kind of
+comparison to do.
+
+SPARC: First, we have to ensure that the condition codes are set
+according to the supplied comparison operation.  We generate slightly
+different code for floating point comparisons, because a floating
+point operation cannot directly precede a @BF@.  We assume the worst
+and fill that slot with a @NOP@.
+
+SPARC: Do not fill the delay slots here; you will confuse the register
+allocator.
+-}
+
+
+genCondJump
+    :: BlockId      -- the branch target
+    -> CmmExpr      -- the condition on which to branch
+    -> NatM InstrBlock
+
+
+
+genCondJump bid bool = do
+  CondCode is_float cond code <- getCondCode bool
+  return (
+       code `appOL`
+       toOL (
+         if   is_float
+         then [NOP, BF cond False bid, NOP]
+         else [BI cond False bid, NOP]
+       )
+    )
+
+
+
+-- -----------------------------------------------------------------------------
+-- Generating a table-branch
+
+genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
+genSwitch dflags expr targets
+        | positionIndependent dflags
+        = error "MachCodeGen: sparc genSwitch PIC not finished\n"
+
+        | otherwise
+        = do    (e_reg, e_code) <- getSomeReg (cmmOffset dflags expr offset)
+
+                base_reg        <- getNewRegNat II32
+                offset_reg      <- getNewRegNat II32
+                dst             <- getNewRegNat II32
+
+                label           <- getNewLabelNat
+
+                return $ e_code `appOL`
+                 toOL
+                        [ -- load base of jump table
+                          SETHI (HI (ImmCLbl label)) base_reg
+                        , OR    False base_reg (RIImm $ LO $ ImmCLbl label) base_reg
+
+                        -- the addrs in the table are 32 bits wide..
+                        , SLL   e_reg (RIImm $ ImmInt 2) offset_reg
+
+                        -- load and jump to the destination
+                        , LD      II32 (AddrRegReg base_reg offset_reg) dst
+                        , JMP_TBL (AddrRegImm dst (ImmInt 0)) ids label
+                        , NOP ]
+  where (offset, ids) = switchTargetsToTable targets
+
+generateJumpTableForInstr :: DynFlags -> Instr
+                          -> Maybe (NatCmmDecl CmmStatics Instr)
+generateJumpTableForInstr dflags (JMP_TBL _ ids label) =
+  let jumpTable = map (jumpTableEntry dflags) ids
+  in Just (CmmData (Section ReadOnlyData label) (Statics label jumpTable))
+generateJumpTableForInstr _ _ = Nothing
+
+
+
+-- -----------------------------------------------------------------------------
+-- Generating C calls
+
+{-
+   Now the biggest nightmare---calls.  Most of the nastiness is buried in
+   @get_arg@, which moves the arguments to the correct registers/stack
+   locations.  Apart from that, the code is easy.
+
+   The SPARC calling convention is an absolute
+   nightmare.  The first 6x32 bits of arguments are mapped into
+   %o0 through %o5, and the remaining arguments are dumped to the
+   stack, beginning at [%sp+92].  (Note that %o6 == %sp.)
+
+   If we have to put args on the stack, move %o6==%sp down by
+   the number of words to go on the stack, to ensure there's enough space.
+
+   According to Fraser and Hanson's lcc book, page 478, fig 17.2,
+   16 words above the stack pointer is a word for the address of
+   a structure return value.  I use this as a temporary location
+   for moving values from float to int regs.  Certainly it isn't
+   safe to put anything in the 16 words starting at %sp, since
+   this area can get trashed at any time due to window overflows
+   caused by signal handlers.
+
+   A final complication (if the above isn't enough) is that
+   we can't blithely calculate the arguments one by one into
+   %o0 .. %o5.  Consider the following nested calls:
+
+       fff a (fff b c)
+
+   Naive code moves a into %o0, and (fff b c) into %o1.  Unfortunately
+   the inner call will itself use %o0, which trashes the value put there
+   in preparation for the outer call.  Upshot: we need to calculate the
+   args into temporary regs, and move those to arg regs or onto the
+   stack only immediately prior to the call proper.  Sigh.
+-}
+
+genCCall
+    :: ForeignTarget            -- function to call
+    -> [CmmFormal]        -- where to put the result
+    -> [CmmActual]        -- arguments (of mixed type)
+    -> NatM InstrBlock
+
+
+
+-- On SPARC under TSO (Total Store Ordering), writes earlier in the instruction stream
+-- are guaranteed to take place before writes afterwards (unlike on PowerPC).
+-- Ref: Section 8.4 of the SPARC V9 Architecture manual.
+--
+-- In the SPARC case we don't need a barrier.
+--
+genCCall (PrimTarget MO_WriteBarrier) _ _
+ = return $ nilOL
+
+genCCall (PrimTarget (MO_Prefetch_Data _)) _ _
+ = return $ nilOL
+
+genCCall target dest_regs args
+ = do   -- work out the arguments, and assign them to integer regs
+        argcode_and_vregs       <- mapM arg_to_int_vregs args
+        let (argcodes, vregss)  = unzip argcode_and_vregs
+        let vregs               = concat vregss
+
+        let n_argRegs           = length allArgRegs
+        let n_argRegs_used      = min (length vregs) n_argRegs
+
+
+        -- deal with static vs dynamic call targets
+        callinsns <- case target of
+                ForeignTarget (CmmLit (CmmLabel lbl)) _ ->
+                        return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
+
+                ForeignTarget expr _
+                 -> do  (dyn_c, dyn_rs) <- arg_to_int_vregs expr
+                        let dyn_r = case dyn_rs of
+                                      [dyn_r'] -> dyn_r'
+                                      _ -> panic "SPARC.CodeGen.genCCall: arg_to_int"
+                        return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
+
+                PrimTarget mop
+                 -> do  res     <- outOfLineMachOp mop
+                        lblOrMopExpr <- case res of
+                                Left lbl -> do
+                                        return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))
+
+                                Right mopExpr -> do
+                                        (dyn_c, dyn_rs) <- arg_to_int_vregs mopExpr
+                                        let dyn_r = case dyn_rs of
+                                                      [dyn_r'] -> dyn_r'
+                                                      _ -> panic "SPARC.CodeGen.genCCall: arg_to_int"
+                                        return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False)
+
+                        return lblOrMopExpr
+
+        let argcode = concatOL argcodes
+
+        let (move_sp_down, move_sp_up)
+                   = let diff = length vregs - n_argRegs
+                         nn   = if odd diff then diff + 1 else diff -- keep 8-byte alignment
+                     in  if   nn <= 0
+                         then (nilOL, nilOL)
+                         else (unitOL (moveSp (-1*nn)), unitOL (moveSp (1*nn)))
+
+        let transfer_code
+                = toOL (move_final vregs allArgRegs extraStackArgsHere)
+
+        dflags <- getDynFlags
+        return
+         $      argcode                 `appOL`
+                move_sp_down            `appOL`
+                transfer_code           `appOL`
+                callinsns               `appOL`
+                unitOL NOP              `appOL`
+                move_sp_up              `appOL`
+                assign_code (targetPlatform dflags) dest_regs
+
+
+-- | Generate code to calculate an argument, and move it into one
+--      or two integer vregs.
+arg_to_int_vregs :: CmmExpr -> NatM (OrdList Instr, [Reg])
+arg_to_int_vregs arg = do dflags <- getDynFlags
+                          arg_to_int_vregs' dflags arg
+
+arg_to_int_vregs' :: DynFlags -> CmmExpr -> NatM (OrdList Instr, [Reg])
+arg_to_int_vregs' dflags arg
+
+        -- If the expr produces a 64 bit int, then we can just use iselExpr64
+        | isWord64 (cmmExprType dflags arg)
+        = do    (ChildCode64 code r_lo) <- iselExpr64 arg
+                let r_hi                = getHiVRegFromLo r_lo
+                return (code, [r_hi, r_lo])
+
+        | otherwise
+        = do    (src, code)     <- getSomeReg arg
+                let pk          = cmmExprType dflags arg
+
+                case cmmTypeFormat pk of
+
+                 -- Load a 64 bit float return value into two integer regs.
+                 FF64 -> do
+                        v1 <- getNewRegNat II32
+                        v2 <- getNewRegNat II32
+
+                        let code2 =
+                                code                            `snocOL`
+                                FMOV FF64 src f0                `snocOL`
+                                ST   FF32  f0 (spRel 16)        `snocOL`
+                                LD   II32  (spRel 16) v1        `snocOL`
+                                ST   FF32  f1 (spRel 16)        `snocOL`
+                                LD   II32  (spRel 16) v2
+
+                        return  (code2, [v1,v2])
+
+                 -- Load a 32 bit float return value into an integer reg
+                 FF32 -> do
+                        v1 <- getNewRegNat II32
+
+                        let code2 =
+                                code                            `snocOL`
+                                ST   FF32  src (spRel 16)       `snocOL`
+                                LD   II32  (spRel 16) v1
+
+                        return (code2, [v1])
+
+                 -- Move an integer return value into its destination reg.
+                 _ -> do
+                        v1 <- getNewRegNat II32
+
+                        let code2 =
+                                code                            `snocOL`
+                                OR False g0 (RIReg src) v1
+
+                        return (code2, [v1])
+
+
+-- | Move args from the integer vregs into which they have been
+--      marshalled, into %o0 .. %o5, and the rest onto the stack.
+--
+move_final :: [Reg] -> [Reg] -> Int -> [Instr]
+
+-- all args done
+move_final [] _ _
+        = []
+
+-- out of aregs; move to stack
+move_final (v:vs) [] offset
+        = ST II32 v (spRel offset)
+        : move_final vs [] (offset+1)
+
+-- move into an arg (%o[0..5]) reg
+move_final (v:vs) (a:az) offset
+        = OR False g0 (RIReg v) a
+        : move_final vs az offset
+
+
+-- | Assign results returned from the call into their
+--      destination regs.
+--
+assign_code :: Platform -> [LocalReg] -> OrdList Instr
+
+assign_code _ [] = nilOL
+
+assign_code platform [dest]
+ = let  rep     = localRegType dest
+        width   = typeWidth rep
+        r_dest  = getRegisterReg platform (CmmLocal dest)
+
+        result
+                | isFloatType rep
+                , W32   <- width
+                = unitOL $ FMOV FF32 (regSingle $ fReg 0) r_dest
+
+                | isFloatType rep
+                , W64   <- width
+                = unitOL $ FMOV FF64 (regSingle $ fReg 0) r_dest
+
+                | not $ isFloatType rep
+                , W32   <- width
+                = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest
+
+                | not $ isFloatType rep
+                , W64           <- width
+                , r_dest_hi     <- getHiVRegFromLo r_dest
+                = toOL  [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi
+                        , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest]
+
+                | otherwise
+                = panic "SPARC.CodeGen.GenCCall: no match"
+
+   in   result
+
+assign_code _ _
+        = panic "SPARC.CodeGen.GenCCall: no match"
+
+
+
+-- | Generate a call to implement an out-of-line floating point operation
+outOfLineMachOp
+        :: CallishMachOp
+        -> NatM (Either CLabel CmmExpr)
+
+outOfLineMachOp mop
+ = do   let functionName
+                = outOfLineMachOp_table mop
+
+        dflags  <- getDynFlags
+        mopExpr <- cmmMakeDynamicReference dflags CallReference
+                $  mkForeignLabel functionName Nothing ForeignLabelInExternalPackage IsFunction
+
+        let mopLabelOrExpr
+                = case mopExpr of
+                        CmmLit (CmmLabel lbl)   -> Left lbl
+                        _                       -> Right mopExpr
+
+        return mopLabelOrExpr
+
+
+-- | Decide what C function to use to implement a CallishMachOp
+--
+outOfLineMachOp_table
+        :: CallishMachOp
+        -> FastString
+
+outOfLineMachOp_table mop
+ = case mop of
+        MO_F32_Exp    -> fsLit "expf"
+        MO_F32_Log    -> fsLit "logf"
+        MO_F32_Sqrt   -> fsLit "sqrtf"
+        MO_F32_Fabs   -> unsupported
+        MO_F32_Pwr    -> fsLit "powf"
+
+        MO_F32_Sin    -> fsLit "sinf"
+        MO_F32_Cos    -> fsLit "cosf"
+        MO_F32_Tan    -> fsLit "tanf"
+
+        MO_F32_Asin   -> fsLit "asinf"
+        MO_F32_Acos   -> fsLit "acosf"
+        MO_F32_Atan   -> fsLit "atanf"
+
+        MO_F32_Sinh   -> fsLit "sinhf"
+        MO_F32_Cosh   -> fsLit "coshf"
+        MO_F32_Tanh   -> fsLit "tanhf"
+
+        MO_F32_Asinh  -> fsLit "asinhf"
+        MO_F32_Acosh  -> fsLit "acoshf"
+        MO_F32_Atanh  -> fsLit "atanhf"
+
+        MO_F64_Exp    -> fsLit "exp"
+        MO_F64_Log    -> fsLit "log"
+        MO_F64_Sqrt   -> fsLit "sqrt"
+        MO_F64_Fabs   -> unsupported
+        MO_F64_Pwr    -> fsLit "pow"
+
+        MO_F64_Sin    -> fsLit "sin"
+        MO_F64_Cos    -> fsLit "cos"
+        MO_F64_Tan    -> fsLit "tan"
+
+        MO_F64_Asin   -> fsLit "asin"
+        MO_F64_Acos   -> fsLit "acos"
+        MO_F64_Atan   -> fsLit "atan"
+
+        MO_F64_Sinh   -> fsLit "sinh"
+        MO_F64_Cosh   -> fsLit "cosh"
+        MO_F64_Tanh   -> fsLit "tanh"
+
+        MO_F64_Asinh  -> fsLit "asinh"
+        MO_F64_Acosh  -> fsLit "acosh"
+        MO_F64_Atanh  -> fsLit "atanh"
+
+        MO_UF_Conv w -> fsLit $ word2FloatLabel w
+
+        MO_Memcpy _  -> fsLit "memcpy"
+        MO_Memset _  -> fsLit "memset"
+        MO_Memmove _ -> fsLit "memmove"
+        MO_Memcmp _  -> fsLit "memcmp"
+
+        MO_BSwap w   -> fsLit $ bSwapLabel w
+        MO_PopCnt w  -> fsLit $ popCntLabel w
+        MO_Pdep w    -> fsLit $ pdepLabel w
+        MO_Pext w    -> fsLit $ pextLabel w
+        MO_Clz w     -> fsLit $ clzLabel w
+        MO_Ctz w     -> fsLit $ ctzLabel w
+        MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop
+        MO_Cmpxchg w -> fsLit $ cmpxchgLabel w
+        MO_AtomicRead w -> fsLit $ atomicReadLabel w
+        MO_AtomicWrite w -> fsLit $ atomicWriteLabel w
+
+        MO_S_QuotRem {}  -> unsupported
+        MO_U_QuotRem {}  -> unsupported
+        MO_U_QuotRem2 {} -> unsupported
+        MO_Add2 {}       -> unsupported
+        MO_AddWordC {}   -> unsupported
+        MO_SubWordC {}   -> unsupported
+        MO_AddIntC {}    -> unsupported
+        MO_SubIntC {}    -> unsupported
+        MO_U_Mul2 {}     -> unsupported
+        MO_WriteBarrier  -> unsupported
+        MO_Touch         -> unsupported
+        (MO_Prefetch_Data _) -> unsupported
+    where unsupported = panic ("outOfLineCmmOp: " ++ show mop
+                            ++ " not supported here")
+
diff --git a/compiler/nativeGen/SPARC/CodeGen/Amode.hs b/compiler/nativeGen/SPARC/CodeGen/Amode.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/Amode.hs
@@ -0,0 +1,74 @@
+module SPARC.CodeGen.Amode (
+        getAmode
+)
+
+where
+
+import GhcPrelude
+
+import {-# SOURCE #-} SPARC.CodeGen.Gen32
+import SPARC.CodeGen.Base
+import SPARC.AddrMode
+import SPARC.Imm
+import SPARC.Instr
+import SPARC.Regs
+import SPARC.Base
+import NCGMonad
+import Format
+
+import Cmm
+
+import OrdList
+
+
+-- | Generate code to reference a memory address.
+getAmode
+        :: CmmExpr      -- ^ expr producing an address
+        -> NatM Amode
+
+getAmode tree@(CmmRegOff _ _)
+    = do dflags <- getDynFlags
+         getAmode (mangleIndexTree dflags tree)
+
+getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)])
+  | fits13Bits (-i)
+  = do
+       (reg, code) <- getSomeReg x
+       let
+         off  = ImmInt (-(fromInteger i))
+       return (Amode (AddrRegImm reg off) code)
+
+
+getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)])
+  | fits13Bits i
+  = do
+       (reg, code) <- getSomeReg x
+       let
+         off  = ImmInt (fromInteger i)
+       return (Amode (AddrRegImm reg off) code)
+
+getAmode (CmmMachOp (MO_Add _) [x, y])
+  = do
+    (regX, codeX) <- getSomeReg x
+    (regY, codeY) <- getSomeReg y
+    let
+        code = codeX `appOL` codeY
+    return (Amode (AddrRegReg regX regY) code)
+
+getAmode (CmmLit lit)
+  = do
+        let imm__2      = litToImm lit
+        tmp1    <- getNewRegNat II32
+        tmp2    <- getNewRegNat II32
+
+        let code = toOL [ SETHI (HI imm__2) tmp1
+                        , OR    False tmp1 (RIImm (LO imm__2)) tmp2]
+
+        return (Amode (AddrRegReg tmp2 g0) code)
+
+getAmode other
+  = do
+       (reg, code) <- getSomeReg other
+       let
+            off  = ImmInt 0
+       return (Amode (AddrRegImm reg off) code)
diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs
@@ -0,0 +1,119 @@
+module SPARC.CodeGen.Base (
+        InstrBlock,
+        CondCode(..),
+        ChildCode64(..),
+        Amode(..),
+
+        Register(..),
+        setFormatOfRegister,
+
+        getRegisterReg,
+        mangleIndexTree
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.Instr
+import SPARC.Cond
+import SPARC.AddrMode
+import SPARC.Regs
+import Format
+import Reg
+
+import CodeGen.Platform
+import DynFlags
+import Cmm
+import PprCmmExpr ()
+import Platform
+
+import Outputable
+import OrdList
+
+--------------------------------------------------------------------------------
+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
+--      They are really trees of insns to facilitate fast appending, where a
+--      left-to-right traversal yields the insns in the correct order.
+--
+type InstrBlock
+        = OrdList Instr
+
+
+-- | Condition codes passed up the tree.
+--
+data CondCode
+        = CondCode Bool Cond InstrBlock
+
+
+-- | a.k.a "Register64"
+--      Reg is the lower 32-bit temporary which contains the result.
+--      Use getHiVRegFromLo to find the other VRegUnique.
+--
+--      Rules of this simplified insn selection game are therefore that
+--      the returned Reg may be modified
+--
+data ChildCode64
+   = ChildCode64
+        InstrBlock
+        Reg
+
+
+-- | Holds code that references a memory address.
+data Amode
+        = Amode
+                -- the AddrMode we can use in the instruction
+                --      that does the real load\/store.
+                AddrMode
+
+                -- other setup code we have to run first before we can use the
+                --      above AddrMode.
+                InstrBlock
+
+
+
+--------------------------------------------------------------------------------
+-- | Code to produce a result into a register.
+--      If the result must go in a specific register, it comes out as Fixed.
+--      Otherwise, the parent can decide which register to put it in.
+--
+data Register
+        = Fixed Format Reg InstrBlock
+        | Any   Format (Reg -> InstrBlock)
+
+
+-- | Change the format field in a Register.
+setFormatOfRegister
+        :: Register -> Format -> Register
+
+setFormatOfRegister reg format
+ = case reg of
+        Fixed _ reg code        -> Fixed format reg code
+        Any _ codefn            -> Any   format codefn
+
+
+--------------------------------------------------------------------------------
+-- | Grab the Reg for a CmmReg
+getRegisterReg :: Platform -> CmmReg -> Reg
+
+getRegisterReg _ (CmmLocal (LocalReg u pk))
+        = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)
+
+getRegisterReg platform (CmmGlobal mid)
+  = case globalRegMaybe platform mid of
+        Just reg -> RegReal reg
+        Nothing  -> pprPanic
+                        "SPARC.CodeGen.Base.getRegisterReg: global is in memory"
+                        (ppr $ CmmGlobal mid)
+
+
+-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
+-- CmmExprs into CmmRegOff?
+mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr
+
+mangleIndexTree dflags (CmmRegOff reg off)
+        = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
+        where width = typeWidth (cmmRegType dflags reg)
+
+mangleIndexTree _ _
+        = panic "SPARC.CodeGen.Base.mangleIndexTree: no match"
diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs
@@ -0,0 +1,110 @@
+module SPARC.CodeGen.CondCode (
+        getCondCode,
+        condIntCode,
+        condFltCode
+)
+
+where
+
+import GhcPrelude
+
+import {-# SOURCE #-} SPARC.CodeGen.Gen32
+import SPARC.CodeGen.Base
+import SPARC.Instr
+import SPARC.Regs
+import SPARC.Cond
+import SPARC.Imm
+import SPARC.Base
+import NCGMonad
+import Format
+
+import Cmm
+
+import OrdList
+import Outputable
+
+
+getCondCode :: CmmExpr -> NatM CondCode
+getCondCode (CmmMachOp mop [x, y])
+  =
+    case mop of
+      MO_F_Eq W32 -> condFltCode EQQ x y
+      MO_F_Ne W32 -> condFltCode NE  x y
+      MO_F_Gt W32 -> condFltCode GTT x y
+      MO_F_Ge W32 -> condFltCode GE  x y
+      MO_F_Lt W32 -> condFltCode LTT x y
+      MO_F_Le W32 -> condFltCode LE  x y
+
+      MO_F_Eq W64 -> condFltCode EQQ x y
+      MO_F_Ne W64 -> condFltCode NE  x y
+      MO_F_Gt W64 -> condFltCode GTT x y
+      MO_F_Ge W64 -> condFltCode GE  x y
+      MO_F_Lt W64 -> condFltCode LTT x y
+      MO_F_Le W64 -> condFltCode LE  x y
+
+      MO_Eq   _   -> condIntCode EQQ  x y
+      MO_Ne   _   -> condIntCode NE   x y
+
+      MO_S_Gt _   -> condIntCode GTT  x y
+      MO_S_Ge _   -> condIntCode GE   x y
+      MO_S_Lt _   -> condIntCode LTT  x y
+      MO_S_Le _   -> condIntCode LE   x y
+
+      MO_U_Gt _   -> condIntCode GU   x y
+      MO_U_Ge _   -> condIntCode GEU  x y
+      MO_U_Lt _   -> condIntCode LU   x y
+      MO_U_Le _   -> condIntCode LEU  x y
+
+      _           -> pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr (CmmMachOp mop [x,y]))
+
+getCondCode other = pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr other)
+
+
+
+
+
+-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
+-- passed back up the tree.
+
+condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
+condIntCode cond x (CmmLit (CmmInt y _))
+  | fits13Bits y
+  = do
+       (src1, code) <- getSomeReg x
+       let
+           src2 = ImmInt (fromInteger y)
+           code' = code `snocOL` SUB False True src1 (RIImm src2) g0
+       return (CondCode False cond code')
+
+condIntCode cond x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let
+        code__2 = code1 `appOL` code2 `snocOL`
+                  SUB False True src1 (RIReg src2) g0
+    return (CondCode False cond code__2)
+
+
+condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
+condFltCode cond x y = do
+    dflags <- getDynFlags
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    tmp <- getNewRegNat FF64
+    let
+        promote x = FxTOy FF32 FF64 x tmp
+
+        pk1   = cmmExprType dflags x
+        pk2   = cmmExprType dflags y
+
+        code__2 =
+                if pk1 `cmmEqType` pk2 then
+                    code1 `appOL` code2 `snocOL`
+                    FCMP True (cmmTypeFormat pk1) src1 src2
+                else if typeWidth pk1 == W32 then
+                    code1 `snocOL` promote src1 `appOL` code2 `snocOL`
+                    FCMP True FF64 tmp src2
+                else
+                    code1 `appOL` code2 `snocOL` promote src2 `snocOL`
+                    FCMP True FF64 src1 tmp
+    return (CondCode True cond code__2)
diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs
@@ -0,0 +1,155 @@
+-- | Expand out synthetic instructions into single machine instrs.
+module SPARC.CodeGen.Expand (
+        expandTop
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.Instr
+import SPARC.Imm
+import SPARC.AddrMode
+import SPARC.Regs
+import SPARC.Ppr        ()
+import Instruction
+import Reg
+import Format
+import Cmm
+
+
+import Outputable
+import OrdList
+
+-- | Expand out synthetic instructions in this top level thing
+expandTop :: NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr
+expandTop top@(CmmData{})
+        = top
+
+expandTop (CmmProc info lbl live (ListGraph blocks))
+        = CmmProc info lbl live (ListGraph $ map expandBlock blocks)
+
+
+-- | Expand out synthetic instructions in this block
+expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr
+
+expandBlock (BasicBlock label instrs)
+ = let  instrs_ol       = expandBlockInstrs instrs
+        instrs'         = fromOL instrs_ol
+   in   BasicBlock label instrs'
+
+
+-- | Expand out some instructions
+expandBlockInstrs :: [Instr] -> OrdList Instr
+expandBlockInstrs []    = nilOL
+
+expandBlockInstrs (ii:is)
+ = let  ii_doubleRegs   = remapRegPair ii
+        is_misaligned   = expandMisalignedDoubles ii_doubleRegs
+
+   in   is_misaligned `appOL` expandBlockInstrs is
+
+
+
+-- | In the SPARC instruction set the FP register pairs that are used
+--      to hold 64 bit floats are refered to by just the first reg
+--      of the pair. Remap our internal reg pairs to the appropriate reg.
+--
+--      For example:
+--          ldd [%l1], (%f0 | %f1)
+--
+--      gets mapped to
+--          ldd [$l1], %f0
+--
+remapRegPair :: Instr -> Instr
+remapRegPair instr
+ = let  patchF reg
+         = case reg of
+                RegReal (RealRegSingle _)
+                        -> reg
+
+                RegReal (RealRegPair r1 r2)
+
+                        -- sanity checking
+                        | r1         >= 32
+                        , r1         <= 63
+                        , r1 `mod` 2 == 0
+                        , r2         == r1 + 1
+                        -> RegReal (RealRegSingle r1)
+
+                        | otherwise
+                        -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg)
+
+                RegVirtual _
+                        -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg)
+
+   in   patchRegsOfInstr instr patchF
+
+
+
+
+-- Expand out 64 bit load/stores into individual instructions to handle
+--      possible double alignment problems.
+--
+--      TODO:   It'd be better to use a scratch reg instead of the add/sub thing.
+--              We might be able to do this faster if we use the UA2007 instr set
+--              instead of restricting ourselves to SPARC V9.
+--
+expandMisalignedDoubles :: Instr -> OrdList Instr
+expandMisalignedDoubles instr
+
+        -- Translate to:
+        --    add g1,g2,g1
+        --    ld  [g1],%fn
+        --    ld  [g1+4],%f(n+1)
+        --    sub g1,g2,g1           -- to restore g1
+        | LD FF64 (AddrRegReg r1 r2) fReg       <- instr
+        =       toOL    [ ADD False False r1 (RIReg r2) r1
+                        , LD  FF32  (AddrRegReg r1 g0)          fReg
+                        , LD  FF32  (AddrRegImm r1 (ImmInt 4))  (fRegHi fReg)
+                        , SUB False False r1 (RIReg r2) r1 ]
+
+        -- Translate to
+        --    ld  [addr],%fn
+        --    ld  [addr+4],%f(n+1)
+        | LD FF64 addr fReg                     <- instr
+        = let   Just addr'      = addrOffset addr 4
+          in    toOL    [ LD  FF32  addr        fReg
+                        , LD  FF32  addr'       (fRegHi fReg) ]
+
+        -- Translate to:
+        --    add g1,g2,g1
+        --    st  %fn,[g1]
+        --    st  %f(n+1),[g1+4]
+        --    sub g1,g2,g1           -- to restore g1
+        | ST FF64 fReg (AddrRegReg r1 r2)       <- instr
+        =       toOL    [ ADD False False r1 (RIReg r2) r1
+                        , ST  FF32  fReg           (AddrRegReg r1 g0)
+                        , ST  FF32  (fRegHi fReg)  (AddrRegImm r1 (ImmInt 4))
+                        , SUB False False r1 (RIReg r2) r1 ]
+
+        -- Translate to
+        --    ld  [addr],%fn
+        --    ld  [addr+4],%f(n+1)
+        | ST FF64 fReg addr                     <- instr
+        = let   Just addr'      = addrOffset addr 4
+          in    toOL    [ ST  FF32  fReg           addr
+                        , ST  FF32  (fRegHi fReg)  addr'         ]
+
+        -- some other instr
+        | otherwise
+        = unitOL instr
+
+
+
+-- | The high partner for this float reg.
+fRegHi :: Reg -> Reg
+fRegHi (RegReal (RealRegSingle r1))
+        | r1            >= 32
+        , r1            <= 63
+        , r1 `mod` 2 == 0
+        = (RegReal $ RealRegSingle (r1 + 1))
+
+-- Can't take high partner for non-low reg.
+fRegHi reg
+        = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg)
diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs
@@ -0,0 +1,692 @@
+-- | Evaluation of 32 bit values.
+module SPARC.CodeGen.Gen32 (
+        getSomeReg,
+        getRegister
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.CodeGen.CondCode
+import SPARC.CodeGen.Amode
+import SPARC.CodeGen.Gen64
+import SPARC.CodeGen.Base
+import SPARC.Stack
+import SPARC.Instr
+import SPARC.Cond
+import SPARC.AddrMode
+import SPARC.Imm
+import SPARC.Regs
+import SPARC.Base
+import NCGMonad
+import Format
+import Reg
+
+import Cmm
+
+import Control.Monad (liftM)
+import DynFlags
+import OrdList
+import Outputable
+
+-- | The dual to getAnyReg: compute an expression into a register, but
+--      we don't mind which one it is.
+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
+getSomeReg expr = do
+  r <- getRegister expr
+  case r of
+    Any rep code -> do
+        tmp <- getNewRegNat rep
+        return (tmp, code tmp)
+    Fixed _ reg code ->
+        return (reg, code)
+
+
+
+-- | Make code to evaluate a 32 bit expression.
+--
+getRegister :: CmmExpr -> NatM Register
+
+getRegister (CmmReg reg)
+  = do dflags <- getDynFlags
+       let platform = targetPlatform dflags
+       return (Fixed (cmmTypeFormat (cmmRegType dflags reg))
+                     (getRegisterReg platform reg) nilOL)
+
+getRegister tree@(CmmRegOff _ _)
+  = do dflags <- getDynFlags
+       getRegister (mangleIndexTree dflags tree)
+
+getRegister (CmmMachOp (MO_UU_Conv W64 W32)
+             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister (CmmMachOp (MO_SS_Conv W64 W32)
+             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code
+
+getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code
+
+
+-- Load a literal float into a float register.
+--      The actual literal is stored in a new data area, and we load it
+--      at runtime.
+getRegister (CmmLit (CmmFloat f W32)) = do
+
+    -- a label for the new data area
+    lbl <- getNewLabelNat
+    tmp <- getNewRegNat II32
+
+    let code dst = toOL [
+            -- the data area
+            LDATA (Section ReadOnlyData lbl) $ Statics lbl
+                         [CmmStaticLit (CmmFloat f W32)],
+
+            -- load the literal
+            SETHI (HI (ImmCLbl lbl)) tmp,
+            LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
+
+    return (Any FF32 code)
+
+getRegister (CmmLit (CmmFloat d W64)) = do
+    lbl <- getNewLabelNat
+    tmp <- getNewRegNat II32
+    let code dst = toOL [
+            LDATA (Section ReadOnlyData lbl) $ Statics lbl
+                         [CmmStaticLit (CmmFloat d W64)],
+            SETHI (HI (ImmCLbl lbl)) tmp,
+            LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]
+    return (Any FF64 code)
+
+
+-- Unary machine ops
+getRegister (CmmMachOp mop [x])
+  = case mop of
+        -- Floating point negation -------------------------
+        MO_F_Neg W32            -> trivialUFCode FF32 (FNEG FF32) x
+        MO_F_Neg W64            -> trivialUFCode FF64 (FNEG FF64) x
+
+
+        -- Integer negation --------------------------------
+        MO_S_Neg rep            -> trivialUCode (intFormat rep) (SUB False False g0) x
+        MO_Not rep              -> trivialUCode (intFormat rep) (XNOR False g0) x
+
+
+        -- Float word size conversion ----------------------
+        MO_FF_Conv W64 W32      -> coerceDbl2Flt x
+        MO_FF_Conv W32 W64      -> coerceFlt2Dbl x
+
+
+        -- Float <-> Signed Int conversion -----------------
+        MO_FS_Conv from to      -> coerceFP2Int from to x
+        MO_SF_Conv from to      -> coerceInt2FP from to x
+
+
+        -- Unsigned integer word size conversions ----------
+
+        -- If it's the same size, then nothing needs to be done.
+        MO_UU_Conv from to
+         | from == to           -> conversionNop (intFormat to)  x
+
+        -- To narrow an unsigned word, mask out the high bits to simulate what would
+        --      happen if we copied the value into a smaller register.
+        MO_UU_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))
+        MO_UU_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))
+
+        -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8
+        --      case because the only way we can load it is via SETHI, which needs 2 ops.
+        --      Do some shifts to chop out the high bits instead.
+        MO_UU_Conv W32 W16
+         -> do  tmpReg          <- getNewRegNat II32
+                (xReg, xCode)   <- getSomeReg x
+                let code dst
+                        =       xCode
+                        `appOL` toOL
+                                [ SLL xReg   (RIImm $ ImmInt 16) tmpReg
+                                , SRL tmpReg (RIImm $ ImmInt 16) dst]
+
+                return  $ Any II32 code
+
+                --       trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))
+
+        -- To widen an unsigned word we don't have to do anything.
+        --      Just leave it in the same register and mark the result as the new size.
+        MO_UU_Conv W8  W16      -> conversionNop (intFormat W16)  x
+        MO_UU_Conv W8  W32      -> conversionNop (intFormat W32)  x
+        MO_UU_Conv W16 W32      -> conversionNop (intFormat W32)  x
+
+
+        -- Signed integer word size conversions ------------
+
+        -- Mask out high bits when narrowing them
+        MO_SS_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))
+        MO_SS_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))
+        MO_SS_Conv W32 W16      -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))
+
+        -- Sign extend signed words when widening them.
+        MO_SS_Conv W8  W16      -> integerExtend W8  W16 x
+        MO_SS_Conv W8  W32      -> integerExtend W8  W32 x
+        MO_SS_Conv W16 W32      -> integerExtend W16 W32 x
+
+        _                       -> panic ("Unknown unary mach op: " ++ show mop)
+
+
+-- Binary machine ops
+getRegister (CmmMachOp mop [x, y])
+  = case mop of
+      MO_Eq _           -> condIntReg EQQ x y
+      MO_Ne _           -> condIntReg NE x y
+
+      MO_S_Gt _         -> condIntReg GTT x y
+      MO_S_Ge _         -> condIntReg GE x y
+      MO_S_Lt _         -> condIntReg LTT x y
+      MO_S_Le _         -> condIntReg LE x y
+
+      MO_U_Gt W32       -> condIntReg GU  x y
+      MO_U_Ge W32       -> condIntReg GEU x y
+      MO_U_Lt W32       -> condIntReg LU  x y
+      MO_U_Le W32       -> condIntReg LEU x y
+
+      MO_U_Gt W16       -> condIntReg GU  x y
+      MO_U_Ge W16       -> condIntReg GEU x y
+      MO_U_Lt W16       -> condIntReg LU  x y
+      MO_U_Le W16       -> condIntReg LEU x y
+
+      MO_Add W32        -> trivialCode W32 (ADD False False) x y
+      MO_Sub W32        -> trivialCode W32 (SUB False False) x y
+
+      MO_S_MulMayOflo rep -> imulMayOflo rep x y
+
+      MO_S_Quot W32     -> idiv True  False x y
+      MO_U_Quot W32     -> idiv False False x y
+
+      MO_S_Rem  W32     -> irem True  x y
+      MO_U_Rem  W32     -> irem False x y
+
+      MO_F_Eq _         -> condFltReg EQQ x y
+      MO_F_Ne _         -> condFltReg NE x y
+
+      MO_F_Gt _         -> condFltReg GTT x y
+      MO_F_Ge _         -> condFltReg GE x y
+      MO_F_Lt _         -> condFltReg LTT x y
+      MO_F_Le _         -> condFltReg LE x y
+
+      MO_F_Add  w       -> trivialFCode w FADD x y
+      MO_F_Sub  w       -> trivialFCode w FSUB x y
+      MO_F_Mul  w       -> trivialFCode w FMUL x y
+      MO_F_Quot w       -> trivialFCode w FDIV x y
+
+      MO_And rep        -> trivialCode rep (AND False) x y
+      MO_Or  rep        -> trivialCode rep (OR  False) x y
+      MO_Xor rep        -> trivialCode rep (XOR False) x y
+
+      MO_Mul rep        -> trivialCode rep (SMUL False) x y
+
+      MO_Shl rep        -> trivialCode rep SLL  x y
+      MO_U_Shr rep      -> trivialCode rep SRL x y
+      MO_S_Shr rep      -> trivialCode rep SRA x y
+
+      _                 -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop)
+
+getRegister (CmmLoad mem pk) = do
+    Amode src code <- getAmode mem
+    let
+        code__2 dst     = code `snocOL` LD (cmmTypeFormat pk) src dst
+    return (Any (cmmTypeFormat pk) code__2)
+
+getRegister (CmmLit (CmmInt i _))
+  | fits13Bits i
+  = let
+        src = ImmInt (fromInteger i)
+        code dst = unitOL (OR False g0 (RIImm src) dst)
+    in
+        return (Any II32 code)
+
+getRegister (CmmLit lit)
+  = let imm = litToImm lit
+        code dst = toOL [
+            SETHI (HI imm) dst,
+            OR False dst (RIImm (LO imm)) dst]
+    in return (Any II32 code)
+
+
+getRegister _
+        = panic "SPARC.CodeGen.Gen32.getRegister: no match"
+
+
+-- | sign extend and widen
+integerExtend
+        :: Width                -- ^ width of source expression
+        -> Width                -- ^ width of result
+        -> CmmExpr              -- ^ source expression
+        -> NatM Register
+
+integerExtend from to expr
+ = do   -- load the expr into some register
+        (reg, e_code)   <- getSomeReg expr
+        tmp             <- getNewRegNat II32
+        let bitCount
+                = case (from, to) of
+                        (W8,  W32)      -> 24
+                        (W16, W32)      -> 16
+                        (W8,  W16)      -> 24
+                        _               -> panic "SPARC.CodeGen.Gen32: no match"
+        let code dst
+                = e_code
+
+                -- local shift word left to load the sign bit
+                `snocOL`  SLL reg (RIImm (ImmInt bitCount)) tmp
+
+                -- arithmetic shift right to sign extend
+                `snocOL`  SRA tmp (RIImm (ImmInt bitCount)) dst
+
+        return (Any (intFormat to) code)
+
+
+-- | For nop word format conversions we set the resulting value to have the
+--      required size, but don't need to generate any actual code.
+--
+conversionNop
+        :: Format -> CmmExpr -> NatM Register
+
+conversionNop new_rep expr
+ = do   e_code <- getRegister expr
+        return (setFormatOfRegister e_code new_rep)
+
+
+
+-- | Generate an integer division instruction.
+idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register
+
+-- For unsigned division with a 32 bit numerator,
+--              we can just clear the Y register.
+idiv False cc x y
+ = do
+        (a_reg, a_code)         <- getSomeReg x
+        (b_reg, b_code)         <- getSomeReg y
+
+        let code dst
+                =       a_code
+                `appOL` b_code
+                `appOL` toOL
+                        [ WRY  g0 g0
+                        , UDIV cc a_reg (RIReg b_reg) dst]
+
+        return (Any II32 code)
+
+
+-- For _signed_ division with a 32 bit numerator,
+--              we have to sign extend the numerator into the Y register.
+idiv True cc x y
+ = do
+        (a_reg, a_code)         <- getSomeReg x
+        (b_reg, b_code)         <- getSomeReg y
+
+        tmp                     <- getNewRegNat II32
+
+        let code dst
+                =       a_code
+                `appOL` b_code
+                `appOL` toOL
+                        [ SRA  a_reg (RIImm (ImmInt 16)) tmp            -- sign extend
+                        , SRA  tmp   (RIImm (ImmInt 16)) tmp
+
+                        , WRY  tmp g0
+                        , SDIV cc a_reg (RIReg b_reg) dst]
+
+        return (Any II32 code)
+
+
+-- | Do an integer remainder.
+--
+--       NOTE:  The SPARC v8 architecture manual says that integer division
+--              instructions _may_ generate a remainder, depending on the implementation.
+--              If so it is _recommended_ that the remainder is placed in the Y register.
+--
+--          The UltraSparc 2007 manual says Y is _undefined_ after division.
+--
+--              The SPARC T2 doesn't store the remainder, not sure about the others.
+--              It's probably best not to worry about it, and just generate our own
+--              remainders.
+--
+irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register
+
+-- For unsigned operands:
+--              Division is between a 64 bit numerator and a 32 bit denominator,
+--              so we still have to clear the Y register.
+irem False x y
+ = do
+        (a_reg, a_code) <- getSomeReg x
+        (b_reg, b_code) <- getSomeReg y
+
+        tmp_reg         <- getNewRegNat II32
+
+        let code dst
+                =       a_code
+                `appOL` b_code
+                `appOL` toOL
+                        [ WRY   g0 g0
+                        , UDIV  False         a_reg (RIReg b_reg) tmp_reg
+                        , UMUL  False       tmp_reg (RIReg b_reg) tmp_reg
+                        , SUB   False False   a_reg (RIReg tmp_reg) dst]
+
+        return  (Any II32 code)
+
+
+
+-- For signed operands:
+--              Make sure to sign extend into the Y register, or the remainder
+--              will have the wrong sign when the numerator is negative.
+--
+--      TODO:   When sign extending, GCC only shifts the a_reg right by 17 bits,
+--              not the full 32. Not sure why this is, something to do with overflow?
+--              If anyone cares enough about the speed of signed remainder they
+--              can work it out themselves (then tell me). -- BL 2009/01/20
+irem True x y
+ = do
+        (a_reg, a_code) <- getSomeReg x
+        (b_reg, b_code) <- getSomeReg y
+
+        tmp1_reg        <- getNewRegNat II32
+        tmp2_reg        <- getNewRegNat II32
+
+        let code dst
+                =       a_code
+                `appOL` b_code
+                `appOL` toOL
+                        [ SRA   a_reg      (RIImm (ImmInt 16)) tmp1_reg -- sign extend
+                        , SRA   tmp1_reg   (RIImm (ImmInt 16)) tmp1_reg -- sign extend
+                        , WRY   tmp1_reg g0
+
+                        , SDIV  False          a_reg (RIReg b_reg)    tmp2_reg
+                        , SMUL  False       tmp2_reg (RIReg b_reg)    tmp2_reg
+                        , SUB   False False    a_reg (RIReg tmp2_reg) dst]
+
+        return (Any II32 code)
+
+
+imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
+imulMayOflo rep a b
+ = do
+        (a_reg, a_code) <- getSomeReg a
+        (b_reg, b_code) <- getSomeReg b
+        res_lo <- getNewRegNat II32
+        res_hi <- getNewRegNat II32
+
+        let shift_amt  = case rep of
+                          W32 -> 31
+                          W64 -> 63
+                          _ -> panic "shift_amt"
+
+        let code dst = a_code `appOL` b_code `appOL`
+                       toOL [
+                           SMUL False a_reg (RIReg b_reg) res_lo,
+                           RDY res_hi,
+                           SRA res_lo (RIImm (ImmInt shift_amt)) res_lo,
+                           SUB False False res_lo (RIReg res_hi) dst
+                        ]
+        return (Any II32 code)
+
+
+-- -----------------------------------------------------------------------------
+-- 'trivial*Code': deal with trivial instructions
+
+-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
+-- Only look for constants on the right hand side, because that's
+-- where the generic optimizer will have put them.
+
+-- Similarly, for unary instructions, we don't have to worry about
+-- matching an StInt as the argument, because genericOpt will already
+-- have handled the constant-folding.
+
+trivialCode
+        :: Width
+        -> (Reg -> RI -> Reg -> Instr)
+        -> CmmExpr
+        -> CmmExpr
+        -> NatM Register
+
+trivialCode _ instr x (CmmLit (CmmInt y _))
+  | fits13Bits y
+  = do
+      (src1, code) <- getSomeReg x
+      let
+        src2 = ImmInt (fromInteger y)
+        code__2 dst = code `snocOL` instr src1 (RIImm src2) dst
+      return (Any II32 code__2)
+
+
+trivialCode _ instr x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let
+        code__2 dst = code1 `appOL` code2 `snocOL`
+                      instr src1 (RIReg src2) dst
+    return (Any II32 code__2)
+
+
+trivialFCode
+        :: Width
+        -> (Format -> Reg -> Reg -> Reg -> Instr)
+        -> CmmExpr
+        -> CmmExpr
+        -> NatM Register
+
+trivialFCode pk instr x y = do
+    dflags <- getDynFlags
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    tmp <- getNewRegNat FF64
+    let
+        promote x = FxTOy FF32 FF64 x tmp
+
+        pk1   = cmmExprType dflags x
+        pk2   = cmmExprType dflags y
+
+        code__2 dst =
+                if pk1 `cmmEqType` pk2 then
+                    code1 `appOL` code2 `snocOL`
+                    instr (floatFormat pk) src1 src2 dst
+                else if typeWidth pk1 == W32 then
+                    code1 `snocOL` promote src1 `appOL` code2 `snocOL`
+                    instr FF64 tmp src2 dst
+                else
+                    code1 `appOL` code2 `snocOL` promote src2 `snocOL`
+                    instr FF64 src1 tmp dst
+    return (Any (cmmTypeFormat $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64)
+                code__2)
+
+
+
+trivialUCode
+        :: Format
+        -> (RI -> Reg -> Instr)
+        -> CmmExpr
+        -> NatM Register
+
+trivialUCode format instr x = do
+    (src, code) <- getSomeReg x
+    let
+        code__2 dst = code `snocOL` instr (RIReg src) dst
+    return (Any format code__2)
+
+
+trivialUFCode
+        :: Format
+        -> (Reg -> Reg -> Instr)
+        -> CmmExpr
+        -> NatM Register
+
+trivialUFCode pk instr x = do
+    (src, code) <- getSomeReg x
+    let
+        code__2 dst = code `snocOL` instr src dst
+    return (Any pk code__2)
+
+
+
+
+-- Coercions -------------------------------------------------------------------
+
+-- | Coerce a integer value to floating point
+coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
+coerceInt2FP width1 width2 x = do
+    (src, code) <- getSomeReg x
+    let
+        code__2 dst = code `appOL` toOL [
+            ST (intFormat width1) src (spRel (-2)),
+            LD (intFormat width1) (spRel (-2)) dst,
+            FxTOy (intFormat width1) (floatFormat width2) dst dst]
+    return (Any (floatFormat $ width2) code__2)
+
+
+
+-- | Coerce a floating point value to integer
+--
+--   NOTE: On sparc v9 there are no instructions to move a value from an
+--         FP register directly to an int register, so we have to use a load/store.
+--
+coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
+coerceFP2Int width1 width2 x
+ = do   let fformat1      = floatFormat width1
+            fformat2      = floatFormat width2
+
+            iformat2      = intFormat   width2
+
+        (fsrc, code)    <- getSomeReg x
+        fdst            <- getNewRegNat fformat2
+
+        let code2 dst
+                =       code
+                `appOL` toOL
+                        -- convert float to int format, leaving it in a float reg.
+                        [ FxTOy fformat1 iformat2 fsrc fdst
+
+                        -- store the int into mem, then load it back to move
+                        --      it into an actual int reg.
+                        , ST    fformat2 fdst (spRel (-2))
+                        , LD    iformat2 (spRel (-2)) dst]
+
+        return (Any iformat2 code2)
+
+
+-- | Coerce a double precision floating point value to single precision.
+coerceDbl2Flt :: CmmExpr -> NatM Register
+coerceDbl2Flt x = do
+    (src, code) <- getSomeReg x
+    return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst))
+
+
+-- | Coerce a single precision floating point value to double precision
+coerceFlt2Dbl :: CmmExpr -> NatM Register
+coerceFlt2Dbl x = do
+    (src, code) <- getSomeReg x
+    return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst))
+
+
+
+
+-- Condition Codes -------------------------------------------------------------
+--
+-- Evaluate a comparison, and get the result into a register.
+--
+-- Do not fill the delay slots here. you will confuse the register allocator.
+--
+condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
+condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do
+    (src, code) <- getSomeReg x
+    let
+        code__2 dst = code `appOL` toOL [
+            SUB False True g0 (RIReg src) g0,
+            SUB True False g0 (RIImm (ImmInt (-1))) dst]
+    return (Any II32 code__2)
+
+condIntReg EQQ x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let
+        code__2 dst = code1 `appOL` code2 `appOL` toOL [
+            XOR False src1 (RIReg src2) dst,
+            SUB False True g0 (RIReg dst) g0,
+            SUB True False g0 (RIImm (ImmInt (-1))) dst]
+    return (Any II32 code__2)
+
+condIntReg NE x (CmmLit (CmmInt 0 _)) = do
+    (src, code) <- getSomeReg x
+    let
+        code__2 dst = code `appOL` toOL [
+            SUB False True g0 (RIReg src) g0,
+            ADD True False g0 (RIImm (ImmInt 0)) dst]
+    return (Any II32 code__2)
+
+condIntReg NE x y = do
+    (src1, code1) <- getSomeReg x
+    (src2, code2) <- getSomeReg y
+    let
+        code__2 dst = code1 `appOL` code2 `appOL` toOL [
+            XOR False src1 (RIReg src2) dst,
+            SUB False True g0 (RIReg dst) g0,
+            ADD True False g0 (RIImm (ImmInt 0)) dst]
+    return (Any II32 code__2)
+
+condIntReg cond x y = do
+    bid1 <- liftM (\a -> seq a a) getBlockIdNat
+    bid2 <- liftM (\a -> seq a a) getBlockIdNat
+    CondCode _ cond cond_code <- condIntCode cond x y
+    let
+        code__2 dst
+         =      cond_code
+          `appOL` toOL
+                [ BI cond False bid1
+                , NOP
+
+                , OR False g0 (RIImm (ImmInt 0)) dst
+                , BI ALWAYS False bid2
+                , NOP
+
+                , NEWBLOCK bid1
+                , OR False g0 (RIImm (ImmInt 1)) dst
+                , BI ALWAYS False bid2
+                , NOP
+
+                , NEWBLOCK bid2]
+
+    return (Any II32 code__2)
+
+
+condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
+condFltReg cond x y = do
+    bid1 <- liftM (\a -> seq a a) getBlockIdNat
+    bid2 <- liftM (\a -> seq a a) getBlockIdNat
+
+    CondCode _ cond cond_code <- condFltCode cond x y
+    let
+        code__2 dst
+         =      cond_code
+          `appOL` toOL
+                [ NOP
+                , BF cond False bid1
+                , NOP
+
+                , OR False g0 (RIImm (ImmInt 0)) dst
+                , BI ALWAYS False bid2
+                , NOP
+
+                , NEWBLOCK bid1
+                , OR False g0 (RIImm (ImmInt 1)) dst
+                , BI ALWAYS False bid2
+                , NOP
+
+                , NEWBLOCK bid2 ]
+
+    return (Any II32 code__2)
diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot
@@ -0,0 +1,16 @@
+
+module SPARC.CodeGen.Gen32 (
+        getSomeReg,
+        getRegister
+)
+
+where
+
+import SPARC.CodeGen.Base
+import NCGMonad
+import Reg
+
+import Cmm
+
+getSomeReg  :: CmmExpr -> NatM (Reg, InstrBlock)
+getRegister :: CmmExpr -> NatM Register
diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs
@@ -0,0 +1,216 @@
+-- | Evaluation of 64 bit values on 32 bit platforms.
+module SPARC.CodeGen.Gen64 (
+        assignMem_I64Code,
+        assignReg_I64Code,
+        iselExpr64
+)
+
+where
+
+import GhcPrelude
+
+import {-# SOURCE #-} SPARC.CodeGen.Gen32
+import SPARC.CodeGen.Base
+import SPARC.CodeGen.Amode
+import SPARC.Regs
+import SPARC.AddrMode
+import SPARC.Imm
+import SPARC.Instr
+import SPARC.Ppr()
+import NCGMonad
+import Instruction
+import Format
+import Reg
+
+import Cmm
+
+import DynFlags
+import OrdList
+import Outputable
+
+-- | Code to assign a 64 bit value to memory.
+assignMem_I64Code
+        :: CmmExpr              -- ^ expr producing the destination address
+        -> CmmExpr              -- ^ expr producing the source value.
+        -> NatM InstrBlock
+
+assignMem_I64Code addrTree valueTree
+ = do
+     ChildCode64 vcode rlo      <- iselExpr64 valueTree
+
+     (src, acode) <- getSomeReg addrTree
+     let
+         rhi = getHiVRegFromLo rlo
+
+         -- Big-endian store
+         mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0))
+         mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4))
+
+         code   = vcode `appOL` acode `snocOL` mov_hi `snocOL` mov_lo
+
+{-     pprTrace "assignMem_I64Code"
+        (vcat   [ text "addrTree:  " <+> ppr addrTree
+                , text "valueTree: " <+> ppr valueTree
+                , text "vcode:"
+                , vcat $ map ppr $ fromOL vcode
+                , text ""
+                , text "acode:"
+                , vcat $ map ppr $ fromOL acode ])
+       $ -}
+     return code
+
+
+-- | Code to assign a 64 bit value to a register.
+assignReg_I64Code
+        :: CmmReg               -- ^ the destination register
+        -> CmmExpr              -- ^ expr producing the source value
+        -> NatM InstrBlock
+
+assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree
+ = do
+     ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
+     let
+         r_dst_lo = RegVirtual $ mkVirtualReg u_dst (cmmTypeFormat pk)
+         r_dst_hi = getHiVRegFromLo r_dst_lo
+         r_src_hi = getHiVRegFromLo r_src_lo
+         mov_lo = mkMOV r_src_lo r_dst_lo
+         mov_hi = mkMOV r_src_hi r_dst_hi
+         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
+
+     return (vcode `snocOL` mov_hi `snocOL` mov_lo)
+
+assignReg_I64Code _ _
+   = panic "assignReg_I64Code(sparc): invalid lvalue"
+
+
+
+
+-- | Get the value of an expression into a 64 bit register.
+
+iselExpr64 :: CmmExpr -> NatM ChildCode64
+
+-- Load a 64 bit word
+iselExpr64 (CmmLoad addrTree ty)
+ | isWord64 ty
+ = do   Amode amode addr_code   <- getAmode addrTree
+        let result
+
+                | AddrRegReg r1 r2      <- amode
+                = do    rlo     <- getNewRegNat II32
+                        tmp     <- getNewRegNat II32
+                        let rhi = getHiVRegFromLo rlo
+
+                        return  $ ChildCode64
+                                (        addr_code
+                                `appOL`  toOL
+                                         [ ADD False False r1 (RIReg r2) tmp
+                                         , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi
+                                         , LD II32 (AddrRegImm tmp (ImmInt 4)) rlo ])
+                                rlo
+
+                | AddrRegImm r1 (ImmInt i) <- amode
+                = do    rlo     <- getNewRegNat II32
+                        let rhi = getHiVRegFromLo rlo
+
+                        return  $ ChildCode64
+                                (        addr_code
+                                `appOL`  toOL
+                                         [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi
+                                         , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ])
+                                rlo
+
+                | otherwise
+                = panic "SPARC.CodeGen.Gen64: no match"
+
+        result
+
+
+-- Add a literal to a 64 bit integer
+iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)])
+ = do   ChildCode64 code1 r1_lo <- iselExpr64 e1
+        let r1_hi       = getHiVRegFromLo r1_lo
+
+        r_dst_lo        <- getNewRegNat II32
+        let r_dst_hi    =  getHiVRegFromLo r_dst_lo
+
+        let code =      code1
+                `appOL` toOL
+                        [ ADD False True  r1_lo (RIImm (ImmInteger i)) r_dst_lo
+                        , ADD True  False r1_hi (RIReg g0)         r_dst_hi ]
+
+        return  $ ChildCode64 code r_dst_lo
+
+
+-- Addition of II64
+iselExpr64 (CmmMachOp (MO_Add _) [e1, e2])
+ = do   ChildCode64 code1 r1_lo <- iselExpr64 e1
+        let r1_hi       = getHiVRegFromLo r1_lo
+
+        ChildCode64 code2 r2_lo <- iselExpr64 e2
+        let r2_hi       = getHiVRegFromLo r2_lo
+
+        r_dst_lo        <- getNewRegNat II32
+        let r_dst_hi    = getHiVRegFromLo r_dst_lo
+
+        let code =      code1
+                `appOL` code2
+                `appOL` toOL
+                        [ ADD False True  r1_lo (RIReg r2_lo) r_dst_lo
+                        , ADD True  False r1_hi (RIReg r2_hi) r_dst_hi ]
+
+        return  $ ChildCode64 code r_dst_lo
+
+
+iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty)))
+ | isWord64 ty
+ = do
+     r_dst_lo <-  getNewRegNat II32
+     let r_dst_hi = getHiVRegFromLo r_dst_lo
+         r_src_lo = RegVirtual $ mkVirtualReg uq II32
+         r_src_hi = getHiVRegFromLo r_src_lo
+         mov_lo = mkMOV r_src_lo r_dst_lo
+         mov_hi = mkMOV r_src_hi r_dst_hi
+         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg
+     return (
+            ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo
+         )
+
+-- Convert something into II64
+iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr])
+ = do
+        r_dst_lo        <- getNewRegNat II32
+        let r_dst_hi    = getHiVRegFromLo r_dst_lo
+
+        -- compute expr and load it into r_dst_lo
+        (a_reg, a_code) <- getSomeReg expr
+
+        dflags <- getDynFlags
+        let platform = targetPlatform dflags
+            code        = a_code
+                `appOL` toOL
+                        [ mkRegRegMoveInstr platform g0    r_dst_hi     -- clear high 32 bits
+                        , mkRegRegMoveInstr platform a_reg r_dst_lo ]
+
+        return  $ ChildCode64 code r_dst_lo
+
+-- only W32 supported for now
+iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr])
+ = do
+        r_dst_lo        <- getNewRegNat II32
+        let r_dst_hi    = getHiVRegFromLo r_dst_lo
+
+        -- compute expr and load it into r_dst_lo
+        (a_reg, a_code) <- getSomeReg expr
+
+        dflags          <- getDynFlags
+        let platform    = targetPlatform dflags
+            code        = a_code
+                `appOL` toOL
+                        [ SRA a_reg (RIImm (ImmInt 31)) r_dst_hi
+                        , mkRegRegMoveInstr platform a_reg r_dst_lo ]
+
+        return  $ ChildCode64 code r_dst_lo
+
+
+iselExpr64 expr
+   = pprPanic "iselExpr64(sparc)" (ppr expr)
diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
@@ -0,0 +1,69 @@
+-- | One ounce of sanity checking is worth 10000000000000000 ounces
+-- of staring blindly at assembly code trying to find the problem..
+module SPARC.CodeGen.Sanity (
+        checkBlock
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.Instr
+import SPARC.Ppr        ()
+import Instruction
+
+import Cmm
+
+import Outputable
+
+
+-- | Enforce intra-block invariants.
+--
+checkBlock :: CmmBlock
+           -> NatBasicBlock Instr
+           -> NatBasicBlock Instr
+
+checkBlock cmm block@(BasicBlock _ instrs)
+        | checkBlockInstrs instrs
+        = block
+
+        | otherwise
+        = pprPanic
+                ("SPARC.CodeGen: bad block\n")
+                ( vcat  [ text " -- cmm -----------------\n"
+                        , ppr cmm
+                        , text " -- native code ---------\n"
+                        , ppr block ])
+
+
+checkBlockInstrs :: [Instr] -> Bool
+checkBlockInstrs ii
+
+        -- An unconditional jumps end the block.
+        --      There must be an unconditional jump in the block, otherwise
+        --      the register liveness determinator will get the liveness
+        --      information wrong.
+        --
+        --      If the block ends with a cmm call that never returns
+        --      then there can be unreachable instructions after the jump,
+        --      but we don't mind here.
+        --
+        | instr : NOP : _       <- ii
+        , isUnconditionalJump instr
+        = True
+
+        -- All jumps must have a NOP in their branch delay slot.
+        --      The liveness determinator and register allocators aren't smart
+        --      enough to handle branch delay slots.
+        --
+        | instr : NOP : is      <- ii
+        , isJumpishInstr instr
+        = checkBlockInstrs is
+
+        -- keep checking
+        | _:i2:is               <- ii
+        = checkBlockInstrs (i2:is)
+
+        -- this block is no good
+        | otherwise
+        = False
diff --git a/compiler/nativeGen/SPARC/Cond.hs b/compiler/nativeGen/SPARC/Cond.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/Cond.hs
@@ -0,0 +1,54 @@
+module SPARC.Cond (
+        Cond(..),
+        condUnsigned,
+        condToSigned,
+        condToUnsigned
+)
+
+where
+
+import GhcPrelude
+
+-- | Branch condition codes.
+data Cond
+        = ALWAYS
+        | EQQ
+        | GE
+        | GEU
+        | GTT
+        | GU
+        | LE
+        | LEU
+        | LTT
+        | LU
+        | NE
+        | NEG
+        | NEVER
+        | POS
+        | VC
+        | VS
+        deriving Eq
+
+
+condUnsigned :: Cond -> Bool
+condUnsigned GU  = True
+condUnsigned LU  = True
+condUnsigned GEU = True
+condUnsigned LEU = True
+condUnsigned _   = False
+
+
+condToSigned :: Cond -> Cond
+condToSigned GU  = GTT
+condToSigned LU  = LTT
+condToSigned GEU = GE
+condToSigned LEU = LE
+condToSigned x   = x
+
+
+condToUnsigned :: Cond -> Cond
+condToUnsigned GTT = GU
+condToUnsigned LTT = LU
+condToUnsigned GE  = GEU
+condToUnsigned LE  = LEU
+condToUnsigned x   = x
diff --git a/compiler/nativeGen/SPARC/Imm.hs b/compiler/nativeGen/SPARC/Imm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/Imm.hs
@@ -0,0 +1,67 @@
+module SPARC.Imm (
+        -- immediate values
+        Imm(..),
+        strImmLit,
+        litToImm
+)
+
+where
+
+import GhcPrelude
+
+import Cmm
+import CLabel
+
+import Outputable
+
+-- | An immediate value.
+--      Not all of these are directly representable by the machine.
+--      Things like ImmLit are slurped out and put in a data segment instead.
+--
+data Imm
+        = ImmInt        Int
+
+        -- Sigh.
+        | ImmInteger    Integer
+
+        -- AbstractC Label (with baggage)
+        | ImmCLbl       CLabel
+
+        -- Simple string
+        | ImmLit        SDoc
+        | ImmIndex      CLabel Int
+        | ImmFloat      Rational
+        | ImmDouble     Rational
+
+        | ImmConstantSum  Imm Imm
+        | ImmConstantDiff Imm Imm
+
+        | LO    Imm
+        | HI    Imm
+
+
+-- | Create a ImmLit containing this string.
+strImmLit :: String -> Imm
+strImmLit s = ImmLit (text s)
+
+
+-- | Convert a CmmLit to an Imm.
+--      Narrow to the width: a CmmInt might be out of
+--      range, but we assume that ImmInteger only contains
+--      in-range values.  A signed value should be fine here.
+--
+litToImm :: CmmLit -> Imm
+litToImm lit
+ = case lit of
+        CmmInt i w              -> ImmInteger (narrowS w i)
+        CmmFloat f W32          -> ImmFloat f
+        CmmFloat f W64          -> ImmDouble f
+        CmmLabel l              -> ImmCLbl l
+        CmmLabelOff l off       -> ImmIndex l off
+
+        CmmLabelDiffOff l1 l2 off _
+         -> ImmConstantSum
+                (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
+                (ImmInt off)
+
+        _               -> panic "SPARC.Regs.litToImm: no match"
diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/Instr.hs
@@ -0,0 +1,485 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Machine-dependent assembly language
+--
+-- (c) The University of Glasgow 1993-2004
+--
+-----------------------------------------------------------------------------
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+module SPARC.Instr (
+        RI(..),
+        riZero,
+
+        fpRelEA,
+        moveSp,
+
+        isUnconditionalJump,
+
+        Instr(..),
+        maxSpillSlots
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.Stack
+import SPARC.Imm
+import SPARC.AddrMode
+import SPARC.Cond
+import SPARC.Regs
+import SPARC.Base
+import TargetReg
+import Instruction
+import RegClass
+import Reg
+import Format
+
+import CLabel
+import CodeGen.Platform
+import BlockId
+import DynFlags
+import Cmm
+import FastString
+import Outputable
+import Platform
+
+
+-- | Register or immediate
+data RI
+        = RIReg Reg
+        | RIImm Imm
+
+-- | Check if a RI represents a zero value.
+--      - a literal zero
+--      - register %g0, which is always zero.
+--
+riZero :: RI -> Bool
+riZero (RIImm (ImmInt 0))                       = True
+riZero (RIImm (ImmInteger 0))                   = True
+riZero (RIReg (RegReal (RealRegSingle 0)))      = True
+riZero _                                        = False
+
+
+-- | Calculate the effective address which would be used by the
+--      corresponding fpRel sequence.
+fpRelEA :: Int -> Reg -> Instr
+fpRelEA n dst
+   = ADD False False fp (RIImm (ImmInt (n * wordLength))) dst
+
+
+-- | Code to shift the stack pointer by n words.
+moveSp :: Int -> Instr
+moveSp n
+   = ADD False False sp (RIImm (ImmInt (n * wordLength))) sp
+
+-- | An instruction that will cause the one after it never to be exectuted
+isUnconditionalJump :: Instr -> Bool
+isUnconditionalJump ii
+ = case ii of
+        CALL{}          -> True
+        JMP{}           -> True
+        JMP_TBL{}       -> True
+        BI ALWAYS _ _   -> True
+        BF ALWAYS _ _   -> True
+        _               -> False
+
+
+-- | instance for sparc instruction set
+instance Instruction Instr where
+        regUsageOfInstr         = sparc_regUsageOfInstr
+        patchRegsOfInstr        = sparc_patchRegsOfInstr
+        isJumpishInstr          = sparc_isJumpishInstr
+        jumpDestsOfInstr        = sparc_jumpDestsOfInstr
+        patchJumpInstr          = sparc_patchJumpInstr
+        mkSpillInstr            = sparc_mkSpillInstr
+        mkLoadInstr             = sparc_mkLoadInstr
+        takeDeltaInstr          = sparc_takeDeltaInstr
+        isMetaInstr             = sparc_isMetaInstr
+        mkRegRegMoveInstr       = sparc_mkRegRegMoveInstr
+        takeRegRegMoveInstr     = sparc_takeRegRegMoveInstr
+        mkJumpInstr             = sparc_mkJumpInstr
+        mkStackAllocInstr       = panic "no sparc_mkStackAllocInstr"
+        mkStackDeallocInstr     = panic "no sparc_mkStackDeallocInstr"
+
+
+-- | SPARC instruction set.
+--      Not complete. This is only the ones we need.
+--
+data Instr
+
+        -- meta ops --------------------------------------------------
+        -- comment pseudo-op
+        = COMMENT FastString
+
+        -- some static data spat out during code generation.
+        -- Will be extracted before pretty-printing.
+        | LDATA   Section CmmStatics
+
+        -- Start a new basic block.  Useful during codegen, removed later.
+        -- Preceding instruction should be a jump, as per the invariants
+        -- for a BasicBlock (see Cmm).
+        | NEWBLOCK BlockId
+
+        -- specify current stack offset for benefit of subsequent passes.
+        | DELTA   Int
+
+        -- real instrs -----------------------------------------------
+        -- Loads and stores.
+        | LD            Format AddrMode Reg             -- format, src, dst
+        | ST            Format Reg AddrMode             -- format, src, dst
+
+        -- Int Arithmetic.
+        --      x:   add/sub with carry bit.
+        --              In SPARC V9 addx and friends were renamed addc.
+        --
+        --      cc:  modify condition codes
+        --
+        | ADD           Bool Bool Reg RI Reg            -- x?, cc?, src1, src2, dst
+        | SUB           Bool Bool Reg RI Reg            -- x?, cc?, src1, src2, dst
+
+        | UMUL          Bool Reg RI Reg                 --     cc?, src1, src2, dst
+        | SMUL          Bool Reg RI Reg                 --     cc?, src1, src2, dst
+
+
+        -- The SPARC divide instructions perform 64bit by 32bit division
+        --   The Y register is xored into the first operand.
+
+        --   On _some implementations_ the Y register is overwritten by
+        --   the remainder, so we have to make sure it is 0 each time.
+
+        --   dst <- ((Y `shiftL` 32) `or` src1) `div` src2
+        | UDIV          Bool Reg RI Reg                 --     cc?, src1, src2, dst
+        | SDIV          Bool Reg RI Reg                 --     cc?, src1, src2, dst
+
+        | RDY           Reg                             -- move contents of Y register to reg
+        | WRY           Reg  Reg                        -- Y <- src1 `xor` src2
+
+        -- Logic operations.
+        | AND           Bool Reg RI Reg                 -- cc?, src1, src2, dst
+        | ANDN          Bool Reg RI Reg                 -- cc?, src1, src2, dst
+        | OR            Bool Reg RI Reg                 -- cc?, src1, src2, dst
+        | ORN           Bool Reg RI Reg                 -- cc?, src1, src2, dst
+        | XOR           Bool Reg RI Reg                 -- cc?, src1, src2, dst
+        | XNOR          Bool Reg RI Reg                 -- cc?, src1, src2, dst
+        | SLL           Reg RI Reg                      -- src1, src2, dst
+        | SRL           Reg RI Reg                      -- src1, src2, dst
+        | SRA           Reg RI Reg                      -- src1, src2, dst
+
+        -- Load immediates.
+        | SETHI         Imm Reg                         -- src, dst
+
+        -- Do nothing.
+        -- Implemented by the assembler as SETHI 0, %g0, but worth an alias
+        | NOP
+
+        -- Float Arithmetic.
+        -- Note that we cheat by treating F{ABS,MOV,NEG} of doubles as single
+        -- instructions right up until we spit them out.
+        --
+        | FABS          Format Reg Reg                  -- src dst
+        | FADD          Format Reg Reg Reg              -- src1, src2, dst
+        | FCMP          Bool Format Reg Reg             -- exception?, src1, src2, dst
+        | FDIV          Format Reg Reg Reg              -- src1, src2, dst
+        | FMOV          Format Reg Reg                  -- src, dst
+        | FMUL          Format Reg Reg Reg              -- src1, src2, dst
+        | FNEG          Format Reg Reg                  -- src, dst
+        | FSQRT         Format Reg Reg                  -- src, dst
+        | FSUB          Format Reg Reg Reg              -- src1, src2, dst
+        | FxTOy         Format Format Reg Reg           -- src, dst
+
+        -- Jumping around.
+        | BI            Cond Bool BlockId               -- cond, annul?, target
+        | BF            Cond Bool BlockId               -- cond, annul?, target
+
+        | JMP           AddrMode                        -- target
+
+        -- With a tabled jump we know all the possible destinations.
+        -- We also need this info so we can work out what regs are live across the jump.
+        --
+        | JMP_TBL       AddrMode [Maybe BlockId] CLabel
+
+        | CALL          (Either Imm Reg) Int Bool       -- target, args, terminal
+
+
+-- | regUsage returns the sets of src and destination registers used
+--      by a particular instruction.  Machine registers that are
+--      pre-allocated to stgRegs are filtered out, because they are
+--      uninteresting from a register allocation standpoint.  (We wouldn't
+--      want them to end up on the free list!)  As far as we are concerned,
+--      the fixed registers simply don't exist (for allocation purposes,
+--      anyway).
+
+--      regUsage doesn't need to do any trickery for jumps and such.  Just
+--      state precisely the regs read and written by that insn.  The
+--      consequences of control flow transfers, as far as register
+--      allocation goes, are taken care of by the register allocator.
+--
+sparc_regUsageOfInstr :: Platform -> Instr -> RegUsage
+sparc_regUsageOfInstr platform instr
+ = case instr of
+    LD    _ addr reg            -> usage (regAddr addr,         [reg])
+    ST    _ reg addr            -> usage (reg : regAddr addr,   [])
+    ADD   _ _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    SUB   _ _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    UMUL    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    SMUL    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    UDIV    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    SDIV    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    RDY       rd                -> usage ([],                   [rd])
+    WRY       r1 r2             -> usage ([r1, r2],             [])
+    AND     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    ANDN    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    OR      _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    ORN     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    XOR     _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    XNOR    _ r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    SLL       r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    SRL       r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    SRA       r1 ar r2          -> usage (r1 : regRI ar,        [r2])
+    SETHI   _ reg               -> usage ([],                   [reg])
+    FABS    _ r1 r2             -> usage ([r1],                 [r2])
+    FADD    _ r1 r2 r3          -> usage ([r1, r2],             [r3])
+    FCMP    _ _  r1 r2          -> usage ([r1, r2],             [])
+    FDIV    _ r1 r2 r3          -> usage ([r1, r2],             [r3])
+    FMOV    _ r1 r2             -> usage ([r1],                 [r2])
+    FMUL    _ r1 r2 r3          -> usage ([r1, r2],             [r3])
+    FNEG    _ r1 r2             -> usage ([r1],                 [r2])
+    FSQRT   _ r1 r2             -> usage ([r1],                 [r2])
+    FSUB    _ r1 r2 r3          -> usage ([r1, r2],             [r3])
+    FxTOy   _ _  r1 r2          -> usage ([r1],                 [r2])
+
+    JMP     addr                -> usage (regAddr addr, [])
+    JMP_TBL addr _ _            -> usage (regAddr addr, [])
+
+    CALL  (Left _  )  _ True    -> noUsage
+    CALL  (Left _  )  n False   -> usage (argRegs n, callClobberedRegs)
+    CALL  (Right reg) _ True    -> usage ([reg], [])
+    CALL  (Right reg) n False   -> usage (reg : (argRegs n), callClobberedRegs)
+    _                           -> noUsage
+
+  where
+    usage (src, dst)
+     = RU (filter (interesting platform) src)
+          (filter (interesting platform) dst)
+
+    regAddr (AddrRegReg r1 r2)  = [r1, r2]
+    regAddr (AddrRegImm r1 _)   = [r1]
+
+    regRI (RIReg r)             = [r]
+    regRI  _                    = []
+
+
+-- | Interesting regs are virtuals, or ones that are allocatable
+--      by the register allocator.
+interesting :: Platform -> Reg -> Bool
+interesting platform reg
+ = case reg of
+        RegVirtual _                    -> True
+        RegReal (RealRegSingle r1)      -> freeReg platform r1
+        RegReal (RealRegPair r1 _)      -> freeReg platform r1
+
+
+
+-- | Apply a given mapping to tall the register references in this instruction.
+sparc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
+sparc_patchRegsOfInstr instr env = case instr of
+    LD    fmt addr reg          -> LD fmt (fixAddr addr) (env reg)
+    ST    fmt reg addr          -> ST fmt (env reg) (fixAddr addr)
+
+    ADD   x cc r1 ar r2         -> ADD   x cc  (env r1) (fixRI ar) (env r2)
+    SUB   x cc r1 ar r2         -> SUB   x cc  (env r1) (fixRI ar) (env r2)
+    UMUL    cc r1 ar r2         -> UMUL    cc  (env r1) (fixRI ar) (env r2)
+    SMUL    cc r1 ar r2         -> SMUL    cc  (env r1) (fixRI ar) (env r2)
+    UDIV    cc r1 ar r2         -> UDIV    cc  (env r1) (fixRI ar) (env r2)
+    SDIV    cc r1 ar r2         -> SDIV    cc  (env r1) (fixRI ar) (env r2)
+    RDY   rd                    -> RDY         (env rd)
+    WRY   r1 r2                 -> WRY         (env r1) (env r2)
+    AND   b r1 ar r2            -> AND   b     (env r1) (fixRI ar) (env r2)
+    ANDN  b r1 ar r2            -> ANDN  b     (env r1) (fixRI ar) (env r2)
+    OR    b r1 ar r2            -> OR    b     (env r1) (fixRI ar) (env r2)
+    ORN   b r1 ar r2            -> ORN   b     (env r1) (fixRI ar) (env r2)
+    XOR   b r1 ar r2            -> XOR   b     (env r1) (fixRI ar) (env r2)
+    XNOR  b r1 ar r2            -> XNOR  b     (env r1) (fixRI ar) (env r2)
+    SLL   r1 ar r2              -> SLL         (env r1) (fixRI ar) (env r2)
+    SRL   r1 ar r2              -> SRL         (env r1) (fixRI ar) (env r2)
+    SRA   r1 ar r2              -> SRA         (env r1) (fixRI ar) (env r2)
+
+    SETHI imm reg               -> SETHI imm (env reg)
+
+    FABS  s r1 r2               -> FABS    s   (env r1) (env r2)
+    FADD  s r1 r2 r3            -> FADD    s   (env r1) (env r2) (env r3)
+    FCMP  e s r1 r2             -> FCMP e  s   (env r1) (env r2)
+    FDIV  s r1 r2 r3            -> FDIV    s   (env r1) (env r2) (env r3)
+    FMOV  s r1 r2               -> FMOV    s   (env r1) (env r2)
+    FMUL  s r1 r2 r3            -> FMUL    s   (env r1) (env r2) (env r3)
+    FNEG  s r1 r2               -> FNEG    s   (env r1) (env r2)
+    FSQRT s r1 r2               -> FSQRT   s   (env r1) (env r2)
+    FSUB  s r1 r2 r3            -> FSUB    s   (env r1) (env r2) (env r3)
+    FxTOy s1 s2 r1 r2           -> FxTOy s1 s2 (env r1) (env r2)
+
+    JMP     addr                -> JMP     (fixAddr addr)
+    JMP_TBL addr ids l          -> JMP_TBL (fixAddr addr) ids l
+
+    CALL  (Left i) n t          -> CALL (Left i) n t
+    CALL  (Right r) n t         -> CALL (Right (env r)) n t
+    _                           -> instr
+
+  where
+    fixAddr (AddrRegReg r1 r2)  = AddrRegReg   (env r1) (env r2)
+    fixAddr (AddrRegImm r1 i)   = AddrRegImm   (env r1) i
+
+    fixRI (RIReg r)             = RIReg (env r)
+    fixRI other                 = other
+
+
+--------------------------------------------------------------------------------
+sparc_isJumpishInstr :: Instr -> Bool
+sparc_isJumpishInstr instr
+ = case instr of
+        BI{}            -> True
+        BF{}            -> True
+        JMP{}           -> True
+        JMP_TBL{}       -> True
+        CALL{}          -> True
+        _               -> False
+
+sparc_jumpDestsOfInstr :: Instr -> [BlockId]
+sparc_jumpDestsOfInstr insn
+  = case insn of
+        BI   _ _ id     -> [id]
+        BF   _ _ id     -> [id]
+        JMP_TBL _ ids _ -> [id | Just id <- ids]
+        _               -> []
+
+
+sparc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
+sparc_patchJumpInstr insn patchF
+  = case insn of
+        BI cc annul id  -> BI cc annul (patchF id)
+        BF cc annul id  -> BF cc annul (patchF id)
+        JMP_TBL n ids l -> JMP_TBL n (map (fmap patchF) ids) l
+        _               -> insn
+
+
+--------------------------------------------------------------------------------
+-- | Make a spill instruction.
+--      On SPARC we spill below frame pointer leaving 2 words/spill
+sparc_mkSpillInstr
+    :: DynFlags
+    -> Reg      -- ^ register to spill
+    -> Int      -- ^ current stack delta
+    -> Int      -- ^ spill slot to use
+    -> Instr
+
+sparc_mkSpillInstr dflags reg _ slot
+ = let  platform = targetPlatform dflags
+        off      = spillSlotToOffset dflags slot
+        off_w    = 1 + (off `div` 4)
+        fmt      = case targetClassOfReg platform reg of
+                        RcInteger -> II32
+                        RcFloat   -> FF32
+                        RcDouble  -> FF64
+                        _         -> panic "sparc_mkSpillInstr"
+
+    in ST fmt reg (fpRel (negate off_w))
+
+
+-- | Make a spill reload instruction.
+sparc_mkLoadInstr
+    :: DynFlags
+    -> Reg      -- ^ register to load into
+    -> Int      -- ^ current stack delta
+    -> Int      -- ^ spill slot to use
+    -> Instr
+
+sparc_mkLoadInstr dflags reg _ slot
+  = let platform = targetPlatform dflags
+        off      = spillSlotToOffset dflags slot
+        off_w    = 1 + (off `div` 4)
+        fmt      = case targetClassOfReg platform reg of
+                        RcInteger -> II32
+                        RcFloat   -> FF32
+                        RcDouble  -> FF64
+                        _         -> panic "sparc_mkLoadInstr"
+
+        in LD fmt (fpRel (- off_w)) reg
+
+
+--------------------------------------------------------------------------------
+-- | See if this instruction is telling us the current C stack delta
+sparc_takeDeltaInstr
+        :: Instr
+        -> Maybe Int
+
+sparc_takeDeltaInstr instr
+ = case instr of
+        DELTA i         -> Just i
+        _               -> Nothing
+
+
+sparc_isMetaInstr
+        :: Instr
+        -> Bool
+
+sparc_isMetaInstr instr
+ = case instr of
+        COMMENT{}       -> True
+        LDATA{}         -> True
+        NEWBLOCK{}      -> True
+        DELTA{}         -> True
+        _               -> False
+
+
+-- | Make a reg-reg move instruction.
+--      On SPARC v8 there are no instructions to move directly between
+--      floating point and integer regs. If we need to do that then we
+--      have to go via memory.
+--
+sparc_mkRegRegMoveInstr
+    :: Platform
+    -> Reg
+    -> Reg
+    -> Instr
+
+sparc_mkRegRegMoveInstr platform src dst
+        | srcClass      <- targetClassOfReg platform src
+        , dstClass      <- targetClassOfReg platform dst
+        , srcClass == dstClass
+        = case srcClass of
+                RcInteger -> ADD  False False src (RIReg g0) dst
+                RcDouble  -> FMOV FF64 src dst
+                RcFloat   -> FMOV FF32 src dst
+                _         -> panic "sparc_mkRegRegMoveInstr"
+
+        | otherwise
+        = panic "SPARC.Instr.mkRegRegMoveInstr: classes of src and dest not the same"
+
+
+-- | Check whether an instruction represents a reg-reg move.
+--      The register allocator attempts to eliminate reg->reg moves whenever it can,
+--      by assigning the src and dest temporaries to the same real register.
+--
+sparc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)
+sparc_takeRegRegMoveInstr instr
+ = case instr of
+        ADD False False src (RIReg src2) dst
+         | g0 == src2           -> Just (src, dst)
+
+        FMOV FF64 src dst       -> Just (src, dst)
+        FMOV FF32  src dst      -> Just (src, dst)
+        _                       -> Nothing
+
+
+-- | Make an unconditional branch instruction.
+sparc_mkJumpInstr
+        :: BlockId
+        -> [Instr]
+
+sparc_mkJumpInstr id
+ =       [BI ALWAYS False id
+        , NOP]                  -- fill the branch delay slot.
diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/Ppr.hs
@@ -0,0 +1,646 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing assembly language
+--
+-- (c) The University of Glasgow 1993-2005
+--
+-----------------------------------------------------------------------------
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module SPARC.Ppr (
+        pprNatCmmDecl,
+        pprBasicBlock,
+        pprData,
+        pprInstr,
+        pprFormat,
+        pprImm,
+        pprDataItem
+)
+
+where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+import GhcPrelude
+
+import SPARC.Regs
+import SPARC.Instr
+import SPARC.Cond
+import SPARC.Imm
+import SPARC.AddrMode
+import SPARC.Base
+import Instruction
+import Reg
+import Format
+import PprBase
+
+import Cmm hiding (topInfoTable)
+import PprCmm()
+import BlockId
+import CLabel
+import Hoopl.Label
+import Hoopl.Collections
+
+import Unique           ( pprUniqueAlways )
+import Outputable
+import Platform
+import FastString
+import Data.Word
+
+-- -----------------------------------------------------------------------------
+-- Printing this stuff out
+
+pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
+pprNatCmmDecl (CmmData section dats) =
+  pprSectionAlign section $$ pprDatas dats
+
+pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
+  case topInfoTable proc of
+    Nothing ->
+       case blocks of
+         []     -> -- special case for split markers:
+           pprLabel lbl
+         blocks -> -- special case for code without info table:
+           pprSectionAlign (Section Text lbl) $$
+           pprLabel lbl $$ -- blocks guaranteed not null, so label needed
+           vcat (map (pprBasicBlock top_info) blocks)
+
+    Just (Statics info_lbl _) ->
+      sdocWithPlatform $ \platform ->
+      (if platformHasSubsectionsViaSymbols platform
+          then pprSectionAlign dspSection $$
+               ppr (mkDeadStripPreventer info_lbl) <> char ':'
+          else empty) $$
+      vcat (map (pprBasicBlock top_info) blocks) $$
+      -- above: Even the first block gets a label, because with branch-chain
+      -- elimination, it might be the target of a goto.
+      (if platformHasSubsectionsViaSymbols platform
+       then
+       -- See Note [Subsections Via Symbols] in X86/Ppr.hs
+                text "\t.long "
+            <+> ppr info_lbl
+            <+> char '-'
+            <+> ppr (mkDeadStripPreventer info_lbl)
+       else empty)
+
+dspSection :: Section
+dspSection = Section Text $
+    panic "subsections-via-symbols doesn't combine with split-sections"
+
+pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc
+pprBasicBlock info_env (BasicBlock blockid instrs)
+  = maybe_infotable $$
+    pprLabel (blockLbl blockid) $$
+    vcat (map pprInstr instrs)
+  where
+    maybe_infotable = case mapLookup blockid info_env of
+       Nothing   -> empty
+       Just (Statics info_lbl info) ->
+           pprAlignForSection Text $$
+           vcat (map pprData info) $$
+           pprLabel info_lbl
+
+
+pprDatas :: CmmStatics -> SDoc
+pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)
+
+pprData :: CmmStatic -> SDoc
+pprData (CmmString str)
+  = vcat (map do1 str) $$ do1 0
+    where
+       do1 :: Word8 -> SDoc
+       do1 w = text "\t.byte\t" <> int (fromIntegral w)
+pprData (CmmUninitialised bytes) = text ".skip " <> int bytes
+pprData (CmmStaticLit lit)       = pprDataItem lit
+
+pprGloblDecl :: CLabel -> SDoc
+pprGloblDecl lbl
+  | not (externallyVisibleCLabel lbl) = empty
+  | otherwise = text ".global " <> ppr lbl
+
+pprTypeAndSizeDecl :: CLabel -> SDoc
+pprTypeAndSizeDecl lbl
+    = sdocWithPlatform $ \platform ->
+      if platformOS platform == OSLinux && externallyVisibleCLabel lbl
+      then text ".type " <> ppr lbl <> ptext (sLit ", @object")
+      else empty
+
+pprLabel :: CLabel -> SDoc
+pprLabel lbl = pprGloblDecl lbl
+            $$ pprTypeAndSizeDecl lbl
+            $$ (ppr lbl <> char ':')
+
+-- -----------------------------------------------------------------------------
+-- pprInstr: print an 'Instr'
+
+instance Outputable Instr where
+    ppr instr = pprInstr instr
+
+
+-- | Pretty print a register.
+pprReg :: Reg -> SDoc
+pprReg reg
+ = case reg of
+        RegVirtual vr
+         -> case vr of
+                VirtualRegI   u -> text "%vI_"   <> pprUniqueAlways u
+                VirtualRegHi  u -> text "%vHi_"  <> pprUniqueAlways u
+                VirtualRegF   u -> text "%vF_"   <> pprUniqueAlways u
+                VirtualRegD   u -> text "%vD_"   <> pprUniqueAlways u
+                VirtualRegSSE u -> text "%vSSE_" <> pprUniqueAlways u
+
+        RegReal rr
+         -> case rr of
+                RealRegSingle r1
+                 -> pprReg_ofRegNo r1
+
+                RealRegPair r1 r2
+                 -> text "(" <> pprReg_ofRegNo r1
+                 <> vbar     <> pprReg_ofRegNo r2
+                 <> text ")"
+
+
+
+-- | Pretty print a register name, based on this register number.
+--   The definition has been unfolded so we get a jump-table in the
+--   object code. This function is called quite a lot when emitting
+--   the asm file..
+--
+pprReg_ofRegNo :: Int -> SDoc
+pprReg_ofRegNo i
+ = ptext
+    (case i of {
+         0 -> sLit "%g0";   1 -> sLit "%g1";
+         2 -> sLit "%g2";   3 -> sLit "%g3";
+         4 -> sLit "%g4";   5 -> sLit "%g5";
+         6 -> sLit "%g6";   7 -> sLit "%g7";
+         8 -> sLit "%o0";   9 -> sLit "%o1";
+        10 -> sLit "%o2";  11 -> sLit "%o3";
+        12 -> sLit "%o4";  13 -> sLit "%o5";
+        14 -> sLit "%o6";  15 -> sLit "%o7";
+        16 -> sLit "%l0";  17 -> sLit "%l1";
+        18 -> sLit "%l2";  19 -> sLit "%l3";
+        20 -> sLit "%l4";  21 -> sLit "%l5";
+        22 -> sLit "%l6";  23 -> sLit "%l7";
+        24 -> sLit "%i0";  25 -> sLit "%i1";
+        26 -> sLit "%i2";  27 -> sLit "%i3";
+        28 -> sLit "%i4";  29 -> sLit "%i5";
+        30 -> sLit "%i6";  31 -> sLit "%i7";
+        32 -> sLit "%f0";  33 -> sLit "%f1";
+        34 -> sLit "%f2";  35 -> sLit "%f3";
+        36 -> sLit "%f4";  37 -> sLit "%f5";
+        38 -> sLit "%f6";  39 -> sLit "%f7";
+        40 -> sLit "%f8";  41 -> sLit "%f9";
+        42 -> sLit "%f10"; 43 -> sLit "%f11";
+        44 -> sLit "%f12"; 45 -> sLit "%f13";
+        46 -> sLit "%f14"; 47 -> sLit "%f15";
+        48 -> sLit "%f16"; 49 -> sLit "%f17";
+        50 -> sLit "%f18"; 51 -> sLit "%f19";
+        52 -> sLit "%f20"; 53 -> sLit "%f21";
+        54 -> sLit "%f22"; 55 -> sLit "%f23";
+        56 -> sLit "%f24"; 57 -> sLit "%f25";
+        58 -> sLit "%f26"; 59 -> sLit "%f27";
+        60 -> sLit "%f28"; 61 -> sLit "%f29";
+        62 -> sLit "%f30"; 63 -> sLit "%f31";
+        _  -> sLit "very naughty sparc register" })
+
+
+-- | Pretty print a format for an instruction suffix.
+pprFormat :: Format -> SDoc
+pprFormat x
+ = ptext
+    (case x of
+        II8     -> sLit "ub"
+        II16    -> sLit "uh"
+        II32    -> sLit ""
+        II64    -> sLit "d"
+        FF32    -> sLit ""
+        FF64    -> sLit "d"
+        _       -> panic "SPARC.Ppr.pprFormat: no match")
+
+
+-- | Pretty print a format for an instruction suffix.
+--      eg LD is 32bit on sparc, but LDD is 64 bit.
+pprStFormat :: Format -> SDoc
+pprStFormat x
+ = ptext
+    (case x of
+        II8   -> sLit "b"
+        II16  -> sLit "h"
+        II32  -> sLit ""
+        II64  -> sLit "x"
+        FF32  -> sLit ""
+        FF64  -> sLit "d"
+        _       -> panic "SPARC.Ppr.pprFormat: no match")
+
+
+-- | Pretty print a condition code.
+pprCond :: Cond -> SDoc
+pprCond c
+ = ptext
+    (case c of
+        ALWAYS  -> sLit ""
+        NEVER   -> sLit "n"
+        GEU     -> sLit "geu"
+        LU      -> sLit "lu"
+        EQQ     -> sLit "e"
+        GTT     -> sLit "g"
+        GE      -> sLit "ge"
+        GU      -> sLit "gu"
+        LTT     -> sLit "l"
+        LE      -> sLit "le"
+        LEU     -> sLit "leu"
+        NE      -> sLit "ne"
+        NEG     -> sLit "neg"
+        POS     -> sLit "pos"
+        VC      -> sLit "vc"
+        VS      -> sLit "vs")
+
+
+-- | Pretty print an address mode.
+pprAddr :: AddrMode -> SDoc
+pprAddr am
+ = case am of
+        AddrRegReg r1 (RegReal (RealRegSingle 0))
+         -> pprReg r1
+
+        AddrRegReg r1 r2
+         -> hcat [ pprReg r1, char '+', pprReg r2 ]
+
+        AddrRegImm r1 (ImmInt i)
+         | i == 0               -> pprReg r1
+         | not (fits13Bits i)   -> largeOffsetError i
+         | otherwise            -> hcat [ pprReg r1, pp_sign, int i ]
+         where
+                pp_sign = if i > 0 then char '+' else empty
+
+        AddrRegImm r1 (ImmInteger i)
+         | i == 0               -> pprReg r1
+         | not (fits13Bits i)   -> largeOffsetError i
+         | otherwise            -> hcat [ pprReg r1, pp_sign, integer i ]
+         where
+                pp_sign = if i > 0 then char '+' else empty
+
+        AddrRegImm r1 imm
+         -> hcat [ pprReg r1, char '+', pprImm imm ]
+
+
+-- | Pretty print an immediate value.
+pprImm :: Imm -> SDoc
+pprImm imm
+ = case imm of
+        ImmInt i        -> int i
+        ImmInteger i    -> integer i
+        ImmCLbl l       -> ppr l
+        ImmIndex l i    -> ppr l <> char '+' <> int i
+        ImmLit s        -> s
+
+        ImmConstantSum a b
+         -> pprImm a <> char '+' <> pprImm b
+
+        ImmConstantDiff a b
+         -> pprImm a <> char '-' <> lparen <> pprImm b <> rparen
+
+        LO i
+         -> hcat [ text "%lo(", pprImm i, rparen ]
+
+        HI i
+         -> hcat [ text "%hi(", pprImm i, rparen ]
+
+        -- these should have been converted to bytes and placed
+        --      in the data section.
+        ImmFloat _      -> text "naughty float immediate"
+        ImmDouble _     -> text "naughty double immediate"
+
+
+-- | Pretty print a section \/ segment header.
+--      On SPARC all the data sections must be at least 8 byte aligned
+--      incase we store doubles in them.
+--
+pprSectionAlign :: Section -> SDoc
+pprSectionAlign sec@(Section seg _) =
+  sdocWithPlatform $ \platform ->
+    pprSectionHeader platform sec $$
+    pprAlignForSection seg
+
+-- | Print appropriate alignment for the given section type.
+pprAlignForSection :: SectionType -> SDoc
+pprAlignForSection seg =
+    ptext (case seg of
+      Text              -> sLit ".align 4"
+      Data              -> sLit ".align 8"
+      ReadOnlyData      -> sLit ".align 8"
+      RelocatableReadOnlyData
+                        -> sLit ".align 8"
+      UninitialisedData -> sLit ".align 8"
+      ReadOnlyData16    -> sLit ".align 16"
+      -- TODO: This is copied from the ReadOnlyData case, but it can likely be
+      -- made more efficient.
+      CString           -> sLit ".align 8"
+      OtherSection _    -> panic "PprMach.pprSectionHeader: unknown section")
+
+-- | Pretty print a data item.
+pprDataItem :: CmmLit -> SDoc
+pprDataItem lit
+  = sdocWithDynFlags $ \dflags ->
+    vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit)
+    where
+        imm = litToImm lit
+
+        ppr_item II8   _        = [text "\t.byte\t" <> pprImm imm]
+        ppr_item II32  _        = [text "\t.long\t" <> pprImm imm]
+
+        ppr_item FF32  (CmmFloat r _)
+         = let bs = floatToBytes (fromRational r)
+           in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+
+        ppr_item FF64 (CmmFloat r _)
+         = let bs = doubleToBytes (fromRational r)
+           in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+
+        ppr_item II16  _        = [text "\t.short\t" <> pprImm imm]
+        ppr_item II64  _        = [text "\t.quad\t" <> pprImm imm]
+        ppr_item _ _            = panic "SPARC.Ppr.pprDataItem: no match"
+
+
+-- | Pretty print an instruction.
+pprInstr :: Instr -> SDoc
+
+-- nuke comments.
+pprInstr (COMMENT _)
+        = empty
+
+pprInstr (DELTA d)
+        = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))
+
+-- Newblocks and LData should have been slurped out before producing the .s file.
+pprInstr (NEWBLOCK _)
+        = panic "X86.Ppr.pprInstr: NEWBLOCK"
+
+pprInstr (LDATA _ _)
+        = panic "PprMach.pprInstr: LDATA"
+
+-- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand
+pprInstr (LD FF64 _ reg)
+        | RegReal (RealRegSingle{})     <- reg
+        = panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr"
+
+pprInstr (LD format addr reg)
+        = hcat [
+               text "\tld",
+               pprFormat format,
+               char '\t',
+               lbrack,
+               pprAddr addr,
+               pp_rbracket_comma,
+               pprReg reg
+            ]
+
+-- 64 bit FP stores are expanded into individual instructions in CodeGen.Expand
+pprInstr (ST FF64 reg _)
+        | RegReal (RealRegSingle{}) <- reg
+        = panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr"
+
+-- no distinction is made between signed and unsigned bytes on stores for the
+-- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),
+-- so we call a special-purpose pprFormat for ST..
+pprInstr (ST format reg addr)
+        = hcat [
+               text "\tst",
+               pprStFormat format,
+               char '\t',
+               pprReg reg,
+               pp_comma_lbracket,
+               pprAddr addr,
+               rbrack
+            ]
+
+
+pprInstr (ADD x cc reg1 ri reg2)
+        | not x && not cc && riZero ri
+        = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ]
+
+        | otherwise
+        = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2
+
+
+pprInstr (SUB x cc reg1 ri reg2)
+        | not x && cc && reg2 == g0
+        = hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI ri ]
+
+        | not x && not cc && riZero ri
+        = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ]
+
+        | otherwise
+        = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2
+
+pprInstr (AND  b reg1 ri reg2) = pprRegRIReg (sLit "and")  b reg1 ri reg2
+
+pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2
+
+pprInstr (OR b reg1 ri reg2)
+        | not b && reg1 == g0
+        = let doit = hcat [ text "\tmov\t", pprRI ri, comma, pprReg reg2 ]
+          in  case ri of
+                   RIReg rrr | rrr == reg2 -> empty
+                   _                       -> doit
+
+        | otherwise
+        = pprRegRIReg (sLit "or") b reg1 ri reg2
+
+pprInstr (ORN b reg1 ri reg2)  = pprRegRIReg (sLit "orn") b reg1 ri reg2
+
+pprInstr (XOR  b reg1 ri reg2) = pprRegRIReg (sLit "xor")  b reg1 ri reg2
+pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2
+
+pprInstr (SLL reg1 ri reg2)    = pprRegRIReg (sLit "sll") False reg1 ri reg2
+pprInstr (SRL reg1 ri reg2)    = pprRegRIReg (sLit "srl") False reg1 ri reg2
+pprInstr (SRA reg1 ri reg2)    = pprRegRIReg (sLit "sra") False reg1 ri reg2
+
+pprInstr (RDY rd)              = text "\trd\t%y," <> pprReg rd
+pprInstr (WRY reg1 reg2)
+        = text "\twr\t"
+                <> pprReg reg1
+                <> char ','
+                <> pprReg reg2
+                <> char ','
+                <> text "%y"
+
+pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul")  b reg1 ri reg2
+pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul")  b reg1 ri reg2
+pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv")  b reg1 ri reg2
+pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv")  b reg1 ri reg2
+
+pprInstr (SETHI imm reg)
+  = hcat [
+        text "\tsethi\t",
+        pprImm imm,
+        comma,
+        pprReg reg
+    ]
+
+pprInstr NOP
+        = text "\tnop"
+
+pprInstr (FABS format reg1 reg2)
+        = pprFormatRegReg (sLit "fabs") format reg1 reg2
+
+pprInstr (FADD format reg1 reg2 reg3)
+        = pprFormatRegRegReg (sLit "fadd") format reg1 reg2 reg3
+
+pprInstr (FCMP e format reg1 reg2)
+        = pprFormatRegReg (if e then sLit "fcmpe" else sLit "fcmp")
+                          format reg1 reg2
+
+pprInstr (FDIV format reg1 reg2 reg3)
+        = pprFormatRegRegReg (sLit "fdiv") format reg1 reg2 reg3
+
+pprInstr (FMOV format reg1 reg2)
+        = pprFormatRegReg (sLit "fmov") format reg1 reg2
+
+pprInstr (FMUL format reg1 reg2 reg3)
+        = pprFormatRegRegReg (sLit "fmul") format reg1 reg2 reg3
+
+pprInstr (FNEG format reg1 reg2)
+        = pprFormatRegReg (sLit "fneg") format reg1 reg2
+
+pprInstr (FSQRT format reg1 reg2)
+        = pprFormatRegReg (sLit "fsqrt") format reg1 reg2
+
+pprInstr (FSUB format reg1 reg2 reg3)
+        = pprFormatRegRegReg (sLit "fsub") format reg1 reg2 reg3
+
+pprInstr (FxTOy format1 format2 reg1 reg2)
+  = hcat [
+        text "\tf",
+        ptext
+        (case format1 of
+            II32  -> sLit "ito"
+            FF32  -> sLit "sto"
+            FF64  -> sLit "dto"
+            _     -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),
+        ptext
+        (case format2 of
+            II32  -> sLit "i\t"
+            II64  -> sLit "x\t"
+            FF32  -> sLit "s\t"
+            FF64  -> sLit "d\t"
+            _     -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),
+        pprReg reg1, comma, pprReg reg2
+    ]
+
+
+pprInstr (BI cond b blockid)
+  = hcat [
+        text "\tb", pprCond cond,
+        if b then pp_comma_a else empty,
+        char '\t',
+        ppr (blockLbl blockid)
+    ]
+
+pprInstr (BF cond b blockid)
+  = hcat [
+        text "\tfb", pprCond cond,
+        if b then pp_comma_a else empty,
+        char '\t',
+        ppr (blockLbl blockid)
+    ]
+
+pprInstr (JMP addr) = text "\tjmp\t" <> pprAddr addr
+pprInstr (JMP_TBL op _ _)  = pprInstr (JMP op)
+
+pprInstr (CALL (Left imm) n _)
+  = hcat [ text "\tcall\t", pprImm imm, comma, int n ]
+
+pprInstr (CALL (Right reg) n _)
+  = hcat [ text "\tcall\t", pprReg reg, comma, int n ]
+
+
+-- | Pretty print a RI
+pprRI :: RI -> SDoc
+pprRI (RIReg r) = pprReg r
+pprRI (RIImm r) = pprImm r
+
+
+-- | Pretty print a two reg instruction.
+pprFormatRegReg :: PtrString -> Format -> Reg -> Reg -> SDoc
+pprFormatRegReg name format reg1 reg2
+  = hcat [
+        char '\t',
+        ptext name,
+        (case format of
+            FF32 -> text "s\t"
+            FF64 -> text "d\t"
+            _    -> panic "SPARC.Ppr.pprFormatRegReg: no match"),
+
+        pprReg reg1,
+        comma,
+        pprReg reg2
+    ]
+
+
+-- | Pretty print a three reg instruction.
+pprFormatRegRegReg :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc
+pprFormatRegRegReg name format reg1 reg2 reg3
+  = hcat [
+        char '\t',
+        ptext name,
+        (case format of
+            FF32  -> text "s\t"
+            FF64  -> text "d\t"
+            _    -> panic "SPARC.Ppr.pprFormatRegReg: no match"),
+        pprReg reg1,
+        comma,
+        pprReg reg2,
+        comma,
+        pprReg reg3
+    ]
+
+
+-- | Pretty print an instruction of two regs and a ri.
+pprRegRIReg :: PtrString -> Bool -> Reg -> RI -> Reg -> SDoc
+pprRegRIReg name b reg1 ri reg2
+  = hcat [
+        char '\t',
+        ptext name,
+        if b then text "cc\t" else char '\t',
+        pprReg reg1,
+        comma,
+        pprRI ri,
+        comma,
+        pprReg reg2
+    ]
+
+{-
+pprRIReg :: PtrString -> Bool -> RI -> Reg -> SDoc
+pprRIReg name b ri reg1
+  = hcat [
+        char '\t',
+        ptext name,
+        if b then text "cc\t" else char '\t',
+        pprRI ri,
+        comma,
+        pprReg reg1
+    ]
+-}
+
+{-
+pp_ld_lbracket :: SDoc
+pp_ld_lbracket    = text "\tld\t["
+-}
+
+pp_rbracket_comma :: SDoc
+pp_rbracket_comma = text "],"
+
+
+pp_comma_lbracket :: SDoc
+pp_comma_lbracket = text ",["
+
+
+pp_comma_a :: SDoc
+pp_comma_a        = text ",a"
+
diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/Regs.hs
@@ -0,0 +1,261 @@
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 1994-2004
+--
+-- -----------------------------------------------------------------------------
+
+module SPARC.Regs (
+        -- registers
+        showReg,
+        virtualRegSqueeze,
+        realRegSqueeze,
+        classOfRealReg,
+        allRealRegs,
+
+        -- machine specific info
+        gReg, iReg, lReg, oReg, fReg,
+        fp, sp, g0, g1, g2, o0, o1, f0, f1, f6, f8, f22, f26, f27,
+
+        -- allocatable
+        allocatableRegs,
+
+        -- args
+        argRegs,
+        allArgRegs,
+        callClobberedRegs,
+
+        --
+        mkVirtualReg,
+        regDotColor
+)
+
+where
+
+
+import GhcPrelude
+
+import CodeGen.Platform.SPARC
+import Reg
+import RegClass
+import Format
+
+import Unique
+import Outputable
+
+{-
+        The SPARC has 64 registers of interest; 32 integer registers and 32
+        floating point registers.  The mapping of STG registers to SPARC
+        machine registers is defined in StgRegs.h.  We are, of course,
+        prepared for any eventuality.
+
+        The whole fp-register pairing thing on sparcs is a huge nuisance.  See
+        includes/stg/MachRegs.h for a description of what's going on
+        here.
+-}
+
+
+-- | Get the standard name for the register with this number.
+showReg :: RegNo -> String
+showReg n
+        | n >= 0  && n < 8   = "%g" ++ show n
+        | n >= 8  && n < 16  = "%o" ++ show (n-8)
+        | n >= 16 && n < 24  = "%l" ++ show (n-16)
+        | n >= 24 && n < 32  = "%i" ++ show (n-24)
+        | n >= 32 && n < 64  = "%f" ++ show (n-32)
+        | otherwise          = panic "SPARC.Regs.showReg: unknown sparc register"
+
+
+-- Get the register class of a certain real reg
+classOfRealReg :: RealReg -> RegClass
+classOfRealReg reg
+ = case reg of
+        RealRegSingle i
+                | i < 32        -> RcInteger
+                | otherwise     -> RcFloat
+
+        RealRegPair{}           -> RcDouble
+
+
+-- | regSqueeze_class reg
+--      Calculate the maximum number of register colors that could be
+--      denied to a node of this class due to having this reg
+--      as a neighbour.
+--
+{-# INLINE virtualRegSqueeze #-}
+virtualRegSqueeze :: RegClass -> VirtualReg -> Int
+
+virtualRegSqueeze cls vr
+ = case cls of
+        RcInteger
+         -> case vr of
+                VirtualRegI{}           -> 1
+                VirtualRegHi{}          -> 1
+                _other                  -> 0
+
+        RcFloat
+         -> case vr of
+                VirtualRegF{}           -> 1
+                VirtualRegD{}           -> 2
+                _other                  -> 0
+
+        RcDouble
+         -> case vr of
+                VirtualRegF{}           -> 1
+                VirtualRegD{}           -> 1
+                _other                  -> 0
+
+        _other -> 0
+
+{-# INLINE realRegSqueeze #-}
+realRegSqueeze :: RegClass -> RealReg -> Int
+
+realRegSqueeze cls rr
+ = case cls of
+        RcInteger
+         -> case rr of
+                RealRegSingle regNo
+                        | regNo < 32    -> 1
+                        | otherwise     -> 0
+
+                RealRegPair{}           -> 0
+
+        RcFloat
+         -> case rr of
+                RealRegSingle regNo
+                        | regNo < 32    -> 0
+                        | otherwise     -> 1
+
+                RealRegPair{}           -> 2
+
+        RcDouble
+         -> case rr of
+                RealRegSingle regNo
+                        | regNo < 32    -> 0
+                        | otherwise     -> 1
+
+                RealRegPair{}           -> 1
+
+        _other -> 0
+
+-- | All the allocatable registers in the machine,
+--      including register pairs.
+allRealRegs :: [RealReg]
+allRealRegs
+        =  [ (RealRegSingle i)          | i <- [0..63] ]
+        ++ [ (RealRegPair   i (i+1))    | i <- [32, 34 .. 62 ] ]
+
+
+-- | Get the regno for this sort of reg
+gReg, lReg, iReg, oReg, fReg :: Int -> RegNo
+
+gReg x  = x             -- global regs
+oReg x  = (8 + x)       -- output regs
+lReg x  = (16 + x)      -- local regs
+iReg x  = (24 + x)      -- input regs
+fReg x  = (32 + x)      -- float regs
+
+
+-- | Some specific regs used by the code generator.
+g0, g1, g2, fp, sp, o0, o1, f0, f1, f6, f8, f22, f26, f27 :: Reg
+
+f6  = RegReal (RealRegSingle (fReg 6))
+f8  = RegReal (RealRegSingle (fReg 8))
+f22 = RegReal (RealRegSingle (fReg 22))
+f26 = RegReal (RealRegSingle (fReg 26))
+f27 = RegReal (RealRegSingle (fReg 27))
+
+-- g0 is always zero, and writes to it vanish.
+g0  = RegReal (RealRegSingle (gReg 0))
+g1  = RegReal (RealRegSingle (gReg 1))
+g2  = RegReal (RealRegSingle (gReg 2))
+
+-- FP, SP, int and float return (from C) regs.
+fp  = RegReal (RealRegSingle (iReg 6))
+sp  = RegReal (RealRegSingle (oReg 6))
+o0  = RegReal (RealRegSingle (oReg 0))
+o1  = RegReal (RealRegSingle (oReg 1))
+f0  = RegReal (RealRegSingle (fReg 0))
+f1  = RegReal (RealRegSingle (fReg 1))
+
+-- | Produce the second-half-of-a-double register given the first half.
+{-
+fPair :: Reg -> Maybe Reg
+fPair (RealReg n)
+        | n >= 32 && n `mod` 2 == 0  = Just (RealReg (n+1))
+
+fPair (VirtualRegD u)
+        = Just (VirtualRegHi u)
+
+fPair reg
+        = trace ("MachInstrs.fPair: can't get high half of supposed double reg " ++ showPpr reg)
+                Nothing
+-}
+
+
+-- | All the regs that the register allocator can allocate to,
+--      with the fixed use regs removed.
+--
+allocatableRegs :: [RealReg]
+allocatableRegs
+   = let isFree rr
+           = case rr of
+                RealRegSingle r     -> freeReg r
+                RealRegPair   r1 r2 -> freeReg r1 && freeReg r2
+     in filter isFree allRealRegs
+
+
+-- | The registers to place arguments for function calls,
+--      for some number of arguments.
+--
+argRegs :: RegNo -> [Reg]
+argRegs r
+ = case r of
+        0       -> []
+        1       -> map (RegReal . RealRegSingle . oReg) [0]
+        2       -> map (RegReal . RealRegSingle . oReg) [0,1]
+        3       -> map (RegReal . RealRegSingle . oReg) [0,1,2]
+        4       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3]
+        5       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4]
+        6       -> map (RegReal . RealRegSingle . oReg) [0,1,2,3,4,5]
+        _       -> panic "MachRegs.argRegs(sparc): don't know about >6 arguments!"
+
+
+-- | All all the regs that could possibly be returned by argRegs
+--
+allArgRegs :: [Reg]
+allArgRegs
+        = map (RegReal . RealRegSingle) [oReg i | i <- [0..5]]
+
+
+-- These are the regs that we cannot assume stay alive over a C call.
+--      TODO: Why can we assume that o6 isn't clobbered? -- BL 2009/02
+--
+callClobberedRegs :: [Reg]
+callClobberedRegs
+        = map (RegReal . RealRegSingle)
+                (  oReg 7 :
+                  [oReg i | i <- [0..5]] ++
+                  [gReg i | i <- [1..7]] ++
+                  [fReg i | i <- [0..31]] )
+
+
+
+-- | Make a virtual reg with this format.
+mkVirtualReg :: Unique -> Format -> VirtualReg
+mkVirtualReg u format
+        | not (isFloatFormat format)
+        = VirtualRegI u
+
+        | otherwise
+        = case format of
+                FF32    -> VirtualRegF u
+                FF64    -> VirtualRegD u
+                _       -> panic "mkVReg"
+
+
+regDotColor :: RealReg -> SDoc
+regDotColor reg
+ = case classOfRealReg reg of
+        RcInteger       -> text "blue"
+        RcFloat         -> text "red"
+        _other          -> text "green"
diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/ShortcutJump.hs
@@ -0,0 +1,74 @@
+module SPARC.ShortcutJump (
+        JumpDest(..), getJumpDestBlockId,
+        canShortcut,
+        shortcutJump,
+        shortcutStatics,
+        shortBlockId
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.Instr
+import SPARC.Imm
+
+import CLabel
+import BlockId
+import Cmm
+
+import Panic
+import Outputable
+
+data JumpDest
+        = DestBlockId BlockId
+        | DestImm Imm
+
+-- Debug Instance
+instance Outputable JumpDest where
+  ppr (DestBlockId bid) = text "blk:" <> ppr bid
+  ppr (DestImm _bid)    = text "imm:?"
+
+getJumpDestBlockId :: JumpDest -> Maybe BlockId
+getJumpDestBlockId (DestBlockId bid) = Just bid
+getJumpDestBlockId _                 = Nothing
+
+
+canShortcut :: Instr -> Maybe JumpDest
+canShortcut _ = Nothing
+
+
+shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
+shortcutJump _ other = other
+
+
+
+shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics
+shortcutStatics fn (Statics lbl statics)
+  = Statics lbl $ map (shortcutStatic fn) statics
+  -- we need to get the jump tables, so apply the mapping to the entries
+  -- of a CmmData too.
+
+shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
+shortcutLabel fn lab
+  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId
+  | otherwise                              = lab
+
+shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
+shortcutStatic fn (CmmStaticLit (CmmLabel lab))
+        = CmmStaticLit (CmmLabel (shortcutLabel fn lab))
+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w))
+        = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w)
+-- slightly dodgy, we're ignoring the second label, but this
+-- works with the way we use CmmLabelDiffOff for jump tables now.
+shortcutStatic _ other_static
+        = other_static
+
+
+shortBlockId :: (BlockId -> Maybe JumpDest) -> BlockId -> CLabel
+shortBlockId fn blockid =
+   case fn blockid of
+      Nothing -> blockLbl blockid
+      Just (DestBlockId blockid')  -> shortBlockId fn blockid'
+      Just (DestImm (ImmCLbl lbl)) -> lbl
+      _other -> panic "shortBlockId"
diff --git a/compiler/nativeGen/SPARC/Stack.hs b/compiler/nativeGen/SPARC/Stack.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/SPARC/Stack.hs
@@ -0,0 +1,59 @@
+module SPARC.Stack (
+        spRel,
+        fpRel,
+        spillSlotToOffset,
+        maxSpillSlots
+)
+
+where
+
+import GhcPrelude
+
+import SPARC.AddrMode
+import SPARC.Regs
+import SPARC.Base
+import SPARC.Imm
+
+import DynFlags
+import Outputable
+
+-- | Get an AddrMode relative to the address in sp.
+--      This gives us a stack relative addressing mode for volatile
+--      temporaries and for excess call arguments.
+--
+spRel :: Int            -- ^ stack offset in words, positive or negative
+      -> AddrMode
+
+spRel n = AddrRegImm sp (ImmInt (n * wordLength))
+
+
+-- | Get an address relative to the frame pointer.
+--      This doesn't work work for offsets greater than 13 bits; we just hope for the best
+--
+fpRel :: Int -> AddrMode
+fpRel n
+        = AddrRegImm fp (ImmInt (n * wordLength))
+
+
+-- | Convert a spill slot number to a *byte* offset, with no sign.
+--
+spillSlotToOffset :: DynFlags -> Int -> Int
+spillSlotToOffset dflags slot
+        | slot >= 0 && slot < maxSpillSlots dflags
+        = 64 + spillSlotSize * slot
+
+        | otherwise
+        = pprPanic "spillSlotToOffset:"
+                      (   text "invalid spill location: " <> int slot
+                      $$  text "maxSpillSlots:          " <> int (maxSpillSlots dflags))
+
+
+-- | The maximum number of spill slots available on the C stack.
+--      If we use up all of the slots, then we're screwed.
+--
+--      Why do we reserve 64 bytes, instead of using the whole thing??
+--              -- BL 2009/02/15
+--
+maxSpillSlots :: DynFlags -> Int
+maxSpillSlots dflags
+        = ((spillAreaLength dflags - 64) `div` spillSlotSize) - 1
diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/TargetReg.hs
@@ -0,0 +1,132 @@
+{-# LANGUAGE CPP #-}
+-- | Hard wired things related to registers.
+--      This is module is preventing the native code generator being able to
+--      emit code for non-host architectures.
+--
+--      TODO: Do a better job of the overloading, and eliminate this module.
+--      We'd probably do better with a Register type class, and hook this to
+--      Instruction somehow.
+--
+--      TODO: We should also make arch specific versions of RegAlloc.Graph.TrivColorable
+module TargetReg (
+        targetVirtualRegSqueeze,
+        targetRealRegSqueeze,
+        targetClassOfRealReg,
+        targetMkVirtualReg,
+        targetRegDotColor,
+        targetClassOfReg
+)
+
+where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Reg
+import RegClass
+import Format
+
+import Outputable
+import Unique
+import Platform
+
+import qualified X86.Regs       as X86
+import qualified X86.RegInfo    as X86
+
+import qualified PPC.Regs       as PPC
+
+import qualified SPARC.Regs     as SPARC
+
+targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int
+targetVirtualRegSqueeze platform
+    = case platformArch platform of
+      ArchX86       -> X86.virtualRegSqueeze
+      ArchX86_64    -> X86.virtualRegSqueeze
+      ArchPPC       -> PPC.virtualRegSqueeze
+      ArchSPARC     -> SPARC.virtualRegSqueeze
+      ArchSPARC64   -> panic "targetVirtualRegSqueeze ArchSPARC64"
+      ArchPPC_64 _  -> PPC.virtualRegSqueeze
+      ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM"
+      ArchARM64     -> panic "targetVirtualRegSqueeze ArchARM64"
+      ArchAlpha     -> panic "targetVirtualRegSqueeze ArchAlpha"
+      ArchMipseb    -> panic "targetVirtualRegSqueeze ArchMipseb"
+      ArchMipsel    -> panic "targetVirtualRegSqueeze ArchMipsel"
+      ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript"
+      ArchUnknown   -> panic "targetVirtualRegSqueeze ArchUnknown"
+
+
+targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> Int
+targetRealRegSqueeze platform
+    = case platformArch platform of
+      ArchX86       -> X86.realRegSqueeze
+      ArchX86_64    -> X86.realRegSqueeze
+      ArchPPC       -> PPC.realRegSqueeze
+      ArchSPARC     -> SPARC.realRegSqueeze
+      ArchSPARC64   -> panic "targetRealRegSqueeze ArchSPARC64"
+      ArchPPC_64 _  -> PPC.realRegSqueeze
+      ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM"
+      ArchARM64     -> panic "targetRealRegSqueeze ArchARM64"
+      ArchAlpha     -> panic "targetRealRegSqueeze ArchAlpha"
+      ArchMipseb    -> panic "targetRealRegSqueeze ArchMipseb"
+      ArchMipsel    -> panic "targetRealRegSqueeze ArchMipsel"
+      ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript"
+      ArchUnknown   -> panic "targetRealRegSqueeze ArchUnknown"
+
+targetClassOfRealReg :: Platform -> RealReg -> RegClass
+targetClassOfRealReg platform
+    = case platformArch platform of
+      ArchX86       -> X86.classOfRealReg platform
+      ArchX86_64    -> X86.classOfRealReg platform
+      ArchPPC       -> PPC.classOfRealReg
+      ArchSPARC     -> SPARC.classOfRealReg
+      ArchSPARC64   -> panic "targetClassOfRealReg ArchSPARC64"
+      ArchPPC_64 _  -> PPC.classOfRealReg
+      ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM"
+      ArchARM64     -> panic "targetClassOfRealReg ArchARM64"
+      ArchAlpha     -> panic "targetClassOfRealReg ArchAlpha"
+      ArchMipseb    -> panic "targetClassOfRealReg ArchMipseb"
+      ArchMipsel    -> panic "targetClassOfRealReg ArchMipsel"
+      ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript"
+      ArchUnknown   -> panic "targetClassOfRealReg ArchUnknown"
+
+targetMkVirtualReg :: Platform -> Unique -> Format -> VirtualReg
+targetMkVirtualReg platform
+    = case platformArch platform of
+      ArchX86       -> X86.mkVirtualReg
+      ArchX86_64    -> X86.mkVirtualReg
+      ArchPPC       -> PPC.mkVirtualReg
+      ArchSPARC     -> SPARC.mkVirtualReg
+      ArchSPARC64   -> panic "targetMkVirtualReg ArchSPARC64"
+      ArchPPC_64 _  -> PPC.mkVirtualReg
+      ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM"
+      ArchARM64     -> panic "targetMkVirtualReg ArchARM64"
+      ArchAlpha     -> panic "targetMkVirtualReg ArchAlpha"
+      ArchMipseb    -> panic "targetMkVirtualReg ArchMipseb"
+      ArchMipsel    -> panic "targetMkVirtualReg ArchMipsel"
+      ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript"
+      ArchUnknown   -> panic "targetMkVirtualReg ArchUnknown"
+
+targetRegDotColor :: Platform -> RealReg -> SDoc
+targetRegDotColor platform
+    = case platformArch platform of
+      ArchX86       -> X86.regDotColor platform
+      ArchX86_64    -> X86.regDotColor platform
+      ArchPPC       -> PPC.regDotColor
+      ArchSPARC     -> SPARC.regDotColor
+      ArchSPARC64   -> panic "targetRegDotColor ArchSPARC64"
+      ArchPPC_64 _  -> PPC.regDotColor
+      ArchARM _ _ _ -> panic "targetRegDotColor ArchARM"
+      ArchARM64     -> panic "targetRegDotColor ArchARM64"
+      ArchAlpha     -> panic "targetRegDotColor ArchAlpha"
+      ArchMipseb    -> panic "targetRegDotColor ArchMipseb"
+      ArchMipsel    -> panic "targetRegDotColor ArchMipsel"
+      ArchJavaScript-> panic "targetRegDotColor ArchJavaScript"
+      ArchUnknown   -> panic "targetRegDotColor ArchUnknown"
+
+
+targetClassOfReg :: Platform -> Reg -> RegClass
+targetClassOfReg platform reg
+ = case reg of
+   RegVirtual vr -> classOfVirtualReg vr
+   RegReal rr -> targetClassOfRealReg platform rr
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -0,0 +1,3474 @@
+{-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-}
+
+-- The default iteration limit is a bit too low for the definitions
+-- in this module.
+{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
+
+-----------------------------------------------------------------------------
+--
+-- Generating machine code (instruction selection)
+--
+-- (c) The University of Glasgow 1996-2004
+--
+-----------------------------------------------------------------------------
+
+-- This is a big module, but, if you pay attention to
+-- (a) the sectioning, and (b) the type signatures, the
+-- structure should not be too overwhelming.
+
+module X86.CodeGen (
+        cmmTopCodeGen,
+        generateJumpTableForInstr,
+        extractUnwindPoints,
+        invertCondBranches,
+        InstrBlock
+)
+
+where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+#include "../includes/MachDeps.h"
+
+-- NCG stuff:
+import GhcPrelude
+
+import X86.Instr
+import X86.Cond
+import X86.Regs
+import X86.RegInfo
+
+--TODO: Remove - Just for development/debugging
+import X86.Ppr()
+
+import CodeGen.Platform
+import CPrim
+import Debug            ( DebugBlock(..), UnwindPoint(..), UnwindTable
+                        , UnwindExpr(UwReg), toUnwindExpr )
+import Instruction
+import PIC
+import NCGMonad   ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat
+                  , getDeltaNat, getBlockIdNat, getPicBaseNat, getNewRegPairNat
+                  , getPicBaseMaybeNat, getDebugBlock, getFileId
+                  , addImmediateSuccessorNat, updateCfgNat)
+import CFG
+import Format
+import Reg
+import Platform
+
+-- Our intermediate code:
+import BasicTypes
+import BlockId
+import Module           ( primUnitId )
+import PprCmm           ()
+import CmmUtils
+import CmmSwitch
+import Cmm
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
+import CLabel
+import CoreSyn          ( Tickish(..) )
+import SrcLoc           ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
+
+-- The rest:
+import ForeignCall      ( CCallConv(..) )
+import OrdList
+import Outputable
+import FastString
+import DynFlags
+import Util
+import UniqSupply       ( getUniqueM )
+
+import Control.Monad
+import Data.Bits
+import Data.Foldable (fold)
+import Data.Int
+import Data.Maybe
+import Data.Word
+
+import qualified Data.Map as M
+
+is32BitPlatform :: NatM Bool
+is32BitPlatform = do
+    dflags <- getDynFlags
+    return $ target32Bit (targetPlatform dflags)
+
+sse2Enabled :: NatM Bool
+sse2Enabled = do
+  dflags <- getDynFlags
+  return (isSse2Enabled dflags)
+
+sse4_2Enabled :: NatM Bool
+sse4_2Enabled = do
+  dflags <- getDynFlags
+  return (isSse4_2Enabled dflags)
+
+if_sse2 :: NatM a -> NatM a -> NatM a
+if_sse2 sse2 x87 = do
+  b <- sse2Enabled
+  if b then sse2 else x87
+
+cmmTopCodeGen
+        :: RawCmmDecl
+        -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]
+
+cmmTopCodeGen (CmmProc info lab live graph) = do
+  let blocks = toBlockListEntryFirst graph
+  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
+  picBaseMb <- getPicBaseMaybeNat
+  dflags <- getDynFlags
+  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
+      tops = proc : concat statics
+      os   = platformOS $ targetPlatform dflags
+
+  case picBaseMb of
+      Just picBase -> initializePicBase_x86 ArchX86 os picBase tops
+      Nothing -> return tops
+
+cmmTopCodeGen (CmmData sec dat) = do
+  return [CmmData sec (1, dat)]  -- no translation, we just use CmmStatic
+
+
+basicBlockCodeGen
+        :: CmmBlock
+        -> NatM ( [NatBasicBlock Instr]
+                , [NatCmmDecl (Alignment, CmmStatics) Instr])
+
+basicBlockCodeGen block = do
+  let (_, nodes, tail)  = blockSplit block
+      id = entryLabel block
+      stmts = blockToList nodes
+  -- Generate location directive
+  dbg <- getDebugBlock (entryLabel block)
+  loc_instrs <- case dblSourceTick =<< dbg of
+    Just (SourceNote span name)
+      -> do fileId <- getFileId (srcSpanFile span)
+            let line = srcSpanStartLine span; col = srcSpanStartCol span
+            return $ unitOL $ LOCATION fileId line col name
+    _ -> return nilOL
+  mid_instrs <- stmtsToInstrs id stmts
+  tail_instrs <- stmtToInstrs id tail
+  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs
+  instrs' <- fold <$> traverse addSpUnwindings instrs
+  -- code generation may introduce new basic block boundaries, which
+  -- are indicated by the NEWBLOCK instruction.  We must split up the
+  -- instruction stream into basic blocks again.  Also, we extract
+  -- LDATAs here too.
+  let
+        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'
+
+        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
+          = ([], BasicBlock id instrs : blocks, statics)
+        mkBlocks (LDATA sec dat) (instrs,blocks,statics)
+          = (instrs, blocks, CmmData sec dat:statics)
+        mkBlocks instr (instrs,blocks,statics)
+          = (instr:instrs, blocks, statics)
+  return (BasicBlock id top : other_blocks, statics)
+
+-- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes
+-- in the @sp@ register. See Note [What is this unwinding business?] in Debug
+-- for details.
+addSpUnwindings :: Instr -> NatM (OrdList Instr)
+addSpUnwindings instr@(DELTA d) = do
+    dflags <- getDynFlags
+    if debugLevel dflags >= 1
+        then do lbl <- mkAsmTempLabel <$> getUniqueM
+                let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)
+                return $ toOL [ instr, UNWIND lbl unwind ]
+        else return (unitOL instr)
+addSpUnwindings instr = return $ unitOL instr
+
+stmtsToInstrs :: BlockId -> [CmmNode e x] -> NatM InstrBlock
+stmtsToInstrs bid stmts
+   = do instrss <- mapM (stmtToInstrs bid) stmts
+        return (concatOL instrss)
+
+-- | `bid` refers to the current block and is used to update the CFG
+--   if new blocks are inserted in the control flow.
+stmtToInstrs :: BlockId -> CmmNode e x -> NatM InstrBlock
+stmtToInstrs bid stmt = do
+  dflags <- getDynFlags
+  is32Bit <- is32BitPlatform
+  case stmt of
+    CmmComment s   -> return (unitOL (COMMENT s))
+    CmmTick {}     -> return nilOL
+
+    CmmUnwind regs -> do
+      let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable
+          to_unwind_entry (reg, expr) = M.singleton reg (fmap toUnwindExpr expr)
+      case foldMap to_unwind_entry regs of
+        tbl | M.null tbl -> return nilOL
+            | otherwise  -> do
+                lbl <- mkAsmTempLabel <$> getUniqueM
+                return $ unitOL $ UNWIND lbl tbl
+
+    CmmAssign reg src
+      | isFloatType ty         -> assignReg_FltCode format reg src
+      | is32Bit && isWord64 ty -> assignReg_I64Code      reg src
+      | otherwise              -> assignReg_IntCode format reg src
+        where ty = cmmRegType dflags reg
+              format = cmmTypeFormat ty
+
+    CmmStore addr src
+      | isFloatType ty         -> assignMem_FltCode format addr src
+      | is32Bit && isWord64 ty -> assignMem_I64Code      addr src
+      | otherwise              -> assignMem_IntCode format addr src
+        where ty = cmmExprType dflags src
+              format = cmmTypeFormat ty
+
+    CmmUnsafeForeignCall target result_regs args
+       -> genCCall dflags is32Bit target result_regs args bid
+
+    CmmBranch id          -> return $ genBranch id
+
+    --We try to arrange blocks such that the likely branch is the fallthrough
+    --in CmmContFlowOpt. So we can assume the condition is likely false here.
+    CmmCondBranch arg true false _ -> genCondBranch bid true false arg
+    CmmSwitch arg ids -> do dflags <- getDynFlags
+                            genSwitch dflags arg ids
+    CmmCall { cml_target = arg
+            , cml_args_regs = gregs } -> do
+                                dflags <- getDynFlags
+                                genJump arg (jumpRegs dflags gregs)
+    _ ->
+      panic "stmtToInstrs: statement should have been cps'd away"
+
+
+jumpRegs :: DynFlags -> [GlobalReg] -> [Reg]
+jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]
+    where platform = targetPlatform dflags
+
+--------------------------------------------------------------------------------
+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
+--      They are really trees of insns to facilitate fast appending, where a
+--      left-to-right traversal yields the insns in the correct order.
+--
+type InstrBlock
+        = OrdList Instr
+
+
+-- | Condition codes passed up the tree.
+--
+data CondCode
+        = CondCode Bool Cond InstrBlock
+
+
+-- | a.k.a "Register64"
+--      Reg is the lower 32-bit temporary which contains the result.
+--      Use getHiVRegFromLo to find the other VRegUnique.
+--
+--      Rules of this simplified insn selection game are therefore that
+--      the returned Reg may be modified
+--
+data ChildCode64
+   = ChildCode64
+        InstrBlock
+        Reg
+
+
+-- | Register's passed up the tree.  If the stix code forces the register
+--      to live in a pre-decided machine register, it comes out as @Fixed@;
+--      otherwise, it comes out as @Any@, and the parent can decide which
+--      register to put it in.
+--
+data Register
+        = Fixed Format Reg InstrBlock
+        | Any   Format (Reg -> InstrBlock)
+
+
+swizzleRegisterRep :: Register -> Format -> Register
+swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code
+swizzleRegisterRep (Any _ codefn)     format = Any   format codefn
+
+
+-- | Grab the Reg for a CmmReg
+getRegisterReg :: Platform -> Bool -> CmmReg -> Reg
+
+getRegisterReg _ use_sse2 (CmmLocal (LocalReg u pk))
+  = let fmt = cmmTypeFormat pk in
+    if isFloatFormat fmt && not use_sse2
+       then RegVirtual (mkVirtualReg u FF80)
+       else RegVirtual (mkVirtualReg u fmt)
+
+getRegisterReg platform _ (CmmGlobal mid)
+  = case globalRegMaybe platform mid of
+        Just reg -> RegReal $ reg
+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
+        -- By this stage, the only MagicIds remaining should be the
+        -- ones which map to a real machine register on this
+        -- platform.  Hence ...
+
+
+-- | Memory addressing modes passed up the tree.
+data Amode
+        = Amode AddrMode InstrBlock
+
+{-
+Now, given a tree (the argument to a CmmLoad) that references memory,
+produce a suitable addressing mode.
+
+A Rule of the Game (tm) for Amodes: use of the addr bit must
+immediately follow use of the code part, since the code part puts
+values in registers which the addr then refers to.  So you can't put
+anything in between, lest it overwrite some of those registers.  If
+you need to do some other computation between the code part and use of
+the addr bit, first store the effective address from the amode in a
+temporary, then do the other computation, and then use the temporary:
+
+    code
+    LEA amode, tmp
+    ... other computation ...
+    ... (tmp) ...
+-}
+
+
+-- | Check whether an integer will fit in 32 bits.
+--      A CmmInt is intended to be truncated to the appropriate
+--      number of bits, so here we truncate it to Int64.  This is
+--      important because e.g. -1 as a CmmInt might be either
+--      -1 or 18446744073709551615.
+--
+is32BitInteger :: Integer -> Bool
+is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000
+  where i64 = fromIntegral i :: Int64
+
+
+-- | Convert a BlockId to some CmmStatic data
+jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
+jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))
+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
+    where blockLabel = blockLbl blockid
+
+
+-- -----------------------------------------------------------------------------
+-- General things for putting together code sequences
+
+-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
+-- CmmExprs into CmmRegOff?
+mangleIndexTree :: DynFlags -> CmmReg -> Int -> CmmExpr
+mangleIndexTree dflags reg off
+  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
+  where width = typeWidth (cmmRegType dflags reg)
+
+-- | The dual to getAnyReg: compute an expression into a register, but
+--      we don't mind which one it is.
+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
+getSomeReg expr = do
+  r <- getRegister expr
+  case r of
+    Any rep code -> do
+        tmp <- getNewRegNat rep
+        return (tmp, code tmp)
+    Fixed _ reg code ->
+        return (reg, code)
+
+
+assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
+assignMem_I64Code addrTree valueTree = do
+  Amode addr addr_code <- getAmode addrTree
+  ChildCode64 vcode rlo <- iselExpr64 valueTree
+  let
+        rhi = getHiVRegFromLo rlo
+
+        -- Little-endian store
+        mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)
+        mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))
+  return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
+
+
+assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
+assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do
+   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
+   let
+         r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32
+         r_dst_hi = getHiVRegFromLo r_dst_lo
+         r_src_hi = getHiVRegFromLo r_src_lo
+         mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)
+         mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)
+   return (
+        vcode `snocOL` mov_lo `snocOL` mov_hi
+     )
+
+assignReg_I64Code _ _
+   = panic "assignReg_I64Code(i386): invalid lvalue"
+
+
+iselExpr64        :: CmmExpr -> NatM ChildCode64
+iselExpr64 (CmmLit (CmmInt i _)) = do
+  (rlo,rhi) <- getNewRegPairNat II32
+  let
+        r = fromIntegral (fromIntegral i :: Word32)
+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)
+        code = toOL [
+                MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),
+                MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)
+                ]
+  return (ChildCode64 code rlo)
+
+iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do
+   Amode addr addr_code <- getAmode addrTree
+   (rlo,rhi) <- getNewRegPairNat II32
+   let
+        mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)
+        mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)
+   return (
+            ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
+                        rlo
+     )
+
+iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty
+   = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))
+
+-- we handle addition, but rather badly
+iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do
+   ChildCode64 code1 r1lo <- iselExpr64 e1
+   (rlo,rhi) <- getNewRegPairNat II32
+   let
+        r = fromIntegral (fromIntegral i :: Word32)
+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)
+        r1hi = getHiVRegFromLo r1lo
+        code =  code1 `appOL`
+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
+                       ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),
+                       MOV II32 (OpReg r1hi) (OpReg rhi),
+                       ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]
+   return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
+   ChildCode64 code1 r1lo <- iselExpr64 e1
+   ChildCode64 code2 r2lo <- iselExpr64 e2
+   (rlo,rhi) <- getNewRegPairNat II32
+   let
+        r1hi = getHiVRegFromLo r1lo
+        r2hi = getHiVRegFromLo r2lo
+        code =  code1 `appOL`
+                code2 `appOL`
+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
+                       ADD II32 (OpReg r2lo) (OpReg rlo),
+                       MOV II32 (OpReg r1hi) (OpReg rhi),
+                       ADC II32 (OpReg r2hi) (OpReg rhi) ]
+   return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do
+   ChildCode64 code1 r1lo <- iselExpr64 e1
+   ChildCode64 code2 r2lo <- iselExpr64 e2
+   (rlo,rhi) <- getNewRegPairNat II32
+   let
+        r1hi = getHiVRegFromLo r1lo
+        r2hi = getHiVRegFromLo r2lo
+        code =  code1 `appOL`
+                code2 `appOL`
+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),
+                       SUB II32 (OpReg r2lo) (OpReg rlo),
+                       MOV II32 (OpReg r1hi) (OpReg rhi),
+                       SBB II32 (OpReg r2hi) (OpReg rhi) ]
+   return (ChildCode64 code rlo)
+
+iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do
+     fn <- getAnyReg expr
+     r_dst_lo <-  getNewRegNat II32
+     let r_dst_hi = getHiVRegFromLo r_dst_lo
+         code = fn r_dst_lo
+     return (
+             ChildCode64 (code `snocOL`
+                          MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))
+                          r_dst_lo
+            )
+
+iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do
+     fn <- getAnyReg expr
+     r_dst_lo <-  getNewRegNat II32
+     let r_dst_hi = getHiVRegFromLo r_dst_lo
+         code = fn r_dst_lo
+     return (
+             ChildCode64 (code `snocOL`
+                          MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL`
+                          CLTD II32 `snocOL`
+                          MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL`
+                          MOV II32 (OpReg edx) (OpReg r_dst_hi))
+                          r_dst_lo
+            )
+
+iselExpr64 expr
+   = pprPanic "iselExpr64(i386)" (ppr expr)
+
+
+--------------------------------------------------------------------------------
+getRegister :: CmmExpr -> NatM Register
+getRegister e = do dflags <- getDynFlags
+                   is32Bit <- is32BitPlatform
+                   getRegister' dflags is32Bit e
+
+getRegister' :: DynFlags -> Bool -> CmmExpr -> NatM Register
+
+getRegister' dflags is32Bit (CmmReg reg)
+  = case reg of
+        CmmGlobal PicBaseReg
+         | is32Bit ->
+            -- on x86_64, we have %rip for PicBaseReg, but it's not
+            -- a full-featured register, it can only be used for
+            -- rip-relative addressing.
+            do reg' <- getPicBaseNat (archWordFormat is32Bit)
+               return (Fixed (archWordFormat is32Bit) reg' nilOL)
+        _ ->
+            do use_sse2 <- sse2Enabled
+               let
+                 fmt = cmmTypeFormat (cmmRegType dflags reg)
+                 format | not use_sse2 && isFloatFormat fmt = FF80
+                        | otherwise                         = fmt
+               --
+               let platform = targetPlatform dflags
+               return (Fixed format
+                             (getRegisterReg platform use_sse2 reg)
+                             nilOL)
+
+
+getRegister' dflags is32Bit (CmmRegOff r n)
+  = getRegister' dflags is32Bit $ mangleIndexTree dflags r n
+
+getRegister' dflags is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])
+  = addAlignmentCheck align <$> getRegister' dflags is32Bit e
+
+-- for 32-bit architectuers, support some 64 -> 32 bit conversions:
+-- TO_W_(x), TO_W_(x >> 32)
+
+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)
+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
+ | is32Bit = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32)
+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
+ | is32Bit = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 (getHiVRegFromLo rlo) code
+
+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])
+ | is32Bit = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code
+
+getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])
+ | is32Bit = do
+  ChildCode64 code rlo <- iselExpr64 x
+  return $ Fixed II32 rlo code
+
+getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =
+  if_sse2 float_const_sse2 float_const_x87
+ where
+  float_const_sse2
+    | f == 0.0 = do
+      let
+          format = floatFormat w
+          code dst = unitOL  (XOR format (OpReg dst) (OpReg dst))
+        -- I don't know why there are xorpd, xorps, and pxor instructions.
+        -- They all appear to do the same thing --SDM
+      return (Any format code)
+
+   | otherwise = do
+      Amode addr code <- memConstant (widthInBytes w) lit
+      loadFloatAmode True w addr code
+
+  float_const_x87 = case w of
+    W64
+      | f == 0.0 ->
+        let code dst = unitOL (GLDZ dst)
+        in  return (Any FF80 code)
+
+      | f == 1.0 ->
+        let code dst = unitOL (GLD1 dst)
+        in  return (Any FF80 code)
+
+    _otherwise -> do
+      Amode addr code <- memConstant (widthInBytes w) lit
+      loadFloatAmode False w addr code
+
+-- catch simple cases of zero- or sign-extended load
+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do
+  code <- intLoadCode (MOVZxL II8) addr
+  return (Any II32 code)
+
+getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do
+  code <- intLoadCode (MOVSxL II8) addr
+  return (Any II32 code)
+
+getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do
+  code <- intLoadCode (MOVZxL II16) addr
+  return (Any II32 code)
+
+getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do
+  code <- intLoadCode (MOVSxL II16) addr
+  return (Any II32 code)
+
+-- catch simple cases of zero- or sign-extended load
+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _])
+ | not is32Bit = do
+  code <- intLoadCode (MOVZxL II8) addr
+  return (Any II64 code)
+
+getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _])
+ | not is32Bit = do
+  code <- intLoadCode (MOVSxL II8) addr
+  return (Any II64 code)
+
+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _])
+ | not is32Bit = do
+  code <- intLoadCode (MOVZxL II16) addr
+  return (Any II64 code)
+
+getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _])
+ | not is32Bit = do
+  code <- intLoadCode (MOVSxL II16) addr
+  return (Any II64 code)
+
+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _])
+ | not is32Bit = do
+  code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend
+  return (Any II64 code)
+
+getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _])
+ | not is32Bit = do
+  code <- intLoadCode (MOVSxL II32) addr
+  return (Any II64 code)
+
+getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),
+                                     CmmLit displacement])
+ | not is32Bit = do
+      return $ Any II64 (\dst -> unitOL $
+        LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))
+
+getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps
+    sse2 <- sse2Enabled
+    case mop of
+      MO_F_Neg w
+         | sse2      -> sse2NegCode w x
+         | otherwise -> trivialUFCode FF80 (GNEG FF80) x
+
+      MO_S_Neg w -> triv_ucode NEGI (intFormat w)
+      MO_Not w   -> triv_ucode NOT  (intFormat w)
+
+      -- Nop conversions
+      MO_UU_Conv W32 W8  -> toI8Reg  W32 x
+      MO_SS_Conv W32 W8  -> toI8Reg  W32 x
+      MO_XX_Conv W32 W8  -> toI8Reg  W32 x
+      MO_UU_Conv W16 W8  -> toI8Reg  W16 x
+      MO_SS_Conv W16 W8  -> toI8Reg  W16 x
+      MO_XX_Conv W16 W8  -> toI8Reg  W16 x
+      MO_UU_Conv W32 W16 -> toI16Reg W32 x
+      MO_SS_Conv W32 W16 -> toI16Reg W32 x
+      MO_XX_Conv W32 W16 -> toI16Reg W32 x
+
+      MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x
+      MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x
+      MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x
+      MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x
+      MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x
+      MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x
+      MO_UU_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x
+      MO_SS_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x
+      MO_XX_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x
+
+      MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x
+      MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x
+      MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x
+
+      -- widenings
+      MO_UU_Conv W8  W32 -> integerExtend W8  W32 MOVZxL x
+      MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x
+      MO_UU_Conv W8  W16 -> integerExtend W8  W16 MOVZxL x
+
+      MO_SS_Conv W8  W32 -> integerExtend W8  W32 MOVSxL x
+      MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x
+      MO_SS_Conv W8  W16 -> integerExtend W8  W16 MOVSxL x
+
+      -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we
+      -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register
+      -- has 8-bit version). So for 32-bit code, we'll just zero-extend.
+      MO_XX_Conv W8  W32
+          | is32Bit   -> integerExtend W8 W32 MOVZxL x
+          | otherwise -> integerExtend W8 W32 MOV x
+      MO_XX_Conv W8  W16
+          | is32Bit   -> integerExtend W8 W16 MOVZxL x
+          | otherwise -> integerExtend W8 W16 MOV x
+      MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x
+
+      MO_UU_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVZxL x
+      MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x
+      MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x
+      MO_SS_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVSxL x
+      MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x
+      MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x
+      -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.
+      -- However, we don't want the register allocator to throw it
+      -- away as an unnecessary reg-to-reg move, so we keep it in
+      -- the form of a movzl and print it as a movl later.
+      -- This doesn't apply to MO_XX_Conv since in this case we don't care about
+      -- the upper bits. So we can just use MOV.
+      MO_XX_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOV x
+      MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x
+      MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x
+
+      MO_FF_Conv W32 W64
+        | sse2      -> coerceFP2FP W64 x
+        | otherwise -> conversionNop FF80 x
+
+      MO_FF_Conv W64 W32 -> coerceFP2FP W32 x
+
+      MO_FS_Conv from to -> coerceFP2Int from to x
+      MO_SF_Conv from to -> coerceInt2FP from to x
+
+      MO_V_Insert {}   -> needLlvm
+      MO_V_Extract {}  -> needLlvm
+      MO_V_Add {}      -> needLlvm
+      MO_V_Sub {}      -> needLlvm
+      MO_V_Mul {}      -> needLlvm
+      MO_VS_Quot {}    -> needLlvm
+      MO_VS_Rem {}     -> needLlvm
+      MO_VS_Neg {}     -> needLlvm
+      MO_VU_Quot {}    -> needLlvm
+      MO_VU_Rem {}     -> needLlvm
+      MO_VF_Insert {}  -> needLlvm
+      MO_VF_Extract {} -> needLlvm
+      MO_VF_Add {}     -> needLlvm
+      MO_VF_Sub {}     -> needLlvm
+      MO_VF_Mul {}     -> needLlvm
+      MO_VF_Quot {}    -> needLlvm
+      MO_VF_Neg {}     -> needLlvm
+
+      _other -> pprPanic "getRegister" (pprMachOp mop)
+   where
+        triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register
+        triv_ucode instr format = trivialUCode format (instr format) x
+
+        -- signed or unsigned extension.
+        integerExtend :: Width -> Width
+                      -> (Format -> Operand -> Operand -> Instr)
+                      -> CmmExpr -> NatM Register
+        integerExtend from to instr expr = do
+            (reg,e_code) <- if from == W8 then getByteReg expr
+                                          else getSomeReg expr
+            let
+                code dst =
+                  e_code `snocOL`
+                  instr (intFormat from) (OpReg reg) (OpReg dst)
+            return (Any (intFormat to) code)
+
+        toI8Reg :: Width -> CmmExpr -> NatM Register
+        toI8Reg new_rep expr
+            = do codefn <- getAnyReg expr
+                 return (Any (intFormat new_rep) codefn)
+                -- HACK: use getAnyReg to get a byte-addressable register.
+                -- If the source was a Fixed register, this will add the
+                -- mov instruction to put it into the desired destination.
+                -- We're assuming that the destination won't be a fixed
+                -- non-byte-addressable register; it won't be, because all
+                -- fixed registers are word-sized.
+
+        toI16Reg = toI8Reg -- for now
+
+        conversionNop :: Format -> CmmExpr -> NatM Register
+        conversionNop new_format expr
+            = do e_code <- getRegister' dflags is32Bit expr
+                 return (swizzleRegisterRep e_code new_format)
+
+
+getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps
+  sse2 <- sse2Enabled
+  case mop of
+      MO_F_Eq _ -> condFltReg is32Bit EQQ x y
+      MO_F_Ne _ -> condFltReg is32Bit NE  x y
+      MO_F_Gt _ -> condFltReg is32Bit GTT x y
+      MO_F_Ge _ -> condFltReg is32Bit GE  x y
+      -- Invert comparison condition and swap operands
+      -- See Note [SSE Parity Checks]
+      MO_F_Lt _ -> condFltReg is32Bit GTT  y x
+      MO_F_Le _ -> condFltReg is32Bit GE   y x
+
+      MO_Eq _   -> condIntReg EQQ x y
+      MO_Ne _   -> condIntReg NE  x y
+
+      MO_S_Gt _ -> condIntReg GTT x y
+      MO_S_Ge _ -> condIntReg GE  x y
+      MO_S_Lt _ -> condIntReg LTT x y
+      MO_S_Le _ -> condIntReg LE  x y
+
+      MO_U_Gt _ -> condIntReg GU  x y
+      MO_U_Ge _ -> condIntReg GEU x y
+      MO_U_Lt _ -> condIntReg LU  x y
+      MO_U_Le _ -> condIntReg LEU x y
+
+      MO_F_Add w  | sse2      -> trivialFCode_sse2 w ADD  x y
+                  | otherwise -> trivialFCode_x87    GADD x y
+      MO_F_Sub w  | sse2      -> trivialFCode_sse2 w SUB  x y
+                  | otherwise -> trivialFCode_x87    GSUB x y
+      MO_F_Quot w | sse2      -> trivialFCode_sse2 w FDIV x y
+                  | otherwise -> trivialFCode_x87    GDIV x y
+      MO_F_Mul w  | sse2      -> trivialFCode_sse2 w MUL x y
+                  | otherwise -> trivialFCode_x87    GMUL x y
+
+      MO_Add rep -> add_code rep x y
+      MO_Sub rep -> sub_code rep x y
+
+      MO_S_Quot rep -> div_code rep True  True  x y
+      MO_S_Rem  rep -> div_code rep True  False x y
+      MO_U_Quot rep -> div_code rep False True  x y
+      MO_U_Rem  rep -> div_code rep False False x y
+
+      MO_S_MulMayOflo rep -> imulMayOflo rep x y
+
+      MO_Mul W8  -> imulW8 x y
+      MO_Mul rep -> triv_op rep IMUL
+      MO_And rep -> triv_op rep AND
+      MO_Or  rep -> triv_op rep OR
+      MO_Xor rep -> triv_op rep XOR
+
+        {- Shift ops on x86s have constraints on their source, it
+           either has to be Imm, CL or 1
+            => trivialCode is not restrictive enough (sigh.)
+        -}
+      MO_Shl rep   -> shift_code rep SHL x y {-False-}
+      MO_U_Shr rep -> shift_code rep SHR x y {-False-}
+      MO_S_Shr rep -> shift_code rep SAR x y {-False-}
+
+      MO_V_Insert {}   -> needLlvm
+      MO_V_Extract {}  -> needLlvm
+      MO_V_Add {}      -> needLlvm
+      MO_V_Sub {}      -> needLlvm
+      MO_V_Mul {}      -> needLlvm
+      MO_VS_Quot {}    -> needLlvm
+      MO_VS_Rem {}     -> needLlvm
+      MO_VS_Neg {}     -> needLlvm
+      MO_VF_Insert {}  -> needLlvm
+      MO_VF_Extract {} -> needLlvm
+      MO_VF_Add {}     -> needLlvm
+      MO_VF_Sub {}     -> needLlvm
+      MO_VF_Mul {}     -> needLlvm
+      MO_VF_Quot {}    -> needLlvm
+      MO_VF_Neg {}     -> needLlvm
+
+      _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)
+  where
+    --------------------
+    triv_op width instr = trivialCode width op (Just op) x y
+                        where op   = instr (intFormat width)
+
+    -- Special case for IMUL for bytes, since the result of IMULB will be in
+    -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider
+    -- values.
+    imulW8 :: CmmExpr -> CmmExpr -> NatM Register
+    imulW8 arg_a arg_b = do
+        (a_reg, a_code) <- getNonClobberedReg arg_a
+        b_code <- getAnyReg arg_b
+
+        let code = a_code `appOL` b_code eax `appOL`
+                   toOL [ IMUL2 format (OpReg a_reg) ]
+            format = intFormat W8
+
+        return (Fixed format eax code)
+
+
+    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
+    imulMayOflo rep a b = do
+         (a_reg, a_code) <- getNonClobberedReg a
+         b_code <- getAnyReg b
+         let
+             shift_amt  = case rep of
+                           W32 -> 31
+                           W64 -> 63
+                           _ -> panic "shift_amt"
+
+             format = intFormat rep
+             code = a_code `appOL` b_code eax `appOL`
+                        toOL [
+                           IMUL2 format (OpReg a_reg),   -- result in %edx:%eax
+                           SAR format (OpImm (ImmInt shift_amt)) (OpReg eax),
+                                -- sign extend lower part
+                           SUB format (OpReg edx) (OpReg eax)
+                                -- compare against upper
+                           -- eax==0 if high part == sign extended low part
+                        ]
+         return (Fixed format eax code)
+
+    --------------------
+    shift_code :: Width
+               -> (Format -> Operand -> Operand -> Instr)
+               -> CmmExpr
+               -> CmmExpr
+               -> NatM Register
+
+    {- Case1: shift length as immediate -}
+    shift_code width instr x (CmmLit lit) = do
+          x_code <- getAnyReg x
+          let
+               format = intFormat width
+               code dst
+                  = x_code dst `snocOL`
+                    instr format (OpImm (litToImm lit)) (OpReg dst)
+          return (Any format code)
+
+    {- Case2: shift length is complex (non-immediate)
+      * y must go in %ecx.
+      * we cannot do y first *and* put its result in %ecx, because
+        %ecx might be clobbered by x.
+      * if we do y second, then x cannot be
+        in a clobbered reg.  Also, we cannot clobber x's reg
+        with the instruction itself.
+      * so we can either:
+        - do y first, put its result in a fresh tmp, then copy it to %ecx later
+        - do y second and put its result into %ecx.  x gets placed in a fresh
+          tmp.  This is likely to be better, because the reg alloc can
+          eliminate this reg->reg move here (it won't eliminate the other one,
+          because the move is into the fixed %ecx).
+    -}
+    shift_code width instr x y{-amount-} = do
+        x_code <- getAnyReg x
+        let format = intFormat width
+        tmp <- getNewRegNat format
+        y_code <- getAnyReg y
+        let
+           code = x_code tmp `appOL`
+                  y_code ecx `snocOL`
+                  instr format (OpReg ecx) (OpReg tmp)
+        return (Fixed format tmp code)
+
+    --------------------
+    add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
+    add_code rep x (CmmLit (CmmInt y _))
+        | is32BitInteger y = add_int rep x y
+    add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y
+      where format = intFormat rep
+    -- TODO: There are other interesting patterns we want to replace
+    --     with a LEA, e.g. `(x + offset) + (y << shift)`.
+
+    --------------------
+    sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
+    sub_code rep x (CmmLit (CmmInt y _))
+        | is32BitInteger (-y) = add_int rep x (-y)
+    sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y
+
+    -- our three-operand add instruction:
+    add_int width x y = do
+        (x_reg, x_code) <- getSomeReg x
+        let
+            format = intFormat width
+            imm = ImmInt (fromInteger y)
+            code dst
+               = x_code `snocOL`
+                 LEA format
+                        (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))
+                        (OpReg dst)
+        --
+        return (Any format code)
+
+    ----------------------
+
+    -- See Note [DIV/IDIV for bytes]
+    div_code W8 signed quotient x y = do
+        let widen | signed    = MO_SS_Conv W8 W16
+                  | otherwise = MO_UU_Conv W8 W16
+        div_code
+            W16
+            signed
+            quotient
+            (CmmMachOp widen [x])
+            (CmmMachOp widen [y])
+
+    div_code width signed quotient x y = do
+           (y_op, y_code) <- getRegOrMem y -- cannot be clobbered
+           x_code <- getAnyReg x
+           let
+             format = intFormat width
+             widen | signed    = CLTD format
+                   | otherwise = XOR format (OpReg edx) (OpReg edx)
+
+             instr | signed    = IDIV
+                   | otherwise = DIV
+
+             code = y_code `appOL`
+                    x_code eax `appOL`
+                    toOL [widen, instr format y_op]
+
+             result | quotient  = eax
+                    | otherwise = edx
+
+           return (Fixed format result code)
+
+
+getRegister' _ _ (CmmLoad mem pk)
+  | isFloatType pk
+  = do
+    Amode addr mem_code <- getAmode mem
+    use_sse2 <- sse2Enabled
+    loadFloatAmode use_sse2 (typeWidth pk) addr mem_code
+
+getRegister' _ is32Bit (CmmLoad mem pk)
+  | is32Bit && not (isWord64 pk)
+  = do
+    code <- intLoadCode instr mem
+    return (Any format code)
+  where
+    width = typeWidth pk
+    format = intFormat width
+    instr = case width of
+                W8     -> MOVZxL II8
+                _other -> MOV format
+        -- We always zero-extend 8-bit loads, if we
+        -- can't think of anything better.  This is because
+        -- we can't guarantee access to an 8-bit variant of every register
+        -- (esi and edi don't have 8-bit variants), so to make things
+        -- simpler we do our 8-bit arithmetic with full 32-bit registers.
+
+-- Simpler memory load code on x86_64
+getRegister' _ is32Bit (CmmLoad mem pk)
+ | not is32Bit
+  = do
+    code <- intLoadCode (MOV format) mem
+    return (Any format code)
+  where format = intFormat $ typeWidth pk
+
+getRegister' _ is32Bit (CmmLit (CmmInt 0 width))
+  = let
+        format = intFormat width
+
+        -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits
+        format1 = if is32Bit then format
+                           else case format of
+                                II64 -> II32
+                                _ -> format
+        code dst
+           = unitOL (XOR format1 (OpReg dst) (OpReg dst))
+    in
+        return (Any format code)
+
+  -- optimisation for loading small literals on x86_64: take advantage
+  -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit
+  -- instruction forms are shorter.
+getRegister' dflags is32Bit (CmmLit lit)
+  | not is32Bit, isWord64 (cmmLitType dflags lit), not (isBigLit lit)
+  = let
+        imm = litToImm lit
+        code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))
+    in
+        return (Any II64 code)
+  where
+   isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff
+   isBigLit _ = False
+        -- note1: not the same as (not.is32BitLit), because that checks for
+        -- signed literals that fit in 32 bits, but we want unsigned
+        -- literals here.
+        -- note2: all labels are small, because we're assuming the
+        -- small memory model (see gcc docs, -mcmodel=small).
+
+getRegister' dflags _ (CmmLit lit)
+  = do let format = cmmTypeFormat (cmmLitType dflags lit)
+           imm = litToImm lit
+           code dst = unitOL (MOV format (OpImm imm) (OpReg dst))
+       return (Any format code)
+
+getRegister' _ _ other
+    | isVecExpr other  = needLlvm
+    | otherwise        = pprPanic "getRegister(x86)" (ppr other)
+
+
+intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr
+   -> NatM (Reg -> InstrBlock)
+intLoadCode instr mem = do
+  Amode src mem_code <- getAmode mem
+  return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))
+
+-- Compute an expression into *any* register, adding the appropriate
+-- move instruction if necessary.
+getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)
+getAnyReg expr = do
+  r <- getRegister expr
+  anyReg r
+
+anyReg :: Register -> NatM (Reg -> InstrBlock)
+anyReg (Any _ code)          = return code
+anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)
+
+-- A bit like getSomeReg, but we want a reg that can be byte-addressed.
+-- Fixed registers might not be byte-addressable, so we make sure we've
+-- got a temporary, inserting an extra reg copy if necessary.
+getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)
+getByteReg expr = do
+  is32Bit <- is32BitPlatform
+  if is32Bit
+      then do r <- getRegister expr
+              case r of
+                Any rep code -> do
+                    tmp <- getNewRegNat rep
+                    return (tmp, code tmp)
+                Fixed rep reg code
+                    | isVirtualReg reg -> return (reg,code)
+                    | otherwise -> do
+                        tmp <- getNewRegNat rep
+                        return (tmp, code `snocOL` reg2reg rep reg tmp)
+                    -- ToDo: could optimise slightly by checking for
+                    -- byte-addressable real registers, but that will
+                    -- happen very rarely if at all.
+      else getSomeReg expr -- all regs are byte-addressable on x86_64
+
+-- Another variant: this time we want the result in a register that cannot
+-- be modified by code to evaluate an arbitrary expression.
+getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)
+getNonClobberedReg expr = do
+  dflags <- getDynFlags
+  r <- getRegister expr
+  case r of
+    Any rep code -> do
+        tmp <- getNewRegNat rep
+        return (tmp, code tmp)
+    Fixed rep reg code
+        -- only certain regs can be clobbered
+        | reg `elem` instrClobberedRegs (targetPlatform dflags)
+        -> do
+                tmp <- getNewRegNat rep
+                return (tmp, code `snocOL` reg2reg rep reg tmp)
+        | otherwise ->
+                return (reg, code)
+
+reg2reg :: Format -> Reg -> Reg -> Instr
+reg2reg format src dst
+  | format == FF80 = GMOV src dst
+  | otherwise    = MOV format (OpReg src) (OpReg dst)
+
+
+--------------------------------------------------------------------------------
+getAmode :: CmmExpr -> NatM Amode
+getAmode e = do is32Bit <- is32BitPlatform
+                getAmode' is32Bit e
+
+getAmode' :: Bool -> CmmExpr -> NatM Amode
+getAmode' _ (CmmRegOff r n) = do dflags <- getDynFlags
+                                 getAmode $ mangleIndexTree dflags r n
+
+getAmode' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),
+                                                  CmmLit displacement])
+ | not is32Bit
+    = return $ Amode (ripRel (litToImm displacement)) nilOL
+
+
+-- This is all just ridiculous, since it carefully undoes
+-- what mangleIndexTree has just done.
+getAmode' is32Bit (CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)])
+  | is32BitLit is32Bit lit
+  -- ASSERT(rep == II32)???
+  = do (x_reg, x_code) <- getSomeReg x
+       let off = ImmInt (-(fromInteger i))
+       return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)
+
+getAmode' is32Bit (CmmMachOp (MO_Add _rep) [x, CmmLit lit])
+  | is32BitLit is32Bit lit
+  -- ASSERT(rep == II32)???
+  = do (x_reg, x_code) <- getSomeReg x
+       let off = litToImm lit
+       return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)
+
+-- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be
+-- recognised by the next rule.
+getAmode' is32Bit (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _),
+                                  b@(CmmLit _)])
+  = getAmode' is32Bit (CmmMachOp (MO_Add rep) [b,a])
+
+-- Matches: (x + offset) + (y << shift)
+getAmode' _ (CmmMachOp (MO_Add _) [CmmRegOff x offset,
+                                   CmmMachOp (MO_Shl _)
+                                        [y, CmmLit (CmmInt shift _)]])
+  | shift == 0 || shift == 1 || shift == 2 || shift == 3
+  = x86_complex_amode (CmmReg x) y shift (fromIntegral offset)
+
+getAmode' _ (CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _)
+                                        [y, CmmLit (CmmInt shift _)]])
+  | shift == 0 || shift == 1 || shift == 2 || shift == 3
+  = x86_complex_amode x y shift 0
+
+getAmode' _ (CmmMachOp (MO_Add _)
+                [x, CmmMachOp (MO_Add _)
+                        [CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)],
+                         CmmLit (CmmInt offset _)]])
+  | shift == 0 || shift == 1 || shift == 2 || shift == 3
+  && is32BitInteger offset
+  = x86_complex_amode x y shift offset
+
+getAmode' _ (CmmMachOp (MO_Add _) [x,y])
+  = x86_complex_amode x y 0 0
+
+getAmode' is32Bit (CmmLit lit) | is32BitLit is32Bit lit
+  = return (Amode (ImmAddr (litToImm lit) 0) nilOL)
+
+getAmode' _ expr = do
+  (reg,code) <- getSomeReg expr
+  return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)
+
+-- | Like 'getAmode', but on 32-bit use simple register addressing
+-- (i.e. no index register). This stops us from running out of
+-- registers on x86 when using instructions such as cmpxchg, which can
+-- use up to three virtual registers and one fixed register.
+getSimpleAmode :: DynFlags -> Bool -> CmmExpr -> NatM Amode
+getSimpleAmode dflags is32Bit addr
+    | is32Bit = do
+        addr_code <- getAnyReg addr
+        addr_r <- getNewRegNat (intFormat (wordWidth dflags))
+        let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0)
+        return $! Amode amode (addr_code addr_r)
+    | otherwise = getAmode addr
+
+x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode
+x86_complex_amode base index shift offset
+  = do (x_reg, x_code) <- getNonClobberedReg base
+        -- x must be in a temp, because it has to stay live over y_code
+        -- we could compre x_reg and y_reg and do something better here...
+       (y_reg, y_code) <- getSomeReg index
+       let
+           code = x_code `appOL` y_code
+           base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;
+                                n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"
+       return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))
+               code)
+
+
+
+
+-- -----------------------------------------------------------------------------
+-- getOperand: sometimes any operand will do.
+
+-- getNonClobberedOperand: the value of the operand will remain valid across
+-- the computation of an arbitrary expression, unless the expression
+-- is computed directly into a register which the operand refers to
+-- (see trivialCode where this function is used for an example).
+
+getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)
+getNonClobberedOperand (CmmLit lit) = do
+  use_sse2 <- sse2Enabled
+  if use_sse2 && isSuitableFloatingPointLit lit
+    then do
+      let CmmFloat _ w = lit
+      Amode addr code <- memConstant (widthInBytes w) lit
+      return (OpAddr addr, code)
+     else do
+
+  is32Bit <- is32BitPlatform
+  dflags <- getDynFlags
+  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit))
+    then return (OpImm (litToImm lit), nilOL)
+    else getNonClobberedOperand_generic (CmmLit lit)
+
+getNonClobberedOperand (CmmLoad mem pk) = do
+  is32Bit <- is32BitPlatform
+  use_sse2 <- sse2Enabled
+  if (not (isFloatType pk) || use_sse2)
+      && (if is32Bit then not (isWord64 pk) else True)
+    then do
+      dflags <- getDynFlags
+      let platform = targetPlatform dflags
+      Amode src mem_code <- getAmode mem
+      (src',save_code) <-
+        if (amodeCouldBeClobbered platform src)
+                then do
+                   tmp <- getNewRegNat (archWordFormat is32Bit)
+                   return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),
+                           unitOL (LEA (archWordFormat is32Bit)
+                                       (OpAddr src)
+                                       (OpReg tmp)))
+                else
+                   return (src, nilOL)
+      return (OpAddr src', mem_code `appOL` save_code)
+    else do
+      getNonClobberedOperand_generic (CmmLoad mem pk)
+
+getNonClobberedOperand e = getNonClobberedOperand_generic e
+
+getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)
+getNonClobberedOperand_generic e = do
+    (reg, code) <- getNonClobberedReg e
+    return (OpReg reg, code)
+
+amodeCouldBeClobbered :: Platform -> AddrMode -> Bool
+amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)
+
+regClobbered :: Platform -> Reg -> Bool
+regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr
+regClobbered _ _ = False
+
+-- getOperand: the operand is not required to remain valid across the
+-- computation of an arbitrary expression.
+getOperand :: CmmExpr -> NatM (Operand, InstrBlock)
+
+getOperand (CmmLit lit) = do
+  use_sse2 <- sse2Enabled
+  if (use_sse2 && isSuitableFloatingPointLit lit)
+    then do
+      let CmmFloat _ w = lit
+      Amode addr code <- memConstant (widthInBytes w) lit
+      return (OpAddr addr, code)
+    else do
+
+  is32Bit <- is32BitPlatform
+  dflags <- getDynFlags
+  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit))
+    then return (OpImm (litToImm lit), nilOL)
+    else getOperand_generic (CmmLit lit)
+
+getOperand (CmmLoad mem pk) = do
+  is32Bit <- is32BitPlatform
+  use_sse2 <- sse2Enabled
+  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)
+     then do
+       Amode src mem_code <- getAmode mem
+       return (OpAddr src, mem_code)
+     else
+       getOperand_generic (CmmLoad mem pk)
+
+getOperand e = getOperand_generic e
+
+getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)
+getOperand_generic e = do
+    (reg, code) <- getSomeReg e
+    return (OpReg reg, code)
+
+isOperand :: Bool -> CmmExpr -> Bool
+isOperand _ (CmmLoad _ _) = True
+isOperand is32Bit (CmmLit lit)  = is32BitLit is32Bit lit
+                          || isSuitableFloatingPointLit lit
+isOperand _ _            = False
+
+-- | Given a 'Register', produce a new 'Register' with an instruction block
+-- which will check the value for alignment. Used for @-falignment-sanitisation@.
+addAlignmentCheck :: Int -> Register -> Register
+addAlignmentCheck align reg =
+    case reg of
+      Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)
+      Any fmt f          -> Any fmt (\reg -> f reg `appOL` check fmt reg)
+  where
+    check :: Format -> Reg -> InstrBlock
+    check fmt reg =
+        ASSERT(not $ isFloatFormat fmt)
+        toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)
+             , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel
+             ]
+
+memConstant :: Int -> CmmLit -> NatM Amode
+memConstant align lit = do
+  lbl <- getNewLabelNat
+  let rosection = Section ReadOnlyData lbl
+  dflags <- getDynFlags
+  (addr, addr_code) <- if target32Bit (targetPlatform dflags)
+                       then do dynRef <- cmmMakeDynamicReference
+                                             dflags
+                                             DataReference
+                                             lbl
+                               Amode addr addr_code <- getAmode dynRef
+                               return (addr, addr_code)
+                       else return (ripRel (ImmCLbl lbl), nilOL)
+  let code =
+        LDATA rosection (align, Statics lbl [CmmStaticLit lit])
+        `consOL` addr_code
+  return (Amode addr code)
+
+
+loadFloatAmode :: Bool -> Width -> AddrMode -> InstrBlock -> NatM Register
+loadFloatAmode use_sse2 w addr addr_code = do
+  let format = floatFormat w
+      code dst = addr_code `snocOL`
+                 if use_sse2
+                    then MOV format (OpAddr addr) (OpReg dst)
+                    else GLD format addr dst
+  return (Any (if use_sse2 then format else FF80) code)
+
+
+-- if we want a floating-point literal as an operand, we can
+-- use it directly from memory.  However, if the literal is
+-- zero, we're better off generating it into a register using
+-- xor.
+isSuitableFloatingPointLit :: CmmLit -> Bool
+isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0
+isSuitableFloatingPointLit _ = False
+
+getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)
+getRegOrMem e@(CmmLoad mem pk) = do
+  is32Bit <- is32BitPlatform
+  use_sse2 <- sse2Enabled
+  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)
+     then do
+       Amode src mem_code <- getAmode mem
+       return (OpAddr src, mem_code)
+     else do
+       (reg, code) <- getNonClobberedReg e
+       return (OpReg reg, code)
+getRegOrMem e = do
+    (reg, code) <- getNonClobberedReg e
+    return (OpReg reg, code)
+
+is32BitLit :: Bool -> CmmLit -> Bool
+is32BitLit is32Bit (CmmInt i W64)
+ | not is32Bit
+    = -- assume that labels are in the range 0-2^31-1: this assumes the
+      -- small memory model (see gcc docs, -mcmodel=small).
+      is32BitInteger i
+is32BitLit _ _ = True
+
+
+
+
+-- Set up a condition code for a conditional branch.
+
+getCondCode :: CmmExpr -> NatM CondCode
+
+-- yes, they really do seem to want exactly the same!
+
+getCondCode (CmmMachOp mop [x, y])
+  =
+    case mop of
+      MO_F_Eq W32 -> condFltCode EQQ x y
+      MO_F_Ne W32 -> condFltCode NE  x y
+      MO_F_Gt W32 -> condFltCode GTT x y
+      MO_F_Ge W32 -> condFltCode GE  x y
+      -- Invert comparison condition and swap operands
+      -- See Note [SSE Parity Checks]
+      MO_F_Lt W32 -> condFltCode GTT  y x
+      MO_F_Le W32 -> condFltCode GE   y x
+
+      MO_F_Eq W64 -> condFltCode EQQ x y
+      MO_F_Ne W64 -> condFltCode NE  x y
+      MO_F_Gt W64 -> condFltCode GTT x y
+      MO_F_Ge W64 -> condFltCode GE  x y
+      MO_F_Lt W64 -> condFltCode GTT y x
+      MO_F_Le W64 -> condFltCode GE  y x
+
+      _ -> condIntCode (machOpToCond mop) x y
+
+getCondCode other = pprPanic "getCondCode(2)(x86,x86_64)" (ppr other)
+
+machOpToCond :: MachOp -> Cond
+machOpToCond mo = case mo of
+  MO_Eq _   -> EQQ
+  MO_Ne _   -> NE
+  MO_S_Gt _ -> GTT
+  MO_S_Ge _ -> GE
+  MO_S_Lt _ -> LTT
+  MO_S_Le _ -> LE
+  MO_U_Gt _ -> GU
+  MO_U_Ge _ -> GEU
+  MO_U_Lt _ -> LU
+  MO_U_Le _ -> LEU
+  _other -> pprPanic "machOpToCond" (pprMachOp mo)
+
+
+-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
+-- passed back up the tree.
+
+condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
+condIntCode cond x y = do is32Bit <- is32BitPlatform
+                          condIntCode' is32Bit cond x y
+
+condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
+
+-- memory vs immediate
+condIntCode' is32Bit cond (CmmLoad x pk) (CmmLit lit)
+ | is32BitLit is32Bit lit = do
+    Amode x_addr x_code <- getAmode x
+    let
+        imm  = litToImm lit
+        code = x_code `snocOL`
+                  CMP (cmmTypeFormat pk) (OpImm imm) (OpAddr x_addr)
+    --
+    return (CondCode False cond code)
+
+-- anything vs zero, using a mask
+-- TODO: Add some sanity checking!!!!
+condIntCode' is32Bit cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))
+    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit is32Bit lit
+    = do
+      (x_reg, x_code) <- getSomeReg x
+      let
+         code = x_code `snocOL`
+                TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg)
+      --
+      return (CondCode False cond code)
+
+-- anything vs zero
+condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do
+    (x_reg, x_code) <- getSomeReg x
+    let
+        code = x_code `snocOL`
+                  TEST (intFormat pk) (OpReg x_reg) (OpReg x_reg)
+    --
+    return (CondCode False cond code)
+
+-- anything vs operand
+condIntCode' is32Bit cond x y
+ | isOperand is32Bit y = do
+    dflags <- getDynFlags
+    (x_reg, x_code) <- getNonClobberedReg x
+    (y_op,  y_code) <- getOperand y
+    let
+        code = x_code `appOL` y_code `snocOL`
+                  CMP (cmmTypeFormat (cmmExprType dflags x)) y_op (OpReg x_reg)
+    return (CondCode False cond code)
+-- operand vs. anything: invert the comparison so that we can use a
+-- single comparison instruction.
+ | isOperand is32Bit x
+ , Just revcond <- maybeFlipCond cond = do
+    dflags <- getDynFlags
+    (y_reg, y_code) <- getNonClobberedReg y
+    (x_op,  x_code) <- getOperand x
+    let
+        code = y_code `appOL` x_code `snocOL`
+                  CMP (cmmTypeFormat (cmmExprType dflags x)) x_op (OpReg y_reg)
+    return (CondCode False revcond code)
+
+-- anything vs anything
+condIntCode' _ cond x y = do
+  dflags <- getDynFlags
+  (y_reg, y_code) <- getNonClobberedReg y
+  (x_op, x_code) <- getRegOrMem x
+  let
+        code = y_code `appOL`
+               x_code `snocOL`
+                  CMP (cmmTypeFormat (cmmExprType dflags x)) (OpReg y_reg) x_op
+  return (CondCode False cond code)
+
+
+
+--------------------------------------------------------------------------------
+condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
+
+condFltCode cond x y
+  = if_sse2 condFltCode_sse2 condFltCode_x87
+  where
+
+  condFltCode_x87
+    = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) do
+    (x_reg, x_code) <- getNonClobberedReg x
+    (y_reg, y_code) <- getSomeReg y
+    let
+        code = x_code `appOL` y_code `snocOL`
+                GCMP cond x_reg y_reg
+    -- The GCMP insn does the test and sets the zero flag if comparable
+    -- and true.  Hence we always supply EQQ as the condition to test.
+    return (CondCode True EQQ code)
+
+  -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be
+  -- an operand, but the right must be a reg.  We can probably do better
+  -- than this general case...
+  condFltCode_sse2 = do
+    dflags <- getDynFlags
+    (x_reg, x_code) <- getNonClobberedReg x
+    (y_op, y_code) <- getOperand y
+    let
+        code = x_code `appOL`
+               y_code `snocOL`
+                  CMP (floatFormat $ cmmExprWidth dflags x) y_op (OpReg x_reg)
+        -- NB(1): we need to use the unsigned comparison operators on the
+        -- result of this comparison.
+    return (CondCode True (condToUnsigned cond) code)
+
+-- -----------------------------------------------------------------------------
+-- Generating assignments
+
+-- Assignments are really at the heart of the whole code generation
+-- business.  Almost all top-level nodes of any real importance are
+-- assignments, which correspond to loads, stores, or register
+-- transfers.  If we're really lucky, some of the register transfers
+-- will go away, because we can use the destination register to
+-- complete the code generation for the right hand side.  This only
+-- fails when the right hand side is forced into a fixed register
+-- (e.g. the result of a call).
+
+assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
+
+assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock
+
+
+-- integer assignment to memory
+
+-- specific case of adding/subtracting an integer to a particular address.
+-- ToDo: catch other cases where we can use an operation directly on a memory
+-- address.
+assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _,
+                                                 CmmLit (CmmInt i _)])
+   | addr == addr2, pk /= II64 || is32BitInteger i,
+     Just instr <- check op
+   = do Amode amode code_addr <- getAmode addr
+        let code = code_addr `snocOL`
+                   instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)
+        return code
+   where
+        check (MO_Add _) = Just ADD
+        check (MO_Sub _) = Just SUB
+        check _ = Nothing
+        -- ToDo: more?
+
+-- general case
+assignMem_IntCode pk addr src = do
+    is32Bit <- is32BitPlatform
+    Amode addr code_addr <- getAmode addr
+    (code_src, op_src)   <- get_op_RI is32Bit src
+    let
+        code = code_src `appOL`
+               code_addr `snocOL`
+                  MOV pk op_src (OpAddr addr)
+        -- NOTE: op_src is stable, so it will still be valid
+        -- after code_addr.  This may involve the introduction
+        -- of an extra MOV to a temporary register, but we hope
+        -- the register allocator will get rid of it.
+    --
+    return code
+  where
+    get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator
+    get_op_RI is32Bit (CmmLit lit) | is32BitLit is32Bit lit
+      = return (nilOL, OpImm (litToImm lit))
+    get_op_RI _ op
+      = do (reg,code) <- getNonClobberedReg op
+           return (code, OpReg reg)
+
+
+-- Assign; dst is a reg, rhs is mem
+assignReg_IntCode pk reg (CmmLoad src _) = do
+  load_code <- intLoadCode (MOV pk) src
+  dflags <- getDynFlags
+  let platform = targetPlatform dflags
+  return (load_code (getRegisterReg platform False{-no sse2-} reg))
+
+-- dst is a reg, but src could be anything
+assignReg_IntCode _ reg src = do
+  dflags <- getDynFlags
+  let platform = targetPlatform dflags
+  code <- getAnyReg src
+  return (code (getRegisterReg platform False{-no sse2-} reg))
+
+
+-- Floating point assignment to memory
+assignMem_FltCode pk addr src = do
+  (src_reg, src_code) <- getNonClobberedReg src
+  Amode addr addr_code <- getAmode addr
+  use_sse2 <- sse2Enabled
+  let
+        code = src_code `appOL`
+               addr_code `snocOL`
+                if use_sse2 then MOV pk (OpReg src_reg) (OpAddr addr)
+                            else GST pk src_reg addr
+  return code
+
+-- Floating point assignment to a register/temporary
+assignReg_FltCode _ reg src = do
+  use_sse2 <- sse2Enabled
+  src_code <- getAnyReg src
+  dflags <- getDynFlags
+  let platform = targetPlatform dflags
+  return (src_code (getRegisterReg platform use_sse2 reg))
+
+
+genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock
+
+genJump (CmmLoad mem _) regs = do
+  Amode target code <- getAmode mem
+  return (code `snocOL` JMP (OpAddr target) regs)
+
+genJump (CmmLit lit) regs = do
+  return (unitOL (JMP (OpImm (litToImm lit)) regs))
+
+genJump expr regs = do
+  (reg,code) <- getSomeReg expr
+  return (code `snocOL` JMP (OpReg reg) regs)
+
+
+-- -----------------------------------------------------------------------------
+--  Unconditional branches
+
+genBranch :: BlockId -> InstrBlock
+genBranch = toOL . mkJumpInstr
+
+
+
+-- -----------------------------------------------------------------------------
+--  Conditional jumps/branches
+
+{-
+Conditional jumps are always to local labels, so we can use branch
+instructions.  We peek at the arguments to decide what kind of
+comparison to do.
+
+I386: First, we have to ensure that the condition
+codes are set according to the supplied comparison operation.
+-}
+
+
+genCondBranch
+    :: BlockId      -- the source of the jump
+    -> BlockId      -- the true branch target
+    -> BlockId      -- the false branch target
+    -> CmmExpr      -- the condition on which to branch
+    -> NatM InstrBlock -- Instructions
+
+genCondBranch bid id false expr = do
+  is32Bit <- is32BitPlatform
+  genCondBranch' is32Bit bid id false expr
+
+-- | We return the instructions generated.
+genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr
+               -> NatM InstrBlock
+
+-- 64-bit integer comparisons on 32-bit
+genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])
+  | is32Bit, Just W64 <- maybeIntComparison mop = do
+  ChildCode64 code1 r1_lo <- iselExpr64 e1
+  ChildCode64 code2 r2_lo <- iselExpr64 e2
+  let r1_hi = getHiVRegFromLo r1_lo
+      r2_hi = getHiVRegFromLo r2_lo
+      cond = machOpToCond mop
+      Just cond' = maybeFlipCond cond
+  --TODO: Update CFG for x86
+  let code = code1 `appOL` code2 `appOL` toOL [
+        CMP II32 (OpReg r2_hi) (OpReg r1_hi),
+        JXX cond true,
+        JXX cond' false,
+        CMP II32 (OpReg r2_lo) (OpReg r1_lo),
+        JXX cond true] `appOL` genBranch false
+  return code
+
+genCondBranch' _ bid id false bool = do
+  CondCode is_float cond cond_code <- getCondCode bool
+  use_sse2 <- sse2Enabled
+  if not is_float || not use_sse2
+    then
+        return (cond_code `snocOL` JXX cond id `appOL` genBranch false)
+    else do
+        -- See Note [SSE Parity Checks]
+        let jmpFalse = genBranch false
+            code
+                = case cond of
+                  NE  -> or_unordered
+                  GU  -> plain_test
+                  GEU -> plain_test
+                  -- Use ASSERT so we don't break releases if
+                  -- LTT/LE creep in somehow.
+                  LTT ->
+                    ASSERT2(False, ppr "Should have been turned into >")
+                    and_ordered
+                  LE  ->
+                    ASSERT2(False, ppr "Should have been turned into >=")
+                    and_ordered
+                  _   -> and_ordered
+
+            plain_test = unitOL (
+                  JXX cond id
+                ) `appOL` jmpFalse
+            or_unordered = toOL [
+                  JXX cond id,
+                  JXX PARITY id
+                ] `appOL` jmpFalse
+            and_ordered = toOL [
+                  JXX PARITY false,
+                  JXX cond id,
+                  JXX ALWAYS false
+                ]
+        updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)
+        return (cond_code `appOL` code)
+
+-- -----------------------------------------------------------------------------
+--  Generating C calls
+
+-- Now the biggest nightmare---calls.  Most of the nastiness is buried in
+-- @get_arg@, which moves the arguments to the correct registers/stack
+-- locations.  Apart from that, the code is easy.
+--
+-- (If applicable) Do not fill the delay slots here; you will confuse the
+-- register allocator.
+
+genCCall
+    :: DynFlags
+    -> Bool                     -- 32 bit platform?
+    -> ForeignTarget            -- function to call
+    -> [CmmFormal]        -- where to put the result
+    -> [CmmActual]        -- arguments (of mixed type)
+    -> BlockId      -- The block we are in
+    -> NatM InstrBlock
+
+-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+-- Unroll memcpy calls if the source and destination pointers are at
+-- least DWORD aligned and the number of bytes to copy isn't too
+-- large.  Otherwise, call C's memcpy.
+genCCall dflags is32Bit (PrimTarget (MO_Memcpy align)) _
+         [dst, src, CmmLit (CmmInt n _)] _
+    | fromInteger insns <= maxInlineMemcpyInsns dflags && align .&. 3 == 0 = do
+        code_dst <- getAnyReg dst
+        dst_r <- getNewRegNat format
+        code_src <- getAnyReg src
+        src_r <- getNewRegNat format
+        tmp_r <- getNewRegNat format
+        return $ code_dst dst_r `appOL` code_src src_r `appOL`
+            go dst_r src_r tmp_r (fromInteger n)
+  where
+    -- The number of instructions we will generate (approx). We need 2
+    -- instructions per move.
+    insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)
+
+    format = if align .&. 4 /= 0 then II32 else (archWordFormat is32Bit)
+
+    -- The size of each move, in bytes.
+    sizeBytes :: Integer
+    sizeBytes = fromIntegral (formatInBytes format)
+
+    go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr
+    go dst src tmp i
+        | i >= sizeBytes =
+            unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL`
+            unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL`
+            go dst src tmp (i - sizeBytes)
+        -- Deal with remaining bytes.
+        | i >= 4 =  -- Will never happen on 32-bit
+            unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL`
+            unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL`
+            go dst src tmp (i - 4)
+        | i >= 2 =
+            unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL`
+            unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL`
+            go dst src tmp (i - 2)
+        | i >= 1 =
+            unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL`
+            unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL`
+            go dst src tmp (i - 1)
+        | otherwise = nilOL
+      where
+        src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone
+                   (ImmInteger (n - i))
+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone
+                   (ImmInteger (n - i))
+
+genCCall dflags _ (PrimTarget (MO_Memset align)) _
+         [dst,
+          CmmLit (CmmInt c _),
+          CmmLit (CmmInt n _)]
+         _
+    | fromInteger insns <= maxInlineMemsetInsns dflags && align .&. 3 == 0 = do
+        code_dst <- getAnyReg dst
+        dst_r <- getNewRegNat format
+        return $ code_dst dst_r `appOL` go dst_r (fromInteger n)
+  where
+    (format, val) = case align .&. 3 of
+        2 -> (II16, c2)
+        0 -> (II32, c4)
+        _ -> (II8, c)
+    c2 = c `shiftL` 8 .|. c
+    c4 = c2 `shiftL` 16 .|. c2
+
+    -- The number of instructions we will generate (approx). We need 1
+    -- instructions per move.
+    insns = (n + sizeBytes - 1) `div` sizeBytes
+
+    -- The size of each move, in bytes.
+    sizeBytes :: Integer
+    sizeBytes = fromIntegral (formatInBytes format)
+
+    go :: Reg -> Integer -> OrdList Instr
+    go dst i
+        -- TODO: Add movabs instruction and support 64-bit sets.
+        | i >= sizeBytes =  -- This might be smaller than the below sizes
+            unitOL (MOV format (OpImm (ImmInteger val)) (OpAddr dst_addr)) `appOL`
+            go dst (i - sizeBytes)
+        | i >= 4 =  -- Will never happen on 32-bit
+            unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr dst_addr)) `appOL`
+            go dst (i - 4)
+        | i >= 2 =
+            unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr dst_addr)) `appOL`
+            go dst (i - 2)
+        | i >= 1 =
+            unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr dst_addr)) `appOL`
+            go dst (i - 1)
+        | otherwise = nilOL
+      where
+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone
+                   (ImmInteger (n - i))
+
+genCCall _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL
+        -- write barrier compiles to no code on x86/x86-64;
+        -- we keep it this long in order to prevent earlier optimisations.
+
+genCCall _ _ (PrimTarget MO_Touch) _ _ _ = return nilOL
+
+genCCall _ is32bit (PrimTarget (MO_Prefetch_Data n )) _  [src] _ =
+        case n of
+            0 -> genPrefetch src $ PREFETCH NTA  format
+            1 -> genPrefetch src $ PREFETCH Lvl2 format
+            2 -> genPrefetch src $ PREFETCH Lvl1 format
+            3 -> genPrefetch src $ PREFETCH Lvl0 format
+            l -> panic $ "unexpected prefetch level in genCCall MO_Prefetch_Data: " ++ (show l)
+            -- the c / llvm prefetch convention is 0, 1, 2, and 3
+            -- the x86 corresponding names are : NTA, 2 , 1, and 0
+   where
+        format = archWordFormat is32bit
+        -- need to know what register width for pointers!
+        genPrefetch inRegSrc prefetchCTor =
+            do
+                code_src <- getAnyReg inRegSrc
+                src_r <- getNewRegNat format
+                return $ code_src src_r `appOL`
+                  (unitOL (prefetchCTor  (OpAddr
+                              ((AddrBaseIndex (EABaseReg src_r )   EAIndexNone (ImmInt 0))))  ))
+                  -- prefetch always takes an address
+
+genCCall dflags is32Bit (PrimTarget (MO_BSwap width)) [dst] [src] _ = do
+    let platform = targetPlatform dflags
+    let dst_r = getRegisterReg platform False (CmmLocal dst)
+    case width of
+        W64 | is32Bit -> do
+               ChildCode64 vcode rlo <- iselExpr64 src
+               let dst_rhi = getHiVRegFromLo dst_r
+                   rhi     = getHiVRegFromLo rlo
+               return $ vcode `appOL`
+                        toOL [ MOV II32 (OpReg rlo) (OpReg dst_rhi),
+                               MOV II32 (OpReg rhi) (OpReg dst_r),
+                               BSWAP II32 dst_rhi,
+                               BSWAP II32 dst_r ]
+        W16 -> do code_src <- getAnyReg src
+                  return $ code_src dst_r `appOL`
+                           unitOL (BSWAP II32 dst_r) `appOL`
+                           unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r))
+        _   -> do code_src <- getAnyReg src
+                  return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r)
+  where
+    format = intFormat width
+
+genCCall dflags is32Bit (PrimTarget (MO_PopCnt width)) dest_regs@[dst]
+         args@[src] bid = do
+    sse4_2 <- sse4_2Enabled
+    let platform = targetPlatform dflags
+    if sse4_2
+        then do code_src <- getAnyReg src
+                src_r <- getNewRegNat format
+                let dst_r = getRegisterReg platform False (CmmLocal dst)
+                return $ code_src src_r `appOL`
+                    (if width == W8 then
+                         -- The POPCNT instruction doesn't take a r/m8
+                         unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`
+                         unitOL (POPCNT II16 (OpReg src_r) dst_r)
+                     else
+                         unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`
+                    (if width == W8 || width == W16 then
+                         -- We used a 16-bit destination register above,
+                         -- so zero-extend
+                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
+                     else nilOL)
+        else do
+            targetExpr <- cmmMakeDynamicReference dflags
+                          CallReference lbl
+            let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                                           [NoHint] [NoHint]
+                                                           CmmMayReturn)
+            genCCall dflags is32Bit target dest_regs args bid
+  where
+    format = intFormat width
+    lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width))
+
+genCCall dflags is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst]
+         args@[src, mask] bid = do
+    let platform = targetPlatform dflags
+    if isBmi2Enabled dflags
+        then do code_src  <- getAnyReg src
+                code_mask <- getAnyReg mask
+                src_r     <- getNewRegNat format
+                mask_r    <- getNewRegNat format
+                let dst_r = getRegisterReg platform False (CmmLocal dst)
+                return $ code_src src_r `appOL` code_mask mask_r `appOL`
+                    (if width == W8 then
+                         -- The PDEP instruction doesn't take a r/m8
+                         unitOL (MOVZxL II8  (OpReg src_r ) (OpReg src_r )) `appOL`
+                         unitOL (MOVZxL II8  (OpReg mask_r) (OpReg mask_r)) `appOL`
+                         unitOL (PDEP   II16 (OpReg mask_r) (OpReg src_r ) dst_r)
+                     else
+                         unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL`
+                    (if width == W8 || width == W16 then
+                         -- We used a 16-bit destination register above,
+                         -- so zero-extend
+                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
+                     else nilOL)
+        else do
+            targetExpr <- cmmMakeDynamicReference dflags
+                          CallReference lbl
+            let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                                           [NoHint] [NoHint]
+                                                           CmmMayReturn)
+            genCCall dflags is32Bit target dest_regs args bid
+  where
+    format = intFormat width
+    lbl = mkCmmCodeLabel primUnitId (fsLit (pdepLabel width))
+
+genCCall dflags is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst]
+         args@[src, mask] bid = do
+    let platform = targetPlatform dflags
+    if isBmi2Enabled dflags
+        then do code_src  <- getAnyReg src
+                code_mask <- getAnyReg mask
+                src_r     <- getNewRegNat format
+                mask_r    <- getNewRegNat format
+                let dst_r = getRegisterReg platform False (CmmLocal dst)
+                return $ code_src src_r `appOL` code_mask mask_r `appOL`
+                    (if width == W8 then
+                         -- The PEXT instruction doesn't take a r/m8
+                         unitOL (MOVZxL II8 (OpReg src_r ) (OpReg src_r )) `appOL`
+                         unitOL (MOVZxL II8 (OpReg mask_r) (OpReg mask_r)) `appOL`
+                         unitOL (PEXT II16 (OpReg mask_r) (OpReg src_r) dst_r)
+                     else
+                         unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)) `appOL`
+                    (if width == W8 || width == W16 then
+                         -- We used a 16-bit destination register above,
+                         -- so zero-extend
+                         unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))
+                     else nilOL)
+        else do
+            targetExpr <- cmmMakeDynamicReference dflags
+                          CallReference lbl
+            let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                                           [NoHint] [NoHint]
+                                                           CmmMayReturn)
+            genCCall dflags is32Bit target dest_regs args bid
+  where
+    format = intFormat width
+    lbl = mkCmmCodeLabel primUnitId (fsLit (pextLabel width))
+
+genCCall dflags is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid
+  | is32Bit && width == W64 = do
+    -- Fallback to `hs_clz64` on i386
+    targetExpr <- cmmMakeDynamicReference dflags CallReference lbl
+    let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                           [NoHint] [NoHint]
+                                           CmmMayReturn)
+    genCCall dflags is32Bit target dest_regs args bid
+
+  | otherwise = do
+    code_src <- getAnyReg src
+    src_r <- getNewRegNat format
+    tmp_r <- getNewRegNat format
+    let dst_r = getRegisterReg platform False (CmmLocal dst)
+
+    -- The following insn sequence makes sure 'clz 0' has a defined value.
+    -- starting with Haswell, one could use the LZCNT insn instead.
+    return $ code_src src_r `appOL` toOL
+             ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] ++
+              [ BSR     format (OpReg src_r) tmp_r
+              , MOV     II32   (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)
+              , CMOV NE format (OpReg tmp_r) dst_r
+              , XOR     format (OpImm (ImmInt (bw-1))) (OpReg dst_r)
+              ]) -- NB: We don't need to zero-extend the result for the
+                 -- W8/W16 cases because the 'MOV' insn already
+                 -- took care of implicitly clearing the upper bits
+  where
+    bw = widthInBits width
+    platform = targetPlatform dflags
+    format = if width == W8 then II16 else intFormat width
+    lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width))
+
+genCCall dflags is32Bit (PrimTarget (MO_Ctz width)) [dst] [src] bid
+  | is32Bit, width == W64 = do
+      ChildCode64 vcode rlo <- iselExpr64 src
+      let rhi     = getHiVRegFromLo rlo
+          dst_r   = getRegisterReg platform False (CmmLocal dst)
+      lbl1 <- getBlockIdNat
+      lbl2 <- getBlockIdNat
+      tmp_r <- getNewRegNat format
+
+      -- New CFG Edges:
+      --  bid -> lbl2
+      --  bid -> lbl1 -> lbl2
+      --  We also changes edges originating at bid to start at lbl2 instead.
+      updateCfgNat (addWeightEdge bid lbl1 110 .
+                    addWeightEdge lbl1 lbl2 110 .
+                    addImmediateSuccessor bid lbl2)
+
+      -- The following instruction sequence corresponds to the pseudo-code
+      --
+      --  if (src) {
+      --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);
+      --  } else {
+      --    dst = 64;
+      --  }
+      return $ vcode `appOL` toOL
+               ([ MOV      II32 (OpReg rhi)         (OpReg tmp_r)
+                , OR       II32 (OpReg rlo)         (OpReg tmp_r)
+                , MOV      II32 (OpImm (ImmInt 64)) (OpReg dst_r)
+                , JXX EQQ    lbl2
+                , JXX ALWAYS lbl1
+
+                , NEWBLOCK   lbl1
+                , BSF     II32 (OpReg rhi)         dst_r
+                , ADD     II32 (OpImm (ImmInt 32)) (OpReg dst_r)
+                , BSF     II32 (OpReg rlo)         tmp_r
+                , CMOV NE II32 (OpReg tmp_r)       dst_r
+                , JXX ALWAYS lbl2
+
+                , NEWBLOCK   lbl2
+                ])
+
+  | otherwise = do
+    code_src <- getAnyReg src
+    src_r <- getNewRegNat format
+    tmp_r <- getNewRegNat format
+    let dst_r = getRegisterReg platform False (CmmLocal dst)
+
+    -- The following insn sequence makes sure 'ctz 0' has a defined value.
+    -- starting with Haswell, one could use the TZCNT insn instead.
+    return $ code_src src_r `appOL` toOL
+             ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] ++
+              [ BSF     format (OpReg src_r) tmp_r
+              , MOV     II32   (OpImm (ImmInt bw)) (OpReg dst_r)
+              , CMOV NE format (OpReg tmp_r) dst_r
+              ]) -- NB: We don't need to zero-extend the result for the
+                 -- W8/W16 cases because the 'MOV' insn already
+                 -- took care of implicitly clearing the upper bits
+  where
+    bw = widthInBits width
+    platform = targetPlatform dflags
+    format = if width == W8 then II16 else intFormat width
+
+genCCall dflags is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do
+    targetExpr <- cmmMakeDynamicReference dflags
+                  CallReference lbl
+    let target = ForeignTarget targetExpr (ForeignConvention CCallConv
+                                           [NoHint] [NoHint]
+                                           CmmMayReturn)
+    genCCall dflags is32Bit target dest_regs args bid
+  where
+    lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width))
+
+genCCall dflags is32Bit (PrimTarget (MO_AtomicRMW width amop))
+                                           [dst] [addr, n] bid = do
+    Amode amode addr_code <-
+        if amop `elem` [AMO_Add, AMO_Sub]
+        then getAmode addr
+        else getSimpleAmode dflags is32Bit addr  -- See genCCall for MO_Cmpxchg
+    arg <- getNewRegNat format
+    arg_code <- getAnyReg n
+    use_sse2 <- sse2Enabled
+    let platform = targetPlatform dflags
+        dst_r    = getRegisterReg platform use_sse2 (CmmLocal dst)
+    code <- op_code dst_r arg amode
+    return $ addr_code `appOL` arg_code arg `appOL` code
+  where
+    -- Code for the operation
+    op_code :: Reg       -- Destination reg
+            -> Reg       -- Register containing argument
+            -> AddrMode  -- Address of location to mutate
+            -> NatM (OrdList Instr)
+    op_code dst_r arg amode = case amop of
+        -- In the common case where dst_r is a virtual register the
+        -- final move should go away, because it's the last use of arg
+        -- and the first use of dst_r.
+        AMO_Add  -> return $ toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))
+                                  , MOV format (OpReg arg) (OpReg dst_r)
+                                  ]
+        AMO_Sub  -> return $ toOL [ NEGI format (OpReg arg)
+                                  , LOCK (XADD format (OpReg arg) (OpAddr amode))
+                                  , MOV format (OpReg arg) (OpReg dst_r)
+                                  ]
+        AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)
+        AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst
+                                                    , NOT format dst
+                                                    ])
+        AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)
+        AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)
+      where
+        -- Simulate operation that lacks a dedicated instruction using
+        -- cmpxchg.
+        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)
+                     -> NatM (OrdList Instr)
+        cmpxchg_code instrs = do
+            lbl <- getBlockIdNat
+            tmp <- getNewRegNat format
+
+            --Record inserted blocks
+            addImmediateSuccessorNat bid lbl
+            updateCfgNat (addWeightEdge lbl lbl 0)
+
+            return $ toOL
+                [ MOV format (OpAddr amode) (OpReg eax)
+                , JXX ALWAYS lbl
+                , NEWBLOCK lbl
+                  -- Keep old value so we can return it:
+                , MOV format (OpReg eax) (OpReg dst_r)
+                , MOV format (OpReg eax) (OpReg tmp)
+                ]
+                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL
+                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))
+                , JXX NE lbl
+                ]
+
+    format = intFormat width
+
+genCCall dflags _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do
+  load_code <- intLoadCode (MOV (intFormat width)) addr
+  let platform = targetPlatform dflags
+  use_sse2 <- sse2Enabled
+  return (load_code (getRegisterReg platform use_sse2 (CmmLocal dst)))
+
+genCCall _ _ (PrimTarget (MO_AtomicWrite width)) [] [addr, val] _ = do
+    code <- assignMem_IntCode (intFormat width) addr val
+    return $ code `snocOL` MFENCE
+
+genCCall dflags is32Bit (PrimTarget (MO_Cmpxchg width)) [dst] [addr, old, new] _ = do
+    -- On x86 we don't have enough registers to use cmpxchg with a
+    -- complicated addressing mode, so on that architecture we
+    -- pre-compute the address first.
+    Amode amode addr_code <- getSimpleAmode dflags is32Bit addr
+    newval <- getNewRegNat format
+    newval_code <- getAnyReg new
+    oldval <- getNewRegNat format
+    oldval_code <- getAnyReg old
+    use_sse2 <- sse2Enabled
+    let platform = targetPlatform dflags
+        dst_r    = getRegisterReg platform use_sse2 (CmmLocal dst)
+        code     = toOL
+                   [ MOV format (OpReg oldval) (OpReg eax)
+                   , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))
+                   , MOV format (OpReg eax) (OpReg dst_r)
+                   ]
+    return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval
+        `appOL` code
+  where
+    format = intFormat width
+
+genCCall _ is32Bit target dest_regs args bid = do
+  dflags <- getDynFlags
+  let platform = targetPlatform dflags
+      sse2     = isSse2Enabled dflags
+  case (target, dest_regs) of
+    -- void return type prim op
+    (PrimTarget op, []) ->
+        outOfLineCmmOp bid op Nothing args
+    -- we only cope with a single result for foreign calls
+    (PrimTarget op, [r])
+      | sse2 -> case op of
+          MO_F32_Fabs -> case args of
+            [x] -> sse2FabsCode W32 x
+            _ -> panic "genCCall: Wrong number of arguments for fabs"
+          MO_F64_Fabs -> case args of
+            [x] -> sse2FabsCode W64 x
+            _ -> panic "genCCall: Wrong number of arguments for fabs"
+
+          MO_F32_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF32 args
+          MO_F64_Sqrt -> actuallyInlineSSE2Op (\fmt r -> SQRT fmt (OpReg r)) FF64 args
+          _other_op -> outOfLineCmmOp bid op (Just r) args
+      | otherwise -> do
+        l1 <- getNewLabelNat
+        l2 <- getNewLabelNat
+        if sse2
+          then outOfLineCmmOp bid op (Just r) args
+          else case op of
+              MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args
+              MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args
+
+              MO_F32_Sin  -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args
+              MO_F64_Sin  -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args
+
+              MO_F32_Cos  -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args
+              MO_F64_Cos  -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args
+
+              MO_F32_Tan  -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args
+              MO_F64_Tan  -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args
+
+              _other_op   -> outOfLineCmmOp bid op (Just r) args
+
+       where
+        actuallyInlineFloatOp = actuallyInlineFloatOp' False
+        actuallyInlineSSE2Op = actuallyInlineFloatOp' True
+
+        actuallyInlineFloatOp' usesSSE instr format [x]
+              = do res <- trivialUFCode format (instr format) x
+                   any <- anyReg res
+                   return (any (getRegisterReg platform usesSSE (CmmLocal r)))
+
+        actuallyInlineFloatOp' _ _ _ args
+              = panic $ "genCCall.actuallyInlineFloatOp': bad number of arguments! ("
+                      ++ show (length args) ++ ")"
+
+        sse2FabsCode :: Width -> CmmExpr -> NatM InstrBlock
+        sse2FabsCode w x = do
+          let fmt = floatFormat w
+          x_code <- getAnyReg x
+          let
+            const | FF32 <- fmt = CmmInt 0x7fffffff W32
+                  | otherwise   = CmmInt 0x7fffffffffffffff W64
+          Amode amode amode_code <- memConstant (widthInBytes w) const
+          tmp <- getNewRegNat fmt
+          let
+            code dst = x_code dst `appOL` amode_code `appOL` toOL [
+                MOV fmt (OpAddr amode) (OpReg tmp),
+                AND fmt (OpReg tmp) (OpReg dst)
+                ]
+
+          return $ code (getRegisterReg platform True (CmmLocal r))
+
+    (PrimTarget (MO_S_QuotRem  width), _) -> divOp1 platform True  width dest_regs args
+    (PrimTarget (MO_U_QuotRem  width), _) -> divOp1 platform False width dest_regs args
+    (PrimTarget (MO_U_QuotRem2 width), _) -> divOp2 platform False width dest_regs args
+    (PrimTarget (MO_Add2 width), [res_h, res_l]) ->
+        case args of
+        [arg_x, arg_y] ->
+            do hCode <- getAnyReg (CmmLit (CmmInt 0 width))
+               let format = intFormat width
+               lCode <- anyReg =<< trivialCode width (ADD_CC format)
+                                     (Just (ADD_CC format)) arg_x arg_y
+               let reg_l = getRegisterReg platform True (CmmLocal res_l)
+                   reg_h = getRegisterReg platform True (CmmLocal res_h)
+                   code = hCode reg_h `appOL`
+                          lCode reg_l `snocOL`
+                          ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)
+               return code
+        _ -> panic "genCCall: Wrong number of arguments/results for add2"
+    (PrimTarget (MO_AddWordC width), [res_r, res_c]) ->
+        addSubIntC platform ADD_CC (const Nothing) CARRY width res_r res_c args
+    (PrimTarget (MO_SubWordC width), [res_r, res_c]) ->
+        addSubIntC platform SUB_CC (const Nothing) CARRY width res_r res_c args
+    (PrimTarget (MO_AddIntC width), [res_r, res_c]) ->
+        addSubIntC platform ADD_CC (Just . ADD_CC) OFLO width res_r res_c args
+    (PrimTarget (MO_SubIntC width), [res_r, res_c]) ->
+        addSubIntC platform SUB_CC (const Nothing) OFLO width res_r res_c args
+    (PrimTarget (MO_U_Mul2 width), [res_h, res_l]) ->
+        case args of
+        [arg_x, arg_y] ->
+            do (y_reg, y_code) <- getRegOrMem arg_y
+               x_code <- getAnyReg arg_x
+               let format = intFormat width
+                   reg_h = getRegisterReg platform True (CmmLocal res_h)
+                   reg_l = getRegisterReg platform True (CmmLocal res_l)
+                   code = y_code `appOL`
+                          x_code rax `appOL`
+                          toOL [MUL2 format y_reg,
+                                MOV format (OpReg rdx) (OpReg reg_h),
+                                MOV format (OpReg rax) (OpReg reg_l)]
+               return code
+        _ -> panic "genCCall: Wrong number of arguments/results for mul2"
+
+    _ -> if is32Bit
+         then genCCall32' dflags target dest_regs args
+         else genCCall64' dflags target dest_regs args
+
+  where divOp1 platform signed width results [arg_x, arg_y]
+            = divOp platform signed width results Nothing arg_x arg_y
+        divOp1 _ _ _ _ _
+            = panic "genCCall: Wrong number of arguments for divOp1"
+        divOp2 platform signed width results [arg_x_high, arg_x_low, arg_y]
+            = divOp platform signed width results (Just arg_x_high) arg_x_low arg_y
+        divOp2 _ _ _ _ _
+            = panic "genCCall: Wrong number of arguments for divOp2"
+
+        -- See Note [DIV/IDIV for bytes]
+        divOp platform signed W8 [res_q, res_r] m_arg_x_high arg_x_low arg_y =
+            let widen | signed = MO_SS_Conv W8 W16
+                      | otherwise = MO_UU_Conv W8 W16
+                arg_x_low_16 = CmmMachOp widen [arg_x_low]
+                arg_y_16 = CmmMachOp widen [arg_y]
+                m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high
+            in divOp
+                  platform signed W16 [res_q, res_r]
+                  m_arg_x_high_16 arg_x_low_16 arg_y_16
+
+        divOp platform signed width [res_q, res_r]
+              m_arg_x_high arg_x_low arg_y
+            = do let format = intFormat width
+                     reg_q = getRegisterReg platform True (CmmLocal res_q)
+                     reg_r = getRegisterReg platform True (CmmLocal res_r)
+                     widen | signed    = CLTD format
+                           | otherwise = XOR format (OpReg rdx) (OpReg rdx)
+                     instr | signed    = IDIV
+                           | otherwise = DIV
+                 (y_reg, y_code) <- getRegOrMem arg_y
+                 x_low_code <- getAnyReg arg_x_low
+                 x_high_code <- case m_arg_x_high of
+                                Just arg_x_high ->
+                                    getAnyReg arg_x_high
+                                Nothing ->
+                                    return $ const $ unitOL widen
+                 return $ y_code `appOL`
+                          x_low_code rax `appOL`
+                          x_high_code rdx `appOL`
+                          toOL [instr format y_reg,
+                                MOV format (OpReg rax) (OpReg reg_q),
+                                MOV format (OpReg rdx) (OpReg reg_r)]
+        divOp _ _ _ _ _ _ _
+            = panic "genCCall: Wrong number of results for divOp"
+
+        addSubIntC platform instr mrevinstr cond width
+                   res_r res_c [arg_x, arg_y]
+            = do let format = intFormat width
+                 rCode <- anyReg =<< trivialCode width (instr format)
+                                       (mrevinstr format) arg_x arg_y
+                 reg_tmp <- getNewRegNat II8
+                 let reg_c = getRegisterReg platform True (CmmLocal res_c)
+                     reg_r = getRegisterReg platform True (CmmLocal res_r)
+                     code = rCode reg_r `snocOL`
+                            SETCC cond (OpReg reg_tmp) `snocOL`
+                            MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)
+
+                 return code
+        addSubIntC _ _ _ _ _ _ _ _
+            = panic "genCCall: Wrong number of arguments/results for addSubIntC"
+
+-- Note [DIV/IDIV for bytes]
+--
+-- IDIV reminder:
+--   Size    Dividend   Divisor   Quotient    Remainder
+--   byte    %ax         r/m8      %al          %ah
+--   word    %dx:%ax     r/m16     %ax          %dx
+--   dword   %edx:%eax   r/m32     %eax         %edx
+--   qword   %rdx:%rax   r/m64     %rax         %rdx
+--
+-- We do a special case for the byte division because the current
+-- codegen doesn't deal well with accessing %ah register (also,
+-- accessing %ah in 64-bit mode is complicated because it cannot be an
+-- operand of many instructions). So we just widen operands to 16 bits
+-- and get the results from %al, %dl. This is not optimal, but a few
+-- register moves are probably not a huge deal when doing division.
+
+genCCall32' :: DynFlags
+            -> ForeignTarget            -- function to call
+            -> [CmmFormal]        -- where to put the result
+            -> [CmmActual]        -- arguments (of mixed type)
+            -> NatM InstrBlock
+genCCall32' dflags target dest_regs args = do
+        let
+            prom_args = map (maybePromoteCArg dflags W32) args
+
+            -- Align stack to 16n for calls, assuming a starting stack
+            -- alignment of 16n - word_size on procedure entry. Which we
+            -- maintiain. See Note [rts/StgCRun.c : Stack Alignment on X86]
+            sizes               = map (arg_size_bytes . cmmExprType dflags) (reverse args)
+            raw_arg_size        = sum sizes + wORD_SIZE dflags
+            arg_pad_size        = (roundTo 16 $ raw_arg_size) - raw_arg_size
+            tot_arg_size        = raw_arg_size + arg_pad_size - wORD_SIZE dflags
+        delta0 <- getDeltaNat
+        setDeltaNat (delta0 - arg_pad_size)
+
+        use_sse2 <- sse2Enabled
+        push_codes <- mapM (push_arg use_sse2) (reverse prom_args)
+        delta <- getDeltaNat
+        MASSERT(delta == delta0 - tot_arg_size)
+
+        -- deal with static vs dynamic call targets
+        (callinsns,cconv) <-
+          case target of
+            ForeignTarget (CmmLit (CmmLabel lbl)) conv
+               -> -- ToDo: stdcall arg sizes
+                  return (unitOL (CALL (Left fn_imm) []), conv)
+               where fn_imm = ImmCLbl lbl
+            ForeignTarget expr conv
+               -> do { (dyn_r, dyn_c) <- getSomeReg expr
+                     ; ASSERT( isWord32 (cmmExprType dflags expr) )
+                       return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }
+            PrimTarget _
+                -> panic $ "genCCall: Can't handle PrimTarget call type here, error "
+                            ++ "probably because too many return values."
+
+        let push_code
+                | arg_pad_size /= 0
+                = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),
+                        DELTA (delta0 - arg_pad_size)]
+                  `appOL` concatOL push_codes
+                | otherwise
+                = concatOL push_codes
+
+              -- Deallocate parameters after call for ccall;
+              -- but not for stdcall (callee does it)
+              --
+              -- We have to pop any stack padding we added
+              -- even if we are doing stdcall, though (#5052)
+            pop_size
+               | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size
+               | otherwise = tot_arg_size
+
+            call = callinsns `appOL`
+                   toOL (
+                      (if pop_size==0 then [] else
+                       [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)])
+                      ++
+                      [DELTA delta0]
+                   )
+        setDeltaNat delta0
+
+        dflags <- getDynFlags
+        let platform = targetPlatform dflags
+
+        let
+            -- assign the results, if necessary
+            assign_code []     = nilOL
+            assign_code [dest]
+              | isFloatType ty =
+                 if use_sse2
+                    then let tmp_amode = AddrBaseIndex (EABaseReg esp)
+                                                       EAIndexNone
+                                                       (ImmInt 0)
+                             fmt = floatFormat w
+                         in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),
+                                   DELTA (delta0 - b),
+                                   GST fmt fake0 tmp_amode,
+                                   MOV fmt (OpAddr tmp_amode) (OpReg r_dest),
+                                   ADD II32 (OpImm (ImmInt b)) (OpReg esp),
+                                   DELTA delta0]
+                    else unitOL (GMOV fake0 r_dest)
+              | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),
+                                        MOV II32 (OpReg edx) (OpReg r_dest_hi)]
+              | otherwise      = unitOL (MOV (intFormat w)
+                                             (OpReg eax)
+                                             (OpReg r_dest))
+              where
+                    ty = localRegType dest
+                    w  = typeWidth ty
+                    b  = widthInBytes w
+                    r_dest_hi = getHiVRegFromLo r_dest
+                    r_dest    = getRegisterReg platform use_sse2 (CmmLocal dest)
+            assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many)
+
+        return (push_code `appOL`
+                call `appOL`
+                assign_code dest_regs)
+
+      where
+        -- If the size is smaller than the word, we widen things (see maybePromoteCArg)
+        arg_size_bytes :: CmmType -> Int
+        arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth dflags))
+
+        roundTo a x | x `mod` a == 0 = x
+                    | otherwise = x + a - (x `mod` a)
+
+        push_arg :: Bool -> CmmActual {-current argument-}
+                        -> NatM InstrBlock  -- code
+
+        push_arg use_sse2 arg -- we don't need the hints on x86
+          | isWord64 arg_ty = do
+            ChildCode64 code r_lo <- iselExpr64 arg
+            delta <- getDeltaNat
+            setDeltaNat (delta - 8)
+            let r_hi = getHiVRegFromLo r_lo
+            return (       code `appOL`
+                           toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),
+                                 PUSH II32 (OpReg r_lo), DELTA (delta - 8),
+                                 DELTA (delta-8)]
+                )
+
+          | isFloatType arg_ty = do
+            (reg, code) <- getSomeReg arg
+            delta <- getDeltaNat
+            setDeltaNat (delta-size)
+            return (code `appOL`
+                            toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),
+                                  DELTA (delta-size),
+                                  let addr = AddrBaseIndex (EABaseReg esp)
+                                                            EAIndexNone
+                                                            (ImmInt 0)
+                                      format = floatFormat (typeWidth arg_ty)
+                                  in
+                                  if use_sse2
+                                     then MOV format (OpReg reg) (OpAddr addr)
+                                     else GST format reg addr
+                                 ]
+                           )
+
+          | otherwise = do
+            -- Arguments can be smaller than 32-bit, but we still use @PUSH
+            -- II32@ - the usual calling conventions expect integers to be
+            -- 4-byte aligned.
+            ASSERT((typeWidth arg_ty) <= W32) return ()
+            (operand, code) <- getOperand arg
+            delta <- getDeltaNat
+            setDeltaNat (delta-size)
+            return (code `snocOL`
+                    PUSH II32 operand `snocOL`
+                    DELTA (delta-size))
+
+          where
+             arg_ty = cmmExprType dflags arg
+             size = arg_size_bytes arg_ty -- Byte size
+
+genCCall64' :: DynFlags
+            -> ForeignTarget      -- function to call
+            -> [CmmFormal]        -- where to put the result
+            -> [CmmActual]        -- arguments (of mixed type)
+            -> NatM InstrBlock
+genCCall64' dflags target dest_regs args = do
+    -- load up the register arguments
+    let prom_args = map (maybePromoteCArg dflags W32) args
+
+    (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code)
+         <-
+        if platformOS platform == OSMinGW32
+        then load_args_win prom_args [] [] (allArgRegs platform) nilOL
+        else do
+           (stack_args, aregs, fregs, load_args_code, assign_args_code)
+               <- load_args prom_args (allIntArgRegs platform)
+                                      (allFPArgRegs platform)
+                                      nilOL nilOL
+           let used_regs rs as = reverse (drop (length rs) (reverse as))
+               fregs_used      = used_regs fregs (allFPArgRegs platform)
+               aregs_used      = used_regs aregs (allIntArgRegs platform)
+           return (stack_args, aregs_used, fregs_used, load_args_code
+                                                      , assign_args_code)
+
+    let
+        arg_regs_used = int_regs_used ++ fp_regs_used
+        arg_regs = [eax] ++ arg_regs_used
+                -- for annotating the call instruction with
+        sse_regs = length fp_regs_used
+        arg_stack_slots = if platformOS platform == OSMinGW32
+                          then length stack_args + length (allArgRegs platform)
+                          else length stack_args
+        tot_arg_size = arg_size * arg_stack_slots
+
+
+    -- Align stack to 16n for calls, assuming a starting stack
+    -- alignment of 16n - word_size on procedure entry. Which we
+    -- maintain. See Note [rts/StgCRun.c : Stack Alignment on X86]
+    (real_size, adjust_rsp) <-
+        if (tot_arg_size + wORD_SIZE dflags) `rem` 16 == 0
+            then return (tot_arg_size, nilOL)
+            else do -- we need to adjust...
+                delta <- getDeltaNat
+                setDeltaNat (delta - wORD_SIZE dflags)
+                return (tot_arg_size + wORD_SIZE dflags, toOL [
+                                SUB II64 (OpImm (ImmInt (wORD_SIZE dflags))) (OpReg rsp),
+                                DELTA (delta - wORD_SIZE dflags) ])
+
+    -- push the stack args, right to left
+    push_code <- push_args (reverse stack_args) nilOL
+    -- On Win64, we also have to leave stack space for the arguments
+    -- that we are passing in registers
+    lss_code <- if platformOS platform == OSMinGW32
+                then leaveStackSpace (length (allArgRegs platform))
+                else return nilOL
+    delta <- getDeltaNat
+
+    -- deal with static vs dynamic call targets
+    (callinsns,_cconv) <-
+      case target of
+        ForeignTarget (CmmLit (CmmLabel lbl)) conv
+           -> -- ToDo: stdcall arg sizes
+              return (unitOL (CALL (Left fn_imm) arg_regs), conv)
+           where fn_imm = ImmCLbl lbl
+        ForeignTarget expr conv
+           -> do (dyn_r, dyn_c) <- getSomeReg expr
+                 return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)
+        PrimTarget _
+            -> panic $ "genCCall: Can't handle PrimTarget call type here, error "
+                        ++ "probably because too many return values."
+
+    let
+        -- The x86_64 ABI requires us to set %al to the number of SSE2
+        -- registers that contain arguments, if the called routine
+        -- is a varargs function.  We don't know whether it's a
+        -- varargs function or not, so we have to assume it is.
+        --
+        -- It's not safe to omit this assignment, even if the number
+        -- of SSE2 regs in use is zero.  If %al is larger than 8
+        -- on entry to a varargs function, seg faults ensue.
+        assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))
+
+    let call = callinsns `appOL`
+               toOL (
+                    -- Deallocate parameters after call for ccall;
+                    -- stdcall has callee do it, but is not supported on
+                    -- x86_64 target (see #3336)
+                  (if real_size==0 then [] else
+                   [ADD (intFormat (wordWidth dflags)) (OpImm (ImmInt real_size)) (OpReg esp)])
+                  ++
+                  [DELTA (delta + real_size)]
+               )
+    setDeltaNat (delta + real_size)
+
+    let
+        -- assign the results, if necessary
+        assign_code []     = nilOL
+        assign_code [dest] =
+          case typeWidth rep of
+                W32 | isFloatType rep -> unitOL (MOV (floatFormat W32)
+                                                     (OpReg xmm0)
+                                                     (OpReg r_dest))
+                W64 | isFloatType rep -> unitOL (MOV (floatFormat W64)
+                                                     (OpReg xmm0)
+                                                     (OpReg r_dest))
+                _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))
+          where
+                rep = localRegType dest
+                r_dest = getRegisterReg platform True (CmmLocal dest)
+        assign_code _many = panic "genCCall.assign_code many"
+
+    return (adjust_rsp          `appOL`
+            push_code           `appOL`
+            load_args_code      `appOL`
+            assign_args_code    `appOL`
+            lss_code            `appOL`
+            assign_eax sse_regs `appOL`
+            call                `appOL`
+            assign_code dest_regs)
+
+  where platform = targetPlatform dflags
+        arg_size = 8 -- always, at the mo
+
+
+        load_args :: [CmmExpr]
+                  -> [Reg]         -- int regs avail for args
+                  -> [Reg]         -- FP regs avail for args
+                  -> InstrBlock    -- code computing args
+                  -> InstrBlock    -- code assigning args to ABI regs
+                  -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)
+        -- no more regs to use
+        load_args args [] [] code acode     =
+            return (args, [], [], code, acode)
+
+        -- no more args to push
+        load_args [] aregs fregs code acode =
+            return ([], aregs, fregs, code, acode)
+
+        load_args (arg : rest) aregs fregs code acode
+            | isFloatType arg_rep = case fregs of
+                 []     -> push_this_arg
+                 (r:rs) -> do
+                    (code',acode') <- reg_this_arg r
+                    load_args rest aregs rs code' acode'
+            | otherwise           = case aregs of
+                 []     -> push_this_arg
+                 (r:rs) -> do
+                    (code',acode') <- reg_this_arg r
+                    load_args rest rs fregs code' acode'
+            where
+
+              -- put arg into the list of stack pushed args
+              push_this_arg = do
+                 (args',ars,frs,code',acode')
+                     <- load_args rest aregs fregs code acode
+                 return (arg:args', ars, frs, code', acode')
+
+              -- pass the arg into the given register
+              reg_this_arg r
+                -- "operand" args can be directly assigned into r
+                | isOperand False arg = do
+                    arg_code <- getAnyReg arg
+                    return (code, (acode `appOL` arg_code r))
+                -- The last non-operand arg can be directly assigned after its
+                -- computation without going into a temporary register
+                | all (isOperand False) rest = do
+                    arg_code   <- getAnyReg arg
+                    return (code `appOL` arg_code r,acode)
+
+                -- other args need to be computed beforehand to avoid clobbering
+                -- previously assigned registers used to pass parameters (see
+                -- #11792, #12614). They are assigned into temporary registers
+                -- and get assigned to proper call ABI registers after they all
+                -- have been computed.
+                | otherwise     = do
+                    arg_code <- getAnyReg arg
+                    tmp      <- getNewRegNat arg_fmt
+                    let
+                      code'  = code `appOL` arg_code tmp
+                      acode' = acode `snocOL` reg2reg arg_fmt tmp r
+                    return (code',acode')
+
+              arg_rep = cmmExprType dflags arg
+              arg_fmt = cmmTypeFormat arg_rep
+
+        load_args_win :: [CmmExpr]
+                      -> [Reg]        -- used int regs
+                      -> [Reg]        -- used FP regs
+                      -> [(Reg, Reg)] -- (int, FP) regs avail for args
+                      -> InstrBlock
+                      -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)
+        load_args_win args usedInt usedFP [] code
+            = return (args, usedInt, usedFP, code, nilOL)
+            -- no more regs to use
+        load_args_win [] usedInt usedFP _ code
+            = return ([], usedInt, usedFP, code, nilOL)
+            -- no more args to push
+        load_args_win (arg : rest) usedInt usedFP
+                      ((ireg, freg) : regs) code
+            | isFloatType arg_rep = do
+                 arg_code <- getAnyReg arg
+                 load_args_win rest (ireg : usedInt) (freg : usedFP) regs
+                               (code `appOL`
+                                arg_code freg `snocOL`
+                                -- If we are calling a varargs function
+                                -- then we need to define ireg as well
+                                -- as freg
+                                MOV II64 (OpReg freg) (OpReg ireg))
+            | otherwise = do
+                 arg_code <- getAnyReg arg
+                 load_args_win rest (ireg : usedInt) usedFP regs
+                               (code `appOL` arg_code ireg)
+            where
+              arg_rep = cmmExprType dflags arg
+
+        push_args [] code = return code
+        push_args (arg:rest) code
+           | isFloatType arg_rep = do
+             (arg_reg, arg_code) <- getSomeReg arg
+             delta <- getDeltaNat
+             setDeltaNat (delta-arg_size)
+             let code' = code `appOL` arg_code `appOL` toOL [
+                            SUB (intFormat (wordWidth dflags)) (OpImm (ImmInt arg_size)) (OpReg rsp),
+                            DELTA (delta-arg_size),
+                            MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel dflags 0))]
+             push_args rest code'
+
+           | otherwise = do
+             -- Arguments can be smaller than 64-bit, but we still use @PUSH
+             -- II64@ - the usual calling conventions expect integers to be
+             -- 8-byte aligned.
+             ASSERT(width <= W64) return ()
+             (arg_op, arg_code) <- getOperand arg
+             delta <- getDeltaNat
+             setDeltaNat (delta-arg_size)
+             let code' = code `appOL` arg_code `appOL` toOL [
+                                    PUSH II64 arg_op,
+                                    DELTA (delta-arg_size)]
+             push_args rest code'
+            where
+              arg_rep = cmmExprType dflags arg
+              width = typeWidth arg_rep
+
+        leaveStackSpace n = do
+             delta <- getDeltaNat
+             setDeltaNat (delta - n * arg_size)
+             return $ toOL [
+                         SUB II64 (OpImm (ImmInt (n * wORD_SIZE dflags))) (OpReg rsp),
+                         DELTA (delta - n * arg_size)]
+
+maybePromoteCArg :: DynFlags -> Width -> CmmExpr -> CmmExpr
+maybePromoteCArg dflags wto arg
+ | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]
+ | otherwise   = arg
+ where
+   wfrom = cmmExprWidth dflags arg
+
+outOfLineCmmOp :: BlockId -> CallishMachOp -> Maybe CmmFormal -> [CmmActual]
+               -> NatM InstrBlock
+outOfLineCmmOp bid mop res args
+  = do
+      dflags <- getDynFlags
+      targetExpr <- cmmMakeDynamicReference dflags CallReference lbl
+      let target = ForeignTarget targetExpr
+                           (ForeignConvention CCallConv [] [] CmmMayReturn)
+
+      stmtToInstrs bid (CmmUnsafeForeignCall target (catMaybes [res]) args)
+  where
+        -- Assume we can call these functions directly, and that they're not in a dynamic library.
+        -- TODO: Why is this ok? Under linux this code will be in libm.so
+        --       Is it because they're really implemented as a primitive instruction by the assembler??  -- BL 2009/12/31
+        lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction
+
+        fn = case mop of
+              MO_F32_Sqrt  -> fsLit "sqrtf"
+              MO_F32_Fabs  -> fsLit "fabsf"
+              MO_F32_Sin   -> fsLit "sinf"
+              MO_F32_Cos   -> fsLit "cosf"
+              MO_F32_Tan   -> fsLit "tanf"
+              MO_F32_Exp   -> fsLit "expf"
+              MO_F32_Log   -> fsLit "logf"
+
+              MO_F32_Asin  -> fsLit "asinf"
+              MO_F32_Acos  -> fsLit "acosf"
+              MO_F32_Atan  -> fsLit "atanf"
+
+              MO_F32_Sinh  -> fsLit "sinhf"
+              MO_F32_Cosh  -> fsLit "coshf"
+              MO_F32_Tanh  -> fsLit "tanhf"
+              MO_F32_Pwr   -> fsLit "powf"
+
+              MO_F32_Asinh -> fsLit "asinhf"
+              MO_F32_Acosh -> fsLit "acoshf"
+              MO_F32_Atanh -> fsLit "atanhf"
+
+              MO_F64_Sqrt  -> fsLit "sqrt"
+              MO_F64_Fabs  -> fsLit "fabs"
+              MO_F64_Sin   -> fsLit "sin"
+              MO_F64_Cos   -> fsLit "cos"
+              MO_F64_Tan   -> fsLit "tan"
+              MO_F64_Exp   -> fsLit "exp"
+              MO_F64_Log   -> fsLit "log"
+
+              MO_F64_Asin  -> fsLit "asin"
+              MO_F64_Acos  -> fsLit "acos"
+              MO_F64_Atan  -> fsLit "atan"
+
+              MO_F64_Sinh  -> fsLit "sinh"
+              MO_F64_Cosh  -> fsLit "cosh"
+              MO_F64_Tanh  -> fsLit "tanh"
+              MO_F64_Pwr   -> fsLit "pow"
+
+              MO_F64_Asinh  -> fsLit "asinh"
+              MO_F64_Acosh  -> fsLit "acosh"
+              MO_F64_Atanh  -> fsLit "atanh"
+
+              MO_Memcpy _  -> fsLit "memcpy"
+              MO_Memset _  -> fsLit "memset"
+              MO_Memmove _ -> fsLit "memmove"
+              MO_Memcmp _  -> fsLit "memcmp"
+
+              MO_PopCnt _  -> fsLit "popcnt"
+              MO_BSwap _   -> fsLit "bswap"
+              MO_Clz w     -> fsLit $ clzLabel w
+              MO_Ctz _     -> unsupported
+
+              MO_Pdep w    -> fsLit $ pdepLabel w
+              MO_Pext w    -> fsLit $ pextLabel w
+
+              MO_AtomicRMW _ _ -> fsLit "atomicrmw"
+              MO_AtomicRead _  -> fsLit "atomicread"
+              MO_AtomicWrite _ -> fsLit "atomicwrite"
+              MO_Cmpxchg _     -> fsLit "cmpxchg"
+
+              MO_UF_Conv _ -> unsupported
+
+              MO_S_QuotRem {}  -> unsupported
+              MO_U_QuotRem {}  -> unsupported
+              MO_U_QuotRem2 {} -> unsupported
+              MO_Add2 {}       -> unsupported
+              MO_AddIntC {}    -> unsupported
+              MO_SubIntC {}    -> unsupported
+              MO_AddWordC {}   -> unsupported
+              MO_SubWordC {}   -> unsupported
+              MO_U_Mul2 {}     -> unsupported
+              MO_WriteBarrier  -> unsupported
+              MO_Touch         -> unsupported
+              (MO_Prefetch_Data _ ) -> unsupported
+        unsupported = panic ("outOfLineCmmOp: " ++ show mop
+                          ++ " not supported here")
+
+-- -----------------------------------------------------------------------------
+-- Generating a table-branch
+
+genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
+
+genSwitch dflags expr targets
+  | positionIndependent dflags
+  = do
+        (reg,e_code) <- getNonClobberedReg (cmmOffset dflags expr offset)
+           -- getNonClobberedReg because it needs to survive across t_code
+        lbl <- getNewLabelNat
+        dflags <- getDynFlags
+        let is32bit = target32Bit (targetPlatform dflags)
+            os = platformOS (targetPlatform dflags)
+            -- Might want to use .rodata.<function we're in> instead, but as
+            -- long as it's something unique it'll work out since the
+            -- references to the jump table are in the appropriate section.
+            rosection = case os of
+              -- on Mac OS X/x86_64, put the jump table in the text section to
+              -- work around a limitation of the linker.
+              -- ld64 is unable to handle the relocations for
+              --     .quad L1 - L0
+              -- if L0 is not preceded by a non-anonymous label in its section.
+              OSDarwin | not is32bit -> Section Text lbl
+              _ -> Section ReadOnlyData lbl
+        dynRef <- cmmMakeDynamicReference dflags DataReference lbl
+        (tableReg,t_code) <- getSomeReg $ dynRef
+        let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
+                                       (EAIndex reg (wORD_SIZE dflags)) (ImmInt 0))
+
+        offsetReg <- getNewRegNat (intFormat (wordWidth dflags))
+        return $ if is32bit || os == OSDarwin
+                 then e_code `appOL` t_code `appOL` toOL [
+                                ADD (intFormat (wordWidth dflags)) op (OpReg tableReg),
+                                JMP_TBL (OpReg tableReg) ids rosection lbl
+                       ]
+                 else -- HACK: On x86_64 binutils<2.17 is only able to generate
+                      -- PC32 relocations, hence we only get 32-bit offsets in
+                      -- the jump table. As these offsets are always negative
+                      -- we need to properly sign extend them to 64-bit. This
+                      -- hack should be removed in conjunction with the hack in
+                      -- PprMach.hs/pprDataItem once binutils 2.17 is standard.
+                      e_code `appOL` t_code `appOL` toOL [
+                               MOVSxL II32 op (OpReg offsetReg),
+                               ADD (intFormat (wordWidth dflags))
+                                   (OpReg offsetReg)
+                                   (OpReg tableReg),
+                               JMP_TBL (OpReg tableReg) ids rosection lbl
+                       ]
+  | otherwise
+  = do
+        (reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
+        lbl <- getNewLabelNat
+        let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (wORD_SIZE dflags)) (ImmCLbl lbl))
+            code = e_code `appOL` toOL [
+                    JMP_TBL op ids (Section ReadOnlyData lbl) lbl
+                 ]
+        return code
+  where
+    (offset, blockIds) = switchTargetsToTable targets
+    ids = map (fmap DestBlockId) blockIds
+
+generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl (Alignment, CmmStatics) Instr)
+generateJumpTableForInstr dflags (JMP_TBL _ ids section lbl)
+    = let getBlockId (DestBlockId id) = id
+          getBlockId _ = panic "Non-Label target in Jump Table"
+          blockIds = map (fmap getBlockId) ids
+      in Just (createJumpTable dflags blockIds section lbl)
+generateJumpTableForInstr _ _ = Nothing
+
+createJumpTable :: DynFlags -> [Maybe BlockId] -> Section -> CLabel
+                -> GenCmmDecl (Alignment, CmmStatics) h g
+createJumpTable dflags ids section lbl
+    = let jumpTable
+            | positionIndependent dflags =
+                  let ww = wordWidth dflags
+                      jumpTableEntryRel Nothing
+                          = CmmStaticLit (CmmInt 0 ww)
+                      jumpTableEntryRel (Just blockid)
+                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww)
+                          where blockLabel = blockLbl blockid
+                  in map jumpTableEntryRel ids
+            | otherwise = map (jumpTableEntry dflags) ids
+      in CmmData section (1, Statics lbl jumpTable)
+
+extractUnwindPoints :: [Instr] -> [UnwindPoint]
+extractUnwindPoints instrs =
+    [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs]
+
+-- -----------------------------------------------------------------------------
+-- 'condIntReg' and 'condFltReg': condition codes into registers
+
+-- Turn those condition codes into integers now (when they appear on
+-- the right hand side of an assignment).
+--
+-- (If applicable) Do not fill the delay slots here; you will confuse the
+-- register allocator.
+
+condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
+
+condIntReg cond x y = do
+  CondCode _ cond cond_code <- condIntCode cond x y
+  tmp <- getNewRegNat II8
+  let
+        code dst = cond_code `appOL` toOL [
+                    SETCC cond (OpReg tmp),
+                    MOVZxL II8 (OpReg tmp) (OpReg dst)
+                  ]
+  return (Any II32 code)
+
+
+-----------------------------------------------------------
+---          Note [SSE Parity Checks]                   ---
+-----------------------------------------------------------
+
+-- We have to worry about unordered operands (eg. comparisons
+-- against NaN).  If the operands are unordered, the comparison
+-- sets the parity flag, carry flag and zero flag.
+-- All comparisons are supposed to return false for unordered
+-- operands except for !=, which returns true.
+--
+-- Optimisation: we don't have to test the parity flag if we
+-- know the test has already excluded the unordered case: eg >
+-- and >= test for a zero carry flag, which can only occur for
+-- ordered operands.
+--
+-- By reversing comparisons we can avoid testing the parity
+-- for < and <= as well. If any of the arguments is an NaN we
+-- return false either way. If both arguments are valid then
+-- x <= y  <->  y >= x  holds. So it's safe to swap these.
+--
+-- We invert the condition inside getRegister'and  getCondCode
+-- which should cover all invertable cases.
+-- All other functions translating FP comparisons to assembly
+-- use these to two generate the comparison code.
+--
+-- As an example consider a simple check:
+--
+-- func :: Float -> Float -> Int
+-- func x y = if x < y then 1 else 0
+--
+-- Which in Cmm gives the floating point comparison.
+--
+--  if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf;
+--
+-- We used to compile this to an assembly code block like this:
+-- _c2gh:
+--  ucomiss %xmm2,%xmm1
+--  jp _c2gf
+--  jb _c2gg
+--  jmp _c2gf
+--
+-- Where we have to introduce an explicit
+-- check for unordered results (using jmp parity):
+--
+-- We can avoid this by exchanging the arguments and inverting the direction
+-- of the comparison. This results in the sequence of:
+--
+--  ucomiss %xmm1,%xmm2
+--  ja _c2g2
+--  jmp _c2g1
+--
+-- Removing the jump reduces the pressure on the branch predidiction system
+-- and plays better with the uOP cache.
+
+condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register
+condFltReg is32Bit cond x y = if_sse2 condFltReg_sse2 condFltReg_x87
+ where
+  condFltReg_x87 = do
+    CondCode _ cond cond_code <- condFltCode cond x y
+    tmp <- getNewRegNat II8
+    let
+        code dst = cond_code `appOL` toOL [
+                    SETCC cond (OpReg tmp),
+                    MOVZxL II8 (OpReg tmp) (OpReg dst)
+                  ]
+    return (Any II32 code)
+
+  condFltReg_sse2 = do
+    CondCode _ cond cond_code <- condFltCode cond x y
+    tmp1 <- getNewRegNat (archWordFormat is32Bit)
+    tmp2 <- getNewRegNat (archWordFormat is32Bit)
+    let -- See Note [SSE Parity Checks]
+        code dst =
+           cond_code `appOL`
+             (case cond of
+                NE  -> or_unordered dst
+                GU  -> plain_test   dst
+                GEU -> plain_test   dst
+                -- Use ASSERT so we don't break releases if these creep in.
+                LTT -> ASSERT2(False, ppr "Should have been turned into >")
+                       and_ordered  dst
+                LE  -> ASSERT2(False, ppr "Should have been turned into >=")
+                       and_ordered  dst
+                _   -> and_ordered  dst)
+
+        plain_test dst = toOL [
+                    SETCC cond (OpReg tmp1),
+                    MOVZxL II8 (OpReg tmp1) (OpReg dst)
+                 ]
+        or_unordered dst = toOL [
+                    SETCC cond (OpReg tmp1),
+                    SETCC PARITY (OpReg tmp2),
+                    OR II8 (OpReg tmp1) (OpReg tmp2),
+                    MOVZxL II8 (OpReg tmp2) (OpReg dst)
+                  ]
+        and_ordered dst = toOL [
+                    SETCC cond (OpReg tmp1),
+                    SETCC NOTPARITY (OpReg tmp2),
+                    AND II8 (OpReg tmp1) (OpReg tmp2),
+                    MOVZxL II8 (OpReg tmp2) (OpReg dst)
+                  ]
+    return (Any II32 code)
+
+
+-- -----------------------------------------------------------------------------
+-- 'trivial*Code': deal with trivial instructions
+
+-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
+-- Only look for constants on the right hand side, because that's
+-- where the generic optimizer will have put them.
+
+-- Similarly, for unary instructions, we don't have to worry about
+-- matching an StInt as the argument, because genericOpt will already
+-- have handled the constant-folding.
+
+
+{-
+The Rules of the Game are:
+
+* You cannot assume anything about the destination register dst;
+  it may be anything, including a fixed reg.
+
+* You may compute an operand into a fixed reg, but you may not
+  subsequently change the contents of that fixed reg.  If you
+  want to do so, first copy the value either to a temporary
+  or into dst.  You are free to modify dst even if it happens
+  to be a fixed reg -- that's not your problem.
+
+* You cannot assume that a fixed reg will stay live over an
+  arbitrary computation.  The same applies to the dst reg.
+
+* Temporary regs obtained from getNewRegNat are distinct from
+  each other and from all other regs, and stay live over
+  arbitrary computations.
+
+--------------------
+
+SDM's version of The Rules:
+
+* If getRegister returns Any, that means it can generate correct
+  code which places the result in any register, period.  Even if that
+  register happens to be read during the computation.
+
+  Corollary #1: this means that if you are generating code for an
+  operation with two arbitrary operands, you cannot assign the result
+  of the first operand into the destination register before computing
+  the second operand.  The second operand might require the old value
+  of the destination register.
+
+  Corollary #2: A function might be able to generate more efficient
+  code if it knows the destination register is a new temporary (and
+  therefore not read by any of the sub-computations).
+
+* If getRegister returns Any, then the code it generates may modify only:
+        (a) fresh temporaries
+        (b) the destination register
+        (c) known registers (eg. %ecx is used by shifts)
+  In particular, it may *not* modify global registers, unless the global
+  register happens to be the destination register.
+-}
+
+trivialCode :: Width -> (Operand -> Operand -> Instr)
+            -> Maybe (Operand -> Operand -> Instr)
+            -> CmmExpr -> CmmExpr -> NatM Register
+trivialCode width instr m a b
+    = do is32Bit <- is32BitPlatform
+         trivialCode' is32Bit width instr m a b
+
+trivialCode' :: Bool -> Width -> (Operand -> Operand -> Instr)
+             -> Maybe (Operand -> Operand -> Instr)
+             -> CmmExpr -> CmmExpr -> NatM Register
+trivialCode' is32Bit width _ (Just revinstr) (CmmLit lit_a) b
+  | is32BitLit is32Bit lit_a = do
+  b_code <- getAnyReg b
+  let
+       code dst
+         = b_code dst `snocOL`
+           revinstr (OpImm (litToImm lit_a)) (OpReg dst)
+  return (Any (intFormat width) code)
+
+trivialCode' _ width instr _ a b
+  = genTrivialCode (intFormat width) instr a b
+
+-- This is re-used for floating pt instructions too.
+genTrivialCode :: Format -> (Operand -> Operand -> Instr)
+               -> CmmExpr -> CmmExpr -> NatM Register
+genTrivialCode rep instr a b = do
+  (b_op, b_code) <- getNonClobberedOperand b
+  a_code <- getAnyReg a
+  tmp <- getNewRegNat rep
+  let
+     -- We want the value of b to stay alive across the computation of a.
+     -- But, we want to calculate a straight into the destination register,
+     -- because the instruction only has two operands (dst := dst `op` src).
+     -- The troublesome case is when the result of b is in the same register
+     -- as the destination reg.  In this case, we have to save b in a
+     -- new temporary across the computation of a.
+     code dst
+        | dst `regClashesWithOp` b_op =
+                b_code `appOL`
+                unitOL (MOV rep b_op (OpReg tmp)) `appOL`
+                a_code dst `snocOL`
+                instr (OpReg tmp) (OpReg dst)
+        | otherwise =
+                b_code `appOL`
+                a_code dst `snocOL`
+                instr b_op (OpReg dst)
+  return (Any rep code)
+
+regClashesWithOp :: Reg -> Operand -> Bool
+reg `regClashesWithOp` OpReg reg2   = reg == reg2
+reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)
+_   `regClashesWithOp` _            = False
+
+-----------
+
+trivialUCode :: Format -> (Operand -> Instr)
+             -> CmmExpr -> NatM Register
+trivialUCode rep instr x = do
+  x_code <- getAnyReg x
+  let
+     code dst =
+        x_code dst `snocOL`
+        instr (OpReg dst)
+  return (Any rep code)
+
+-----------
+
+trivialFCode_x87 :: (Format -> Reg -> Reg -> Reg -> Instr)
+                 -> CmmExpr -> CmmExpr -> NatM Register
+trivialFCode_x87 instr x y = do
+  (x_reg, x_code) <- getNonClobberedReg x -- these work for float regs too
+  (y_reg, y_code) <- getSomeReg y
+  let
+     format = FF80 -- always, on x87
+     code dst =
+        x_code `appOL`
+        y_code `snocOL`
+        instr format x_reg y_reg dst
+  return (Any format code)
+
+trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr)
+                  -> CmmExpr -> CmmExpr -> NatM Register
+trivialFCode_sse2 pk instr x y
+    = genTrivialCode format (instr format) x y
+    where format = floatFormat pk
+
+
+trivialUFCode :: Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
+trivialUFCode format instr x = do
+  (x_reg, x_code) <- getSomeReg x
+  let
+     code dst =
+        x_code `snocOL`
+        instr x_reg dst
+  return (Any format code)
+
+
+--------------------------------------------------------------------------------
+coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
+coerceInt2FP from to x = if_sse2 coerce_sse2 coerce_x87
+ where
+   coerce_x87 = do
+     (x_reg, x_code) <- getSomeReg x
+     let
+           opc  = case to of W32 -> GITOF; W64 -> GITOD;
+                             n -> panic $ "coerceInt2FP.x87: unhandled width ("
+                                         ++ show n ++ ")"
+           code dst = x_code `snocOL` opc x_reg dst
+        -- ToDo: works for non-II32 reps?
+     return (Any FF80 code)
+
+   coerce_sse2 = do
+     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand
+     let
+           opc  = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD
+                             n -> panic $ "coerceInt2FP.sse: unhandled width ("
+                                         ++ show n ++ ")"
+           code dst = x_code `snocOL` opc (intFormat from) x_op dst
+     return (Any (floatFormat to) code)
+        -- works even if the destination rep is <II32
+
+--------------------------------------------------------------------------------
+coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
+coerceFP2Int from to x = if_sse2 coerceFP2Int_sse2 coerceFP2Int_x87
+ where
+   coerceFP2Int_x87 = do
+     (x_reg, x_code) <- getSomeReg x
+     let
+           opc  = case from of W32 -> GFTOI; W64 -> GDTOI
+                               n -> panic $ "coerceFP2Int.x87: unhandled width ("
+                                           ++ show n ++ ")"
+           code dst = x_code `snocOL` opc x_reg dst
+        -- ToDo: works for non-II32 reps?
+     return (Any (intFormat to) code)
+
+   coerceFP2Int_sse2 = do
+     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand
+     let
+           opc  = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;
+                               n -> panic $ "coerceFP2Init.sse: unhandled width ("
+                                           ++ show n ++ ")"
+           code dst = x_code `snocOL` opc (intFormat to) x_op dst
+     return (Any (intFormat to) code)
+         -- works even if the destination rep is <II32
+
+
+--------------------------------------------------------------------------------
+coerceFP2FP :: Width -> CmmExpr -> NatM Register
+coerceFP2FP to x = do
+  use_sse2 <- sse2Enabled
+  (x_reg, x_code) <- getSomeReg x
+  let
+        opc | use_sse2  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;
+                                     n -> panic $ "coerceFP2FP: unhandled width ("
+                                                 ++ show n ++ ")"
+            | otherwise = GDTOF
+        code dst = x_code `snocOL` opc x_reg dst
+  return (Any (if use_sse2 then floatFormat to else FF80) code)
+
+--------------------------------------------------------------------------------
+
+sse2NegCode :: Width -> CmmExpr -> NatM Register
+sse2NegCode w x = do
+  let fmt = floatFormat w
+  x_code <- getAnyReg x
+  -- This is how gcc does it, so it can't be that bad:
+  let
+    const = case fmt of
+      FF32 -> CmmInt 0x80000000 W32
+      FF64 -> CmmInt 0x8000000000000000 W64
+      x@II8  -> wrongFmt x
+      x@II16 -> wrongFmt x
+      x@II32 -> wrongFmt x
+      x@II64 -> wrongFmt x
+      x@FF80 -> wrongFmt x
+      where
+        wrongFmt x = panic $ "sse2NegCode: " ++ show x
+  Amode amode amode_code <- memConstant (widthInBytes w) const
+  tmp <- getNewRegNat fmt
+  let
+    code dst = x_code dst `appOL` amode_code `appOL` toOL [
+        MOV fmt (OpAddr amode) (OpReg tmp),
+        XOR fmt (OpReg tmp) (OpReg dst)
+        ]
+  --
+  return (Any fmt code)
+
+isVecExpr :: CmmExpr -> Bool
+isVecExpr (CmmMachOp (MO_V_Insert {}) _)   = True
+isVecExpr (CmmMachOp (MO_V_Extract {}) _)  = True
+isVecExpr (CmmMachOp (MO_V_Add {}) _)      = True
+isVecExpr (CmmMachOp (MO_V_Sub {}) _)      = True
+isVecExpr (CmmMachOp (MO_V_Mul {}) _)      = True
+isVecExpr (CmmMachOp (MO_VS_Quot {}) _)    = True
+isVecExpr (CmmMachOp (MO_VS_Rem {}) _)     = True
+isVecExpr (CmmMachOp (MO_VS_Neg {}) _)     = True
+isVecExpr (CmmMachOp (MO_VF_Insert {}) _)  = True
+isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True
+isVecExpr (CmmMachOp (MO_VF_Add {}) _)     = True
+isVecExpr (CmmMachOp (MO_VF_Sub {}) _)     = True
+isVecExpr (CmmMachOp (MO_VF_Mul {}) _)     = True
+isVecExpr (CmmMachOp (MO_VF_Quot {}) _)    = True
+isVecExpr (CmmMachOp (MO_VF_Neg {}) _)     = True
+isVecExpr (CmmMachOp _ [e])                = isVecExpr e
+isVecExpr _                                = False
+
+needLlvm :: NatM a
+needLlvm =
+    sorry $ unlines ["The native code generator does not support vector"
+                    ,"instructions. Please use -fllvm."]
+
+-- | This works on the invariant that all jumps in the given blocks are required.
+--   Starting from there we try to make a few more jumps redundant by reordering
+--   them.
+invertCondBranches :: CFG -> LabelMap a -> [NatBasicBlock Instr]
+                   -> [NatBasicBlock Instr]
+invertCondBranches cfg keep bs =
+    --trace "Foo" $
+    invert bs
+  where
+    invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]
+    invert ((BasicBlock lbl1 ins@(_:_:_xs)):b2@(BasicBlock lbl2 _):bs)
+      | --pprTrace "Block" (ppr lbl1) True,
+        (jmp1,jmp2) <- last2 ins
+      , JXX cond1 target1 <- jmp1
+      , target1 == lbl2
+      --, pprTrace "CutChance" (ppr b1) True
+      , JXX ALWAYS target2 <- jmp2
+      -- We have enough information to check if we can perform the inversion
+      -- TODO: We could also check for the last asm instruction which sets
+      -- status flags instead. Which I suspect is worse in terms of compiler
+      -- performance, but might be applicable to more cases
+      , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg
+      , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg
+      -- Both jumps come from the same cmm statement
+      , transitionSource edgeInfo1 == transitionSource edgeInfo2
+      , (CmmSource cmmCondBranch) <- transitionSource edgeInfo1
+
+      --Int comparisons are invertable
+      , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch
+      , Just _ <- maybeIntComparison op
+      , Just invCond <- maybeInvertCond cond1
+
+      --Swap the last two jumps, invert the conditional jumps condition.
+      = let jumps =
+              case () of
+                -- We are free the eliminate the jmp. So we do so.
+                _ | not (mapMember target1 keep)
+                    -> [JXX invCond target2]
+                -- If the conditional target is unlikely we put the other
+                -- target at the front.
+                  | edgeWeight edgeInfo2 > edgeWeight edgeInfo1
+                    -> [JXX invCond target2, JXX ALWAYS target1]
+                -- Keep things as-is otherwise
+                  | otherwise
+                    -> [jmp1, jmp2]
+        in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $
+           (BasicBlock lbl1
+            (dropTail 2 ins ++ jumps))
+            : invert (b2:bs)
+    invert (b:bs) = b : invert bs
+    invert [] = []
diff --git a/compiler/nativeGen/X86/Cond.hs b/compiler/nativeGen/X86/Cond.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/X86/Cond.hs
@@ -0,0 +1,109 @@
+module X86.Cond (
+        Cond(..),
+        condUnsigned,
+        condToSigned,
+        condToUnsigned,
+        maybeFlipCond,
+        maybeInvertCond
+)
+
+where
+
+import GhcPrelude
+
+data Cond
+        = ALWAYS        -- What's really used? ToDo
+        | EQQ
+        | GE
+        | GEU
+        | GTT
+        | GU
+        | LE
+        | LEU
+        | LTT
+        | LU
+        | NE
+        | NEG
+        | POS
+        | CARRY
+        | OFLO
+        | PARITY
+        | NOTPARITY
+        deriving Eq
+
+condUnsigned :: Cond -> Bool
+condUnsigned GU  = True
+condUnsigned LU  = True
+condUnsigned GEU = True
+condUnsigned LEU = True
+condUnsigned _   = False
+
+
+condToSigned :: Cond -> Cond
+condToSigned GU  = GTT
+condToSigned LU  = LTT
+condToSigned GEU = GE
+condToSigned LEU = LE
+condToSigned x   = x
+
+
+condToUnsigned :: Cond -> Cond
+condToUnsigned GTT = GU
+condToUnsigned LTT = LU
+condToUnsigned GE  = GEU
+condToUnsigned LE  = LEU
+condToUnsigned x   = x
+
+-- | @maybeFlipCond c@ returns @Just c'@ if it is possible to flip the
+-- arguments to the conditional @c@, and the new condition should be @c'@.
+maybeFlipCond :: Cond -> Maybe Cond
+maybeFlipCond cond  = case cond of
+        EQQ   -> Just EQQ
+        NE    -> Just NE
+        LU    -> Just GU
+        GU    -> Just LU
+        LEU   -> Just GEU
+        GEU   -> Just LEU
+        LTT   -> Just GTT
+        GTT   -> Just LTT
+        LE    -> Just GE
+        GE    -> Just LE
+        _other -> Nothing
+
+-- | If we apply @maybeInvertCond@ to the condition of a jump we turn
+-- jumps taken into jumps not taken and vice versa.
+--
+-- Careful! If the used comparison and the conditional jump
+-- don't match the above behaviour will NOT hold.
+-- When used for FP comparisons this does not consider unordered
+-- numbers.
+-- Also inverting twice might return a synonym for the original condition.
+maybeInvertCond :: Cond -> Maybe Cond
+maybeInvertCond cond  = case cond of
+        ALWAYS  -> Nothing
+        EQQ     -> Just NE
+        NE      -> Just EQQ
+
+        NEG     -> Just POS
+        POS     -> Just NEG
+
+        GEU     -> Just LU
+        LU      -> Just GEU
+
+        GE      -> Just LTT
+        LTT     -> Just GE
+
+        GTT     -> Just LE
+        LE      -> Just GTT
+
+        GU      -> Just LEU
+        LEU     -> Just GU
+
+        --GEU "==" NOTCARRY, they are synonyms
+        --at the assembly level
+        CARRY   -> Just GEU
+
+        OFLO    -> Nothing
+
+        PARITY  -> Just NOTPARITY
+        NOTPARITY -> Just PARITY
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -0,0 +1,1181 @@
+{-# LANGUAGE CPP, TypeFamilies #-}
+
+-----------------------------------------------------------------------------
+--
+-- Machine-dependent assembly language
+--
+-- (c) The University of Glasgow 1993-2004
+--
+-----------------------------------------------------------------------------
+
+module X86.Instr (Instr(..), Operand(..), PrefetchVariant(..), JumpDest(..),
+                  getJumpDestBlockId, canShortcut, shortcutStatics,
+                  shortcutJump, i386_insert_ffrees, allocMoreStack,
+                  maxSpillSlots, archWordFormat )
+where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+import GhcPrelude
+
+import X86.Cond
+import X86.Regs
+import Instruction
+import Format
+import RegClass
+import Reg
+import TargetReg
+
+import BlockId
+import Hoopl.Collections
+import Hoopl.Label
+import CodeGen.Platform
+import Cmm
+import FastString
+import Outputable
+import Platform
+
+import BasicTypes       (Alignment)
+import CLabel
+import DynFlags
+import UniqSet
+import Unique
+import UniqSupply
+import Debug (UnwindTable)
+
+import Control.Monad
+import Data.Maybe       (fromMaybe)
+
+-- Format of an x86/x86_64 memory address, in bytes.
+--
+archWordFormat :: Bool -> Format
+archWordFormat is32Bit
+ | is32Bit   = II32
+ | otherwise = II64
+
+-- | Instruction instance for x86 instruction set.
+instance Instruction Instr where
+        regUsageOfInstr         = x86_regUsageOfInstr
+        patchRegsOfInstr        = x86_patchRegsOfInstr
+        isJumpishInstr          = x86_isJumpishInstr
+        jumpDestsOfInstr        = x86_jumpDestsOfInstr
+        patchJumpInstr          = x86_patchJumpInstr
+        mkSpillInstr            = x86_mkSpillInstr
+        mkLoadInstr             = x86_mkLoadInstr
+        takeDeltaInstr          = x86_takeDeltaInstr
+        isMetaInstr             = x86_isMetaInstr
+        mkRegRegMoveInstr       = x86_mkRegRegMoveInstr
+        takeRegRegMoveInstr     = x86_takeRegRegMoveInstr
+        mkJumpInstr             = x86_mkJumpInstr
+        mkStackAllocInstr       = x86_mkStackAllocInstr
+        mkStackDeallocInstr     = x86_mkStackDeallocInstr
+
+
+-- -----------------------------------------------------------------------------
+-- Intel x86 instructions
+
+{-
+Intel, in their infinite wisdom, selected a stack model for floating
+point registers on x86.  That might have made sense back in 1979 --
+nowadays we can see it for the nonsense it really is.  A stack model
+fits poorly with the existing nativeGen infrastructure, which assumes
+flat integer and FP register sets.  Prior to this commit, nativeGen
+could not generate correct x86 FP code -- to do so would have meant
+somehow working the register-stack paradigm into the register
+allocator and spiller, which sounds very difficult.
+
+We have decided to cheat, and go for a simple fix which requires no
+infrastructure modifications, at the expense of generating ropey but
+correct FP code.  All notions of the x86 FP stack and its insns have
+been removed.  Instead, we pretend (to the instruction selector and
+register allocator) that x86 has six floating point registers, %fake0
+.. %fake5, which can be used in the usual flat manner.  We further
+claim that x86 has floating point instructions very similar to SPARC
+and Alpha, that is, a simple 3-operand register-register arrangement.
+Code generation and register allocation proceed on this basis.
+
+When we come to print out the final assembly, our convenient fiction
+is converted to dismal reality.  Each fake instruction is
+independently converted to a series of real x86 instructions.
+%fake0 .. %fake5 are mapped to %st(0) .. %st(5).  To do reg-reg
+arithmetic operations, the two operands are pushed onto the top of the
+FP stack, the operation done, and the result copied back into the
+relevant register.  There are only six %fake registers because 2 are
+needed for the translation, and x86 has 8 in total.
+
+The translation is inefficient but is simple and it works.  A cleverer
+translation would handle a sequence of insns, simulating the FP stack
+contents, would not impose a fixed mapping from %fake to %st regs, and
+hopefully could avoid most of the redundant reg-reg moves of the
+current translation.
+
+We might as well make use of whatever unique FP facilities Intel have
+chosen to bless us with (let's not be churlish, after all).
+Hence GLDZ and GLD1.  Bwahahahahahahaha!
+-}
+
+{-
+Note [x86 Floating point precision]
+
+Intel's internal floating point registers are by default 80 bit
+extended precision.  This means that all operations done on values in
+registers are done at 80 bits, and unless the intermediate values are
+truncated to the appropriate size (32 or 64 bits) by storing in
+memory, calculations in registers will give different results from
+calculations which pass intermediate values in memory (eg. via
+function calls).
+
+One solution is to set the FPU into 64 bit precision mode.  Some OSs
+do this (eg. FreeBSD) and some don't (eg. Linux).  The problem here is
+that this will only affect 64-bit precision arithmetic; 32-bit
+calculations will still be done at 64-bit precision in registers.  So
+it doesn't solve the whole problem.
+
+There's also the issue of what the C library is expecting in terms of
+precision.  It seems to be the case that glibc on Linux expects the
+FPU to be set to 80 bit precision, so setting it to 64 bit could have
+unexpected effects.  Changing the default could have undesirable
+effects on other 3rd-party library code too, so the right thing would
+be to save/restore the FPU control word across Haskell code if we were
+to do this.
+
+gcc's -ffloat-store gives consistent results by always storing the
+results of floating-point calculations in memory, which works for both
+32 and 64-bit precision.  However, it only affects the values of
+user-declared floating point variables in C, not intermediate results.
+GHC in -fvia-C mode uses -ffloat-store (see the -fexcess-precision
+flag).
+
+Another problem is how to spill floating point registers in the
+register allocator.  Should we spill the whole 80 bits, or just 64?
+On an OS which is set to 64 bit precision, spilling 64 is fine.  On
+Linux, spilling 64 bits will round the results of some operations.
+This is what gcc does.  Spilling at 80 bits requires taking up a full
+128 bit slot (so we get alignment).  We spill at 80-bits and ignore
+the alignment problems.
+
+In the future [edit: now available in GHC 7.0.1, with the -msse2
+flag], we'll use the SSE registers for floating point.  This requires
+a CPU that supports SSE2 (ordinary SSE only supports 32 bit precision
+float ops), which means P4 or Xeon and above.  Using SSE will solve
+all these problems, because the SSE registers use fixed 32 bit or 64
+bit precision.
+
+--SDM 1/2003
+-}
+
+data Instr
+        -- comment pseudo-op
+        = COMMENT FastString
+
+        -- location pseudo-op (file, line, col, name)
+        | LOCATION Int Int Int String
+
+        -- some static data spat out during code
+        -- generation.  Will be extracted before
+        -- pretty-printing.
+        | LDATA   Section (Alignment, CmmStatics)
+
+        -- start a new basic block.  Useful during
+        -- codegen, removed later.  Preceding
+        -- instruction should be a jump, as per the
+        -- invariants for a BasicBlock (see Cmm).
+        | NEWBLOCK BlockId
+
+        -- unwinding information
+        -- See Note [Unwinding information in the NCG].
+        | UNWIND CLabel UnwindTable
+
+        -- specify current stack offset for benefit of subsequent passes.
+        -- This carries a BlockId so it can be used in unwinding information.
+        | DELTA  Int
+
+        -- Moves.
+        | MOV         Format Operand Operand
+        | CMOV   Cond Format Operand Reg
+        | MOVZxL      Format Operand Operand -- format is the size of operand 1
+        | MOVSxL      Format Operand Operand -- format is the size of operand 1
+        -- x86_64 note: plain mov into a 32-bit register always zero-extends
+        -- into the 64-bit reg, in contrast to the 8 and 16-bit movs which
+        -- don't affect the high bits of the register.
+
+        -- Load effective address (also a very useful three-operand add instruction :-)
+        | LEA         Format Operand Operand
+
+        -- Int Arithmetic.
+        | ADD         Format Operand Operand
+        | ADC         Format Operand Operand
+        | SUB         Format Operand Operand
+        | SBB         Format Operand Operand
+
+        | MUL         Format Operand Operand
+        | MUL2        Format Operand         -- %edx:%eax = operand * %rax
+        | IMUL        Format Operand Operand -- signed int mul
+        | IMUL2       Format Operand         -- %edx:%eax = operand * %eax
+
+        | DIV         Format Operand         -- eax := eax:edx/op, edx := eax:edx%op
+        | IDIV        Format Operand         -- ditto, but signed
+
+        -- Int Arithmetic, where the effects on the condition register
+        -- are important. Used in specialized sequences such as MO_Add2.
+        -- Do not rewrite these instructions to "equivalent" ones that
+        -- have different effect on the condition register! (See #9013.)
+        | ADD_CC      Format Operand Operand
+        | SUB_CC      Format Operand Operand
+
+        -- Simple bit-twiddling.
+        | AND         Format Operand Operand
+        | OR          Format Operand Operand
+        | XOR         Format Operand Operand
+        | NOT         Format Operand
+        | NEGI        Format Operand         -- NEG instruction (name clash with Cond)
+        | BSWAP       Format Reg
+
+        -- Shifts (amount may be immediate or %cl only)
+        | SHL         Format Operand{-amount-} Operand
+        | SAR         Format Operand{-amount-} Operand
+        | SHR         Format Operand{-amount-} Operand
+
+        | BT          Format Imm Operand
+        | NOP
+
+        -- x86 Float Arithmetic.
+        -- Note that we cheat by treating G{ABS,MOV,NEG} of doubles
+        -- as single instructions right up until we spit them out.
+        -- all the 3-operand fake fp insns are src1 src2 dst
+        -- and furthermore are constrained to be fp regs only.
+        -- IMPORTANT: keep is_G_insn up to date with any changes here
+        | GMOV        Reg Reg -- src(fpreg), dst(fpreg)
+        | GLD         Format AddrMode Reg -- src, dst(fpreg)
+        | GST         Format Reg AddrMode -- src(fpreg), dst
+
+        | GLDZ        Reg -- dst(fpreg)
+        | GLD1        Reg -- dst(fpreg)
+
+        | GFTOI       Reg Reg -- src(fpreg), dst(intreg)
+        | GDTOI       Reg Reg -- src(fpreg), dst(intreg)
+
+        | GITOF       Reg Reg -- src(intreg), dst(fpreg)
+        | GITOD       Reg Reg -- src(intreg), dst(fpreg)
+
+        | GDTOF       Reg Reg -- src(fpreg), dst(fpreg)
+
+        | GADD        Format Reg Reg Reg -- src1, src2, dst
+        | GDIV        Format Reg Reg Reg -- src1, src2, dst
+        | GSUB        Format Reg Reg Reg -- src1, src2, dst
+        | GMUL        Format Reg Reg Reg -- src1, src2, dst
+
+                -- FP compare.  Cond must be `elem` [EQQ, NE, LE, LTT, GE, GTT]
+                -- Compare src1 with src2; set the Zero flag iff the numbers are
+                -- comparable and the comparison is True.  Subsequent code must
+                -- test the %eflags zero flag regardless of the supplied Cond.
+        | GCMP        Cond Reg Reg -- src1, src2
+
+        | GABS        Format Reg Reg -- src, dst
+        | GNEG        Format Reg Reg -- src, dst
+        | GSQRT       Format Reg Reg -- src, dst
+        | GSIN        Format CLabel CLabel Reg Reg -- src, dst
+        | GCOS        Format CLabel CLabel Reg Reg -- src, dst
+        | GTAN        Format CLabel CLabel Reg Reg -- src, dst
+
+        | GFREE         -- do ffree on all x86 regs; an ugly hack
+
+
+        -- SSE2 floating point: we use a restricted set of the available SSE2
+        -- instructions for floating-point.
+        -- use MOV for moving (either movss or movsd (movlpd better?))
+        | CVTSS2SD      Reg Reg            -- F32 to F64
+        | CVTSD2SS      Reg Reg            -- F64 to F32
+        | CVTTSS2SIQ    Format Operand Reg -- F32 to I32/I64 (with truncation)
+        | CVTTSD2SIQ    Format Operand Reg -- F64 to I32/I64 (with truncation)
+        | CVTSI2SS      Format Operand Reg -- I32/I64 to F32
+        | CVTSI2SD      Format Operand Reg -- I32/I64 to F64
+
+        -- use ADD, SUB, and SQRT for arithmetic.  In both cases, operands
+        -- are  Operand Reg.
+
+        -- SSE2 floating-point division:
+        | FDIV          Format Operand Operand   -- divisor, dividend(dst)
+
+        -- use CMP for comparisons.  ucomiss and ucomisd instructions
+        -- compare single/double prec floating point respectively.
+
+        | SQRT          Format Operand Reg      -- src, dst
+
+
+        -- Comparison
+        | TEST          Format Operand Operand
+        | CMP           Format Operand Operand
+        | SETCC         Cond Operand
+
+        -- Stack Operations.
+        | PUSH          Format Operand
+        | POP           Format Operand
+        -- both unused (SDM):
+        --  | PUSHA
+        --  | POPA
+
+        -- Jumping around.
+        | JMP         Operand [Reg] -- including live Regs at the call
+        | JXX         Cond BlockId  -- includes unconditional branches
+        | JXX_GBL     Cond Imm      -- non-local version of JXX
+        -- Table jump
+        | JMP_TBL     Operand   -- Address to jump to
+                      [Maybe JumpDest] -- Targets of the jump table
+                      Section   -- Data section jump table should be put in
+                      CLabel    -- Label of jump table
+        | CALL        (Either Imm Reg) [Reg]
+
+        -- Other things.
+        | CLTD Format            -- sign extend %eax into %edx:%eax
+
+        | FETCHGOT    Reg        -- pseudo-insn for ELF position-independent code
+                                 -- pretty-prints as
+                                 --       call 1f
+                                 -- 1:    popl %reg
+                                 --       addl __GLOBAL_OFFSET_TABLE__+.-1b, %reg
+        | FETCHPC     Reg        -- pseudo-insn for Darwin position-independent code
+                                 -- pretty-prints as
+                                 --       call 1f
+                                 -- 1:    popl %reg
+
+    -- bit counting instructions
+        | POPCNT      Format Operand Reg -- [SSE4.2] count number of bits set to 1
+        | BSF         Format Operand Reg -- bit scan forward
+        | BSR         Format Operand Reg -- bit scan reverse
+
+    -- bit manipulation instructions
+        | PDEP        Format Operand Operand Reg -- [BMI2] deposit bits to   the specified mask
+        | PEXT        Format Operand Operand Reg -- [BMI2] extract bits from the specified mask
+
+    -- prefetch
+        | PREFETCH  PrefetchVariant Format Operand -- prefetch Variant, addr size, address to prefetch
+                                        -- variant can be NTA, Lvl0, Lvl1, or Lvl2
+
+        | LOCK        Instr -- lock prefix
+        | XADD        Format Operand Operand -- src (r), dst (r/m)
+        | CMPXCHG     Format Operand Operand -- src (r), dst (r/m), eax implicit
+        | MFENCE
+
+data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2
+
+
+data Operand
+        = OpReg  Reg            -- register
+        | OpImm  Imm            -- immediate value
+        | OpAddr AddrMode       -- memory reference
+
+
+
+-- | Returns which registers are read and written as a (read, written)
+-- pair.
+x86_regUsageOfInstr :: Platform -> Instr -> RegUsage
+x86_regUsageOfInstr platform instr
+ = case instr of
+    MOV    _ src dst    -> usageRW src dst
+    CMOV _ _ src dst    -> mkRU (use_R src [dst]) [dst]
+    MOVZxL _ src dst    -> usageRW src dst
+    MOVSxL _ src dst    -> usageRW src dst
+    LEA    _ src dst    -> usageRW src dst
+    ADD    _ src dst    -> usageRM src dst
+    ADC    _ src dst    -> usageRM src dst
+    SUB    _ src dst    -> usageRM src dst
+    SBB    _ src dst    -> usageRM src dst
+    IMUL   _ src dst    -> usageRM src dst
+
+    -- Result of IMULB will be in just in %ax
+    IMUL2  II8 src       -> mkRU (eax:use_R src []) [eax]
+    -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and
+    -- %ax/%eax/%rax.
+    IMUL2  _ src        -> mkRU (eax:use_R src []) [eax,edx]
+
+    MUL    _ src dst    -> usageRM src dst
+    MUL2   _ src        -> mkRU (eax:use_R src []) [eax,edx]
+    DIV    _ op -> mkRU (eax:edx:use_R op []) [eax,edx]
+    IDIV   _ op -> mkRU (eax:edx:use_R op []) [eax,edx]
+    ADD_CC _ src dst    -> usageRM src dst
+    SUB_CC _ src dst    -> usageRM src dst
+    AND    _ src dst    -> usageRM src dst
+    OR     _ src dst    -> usageRM src dst
+
+    XOR    _ (OpReg src) (OpReg dst)
+        | src == dst    -> mkRU [] [dst]
+
+    XOR    _ src dst    -> usageRM src dst
+    NOT    _ op         -> usageM op
+    BSWAP  _ reg        -> mkRU [reg] [reg]
+    NEGI   _ op         -> usageM op
+    SHL    _ imm dst    -> usageRM imm dst
+    SAR    _ imm dst    -> usageRM imm dst
+    SHR    _ imm dst    -> usageRM imm dst
+    BT     _ _   src    -> mkRUR (use_R src [])
+
+    PUSH   _ op         -> mkRUR (use_R op [])
+    POP    _ op         -> mkRU [] (def_W op)
+    TEST   _ src dst    -> mkRUR (use_R src $! use_R dst [])
+    CMP    _ src dst    -> mkRUR (use_R src $! use_R dst [])
+    SETCC  _ op         -> mkRU [] (def_W op)
+    JXX    _ _          -> mkRU [] []
+    JXX_GBL _ _         -> mkRU [] []
+    JMP     op regs     -> mkRUR (use_R op regs)
+    JMP_TBL op _ _ _    -> mkRUR (use_R op [])
+    CALL (Left _)  params   -> mkRU params (callClobberedRegs platform)
+    CALL (Right reg) params -> mkRU (reg:params) (callClobberedRegs platform)
+    CLTD   _            -> mkRU [eax] [edx]
+    NOP                 -> mkRU [] []
+
+    GMOV   src dst      -> mkRU [src] [dst]
+    GLD    _ src dst    -> mkRU (use_EA src []) [dst]
+    GST    _ src dst    -> mkRUR (src : use_EA dst [])
+
+    GLDZ   dst          -> mkRU [] [dst]
+    GLD1   dst          -> mkRU [] [dst]
+
+    GFTOI  src dst      -> mkRU [src] [dst]
+    GDTOI  src dst      -> mkRU [src] [dst]
+
+    GITOF  src dst      -> mkRU [src] [dst]
+    GITOD  src dst      -> mkRU [src] [dst]
+
+    GDTOF  src dst      -> mkRU [src] [dst]
+
+    GADD   _ s1 s2 dst  -> mkRU [s1,s2] [dst]
+    GSUB   _ s1 s2 dst  -> mkRU [s1,s2] [dst]
+    GMUL   _ s1 s2 dst  -> mkRU [s1,s2] [dst]
+    GDIV   _ s1 s2 dst  -> mkRU [s1,s2] [dst]
+
+    GCMP   _ src1 src2   -> mkRUR [src1,src2]
+    GABS   _ src dst     -> mkRU [src] [dst]
+    GNEG   _ src dst     -> mkRU [src] [dst]
+    GSQRT  _ src dst     -> mkRU [src] [dst]
+    GSIN   _ _ _ src dst -> mkRU [src] [dst]
+    GCOS   _ _ _ src dst -> mkRU [src] [dst]
+    GTAN   _ _ _ src dst -> mkRU [src] [dst]
+
+    CVTSS2SD   src dst  -> mkRU [src] [dst]
+    CVTSD2SS   src dst  -> mkRU [src] [dst]
+    CVTTSS2SIQ _ src dst -> mkRU (use_R src []) [dst]
+    CVTTSD2SIQ _ src dst -> mkRU (use_R src []) [dst]
+    CVTSI2SS   _ src dst -> mkRU (use_R src []) [dst]
+    CVTSI2SD   _ src dst -> mkRU (use_R src []) [dst]
+    FDIV _     src dst  -> usageRM src dst
+    SQRT _ src dst      -> mkRU (use_R src []) [dst]
+
+    FETCHGOT reg        -> mkRU [] [reg]
+    FETCHPC  reg        -> mkRU [] [reg]
+
+    COMMENT _           -> noUsage
+    LOCATION{}          -> noUsage
+    UNWIND{}            -> noUsage
+    DELTA   _           -> noUsage
+
+    POPCNT _ src dst -> mkRU (use_R src []) [dst]
+    BSF    _ src dst -> mkRU (use_R src []) [dst]
+    BSR    _ src dst -> mkRU (use_R src []) [dst]
+
+    PDEP   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]
+    PEXT   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]
+
+    -- note: might be a better way to do this
+    PREFETCH _  _ src -> mkRU (use_R src []) []
+    LOCK i              -> x86_regUsageOfInstr platform i
+    XADD _ src dst      -> usageMM src dst
+    CMPXCHG _ src dst   -> usageRMM src dst (OpReg eax)
+    MFENCE -> noUsage
+
+    _other              -> panic "regUsage: unrecognised instr"
+ where
+    -- # Definitions
+    --
+    -- Written: If the operand is a register, it's written. If it's an
+    -- address, registers mentioned in the address are read.
+    --
+    -- Modified: If the operand is a register, it's both read and
+    -- written. If it's an address, registers mentioned in the address
+    -- are read.
+
+    -- 2 operand form; first operand Read; second Written
+    usageRW :: Operand -> Operand -> RegUsage
+    usageRW op (OpReg reg)      = mkRU (use_R op []) [reg]
+    usageRW op (OpAddr ea)      = mkRUR (use_R op $! use_EA ea [])
+    usageRW _ _                 = panic "X86.RegInfo.usageRW: no match"
+
+    -- 2 operand form; first operand Read; second Modified
+    usageRM :: Operand -> Operand -> RegUsage
+    usageRM op (OpReg reg)      = mkRU (use_R op [reg]) [reg]
+    usageRM op (OpAddr ea)      = mkRUR (use_R op $! use_EA ea [])
+    usageRM _ _                 = panic "X86.RegInfo.usageRM: no match"
+
+    -- 2 operand form; first operand Modified; second Modified
+    usageMM :: Operand -> Operand -> RegUsage
+    usageMM (OpReg src) (OpReg dst) = mkRU [src, dst] [src, dst]
+    usageMM (OpReg src) (OpAddr ea) = mkRU (use_EA ea [src]) [src]
+    usageMM _ _                     = panic "X86.RegInfo.usageMM: no match"
+
+    -- 3 operand form; first operand Read; second Modified; third Modified
+    usageRMM :: Operand -> Operand -> Operand -> RegUsage
+    usageRMM (OpReg src) (OpReg dst) (OpReg reg) = mkRU [src, dst, reg] [dst, reg]
+    usageRMM (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [src, reg]) [reg]
+    usageRMM _ _ _                               = panic "X86.RegInfo.usageRMM: no match"
+
+    -- 1 operand form; operand Modified
+    usageM :: Operand -> RegUsage
+    usageM (OpReg reg)          = mkRU [reg] [reg]
+    usageM (OpAddr ea)          = mkRUR (use_EA ea [])
+    usageM _                    = panic "X86.RegInfo.usageM: no match"
+
+    -- Registers defd when an operand is written.
+    def_W (OpReg reg)           = [reg]
+    def_W (OpAddr _ )           = []
+    def_W _                     = panic "X86.RegInfo.def_W: no match"
+
+    -- Registers used when an operand is read.
+    use_R (OpReg reg)  tl = reg : tl
+    use_R (OpImm _)    tl = tl
+    use_R (OpAddr ea)  tl = use_EA ea tl
+
+    -- Registers used to compute an effective address.
+    use_EA (ImmAddr _ _) tl = tl
+    use_EA (AddrBaseIndex base index _) tl =
+        use_base base $! use_index index tl
+        where use_base (EABaseReg r)  tl = r : tl
+              use_base _              tl = tl
+              use_index EAIndexNone   tl = tl
+              use_index (EAIndex i _) tl = i : tl
+
+    mkRUR src = src' `seq` RU src' []
+        where src' = filter (interesting platform) src
+
+    mkRU src dst = src' `seq` dst' `seq` RU src' dst'
+        where src' = filter (interesting platform) src
+              dst' = filter (interesting platform) dst
+
+-- | Is this register interesting for the register allocator?
+interesting :: Platform -> Reg -> Bool
+interesting _        (RegVirtual _)              = True
+interesting platform (RegReal (RealRegSingle i)) = freeReg platform i
+interesting _        (RegReal (RealRegPair{}))   = panic "X86.interesting: no reg pairs on this arch"
+
+
+
+-- | Applies the supplied function to all registers in instructions.
+-- Typically used to change virtual registers to real registers.
+x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
+x86_patchRegsOfInstr instr env
+ = case instr of
+    MOV  fmt src dst     -> patch2 (MOV  fmt) src dst
+    CMOV cc fmt src dst  -> CMOV cc fmt (patchOp src) (env dst)
+    MOVZxL fmt src dst   -> patch2 (MOVZxL fmt) src dst
+    MOVSxL fmt src dst   -> patch2 (MOVSxL fmt) src dst
+    LEA  fmt src dst     -> patch2 (LEA  fmt) src dst
+    ADD  fmt src dst     -> patch2 (ADD  fmt) src dst
+    ADC  fmt src dst     -> patch2 (ADC  fmt) src dst
+    SUB  fmt src dst     -> patch2 (SUB  fmt) src dst
+    SBB  fmt src dst     -> patch2 (SBB  fmt) src dst
+    IMUL fmt src dst     -> patch2 (IMUL fmt) src dst
+    IMUL2 fmt src        -> patch1 (IMUL2 fmt) src
+    MUL fmt src dst      -> patch2 (MUL fmt) src dst
+    MUL2 fmt src         -> patch1 (MUL2 fmt) src
+    IDIV fmt op          -> patch1 (IDIV fmt) op
+    DIV fmt op           -> patch1 (DIV fmt) op
+    ADD_CC fmt src dst   -> patch2 (ADD_CC fmt) src dst
+    SUB_CC fmt src dst   -> patch2 (SUB_CC fmt) src dst
+    AND  fmt src dst     -> patch2 (AND  fmt) src dst
+    OR   fmt src dst     -> patch2 (OR   fmt) src dst
+    XOR  fmt src dst     -> patch2 (XOR  fmt) src dst
+    NOT  fmt op          -> patch1 (NOT  fmt) op
+    BSWAP fmt reg        -> BSWAP fmt (env reg)
+    NEGI fmt op          -> patch1 (NEGI fmt) op
+    SHL  fmt imm dst     -> patch1 (SHL fmt imm) dst
+    SAR  fmt imm dst     -> patch1 (SAR fmt imm) dst
+    SHR  fmt imm dst     -> patch1 (SHR fmt imm) dst
+    BT   fmt imm src     -> patch1 (BT  fmt imm) src
+    TEST fmt src dst     -> patch2 (TEST fmt) src dst
+    CMP  fmt src dst     -> patch2 (CMP  fmt) src dst
+    PUSH fmt op          -> patch1 (PUSH fmt) op
+    POP  fmt op          -> patch1 (POP  fmt) op
+    SETCC cond op        -> patch1 (SETCC cond) op
+    JMP op regs          -> JMP (patchOp op) regs
+    JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl
+
+    GMOV src dst         -> GMOV (env src) (env dst)
+    GLD  fmt src dst     -> GLD fmt (lookupAddr src) (env dst)
+    GST  fmt src dst     -> GST fmt (env src) (lookupAddr dst)
+
+    GLDZ dst            -> GLDZ (env dst)
+    GLD1 dst            -> GLD1 (env dst)
+
+    GFTOI src dst       -> GFTOI (env src) (env dst)
+    GDTOI src dst       -> GDTOI (env src) (env dst)
+
+    GITOF src dst       -> GITOF (env src) (env dst)
+    GITOD src dst       -> GITOD (env src) (env dst)
+
+    GDTOF src dst       -> GDTOF (env src) (env dst)
+
+    GADD fmt s1 s2 dst   -> GADD fmt (env s1) (env s2) (env dst)
+    GSUB fmt s1 s2 dst   -> GSUB fmt (env s1) (env s2) (env dst)
+    GMUL fmt s1 s2 dst   -> GMUL fmt (env s1) (env s2) (env dst)
+    GDIV fmt s1 s2 dst   -> GDIV fmt (env s1) (env s2) (env dst)
+
+    GCMP fmt src1 src2   -> GCMP fmt (env src1) (env src2)
+    GABS fmt src dst     -> GABS fmt (env src) (env dst)
+    GNEG fmt src dst     -> GNEG fmt (env src) (env dst)
+    GSQRT fmt src dst    -> GSQRT fmt (env src) (env dst)
+    GSIN fmt l1 l2 src dst       -> GSIN fmt l1 l2 (env src) (env dst)
+    GCOS fmt l1 l2 src dst       -> GCOS fmt l1 l2 (env src) (env dst)
+    GTAN fmt l1 l2 src dst       -> GTAN fmt l1 l2 (env src) (env dst)
+
+    CVTSS2SD src dst    -> CVTSS2SD (env src) (env dst)
+    CVTSD2SS src dst    -> CVTSD2SS (env src) (env dst)
+    CVTTSS2SIQ fmt src dst -> CVTTSS2SIQ fmt (patchOp src) (env dst)
+    CVTTSD2SIQ fmt src dst -> CVTTSD2SIQ fmt (patchOp src) (env dst)
+    CVTSI2SS fmt src dst -> CVTSI2SS fmt (patchOp src) (env dst)
+    CVTSI2SD fmt src dst -> CVTSI2SD fmt (patchOp src) (env dst)
+    FDIV fmt src dst     -> FDIV fmt (patchOp src) (patchOp dst)
+    SQRT fmt src dst    -> SQRT fmt (patchOp src) (env dst)
+
+    CALL (Left _)  _    -> instr
+    CALL (Right reg) p  -> CALL (Right (env reg)) p
+
+    FETCHGOT reg        -> FETCHGOT (env reg)
+    FETCHPC  reg        -> FETCHPC  (env reg)
+
+    NOP                 -> instr
+    COMMENT _           -> instr
+    LOCATION {}         -> instr
+    UNWIND {}           -> instr
+    DELTA _             -> instr
+
+    JXX _ _             -> instr
+    JXX_GBL _ _         -> instr
+    CLTD _              -> instr
+
+    POPCNT fmt src dst -> POPCNT fmt (patchOp src) (env dst)
+    PDEP   fmt src mask dst -> PDEP   fmt (patchOp src) (patchOp mask) (env dst)
+    PEXT   fmt src mask dst -> PEXT   fmt (patchOp src) (patchOp mask) (env dst)
+    BSF    fmt src dst -> BSF    fmt (patchOp src) (env dst)
+    BSR    fmt src dst -> BSR    fmt (patchOp src) (env dst)
+
+    PREFETCH lvl format src -> PREFETCH lvl format (patchOp src)
+
+    LOCK i               -> LOCK (x86_patchRegsOfInstr i env)
+    XADD fmt src dst     -> patch2 (XADD fmt) src dst
+    CMPXCHG fmt src dst  -> patch2 (CMPXCHG fmt) src dst
+    MFENCE               -> instr
+
+    _other              -> panic "patchRegs: unrecognised instr"
+
+  where
+    patch1 :: (Operand -> a) -> Operand -> a
+    patch1 insn op      = insn $! patchOp op
+    patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a
+    patch2 insn src dst = (insn $! patchOp src) $! patchOp dst
+
+    patchOp (OpReg  reg) = OpReg $! env reg
+    patchOp (OpImm  imm) = OpImm imm
+    patchOp (OpAddr ea)  = OpAddr $! lookupAddr ea
+
+    lookupAddr (ImmAddr imm off) = ImmAddr imm off
+    lookupAddr (AddrBaseIndex base index disp)
+      = ((AddrBaseIndex $! lookupBase base) $! lookupIndex index) disp
+      where
+        lookupBase EABaseNone       = EABaseNone
+        lookupBase EABaseRip        = EABaseRip
+        lookupBase (EABaseReg r)    = EABaseReg $! env r
+
+        lookupIndex EAIndexNone     = EAIndexNone
+        lookupIndex (EAIndex r i)   = (EAIndex $! env r) i
+
+
+--------------------------------------------------------------------------------
+x86_isJumpishInstr
+        :: Instr -> Bool
+
+x86_isJumpishInstr instr
+ = case instr of
+        JMP{}           -> True
+        JXX{}           -> True
+        JXX_GBL{}       -> True
+        JMP_TBL{}       -> True
+        CALL{}          -> True
+        _               -> False
+
+
+x86_jumpDestsOfInstr
+        :: Instr
+        -> [BlockId]
+
+x86_jumpDestsOfInstr insn
+  = case insn of
+        JXX _ id        -> [id]
+        JMP_TBL _ ids _ _ -> [id | Just (DestBlockId id) <- ids]
+        _               -> []
+
+
+x86_patchJumpInstr
+        :: Instr -> (BlockId -> BlockId) -> Instr
+
+x86_patchJumpInstr insn patchF
+  = case insn of
+        JXX cc id       -> JXX cc (patchF id)
+        JMP_TBL op ids section lbl
+          -> JMP_TBL op (map (fmap (patchJumpDest patchF)) ids) section lbl
+        _               -> insn
+    where
+        patchJumpDest f (DestBlockId id) = DestBlockId (f id)
+        patchJumpDest _ dest             = dest
+
+
+
+
+
+-- -----------------------------------------------------------------------------
+-- | Make a spill instruction.
+x86_mkSpillInstr
+    :: DynFlags
+    -> Reg      -- register to spill
+    -> Int      -- current stack delta
+    -> Int      -- spill slot to use
+    -> Instr
+
+x86_mkSpillInstr dflags reg delta slot
+  = let off     = spillSlotToOffset platform slot - delta
+    in
+    case targetClassOfReg platform reg of
+           RcInteger   -> MOV (archWordFormat is32Bit)
+                              (OpReg reg) (OpAddr (spRel dflags off))
+           RcDouble    -> GST FF80 reg (spRel dflags off) {- RcFloat/RcDouble -}
+           RcDoubleSSE -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off))
+           _         -> panic "X86.mkSpillInstr: no match"
+    where platform = targetPlatform dflags
+          is32Bit = target32Bit platform
+
+-- | Make a spill reload instruction.
+x86_mkLoadInstr
+    :: DynFlags
+    -> Reg      -- register to load
+    -> Int      -- current stack delta
+    -> Int      -- spill slot to use
+    -> Instr
+
+x86_mkLoadInstr dflags reg delta slot
+  = let off     = spillSlotToOffset platform slot - delta
+    in
+        case targetClassOfReg platform reg of
+              RcInteger -> MOV (archWordFormat is32Bit)
+                               (OpAddr (spRel dflags off)) (OpReg reg)
+              RcDouble  -> GLD FF80 (spRel dflags off) reg {- RcFloat/RcDouble -}
+              RcDoubleSSE -> MOV FF64 (OpAddr (spRel dflags off)) (OpReg reg)
+              _           -> panic "X86.x86_mkLoadInstr"
+    where platform = targetPlatform dflags
+          is32Bit = target32Bit platform
+
+spillSlotSize :: Platform -> Int
+spillSlotSize dflags = if is32Bit then 12 else 8
+    where is32Bit = target32Bit dflags
+
+maxSpillSlots :: DynFlags -> Int
+maxSpillSlots dflags
+    = ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize (targetPlatform dflags)) - 1
+--     = 0 -- useful for testing allocMoreStack
+
+-- number of bytes that the stack pointer should be aligned to
+stackAlign :: Int
+stackAlign = 16
+
+-- convert a spill slot number to a *byte* offset, with no sign:
+-- decide on a per arch basis whether you are spilling above or below
+-- the C stack pointer.
+spillSlotToOffset :: Platform -> Int -> Int
+spillSlotToOffset platform slot
+   = 64 + spillSlotSize platform * slot
+
+--------------------------------------------------------------------------------
+
+-- | See if this instruction is telling us the current C stack delta
+x86_takeDeltaInstr
+        :: Instr
+        -> Maybe Int
+
+x86_takeDeltaInstr instr
+ = case instr of
+        DELTA i         -> Just i
+        _               -> Nothing
+
+
+x86_isMetaInstr
+        :: Instr
+        -> Bool
+
+x86_isMetaInstr instr
+ = case instr of
+        COMMENT{}       -> True
+        LOCATION{}      -> True
+        LDATA{}         -> True
+        NEWBLOCK{}      -> True
+        UNWIND{}        -> True
+        DELTA{}         -> True
+        _               -> False
+
+
+
+-- | Make a reg-reg move instruction.
+--      On SPARC v8 there are no instructions to move directly between
+--      floating point and integer regs. If we need to do that then we
+--      have to go via memory.
+--
+x86_mkRegRegMoveInstr
+    :: Platform
+    -> Reg
+    -> Reg
+    -> Instr
+
+x86_mkRegRegMoveInstr platform src dst
+ = case targetClassOfReg platform src of
+        RcInteger -> case platformArch platform of
+                     ArchX86    -> MOV II32 (OpReg src) (OpReg dst)
+                     ArchX86_64 -> MOV II64 (OpReg src) (OpReg dst)
+                     _          -> panic "x86_mkRegRegMoveInstr: Bad arch"
+        RcDouble    -> GMOV src dst
+        RcDoubleSSE -> MOV FF64 (OpReg src) (OpReg dst)
+        _     -> panic "X86.RegInfo.mkRegRegMoveInstr: no match"
+
+-- | Check whether an instruction represents a reg-reg move.
+--      The register allocator attempts to eliminate reg->reg moves whenever it can,
+--      by assigning the src and dest temporaries to the same real register.
+--
+x86_takeRegRegMoveInstr
+        :: Instr
+        -> Maybe (Reg,Reg)
+
+x86_takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2))
+        = Just (r1,r2)
+
+x86_takeRegRegMoveInstr _  = Nothing
+
+
+-- | Make an unconditional branch instruction.
+x86_mkJumpInstr
+        :: BlockId
+        -> [Instr]
+
+x86_mkJumpInstr id
+        = [JXX ALWAYS id]
+
+-- Note [Windows stack layout]
+-- | On most OSes the kernel will place a guard page after the current stack
+--   page.  If you allocate larger than a page worth you may jump over this
+--   guard page.  Not only is this a security issue, but on certain OSes such
+--   as Windows a new page won't be allocated if you don't hit the guard.  This
+--   will cause a segfault or access fault.
+--
+--   This function defines if the current allocation amount requires a probe.
+--   On Windows (for now) we emit a call to _chkstk for this.  For other OSes
+--   this is not yet implemented.
+--   See https://docs.microsoft.com/en-us/windows/desktop/DevNotes/-win32-chkstk
+--   The Windows stack looks like this:
+--
+--                         +-------------------+
+--                         |        SP         |
+--                         +-------------------+
+--                         |                   |
+--                         |    GUARD PAGE     |
+--                         |                   |
+--                         +-------------------+
+--                         |                   |
+--                         |                   |
+--                         |     UNMAPPED      |
+--                         |                   |
+--                         |                   |
+--                         +-------------------+
+--
+--   In essense each allocation larger than a page size needs to be chunked and
+--   a probe emitted after each page allocation.  You have to hit the guard
+--   page so the kernel can map in the next page, otherwise you'll segfault.
+--
+needs_probe_call :: Platform -> Int -> Bool
+needs_probe_call platform amount
+  = case platformOS platform of
+     OSMinGW32 -> case platformArch platform of
+                    ArchX86    -> amount > (4 * 1024)
+                    ArchX86_64 -> amount > (8 * 1024)
+                    _          -> False
+     _         -> False
+
+x86_mkStackAllocInstr
+        :: Platform
+        -> Int
+        -> [Instr]
+x86_mkStackAllocInstr platform amount
+  = case platformOS platform of
+      OSMinGW32 ->
+        -- These will clobber AX but this should be ok because
+        --
+        -- 1. It is the first thing we do when entering the closure and AX is
+        --    a caller saved registers on Windows both on x86_64 and x86.
+        --
+        -- 2. The closures are only entered via a call or longjmp in which case
+        --    there are no expectations for volatile registers.
+        --
+        -- 3. When the target is a local branch point it is re-targeted
+        --    after the dealloc, preserving #2.  See note [extra spill slots].
+        --
+        -- We emit a call because the stack probes are quite involved and
+        -- would bloat code size a lot.  GHC doesn't really have an -Os.
+        -- __chkstk is guaranteed to leave all nonvolatile registers and AX
+        -- untouched.  It's part of the standard prologue code for any Windows
+        -- function dropping the stack more than a page.
+        -- See Note [Windows stack layout]
+        case platformArch platform of
+            ArchX86    | needs_probe_call platform amount ->
+                           [ MOV II32 (OpImm (ImmInt amount)) (OpReg eax)
+                           , CALL (Left $ strImmLit "___chkstk_ms") [eax]
+                           , SUB II32 (OpReg eax) (OpReg esp)
+                           ]
+                       | otherwise ->
+                           [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp)
+                           , TEST II32 (OpReg esp) (OpReg esp)
+                           ]
+            ArchX86_64 | needs_probe_call platform amount ->
+                           [ MOV II64 (OpImm (ImmInt amount)) (OpReg rax)
+                           , CALL (Left $ strImmLit "__chkstk_ms") [rax]
+                           , SUB II64 (OpReg rax) (OpReg rsp)
+                           ]
+                       | otherwise ->
+                           [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp)
+                           , TEST II64 (OpReg rsp) (OpReg rsp)
+                           ]
+            _ -> panic "x86_mkStackAllocInstr"
+      _       ->
+        case platformArch platform of
+          ArchX86    -> [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp) ]
+          ArchX86_64 -> [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) ]
+          _ -> panic "x86_mkStackAllocInstr"
+
+x86_mkStackDeallocInstr
+        :: Platform
+        -> Int
+        -> [Instr]
+x86_mkStackDeallocInstr platform amount
+  = case platformArch platform of
+      ArchX86    -> [ADD II32 (OpImm (ImmInt amount)) (OpReg esp)]
+      ArchX86_64 -> [ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)]
+      _ -> panic "x86_mkStackDeallocInstr"
+
+i386_insert_ffrees
+        :: [GenBasicBlock Instr]
+        -> [GenBasicBlock Instr]
+
+i386_insert_ffrees blocks
+   | any (any is_G_instr) [ instrs | BasicBlock _ instrs <- blocks ]
+   = map insertGFREEs blocks
+   | otherwise
+   = blocks
+ where
+   insertGFREEs (BasicBlock id insns)
+     = BasicBlock id (insertBeforeNonlocalTransfers GFREE insns)
+
+insertBeforeNonlocalTransfers :: Instr -> [Instr] -> [Instr]
+insertBeforeNonlocalTransfers insert insns
+     = foldr p [] insns
+     where p insn r = case insn of
+                        CALL _ _    -> insert : insn : r
+                        JMP _ _     -> insert : insn : r
+                        JXX_GBL _ _ -> panic "insertBeforeNonlocalTransfers: cannot handle JXX_GBL"
+                        _           -> insn : r
+
+
+-- if you ever add a new FP insn to the fake x86 FP insn set,
+-- you must update this too
+is_G_instr :: Instr -> Bool
+is_G_instr instr
+   = case instr of
+        GMOV{}          -> True
+        GLD{}           -> True
+        GST{}           -> True
+        GLDZ{}          -> True
+        GLD1{}          -> True
+        GFTOI{}         -> True
+        GDTOI{}         -> True
+        GITOF{}         -> True
+        GITOD{}         -> True
+        GDTOF{}         -> True
+        GADD{}          -> True
+        GDIV{}          -> True
+        GSUB{}          -> True
+        GMUL{}          -> True
+        GCMP{}          -> True
+        GABS{}          -> True
+        GNEG{}          -> True
+        GSQRT{}         -> True
+        GSIN{}          -> True
+        GCOS{}          -> True
+        GTAN{}          -> True
+        GFREE           -> panic "is_G_instr: GFREE (!)"
+        _               -> False
+
+
+--
+-- Note [extra spill slots]
+--
+-- If the register allocator used more spill slots than we have
+-- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more
+-- C stack space on entry and exit from this proc.  Therefore we
+-- insert a "sub $N, %rsp" at every entry point, and an "add $N, %rsp"
+-- before every non-local jump.
+--
+-- This became necessary when the new codegen started bundling entire
+-- functions together into one proc, because the register allocator
+-- assigns a different stack slot to each virtual reg within a proc.
+-- To avoid using so many slots we could also:
+--
+--   - split up the proc into connected components before code generator
+--
+--   - rename the virtual regs, so that we re-use vreg names and hence
+--     stack slots for non-overlapping vregs.
+--
+-- Note that when a block is both a non-local entry point (with an
+-- info table) and a local branch target, we have to split it into
+-- two, like so:
+--
+--    <info table>
+--    L:
+--       <code>
+--
+-- becomes
+--
+--    <info table>
+--    L:
+--       subl $rsp, N
+--       jmp Lnew
+--    Lnew:
+--       <code>
+--
+-- and all branches pointing to L are retargetted to point to Lnew.
+-- Otherwise, we would repeat the $rsp adjustment for each branch to
+-- L.
+--
+-- Returns a list of (L,Lnew) pairs.
+--
+allocMoreStack
+  :: Platform
+  -> Int
+  -> NatCmmDecl statics X86.Instr.Instr
+  -> UniqSM (NatCmmDecl statics X86.Instr.Instr, [(BlockId,BlockId)])
+
+allocMoreStack _ _ top@(CmmData _ _) = return (top,[])
+allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do
+    let entries = entryBlocks proc
+
+    uniqs <- replicateM (length entries) getUniqueM
+
+    let
+      delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
+        where x = slots * spillSlotSize platform -- sp delta
+
+      alloc   = mkStackAllocInstr   platform delta
+      dealloc = mkStackDeallocInstr platform delta
+
+      retargetList = (zip entries (map mkBlockId uniqs))
+
+      new_blockmap :: LabelMap BlockId
+      new_blockmap = mapFromList retargetList
+
+      insert_stack_insns (BasicBlock id insns)
+         | Just new_blockid <- mapLookup id new_blockmap
+         = [ BasicBlock id $ alloc ++ [JXX ALWAYS new_blockid]
+           , BasicBlock new_blockid block' ]
+         | otherwise
+         = [ BasicBlock id block' ]
+         where
+           block' = foldr insert_dealloc [] insns
+
+      insert_dealloc insn r = case insn of
+         JMP _ _     -> dealloc ++ (insn : r)
+         JXX_GBL _ _ -> panic "insert_dealloc: cannot handle JXX_GBL"
+         _other      -> x86_patchJumpInstr insn retarget : r
+           where retarget b = fromMaybe b (mapLookup b new_blockmap)
+
+      new_code = concatMap insert_stack_insns code
+    -- in
+    return (CmmProc info lbl live (ListGraph new_code), retargetList)
+
+data JumpDest = DestBlockId BlockId | DestImm Imm
+
+-- Debug Instance
+instance Outputable JumpDest where
+  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid
+  ppr (DestImm _imm)    = text "jd<imm>:noShow"
+
+
+getJumpDestBlockId :: JumpDest -> Maybe BlockId
+getJumpDestBlockId (DestBlockId bid) = Just bid
+getJumpDestBlockId _                 = Nothing
+
+canShortcut :: Instr -> Maybe JumpDest
+canShortcut (JXX ALWAYS id)      = Just (DestBlockId id)
+canShortcut (JMP (OpImm imm) _)  = Just (DestImm imm)
+canShortcut _                    = Nothing
+
+
+-- This helper shortcuts a sequence of branches.
+-- The blockset helps avoid following cycles.
+shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
+shortcutJump fn insn = shortcutJump' fn (setEmpty :: LabelSet) insn
+  where
+    shortcutJump' :: (BlockId -> Maybe JumpDest) -> LabelSet -> Instr -> Instr
+    shortcutJump' fn seen insn@(JXX cc id) =
+        if setMember id seen then insn
+        else case fn id of
+            Nothing                -> insn
+            Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id')
+            Just (DestImm imm)     -> shortcutJump' fn seen' (JXX_GBL cc imm)
+        where seen' = setInsert id seen
+    shortcutJump' fn _ (JMP_TBL addr blocks section tblId) =
+        let updateBlock (Just (DestBlockId bid))  =
+                case fn bid of
+                    Nothing   -> Just (DestBlockId bid )
+                    Just dest -> Just dest
+            updateBlock dest = dest
+            blocks' = map updateBlock blocks
+        in  JMP_TBL addr blocks' section tblId
+    shortcutJump' _ _ other = other
+
+-- Here because it knows about JumpDest
+shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, CmmStatics) -> (Alignment, CmmStatics)
+shortcutStatics fn (align, Statics lbl statics)
+  = (align, Statics lbl $ map (shortcutStatic fn) statics)
+  -- we need to get the jump tables, so apply the mapping to the entries
+  -- of a CmmData too.
+
+shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel
+shortcutLabel fn lab
+  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn emptyUniqSet blkId
+  | otherwise                              = lab
+
+shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
+shortcutStatic fn (CmmStaticLit (CmmLabel lab))
+  = CmmStaticLit (CmmLabel (shortcutLabel fn lab))
+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w))
+  = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w)
+        -- slightly dodgy, we're ignoring the second label, but this
+        -- works with the way we use CmmLabelDiffOff for jump tables now.
+shortcutStatic _ other_static
+        = other_static
+
+shortBlockId
+        :: (BlockId -> Maybe JumpDest)
+        -> UniqSet Unique
+        -> BlockId
+        -> CLabel
+
+shortBlockId fn seen blockid =
+  case (elementOfUniqSet uq seen, fn blockid) of
+    (True, _)    -> blockLbl blockid
+    (_, Nothing) -> blockLbl blockid
+    (_, Just (DestBlockId blockid'))  -> shortBlockId fn (addOneToUniqSet seen uq) blockid'
+    (_, Just (DestImm (ImmCLbl lbl))) -> lbl
+    (_, _other) -> panic "shortBlockId"
+  where uq = getUnique blockid
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -0,0 +1,1368 @@
+{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing assembly language
+--
+-- (c) The University of Glasgow 1993-2005
+--
+-----------------------------------------------------------------------------
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module X86.Ppr (
+        pprNatCmmDecl,
+        pprData,
+        pprInstr,
+        pprFormat,
+        pprImm,
+        pprDataItem,
+)
+
+where
+
+#include "HsVersions.h"
+#include "nativeGen/NCG.h"
+
+import GhcPrelude
+
+import X86.Regs
+import X86.Instr
+import X86.Cond
+import Instruction
+import Format
+import Reg
+import PprBase
+
+
+import Hoopl.Collections
+import Hoopl.Label
+import BasicTypes       (Alignment)
+import DynFlags
+import Cmm              hiding (topInfoTable)
+import BlockId
+import CLabel
+import Unique           ( pprUniqueAlways )
+import Platform
+import FastString
+import Outputable
+
+import Data.Word
+
+import Data.Bits
+
+-- -----------------------------------------------------------------------------
+-- Printing this stuff out
+--
+--
+-- Note [Subsections Via Symbols]
+--
+-- If we are using the .subsections_via_symbols directive
+-- (available on recent versions of Darwin),
+-- we have to make sure that there is some kind of reference
+-- from the entry code to a label on the _top_ of of the info table,
+-- so that the linker will not think it is unreferenced and dead-strip
+-- it. That's why the label is called a DeadStripPreventer (_dsp).
+--
+-- The LLVM code gen already creates `iTableSuf` symbols, where
+-- the X86 would generate the DeadStripPreventer (_dsp) symbol.
+-- Therefore all that is left for llvm code gen, is to ensure
+-- that all the `iTableSuf` symbols are marked as used.
+-- As of this writing the documentation regarding the
+-- .subsections_via_symbols and -dead_strip can be found at
+-- <https://developer.apple.com/library/mac/documentation/DeveloperTools/Reference/Assembler/040-Assembler_Directives/asm_directives.html#//apple_ref/doc/uid/TP30000823-TPXREF101>
+
+pprProcAlignment :: SDoc
+pprProcAlignment = sdocWithDynFlags $ \dflags ->
+  (maybe empty pprAlign . cmmProcAlignment $ dflags)
+
+pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc
+pprNatCmmDecl (CmmData section dats) =
+  pprSectionAlign section $$ pprDatas dats
+
+pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
+  sdocWithDynFlags $ \dflags ->
+  pprProcAlignment $$
+  case topInfoTable proc of
+    Nothing ->
+       case blocks of
+         []     -> -- special case for split markers:
+           pprLabel lbl
+         blocks -> -- special case for code without info table:
+           pprSectionAlign (Section Text lbl) $$
+           pprProcAlignment $$
+           pprLabel lbl $$ -- blocks guaranteed not null, so label needed
+           vcat (map (pprBasicBlock top_info) blocks) $$
+           (if debugLevel dflags > 0
+            then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
+           pprSizeDecl lbl
+
+    Just (Statics info_lbl _) ->
+      sdocWithPlatform $ \platform ->
+      pprSectionAlign (Section Text info_lbl) $$
+      pprProcAlignment $$
+      (if platformHasSubsectionsViaSymbols platform
+          then ppr (mkDeadStripPreventer info_lbl) <> char ':'
+          else empty) $$
+      vcat (map (pprBasicBlock top_info) blocks) $$
+      -- above: Even the first block gets a label, because with branch-chain
+      -- elimination, it might be the target of a goto.
+      (if platformHasSubsectionsViaSymbols platform
+       then -- See Note [Subsections Via Symbols]
+                text "\t.long "
+            <+> ppr info_lbl
+            <+> char '-'
+            <+> ppr (mkDeadStripPreventer info_lbl)
+       else empty) $$
+      pprSizeDecl info_lbl
+
+-- | Output the ELF .size directive.
+pprSizeDecl :: CLabel -> SDoc
+pprSizeDecl lbl
+ = sdocWithPlatform $ \platform ->
+   if osElfTarget (platformOS platform)
+   then text "\t.size" <+> ppr lbl <> ptext (sLit ", .-") <> ppr lbl
+   else empty
+
+pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc
+pprBasicBlock info_env (BasicBlock blockid instrs)
+  = sdocWithDynFlags $ \dflags ->
+    maybe_infotable dflags $
+    pprLabel asmLbl $$
+    vcat (map pprInstr instrs) $$
+    (if debugLevel dflags > 0
+     then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty)
+  where
+    asmLbl = blockLbl blockid
+    maybe_infotable dflags c = case mapLookup blockid info_env of
+       Nothing -> c
+       Just (Statics infoLbl info) ->
+           pprAlignForSection Text $$
+           infoTableLoc $$
+           vcat (map pprData info) $$
+           pprLabel infoLbl $$
+           c $$
+           (if debugLevel dflags > 0
+            then ppr (mkAsmTempEndLabel infoLbl) <> char ':' else empty)
+    -- Make sure the info table has the right .loc for the block
+    -- coming right after it. See [Note: Info Offset]
+    infoTableLoc = case instrs of
+      (l@LOCATION{} : _) -> pprInstr l
+      _other             -> empty
+
+pprDatas :: (Alignment, CmmStatics) -> SDoc
+pprDatas (align, (Statics lbl dats))
+ = vcat (pprAlign align : pprLabel lbl : map pprData dats)
+
+pprData :: CmmStatic -> SDoc
+pprData (CmmString str)
+ = ptext (sLit "\t.asciz ") <> doubleQuotes (pprASCII str)
+
+pprData (CmmUninitialised bytes)
+ = sdocWithPlatform $ \platform ->
+   if platformOS platform == OSDarwin then text ".space " <> int bytes
+                                      else text ".skip "  <> int bytes
+
+pprData (CmmStaticLit lit) = pprDataItem lit
+
+pprGloblDecl :: CLabel -> SDoc
+pprGloblDecl lbl
+  | not (externallyVisibleCLabel lbl) = empty
+  | otherwise = text ".globl " <> ppr lbl
+
+pprLabelType' :: DynFlags -> CLabel -> SDoc
+pprLabelType' dflags lbl =
+  if isCFunctionLabel lbl || functionOkInfoTable then
+    text "@function"
+  else
+    text "@object"
+  where
+    {-
+    NOTE: This is a bit hacky.
+
+    With the `tablesNextToCode` info tables look like this:
+    ```
+      <info table data>
+    label_info:
+      <info table code>
+    ```
+    So actually info table label points exactly to the code and we can mark
+    the label as @function. (This is required to make perf and potentially other
+    tools to work on Haskell binaries).
+    This usually works well but it can cause issues with a linker.
+    A linker uses different algorithms for the relocation depending on
+    the symbol type.For some reason, a linker will generate JUMP_SLOT relocation
+    when constructor info table is referenced from a data section.
+    This only happens with static constructor call so
+    we mark _con_info symbols as `@object` to avoid the issue with relocations.
+
+    @SimonMarlow hack explanation:
+    "The reasoning goes like this:
+
+    * The danger when we mark a symbol as `@function` is that the linker will
+      redirect it to point to the PLT and use a `JUMP_SLOT` relocation when
+      the symbol refers to something outside the current shared object.
+      A PLT / JUMP_SLOT reference only works for symbols that we jump to, not
+      for symbols representing data,, nor for info table symbol references which
+      we expect to point directly to the info table.
+    * GHC generates code that might refer to any info table symbol from the text
+      segment, but that's OK, because those will be explicit GOT references
+      generated by the code generator.
+    * When we refer to info tables from the data segment, it's either
+      * a FUN_STATIC/THUNK_STATIC local to this module
+      * a `con_info` that could be from anywhere
+
+    So, the only info table symbols that we might refer to from the data segment
+    of another shared object are `con_info` symbols, so those are the ones we
+    need to exclude from getting the @function treatment.
+    "
+
+    A good place to check for more
+    https://ghc.haskell.org/trac/ghc/wiki/Commentary/PositionIndependentCode
+
+    Another possible hack is to create an extra local function symbol for
+    every code-like thing to give the needed information for to the tools
+    but mess up with the relocation. https://phabricator.haskell.org/D4730
+    -}
+    functionOkInfoTable = tablesNextToCode dflags &&
+      isInfoTableLabel lbl && not (isConInfoTableLabel lbl)
+
+
+pprTypeDecl :: CLabel -> SDoc
+pprTypeDecl lbl
+    = sdocWithPlatform $ \platform ->
+      if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl
+      then
+        sdocWithDynFlags $ \df ->
+          text ".type " <> ppr lbl <> ptext (sLit  ", ") <> pprLabelType' df lbl
+      else empty
+
+pprLabel :: CLabel -> SDoc
+pprLabel lbl = pprGloblDecl lbl
+            $$ pprTypeDecl lbl
+            $$ (ppr lbl <> char ':')
+
+pprAlign :: Int -> SDoc
+pprAlign bytes
+        = sdocWithPlatform $ \platform ->
+          text ".align " <> int (alignment platform)
+  where
+        alignment platform = if platformOS platform == OSDarwin
+                             then log2 bytes
+                             else      bytes
+
+        log2 :: Int -> Int  -- cache the common ones
+        log2 1 = 0
+        log2 2 = 1
+        log2 4 = 2
+        log2 8 = 3
+        log2 n = 1 + log2 (n `quot` 2)
+
+-- -----------------------------------------------------------------------------
+-- pprInstr: print an 'Instr'
+
+instance Outputable Instr where
+    ppr instr = pprInstr instr
+
+
+pprReg :: Format -> Reg -> SDoc
+pprReg f r
+  = case r of
+      RegReal    (RealRegSingle i) ->
+          sdocWithPlatform $ \platform ->
+          if target32Bit platform then ppr32_reg_no f i
+                                  else ppr64_reg_no f i
+      RegReal    (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch"
+      RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u
+      RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u
+      RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u
+      RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u
+      RegVirtual (VirtualRegSSE u) -> text "%vSSE_" <> pprUniqueAlways u
+  where
+    ppr32_reg_no :: Format -> Int -> SDoc
+    ppr32_reg_no II8   = ppr32_reg_byte
+    ppr32_reg_no II16  = ppr32_reg_word
+    ppr32_reg_no _     = ppr32_reg_long
+
+    ppr32_reg_byte i = ptext
+      (case i of {
+         0 -> sLit "%al";     1 -> sLit "%bl";
+         2 -> sLit "%cl";     3 -> sLit "%dl";
+        _  -> sLit $ "very naughty I386 byte register: " ++ show i
+      })
+
+    ppr32_reg_word i = ptext
+      (case i of {
+         0 -> sLit "%ax";     1 -> sLit "%bx";
+         2 -> sLit "%cx";     3 -> sLit "%dx";
+         4 -> sLit "%si";     5 -> sLit "%di";
+         6 -> sLit "%bp";     7 -> sLit "%sp";
+        _  -> sLit "very naughty I386 word register"
+      })
+
+    ppr32_reg_long i = ptext
+      (case i of {
+         0 -> sLit "%eax";    1 -> sLit "%ebx";
+         2 -> sLit "%ecx";    3 -> sLit "%edx";
+         4 -> sLit "%esi";    5 -> sLit "%edi";
+         6 -> sLit "%ebp";    7 -> sLit "%esp";
+         _  -> ppr_reg_float i
+      })
+
+    ppr64_reg_no :: Format -> Int -> SDoc
+    ppr64_reg_no II8   = ppr64_reg_byte
+    ppr64_reg_no II16  = ppr64_reg_word
+    ppr64_reg_no II32  = ppr64_reg_long
+    ppr64_reg_no _     = ppr64_reg_quad
+
+    ppr64_reg_byte i = ptext
+      (case i of {
+         0 -> sLit "%al";     1 -> sLit "%bl";
+         2 -> sLit "%cl";     3 -> sLit "%dl";
+         4 -> sLit "%sil";    5 -> sLit "%dil"; -- new 8-bit regs!
+         6 -> sLit "%bpl";    7 -> sLit "%spl";
+         8 -> sLit "%r8b";    9  -> sLit "%r9b";
+        10 -> sLit "%r10b";   11 -> sLit "%r11b";
+        12 -> sLit "%r12b";   13 -> sLit "%r13b";
+        14 -> sLit "%r14b";   15 -> sLit "%r15b";
+        _  -> sLit $ "very naughty x86_64 byte register: " ++ show i
+      })
+
+    ppr64_reg_word i = ptext
+      (case i of {
+         0 -> sLit "%ax";     1 -> sLit "%bx";
+         2 -> sLit "%cx";     3 -> sLit "%dx";
+         4 -> sLit "%si";     5 -> sLit "%di";
+         6 -> sLit "%bp";     7 -> sLit "%sp";
+         8 -> sLit "%r8w";    9  -> sLit "%r9w";
+        10 -> sLit "%r10w";   11 -> sLit "%r11w";
+        12 -> sLit "%r12w";   13 -> sLit "%r13w";
+        14 -> sLit "%r14w";   15 -> sLit "%r15w";
+        _  -> sLit "very naughty x86_64 word register"
+      })
+
+    ppr64_reg_long i = ptext
+      (case i of {
+         0 -> sLit "%eax";    1  -> sLit "%ebx";
+         2 -> sLit "%ecx";    3  -> sLit "%edx";
+         4 -> sLit "%esi";    5  -> sLit "%edi";
+         6 -> sLit "%ebp";    7  -> sLit "%esp";
+         8 -> sLit "%r8d";    9  -> sLit "%r9d";
+        10 -> sLit "%r10d";   11 -> sLit "%r11d";
+        12 -> sLit "%r12d";   13 -> sLit "%r13d";
+        14 -> sLit "%r14d";   15 -> sLit "%r15d";
+        _  -> sLit "very naughty x86_64 register"
+      })
+
+    ppr64_reg_quad i = ptext
+      (case i of {
+         0 -> sLit "%rax";      1 -> sLit "%rbx";
+         2 -> sLit "%rcx";      3 -> sLit "%rdx";
+         4 -> sLit "%rsi";      5 -> sLit "%rdi";
+         6 -> sLit "%rbp";      7 -> sLit "%rsp";
+         8 -> sLit "%r8";       9 -> sLit "%r9";
+        10 -> sLit "%r10";    11 -> sLit "%r11";
+        12 -> sLit "%r12";    13 -> sLit "%r13";
+        14 -> sLit "%r14";    15 -> sLit "%r15";
+        _  -> ppr_reg_float i
+      })
+
+ppr_reg_float :: Int -> PtrString
+ppr_reg_float i = case i of
+        16 -> sLit "%fake0";  17 -> sLit "%fake1"
+        18 -> sLit "%fake2";  19 -> sLit "%fake3"
+        20 -> sLit "%fake4";  21 -> sLit "%fake5"
+        24 -> sLit "%xmm0";   25 -> sLit "%xmm1"
+        26 -> sLit "%xmm2";   27 -> sLit "%xmm3"
+        28 -> sLit "%xmm4";   29 -> sLit "%xmm5"
+        30 -> sLit "%xmm6";   31 -> sLit "%xmm7"
+        32 -> sLit "%xmm8";   33 -> sLit "%xmm9"
+        34 -> sLit "%xmm10";  35 -> sLit "%xmm11"
+        36 -> sLit "%xmm12";  37 -> sLit "%xmm13"
+        38 -> sLit "%xmm14";  39 -> sLit "%xmm15"
+        _  -> sLit "very naughty x86 register"
+
+pprFormat :: Format -> SDoc
+pprFormat x
+ = ptext (case x of
+                II8   -> sLit "b"
+                II16  -> sLit "w"
+                II32  -> sLit "l"
+                II64  -> sLit "q"
+                FF32  -> sLit "ss"      -- "scalar single-precision float" (SSE2)
+                FF64  -> sLit "sd"      -- "scalar double-precision float" (SSE2)
+                FF80  -> sLit "t"
+                )
+
+pprFormat_x87 :: Format -> SDoc
+pprFormat_x87 x
+  = ptext $ case x of
+                FF32  -> sLit "s"
+                FF64  -> sLit "l"
+                FF80  -> sLit "t"
+                _     -> panic "X86.Ppr.pprFormat_x87"
+
+pprCond :: Cond -> SDoc
+pprCond c
+ = ptext (case c of {
+                GEU     -> sLit "ae";   LU    -> sLit "b";
+                EQQ     -> sLit "e";    GTT   -> sLit "g";
+                GE      -> sLit "ge";   GU    -> sLit "a";
+                LTT     -> sLit "l";    LE    -> sLit "le";
+                LEU     -> sLit "be";   NE    -> sLit "ne";
+                NEG     -> sLit "s";    POS   -> sLit "ns";
+                CARRY   -> sLit "c";   OFLO  -> sLit "o";
+                PARITY  -> sLit "p";   NOTPARITY -> sLit "np";
+                ALWAYS  -> sLit "mp"})
+
+
+pprImm :: Imm -> SDoc
+pprImm (ImmInt i)     = int i
+pprImm (ImmInteger i) = integer i
+pprImm (ImmCLbl l)    = ppr l
+pprImm (ImmIndex l i) = ppr l <> char '+' <> int i
+pprImm (ImmLit s)     = s
+
+pprImm (ImmFloat _)  = text "naughty float immediate"
+pprImm (ImmDouble _) = text "naughty double immediate"
+
+pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b
+pprImm (ImmConstantDiff a b) = pprImm a <> char '-'
+                            <> lparen <> pprImm b <> rparen
+
+
+
+pprAddr :: AddrMode -> SDoc
+pprAddr (ImmAddr imm off)
+  = let pp_imm = pprImm imm
+    in
+    if (off == 0) then
+        pp_imm
+    else if (off < 0) then
+        pp_imm <> int off
+    else
+        pp_imm <> char '+' <> int off
+
+pprAddr (AddrBaseIndex base index displacement)
+  = sdocWithPlatform $ \platform ->
+    let
+        pp_disp  = ppr_disp displacement
+        pp_off p = pp_disp <> char '(' <> p <> char ')'
+        pp_reg r = pprReg (archWordFormat (target32Bit platform)) r
+    in
+    case (base, index) of
+      (EABaseNone,  EAIndexNone) -> pp_disp
+      (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b)
+      (EABaseRip,   EAIndexNone) -> pp_off (text "%rip")
+      (EABaseNone,  EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i)
+      (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r
+                                       <> comma <> int i)
+      _                         -> panic "X86.Ppr.pprAddr: no match"
+
+  where
+    ppr_disp (ImmInt 0) = empty
+    ppr_disp imm        = pprImm imm
+
+-- | Print section header and appropriate alignment for that section.
+pprSectionAlign :: Section -> SDoc
+pprSectionAlign (Section (OtherSection _) _) =
+     panic "X86.Ppr.pprSectionAlign: unknown section"
+pprSectionAlign sec@(Section seg _) =
+  sdocWithPlatform $ \platform ->
+    pprSectionHeader platform sec $$
+    pprAlignForSection seg
+
+-- | Print appropriate alignment for the given section type.
+pprAlignForSection :: SectionType -> SDoc
+pprAlignForSection seg =
+  sdocWithPlatform $ \platform ->
+    text ".align " <>
+    case platformOS platform of
+      -- Darwin: alignments are given as shifts.
+      OSDarwin
+       | target32Bit platform ->
+          case seg of
+           ReadOnlyData16    -> int 4
+           CString           -> int 1
+           _                 -> int 2
+       | otherwise ->
+          case seg of
+           ReadOnlyData16    -> int 4
+           CString           -> int 1
+           _                 -> int 3
+      -- Other: alignments are given as bytes.
+      _
+       | target32Bit platform ->
+          case seg of
+           Text              -> text "4,0x90"
+           ReadOnlyData16    -> int 16
+           CString           -> int 1
+           _                 -> int 4
+       | otherwise ->
+          case seg of
+           ReadOnlyData16    -> int 16
+           CString           -> int 1
+           _                 -> int 8
+
+pprDataItem :: CmmLit -> SDoc
+pprDataItem lit = sdocWithDynFlags $ \dflags -> pprDataItem' dflags lit
+
+pprDataItem' :: DynFlags -> CmmLit -> SDoc
+pprDataItem' dflags lit
+  = vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit)
+    where
+        platform = targetPlatform dflags
+        imm = litToImm lit
+
+        -- These seem to be common:
+        ppr_item II8   _ = [text "\t.byte\t" <> pprImm imm]
+        ppr_item II16  _ = [text "\t.word\t" <> pprImm imm]
+        ppr_item II32  _ = [text "\t.long\t" <> pprImm imm]
+
+        ppr_item FF32  (CmmFloat r _)
+           = let bs = floatToBytes (fromRational r)
+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+
+        ppr_item FF64 (CmmFloat r _)
+           = let bs = doubleToBytes (fromRational r)
+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs
+
+        ppr_item II64 _
+            = case platformOS platform of
+              OSDarwin
+               | target32Bit platform ->
+                  case lit of
+                  CmmInt x _ ->
+                      [text "\t.long\t"
+                          <> int (fromIntegral (fromIntegral x :: Word32)),
+                       text "\t.long\t"
+                          <> int (fromIntegral
+                              (fromIntegral (x `shiftR` 32) :: Word32))]
+                  _ -> panic "X86.Ppr.ppr_item: no match for II64"
+               | otherwise ->
+                  [text "\t.quad\t" <> pprImm imm]
+              _
+               | target32Bit platform ->
+                  [text "\t.quad\t" <> pprImm imm]
+               | otherwise ->
+                  -- x86_64: binutils can't handle the R_X86_64_PC64
+                  -- relocation type, which means we can't do
+                  -- pc-relative 64-bit addresses. Fortunately we're
+                  -- assuming the small memory model, in which all such
+                  -- offsets will fit into 32 bits, so we have to stick
+                  -- to 32-bit offset fields and modify the RTS
+                  -- appropriately
+                  --
+                  -- See Note [x86-64-relative] in includes/rts/storage/InfoTables.h
+                  --
+                  case lit of
+                  -- A relative relocation:
+                  CmmLabelDiffOff _ _ _ _ ->
+                      [text "\t.long\t" <> pprImm imm,
+                       text "\t.long\t0"]
+                  _ ->
+                      [text "\t.quad\t" <> pprImm imm]
+
+        ppr_item _ _
+                = panic "X86.Ppr.ppr_item: no match"
+
+
+asmComment :: SDoc -> SDoc
+asmComment c = whenPprDebug $ text "# " <> c
+
+pprInstr :: Instr -> SDoc
+
+pprInstr (COMMENT s)
+   = asmComment (ftext s)
+
+pprInstr (LOCATION file line col _name)
+   = text "\t.loc " <> ppr file <+> ppr line <+> ppr col
+
+pprInstr (DELTA d)
+   = asmComment $ text ("\tdelta = " ++ show d)
+
+pprInstr (NEWBLOCK _)
+   = panic "PprMach.pprInstr: NEWBLOCK"
+
+pprInstr (UNWIND lbl d)
+   = asmComment (text "\tunwind = " <> ppr d)
+     $$ ppr lbl <> colon
+
+pprInstr (LDATA _ _)
+   = panic "PprMach.pprInstr: LDATA"
+
+{-
+pprInstr (SPILL reg slot)
+   = hcat [
+        text "\tSPILL",
+        char ' ',
+        pprUserReg reg,
+        comma,
+        text "SLOT" <> parens (int slot)]
+
+pprInstr (RELOAD slot reg)
+   = hcat [
+        text "\tRELOAD",
+        char ' ',
+        text "SLOT" <> parens (int slot),
+        comma,
+        pprUserReg reg]
+-}
+
+-- Replace 'mov $0x0,%reg' by 'xor %reg,%reg', which is smaller and cheaper.
+-- The code generator catches most of these already, but not all.
+pprInstr (MOV format (OpImm (ImmInt 0)) dst@(OpReg _))
+  = pprInstr (XOR format' dst dst)
+  where format' = case format of
+          II64 -> II32          -- 32-bit version is equivalent, and smaller
+          _    -> format
+pprInstr (MOV format src dst)
+  = pprFormatOpOp (sLit "mov") format src dst
+
+pprInstr (CMOV cc format src dst)
+  = pprCondOpReg (sLit "cmov") format cc src dst
+
+pprInstr (MOVZxL II32 src dst) = pprFormatOpOp (sLit "mov") II32 src dst
+        -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple
+        -- movl.  But we represent it as a MOVZxL instruction, because
+        -- the reg alloc would tend to throw away a plain reg-to-reg
+        -- move, and we still want it to do that.
+
+pprInstr (MOVZxL formats src dst)
+  = pprFormatOpOpCoerce (sLit "movz") formats II32 src dst
+        -- zero-extension only needs to extend to 32 bits: on x86_64,
+        -- the remaining zero-extension to 64 bits is automatic, and the 32-bit
+        -- instruction is shorter.
+
+pprInstr (MOVSxL formats src dst)
+  = sdocWithPlatform $ \platform ->
+    pprFormatOpOpCoerce (sLit "movs") formats (archWordFormat (target32Bit platform)) src dst
+
+-- here we do some patching, since the physical registers are only set late
+-- in the code generation.
+pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
+  | reg1 == reg3
+  = pprFormatOpOp (sLit "add") format (OpReg reg2) dst
+
+pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3))
+  | reg2 == reg3
+  = pprFormatOpOp (sLit "add") format (OpReg reg1) dst
+
+pprInstr (LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3))
+  | reg1 == reg3
+  = pprInstr (ADD format (OpImm displ) dst)
+
+pprInstr (LEA format src dst) = pprFormatOpOp (sLit "lea") format src dst
+
+pprInstr (ADD format (OpImm (ImmInt (-1))) dst)
+  = pprFormatOp (sLit "dec") format dst
+pprInstr (ADD format (OpImm (ImmInt 1)) dst)
+  = pprFormatOp (sLit "inc") format dst
+pprInstr (ADD format src dst) = pprFormatOpOp (sLit "add") format src dst
+pprInstr (ADC format src dst) = pprFormatOpOp (sLit "adc") format src dst
+pprInstr (SUB format src dst) = pprFormatOpOp (sLit "sub") format src dst
+pprInstr (SBB format src dst) = pprFormatOpOp (sLit "sbb") format src dst
+pprInstr (IMUL format op1 op2) = pprFormatOpOp (sLit "imul") format op1 op2
+
+pprInstr (ADD_CC format src dst)
+  = pprFormatOpOp (sLit "add") format src dst
+pprInstr (SUB_CC format src dst)
+  = pprFormatOpOp (sLit "sub") format src dst
+
+{- A hack.  The Intel documentation says that "The two and three
+   operand forms [of IMUL] may also be used with unsigned operands
+   because the lower half of the product is the same regardless if
+   (sic) the operands are signed or unsigned.  The CF and OF flags,
+   however, cannot be used to determine if the upper half of the
+   result is non-zero."  So there.
+-}
+
+-- Use a 32-bit instruction when possible as it saves a byte.
+-- Notably, extracting the tag bits of a pointer has this form.
+-- TODO: we could save a byte in a subsequent CMP instruction too,
+-- but need something like a peephole pass for this
+pprInstr (AND II64 src@(OpImm (ImmInteger mask)) dst)
+  | 0 <= mask && mask < 0xffffffff
+    = pprInstr (AND II32 src dst)
+pprInstr (AND FF32 src dst) = pprOpOp (sLit "andps") FF32 src dst
+pprInstr (AND FF64 src dst) = pprOpOp (sLit "andpd") FF64 src dst
+pprInstr (AND format src dst) = pprFormatOpOp (sLit "and") format src dst
+pprInstr (OR  format src dst) = pprFormatOpOp (sLit "or")  format src dst
+
+pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst
+pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst
+pprInstr (XOR format src dst) = pprFormatOpOp (sLit "xor")  format src dst
+
+pprInstr (POPCNT format src dst) = pprOpOp (sLit "popcnt") format src (OpReg dst)
+pprInstr (BSF format src dst)    = pprOpOp (sLit "bsf")    format src (OpReg dst)
+pprInstr (BSR format src dst)    = pprOpOp (sLit "bsr")    format src (OpReg dst)
+
+pprInstr (PDEP format src mask dst)   = pprFormatOpOpReg (sLit "pdep") format src mask dst
+pprInstr (PEXT format src mask dst)   = pprFormatOpOpReg (sLit "pext") format src mask dst
+
+pprInstr (PREFETCH NTA format src ) = pprFormatOp_ (sLit "prefetchnta") format src
+pprInstr (PREFETCH Lvl0 format src) = pprFormatOp_ (sLit "prefetcht0") format src
+pprInstr (PREFETCH Lvl1 format src) = pprFormatOp_ (sLit "prefetcht1") format src
+pprInstr (PREFETCH Lvl2 format src) = pprFormatOp_ (sLit "prefetcht2") format src
+
+pprInstr (NOT format op) = pprFormatOp (sLit "not") format op
+pprInstr (BSWAP format op) = pprFormatOp (sLit "bswap") format (OpReg op)
+pprInstr (NEGI format op) = pprFormatOp (sLit "neg") format op
+
+pprInstr (SHL format src dst) = pprShift (sLit "shl") format src dst
+pprInstr (SAR format src dst) = pprShift (sLit "sar") format src dst
+pprInstr (SHR format src dst) = pprShift (sLit "shr") format src dst
+
+pprInstr (BT  format imm src) = pprFormatImmOp (sLit "bt") format imm src
+
+pprInstr (CMP format src dst)
+  | isFloatFormat format =  pprFormatOpOp (sLit "ucomi") format src dst -- SSE2
+  | otherwise     =  pprFormatOpOp (sLit "cmp")   format src dst
+
+pprInstr (TEST format src dst) = sdocWithPlatform $ \platform ->
+  let format' = case (src,dst) of
+        -- Match instructions like 'test $0x3,%esi' or 'test $0x7,%rbx'.
+        -- We can replace them by equivalent, but smaller instructions
+        -- by reducing the size of the immediate operand as far as possible.
+        -- (We could handle masks larger than a single byte too,
+        -- but it would complicate the code considerably
+        -- and tag checks are by far the most common case.)
+        -- The mask must have the high bit clear for this smaller encoding
+        -- to be completely equivalent to the original; in particular so
+        -- that the signed comparison condition bits are the same as they
+        -- would be if doing a full word comparison. See Trac #13425.
+        (OpImm (ImmInteger mask), OpReg dstReg)
+          | 0 <= mask && mask < 128 -> minSizeOfReg platform dstReg
+        _ -> format
+  in pprFormatOpOp (sLit "test") format' src dst
+  where
+    minSizeOfReg platform (RegReal (RealRegSingle i))
+      | target32Bit platform && i <= 3        = II8  -- al, bl, cl, dl
+      | target32Bit platform && i <= 7        = II16 -- si, di, bp, sp
+      | not (target32Bit platform) && i <= 15 = II8  -- al .. r15b
+    minSizeOfReg _ _ = format                 -- other
+
+pprInstr (PUSH format op) = pprFormatOp (sLit "push") format op
+pprInstr (POP format op) = pprFormatOp (sLit "pop") format op
+
+-- both unused (SDM):
+-- pprInstr PUSHA = text "\tpushal"
+-- pprInstr POPA = text "\tpopal"
+
+pprInstr NOP = text "\tnop"
+pprInstr (CLTD II8) = text "\tcbtw"
+pprInstr (CLTD II16) = text "\tcwtd"
+pprInstr (CLTD II32) = text "\tcltd"
+pprInstr (CLTD II64) = text "\tcqto"
+pprInstr (CLTD x) = panic $ "pprInstr: " ++ show x
+
+pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
+
+pprInstr (JXX cond blockid)
+  = pprCondInstr (sLit "j") cond (ppr lab)
+  where lab = blockLbl blockid
+
+pprInstr        (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
+
+pprInstr        (JMP (OpImm imm) _) = text "\tjmp " <> pprImm imm
+pprInstr (JMP op _)          = sdocWithPlatform $ \platform ->
+                               text "\tjmp *"
+                                   <> pprOperand (archWordFormat (target32Bit platform)) op
+pprInstr (JMP_TBL op _ _ _)  = pprInstr (JMP op [])
+pprInstr        (CALL (Left imm) _)    = text "\tcall " <> pprImm imm
+pprInstr (CALL (Right reg) _)   = sdocWithPlatform $ \platform ->
+                                  text "\tcall *"
+                                      <> pprReg (archWordFormat (target32Bit platform)) reg
+
+pprInstr (IDIV fmt op)   = pprFormatOp (sLit "idiv") fmt op
+pprInstr (DIV fmt op)    = pprFormatOp (sLit "div")  fmt op
+pprInstr (IMUL2 fmt op)  = pprFormatOp (sLit "imul") fmt op
+
+-- x86_64 only
+pprInstr (MUL format op1 op2) = pprFormatOpOp (sLit "mul") format op1 op2
+pprInstr (MUL2 format op) = pprFormatOp (sLit "mul") format op
+
+pprInstr (FDIV format op1 op2) = pprFormatOpOp (sLit "div") format op1 op2
+pprInstr (SQRT format op1 op2) = pprFormatOpReg (sLit "sqrt") format op1 op2
+
+pprInstr (CVTSS2SD from to)      = pprRegReg (sLit "cvtss2sd") from to
+pprInstr (CVTSD2SS from to)      = pprRegReg (sLit "cvtsd2ss") from to
+pprInstr (CVTTSS2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttss2si") FF32 fmt from to
+pprInstr (CVTTSD2SIQ fmt from to) = pprFormatFormatOpReg (sLit "cvttsd2si") FF64 fmt from to
+pprInstr (CVTSI2SS fmt from to)   = pprFormatOpReg (sLit "cvtsi2ss") fmt from to
+pprInstr (CVTSI2SD fmt from to)   = pprFormatOpReg (sLit "cvtsi2sd") fmt from to
+
+    -- FETCHGOT for PIC on ELF platforms
+pprInstr (FETCHGOT reg)
+   = vcat [ text "\tcall 1f",
+            hcat [ text "1:\tpopl\t", pprReg II32 reg ],
+            hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ",
+                   pprReg II32 reg ]
+          ]
+
+    -- FETCHPC for PIC on Darwin/x86
+    -- get the instruction pointer into a register
+    -- (Terminology note: the IP is called Program Counter on PPC,
+    --  and it's a good thing to use the same name on both platforms)
+pprInstr (FETCHPC reg)
+   = vcat [ text "\tcall 1f",
+            hcat [ text "1:\tpopl\t", pprReg II32 reg ]
+          ]
+
+
+-- -----------------------------------------------------------------------------
+-- i386 floating-point
+
+-- Simulating a flat register set on the x86 FP stack is tricky.
+-- you have to free %st(7) before pushing anything on the FP reg stack
+-- so as to preclude the possibility of a FP stack overflow exception.
+pprInstr g@(GMOV src dst)
+   | src == dst
+   = empty
+   | otherwise
+   = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1])
+
+-- GLD fmt addr dst ==> FLDsz addr ; FSTP (dst+1)
+pprInstr g@(GLD fmt addr dst)
+ = pprG g (hcat [gtab, text "fld", pprFormat_x87 fmt, gsp,
+                 pprAddr addr, gsemi, gpop dst 1])
+
+-- GST fmt src addr ==> FLD dst ; FSTPsz addr
+pprInstr g@(GST fmt src addr)
+ | src == fake0 && fmt /= FF80 -- fstt instruction doesn't exist
+ = pprG g (hcat [gtab,
+                 text "fst", pprFormat_x87 fmt, gsp, pprAddr addr])
+ | otherwise
+ = pprG g (hcat [gtab, gpush src 0, gsemi,
+                 text "fstp", pprFormat_x87 fmt, gsp, pprAddr addr])
+
+pprInstr g@(GLDZ dst)
+ = pprG g (hcat [gtab, text "fldz ; ", gpop dst 1])
+pprInstr g@(GLD1 dst)
+ = pprG g (hcat [gtab, text "fld1 ; ", gpop dst 1])
+
+pprInstr (GFTOI src dst)
+   = pprInstr (GDTOI src dst)
+
+pprInstr g@(GDTOI src dst)
+   = pprG g (vcat [
+         hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"],
+         hcat [gtab, gpush src 0],
+         hcat [gtab, text "movzwl 4(%esp), ", reg,
+                     text " ; orl $0xC00, ", reg],
+         hcat [gtab, text "movl ", reg, text ", 0(%esp) ; fldcw 0(%esp)"],
+         hcat [gtab, text "fistpl 0(%esp)"],
+         hcat [gtab, text "fldcw 4(%esp) ; movl 0(%esp), ", reg],
+         hcat [gtab, text "addl $8, %esp"]
+     ])
+   where
+     reg = pprReg II32 dst
+
+pprInstr (GITOF src dst)
+   = pprInstr (GITOD src dst)
+
+pprInstr g@(GITOD src dst)
+   = pprG g (hcat [gtab, text "pushl ", pprReg II32 src,
+                   text " ; fildl (%esp) ; ",
+                   gpop dst 1, text " ; addl $4,%esp"])
+
+pprInstr g@(GDTOF src dst)
+  = pprG g (vcat [gtab <> gpush src 0,
+                  gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;",
+                  gtab <> gpop dst 1])
+
+{- Gruesome swamp follows.  If you're unfortunate enough to have ventured
+   this far into the jungle AND you give a Rat's Ass (tm) what's going
+   on, here's the deal.  Generate code to do a floating point comparison
+   of src1 and src2, of kind cond, and set the Zero flag if true.
+
+   The complications are to do with handling NaNs correctly.  We want the
+   property that if either argument is NaN, then the result of the
+   comparison is False ... except if we're comparing for inequality,
+   in which case the answer is True.
+
+   Here's how the general (non-inequality) case works.  As an
+   example, consider generating the an equality test:
+
+     pushl %eax         -- we need to mess with this
+     <get src1 to top of FPU stack>
+     fcomp <src2 location in FPU stack> and pop pushed src1
+                -- Result of comparison is in FPU Status Register bits
+                -- C3 C2 and C0
+     fstsw %ax  -- Move FPU Status Reg to %ax
+     sahf       -- move C3 C2 C0 from %ax to integer flag reg
+     -- now the serious magic begins
+     setpo %ah     -- %ah = if comparable(neither arg was NaN) then 1 else 0
+     sete  %al     -- %al = if arg1 == arg2 then 1 else 0
+     andb %ah,%al  -- %al &= %ah
+                   -- so %al == 1 iff (comparable && same); else it holds 0
+     decb %al      -- %al == 0, ZeroFlag=1  iff (comparable && same);
+                      else %al == 0xFF, ZeroFlag=0
+     -- the zero flag is now set as we desire.
+     popl %eax
+
+   The special case of inequality differs thusly:
+
+     setpe %ah     -- %ah = if incomparable(either arg was NaN) then 1 else 0
+     setne %al     -- %al = if arg1 /= arg2 then 1 else 0
+     orb %ah,%al   -- %al = if (incomparable || different) then 1 else 0
+     decb %al      -- if (incomparable || different) then (%al == 0, ZF=1)
+                                                     else (%al == 0xFF, ZF=0)
+-}
+pprInstr g@(GCMP cond src1 src2)
+   | case cond of { NE -> True; _ -> False }
+   = pprG g (vcat [
+        hcat [gtab, text "pushl %eax ; ",gpush src1 0],
+        hcat [gtab, text "fcomp ", greg src2 1,
+                    text "; fstsw %ax ; sahf ;  setpe %ah"],
+        hcat [gtab, text "setne %al ;  ",
+              text "orb %ah,%al ;  decb %al ;  popl %eax"]
+    ])
+   | otherwise
+   = pprG g (vcat [
+        hcat [gtab, text "pushl %eax ; ",gpush src1 0],
+        hcat [gtab, text "fcomp ", greg src2 1,
+                    text "; fstsw %ax ; sahf ;  setpo %ah"],
+        hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ;  ",
+              text "andb %ah,%al ;  decb %al ;  popl %eax"]
+    ])
+    where
+        {- On the 486, the flags set by FP compare are the unsigned ones!
+           (This looks like a HACK to me.  WDP 96/03)
+        -}
+        fix_FP_cond :: Cond -> Cond
+        fix_FP_cond GE   = GEU
+        fix_FP_cond GTT  = GU
+        fix_FP_cond LTT  = LU
+        fix_FP_cond LE   = LEU
+        fix_FP_cond EQQ  = EQQ
+        fix_FP_cond NE   = NE
+        fix_FP_cond _    = panic "X86.Ppr.fix_FP_cond: no match"
+        -- there should be no others
+
+
+pprInstr g@(GABS _ src dst)
+   = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1])
+
+pprInstr g@(GNEG _ src dst)
+   = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1])
+
+pprInstr g@(GSQRT fmt src dst)
+   = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$
+             hcat [gtab, gcoerceto fmt, gpop dst 1])
+
+pprInstr g@(GSIN fmt l1 l2 src dst)
+   = pprG g (pprTrigOp "fsin" False l1 l2 src dst fmt)
+
+pprInstr g@(GCOS fmt l1 l2 src dst)
+   = pprG g (pprTrigOp "fcos" False l1 l2 src dst fmt)
+
+pprInstr g@(GTAN fmt l1 l2 src dst)
+   = pprG g (pprTrigOp "fptan" True l1 l2 src dst fmt)
+
+-- In the translations for GADD, GMUL, GSUB and GDIV,
+-- the first two cases are mere optimisations.  The otherwise clause
+-- generates correct code under all circumstances.
+
+pprInstr g@(GADD _ src1 src2 dst)
+   | src1 == dst
+   = pprG g (text "\t#GADD-xxxcase1" $$
+             hcat [gtab, gpush src2 0,
+                   text " ; faddp %st(0),", greg src1 1])
+   | src2 == dst
+   = pprG g (text "\t#GADD-xxxcase2" $$
+             hcat [gtab, gpush src1 0,
+                   text " ; faddp %st(0),", greg src2 1])
+   | otherwise
+   = pprG g (hcat [gtab, gpush src1 0,
+                   text " ; fadd ", greg src2 1, text ",%st(0)",
+                   gsemi, gpop dst 1])
+
+
+pprInstr g@(GMUL _ src1 src2 dst)
+   | src1 == dst
+   = pprG g (text "\t#GMUL-xxxcase1" $$
+             hcat [gtab, gpush src2 0,
+                   text " ; fmulp %st(0),", greg src1 1])
+   | src2 == dst
+   = pprG g (text "\t#GMUL-xxxcase2" $$
+             hcat [gtab, gpush src1 0,
+                   text " ; fmulp %st(0),", greg src2 1])
+   | otherwise
+   = pprG g (hcat [gtab, gpush src1 0,
+             text " ; fmul ", greg src2 1, text ",%st(0)",
+             gsemi, gpop dst 1])
+
+
+pprInstr g@(GSUB _ src1 src2 dst)
+   | src1 == dst
+   = pprG g (text "\t#GSUB-xxxcase1" $$
+             hcat [gtab, gpush src2 0,
+                   text " ; fsubrp %st(0),", greg src1 1])
+   | src2 == dst
+   = pprG g (text "\t#GSUB-xxxcase2" $$
+             hcat [gtab, gpush src1 0,
+                   text " ; fsubp %st(0),", greg src2 1])
+   | otherwise
+   = pprG g (hcat [gtab, gpush src1 0,
+                   text " ; fsub ", greg src2 1, text ",%st(0)",
+                   gsemi, gpop dst 1])
+
+
+pprInstr g@(GDIV _ src1 src2 dst)
+   | src1 == dst
+   = pprG g (text "\t#GDIV-xxxcase1" $$
+             hcat [gtab, gpush src2 0,
+                   text " ; fdivrp %st(0),", greg src1 1])
+   | src2 == dst
+   = pprG g (text "\t#GDIV-xxxcase2" $$
+             hcat [gtab, gpush src1 0,
+                   text " ; fdivp %st(0),", greg src2 1])
+   | otherwise
+   = pprG g (hcat [gtab, gpush src1 0,
+                   text " ; fdiv ", greg src2 1, text ",%st(0)",
+                   gsemi, gpop dst 1])
+
+
+pprInstr GFREE
+   = vcat [ text "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)",
+            text "\tffree %st(4) ;ffree %st(5)"
+          ]
+
+-- Atomics
+
+pprInstr (LOCK i) = text "\tlock" $$ pprInstr i
+
+pprInstr MFENCE = text "\tmfence"
+
+pprInstr (XADD format src dst) = pprFormatOpOp (sLit "xadd") format src dst
+
+pprInstr (CMPXCHG format src dst)
+   = pprFormatOpOp (sLit "cmpxchg") format src dst
+
+
+pprTrigOp :: String -> Bool -> CLabel -> CLabel
+          -> Reg -> Reg -> Format -> SDoc
+pprTrigOp op -- fsin, fcos or fptan
+          isTan -- we need a couple of extra steps if we're doing tan
+          l1 l2 -- internal labels for us to use
+          src dst fmt
+    = -- We'll be needing %eax later on
+      hcat [gtab, text "pushl %eax;"] $$
+      -- tan is going to use an extra space on the FP stack
+      (if isTan then hcat [gtab, text "ffree %st(6)"] else empty) $$
+      -- First put the value in %st(0) and try to apply the op to it
+      hcat [gpush src 0, text ("; " ++ op)] $$
+      -- Now look to see if C2 was set (overflow, |value| >= 2^63)
+      hcat [gtab, text "fnstsw %ax"] $$
+      hcat [gtab, text "test   $0x400,%eax"] $$
+      -- If we were in bounds then jump to the end
+      hcat [gtab, text "je     " <> ppr l1] $$
+      -- Otherwise we need to shrink the value. Start by
+      -- loading pi, doubleing it (by adding it to itself),
+      -- and then swapping pi with the value, so the value we
+      -- want to apply op to is in %st(0) again
+      hcat [gtab, text "ffree %st(7); fldpi"] $$
+      hcat [gtab, text "fadd   %st(0),%st"] $$
+      hcat [gtab, text "fxch   %st(1)"] $$
+      -- Now we have a loop in which we make the value smaller,
+      -- see if it's small enough, and loop if not
+      (ppr l2 <> char ':') $$
+      hcat [gtab, text "fprem1"] $$
+      -- My Debian libc uses fstsw here for the tan code, but I can't
+      -- see any reason why it should need to be different for tan.
+      hcat [gtab, text "fnstsw %ax"] $$
+      hcat [gtab, text "test   $0x400,%eax"] $$
+      hcat [gtab, text "jne    " <> ppr l2] $$
+      hcat [gtab, text "fstp   %st(1)"] $$
+      hcat [gtab, text op] $$
+      (ppr l1 <> char ':') $$
+      -- Pop the 1.0 tan gave us
+      (if isTan then hcat [gtab, text "fstp %st(0)"] else empty) $$
+      -- Restore %eax
+      hcat [gtab, text "popl %eax;"] $$
+      -- And finally make the result the right size
+      hcat [gtab, gcoerceto fmt, gpop dst 1]
+
+--------------------------
+
+-- coerce %st(0) to the specified size
+gcoerceto :: Format -> SDoc
+gcoerceto FF64 = empty
+gcoerceto FF32 = empty --text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ; "
+gcoerceto _    = panic "X86.Ppr.gcoerceto: no match"
+
+gpush :: Reg -> RegNo -> SDoc
+gpush reg offset
+   = hcat [text "fld ", greg reg offset]
+
+gpop :: Reg -> RegNo -> SDoc
+gpop reg offset
+   = hcat [text "fstp ", greg reg offset]
+
+greg :: Reg -> RegNo -> SDoc
+greg reg offset = text "%st(" <> int (gregno reg - firstfake+offset) <> char ')'
+
+gsemi :: SDoc
+gsemi = text " ; "
+
+gtab :: SDoc
+gtab  = char '\t'
+
+gsp :: SDoc
+gsp   = char ' '
+
+gregno :: Reg -> RegNo
+gregno (RegReal (RealRegSingle i)) = i
+gregno _           = --pprPanic "gregno" (ppr other)
+                     999   -- bogus; only needed for debug printing
+
+pprG :: Instr -> SDoc -> SDoc
+pprG fake actual
+   = (char '#' <> pprGInstr fake) $$ actual
+
+
+pprGInstr :: Instr -> SDoc
+pprGInstr (GMOV src dst)   = pprFormatRegReg (sLit "gmov") FF64 src dst
+pprGInstr (GLD fmt src dst) = pprFormatAddrReg (sLit "gld") fmt src dst
+pprGInstr (GST fmt src dst) = pprFormatRegAddr (sLit "gst") fmt src dst
+
+pprGInstr (GLDZ dst) = pprFormatReg (sLit "gldz") FF64 dst
+pprGInstr (GLD1 dst) = pprFormatReg (sLit "gld1") FF64 dst
+
+pprGInstr (GFTOI src dst) = pprFormatFormatRegReg (sLit "gftoi") FF32 II32 src dst
+pprGInstr (GDTOI src dst) = pprFormatFormatRegReg (sLit "gdtoi") FF64 II32 src dst
+
+pprGInstr (GITOF src dst) = pprFormatFormatRegReg (sLit "gitof") II32 FF32 src dst
+pprGInstr (GITOD src dst) = pprFormatFormatRegReg (sLit "gitod") II32 FF64 src dst
+pprGInstr (GDTOF src dst) = pprFormatFormatRegReg (sLit "gdtof") FF64 FF32 src dst
+
+pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst
+pprGInstr (GABS fmt src dst) = pprFormatRegReg (sLit "gabs") fmt src dst
+pprGInstr (GNEG fmt src dst) = pprFormatRegReg (sLit "gneg") fmt src dst
+pprGInstr (GSQRT fmt src dst) = pprFormatRegReg (sLit "gsqrt") fmt src dst
+pprGInstr (GSIN fmt _ _ src dst) = pprFormatRegReg (sLit "gsin") fmt src dst
+pprGInstr (GCOS fmt _ _ src dst) = pprFormatRegReg (sLit "gcos") fmt src dst
+pprGInstr (GTAN fmt _ _ src dst) = pprFormatRegReg (sLit "gtan") fmt src dst
+
+pprGInstr (GADD fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gadd") fmt src1 src2 dst
+pprGInstr (GSUB fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gsub") fmt src1 src2 dst
+pprGInstr (GMUL fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gmul") fmt src1 src2 dst
+pprGInstr (GDIV fmt src1 src2 dst) = pprFormatRegRegReg (sLit "gdiv") fmt src1 src2 dst
+
+pprGInstr _ = panic "X86.Ppr.pprGInstr: no match"
+
+pprDollImm :: Imm -> SDoc
+pprDollImm i = text "$" <> pprImm i
+
+
+pprOperand :: Format -> Operand -> SDoc
+pprOperand f (OpReg r)   = pprReg f r
+pprOperand _ (OpImm i)   = pprDollImm i
+pprOperand _ (OpAddr ea) = pprAddr ea
+
+
+pprMnemonic_  :: PtrString -> SDoc
+pprMnemonic_ name =
+   char '\t' <> ptext name <> space
+
+
+pprMnemonic  :: PtrString -> Format -> SDoc
+pprMnemonic name format =
+   char '\t' <> ptext name <> pprFormat format <> space
+
+
+pprFormatImmOp :: PtrString -> Format -> Imm -> Operand -> SDoc
+pprFormatImmOp name format imm op1
+  = hcat [
+        pprMnemonic name format,
+        char '$',
+        pprImm imm,
+        comma,
+        pprOperand format op1
+    ]
+
+
+pprFormatOp_ :: PtrString -> Format -> Operand -> SDoc
+pprFormatOp_ name format op1
+  = hcat [
+        pprMnemonic_ name ,
+        pprOperand format op1
+    ]
+
+pprFormatOp :: PtrString -> Format -> Operand -> SDoc
+pprFormatOp name format op1
+  = hcat [
+        pprMnemonic name format,
+        pprOperand format op1
+    ]
+
+
+pprFormatOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc
+pprFormatOpOp name format op1 op2
+  = hcat [
+        pprMnemonic name format,
+        pprOperand format op1,
+        comma,
+        pprOperand format op2
+    ]
+
+
+pprOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc
+pprOpOp name format op1 op2
+  = hcat [
+        pprMnemonic_ name,
+        pprOperand format op1,
+        comma,
+        pprOperand format op2
+    ]
+
+
+pprFormatReg :: PtrString -> Format -> Reg -> SDoc
+pprFormatReg name format reg1
+  = hcat [
+        pprMnemonic name format,
+        pprReg format reg1
+    ]
+
+
+pprFormatRegReg :: PtrString -> Format -> Reg -> Reg -> SDoc
+pprFormatRegReg name format reg1 reg2
+  = hcat [
+        pprMnemonic name format,
+        pprReg format reg1,
+        comma,
+        pprReg format reg2
+    ]
+
+
+pprRegReg :: PtrString -> Reg -> Reg -> SDoc
+pprRegReg name reg1 reg2
+  = sdocWithPlatform $ \platform ->
+    hcat [
+        pprMnemonic_ name,
+        pprReg (archWordFormat (target32Bit platform)) reg1,
+        comma,
+        pprReg (archWordFormat (target32Bit platform)) reg2
+    ]
+
+
+pprFormatOpReg :: PtrString -> Format -> Operand -> Reg -> SDoc
+pprFormatOpReg name format op1 reg2
+  = sdocWithPlatform $ \platform ->
+    hcat [
+        pprMnemonic name format,
+        pprOperand format op1,
+        comma,
+        pprReg (archWordFormat (target32Bit platform)) reg2
+    ]
+
+pprCondOpReg :: PtrString -> Format -> Cond -> Operand -> Reg -> SDoc
+pprCondOpReg name format cond op1 reg2
+  = hcat [
+        char '\t',
+        ptext name,
+        pprCond cond,
+        space,
+        pprOperand format op1,
+        comma,
+        pprReg format reg2
+    ]
+
+pprCondRegReg :: PtrString -> Format -> Cond -> Reg -> Reg -> SDoc
+pprCondRegReg name format cond reg1 reg2
+  = hcat [
+        char '\t',
+        ptext name,
+        pprCond cond,
+        space,
+        pprReg format reg1,
+        comma,
+        pprReg format reg2
+    ]
+
+pprFormatFormatRegReg :: PtrString -> Format -> Format -> Reg -> Reg -> SDoc
+pprFormatFormatRegReg name format1 format2 reg1 reg2
+  = hcat [
+        char '\t',
+        ptext name,
+        pprFormat format1,
+        pprFormat format2,
+        space,
+        pprReg format1 reg1,
+        comma,
+        pprReg format2 reg2
+    ]
+
+pprFormatFormatOpReg :: PtrString -> Format -> Format -> Operand -> Reg -> SDoc
+pprFormatFormatOpReg name format1 format2 op1 reg2
+  = hcat [
+        pprMnemonic name format2,
+        pprOperand format1 op1,
+        comma,
+        pprReg format2 reg2
+    ]
+
+pprFormatRegRegReg :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc
+pprFormatRegRegReg name format reg1 reg2 reg3
+  = hcat [
+        pprMnemonic name format,
+        pprReg format reg1,
+        comma,
+        pprReg format reg2,
+        comma,
+        pprReg format reg3
+    ]
+
+pprFormatOpOpReg :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc
+pprFormatOpOpReg name format op1 op2 reg3
+  = hcat [
+        pprMnemonic name format,
+        pprOperand format op1,
+        comma,
+        pprOperand format op2,
+        comma,
+        pprReg format reg3
+    ]
+
+pprFormatAddrReg :: PtrString -> Format -> AddrMode -> Reg -> SDoc
+pprFormatAddrReg name format op dst
+  = hcat [
+        pprMnemonic name format,
+        pprAddr op,
+        comma,
+        pprReg format dst
+    ]
+
+
+pprFormatRegAddr :: PtrString -> Format -> Reg -> AddrMode -> SDoc
+pprFormatRegAddr name format src op
+  = hcat [
+        pprMnemonic name format,
+        pprReg format src,
+        comma,
+        pprAddr op
+    ]
+
+
+pprShift :: PtrString -> Format -> Operand -> Operand -> SDoc
+pprShift name format src dest
+  = hcat [
+        pprMnemonic name format,
+        pprOperand II8 src,  -- src is 8-bit sized
+        comma,
+        pprOperand format dest
+    ]
+
+
+pprFormatOpOpCoerce :: PtrString -> Format -> Format -> Operand -> Operand -> SDoc
+pprFormatOpOpCoerce name format1 format2 op1 op2
+  = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space,
+        pprOperand format1 op1,
+        comma,
+        pprOperand format2 op2
+    ]
+
+
+pprCondInstr :: PtrString -> Cond -> SDoc -> SDoc
+pprCondInstr name cond arg
+  = hcat [ char '\t', ptext name, pprCond cond, space, arg]
diff --git a/compiler/nativeGen/X86/RegInfo.hs b/compiler/nativeGen/X86/RegInfo.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/X86/RegInfo.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE CPP #-}
+module X86.RegInfo (
+        mkVirtualReg,
+        regDotColor
+)
+
+where
+
+#include "nativeGen/NCG.h"
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Format
+import Reg
+
+import Outputable
+import Platform
+import Unique
+
+import UniqFM
+import X86.Regs
+
+
+mkVirtualReg :: Unique -> Format -> VirtualReg
+mkVirtualReg u format
+   = case format of
+        FF32    -> VirtualRegSSE u
+        FF64    -> VirtualRegSSE u
+        FF80    -> VirtualRegD   u
+        _other  -> VirtualRegI   u
+
+regDotColor :: Platform -> RealReg -> SDoc
+regDotColor platform reg
+ = let Just str = lookupUFM (regColors platform) reg
+   in text str
+
+regColors :: Platform -> UniqFM [Char]
+regColors platform = listToUFM (normalRegColors platform ++ fpRegColors)
+
+normalRegColors :: Platform -> [(Reg,String)]
+normalRegColors platform
+ | target32Bit platform = [ (eax, "#00ff00")
+                          , (ebx, "#0000ff")
+                          , (ecx, "#00ffff")
+                          , (edx, "#0080ff") ]
+ | otherwise            = [ (rax, "#00ff00"), (eax, "#00ff00")
+                          , (rbx, "#0000ff"), (ebx, "#0000ff")
+                          , (rcx, "#00ffff"), (ecx, "#00ffff")
+                          , (rdx, "#0080ff"), (edx, "#00ffff")
+                          , (r8,  "#00ff80")
+                          , (r9,  "#008080")
+                          , (r10, "#0040ff")
+                          , (r11, "#00ff40")
+                          , (r12, "#008040")
+                          , (r13, "#004080")
+                          , (r14, "#004040")
+                          , (r15, "#002080") ]
+
+fpRegColors :: [(Reg,String)]
+fpRegColors =
+        [ (fake0, "#ff00ff")
+        , (fake1, "#ff00aa")
+        , (fake2, "#aa00ff")
+        , (fake3, "#aa00aa")
+        , (fake4, "#ff0055")
+        , (fake5, "#5500ff") ]
+
+        ++ zip (map regSingle [24..39]) (repeat "red")
diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/nativeGen/X86/Regs.hs
@@ -0,0 +1,454 @@
+{-# LANGUAGE CPP #-}
+
+module X86.Regs (
+        -- squeese functions for the graph allocator
+        virtualRegSqueeze,
+        realRegSqueeze,
+
+        -- immediates
+        Imm(..),
+        strImmLit,
+        litToImm,
+
+        -- addressing modes
+        AddrMode(..),
+        addrOffset,
+
+        -- registers
+        spRel,
+        argRegs,
+        allArgRegs,
+        allIntArgRegs,
+        callClobberedRegs,
+        instrClobberedRegs,
+        allMachRegNos,
+        classOfRealReg,
+        showReg,
+
+        -- machine specific
+        EABase(..), EAIndex(..), addrModeRegs,
+
+        eax, ebx, ecx, edx, esi, edi, ebp, esp,
+        fake0, fake1, fake2, fake3, fake4, fake5, firstfake,
+
+        rax, rbx, rcx, rdx, rsi, rdi, rbp, rsp,
+        r8,  r9,  r10, r11, r12, r13, r14, r15,
+        xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7,
+        xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15,
+        xmm,
+
+        ripRel,
+        allFPArgRegs,
+
+        allocatableRegs
+)
+
+where
+
+#include "nativeGen/NCG.h"
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CodeGen.Platform
+import Reg
+import RegClass
+
+import Cmm
+import CLabel           ( CLabel )
+import DynFlags
+import Outputable
+import Platform
+
+import qualified Data.Array as A
+
+-- | regSqueeze_class reg
+--      Calculate the maximum number of register colors that could be
+--      denied to a node of this class due to having this reg
+--      as a neighbour.
+--
+{-# INLINE virtualRegSqueeze #-}
+virtualRegSqueeze :: RegClass -> VirtualReg -> Int
+
+virtualRegSqueeze cls vr
+ = case cls of
+        RcInteger
+         -> case vr of
+                VirtualRegI{}           -> 1
+                VirtualRegHi{}          -> 1
+                _other                  -> 0
+
+        RcDouble
+         -> case vr of
+                VirtualRegD{}           -> 1
+                VirtualRegF{}           -> 0
+                _other                  -> 0
+
+        RcDoubleSSE
+         -> case vr of
+                VirtualRegSSE{}         -> 1
+                _other                  -> 0
+
+        _other -> 0
+
+{-# INLINE realRegSqueeze #-}
+realRegSqueeze :: RegClass -> RealReg -> Int
+realRegSqueeze cls rr
+ = case cls of
+        RcInteger
+         -> case rr of
+                RealRegSingle regNo
+                        | regNo < firstfake -> 1
+                        | otherwise     -> 0
+
+                RealRegPair{}           -> 0
+
+        RcDouble
+         -> case rr of
+                RealRegSingle regNo
+                        | regNo >= firstfake && regNo <= lastfake -> 1
+                        | otherwise     -> 0
+
+                RealRegPair{}           -> 0
+
+        RcDoubleSSE
+         -> case rr of
+                RealRegSingle regNo | regNo >= firstxmm -> 1
+                _otherwise                        -> 0
+
+        _other -> 0
+
+-- -----------------------------------------------------------------------------
+-- Immediates
+
+data Imm
+  = ImmInt      Int
+  | ImmInteger  Integer     -- Sigh.
+  | ImmCLbl     CLabel      -- AbstractC Label (with baggage)
+  | ImmLit      SDoc        -- Simple string
+  | ImmIndex    CLabel Int
+  | ImmFloat    Rational
+  | ImmDouble   Rational
+  | ImmConstantSum Imm Imm
+  | ImmConstantDiff Imm Imm
+
+strImmLit :: String -> Imm
+strImmLit s = ImmLit (text s)
+
+
+litToImm :: CmmLit -> Imm
+litToImm (CmmInt i w)        = ImmInteger (narrowS w i)
+                -- narrow to the width: a CmmInt might be out of
+                -- range, but we assume that ImmInteger only contains
+                -- in-range values.  A signed value should be fine here.
+litToImm (CmmFloat f W32)    = ImmFloat f
+litToImm (CmmFloat f W64)    = ImmDouble f
+litToImm (CmmLabel l)        = ImmCLbl l
+litToImm (CmmLabelOff l off) = ImmIndex l off
+litToImm (CmmLabelDiffOff l1 l2 off _)
+                             = ImmConstantSum
+                               (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))
+                               (ImmInt off)
+litToImm _                   = panic "X86.Regs.litToImm: no match"
+
+-- addressing modes ------------------------------------------------------------
+
+data AddrMode
+        = AddrBaseIndex EABase EAIndex Displacement
+        | ImmAddr Imm Int
+
+data EABase       = EABaseNone  | EABaseReg Reg | EABaseRip
+data EAIndex      = EAIndexNone | EAIndex Reg Int
+type Displacement = Imm
+
+
+addrOffset :: AddrMode -> Int -> Maybe AddrMode
+addrOffset addr off
+  = case addr of
+      ImmAddr i off0      -> Just (ImmAddr i (off0 + off))
+
+      AddrBaseIndex r i (ImmInt n) -> Just (AddrBaseIndex r i (ImmInt (n + off)))
+      AddrBaseIndex r i (ImmInteger n)
+        -> Just (AddrBaseIndex r i (ImmInt (fromInteger (n + toInteger off))))
+
+      AddrBaseIndex r i (ImmCLbl lbl)
+        -> Just (AddrBaseIndex r i (ImmIndex lbl off))
+
+      AddrBaseIndex r i (ImmIndex lbl ix)
+        -> Just (AddrBaseIndex r i (ImmIndex lbl (ix+off)))
+
+      _ -> Nothing  -- in theory, shouldn't happen
+
+
+addrModeRegs :: AddrMode -> [Reg]
+addrModeRegs (AddrBaseIndex b i _) =  b_regs ++ i_regs
+  where
+   b_regs = case b of { EABaseReg r -> [r]; _ -> [] }
+   i_regs = case i of { EAIndex r _ -> [r]; _ -> [] }
+addrModeRegs _ = []
+
+
+-- registers -------------------------------------------------------------------
+
+-- @spRel@ gives us a stack relative addressing mode for volatile
+-- temporaries and for excess call arguments.  @fpRel@, where
+-- applicable, is the same but for the frame pointer.
+
+
+spRel :: DynFlags
+      -> Int -- ^ desired stack offset in bytes, positive or negative
+      -> AddrMode
+spRel dflags n
+ | target32Bit (targetPlatform dflags)
+    = AddrBaseIndex (EABaseReg esp) EAIndexNone (ImmInt n)
+ | otherwise
+    = AddrBaseIndex (EABaseReg rsp) EAIndexNone (ImmInt n)
+
+-- The register numbers must fit into 32 bits on x86, so that we can
+-- use a Word32 to represent the set of free registers in the register
+-- allocator.
+
+firstfake, lastfake :: RegNo
+firstfake = 16
+lastfake  = 21
+
+firstxmm :: RegNo
+firstxmm  = 24
+
+lastxmm :: Platform -> RegNo
+lastxmm platform
+ | target32Bit platform = 31
+ | otherwise            = 39
+
+lastint :: Platform -> RegNo
+lastint platform
+ | target32Bit platform = 7 -- not %r8..%r15
+ | otherwise            = 15
+
+intregnos :: Platform -> [RegNo]
+intregnos platform = [0 .. lastint platform]
+
+fakeregnos :: [RegNo]
+fakeregnos  = [firstfake .. lastfake]
+
+xmmregnos :: Platform -> [RegNo]
+xmmregnos platform = [firstxmm  .. lastxmm platform]
+
+floatregnos :: Platform -> [RegNo]
+floatregnos platform = fakeregnos ++ xmmregnos platform
+
+-- argRegs is the set of regs which are read for an n-argument call to C.
+-- For archs which pass all args on the stack (x86), is empty.
+-- Sparc passes up to the first 6 args in regs.
+argRegs :: RegNo -> [Reg]
+argRegs _       = panic "MachRegs.argRegs(x86): should not be used!"
+
+-- | The complete set of machine registers.
+allMachRegNos :: Platform -> [RegNo]
+allMachRegNos platform = intregnos platform ++ floatregnos platform
+
+-- | Take the class of a register.
+{-# INLINE classOfRealReg #-}
+classOfRealReg :: Platform -> RealReg -> RegClass
+-- On x86, we might want to have an 8-bit RegClass, which would
+-- contain just regs 1-4 (the others don't have 8-bit versions).
+-- However, we can get away without this at the moment because the
+-- only allocatable integer regs are also 8-bit compatible (1, 3, 4).
+classOfRealReg platform reg
+ = case reg of
+        RealRegSingle i
+          | i <= lastint platform -> RcInteger
+          | i <= lastfake         -> RcDouble
+          | otherwise             -> RcDoubleSSE
+
+        RealRegPair{}   -> panic "X86.Regs.classOfRealReg: RegPairs on this arch"
+
+-- | Get the name of the register with this number.
+showReg :: Platform -> RegNo -> String
+showReg platform n
+        | n >= firstxmm  = "%xmm" ++ show (n-firstxmm)
+        | n >= firstfake = "%fake" ++ show (n-firstfake)
+        | n >= 8         = "%r" ++ show n
+        | otherwise      = regNames platform A.! n
+
+regNames :: Platform -> A.Array Int String
+regNames platform
+    = if target32Bit platform
+      then A.listArray (0,8) ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp"]
+      else A.listArray (0,8) ["%rax", "%rbx", "%rcx", "%rdx", "%rsi", "%rdi", "%rbp", "%rsp"]
+
+
+
+-- machine specific ------------------------------------------------------------
+
+
+{-
+Intel x86 architecture:
+- All registers except 7 (esp) are available for use.
+- Only ebx, esi, edi and esp are available across a C call (they are callee-saves).
+- Registers 0-7 have 16-bit counterparts (ax, bx etc.)
+- Registers 0-3 have 8 bit counterparts (ah, bh etc.)
+- Registers fake0..fake5 are fakes; we pretend x86 has 6 conventionally-addressable
+  fp registers, and 3-operand insns for them, and we translate this into
+  real stack-based x86 fp code after register allocation.
+
+The fp registers are all Double registers; we don't have any RcFloat class
+regs.  @regClass@ barfs if you give it a VirtualRegF, and mkVReg above should
+never generate them.
+-}
+
+fake0, fake1, fake2, fake3, fake4, fake5,
+       eax, ebx, ecx, edx, esp, ebp, esi, edi :: Reg
+
+eax   = regSingle 0
+ebx   = regSingle 1
+ecx   = regSingle 2
+edx   = regSingle 3
+esi   = regSingle 4
+edi   = regSingle 5
+ebp   = regSingle 6
+esp   = regSingle 7
+fake0 = regSingle 16
+fake1 = regSingle 17
+fake2 = regSingle 18
+fake3 = regSingle 19
+fake4 = regSingle 20
+fake5 = regSingle 21
+
+
+
+{-
+AMD x86_64 architecture:
+- All 16 integer registers are addressable as 8, 16, 32 and 64-bit values:
+
+  8     16    32    64
+  ---------------------
+  al    ax    eax   rax
+  bl    bx    ebx   rbx
+  cl    cx    ecx   rcx
+  dl    dx    edx   rdx
+  sil   si    esi   rsi
+  dil   si    edi   rdi
+  bpl   bp    ebp   rbp
+  spl   sp    esp   rsp
+  r10b  r10w  r10d  r10
+  r11b  r11w  r11d  r11
+  r12b  r12w  r12d  r12
+  r13b  r13w  r13d  r13
+  r14b  r14w  r14d  r14
+  r15b  r15w  r15d  r15
+-}
+
+rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi,
+  r8, r9, r10, r11, r12, r13, r14, r15,
+  xmm0, xmm1, xmm2, xmm3, xmm4, xmm5, xmm6, xmm7,
+  xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15 :: Reg
+
+rax   = regSingle 0
+rbx   = regSingle 1
+rcx   = regSingle 2
+rdx   = regSingle 3
+rsi   = regSingle 4
+rdi   = regSingle 5
+rbp   = regSingle 6
+rsp   = regSingle 7
+r8    = regSingle 8
+r9    = regSingle 9
+r10   = regSingle 10
+r11   = regSingle 11
+r12   = regSingle 12
+r13   = regSingle 13
+r14   = regSingle 14
+r15   = regSingle 15
+xmm0  = regSingle 24
+xmm1  = regSingle 25
+xmm2  = regSingle 26
+xmm3  = regSingle 27
+xmm4  = regSingle 28
+xmm5  = regSingle 29
+xmm6  = regSingle 30
+xmm7  = regSingle 31
+xmm8  = regSingle 32
+xmm9  = regSingle 33
+xmm10 = regSingle 34
+xmm11 = regSingle 35
+xmm12 = regSingle 36
+xmm13 = regSingle 37
+xmm14 = regSingle 38
+xmm15 = regSingle 39
+
+ripRel :: Displacement -> AddrMode
+ripRel imm      = AddrBaseIndex EABaseRip EAIndexNone imm
+
+
+ -- so we can re-use some x86 code:
+{-
+eax = rax
+ebx = rbx
+ecx = rcx
+edx = rdx
+esi = rsi
+edi = rdi
+ebp = rbp
+esp = rsp
+-}
+
+xmm :: RegNo -> Reg
+xmm n = regSingle (firstxmm+n)
+
+
+
+
+-- | these are the regs which we cannot assume stay alive over a C call.
+callClobberedRegs       :: Platform -> [Reg]
+-- caller-saves registers
+callClobberedRegs platform
+ | target32Bit platform = [eax,ecx,edx] ++ map regSingle (floatregnos platform)
+ | platformOS platform == OSMinGW32
+   = [rax,rcx,rdx,r8,r9,r10,r11]
+   -- Only xmm0-5 are caller-saves registers on 64bit windows.
+   -- ( https://docs.microsoft.com/en-us/cpp/build/register-usage )
+   -- For details check the Win64 ABI.
+   ++ map regSingle fakeregnos ++ map xmm [0  .. 5]
+ | otherwise
+    -- all xmm regs are caller-saves
+    -- caller-saves registers
+    = [rax,rcx,rdx,rsi,rdi,r8,r9,r10,r11]
+   ++ map regSingle (floatregnos platform)
+
+allArgRegs :: Platform -> [(Reg, Reg)]
+allArgRegs platform
+ | platformOS platform == OSMinGW32 = zip [rcx,rdx,r8,r9]
+                                          (map regSingle [firstxmm ..])
+ | otherwise = panic "X86.Regs.allArgRegs: not defined for this arch"
+
+allIntArgRegs :: Platform -> [Reg]
+allIntArgRegs platform
+ | (platformOS platform == OSMinGW32) || target32Bit platform
+    = panic "X86.Regs.allIntArgRegs: not defined for this platform"
+ | otherwise = [rdi,rsi,rdx,rcx,r8,r9]
+
+allFPArgRegs :: Platform -> [Reg]
+allFPArgRegs platform
+ | platformOS platform == OSMinGW32
+    = panic "X86.Regs.allFPArgRegs: not defined for this platform"
+ | otherwise = map regSingle [firstxmm .. firstxmm+7]
+
+-- Machine registers which might be clobbered by instructions that
+-- generate results into fixed registers, or need arguments in a fixed
+-- register.
+instrClobberedRegs :: Platform -> [Reg]
+instrClobberedRegs platform
+ | target32Bit platform = [ eax, ecx, edx ]
+ | otherwise            = [ rax, rcx, rdx ]
+
+--
+
+-- allocatableRegs is allMachRegNos with the fixed-use regs removed.
+-- i.e., these are the regs for which we are prepared to allow the
+-- register allocator to attempt to map VRegs to.
+allocatableRegs :: Platform -> [RealReg]
+allocatableRegs platform
+   = let isFree i = freeReg platform i
+     in  map RealRegSingle $ filter isFree (allMachRegNos platform)
+
diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs
new file mode 100644
--- /dev/null
+++ b/compiler/prelude/PrelInfo.hs
@@ -0,0 +1,285 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+-}
+
+{-# LANGUAGE CPP #-}
+
+-- | The @PrelInfo@ interface to the compiler's prelude knowledge.
+--
+-- This module serves as the central gathering point for names which the
+-- compiler knows something about. This includes functions for,
+--
+--  * discerning whether a 'Name' is known-key
+--
+--  * given a 'Unique', looking up its corresponding known-key 'Name'
+--
+-- See Note [Known-key names] and Note [About wired-in things] for information
+-- about the two types of prelude things in GHC.
+--
+module PrelInfo (
+        -- * Known-key names
+        isKnownKeyName,
+        lookupKnownKeyName,
+        lookupKnownNameInfo,
+
+        -- ** Internal use
+        -- | 'knownKeyNames' is exported to seed the original name cache only;
+        -- if you find yourself wanting to look at it you might consider using
+        -- 'lookupKnownKeyName' or 'isKnownKeyName'.
+        knownKeyNames,
+
+        -- * Miscellaneous
+        wiredInIds, ghcPrimIds,
+        primOpRules, builtinRules,
+
+        ghcPrimExports,
+        primOpId,
+
+        -- * Random other things
+        maybeCharLikeCon, maybeIntLikeCon,
+
+        -- * Class categories
+        isNumericClass, isStandardClass
+
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import KnownUniques
+import Unique           ( isValidKnownKeyUnique )
+
+import ConLike          ( ConLike(..) )
+import THNames          ( templateHaskellNames )
+import PrelNames
+import PrelRules
+import Avail
+import PrimOp
+import DataCon
+import Id
+import Name
+import NameEnv
+import MkId
+import Outputable
+import TysPrim
+import TysWiredIn
+import HscTypes
+import Class
+import TyCon
+import UniqFM
+import Util
+import TcTypeNats ( typeNatTyCons )
+
+import Control.Applicative ((<|>))
+import Data.List        ( intercalate )
+import Data.Array
+import Data.Maybe
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[builtinNameInfo]{Lookup built-in names}
+*                                                                      *
+************************************************************************
+
+Note [About wired-in things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Wired-in things are Ids\/TyCons that are completely known to the compiler.
+  They are global values in GHC, (e.g.  listTyCon :: TyCon).
+
+* A wired in Name contains the thing itself inside the Name:
+        see Name.wiredInNameTyThing_maybe
+  (E.g. listTyConName contains listTyCon.
+
+* The name cache is initialised with (the names of) all wired-in things
+  (except tuples and sums; see Note [Known-])
+
+* The type environment itself contains no wired in things. The type
+  checker sees if the Name is wired in before looking up the name in
+  the type environment.
+
+* MkIface prunes out wired-in things before putting them in an interface file.
+  So interface files never contain wired-in things.
+-}
+
+
+-- | This list is used to ensure that when you say "Prelude.map" in your source
+-- code, or in an interface file, you get a Name with the correct known key (See
+-- Note [Known-key names] in PrelNames)
+knownKeyNames :: [Name]
+knownKeyNames
+  | debugIsOn
+  , Just badNamesStr <- knownKeyNamesOkay all_names
+  = panic ("badAllKnownKeyNames:\n" ++ badNamesStr)
+       -- NB: We can't use ppr here, because this is sometimes evaluated in a
+       -- context where there are no DynFlags available, leading to a cryptic
+       -- "<<details unavailable>>" error. (This seems to happen only in the
+       -- stage 2 compiler, for reasons I [Richard] have no clue of.)
+  | otherwise
+  = all_names
+  where
+    all_names =
+      concat [ wired_tycon_kk_names funTyCon
+             , concatMap wired_tycon_kk_names primTyCons
+
+             , concatMap wired_tycon_kk_names wiredInTyCons
+               -- Does not include tuples
+
+             , concatMap wired_tycon_kk_names typeNatTyCons
+
+             , map idName wiredInIds
+             , map (idName . primOpId) allThePrimOps
+             , basicKnownKeyNames
+             , templateHaskellNames
+             ]
+    -- All of the names associated with a wired-in TyCon.
+    -- This includes the TyCon itself, its DataCons and promoted TyCons.
+    wired_tycon_kk_names :: TyCon -> [Name]
+    wired_tycon_kk_names tc =
+        tyConName tc : (rep_names tc ++ implicits)
+      where implicits = concatMap thing_kk_names (implicitTyConThings tc)
+
+    wired_datacon_kk_names :: DataCon -> [Name]
+    wired_datacon_kk_names dc =
+      dataConName dc : rep_names (promoteDataCon dc)
+
+    thing_kk_names :: TyThing -> [Name]
+    thing_kk_names (ATyCon tc)                 = wired_tycon_kk_names tc
+    thing_kk_names (AConLike (RealDataCon dc)) = wired_datacon_kk_names dc
+    thing_kk_names thing                       = [getName thing]
+
+    -- The TyConRepName for a known-key TyCon has a known key,
+    -- but isn't itself an implicit thing.  Yurgh.
+    -- NB: if any of the wired-in TyCons had record fields, the record
+    --     field names would be in a similar situation.  Ditto class ops.
+    --     But it happens that there aren't any
+    rep_names tc = case tyConRepName_maybe tc of
+                        Just n  -> [n]
+                        Nothing -> []
+
+-- | Check the known-key names list of consistency.
+knownKeyNamesOkay :: [Name] -> Maybe String
+knownKeyNamesOkay all_names
+  | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names
+  = Just $ "    Out-of-range known-key uniques: ["
+        ++ intercalate ", " (map (occNameString . nameOccName) ns) ++
+         "]"
+  | null badNamesPairs
+  = Nothing
+  | otherwise
+  = Just badNamesStr
+  where
+    namesEnv      = foldl' (\m n -> extendNameEnv_Acc (:) singleton m n n)
+                           emptyUFM all_names
+    badNamesEnv   = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv
+    badNamesPairs = nonDetUFMToList badNamesEnv
+      -- It's OK to use nonDetUFMToList here because the ordering only affects
+      -- the message when we get a panic
+    badNamesStrs  = map pairToStr badNamesPairs
+    badNamesStr   = unlines badNamesStrs
+
+    pairToStr (uniq, ns) = "        " ++
+                           show uniq ++
+                           ": [" ++
+                           intercalate ", " (map (occNameString . nameOccName) ns) ++
+                           "]"
+
+-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a
+-- known-key thing.
+lookupKnownKeyName :: Unique -> Maybe Name
+lookupKnownKeyName u =
+    knownUniqueName u <|> lookupUFM knownKeysMap u
+
+-- | Is a 'Name' known-key?
+isKnownKeyName :: Name -> Bool
+isKnownKeyName n =
+    isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap
+
+knownKeysMap :: UniqFM Name
+knownKeysMap = listToUFM [ (nameUnique n, n) | n <- knownKeyNames ]
+
+-- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by
+-- GHCi's ':info' command.
+lookupKnownNameInfo :: Name -> SDoc
+lookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of
+    -- If we do find a doc, we add comment delimeters to make the output
+    -- of ':info' valid Haskell.
+    Nothing  -> empty
+    Just doc -> vcat [text "{-", doc, text "-}"]
+
+-- A map from Uniques to SDocs, used in GHCi's ':info' command. (#12390)
+knownNamesInfo :: NameEnv SDoc
+knownNamesInfo = unitNameEnv coercibleTyConName $
+    vcat [ text "Coercible is a special constraint with custom solving rules."
+         , text "It is not a class."
+         , text "Please see section 9.14.4 of the user's guide for details." ]
+
+{-
+We let a lot of "non-standard" values be visible, so that we can make
+sense of them in interface pragmas. It's cool, though they all have
+"non-standard" names, so they won't get past the parser in user code.
+
+************************************************************************
+*                                                                      *
+                PrimOpIds
+*                                                                      *
+************************************************************************
+-}
+
+primOpIds :: Array Int Id
+-- A cache of the PrimOp Ids, indexed by PrimOp tag
+primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op)
+                                   | op <- allThePrimOps ]
+
+primOpId :: PrimOp -> Id
+primOpId op = primOpIds ! primOpTag op
+
+{-
+************************************************************************
+*                                                                      *
+            Export lists for pseudo-modules (GHC.Prim)
+*                                                                      *
+************************************************************************
+
+GHC.Prim "exports" all the primops and primitive types, some
+wired-in Ids.
+-}
+
+ghcPrimExports :: [IfaceExport]
+ghcPrimExports
+ = map (avail . idName) ghcPrimIds ++
+   map (avail . idName . primOpId) allThePrimOps ++
+   [ AvailTC n [n] []
+   | tc <- funTyCon : exposedPrimTyCons, let n = tyConName tc  ]
+
+{-
+************************************************************************
+*                                                                      *
+            Built-in keys
+*                                                                      *
+************************************************************************
+
+ToDo: make it do the ``like'' part properly (as in 0.26 and before).
+-}
+
+maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool
+maybeCharLikeCon con = con `hasKey` charDataConKey
+maybeIntLikeCon  con = con `hasKey` intDataConKey
+
+{-
+************************************************************************
+*                                                                      *
+            Class predicates
+*                                                                      *
+************************************************************************
+-}
+
+isNumericClass, isStandardClass :: Class -> Bool
+
+isNumericClass     clas = classKey clas `is_elem` numericClassKeys
+isStandardClass    clas = classKey clas `is_elem` standardClassKeys
+
+is_elem :: Eq a => a -> [a] -> Bool
+is_elem = isIn "is_X_Class"
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
new file mode 100644
--- /dev/null
+++ b/compiler/prelude/THNames.hs
@@ -0,0 +1,1100 @@
+-- %************************************************************************
+-- %*                                                                   *
+--              The known-key names for Template Haskell
+-- %*                                                                   *
+-- %************************************************************************
+
+module THNames where
+
+import GhcPrelude ()
+
+import PrelNames( mk_known_key_name )
+import Module( Module, mkModuleNameFS, mkModule, thUnitId )
+import Name( Name )
+import OccName( tcName, clsName, dataName, varName )
+import RdrName( RdrName, nameRdrName )
+import Unique
+import FastString
+
+-- To add a name, do three things
+--
+--  1) Allocate a key
+--  2) Make a "Name"
+--  3) Add the name to templateHaskellNames
+
+templateHaskellNames :: [Name]
+-- The names that are implicitly mentioned by ``bracket''
+-- Should stay in sync with the import list of DsMeta
+
+templateHaskellNames = [
+    returnQName, bindQName, sequenceQName, newNameName, liftName,
+    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
+    mkNameSName,
+    liftStringName,
+    unTypeName,
+    unTypeQName,
+    unsafeTExpCoerceName,
+
+    -- Lit
+    charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
+    floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,
+    charPrimLName,
+    -- Pat
+    litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName,
+    conPName, tildePName, bangPName, infixPName,
+    asPName, wildPName, recPName, listPName, sigPName, viewPName,
+    -- FieldPat
+    fieldPatName,
+    -- Match
+    matchName,
+    -- Clause
+    clauseName,
+    -- Exp
+    varEName, conEName, litEName, appEName, appTypeEName, infixEName,
+    infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,
+    tupEName, unboxedTupEName, unboxedSumEName,
+    condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,
+    fromEName, fromThenEName, fromToEName, fromThenToEName,
+    listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,
+    labelEName, implicitParamVarEName,
+    -- FieldExp
+    fieldExpName,
+    -- Body
+    guardedBName, normalBName,
+    -- Guard
+    normalGEName, patGEName,
+    -- Stmt
+    bindSName, letSName, noBindSName, parSName, recSName,
+    -- Dec
+    funDName, valDName, dataDName, newtypeDName, tySynDName,
+    classDName, instanceWithOverlapDName,
+    standaloneDerivWithStrategyDName, sigDName, forImpDName,
+    pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
+    pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName,
+    dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
+    dataInstDName, newtypeInstDName, tySynInstDName,
+    infixLDName, infixRDName, infixNDName,
+    roleAnnotDName, patSynDName, patSynSigDName,
+    implicitParamBindDName,
+    -- Cxt
+    cxtName,
+
+    -- SourceUnpackedness
+    noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName,
+    -- SourceStrictness
+    noSourceStrictnessName, sourceLazyName, sourceStrictName,
+    -- Con
+    normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName,
+    -- Bang
+    bangName,
+    -- BangType
+    bangTypeName,
+    -- VarBangType
+    varBangTypeName,
+    -- PatSynDir (for pattern synonyms)
+    unidirPatSynName, implBidirPatSynName, explBidirPatSynName,
+    -- PatSynArgs (for pattern synonyms)
+    prefixPatSynName, infixPatSynName, recordPatSynName,
+    -- Type
+    forallTName, varTName, conTName, infixTName, appTName, appKindTName,
+    equalityTName, tupleTName, unboxedTupleTName, unboxedSumTName,
+    arrowTName, listTName, sigTName, litTName,
+    promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
+    wildCardTName, implicitParamTName,
+    -- TyLit
+    numTyLitName, strTyLitName,
+    -- TyVarBndr
+    plainTVName, kindedTVName,
+    -- Role
+    nominalRName, representationalRName, phantomRName, inferRName,
+    -- Kind
+    varKName, conKName, tupleKName, arrowKName, listKName, appKName,
+    starKName, constraintKName,
+    -- FamilyResultSig
+    noSigName, kindSigName, tyVarSigName,
+    -- InjectivityAnn
+    injectivityAnnName,
+    -- Callconv
+    cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName,
+    -- Safety
+    unsafeName,
+    safeName,
+    interruptibleName,
+    -- Inline
+    noInlineDataConName, inlineDataConName, inlinableDataConName,
+    -- RuleMatch
+    conLikeDataConName, funLikeDataConName,
+    -- Phases
+    allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,
+    -- Overlap
+    overlappableDataConName, overlappingDataConName, overlapsDataConName,
+    incoherentDataConName,
+    -- DerivStrategy
+    stockStrategyName, anyclassStrategyName,
+    newtypeStrategyName, viaStrategyName,
+    -- TExp
+    tExpDataConName,
+    -- RuleBndr
+    ruleVarName, typedRuleVarName,
+    -- FunDep
+    funDepName,
+    -- TySynEqn
+    tySynEqnName,
+    -- AnnTarget
+    valueAnnotationName, typeAnnotationName, moduleAnnotationName,
+    -- DerivClause
+    derivClauseName,
+
+    -- The type classes
+    liftClassName,
+
+    -- And the tycons
+    qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
+    clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
+    stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName,
+    varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
+    typeTyConName, tyVarBndrQTyConName, matchTyConName, clauseTyConName,
+    patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
+    predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
+    roleTyConName, tExpTyConName, injAnnTyConName, kindQTyConName,
+    overlapTyConName, derivClauseQTyConName, derivStrategyQTyConName,
+
+    -- Quasiquoting
+    quoteDecName, quoteTypeName, quoteExpName, quotePatName]
+
+thSyn, thLib, qqLib :: Module
+thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")
+thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal")
+qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
+
+mkTHModule :: FastString -> Module
+mkTHModule m = mkModule thUnitId (mkModuleNameFS m)
+
+libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name
+libFun = mk_known_key_name OccName.varName  thLib
+libTc  = mk_known_key_name OccName.tcName   thLib
+thFun  = mk_known_key_name OccName.varName  thSyn
+thTc   = mk_known_key_name OccName.tcName   thSyn
+thCls  = mk_known_key_name OccName.clsName  thSyn
+thCon  = mk_known_key_name OccName.dataName thSyn
+qqFun  = mk_known_key_name OccName.varName  qqLib
+
+-------------------- TH.Syntax -----------------------
+liftClassName :: Name
+liftClassName = thCls (fsLit "Lift") liftClassKey
+
+qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
+    fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
+    matchTyConName, clauseTyConName, funDepTyConName, predTyConName,
+    tExpTyConName, injAnnTyConName, overlapTyConName :: Name
+qTyConName             = thTc (fsLit "Q")              qTyConKey
+nameTyConName          = thTc (fsLit "Name")           nameTyConKey
+fieldExpTyConName      = thTc (fsLit "FieldExp")       fieldExpTyConKey
+patTyConName           = thTc (fsLit "Pat")            patTyConKey
+fieldPatTyConName      = thTc (fsLit "FieldPat")       fieldPatTyConKey
+expTyConName           = thTc (fsLit "Exp")            expTyConKey
+decTyConName           = thTc (fsLit "Dec")            decTyConKey
+typeTyConName          = thTc (fsLit "Type")           typeTyConKey
+matchTyConName         = thTc (fsLit "Match")          matchTyConKey
+clauseTyConName        = thTc (fsLit "Clause")         clauseTyConKey
+funDepTyConName        = thTc (fsLit "FunDep")         funDepTyConKey
+predTyConName          = thTc (fsLit "Pred")           predTyConKey
+tExpTyConName          = thTc (fsLit "TExp")           tExpTyConKey
+injAnnTyConName        = thTc (fsLit "InjectivityAnn") injAnnTyConKey
+overlapTyConName       = thTc (fsLit "Overlap")        overlapTyConKey
+
+returnQName, bindQName, sequenceQName, newNameName, liftName,
+    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
+    mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName,
+    unsafeTExpCoerceName :: Name
+returnQName    = thFun (fsLit "returnQ")   returnQIdKey
+bindQName      = thFun (fsLit "bindQ")     bindQIdKey
+sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey
+newNameName    = thFun (fsLit "newName")   newNameIdKey
+liftName       = thFun (fsLit "lift")      liftIdKey
+liftStringName = thFun (fsLit "liftString")  liftStringIdKey
+mkNameName     = thFun (fsLit "mkName")     mkNameIdKey
+mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey
+mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey
+mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
+mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey
+mkNameSName    = thFun (fsLit "mkNameS")    mkNameSIdKey
+unTypeName     = thFun (fsLit "unType")     unTypeIdKey
+unTypeQName    = thFun (fsLit "unTypeQ")    unTypeQIdKey
+unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey
+
+
+-------------------- TH.Lib -----------------------
+-- data Lit = ...
+charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
+    floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,
+    charPrimLName :: Name
+charLName       = libFun (fsLit "charL")       charLIdKey
+stringLName     = libFun (fsLit "stringL")     stringLIdKey
+integerLName    = libFun (fsLit "integerL")    integerLIdKey
+intPrimLName    = libFun (fsLit "intPrimL")    intPrimLIdKey
+wordPrimLName   = libFun (fsLit "wordPrimL")   wordPrimLIdKey
+floatPrimLName  = libFun (fsLit "floatPrimL")  floatPrimLIdKey
+doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey
+rationalLName   = libFun (fsLit "rationalL")     rationalLIdKey
+stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey
+charPrimLName   = libFun (fsLit "charPrimL")   charPrimLIdKey
+
+-- data Pat = ...
+litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName,
+    infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName,
+    sigPName, viewPName :: Name
+litPName   = libFun (fsLit "litP")   litPIdKey
+varPName   = libFun (fsLit "varP")   varPIdKey
+tupPName   = libFun (fsLit "tupP")   tupPIdKey
+unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey
+unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey
+conPName   = libFun (fsLit "conP")   conPIdKey
+infixPName = libFun (fsLit "infixP") infixPIdKey
+tildePName = libFun (fsLit "tildeP") tildePIdKey
+bangPName  = libFun (fsLit "bangP")  bangPIdKey
+asPName    = libFun (fsLit "asP")    asPIdKey
+wildPName  = libFun (fsLit "wildP")  wildPIdKey
+recPName   = libFun (fsLit "recP")   recPIdKey
+listPName  = libFun (fsLit "listP")  listPIdKey
+sigPName   = libFun (fsLit "sigP")   sigPIdKey
+viewPName  = libFun (fsLit "viewP")  viewPIdKey
+
+-- type FieldPat = ...
+fieldPatName :: Name
+fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey
+
+-- data Match = ...
+matchName :: Name
+matchName = libFun (fsLit "match") matchIdKey
+
+-- data Clause = ...
+clauseName :: Name
+clauseName = libFun (fsLit "clause") clauseIdKey
+
+-- data Exp = ...
+varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,
+    sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
+    unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,
+    caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,
+    labelEName, implicitParamVarEName :: Name
+varEName              = libFun (fsLit "varE")              varEIdKey
+conEName              = libFun (fsLit "conE")              conEIdKey
+litEName              = libFun (fsLit "litE")              litEIdKey
+appEName              = libFun (fsLit "appE")              appEIdKey
+appTypeEName          = libFun (fsLit "appTypeE")          appTypeEIdKey
+infixEName            = libFun (fsLit "infixE")            infixEIdKey
+infixAppName          = libFun (fsLit "infixApp")          infixAppIdKey
+sectionLName          = libFun (fsLit "sectionL")          sectionLIdKey
+sectionRName          = libFun (fsLit "sectionR")          sectionRIdKey
+lamEName              = libFun (fsLit "lamE")              lamEIdKey
+lamCaseEName          = libFun (fsLit "lamCaseE")          lamCaseEIdKey
+tupEName              = libFun (fsLit "tupE")              tupEIdKey
+unboxedTupEName       = libFun (fsLit "unboxedTupE")       unboxedTupEIdKey
+unboxedSumEName       = libFun (fsLit "unboxedSumE")       unboxedSumEIdKey
+condEName             = libFun (fsLit "condE")             condEIdKey
+multiIfEName          = libFun (fsLit "multiIfE")          multiIfEIdKey
+letEName              = libFun (fsLit "letE")              letEIdKey
+caseEName             = libFun (fsLit "caseE")             caseEIdKey
+doEName               = libFun (fsLit "doE")               doEIdKey
+mdoEName              = libFun (fsLit "mdoE")              mdoEIdKey
+compEName             = libFun (fsLit "compE")             compEIdKey
+-- ArithSeq skips a level
+fromEName, fromThenEName, fromToEName, fromThenToEName :: Name
+fromEName             = libFun (fsLit "fromE")             fromEIdKey
+fromThenEName         = libFun (fsLit "fromThenE")         fromThenEIdKey
+fromToEName           = libFun (fsLit "fromToE")           fromToEIdKey
+fromThenToEName       = libFun (fsLit "fromThenToE")       fromThenToEIdKey
+-- end ArithSeq
+listEName, sigEName, recConEName, recUpdEName :: Name
+listEName             = libFun (fsLit "listE")             listEIdKey
+sigEName              = libFun (fsLit "sigE")              sigEIdKey
+recConEName           = libFun (fsLit "recConE")           recConEIdKey
+recUpdEName           = libFun (fsLit "recUpdE")           recUpdEIdKey
+staticEName           = libFun (fsLit "staticE")           staticEIdKey
+unboundVarEName       = libFun (fsLit "unboundVarE")       unboundVarEIdKey
+labelEName            = libFun (fsLit "labelE")            labelEIdKey
+implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey
+
+-- type FieldExp = ...
+fieldExpName :: Name
+fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey
+
+-- data Body = ...
+guardedBName, normalBName :: Name
+guardedBName = libFun (fsLit "guardedB") guardedBIdKey
+normalBName  = libFun (fsLit "normalB")  normalBIdKey
+
+-- data Guard = ...
+normalGEName, patGEName :: Name
+normalGEName = libFun (fsLit "normalGE") normalGEIdKey
+patGEName    = libFun (fsLit "patGE")    patGEIdKey
+
+-- data Stmt = ...
+bindSName, letSName, noBindSName, parSName, recSName :: Name
+bindSName   = libFun (fsLit "bindS")   bindSIdKey
+letSName    = libFun (fsLit "letS")    letSIdKey
+noBindSName = libFun (fsLit "noBindS") noBindSIdKey
+parSName    = libFun (fsLit "parS")    parSIdKey
+recSName    = libFun (fsLit "recS")    recSIdKey
+
+-- data Dec = ...
+funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
+    instanceWithOverlapDName, sigDName, forImpDName, pragInlDName,
+    pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,
+    pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName,
+    dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
+    openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
+    infixNDName, roleAnnotDName, patSynDName, patSynSigDName,
+    pragCompleteDName, implicitParamBindDName :: Name
+funDName                         = libFun (fsLit "funD")                         funDIdKey
+valDName                         = libFun (fsLit "valD")                         valDIdKey
+dataDName                        = libFun (fsLit "dataD")                        dataDIdKey
+newtypeDName                     = libFun (fsLit "newtypeD")                     newtypeDIdKey
+tySynDName                       = libFun (fsLit "tySynD")                       tySynDIdKey
+classDName                       = libFun (fsLit "classD")                       classDIdKey
+instanceWithOverlapDName         = libFun (fsLit "instanceWithOverlapD")         instanceWithOverlapDIdKey
+standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey
+sigDName                         = libFun (fsLit "sigD")                         sigDIdKey
+defaultSigDName                  = libFun (fsLit "defaultSigD")                  defaultSigDIdKey
+forImpDName                      = libFun (fsLit "forImpD")                      forImpDIdKey
+pragInlDName                     = libFun (fsLit "pragInlD")                     pragInlDIdKey
+pragSpecDName                    = libFun (fsLit "pragSpecD")                    pragSpecDIdKey
+pragSpecInlDName                 = libFun (fsLit "pragSpecInlD")                 pragSpecInlDIdKey
+pragSpecInstDName                = libFun (fsLit "pragSpecInstD")                pragSpecInstDIdKey
+pragRuleDName                    = libFun (fsLit "pragRuleD")                    pragRuleDIdKey
+pragCompleteDName                = libFun (fsLit "pragCompleteD")                pragCompleteDIdKey
+pragAnnDName                     = libFun (fsLit "pragAnnD")                     pragAnnDIdKey
+dataInstDName                    = libFun (fsLit "dataInstD")                    dataInstDIdKey
+newtypeInstDName                 = libFun (fsLit "newtypeInstD")                 newtypeInstDIdKey
+tySynInstDName                   = libFun (fsLit "tySynInstD")                   tySynInstDIdKey
+openTypeFamilyDName              = libFun (fsLit "openTypeFamilyD")              openTypeFamilyDIdKey
+closedTypeFamilyDName            = libFun (fsLit "closedTypeFamilyD")            closedTypeFamilyDIdKey
+dataFamilyDName                  = libFun (fsLit "dataFamilyD")                  dataFamilyDIdKey
+infixLDName                      = libFun (fsLit "infixLD")                      infixLDIdKey
+infixRDName                      = libFun (fsLit "infixRD")                      infixRDIdKey
+infixNDName                      = libFun (fsLit "infixND")                      infixNDIdKey
+roleAnnotDName                   = libFun (fsLit "roleAnnotD")                   roleAnnotDIdKey
+patSynDName                      = libFun (fsLit "patSynD")                      patSynDIdKey
+patSynSigDName                   = libFun (fsLit "patSynSigD")                   patSynSigDIdKey
+implicitParamBindDName           = libFun (fsLit "implicitParamBindD")           implicitParamBindDIdKey
+
+-- type Ctxt = ...
+cxtName :: Name
+cxtName = libFun (fsLit "cxt") cxtIdKey
+
+-- data SourceUnpackedness = ...
+noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name
+noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey
+sourceNoUnpackName       = libFun (fsLit "sourceNoUnpack")       sourceNoUnpackKey
+sourceUnpackName         = libFun (fsLit "sourceUnpack")         sourceUnpackKey
+
+-- data SourceStrictness = ...
+noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name
+noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey
+sourceLazyName         = libFun (fsLit "sourceLazy")         sourceLazyKey
+sourceStrictName       = libFun (fsLit "sourceStrict")       sourceStrictKey
+
+-- data Con = ...
+normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name
+normalCName  = libFun (fsLit "normalC" ) normalCIdKey
+recCName     = libFun (fsLit "recC"    ) recCIdKey
+infixCName   = libFun (fsLit "infixC"  ) infixCIdKey
+forallCName  = libFun (fsLit "forallC" ) forallCIdKey
+gadtCName    = libFun (fsLit "gadtC"   ) gadtCIdKey
+recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey
+
+-- data Bang = ...
+bangName :: Name
+bangName = libFun (fsLit "bang") bangIdKey
+
+-- type BangType = ...
+bangTypeName :: Name
+bangTypeName = libFun (fsLit "bangType") bangTKey
+
+-- type VarBangType = ...
+varBangTypeName :: Name
+varBangTypeName = libFun (fsLit "varBangType") varBangTKey
+
+-- data PatSynDir = ...
+unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: Name
+unidirPatSynName    = libFun (fsLit "unidir")    unidirPatSynIdKey
+implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey
+explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey
+
+-- data PatSynArgs = ...
+prefixPatSynName, infixPatSynName, recordPatSynName :: Name
+prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey
+infixPatSynName  = libFun (fsLit "infixPatSyn")  infixPatSynIdKey
+recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey
+
+-- data Type = ...
+forallTName, varTName, conTName, infixTName, tupleTName, unboxedTupleTName,
+    unboxedSumTName, arrowTName, listTName, appTName, appKindTName,
+    sigTName, equalityTName, litTName, promotedTName,
+    promotedTupleTName, promotedNilTName, promotedConsTName,
+    wildCardTName, implicitParamTName :: Name
+forallTName         = libFun (fsLit "forallT")        forallTIdKey
+varTName            = libFun (fsLit "varT")           varTIdKey
+conTName            = libFun (fsLit "conT")           conTIdKey
+tupleTName          = libFun (fsLit "tupleT")         tupleTIdKey
+unboxedTupleTName   = libFun (fsLit "unboxedTupleT")  unboxedTupleTIdKey
+unboxedSumTName     = libFun (fsLit "unboxedSumT")    unboxedSumTIdKey
+arrowTName          = libFun (fsLit "arrowT")         arrowTIdKey
+listTName           = libFun (fsLit "listT")          listTIdKey
+appTName            = libFun (fsLit "appT")           appTIdKey
+appKindTName        = libFun (fsLit "appKindT")       appKindTIdKey
+sigTName            = libFun (fsLit "sigT")           sigTIdKey
+equalityTName       = libFun (fsLit "equalityT")      equalityTIdKey
+litTName            = libFun (fsLit "litT")           litTIdKey
+promotedTName       = libFun (fsLit "promotedT")      promotedTIdKey
+promotedTupleTName  = libFun (fsLit "promotedTupleT") promotedTupleTIdKey
+promotedNilTName    = libFun (fsLit "promotedNilT")   promotedNilTIdKey
+promotedConsTName   = libFun (fsLit "promotedConsT")  promotedConsTIdKey
+wildCardTName       = libFun (fsLit "wildCardT")      wildCardTIdKey
+infixTName          = libFun (fsLit "infixT")         infixTIdKey
+implicitParamTName  = libFun (fsLit "implicitParamT") implicitParamTIdKey
+
+-- data TyLit = ...
+numTyLitName, strTyLitName :: Name
+numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey
+strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey
+
+-- data TyVarBndr = ...
+plainTVName, kindedTVName :: Name
+plainTVName  = libFun (fsLit "plainTV")  plainTVIdKey
+kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
+
+-- data Role = ...
+nominalRName, representationalRName, phantomRName, inferRName :: Name
+nominalRName          = libFun (fsLit "nominalR")          nominalRIdKey
+representationalRName = libFun (fsLit "representationalR") representationalRIdKey
+phantomRName          = libFun (fsLit "phantomR")          phantomRIdKey
+inferRName            = libFun (fsLit "inferR")            inferRIdKey
+
+-- data Kind = ...
+varKName, conKName, tupleKName, arrowKName, listKName, appKName,
+  starKName, constraintKName :: Name
+varKName        = libFun (fsLit "varK")         varKIdKey
+conKName        = libFun (fsLit "conK")         conKIdKey
+tupleKName      = libFun (fsLit "tupleK")       tupleKIdKey
+arrowKName      = libFun (fsLit "arrowK")       arrowKIdKey
+listKName       = libFun (fsLit "listK")        listKIdKey
+appKName        = libFun (fsLit "appK")         appKIdKey
+starKName       = libFun (fsLit "starK")        starKIdKey
+constraintKName = libFun (fsLit "constraintK")  constraintKIdKey
+
+-- data FamilyResultSig = ...
+noSigName, kindSigName, tyVarSigName :: Name
+noSigName    = libFun (fsLit "noSig")    noSigIdKey
+kindSigName  = libFun (fsLit "kindSig")  kindSigIdKey
+tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey
+
+-- data InjectivityAnn = ...
+injectivityAnnName :: Name
+injectivityAnnName = libFun (fsLit "injectivityAnn") injectivityAnnIdKey
+
+-- data Callconv = ...
+cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name
+cCallName = libFun (fsLit "cCall") cCallIdKey
+stdCallName = libFun (fsLit "stdCall") stdCallIdKey
+cApiCallName = libFun (fsLit "cApi") cApiCallIdKey
+primCallName = libFun (fsLit "prim") primCallIdKey
+javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey
+
+-- data Safety = ...
+unsafeName, safeName, interruptibleName :: Name
+unsafeName     = libFun (fsLit "unsafe") unsafeIdKey
+safeName       = libFun (fsLit "safe") safeIdKey
+interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
+
+-- newtype TExp a = ...
+tExpDataConName :: Name
+tExpDataConName = thCon (fsLit "TExp") tExpDataConKey
+
+-- data RuleBndr = ...
+ruleVarName, typedRuleVarName :: Name
+ruleVarName      = libFun (fsLit ("ruleVar"))      ruleVarIdKey
+typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey
+
+-- data FunDep = ...
+funDepName :: Name
+funDepName     = libFun (fsLit "funDep") funDepIdKey
+
+-- data TySynEqn = ...
+tySynEqnName :: Name
+tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey
+
+-- data AnnTarget = ...
+valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name
+valueAnnotationName  = libFun (fsLit "valueAnnotation")  valueAnnotationIdKey
+typeAnnotationName   = libFun (fsLit "typeAnnotation")   typeAnnotationIdKey
+moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey
+
+-- type DerivClause = ...
+derivClauseName :: Name
+derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey
+
+-- data DerivStrategy = ...
+stockStrategyName, anyclassStrategyName, newtypeStrategyName,
+  viaStrategyName :: Name
+stockStrategyName    = libFun (fsLit "stockStrategy")    stockStrategyIdKey
+anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey
+newtypeStrategyName  = libFun (fsLit "newtypeStrategy")  newtypeStrategyIdKey
+viaStrategyName      = libFun (fsLit "viaStrategy")      viaStrategyIdKey
+
+matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
+    decQTyConName, conQTyConName, bangTypeQTyConName,
+    varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName,
+    patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
+    ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName,
+    derivClauseQTyConName, kindQTyConName, tyVarBndrQTyConName,
+    derivStrategyQTyConName :: Name
+matchQTyConName         = libTc (fsLit "MatchQ")         matchQTyConKey
+clauseQTyConName        = libTc (fsLit "ClauseQ")        clauseQTyConKey
+expQTyConName           = libTc (fsLit "ExpQ")           expQTyConKey
+stmtQTyConName          = libTc (fsLit "StmtQ")          stmtQTyConKey
+decQTyConName           = libTc (fsLit "DecQ")           decQTyConKey
+decsQTyConName          = libTc (fsLit "DecsQ")          decsQTyConKey  -- Q [Dec]
+conQTyConName           = libTc (fsLit "ConQ")           conQTyConKey
+bangTypeQTyConName      = libTc (fsLit "BangTypeQ")      bangTypeQTyConKey
+varBangTypeQTyConName   = libTc (fsLit "VarBangTypeQ")   varBangTypeQTyConKey
+typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey
+fieldExpQTyConName      = libTc (fsLit "FieldExpQ")      fieldExpQTyConKey
+patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey
+fieldPatQTyConName      = libTc (fsLit "FieldPatQ")      fieldPatQTyConKey
+predQTyConName          = libTc (fsLit "PredQ")          predQTyConKey
+ruleBndrQTyConName      = libTc (fsLit "RuleBndrQ")      ruleBndrQTyConKey
+tySynEqnQTyConName      = libTc (fsLit "TySynEqnQ")      tySynEqnQTyConKey
+roleTyConName           = libTc (fsLit "Role")           roleTyConKey
+derivClauseQTyConName   = libTc (fsLit "DerivClauseQ")   derivClauseQTyConKey
+kindQTyConName          = libTc (fsLit "KindQ")          kindQTyConKey
+tyVarBndrQTyConName     = libTc (fsLit "TyVarBndrQ")     tyVarBndrQTyConKey
+derivStrategyQTyConName = libTc (fsLit "DerivStrategyQ") derivStrategyQTyConKey
+
+-- quasiquoting
+quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
+quoteExpName        = qqFun (fsLit "quoteExp")  quoteExpKey
+quotePatName        = qqFun (fsLit "quotePat")  quotePatKey
+quoteDecName        = qqFun (fsLit "quoteDec")  quoteDecKey
+quoteTypeName       = qqFun (fsLit "quoteType") quoteTypeKey
+
+-- data Inline = ...
+noInlineDataConName, inlineDataConName, inlinableDataConName :: Name
+noInlineDataConName  = thCon (fsLit "NoInline")  noInlineDataConKey
+inlineDataConName    = thCon (fsLit "Inline")    inlineDataConKey
+inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey
+
+-- data RuleMatch = ...
+conLikeDataConName, funLikeDataConName :: Name
+conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey
+funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey
+
+-- data Phases = ...
+allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name
+allPhasesDataConName   = thCon (fsLit "AllPhases")   allPhasesDataConKey
+fromPhaseDataConName   = thCon (fsLit "FromPhase")   fromPhaseDataConKey
+beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey
+
+-- data Overlap = ...
+overlappableDataConName,
+  overlappingDataConName,
+  overlapsDataConName,
+  incoherentDataConName :: Name
+overlappableDataConName = thCon (fsLit "Overlappable") overlappableDataConKey
+overlappingDataConName  = thCon (fsLit "Overlapping")  overlappingDataConKey
+overlapsDataConName     = thCon (fsLit "Overlaps")     overlapsDataConKey
+incoherentDataConName   = thCon (fsLit "Incoherent")   incoherentDataConKey
+
+{- *********************************************************************
+*                                                                      *
+                     Class keys
+*                                                                      *
+********************************************************************* -}
+
+-- ClassUniques available: 200-299
+-- Check in PrelNames if you want to change this
+
+liftClassKey :: Unique
+liftClassKey = mkPreludeClassUnique 200
+
+{- *********************************************************************
+*                                                                      *
+                     TyCon keys
+*                                                                      *
+********************************************************************* -}
+
+-- TyConUniques available: 200-299
+-- Check in PrelNames if you want to change this
+
+expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
+    decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
+    stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey,
+    tyVarBndrQTyConKey, decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,
+    fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
+    fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
+    predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
+    roleTyConKey, tExpTyConKey, injAnnTyConKey, kindQTyConKey,
+    overlapTyConKey, derivClauseQTyConKey, derivStrategyQTyConKey :: Unique
+expTyConKey             = mkPreludeTyConUnique 200
+matchTyConKey           = mkPreludeTyConUnique 201
+clauseTyConKey          = mkPreludeTyConUnique 202
+qTyConKey               = mkPreludeTyConUnique 203
+expQTyConKey            = mkPreludeTyConUnique 204
+decQTyConKey            = mkPreludeTyConUnique 205
+patTyConKey             = mkPreludeTyConUnique 206
+matchQTyConKey          = mkPreludeTyConUnique 207
+clauseQTyConKey         = mkPreludeTyConUnique 208
+stmtQTyConKey           = mkPreludeTyConUnique 209
+conQTyConKey            = mkPreludeTyConUnique 210
+typeQTyConKey           = mkPreludeTyConUnique 211
+typeTyConKey            = mkPreludeTyConUnique 212
+decTyConKey             = mkPreludeTyConUnique 213
+bangTypeQTyConKey       = mkPreludeTyConUnique 214
+varBangTypeQTyConKey    = mkPreludeTyConUnique 215
+fieldExpTyConKey        = mkPreludeTyConUnique 216
+fieldPatTyConKey        = mkPreludeTyConUnique 217
+nameTyConKey            = mkPreludeTyConUnique 218
+patQTyConKey            = mkPreludeTyConUnique 219
+fieldPatQTyConKey       = mkPreludeTyConUnique 220
+fieldExpQTyConKey       = mkPreludeTyConUnique 221
+funDepTyConKey          = mkPreludeTyConUnique 222
+predTyConKey            = mkPreludeTyConUnique 223
+predQTyConKey           = mkPreludeTyConUnique 224
+tyVarBndrQTyConKey      = mkPreludeTyConUnique 225
+decsQTyConKey           = mkPreludeTyConUnique 226
+ruleBndrQTyConKey       = mkPreludeTyConUnique 227
+tySynEqnQTyConKey       = mkPreludeTyConUnique 228
+roleTyConKey            = mkPreludeTyConUnique 229
+tExpTyConKey            = mkPreludeTyConUnique 230
+injAnnTyConKey          = mkPreludeTyConUnique 231
+kindQTyConKey           = mkPreludeTyConUnique 232
+overlapTyConKey         = mkPreludeTyConUnique 233
+derivClauseQTyConKey    = mkPreludeTyConUnique 234
+derivStrategyQTyConKey  = mkPreludeTyConUnique 235
+
+{- *********************************************************************
+*                                                                      *
+                     DataCon keys
+*                                                                      *
+********************************************************************* -}
+
+-- DataConUniques available: 100-150
+-- If you want to change this, make sure you check in PrelNames
+
+-- data Inline = ...
+noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
+noInlineDataConKey  = mkPreludeDataConUnique 200
+inlineDataConKey    = mkPreludeDataConUnique 201
+inlinableDataConKey = mkPreludeDataConUnique 202
+
+-- data RuleMatch = ...
+conLikeDataConKey, funLikeDataConKey :: Unique
+conLikeDataConKey = mkPreludeDataConUnique 203
+funLikeDataConKey = mkPreludeDataConUnique 204
+
+-- data Phases = ...
+allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique
+allPhasesDataConKey   = mkPreludeDataConUnique 205
+fromPhaseDataConKey   = mkPreludeDataConUnique 206
+beforePhaseDataConKey = mkPreludeDataConUnique 207
+
+-- newtype TExp a = ...
+tExpDataConKey :: Unique
+tExpDataConKey = mkPreludeDataConUnique 208
+
+-- data Overlap = ..
+overlappableDataConKey,
+  overlappingDataConKey,
+  overlapsDataConKey,
+  incoherentDataConKey :: Unique
+overlappableDataConKey = mkPreludeDataConUnique 209
+overlappingDataConKey  = mkPreludeDataConUnique 210
+overlapsDataConKey     = mkPreludeDataConUnique 211
+incoherentDataConKey   = mkPreludeDataConUnique 212
+
+{- *********************************************************************
+*                                                                      *
+                     Id keys
+*                                                                      *
+********************************************************************* -}
+
+-- IdUniques available: 200-499
+-- If you want to change this, make sure you check in PrelNames
+
+returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
+    mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
+    mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey,
+    unsafeTExpCoerceIdKey :: Unique
+returnQIdKey        = mkPreludeMiscIdUnique 200
+bindQIdKey          = mkPreludeMiscIdUnique 201
+sequenceQIdKey      = mkPreludeMiscIdUnique 202
+liftIdKey           = mkPreludeMiscIdUnique 203
+newNameIdKey         = mkPreludeMiscIdUnique 204
+mkNameIdKey          = mkPreludeMiscIdUnique 205
+mkNameG_vIdKey       = mkPreludeMiscIdUnique 206
+mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
+mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
+mkNameLIdKey         = mkPreludeMiscIdUnique 209
+mkNameSIdKey         = mkPreludeMiscIdUnique 210
+unTypeIdKey          = mkPreludeMiscIdUnique 211
+unTypeQIdKey         = mkPreludeMiscIdUnique 212
+unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213
+
+
+-- data Lit = ...
+charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,
+    floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey, stringPrimLIdKey,
+    charPrimLIdKey:: Unique
+charLIdKey        = mkPreludeMiscIdUnique 220
+stringLIdKey      = mkPreludeMiscIdUnique 221
+integerLIdKey     = mkPreludeMiscIdUnique 222
+intPrimLIdKey     = mkPreludeMiscIdUnique 223
+wordPrimLIdKey    = mkPreludeMiscIdUnique 224
+floatPrimLIdKey   = mkPreludeMiscIdUnique 225
+doublePrimLIdKey  = mkPreludeMiscIdUnique 226
+rationalLIdKey    = mkPreludeMiscIdUnique 227
+stringPrimLIdKey  = mkPreludeMiscIdUnique 228
+charPrimLIdKey    = mkPreludeMiscIdUnique 229
+
+liftStringIdKey :: Unique
+liftStringIdKey     = mkPreludeMiscIdUnique 230
+
+-- data Pat = ...
+litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey,
+  infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey,
+  listPIdKey, sigPIdKey, viewPIdKey :: Unique
+litPIdKey         = mkPreludeMiscIdUnique 240
+varPIdKey         = mkPreludeMiscIdUnique 241
+tupPIdKey         = mkPreludeMiscIdUnique 242
+unboxedTupPIdKey  = mkPreludeMiscIdUnique 243
+unboxedSumPIdKey  = mkPreludeMiscIdUnique 244
+conPIdKey         = mkPreludeMiscIdUnique 245
+infixPIdKey       = mkPreludeMiscIdUnique 246
+tildePIdKey       = mkPreludeMiscIdUnique 247
+bangPIdKey        = mkPreludeMiscIdUnique 248
+asPIdKey          = mkPreludeMiscIdUnique 249
+wildPIdKey        = mkPreludeMiscIdUnique 250
+recPIdKey         = mkPreludeMiscIdUnique 251
+listPIdKey        = mkPreludeMiscIdUnique 252
+sigPIdKey         = mkPreludeMiscIdUnique 253
+viewPIdKey        = mkPreludeMiscIdUnique 254
+
+-- type FieldPat = ...
+fieldPatIdKey :: Unique
+fieldPatIdKey       = mkPreludeMiscIdUnique 260
+
+-- data Match = ...
+matchIdKey :: Unique
+matchIdKey          = mkPreludeMiscIdUnique 261
+
+-- data Clause = ...
+clauseIdKey :: Unique
+clauseIdKey         = mkPreludeMiscIdUnique 262
+
+
+-- data Exp = ...
+varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,
+    infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey,
+    tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey,
+    letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
+    fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
+    listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,
+    unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey :: Unique
+varEIdKey              = mkPreludeMiscIdUnique 270
+conEIdKey              = mkPreludeMiscIdUnique 271
+litEIdKey              = mkPreludeMiscIdUnique 272
+appEIdKey              = mkPreludeMiscIdUnique 273
+appTypeEIdKey          = mkPreludeMiscIdUnique 274
+infixEIdKey            = mkPreludeMiscIdUnique 275
+infixAppIdKey          = mkPreludeMiscIdUnique 276
+sectionLIdKey          = mkPreludeMiscIdUnique 277
+sectionRIdKey          = mkPreludeMiscIdUnique 278
+lamEIdKey              = mkPreludeMiscIdUnique 279
+lamCaseEIdKey          = mkPreludeMiscIdUnique 280
+tupEIdKey              = mkPreludeMiscIdUnique 281
+unboxedTupEIdKey       = mkPreludeMiscIdUnique 282
+unboxedSumEIdKey       = mkPreludeMiscIdUnique 283
+condEIdKey             = mkPreludeMiscIdUnique 284
+multiIfEIdKey          = mkPreludeMiscIdUnique 285
+letEIdKey              = mkPreludeMiscIdUnique 286
+caseEIdKey             = mkPreludeMiscIdUnique 287
+doEIdKey               = mkPreludeMiscIdUnique 288
+compEIdKey             = mkPreludeMiscIdUnique 289
+fromEIdKey             = mkPreludeMiscIdUnique 290
+fromThenEIdKey         = mkPreludeMiscIdUnique 291
+fromToEIdKey           = mkPreludeMiscIdUnique 292
+fromThenToEIdKey       = mkPreludeMiscIdUnique 293
+listEIdKey             = mkPreludeMiscIdUnique 294
+sigEIdKey              = mkPreludeMiscIdUnique 295
+recConEIdKey           = mkPreludeMiscIdUnique 296
+recUpdEIdKey           = mkPreludeMiscIdUnique 297
+staticEIdKey           = mkPreludeMiscIdUnique 298
+unboundVarEIdKey       = mkPreludeMiscIdUnique 299
+labelEIdKey            = mkPreludeMiscIdUnique 300
+implicitParamVarEIdKey = mkPreludeMiscIdUnique 301
+mdoEIdKey              = mkPreludeMiscIdUnique 302
+
+-- type FieldExp = ...
+fieldExpIdKey :: Unique
+fieldExpIdKey       = mkPreludeMiscIdUnique 305
+
+-- data Body = ...
+guardedBIdKey, normalBIdKey :: Unique
+guardedBIdKey     = mkPreludeMiscIdUnique 306
+normalBIdKey      = mkPreludeMiscIdUnique 307
+
+-- data Guard = ...
+normalGEIdKey, patGEIdKey :: Unique
+normalGEIdKey     = mkPreludeMiscIdUnique 308
+patGEIdKey        = mkPreludeMiscIdUnique 309
+
+-- data Stmt = ...
+bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique
+bindSIdKey       = mkPreludeMiscIdUnique 310
+letSIdKey        = mkPreludeMiscIdUnique 311
+noBindSIdKey     = mkPreludeMiscIdUnique 312
+parSIdKey        = mkPreludeMiscIdUnique 313
+recSIdKey        = mkPreludeMiscIdUnique 314
+
+-- data Dec = ...
+funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
+    instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,
+    pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey,
+    pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,
+    openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
+    newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
+    infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
+    patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey :: Unique
+funDIdKey                         = mkPreludeMiscIdUnique 320
+valDIdKey                         = mkPreludeMiscIdUnique 321
+dataDIdKey                        = mkPreludeMiscIdUnique 322
+newtypeDIdKey                     = mkPreludeMiscIdUnique 323
+tySynDIdKey                       = mkPreludeMiscIdUnique 324
+classDIdKey                       = mkPreludeMiscIdUnique 325
+instanceWithOverlapDIdKey         = mkPreludeMiscIdUnique 326
+instanceDIdKey                    = mkPreludeMiscIdUnique 327
+sigDIdKey                         = mkPreludeMiscIdUnique 328
+forImpDIdKey                      = mkPreludeMiscIdUnique 329
+pragInlDIdKey                     = mkPreludeMiscIdUnique 330
+pragSpecDIdKey                    = mkPreludeMiscIdUnique 331
+pragSpecInlDIdKey                 = mkPreludeMiscIdUnique 332
+pragSpecInstDIdKey                = mkPreludeMiscIdUnique 333
+pragRuleDIdKey                    = mkPreludeMiscIdUnique 334
+pragAnnDIdKey                     = mkPreludeMiscIdUnique 335
+dataFamilyDIdKey                  = mkPreludeMiscIdUnique 336
+openTypeFamilyDIdKey              = mkPreludeMiscIdUnique 337
+dataInstDIdKey                    = mkPreludeMiscIdUnique 338
+newtypeInstDIdKey                 = mkPreludeMiscIdUnique 339
+tySynInstDIdKey                   = mkPreludeMiscIdUnique 340
+closedTypeFamilyDIdKey            = mkPreludeMiscIdUnique 341
+infixLDIdKey                      = mkPreludeMiscIdUnique 342
+infixRDIdKey                      = mkPreludeMiscIdUnique 343
+infixNDIdKey                      = mkPreludeMiscIdUnique 344
+roleAnnotDIdKey                   = mkPreludeMiscIdUnique 345
+standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346
+defaultSigDIdKey                  = mkPreludeMiscIdUnique 347
+patSynDIdKey                      = mkPreludeMiscIdUnique 348
+patSynSigDIdKey                   = mkPreludeMiscIdUnique 349
+pragCompleteDIdKey                = mkPreludeMiscIdUnique 350
+implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351
+
+-- type Cxt = ...
+cxtIdKey :: Unique
+cxtIdKey               = mkPreludeMiscIdUnique 361
+
+-- data SourceUnpackedness = ...
+noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique
+noSourceUnpackednessKey = mkPreludeMiscIdUnique 362
+sourceNoUnpackKey       = mkPreludeMiscIdUnique 363
+sourceUnpackKey         = mkPreludeMiscIdUnique 364
+
+-- data SourceStrictness = ...
+noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique
+noSourceStrictnessKey   = mkPreludeMiscIdUnique 365
+sourceLazyKey           = mkPreludeMiscIdUnique 366
+sourceStrictKey         = mkPreludeMiscIdUnique 367
+
+-- data Con = ...
+normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,
+  recGadtCIdKey :: Unique
+normalCIdKey      = mkPreludeMiscIdUnique 368
+recCIdKey         = mkPreludeMiscIdUnique 369
+infixCIdKey       = mkPreludeMiscIdUnique 370
+forallCIdKey      = mkPreludeMiscIdUnique 371
+gadtCIdKey        = mkPreludeMiscIdUnique 372
+recGadtCIdKey     = mkPreludeMiscIdUnique 373
+
+-- data Bang = ...
+bangIdKey :: Unique
+bangIdKey         = mkPreludeMiscIdUnique 374
+
+-- type BangType = ...
+bangTKey :: Unique
+bangTKey          = mkPreludeMiscIdUnique 375
+
+-- type VarBangType = ...
+varBangTKey :: Unique
+varBangTKey       = mkPreludeMiscIdUnique 376
+
+-- data PatSynDir = ...
+unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique
+unidirPatSynIdKey    = mkPreludeMiscIdUnique 377
+implBidirPatSynIdKey = mkPreludeMiscIdUnique 378
+explBidirPatSynIdKey = mkPreludeMiscIdUnique 379
+
+-- data PatSynArgs = ...
+prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique
+prefixPatSynIdKey = mkPreludeMiscIdUnique 380
+infixPatSynIdKey  = mkPreludeMiscIdUnique 381
+recordPatSynIdKey = mkPreludeMiscIdUnique 382
+
+-- data Type = ...
+forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey,
+    unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, appKindTIdKey,
+    sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey,
+    promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey,
+    wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique
+forallTIdKey        = mkPreludeMiscIdUnique 390
+varTIdKey           = mkPreludeMiscIdUnique 391
+conTIdKey           = mkPreludeMiscIdUnique 392
+tupleTIdKey         = mkPreludeMiscIdUnique 393
+unboxedTupleTIdKey  = mkPreludeMiscIdUnique 394
+unboxedSumTIdKey    = mkPreludeMiscIdUnique 395
+arrowTIdKey         = mkPreludeMiscIdUnique 396
+listTIdKey          = mkPreludeMiscIdUnique 397
+appTIdKey           = mkPreludeMiscIdUnique 398
+appKindTIdKey       = mkPreludeMiscIdUnique 399
+sigTIdKey           = mkPreludeMiscIdUnique 400
+equalityTIdKey      = mkPreludeMiscIdUnique 401
+litTIdKey           = mkPreludeMiscIdUnique 402
+promotedTIdKey      = mkPreludeMiscIdUnique 403
+promotedTupleTIdKey = mkPreludeMiscIdUnique 404
+promotedNilTIdKey   = mkPreludeMiscIdUnique 405
+promotedConsTIdKey  = mkPreludeMiscIdUnique 406
+wildCardTIdKey      = mkPreludeMiscIdUnique 407
+implicitParamTIdKey = mkPreludeMiscIdUnique 408
+infixTIdKey         = mkPreludeMiscIdUnique 409
+
+-- data TyLit = ...
+numTyLitIdKey, strTyLitIdKey :: Unique
+numTyLitIdKey = mkPreludeMiscIdUnique 410
+strTyLitIdKey = mkPreludeMiscIdUnique 411
+
+-- data TyVarBndr = ...
+plainTVIdKey, kindedTVIdKey :: Unique
+plainTVIdKey       = mkPreludeMiscIdUnique 412
+kindedTVIdKey      = mkPreludeMiscIdUnique 413
+
+-- data Role = ...
+nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique
+nominalRIdKey          = mkPreludeMiscIdUnique 414
+representationalRIdKey = mkPreludeMiscIdUnique 415
+phantomRIdKey          = mkPreludeMiscIdUnique 416
+inferRIdKey            = mkPreludeMiscIdUnique 417
+
+-- data Kind = ...
+varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,
+  starKIdKey, constraintKIdKey :: Unique
+varKIdKey         = mkPreludeMiscIdUnique 418
+conKIdKey         = mkPreludeMiscIdUnique 419
+tupleKIdKey       = mkPreludeMiscIdUnique 420
+arrowKIdKey       = mkPreludeMiscIdUnique 421
+listKIdKey        = mkPreludeMiscIdUnique 422
+appKIdKey         = mkPreludeMiscIdUnique 423
+starKIdKey        = mkPreludeMiscIdUnique 424
+constraintKIdKey  = mkPreludeMiscIdUnique 425
+
+-- data FamilyResultSig = ...
+noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique
+noSigIdKey        = mkPreludeMiscIdUnique 426
+kindSigIdKey      = mkPreludeMiscIdUnique 427
+tyVarSigIdKey     = mkPreludeMiscIdUnique 428
+
+-- data InjectivityAnn = ...
+injectivityAnnIdKey :: Unique
+injectivityAnnIdKey = mkPreludeMiscIdUnique 429
+
+-- data Callconv = ...
+cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey,
+  javaScriptCallIdKey :: Unique
+cCallIdKey          = mkPreludeMiscIdUnique 430
+stdCallIdKey        = mkPreludeMiscIdUnique 431
+cApiCallIdKey       = mkPreludeMiscIdUnique 432
+primCallIdKey       = mkPreludeMiscIdUnique 433
+javaScriptCallIdKey = mkPreludeMiscIdUnique 434
+
+-- data Safety = ...
+unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
+unsafeIdKey        = mkPreludeMiscIdUnique 440
+safeIdKey          = mkPreludeMiscIdUnique 441
+interruptibleIdKey = mkPreludeMiscIdUnique 442
+
+-- data FunDep = ...
+funDepIdKey :: Unique
+funDepIdKey = mkPreludeMiscIdUnique 445
+
+-- data TySynEqn = ...
+tySynEqnIdKey :: Unique
+tySynEqnIdKey = mkPreludeMiscIdUnique 460
+
+-- quasiquoting
+quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
+quoteExpKey  = mkPreludeMiscIdUnique 470
+quotePatKey  = mkPreludeMiscIdUnique 471
+quoteDecKey  = mkPreludeMiscIdUnique 472
+quoteTypeKey = mkPreludeMiscIdUnique 473
+
+-- data RuleBndr = ...
+ruleVarIdKey, typedRuleVarIdKey :: Unique
+ruleVarIdKey      = mkPreludeMiscIdUnique 480
+typedRuleVarIdKey = mkPreludeMiscIdUnique 481
+
+-- data AnnTarget = ...
+valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique
+valueAnnotationIdKey  = mkPreludeMiscIdUnique 490
+typeAnnotationIdKey   = mkPreludeMiscIdUnique 491
+moduleAnnotationIdKey = mkPreludeMiscIdUnique 492
+
+-- type DerivPred = ...
+derivClauseIdKey :: Unique
+derivClauseIdKey = mkPreludeMiscIdUnique 493
+
+-- data DerivStrategy = ...
+stockStrategyIdKey, anyclassStrategyIdKey, newtypeStrategyIdKey,
+  viaStrategyIdKey :: Unique
+stockStrategyIdKey    = mkPreludeDataConUnique 494
+anyclassStrategyIdKey = mkPreludeDataConUnique 495
+newtypeStrategyIdKey  = mkPreludeDataConUnique 496
+viaStrategyIdKey      = mkPreludeDataConUnique 497
+
+{-
+************************************************************************
+*                                                                      *
+                        RdrNames
+*                                                                      *
+************************************************************************
+-}
+
+lift_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName
+lift_RDR     = nameRdrName liftName
+mkNameG_dRDR = nameRdrName mkNameG_dName
+mkNameG_vRDR = nameRdrName mkNameG_vName
+
+-- data Exp = ...
+conE_RDR, litE_RDR, appE_RDR, infixApp_RDR :: RdrName
+conE_RDR     = nameRdrName conEName
+litE_RDR     = nameRdrName litEName
+appE_RDR     = nameRdrName appEName
+infixApp_RDR = nameRdrName infixAppName
+
+-- data Lit = ...
+stringL_RDR, intPrimL_RDR, wordPrimL_RDR, floatPrimL_RDR,
+    doublePrimL_RDR, stringPrimL_RDR, charPrimL_RDR :: RdrName
+stringL_RDR     = nameRdrName stringLName
+intPrimL_RDR    = nameRdrName intPrimLName
+wordPrimL_RDR   = nameRdrName wordPrimLName
+floatPrimL_RDR  = nameRdrName floatPrimLName
+doublePrimL_RDR = nameRdrName doublePrimLName
+stringPrimL_RDR = nameRdrName stringPrimLName
+charPrimL_RDR   = nameRdrName charPrimLName
diff --git a/compiler/profiling/ProfInit.hs b/compiler/profiling/ProfInit.hs
new file mode 100644
--- /dev/null
+++ b/compiler/profiling/ProfInit.hs
@@ -0,0 +1,64 @@
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2011
+--
+-- Generate code to initialise cost centres
+--
+-- -----------------------------------------------------------------------------
+
+module ProfInit (profilingInitCode) where
+
+import GhcPrelude
+
+import CLabel
+import CostCentre
+import DynFlags
+import Outputable
+import Module
+
+-- -----------------------------------------------------------------------------
+-- Initialising cost centres
+
+-- We must produce declarations for the cost-centres defined in this
+-- module;
+
+profilingInitCode :: Module -> CollectedCCs -> SDoc
+profilingInitCode this_mod (local_CCs, singleton_CCSs)
+ = sdocWithDynFlags $ \dflags ->
+   if not (gopt Opt_SccProfilingOn dflags)
+   then empty
+   else vcat
+    $  map emit_cc_decl local_CCs
+    ++ map emit_ccs_decl singleton_CCSs
+    ++ [emit_cc_list local_CCs]
+    ++ [emit_ccs_list singleton_CCSs]
+    ++ [ text "static void prof_init_" <> ppr this_mod
+            <> text "(void) __attribute__((constructor));"
+       , text "static void prof_init_" <> ppr this_mod <> text "(void)"
+       , braces (vcat
+                 [ text "registerCcList" <> parens local_cc_list_label <> semi
+                 , text "registerCcsList" <> parens singleton_cc_list_label <> semi
+                 ])
+       ]
+ where
+   emit_cc_decl cc =
+       text "extern CostCentre" <+> cc_lbl <> text "[];"
+     where cc_lbl = ppr (mkCCLabel cc)
+   local_cc_list_label = text "local_cc_" <> ppr this_mod
+   emit_cc_list ccs =
+      text "static CostCentre *" <> local_cc_list_label <> text "[] ="
+      <+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma
+                         | cc <- ccs
+                         ] ++ [text "NULL"])
+      <> semi
+
+   emit_ccs_decl ccs =
+       text "extern CostCentreStack" <+> ccs_lbl <> text "[];"
+     where ccs_lbl = ppr (mkCCSLabel ccs)
+   singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod
+   emit_ccs_list ccs =
+      text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] ="
+      <+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma
+                         | cc <- ccs
+                         ] ++ [text "NULL"])
+      <> semi
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnBinds.hs
@@ -0,0 +1,1327 @@
+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[RnBinds]{Renaming and dependency analysis of bindings}
+
+This module does renaming and dependency analysis on value bindings in
+the abstract syntax.  It does {\em not} do cycle-checks on class or
+type-synonym declarations; those cannot be done at this stage because
+they may be affected by renaming (which isn't fully worked out yet).
+-}
+
+module RnBinds (
+   -- Renaming top-level bindings
+   rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS,
+
+   -- Renaming local bindings
+   rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
+
+   -- Other bindings
+   rnMethodBinds, renameSigs,
+   rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl,
+   makeMiniFixityEnv, MiniFixityEnv,
+   HsSigCtxt(..)
+   ) where
+
+import GhcPrelude
+
+import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
+
+import HsSyn
+import TcRnMonad
+import RnTypes
+import RnPat
+import RnNames
+import RnEnv
+import RnFixity
+import RnUtils          ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn
+                        , checkDupRdrNames, warnUnusedLocalBinds
+                        , checkDupAndShadowedNames, bindLocalNamesFV )
+import DynFlags
+import Module
+import Name
+import NameEnv
+import NameSet
+import RdrName          ( RdrName, rdrNameOcc )
+import SrcLoc
+import ListSetOps       ( findDupsEq )
+import BasicTypes       ( RecFlag(..) )
+import Digraph          ( SCC(..) )
+import Bag
+import Util
+import Outputable
+import UniqSet
+import Maybes           ( orElse )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Data.Foldable      ( toList )
+import Data.List          ( partition, sort )
+import Data.List.NonEmpty ( NonEmpty(..) )
+
+{-
+-- ToDo: Put the annotations into the monad, so that they arrive in the proper
+-- place and can be used when complaining.
+
+The code tree received by the function @rnBinds@ contains definitions
+in where-clauses which are all apparently mutually recursive, but which may
+not really depend upon each other. For example, in the top level program
+\begin{verbatim}
+f x = y where a = x
+              y = x
+\end{verbatim}
+the definitions of @a@ and @y@ do not depend on each other at all.
+Unfortunately, the typechecker cannot always check such definitions.
+\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
+definitions. In Proceedings of the International Symposium on Programming,
+Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
+However, the typechecker usually can check definitions in which only the
+strongly connected components have been collected into recursive bindings.
+This is precisely what the function @rnBinds@ does.
+
+ToDo: deal with case where a single monobinds binds the same variable
+twice.
+
+The vertag tag is a unique @Int@; the tags only need to be unique
+within one @MonoBinds@, so that unique-Int plumbing is done explicitly
+(heavy monad machinery not needed).
+
+
+************************************************************************
+*                                                                      *
+* naming conventions                                                   *
+*                                                                      *
+************************************************************************
+
+\subsection[name-conventions]{Name conventions}
+
+The basic algorithm involves walking over the tree and returning a tuple
+containing the new tree plus its free variables. Some functions, such
+as those walking polymorphic bindings (HsBinds) and qualifier lists in
+list comprehensions (@Quals@), return the variables bound in local
+environments. These are then used to calculate the free variables of the
+expression evaluated in these environments.
+
+Conventions for variable names are as follows:
+\begin{itemize}
+\item
+new code is given a prime to distinguish it from the old.
+
+\item
+a set of variables defined in @Exp@ is written @dvExp@
+
+\item
+a set of variables free in @Exp@ is written @fvExp@
+\end{itemize}
+
+************************************************************************
+*                                                                      *
+* analysing polymorphic bindings (HsBindGroup, HsBind)
+*                                                                      *
+************************************************************************
+
+\subsubsection[dep-HsBinds]{Polymorphic bindings}
+
+Non-recursive expressions are reconstructed without any changes at top
+level, although their component expressions may have to be altered.
+However, non-recursive expressions are currently not expected as
+\Haskell{} programs, and this code should not be executed.
+
+Monomorphic bindings contain information that is returned in a tuple
+(a @FlatMonoBinds@) containing:
+
+\begin{enumerate}
+\item
+a unique @Int@ that serves as the ``vertex tag'' for this binding.
+
+\item
+the name of a function or the names in a pattern. These are a set
+referred to as @dvLhs@, the defined variables of the left hand side.
+
+\item
+the free variables of the body. These are referred to as @fvBody@.
+
+\item
+the definition's actual code. This is referred to as just @code@.
+\end{enumerate}
+
+The function @nonRecDvFv@ returns two sets of variables. The first is
+the set of variables defined in the set of monomorphic bindings, while the
+second is the set of free variables in those bindings.
+
+The set of variables defined in a non-recursive binding is just the
+union of all of them, as @union@ removes duplicates. However, the
+free variables in each successive set of cumulative bindings is the
+union of those in the previous set plus those of the newest binding after
+the defined variables of the previous set have been removed.
+
+@rnMethodBinds@ deals only with the declarations in class and
+instance declarations.  It expects only to see @FunMonoBind@s, and
+it expects the global environment to contain bindings for the binders
+(which are all class operations).
+
+************************************************************************
+*                                                                      *
+\subsubsection{ Top-level bindings}
+*                                                                      *
+************************************************************************
+-}
+
+-- for top-level bindings, we need to make top-level names,
+-- so we have a different entry point than for local bindings
+rnTopBindsLHS :: MiniFixityEnv
+              -> HsValBinds GhcPs
+              -> RnM (HsValBindsLR GhcRn GhcPs)
+rnTopBindsLHS fix_env binds
+  = rnValBindsLHS (topRecNameMaker fix_env) binds
+
+rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs
+               -> RnM (HsValBinds GhcRn, DefUses)
+-- A hs-boot file has no bindings.
+-- Return a single HsBindGroup with empty binds and renamed signatures
+rnTopBindsBoot bound_names (ValBinds _ mbinds sigs)
+  = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
+        ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs
+        ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) }
+rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)
+
+{-
+*********************************************************
+*                                                      *
+                HsLocalBinds
+*                                                      *
+*********************************************************
+-}
+
+rnLocalBindsAndThen :: HsLocalBinds GhcPs
+                   -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
+                   -> RnM (result, FreeVars)
+-- This version (a) assumes that the binding vars are *not* already in scope
+--               (b) removes the binders from the free vars of the thing inside
+-- The parser doesn't produce ThenBinds
+rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside =
+  thing_inside (EmptyLocalBinds x) emptyNameSet
+
+rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside
+  = rnLocalValBindsAndThen val_binds $ \ val_binds' ->
+      thing_inside (HsValBinds x val_binds')
+
+rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do
+    (binds',fv_binds) <- rnIPBinds binds
+    (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds
+    return (thing, fvs_thing `plusFV` fv_binds)
+
+rnLocalBindsAndThen (XHsLocalBindsLR _) _ = panic "rnLocalBindsAndThen"
+
+rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars)
+rnIPBinds (IPBinds _ ip_binds ) = do
+    (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
+    return (IPBinds noExt ip_binds', plusFVs fvs_s)
+rnIPBinds (XHsIPBinds _) = panic "rnIPBinds"
+
+rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)
+rnIPBind (IPBind _ ~(Left n) expr) = do
+    (expr',fvExpr) <- rnLExpr expr
+    return (IPBind noExt (Left n) expr', fvExpr)
+rnIPBind (XIPBind _) = panic "rnIPBind"
+
+{-
+************************************************************************
+*                                                                      *
+                ValBinds
+*                                                                      *
+************************************************************************
+-}
+
+-- Renaming local binding groups
+-- Does duplicate/shadow check
+rnLocalValBindsLHS :: MiniFixityEnv
+                   -> HsValBinds GhcPs
+                   -> RnM ([Name], HsValBindsLR GhcRn GhcPs)
+rnLocalValBindsLHS fix_env binds
+  = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds
+
+         -- Check for duplicates and shadowing
+         -- Must do this *after* renaming the patterns
+         -- See Note [Collect binders only after renaming] in HsUtils
+
+         -- We need to check for dups here because we
+         -- don't don't bind all of the variables from the ValBinds at once
+         -- with bindLocatedLocals any more.
+         --
+         -- Note that we don't want to do this at the top level, since
+         -- sorting out duplicates and shadowing there happens elsewhere.
+         -- The behavior is even different. For example,
+         --   import A(f)
+         --   f = ...
+         -- should not produce a shadowing warning (but it will produce
+         -- an ambiguity warning if you use f), but
+         --   import A(f)
+         --   g = let f = ... in f
+         -- should.
+       ; let bound_names = collectHsValBinders binds'
+             -- There should be only Ids, but if there are any bogus
+             -- pattern synonyms, we'll collect them anyway, so that
+             -- we don't generate subsequent out-of-scope messages
+       ; envs <- getRdrEnvs
+       ; checkDupAndShadowedNames envs bound_names
+
+       ; return (bound_names, binds') }
+
+-- renames the left-hand sides
+-- generic version used both at the top level and for local binds
+-- does some error checking, but not what gets done elsewhere at the top level
+rnValBindsLHS :: NameMaker
+              -> HsValBinds GhcPs
+              -> RnM (HsValBindsLR GhcRn GhcPs)
+rnValBindsLHS topP (ValBinds x mbinds sigs)
+  = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds
+       ; return $ ValBinds x mbinds' sigs }
+  where
+    bndrs = collectHsBindsBinders mbinds
+    doc   = text "In the binding group for:" <+> pprWithCommas ppr bndrs
+
+rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
+
+-- General version used both from the top-level and for local things
+-- Assumes the LHS vars are in scope
+--
+-- Does not bind the local fixity declarations
+rnValBindsRHS :: HsSigCtxt
+              -> HsValBindsLR GhcRn GhcPs
+              -> RnM (HsValBinds GhcRn, DefUses)
+
+rnValBindsRHS ctxt (ValBinds _ mbinds sigs)
+  = do { (sigs', sig_fvs) <- renameSigs ctxt sigs
+       ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds
+       ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus
+
+       ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $
+                          getPatSynBinds anal_binds
+                -- The uses in binds_w_dus for PatSynBinds do not include
+                -- variables used in the patsyn builders; see
+                -- Note [Pattern synonym builders don't yield dependencies]
+                -- But psb_fvs /does/ include those builder fvs.  So we
+                -- add them back in here to avoid bogus warnings about
+                -- unused variables (Trac #12548)
+
+             valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs
+                                     `plusDU` usesOnly patsyn_fvs
+                            -- Put the sig uses *after* the bindings
+                            -- so that the binders are removed from
+                            -- the uses in the sigs
+
+        ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) }
+
+rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)
+
+-- Wrapper for local binds
+--
+-- The *client* of this function is responsible for checking for unused binders;
+-- it doesn't (and can't: we don't have the thing inside the binds) happen here
+--
+-- The client is also responsible for bringing the fixities into scope
+rnLocalValBindsRHS :: NameSet  -- names bound by the LHSes
+                   -> HsValBindsLR GhcRn GhcPs
+                   -> RnM (HsValBinds GhcRn, DefUses)
+rnLocalValBindsRHS bound_names binds
+  = rnValBindsRHS (LocalBindCtxt bound_names) binds
+
+-- for local binds
+-- wrapper that does both the left- and right-hand sides
+--
+-- here there are no local fixity decls passed in;
+-- the local fixity decls come from the ValBinds sigs
+rnLocalValBindsAndThen
+  :: HsValBinds GhcPs
+  -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars))
+  -> RnM (result, FreeVars)
+rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside
+ = do   {     -- (A) Create the local fixity environment
+          new_fixities <- makeMiniFixityEnv [ L loc sig
+                                            | L loc (FixSig _ sig) <- sigs]
+
+              -- (B) Rename the LHSes
+        ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds
+
+              --     ...and bring them (and their fixities) into scope
+        ; bindLocalNamesFV bound_names              $
+          addLocalFixities new_fixities bound_names $ do
+
+        {      -- (C) Do the RHS and thing inside
+          (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs
+        ; (result, result_fvs) <- thing_inside binds' (allUses dus)
+
+                -- Report unused bindings based on the (accurate)
+                -- findUses.  E.g.
+                --      let x = x in 3
+                -- should report 'x' unused
+        ; let real_uses = findUses dus result_fvs
+              -- Insert fake uses for variables introduced implicitly by
+              -- wildcards (#4404)
+              implicit_uses = hsValBindsImplicits binds'
+        ; warnUnusedLocalBinds bound_names
+                                      (real_uses `unionNameSet` implicit_uses)
+
+        ; let
+            -- The variables "used" in the val binds are:
+            --   (1) the uses of the binds (allUses)
+            --   (2) the FVs of the thing-inside
+            all_uses = allUses dus `plusFV` result_fvs
+                -- Note [Unused binding hack]
+                -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
+                -- Note that *in contrast* to the above reporting of
+                -- unused bindings, (1) above uses duUses to return *all*
+                -- the uses, even if the binding is unused.  Otherwise consider:
+                --      x = 3
+                --      y = let p = x in 'x'    -- NB: p not used
+                -- If we don't "see" the dependency of 'y' on 'x', we may put the
+                -- bindings in the wrong order, and the type checker will complain
+                -- that x isn't in scope
+                --
+                -- But note that this means we won't report 'x' as unused,
+                -- whereas we would if we had { x = 3; p = x; y = 'x' }
+
+        ; return (result, all_uses) }}
+                -- The bound names are pruned out of all_uses
+                -- by the bindLocalNamesFV call above
+
+rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)
+
+
+---------------------
+
+-- renaming a single bind
+
+rnBindLHS :: NameMaker
+          -> SDoc
+          -> HsBind GhcPs
+          -- returns the renamed left-hand side,
+          -- and the FreeVars *of the LHS*
+          -- (i.e., any free variables of the pattern)
+          -> RnM (HsBindLR GhcRn GhcPs)
+
+rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })
+  = do
+      -- we don't actually use the FV processing of rnPatsAndThen here
+      (pat',pat'_fvs) <- rnBindPat name_maker pat
+      return (bind { pat_lhs = pat', pat_ext = pat'_fvs })
+                -- We temporarily store the pat's FVs in bind_fvs;
+                -- gets updated to the FVs of the whole bind
+                -- when doing the RHS below
+
+rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
+  = do { name <- applyNameMaker name_maker rdr_name
+       ; return (bind { fun_id = name
+                      , fun_ext = noExt }) }
+
+rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })
+  | isTopRecNameMaker name_maker
+  = do { addLocM checkConName rdrname
+       ; name <- lookupLocatedTopBndrRn rdrname   -- Should be in scope already
+       ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }
+
+  | otherwise  -- Pattern synonym, not at top level
+  = do { addErr localPatternSynonymErr  -- Complain, but make up a fake
+                                        -- name so that we can carry on
+       ; name <- applyNameMaker name_maker rdrname
+       ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }
+  where
+    localPatternSynonymErr :: SDoc
+    localPatternSynonymErr
+      = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))
+           2 (text "Pattern synonym declarations are only valid at top level")
+
+rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
+
+rnLBind :: (Name -> [Name])      -- Signature tyvar function
+        -> LHsBindLR GhcRn GhcPs
+        -> RnM (LHsBind GhcRn, [Name], Uses)
+rnLBind sig_fn (L loc bind)
+  = setSrcSpan loc $
+    do { (bind', bndrs, dus) <- rnBind sig_fn bind
+       ; return (L loc bind', bndrs, dus) }
+
+-- assumes the left-hands-side vars are in scope
+rnBind :: (Name -> [Name])        -- Signature tyvar function
+       -> HsBindLR GhcRn GhcPs
+       -> RnM (HsBind GhcRn, [Name], Uses)
+rnBind _ bind@(PatBind { pat_lhs = pat
+                       , pat_rhs = grhss
+                                   -- pat fvs were stored in bind_fvs
+                                   -- after processing the LHS
+                       , pat_ext = pat_fvs })
+  = do  { mod <- getModule
+        ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss
+
+                -- No scoped type variables for pattern bindings
+        ; let all_fvs = pat_fvs `plusFV` rhs_fvs
+              fvs'    = filterNameSet (nameIsLocalOrFrom mod) all_fvs
+                -- Keep locally-defined Names
+                -- As well as dependency analysis, we need these for the
+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
+              bndrs = collectPatBinders pat
+              bind' = bind { pat_rhs  = grhss'
+                           , pat_ext = fvs' }
+
+              ok_nobind_pat
+                  = -- See Note [Pattern bindings that bind no variables]
+                    case unLoc pat of
+                       WildPat {}   -> True
+                       BangPat {}   -> True -- #9127, #13646
+                       SplicePat {} -> True
+                       _            -> False
+
+        -- Warn if the pattern binds no variables
+        -- See Note [Pattern bindings that bind no variables]
+        ; whenWOptM Opt_WarnUnusedPatternBinds $
+          when (null bndrs && not ok_nobind_pat) $
+          addWarn (Reason Opt_WarnUnusedPatternBinds) $
+          unusedPatBindWarn bind'
+
+        ; fvs' `seq` -- See Note [Free-variable space leak]
+          return (bind', bndrs, all_fvs) }
+
+rnBind sig_fn bind@(FunBind { fun_id = name
+                            , fun_matches = matches })
+       -- invariant: no free vars here when it's a FunBind
+  = do  { let plain_name = unLoc name
+
+        ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
+                                -- bindSigTyVars tests for LangExt.ScopedTyVars
+                                 rnMatchGroup (mkPrefixFunRhs name)
+                                              rnLExpr matches
+        ; let is_infix = isInfixFunBind bind
+        ; when is_infix $ checkPrecMatch plain_name matches'
+
+        ; mod <- getModule
+        ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs
+                -- Keep locally-defined Names
+                -- As well as dependency analysis, we need these for the
+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
+
+        ; fvs' `seq` -- See Note [Free-variable space leak]
+          return (bind { fun_matches = matches'
+                       , fun_ext     = fvs' },
+                  [plain_name], rhs_fvs)
+      }
+
+rnBind sig_fn (PatSynBind x bind)
+  = do  { (bind', name, fvs) <- rnPatSynBind sig_fn bind
+        ; return (PatSynBind x bind', name, fvs) }
+
+rnBind _ b = pprPanic "rnBind" (ppr b)
+
+{- Note [Pattern bindings that bind no variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally, we want to warn about pattern bindings like
+  Just _ = e
+because they don't do anything!  But we have three exceptions:
+
+* A wildcard pattern
+       _ = rhs
+  which (a) is not that different from  _v = rhs
+        (b) is sometimes used to give a type sig for,
+            or an occurrence of, a variable on the RHS
+
+* A strict pattern binding; that is, one with an outermost bang
+     !Just _ = e
+  This can fail, so unlike the lazy variant, it is not a no-op.
+  Moreover, Trac #13646 argues that even for single constructor
+  types, you might want to write the constructor.  See also #9127.
+
+* A splice pattern
+      $(th-lhs) = rhs
+   It is impossible to determine whether or not th-lhs really
+   binds any variable. We should disable the warning for any pattern
+   which contain splices, but that is a more expensive check.
+
+Note [Free-variable space leak]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have
+    fvs' = trim fvs
+and we seq fvs' before turning it as part of a record.
+
+The reason is that trim is sometimes something like
+    \xs -> intersectNameSet (mkNameSet bound_names) xs
+and we don't want to retain the list bound_names. This showed up in
+trac ticket #1136.
+-}
+
+{- *********************************************************************
+*                                                                      *
+          Dependency analysis and other support functions
+*                                                                      *
+********************************************************************* -}
+
+depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses)
+             -> ([(RecFlag, LHsBinds GhcRn)], DefUses)
+-- Dependency analysis; this is important so that
+-- unused-binding reporting is accurate
+depAnalBinds binds_w_dus
+  = (map get_binds sccs, map get_du sccs)
+  where
+    sccs = depAnal (\(_, defs, _) -> defs)
+                   (\(_, _, uses) -> nonDetEltsUniqSet uses)
+                   -- It's OK to use nonDetEltsUniqSet here as explained in
+                   -- Note [depAnal determinism] in NameEnv.
+                   (bagToList binds_w_dus)
+
+    get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)
+    get_binds (CyclicSCC  binds_w_dus)  = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus])
+
+    get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)
+    get_du (CyclicSCC  binds_w_dus)      = (Just defs, uses)
+        where
+          defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]
+          uses = unionNameSets [u | (_,_,u) <- binds_w_dus]
+
+---------------------
+-- Bind the top-level forall'd type variables in the sigs.
+-- E.g  f :: forall a. a -> a
+--      f = rhs
+--      The 'a' scopes over the rhs
+--
+-- NB: there'll usually be just one (for a function binding)
+--     but if there are many, one may shadow the rest; too bad!
+--      e.g  x :: forall a. [a] -> [a]
+--           y :: forall a. [(a,a)] -> a
+--           (x,y) = e
+--      In e, 'a' will be in scope, and it'll be the one from 'y'!
+
+mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name])
+-- Return a lookup function that maps an Id Name to the names
+-- of the type variables that should scope over its body.
+mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` []
+  where
+    env = mkHsSigEnv get_scoped_tvs sigs
+
+    get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name])
+    -- Returns (binders, scoped tvs for those binders)
+    get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty))
+      = Just (names, hsScopedTvs sig_ty)
+    get_scoped_tvs (L _ (TypeSig _ names sig_ty))
+      = Just (names, hsWcScopedTvs sig_ty)
+    get_scoped_tvs (L _ (PatSynSig _ names sig_ty))
+      = Just (names, hsScopedTvs sig_ty)
+    get_scoped_tvs _ = Nothing
+
+-- Process the fixity declarations, making a FastString -> (Located Fixity) map
+-- (We keep the location around for reporting duplicate fixity declarations.)
+--
+-- Checks for duplicates, but not that only locally defined things are fixed.
+-- Note: for local fixity declarations, duplicates would also be checked in
+--       check_sigs below.  But we also use this function at the top level.
+
+makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv
+
+makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
+ where
+   add_one_sig env (L loc (FixitySig _ names fixity)) =
+     foldlM add_one env [ (loc,name_loc,name,fixity)
+                        | L name_loc name <- names ]
+   add_one_sig _ (L _ (XFixitySig _)) = panic "makeMiniFixityEnv"
+
+   add_one env (loc, name_loc, name,fixity) = do
+     { -- this fixity decl is a duplicate iff
+       -- the ReaderName's OccName's FastString is already in the env
+       -- (we only need to check the local fix_env because
+       --  definitions of non-local will be caught elsewhere)
+       let { fs = occNameFS (rdrNameOcc name)
+           ; fix_item = L loc fixity };
+
+       case lookupFsEnv env fs of
+         Nothing -> return $ extendFsEnv env fs fix_item
+         Just (L loc' _) -> do
+           { setSrcSpan loc $
+             addErrAt name_loc (dupFixityDecl loc' name)
+           ; return env}
+     }
+
+dupFixityDecl :: SrcSpan -> RdrName -> SDoc
+dupFixityDecl loc rdr_name
+  = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),
+          text "also at " <+> ppr loc]
+
+
+{- *********************************************************************
+*                                                                      *
+                Pattern synonym bindings
+*                                                                      *
+********************************************************************* -}
+
+rnPatSynBind :: (Name -> [Name])           -- Signature tyvar function
+             -> PatSynBind GhcRn GhcPs
+             -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses)
+rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
+                              , psb_args = details
+                              , psb_def = pat
+                              , psb_dir = dir })
+       -- invariant: no free vars here when it's a FunBind
+  = do  { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms
+        ; unless pattern_synonym_ok (addErr patternSynonymErr)
+        ; let scoped_tvs = sig_fn name
+
+        ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $
+                                      rnPat PatSyn pat $ \pat' ->
+         -- We check the 'RdrName's instead of the 'Name's
+         -- so that the binding locations are reported
+         -- from the left-hand side
+            case details of
+               PrefixCon vars ->
+                   do { checkDupRdrNames vars
+                      ; names <- mapM lookupPatSynBndr vars
+                      ; return ( (pat', PrefixCon names)
+                               , mkFVs (map unLoc names)) }
+               InfixCon var1 var2 ->
+                   do { checkDupRdrNames [var1, var2]
+                      ; name1 <- lookupPatSynBndr var1
+                      ; name2 <- lookupPatSynBndr var2
+                      -- ; checkPrecMatch -- TODO
+                      ; return ( (pat', InfixCon name1 name2)
+                               , mkFVs (map unLoc [name1, name2])) }
+               RecCon vars ->
+                   do { checkDupRdrNames (map recordPatSynSelectorId vars)
+                      ; let rnRecordPatSynField
+                              (RecordPatSynField { recordPatSynSelectorId = visible
+                                                 , recordPatSynPatVar = hidden })
+                              = do { visible' <- lookupLocatedTopBndrRn visible
+                                   ; hidden'  <- lookupPatSynBndr hidden
+                                   ; return $ RecordPatSynField { recordPatSynSelectorId = visible'
+                                                                , recordPatSynPatVar = hidden' } }
+                      ; names <- mapM rnRecordPatSynField  vars
+                      ; return ( (pat', RecCon names)
+                               , mkFVs (map (unLoc . recordPatSynPatVar) names)) }
+
+        ; (dir', fvs2) <- case dir of
+            Unidirectional -> return (Unidirectional, emptyFVs)
+            ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)
+            ExplicitBidirectional mg ->
+                do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $
+                                   rnMatchGroup (mkPrefixFunRhs (L l name))
+                                                rnLExpr mg
+                   ; return (ExplicitBidirectional mg', fvs) }
+
+        ; mod <- getModule
+        ; let fvs = fvs1 `plusFV` fvs2
+              fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs
+                -- Keep locally-defined Names
+                -- As well as dependency analysis, we need these for the
+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
+
+              bind' = bind{ psb_args = details'
+                          , psb_def = pat'
+                          , psb_dir = dir'
+                          , psb_ext = fvs' }
+              selector_names = case details' of
+                                 RecCon names ->
+                                  map (unLoc . recordPatSynSelectorId) names
+                                 _ -> []
+
+        ; fvs' `seq` -- See Note [Free-variable space leak]
+          return (bind', name : selector_names , fvs1)
+          -- Why fvs1?  See Note [Pattern synonym builders don't yield dependencies]
+      }
+  where
+    -- See Note [Renaming pattern synonym variables]
+    lookupPatSynBndr = wrapLocM lookupLocalOccRn
+
+    patternSynonymErr :: SDoc
+    patternSynonymErr
+      = hang (text "Illegal pattern synonym declaration")
+           2 (text "Use -XPatternSynonyms to enable this extension")
+
+rnPatSynBind _ (XPatSynBind _) = panic "rnPatSynBind"
+
+{-
+Note [Renaming pattern synonym variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We rename pattern synonym declaractions backwards to normal to reuse
+the logic already implemented for renaming patterns.
+
+We first rename the RHS of a declaration which brings into
+scope the variables bound by the pattern (as they would be
+in normal function definitions). We then lookup the variables
+which we want to bind in this local environment.
+
+It is crucial that we then only lookup in the *local* environment which
+only contains the variables brought into scope by the pattern and nothing
+else. Amazingly no-one encountered this bug for 3 GHC versions but
+it was possible to define a pattern synonym which referenced global
+identifiers and worked correctly.
+
+```
+x = 5
+
+pattern P :: Int -> ()
+pattern P x <- _
+
+f (P x) = x
+
+> f () = 5
+```
+
+See #13470 for the original report.
+
+Note [Pattern synonym builders don't yield dependencies]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When renaming a pattern synonym that has an explicit builder,
+references in the builder definition should not be used when
+calculating dependencies. For example, consider the following pattern
+synonym definition:
+
+pattern P x <- C1 x where
+  P x = f (C1 x)
+
+f (P x) = C2 x
+
+In this case, 'P' needs to be typechecked in two passes:
+
+1. Typecheck the pattern definition of 'P', which fully determines the
+   type of 'P'. This step doesn't require knowing anything about 'f',
+   since the builder definition is not looked at.
+
+2. Typecheck the builder definition, which needs the typechecked
+   definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind
+   in TcBinds.tcValBinds.
+
+This behaviour is implemented in 'tcValBinds', but it crucially
+depends on 'P' not being put in a recursive group with 'f' (which
+would make it look like a recursive pattern synonym a la 'pattern P =
+P' which is unsound and rejected).
+
+So:
+ * We do not include builder fvs in the Uses returned by rnPatSynBind
+   (which is then used for dependency analysis)
+ * But we /do/ include them in the psb_fvs for the PatSynBind
+ * In rnValBinds we record these builder uses, to avoid bogus
+   unused-variable warnings (Trac #12548)
+-}
+
+{- *********************************************************************
+*                                                                      *
+                Class/instance method bindings
+*                                                                      *
+********************************************************************* -}
+
+{- @rnMethodBinds@ is used for the method bindings of a class and an instance
+declaration.   Like @rnBinds@ but without dependency analysis.
+
+NOTA BENE: we record each {\em binder} of a method-bind group as a free variable.
+That's crucial when dealing with an instance decl:
+\begin{verbatim}
+        instance Foo (T a) where
+           op x = ...
+\end{verbatim}
+This might be the {\em sole} occurrence of @op@ for an imported class @Foo@,
+and unless @op@ occurs we won't treat the type signature of @op@ in the class
+decl for @Foo@ as a source of instance-decl gates.  But we should!  Indeed,
+in many ways the @op@ in an instance decl is just like an occurrence, not
+a binder.
+-}
+
+rnMethodBinds :: Bool                   -- True <=> is a class declaration
+              -> Name                   -- Class name
+              -> [Name]                 -- Type variables from the class/instance header
+              -> LHsBinds GhcPs         -- Binds
+              -> [LSig GhcPs]           -- and signatures/pragmas
+              -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars)
+-- Used for
+--   * the default method bindings in a class decl
+--   * the method bindings in an instance decl
+rnMethodBinds is_cls_decl cls ktv_names binds sigs
+  = do { checkDupRdrNames (collectMethodBinders binds)
+             -- Check that the same method is not given twice in the
+             -- same instance decl      instance C T where
+             --                       f x = ...
+             --                       g y = ...
+             --                       f x = ...
+             -- We must use checkDupRdrNames because the Name of the
+             -- method is the Name of the class selector, whose SrcSpan
+             -- points to the class declaration; and we use rnMethodBinds
+             -- for instance decls too
+
+       -- Rename the bindings LHSs
+       ; binds' <- foldrBagM (rnMethodBindLHS is_cls_decl cls) emptyBag binds
+
+       -- Rename the pragmas and signatures
+       -- Annoyingly the type variables /are/ in scope for signatures, but
+       -- /are not/ in scope in the SPECIALISE instance pramas; e.g.
+       --    instance Eq a => Eq (T a) where
+       --       (==) :: a -> a -> a
+       --       {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
+       ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs
+             bound_nms = mkNameSet (collectHsBindsBinders binds')
+             sig_ctxt | is_cls_decl = ClsDeclCtxt cls
+                      | otherwise   = InstDeclCtxt bound_nms
+       ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags
+       ; (other_sigs',      sig_fvs) <- extendTyVarEnvFVRn ktv_names $
+                                        renameSigs sig_ctxt other_sigs
+
+       -- Rename the bindings RHSs.  Again there's an issue about whether the
+       -- type variables from the class/instance head are in scope.
+       -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables
+       ; scoped_tvs  <- xoptM LangExt.ScopedTypeVariables
+       ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $
+              do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds'
+                 ; let bind_fvs = foldrBag (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)
+                                           emptyFVs binds_w_dus
+                 ; return (mapBag fstOf3 binds_w_dus, bind_fvs) }
+
+       ; return ( binds'', spec_inst_prags' ++ other_sigs'
+                , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) }
+  where
+    -- For the method bindings in class and instance decls, we extend
+    -- the type variable environment iff -XScopedTypeVariables
+    maybe_extend_tyvar_env scoped_tvs thing_inside
+       | scoped_tvs = extendTyVarEnvFVRn ktv_names thing_inside
+       | otherwise  = thing_inside
+
+rnMethodBindLHS :: Bool -> Name
+                -> LHsBindLR GhcPs GhcPs
+                -> LHsBindsLR GhcRn GhcPs
+                -> RnM (LHsBindsLR GhcRn GhcPs)
+rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest
+  = setSrcSpan loc $ do
+    do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name
+                     -- We use the selector name as the binder
+       ; let bind' = bind { fun_id = sel_name, fun_ext = noExt }
+       ; return (L loc bind' `consBag` rest ) }
+
+-- Report error for all other forms of bindings
+-- This is why we use a fold rather than map
+rnMethodBindLHS is_cls_decl _ (L loc bind) rest
+  = do { addErrAt loc $
+         vcat [ what <+> text "not allowed in" <+> decl_sort
+              , nest 2 (ppr bind) ]
+       ; return rest }
+  where
+    decl_sort | is_cls_decl = text "class declaration:"
+              | otherwise   = text "instance declaration:"
+    what = case bind of
+              PatBind {}    -> text "Pattern bindings (except simple variables)"
+              PatSynBind {} -> text "Pattern synonyms"
+                               -- Associated pattern synonyms are not implemented yet
+              _ -> pprPanic "rnMethodBind" (ppr bind)
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
+*                                                                      *
+************************************************************************
+
+@renameSigs@ checks for:
+\begin{enumerate}
+\item more than one sig for one thing;
+\item signatures given for things not bound here;
+\end{enumerate}
+
+At the moment we don't gather free-var info from the types in
+signatures.  We'd only need this if we wanted to report unused tyvars.
+-}
+
+renameSigs :: HsSigCtxt
+           -> [LSig GhcPs]
+           -> RnM ([LSig GhcRn], FreeVars)
+-- Renames the signatures and performs error checks
+renameSigs ctxt sigs
+  = do  { mapM_ dupSigDeclErr (findDupSigs sigs)
+
+        ; checkDupMinimalSigs sigs
+
+        ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs
+
+        ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
+        ; mapM_ misplacedSigErr bad_sigs                 -- Misplaced
+
+        ; return (good_sigs, sig_fvs) }
+
+----------------------
+-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
+-- because this won't work for:
+--      instance Foo T where
+--        {-# INLINE op #-}
+--        Baz.op = ...
+-- We'll just rename the INLINE prag to refer to whatever other 'op'
+-- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)
+-- Doesn't seem worth much trouble to sort this.
+
+renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)
+renameSig _ (IdSig _ x)
+  = return (IdSig noExt x, emptyFVs)    -- Actually this never occurs
+
+renameSig ctxt sig@(TypeSig _ vs ty)
+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
+        ; let doc = TypeSigCtx (ppr_sig_bndrs vs)
+        ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty
+        ; return (TypeSig noExt new_vs new_ty, fvs) }
+
+renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
+  = do  { defaultSigs_on <- xoptM LangExt.DefaultSignatures
+        ; when (is_deflt && not defaultSigs_on) $
+          addErr (defaultSigErr sig)
+        ; new_v <- mapM (lookupSigOccRn ctxt sig) vs
+        ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty
+        ; return (ClassOpSig noExt is_deflt new_v new_ty, fvs) }
+  where
+    (v1:_) = vs
+    ty_ctxt = GenericCtx (text "a class method signature for"
+                          <+> quotes (ppr v1))
+
+renameSig _ (SpecInstSig _ src ty)
+  = do  { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty
+        ; return (SpecInstSig noExt src new_ty,fvs) }
+
+-- {-# SPECIALISE #-} pragmas can refer to imported Ids
+-- so, in the top-level case (when mb_names is Nothing)
+-- we use lookupOccRn.  If there's both an imported and a local 'f'
+-- then the SPECIALISE pragma is ambiguous, unlike all other signatures
+renameSig ctxt sig@(SpecSig _ v tys inl)
+  = do  { new_v <- case ctxt of
+                     TopSigCtxt {} -> lookupLocatedOccRn v
+                     _             -> lookupSigOccRn ctxt sig v
+        ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys
+        ; return (SpecSig noExt new_v new_ty inl, fvs) }
+  where
+    ty_ctxt = GenericCtx (text "a SPECIALISE signature for"
+                          <+> quotes (ppr v))
+    do_one (tys,fvs) ty
+      = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty
+           ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
+
+renameSig ctxt sig@(InlineSig _ v s)
+  = do  { new_v <- lookupSigOccRn ctxt sig v
+        ; return (InlineSig noExt new_v s, emptyFVs) }
+
+renameSig ctxt (FixSig _ fsig)
+  = do  { new_fsig <- rnSrcFixityDecl ctxt fsig
+        ; return (FixSig noExt new_fsig, emptyFVs) }
+
+renameSig ctxt sig@(MinimalSig _ s (L l bf))
+  = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
+       return (MinimalSig noExt s (L l new_bf), emptyFVs)
+
+renameSig ctxt sig@(PatSynSig _ vs ty)
+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
+        ; (ty', fvs) <- rnHsSigType ty_ctxt ty
+        ; return (PatSynSig noExt new_vs ty', fvs) }
+  where
+    ty_ctxt = GenericCtx (text "a pattern synonym signature for"
+                          <+> ppr_sig_bndrs vs)
+
+renameSig ctxt sig@(SCCFunSig _ st v s)
+  = do  { new_v <- lookupSigOccRn ctxt sig v
+        ; return (SCCFunSig noExt st new_v s, emptyFVs) }
+
+-- COMPLETE Sigs can refer to imported IDs which is why we use
+-- lookupLocatedOccRn rather than lookupSigOccRn
+renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)
+  = do new_bf <- traverse lookupLocatedOccRn bf
+       new_mty  <- traverse lookupLocatedOccRn mty
+
+       this_mod <- fmap tcg_mod getGblEnv
+       unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do
+         -- Why 'any'? See Note [Orphan COMPLETE pragmas]
+         addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError
+
+       return (CompleteMatchSig noExt s (L l new_bf) new_mty, emptyFVs)
+  where
+    orphanError :: SDoc
+    orphanError =
+      text "Orphan COMPLETE pragmas not supported" $$
+      text "A COMPLETE pragma must mention at least one data constructor" $$
+      text "or pattern synonym defined in the same module."
+
+renameSig _ (XSig _) = panic "renameSig"
+
+{-
+Note [Orphan COMPLETE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We define a COMPLETE pragma to be a non-orphan if it includes at least
+one conlike defined in the current module. Why is this sufficient?
+Well if you have a pattern match
+
+  case expr of
+    P1 -> ...
+    P2 -> ...
+    P3 -> ...
+
+any COMPLETE pragma which mentions a conlike other than P1, P2 or P3
+will not be of any use in verifying that the pattern match is
+exhaustive. So as we have certainly read the interface files that
+define P1, P2 and P3, we will have loaded all non-orphan COMPLETE
+pragmas that could be relevant to this pattern match.
+
+For now we simply disallow orphan COMPLETE pragmas, as the added
+complexity of supporting them properly doesn't seem worthwhile.
+-}
+
+ppr_sig_bndrs :: [Located RdrName] -> SDoc
+ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
+
+okHsSig :: HsSigCtxt -> LSig a -> Bool
+okHsSig ctxt (L _ sig)
+  = case (sig, ctxt) of
+     (ClassOpSig {}, ClsDeclCtxt {})  -> True
+     (ClassOpSig {}, InstDeclCtxt {}) -> True
+     (ClassOpSig {}, _)               -> False
+
+     (TypeSig {}, ClsDeclCtxt {})  -> False
+     (TypeSig {}, InstDeclCtxt {}) -> False
+     (TypeSig {}, _)               -> True
+
+     (PatSynSig {}, TopSigCtxt{}) -> True
+     (PatSynSig {}, _)            -> False
+
+     (FixSig {}, InstDeclCtxt {}) -> False
+     (FixSig {}, _)               -> True
+
+     (IdSig {}, TopSigCtxt {})   -> True
+     (IdSig {}, InstDeclCtxt {}) -> True
+     (IdSig {}, _)               -> False
+
+     (InlineSig {}, HsBootCtxt {}) -> False
+     (InlineSig {}, _)             -> True
+
+     (SpecSig {}, TopSigCtxt {})    -> True
+     (SpecSig {}, LocalBindCtxt {}) -> True
+     (SpecSig {}, InstDeclCtxt {})  -> True
+     (SpecSig {}, _)                -> False
+
+     (SpecInstSig {}, InstDeclCtxt {}) -> True
+     (SpecInstSig {}, _)               -> False
+
+     (MinimalSig {}, ClsDeclCtxt {}) -> True
+     (MinimalSig {}, _)              -> False
+
+     (SCCFunSig {}, HsBootCtxt {}) -> False
+     (SCCFunSig {}, _)             -> True
+
+     (CompleteMatchSig {}, TopSigCtxt {} ) -> True
+     (CompleteMatchSig {}, _)              -> False
+
+     (XSig _, _) -> panic "okHsSig"
+
+-------------------
+findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]
+-- Check for duplicates on RdrName version,
+-- because renamed version has unboundName for
+-- not-in-scope binders, which gives bogus dup-sig errors
+-- NB: in a class decl, a 'generic' sig is not considered
+--     equal to an ordinary sig, so we allow, say
+--           class C a where
+--             op :: a -> a
+--             default op :: Eq a => a -> a
+findDupSigs sigs
+  = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)
+  where
+    expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig)
+    expand_sig sig@(InlineSig _ n _)             = [(n,sig)]
+    expand_sig sig@(TypeSig _ ns _)              = [(n,sig) | n <- ns]
+    expand_sig sig@(ClassOpSig _ _ ns _)         = [(n,sig) | n <- ns]
+    expand_sig sig@(PatSynSig _ ns  _ )          = [(n,sig) | n <- ns]
+    expand_sig sig@(SCCFunSig _ _ n _)           = [(n,sig)]
+    expand_sig _ = []
+
+    matching_sig (L _ n1,sig1) (L _ n2,sig2)       = n1 == n2 && mtch sig1 sig2
+    mtch (FixSig {})           (FixSig {})         = True
+    mtch (InlineSig {})        (InlineSig {})      = True
+    mtch (TypeSig {})          (TypeSig {})        = True
+    mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2
+    mtch (PatSynSig _ _ _)     (PatSynSig _ _ _)   = True
+    mtch (SCCFunSig{})         (SCCFunSig{})       = True
+    mtch _ _ = False
+
+-- Warn about multiple MINIMAL signatures
+checkDupMinimalSigs :: [LSig GhcPs] -> RnM ()
+checkDupMinimalSigs sigs
+  = case filter isMinimalLSig sigs of
+      minSigs@(_:_:_) -> dupMinimalSigErr minSigs
+      _ -> return ()
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Match}
+*                                                                      *
+************************************************************************
+-}
+
+rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name
+             -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+             -> MatchGroup GhcPs (Located (body GhcPs))
+             -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)
+rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })
+  = do { empty_case_ok <- xoptM LangExt.EmptyCase
+       ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
+       ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
+       ; return (mkMatchGroup origin new_ms, ms_fvs) }
+rnMatchGroup _ _ (XMatchGroup {}) = panic "rnMatchGroup"
+
+rnMatch :: Outputable (body GhcPs) => HsMatchContext Name
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+        -> LMatch GhcPs (Located (body GhcPs))
+        -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars)
+rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody)
+
+rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name
+         -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+         -> Match GhcPs (Located (body GhcPs))
+         -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars)
+rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
+  = do  { -- Note that there are no local fixity decls for matches
+        ; rnPats ctxt pats      $ \ pats' -> do
+        { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
+        ; let mf' = case (ctxt, mf) of
+                      (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })
+                                            -> mf { mc_fun = L lf funid }
+                      _                     -> ctxt
+        ; return (Match { m_ext = noExt, m_ctxt = mf', m_pats = pats'
+                        , m_grhss = grhss'}, grhss_fvs ) }}
+rnMatch' _ _ (XMatch _) = panic "rnMatch'"
+
+emptyCaseErr :: HsMatchContext Name -> SDoc
+emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)
+                       2 (text "Use EmptyCase to allow this")
+  where
+    pp_ctxt = case ctxt of
+                CaseAlt    -> text "case expression"
+                LambdaExpr -> text "\\case expression"
+                _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{Guarded right-hand sides (GRHSs)}
+*                                                                      *
+************************************************************************
+-}
+
+rnGRHSs :: HsMatchContext Name
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+        -> GRHSs GhcPs (Located (body GhcPs))
+        -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)
+rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds))
+  = rnLocalBindsAndThen binds   $ \ binds' _ -> do
+    (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss
+    return (GRHSs noExt grhss' (L l binds'), fvGRHSs)
+rnGRHSs _ _ (XGRHSs _) = panic "rnGRHSs"
+
+rnGRHS :: HsMatchContext Name
+       -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+       -> LGRHS GhcPs (Located (body GhcPs))
+       -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars)
+rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)
+
+rnGRHS' :: HsMatchContext Name
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+        -> GRHS GhcPs (Located (body GhcPs))
+        -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars)
+rnGRHS' ctxt rnBody (GRHS _ guards rhs)
+  = do  { pattern_guards_allowed <- xoptM LangExt.PatternGuards
+        ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->
+                                    rnBody rhs
+
+        ; unless (pattern_guards_allowed || is_standard_guard guards')
+                 (addWarn NoReason (nonStdGuardErr guards'))
+
+        ; return (GRHS noExt guards' rhs', fvs) }
+  where
+        -- Standard Haskell 1.4 guards are just a single boolean
+        -- expression, rather than a list of qualifiers as in the
+        -- Glasgow extension
+    is_standard_guard []                  = True
+    is_standard_guard [L _ (BodyStmt {})] = True
+    is_standard_guard _                   = False
+rnGRHS' _ _ (XGRHS _) = panic "rnGRHS'"
+
+{-
+*********************************************************
+*                                                       *
+        Source-code fixity declarations
+*                                                       *
+*********************************************************
+-}
+
+rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn)
+-- Rename a fixity decl, so we can put
+-- the renamed decl in the renamed syntax tree
+-- Errors if the thing being fixed is not defined locally.
+rnSrcFixityDecl sig_ctxt = rn_decl
+  where
+    rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn)
+        -- GHC extension: look up both the tycon and data con
+        -- for con-like things; hence returning a list
+        -- If neither are in scope, report an error; otherwise
+        -- return a fixity sig for each (slightly odd)
+    rn_decl (FixitySig _ fnames fixity)
+      = do names <- concatMapM lookup_one fnames
+           return (FixitySig noExt names fixity)
+    rn_decl (XFixitySig _) = panic "rnSrcFixityDecl"
+
+    lookup_one :: Located RdrName -> RnM [Located Name]
+    lookup_one (L name_loc rdr_name)
+      = setSrcSpan name_loc $
+                    -- This lookup will fail if the name is not defined in the
+                    -- same binding group as this fixity declaration.
+        do names <- lookupLocalTcNames sig_ctxt what rdr_name
+           return [ L name_loc name | (_, name) <- names ]
+    what = text "fixity signature"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Error messages}
+*                                                                      *
+************************************************************************
+-}
+
+dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM ()
+dupSigDeclErr pairs@((L loc name, sig) :| _)
+  = addErrAt loc $
+    vcat [ text "Duplicate" <+> what_it_is
+           <> text "s for" <+> quotes (ppr name)
+         , text "at" <+> vcat (map ppr $ sort
+                                       $ map (getLoc . fst)
+                                       $ toList pairs)
+         ]
+  where
+    what_it_is = hsSigDoc sig
+
+misplacedSigErr :: LSig GhcRn -> RnM ()
+misplacedSigErr (L loc sig)
+  = addErrAt loc $
+    sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig]
+
+defaultSigErr :: Sig GhcPs -> SDoc
+defaultSigErr sig = vcat [ hang (text "Unexpected default signature:")
+                              2 (ppr sig)
+                         , text "Use DefaultSignatures to enable default signatures" ]
+
+bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc
+bindsInHsBootFile mbinds
+  = hang (text "Bindings in hs-boot files are not allowed")
+       2 (ppr mbinds)
+
+nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc
+nonStdGuardErr guards
+  = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)")
+       4 (interpp'SP guards)
+
+unusedPatBindWarn :: HsBind GhcRn -> SDoc
+unusedPatBindWarn bind
+  = hang (text "This pattern-binding binds no variables:")
+       2 (ppr bind)
+
+dupMinimalSigErr :: [LSig GhcPs] -> RnM ()
+dupMinimalSigErr sigs@(L loc _ : _)
+  = addErrAt loc $
+    vcat [ text "Multiple minimal complete definitions"
+         , text "at" <+> vcat (map ppr $ sort $ map getLoc sigs)
+         , text "Combine alternative minimal complete definitions with `|'" ]
+dupMinimalSigErr [] = panic "dupMinimalSigErr"
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnEnv.hs
@@ -0,0 +1,1665 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-2006
+
+RnEnv contains functions which convert RdrNames into Names.
+
+-}
+
+{-# LANGUAGE CPP, MultiWayIf, NamedFieldPuns #-}
+
+module RnEnv (
+        newTopSrcBinder,
+        lookupLocatedTopBndrRn, lookupTopBndrRn,
+        lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,
+        lookupLocalOccRn_maybe, lookupInfoOccRn,
+        lookupLocalOccThLvl_maybe, lookupLocalOccRn,
+        lookupTypeOccRn,
+        lookupGlobalOccRn, lookupGlobalOccRn_maybe,
+        lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,
+
+        ChildLookupResult(..),
+        lookupSubBndrOcc_helper,
+        combineChildLookupResult, -- Called by lookupChildrenExport
+
+        HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
+        lookupSigCtxtOccRn,
+
+        lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName,
+        lookupConstructorFields,
+
+        lookupGreAvailRn,
+
+        -- Rebindable Syntax
+        lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames,
+        lookupIfThenElse,
+
+        -- Constructing usage information
+        addUsedGRE, addUsedGREs, addUsedDataCons,
+
+
+
+        dataTcOccs, --TODO: Move this somewhere, into utils?
+
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import LoadIface        ( loadInterfaceForName, loadSrcInterface_maybe )
+import IfaceEnv
+import HsSyn
+import RdrName
+import HscTypes
+import TcEnv
+import TcRnMonad
+import RdrHsSyn         ( filterCTuple, setRdrNameSpace )
+import TysWiredIn
+import Name
+import NameSet
+import NameEnv
+import Avail
+import Module
+import ConLike
+import DataCon
+import TyCon
+import ErrUtils         ( MsgDoc )
+import PrelNames        ( rOOT_MAIN )
+import BasicTypes       ( pprWarningTxtForMsg, TopLevelFlag(..))
+import SrcLoc
+import Outputable
+import Util
+import Maybes
+import DynFlags
+import FastString
+import Control.Monad
+import ListSetOps       ( minusList )
+import qualified GHC.LanguageExtensions as LangExt
+import RnUnbound
+import RnUtils
+import qualified Data.Semigroup as Semi
+import Data.Either      ( partitionEithers )
+import Data.List        (find)
+
+{-
+*********************************************************
+*                                                      *
+                Source-code binders
+*                                                      *
+*********************************************************
+
+Note [Signature lazy interface loading]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+GHC's lazy interface loading can be a bit confusing, so this Note is an
+empirical description of what happens in one interesting case. When
+compiling a signature module against an its implementation, we do NOT
+load interface files associated with its names until after the type
+checking phase.  For example:
+
+    module ASig where
+        data T
+        f :: T -> T
+
+Suppose we compile this with -sig-of "A is ASig":
+
+    module B where
+        data T = T
+        f T = T
+
+    module A(module B) where
+        import B
+
+During type checking, we'll load A.hi because we need to know what the
+RdrEnv for the module is, but we DO NOT load the interface for B.hi!
+It's wholly unnecessary: our local definition 'data T' in ASig is all
+the information we need to finish type checking.  This is contrast to
+type checking of ordinary Haskell files, in which we would not have the
+local definition "data T" and would need to consult B.hi immediately.
+(Also, this situation never occurs for hs-boot files, since you're not
+allowed to reexport from another module.)
+
+After type checking, we then check that the types we provided are
+consistent with the backing implementation (in checkHiBootOrHsigIface).
+At this point, B.hi is loaded, because we need something to compare
+against.
+
+I discovered this behavior when trying to figure out why type class
+instances for Data.Map weren't in the EPS when I was type checking a
+test very much like ASig (sigof02dm): the associated interface hadn't
+been loaded yet!  (The larger issue is a moot point, since an instance
+declared in a signature can never be a duplicate.)
+
+This behavior might change in the future.  Consider this
+alternate module B:
+
+    module B where
+        {-# DEPRECATED T, f "Don't use" #-}
+        data T = T
+        f T = T
+
+One might conceivably want to report deprecation warnings when compiling
+ASig with -sig-of B, in which case we need to look at B.hi to find the
+deprecation warnings during renaming.  At the moment, you don't get any
+warning until you use the identifier further downstream.  This would
+require adjusting addUsedGRE so that during signature compilation,
+we do not report deprecation warnings for LocalDef.  See also
+Note [Handling of deprecations]
+-}
+
+newTopSrcBinder :: Located RdrName -> RnM Name
+newTopSrcBinder (L loc rdr_name)
+  | Just name <- isExact_maybe rdr_name
+  =     -- This is here to catch
+        --   (a) Exact-name binders created by Template Haskell
+        --   (b) The PrelBase defn of (say) [] and similar, for which
+        --       the parser reads the special syntax and returns an Exact RdrName
+        -- We are at a binding site for the name, so check first that it
+        -- the current module is the correct one; otherwise GHC can get
+        -- very confused indeed. This test rejects code like
+        --      data T = (,) Int Int
+        -- unless we are in GHC.Tup
+    if isExternalName name then
+      do { this_mod <- getModule
+         ; unless (this_mod == nameModule name)
+                  (addErrAt loc (badOrigBinding rdr_name))
+         ; return name }
+    else   -- See Note [Binders in Template Haskell] in Convert.hs
+      do { this_mod <- getModule
+         ; externaliseName this_mod name }
+
+  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+  = do  { this_mod <- getModule
+        ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
+                 (addErrAt loc (badOrigBinding rdr_name))
+        -- When reading External Core we get Orig names as binders,
+        -- but they should agree with the module gotten from the monad
+        --
+        -- We can get built-in syntax showing up here too, sadly.  If you type
+        --      data T = (,,,)
+        -- the constructor is parsed as a type, and then RdrHsSyn.tyConToDataCon
+        -- uses setRdrNameSpace to make it into a data constructors.  At that point
+        -- the nice Exact name for the TyCon gets swizzled to an Orig name.
+        -- Hence the badOrigBinding error message.
+        --
+        -- Except for the ":Main.main = ..." definition inserted into
+        -- the Main module; ugh!
+
+        -- Because of this latter case, we call newGlobalBinder with a module from
+        -- the RdrName, not from the environment.  In principle, it'd be fine to
+        -- have an arbitrary mixture of external core definitions in a single module,
+        -- (apart from module-initialisation issues, perhaps).
+        ; newGlobalBinder rdr_mod rdr_occ loc }
+
+  | otherwise
+  = do  { when (isQual rdr_name)
+                 (addErrAt loc (badQualBndrErr rdr_name))
+                -- Binders should not be qualified; if they are, and with a different
+                -- module name, we get a confusing "M.T is not in scope" error later
+
+        ; stage <- getStage
+        ; if isBrackStage stage then
+                -- We are inside a TH bracket, so make an *Internal* name
+                -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames
+             do { uniq <- newUnique
+                ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
+          else
+             do { this_mod <- getModule
+                ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr loc)
+                ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc }
+        }
+
+{-
+*********************************************************
+*                                                      *
+        Source code occurrences
+*                                                      *
+*********************************************************
+
+Looking up a name in the RnEnv.
+
+Note [Type and class operator definitions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to reject all of these unless we have -XTypeOperators (Trac #3265)
+   data a :*: b  = ...
+   class a :*: b where ...
+   data (:*:) a b  = ....
+   class (:*:) a b where ...
+The latter two mean that we are not just looking for a
+*syntactically-infix* declaration, but one that uses an operator
+OccName.  We use OccName.isSymOcc to detect that case, which isn't
+terribly efficient, but there seems to be no better way.
+-}
+
+-- Can be made to not be exposed
+-- Only used unwrapped in rnAnnProvenance
+lookupTopBndrRn :: RdrName -> RnM Name
+lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n
+                       case nopt of
+                         Just n' -> return n'
+                         Nothing -> do traceRn "lookupTopBndrRn fail" (ppr n)
+                                       unboundName WL_LocalTop n
+
+lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)
+lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn
+
+lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name)
+-- Look up a top-level source-code binder.   We may be looking up an unqualified 'f',
+-- and there may be several imported 'f's too, which must not confuse us.
+-- For example, this is OK:
+--      import Foo( f )
+--      infix 9 f       -- The 'f' here does not need to be qualified
+--      f x = x         -- Nor here, of course
+-- So we have to filter out the non-local ones.
+--
+-- A separate function (importsFromLocalDecls) reports duplicate top level
+-- decls, so here it's safe just to choose an arbitrary one.
+--
+-- There should never be a qualified name in a binding position in Haskell,
+-- but there can be if we have read in an external-Core file.
+-- The Haskell parser checks for the illegal qualified name in Haskell
+-- source files, so we don't need to do so here.
+
+lookupTopBndrRn_maybe rdr_name =
+  lookupExactOrOrig rdr_name Just $
+    do  {  -- Check for operators in type or class declarations
+           -- See Note [Type and class operator definitions]
+          let occ = rdrNameOcc rdr_name
+        ; when (isTcOcc occ && isSymOcc occ)
+               (do { op_ok <- xoptM LangExt.TypeOperators
+                   ; unless op_ok (addErr (opDeclErr rdr_name)) })
+
+        ; env <- getGlobalRdrEnv
+        ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of
+            [gre] -> return (Just (gre_name gre))
+            _     -> return Nothing  -- Ambiguous (can't happen) or unbound
+    }
+
+-----------------------------------------------
+-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].
+-- This adds an error if the name cannot be found.
+lookupExactOcc :: Name -> RnM Name
+lookupExactOcc name
+  = do { result <- lookupExactOcc_either name
+       ; case result of
+           Left err -> do { addErr err
+                          ; return name }
+           Right name' -> return name' }
+
+-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].
+-- This never adds an error, but it may return one.
+lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name)
+-- See Note [Looking up Exact RdrNames]
+lookupExactOcc_either name
+  | Just thing <- wiredInNameTyThing_maybe name
+  , Just tycon <- case thing of
+                    ATyCon tc                 -> Just tc
+                    AConLike (RealDataCon dc) -> Just (dataConTyCon dc)
+                    _                         -> Nothing
+  , isTupleTyCon tycon
+  = do { checkTupSize (tyConArity tycon)
+       ; return (Right name) }
+
+  | isExternalName name
+  = return (Right name)
+
+  | otherwise
+  = do { env <- getGlobalRdrEnv
+       ; let -- See Note [Splicing Exact names]
+             main_occ =  nameOccName name
+             demoted_occs = case demoteOccName main_occ of
+                              Just occ -> [occ]
+                              Nothing  -> []
+             gres = [ gre | occ <- main_occ : demoted_occs
+                          , gre <- lookupGlobalRdrEnv env occ
+                          , gre_name gre == name ]
+       ; case gres of
+           [gre] -> return (Right (gre_name gre))
+
+           []    -> -- See Note [Splicing Exact names]
+                    do { lcl_env <- getLocalRdrEnv
+                       ; if name `inLocalRdrEnvScope` lcl_env
+                         then return (Right name)
+                         else
+                         do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
+                            ; th_topnames <- readTcRef th_topnames_var
+                            ; if name `elemNameSet` th_topnames
+                              then return (Right name)
+                              else return (Left exact_nm_err)
+                            }
+                       }
+           gres -> return (Left (sameNameErr gres))   -- Ugh!  See Note [Template Haskell ambiguity]
+       }
+  where
+    exact_nm_err = hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))
+                      2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), "
+                              , text "perhaps via newName, but did not bind it"
+                              , text "If that's it, then -ddump-splices might be useful" ])
+
+sameNameErr :: [GlobalRdrElt] -> MsgDoc
+sameNameErr [] = panic "addSameNameErr: empty list"
+sameNameErr gres@(_ : _)
+  = hang (text "Same exact name in multiple name-spaces:")
+       2 (vcat (map pp_one sorted_names) $$ th_hint)
+  where
+    sorted_names = sortWith nameSrcLoc (map gre_name gres)
+    pp_one name
+      = hang (pprNameSpace (occNameSpace (getOccName name))
+              <+> quotes (ppr name) <> comma)
+           2 (text "declared at:" <+> ppr (nameSrcLoc name))
+
+    th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU),"
+                   , text "perhaps via newName, in different name-spaces."
+                   , text "If that's it, then -ddump-splices might be useful" ]
+
+
+-----------------------------------------------
+lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name
+-- This is called on the method name on the left-hand side of an
+-- instance declaration binding. eg.  instance Functor T where
+--                                       fmap = ...
+--                                       ^^^^ called on this
+-- Regardless of how many unqualified fmaps are in scope, we want
+-- the one that comes from the Functor class.
+--
+-- Furthermore, note that we take no account of whether the
+-- name is only in scope qualified.  I.e. even if method op is
+-- in scope as M.op, we still allow plain 'op' on the LHS of
+-- an instance decl
+--
+-- The "what" parameter says "method" or "associated type",
+-- depending on what we are looking up
+lookupInstDeclBndr cls what rdr
+  = do { when (isQual rdr)
+              (addErr (badQualBndrErr rdr))
+                -- In an instance decl you aren't allowed
+                -- to use a qualified name for the method
+                -- (Although it'd make perfect sense.)
+       ; mb_name <- lookupSubBndrOcc
+                          False -- False => we don't give deprecated
+                                -- warnings when a deprecated class
+                                -- method is defined. We only warn
+                                -- when it's used
+                          cls doc rdr
+       ; case mb_name of
+           Left err -> do { addErr err; return (mkUnboundNameRdr rdr) }
+           Right nm -> return nm }
+  where
+    doc = what <+> text "of class" <+> quotes (ppr cls)
+
+-----------------------------------------------
+lookupFamInstName :: Maybe Name -> Located RdrName
+                  -> RnM (Located Name)
+-- Used for TyData and TySynonym family instances only,
+-- See Note [Family instance binders]
+lookupFamInstName (Just cls) tc_rdr  -- Associated type; c.f RnBinds.rnMethodBind
+  = wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr
+lookupFamInstName Nothing tc_rdr     -- Family instance; tc_rdr is an *occurrence*
+  = lookupLocatedOccRn tc_rdr
+
+-----------------------------------------------
+lookupConstructorFields :: Name -> RnM [FieldLabel]
+-- Look up the fields of a given constructor
+--   *  For constructors from this module, use the record field env,
+--      which is itself gathered from the (as yet un-typechecked)
+--      data type decls
+--
+--    * For constructors from imported modules, use the *type* environment
+--      since imported modles are already compiled, the info is conveniently
+--      right there
+
+lookupConstructorFields con_name
+  = do  { this_mod <- getModule
+        ; if nameIsLocalOrFrom this_mod con_name then
+          do { field_env <- getRecFieldEnv
+             ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env)
+             ; return (lookupNameEnv field_env con_name `orElse` []) }
+          else
+          do { con <- tcLookupConLike con_name
+             ; traceTc "lookupCF 2" (ppr con)
+             ; return (conLikeFieldLabels con) } }
+
+
+-- In CPS style as `RnM r` is monadic
+lookupExactOrOrig :: RdrName -> (Name -> r) -> RnM r -> RnM r
+lookupExactOrOrig rdr_name res k
+  | Just n <- isExact_maybe rdr_name   -- This happens in derived code
+  = res <$> lookupExactOcc n
+  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+  = res <$> lookupOrig rdr_mod rdr_occ
+  | otherwise = k
+
+
+
+-----------------------------------------------
+-- | Look up an occurrence of a field in record construction or pattern
+-- matching (but not update).  When the -XDisambiguateRecordFields
+-- flag is on, take account of the data constructor name to
+-- disambiguate which field to use.
+--
+-- See Note [DisambiguateRecordFields].
+lookupRecFieldOcc :: Maybe Name -- Nothing  => just look it up as usual
+                                -- Just con => use data con to disambiguate
+                  -> RdrName
+                  -> RnM Name
+lookupRecFieldOcc mb_con rdr_name
+  | Just con <- mb_con
+  , isUnboundName con  -- Avoid error cascade
+  = return (mkUnboundNameRdr rdr_name)
+  | Just con <- mb_con
+  = do { flds <- lookupConstructorFields con
+       ; env <- getGlobalRdrEnv
+       ; let lbl      = occNameFS (rdrNameOcc rdr_name)
+             mb_field = do fl <- find ((== lbl) . flLabel) flds
+                           -- We have the label, now check it is in
+                           -- scope (with the correct qualifier if
+                           -- there is one, hence calling pickGREs).
+                           gre <- lookupGRE_FieldLabel env fl
+                           guard (not (isQual rdr_name
+                                         && null (pickGREs rdr_name [gre])))
+                           return (fl, gre)
+       ; case mb_field of
+           Just (fl, gre) -> do { addUsedGRE True gre
+                                ; return (flSelector fl) }
+           Nothing        -> lookupGlobalOccRn rdr_name }
+             -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]
+  | otherwise
+  -- This use of Global is right as we are looking up a selector which
+  -- can only be defined at the top level.
+  = lookupGlobalOccRn rdr_name
+
+{- Note [DisambiguateRecordFields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we are looking up record fields in record construction or pattern
+matching, we can take advantage of the data constructor name to
+resolve fields that would otherwise be ambiguous (provided the
+-XDisambiguateRecordFields flag is on).
+
+For example, consider:
+
+   data S = MkS { x :: Int }
+   data T = MkT { x :: Int }
+
+   e = MkS { x = 3 }
+
+When we are renaming the occurrence of `x` in `e`, instead of looking
+`x` up directly (and finding both fields), lookupRecFieldOcc will
+search the fields of `MkS` to find the only possible `x` the user can
+mean.
+
+Of course, we still have to check the field is in scope, using
+lookupGRE_FieldLabel.  The handling of qualified imports is slightly
+subtle: the occurrence may be unqualified even if the field is
+imported only qualified (but if the occurrence is qualified, the
+qualifier must be correct). For example:
+
+   module A where
+     data S = MkS { x :: Int }
+     data T = MkT { x :: Int }
+
+   module B where
+     import qualified A (S(..))
+     import A (T(MkT))
+
+     e1 = MkT   { x = 3 }   -- x not in scope, so fail
+     e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail
+     e3 = A.MkS { x = 3 }   -- x in scope (lack of module qualifier permitted)
+
+In case `e1`, lookupGRE_FieldLabel will return Nothing.  In case `e2`,
+lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard
+will fail because the field RdrName `B.x` is qualified and pickGREs
+rejects the GRE.  In case `e3`, lookupGRE_FieldLabel will return the
+GRE for `A.x` and the guard will succeed because the field RdrName `x`
+is unqualified.
+
+
+Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Whenever we fail to find the field or it is not in scope, mb_field
+will be False, and we fall back on looking it up normally using
+lookupGlobalOccRn.  We don't report an error immediately because the
+actual problem might be located elsewhere.  For example (Trac #9975):
+
+   data Test = Test { x :: Int }
+   pattern Test wat = Test { x = wat }
+
+Here there are multiple declarations of Test (as a data constructor
+and as a pattern synonym), which will be reported as an error.  We
+shouldn't also report an error about the occurrence of `x` in the
+pattern synonym RHS.  However, if the pattern synonym gets added to
+the environment first, we will try and fail to find `x` amongst the
+(nonexistent) fields of the pattern synonym.
+
+Alternatively, the scope check can fail due to Template Haskell.
+Consider (Trac #12130):
+
+   module Foo where
+     import M
+     b = $(funny)
+
+   module M(funny) where
+     data T = MkT { x :: Int }
+     funny :: Q Exp
+     funny = [| MkT { x = 3 } |]
+
+When we splice, `MkT` is not lexically in scope, so
+lookupGRE_FieldLabel will fail.  But there is no need for
+disambiguation anyway, because `x` is an original name, and
+lookupGlobalOccRn will find it.
+-}
+
+
+
+-- | Used in export lists to lookup the children.
+lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName
+                        -> RnM ChildLookupResult
+lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name
+  | isUnboundName parent
+    -- Avoid an error cascade
+  = return (FoundName NoParent (mkUnboundNameRdr rdr_name))
+
+  | otherwise = do
+  gre_env <- getGlobalRdrEnv
+
+  let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name)
+  -- Disambiguate the lookup based on the parent information.
+  -- The remaining GREs are things that we *could* export here, note that
+  -- this includes things which have `NoParent`. Those are sorted in
+  -- `checkPatSynParent`.
+  traceRn "parent" (ppr parent)
+  traceRn "lookupExportChild original_gres:" (ppr original_gres)
+  traceRn "lookupExportChild picked_gres:" (ppr $ picked_gres original_gres)
+  case picked_gres original_gres of
+    NoOccurrence ->
+      noMatchingParentErr original_gres
+    UniqueOccurrence g ->
+      if must_have_parent then noMatchingParentErr original_gres
+                          else checkFld g
+    DisambiguatedOccurrence g ->
+      checkFld g
+    AmbiguousOccurrence gres ->
+      mkNameClashErr gres
+    where
+        -- Convert into FieldLabel if necessary
+        checkFld :: GlobalRdrElt -> RnM ChildLookupResult
+        checkFld g@GRE{gre_name, gre_par} = do
+          addUsedGRE warn_if_deprec g
+          return $ case gre_par of
+            FldParent _ mfs ->
+              FoundFL  (fldParentToFieldLabel gre_name mfs)
+            _ -> FoundName gre_par gre_name
+
+        fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel
+        fldParentToFieldLabel name mfs =
+          case mfs of
+            Nothing ->
+              let fs = occNameFS (nameOccName name)
+              in FieldLabel fs False name
+            Just fs -> FieldLabel fs True name
+
+        -- Called when we find no matching GREs after disambiguation but
+        -- there are three situations where this happens.
+        -- 1. There were none to begin with.
+        -- 2. None of the matching ones were the parent but
+        --  a. They were from an overloaded record field so we can report
+        --     a better error
+        --  b. The original lookup was actually ambiguous.
+        --     For example, the case where overloading is off and two
+        --     record fields are in scope from different record
+        --     constructors, neither of which is the parent.
+        noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult
+        noMatchingParentErr original_gres = do
+          overload_ok <- xoptM LangExt.DuplicateRecordFields
+          case original_gres of
+            [] ->  return NameNotFound
+            [g] -> return $ IncorrectParent parent
+                              (gre_name g) (ppr $ gre_name g)
+                              [p | Just p <- [getParent g]]
+            gss@(g:_:_) ->
+              if all isRecFldGRE gss && overload_ok
+                then return $
+                      IncorrectParent parent
+                        (gre_name g)
+                        (ppr $ expectJust "noMatchingParentErr" (greLabel g))
+                        [p | x <- gss, Just p <- [getParent x]]
+                else mkNameClashErr gss
+
+        mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult
+        mkNameClashErr gres = do
+          addNameClashErrRn rdr_name gres
+          return (FoundName (gre_par (head gres)) (gre_name (head gres)))
+
+        getParent :: GlobalRdrElt -> Maybe Name
+        getParent (GRE { gre_par = p } ) =
+          case p of
+            ParentIs cur_parent -> Just cur_parent
+            FldParent { par_is = cur_parent } -> Just cur_parent
+            NoParent -> Nothing
+
+        picked_gres :: [GlobalRdrElt] -> DisambigInfo
+        -- For Unqual, find GREs that are in scope qualified or unqualified
+        -- For Qual,   find GREs that are in scope with that qualification
+        picked_gres gres
+          | isUnqual rdr_name
+          = mconcat (map right_parent gres)
+          | otherwise
+          = mconcat (map right_parent (pickGREs rdr_name gres))
+
+        right_parent :: GlobalRdrElt -> DisambigInfo
+        right_parent p
+          = case getParent p of
+               Just cur_parent
+                  | parent == cur_parent -> DisambiguatedOccurrence p
+                  | otherwise            -> NoOccurrence
+               Nothing                   -> UniqueOccurrence p
+
+
+-- This domain specific datatype is used to record why we decided it was
+-- possible that a GRE could be exported with a parent.
+data DisambigInfo
+       = NoOccurrence
+          -- The GRE could never be exported. It has the wrong parent.
+       | UniqueOccurrence GlobalRdrElt
+          -- The GRE has no parent. It could be a pattern synonym.
+       | DisambiguatedOccurrence GlobalRdrElt
+          -- The parent of the GRE is the correct parent
+       | AmbiguousOccurrence [GlobalRdrElt]
+          -- For example, two normal identifiers with the same name are in
+          -- scope. They will both be resolved to "UniqueOccurrence" and the
+          -- monoid will combine them to this failing case.
+
+instance Outputable DisambigInfo where
+  ppr NoOccurrence = text "NoOccurence"
+  ppr (UniqueOccurrence gre) = text "UniqueOccurrence:" <+> ppr gre
+  ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre
+  ppr (AmbiguousOccurrence gres)    = text "Ambiguous:" <+> ppr gres
+
+instance Semi.Semigroup DisambigInfo where
+  -- This is the key line: We prefer disambiguated occurrences to other
+  -- names.
+  _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g'
+  DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g'
+
+  NoOccurrence <> m = m
+  m <> NoOccurrence = m
+  UniqueOccurrence g <> UniqueOccurrence g'
+    = AmbiguousOccurrence [g, g']
+  UniqueOccurrence g <> AmbiguousOccurrence gs
+    = AmbiguousOccurrence (g:gs)
+  AmbiguousOccurrence gs <> UniqueOccurrence g'
+    = AmbiguousOccurrence (g':gs)
+  AmbiguousOccurrence gs <> AmbiguousOccurrence gs'
+    = AmbiguousOccurrence (gs ++ gs')
+
+instance Monoid DisambigInfo where
+  mempty = NoOccurrence
+  mappend = (Semi.<>)
+
+-- Lookup SubBndrOcc can never be ambiguous
+--
+-- Records the result of looking up a child.
+data ChildLookupResult
+      = NameNotFound                --  We couldn't find a suitable name
+      | IncorrectParent Name        -- Parent
+                        Name        -- Name of thing we were looking for
+                        SDoc        -- How to print the name
+                        [Name]      -- List of possible parents
+      | FoundName Parent Name       --  We resolved to a normal name
+      | FoundFL FieldLabel          --  We resolved to a FL
+
+-- | Specialised version of msum for RnM ChildLookupResult
+combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult
+combineChildLookupResult [] = return NameNotFound
+combineChildLookupResult (x:xs) = do
+  res <- x
+  case res of
+    NameNotFound -> combineChildLookupResult xs
+    _ -> return res
+
+instance Outputable ChildLookupResult where
+  ppr NameNotFound = text "NameNotFound"
+  ppr (FoundName p n) = text "Found:" <+> ppr p <+> ppr n
+  ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls
+  ppr (IncorrectParent p n td ns) = text "IncorrectParent"
+                                  <+> hsep [ppr p, ppr n, td, ppr ns]
+
+lookupSubBndrOcc :: Bool
+                 -> Name     -- Parent
+                 -> SDoc
+                 -> RdrName
+                 -> RnM (Either MsgDoc Name)
+-- Find all the things the rdr-name maps to
+-- and pick the one with the right parent namep
+lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do
+  res <-
+    lookupExactOrOrig rdr_name (FoundName NoParent) $
+      -- This happens for built-in classes, see mod052 for example
+      lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name
+  case res of
+    NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name))
+    FoundName _p n -> return (Right n)
+    FoundFL fl  ->  return (Right (flSelector fl))
+    IncorrectParent {}
+         -- See [Mismatched class methods and associated type families]
+         -- in TcInstDecls.
+      -> return $ Left (unknownSubordinateErr doc rdr_name)
+
+{-
+Note [Family instance binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data family F a
+  data instance F T = X1 | X2
+
+The 'data instance' decl has an *occurrence* of F (and T), and *binds*
+X1 and X2.  (This is unlike a normal data type declaration which would
+bind F too.)  So we want an AvailTC F [X1,X2].
+
+Now consider a similar pair:
+  class C a where
+    data G a
+  instance C S where
+    data G S = Y1 | Y2
+
+The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G.
+
+But there is a small complication: in an instance decl, we don't use
+qualified names on the LHS; instead we use the class to disambiguate.
+Thus:
+  module M where
+    import Blib( G )
+    class C a where
+      data G a
+    instance C S where
+      data G S = Y1 | Y2
+Even though there are two G's in scope (M.G and Blib.G), the occurrence
+of 'G' in the 'instance C S' decl is unambiguous, because C has only
+one associated type called G. This is exactly what happens for methods,
+and it is only consistent to do the same thing for types. That's the
+role of the function lookupTcdName; the (Maybe Name) give the class of
+the encloseing instance decl, if any.
+
+Note [Looking up Exact RdrNames]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Exact RdrNames are generated by Template Haskell.  See Note [Binders
+in Template Haskell] in Convert.
+
+For data types and classes have Exact system Names in the binding
+positions for constructors, TyCons etc.  For example
+    [d| data T = MkT Int |]
+when we splice in and Convert to HsSyn RdrName, we'll get
+    data (Exact (system Name "T")) = (Exact (system Name "MkT")) ...
+These System names are generated by Convert.thRdrName
+
+But, constructors and the like need External Names, not System Names!
+So we do the following
+
+ * In RnEnv.newTopSrcBinder we spot Exact RdrNames that wrap a
+   non-External Name, and make an External name for it. This is
+   the name that goes in the GlobalRdrEnv
+
+ * When looking up an occurrence of an Exact name, done in
+   RnEnv.lookupExactOcc, we find the Name with the right unique in the
+   GlobalRdrEnv, and use the one from the envt -- it will be an
+   External Name in the case of the data type/constructor above.
+
+ * Exact names are also use for purely local binders generated
+   by TH, such as    \x_33. x_33
+   Both binder and occurrence are Exact RdrNames.  The occurrence
+   gets looked up in the LocalRdrEnv by RnEnv.lookupOccRn, and
+   misses, because lookupLocalRdrEnv always returns Nothing for
+   an Exact Name.  Now we fall through to lookupExactOcc, which
+   will find the Name is not in the GlobalRdrEnv, so we just use
+   the Exact supplied Name.
+
+Note [Splicing Exact names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the splice $(do { x <- newName "x"; return (VarE x) })
+This will generate a (HsExpr RdrName) term that mentions the
+Exact RdrName "x_56" (or whatever), but does not bind it.  So
+when looking such Exact names we want to check that it's in scope,
+otherwise the type checker will get confused.  To do this we need to
+keep track of all the Names in scope, and the LocalRdrEnv does just that;
+we consult it with RdrName.inLocalRdrEnvScope.
+
+There is another wrinkle.  With TH and -XDataKinds, consider
+   $( [d| data Nat = Zero
+          data T = MkT (Proxy 'Zero)  |] )
+After splicing, but before renaming we get this:
+   data Nat_77{tc} = Zero_78{d}
+   data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc})  |] )
+The occurrence of 'Zero in the data type for T has the right unique,
+but it has a TcClsName name-space in its OccName.  (This is set by
+the ctxt_ns argument of Convert.thRdrName.)  When we check that is
+in scope in the GlobalRdrEnv, we need to look up the DataName namespace
+too.  (An alternative would be to make the GlobalRdrEnv also have
+a Name -> GRE mapping.)
+
+Note [Template Haskell ambiguity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The GlobalRdrEnv invariant says that if
+  occ -> [gre1, ..., gren]
+then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv).
+This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre).
+
+So how can we get multiple gres in lookupExactOcc_maybe?  Because in
+TH we might use the same TH NameU in two different name spaces.
+eg (Trac #7241):
+   $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]])
+Here we generate a type constructor and data constructor with the same
+unique, but different name spaces.
+
+It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would
+mean looking up the OccName in every name-space, just in case, and that
+seems a bit brutal.  So it's just done here on lookup.  But we might
+need to revisit that choice.
+
+Note [Usage for sub-bndrs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+If you have this
+   import qualified M( C( f ) )
+   instance M.C T where
+     f x = x
+then is the qualified import M.f used?  Obviously yes.
+But the RdrName used in the instance decl is unqualified.  In effect,
+we fill in the qualification by looking for f's whose class is M.C
+But when adding to the UsedRdrNames we must make that qualification
+explicit (saying "used  M.f"), otherwise we get "Redundant import of M.f".
+
+So we make up a suitable (fake) RdrName.  But be careful
+   import qualified M
+   import M( C(f) )
+   instance C T where
+     f x = x
+Here we want to record a use of 'f', not of 'M.f', otherwise
+we'll miss the fact that the qualified import is redundant.
+
+--------------------------------------------------
+--              Occurrences
+--------------------------------------------------
+-}
+
+
+lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)
+lookupLocatedOccRn = wrapLocM lookupOccRn
+
+lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name)
+-- Just look in the local environment
+lookupLocalOccRn_maybe rdr_name
+  = do { local_env <- getLocalRdrEnv
+       ; return (lookupLocalRdrEnv local_env rdr_name) }
+
+lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel))
+-- Just look in the local environment
+lookupLocalOccThLvl_maybe name
+  = do { lcl_env <- getLclEnv
+       ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) }
+
+-- lookupOccRn looks up an occurrence of a RdrName
+lookupOccRn :: RdrName -> RnM Name
+lookupOccRn rdr_name
+  = do { mb_name <- lookupOccRn_maybe rdr_name
+       ; case mb_name of
+           Just name -> return name
+           Nothing   -> reportUnboundName rdr_name }
+
+-- Only used in one place, to rename pattern synonym binders.
+-- See Note [Renaming pattern synonym variables] in RnBinds
+lookupLocalOccRn :: RdrName -> RnM Name
+lookupLocalOccRn rdr_name
+  = do { mb_name <- lookupLocalOccRn_maybe rdr_name
+       ; case mb_name of
+           Just name -> return name
+           Nothing   -> unboundName WL_LocalOnly rdr_name }
+
+-- lookupPromotedOccRn looks up an optionally promoted RdrName.
+lookupTypeOccRn :: RdrName -> RnM Name
+-- see Note [Demotion]
+lookupTypeOccRn rdr_name
+  | isVarOcc (rdrNameOcc rdr_name)  -- See Note [Promoted variables in types]
+  = badVarInType rdr_name
+  | otherwise
+  = do { mb_name <- lookupOccRn_maybe rdr_name
+       ; case mb_name of
+             Just name -> return name
+             Nothing   -> lookup_demoted rdr_name }
+
+lookup_demoted :: RdrName -> RnM Name
+lookup_demoted rdr_name
+  | Just demoted_rdr <- demoteRdrName rdr_name
+    -- Maybe it's the name of a *data* constructor
+  = do { data_kinds <- xoptM LangExt.DataKinds
+       ; star_is_type <- xoptM LangExt.StarIsType
+       ; let star_info = starInfo star_is_type rdr_name
+       ; if data_kinds
+            then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr
+                    ; case mb_demoted_name of
+                        Nothing -> unboundNameX WL_Any rdr_name star_info
+                        Just demoted_name ->
+                          do { whenWOptM Opt_WarnUntickedPromotedConstructors $
+                               addWarn
+                                 (Reason Opt_WarnUntickedPromotedConstructors)
+                                 (untickedPromConstrWarn demoted_name)
+                             ; return demoted_name } }
+            else do { -- We need to check if a data constructor of this name is
+                      -- in scope to give good error messages. However, we do
+                      -- not want to give an additional error if the data
+                      -- constructor happens to be out of scope! See #13947.
+                      mb_demoted_name <- discardErrs $
+                                         lookupOccRn_maybe demoted_rdr
+                    ; let suggestion | isJust mb_demoted_name = suggest_dk
+                                     | otherwise = star_info
+                    ; unboundNameX WL_Any rdr_name suggestion } }
+
+  | otherwise
+  = reportUnboundName rdr_name
+
+  where
+    suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?"
+    untickedPromConstrWarn name =
+      text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot
+      $$
+      hsep [ text "Use"
+           , quotes (char '\'' <> ppr name)
+           , text "instead of"
+           , quotes (ppr name) <> dot ]
+
+badVarInType :: RdrName -> RnM Name
+badVarInType rdr_name
+  = do { addErr (text "Illegal promoted term variable in a type:"
+                 <+> ppr rdr_name)
+       ; return (mkUnboundNameRdr rdr_name) }
+
+{- Note [Promoted variables in types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (Trac #12686):
+   x = True
+   data Bad = Bad 'x
+
+The parser treats the quote in 'x as saying "use the term
+namespace", so we'll get (Bad x{v}), with 'x' in the
+VarName namespace.  If we don't test for this, the renamer
+will happily rename it to the x bound at top level, and then
+the typecheck falls over because it doesn't have 'x' in scope
+when kind-checking.
+
+Note [Demotion]
+~~~~~~~~~~~~~~~
+When the user writes:
+  data Nat = Zero | Succ Nat
+  foo :: f Zero -> Int
+
+'Zero' in the type signature of 'foo' is parsed as:
+  HsTyVar ("Zero", TcClsName)
+
+When the renamer hits this occurrence of 'Zero' it's going to realise
+that it's not in scope. But because it is renaming a type, it knows
+that 'Zero' might be a promoted data constructor, so it will demote
+its namespace to DataName and do a second lookup.
+
+The final result (after the renamer) will be:
+  HsTyVar ("Zero", DataName)
+-}
+
+lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (Name -> r) -> RdrName
+                   -> RnM (Maybe r)
+lookupOccRnX_maybe globalLookup wrapper rdr_name
+  = runMaybeT . msum . map MaybeT $
+      [ fmap wrapper <$> lookupLocalOccRn_maybe rdr_name
+      , globalLookup rdr_name ]
+
+lookupOccRn_maybe :: RdrName -> RnM (Maybe Name)
+lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id
+
+lookupOccRn_overloaded :: Bool -> RdrName
+                       -> RnM (Maybe (Either Name [Name]))
+lookupOccRn_overloaded overload_ok
+  = lookupOccRnX_maybe global_lookup Left
+      where
+        global_lookup :: RdrName -> RnM (Maybe (Either Name [Name]))
+        global_lookup n =
+          runMaybeT . msum . map MaybeT $
+            [ lookupGlobalOccRn_overloaded overload_ok n
+            , fmap Left . listToMaybe <$> lookupQualifiedNameGHCi n ]
+
+
+
+lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)
+-- Looks up a RdrName occurrence in the top-level
+--   environment, including using lookupQualifiedNameGHCi
+--   for the GHCi case
+-- No filter function; does not report an error on failure
+-- Uses addUsedRdrName to record use and deprecations
+lookupGlobalOccRn_maybe rdr_name =
+  lookupExactOrOrig rdr_name Just $
+    runMaybeT . msum . map MaybeT $
+      [ fmap gre_name <$> lookupGreRn_maybe rdr_name
+      , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ]
+                      -- This test is not expensive,
+                      -- and only happens for failed lookups
+
+lookupGlobalOccRn :: RdrName -> RnM Name
+-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
+-- environment.  Adds an error message if the RdrName is not in scope.
+-- You usually want to use "lookupOccRn" which also looks in the local
+-- environment.
+lookupGlobalOccRn rdr_name
+  = do { mb_name <- lookupGlobalOccRn_maybe rdr_name
+       ; case mb_name of
+           Just n  -> return n
+           Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)
+                         ; unboundName WL_Global rdr_name } }
+
+lookupInfoOccRn :: RdrName -> RnM [Name]
+-- lookupInfoOccRn is intended for use in GHCi's ":info" command
+-- It finds all the GREs that RdrName could mean, not complaining
+-- about ambiguity, but rather returning them all
+-- C.f. Trac #9881
+lookupInfoOccRn rdr_name =
+  lookupExactOrOrig rdr_name (:[]) $
+    do { rdr_env <- getGlobalRdrEnv
+       ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env)
+       ; qual_ns <- lookupQualifiedNameGHCi rdr_name
+       ; return (ns ++ (qual_ns `minusList` ns)) }
+
+-- | Like 'lookupOccRn_maybe', but with a more informative result if
+-- the 'RdrName' happens to be a record selector:
+--
+--   * Nothing         -> name not in scope (no error reported)
+--   * Just (Left x)   -> name uniquely refers to x,
+--                        or there is a name clash (reported)
+--   * Just (Right xs) -> name refers to one or more record selectors;
+--                        if overload_ok was False, this list will be
+--                        a singleton.
+
+lookupGlobalOccRn_overloaded :: Bool -> RdrName
+                             -> RnM (Maybe (Either Name [Name]))
+lookupGlobalOccRn_overloaded overload_ok rdr_name =
+  lookupExactOrOrig rdr_name (Just . Left) $
+     do  { res <- lookupGreRn_helper rdr_name
+         ; case res of
+                GreNotFound  -> return Nothing
+                OneNameMatch gre -> do
+                  let wrapper = if isRecFldGRE gre then Right . (:[]) else Left
+                  return $ Just (wrapper (gre_name gre))
+                MultipleNames gres  | all isRecFldGRE gres && overload_ok ->
+                  -- Don't record usage for ambiguous selectors
+                  -- until we know which is meant
+                  return $ Just (Right (map gre_name gres))
+                MultipleNames gres  -> do
+                  addNameClashErrRn rdr_name gres
+                  return (Just (Left (gre_name (head gres)))) }
+
+
+--------------------------------------------------
+--      Lookup in the Global RdrEnv of the module
+--------------------------------------------------
+
+data GreLookupResult = GreNotFound
+                     | OneNameMatch GlobalRdrElt
+                     | MultipleNames [GlobalRdrElt]
+
+lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
+-- Look up the RdrName in the GlobalRdrEnv
+--   Exactly one binding: records it as "used", return (Just gre)
+--   No bindings:         return Nothing
+--   Many bindings:       report "ambiguous", return an arbitrary (Just gre)
+-- Uses addUsedRdrName to record use and deprecations
+lookupGreRn_maybe rdr_name
+  = do
+      res <- lookupGreRn_helper rdr_name
+      case res of
+        OneNameMatch gre ->  return $ Just gre
+        MultipleNames gres -> do
+          traceRn "lookupGreRn_maybe:NameClash" (ppr gres)
+          addNameClashErrRn rdr_name gres
+          return $ Just (head gres)
+        GreNotFound -> return Nothing
+
+{-
+
+Note [ Unbound vs Ambiguous Names ]
+
+lookupGreRn_maybe deals with failures in two different ways. If a name
+is unbound then we return a `Nothing` but if the name is ambiguous
+then we raise an error and return a dummy name.
+
+The reason for this is that when we call `lookupGreRn_maybe` we are
+speculatively looking for whatever we are looking up. If we don't find it,
+then we might have been looking for the wrong thing and can keep trying.
+On the other hand, if we find a clash then there is no way to recover as
+we found the thing we were looking for but can no longer resolve which
+the correct one is.
+
+One example of this is in `lookupTypeOccRn` which first looks in the type
+constructor namespace before looking in the data constructor namespace to
+deal with `DataKinds`.
+
+There is however, as always, one exception to this scheme. If we find
+an ambiguous occurence of a record selector and DuplicateRecordFields
+is enabled then we defer the selection until the typechecker.
+
+-}
+
+
+
+
+-- Internal Function
+lookupGreRn_helper :: RdrName -> RnM GreLookupResult
+lookupGreRn_helper rdr_name
+  = do  { env <- getGlobalRdrEnv
+        ; case lookupGRE_RdrName rdr_name env of
+            []    -> return GreNotFound
+            [gre] -> do { addUsedGRE True gre
+                        ; return (OneNameMatch gre) }
+            gres  -> return (MultipleNames gres) }
+
+lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo)
+-- Used in export lists
+-- If not found or ambiguous, add error message, and fake with UnboundName
+-- Uses addUsedRdrName to record use and deprecations
+lookupGreAvailRn rdr_name
+  = do
+      mb_gre <- lookupGreRn_helper rdr_name
+      case mb_gre of
+        GreNotFound ->
+          do
+            traceRn "lookupGreAvailRn" (ppr rdr_name)
+            name <- unboundName WL_Global rdr_name
+            return (name, avail name)
+        MultipleNames gres ->
+          do
+            addNameClashErrRn rdr_name gres
+            let unbound_name = mkUnboundNameRdr rdr_name
+            return (unbound_name, avail unbound_name)
+                        -- Returning an unbound name here prevents an error
+                        -- cascade
+        OneNameMatch gre ->
+          return (gre_name gre, availFromGRE gre)
+
+
+{-
+*********************************************************
+*                                                      *
+                Deprecations
+*                                                      *
+*********************************************************
+
+Note [Handling of deprecations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* We report deprecations at each *occurrence* of the deprecated thing
+  (see Trac #5867)
+
+* We do not report deprecations for locally-defined names. For a
+  start, we may be exporting a deprecated thing. Also we may use a
+  deprecated thing in the defn of another deprecated things.  We may
+  even use a deprecated thing in the defn of a non-deprecated thing,
+  when changing a module's interface.
+
+* addUsedGREs: we do not report deprecations for sub-binders:
+     - the ".." completion for records
+     - the ".." in an export item 'T(..)'
+     - the things exported by a module export 'module M'
+-}
+
+addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM ()
+-- Remember use of in-scope data constructors (Trac #7969)
+addUsedDataCons rdr_env tycon
+  = addUsedGREs [ gre
+                | dc <- tyConDataCons tycon
+                , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ]
+
+addUsedGRE :: Bool -> GlobalRdrElt -> RnM ()
+-- Called for both local and imported things
+-- Add usage *and* warn if deprecated
+addUsedGRE warn_if_deprec gre
+  = do { when warn_if_deprec (warnIfDeprecated gre)
+       ; unless (isLocalGRE gre) $
+         do { env <- getGblEnv
+            ; traceRn "addUsedGRE" (ppr gre)
+            ; updMutVar (tcg_used_gres env) (gre :) } }
+
+addUsedGREs :: [GlobalRdrElt] -> RnM ()
+-- Record uses of any *imported* GREs
+-- Used for recording used sub-bndrs
+-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations]
+addUsedGREs gres
+  | null imp_gres = return ()
+  | otherwise     = do { env <- getGblEnv
+                       ; traceRn "addUsedGREs" (ppr imp_gres)
+                       ; updMutVar (tcg_used_gres env) (imp_gres ++) }
+  where
+    imp_gres = filterOut isLocalGRE gres
+
+warnIfDeprecated :: GlobalRdrElt -> RnM ()
+warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })
+  | (imp_spec : _) <- iss
+  = do { dflags <- getDynFlags
+       ; this_mod <- getModule
+       ; when (wopt Opt_WarnWarningsDeprecations dflags &&
+               not (nameIsLocalOrFrom this_mod name)) $
+                   -- See Note [Handling of deprecations]
+         do { iface <- loadInterfaceForName doc name
+            ; case lookupImpDeprec iface gre of
+                Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations)
+                                   (mk_msg imp_spec txt)
+                Nothing  -> return () } }
+  | otherwise
+  = return ()
+  where
+    occ = greOccName gre
+    name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
+    doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly")
+
+    mk_msg imp_spec txt
+      = sep [ sep [ text "In the use of"
+                    <+> pprNonVarNameSpace (occNameSpace occ)
+                    <+> quotes (ppr occ)
+                  , parens imp_msg <> colon ]
+            , pprWarningTxtForMsg txt ]
+      where
+        imp_mod  = importSpecModule imp_spec
+        imp_msg  = text "imported from" <+> ppr imp_mod <> extra
+        extra | imp_mod == moduleName name_mod = Outputable.empty
+              | otherwise = text ", but defined in" <+> ppr name_mod
+
+lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt
+lookupImpDeprec iface gre
+  = mi_warn_fn iface (greOccName gre) `mplus`  -- Bleat if the thing,
+    case gre_par gre of                      -- or its parent, is warn'd
+       ParentIs  p              -> mi_warn_fn iface (nameOccName p)
+       FldParent { par_is = p } -> mi_warn_fn iface (nameOccName p)
+       NoParent                 -> Nothing
+
+{-
+Note [Used names with interface not loaded]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's (just) possible to find a used
+Name whose interface hasn't been loaded:
+
+a) It might be a WiredInName; in that case we may not load
+   its interface (although we could).
+
+b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger
+   These are seen as "used" by the renamer (if -XRebindableSyntax)
+   is on), but the typechecker may discard their uses
+   if in fact the in-scope fromRational is GHC.Read.fromRational,
+   (see tcPat.tcOverloadedLit), and the typechecker sees that the type
+   is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst).
+   In that obscure case it won't force the interface in.
+
+In both cases we simply don't permit deprecations;
+this is, after all, wired-in stuff.
+
+
+*********************************************************
+*                                                      *
+                GHCi support
+*                                                      *
+*********************************************************
+
+A qualified name on the command line can refer to any module at
+all: we try to load the interface if we don't already have it, just
+as if there was an "import qualified M" declaration for every
+module.
+
+For example, writing `Data.List.sort` will load the interface file for
+`Data.List` as if the user had written `import qualified Data.List`.
+
+If we fail we just return Nothing, rather than bleating
+about "attempting to use module ‘D’ (./D.hs) which is not loaded"
+which is what loadSrcInterface does.
+
+It is enabled by default and disabled by the flag
+`-fno-implicit-import-qualified`.
+
+Note [Safe Haskell and GHCi]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We DON'T do this Safe Haskell as we need to check imports. We can
+and should instead check the qualified import but at the moment
+this requires some refactoring so leave as a TODO
+-}
+
+
+
+lookupQualifiedNameGHCi :: RdrName -> RnM [Name]
+lookupQualifiedNameGHCi rdr_name
+  = -- We want to behave as we would for a source file import here,
+    -- and respect hiddenness of modules/packages, hence loadSrcInterface.
+    do { dflags  <- getDynFlags
+       ; is_ghci <- getIsGHCi
+       ; go_for_it dflags is_ghci }
+
+  where
+    go_for_it dflags is_ghci
+      | Just (mod,occ) <- isQual_maybe rdr_name
+      , is_ghci
+      , gopt Opt_ImplicitImportQualified dflags   -- Enables this GHCi behaviour
+      , not (safeDirectImpsReq dflags)            -- See Note [Safe Haskell and GHCi]
+      = do { res <- loadSrcInterface_maybe doc mod False Nothing
+           ; case res of
+                Succeeded iface
+                  -> return [ name
+                            | avail <- mi_exports iface
+                            , name  <- availNames avail
+                            , nameOccName name == occ ]
+
+                _ -> -- Either we couldn't load the interface, or
+                     -- we could but we didn't find the name in it
+                     do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name)
+                        ; return [] } }
+
+      | otherwise
+      = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name)
+           ; return [] }
+
+    doc = text "Need to find" <+> ppr rdr_name
+
+{-
+Note [Looking up signature names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+lookupSigOccRn is used for type signatures and pragmas
+Is this valid?
+  module A
+        import M( f )
+        f :: Int -> Int
+        f x = x
+It's clear that the 'f' in the signature must refer to A.f
+The Haskell98 report does not stipulate this, but it will!
+So we must treat the 'f' in the signature in the same way
+as the binding occurrence of 'f', using lookupBndrRn
+
+However, consider this case:
+        import M( f )
+        f :: Int -> Int
+        g x = x
+We don't want to say 'f' is out of scope; instead, we want to
+return the imported 'f', so that later on the reanamer will
+correctly report "misplaced type sig".
+
+Note [Signatures for top level things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+data HsSigCtxt = ... | TopSigCtxt NameSet | ....
+
+* The NameSet says what is bound in this group of bindings.
+  We can't use isLocalGRE from the GlobalRdrEnv, because of this:
+       f x = x
+       $( ...some TH splice... )
+       f :: Int -> Int
+  When we encounter the signature for 'f', the binding for 'f'
+  will be in the GlobalRdrEnv, and will be a LocalDef. Yet the
+  signature is mis-placed
+
+* For type signatures the NameSet should be the names bound by the
+  value bindings; for fixity declarations, the NameSet should also
+  include class sigs and record selectors
+
+      infix 3 `f`          -- Yes, ok
+      f :: C a => a -> a   -- No, not ok
+      class C a where
+        f :: a -> a
+-}
+
+data HsSigCtxt
+  = TopSigCtxt NameSet       -- At top level, binding these names
+                             -- See Note [Signatures for top level things]
+  | LocalBindCtxt NameSet    -- In a local binding, binding these names
+  | ClsDeclCtxt   Name       -- Class decl for this class
+  | InstDeclCtxt  NameSet    -- Instance decl whose user-written method
+                             -- bindings are for these methods
+  | HsBootCtxt NameSet       -- Top level of a hs-boot file, binding these names
+  | RoleAnnotCtxt NameSet    -- A role annotation, with the names of all types
+                             -- in the group
+
+instance Outputable HsSigCtxt where
+    ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns
+    ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns
+    ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n
+    ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns
+    ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns
+    ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns
+
+lookupSigOccRn :: HsSigCtxt
+               -> Sig GhcPs
+               -> Located RdrName -> RnM (Located Name)
+lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig)
+
+-- | Lookup a name in relation to the names in a 'HsSigCtxt'
+lookupSigCtxtOccRn :: HsSigCtxt
+                   -> SDoc         -- ^ description of thing we're looking up,
+                                   -- like "type family"
+                   -> Located RdrName -> RnM (Located Name)
+lookupSigCtxtOccRn ctxt what
+  = wrapLocM $ \ rdr_name ->
+    do { mb_name <- lookupBindGroupOcc ctxt what rdr_name
+       ; case mb_name of
+           Left err   -> do { addErr err; return (mkUnboundNameRdr rdr_name) }
+           Right name -> return name }
+
+lookupBindGroupOcc :: HsSigCtxt
+                   -> SDoc
+                   -> RdrName -> RnM (Either MsgDoc Name)
+-- Looks up the RdrName, expecting it to resolve to one of the
+-- bound names passed in.  If not, return an appropriate error message
+--
+-- See Note [Looking up signature names]
+lookupBindGroupOcc ctxt what rdr_name
+  | Just n <- isExact_maybe rdr_name
+  = lookupExactOcc_either n   -- allow for the possibility of missing Exacts;
+                              -- see Note [dataTcOccs and Exact Names]
+      -- Maybe we should check the side conditions
+      -- but it's a pain, and Exact things only show
+      -- up when you know what you are doing
+
+  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+  = do { n' <- lookupOrig rdr_mod rdr_occ
+       ; return (Right n') }
+
+  | otherwise
+  = case ctxt of
+      HsBootCtxt ns    -> lookup_top (`elemNameSet` ns)
+      TopSigCtxt ns    -> lookup_top (`elemNameSet` ns)
+      RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns)
+      LocalBindCtxt ns -> lookup_group ns
+      ClsDeclCtxt  cls -> lookup_cls_op cls
+      InstDeclCtxt ns  -> lookup_top (`elemNameSet` ns)
+  where
+    lookup_cls_op cls
+      = lookupSubBndrOcc True cls doc rdr_name
+      where
+        doc = text "method of class" <+> quotes (ppr cls)
+
+    lookup_top keep_me
+      = do { env <- getGlobalRdrEnv
+           ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
+           ; case filter (keep_me . gre_name) all_gres of
+               [] | null all_gres -> bale_out_with Outputable.empty
+                  | otherwise     -> bale_out_with local_msg
+               (gre:_)            -> return (Right (gre_name gre)) }
+
+    lookup_group bound_names  -- Look in the local envt (not top level)
+      = do { mname <- lookupLocalOccRn_maybe rdr_name
+           ; case mname of
+               Just n
+                 | n `elemNameSet` bound_names -> return (Right n)
+                 | otherwise                   -> bale_out_with local_msg
+               Nothing                         -> bale_out_with Outputable.empty }
+
+    bale_out_with msg
+        = return (Left (sep [ text "The" <+> what
+                                <+> text "for" <+> quotes (ppr rdr_name)
+                           , nest 2 $ text "lacks an accompanying binding"]
+                       $$ nest 2 msg))
+
+    local_msg = parens $ text "The"  <+> what <+> ptext (sLit "must be given where")
+                           <+> quotes (ppr rdr_name) <+> text "is declared"
+
+
+---------------
+lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)]
+-- GHC extension: look up both the tycon and data con or variable.
+-- Used for top-level fixity signatures and deprecations.
+-- Complain if neither is in scope.
+-- See Note [Fixity signature lookup]
+lookupLocalTcNames ctxt what rdr_name
+  = do { mb_gres <- mapM lookup (dataTcOccs rdr_name)
+       ; let (errs, names) = partitionEithers mb_gres
+       ; when (null names) $ addErr (head errs) -- Bleat about one only
+       ; return names }
+  where
+    lookup rdr = do { this_mod <- getModule
+                    ; nameEither <- lookupBindGroupOcc ctxt what rdr
+                    ; return (guard_builtin_syntax this_mod rdr nameEither) }
+
+    -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233
+    guard_builtin_syntax this_mod rdr (Right name)
+      | Just _ <- isBuiltInOcc_maybe (occName rdr)
+      , this_mod /= nameModule name
+      = Left (hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr])
+      | otherwise
+      = Right (rdr, name)
+    guard_builtin_syntax _ _ (Left err) = Left err
+
+dataTcOccs :: RdrName -> [RdrName]
+-- Return both the given name and the same name promoted to the TcClsName
+-- namespace.  This is useful when we aren't sure which we are looking at.
+-- See also Note [dataTcOccs and Exact Names]
+dataTcOccs rdr_name
+  | isDataOcc occ || isVarOcc occ
+  = [rdr_name, rdr_name_tc]
+  | otherwise
+  = [rdr_name]
+  where
+    occ = rdrNameOcc rdr_name
+    rdr_name_tc = setRdrNameSpace rdr_name tcName
+
+{-
+Note [dataTcOccs and Exact Names]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Exact RdrNames can occur in code generated by Template Haskell, and generally
+those references are, well, exact. However, the TH `Name` type isn't expressive
+enough to always track the correct namespace information, so we sometimes get
+the right Unique but wrong namespace. Thus, we still have to do the double-lookup
+for Exact RdrNames.
+
+There is also an awkward situation for built-in syntax. Example in GHCi
+   :info []
+This parses as the Exact RdrName for nilDataCon, but we also want
+the list type constructor.
+
+Note that setRdrNameSpace on an Exact name requires the Name to be External,
+which it always is for built in syntax.
+-}
+
+
+
+{-
+************************************************************************
+*                                                                      *
+                        Rebindable names
+        Dealing with rebindable syntax is driven by the
+        Opt_RebindableSyntax dynamic flag.
+
+        In "deriving" code we don't want to use rebindable syntax
+        so we switch off the flag locally
+
+*                                                                      *
+************************************************************************
+
+Haskell 98 says that when you say "3" you get the "fromInteger" from the
+Standard Prelude, regardless of what is in scope.   However, to experiment
+with having a language that is less coupled to the standard prelude, we're
+trying a non-standard extension that instead gives you whatever "Prelude.fromInteger"
+happens to be in scope.  Then you can
+        import Prelude ()
+        import MyPrelude as Prelude
+to get the desired effect.
+
+At the moment this just happens for
+  * fromInteger, fromRational on literals (in expressions and patterns)
+  * negate (in expressions)
+  * minus  (arising from n+k patterns)
+  * "do" notation
+
+We store the relevant Name in the HsSyn tree, in
+  * HsIntegral/HsFractional/HsIsString
+  * NegApp
+  * NPlusKPat
+  * HsDo
+respectively.  Initially, we just store the "standard" name (PrelNames.fromIntegralName,
+fromRationalName etc), but the renamer changes this to the appropriate user
+name if Opt_NoImplicitPrelude is on.  That is what lookupSyntaxName does.
+
+We treat the original (standard) names as free-vars too, because the type checker
+checks the type of the user thing against the type of the standard thing.
+-}
+
+lookupIfThenElse :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars)
+-- Different to lookupSyntaxName because in the non-rebindable
+-- case we desugar directly rather than calling an existing function
+-- Hence the (Maybe (SyntaxExpr GhcRn)) return type
+lookupIfThenElse
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+       ; if not rebindable_on
+         then return (Nothing, emptyFVs)
+         else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))
+                 ; return ( Just (mkRnSyntaxExpr ite)
+                          , unitFV ite ) } }
+
+lookupSyntaxName' :: Name          -- ^ The standard name
+                  -> RnM Name      -- ^ Possibly a non-standard name
+lookupSyntaxName' std_name
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+       ; if not rebindable_on then
+           return std_name
+         else
+            -- Get the similarly named thing from the local environment
+           lookupOccRn (mkRdrUnqual (nameOccName std_name)) }
+
+lookupSyntaxName :: Name                             -- The standard name
+                 -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard
+                                                     -- name
+lookupSyntaxName std_name
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+       ; if not rebindable_on then
+           return (mkRnSyntaxExpr std_name, emptyFVs)
+         else
+            -- Get the similarly named thing from the local environment
+           do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name))
+              ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } }
+
+lookupSyntaxNames :: [Name]                         -- Standard names
+     -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames
+   -- this works with CmdTop, which wants HsExprs, not SyntaxExprs
+lookupSyntaxNames std_names
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+       ; if not rebindable_on then
+             return (map (HsVar noExt . noLoc) std_names, emptyFVs)
+        else
+          do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names
+             ; return (map (HsVar noExt . noLoc) usr_names, mkFVs usr_names) } }
+
+-- Error messages
+
+
+opDeclErr :: RdrName -> SDoc
+opDeclErr n
+  = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))
+       2 (text "Use TypeOperators to declare operators in type and declarations")
+
+badOrigBinding :: RdrName -> SDoc
+badOrigBinding name
+  | Just _ <- isBuiltInOcc_maybe occ
+  = text "Illegal binding of built-in syntax:" <+> ppr occ
+    -- Use an OccName here because we don't want to print Prelude.(,)
+  | otherwise
+  = text "Cannot redefine a Name retrieved by a Template Haskell quote:"
+    <+> ppr name
+    -- This can happen when one tries to use a Template Haskell splice to
+    -- define a top-level identifier with an already existing name, e.g.,
+    --
+    --   $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []])
+    --
+    -- (See Trac #13968.)
+  where
+    occ = rdrNameOcc $ filterCTuple name
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnExpr.hs
@@ -0,0 +1,2173 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[RnExpr]{Renaming of expressions}
+
+Basically dependency analysis.
+
+Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
+general, all of these functions return a renamed thing, and a set of
+free variables.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module RnExpr (
+        rnLExpr, rnExpr, rnStmts
+   ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
+                   rnMatchGroup, rnGRHS, makeMiniFixityEnv)
+import HsSyn
+import TcEnv            ( isBrackStage )
+import TcRnMonad
+import Module           ( getModule )
+import RnEnv
+import RnFixity
+import RnUtils          ( HsDocContext(..), bindLocalNamesFV, checkDupNames
+                        , bindLocalNames
+                        , mapMaybeFvRn, mapFvRn
+                        , warnUnusedLocalBinds, typeAppErr )
+import RnUnbound        ( reportUnboundName )
+import RnSplice         ( rnBracket, rnSpliceExpr, checkThLocalName )
+import RnTypes
+import RnPat
+import DynFlags
+import PrelNames
+
+import BasicTypes
+import Name
+import NameSet
+import RdrName
+import UniqSet
+import Data.List
+import Util
+import ListSetOps       ( removeDups )
+import ErrUtils
+import Outputable
+import SrcLoc
+import FastString
+import Control.Monad
+import TysWiredIn       ( nilDataConName )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.Ord
+import Data.Array
+import qualified Data.List.NonEmpty as NE
+
+import Unique           ( mkVarOccUnique )
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{Expressions}
+*                                                                      *
+************************************************************************
+-}
+
+rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars)
+rnExprs ls = rnExprs' ls emptyUniqSet
+ where
+  rnExprs' [] acc = return ([], acc)
+  rnExprs' (expr:exprs) acc =
+   do { (expr', fvExpr) <- rnLExpr expr
+        -- Now we do a "seq" on the free vars because typically it's small
+        -- or empty, especially in very long lists of constants
+      ; let  acc' = acc `plusFV` fvExpr
+      ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'
+      ; return (expr':exprs', fvExprs) }
+
+-- Variables. We look up the variable and return the resulting name.
+
+rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
+rnLExpr = wrapLocFstM rnExpr
+
+rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
+
+finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars)
+-- Separated from rnExpr because it's also used
+-- when renaming infix expressions
+finishHsVar (L l name)
+ = do { this_mod <- getModule
+      ; when (nameIsLocalOrFrom this_mod name) $
+        checkThLocalName name
+      ; return (HsVar noExt (L l name), unitFV name) }
+
+rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
+rnUnboundVar v
+ = do { if isUnqual v
+        then -- Treat this as a "hole"
+             -- Do not fail right now; instead, return HsUnboundVar
+             -- and let the type checker report the error
+             do { let occ = rdrNameOcc v
+                ; uv <- if startsWithUnderscore occ
+                        then return (TrueExprHole occ)
+                        else OutOfScope occ <$> getGlobalRdrEnv
+                ; return (HsUnboundVar noExt uv, emptyFVs) }
+
+        else -- Fail immediately (qualified name)
+             do { n <- reportUnboundName v
+                ; return (HsVar noExt (noLoc n), emptyFVs) } }
+
+rnExpr (HsVar _ (L l v))
+  = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields
+       ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
+       ; case mb_name of {
+           Nothing -> rnUnboundVar v ;
+           Just (Left name)
+              | name == nilDataConName -- Treat [] as an ExplicitList, so that
+                                       -- OverloadedLists works correctly
+              -> rnExpr (ExplicitList noExt Nothing [])
+
+              | otherwise
+              -> finishHsVar (L l name) ;
+            Just (Right [s]) ->
+              return ( HsRecFld noExt (Unambiguous s (L l v) ), unitFV s) ;
+           Just (Right fs@(_:_:_)) ->
+              return ( HsRecFld noExt (Ambiguous noExt (L l v))
+                     , mkFVs fs);
+           Just (Right [])         -> panic "runExpr/HsVar" } }
+
+rnExpr (HsIPVar x v)
+  = return (HsIPVar x v, emptyFVs)
+
+rnExpr (HsOverLabel x _ v)
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+       ; if rebindable_on
+         then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))
+                 ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) }
+         else return (HsOverLabel x Nothing v, emptyFVs) }
+
+rnExpr (HsLit x lit@(HsString src s))
+  = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
+       ; if opt_OverloadedStrings then
+            rnExpr (HsOverLit x (mkHsIsString src s))
+         else do {
+            ; rnLit lit
+            ; return (HsLit x (convertLit lit), emptyFVs) } }
+
+rnExpr (HsLit x lit)
+  = do { rnLit lit
+       ; return (HsLit x(convertLit lit), emptyFVs) }
+
+rnExpr (HsOverLit x lit)
+  = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]
+       ; case mb_neg of
+              Nothing -> return (HsOverLit x lit', fvs)
+              Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit'))
+                                 , fvs ) }
+
+rnExpr (HsApp x fun arg)
+  = do { (fun',fvFun) <- rnLExpr fun
+       ; (arg',fvArg) <- rnLExpr arg
+       ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }
+
+rnExpr (HsAppType x fun arg)
+  = do { type_app <- xoptM LangExt.TypeApplications
+       ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg
+       ; (fun',fvFun) <- rnLExpr fun
+       ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
+       ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) }
+
+rnExpr (OpApp _ e1 op e2)
+  = do  { (e1', fv_e1) <- rnLExpr e1
+        ; (e2', fv_e2) <- rnLExpr e2
+        ; (op', fv_op) <- rnLExpr op
+
+        -- Deal with fixity
+        -- When renaming code synthesised from "deriving" declarations
+        -- we used to avoid fixity stuff, but we can't easily tell any
+        -- more, so I've removed the test.  Adding HsPars in TcGenDeriv
+        -- should prevent bad things happening.
+        ; fixity <- case op' of
+              L _ (HsVar _ (L _ n)) -> lookupFixityRn n
+              L _ (HsRecFld _ f)    -> lookupFieldFixityRn f
+              _ -> return (Fixity NoSourceText minPrecedence InfixL)
+                   -- c.f. lookupFixity for unbound
+
+        ; final_e <- mkOpAppRn e1' op' fixity e2'
+        ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
+
+rnExpr (NegApp _ e _)
+  = do { (e', fv_e)         <- rnLExpr e
+       ; (neg_name, fv_neg) <- lookupSyntaxName negateName
+       ; final_e            <- mkNegAppRn e' neg_name
+       ; return (final_e, fv_e `plusFV` fv_neg) }
+
+------------------------------------------
+-- Template Haskell extensions
+-- Don't ifdef-GHCI them because we want to fail gracefully
+-- (not with an rnExpr crash) in a stage-1 compiler.
+rnExpr e@(HsBracket _ br_body) = rnBracket e br_body
+
+rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice
+
+---------------------------------------------
+--      Sections
+-- See Note [Parsing sections] in Parser.y
+rnExpr (HsPar x (L loc (section@(SectionL {}))))
+  = do  { (section', fvs) <- rnSection section
+        ; return (HsPar x (L loc section'), fvs) }
+
+rnExpr (HsPar x (L loc (section@(SectionR {}))))
+  = do  { (section', fvs) <- rnSection section
+        ; return (HsPar x (L loc section'), fvs) }
+
+rnExpr (HsPar x e)
+  = do  { (e', fvs_e) <- rnLExpr e
+        ; return (HsPar x e', fvs_e) }
+
+rnExpr expr@(SectionL {})
+  = do  { addErr (sectionErr expr); rnSection expr }
+rnExpr expr@(SectionR {})
+  = do  { addErr (sectionErr expr); rnSection expr }
+
+---------------------------------------------
+rnExpr (HsCoreAnn x src ann expr)
+  = do { (expr', fvs_expr) <- rnLExpr expr
+       ; return (HsCoreAnn x src ann expr', fvs_expr) }
+
+rnExpr (HsSCC x src lbl expr)
+  = do { (expr', fvs_expr) <- rnLExpr expr
+       ; return (HsSCC x src lbl expr', fvs_expr) }
+rnExpr (HsTickPragma x src info srcInfo expr)
+  = do { (expr', fvs_expr) <- rnLExpr expr
+       ; return (HsTickPragma x src info srcInfo expr', fvs_expr) }
+
+rnExpr (HsLam x matches)
+  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
+       ; return (HsLam x matches', fvMatch) }
+
+rnExpr (HsLamCase x matches)
+  = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
+       ; return (HsLamCase x matches', fvs_ms) }
+
+rnExpr (HsCase x expr matches)
+  = do { (new_expr, e_fvs) <- rnLExpr expr
+       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
+       ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }
+
+rnExpr (HsLet x (L l binds) expr)
+  = rnLocalBindsAndThen binds $ \binds' _ -> do
+      { (expr',fvExpr) <- rnLExpr expr
+      ; return (HsLet x (L l binds') expr', fvExpr) }
+
+rnExpr (HsDo x do_or_lc (L l stmts))
+  = do  { ((stmts', _), fvs) <-
+           rnStmtsWithPostProcessing do_or_lc rnLExpr
+             postProcessStmtsForApplicativeDo stmts
+             (\ _ -> return ((), emptyFVs))
+        ; return ( HsDo x do_or_lc (L l stmts'), fvs ) }
+
+rnExpr (ExplicitList x _  exps)
+  = do  { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
+        ; (exps', fvs) <- rnExprs exps
+        ; if opt_OverloadedLists
+           then do {
+            ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
+            ; return (ExplicitList x (Just from_list_n_name) exps'
+                     , fvs `plusFV` fvs') }
+           else
+            return  (ExplicitList x Nothing exps', fvs) }
+
+rnExpr (ExplicitTuple x tup_args boxity)
+  = do { checkTupleSection tup_args
+       ; checkTupSize (length tup_args)
+       ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
+       ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) }
+  where
+    rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e
+                                      ; return (L l (Present x e'), fvs) }
+    rnTupArg (L l (Missing _)) = return (L l (Missing noExt)
+                                        , emptyFVs)
+    rnTupArg (L _ (XTupArg {})) = panic "rnExpr.XTupArg"
+
+rnExpr (ExplicitSum x alt arity expr)
+  = do { (expr', fvs) <- rnLExpr expr
+       ; return (ExplicitSum x alt arity expr', fvs) }
+
+rnExpr (RecordCon { rcon_con_name = con_id
+                  , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
+  = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id
+       ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
+       ; (flds', fvss) <- mapAndUnzipM rn_field flds
+       ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
+       ; return (RecordCon { rcon_ext = noExt
+                           , rcon_con_name = con_lname, rcon_flds = rec_binds' }
+                , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
+  where
+    mk_hs_var l n = HsVar noExt (L l n)
+    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
+                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
+
+rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
+  = do  { (expr', fvExpr) <- rnLExpr expr
+        ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
+        ; return (RecordUpd { rupd_ext = noExt, rupd_expr = expr'
+                            , rupd_flds = rbinds' }
+                 , fvExpr `plusFV` fvRbinds) }
+
+rnExpr (ExprWithTySig _ expr pty)
+  = do  { (pty', fvTy)    <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty
+        ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
+                             rnLExpr expr
+        ; return (ExprWithTySig noExt expr' pty', fvExpr `plusFV` fvTy) }
+
+rnExpr (HsIf x _ p b1 b2)
+  = do { (p', fvP) <- rnLExpr p
+       ; (b1', fvB1) <- rnLExpr b1
+       ; (b2', fvB2) <- rnLExpr b2
+       ; (mb_ite, fvITE) <- lookupIfThenElse
+       ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
+
+rnExpr (HsMultiIf x alts)
+  = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts
+       -- ; return (HsMultiIf ty alts', fvs) }
+       ; return (HsMultiIf x alts', fvs) }
+
+rnExpr (ArithSeq x _ seq)
+  = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
+       ; (new_seq, fvs) <- rnArithSeq seq
+       ; if opt_OverloadedLists
+           then do {
+            ; (from_list_name, fvs') <- lookupSyntaxName fromListName
+            ; return (ArithSeq x (Just from_list_name) new_seq
+                     , fvs `plusFV` fvs') }
+           else
+            return (ArithSeq x Nothing new_seq, fvs) }
+
+{-
+These three are pattern syntax appearing in expressions.
+Since all the symbols are reservedops we can simply reject them.
+We return a (bogus) EWildPat in each case.
+-}
+
+rnExpr (EWildPat _)  = return (hsHoleExpr, emptyFVs)   -- "_" is just a hole
+rnExpr e@(EAsPat {})
+  = do { opt_TypeApplications <- xoptM LangExt.TypeApplications
+       ; let msg | opt_TypeApplications
+                    = "Type application syntax requires a space before '@'"
+                 | otherwise
+                    = "Did you mean to enable TypeApplications?"
+       ; patSynErr e (text msg)
+       }
+rnExpr e@(EViewPat {}) = patSynErr e empty
+rnExpr e@(ELazyPat {}) = patSynErr e empty
+
+{-
+************************************************************************
+*                                                                      *
+        Static values
+*                                                                      *
+************************************************************************
+
+For the static form we check that it is not used in splices.
+We also collect the free variables of the term which come from
+this module. See Note [Grand plan for static forms] in StaticPtrTable.
+-}
+
+rnExpr e@(HsStatic _ expr) = do
+    -- Normally, you wouldn't be able to construct a static expression without
+    -- first enabling -XStaticPointers in the first place, since that extension
+    -- is what makes the parser treat `static` as a keyword. But this is not a
+    -- sufficient safeguard, as one can construct static expressions by another
+    -- mechanism: Template Haskell (see #14204). To ensure that GHC is
+    -- absolutely prepared to cope with static forms, we check for
+    -- -XStaticPointers here as well.
+    unlessXOptM LangExt.StaticPointers $
+      addErr $ hang (text "Illegal static expression:" <+> ppr e)
+                  2 (text "Use StaticPointers to enable this extension")
+    (expr',fvExpr) <- rnLExpr expr
+    stage <- getStage
+    case stage of
+      Splice _ -> addErr $ sep
+             [ text "static forms cannot be used in splices:"
+             , nest 2 $ ppr e
+             ]
+      _ -> return ()
+    mod <- getModule
+    let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr
+    return (HsStatic fvExpr' expr', fvExpr)
+
+{-
+************************************************************************
+*                                                                      *
+        Arrow notation
+*                                                                      *
+************************************************************************
+-}
+
+rnExpr (HsProc x pat body)
+  = newArrowScope $
+    rnPat ProcExpr pat $ \ pat' -> do
+      { (body',fvBody) <- rnCmdTop body
+      ; return (HsProc x pat' body', fvBody) }
+
+-- Ideally, these would be done in parsing, but to keep parsing simple, we do it here.
+rnExpr e@(HsArrApp {})  = arrowFail e
+rnExpr e@(HsArrForm {}) = arrowFail e
+
+rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
+        -- HsWrap
+
+hsHoleExpr :: HsExpr (GhcPass id)
+hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_"))
+
+arrowFail :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
+arrowFail e
+  = do { addErr (vcat [ text "Arrow command found where an expression was expected:"
+                      , nest 2 (ppr e) ])
+         -- Return a place-holder hole, so that we can carry on
+         -- to report other errors
+       ; return (hsHoleExpr, emptyFVs) }
+
+----------------------
+-- See Note [Parsing sections] in Parser.y
+rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
+rnSection section@(SectionR x op expr)
+  = do  { (op', fvs_op)     <- rnLExpr op
+        ; (expr', fvs_expr) <- rnLExpr expr
+        ; checkSectionPrec InfixR section op' expr'
+        ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) }
+
+rnSection section@(SectionL x expr op)
+  = do  { (expr', fvs_expr) <- rnLExpr expr
+        ; (op', fvs_op)     <- rnLExpr op
+        ; checkSectionPrec InfixL section op' expr'
+        ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) }
+
+rnSection other = pprPanic "rnSection" (ppr other)
+
+{-
+************************************************************************
+*                                                                      *
+        Arrow commands
+*                                                                      *
+************************************************************************
+-}
+
+rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
+rnCmdArgs [] = return ([], emptyFVs)
+rnCmdArgs (arg:args)
+  = do { (arg',fvArg) <- rnCmdTop arg
+       ; (args',fvArgs) <- rnCmdArgs args
+       ; return (arg':args', fvArg `plusFV` fvArgs) }
+
+rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
+rnCmdTop = wrapLocFstM rnCmdTop'
+ where
+  rnCmdTop' (HsCmdTop _ cmd)
+   = do { (cmd', fvCmd) <- rnLCmd cmd
+        ; let cmd_names = [arrAName, composeAName, firstAName] ++
+                          nameSetElemsStable (methodNamesCmd (unLoc cmd'))
+        -- Generate the rebindable syntax for the monad
+        ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names
+
+        ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd',
+                  fvCmd `plusFV` cmd_fvs) }
+  rnCmdTop' (XCmdTop{}) = panic "rnCmdTop"
+
+rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
+rnLCmd = wrapLocFstM rnCmd
+
+rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
+
+rnCmd (HsCmdArrApp x arrow arg ho rtl)
+  = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
+       ; (arg',fvArg) <- rnLExpr arg
+       ; return (HsCmdArrApp x arrow' arg' ho rtl,
+                 fvArrow `plusFV` fvArg) }
+  where
+    select_arrow_scope tc = case ho of
+        HsHigherOrderApp -> tc
+        HsFirstOrderApp  -> escapeArrowScope tc
+        -- See Note [Escaping the arrow scope] in TcRnTypes
+        -- Before renaming 'arrow', use the environment of the enclosing
+        -- proc for the (-<) case.
+        -- Local bindings, inside the enclosing proc, are not in scope
+        -- inside 'arrow'.  In the higher-order case (-<<), they are.
+
+-- infix form
+rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2])
+  = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
+       ; let L _ (HsVar _ (L _ op_name)) = op'
+       ; (arg1',fv_arg1) <- rnCmdTop arg1
+       ; (arg2',fv_arg2) <- rnCmdTop arg2
+        -- Deal with fixity
+       ; fixity <- lookupFixityRn op_name
+       ; final_e <- mkOpFormRn arg1' op' fixity arg2'
+       ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }
+
+rnCmd (HsCmdArrForm x op f fixity cmds)
+  = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)
+       ; (cmds',fvCmds) <- rnCmdArgs cmds
+       ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) }
+
+rnCmd (HsCmdApp x fun arg)
+  = do { (fun',fvFun) <- rnLCmd  fun
+       ; (arg',fvArg) <- rnLExpr arg
+       ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) }
+
+rnCmd (HsCmdLam x matches)
+  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches
+       ; return (HsCmdLam x matches', fvMatch) }
+
+rnCmd (HsCmdPar x e)
+  = do  { (e', fvs_e) <- rnLCmd e
+        ; return (HsCmdPar x e', fvs_e) }
+
+rnCmd (HsCmdCase x expr matches)
+  = do { (new_expr, e_fvs) <- rnLExpr expr
+       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
+       ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }
+
+rnCmd (HsCmdIf x _ p b1 b2)
+  = do { (p', fvP) <- rnLExpr p
+       ; (b1', fvB1) <- rnLCmd b1
+       ; (b2', fvB2) <- rnLCmd b2
+       ; (mb_ite, fvITE) <- lookupIfThenElse
+       ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
+
+rnCmd (HsCmdLet x (L l binds) cmd)
+  = rnLocalBindsAndThen binds $ \ binds' _ -> do
+      { (cmd',fvExpr) <- rnLCmd cmd
+      ; return (HsCmdLet x (L l binds') cmd', fvExpr) }
+
+rnCmd (HsCmdDo x (L l stmts))
+  = do  { ((stmts', _), fvs) <-
+            rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
+        ; return ( HsCmdDo x (L l stmts'), fvs ) }
+
+rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)
+rnCmd cmd@(XCmd {})      = pprPanic "rnCmd" (ppr cmd)
+
+---------------------------------------------------
+type CmdNeeds = FreeVars        -- Only inhabitants are
+                                --      appAName, choiceAName, loopAName
+
+-- find what methods the Cmd needs (loop, choice, apply)
+methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds
+methodNamesLCmd = methodNamesCmd . unLoc
+
+methodNamesCmd :: HsCmd GhcRn -> CmdNeeds
+
+methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl)
+  = emptyFVs
+methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl)
+  = unitFV appAName
+methodNamesCmd (HsCmdArrForm {}) = emptyFVs
+methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd
+
+methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c
+
+methodNamesCmd (HsCmdIf _ _ _ c1 c2)
+  = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
+
+methodNamesCmd (HsCmdLet _ _ c)          = methodNamesLCmd c
+methodNamesCmd (HsCmdDo _ (L _ stmts))   = methodNamesStmts stmts
+methodNamesCmd (HsCmdApp _ c _)          = methodNamesLCmd c
+methodNamesCmd (HsCmdLam _ match)        = methodNamesMatch match
+
+methodNamesCmd (HsCmdCase _ _ matches)
+  = methodNamesMatch matches `addOneFV` choiceAName
+
+methodNamesCmd (XCmd {}) = panic "methodNamesCmd"
+
+--methodNamesCmd _ = emptyFVs
+   -- Other forms can't occur in commands, but it's not convenient
+   -- to error here so we just do what's convenient.
+   -- The type checker will complain later
+
+---------------------------------------------------
+methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
+methodNamesMatch (MG { mg_alts = L _ ms })
+  = plusFVs (map do_one ms)
+ where
+    do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss
+    do_one (L _ (XMatch _)) = panic "methodNamesMatch.XMatch"
+methodNamesMatch (XMatchGroup _) = panic "methodNamesMatch"
+
+-------------------------------------------------
+-- gaw 2004
+methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
+methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)
+methodNamesGRHSs (XGRHSs _) = panic "methodNamesGRHSs"
+
+-------------------------------------------------
+
+methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
+methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs
+methodNamesGRHS (L _ (XGRHS _)) = panic "methodNamesGRHS"
+
+---------------------------------------------------
+methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars
+methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
+
+---------------------------------------------------
+methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars
+methodNamesLStmt = methodNamesStmt . unLoc
+
+methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
+methodNamesStmt (LastStmt _ cmd _ _)           = methodNamesLCmd cmd
+methodNamesStmt (BodyStmt _ cmd _ _)           = methodNamesLCmd cmd
+methodNamesStmt (BindStmt _ _ cmd _ _)         = methodNamesLCmd cmd
+methodNamesStmt (RecStmt { recS_stmts = stmts }) =
+  methodNamesStmts stmts `addOneFV` loopAName
+methodNamesStmt (LetStmt {})                   = emptyFVs
+methodNamesStmt (ParStmt {})                   = emptyFVs
+methodNamesStmt (TransStmt {})                 = emptyFVs
+methodNamesStmt ApplicativeStmt{}              = emptyFVs
+   -- ParStmt and TransStmt can't occur in commands, but it's not
+   -- convenient to error here so we just do what's convenient
+methodNamesStmt (XStmtLR {}) = panic "methodNamesStmt"
+
+{-
+************************************************************************
+*                                                                      *
+        Arithmetic sequences
+*                                                                      *
+************************************************************************
+-}
+
+rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)
+rnArithSeq (From expr)
+ = do { (expr', fvExpr) <- rnLExpr expr
+      ; return (From expr', fvExpr) }
+
+rnArithSeq (FromThen expr1 expr2)
+ = do { (expr1', fvExpr1) <- rnLExpr expr1
+      ; (expr2', fvExpr2) <- rnLExpr expr2
+      ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
+
+rnArithSeq (FromTo expr1 expr2)
+ = do { (expr1', fvExpr1) <- rnLExpr expr1
+      ; (expr2', fvExpr2) <- rnLExpr expr2
+      ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }
+
+rnArithSeq (FromThenTo expr1 expr2 expr3)
+ = do { (expr1', fvExpr1) <- rnLExpr expr1
+      ; (expr2', fvExpr2) <- rnLExpr expr2
+      ; (expr3', fvExpr3) <- rnLExpr expr3
+      ; return (FromThenTo expr1' expr2' expr3',
+                plusFVs [fvExpr1, fvExpr2, fvExpr3]) }
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{@Stmt@s: in @do@ expressions}
+*                                                                      *
+************************************************************************
+-}
+
+{-
+Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Both ApplicativeDo and RecursiveDo need to create tuples not
+present in the source text.
+
+For ApplicativeDo we create:
+
+  (a,b,c) <- (\c b a -> (a,b,c)) <$>
+
+For RecursiveDo we create:
+
+  mfix (\ ~(a,b,c) -> do ...; return (a',b',c'))
+
+The order of the components in those tuples needs to be stable
+across recompilations, otherwise they can get optimized differently
+and we end up with incompatible binaries.
+To get a stable order we use nameSetElemsStable.
+See Note [Deterministic UniqFM] to learn more about nondeterminism.
+-}
+
+-- | Rename some Stmts
+rnStmts :: Outputable (body GhcPs)
+        => HsStmtContext Name
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+           -- ^ How to rename the body of each statement (e.g. rnLExpr)
+        -> [LStmt GhcPs (Located (body GhcPs))]
+           -- ^ Statements
+        -> ([Name] -> RnM (thing, FreeVars))
+           -- ^ if these statements scope over something, this renames it
+           -- and returns the result.
+        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
+rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts
+
+-- | like 'rnStmts' but applies a post-processing step to the renamed Stmts
+rnStmtsWithPostProcessing
+        :: Outputable (body GhcPs)
+        => HsStmtContext Name
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+           -- ^ How to rename the body of each statement (e.g. rnLExpr)
+        -> (HsStmtContext Name
+              -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
+              -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))
+           -- ^ postprocess the statements
+        -> [LStmt GhcPs (Located (body GhcPs))]
+           -- ^ Statements
+        -> ([Name] -> RnM (thing, FreeVars))
+           -- ^ if these statements scope over something, this renames it
+           -- and returns the result.
+        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
+rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside
+ = do { ((stmts', thing), fvs) <-
+          rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
+      ; (pp_stmts, fvs') <- ppStmts ctxt stmts'
+      ; return ((pp_stmts, thing), fvs `plusFV` fvs')
+      }
+
+-- | maybe rearrange statements according to the ApplicativeDo transformation
+postProcessStmtsForApplicativeDo
+  :: HsStmtContext Name
+  -> [(ExprLStmt GhcRn, FreeVars)]
+  -> RnM ([ExprLStmt GhcRn], FreeVars)
+postProcessStmtsForApplicativeDo ctxt stmts
+  = do {
+       -- rearrange the statements using ApplicativeStmt if
+       -- -XApplicativeDo is on.  Also strip out the FreeVars attached
+       -- to each Stmt body.
+         ado_is_on <- xoptM LangExt.ApplicativeDo
+       ; let is_do_expr | DoExpr <- ctxt = True
+                        | otherwise = False
+       -- don't apply the transformation inside TH brackets, because
+       -- DsMeta does not handle ApplicativeDo.
+       ; in_th_bracket <- isBrackStage <$> getStage
+       ; if ado_is_on && is_do_expr && not in_th_bracket
+            then do { traceRn "ppsfa" (ppr stmts)
+                    ; rearrangeForApplicativeDo ctxt stmts }
+            else noPostProcessStmts ctxt stmts }
+
+-- | strip the FreeVars annotations from statements
+noPostProcessStmts
+  :: HsStmtContext Name
+  -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
+  -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)
+noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
+
+
+rnStmtsWithFreeVars :: Outputable (body GhcPs)
+        => HsStmtContext Name
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+        -> [LStmt GhcPs (Located (body GhcPs))]
+        -> ([Name] -> RnM (thing, FreeVars))
+        -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)
+               , FreeVars)
+-- Each Stmt body is annotated with its FreeVars, so that
+-- we can rearrange statements for ApplicativeDo.
+--
+-- Variables bound by the Stmts, and mentioned in thing_inside,
+-- do not appear in the result FreeVars
+
+rnStmtsWithFreeVars ctxt _ [] thing_inside
+  = do { checkEmptyStmts ctxt
+       ; (thing, fvs) <- thing_inside []
+       ; return (([], thing), fvs) }
+
+rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside    -- Deal with mdo
+  = -- Behave like do { rec { ...all but last... }; last }
+    do { ((stmts1, (stmts2, thing)), fvs)
+           <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->
+              do { last_stmt' <- checkLastStmt MDoExpr last_stmt
+                 ; rnStmt MDoExpr rnBody last_stmt' thing_inside }
+        ; return (((stmts1 ++ stmts2), thing), fvs) }
+  where
+    Just (all_but_last, last_stmt) = snocView stmts
+
+rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
+  | null lstmts
+  = setSrcSpan loc $
+    do { lstmt' <- checkLastStmt ctxt lstmt
+       ; rnStmt ctxt rnBody lstmt' thing_inside }
+
+  | otherwise
+  = do { ((stmts1, (stmts2, thing)), fvs)
+            <- setSrcSpan loc                         $
+               do { checkStmt ctxt lstmt
+                  ; rnStmt ctxt rnBody lstmt    $ \ bndrs1 ->
+                    rnStmtsWithFreeVars ctxt rnBody lstmts  $ \ bndrs2 ->
+                    thing_inside (bndrs1 ++ bndrs2) }
+        ; return (((stmts1 ++ stmts2), thing), fvs) }
+
+----------------------
+
+{-
+Note [Failing pattern matches in Stmts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Many things desugar to HsStmts including monadic things like `do` and `mdo`
+statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an
+exhaustive list). How we deal with pattern match failure is context-dependent.
+
+ * In the case of list comprehensions and pattern guards we don't need any 'fail'
+   function; the desugarer ignores the fail function field of 'BindStmt' entirely.
+ * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo
+   expressions) we want pattern match failure to be desugared to the appropriate
+   'fail' function (either that of Monad or MonadFail, depending on whether
+   -XMonadFailDesugaring is enabled.)
+
+At one point we failed to make this distinction, leading to #11216.
+-}
+
+rnStmt :: Outputable (body GhcPs)
+       => HsStmtContext Name
+       -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+          -- ^ How to rename the body of the statement
+       -> LStmt GhcPs (Located (body GhcPs))
+          -- ^ The statement
+       -> ([Name] -> RnM (thing, FreeVars))
+          -- ^ Rename the stuff that this statement scopes over
+       -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)
+              , FreeVars)
+-- Variables bound by the Stmt, and mentioned in thing_inside,
+-- do not appear in the result FreeVars
+
+rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside
+  = do  { (body', fv_expr) <- rnBody body
+        ; (ret_op, fvs1) <- if isMonadCompContext ctxt
+                            then lookupStmtName ctxt returnMName
+                            else return (noSyntaxExpr, emptyFVs)
+                            -- The 'return' in a LastStmt is used only
+                            -- for MonadComp; and we don't want to report
+                            -- "non in scope: return" in other cases
+                            -- Trac #15607
+
+        ; (thing,  fvs3) <- thing_inside []
+        ; return (([(L loc (LastStmt noExt body' noret ret_op), fv_expr)]
+                  , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) }
+
+rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside
+  = do  { (body', fv_expr) <- rnBody body
+        ; (then_op, fvs1)  <- lookupStmtName ctxt thenMName
+
+        ; (guard_op, fvs2) <- if isComprehensionContext ctxt
+                              then lookupStmtName ctxt guardMName
+                              else return (noSyntaxExpr, emptyFVs)
+                              -- Only list/monad comprehensions use 'guard'
+                              -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
+                              -- Here "gd" is a guard
+
+        ; (thing, fvs3)    <- thing_inside []
+        ; return ( ([(L loc (BodyStmt noExt body' then_op guard_op), fv_expr)]
+                  , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
+
+rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside
+  = do  { (body', fv_expr) <- rnBody body
+                -- The binders do not scope over the expression
+        ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
+
+        ; (fail_op, fvs2) <- monadFailOp pat ctxt
+
+        ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
+        { (thing, fvs3) <- thing_inside (collectPatBinders pat')
+        ; return (( [( L loc (BindStmt noExt pat' body' bind_op fail_op)
+                     , fv_expr )]
+                  , thing),
+                  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
+       -- fv_expr shouldn't really be filtered by the rnPatsAndThen
+        -- but it does not matter because the names are unique
+
+rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside
+  = do  { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
+        { (thing, fvs) <- thing_inside (collectLocalBinders binds')
+        ; return ( ([(L loc (LetStmt noExt (L l binds')), bind_fvs)], thing)
+                 , fvs) }  }
+
+rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
+  = do  { (return_op, fvs1)  <- lookupStmtName ctxt returnMName
+        ; (mfix_op,   fvs2)  <- lookupStmtName ctxt mfixName
+        ; (bind_op,   fvs3)  <- lookupStmtName ctxt bindMName
+        ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn  = return_op
+                                                , recS_mfix_fn = mfix_op
+                                                , recS_bind_fn = bind_op }
+
+        -- Step1: Bring all the binders of the mdo into scope
+        -- (Remember that this also removes the binders from the
+        -- finally-returned free-vars.)
+        -- And rename each individual stmt, making a
+        -- singleton segment.  At this stage the FwdRefs field
+        -- isn't finished: it's empty for all except a BindStmt
+        -- for which it's the fwd refs within the bind itself
+        -- (This set may not be empty, because we're in a recursive
+        -- context.)
+        ; rnRecStmtsAndThen rnBody rec_stmts   $ \ segs -> do
+        { let bndrs = nameSetElemsStable $
+                        foldr (unionNameSet . (\(ds,_,_,_) -> ds))
+                              emptyNameSet
+                              segs
+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
+        ; (thing, fvs_later) <- thing_inside bndrs
+        ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
+        -- We aren't going to try to group RecStmts with
+        -- ApplicativeDo, so attaching empty FVs is fine.
+        ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)
+                 , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
+
+rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside
+  = do  { (mzip_op, fvs1)   <- lookupStmtNamePoly ctxt mzipName
+        ; (bind_op, fvs2)   <- lookupStmtName ctxt bindMName
+        ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
+        ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
+        ; return (([(L loc (ParStmt noExt segs' mzip_op bind_op), fvs4)], thing)
+                 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
+
+rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
+                              , trS_using = using })) thing_inside
+  = do { -- Rename the 'using' expression in the context before the transform is begun
+         (using', fvs1) <- rnLExpr using
+
+         -- Rename the stmts and the 'by' expression
+         -- Keep track of the variables mentioned in the 'by' expression
+       ; ((stmts', (by', used_bndrs, thing)), fvs2)
+             <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs ->
+                do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by
+                   ; (thing, fvs_thing) <- thing_inside bndrs
+                   ; let fvs = fvs_by `plusFV` fvs_thing
+                         used_bndrs = filter (`elemNameSet` fvs) bndrs
+                         -- The paper (Fig 5) has a bug here; we must treat any free variable
+                         -- of the "thing inside", **or of the by-expression**, as used
+                   ; return ((by', used_bndrs, thing), fvs) }
+
+       -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions
+       ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
+       ; (bind_op,   fvs4) <- lookupStmtName ctxt bindMName
+       ; (fmap_op,   fvs5) <- case form of
+                                ThenForm -> return (noExpr, emptyFVs)
+                                _        -> lookupStmtNamePoly ctxt fmapName
+
+       ; let all_fvs  = fvs1 `plusFV` fvs2 `plusFV` fvs3
+                             `plusFV` fvs4 `plusFV` fvs5
+             bndr_map = used_bndrs `zip` used_bndrs
+             -- See Note [TransStmt binder map] in HsExpr
+
+       ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)
+       ; return (([(L loc (TransStmt { trS_ext = noExt
+                                    , trS_stmts = stmts', trS_bndrs = bndr_map
+                                    , trS_by = by', trS_using = using', trS_form = form
+                                    , trS_ret = return_op, trS_bind = bind_op
+                                    , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
+
+rnStmt _ _ (L _ ApplicativeStmt{}) _ =
+  panic "rnStmt: ApplicativeStmt"
+
+rnStmt _ _ (L _ XStmtLR{}) _ =
+  panic "rnStmt: XStmtLR"
+
+rnParallelStmts :: forall thing. HsStmtContext Name
+                -> SyntaxExpr GhcRn
+                -> [ParStmtBlock GhcPs GhcPs]
+                -> ([Name] -> RnM (thing, FreeVars))
+                -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
+-- Note [Renaming parallel Stmts]
+rnParallelStmts ctxt return_op segs thing_inside
+  = do { orig_lcl_env <- getLocalRdrEnv
+       ; rn_segs orig_lcl_env [] segs }
+  where
+    rn_segs :: LocalRdrEnv
+            -> [Name] -> [ParStmtBlock GhcPs GhcPs]
+            -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
+    rn_segs _ bndrs_so_far []
+      = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
+           ; mapM_ dupErr dups
+           ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
+           ; return (([], thing), fvs) }
+
+    rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs)
+      = do { ((stmts', (used_bndrs, segs', thing)), fvs)
+                    <- rnStmts ctxt rnLExpr stmts $ \ bndrs ->
+                       setLocalRdrEnv env       $ do
+                       { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
+                       ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
+                       ; return ((used_bndrs, segs', thing), fvs) }
+
+           ; let seg' = ParStmtBlock x stmts' used_bndrs return_op
+           ; return ((seg':segs', thing), fvs) }
+    rn_segs _ _ (XParStmtBlock{}:_) = panic "rnParallelStmts"
+
+    cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
+    dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
+                    <+> quotes (ppr (NE.head vs)))
+
+lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
+-- Like lookupSyntaxName, but respects contexts
+lookupStmtName ctxt n
+  | rebindableContext ctxt
+  = lookupSyntaxName n
+  | otherwise
+  = return (mkRnSyntaxExpr n, emptyFVs)
+
+lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars)
+lookupStmtNamePoly ctxt name
+  | rebindableContext ctxt
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+       ; if rebindable_on
+         then do { fm <- lookupOccRn (nameRdrName name)
+                 ; return (HsVar noExt (noLoc fm), unitFV fm) }
+         else not_rebindable }
+  | otherwise
+  = not_rebindable
+  where
+    not_rebindable = return (HsVar noExt (noLoc name), emptyFVs)
+
+-- | Is this a context where we respect RebindableSyntax?
+-- but ListComp are never rebindable
+-- Neither is ArrowExpr, which has its own desugarer in DsArrows
+rebindableContext :: HsStmtContext Name -> Bool
+rebindableContext ctxt = case ctxt of
+  ListComp        -> False
+  ArrowExpr       -> False
+  PatGuard {}     -> False
+
+  DoExpr          -> True
+  MDoExpr         -> True
+  MonadComp       -> True
+  GhciStmtCtxt    -> True   -- I suppose?
+
+  ParStmtCtxt   c -> rebindableContext c     -- Look inside to
+  TransStmtCtxt c -> rebindableContext c     -- the parent context
+
+{-
+Note [Renaming parallel Stmts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Renaming parallel statements is painful.  Given, say
+     [ a+c | a <- as, bs <- bss
+           | c <- bs, a <- ds ]
+Note that
+  (a) In order to report "Defined but not used" about 'bs', we must
+      rename each group of Stmts with a thing_inside whose FreeVars
+      include at least {a,c}
+
+  (b) We want to report that 'a' is illegally bound in both branches
+
+  (c) The 'bs' in the second group must obviously not be captured by
+      the binding in the first group
+
+To satisfy (a) we nest the segements.
+To satisfy (b) we check for duplicates just before thing_inside.
+To satisfy (c) we reset the LocalRdrEnv each time.
+
+************************************************************************
+*                                                                      *
+\subsubsection{mdo expressions}
+*                                                                      *
+************************************************************************
+-}
+
+type FwdRefs = NameSet
+type Segment stmts = (Defs,
+                      Uses,     -- May include defs
+                      FwdRefs,  -- A subset of uses that are
+                                --   (a) used before they are bound in this segment, or
+                                --   (b) used here, and bound in subsequent segments
+                      stmts)    -- Either Stmt or [Stmt]
+
+
+-- wrapper that does both the left- and right-hand sides
+rnRecStmtsAndThen :: Outputable (body GhcPs) =>
+                     (Located (body GhcPs)
+                  -> RnM (Located (body GhcRn), FreeVars))
+                  -> [LStmt GhcPs (Located (body GhcPs))]
+                         -- assumes that the FreeVars returned includes
+                         -- the FreeVars of the Segments
+                  -> ([Segment (LStmt GhcRn (Located (body GhcRn)))]
+                      -> RnM (a, FreeVars))
+                  -> RnM (a, FreeVars)
+rnRecStmtsAndThen rnBody s cont
+  = do  { -- (A) Make the mini fixity env for all of the stmts
+          fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
+
+          -- (B) Do the LHSes
+        ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
+
+          --    ...bring them and their fixities into scope
+        ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
+              -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
+              implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
+        ; bindLocalNamesFV bound_names $
+          addLocalFixities fix_env bound_names $ do
+
+          -- (C) do the right-hand-sides and thing-inside
+        { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv
+        ; (res, fvs) <- cont segs
+        ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)
+        ; return (res, fvs) }}
+
+-- get all the fixity decls in any Let stmt
+collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
+collectRecStmtsFixities l =
+    foldr (\ s -> \acc -> case s of
+            (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) ->
+              foldr (\ sig -> \ acc -> case sig of
+                                         (L loc (FixSig _ s)) -> (L loc s) : acc
+                                         _ -> acc) acc sigs
+            _ -> acc) [] l
+
+-- left-hand sides
+
+rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv
+                -> LStmt GhcPs body
+                   -- rename LHS, and return its FVs
+                   -- Warning: we will only need the FreeVars below in the case of a BindStmt,
+                   -- so we don't bother to compute it accurately in the other cases
+                -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
+
+rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))
+  = return [(L loc (BodyStmt noExt body a b), emptyFVs)]
+
+rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))
+  = return [(L loc (LastStmt noExt body noret a), emptyFVs)]
+
+rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b))
+  = do
+      -- should the ctxt be MDo instead?
+      (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
+      return [(L loc (BindStmt noExt pat' body a b), fv_pat)]
+
+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))))
+  = failWith (badIpBinds (text "an mdo expression") binds)
+
+rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds))))
+    = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
+         return [(L loc (LetStmt noExt (L l (HsValBinds x binds'))),
+                 -- Warning: this is bogus; see function invariant
+                 emptyFVs
+                 )]
+
+-- XXX Do we need to do something with the return and mfix names?
+rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))  -- Flatten Rec inside Rec
+    = rn_rec_stmts_lhs fix_env stmts
+
+rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {}))       -- Syntactically illegal in mdo
+  = pprPanic "rn_rec_stmt" (ppr stmt)
+
+rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))     -- Syntactically illegal in mdo
+  = pprPanic "rn_rec_stmt" (ppr stmt)
+
+rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
+  = pprPanic "rn_rec_stmt" (ppr stmt)
+
+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))))
+  = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))))
+  = panic "rn_rec_stmt LetStmt XHsLocalBindsLR"
+rn_rec_stmt_lhs _ (L _ (XStmtLR _))
+  = panic "rn_rec_stmt XStmtLR"
+
+rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
+                 -> [LStmt GhcPs body]
+                 -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
+rn_rec_stmts_lhs fix_env stmts
+  = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
+       ; let boundNames = collectLStmtsBinders (map fst ls)
+            -- First do error checking: we need to check for dups here because we
+            -- don't bind all of the variables from the Stmt at once
+            -- with bindLocatedLocals.
+       ; checkDupNames boundNames
+       ; return ls }
+
+
+-- right-hand-sides
+
+rn_rec_stmt :: (Outputable (body GhcPs)) =>
+               (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+            -> [Name]
+            -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
+            -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
+        -- Rename a Stmt that is inside a RecStmt (or mdo)
+        -- Assumes all binders are already in scope
+        -- Turns each stmt into a singleton Stmt
+rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _)
+  = do  { (body', fv_expr) <- rnBody body
+        ; (ret_op, fvs1)   <- lookupSyntaxName returnMName
+        ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
+                   L loc (LastStmt noExt body' noret ret_op))] }
+
+rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _)
+  = do { (body', fvs) <- rnBody body
+       ; (then_op, fvs1) <- lookupSyntaxName thenMName
+       ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
+                 L loc (BodyStmt noExt body' then_op noSyntaxExpr))] }
+
+rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)
+  = do { (body', fv_expr) <- rnBody body
+       ; (bind_op, fvs1) <- lookupSyntaxName bindMName
+
+       ; (fail_op, fvs2) <- getMonadFailOp
+
+       ; let bndrs = mkNameSet (collectPatBinders pat')
+             fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
+       ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
+                  L loc (BindStmt noExt pat' body' bind_op fail_op))] }
+
+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)
+  = failWith (badIpBinds (text "an mdo expression") binds)
+
+rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _)
+  = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
+           -- fixities and unused are handled above in rnRecStmtsAndThen
+       ; let fvs = allUses du_binds
+       ; return [(duDefs du_binds, fvs, emptyNameSet,
+                 L loc (LetStmt noExt (L l (HsValBinds x binds'))))] }
+
+-- no RecStmt case because they get flattened above when doing the LHSes
+rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)
+  = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
+
+rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _)       -- Syntactically illegal in mdo
+  = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
+
+rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _)     -- Syntactically illegal in mdo
+  = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
+
+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))), _)
+  = panic "rn_rec_stmt: LetStmt XHsLocalBindsLR"
+
+rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _)
+  = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
+
+rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)
+  = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
+
+rn_rec_stmt _ _ stmt@(L _ (XStmtLR {}), _)
+  = pprPanic "rn_rec_stmt: XStmtLR" (ppr stmt)
+
+rn_rec_stmts :: Outputable (body GhcPs) =>
+                (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+             -> [Name]
+             -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
+             -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
+rn_rec_stmts rnBody bndrs stmts
+  = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts
+       ; return (concat segs_s) }
+
+---------------------------------------------
+segmentRecStmts :: SrcSpan -> HsStmtContext Name
+                -> Stmt GhcRn body
+                -> [Segment (LStmt GhcRn body)] -> FreeVars
+                -> ([LStmt GhcRn body], FreeVars)
+
+segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
+  | null segs
+  = ([], fvs_later)
+
+  | MDoExpr <- ctxt
+  = segsToStmts empty_rec_stmt grouped_segs fvs_later
+               -- Step 4: Turn the segments into Stmts
+                --         Use RecStmt when and only when there are fwd refs
+                --         Also gather up the uses from the end towards the
+                --         start, so we can tell the RecStmt which things are
+                --         used 'after' the RecStmt
+
+  | otherwise
+  = ([ L loc $
+       empty_rec_stmt { recS_stmts = ss
+                      , recS_later_ids = nameSetElemsStable
+                                           (defs `intersectNameSet` fvs_later)
+                      , recS_rec_ids   = nameSetElemsStable
+                                           (defs `intersectNameSet` uses) }]
+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
+    , uses `plusFV` fvs_later)
+
+  where
+    (defs_s, uses_s, _, ss) = unzip4 segs
+    defs = plusFVs defs_s
+    uses = plusFVs uses_s
+
+                -- Step 2: Fill in the fwd refs.
+                --         The segments are all singletons, but their fwd-ref
+                --         field mentions all the things used by the segment
+                --         that are bound after their use
+    segs_w_fwd_refs = addFwdRefs segs
+
+                -- Step 3: Group together the segments to make bigger segments
+                --         Invariant: in the result, no segment uses a variable
+                --                    bound in a later segment
+    grouped_segs = glomSegments ctxt segs_w_fwd_refs
+
+----------------------------
+addFwdRefs :: [Segment a] -> [Segment a]
+-- So far the segments only have forward refs *within* the Stmt
+--      (which happens for bind:  x <- ...x...)
+-- This function adds the cross-seg fwd ref info
+
+addFwdRefs segs
+  = fst (foldr mk_seg ([], emptyNameSet) segs)
+  where
+    mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
+        = (new_seg : segs, all_defs)
+        where
+          new_seg = (defs, uses, new_fwds, stmts)
+          all_defs = later_defs `unionNameSet` defs
+          new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)
+                -- Add the downstream fwd refs here
+
+{-
+Note [Segmenting mdo]
+~~~~~~~~~~~~~~~~~~~~~
+NB. June 7 2012: We only glom segments that appear in an explicit mdo;
+and leave those found in "do rec"'s intact.  See
+http://ghc.haskell.org/trac/ghc/ticket/4148 for the discussion
+leading to this design choice.  Hence the test in segmentRecStmts.
+
+Note [Glomming segments]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Glomming the singleton segments of an mdo into minimal recursive groups.
+
+At first I thought this was just strongly connected components, but
+there's an important constraint: the order of the stmts must not change.
+
+Consider
+     mdo { x <- ...y...
+           p <- z
+           y <- ...x...
+           q <- x
+           z <- y
+           r <- x }
+
+Here, the first stmt mention 'y', which is bound in the third.
+But that means that the innocent second stmt (p <- z) gets caught
+up in the recursion.  And that in turn means that the binding for
+'z' has to be included... and so on.
+
+Start at the tail { r <- x }
+Now add the next one { z <- y ; r <- x }
+Now add one more     { q <- x ; z <- y ; r <- x }
+Now one more... but this time we have to group a bunch into rec
+     { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
+Now one more, which we can add on without a rec
+     { p <- z ;
+       rec { y <- ...x... ; q <- x ; z <- y } ;
+       r <- x }
+Finally we add the last one; since it mentions y we have to
+glom it together with the first two groups
+     { rec { x <- ...y...; p <- z ; y <- ...x... ;
+             q <- x ; z <- y } ;
+       r <- x }
+-}
+
+glomSegments :: HsStmtContext Name
+             -> [Segment (LStmt GhcRn body)]
+             -> [Segment [LStmt GhcRn body]]
+                                  -- Each segment has a non-empty list of Stmts
+-- See Note [Glomming segments]
+
+glomSegments _ [] = []
+glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
+        -- Actually stmts will always be a singleton
+  = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
+  where
+    segs'            = glomSegments ctxt segs
+    (extras, others) = grab uses segs'
+    (ds, us, fs, ss) = unzip4 extras
+
+    seg_defs  = plusFVs ds `plusFV` defs
+    seg_uses  = plusFVs us `plusFV` uses
+    seg_fwds  = plusFVs fs `plusFV` fwds
+    seg_stmts = stmt : concat ss
+
+    grab :: NameSet             -- The client
+         -> [Segment a]
+         -> ([Segment a],       -- Needed by the 'client'
+             [Segment a])       -- Not needed by the client
+        -- The result is simply a split of the input
+    grab uses dus
+        = (reverse yeses, reverse noes)
+        where
+          (noes, yeses)           = span not_needed (reverse dus)
+          not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
+
+----------------------------------------------------
+segsToStmts :: Stmt GhcRn body
+                                  -- A RecStmt with the SyntaxOps filled in
+            -> [Segment [LStmt GhcRn body]]
+                                  -- Each Segment has a non-empty list of Stmts
+            -> FreeVars           -- Free vars used 'later'
+            -> ([LStmt GhcRn body], FreeVars)
+
+segsToStmts _ [] fvs_later = ([], fvs_later)
+segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
+  = ASSERT( not (null ss) )
+    (new_stmt : later_stmts, later_uses `plusFV` uses)
+  where
+    (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
+    new_stmt | non_rec   = head ss
+             | otherwise = cL (getLoc (head ss)) rec_stmt
+    rec_stmt = empty_rec_stmt { recS_stmts     = ss
+                              , recS_later_ids = nameSetElemsStable used_later
+                              , recS_rec_ids   = nameSetElemsStable fwds }
+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
+    non_rec    = isSingleton ss && isEmptyNameSet fwds
+    used_later = defs `intersectNameSet` later_uses
+                                -- The ones needed after the RecStmt
+
+{-
+************************************************************************
+*                                                                      *
+ApplicativeDo
+*                                                                      *
+************************************************************************
+
+Note [ApplicativeDo]
+
+= Example =
+
+For a sequence of statements
+
+ do
+     x <- A
+     y <- B x
+     z <- C
+     return (f x y z)
+
+We want to transform this to
+
+  (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C
+
+It would be easy to notice that "y <- B x" and "z <- C" are
+independent and do something like this:
+
+ do
+     x <- A
+     (y,z) <- (,) <$> B x <*> C
+     return (f x y z)
+
+But this isn't enough! A and C were also independent, and this
+transformation loses the ability to do A and C in parallel.
+
+The algorithm works by first splitting the sequence of statements into
+independent "segments", and a separate "tail" (the final statement). In
+our example above, the segements would be
+
+     [ x <- A
+     , y <- B x ]
+
+     [ z <- C ]
+
+and the tail is:
+
+     return (f x y z)
+
+Then we take these segments and make an Applicative expression from them:
+
+     (\(x,y) z -> return (f x y z))
+       <$> do { x <- A; y <- B x; return (x,y) }
+       <*> C
+
+Finally, we recursively apply the transformation to each segment, to
+discover any nested parallelism.
+
+= Syntax & spec =
+
+  expr ::= ... | do {stmt_1; ..; stmt_n} expr | ...
+
+  stmt ::= pat <- expr
+         | (arg_1 | ... | arg_n)  -- applicative composition, n>=1
+         | ...                    -- other kinds of statement (e.g. let)
+
+  arg ::= pat <- expr
+        | {stmt_1; ..; stmt_n} {var_1..var_n}
+
+(note that in the actual implementation,the expr in a do statement is
+represented by a LastStmt as the final stmt, this is just a
+representational issue and may change later.)
+
+== Transformation to introduce applicative stmts ==
+
+ado {} tail = tail
+ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr'
+ado {one} tail = one : tail
+ado stmts tail
+  | n == 1 = ado before (ado after tail)
+    where (before,after) = split(stmts_1)
+  | n > 1  = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail
+  where
+    {stmts_1 .. stmts_n} = segments(stmts)
+
+segments(stmts) =
+  -- divide stmts into segments with no interdependencies
+
+mkArg({pat <- expr}) = (pat <- expr)
+mkArg({stmt_1; ...; stmt_n}) =
+  {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)}
+
+split({stmt_1; ..; stmt_n) =
+  ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n})
+  -- 1 <= i <= n
+  -- i is a good place to insert a bind
+
+== Desugaring for do ==
+
+dsDo {} expr = expr
+
+dsDo {pat <- rhs; stmts} expr =
+   rhs >>= \pat -> dsDo stmts expr
+
+dsDo {(arg_1 | ... | arg_n)} (return expr) =
+  (\argpat (arg_1) .. argpat(arg_n) -> expr)
+     <$> argexpr(arg_1)
+     <*> ...
+     <*> argexpr(arg_n)
+
+dsDo {(arg_1 | ... | arg_n); stmts} expr =
+  join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr)
+     <$> argexpr(arg_1)
+     <*> ...
+     <*> argexpr(arg_n)
+
+-}
+
+-- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and
+-- 'pureName' due to @RebindableSyntax@.
+data MonadNames = MonadNames { return_name, pure_name :: Name }
+
+-- | rearrange a list of statements using ApplicativeDoStmt.  See
+-- Note [ApplicativeDo].
+rearrangeForApplicativeDo
+  :: HsStmtContext Name
+  -> [(ExprLStmt GhcRn, FreeVars)]
+  -> RnM ([ExprLStmt GhcRn], FreeVars)
+
+rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)
+rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet)
+rearrangeForApplicativeDo ctxt stmts0 = do
+  optimal_ado <- goptM Opt_OptimalApplicativeDo
+  let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
+                | otherwise = mkStmtTreeHeuristic stmts
+  traceRn "rearrangeForADo" (ppr stmt_tree)
+  return_name <- lookupSyntaxName' returnMName
+  pure_name   <- lookupSyntaxName' pureAName
+  let monad_names = MonadNames { return_name = return_name
+                               , pure_name   = pure_name }
+  stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs
+  where
+    (stmts,(last,last_fvs)) = findLast stmts0
+    findLast [] = error "findLast"
+    findLast [last] = ([],last)
+    findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs
+
+-- | A tree of statements using a mixture of applicative and bind constructs.
+data StmtTree a
+  = StmtTreeOne a
+  | StmtTreeBind (StmtTree a) (StmtTree a)
+  | StmtTreeApplicative [StmtTree a]
+
+instance Outputable a => Outputable (StmtTree a) where
+  ppr (StmtTreeOne x)          = parens (text "StmtTreeOne" <+> ppr x)
+  ppr (StmtTreeBind x y)       = parens (hang (text "StmtTreeBind")
+                                            2 (sep [ppr x, ppr y]))
+  ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative")
+                                            2 (vcat (map ppr xs)))
+
+flattenStmtTree :: StmtTree a -> [a]
+flattenStmtTree t = go t []
+ where
+  go (StmtTreeOne a) as = a : as
+  go (StmtTreeBind l r) as = go l (go r as)
+  go (StmtTreeApplicative ts) as = foldr go as ts
+
+type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars)
+type Cost = Int
+
+-- | Turn a sequence of statements into an ExprStmtTree using a
+-- heuristic algorithm.  /O(n^2)/
+mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
+mkStmtTreeHeuristic [one] = StmtTreeOne one
+mkStmtTreeHeuristic stmts =
+  case segments stmts of
+    [one] -> split one
+    segs -> StmtTreeApplicative (map split segs)
+ where
+  split [one] = StmtTreeOne one
+  split stmts =
+    StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after)
+    where (before, after) = splitSegment stmts
+
+-- | Turn a sequence of statements into an ExprStmtTree optimally,
+-- using dynamic programming.  /O(n^3)/
+mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
+mkStmtTreeOptimal stmts =
+  ASSERT(not (null stmts)) -- the empty case is handled by the caller;
+                           -- we don't support empty StmtTrees.
+  fst (arr ! (0,n))
+  where
+    n = length stmts - 1
+    stmt_arr = listArray (0,n) stmts
+
+    -- lazy cache of optimal trees for subsequences of the input
+    arr :: Array (Int,Int) (ExprStmtTree, Cost)
+    arr = array ((0,0),(n,n))
+             [ ((lo,hi), tree lo hi)
+             | lo <- [0..n]
+             , hi <- [lo..n] ]
+
+    -- compute the optimal tree for the sequence [lo..hi]
+    tree lo hi
+      | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
+      | otherwise =
+         case segments [ stmt_arr ! i | i <- [lo..hi] ] of
+           [] -> panic "mkStmtTree"
+           [_one] -> split lo hi
+           segs -> (StmtTreeApplicative trees, maximum costs)
+             where
+               bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs
+               (trees,costs) = unzip (map (uncurry split) (tail bounds))
+
+    -- find the best place to split the segment [lo..hi]
+    split :: Int -> Int -> (ExprStmtTree, Cost)
+    split lo hi
+      | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)
+      | otherwise = (StmtTreeBind before after, c1+c2)
+        where
+         -- As per the paper, for a sequence s1...sn, we want to find
+         -- the split with the minimum cost, where the cost is the
+         -- sum of the cost of the left and right subsequences.
+         --
+         -- As an optimisation (also in the paper) if the cost of
+         -- s1..s(n-1) is different from the cost of s2..sn, we know
+         -- that the optimal solution is the lower of the two.  Only
+         -- in the case that these two have the same cost do we need
+         -- to do the exhaustive search.
+         --
+         ((before,c1),(after,c2))
+           | hi - lo == 1
+           = ((StmtTreeOne (stmt_arr ! lo), 1),
+              (StmtTreeOne (stmt_arr ! hi), 1))
+           | left_cost < right_cost
+           = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))
+           | left_cost > right_cost
+           = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))
+           | otherwise = minimumBy (comparing cost) alternatives
+           where
+             (left, left_cost) = arr ! (lo,hi-1)
+             (right, right_cost) = arr ! (lo+1,hi)
+             cost ((_,c1),(_,c2)) = c1 + c2
+             alternatives = [ (arr ! (lo,k), arr ! (k+1,hi))
+                            | k <- [lo .. hi-1] ]
+
+
+-- | Turn the ExprStmtTree back into a sequence of statements, using
+-- ApplicativeStmt where necessary.
+stmtTreeToStmts
+  :: MonadNames
+  -> HsStmtContext Name
+  -> ExprStmtTree
+  -> [ExprLStmt GhcRn]             -- ^ the "tail"
+  -> FreeVars                     -- ^ free variables of the tail
+  -> RnM ( [ExprLStmt GhcRn]       -- ( output statements,
+         , FreeVars )             -- , things we needed
+
+-- If we have a single bind, and we can do it without a join, transform
+-- to an ApplicativeStmt.  This corresponds to the rule
+--   dsBlock [pat <- rhs] (return expr) = expr <$> rhs
+-- In the spec, but we do it here rather than in the desugarer,
+-- because we need the typechecker to typecheck the <$> form rather than
+-- the bind form, which would give rise to a Monad constraint.
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ _), _))
+                tail _tail_fvs
+  | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail
+  -- See Note [ApplicativeDo and strict patterns]
+  = mkApplicativeStmt ctxt [ApplicativeArgOne noExt pat rhs False] False tail'
+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))
+                tail _tail_fvs
+  | (False,tail') <- needJoin monad_names tail
+  = mkApplicativeStmt ctxt
+      [ApplicativeArgOne noExt nlWildPatName rhs True] False tail'
+
+stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
+  return (s : tail, emptyNameSet)
+
+stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do
+  (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs
+  let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after))
+  (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs
+  return (stmts2, fvs1 `plusFV` fvs2)
+
+stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
+   pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees
+   let (stmts', fvss) = unzip pairs
+   let (need_join, tail') = needJoin monad_names tail
+   (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
+   return (stmts, unionNameSets (fvs:fvss))
+ where
+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ _), _))
+     = return (ApplicativeArgOne noExt pat exp False, emptyFVs)
+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =
+     return (ApplicativeArgOne noExt nlWildPatName exp True, emptyFVs)
+   stmtTreeArg ctxt tail_fvs tree = do
+     let stmts = flattenStmtTree tree
+         pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
+                     `intersectNameSet` tail_fvs
+         pvars = nameSetElemsStable pvarset
+           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
+         pat = mkBigLHsVarPatTup pvars
+         tup = mkBigLHsVarTup pvars
+     (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset
+     (mb_ret, fvs1) <-
+        if | L _ ApplicativeStmt{} <- last stmts' ->
+             return (unLoc tup, emptyNameSet)
+           | otherwise -> do
+             (ret,fvs) <- lookupStmtNamePoly ctxt returnMName
+             return (HsApp noExt (noLoc ret) tup, fvs)
+     return ( ApplicativeArgMany noExt stmts' mb_ret pat
+            , fvs1 `plusFV` fvs2)
+
+
+-- | Divide a sequence of statements into segments, where no segment
+-- depends on any variables defined by a statement in another segment.
+segments
+  :: [(ExprLStmt GhcRn, FreeVars)]
+  -> [[(ExprLStmt GhcRn, FreeVars)]]
+segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
+  where
+    allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
+
+    -- We would rather not have a segment that just has LetStmts in
+    -- it, so combine those with an adjacent segment where possible.
+    merge [] = []
+    merge (seg : segs)
+       = case rest of
+          [] -> [(seg,all_lets)]
+          ((s,s_lets):ss) | all_lets || s_lets
+               -> (seg ++ s, all_lets && s_lets) : ss
+          _otherwise -> (seg,all_lets) : rest
+      where
+        rest = merge segs
+        all_lets = all (isLetStmt . fst) seg
+
+    -- walk splits the statement sequence into segments, traversing
+    -- the sequence from the back to the front, and keeping track of
+    -- the set of free variables of the current segment.  Whenever
+    -- this set of free variables is empty, we have a complete segment.
+    walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
+    walk [] = []
+    walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest
+      where (seg,rest) = chunter fvs' stmts
+            (_, fvs') = stmtRefs stmt fvs
+
+    chunter _ [] = ([], [])
+    chunter vars ((stmt,fvs) : rest)
+       | not (isEmptyNameSet vars)
+       || isStrictPatternBind stmt
+           -- See Note [ApplicativeDo and strict patterns]
+       = ((stmt,fvs) : chunk, rest')
+       where (chunk,rest') = chunter vars' rest
+             (pvars, evars) = stmtRefs stmt fvs
+             vars' = (vars `minusNameSet` pvars) `unionNameSet` evars
+    chunter _ rest = ([], rest)
+
+    stmtRefs stmt fvs
+      | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)
+      | otherwise      = (pvars, fvs')
+      where fvs' = fvs `intersectNameSet` allvars
+            pvars = mkNameSet (collectStmtBinders (unLoc stmt))
+
+    isStrictPatternBind :: ExprLStmt GhcRn -> Bool
+    isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat
+    isStrictPatternBind _ = False
+
+{-
+Note [ApplicativeDo and strict patterns]
+
+A strict pattern match is really a dependency.  For example,
+
+do
+  (x,y) <- A
+  z <- B
+  return C
+
+The pattern (_,_) must be matched strictly before we do B.  If we
+allowed this to be transformed into
+
+  (\(x,y) -> \z -> C) <$> A <*> B
+
+then it could be lazier than the standard desuraging using >>=.  See #13875
+for more examples.
+
+Thus, whenever we have a strict pattern match, we treat it as a
+dependency between that statement and the following one.  The
+dependency prevents those two statements from being performed "in
+parallel" in an ApplicativeStmt, but doesn't otherwise affect what we
+can do with the rest of the statements in the same "do" expression.
+-}
+
+isStrictPattern :: LPat (GhcPass p) -> Bool
+isStrictPattern lpat =
+  case unLoc lpat of
+    WildPat{}       -> False
+    VarPat{}        -> False
+    LazyPat{}       -> False
+    AsPat _ _ p     -> isStrictPattern p
+    ParPat _ p      -> isStrictPattern p
+    ViewPat _ _ p   -> isStrictPattern p
+    SigPat _ p _    -> isStrictPattern p
+    BangPat{}       -> True
+    ListPat{}       -> True
+    TuplePat{}      -> True
+    SumPat{}        -> True
+    ConPatIn{}      -> True
+    ConPatOut{}     -> True
+    LitPat{}        -> True
+    NPat{}          -> True
+    NPlusKPat{}     -> True
+    SplicePat{}     -> True
+    _otherwise -> panic "isStrictPattern"
+
+isLetStmt :: LStmt a b -> Bool
+isLetStmt (L _ LetStmt{}) = True
+isLetStmt _ = False
+
+-- | Find a "good" place to insert a bind in an indivisible segment.
+-- This is the only place where we use heuristics.  The current
+-- heuristic is to peel off the first group of independent statements
+-- and put the bind after those.
+splitSegment
+  :: [(ExprLStmt GhcRn, FreeVars)]
+  -> ( [(ExprLStmt GhcRn, FreeVars)]
+     , [(ExprLStmt GhcRn, FreeVars)] )
+splitSegment [one,two] = ([one],[two])
+  -- there is no choice when there are only two statements; this just saves
+  -- some work in a common case.
+splitSegment stmts
+  | Just (lets,binds,rest) <- slurpIndependentStmts stmts
+  =  if not (null lets)
+       then (lets, binds++rest)
+       else (lets++binds, rest)
+  | otherwise
+  = case stmts of
+      (x:xs) -> ([x],xs)
+      _other -> (stmts,[])
+
+slurpIndependentStmts
+   :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
+   -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts
+            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts
+            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] )
+slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
+ where
+  -- If we encounter a BindStmt that doesn't depend on a previous BindStmt
+  -- in this group, then add it to the group. We have to be careful about
+  -- strict patterns though; splitSegments expects that if we return Just
+  -- then we have actually done some splitting. Otherwise it will go into
+  -- an infinite loop (#14163).
+  go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest)
+    | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)
+    = go lets ((L loc (BindStmt noExt pat body bind_op fail_op), fvs) : indep)
+         bndrs' rest
+    where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
+  -- If we encounter a LetStmt that doesn't depend on a BindStmt in this
+  -- group, then move it to the beginning, so that it doesn't interfere with
+  -- grouping more BindStmts.
+  -- TODO: perhaps we shouldn't do this if there are any strict bindings,
+  -- because we might be moving evaluation earlier.
+  go lets indep bndrs ((L loc (LetStmt noExt binds), fvs) : rest)
+    | isEmptyNameSet (bndrs `intersectNameSet` fvs)
+    = go ((L loc (LetStmt noExt binds), fvs) : lets) indep bndrs rest
+  go _ []  _ _ = Nothing
+  go _ [_] _ _ = Nothing
+  go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
+
+-- | Build an ApplicativeStmt, and strip the "return" from the tail
+-- if necessary.
+--
+-- For example, if we start with
+--   do x <- E1; y <- E2; return (f x y)
+-- then we get
+--   do (E1[x] | E2[y]); f x y
+--
+-- the LastStmt in this case has the return removed, but we set the
+-- flag on the LastStmt to indicate this, so that we can print out the
+-- original statement correctly in error messages.  It is easier to do
+-- it this way rather than try to ignore the return later in both the
+-- typechecker and the desugarer (I tried it that way first!).
+mkApplicativeStmt
+  :: HsStmtContext Name
+  -> [ApplicativeArg GhcRn]             -- ^ The args
+  -> Bool                               -- ^ True <=> need a join
+  -> [ExprLStmt GhcRn]        -- ^ The body statements
+  -> RnM ([ExprLStmt GhcRn], FreeVars)
+mkApplicativeStmt ctxt args need_join body_stmts
+  = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName
+       ; (ap_op, fvs2) <- lookupStmtName ctxt apAName
+       ; (mb_join, fvs3) <-
+           if need_join then
+             do { (join_op, fvs) <- lookupStmtName ctxt joinMName
+                ; return (Just join_op, fvs) }
+           else
+             return (Nothing, emptyNameSet)
+       ; let applicative_stmt = noLoc $ ApplicativeStmt noExt
+               (zip (fmap_op : repeat ap_op) args)
+               mb_join
+       ; return ( applicative_stmt : body_stmts
+                , fvs1 `plusFV` fvs2 `plusFV` fvs3) }
+
+-- | Given the statements following an ApplicativeStmt, determine whether
+-- we need a @join@ or not, and remove the @return@ if necessary.
+needJoin :: MonadNames
+         -> [ExprLStmt GhcRn]
+         -> (Bool, [ExprLStmt GhcRn])
+needJoin _monad_names [] = (False, [])  -- we're in an ApplicativeArg
+needJoin monad_names  [L loc (LastStmt _ e _ t)]
+ | Just arg <- isReturnApp monad_names e =
+       (False, [L loc (LastStmt noExt arg True t)])
+needJoin _monad_names stmts = (True, stmts)
+
+-- | @Just e@, if the expression is @return e@ or @return $ e@,
+-- otherwise @Nothing@
+isReturnApp :: MonadNames
+            -> LHsExpr GhcRn
+            -> Maybe (LHsExpr GhcRn)
+isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr
+isReturnApp monad_names (L _ e) = case e of
+  OpApp _ l op r | is_return l, is_dollar op -> Just r
+  HsApp _ f arg  | is_return f               -> Just arg
+  _otherwise -> Nothing
+ where
+  is_var f (L _ (HsPar _ e)) = is_var f e
+  is_var f (L _ (HsAppType _ e _)) = is_var f e
+  is_var f (L _ (HsVar _ (L _ r))) = f r
+       -- TODO: I don't know how to get this right for rebindable syntax
+  is_var _ _ = False
+
+  is_return = is_var (\n -> n == return_name monad_names
+                         || n == pure_name monad_names)
+  is_dollar = is_var (`hasKey` dollarIdKey)
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{Errors}
+*                                                                      *
+************************************************************************
+-}
+
+checkEmptyStmts :: HsStmtContext Name -> RnM ()
+-- We've seen an empty sequence of Stmts... is that ok?
+checkEmptyStmts ctxt
+  = unless (okEmpty ctxt) (addErr (emptyErr ctxt))
+
+okEmpty :: HsStmtContext a -> Bool
+okEmpty (PatGuard {}) = True
+okEmpty _             = False
+
+emptyErr :: HsStmtContext Name -> SDoc
+emptyErr (ParStmtCtxt {})   = text "Empty statement group in parallel comprehension"
+emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'"
+emptyErr ctxt               = text "Empty" <+> pprStmtContext ctxt
+
+----------------------
+checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name
+              -> LStmt GhcPs (Located (body GhcPs))
+              -> RnM (LStmt GhcPs (Located (body GhcPs)))
+checkLastStmt ctxt lstmt@(L loc stmt)
+  = case ctxt of
+      ListComp  -> check_comp
+      MonadComp -> check_comp
+      ArrowExpr -> check_do
+      DoExpr    -> check_do
+      MDoExpr   -> check_do
+      _         -> check_other
+  where
+    check_do    -- Expect BodyStmt, and change it to LastStmt
+      = case stmt of
+          BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))
+          LastStmt {}      -> return lstmt   -- "Deriving" clauses may generate a
+                                             -- LastStmt directly (unlike the parser)
+          _                -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }
+    last_error = (text "The last statement in" <+> pprAStmtContext ctxt
+                  <+> text "must be an expression")
+
+    check_comp  -- Expect LastStmt; this should be enforced by the parser!
+      = case stmt of
+          LastStmt {} -> return lstmt
+          _           -> pprPanic "checkLastStmt" (ppr lstmt)
+
+    check_other -- Behave just as if this wasn't the last stmt
+      = do { checkStmt ctxt lstmt; return lstmt }
+
+-- Checking when a particular Stmt is ok
+checkStmt :: HsStmtContext Name
+          -> LStmt GhcPs (Located (body GhcPs))
+          -> RnM ()
+checkStmt ctxt (L _ stmt)
+  = do { dflags <- getDynFlags
+       ; case okStmt dflags ctxt stmt of
+           IsValid        -> return ()
+           NotValid extra -> addErr (msg $$ extra) }
+  where
+   msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement")
+             , text "in" <+> pprAStmtContext ctxt ]
+
+pprStmtCat :: Stmt a body -> SDoc
+pprStmtCat (TransStmt {})     = text "transform"
+pprStmtCat (LastStmt {})      = text "return expression"
+pprStmtCat (BodyStmt {})      = text "body"
+pprStmtCat (BindStmt {})      = text "binding"
+pprStmtCat (LetStmt {})       = text "let"
+pprStmtCat (RecStmt {})       = text "rec"
+pprStmtCat (ParStmt {})       = text "parallel"
+pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
+pprStmtCat (XStmtLR {})         = panic "pprStmtCat: XStmtLR"
+
+------------
+emptyInvalid :: Validity  -- Payload is the empty document
+emptyInvalid = NotValid Outputable.empty
+
+okStmt, okDoStmt, okCompStmt, okParStmt
+   :: DynFlags -> HsStmtContext Name
+   -> Stmt GhcPs (Located (body GhcPs)) -> Validity
+-- Return Nothing if OK, (Just extra) if not ok
+-- The "extra" is an SDoc that is appended to a generic error message
+
+okStmt dflags ctxt stmt
+  = case ctxt of
+      PatGuard {}        -> okPatGuardStmt stmt
+      ParStmtCtxt ctxt   -> okParStmt  dflags ctxt stmt
+      DoExpr             -> okDoStmt   dflags ctxt stmt
+      MDoExpr            -> okDoStmt   dflags ctxt stmt
+      ArrowExpr          -> okDoStmt   dflags ctxt stmt
+      GhciStmtCtxt       -> okDoStmt   dflags ctxt stmt
+      ListComp           -> okCompStmt dflags ctxt stmt
+      MonadComp          -> okCompStmt dflags ctxt stmt
+      TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
+
+-------------
+okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity
+okPatGuardStmt stmt
+  = case stmt of
+      BodyStmt {} -> IsValid
+      BindStmt {} -> IsValid
+      LetStmt {}  -> IsValid
+      _           -> emptyInvalid
+
+-------------
+okParStmt dflags ctxt stmt
+  = case stmt of
+      LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid
+      _                              -> okStmt dflags ctxt stmt
+
+----------------
+okDoStmt dflags ctxt stmt
+  = case stmt of
+       RecStmt {}
+         | LangExt.RecursiveDo `xopt` dflags -> IsValid
+         | ArrowExpr <- ctxt -> IsValid    -- Arrows allows 'rec'
+         | otherwise         -> NotValid (text "Use RecursiveDo")
+       BindStmt {} -> IsValid
+       LetStmt {}  -> IsValid
+       BodyStmt {} -> IsValid
+       _           -> emptyInvalid
+
+----------------
+okCompStmt dflags _ stmt
+  = case stmt of
+       BindStmt {} -> IsValid
+       LetStmt {}  -> IsValid
+       BodyStmt {} -> IsValid
+       ParStmt {}
+         | LangExt.ParallelListComp `xopt` dflags -> IsValid
+         | otherwise -> NotValid (text "Use ParallelListComp")
+       TransStmt {}
+         | LangExt.TransformListComp `xopt` dflags -> IsValid
+         | otherwise -> NotValid (text "Use TransformListComp")
+       RecStmt {}  -> emptyInvalid
+       LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)
+       ApplicativeStmt {} -> emptyInvalid
+       XStmtLR{} -> panic "okCompStmt"
+
+---------
+checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()
+checkTupleSection args
+  = do  { tuple_section <- xoptM LangExt.TupleSections
+        ; checkErr (all tupArgPresent args || tuple_section) msg }
+  where
+    msg = text "Illegal tuple section: use TupleSections"
+
+---------
+sectionErr :: HsExpr GhcPs -> SDoc
+sectionErr expr
+  = hang (text "A section must be enclosed in parentheses")
+       2 (text "thus:" <+> (parens (ppr expr)))
+
+patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars)
+patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:",
+                                nest 4 (ppr e)] $$
+                                  explanation)
+                 ; return (EWildPat noExt, emptyFVs) }
+
+badIpBinds :: Outputable a => SDoc -> a -> SDoc
+badIpBinds what binds
+  = hang (text "Implicit-parameter bindings illegal in" <+> what)
+         2 (ppr binds)
+
+---------
+
+monadFailOp :: LPat GhcPs
+            -> HsStmtContext Name
+            -> RnM (SyntaxExpr GhcRn, FreeVars)
+monadFailOp pat ctxt
+  -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)
+  -- we should not need to fail.
+  | isIrrefutableHsPat pat = return (noSyntaxExpr, emptyFVs)
+
+  -- For non-monadic contexts (e.g. guard patterns, list
+  -- comprehensions, etc.) we should not need to fail.  See Note
+  -- [Failing pattern matches in Stmts]
+  | not (isMonadFailStmtContext ctxt) = return (noSyntaxExpr, emptyFVs)
+
+  | otherwise = getMonadFailOp
+
+{-
+Note [Monad fail : Rebindable syntax, overloaded strings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Given the code
+  foo x = do { Just y <- x; return y }
+
+we expect it to desugar as
+  foo x = x >>= \r -> case r of
+                        Just y  -> return y
+                        Nothing -> fail "Pattern match error"
+
+But with RebindableSyntax and OverloadedStrings, we really want
+it to desugar thus:
+  foo x = x >>= \r -> case r of
+                        Just y  -> return y
+                        Nothing -> fail (fromString "Patterm match error")
+
+So, in this case, we synthesize the function
+  \x -> fail (fromString x)
+
+(rather than plain 'fail') for the 'fail' operation. This is done in
+'getMonadFailOp'.
+-}
+getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars) -- Syntax expr fail op
+getMonadFailOp
+ = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags
+      ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags
+      ; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings
+      }
+  where
+    reallyGetMonadFailOp rebindableSyntax overloadedStrings
+      | rebindableSyntax && overloadedStrings = do
+        (failExpr, failFvs) <- lookupSyntaxName failMName
+        (fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName
+        let arg_lit = fsLit "arg"
+            arg_name = mkSystemVarName (mkVarOccUnique arg_lit) arg_lit
+            arg_syn_expr = mkRnSyntaxExpr arg_name
+        let body :: LHsExpr GhcRn =
+              nlHsApp (noLoc $ syn_expr failExpr)
+                      (nlHsApp (noLoc $ syn_expr fromStringExpr)
+                                (noLoc $ syn_expr arg_syn_expr))
+        let failAfterFromStringExpr :: HsExpr GhcRn =
+              unLoc $ mkHsLam [noLoc $ VarPat noExt $ noLoc arg_name] body
+        let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
+              mkSyntaxExpr failAfterFromStringExpr
+        return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
+      | otherwise = lookupSyntaxName failMName
diff --git a/compiler/rename/RnExpr.hs-boot b/compiler/rename/RnExpr.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnExpr.hs-boot
@@ -0,0 +1,17 @@
+module RnExpr where
+import Name
+import HsSyn
+import NameSet     ( FreeVars )
+import TcRnTypes
+import SrcLoc      ( Located )
+import Outputable  ( Outputable )
+
+rnLExpr :: LHsExpr GhcPs
+        -> RnM (LHsExpr GhcRn, FreeVars)
+
+rnStmts :: --forall thing body.
+           Outputable (body GhcPs) => HsStmtContext Name
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+        -> [LStmt GhcPs (Located (body GhcPs))]
+        -> ([Name] -> RnM (thing, FreeVars))
+        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
diff --git a/compiler/rename/RnFixity.hs b/compiler/rename/RnFixity.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnFixity.hs
@@ -0,0 +1,214 @@
+{-# LANGUAGE ViewPatterns #-}
+
+{-
+
+This module contains code which maintains and manipulates the
+fixity environment during renaming.
+
+-}
+module RnFixity ( MiniFixityEnv,
+                  addLocalFixities,
+  lookupFixityRn, lookupFixityRn_help,
+  lookupFieldFixityRn, lookupTyFixityRn ) where
+
+import GhcPrelude
+
+import LoadIface
+import HsSyn
+import RdrName
+import HscTypes
+import TcRnMonad
+import Name
+import NameEnv
+import Module
+import BasicTypes       ( Fixity(..), FixityDirection(..), minPrecedence,
+                          defaultFixity, SourceText(..) )
+import SrcLoc
+import Outputable
+import Maybes
+import Data.List
+import Data.Function    ( on )
+import RnUnbound
+
+{-
+*********************************************************
+*                                                      *
+                Fixities
+*                                                      *
+*********************************************************
+
+Note [Fixity signature lookup]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A fixity declaration like
+
+    infixr 2 ?
+
+can refer to a value-level operator, e.g.:
+
+    (?) :: String -> String -> String
+
+or a type-level operator, like:
+
+    data (?) a b = A a | B b
+
+so we extend the lookup of the reader name '?' to the TcClsName namespace, as
+well as the original namespace.
+
+The extended lookup is also used in other places, like resolution of
+deprecation declarations, and lookup of names in GHCi.
+-}
+
+--------------------------------
+type MiniFixityEnv = FastStringEnv (Located Fixity)
+        -- Mini fixity env for the names we're about
+        -- to bind, in a single binding group
+        --
+        -- It is keyed by the *FastString*, not the *OccName*, because
+        -- the single fixity decl       infix 3 T
+        -- affects both the data constructor T and the type constrctor T
+        --
+        -- We keep the location so that if we find
+        -- a duplicate, we can report it sensibly
+
+--------------------------------
+-- Used for nested fixity decls to bind names along with their fixities.
+-- the fixities are given as a UFM from an OccName's FastString to a fixity decl
+
+addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a
+addLocalFixities mini_fix_env names thing_inside
+  = extendFixityEnv (mapMaybe find_fixity names) thing_inside
+  where
+    find_fixity name
+      = case lookupFsEnv mini_fix_env (occNameFS occ) of
+          Just lfix -> Just (name, FixItem occ (unLoc lfix))
+          Nothing   -> Nothing
+      where
+        occ = nameOccName name
+
+{-
+--------------------------------
+lookupFixity is a bit strange.
+
+* Nested local fixity decls are put in the local fixity env, which we
+  find with getFixtyEnv
+
+* Imported fixities are found in the PIT
+
+* Top-level fixity decls in this module may be for Names that are
+    either  Global         (constructors, class operations)
+    or      Local/Exported (everything else)
+  (See notes with RnNames.getLocalDeclBinders for why we have this split.)
+  We put them all in the local fixity environment
+-}
+
+lookupFixityRn :: Name -> RnM Fixity
+lookupFixityRn name = lookupFixityRn' name (nameOccName name)
+
+lookupFixityRn' :: Name -> OccName -> RnM Fixity
+lookupFixityRn' name = fmap snd . lookupFixityRn_help' name
+
+-- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity'
+-- in a local environment or from an interface file. Otherwise, it returns
+-- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without
+-- user-supplied fixity declarations).
+lookupFixityRn_help :: Name
+                    -> RnM (Bool, Fixity)
+lookupFixityRn_help name =
+    lookupFixityRn_help' name (nameOccName name)
+
+lookupFixityRn_help' :: Name
+                     -> OccName
+                     -> RnM (Bool, Fixity)
+lookupFixityRn_help' name occ
+  | isUnboundName name
+  = return (False, Fixity NoSourceText minPrecedence InfixL)
+    -- Minimise errors from ubound names; eg
+    --    a>0 `foo` b>0
+    -- where 'foo' is not in scope, should not give an error (Trac #7937)
+
+  | otherwise
+  = do { local_fix_env <- getFixityEnv
+       ; case lookupNameEnv local_fix_env name of {
+           Just (FixItem _ fix) -> return (True, fix) ;
+           Nothing ->
+
+    do { this_mod <- getModule
+       ; if nameIsLocalOrFrom this_mod name
+               -- Local (and interactive) names are all in the
+               -- fixity env, and don't have entries in the HPT
+         then return (False, defaultFixity)
+         else lookup_imported } } }
+  where
+    lookup_imported
+      -- For imported names, we have to get their fixities by doing a
+      -- loadInterfaceForName, and consulting the Ifaces that comes back
+      -- from that, because the interface file for the Name might not
+      -- have been loaded yet.  Why not?  Suppose you import module A,
+      -- which exports a function 'f', thus;
+      --        module CurrentModule where
+      --          import A( f )
+      --        module A( f ) where
+      --          import B( f )
+      -- Then B isn't loaded right away (after all, it's possible that
+      -- nothing from B will be used).  When we come across a use of
+      -- 'f', we need to know its fixity, and it's then, and only
+      -- then, that we load B.hi.  That is what's happening here.
+      --
+      -- loadInterfaceForName will find B.hi even if B is a hidden module,
+      -- and that's what we want.
+      = do { iface <- loadInterfaceForName doc name
+           ; let mb_fix = mi_fix_fn iface occ
+           ; let msg = case mb_fix of
+                            Nothing ->
+                                  text "looking up name" <+> ppr name
+                              <+> text "in iface, but found no fixity for it."
+                              <+> text "Using default fixity instead."
+                            Just f ->
+                                  text "looking up name in iface and found:"
+                              <+> vcat [ppr name, ppr f]
+           ; traceRn "lookupFixityRn_either:" msg
+           ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix)  }
+
+    doc = text "Checking fixity for" <+> ppr name
+
+---------------
+lookupTyFixityRn :: Located Name -> RnM Fixity
+lookupTyFixityRn = lookupFixityRn . unLoc
+
+-- | Look up the fixity of a (possibly ambiguous) occurrence of a record field
+-- selector.  We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as
+-- the field label, which might be different to the 'OccName' of the selector
+-- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are
+-- multiple possible selectors with different fixities, generate an error.
+lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity
+lookupFieldFixityRn (Unambiguous n lrdr)
+  = lookupFixityRn' n (rdrNameOcc (unLoc lrdr))
+lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr)
+  where
+    get_ambiguous_fixity :: RdrName -> RnM Fixity
+    get_ambiguous_fixity rdr_name = do
+      traceRn "get_ambiguous_fixity" (ppr rdr_name)
+      rdr_env <- getGlobalRdrEnv
+      let elts =  lookupGRE_RdrName rdr_name rdr_env
+
+      fixities <- groupBy ((==) `on` snd) . zip elts
+                  <$> mapM lookup_gre_fixity elts
+
+      case fixities of
+        -- There should always be at least one fixity.
+        -- Something's very wrong if there are no fixity candidates, so panic
+        [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"
+        [ (_, fix):_ ] -> return fix
+        ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)
+                  >> return (Fixity NoSourceText minPrecedence InfixL)
+
+    lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre)
+
+    ambiguous_fixity_err rn ambigs
+      = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)
+             , hang (text "Conflicts: ") 2 . vcat .
+               map format_ambig $ concat ambigs ]
+
+    format_ambig (elt, fix) = hang (ppr fix)
+                                 2 (pprNameProvenance elt)
+lookupFieldFixityRn (XAmbiguousFieldOcc{}) = panic "lookupFieldFixityRn"
diff --git a/compiler/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnHsDoc.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE ViewPatterns #-}
+
+module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where
+
+import GhcPrelude
+
+import TcRnTypes
+import HsSyn
+import SrcLoc
+
+
+rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)
+rnMbLHsDoc mb_doc = case mb_doc of
+  Just doc -> do
+    doc' <- rnLHsDoc doc
+    return (Just doc')
+  Nothing -> return Nothing
+
+rnLHsDoc :: LHsDocString -> RnM LHsDocString
+rnLHsDoc (dL->L pos doc) = do
+  doc' <- rnHsDoc doc
+  return (cL pos doc')
+
+rnHsDoc :: HsDocString -> RnM HsDocString
+rnHsDoc = pure
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnNames.hs
@@ -0,0 +1,1763 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[RnNames]{Extracting imported and top-level names in scope}
+-}
+
+{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module RnNames (
+        rnImports, getLocalNonValBinders, newRecordSelector,
+        extendGlobalRdrEnvRn,
+        gresFromAvails,
+        calculateAvails,
+        reportUnusedNames,
+        checkConName,
+        mkChildEnv,
+        findChildren,
+        dodgyMsg,
+        dodgyMsgInsert,
+        findImportUsage,
+        getMinimalImports,
+        printMinimalImports,
+        ImportDeclUsage
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import DynFlags
+import HsSyn
+import TcEnv
+import RnEnv
+import RnFixity
+import RnUtils          ( warnUnusedTopBinds, mkFieldEnv )
+import LoadIface        ( loadSrcInterface )
+import TcRnMonad
+import PrelNames
+import Module
+import Name
+import NameEnv
+import NameSet
+import Avail
+import FieldLabel
+import HscTypes
+import RdrName
+import RdrHsSyn        ( setRdrNameSpace )
+import Outputable
+import Maybes
+import SrcLoc
+import BasicTypes      ( TopLevelFlag(..), StringLiteral(..) )
+import Util
+import FastString
+import FastStringEnv
+import Id
+import Type
+import PatSyn
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Data.Either      ( partitionEithers, isRight, rights )
+import Data.Map         ( Map )
+import qualified Data.Map as Map
+import Data.Ord         ( comparing )
+import Data.List        ( partition, (\\), find, sortBy )
+import qualified Data.Set as S
+import System.FilePath  ((</>))
+
+import System.IO
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{rnImports}
+*                                                                      *
+************************************************************************
+
+Note [Tracking Trust Transitively]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we import a package as well as checking that the direct imports are safe
+according to the rules outlined in the Note [HscMain . Safe Haskell Trust Check]
+we must also check that these rules hold transitively for all dependent modules
+and packages. Doing this without caching any trust information would be very
+slow as we would need to touch all packages and interface files a module depends
+on. To avoid this we make use of the property that if a modules Safe Haskell
+mode changes, this triggers a recompilation from that module in the dependcy
+graph. So we can just worry mostly about direct imports.
+
+There is one trust property that can change for a package though without
+recompliation being triggered: package trust. So we must check that all
+packages a module tranitively depends on to be trusted are still trusted when
+we are compiling this module (as due to recompilation avoidance some modules
+below may not be considered trusted any more without recompilation being
+triggered).
+
+We handle this by augmenting the existing transitive list of packages a module M
+depends on with a bool for each package that says if it must be trusted when the
+module M is being checked for trust. This list of trust required packages for a
+single import is gathered in the rnImportDecl function and stored in an
+ImportAvails data structure. The union of these trust required packages for all
+imports is done by the rnImports function using the combine function which calls
+the plusImportAvails function that is a union operation for the ImportAvails
+type. This gives us in an ImportAvails structure all packages required to be
+trusted for the module we are currently compiling. Checking that these packages
+are still trusted (and that direct imports are trusted) is done in
+HscMain.checkSafeImports.
+
+See the note below, [Trust Own Package] for a corner case in this method and
+how its handled.
+
+
+Note [Trust Own Package]
+~~~~~~~~~~~~~~~~~~~~~~~~
+There is a corner case of package trust checking that the usual transitive check
+doesn't cover. (For how the usual check operates see the Note [Tracking Trust
+Transitively] below). The case is when you import a -XSafe module M and M
+imports a -XTrustworthy module N. If N resides in a different package than M,
+then the usual check works as M will record a package dependency on N's package
+and mark it as required to be trusted. If N resides in the same package as M
+though, then importing M should require its own package be trusted due to N
+(since M is -XSafe so doesn't create this requirement by itself). The usual
+check fails as a module doesn't record a package dependency of its own package.
+So instead we now have a bool field in a modules interface file that simply
+states if the module requires its own package to be trusted. This field avoids
+us having to load all interface files that the module depends on to see if one
+is trustworthy.
+
+
+Note [Trust Transitive Property]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+So there is an interesting design question in regards to transitive trust
+checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch
+of modules and packages, some packages it requires to be trusted as its using
+-XTrustworthy modules from them. Now if I have a module A that doesn't use safe
+haskell at all and simply imports B, should A inherit all the trust
+requirements from B? Should A now also require that a package p is trusted since
+B required it?
+
+We currently say no but saying yes also makes sense. The difference is, if a
+module M that doesn't use Safe Haskell imports a module N that does, should all
+the trusted package requirements be dropped since M didn't declare that it cares
+about Safe Haskell (so -XSafe is more strongly associated with the module doing
+the importing) or should it be done still since the author of the module N that
+uses Safe Haskell said they cared (so -XSafe is more strongly associated with
+the module that was compiled that used it).
+
+Going with yes is a simpler semantics we think and harder for the user to stuff
+up but it does mean that Safe Haskell will affect users who don't care about
+Safe Haskell as they might grab a package from Cabal which uses safe haskell (say
+network) and that packages imports -XTrustworthy modules from another package
+(say bytestring), so requires that package is trusted. The user may now get
+compilation errors in code that doesn't do anything with Safe Haskell simply
+because they are using the network package. They will have to call 'ghc-pkg
+trust network' to get everything working. Due to this invasive nature of going
+with yes we have gone with no for now.
+-}
+
+-- | Process Import Decls.  See 'rnImportDecl' for a description of what
+-- the return types represent.
+-- Note: Do the non SOURCE ones first, so that we get a helpful warning
+-- for SOURCE ones that are unnecessary
+rnImports :: [LImportDecl GhcPs]
+          -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
+rnImports imports = do
+    tcg_env <- getGblEnv
+    -- NB: want an identity module here, because it's OK for a signature
+    -- module to import from its implementor
+    let this_mod = tcg_mod tcg_env
+    let (source, ordinary) = partition is_source_import imports
+        is_source_import d = ideclSource (unLoc d)
+    stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary
+    stuff2 <- mapAndReportM (rnImportDecl this_mod) source
+    -- Safe Haskell: See Note [Tracking Trust Transitively]
+    let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2)
+    return (decls, rdr_env, imp_avails, hpc_usage)
+
+  where
+    -- See Note [Combining ImportAvails]
+    combine :: [(LImportDecl GhcRn,  GlobalRdrEnv, ImportAvails, AnyHpcUsage)]
+            -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)
+    combine ss =
+      let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr
+            plus
+            ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet)
+            ss
+      in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts },
+            hpc_usage)
+
+    plus (decl,  gbl_env1, imp_avails1, hpc_usage1)
+         (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set)
+      = ( decl:decls,
+          gbl_env1 `plusGlobalRdrEnv` gbl_env2,
+          imp_avails1' `plusImportAvails` imp_avails2,
+          hpc_usage1 || hpc_usage2,
+          extendModuleSetList finsts_set new_finsts )
+      where
+      imp_avails1' = imp_avails1 { imp_finsts = [] }
+      new_finsts = imp_finsts imp_avails1
+
+{-
+Note [Combining ImportAvails]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+imp_finsts in ImportAvails is a list of family instance modules
+transitively depended on by an import. imp_finsts for a currently
+compiled module is a union of all the imp_finsts of imports.
+Computing the union of two lists of size N is O(N^2) and if we
+do it to M imports we end up with O(M*N^2). That can get very
+expensive for bigger module hierarchies.
+
+Union can be optimized to O(N log N) if we use a Set.
+imp_finsts is converted back and forth between dep_finsts, so
+changing a type of imp_finsts means either paying for the conversions
+or changing the type of dep_finsts as well.
+
+I've measured that the conversions would cost 20% of allocations on my
+test case, so that can be ruled out.
+
+Changing the type of dep_finsts forces checkFamInsts to
+get the module lists in non-deterministic order. If we wanted to restore
+the deterministic order, we'd have to sort there, which is an additional
+cost. As far as I can tell, using a non-deterministic order is fine there,
+but that's a brittle nonlocal property which I'd like to avoid.
+
+Additionally, dep_finsts is read from an interface file, so its "natural"
+type is a list. Which makes it a natural type for imp_finsts.
+
+Since rnImports.combine is really the only place that would benefit from
+it being a Set, it makes sense to optimize the hot loop in rnImports.combine
+without changing the representation.
+
+So here's what we do: instead of naively merging ImportAvails with
+plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts
+and compute the union on the side using Sets. When we're done, we can
+convert it back to a list. One nice side effect of this approach is that
+if there's a lot of overlap in the imp_finsts of imports, the
+Set doesn't really need to grow and we don't need to allocate.
+
+Running generateModules from Trac #14693 with DEPTH=16, WIDTH=30 finishes in
+23s before, and 11s after.
+-}
+
+
+
+-- | Given a located import declaration @decl@ from @this_mod@,
+-- calculate the following pieces of information:
+--
+--  1. An updated 'LImportDecl', where all unresolved 'RdrName' in
+--     the entity lists have been resolved into 'Name's,
+--
+--  2. A 'GlobalRdrEnv' representing the new identifiers that were
+--     brought into scope (taking into account module qualification
+--     and hiding),
+--
+--  3. 'ImportAvails' summarizing the identifiers that were imported
+--     by this declaration, and
+--
+--  4. A boolean 'AnyHpcUsage' which is true if the imported module
+--     used HPC.
+rnImportDecl  :: Module -> LImportDecl GhcPs
+             -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)
+rnImportDecl this_mod
+             (L loc decl@(ImportDecl { ideclExt = noExt
+                                     , ideclName = loc_imp_mod_name
+                                     , ideclPkgQual = mb_pkg
+                                     , ideclSource = want_boot, ideclSafe = mod_safe
+                                     , ideclQualified = qual_only, ideclImplicit = implicit
+                                     , ideclAs = as_mod, ideclHiding = imp_details }))
+  = setSrcSpan loc $ do
+
+    when (isJust mb_pkg) $ do
+        pkg_imports <- xoptM LangExt.PackageImports
+        when (not pkg_imports) $ addErr packageImportErr
+
+    -- If there's an error in loadInterface, (e.g. interface
+    -- file not found) we get lots of spurious errors from 'filterImports'
+    let imp_mod_name = unLoc loc_imp_mod_name
+        doc = ppr imp_mod_name <+> text "is directly imported"
+
+    -- Check for self-import, which confuses the typechecker (Trac #9032)
+    -- ghc --make rejects self-import cycles already, but batch-mode may not
+    -- at least not until TcIface.tcHiBootIface, which is too late to avoid
+    -- typechecker crashes.  (Indirect self imports are not caught until
+    -- TcIface, see #10337 tracking how to make this error better.)
+    --
+    -- Originally, we also allowed 'import {-# SOURCE #-} M', but this
+    -- caused bug #10182: in one-shot mode, we should never load an hs-boot
+    -- file for the module we are compiling into the EPS.  In principle,
+    -- it should be possible to support this mode of use, but we would have to
+    -- extend Provenance to support a local definition in a qualified location.
+    -- For now, we don't support it, but see #10336
+    when (imp_mod_name == moduleName this_mod &&
+          (case mb_pkg of  -- If we have import "<pkg>" M, then we should
+                           -- check that "<pkg>" is "this" (which is magic)
+                           -- or the name of this_mod's package.  Yurgh!
+                           -- c.f. GHC.findModule, and Trac #9997
+             Nothing         -> True
+             Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" ||
+                            fsToUnitId pkg_fs == moduleUnitId this_mod))
+         (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name))
+
+    -- Check for a missing import list (Opt_WarnMissingImportList also
+    -- checks for T(..) items but that is done in checkDodgyImport below)
+    case imp_details of
+        Just (False, _) -> return () -- Explicit import list
+        _  | implicit   -> return () -- Do not bleat for implicit imports
+           | qual_only  -> return ()
+           | otherwise  -> whenWOptM Opt_WarnMissingImportList $
+                           addWarn (Reason Opt_WarnMissingImportList)
+                                   (missingImportListWarn imp_mod_name)
+
+    iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg)
+
+    -- Compiler sanity check: if the import didn't say
+    -- {-# SOURCE #-} we should not get a hi-boot file
+    WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) do
+
+    -- Issue a user warning for a redundant {- SOURCE -} import
+    -- NB that we arrange to read all the ordinary imports before
+    -- any of the {- SOURCE -} imports.
+    --
+    -- in --make and GHCi, the compilation manager checks for this,
+    -- and indeed we shouldn't do it here because the existence of
+    -- the non-boot module depends on the compilation order, which
+    -- is not deterministic.  The hs-boot test can show this up.
+    dflags <- getDynFlags
+    warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags))
+           (warnRedundantSourceImport imp_mod_name)
+    when (mod_safe && not (safeImportsOn dflags)) $
+        addErr (text "safe import can't be used as Safe Haskell isn't on!"
+                $+$ ptext (sLit $ "please enable Safe Haskell through either "
+                                   ++ "Safe, Trustworthy or Unsafe"))
+
+    let
+        qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name
+        imp_spec  = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only,
+                                  is_dloc = loc, is_as = qual_mod_name }
+
+    -- filter the imports according to the import declaration
+    (new_imp_details, gres) <- filterImports iface imp_spec imp_details
+
+    -- for certain error messages, we’d like to know what could be imported
+    -- here, if everything were imported
+    potential_gres <- mkGlobalRdrEnv . snd <$> filterImports iface imp_spec Nothing
+
+    let gbl_env = mkGlobalRdrEnv gres
+
+        is_hiding | Just (True,_) <- imp_details = True
+                  | otherwise                    = False
+
+        -- should the import be safe?
+        mod_safe' = mod_safe
+                    || (not implicit && safeDirectImpsReq dflags)
+                    || (implicit && safeImplicitImpsReq dflags)
+
+    let imv = ImportedModsVal
+            { imv_name        = qual_mod_name
+            , imv_span        = loc
+            , imv_is_safe     = mod_safe'
+            , imv_is_hiding   = is_hiding
+            , imv_all_exports = potential_gres
+            , imv_qualified   = qual_only
+            }
+        imports = calculateAvails dflags iface mod_safe' want_boot (ImportedByUser imv)
+
+    -- Complain if we import a deprecated module
+    whenWOptM Opt_WarnWarningsDeprecations (
+       case (mi_warns iface) of
+          WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations)
+                                (moduleWarn imp_mod_name txt)
+          _           -> return ()
+     )
+
+    let new_imp_decl = L loc (decl { ideclExt = noExt, ideclSafe = mod_safe'
+                                   , ideclHiding = new_imp_details })
+
+    return (new_imp_decl, gbl_env, imports, mi_hpc iface)
+rnImportDecl _ (L _ (XImportDecl _)) = panic "rnImportDecl"
+
+-- | Calculate the 'ImportAvails' induced by an import of a particular
+-- interface, but without 'imp_mods'.
+calculateAvails :: DynFlags
+                -> ModIface
+                -> IsSafeImport
+                -> IsBootInterface
+                -> ImportedBy
+                -> ImportAvails
+calculateAvails dflags iface mod_safe' want_boot imported_by =
+  let imp_mod    = mi_module iface
+      imp_sem_mod= mi_semantic_module iface
+      orph_iface = mi_orphan iface
+      has_finsts = mi_finsts iface
+      deps       = mi_deps iface
+      trust      = getSafeMode $ mi_trust iface
+      trust_pkg  = mi_trust_pkg iface
+
+      -- If the module exports anything defined in this module, just
+      -- ignore it.  Reason: otherwise it looks as if there are two
+      -- local definition sites for the thing, and an error gets
+      -- reported.  Easiest thing is just to filter them out up
+      -- front. This situation only arises if a module imports
+      -- itself, or another module that imported it.  (Necessarily,
+      -- this invoves a loop.)
+      --
+      -- We do this *after* filterImports, so that if you say
+      --      module A where
+      --         import B( AType )
+      --         type AType = ...
+      --
+      --      module B( AType ) where
+      --         import {-# SOURCE #-} A( AType )
+      --
+      -- then you won't get a 'B does not export AType' message.
+
+
+      -- Compute new transitive dependencies
+      --
+      -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module
+      -- itself, but we DO need to include this module in 'imp_orphs' and
+      -- 'imp_finsts' if it defines an orphan or instance family; thus the
+      -- orph_iface/has_iface tests.
+
+      orphans | orph_iface = ASSERT2( not (imp_sem_mod `elem` dep_orphs deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )
+                             imp_sem_mod : dep_orphs deps
+              | otherwise  = dep_orphs deps
+
+      finsts | has_finsts = ASSERT2( not (imp_sem_mod `elem` dep_finsts deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )
+                            imp_sem_mod : dep_finsts deps
+             | otherwise  = dep_finsts deps
+
+      pkg = moduleUnitId (mi_module iface)
+      ipkg = toInstalledUnitId pkg
+
+      -- Does this import mean we now require our own pkg
+      -- to be trusted? See Note [Trust Own Package]
+      ptrust = trust == Sf_Trustworthy || trust_pkg
+
+      (dependent_mods, dependent_pkgs, pkg_trust_req)
+         | pkg == thisPackage dflags =
+            -- Imported module is from the home package
+            -- Take its dependent modules and add imp_mod itself
+            -- Take its dependent packages unchanged
+            --
+            -- NB: (dep_mods deps) might include a hi-boot file
+            -- for the module being compiled, CM. Do *not* filter
+            -- this out (as we used to), because when we've
+            -- finished dealing with the direct imports we want to
+            -- know if any of them depended on CM.hi-boot, in
+            -- which case we should do the hi-boot consistency
+            -- check.  See LoadIface.loadHiBootInterface
+            ((moduleName imp_mod,want_boot):dep_mods deps,dep_pkgs deps,ptrust)
+
+         | otherwise =
+            -- Imported module is from another package
+            -- Dump the dependent modules
+            -- Add the package imp_mod comes from to the dependent packages
+            ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps))
+                   , ppr ipkg <+> ppr (dep_pkgs deps) )
+            ([], (ipkg, False) : dep_pkgs deps, False)
+
+  in ImportAvails {
+          imp_mods       = unitModuleEnv (mi_module iface) [imported_by],
+          imp_orphs      = orphans,
+          imp_finsts     = finsts,
+          imp_dep_mods   = mkModDeps dependent_mods,
+          imp_dep_pkgs   = S.fromList . map fst $ dependent_pkgs,
+          -- Add in the imported modules trusted package
+          -- requirements. ONLY do this though if we import the
+          -- module as a safe import.
+          -- See Note [Tracking Trust Transitively]
+          -- and Note [Trust Transitive Property]
+          imp_trust_pkgs = if mod_safe'
+                               then S.fromList . map fst $ filter snd dependent_pkgs
+                               else S.empty,
+          -- Do we require our own pkg to be trusted?
+          -- See Note [Trust Own Package]
+          imp_trust_own_pkg = pkg_trust_req
+     }
+
+
+warnRedundantSourceImport :: ModuleName -> SDoc
+warnRedundantSourceImport mod_name
+  = text "Unnecessary {-# SOURCE #-} in the import of module"
+          <+> quotes (ppr mod_name)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{importsFromLocalDecls}
+*                                                                      *
+************************************************************************
+
+From the top-level declarations of this module produce
+        * the lexical environment
+        * the ImportAvails
+created by its bindings.
+
+Note [Top-level Names in Template Haskell decl quotes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also: Note [Interactively-bound Ids in GHCi] in HscTypes
+          Note [Looking up Exact RdrNames] in RnEnv
+
+Consider a Template Haskell declaration quotation like this:
+      module M where
+        f x = h [d| f = 3 |]
+When renaming the declarations inside [d| ...|], we treat the
+top level binders specially in two ways
+
+1.  We give them an Internal Name, not (as usual) an External one.
+    This is done by RnEnv.newTopSrcBinder.
+
+2.  We make them *shadow* the outer bindings.
+    See Note [GlobalRdrEnv shadowing]
+
+3. We find out whether we are inside a [d| ... |] by testing the TH
+   stage. This is a slight hack, because the stage field was really
+   meant for the type checker, and here we are not interested in the
+   fields of Brack, hence the error thunks in thRnBrack.
+-}
+
+extendGlobalRdrEnvRn :: [AvailInfo]
+                     -> MiniFixityEnv
+                     -> RnM (TcGblEnv, TcLclEnv)
+-- Updates both the GlobalRdrEnv and the FixityEnv
+-- We return a new TcLclEnv only because we might have to
+-- delete some bindings from it;
+-- see Note [Top-level Names in Template Haskell decl quotes]
+
+extendGlobalRdrEnvRn avails new_fixities
+  = do  { (gbl_env, lcl_env) <- getEnvs
+        ; stage <- getStage
+        ; isGHCi <- getIsGHCi
+        ; let rdr_env  = tcg_rdr_env gbl_env
+              fix_env  = tcg_fix_env gbl_env
+              th_bndrs = tcl_th_bndrs lcl_env
+              th_lvl   = thLevel stage
+
+              -- Delete new_occs from global and local envs
+              -- If we are in a TemplateHaskell decl bracket,
+              --    we are going to shadow them
+              -- See Note [GlobalRdrEnv shadowing]
+              inBracket = isBrackStage stage
+
+              lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs }
+                           -- See Note [GlobalRdrEnv shadowing]
+
+              lcl_env2 | inBracket = lcl_env_TH
+                       | otherwise = lcl_env
+
+              -- Deal with shadowing: see Note [GlobalRdrEnv shadowing]
+              want_shadowing = isGHCi || inBracket
+              rdr_env1 | want_shadowing = shadowNames rdr_env new_names
+                       | otherwise      = rdr_env
+
+              lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs
+                                                       [ (n, (TopLevel, th_lvl))
+                                                       | n <- new_names ] }
+
+        ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres
+
+        ; let fix_env' = foldl' extend_fix_env fix_env new_gres
+              gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }
+
+        ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2)
+        ; return (gbl_env', lcl_env3) }
+  where
+    new_names = concatMap availNames avails
+    new_occs  = map nameOccName new_names
+
+    -- If there is a fixity decl for the gre, add it to the fixity env
+    extend_fix_env fix_env gre
+      | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ)
+      = extendNameEnv fix_env name (FixItem occ fi)
+      | otherwise
+      = fix_env
+      where
+        name = gre_name gre
+        occ  = greOccName gre
+
+    new_gres :: [GlobalRdrElt]  -- New LocalDef GREs, derived from avails
+    new_gres = concatMap localGREsFromAvail avails
+
+    add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv
+    -- Extend the GlobalRdrEnv with a LocalDef GRE
+    -- If there is already a LocalDef GRE with the same OccName,
+    --    report an error and discard the new GRE
+    -- This establishes INVARIANT 1 of GlobalRdrEnvs
+    add_gre env gre
+      | not (null dups)    -- Same OccName defined twice
+      = do { addDupDeclErr (gre : dups); return env }
+
+      | otherwise
+      = return (extendGlobalRdrEnv env gre)
+      where
+        name = gre_name gre
+        occ  = nameOccName name
+        dups = filter isLocalGRE (lookupGlobalRdrEnv env occ)
+
+
+{- *********************************************************************
+*                                                                      *
+    getLocalDeclBindersd@ returns the names for an HsDecl
+             It's used for source code.
+
+        *** See Note [The Naming story] in HsDecls ****
+*                                                                      *
+********************************************************************* -}
+
+getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs
+    -> RnM ((TcGblEnv, TcLclEnv), NameSet)
+-- Get all the top-level binders bound the group *except*
+-- for value bindings, which are treated separately
+-- Specifically we return AvailInfo for
+--      * type decls (incl constructors and record selectors)
+--      * class decls (including class ops)
+--      * associated types
+--      * foreign imports
+--      * value signatures (in hs-boot files only)
+
+getLocalNonValBinders fixity_env
+     (HsGroup { hs_valds  = binds,
+                hs_tyclds = tycl_decls,
+                hs_fords  = foreign_decls })
+  = do  { -- Process all type/class decls *except* family instances
+        ; let inst_decls = tycl_decls >>= group_instds
+        ; overload_ok <- xoptM LangExt.DuplicateRecordFields
+        ; (tc_avails, tc_fldss)
+            <- fmap unzip $ mapM (new_tc overload_ok)
+                                 (tyClGroupTyClDecls tycl_decls)
+        ; traceRn "getLocalNonValBinders 1" (ppr tc_avails)
+        ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env
+        ; setEnvs envs $ do {
+            -- Bring these things into scope first
+            -- See Note [Looking up family names in family instances]
+
+          -- Process all family instances
+          -- to bring new data constructors into scope
+        ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok)
+                                                   inst_decls
+
+          -- Finish off with value binders:
+          --    foreign decls and pattern synonyms for an ordinary module
+          --    type sigs in case of a hs-boot file only
+        ; is_boot <- tcIsHsBootOrSig
+        ; let val_bndrs | is_boot   = hs_boot_sig_bndrs
+                        | otherwise = for_hs_bndrs
+        ; val_avails <- mapM new_simple val_bndrs
+
+        ; let avails    = concat nti_availss ++ val_avails
+              new_bndrs = availsToNameSetWithSelectors avails `unionNameSet`
+                          availsToNameSetWithSelectors tc_avails
+              flds      = concat nti_fldss ++ concat tc_fldss
+        ; traceRn "getLocalNonValBinders 2" (ppr avails)
+        ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env
+
+        -- Extend tcg_field_env with new fields (this used to be the
+        -- work of extendRecordFieldEnv)
+        ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds
+              envs      = (tcg_env { tcg_field_env = field_env }, tcl_env)
+
+        ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])
+        ; return (envs, new_bndrs) } }
+  where
+    ValBinds _ _val_binds val_sigs = binds
+
+    for_hs_bndrs :: [Located RdrName]
+    for_hs_bndrs = hsForeignDeclsBinders foreign_decls
+
+    -- In a hs-boot file, the value binders come from the
+    --  *signatures*, and there should be no foreign binders
+    hs_boot_sig_bndrs = [ L decl_loc (unLoc n)
+                        | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns]
+
+      -- the SrcSpan attached to the input should be the span of the
+      -- declaration, not just the name
+    new_simple :: Located RdrName -> RnM AvailInfo
+    new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name
+                            ; return (avail nm) }
+
+    new_tc :: Bool -> LTyClDecl GhcPs
+           -> RnM (AvailInfo, [(Name, [FieldLabel])])
+    new_tc overload_ok tc_decl -- NOT for type/data instances
+        = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl
+             ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs
+             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds
+             ; let fld_env = case unLoc tc_decl of
+                     DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'
+                     _                            -> []
+             ; return (AvailTC main_name names flds', fld_env) }
+
+
+    -- Calculate the mapping from constructor names to fields, which
+    -- will go in tcg_field_env. It's convenient to do this here where
+    -- we are working with a single datatype definition.
+    mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel]
+               -> [(Name, [FieldLabel])]
+    mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)
+      where
+        find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr
+                                       , con_args = RecCon cdflds }))
+            = [( find_con_name rdr
+               , concatMap find_con_decl_flds (unLoc cdflds) )]
+        find_con_flds (L _ (ConDeclGADT { con_names = rdrs
+                                        , con_args = RecCon flds }))
+            = [ ( find_con_name rdr
+                 , concatMap find_con_decl_flds (unLoc flds))
+              | L _ rdr <- rdrs ]
+
+        find_con_flds _ = []
+
+        find_con_name rdr
+          = expectJust "getLocalNonValBinders/find_con_name" $
+              find (\ n -> nameOccName n == rdrNameOcc rdr) names
+        find_con_decl_flds (L _ x)
+          = map find_con_decl_fld (cd_fld_names x)
+
+        find_con_decl_fld  (L _ (FieldOcc _ (L _ rdr)))
+          = expectJust "getLocalNonValBinders/find_con_decl_fld" $
+              find (\ fl -> flLabel fl == lbl) flds
+          where lbl = occNameFS (rdrNameOcc rdr)
+        find_con_decl_fld (L _ (XFieldOcc _)) = panic "getLocalNonValBinders"
+
+    new_assoc :: Bool -> LInstDecl GhcPs
+              -> RnM ([AvailInfo], [(Name, [FieldLabel])])
+    new_assoc _ (L _ (TyFamInstD {})) = return ([], [])
+      -- type instances don't bind new names
+
+    new_assoc overload_ok (L _ (DataFamInstD _ d))
+      = do { (avail, flds) <- new_di overload_ok Nothing d
+           ; return ([avail], flds) }
+    new_assoc overload_ok (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty
+                                                      , cid_datafam_insts = adts })))
+      | Just (L loc cls_rdr) <- getLHsInstDeclClass_maybe inst_ty
+      = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
+           ; (avails, fldss)
+                    <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts
+           ; return (avails, concat fldss) }
+      | otherwise
+      = return ([], [])    -- Do not crash on ill-formed instances
+                           -- Eg   instance !Show Int   Trac #3811c
+    new_assoc _ (L _ (ClsInstD _ (XClsInstDecl _))) = panic "new_assoc"
+    new_assoc _ (L _ (XInstDecl _))                 = panic "new_assoc"
+
+    new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs
+                   -> RnM (AvailInfo, [(Name, [FieldLabel])])
+    new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn =
+                                     HsIB { hsib_body = ti_decl }})
+        = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl)
+             ; let (bndrs, flds) = hsDataFamInstBinders dfid
+             ; sub_names <- mapM newTopSrcBinder bndrs
+             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds
+             ; let avail    = AvailTC (unLoc main_name) sub_names flds'
+                                  -- main_name is not bound here!
+                   fld_env  = mk_fld_env (feqn_rhs ti_decl) sub_names flds'
+             ; return (avail, fld_env) }
+    new_di _ _ (DataFamInstDecl (XHsImplicitBndrs _)) = panic "new_di"
+
+    new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs
+                   -> RnM (AvailInfo, [(Name, [FieldLabel])])
+    new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d
+getLocalNonValBinders _ (XHsGroup _) = panic "getLocalNonValBinders"
+
+newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel
+newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"
+newRecordSelector _ _ (L _ (XFieldOcc _)) = panic "newRecordSelector"
+newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld)))
+  = do { selName <- newTopSrcBinder $ L loc $ field
+       ; return $ qualFieldLbl { flSelector = selName } }
+  where
+    fieldOccName = occNameFS $ rdrNameOcc fld
+    qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok
+    field | isExact fld = fld
+              -- use an Exact RdrName as is to preserve the bindings
+              -- of an already renamer-resolved field and its use
+              -- sites. This is needed to correctly support record
+              -- selectors in Template Haskell. See Note [Binders in
+              -- Template Haskell] in Convert.hs and Note [Looking up
+              -- Exact RdrNames] in RnEnv.hs.
+          | otherwise   = mkRdrUnqual (flSelector qualFieldLbl)
+
+{-
+Note [Looking up family names in family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+  module M where
+    type family T a :: *
+    type instance M.T Int = Bool
+
+We might think that we can simply use 'lookupOccRn' when processing the type
+instance to look up 'M.T'.  Alas, we can't!  The type family declaration is in
+the *same* HsGroup as the type instance declaration.  Hence, as we are
+currently collecting the binders declared in that HsGroup, these binders will
+not have been added to the global environment yet.
+
+Solution is simple: process the type family declarations first, extend
+the environment, and then process the type instances.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Filtering imports}
+*                                                                      *
+************************************************************************
+
+@filterImports@ takes the @ExportEnv@ telling what the imported module makes
+available, and filters it through the import spec (if any).
+
+Note [Dealing with imports]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For import M( ies ), we take the mi_exports of M, and make
+   imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name)
+One entry for each Name that M exports; the AvailInfo is the
+AvailInfo exported from M that exports that Name.
+
+The situation is made more complicated by associated types. E.g.
+   module M where
+     class    C a    where { data T a }
+     instance C Int  where { data T Int = T1 | T2 }
+     instance C Bool where { data T Int = T3 }
+Then M's export_avails are (recall the AvailTC invariant from Avails.hs)
+  C(C,T), T(T,T1,T2,T3)
+Notice that T appears *twice*, once as a child and once as a parent. From
+this list we construct a raw list including
+   T -> (T, T( T1, T2, T3 ), Nothing)
+   T -> (C, C( C, T ),       Nothing)
+and we combine these (in function 'combine' in 'imp_occ_env' in
+'filterImports') to get
+   T  -> (T,  T(T,T1,T2,T3), Just C)
+
+So the overall imp_occ_env is
+   C  -> (C,  C(C,T),        Nothing)
+   T  -> (T,  T(T,T1,T2,T3), Just C)
+   T1 -> (T1, T(T,T1,T2,T3), Nothing)   -- similarly T2,T3
+
+If we say
+   import M( T(T1,T2) )
+then we get *two* Avails:  C(T), T(T1,T2)
+
+Note that the imp_occ_env will have entries for data constructors too,
+although we never look up data constructors.
+-}
+
+filterImports
+    :: ModIface
+    -> ImpDeclSpec                     -- The span for the entire import decl
+    -> Maybe (Bool, Located [LIE GhcPs])    -- Import spec; True => hiding
+    -> RnM (Maybe (Bool, Located [LIE GhcRn]), -- Import spec w/ Names
+            [GlobalRdrElt])                   -- Same again, but in GRE form
+filterImports iface decl_spec Nothing
+  = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface))
+  where
+    imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }
+
+
+filterImports iface decl_spec (Just (want_hiding, L l import_items))
+  = do  -- check for errors, convert RdrNames to Names
+        items1 <- mapM lookup_lie import_items
+
+        let items2 :: [(LIE GhcRn, AvailInfo)]
+            items2 = concat items1
+                -- NB the AvailInfo may have duplicates, and several items
+                --    for the same parent; e.g N(x) and N(y)
+
+            names  = availsToNameSetWithSelectors (map snd items2)
+            keep n = not (n `elemNameSet` names)
+            pruned_avails = filterAvails keep all_avails
+            hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }
+
+            gres | want_hiding = gresFromAvails (Just hiding_spec) pruned_avails
+                 | otherwise   = concatMap (gresFromIE decl_spec) items2
+
+        return (Just (want_hiding, L l (map fst items2)), gres)
+  where
+    all_avails = mi_exports iface
+
+        -- See Note [Dealing with imports]
+    imp_occ_env :: OccEnv (Name,    -- the name
+                           AvailInfo,   -- the export item providing the name
+                           Maybe Name)  -- the parent of associated types
+    imp_occ_env = mkOccEnv_C combine [ (occ, (n, a, Nothing))
+                                     | a <- all_avails
+                                     , (n, occ) <- availNamesWithOccs a]
+      where
+        -- See Note [Dealing with imports]
+        -- 'combine' is only called for associated data types which appear
+        -- twice in the all_avails. In the example, we combine
+        --    T(T,T1,T2,T3) and C(C,T)  to give   (T, T(T,T1,T2,T3), Just C)
+        -- NB: the AvailTC can have fields as well as data constructors (Trac #12127)
+        combine (name1, a1@(AvailTC p1 _ _), mp1)
+                (name2, a2@(AvailTC p2 _ _), mp2)
+          = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2
+                   , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 )
+            if p1 == name1 then (name1, a1, Just p2)
+                           else (name1, a2, Just p1)
+        combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y)
+
+    lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name)
+    lookup_name ie rdr
+       | isQual rdr              = failLookupWith (QualImportError rdr)
+       | Just succ <- mb_success = return succ
+       | otherwise               = failLookupWith (BadImport ie)
+      where
+        mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr)
+
+    lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)]
+    lookup_lie (L loc ieRdr)
+        = do (stuff, warns) <- setSrcSpan loc $
+                               liftM (fromMaybe ([],[])) $
+                               run_lookup (lookup_ie ieRdr)
+             mapM_ emit_warning warns
+             return [ (L loc ie, avail) | (ie,avail) <- stuff ]
+        where
+            -- Warn when importing T(..) if T was exported abstractly
+            emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $
+              addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n)
+            emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $
+              addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr)
+            emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $
+              addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie))
+
+            run_lookup :: IELookupM a -> TcRn (Maybe a)
+            run_lookup m = case m of
+              Failed err -> addErr (lookup_err_msg err) >> return Nothing
+              Succeeded a -> return (Just a)
+
+            lookup_err_msg err = case err of
+              BadImport ie  -> badImportItemErr iface decl_spec ie all_avails
+              IllegalImport -> illegalImportItemErr
+              QualImportError rdr -> qualImportItemErr rdr
+
+        -- For each import item, we convert its RdrNames to Names,
+        -- and at the same time construct an AvailInfo corresponding
+        -- to what is actually imported by this item.
+        -- Returns Nothing on error.
+        -- We return a list here, because in the case of an import
+        -- item like C, if we are hiding, then C refers to *both* a
+        -- type/class and a data constructor.  Moreover, when we import
+        -- data constructors of an associated family, we need separate
+        -- AvailInfos for the data constructors and the family (as they have
+        -- different parents).  See Note [Dealing with imports]
+    lookup_ie :: IE GhcPs
+              -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning])
+    lookup_ie ie = handle_bad_import $ do
+      case ie of
+        IEVar _ (L l n) -> do
+            (name, avail, _) <- lookup_name ie $ ieWrappedName n
+            return ([(IEVar noExt (L l (replaceWrappedName n name)),
+                                                  trimAvail avail name)], [])
+
+        IEThingAll _ (L l tc) -> do
+            (name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc
+            let warns = case avail of
+                          Avail {}                     -- e.g. f(..)
+                            -> [DodgyImport $ ieWrappedName tc]
+
+                          AvailTC _ subs fs
+                            | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym
+                            -> [DodgyImport $ ieWrappedName tc]
+
+                            | not (is_qual decl_spec)  -- e.g. import M( T(..) )
+                            -> [MissingImportList]
+
+                            | otherwise
+                            -> []
+
+                renamed_ie = IEThingAll noExt (L l (replaceWrappedName tc name))
+                sub_avails = case avail of
+                               Avail {}              -> []
+                               AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]
+            case mb_parent of
+              Nothing     -> return ([(renamed_ie, avail)], warns)
+                             -- non-associated ty/cls
+              Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)
+                             -- associated type
+
+        IEThingAbs _ (L l tc')
+            | want_hiding   -- hiding ( C )
+                       -- Here the 'C' can be a data constructor
+                       --  *or* a type/class, or even both
+            -> let tc = ieWrappedName tc'
+                   tc_name = lookup_name ie tc
+                   dc_name = lookup_name ie (setRdrNameSpace tc srcDataName)
+               in
+               case catIELookupM [ tc_name, dc_name ] of
+                 []    -> failLookupWith (BadImport ie)
+                 names -> return ([mkIEThingAbs tc' l name | name <- names], [])
+            | otherwise
+            -> do nameAvail <- lookup_name ie (ieWrappedName tc')
+                  return ([mkIEThingAbs tc' l nameAvail]
+                         , [])
+
+        IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs ->
+          ASSERT2(null rdr_fs, ppr rdr_fs) do
+           (name, avail, mb_parent)
+               <- lookup_name (IEThingAbs noExt ltc) (ieWrappedName rdr_tc)
+
+           let (ns,subflds) = case avail of
+                                AvailTC _ ns' subflds' -> (ns',subflds')
+                                Avail _                -> panic "filterImports"
+
+           -- Look up the children in the sub-names of the parent
+           let subnames = case ns of   -- The tc is first in ns,
+                            [] -> []   -- if it is there at all
+                                       -- See the AvailTC Invariant in Avail.hs
+                            (n1:ns1) | n1 == name -> ns1
+                                     | otherwise  -> ns
+           case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of
+
+             Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs []))
+                                -- We are trying to import T( a,b,c,d ), and failed
+                                -- to find 'b' and 'd'.  So we make up an import item
+                                -- to report as failing, namely T( b, d ).
+                                -- c.f. Trac #15412
+
+             Succeeded (childnames, childflds) ->
+               case mb_parent of
+                 -- non-associated ty/cls
+                 Nothing
+                   -> return ([(IEThingWith noExt (L l name') wc childnames'
+                                                                 childflds,
+                               AvailTC name (name:map unLoc childnames) (map unLoc childflds))],
+                              [])
+                   where name' = replaceWrappedName rdr_tc name
+                         childnames' = map to_ie_post_rn childnames
+                         -- childnames' = postrn_ies childnames
+                 -- associated ty
+                 Just parent
+                   -> return ([(IEThingWith noExt (L l name') wc childnames'
+                                                           childflds,
+                                AvailTC name (map unLoc childnames) (map unLoc childflds)),
+                               (IEThingWith noExt (L l name') wc childnames'
+                                                           childflds,
+                                AvailTC parent [name] [])],
+                              [])
+                   where name' = replaceWrappedName rdr_tc name
+                         childnames' = map to_ie_post_rn childnames
+
+        _other -> failLookupWith IllegalImport
+        -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed
+        -- all errors.
+
+      where
+        mkIEThingAbs tc l (n, av, Nothing    )
+          = (IEThingAbs noExt (L l (replaceWrappedName tc n)), trimAvail av n)
+        mkIEThingAbs tc l (n, _,  Just parent)
+          = (IEThingAbs noExt (L l (replaceWrappedName tc n))
+             , AvailTC parent [n] [])
+
+        handle_bad_import m = catchIELookup m $ \err -> case err of
+          BadImport ie | want_hiding -> return ([], [BadImportW ie])
+          _                          -> failLookupWith err
+
+type IELookupM = MaybeErr IELookupError
+
+data IELookupWarning
+  = BadImportW (IE GhcPs)
+  | MissingImportList
+  | DodgyImport RdrName
+  -- NB. use the RdrName for reporting a "dodgy" import
+
+data IELookupError
+  = QualImportError RdrName
+  | BadImport (IE GhcPs)
+  | IllegalImport
+
+failLookupWith :: IELookupError -> IELookupM a
+failLookupWith err = Failed err
+
+catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a
+catchIELookup m h = case m of
+  Succeeded r -> return r
+  Failed err  -> h err
+
+catIELookupM :: [IELookupM a] -> [a]
+catIELookupM ms = [ a | Succeeded a <- ms ]
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Import/Export Utils}
+*                                                                      *
+************************************************************************
+-}
+
+-- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's.
+gresFromIE :: ImpDeclSpec -> (LIE GhcRn, AvailInfo) -> [GlobalRdrElt]
+gresFromIE decl_spec (L loc ie, avail)
+  = gresFromAvail prov_fn avail
+  where
+    is_explicit = case ie of
+                    IEThingAll _ name -> \n -> n == lieWrappedName name
+                    _                 -> \_ -> True
+    prov_fn name
+      = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec })
+      where
+        item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc }
+
+
+{-
+Note [Children for duplicate record fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the module
+
+    {-# LANGUAGE DuplicateRecordFields #-}
+    module M (F(foo, MkFInt, MkFBool)) where
+      data family F a
+      data instance F Int = MkFInt { foo :: Int }
+      data instance F Bool = MkFBool { foo :: Bool }
+
+The `foo` in the export list refers to *both* selectors! For this
+reason, lookupChildren builds an environment that maps the FastString
+to a list of items, rather than a single item.
+-}
+
+mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt]
+mkChildEnv gres = foldr add emptyNameEnv gres
+  where
+    add gre env = case gre_par gre of
+        FldParent p _  -> extendNameEnv_Acc (:) singleton env p gre
+        ParentIs  p    -> extendNameEnv_Acc (:) singleton env p gre
+        NoParent       -> env
+
+findChildren :: NameEnv [a] -> Name -> [a]
+findChildren env n = lookupNameEnv env n `orElse` []
+
+lookupChildren :: [Either Name FieldLabel] -> [LIEWrappedName RdrName]
+               -> MaybeErr [LIEWrappedName RdrName]   -- The ones for which the lookup failed
+                           ([Located Name], [Located FieldLabel])
+-- (lookupChildren all_kids rdr_items) maps each rdr_item to its
+-- corresponding Name all_kids, if the former exists
+-- The matching is done by FastString, not OccName, so that
+--    Cls( meth, AssocTy )
+-- will correctly find AssocTy among the all_kids of Cls, even though
+-- the RdrName for AssocTy may have a (bogus) DataName namespace
+-- (Really the rdr_items should be FastStrings in the first place.)
+lookupChildren all_kids rdr_items
+  | null fails
+  = Succeeded (fmap concat (partitionEithers oks))
+       -- This 'fmap concat' trickily applies concat to the /second/ component
+       -- of the pair, whose type is ([Located Name], [[Located FieldLabel]])
+  | otherwise
+  = Failed fails
+  where
+    mb_xs = map doOne rdr_items
+    fails = [ bad_rdr | Failed bad_rdr <- mb_xs ]
+    oks   = [ ok      | Succeeded ok   <- mb_xs ]
+    oks :: [Either (Located Name) [Located FieldLabel]]
+
+    doOne item@(L l r)
+       = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of
+           Just [Left n]            -> Succeeded (Left (L l n))
+           Just rs | all isRight rs -> Succeeded (Right (map (L l) (rights rs)))
+           _                        -> Failed    item
+
+    -- See Note [Children for duplicate record fields]
+    kid_env = extendFsEnvList_C (++) emptyFsEnv
+              [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]
+
+
+
+-------------------------------
+
+{-
+*********************************************************
+*                                                       *
+\subsection{Unused names}
+*                                                       *
+*********************************************************
+-}
+
+reportUnusedNames :: Maybe (Located [LIE GhcPs])  -- Export list
+                  -> TcGblEnv -> RnM ()
+reportUnusedNames _export_decls gbl_env
+  = do  { traceRn "RUN" (ppr (tcg_dus gbl_env))
+        ; warnUnusedImportDecls gbl_env
+        ; warnUnusedTopBinds unused_locals
+        ; warnMissingSignatures gbl_env }
+  where
+    used_names :: NameSet
+    used_names = findUses (tcg_dus gbl_env) emptyNameSet
+    -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used
+    -- Hence findUses
+
+    -- Collect the defined names from the in-scope environment
+    defined_names :: [GlobalRdrElt]
+    defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env)
+
+    -- Note that defined_and_used, defined_but_not_used
+    -- are both [GRE]; that's why we need defined_and_used
+    -- rather than just used_names
+    _defined_and_used, defined_but_not_used :: [GlobalRdrElt]
+    (_defined_and_used, defined_but_not_used)
+        = partition (gre_is_used used_names) defined_names
+
+    kids_env = mkChildEnv defined_names
+    -- This is done in mkExports too; duplicated work
+
+    gre_is_used :: NameSet -> GlobalRdrElt -> Bool
+    gre_is_used used_names (GRE {gre_name = name})
+        = name `elemNameSet` used_names
+          || any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name)
+                -- A use of C implies a use of T,
+                -- if C was brought into scope by T(..) or T(C)
+
+    -- Filter out the ones that are
+    --  (a) defined in this module, and
+    --  (b) not defined by a 'deriving' clause
+    -- The latter have an Internal Name, so we can filter them out easily
+    unused_locals :: [GlobalRdrElt]
+    unused_locals = filter is_unused_local defined_but_not_used
+    is_unused_local :: GlobalRdrElt -> Bool
+    is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre)
+
+{- *********************************************************************
+*                                                                      *
+              Missing signatures
+*                                                                      *
+********************************************************************* -}
+
+-- | Warn the user about top level binders that lack type signatures.
+-- Called /after/ type inference, so that we can report the
+-- inferred type of the function
+warnMissingSignatures :: TcGblEnv -> RnM ()
+warnMissingSignatures gbl_env
+  = do { let exports = availsToNameSet (tcg_exports gbl_env)
+             sig_ns  = tcg_sigs gbl_env
+               -- We use sig_ns to exclude top-level bindings that are generated by GHC
+             binds    = collectHsBindsBinders $ tcg_binds gbl_env
+             pat_syns = tcg_patsyns gbl_env
+
+         -- Warn about missing signatures
+         -- Do this only when we have a type to offer
+       ; warn_missing_sigs  <- woptM Opt_WarnMissingSignatures
+       ; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures
+       ; warn_pat_syns      <- woptM Opt_WarnMissingPatternSynonymSignatures
+
+       ; let add_sig_warns
+               | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures
+               | warn_missing_sigs  = add_warns Opt_WarnMissingSignatures
+               | warn_pat_syns      = add_warns Opt_WarnMissingPatternSynonymSignatures
+               | otherwise          = return ()
+
+             add_warns flag
+                = when warn_pat_syns
+                       (mapM_ add_pat_syn_warn pat_syns) >>
+                  when (warn_missing_sigs || warn_only_exported)
+                       (mapM_ add_bind_warn binds)
+                where
+                  add_pat_syn_warn p
+                    = add_warn name $
+                      hang (text "Pattern synonym with no type signature:")
+                         2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty)
+                    where
+                      name  = patSynName p
+                      pp_ty = pprPatSynType p
+
+                  add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) ()
+                  add_bind_warn id
+                    = do { env <- tcInitTidyEnv     -- Why not use emptyTidyEnv?
+                         ; let name    = idName id
+                               (_, ty) = tidyOpenType env (idType id)
+                               ty_msg  = pprSigmaType ty
+                         ; add_warn name $
+                           hang (text "Top-level binding with no type signature:")
+                              2 (pprPrefixName name <+> dcolon <+> ty_msg) }
+
+                  add_warn name msg
+                    = when (name `elemNameSet` sig_ns && export_check name)
+                           (addWarnAt (Reason flag) (getSrcSpan name) msg)
+
+                  export_check name
+                    = not warn_only_exported || name `elemNameSet` exports
+
+       ; add_sig_warns }
+
+
+{-
+*********************************************************
+*                                                       *
+\subsection{Unused imports}
+*                                                       *
+*********************************************************
+
+This code finds which import declarations are unused.  The
+specification and implementation notes are here:
+  http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/UnusedImports
+
+See also Note [Choosing the best import declaration] in RdrName
+-}
+
+type ImportDeclUsage
+   = ( LImportDecl GhcRn   -- The import declaration
+     , [GlobalRdrElt]      -- What *is* used (normalised)
+     , [Name] )            -- What is imported but *not* used
+
+warnUnusedImportDecls :: TcGblEnv -> RnM ()
+warnUnusedImportDecls gbl_env
+  = do { uses <- readMutVar (tcg_used_gres gbl_env)
+       ; let user_imports = filterOut
+                              (ideclImplicit . unLoc)
+                              (tcg_rn_imports gbl_env)
+                -- This whole function deals only with *user* imports
+                -- both for warning about unnecessary ones, and for
+                -- deciding the minimal ones
+             rdr_env = tcg_rdr_env gbl_env
+             fld_env = mkFieldEnv rdr_env
+
+       ; let usage :: [ImportDeclUsage]
+             usage = findImportUsage user_imports uses
+
+       ; traceRn "warnUnusedImportDecls" $
+                       (vcat [ text "Uses:" <+> ppr uses
+                             , text "Import usage" <+> ppr usage])
+
+       ; whenWOptM Opt_WarnUnusedImports $
+         mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage
+
+       ; whenGOptM Opt_D_dump_minimal_imports $
+         printMinimalImports usage }
+
+findImportUsage :: [LImportDecl GhcRn]
+                -> [GlobalRdrElt]
+                -> [ImportDeclUsage]
+
+findImportUsage imports used_gres
+  = map unused_decl imports
+  where
+    import_usage :: ImportMap
+    import_usage = mkImportMap used_gres
+
+    unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))
+      = (decl, used_gres, nameSetElemsStable unused_imps)
+      where
+        used_gres = Map.lookup (srcSpanEnd loc) import_usage
+                               -- srcSpanEnd: see Note [The ImportMap]
+                    `orElse` []
+
+        used_names   = mkNameSet (map      gre_name        used_gres)
+        used_parents = mkNameSet (mapMaybe greParent_maybe used_gres)
+
+        unused_imps   -- Not trivial; see eg Trac #7454
+          = case imps of
+              Just (False, L _ imp_ies) ->
+                                 foldr (add_unused . unLoc) emptyNameSet imp_ies
+              _other -> emptyNameSet -- No explicit import list => no unused-name list
+
+        add_unused :: IE GhcRn -> NameSet -> NameSet
+        add_unused (IEVar _ n)      acc = add_unused_name (lieWrappedName n) acc
+        add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc
+        add_unused (IEThingAll _ n) acc = add_unused_all  (lieWrappedName n) acc
+        add_unused (IEThingWith _ p wc ns fs) acc =
+          add_wc_all (add_unused_with pn xs acc)
+          where pn = lieWrappedName p
+                xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs
+                add_wc_all = case wc of
+                            NoIEWildcard -> id
+                            IEWildcard _ -> add_unused_all pn
+        add_unused _ acc = acc
+
+        add_unused_name n acc
+          | n `elemNameSet` used_names = acc
+          | otherwise                  = acc `extendNameSet` n
+        add_unused_all n acc
+          | n `elemNameSet` used_names   = acc
+          | n `elemNameSet` used_parents = acc
+          | otherwise                    = acc `extendNameSet` n
+        add_unused_with p ns acc
+          | all (`elemNameSet` acc1) ns = add_unused_name p acc1
+          | otherwise = acc1
+          where
+            acc1 = foldr add_unused_name acc ns
+       -- If you use 'signum' from Num, then the user may well have
+       -- imported Num(signum).  We don't want to complain that
+       -- Num is not itself mentioned.  Hence the two cases in add_unused_with.
+    unused_decl (L _ (XImportDecl _)) = panic "unused_decl"
+
+
+{- Note [The ImportMap]
+~~~~~~~~~~~~~~~~~~~~~~~
+The ImportMap is a short-lived intermediate data structure records, for
+each import declaration, what stuff brought into scope by that
+declaration is actually used in the module.
+
+The SrcLoc is the location of the END of a particular 'import'
+declaration.  Why *END*?  Because we don't want to get confused
+by the implicit Prelude import. Consider (Trac #7476) the module
+    import Foo( foo )
+    main = print foo
+There is an implicit 'import Prelude(print)', and it gets a SrcSpan
+of line 1:1 (just the point, not a span). If we use the *START* of
+the SrcSpan to identify the import decl, we'll confuse the implicit
+import Prelude with the explicit 'import Foo'.  So we use the END.
+It's just a cheap hack; we could equally well use the Span too.
+
+The [GlobalRdrElt] are the things imported from that decl.
+-}
+
+type ImportMap = Map SrcLoc [GlobalRdrElt]  -- See [The ImportMap]
+     -- If loc :-> gres, then
+     --   'loc' = the end loc of the bestImport of each GRE in 'gres'
+
+mkImportMap :: [GlobalRdrElt] -> ImportMap
+-- For each of a list of used GREs, find all the import decls that brought
+-- it into scope; choose one of them (bestImport), and record
+-- the RdrName in that import decl's entry in the ImportMap
+mkImportMap gres
+  = foldr add_one Map.empty gres
+  where
+    add_one gre@(GRE { gre_imp = imp_specs }) imp_map
+       = Map.insertWith add decl_loc [gre] imp_map
+       where
+          best_imp_spec = bestImport imp_specs
+          decl_loc      = srcSpanEnd (is_dloc (is_decl best_imp_spec))
+                        -- For srcSpanEnd see Note [The ImportMap]
+          add _ gres = gre : gres
+
+warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name)
+                 -> ImportDeclUsage -> RnM ()
+warnUnusedImport flag fld_env (L loc decl, used, unused)
+
+  -- Do not warn for 'import M()'
+  | Just (False,L _ []) <- ideclHiding decl
+  = return ()
+
+  -- Note [Do not warn about Prelude hiding]
+  | Just (True, L _ hides) <- ideclHiding decl
+  , not (null hides)
+  , pRELUDE_NAME == unLoc (ideclName decl)
+  = return ()
+
+  -- Nothing used; drop entire declaration
+  | null used
+  = addWarnAt (Reason flag) loc msg1
+
+  -- Everything imported is used; nop
+  | null unused
+  = return ()
+
+  -- Some imports are unused
+  | otherwise
+  = addWarnAt (Reason flag) loc  msg2
+
+  where
+    msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant
+                , nest 2 (text "except perhaps to import instances from"
+                                   <+> quotes pp_mod)
+                , text "To import instances alone, use:"
+                                   <+> text "import" <+> pp_mod <> parens Outputable.empty ]
+    msg2 = sep [ pp_herald <+> quotes sort_unused
+               , text "from module" <+> quotes pp_mod <+> is_redundant]
+    pp_herald  = text "The" <+> pp_qual <+> text "import of"
+    pp_qual
+      | ideclQualified decl = text "qualified"
+      | otherwise           = Outputable.empty
+    pp_mod       = ppr (unLoc (ideclName decl))
+    is_redundant = text "is redundant"
+
+    -- In warning message, pretty-print identifiers unqualified unconditionally
+    -- to improve the consistent for ambiguous/unambiguous identifiers.
+    -- See trac#14881.
+    ppr_possible_field n = case lookupNameEnv fld_env n of
+                               Just (fld, p) -> pprNameUnqualified p <> parens (ppr fld)
+                               Nothing  -> pprNameUnqualified n
+
+    -- Print unused names in a deterministic (lexicographic) order
+    sort_unused :: SDoc
+    sort_unused = pprWithCommas ppr_possible_field $
+                  sortBy (comparing nameOccName) unused
+
+{-
+Note [Do not warn about Prelude hiding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not warn about
+   import Prelude hiding( x, y )
+because even if nothing else from Prelude is used, it may be essential to hide
+x,y to avoid name-shadowing warnings.  Example (Trac #9061)
+   import Prelude hiding( log )
+   f x = log where log = ()
+
+
+
+Note [Printing minimal imports]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To print the minimal imports we walk over the user-supplied import
+decls, and simply trim their import lists.  NB that
+
+  * We do *not* change the 'qualified' or 'as' parts!
+
+  * We do not disard a decl altogether; we might need instances
+    from it.  Instead we just trim to an empty import list
+-}
+
+getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn]
+getMinimalImports = mapM mk_minimal
+  where
+    mk_minimal (L l decl, used_gres, unused)
+      | null unused
+      , Just (False, _) <- ideclHiding decl
+      = return (L l decl)
+      | otherwise
+      = do { let ImportDecl { ideclName    = L _ mod_name
+                            , ideclSource  = is_boot
+                            , ideclPkgQual = mb_pkg } = decl
+           ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg)
+           ; let used_avails = gresToAvailInfo used_gres
+                 lies = map (L l) (concatMap (to_ie iface) used_avails)
+           ; return (L l (decl { ideclHiding = Just (False, L l lies) })) }
+      where
+        doc = text "Compute minimal imports for" <+> ppr decl
+
+    to_ie :: ModIface -> AvailInfo -> [IE GhcRn]
+    -- The main trick here is that if we're importing all the constructors
+    -- we want to say "T(..)", but if we're importing only a subset we want
+    -- to say "T(A,B,C)".  So we have to find out what the module exports.
+    to_ie _ (Avail n)
+       = [IEVar noExt (to_ie_post_rn $ noLoc n)]
+    to_ie _ (AvailTC n [m] [])
+       | n==m = [IEThingAbs noExt (to_ie_post_rn $ noLoc n)]
+    to_ie iface (AvailTC n ns fs)
+      = case [(xs,gs) |  AvailTC x xs gs <- mi_exports iface
+                 , x == n
+                 , x `elem` xs    -- Note [Partial export]
+                 ] of
+           [xs] | all_used xs -> [IEThingAll noExt (to_ie_post_rn $ noLoc n)]
+                | otherwise   ->
+                   [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard
+                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))
+                                (map noLoc fs)]
+                                          -- Note [Overloaded field import]
+           _other | all_non_overloaded fs
+                           -> map (IEVar noExt . to_ie_post_rn_var . noLoc) $ ns
+                                 ++ map flSelector fs
+                  | otherwise ->
+                      [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard
+                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))
+                                (map noLoc fs)]
+        where
+
+          fld_lbls = map flLabel fs
+
+          all_used (avail_occs, avail_flds)
+              = all (`elem` ns) avail_occs
+                    && all (`elem` fld_lbls) (map flLabel avail_flds)
+
+          all_non_overloaded = all (not . flIsOverloaded)
+
+printMinimalImports :: [ImportDeclUsage] -> RnM ()
+-- See Note [Printing minimal imports]
+printMinimalImports imports_w_usage
+  = do { imports' <- getMinimalImports imports_w_usage
+       ; this_mod <- getModule
+       ; dflags   <- getDynFlags
+       ; liftIO $
+         do { h <- openFile (mkFilename dflags this_mod) WriteMode
+            ; printForUser dflags h neverQualify (vcat (map ppr imports')) }
+              -- The neverQualify is important.  We are printing Names
+              -- but they are in the context of an 'import' decl, and
+              -- we never qualify things inside there
+              -- E.g.   import Blag( f, b )
+              -- not    import Blag( Blag.f, Blag.g )!
+       }
+  where
+    mkFilename dflags this_mod
+      | Just d <- dumpDir dflags = d </> basefn
+      | otherwise                = basefn
+      where
+        basefn = moduleNameString (moduleName this_mod) ++ ".imports"
+
+
+to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name
+to_ie_post_rn_var (L l n)
+  | isDataOcc $ occName n = L l (IEPattern (L l n))
+  | otherwise             = L l (IEName    (L l n))
+
+
+to_ie_post_rn :: (HasOccName name) => Located name -> LIEWrappedName name
+to_ie_post_rn (L l n)
+  | isTcOcc occ && isSymOcc occ = L l (IEType (L l n))
+  | otherwise                   = L l (IEName (L l n))
+  where occ = occName n
+
+{-
+Note [Partial export]
+~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+   module A( op ) where
+     class C a where
+       op :: a -> a
+
+   module B where
+   import A
+   f = ..op...
+
+Then the minimal import for module B is
+   import A( op )
+not
+   import A( C( op ) )
+which we would usually generate if C was exported from B.  Hence
+the (x `elem` xs) test when deciding what to generate.
+
+
+Note [Overloaded field import]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+On the other hand, if we have
+
+    {-# LANGUAGE DuplicateRecordFields #-}
+    module A where
+      data T = MkT { foo :: Int }
+
+    module B where
+      import A
+      f = ...foo...
+
+then the minimal import for module B must be
+    import A ( T(foo) )
+because when DuplicateRecordFields is enabled, field selectors are
+not in scope without their enclosing datatype.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Errors}
+*                                                                      *
+************************************************************************
+-}
+
+qualImportItemErr :: RdrName -> SDoc
+qualImportItemErr rdr
+  = hang (text "Illegal qualified name in import item:")
+       2 (ppr rdr)
+
+badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc
+badImportItemErrStd iface decl_spec ie
+  = sep [text "Module", quotes (ppr (is_mod decl_spec)), source_import,
+         text "does not export", quotes (ppr ie)]
+  where
+    source_import | mi_boot iface = text "(hi-boot interface)"
+                  | otherwise     = Outputable.empty
+
+badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs
+                        -> SDoc
+badImportItemErrDataCon dataType_occ iface decl_spec ie
+  = vcat [ text "In module"
+             <+> quotes (ppr (is_mod decl_spec))
+             <+> source_import <> colon
+         , nest 2 $ quotes datacon
+             <+> text "is a data constructor of"
+             <+> quotes dataType
+         , text "To import it use"
+         , nest 2 $ text "import"
+             <+> ppr (is_mod decl_spec)
+             <> parens_sp (dataType <> parens_sp datacon)
+         , text "or"
+         , nest 2 $ text "import"
+             <+> ppr (is_mod decl_spec)
+             <> parens_sp (dataType <> text "(..)")
+         ]
+  where
+    datacon_occ = rdrNameOcc $ ieName ie
+    datacon = parenSymOcc datacon_occ (ppr datacon_occ)
+    dataType = parenSymOcc dataType_occ (ppr dataType_occ)
+    source_import | mi_boot iface = text "(hi-boot interface)"
+                  | otherwise     = Outputable.empty
+    parens_sp d = parens (space <> d <> space)  -- T( f,g )
+
+badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc
+badImportItemErr iface decl_spec ie avails
+  = case find checkIfDataCon avails of
+      Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie
+      Nothing  -> badImportItemErrStd iface decl_spec ie
+  where
+    checkIfDataCon (AvailTC _ ns _) =
+      case find (\n -> importedFS == nameOccNameFS n) ns of
+        Just n  -> isDataConName n
+        Nothing -> False
+    checkIfDataCon _ = False
+    availOccName = nameOccName . availName
+    nameOccNameFS = occNameFS . nameOccName
+    importedFS = occNameFS . rdrNameOcc $ ieName ie
+
+illegalImportItemErr :: SDoc
+illegalImportItemErr = text "Illegal import item"
+
+dodgyImportWarn :: RdrName -> SDoc
+dodgyImportWarn item
+  = dodgyMsg (text "import") item (dodgyMsgInsert item :: IE GhcPs)
+
+dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc
+dodgyMsg kind tc ie
+  = sep [ text "The" <+> kind <+> ptext (sLit "item")
+                    -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc))))
+                     <+> quotes (ppr ie)
+                <+> text "suggests that",
+          quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",
+          text "but it has none" ]
+
+dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)
+dodgyMsgInsert tc = IEThingAll noExt ii
+  where
+    ii :: LIEWrappedName (IdP (GhcPass p))
+    ii = noLoc (IEName $ noLoc tc)
+
+
+addDupDeclErr :: [GlobalRdrElt] -> TcRn ()
+addDupDeclErr [] = panic "addDupDeclErr: empty list"
+addDupDeclErr gres@(gre : _)
+  = addErrAt (getSrcSpan (last sorted_names)) $
+    -- Report the error at the later location
+    vcat [text "Multiple declarations of" <+>
+             quotes (ppr (nameOccName name)),
+             -- NB. print the OccName, not the Name, because the
+             -- latter might not be in scope in the RdrEnv and so will
+             -- be printed qualified.
+          text "Declared at:" <+>
+                   vcat (map (ppr . nameSrcLoc) sorted_names)]
+  where
+    name = gre_name gre
+    sorted_names = sortWith nameSrcLoc (map gre_name gres)
+
+
+
+missingImportListWarn :: ModuleName -> SDoc
+missingImportListWarn mod
+  = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list")
+
+missingImportListItem :: IE GhcPs -> SDoc
+missingImportListItem ie
+  = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list")
+
+moduleWarn :: ModuleName -> WarningTxt -> SDoc
+moduleWarn mod (WarningTxt _ txt)
+  = sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"),
+          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]
+moduleWarn mod (DeprecatedTxt _ txt)
+  = sep [ text "Module" <+> quotes (ppr mod)
+                                <+> text "is deprecated:",
+          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]
+
+packageImportErr :: SDoc
+packageImportErr
+  = text "Package-qualified imports are not enabled; use PackageImports"
+
+-- This data decl will parse OK
+--      data T = a Int
+-- treating "a" as the constructor.
+-- It is really hard to make the parser spot this malformation.
+-- So the renamer has to check that the constructor is legal
+--
+-- We can get an operator as the constructor, even in the prefix form:
+--      data T = :% Int Int
+-- from interface files, which always print in prefix form
+
+checkConName :: RdrName -> TcRn ()
+checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
+
+badDataCon :: RdrName -> SDoc
+badDataCon name
+   = hsep [text "Illegal data constructor name", quotes (ppr name)]
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnPat.hs
@@ -0,0 +1,881 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[RnPat]{Renaming of patterns}
+
+Basically dependency analysis.
+
+Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
+general, all of these functions return a renamed thing, and a set of
+free variables.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module RnPat (-- main entry points
+              rnPat, rnPats, rnBindPat, rnPatAndThen,
+
+              NameMaker, applyNameMaker,     -- a utility for making names:
+              localRecNameMaker, topRecNameMaker,  --   sometimes we want to make local names,
+                                             --   sometimes we want to make top (qualified) names.
+              isTopRecNameMaker,
+
+              rnHsRecFields, HsRecFieldContext(..),
+              rnHsRecUpdFields,
+
+              -- CpsRn monad
+              CpsRn, liftCps,
+
+              -- Literals
+              rnLit, rnOverLit,
+
+             -- Pattern Error messages that are also used elsewhere
+             checkTupSize, patSigErr
+             ) where
+
+-- ENH: thin imports to only what is necessary for patterns
+
+import GhcPrelude
+
+import {-# SOURCE #-} RnExpr ( rnLExpr )
+import {-# SOURCE #-} RnSplice ( rnSplicePat )
+
+#include "HsVersions.h"
+
+import HsSyn
+import TcRnMonad
+import TcHsSyn             ( hsOverLitName )
+import RnEnv
+import RnFixity
+import RnUtils             ( HsDocContext(..), newLocalBndrRn, bindLocalNames
+                           , warnUnusedMatches, newLocalBndrRn
+                           , checkDupNames, checkDupAndShadowedNames
+                           , checkTupSize , unknownSubordinateErr )
+import RnTypes
+import PrelNames
+import Name
+import NameSet
+import RdrName
+import BasicTypes
+import Util
+import ListSetOps          ( removeDups )
+import Outputable
+import SrcLoc
+import Literal             ( inCharRange )
+import TysWiredIn          ( nilDataCon )
+import DataCon
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad       ( when, liftM, ap, guard )
+import qualified Data.List.NonEmpty as NE
+import Data.Ratio
+
+{-
+*********************************************************
+*                                                      *
+        The CpsRn Monad
+*                                                      *
+*********************************************************
+
+Note [CpsRn monad]
+~~~~~~~~~~~~~~~~~~
+The CpsRn monad uses continuation-passing style to support this
+style of programming:
+
+        do { ...
+           ; ns <- bindNames rs
+           ; ...blah... }
+
+   where rs::[RdrName], ns::[Name]
+
+The idea is that '...blah...'
+  a) sees the bindings of ns
+  b) returns the free variables it mentions
+     so that bindNames can report unused ones
+
+In particular,
+    mapM rnPatAndThen [p1, p2, p3]
+has a *left-to-right* scoping: it makes the binders in
+p1 scope over p2,p3.
+-}
+
+newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))
+                                            -> RnM (r, FreeVars) }
+        -- See Note [CpsRn monad]
+
+instance Functor CpsRn where
+    fmap = liftM
+
+instance Applicative CpsRn where
+    pure x = CpsRn (\k -> k x)
+    (<*>) = ap
+
+instance Monad CpsRn where
+  (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))
+
+runCps :: CpsRn a -> RnM (a, FreeVars)
+runCps (CpsRn m) = m (\r -> return (r, emptyFVs))
+
+liftCps :: RnM a -> CpsRn a
+liftCps rn_thing = CpsRn (\k -> rn_thing >>= k)
+
+liftCpsFV :: RnM (a, FreeVars) -> CpsRn a
+liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing
+                                     ; (r,fvs2) <- k v
+                                     ; return (r, fvs1 `plusFV` fvs2) })
+
+wrapSrcSpanCps :: (HasSrcSpan a, HasSrcSpan b) =>
+                  (SrcSpanLess a -> CpsRn (SrcSpanLess b)) -> a -> CpsRn b
+-- Set the location, and also wrap it around the value returned
+wrapSrcSpanCps fn (dL->L loc a)
+  = CpsRn (\k -> setSrcSpan loc $
+                 unCpsRn (fn a) $ \v ->
+                 k (cL loc v))
+
+lookupConCps :: Located RdrName -> CpsRn (Located Name)
+lookupConCps con_rdr
+  = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr
+                    ; (r, fvs) <- k con_name
+                    ; return (r, addOneFV fvs (unLoc con_name)) })
+    -- We add the constructor name to the free vars
+    -- See Note [Patterns are uses]
+
+{-
+Note [Patterns are uses]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  module Foo( f, g ) where
+  data T = T1 | T2
+
+  f T1 = True
+  f T2 = False
+
+  g _ = T1
+
+Arguably we should report T2 as unused, even though it appears in a
+pattern, because it never occurs in a constructed position.  See
+Trac #7336.
+However, implementing this in the face of pattern synonyms would be
+less straightforward, since given two pattern synonyms
+
+  pattern P1 <- P2
+  pattern P2 <- ()
+
+we need to observe the dependency between P1 and P2 so that type
+checking can be done in the correct order (just like for value
+bindings). Dependencies between bindings is analyzed in the renamer,
+where we don't know yet whether P2 is a constructor or a pattern
+synonym. So for now, we do report conid occurrences in patterns as
+uses.
+
+*********************************************************
+*                                                      *
+        Name makers
+*                                                      *
+*********************************************************
+
+Externally abstract type of name makers,
+which is how you go from a RdrName to a Name
+-}
+
+data NameMaker
+  = LamMk       -- Lambdas
+      Bool      -- True <=> report unused bindings
+                --   (even if True, the warning only comes out
+                --    if -Wunused-matches is on)
+
+  | LetMk       -- Let bindings, incl top level
+                -- Do *not* check for unused bindings
+      TopLevelFlag
+      MiniFixityEnv
+
+topRecNameMaker :: MiniFixityEnv -> NameMaker
+topRecNameMaker fix_env = LetMk TopLevel fix_env
+
+isTopRecNameMaker :: NameMaker -> Bool
+isTopRecNameMaker (LetMk TopLevel _) = True
+isTopRecNameMaker _ = False
+
+localRecNameMaker :: MiniFixityEnv -> NameMaker
+localRecNameMaker fix_env = LetMk NotTopLevel fix_env
+
+matchNameMaker :: HsMatchContext a -> NameMaker
+matchNameMaker ctxt = LamMk report_unused
+  where
+    -- Do not report unused names in interactive contexts
+    -- i.e. when you type 'x <- e' at the GHCi prompt
+    report_unused = case ctxt of
+                      StmtCtxt GhciStmtCtxt -> False
+                      -- also, don't warn in pattern quotes, as there
+                      -- is no RHS where the variables can be used!
+                      ThPatQuote            -> False
+                      _                     -> True
+
+rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn)
+rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig)
+
+newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)
+newPatLName name_maker rdr_name@(dL->L loc _)
+  = do { name <- newPatName name_maker rdr_name
+       ; return (cL loc name) }
+
+newPatName :: NameMaker -> Located RdrName -> CpsRn Name
+newPatName (LamMk report_unused) rdr_name
+  = CpsRn (\ thing_inside ->
+        do { name <- newLocalBndrRn rdr_name
+           ; (res, fvs) <- bindLocalNames [name] (thing_inside name)
+           ; when report_unused $ warnUnusedMatches [name] fvs
+           ; return (res, name `delFV` fvs) })
+
+newPatName (LetMk is_top fix_env) rdr_name
+  = CpsRn (\ thing_inside ->
+        do { name <- case is_top of
+                       NotTopLevel -> newLocalBndrRn rdr_name
+                       TopLevel    -> newTopSrcBinder rdr_name
+           ; bindLocalNames [name] $       -- Do *not* use bindLocalNameFV here
+                                        -- See Note [View pattern usage]
+             addLocalFixities fix_env [name] $
+             thing_inside name })
+
+    -- Note: the bindLocalNames is somewhat suspicious
+    --       because it binds a top-level name as a local name.
+    --       however, this binding seems to work, and it only exists for
+    --       the duration of the patterns and the continuation;
+    --       then the top-level name is added to the global env
+    --       before going on to the RHSes (see RnSource.hs).
+
+{-
+Note [View pattern usage]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  let (r, (r -> x)) = x in ...
+Here the pattern binds 'r', and then uses it *only* in the view pattern.
+We want to "see" this use, and in let-bindings we collect all uses and
+report unused variables at the binding level. So we must use bindLocalNames
+here, *not* bindLocalNameFV.  Trac #3943.
+
+
+Note [Don't report shadowing for pattern synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There is one special context where a pattern doesn't introduce any new binders -
+pattern synonym declarations. Therefore we don't check to see if pattern
+variables shadow existing identifiers as they are never bound to anything
+and have no scope.
+
+Without this check, there would be quite a cryptic warning that the `x`
+in the RHS of the pattern synonym declaration shadowed the top level `x`.
+
+```
+x :: ()
+x = ()
+
+pattern P x = Just x
+```
+
+See #12615 for some more examples.
+
+*********************************************************
+*                                                      *
+        External entry points
+*                                                      *
+*********************************************************
+
+There are various entry points to renaming patterns, depending on
+ (1) whether the names created should be top-level names or local names
+ (2) whether the scope of the names is entirely given in a continuation
+     (e.g., in a case or lambda, but not in a let or at the top-level,
+      because of the way mutually recursive bindings are handled)
+ (3) whether the a type signature in the pattern can bind
+        lexically-scoped type variables (for unpacking existential
+        type vars in data constructors)
+ (4) whether we do duplicate and unused variable checking
+ (5) whether there are fixity declarations associated with the names
+     bound by the patterns that need to be brought into scope with them.
+
+ Rather than burdening the clients of this module with all of these choices,
+ we export the three points in this design space that we actually need:
+-}
+
+-- ----------- Entry point 1: rnPats -------------------
+-- Binds local names; the scope of the bindings is entirely in the thing_inside
+--   * allows type sigs to bind type vars
+--   * local namemaker
+--   * unused and duplicate checking
+--   * no fixities
+rnPats :: HsMatchContext Name -- for error messages
+       -> [LPat GhcPs]
+       -> ([LPat GhcRn] -> RnM (a, FreeVars))
+       -> RnM (a, FreeVars)
+rnPats ctxt pats thing_inside
+  = do  { envs_before <- getRdrEnvs
+
+          -- (1) rename the patterns, bringing into scope all of the term variables
+          -- (2) then do the thing inside.
+        ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do
+        { -- Check for duplicated and shadowed names
+          -- Must do this *after* renaming the patterns
+          -- See Note [Collect binders only after renaming] in HsUtils
+          -- Because we don't bind the vars all at once, we can't
+          --    check incrementally for duplicates;
+          -- Nor can we check incrementally for shadowing, else we'll
+          --    complain *twice* about duplicates e.g. f (x,x) = ...
+          --
+          -- See note [Don't report shadowing for pattern synonyms]
+        ; let bndrs = collectPatsBinders pats'
+        ; addErrCtxt doc_pat $
+          if isPatSynCtxt ctxt
+             then checkDupNames bndrs
+             else checkDupAndShadowedNames envs_before bndrs
+        ; thing_inside pats' } }
+  where
+    doc_pat = text "In" <+> pprMatchContext ctxt
+
+rnPat :: HsMatchContext Name -- for error messages
+      -> LPat GhcPs
+      -> (LPat GhcRn -> RnM (a, FreeVars))
+      -> RnM (a, FreeVars)     -- Variables bound by pattern do not
+                               -- appear in the result FreeVars
+rnPat ctxt pat thing_inside
+  = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')
+
+applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name)
+applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr)
+                           ; return n }
+
+-- ----------- Entry point 2: rnBindPat -------------------
+-- Binds local names; in a recursive scope that involves other bound vars
+--      e.g let { (x, Just y) = e1; ... } in ...
+--   * does NOT allows type sig to bind type vars
+--   * local namemaker
+--   * no unused and duplicate checking
+--   * fixities might be coming in
+rnBindPat :: NameMaker
+          -> LPat GhcPs
+          -> RnM (LPat GhcRn, FreeVars)
+   -- Returned FreeVars are the free variables of the pattern,
+   -- of course excluding variables bound by this pattern
+
+rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat)
+
+{-
+*********************************************************
+*                                                      *
+        The main event
+*                                                      *
+*********************************************************
+-}
+
+-- ----------- Entry point 3: rnLPatAndThen -------------------
+-- General version: parametrized by how you make new names
+
+rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn]
+rnLPatsAndThen mk = mapM (rnLPatAndThen mk)
+  -- Despite the map, the monad ensures that each pattern binds
+  -- variables that may be mentioned in subsequent patterns in the list
+
+--------------------
+-- The workhorse
+rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)
+rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat
+
+rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)
+rnPatAndThen _  (WildPat _)   = return (WildPat noExt)
+rnPatAndThen mk (ParPat x pat)  = do { pat' <- rnLPatAndThen mk pat
+                                     ; return (ParPat x pat') }
+rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat
+                                     ; return (LazyPat x pat') }
+rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat
+                                     ; return (BangPat x pat') }
+rnPatAndThen mk (VarPat x (dL->L l rdr))
+    = do { loc <- liftCps getSrcSpanM
+         ; name <- newPatName mk (cL loc rdr)
+         ; return (VarPat x (cL l name)) }
+     -- we need to bind pattern variables for view pattern expressions
+     -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
+
+rnPatAndThen mk (SigPat x pat sig)
+  -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is
+  -- important to rename its type signature _before_ renaming the rest of the
+  -- pattern, so that type variables are first bound by the _outermost_ pattern
+  -- type signature they occur in. This keeps the type checker happy when
+  -- pattern type signatures happen to be nested (#7827)
+  --
+  -- f ((Just (x :: a) :: Maybe a)
+  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^       `a' is first bound here
+  -- ~~~~~~~~~~~~~~~^                   the same `a' then used here
+  = do { sig' <- rnHsSigCps sig
+       ; pat' <- rnLPatAndThen mk pat
+       ; return (SigPat x pat' sig' ) }
+
+rnPatAndThen mk (LitPat x lit)
+  | HsString src s <- lit
+  = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
+       ; if ovlStr
+         then rnPatAndThen mk
+                           (mkNPat (noLoc (mkHsIsString src s))
+                                      Nothing)
+         else normal_lit }
+  | otherwise = normal_lit
+  where
+    normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }
+
+rnPatAndThen _ (NPat x (dL->L l lit) mb_neg _eq)
+  = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit
+       ; mb_neg' -- See Note [Negative zero]
+           <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName
+                                ; return (Just neg, fvs) }
+                  positive = return (Nothing, emptyFVs)
+              in liftCpsFV $ case (mb_neg , mb_neg') of
+                                  (Nothing, Just _ ) -> negative
+                                  (Just _ , Nothing) -> negative
+                                  (Nothing, Nothing) -> positive
+                                  (Just _ , Just _ ) -> positive
+       ; eq' <- liftCpsFV $ lookupSyntaxName eqName
+       ; return (NPat x (cL l lit') mb_neg' eq') }
+
+rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ )
+  = do { new_name <- newPatName mk rdr
+       ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]
+                                                -- We skip negateName as
+                                                -- negative zero doesn't make
+                                                -- sense in n + k patterns
+       ; minus <- liftCpsFV $ lookupSyntaxName minusName
+       ; ge    <- liftCpsFV $ lookupSyntaxName geName
+       ; return (NPlusKPat x (cL (nameSrcSpan new_name) new_name)
+                             (cL l lit') lit' ge minus) }
+                -- The Report says that n+k patterns must be in Integral
+
+rnPatAndThen mk (AsPat x rdr pat)
+  = do { new_name <- newPatLName mk rdr
+       ; pat' <- rnLPatAndThen mk pat
+       ; return (AsPat x new_name pat') }
+
+rnPatAndThen mk p@(ViewPat x expr pat)
+  = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns
+                      ; checkErr vp_flag (badViewPat p) }
+         -- Because of the way we're arranging the recursive calls,
+         -- this will be in the right context
+       ; expr' <- liftCpsFV $ rnLExpr expr
+       ; pat' <- rnLPatAndThen mk pat
+       -- Note: at this point the PreTcType in ty can only be a placeHolder
+       -- ; return (ViewPat expr' pat' ty) }
+       ; return (ViewPat x expr' pat') }
+
+rnPatAndThen mk (ConPatIn con stuff)
+   -- rnConPatAndThen takes care of reconstructing the pattern
+   -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.
+  = case unLoc con == nameRdrName (dataConName nilDataCon) of
+      True    -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists
+                    ; if ol_flag then rnPatAndThen mk (ListPat noExt [])
+                                 else rnConPatAndThen mk con stuff}
+      False   -> rnConPatAndThen mk con stuff
+
+rnPatAndThen mk (ListPat _ pats)
+  = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists
+       ; pats' <- rnLPatsAndThen mk pats
+       ; case opt_OverloadedLists of
+          True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
+                     ; return (ListPat (Just to_list_name) pats')}
+          False -> return (ListPat Nothing pats') }
+
+rnPatAndThen mk (TuplePat x pats boxed)
+  = do { liftCps $ checkTupSize (length pats)
+       ; pats' <- rnLPatsAndThen mk pats
+       ; return (TuplePat x pats' boxed) }
+
+rnPatAndThen mk (SumPat x pat alt arity)
+  = do { pat <- rnLPatAndThen mk pat
+       ; return (SumPat x pat alt arity)
+       }
+
+-- If a splice has been run already, just rename the result.
+rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat)))
+  = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat
+
+rnPatAndThen mk (SplicePat _ splice)
+  = do { eith <- liftCpsFV $ rnSplicePat splice
+       ; case eith of   -- See Note [rnSplicePat] in RnSplice
+           Left  not_yet_renamed -> rnPatAndThen mk not_yet_renamed
+           Right already_renamed -> return already_renamed }
+
+rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat)
+
+
+--------------------
+rnConPatAndThen :: NameMaker
+                -> Located RdrName    -- the constructor
+                -> HsConPatDetails GhcPs
+                -> CpsRn (Pat GhcRn)
+
+rnConPatAndThen mk con (PrefixCon pats)
+  = do  { con' <- lookupConCps con
+        ; pats' <- rnLPatsAndThen mk pats
+        ; return (ConPatIn con' (PrefixCon pats')) }
+
+rnConPatAndThen mk con (InfixCon pat1 pat2)
+  = do  { con' <- lookupConCps con
+        ; pat1' <- rnLPatAndThen mk pat1
+        ; pat2' <- rnLPatAndThen mk pat2
+        ; fixity <- liftCps $ lookupFixityRn (unLoc con')
+        ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }
+
+rnConPatAndThen mk con (RecCon rpats)
+  = do  { con' <- lookupConCps con
+        ; rpats' <- rnHsRecPatsAndThen mk con' rpats
+        ; return (ConPatIn con' (RecCon rpats')) }
+
+--------------------
+rnHsRecPatsAndThen :: NameMaker
+                   -> Located Name      -- Constructor
+                   -> HsRecFields GhcPs (LPat GhcPs)
+                   -> CpsRn (HsRecFields GhcRn (LPat GhcRn))
+rnHsRecPatsAndThen mk (dL->L _ con)
+     hs_rec_fields@(HsRecFields { rec_dotdot = dd })
+  = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat
+                                            hs_rec_fields
+       ; flds' <- mapM rn_field (flds `zip` [1..])
+       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
+  where
+    mkVarPat l n = VarPat noExt (cL l n)
+    rn_field (dL->L l fld, n') =
+      do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)
+         ; return (cL l (fld { hsRecFieldArg = arg' })) }
+
+        -- Suppress unused-match reporting for fields introduced by ".."
+    nested_mk Nothing  mk                    _  = mk
+    nested_mk (Just _) mk@(LetMk {})         _  = mk
+    nested_mk (Just n) (LamMk report_unused) n' = LamMk (report_unused && (n' <= n))
+
+{-
+************************************************************************
+*                                                                      *
+        Record fields
+*                                                                      *
+************************************************************************
+-}
+
+data HsRecFieldContext
+  = HsRecFieldCon Name
+  | HsRecFieldPat Name
+  | HsRecFieldUpd
+
+rnHsRecFields
+    :: forall arg. HasSrcSpan arg =>
+       HsRecFieldContext
+    -> (SrcSpan -> RdrName -> SrcSpanLess arg)
+         -- When punning, use this to build a new field
+    -> HsRecFields GhcPs arg
+    -> RnM ([LHsRecField GhcRn arg], FreeVars)
+
+-- This surprisingly complicated pass
+--   a) looks up the field name (possibly using disambiguation)
+--   b) fills in puns and dot-dot stuff
+-- When we've finished, we've renamed the LHS, but not the RHS,
+-- of each x=e binding
+--
+-- This is used for record construction and pattern-matching, but not updates.
+
+rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
+  = do { pun_ok      <- xoptM LangExt.RecordPuns
+       ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields
+       ; let parent = guard disambig_ok >> mb_con
+       ; flds1  <- mapM (rn_fld pun_ok parent) flds
+       ; mapM_ (addErr . dupFieldErr ctxt) dup_flds
+       ; dotdot_flds <- rn_dotdot dotdot mb_con flds1
+       ; let all_flds | null dotdot_flds = flds1
+                      | otherwise        = flds1 ++ dotdot_flds
+       ; return (all_flds, mkFVs (getFieldIds all_flds)) }
+  where
+    mb_con = case ctxt of
+                HsRecFieldCon con  -> Just con
+                HsRecFieldPat con  -> Just con
+                _ {- update -}     -> Nothing
+
+    rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs arg
+           -> RnM (LHsRecField GhcRn arg)
+    rn_fld pun_ok parent (dL->L l
+                           (HsRecField
+                              { hsRecFieldLbl =
+                                  (dL->L loc (FieldOcc _ (dL->L ll lbl)))
+                              , hsRecFieldArg = arg
+                              , hsRecPun      = pun }))
+      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl
+           ; arg' <- if pun
+                     then do { checkErr pun_ok (badPun (cL loc lbl))
+                               -- Discard any module qualifier (#11662)
+                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
+                             ; return (cL loc (mk_arg loc arg_rdr)) }
+                     else return arg
+           ; return (cL l (HsRecField
+                             { hsRecFieldLbl = (cL loc (FieldOcc
+                                                          sel (cL ll lbl)))
+                             , hsRecFieldArg = arg'
+                             , hsRecPun      = pun })) }
+    rn_fld _ _ (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _))
+      = panic "rnHsRecFields"
+    rn_fld _ _ _ = panic "rn_fld: Impossible Match"
+                                -- due to #15884
+
+
+    rn_dotdot :: Maybe Int      -- See Note [DotDot fields] in HsPat
+              -> Maybe Name -- The constructor (Nothing for an
+                                --    out of scope constructor)
+              -> [LHsRecField GhcRn arg] -- Explicit fields
+              -> RnM [LHsRecField GhcRn arg]   -- Filled in .. fields
+    rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match
+      | not (isUnboundName con) -- This test is because if the constructor
+                                -- isn't in scope the constructor lookup will add
+                                -- an error but still return an unbound name. We
+                                -- don't want that to screw up the dot-dot fill-in stuff.
+      = ASSERT( flds `lengthIs` n )
+        do { loc <- getSrcSpanM -- Rather approximate
+           ; dd_flag <- xoptM LangExt.RecordWildCards
+           ; checkErr dd_flag (needFlagDotDot ctxt)
+           ; (rdr_env, lcl_env) <- getRdrEnvs
+           ; con_fields <- lookupConstructorFields con
+           ; when (null con_fields) (addErr (badDotDotCon con))
+           ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)
+
+                   -- For constructor uses (but not patterns)
+                   -- the arg should be in scope locally;
+                   -- i.e. not top level or imported
+                   -- Eg.  data R = R { x,y :: Int }
+                   --      f x = R { .. }   -- Should expand to R {x=x}, not R{x=x,y=y}
+                 arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env
+
+                 (dot_dot_fields, dot_dot_gres)
+                        = unzip [ (fl, gre)
+                                | fl <- con_fields
+                                , let lbl = mkVarOccFS (flLabel fl)
+                                , not (lbl `elemOccSet` present_flds)
+                                , Just gre <- [lookupGRE_FieldLabel rdr_env fl]
+                                              -- Check selector is in scope
+                                , case ctxt of
+                                    HsRecFieldCon {} -> arg_in_scope lbl
+                                    _other           -> True ]
+
+           ; addUsedGREs dot_dot_gres
+           ; return [ cL loc (HsRecField
+                        { hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr))
+                        , hsRecFieldArg = cL loc (mk_arg loc arg_rdr)
+                        , hsRecPun      = False })
+                    | fl <- dot_dot_fields
+                    , let sel     = flSelector fl
+                    , let arg_rdr = mkVarUnqual (flLabel fl) ] }
+
+    rn_dotdot _dotdot _mb_con _flds
+      = return []
+      -- _dotdot = Nothing => No ".." at all
+      -- _mb_con = Nothing => Record update
+      -- _mb_con = Just unbound => Out of scope data constructor
+
+    dup_flds :: [NE.NonEmpty RdrName]
+        -- Each list represents a RdrName that occurred more than once
+        -- (the list contains all occurrences)
+        -- Each list in dup_fields is non-empty
+    (_, dup_flds) = removeDups compare (getFieldLbls flds)
+
+
+-- NB: Consider this:
+--      module Foo where { data R = R { fld :: Int } }
+--      module Odd where { import Foo; fld x = x { fld = 3 } }
+-- Arguably this should work, because the reference to 'fld' is
+-- unambiguous because there is only one field id 'fld' in scope.
+-- But currently it's rejected.
+
+rnHsRecUpdFields
+    :: [LHsRecUpdField GhcPs]
+    -> RnM ([LHsRecUpdField GhcRn], FreeVars)
+rnHsRecUpdFields flds
+  = do { pun_ok        <- xoptM LangExt.RecordPuns
+       ; overload_ok   <- xoptM LangExt.DuplicateRecordFields
+       ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds
+       ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds
+
+       -- Check for an empty record update  e {}
+       -- NB: don't complain about e { .. }, because rn_dotdot has done that already
+       ; when (null flds) $ addErr emptyUpdateErr
+
+       ; return (flds1, plusFVs fvss) }
+  where
+    doc = text "constructor field name"
+
+    rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs
+           -> RnM (LHsRecUpdField GhcRn, FreeVars)
+    rn_fld pun_ok overload_ok (dL->L l (HsRecField { hsRecFieldLbl = dL->L loc f
+                                                   , hsRecFieldArg = arg
+                                                   , hsRecPun      = pun }))
+      = do { let lbl = rdrNameAmbiguousFieldOcc f
+           ; sel <- setSrcSpan loc $
+                      -- Defer renaming of overloaded fields to the typechecker
+                      -- See Note [Disambiguating record fields] in TcExpr
+                      if overload_ok
+                          then do { mb <- lookupGlobalOccRn_overloaded
+                                            overload_ok lbl
+                                  ; case mb of
+                                      Nothing ->
+                                        do { addErr
+                                               (unknownSubordinateErr doc lbl)
+                                           ; return (Right []) }
+                                      Just r  -> return r }
+                          else fmap Left $ lookupGlobalOccRn lbl
+           ; arg' <- if pun
+                     then do { checkErr pun_ok (badPun (cL loc lbl))
+                               -- Discard any module qualifier (#11662)
+                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)
+                             ; return (cL loc (HsVar noExt (cL loc arg_rdr))) }
+                     else return arg
+           ; (arg'', fvs) <- rnLExpr arg'
+
+           ; let fvs' = case sel of
+                          Left sel_name -> fvs `addOneFV` sel_name
+                          Right [sel_name] -> fvs `addOneFV` sel_name
+                          Right _       -> fvs
+                 lbl' = case sel of
+                          Left sel_name ->
+                                     cL loc (Unambiguous sel_name  (cL loc lbl))
+                          Right [sel_name] ->
+                                     cL loc (Unambiguous sel_name  (cL loc lbl))
+                          Right _ -> cL loc (Ambiguous   noExt     (cL loc lbl))
+
+           ; return (cL l (HsRecField { hsRecFieldLbl = lbl'
+                                      , hsRecFieldArg = arg''
+                                      , hsRecPun      = pun }), fvs') }
+
+    dup_flds :: [NE.NonEmpty RdrName]
+        -- Each list represents a RdrName that occurred more than once
+        -- (the list contains all occurrences)
+        -- Each list in dup_fields is non-empty
+    (_, dup_flds) = removeDups compare (getFieldUpdLbls flds)
+
+
+
+getFieldIds :: [LHsRecField GhcRn arg] -> [Name]
+getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds
+
+getFieldLbls :: [LHsRecField id arg] -> [RdrName]
+getFieldLbls flds
+  = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
+
+getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]
+getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds
+
+needFlagDotDot :: HsRecFieldContext -> SDoc
+needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt,
+                            text "Use RecordWildCards to permit this"]
+
+badDotDotCon :: Name -> SDoc
+badDotDotCon con
+  = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)
+         , nest 2 (text "The constructor has no labelled fields") ]
+
+emptyUpdateErr :: SDoc
+emptyUpdateErr = text "Empty record update"
+
+badPun :: Located RdrName -> SDoc
+badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),
+                   text "Use NamedFieldPuns to permit this"]
+
+dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc
+dupFieldErr ctxt dups
+  = hsep [text "duplicate field name",
+          quotes (ppr (NE.head dups)),
+          text "in record", pprRFC ctxt]
+
+pprRFC :: HsRecFieldContext -> SDoc
+pprRFC (HsRecFieldCon {}) = text "construction"
+pprRFC (HsRecFieldPat {}) = text "pattern"
+pprRFC (HsRecFieldUpd {}) = text "update"
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{Literals}
+*                                                                      *
+************************************************************************
+
+When literals occur we have to make sure
+that the types and classes they involve
+are made available.
+-}
+
+rnLit :: HsLit p -> RnM ()
+rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c)
+rnLit _ = return ()
+
+-- Turn a Fractional-looking literal which happens to be an integer into an
+-- Integer-looking literal.
+generalizeOverLitVal :: OverLitVal -> OverLitVal
+generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val}))
+    | denominator val == 1 = HsIntegral (IL { il_text=src
+                                            , il_neg=neg
+                                            , il_value=numerator val})
+generalizeOverLitVal lit = lit
+
+isNegativeZeroOverLit :: HsOverLit t -> Bool
+isNegativeZeroOverLit lit
+ = case ol_val lit of
+        HsIntegral i   -> 0 == il_value i && il_neg i
+        HsFractional f -> 0 == fl_value f && fl_neg f
+        _              -> False
+
+{-
+Note [Negative zero]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+There were problems with negative zero in conjunction with Negative Literals
+extension. Numeric literal value is contained in Integer and Rational types
+inside IntegralLit and FractionalLit. These types cannot represent negative
+zero value. So we had to add explicit field 'neg' which would hold information
+about literal sign. Here in rnOverLit we use it to detect negative zeroes and
+in this case return not only literal itself but also negateName so that users
+can apply it explicitly. In this case it stays negative zero.  Trac #13211
+-}
+
+rnOverLit :: HsOverLit t ->
+             RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)
+rnOverLit origLit
+  = do  { opt_NumDecimals <- xoptM LangExt.NumDecimals
+        ; let { lit@(OverLit {ol_val=val})
+            | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)}
+            | otherwise       = origLit
+          }
+        ; let std_name = hsOverLitName val
+        ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1)
+            <- lookupSyntaxName std_name
+        ; let rebindable = case from_thing_name of
+                                HsVar _ lv -> (unLoc lv) /= std_name
+                                _          -> panic "rnOverLit"
+        ; let lit' = lit { ol_witness = from_thing_name
+                         , ol_ext = rebindable }
+        ; if isNegativeZeroOverLit lit'
+          then do { (SyntaxExpr { syn_expr = negate_name }, fvs2)
+                      <- lookupSyntaxName negateName
+                  ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
+                                  , fvs1 `plusFV` fvs2) }
+          else return ((lit', Nothing), fvs1) }
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{Errors}
+*                                                                      *
+************************************************************************
+-}
+
+patSigErr :: Outputable a => a -> SDoc
+patSigErr ty
+  =  (text "Illegal signature in pattern:" <+> ppr ty)
+        $$ nest 4 (text "Use ScopedTypeVariables to permit it")
+
+bogusCharError :: Char -> SDoc
+bogusCharError c
+  = text "character literal out of range: '\\" <> char c  <> char '\''
+
+badViewPat :: Pat GhcPs -> SDoc
+badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat,
+                       text "Use ViewPatterns to enable view patterns"]
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnSource.hs
@@ -0,0 +1,2384 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[RnSource]{Main pass of renamer}
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module RnSource (
+        rnSrcDecls, addTcgDUs, findSplice
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-} RnExpr( rnLExpr )
+import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls )
+
+import HsSyn
+import FieldLabel
+import RdrName
+import RnTypes
+import RnBinds
+import RnEnv
+import RnUtils          ( HsDocContext(..), mapFvRn, bindLocalNames
+                        , checkDupRdrNames, inHsDocContext, bindLocalNamesFV
+                        , checkShadowedRdrNames, warnUnusedTypePatterns
+                        , extendTyVarEnvFVRn, newLocalBndrsRn
+                        , withHsDocContext )
+import RnUnbound        ( mkUnboundName, notInScopeErr )
+import RnNames
+import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
+import TcAnnotations    ( annCtxt )
+import TcRnMonad
+
+import ForeignCall      ( CCallTarget(..) )
+import Module
+import HscTypes         ( Warnings(..), plusWarns )
+import PrelNames        ( applicativeClassName, pureAName, thenAName
+                        , monadClassName, returnMName, thenMName
+                        , semigroupClassName, sappendName
+                        , monoidClassName, mappendName
+                        )
+import Name
+import NameSet
+import NameEnv
+import Avail
+import Outputable
+import Bag
+import BasicTypes       ( pprRuleName )
+import FastString
+import SrcLoc
+import DynFlags
+import Util             ( debugIsOn, filterOut, lengthExceeds, partitionWith )
+import HscTypes         ( HscEnv, hsc_dflags )
+import ListSetOps       ( findDupsEq, removeDups, equivClasses )
+import Digraph          ( SCC, flattenSCC, flattenSCCs, Node(..)
+                        , stronglyConnCompFromEdgedVerticesUniq )
+import UniqSet
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Control.Arrow ( first )
+import Data.List ( mapAccumL )
+import qualified Data.List.NonEmpty as NE
+import Data.List.NonEmpty ( NonEmpty(..) )
+import Data.Maybe ( isNothing, fromMaybe )
+import qualified Data.Set as Set ( difference, fromList, toList, null )
+
+{- | @rnSourceDecl@ "renames" declarations.
+It simultaneously performs dependency analysis and precedence parsing.
+It also does the following error checks:
+
+* Checks that tyvars are used properly. This includes checking
+  for undefined tyvars, and tyvars in contexts that are ambiguous.
+  (Some of this checking has now been moved to module @TcMonoType@,
+  since we don't have functional dependency information at this point.)
+
+* Checks that all variable occurrences are defined.
+
+* Checks the @(..)@ etc constraints in the export list.
+
+Brings the binders of the group into scope in the appropriate places;
+does NOT assume that anything is in scope already
+-}
+rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn)
+-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files
+rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
+                            hs_splcds  = splice_decls,
+                            hs_tyclds  = tycl_decls,
+                            hs_derivds = deriv_decls,
+                            hs_fixds   = fix_decls,
+                            hs_warnds  = warn_decls,
+                            hs_annds   = ann_decls,
+                            hs_fords   = foreign_decls,
+                            hs_defds   = default_decls,
+                            hs_ruleds  = rule_decls,
+                            hs_docs    = docs })
+ = do {
+   -- (A) Process the fixity declarations, creating a mapping from
+   --     FastStrings to FixItems.
+   --     Also checks for duplicates.
+   local_fix_env <- makeMiniFixityEnv fix_decls ;
+
+   -- (B) Bring top level binders (and their fixities) into scope,
+   --     *except* for the value bindings, which get done in step (D)
+   --     with collectHsIdBinders. However *do* include
+   --
+   --        * Class ops, data constructors, and record fields,
+   --          because they do not have value declarations.
+   --
+   --        * For hs-boot files, include the value signatures
+   --          Again, they have no value declarations
+   --
+   (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
+
+
+   setEnvs tc_envs $ do {
+
+   failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
+
+   -- (D1) Bring pattern synonyms into scope.
+   --      Need to do this before (D2) because rnTopBindsLHS
+   --      looks up those pattern synonyms (Trac #9889)
+
+   extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do {
+
+   -- (D2) Rename the left-hand sides of the value bindings.
+   --     This depends on everything from (B) being in scope.
+   --     It uses the fixity env from (A) to bind fixities for view patterns.
+   new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
+
+   -- Bind the LHSes (and their fixities) in the global rdr environment
+   let { id_bndrs = collectHsIdBinders new_lhs } ;  -- Excludes pattern-synonym binders
+                                                    -- They are already in scope
+   traceRn "rnSrcDecls" (ppr id_bndrs) ;
+   tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
+   setEnvs tc_envs $ do {
+
+   --  Now everything is in scope, as the remaining renaming assumes.
+
+   -- (E) Rename type and class decls
+   --     (note that value LHSes need to be in scope for default methods)
+   --
+   -- You might think that we could build proper def/use information
+   -- for type and class declarations, but they can be involved
+   -- in mutual recursion across modules, and we only do the SCC
+   -- analysis for them in the type checker.
+   -- So we content ourselves with gathering uses only; that
+   -- means we'll only report a declaration as unused if it isn't
+   -- mentioned at all.  Ah well.
+   traceRn "Start rnTyClDecls" (ppr tycl_decls) ;
+   (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
+
+   -- (F) Rename Value declarations right-hand sides
+   traceRn "Start rnmono" empty ;
+   let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
+   is_boot <- tcIsHsBootOrSig ;
+   (rn_val_decls, bind_dus) <- if is_boot
+    -- For an hs-boot, use tc_bndrs (which collects how we're renamed
+    -- signatures), since val_bndr_set is empty (there are no x = ...
+    -- bindings in an hs-boot.)
+    then rnTopBindsBoot tc_bndrs new_lhs
+    else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ;
+   traceRn "finish rnmono" (ppr rn_val_decls) ;
+
+   -- (G) Rename Fixity and deprecations
+
+   -- Rename fixity declarations and error if we try to
+   -- fix something from another module (duplicates were checked in (A))
+   let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;
+   rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs)))
+                        fix_decls ;
+
+   -- Rename deprec decls;
+   -- check for duplicates and ensure that deprecated things are defined locally
+   -- at the moment, we don't keep these around past renaming
+   rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
+
+   -- (H) Rename Everything else
+
+   (rn_rule_decls,    src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $
+                                   rnList rnHsRuleDecls rule_decls ;
+                           -- Inside RULES, scoped type variables are on
+   (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ;
+   (rn_ann_decls,     src_fvs4) <- rnList rnAnnDecl       ann_decls ;
+   (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl   default_decls ;
+   (rn_deriv_decls,   src_fvs6) <- rnList rnSrcDerivDecl  deriv_decls ;
+   (rn_splice_decls,  src_fvs7) <- rnList rnSpliceDecl    splice_decls ;
+      -- Haddock docs; no free vars
+   rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
+
+   last_tcg_env <- getGblEnv ;
+   -- (I) Compute the results and return
+   let {rn_group = HsGroup { hs_ext     = noExt,
+                             hs_valds   = rn_val_decls,
+                             hs_splcds  = rn_splice_decls,
+                             hs_tyclds  = rn_tycl_decls,
+                             hs_derivds = rn_deriv_decls,
+                             hs_fixds   = rn_fix_decls,
+                             hs_warnds  = [], -- warns are returned in the tcg_env
+                                             -- (see below) not in the HsGroup
+                             hs_fords  = rn_foreign_decls,
+                             hs_annds  = rn_ann_decls,
+                             hs_defds  = rn_default_decls,
+                             hs_ruleds = rn_rule_decls,
+                             hs_docs   = rn_docs } ;
+
+        tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;
+        other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
+        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
+                              src_fvs5, src_fvs6, src_fvs7] ;
+                -- It is tiresome to gather the binders from type and class decls
+
+        src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
+                -- Instance decls may have occurrences of things bound in bind_dus
+                -- so we must put other_fvs last
+
+        final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
+                        in -- we return the deprecs in the env, not in the HsGroup above
+                        tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
+       } ;
+   traceRn "finish rnSrc" (ppr rn_group) ;
+   traceRn "finish Dus" (ppr src_dus ) ;
+   return (final_tcg_env, rn_group)
+                    }}}}
+rnSrcDecls (XHsGroup _) = panic "rnSrcDecls"
+
+addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
+-- This function could be defined lower down in the module hierarchy,
+-- but there doesn't seem anywhere very logical to put it.
+addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
+
+rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
+rnList f xs = mapFvRn (wrapLocFstM f) xs
+
+{-
+*********************************************************
+*                                                       *
+        HsDoc stuff
+*                                                       *
+*********************************************************
+-}
+
+rnDocDecl :: DocDecl -> RnM DocDecl
+rnDocDecl (DocCommentNext doc) = do
+  rn_doc <- rnHsDoc doc
+  return (DocCommentNext rn_doc)
+rnDocDecl (DocCommentPrev doc) = do
+  rn_doc <- rnHsDoc doc
+  return (DocCommentPrev rn_doc)
+rnDocDecl (DocCommentNamed str doc) = do
+  rn_doc <- rnHsDoc doc
+  return (DocCommentNamed str rn_doc)
+rnDocDecl (DocGroup lev doc) = do
+  rn_doc <- rnHsDoc doc
+  return (DocGroup lev rn_doc)
+
+{-
+*********************************************************
+*                                                       *
+        Source-code deprecations declarations
+*                                                       *
+*********************************************************
+
+Check that the deprecated names are defined, are defined locally, and
+that there are no duplicate deprecations.
+
+It's only imported deprecations, dealt with in RnIfaces, that we
+gather them together.
+-}
+
+-- checks that the deprecations are defined locally, and that there are no duplicates
+rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings
+rnSrcWarnDecls _ []
+  = return NoWarnings
+
+rnSrcWarnDecls bndr_set decls'
+  = do { -- check for duplicates
+       ; mapM_ (\ dups -> let ((dL->L loc rdr) :| (lrdr':_)) = dups
+                          in addErrAt loc (dupWarnDecl lrdr' rdr))
+               warn_rdr_dups
+       ; pairs_s <- mapM (addLocM rn_deprec) decls
+       ; return (WarnSome ((concat pairs_s))) }
+ where
+   decls = concatMap (wd_warnings . unLoc) decls'
+
+   sig_ctxt = TopSigCtxt bndr_set
+
+   rn_deprec (Warning _ rdr_names txt)
+       -- ensures that the names are defined locally
+     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
+                                rdr_names
+          ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
+   rn_deprec (XWarnDecl _) = panic "rnSrcWarnDecls"
+
+   what = text "deprecation"
+
+   warn_rdr_dups = findDupRdrNames
+                   $ concatMap (\(dL->L _ (Warning _ ns _)) -> ns) decls
+
+findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]
+findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
+
+-- look for duplicates among the OccNames;
+-- we check that the names are defined above
+-- invt: the lists returned by findDupsEq always have at least two elements
+
+dupWarnDecl :: Located RdrName -> RdrName -> SDoc
+-- Located RdrName -> DeprecDecl RdrName -> SDoc
+dupWarnDecl d rdr_name
+  = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),
+          text "also at " <+> ppr (getLoc d)]
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Annotation declarations}
+*                                                      *
+*********************************************************
+-}
+
+rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
+rnAnnDecl ann@(HsAnnotation _ s provenance expr)
+  = addErrCtxt (annCtxt ann) $
+    do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
+       ; (expr', expr_fvs) <- setStage (Splice Untyped) $
+                              rnLExpr expr
+       ; return (HsAnnotation noExt s provenance' expr',
+                 provenance_fvs `plusFV` expr_fvs) }
+rnAnnDecl (XAnnDecl _) = panic "rnAnnDecl"
+
+rnAnnProvenance :: AnnProvenance RdrName
+                -> RnM (AnnProvenance Name, FreeVars)
+rnAnnProvenance provenance = do
+    provenance' <- traverse lookupTopBndrRn provenance
+    return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Default declarations}
+*                                                      *
+*********************************************************
+-}
+
+rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
+rnDefaultDecl (DefaultDecl _ tys)
+  = do { (tys', fvs) <- rnLHsTypes doc_str tys
+       ; return (DefaultDecl noExt tys', fvs) }
+  where
+    doc_str = DefaultDeclCtx
+rnDefaultDecl (XDefaultDecl _) = panic "rnDefaultDecl"
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Foreign declarations}
+*                                                      *
+*********************************************************
+-}
+
+rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
+rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
+  = do { topEnv :: HscEnv <- getTopEnv
+       ; name' <- lookupLocatedTopBndrRn name
+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
+
+        -- Mark any PackageTarget style imports as coming from the current package
+       ; let unitId = thisPackage $ hsc_dflags topEnv
+             spec'      = patchForeignImport unitId spec
+
+       ; return (ForeignImport { fd_i_ext = noExt
+                               , fd_name = name', fd_sig_ty = ty'
+                               , fd_fi = spec' }, fvs) }
+
+rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
+  = do { name' <- lookupLocatedOccRn name
+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
+       ; return (ForeignExport { fd_e_ext = noExt
+                               , fd_name = name', fd_sig_ty = ty'
+                               , fd_fe = spec }
+                , fvs `addOneFV` unLoc name') }
+        -- NB: a foreign export is an *occurrence site* for name, so
+        --     we add it to the free-variable list.  It might, for example,
+        --     be imported from another module
+
+rnHsForeignDecl (XForeignDecl _) = panic "rnHsForeignDecl"
+
+-- | For Windows DLLs we need to know what packages imported symbols are from
+--      to generate correct calls. Imported symbols are tagged with the current
+--      package, so if they get inlined across a package boundary we'll still
+--      know where they're from.
+--
+patchForeignImport :: UnitId -> ForeignImport -> ForeignImport
+patchForeignImport unitId (CImport cconv safety fs spec src)
+        = CImport cconv safety fs (patchCImportSpec unitId spec) src
+
+patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec
+patchCImportSpec unitId spec
+ = case spec of
+        CFunction callTarget    -> CFunction $ patchCCallTarget unitId callTarget
+        _                       -> spec
+
+patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget
+patchCCallTarget unitId callTarget =
+  case callTarget of
+  StaticTarget src label Nothing isFun
+                              -> StaticTarget src label (Just unitId) isFun
+  _                           -> callTarget
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Instance declarations}
+*                                                      *
+*********************************************************
+-}
+
+rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
+rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
+  = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
+       ; return (TyFamInstD { tfid_ext = noExt, tfid_inst = tfi' }, fvs) }
+
+rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
+  = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
+       ; return (DataFamInstD { dfid_ext = noExt, dfid_inst = dfi' }, fvs) }
+
+rnSrcInstDecl (ClsInstD { cid_inst = cid })
+  = do { traceRn "rnSrcIstDecl {" (ppr cid)
+       ; (cid', fvs) <- rnClsInstDecl cid
+       ; traceRn "rnSrcIstDecl end }" empty
+       ; return (ClsInstD { cid_d_ext = noExt, cid_inst = cid' }, fvs) }
+
+rnSrcInstDecl (XInstDecl _) = panic "rnSrcInstDecl"
+
+-- | Warn about non-canonical typeclass instance declarations
+--
+-- A "non-canonical" instance definition can occur for instances of a
+-- class which redundantly defines an operation its superclass
+-- provides as well (c.f. `return`/`pure`). In such cases, a canonical
+-- instance is one where the subclass inherits its method
+-- implementation from its superclass instance (usually the subclass
+-- has a default method implementation to that effect). Consequently,
+-- a non-canonical instance occurs when this is not the case.
+--
+-- See also descriptions of 'checkCanonicalMonadInstances' and
+-- 'checkCanonicalMonoidInstances'
+checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()
+checkCanonicalInstances cls poly_ty mbinds = do
+    whenWOptM Opt_WarnNonCanonicalMonadInstances
+        checkCanonicalMonadInstances
+
+    whenWOptM Opt_WarnNonCanonicalMonoidInstances
+        checkCanonicalMonoidInstances
+
+  where
+    -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance
+    -- declarations. Specifically, the following conditions are verified:
+    --
+    -- In 'Monad' instances declarations:
+    --
+    --  * If 'return' is overridden it must be canonical (i.e. @return = pure@)
+    --  * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@)
+    --
+    -- In 'Applicative' instance declarations:
+    --
+    --  * Warn if 'pure' is defined backwards (i.e. @pure = return@).
+    --  * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
+    --
+    checkCanonicalMonadInstances
+      | cls == applicativeClassName  = do
+          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
+              case mbind of
+                  FunBind { fun_id = (dL->L _ name)
+                          , fun_matches = mg }
+                      | name == pureAName, isAliasMG mg == Just returnMName
+                      -> addWarnNonCanonicalMethod1
+                            Opt_WarnNonCanonicalMonadInstances "pure" "return"
+
+                      | name == thenAName, isAliasMG mg == Just thenMName
+                      -> addWarnNonCanonicalMethod1
+                            Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"
+
+                  _ -> return ()
+
+      | cls == monadClassName  = do
+          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
+              case mbind of
+                  FunBind { fun_id = (dL->L _ name)
+                          , fun_matches = mg }
+                      | name == returnMName, isAliasMG mg /= Just pureAName
+                      -> addWarnNonCanonicalMethod2
+                            Opt_WarnNonCanonicalMonadInstances "return" "pure"
+
+                      | name == thenMName, isAliasMG mg /= Just thenAName
+                      -> addWarnNonCanonicalMethod2
+                            Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"
+
+                  _ -> return ()
+
+      | otherwise = return ()
+
+    -- | Check whether Monoid(mappend) is defined in terms of
+    -- Semigroup((<>)) (and not the other way round). Specifically,
+    -- the following conditions are verified:
+    --
+    -- In 'Monoid' instances declarations:
+    --
+    --  * If 'mappend' is overridden it must be canonical
+    --    (i.e. @mappend = (<>)@)
+    --
+    -- In 'Semigroup' instance declarations:
+    --
+    --  * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).
+    --
+    checkCanonicalMonoidInstances
+      | cls == semigroupClassName  = do
+          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
+              case mbind of
+                  FunBind { fun_id      = (dL->L _ name)
+                          , fun_matches = mg }
+                      | name == sappendName, isAliasMG mg == Just mappendName
+                      -> addWarnNonCanonicalMethod1
+                            Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"
+
+                  _ -> return ()
+
+      | cls == monoidClassName  = do
+          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do
+              case mbind of
+                  FunBind { fun_id = (dL->L _ name)
+                          , fun_matches = mg }
+                      | name == mappendName, isAliasMG mg /= Just sappendName
+                      -> addWarnNonCanonicalMethod2NoDefault
+                            Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"
+
+                  _ -> return ()
+
+      | otherwise = return ()
+
+    -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"
+    -- binding, and return @Just rhsName@ if this is the case
+    isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
+    isAliasMG MG {mg_alts = (dL->L _
+                             [dL->L _ (Match { m_pats = []
+                                             , m_grhss = grhss })])}
+        | GRHSs _ [dL->L _ (GRHS _ [] body)] lbinds <- grhss
+        , EmptyLocalBinds _ <- unLoc lbinds
+        , HsVar _ lrhsName  <- unLoc body  = Just (unLoc lrhsName)
+    isAliasMG _ = Nothing
+
+    -- got "lhs = rhs" but expected something different
+    addWarnNonCanonicalMethod1 flag lhs rhs = do
+        addWarn (Reason flag) $ vcat
+                       [ text "Noncanonical" <+>
+                         quotes (text (lhs ++ " = " ++ rhs)) <+>
+                         text "definition detected"
+                       , instDeclCtxt1 poly_ty
+                       , text "Move definition from" <+>
+                         quotes (text rhs) <+>
+                         text "to" <+> quotes (text lhs)
+                       ]
+
+    -- expected "lhs = rhs" but got something else
+    addWarnNonCanonicalMethod2 flag lhs rhs = do
+        addWarn (Reason flag) $ vcat
+                       [ text "Noncanonical" <+>
+                         quotes (text lhs) <+>
+                         text "definition detected"
+                       , instDeclCtxt1 poly_ty
+                       , text "Either remove definition for" <+>
+                         quotes (text lhs) <+> text "or define as" <+>
+                         quotes (text (lhs ++ " = " ++ rhs))
+                       ]
+
+    -- like above, but method has no default impl
+    addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do
+        addWarn (Reason flag) $ vcat
+                       [ text "Noncanonical" <+>
+                         quotes (text lhs) <+>
+                         text "definition detected"
+                       , instDeclCtxt1 poly_ty
+                       , text "Define as" <+>
+                         quotes (text (lhs ++ " = " ++ rhs))
+                       ]
+
+    -- stolen from TcInstDcls
+    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
+    instDeclCtxt1 hs_inst_ty
+      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
+
+    inst_decl_ctxt :: SDoc -> SDoc
+    inst_decl_ctxt doc = hang (text "in the instance declaration for")
+                         2 (quotes doc <> text ".")
+
+
+rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
+rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
+                           , cid_sigs = uprags, cid_tyfam_insts = ats
+                           , cid_overlap_mode = oflag
+                           , cid_datafam_insts = adts })
+  = do { (inst_ty', inst_fvs)
+           <- rnHsSigType (GenericCtx $ text "an instance declaration") inst_ty
+       ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
+       ; cls <-
+           case hsTyGetAppHead_maybe head_ty' of
+             Just (dL->L _ cls) -> pure cls
+             Nothing -> do
+               -- The instance is malformed. We'd still like
+               -- to make *some* progress (rather than failing outright), so
+               -- we report an error and continue for as long as we can.
+               -- Importantly, this error should be thrown before we reach the
+               -- typechecker, lest we encounter different errors that are
+               -- hopelessly confusing (such as the one in Trac #16114).
+               addErrAt (getLoc (hsSigType inst_ty)) $
+                 hang (text "Illegal class instance:" <+> quotes (ppr inst_ty))
+                    2 (vcat [ text "Class instances must be of the form"
+                            , nest 2 $ text "context => C ty_1 ... ty_n"
+                            , text "where" <+> quotes (char 'C')
+                              <+> text "is a class"
+                            ])
+               pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))
+
+          -- Rename the bindings
+          -- The typechecker (not the renamer) checks that all
+          -- the bindings are for the right class
+          -- (Slightly strangely) when scoped type variables are on, the
+          -- forall-d tyvars scope over the method bindings too
+       ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags
+
+       ; checkCanonicalInstances cls inst_ty' mbinds'
+
+       -- Rename the associated types, and type signatures
+       -- Both need to have the instance type variables in scope
+       ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)
+       ; ((ats', adts'), more_fvs)
+             <- extendTyVarEnvFVRn ktv_names $
+                do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats
+                   ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts
+                   ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }
+
+       ; let all_fvs = meth_fvs `plusFV` more_fvs
+                                `plusFV` inst_fvs
+       ; return (ClsInstDecl { cid_ext = noExt
+                             , cid_poly_ty = inst_ty', cid_binds = mbinds'
+                             , cid_sigs = uprags', cid_tyfam_insts = ats'
+                             , cid_overlap_mode = oflag
+                             , cid_datafam_insts = adts' },
+                 all_fvs) }
+             -- We return the renamed associated data type declarations so
+             -- that they can be entered into the list of type declarations
+             -- for the binding group, but we also keep a copy in the instance.
+             -- The latter is needed for well-formedness checks in the type
+             -- checker (eg, to ensure that all ATs of the instance actually
+             -- receive a declaration).
+             -- NB: Even the copies in the instance declaration carry copies of
+             --     the instance context after renaming.  This is a bit
+             --     strange, but should not matter (and it would be more work
+             --     to remove the context).
+rnClsInstDecl (XClsInstDecl _) = panic "rnClsInstDecl"
+
+rnFamInstEqn :: HsDocContext
+             -> Maybe (Name, [Name]) -- Nothing => not associated
+                                     -- Just (cls,tvs) => associated,
+                                     --   and gives class and tyvars of the
+                                     --   parent instance decl
+             -> [Located RdrName]    -- Kind variables from the equation's RHS
+             -> FamInstEqn GhcPs rhs
+             -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
+             -> RnM (FamInstEqn GhcRn rhs', FreeVars)
+rnFamInstEqn doc mb_cls rhs_kvars
+    (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon
+                               , feqn_bndrs  = mb_bndrs
+                               , feqn_pats   = pats
+                               , feqn_fixity = fixity
+                               , feqn_rhs    = payload }}) rn_payload
+  = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
+       ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats
+             -- Use the "...Dups" form because it's needed
+             -- below to report unsed binder on the LHS
+       ; let pat_kity_vars = rmDupsInRdrTyVars pat_kity_vars_with_dups
+
+         -- all pat vars not explicitly bound (see extractHsTvBndrs)
+       ; let mb_imp_kity_vars = extractHsTvBndrs <$> mb_bndrs <*> pure pat_kity_vars
+             imp_vars = case mb_imp_kity_vars of
+                          -- kind vars are the only ones free if we have an explicit forall
+                          Just nbnd_kity_vars -> freeKiTyVarsKindVars nbnd_kity_vars
+                          -- all pattern vars are free otherwise
+                          Nothing             -> freeKiTyVarsAllVars pat_kity_vars
+       ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars
+
+       ; let bndrs = fromMaybe [] mb_bndrs
+             bnd_vars = map hsLTyVarLocName bndrs
+             payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars
+             -- Make sure to filter out the kind variables that were explicitly
+             -- bound in the type patterns.
+       ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars
+
+         -- all names not bound in an explict forall
+       ; let all_imp_var_names = imp_var_names ++ payload_kvar_names
+
+             -- All the free vars of the family patterns
+             -- with a sensible binding location
+       ; ((bndrs', pats', payload'), fvs)
+              <- bindLocalNamesFV all_imp_var_names $
+                 bindLHsTyVarBndrs doc (Just $ inHsDocContext doc)
+                                   Nothing bndrs $ \bndrs' ->
+                 -- Note: If we pass mb_cls instead of Nothing here,
+                 --  bindLHsTyVarBndrs will use class variables for any names
+                 --  the user meant to bring in scope here. This is an explicit
+                 --  forall, so we want fresh names, not class variables.
+                 --  Thus: always pass Nothing
+                 do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats
+                    ; (payload', rhs_fvs) <- rn_payload doc payload
+
+                       -- Report unused binders on the LHS
+                       -- See Note [Unused type variables in family instances]
+                    ; let groups :: [NonEmpty (Located RdrName)]
+                          groups = equivClasses cmpLocated $
+                                   freeKiTyVarsAllVars pat_kity_vars_with_dups
+                    ; nms_dups <- mapM (lookupOccRn . unLoc) $
+                                     [ tv | (tv :| (_:_)) <- groups ]
+                          -- Add to the used variables
+                          --  a) any variables that appear *more than once* on the LHS
+                          --     e.g.   F a Int a = Bool
+                          --  b) for associated instances, the variables
+                          --     of the instance decl.  See
+                          --     Note [Unused type variables in family instances]
+                    ; let nms_used = extendNameSetList rhs_fvs $
+                                        inst_tvs ++ nms_dups
+                          inst_tvs = case mb_cls of
+                                       Nothing            -> []
+                                       Just (_, inst_tvs) -> inst_tvs
+                          all_nms = all_imp_var_names
+                                      ++ map hsLTyVarName bndrs'
+                    ; warnUnusedTypePatterns all_nms nms_used
+
+                    ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) }
+
+       ; let all_fvs  = fvs `addOneFV` unLoc tycon'
+            -- type instance => use, hence addOneFV
+
+       ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances]
+                      , hsib_body
+                          = FamEqn { feqn_ext    = noExt
+                                   , feqn_tycon  = tycon'
+                                   , feqn_bndrs  = bndrs' <$ mb_bndrs
+                                   , feqn_pats   = pats'
+                                   , feqn_fixity = fixity
+                                   , feqn_rhs    = payload' } },
+                 all_fvs) }
+rnFamInstEqn _ _ _ (HsIB _ (XFamEqn _)) _ = panic "rnFamInstEqn"
+rnFamInstEqn _ _ _ (XHsImplicitBndrs _) _ = panic "rnFamInstEqn"
+
+rnTyFamInstDecl :: Maybe (Name, [Name]) -- Just (cls,tvs) => associated,
+                                        --   and gives class and tyvars of
+                                        --   the parent instance decl
+                -> TyFamInstDecl GhcPs
+                -> RnM (TyFamInstDecl GhcRn, FreeVars)
+rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = eqn })
+  = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls NotClosedTyFam eqn
+       ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }
+
+-- | Tracks whether we are renaming an equation in a closed type family
+-- equation ('ClosedTyFam') or not ('NotClosedTyFam').
+data ClosedTyFamInfo
+  = NotClosedTyFam
+  | ClosedTyFam (Located RdrName) Name
+                -- The names (RdrName and Name) of the closed type family
+
+rnTyFamInstEqn :: Maybe (Name, [Name])
+               -> ClosedTyFamInfo
+               -> TyFamInstEqn GhcPs
+               -> RnM (TyFamInstEqn GhcRn, FreeVars)
+rnTyFamInstEqn mb_cls ctf_info
+    eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
+                                   , feqn_rhs   = rhs }})
+  = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs
+       ; (eqn'@(HsIB { hsib_body =
+                       FamEqn { feqn_tycon = dL -> L _ tycon' }}), fvs)
+           <- rnFamInstEqn (TySynCtx tycon) mb_cls rhs_kvs eqn rnTySyn
+       ; case ctf_info of
+           NotClosedTyFam -> pure ()
+           ClosedTyFam fam_rdr_name fam_name ->
+             checkTc (fam_name == tycon') $
+             withHsDocContext (TyFamilyCtx fam_rdr_name) $
+             wrongTyFamName fam_name tycon'
+       ; pure (eqn', fvs) }
+rnTyFamInstEqn _ _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn"
+rnTyFamInstEqn _ _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn"
+
+rnTyFamDefltEqn :: Name
+                -> TyFamDefltEqn GhcPs
+                -> RnM (TyFamDefltEqn GhcRn, FreeVars)
+rnTyFamDefltEqn cls (FamEqn { feqn_tycon  = tycon
+                            , feqn_bndrs  = bndrs
+                            , feqn_pats   = tyvars
+                            , feqn_fixity = fixity
+                            , feqn_rhs    = rhs })
+  = do { let kvs = extractHsTyRdrTyVarsKindVars rhs
+       ; bindHsQTyVars ctx Nothing (Just cls) kvs tyvars $ \ tyvars' _ ->
+    do { tycon'      <- lookupFamInstName (Just cls) tycon
+       ; (rhs', fvs) <- rnLHsType ctx rhs
+       ; return (FamEqn { feqn_ext    = noExt
+                        , feqn_tycon  = tycon'
+                        , feqn_bndrs  = ASSERT( isNothing bndrs )
+                                        Nothing
+                        , feqn_pats   = tyvars'
+                        , feqn_fixity = fixity
+                        , feqn_rhs    = rhs' }, fvs) } }
+  where
+    ctx = TyFamilyCtx tycon
+rnTyFamDefltEqn _ (XFamEqn _) = panic "rnTyFamDefltEqn"
+
+rnDataFamInstDecl :: Maybe (Name, [Name])
+                  -> DataFamInstDecl GhcPs
+                  -> RnM (DataFamInstDecl GhcRn, FreeVars)
+rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =
+                           FamEqn { feqn_tycon = tycon
+                                  , feqn_rhs   = rhs }})})
+  = do { let rhs_kvs = extractDataDefnKindVars rhs
+       ; (eqn', fvs) <-
+           rnFamInstEqn (TyDataCtx tycon) mb_cls rhs_kvs eqn rnDataDefn
+       ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
+rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn _)))
+  = panic "rnDataFamInstDecl"
+rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs _))
+  = panic "rnDataFamInstDecl"
+
+-- Renaming of the associated types in instances.
+
+-- Rename associated type family decl in class
+rnATDecls :: Name      -- Class
+          -> [LFamilyDecl GhcPs]
+          -> RnM ([LFamilyDecl GhcRn], FreeVars)
+rnATDecls cls at_decls
+  = rnList (rnFamDecl (Just cls)) at_decls
+
+rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames
+                  decl GhcPs ->            -- an instance. rnTyFamInstDecl
+                  RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl
+              -> Name      -- Class
+              -> [Name]
+              -> [Located (decl GhcPs)]
+              -> RnM ([Located (decl GhcRn)], FreeVars)
+-- Used for data and type family defaults in a class decl
+-- and the family instance declarations in an instance
+--
+-- NB: We allow duplicate associated-type decls;
+--     See Note [Associated type instances] in TcInstDcls
+rnATInstDecls rnFun cls tv_ns at_insts
+  = rnList (rnFun (Just (cls, tv_ns))) at_insts
+    -- See Note [Renaming associated types]
+
+{- Note [Wildcards in family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Wild cards can be used in type/data family instance declarations to indicate
+that the name of a type variable doesn't matter. Each wild card will be
+replaced with a new unique type variable. For instance:
+
+    type family F a b :: *
+    type instance F Int _ = Int
+
+is the same as
+
+    type family F a b :: *
+    type instance F Int b = Int
+
+This is implemented as follows: Unnamed wildcards remain unchanged after
+the renamer, and then given fresh meta-variables during typechecking, and
+it is handled pretty much the same way as the ones in partial type signatures.
+We however don't want to emit hole constraints on wildcards in family
+instances, so we turn on PartialTypeSignatures and turn off warning flag to
+let typechecker know this.
+See related Note [Wildcards in visible kind application] in TcHsType.hs
+
+Note [Unused type variables in family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the flag -fwarn-unused-type-patterns is on, the compiler reports
+warnings about unused type variables in type-family instances. A
+tpye variable is considered used (i.e. cannot be turned into a wildcard)
+when
+
+ * it occurs on the RHS of the family instance
+   e.g.   type instance F a b = a    -- a is used on the RHS
+
+ * it occurs multiple times in the patterns on the LHS
+   e.g.   type instance F a a = Int  -- a appears more than once on LHS
+
+ * it is one of the instance-decl variables, for associated types
+   e.g.   instance C (a,b) where
+            type T (a,b) = a
+   Here the type pattern in the type instance must be the same as that
+   for the class instance, so
+            type T (a,_) = a
+   would be rejected.  So we should not complain about an unused variable b
+
+As usual, the warnings are not reported for type variables with names
+beginning with an underscore.
+
+Extra-constraints wild cards are not supported in type/data family
+instance declarations.
+
+Relevant tickets: #3699, #10586, #10982 and #11451.
+
+Note [Renaming associated types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Check that the RHS of the decl mentions only type variables that are explicitly
+bound on the LHS.  For example, this is not ok
+   class C a b where
+      type F a x :: *
+   instance C (p,q) r where
+      type F (p,q) x = (x, r)   -- BAD: mentions 'r'
+c.f. Trac #5515
+
+Kind variables, on the other hand, are allowed to be implicitly or explicitly
+bound. As examples, this (#9574) is acceptable:
+   class Funct f where
+      type Codomain f :: *
+   instance Funct ('KProxy :: KProxy o) where
+      -- o is implicitly bound by the kind signature
+      -- of the LHS type pattern ('KProxy)
+      type Codomain 'KProxy = NatTr (Proxy :: o -> *)
+And this (#14131) is also acceptable:
+    data family Nat :: k -> k -> *
+    -- k is implicitly bound by an invisible kind pattern
+    newtype instance Nat :: (k -> *) -> (k -> *) -> * where
+      Nat :: (forall xx. f xx -> g xx) -> Nat f g
+We could choose to disallow this, but then associated type families would not
+be able to be as expressive as top-level type synonyms. For example, this type
+synonym definition is allowed:
+    type T = (Nothing :: Maybe a)
+So for parity with type synonyms, we also allow:
+    type family   T :: Maybe a
+    type instance T = (Nothing :: Maybe a)
+
+All this applies only for *instance* declarations.  In *class*
+declarations there is no RHS to worry about, and the class variables
+can all be in scope (Trac #5862):
+    class Category (x :: k -> k -> *) where
+      type Ob x :: k -> Constraint
+      id :: Ob x a => x a a
+      (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
+Here 'k' is in scope in the kind signature, just like 'x'.
+
+Although type family equations can bind type variables with explicit foralls,
+it need not be the case that all variables that appear on the RHS must be bound
+by a forall. For instance, the following is acceptable:
+
+   class C a where
+     type T a b
+   instance C (Maybe a) where
+     type forall b. T (Maybe a) b = Either a b
+
+Even though `a` is not bound by the forall, this is still accepted because `a`
+was previously bound by the `instance C (Maybe a)` part. (see Trac #16116).
+
+In each case, the function which detects improperly bound variables on the RHS
+is TcValidity.checkValidFamPats.
+-}
+
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Stand-alone deriving declarations}
+*                                                      *
+*********************************************************
+-}
+
+rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
+rnSrcDerivDecl (DerivDecl _ ty mds overlap)
+  = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
+       ; unless standalone_deriv_ok (addErr standaloneDerivErr)
+       ; (mds', ty', fvs)
+           <- rnLDerivStrategy DerivDeclCtx mds $ \strat_tvs ppr_via_ty ->
+              rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "instance" $
+              rnHsSigWcType BindUnlessForall DerivDeclCtx ty
+       ; warnNoDerivStrat mds' loc
+       ; return (DerivDecl noExt ty' mds' overlap, fvs) }
+  where
+    loc = getLoc $ hsib_body $ hswc_body ty
+rnSrcDerivDecl (XDerivDecl _) = panic "rnSrcDerivDecl"
+
+standaloneDerivErr :: SDoc
+standaloneDerivErr
+  = hang (text "Illegal standalone deriving declaration")
+       2 (text "Use StandaloneDeriving to enable this extension")
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Rules}
+*                                                      *
+*********************************************************
+-}
+
+rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
+rnHsRuleDecls (HsRules { rds_src = src
+                       , rds_rules = rules })
+  = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
+       ; return (HsRules { rds_ext = noExt
+                         , rds_src = src
+                         , rds_rules = rn_rules }, fvs) }
+rnHsRuleDecls (XRuleDecls _) = panic "rnHsRuleDecls"
+
+rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
+rnHsRuleDecl (HsRule { rd_name = rule_name
+                     , rd_act  = act
+                     , rd_tyvs = tyvs
+                     , rd_tmvs = tmvs
+                     , rd_lhs  = lhs
+                     , rd_rhs  = rhs })
+  = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs
+       ; checkDupRdrNames rdr_names_w_loc
+       ; checkShadowedRdrNames rdr_names_w_loc
+       ; names <- newLocalBndrsRn rdr_names_w_loc
+       ; let doc = RuleCtx (snd $ unLoc rule_name)
+       ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' ->
+         bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->
+    do { (lhs', fv_lhs') <- rnLExpr lhs
+       ; (rhs', fv_rhs') <- rnLExpr rhs
+       ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
+       ; return (HsRule { rd_ext  = HsRuleRn fv_lhs' fv_rhs'
+                        , rd_name = rule_name
+                        , rd_act  = act
+                        , rd_tyvs = tyvs'
+                        , rd_tmvs = tmvs'
+                        , rd_lhs  = lhs'
+                        , rd_rhs  = rhs' }, fv_lhs' `plusFV` fv_rhs') } }
+  where
+    get_var (RuleBndrSig _ v _) = v
+    get_var (RuleBndr _ v)      = v
+    get_var (XRuleBndr _)       = panic "rnHsRuleDecl"
+    in_rule = text "in the rule" <+> pprFullRuleName rule_name
+rnHsRuleDecl (XRuleDecl _) = panic "rnHsRuleDecl"
+
+bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs
+               -> [LRuleBndr GhcPs] -> [Name]
+               -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
+               -> RnM (a, FreeVars)
+bindRuleTmVars doc tyvs vars names thing_inside
+  = go vars names $ \ vars' ->
+    bindLocalNamesFV names (thing_inside vars')
+  where
+    go ((dL->L l (RuleBndr _ (dL->L loc _))) : vars) (n : ns) thing_inside
+      = go vars ns $ \ vars' ->
+        thing_inside (cL l (RuleBndr noExt (cL loc n)) : vars')
+
+    go ((dL->L l (RuleBndrSig _ (dL->L loc _) bsig)) : vars)
+       (n : ns) thing_inside
+      = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' ->
+        go vars ns $ \ vars' ->
+        thing_inside (cL l (RuleBndrSig noExt (cL loc n) bsig') : vars')
+
+    go [] [] thing_inside = thing_inside []
+    go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
+
+    bind_free_tvs = case tyvs of Nothing -> AlwaysBind
+                                 Just _  -> NeverBind
+
+bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs]
+               -> (Maybe [LHsTyVarBndr GhcRn]  -> RnM (b, FreeVars))
+               -> RnM (b, FreeVars)
+bindRuleTyVars doc in_doc (Just bndrs) thing_inside
+  = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just)
+bindRuleTyVars _ _ _ thing_inside = thing_inside Nothing
+
+{-
+Note [Rule LHS validity checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Check the shape of a transformation rule LHS.  Currently we only allow
+LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
+@forall@'d variables.
+
+We used restrict the form of the 'ei' to prevent you writing rules
+with LHSs with a complicated desugaring (and hence unlikely to match);
+(e.g. a case expression is not allowed: too elaborate.)
+
+But there are legitimate non-trivial args ei, like sections and
+lambdas.  So it seems simmpler not to check at all, and that is why
+check_e is commented out.
+-}
+
+checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()
+checkValidRule rule_name ids lhs' fv_lhs'
+  = do  {       -- Check for the form of the LHS
+          case (validRuleLhs ids lhs') of
+                Nothing  -> return ()
+                Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
+
+                -- Check that LHS vars are all bound
+        ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
+        ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
+
+validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
+-- Nothing => OK
+-- Just e  => Not ok, and e is the offending sub-expression
+validRuleLhs foralls lhs
+  = checkl lhs
+  where
+    checkl = check . unLoc
+
+    check (OpApp _ e1 op e2)              = checkl op `mplus` checkl_e e1
+                                                      `mplus` checkl_e e2
+    check (HsApp _ e1 e2)                 = checkl e1 `mplus` checkl_e e2
+    check (HsAppType _ e _)               = checkl e
+    check (HsVar _ lv)
+      | (unLoc lv) `notElem` foralls      = Nothing
+    check other                           = Just other  -- Failure
+
+        -- Check an argument
+    checkl_e _ = Nothing
+    -- Was (check_e e); see Note [Rule LHS validity checking]
+
+{-      Commented out; see Note [Rule LHS validity checking] above
+    check_e (HsVar v)     = Nothing
+    check_e (HsPar e)     = checkl_e e
+    check_e (HsLit e)     = Nothing
+    check_e (HsOverLit e) = Nothing
+
+    check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
+    check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2
+    check_e (NegApp e _)         = checkl_e e
+    check_e (ExplicitList _ es)  = checkl_es es
+    check_e other                = Just other   -- Fails
+
+    checkl_es es = foldr (mplus . checkl_e) Nothing es
+-}
+
+badRuleVar :: FastString -> Name -> SDoc
+badRuleVar name var
+  = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,
+         text "Forall'd variable" <+> quotes (ppr var) <+>
+                text "does not appear on left hand side"]
+
+badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc
+badRuleLhsErr name lhs bad_e
+  = sep [text "Rule" <+> pprRuleName name <> colon,
+         nest 2 (vcat [err,
+                       text "in left-hand side:" <+> ppr lhs])]
+    $$
+    text "LHS must be of form (f e1 .. en) where f is not forall'd"
+  where
+    err = case bad_e of
+            HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual (unboundVarOcc uv))
+            _                 -> text "Illegal expression:" <+> ppr bad_e
+
+{- **************************************************************
+         *                                                      *
+      Renaming type, class, instance and role declarations
+*                                                               *
+*****************************************************************
+
+@rnTyDecl@ uses the `global name function' to create a new type
+declaration in which local names have been replaced by their original
+names, reporting any unknown names.
+
+Renaming type variables is a pain. Because they now contain uniques,
+it is necessary to pass in an association list which maps a parsed
+tyvar to its @Name@ representation.
+In some cases (type signatures of values),
+it is even necessary to go over the type first
+in order to get the set of tyvars used by it, make an assoc list,
+and then go over it again to rename the tyvars!
+However, we can also do some scoping checks at the same time.
+
+Note [Dependency analysis of type, class, and instance decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A TyClGroup represents a strongly connected components of
+type/class/instance decls, together with the role annotations for the
+type/class declarations.  The renamer uses strongly connected
+comoponent analysis to build these groups.  We do this for a number of
+reasons:
+
+* Improve kind error messages. Consider
+
+     data T f a = MkT f a
+     data S f a = MkS f (T f a)
+
+  This has a kind error, but the error message is better if you
+  check T first, (fixing its kind) and *then* S.  If you do kind
+  inference together, you might get an error reported in S, which
+  is jolly confusing.  See Trac #4875
+
+
+* Increase kind polymorphism.  See TcTyClsDecls
+  Note [Grouping of type and class declarations]
+
+Why do the instance declarations participate?  At least two reasons
+
+* Consider (Trac #11348)
+
+     type family F a
+     type instance F Int = Bool
+
+     data R = MkR (F Int)
+
+     type Foo = 'MkR 'True
+
+  For Foo to kind-check we need to know that (F Int) ~ Bool.  But we won't
+  know that unless we've looked at the type instance declaration for F
+  before kind-checking Foo.
+
+* Another example is this (Trac #3990).
+
+     data family Complex a
+     data instance Complex Double = CD {-# UNPACK #-} !Double
+                                       {-# UNPACK #-} !Double
+
+     data T = T {-# UNPACK #-} !(Complex Double)
+
+  Here, to generate the right kind of unpacked implementation for T,
+  we must have access to the 'data instance' declaration.
+
+* Things become more complicated when we introduce transitive
+  dependencies through imported definitions, like in this scenario:
+
+      A.hs
+        type family Closed (t :: Type) :: Type where
+          Closed t = Open t
+
+        type family Open (t :: Type) :: Type
+
+      B.hs
+        data Q where
+          Q :: Closed Bool -> Q
+
+        type instance Open Int = Bool
+
+        type S = 'Q 'True
+
+  Somehow, we must ensure that the instance Open Int = Bool is checked before
+  the type synonym S. While we know that S depends upon 'Q depends upon Closed,
+  we have no idea that Closed depends upon Open!
+
+  To accomodate for these situations, we ensure that an instance is checked
+  before every @TyClDecl@ on which it does not depend. That's to say, instances
+  are checked as early as possible in @tcTyAndClassDecls@.
+
+------------------------------------
+So much for WHY.  What about HOW?  It's pretty easy:
+
+(1) Rename the type/class, instance, and role declarations
+    individually
+
+(2) Do strongly-connected component analysis of the type/class decls,
+    We'll make a TyClGroup for each SCC
+
+    In this step we treat a reference to a (promoted) data constructor
+    K as a dependency on its parent type.  Thus
+        data T = K1 | K2
+        data S = MkS (Proxy 'K1)
+    Here S depends on 'K1 and hence on its parent T.
+
+    In this step we ignore instances; see
+    Note [No dependencies on data instances]
+
+(3) Attach roles to the appropriate SCC
+
+(4) Attach instances to the appropriate SCC.
+    We add an instance decl to SCC when:
+      all its free types/classes are bound in this SCC or earlier ones
+
+(5) We make an initial TyClGroup, with empty group_tyclds, for any
+    (orphan) instances that affect only imported types/classes
+
+Steps (3) and (4) are done by the (mapAccumL mk_group) call.
+
+Note [No dependencies on data instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+   data family D a
+   data instance D Int = D1
+   data S = MkS (Proxy 'D1)
+
+Here the declaration of S depends on the /data instance/ declaration
+for 'D Int'.  That makes things a lot more complicated, especially
+if the data instance is an associated type of an enclosing class instance.
+(And the class instance might have several associated type instances
+with different dependency structure!)
+
+Ugh.  For now we simply don't allow promotion of data constructors for
+data instances.  See Note [AFamDataCon: not promoting data family
+constructors] in TcEnv
+-}
+
+
+rnTyClDecls :: [TyClGroup GhcPs]
+            -> RnM ([TyClGroup GhcRn], FreeVars)
+-- Rename the declarations and do dependency analysis on them
+rnTyClDecls tycl_ds
+  = do { -- Rename the type/class, instance, and role declaraations
+         tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl)
+                             (tyClGroupTyClDecls tycl_ds)
+       ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)
+
+       ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
+       ; role_annots  <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
+
+       -- Do SCC analysis on the type/class decls
+       ; rdr_env <- getGlobalRdrEnv
+       ; let tycl_sccs = depAnalTyClDecls rdr_env tycls_w_fvs
+             role_annot_env = mkRoleAnnotEnv role_annots
+
+             inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs
+             (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map
+
+             first_group
+               | null init_inst_ds = []
+               | otherwise = [TyClGroup { group_ext    = noExt
+                                        , group_tyclds = []
+                                        , group_roles  = []
+                                        , group_instds = init_inst_ds }]
+
+             ((final_inst_ds, orphan_roles), groups)
+                = mapAccumL mk_group (rest_inst_ds, role_annot_env) tycl_sccs
+
+
+             all_fvs = plusFV (foldr (plusFV . snd) emptyFVs tycls_w_fvs)
+                              (foldr (plusFV . snd) emptyFVs instds_w_fvs)
+
+             all_groups = first_group ++ groups
+
+       ; ASSERT2( null final_inst_ds,  ppr instds_w_fvs $$ ppr inst_ds_map
+                                       $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds  )
+         mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
+
+       ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)
+       ; return (all_groups, all_fvs) }
+  where
+    mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv)
+             -> SCC (LTyClDecl GhcRn)
+             -> ( (InstDeclFreeVarsMap, RoleAnnotEnv)
+                , TyClGroup GhcRn )
+    mk_group (inst_map, role_env) scc
+      = ((inst_map', role_env'), group)
+      where
+        tycl_ds              = flattenSCC scc
+        bndrs                = map (tcdName . unLoc) tycl_ds
+        (inst_ds, inst_map') = getInsts      bndrs inst_map
+        (roles,   role_env') = getRoleAnnots bndrs role_env
+        group = TyClGroup { group_ext    = noExt
+                          , group_tyclds = tycl_ds
+                          , group_roles  = roles
+                          , group_instds = inst_ds }
+
+
+depAnalTyClDecls :: GlobalRdrEnv
+                 -> [(LTyClDecl GhcRn, FreeVars)]
+                 -> [SCC (LTyClDecl GhcRn)]
+-- See Note [Dependency analysis of type, class, and instance decls]
+depAnalTyClDecls rdr_env ds_w_fvs
+  = stronglyConnCompFromEdgedVerticesUniq edges
+  where
+    edges :: [ Node Name (LTyClDecl GhcRn) ]
+    edges = [ DigraphNode d (tcdName (unLoc d)) (map (getParent rdr_env) (nonDetEltsUniqSet fvs))
+            | (d, fvs) <- ds_w_fvs ]
+            -- It's OK to use nonDetEltsUFM here as
+            -- stronglyConnCompFromEdgedVertices is still deterministic
+            -- even if the edges are in nondeterministic order as explained
+            -- in Note [Deterministic SCC] in Digraph.
+
+toParents :: GlobalRdrEnv -> NameSet -> NameSet
+toParents rdr_env ns
+  = nonDetFoldUniqSet add emptyNameSet ns
+  -- It's OK to use nonDetFoldUFM because we immediately forget the
+  -- ordering by creating a set
+  where
+    add n s = extendNameSet s (getParent rdr_env n)
+
+getParent :: GlobalRdrEnv -> Name -> Name
+getParent rdr_env n
+  = case lookupGRE_Name rdr_env n of
+      Just gre -> case gre_par gre of
+                    ParentIs  { par_is = p } -> p
+                    FldParent { par_is = p } -> p
+                    _                        -> n
+      Nothing -> n
+
+
+{- ******************************************************
+*                                                       *
+       Role annotations
+*                                                       *
+****************************************************** -}
+
+-- | Renames role annotations, returning them as the values in a NameEnv
+-- and checks for duplicate role annotations.
+-- It is quite convenient to do both of these in the same place.
+-- See also Note [Role annotations in the renamer]
+rnRoleAnnots :: NameSet
+             -> [LRoleAnnotDecl GhcPs]
+             -> RnM [LRoleAnnotDecl GhcRn]
+rnRoleAnnots tc_names role_annots
+  = do {  -- Check for duplicates *before* renaming, to avoid
+          -- lumping together all the unboundNames
+         let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
+             role_annots_cmp (dL->L _ annot1) (dL->L _ annot2)
+               = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
+       ; mapM_ dupRoleAnnotErr dup_annots
+       ; mapM (wrapLocM rn_role_annot1) no_dups }
+  where
+    rn_role_annot1 (RoleAnnotDecl _ tycon roles)
+      = do {  -- the name is an *occurrence*, but look it up only in the
+              -- decls defined in this group (see #10263)
+             tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)
+                                          (text "role annotation")
+                                          tycon
+           ; return $ RoleAnnotDecl noExt tycon' roles }
+    rn_role_annot1 (XRoleAnnotDecl _) = panic "rnRoleAnnots"
+
+dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
+dupRoleAnnotErr list
+  = addErrAt loc $
+    hang (text "Duplicate role annotations for" <+>
+          quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
+       2 (vcat $ map pp_role_annot $ NE.toList sorted_list)
+    where
+      sorted_list = NE.sortBy cmp_annot list
+      ((dL->L loc first_decl) :| _) = sorted_list
+
+      pp_role_annot (dL->L loc decl) = hang (ppr decl)
+                                      4 (text "-- written at" <+> ppr loc)
+
+      cmp_annot (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2
+
+orphanRoleAnnotErr :: LRoleAnnotDecl GhcRn -> RnM ()
+orphanRoleAnnotErr (dL->L loc decl)
+  = addErrAt loc $
+    hang (text "Role annotation for a type previously declared:")
+       2 (ppr decl) $$
+    parens (text "The role annotation must be given where" <+>
+            quotes (ppr $ roleAnnotDeclName decl) <+>
+            text "is declared.")
+
+
+{- Note [Role annotations in the renamer]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must ensure that a type's role annotation is put in the same group as the
+proper type declaration. This is because role annotations are needed during
+type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
+NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
+type, if any. Then, this map can be used to add the role annotations to the
+groups after dependency analysis.
+
+This process checks for duplicate role annotations, where we must be careful
+to do the check *before* renaming to avoid calling all unbound names duplicates
+of one another.
+
+The renaming process, as usual, might identify and report errors for unbound
+names. We exclude the annotations for unbound names in the annotation
+environment to avoid spurious errors for orphaned annotations.
+
+We then (in rnTyClDecls) do a check for orphan role annotations (role
+annotations without an accompanying type decl). The check works by folding
+over components (of type [[Either (TyClDecl Name) (InstDecl Name)]]), selecting
+out the relevant role declarations for each group, as well as diminishing the
+annotation environment. After the fold is complete, anything left over in the
+name environment must be an orphan, and errors are generated.
+
+An earlier version of this algorithm short-cut the orphan check by renaming
+only with names declared in this module. But, this check is insufficient in
+the case of staged module compilation (Template Haskell, GHCi).
+See #8485. With the new lookup process (which includes types declared in other
+modules), we get better error messages, too.
+-}
+
+
+{- ******************************************************
+*                                                       *
+       Dependency info for instances
+*                                                       *
+****************************************************** -}
+
+----------------------------------------------------------
+-- | 'InstDeclFreeVarsMap is an association of an
+--   @InstDecl@ with @FreeVars@. The @FreeVars@ are
+--   the tycon names that are both
+--     a) free in the instance declaration
+--     b) bound by this group of type/class/instance decls
+type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)]
+
+-- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the
+--   @FreeVars@ which are *not* the binders of a @TyClDecl@.
+mkInstDeclFreeVarsMap :: GlobalRdrEnv
+                      -> NameSet
+                      -> [(LInstDecl GhcRn, FreeVars)]
+                      -> InstDeclFreeVarsMap
+mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs
+  = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs)
+    | (inst_decl, fvs) <- inst_ds_fvs ]
+
+-- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the
+--   @InstDeclFreeVarsMap@ with these entries removed.
+-- We call (getInsts tcs instd_map) when we've completed the declarations
+-- for 'tcs'.  The call returns (inst_decls, instd_map'), where
+--   inst_decls are the instance declarations all of
+--              whose free vars are now defined
+--   instd_map' is the inst-decl map with 'tcs' removed from
+--               the free-var set
+getInsts :: [Name] -> InstDeclFreeVarsMap
+         -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
+getInsts bndrs inst_decl_map
+  = partitionWith pick_me inst_decl_map
+  where
+    pick_me :: (LInstDecl GhcRn, FreeVars)
+            -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
+    pick_me (decl, fvs)
+      | isEmptyNameSet depleted_fvs = Left decl
+      | otherwise                   = Right (decl, depleted_fvs)
+      where
+        depleted_fvs = delFVs bndrs fvs
+
+{- ******************************************************
+*                                                       *
+         Renaming a type or class declaration
+*                                                       *
+****************************************************** -}
+
+rnTyClDecl :: TyClDecl GhcPs
+           -> RnM (TyClDecl GhcRn, FreeVars)
+
+-- All flavours of type family declarations ("type family", "newtype family",
+-- and "data family"), both top level and (for an associated type)
+-- in a class decl
+rnTyClDecl (FamDecl { tcdFam = decl })
+  = do { (decl', fvs) <- rnFamDecl Nothing decl
+       ; return (FamDecl noExt decl', fvs) }
+
+rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
+                      tcdFixity = fixity, tcdRhs = rhs })
+  = do { tycon' <- lookupLocatedTopBndrRn tycon
+       ; let kvs = extractHsTyRdrTyVarsKindVars rhs
+             doc = TySynCtx tycon
+       ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)
+       ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ ->
+    do { (rhs', fvs) <- rnTySyn doc rhs
+       ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
+                         , tcdFixity = fixity
+                         , tcdRhs = rhs', tcdSExt = fvs }, fvs) } }
+
+-- "data", "newtype" declarations
+-- both top level and (for an associated type) in an instance decl
+rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,
+                       tcdFixity = fixity, tcdDataDefn = defn })
+  = do { tycon' <- lookupLocatedTopBndrRn tycon
+       ; let kvs = extractDataDefnKindVars defn
+             doc = TyDataCtx tycon
+       ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
+       ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
+    do { (defn', fvs) <- rnDataDefn doc defn
+          -- See Note [Complete user-supplied kind signatures] in HsDecls
+       ; let cusk = hsTvbAllKinded tyvars' && no_rhs_kvs
+             rn_info = DataDeclRn { tcdDataCusk = cusk
+                                  , tcdFVs      = fvs }
+       ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
+       ; return (DataDecl { tcdLName    = tycon'
+                          , tcdTyVars   = tyvars'
+                          , tcdFixity   = fixity
+                          , tcdDataDefn = defn'
+                          , tcdDExt     = rn_info }, fvs) } }
+
+rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
+                        tcdTyVars = tyvars, tcdFixity = fixity,
+                        tcdFDs = fds, tcdSigs = sigs,
+                        tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
+                        tcdDocs = docs})
+  = do  { lcls' <- lookupLocatedTopBndrRn lcls
+        ; let cls' = unLoc lcls'
+              kvs = []  -- No scoped kind vars except those in
+                        -- kind signatures on the tyvars
+
+        -- Tyvars scope over superclass context and method signatures
+        ; ((tyvars', context', fds', ats'), stuff_fvs)
+            <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do
+                  -- Checks for distinct tyvars
+             { (context', cxt_fvs) <- rnContext cls_doc context
+             ; fds'  <- rnFds fds
+                         -- The fundeps have no free variables
+             ; (ats', fv_ats) <- rnATDecls cls' ats
+             ; let fvs = cxt_fvs     `plusFV`
+                         fv_ats
+             ; return ((tyvars', context', fds', ats'), fvs) }
+
+        ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
+
+        -- No need to check for duplicate associated type decls
+        -- since that is done by RnNames.extendGlobalRdrEnvRn
+
+        -- Check the signatures
+        -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
+        ; let sig_rdr_names_w_locs =
+                [op | (dL->L _ (ClassOpSig _ False ops _)) <- sigs
+                    , op <- ops]
+        ; checkDupRdrNames sig_rdr_names_w_locs
+                -- Typechecker is responsible for checking that we only
+                -- give default-method bindings for things in this class.
+                -- The renamer *could* check this for class decls, but can't
+                -- for instance decls.
+
+        -- The newLocals call is tiresome: given a generic class decl
+        --      class C a where
+        --        op :: a -> a
+        --        op {| x+y |} (Inl a) = ...
+        --        op {| x+y |} (Inr b) = ...
+        --        op {| a*b |} (a*b)   = ...
+        -- we want to name both "x" tyvars with the same unique, so that they are
+        -- easy to group together in the typechecker.
+        ; (mbinds', sigs', meth_fvs)
+            <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs
+                -- No need to check for duplicate method signatures
+                -- since that is done by RnNames.extendGlobalRdrEnvRn
+                -- and the methods are already in scope
+
+  -- Haddock docs
+        ; docs' <- mapM (wrapLocM rnDocDecl) docs
+
+        ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
+        ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
+                              tcdTyVars = tyvars', tcdFixity = fixity,
+                              tcdFDs = fds', tcdSigs = sigs',
+                              tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
+                              tcdDocs = docs', tcdCExt = all_fvs },
+                  all_fvs ) }
+  where
+    cls_doc  = ClassDeclCtx lcls
+
+rnTyClDecl (XTyClDecl _) = panic "rnTyClDecl"
+
+-- "type" and "type instance" declarations
+rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
+rnTySyn doc rhs = rnLHsType doc rhs
+
+rnDataDefn :: HsDocContext -> HsDataDefn GhcPs
+           -> RnM (HsDataDefn GhcRn, FreeVars)
+rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+                           , dd_ctxt = context, dd_cons = condecls
+                           , dd_kindSig = m_sig, dd_derivs = derivs })
+  = do  { checkTc (h98_style || null (unLoc context))
+                  (badGadtStupidTheta doc)
+
+        ; (m_sig', sig_fvs) <- case m_sig of
+             Just sig -> first Just <$> rnLHsKind doc sig
+             Nothing  -> return (Nothing, emptyFVs)
+        ; (context', fvs1) <- rnContext doc context
+        ; (derivs',  fvs3) <- rn_derivs derivs
+
+        -- For the constructor declarations, drop the LocalRdrEnv
+        -- in the GADT case, where the type variables in the declaration
+        -- do not scope over the constructor signatures
+        -- data T a where { T1 :: forall b. b-> b }
+        ; let { zap_lcl_env | h98_style = \ thing -> thing
+                            | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
+        ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
+           -- No need to check for duplicate constructor decls
+           -- since that is done by RnNames.extendGlobalRdrEnvRn
+
+        ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
+                        con_fvs `plusFV` sig_fvs
+        ; return ( HsDataDefn { dd_ext = noExt
+                              , dd_ND = new_or_data, dd_cType = cType
+                              , dd_ctxt = context', dd_kindSig = m_sig'
+                              , dd_cons = condecls'
+                              , dd_derivs = derivs' }
+                 , all_fvs )
+        }
+  where
+    h98_style = case condecls of  -- Note [Stupid theta]
+                     (dL->L _ (ConDeclGADT {})) : _  -> False
+                     _                               -> True
+
+    rn_derivs (dL->L loc ds)
+      = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies
+           ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)
+               multipleDerivClausesErr
+           ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds
+           ; return (cL loc ds', fvs) }
+rnDataDefn _ (XHsDataDefn _) = panic "rnDataDefn"
+
+warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)
+                 -> SrcSpan
+                 -> RnM ()
+warnNoDerivStrat mds loc
+  = do { dyn_flags <- getDynFlags
+       ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $
+           case mds of
+             Nothing -> addWarnAt
+               (Reason Opt_WarnMissingDerivingStrategies)
+               loc
+               (if xopt LangExt.DerivingStrategies dyn_flags
+                 then no_strat_warning
+                 else no_strat_warning $+$ deriv_strat_nenabled
+               )
+             _ -> pure ()
+       }
+  where
+    no_strat_warning :: SDoc
+    no_strat_warning = text "No deriving strategy specified. Did you want stock"
+                       <> text ", newtype, or anyclass?"
+    deriv_strat_nenabled :: SDoc
+    deriv_strat_nenabled = text "Use DerivingStrategies to specify a strategy."
+
+rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs
+                    -> RnM (LHsDerivingClause GhcRn, FreeVars)
+rnLHsDerivingClause doc
+                (dL->L loc (HsDerivingClause
+                              { deriv_clause_ext = noExt
+                              , deriv_clause_strategy = dcs
+                              , deriv_clause_tys = (dL->L loc' dct) }))
+  = do { (dcs', dct', fvs)
+           <- rnLDerivStrategy doc dcs $ \strat_tvs ppr_via_ty ->
+              mapFvRn (rn_deriv_ty strat_tvs ppr_via_ty) dct
+       ; warnNoDerivStrat dcs' loc
+       ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExt
+                                         , deriv_clause_strategy = dcs'
+                                         , deriv_clause_tys = cL loc' dct' })
+              , fvs ) }
+  where
+    rn_deriv_ty :: [Name] -> SDoc -> LHsSigType GhcPs
+                -> RnM (LHsSigType GhcRn, FreeVars)
+    rn_deriv_ty strat_tvs ppr_via_ty deriv_ty@(HsIB {hsib_body = dL->L loc _}) =
+      rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "class" $
+      rnHsSigType doc deriv_ty
+    rn_deriv_ty _ _ (XHsImplicitBndrs _) = panic "rn_deriv_ty"
+rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause _))
+  = panic "rnLHsDerivingClause"
+rnLHsDerivingClause _ _ = panic "rnLHsDerivingClause: Impossible Match"
+                                -- due to #15884
+
+rnLDerivStrategy :: forall a.
+                    HsDocContext
+                 -> Maybe (LDerivStrategy GhcPs)
+                 -> ([Name]   -- The tyvars bound by the via type
+                      -> SDoc -- The pretty-printed via type (used for
+                              -- error message reporting)
+                      -> RnM (a, FreeVars))
+                 -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)
+rnLDerivStrategy doc mds thing_inside
+  = case mds of
+      Nothing -> boring_case Nothing
+      Just ds -> do (ds', thing, fvs) <- rn_deriv_strat ds
+                    pure (Just ds', thing, fvs)
+  where
+    rn_deriv_strat :: LDerivStrategy GhcPs
+                   -> RnM (LDerivStrategy GhcRn, a, FreeVars)
+    rn_deriv_strat (dL->L loc ds) = do
+      let extNeeded :: LangExt.Extension
+          extNeeded
+            | ViaStrategy{} <- ds
+            = LangExt.DerivingVia
+            | otherwise
+            = LangExt.DerivingStrategies
+
+      unlessXOptM extNeeded $
+        failWith $ illegalDerivStrategyErr ds
+
+      case ds of
+        StockStrategy    -> boring_case (cL loc StockStrategy)
+        AnyclassStrategy -> boring_case (cL loc AnyclassStrategy)
+        NewtypeStrategy  -> boring_case (cL loc NewtypeStrategy)
+        ViaStrategy via_ty ->
+          do (via_ty', fvs1) <- rnHsSigType doc via_ty
+             let HsIB { hsib_ext  = via_imp_tvs
+                      , hsib_body = via_body } = via_ty'
+                 (via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body
+                 via_exp_tvs = map hsLTyVarName via_exp_tv_bndrs
+                 via_tvs = via_imp_tvs ++ via_exp_tvs
+             (thing, fvs2) <- extendTyVarEnvFVRn via_tvs $
+                              thing_inside via_tvs (ppr via_ty')
+             pure (cL loc (ViaStrategy via_ty'), thing, fvs1 `plusFV` fvs2)
+
+    boring_case :: mds
+                -> RnM (mds, a, FreeVars)
+    boring_case mds = do
+      (thing, fvs) <- thing_inside [] empty
+      pure (mds, thing, fvs)
+
+-- | Errors if a @via@ type binds any floating type variables.
+-- See @Note [Floating `via` type variables]@
+rnAndReportFloatingViaTvs
+  :: forall a. Outputable a
+  => [Name]  -- ^ The bound type variables from a @via@ type.
+  -> SrcSpan -- ^ The source span (for error reporting only).
+  -> SDoc    -- ^ The pretty-printed @via@ type (for error reporting only).
+  -> String  -- ^ A description of what the @via@ type scopes over
+             --   (for error reporting only).
+  -> RnM (a, FreeVars) -- ^ The thing the @via@ type scopes over.
+  -> RnM (a, FreeVars)
+rnAndReportFloatingViaTvs tv_names loc ppr_via_ty via_scope_desc thing_inside
+  = do (thing, thing_fvs) <- thing_inside
+       setSrcSpan loc $ mapM_ (report_floating_via_tv thing thing_fvs) tv_names
+       pure (thing, thing_fvs)
+  where
+    report_floating_via_tv :: a -> FreeVars -> Name -> RnM ()
+    report_floating_via_tv thing used_names tv_name
+      = unless (tv_name `elemNameSet` used_names) $ addErr $ vcat
+          [ text "Type variable" <+> quotes (ppr tv_name) <+>
+            text "is bound in the" <+> quotes (text "via") <+>
+            text "type" <+> quotes ppr_via_ty
+          , text "but is not mentioned in the derived" <+>
+            text via_scope_desc <+> quotes (ppr thing) <>
+            text ", which is illegal" ]
+
+{-
+Note [Floating `via` type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Imagine the following `deriving via` clause:
+
+    data Quux
+      deriving Eq via (Const a Quux)
+
+This should be rejected. Why? Because it would generate the following instance:
+
+    instance Eq Quux where
+      (==) = coerce @(Quux         -> Quux         -> Bool)
+                    @(Const a Quux -> Const a Quux -> Bool)
+                    (==) :: Const a Quux -> Const a Quux -> Bool
+
+This instance is ill-formed, as the `a` in `Const a Quux` is unbound. The
+problem is that `a` is never used anywhere in the derived class `Eq`. Since
+`a` is bound but has no use sites, we refer to it as "floating".
+
+We use the rnAndReportFloatingViaTvs function to check that any type renamed
+within the context of the `via` deriving strategy actually uses all bound
+`via` type variables, and if it doesn't, it throws an error.
+-}
+
+badGadtStupidTheta :: HsDocContext -> SDoc
+badGadtStupidTheta _
+  = vcat [text "No context is allowed on a GADT-style data declaration",
+          text "(You can put a context on each constructor, though.)"]
+
+illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc
+illegalDerivStrategyErr ds
+  = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds
+         , text enableStrategy ]
+
+  where
+    enableStrategy :: String
+    enableStrategy
+      | ViaStrategy{} <- ds
+      = "Use DerivingVia to enable this extension"
+      | otherwise
+      = "Use DerivingStrategies to enable this extension"
+
+multipleDerivClausesErr :: SDoc
+multipleDerivClausesErr
+  = vcat [ text "Illegal use of multiple, consecutive deriving clauses"
+         , text "Use DerivingStrategies to allow this" ]
+
+rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
+                        --             inside an *class decl* for cls
+                        --             used for associated types
+          -> FamilyDecl GhcPs
+          -> RnM (FamilyDecl GhcRn, FreeVars)
+rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
+                             , fdFixity = fixity
+                             , fdInfo = info, fdResultSig = res_sig
+                             , fdInjectivityAnn = injectivity })
+  = do { tycon' <- lookupLocatedTopBndrRn tycon
+       ; ((tyvars', res_sig', injectivity'), fv1) <-
+            bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ ->
+            do { let rn_sig = rnFamResultSig doc
+               ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
+               ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
+                                          injectivity
+               ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
+       ; (info', fv2) <- rn_info tycon' info
+       ; return (FamilyDecl { fdExt = noExt
+                            , fdLName = tycon', fdTyVars = tyvars'
+                            , fdFixity = fixity
+                            , fdInfo = info', fdResultSig = res_sig'
+                            , fdInjectivityAnn = injectivity' }
+                , fv1 `plusFV` fv2) }
+  where
+     doc = TyFamilyCtx tycon
+     kvs = extractRdrKindSigVars res_sig
+
+     ----------------------
+     rn_info :: Located Name
+             -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
+     rn_info (dL->L _ fam_name) (ClosedTypeFamily (Just eqns))
+       = do { (eqns', fvs)
+                <- rnList (rnTyFamInstEqn Nothing (ClosedTyFam tycon fam_name))
+                                          -- no class context
+                          eqns
+            ; return (ClosedTypeFamily (Just eqns'), fvs) }
+     rn_info _ (ClosedTypeFamily Nothing)
+       = return (ClosedTypeFamily Nothing, emptyFVs)
+     rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
+     rn_info _ DataFamily     = return (DataFamily, emptyFVs)
+rnFamDecl _ (XFamilyDecl _) = panic "rnFamDecl"
+
+rnFamResultSig :: HsDocContext
+               -> FamilyResultSig GhcPs
+               -> RnM (FamilyResultSig GhcRn, FreeVars)
+rnFamResultSig _ (NoSig _)
+   = return (NoSig noExt, emptyFVs)
+rnFamResultSig doc (KindSig _ kind)
+   = do { (rndKind, ftvs) <- rnLHsKind doc kind
+        ;  return (KindSig noExt rndKind, ftvs) }
+rnFamResultSig doc (TyVarSig _ tvbndr)
+   = do { -- `TyVarSig` tells us that user named the result of a type family by
+          -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
+          -- be sure that the supplied result name is not identical to an
+          -- already in-scope type variable from an enclosing class.
+          --
+          --  Example of disallowed declaration:
+          --         class C a b where
+          --            type F b = a | a -> b
+          rdr_env <- getLocalRdrEnv
+       ;  let resName = hsLTyVarName tvbndr
+       ;  when (resName `elemLocalRdrEnv` rdr_env) $
+          addErrAt (getLoc tvbndr) $
+                     (hsep [ text "Type variable", quotes (ppr resName) <> comma
+                           , text "naming a type family result,"
+                           ] $$
+                      text "shadows an already bound type variable")
+
+       ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for
+                                      -- scoping checks that are irrelevant here
+                          tvbndr $ \ tvbndr' ->
+         return (TyVarSig noExt tvbndr', unitFV (hsLTyVarName tvbndr')) }
+rnFamResultSig _ (XFamilyResultSig _) = panic "rnFamResultSig"
+
+-- Note [Renaming injectivity annotation]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- During renaming of injectivity annotation we have to make several checks to
+-- make sure that it is well-formed.  At the moment injectivity annotation
+-- consists of a single injectivity condition, so the terms "injectivity
+-- annotation" and "injectivity condition" might be used interchangeably.  See
+-- Note [Injectivity annotation] for a detailed discussion of currently allowed
+-- injectivity annotations.
+--
+-- Checking LHS is simple because the only type variable allowed on the LHS of
+-- injectivity condition is the variable naming the result in type family head.
+-- Example of disallowed annotation:
+--
+--     type family Foo a b = r | b -> a
+--
+-- Verifying RHS of injectivity consists of checking that:
+--
+--  1. only variables defined in type family head appear on the RHS (kind
+--     variables are also allowed).  Example of disallowed annotation:
+--
+--        type family Foo a = r | r -> b
+--
+--  2. for associated types the result variable does not shadow any of type
+--     class variables. Example of disallowed annotation:
+--
+--        class Foo a b where
+--           type F a = b | b -> a
+--
+-- Breaking any of these assumptions results in an error.
+
+-- | Rename injectivity annotation. Note that injectivity annotation is just the
+-- part after the "|".  Everything that appears before it is renamed in
+-- rnFamDecl.
+rnInjectivityAnn :: LHsQTyVars GhcRn           -- ^ Type variables declared in
+                                               --   type family head
+                 -> LFamilyResultSig GhcRn     -- ^ Result signature
+                 -> LInjectivityAnn GhcPs      -- ^ Injectivity annotation
+                 -> RnM (LInjectivityAnn GhcRn)
+rnInjectivityAnn tvBndrs (dL->L _ (TyVarSig _ resTv))
+                 (dL->L srcSpan (InjectivityAnn injFrom injTo))
+ = do
+   { (injDecl'@(dL->L _ (InjectivityAnn injFrom' injTo')), noRnErrors)
+          <- askNoErrs $
+             bindLocalNames [hsLTyVarName resTv] $
+             -- The return type variable scopes over the injectivity annotation
+             -- e.g.   type family F a = (r::*) | r -> a
+             do { injFrom' <- rnLTyVar injFrom
+                ; injTo'   <- mapM rnLTyVar injTo
+                ; return $ cL srcSpan (InjectivityAnn injFrom' injTo') }
+
+   ; let tvNames  = Set.fromList $ hsAllLTyVarNames tvBndrs
+         resName  = hsLTyVarName resTv
+         -- See Note [Renaming injectivity annotation]
+         lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))
+         rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames
+
+   -- if renaming of type variables ended with errors (eg. there were
+   -- not-in-scope variables) don't check the validity of injectivity
+   -- annotation. This gives better error messages.
+   ; when (noRnErrors && not lhsValid) $
+        addErrAt (getLoc injFrom)
+              ( vcat [ text $ "Incorrect type variable on the LHS of "
+                           ++ "injectivity condition"
+              , nest 5
+              ( vcat [ text "Expected :" <+> ppr resName
+                     , text "Actual   :" <+> ppr injFrom ])])
+
+   ; when (noRnErrors && not (Set.null rhsValid)) $
+      do { let errorVars = Set.toList rhsValid
+         ; addErrAt srcSpan $ ( hsep
+                        [ text "Unknown type variable" <> plural errorVars
+                        , text "on the RHS of injectivity condition:"
+                        , interpp'SP errorVars ] ) }
+
+   ; return injDecl' }
+
+-- We can only hit this case when the user writes injectivity annotation without
+-- naming the result:
+--
+--   type family F a | result -> a
+--   type family F a :: * | result -> a
+--
+-- So we rename injectivity annotation like we normally would except that
+-- this time we expect "result" to be reported not in scope by rnLTyVar.
+rnInjectivityAnn _ _ (dL->L srcSpan (InjectivityAnn injFrom injTo)) =
+   setSrcSpan srcSpan $ do
+   (injDecl', _) <- askNoErrs $ do
+     injFrom' <- rnLTyVar injFrom
+     injTo'   <- mapM rnLTyVar injTo
+     return $ cL srcSpan (InjectivityAnn injFrom' injTo')
+   return $ injDecl'
+
+{-
+Note [Stupid theta]
+~~~~~~~~~~~~~~~~~~~
+Trac #3850 complains about a regression wrt 6.10 for
+     data Show a => T a
+There is no reason not to allow the stupid theta if there are no data
+constructors.  It's still stupid, but does no harm, and I don't want
+to cause programs to break unnecessarily (notably HList).  So if there
+are no data constructors we allow h98_style = True
+-}
+
+
+{- *****************************************************
+*                                                      *
+     Support code for type/data declarations
+*                                                      *
+***************************************************** -}
+
+---------------
+wrongTyFamName :: Name -> Name -> SDoc
+wrongTyFamName fam_tc_name eqn_tc_name
+  = hang (text "Mismatched type name in type family instance.")
+       2 (vcat [ text "Expected:" <+> ppr fam_tc_name
+               , text "  Actual:" <+> ppr eqn_tc_name ])
+
+-----------------
+rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
+rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
+
+rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
+rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
+                           , con_mb_cxt = mcxt, con_args = args
+                           , con_doc = mb_doc })
+  = do  { _        <- addLocM checkConName name
+        ; new_name <- lookupLocatedTopBndrRn name
+        ; mb_doc'  <- rnMbLHsDoc mb_doc
+
+        -- We bind no implicit binders here; this is just like
+        -- a nested HsForAllTy.  E.g. consider
+        --         data T a = forall (b::k). MkT (...)
+        -- The 'k' will already be in scope from the bindHsQTyVars
+        -- for the data decl itself. So we'll get
+        --         data T {k} a = ...
+        -- And indeed we may later discover (a::k).  But that's the
+        -- scoping we get.  So no implicit binders at the existential forall
+
+        ; let ctxt = ConDeclCtx [new_name]
+        ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt))
+                            Nothing ex_tvs $ \ new_ex_tvs ->
+    do  { (new_context, fvs1) <- rnMbContext ctxt mcxt
+        ; (new_args,    fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args
+        ; let all_fvs  = fvs1 `plusFV` fvs2
+        ; traceRn "rnConDecl" (ppr name <+> vcat
+             [ text "ex_tvs:" <+> ppr ex_tvs
+             , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ])
+
+        ; return (decl { con_ext = noExt
+                       , con_name = new_name, con_ex_tvs = new_ex_tvs
+                       , con_mb_cxt = new_context, con_args = new_args
+                       , con_doc = mb_doc' },
+                  all_fvs) }}
+
+rnConDecl decl@(ConDeclGADT { con_names   = names
+                            , con_forall  = (dL->L _ explicit_forall)
+                            , con_qvars   = qtvs
+                            , con_mb_cxt  = mcxt
+                            , con_args    = args
+                            , con_res_ty  = res_ty
+                            , con_doc = mb_doc })
+  = do  { mapM_ (addLocM checkConName) names
+        ; new_names <- mapM lookupLocatedTopBndrRn names
+        ; mb_doc'   <- rnMbLHsDoc mb_doc
+
+        ; let explicit_tkvs = hsQTvExplicit qtvs
+              theta         = hsConDeclTheta mcxt
+              arg_tys       = hsConDeclArgTys args
+
+          -- We must ensure that we extract the free tkvs in left-to-right
+          -- order of their appearance in the constructor type.
+          -- That order governs the order the implicitly-quantified type
+          -- variable, and hence the order needed for visible type application
+          -- See Trac #14808.
+              free_tkvs = extractHsTvBndrs explicit_tkvs $
+                          extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty])
+
+              ctxt    = ConDeclCtx new_names
+              mb_ctxt = Just (inHsDocContext ctxt)
+
+        ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall )
+        ; rnImplicitBndrs (not explicit_forall) free_tkvs $ \ implicit_tkvs ->
+          bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs ->
+    do  { (new_cxt, fvs1)    <- rnMbContext ctxt mcxt
+        ; (new_args, fvs2)   <- rnConDeclDetails (unLoc (head new_names)) ctxt args
+        ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
+
+        ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
+              (args', res_ty')
+                  = case args of
+                      InfixCon {}  -> pprPanic "rnConDecl" (ppr names)
+                      RecCon {}    -> (new_args, new_res_ty)
+                      PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty
+                                   -> ASSERT( null as )
+                                      -- See Note [GADT abstract syntax] in HsDecls
+                                      (PrefixCon arg_tys, final_res_ty)
+
+              new_qtvs =  HsQTvs { hsq_ext = HsQTvsRn
+                                     { hsq_implicit  = implicit_tkvs
+                                     , hsq_dependent = emptyNameSet }
+                                 , hsq_explicit  = explicit_tkvs }
+
+        ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)
+        ; return (decl { con_g_ext = noExt, con_names = new_names
+                       , con_qvars = new_qtvs, con_mb_cxt = new_cxt
+                       , con_args = args', con_res_ty = res_ty'
+                       , con_doc = mb_doc' },
+                  all_fvs) } }
+
+rnConDecl (XConDecl _) = panic "rnConDecl"
+
+
+rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
+            -> RnM (Maybe (LHsContext GhcRn), FreeVars)
+rnMbContext _    Nothing    = return (Nothing, emptyFVs)
+rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt
+                                ; return (Just ctx',fvs) }
+
+rnConDeclDetails
+   :: Name
+   -> HsDocContext
+   -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs])
+   -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
+           FreeVars)
+rnConDeclDetails _ doc (PrefixCon tys)
+  = do { (new_tys, fvs) <- rnLHsTypes doc tys
+       ; return (PrefixCon new_tys, fvs) }
+
+rnConDeclDetails _ doc (InfixCon ty1 ty2)
+  = do { (new_ty1, fvs1) <- rnLHsType doc ty1
+       ; (new_ty2, fvs2) <- rnLHsType doc ty2
+       ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
+
+rnConDeclDetails con doc (RecCon (dL->L l fields))
+  = do  { fls <- lookupConstructorFields con
+        ; (new_fields, fvs) <- rnConDeclFields doc fls fields
+                -- No need to check for duplicate fields
+                -- since that is done by RnNames.extendGlobalRdrEnvRn
+        ; return (RecCon (cL l new_fields), fvs) }
+
+-------------------------------------------------
+
+-- | Brings pattern synonym names and also pattern synonym selectors
+-- from record pattern synonyms into scope.
+extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv
+                -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
+extendPatSynEnv val_decls local_fix_env thing = do {
+     names_with_fls <- new_ps val_decls
+   ; let pat_syn_bndrs = concat [ name: map flSelector fields
+                                | (name, fields) <- names_with_fls ]
+   ; let avails = map avail pat_syn_bndrs
+   ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env
+
+   ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
+         final_gbl_env = gbl_env { tcg_field_env = field_env' }
+   ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
+  where
+    new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
+    new_ps (ValBinds _ binds _) = foldrBagM new_ps' [] binds
+    new_ps _ = panic "new_ps"
+
+    new_ps' :: LHsBindLR GhcPs GhcPs
+            -> [(Name, [FieldLabel])]
+            -> TcM [(Name, [FieldLabel])]
+    new_ps' bind names
+      | (dL->L bind_loc (PatSynBind _ (PSB { psb_id = (dL->L _ n)
+                                           , psb_args = RecCon as }))) <- bind
+      = do
+          bnd_name <- newTopSrcBinder (cL bind_loc n)
+          let rnames = map recordPatSynSelectorId as
+              mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs
+              mkFieldOcc (dL->L l name) = cL l (FieldOcc noExt (cL l name))
+              field_occs =  map mkFieldOcc rnames
+          flds     <- mapM (newRecordSelector False [bnd_name]) field_occs
+          return ((bnd_name, flds): names)
+      | (dL->L bind_loc (PatSynBind _
+                          (PSB { psb_id = (dL->L _ n)}))) <- bind
+      = do
+        bnd_name <- newTopSrcBinder (cL bind_loc n)
+        return ((bnd_name, []): names)
+      | otherwise
+      = return names
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Support code to rename types}
+*                                                      *
+*********************************************************
+-}
+
+rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]
+rnFds fds
+  = mapM (wrapLocM rn_fds) fds
+  where
+    rn_fds (tys1, tys2)
+      = do { tys1' <- rnHsTyVars tys1
+           ; tys2' <- rnHsTyVars tys2
+           ; return (tys1', tys2') }
+
+rnHsTyVars :: [Located RdrName] -> RnM [Located Name]
+rnHsTyVars tvs  = mapM rnHsTyVar tvs
+
+rnHsTyVar :: Located RdrName -> RnM (Located Name)
+rnHsTyVar (dL->L l tyvar) = do
+  tyvar' <- lookupOccRn tyvar
+  return (cL l tyvar')
+
+{-
+*********************************************************
+*                                                      *
+        findSplice
+*                                                      *
+*********************************************************
+
+This code marches down the declarations, looking for the first
+Template Haskell splice.  As it does so it
+        a) groups the declarations into a HsGroup
+        b) runs any top-level quasi-quotes
+-}
+
+findSplice :: [LHsDecl GhcPs]
+           -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
+findSplice ds = addl emptyRdrGroup ds
+
+addl :: HsGroup GhcPs -> [LHsDecl GhcPs]
+     -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
+-- This stuff reverses the declarations (again) but it doesn't matter
+addl gp []           = return (gp, Nothing)
+addl gp ((dL->L l d) : ds) = add gp l d ds
+
+
+add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]
+    -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
+
+-- #10047: Declaration QuasiQuoters are expanded immediately, without
+--         causing a group split
+add gp _ (SpliceD _ (SpliceDecl _ (dL->L _ qq@HsQuasiQuote{}) _)) ds
+  = do { (ds', _) <- rnTopSpliceDecls qq
+       ; addl gp (ds' ++ ds)
+       }
+
+add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds
+  = do { -- We've found a top-level splice.  If it is an *implicit* one
+         -- (i.e. a naked top level expression)
+         case flag of
+           ExplicitSplice -> return ()
+           ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell
+                                ; unless th_on $ setSrcSpan loc $
+                                  failWith badImplicitSplice }
+
+       ; return (gp, Just (splice, ds)) }
+  where
+    badImplicitSplice = text "Parse error: module header, import declaration"
+                     $$ text "or top-level declaration expected."
+                     -- The compiler should suggest the above, and not using
+                     -- TemplateHaskell since the former suggestion is more
+                     -- relevant to the larger base of users.
+                     -- See Trac #12146 for discussion.
+
+-- Class declarations: pull out the fixity signatures to the top
+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds
+  | isClassDecl d
+  = let fsigs = [ cL l f
+                | (dL->L l (FixSig _ f)) <- tcdSigs d ] in
+    addl (gp { hs_tyclds = add_tycld (cL l d) ts, hs_fixds = fsigs ++ fs}) ds
+  | otherwise
+  = addl (gp { hs_tyclds = add_tycld (cL l d) ts }) ds
+
+-- Signatures: fixity sigs go a different place than all others
+add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds
+  = addl (gp {hs_fixds = cL l f : ts}) ds
+add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds
+  = addl (gp {hs_valds = add_sig (cL l d) ts}) ds
+
+-- Value declarations: use add_bind
+add gp@(HsGroup {hs_valds  = ts}) l (ValD _ d) ds
+  = addl (gp { hs_valds = add_bind (cL l d) ts }) ds
+
+-- Role annotations: added to the TyClGroup
+add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds
+  = addl (gp { hs_tyclds = add_role_annot (cL l d) ts }) ds
+
+-- NB instance declarations go into TyClGroups. We throw them into the first
+-- group, just as we do for the TyClD case. The renamer will go on to group
+-- and order them later.
+add gp@(HsGroup {hs_tyclds = ts})  l (InstD _ d) ds
+  = addl (gp { hs_tyclds = add_instd (cL l d) ts }) ds
+
+-- The rest are routine
+add gp@(HsGroup {hs_derivds = ts})  l (DerivD _ d) ds
+  = addl (gp { hs_derivds = cL l d : ts }) ds
+add gp@(HsGroup {hs_defds  = ts})  l (DefD _ d) ds
+  = addl (gp { hs_defds = cL l d : ts }) ds
+add gp@(HsGroup {hs_fords  = ts}) l (ForD _ d) ds
+  = addl (gp { hs_fords = cL l d : ts }) ds
+add gp@(HsGroup {hs_warnds  = ts})  l (WarningD _ d) ds
+  = addl (gp { hs_warnds = cL l d : ts }) ds
+add gp@(HsGroup {hs_annds  = ts}) l (AnnD _ d) ds
+  = addl (gp { hs_annds = cL l d : ts }) ds
+add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD _ d) ds
+  = addl (gp { hs_ruleds = cL l d : ts }) ds
+add gp l (DocD _ d) ds
+  = addl (gp { hs_docs = (cL l d) : (hs_docs gp) })  ds
+add (HsGroup {}) _ (SpliceD _ (XSpliceDecl _)) _ = panic "RnSource.add"
+add (HsGroup {}) _ (XHsDecl _)                 _ = panic "RnSource.add"
+add (XHsGroup _) _ _                           _ = panic "RnSource.add"
+
+add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
+          -> [TyClGroup (GhcPass p)]
+add_tycld d []       = [TyClGroup { group_ext    = noExt
+                                  , group_tyclds = [d]
+                                  , group_roles  = []
+                                  , group_instds = []
+                                  }
+                       ]
+add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
+  = ds { group_tyclds = d : tyclds } : dss
+add_tycld _ (XTyClGroup _: _) = panic "add_tycld"
+
+add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
+          -> [TyClGroup (GhcPass p)]
+add_instd d []       = [TyClGroup { group_ext    = noExt
+                                  , group_tyclds = []
+                                  , group_roles  = []
+                                  , group_instds = [d]
+                                  }
+                       ]
+add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
+  = ds { group_instds = d : instds } : dss
+add_instd _ (XTyClGroup _: _) = panic "add_instd"
+
+add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
+               -> [TyClGroup (GhcPass p)]
+add_role_annot d [] = [TyClGroup { group_ext    = noExt
+                                 , group_tyclds = []
+                                 , group_roles  = [d]
+                                 , group_instds = []
+                                 }
+                      ]
+add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
+  = tycls { group_roles = d : roles } : rest
+add_role_annot _ (XTyClGroup _: _) = panic "add_role_annot"
+
+add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
+add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs
+add_bind _ (XValBindsLR {})     = panic "RdrHsSyn:add_bind"
+
+add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
+add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs)
+add_sig _ (XValBindsLR {})     = panic "RdrHsSyn:add_sig"
diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnSplice.hs
@@ -0,0 +1,904 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module RnSplice (
+        rnTopSpliceDecls,
+        rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,
+        rnBracket,
+        checkThLocalName
+        , traceSplice, SpliceInfo(..)
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Name
+import NameSet
+import HsSyn
+import RdrName
+import TcRnMonad
+
+import RnEnv
+import RnUtils          ( HsDocContext(..), newLocalBndrRn )
+import RnUnbound        ( isUnboundName )
+import RnSource         ( rnSrcDecls, findSplice )
+import RnPat            ( rnPat )
+import BasicTypes       ( TopLevelFlag, isTopLevel, SourceText(..) )
+import Outputable
+import Module
+import SrcLoc
+import RnTypes          ( rnLHsType )
+
+import Control.Monad    ( unless, when )
+
+import {-# SOURCE #-} RnExpr   ( rnLExpr )
+
+import TcEnv            ( checkWellStaged )
+import THNames          ( liftName )
+
+import DynFlags
+import FastString
+import ErrUtils         ( dumpIfSet_dyn_printer )
+import TcEnv            ( tcMetaTy )
+import Hooks
+import THNames          ( quoteExpName, quotePatName, quoteDecName, quoteTypeName
+                        , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )
+
+import {-# SOURCE #-} TcExpr   ( tcPolyExpr )
+import {-# SOURCE #-} TcSplice
+    ( runMetaD
+    , runMetaE
+    , runMetaP
+    , runMetaT
+    , tcTopSpliceExpr
+    )
+
+import TcHsSyn
+
+import GHCi.RemoteTypes ( ForeignRef )
+import qualified Language.Haskell.TH as TH (Q)
+
+import qualified GHC.LanguageExtensions as LangExt
+
+{-
+************************************************************************
+*                                                                      *
+        Template Haskell brackets
+*                                                                      *
+************************************************************************
+-}
+
+rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)
+rnBracket e br_body
+  = addErrCtxt (quotationCtxtDoc br_body) $
+    do { -- Check that -XTemplateHaskellQuotes is enabled and available
+         thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes
+       ; unless thQuotesEnabled $
+           failWith ( vcat
+                      [ text "Syntax error on" <+> ppr e
+                      , text ("Perhaps you intended to use TemplateHaskell"
+                              ++ " or TemplateHaskellQuotes") ] )
+
+         -- Check for nested brackets
+       ; cur_stage <- getStage
+       ; case cur_stage of
+           { Splice Typed   -> checkTc (isTypedBracket br_body)
+                                       illegalUntypedBracket
+           ; Splice Untyped -> checkTc (not (isTypedBracket br_body))
+                                       illegalTypedBracket
+           ; RunSplice _    ->
+               -- See Note [RunSplice ThLevel] in "TcRnTypes".
+               pprPanic "rnBracket: Renaming bracket when running a splice"
+                        (ppr e)
+           ; Comp           -> return ()
+           ; Brack {}       -> failWithTc illegalBracket
+           }
+
+         -- Brackets are desugared to code that mentions the TH package
+       ; recordThUse
+
+       ; case isTypedBracket br_body of
+            True  -> do { traceRn "Renaming typed TH bracket" empty
+                        ; (body', fvs_e) <-
+                          setStage (Brack cur_stage RnPendingTyped) $
+                                   rn_bracket cur_stage br_body
+                        ; return (HsBracket noExt body', fvs_e) }
+
+            False -> do { traceRn "Renaming untyped TH bracket" empty
+                        ; ps_var <- newMutVar []
+                        ; (body', fvs_e) <-
+                          setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
+                                   rn_bracket cur_stage br_body
+                        ; pendings <- readMutVar ps_var
+                        ; return (HsRnBracketOut noExt body' pendings, fvs_e) }
+       }
+
+rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)
+rn_bracket outer_stage br@(VarBr x flg rdr_name)
+  = do { name <- lookupOccRn rdr_name
+       ; this_mod <- getModule
+
+       ; when (flg && nameIsLocalOrFrom this_mod name) $
+             -- Type variables can be quoted in TH. See #5721.
+                 do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name
+                    ; case mb_bind_lvl of
+                        { Nothing -> return ()      -- Can happen for data constructors,
+                                                    -- but nothing needs to be done for them
+
+                        ; Just (top_lvl, bind_lvl)  -- See Note [Quoting names]
+                             | isTopLevel top_lvl
+                             -> when (isExternalName name) (keepAlive name)
+                             | otherwise
+                             -> do { traceRn "rn_bracket VarBr"
+                                      (ppr name <+> ppr bind_lvl
+                                                <+> ppr outer_stage)
+                                   ; checkTc (thLevel outer_stage + 1 == bind_lvl)
+                                             (quotedNameStageErr br) }
+                        }
+                    }
+       ; return (VarBr x flg name, unitFV name) }
+
+rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e
+                            ; return (ExpBr x e', fvs) }
+
+rn_bracket _ (PatBr x p)
+  = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs)
+
+rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t
+                              ; return (TypBr x t', fvs) }
+
+rn_bracket _ (DecBrL x decls)
+  = do { group <- groupDecls decls
+       ; gbl_env  <- getGblEnv
+       ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
+                          -- The emptyDUs is so that we just collect uses for this
+                          -- group alone in the call to rnSrcDecls below
+       ; (tcg_env, group') <- setGblEnv new_gbl_env $
+                              rnSrcDecls group
+
+              -- Discard the tcg_env; it contains only extra info about fixity
+        ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$
+                   ppr (duUses (tcg_dus tcg_env)))
+        ; return (DecBrG x group', duUses (tcg_dus tcg_env)) }
+  where
+    groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)
+    groupDecls decls
+      = do { (group, mb_splice) <- findSplice decls
+           ; case mb_splice of
+           { Nothing -> return group
+           ; Just (splice, rest) ->
+               do { group' <- groupDecls rest
+                  ; let group'' = appendGroups group group'
+                  ; return group'' { hs_splcds = noLoc splice : hs_splcds group' }
+                  }
+           }}
+
+rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG"
+
+rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e
+                               ; return (TExpBr x e', fvs) }
+
+rn_bracket _ (XBracket {}) = panic "rn_bracket: unexpected XBracket"
+
+quotationCtxtDoc :: HsBracket GhcPs -> SDoc
+quotationCtxtDoc br_body
+  = hang (text "In the Template Haskell quotation")
+         2 (ppr br_body)
+
+illegalBracket :: SDoc
+illegalBracket =
+    text "Template Haskell brackets cannot be nested" <+>
+    text "(without intervening splices)"
+
+illegalTypedBracket :: SDoc
+illegalTypedBracket =
+    text "Typed brackets may only appear in typed splices."
+
+illegalUntypedBracket :: SDoc
+illegalUntypedBracket =
+    text "Untyped brackets may only appear in untyped splices."
+
+quotedNameStageErr :: HsBracket GhcPs -> SDoc
+quotedNameStageErr br
+  = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br
+        , text "must be used at the same stage at which it is bound" ]
+
+
+{-
+*********************************************************
+*                                                      *
+                Splices
+*                                                      *
+*********************************************************
+
+Note [Free variables of typed splices]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider renaming this:
+        f = ...
+        h = ...$(thing "f")...
+
+where the splice is a *typed* splice.  The splice can expand into
+literally anything, so when we do dependency analysis we must assume
+that it might mention 'f'.  So we simply treat all locally-defined
+names as mentioned by any splice.  This is terribly brutal, but I
+don't see what else to do.  For example, it'll mean that every
+locally-defined thing will appear to be used, so no unused-binding
+warnings.  But if we miss the dependency, then we might typecheck 'h'
+before 'f', and that will crash the type checker because 'f' isn't in
+scope.
+
+Currently, I'm not treating a splice as also mentioning every import,
+which is a bit inconsistent -- but there are a lot of them.  We might
+thereby get some bogus unused-import warnings, but we won't crash the
+type checker.  Not very satisfactory really.
+
+Note [Renamer errors]
+~~~~~~~~~~~~~~~~~~~~~
+It's important to wrap renamer calls in checkNoErrs, because the
+renamer does not fail for out of scope variables etc. Instead it
+returns a bogus term/type, so that it can report more than one error.
+We don't want the type checker to see these bogus unbound variables.
+-}
+
+rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars))
+                                            -- Outside brackets, run splice
+            -> (HsSplice GhcRn -> (PendingRnSplice, a))
+                                            -- Inside brackets, make it pending
+            -> HsSplice GhcPs
+            -> RnM (a, FreeVars)
+rnSpliceGen run_splice pend_splice splice
+  = addErrCtxt (spliceCtxt splice) $ do
+    { stage <- getStage
+    ; case stage of
+        Brack pop_stage RnPendingTyped
+          -> do { checkTc is_typed_splice illegalUntypedSplice
+                ; (splice', fvs) <- setStage pop_stage $
+                                    rnSplice splice
+                ; let (_pending_splice, result) = pend_splice splice'
+                ; return (result, fvs) }
+
+        Brack pop_stage (RnPendingUntyped ps_var)
+          -> do { checkTc (not is_typed_splice) illegalTypedSplice
+                ; (splice', fvs) <- setStage pop_stage $
+                                    rnSplice splice
+                ; let (pending_splice, result) = pend_splice splice'
+                ; ps <- readMutVar ps_var
+                ; writeMutVar ps_var (pending_splice : ps)
+                ; return (result, fvs) }
+
+        _ ->  do { (splice', fvs1) <- checkNoErrs $
+                                      setStage (Splice splice_type) $
+                                      rnSplice splice
+                   -- checkNoErrs: don't attempt to run the splice if
+                   -- renaming it failed; otherwise we get a cascade of
+                   -- errors from e.g. unbound variables
+                 ; (result, fvs2) <- run_splice splice'
+                 ; return (result, fvs1 `plusFV` fvs2) } }
+   where
+     is_typed_splice = isTypedSplice splice
+     splice_type = if is_typed_splice
+                   then Typed
+                   else Untyped
+
+------------------
+
+-- | Returns the result of running a splice and the modFinalizers collected
+-- during the execution.
+--
+-- See Note [Delaying modFinalizers in untyped splices].
+runRnSplice :: UntypedSpliceFlavour
+            -> (LHsExpr GhcTc -> TcRn res)
+            -> (res -> SDoc)    -- How to pretty-print res
+                                -- Usually just ppr, but not for [Decl]
+            -> HsSplice GhcRn   -- Always untyped
+            -> TcRn (res, [ForeignRef (TH.Q ())])
+runRnSplice flavour run_meta ppr_res splice
+  = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)
+
+       ; let the_expr = case splice' of
+                HsUntypedSplice _ _ _ e   ->  e
+                HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str
+                HsTypedSplice {}          -> pprPanic "runRnSplice" (ppr splice)
+                HsSpliced {}              -> pprPanic "runRnSplice" (ppr splice)
+                HsSplicedT {}             -> pprPanic "runRnSplice" (ppr splice)
+                XSplice {}                -> pprPanic "runRnSplice" (ppr splice)
+
+             -- Typecheck the expression
+       ; meta_exp_ty   <- tcMetaTy meta_ty_name
+       ; zonked_q_expr <- zonkTopLExpr =<<
+                            tcTopSpliceExpr Untyped
+                              (tcPolyExpr the_expr meta_exp_ty)
+
+             -- Run the expression
+       ; mod_finalizers_ref <- newTcRef []
+       ; result <- setStage (RunSplice mod_finalizers_ref) $
+                     run_meta zonked_q_expr
+       ; mod_finalizers <- readTcRef mod_finalizers_ref
+       ; traceSplice (SpliceInfo { spliceDescription = what
+                                 , spliceIsDecl      = is_decl
+                                 , spliceSource      = Just the_expr
+                                 , spliceGenerated   = ppr_res result })
+
+       ; return (result, mod_finalizers) }
+
+  where
+    meta_ty_name = case flavour of
+                       UntypedExpSplice  -> expQTyConName
+                       UntypedPatSplice  -> patQTyConName
+                       UntypedTypeSplice -> typeQTyConName
+                       UntypedDeclSplice -> decsQTyConName
+    what = case flavour of
+                  UntypedExpSplice  -> "expression"
+                  UntypedPatSplice  -> "pattern"
+                  UntypedTypeSplice -> "type"
+                  UntypedDeclSplice -> "declarations"
+    is_decl = case flavour of
+                 UntypedDeclSplice -> True
+                 _                 -> False
+
+------------------
+makePending :: UntypedSpliceFlavour
+            -> HsSplice GhcRn
+            -> PendingRnSplice
+makePending flavour (HsUntypedSplice _ _ n e)
+  = PendingRnSplice flavour n e
+makePending flavour (HsQuasiQuote _ n quoter q_span quote)
+  = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)
+makePending _ splice@(HsTypedSplice {})
+  = pprPanic "makePending" (ppr splice)
+makePending _ splice@(HsSpliced {})
+  = pprPanic "makePending" (ppr splice)
+makePending _ splice@(HsSplicedT {})
+  = pprPanic "makePending" (ppr splice)
+makePending _ splice@(XSplice {})
+  = pprPanic "makePending" (ppr splice)
+
+------------------
+mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString
+                 -> LHsExpr GhcRn
+-- Return the expression (quoter "...quote...")
+-- which is what we must run in a quasi-quote
+mkQuasiQuoteExpr flavour quoter q_span quote
+  = cL q_span $ HsApp noExt (cL q_span
+              $ HsApp noExt (cL q_span (HsVar noExt (cL q_span quote_selector)))
+                            quoterExpr)
+                     quoteExpr
+  where
+    quoterExpr = cL q_span $! HsVar noExt $! (cL q_span quoter)
+    quoteExpr  = cL q_span $! HsLit noExt $! HsString NoSourceText quote
+    quote_selector = case flavour of
+                       UntypedExpSplice  -> quoteExpName
+                       UntypedPatSplice  -> quotePatName
+                       UntypedTypeSplice -> quoteTypeName
+                       UntypedDeclSplice -> quoteDecName
+
+---------------------
+rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars)
+-- Not exported...used for all
+rnSplice (HsTypedSplice x hasParen splice_name expr)
+  = do  { checkTH expr "Template Haskell typed splice"
+        ; loc  <- getSrcSpanM
+        ; n' <- newLocalBndrRn (cL loc splice_name)
+        ; (expr', fvs) <- rnLExpr expr
+        ; return (HsTypedSplice x hasParen n' expr', fvs) }
+
+rnSplice (HsUntypedSplice x hasParen splice_name expr)
+  = do  { checkTH expr "Template Haskell untyped splice"
+        ; loc  <- getSrcSpanM
+        ; n' <- newLocalBndrRn (cL loc splice_name)
+        ; (expr', fvs) <- rnLExpr expr
+        ; return (HsUntypedSplice x hasParen n' expr', fvs) }
+
+rnSplice (HsQuasiQuote x splice_name quoter q_loc quote)
+  = do  { checkTH quoter "Template Haskell quasi-quote"
+        ; loc  <- getSrcSpanM
+        ; splice_name' <- newLocalBndrRn (cL loc splice_name)
+
+          -- Rename the quoter; akin to the HsVar case of rnExpr
+        ; quoter' <- lookupOccRn quoter
+        ; this_mod <- getModule
+        ; when (nameIsLocalOrFrom this_mod quoter') $
+          checkThLocalName quoter'
+
+        ; return (HsQuasiQuote x splice_name' quoter' q_loc quote
+                                                             , unitFV quoter') }
+
+rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice)
+rnSplice splice@(HsSplicedT {}) = pprPanic "rnSplice" (ppr splice)
+rnSplice splice@(XSplice {})   = pprPanic "rnSplice" (ppr splice)
+
+---------------------
+rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)
+rnSpliceExpr splice
+  = rnSpliceGen run_expr_splice pend_expr_splice splice
+  where
+    pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)
+    pend_expr_splice rn_splice
+        = (makePending UntypedExpSplice rn_splice, HsSpliceE noExt rn_splice)
+
+    run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)
+    run_expr_splice rn_splice
+      | isTypedSplice rn_splice   -- Run it later, in the type checker
+      = do {  -- Ugh!  See Note [Splices] above
+             traceRn "rnSpliceExpr: typed expression splice" empty
+           ; lcl_rdr <- getLocalRdrEnv
+           ; gbl_rdr <- getGlobalRdrEnv
+           ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr
+                                                     , isLocalGRE gre]
+                 lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
+
+           ; return (HsSpliceE noExt rn_splice, lcl_names `plusFV` gbl_names) }
+
+      | otherwise  -- Run it here, see Note [Running splices in the Renamer]
+      = do { traceRn "rnSpliceExpr: untyped expression splice" empty
+           ; (rn_expr, mod_finalizers) <-
+                runRnSplice UntypedExpSplice runMetaE ppr rn_splice
+           ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
+             -- See Note [Delaying modFinalizers in untyped splices].
+           ; return ( HsPar noExt $ HsSpliceE noExt
+                            . HsSpliced noExt (ThModFinalizers mod_finalizers)
+                            . HsSplicedExpr <$>
+                            lexpr3
+                    , fvs)
+           }
+
+{- Note [Running splices in the Renamer]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Splices used to be run in the typechecker, which led to (Trac #4364). Since the
+renamer must decide which expressions depend on which others, and it cannot
+reliably do this for arbitrary splices, we used to conservatively say that
+splices depend on all other expressions in scope. Unfortunately, this led to
+the problem of cyclic type declarations seen in (Trac #4364). Instead, by
+running splices in the renamer, we side-step the problem of determining
+dependencies: by the time the dependency analysis happens, any splices have
+already been run, and expression dependencies can be determined as usual.
+
+However, see (Trac #9813), for an example where we would like to run splices
+*after* performing dependency analysis (that is, after renaming). It would be
+desirable to typecheck "non-splicy" expressions (those expressions that do not
+contain splices directly or via dependence on an expression that does) before
+"splicy" expressions, such that types/expressions within the same declaration
+group would be available to `reify` calls, for example consider the following:
+
+> module M where
+>   data D = C
+>   f = 1
+>   g = $(mapM reify ['f, 'D, ''C] ...)
+
+Compilation of this example fails since D/C/f are not in the type environment
+and thus cannot be reified as they have not been typechecked by the time the
+splice is renamed and thus run.
+
+These requirements are at odds: we do not want to run splices in the renamer as
+we wish to first determine dependencies and typecheck certain expressions,
+making them available to reify, but cannot accurately determine dependencies
+without running splices in the renamer!
+
+Indeed, the conclusion of (Trac #9813) was that it is not worth the complexity
+to try and
+ a) implement and maintain the code for renaming/typechecking non-splicy
+    expressions before splicy expressions,
+ b) explain to TH users which expressions are/not available to reify at any
+    given point.
+
+-}
+
+{- Note [Delaying modFinalizers in untyped splices]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When splices run in the renamer, 'reify' does not have access to the local
+type environment (Trac #11832, [1]).
+
+For instance, in
+
+> let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |])
+
+'reify' cannot find @x@, because the local type environment is not yet
+populated. To address this, we allow 'reify' execution to be deferred with
+'addModFinalizer'.
+
+> let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print)
+                    [| return () |]
+                )
+
+The finalizer is run with the local type environment when type checking is
+complete.
+
+Since the local type environment is not available in the renamer, we annotate
+the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where
+@e@ is the result of splicing and @finalizers@ are the finalizers that have been
+collected during evaluation of the splice [3]. In our example,
+
+> HsLet
+>   (x = e)
+>   (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print]
+>                          (HsSplicedExpr $ return ())
+>   )
+
+When the typechecker finds the annotation, it inserts the finalizers in the
+global environment and exposes the current local environment to them [4, 5, 6].
+
+> addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print]
+
+References:
+
+[1] https://ghc.haskell.org/trac/ghc/wiki/TemplateHaskell/Reify
+[2] 'rnSpliceExpr'
+[3] 'TcSplice.qAddModFinalizer'
+[4] 'TcExpr.tcExpr' ('HsSpliceE' ('HsSpliced' ...))
+[5] 'TcHsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...))
+[6] 'TcPat.tc_pat' ('SplicePat' ('HsSpliced' ...))
+
+-}
+
+----------------------
+rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
+rnSpliceType splice
+  = rnSpliceGen run_type_splice pend_type_splice splice
+  where
+    pend_type_splice rn_splice
+       = ( makePending UntypedTypeSplice rn_splice
+         , HsSpliceTy noExt rn_splice)
+
+    run_type_splice rn_splice
+      = do { traceRn "rnSpliceType: untyped type splice" empty
+           ; (hs_ty2, mod_finalizers) <-
+                runRnSplice UntypedTypeSplice runMetaT ppr rn_splice
+           ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2
+                                 ; checkNoErrs $ rnLHsType doc hs_ty2 }
+                                    -- checkNoErrs: see Note [Renamer errors]
+             -- See Note [Delaying modFinalizers in untyped splices].
+           ; return ( HsParTy noExt $ HsSpliceTy noExt
+                              . HsSpliced noExt (ThModFinalizers mod_finalizers)
+                              . HsSplicedTy <$>
+                              hs_ty3
+                    , fvs
+                    ) }
+              -- Wrap the result of the splice in parens so that we don't
+              -- lose the outermost location set by runQuasiQuote (#7918)
+
+{- Note [Partial Type Splices]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Partial Type Signatures are partially supported in TH type splices: only
+anonymous wild cards are allowed.
+
+  -- ToDo: SLPJ says: I don't understand all this
+
+Normally, named wild cards are collected before renaming a (partial) type
+signature. However, TH type splices are run during renaming, i.e. after the
+initial traversal, leading to out of scope errors for named wild cards. We
+can't just extend the initial traversal to collect the named wild cards in TH
+type splices, as we'd need to expand them, which is supposed to happen only
+once, during renaming.
+
+Similarly, the extra-constraints wild card is handled right before renaming
+too, and is therefore also not supported in a TH type splice. Another reason
+to forbid extra-constraints wild cards in TH type splices is that a single
+signature can contain many TH type splices, whereas it mustn't contain more
+than one extra-constraints wild card. Enforcing would this be hard the way
+things are currently organised.
+
+Anonymous wild cards pose no problem, because they start out without names and
+are given names during renaming. These names are collected right after
+renaming. The names generated for anonymous wild cards in TH type splices will
+thus be collected as well.
+
+For more details about renaming wild cards, see RnTypes.rnHsSigWcType
+
+Note that partial type signatures are fully supported in TH declaration
+splices, e.g.:
+
+     [d| foo :: _ => _
+         foo x y = x == y |]
+
+This is because in this case, the partial type signature can be treated as a
+whole signature, instead of as an arbitrary type.
+
+-}
+
+
+----------------------
+-- | Rename a splice pattern. See Note [rnSplicePat]
+rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn)
+                                       , FreeVars)
+rnSplicePat splice
+  = rnSpliceGen run_pat_splice pend_pat_splice splice
+  where
+    pend_pat_splice :: HsSplice GhcRn ->
+                       (PendingRnSplice, Either b (Pat GhcRn))
+    pend_pat_splice rn_splice
+      = (makePending UntypedPatSplice rn_splice
+        , Right (SplicePat noExt rn_splice))
+
+    run_pat_splice :: HsSplice GhcRn ->
+                      RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)
+    run_pat_splice rn_splice
+      = do { traceRn "rnSplicePat: untyped pattern splice" empty
+           ; (pat, mod_finalizers) <-
+                runRnSplice UntypedPatSplice runMetaP ppr rn_splice
+             -- See Note [Delaying modFinalizers in untyped splices].
+           ; return ( Left $ ParPat noExt $ ((SplicePat noExt)
+                              . HsSpliced noExt (ThModFinalizers mod_finalizers)
+                              . HsSplicedPat)  `onHasSrcSpan`
+                              pat
+                    , emptyFVs
+                    ) }
+              -- Wrap the result of the quasi-quoter in parens so that we don't
+              -- lose the outermost location set by runQuasiQuote (#7918)
+
+----------------------
+rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
+rnSpliceDecl (SpliceDecl _ (dL->L loc splice) flg)
+  = rnSpliceGen run_decl_splice pend_decl_splice splice
+  where
+    pend_decl_splice rn_splice
+       = ( makePending UntypedDeclSplice rn_splice
+         , SpliceDecl noExt (cL loc rn_splice) flg)
+
+    run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)
+rnSpliceDecl (XSpliceDecl _) = panic "rnSpliceDecl"
+
+rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
+-- Declaration splice at the very top level of the module
+rnTopSpliceDecls splice
+   = do  { (rn_splice, fvs) <- checkNoErrs $
+                               setStage (Splice Untyped) $
+                               rnSplice splice
+           -- As always, be sure to checkNoErrs above lest we end up with
+           -- holes making it to typechecking, hence #12584.
+           --
+           -- Note that we cannot call checkNoErrs for the whole duration
+           -- of rnTopSpliceDecls. The reason is that checkNoErrs changes
+           -- the local environment to temporarily contain a new
+           -- reference to store errors, and add_mod_finalizers would
+           -- cause this reference to be stored after checkNoErrs finishes.
+           -- This is checked by test TH_finalizer.
+         ; traceRn "rnTopSpliceDecls: untyped declaration splice" empty
+         ; (decls, mod_finalizers) <- checkNoErrs $
+               runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice
+         ; add_mod_finalizers_now mod_finalizers
+         ; return (decls,fvs) }
+   where
+     ppr_decls :: [LHsDecl GhcPs] -> SDoc
+     ppr_decls ds = vcat (map ppr ds)
+
+     -- Adds finalizers to the global environment instead of delaying them
+     -- to the type checker.
+     --
+     -- Declaration splices do not have an interesting local environment so
+     -- there is no point in delaying them.
+     --
+     -- See Note [Delaying modFinalizers in untyped splices].
+     add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn ()
+     add_mod_finalizers_now []             = return ()
+     add_mod_finalizers_now mod_finalizers = do
+       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
+       env <- getLclEnv
+       updTcRef th_modfinalizers_var $ \fins ->
+         (env, ThModFinalizers mod_finalizers) : fins
+
+
+{-
+Note [rnSplicePat]
+~~~~~~~~~~~~~~~~~~
+Renaming a pattern splice is a bit tricky, because we need the variables
+bound in the pattern to be in scope in the RHS of the pattern. This scope
+management is effectively done by using continuation-passing style in
+RnPat, through the CpsRn monad. We don't wish to be in that monad here
+(it would create import cycles and generally conflict with renaming other
+splices), so we really want to return a (Pat RdrName) -- the result of
+running the splice -- which can then be further renamed in RnPat, in
+the CpsRn monad.
+
+The problem is that if we're renaming a splice within a bracket, we
+*don't* want to run the splice now. We really do just want to rename
+it to an HsSplice Name. Of course, then we can't know what variables
+are bound within the splice. So we accept any unbound variables and
+rename them again when the bracket is spliced in.  If a variable is brought
+into scope by a pattern splice all is fine.  If it is not then an error is
+reported.
+
+In any case, when we're done in rnSplicePat, we'll either have a
+Pat RdrName (the result of running a top-level splice) or a Pat Name
+(the renamed nested splice). Thus, the awkward return type of
+rnSplicePat.
+-}
+
+spliceCtxt :: HsSplice GhcPs -> SDoc
+spliceCtxt splice
+  = hang (text "In the" <+> what) 2 (ppr splice)
+  where
+    what = case splice of
+             HsUntypedSplice {} -> text "untyped splice:"
+             HsTypedSplice   {} -> text "typed splice:"
+             HsQuasiQuote    {} -> text "quasi-quotation:"
+             HsSpliced       {} -> text "spliced expression:"
+             HsSplicedT      {} -> text "spliced expression:"
+             XSplice         {} -> text "spliced expression:"
+
+-- | The splice data to be logged
+data SpliceInfo
+  = SpliceInfo
+    { spliceDescription  :: String
+    , spliceSource       :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls
+                                                  --        added by addTopDecls
+    , spliceIsDecl       :: Bool    -- True <=> put the generate code in a file
+                                    --          when -dth-dec-file is on
+    , spliceGenerated    :: SDoc
+    }
+        -- Note that 'spliceSource' is *renamed* but not *typechecked*
+        -- Reason (a) less typechecking crap
+        --        (b) data constructors after type checking have been
+        --            changed to their *wrappers*, and that makes them
+        --            print always fully qualified
+
+-- | outputs splice information for 2 flags which have different output formats:
+-- `-ddump-splices` and `-dth-dec-file`
+traceSplice :: SpliceInfo -> TcM ()
+traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src
+                        , spliceGenerated = gen, spliceIsDecl = is_decl })
+  = do { loc <- case mb_src of
+                   Nothing           -> getSrcSpanM
+                   Just (dL->L loc _) -> return loc
+       ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)
+
+       ; when is_decl $  -- Raw material for -dth-dec-file
+         do { dflags <- getDynFlags
+            ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file
+                                             (spliceCodeDoc loc) } }
+  where
+    -- `-ddump-splices`
+    spliceDebugDoc :: SrcSpan -> SDoc
+    spliceDebugDoc loc
+      = let code = case mb_src of
+                     Nothing -> ending
+                     Just e  -> nest 2 (ppr e) : ending
+            ending = [ text "======>", nest 2 gen ]
+        in  hang (ppr loc <> colon <+> text "Splicing" <+> text sd)
+               2 (sep code)
+
+    -- `-dth-dec-file`
+    spliceCodeDoc :: SrcSpan -> SDoc
+    spliceCodeDoc loc
+      = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd
+             , gen ]
+
+illegalTypedSplice :: SDoc
+illegalTypedSplice = text "Typed splices may not appear in untyped brackets"
+
+illegalUntypedSplice :: SDoc
+illegalUntypedSplice = text "Untyped splices may not appear in typed brackets"
+
+checkThLocalName :: Name -> RnM ()
+checkThLocalName name
+  | isUnboundName name   -- Do not report two errors for
+  = return ()            --   $(not_in_scope args)
+
+  | otherwise
+  = do  { traceRn "checkThLocalName" (ppr name)
+        ; mb_local_use <- getStageAndBindLevel name
+        ; case mb_local_use of {
+             Nothing -> return () ;  -- Not a locally-bound thing
+             Just (top_lvl, bind_lvl, use_stage) ->
+    do  { let use_lvl = thLevel use_stage
+        ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl
+        ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl
+                                               <+> ppr use_stage
+                                               <+> ppr use_lvl)
+        ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } }
+
+--------------------------------------
+checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel
+                       -> Name -> TcM ()
+-- We are inside brackets, and (use_lvl > bind_lvl)
+-- Now we must check whether there's a cross-stage lift to do
+-- Examples   \x -> [| x |]
+--            [| map |]
+--
+-- This code is similar to checkCrossStageLifting in TcExpr, but
+-- this is only run on *untyped* brackets.
+
+checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name
+  | Brack _ (RnPendingUntyped ps_var) <- use_stage   -- Only for untyped brackets
+  , use_lvl > bind_lvl                               -- Cross-stage condition
+  = check_cross_stage_lifting top_lvl name ps_var
+  | otherwise
+  = return ()
+
+check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()
+check_cross_stage_lifting top_lvl name ps_var
+  | isTopLevel top_lvl
+        -- Top-level identifiers in this module,
+        -- (which have External Names)
+        -- are just like the imported case:
+        -- no need for the 'lifting' treatment
+        -- E.g.  this is fine:
+        --   f x = x
+        --   g y = [| f 3 |]
+  = when (isExternalName name) (keepAlive name)
+    -- See Note [Keeping things alive for Template Haskell]
+
+  | otherwise
+  =     -- Nested identifiers, such as 'x' in
+        -- E.g. \x -> [| h x |]
+        -- We must behave as if the reference to x was
+        --      h $(lift x)
+        -- We use 'x' itself as the SplicePointName, used by
+        -- the desugarer to stitch it all back together.
+        -- If 'x' occurs many times we may get many identical
+        -- bindings of the same SplicePointName, but that doesn't
+        -- matter, although it's a mite untidy.
+    do  { traceRn "checkCrossStageLifting" (ppr name)
+
+          -- Construct the (lift x) expression
+        ; let lift_expr   = nlHsApp (nlHsVar liftName) (nlHsVar name)
+              pend_splice = PendingRnSplice UntypedExpSplice name lift_expr
+
+          -- Update the pending splices
+        ; ps <- readMutVar ps_var
+        ; writeMutVar ps_var (pend_splice : ps) }
+
+{-
+Note [Keeping things alive for Template Haskell]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f x = x+1
+  g y = [| f 3 |]
+
+Here 'f' is referred to from inside the bracket, which turns into data
+and mentions only f's *name*, not 'f' itself. So we need some other
+way to keep 'f' alive, lest it get dropped as dead code.  That's what
+keepAlive does. It puts it in the keep-alive set, which subsequently
+ensures that 'f' stays as a top level binding.
+
+This must be done by the renamer, not the type checker (as of old),
+because the type checker doesn't typecheck the body of untyped
+brackets (Trac #8540).
+
+A thing can have a bind_lvl of outerLevel, but have an internal name:
+   foo = [d| op = 3
+             bop = op + 1 |]
+Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is
+bound inside a bracket.  That is because we don't even even record
+binding levels for top-level things; the binding levels are in the
+LocalRdrEnv.
+
+So the occurrence of 'op' in the rhs of 'bop' looks a bit like a
+cross-stage thing, but it isn't really.  And in fact we never need
+to do anything here for top-level bound things, so all is fine, if
+a bit hacky.
+
+For these chaps (which have Internal Names) we don't want to put
+them in the keep-alive set.
+
+Note [Quoting names]
+~~~~~~~~~~~~~~~~~~~~
+A quoted name 'n is a bit like a quoted expression [| n |], except that we
+have no cross-stage lifting (c.f. TcExpr.thBrackId).  So, after incrementing
+the use-level to account for the brackets, the cases are:
+
+        bind > use                      Error
+        bind = use+1                    OK
+        bind < use
+                Imported things         OK
+                Top-level things        OK
+                Non-top-level           Error
+
+where 'use' is the binding level of the 'n quote. (So inside the implied
+bracket the level would be use+1.)
+
+Examples:
+
+  f 'map        -- OK; also for top-level defns of this module
+
+  \x. f 'x      -- Not ok (bind = 1, use = 1)
+                -- (whereas \x. f [| x |] might have been ok, by
+                --                               cross-stage lifting
+
+  \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1)
+
+  [| \x. $(f 'x) |]     -- OK (bind = 2, use = 1)
+-}
diff --git a/compiler/rename/RnSplice.hs-boot b/compiler/rename/RnSplice.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnSplice.hs-boot
@@ -0,0 +1,14 @@
+module RnSplice where
+
+import GhcPrelude
+import HsSyn
+import TcRnMonad
+import NameSet
+
+
+rnSpliceType :: HsSplice GhcPs   -> RnM (HsType GhcRn, FreeVars)
+rnSplicePat  :: HsSplice GhcPs   -> RnM ( Either (Pat GhcPs) (Pat GhcRn)
+                                          , FreeVars )
+rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)
+
+rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnTypes.hs
@@ -0,0 +1,1876 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[RnSource]{Main pass of renamer}
+-}
+
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module RnTypes (
+        -- Type related stuff
+        rnHsType, rnLHsType, rnLHsTypes, rnContext,
+        rnHsKind, rnLHsKind, rnLHsTypeArgs,
+        rnHsSigType, rnHsWcType,
+        HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,
+        newTyVarNameRn,
+        rnConDeclFields,
+        rnLTyVar,
+
+        -- Precence related stuff
+        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
+        checkPrecMatch, checkSectionPrec,
+
+        -- Binding related stuff
+        bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,
+        bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
+        extractFilteredRdrTyVars, extractFilteredRdrTyVarsDups,
+        extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
+        extractHsTyRdrTyVarsDups, extractHsTysRdrTyVars,
+        extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,
+        extractRdrKindSigVars, extractDataDefnKindVars,
+        extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup,
+        freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars,
+        elemRdr
+  ) where
+
+import GhcPrelude
+
+import {-# SOURCE #-} RnSplice( rnSpliceType )
+
+import DynFlags
+import HsSyn
+import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
+import RnEnv
+import RnUtils          ( HsDocContext(..), withHsDocContext, mapFvRn
+                        , pprHsDocContext, bindLocalNamesFV, typeAppErr
+                        , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames )
+import RnFixity         ( lookupFieldFixityRn, lookupFixityRn
+                        , lookupTyFixityRn )
+import TcRnMonad
+import RdrName
+import PrelNames
+import TysPrim          ( funTyConName )
+import Name
+import SrcLoc
+import NameSet
+import FieldLabel
+
+import Util
+import ListSetOps       ( deleteBys )
+import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
+                          Fixity(..), FixityDirection(..), LexicalFixity(..) )
+import Outputable
+import FastString
+import Maybes
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.List          ( nubBy, partition, (\\) )
+import Control.Monad      ( unless, when )
+
+#include "HsVersions.h"
+
+{-
+These type renamers are in a separate module, rather than in (say) RnSource,
+to break several loop.
+
+*********************************************************
+*                                                       *
+           HsSigWcType (i.e with wildcards)
+*                                                       *
+*********************************************************
+-}
+
+data HsSigWcTypeScoping = AlwaysBind
+                          -- ^ Always bind any free tyvars of the given type,
+                          --   regardless of whether we have a forall at the top
+                        | BindUnlessForall
+                          -- ^ Unless there's forall at the top, do the same
+                          --   thing as 'AlwaysBind'
+                        | NeverBind
+                          -- ^ Never bind any free tyvars
+
+rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
+              -> RnM (LHsSigWcType GhcRn, FreeVars)
+rnHsSigWcType scoping doc sig_ty
+  = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' ->
+    return (sig_ty', emptyFVs)
+
+rnHsSigWcTypeScoped :: HsSigWcTypeScoping
+                       -- AlwaysBind: for pattern type sigs and rules we /do/ want
+                       --             to bring those type variables into scope, even
+                       --             if there's a forall at the top which usually
+                       --             stops that happening
+                       -- e.g  \ (x :: forall a. a-> b) -> e
+                       -- Here we do bring 'b' into scope
+                    -> HsDocContext -> LHsSigWcType GhcPs
+                    -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
+                    -> RnM (a, FreeVars)
+-- Used for
+--   - Signatures on binders in a RULE
+--   - Pattern type signatures
+-- Wildcards are allowed
+-- type signatures on binders only allowed with ScopedTypeVariables
+rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside
+  = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
+       ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)
+       ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside
+       }
+
+rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
+                  -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
+                  -> RnM (a, FreeVars)
+-- rn_hs_sig_wc_type is used for source-language type signatures
+rn_hs_sig_wc_type scoping ctxt
+                  (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
+                  thing_inside
+  = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty
+       ; (tv_rdrs, nwc_rdrs') <- partition_nwcs free_vars
+       ; let nwc_rdrs = nubL nwc_rdrs'
+             bind_free_tvs = case scoping of
+                               AlwaysBind       -> True
+                               BindUnlessForall -> not (isLHsForAllTy hs_ty)
+                               NeverBind        -> False
+       ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars ->
+    do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
+       ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }
+             ib_ty'  = HsIB { hsib_ext = vars
+                            , hsib_body = hs_ty' }
+       ; (res, fvs2) <- thing_inside sig_ty'
+       ; return (res, fvs1 `plusFV` fvs2) } }
+rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs _)) _
+  = panic "rn_hs_sig_wc_type"
+rn_hs_sig_wc_type _ _ (XHsWildCardBndrs _) _
+  = panic "rn_hs_sig_wc_type"
+
+rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
+rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
+  = do { free_vars <- extractFilteredRdrTyVars hs_ty
+       ; (_, nwc_rdrs) <- partition_nwcs free_vars
+       ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty
+       ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }
+       ; return (sig_ty', fvs) }
+rnHsWcType _ (XHsWildCardBndrs _) = panic "rnHsWcType"
+
+rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs
+         -> RnM ([Name], LHsType GhcRn, FreeVars)
+rnWcBody ctxt nwc_rdrs hs_ty
+  = do { nwcs <- mapM newLocalBndrRn nwc_rdrs
+       ; let env = RTKE { rtke_level = TypeLevel
+                        , rtke_what  = RnTypeBody
+                        , rtke_nwcs  = mkNameSet nwcs
+                        , rtke_ctxt  = ctxt }
+       ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $
+                          rn_lty env hs_ty
+       ; return (nwcs, hs_ty', fvs) }
+  where
+    rn_lty env (dL->L loc hs_ty)
+      = setSrcSpan loc $
+        do { (hs_ty', fvs) <- rn_ty env hs_ty
+           ; return (cL loc hs_ty', fvs) }
+
+    rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
+    -- A lot of faff just to allow the extra-constraints wildcard to appear
+    rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body })
+      = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' ->
+        do { (hs_body', fvs) <- rn_lty env hs_body
+           ; return (HsForAllTy { hst_xforall = noExt, hst_bndrs = tvs'
+                                , hst_body = hs_body' }, fvs) }
+
+    rn_ty env (HsQualTy { hst_ctxt = dL->L cx hs_ctxt
+                        , hst_body = hs_ty })
+      | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
+      , (dL->L lx (HsWildCardTy _))  <- ignoreParens hs_ctxt_last
+      = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
+           ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1
+           ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExt)]
+           ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
+           ; return (HsQualTy { hst_xqual = noExt
+                              , hst_ctxt = cL cx hs_ctxt', hst_body = hs_ty' }
+                    , fvs1 `plusFV` fvs2) }
+
+      | otherwise
+      = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt
+           ; (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty
+           ; return (HsQualTy { hst_xqual = noExt
+                              , hst_ctxt = cL cx hs_ctxt'
+                              , hst_body = hs_ty' }
+                    , fvs1 `plusFV` fvs2) }
+
+    rn_ty env hs_ty = rnHsTyKi env hs_ty
+
+    rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })
+
+
+checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()
+-- Rename the extra-constraint spot in a type signature
+--    (blah, _) => type
+-- Check that extra-constraints are allowed at all, and
+-- if so that it's an anonymous wildcard
+checkExtraConstraintWildCard env hs_ctxt
+  = checkWildCard env mb_bad
+  where
+    mb_bad | not (extraConstraintWildCardsAllowed env)
+           = Just base_msg
+             -- Currently, we do not allow wildcards in their full glory in
+             -- standalone deriving declarations. We only allow a single
+             -- extra-constraints wildcard à la:
+             --
+             --   deriving instance _ => Eq (Foo a)
+             --
+             -- i.e., we don't support things like
+             --
+             --   deriving instance (Eq a, _) => Eq (Foo a)
+           | DerivDeclCtx {} <- rtke_ctxt env
+           , not (null hs_ctxt)
+           = Just deriv_decl_msg
+           | otherwise
+           = Nothing
+
+    base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard
+                   <+> text "not allowed"
+
+    deriv_decl_msg
+      = hang base_msg
+           2 (vcat [ text "except as the sole constraint"
+                   , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])
+
+extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
+extraConstraintWildCardsAllowed env
+  = case rtke_ctxt env of
+      TypeSigCtx {}       -> True
+      ExprWithTySigCtx {} -> True
+      DerivDeclCtx {}     -> True
+      _                   -> False
+
+-- | Finds free type and kind variables in a type,
+--     without duplicates, and
+--     without variables that are already in scope in LocalRdrEnv
+--   NB: this includes named wildcards, which look like perfectly
+--       ordinary type variables at this point
+extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups
+extractFilteredRdrTyVars hs_ty
+  = do { rdr_env <- getLocalRdrEnv
+       ; return (filterInScope rdr_env (extractHsTyRdrTyVars hs_ty)) }
+
+-- | Finds free type and kind variables in a type,
+--     with duplicates, but
+--     without variables that are already in scope in LocalRdrEnv
+--   NB: this includes named wildcards, which look like perfectly
+--       ordinary type variables at this point
+extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups
+extractFilteredRdrTyVarsDups hs_ty
+  = do { rdr_env <- getLocalRdrEnv
+       ; return (filterInScope rdr_env (extractHsTyRdrTyVarsDups hs_ty)) }
+
+-- | When the NamedWildCards extension is enabled, partition_nwcs
+-- removes type variables that start with an underscore from the
+-- FreeKiTyVars in the argument and returns them in a separate list.
+-- When the extension is disabled, the function returns the argument
+-- and empty list.  See Note [Renaming named wild cards]
+partition_nwcs :: FreeKiTyVars -> RnM (FreeKiTyVars, [Located RdrName])
+partition_nwcs free_vars@(FKTV { fktv_tys = tys })
+  = do { wildcards_enabled <- fmap (xopt LangExt.NamedWildCards) getDynFlags
+       ; let (nwcs, no_nwcs) | wildcards_enabled = partition is_wildcard tys
+                             | otherwise         = ([], tys)
+             free_vars' = free_vars { fktv_tys = no_nwcs }
+       ; return (free_vars', nwcs) }
+  where
+     is_wildcard :: Located RdrName -> Bool
+     is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))
+
+{- Note [Renaming named wild cards]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Identifiers starting with an underscore are always parsed as type variables.
+It is only here in the renamer that we give the special treatment.
+See Note [The wildcard story for types] in HsTypes.
+
+It's easy!  When we collect the implicitly bound type variables, ready
+to bring them into scope, and NamedWildCards is on, we partition the
+variables into the ones that start with an underscore (the named
+wildcards) and the rest. Then we just add them to the hswc_wcs field
+of the HsWildCardBndrs structure, and we are done.
+
+
+*********************************************************
+*                                                       *
+           HsSigtype (i.e. no wildcards)
+*                                                       *
+****************************************************** -}
+
+rnHsSigType :: HsDocContext -> LHsSigType GhcPs
+            -> RnM (LHsSigType GhcRn, FreeVars)
+-- Used for source-language type signatures
+-- that cannot have wildcards
+rnHsSigType ctx (HsIB { hsib_body = hs_ty })
+  = do { traceRn "rnHsSigType" (ppr hs_ty)
+       ; vars <- extractFilteredRdrTyVarsDups hs_ty
+       ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars ->
+    do { (body', fvs) <- rnLHsType ctx hs_ty
+       ; return ( HsIB { hsib_ext = vars
+                       , hsib_body = body' }
+                , fvs ) } }
+rnHsSigType _ (XHsImplicitBndrs _) = panic "rnHsSigType"
+
+rnImplicitBndrs :: Bool    -- True <=> bring into scope any free type variables
+                           -- E.g.  f :: forall a. a->b
+                           --  we do not want to bring 'b' into scope, hence False
+                           -- But   f :: a -> b
+                           --  we want to bring both 'a' and 'b' into scope
+                -> FreeKiTyVarsWithDups
+                                   -- Free vars of hs_ty (excluding wildcards)
+                                   -- May have duplicates, which is
+                                   -- checked here
+                -> ([Name] -> RnM (a, FreeVars))
+                -> RnM (a, FreeVars)
+rnImplicitBndrs bind_free_tvs
+                fvs_with_dups@(FKTV { fktv_kis = kvs_with_dups
+                                    , fktv_tys = tvs_with_dups })
+                thing_inside
+  = do { let FKTV kvs tvs = rmDupsInRdrTyVars fvs_with_dups
+             real_tvs | bind_free_tvs = tvs
+                      | otherwise     = []
+             -- We always bind over free /kind/ variables.
+             -- Bind free /type/ variables only if there is no
+             -- explicit forall.  E.g.
+             --    f :: Proxy (a :: k) -> b
+             --         Quantify over {k} and {a,b}
+             --    g :: forall a. Proxy (a :: k) -> b
+             --         Quantify over {k} and {}
+             -- Note that we always do the implicit kind-quantification
+             -- but, rather arbitrarily, we switch off the type-quantification
+             -- if there is an explicit forall
+
+       ; traceRn "rnImplicitBndrs" (vcat [ ppr kvs, ppr tvs, ppr real_tvs ])
+
+       ; whenWOptM Opt_WarnImplicitKindVars $
+         unless (bind_free_tvs || null kvs) $
+         addWarnAt (Reason Opt_WarnImplicitKindVars) (getLoc (head kvs)) $
+         implicit_kind_vars_msg kvs
+
+       ; loc <- getSrcSpanM
+          -- NB: kinds before tvs, as mandated by
+          -- Note [Ordering of implicit variables]
+       ; vars <- mapM (newLocalBndrRn . cL loc . unLoc) (kvs ++ real_tvs)
+
+       ; traceRn "checkMixedVars2" $
+           vcat [ text "kvs_with_dups" <+> ppr kvs_with_dups
+                , text "tvs_with_dups" <+> ppr tvs_with_dups ]
+
+       ; bindLocalNamesFV vars $
+         thing_inside vars }
+  where
+    implicit_kind_vars_msg kvs =
+      vcat [ text "An explicit" <+> quotes (text "forall") <+>
+             text "was used, but the following kind variables" <+>
+             text "are not quantified:" <+>
+             hsep (punctuate comma (map (quotes . ppr) kvs))
+           , text "Despite this fact, GHC will introduce them into scope," <+>
+             text "but it will stop doing so in the future."
+           , text "Suggested fix: add" <+>
+             quotes (text "forall" <+> hsep (map ppr kvs) <> char '.') ]
+
+{- ******************************************************
+*                                                       *
+           LHsType and HsType
+*                                                       *
+****************************************************** -}
+
+{-
+rnHsType is here because we call it from loadInstDecl, and I didn't
+want a gratuitous knot.
+
+Note [Context quantification]
+-----------------------------
+Variables in type signatures are implicitly quantified
+when (1) they are in a type signature not beginning
+with "forall" or (2) in any qualified type T => R.
+We are phasing out (2) since it leads to inconsistencies
+(Trac #4426):
+
+data A = A (a -> a)           is an error
+data A = A (Eq a => a -> a)   binds "a"
+data A = A (Eq a => a -> b)   binds "a" and "b"
+data A = A (() => a -> b)     binds "a" and "b"
+f :: forall a. a -> b         is an error
+f :: forall a. () => a -> b   is an error
+f :: forall a. a -> (() => b) binds "a" and "b"
+
+This situation is now considered to be an error. See rnHsTyKi for case
+HsForAllTy Qualified.
+
+Note [QualTy in kinds]
+~~~~~~~~~~~~~~~~~~~~~~
+I was wondering whether QualTy could occur only at TypeLevel.  But no,
+we can have a qualified type in a kind too. Here is an example:
+
+  type family F a where
+    F Bool = Nat
+    F Nat  = Type
+
+  type family G a where
+    G Type = Type -> Type
+    G ()   = Nat
+
+  data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where
+    MkX :: X 'True '()
+
+See that k1 becomes Bool and k2 becomes (), so the equality is
+satisfied. If I write MkX :: X 'True 'False, compilation fails with a
+suitable message:
+
+  MkX :: X 'True '()
+    • Couldn't match kind ‘G Bool’ with ‘Nat’
+      Expected kind: G Bool
+        Actual kind: F Bool
+
+However: in a kind, the constraints in the QualTy must all be
+equalities; or at least, any kinds with a class constraint are
+uninhabited.
+-}
+
+data RnTyKiEnv
+  = RTKE { rtke_ctxt  :: HsDocContext
+         , rtke_level :: TypeOrKind  -- Am I renaming a type or a kind?
+         , rtke_what  :: RnTyKiWhat  -- And within that what am I renaming?
+         , rtke_nwcs  :: NameSet     -- These are the in-scope named wildcards
+    }
+
+data RnTyKiWhat = RnTypeBody
+                | RnTopConstraint   -- Top-level context of HsSigWcTypes
+                | RnConstraint      -- All other constraints
+
+instance Outputable RnTyKiEnv where
+  ppr (RTKE { rtke_level = lev, rtke_what = what
+            , rtke_nwcs = wcs, rtke_ctxt = ctxt })
+    = text "RTKE"
+      <+> braces (sep [ ppr lev, ppr what, ppr wcs
+                      , pprHsDocContext ctxt ])
+
+instance Outputable RnTyKiWhat where
+  ppr RnTypeBody      = text "RnTypeBody"
+  ppr RnTopConstraint = text "RnTopConstraint"
+  ppr RnConstraint    = text "RnConstraint"
+
+mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
+mkTyKiEnv cxt level what
+ = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet
+        , rtke_what = what, rtke_ctxt = cxt }
+
+isRnKindLevel :: RnTyKiEnv -> Bool
+isRnKindLevel (RTKE { rtke_level = KindLevel }) = True
+isRnKindLevel _                                 = False
+
+--------------
+rnLHsType  :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
+rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
+
+rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
+rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
+
+rnHsType  :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
+rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
+
+rnLHsKind  :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars)
+rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
+
+rnHsKind  :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars)
+rnHsKind ctxt kind = rnHsTyKi  (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
+
+-- renaming a type only, not a kind
+rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs
+                -> RnM (LHsTypeArg GhcRn, FreeVars)
+rnLHsTypeArg ctxt (HsValArg ty)
+   = do { (tys_rn, fvs) <- rnLHsType ctxt ty
+        ; return (HsValArg tys_rn, fvs) }
+rnLHsTypeArg ctxt (HsTypeArg l ki)
+   = do { (kis_rn, fvs) <- rnLHsKind ctxt ki
+        ; return (HsTypeArg l kis_rn, fvs) }
+rnLHsTypeArg _ (HsArgPar sp)
+   = return (HsArgPar sp, emptyFVs)
+
+rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs]
+                 -> RnM ([LHsTypeArg GhcRn], FreeVars)
+rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args
+
+--------------
+rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs
+              -> RnM (LHsContext GhcRn, FreeVars)
+rnTyKiContext env (dL->L loc cxt)
+  = do { traceRn "rncontext" (ppr cxt)
+       ; let env' = env { rtke_what = RnConstraint }
+       ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt
+       ; return (cL loc cxt', fvs) }
+
+rnContext :: HsDocContext -> LHsContext GhcPs
+          -> RnM (LHsContext GhcRn, FreeVars)
+rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta
+
+--------------
+rnLHsTyKi  :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
+rnLHsTyKi env (dL->L loc ty)
+  = setSrcSpan loc $
+    do { (ty', fvs) <- rnHsTyKi env ty
+       ; return (cL loc ty', fvs) }
+
+rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
+
+rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body  = tau })
+  = do { checkPolyKinds env ty
+       ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)
+                           Nothing tyvars $ \ tyvars' ->
+    do { (tau',  fvs) <- rnLHsTyKi env tau
+       ; return ( HsForAllTy { hst_xforall = noExt, hst_bndrs = tyvars'
+                             , hst_body =  tau' }
+                , fvs) } }
+
+rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
+  = do { checkPolyKinds env ty  -- See Note [QualTy in kinds]
+       ; (ctxt', fvs1) <- rnTyKiContext env lctxt
+       ; (tau',  fvs2) <- rnLHsTyKi env tau
+       ; return (HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
+                          , hst_body =  tau' }
+                , fvs1 `plusFV` fvs2) }
+
+rnHsTyKi env (HsTyVar _ ip (dL->L loc rdr_name))
+  = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $
+         unlessXOptM LangExt.PolyKinds $ addErr $
+         withHsDocContext (rtke_ctxt env) $
+         vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name)
+              , text "Perhaps you intended to use PolyKinds" ]
+           -- Any type variable at the kind level is illegal without the use
+           -- of PolyKinds (see #14710)
+       ; name <- rnTyVar env rdr_name
+       ; return (HsTyVar noExt ip (cL loc name), unitFV name) }
+
+rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)
+  = setSrcSpan (getLoc l_op) $
+    do  { (l_op', fvs1) <- rnHsTyOp env ty l_op
+        ; fix   <- lookupTyFixityRn l_op'
+        ; (ty1', fvs2) <- rnLHsTyKi env ty1
+        ; (ty2', fvs3) <- rnLHsTyKi env ty2
+        ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 l_op' t2)
+                               (unLoc l_op') fix ty1' ty2'
+        ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
+
+rnHsTyKi env (HsParTy _ ty)
+  = do { (ty', fvs) <- rnLHsTyKi env ty
+       ; return (HsParTy noExt ty', fvs) }
+
+rnHsTyKi env (HsBangTy _ b ty)
+  = do { (ty', fvs) <- rnLHsTyKi env ty
+       ; return (HsBangTy noExt b ty', fvs) }
+
+rnHsTyKi env ty@(HsRecTy _ flds)
+  = do { let ctxt = rtke_ctxt env
+       ; fls          <- get_fields ctxt
+       ; (flds', fvs) <- rnConDeclFields ctxt fls flds
+       ; return (HsRecTy noExt flds', fvs) }
+  where
+    get_fields (ConDeclCtx names)
+      = concatMapM (lookupConstructorFields . unLoc) names
+    get_fields _
+      = do { addErr (hang (text "Record syntax is illegal here:")
+                                   2 (ppr ty))
+           ; return [] }
+
+rnHsTyKi env (HsFunTy _ ty1 ty2)
+  = do { (ty1', fvs1) <- rnLHsTyKi env ty1
+        -- Might find a for-all as the arg of a function type
+       ; (ty2', fvs2) <- rnLHsTyKi env ty2
+        -- Or as the result.  This happens when reading Prelude.hi
+        -- when we find return :: forall m. Monad m -> forall a. a -> m a
+
+        -- Check for fixity rearrangements
+       ; res_ty <- mkHsOpTyRn (HsFunTy noExt) funTyConName funTyFixity ty1' ty2'
+       ; return (res_ty, fvs1 `plusFV` fvs2) }
+
+rnHsTyKi env listTy@(HsListTy _ ty)
+  = do { data_kinds <- xoptM LangExt.DataKinds
+       ; when (not data_kinds && isRnKindLevel env)
+              (addErr (dataKindsErr env listTy))
+       ; (ty', fvs) <- rnLHsTyKi env ty
+       ; return (HsListTy noExt ty', fvs) }
+
+rnHsTyKi env t@(HsKindSig _ ty k)
+  = do { checkPolyKinds env t
+       ; kind_sigs_ok <- xoptM LangExt.KindSignatures
+       ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)
+       ; (ty', fvs1) <- rnLHsTyKi env ty
+       ; (k', fvs2)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k
+       ; return (HsKindSig noExt ty' k', fvs1 `plusFV` fvs2) }
+
+-- Unboxed tuples are allowed to have poly-typed arguments.  These
+-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
+rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys)
+  = do { data_kinds <- xoptM LangExt.DataKinds
+       ; when (not data_kinds && isRnKindLevel env)
+              (addErr (dataKindsErr env tupleTy))
+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
+       ; return (HsTupleTy noExt tup_con tys', fvs) }
+
+rnHsTyKi env sumTy@(HsSumTy _ tys)
+  = do { data_kinds <- xoptM LangExt.DataKinds
+       ; when (not data_kinds && isRnKindLevel env)
+              (addErr (dataKindsErr env sumTy))
+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
+       ; return (HsSumTy noExt tys', fvs) }
+
+-- Ensure that a type-level integer is nonnegative (#8306, #8412)
+rnHsTyKi env tyLit@(HsTyLit _ t)
+  = do { data_kinds <- xoptM LangExt.DataKinds
+       ; unless data_kinds (addErr (dataKindsErr env tyLit))
+       ; when (negLit t) (addErr negLitErr)
+       ; checkPolyKinds env tyLit
+       ; return (HsTyLit noExt t, emptyFVs) }
+  where
+    negLit (HsStrTy _ _) = False
+    negLit (HsNumTy _ i) = i < 0
+    negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit
+
+rnHsTyKi env (HsAppTy _ ty1 ty2)
+  = do { (ty1', fvs1) <- rnLHsTyKi env ty1
+       ; (ty2', fvs2) <- rnLHsTyKi env ty2
+       ; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) }
+
+rnHsTyKi env (HsAppKindTy l ty k)
+  = do { kind_app <- xoptM LangExt.TypeApplications
+       ; unless kind_app (addErr (typeAppErr "kind" k))
+       ; (ty', fvs1) <- rnLHsTyKi env ty
+       ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k
+       ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) }
+
+rnHsTyKi env t@(HsIParamTy _ n ty)
+  = do { notInKinds env t
+       ; (ty', fvs) <- rnLHsTyKi env ty
+       ; return (HsIParamTy noExt n ty', fvs) }
+
+rnHsTyKi _ (HsStarTy _ isUni)
+  = return (HsStarTy noExt isUni, emptyFVs)
+
+rnHsTyKi _ (HsSpliceTy _ sp)
+  = rnSpliceType sp
+
+rnHsTyKi env (HsDocTy _ ty haddock_doc)
+  = do { (ty', fvs) <- rnLHsTyKi env ty
+       ; haddock_doc' <- rnLHsDoc haddock_doc
+       ; return (HsDocTy noExt ty' haddock_doc', fvs) }
+
+rnHsTyKi _ (XHsType (NHsCoreTy ty))
+  = return (XHsType (NHsCoreTy ty), emptyFVs)
+    -- The emptyFVs probably isn't quite right
+    -- but I don't think it matters
+
+rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
+  = do { checkPolyKinds env ty
+       ; data_kinds <- xoptM LangExt.DataKinds
+       ; unless data_kinds (addErr (dataKindsErr env ty))
+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
+       ; return (HsExplicitListTy noExt ip tys', fvs) }
+
+rnHsTyKi env ty@(HsExplicitTupleTy _ tys)
+  = do { checkPolyKinds env ty
+       ; data_kinds <- xoptM LangExt.DataKinds
+       ; unless data_kinds (addErr (dataKindsErr env ty))
+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
+       ; return (HsExplicitTupleTy noExt tys', fvs) }
+
+rnHsTyKi env (HsWildCardTy _)
+  = do { checkAnonWildCard env
+       ; return (HsWildCardTy noExt, emptyFVs) }
+
+--------------
+rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
+rnTyVar env rdr_name
+  = do { name <- lookupTypeOccRn rdr_name
+       ; checkNamedWildCard env name
+       ; return name }
+
+rnLTyVar :: Located RdrName -> RnM (Located Name)
+-- Called externally; does not deal with wildards
+rnLTyVar (dL->L loc rdr_name)
+  = do { tyvar <- lookupTypeOccRn rdr_name
+       ; return (cL loc tyvar) }
+
+--------------
+rnHsTyOp :: Outputable a
+         => RnTyKiEnv -> a -> Located RdrName
+         -> RnM (Located Name, FreeVars)
+rnHsTyOp env overall_ty (dL->L loc op)
+  = do { ops_ok <- xoptM LangExt.TypeOperators
+       ; op' <- rnTyVar env op
+       ; unless (ops_ok || op' `hasKey` eqTyConKey) $
+           addErr (opTyErr op overall_ty)
+       ; let l_op' = cL loc op'
+       ; return (l_op', unitFV op') }
+
+--------------
+notAllowed :: SDoc -> SDoc
+notAllowed doc
+  = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed")
+
+checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()
+checkWildCard env (Just doc)
+  = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]
+checkWildCard _ Nothing
+  = return ()
+
+checkAnonWildCard :: RnTyKiEnv -> RnM ()
+-- Report an error if an anonymous wildcard is illegal here
+checkAnonWildCard env
+  = checkWildCard env mb_bad
+  where
+    mb_bad :: Maybe SDoc
+    mb_bad | not (wildCardsAllowed env)
+           = Just (notAllowed pprAnonWildCard)
+           | otherwise
+           = case rtke_what env of
+               RnTypeBody      -> Nothing
+               RnConstraint    -> Just constraint_msg
+               RnTopConstraint -> Just constraint_msg
+
+    constraint_msg = hang
+                         (notAllowed pprAnonWildCard <+> text "in a constraint")
+                        2 hint_msg
+    hint_msg = vcat [ text "except as the last top-level constraint of a type signature"
+                    , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]
+
+checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()
+-- Report an error if a named wildcard is illegal here
+checkNamedWildCard env name
+  = checkWildCard env mb_bad
+  where
+    mb_bad | not (name `elemNameSet` rtke_nwcs env)
+           = Nothing  -- Not a wildcard
+           | not (wildCardsAllowed env)
+           = Just (notAllowed (ppr name))
+           | otherwise
+           = case rtke_what env of
+               RnTypeBody      -> Nothing   -- Allowed
+               RnTopConstraint -> Nothing   -- Allowed
+               RnConstraint    -> Just constraint_msg
+    constraint_msg = notAllowed (ppr name) <+> text "in a constraint"
+
+wildCardsAllowed :: RnTyKiEnv -> Bool
+-- ^ In what contexts are wildcards permitted
+wildCardsAllowed env
+   = case rtke_ctxt env of
+       TypeSigCtx {}       -> True
+       TypBrCtx {}         -> True   -- Template Haskell quoted type
+       SpliceTypeCtx {}    -> True   -- Result of a Template Haskell splice
+       ExprWithTySigCtx {} -> True
+       PatCtx {}           -> True
+       RuleCtx {}          -> True
+       FamPatCtx {}        -> True   -- Not named wildcards though
+       GHCiCtx {}          -> True
+       HsTypeCtx {}        -> True
+       _                   -> False
+
+
+
+---------------
+-- | Ensures either that we're in a type or that -XPolyKinds is set
+checkPolyKinds :: Outputable ty
+                => RnTyKiEnv
+                -> ty      -- ^ type
+                -> RnM ()
+checkPolyKinds env ty
+  | isRnKindLevel env
+  = do { polykinds <- xoptM LangExt.PolyKinds
+       ; unless polykinds $
+         addErr (text "Illegal kind:" <+> ppr ty $$
+                 text "Did you mean to enable PolyKinds?") }
+checkPolyKinds _ _ = return ()
+
+notInKinds :: Outputable ty
+           => RnTyKiEnv
+           -> ty
+           -> RnM ()
+notInKinds env ty
+  | isRnKindLevel env
+  = addErr (text "Illegal kind:" <+> ppr ty)
+notInKinds _ _ = return ()
+
+{- *****************************************************
+*                                                      *
+          Binding type variables
+*                                                      *
+***************************************************** -}
+
+bindSigTyVarsFV :: [Name]
+                -> RnM (a, FreeVars)
+                -> RnM (a, FreeVars)
+-- Used just before renaming the defn of a function
+-- with a separate type signature, to bring its tyvars into scope
+-- With no -XScopedTypeVariables, this is a no-op
+bindSigTyVarsFV tvs thing_inside
+  = do  { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables
+        ; if not scoped_tyvars then
+                thing_inside
+          else
+                bindLocalNamesFV tvs thing_inside }
+
+-- | Simply bring a bunch of RdrNames into scope. No checking for
+-- validity, at all. The binding location is taken from the location
+-- on each name.
+bindLRdrNames :: [Located RdrName]
+              -> ([Name] -> RnM (a, FreeVars))
+              -> RnM (a, FreeVars)
+bindLRdrNames rdrs thing_inside
+  = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs
+       ; bindLocalNamesFV var_names $
+         thing_inside var_names }
+
+---------------
+bindHsQTyVars :: forall a b.
+                 HsDocContext
+              -> Maybe SDoc         -- Just d => check for unused tvs
+                                    --   d is a phrase like "in the type ..."
+              -> Maybe a            -- Just _  => an associated type decl
+              -> [Located RdrName]  -- Kind variables from scope, no dups
+              -> (LHsQTyVars GhcPs)
+              -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
+                  -- The Bool is True <=> all kind variables used in the
+                  -- kind signature are bound on the left.  Reason:
+                  -- the last clause of Note [CUSKs: Complete user-supplied
+                  -- kind signatures] in HsDecls
+              -> RnM (b, FreeVars)
+
+-- See Note [bindHsQTyVars examples]
+-- (a) Bring kind variables into scope
+--     both (i)  passed in body_kv_occs
+--     and  (ii) mentioned in the kinds of hsq_bndrs
+-- (b) Bring type variables into scope
+--
+bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
+  = do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs
+             bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs
+
+       ; let -- See Note [bindHsQTyVars examples] for what
+             -- all these various things are doing
+             bndrs, kv_occs, implicit_kvs :: [Located RdrName]
+             bndrs        = map hsLTyVarLocName hs_tv_bndrs
+             kv_occs      = nubL (bndr_kv_occs ++ body_kv_occs)
+                                 -- Make sure to list the binder kvs before the
+                                 -- body kvs, as mandated by
+                                 -- Note [Ordering of implicit variables]
+             implicit_kvs = filter_occs bndrs kv_occs
+             -- dep_bndrs is the subset of bndrs that are dependent
+             --   i.e. appear in bndr/body_kv_occs
+             -- Can't use implicit_kvs because we've deleted bndrs from that!
+             dep_bndrs = filter (`elemRdr` kv_occs) bndrs
+             del       = deleteBys eqLocated
+             all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs)
+
+       ; traceRn "checkMixedVars3" $
+           vcat [ text "kv_occs" <+> ppr kv_occs
+                , text "bndrs"   <+> ppr hs_tv_bndrs
+                , text "bndr_kv_occs"   <+> ppr bndr_kv_occs
+                , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs)
+                ]
+
+       ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs
+
+       ; bindLocalNamesFV implicit_kv_nms                     $
+         bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs ->
+    do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)
+       ; dep_bndr_nms <- mapM (lookupLocalOccRn . unLoc) dep_bndrs
+       ; thing_inside (HsQTvs { hsq_ext = HsQTvsRn
+                                   { hsq_implicit  = implicit_kv_nms
+                                   , hsq_dependent = mkNameSet dep_bndr_nms }
+                              , hsq_explicit  = rn_bndrs })
+                      all_bound_on_lhs } }
+
+  where
+    filter_occs :: [Located RdrName]   -- Bound here
+                -> [Located RdrName]   -- Potential implicit binders
+                -> [Located RdrName]   -- Final implicit binders
+    -- Filter out any potential implicit binders that are either
+    -- already in scope, or are explicitly bound in the same HsQTyVars
+    filter_occs bndrs occs
+      = filterOut is_in_scope occs
+      where
+        is_in_scope locc = locc `elemRdr` bndrs
+
+{- Note [bindHsQTyVars examples]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+   data T k (a::k1) (b::k) :: k2 -> k1 -> *
+
+Then:
+  hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables
+  bndrs       = [k,a,b]
+
+  bndr_kv_occs = [k,k1], kind variables free in kind signatures
+                         of hs_tv_bndrs
+
+  body_kv_occs = [k2,k1], kind variables free in the
+                          result kind signature
+
+  implicit_kvs = [k1,k2], kind variables free in kind signatures
+                          of hs_tv_bndrs, and not bound by bndrs
+
+* We want to quantify add implicit bindings for implicit_kvs
+
+* The "dependent" bndrs (hsq_dependent) are the subset of
+  bndrs that are free in bndr_kv_occs or body_kv_occs
+
+* If implicit_body_kvs is non-empty, then there is a kind variable
+  mentioned in the kind signature that is not bound "on the left".
+  That's one of the rules for a CUSK, so we pass that info on
+  as the second argument to thing_inside.
+
+* Order is not important in these lists.  All we are doing is
+  bring Names into scope.
+
+Finally, you may wonder why filter_occs removes in-scope variables
+from bndr/body_kv_occs.  How can anything be in scope?  Answer:
+HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax
+ConDecls
+   data T a = forall (b::k). MkT a b
+The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire
+ConDecl.  Hence the local RdrEnv may be non-empty and we must filter
+out 'a' from the free vars.  (Mind you, in this situation all the
+implicit kind variables are bound at the data type level, so there
+are none to bind in the ConDecl, so there are no implicitly bound
+variables at all.
+
+Note [Kind variable scoping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+  data T (a :: k) k = ...
+we report "k is out of scope" for (a::k).  Reason: k is not brought
+into scope until the explicit k-binding that follows.  It would be
+terribly confusing to bring into scope an /implicit/ k for a's kind
+and a distinct, shadowing explicit k that follows, something like
+  data T {k1} (a :: k1) k = ...
+
+So the rule is:
+
+   the implicit binders never include any
+   of the explicit binders in the group
+
+Note that in the denerate case
+  data T (a :: a) = blah
+we get a complaint the second 'a' is not in scope.
+
+That applies to foralls too: e.g.
+   forall (a :: k) k . blah
+
+But if the foralls are split, we treat the two groups separately:
+   forall (a :: k). forall k. blah
+Here we bring into scope an implicit k, which is later shadowed
+by the explicit k.
+
+In implementation terms
+
+* In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete
+  the binders {a,k}, and so end with no implicit binders.  Then we
+  rename the binders left-to-right, and hence see that 'k' is out of
+  scope in the kind of 'a'.
+
+* Similarly in extract_hs_tv_bndrs
+
+Note [Variables used as both types and kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We bind the type variables tvs, and kvs is the set of free variables of the
+kinds in the scope of the binding. Here is one typical example:
+
+   forall a b. a -> (b::k) -> (c::a)
+
+Here, tvs will be {a,b}, and kvs {k,a}.
+
+We must make sure that kvs includes all of variables in the kinds of type
+variable bindings. For instance:
+
+   forall k (a :: k). Proxy a
+
+If we only look in the body of the `forall` type, we will mistakenly conclude
+that kvs is {}. But in fact, the type variable `k` is also used as a kind
+variable in (a :: k), later in the binding. (This mistake lead to #14710.)
+So tvs is {k,a} and kvs is {k}.
+
+NB: we do this only at the binding site of 'tvs'.
+-}
+
+bindLHsTyVarBndrs :: HsDocContext
+                  -> Maybe SDoc            -- Just d => check for unused tvs
+                                           --   d is a phrase like "in the type ..."
+                  -> Maybe a               -- Just _  => an associated type decl
+                  -> [LHsTyVarBndr GhcPs]  -- User-written tyvars
+                  -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
+                  -> RnM (b, FreeVars)
+bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside
+  = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
+       ; checkDupRdrNames tv_names_w_loc
+       ; go tv_bndrs thing_inside }
+  where
+    tv_names_w_loc = map hsLTyVarLocName tv_bndrs
+
+    go []     thing_inside = thing_inside []
+    go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' ->
+                             do { (res, fvs) <- go bs $ \ bs' ->
+                                                thing_inside (b' : bs')
+                                ; warn_unused b' fvs
+                                ; return (res, fvs) }
+
+    warn_unused tv_bndr fvs = case mb_in_doc of
+      Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs
+      Nothing     -> return ()
+
+bindLHsTyVarBndr :: HsDocContext
+                 -> Maybe a   -- associated class
+                 -> LHsTyVarBndr GhcPs
+                 -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))
+                 -> RnM (b, FreeVars)
+bindLHsTyVarBndr _doc mb_assoc (dL->L loc
+                                 (UserTyVar x
+                                    lrdr@(dL->L lv _))) thing_inside
+  = do { nm <- newTyVarNameRn mb_assoc lrdr
+       ; bindLocalNamesFV [nm] $
+         thing_inside (cL loc (UserTyVar x (cL lv nm))) }
+
+bindLHsTyVarBndr doc mb_assoc (dL->L loc (KindedTyVar x lrdr@(dL->L lv _) kind))
+                 thing_inside
+  = do { sig_ok <- xoptM LangExt.KindSignatures
+           ; unless sig_ok (badKindSigErr doc kind)
+           ; (kind', fvs1) <- rnLHsKind doc kind
+           ; tv_nm  <- newTyVarNameRn mb_assoc lrdr
+           ; (b, fvs2) <- bindLocalNamesFV [tv_nm]
+               $ thing_inside (cL loc (KindedTyVar x (cL lv tv_nm) kind'))
+           ; return (b, fvs1 `plusFV` fvs2) }
+
+bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr{})) _ = panic "bindLHsTyVarBndr"
+bindLHsTyVarBndr _ _ _ _ = panic "bindLHsTyVarBndr: Impossible Match"
+                             -- due to #15884
+
+newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
+newTyVarNameRn mb_assoc (dL->L loc rdr)
+  = do { rdr_env <- getLocalRdrEnv
+       ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of
+           (Just _, Just n) -> return n
+              -- Use the same Name as the parent class decl
+
+           _                -> newLocalBndrRn (cL loc rdr) }
+{-
+*********************************************************
+*                                                       *
+        ConDeclField
+*                                                       *
+*********************************************************
+
+When renaming a ConDeclField, we have to find the FieldLabel
+associated with each field.  But we already have all the FieldLabels
+available (since they were brought into scope by
+RnNames.getLocalNonValBinders), so we just take the list as an
+argument, build a map and look them up.
+-}
+
+rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs]
+                -> RnM ([LConDeclField GhcRn], FreeVars)
+-- Also called from RnSource
+-- No wildcards can appear in record fields
+rnConDeclFields ctxt fls fields
+   = mapFvRn (rnField fl_env env) fields
+  where
+    env    = mkTyKiEnv ctxt TypeLevel RnTypeBody
+    fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
+
+rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
+        -> RnM (LConDeclField GhcRn, FreeVars)
+rnField fl_env env (dL->L l (ConDeclField _ names ty haddock_doc))
+  = do { let new_names = map (fmap lookupField) names
+       ; (new_ty, fvs) <- rnLHsTyKi env ty
+       ; new_haddock_doc <- rnMbLHsDoc haddock_doc
+       ; return (cL l (ConDeclField noExt new_names new_ty new_haddock_doc)
+                , fvs) }
+  where
+    lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
+    lookupField (FieldOcc _ (dL->L lr rdr)) =
+        FieldOcc (flSelector fl) (cL lr rdr)
+      where
+        lbl = occNameFS $ rdrNameOcc rdr
+        fl  = expectJust "rnField" $ lookupFsEnv fl_env lbl
+    lookupField (XFieldOcc{}) = panic "rnField"
+rnField _ _ (dL->L _ (XConDeclField _)) = panic "rnField"
+rnField _ _ _ = panic "rnField: Impossible Match"
+                             -- due to #15884
+
+{-
+************************************************************************
+*                                                                      *
+        Fixities and precedence parsing
+*                                                                      *
+************************************************************************
+
+@mkOpAppRn@ deals with operator fixities.  The argument expressions
+are assumed to be already correctly arranged.  It needs the fixities
+recorded in the OpApp nodes, because fixity info applies to the things
+the programmer actually wrote, so you can't find it out from the Name.
+
+Furthermore, the second argument is guaranteed not to be another
+operator application.  Why? Because the parser parses all
+operator applications left-associatively, EXCEPT negation, which
+we need to handle specially.
+Infix types are read in a *right-associative* way, so that
+        a `op` b `op` c
+is always read in as
+        a `op` (b `op` c)
+
+mkHsOpTyRn rearranges where necessary.  The two arguments
+have already been renamed and rearranged.  It's made rather tiresome
+by the presence of ->, which is a separate syntactic construct.
+-}
+
+---------------
+-- Building (ty1 `op1` (ty21 `op2` ty22))
+mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
+           -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
+           -> RnM (HsType GhcRn)
+
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsOpTy noExt ty21 op2 ty22))
+  = do  { fix2 <- lookupTyFixityRn op2
+        ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
+                      (\t1 t2 -> HsOpTy noExt t1 op2 t2)
+                      (unLoc op2) fix2 ty21 ty22 loc2 }
+
+mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsFunTy _ ty21 ty22))
+  = mk_hs_op_ty mk1 pp_op1 fix1 ty1
+                (HsFunTy noExt) funTyConName funTyFixity ty21 ty22 loc2
+
+mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment
+  = return (mk1 ty1 ty2)
+
+---------------
+mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
+            -> Name -> Fixity -> LHsType GhcRn
+            -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
+            -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan
+            -> RnM (HsType GhcRn)
+mk_hs_op_ty mk1 op1 fix1 ty1
+            mk2 op2 fix2 ty21 ty22 loc2
+  | nofix_error     = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2)
+                         ; return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) }
+  | associate_right = return (mk1 ty1 (cL loc2 (mk2 ty21 ty22)))
+  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
+                           new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
+                         ; return (mk2 (noLoc new_ty) ty22) }
+  where
+    (nofix_error, associate_right) = compareFixity fix1 fix2
+
+
+---------------------------
+mkOpAppRn :: LHsExpr GhcRn             -- Left operand; already rearranged
+          -> LHsExpr GhcRn -> Fixity   -- Operator and fixity
+          -> LHsExpr GhcRn             -- Right operand (not an OpApp, but might
+                                       -- be a NegApp)
+          -> RnM (HsExpr GhcRn)
+
+-- (e11 `op1` e12) `op2` e2
+mkOpAppRn e1@(dL->L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2
+  | nofix_error
+  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
+       return (OpApp fix2 e1 op2 e2)
+
+  | associate_right = do
+    new_e <- mkOpAppRn e12 op2 fix2 e2
+    return (OpApp fix1 e11 op1 (cL loc' new_e))
+  where
+    loc'= combineLocs e12 e2
+    (nofix_error, associate_right) = compareFixity fix1 fix2
+
+---------------------------
+--      (- neg_arg) `op` e2
+mkOpAppRn e1@(dL->L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2
+  | nofix_error
+  = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)
+       return (OpApp fix2 e1 op2 e2)
+
+  | associate_right
+  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
+       return (NegApp noExt (cL loc' new_e) neg_name)
+  where
+    loc' = combineLocs neg_arg e2
+    (nofix_error, associate_right) = compareFixity negateFixity fix2
+
+---------------------------
+--      e1 `op` - neg_arg
+mkOpAppRn e1 op1 fix1 e2@(dL->L _ (NegApp {})) -- NegApp can occur on the right
+  | not associate_right                        -- We *want* right association
+  = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)
+       return (OpApp fix1 e1 op1 e2)
+  where
+    (_, associate_right) = compareFixity fix1 negateFixity
+
+---------------------------
+--      Default case
+mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
+  = ASSERT2( right_op_ok fix (unLoc e2),
+             ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
+    )
+    return (OpApp fix e1 op e2)
+
+----------------------------
+
+-- | Name of an operator in an operator application or section
+data OpName = NormalOp Name         -- ^ A normal identifier
+            | NegateOp              -- ^ Prefix negation
+            | UnboundOp UnboundVar  -- ^ An unbound indentifier
+            | RecFldOp (AmbiguousFieldOcc GhcRn)
+              -- ^ A (possibly ambiguous) record field occurrence
+
+instance Outputable OpName where
+  ppr (NormalOp n)   = ppr n
+  ppr NegateOp       = ppr negateName
+  ppr (UnboundOp uv) = ppr uv
+  ppr (RecFldOp fld) = ppr fld
+
+get_op :: LHsExpr GhcRn -> OpName
+-- An unbound name could be either HsVar or HsUnboundVar
+-- See RnExpr.rnUnboundVar
+get_op (dL->L _ (HsVar _ n))         = NormalOp (unLoc n)
+get_op (dL->L _ (HsUnboundVar _ uv)) = UnboundOp uv
+get_op (dL->L _ (HsRecFld _ fld))    = RecFldOp fld
+get_op other                         = pprPanic "get_op" (ppr other)
+
+-- Parser left-associates everything, but
+-- derived instances may have correctly-associated things to
+-- in the right operand.  So we just check that the right operand is OK
+right_op_ok :: Fixity -> HsExpr GhcRn -> Bool
+right_op_ok fix1 (OpApp fix2 _ _ _)
+  = not error_please && associate_right
+  where
+    (error_please, associate_right) = compareFixity fix1 fix2
+right_op_ok _ _
+  = True
+
+-- Parser initially makes negation bind more tightly than any other operator
+-- And "deriving" code should respect this (use HsPar if not)
+mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id)
+           -> RnM (HsExpr (GhcPass id))
+mkNegAppRn neg_arg neg_name
+  = ASSERT( not_op_app (unLoc neg_arg) )
+    return (NegApp noExt neg_arg neg_name)
+
+not_op_app :: HsExpr id -> Bool
+not_op_app (OpApp {}) = False
+not_op_app _          = True
+
+---------------------------
+mkOpFormRn :: LHsCmdTop GhcRn            -- Left operand; already rearranged
+          -> LHsExpr GhcRn -> Fixity     -- Operator and fixity
+          -> LHsCmdTop GhcRn             -- Right operand (not an infix)
+          -> RnM (HsCmd GhcRn)
+
+-- (e11 `op1` e12) `op2` e2
+mkOpFormRn a1@(dL->L loc
+                    (HsCmdTop _
+                     (dL->L _ (HsCmdArrForm x op1 f (Just fix1)
+                        [a11,a12]))))
+        op2 fix2 a2
+  | nofix_error
+  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
+       return (HsCmdArrForm x op2 f (Just fix2) [a1, a2])
+
+  | associate_right
+  = do new_c <- mkOpFormRn a12 op2 fix2 a2
+       return (HsCmdArrForm noExt op1 f (Just fix1)
+               [a11, cL loc (HsCmdTop [] (cL loc new_c))])
+        -- TODO: locs are wrong
+  where
+    (nofix_error, associate_right) = compareFixity fix1 fix2
+
+--      Default case
+mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
+  = return (HsCmdArrForm noExt op Infix (Just fix) [arg1, arg2])
+
+
+--------------------------------------
+mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn
+             -> RnM (Pat GhcRn)
+
+mkConOpPatRn op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2
+  = do  { fix1 <- lookupFixityRn (unLoc op1)
+        ; let (nofix_error, associate_right) = compareFixity fix1 fix2
+
+        ; if nofix_error then do
+                { precParseErr (NormalOp (unLoc op1),fix1)
+                               (NormalOp (unLoc op2),fix2)
+                ; return (ConPatIn op2 (InfixCon p1 p2)) }
+
+          else if associate_right then do
+                { new_p <- mkConOpPatRn op2 fix2 p12 p2
+                ; return (ConPatIn op1 (InfixCon p11 (cL loc new_p))) }
+                -- XXX loc right?
+          else return (ConPatIn op2 (InfixCon p1 p2)) }
+
+mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
+  = ASSERT( not_op_pat (unLoc p2) )
+    return (ConPatIn op (InfixCon p1 p2))
+
+not_op_pat :: Pat GhcRn -> Bool
+not_op_pat (ConPatIn _ (InfixCon _ _)) = False
+not_op_pat _                           = True
+
+--------------------------------------
+checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()
+  -- Check precedence of a function binding written infix
+  --   eg  a `op` b `C` c = ...
+  -- See comments with rnExpr (OpApp ...) about "deriving"
+
+checkPrecMatch op (MG { mg_alts = (dL->L _ ms) })
+  = mapM_ check ms
+  where
+    check (dL->L _ (Match { m_pats = (dL->L l1 p1)
+                                   : (dL->L l2 p2)
+                                   : _ }))
+      = setSrcSpan (combineSrcSpans l1 l2) $
+        do checkPrec op p1 False
+           checkPrec op p2 True
+
+    check _ = return ()
+        -- This can happen.  Consider
+        --      a `op` True = ...
+        --      op          = ...
+        -- The infix flag comes from the first binding of the group
+        -- but the second eqn has no args (an error, but not discovered
+        -- until the type checker).  So we don't want to crash on the
+        -- second eqn.
+checkPrecMatch _ (XMatchGroup {}) = panic "checkPrecMatch"
+
+checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
+checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
+    op_fix@(Fixity _ op_prec  op_dir) <- lookupFixityRn op
+    op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
+    let
+        inf_ok = op1_prec > op_prec ||
+                 (op1_prec == op_prec &&
+                  (op1_dir == InfixR && op_dir == InfixR && right ||
+                   op1_dir == InfixL && op_dir == InfixL && not right))
+
+        info  = (NormalOp op,          op_fix)
+        info1 = (NormalOp (unLoc op1), op1_fix)
+        (infol, infor) = if right then (info, info1) else (info1, info)
+    unless inf_ok (precParseErr infol infor)
+
+checkPrec _ _ _
+  = return ()
+
+-- Check precedence of (arg op) or (op arg) respectively
+-- If arg is itself an operator application, then either
+--   (a) its precedence must be higher than that of op
+--   (b) its precedency & associativity must be the same as that of op
+checkSectionPrec :: FixityDirection -> HsExpr GhcPs
+        -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM ()
+checkSectionPrec direction section op arg
+  = case unLoc arg of
+        OpApp fix _ op' _ -> go_for_it (get_op op') fix
+        NegApp _ _ _      -> go_for_it NegateOp     negateFixity
+        _                 -> return ()
+  where
+    op_name = get_op op
+    go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do
+          op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name
+          unless (op_prec < arg_prec
+                  || (op_prec == arg_prec && direction == assoc))
+                 (sectionPrecErr (get_op op, op_fix)
+                                 (arg_op, arg_fix) section)
+
+-- | Look up the fixity for an operator name.  Be careful to use
+-- 'lookupFieldFixityRn' for (possibly ambiguous) record fields
+-- (see Trac #13132).
+lookupFixityOp :: OpName -> RnM Fixity
+lookupFixityOp (NormalOp n)  = lookupFixityRn n
+lookupFixityOp NegateOp      = lookupFixityRn negateName
+lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (unboundVarOcc u))
+lookupFixityOp (RecFldOp f)  = lookupFieldFixityRn f
+
+
+-- Precedence-related error messages
+
+precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()
+precParseErr op1@(n1,_) op2@(n2,_)
+  | is_unbound n1 || is_unbound n2
+  = return ()     -- Avoid error cascade
+  | otherwise
+  = addErr $ hang (text "Precedence parsing error")
+      4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"),
+               ppr_opfix op2,
+               text "in the same infix expression"])
+
+sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM ()
+sectionPrecErr op@(n1,_) arg_op@(n2,_) section
+  | is_unbound n1 || is_unbound n2
+  = return ()     -- Avoid error cascade
+  | otherwise
+  = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),
+         nest 4 (sep [text "must have lower precedence than that of the operand,",
+                      nest 2 (text "namely" <+> ppr_opfix arg_op)]),
+         nest 4 (text "in the section:" <+> quotes (ppr section))]
+
+is_unbound :: OpName -> Bool
+is_unbound (NormalOp n) = isUnboundName n
+is_unbound UnboundOp{}  = True
+is_unbound _            = False
+
+ppr_opfix :: (OpName, Fixity) -> SDoc
+ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
+   where
+     pp_op | NegateOp <- op = text "prefix `-'"
+           | otherwise      = quotes (ppr op)
+
+
+{- *****************************************************
+*                                                      *
+                 Errors
+*                                                      *
+***************************************************** -}
+
+unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc
+unexpectedTypeSigErr ty
+  = hang (text "Illegal type signature:" <+> quotes (ppr ty))
+       2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")
+
+badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()
+badKindSigErr doc (dL->L loc ty)
+  = setSrcSpan loc $ addErr $
+    withHsDocContext doc $
+    hang (text "Illegal kind signature:" <+> quotes (ppr ty))
+       2 (text "Perhaps you intended to use KindSignatures")
+
+dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc
+dataKindsErr env thing
+  = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))
+       2 (text "Perhaps you intended to use DataKinds")
+  where
+    pp_what | isRnKindLevel env = text "kind"
+            | otherwise          = text "type"
+
+inTypeDoc :: HsType GhcPs -> SDoc
+inTypeDoc ty = text "In the type" <+> quotes (ppr ty)
+
+warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM ()
+warnUnusedForAll in_doc (dL->L loc tv) used_names
+  = whenWOptM Opt_WarnUnusedForalls $
+    unless (hsTyVarName tv `elemNameSet` used_names) $
+    addWarnAt (Reason Opt_WarnUnusedForalls) loc $
+    vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)
+         , in_doc ]
+
+opTyErr :: Outputable a => RdrName -> a -> SDoc
+opTyErr op overall_ty
+  = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))
+         2 (text "Use TypeOperators to allow operators in types")
+
+{-
+************************************************************************
+*                                                                      *
+      Finding the free type variables of a (HsType RdrName)
+*                                                                      *
+************************************************************************
+
+
+Note [Kind and type-variable binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a type signature we may implicitly bind type variable and, more
+recently, kind variables.  For example:
+  *   f :: a -> a
+      f = ...
+    Here we need to find the free type variables of (a -> a),
+    so that we know what to quantify
+
+  *   class C (a :: k) where ...
+    This binds 'k' in ..., as well as 'a'
+
+  *   f (x :: a -> [a]) = ....
+    Here we bind 'a' in ....
+
+  *   f (x :: T a -> T (b :: k)) = ...
+    Here we bind both 'a' and the kind variable 'k'
+
+  *   type instance F (T (a :: Maybe k)) = ...a...k...
+    Here we want to constrain the kind of 'a', and bind 'k'.
+
+In general we want to walk over a type, and find
+  * Its free type variables
+  * The free kind variables of any kind signatures in the type
+
+Hence we return a pair (kind-vars, type vars)
+(See Note [HsBSig binder lists] in HsTypes.)
+Moreover, we preserve the left-to-right order of the first occurrence of each
+variable, while preserving dependency order.
+(See Note [Ordering of implicit variables].)
+
+Most clients of this code just want to know the kind/type vars, without
+duplicates. The function rmDupsInRdrTyVars removes duplicates. That function
+also makes sure that no variable is reported as both a kind var and
+a type var, preferring kind vars. Why kind vars? Consider this:
+
+ foo :: forall (a :: k). Proxy k -> Proxy a -> ...
+
+Should that be accepted?
+
+Normally, if a type signature has an explicit forall, it must list *all*
+tyvars mentioned in the type. But there's an exception for tyvars mentioned in
+a kind, as k is above. Note that k is also used "as a type variable", as the
+argument to the first Proxy. So, do we consider k to be type-variable-like and
+require it in the forall? Or do we consider k to be kind-variable-like and not
+require it?
+
+It's not just in type signatures: kind variables are implicitly brought into
+scope in a variety of places. Should vars used at both the type level and kind
+level be treated this way?
+
+GHC indeed allows kind variables to be brought into scope implicitly even when
+the kind variable is also used as a type variable. Thus, we must prefer to keep
+a variable listed as a kind var in rmDupsInRdrTyVars. If we kept it as a type
+var, then this would prevent it from being implicitly quantified (see
+rnImplicitBndrs). In the `foo` example above, that would have the consequence
+of the k in Proxy k being reported as out of scope.
+
+Note [Ordering of implicit variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Since the advent of -XTypeApplications, GHC makes promises about the ordering
+of implicit variable quantification. Specifically, we offer that implicitly
+quantified variables (such as those in const :: a -> b -> a, without a `forall`)
+will occur in left-to-right order of first occurrence. Here are a few examples:
+
+  const :: a -> b -> a       -- forall a b. ...
+  f :: Eq a => b -> a -> a   -- forall a b. ...  contexts are included
+
+  type a <-< b = b -> a
+  g :: a <-< b               -- forall a b. ...  type synonyms matter
+
+  class Functor f where
+    fmap :: (a -> b) -> f a -> f b   -- forall f a b. ...
+    -- The f is quantified by the class, so only a and b are considered in fmap
+
+This simple story is complicated by the possibility of dependency: all variables
+must come after any variables mentioned in their kinds.
+
+  typeRep :: Typeable a => TypeRep (a :: k)   -- forall k a. ...
+
+The k comes first because a depends on k, even though the k appears later than
+the a in the code. Thus, GHC does ScopedSort on the variables.
+See Note [ScopedSort] in Type.
+
+Implicitly bound variables are collected by any function which returns a
+FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably
+includes the `extract-` family of functions (extractHsTysRdrTyVars,
+extractHsTyVarBndrsKVs, etc.).
+These functions thus promise to keep left-to-right ordering.
+Look for pointers to this note to see the places where the action happens.
+
+Note that we also maintain this ordering in kind signatures. Even though
+there's no visible kind application (yet), having implicit variables be
+quantified in left-to-right order in kind signatures is nice since:
+
+* It's consistent with the treatment for type signatures.
+* It can affect how types are displayed with -fprint-explicit-kinds (see
+  #15568 for an example), which is a situation where knowing the order in
+  which implicit variables are quantified can be useful.
+* In the event that visible kind application is implemented, the order in
+  which we would expect implicit variables to be ordered in kinds will have
+  already been established.
+-}
+
+-- See Note [Kind and type-variable binders]
+-- These lists are guaranteed to preserve left-to-right ordering of
+-- the types the variables were extracted from. See also
+-- Note [Ordering of implicit variables].
+data FreeKiTyVars = FKTV { fktv_kis    :: [Located RdrName]
+                         , fktv_tys    :: [Located RdrName] }
+
+-- | A 'FreeKiTyVars' list that is allowed to have duplicate variables.
+type FreeKiTyVarsWithDups = FreeKiTyVars
+
+-- | A 'FreeKiTyVars' list that contains no duplicate variables.
+type FreeKiTyVarsNoDups   = FreeKiTyVars
+
+instance Outputable FreeKiTyVars where
+  ppr (FKTV { fktv_kis = kis, fktv_tys = tys}) = ppr (kis, tys)
+
+emptyFKTV :: FreeKiTyVarsNoDups
+emptyFKTV = FKTV { fktv_kis = [], fktv_tys = [] }
+
+freeKiTyVarsAllVars :: FreeKiTyVars -> [Located RdrName]
+freeKiTyVarsAllVars (FKTV { fktv_kis = kvs, fktv_tys = tvs }) = kvs ++ tvs
+
+freeKiTyVarsKindVars :: FreeKiTyVars -> [Located RdrName]
+freeKiTyVarsKindVars = fktv_kis
+
+freeKiTyVarsTypeVars :: FreeKiTyVars -> [Located RdrName]
+freeKiTyVarsTypeVars = fktv_tys
+
+filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
+filterInScope rdr_env (FKTV { fktv_kis = kis, fktv_tys = tys })
+  = FKTV { fktv_kis = filterOut in_scope kis
+         , fktv_tys = filterOut in_scope tys }
+  where
+    in_scope = inScope rdr_env . unLoc
+
+inScope :: LocalRdrEnv -> RdrName -> Bool
+inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
+
+-- | 'extractHsTyRdrTyVars' finds the
+--        free (kind, type) variables of an 'HsType'
+-- or the free (sort, kind) variables of an 'HsKind'.
+-- It's used when making the @forall@s explicit.
+-- Does not return any wildcards.
+-- When the same name occurs multiple times in the types, only the first
+-- occurrence is returned.
+-- See Note [Kind and type-variable binders]
+
+
+extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_tyarg (HsValArg ty) acc = extract_lty TypeLevel ty acc
+extract_tyarg (HsTypeArg _ ki) acc = extract_lty KindLevel ki acc
+extract_tyarg (HsArgPar _) acc = acc
+
+extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_tyargs args acc = foldr extract_tyarg acc args
+
+extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups
+extractHsTyArgRdrKiTyVarsDup args = extract_tyargs args emptyFKTV
+
+extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups
+extractHsTyRdrTyVars ty
+  = rmDupsInRdrTyVars (extractHsTyRdrTyVarsDups ty)
+
+-- | 'extractHsTyRdrTyVarsDups' find the
+--        free (kind, type) variables of an 'HsType'
+-- or the free (sort, kind) variables of an 'HsKind'.
+-- It's used when making the @forall@s explicit.
+-- Does not return any wildcards.
+-- When the same name occurs multiple times in the types, all occurrences
+-- are returned.
+extractHsTyRdrTyVarsDups :: LHsType GhcPs -> FreeKiTyVarsWithDups
+extractHsTyRdrTyVarsDups ty
+  = extract_lty TypeLevel ty emptyFKTV
+
+-- | Extracts the free kind variables (but not the type variables) of an
+-- 'HsType'. Does not return any wildcards.
+-- When the same name occurs multiple times in the type, only the first
+-- occurrence is returned, and the left-to-right order of variables is
+-- preserved.
+-- See Note [Kind and type-variable binders] and
+-- Note [Ordering of implicit variables].
+extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> [Located RdrName]
+extractHsTyRdrTyVarsKindVars ty
+  = freeKiTyVarsKindVars (extractHsTyRdrTyVars ty)
+
+-- | Extracts free type and kind variables from types in a list.
+-- When the same name occurs multiple times in the types, only the first
+-- occurrence is returned and the rest is filtered out.
+-- See Note [Kind and type-variable binders]
+extractHsTysRdrTyVars :: [LHsType GhcPs] -> FreeKiTyVarsNoDups
+extractHsTysRdrTyVars tys
+  = rmDupsInRdrTyVars (extractHsTysRdrTyVarsDups tys)
+
+-- | Extracts free type and kind variables from types in a list.
+-- When the same name occurs multiple times in the types, all occurrences
+-- are returned.
+extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups
+extractHsTysRdrTyVarsDups tys
+  = extract_ltys TypeLevel tys emptyFKTV
+
+extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> [Located RdrName]
+-- Returns the free kind variables of any explictly-kinded binders, returning
+-- variable occurrences in left-to-right order.
+-- See Note [Ordering of implicit variables].
+-- NB: Does /not/ delete the binders themselves.
+--     However duplicates are removed
+--     E.g. given  [k1, a:k1, b:k2]
+--          the function returns [k1,k2], even though k1 is bound here
+extractHsTyVarBndrsKVs tv_bndrs
+  = nubL (extract_hs_tv_bndrs_kvs tv_bndrs)
+
+-- | Removes multiple occurrences of the same name from FreeKiTyVars. If a
+-- variable occurs as both a kind and a type variable, only keep the occurrence
+-- as a kind variable.
+-- See also Note [Kind and type-variable binders]
+rmDupsInRdrTyVars :: FreeKiTyVarsWithDups -> FreeKiTyVarsNoDups
+rmDupsInRdrTyVars (FKTV { fktv_kis = kis, fktv_tys = tys })
+  = FKTV { fktv_kis = kis'
+         , fktv_tys = nubL (filterOut (`elemRdr` kis') tys) }
+  where
+    kis' = nubL kis
+
+extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName]
+-- Returns the free kind variables in a type family result signature, returning
+-- variable occurrences in left-to-right order.
+-- See Note [Ordering of implicit variables].
+extractRdrKindSigVars (dL->L _ resultSig)
+  | KindSig _ k                              <- resultSig = kindRdrNameFromSig k
+  | TyVarSig _ (dL->L _ (KindedTyVar _ _ k)) <- resultSig = kindRdrNameFromSig k
+  | otherwise =  []
+    where
+      kindRdrNameFromSig k = freeKiTyVarsAllVars (extractHsTyRdrTyVars k)
+
+extractDataDefnKindVars :: HsDataDefn GhcPs -> [Located RdrName]
+-- Get the scoped kind variables mentioned free in the constructor decls
+-- Eg: data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
+--     Here k should scope over the whole definition
+--
+-- However, do NOT collect free kind vars from the deriving clauses:
+-- Eg: (Trac #14331)    class C p q
+--                      data D = D deriving ( C (a :: k) )
+--     Here k should /not/ scope over the whole definition.  We intend
+--     this to elaborate to:
+--         class C @k1 @k2 (p::k1) (q::k2)
+--         data D = D
+--         instance forall k (a::k). C @k @* a D where ...
+--
+-- This returns variable occurrences in left-to-right order.
+-- See Note [Ordering of implicit variables].
+extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
+                                    , dd_cons = cons })
+  = (nubL . freeKiTyVarsKindVars) $
+    (extract_lctxt TypeLevel ctxt  $
+     extract_mb extract_lkind ksig $
+     foldr (extract_con . unLoc) emptyFKTV cons)
+  where
+    extract_con (ConDeclGADT { }) acc = acc
+    extract_con (ConDeclH98 { con_ex_tvs = ex_tvs
+                            , con_mb_cxt = ctxt, con_args = args }) acc
+      = extract_hs_tv_bndrs ex_tvs acc $
+        extract_mlctxt ctxt            $
+        extract_ltys TypeLevel (hsConDeclArgTys args) emptyFKTV
+    extract_con (XConDecl { }) _ = panic "extractDataDefnKindVars"
+extractDataDefnKindVars (XHsDataDefn _) = panic "extractDataDefnKindVars"
+
+extract_mlctxt :: Maybe (LHsContext GhcPs)
+               -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_mlctxt Nothing     acc = acc
+extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc
+
+extract_lctxt :: TypeOrKind
+              -> LHsContext GhcPs
+              -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt)
+
+extract_ltys :: TypeOrKind
+             -> [LHsType GhcPs]
+             -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_ltys t_or_k tys acc = foldr (extract_lty t_or_k) acc tys
+
+extract_mb :: (a -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
+           -> Maybe a
+           -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_mb _ Nothing  acc = acc
+extract_mb f (Just x) acc = f x acc
+
+extract_lkind :: LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
+extract_lkind = extract_lty KindLevel
+
+extract_lty :: TypeOrKind -> LHsType GhcPs
+            -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_lty t_or_k (dL->L _ ty) acc
+  = case ty of
+      HsTyVar _ _  ltv            -> extract_tv t_or_k ltv acc
+      HsBangTy _ _ ty             -> extract_lty t_or_k ty acc
+      HsRecTy _ flds              -> foldr (extract_lty t_or_k
+                                            . cd_fld_type . unLoc) acc
+                                           flds
+      HsAppTy _ ty1 ty2           -> extract_lty t_or_k ty1 $
+                                     extract_lty t_or_k ty2 acc
+      HsAppKindTy _ ty k          -> extract_lty t_or_k ty $
+                                     extract_lty KindLevel k acc
+      HsListTy _ ty               -> extract_lty t_or_k ty acc
+      HsTupleTy _ _ tys           -> extract_ltys t_or_k tys acc
+      HsSumTy _ tys               -> extract_ltys t_or_k tys acc
+      HsFunTy _ ty1 ty2           -> extract_lty t_or_k ty1 $
+                                     extract_lty t_or_k ty2 acc
+      HsIParamTy _ _ ty           -> extract_lty t_or_k ty acc
+      HsOpTy _ ty1 tv ty2         -> extract_tv t_or_k tv   $
+                                     extract_lty t_or_k ty1 $
+                                     extract_lty t_or_k ty2 acc
+      HsParTy _ ty                -> extract_lty t_or_k ty acc
+      HsSpliceTy {}               -> acc  -- Type splices mention no tvs
+      HsDocTy _ ty _              -> extract_lty t_or_k ty acc
+      HsExplicitListTy _ _ tys    -> extract_ltys t_or_k tys acc
+      HsExplicitTupleTy _ tys     -> extract_ltys t_or_k tys acc
+      HsTyLit _ _                 -> acc
+      HsStarTy _ _                -> acc
+      HsKindSig _ ty ki           -> extract_lty t_or_k ty $
+                                     extract_lkind ki acc
+      HsForAllTy { hst_bndrs = tvs, hst_body = ty }
+                                  -> extract_hs_tv_bndrs tvs acc $
+                                     extract_lty t_or_k ty emptyFKTV
+      HsQualTy { hst_ctxt = ctxt, hst_body = ty }
+                                  -> extract_lctxt t_or_k ctxt $
+                                     extract_lty t_or_k ty acc
+      XHsType {}                  -> acc
+      -- We deal with these separately in rnLHsTypeWithWildCards
+      HsWildCardTy {}             -> acc
+
+extractHsTvBndrs :: [LHsTyVarBndr GhcPs]
+                 -> FreeKiTyVarsWithDups           -- Free in body
+                 -> FreeKiTyVarsWithDups       -- Free in result
+extractHsTvBndrs tv_bndrs body_fvs
+  = extract_hs_tv_bndrs tv_bndrs emptyFKTV body_fvs
+
+extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]
+                    -> FreeKiTyVarsWithDups  -- Accumulator
+                    -> FreeKiTyVarsWithDups  -- Free in body
+                    -> FreeKiTyVarsWithDups
+-- In (forall (a :: Maybe e). a -> b) we have
+--     'a' is bound by the forall
+--     'b' is a free type variable
+--     'e' is a free kind variable
+extract_hs_tv_bndrs tv_bndrs
+      (FKTV { fktv_kis = acc_kvs,  fktv_tys = acc_tvs })   -- Accumulator
+      (FKTV { fktv_kis = body_kvs, fktv_tys = body_tvs })  -- Free in the body
+  | null tv_bndrs
+  = FKTV { fktv_kis = body_kvs ++ acc_kvs
+         , fktv_tys = body_tvs ++ acc_tvs }
+  | otherwise
+  = FKTV { fktv_kis = filterOut (`elemRdr` tv_bndr_rdrs) all_kv_occs
+                      -- NB: delete all tv_bndr_rdrs from bndr_kvs as well
+                      -- as body_kvs; see Note [Kind variable scoping]
+                      ++ acc_kvs
+         , fktv_tys = filterOut (`elemRdr` tv_bndr_rdrs) body_tvs ++ acc_tvs }
+  where
+    bndr_kvs = extract_hs_tv_bndrs_kvs tv_bndrs
+
+    tv_bndr_rdrs, all_kv_occs :: [Located RdrName]
+    tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs
+    all_kv_occs = bndr_kvs ++ body_kvs
+       -- We must include both kind variables from the binding as well
+       -- as the body of the `forall` type.
+       -- See Note [Variables used as both types and kinds].
+
+extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName]
+-- Returns the free kind variables of any explictly-kinded binders, returning
+-- variable occurrences in left-to-right order.
+-- See Note [Ordering of implicit variables].
+-- NB: Does /not/ delete the binders themselves.
+--     Duplicates are /not/ removed
+--     E.g. given  [k1, a:k1, b:k2]
+--          the function returns [k1,k2], even though k1 is bound here
+extract_hs_tv_bndrs_kvs tv_bndrs
+  = freeKiTyVarsKindVars $        -- There will /be/ no free tyvars!
+    foldr extract_lkind emptyFKTV
+          [k | (dL->L _ (KindedTyVar _ _ k)) <- tv_bndrs]
+
+extract_tv :: TypeOrKind -> Located RdrName
+           -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
+extract_tv t_or_k ltv@(dL->L _ tv) acc@(FKTV kvs tvs)
+  | not (isRdrTyVar tv) = acc
+  | isTypeLevel t_or_k  = FKTV { fktv_kis = kvs, fktv_tys = ltv : tvs }
+  | otherwise           = FKTV { fktv_kis = ltv : kvs, fktv_tys = tvs }
+
+-- Deletes duplicates in a list of Located things.
+--
+-- Importantly, this function is stable with respect to the original ordering
+-- of things in the list. This is important, as it is a property that GHC
+-- relies on to maintain the left-to-right ordering of implicitly quantified
+-- type variables.
+-- See Note [Ordering of implicit variables].
+nubL :: Eq a => [Located a] -> [Located a]
+nubL = nubBy eqLocated
+
+elemRdr :: Located RdrName -> [Located RdrName] -> Bool
+elemRdr x = any (eqLocated x)
diff --git a/compiler/rename/RnUnbound.hs b/compiler/rename/RnUnbound.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnUnbound.hs
@@ -0,0 +1,381 @@
+{-
+
+This module contains helper functions for reporting and creating
+unbound variables.
+
+-}
+module RnUnbound ( mkUnboundName
+                 , mkUnboundNameRdr
+                 , isUnboundName
+                 , reportUnboundName
+                 , unknownNameSuggestions
+                 , WhereLooking(..)
+                 , unboundName
+                 , unboundNameX
+                 , notInScopeErr ) where
+
+import GhcPrelude
+
+import RdrName
+import HscTypes
+import TcRnMonad
+import Name
+import Module
+import SrcLoc
+import Outputable
+import PrelNames ( mkUnboundName, isUnboundName, getUnique)
+import Util
+import Maybes
+import DynFlags
+import FastString
+import Data.List
+import Data.Function ( on )
+import UniqDFM (udfmToList)
+
+{-
+************************************************************************
+*                                                                      *
+               What to do when a lookup fails
+*                                                                      *
+************************************************************************
+-}
+
+data WhereLooking = WL_Any        -- Any binding
+                  | WL_Global     -- Any top-level binding (local or imported)
+                  | WL_LocalTop   -- Any top-level binding in this module
+                  | WL_LocalOnly
+                        -- Only local bindings
+                        -- (pattern synonyms declaractions,
+                        -- see Note [Renaming pattern synonym variables])
+
+mkUnboundNameRdr :: RdrName -> Name
+mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)
+
+reportUnboundName :: RdrName -> RnM Name
+reportUnboundName rdr = unboundName WL_Any rdr
+
+unboundName :: WhereLooking -> RdrName -> RnM Name
+unboundName wl rdr = unboundNameX wl rdr Outputable.empty
+
+unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name
+unboundNameX where_look rdr_name extra
+  = do  { dflags <- getDynFlags
+        ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags
+              err = notInScopeErr rdr_name $$ extra
+        ; if not show_helpful_errors
+          then addErr err
+          else do { local_env  <- getLocalRdrEnv
+                  ; global_env <- getGlobalRdrEnv
+                  ; impInfo <- getImports
+                  ; currmod <- getModule
+                  ; hpt <- getHpt
+                  ; let suggestions = unknownNameSuggestions_ where_look
+                          dflags hpt currmod global_env local_env impInfo
+                          rdr_name
+                  ; addErr (err $$ suggestions) }
+        ; return (mkUnboundNameRdr rdr_name) }
+
+notInScopeErr :: RdrName -> SDoc
+notInScopeErr rdr_name
+  = hang (text "Not in scope:")
+       2 (what <+> quotes (ppr rdr_name))
+  where
+    what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
+
+type HowInScope = Either SrcSpan ImpDeclSpec
+     -- Left loc    =>  locally bound at loc
+     -- Right ispec =>  imported as specified by ispec
+
+
+-- | Called from the typechecker (TcErrors) when we find an unbound variable
+unknownNameSuggestions :: DynFlags
+                       -> HomePackageTable -> Module
+                       -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails
+                       -> RdrName -> SDoc
+unknownNameSuggestions = unknownNameSuggestions_ WL_Any
+
+unknownNameSuggestions_ :: WhereLooking -> DynFlags
+                       -> HomePackageTable -> Module
+                       -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails
+                       -> RdrName -> SDoc
+unknownNameSuggestions_ where_look dflags hpt curr_mod global_env local_env
+                          imports tried_rdr_name =
+    similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$
+    importSuggestions where_look global_env hpt
+                      curr_mod imports tried_rdr_name $$
+    extensionSuggestions tried_rdr_name
+
+
+similarNameSuggestions :: WhereLooking -> DynFlags
+                        -> GlobalRdrEnv -> LocalRdrEnv
+                        -> RdrName -> SDoc
+similarNameSuggestions where_look dflags global_env
+                        local_env tried_rdr_name
+  = case suggest of
+      []  -> Outputable.empty
+      [p] -> perhaps <+> pp_item p
+      ps  -> sep [ perhaps <+> text "one of these:"
+                 , nest 2 (pprWithCommas pp_item ps) ]
+  where
+    all_possibilities :: [(String, (RdrName, HowInScope))]
+    all_possibilities
+       =  [ (showPpr dflags r, (r, Left loc))
+          | (r,loc) <- local_possibilities local_env ]
+       ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]
+
+    suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities
+    perhaps = text "Perhaps you meant"
+
+    pp_item :: (RdrName, HowInScope) -> SDoc
+    pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined
+        where loc' = case loc of
+                     UnhelpfulSpan l -> parens (ppr l)
+                     RealSrcSpan l -> parens (text "line" <+> int (srcSpanStartLine l))
+    pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+>   -- Imported
+                              parens (text "imported from" <+> ppr (is_mod is))
+
+    pp_ns :: RdrName -> SDoc
+    pp_ns rdr | ns /= tried_ns = pprNameSpace ns
+              | otherwise      = Outputable.empty
+      where ns = rdrNameSpace rdr
+
+    tried_occ     = rdrNameOcc tried_rdr_name
+    tried_is_sym  = isSymOcc tried_occ
+    tried_ns      = occNameSpace tried_occ
+    tried_is_qual = isQual tried_rdr_name
+
+    correct_name_space occ =  nameSpacesRelated (occNameSpace occ) tried_ns
+                           && isSymOcc occ == tried_is_sym
+        -- Treat operator and non-operators as non-matching
+        -- This heuristic avoids things like
+        --      Not in scope 'f'; perhaps you meant '+' (from Prelude)
+
+    local_ok = case where_look of { WL_Any -> True
+                                  ; WL_LocalOnly -> True
+                                  ; _ -> False }
+    local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)]
+    local_possibilities env
+      | tried_is_qual = []
+      | not local_ok  = []
+      | otherwise     = [ (mkRdrUnqual occ, nameSrcSpan name)
+                        | name <- localRdrEnvElts env
+                        , let occ = nameOccName name
+                        , correct_name_space occ]
+
+    global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))]
+    global_possibilities global_env
+      | tried_is_qual = [ (rdr_qual, (rdr_qual, how))
+                        | gre <- globalRdrEnvElts global_env
+                        , isGreOk where_look gre
+                        , let name = gre_name gre
+                              occ  = nameOccName name
+                        , correct_name_space occ
+                        , (mod, how) <- qualsInScope gre
+                        , let rdr_qual = mkRdrQual mod occ ]
+
+      | otherwise = [ (rdr_unqual, pair)
+                    | gre <- globalRdrEnvElts global_env
+                    , isGreOk where_look gre
+                    , let name = gre_name gre
+                          occ  = nameOccName name
+                          rdr_unqual = mkRdrUnqual occ
+                    , correct_name_space occ
+                    , pair <- case (unquals_in_scope gre, quals_only gre) of
+                                (how:_, _)    -> [ (rdr_unqual, how) ]
+                                ([],    pr:_) -> [ pr ]  -- See Note [Only-quals]
+                                ([],    [])   -> [] ]
+
+              -- Note [Only-quals]
+              -- The second alternative returns those names with the same
+              -- OccName as the one we tried, but live in *qualified* imports
+              -- e.g. if you have:
+              --
+              -- > import qualified Data.Map as Map
+              -- > foo :: Map
+              --
+              -- then we suggest @Map.Map@.
+
+    --------------------
+    unquals_in_scope :: GlobalRdrElt -> [HowInScope]
+    unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is })
+      | lcl       = [ Left (nameSrcSpan n) ]
+      | otherwise = [ Right ispec
+                    | i <- is, let ispec = is_decl i
+                    , not (is_qual ispec) ]
+
+
+    --------------------
+    quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)]
+    -- Ones for which *only* the qualified version is in scope
+    quals_only (GRE { gre_name = n, gre_imp = is })
+      = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec)
+        | i <- is, let ispec = is_decl i, is_qual ispec ]
+
+-- | Generate helpful suggestions if a qualified name Mod.foo is not in scope.
+importSuggestions :: WhereLooking
+                  -> GlobalRdrEnv
+                  -> HomePackageTable -> Module
+                  -> ImportAvails -> RdrName -> SDoc
+importSuggestions where_look global_env hpt currMod imports rdr_name
+  | WL_LocalOnly <- where_look                 = Outputable.empty
+  | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty
+  | null interesting_imports
+  , Just name <- mod_name
+  , show_not_imported_line name
+  = hsep
+      [ text "No module named"
+      , quotes (ppr name)
+      , text "is imported."
+      ]
+  | is_qualified
+  , null helpful_imports
+  , [(mod,_)] <- interesting_imports
+  = hsep
+      [ text "Module"
+      , quotes (ppr mod)
+      , text "does not export"
+      , quotes (ppr occ_name) <> dot
+      ]
+  | is_qualified
+  , null helpful_imports
+  , not (null interesting_imports)
+  , mods <- map fst interesting_imports
+  = hsep
+      [ text "Neither"
+      , quotedListWithNor (map ppr mods)
+      , text "exports"
+      , quotes (ppr occ_name) <> dot
+      ]
+  | [(mod,imv)] <- helpful_imports_non_hiding
+  = fsep
+      [ text "Perhaps you want to add"
+      , quotes (ppr occ_name)
+      , text "to the import list"
+      , text "in the import of"
+      , quotes (ppr mod)
+      , parens (ppr (imv_span imv)) <> dot
+      ]
+  | not (null helpful_imports_non_hiding)
+  = fsep
+      [ text "Perhaps you want to add"
+      , quotes (ppr occ_name)
+      , text "to one of these import lists:"
+      ]
+    $$
+    nest 2 (vcat
+        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))
+        | (mod,imv) <- helpful_imports_non_hiding
+        ])
+  | [(mod,imv)] <- helpful_imports_hiding
+  = fsep
+      [ text "Perhaps you want to remove"
+      , quotes (ppr occ_name)
+      , text "from the explicit hiding list"
+      , text "in the import of"
+      , quotes (ppr mod)
+      , parens (ppr (imv_span imv)) <> dot
+      ]
+  | not (null helpful_imports_hiding)
+  = fsep
+      [ text "Perhaps you want to remove"
+      , quotes (ppr occ_name)
+      , text "from the hiding clauses"
+      , text "in one of these imports:"
+      ]
+    $$
+    nest 2 (vcat
+        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))
+        | (mod,imv) <- helpful_imports_hiding
+        ])
+  | otherwise
+  = Outputable.empty
+ where
+  is_qualified = isQual rdr_name
+  (mod_name, occ_name) = case rdr_name of
+    Unqual occ_name        -> (Nothing, occ_name)
+    Qual mod_name occ_name -> (Just mod_name, occ_name)
+    _                      -> error "importSuggestions: dead code"
+
+
+  -- What import statements provide "Mod" at all
+  -- or, if this is an unqualified name, are not qualified imports
+  interesting_imports = [ (mod, imp)
+    | (mod, mod_imports) <- moduleEnvToList (imp_mods imports)
+    , Just imp <- return $ pick (importedByUser mod_imports)
+    ]
+
+  -- We want to keep only one for each original module; preferably one with an
+  -- explicit import list (for no particularly good reason)
+  pick :: [ImportedModsVal] -> Maybe ImportedModsVal
+  pick = listToMaybe . sortBy (compare `on` prefer) . filter select
+    where select imv = case mod_name of Just name -> imv_name imv == name
+                                        Nothing   -> not (imv_qualified imv)
+          prefer imv = (imv_is_hiding imv, imv_span imv)
+
+  -- Which of these would export a 'foo'
+  -- (all of these are restricted imports, because if they were not, we
+  -- wouldn't have an out-of-scope error in the first place)
+  helpful_imports = filter helpful interesting_imports
+    where helpful (_,imv)
+            = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name
+
+  -- Which of these do that because of an explicit hiding list resp. an
+  -- explicit import list
+  (helpful_imports_hiding, helpful_imports_non_hiding)
+    = partition (imv_is_hiding . snd) helpful_imports
+
+  -- See note [When to show/hide the module-not-imported line]
+  show_not_imported_line :: ModuleName -> Bool                    -- #15611
+  show_not_imported_line modnam
+      | modnam `elem` globMods                = False    -- #14225     -- 1
+      | moduleName currMod == modnam          = False                  -- 2.1
+      | is_last_loaded_mod modnam hpt_uniques = False                  -- 2.2
+      | otherwise                             = True
+    where
+      hpt_uniques = map fst (udfmToList hpt)
+      is_last_loaded_mod _ []         = False
+      is_last_loaded_mod modnam uniqs = last uniqs == getUnique modnam
+      globMods = nub [ mod
+                     | gre <- globalRdrEnvElts global_env
+                     , isGreOk where_look gre
+                     , (mod, _) <- qualsInScope gre
+                     ]
+
+extensionSuggestions :: RdrName -> SDoc
+extensionSuggestions rdrName
+  | rdrName == mkUnqual varName (fsLit "mdo") ||
+    rdrName == mkUnqual varName (fsLit "rec")
+      = text "Perhaps you meant to use RecursiveDo"
+  | otherwise = Outputable.empty
+
+qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)]
+-- Ones for which the qualified version is in scope
+qualsInScope GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }
+      | lcl = case nameModule_maybe n of
+                Nothing -> []
+                Just m  -> [(moduleName m, Left (nameSrcSpan n))]
+      | otherwise = [ (is_as ispec, Right ispec)
+                    | i <- is, let ispec = is_decl i ]
+
+isGreOk :: WhereLooking -> GlobalRdrElt -> Bool
+isGreOk where_look = case where_look of
+                         WL_LocalTop  -> isLocalGRE
+                         WL_LocalOnly -> const False
+                         _            -> const True
+
+{- Note [When to show/hide the module-not-imported line]           -- #15611
+For the error message:
+    Not in scope X.Y
+    Module X does not export Y
+    No module named ‘X’ is imported:
+there are 2 cases, where we hide the last "no module is imported" line:
+1. If the module X has been imported.
+2. If the module X is the current module. There are 2 subcases:
+   2.1 If the unknown module name is in a input source file,
+       then we can use the getModule function to get the current module name.
+       (See test T15611a)
+   2.2 If the unknown module name has been entered by the user in GHCi,
+       then the getModule function returns something like "interactive:Ghci1",
+       and we have to check the current module in the last added entry of
+       the HomePackageTable. (See test T15611b)
+-}
diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/rename/RnUtils.hs
@@ -0,0 +1,446 @@
+{-
+
+This module contains miscellaneous functions related to renaming.
+
+-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module RnUtils (
+        checkDupRdrNames, checkShadowedRdrNames,
+        checkDupNames, checkDupAndShadowedNames, dupNamesErr,
+        checkTupSize,
+        addFvRn, mapFvRn, mapMaybeFvRn,
+        warnUnusedMatches, warnUnusedTypePatterns,
+        warnUnusedTopBinds, warnUnusedLocalBinds,
+        mkFieldEnv,
+        unknownSubordinateErr, badQualBndrErr, typeAppErr,
+        HsDocContext(..), pprHsDocContext,
+        inHsDocContext, withHsDocContext,
+
+        newLocalBndrRn, newLocalBndrsRn,
+
+        bindLocalNames, bindLocalNamesFV,
+
+        addNameClashErrRn, extendTyVarEnvFVRn
+
+)
+
+where
+
+
+import GhcPrelude
+
+import HsSyn
+import RdrName
+import HscTypes
+import TcEnv
+import TcRnMonad
+import Name
+import NameSet
+import NameEnv
+import DataCon
+import SrcLoc
+import Outputable
+import Util
+import BasicTypes       ( TopLevelFlag(..) )
+import ListSetOps       ( removeDups )
+import DynFlags
+import FastString
+import Control.Monad
+import Data.List
+import Constants        ( mAX_TUPLE_SIZE )
+import qualified Data.List.NonEmpty as NE
+import qualified GHC.LanguageExtensions as LangExt
+
+{-
+*********************************************************
+*                                                      *
+\subsection{Binding}
+*                                                      *
+*********************************************************
+-}
+
+newLocalBndrRn :: Located RdrName -> RnM Name
+-- Used for non-top-level binders.  These should
+-- never be qualified.
+newLocalBndrRn (dL->L loc rdr_name)
+  | Just name <- isExact_maybe rdr_name
+  = return name -- This happens in code generated by Template Haskell
+                -- See Note [Binders in Template Haskell] in Convert.hs
+  | otherwise
+  = do { unless (isUnqual rdr_name)
+                (addErrAt loc (badQualBndrErr rdr_name))
+       ; uniq <- newUnique
+       ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
+
+newLocalBndrsRn :: [Located RdrName] -> RnM [Name]
+newLocalBndrsRn = mapM newLocalBndrRn
+
+bindLocalNames :: [Name] -> RnM a -> RnM a
+bindLocalNames names enclosed_scope
+  = do { lcl_env <- getLclEnv
+       ; let th_level  = thLevel (tcl_th_ctxt lcl_env)
+             th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)
+                           [ (n, (NotTopLevel, th_level)) | n <- names ]
+             rdr_env'  = extendLocalRdrEnvList (tcl_rdr lcl_env) names
+       ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs'
+                            , tcl_rdr      = rdr_env' })
+                    enclosed_scope }
+
+bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+bindLocalNamesFV names enclosed_scope
+  = do  { (result, fvs) <- bindLocalNames names enclosed_scope
+        ; return (result, delFVs names fvs) }
+
+-------------------------------------
+
+extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside
+
+-------------------------------------
+checkDupRdrNames :: [Located RdrName] -> RnM ()
+-- Check for duplicated names in a binding group
+checkDupRdrNames rdr_names_w_loc
+  = mapM_ (dupNamesErr getLoc) dups
+  where
+    (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
+
+checkDupNames :: [Name] -> RnM ()
+-- Check for duplicated names in a binding group
+checkDupNames names = check_dup_names (filterOut isSystemName names)
+                -- See Note [Binders in Template Haskell] in Convert
+
+check_dup_names :: [Name] -> RnM ()
+check_dup_names names
+  = mapM_ (dupNamesErr nameSrcSpan) dups
+  where
+    (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names
+
+---------------------
+checkShadowedRdrNames :: [Located RdrName] -> RnM ()
+checkShadowedRdrNames loc_rdr_names
+  = do { envs <- getRdrEnvs
+       ; checkShadowedOccs envs get_loc_occ filtered_rdrs }
+  where
+    filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names
+                -- See Note [Binders in Template Haskell] in Convert
+    get_loc_occ (dL->L loc rdr) = (loc,rdrNameOcc rdr)
+
+checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
+checkDupAndShadowedNames envs names
+  = do { check_dup_names filtered_names
+       ; checkShadowedOccs envs get_loc_occ filtered_names }
+  where
+    filtered_names = filterOut isSystemName names
+                -- See Note [Binders in Template Haskell] in Convert
+    get_loc_occ name = (nameSrcSpan name, nameOccName name)
+
+-------------------------------------
+checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)
+                  -> (a -> (SrcSpan, OccName))
+                  -> [a] -> RnM ()
+checkShadowedOccs (global_env,local_env) get_loc_occ ns
+  = whenWOptM Opt_WarnNameShadowing $
+    do  { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns))
+        ; mapM_ check_shadow ns }
+  where
+    check_shadow n
+        | startsWithUnderscore occ = return ()  -- Do not report shadowing for "_x"
+                                                -- See Trac #3262
+        | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)]
+        | otherwise = do { gres' <- filterM is_shadowed_gre gres
+                         ; complain (map pprNameProvenance gres') }
+        where
+          (loc,occ) = get_loc_occ n
+          mb_local  = lookupLocalRdrOcc local_env occ
+          gres      = lookupGRE_RdrName (mkRdrUnqual occ) global_env
+                -- Make an Unqualified RdrName and look that up, so that
+                -- we don't find any GREs that are in scope qualified-only
+
+          complain []      = return ()
+          complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing)
+                                       loc
+                                       (shadowedNameWarn occ pp_locs)
+
+    is_shadowed_gre :: GlobalRdrElt -> RnM Bool
+        -- Returns False for record selectors that are shadowed, when
+        -- punning or wild-cards are on (cf Trac #2723)
+    is_shadowed_gre gre | isRecFldGRE gre
+        = do { dflags <- getDynFlags
+             ; return $ not (xopt LangExt.RecordPuns dflags
+                             || xopt LangExt.RecordWildCards dflags) }
+    is_shadowed_gre _other = return True
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Free variable manipulation}
+*                                                                      *
+************************************************************************
+-}
+
+-- A useful utility
+addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
+addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside
+                               ; return (res, fvs1 `plusFV` fvs2) }
+
+mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
+mapFvRn f xs = do stuff <- mapM f xs
+                  case unzip stuff of
+                      (ys, fvs_s) -> return (ys, plusFVs fvs_s)
+
+mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
+mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)
+mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Envt utility functions}
+*                                                                      *
+************************************************************************
+-}
+
+warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()
+warnUnusedTopBinds gres
+    = whenWOptM Opt_WarnUnusedTopBinds
+    $ do env <- getGblEnv
+         let isBoot = tcg_src env == HsBootFile
+         let noParent gre = case gre_par gre of
+                            NoParent -> True
+                            _        -> False
+             -- Don't warn about unused bindings with parents in
+             -- .hs-boot files, as you are sometimes required to give
+             -- unused bindings (trac #3449).
+             -- HOWEVER, in a signature file, you are never obligated to put a
+             -- definition in the main text.  Thus, if you define something
+             -- and forget to export it, we really DO want to warn.
+             gres' = if isBoot then filter noParent gres
+                               else                 gres
+         warnUnusedGREs gres'
+
+warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns
+  :: [Name] -> FreeVars -> RnM ()
+warnUnusedLocalBinds   = check_unused Opt_WarnUnusedLocalBinds
+warnUnusedMatches      = check_unused Opt_WarnUnusedMatches
+warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns
+
+check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()
+check_unused flag bound_names used_names
+  = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names)
+                                               bound_names))
+
+-------------------------
+--      Helpers
+warnUnusedGREs :: [GlobalRdrElt] -> RnM ()
+warnUnusedGREs gres = mapM_ warnUnusedGRE gres
+
+warnUnused :: WarningFlag -> [Name] -> RnM ()
+warnUnused flag names = do
+    fld_env <- mkFieldEnv <$> getGlobalRdrEnv
+    mapM_ (warnUnused1 flag fld_env) names
+
+warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM ()
+warnUnused1 flag fld_env name
+  = when (reportable name occ) $
+    addUnusedWarning flag
+                     occ (nameSrcSpan name)
+                     (text $ "Defined but not used" ++ opt_str)
+  where
+    occ = case lookupNameEnv fld_env name of
+              Just (fl, _) -> mkVarOccFS fl
+              Nothing      -> nameOccName name
+    opt_str = case flag of
+                Opt_WarnUnusedTypePatterns -> " on the right hand side"
+                _ -> ""
+
+warnUnusedGRE :: GlobalRdrElt -> RnM ()
+warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })
+  | lcl       = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv
+                   warnUnused1 Opt_WarnUnusedTopBinds fld_env name
+  | otherwise = when (reportable name occ) (mapM_ warn is)
+  where
+    occ = greOccName gre
+    warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg
+        where
+           span = importSpecLoc spec
+           pp_mod = quotes (ppr (importSpecModule spec))
+           msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used")
+
+-- | Make a map from selector names to field labels and parent tycon
+-- names, to be used when reporting unused record fields.
+mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)
+mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre)))
+                               | gres <- occEnvElts rdr_env
+                               , gre <- gres
+                               , Just lbl <- [greLabel gre]
+                               ]
+
+-- | Should we report the fact that this 'Name' is unused? The
+-- 'OccName' may differ from 'nameOccName' due to
+-- DuplicateRecordFields.
+reportable :: Name -> OccName -> Bool
+reportable name occ
+  | isWiredInName name = False    -- Don't report unused wired-in names
+                                  -- Otherwise we get a zillion warnings
+                                  -- from Data.Tuple
+  | otherwise = not (startsWithUnderscore occ)
+
+addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()
+addUnusedWarning flag occ span msg
+  = addWarnAt (Reason flag) span $
+    sep [msg <> colon,
+         nest 2 $ pprNonVarNameSpace (occNameSpace occ)
+                        <+> quotes (ppr occ)]
+
+addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()
+addNameClashErrRn rdr_name gres
+  | all isLocalGRE gres && not (all isRecFldGRE gres)
+               -- If there are two or more *local* defns, we'll have reported
+  = return ()  -- that already, and we don't want an error cascade
+  | otherwise
+  = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)
+                 , text "It could refer to"
+                 , nest 3 (vcat (msg1 : msgs)) ])
+  where
+    (np1:nps) = gres
+    msg1 =  text "either" <+> ppr_gre np1
+    msgs = [text "    or" <+> ppr_gre np | np <- nps]
+    ppr_gre gre = sep [ pp_gre_name gre <> comma
+                      , pprNameProvenance gre]
+
+    -- When printing the name, take care to qualify it in the same
+    -- way as the provenance reported by pprNameProvenance, namely
+    -- the head of 'gre_imp'.  Otherwise we get confusing reports like
+    --   Ambiguous occurrence ‘null’
+    --   It could refer to either ‘T15487a.null’,
+    --                            imported from ‘Prelude’ at T15487.hs:1:8-13
+    --                     or ...
+    -- See Trac #15487
+    pp_gre_name gre@(GRE { gre_name = name, gre_par = parent
+                         , gre_lcl = lcl, gre_imp = iss })
+      | FldParent { par_lbl = Just lbl } <- parent
+      = text "the field" <+> quotes (ppr lbl)
+      | otherwise
+      = quotes (pp_qual <> dot <> ppr (nameOccName name))
+      where
+        pp_qual | lcl
+                = ppr (nameModule name)
+                | imp : _ <- iss  -- This 'imp' is the one that
+                                  -- pprNameProvenance chooses
+                , ImpDeclSpec { is_as = mod } <- is_decl imp
+                = ppr mod
+                | otherwise
+                = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss)
+                  -- Invariant: either 'lcl' is True or 'iss' is non-empty
+
+shadowedNameWarn :: OccName -> [SDoc] -> SDoc
+shadowedNameWarn occ shadowed_locs
+  = sep [text "This binding for" <+> quotes (ppr occ)
+            <+> text "shadows the existing binding" <> plural shadowed_locs,
+         nest 2 (vcat shadowed_locs)]
+
+
+unknownSubordinateErr :: SDoc -> RdrName -> SDoc
+unknownSubordinateErr doc op    -- Doc is "method of class" or
+                                -- "field of constructor"
+  = quotes (ppr op) <+> text "is not a (visible)" <+> doc
+
+
+dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM ()
+dupNamesErr get_loc names
+  = addErrAt big_loc $
+    vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)),
+          locations]
+  where
+    locs      = map get_loc (NE.toList names)
+    big_loc   = foldr1 combineSrcSpans locs
+    locations = text "Bound at:" <+> vcat (map ppr (sort locs))
+
+badQualBndrErr :: RdrName -> SDoc
+badQualBndrErr rdr_name
+  = text "Qualified name in binding position:" <+> ppr rdr_name
+
+typeAppErr :: String -> LHsType GhcPs -> SDoc
+typeAppErr what (L _ k)
+  = hang (text "Illegal visible" <+> text what <+> text "application"
+            <+> quotes (char '@' <> ppr k))
+       2 (text "Perhaps you intended to use TypeApplications")
+
+checkTupSize :: Int -> RnM ()
+checkTupSize tup_size
+  | tup_size <= mAX_TUPLE_SIZE
+  = return ()
+  | otherwise
+  = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),
+                 nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),
+                 nest 2 (text "Workaround: use nested tuples or define a data type")])
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Contexts for renaming errors}
+*                                                                      *
+************************************************************************
+-}
+
+-- AZ:TODO: Change these all to be Name instead of RdrName.
+--          Merge TcType.UserTypeContext in to it.
+data HsDocContext
+  = TypeSigCtx SDoc
+  | PatCtx
+  | SpecInstSigCtx
+  | DefaultDeclCtx
+  | ForeignDeclCtx (Located RdrName)
+  | DerivDeclCtx
+  | RuleCtx FastString
+  | TyDataCtx (Located RdrName)
+  | TySynCtx (Located RdrName)
+  | TyFamilyCtx (Located RdrName)
+  | FamPatCtx (Located RdrName)    -- The patterns of a type/data family instance
+  | ConDeclCtx [Located Name]
+  | ClassDeclCtx (Located RdrName)
+  | ExprWithTySigCtx
+  | TypBrCtx
+  | HsTypeCtx
+  | GHCiCtx
+  | SpliceTypeCtx (LHsType GhcPs)
+  | ClassInstanceCtx
+  | GenericCtx SDoc   -- Maybe we want to use this more!
+
+withHsDocContext :: HsDocContext -> SDoc -> SDoc
+withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt
+
+inHsDocContext :: HsDocContext -> SDoc
+inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt
+
+pprHsDocContext :: HsDocContext -> SDoc
+pprHsDocContext (GenericCtx doc)      = doc
+pprHsDocContext (TypeSigCtx doc)      = text "the type signature for" <+> doc
+pprHsDocContext PatCtx                = text "a pattern type-signature"
+pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma"
+pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"
+pprHsDocContext DerivDeclCtx          = text "a deriving declaration"
+pprHsDocContext (RuleCtx name)        = text "the transformation rule" <+> ftext name
+pprHsDocContext (TyDataCtx tycon)     = text "the data type declaration for" <+> quotes (ppr tycon)
+pprHsDocContext (FamPatCtx tycon)     = text "a type pattern of family instance for" <+> quotes (ppr tycon)
+pprHsDocContext (TySynCtx name)       = text "the declaration for type synonym" <+> quotes (ppr name)
+pprHsDocContext (TyFamilyCtx name)    = text "the declaration for type family" <+> quotes (ppr name)
+pprHsDocContext (ClassDeclCtx name)   = text "the declaration for class" <+> quotes (ppr name)
+pprHsDocContext ExprWithTySigCtx      = text "an expression type signature"
+pprHsDocContext TypBrCtx              = text "a Template-Haskell quoted type"
+pprHsDocContext HsTypeCtx             = text "a type argument"
+pprHsDocContext GHCiCtx               = text "GHCi input"
+pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)
+pprHsDocContext ClassInstanceCtx      = text "TcSplice.reifyInstances"
+
+pprHsDocContext (ForeignDeclCtx name)
+   = text "the foreign declaration for" <+> quotes (ppr name)
+pprHsDocContext (ConDeclCtx [name])
+   = text "the definition of data constructor" <+> quotes (ppr name)
+pprHsDocContext (ConDeclCtx names)
+   = text "the definition of data constructors" <+> interpp'SP names
diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/CSE.hs
@@ -0,0 +1,701 @@
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+\section{Common subexpression}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module CSE (cseProgram, cseOneExpr) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSubst
+import Var              ( Var )
+import VarEnv           ( elemInScopeSet, mkInScopeSet )
+import Id               ( Id, idType, isDeadBinder
+                        , idInlineActivation, setInlineActivation
+                        , zapIdOccInfo, zapIdUsageInfo, idInlinePragma
+                        , isJoinId, isJoinId_maybe )
+import CoreUtils        ( mkAltExpr, eqExpr
+                        , exprIsTickedString
+                        , stripTicksE, stripTicksT, mkTicks )
+import CoreFVs          ( exprFreeVars )
+import Type             ( tyConAppArgs )
+import CoreSyn
+import Outputable
+import BasicTypes
+import CoreMap
+import Util             ( filterOut )
+import Data.List        ( mapAccumL )
+
+{-
+                        Simple common sub-expression
+                        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we see
+        x1 = C a b
+        x2 = C x1 b
+we build up a reverse mapping:   C a b  -> x1
+                                 C x1 b -> x2
+and apply that to the rest of the program.
+
+When we then see
+        y1 = C a b
+        y2 = C y1 b
+we replace the C a b with x1.  But then we *dont* want to
+add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1
+so that a subsequent binding
+        y2 = C y1 b
+will get transformed to C x1 b, and then to x2.
+
+So we carry an extra var->var substitution which we apply *before* looking up in the
+reverse mapping.
+
+
+Note [Shadowing]
+~~~~~~~~~~~~~~~~
+We have to be careful about shadowing.
+For example, consider
+        f = \x -> let y = x+x in
+                      h = \x -> x+x
+                  in ...
+
+Here we must *not* do CSE on the inner x+x!  The simplifier used to guarantee no
+shadowing, but it doesn't any more (it proved too hard), so we clone as we go.
+We can simply add clones to the substitution already described.
+
+
+Note [CSE for bindings]
+~~~~~~~~~~~~~~~~~~~~~~~
+Let-bindings have two cases, implemented by addBinding.
+
+* SUBSTITUTE: applies when the RHS is a variable
+
+     let x = y in ...(h x)....
+
+  Here we want to extend the /substitution/ with x -> y, so that the
+  (h x) in the body might CSE with an enclosing (let v = h y in ...).
+  NB: the substitution maps InIds, so we extend the substitution with
+      a binding for the original InId 'x'
+
+  How can we have a variable on the RHS? Doesn't the simplifier inline them?
+
+    - First, the original RHS might have been (g z) which has CSE'd
+      with an enclosing (let y = g z in ...).  This is super-important.
+      See Trac #5996:
+         x1 = C a b
+         x2 = C x1 b
+         y1 = C a b
+         y2 = C y1 b
+      Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to
+      the substitution so that we can CSE the binding for y2.
+
+    - Second, we use addBinding for case expression scrutinees too;
+      see Note [CSE for case expressions]
+
+* EXTEND THE REVERSE MAPPING: applies in all other cases
+
+     let x = h y in ...(h y)...
+
+  Here we want to extend the /reverse mapping (cs_map)/ so that
+  we CSE the (h y) call to x.
+
+  Note that we use EXTEND even for a trivial expression, provided it
+  is not a variable or literal. In particular this /includes/ type
+  applications. This can be important (Trac #13156); e.g.
+     case f @ Int of { r1 ->
+     case f @ Int of { r2 -> ...
+  Here we want to common-up the two uses of (f @ Int) so we can
+  remove one of the case expressions.
+
+  See also Note [Corner case for case expressions] for another
+  reason not to use SUBSTITUTE for all trivial expressions.
+
+Notice that
+  - The SUBSTITUTE situation extends the substitution (cs_subst)
+  - The EXTEND situation extends the reverse mapping (cs_map)
+
+Notice also that in the SUBSTITUTE case we leave behind a binding
+  x = y
+even though we /also/ carry a substitution x -> y.  Can we just drop
+the binding instead?  Well, not at top level! See SimplUtils
+Note [Top level and postInlineUnconditionally]; and in any case CSE
+applies only to the /bindings/ of the program, and we leave it to the
+simplifier to propate effects to the RULES.  Finally, it doesn't seem
+worth the effort to discard the nested bindings because the simplifier
+will do it next.
+
+Note [CSE for case expressions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  case scrut_expr of x { ...alts... }
+This is very like a strict let-binding
+  let !x = scrut_expr in ...
+So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a
+result all the stuff under Note [CSE for bindings] applies directly.
+
+For example:
+
+* Trivial scrutinee
+     f = \x -> case x of wild {
+                 (a:as) -> case a of wild1 {
+                             (p,q) -> ...(wild1:as)...
+
+  Here, (wild1:as) is morally the same as (a:as) and hence equal to
+  wild. But that's not quite obvious.  In the rest of the compiler we
+  want to keep it as (wild1:as), but for CSE purpose that's a bad
+  idea.
+
+  By using addBinding we add the binding (wild1 -> a) to the substitution,
+  which does exactly the right thing.
+
+  (Notice this is exactly backwards to what the simplifier does, which
+  is to try to replaces uses of 'a' with uses of 'wild1'.)
+
+  This is the main reason that addBinding is called with a trivial rhs.
+
+* Non-trivial scrutinee
+     case (f x) of y { pat -> ...let z = f x in ... }
+
+  By using addBinding we'll add (f x :-> y) to the cs_map, and
+  thereby CSE the inner (f x) to y.
+
+Note [CSE for INLINE and NOINLINE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are some subtle interactions of CSE with functions that the user
+has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)
+Consider
+
+        yes :: Int  {-# NOINLINE yes #-}
+        yes = undefined
+
+        no :: Int   {-# NOINLINE no #-}
+        no = undefined
+
+        foo :: Int -> Int -> Int  {-# NOINLINE foo #-}
+        foo m n = n
+
+        {-# RULES "foo/no" foo no = id #-}
+
+        bar :: Int -> Int
+        bar = foo yes
+
+We do not expect the rule to fire.  But if we do CSE, then we risk
+getting yes=no, and the rule does fire.  Actually, it won't because
+NOINLINE means that 'yes' will never be inlined, not even if we have
+yes=no.  So that's fine (now; perhaps in the olden days, yes=no would
+have substituted even if 'yes' was NOINLINE).
+
+But we do need to take care.  Consider
+
+        {-# NOINLINE bar #-}
+        bar = <rhs>     -- Same rhs as foo
+
+        foo = <rhs>
+
+If CSE produces
+        foo = bar
+then foo will never be inlined to <rhs> (when it should be, if <rhs>
+is small).  The conclusion here is this:
+
+   We should not add
+       <rhs> :-> bar
+  to the CSEnv if 'bar' has any constraints on when it can inline;
+  that is, if its 'activation' not always active.  Otherwise we
+  might replace <rhs> by 'bar', and then later be unable to see that it
+  really was <rhs>.
+
+An except to the rule is when the INLINE pragma is not from the user, e.g. from
+WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec
+is then true.
+
+Note that we do not (currently) do CSE on the unfolding stored inside
+an Id, even if it is a 'stable' unfolding.  That means that when an
+unfolding happens, it is always faithful to what the stable unfolding
+originally was.
+
+Note [CSE for stable unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   {-# Unf = Stable (\pq. build blah) #-}
+   foo = x
+
+Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial.
+(Turns out that this actually happens for the enumFromTo method of
+the Integer instance of Enum in GHC.Enum.)  Suppose moreover that foo's
+stable unfolding originates from an INLINE or INLINEABLE pragma on foo.
+Then we obviously do NOT want to extend the substitution with (foo->x),
+because we promised to inline foo as what the user wrote.  See similar
+SimplUtils Note [Stable unfoldings and postInlineUnconditionally].
+
+Nor do we want to change the reverse mapping. Suppose we have
+
+   {-# Unf = Stable (\pq. build blah) #-}
+   foo = <expr>
+   bar = <expr>
+
+There could conceivably be merit in rewriting the RHS of bar:
+   bar = foo
+but now bar's inlining behaviour will change, and importing
+modules might see that.  So it seems dodgy and we don't do it.
+
+Stable unfoldings are also created during worker/wrapper when we decide
+that a function's definition is so small that it should always inline.
+In this case we still want to do CSE (#13340). Hence the use of
+isAnyInlinePragma rather than isStableUnfolding.
+
+Note [Corner case for case expressions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is another reason that we do not use SUBSTITUTE for
+all trivial expressions. Consider
+   case x |> co of (y::Array# Int) { ... }
+
+We do not want to extend the substitution with (y -> x |> co); since y
+is of unlifted type, this would destroy the let/app invariant if (x |>
+co) was not ok-for-speculation.
+
+But surely (x |> co) is ok-for-speculation, becasue it's a trivial
+expression, and x's type is also unlifted, presumably.  Well, maybe
+not if you are using unsafe casts.  I actually found a case where we
+had
+   (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int)
+
+Note [CSE for join points?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must not be naive about join points in CSE:
+   join j = e in
+   if b then jump j else 1 + e
+The expression (1 + jump j) is not good (see Note [Invariants on join points] in
+CoreSyn). This seems to come up quite seldom, but it happens (first seen
+compiling ppHtml in Haddock.Backends.Xhtml).
+
+We could try and be careful by tracking which join points are still valid at
+each subexpression, but since join points aren't allocated or shared, there's
+less to gain by trying to CSE them. (#13219)
+
+Note [Look inside join-point binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Another way how CSE for joint points is tricky is
+
+  let join foo x = (x, 42)
+      join bar x = (x, 42)
+  in … jump foo 1 … jump bar 2 …
+
+naively, CSE would turn this into
+
+  let join foo x = (x, 42)
+      join bar = foo
+  in … jump foo 1 … jump bar 2 …
+
+but now bar is a join point that claims arity one, but its right-hand side
+is not a lambda, breaking the join-point invariant (this was #15002).
+
+So `cse_bind` must zoom past the lambdas of a join point (using
+`collectNBinders`) and resume searching for CSE opportunities only in
+the body of the join point.
+
+Note [CSE for recursive bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f = \x ... f....
+  g = \y ... g ...
+where the "..." are identical.  Could we CSE them?  In full generality
+with mutual recursion it's quite hard; but for self-recursive bindings
+(which are very common) it's rather easy:
+
+* Maintain a separate cs_rec_map, that maps
+      (\f. (\x. ...f...) ) -> f
+  Note the \f in the domain of the mapping!
+
+* When we come across the binding for 'g', look up (\g. (\y. ...g...))
+  Bingo we get a hit.  So we can replace the 'g' binding with
+     g = f
+
+We can't use cs_map for this, because the key isn't an expression of
+the program; it's a kind of synthetic key for recursive bindings.
+
+
+************************************************************************
+*                                                                      *
+\section{Common subexpression}
+*                                                                      *
+************************************************************************
+-}
+
+cseProgram :: CoreProgram -> CoreProgram
+cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds)
+
+cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind)
+cseBind toplevel env (NonRec b e)
+  = (env2, NonRec b2 e2)
+  where
+    (env1, b1)       = addBinder env b
+    (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1
+
+cseBind toplevel env (Rec [(in_id, rhs)])
+  | noCSE in_id
+  = (env1, Rec [(out_id, rhs')])
+
+  -- See Note [CSE for recursive bindings]
+  | Just previous <- lookupCSRecEnv env out_id rhs''
+  , let previous' = mkTicks ticks previous
+        out_id'   = delayInlining toplevel out_id
+  = -- We have a hit in the recursive-binding cache
+    (extendCSSubst env1 in_id previous', NonRec out_id' previous')
+
+  | otherwise
+  = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')])
+
+  where
+    (env1, [out_id]) = addRecBinders env [in_id]
+    rhs'  = cseExpr env1 rhs
+    rhs'' = stripTicksE tickishFloatable rhs'
+    ticks = stripTicksT tickishFloatable rhs'
+    id_expr'  = varToCoreExpr out_id
+    zapped_id = zapIdUsageInfo out_id
+
+cseBind toplevel env (Rec pairs)
+  = (env2, Rec pairs')
+  where
+    (env1, bndrs1) = addRecBinders env (map fst pairs)
+    (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1)
+
+    do_one env (pr, b1) = cse_bind toplevel env pr b1
+
+-- | Given a binding of @in_id@ to @in_rhs@, and a fresh name to refer
+-- to @in_id@ (@out_id@, created from addBinder or addRecBinders),
+-- first try to CSE @in_rhs@, and then add the resulting (possibly CSE'd)
+-- binding to the 'CSEnv', so that we attempt to CSE any expressions
+-- which are equal to @out_rhs@.
+cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))
+cse_bind toplevel env (in_id, in_rhs) out_id
+  | isTopLevel toplevel, exprIsTickedString in_rhs
+      -- See Note [Take care with literal strings]
+  = (env', (out_id', in_rhs))
+
+  | Just arity <- isJoinId_maybe in_id
+      -- See Note [Look inside join-point binders]
+  = let (params, in_body) = collectNBinders arity in_rhs
+        (env', params') = addBinders env params
+        out_body = tryForCSE env' in_body
+    in (env, (out_id, mkLams params' out_body))
+
+  | otherwise
+  = (env', (out_id'', out_rhs))
+  where
+    (env', out_id') = addBinding env in_id out_id out_rhs
+    (cse_done, out_rhs) = try_for_cse env in_rhs
+    out_id'' | cse_done  = delayInlining toplevel out_id'
+             | otherwise = out_id'
+
+delayInlining :: TopLevelFlag -> Id -> Id
+-- Add a NOINLINE[2] if the Id doesn't have an INLNE pragma already
+delayInlining top_lvl bndr
+  | isTopLevel top_lvl
+  , isAlwaysActive (idInlineActivation bndr)
+  = bndr `setInlineActivation` activeAfterInitial
+  | otherwise
+  = bndr
+
+addBinding :: CSEnv                      -- Includes InId->OutId cloning
+           -> InVar                      -- Could be a let-bound type
+           -> OutId -> OutExpr           -- Processed binding
+           -> (CSEnv, OutId)             -- Final env, final bndr
+-- Extend the CSE env with a mapping [rhs -> out-id]
+-- unless we can instead just substitute [in-id -> rhs]
+--
+-- It's possible for the binder to be a type variable (see
+-- Note [Type-let] in CoreSyn), in which case we can just substitute.
+addBinding env in_id out_id rhs'
+  | not (isId in_id) = (extendCSSubst env in_id rhs',     out_id)
+  | noCSE in_id      = (env,                              out_id)
+  | use_subst        = (extendCSSubst env in_id rhs',     out_id)
+  | otherwise        = (extendCSEnv env rhs' id_expr', zapped_id)
+  where
+    id_expr'  = varToCoreExpr out_id
+    zapped_id = zapIdUsageInfo out_id
+       -- Putting the Id into the cs_map makes it possible that
+       -- it'll become shared more than it is now, which would
+       -- invalidate (the usage part of) its demand info.
+       --    This caused Trac #100218.
+       -- Easiest thing is to zap the usage info; subsequently
+       -- performing late demand-analysis will restore it.  Don't zap
+       -- the strictness info; it's not necessary to do so, and losing
+       -- it is bad for performance if you don't do late demand
+       -- analysis
+
+    -- Should we use SUBSTITUTE or EXTEND?
+    -- See Note [CSE for bindings]
+    use_subst = case rhs' of
+                   Var {} -> True
+                   _      -> False
+
+-- | Given a binder `let x = e`, this function
+-- determines whether we should add `e -> x` to the cs_map
+noCSE :: InId -> Bool
+noCSE id =  not (isAlwaysActive (idInlineActivation id)) &&
+            not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id)))
+             -- See Note [CSE for INLINE and NOINLINE]
+         || isAnyInlinePragma (idInlinePragma id)
+             -- See Note [CSE for stable unfoldings]
+         || isJoinId id
+             -- See Note [CSE for join points?]
+
+
+{- Note [Take care with literal strings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this example:
+
+  x = "foo"#
+  y = "foo"#
+  ...x...y...x...y....
+
+We would normally turn this into:
+
+  x = "foo"#
+  y = x
+  ...x...x...x...x....
+
+But this breaks an invariant of Core, namely that the RHS of a top-level binding
+of type Addr# must be a string literal, not another variable. See Note
+[CoreSyn top-level string literals] in CoreSyn.
+
+For this reason, we special case top-level bindings to literal strings and leave
+the original RHS unmodified. This produces:
+
+  x = "foo"#
+  y = "foo"#
+  ...x...x...x...x....
+
+Now 'y' will be discarded as dead code, and we are done.
+
+The net effect is that for the y-binding we want to
+  - Use SUBSTITUTE, by extending the substitution with  y :-> x
+  - but leave the original binding for y undisturbed
+
+This is done by cse_bind.  I got it wrong the first time (Trac #13367).
+
+Note [Delay inlining after CSE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose (Trac #15445) we have
+   f,g :: Num a => a -> a
+   f x = ...f (x-1).....
+   g y = ...g (y-1) ....
+
+and we make some specialisations of 'g', either automatically, or via
+a SPECIALISE pragma.  Then CSE kicks in and notices that the RHSs of
+'f' and 'g' are identical, so we get
+   f x = ...f (x-1)...
+   g = f
+   {-# RULES g @Int _ = $sg #-}
+
+Now there is terrible danger that, in an importing module, we'll inline
+'g' before we have a chance to run its specialisation!
+
+Solution: during CSE, when adding a top-level
+  g = f
+binding after a "hit" in the CSE cache, add a NOINLINE[2] activation
+to it, to ensure it's not inlined right away.
+
+Why top level only?  Because for nested bindings we are already past
+phase 2 and will never return there.
+-}
+
+tryForCSE :: CSEnv -> InExpr -> OutExpr
+tryForCSE env expr = snd (try_for_cse env expr)
+
+try_for_cse :: CSEnv -> InExpr -> (Bool, OutExpr)
+-- (False, e') => We did not CSE the entire expression,
+--                but we might have CSE'd some sub-expressions,
+--                yielding e'
+--
+-- (True, te') => We CSE'd the entire expression,
+--                yielding the trivial expression te'
+try_for_cse env expr
+  | Just e <- lookupCSEnv env expr'' = (True,  mkTicks ticks e)
+  | otherwise                        = (False, expr')
+    -- The varToCoreExpr is needed if we have
+    --   case e of xco { ...case e of yco { ... } ... }
+    -- Then CSE will substitute yco -> xco;
+    -- but these are /coercion/ variables
+  where
+    expr'  = cseExpr env expr
+    expr'' = stripTicksE tickishFloatable expr'
+    ticks  = stripTicksT tickishFloatable expr'
+    -- We don't want to lose the source notes when a common sub
+    -- expression gets eliminated. Hence we push all (!) of them on
+    -- top of the replaced sub-expression. This is probably not too
+    -- useful in practice, but upholds our semantics.
+
+-- | Runs CSE on a single expression.
+--
+-- This entry point is not used in the compiler itself, but is provided
+-- as a convenient entry point for users of the GHC API.
+cseOneExpr :: InExpr -> OutExpr
+cseOneExpr e = cseExpr env e
+  where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) }
+
+cseExpr :: CSEnv -> InExpr -> OutExpr
+cseExpr env (Type t)              = Type (substTy (csEnvSubst env) t)
+cseExpr env (Coercion c)          = Coercion (substCo (csEnvSubst env) c)
+cseExpr _   (Lit lit)             = Lit lit
+cseExpr env (Var v)               = lookupSubst env v
+cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)
+cseExpr env (Tick t e)            = Tick t (cseExpr env e)
+cseExpr env (Cast e co)           = Cast (tryForCSE env e) (substCo (csEnvSubst env) co)
+cseExpr env (Lam b e)             = let (env', b') = addBinder env b
+                                    in Lam b' (cseExpr env' e)
+cseExpr env (Let bind e)          = let (env', bind') = cseBind NotTopLevel env bind
+                                    in Let bind' (cseExpr env' e)
+cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts
+
+cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr
+cseCase env scrut bndr ty alts
+  = Case scrut1 bndr3 ty' $
+    combineAlts alt_env (map cse_alt alts)
+  where
+    ty' = substTy (csEnvSubst env) ty
+    scrut1 = tryForCSE env scrut
+
+    bndr1 = zapIdOccInfo bndr
+      -- Zapping the OccInfo is needed because the extendCSEnv
+      -- in cse_alt may mean that a dead case binder
+      -- becomes alive, and Lint rejects that
+    (env1, bndr2)    = addBinder env bndr1
+    (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1
+         -- addBinding: see Note [CSE for case expressions]
+
+    con_target :: OutExpr
+    con_target = lookupSubst alt_env bndr
+
+    arg_tys :: [OutType]
+    arg_tys = tyConAppArgs (idType bndr3)
+
+    -- Given case x of { K y z -> ...K y z... }
+    -- CSE K y z into x...
+    cse_alt (DataAlt con, args, rhs)
+        | not (null args)
+                -- ... but don't try CSE if there are no args; it just increases the number
+                -- of live vars.  E.g.
+                --      case x of { True -> ....True.... }
+                -- Don't replace True by x!
+                -- Hence the 'null args', which also deal with literals and DEFAULT
+        = (DataAlt con, args', tryForCSE new_env rhs)
+        where
+          (env', args') = addBinders alt_env args
+          new_env       = extendCSEnv env' con_expr con_target
+          con_expr      = mkAltExpr (DataAlt con) args' arg_tys
+
+    cse_alt (con, args, rhs)
+        = (con, args', tryForCSE env' rhs)
+        where
+          (env', args') = addBinders alt_env args
+
+combineAlts :: CSEnv -> [InAlt] -> [InAlt]
+-- See Note [Combine case alternatives]
+combineAlts env ((_,bndrs1,rhs1) : rest_alts)
+  | all isDeadBinder bndrs1
+  = (DEFAULT, [], rhs1) : filtered_alts
+  where
+    in_scope = substInScope (csEnvSubst env)
+    filtered_alts = filterOut identical rest_alts
+    identical (_con, bndrs, rhs) = all ok bndrs && eqExpr in_scope rhs1 rhs
+    ok bndr = isDeadBinder bndr || not (bndr `elemInScopeSet` in_scope)
+
+combineAlts _ alts = alts  -- Default case
+
+{- Note [Combine case alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+combineAlts is just a more heavyweight version of the use of
+combineIdenticalAlts in SimplUtils.prepareAlts.  The basic idea is
+to transform
+
+    DEFAULT -> e1
+    K x     -> e1
+    W y z   -> e2
+===>
+   DEFAULT -> e1
+   W y z   -> e2
+
+In the simplifier we use cheapEqExpr, because it is called a lot.
+But here in CSE we use the full eqExpr.  After all, two alternatives usually
+differ near the root, so it probably isn't expensive to compare the full
+alternative.  It seems like the same kind of thing that CSE is supposed
+to be doing, which is why I put it here.
+
+I acutally saw some examples in the wild, where some inlining made e1 too
+big for cheapEqExpr to catch it.
+
+
+************************************************************************
+*                                                                      *
+\section{The CSE envt}
+*                                                                      *
+************************************************************************
+-}
+
+data CSEnv
+  = CS { cs_subst :: Subst  -- Maps InBndrs to OutExprs
+            -- The substitution variables to
+            -- /trivial/ OutExprs, not arbitrary expressions
+
+       , cs_map   :: CoreMap OutExpr   -- The reverse mapping
+            -- Maps a OutExpr to a /trivial/ OutExpr
+            -- The key of cs_map is stripped of all Ticks
+
+       , cs_rec_map :: CoreMap OutExpr
+            -- See Note [CSE for recursive bindings]
+       }
+
+emptyCSEnv :: CSEnv
+emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap
+                , cs_subst = emptySubst }
+
+lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr
+lookupCSEnv (CS { cs_map = csmap }) expr
+  = lookupCoreMap csmap expr
+
+extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv
+extendCSEnv cse expr triv_expr
+  = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }
+  where
+    sexpr = stripTicksE tickishFloatable expr
+
+extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv
+-- See Note [CSE for recursive bindings]
+extendCSRecEnv cse bndr expr triv_expr
+  = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr }
+
+lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr
+-- See Note [CSE for recursive bindings]
+lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr
+  = lookupCoreMap csmap (Lam bndr expr)
+
+csEnvSubst :: CSEnv -> Subst
+csEnvSubst = cs_subst
+
+lookupSubst :: CSEnv -> Id -> OutExpr
+lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x
+
+extendCSSubst :: CSEnv -> Id  -> CoreExpr -> CSEnv
+extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }
+
+-- | Add clones to the substitution to deal with shadowing.  See
+-- Note [Shadowing] for more details.  You should call this whenever
+-- you go under a binder.
+addBinder :: CSEnv -> Var -> (CSEnv, Var)
+addBinder cse v = (cse { cs_subst = sub' }, v')
+                where
+                  (sub', v') = substBndr (cs_subst cse) v
+
+addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])
+addBinders cse vs = (cse { cs_subst = sub' }, vs')
+                where
+                  (sub', vs') = substBndrs (cs_subst cse) vs
+
+addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])
+addRecBinders cse vs = (cse { cs_subst = sub' }, vs')
+                where
+                  (sub', vs') = substRecBndrs (cs_subst cse) vs
diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/CallArity.hs
@@ -0,0 +1,763 @@
+--
+-- Copyright (c) 2014 Joachim Breitner
+--
+
+module CallArity
+    ( callArityAnalProgram
+    , callArityRHS -- for testing
+    ) where
+
+import GhcPrelude
+
+import VarSet
+import VarEnv
+import DynFlags ( DynFlags )
+
+import BasicTypes
+import CoreSyn
+import Id
+import CoreArity ( typeArity )
+import CoreUtils ( exprIsCheap, exprIsTrivial )
+import UnVarGraph
+import Demand
+import Util
+
+import Control.Arrow ( first, second )
+
+
+{-
+%************************************************************************
+%*                                                                      *
+              Call Arity Analysis
+%*                                                                      *
+%************************************************************************
+
+Note [Call Arity: The goal]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The goal of this analysis is to find out if we can eta-expand a local function,
+based on how it is being called. The motivating example is this code,
+which comes up when we implement foldl using foldr, and do list fusion:
+
+    let go = \x -> let d = case ... of
+                              False -> go (x+1)
+                              True  -> id
+                   in \z -> d (x + z)
+    in go 1 0
+
+If we do not eta-expand `go` to have arity 2, we are going to allocate a lot of
+partial function applications, which would be bad.
+
+The function `go` has a type of arity two, but only one lambda is manifest.
+Furthermore, an analysis that only looks at the RHS of go cannot be sufficient
+to eta-expand go: If `go` is ever called with one argument (and the result used
+multiple times), we would be doing the work in `...` multiple times.
+
+So `callArityAnalProgram` looks at the whole let expression to figure out if
+all calls are nice, i.e. have a high enough arity. It then stores the result in
+the `calledArity` field of the `IdInfo` of `go`, which the next simplifier
+phase will eta-expand.
+
+The specification of the `calledArity` field is:
+
+    No work will be lost if you eta-expand me to the arity in `calledArity`.
+
+What we want to know for a variable
+-----------------------------------
+
+For every let-bound variable we'd like to know:
+  1. A lower bound on the arity of all calls to the variable, and
+  2. whether the variable is being called at most once or possible multiple
+     times.
+
+It is always ok to lower the arity, or pretend that there are multiple calls.
+In particular, "Minimum arity 0 and possible called multiple times" is always
+correct.
+
+
+What we want to know from an expression
+---------------------------------------
+
+In order to obtain that information for variables, we analyze expression and
+obtain bits of information:
+
+ I.  The arity analysis:
+     For every variable, whether it is absent, or called,
+     and if called, which what arity.
+
+ II. The Co-Called analysis:
+     For every two variables, whether there is a possibility that both are being
+     called.
+     We obtain as a special case: For every variables, whether there is a
+     possibility that it is being called twice.
+
+For efficiency reasons, we gather this information only for a set of
+*interesting variables*, to avoid spending time on, e.g., variables from pattern matches.
+
+The two analysis are not completely independent, as a higher arity can improve
+the information about what variables are being called once or multiple times.
+
+Note [Analysis I: The arity analysis]
+------------------------------------
+
+The arity analysis is quite straight forward: The information about an
+expression is an
+    VarEnv Arity
+where absent variables are bound to Nothing and otherwise to a lower bound to
+their arity.
+
+When we analyze an expression, we analyze it with a given context arity.
+Lambdas decrease and applications increase the incoming arity. Analysizing a
+variable will put that arity in the environment. In lets or cases all the
+results from the various subexpressions are lubed, which takes the point-wise
+minimum (considering Nothing an infinity).
+
+
+Note [Analysis II: The Co-Called analysis]
+------------------------------------------
+
+The second part is more sophisticated. For reasons explained below, it is not
+sufficient to simply know how often an expression evaluates a variable. Instead
+we need to know which variables are possibly called together.
+
+The data structure here is an undirected graph of variables, which is provided
+by the abstract
+    UnVarGraph
+
+It is safe to return a larger graph, i.e. one with more edges. The worst case
+(i.e. the least useful and always correct result) is the complete graph on all
+free variables, which means that anything can be called together with anything
+(including itself).
+
+Notation for the following:
+C(e)  is the co-called result for e.
+G₁∪G₂ is the union of two graphs
+fv    is the set of free variables (conveniently the domain of the arity analysis result)
+S₁×S₂ is the complete bipartite graph { {a,b} | a ∈ S₁, b ∈ S₂ }
+S²    is the complete graph on the set of variables S, S² = S×S
+C'(e) is a variant for bound expression:
+      If e is called at most once, or it is and stays a thunk (after the analysis),
+      it is simply C(e). Otherwise, the expression can be called multiple times
+      and we return (fv e)²
+
+The interesting cases of the analysis:
+ * Var v:
+   No other variables are being called.
+   Return {} (the empty graph)
+ * Lambda v e, under arity 0:
+   This means that e can be evaluated many times and we cannot get
+   any useful co-call information.
+   Return (fv e)²
+ * Case alternatives alt₁,alt₂,...:
+   Only one can be execuded, so
+   Return (alt₁ ∪ alt₂ ∪...)
+ * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂:
+   We get the results from both sides, with the argument evaluated at most once.
+   Additionally, anything called by e₁ can possibly be called with anything
+   from e₂.
+   Return: C(e₁) ∪ C(e₂) ∪ (fv e₁) × (fv e₂)
+ * App e₁ x:
+   As this is already in A-normal form, CorePrep will not separately lambda
+   bind (and hence share) x. So we conservatively assume multiple calls to x here
+   Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)}
+ * Let v = rhs in body:
+   In addition to the results from the subexpressions, add all co-calls from
+   everything that the body calls together with v to everthing that is called
+   by v.
+   Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)}
+ * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body
+   Tricky.
+   We assume that it is really mutually recursive, i.e. that every variable
+   calls one of the others, and that this is strongly connected (otherwise we
+   return an over-approximation, so that's ok), see note [Recursion and fixpointing].
+
+   Let V = {v₁,...vₙ}.
+   Assume that the vs have been analysed with an incoming demand and
+   cardinality consistent with the final result (this is the fixed-pointing).
+   Again we can use the results from all subexpressions.
+   In addition, for every variable vᵢ, we need to find out what it is called
+   with (call this set Sᵢ). There are two cases:
+    * If vᵢ is a function, we need to go through all right-hand-sides and bodies,
+      and collect every variable that is called together with any variable from V:
+      Sᵢ = {v' | j ∈ {1,...,n},      {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }
+    * If vᵢ is a thunk, then its rhs is evaluated only once, so we need to
+      exclude it from this set:
+      Sᵢ = {v' | j ∈ {1,...,n}, j≠i, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }
+   Finally, combine all this:
+   Return: C(body) ∪
+           C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪
+           (fv rhs₁) × S₁) ∪ ... ∪ (fv rhsₙ) × Sₙ)
+
+Using the result: Eta-Expansion
+-------------------------------
+
+We use the result of these two analyses to decide whether we can eta-expand the
+rhs of a let-bound variable.
+
+If the variable is already a function (exprIsCheap), and all calls to the
+variables have a higher arity than the current manifest arity (i.e. the number
+of lambdas), expand.
+
+If the variable is a thunk we must be careful: Eta-Expansion will prevent
+sharing of work, so this is only safe if there is at most one call to the
+function. Therefore, we check whether {v,v} ∈ G.
+
+    Example:
+
+        let n = case .. of .. -- A thunk!
+        in n 0 + n 1
+
+    vs.
+
+        let n = case .. of ..
+        in case .. of T -> n 0
+                      F -> n 1
+
+    We are only allowed to eta-expand `n` if it is going to be called at most
+    once in the body of the outer let. So we need to know, for each variable
+    individually, that it is going to be called at most once.
+
+
+Why the co-call graph?
+----------------------
+
+Why is it not sufficient to simply remember which variables are called once and
+which are called multiple times? It would be in the previous example, but consider
+
+        let n = case .. of ..
+        in case .. of
+            True -> let go = \y -> case .. of
+                                     True -> go (y + n 1)
+                                     False > n
+                    in go 1
+            False -> n
+
+vs.
+
+        let n = case .. of ..
+        in case .. of
+            True -> let go = \y -> case .. of
+                                     True -> go (y+1)
+                                     False > n
+                    in go 1
+            False -> n
+
+In both cases, the body and the rhs of the inner let call n at most once.
+But only in the second case that holds for the whole expression! The
+crucial difference is that in the first case, the rhs of `go` can call
+*both* `go` and `n`, and hence can call `n` multiple times as it recurses,
+while in the second case find out that `go` and `n` are not called together.
+
+
+Why co-call information for functions?
+--------------------------------------
+
+Although for eta-expansion we need the information only for thunks, we still
+need to know whether functions are being called once or multiple times, and
+together with what other functions.
+
+    Example:
+
+        let n = case .. of ..
+            f x = n (x+1)
+        in f 1 + f 2
+
+    vs.
+
+        let n = case .. of ..
+            f x = n (x+1)
+        in case .. of T -> f 0
+                      F -> f 1
+
+    Here, the body of f calls n exactly once, but f itself is being called
+    multiple times, so eta-expansion is not allowed.
+
+
+Note [Analysis type signature]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The work-hourse of the analysis is the function `callArityAnal`, with the
+following type:
+
+    type CallArityRes = (UnVarGraph, VarEnv Arity)
+    callArityAnal ::
+        Arity ->  -- The arity this expression is called with
+        VarSet -> -- The set of interesting variables
+        CoreExpr ->  -- The expression to analyse
+        (CallArityRes, CoreExpr)
+
+and the following specification:
+
+  ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr
+
+                            <=>
+
+  Assume the expression `expr` is being passed `arity` arguments. Then it holds that
+    * The domain of `callArityEnv` is a subset of `interestingIds`.
+    * Any variable from `interestingIds` that is not mentioned in the `callArityEnv`
+      is absent, i.e. not called at all.
+    * Every call from `expr` to a variable bound to n in `callArityEnv` has at
+      least n value arguments.
+    * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`,
+      then in no execution of `expr` both are being called.
+  Furthermore, expr' is expr with the callArity field of the `IdInfo` updated.
+
+
+Note [Which variables are interesting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The analysis would quickly become prohibitive expensive if we would analyse all
+variables; for most variables we simply do not care about how often they are
+called, i.e. variables bound in a pattern match. So interesting are variables that are
+ * top-level or let bound
+ * and possibly functions (typeArity > 0)
+
+Note [Taking boring variables into account]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+If we decide that the variable bound in `let x = e1 in e2` is not interesting,
+the analysis of `e2` will not report anything about `x`. To ensure that
+`callArityBind` does still do the right thing we have to take that into account
+everytime we would be lookup up `x` in the analysis result of `e2`.
+  * Instead of calling lookupCallArityRes, we return (0, True), indicating
+    that this variable might be called many times with no arguments.
+  * Instead of checking `calledWith x`, we assume that everything can be called
+    with it.
+  * In the recursive case, when calclulating the `cross_calls`, if there is
+    any boring variable in the recursive group, we ignore all co-call-results
+    and directly go to a very conservative assumption.
+
+The last point has the nice side effect that the relatively expensive
+integration of co-call results in a recursive groups is often skipped. This
+helped to avoid the compile time blowup in some real-world code with large
+recursive groups (#10293).
+
+Note [Recursion and fixpointing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For a mutually recursive let, we begin by
+ 1. analysing the body, using the same incoming arity as for the whole expression.
+ 2. Then we iterate, memoizing for each of the bound variables the last
+    analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes.
+ 3. We combine the analysis result from the body and the memoized results for
+    the arguments (if already present).
+ 4. For each variable, we find out the incoming arity and whether it is called
+    once, based on the current analysis result. If this differs from the
+    memoized results, we re-analyse the rhs and update the memoized table.
+ 5. If nothing had to be reanalyzed, we are done.
+    Otherwise, repeat from step 3.
+
+
+Note [Thunks in recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We never eta-expand a thunk in a recursive group, on the grounds that if it is
+part of a recursive group, then it will be called multiple times.
+
+This is not necessarily true, e.g.  it would be safe to eta-expand t2 (but not
+t1) in the following code:
+
+  let go x = t1
+      t1 = if ... then t2 else ...
+      t2 = if ... then go 1 else ...
+  in go 0
+
+Detecting this would require finding out what variables are only ever called
+from thunks. While this is certainly possible, we yet have to see this to be
+relevant in the wild.
+
+
+Note [Analysing top-level binds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We can eta-expand top-level-binds if they are not exported, as we see all calls
+to them. The plan is as follows: Treat the top-level binds as nested lets around
+a body representing “all external calls”, which returns a pessimistic
+CallArityRes (the co-call graph is the complete graph, all arityies 0).
+
+Note [Trimming arity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In the Call Arity papers, we are working on an untyped lambda calculus with no
+other id annotations, where eta-expansion is always possible. But this is not
+the case for Core!
+ 1. We need to ensure the invariant
+      callArity e <= typeArity (exprType e)
+    for the same reasons that exprArity needs this invariant (see Note
+    [exprArity invariant] in CoreArity).
+
+    If we are not doing that, a too-high arity annotation will be stored with
+    the id, confusing the simplifier later on.
+
+ 2. Eta-expanding a right hand side might invalidate existing annotations. In
+    particular, if an id has a strictness annotation of <...><...>b, then
+    passing two arguments to it will definitely bottom out, so the simplifier
+    will throw away additional parameters. This conflicts with Call Arity! So
+    we ensure that we never eta-expand such a value beyond the number of
+    arguments mentioned in the strictness signature.
+    See #10176 for a real-world-example.
+
+Note [What is a thunk]
+~~~~~~~~~~~~~~~~~~~~~~
+
+Originally, everything that is not in WHNF (`exprIsWHNF`) is considered a
+thunk, not eta-expanded, to avoid losing any sharing. This is also how the
+published papers on Call Arity describe it.
+
+In practice, there are thunks that do a just little work, such as
+pattern-matching on a variable, and the benefits of eta-expansion likely
+outweigh the cost of doing that repeatedly. Therefore, this implementation of
+Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk.
+
+Note [Call Arity and Join Points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The Call Arity analysis does not care about join points, and treats them just
+like normal functions. This is ok.
+
+The analysis *could* make use of the fact that join points are always evaluated
+in the same context as the join-binding they are defined in and are always
+one-shot, and handle join points separately, as suggested in
+https://ghc.haskell.org/trac/ghc/ticket/13479#comment:10.
+This *might* be more efficient (for example, join points would not have to be
+considered interesting variables), but it would also add redundant code. So for
+now we do not do that.
+
+The simplifier never eta-expands join points (it instead pushes extra arguments from
+an eta-expanded context into the join point’s RHS), so the call arity
+annotation on join points is not actually used. As it would be equally valid
+(though less efficient) to eta-expand join points, this is the simplifier's
+choice, and hence Call Arity sets the call arity for join points as well.
+-}
+
+-- Main entry point
+
+callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram
+callArityAnalProgram _dflags binds = binds'
+  where
+    (_, binds') = callArityTopLvl [] emptyVarSet binds
+
+-- See Note [Analysing top-level-binds]
+callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind])
+callArityTopLvl exported _ []
+    = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported])
+      , [] )
+callArityTopLvl exported int1 (b:bs)
+    = (ae2, b':bs')
+  where
+    int2 = bindersOf b
+    exported' = filter isExportedId int2 ++ exported
+    int' = int1 `addInterestingBinds` b
+    (ae1, bs') = callArityTopLvl exported' int' bs
+    (ae2, b')  = callArityBind (boringBinds b) ae1 int1 b
+
+
+callArityRHS :: CoreExpr -> CoreExpr
+callArityRHS = snd . callArityAnal 0 emptyVarSet
+
+-- The main analysis function. See Note [Analysis type signature]
+callArityAnal ::
+    Arity ->  -- The arity this expression is called with
+    VarSet -> -- The set of interesting variables
+    CoreExpr ->  -- The expression to analyse
+    (CallArityRes, CoreExpr)
+        -- How this expression uses its interesting variables
+        -- and the expression with IdInfo updated
+
+-- The trivial base cases
+callArityAnal _     _   e@(Lit _)
+    = (emptyArityRes, e)
+callArityAnal _     _   e@(Type _)
+    = (emptyArityRes, e)
+callArityAnal _     _   e@(Coercion _)
+    = (emptyArityRes, e)
+-- The transparent cases
+callArityAnal arity int (Tick t e)
+    = second (Tick t) $ callArityAnal arity int e
+callArityAnal arity int (Cast e co)
+    = second (\e -> Cast e co) $ callArityAnal arity int e
+
+-- The interesting case: Variables, Lambdas, Lets, Applications, Cases
+callArityAnal arity int e@(Var v)
+    | v `elemVarSet` int
+    = (unitArityRes v arity, e)
+    | otherwise
+    = (emptyArityRes, e)
+
+-- Non-value lambdas are ignored
+callArityAnal arity int (Lam v e) | not (isId v)
+    = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e
+
+-- We have a lambda that may be called multiple times, so its free variables
+-- can all be co-called.
+callArityAnal 0     int (Lam v e)
+    = (ae', Lam v e')
+  where
+    (ae, e') = callArityAnal 0 (int `delVarSet` v) e
+    ae' = calledMultipleTimes ae
+-- We have a lambda that we are calling. decrease arity.
+callArityAnal arity int (Lam v e)
+    = (ae, Lam v e')
+  where
+    (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e
+
+-- Application. Increase arity for the called expression, nothing to know about
+-- the second
+callArityAnal arity int (App e (Type t))
+    = second (\e -> App e (Type t)) $ callArityAnal arity int e
+callArityAnal arity int (App e1 e2)
+    = (final_ae, App e1' e2')
+  where
+    (ae1, e1') = callArityAnal (arity + 1) int e1
+    (ae2, e2') = callArityAnal 0           int e2
+    -- If the argument is trivial (e.g. a variable), then it will _not_ be
+    -- let-bound in the Core to STG transformation (CorePrep actually),
+    -- so no sharing will happen here, and we have to assume many calls.
+    ae2' | exprIsTrivial e2 = calledMultipleTimes ae2
+         | otherwise        = ae2
+    final_ae = ae1 `both` ae2'
+
+-- Case expression.
+callArityAnal arity int (Case scrut bndr ty alts)
+    = -- pprTrace "callArityAnal:Case"
+      --          (vcat [ppr scrut, ppr final_ae])
+      (final_ae, Case scrut' bndr ty alts')
+  where
+    (alt_aes, alts') = unzip $ map go alts
+    go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e
+                        in  (ae, (dc, bndrs, e'))
+    alt_ae = lubRess alt_aes
+    (scrut_ae, scrut') = callArityAnal 0 int scrut
+    final_ae = scrut_ae `both` alt_ae
+
+-- For lets, use callArityBind
+callArityAnal arity int (Let bind e)
+  = -- pprTrace "callArityAnal:Let"
+    --          (vcat [ppr v, ppr arity, ppr n, ppr final_ae ])
+    (final_ae, Let bind' e')
+  where
+    int_body = int `addInterestingBinds` bind
+    (ae_body, e') = callArityAnal arity int_body e
+    (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind
+
+-- Which bindings should we look at?
+-- See Note [Which variables are interesting]
+isInteresting :: Var -> Bool
+isInteresting v = not $ null (typeArity (idType v))
+
+interestingBinds :: CoreBind -> [Var]
+interestingBinds = filter isInteresting . bindersOf
+
+boringBinds :: CoreBind -> VarSet
+boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf
+
+addInterestingBinds :: VarSet -> CoreBind -> VarSet
+addInterestingBinds int bind
+    = int `delVarSetList`    bindersOf bind -- Possible shadowing
+          `extendVarSetList` interestingBinds bind
+
+-- Used for both local and top-level binds
+-- Second argument is the demand from the body
+callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)
+-- Non-recursive let
+callArityBind boring_vars ae_body int (NonRec v rhs)
+  | otherwise
+  = -- pprTrace "callArityBind:NonRec"
+    --          (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity])
+    (final_ae, NonRec v' rhs')
+  where
+    is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]
+    -- If v is boring, we will not find it in ae_body, but always assume (0, False)
+    boring = v `elemVarSet` boring_vars
+
+    (arity, called_once)
+        | boring    = (0, False) -- See Note [Taking boring variables into account]
+        | otherwise = lookupCallArityRes ae_body v
+    safe_arity | called_once = arity
+               | is_thunk    = 0      -- A thunk! Do not eta-expand
+               | otherwise   = arity
+
+    -- See Note [Trimming arity]
+    trimmed_arity = trimArity v safe_arity
+
+    (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs
+
+
+    ae_rhs'| called_once     = ae_rhs
+           | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once
+           | otherwise       = calledMultipleTimes ae_rhs
+
+    called_by_v = domRes ae_rhs'
+    called_with_v
+        | boring    = domRes ae_body
+        | otherwise = calledWith ae_body v `delUnVarSet` v
+    final_ae = addCrossCoCalls called_by_v called_with_v $ ae_rhs' `lubRes` resDel v ae_body
+
+    v' = v `setIdCallArity` trimmed_arity
+
+
+-- Recursive let. See Note [Recursion and fixpointing]
+callArityBind boring_vars ae_body int b@(Rec binds)
+  = -- (if length binds > 300 then
+    -- pprTrace "callArityBind:Rec"
+    --           (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $
+    (final_ae, Rec binds')
+  where
+    -- See Note [Taking boring variables into account]
+    any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds]
+
+    int_body = int `addInterestingBinds` b
+    (ae_rhs, binds') = fix initial_binds
+    final_ae = bindersOf b `resDelList` ae_rhs
+
+    initial_binds = [(i,Nothing,e) | (i,e) <- binds]
+
+    fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)])
+    fix ann_binds
+        | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $
+          any_change
+        = fix ann_binds'
+        | otherwise
+        = (ae, map (\(i, _, e) -> (i, e)) ann_binds')
+      where
+        aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ]
+        ae = callArityRecEnv any_boring aes_old ae_body
+
+        rerun (i, mbLastRun, rhs)
+            | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae)
+            -- No call to this yet, so do nothing
+            = (False, (i, Nothing, rhs))
+
+            | Just (old_called_once, old_arity, _) <- mbLastRun
+            , called_once == old_called_once
+            , new_arity == old_arity
+            -- No change, no need to re-analyze
+            = (False, (i, mbLastRun, rhs))
+
+            | otherwise
+            -- We previously analyzed this with a different arity (or not at all)
+            = let is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]
+
+                  safe_arity | is_thunk    = 0  -- See Note [Thunks in recursive groups]
+                             | otherwise   = new_arity
+
+                  -- See Note [Trimming arity]
+                  trimmed_arity = trimArity i safe_arity
+
+                  (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs
+
+                  ae_rhs' | called_once     = ae_rhs
+                          | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once
+                          | otherwise       = calledMultipleTimes ae_rhs
+
+                  i' = i `setIdCallArity` trimmed_arity
+
+              in (True, (i', Just (called_once, new_arity, ae_rhs'), rhs'))
+          where
+            -- See Note [Taking boring variables into account]
+            (new_arity, called_once) | i `elemVarSet` boring_vars = (0, False)
+                                     | otherwise                  = lookupCallArityRes ae i
+
+        (changes, ann_binds') = unzip $ map rerun ann_binds
+        any_change = or changes
+
+-- Combining the results from body and rhs, (mutually) recursive case
+-- See Note [Analysis II: The Co-Called analysis]
+callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes
+callArityRecEnv any_boring ae_rhss ae_body
+    = -- (if length ae_rhss > 300 then pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new]) else id) $
+      ae_new
+  where
+    vars = map fst ae_rhss
+
+    ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body
+
+    cross_calls
+        -- See Note [Taking boring variables into account]
+        | any_boring               = completeGraph (domRes ae_combined)
+        -- Also, calculating cross_calls is expensive. Simply be conservative
+        -- if the mutually recursive group becomes too large.
+        | lengthExceeds ae_rhss 25 = completeGraph (domRes ae_combined)
+        | otherwise                = unionUnVarGraphs $ map cross_call ae_rhss
+    cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v
+      where
+        is_thunk = idCallArity v == 0
+        -- What rhs are relevant as happening before (or after) calling v?
+        --    If v is a thunk, everything from all the _other_ variables
+        --    If v is not a thunk, everything can happen.
+        ae_before_v | is_thunk  = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body
+                    | otherwise = ae_combined
+        -- What do we want to know from these?
+        -- Which calls can happen next to any recursive call.
+        called_with_v
+            = unionUnVarSets $ map (calledWith ae_before_v) vars
+        called_by_v = domRes ae_rhs
+
+    ae_new = first (cross_calls `unionUnVarGraph`) ae_combined
+
+-- See Note [Trimming arity]
+trimArity :: Id -> Arity -> Arity
+trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig]
+  where
+    max_arity_by_type = length (typeArity (idType v))
+    max_arity_by_strsig
+        | isBotRes result_info = length demands
+        | otherwise = a
+
+    (demands, result_info) = splitStrictSig (idStrictness v)
+
+---------------------------------------
+-- Functions related to CallArityRes --
+---------------------------------------
+
+-- Result type for the two analyses.
+-- See Note [Analysis I: The arity analysis]
+-- and Note [Analysis II: The Co-Called analysis]
+type CallArityRes = (UnVarGraph, VarEnv Arity)
+
+emptyArityRes :: CallArityRes
+emptyArityRes = (emptyUnVarGraph, emptyVarEnv)
+
+unitArityRes :: Var -> Arity -> CallArityRes
+unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity)
+
+resDelList :: [Var] -> CallArityRes -> CallArityRes
+resDelList vs ae = foldr resDel ae vs
+
+resDel :: Var -> CallArityRes -> CallArityRes
+resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v)
+
+domRes :: CallArityRes -> UnVarSet
+domRes (_, ae) = varEnvDom ae
+
+-- In the result, find out the minimum arity and whether the variable is called
+-- at most once.
+lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool)
+lookupCallArityRes (g, ae) v
+    = case lookupVarEnv ae v of
+        Just a -> (a, not (g `hasLoopAt` v))
+        Nothing -> (0, False)
+
+calledWith :: CallArityRes -> Var -> UnVarSet
+calledWith (g, _) v = neighbors g v
+
+addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes
+addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`)
+
+-- Replaces the co-call graph by a complete graph (i.e. no information)
+calledMultipleTimes :: CallArityRes -> CallArityRes
+calledMultipleTimes res = first (const (completeGraph (domRes res))) res
+
+-- Used for application and cases
+both :: CallArityRes -> CallArityRes -> CallArityRes
+both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2
+
+-- Used when combining results from alternative cases; take the minimum
+lubRes :: CallArityRes -> CallArityRes -> CallArityRes
+lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2)
+
+lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity
+lubArityEnv = plusVarEnv_C min
+
+lubRess :: [CallArityRes] -> CallArityRes
+lubRess = foldl' lubRes emptyArityRes
diff --git a/compiler/simplCore/Exitify.hs b/compiler/simplCore/Exitify.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/Exitify.hs
@@ -0,0 +1,499 @@
+module Exitify ( exitifyProgram ) where
+
+{-
+Note [Exitification]
+~~~~~~~~~~~~~~~~~~~~
+
+This module implements Exitification. The goal is to pull as much code out of
+recursive functions as possible, as the simplifier is better at inlining into
+call-sites that are not in recursive functions.
+
+Example:
+
+  let t = foo bar
+  joinrec go 0     x y = t (x*x)
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+We’d like to inline `t`, but that does not happen: Because t is a thunk and is
+used in a recursive function, doing so might lose sharing in general. In
+this case, however, `t` is on the _exit path_ of `go`, so called at most once.
+How do we make this clearly visible to the simplifier?
+
+A code path (i.e., an expression in a tail-recursive position) in a recursive
+function is an exit path if it does not contain a recursive call. We can bind
+this expression outside the recursive function, as a join-point.
+
+Example result:
+
+  let t = foo bar
+  join exit x = t (x*x)
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+Now `t` is no longer in a recursive function, and good things happen!
+-}
+
+import GhcPrelude
+import Var
+import Id
+import IdInfo
+import CoreSyn
+import CoreUtils
+import State
+import Unique
+import VarSet
+import VarEnv
+import CoreFVs
+import FastString
+import Type
+import Util( mapSnd )
+
+import Data.Bifunctor
+import Control.Monad
+
+-- | Traverses the AST, simply to find all joinrecs and call 'exitify' on them.
+-- The really interesting function is exitifyRec
+exitifyProgram :: CoreProgram -> CoreProgram
+exitifyProgram binds = map goTopLvl binds
+  where
+    goTopLvl (NonRec v e) = NonRec v (go in_scope_toplvl e)
+    goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs)
+      -- Top-level bindings are never join points
+
+    in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds
+
+    go :: InScopeSet -> CoreExpr -> CoreExpr
+    go _    e@(Var{})       = e
+    go _    e@(Lit {})      = e
+    go _    e@(Type {})     = e
+    go _    e@(Coercion {}) = e
+    go in_scope (Cast e' c) = Cast (go in_scope e') c
+    go in_scope (Tick t e') = Tick t (go in_scope e')
+    go in_scope (App e1 e2) = App (go in_scope e1) (go in_scope e2)
+
+    go in_scope (Lam v e')
+      = Lam v (go in_scope' e')
+      where in_scope' = in_scope `extendInScopeSet` v
+
+    go in_scope (Case scrut bndr ty alts)
+      = Case (go in_scope scrut) bndr ty (map go_alt alts)
+      where
+        in_scope1 = in_scope `extendInScopeSet` bndr
+        go_alt (dc, pats, rhs) = (dc, pats, go in_scope' rhs)
+           where in_scope' = in_scope1 `extendInScopeSetList` pats
+
+    go in_scope (Let (NonRec bndr rhs) body)
+      = Let (NonRec bndr (go in_scope rhs)) (go in_scope' body)
+      where
+        in_scope' = in_scope `extendInScopeSet` bndr
+
+    go in_scope (Let (Rec pairs) body)
+      | is_join_rec = mkLets (exitifyRec in_scope' pairs') body'
+      | otherwise   = Let (Rec pairs') body'
+      where
+        is_join_rec = any (isJoinId . fst) pairs
+        in_scope'   = in_scope `extendInScopeSetList` bindersOf (Rec pairs)
+        pairs'      = mapSnd (go in_scope') pairs
+        body'       = go in_scope' body
+
+
+-- | State Monad used inside `exitify`
+type ExitifyM =  State [(JoinId, CoreExpr)]
+
+-- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as
+--   join-points outside the joinrec.
+exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind]
+exitifyRec in_scope pairs
+  = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs']
+  where
+    -- We need the set of free variables of many subexpressions here, so
+    -- annotate the AST with them
+    -- see Note [Calculating free variables]
+    ann_pairs = map (second freeVars) pairs
+
+    -- Which are the recursive calls?
+    recursive_calls = mkVarSet $ map fst pairs
+
+    (pairs',exits) = (`runState` []) $ do
+        forM ann_pairs $ \(x,rhs) -> do
+            -- go past the lambdas of the join point
+            let (args, body) = collectNAnnBndrs (idJoinArity x) rhs
+            body' <- go args body
+            let rhs' = mkLams args body'
+            return (x, rhs')
+
+    ---------------------
+    -- 'go' is the main working function.
+    -- It goes through the RHS (tail-call positions only),
+    -- checks if there are no more recursive calls, if so, abstracts over
+    -- variables bound on the way and lifts it out as a join point.
+    --
+    -- ExitifyM is a state monad to keep track of floated binds
+    go :: [Var]           -- ^ Variables that are in-scope here, but
+                          -- not in scope at the joinrec; that is,
+                          -- we must potentially abstract over them.
+                          -- Invariant: they are kept in dependency order
+       -> CoreExprWithFVs -- ^ Current expression in tail position
+       -> ExitifyM CoreExpr
+
+    -- We first look at the expression (no matter what it shape is)
+    -- and determine if we can turn it into a exit join point
+    go captured ann_e
+        | -- An exit expression has no recursive calls
+          let fvs = dVarSetToVarSet (freeVarsOf ann_e)
+        , disjointVarSet fvs recursive_calls
+        = go_exit captured (deAnnotate ann_e) fvs
+
+    -- We could not turn it into a exit joint point. So now recurse
+    -- into all expression where eligible exit join points might sit,
+    -- i.e. into all tail-call positions:
+
+    -- Case right hand sides are in tail-call position
+    go captured (_, AnnCase scrut bndr ty alts) = do
+        alts' <- forM alts $ \(dc, pats, rhs) -> do
+            rhs' <- go (captured ++ [bndr] ++ pats) rhs
+            return (dc, pats, rhs')
+        return $ Case (deAnnotate scrut) bndr ty alts'
+
+    go captured (_, AnnLet ann_bind body)
+        -- join point, RHS and body are in tail-call position
+        | AnnNonRec j rhs <- ann_bind
+        , Just join_arity <- isJoinId_maybe j
+        = do let (params, join_body) = collectNAnnBndrs join_arity rhs
+             join_body' <- go (captured ++ params) join_body
+             let rhs' = mkLams params join_body'
+             body' <- go (captured ++ [j]) body
+             return $ Let (NonRec j rhs') body'
+
+        -- rec join point, RHSs and body are in tail-call position
+        | AnnRec pairs <- ann_bind
+        , isJoinId (fst (head pairs))
+        = do let js = map fst pairs
+             pairs' <- forM pairs $ \(j,rhs) -> do
+                 let join_arity = idJoinArity j
+                     (params, join_body) = collectNAnnBndrs join_arity rhs
+                 join_body' <- go (captured ++ js ++ params) join_body
+                 let rhs' = mkLams params join_body'
+                 return (j, rhs')
+             body' <- go (captured ++ js) body
+             return $ Let (Rec pairs') body'
+
+        -- normal Let, only the body is in tail-call position
+        | otherwise
+        = do body' <- go (captured ++ bindersOf bind ) body
+             return $ Let bind body'
+      where bind = deAnnBind ann_bind
+
+    -- Cannot be turned into an exit join point, but also has no
+    -- tail-call subexpression. Nothing to do here.
+    go _ ann_e = return (deAnnotate ann_e)
+
+    ---------------------
+    go_exit :: [Var]      -- Variables captured locally
+            -> CoreExpr   -- An exit expression
+            -> VarSet     -- Free vars of the expression
+            -> ExitifyM CoreExpr
+    -- go_exit deals with a tail expression that is floatable
+    -- out as an exit point; that is, it mentions no recursive calls
+    go_exit captured e fvs
+      -- Do not touch an expression that is already a join jump where all arguments
+      -- are captured variables. See Note [Idempotency]
+      -- But _do_ float join jumps with interesting arguments.
+      -- See Note [Jumps can be interesting]
+      | (Var f, args) <- collectArgs e
+      , isJoinId f
+      , all isCapturedVarArg args
+      = return e
+
+      -- Do not touch a boring expression (see Note [Interesting expression])
+      | not is_interesting
+      = return e
+
+      -- Cannot float out if local join points are used, as
+      -- we cannot abstract over them
+      | captures_join_points
+      = return e
+
+      -- We have something to float out!
+      | otherwise
+      = do { -- Assemble the RHS of the exit join point
+             let rhs   = mkLams abs_vars e
+                 avoid = in_scope `extendInScopeSetList` captured
+             -- Remember this binding under a suitable name
+           ; v <- addExit avoid (length abs_vars) rhs
+             -- And jump to it from here
+           ; return $ mkVarApps (Var v) abs_vars }
+
+      where
+        -- Used to detect exit expressoins that are already proper exit jumps
+        isCapturedVarArg (Var v) = v `elem` captured
+        isCapturedVarArg _ = False
+
+        -- An interesting exit expression has free, non-imported
+        -- variables from outside the recursive group
+        -- See Note [Interesting expression]
+        is_interesting = anyVarSet isLocalId $
+                         fvs `minusVarSet` mkVarSet captured
+
+        -- The arguments of this exit join point
+        -- See Note [Picking arguments to abstract over]
+        abs_vars = snd $ foldr pick (fvs, []) captured
+          where
+            pick v (fvs', acc) | v `elemVarSet` fvs' = (fvs' `delVarSet` v, zap v : acc)
+                               | otherwise           = (fvs',               acc)
+
+        -- We are going to abstract over these variables, so we must
+        -- zap any IdInfo they have; see Trac #15005
+        -- cf. SetLevels.abstractVars
+        zap v | isId v = setIdInfo v vanillaIdInfo
+              | otherwise = v
+
+        -- We cannot abstract over join points
+        captures_join_points = any isJoinId abs_vars
+
+
+-- Picks a new unique, which is disjoint from
+--  * the free variables of the whole joinrec
+--  * any bound variables (captured)
+--  * any exit join points created so far.
+mkExitJoinId :: InScopeSet -> Type -> JoinArity -> ExitifyM JoinId
+mkExitJoinId in_scope ty join_arity = do
+    fs <- get
+    let avoid = in_scope `extendInScopeSetList` (map fst fs)
+                         `extendInScopeSet` exit_id_tmpl -- just cosmetics
+    return (uniqAway avoid exit_id_tmpl)
+  where
+    exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ty
+                    `asJoinId` join_arity
+
+addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId
+addExit in_scope join_arity rhs = do
+    -- Pick a suitable name
+    let ty = exprType rhs
+    v <- mkExitJoinId in_scope ty join_arity
+    fs <- get
+    put ((v,rhs):fs)
+    return v
+
+{-
+Note [Interesting expression]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not want this to happen:
+
+  joinrec go 0     x y = x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+==>
+  join exit x = x
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+because the floated exit path (`x`) is simply a parameter of `go`; there are
+not useful interactions exposed this way.
+
+Neither do we want this to happen
+
+  joinrec go 0     x y = x+x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+==>
+  join exit x = x+x
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+where the floated expression `x+x` is a bit more complicated, but still not
+intersting.
+
+Expressions are interesting when they move an occurrence of a variable outside
+the recursive `go` that can benefit from being obviously called once, for example:
+ * a local thunk that can then be inlined (see example in note [Exitification])
+ * the parameter of a function, where the demand analyzer then can then
+   see that it is called at most once, and hence improve the function’s
+   strictness signature
+
+So we only hoist an exit expression out if it mentiones at least one free,
+non-imported variable.
+
+Note [Jumps can be interesting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A jump to a join point can be interesting, if its arguments contain free
+non-exported variables (z in the following example):
+
+  joinrec go 0     x y = jump j (x+z)
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+==>
+  join exit x y = jump j (x+z)
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+
+
+The join point itself can be interesting, even if none if its
+arguments have free variables free in the joinrec.  For example
+
+  join j p = case p of (x,y) -> x+y
+  joinrec go 0     x y = jump j (x,y)
+          go (n-1) x y = jump go (n-1) (x+y) y
+  in …
+
+Here, `j` would not be inlined because we do not inline something that looks
+like an exit join point (see Note [Do not inline exit join points]). But
+if we exitify the 'jump j (x,y)' we get
+
+  join j p = case p of (x,y) -> x+y
+  join exit x y = jump j (x,y)
+  joinrec go 0     x y = jump exit x y
+          go (n-1) x y = jump go (n-1) (x+y) y
+  in …
+
+and now 'j' can inline, and we get rid of the pair. Here's another
+example (assume `g` to be an imported function that, on its own,
+does not make this interesting):
+
+  join j y = map f y
+  joinrec go 0     x y = jump j (map g x)
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+Again, `j` would not be inlined because we do not inline something that looks
+like an exit join point (see Note [Do not inline exit join points]).
+
+But after exitification we have
+
+  join j y = map f y
+  join exit x = jump j (map g x)
+  joinrec go 0     x y = jump j (map g x)
+              go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+and now we can inline `j` and this will allow `map/map` to fire.
+
+
+Note [Idempotency]
+~~~~~~~~~~~~~~~~~~
+
+We do not want this to happen, where we replace the floated expression with
+essentially the same expression:
+
+  join exit x = t (x*x)
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+==>
+  join exit x = t (x*x)
+  join exit' x = jump exit x
+  joinrec go 0     x y = jump exit' x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+So when the RHS is a join jump, and all of its arguments are captured variables,
+then we leave it in place.
+
+Note that `jump exit x` in this example looks interesting, as `exit` is a free
+variable. Therefore, idempotency does not simply follow from floating only
+interesting expressions.
+
+Note [Calculating free variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have two options where to annotate the tree with free variables:
+
+ A) The whole tree.
+ B) Each individual joinrec as we come across it.
+
+Downside of A: We pay the price on the whole module, even outside any joinrecs.
+Downside of B: We pay the price per joinrec, possibly multiple times when
+joinrecs are nested.
+
+Further downside of A: If the exitify function returns annotated expressions,
+it would have to ensure that the annotations are correct.
+
+We therefore choose B, and calculate the free variables in `exitify`.
+
+
+Note [Do not inline exit join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we have
+
+  let t = foo bar
+  join exit x = t (x*x)
+  joinrec go 0     x y = jump exit x
+          go (n-1) x y = jump go (n-1) (x+y)
+  in …
+
+we do not want the simplifier to simply inline `exit` back in (which it happily
+would).
+
+To prevent this, we need to recognize exit join points, and then disable
+inlining.
+
+Exit join points, recognizeable using `isExitJoinId` are join points with an
+occurence in a recursive group, and can be recognized (after the occurence
+analyzer ran!) using `isExitJoinId`.
+This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`,
+because the lambdas of a non-recursive join point are not considered for
+`occ_in_lam`.  For example, in the following code, `j1` is /not/ marked
+occ_in_lam, because `j2` is called only once.
+
+  join j1 x = x+1
+  join j2 y = join j1 (y+2)
+
+To prevent inlining, we check for isExitJoinId
+* In `preInlineUnconditionally` directly.
+* In `simplLetUnfolding` we simply give exit join points no unfolding, which
+  prevents inlining in `postInlineUnconditionally` and call sites.
+
+Note [Placement of the exitification pass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+I (Joachim) experimented with multiple positions for the Exitification pass in
+the Core2Core pipeline:
+
+ A) Before the `simpl_phases`
+ B) Between the `simpl_phases` and the "main" simplifier pass
+ C) After demand_analyser
+ D) Before the final simplification phase
+
+Here is the table (this is without inlining join exit points in the final
+simplifier run):
+
+        Program |                       Allocs                      |                      Instrs
+                | ABCD.log     A.log     B.log     C.log     D.log  | ABCD.log     A.log     B.log     C.log     D.log
+----------------|---------------------------------------------------|-------------------------------------------------
+ fannkuch-redux |   -99.9%     +0.0%    -99.9%    -99.9%    -99.9%  |    -3.9%     +0.5%     -3.0%     -3.9%     -3.9%
+          fasta |    -0.0%     +0.0%     +0.0%     -0.0%     -0.0%  |    -8.5%     +0.0%     +0.0%     -0.0%     -8.5%
+            fem |     0.0%      0.0%      0.0%      0.0%     +0.0%  |    -2.2%     -0.1%     -0.1%     -2.1%     -2.1%
+           fish |     0.0%      0.0%      0.0%      0.0%     +0.0%  |    -3.1%     +0.0%     -1.1%     -1.1%     -0.0%
+   k-nucleotide |   -91.3%    -91.0%    -91.0%    -91.3%    -91.3%  |    -6.3%    +11.4%    +11.4%     -6.3%     -6.2%
+            scs |    -0.0%     -0.0%     -0.0%     -0.0%     -0.0%  |    -3.4%     -3.0%     -3.1%     -3.3%     -3.3%
+         simple |    -6.0%      0.0%     -6.0%     -6.0%     +0.0%  |    -3.4%     +0.0%     -5.2%     -3.4%     -0.1%
+  spectral-norm |    -0.0%      0.0%      0.0%     -0.0%     +0.0%  |    -2.7%     +0.0%     -2.7%     -5.4%     -5.4%
+----------------|---------------------------------------------------|-------------------------------------------------
+            Min |   -95.0%    -91.0%    -95.0%    -95.0%    -95.0%  |    -8.5%     -3.0%     -5.2%     -6.3%     -8.5%
+            Max |    +0.2%     +0.2%     +0.2%     +0.2%     +1.5%  |    +0.4%    +11.4%    +11.4%     +0.4%     +1.5%
+ Geometric Mean |    -4.7%     -2.1%     -4.7%     -4.7%     -4.6%  |    -0.4%     +0.1%     -0.1%     -0.3%     -0.2%
+
+Position A is disqualified, as it does not get rid of the allocations in
+fannkuch-redux.
+Position A and B are disqualified because it increases instructions in k-nucleotide.
+Positions C and D have their advantages: C decreases allocations in simpl, but D instructions in fasta.
+
+Assuming we have a budget of _one_ run of Exitification, then C wins (but we
+could get more from running it multiple times, as seen in fish).
+
+Note [Picking arguments to abstract over]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When we create an exit join point, so we need to abstract over those of its
+free variables that are be out-of-scope at the destination of the exit join
+point. So we go through the list `captured` and pick those that are actually
+free variables of the join point.
+
+We do not just `filter (`elemVarSet` fvs) captured`, as there might be
+shadowing, and `captured` may contain multiple variables with the same Unique. I
+these cases we want to abstract only over the last occurence, hence the `foldr`
+(with emphasis on the `r`). This is #15110.
+
+-}
diff --git a/compiler/simplCore/FloatIn.hs b/compiler/simplCore/FloatIn.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/FloatIn.hs
@@ -0,0 +1,771 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+************************************************************************
+*                                                                      *
+\section[FloatIn]{Floating Inwards pass}
+*                                                                      *
+************************************************************************
+
+The main purpose of @floatInwards@ is floating into branches of a
+case, so that we don't allocate things, save them on the stack, and
+then discover that they aren't needed in the chosen branch.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fprof-auto #-}
+
+module FloatIn ( floatInwards ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSyn
+import MkCore
+import HscTypes         ( ModGuts(..) )
+import CoreUtils
+import CoreFVs
+import CoreMonad        ( CoreM )
+import Id               ( isOneShotBndr, idType, isJoinId, isJoinId_maybe )
+import Var
+import Type
+import VarSet
+import Util
+import DynFlags
+import Outputable
+-- import Data.List        ( mapAccumL )
+import BasicTypes       ( RecFlag(..), isRec )
+
+{-
+Top-level interface function, @floatInwards@.  Note that we do not
+actually float any bindings downwards from the top-level.
+-}
+
+floatInwards :: ModGuts -> CoreM ModGuts
+floatInwards pgm@(ModGuts { mg_binds = binds })
+  = do { dflags <- getDynFlags
+       ; return (pgm { mg_binds = map (fi_top_bind dflags) binds }) }
+  where
+    fi_top_bind dflags (NonRec binder rhs)
+      = NonRec binder (fiExpr dflags [] (freeVars rhs))
+    fi_top_bind dflags (Rec pairs)
+      = Rec [ (b, fiExpr dflags [] (freeVars rhs)) | (b, rhs) <- pairs ]
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Mail from Andr\'e [edited]}
+*                                                                      *
+************************************************************************
+
+{\em Will wrote: What??? I thought the idea was to float as far
+inwards as possible, no matter what.  This is dropping all bindings
+every time it sees a lambda of any kind.  Help! }
+
+You are assuming we DO DO full laziness AFTER floating inwards!  We
+have to [not float inside lambdas] if we don't.
+
+If we indeed do full laziness after the floating inwards (we could
+check the compilation flags for that) then I agree we could be more
+aggressive and do float inwards past lambdas.
+
+Actually we are not doing a proper full laziness (see below), which
+was another reason for not floating inwards past a lambda.
+
+This can easily be fixed.  The problem is that we float lets outwards,
+but there are a few expressions which are not let bound, like case
+scrutinees and case alternatives.  After floating inwards the
+simplifier could decide to inline the let and the laziness would be
+lost, e.g.
+
+\begin{verbatim}
+let a = expensive             ==> \b -> case expensive of ...
+in \ b -> case a of ...
+\end{verbatim}
+The fix is
+\begin{enumerate}
+\item
+to let bind the algebraic case scrutinees (done, I think) and
+the case alternatives (except the ones with an
+unboxed type)(not done, I think). This is best done in the
+SetLevels.hs module, which tags things with their level numbers.
+\item
+do the full laziness pass (floating lets outwards).
+\item
+simplify. The simplifier inlines the (trivial) lets that were
+ created but were not floated outwards.
+\end{enumerate}
+
+With the fix I think Will's suggestion that we can gain even more from
+strictness by floating inwards past lambdas makes sense.
+
+We still gain even without going past lambdas, as things may be
+strict in the (new) context of a branch (where it was floated to) or
+of a let rhs, e.g.
+\begin{verbatim}
+let a = something            case x of
+in case x of                   alt1 -> case something of a -> a + a
+     alt1 -> a + a      ==>    alt2 -> b
+     alt2 -> b
+
+let a = something           let b = case something of a -> a + a
+in let b = a + a        ==> in (b,b)
+in (b,b)
+\end{verbatim}
+Also, even if a is not found to be strict in the new context and is
+still left as a let, if the branch is not taken (or b is not entered)
+the closure for a is not built.
+
+************************************************************************
+*                                                                      *
+\subsection{Main floating-inwards code}
+*                                                                      *
+************************************************************************
+-}
+
+type FreeVarSet  = DIdSet
+type BoundVarSet = DIdSet
+
+data FloatInBind = FB BoundVarSet FreeVarSet FloatBind
+        -- The FreeVarSet is the free variables of the binding.  In the case
+        -- of recursive bindings, the set doesn't include the bound
+        -- variables.
+
+type FloatInBinds = [FloatInBind]
+        -- In reverse dependency order (innermost binder first)
+
+fiExpr :: DynFlags
+       -> FloatInBinds      -- Binds we're trying to drop
+                            -- as far "inwards" as possible
+       -> CoreExprWithFVs   -- Input expr
+       -> CoreExpr          -- Result
+
+fiExpr _ to_drop (_, AnnLit lit)     = wrapFloats to_drop (Lit lit)
+                                       -- See Note [Dead bindings]
+fiExpr _ to_drop (_, AnnType ty)     = ASSERT( null to_drop ) Type ty
+fiExpr _ to_drop (_, AnnVar v)       = wrapFloats to_drop (Var v)
+fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)
+fiExpr dflags to_drop (_, AnnCast expr (co_ann, co))
+  = wrapFloats (drop_here ++ co_drop) $
+    Cast (fiExpr dflags e_drop expr) co
+  where
+    [drop_here, e_drop, co_drop]
+      = sepBindsByDropPoint dflags False
+          [freeVarsOf expr, freeVarsOfAnn co_ann]
+          to_drop
+
+{-
+Applications: we do float inside applications, mainly because we
+need to get at all the arguments.  The next simplifier run will
+pull out any silly ones.
+-}
+
+fiExpr dflags to_drop ann_expr@(_,AnnApp {})
+  = wrapFloats drop_here $ wrapFloats extra_drop $
+    mkTicks ticks $
+    mkApps (fiExpr dflags fun_drop ann_fun)
+           (zipWith (fiExpr dflags) arg_drops ann_args)
+  where
+    (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr
+    fun_ty  = exprType (deAnnotate ann_fun)
+    fun_fvs = freeVarsOf ann_fun
+    arg_fvs = map freeVarsOf ann_args
+
+    (drop_here : extra_drop : fun_drop : arg_drops)
+       = sepBindsByDropPoint dflags False
+                             (extra_fvs : fun_fvs : arg_fvs)
+                             to_drop
+         -- Shortcut behaviour: if to_drop is empty,
+         -- sepBindsByDropPoint returns a suitable bunch of empty
+         -- lists without evaluating extra_fvs, and hence without
+         -- peering into each argument
+
+    (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args
+    extra_fvs0 = case ann_fun of
+                   (_, AnnVar _) -> fun_fvs
+                   _             -> emptyDVarSet
+          -- Don't float the binding for f into f x y z; see Note [Join points]
+          -- for why we *can't* do it when f is a join point. (If f isn't a
+          -- join point, floating it in isn't especially harmful but it's
+          -- useless since the simplifier will immediately float it back out.)
+
+    add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)
+    add_arg (fun_ty, extra_fvs) (_, AnnType ty)
+      = (piResultTy fun_ty ty, extra_fvs)
+
+    add_arg (fun_ty, extra_fvs) (arg_fvs, arg)
+      | noFloatIntoArg arg arg_ty
+      = (res_ty, extra_fvs `unionDVarSet` arg_fvs)
+      | otherwise
+      = (res_ty, extra_fvs)
+      where
+       (arg_ty, res_ty) = splitFunTy fun_ty
+
+{- Note [Dead bindings]
+~~~~~~~~~~~~~~~~~~~~~~~
+At a literal we won't usually have any floated bindings; the
+only way that can happen is if the binding wrapped the literal
+/in the original input program/.  e.g.
+   case x of { DEFAULT -> 1# }
+But, while this may be unusual it is not actually wrong, and it did
+once happen (Trac #15696).
+
+Note [Do not destroy the let/app invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Watch out for
+   f (x +# y)
+We don't want to float bindings into here
+   f (case ... of { x -> x +# y })
+because that might destroy the let/app invariant, which requires
+unlifted function arguments to be ok-for-speculation.
+
+Note [Join points]
+~~~~~~~~~~~~~~~~~~
+Generally, we don't need to worry about join points - there are places we're
+not allowed to float them, but since they can't have occurrences in those
+places, we're not tempted.
+
+We do need to be careful about jumps, however:
+
+  joinrec j x y z = ... in
+  jump j a b c
+
+Previous versions often floated the definition of a recursive function into its
+only non-recursive occurrence. But for a join point, this is a disaster:
+
+  (joinrec j x y z = ... in
+  jump j) a b c -- wrong!
+
+Every jump must be exact, so the jump to j must have three arguments. Hence
+we're careful not to float into the target of a jump (though we can float into
+the arguments just fine).
+
+Note [Floating in past a lambda group]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* We must be careful about floating inside a value lambda.
+  That risks losing laziness.
+  The float-out pass might rescue us, but then again it might not.
+
+* We must be careful about type lambdas too.  At one time we did, and
+  there is no risk of duplicating work thereby, but we do need to be
+  careful.  In particular, here is a bad case (it happened in the
+  cichelli benchmark:
+        let v = ...
+        in let f = /\t -> \a -> ...
+           ==>
+        let f = /\t -> let v = ... in \a -> ...
+  This is bad as now f is an updatable closure (update PAP)
+  and has arity 0.
+
+* Hack alert!  We only float in through one-shot lambdas,
+  not (as you might guess) through lone big lambdas.
+  Reason: we float *out* past big lambdas (see the test in the Lam
+  case of FloatOut.floatExpr) and we don't want to float straight
+  back in again.
+
+  It *is* important to float into one-shot lambdas, however;
+  see the remarks with noFloatIntoRhs.
+
+So we treat lambda in groups, using the following rule:
+
+ Float in if (a) there is at least one Id,
+         and (b) there are no non-one-shot Ids
+
+ Otherwise drop all the bindings outside the group.
+
+This is what the 'go' function in the AnnLam case is doing.
+
+(Join points are handled similarly: a join point is considered one-shot iff
+it's non-recursive, so we float only into non-recursive join points.)
+
+Urk! if all are tyvars, and we don't float in, we may miss an
+      opportunity to float inside a nested case branch
+
+
+Note [Floating coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+We could, in principle, have a coercion binding like
+   case f x of co { DEFAULT -> e1 e2 }
+It's not common to have a function that returns a coercion, but nothing
+in Core prohibits it.  If so, 'co' might be mentioned in e1 or e2
+/only in a type/.  E.g. suppose e1 was
+  let (x :: Int |> co) = blah in blah2
+
+
+But, with coercions appearing in types, there is a complication: we
+might be floating in a "strict let" -- that is, a case. Case expressions
+mention their return type. We absolutely can't float a coercion binding
+inward to the point that the type of the expression it's about to wrap
+mentions the coercion. So we include the union of the sets of free variables
+of the types of all the drop points involved. If any of the floaters
+bind a coercion variable mentioned in any of the types, that binder must
+be dropped right away.
+
+-}
+
+fiExpr dflags to_drop lam@(_, AnnLam _ _)
+  | noFloatIntoLam bndrs       -- Dump it all here
+     -- NB: Must line up with noFloatIntoRhs (AnnLam...); see Trac #7088
+  = wrapFloats to_drop (mkLams bndrs (fiExpr dflags [] body))
+
+  | otherwise           -- Float inside
+  = mkLams bndrs (fiExpr dflags to_drop body)
+
+  where
+    (bndrs, body) = collectAnnBndrs lam
+
+{-
+We don't float lets inwards past an SCC.
+        ToDo: keep info on current cc, and when passing
+        one, if it is not the same, annotate all lets in binds with current
+        cc, change current cc to the new one and float binds into expr.
+-}
+
+fiExpr dflags to_drop (_, AnnTick tickish expr)
+  | tickish `tickishScopesLike` SoftScope
+  = Tick tickish (fiExpr dflags to_drop expr)
+
+  | otherwise -- Wimp out for now - we could push values in
+  = wrapFloats to_drop (Tick tickish (fiExpr dflags [] expr))
+
+{-
+For @Lets@, the possible ``drop points'' for the \tr{to_drop}
+bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
+or~(b2), in each of the RHSs of the pairs of a @Rec@.
+
+Note that we do {\em weird things} with this let's binding.  Consider:
+\begin{verbatim}
+let
+    w = ...
+in {
+    let v = ... w ...
+    in ... v .. w ...
+}
+\end{verbatim}
+Look at the inner \tr{let}.  As \tr{w} is used in both the bind and
+body of the inner let, we could panic and leave \tr{w}'s binding where
+it is.  But \tr{v} is floatable further into the body of the inner let, and
+{\em then} \tr{w} will also be only in the body of that inner let.
+
+So: rather than drop \tr{w}'s binding here, we add it onto the list of
+things to drop in the outer let's body, and let nature take its
+course.
+
+Note [extra_fvs (1): avoid floating into RHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider let x=\y....t... in body.  We do not necessarily want to float
+a binding for t into the RHS, because it'll immediately be floated out
+again.  (It won't go inside the lambda else we risk losing work.)
+In letrec, we need to be more careful still. We don't want to transform
+        let x# = y# +# 1#
+        in
+        letrec f = \z. ...x#...f...
+        in ...
+into
+        letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...
+because now we can't float the let out again, because a letrec
+can't have unboxed bindings.
+
+So we make "extra_fvs" which is the rhs_fvs of such bindings, and
+arrange to dump bindings that bind extra_fvs before the entire let.
+
+Note [extra_fvs (2): free variables of rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  let x{rule mentioning y} = rhs in body
+Here y is not free in rhs or body; but we still want to dump bindings
+that bind y outside the let.  So we augment extra_fvs with the
+idRuleAndUnfoldingVars of x.  No need for type variables, hence not using
+idFreeVars.
+-}
+
+fiExpr dflags to_drop (_,AnnLet bind body)
+  = fiExpr dflags (after ++ new_float : before) body
+           -- to_drop is in reverse dependency order
+  where
+    (before, new_float, after) = fiBind dflags to_drop bind body_fvs
+    body_fvs    = freeVarsOf body
+
+{- Note [Floating primops]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We try to float-in a case expression over an unlifted type.  The
+motivating example was Trac #5658: in particular, this change allows
+array indexing operations, which have a single DEFAULT alternative
+without any binders, to be floated inward.
+
+SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed
+scalars also need to be floated inward, but unpacks have a single non-DEFAULT
+alternative that binds the elements of the tuple. We now therefore also support
+floating in cases with a single alternative that may bind values.
+
+But there are wrinkles
+
+* Which unlifted cases do we float? See PrimOp.hs
+  Note [PrimOp can_fail and has_side_effects] which explains:
+   - We can float-in can_fail primops, but we can't float them out.
+   - But we can float a has_side_effects primop, but NOT inside a lambda,
+     so for now we don't float them at all.
+  Hence exprOkForSideEffects
+
+* Because we can float can-fail primops (array indexing, division) inwards
+  but not outwards, we must be careful not to transform
+     case a /# b of r -> f (F# r)
+  ===>
+    f (case a /# b of r -> F# r)
+  because that creates a new thunk that wasn't there before.  And
+  because it can't be floated out (can_fail), the thunk will stay
+  there.  Disaster!  (This happened in nofib 'simple' and 'scs'.)
+
+  Solution: only float cases into the branches of other cases, and
+  not into the arguments of an application, or the RHS of a let. This
+  is somewhat conservative, but it's simple.  And it still hits the
+  cases like Trac #5658.   This is implemented in sepBindsByJoinPoint;
+  if is_case is False we dump all floating cases right here.
+
+* Trac #14511 is another example of why we want to restrict float-in
+  of case-expressions.  Consider
+     case indexArray# a n of (# r #) -> writeArray# ma i (f r)
+  Now, floating that indexing operation into the (f r) thunk will
+  not create any new thunks, but it will keep the array 'a' alive
+  for much longer than the programmer expected.
+
+  So again, not floating a case into a let or argument seems like
+  the Right Thing
+
+For @Case@, the possible drop points for the 'to_drop'
+bindings are:
+  (a) inside the scrutinee
+  (b) inside one of the alternatives/default (default FVs always /first/!).
+
+-}
+
+fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)])
+  | isUnliftedType (idType case_bndr)
+  , exprOkForSideEffects (deAnnotate scrut)
+      -- See Note [Floating primops]
+  = wrapFloats shared_binds $
+    fiExpr dflags (case_float : rhs_binds) rhs
+  where
+    case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs
+                    (FloatCase scrut' case_bndr con alt_bndrs)
+    scrut'     = fiExpr dflags scrut_binds scrut
+    rhs_fvs    = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)
+    scrut_fvs  = freeVarsOf scrut
+
+    [shared_binds, scrut_binds, rhs_binds]
+       = sepBindsByDropPoint dflags False
+           [scrut_fvs, rhs_fvs]
+           to_drop
+
+fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts)
+  = wrapFloats drop_here1 $
+    wrapFloats drop_here2 $
+    Case (fiExpr dflags scrut_drops scrut) case_bndr ty
+         (zipWith fi_alt alts_drops_s alts)
+  where
+        -- Float into the scrut and alts-considered-together just like App
+    [drop_here1, scrut_drops, alts_drops]
+       = sepBindsByDropPoint dflags False
+           [scrut_fvs, all_alts_fvs]
+           to_drop
+
+        -- Float into the alts with the is_case flag set
+    (drop_here2 : alts_drops_s)
+      | [ _ ] <- alts = [] : [alts_drops]
+      | otherwise     = sepBindsByDropPoint dflags True alts_fvs alts_drops
+
+    scrut_fvs    = freeVarsOf scrut
+    alts_fvs     = map alt_fvs alts
+    all_alts_fvs = unionDVarSets alts_fvs
+    alt_fvs (_con, args, rhs)
+      = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)
+           -- Delete case_bndr and args from free vars of rhs
+           -- to get free vars of alt
+
+    fi_alt to_drop (con, args, rhs) = (con, args, fiExpr dflags to_drop rhs)
+
+------------------
+fiBind :: DynFlags
+       -> FloatInBinds      -- Binds we're trying to drop
+                            -- as far "inwards" as possible
+       -> CoreBindWithFVs   -- Input binding
+       -> DVarSet           -- Free in scope of binding
+       -> ( FloatInBinds    -- Land these before
+          , FloatInBind     -- The binding itself
+          , FloatInBinds)   -- Land these after
+
+fiBind dflags to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs
+  = ( extra_binds ++ shared_binds          -- Land these before
+                                           -- See Note [extra_fvs (1,2)]
+    , FB (unitDVarSet id) rhs_fvs'         -- The new binding itself
+          (FloatLet (NonRec id rhs'))
+    , body_binds )                         -- Land these after
+
+  where
+    body_fvs2 = body_fvs `delDVarSet` id
+
+    rule_fvs = bndrRuleAndUnfoldingVarsDSet id        -- See Note [extra_fvs (2): free variables of rules]
+    extra_fvs | noFloatIntoRhs NonRecursive id rhs
+              = rule_fvs `unionDVarSet` rhs_fvs
+              | otherwise
+              = rule_fvs
+        -- See Note [extra_fvs (1): avoid floating into RHS]
+        -- No point in floating in only to float straight out again
+        -- We *can't* float into ok-for-speculation unlifted RHSs
+        -- But do float into join points
+
+    [shared_binds, extra_binds, rhs_binds, body_binds]
+        = sepBindsByDropPoint dflags False
+            [extra_fvs, rhs_fvs, body_fvs2]
+            to_drop
+
+        -- Push rhs_binds into the right hand side of the binding
+    rhs'     = fiRhs dflags rhs_binds id ann_rhs
+    rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs
+                        -- Don't forget the rule_fvs; the binding mentions them!
+
+fiBind dflags to_drop (AnnRec bindings) body_fvs
+  = ( extra_binds ++ shared_binds
+    , FB (mkDVarSet ids) rhs_fvs'
+         (FloatLet (Rec (fi_bind rhss_binds bindings)))
+    , body_binds )
+  where
+    (ids, rhss) = unzip bindings
+    rhss_fvs = map freeVarsOf rhss
+
+        -- See Note [extra_fvs (1,2)]
+    rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids
+    extra_fvs = rule_fvs `unionDVarSet`
+                unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings
+                              , noFloatIntoRhs Recursive bndr rhs ]
+
+    (shared_binds:extra_binds:body_binds:rhss_binds)
+        = sepBindsByDropPoint dflags False
+            (extra_fvs:body_fvs:rhss_fvs)
+            to_drop
+
+    rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet`
+               unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet`
+               rule_fvs         -- Don't forget the rule variables!
+
+    -- Push rhs_binds into the right hand side of the binding
+    fi_bind :: [FloatInBinds]       -- one per "drop pt" conjured w/ fvs_of_rhss
+            -> [(Id, CoreExprWithFVs)]
+            -> [(Id, CoreExpr)]
+
+    fi_bind to_drops pairs
+      = [ (binder, fiRhs dflags to_drop binder rhs)
+        | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
+
+------------------
+fiRhs :: DynFlags -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr
+fiRhs dflags to_drop bndr rhs
+  | Just join_arity <- isJoinId_maybe bndr
+  , let (bndrs, body) = collectNAnnBndrs join_arity rhs
+  = mkLams bndrs (fiExpr dflags to_drop body)
+  | otherwise
+  = fiExpr dflags to_drop rhs
+
+------------------
+noFloatIntoLam :: [Var] -> Bool
+noFloatIntoLam bndrs = any bad bndrs
+  where
+    bad b = isId b && not (isOneShotBndr b)
+    -- Don't float inside a non-one-shot lambda
+
+noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool
+-- ^ True if it's a bad idea to float bindings into this RHS
+noFloatIntoRhs is_rec bndr rhs
+  | isJoinId bndr
+  = isRec is_rec -- Joins are one-shot iff non-recursive
+
+  | otherwise
+  = noFloatIntoArg rhs (idType bndr)
+
+noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool
+noFloatIntoArg expr expr_ty
+  | isUnliftedType expr_ty
+  = True  -- See Note [Do not destroy the let/app invariant]
+
+   | AnnLam bndr e <- expr
+   , (bndrs, _) <- collectAnnBndrs e
+   =  noFloatIntoLam (bndr:bndrs)  -- Wrinkle 1 (a)
+   || all isTyVar (bndr:bndrs)     -- Wrinkle 1 (b)
+      -- See Note [noFloatInto considerations] wrinkle 2
+
+  | otherwise  -- Note [noFloatInto considerations] wrinkle 2
+  = exprIsTrivial deann_expr || exprIsHNF deann_expr
+  where
+    deann_expr = deAnnotate' expr
+
+{- Note [noFloatInto considerations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When do we want to float bindings into
+   - noFloatIntoRHs: the RHS of a let-binding
+   - noFloatIntoArg: the argument of a function application
+
+Definitely don't float in if it has unlifted type; that
+would destroy the let/app invariant.
+
+* Wrinkle 1: do not float in if
+     (a) any non-one-shot value lambdas
+  or (b) all type lambdas
+  In both cases we'll float straight back out again
+  NB: Must line up with fiExpr (AnnLam...); see Trac #7088
+
+  (a) is important: we /must/ float into a one-shot lambda group
+  (which includes join points). This makes a big difference
+  for things like
+     f x# = let x = I# x#
+            in let j = \() -> ...x...
+               in if <condition> then normal-path else j ()
+  If x is used only in the error case join point, j, we must float the
+  boxing constructor into it, else we box it every time which is very
+  bad news indeed.
+
+* Wrinkle 2: for RHSs, do not float into a HNF; we'll just float right
+  back out again... not tragic, but a waste of time.
+
+  For function arguments we will still end up with this
+  in-then-out stuff; consider
+    letrec x = e in f x
+  Here x is not a HNF, so we'll produce
+    f (letrec x = e in x)
+  which is OK... it's not that common, and we'll end up
+  floating out again, in CorePrep if not earlier.
+  Still, we use exprIsTrivial to catch this case (sigh)
+
+
+************************************************************************
+*                                                                      *
+\subsection{@sepBindsByDropPoint@}
+*                                                                      *
+************************************************************************
+
+This is the crucial function.  The idea is: We have a wad of bindings
+that we'd like to distribute inside a collection of {\em drop points};
+insides the alternatives of a \tr{case} would be one example of some
+drop points; the RHS and body of a non-recursive \tr{let} binding
+would be another (2-element) collection.
+
+So: We're given a list of sets-of-free-variables, one per drop point,
+and a list of floating-inwards bindings.  If a binding can go into
+only one drop point (without suddenly making something out-of-scope),
+in it goes.  If a binding is used inside {\em multiple} drop points,
+then it has to go in a you-must-drop-it-above-all-these-drop-points
+point.
+
+We have to maintain the order on these drop-point-related lists.
+-}
+
+-- pprFIB :: FloatInBinds -> SDoc
+-- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs]
+
+sepBindsByDropPoint
+    :: DynFlags
+    -> Bool                -- True <=> is case expression
+    -> [FreeVarSet]        -- One set of FVs per drop point
+                           -- Always at least two long!
+    -> FloatInBinds        -- Candidate floaters
+    -> [FloatInBinds]      -- FIRST one is bindings which must not be floated
+                           -- inside any drop point; the rest correspond
+                           -- one-to-one with the input list of FV sets
+
+-- Every input floater is returned somewhere in the result;
+-- none are dropped, not even ones which don't seem to be
+-- free in *any* of the drop-point fvs.  Why?  Because, for example,
+-- a binding (let x = E in B) might have a specialised version of
+-- x (say x') stored inside x, but x' isn't free in E or B.
+
+type DropBox = (FreeVarSet, FloatInBinds)
+
+sepBindsByDropPoint dflags is_case drop_pts floaters
+  | null floaters  -- Shortcut common case
+  = [] : [[] | _ <- drop_pts]
+
+  | otherwise
+  = ASSERT( drop_pts `lengthAtLeast` 2 )
+    go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))
+  where
+    n_alts = length drop_pts
+
+    go :: FloatInBinds -> [DropBox] -> [FloatInBinds]
+        -- The *first* one in the argument list is the drop_here set
+        -- The FloatInBinds in the lists are in the reverse of
+        -- the normal FloatInBinds order; that is, they are the right way round!
+
+    go [] drop_boxes = map (reverse . snd) drop_boxes
+
+    go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)
+        = go binds new_boxes
+        where
+          -- "here" means the group of bindings dropped at the top of the fork
+
+          (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs
+                                        | (fvs, _) <- drop_boxes]
+
+          drop_here = used_here || cant_push
+
+          n_used_alts = count id used_in_flags -- returns number of Trues in list.
+
+          cant_push
+            | is_case   = n_used_alts == n_alts   -- Used in all, don't push
+                                                  -- Remember n_alts > 1
+                          || (n_used_alts > 1 && not (floatIsDupable dflags bind))
+                             -- floatIsDupable: see Note [Duplicating floats]
+
+            | otherwise = floatIsCase bind || n_used_alts > 1
+                             -- floatIsCase: see Note [Floating primops]
+
+          new_boxes | drop_here = (insert here_box : fork_boxes)
+                    | otherwise = (here_box : new_fork_boxes)
+
+          new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe
+                                        fork_boxes used_in_flags
+
+          insert :: DropBox -> DropBox
+          insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops)
+
+          insert_maybe box True  = insert box
+          insert_maybe box False = box
+
+    go _ _ = panic "sepBindsByDropPoint/go"
+
+
+{- Note [Duplicating floats]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For case expressions we duplicate the binding if it is reasonably
+small, and if it is not used in all the RHSs This is good for
+situations like
+     let x = I# y in
+     case e of
+       C -> error x
+       D -> error x
+       E -> ...not mentioning x...
+
+If the thing is used in all RHSs there is nothing gained,
+so we don't duplicate then.
+-}
+
+floatedBindsFVs :: FloatInBinds -> FreeVarSet
+floatedBindsFVs binds = mapUnionDVarSet fbFVs binds
+
+fbFVs :: FloatInBind -> DVarSet
+fbFVs (FB _ fvs _) = fvs
+
+wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr
+-- Remember FloatInBinds is in *reverse* dependency order
+wrapFloats []               e = e
+wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)
+
+floatIsDupable :: DynFlags -> FloatBind -> Bool
+floatIsDupable dflags (FloatCase scrut _ _ _) = exprIsDupable dflags scrut
+floatIsDupable dflags (FloatLet (Rec prs))    = all (exprIsDupable dflags . snd) prs
+floatIsDupable dflags (FloatLet (NonRec _ r)) = exprIsDupable dflags r
+
+floatIsCase :: FloatBind -> Bool
+floatIsCase (FloatCase {}) = True
+floatIsCase (FloatLet {})  = False
diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/FloatOut.hs
@@ -0,0 +1,755 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[FloatOut]{Float bindings outwards (towards the top level)}
+
+``Long-distance'' floating of bindings towards the top level.
+-}
+
+{-# LANGUAGE CPP #-}
+
+module FloatOut ( floatOutwards ) where
+
+import GhcPrelude
+
+import CoreSyn
+import CoreUtils
+import MkCore
+import CoreArity        ( etaExpand )
+import CoreMonad        ( FloatOutSwitches(..) )
+
+import DynFlags
+import ErrUtils         ( dumpIfSet_dyn )
+import Id               ( Id, idArity, idType, isBottomingId,
+                          isJoinId, isJoinId_maybe )
+import SetLevels
+import UniqSupply       ( UniqSupply )
+import Bag
+import Util
+import Maybes
+import Outputable
+import Type
+import qualified Data.IntMap as M
+
+import Data.List        ( partition )
+
+#include "HsVersions.h"
+
+{-
+        -----------------
+        Overall game plan
+        -----------------
+
+The Big Main Idea is:
+
+        To float out sub-expressions that can thereby get outside
+        a non-one-shot value lambda, and hence may be shared.
+
+
+To achieve this we may need to do two things:
+
+   a) Let-bind the sub-expression:
+
+        f (g x)  ==>  let lvl = f (g x) in lvl
+
+      Now we can float the binding for 'lvl'.
+
+   b) More than that, we may need to abstract wrt a type variable
+
+        \x -> ... /\a -> let v = ...a... in ....
+
+      Here the binding for v mentions 'a' but not 'x'.  So we
+      abstract wrt 'a', to give this binding for 'v':
+
+            vp = /\a -> ...a...
+            v  = vp a
+
+      Now the binding for vp can float out unimpeded.
+      I can't remember why this case seemed important enough to
+      deal with, but I certainly found cases where important floats
+      didn't happen if we did not abstract wrt tyvars.
+
+With this in mind we can also achieve another goal: lambda lifting.
+We can make an arbitrary (function) binding float to top level by
+abstracting wrt *all* local variables, not just type variables, leaving
+a binding that can be floated right to top level.  Whether or not this
+happens is controlled by a flag.
+
+
+Random comments
+~~~~~~~~~~~~~~~
+
+At the moment we never float a binding out to between two adjacent
+lambdas.  For example:
+
+@
+        \x y -> let t = x+x in ...
+===>
+        \x -> let t = x+x in \y -> ...
+@
+Reason: this is less efficient in the case where the original lambda
+is never partially applied.
+
+But there's a case I've seen where this might not be true.  Consider:
+@
+elEm2 x ys
+  = elem' x ys
+  where
+    elem' _ []  = False
+    elem' x (y:ys)      = x==y || elem' x ys
+@
+It turns out that this generates a subexpression of the form
+@
+        \deq x ys -> let eq = eqFromEqDict deq in ...
+@
+which might usefully be separated to
+@
+        \deq -> let eq = eqFromEqDict deq in \xy -> ...
+@
+Well, maybe.  We don't do this at the moment.
+
+Note [Join points]
+~~~~~~~~~~~~~~~~~~
+Every occurrence of a join point must be a tail call (see Note [Invariants on
+join points] in CoreSyn), so we must be careful with how far we float them. The
+mechanism for doing so is the *join ceiling*, detailed in Note [Join ceiling]
+in SetLevels. For us, the significance is that a binder might be marked to be
+dropped at the nearest boundary between tail calls and non-tail calls. For
+example:
+
+  (< join j = ... in
+     let x = < ... > in
+     case < ... > of
+       A -> ...
+       B -> ...
+   >) < ... > < ... >
+
+Here the join ceilings are marked with angle brackets. Either side of an
+application is a join ceiling, as is the scrutinee position of a case
+expression or the RHS of a let binding (but not a join point).
+
+Why do we *want* do float join points at all? After all, they're never
+allocated, so there's no sharing to be gained by floating them. However, the
+other benefit of floating is making RHSes small, and this can have a significant
+impact. In particular, stream fusion has been known to produce nested loops like
+this:
+
+  joinrec j1 x1 =
+    joinrec j2 x2 =
+      joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...
+      in jump j3 x2
+    in jump j2 x1
+  in jump j1 x
+
+(Assume x1 and x2 do *not* occur free in j3.)
+
+Here j1 and j2 are wholly superfluous---each of them merely forwards its
+argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make
+everything one big mutual recursion:
+
+  joinrec j1 x1 = jump j2 x1
+          j2 x2 = jump j3 x2
+          j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...
+  in jump j1 x
+
+Now the simplifier will happily inline the trivial j1 and j2, leaving only j3.
+Without floating, we're stuck with three loops instead of one.
+
+************************************************************************
+*                                                                      *
+\subsection[floatOutwards]{@floatOutwards@: let-floating interface function}
+*                                                                      *
+************************************************************************
+-}
+
+floatOutwards :: FloatOutSwitches
+              -> DynFlags
+              -> UniqSupply
+              -> CoreProgram -> IO CoreProgram
+
+floatOutwards float_sws dflags us pgm
+  = do {
+        let { annotated_w_levels = setLevels float_sws pgm us ;
+              (fss, binds_s')    = unzip (map floatTopBind annotated_w_levels)
+            } ;
+
+        dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"
+                  (vcat (map ppr annotated_w_levels));
+
+        let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };
+
+        dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"
+                (hcat [ int tlets,  text " Lets floated to top level; ",
+                        int ntlets, text " Lets floated elsewhere; from ",
+                        int lams,   text " Lambda groups"]);
+
+        return (bagToList (unionManyBags binds_s'))
+    }
+
+floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind)
+floatTopBind bind
+  = case (floatBind bind) of { (fs, floats, bind') ->
+    let float_bag = flattenTopFloats floats
+    in case bind' of
+      -- bind' can't have unlifted values or join points, so can only be one
+      -- value bind, rec or non-rec (see comment on floatBind)
+      [Rec prs]    -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs)))
+      [NonRec b e] -> (fs, float_bag `snocBag` NonRec b e)
+      _            -> pprPanic "floatTopBind" (ppr bind') }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[FloatOut-Bind]{Floating in a binding (the business end)}
+*                                                                      *
+************************************************************************
+-}
+
+floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind])
+  -- Returns a list with either
+  --   * A single non-recursive binding (value or join point), or
+  --   * The following, in order:
+  --     * Zero or more non-rec unlifted bindings
+  --     * One or both of:
+  --       * A recursive group of join binds
+  --       * A recursive group of value binds
+  -- See Note [Floating out of Rec rhss] for why things get arranged this way.
+floatBind (NonRec (TB var _) rhs)
+  = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') ->
+
+        -- A tiresome hack:
+        -- see Note [Bottoming floats: eta expansion] in SetLevels
+    let rhs'' | isBottomingId var = etaExpand (idArity var) rhs'
+              | otherwise         = rhs'
+
+    in (fs, rhs_floats, [NonRec var rhs'']) }
+
+floatBind (Rec pairs)
+  = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) ->
+    let (new_ul_pairss, new_other_pairss) = unzip new_pairs
+        (new_join_pairs, new_l_pairs)     = partition (isJoinId . fst)
+                                                      (concat new_other_pairss)
+        -- Can't put the join points and the values in the same rec group
+        new_rec_binds | null new_join_pairs = [ Rec new_l_pairs    ]
+                      | null new_l_pairs    = [ Rec new_join_pairs ]
+                      | otherwise           = [ Rec new_l_pairs
+                                              , Rec new_join_pairs ]
+        new_non_rec_binds = [ NonRec b e | (b, e) <- concat new_ul_pairss ]
+    in
+    (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) }
+  where
+    do_pair :: (LevelledBndr, LevelledExpr)
+            -> (FloatStats, FloatBinds,
+                ([(Id,CoreExpr)],  -- Non-recursive unlifted value bindings
+                 [(Id,CoreExpr)])) -- Join points and lifted value bindings
+    do_pair (TB name spec, rhs)
+      | isTopLvl dest_lvl  -- See Note [floatBind for top level]
+      = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->
+        (fs, emptyFloats, ([], addTopFloatPairs (flattenTopFloats rhs_floats)
+                                                [(name, rhs')]))}
+      | otherwise         -- Note [Floating out of Rec rhss]
+      = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->
+        case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) ->
+        case (splitRecFloats heres) of { (ul_pairs, pairs, case_heres) ->
+        let pairs' = (name, installUnderLambdas case_heres rhs') : pairs in
+        (fs, rhs_floats', (ul_pairs, pairs')) }}}
+      where
+        dest_lvl = floatSpecLevel spec
+
+splitRecFloats :: Bag FloatBind
+               -> ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings
+                   [(Id,CoreExpr)], -- Join points and lifted value bindings
+                   Bag FloatBind)   -- A tail of further bindings
+-- The "tail" begins with a case
+-- See Note [Floating out of Rec rhss]
+splitRecFloats fs
+  = go [] [] (bagToList fs)
+  where
+    go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b)
+                                               , not (isJoinId b)
+                                               = go ((b,r):ul_prs) prs fs
+                                               | otherwise
+                                               = go ul_prs ((b,r):prs) fs
+    go ul_prs prs (FloatLet (Rec prs')   : fs) = go ul_prs (prs' ++ prs) fs
+    go ul_prs prs fs                           = (reverse ul_prs, prs,
+                                                  listToBag fs)
+                                                   -- Order only matters for
+                                                   -- non-rec
+
+installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr
+-- Note [Floating out of Rec rhss]
+installUnderLambdas floats e
+  | isEmptyBag floats = e
+  | otherwise         = go e
+  where
+    go (Lam b e)                 = Lam b (go e)
+    go e                         = install floats e
+
+---------------
+floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])
+floatList _ [] = (zeroStats, emptyFloats, [])
+floatList f (a:as) = case f a            of { (fs_a,  binds_a,  b)  ->
+                     case floatList f as of { (fs_as, binds_as, bs) ->
+                     (fs_a `add_stats` fs_as, binds_a `plusFloats`  binds_as, b:bs) }}
+
+{-
+Note [Floating out of Rec rhss]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider   Rec { f<1,0> = \xy. body }
+From the body we may get some floats. The ones with level <1,0> must
+stay here, since they may mention f.  Ideally we'd like to make them
+part of the Rec block pairs -- but we can't if there are any
+FloatCases involved.
+
+Nor is it a good idea to dump them in the rhs, but outside the lambda
+    f = case x of I# y -> \xy. body
+because now f's arity might get worse, which is Not Good. (And if
+there's an SCC around the RHS it might not get better again.
+See Trac #5342.)
+
+So, gruesomely, we split the floats into
+ * the outer FloatLets, which can join the Rec, and
+ * an inner batch starting in a FloatCase, which are then
+   pushed *inside* the lambdas.
+This loses full-laziness the rare situation where there is a
+FloatCase and a Rec interacting.
+
+If there are unlifted FloatLets (that *aren't* join points) among the floats,
+we can't add them to the recursive group without angering Core Lint, but since
+they must be ok-for-speculation, they can't actually be making any recursive
+calls, so we can safely pull them out and keep them non-recursive.
+
+(Why is something getting floated to <1,0> that doesn't make a recursive call?
+The case that came up in testing was that f *and* the unlifted binding were
+getting floated *to the same place*:
+
+  \x<2,0> ->
+    ... <3,0>
+    letrec { f<F<2,0>> =
+      ... let x'<F<2,0>> = x +# 1# in ...
+    } in ...
+
+Everything gets labeled "float to <2,0>" because it all depends on x, but this
+makes f and x' look mutually recursive when they're not.
+
+The test was shootout/k-nucleotide, as compiled using commit 47d5dd68 on the
+wip/join-points branch.
+
+TODO: This can probably be solved somehow in SetLevels. The difference between
+"this *is at* level <2,0>" and "this *depends on* level <2,0>" is very
+important.)
+
+Note [floatBind for top level]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus
+         letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... }
+The binding for bar will be in the "tops" part of the floating binds,
+and thus not partioned by floatBody.
+
+We could perhaps get rid of the 'tops' component of the floating binds,
+but this case works just as well.
+
+
+************************************************************************
+
+\subsection[FloatOut-Expr]{Floating in expressions}
+*                                                                      *
+************************************************************************
+-}
+
+floatBody :: Level
+          -> LevelledExpr
+          -> (FloatStats, FloatBinds, CoreExpr)
+
+floatBody lvl arg       -- Used rec rhss, and case-alternative rhss
+  = case (floatExpr arg) of { (fsa, floats, arg') ->
+    case (partitionByLevel lvl floats) of { (floats', heres) ->
+        -- Dump bindings are bound here
+    (fsa, floats', install heres arg') }}
+
+-----------------
+
+{- Note [Floating past breakpoints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We used to disallow floating out of breakpoint ticks (see #10052). However, I
+think this is too restrictive.
+
+Consider the case of an expression scoped over by a breakpoint tick,
+
+  tick<...> (let x = ... in f x)
+
+In this case it is completely legal to float out x, despite the fact that
+breakpoint ticks are scoped,
+
+  let x = ... in (tick<...>  f x)
+
+The reason here is that we know that the breakpoint will still be hit when the
+expression is entered since the tick still scopes over the RHS.
+
+-}
+
+floatExpr :: LevelledExpr
+          -> (FloatStats, FloatBinds, CoreExpr)
+floatExpr (Var v)   = (zeroStats, emptyFloats, Var v)
+floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty)
+floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co)
+floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit)
+
+floatExpr (App e a)
+  = case (atJoinCeiling $ floatExpr  e) of { (fse, floats_e, e') ->
+    case (atJoinCeiling $ floatExpr  a) of { (fsa, floats_a, a') ->
+    (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}
+
+floatExpr lam@(Lam (TB _ lam_spec) _)
+  = let (bndrs_w_lvls, body) = collectBinders lam
+        bndrs                = [b | TB b _ <- bndrs_w_lvls]
+        bndr_lvl             = asJoinCeilLvl (floatSpecLevel lam_spec)
+        -- All the binders have the same level
+        -- See SetLevels.lvlLamBndrs
+        -- Use asJoinCeilLvl to make this the join ceiling
+    in
+    case (floatBody bndr_lvl body) of { (fs, floats, body') ->
+    (add_to_stats fs floats, floats, mkLams bndrs body') }
+
+floatExpr (Tick tickish expr)
+  | tickish `tickishScopesLike` SoftScope -- not scoped, can just float
+  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->
+    (fs, floating_defns, Tick tickish expr') }
+
+  | not (tickishCounts tickish) || tickishCanSplit tickish
+  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->
+    let -- Annotate bindings floated outwards past an scc expression
+        -- with the cc.  We mark that cc as "duplicated", though.
+        annotated_defns = wrapTick (mkNoCount tickish) floating_defns
+    in
+    (fs, annotated_defns, Tick tickish expr') }
+
+  -- Note [Floating past breakpoints]
+  | Breakpoint{} <- tickish
+  = case (floatExpr expr)    of { (fs, floating_defns, expr') ->
+    (fs, floating_defns, Tick tickish expr') }
+
+  | otherwise
+  = pprPanic "floatExpr tick" (ppr tickish)
+
+floatExpr (Cast expr co)
+  = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') ->
+    (fs, floating_defns, Cast expr' co) }
+
+floatExpr (Let bind body)
+  = case bind_spec of
+      FloatMe dest_lvl
+        -> case (floatBind bind) of { (fsb, bind_floats, binds') ->
+           case (floatExpr body) of { (fse, body_floats, body') ->
+           let new_bind_floats = foldr plusFloats emptyFloats
+                                   (map (unitLetFloat dest_lvl) binds') in
+           ( add_stats fsb fse
+           , bind_floats `plusFloats` new_bind_floats
+                         `plusFloats` body_floats
+           , body') }}
+
+      StayPut bind_lvl  -- See Note [Avoiding unnecessary floating]
+        -> case (floatBind bind)          of { (fsb, bind_floats, binds') ->
+           case (floatBody bind_lvl body) of { (fse, body_floats, body') ->
+           ( add_stats fsb fse
+           , bind_floats `plusFloats` body_floats
+           , foldr Let body' binds' ) }}
+  where
+    bind_spec = case bind of
+                 NonRec (TB _ s) _     -> s
+                 Rec ((TB _ s, _) : _) -> s
+                 Rec []                -> panic "floatExpr:rec"
+
+floatExpr (Case scrut (TB case_bndr case_spec) ty alts)
+  = case case_spec of
+      FloatMe dest_lvl  -- Case expression moves
+        | [(con@(DataAlt {}), bndrs, rhs)] <- alts
+        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->
+           case                 floatExpr rhs   of { (fsb, fdb, rhs') ->
+           let
+             float = unitCaseFloat dest_lvl scrut'
+                          case_bndr con [b | TB b _ <- bndrs]
+           in
+           (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }}
+        | otherwise
+        -> pprPanic "Floating multi-case" (ppr alts)
+
+      StayPut bind_lvl  -- Case expression stays put
+        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->
+           case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts')  ->
+           (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')
+           }}
+  where
+    float_alt bind_lvl (con, bs, rhs)
+        = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') ->
+          (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }
+
+floatRhs :: CoreBndr
+         -> LevelledExpr
+         -> (FloatStats, FloatBinds, CoreExpr)
+floatRhs bndr rhs
+  | Just join_arity <- isJoinId_maybe bndr
+  , Just (bndrs, body) <- try_collect join_arity rhs []
+  = case bndrs of
+      []                -> floatExpr rhs
+      (TB _ lam_spec):_ ->
+        let lvl = floatSpecLevel lam_spec in
+        case floatBody lvl body of { (fs, floats, body') ->
+        (fs, floats, mkLams [b | TB b _ <- bndrs] body') }
+  | otherwise
+  = atJoinCeiling $ floatExpr rhs
+  where
+    try_collect 0 expr      acc = Just (reverse acc, expr)
+    try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc)
+    try_collect _ _         _   = Nothing
+
+{-
+Note [Avoiding unnecessary floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general we want to avoid floating a let unnecessarily, because
+it might worsen strictness:
+    let
+       x = ...(let y = e in y+y)....
+Here y is demanded.  If we float it outside the lazy 'x=..' then
+we'd have to zap its demand info, and it may never be restored.
+
+So at a 'let' we leave the binding right where the are unless
+the binding will escape a value lambda, e.g.
+
+(\x -> let y = fac 100 in y)
+
+That's what the partitionByMajorLevel does in the floatExpr (Let ...)
+case.
+
+Notice, though, that we must take care to drop any bindings
+from the body of the let that depend on the staying-put bindings.
+
+We used instead to do the partitionByMajorLevel on the RHS of an '=',
+in floatRhs.  But that was quite tiresome.  We needed to test for
+values or trival rhss, because (in particular) we don't want to insert
+new bindings between the "=" and the "\".  E.g.
+        f = \x -> let <bind> in <body>
+We do not want
+        f = let <bind> in \x -> <body>
+(a) The simplifier will immediately float it further out, so we may
+        as well do so right now; in general, keeping rhss as manifest
+        values is good
+(b) If a float-in pass follows immediately, it might add yet more
+        bindings just after the '='.  And some of them might (correctly)
+        be strict even though the 'let f' is lazy, because f, being a value,
+        gets its demand-info zapped by the simplifier.
+And even all that turned out to be very fragile, and broke
+altogether when profiling got in the way.
+
+So now we do the partition right at the (Let..) itself.
+
+************************************************************************
+*                                                                      *
+\subsection{Utility bits for floating stats}
+*                                                                      *
+************************************************************************
+
+I didn't implement this with unboxed numbers.  I don't want to be too
+strict in this stuff, as it is rarely turned on.  (WDP 95/09)
+-}
+
+data FloatStats
+  = FlS Int  -- Number of top-floats * lambda groups they've been past
+        Int  -- Number of non-top-floats * lambda groups they've been past
+        Int  -- Number of lambda (groups) seen
+
+get_stats :: FloatStats -> (Int, Int, Int)
+get_stats (FlS a b c) = (a, b, c)
+
+zeroStats :: FloatStats
+zeroStats = FlS 0 0 0
+
+sum_stats :: [FloatStats] -> FloatStats
+sum_stats xs = foldr add_stats zeroStats xs
+
+add_stats :: FloatStats -> FloatStats -> FloatStats
+add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)
+  = FlS (a1 + a2) (b1 + b2) (c1 + c2)
+
+add_to_stats :: FloatStats -> FloatBinds -> FloatStats
+add_to_stats (FlS a b c) (FB tops ceils others)
+  = FlS (a + lengthBag tops)
+        (b + lengthBag ceils + lengthBag (flattenMajor others))
+        (c + 1)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Utility bits for floating}
+*                                                                      *
+************************************************************************
+
+Note [Representation of FloatBinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The FloatBinds types is somewhat important.  We can get very large numbers
+of floating bindings, often all destined for the top level.  A typical example
+is     x = [4,2,5,2,5, .... ]
+Then we get lots of small expressions like (fromInteger 4), which all get
+lifted to top level.
+
+The trouble is that
+  (a) we partition these floating bindings *at every binding site*
+  (b) SetLevels introduces a new bindings site for every float
+So we had better not look at each binding at each binding site!
+
+That is why MajorEnv is represented as a finite map.
+
+We keep the bindings destined for the *top* level separate, because
+we float them out even if they don't escape a *value* lambda; see
+partitionByMajorLevel.
+-}
+
+type FloatLet = CoreBind        -- INVARIANT: a FloatLet is always lifted
+type MajorEnv = M.IntMap MinorEnv         -- Keyed by major level
+type MinorEnv = M.IntMap (Bag FloatBind)  -- Keyed by minor level
+
+data FloatBinds  = FB !(Bag FloatLet)           -- Destined for top level
+                      !(Bag FloatBind)          -- Destined for join ceiling
+                      !MajorEnv                 -- Other levels
+     -- See Note [Representation of FloatBinds]
+
+instance Outputable FloatBinds where
+  ppr (FB fbs ceils defs)
+      = text "FB" <+> (braces $ vcat
+           [ text "tops ="     <+> ppr fbs
+           , text "ceils ="    <+> ppr ceils
+           , text "non-tops =" <+> ppr defs ])
+
+flattenTopFloats :: FloatBinds -> Bag CoreBind
+flattenTopFloats (FB tops ceils defs)
+  = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs )
+    ASSERT2( isEmptyBag ceils, ppr ceils )
+    tops
+
+addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
+addTopFloatPairs float_bag prs
+  = foldrBag add prs float_bag
+  where
+    add (NonRec b r) prs  = (b,r):prs
+    add (Rec prs1)   prs2 = prs1 ++ prs2
+
+flattenMajor :: MajorEnv -> Bag FloatBind
+flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag
+
+flattenMinor :: MinorEnv -> Bag FloatBind
+flattenMinor = M.foldr unionBags emptyBag
+
+emptyFloats :: FloatBinds
+emptyFloats = FB emptyBag emptyBag M.empty
+
+unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds
+unitCaseFloat (Level major minor t) e b con bs
+  | t == JoinCeilLvl
+  = FB emptyBag floats M.empty
+  | otherwise
+  = FB emptyBag emptyBag (M.singleton major (M.singleton minor floats))
+  where
+    floats = unitBag (FloatCase e b con bs)
+
+unitLetFloat :: Level -> FloatLet -> FloatBinds
+unitLetFloat lvl@(Level major minor t) b
+  | isTopLvl lvl     = FB (unitBag b) emptyBag M.empty
+  | t == JoinCeilLvl = FB emptyBag floats M.empty
+  | otherwise        = FB emptyBag emptyBag (M.singleton major
+                                              (M.singleton minor floats))
+  where
+    floats = unitBag (FloatLet b)
+
+plusFloats :: FloatBinds -> FloatBinds -> FloatBinds
+plusFloats (FB t1 c1 l1) (FB t2 c2 l2)
+  = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2)
+
+plusMajor :: MajorEnv -> MajorEnv -> MajorEnv
+plusMajor = M.unionWith plusMinor
+
+plusMinor :: MinorEnv -> MinorEnv -> MinorEnv
+plusMinor = M.unionWith unionBags
+
+install :: Bag FloatBind -> CoreExpr -> CoreExpr
+install defn_groups expr
+  = foldrBag wrapFloat expr defn_groups
+
+partitionByLevel
+        :: Level                -- Partitioning level
+        -> FloatBinds           -- Defns to be divided into 2 piles...
+        -> (FloatBinds,         -- Defns  with level strictly < partition level,
+            Bag FloatBind)      -- The rest
+
+{-
+--       ---- partitionByMajorLevel ----
+-- Float it if we escape a value lambda,
+--     *or* if we get to the top level
+--     *or* if it's a case-float and its minor level is < current
+--
+-- If we can get to the top level, say "yes" anyway. This means that
+--      x = f e
+-- transforms to
+--    lvl = e
+--    x = f lvl
+-- which is as it should be
+
+partitionByMajorLevel (Level major _) (FB tops defns)
+  = (FB tops outer, heres `unionBags` flattenMajor inner)
+  where
+    (outer, mb_heres, inner) = M.splitLookup major defns
+    heres = case mb_heres of
+               Nothing -> emptyBag
+               Just h  -> flattenMinor h
+-}
+
+partitionByLevel (Level major minor typ) (FB tops ceils defns)
+  = (FB tops ceils' (outer_maj `plusMajor` M.singleton major outer_min),
+     here_min `unionBags` here_ceil
+              `unionBags` flattenMinor inner_min
+              `unionBags` flattenMajor inner_maj)
+
+  where
+    (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns
+    (outer_min, mb_here_min, inner_min) = case mb_here_maj of
+                                            Nothing -> (M.empty, Nothing, M.empty)
+                                            Just min_defns -> M.splitLookup minor min_defns
+    here_min = mb_here_min `orElse` emptyBag
+    (here_ceil, ceils') | typ == JoinCeilLvl = (ceils, emptyBag)
+                        | otherwise          = (emptyBag, ceils)
+
+-- Like partitionByLevel, but instead split out the bindings that are marked
+-- to float to the nearest join ceiling (see Note [Join points])
+partitionAtJoinCeiling :: FloatBinds -> (FloatBinds, Bag FloatBind)
+partitionAtJoinCeiling (FB tops ceils defs)
+  = (FB tops emptyBag defs, ceils)
+
+-- Perform some action at a join ceiling, i.e., don't let join points float out
+-- (see Note [Join points])
+atJoinCeiling :: (FloatStats, FloatBinds, CoreExpr)
+              -> (FloatStats, FloatBinds, CoreExpr)
+atJoinCeiling (fs, floats, expr')
+  = (fs, floats', install ceils expr')
+  where
+    (floats', ceils) = partitionAtJoinCeiling floats
+
+wrapTick :: Tickish Id -> FloatBinds -> FloatBinds
+wrapTick t (FB tops ceils defns)
+  = FB (mapBag wrap_bind tops) (wrap_defns ceils)
+       (M.map (M.map wrap_defns) defns)
+  where
+    wrap_defns = mapBag wrap_one
+
+    wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs)
+    wrap_bind (Rec pairs)         = Rec (mapSnd maybe_tick pairs)
+
+    wrap_one (FloatLet bind)      = FloatLet (wrap_bind bind)
+    wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs
+
+    maybe_tick e | exprIsHNF e = tickHNFArgs t e
+                 | otherwise   = mkTick t e
+      -- we don't need to wrap a tick around an HNF when we float it
+      -- outside a tick: that is an invariant of the tick semantics
+      -- Conversely, inlining of HNFs inside an SCC is allowed, and
+      -- indeed the HNF we're floating here might well be inlined back
+      -- again, and we don't want to end up with duplicate ticks.
diff --git a/compiler/simplCore/LiberateCase.hs b/compiler/simplCore/LiberateCase.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/LiberateCase.hs
@@ -0,0 +1,442 @@
+{-
+(c) The AQUA Project, Glasgow University, 1994-1998
+
+\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}
+-}
+
+{-# LANGUAGE CPP #-}
+module LiberateCase ( liberateCase ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import DynFlags
+import CoreSyn
+import CoreUnfold       ( couldBeSmallEnoughToInline )
+import TysWiredIn       ( unitDataConId )
+import Id
+import VarEnv
+import Util             ( notNull )
+
+{-
+The liberate-case transformation
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This module walks over @Core@, and looks for @case@ on free variables.
+The criterion is:
+        if there is case on a free on the route to the recursive call,
+        then the recursive call is replaced with an unfolding.
+
+Example
+
+   f = \ t -> case v of
+                 V a b -> a : f t
+
+=> the inner f is replaced.
+
+   f = \ t -> case v of
+                 V a b -> a : (letrec
+                                f =  \ t -> case v of
+                                               V a b -> a : f t
+                               in f) t
+(note the NEED for shadowing)
+
+=> Simplify
+
+  f = \ t -> case v of
+                 V a b -> a : (letrec
+                                f = \ t -> a : f t
+                               in f t)
+
+Better code, because 'a' is  free inside the inner letrec, rather
+than needing projection from v.
+
+Note that this deals with *free variables*.  SpecConstr deals with
+*arguments* that are of known form.  E.g.
+
+        last []     = error
+        last (x:[]) = x
+        last (x:xs) = last xs
+
+
+Note [Scrutinee with cast]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+    f = \ t -> case (v `cast` co) of
+                 V a b -> a : f t
+
+Exactly the same optimisation (unrolling one call to f) will work here,
+despite the cast.  See mk_alt_env in the Case branch of libCase.
+
+
+To think about (Apr 94)
+~~~~~~~~~~~~~~
+Main worry: duplicating code excessively.  At the moment we duplicate
+the entire binding group once at each recursive call.  But there may
+be a group of recursive calls which share a common set of evaluated
+free variables, in which case the duplication is a plain waste.
+
+Another thing we could consider adding is some unfold-threshold thing,
+so that we'll only duplicate if the size of the group rhss isn't too
+big.
+
+Data types
+~~~~~~~~~~
+The ``level'' of a binder tells how many
+recursive defns lexically enclose the binding
+A recursive defn "encloses" its RHS, not its
+scope.  For example:
+\begin{verbatim}
+        letrec f = let g = ... in ...
+        in
+        let h = ...
+        in ...
+\end{verbatim}
+Here, the level of @f@ is zero, the level of @g@ is one,
+and the level of @h@ is zero (NB not one).
+
+
+************************************************************************
+*                                                                      *
+         Top-level code
+*                                                                      *
+************************************************************************
+-}
+
+liberateCase :: DynFlags -> CoreProgram -> CoreProgram
+liberateCase dflags binds = do_prog (initEnv dflags) binds
+  where
+    do_prog _   [] = []
+    do_prog env (bind:binds) = bind' : do_prog env' binds
+                             where
+                               (env', bind') = libCaseBind env bind
+
+{-
+************************************************************************
+*                                                                      *
+         Main payload
+*                                                                      *
+************************************************************************
+
+Bindings
+~~~~~~~~
+-}
+
+libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)
+
+libCaseBind env (NonRec binder rhs)
+  = (addBinders env [binder], NonRec binder (libCase env rhs))
+
+libCaseBind env (Rec pairs)
+  = (env_body, Rec pairs')
+  where
+    binders = map fst pairs
+
+    env_body = addBinders env binders
+
+    pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs]
+
+        -- We extend the rec-env by binding each Id to its rhs, first
+        -- processing the rhs with an *un-extended* environment, so
+        -- that the same process doesn't occur for ever!
+    env_rhs | is_dupable_bind = addRecBinds env dup_pairs
+            | otherwise       = env
+
+    dup_pairs = [ (localiseId binder, libCase env_body rhs)
+                | (binder, rhs) <- pairs ]
+        -- localiseID : see Note [Need to localiseId in libCaseBind]
+
+    is_dupable_bind = small_enough && all ok_pair pairs
+
+    -- Size: we are going to duplicate dup_pairs; to find their
+    --       size, build a fake binding (let { dup_pairs } in (),
+    --       and find the size of that
+    -- See Note [Small enough]
+    small_enough = case bombOutSize env of
+                      Nothing   -> True   -- Infinity
+                      Just size -> couldBeSmallEnoughToInline (lc_dflags env) size $
+                                   Let (Rec dup_pairs) (Var unitDataConId)
+
+    ok_pair (id,_)
+        =  idArity id > 0          -- Note [Only functions!]
+        && not (isBottomingId id)  -- Note [Not bottoming ids]
+
+{- Note [Not bottoming Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Do not specialise error-functions (this is unusual, but I once saw it,
+(acually in Data.Typable.Internal)
+
+Note [Only functions!]
+~~~~~~~~~~~~~~~~~~~~~~
+Consider the following code
+
+       f = g (case v of V a b -> a : t f)
+
+where g is expensive. If we aren't careful, liberate case will turn this into
+
+       f = g (case v of
+               V a b -> a : t (letrec f = g (case v of V a b -> a : f t)
+                                in f)
+             )
+
+Yikes! We evaluate g twice. This leads to a O(2^n) explosion
+if g calls back to the same code recursively.
+
+Solution: make sure that we only do the liberate-case thing on *functions*
+
+Note [Small enough]
+~~~~~~~~~~~~~~~~~~~
+Consider
+  \fv. letrec
+         f = \x. BIG...(case fv of { (a,b) -> ...g.. })...
+         g = \y. SMALL...f...
+
+Then we *can* in principle do liberate-case on 'g' (small RHS) but not
+for 'f' (too big).  But doing so is not profitable, because duplicating
+'g' at its call site in 'f' doesn't get rid of any cases.  So we just
+ask for the whole group to be small enough.
+
+Note [Need to localiseId in libCaseBind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The call to localiseId is needed for two subtle reasons
+(a)  Reset the export flags on the binders so
+        that we don't get name clashes on exported things if the
+        local binding floats out to top level.  This is most unlikely
+        to happen, since the whole point concerns free variables.
+        But resetting the export flag is right regardless.
+
+(b)  Make the name an Internal one.  External Names should never be
+        nested; if it were floated to the top level, we'd get a name
+        clash at code generation time.
+
+Expressions
+~~~~~~~~~~~
+-}
+
+libCase :: LibCaseEnv
+        -> CoreExpr
+        -> CoreExpr
+
+libCase env (Var v)             = libCaseApp env v []
+libCase _   (Lit lit)           = Lit lit
+libCase _   (Type ty)           = Type ty
+libCase _   (Coercion co)       = Coercion co
+libCase env e@(App {})          | let (fun, args) = collectArgs e
+                                , Var v <- fun
+                                = libCaseApp env v args
+libCase env (App fun arg)       = App (libCase env fun) (libCase env arg)
+libCase env (Tick tickish body) = Tick tickish (libCase env body)
+libCase env (Cast e co)         = Cast (libCase env e) co
+
+libCase env (Lam binder body)
+  = Lam binder (libCase (addBinders env [binder]) body)
+
+libCase env (Let bind body)
+  = Let bind' (libCase env_body body)
+  where
+    (env_body, bind') = libCaseBind env bind
+
+libCase env (Case scrut bndr ty alts)
+  = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)
+  where
+    env_alts = addBinders (mk_alt_env scrut) [bndr]
+    mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var
+    mk_alt_env (Cast scrut _)  = mk_alt_env scrut       -- Note [Scrutinee with cast]
+    mk_alt_env _               = env
+
+libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr)
+                         -> (AltCon, [CoreBndr], CoreExpr)
+libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)
+
+{-
+Ids
+~~~
+
+To unfold, we can't just wrap the id itself in its binding if it's a join point:
+
+  jump j a b c  =>  (joinrec j x y z = ... in jump j) a b c -- wrong!!!
+
+Every jump must provide all arguments, so we have to be careful to wrap the
+whole jump instead:
+
+  jump j a b c  =>  joinrec j x y z = ... in jump j a b c -- right
+
+-}
+
+libCaseApp :: LibCaseEnv -> Id -> [CoreExpr] -> CoreExpr
+libCaseApp env v args
+  | Just the_bind <- lookupRecId env v  -- It's a use of a recursive thing
+  , notNull free_scruts                 -- with free vars scrutinised in RHS
+  = Let the_bind expr'
+
+  | otherwise
+  = expr'
+
+  where
+    rec_id_level = lookupLevel env v
+    free_scruts  = freeScruts env rec_id_level
+    expr'        = mkApps (Var v) (map (libCase env) args)
+
+freeScruts :: LibCaseEnv
+           -> LibCaseLevel      -- Level of the recursive Id
+           -> [Id]              -- Ids that are scrutinised between the binding
+                                -- of the recursive Id and here
+freeScruts env rec_bind_lvl
+  = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env
+       , scrut_bind_lvl <= rec_bind_lvl
+       , scrut_at_lvl > rec_bind_lvl]
+        -- Note [When to specialise]
+        -- Note [Avoiding fruitless liberate-case]
+
+{-
+Note [When to specialise]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f = \x. letrec g = \y. case x of
+                           True  -> ... (f a) ...
+                           False -> ... (g b) ...
+
+We get the following levels
+          f  0
+          x  1
+          g  1
+          y  2
+
+Then 'x' is being scrutinised at a deeper level than its binding, so
+it's added to lc_sruts:  [(x,1)]
+
+We do *not* want to specialise the call to 'f', because 'x' is not free
+in 'f'.  So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0).
+
+We *do* want to specialise the call to 'g', because 'x' is free in g.
+Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1).
+
+Note [Avoiding fruitless liberate-case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider also:
+  f = \x. case top_lvl_thing of
+                I# _ -> let g = \y. ... g ...
+                        in ...
+
+Here, top_lvl_thing is scrutinised at a level (1) deeper than its
+binding site (0).  Nevertheless, we do NOT want to specialise the call
+to 'g' because all the structure in its free variables is already
+visible at the definition site for g.  Hence, when considering specialising
+an occurrence of 'g', we want to check that there's a scruted-var v st
+
+   a) v's binding site is *outside* g
+   b) v's scrutinisation site is *inside* g
+
+
+************************************************************************
+*                                                                      *
+        Utility functions
+*                                                                      *
+************************************************************************
+-}
+
+addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv
+addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders
+  = env { lc_lvl_env = lvl_env' }
+  where
+    lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl)
+
+addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv
+addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env,
+                             lc_rec_env = rec_env}) pairs
+  = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' }
+  where
+    lvl'     = lvl + 1
+    lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]
+    rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]
+
+addScrutedVar :: LibCaseEnv
+              -> Id             -- This Id is being scrutinised by a case expression
+              -> LibCaseEnv
+
+addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env,
+                                lc_scruts = scruts }) scrut_var
+  | bind_lvl < lvl
+  = env { lc_scruts = scruts' }
+        -- Add to scruts iff the scrut_var is being scrutinised at
+        -- a deeper level than its defn
+
+  | otherwise = env
+  where
+    scruts'  = (scrut_var, bind_lvl, lvl) : scruts
+    bind_lvl = case lookupVarEnv lvl_env scrut_var of
+                 Just lvl -> lvl
+                 Nothing  -> topLevel
+
+lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind
+lookupRecId env id = lookupVarEnv (lc_rec_env env) id
+
+lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
+lookupLevel env id
+  = case lookupVarEnv (lc_lvl_env env) id of
+      Just lvl -> lvl
+      Nothing  -> topLevel
+
+{-
+************************************************************************
+*                                                                      *
+         The environment
+*                                                                      *
+************************************************************************
+-}
+
+type LibCaseLevel = Int
+
+topLevel :: LibCaseLevel
+topLevel = 0
+
+data LibCaseEnv
+  = LibCaseEnv {
+        lc_dflags :: DynFlags,
+
+        lc_lvl :: LibCaseLevel, -- Current level
+                -- The level is incremented when (and only when) going
+                -- inside the RHS of a (sufficiently small) recursive
+                -- function.
+
+        lc_lvl_env :: IdEnv LibCaseLevel,
+                -- Binds all non-top-level in-scope Ids (top-level and
+                -- imported things have a level of zero)
+
+        lc_rec_env :: IdEnv CoreBind,
+                -- Binds *only* recursively defined ids, to their own
+                -- binding group, and *only* in their own RHSs
+
+        lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)]
+                -- Each of these Ids was scrutinised by an enclosing
+                -- case expression, at a level deeper than its binding
+                -- level.
+                --
+                -- The first LibCaseLevel is the *binding level* of
+                --   the scrutinised Id,
+                -- The second is the level *at which it was scrutinised*.
+                --   (see Note [Avoiding fruitless liberate-case])
+                -- The former is a bit redundant, since you could always
+                -- look it up in lc_lvl_env, but it's just cached here
+                --
+                -- The order is insignificant; it's a bag really
+                --
+                -- There's one element per scrutinisation;
+                --    in principle the same Id may appear multiple times,
+                --    although that'd be unusual:
+                --       case x of { (a,b) -> ....(case x of ...) .. }
+        }
+
+initEnv :: DynFlags -> LibCaseEnv
+initEnv dflags
+  = LibCaseEnv { lc_dflags = dflags,
+                 lc_lvl = 0,
+                 lc_lvl_env = emptyVarEnv,
+                 lc_rec_env = emptyVarEnv,
+                 lc_scruts = [] }
+
+-- Bomb-out size for deciding if
+-- potential liberatees are too big.
+-- (passed in from cmd-line args)
+bombOutSize :: LibCaseEnv -> Maybe Int
+bombOutSize = liberateCaseThreshold . lc_dflags
diff --git a/compiler/simplCore/SAT.hs b/compiler/simplCore/SAT.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/SAT.hs
@@ -0,0 +1,433 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+************************************************************************
+
+               Static Argument Transformation pass
+
+************************************************************************
+
+May be seen as removing invariants from loops:
+Arguments of recursive functions that do not change in recursive
+calls are removed from the recursion, which is done locally
+and only passes the arguments which effectively change.
+
+Example:
+map = /\ ab -> \f -> \xs -> case xs of
+                 []       -> []
+                 (a:b) -> f a : map f b
+
+as map is recursively called with the same argument f (unmodified)
+we transform it to
+
+map = /\ ab -> \f -> \xs -> let map' ys = case ys of
+                       []     -> []
+                       (a:b) -> f a : map' b
+                in map' xs
+
+Notice that for a compiler that uses lambda lifting this is
+useless as map' will be transformed back to what map was.
+
+We could possibly do the same for big lambdas, but we don't as
+they will eventually be removed in later stages of the compiler,
+therefore there is no penalty in keeping them.
+
+We only apply the SAT when the number of static args is > 2. This
+produces few bad cases.  See
+                should_transform
+in saTransform.
+
+Here are the headline nofib results:
+                  Size    Allocs   Runtime
+Min             +0.0%    -13.7%    -21.4%
+Max             +0.1%     +0.0%     +5.4%
+Geometric Mean  +0.0%     -0.2%     -6.9%
+
+The previous patch, to fix polymorphic floatout demand signatures, is
+essential to make this work well!
+-}
+
+{-# LANGUAGE CPP #-}
+module SAT ( doStaticArgs ) where
+
+import GhcPrelude
+
+import Var
+import CoreSyn
+import CoreUtils
+import Type
+import Coercion
+import Id
+import Name
+import VarEnv
+import UniqSupply
+import Util
+import UniqFM
+import VarSet
+import Unique
+import UniqSet
+import Outputable
+
+import Data.List
+import FastString
+
+#include "HsVersions.h"
+
+doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram
+doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds
+  where
+    sat_bind_threaded_us us bind =
+        let (us1, us2) = splitUniqSupply us
+        in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet))
+
+-- We don't bother to SAT recursive groups since it can lead
+-- to massive code expansion: see Andre Santos' thesis for details.
+-- This means we only apply the actual SAT to Rec groups of one element,
+-- but we want to recurse into the others anyway to discover other binds
+satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo)
+satBind (NonRec binder expr) interesting_ids = do
+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
+    return (NonRec binder expr', finalizeApp expr_app sat_info_expr)
+satBind (Rec [(binder, rhs)]) interesting_ids = do
+    let interesting_ids' = interesting_ids `addOneToUniqSet` binder
+        (rhs_binders, rhs_body) = collectBinders rhs
+    (rhs_body', sat_info_rhs_body) <- satTopLevelExpr rhs_body interesting_ids'
+    let sat_info_rhs_from_args = unitVarEnv binder (bindersToSATInfo rhs_binders)
+        sat_info_rhs' = mergeIdSATInfo sat_info_rhs_from_args sat_info_rhs_body
+
+        shadowing = binder `elementOfUniqSet` interesting_ids
+        sat_info_rhs'' = if shadowing
+                        then sat_info_rhs' `delFromUFM` binder -- For safety
+                        else sat_info_rhs'
+
+    bind' <- saTransformMaybe binder (lookupUFM sat_info_rhs' binder)
+                              rhs_binders rhs_body'
+    return (bind', sat_info_rhs'')
+satBind (Rec pairs) interesting_ids = do
+    let (binders, rhss) = unzip pairs
+    rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss
+    let (rhss', sat_info_rhss') = unzip rhss_SATed
+    return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss')
+
+data App = VarApp Id | TypeApp Type | CoApp Coercion
+data Staticness a = Static a | NotStatic
+
+type IdAppInfo = (Id, SATInfo)
+
+type SATInfo = [Staticness App]
+type IdSATInfo = IdEnv SATInfo
+emptyIdSATInfo :: IdSATInfo
+emptyIdSATInfo = emptyUFM
+
+{-
+pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info))
+  where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info)
+-}
+
+pprSATInfo :: SATInfo -> SDoc
+pprSATInfo staticness = hcat $ map pprStaticness staticness
+
+pprStaticness :: Staticness App -> SDoc
+pprStaticness (Static (VarApp _))  = text "SV"
+pprStaticness (Static (TypeApp _)) = text "ST"
+pprStaticness (Static (CoApp _))   = text "SC"
+pprStaticness NotStatic            = text "NS"
+
+
+mergeSATInfo :: SATInfo -> SATInfo -> SATInfo
+mergeSATInfo l r = zipWith mergeSA l r
+  where
+    mergeSA NotStatic _ = NotStatic
+    mergeSA _ NotStatic = NotStatic
+    mergeSA (Static (VarApp v)) (Static (VarApp v'))
+      | v == v'   = Static (VarApp v)
+      | otherwise = NotStatic
+    mergeSA (Static (TypeApp t)) (Static (TypeApp t'))
+      | t `eqType` t' = Static (TypeApp t)
+      | otherwise     = NotStatic
+    mergeSA (Static (CoApp c)) (Static (CoApp c'))
+      | c `eqCoercion` c' = Static (CoApp c)
+      | otherwise             = NotStatic
+    mergeSA _ _  = pprPanic "mergeSATInfo" $
+                          text "Left:"
+                       <> pprSATInfo l <> text ", "
+                       <> text "Right:"
+                       <> pprSATInfo r
+
+mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo
+mergeIdSATInfo = plusUFM_C mergeSATInfo
+
+mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo
+mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo
+
+bindersToSATInfo :: [Id] -> SATInfo
+bindersToSATInfo vs = map (Static . binderToApp) vs
+    where binderToApp v | isId v    = VarApp v
+                        | isTyVar v = TypeApp $ mkTyVarTy v
+                        | otherwise = CoApp $ mkCoVarCo v
+
+finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo
+finalizeApp Nothing id_sat_info = id_sat_info
+finalizeApp (Just (v, sat_info')) id_sat_info =
+    let sat_info'' = case lookupUFM id_sat_info v of
+                        Nothing -> sat_info'
+                        Just sat_info -> mergeSATInfo sat_info sat_info'
+    in extendVarEnv id_sat_info v sat_info''
+
+satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo)
+satTopLevelExpr expr interesting_ids = do
+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
+    return (expr', finalizeApp expr_app sat_info_expr)
+
+satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)
+satExpr var@(Var v) interesting_ids = do
+    let app_info = if v `elementOfUniqSet` interesting_ids
+                   then Just (v, [])
+                   else Nothing
+    return (var, emptyIdSATInfo, app_info)
+
+satExpr lit@(Lit _) _ = do
+    return (lit, emptyIdSATInfo, Nothing)
+
+satExpr (Lam binders body) interesting_ids = do
+    (body', sat_info, this_app) <- satExpr body interesting_ids
+    return (Lam binders body', finalizeApp this_app sat_info, Nothing)
+
+satExpr (App fn arg) interesting_ids = do
+    (fn', sat_info_fn, fn_app) <- satExpr fn interesting_ids
+    let satRemainder = boring fn' sat_info_fn
+    case fn_app of
+        Nothing -> satRemainder Nothing
+        Just (fn_id, fn_app_info) ->
+            -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface)
+            let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness])
+            in case arg of
+                Type t     -> satRemainderWithStaticness $ Static (TypeApp t)
+                Coercion c -> satRemainderWithStaticness $ Static (CoApp c)
+                Var v      -> satRemainderWithStaticness $ Static (VarApp v)
+                _          -> satRemainderWithStaticness $ NotStatic
+  where
+    boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)
+    boring fn' sat_info_fn app_info =
+        do (arg', sat_info_arg, arg_app) <- satExpr arg interesting_ids
+           let sat_info_arg' = finalizeApp arg_app sat_info_arg
+               sat_info = mergeIdSATInfo sat_info_fn sat_info_arg'
+           return (App fn' arg', sat_info, app_info)
+
+satExpr (Case expr bndr ty alts) interesting_ids = do
+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
+    let sat_info_expr' = finalizeApp expr_app sat_info_expr
+
+    zipped_alts' <- mapM satAlt alts
+    let (alts', sat_infos_alts) = unzip zipped_alts'
+    return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing)
+  where
+    satAlt (con, bndrs, expr) = do
+        (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids
+        return ((con, bndrs, expr'), sat_info_expr)
+
+satExpr (Let bind body) interesting_ids = do
+    (body', sat_info_body, body_app) <- satExpr body interesting_ids
+    (bind', sat_info_bind) <- satBind bind interesting_ids
+    return (Let bind' body', mergeIdSATInfo sat_info_body sat_info_bind, body_app)
+
+satExpr (Tick tickish expr) interesting_ids = do
+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
+    return (Tick tickish expr', sat_info_expr, expr_app)
+
+satExpr ty@(Type _) _ = do
+    return (ty, emptyIdSATInfo, Nothing)
+
+satExpr co@(Coercion _) _ = do
+    return (co, emptyIdSATInfo, Nothing)
+
+satExpr (Cast expr coercion) interesting_ids = do
+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids
+    return (Cast expr' coercion, sat_info_expr, expr_app)
+
+{-
+************************************************************************
+
+                Static Argument Transformation Monad
+
+************************************************************************
+-}
+
+type SatM result = UniqSM result
+
+runSAT :: UniqSupply -> SatM a -> a
+runSAT = initUs_
+
+newUnique :: SatM Unique
+newUnique = getUniqueM
+
+{-
+************************************************************************
+
+                Static Argument Transformation Monad
+
+************************************************************************
+
+To do the transformation, the game plan is to:
+
+1. Create a small nonrecursive RHS that takes the
+   original arguments to the function but discards
+   the ones that are static and makes a call to the
+   SATed version with the remainder. We intend that
+   this will be inlined later, removing the overhead
+
+2. Bind this nonrecursive RHS over the original body
+   WITH THE SAME UNIQUE as the original body so that
+   any recursive calls to the original now go via
+   the small wrapper
+
+3. Rebind the original function to a new one which contains
+   our SATed function and just makes a call to it:
+   we call the thing making this call the local body
+
+Example: transform this
+
+    map :: forall a b. (a->b) -> [a] -> [b]
+    map = /\ab. \(f:a->b) (as:[a]) -> body[map]
+to
+    map :: forall a b. (a->b) -> [a] -> [b]
+    map = /\ab. \(f:a->b) (as:[a]) ->
+         letrec map' :: [a] -> [b]
+                    -- The "worker function
+                map' = \(as:[a]) ->
+                         let map :: forall a' b'. (a -> b) -> [a] -> [b]
+                                -- The "shadow function
+                             map = /\a'b'. \(f':(a->b) (as:[a]).
+                                   map' as
+                         in body[map]
+         in map' as
+
+Note [Shadow binding]
+~~~~~~~~~~~~~~~~~~~~~
+The calls to the inner map inside body[map] should get inlined
+by the local re-binding of 'map'.  We call this the "shadow binding".
+
+But we can't use the original binder 'map' unchanged, because
+it might be exported, in which case the shadow binding won't be
+discarded as dead code after it is inlined.
+
+So we use a hack: we make a new SysLocal binder with the *same* unique
+as binder.  (Another alternative would be to reset the export flag.)
+
+Note [Binder type capture]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Notice that in the inner map (the "shadow function"), the static arguments
+are discarded -- it's as if they were underscores.  Instead, mentions
+of these arguments (notably in the types of dynamic arguments) are bound
+by the *outer* lambdas of the main function.  So we must make up fresh
+names for the static arguments so that they do not capture variables
+mentioned in the types of dynamic args.
+
+In the map example, the shadow function must clone the static type
+argument a,b, giving a',b', to ensure that in the \(as:[a]), the 'a'
+is bound by the outer forall.  We clone f' too for consistency, but
+that doesn't matter either way because static Id arguments aren't
+mentioned in the shadow binding at all.
+
+If we don't we get something like this:
+
+[Exported]
+[Arity 3]
+GHC.Base.until =
+  \ (@ a_aiK)
+    (p_a6T :: a_aiK -> GHC.Types.Bool)
+    (f_a6V :: a_aiK -> a_aiK)
+    (x_a6X :: a_aiK) ->
+    letrec {
+      sat_worker_s1aU :: a_aiK -> a_aiK
+      []
+      sat_worker_s1aU =
+        \ (x_a6X :: a_aiK) ->
+          let {
+            sat_shadow_r17 :: forall a_a3O.
+                              (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O
+            []
+            sat_shadow_r17 =
+              \ (@ a_aiK)
+                (p_a6T :: a_aiK -> GHC.Types.Bool)
+                (f_a6V :: a_aiK -> a_aiK)
+                (x_a6X :: a_aiK) ->
+                sat_worker_s1aU x_a6X } in
+          case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] {
+            GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X);
+            GHC.Types.True -> x_a6X
+          }; } in
+    sat_worker_s1aU x_a6X
+
+Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK
+type argument. This is bad because it means the application sat_worker_s1aU x_a6X
+is not well typed.
+-}
+
+saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind
+saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body
+  | Just arg_staticness <- maybe_arg_staticness
+  , should_transform arg_staticness
+  = saTransform binder arg_staticness rhs_binders rhs_body
+  | otherwise
+  = return (Rec [(binder, mkLams rhs_binders rhs_body)])
+  where
+    should_transform staticness = n_static_args > 1 -- THIS IS THE DECISION POINT
+      where
+        n_static_args = count isStaticValue staticness
+
+saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind
+saTransform binder arg_staticness rhs_binders rhs_body
+  = do  { shadow_lam_bndrs <- mapM clone binders_w_staticness
+        ; uniq             <- newUnique
+        ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) }
+  where
+    -- Running example: foldr
+    -- foldr \alpha \beta c n xs = e, for some e
+    -- arg_staticness = [Static TypeApp, Static TypeApp, Static VarApp, Static VarApp, NonStatic]
+    -- rhs_binders = [\alpha, \beta, c, n, xs]
+    -- rhs_body = e
+
+    binders_w_staticness = rhs_binders `zip` (arg_staticness ++ repeat NotStatic)
+                                        -- Any extra args are assumed NotStatic
+
+    non_static_args :: [Var]
+            -- non_static_args = [xs]
+            -- rhs_binders_without_type_capture = [\alpha', \beta', c, n, xs]
+    non_static_args = [v | (v, NotStatic) <- binders_w_staticness]
+
+    clone (bndr, NotStatic) = return bndr
+    clone (bndr, _        ) = do { uniq <- newUnique
+                                 ; return (setVarUnique bndr uniq) }
+
+    -- new_rhs = \alpha beta c n xs ->
+    --           let sat_worker = \xs -> let sat_shadow = \alpha' beta' c n xs ->
+    --                                       sat_worker xs
+    --                                   in e
+    --           in sat_worker xs
+    mk_new_rhs uniq shadow_lam_bndrs
+        = mkLams rhs_binders $
+          Let (Rec [(rec_body_bndr, rec_body)])
+          local_body
+        where
+          local_body = mkVarApps (Var rec_body_bndr) non_static_args
+
+          rec_body = mkLams non_static_args $
+                     Let (NonRec shadow_bndr shadow_rhs) rhs_body
+
+            -- See Note [Binder type capture]
+          shadow_rhs = mkLams shadow_lam_bndrs local_body
+            -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs
+
+          rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq (exprType rec_body)
+            -- rec_body_bndr = sat_worker
+
+            -- See Note [Shadow binding]; make a SysLocal
+          shadow_bndr = mkSysLocal (occNameFS (getOccName binder))
+                                   (idUnique binder)
+                                   (exprType shadow_rhs)
+
+isStaticValue :: Staticness App -> Bool
+isStaticValue (Static (VarApp _)) = True
+isStaticValue _                   = False
diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/SetLevels.hs
@@ -0,0 +1,1722 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section{SetLevels}
+
+                ***************************
+                        Overview
+                ***************************
+
+1. We attach binding levels to Core bindings, in preparation for floating
+   outwards (@FloatOut@).
+
+2. We also let-ify many expressions (notably case scrutinees), so they
+   will have a fighting chance of being floated sensible.
+
+3. Note [Need for cloning during float-out]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   We clone the binders of any floatable let-binding, so that when it is
+   floated out it will be unique. Example
+      (let x=2 in x) + (let x=3 in x)
+   we must clone before floating so we get
+      let x1=2 in
+      let x2=3 in
+      x1+x2
+
+   NOTE: this can't be done using the uniqAway idea, because the variable
+         must be unique in the whole program, not just its current scope,
+         because two variables in different scopes may float out to the
+         same top level place
+
+   NOTE: Very tiresomely, we must apply this substitution to
+         the rules stored inside a variable too.
+
+   We do *not* clone top-level bindings, because some of them must not change,
+   but we *do* clone bindings that are heading for the top level
+
+4. Note [Binder-swap during float-out]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   In the expression
+        case x of wild { p -> ...wild... }
+   we substitute x for wild in the RHS of the case alternatives:
+        case x of wild { p -> ...x... }
+   This means that a sub-expression involving x is not "trapped" inside the RHS.
+   And it's not inconvenient because we already have a substitution.
+
+  Note that this is EXACTLY BACKWARDS from the what the simplifier does.
+  The simplifier tries to get rid of occurrences of x, in favour of wild,
+  in the hope that there will only be one remaining occurrence of x, namely
+  the scrutinee of the case, and we can inline it.
+-}
+
+{-# LANGUAGE CPP, MultiWayIf #-}
+module SetLevels (
+        setLevels,
+
+        Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl,
+        LevelledBind, LevelledExpr, LevelledBndr,
+        FloatSpec(..), floatSpecLevel,
+
+        incMinorLvl, ltMajLvl, ltLvl, isTopLvl
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSyn
+import CoreMonad        ( FloatOutSwitches(..) )
+import CoreUtils        ( exprType, exprIsHNF
+                        , exprOkForSpeculation
+                        , exprIsTopLevelBindable
+                        , isExprLevPoly
+                        , collectMakeStaticArgs
+                        )
+import CoreArity        ( exprBotStrictness_maybe )
+import CoreFVs          -- all of it
+import CoreSubst
+import MkCore           ( sortQuantVars )
+
+import Id
+import IdInfo
+import Var
+import VarSet
+import UniqSet          ( nonDetFoldUniqSet )
+import UniqDSet         ( getUniqDSet )
+import VarEnv
+import Literal          ( litIsTrivial )
+import Demand           ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity )
+import Name             ( getOccName, mkSystemVarName )
+import OccName          ( occNameString )
+import Type             ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType, closeOverKindsDSet )
+import BasicTypes       ( Arity, RecFlag(..), isRec )
+import DataCon          ( dataConOrigResTy )
+import TysWiredIn
+import UniqSupply
+import Util
+import Outputable
+import FastString
+import UniqDFM
+import FV
+import Data.Maybe
+import MonadUtils       ( mapAccumLM )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Level numbers}
+*                                                                      *
+************************************************************************
+-}
+
+type LevelledExpr = TaggedExpr FloatSpec
+type LevelledBind = TaggedBind FloatSpec
+type LevelledBndr = TaggedBndr FloatSpec
+
+data Level = Level Int  -- Level number of enclosing lambdas
+                   Int  -- Number of big-lambda and/or case expressions and/or
+                        -- context boundaries between
+                        -- here and the nearest enclosing lambda
+                   LevelType -- Binder or join ceiling?
+data LevelType = BndrLvl | JoinCeilLvl deriving (Eq)
+
+data FloatSpec
+  = FloatMe Level       -- Float to just inside the binding
+                        --    tagged with this level
+  | StayPut Level       -- Stay where it is; binding is
+                        --     tagged with this level
+
+floatSpecLevel :: FloatSpec -> Level
+floatSpecLevel (FloatMe l) = l
+floatSpecLevel (StayPut l) = l
+
+{-
+The {\em level number} on a (type-)lambda-bound variable is the
+nesting depth of the (type-)lambda which binds it.  The outermost lambda
+has level 1, so (Level 0 0) means that the variable is bound outside any lambda.
+
+On an expression, it's the maximum level number of its free
+(type-)variables.  On a let(rec)-bound variable, it's the level of its
+RHS.  On a case-bound variable, it's the number of enclosing lambdas.
+
+Top-level variables: level~0.  Those bound on the RHS of a top-level
+definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown
+as ``subscripts'')...
+\begin{verbatim}
+a_0 = let  b_? = ...  in
+           x_1 = ... b ... in ...
+\end{verbatim}
+
+The main function @lvlExpr@ carries a ``context level'' (@le_ctxt_lvl@).
+That's meant to be the level number of the enclosing binder in the
+final (floated) program.  If the level number of a sub-expression is
+less than that of the context, then it might be worth let-binding the
+sub-expression so that it will indeed float.
+
+If you can float to level @Level 0 0@ worth doing so because then your
+allocation becomes static instead of dynamic.  We always start with
+context @Level 0 0@.
+
+
+Note [FloatOut inside INLINE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose:
+to say "don't float anything out of here".  That's exactly what we
+want for the body of an INLINE, where we don't want to float anything
+out at all.  See notes with lvlMFE below.
+
+But, check this out:
+
+-- At one time I tried the effect of not floating anything out of an InlineMe,
+-- but it sometimes works badly.  For example, consider PrelArr.done.  It
+-- has the form         __inline (\d. e)
+-- where e doesn't mention d.  If we float this to
+--      __inline (let x = e in \d. x)
+-- things are bad.  The inliner doesn't even inline it because it doesn't look
+-- like a head-normal form.  So it seems a lesser evil to let things float.
+-- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe
+-- which discourages floating out.
+
+So the conclusion is: don't do any floating at all inside an InlineMe.
+(In the above example, don't float the {x=e} out of the \d.)
+
+One particular case is that of workers: we don't want to float the
+call to the worker outside the wrapper, otherwise the worker might get
+inlined into the floated expression, and an importing module won't see
+the worker at all.
+
+Note [Join ceiling]
+~~~~~~~~~~~~~~~~~~~
+Join points can't float very far; too far, and they can't remain join points
+So, suppose we have:
+
+  f x = (joinrec j y = ... x ... in jump j x) + 1
+
+One may be tempted to float j out to the top of f's RHS, but then the jump
+would not be a tail call. Thus we keep track of a level called the *join
+ceiling* past which join points are not allowed to float.
+
+The troublesome thing is that, unlike most levels to which something might
+float, there is not necessarily an identifier to which the join ceiling is
+attached. Fortunately, if something is to be floated to a join ceiling, it must
+be dropped at the *nearest* join ceiling. Thus each level is marked as to
+whether it is a join ceiling, so that FloatOut can tell which binders are being
+floated to the nearest join ceiling and which to a particular binder (or set of
+binders).
+-}
+
+instance Outputable FloatSpec where
+  ppr (FloatMe l) = char 'F' <> ppr l
+  ppr (StayPut l) = ppr l
+
+tOP_LEVEL :: Level
+tOP_LEVEL   = Level 0 0 BndrLvl
+
+incMajorLvl :: Level -> Level
+incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl
+
+incMinorLvl :: Level -> Level
+incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl
+
+asJoinCeilLvl :: Level -> Level
+asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl
+
+maxLvl :: Level -> Level -> Level
+maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _)
+  | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1
+  | otherwise                                      = l2
+
+ltLvl :: Level -> Level -> Bool
+ltLvl (Level maj1 min1 _) (Level maj2 min2 _)
+  = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)
+
+ltMajLvl :: Level -> Level -> Bool
+    -- Tells if one level belongs to a difft *lambda* level to another
+ltMajLvl (Level maj1 _ _) (Level maj2 _ _) = maj1 < maj2
+
+isTopLvl :: Level -> Bool
+isTopLvl (Level 0 0 _) = True
+isTopLvl _             = False
+
+isJoinCeilLvl :: Level -> Bool
+isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl
+
+instance Outputable Level where
+  ppr (Level maj min typ)
+    = hcat [ char '<', int maj, char ',', int min, char '>'
+           , ppWhen (typ == JoinCeilLvl) (char 'C') ]
+
+instance Eq Level where
+  (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Main level-setting code}
+*                                                                      *
+************************************************************************
+-}
+
+setLevels :: FloatOutSwitches
+          -> CoreProgram
+          -> UniqSupply
+          -> [LevelledBind]
+
+setLevels float_lams binds us
+  = initLvl us (do_them init_env binds)
+  where
+    init_env = initialEnv float_lams
+
+    do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind]
+    do_them _ [] = return []
+    do_them env (b:bs)
+      = do { (lvld_bind, env') <- lvlTopBind env b
+           ; lvld_binds <- do_them env' bs
+           ; return (lvld_bind : lvld_binds) }
+
+lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv)
+lvlTopBind env (NonRec bndr rhs)
+  = do { rhs' <- lvl_top env NonRecursive bndr rhs
+       ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr]
+       ; return (NonRec bndr' rhs', env') }
+
+lvlTopBind env (Rec pairs)
+  = do { let (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL
+                                               (map fst pairs)
+       ; rhss' <- mapM (\(b,r) -> lvl_top env' Recursive b r) pairs
+       ; return (Rec (bndrs' `zip` rhss'), env') }
+
+lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr
+lvl_top env is_rec bndr rhs
+  = lvlRhs env is_rec
+           (isBottomingId bndr)
+           Nothing  -- Not a join point
+           (freeVars rhs)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Setting expression levels}
+*                                                                      *
+************************************************************************
+
+Note [Floating over-saturated applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see (f x y), and (f x) is a redex (ie f's arity is 1),
+we call (f x) an "over-saturated application"
+
+Should we float out an over-sat app, if can escape a value lambda?
+It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2).
+But we don't want to do it for class selectors, because the work saved
+is minimal, and the extra local thunks allocated cost money.
+
+Arguably we could float even class-op applications if they were going to
+top level -- but then they must be applied to a constant dictionary and
+will almost certainly be optimised away anyway.
+-}
+
+lvlExpr :: LevelEnv             -- Context
+        -> CoreExprWithFVs      -- Input expression
+        -> LvlM LevelledExpr    -- Result expression
+
+{-
+The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing
+binder.  Here's an example
+
+        v = \x -> ...\y -> let r = case (..x..) of
+                                        ..x..
+                           in ..
+
+When looking at the rhs of @r@, @le_ctxt_lvl@ will be 1 because that's
+the level of @r@, even though it's inside a level-2 @\y@.  It's
+important that @le_ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we
+don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE
+--- because it isn't a *maximal* free expression.
+
+If there were another lambda in @r@'s rhs, it would get level-2 as well.
+-}
+
+lvlExpr env (_, AnnType ty)     = return (Type (CoreSubst.substTy (le_subst env) ty))
+lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co))
+lvlExpr env (_, AnnVar v)       = return (lookupVar env v)
+lvlExpr _   (_, AnnLit lit)     = return (Lit lit)
+
+lvlExpr env (_, AnnCast expr (_, co)) = do
+    expr' <- lvlNonTailExpr env expr
+    return (Cast expr' (substCo (le_subst env) co))
+
+lvlExpr env (_, AnnTick tickish expr) = do
+    expr' <- lvlNonTailExpr env expr
+    let tickish' = substTickish (le_subst env) tickish
+    return (Tick tickish' expr')
+
+lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr)
+
+-- We don't split adjacent lambdas.  That is, given
+--      \x y -> (x+1,y)
+-- we don't float to give
+--      \x -> let v = x+1 in \y -> (v,y)
+-- Why not?  Because partial applications are fairly rare, and splitting
+-- lambdas makes them more expensive.
+
+lvlExpr env expr@(_, AnnLam {})
+  = do { new_body <- lvlNonTailMFE new_env True body
+       ; return (mkLams new_bndrs new_body) }
+  where
+    (bndrs, body)        = collectAnnBndrs expr
+    (env1, bndrs1)       = substBndrsSL NonRecursive env bndrs
+    (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1
+        -- At one time we called a special version of collectBinders,
+        -- which ignored coercions, because we don't want to split
+        -- a lambda like this (\x -> coerce t (\s -> ...))
+        -- This used to happen quite a bit in state-transformer programs,
+        -- but not nearly so much now non-recursive newtypes are transparent.
+        -- [See SetLevels rev 1.50 for a version with this approach.]
+
+lvlExpr env (_, AnnLet bind body)
+  = do { (bind', new_env) <- lvlBind env bind
+       ; body' <- lvlExpr new_env body
+           -- No point in going via lvlMFE here.  If the binding is alive
+           -- (mentioned in body), and the whole let-expression doesn't
+           -- float, then neither will the body
+       ; return (Let bind' body') }
+
+lvlExpr env (_, AnnCase scrut case_bndr ty alts)
+  = do { scrut' <- lvlNonTailMFE env True scrut
+       ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts }
+
+lvlNonTailExpr :: LevelEnv             -- Context
+               -> CoreExprWithFVs      -- Input expression
+               -> LvlM LevelledExpr    -- Result expression
+lvlNonTailExpr env expr
+  = lvlExpr (placeJoinCeiling env) expr
+
+-------------------------------------------
+lvlApp :: LevelEnv
+       -> CoreExprWithFVs
+       -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application
+        -> LvlM LevelledExpr                   -- Result expression
+lvlApp env orig_expr ((_,AnnVar fn), args)
+  | floatOverSat env   -- See Note [Floating over-saturated applications]
+  , arity > 0
+  , arity < n_val_args
+  , Nothing <- isClassOpId_maybe fn
+  =  do { rargs' <- mapM (lvlNonTailMFE env False) rargs
+        ; lapp'  <- lvlNonTailMFE env False lapp
+        ; return (foldl' App lapp' rargs') }
+
+  | otherwise
+  = do { (_, args') <- mapAccumLM lvl_arg stricts args
+            -- Take account of argument strictness; see
+            -- Note [Floating to the top]
+       ; return (foldl' App (lookupVar env fn) args') }
+  where
+    n_val_args = count (isValArg . deAnnotate) args
+    arity      = idArity fn
+
+    stricts :: [Demand]   -- True for strict /value/ arguments
+    stricts = case splitStrictSig (idStrictness fn) of
+                (arg_ds, _) | arg_ds `lengthExceeds` n_val_args
+                            -> []
+                            | otherwise
+                            -> arg_ds
+
+    -- Separate out the PAP that we are floating from the extra
+    -- arguments, by traversing the spine until we have collected
+    -- (n_val_args - arity) value arguments.
+    (lapp, rargs) = left (n_val_args - arity) orig_expr []
+
+    left 0 e               rargs = (e, rargs)
+    left n (_, AnnApp f a) rargs
+       | isValArg (deAnnotate a) = left (n-1) f (a:rargs)
+       | otherwise               = left n     f (a:rargs)
+    left _ _ _                   = panic "SetLevels.lvlExpr.left"
+
+    is_val_arg :: CoreExprWithFVs -> Bool
+    is_val_arg (_, AnnType {}) = False
+    is_val_arg _               = True
+
+    lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr)
+    lvl_arg strs arg | (str1 : strs') <- strs
+                     , is_val_arg arg
+                     = do { arg' <- lvlMFE env (isStrictDmd str1) arg
+                          ; return (strs', arg') }
+                     | otherwise
+                     = do { arg' <- lvlMFE env False arg
+                          ; return (strs, arg') }
+
+lvlApp env _ (fun, args)
+  =  -- No PAPs that we can float: just carry on with the
+     -- arguments and the function.
+     do { args' <- mapM (lvlNonTailMFE env False) args
+        ; fun'  <- lvlNonTailExpr env fun
+        ; return (foldl' App fun' args') }
+
+-------------------------------------------
+lvlCase :: LevelEnv             -- Level of in-scope names/tyvars
+        -> DVarSet              -- Free vars of input scrutinee
+        -> LevelledExpr         -- Processed scrutinee
+        -> Id -> Type           -- Case binder and result type
+        -> [CoreAltWithFVs]     -- Input alternatives
+        -> LvlM LevelledExpr    -- Result expression
+lvlCase env scrut_fvs scrut' case_bndr ty alts
+  -- See Note [Floating single-alternative cases]
+  | [(con@(DataAlt {}), bs, body)] <- alts
+  , exprIsHNF (deTagExpr scrut')  -- See Note [Check the output scrutinee for exprIsHNF]
+  , not (isTopLvl dest_lvl)       -- Can't have top-level cases
+  , not (floatTopLvlOnly env)     -- Can float anywhere
+  =     -- Always float the case if possible
+        -- Unlike lets we don't insist that it escapes a value lambda
+    do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs)
+       ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut'
+       ; body' <- lvlMFE rhs_env True body
+       ; let alt' = (con, map (stayPut dest_lvl) bs', body')
+       ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) }
+
+  | otherwise     -- Stays put
+  = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr]
+             alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut'
+       ; alts' <- mapM (lvl_alt alts_env) alts
+       ; return (Case scrut' case_bndr' ty' alts') }
+  where
+    ty' = substTy (le_subst env) ty
+
+    incd_lvl = incMinorLvl (le_ctxt_lvl env)
+    dest_lvl = maxFvLevel (const True) env scrut_fvs
+            -- Don't abstract over type variables, hence const True
+
+    lvl_alt alts_env (con, bs, rhs)
+      = do { rhs' <- lvlMFE new_env True rhs
+           ; return (con, bs', rhs') }
+      where
+        (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs
+
+{- Note [Floating single-alternative cases]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+  data T a = MkT !a
+  f :: T Int -> blah
+  f x vs = case x of { MkT y ->
+             let f vs = ...(case y of I# w -> e)...f..
+             in f vs
+
+Here we can float the (case y ...) out, because y is sure
+to be evaluated, to give
+  f x vs = case x of { MkT y ->
+           caes y of I# w ->
+             let f vs = ...(e)...f..
+             in f vs
+
+That saves unboxing it every time round the loop.  It's important in
+some DPH stuff where we really want to avoid that repeated unboxing in
+the inner loop.
+
+Things to note:
+
+ * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation.
+
+     - exrpIsHNF catches the key case of an evaluated variable
+
+     - exprOkForSpeculation is /false/ of an evaluated variable;
+       See Note [exprOkForSpeculation and evaluated variables] in CoreUtils
+       So we'd actually miss the key case!
+
+     - Nothing is gained from the extra generality of exprOkForSpeculation
+       since we only consider floating a case whose single alternative
+       is a DataAlt   K a b -> rhs
+
+ * We can't float a case to top level
+
+ * It's worth doing this float even if we don't float
+   the case outside a value lambda.  Example
+     case x of {
+       MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...)
+   If we floated the cases out we could eliminate one of them.
+
+ * We only do this with a single-alternative case
+
+Note [Check the output scrutinee for exprIsHNF]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+  case x of y {
+    A -> ....(case y of alts)....
+  }
+
+Because of the binder-swap, the inner case will get substituted to
+(case x of ..).  So when testing whether the scrutinee is in HNF we
+must be careful to test the *result* scrutinee ('x' in this case), not
+the *input* one 'y'.  The latter *is* in HNF here (because y is
+evaluated), but the former is not -- and indeed we can't float the
+inner case out, at least not unless x is also evaluated at its binding
+site.  See Trac #5453.
+
+That's why we apply exprIsHNF to scrut' and not to scrut.
+
+See Note [Floating single-alternative cases] for why
+we use exprIsHNF in the first place.
+-}
+
+lvlNonTailMFE :: LevelEnv             -- Level of in-scope names/tyvars
+              -> Bool                 -- True <=> strict context [body of case
+                                      --   or let]
+              -> CoreExprWithFVs      -- input expression
+              -> LvlM LevelledExpr    -- Result expression
+lvlNonTailMFE env strict_ctxt ann_expr
+  = lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr
+
+lvlMFE ::  LevelEnv             -- Level of in-scope names/tyvars
+        -> Bool                 -- True <=> strict context [body of case or let]
+        -> CoreExprWithFVs      -- input expression
+        -> LvlM LevelledExpr    -- Result expression
+-- lvlMFE is just like lvlExpr, except that it might let-bind
+-- the expression, so that it can itself be floated.
+
+lvlMFE env _ (_, AnnType ty)
+  = return (Type (CoreSubst.substTy (le_subst env) ty))
+
+-- No point in floating out an expression wrapped in a coercion or note
+-- If we do we'll transform  lvl = e |> co
+--                       to  lvl' = e; lvl = lvl' |> co
+-- and then inline lvl.  Better just to float out the payload.
+lvlMFE env strict_ctxt (_, AnnTick t e)
+  = do { e' <- lvlMFE env strict_ctxt e
+       ; let t' = substTickish (le_subst env) t
+       ; return (Tick t' e') }
+
+lvlMFE env strict_ctxt (_, AnnCast e (_, co))
+  = do  { e' <- lvlMFE env strict_ctxt e
+        ; return (Cast e' (substCo (le_subst env) co)) }
+
+lvlMFE env strict_ctxt e@(_, AnnCase {})
+  | strict_ctxt       -- Don't share cases in a strict context
+  = lvlExpr env e     -- See Note [Case MFEs]
+
+lvlMFE env strict_ctxt ann_expr
+  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)
+         -- Only floating to the top level is allowed.
+  || anyDVarSet isJoinId fvs   -- If there is a free join, don't float
+                               -- See Note [Free join points]
+  || isExprLevPoly expr
+         -- We can't let-bind levity polymorphic expressions
+         -- See Note [Levity polymorphism invariants] in CoreSyn
+  || notWorthFloating expr abs_vars
+  || not float_me
+  =     -- Don't float it out
+    lvlExpr env ann_expr
+
+  |  float_is_new_lam || exprIsTopLevelBindable expr expr_ty
+         -- No wrapping needed if the type is lifted, or is a literal string
+         -- or if we are wrapping it in one or more value lambdas
+  = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive
+                              (isJust mb_bot_str)
+                              join_arity_maybe
+                              ann_expr
+                  -- Treat the expr just like a right-hand side
+       ; var <- newLvlVar expr1 join_arity_maybe is_mk_static
+       ; let var2 = annotateBotStr var float_n_lams mb_bot_str
+       ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)
+                     (mkVarApps (Var var2) abs_vars)) }
+
+  -- OK, so the float has an unlifted type (not top-level bindable)
+  --     and no new value lambdas (float_is_new_lam is False)
+  -- Try for the boxing strategy
+  -- See Note [Floating MFEs of unlifted type]
+  | escapes_value_lam
+  , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions
+                         -- See Note [Test cheapness with exprOkForSpeculation]
+  , Just (tc, _) <- splitTyConApp_maybe expr_ty
+  , Just dc <- boxingDataCon_maybe tc
+  , let dc_res_ty = dataConOrigResTy dc  -- No free type variables
+        [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty]
+  = do { expr1 <- lvlExpr rhs_env ann_expr
+       ; let l1r       = incMinorLvlFrom rhs_env
+             float_rhs = mkLams abs_vars_w_lvls $
+                         Case expr1 (stayPut l1r ubx_bndr) dc_res_ty
+                             [(DEFAULT, [], mkConApp dc [Var ubx_bndr])]
+
+       ; var <- newLvlVar float_rhs Nothing is_mk_static
+       ; let l1u      = incMinorLvlFrom env
+             use_expr = Case (mkVarApps (Var var) abs_vars)
+                             (stayPut l1u bx_bndr) expr_ty
+                             [(DataAlt dc, [stayPut l1u ubx_bndr], Var ubx_bndr)]
+       ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs)
+                     use_expr) }
+
+  | otherwise          -- e.g. do not float unboxed tuples
+  = lvlExpr env ann_expr
+
+  where
+    expr         = deAnnotate ann_expr
+    expr_ty      = exprType expr
+    fvs          = freeVarsOf ann_expr
+    fvs_ty       = tyCoVarsOfType expr_ty
+    is_bot       = isBottomThunk mb_bot_str
+    is_function  = isFunction ann_expr
+    mb_bot_str   = exprBotStrictness_maybe expr
+                           -- See Note [Bottoming floats]
+                           -- esp Bottoming floats (2)
+    expr_ok_for_spec = exprOkForSpeculation expr
+    dest_lvl     = destLevel env fvs fvs_ty is_function is_bot False
+    abs_vars     = abstractVars dest_lvl env fvs
+
+    -- float_is_new_lam: the floated thing will be a new value lambda
+    -- replacing, say (g (x+4)) by (lvl x).  No work is saved, nor is
+    -- allocation saved.  The benefit is to get it to the top level
+    -- and hence out of the body of this function altogether, making
+    -- it smaller and more inlinable
+    float_is_new_lam = float_n_lams > 0
+    float_n_lams     = count isId abs_vars
+
+    (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
+
+    join_arity_maybe = Nothing
+
+    is_mk_static = isJust (collectMakeStaticArgs expr)
+        -- Yuk: See Note [Grand plan for static forms] in main/StaticPtrTable
+
+        -- A decision to float entails let-binding this thing, and we only do
+        -- that if we'll escape a value lambda, or will go to the top level.
+    float_me = saves_work || saves_alloc || is_mk_static
+
+    -- We can save work if we can move a redex outside a value lambda
+    -- But if float_is_new_lam is True, then the redex is wrapped in a
+    -- a new lambda, so no work is saved
+    saves_work = escapes_value_lam && not float_is_new_lam
+
+    escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env)
+                  -- See Note [Escaping a value lambda]
+
+    -- See Note [Floating to the top]
+    saves_alloc =  isTopLvl dest_lvl
+                && floatConsts env
+                && (not strict_ctxt || is_bot || exprIsHNF expr)
+
+isBottomThunk :: Maybe (Arity, s) -> Bool
+-- See Note [Bottoming floats] (2)
+isBottomThunk (Just (0, _)) = True   -- Zero arity
+isBottomThunk _             = False
+
+{- Note [Floating to the top]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We are keen to float something to the top level, even if it does not
+escape a value lambda (and hence save work), for two reasons:
+
+  * Doing so makes the function smaller, by floating out
+    bottoming expressions, or integer or string literals.  That in
+    turn makes it easier to inline, with less duplication.
+
+  * (Minor) Doing so may turn a dynamic allocation (done by machine
+    instructions) into a static one. Minor because we are assuming
+    we are not escaping a value lambda.
+
+But do not so if:
+     - the context is a strict, and
+     - the expression is not a HNF, and
+     - the expression is not bottoming
+
+Exammples:
+
+* Bottoming
+      f x = case x of
+              0 -> error <big thing>
+              _ -> x+1
+  Here we want to float (error <big thing>) to top level, abstracting
+  over 'x', so as to make f's RHS smaller.
+
+* HNF
+      f = case y of
+            True  -> p:q
+            False -> blah
+  We may as well float the (p:q) so it becomes a static data structure.
+
+* Case scrutinee
+      f = case g True of ....
+  Don't float (g True) to top level; then we have the admin of a
+  top-level thunk to worry about, with zero gain.
+
+* Case alternative
+      h = case y of
+             True  -> g True
+             False -> False
+  Don't float (g True) to the top level
+
+* Arguments
+     t = f (g True)
+  If f is lazy, we /do/ float (g True) because then we can allocate
+  the thunk statically rather than dynamically.  But if f is strict
+  we don't (see the use of idStrictness in lvlApp).  It's not clear
+  if this test is worth the bother: it's only about CAFs!
+
+It's controlled by a flag (floatConsts), because doing this too
+early loses opportunities for RULES which (needless to say) are
+important in some nofib programs (gcd is an example).  [SPJ note:
+I think this is obselete; the flag seems always on.]
+
+Note [Floating join point bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Mostly we only float a join point if it can /stay/ a join point.  But
+there is one exception: if it can go to the top level (Trac #13286).
+Consider
+  f x = joinrec j y n = <...j y' n'...>
+        in jump j x 0
+
+Here we may just as well produce
+  j y n = <....j y' n'...>
+  f x = j x 0
+
+and now there is a chance that 'f' will be inlined at its call sites.
+It shouldn't make a lot of difference, but thes tests
+  perf/should_run/MethSharing
+  simplCore/should_compile/spec-inline
+and one nofib program, all improve if you do float to top, because
+of the resulting inlining of f.  So ok, let's do it.
+
+Note [Free join points]
+~~~~~~~~~~~~~~~~~~~~~~~
+We never float a MFE that has a free join-point variable.  You mght think
+this can never occur.  After all, consider
+     join j x = ...
+     in ....(jump j x)....
+How might we ever want to float that (jump j x)?
+  * If it would escape a value lambda, thus
+        join j x = ... in (\y. ...(jump j x)... )
+    then 'j' isn't a valid join point in the first place.
+
+But consider
+     join j x = .... in
+     joinrec j2 y =  ...(jump j x)...(a+b)....
+
+Since j2 is recursive, it /is/ worth floating (a+b) out of the joinrec.
+But it is emphatically /not/ good to float the (jump j x) out:
+ (a) 'j' will stop being a join point
+ (b) In any case, jumping to 'j' must be an exit of the j2 loop, so no
+     work would be saved by floating it out of the \y.
+
+Even if we floated 'j' to top level, (b) would still hold.
+
+Bottom line: never float a MFE that has a free JoinId.
+
+Note [Floating MFEs of unlifted type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+   case f x of (r::Int#) -> blah
+we'd like to float (f x). But it's not trivial because it has type
+Int#, and we don't want to evaluate it too early.  But we can instead
+float a boxed version
+   y = case f x of r -> I# r
+and replace the original (f x) with
+   case (case y of I# r -> r) of r -> blah
+
+Being able to float unboxed expressions is sometimes important; see
+Trac #12603.  I'm not sure how /often/ it is important, but it's
+not hard to achieve.
+
+We only do it for a fixed collection of types for which we have a
+convenient boxing constructor (see boxingDataCon_maybe).  In
+particular we /don't/ do it for unboxed tuples; it's better to float
+the components of the tuple individually.
+
+I did experiment with a form of boxing that works for any type, namely
+wrapping in a function.  In our example
+
+   let y = case f x of r -> \v. f x
+   in case y void of r -> blah
+
+It works fine, but it's 50% slower (based on some crude benchmarking).
+I suppose we could do it for types not covered by boxingDataCon_maybe,
+but it's more code and I'll wait to see if anyone wants it.
+
+Note [Test cheapness with exprOkForSpeculation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't want to float very cheap expressions by boxing and unboxing.
+But we use exprOkForSpeculation for the test, not exprIsCheap.
+Why?  Because it's important /not/ to transform
+     f (a /# 3)
+to
+     f (case bx of I# a -> a /# 3)
+and float bx = I# (a /# 3), because the application of f no
+longer obeys the let/app invariant.  But (a /# 3) is ok-for-spec
+due to a special hack that says division operators can't fail
+when the denominator is definitely non-zero.  And yet that
+same expression says False to exprIsCheap.  Simplest way to
+guarantee the let/app invariant is to use the same function!
+
+If an expression is okay for speculation, we could also float it out
+*without* boxing and unboxing, since evaluating it early is okay.
+However, it turned out to usually be better not to float such expressions,
+since they tend to be extremely cheap things like (x +# 1#). Even the
+cost of spilling the let-bound variable to the stack across a call may
+exceed the cost of recomputing such an expression. (And we can't float
+unlifted bindings to top-level.)
+
+We could try to do something smarter here, and float out expensive yet
+okay-for-speculation things, such as division by non-zero constants.
+But I suspect it's a narrow target.
+
+Note [Bottoming floats]
+~~~~~~~~~~~~~~~~~~~~~~~
+If we see
+        f = \x. g (error "urk")
+we'd like to float the call to error, to get
+        lvl = error "urk"
+        f = \x. g lvl
+
+But, as ever, we need to be careful:
+
+(1) We want to float a bottoming
+    expression even if it has free variables:
+        f = \x. g (let v = h x in error ("urk" ++ v))
+    Then we'd like to abstract over 'x' can float the whole arg of g:
+        lvl = \x. let v = h x in error ("urk" ++ v)
+        f = \x. g (lvl x)
+    To achieve this we pass is_bot to destLevel
+
+(2) We do not do this for lambdas that return
+    bottom.  Instead we treat the /body/ of such a function specially,
+    via point (1).  For example:
+        f = \x. ....(\y z. if x then error y else error z)....
+    ===>
+        lvl = \x z y. if b then error y else error z
+        f = \x. ...(\y z. lvl x z y)...
+    (There is no guarantee that we'll choose the perfect argument order.)
+
+(3) If we have a /binding/ that returns bottom, we want to float it to top
+    level, even if it has free vars (point (1)), and even it has lambdas.
+    Example:
+       ... let { v = \y. error (show x ++ show y) } in ...
+    We want to abstract over x and float the whole thing to top:
+       lvl = \xy. errror (show x ++ show y)
+       ...let {v = lvl x} in ...
+
+    Then of course we don't want to separately float the body (error ...)
+    as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot
+    argument.
+
+See Maessen's paper 1999 "Bottom extraction: factoring error handling out
+of functional programs" (unpublished I think).
+
+When we do this, we set the strictness and arity of the new bottoming
+Id, *immediately*, for three reasons:
+
+  * To prevent the abstracted thing being immediately inlined back in again
+    via preInlineUnconditionally.  The latter has a test for bottoming Ids
+    to stop inlining them, so we'd better make sure it *is* a bottoming Id!
+
+  * So that it's properly exposed as such in the interface file, even if
+    this is all happening after strictness analysis.
+
+  * In case we do CSE with the same expression that *is* marked bottom
+        lvl          = error "urk"
+          x{str=bot) = error "urk"
+    Here we don't want to replace 'x' with 'lvl', else we may get Lint
+    errors, e.g. via a case with empty alternatives:  (case x of {})
+    Lint complains unless the scrutinee of such a case is clearly bottom.
+
+    This was reported in Trac #11290.   But since the whole bottoming-float
+    thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure
+    that it'll nail all such cases.
+
+Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Tiresomely, though, the simplifier has an invariant that the manifest
+arity of the RHS should be the same as the arity; but we can't call
+etaExpand during SetLevels because it works over a decorated form of
+CoreExpr.  So we do the eta expansion later, in FloatOut.
+
+Note [Case MFEs]
+~~~~~~~~~~~~~~~~
+We don't float a case expression as an MFE from a strict context.  Why not?
+Because in doing so we share a tiny bit of computation (the switch) but
+in exchange we build a thunk, which is bad.  This case reduces allocation
+by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.
+Doesn't change any other allocation at all.
+
+We will make a separate decision for the scrutinee and alternatives.
+
+However this can have a knock-on effect for fusion: consider
+    \v -> foldr k z (case x of I# y -> build ..y..)
+Perhaps we can float the entire (case x of ...) out of the \v.  Then
+fusion will not happen, but we will get more sharing.  But if we don't
+float the case (as advocated here) we won't float the (build ...y..)
+either, so fusion will happen.  It can be a big effect, esp in some
+artificial benchmarks (e.g. integer, queens), but there is no perfect
+answer.
+
+-}
+
+annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id
+-- See Note [Bottoming floats] for why we want to add
+-- bottoming information right now
+--
+-- n_extra are the number of extra value arguments added during floating
+annotateBotStr id n_extra mb_str
+  = case mb_str of
+      Nothing           -> id
+      Just (arity, sig) -> id `setIdArity`      (arity + n_extra)
+                              `setIdStrictness` (increaseStrictSigArity n_extra sig)
+
+notWorthFloating :: CoreExpr -> [Var] -> Bool
+-- Returns True if the expression would be replaced by
+-- something bigger than it is now.  For example:
+--   abs_vars = tvars only:  return True if e is trivial,
+--                           but False for anything bigger
+--   abs_vars = [x] (an Id): return True for trivial, or an application (f x)
+--                           but False for (f x x)
+--
+-- One big goal is that floating should be idempotent.  Eg if
+-- we replace e with (lvl79 x y) and then run FloatOut again, don't want
+-- to replace (lvl79 x y) with (lvl83 x y)!
+
+notWorthFloating e abs_vars
+  = go e (count isId abs_vars)
+  where
+    go (Var {}) n    = n >= 0
+    go (Lit lit) n   = ASSERT( n==0 )
+                       litIsTrivial lit   -- Note [Floating literals]
+    go (Tick t e) n  = not (tickishIsCode t) && go e n
+    go (Cast e _)  n = go e n
+    go (App e arg) n
+       | Type {}     <- arg = go e n
+       | Coercion {} <- arg = go e n
+       | n==0               = False
+       | is_triv arg        = go e (n-1)
+       | otherwise          = False
+    go _ _                  = False
+
+    is_triv (Lit {})              = True        -- Treat all literals as trivial
+    is_triv (Var {})              = True        -- (ie not worth floating)
+    is_triv (Cast e _)            = is_triv e
+    is_triv (App e (Type {}))     = is_triv e
+    is_triv (App e (Coercion {})) = is_triv e
+    is_triv (Tick t e)            = not (tickishIsCode t) && is_triv e
+    is_triv _                     = False
+
+{-
+Note [Floating literals]
+~~~~~~~~~~~~~~~~~~~~~~~~
+It's important to float Integer literals, so that they get shared,
+rather than being allocated every time round the loop.
+Hence the litIsTrivial.
+
+Ditto literal strings (LitString), which we'd like to float to top
+level, which is now possible.
+
+
+Note [Escaping a value lambda]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to float even cheap expressions out of value lambdas,
+because that saves allocation.  Consider
+        f = \x.  .. (\y.e) ...
+Then we'd like to avoid allocating the (\y.e) every time we call f,
+(assuming e does not mention x). An example where this really makes a
+difference is simplrun009.
+
+Another reason it's good is because it makes SpecContr fire on functions.
+Consider
+        f = \x. ....(f (\y.e))....
+After floating we get
+        lvl = \y.e
+        f = \x. ....(f lvl)...
+and that is much easier for SpecConstr to generate a robust
+specialisation for.
+
+However, if we are wrapping the thing in extra value lambdas (in
+abs_vars), then nothing is saved.  E.g.
+        f = \xyz. ...(e1[y],e2)....
+If we float
+        lvl = \y. (e1[y],e2)
+        f = \xyz. ...(lvl y)...
+we have saved nothing: one pair will still be allocated for each
+call of 'f'.  Hence the (not float_is_lam) in float_me.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Bindings}
+*                                                                      *
+************************************************************************
+
+The binding stuff works for top level too.
+-}
+
+lvlBind :: LevelEnv
+        -> CoreBindWithFVs
+        -> LvlM (LevelledBind, LevelEnv)
+
+lvlBind env (AnnNonRec bndr rhs)
+  | isTyVar bndr    -- Don't do anything for TyVar binders
+                    --   (simplifier gets rid of them pronto)
+  || isCoVar bndr   -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)
+                    -- so we will ignore this case for now
+  || not (profitableFloat env dest_lvl)
+  || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty))
+          -- We can't float an unlifted binding to top level (except
+          -- literal strings), so we don't float it at all.  It's a
+          -- bit brutal, but unlifted bindings aren't expensive either
+
+  = -- No float
+    do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs
+       ; let  bind_lvl        = incMinorLvl (le_ctxt_lvl env)
+              (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]
+       ; return (NonRec bndr' rhs', env') }
+
+  -- Otherwise we are going to float
+  | null abs_vars
+  = do {  -- No type abstraction; clone existing binder
+         rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive
+                             is_bot mb_join_arity rhs
+       ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]
+       ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str
+       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
+
+  | otherwise
+  = do {  -- Yes, type abstraction; create a new binder, extend substitution, etc
+         rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive
+                             is_bot mb_join_arity rhs
+       ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]
+       ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str
+       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
+
+  where
+    bndr_ty    = idType bndr
+    ty_fvs     = tyCoVarsOfType bndr_ty
+    rhs_fvs    = freeVarsOf rhs
+    bind_fvs   = rhs_fvs `unionDVarSet` dIdFreeVars bndr
+    abs_vars   = abstractVars dest_lvl env bind_fvs
+    dest_lvl   = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join
+
+    deann_rhs  = deAnnotate rhs
+    mb_bot_str = exprBotStrictness_maybe deann_rhs
+    is_bot     = isJust mb_bot_str
+        -- NB: not isBottomThunk!  See Note [Bottoming floats] point (3)
+
+    n_extra    = count isId abs_vars
+    mb_join_arity = isJoinId_maybe bndr
+    is_join       = isJust mb_join_arity
+
+lvlBind env (AnnRec pairs)
+  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)
+         -- Only floating to the top level is allowed.
+  || not (profitableFloat env dest_lvl)
+  = do { let bind_lvl       = incMinorLvl (le_ctxt_lvl env)
+             (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs
+             lvl_rhs (b,r)  = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r
+       ; rhss' <- mapM lvl_rhs pairs
+       ; return (Rec (bndrs' `zip` rhss'), env') }
+
+  | null abs_vars
+  = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs
+       ; new_rhss <- mapM (do_rhs new_env) pairs
+       ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)
+                , new_env) }
+
+-- ToDo: when enabling the floatLambda stuff,
+--       I think we want to stop doing this
+  | [(bndr,rhs)] <- pairs
+  , count isId abs_vars > 1
+  = do  -- Special case for self recursion where there are
+        -- several variables carried around: build a local loop:
+        --      poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars
+        -- This just makes the closures a bit smaller.  If we don't do
+        -- this, allocation rises significantly on some programs
+        --
+        -- We could elaborate it for the case where there are several
+        -- mutually recursive functions, but it's quite a bit more complicated
+        --
+        -- This all seems a bit ad hoc -- sigh
+    let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars
+        rhs_lvl = le_ctxt_lvl rhs_env
+
+    (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr]
+    let
+        (lam_bndrs, rhs_body)   = collectAnnBndrs rhs
+        (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs
+        (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1
+    new_rhs_body <- lvlRhs body_env2 Recursive is_bot (get_join bndr) rhs_body
+    (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]
+    return (Rec [(TB poly_bndr (FloatMe dest_lvl)
+                 , mkLams abs_vars_w_lvls $
+                   mkLams lam_bndrs2 $
+                   Let (Rec [( TB new_bndr (StayPut rhs_lvl)
+                             , mkLams lam_bndrs2 new_rhs_body)])
+                       (mkVarApps (Var new_bndr) lam_bndrs1))]
+           , poly_env)
+
+  | otherwise  -- Non-null abs_vars
+  = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs
+       ; new_rhss <- mapM (do_rhs new_env) pairs
+       ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)
+                , new_env) }
+
+  where
+    (bndrs,rhss) = unzip pairs
+    is_join  = isJoinId (head bndrs)
+                -- bndrs is always non-empty and if one is a join they all are
+                -- Both are checked by Lint
+    is_fun   = all isFunction rhss
+    is_bot   = False  -- It's odd to have an unconditionally divergent
+                      -- function in a Rec, and we don't much care what
+                      -- happens to it.  False is simple!
+
+    do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive
+                                        is_bot (get_join bndr)
+                                        rhs
+
+    get_join bndr | need_zap  = Nothing
+                  | otherwise = isJoinId_maybe bndr
+    need_zap = dest_lvl `ltLvl` joinCeilingLevel env
+
+        -- Finding the free vars of the binding group is annoying
+    bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs])
+                `unionDVarSet`
+                (fvDVarSet $ unionsFV [ idFVs bndr
+                                      | (bndr, (_,_)) <- pairs]))
+               `delDVarSetList`
+                bndrs
+
+    ty_fvs   = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs
+    dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join
+    abs_vars = abstractVars dest_lvl env bind_fvs
+
+profitableFloat :: LevelEnv -> Level -> Bool
+profitableFloat env dest_lvl
+  =  (dest_lvl `ltMajLvl` le_ctxt_lvl env)  -- Escapes a value lambda
+  || isTopLvl dest_lvl                      -- Going all the way to top level
+
+
+----------------------------------------------------
+-- Three help functions for the type-abstraction case
+
+lvlRhs :: LevelEnv
+       -> RecFlag
+       -> Bool               -- Is this a bottoming function
+       -> Maybe JoinArity
+       -> CoreExprWithFVs
+       -> LvlM LevelledExpr
+lvlRhs env rec_flag is_bot mb_join_arity expr
+  = lvlFloatRhs [] (le_ctxt_lvl env) env
+                rec_flag is_bot mb_join_arity expr
+
+lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag
+            -> Bool   -- Binding is for a bottoming function
+            -> Maybe JoinArity
+            -> CoreExprWithFVs
+            -> LvlM (Expr LevelledBndr)
+-- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline
+lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs
+  = do { body' <- if not is_bot  -- See Note [Floating from a RHS]
+                     && any isId bndrs
+                  then lvlMFE  body_env True body
+                  else lvlExpr body_env      body
+       ; return (mkLams bndrs' body') }
+  where
+    (bndrs, body)     | Just join_arity <- mb_join_arity
+                      = collectNAnnBndrs join_arity rhs
+                      | otherwise
+                      = collectAnnBndrs rhs
+    (env1, bndrs1)    = substBndrsSL NonRecursive env bndrs
+    all_bndrs         = abs_vars ++ bndrs1
+    (body_env, bndrs') | Just _ <- mb_join_arity
+                      = lvlJoinBndrs env1 dest_lvl rec all_bndrs
+                      | otherwise
+                      = case lvlLamBndrs env1 dest_lvl all_bndrs of
+                          (env2, bndrs') -> (placeJoinCeiling env2, bndrs')
+        -- The important thing here is that we call lvlLamBndrs on
+        -- all these binders at once (abs_vars and bndrs), so they
+        -- all get the same major level.  Otherwise we create stupid
+        -- let-bindings inside, joyfully thinking they can float; but
+        -- in the end they don't because we never float bindings in
+        -- between lambdas
+
+{- Note [Floating from a RHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When floating the RHS of a let-binding, we don't always want to apply
+lvlMFE to the body of a lambda, as we usually do, because the entire
+binding body is already going to the right place (dest_lvl).
+
+A particular example is the top level.  Consider
+   concat = /\ a -> foldr ..a.. (++) []
+We don't want to float the body of the lambda to get
+   lvl    = /\ a -> foldr ..a.. (++) []
+   concat = /\ a -> lvl a
+That would be stupid.
+
+Previously this was avoided in a much nastier way, by testing strict_ctxt
+in float_me in lvlMFE.  But that wasn't even right because it would fail
+to float out the error sub-expression in
+    f = \x. case x of
+              True  -> error ("blah" ++ show x)
+              False -> ...
+
+But we must be careful:
+
+* If we had
+    f = \x -> factorial 20
+  we /would/ want to float that (factorial 20) out!  Functions are treated
+  differently: see the use of isFunction in the calls to destLevel. If
+  there are only type lambdas, then destLevel will say "go to top, and
+  abstract over the free tyvars" and we don't want that here.
+
+* But if we had
+    f = \x -> error (...x....)
+  we would NOT want to float the bottoming expression out to give
+    lvl = \x -> error (...x...)
+    f = \x -> lvl x
+
+Conclusion: use lvlMFE if there are
+  * any value lambdas in the original function, and
+  * this is not a bottoming function (the is_bot argument)
+Use lvlExpr otherwise.  A little subtle, and I got it wrong at least twice
+(e.g. Trac #13369).
+-}
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Deciding floatability}
+*                                                                      *
+************************************************************************
+-}
+
+substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr])
+substAndLvlBndrs is_rec env lvl bndrs
+  = lvlBndrs subst_env lvl subst_bndrs
+  where
+    (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs
+
+substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar])
+-- So named only to avoid the name clash with CoreSubst.substBndrs
+substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs
+  = ( env { le_subst    = subst'
+          , le_env      = foldl' add_id  id_env (bndrs `zip` bndrs') }
+    , bndrs')
+  where
+    (subst', bndrs') = case is_rec of
+                         NonRecursive -> substBndrs    subst bndrs
+                         Recursive    -> substRecBndrs subst bndrs
+
+lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr])
+-- Compute the levels for the binders of a lambda group
+lvlLamBndrs env lvl bndrs
+  = lvlBndrs env new_lvl bndrs
+  where
+    new_lvl | any is_major bndrs = incMajorLvl lvl
+            | otherwise          = incMinorLvl lvl
+
+    is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr)
+       -- The "probably" part says "don't float things out of a
+       -- probable one-shot lambda"
+       -- See Note [Computing one-shot info] in Demand.hs
+
+lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar]
+             -> (LevelEnv, [LevelledBndr])
+lvlJoinBndrs env lvl rec bndrs
+  = lvlBndrs env new_lvl bndrs
+  where
+    new_lvl | isRec rec = incMajorLvl lvl
+            | otherwise = incMinorLvl lvl
+      -- Non-recursive join points are one-shot; recursive ones are not
+
+lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])
+-- The binders returned are exactly the same as the ones passed,
+-- apart from applying the substitution, but they are now paired
+-- with a (StayPut level)
+--
+-- The returned envt has le_ctxt_lvl updated to the new_lvl
+--
+-- All the new binders get the same level, because
+-- any floating binding is either going to float past
+-- all or none.  We never separate binders.
+lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs
+  = ( env { le_ctxt_lvl = new_lvl
+          , le_join_ceil = new_lvl
+          , le_lvl_env  = addLvls new_lvl lvl_env bndrs }
+    , map (stayPut new_lvl) bndrs)
+
+stayPut :: Level -> OutVar -> LevelledBndr
+stayPut new_lvl bndr = TB bndr (StayPut new_lvl)
+
+  -- Destination level is the max Id level of the expression
+  -- (We'll abstract the type variables, if any.)
+destLevel :: LevelEnv
+          -> DVarSet    -- Free vars of the term
+          -> TyCoVarSet -- Free in the /type/ of the term
+                        -- (a subset of the previous argument)
+          -> Bool   -- True <=> is function
+          -> Bool   -- True <=> is bottom
+          -> Bool   -- True <=> is a join point
+          -> Level
+-- INVARIANT: if is_join=True then result >= join_ceiling
+destLevel env fvs fvs_ty is_function is_bot is_join
+  | isTopLvl max_fv_id_level  -- Float even joins if they get to top level
+                              -- See Note [Floating join point bindings]
+  = tOP_LEVEL
+
+  | is_join  -- Never float a join point past the join ceiling
+             -- See Note [Join points] in FloatOut
+  = if max_fv_id_level `ltLvl` join_ceiling
+    then join_ceiling
+    else max_fv_id_level
+
+  | is_bot              -- Send bottoming bindings to the top
+  = as_far_as_poss      -- regardless; see Note [Bottoming floats]
+                        -- Esp Bottoming floats (1)
+
+  | Just n_args <- floatLams env
+  , n_args > 0  -- n=0 case handled uniformly by the 'otherwise' case
+  , is_function
+  , countFreeIds fvs <= n_args
+  = as_far_as_poss  -- Send functions to top level; see
+                    -- the comments with isFunction
+
+  | otherwise = max_fv_id_level
+  where
+    join_ceiling    = joinCeilingLevel env
+    max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the
+                                              -- tyvars will be abstracted
+
+    as_far_as_poss = maxFvLevel' isId env fvs_ty
+                     -- See Note [Floating and kind casts]
+
+{- Note [Floating and kind casts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+   case x of
+     K (co :: * ~# k) -> let v :: Int |> co
+                             v = e
+                         in blah
+
+Then, even if we are abstracting over Ids, or if e is bottom, we can't
+float v outside the 'co' binding.  Reason: if we did we'd get
+    v' :: forall k. (Int ~# Age) => Int |> co
+and now 'co' isn't in scope in that type. The underlying reason is
+that 'co' is a value-level thing and we can't abstract over that in a
+type (else we'd get a dependent type).  So if v's /type/ mentions 'co'
+we can't float it out beyond the binding site of 'co'.
+
+That's why we have this as_far_as_poss stuff.  Usually as_far_as_poss
+is just tOP_LEVEL; but occasionally a coercion variable (which is an
+Id) mentioned in type prevents this.
+
+Example Trac #14270 comment:15.
+-}
+
+
+isFunction :: CoreExprWithFVs -> Bool
+-- The idea here is that we want to float *functions* to
+-- the top level.  This saves no work, but
+--      (a) it can make the host function body a lot smaller,
+--              and hence inlinable.
+--      (b) it can also save allocation when the function is recursive:
+--          h = \x -> letrec f = \y -> ...f...y...x...
+--                    in f x
+--     becomes
+--          f = \x y -> ...(f x)...y...x...
+--          h = \x -> f x x
+--     No allocation for f now.
+-- We may only want to do this if there are sufficiently few free
+-- variables.  We certainly only want to do it for values, and not for
+-- constructors.  So the simple thing is just to look for lambdas
+isFunction (_, AnnLam b e) | isId b    = True
+                           | otherwise = isFunction e
+-- isFunction (_, AnnTick _ e)         = isFunction e  -- dubious
+isFunction _                           = False
+
+countFreeIds :: DVarSet -> Int
+countFreeIds = nonDetFoldUDFM add 0 . getUniqDSet
+  -- It's OK to use nonDetFoldUDFM here because we're just counting things.
+  where
+    add :: Var -> Int -> Int
+    add v n | isId v    = n+1
+            | otherwise = n
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Free-To-Level Monad}
+*                                                                      *
+************************************************************************
+-}
+
+data LevelEnv
+  = LE { le_switches :: FloatOutSwitches
+       , le_ctxt_lvl :: Level           -- The current level
+       , le_lvl_env  :: VarEnv Level    -- Domain is *post-cloned* TyVars and Ids
+       , le_join_ceil:: Level           -- Highest level to which joins float
+                                        -- Invariant: always >= le_ctxt_lvl
+
+       -- See Note [le_subst and le_env]
+       , le_subst    :: Subst           -- Domain is pre-cloned TyVars and Ids
+                                        -- The Id -> CoreExpr in the Subst is ignored
+                                        -- (since we want to substitute a LevelledExpr for
+                                        -- an Id via le_env) but we do use the Co/TyVar substs
+       , le_env      :: IdEnv ([OutVar], LevelledExpr)  -- Domain is pre-cloned Ids
+    }
+
+{- Note [le_subst and le_env]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We clone let- and case-bound variables so that they are still distinct
+when floated out; hence the le_subst/le_env.  (see point 3 of the
+module overview comment).  We also use these envs when making a
+variable polymorphic because we want to float it out past a big
+lambda.
+
+The le_subst and le_env always implement the same mapping,
+     in_x :->  out_x a b
+where out_x is an OutVar, and a,b are its arguments (when
+we perform abstraction at the same time as floating).
+
+  le_subst maps to CoreExpr
+  le_env   maps to LevelledExpr
+
+Since the range is always a variable or application, there is never
+any difference between the two, but sadly the types differ.  The
+le_subst is used when substituting in a variable's IdInfo; the le_env
+when we find a Var.
+
+In addition the le_env records a [OutVar] of variables free in the
+OutExpr/LevelledExpr, just so we don't have to call freeVars
+repeatedly.  This list is always non-empty, and the first element is
+out_x
+
+The domain of the both envs is *pre-cloned* Ids, though
+
+The domain of the le_lvl_env is the *post-cloned* Ids
+-}
+
+initialEnv :: FloatOutSwitches -> LevelEnv
+initialEnv float_lams
+  = LE { le_switches = float_lams
+       , le_ctxt_lvl = tOP_LEVEL
+       , le_join_ceil = panic "initialEnv"
+       , le_lvl_env = emptyVarEnv
+       , le_subst = emptySubst
+       , le_env = emptyVarEnv }
+
+addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level
+addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl
+
+addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level
+addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs
+
+floatLams :: LevelEnv -> Maybe Int
+floatLams le = floatOutLambdas (le_switches le)
+
+floatConsts :: LevelEnv -> Bool
+floatConsts le = floatOutConstants (le_switches le)
+
+floatOverSat :: LevelEnv -> Bool
+floatOverSat le = floatOutOverSatApps (le_switches le)
+
+floatTopLvlOnly :: LevelEnv -> Bool
+floatTopLvlOnly le = floatToTopLevelOnly (le_switches le)
+
+incMinorLvlFrom :: LevelEnv -> Level
+incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env)
+
+-- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can
+-- See Note [Binder-swap during float-out]
+extendCaseBndrEnv :: LevelEnv
+                  -> Id                 -- Pre-cloned case binder
+                  -> Expr LevelledBndr  -- Post-cloned scrutinee
+                  -> LevelEnv
+extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })
+                  case_bndr (Var scrut_var)
+  = le { le_subst   = extendSubstWithVar subst case_bndr scrut_var
+       , le_env     = add_id id_env (case_bndr, scrut_var) }
+extendCaseBndrEnv env _ _ = env
+
+-- See Note [Join ceiling]
+placeJoinCeiling :: LevelEnv -> LevelEnv
+placeJoinCeiling le@(LE { le_ctxt_lvl = lvl })
+  = le { le_ctxt_lvl = lvl', le_join_ceil = lvl' }
+  where
+    lvl' = asJoinCeilLvl (incMinorLvl lvl)
+
+maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level
+maxFvLevel max_me env var_set
+  = foldDVarSet (maxIn max_me env) tOP_LEVEL var_set
+
+maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level
+-- Same but for TyCoVarSet
+maxFvLevel' max_me env var_set
+  = nonDetFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set
+
+maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level
+maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl
+  = case lookupVarEnv id_env in_var of
+      Just (abs_vars, _) -> foldr max_out lvl abs_vars
+      Nothing            -> max_out in_var lvl
+  where
+    max_out out_var lvl
+        | max_me out_var = case lookupVarEnv lvl_env out_var of
+                                Just lvl' -> maxLvl lvl' lvl
+                                Nothing   -> lvl
+        | otherwise = lvl       -- Ignore some vars depending on max_me
+
+lookupVar :: LevelEnv -> Id -> LevelledExpr
+lookupVar le v = case lookupVarEnv (le_env le) v of
+                    Just (_, expr) -> expr
+                    _              -> Var v
+
+-- Level to which join points are allowed to float (boundary of current tail
+-- context). See Note [Join ceiling]
+joinCeilingLevel :: LevelEnv -> Level
+joinCeilingLevel = le_join_ceil
+
+abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]
+        -- Find the variables in fvs, free vars of the target expression,
+        -- whose level is greater than the destination level
+        -- These are the ones we are going to abstract out
+        --
+        -- Note that to get reproducible builds, the variables need to be
+        -- abstracted in deterministic order, not dependent on the values of
+        -- Uniques. This is achieved by using DVarSets, deterministic free
+        -- variable computation and deterministic sort.
+        -- See Note [Unique Determinism] in Unique for explanation of why
+        -- Uniques are not deterministic.
+abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
+  =  -- NB: sortQuantVars might not put duplicates next to each other
+    map zap $ sortQuantVars $
+    filter abstract_me      $
+    dVarSetElems            $
+    closeOverKindsDSet      $
+    substDVarSet subst in_fvs
+        -- NB: it's important to call abstract_me only on the OutIds the
+        -- come from substDVarSet (not on fv, which is an InId)
+  where
+    abstract_me v = case lookupVarEnv lvl_env v of
+                        Just lvl -> dest_lvl `ltLvl` lvl
+                        Nothing  -> False
+
+        -- We are going to lambda-abstract, so nuke any IdInfo,
+        -- and add the tyvars of the Id (if necessary)
+    zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||
+                           not (isEmptyRuleInfo (idSpecialisation v)),
+                           text "absVarsOf: discarding info on" <+> ppr v )
+                     setIdInfo v vanillaIdInfo
+          | otherwise = v
+
+type LvlM result = UniqSM result
+
+initLvl :: UniqSupply -> UniqSM a -> a
+initLvl = initUs_
+
+newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId]
+             -> LvlM (LevelEnv, [OutId])
+-- The envt is extended to bind the new bndrs to dest_lvl, but
+-- the le_ctxt_lvl is unaffected
+newPolyBndrs dest_lvl
+             env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env })
+             abs_vars bndrs
+ = ASSERT( all (not . isCoVar) bndrs )   -- What would we add to the CoSubst in this case. No easy answer.
+   do { uniqs <- getUniquesM
+      ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
+            bndr_prs  = bndrs `zip` new_bndrs
+            env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs
+                       , le_subst   = foldl' add_subst subst   bndr_prs
+                       , le_env     = foldl' add_id    id_env  bndr_prs }
+      ; return (env', new_bndrs) }
+  where
+    add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)
+    add_id    env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)
+
+    mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $         -- Note [transferPolyIdInfo] in Id.hs
+                             transfer_join_info bndr $
+                             mkSysLocalOrCoVar (mkFastString str) uniq poly_ty
+                           where
+                             str     = "poly_" ++ occNameString (getOccName bndr)
+                             poly_ty = mkLamTypes abs_vars (CoreSubst.substTy subst (idType bndr))
+
+    -- If we are floating a join point to top level, it stops being
+    -- a join point.  Otherwise it continues to be a join point,
+    -- but we may need to adjust its arity
+    dest_is_top = isTopLvl dest_lvl
+    transfer_join_info bndr new_bndr
+      | Just join_arity <- isJoinId_maybe bndr
+      , not dest_is_top
+      = new_bndr `asJoinId` join_arity + length abs_vars
+      | otherwise
+      = new_bndr
+
+newLvlVar :: LevelledExpr        -- The RHS of the new binding
+          -> Maybe JoinArity     -- Its join arity, if it is a join point
+          -> Bool                -- True <=> the RHS looks like (makeStatic ...)
+          -> LvlM Id
+newLvlVar lvld_rhs join_arity_maybe is_mk_static
+  = do { uniq <- getUniqueM
+       ; return (add_join_info (mk_id uniq rhs_ty))
+       }
+  where
+    add_join_info var = var `asJoinId_maybe` join_arity_maybe
+    de_tagged_rhs = deTagExpr lvld_rhs
+    rhs_ty        = exprType de_tagged_rhs
+
+    mk_id uniq rhs_ty
+      -- See Note [Grand plan for static forms] in StaticPtrTable.
+      | is_mk_static
+      = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
+                            rhs_ty
+      | otherwise
+      = mkSysLocalOrCoVar (mkFastString "lvl") uniq rhs_ty
+
+cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
+cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
+               new_lvl vs
+  = do { us <- getUniqueSupplyM
+       ; let (subst', vs') = cloneBndrs subst us vs
+             env' = env { le_ctxt_lvl  = new_lvl
+                        , le_join_ceil = new_lvl
+                        , le_lvl_env   = addLvls new_lvl lvl_env vs'
+                        , le_subst     = subst'
+                        , le_env       = foldl' add_id id_env (vs `zip` vs') }
+
+       ; return (env', vs') }
+
+cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]
+             -> LvlM (LevelEnv, [OutVar])
+-- See Note [Need for cloning during float-out]
+-- Works for Ids bound by let(rec)
+-- The dest_lvl is attributed to the binders in the new env,
+-- but cloneVars doesn't affect the le_ctxt_lvl of the incoming env
+cloneLetVars is_rec
+          env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
+          dest_lvl vs
+  = do { us <- getUniqueSupplyM
+       ; let vs1  = map zap vs
+                      -- See Note [Zapping the demand info]
+             (subst', vs2) = case is_rec of
+                               NonRecursive -> cloneBndrs      subst us vs1
+                               Recursive    -> cloneRecIdBndrs subst us vs1
+             prs  = vs `zip` vs2
+             env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2
+                        , le_subst   = subst'
+                        , le_env     = foldl' add_id id_env prs }
+
+       ; return (env', vs2) }
+  where
+    zap :: Var -> Var
+    zap v | isId v    = zap_join (zapIdDemandInfo v)
+          | otherwise = v
+
+    zap_join | isTopLvl dest_lvl = zapJoinId
+             | otherwise         = id
+
+add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)
+add_id id_env (v, v1)
+  | isTyVar v = delVarEnv    id_env v
+  | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1)
+
+{-
+Note [Zapping the demand info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+VERY IMPORTANT: we must zap the demand info if the thing is going to
+float out, because it may be less demanded than at its original
+binding site.  Eg
+   f :: Int -> Int
+   f x = let v = 3*4 in v+x
+Here v is strict; but if we float v to top level, it isn't any more.
+
+Similarly, if we're floating a join point, it won't be one anymore, so we zap
+join point information as well.
+-}
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/SimplCore.hs
@@ -0,0 +1,1030 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[SimplCore]{Driver for simplifying @Core@ programs}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module SimplCore ( core2core, simplifyExpr ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import DynFlags
+import CoreSyn
+import HscTypes
+import CSE              ( cseProgram )
+import Rules            ( mkRuleBase, unionRuleBase,
+                          extendRuleBaseList, ruleCheckProgram, addRuleInfo,
+                          getRules )
+import PprCore          ( pprCoreBindings, pprCoreExpr )
+import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )
+import IdInfo
+import CoreStats        ( coreBindsSize, coreBindsStats, exprSize )
+import CoreUtils        ( mkTicks, stripTicksTop )
+import CoreLint         ( endPass, lintPassResult, dumpPassResult,
+                          lintAnnots )
+import Simplify         ( simplTopBinds, simplExpr, simplRules )
+import SimplUtils       ( simplEnvForGHCi, activeRule, activeUnfolding )
+import SimplEnv
+import SimplMonad
+import CoreMonad
+import qualified ErrUtils as Err
+import FloatIn          ( floatInwards )
+import FloatOut         ( floatOutwards )
+import FamInstEnv
+import Id
+import ErrUtils         ( withTiming )
+import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma )
+import VarSet
+import VarEnv
+import LiberateCase     ( liberateCase )
+import SAT              ( doStaticArgs )
+import Specialise       ( specProgram)
+import SpecConstr       ( specConstrProgram)
+import DmdAnal          ( dmdAnalProgram )
+import CallArity        ( callArityAnalProgram )
+import Exitify          ( exitifyProgram )
+import WorkWrap         ( wwTopBinds )
+import SrcLoc
+import Util
+import Module
+import Plugins          ( withPlugins, installCoreToDos )
+import DynamicLoading  -- ( initializePlugins )
+
+import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
+import UniqFM
+import Outputable
+import Control.Monad
+import qualified GHC.LanguageExtensions as LangExt
+{-
+************************************************************************
+*                                                                      *
+\subsection{The driver for the simplifier}
+*                                                                      *
+************************************************************************
+-}
+
+core2core :: HscEnv -> ModGuts -> IO ModGuts
+core2core hsc_env guts@(ModGuts { mg_module  = mod
+                                , mg_loc     = loc
+                                , mg_deps    = deps
+                                , mg_rdr_env = rdr_env })
+  = do { us <- mkSplitUniqSupply 's'
+       -- make sure all plugins are loaded
+
+       ; let builtin_passes = getCoreToDo dflags
+             orph_mods = mkModuleSet (mod : dep_orphs deps)
+       ;
+       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod
+                                    orph_mods print_unqual loc $
+                           do { hsc_env' <- getHscEnv
+                              ; dflags' <- liftIO $ initializePlugins hsc_env'
+                                                      (hsc_dflags hsc_env')
+                              ; all_passes <- withPlugins dflags'
+                                                installCoreToDos
+                                                builtin_passes
+                              ; runCorePasses all_passes guts }
+
+       ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
+             "Grand total simplifier statistics"
+             (pprSimplCount stats)
+
+       ; return guts2 }
+  where
+    dflags         = hsc_dflags hsc_env
+    home_pkg_rules = hptRules hsc_env (dep_mods deps)
+    hpt_rule_base  = mkRuleBase home_pkg_rules
+    print_unqual   = mkPrintUnqualified dflags rdr_env
+    -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
+    -- This is very convienent for the users of the monad (e.g. plugins do not have to
+    -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
+    -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
+    -- would mean our cached value would go out of date.
+
+{-
+************************************************************************
+*                                                                      *
+           Generating the main optimisation pipeline
+*                                                                      *
+************************************************************************
+-}
+
+getCoreToDo :: DynFlags -> [CoreToDo]
+getCoreToDo dflags
+  = flatten_todos core_todo
+  where
+    opt_level     = optLevel           dflags
+    phases        = simplPhases        dflags
+    max_iter      = maxSimplIterations dflags
+    rule_check    = ruleCheck          dflags
+    call_arity    = gopt Opt_CallArity                    dflags
+    exitification = gopt Opt_Exitification                dflags
+    strictness    = gopt Opt_Strictness                   dflags
+    full_laziness = gopt Opt_FullLaziness                 dflags
+    do_specialise = gopt Opt_Specialise                   dflags
+    do_float_in   = gopt Opt_FloatIn                      dflags
+    cse           = gopt Opt_CSE                          dflags
+    spec_constr   = gopt Opt_SpecConstr                   dflags
+    liberate_case = gopt Opt_LiberateCase                 dflags
+    late_dmd_anal = gopt Opt_LateDmdAnal                  dflags
+    late_specialise = gopt Opt_LateSpecialise             dflags
+    static_args   = gopt Opt_StaticArgumentTransformation dflags
+    rules_on      = gopt Opt_EnableRewriteRules           dflags
+    eta_expand_on = gopt Opt_DoLambdaEtaExpansion         dflags
+    ww_on         = gopt Opt_WorkerWrapper                dflags
+    static_ptrs   = xopt LangExt.StaticPointers           dflags
+
+    maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
+
+    maybe_strictness_before phase
+      = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness
+
+    base_mode = SimplMode { sm_phase      = panic "base_mode"
+                          , sm_names      = []
+                          , sm_dflags     = dflags
+                          , sm_rules      = rules_on
+                          , sm_eta_expand = eta_expand_on
+                          , sm_inline     = True
+                          , sm_case_case  = True }
+
+    simpl_phase phase names iter
+      = CoreDoPasses
+      $   [ maybe_strictness_before phase
+          , CoreDoSimplify iter
+                (base_mode { sm_phase = Phase phase
+                           , sm_names = names })
+
+          , maybe_rule_check (Phase phase) ]
+
+    simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter
+                                | phase <- [phases, phases-1 .. 1] ]
+
+
+        -- initial simplify: mk specialiser happy: minimum effort please
+    simpl_gently = CoreDoSimplify max_iter
+                       (base_mode { sm_phase = InitialPhase
+                                  , sm_names = ["Gentle"]
+                                  , sm_rules = rules_on   -- Note [RULEs enabled in SimplGently]
+                                  , sm_inline = True
+                                              -- See Note [Inline in InitialPhase]
+                                  , sm_case_case = False })
+                          -- Don't do case-of-case transformations.
+                          -- This makes full laziness work better
+
+    strictness_pass = if ww_on
+                       then [CoreDoStrictness,CoreDoWorkerWrapper]
+                       else [CoreDoStrictness]
+
+
+    -- New demand analyser
+    demand_analyser = (CoreDoPasses (
+                           strictness_pass ++
+                           [simpl_phase 0 ["post-worker-wrapper"] max_iter]
+                           ))
+
+    -- Static forms are moved to the top level with the FloatOut pass.
+    -- See Note [Grand plan for static forms] in StaticPtrTable.
+    static_ptrs_float_outwards =
+      runWhen static_ptrs $ CoreDoPasses
+        [ simpl_gently -- Float Out can't handle type lets (sometimes created
+                       -- by simpleOptPgm via mkParallelBindings)
+        , CoreDoFloatOutwards FloatOutSwitches
+          { floatOutLambdas   = Just 0
+          , floatOutConstants = True
+          , floatOutOverSatApps = False
+          , floatToTopLevelOnly = True
+          }
+        ]
+
+    core_todo =
+     if opt_level == 0 then
+       [ static_ptrs_float_outwards,
+         CoreDoSimplify max_iter
+             (base_mode { sm_phase = Phase 0
+                        , sm_names = ["Non-opt simplification"] })
+       ]
+
+     else {- opt_level >= 1 -} [
+
+    -- We want to do the static argument transform before full laziness as it
+    -- may expose extra opportunities to float things outwards. However, to fix
+    -- up the output of the transformation we need at do at least one simplify
+    -- after this before anything else
+        runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),
+
+        -- initial simplify: mk specialiser happy: minimum effort please
+        simpl_gently,
+
+        -- Specialisation is best done before full laziness
+        -- so that overloaded functions have all their dictionary lambdas manifest
+        runWhen do_specialise CoreDoSpecialising,
+
+        if full_laziness then
+           CoreDoFloatOutwards FloatOutSwitches {
+                                 floatOutLambdas   = Just 0,
+                                 floatOutConstants = True,
+                                 floatOutOverSatApps = False,
+                                 floatToTopLevelOnly = False }
+                -- Was: gentleFloatOutSwitches
+                --
+                -- I have no idea why, but not floating constants to
+                -- top level is very bad in some cases.
+                --
+                -- Notably: p_ident in spectral/rewrite
+                --          Changing from "gentle" to "constantsOnly"
+                --          improved rewrite's allocation by 19%, and
+                --          made 0.0% difference to any other nofib
+                --          benchmark
+                --
+                -- Not doing floatOutOverSatApps yet, we'll do
+                -- that later on when we've had a chance to get more
+                -- accurate arity information.  In fact it makes no
+                -- difference at all to performance if we do it here,
+                -- but maybe we save some unnecessary to-and-fro in
+                -- the simplifier.
+        else
+           -- Even with full laziness turned off, we still need to float static
+           -- forms to the top level. See Note [Grand plan for static forms] in
+           -- StaticPtrTable.
+           static_ptrs_float_outwards,
+
+        simpl_phases,
+
+                -- Phase 0: allow all Ids to be inlined now
+                -- This gets foldr inlined before strictness analysis
+
+                -- At least 3 iterations because otherwise we land up with
+                -- huge dead expressions because of an infelicity in the
+                -- simplifier.
+                --      let k = BIG in foldr k z xs
+                -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs
+                -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs
+                -- Don't stop now!
+        simpl_phase 0 ["main"] (max max_iter 3),
+
+        runWhen do_float_in CoreDoFloatInwards,
+            -- Run float-inwards immediately before the strictness analyser
+            -- Doing so pushes bindings nearer their use site and hence makes
+            -- them more likely to be strict. These bindings might only show
+            -- up after the inlining from simplification.  Example in fulsom,
+            -- Csg.calc, where an arg of timesDouble thereby becomes strict.
+
+        runWhen call_arity $ CoreDoPasses
+            [ CoreDoCallArity
+            , simpl_phase 0 ["post-call-arity"] max_iter
+            ],
+
+        runWhen strictness demand_analyser,
+
+        runWhen exitification CoreDoExitify,
+            -- See note [Placement of the exitification pass]
+
+        runWhen full_laziness $
+           CoreDoFloatOutwards FloatOutSwitches {
+                                 floatOutLambdas     = floatLamArgs dflags,
+                                 floatOutConstants   = True,
+                                 floatOutOverSatApps = True,
+                                 floatToTopLevelOnly = False },
+                -- nofib/spectral/hartel/wang doubles in speed if you
+                -- do full laziness late in the day.  It only happens
+                -- after fusion and other stuff, so the early pass doesn't
+                -- catch it.  For the record, the redex is
+                --        f_el22 (f_el21 r_midblock)
+
+
+        runWhen cse CoreCSE,
+                -- We want CSE to follow the final full-laziness pass, because it may
+                -- succeed in commoning up things floated out by full laziness.
+                -- CSE used to rely on the no-shadowing invariant, but it doesn't any more
+
+        runWhen do_float_in CoreDoFloatInwards,
+
+        maybe_rule_check (Phase 0),
+
+                -- Case-liberation for -O2.  This should be after
+                -- strictness analysis and the simplification which follows it.
+        runWhen liberate_case (CoreDoPasses [
+            CoreLiberateCase,
+            simpl_phase 0 ["post-liberate-case"] max_iter
+            ]),         -- Run the simplifier after LiberateCase to vastly
+                        -- reduce the possibility of shadowing
+                        -- Reason: see Note [Shadowing] in SpecConstr.hs
+
+        runWhen spec_constr CoreDoSpecConstr,
+
+        maybe_rule_check (Phase 0),
+
+        runWhen late_specialise
+          (CoreDoPasses [ CoreDoSpecialising
+                        , simpl_phase 0 ["post-late-spec"] max_iter]),
+
+        -- LiberateCase can yield new CSE opportunities because it peels
+        -- off one layer of a recursive function (concretely, I saw this
+        -- in wheel-sieve1), and I'm guessing that SpecConstr can too
+        -- And CSE is a very cheap pass. So it seems worth doing here.
+        runWhen ((liberate_case || spec_constr) && cse) CoreCSE,
+
+        -- Final clean-up simplification:
+        simpl_phase 0 ["final"] max_iter,
+
+        runWhen late_dmd_anal $ CoreDoPasses (
+            strictness_pass ++
+            [simpl_phase 0 ["post-late-ww"] max_iter]
+          ),
+
+        -- Final run of the demand_analyser, ensures that one-shot thunks are
+        -- really really one-shot thunks. Only needed if the demand analyser
+        -- has run at all. See Note [Final Demand Analyser run] in DmdAnal
+        -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution
+        -- can become /exponentially/ more expensive. See Trac #11731, #12996.
+        runWhen (strictness || late_dmd_anal) CoreDoStrictness,
+
+        maybe_rule_check (Phase 0)
+     ]
+
+    -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.
+    flatten_todos [] = []
+    flatten_todos (CoreDoNothing : rest) = flatten_todos rest
+    flatten_todos (CoreDoPasses passes : rest) =
+      flatten_todos passes ++ flatten_todos rest
+    flatten_todos (todo : rest) = todo : flatten_todos rest
+
+{- Note [Inline in InitialPhase]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is
+confusing for users because when they say INLINE they expect the function to inline
+right away.
+
+So now we do inlining immediately, even in the InitialPhase, assuming that the
+Id's Activation allows it.
+
+This is a surprisingly big deal. Compiler performance improved a lot
+when I made this change:
+
+   perf/compiler/T5837.run            T5837 [stat too good] (normal)
+   perf/compiler/parsing001.run       parsing001 [stat too good] (normal)
+   perf/compiler/T12234.run           T12234 [stat too good] (optasm)
+   perf/compiler/T9020.run            T9020 [stat too good] (optasm)
+   perf/compiler/T3064.run            T3064 [stat too good] (normal)
+   perf/compiler/T9961.run            T9961 [stat too good] (normal)
+   perf/compiler/T13056.run           T13056 [stat too good] (optasm)
+   perf/compiler/T9872d.run           T9872d [stat too good] (normal)
+   perf/compiler/T783.run             T783 [stat too good] (normal)
+   perf/compiler/T12227.run           T12227 [stat too good] (normal)
+   perf/should_run/lazy-bs-alloc.run  lazy-bs-alloc [stat too good] (normal)
+   perf/compiler/T1969.run            T1969 [stat too good] (normal)
+   perf/compiler/T9872a.run           T9872a [stat too good] (normal)
+   perf/compiler/T9872c.run           T9872c [stat too good] (normal)
+   perf/compiler/T9872b.run           T9872b [stat too good] (normal)
+   perf/compiler/T9872d.run           T9872d [stat too good] (normal)
+
+Note [RULEs enabled in SimplGently]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+RULES are enabled when doing "gentle" simplification.  Two reasons:
+
+  * We really want the class-op cancellation to happen:
+        op (df d1 d2) --> $cop3 d1 d2
+    because this breaks the mutual recursion between 'op' and 'df'
+
+  * I wanted the RULE
+        lift String ===> ...
+    to work in Template Haskell when simplifying
+    splices, so we get simpler code for literal strings
+
+But watch out: list fusion can prevent floating.  So use phase control
+to switch off those rules until after floating.
+
+************************************************************************
+*                                                                      *
+                  The CoreToDo interpreter
+*                                                                      *
+************************************************************************
+-}
+
+runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts
+runCorePasses passes guts
+  = foldM do_pass guts passes
+  where
+    do_pass guts CoreDoNothing = return guts
+    do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
+    do_pass guts pass
+       = withTiming getDynFlags
+                    (ppr pass <+> brackets (ppr mod))
+                    (const ()) $ do
+            { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts
+            ; endPass pass (mg_binds guts') (mg_rules guts')
+            ; return guts' }
+
+    mod = mg_module guts
+
+doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
+doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}
+                                       simplifyPgm pass
+
+doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}
+                                       doPass cseProgram
+
+doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}
+                                       doPassD liberateCase
+
+doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}
+                                       floatInwards
+
+doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}
+                                       doPassDUM (floatOutwards f)
+
+doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}
+                                       doPassU doStaticArgs
+
+doCorePass CoreDoCallArity           = {-# SCC "CallArity" #-}
+                                       doPassD callArityAnalProgram
+
+doCorePass CoreDoExitify             = {-# SCC "Exitify" #-}
+                                       doPass exitifyProgram
+
+doCorePass CoreDoStrictness          = {-# SCC "NewStranal" #-}
+                                       doPassDFM dmdAnalProgram
+
+doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}
+                                       doPassDFU wwTopBinds
+
+doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}
+                                       specProgram
+
+doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}
+                                       specConstrProgram
+
+doCorePass CoreDoPrintCore              = observe   printCore
+doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat
+doCorePass CoreDoNothing                = return
+doCorePass (CoreDoPasses passes)        = runCorePasses passes
+
+#if defined(GHCI)
+doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass
+#else
+doCorePass pass@CoreDoPluginPass {}  = pprPanic "doCorePass" (ppr pass)
+#endif
+
+doCorePass pass@CoreDesugar          = pprPanic "doCorePass" (ppr pass)
+doCorePass pass@CoreDesugarOpt       = pprPanic "doCorePass" (ppr pass)
+doCorePass pass@CoreTidy             = pprPanic "doCorePass" (ppr pass)
+doCorePass pass@CorePrep             = pprPanic "doCorePass" (ppr pass)
+doCorePass pass@CoreOccurAnal        = pprPanic "doCorePass" (ppr pass)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Core pass combinators}
+*                                                                      *
+************************************************************************
+-}
+
+printCore :: DynFlags -> CoreProgram -> IO ()
+printCore dflags binds
+    = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)
+
+ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
+ruleCheckPass current_phase pat guts =
+    withTiming getDynFlags
+               (text "RuleCheck"<+>brackets (ppr $ mg_module guts))
+               (const ()) $ do
+    { rb <- getRuleBase
+    ; dflags <- getDynFlags
+    ; vis_orphs <- getVisibleOrphanMods
+    ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn
+                        ++ (mg_rules guts)
+    ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan
+                   (defaultDumpStyle dflags)
+                   (ruleCheckProgram current_phase pat
+                      rule_fn (mg_binds guts))
+    ; return guts }
+
+doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassDUM do_pass = doPassM $ \binds -> do
+    dflags <- getDynFlags
+    us     <- getUniqueSupplyM
+    liftIO $ do_pass dflags us binds
+
+doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
+
+doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
+
+doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
+
+doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassU do_pass = doPassDU (const do_pass)
+
+doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassDFM do_pass guts = do
+    dflags <- getDynFlags
+    p_fam_env <- getPackageFamInstEnv
+    let fam_envs = (p_fam_env, mg_fam_inst_env guts)
+    doPassM (liftIO . do_pass dflags fam_envs) guts
+
+doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
+doPassDFU do_pass guts = do
+    dflags <- getDynFlags
+    us     <- getUniqueSupplyM
+    p_fam_env <- getPackageFamInstEnv
+    let fam_envs = (p_fam_env, mg_fam_inst_env guts)
+    doPass (do_pass dflags fam_envs us) guts
+
+-- Most passes return no stats and don't change rules: these combinators
+-- let us lift them to the full blown ModGuts+CoreM world
+doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts
+doPassM bind_f guts = do
+    binds' <- bind_f (mg_binds guts)
+    return (guts { mg_binds = binds' })
+
+doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts
+doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
+
+-- Observer passes just peek; don't modify the bindings at all
+observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts
+observe do_pass = doPassM $ \binds -> do
+    dflags <- getDynFlags
+    _ <- liftIO $ do_pass dflags binds
+    return binds
+
+{-
+************************************************************************
+*                                                                      *
+        Gentle simplification
+*                                                                      *
+************************************************************************
+-}
+
+simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
+             -> CoreExpr
+             -> IO CoreExpr
+-- simplifyExpr is called by the driver to simplify an
+-- expression typed in at the interactive prompt
+--
+-- Also used by Template Haskell
+simplifyExpr dflags expr
+  = withTiming (pure dflags) (text "Simplify [expr]") (const ()) $
+    do  {
+        ; us <-  mkSplitUniqSupply 's'
+
+        ; let sz = exprSize expr
+
+        ; (expr', counts) <- initSmpl dflags emptyRuleEnv
+                               emptyFamInstEnvs us sz
+                               (simplExprGently (simplEnvForGHCi dflags) expr)
+
+        ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)
+                  "Simplifier statistics" (pprSimplCount counts)
+
+        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
+                        (pprCoreExpr expr')
+
+        ; return expr'
+        }
+
+simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
+-- Simplifies an expression
+--      does occurrence analysis, then simplification
+--      and repeats (twice currently) because one pass
+--      alone leaves tons of crud.
+-- Used (a) for user expressions typed in at the interactive prompt
+--      (b) the LHS and RHS of a RULE
+--      (c) Template Haskell splices
+--
+-- The name 'Gently' suggests that the SimplMode is SimplGently,
+-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
+-- enforce that; it just simplifies the expression twice
+
+-- It's important that simplExprGently does eta reduction; see
+-- Note [Simplifying the left-hand side of a RULE] above.  The
+-- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
+-- but only if -O is on.
+
+simplExprGently env expr = do
+    expr1 <- simplExpr env (occurAnalyseExpr expr)
+    simplExpr env (occurAnalyseExpr expr1)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{The driver for the simplifier}
+*                                                                      *
+************************************************************************
+-}
+
+simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
+simplifyPgm pass guts
+  = do { hsc_env <- getHscEnv
+       ; us <- getUniqueSupplyM
+       ; rb <- getRuleBase
+       ; liftIOWithCount $
+         simplifyPgmIO pass hsc_env us rb guts }
+
+simplifyPgmIO :: CoreToDo
+              -> HscEnv
+              -> UniqSupply
+              -> RuleBase
+              -> ModGuts
+              -> IO (SimplCount, ModGuts)  -- New bindings
+
+simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
+              hsc_env us hpt_rule_base
+              guts@(ModGuts { mg_module = this_mod
+                            , mg_rdr_env = rdr_env
+                            , mg_deps = deps
+                            , mg_binds = binds, mg_rules = rules
+                            , mg_fam_inst_env = fam_inst_env })
+  = do { (termination_msg, it_count, counts_out, guts')
+           <- do_iteration us 1 [] binds rules
+
+        ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags &&
+                                dopt Opt_D_dump_simpl_stats  dflags)
+                  "Simplifier statistics for following pass"
+                  (vcat [text termination_msg <+> text "after" <+> ppr it_count
+                                              <+> text "iterations",
+                         blankLine,
+                         pprSimplCount counts_out])
+
+        ; return (counts_out, guts')
+    }
+  where
+    dflags       = hsc_dflags hsc_env
+    print_unqual = mkPrintUnqualified dflags rdr_env
+    simpl_env    = mkSimplEnv mode
+    active_rule  = activeRule mode
+    active_unf   = activeUnfolding mode
+
+    do_iteration :: UniqSupply
+                 -> Int          -- Counts iterations
+                 -> [SimplCount] -- Counts from earlier iterations, reversed
+                 -> CoreProgram  -- Bindings in
+                 -> [CoreRule]   -- and orphan rules
+                 -> IO (String, Int, SimplCount, ModGuts)
+
+    do_iteration us iteration_no counts_so_far binds rules
+        -- iteration_no is the number of the iteration we are
+        -- about to begin, with '1' for the first
+      | iteration_no > max_iterations   -- Stop if we've run out of iterations
+      = WARN( debugIsOn && (max_iterations > 2)
+            , hang (text "Simplifier bailing out after" <+> int max_iterations
+                    <+> text "iterations"
+                    <+> (brackets $ hsep $ punctuate comma $
+                         map (int . simplCountN) (reverse counts_so_far)))
+                 2 (text "Size =" <+> ppr (coreBindsStats binds)))
+
+                -- Subtract 1 from iteration_no to get the
+                -- number of iterations we actually completed
+        return ( "Simplifier baled out", iteration_no - 1
+               , totalise counts_so_far
+               , guts { mg_binds = binds, mg_rules = rules } )
+
+      -- Try and force thunks off the binds; significantly reduces
+      -- space usage, especially with -O.  JRS, 000620.
+      | let sz = coreBindsSize binds
+      , () <- sz `seq` ()     -- Force it
+      = do {
+                -- Occurrence analysis
+           let { tagged_binds = {-# SCC "OccAnal" #-}
+                     occurAnalysePgm this_mod active_unf active_rule rules
+                                     binds
+               } ;
+           Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
+                     (pprCoreBindings tagged_binds);
+
+                -- Get any new rules, and extend the rule base
+                -- See Note [Overall plumbing for rules] in Rules.hs
+                -- We need to do this regularly, because simplification can
+                -- poke on IdInfo thunks, which in turn brings in new rules
+                -- behind the scenes.  Otherwise there's a danger we'll simply
+                -- miss the rules for Ids hidden inside imported inlinings
+           eps <- hscEPS hsc_env ;
+           let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
+                ; rule_base2 = extendRuleBaseList rule_base1 rules
+                ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)
+                ; vis_orphs = this_mod : dep_orphs deps } ;
+
+                -- Simplify the program
+           ((binds1, rules1), counts1) <-
+             initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $
+               do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}
+                                      simplTopBinds simpl_env tagged_binds
+
+                      -- Apply the substitution to rules defined in this module
+                      -- for imported Ids.  Eg  RULE map my_f = blah
+                      -- If we have a substitution my_f :-> other_f, we'd better
+                      -- apply it to the rule to, or it'll never match
+                  ; rules1 <- simplRules env1 Nothing rules Nothing
+
+                  ; return (getTopFloatBinds floats, rules1) } ;
+
+                -- Stop if nothing happened; don't dump output
+                -- See Note [Which transformations are innocuous] in CoreMonad
+           if isZeroSimplCount counts1 then
+                return ( "Simplifier reached fixed point", iteration_no
+                       , totalise (counts1 : counts_so_far)  -- Include "free" ticks
+                       , guts { mg_binds = binds1, mg_rules = rules1 } )
+           else do {
+                -- Short out indirections
+                -- We do this *after* at least one run of the simplifier
+                -- because indirection-shorting uses the export flag on *occurrences*
+                -- and that isn't guaranteed to be ok until after the first run propagates
+                -- stuff from the binding site to its occurrences
+                --
+                -- ToDo: alas, this means that indirection-shorting does not happen at all
+                --       if the simplifier does nothing (not common, I know, but unsavoury)
+           let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
+
+                -- Dump the result of this iteration
+           dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;
+           lintPassResult hsc_env pass binds2 ;
+
+                -- Loop
+           do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
+           } }
+      | otherwise = panic "do_iteration"
+      where
+        (us1, us2) = splitUniqSupply us
+
+        -- Remember the counts_so_far are reversed
+        totalise :: [SimplCount] -> SimplCount
+        totalise = foldr (\c acc -> acc `plusSimplCount` c)
+                         (zeroSimplCount dflags)
+
+simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"
+
+-------------------
+dump_end_iteration :: DynFlags -> PrintUnqualified -> Int
+                   -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()
+dump_end_iteration dflags print_unqual iteration_no counts binds rules
+  = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules
+  where
+    mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations
+            | otherwise                               = Nothing
+            -- Show details if Opt_D_dump_simpl_iterations is on
+
+    hdr = text "Simplifier iteration=" <> int iteration_no
+    pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr
+                     , pprSimplCount counts
+                     , text "---- End of simplifier counts for" <+> hdr ]
+
+{-
+************************************************************************
+*                                                                      *
+                Shorting out indirections
+*                                                                      *
+************************************************************************
+
+If we have this:
+
+        x_local = <expression>
+        ...bindings...
+        x_exported = x_local
+
+where x_exported is exported, and x_local is not, then we replace it with this:
+
+        x_exported = <expression>
+        x_local = x_exported
+        ...bindings...
+
+Without this we never get rid of the x_exported = x_local thing.  This
+save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
+makes strictness information propagate better.  This used to happen in
+the final phase, but it's tidier to do it here.
+
+Note [Messing up the exported Id's RULES]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must be careful about discarding (obviously) or even merging the
+RULES on the exported Id. The example that went bad on me at one stage
+was this one:
+
+    iterate :: (a -> a) -> a -> [a]
+        [Exported]
+    iterate = iterateList
+
+    iterateFB c f x = x `c` iterateFB c f (f x)
+    iterateList f x =  x : iterateList f (f x)
+        [Not exported]
+
+    {-# RULES
+    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
+    "iterateFB"                 iterateFB (:) = iterateList
+     #-}
+
+This got shorted out to:
+
+    iterateList :: (a -> a) -> a -> [a]
+    iterateList = iterate
+
+    iterateFB c f x = x `c` iterateFB c f (f x)
+    iterate f x =  x : iterate f (f x)
+
+    {-# RULES
+    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)
+    "iterateFB"                 iterateFB (:) = iterate
+     #-}
+
+And now we get an infinite loop in the rule system
+        iterate f x -> build (\cn -> iterateFB c f x)
+                    -> iterateFB (:) f x
+                    -> iterate f x
+
+Old "solution":
+        use rule switching-off pragmas to get rid
+        of iterateList in the first place
+
+But in principle the user *might* want rules that only apply to the Id
+he says.  And inline pragmas are similar
+   {-# NOINLINE f #-}
+   f = local
+   local = <stuff>
+Then we do not want to get rid of the NOINLINE.
+
+Hence hasShortableIdinfo.
+
+
+Note [Rules and indirection-zapping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Problem: what if x_exported has a RULE that mentions something in ...bindings...?
+Then the things mentioned can be out of scope!  Solution
+ a) Make sure that in this pass the usage-info from x_exported is
+        available for ...bindings...
+ b) If there are any such RULES, rec-ify the entire top-level.
+    It'll get sorted out next time round
+
+Other remarks
+~~~~~~~~~~~~~
+If more than one exported thing is equal to a local thing (i.e., the
+local thing really is shared), then we do one only:
+\begin{verbatim}
+        x_local = ....
+        x_exported1 = x_local
+        x_exported2 = x_local
+==>
+        x_exported1 = ....
+
+        x_exported2 = x_exported1
+\end{verbatim}
+
+We rely on prior eta reduction to simplify things like
+\begin{verbatim}
+        x_exported = /\ tyvars -> x_local tyvars
+==>
+        x_exported = x_local
+\end{verbatim}
+Hence,there's a possibility of leaving unchanged something like this:
+\begin{verbatim}
+        x_local = ....
+        x_exported1 = x_local Int
+\end{verbatim}
+By the time we've thrown away the types in STG land this
+could be eliminated.  But I don't think it's very common
+and it's dangerous to do this fiddling in STG land
+because we might elminate a binding that's mentioned in the
+unfolding for something.
+
+Note [Indirection zapping and ticks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unfortunately this is another place where we need a special case for
+ticks. The following happens quite regularly:
+
+        x_local = <expression>
+        x_exported = tick<x> x_local
+
+Which we want to become:
+
+        x_exported =  tick<x> <expression>
+
+As it makes no sense to keep the tick and the expression on separate
+bindings. Note however that that this might increase the ticks scoping
+over the execution of x_local, so we can only do this for floatable
+ticks. More often than not, other references will be unfoldings of
+x_exported, and therefore carry the tick anyway.
+-}
+
+type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks
+
+shortOutIndirections :: CoreProgram -> CoreProgram
+shortOutIndirections binds
+  | isEmptyVarEnv ind_env = binds
+  | no_need_to_flatten    = binds'                      -- See Note [Rules and indirect-zapping]
+  | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
+  where
+    ind_env            = makeIndEnv binds
+    -- These exported Ids are the subjects  of the indirection-elimination
+    exp_ids            = map fst $ nonDetEltsUFM ind_env
+      -- It's OK to use nonDetEltsUFM here because we forget the ordering
+      -- by immediately converting to a set or check if all the elements
+      -- satisfy a predicate.
+    exp_id_set         = mkVarSet exp_ids
+    no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids
+    binds'             = concatMap zap binds
+
+    zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
+    zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]
+
+    zapPair (bndr, rhs)
+        | bndr `elemVarSet` exp_id_set
+        = []   -- Kill the exported-id binding
+
+        | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr
+        , (exp_id', lcl_id') <- transferIdInfo exp_id bndr
+        =      -- Turn a local-id binding into two bindings
+               --    exp_id = rhs; lcl_id = exp_id
+          [ (exp_id', mkTicks ticks rhs),
+            (lcl_id', Var exp_id') ]
+
+        | otherwise
+        = [(bndr,rhs)]
+
+makeIndEnv :: [CoreBind] -> IndEnv
+makeIndEnv binds
+  = foldl' add_bind emptyVarEnv binds
+  where
+    add_bind :: IndEnv -> CoreBind -> IndEnv
+    add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs)
+    add_bind env (Rec pairs)              = foldl' add_pair env pairs
+
+    add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv
+    add_pair env (exported_id, exported)
+        | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported
+        , shortMeOut env exported_id local_id
+        = extendVarEnv env local_id (exported_id, ticks)
+    add_pair env _ = env
+
+-----------------
+shortMeOut :: IndEnv -> Id -> Id -> Bool
+shortMeOut ind_env exported_id local_id
+-- The if-then-else stuff is just so I can get a pprTrace to see
+-- how often I don't get shorting out because of IdInfo stuff
+  = if isExportedId exported_id &&              -- Only if this is exported
+
+       isLocalId local_id &&                    -- Only if this one is defined in this
+                                                --      module, so that we *can* change its
+                                                --      binding to be the exported thing!
+
+       not (isExportedId local_id) &&           -- Only if this one is not itself exported,
+                                                --      since the transformation will nuke it
+
+       not (local_id `elemVarEnv` ind_env)      -- Only if not already substituted for
+    then
+        if hasShortableIdInfo exported_id
+        then True       -- See Note [Messing up the exported Id's IdInfo]
+        else WARN( True, text "Not shorting out:" <+> ppr exported_id )
+             False
+    else
+        False
+
+-----------------
+hasShortableIdInfo :: Id -> Bool
+-- True if there is no user-attached IdInfo on exported_id,
+-- so we can safely discard it
+-- See Note [Messing up the exported Id's IdInfo]
+hasShortableIdInfo id
+  =  isEmptyRuleInfo (ruleInfo info)
+  && isDefaultInlinePragma (inlinePragInfo info)
+  && not (isStableUnfolding (unfoldingInfo info))
+  where
+     info = idInfo id
+
+-----------------
+{- Note [Transferring IdInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+     lcl_id = e; exp_id = lcl_id
+
+and lcl_id has useful IdInfo, we don't want to discard it by going
+     gbl_id = e; lcl_id = gbl_id
+
+Instead, transfer IdInfo from lcl_id to exp_id, specifically
+* (Stable) unfolding
+* Strictness
+* Rules
+* Inline pragma
+
+Overwriting, rather than merging, seems to work ok.
+
+We also zap the InlinePragma on the lcl_id. It might originally
+have had a NOINLINE, which we have now transferred; and we really
+want the lcl_id to inline now that its RHS is trivial!
+-}
+
+transferIdInfo :: Id -> Id -> (Id, Id)
+-- See Note [Transferring IdInfo]
+transferIdInfo exported_id local_id
+  = ( modifyIdInfo transfer exported_id
+    , local_id `setInlinePragma` defaultInlinePragma )
+  where
+    local_info = idInfo local_id
+    transfer exp_info = exp_info `setStrictnessInfo`    strictnessInfo local_info
+                                 `setUnfoldingInfo`     unfoldingInfo local_info
+                                 `setInlinePragInfo`    inlinePragInfo local_info
+                                 `setRuleInfo`          addRuleInfo (ruleInfo exp_info) new_info
+    new_info = setRuleInfoHead (idName exported_id)
+                               (ruleInfo local_info)
+        -- Remember to set the function-name field of the
+        -- rules as we transfer them from one function to another
diff --git a/compiler/simplCore/SimplEnv.hs b/compiler/simplCore/SimplEnv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/SimplEnv.hs
@@ -0,0 +1,936 @@
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+\section[SimplMonad]{The simplifier Monad}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module SimplEnv (
+        -- * The simplifier mode
+        setMode, getMode, updMode, seDynFlags,
+
+        -- * Environments
+        SimplEnv(..), pprSimplEnv,   -- Temp not abstract
+        mkSimplEnv, extendIdSubst,
+        SimplEnv.extendTvSubst, SimplEnv.extendCvSubst,
+        zapSubstEnv, setSubstEnv,
+        getInScope, setInScopeFromE, setInScopeFromF,
+        setInScopeSet, modifyInScope, addNewInScopeIds,
+        getSimplRules,
+
+        -- * Substitution results
+        SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,
+
+        -- * Simplifying 'Id' binders
+        simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,
+        simplBinder, simplBinders,
+        substTy, substTyVar, getTCvSubst,
+        substCo, substCoVar,
+
+        -- * Floats
+        SimplFloats(..), emptyFloats, mkRecFloats,
+        mkFloatBind, addLetFloats, addJoinFloats, addFloats,
+        extendFloats, wrapFloats,
+        doFloatFromRhs, getTopFloatBinds,
+
+        -- * LetFloats
+        LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat,
+        addLetFlts,  mapLetFloats,
+
+        -- * JoinFloats
+        JoinFloat, JoinFloats, emptyJoinFloats,
+        wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import SimplMonad
+import CoreMonad                ( SimplMode(..) )
+import CoreSyn
+import CoreUtils
+import Var
+import VarEnv
+import VarSet
+import OrdList
+import Id
+import MkCore                   ( mkWildValBinder )
+import DynFlags                 ( DynFlags )
+import TysWiredIn
+import qualified Type
+import Type hiding              ( substTy, substTyVar, substTyVarBndr )
+import qualified Coercion
+import Coercion hiding          ( substCo, substCoVar, substCoVarBndr )
+import BasicTypes
+import MonadUtils
+import Outputable
+import Util
+import UniqFM                   ( pprUniqFM )
+
+import Data.List
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{The @SimplEnv@ type}
+*                                                                      *
+************************************************************************
+-}
+
+data SimplEnv
+  = SimplEnv {
+     ----------- Static part of the environment -----------
+     -- Static in the sense of lexically scoped,
+     -- wrt the original expression
+
+        seMode      :: SimplMode
+
+        -- The current substitution
+      , seTvSubst   :: TvSubstEnv      -- InTyVar |--> OutType
+      , seCvSubst   :: CvSubstEnv      -- InCoVar |--> OutCoercion
+      , seIdSubst   :: SimplIdSubst    -- InId    |--> OutExpr
+
+     ----------- Dynamic part of the environment -----------
+     -- Dynamic in the sense of describing the setup where
+     -- the expression finally ends up
+
+        -- The current set of in-scope variables
+        -- They are all OutVars, and all bound in this module
+      , seInScope   :: InScopeSet       -- OutVars only
+    }
+
+data SimplFloats
+  = SimplFloats
+      { -- Ordinary let bindings
+        sfLetFloats  :: LetFloats
+                -- See Note [LetFloats]
+
+        -- Join points
+      , sfJoinFloats :: JoinFloats
+                -- Handled separately; they don't go very far
+                -- We consider these to be /inside/ sfLetFloats
+                -- because join points can refer to ordinary bindings,
+                -- but not vice versa
+
+        -- Includes all variables bound by sfLetFloats and
+        -- sfJoinFloats, plus at least whatever is in scope where
+        -- these bindings land up.
+      , sfInScope :: InScopeSet  -- All OutVars
+      }
+
+instance Outputable SimplFloats where
+  ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is })
+    = text "SimplFloats"
+      <+> braces (vcat [ text "lets: " <+> ppr lf
+                       , text "joins:" <+> ppr jf
+                       , text "in_scope:" <+> ppr is ])
+
+emptyFloats :: SimplEnv -> SimplFloats
+emptyFloats env
+  = SimplFloats { sfLetFloats  = emptyLetFloats
+                , sfJoinFloats = emptyJoinFloats
+                , sfInScope    = seInScope env }
+
+pprSimplEnv :: SimplEnv -> SDoc
+-- Used for debugging; selective
+pprSimplEnv env
+  = vcat [text "TvSubst:" <+> ppr (seTvSubst env),
+          text "CvSubst:" <+> ppr (seCvSubst env),
+          text "IdSubst:" <+> id_subst_doc,
+          text "InScope:" <+> in_scope_vars_doc
+    ]
+  where
+   id_subst_doc = pprUniqFM ppr (seIdSubst env)
+   in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env))
+                                 (vcat . map ppr_one)
+   ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)
+             | otherwise = ppr v
+
+type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr
+        -- See Note [Extending the Subst] in CoreSubst
+
+-- | A substitution result.
+data SimplSR
+  = DoneEx OutExpr (Maybe JoinArity)
+       -- If  x :-> DoneEx e ja   is in the SimplIdSubst
+       -- then replace occurrences of x by e
+       -- and  ja = Just a <=> x is a join-point of arity a
+       -- See Note [Join arity in SimplIdSubst]
+
+
+  | DoneId OutId
+       -- If  x :-> DoneId v   is in the SimplIdSubst
+       -- then replace occurrences of x by v
+       -- and  v is a join-point of arity a
+       --      <=> x is a join-point of arity a
+
+  | ContEx TvSubstEnv                 -- A suspended substitution
+           CvSubstEnv
+           SimplIdSubst
+           InExpr
+      -- If   x :-> ContEx tv cv id e   is in the SimplISubst
+      -- then replace occurrences of x by (subst (tv,cv,id) e)
+
+instance Outputable SimplSR where
+  ppr (DoneId v)    = text "DoneId" <+> ppr v
+  ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e
+    where
+      pp_mj = case mj of
+                Nothing -> empty
+                Just n  -> parens (int n)
+
+  ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,
+                                ppr (filter_env tv), ppr (filter_env id) -}]
+        -- where
+        -- fvs = exprFreeVars e
+        -- filter_env env = filterVarEnv_Directly keep env
+        -- keep uniq _ = uniq `elemUFM_Directly` fvs
+
+{-
+Note [SimplEnv invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+seInScope:
+        The in-scope part of Subst includes *all* in-scope TyVars and Ids
+        The elements of the set may have better IdInfo than the
+        occurrences of in-scope Ids, and (more important) they will
+        have a correctly-substituted type.  So we use a lookup in this
+        set to replace occurrences
+
+        The Ids in the InScopeSet are replete with their Rules,
+        and as we gather info about the unfolding of an Id, we replace
+        it in the in-scope set.
+
+        The in-scope set is actually a mapping OutVar -> OutVar, and
+        in case expressions we sometimes bind
+
+seIdSubst:
+        The substitution is *apply-once* only, because InIds and OutIds
+        can overlap.
+        For example, we generally omit mappings
+                a77 -> a77
+        from the substitution, when we decide not to clone a77, but it's quite
+        legitimate to put the mapping in the substitution anyway.
+
+        Furthermore, consider
+                let x = case k of I# x77 -> ... in
+                let y = case k of I# x77 -> ... in ...
+        and suppose the body is strict in both x and y.  Then the simplifier
+        will pull the first (case k) to the top; so the second (case k) will
+        cancel out, mapping x77 to, well, x77!  But one is an in-Id and the
+        other is an out-Id.
+
+        Of course, the substitution *must* applied! Things in its domain
+        simply aren't necessarily bound in the result.
+
+* substId adds a binding (DoneId new_id) to the substitution if
+        the Id's unique has changed
+
+  Note, though that the substitution isn't necessarily extended
+  if the type of the Id changes.  Why not?  Because of the next point:
+
+* We *always, always* finish by looking up in the in-scope set
+  any variable that doesn't get a DoneEx or DoneVar hit in the substitution.
+  Reason: so that we never finish up with a "old" Id in the result.
+  An old Id might point to an old unfolding and so on... which gives a space
+  leak.
+
+  [The DoneEx and DoneVar hits map to "new" stuff.]
+
+* It follows that substExpr must not do a no-op if the substitution is empty.
+  substType is free to do so, however.
+
+* When we come to a let-binding (say) we generate new IdInfo, including an
+  unfolding, attach it to the binder, and add this newly adorned binder to
+  the in-scope set.  So all subsequent occurrences of the binder will get
+  mapped to the full-adorned binder, which is also the one put in the
+  binding site.
+
+* The in-scope "set" usually maps x->x; we use it simply for its domain.
+  But sometimes we have two in-scope Ids that are synomyms, and should
+  map to the same target:  x->x, y->x.  Notably:
+        case y of x { ... }
+  That's why the "set" is actually a VarEnv Var
+
+Note [Join arity in SimplIdSubst]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have to remember which incoming variables are join points: the occurrences
+may not be marked correctly yet, and we're in change of propagating the change if
+OccurAnal makes something a join point).
+
+Normally the in-scope set is where we keep the latest information, but
+the in-scope set tracks only OutVars; if a binding is unconditionally
+inlined (via DoneEx), it never makes it into the in-scope set, and we
+need to know at the occurrence site that the variable is a join point
+so that we know to drop the context. Thus we remember which join
+points we're substituting. -}
+
+mkSimplEnv :: SimplMode -> SimplEnv
+mkSimplEnv mode
+  = SimplEnv { seMode = mode
+             , seInScope = init_in_scope
+             , seTvSubst = emptyVarEnv
+             , seCvSubst = emptyVarEnv
+             , seIdSubst = emptyVarEnv }
+        -- The top level "enclosing CC" is "SUBSUMED".
+
+init_in_scope :: InScopeSet
+init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))
+              -- See Note [WildCard binders]
+
+{-
+Note [WildCard binders]
+~~~~~~~~~~~~~~~~~~~~~~~
+The program to be simplified may have wild binders
+    case e of wild { p -> ... }
+We want to *rename* them away, so that there are no
+occurrences of 'wild-id' (with wildCardKey).  The easy
+way to do that is to start of with a representative
+Id in the in-scope set
+
+There can be *occurrences* of wild-id.  For example,
+MkCore.mkCoreApp transforms
+   e (a /# b)   -->   case (a /# b) of wild { DEFAULT -> e wild }
+This is ok provided 'wild' isn't free in 'e', and that's the delicate
+thing. Generally, you want to run the simplifier to get rid of the
+wild-ids before doing much else.
+
+It's a very dark corner of GHC.  Maybe it should be cleaned up.
+-}
+
+getMode :: SimplEnv -> SimplMode
+getMode env = seMode env
+
+seDynFlags :: SimplEnv -> DynFlags
+seDynFlags env = sm_dflags (seMode env)
+
+setMode :: SimplMode -> SimplEnv -> SimplEnv
+setMode mode env = env { seMode = mode }
+
+updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv
+updMode upd env = env { seMode = upd (seMode env) }
+
+---------------------
+extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv
+extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res
+  = ASSERT2( isId var && not (isCoVar var), ppr var )
+    env { seIdSubst = extendVarEnv subst var res }
+
+extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv
+extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res
+  = ASSERT2( isTyVar var, ppr var $$ ppr res )
+    env {seTvSubst = extendVarEnv tsubst var res}
+
+extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv
+extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co
+  = ASSERT( isCoVar var )
+    env {seCvSubst = extendVarEnv csubst var co}
+
+---------------------
+getInScope :: SimplEnv -> InScopeSet
+getInScope env = seInScope env
+
+setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv
+setInScopeSet env in_scope = env {seInScope = in_scope}
+
+setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv
+-- See Note [Setting the right in-scope set]
+setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env }
+
+setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv
+setInScopeFromF env floats = env { seInScope = sfInScope floats }
+
+addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
+        -- The new Ids are guaranteed to be freshly allocated
+addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
+  = env { seInScope = in_scope `extendInScopeSetList` vs,
+          seIdSubst = id_subst `delVarEnvList` vs }
+        -- Why delete?  Consider
+        --      let x = a*b in (x, \x -> x+3)
+        -- We add [x |-> a*b] to the substitution, but we must
+        -- _delete_ it from the substitution when going inside
+        -- the (\x -> ...)!
+
+modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
+-- The variable should already be in scope, but
+-- replace the existing version with this new one
+-- which has more information
+modifyInScope env@(SimplEnv {seInScope = in_scope}) v
+  = env {seInScope = extendInScopeSet in_scope v}
+
+{- Note [Setting the right in-scope set]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  \x. (let x = e in b) arg[x]
+where the let shadows the lambda.  Really this means something like
+  \x1. (let x2 = e in b) arg[x1]
+
+- When we capture the 'arg' in an ApplyToVal continuation, we capture
+  the environment, which says what 'x' is bound to, namely x1
+
+- Then that continuation gets pushed under the let
+
+- Finally we simplify 'arg'.  We want
+     - the static, lexical environment bindig x :-> x1
+     - the in-scopeset from "here", under the 'let' which includes
+       both x1 and x2
+
+It's important to have the right in-scope set, else we may rename a
+variable to one that is already in scope.  So we must pick up the
+in-scope set from "here", but otherwise use the environment we
+captured along with 'arg'.  This transfer of in-scope set is done by
+setInScopeFromE.
+-}
+
+---------------------
+zapSubstEnv :: SimplEnv -> SimplEnv
+zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}
+
+setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv
+setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }
+
+mkContEx :: SimplEnv -> InExpr -> SimplSR
+mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{LetFloats}
+*                                                                      *
+************************************************************************
+
+Note [LetFloats]
+~~~~~~~~~~~~~~~~
+The LetFloats is a bunch of bindings, classified by a FloatFlag.
+
+* All of them satisfy the let/app invariant
+
+Examples
+
+  NonRec x (y:ys)       FltLifted
+  Rec [(x,rhs)]         FltLifted
+
+  NonRec x* (p:q)       FltOKSpec   -- RHS is WHNF.  Question: why not FltLifted?
+  NonRec x# (y +# 3)    FltOkSpec   -- Unboxed, but ok-for-spec'n
+
+  NonRec x* (f y)       FltCareful  -- Strict binding; might fail or diverge
+
+Can't happen:
+  NonRec x# (a /# b)    -- Might fail; does not satisfy let/app
+  NonRec x# (f y)       -- Might diverge; does not satisfy let/app
+-}
+
+data LetFloats = LetFloats (OrdList OutBind) FloatFlag
+                 -- See Note [LetFloats]
+
+type JoinFloat  = OutBind
+type JoinFloats = OrdList JoinFloat
+
+data FloatFlag
+  = FltLifted   -- All bindings are lifted and lazy *or*
+                --     consist of a single primitive string literal
+                --  Hence ok to float to top level, or recursive
+
+  | FltOkSpec   -- All bindings are FltLifted *or*
+                --      strict (perhaps because unlifted,
+                --      perhaps because of a strict binder),
+                --        *and* ok-for-speculation
+                --  Hence ok to float out of the RHS
+                --  of a lazy non-recursive let binding
+                --  (but not to top level, or into a rec group)
+
+  | FltCareful  -- At least one binding is strict (or unlifted)
+                --      and not guaranteed cheap
+                --      Do not float these bindings out of a lazy let
+
+instance Outputable LetFloats where
+  ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds)
+
+instance Outputable FloatFlag where
+  ppr FltLifted  = text "FltLifted"
+  ppr FltOkSpec  = text "FltOkSpec"
+  ppr FltCareful = text "FltCareful"
+
+andFF :: FloatFlag -> FloatFlag -> FloatFlag
+andFF FltCareful _          = FltCareful
+andFF FltOkSpec  FltCareful = FltCareful
+andFF FltOkSpec  _          = FltOkSpec
+andFF FltLifted  flt        = flt
+
+doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool
+-- If you change this function look also at FloatIn.noFloatFromRhs
+doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs
+  =  not (isNilOL fs) && want_to_float && can_float
+  where
+     want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs
+                     -- See Note [Float when cheap or expandable]
+     can_float = case ff of
+                   FltLifted  -> True
+                   FltOkSpec  -> isNotTopLevel lvl && isNonRec rec
+                   FltCareful -> isNotTopLevel lvl && isNonRec rec && str
+
+{-
+Note [Float when cheap or expandable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to float a let from a let if the residual RHS is
+   a) cheap, such as (\x. blah)
+   b) expandable, such as (f b) if f is CONLIKE
+But there are
+  - cheap things that are not expandable (eg \x. expensive)
+  - expandable things that are not cheap (eg (f b) where b is CONLIKE)
+so we must take the 'or' of the two.
+-}
+
+emptyLetFloats :: LetFloats
+emptyLetFloats = LetFloats nilOL FltLifted
+
+emptyJoinFloats :: JoinFloats
+emptyJoinFloats = nilOL
+
+unitLetFloat :: OutBind -> LetFloats
+-- This key function constructs a singleton float with the right form
+unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))
+                    LetFloats (unitOL bind) (flag bind)
+  where
+    flag (Rec {})                = FltLifted
+    flag (NonRec bndr rhs)
+      | not (isStrictId bndr)    = FltLifted
+      | exprIsTickedString rhs   = FltLifted
+          -- String literals can be floated freely.
+          -- See Note [CoreSyn top-level string literals] in CoreSyn.
+      | exprOkForSpeculation rhs = FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)
+      | otherwise                = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )
+                                   FltCareful
+      -- Unlifted binders can only be let-bound if exprOkForSpeculation holds
+
+unitJoinFloat :: OutBind -> JoinFloats
+unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind))
+                     unitOL bind
+
+mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)
+-- Make a singleton SimplFloats, and
+-- extend the incoming SimplEnv's in-scope set with its binders
+-- These binders may already be in the in-scope set,
+-- but may have by now been augmented with more IdInfo
+mkFloatBind env bind
+  = (floats, env { seInScope = in_scope' })
+  where
+    floats
+      | isJoinBind bind
+      = SimplFloats { sfLetFloats  = emptyLetFloats
+                    , sfJoinFloats = unitJoinFloat bind
+                    , sfInScope    = in_scope' }
+      | otherwise
+      = SimplFloats { sfLetFloats  = unitLetFloat bind
+                    , sfJoinFloats = emptyJoinFloats
+                    , sfInScope    = in_scope' }
+
+    in_scope' = seInScope env `extendInScopeSetBind` bind
+
+extendFloats :: SimplFloats -> OutBind -> SimplFloats
+-- Add this binding to the floats, and extend the in-scope env too
+extendFloats (SimplFloats { sfLetFloats  = floats
+                          , sfJoinFloats = jfloats
+                          , sfInScope    = in_scope })
+             bind
+  | isJoinBind bind
+  = SimplFloats { sfInScope    = in_scope'
+                , sfLetFloats  = floats
+                , sfJoinFloats = jfloats' }
+  | otherwise
+  = SimplFloats { sfInScope    = in_scope'
+                , sfLetFloats  = floats'
+                , sfJoinFloats = jfloats }
+  where
+    in_scope' = in_scope `extendInScopeSetBind` bind
+    floats'   = floats  `addLetFlts`  unitLetFloat bind
+    jfloats'  = jfloats `addJoinFlts` unitJoinFloat bind
+
+addLetFloats :: SimplFloats -> LetFloats -> SimplFloats
+-- Add the let-floats for env2 to env1;
+-- *plus* the in-scope set for env2, which is bigger
+-- than that for env1
+addLetFloats floats let_floats@(LetFloats binds _)
+  = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats
+           , sfInScope   = foldlOL extendInScopeSetBind
+                                   (sfInScope floats) binds }
+
+addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats
+addJoinFloats floats join_floats
+  = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats
+           , sfInScope    = foldlOL extendInScopeSetBind
+                                    (sfInScope floats) join_floats }
+
+extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet
+extendInScopeSetBind in_scope bind
+  = extendInScopeSetList in_scope (bindersOf bind)
+
+addFloats :: SimplFloats -> SimplFloats -> SimplFloats
+-- Add both let-floats and join-floats for env2 to env1;
+-- *plus* the in-scope set for env2, which is bigger
+-- than that for env1
+addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 })
+          (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope })
+  = SimplFloats { sfLetFloats  = lf1 `addLetFlts` lf2
+                , sfJoinFloats = jf1 `addJoinFlts` jf2
+                , sfInScope    = in_scope }
+
+addLetFlts :: LetFloats -> LetFloats -> LetFloats
+addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2)
+  = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2)
+
+letFloatBinds :: LetFloats -> [CoreBind]
+letFloatBinds (LetFloats bs _) = fromOL bs
+
+addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats
+addJoinFlts = appOL
+
+mkRecFloats :: SimplFloats -> SimplFloats
+-- Flattens the floats from env2 into a single Rec group,
+-- They must either all be lifted LetFloats or all JoinFloats
+mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats bs ff
+                                , sfJoinFloats = jbs
+                                , sfInScope    = in_scope })
+  = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )
+    ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )
+    SimplFloats { sfLetFloats  = floats'
+                , sfJoinFloats = jfloats'
+                , sfInScope    = in_scope }
+  where
+    floats'  | isNilOL bs  = emptyLetFloats
+             | otherwise   = unitLetFloat (Rec (flattenBinds (fromOL bs)))
+    jfloats' | isNilOL jbs = emptyJoinFloats
+             | otherwise   = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))
+
+wrapFloats :: SimplFloats -> OutExpr -> OutExpr
+-- Wrap the floats around the expression; they should all
+-- satisfy the let/app invariant, so mkLets should do the job just fine
+wrapFloats (SimplFloats { sfLetFloats  = LetFloats bs _
+                        , sfJoinFloats = jbs }) body
+  = foldrOL Let (wrapJoinFloats jbs body) bs
+     -- Note: Always safe to put the joins on the inside
+     -- since the values can't refer to them
+
+wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr)
+-- Wrap the sfJoinFloats of the env around the expression,
+-- and take them out of the SimplEnv
+wrapJoinFloatsX floats body
+  = ( floats { sfJoinFloats = emptyJoinFloats }
+    , wrapJoinFloats (sfJoinFloats floats) body )
+
+wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr
+-- Wrap the sfJoinFloats of the env around the expression,
+-- and take them out of the SimplEnv
+wrapJoinFloats join_floats body
+  = foldrOL Let body join_floats
+
+getTopFloatBinds :: SimplFloats -> [CoreBind]
+getTopFloatBinds (SimplFloats { sfLetFloats  = lbs
+                              , sfJoinFloats = jbs})
+  = ASSERT( isNilOL jbs )  -- Can't be any top-level join bindings
+    letFloatBinds lbs
+
+mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats
+mapLetFloats (LetFloats fs ff) fun
+   = LetFloats (mapOL app fs) ff
+   where
+    app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'
+    app (Rec bs)     = Rec (map fun bs)
+
+{-
+************************************************************************
+*                                                                      *
+                Substitution of Vars
+*                                                                      *
+************************************************************************
+
+Note [Global Ids in the substitution]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We look up even a global (eg imported) Id in the substitution. Consider
+   case X.g_34 of b { (a,b) ->  ... case X.g_34 of { (p,q) -> ...} ... }
+The binder-swap in the occurrence analyser will add a binding
+for a LocalId version of g (with the same unique though):
+   case X.g_34 of b { (a,b) ->  let g_34 = b in
+                                ... case X.g_34 of { (p,q) -> ...} ... }
+So we want to look up the inner X.g_34 in the substitution, where we'll
+find that it has been substituted by b.  (Or conceivably cloned.)
+-}
+
+substId :: SimplEnv -> InId -> SimplSR
+-- Returns DoneEx only on a non-Var expression
+substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
+  = case lookupVarEnv ids v of  -- Note [Global Ids in the substitution]
+        Nothing               -> DoneId (refineFromInScope in_scope v)
+        Just (DoneId v)       -> DoneId (refineFromInScope in_scope v)
+        Just res              -> res    -- DoneEx non-var, or ContEx
+
+        -- Get the most up-to-date thing from the in-scope set
+        -- Even though it isn't in the substitution, it may be in
+        -- the in-scope set with better IdInfo
+
+refineFromInScope :: InScopeSet -> Var -> Var
+refineFromInScope in_scope v
+  | isLocalId v = case lookupInScope in_scope v of
+                  Just v' -> v'
+                  Nothing -> WARN( True, ppr v ) v  -- This is an error!
+  | otherwise = v
+
+lookupRecBndr :: SimplEnv -> InId -> OutId
+-- Look up an Id which has been put into the envt by simplRecBndrs,
+-- but where we have not yet done its RHS
+lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
+  = case lookupVarEnv ids v of
+        Just (DoneId v) -> v
+        Just _ -> pprPanic "lookupRecBndr" (ppr v)
+        Nothing -> refineFromInScope in_scope v
+
+{-
+************************************************************************
+*                                                                      *
+\section{Substituting an Id binder}
+*                                                                      *
+************************************************************************
+
+
+These functions are in the monad only so that they can be made strict via seq.
+
+Note [Return type for join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+   (join j :: Char -> Int -> Int) 77
+   (     j x = \y. y + ord x    )
+   (in case v of                )
+   (     A -> j 'x'             )
+   (     B -> j 'y'             )
+   (     C -> <blah>            )
+
+The simplifier pushes the "apply to 77" continuation inwards to give
+
+   join j :: Char -> Int
+        j x = (\y. y + ord x) 77
+   in case v of
+        A -> j 'x'
+        B -> j 'y'
+        C -> <blah> 77
+
+Notice that the "apply to 77" continuation went into the RHS of the
+join point.  And that meant that the return type of the join point
+changed!!
+
+That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr
+takes a (Just res_ty) argument so that it knows to do the type-changing
+thing.
+-}
+
+simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
+simplBinders  env bndrs = mapAccumLM simplBinder  env bndrs
+
+-------------
+simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
+-- Used for lambda and case-bound variables
+-- Clone Id if necessary, substitute type
+-- Return with IdInfo already substituted, but (fragile) occurrence info zapped
+-- The substitution is extended only if the variable is cloned, because
+-- we *don't* need to use it to track occurrence info.
+simplBinder env bndr
+  | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr
+                        ; seqTyVar tv `seq` return (env', tv) }
+  | otherwise     = do  { let (env', id) = substIdBndr Nothing env bndr
+                        ; seqId id `seq` return (env', id) }
+
+---------------
+simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
+-- A non-recursive let binder
+simplNonRecBndr env id
+  = do  { let (env1, id1) = substIdBndr Nothing env id
+        ; seqId id1 `seq` return (env1, id1) }
+
+---------------
+simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr
+                    -> SimplM (SimplEnv, OutBndr)
+-- A non-recursive let binder for a join point;
+-- context being pushed inward may change the type
+-- See Note [Return type for join points]
+simplNonRecJoinBndr env res_ty id
+  = do  { let (env1, id1) = substIdBndr (Just res_ty) env id
+        ; seqId id1 `seq` return (env1, id1) }
+
+---------------
+simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
+-- Recursive let binders
+simplRecBndrs env@(SimplEnv {}) ids
+  = ASSERT(all (not . isJoinId) ids)
+    do  { let (env1, ids1) = mapAccumL (substIdBndr Nothing) env ids
+        ; seqIds ids1 `seq` return env1 }
+
+---------------
+simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv
+-- Recursive let binders for join points;
+-- context being pushed inward may change types
+-- See Note [Return type for join points]
+simplRecJoinBndrs env@(SimplEnv {}) res_ty ids
+  = ASSERT(all isJoinId ids)
+    do  { let (env1, ids1) = mapAccumL (substIdBndr (Just res_ty)) env ids
+        ; seqIds ids1 `seq` return env1 }
+
+---------------
+substIdBndr :: Maybe OutType -> SimplEnv -> InBndr -> (SimplEnv, OutBndr)
+-- Might be a coercion variable
+substIdBndr new_res_ty env bndr
+  | isCoVar bndr  = substCoVarBndr env bndr
+  | otherwise     = substNonCoVarIdBndr new_res_ty env bndr
+
+---------------
+substNonCoVarIdBndr
+   :: Maybe OutType -- New result type, if a join binder
+                    -- See Note [Return type for join points]
+   -> SimplEnv
+   -> InBndr    -- Env and binder to transform
+   -> (SimplEnv, OutBndr)
+-- Clone Id if necessary, substitute its type
+-- Return an Id with its
+--      * Type substituted
+--      * UnfoldingInfo, Rules, WorkerInfo zapped
+--      * Fragile OccInfo (only) zapped: Note [Robust OccInfo]
+--      * Robust info, retained especially arity and demand info,
+--         so that they are available to occurrences that occur in an
+--         earlier binding of a letrec
+--
+-- For the robust info, see Note [Arity robustness]
+--
+-- Augment the substitution  if the unique changed
+-- Extend the in-scope set with the new Id
+--
+-- Similar to CoreSubst.substIdBndr, except that
+--      the type of id_subst differs
+--      all fragile info is zapped
+substNonCoVarIdBndr new_res_ty
+                    env@(SimplEnv { seInScope = in_scope
+                                  , seIdSubst = id_subst })
+                    old_id
+  = ASSERT2( not (isCoVar old_id), ppr old_id )
+    (env { seInScope = in_scope `extendInScopeSet` new_id,
+           seIdSubst = new_subst }, new_id)
+  where
+    id1    = uniqAway in_scope old_id
+    id2    = substIdType env id1
+
+    id3    | Just res_ty <- new_res_ty
+           = id2 `setIdType` setJoinResTy (idJoinArity id2) res_ty (idType id2)
+                             -- See Note [Return type for join points]
+           | otherwise
+           = id2
+
+    new_id = zapFragileIdInfo id3       -- Zaps rules, worker-info, unfolding
+                                        -- and fragile OccInfo
+
+        -- Extend the substitution if the unique has changed,
+        -- or there's some useful occurrence information
+        -- See the notes with substTyVarBndr for the delSubstEnv
+    new_subst | new_id /= old_id
+              = extendVarEnv id_subst old_id (DoneId new_id)
+              | otherwise
+              = delVarEnv id_subst old_id
+
+------------------------------------
+seqTyVar :: TyVar -> ()
+seqTyVar b = b `seq` ()
+
+seqId :: Id -> ()
+seqId id = seqType (idType id)  `seq`
+           idInfo id            `seq`
+           ()
+
+seqIds :: [Id] -> ()
+seqIds []       = ()
+seqIds (id:ids) = seqId id `seq` seqIds ids
+
+{-
+Note [Arity robustness]
+~~~~~~~~~~~~~~~~~~~~~~~
+We *do* transfer the arity from from the in_id of a let binding to the
+out_id.  This is important, so that the arity of an Id is visible in
+its own RHS.  For example:
+        f = \x. ....g (\y. f y)....
+We can eta-reduce the arg to g, because f is a value.  But that
+needs to be visible.
+
+This interacts with the 'state hack' too:
+        f :: Bool -> IO Int
+        f = \x. case x of
+                  True  -> f y
+                  False -> \s -> ...
+Can we eta-expand f?  Only if we see that f has arity 1, and then we
+take advantage of the 'state hack' on the result of
+(f y) :: State# -> (State#, Int) to expand the arity one more.
+
+There is a disadvantage though.  Making the arity visible in the RHS
+allows us to eta-reduce
+        f = \x -> f x
+to
+        f = f
+which technically is not sound.   This is very much a corner case, so
+I'm not worried about it.  Another idea is to ensure that f's arity
+never decreases; its arity started as 1, and we should never eta-reduce
+below that.
+
+
+Note [Robust OccInfo]
+~~~~~~~~~~~~~~~~~~~~~
+It's important that we *do* retain the loop-breaker OccInfo, because
+that's what stops the Id getting inlined infinitely, in the body of
+the letrec.
+-}
+
+
+{-
+************************************************************************
+*                                                                      *
+                Impedance matching to type substitution
+*                                                                      *
+************************************************************************
+-}
+
+getTCvSubst :: SimplEnv -> TCvSubst
+getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env
+                      , seCvSubst = cv_env })
+  = mkTCvSubst in_scope (tv_env, cv_env)
+
+substTy :: SimplEnv -> Type -> Type
+substTy env ty = Type.substTy (getTCvSubst env) ty
+
+substTyVar :: SimplEnv -> TyVar -> Type
+substTyVar env tv = Type.substTyVar (getTCvSubst env) tv
+
+substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)
+substTyVarBndr env tv
+  = case Type.substTyVarBndr (getTCvSubst env) tv of
+        (TCvSubst in_scope' tv_env' cv_env', tv')
+           -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv')
+
+substCoVar :: SimplEnv -> CoVar -> Coercion
+substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv
+
+substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)
+substCoVarBndr env cv
+  = case Coercion.substCoVarBndr (getTCvSubst env) cv of
+        (TCvSubst in_scope' tv_env' cv_env', cv')
+           -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')
+
+substCo :: SimplEnv -> Coercion -> Coercion
+substCo env co = Coercion.substCo (getTCvSubst env) co
+
+------------------
+substIdType :: SimplEnv -> Id -> Id
+substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id
+  |  (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env)
+  || noFreeVarsOfType old_ty
+  = id
+  | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty)
+                -- The tyCoVarsOfType is cheaper than it looks
+                -- because we cache the free tyvars of the type
+                -- in a Note in the id's type itself
+  where
+    old_ty = idType id
diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/SimplMonad.hs
@@ -0,0 +1,250 @@
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+\section[SimplMonad]{The simplifier Monad}
+-}
+
+module SimplMonad (
+        -- The monad
+        SimplM,
+        initSmpl, traceSmpl,
+        getSimplRules, getFamEnvs,
+
+        -- Unique supply
+        MonadUnique(..), newId, newJoinId,
+
+        -- Counting
+        SimplCount, tick, freeTick, checkedTick,
+        getSimplCount, zeroSimplCount, pprSimplCount,
+        plusSimplCount, isZeroSimplCount
+    ) where
+
+import GhcPrelude
+
+import Var              ( Var, isTyVar, mkLocalVar )
+import Name             ( mkSystemVarName )
+import Id               ( Id, mkSysLocalOrCoVar )
+import IdInfo           ( IdDetails(..), vanillaIdInfo, setArityInfo )
+import Type             ( Type, mkLamTypes )
+import FamInstEnv       ( FamInstEnv )
+import CoreSyn          ( RuleEnv(..) )
+import UniqSupply
+import DynFlags
+import CoreMonad
+import Outputable
+import FastString
+import MonadUtils
+import ErrUtils as Err
+import Panic (throwGhcExceptionIO, GhcException (..))
+import BasicTypes          ( IntWithInf, treatZeroAsInf, mkIntWithInf )
+import Control.Monad       ( liftM, ap )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Monad plumbing}
+*                                                                      *
+************************************************************************
+
+For the simplifier monad, we want to {\em thread} a unique supply and a counter.
+(Command-line switches move around through the explicitly-passed SimplEnv.)
+-}
+
+newtype SimplM result
+  =  SM  { unSM :: SimplTopEnv  -- Envt that does not change much
+                -> UniqSupply   -- We thread the unique supply because
+                                -- constantly splitting it is rather expensive
+                -> SimplCount
+                -> IO (result, UniqSupply, SimplCount)}
+  -- we only need IO here for dump output
+
+data SimplTopEnv
+  = STE { st_flags     :: DynFlags
+        , st_max_ticks :: IntWithInf  -- Max #ticks in this simplifier run
+        , st_rules     :: RuleEnv
+        , st_fams      :: (FamInstEnv, FamInstEnv) }
+
+initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)
+         -> UniqSupply          -- No init count; set to 0
+         -> Int                 -- Size of the bindings, used to limit
+                                -- the number of ticks we allow
+         -> SimplM a
+         -> IO (a, SimplCount)
+
+initSmpl dflags rules fam_envs us size m
+  = do (result, _, count) <- unSM m env us (zeroSimplCount dflags)
+       return (result, count)
+  where
+    env = STE { st_flags = dflags, st_rules = rules
+              , st_max_ticks = computeMaxTicks dflags size
+              , st_fams = fam_envs }
+
+computeMaxTicks :: DynFlags -> Int -> IntWithInf
+-- Compute the max simplifier ticks as
+--     (base-size + pgm-size) * magic-multiplier * tick-factor/100
+-- where
+--    magic-multiplier is a constant that gives reasonable results
+--    base-size is a constant to deal with size-zero programs
+computeMaxTicks dflags size
+  = treatZeroAsInf $
+    fromInteger ((toInteger (size + base_size)
+                  * toInteger (tick_factor * magic_multiplier))
+          `div` 100)
+  where
+    tick_factor      = simplTickFactor dflags
+    base_size        = 100
+    magic_multiplier = 40
+        -- MAGIC NUMBER, multiplies the simplTickFactor
+        -- We can afford to be generous; this is really
+        -- just checking for loops, and shouldn't usually fire
+        -- A figure of 20 was too small: see Trac #5539.
+
+{-# INLINE thenSmpl #-}
+{-# INLINE thenSmpl_ #-}
+{-# INLINE returnSmpl #-}
+
+
+instance Functor SimplM where
+    fmap = liftM
+
+instance Applicative SimplM where
+    pure  = returnSmpl
+    (<*>) = ap
+    (*>)  = thenSmpl_
+
+instance Monad SimplM where
+   (>>)   = (*>)
+   (>>=)  = thenSmpl
+
+returnSmpl :: a -> SimplM a
+returnSmpl e = SM (\_st_env us sc -> return (e, us, sc))
+
+thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b
+thenSmpl_ :: SimplM a -> SimplM b -> SimplM b
+
+thenSmpl m k
+  = SM $ \st_env us0 sc0 -> do
+      (m_result, us1, sc1) <- unSM m st_env us0 sc0
+      unSM (k m_result) st_env us1 sc1
+
+thenSmpl_ m k
+  = SM $ \st_env us0 sc0 -> do
+      (_, us1, sc1) <- unSM m st_env us0 sc0
+      unSM k st_env us1 sc1
+
+-- TODO: this specializing is not allowed
+-- {-# SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}
+-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}
+-- {-# SPECIALIZE mapAccumLM   :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}
+
+traceSmpl :: String -> SDoc -> SimplM ()
+traceSmpl herald doc
+  = do { dflags <- getDynFlags
+       ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace"
+           (hang (text herald) 2 doc) }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{The unique supply}
+*                                                                      *
+************************************************************************
+-}
+
+instance MonadUnique SimplM where
+    getUniqueSupplyM
+       = SM (\_st_env us sc -> case splitUniqSupply us of
+                                (us1, us2) -> return (us1, us2, sc))
+
+    getUniqueM
+       = SM (\_st_env us sc -> case takeUniqFromSupply us of
+                                (u, us') -> return (u, us', sc))
+
+    getUniquesM
+        = SM (\_st_env us sc -> case splitUniqSupply us of
+                                (us1, us2) -> return (uniqsFromSupply us1, us2, sc))
+
+instance HasDynFlags SimplM where
+    getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc))
+
+instance MonadIO SimplM where
+    liftIO m = SM $ \_ us sc -> do
+      x <- m
+      return (x, us, sc)
+
+getSimplRules :: SimplM RuleEnv
+getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc))
+
+getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
+getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc))
+
+newId :: FastString -> Type -> SimplM Id
+newId fs ty = do uniq <- getUniqueM
+                 return (mkSysLocalOrCoVar fs uniq ty)
+
+newJoinId :: [Var] -> Type -> SimplM Id
+newJoinId bndrs body_ty
+  = do { uniq <- getUniqueM
+       ; let name       = mkSystemVarName uniq (fsLit "$j")
+             join_id_ty = mkLamTypes bndrs body_ty  -- Note [Funky mkLamTypes]
+             arity      = length (filter (not . isTyVar) bndrs)
+             join_arity = length bndrs
+             details    = JoinId join_arity
+             id_info    = vanillaIdInfo `setArityInfo` arity
+--                                        `setOccInfo` strongLoopBreaker
+
+       ; return (mkLocalVar details name join_id_ty id_info) }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Counting up what we've done}
+*                                                                      *
+************************************************************************
+-}
+
+getSimplCount :: SimplM SimplCount
+getSimplCount = SM (\_st_env us sc -> return (sc, us, sc))
+
+tick :: Tick -> SimplM ()
+tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc
+                              in sc' `seq` return ((), us, sc'))
+
+checkedTick :: Tick -> SimplM ()
+-- Try to take a tick, but fail if too many
+checkedTick t
+  = SM (\st_env us sc ->
+           if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)
+           then throwGhcExceptionIO $
+                  PprProgramError "Simplifier ticks exhausted" (msg sc)
+           else let sc' = doSimplTick (st_flags st_env) t sc
+                in sc' `seq` return ((), us, sc'))
+  where
+    msg sc = vcat
+      [ text "When trying" <+> ppr t
+      , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)."
+      , space
+      , text "If you need to increase the limit substantially, please file a"
+      , text "bug report and indicate the factor you needed."
+      , space
+      , text "If GHC was unable to complete compilation even"
+               <+> text "with a very large factor"
+      , text "(a thousand or more), please consult the"
+                <+> doubleQuotes (text "Known bugs or infelicities")
+      , text "section in the Users Guide before filing a report. There are a"
+      , text "few situations unlikely to occur in practical programs for which"
+      , text "simplifier non-termination has been judged acceptable."
+      , space
+      , pp_details sc
+      , pprSimplCount sc ]
+    pp_details sc
+      | hasDetailedCounts sc = empty
+      | otherwise = text "To see detailed counts use -ddump-simpl-stats"
+
+
+freeTick :: Tick -> SimplM ()
+-- Record a tick, but don't add to the total tick count, which is
+-- used to decide when nothing further has happened
+freeTick t
+   = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc
+                           in sc' `seq` return ((), us, sc'))
diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/SimplUtils.hs
@@ -0,0 +1,2318 @@
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+\section[SimplUtils]{The simplifier utilities}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module SimplUtils (
+        -- Rebuilding
+        mkLam, mkCase, prepareAlts, tryEtaExpandRhs,
+
+        -- Inlining,
+        preInlineUnconditionally, postInlineUnconditionally,
+        activeUnfolding, activeRule,
+        getUnfoldingInRuleMatch,
+        simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules,
+
+        -- The continuation type
+        SimplCont(..), DupFlag(..), StaticEnv,
+        isSimplified, contIsStop,
+        contIsDupable, contResultType, contHoleType,
+        contIsTrivial, contArgs,
+        countArgs,
+        mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,
+        interestingCallContext,
+
+        -- ArgInfo
+        ArgInfo(..), ArgSpec(..), mkArgInfo,
+        addValArgTo, addCastTo, addTyArgTo,
+        argInfoExpr, argInfoAppArgs, pushSimplifiedArgs,
+
+        abstractFloats,
+
+        -- Utilities
+        isExitJoinId
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import SimplEnv
+import CoreMonad        ( SimplMode(..), Tick(..) )
+import DynFlags
+import CoreSyn
+import qualified CoreSubst
+import PprCore
+import CoreFVs
+import CoreUtils
+import CoreArity
+import CoreUnfold
+import Name
+import Id
+import IdInfo
+import Var
+import Demand
+import SimplMonad
+import Type     hiding( substTy )
+import Coercion hiding( substCo )
+import DataCon          ( dataConWorkId, isNullaryRepDataCon )
+import VarSet
+import BasicTypes
+import Util
+import OrdList          ( isNilOL )
+import MonadUtils
+import Outputable
+import Pair
+import PrelRules
+import FastString       ( fsLit )
+
+import Control.Monad    ( when )
+import Data.List        ( sortBy )
+
+{-
+************************************************************************
+*                                                                      *
+                The SimplCont and DupFlag types
+*                                                                      *
+************************************************************************
+
+A SimplCont allows the simplifier to traverse the expression in a
+zipper-like fashion.  The SimplCont represents the rest of the expression,
+"above" the point of interest.
+
+You can also think of a SimplCont as an "evaluation context", using
+that term in the way it is used for operational semantics. This is the
+way I usually think of it, For example you'll often see a syntax for
+evaluation context looking like
+        C ::= []  |  C e   |  case C of alts  |  C `cast` co
+That's the kind of thing we are doing here, and I use that syntax in
+the comments.
+
+
+Key points:
+  * A SimplCont describes a *strict* context (just like
+    evaluation contexts do).  E.g. Just [] is not a SimplCont
+
+  * A SimplCont describes a context that *does not* bind
+    any variables.  E.g. \x. [] is not a SimplCont
+-}
+
+data SimplCont
+  = Stop                -- Stop[e] = e
+        OutType         -- Type of the <hole>
+        CallCtxt        -- Tells if there is something interesting about
+                        --          the context, and hence the inliner
+                        --          should be a bit keener (see interestingCallContext)
+                        -- Specifically:
+                        --     This is an argument of a function that has RULES
+                        --     Inlining the call might allow the rule to fire
+                        -- Never ValAppCxt (use ApplyToVal instead)
+                        -- or CaseCtxt (use Select instead)
+
+  | CastIt              -- (CastIt co K)[e] = K[ e `cast` co ]
+        OutCoercion             -- The coercion simplified
+                                -- Invariant: never an identity coercion
+        SimplCont
+
+  | ApplyToVal         -- (ApplyToVal arg K)[e] = K[ e arg ]
+      { sc_dup  :: DupFlag      -- See Note [DupFlag invariants]
+      , sc_arg  :: InExpr       -- The argument,
+      , sc_env  :: StaticEnv    -- see Note [StaticEnv invariant]
+      , sc_cont :: SimplCont }
+
+  | ApplyToTy          -- (ApplyToTy ty K)[e] = K[ e ty ]
+      { sc_arg_ty  :: OutType     -- Argument type
+      , sc_hole_ty :: OutType     -- Type of the function, presumably (forall a. blah)
+                                  -- See Note [The hole type in ApplyToTy]
+      , sc_cont    :: SimplCont }
+
+  | Select             -- (Select alts K)[e] = K[ case e of alts ]
+      { sc_dup  :: DupFlag        -- See Note [DupFlag invariants]
+      , sc_bndr :: InId           -- case binder
+      , sc_alts :: [InAlt]        -- Alternatives
+      , sc_env  :: StaticEnv      -- See Note [StaticEnv invariant]
+      , sc_cont :: SimplCont }
+
+  -- The two strict forms have no DupFlag, because we never duplicate them
+  | StrictBind          -- (StrictBind x xs b K)[e] = let x = e in K[\xs.b]
+                        --       or, equivalently,  = K[ (\x xs.b) e ]
+      { sc_dup   :: DupFlag        -- See Note [DupFlag invariants]
+      , sc_bndr  :: InId
+      , sc_bndrs :: [InBndr]
+      , sc_body  :: InExpr
+      , sc_env   :: StaticEnv      -- See Note [StaticEnv invariant]
+      , sc_cont  :: SimplCont }
+
+  | StrictArg           -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ]
+      { sc_dup  :: DupFlag     -- Always Simplified or OkToDup
+      , sc_fun  :: ArgInfo     -- Specifies f, e1..en, Whether f has rules, etc
+                               --     plus strictness flags for *further* args
+      , sc_cci  :: CallCtxt    -- Whether *this* argument position is interesting
+      , sc_cont :: SimplCont }
+
+  | TickIt              -- (TickIt t K)[e] = K[ tick t e ]
+        (Tickish Id)    -- Tick tickish <hole>
+        SimplCont
+
+type StaticEnv = SimplEnv       -- Just the static part is relevant
+
+data DupFlag = NoDup       -- Unsimplified, might be big
+             | Simplified  -- Simplified
+             | OkToDup     -- Simplified and small
+
+isSimplified :: DupFlag -> Bool
+isSimplified NoDup = False
+isSimplified _     = True       -- Invariant: the subst-env is empty
+
+perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type
+perhapsSubstTy dup env ty
+  | isSimplified dup = ty
+  | otherwise        = substTy env ty
+
+{- Note [StaticEnv invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We pair up an InExpr or InAlts with a StaticEnv, which establishes the
+lexical scope for that InExpr.  When we simplify that InExpr/InAlts, we
+use
+  - Its captured StaticEnv
+  - Overriding its InScopeSet with the larger one at the
+    simplification point.
+
+Why override the InScopeSet?  Example:
+      (let y = ey in f) ex
+By the time we simplify ex, 'y' will be in scope.
+
+However the InScopeSet in the StaticEnv is not irrelevant: it should
+include all the free vars of applying the substitution to the InExpr.
+Reason: contHoleType uses perhapsSubstTy to apply the substitution to
+the expression, and that (rightly) gives ASSERT failures if the InScopeSet
+isn't big enough.
+
+Note [DupFlag invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+In both (ApplyToVal dup _ env k)
+   and  (Select dup _ _ env k)
+the following invariants hold
+
+  (a) if dup = OkToDup, then continuation k is also ok-to-dup
+  (b) if dup = OkToDup or Simplified, the subst-env is empty
+      (and and hence no need to re-simplify)
+-}
+
+instance Outputable DupFlag where
+  ppr OkToDup    = text "ok"
+  ppr NoDup      = text "nodup"
+  ppr Simplified = text "simpl"
+
+instance Outputable SimplCont where
+  ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty
+  ppr (CastIt co cont  )    = (text "CastIt" <+> pprOptCo co) $$ ppr cont
+  ppr (TickIt t cont)       = (text "TickIt" <+> ppr t) $$ ppr cont
+  ppr (ApplyToTy  { sc_arg_ty = ty, sc_cont = cont })
+    = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont
+  ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont })
+    = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg)
+                                        $$ ppr cont
+  ppr (StrictBind { sc_bndr = b, sc_cont = cont })
+    = (text "StrictBind" <+> ppr b) $$ ppr cont
+  ppr (StrictArg { sc_fun = ai, sc_cont = cont })
+    = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont
+  ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont })
+    = (text "Select" <+> ppr dup <+> ppr bndr) $$
+       whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont
+
+
+{- Note [The hole type in ApplyToTy]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The sc_hole_ty field of ApplyToTy records the type of the "hole" in the
+continuation.  It is absolutely necessary to compute contHoleType, but it is
+not used for anything else (and hence may not be evaluated).
+
+Why is it necessary for contHoleType?  Consider the continuation
+     ApplyToType Int (Stop Int)
+corresponding to
+     (<hole> @Int) :: Int
+What is the type of <hole>?  It could be (forall a. Int) or (forall a. a),
+and there is no way to know which, so we must record it.
+
+In a chain of applications  (f @t1 @t2 @t3) we'll lazily compute exprType
+for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably
+doesn't matter because we'll never compute them all.
+
+************************************************************************
+*                                                                      *
+                ArgInfo and ArgSpec
+*                                                                      *
+************************************************************************
+-}
+
+data ArgInfo
+  = ArgInfo {
+        ai_fun   :: OutId,      -- The function
+        ai_args  :: [ArgSpec],  -- ...applied to these args (which are in *reverse* order)
+
+        ai_type  :: OutType,    -- Type of (f a1 ... an)
+
+        ai_rules :: FunRules,   -- Rules for this function
+
+        ai_encl :: Bool,        -- Flag saying whether this function
+                                -- or an enclosing one has rules (recursively)
+                                --      True => be keener to inline in all args
+
+        ai_strs :: [Bool],      -- Strictness of remaining arguments
+                                --   Usually infinite, but if it is finite it guarantees
+                                --   that the function diverges after being given
+                                --   that number of args
+        ai_discs :: [Int]       -- Discounts for remaining arguments; non-zero => be keener to inline
+                                --   Always infinite
+    }
+
+data ArgSpec
+  = ValArg OutExpr                    -- Apply to this (coercion or value); c.f. ApplyToVal
+  | TyArg { as_arg_ty  :: OutType     -- Apply to this type; c.f. ApplyToTy
+          , as_hole_ty :: OutType }   -- Type of the function (presumably forall a. blah)
+  | CastBy OutCoercion                -- Cast by this; c.f. CastIt
+
+instance Outputable ArgSpec where
+  ppr (ValArg e)                 = text "ValArg" <+> ppr e
+  ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty
+  ppr (CastBy c)                 = text "CastBy" <+> ppr c
+
+addValArgTo :: ArgInfo -> OutExpr -> ArgInfo
+addValArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai
+                        , ai_type = applyTypeToArg (ai_type ai) arg
+                        , ai_rules = decRules (ai_rules ai) }
+
+addTyArgTo :: ArgInfo -> OutType -> ArgInfo
+addTyArgTo ai arg_ty = ai { ai_args = arg_spec : ai_args ai
+                          , ai_type = piResultTy poly_fun_ty arg_ty
+                          , ai_rules = decRules (ai_rules ai) }
+  where
+    poly_fun_ty = ai_type ai
+    arg_spec    = TyArg { as_arg_ty = arg_ty, as_hole_ty = poly_fun_ty }
+
+addCastTo :: ArgInfo -> OutCoercion -> ArgInfo
+addCastTo ai co = ai { ai_args = CastBy co : ai_args ai
+                     , ai_type = pSnd (coercionKind co) }
+
+argInfoAppArgs :: [ArgSpec] -> [OutExpr]
+argInfoAppArgs []                              = []
+argInfoAppArgs (CastBy {}                : _)  = []  -- Stop at a cast
+argInfoAppArgs (ValArg e                 : as) = e       : argInfoAppArgs as
+argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as
+
+pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont
+pushSimplifiedArgs _env []           k = k
+pushSimplifiedArgs env  (arg : args) k
+  = case arg of
+      TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }
+               -> ApplyToTy  { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest }
+      ValArg e -> ApplyToVal { sc_arg = e, sc_env = env, sc_dup = Simplified, sc_cont = rest }
+      CastBy c -> CastIt c rest
+  where
+    rest = pushSimplifiedArgs env args k
+           -- The env has an empty SubstEnv
+
+argInfoExpr :: OutId -> [ArgSpec] -> OutExpr
+-- NB: the [ArgSpec] is reversed so that the first arg
+-- in the list is the last one in the application
+argInfoExpr fun rev_args
+  = go rev_args
+  where
+    go []                              = Var fun
+    go (ValArg a                 : as) = go as `App` a
+    go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty
+    go (CastBy co                : as) = mkCast (go as) co
+
+
+type FunRules = Maybe (Int, [CoreRule]) -- Remaining rules for this function
+     -- Nothing => No rules
+     -- Just (n, rules) => some rules, requiring at least n more type/value args
+
+decRules :: FunRules -> FunRules
+decRules (Just (n, rules)) = Just (n-1, rules)
+decRules Nothing           = Nothing
+
+mkFunRules :: [CoreRule] -> FunRules
+mkFunRules [] = Nothing
+mkFunRules rs = Just (n_required, rs)
+  where
+    n_required = maximum (map ruleArity rs)
+
+{-
+************************************************************************
+*                                                                      *
+                Functions on SimplCont
+*                                                                      *
+************************************************************************
+-}
+
+mkBoringStop :: OutType -> SimplCont
+mkBoringStop ty = Stop ty BoringCtxt
+
+mkRhsStop :: OutType -> SimplCont       -- See Note [RHS of lets] in CoreUnfold
+mkRhsStop ty = Stop ty RhsCtxt
+
+mkLazyArgStop :: OutType -> CallCtxt -> SimplCont
+mkLazyArgStop ty cci = Stop ty cci
+
+-------------------
+contIsRhsOrArg :: SimplCont -> Bool
+contIsRhsOrArg (Stop {})       = True
+contIsRhsOrArg (StrictBind {}) = True
+contIsRhsOrArg (StrictArg {})  = True
+contIsRhsOrArg _               = False
+
+contIsRhs :: SimplCont -> Bool
+contIsRhs (Stop _ RhsCtxt) = True
+contIsRhs _                = False
+
+-------------------
+contIsStop :: SimplCont -> Bool
+contIsStop (Stop {}) = True
+contIsStop _         = False
+
+contIsDupable :: SimplCont -> Bool
+contIsDupable (Stop {})                         = True
+contIsDupable (ApplyToTy  { sc_cont = k })      = contIsDupable k
+contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants]
+contIsDupable (Select { sc_dup = OkToDup })     = True -- ...ditto...
+contIsDupable (StrictArg { sc_dup = OkToDup })  = True -- ...ditto...
+contIsDupable (CastIt _ k)                      = contIsDupable k
+contIsDupable _                                 = False
+
+-------------------
+contIsTrivial :: SimplCont -> Bool
+contIsTrivial (Stop {})                                         = True
+contIsTrivial (ApplyToTy { sc_cont = k })                       = contIsTrivial k
+contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k
+contIsTrivial (CastIt _ k)                                      = contIsTrivial k
+contIsTrivial _                                                 = False
+
+-------------------
+contResultType :: SimplCont -> OutType
+contResultType (Stop ty _)                  = ty
+contResultType (CastIt _ k)                 = contResultType k
+contResultType (StrictBind { sc_cont = k }) = contResultType k
+contResultType (StrictArg { sc_cont = k })  = contResultType k
+contResultType (Select { sc_cont = k })     = contResultType k
+contResultType (ApplyToTy  { sc_cont = k }) = contResultType k
+contResultType (ApplyToVal { sc_cont = k }) = contResultType k
+contResultType (TickIt _ k)                 = contResultType k
+
+contHoleType :: SimplCont -> OutType
+contHoleType (Stop ty _)                      = ty
+contHoleType (TickIt _ k)                     = contHoleType k
+contHoleType (CastIt co _)                    = pFst (coercionKind co)
+contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })
+  = perhapsSubstTy dup se (idType b)
+contHoleType (StrictArg { sc_fun = ai })      = funArgTy (ai_type ai)
+contHoleType (ApplyToTy  { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]
+contHoleType (ApplyToVal { sc_arg = e, sc_env = se, sc_dup = dup, sc_cont = k })
+  = mkFunTy (perhapsSubstTy dup se (exprType e))
+            (contHoleType k)
+contHoleType (Select { sc_dup = d, sc_bndr =  b, sc_env = se })
+  = perhapsSubstTy d se (idType b)
+
+-------------------
+countArgs :: SimplCont -> Int
+-- Count all arguments, including types, coercions, and other values
+countArgs (ApplyToTy  { sc_cont = cont }) = 1 + countArgs cont
+countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont
+countArgs _                               = 0
+
+contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)
+-- Summarises value args, discards type args and coercions
+-- The returned continuation of the call is only used to
+-- answer questions like "are you interesting?"
+contArgs cont
+  | lone cont = (True, [], cont)
+  | otherwise = go [] cont
+  where
+    lone (ApplyToTy  {}) = False  -- See Note [Lone variables] in CoreUnfold
+    lone (ApplyToVal {}) = False
+    lone (CastIt {})     = False
+    lone _               = True
+
+    go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k })
+                                        = go (is_interesting arg se : args) k
+    go args (ApplyToTy { sc_cont = k }) = go args k
+    go args (CastIt _ k)                = go args k
+    go args k                           = (False, reverse args, k)
+
+    is_interesting arg se = interestingArg se arg
+                   -- Do *not* use short-cutting substitution here
+                   -- because we want to get as much IdInfo as possible
+
+
+-------------------
+mkArgInfo :: SimplEnv
+          -> Id
+          -> [CoreRule] -- Rules for function
+          -> Int        -- Number of value args
+          -> SimplCont  -- Context of the call
+          -> ArgInfo
+
+mkArgInfo env fun rules n_val_args call_cont
+  | n_val_args < idArity fun            -- Note [Unsaturated functions]
+  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
+            , ai_rules = fun_rules
+            , ai_encl = False
+            , ai_strs = vanilla_stricts
+            , ai_discs = vanilla_discounts }
+  | otherwise
+  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty
+            , ai_rules = fun_rules
+            , ai_encl  = interestingArgContext rules call_cont
+            , ai_strs  = arg_stricts
+            , ai_discs = arg_discounts }
+  where
+    fun_ty = idType fun
+
+    fun_rules = mkFunRules rules
+
+    vanilla_discounts, arg_discounts :: [Int]
+    vanilla_discounts = repeat 0
+    arg_discounts = case idUnfolding fun of
+                        CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}}
+                              -> discounts ++ vanilla_discounts
+                        _     -> vanilla_discounts
+
+    vanilla_stricts, arg_stricts :: [Bool]
+    vanilla_stricts  = repeat False
+
+    arg_stricts
+      | not (sm_inline (seMode env))
+      = vanilla_stricts -- See Note [Do not expose strictness if sm_inline=False]
+      | otherwise
+      = add_type_str fun_ty $
+        case splitStrictSig (idStrictness fun) of
+          (demands, result_info)
+                | not (demands `lengthExceeds` n_val_args)
+                ->      -- Enough args, use the strictness given.
+                        -- For bottoming functions we used to pretend that the arg
+                        -- is lazy, so that we don't treat the arg as an
+                        -- interesting context.  This avoids substituting
+                        -- top-level bindings for (say) strings into
+                        -- calls to error.  But now we are more careful about
+                        -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
+                   if isBotRes result_info then
+                        map isStrictDmd demands         -- Finite => result is bottom
+                   else
+                        map isStrictDmd demands ++ vanilla_stricts
+               | otherwise
+               -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)
+                                <+> ppr n_val_args <+> ppr demands )
+                   vanilla_stricts      -- Not enough args, or no strictness
+
+    add_type_str :: Type -> [Bool] -> [Bool]
+    -- If the function arg types are strict, record that in the 'strictness bits'
+    -- No need to instantiate because unboxed types (which dominate the strict
+    --   types) can't instantiate type variables.
+    -- add_type_str is done repeatedly (for each call);
+    --   might be better once-for-all in the function
+    -- But beware primops/datacons with no strictness
+
+    add_type_str _ [] = []
+    add_type_str fun_ty all_strs@(str:strs)
+      | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info
+      = (str || Just False == isLiftedType_maybe arg_ty)
+        : add_type_str fun_ty' strs
+          -- If the type is levity-polymorphic, we can't know whether it's
+          -- strict. isLiftedType_maybe will return Just False only when
+          -- we're sure the type is unlifted.
+
+      | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty
+      = add_type_str fun_ty' all_strs     -- Look through foralls
+
+      | otherwise
+      = all_strs
+
+{- Note [Unsaturated functions]
+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (test eyeball/inline4)
+        x = a:as
+        y = f x
+where f has arity 2.  Then we do not want to inline 'x', because
+it'll just be floated out again.  Even if f has lots of discounts
+on its first argument -- it must be saturated for these to kick in
+
+Note [Do not expose strictness if sm_inline=False]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Trac #15163 showed a case in which we had
+
+  {-# INLINE [1] zip #-}
+  zip = undefined
+
+  {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-}
+
+If we expose zip's bottoming nature when simplifing the LHS of the
+RULE we get
+  {-# RULES "foo" forall as bs.
+                   stream (case zip of {}) = ..blah... #-}
+discarding the arguments to zip.  Usually this is fine, but on the
+LHS of a rule it's not, because 'as' and 'bs' are now not bound on
+the LHS.
+
+This is a pretty pathalogical example, so I'm not losing sleep over
+it, but the simplest solution was to check sm_inline; if it is False,
+which it is on the LHS of a rule (see updModeForRules), then don't
+make use of the strictness info for the function.
+-}
+
+
+{-
+************************************************************************
+*                                                                      *
+        Interesting arguments
+*                                                                      *
+************************************************************************
+
+Note [Interesting call context]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to avoid inlining an expression where there can't possibly be
+any gain, such as in an argument position.  Hence, if the continuation
+is interesting (eg. a case scrutinee, application etc.) then we
+inline, otherwise we don't.
+
+Previously some_benefit used to return True only if the variable was
+applied to some value arguments.  This didn't work:
+
+        let x = _coerce_ (T Int) Int (I# 3) in
+        case _coerce_ Int (T Int) x of
+                I# y -> ....
+
+we want to inline x, but can't see that it's a constructor in a case
+scrutinee position, and some_benefit is False.
+
+Another example:
+
+dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
+
+....  case dMonadST _@_ x0 of (a,b,c) -> ....
+
+we'd really like to inline dMonadST here, but we *don't* want to
+inline if the case expression is just
+
+        case x of y { DEFAULT -> ... }
+
+since we can just eliminate this case instead (x is in WHNF).  Similar
+applies when x is bound to a lambda expression.  Hence
+contIsInteresting looks for case expressions with just a single
+default case.
+
+Note [No case of case is boring]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see
+   case f x of <alts>
+
+we'd usually treat the context as interesting, to encourage 'f' to
+inline.  But if case-of-case is off, it's really not so interesting
+after all, because we are unlikely to be able to push the case
+expression into the branches of any case in f's unfolding.  So, to
+reduce unnecessary code expansion, we just make the context look boring.
+This made a small compile-time perf improvement in perf/compiler/T6048,
+and it looks plausible to me.
+-}
+
+interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt
+-- See Note [Interesting call context]
+interestingCallContext env cont
+  = interesting cont
+  where
+    interesting (Select {})
+       | sm_case_case (getMode env) = CaseCtxt
+       | otherwise                  = BoringCtxt
+       -- See Note [No case of case is boring]
+
+    interesting (ApplyToVal {}) = ValAppCtxt
+        -- Can happen if we have (f Int |> co) y
+        -- If f has an INLINE prag we need to give it some
+        -- motivation to inline. See Note [Cast then apply]
+        -- in CoreUnfold
+
+    interesting (StrictArg { sc_cci = cci }) = cci
+    interesting (StrictBind {})              = BoringCtxt
+    interesting (Stop _ cci)                 = cci
+    interesting (TickIt _ k)                 = interesting k
+    interesting (ApplyToTy { sc_cont = k })  = interesting k
+    interesting (CastIt _ k)                 = interesting k
+        -- If this call is the arg of a strict function, the context
+        -- is a bit interesting.  If we inline here, we may get useful
+        -- evaluation information to avoid repeated evals: e.g.
+        --      x + (y * z)
+        -- Here the contIsInteresting makes the '*' keener to inline,
+        -- which in turn exposes a constructor which makes the '+' inline.
+        -- Assuming that +,* aren't small enough to inline regardless.
+        --
+        -- It's also very important to inline in a strict context for things
+        -- like
+        --              foldr k z (f x)
+        -- Here, the context of (f x) is strict, and if f's unfolding is
+        -- a build it's *great* to inline it here.  So we must ensure that
+        -- the context for (f x) is not totally uninteresting.
+
+interestingArgContext :: [CoreRule] -> SimplCont -> Bool
+-- If the argument has form (f x y), where x,y are boring,
+-- and f is marked INLINE, then we don't want to inline f.
+-- But if the context of the argument is
+--      g (f x y)
+-- where g has rules, then we *do* want to inline f, in case it
+-- exposes a rule that might fire.  Similarly, if the context is
+--      h (g (f x x))
+-- where h has rules, then we do want to inline f; hence the
+-- call_cont argument to interestingArgContext
+--
+-- The ai-rules flag makes this happen; if it's
+-- set, the inliner gets just enough keener to inline f
+-- regardless of how boring f's arguments are, if it's marked INLINE
+--
+-- The alternative would be to *always* inline an INLINE function,
+-- regardless of how boring its context is; but that seems overkill
+-- For example, it'd mean that wrapper functions were always inlined
+--
+-- The call_cont passed to interestingArgContext is the context of
+-- the call itself, e.g. g <hole> in the example above
+interestingArgContext rules call_cont
+  = notNull rules || enclosing_fn_has_rules
+  where
+    enclosing_fn_has_rules = go call_cont
+
+    go (Select {})                  = False
+    go (ApplyToVal {})              = False  -- Shouldn't really happen
+    go (ApplyToTy  {})              = False  -- Ditto
+    go (StrictArg { sc_cci = cci }) = interesting cci
+    go (StrictBind {})              = False      -- ??
+    go (CastIt _ c)                 = go c
+    go (Stop _ cci)                 = interesting cci
+    go (TickIt _ c)                 = go c
+
+    interesting RuleArgCtxt = True
+    interesting _           = False
+
+
+{- Note [Interesting arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An argument is interesting if it deserves a discount for unfoldings
+with a discount in that argument position.  The idea is to avoid
+unfolding a function that is applied only to variables that have no
+unfolding (i.e. they are probably lambda bound): f x y z There is
+little point in inlining f here.
+
+Generally, *values* (like (C a b) and (\x.e)) deserve discounts.  But
+we must look through lets, eg (let x = e in C a b), because the let will
+float, exposing the value, if we inline.  That makes it different to
+exprIsHNF.
+
+Before 2009 we said it was interesting if the argument had *any* structure
+at all; i.e. (hasSomeUnfolding v).  But does too much inlining; see Trac #3016.
+
+But we don't regard (f x y) as interesting, unless f is unsaturated.
+If it's saturated and f hasn't inlined, then it's probably not going
+to now!
+
+Note [Conlike is interesting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+        f d = ...((*) d x y)...
+        ... f (df d')...
+where df is con-like. Then we'd really like to inline 'f' so that the
+rule for (*) (df d) can fire.  To do this
+  a) we give a discount for being an argument of a class-op (eg (*) d)
+  b) we say that a con-like argument (eg (df d)) is interesting
+-}
+
+interestingArg :: SimplEnv -> CoreExpr -> ArgSummary
+-- See Note [Interesting arguments]
+interestingArg env e = go env 0 e
+  where
+    -- n is # value args to which the expression is applied
+    go env n (Var v)
+       = case substId env v of
+           DoneId v'            -> go_var n v'
+           DoneEx e _           -> go (zapSubstEnv env)             n e
+           ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e
+
+    go _   _ (Lit {})          = ValueArg
+    go _   _ (Type _)          = TrivArg
+    go _   _ (Coercion _)      = TrivArg
+    go env n (App fn (Type _)) = go env n fn
+    go env n (App fn _)        = go env (n+1) fn
+    go env n (Tick _ a)        = go env n a
+    go env n (Cast e _)        = go env n e
+    go env n (Lam v e)
+       | isTyVar v             = go env n e
+       | n>0                   = NonTrivArg     -- (\x.b) e   is NonTriv
+       | otherwise             = ValueArg
+    go _ _ (Case {})           = NonTrivArg
+    go env n (Let b e)         = case go env' n e of
+                                   ValueArg -> ValueArg
+                                   _        -> NonTrivArg
+                               where
+                                 env' = env `addNewInScopeIds` bindersOf b
+
+    go_var n v
+       | isConLikeId v     = ValueArg   -- Experimenting with 'conlike' rather that
+                                        --    data constructors here
+       | idArity v > n     = ValueArg   -- Catches (eg) primops with arity but no unfolding
+       | n > 0             = NonTrivArg -- Saturated or unknown call
+       | conlike_unfolding = ValueArg   -- n==0; look for an interesting unfolding
+                                        -- See Note [Conlike is interesting]
+       | otherwise         = TrivArg    -- n==0, no useful unfolding
+       where
+         conlike_unfolding = isConLikeUnfolding (idUnfolding v)
+
+{-
+************************************************************************
+*                                                                      *
+                  SimplMode
+*                                                                      *
+************************************************************************
+
+The SimplMode controls several switches; see its definition in
+CoreMonad
+        sm_rules      :: Bool     -- Whether RULES are enabled
+        sm_inline     :: Bool     -- Whether inlining is enabled
+        sm_case_case  :: Bool     -- Whether case-of-case is enabled
+        sm_eta_expand :: Bool     -- Whether eta-expansion is enabled
+-}
+
+simplEnvForGHCi :: DynFlags -> SimplEnv
+simplEnvForGHCi dflags
+  = mkSimplEnv $ SimplMode { sm_names  = ["GHCi"]
+                           , sm_phase  = InitialPhase
+                           , sm_dflags = dflags
+                           , sm_rules  = rules_on
+                           , sm_inline = False
+                           , sm_eta_expand = eta_expand_on
+                           , sm_case_case  = True }
+  where
+    rules_on      = gopt Opt_EnableRewriteRules   dflags
+    eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags
+   -- Do not do any inlining, in case we expose some unboxed
+   -- tuple stuff that confuses the bytecode interpreter
+
+updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode
+-- See Note [Simplifying inside stable unfoldings]
+updModeForStableUnfoldings inline_rule_act current_mode
+  = current_mode { sm_phase      = phaseFromActivation inline_rule_act
+                 , sm_inline     = True
+                 , sm_eta_expand = False }
+                     -- sm_eta_expand: see Note [No eta expansion in stable unfoldings]
+       -- For sm_rules, just inherit; sm_rules might be "off"
+       -- because of -fno-enable-rewrite-rules
+  where
+    phaseFromActivation (ActiveAfter _ n) = Phase n
+    phaseFromActivation _                 = InitialPhase
+
+updModeForRules :: SimplMode -> SimplMode
+-- See Note [Simplifying rules]
+updModeForRules current_mode
+  = current_mode { sm_phase      = InitialPhase
+                 , sm_inline     = False  -- See Note [Do not expose strictness if sm_inline=False]
+                 , sm_rules      = False
+                 , sm_eta_expand = False }
+
+{- Note [Simplifying rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When simplifying a rule LHS, refrain from /any/ inlining or applying
+of other RULES.
+
+Doing anything to the LHS is plain confusing, because it means that what the
+rule matches is not what the user wrote. c.f. Trac #10595, and #10528.
+Moreover, inlining (or applying rules) on rule LHSs risks introducing
+Ticks into the LHS, which makes matching trickier. Trac #10665, #10745.
+
+Doing this to either side confounds tools like HERMIT, which seek to reason
+about and apply the RULES as originally written. See Trac #10829.
+
+Note [No eta expansion in stable unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have a stable unfolding
+
+  f :: Ord a => a -> IO ()
+  -- Unfolding template
+  --    = /\a \(d:Ord a) (x:a). bla
+
+we do not want to eta-expand to
+
+  f :: Ord a => a -> IO ()
+  -- Unfolding template
+  --    = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co
+
+because not specialisation of the overloading doesn't work properly
+(see Note [Specialisation shape] in Specialise), Trac #9509.
+
+So we disable eta-expansion in stable unfoldings.
+
+Note [Inlining in gentle mode]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Something is inlined if
+   (i)   the sm_inline flag is on, AND
+   (ii)  the thing has an INLINE pragma, AND
+   (iii) the thing is inlinable in the earliest phase.
+
+Example of why (iii) is important:
+  {-# INLINE [~1] g #-}
+  g = ...
+
+  {-# INLINE f #-}
+  f x = g (g x)
+
+If we were to inline g into f's inlining, then an importing module would
+never be able to do
+        f e --> g (g e) ---> RULE fires
+because the stable unfolding for f has had g inlined into it.
+
+On the other hand, it is bad not to do ANY inlining into an
+stable unfolding, because then recursive knots in instance declarations
+don't get unravelled.
+
+However, *sometimes* SimplGently must do no call-site inlining at all
+(hence sm_inline = False).  Before full laziness we must be careful
+not to inline wrappers, because doing so inhibits floating
+    e.g. ...(case f x of ...)...
+    ==> ...(case (case x of I# x# -> fw x#) of ...)...
+    ==> ...(case x of I# x# -> case fw x# of ...)...
+and now the redex (f x) isn't floatable any more.
+
+The no-inlining thing is also important for Template Haskell.  You might be
+compiling in one-shot mode with -O2; but when TH compiles a splice before
+running it, we don't want to use -O2.  Indeed, we don't want to inline
+anything, because the byte-code interpreter might get confused about
+unboxed tuples and suchlike.
+
+Note [Simplifying inside stable unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must take care with simplification inside stable unfoldings (which come from
+INLINE pragmas).
+
+First, consider the following example
+        let f = \pq -> BIG
+        in
+        let g = \y -> f y y
+            {-# INLINE g #-}
+        in ...g...g...g...g...g...
+Now, if that's the ONLY occurrence of f, it might be inlined inside g,
+and thence copied multiple times when g is inlined. HENCE we treat
+any occurrence in a stable unfolding as a multiple occurrence, not a single
+one; see OccurAnal.addRuleUsage.
+
+Second, we do want *do* to some modest rules/inlining stuff in stable
+unfoldings, partly to eliminate senseless crap, and partly to break
+the recursive knots generated by instance declarations.
+
+However, suppose we have
+        {-# INLINE <act> f #-}
+        f = <rhs>
+meaning "inline f in phases p where activation <act>(p) holds".
+Then what inlinings/rules can we apply to the copy of <rhs> captured in
+f's stable unfolding?  Our model is that literally <rhs> is substituted for
+f when it is inlined.  So our conservative plan (implemented by
+updModeForStableUnfoldings) is this:
+
+  -------------------------------------------------------------
+  When simplifying the RHS of a stable unfolding, set the phase
+  to the phase in which the stable unfolding first becomes active
+  -------------------------------------------------------------
+
+That ensures that
+
+  a) Rules/inlinings that *cease* being active before p will
+     not apply to the stable unfolding, consistent with it being
+     inlined in its *original* form in phase p.
+
+  b) Rules/inlinings that only become active *after* p will
+     not apply to the stable unfolding, again to be consistent with
+     inlining the *original* rhs in phase p.
+
+For example,
+        {-# INLINE f #-}
+        f x = ...g...
+
+        {-# NOINLINE [1] g #-}
+        g y = ...
+
+        {-# RULE h g = ... #-}
+Here we must not inline g into f's RHS, even when we get to phase 0,
+because when f is later inlined into some other module we want the
+rule for h to fire.
+
+Similarly, consider
+        {-# INLINE f #-}
+        f x = ...g...
+
+        g y = ...
+and suppose that there are auto-generated specialisations and a strictness
+wrapper for g.  The specialisations get activation AlwaysActive, and the
+strictness wrapper get activation (ActiveAfter 0).  So the strictness
+wrepper fails the test and won't be inlined into f's stable unfolding. That
+means f can inline, expose the specialised call to g, so the specialisation
+rules can fire.
+
+A note about wrappers
+~~~~~~~~~~~~~~~~~~~~~
+It's also important not to inline a worker back into a wrapper.
+A wrapper looks like
+        wraper = inline_me (\x -> ...worker... )
+Normally, the inline_me prevents the worker getting inlined into
+the wrapper (initially, the worker's only call site!).  But,
+if the wrapper is sure to be called, the strictness analyser will
+mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf
+continuation.
+-}
+
+activeUnfolding :: SimplMode -> Id -> Bool
+activeUnfolding mode id
+  | isCompulsoryUnfolding (realIdUnfolding id)
+  = True   -- Even sm_inline can't override compulsory unfoldings
+  | otherwise
+  = isActive (sm_phase mode) (idInlineActivation id)
+  && sm_inline mode
+      -- `or` isStableUnfolding (realIdUnfolding id)
+      -- Inline things when
+      --  (a) they are active
+      --  (b) sm_inline says so, except that for stable unfoldings
+      --                         (ie pragmas) we inline anyway
+
+getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv
+-- When matching in RULE, we want to "look through" an unfolding
+-- (to see a constructor) if *rules* are on, even if *inlinings*
+-- are not.  A notable example is DFuns, which really we want to
+-- match in rules like (op dfun) in gentle mode. Another example
+-- is 'otherwise' which we want exprIsConApp_maybe to be able to
+-- see very early on
+getUnfoldingInRuleMatch env
+  = (in_scope, id_unf)
+  where
+    in_scope = seInScope env
+    mode = getMode env
+    id_unf id | unf_is_active id = idUnfolding id
+              | otherwise        = NoUnfolding
+    unf_is_active id
+     | not (sm_rules mode) = -- active_unfolding_minimal id
+                             isStableUnfolding (realIdUnfolding id)
+        -- Do we even need to test this?  I think this InScopeEnv
+        -- is only consulted if activeRule returns True, which
+        -- never happens if sm_rules is False
+     | otherwise           = isActive (sm_phase mode) (idInlineActivation id)
+
+----------------------
+activeRule :: SimplMode -> Activation -> Bool
+-- Nothing => No rules at all
+activeRule mode
+  | not (sm_rules mode) = \_ -> False     -- Rewriting is off
+  | otherwise           = isActive (sm_phase mode)
+
+{-
+************************************************************************
+*                                                                      *
+                  preInlineUnconditionally
+*                                                                      *
+************************************************************************
+
+preInlineUnconditionally
+~~~~~~~~~~~~~~~~~~~~~~~~
+@preInlineUnconditionally@ examines a bndr to see if it is used just
+once in a completely safe way, so that it is safe to discard the
+binding inline its RHS at the (unique) usage site, REGARDLESS of how
+big the RHS might be.  If this is the case we don't simplify the RHS
+first, but just inline it un-simplified.
+
+This is much better than first simplifying a perhaps-huge RHS and then
+inlining and re-simplifying it.  Indeed, it can be at least quadratically
+better.  Consider
+
+        x1 = e1
+        x2 = e2[x1]
+        x3 = e3[x2]
+        ...etc...
+        xN = eN[xN-1]
+
+We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.
+This can happen with cascades of functions too:
+
+        f1 = \x1.e1
+        f2 = \xs.e2[f1]
+        f3 = \xs.e3[f3]
+        ...etc...
+
+THE MAIN INVARIANT is this:
+
+        ----  preInlineUnconditionally invariant -----
+   IF preInlineUnconditionally chooses to inline x = <rhs>
+   THEN doing the inlining should not change the occurrence
+        info for the free vars of <rhs>
+        ----------------------------------------------
+
+For example, it's tempting to look at trivial binding like
+        x = y
+and inline it unconditionally.  But suppose x is used many times,
+but this is the unique occurrence of y.  Then inlining x would change
+y's occurrence info, which breaks the invariant.  It matters: y
+might have a BIG rhs, which will now be dup'd at every occurrenc of x.
+
+
+Even RHSs labelled InlineMe aren't caught here, because there might be
+no benefit from inlining at the call site.
+
+[Sept 01] Don't unconditionally inline a top-level thing, because that
+can simply make a static thing into something built dynamically.  E.g.
+        x = (a,b)
+        main = \s -> h x
+
+[Remember that we treat \s as a one-shot lambda.]  No point in
+inlining x unless there is something interesting about the call site.
+
+But watch out: if you aren't careful, some useful foldr/build fusion
+can be lost (most notably in spectral/hartel/parstof) because the
+foldr didn't see the build.  Doing the dynamic allocation isn't a big
+deal, in fact, but losing the fusion can be.  But the right thing here
+seems to be to do a callSiteInline based on the fact that there is
+something interesting about the call site (it's strict).  Hmm.  That
+seems a bit fragile.
+
+Conclusion: inline top level things gaily until Phase 0 (the last
+phase), at which point don't.
+
+Note [pre/postInlineUnconditionally in gentle mode]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Even in gentle mode we want to do preInlineUnconditionally.  The
+reason is that too little clean-up happens if you don't inline
+use-once things.  Also a bit of inlining is *good* for full laziness;
+it can expose constant sub-expressions.  Example in
+spectral/mandel/Mandel.hs, where the mandelset function gets a useful
+let-float if you inline windowToViewport
+
+However, as usual for Gentle mode, do not inline things that are
+inactive in the initial stages.  See Note [Gentle mode].
+
+Note [Stable unfoldings and preInlineUnconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas!
+Example
+
+   {-# INLINE f #-}
+   f :: Eq a => a -> a
+   f x = ...
+
+   fInt :: Int -> Int
+   fInt = f Int dEqInt
+
+   ...fInt...fInt...fInt...
+
+Here f occurs just once, in the RHS of fInt. But if we inline it there
+it might make fInt look big, and we'll lose the opportunity to inline f
+at each of fInt's call sites.  The INLINE pragma will only inline when
+the application is saturated for exactly this reason; and we don't
+want PreInlineUnconditionally to second-guess it.  A live example is
+Trac #3736.
+    c.f. Note [Stable unfoldings and postInlineUnconditionally]
+
+NB: if the pragma is INLINEABLE, then we don't want to behave in
+this special way -- an INLINEABLE pragma just says to GHC "inline this
+if you like".  But if there is a unique occurrence, we want to inline
+the stable unfolding, not the RHS.
+
+Note [Top-level bottoming Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Don't inline top-level Ids that are bottoming, even if they are used just
+once, because FloatOut has gone to some trouble to extract them out.
+Inlining them won't make the program run faster!
+
+Note [Do not inline CoVars unconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Coercion variables appear inside coercions, and the RHS of a let-binding
+is a term (not a coercion) so we can't necessarily inline the latter in
+the former.
+-}
+
+preInlineUnconditionally
+    :: SimplEnv -> TopLevelFlag -> InId
+    -> InExpr -> StaticEnv  -- These two go together
+    -> Maybe SimplEnv       -- Returned env has extended substitution
+-- Precondition: rhs satisfies the let/app invariant
+-- See Note [CoreSyn let/app invariant] in CoreSyn
+-- Reason: we don't want to inline single uses, or discard dead bindings,
+--         for unlifted, side-effect-ful bindings
+preInlineUnconditionally env top_lvl bndr rhs rhs_env
+  | not pre_inline_unconditionally           = Nothing
+  | not active                               = Nothing
+  | isTopLevel top_lvl && isBottomingId bndr = Nothing -- Note [Top-level bottoming Ids]
+  | isCoVar bndr                             = Nothing -- Note [Do not inline CoVars unconditionally]
+  | isExitJoinId bndr                        = Nothing -- Note [Do not inline exit join points]
+                                                       -- in module Exitify
+  | not (one_occ (idOccInfo bndr))           = Nothing
+  | not (isStableUnfolding unf)              = Just (extend_subst_with rhs)
+
+  -- Note [Stable unfoldings and preInlineUnconditionally]
+  | isInlinablePragma inline_prag
+  , Just inl <- maybeUnfoldingTemplate unf   = Just (extend_subst_with inl)
+  | otherwise                                = Nothing
+  where
+    unf = idUnfolding bndr
+    extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs)
+
+    one_occ IAmDead = True -- Happens in ((\x.1) v)
+    one_occ (OneOcc { occ_one_br = True      -- One textual occurrence
+                    , occ_in_lam = in_lam
+                    , occ_int_cxt = int_cxt })
+        | not in_lam = isNotTopLevel top_lvl || early_phase
+        | otherwise  = int_cxt && canInlineInLam rhs
+    one_occ _        = False
+
+    pre_inline_unconditionally = gopt Opt_SimplPreInlining (seDynFlags env)
+    mode   = getMode env
+    active = isActive (sm_phase mode) (inlinePragmaActivation inline_prag)
+             -- See Note [pre/postInlineUnconditionally in gentle mode]
+    inline_prag = idInlinePragma bndr
+
+-- Be very careful before inlining inside a lambda, because (a) we must not
+-- invalidate occurrence information, and (b) we want to avoid pushing a
+-- single allocation (here) into multiple allocations (inside lambda).
+-- Inlining a *function* with a single *saturated* call would be ok, mind you.
+--      || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)
+--      where
+--              is_cheap = exprIsCheap rhs
+--              ok = is_cheap && int_cxt
+
+        --      int_cxt         The context isn't totally boring
+        -- E.g. let f = \ab.BIG in \y. map f xs
+        --      Don't want to substitute for f, because then we allocate
+        --      its closure every time the \y is called
+        -- But: let f = \ab.BIG in \y. map (f y) xs
+        --      Now we do want to substitute for f, even though it's not
+        --      saturated, because we're going to allocate a closure for
+        --      (f y) every time round the loop anyhow.
+
+        -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,
+        -- so substituting rhs inside a lambda doesn't change the occ info.
+        -- Sadly, not quite the same as exprIsHNF.
+    canInlineInLam (Lit _)    = True
+    canInlineInLam (Lam b e)  = isRuntimeVar b || canInlineInLam e
+    canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e
+    canInlineInLam _          = False
+      -- not ticks.  Counting ticks cannot be duplicated, and non-counting
+      -- ticks around a Lam will disappear anyway.
+
+    early_phase = case sm_phase mode of
+                    Phase 0 -> False
+                    _       -> True
+-- If we don't have this early_phase test, consider
+--      x = length [1,2,3]
+-- The full laziness pass carefully floats all the cons cells to
+-- top level, and preInlineUnconditionally floats them all back in.
+-- Result is (a) static allocation replaced by dynamic allocation
+--           (b) many simplifier iterations because this tickles
+--               a related problem; only one inlining per pass
+--
+-- On the other hand, I have seen cases where top-level fusion is
+-- lost if we don't inline top level thing (e.g. string constants)
+-- Hence the test for phase zero (which is the phase for all the final
+-- simplifications).  Until phase zero we take no special notice of
+-- top level things, but then we become more leery about inlining
+-- them.
+
+{-
+************************************************************************
+*                                                                      *
+                  postInlineUnconditionally
+*                                                                      *
+************************************************************************
+
+postInlineUnconditionally
+~~~~~~~~~~~~~~~~~~~~~~~~~
+@postInlineUnconditionally@ decides whether to unconditionally inline
+a thing based on the form of its RHS; in particular if it has a
+trivial RHS.  If so, we can inline and discard the binding altogether.
+
+NB: a loop breaker has must_keep_binding = True and non-loop-breakers
+only have *forward* references. Hence, it's safe to discard the binding
+
+NOTE: This isn't our last opportunity to inline.  We're at the binding
+site right now, and we'll get another opportunity when we get to the
+occurrence(s)
+
+Note that we do this unconditional inlining only for trival RHSs.
+Don't inline even WHNFs inside lambdas; doing so may simply increase
+allocation when the function is called. This isn't the last chance; see
+NOTE above.
+
+NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?
+Because we don't even want to inline them into the RHS of constructor
+arguments. See NOTE above
+
+NB: At one time even NOINLINE was ignored here: if the rhs is trivial
+it's best to inline it anyway.  We often get a=E; b=a from desugaring,
+with both a and b marked NOINLINE.  But that seems incompatible with
+our new view that inlining is like a RULE, so I'm sticking to the 'active'
+story for now.
+-}
+
+postInlineUnconditionally
+    :: SimplEnv -> TopLevelFlag
+    -> OutId            -- The binder (*not* a CoVar), including its unfolding
+    -> OccInfo          -- From the InId
+    -> OutExpr
+    -> Bool
+-- Precondition: rhs satisfies the let/app invariant
+-- See Note [CoreSyn let/app invariant] in CoreSyn
+-- Reason: we don't want to inline single uses, or discard dead bindings,
+--         for unlifted, side-effect-ful bindings
+postInlineUnconditionally env top_lvl bndr occ_info rhs
+  | not active                  = False
+  | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline
+                                        -- because it might be referred to "earlier"
+  | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally]
+  | isTopLevel top_lvl          = False -- Note [Top level and postInlineUnconditionally]
+  | exprIsTrivial rhs           = True
+  | otherwise
+  = case occ_info of
+        -- The point of examining occ_info here is that for *non-values*
+        -- that occur outside a lambda, the call-site inliner won't have
+        -- a chance (because it doesn't know that the thing
+        -- only occurs once).   The pre-inliner won't have gotten
+        -- it either, if the thing occurs in more than one branch
+        -- So the main target is things like
+        --      let x = f y in
+        --      case v of
+        --         True  -> case x of ...
+        --         False -> case x of ...
+        -- This is very important in practice; e.g. wheel-seive1 doubles
+        -- in allocation if you miss this out
+      OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt }
+               -- OneOcc => no code-duplication issue
+        ->     smallEnoughToInline dflags unfolding     -- Small enough to dup
+                        -- ToDo: consider discount on smallEnoughToInline if int_cxt is true
+                        --
+                        -- NB: Do NOT inline arbitrarily big things, even if one_br is True
+                        -- Reason: doing so risks exponential behaviour.  We simplify a big
+                        --         expression, inline it, and simplify it again.  But if the
+                        --         very same thing happens in the big expression, we get
+                        --         exponential cost!
+                        -- PRINCIPLE: when we've already simplified an expression once,
+                        -- make sure that we only inline it if it's reasonably small.
+
+           && (not in_lam ||
+                        -- Outside a lambda, we want to be reasonably aggressive
+                        -- about inlining into multiple branches of case
+                        -- e.g. let x = <non-value>
+                        --      in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }
+                        -- Inlining can be a big win if C3 is the hot-spot, even if
+                        -- the uses in C1, C2 are not 'interesting'
+                        -- An example that gets worse if you add int_cxt here is 'clausify'
+
+                (isCheapUnfolding unfolding && int_cxt))
+                        -- isCheap => acceptable work duplication; in_lam may be true
+                        -- int_cxt to prevent us inlining inside a lambda without some
+                        -- good reason.  See the notes on int_cxt in preInlineUnconditionally
+
+      IAmDead -> True   -- This happens; for example, the case_bndr during case of
+                        -- known constructor:  case (a,b) of x { (p,q) -> ... }
+                        -- Here x isn't mentioned in the RHS, so we don't want to
+                        -- create the (dead) let-binding  let x = (a,b) in ...
+
+      _ -> False
+
+-- Here's an example that we don't handle well:
+--      let f = if b then Left (\x.BIG) else Right (\y.BIG)
+--      in \y. ....case f of {...} ....
+-- Here f is used just once, and duplicating the case work is fine (exprIsCheap).
+-- But
+--  - We can't preInlineUnconditionally because that woud invalidate
+--    the occ info for b.
+--  - We can't postInlineUnconditionally because the RHS is big, and
+--    that risks exponential behaviour
+--  - We can't call-site inline, because the rhs is big
+-- Alas!
+
+  where
+    unfolding = idUnfolding bndr
+    dflags    = seDynFlags env
+    active    = isActive (sm_phase (getMode env)) (idInlineActivation bndr)
+        -- See Note [pre/postInlineUnconditionally in gentle mode]
+
+{-
+Note [Top level and postInlineUnconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't do postInlineUnconditionally for top-level things (even for
+ones that are trivial):
+
+  * Doing so will inline top-level error expressions that have been
+    carefully floated out by FloatOut.  More generally, it might
+    replace static allocation with dynamic.
+
+  * Even for trivial expressions there's a problem.  Consider
+      {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-}
+      blah xs = reverse xs
+      ruggle = sort
+    In one simplifier pass we might fire the rule, getting
+      blah xs = ruggle xs
+    but in *that* simplifier pass we must not do postInlineUnconditionally
+    on 'ruggle' because then we'll have an unbound occurrence of 'ruggle'
+
+    If the rhs is trivial it'll be inlined by callSiteInline, and then
+    the binding will be dead and discarded by the next use of OccurAnal
+
+  * There is less point, because the main goal is to get rid of local
+    bindings used in multiple case branches.
+
+  * The inliner should inline trivial things at call sites anyway.
+
+  * The Id might be exported.  We could check for that separately,
+    but since we aren't going to postInlineUnconditionally /any/
+    top-level bindings, we don't need to test.
+
+Note [Stable unfoldings and postInlineUnconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Do not do postInlineUnconditionally if the Id has a stable unfolding,
+otherwise we lose the unfolding.  Example
+
+     -- f has stable unfolding with rhs (e |> co)
+     --   where 'e' is big
+     f = e |> co
+
+Then there's a danger we'll optimise to
+
+     f' = e
+     f = f' |> co
+
+and now postInlineUnconditionally, losing the stable unfolding on f.  Now f'
+won't inline because 'e' is too big.
+
+    c.f. Note [Stable unfoldings and preInlineUnconditionally]
+
+
+************************************************************************
+*                                                                      *
+        Rebuilding a lambda
+*                                                                      *
+************************************************************************
+-}
+
+mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr
+-- mkLam tries three things
+--      a) eta reduction, if that gives a trivial expression
+--      b) eta expansion [only if there are some value lambdas]
+
+mkLam _env [] body _cont
+  = return body
+mkLam env bndrs body cont
+  = do { dflags <- getDynFlags
+       ; mkLam' dflags bndrs body }
+  where
+    mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr
+    mkLam' dflags bndrs (Cast body co)
+      | not (any bad bndrs)
+        -- Note [Casts and lambdas]
+      = do { lam <- mkLam' dflags bndrs body
+           ; return (mkCast lam (mkPiCos Representational bndrs co)) }
+      where
+        co_vars  = tyCoVarsOfCo co
+        bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars
+
+    mkLam' dflags bndrs body@(Lam {})
+      = mkLam' dflags (bndrs ++ bndrs1) body1
+      where
+        (bndrs1, body1) = collectBinders body
+
+    mkLam' dflags bndrs (Tick t expr)
+      | tickishFloatable t
+      = mkTick t <$> mkLam' dflags bndrs expr
+
+    mkLam' dflags bndrs body
+      | gopt Opt_DoEtaReduction dflags
+      , Just etad_lam <- tryEtaReduce bndrs body
+      = do { tick (EtaReduction (head bndrs))
+           ; return etad_lam }
+
+      | not (contIsRhs cont)   -- See Note [Eta-expanding lambdas]
+      , sm_eta_expand (getMode env)
+      , any isRuntimeVar bndrs
+      , let body_arity = exprEtaExpandArity dflags body
+      , body_arity > 0
+      = do { tick (EtaExpansion (head bndrs))
+           ; let res = mkLams bndrs (etaExpand body_arity body)
+           ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body)
+                                          , text "after" <+> ppr res])
+           ; return res }
+
+      | otherwise
+      = return (mkLams bndrs body)
+
+{-
+Note [Eta expanding lambdas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general we *do* want to eta-expand lambdas. Consider
+   f (\x -> case x of (a,b) -> \s -> blah)
+where 's' is a state token, and hence can be eta expanded.  This
+showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather
+important function!
+
+The eta-expansion will never happen unless we do it now.  (Well, it's
+possible that CorePrep will do it, but CorePrep only has a half-baked
+eta-expander that can't deal with casts.  So it's much better to do it
+here.)
+
+However, when the lambda is let-bound, as the RHS of a let, we have a
+better eta-expander (in the form of tryEtaExpandRhs), so we don't
+bother to try expansion in mkLam in that case; hence the contIsRhs
+guard.
+
+NB: We check the SimplEnv (sm_eta_expand), not DynFlags.
+    See Note [No eta expansion in stable unfoldings]
+
+Note [Casts and lambdas]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+        (\x. (\y. e) `cast` g1) `cast` g2
+There is a danger here that the two lambdas look separated, and the
+full laziness pass might float an expression to between the two.
+
+So this equation in mkLam' floats the g1 out, thus:
+        (\x. e `cast` g1)  -->  (\x.e) `cast` (tx -> g1)
+where x:tx.
+
+In general, this floats casts outside lambdas, where (I hope) they
+might meet and cancel with some other cast:
+        \x. e `cast` co   ===>   (\x. e) `cast` (tx -> co)
+        /\a. e `cast` co  ===>   (/\a. e) `cast` (/\a. co)
+        /\g. e `cast` co  ===>   (/\g. e) `cast` (/\g. co)
+                          (if not (g `in` co))
+
+Notice that it works regardless of 'e'.  Originally it worked only
+if 'e' was itself a lambda, but in some cases that resulted in
+fruitless iteration in the simplifier.  A good example was when
+compiling Text.ParserCombinators.ReadPrec, where we had a definition
+like    (\x. Get `cast` g)
+where Get is a constructor with nonzero arity.  Then mkLam eta-expanded
+the Get, and the next iteration eta-reduced it, and then eta-expanded
+it again.
+
+Note also the side condition for the case of coercion binders.
+It does not make sense to transform
+        /\g. e `cast` g  ==>  (/\g.e) `cast` (/\g.g)
+because the latter is not well-kinded.
+
+************************************************************************
+*                                                                      *
+              Eta expansion
+*                                                                      *
+************************************************************************
+-}
+
+tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr
+                -> SimplM (Arity, Bool, OutExpr)
+-- See Note [Eta-expanding at let bindings]
+-- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then
+--   (a) rhs' has manifest arity
+--   (b) if is_bot is True then rhs' applied to n args is guaranteed bottom
+tryEtaExpandRhs mode bndr rhs
+  | Just join_arity <- isJoinId_maybe bndr
+  = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs
+       ; return (count isId join_bndrs, exprIsBottom join_body, rhs) }
+         -- Note [Do not eta-expand join points]
+         -- But do return the correct arity and bottom-ness, because
+         -- these are used to set the bndr's IdInfo (Trac #15517)
+
+  | otherwise
+  = do { (new_arity, is_bot, new_rhs) <- try_expand
+
+       ; WARN( new_arity < old_id_arity,
+               (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity
+                <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) )
+                        -- Note [Arity decrease] in Simplify
+         return (new_arity, is_bot, new_rhs) }
+  where
+    try_expand
+      | exprIsTrivial rhs
+      = return (exprArity rhs, False, rhs)
+
+      | sm_eta_expand mode      -- Provided eta-expansion is on
+      , new_arity > old_arity   -- And the current manifest arity isn't enough
+      = do { tick (EtaExpansion bndr)
+           ; return (new_arity, is_bot, etaExpand new_arity rhs) }
+
+      | otherwise
+      = return (old_arity, is_bot && new_arity == old_arity, rhs)
+
+    dflags       = sm_dflags mode
+    old_arity    = exprArity rhs -- See Note [Do not expand eta-expand PAPs]
+    old_id_arity = idArity bndr
+
+    (new_arity1, is_bot) = findRhsArity dflags bndr rhs old_arity
+    new_arity2 = idCallArity bndr
+    new_arity  = max new_arity1 new_arity2
+
+{-
+Note [Eta-expanding at let bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We now eta expand at let-bindings, which is where the payoff comes.
+The most significant thing is that we can do a simple arity analysis
+(in CoreArity.findRhsArity), which we can't do for free-floating lambdas
+
+One useful consequence of not eta-expanding lambdas is this example:
+   genMap :: C a => ...
+   {-# INLINE genMap #-}
+   genMap f xs = ...
+
+   myMap :: D a => ...
+   {-# INLINE myMap #-}
+   myMap = genMap
+
+Notice that 'genMap' should only inline if applied to two arguments.
+In the stable unfolding for myMap we'll have the unfolding
+    (\d -> genMap Int (..d..))
+We do not want to eta-expand to
+    (\d f xs -> genMap Int (..d..) f xs)
+because then 'genMap' will inline, and it really shouldn't: at least
+as far as the programmer is concerned, it's not applied to two
+arguments!
+
+Note [Do not eta-expand join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Similarly to CPR (see Note [Don't CPR join points] in WorkWrap), a join point
+stands well to gain from its outer binding's eta-expansion, and eta-expanding a
+join point is fraught with issues like how to deal with a cast:
+
+    let join $j1 :: IO ()
+             $j1 = ...
+             $j2 :: Int -> IO ()
+             $j2 n = if n > 0 then $j1
+                              else ...
+
+    =>
+
+    let join $j1 :: IO ()
+             $j1 = (\eta -> ...)
+                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())
+                                 ~  IO ()
+             $j2 :: Int -> IO ()
+             $j2 n = (\eta -> if n > 0 then $j1
+                                       else ...)
+                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())
+                                 ~  IO ()
+
+The cast here can't be pushed inside the lambda (since it's not casting to a
+function type), so the lambda has to stay, but it can't because it contains a
+reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather
+than try and detect this situation (and whatever other situations crop up!), we
+don't bother; again, any surrounding eta-expansion will improve these join
+points anyway, since an outer cast can *always* be pushed inside. By the time
+CorePrep comes around, the code is very likely to look more like this:
+
+    let join $j1 :: State# RealWorld -> (# State# RealWorld, ())
+             $j1 = (...) eta
+             $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ())
+             $j2 = if n > 0 then $j1
+                            else (...) eta
+
+Note [Do not eta-expand PAPs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to have old_arity = manifestArity rhs, which meant that we
+would eta-expand even PAPs.  But this gives no particular advantage,
+and can lead to a massive blow-up in code size, exhibited by Trac #9020.
+Suppose we have a PAP
+    foo :: IO ()
+    foo = returnIO ()
+Then we can eta-expand do
+    foo = (\eta. (returnIO () |> sym g) eta) |> g
+where
+    g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)
+
+But there is really no point in doing this, and it generates masses of
+coercions and whatnot that eventually disappear again. For T9020, GHC
+allocated 6.6G beore, and 0.8G afterwards; and residency dropped from
+1.8G to 45M.
+
+But note that this won't eta-expand, say
+  f = \g -> map g
+Does it matter not eta-expanding such functions?  I'm not sure.  Perhaps
+strictness analysis will have less to bite on?
+
+
+************************************************************************
+*                                                                      *
+\subsection{Floating lets out of big lambdas}
+*                                                                      *
+************************************************************************
+
+Note [Floating and type abstraction]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+        x = /\a. C e1 e2
+We'd like to float this to
+        y1 = /\a. e1
+        y2 = /\a. e2
+        x  = /\a. C (y1 a) (y2 a)
+for the usual reasons: we want to inline x rather vigorously.
+
+You may think that this kind of thing is rare.  But in some programs it is
+common.  For example, if you do closure conversion you might get:
+
+        data a :-> b = forall e. (e -> a -> b) :$ e
+
+        f_cc :: forall a. a :-> a
+        f_cc = /\a. (\e. id a) :$ ()
+
+Now we really want to inline that f_cc thing so that the
+construction of the closure goes away.
+
+So I have elaborated simplLazyBind to understand right-hand sides that look
+like
+        /\ a1..an. body
+
+and treat them specially. The real work is done in SimplUtils.abstractFloats,
+but there is quite a bit of plumbing in simplLazyBind as well.
+
+The same transformation is good when there are lets in the body:
+
+        /\abc -> let(rec) x = e in b
+   ==>
+        let(rec) x' = /\abc -> let x = x' a b c in e
+        in
+        /\abc -> let x = x' a b c in b
+
+This is good because it can turn things like:
+
+        let f = /\a -> letrec g = ... g ... in g
+into
+        letrec g' = /\a -> ... g' a ...
+        in
+        let f = /\ a -> g' a
+
+which is better.  In effect, it means that big lambdas don't impede
+let-floating.
+
+This optimisation is CRUCIAL in eliminating the junk introduced by
+desugaring mutually recursive definitions.  Don't eliminate it lightly!
+
+[May 1999]  If we do this transformation *regardless* then we can
+end up with some pretty silly stuff.  For example,
+
+        let
+            st = /\ s -> let { x1=r1 ; x2=r2 } in ...
+        in ..
+becomes
+        let y1 = /\s -> r1
+            y2 = /\s -> r2
+            st = /\s -> ...[y1 s/x1, y2 s/x2]
+        in ..
+
+Unless the "..." is a WHNF there is really no point in doing this.
+Indeed it can make things worse.  Suppose x1 is used strictly,
+and is of the form
+
+        x1* = case f y of { (a,b) -> e }
+
+If we abstract this wrt the tyvar we then can't do the case inline
+as we would normally do.
+
+That's why the whole transformation is part of the same process that
+floats let-bindings and constructor arguments out of RHSs.  In particular,
+it is guarded by the doFloatFromRhs call in simplLazyBind.
+
+Note [Which type variables to abstract over]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Abstract only over the type variables free in the rhs wrt which the
+new binding is abstracted.  Note that
+
+  * The naive approach of abstracting wrt the
+    tyvars free in the Id's /type/ fails. Consider:
+        /\ a b -> let t :: (a,b) = (e1, e2)
+                      x :: a     = fst t
+                  in ...
+    Here, b isn't free in x's type, but we must nevertheless
+    abstract wrt b as well, because t's type mentions b.
+    Since t is floated too, we'd end up with the bogus:
+         poly_t = /\ a b -> (e1, e2)
+         poly_x = /\ a   -> fst (poly_t a *b*)
+
+  * We must do closeOverKinds.  Example (Trac #10934):
+       f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ...
+    Here we want to float 't', but we must remember to abstract over
+    'k' as well, even though it is not explicitly mentioned in the RHS,
+    otherwise we get
+       t = /\ (f:k->*) (a:k). AccFailure @ (f a)
+    which is obviously bogus.
+-}
+
+abstractFloats :: DynFlags -> TopLevelFlag -> [OutTyVar] -> SimplFloats
+              -> OutExpr -> SimplM ([OutBind], OutExpr)
+abstractFloats dflags top_lvl main_tvs floats body
+  = ASSERT( notNull body_floats )
+    ASSERT( isNilOL (sfJoinFloats floats) )
+    do  { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
+        ; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) }
+  where
+    is_top_lvl  = isTopLevel top_lvl
+    main_tv_set = mkVarSet main_tvs
+    body_floats = letFloatBinds (sfLetFloats floats)
+    empty_subst = CoreSubst.mkEmptySubst (sfInScope floats)
+
+    abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind)
+    abstract subst (NonRec id rhs)
+      = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id
+           ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'
+                 subst' = CoreSubst.extendIdSubst subst id poly_app
+           ; return (subst', NonRec poly_id2 poly_rhs) }
+      where
+        rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
+
+        -- tvs_here: see Note [Which type variables to abstract over]
+        tvs_here = scopedSort $
+                   filter (`elemVarSet` main_tv_set) $
+                   closeOverKindsList $
+                   exprSomeFreeVarsList isTyVar rhs'
+
+    abstract subst (Rec prs)
+       = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids
+            ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)
+                  poly_pairs = [ mk_poly2 poly_id tvs_here rhs'
+                               | (poly_id, rhs) <- poly_ids `zip` rhss
+                               , let rhs' = CoreSubst.substExpr (text "abstract_floats")
+                                                                subst' rhs ]
+            ; return (subst', Rec poly_pairs) }
+       where
+         (ids,rhss) = unzip prs
+                -- For a recursive group, it's a bit of a pain to work out the minimal
+                -- set of tyvars over which to abstract:
+                --      /\ a b c.  let x = ...a... in
+                --                 letrec { p = ...x...q...
+                --                          q = .....p...b... } in
+                --                 ...
+                -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted
+                -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'.
+                -- Since it's a pain, we just use the whole set, which is always safe
+                --
+                -- If you ever want to be more selective, remember this bizarre case too:
+                --      x::a = x
+                -- Here, we must abstract 'x' over 'a'.
+         tvs_here = scopedSort main_tvs
+
+    mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr)
+    mk_poly1 tvs_here var
+      = do { uniq <- getUniqueM
+           ; let  poly_name = setNameUnique (idName var) uniq           -- Keep same name
+                  poly_ty   = mkInvForAllTys tvs_here (idType var) -- But new type of course
+                  poly_id   = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.hs
+                              mkLocalIdOrCoVar poly_name poly_ty
+           ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }
+                -- In the olden days, it was crucial to copy the occInfo of the original var,
+                -- because we were looking at occurrence-analysed but as yet unsimplified code!
+                -- In particular, we mustn't lose the loop breakers.  BUT NOW we are looking
+                -- at already simplified code, so it doesn't matter
+                --
+                -- It's even right to retain single-occurrence or dead-var info:
+                -- Suppose we started with  /\a -> let x = E in B
+                -- where x occurs once in B. Then we transform to:
+                --      let x' = /\a -> E in /\a -> let x* = x' a in B
+                -- where x* has an INLINE prag on it.  Now, once x* is inlined,
+                -- the occurrences of x' will be just the occurrences originally
+                -- pinned on x.
+
+    mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr)
+    mk_poly2 poly_id tvs_here rhs
+      = (poly_id `setIdUnfolding` unf, poly_rhs)
+      where
+        poly_rhs = mkLams tvs_here rhs
+        unf = mkUnfolding dflags InlineRhs is_top_lvl False poly_rhs
+
+        -- We want the unfolding.  Consider
+        --      let
+        --            x = /\a. let y = ... in Just y
+        --      in body
+        -- Then we float the y-binding out (via abstractFloats and addPolyBind)
+        -- but 'x' may well then be inlined in 'body' in which case we'd like the
+        -- opportunity to inline 'y' too.
+
+{-
+Note [Abstract over coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the
+type variable a.  Rather than sort this mess out, we simply bale out and abstract
+wrt all the type variables if any of them are coercion variables.
+
+
+Historical note: if you use let-bindings instead of a substitution, beware of this:
+
+                -- Suppose we start with:
+                --
+                --      x = /\ a -> let g = G in E
+                --
+                -- Then we'll float to get
+                --
+                --      x = let poly_g = /\ a -> G
+                --          in /\ a -> let g = poly_g a in E
+                --
+                -- But now the occurrence analyser will see just one occurrence
+                -- of poly_g, not inside a lambda, so the simplifier will
+                -- PreInlineUnconditionally poly_g back into g!  Badk to square 1!
+                -- (I used to think that the "don't inline lone occurrences" stuff
+                --  would stop this happening, but since it's the *only* occurrence,
+                --  PreInlineUnconditionally kicks in first!)
+                --
+                -- Solution: put an INLINE note on g's RHS, so that poly_g seems
+                --           to appear many times.  (NB: mkInlineMe eliminates
+                --           such notes on trivial RHSs, so do it manually.)
+
+************************************************************************
+*                                                                      *
+                prepareAlts
+*                                                                      *
+************************************************************************
+
+prepareAlts tries these things:
+
+1.  Eliminate alternatives that cannot match, including the
+    DEFAULT alternative.
+
+2.  If the DEFAULT alternative can match only one possible constructor,
+    then make that constructor explicit.
+    e.g.
+        case e of x { DEFAULT -> rhs }
+     ===>
+        case e of x { (a,b) -> rhs }
+    where the type is a single constructor type.  This gives better code
+    when rhs also scrutinises x or e.
+
+3. Returns a list of the constructors that cannot holds in the
+   DEFAULT alternative (if there is one)
+
+Here "cannot match" includes knowledge from GADTs
+
+It's a good idea to do this stuff before simplifying the alternatives, to
+avoid simplifying alternatives we know can't happen, and to come up with
+the list of constructors that are handled, to put into the IdInfo of the
+case binder, for use when simplifying the alternatives.
+
+Eliminating the default alternative in (1) isn't so obvious, but it can
+happen:
+
+data Colour = Red | Green | Blue
+
+f x = case x of
+        Red -> ..
+        Green -> ..
+        DEFAULT -> h x
+
+h y = case y of
+        Blue -> ..
+        DEFAULT -> [ case y of ... ]
+
+If we inline h into f, the default case of the inlined h can't happen.
+If we don't notice this, we may end up filtering out *all* the cases
+of the inner case y, which give us nowhere to go!
+-}
+
+prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
+-- The returned alternatives can be empty, none are possible
+prepareAlts scrut case_bndr' alts
+  | Just (tc, tys) <- splitTyConApp_maybe (varType case_bndr')
+           -- Case binder is needed just for its type. Note that as an
+           --   OutId, it has maximum information; this is important.
+           --   Test simpl013 is an example
+  = do { us <- getUniquesM
+       ; let (idcs1, alts1)       = filterAlts tc tys imposs_cons alts
+             (yes2,  alts2)       = refineDefaultAlt us tc tys idcs1 alts1
+             (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2
+             -- "idcs" stands for "impossible default data constructors"
+             -- i.e. the constructors that can't match the default case
+       ; when yes2 $ tick (FillInCaseDefault case_bndr')
+       ; when yes3 $ tick (AltMerge case_bndr')
+       ; return (idcs3, alts3) }
+
+  | otherwise  -- Not a data type, so nothing interesting happens
+  = return ([], alts)
+  where
+    imposs_cons = case scrut of
+                    Var v -> otherCons (idUnfolding v)
+                    _     -> []
+
+
+{-
+************************************************************************
+*                                                                      *
+                mkCase
+*                                                                      *
+************************************************************************
+
+mkCase tries these things
+
+* Note [Nerge nested cases]
+* Note [Eliminate identity case]
+* Note [Scrutinee constant folding]
+
+Note [Merge Nested Cases]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+       case e of b {             ==>   case e of b {
+         p1 -> rhs1                      p1 -> rhs1
+         ...                             ...
+         pm -> rhsm                      pm -> rhsm
+         _  -> case b of b' {            pn -> let b'=b in rhsn
+                     pn -> rhsn          ...
+                     ...                 po -> let b'=b in rhso
+                     po -> rhso          _  -> let b'=b in rhsd
+                     _  -> rhsd
+       }
+
+which merges two cases in one case when -- the default alternative of
+the outer case scrutises the same variable as the outer case. This
+transformation is called Case Merging.  It avoids that the same
+variable is scrutinised multiple times.
+
+Note [Eliminate Identity Case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        case e of               ===> e
+                True  -> True;
+                False -> False
+
+and similar friends.
+
+Note [Scrutinee Constant Folding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+     case x op# k# of _ {  ===> case x of _ {
+        a1# -> e1                  (a1# inv_op# k#) -> e1
+        a2# -> e2                  (a2# inv_op# k#) -> e2
+        ...                        ...
+        DEFAULT -> ed              DEFAULT -> ed
+
+     where (x op# k#) inv_op# k# == x
+
+And similarly for commuted arguments and for some unary operations.
+
+The purpose of this transformation is not only to avoid an arithmetic
+operation at runtime but to allow other transformations to apply in cascade.
+
+Example with the "Merge Nested Cases" optimization (from #12877):
+
+      main = case t of t0
+         0##     -> ...
+         DEFAULT -> case t0 `minusWord#` 1## of t1
+            0##    -> ...
+            DEFAUT -> case t1 `minusWord#` 1## of t2
+               0##     -> ...
+               DEFAULT -> case t2 `minusWord#` 1## of _
+                  0##     -> ...
+                  DEFAULT -> ...
+
+  becomes:
+
+      main = case t of _
+      0##     -> ...
+      1##     -> ...
+      2##     -> ...
+      3##     -> ...
+      DEFAULT -> ...
+
+There are some wrinkles
+
+* Do not apply caseRules if there is just a single DEFAULT alternative
+     case e +# 3# of b { DEFAULT -> rhs }
+  If we applied the transformation here we would (stupidly) get
+     case a of b' { DEFAULT -> let b = e +# 3# in rhs }
+  and now the process may repeat, because that let will really
+  be a case.
+
+* The type of the scrutinee might change.  E.g.
+        case tagToEnum (x :: Int#) of (b::Bool)
+          False -> e1
+          True -> e2
+  ==>
+        case x of (b'::Int#)
+          DEFAULT -> e1
+          1#      -> e2
+
+* The case binder may be used in the right hand sides, so we need
+  to make a local binding for it, if it is alive.  e.g.
+         case e +# 10# of b
+           DEFAULT -> blah...b...
+           44#     -> blah2...b...
+  ===>
+         case e of b'
+           DEFAULT -> let b = b' +# 10# in blah...b...
+           34#     -> let b = 44# in blah2...b...
+
+  Note that in the non-DEFAULT cases we know what to bind 'b' to,
+  whereas in the DEFAULT case we must reconstruct the original value.
+  But NB: we use b'; we do not duplicate 'e'.
+
+* In dataToTag we might need to make up some fake binders;
+  see Note [caseRules for dataToTag] in PrelRules
+-}
+
+mkCase, mkCase1, mkCase2, mkCase3
+   :: DynFlags
+   -> OutExpr -> OutId
+   -> OutType -> [OutAlt]               -- Alternatives in standard (increasing) order
+   -> SimplM OutExpr
+
+--------------------------------------------------
+--      1. Merge Nested Cases
+--------------------------------------------------
+
+mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts)
+  | gopt Opt_CaseMerge dflags
+  , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts)
+       <- stripTicksTop tickishFloatable deflt_rhs
+  , inner_scrut_var == outer_bndr
+  = do  { tick (CaseMerge outer_bndr)
+
+        ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args )
+                                          (con, args, wrap_rhs rhs)
+                -- Simplifier's no-shadowing invariant should ensure
+                -- that outer_bndr is not shadowed by the inner patterns
+              wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs
+                -- The let is OK even for unboxed binders,
+
+              wrapped_alts | isDeadBinder inner_bndr = inner_alts
+                           | otherwise               = map wrap_alt inner_alts
+
+              merged_alts = mergeAlts outer_alts wrapped_alts
+                -- NB: mergeAlts gives priority to the left
+                --      case x of
+                --        A -> e1
+                --        DEFAULT -> case x of
+                --                      A -> e2
+                --                      B -> e3
+                -- When we merge, we must ensure that e1 takes
+                -- precedence over e2 as the value for A!
+
+        ; fmap (mkTicks ticks) $
+          mkCase1 dflags scrut outer_bndr alts_ty merged_alts
+        }
+        -- Warning: don't call mkCase recursively!
+        -- Firstly, there's no point, because inner alts have already had
+        -- mkCase applied to them, so they won't have a case in their default
+        -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
+        -- in munge_rhs may put a case into the DEFAULT branch!
+
+mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts
+
+--------------------------------------------------
+--      2. Eliminate Identity Case
+--------------------------------------------------
+
+mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _)      -- Identity case
+  | all identity_alt alts
+  = do { tick (CaseIdentity case_bndr)
+       ; return (mkTicks ticks $ re_cast scrut rhs1) }
+  where
+    ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts)
+    identity_alt (con, args, rhs) = check_eq rhs con args
+
+    check_eq (Cast rhs co) con args        -- See Note [RHS casts]
+      = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args
+    check_eq (Tick t e) alt args
+      = tickishFloatable t && check_eq e alt args
+
+    check_eq (Lit lit) (LitAlt lit') _     = lit == lit'
+    check_eq (Var v) _ _  | v == case_bndr = True
+    check_eq (Var v)   (DataAlt con) args
+      | null arg_tys, null args            = v == dataConWorkId con
+                                             -- Optimisation only
+    check_eq rhs        (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $
+                                             mkConApp2 con arg_tys args
+    check_eq _          _             _    = False
+
+    arg_tys = tyConAppArgs (idType case_bndr)
+
+        -- Note [RHS casts]
+        -- ~~~~~~~~~~~~~~~~
+        -- We've seen this:
+        --      case e of x { _ -> x `cast` c }
+        -- And we definitely want to eliminate this case, to give
+        --      e `cast` c
+        -- So we throw away the cast from the RHS, and reconstruct
+        -- it at the other end.  All the RHS casts must be the same
+        -- if (all identity_alt alts) holds.
+        --
+        -- Don't worry about nested casts, because the simplifier combines them
+
+    re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co
+    re_cast scrut _             = scrut
+
+mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts
+
+--------------------------------------------------
+--      2. Scrutinee Constant Folding
+--------------------------------------------------
+
+mkCase2 dflags scrut bndr alts_ty alts
+  | -- See Note [Scrutinee Constant Folding]
+    case alts of  -- Not if there is just a DEFAULT alternative
+      [(DEFAULT,_,_)] -> False
+      _               -> True
+  , gopt Opt_CaseFolding dflags
+  , Just (scrut', tx_con, mk_orig) <- caseRules dflags scrut
+  = do { bndr' <- newId (fsLit "lwild") (exprType scrut')
+
+       ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts
+                  -- mapMaybeM: discard unreachable alternatives
+                  -- See Note [Unreachable caseRules alternatives]
+                  -- in PrelRules
+
+       ; mkCase3 dflags scrut' bndr' alts_ty $
+         add_default (re_sort alts')
+       }
+
+  | otherwise
+  = mkCase3 dflags scrut bndr alts_ty alts
+  where
+    -- We need to keep the correct association between the scrutinee and its
+    -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with
+    -- "let bndr = ... in":
+    --
+    --     case v + 10 of y        =====> case v of y
+    --        20      -> e1                 10      -> let y = 20     in e1
+    --        DEFAULT -> e2                 DEFAULT -> let y = v + 10 in e2
+    --
+    -- Other transformations give: =====> case v of y'
+    --                                      10      -> let y = 20      in e1
+    --                                      DEFAULT -> let y = y' + 10 in e2
+    --
+    -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules,
+    -- to construct an expression equivalent to the original one, for use
+    -- in the DEFAULT case
+
+    tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id
+           -> CoreAlt -> SimplM (Maybe CoreAlt)
+    tx_alt tx_con mk_orig new_bndr (con, bs, rhs)
+      = case tx_con con of
+          Nothing   -> return Nothing
+          Just con' -> do { bs' <- mk_new_bndrs new_bndr con'
+                          ; return (Just (con', bs', rhs')) }
+      where
+        rhs' | isDeadBinder bndr = rhs
+             | otherwise         = bindNonRec bndr orig_val rhs
+
+        orig_val = case con of
+                      DEFAULT    -> mk_orig new_bndr
+                      LitAlt l   -> Lit l
+                      DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs
+
+    mk_new_bndrs new_bndr (DataAlt dc)
+      | not (isNullaryRepDataCon dc)
+      = -- For non-nullary data cons we must invent some fake binders
+        -- See Note [caseRules for dataToTag] in PrelRules
+        do { us <- getUniquesM
+           ; let (ex_tvs, arg_ids) = dataConRepInstPat us dc
+                                        (tyConAppArgs (idType new_bndr))
+           ; return (ex_tvs ++ arg_ids) }
+    mk_new_bndrs _ _ = return []
+
+    re_sort :: [CoreAlt] -> [CoreAlt]  -- Re-sort the alternatives to
+    re_sort alts = sortBy cmpAlt alts  -- preserve the #case_invariants#
+
+    add_default :: [CoreAlt] -> [CoreAlt]
+    -- See Note [Literal cases]
+    add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts
+    add_default alts                          = alts
+
+{- Note [Literal cases]
+~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+  case tagToEnum (a ># b) of
+     False -> e1
+     True  -> e2
+
+then caseRules for TagToEnum will turn it into
+  case tagToEnum (a ># b) of
+     0# -> e1
+     1# -> e2
+
+Since the case is exhaustive (all cases are) we can convert it to
+  case tagToEnum (a ># b) of
+     DEFAULT -> e1
+     1#      -> e2
+
+This may generate sligthtly better code (although it should not, since
+all cases are exhaustive) and/or optimise better.  I'm not certain that
+it's necessary, but currenty we do make this change.  We do it here,
+NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum]
+in PrelRules)
+-}
+
+--------------------------------------------------
+--      Catch-all
+--------------------------------------------------
+mkCase3 _dflags scrut bndr alts_ty alts
+  = return (Case scrut bndr alts_ty alts)
+
+-- See Note [Exitification] and Note [Do not inline exit join points] in Exitify.hs
+-- This lives here (and not in Id) because occurrence info is only valid on
+-- InIds, so it's crucial that isExitJoinId is only called on freshly
+-- occ-analysed code. It's not a generic function you can call anywhere.
+isExitJoinId :: Var -> Bool
+isExitJoinId id = isJoinId id && isOneOcc (idOccInfo id) && occ_in_lam (idOccInfo id)
+
+{-
+Note [Dead binders]
+~~~~~~~~~~~~~~~~~~~~
+Note that dead-ness is maintained by the simplifier, so that it is
+accurate after simplification as well as before.
+
+
+Note [Cascading case merge]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Case merging should cascade in one sweep, because it
+happens bottom-up
+
+      case e of a {
+        DEFAULT -> case a of b
+                      DEFAULT -> case b of c {
+                                     DEFAULT -> e
+                                     A -> ea
+                      B -> eb
+        C -> ec
+==>
+      case e of a {
+        DEFAULT -> case a of b
+                      DEFAULT -> let c = b in e
+                      A -> let c = b in ea
+                      B -> eb
+        C -> ec
+==>
+      case e of a {
+        DEFAULT -> let b = a in let c = b in e
+        A -> let b = a in let c = b in ea
+        B -> let b = a in eb
+        C -> ec
+
+
+However here's a tricky case that we still don't catch, and I don't
+see how to catch it in one pass:
+
+  case x of c1 { I# a1 ->
+  case a1 of c2 ->
+    0 -> ...
+    DEFAULT -> case x of c3 { I# a2 ->
+               case a2 of ...
+
+After occurrence analysis (and its binder-swap) we get this
+
+  case x of c1 { I# a1 ->
+  let x = c1 in         -- Binder-swap addition
+  case a1 of c2 ->
+    0 -> ...
+    DEFAULT -> case x of c3 { I# a2 ->
+               case a2 of ...
+
+When we simplify the inner case x, we'll see that
+x=c1=I# a1.  So we'll bind a2 to a1, and get
+
+  case x of c1 { I# a1 ->
+  case a1 of c2 ->
+    0 -> ...
+    DEFAULT -> case a1 of ...
+
+This is corect, but we can't do a case merge in this sweep
+because c2 /= a1.  Reason: the binding c1=I# a1 went inwards
+without getting changed to c1=I# c2.
+
+I don't think this is worth fixing, even if I knew how. It'll
+all come out in the next pass anyway.
+-}
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplCore/Simplify.hs
@@ -0,0 +1,3562 @@
+{-
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+\section[Simplify]{The main module of the simplifier}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module Simplify ( simplTopBinds, simplExpr, simplRules ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import DynFlags
+import SimplMonad
+import Type hiding      ( substTy, substTyVar, extendTvSubst, extendCvSubst )
+import SimplEnv
+import SimplUtils
+import OccurAnal        ( occurAnalyseExpr )
+import FamInstEnv       ( FamInstEnv )
+import Literal          ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326
+import Id
+import MkId             ( seqId )
+import MkCore           ( mkImpossibleExpr, castBottomExpr )
+import IdInfo
+import Name             ( mkSystemVarName, isExternalName, getOccFS )
+import Coercion hiding  ( substCo, substCoVar )
+import OptCoercion      ( optCoercion )
+import FamInstEnv       ( topNormaliseType_maybe )
+import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness
+                        , dataConRepArgTys, isUnboxedTupleCon
+                        , StrictnessMark (..) )
+import CoreMonad        ( Tick(..), SimplMode(..) )
+import CoreSyn
+import Demand           ( StrictSig(..), dmdTypeDepth, isStrictDmd )
+import PprCore          ( pprCoreExpr )
+import CoreUnfold
+import CoreUtils
+import CoreOpt          ( pushCoTyArg, pushCoValArg
+                        , joinPointBinding_maybe, joinPointBindings_maybe )
+import Rules            ( mkRuleInfo, lookupRule, getRules )
+import Demand           ( mkClosedStrictSig, topDmd, exnRes )
+import BasicTypes       ( TopLevelFlag(..), isNotTopLevel, isTopLevel,
+                          RecFlag(..), Arity )
+import MonadUtils       ( mapAccumLM, liftIO )
+import Var              ( isTyCoVar )
+import Maybes           (  orElse )
+import Control.Monad
+import Outputable
+import FastString
+import Pair
+import Util
+import ErrUtils
+import Module          ( moduleName, pprModuleName )
+import PrimOp          ( PrimOp (SeqOp) )
+
+
+{-
+The guts of the simplifier is in this module, but the driver loop for
+the simplifier is in SimplCore.hs.
+
+Note [The big picture]
+~~~~~~~~~~~~~~~~~~~~~~
+The general shape of the simplifier is this:
+
+  simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)
+  simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)
+
+ * SimplEnv contains
+     - Simplifier mode (which includes DynFlags for convenience)
+     - Ambient substitution
+     - InScopeSet
+
+ * SimplFloats contains
+     - Let-floats (which includes ok-for-spec case-floats)
+     - Join floats
+     - InScopeSet (including all the floats)
+
+ * Expressions
+      simplExpr :: SimplEnv -> InExpr -> SimplCont
+                -> SimplM (SimplFloats, OutExpr)
+   The result of simplifying an /expression/ is (floats, expr)
+      - A bunch of floats (let bindings, join bindings)
+      - A simplified expression.
+   The overall result is effectively (let floats in expr)
+
+ * Bindings
+      simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)
+   The result of simplifying a binding is
+     - A bunch of floats, the last of which is the simplified binding
+       There may be auxiliary bindings too; see prepareRhs
+     - An environment suitable for simplifying the scope of the binding
+
+   The floats may also be empty, if the binding is inlined unconditionally;
+   in that case the returned SimplEnv will have an augmented substitution.
+
+   The returned floats and env both have an in-scope set, and they are
+   guaranteed to be the same.
+
+
+Note [Shadowing]
+~~~~~~~~~~~~~~~~
+The simplifier used to guarantee that the output had no shadowing, but
+it does not do so any more.   (Actually, it never did!)  The reason is
+documented with simplifyArgs.
+
+
+Eta expansion
+~~~~~~~~~~~~~~
+For eta expansion, we want to catch things like
+
+        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r
+
+If the \x was on the RHS of a let, we'd eta expand to bring the two
+lambdas together.  And in general that's a good thing to do.  Perhaps
+we should eta expand wherever we find a (value) lambda?  Then the eta
+expansion at a let RHS can concentrate solely on the PAP case.
+
+************************************************************************
+*                                                                      *
+\subsection{Bindings}
+*                                                                      *
+************************************************************************
+-}
+
+simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)
+-- See Note [The big picture]
+simplTopBinds env0 binds0
+  = do  {       -- Put all the top-level binders into scope at the start
+                -- so that if a transformation rule has unexpectedly brought
+                -- anything into scope, then we don't get a complaint about that.
+                -- It's rather as if the top-level binders were imported.
+                -- See note [Glomming] in OccurAnal.
+        ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)
+        ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0
+        ; freeTick SimplifierDone
+        ; return (floats, env2) }
+  where
+        -- We need to track the zapped top-level binders, because
+        -- they should have their fragile IdInfo zapped (notably occurrence info)
+        -- That's why we run down binds and bndrs' simultaneously.
+        --
+    simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)
+    simpl_binds env []           = return (emptyFloats env, env)
+    simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind
+                                      ; (floats, env2) <- simpl_binds env1 binds
+                                      ; return (float `addFloats` floats, env2) }
+
+    simpl_bind env (Rec pairs)
+      = simplRecBind env TopLevel Nothing pairs
+    simpl_bind env (NonRec b r)
+      = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing
+           ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r }
+
+{-
+************************************************************************
+*                                                                      *
+        Lazy bindings
+*                                                                      *
+************************************************************************
+
+simplRecBind is used for
+        * recursive bindings only
+-}
+
+simplRecBind :: SimplEnv -> TopLevelFlag -> MaybeJoinCont
+             -> [(InId, InExpr)]
+             -> SimplM (SimplFloats, SimplEnv)
+simplRecBind env0 top_lvl mb_cont pairs0
+  = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0
+        ; (rec_floats, env1) <- go env_with_info triples
+        ; return (mkRecFloats rec_floats, env1) }
+  where
+    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))
+        -- Add the (substituted) rules to the binder
+    add_rules env (bndr, rhs)
+        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) mb_cont
+             ; return (env', (bndr, bndr', rhs)) }
+
+    go env [] = return (emptyFloats env, env)
+
+    go env ((old_bndr, new_bndr, rhs) : pairs)
+        = do { (float, env1) <- simplRecOrTopPair env top_lvl Recursive mb_cont
+                                                  old_bndr new_bndr rhs
+             ; (floats, env2) <- go env1 pairs
+             ; return (float `addFloats` floats, env2) }
+
+{-
+simplOrTopPair is used for
+        * recursive bindings (whether top level or not)
+        * top-level non-recursive bindings
+
+It assumes the binder has already been simplified, but not its IdInfo.
+-}
+
+simplRecOrTopPair :: SimplEnv
+                  -> TopLevelFlag -> RecFlag -> MaybeJoinCont
+                  -> InId -> OutBndr -> InExpr  -- Binder and rhs
+                  -> SimplM (SimplFloats, SimplEnv)
+
+simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs
+  | Just env' <- preInlineUnconditionally env top_lvl old_bndr rhs env
+  = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}
+    trace_bind "pre-inline-uncond" $
+    do { tick (PreInlineUnconditionally old_bndr)
+       ; return ( emptyFloats env, env' ) }
+
+  | Just cont <- mb_cont
+  = {-#SCC "simplRecOrTopPair-join" #-}
+    ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr )
+    trace_bind "join" $
+    simplJoinBind env cont old_bndr new_bndr rhs env
+
+  | otherwise
+  = {-#SCC "simplRecOrTopPair-normal" #-}
+    trace_bind "normal" $
+    simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env
+
+  where
+    dflags = seDynFlags env
+
+    -- trace_bind emits a trace for each top-level binding, which
+    -- helps to locate the tracing for inlining and rule firing
+    trace_bind what thing_inside
+      | not (dopt Opt_D_verbose_core2core dflags)
+      = thing_inside
+      | otherwise
+      = pprTrace ("SimplBind " ++ what) (ppr old_bndr) thing_inside
+
+--------------------------
+simplLazyBind :: SimplEnv
+              -> TopLevelFlag -> RecFlag
+              -> InId -> OutId          -- Binder, both pre-and post simpl
+                                        -- Not a JoinId
+                                        -- The OutId has IdInfo, except arity, unfolding
+                                        -- Ids only, no TyVars
+              -> InExpr -> SimplEnv     -- The RHS and its environment
+              -> SimplM (SimplFloats, SimplEnv)
+-- Precondition: not a JoinId
+-- Precondition: rhs obeys the let/app invariant
+-- NOT used for JoinIds
+simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
+  = ASSERT( isId bndr )
+    ASSERT2( not (isJoinId bndr), ppr bndr )
+    -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $
+    do  { let   rhs_env     = rhs_se `setInScopeFromE` env
+                (tvs, body) = case collectTyAndValBinders rhs of
+                                (tvs, [], body)
+                                  | surely_not_lam body -> (tvs, body)
+                                _                       -> ([], rhs)
+
+                surely_not_lam (Lam {})     = False
+                surely_not_lam (Tick t e)
+                  | not (tickishFloatable t) = surely_not_lam e
+                   -- eta-reduction could float
+                surely_not_lam _            = True
+                        -- Do not do the "abstract tyvar" thing if there's
+                        -- a lambda inside, because it defeats eta-reduction
+                        --    f = /\a. \x. g a x
+                        -- should eta-reduce.
+
+
+        ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs
+                -- See Note [Floating and type abstraction] in SimplUtils
+
+        -- Simplify the RHS
+        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))
+        ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont
+
+              -- Never float join-floats out of a non-join let-binding
+              -- So wrap the body in the join-floats right now
+              -- Hence: body_floats1 consists only of let-floats
+        ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0
+
+        -- ANF-ise a constructor or PAP rhs
+        -- We get at most one float per argument here
+        ; (let_floats, body2) <- {-#SCC "prepareRhs" #-} prepareRhs (getMode env) top_lvl
+                                            (getOccFS bndr1) (idInfo bndr1) body1
+        ; let body_floats2 = body_floats1 `addLetFloats` let_floats
+
+        ; (rhs_floats, rhs')
+            <-  if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2)
+                then                    -- No floating, revert to body1
+                     {-#SCC "simplLazyBind-no-floating" #-}
+                     do { rhs' <- mkLam env tvs' (wrapFloats body_floats2 body1) rhs_cont
+                        ; return (emptyFloats env, rhs') }
+
+                else if null tvs then   -- Simple floating
+                     {-#SCC "simplLazyBind-simple-floating" #-}
+                     do { tick LetFloatFromLet
+                        ; return (body_floats2, body2) }
+
+                else                    -- Do type-abstraction first
+                     {-#SCC "simplLazyBind-type-abstraction-first" #-}
+                     do { tick LetFloatFromLet
+                        ; (poly_binds, body3) <- abstractFloats (seDynFlags env) top_lvl
+                                                                tvs' body_floats2 body2
+                        ; let floats = foldl' extendFloats (emptyFloats env) poly_binds
+                        ; rhs' <- mkLam env tvs' body3 rhs_cont
+                        ; return (floats, rhs') }
+
+        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)
+                                             top_lvl Nothing bndr bndr1 rhs'
+        ; return (rhs_floats `addFloats` bind_float, env2) }
+
+--------------------------
+simplJoinBind :: SimplEnv
+              -> SimplCont
+              -> InId -> OutId          -- Binder, both pre-and post simpl
+                                        -- The OutId has IdInfo, except arity,
+                                        --   unfolding
+              -> InExpr -> SimplEnv     -- The right hand side and its env
+              -> SimplM (SimplFloats, SimplEnv)
+simplJoinBind env cont old_bndr new_bndr rhs rhs_se
+  = do  { let rhs_env = rhs_se `setInScopeFromE` env
+        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont
+        ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' }
+
+--------------------------
+simplNonRecX :: SimplEnv
+             -> InId            -- Old binder; not a JoinId
+             -> OutExpr         -- Simplified RHS
+             -> SimplM (SimplFloats, SimplEnv)
+-- A specialised variant of simplNonRec used when the RHS is already
+-- simplified, notably in knownCon.  It uses case-binding where necessary.
+--
+-- Precondition: rhs satisfies the let/app invariant
+
+simplNonRecX env bndr new_rhs
+  | ASSERT2( not (isJoinId bndr), ppr bndr )
+    isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
+  = return (emptyFloats env, env)    --  Here c is dead, and we avoid
+                                         --  creating the binding c = (a,b)
+
+  | Coercion co <- new_rhs
+  = return (emptyFloats env, extendCvSubst env bndr co)
+
+  | otherwise
+  = do  { (env', bndr') <- simplBinder env bndr
+        ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }
+                -- simplNonRecX is only used for NotTopLevel things
+
+--------------------------
+completeNonRecX :: TopLevelFlag -> SimplEnv
+                -> Bool
+                -> InId                 -- Old binder; not a JoinId
+                -> OutId                -- New binder
+                -> OutExpr              -- Simplified RHS
+                -> SimplM (SimplFloats, SimplEnv)    -- The new binding is in the floats
+-- Precondition: rhs satisfies the let/app invariant
+--               See Note [CoreSyn let/app invariant] in CoreSyn
+
+completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs
+  = ASSERT2( not (isJoinId new_bndr), ppr new_bndr )
+    do  { (prepd_floats, rhs1) <- prepareRhs (getMode env) top_lvl (getOccFS new_bndr)
+                                             (idInfo new_bndr) new_rhs
+        ; let floats = emptyFloats env `addLetFloats` prepd_floats
+        ; (rhs_floats, rhs2) <-
+                if doFloatFromRhs NotTopLevel NonRecursive is_strict floats rhs1
+                then    -- Add the floats to the main env
+                     do { tick LetFloatFromLet
+                        ; return (floats, rhs1) }
+                else    -- Do not float; wrap the floats around the RHS
+                     return (emptyFloats env, wrapFloats floats rhs1)
+
+        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)
+                                             NotTopLevel Nothing
+                                             old_bndr new_bndr rhs2
+        ; return (rhs_floats `addFloats` bind_float, env2) }
+
+
+{- *********************************************************************
+*                                                                      *
+           prepareRhs, makeTrivial
+*                                                                      *
+************************************************************************
+
+Note [prepareRhs]
+~~~~~~~~~~~~~~~~~
+prepareRhs takes a putative RHS, checks whether it's a PAP or
+constructor application and, if so, converts it to ANF, so that the
+resulting thing can be inlined more easily.  Thus
+        x = (f a, g b)
+becomes
+        t1 = f a
+        t2 = g b
+        x = (t1,t2)
+
+We also want to deal well cases like this
+        v = (f e1 `cast` co) e2
+Here we want to make e1,e2 trivial and get
+        x1 = e1; x2 = e2; v = (f x1 `cast` co) v2
+That's what the 'go' loop in prepareRhs does
+-}
+
+prepareRhs :: SimplMode -> TopLevelFlag
+           -> FastString   -- Base for any new variables
+           -> IdInfo       -- IdInfo for the LHS of this binding
+           -> OutExpr
+           -> SimplM (LetFloats, OutExpr)
+-- Transforms a RHS into a better RHS by adding floats
+-- e.g        x = Just e
+-- becomes    a = e
+--            x = Just a
+-- See Note [prepareRhs]
+prepareRhs mode top_lvl occ info (Cast rhs co)  -- Note [Float coercions]
+  | Pair ty1 _ty2 <- coercionKind co         -- Do *not* do this if rhs has an unlifted type
+  , not (isUnliftedType ty1)                 -- see Note [Float coercions (unlifted)]
+  = do  { (floats, rhs') <- makeTrivialWithInfo mode top_lvl occ sanitised_info rhs
+        ; return (floats, Cast rhs' co) }
+  where
+    sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info
+                                   `setDemandInfo`     demandInfo info
+
+prepareRhs mode top_lvl occ _ rhs0
+  = do  { (_is_exp, floats, rhs1) <- go 0 rhs0
+        ; return (floats, rhs1) }
+  where
+    go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)
+    go n_val_args (Cast rhs co)
+        = do { (is_exp, floats, rhs') <- go n_val_args rhs
+             ; return (is_exp, floats, Cast rhs' co) }
+    go n_val_args (App fun (Type ty))
+        = do { (is_exp, floats, rhs') <- go n_val_args fun
+             ; return (is_exp, floats, App rhs' (Type ty)) }
+    go n_val_args (App fun arg)
+        = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun
+             ; case is_exp of
+                False -> return (False, emptyLetFloats, App fun arg)
+                True  -> do { (floats2, arg') <- makeTrivial mode top_lvl occ arg
+                            ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } }
+    go n_val_args (Var fun)
+        = return (is_exp, emptyLetFloats, Var fun)
+        where
+          is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP
+                        -- See Note [CONLIKE pragma] in BasicTypes
+                        -- The definition of is_exp should match that in
+                        -- OccurAnal.occAnalApp
+
+    go n_val_args (Tick t rhs)
+        -- We want to be able to float bindings past this
+        -- tick. Non-scoping ticks don't care.
+        | tickishScoped t == NoScope
+        = do { (is_exp, floats, rhs') <- go n_val_args rhs
+             ; return (is_exp, floats, Tick t rhs') }
+
+        -- On the other hand, for scoping ticks we need to be able to
+        -- copy them on the floats, which in turn is only allowed if
+        -- we can obtain non-counting ticks.
+        | (not (tickishCounts t) || tickishCanSplit t)
+        = do { (is_exp, floats, rhs') <- go n_val_args rhs
+             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)
+                   floats' = mapLetFloats floats tickIt
+             ; return (is_exp, floats', Tick t rhs') }
+
+    go _ other
+        = return (False, emptyLetFloats, other)
+
+{-
+Note [Float coercions]
+~~~~~~~~~~~~~~~~~~~~~~
+When we find the binding
+        x = e `cast` co
+we'd like to transform it to
+        x' = e
+        x = x `cast` co         -- A trivial binding
+There's a chance that e will be a constructor application or function, or something
+like that, so moving the coercion to the usage site may well cancel the coercions
+and lead to further optimisation.  Example:
+
+     data family T a :: *
+     data instance T Int = T Int
+
+     foo :: Int -> Int -> Int
+     foo m n = ...
+        where
+          x = T m
+          go 0 = 0
+          go n = case x of { T m -> go (n-m) }
+                -- This case should optimise
+
+Note [Preserve strictness when floating coercions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the Note [Float coercions] transformation, keep the strictness info.
+Eg
+        f = e `cast` co    -- f has strictness SSL
+When we transform to
+        f' = e             -- f' also has strictness SSL
+        f = f' `cast` co   -- f still has strictness SSL
+
+Its not wrong to drop it on the floor, but better to keep it.
+
+Note [Float coercions (unlifted)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+BUT don't do [Float coercions] if 'e' has an unlifted type.
+This *can* happen:
+
+     foo :: Int = (error (# Int,Int #) "urk")
+                  `cast` CoUnsafe (# Int,Int #) Int
+
+If do the makeTrivial thing to the error call, we'll get
+    foo = case error (# Int,Int #) "urk" of v -> v `cast` ...
+But 'v' isn't in scope!
+
+These strange casts can happen as a result of case-of-case
+        bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
+                (# p,q #) -> p+q
+-}
+
+makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec)
+makeTrivialArg mode (ValArg e)
+  = do { (floats, e') <- makeTrivial mode NotTopLevel (fsLit "arg") e
+       ; return (floats, ValArg e') }
+makeTrivialArg _ arg
+  = return (emptyLetFloats, arg)  -- CastBy, TyArg
+
+makeTrivial :: SimplMode -> TopLevelFlag
+            -> FastString  -- ^ A "friendly name" to build the new binder from
+            -> OutExpr     -- ^ This expression satisfies the let/app invariant
+            -> SimplM (LetFloats, OutExpr)
+-- Binds the expression to a variable, if it's not trivial, returning the variable
+makeTrivial mode top_lvl context expr
+ = makeTrivialWithInfo mode top_lvl context vanillaIdInfo expr
+
+makeTrivialWithInfo :: SimplMode -> TopLevelFlag
+                    -> FastString  -- ^ a "friendly name" to build the new binder from
+                    -> IdInfo
+                    -> OutExpr     -- ^ This expression satisfies the let/app invariant
+                    -> SimplM (LetFloats, OutExpr)
+-- Propagate strictness and demand info to the new binder
+-- Note [Preserve strictness when floating coercions]
+-- Returned SimplEnv has same substitution as incoming one
+makeTrivialWithInfo mode top_lvl occ_fs info expr
+  | exprIsTrivial expr                          -- Already trivial
+  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise
+                                                --   See Note [Cannot trivialise]
+  = return (emptyLetFloats, expr)
+
+  | otherwise
+  = do  { (floats, expr1) <- prepareRhs mode top_lvl occ_fs info expr
+        ; if   exprIsTrivial expr1  -- See Note [Trivial after prepareRhs]
+          then return (floats, expr1)
+          else do
+        { uniq <- getUniqueM
+        ; let name = mkSystemVarName uniq occ_fs
+              var  = mkLocalIdOrCoVarWithInfo name expr_ty info
+
+        -- Now something very like completeBind,
+        -- but without the postInlineUnconditinoally part
+        ; (arity, is_bot, expr2) <- tryEtaExpandRhs mode var expr1
+        ; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2
+
+        ; let final_id = addLetBndrInfo var arity is_bot unf
+              bind     = NonRec final_id expr2
+
+        ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }}
+   where
+     expr_ty = exprType expr
+
+bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
+-- True iff we can have a binding of this expression at this level
+-- Precondition: the type is the type of the expression
+bindingOk top_lvl expr expr_ty
+  | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty
+  | otherwise          = True
+
+{- Note [Trivial after prepareRhs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we call makeTrival on (e |> co), the recursive use of prepareRhs
+may leave us with
+   { a1 = e }  and   (a1 |> co)
+Now the latter is trivial, so we don't want to let-bind it.
+
+Note [Cannot trivialise]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Consider:
+   f :: Int -> Addr#
+
+   foo :: Bar
+   foo = Bar (f 3)
+
+Then we can't ANF-ise foo, even though we'd like to, because
+we can't make a top-level binding for the Addr# (f 3). And if
+so we don't want to turn it into
+   foo = let x = f 3 in Bar x
+because we'll just end up inlining x back, and that makes the
+simplifier loop.  Better not to ANF-ise it at all.
+
+Literal strings are an exception.
+
+   foo = Ptr "blob"#
+
+We want to turn this into:
+
+   foo1 = "blob"#
+   foo = Ptr foo1
+
+See Note [CoreSyn top-level string literals] in CoreSyn.
+
+************************************************************************
+*                                                                      *
+          Completing a lazy binding
+*                                                                      *
+************************************************************************
+
+completeBind
+  * deals only with Ids, not TyVars
+  * takes an already-simplified binder and RHS
+  * is used for both recursive and non-recursive bindings
+  * is used for both top-level and non-top-level bindings
+
+It does the following:
+  - tries discarding a dead binding
+  - tries PostInlineUnconditionally
+  - add unfolding [this is the only place we add an unfolding]
+  - add arity
+
+It does *not* attempt to do let-to-case.  Why?  Because it is used for
+  - top-level bindings (when let-to-case is impossible)
+  - many situations where the "rhs" is known to be a WHNF
+                (so let-to-case is inappropriate).
+
+Nor does it do the atomic-argument thing
+-}
+
+completeBind :: SimplEnv
+             -> TopLevelFlag            -- Flag stuck into unfolding
+             -> MaybeJoinCont           -- Required only for join point
+             -> InId                    -- Old binder
+             -> OutId -> OutExpr        -- New binder and RHS
+             -> SimplM (SimplFloats, SimplEnv)
+-- completeBind may choose to do its work
+--      * by extending the substitution (e.g. let x = y in ...)
+--      * or by adding to the floats in the envt
+--
+-- Binder /can/ be a JoinId
+-- Precondition: rhs obeys the let/app invariant
+completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs
+ | isCoVar old_bndr
+ = case new_rhs of
+     Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)
+     _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))
+
+ | otherwise
+ = ASSERT( isId new_bndr )
+   do { let old_info = idInfo old_bndr
+            old_unf  = unfoldingInfo old_info
+            occ_info = occInfo old_info
+
+         -- Do eta-expansion on the RHS of the binding
+         -- See Note [Eta-expanding at let bindings] in SimplUtils
+      ; (new_arity, is_bot, final_rhs) <- tryEtaExpandRhs (getMode env)
+                                                          new_bndr new_rhs
+
+        -- Simplify the unfolding
+      ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr
+                                           final_rhs (idType new_bndr) old_unf
+
+      ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding
+
+      ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs
+
+        then -- Inline and discard the binding
+             do  { tick (PostInlineUnconditionally old_bndr)
+                 ; return ( emptyFloats env
+                          , extendIdSubst env old_bndr $
+                            DoneEx final_rhs (isJoinId_maybe new_bndr)) }
+                -- Use the substitution to make quite, quite sure that the
+                -- substitution will happen, since we are going to discard the binding
+
+        else -- Keep the binding
+             -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $
+             return (mkFloatBind env (NonRec final_bndr final_rhs)) }
+
+addLetBndrInfo :: OutId -> Arity -> Bool -> Unfolding -> OutId
+addLetBndrInfo new_bndr new_arity is_bot new_unf
+  = new_bndr `setIdInfo` info5
+  where
+    info1 = idInfo new_bndr `setArityInfo` new_arity
+
+    -- Unfolding info: Note [Setting the new unfolding]
+    info2 = info1 `setUnfoldingInfo` new_unf
+
+    -- Demand info: Note [Setting the demand info]
+    -- We also have to nuke demand info if for some reason
+    -- eta-expansion *reduces* the arity of the binding to less
+    -- than that of the strictness sig. This can happen: see Note [Arity decrease].
+    info3 | isEvaldUnfolding new_unf
+            || (case strictnessInfo info2 of
+                  StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)
+          = zapDemandInfo info2 `orElse` info2
+          | otherwise
+          = info2
+
+    -- Bottoming bindings: see Note [Bottoming bindings]
+    info4 | is_bot    = info3 `setStrictnessInfo`
+                        mkClosedStrictSig (replicate new_arity topDmd) exnRes
+          | otherwise = info3
+
+     -- Zap call arity info. We have used it by now (via
+     -- `tryEtaExpandRhs`), and the simplifier can invalidate this
+     -- information, leading to broken code later (e.g. #13479)
+    info5 = zapCallArityInfo info4
+
+
+{- Note [Arity decrease]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Generally speaking the arity of a binding should not decrease.  But it *can*
+legitimately happen because of RULES.  Eg
+        f = g Int
+where g has arity 2, will have arity 2.  But if there's a rewrite rule
+        g Int --> h
+where h has arity 1, then f's arity will decrease.  Here's a real-life example,
+which is in the output of Specialise:
+
+     Rec {
+        $dm {Arity 2} = \d.\x. op d
+        {-# RULES forall d. $dm Int d = $s$dm #-}
+
+        dInt = MkD .... opInt ...
+        opInt {Arity 1} = $dm dInt
+
+        $s$dm {Arity 0} = \x. op dInt }
+
+Here opInt has arity 1; but when we apply the rule its arity drops to 0.
+That's why Specialise goes to a little trouble to pin the right arity
+on specialised functions too.
+
+Note [Bottoming bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+   let x = error "urk"
+   in ...(case x of <alts>)...
+or
+   let f = \x. error (x ++ "urk")
+   in ...(case f "foo" of <alts>)...
+
+Then we'd like to drop the dead <alts> immediately.  So it's good to
+propagate the info that x's RHS is bottom to x's IdInfo as rapidly as
+possible.
+
+We use tryEtaExpandRhs on every binding, and it turns ou that the
+arity computation it performs (via CoreArity.findRhsArity) already
+does a simple bottoming-expression analysis.  So all we need to do
+is propagate that info to the binder's IdInfo.
+
+This showed up in Trac #12150; see comment:16.
+
+Note [Setting the demand info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the unfolding is a value, the demand info may
+go pear-shaped, so we nuke it.  Example:
+     let x = (a,b) in
+     case x of (p,q) -> h p q x
+Here x is certainly demanded. But after we've nuked
+the case, we'll get just
+     let x = (a,b) in h a b x
+and now x is not demanded (I'm assuming h is lazy)
+This really happens.  Similarly
+     let f = \x -> e in ...f..f...
+After inlining f at some of its call sites the original binding may
+(for example) be no longer strictly demanded.
+The solution here is a bit ad hoc...
+
+
+************************************************************************
+*                                                                      *
+\subsection[Simplify-simplExpr]{The main function: simplExpr}
+*                                                                      *
+************************************************************************
+
+The reason for this OutExprStuff stuff is that we want to float *after*
+simplifying a RHS, not before.  If we do so naively we get quadratic
+behaviour as things float out.
+
+To see why it's important to do it after, consider this (real) example:
+
+        let t = f x
+        in fst t
+==>
+        let t = let a = e1
+                    b = e2
+                in (a,b)
+        in fst t
+==>
+        let a = e1
+            b = e2
+            t = (a,b)
+        in
+        a       -- Can't inline a this round, cos it appears twice
+==>
+        e1
+
+Each of the ==> steps is a round of simplification.  We'd save a
+whole round if we float first.  This can cascade.  Consider
+
+        let f = g d
+        in \x -> ...f...
+==>
+        let f = let d1 = ..d.. in \y -> e
+        in \x -> ...f...
+==>
+        let d1 = ..d..
+        in \x -> ...(\y ->e)...
+
+Only in this second round can the \y be applied, and it
+might do the same again.
+-}
+
+simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr
+simplExpr env (Type ty)
+  = do { ty' <- simplType env ty  -- See Note [Avoiding space leaks in OutType]
+       ; return (Type ty') }
+
+simplExpr env expr
+  = simplExprC env expr (mkBoringStop expr_out_ty)
+  where
+    expr_out_ty :: OutType
+    expr_out_ty = substTy env (exprType expr)
+    -- NB: Since 'expr' is term-valued, not (Type ty), this call
+    --     to exprType will succeed.  exprType fails on (Type ty).
+
+simplExprC :: SimplEnv
+           -> InExpr     -- A term-valued expression, never (Type ty)
+           -> SimplCont
+           -> SimplM OutExpr
+        -- Simplify an expression, given a continuation
+simplExprC env expr cont
+  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $
+    do  { (floats, expr') <- simplExprF env expr cont
+        ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $
+          -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $
+          -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $
+          return (wrapFloats floats expr') }
+
+--------------------------------------------------
+simplExprF :: SimplEnv
+           -> InExpr     -- A term-valued expression, never (Type ty)
+           -> SimplCont
+           -> SimplM (SimplFloats, OutExpr)
+
+simplExprF env e cont
+  = {- pprTrace "simplExprF" (vcat
+      [ ppr e
+      , text "cont =" <+> ppr cont
+      , text "inscope =" <+> ppr (seInScope env)
+      , text "tvsubst =" <+> ppr (seTvSubst env)
+      , text "idsubst =" <+> ppr (seIdSubst env)
+      , text "cvsubst =" <+> ppr (seCvSubst env)
+      ]) $ -}
+    simplExprF1 env e cont
+
+simplExprF1 :: SimplEnv -> InExpr -> SimplCont
+            -> SimplM (SimplFloats, OutExpr)
+
+simplExprF1 _ (Type ty) _
+  = pprPanic "simplExprF: type" (ppr ty)
+    -- simplExprF does only with term-valued expressions
+    -- The (Type ty) case is handled separately by simplExpr
+    -- and by the other callers of simplExprF
+
+simplExprF1 env (Var v)        cont = {-#SCC "simplIdF" #-} simplIdF env v cont
+simplExprF1 env (Lit lit)      cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont
+simplExprF1 env (Tick t expr)  cont = {-#SCC "simplTick" #-} simplTick env t expr cont
+simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont
+simplExprF1 env (Coercion co)  cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont
+
+simplExprF1 env (App fun arg) cont
+  = {-#SCC "simplExprF1-App" #-} case arg of
+      Type ty -> do { -- The argument type will (almost) certainly be used
+                      -- in the output program, so just force it now.
+                      -- See Note [Avoiding space leaks in OutType]
+                      arg' <- simplType env ty
+
+                      -- But use substTy, not simplType, to avoid forcing
+                      -- the hole type; it will likely not be needed.
+                      -- See Note [The hole type in ApplyToTy]
+                    ; let hole' = substTy env (exprType fun)
+
+                    ; simplExprF env fun $
+                      ApplyToTy { sc_arg_ty  = arg'
+                                , sc_hole_ty = hole'
+                                , sc_cont    = cont } }
+      _       -> simplExprF env fun $
+                 ApplyToVal { sc_arg = arg, sc_env = env
+                            , sc_dup = NoDup, sc_cont = cont }
+
+simplExprF1 env expr@(Lam {}) cont
+  = {-#SCC "simplExprF1-Lam" #-}
+    simplLam env zapped_bndrs body cont
+        -- The main issue here is under-saturated lambdas
+        --   (\x1. \x2. e) arg1
+        -- Here x1 might have "occurs-once" occ-info, because occ-info
+        -- is computed assuming that a group of lambdas is applied
+        -- all at once.  If there are too few args, we must zap the
+        -- occ-info, UNLESS the remaining binders are one-shot
+  where
+    (bndrs, body) = collectBinders expr
+    zapped_bndrs | need_to_zap = map zap bndrs
+                 | otherwise   = bndrs
+
+    need_to_zap = any zappable_bndr (drop n_args bndrs)
+    n_args = countArgs cont
+        -- NB: countArgs counts all the args (incl type args)
+        -- and likewise drop counts all binders (incl type lambdas)
+
+    zappable_bndr b = isId b && not (isOneShotBndr b)
+    zap b | isTyVar b = b
+          | otherwise = zapLamIdInfo b
+
+simplExprF1 env (Case scrut bndr _ alts) cont
+  = {-#SCC "simplExprF1-Case" #-}
+    simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr
+                                 , sc_alts = alts
+                                 , sc_env = env, sc_cont = cont })
+
+simplExprF1 env (Let (Rec pairs) body) cont
+  | Just pairs' <- joinPointBindings_maybe pairs
+  = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont
+
+  | otherwise
+  = {-#SCC "simplRecE" #-} simplRecE env pairs body cont
+
+simplExprF1 env (Let (NonRec bndr rhs) body) cont
+  | Type ty <- rhs    -- First deal with type lets (let a = Type ty in e)
+  = {-#SCC "simplExprF1-NonRecLet-Type" #-}
+    ASSERT( isTyVar bndr )
+    do { ty' <- simplType env ty
+       ; simplExprF (extendTvSubst env bndr ty') body cont }
+
+  | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs
+  = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont
+
+  | otherwise
+  = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) ([], body) cont
+
+{- Note [Avoiding space leaks in OutType]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Since the simplifier is run for multiple iterations, we need to ensure
+that any thunks in the output of one simplifier iteration are forced
+by the evaluation of the next simplifier iteration. Otherwise we may
+retain multiple copies of the Core program and leak a terrible amount
+of memory (as in #13426).
+
+The simplifier is naturally strict in the entire "Expr part" of the
+input Core program, because any expression may contain binders, which
+we must find in order to extend the SimplEnv accordingly. But types
+do not contain binders and so it is tempting to write things like
+
+    simplExpr env (Type ty) = return (Type (substTy env ty))   -- Bad!
+
+This is Bad because the result includes a thunk (substTy env ty) which
+retains a reference to the whole simplifier environment; and the next
+simplifier iteration will not force this thunk either, because the
+line above is not strict in ty.
+
+So instead our strategy is for the simplifier to fully evaluate
+OutTypes when it emits them into the output Core program, for example
+
+    simplExpr env (Type ty) = do { ty' <- simplType env ty     -- Good
+                                 ; return (Type ty') }
+
+where the only difference from above is that simplType calls seqType
+on the result of substTy.
+
+However, SimplCont can also contain OutTypes and it's not necessarily
+a good idea to force types on the way in to SimplCont, because they
+may end up not being used and forcing them could be a lot of wasted
+work. T5631 is a good example of this.
+
+- For ApplyToTy's sc_arg_ty, we force the type on the way in because
+  the type will almost certainly appear as a type argument in the
+  output program.
+
+- For the hole types in Stop and ApplyToTy, we force the type when we
+  emit it into the output program, after obtaining it from
+  contResultType. (The hole type in ApplyToTy is only directly used
+  to form the result type in a new Stop continuation.)
+-}
+
+---------------------------------
+-- Simplify a join point, adding the context.
+-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do:
+--   \x1 .. xn -> e => \x1 .. xn -> E[e]
+-- Note that we need the arity of the join point, since e may be a lambda
+-- (though this is unlikely). See Note [Case-of-case and join points].
+simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont
+             -> SimplM OutExpr
+simplJoinRhs env bndr expr cont
+  | Just arity <- isJoinId_maybe bndr
+  =  do { let (join_bndrs, join_body) = collectNBinders arity expr
+        ; (env', join_bndrs') <- simplLamBndrs env join_bndrs
+        ; join_body' <- simplExprC env' join_body cont
+        ; return $ mkLams join_bndrs' join_body' }
+
+  | otherwise
+  = pprPanic "simplJoinRhs" (ppr bndr)
+
+---------------------------------
+simplType :: SimplEnv -> InType -> SimplM OutType
+        -- Kept monadic just so we can do the seqType
+        -- See Note [Avoiding space leaks in OutType]
+simplType env ty
+  = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $
+    seqType new_ty `seq` return new_ty
+  where
+    new_ty = substTy env ty
+
+---------------------------------
+simplCoercionF :: SimplEnv -> InCoercion -> SimplCont
+               -> SimplM (SimplFloats, OutExpr)
+simplCoercionF env co cont
+  = do { co' <- simplCoercion env co
+       ; rebuild env (Coercion co') cont }
+
+simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion
+simplCoercion env co
+  = do { dflags <- getDynFlags
+       ; let opt_co = optCoercion dflags (getTCvSubst env) co
+       ; seqCo opt_co `seq` return opt_co }
+
+-----------------------------------
+-- | Push a TickIt context outwards past applications and cases, as
+-- long as this is a non-scoping tick, to let case and application
+-- optimisations apply.
+
+simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont
+          -> SimplM (SimplFloats, OutExpr)
+simplTick env tickish expr cont
+  -- A scoped tick turns into a continuation, so that we can spot
+  -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do
+  -- it this way, then it would take two passes of the simplifier to
+  -- reduce ((scc t (\x . e)) e').
+  -- NB, don't do this with counting ticks, because if the expr is
+  -- bottom, then rebuildCall will discard the continuation.
+
+-- XXX: we cannot do this, because the simplifier assumes that
+-- the context can be pushed into a case with a single branch. e.g.
+--    scc<f>  case expensive of p -> e
+-- becomes
+--    case expensive of p -> scc<f> e
+--
+-- So I'm disabling this for now.  It just means we will do more
+-- simplifier iterations that necessary in some cases.
+
+--  | tickishScoped tickish && not (tickishCounts tickish)
+--  = simplExprF env expr (TickIt tickish cont)
+
+  -- For unscoped or soft-scoped ticks, we are allowed to float in new
+  -- cost, so we simply push the continuation inside the tick.  This
+  -- has the effect of moving the tick to the outside of a case or
+  -- application context, allowing the normal case and application
+  -- optimisations to fire.
+  | tickish `tickishScopesLike` SoftScope
+  = do { (floats, expr') <- simplExprF env expr cont
+       ; return (floats, mkTick tickish expr')
+       }
+
+  -- Push tick inside if the context looks like this will allow us to
+  -- do a case-of-case - see Note [case-of-scc-of-case]
+  | Select {} <- cont, Just expr' <- push_tick_inside
+  = simplExprF env expr' cont
+
+  -- We don't want to move the tick, but we might still want to allow
+  -- floats to pass through with appropriate wrapping (or not, see
+  -- wrap_floats below)
+  --- | not (tickishCounts tickish) || tickishCanSplit tickish
+  -- = wrap_floats
+
+  | otherwise
+  = no_floating_past_tick
+
+ where
+
+  -- Try to push tick inside a case, see Note [case-of-scc-of-case].
+  push_tick_inside =
+    case expr0 of
+      Case scrut bndr ty alts
+             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)
+      _other -> Nothing
+   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)
+         movable t      = not (tickishCounts t) ||
+                          t `tickishScopesLike` NoScope ||
+                          tickishCanSplit t
+         tickScrut e    = foldr mkTick e ticks
+         -- Alternatives get annotated with all ticks that scope in some way,
+         -- but we don't want to count entries.
+         tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope)
+         ts_scope         = map mkNoCount $
+                            filter (not . (`tickishScopesLike` NoScope)) ticks
+
+  no_floating_past_tick =
+    do { let (inc,outc) = splitCont cont
+       ; (floats, expr1) <- simplExprF env expr inc
+       ; let expr2    = wrapFloats floats expr1
+             tickish' = simplTickish env tickish
+       ; rebuild env (mkTick tickish' expr2) outc
+       }
+
+-- Alternative version that wraps outgoing floats with the tick.  This
+-- results in ticks being duplicated, as we don't make any attempt to
+-- eliminate the tick if we re-inline the binding (because the tick
+-- semantics allows unrestricted inlining of HNFs), so I'm not doing
+-- this any more.  FloatOut will catch any real opportunities for
+-- floating.
+--
+--  wrap_floats =
+--    do { let (inc,outc) = splitCont cont
+--       ; (env', expr') <- simplExprF (zapFloats env) expr inc
+--       ; let tickish' = simplTickish env tickish
+--       ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0),
+--                                   mkTick (mkNoCount tickish') rhs)
+--              -- when wrapping a float with mkTick, we better zap the Id's
+--              -- strictness info and arity, because it might be wrong now.
+--       ; let env'' = addFloats env (mapFloats env' wrap_float)
+--       ; rebuild env'' expr' (TickIt tickish' outc)
+--       }
+
+
+  simplTickish env tickish
+    | Breakpoint n ids <- tickish
+          = Breakpoint n (map (getDoneId . substId env) ids)
+    | otherwise = tickish
+
+  -- Push type application and coercion inside a tick
+  splitCont :: SimplCont -> (SimplCont, SimplCont)
+  splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)
+    where (inc,outc) = splitCont tail
+  splitCont (CastIt co c) = (CastIt co inc, outc)
+    where (inc,outc) = splitCont c
+  splitCont other = (mkBoringStop (contHoleType other), other)
+
+  getDoneId (DoneId id)  = id
+  getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst
+  getDoneId other = pprPanic "getDoneId" (ppr other)
+
+-- Note [case-of-scc-of-case]
+-- It's pretty important to be able to transform case-of-case when
+-- there's an SCC in the way.  For example, the following comes up
+-- in nofib/real/compress/Encode.hs:
+--
+--        case scctick<code_string.r1>
+--             case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje
+--             of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->
+--             (ww1_s13f, ww2_s13g, ww3_s13h)
+--             }
+--        of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->
+--        tick<code_string.f1>
+--        (ww_s12Y,
+--         ww1_s12Z,
+--         PTTrees.PT
+--           @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)
+--        }
+--
+-- We really want this case-of-case to fire, because then the 3-tuple
+-- will go away (indeed, the CPR optimisation is relying on this
+-- happening).  But the scctick is in the way - we need to push it
+-- inside to expose the case-of-case.  So we perform this
+-- transformation on the inner case:
+--
+--   scctick c (case e of { p1 -> e1; ...; pn -> en })
+--    ==>
+--   case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }
+--
+-- So we've moved a constant amount of work out of the scc to expose
+-- the case.  We only do this when the continuation is interesting: in
+-- for now, it has to be another Case (maybe generalise this later).
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{The main rebuilder}
+*                                                                      *
+************************************************************************
+-}
+
+rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)
+-- At this point the substitution in the SimplEnv should be irrelevant;
+-- only the in-scope set matters
+rebuild env expr cont
+  = case cont of
+      Stop {}          -> return (emptyFloats env, expr)
+      TickIt t cont    -> rebuild env (mkTick t expr) cont
+      CastIt co cont   -> rebuild env (mkCast expr co) cont
+                       -- NB: mkCast implements the (Coercion co |> g) optimisation
+
+      Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }
+        -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont
+
+      StrictArg { sc_fun = fun, sc_cont = cont }
+        -> rebuildCall env (fun `addValArgTo` expr) cont
+      StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body
+                 , sc_env = se, sc_cont = cont }
+        -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr
+                                  -- expr satisfies let/app since it started life
+                                  -- in a call to simplNonRecE
+              ; (floats2, expr') <- simplLam env' bs body cont
+              ; return (floats1 `addFloats` floats2, expr') }
+
+      ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}
+        -> rebuild env (App expr (Type ty)) cont
+
+      ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}
+        -- See Note [Avoid redundant simplification]
+        -> do { (_, _, arg') <- simplArg env dup_flag se arg
+              ; rebuild env (App expr arg') cont }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Lambdas}
+*                                                                      *
+************************************************************************
+-}
+
+{- Note [Optimising reflexivity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's important (for compiler performance) to get rid of reflexivity as soon
+as it appears.  See Trac #11735, #14737, and #15019.
+
+In particular, we want to behave well on
+
+ *  e |> co1 |> co2
+    where the two happen to cancel out entirely. That is quite common;
+    e.g. a newtype wrapping and unwrapping cancel.
+
+
+ * (f |> co) @t1 @t2 ... @tn x1 .. xm
+   Here we wil use pushCoTyArg and pushCoValArg successively, which
+   build up NthCo stacks.  Silly to do that if co is reflexive.
+
+However, we don't want to call isReflexiveCo too much, because it uses
+type equality which is expensive on big types (Trac #14737 comment:7).
+
+A good compromise (determined experimentally) seems to be to call
+isReflexiveCo
+ * when composing casts, and
+ * at the end
+
+In investigating this I saw missed opportunities for on-the-fly
+coercion shrinkage. See Trac #15090.
+-}
+
+
+simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont
+          -> SimplM (SimplFloats, OutExpr)
+simplCast env body co0 cont0
+  = do  { co1   <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0
+        ; cont1 <- {-#SCC "simplCast-addCoerce" #-}
+                   if isReflCo co1
+                   then return cont0  -- See Note [Optimising reflexivity]
+                   else addCoerce co1 cont0
+        ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }
+  where
+        -- If the first parameter is MRefl, then simplifying revealed a
+        -- reflexive coercion. Omit.
+        addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont
+        addCoerceM MRefl   cont = return cont
+        addCoerceM (MCo co) cont = addCoerce co cont
+
+        addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont
+        addCoerce co1 (CastIt co2 cont)  -- See Note [Optimising reflexivity]
+          | isReflexiveCo co' = return cont
+          | otherwise         = addCoerce co' cont
+          where
+            co' = mkTransCo co1 co2
+
+        addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
+          | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty
+          = {-#SCC "addCoerce-pushCoTyArg" #-}
+            do { tail' <- addCoerceM m_co' tail
+               ; return (cont { sc_arg_ty = arg_ty', sc_cont = tail' }) }
+
+        addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se
+                                      , sc_dup = dup, sc_cont = tail })
+          | Just (co1, m_co2) <- pushCoValArg co
+          , Pair _ new_ty <- coercionKind co1
+          , not (isTypeLevPoly new_ty)  -- Without this check, we get a lev-poly arg
+                                        -- See Note [Levity polymorphism invariants] in CoreSyn
+                                        -- test: typecheck/should_run/EtaExpandLevPoly
+          = {-#SCC "addCoerce-pushCoValArg" #-}
+            do { tail' <- addCoerceM m_co2 tail
+               ; if isReflCo co1
+                 then return (cont { sc_cont = tail' })
+                      -- Avoid simplifying if possible;
+                      -- See Note [Avoiding exponential behaviour]
+                 else do
+               { (dup', arg_se', arg') <- simplArg env dup arg_se arg
+                    -- When we build the ApplyTo we can't mix the OutCoercion
+                    -- 'co' with the InExpr 'arg', so we simplify
+                    -- to make it all consistent.  It's a bit messy.
+                    -- But it isn't a common case.
+                    -- Example of use: Trac #995
+               ; return (ApplyToVal { sc_arg  = mkCast arg' co1
+                                    , sc_env  = arg_se'
+                                    , sc_dup  = dup'
+                                    , sc_cont = tail' }) } }
+
+        addCoerce co cont
+          | isReflexiveCo co = return cont  -- Having this at the end makes a huge
+                                            -- difference in T12227, for some reason
+                                            -- See Note [Optimising reflexivity]
+          | otherwise        = return (CastIt co cont)
+
+simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr
+         -> SimplM (DupFlag, StaticEnv, OutExpr)
+simplArg env dup_flag arg_env arg
+  | isSimplified dup_flag
+  = return (dup_flag, arg_env, arg)
+  | otherwise
+  = do { arg' <- simplExpr (arg_env `setInScopeFromE` env) arg
+       ; return (Simplified, zapSubstEnv arg_env, arg') }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Lambdas}
+*                                                                      *
+************************************************************************
+-}
+
+simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
+         -> SimplM (SimplFloats, OutExpr)
+
+simplLam env [] body cont
+  = simplExprF env body cont
+
+simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
+  = do { tick (BetaReduction bndr)
+       ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont }
+
+simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se
+                                           , sc_cont = cont, sc_dup = dup })
+  | isSimplified dup  -- Don't re-simplify if we've simplified it once
+                      -- See Note [Avoiding exponential behaviour]
+  = do  { tick (BetaReduction bndr)
+        ; (floats1, env') <- simplNonRecX env zapped_bndr arg
+        ; (floats2, expr') <- simplLam env' bndrs body cont
+        ; return (floats1 `addFloats` floats2, expr') }
+
+  | otherwise
+  = do  { tick (BetaReduction bndr)
+        ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont }
+  where
+    zapped_bndr  -- See Note [Zap unfolding when beta-reducing]
+      | isId bndr = zapStableUnfolding bndr
+      | otherwise = bndr
+
+      -- Discard a non-counting tick on a lambda.  This may change the
+      -- cost attribution slightly (moving the allocation of the
+      -- lambda elsewhere), but we don't care: optimisation changes
+      -- cost attribution all the time.
+simplLam env bndrs body (TickIt tickish cont)
+  | not (tickishCounts tickish)
+  = simplLam env bndrs body cont
+
+        -- Not enough args, so there are real lambdas left to put in the result
+simplLam env bndrs body cont
+  = do  { (env', bndrs') <- simplLamBndrs env bndrs
+        ; body' <- simplExpr env' body
+        ; new_lam <- mkLam env bndrs' body' cont
+        ; rebuild env' new_lam cont }
+
+-------------
+simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
+-- Used for lambda binders.  These sometimes have unfoldings added by
+-- the worker/wrapper pass that must be preserved, because they can't
+-- be reconstructed from context.  For example:
+--      f x = case x of (a,b) -> fw a b x
+--      fw a b x{=(a,b)} = ...
+-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.
+simplLamBndr env bndr
+  | isId bndr && isFragileUnfolding old_unf   -- Special case
+  = do { (env1, bndr1) <- simplBinder env bndr
+       ; unf'          <- simplStableUnfolding env1 NotTopLevel Nothing bndr
+                                               old_unf (idType bndr1)
+       ; let bndr2 = bndr1 `setIdUnfolding` unf'
+       ; return (modifyInScope env1 bndr2, bndr2) }
+
+  | otherwise
+  = simplBinder env bndr                -- Normal case
+  where
+    old_unf = idUnfolding bndr
+
+simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])
+simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
+
+------------------
+simplNonRecE :: SimplEnv
+             -> InId                    -- The binder, always an Id
+                                        -- Never a join point
+             -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)
+             -> ([InBndr], InExpr)      -- Body of the let/lambda
+                                        --      \xs.e
+             -> SimplCont
+             -> SimplM (SimplFloats, OutExpr)
+
+-- simplNonRecE is used for
+--  * non-top-level non-recursive non-join-point lets in expressions
+--  * beta reduction
+--
+-- simplNonRec env b (rhs, rhs_se) (bs, body) k
+--   = let env in
+--     cont< let b = rhs_se(rhs) in \bs.body >
+--
+-- It deals with strict bindings, via the StrictBind continuation,
+-- which may abort the whole process
+--
+-- Precondition: rhs satisfies the let/app invariant
+--               Note [CoreSyn let/app invariant] in CoreSyn
+--
+-- The "body" of the binding comes as a pair of ([InId],InExpr)
+-- representing a lambda; so we recurse back to simplLam
+-- Why?  Because of the binder-occ-info-zapping done before
+--       the call to simplLam in simplExprF (Lam ...)
+
+simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
+  | ASSERT( isId bndr && not (isJoinId bndr) ) True
+  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se
+  = do { tick (PreInlineUnconditionally bndr)
+       ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
+         simplLam env' bndrs body cont }
+
+  -- Deal with strict bindings
+  | isStrictId bndr          -- Includes coercions
+  , sm_case_case (getMode env)
+  = simplExprF (rhs_se `setInScopeFromE` env) rhs
+               (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body
+                           , sc_env = env, sc_cont = cont, sc_dup = NoDup })
+
+  -- Deal with lazy bindings
+  | otherwise
+  = ASSERT( not (isTyVar bndr) )
+    do { (env1, bndr1) <- simplNonRecBndr env bndr
+       ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing
+       ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
+       ; (floats2, expr') <- simplLam env3 bndrs body cont
+       ; return (floats1 `addFloats` floats2, expr') }
+
+------------------
+simplRecE :: SimplEnv
+          -> [(InId, InExpr)]
+          -> InExpr
+          -> SimplCont
+          -> SimplM (SimplFloats, OutExpr)
+
+-- simplRecE is used for
+--  * non-top-level recursive lets in expressions
+simplRecE env pairs body cont
+  = do  { let bndrs = map fst pairs
+        ; MASSERT(all (not . isJoinId) bndrs)
+        ; env1 <- simplRecBndrs env bndrs
+                -- NB: bndrs' don't have unfoldings or rules
+                -- We add them as we go down
+        ; (floats1, env2) <- simplRecBind env1 NotTopLevel Nothing pairs
+        ; (floats2, expr') <- simplExprF env2 body cont
+        ; return (floats1 `addFloats` floats2, expr') }
+
+{- Note [Avoiding exponential behaviour]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+One way in which we can get exponential behaviour is if we simplify a
+big expression, and the re-simplify it -- and then this happens in a
+deeply-nested way.  So we must be jolly careful about re-simplifying
+an expression.  That is why completeNonRecX does not try
+preInlineUnconditionally.
+
+Example:
+  f BIG, where f has a RULE
+Then
+ * We simplify BIG before trying the rule; but the rule does not fire
+ * We inline f = \x. x True
+ * So if we did preInlineUnconditionally we'd re-simplify (BIG True)
+
+However, if BIG has /not/ already been simplified, we'd /like/ to
+simplify BIG True; maybe good things happen.  That is why
+
+* simplLam has
+    - a case for (isSimplified dup), which goes via simplNonRecX, and
+    - a case for the un-simplified case, which goes via simplNonRecE
+
+* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,
+  in at least two places
+    - In simplCast/addCoerce, where we check for isReflCo
+    - In rebuildCall we avoid simplifying arguments before we have to
+      (see Note [Trying rewrite rules])
+
+
+Note [Zap unfolding when beta-reducing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Lambda-bound variables can have stable unfoldings, such as
+   $j = \x. \b{Unf=Just x}. e
+See Note [Case binders and join points] below; the unfolding for lets
+us optimise e better.  However when we beta-reduce it we want to
+revert to using the actual value, otherwise we can end up in the
+stupid situation of
+          let x = blah in
+          let b{Unf=Just x} = y
+          in ...b...
+Here it'd be far better to drop the unfolding and use the actual RHS.
+
+************************************************************************
+*                                                                      *
+                     Join points
+*                                                                      *
+********************************************************************* -}
+
+{- Note [Rules and unfolding for join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+   simplExpr (join j x = rhs                         ) cont
+             (      {- RULE j (p:ps) = blah -}       )
+             (      {- StableUnfolding j = blah -}   )
+             (in blah                                )
+
+Then we will push 'cont' into the rhs of 'j'.  But we should *also* push
+'cont' into the RHS of
+  * Any RULEs for j, e.g. generated by SpecConstr
+  * Any stable unfolding for j, e.g. the result of an INLINE pragma
+
+Simplifying rules and stable-unfoldings happens a bit after
+simplifying the right-hand side, so we remember whether or not it
+is a join point, and what 'cont' is, in a value of type MaybeJoinCont
+
+Trac #13900 wsa caused by forgetting to push 'cont' into the RHS
+of a SpecConstr-generated RULE for a join point.
+-}
+
+type MaybeJoinCont = Maybe SimplCont
+  -- Nothing => Not a join point
+  -- Just k  => This is a join binding with continuation k
+  -- See Note [Rules and unfolding for join points]
+
+simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr
+                     -> InExpr -> SimplCont
+                     -> SimplM (SimplFloats, OutExpr)
+simplNonRecJoinPoint env bndr rhs body cont
+  | ASSERT( isJoinId bndr ) True
+  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env
+  = do { tick (PreInlineUnconditionally bndr)
+       ; simplExprF env' body cont }
+
+   | otherwise
+   = wrapJoinCont env cont $ \ env cont ->
+     do { -- We push join_cont into the join RHS and the body;
+          -- and wrap wrap_cont around the whole thing
+        ; let res_ty = contResultType cont
+        ; (env1, bndr1)    <- simplNonRecJoinBndr env res_ty bndr
+        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (Just cont)
+        ; (floats1, env3)  <- simplJoinBind env2 cont bndr bndr2 rhs env
+        ; (floats2, body') <- simplExprF env3 body cont
+        ; return (floats1 `addFloats` floats2, body') }
+
+
+------------------
+simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]
+                  -> InExpr -> SimplCont
+                  -> SimplM (SimplFloats, OutExpr)
+simplRecJoinPoint env pairs body cont
+  = wrapJoinCont env cont $ \ env cont ->
+    do { let bndrs = map fst pairs
+             res_ty = contResultType cont
+       ; env1 <- simplRecJoinBndrs env res_ty bndrs
+               -- NB: bndrs' don't have unfoldings or rules
+               -- We add them as we go down
+       ; (floats1, env2)  <- simplRecBind env1 NotTopLevel (Just cont) pairs
+       ; (floats2, body') <- simplExprF env2 body cont
+       ; return (floats1 `addFloats` floats2, body') }
+
+--------------------
+wrapJoinCont :: SimplEnv -> SimplCont
+             -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))
+             -> SimplM (SimplFloats, OutExpr)
+-- Deal with making the continuation duplicable if necessary,
+-- and with the no-case-of-case situation.
+wrapJoinCont env cont thing_inside
+  | contIsStop cont        -- Common case; no need for fancy footwork
+  = thing_inside env cont
+
+  | not (sm_case_case (getMode env))
+    -- See Note [Join points wih -fno-case-of-case]
+  = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))
+       ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1
+       ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont
+       ; return (floats2 `addFloats` floats3, expr3) }
+
+  | otherwise
+    -- Normal case; see Note [Join points and case-of-case]
+  = do { (floats1, cont')  <- mkDupableCont env cont
+       ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'
+       ; return (floats1 `addFloats` floats2, result) }
+
+
+--------------------
+trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont
+-- Drop outer context from join point invocation (jump)
+-- See Note [Join points and case-of-case]
+
+trimJoinCont _ Nothing cont
+  = cont -- Not a jump
+trimJoinCont var (Just arity) cont
+  = trim arity cont
+  where
+    trim 0 cont@(Stop {})
+      = cont
+    trim 0 cont
+      = mkBoringStop (contResultType cont)
+    trim n cont@(ApplyToVal { sc_cont = k })
+      = cont { sc_cont = trim (n-1) k }
+    trim n cont@(ApplyToTy { sc_cont = k })
+      = cont { sc_cont = trim (n-1) k } -- join arity counts types!
+    trim _ cont
+      = pprPanic "completeCall" $ ppr var $$ ppr cont
+
+
+{- Note [Join points and case-of-case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we perform the case-of-case transform (or otherwise push continuations
+inward), we want to treat join points specially. Since they're always
+tail-called and we want to maintain this invariant, we can do this (for any
+evaluation context E):
+
+  E[join j = e
+    in case ... of
+         A -> jump j 1
+         B -> jump j 2
+         C -> f 3]
+
+    -->
+
+  join j = E[e]
+  in case ... of
+       A -> jump j 1
+       B -> jump j 2
+       C -> E[f 3]
+
+As is evident from the example, there are two components to this behavior:
+
+  1. When entering the RHS of a join point, copy the context inside.
+  2. When a join point is invoked, discard the outer context.
+
+We need to be very careful here to remain consistent---neither part is
+optional!
+
+We need do make the continuation E duplicable (since we are duplicating it)
+with mkDuableCont.
+
+
+Note [Join points wih -fno-case-of-case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Supose case-of-case is switched off, and we are simplifying
+
+    case (join j x = <j-rhs> in
+          case y of
+             A -> j 1
+             B -> j 2
+             C -> e) of <outer-alts>
+
+Usually, we'd push the outer continuation (case . of <outer-alts>) into
+both the RHS and the body of the join point j.  But since we aren't doing
+case-of-case we may then end up with this totally bogus result
+
+    join x = case <j-rhs> of <outer-alts> in
+    case (case y of
+             A -> j 1
+             B -> j 2
+             C -> e) of <outer-alts>
+
+This would be OK in the language of the paper, but not in GHC: j is no longer
+a join point.  We can only do the "push contination into the RHS of the
+join point j" if we also push the contination right down to the /jumps/ to
+j, so that it can evaporate there.  If we are doing case-of-case, we'll get to
+
+    join x = case <j-rhs> of <outer-alts> in
+    case y of
+      A -> j 1
+      B -> j 2
+      C -> case e of <outer-alts>
+
+which is great.
+
+Bottom line: if case-of-case is off, we must stop pushing the continuation
+inwards altogether at any join point.  Instead simplify the (join ... in ...)
+with a Stop continuation, and wrap the original continuation around the
+outside.  Surprisingly tricky!
+
+
+************************************************************************
+*                                                                      *
+                     Variables
+*                                                                      *
+************************************************************************
+-}
+
+simplVar :: SimplEnv -> InVar -> SimplM OutExpr
+-- Look up an InVar in the environment
+simplVar env var
+  | isTyVar var = return (Type (substTyVar env var))
+  | isCoVar var = return (Coercion (substCoVar env var))
+  | otherwise
+  = case substId env var of
+        ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e
+        DoneId var1          -> return (Var var1)
+        DoneEx e _           -> return e
+
+simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)
+simplIdF env var cont
+  = case substId env var of
+      ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont
+                                -- Don't trim; haven't already simplified e,
+                                -- so the cont is not embodied in e
+
+      DoneId var1 -> completeCall env var1 (trimJoinCont var (isJoinId_maybe var1) cont)
+
+      DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trimJoinCont var mb_join cont)
+              -- Note [zapSubstEnv]
+              -- The template is already simplified, so don't re-substitute.
+              -- This is VITAL.  Consider
+              --      let x = e in
+              --      let y = \z -> ...x... in
+              --      \ x -> ...y...
+              -- We'll clone the inner \x, adding x->x' in the id_subst
+              -- Then when we inline y, we must *not* replace x by x' in
+              -- the inlined copy!!
+
+---------------------------------------------------------
+--      Dealing with a call site
+
+completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)
+completeCall env var cont
+  | Just expr <- callSiteInline dflags var active_unf
+                                lone_variable arg_infos interesting_cont
+  -- Inline the variable's RHS
+  = do { checkedTick (UnfoldingDone var)
+       ; dump_inline expr cont
+       ; simplExprF (zapSubstEnv env) expr cont }
+
+  | otherwise
+  -- Don't inline; instead rebuild the call
+  = do { rule_base <- getSimplRules
+       ; let info = mkArgInfo env var (getRules rule_base var)
+                              n_val_args call_cont
+       ; rebuildCall env info cont }
+
+  where
+    dflags = seDynFlags env
+    (lone_variable, arg_infos, call_cont) = contArgs cont
+    n_val_args       = length arg_infos
+    interesting_cont = interestingCallContext env call_cont
+    active_unf       = activeUnfolding (getMode env) var
+
+    dump_inline unfolding cont
+      | not (dopt Opt_D_dump_inlinings dflags) = return ()
+      | not (dopt Opt_D_verbose_core2core dflags)
+      = when (isExternalName (idName var)) $
+            liftIO $ printOutputForUser dflags alwaysQualify $
+                sep [text "Inlining done:", nest 4 (ppr var)]
+      | otherwise
+      = liftIO $ printOutputForUser dflags alwaysQualify $
+           sep [text "Inlining done: " <> ppr var,
+                nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),
+                              text "Cont:  " <+> ppr cont])]
+
+rebuildCall :: SimplEnv
+            -> ArgInfo
+            -> SimplCont
+            -> SimplM (SimplFloats, OutExpr)
+-- We decided not to inline, so
+--    - simplify the arguments
+--    - try rewrite rules
+--    - and rebuild
+
+---------- Bottoming applications --------------
+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont
+  -- When we run out of strictness args, it means
+  -- that the call is definitely bottom; see SimplUtils.mkArgInfo
+  -- Then we want to discard the entire strict continuation.  E.g.
+  --    * case (error "hello") of { ... }
+  --    * (error "Hello") arg
+  --    * f (error "Hello") where f is strict
+  --    etc
+  -- Then, especially in the first of these cases, we'd like to discard
+  -- the continuation, leaving just the bottoming expression.  But the
+  -- type might not be right, so we may have to add a coerce.
+  | not (contIsTrivial cont)     -- Only do this if there is a non-trivial
+                                 -- continuation to discard, else we do it
+                                 -- again and again!
+  = seqType cont_ty `seq`        -- See Note [Avoiding space leaks in OutType]
+    return (emptyFloats env, castBottomExpr res cont_ty)
+  where
+    res     = argInfoExpr fun rev_args
+    cont_ty = contResultType cont
+
+---------- Try rewrite RULES --------------
+-- See Note [Trying rewrite rules]
+rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args
+                              , ai_rules = Just (nr_wanted, rules) }) cont
+  | nr_wanted == 0 || no_more_args
+  , let info' = info { ai_rules = Nothing }
+  = -- We've accumulated a simplified call in <fun,rev_args>
+    -- so try rewrite rules; see Note [RULEs apply to simplified arguments]
+    -- See also Note [Rules for recursive functions]
+    do { mb_match <- tryRules env rules fun (reverse rev_args) cont
+       ; case mb_match of
+             Just (env', rhs, cont') -> simplExprF env' rhs cont'
+             Nothing                 -> rebuildCall env info' cont }
+  where
+    no_more_args = case cont of
+                      ApplyToTy  {} -> False
+                      ApplyToVal {} -> False
+                      _             -> True
+
+
+---------- Simplify applications and casts --------------
+rebuildCall env info (CastIt co cont)
+  = rebuildCall env (addCastTo info co) cont
+
+rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
+  = rebuildCall env (addTyArgTo info arg_ty) cont
+
+rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
+                              , ai_strs = str:strs, ai_discs = disc:discs })
+            (ApplyToVal { sc_arg = arg, sc_env = arg_se
+                        , sc_dup = dup_flag, sc_cont = cont })
+  | isSimplified dup_flag     -- See Note [Avoid redundant simplification]
+  = rebuildCall env (addValArgTo info' arg) cont
+
+  | str         -- Strict argument
+  , sm_case_case (getMode env)
+  = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
+    simplExprF (arg_se `setInScopeFromE` env) arg
+               (StrictArg { sc_fun = info', sc_cci = cci_strict
+                          , sc_dup = Simplified, sc_cont = cont })
+                -- Note [Shadowing]
+
+  | otherwise                           -- Lazy argument
+        -- DO NOT float anything outside, hence simplExprC
+        -- There is no benefit (unlike in a let-binding), and we'd
+        -- have to be very careful about bogus strictness through
+        -- floating a demanded let.
+  = do  { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg
+                             (mkLazyArgStop arg_ty cci_lazy)
+        ; rebuildCall env (addValArgTo info' arg') cont }
+  where
+    info'  = info { ai_strs = strs, ai_discs = discs }
+    arg_ty = funArgTy fun_ty
+
+    -- Use this for lazy arguments
+    cci_lazy | encl_rules = RuleArgCtxt
+             | disc > 0   = DiscArgCtxt  -- Be keener here
+             | otherwise  = BoringCtxt   -- Nothing interesting
+
+    -- ..and this for strict arguments
+    cci_strict | encl_rules = RuleArgCtxt
+               | disc > 0   = DiscArgCtxt
+               | otherwise  = RhsCtxt
+      -- Why RhsCtxt?  if we see f (g x) (h x), and f is strict, we
+      -- want to be a bit more eager to inline g, because it may
+      -- expose an eval (on x perhaps) that can be eliminated or
+      -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1
+      -- It's worth an 18% improvement in allocation for this
+      -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'
+
+---------- No further useful info, revert to generic rebuild ------------
+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont
+  = rebuild env (argInfoExpr fun rev_args) cont
+
+{- Note [Trying rewrite rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet
+simplified.  We want to simplify enough arguments to allow the rules
+to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone
+is sufficient.  Example: class ops
+   (+) dNumInt e2 e3
+If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the
+latter's strictness when simplifying e2, e3.  Moreover, suppose we have
+  RULE  f Int = \x. x True
+
+Then given (f Int e1) we rewrite to
+   (\x. x True) e1
+without simplifying e1.  Now we can inline x into its unique call site,
+and absorb the True into it all in the same pass.  If we simplified
+e1 first, we couldn't do that; see Note [Avoiding exponential behaviour].
+
+So we try to apply rules if either
+  (a) no_more_args: we've run out of argument that the rules can "see"
+  (b) nr_wanted: none of the rules wants any more arguments
+
+
+Note [RULES apply to simplified arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's very desirable to try RULES once the arguments have been simplified, because
+doing so ensures that rule cascades work in one pass.  Consider
+   {-# RULES g (h x) = k x
+             f (k x) = x #-}
+   ...f (g (h x))...
+Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If
+we match f's rules against the un-simplified RHS, it won't match.  This
+makes a particularly big difference when superclass selectors are involved:
+        op ($p1 ($p2 (df d)))
+We want all this to unravel in one sweep.
+
+Note [Avoid redundant simplification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because RULES apply to simplified arguments, there's a danger of repeatedly
+simplifying already-simplified arguments.  An important example is that of
+        (>>=) d e1 e2
+Here e1, e2 are simplified before the rule is applied, but don't really
+participate in the rule firing. So we mark them as Simplified to avoid
+re-simplifying them.
+
+Note [Shadowing]
+~~~~~~~~~~~~~~~~
+This part of the simplifier may break the no-shadowing invariant
+Consider
+        f (...(\a -> e)...) (case y of (a,b) -> e')
+where f is strict in its second arg
+If we simplify the innermost one first we get (...(\a -> e)...)
+Simplifying the second arg makes us float the case out, so we end up with
+        case y of (a,b) -> f (...(\a -> e)...) e'
+So the output does not have the no-shadowing invariant.  However, there is
+no danger of getting name-capture, because when the first arg was simplified
+we used an in-scope set that at least mentioned all the variables free in its
+static environment, and that is enough.
+
+We can't just do innermost first, or we'd end up with a dual problem:
+        case x of (a,b) -> f e (...(\a -> e')...)
+
+I spent hours trying to recover the no-shadowing invariant, but I just could
+not think of an elegant way to do it.  The simplifier is already knee-deep in
+continuations.  We have to keep the right in-scope set around; AND we have
+to get the effect that finding (error "foo") in a strict arg position will
+discard the entire application and replace it with (error "foo").  Getting
+all this at once is TOO HARD!
+
+
+************************************************************************
+*                                                                      *
+                Rewrite rules
+*                                                                      *
+************************************************************************
+-}
+
+tryRules :: SimplEnv -> [CoreRule]
+         -> Id -> [ArgSpec]
+         -> SimplCont
+         -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))
+
+tryRules env rules fn args call_cont
+  | null rules
+  = return Nothing
+
+{- Disabled until we fix #8326
+  | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]
+  , [_type_arg, val_arg] <- args
+  , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont
+  , isDeadBinder bndr
+  = do { let enum_to_tag :: CoreAlt -> CoreAlt
+                -- Takes   K -> e  into   tagK# -> e
+                -- where tagK# is the tag of constructor K
+             enum_to_tag (DataAlt con, [], rhs)
+               = ASSERT( isEnumerationTyCon (dataConTyCon con) )
+                (LitAlt tag, [], rhs)
+              where
+                tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG))
+             enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)
+
+             new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts
+             new_bndr = setIdType bndr intPrimTy
+                 -- The binder is dead, but should have the right type
+      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }
+-}
+
+  | Just (rule, rule_rhs) <- lookupRule dflags (getUnfoldingInRuleMatch env)
+                                        (activeRule (getMode env)) fn
+                                        (argInfoAppArgs args) rules
+  -- Fire a rule for the function
+  = do { checkedTick (RuleFired (ruleName rule))
+       ; let cont' = pushSimplifiedArgs zapped_env
+                                        (drop (ruleArity rule) args)
+                                        call_cont
+                     -- (ruleArity rule) says how
+                     -- many args the rule consumed
+
+             occ_anald_rhs = occurAnalyseExpr rule_rhs
+                 -- See Note [Occurrence-analyse after rule firing]
+       ; dump rule rule_rhs
+       ; return (Just (zapped_env, occ_anald_rhs, cont')) }
+            -- The occ_anald_rhs and cont' are all Out things
+            -- hence zapping the environment
+
+  | otherwise  -- No rule fires
+  = do { nodump  -- This ensures that an empty file is written
+       ; return Nothing }
+
+  where
+    dflags     = seDynFlags env
+    zapped_env = zapSubstEnv env  -- See Note [zapSubstEnv]
+
+    printRuleModule rule
+      = parens (maybe (text "BUILTIN")
+                      (pprModuleName . moduleName)
+                      (ruleModule rule))
+
+    dump rule rule_rhs
+      | dopt Opt_D_dump_rule_rewrites dflags
+      = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat
+          [ text "Rule:" <+> ftext (ruleName rule)
+          , text "Module:" <+>  printRuleModule rule
+          , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))
+          , text "After: " <+> pprCoreExpr rule_rhs
+          , text "Cont:  " <+> ppr call_cont ]
+
+      | dopt Opt_D_dump_rule_firings dflags
+      = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $
+          ftext (ruleName rule)
+            <+> printRuleModule rule
+
+      | otherwise
+      = return ()
+
+    nodump
+      | dopt Opt_D_dump_rule_rewrites dflags
+      = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_rewrites "" empty
+
+      | dopt Opt_D_dump_rule_firings dflags
+      = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_firings "" empty
+
+      | otherwise
+      = return ()
+
+    log_rule dflags flag hdr details
+      = liftIO . dumpSDoc dflags alwaysQualify flag "" $
+                   sep [text hdr, nest 4 details]
+
+trySeqRules :: SimplEnv
+            -> OutExpr -> InExpr   -- Scrutinee and RHS
+            -> SimplCont
+            -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))
+-- See Note [User-defined RULES for seq]
+trySeqRules in_env scrut rhs cont
+  = do { rule_base <- getSimplRules
+       ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont }
+  where
+    no_cast_scrut = drop_casts scrut
+    scrut_ty  = exprType no_cast_scrut
+    seq_id_ty = idType seqId
+    rhs_ty    = substTy in_env (exprType rhs)
+    out_args  = [ TyArg { as_arg_ty  = scrut_ty
+                        , as_hole_ty = seq_id_ty }
+                , TyArg { as_arg_ty  = rhs_ty
+                       , as_hole_ty  = piResultTy seq_id_ty scrut_ty }
+                , ValArg no_cast_scrut]
+    rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs
+                           , sc_env = in_env, sc_cont = cont }
+    -- Lazily evaluated, so we don't do most of this
+
+    drop_casts (Cast e _) = drop_casts e
+    drop_casts e          = e
+
+{- Note [User-defined RULES for seq]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given
+   case (scrut |> co) of _ -> rhs
+look for rules that match the expression
+   seq @t1 @t2 scrut
+where scrut :: t1
+      rhs   :: t2
+
+If you find a match, rewrite it, and apply to 'rhs'.
+
+Notice that we can simply drop casts on the fly here, which
+makes it more likely that a rule will match.
+
+See Note [User-defined RULES for seq] in MkId.
+
+Note [Occurrence-analyse after rule firing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+After firing a rule, we occurrence-analyse the instantiated RHS before
+simplifying it.  Usually this doesn't make much difference, but it can
+be huge.  Here's an example (simplCore/should_compile/T7785)
+
+  map f (map f (map f xs)
+
+= -- Use build/fold form of map, twice
+  map f (build (\cn. foldr (mapFB c f) n
+                           (build (\cn. foldr (mapFB c f) n xs))))
+
+= -- Apply fold/build rule
+  map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n))
+
+= -- Beta-reduce
+  -- Alas we have no occurrence-analysed, so we don't know
+  -- that c is used exactly once
+  map f (build (\cn. let c1 = mapFB c f in
+                     foldr (mapFB c1 f) n xs))
+
+= -- Use mapFB rule:   mapFB (mapFB c f) g = mapFB c (f.g)
+  -- We can do this because (mapFB c n) is a PAP and hence expandable
+  map f (build (\cn. let c1 = mapFB c n in
+                     foldr (mapFB c (f.f)) n x))
+
+This is not too bad.  But now do the same with the outer map, and
+we get another use of mapFB, and t can interact with /both/ remaining
+mapFB calls in the above expression.  This is stupid because actually
+that 'c1' binding is dead.  The outer map introduces another c2. If
+there is a deep stack of maps we get lots of dead bindings, and lots
+of redundant work as we repeatedly simplify the result of firing rules.
+
+The easy thing to do is simply to occurrence analyse the result of
+the rule firing.  Note that this occ-anals not only the RHS of the
+rule, but also the function arguments, which by now are OutExprs.
+E.g.
+      RULE f (g x) = x+1
+
+Call   f (g BIG)  -->   (\x. x+1) BIG
+
+The rule binders are lambda-bound and applied to the OutExpr arguments
+(here BIG) which lack all internal occurrence info.
+
+Is this inefficient?  Not really: we are about to walk over the result
+of the rule firing to simplify it, so occurrence analysis is at most
+a constant factor.
+
+Possible improvement: occ-anal the rules when putting them in the
+database; and in the simplifier just occ-anal the OutExpr arguments.
+But that's more complicated and the rule RHS is usually tiny; so I'm
+just doing the simple thing.
+
+Historical note: previously we did occ-anal the rules in Rule.hs,
+but failed to occ-anal the OutExpr arguments, which led to the
+nasty performance problem described above.
+
+
+Note [Optimising tagToEnum#]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have an enumeration data type:
+
+  data Foo = A | B | C
+
+Then we want to transform
+
+   case tagToEnum# x of   ==>    case x of
+     A -> e1                       DEFAULT -> e1
+     B -> e2                       1#      -> e2
+     C -> e3                       2#      -> e3
+
+thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT
+alternative we retain it (remember it comes first).  If not the case must
+be exhaustive, and we reflect that in the transformed version by adding
+a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.
+See #8317.
+
+Note [Rules for recursive functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might think that we shouldn't apply rules for a loop breaker:
+doing so might give rise to an infinite loop, because a RULE is
+rather like an extra equation for the function:
+     RULE:           f (g x) y = x+y
+     Eqn:            f a     y = a-y
+
+But it's too drastic to disable rules for loop breakers.
+Even the foldr/build rule would be disabled, because foldr
+is recursive, and hence a loop breaker:
+     foldr k z (build g) = g k z
+So it's up to the programmer: rules can cause divergence
+
+
+************************************************************************
+*                                                                      *
+                Rebuilding a case expression
+*                                                                      *
+************************************************************************
+
+Note [Case elimination]
+~~~~~~~~~~~~~~~~~~~~~~~
+The case-elimination transformation discards redundant case expressions.
+Start with a simple situation:
+
+        case x# of      ===>   let y# = x# in e
+          y# -> e
+
+(when x#, y# are of primitive type, of course).  We can't (in general)
+do this for algebraic cases, because we might turn bottom into
+non-bottom!
+
+The code in SimplUtils.prepareAlts has the effect of generalise this
+idea to look for a case where we're scrutinising a variable, and we
+know that only the default case can match.  For example:
+
+        case x of
+          0#      -> ...
+          DEFAULT -> ...(case x of
+                         0#      -> ...
+                         DEFAULT -> ...) ...
+
+Here the inner case is first trimmed to have only one alternative, the
+DEFAULT, after which it's an instance of the previous case.  This
+really only shows up in eliminating error-checking code.
+
+Note that SimplUtils.mkCase combines identical RHSs.  So
+
+        case e of       ===> case e of DEFAULT -> r
+           True  -> r
+           False -> r
+
+Now again the case may be elminated by the CaseElim transformation.
+This includes things like (==# a# b#)::Bool so that we simplify
+      case ==# a# b# of { True -> x; False -> x }
+to just
+      x
+This particular example shows up in default methods for
+comparison operations (e.g. in (>=) for Int.Int32)
+
+Note [Case to let transformation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a case over a lifted type has a single alternative, and is being
+used as a strict 'let' (all isDeadBinder bndrs), we may want to do
+this transformation:
+
+    case e of r       ===>   let r = e in ...r...
+      _ -> ...r...
+
+We treat the unlifted and lifted cases separately:
+
+* Unlifted case: 'e' satisfies exprOkForSpeculation
+  (ok-for-spec is needed to satisfy the let/app invariant).
+  This turns     case a +# b of r -> ...r...
+  into           let r = a +# b in ...r...
+  and thence     .....(a +# b)....
+
+  However, if we have
+      case indexArray# a i of r -> ...r...
+  we might like to do the same, and inline the (indexArray# a i).
+  But indexArray# is not okForSpeculation, so we don't build a let
+  in rebuildCase (lest it get floated *out*), so the inlining doesn't
+  happen either.  Annoying.
+
+* Lifted case: we need to be sure that the expression is already
+  evaluated (exprIsHNF).  If it's not already evaluated
+      - we risk losing exceptions, divergence or
+        user-specified thunk-forcing
+      - even if 'e' is guaranteed to converge, we don't want to
+        create a thunk (call by need) instead of evaluating it
+        right away (call by value)
+
+  However, we can turn the case into a /strict/ let if the 'r' is
+  used strictly in the body.  Then we won't lose divergence; and
+  we won't build a thunk because the let is strict.
+  See also Note [Case-to-let for strictly-used binders]
+
+  NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in MkCore.
+  We want to turn
+     case (absentError "foo") of r -> ...MkT r...
+  into
+     let r = absentError "foo" in ...MkT r...
+
+
+Note [Case-to-let for strictly-used binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have this:
+   case <scrut> of r { _ -> ..r.. }
+
+where 'r' is used strictly in (..r..), we can safely transform to
+   let r = <scrut> in ...r...
+
+This is a Good Thing, because 'r' might be dead (if the body just
+calls error), or might be used just once (in which case it can be
+inlined); or we might be able to float the let-binding up or down.
+E.g. Trac #15631 has an example.
+
+Note that this can change the error behaviour.  For example, we might
+transform
+    case x of { _ -> error "bad" }
+    --> error "bad"
+which is might be puzzling if 'x' currently lambda-bound, but later gets
+let-bound to (error "good").
+
+Nevertheless, the paper "A semantics for imprecise exceptions" allows
+this transformation. If you want to fix the evaluation order, use
+'pseq'.  See Trac #8900 for an example where the loss of this
+transformation bit us in practice.
+
+See also Note [Empty case alternatives] in CoreSyn.
+
+Historical notes
+
+There have been various earlier versions of this patch:
+
+* By Sept 18 the code looked like this:
+     || scrut_is_demanded_var scrut
+
+    scrut_is_demanded_var :: CoreExpr -> Bool
+    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s
+    scrut_is_demanded_var (Var _)    = isStrictDmd (idDemandInfo case_bndr)
+    scrut_is_demanded_var _          = False
+
+  This only fired if the scrutinee was a /variable/, which seems
+  an unnecessary restriction. So in Trac #15631 I relaxed it to allow
+  arbitrary scrutinees.  Less code, less to explain -- but the change
+  had 0.00% effect on nofib.
+
+* Previously, in Jan 13 the code looked like this:
+     || case_bndr_evald_next rhs
+
+    case_bndr_evald_next :: CoreExpr -> Bool
+      -- See Note [Case binder next]
+    case_bndr_evald_next (Var v)         = v == case_bndr
+    case_bndr_evald_next (Cast e _)      = case_bndr_evald_next e
+    case_bndr_evald_next (App e _)       = case_bndr_evald_next e
+    case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e
+    case_bndr_evald_next _               = False
+
+  This patch was part of fixing Trac #7542. See also
+  Note [Eta reduction of an eval'd function] in CoreUtils.)
+
+
+Further notes about case elimination
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider:       test :: Integer -> IO ()
+                test = print
+
+Turns out that this compiles to:
+    Print.test
+      = \ eta :: Integer
+          eta1 :: Void# ->
+          case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->
+          case hPutStr stdout
+                 (PrelNum.jtos eta ($w[] @ Char))
+                 eta1
+          of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}
+
+Notice the strange '<' which has no effect at all. This is a funny one.
+It started like this:
+
+f x y = if x < 0 then jtos x
+          else if y==0 then "" else jtos x
+
+At a particular call site we have (f v 1).  So we inline to get
+
+        if v < 0 then jtos x
+        else if 1==0 then "" else jtos x
+
+Now simplify the 1==0 conditional:
+
+        if v<0 then jtos v else jtos v
+
+Now common-up the two branches of the case:
+
+        case (v<0) of DEFAULT -> jtos v
+
+Why don't we drop the case?  Because it's strict in v.  It's technically
+wrong to drop even unnecessary evaluations, and in practice they
+may be a result of 'seq' so we *definitely* don't want to drop those.
+I don't really know how to improve this situation.
+-}
+
+---------------------------------------------------------
+--      Eliminate the case if possible
+
+rebuildCase, reallyRebuildCase
+   :: SimplEnv
+   -> OutExpr          -- Scrutinee
+   -> InId             -- Case binder
+   -> [InAlt]          -- Alternatives (inceasing order)
+   -> SimplCont
+   -> SimplM (SimplFloats, OutExpr)
+
+--------------------------------------------------
+--      1. Eliminate the case if there's a known constructor
+--------------------------------------------------
+
+rebuildCase env scrut case_bndr alts cont
+  | Lit lit <- scrut    -- No need for same treatment as constructors
+                        -- because literals are inlined more vigorously
+  , not (litIsLifted lit)
+  = do  { tick (KnownBranch case_bndr)
+        ; case findAlt (LitAlt lit) alts of
+            Nothing           -> missingAlt env case_bndr alts cont
+            Just (_, bs, rhs) -> simple_rhs bs rhs }
+
+  | Just (con, ty_args, other_args) <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut
+        -- Works when the scrutinee is a variable with a known unfolding
+        -- as well as when it's an explicit constructor application
+  = do  { tick (KnownBranch case_bndr)
+        ; case findAlt (DataAlt con) alts of
+            Nothing  -> missingAlt env case_bndr alts cont
+            Just (DEFAULT, bs, rhs) -> simple_rhs bs rhs
+            Just (_, bs, rhs)       -> knownCon env scrut con ty_args other_args
+                                                case_bndr bs rhs cont
+        }
+  where
+    simple_rhs bs rhs = ASSERT( null bs )
+                        do { (floats1, env') <- simplNonRecX env case_bndr scrut
+                               -- scrut is a constructor application,
+                               -- hence satisfies let/app invariant
+                           ; (floats2, expr') <- simplExprF env' rhs cont
+                           ; return (floats1 `addFloats` floats2, expr') }
+
+
+--------------------------------------------------
+--      2. Eliminate the case if scrutinee is evaluated
+--------------------------------------------------
+
+rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
+  -- See if we can get rid of the case altogether
+  -- See Note [Case elimination]
+  -- mkCase made sure that if all the alternatives are equal,
+  -- then there is now only one (DEFAULT) rhs
+
+  -- 2a.  Dropping the case altogether, if
+  --      a) it binds nothing (so it's really just a 'seq')
+  --      b) evaluating the scrutinee has no side effects
+  | is_plain_seq
+  , exprOkForSideEffects scrut
+          -- The entire case is dead, so we can drop it
+          -- if the scrutinee converges without having imperative
+          -- side effects or raising a Haskell exception
+          -- See Note [PrimOp can_fail and has_side_effects] in PrimOp
+   = simplExprF env rhs cont
+
+  -- 2b.  Turn the case into a let, if
+  --      a) it binds only the case-binder
+  --      b) unlifted case: the scrutinee is ok-for-speculation
+  --           lifted case: the scrutinee is in HNF (or will later be demanded)
+  -- See Note [Case to let transformation]
+  | all_dead_bndrs
+  , doCaseToLet scrut case_bndr
+  = do { tick (CaseElim case_bndr)
+       ; (floats1, env') <- simplNonRecX env case_bndr scrut
+       ; (floats2, expr') <- simplExprF env' rhs cont
+       ; return (floats1 `addFloats` floats2, expr') }
+
+  -- 2c. Try the seq rules if
+  --     a) it binds only the case binder
+  --     b) a rule for seq applies
+  -- See Note [User-defined RULES for seq] in MkId
+  | is_plain_seq
+  = do { mb_rule <- trySeqRules env scrut rhs cont
+       ; case mb_rule of
+           Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'
+           Nothing                      -> reallyRebuildCase env scrut case_bndr alts cont }
+  where
+    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]
+    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect
+
+rebuildCase env scrut case_bndr alts cont
+  = reallyRebuildCase env scrut case_bndr alts cont
+
+
+doCaseToLet :: OutExpr          -- Scrutinee
+            -> InId             -- Case binder
+            -> Bool
+-- The situation is         case scrut of b { DEFAULT -> body }
+-- Can we transform thus?   let { b = scrut } in body
+doCaseToLet scrut case_bndr
+  | isTyCoVar case_bndr    -- Respect CoreSyn
+  = isTyCoArg scrut        -- Note [CoreSyn type and coercion invariant]
+
+  | isUnliftedType (idType case_bndr)
+  = exprOkForSpeculation scrut
+
+  | otherwise  -- Scrut has a lifted type
+  = exprIsHNF scrut
+    || isStrictDmd (idDemandInfo case_bndr)
+    -- See Note [Case-to-let for strictly-used binders]
+
+--------------------------------------------------
+--      3. Catch-all case
+--------------------------------------------------
+
+reallyRebuildCase env scrut case_bndr alts cont
+  | not (sm_case_case (getMode env))
+  = do { case_expr <- simplAlts env scrut case_bndr alts
+                                (mkBoringStop (contHoleType cont))
+       ; rebuild env case_expr cont }
+
+  | otherwise
+  = do { (floats, cont') <- mkDupableCaseCont env alts cont
+       ; case_expr <- simplAlts (env `setInScopeFromF` floats)
+                                scrut case_bndr alts cont'
+       ; return (floats, case_expr) }
+
+{-
+simplCaseBinder checks whether the scrutinee is a variable, v.  If so,
+try to eliminate uses of v in the RHSs in favour of case_bndr; that
+way, there's a chance that v will now only be used once, and hence
+inlined.
+
+Historical note: we use to do the "case binder swap" in the Simplifier
+so there were additional complications if the scrutinee was a variable.
+Now the binder-swap stuff is done in the occurrence analyser; see
+OccurAnal Note [Binder swap].
+
+Note [knownCon occ info]
+~~~~~~~~~~~~~~~~~~~~~~~~
+If the case binder is not dead, then neither are the pattern bound
+variables:
+        case <any> of x { (a,b) ->
+        case x of { (p,q) -> p } }
+Here (a,b) both look dead, but come alive after the inner case is eliminated.
+The point is that we bring into the envt a binding
+        let x = (a,b)
+after the outer case, and that makes (a,b) alive.  At least we do unless
+the case binder is guaranteed dead.
+
+Note [Case alternative occ info]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we are simply reconstructing a case (the common case), we always
+zap the occurrence info on the binders in the alternatives.  Even
+if the case binder is dead, the scrutinee is usually a variable, and *that*
+can bring the case-alternative binders back to life.
+See Note [Add unfolding for scrutinee]
+
+Note [Improving seq]
+~~~~~~~~~~~~~~~~~~~
+Consider
+        type family F :: * -> *
+        type instance F Int = Int
+
+We'd like to transform
+        case e of (x :: F Int) { DEFAULT -> rhs }
+===>
+        case e `cast` co of (x'::Int)
+           I# x# -> let x = x' `cast` sym co
+                    in rhs
+
+so that 'rhs' can take advantage of the form of x'.  Notice that Note
+[Case of cast] (in OccurAnal) may then apply to the result.
+
+We'd also like to eliminate empty types (Trac #13468). So if
+
+    data Void
+    type instance F Bool = Void
+
+then we'd like to transform
+        case (x :: F Bool) of { _ -> error "urk" }
+===>
+        case (x |> co) of (x' :: Void) of {}
+
+Nota Bene: we used to have a built-in rule for 'seq' that dropped
+casts, so that
+    case (x |> co) of { _ -> blah }
+dropped the cast; in order to improve the chances of trySeqRules
+firing.  But that works in the /opposite/ direction to Note [Improving
+seq] so there's a danger of flip/flopping.  Better to make trySeqRules
+insensitive to the cast, which is now is.
+
+The need for [Improving seq] showed up in Roman's experiments.  Example:
+  foo :: F Int -> Int -> Int
+  foo t n = t `seq` bar n
+     where
+       bar 0 = 0
+       bar n = bar (n - case t of TI i -> i)
+Here we'd like to avoid repeated evaluating t inside the loop, by
+taking advantage of the `seq`.
+
+At one point I did transformation in LiberateCase, but it's more
+robust here.  (Otherwise, there's a danger that we'll simply drop the
+'seq' altogether, before LiberateCase gets to see it.)
+-}
+
+simplAlts :: SimplEnv
+          -> OutExpr         -- Scrutinee
+          -> InId            -- Case binder
+          -> [InAlt]         -- Non-empty
+          -> SimplCont
+          -> SimplM OutExpr  -- Returns the complete simplified case expression
+
+simplAlts env0 scrut case_bndr alts cont'
+  = do  { traceSmpl "simplAlts" (vcat [ ppr case_bndr
+                                      , text "cont':" <+> ppr cont'
+                                      , text "in_scope" <+> ppr (seInScope env0) ])
+        ; (env1, case_bndr1) <- simplBinder env0 case_bndr
+        ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding
+              env2       = modifyInScope env1 case_bndr2
+              -- See Note [Case binder evaluated-ness]
+
+        ; fam_envs <- getFamEnvs
+        ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut
+                                                       case_bndr case_bndr2 alts
+
+        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
+          -- NB: it's possible that the returned in_alts is empty: this is handled
+          -- by the caller (rebuildCase) in the missingAlt function
+
+        ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts
+        ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $
+
+        ; let alts_ty' = contResultType cont'
+        -- See Note [Avoiding space leaks in OutType]
+        ; seqType alts_ty' `seq`
+          mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' }
+
+
+------------------------------------
+improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
+           -> OutExpr -> InId -> OutId -> [InAlt]
+           -> SimplM (SimplEnv, OutExpr, OutId)
+-- Note [Improving seq]
+improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
+  | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)
+  = do { case_bndr2 <- newId (fsLit "nt") ty2
+        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing
+              env2 = extendIdSubst env case_bndr rhs
+        ; return (env2, scrut `Cast` co, case_bndr2) }
+
+improveSeq _ env scrut _ case_bndr1 _
+  = return (env, scrut, case_bndr1)
+
+
+------------------------------------
+simplAlt :: SimplEnv
+         -> Maybe OutExpr  -- The scrutinee
+         -> [AltCon]       -- These constructors can't be present when
+                           -- matching the DEFAULT alternative
+         -> OutId          -- The case binder
+         -> SimplCont
+         -> InAlt
+         -> SimplM OutAlt
+
+simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)
+  = ASSERT( null bndrs )
+    do  { let env' = addBinderUnfolding env case_bndr'
+                                        (mkOtherCon imposs_deflt_cons)
+                -- Record the constructors that the case-binder *can't* be.
+        ; rhs' <- simplExprC env' rhs cont'
+        ; return (DEFAULT, [], rhs') }
+
+simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs)
+  = ASSERT( null bndrs )
+    do  { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)
+        ; rhs' <- simplExprC env' rhs cont'
+        ; return (LitAlt lit, [], rhs') }
+
+simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)
+  = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]
+          let vs_with_evals = addEvals scrut' con vs
+        ; (env', vs') <- simplLamBndrs env vs_with_evals
+
+                -- Bind the case-binder to (con args)
+        ; let inst_tys' = tyConAppArgs (idType case_bndr')
+              con_app :: OutExpr
+              con_app   = mkConApp2 con inst_tys' vs'
+
+        ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app
+        ; rhs' <- simplExprC env'' rhs cont'
+        ; return (DataAlt con, vs', rhs') }
+
+{- Note [Adding evaluatedness info to pattern-bound variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+addEvals records the evaluated-ness of the bound variables of
+a case pattern.  This is *important*.  Consider
+
+     data T = T !Int !Int
+
+     case x of { T a b -> T (a+1) b }
+
+We really must record that b is already evaluated so that we don't
+go and re-evaluate it when constructing the result.
+See Note [Data-con worker strictness] in MkId.hs
+
+NB: simplLamBinders preserves this eval info
+
+In addition to handling data constructor fields with !s, addEvals
+also records the fact that the result of seq# is always in WHNF.
+See Note [seq# magic] in PrelRules.  Example (Trac #15226):
+
+  case seq# v s of
+    (# s', v' #) -> E
+
+we want the compiler to be aware that v' is in WHNF in E.
+
+Open problem: we don't record that v itself is in WHNF (and we can't
+do it here).  The right thing is to do some kind of binder-swap;
+see Trac #15226 for discussion.
+-}
+
+addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]
+-- See Note [Adding evaluatedness info to pattern-bound variables]
+addEvals scrut con vs
+  -- Deal with seq# applications
+  | Just scr <- scrut
+  , isUnboxedTupleCon con
+  , [s,x] <- vs
+    -- Use stripNArgs rather than collectArgsTicks to avoid building
+    -- a list of arguments only to throw it away immediately.
+  , Just (Var f) <- stripNArgs 4 scr
+  , Just SeqOp <- isPrimOpId_maybe f
+  , let x' = zapIdOccInfoAndSetEvald MarkedStrict x
+  = [s, x']
+
+  -- Deal with banged datacon fields
+addEvals _scrut con vs = go vs the_strs
+    where
+      the_strs = dataConRepStrictness con
+
+      go [] [] = []
+      go (v:vs') strs | isTyVar v = v : go vs' strs
+      go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs
+      go _ _ = pprPanic "Simplify.addEvals"
+                (ppr con $$
+                 ppr vs  $$
+                 ppr_with_length (map strdisp the_strs) $$
+                 ppr_with_length (dataConRepArgTys con) $$
+                 ppr_with_length (dataConRepStrictness con))
+        where
+          ppr_with_length list
+            = ppr list <+> parens (text "length =" <+> ppr (length list))
+          strdisp MarkedStrict = "MarkedStrict"
+          strdisp NotMarkedStrict = "NotMarkedStrict"
+
+zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id
+zapIdOccInfoAndSetEvald str v =
+  setCaseBndrEvald str $ -- Add eval'dness info
+  zapIdOccInfo v         -- And kill occ info;
+                         -- see Note [Case alternative occ info]
+
+addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv
+addAltUnfoldings env scrut case_bndr con_app
+  = do { let con_app_unf = mk_simple_unf con_app
+             env1 = addBinderUnfolding env case_bndr con_app_unf
+
+             -- See Note [Add unfolding for scrutinee]
+             env2 = case scrut of
+                      Just (Var v)           -> addBinderUnfolding env1 v con_app_unf
+                      Just (Cast (Var v) co) -> addBinderUnfolding env1 v $
+                                                mk_simple_unf (Cast con_app (mkSymCo co))
+                      _                      -> env1
+
+       ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])
+       ; return env2 }
+  where
+    mk_simple_unf = mkSimpleUnfolding (seDynFlags env)
+
+addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv
+addBinderUnfolding env bndr unf
+  | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf
+  = WARN( not (eqType (idType bndr) (exprType tmpl)),
+          ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) )
+    modifyInScope env (bndr `setIdUnfolding` unf)
+
+  | otherwise
+  = modifyInScope env (bndr `setIdUnfolding` unf)
+
+zapBndrOccInfo :: Bool -> Id -> Id
+-- Consider  case e of b { (a,b) -> ... }
+-- Then if we bind b to (a,b) in "...", and b is not dead,
+-- then we must zap the deadness info on a,b
+zapBndrOccInfo keep_occ_info pat_id
+  | keep_occ_info = pat_id
+  | otherwise     = zapIdOccInfo pat_id
+
+{- Note [Case binder evaluated-ness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We pin on a (OtherCon []) unfolding to the case-binder of a Case,
+even though it'll be over-ridden in every case alternative with a more
+informative unfolding.  Why?  Because suppose a later, less clever, pass
+simply replaces all occurrences of the case binder with the binder itself;
+then Lint may complain about the let/app invariant.  Example
+    case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in ....
+                ; K       -> blah }
+
+The let/app invariant requires that y is evaluated in the call to
+reallyUnsafePtrEq#, which it is.  But we still want that to be true if we
+propagate binders to occurrences.
+
+This showed up in Trac #13027.
+
+Note [Add unfolding for scrutinee]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general it's unlikely that a variable scrutinee will appear
+in the case alternatives   case x of { ...x unlikely to appear... }
+because the binder-swap in OccAnal has got rid of all such occurrences
+See Note [Binder swap] in OccAnal.
+
+BUT it is still VERY IMPORTANT to add a suitable unfolding for a
+variable scrutinee, in simplAlt.  Here's why
+   case x of y
+     (a,b) -> case b of c
+                I# v -> ...(f y)...
+There is no occurrence of 'b' in the (...(f y)...).  But y gets
+the unfolding (a,b), and *that* mentions b.  If f has a RULE
+    RULE f (p, I# q) = ...
+we want that rule to match, so we must extend the in-scope env with a
+suitable unfolding for 'y'.  It's *essential* for rule matching; but
+it's also good for case-elimintation -- suppose that 'f' was inlined
+and did multi-level case analysis, then we'd solve it in one
+simplifier sweep instead of two.
+
+Exactly the same issue arises in SpecConstr;
+see Note [Add scrutinee to ValueEnv too] in SpecConstr
+
+HOWEVER, given
+  case x of y { Just a -> r1; Nothing -> r2 }
+we do not want to add the unfolding x -> y to 'x', which might seem cool,
+since 'y' itself has different unfoldings in r1 and r2.  Reason: if we
+did that, we'd have to zap y's deadness info and that is a very useful
+piece of information.
+
+So instead we add the unfolding x -> Just a, and x -> Nothing in the
+respective RHSs.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Known constructor}
+*                                                                      *
+************************************************************************
+
+We are a bit careful with occurrence info.  Here's an example
+
+        (\x* -> case x of (a*, b) -> f a) (h v, e)
+
+where the * means "occurs once".  This effectively becomes
+        case (h v, e) of (a*, b) -> f a)
+and then
+        let a* = h v; b = e in f a
+and then
+        f (h v)
+
+All this should happen in one sweep.
+-}
+
+knownCon :: SimplEnv
+         -> OutExpr                             -- The scrutinee
+         -> DataCon -> [OutType] -> [OutExpr]   -- The scrutinee (in pieces)
+         -> InId -> [InBndr] -> InExpr          -- The alternative
+         -> SimplCont
+         -> SimplM (SimplFloats, OutExpr)
+
+knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
+  = do  { (floats1, env1)  <- bind_args env bs dc_args
+        ; (floats2, env2) <- bind_case_bndr env1
+        ; (floats3, expr') <- simplExprF env2 rhs cont
+        ; return (floats1 `addFloats` floats2 `addFloats` floats3, expr') }
+  where
+    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId
+
+                  -- Ugh!
+    bind_args env' [] _  = return (emptyFloats env', env')
+
+    bind_args env' (b:bs') (Type ty : args)
+      = ASSERT( isTyVar b )
+        bind_args (extendTvSubst env' b ty) bs' args
+
+    bind_args env' (b:bs') (Coercion co : args)
+      = ASSERT( isCoVar b )
+        bind_args (extendCvSubst env' b co) bs' args
+
+    bind_args env' (b:bs') (arg : args)
+      = ASSERT( isId b )
+        do { let b' = zap_occ b
+             -- Note that the binder might be "dead", because it doesn't
+             -- occur in the RHS; and simplNonRecX may therefore discard
+             -- it via postInlineUnconditionally.
+             -- Nevertheless we must keep it if the case-binder is alive,
+             -- because it may be used in the con_app.  See Note [knownCon occ info]
+           ; (floats1, env2) <- simplNonRecX env' b' arg  -- arg satisfies let/app invariant
+           ; (floats2, env3)  <- bind_args env2 bs' args
+           ; return (floats1 `addFloats` floats2, env3) }
+
+    bind_args _ _ _ =
+      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$
+                             text "scrut:" <+> ppr scrut
+
+       -- It's useful to bind bndr to scrut, rather than to a fresh
+       -- binding      x = Con arg1 .. argn
+       -- because very often the scrut is a variable, so we avoid
+       -- creating, and then subsequently eliminating, a let-binding
+       -- BUT, if scrut is a not a variable, we must be careful
+       -- about duplicating the arg redexes; in that case, make
+       -- a new con-app from the args
+    bind_case_bndr env
+      | isDeadBinder bndr   = return (emptyFloats env, env)
+      | exprIsTrivial scrut = return (emptyFloats env
+                                     , extendIdSubst env bndr (DoneEx scrut Nothing))
+      | otherwise           = do { dc_args <- mapM (simplVar env) bs
+                                         -- dc_ty_args are aready OutTypes,
+                                         -- but bs are InBndrs
+                                 ; let con_app = Var (dataConWorkId dc)
+                                                 `mkTyApps` dc_ty_args
+                                                 `mkApps`   dc_args
+                                 ; simplNonRecX env bndr con_app }
+
+-------------------
+missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont
+           -> SimplM (SimplFloats, OutExpr)
+                -- This isn't strictly an error, although it is unusual.
+                -- It's possible that the simplifier might "see" that
+                -- an inner case has no accessible alternatives before
+                -- it "sees" that the entire branch of an outer case is
+                -- inaccessible.  So we simply put an error case here instead.
+missingAlt env case_bndr _ cont
+  = WARN( True, text "missingAlt" <+> ppr case_bndr )
+    -- See Note [Avoiding space leaks in OutType]
+    let cont_ty = contResultType cont
+    in seqType cont_ty `seq`
+       return (emptyFloats env, mkImpossibleExpr cont_ty)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Duplicating continuations}
+*                                                                      *
+************************************************************************
+
+Consider
+  let x* = case e of { True -> e1; False -> e2 }
+  in b
+where x* is a strict binding.  Then mkDupableCont will be given
+the continuation
+   case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop
+and will split it into
+   dupable:      case [] of { True -> $j1; False -> $j2 } ; stop
+   join floats:  $j1 = e1, $j2 = e2
+   non_dupable:  let x* = [] in b; stop
+
+Putting this back together would give
+   let x* = let { $j1 = e1; $j2 = e2 } in
+            case e of { True -> $j1; False -> $j2 }
+   in b
+(Of course we only do this if 'e' wants to duplicate that continuation.)
+Note how important it is that the new join points wrap around the
+inner expression, and not around the whole thing.
+
+In contrast, any let-bindings introduced by mkDupableCont can wrap
+around the entire thing.
+
+Note [Bottom alternatives]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we have
+     case (case x of { A -> error .. ; B -> e; C -> error ..)
+       of alts
+then we can just duplicate those alts because the A and C cases
+will disappear immediately.  This is more direct than creating
+join points and inlining them away.  See Trac #4930.
+-}
+
+--------------------
+mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont
+                  -> SimplM (SimplFloats, SimplCont)
+mkDupableCaseCont env alts cont
+  | altsWouldDup alts = mkDupableCont env cont
+  | otherwise         = return (emptyFloats env, cont)
+
+altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative
+altsWouldDup []  = False        -- See Note [Bottom alternatives]
+altsWouldDup [_] = False
+altsWouldDup (alt:alts)
+  | is_bot_alt alt = altsWouldDup alts
+  | otherwise      = not (all is_bot_alt alts)
+  where
+    is_bot_alt (_,_,rhs) = exprIsBottom rhs
+
+-------------------------
+mkDupableCont :: SimplEnv -> SimplCont
+              -> SimplM ( SimplFloats  -- Incoming SimplEnv augmented with
+                                       --   extra let/join-floats and in-scope variables
+                        , SimplCont)   -- dup_cont: duplicable continuation
+
+mkDupableCont env cont
+  | contIsDupable cont
+  = return (emptyFloats env, cont)
+
+mkDupableCont _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn
+
+mkDupableCont env (CastIt ty cont)
+  = do  { (floats, cont') <- mkDupableCont env cont
+        ; return (floats, CastIt ty cont') }
+
+-- Duplicating ticks for now, not sure if this is good or not
+mkDupableCont env (TickIt t cont)
+  = do  { (floats, cont') <- mkDupableCont env cont
+        ; return (floats, TickIt t cont') }
+
+mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs
+                              , sc_body = body, sc_env = se, sc_cont = cont})
+  -- See Note [Duplicating StrictBind]
+  = do { let sb_env = se `setInScopeFromE` env
+       ; (sb_env1, bndr') <- simplBinder sb_env bndr
+       ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont
+          -- No need to use mkDupableCont before simplLam; we
+          -- use cont once here, and then share the result if necessary
+
+       ; let join_body = wrapFloats floats1 join_inner
+             res_ty    = contResultType cont
+
+       ; (floats2, body2)
+            <- if exprIsDupable (seDynFlags env) join_body
+               then return (emptyFloats env, join_body)
+               else do { join_bndr <- newJoinId [bndr'] res_ty
+                       ; let join_call = App (Var join_bndr) (Var bndr')
+                             join_rhs  = Lam (setOneShotLambda bndr') join_body
+                             join_bind = NonRec join_bndr join_rhs
+                             floats    = emptyFloats env `extendFloats` join_bind
+                       ; return (floats, join_call) }
+       ; return ( floats2
+                , StrictBind { sc_bndr = bndr', sc_bndrs = []
+                             , sc_body = body2
+                             , sc_env  = zapSubstEnv se `setInScopeFromF` floats2
+                                         -- See Note [StaticEnv invariant] in SimplUtils
+                             , sc_dup  = OkToDup
+                             , sc_cont = mkBoringStop res_ty } ) }
+
+mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci, sc_cont = cont })
+        -- See Note [Duplicating StrictArg]
+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
+  = do { (floats1, cont') <- mkDupableCont env cont
+       ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env))
+                                           (ai_args info)
+       ; return ( foldl' addLetFloats floats1 floats_s
+                , StrictArg { sc_fun = info { ai_args = args' }
+                            , sc_cci = cci
+                            , sc_cont = cont'
+                            , sc_dup = OkToDup} ) }
+
+mkDupableCont env (ApplyToTy { sc_cont = cont
+                             , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })
+  = do  { (floats, cont') <- mkDupableCont env cont
+        ; return (floats, ApplyToTy { sc_cont = cont'
+                                    , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }
+
+mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup
+                              , sc_env = se, sc_cont = cont })
+  =     -- e.g.         [...hole...] (...arg...)
+        --      ==>
+        --              let a = ...arg...
+        --              in [...hole...] a
+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
+    do  { (floats1, cont') <- mkDupableCont env cont
+        ; let env' = env `setInScopeFromF` floats1
+        ; (_, se', arg') <- simplArg env' dup se arg
+        ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel (fsLit "karg") arg'
+        ; let all_floats = floats1 `addLetFloats` let_floats2
+        ; return ( all_floats
+                 , ApplyToVal { sc_arg = arg''
+                              , sc_env = se' `setInScopeFromF` all_floats
+                                         -- Ensure that sc_env includes the free vars of
+                                         -- arg'' in its in-scope set, even if makeTrivial
+                                         -- has turned arg'' into a fresh variable
+                                         -- See Note [StaticEnv invariant] in SimplUtils
+                              , sc_dup = OkToDup, sc_cont = cont' }) }
+
+mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts
+                          , sc_env = se, sc_cont = cont })
+  =     -- e.g.         (case [...hole...] of { pi -> ei })
+        --      ===>
+        --              let ji = \xij -> ei
+        --              in case [...hole...] of { pi -> ji xij }
+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
+    do  { tick (CaseOfCase case_bndr)
+        ; (floats, alt_cont) <- mkDupableCaseCont env alts cont
+                -- NB: We call mkDupableCaseCont here to make cont duplicable
+                --     (if necessary, depending on the number of alts)
+                -- And this is important: see Note [Fusing case continuations]
+
+        ; let alt_env = se `setInScopeFromF` floats
+        ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr
+        ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) alts
+        -- Safe to say that there are no handled-cons for the DEFAULT case
+                -- NB: simplBinder does not zap deadness occ-info, so
+                -- a dead case_bndr' will still advertise its deadness
+                -- This is really important because in
+                --      case e of b { (# p,q #) -> ... }
+                -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),
+                -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.
+                -- In the new alts we build, we have the new case binder, so it must retain
+                -- its deadness.
+        -- NB: we don't use alt_env further; it has the substEnv for
+        --     the alternatives, and we don't want that
+
+        ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (seDynFlags env) case_bndr')
+                                              emptyJoinFloats alts'
+
+        ; let all_floats = floats `addJoinFloats` join_floats
+                           -- Note [Duplicated env]
+        ; return (all_floats
+                 , Select { sc_dup  = OkToDup
+                          , sc_bndr = case_bndr'
+                          , sc_alts = alts''
+                          , sc_env  = zapSubstEnv se `setInScopeFromF` all_floats
+                                      -- See Note [StaticEnv invariant] in SimplUtils
+                          , sc_cont = mkBoringStop (contResultType cont) } ) }
+
+mkDupableAlt :: DynFlags -> OutId
+             -> JoinFloats -> OutAlt
+             -> SimplM (JoinFloats, OutAlt)
+mkDupableAlt dflags case_bndr jfloats (con, bndrs', rhs')
+  | exprIsDupable dflags rhs'  -- Note [Small alternative rhs]
+  = return (jfloats, (con, bndrs', rhs'))
+
+  | otherwise
+  = do  { let rhs_ty'  = exprType rhs'
+              scrut_ty = idType case_bndr
+              case_bndr_w_unf
+                = case con of
+                      DEFAULT    -> case_bndr
+                      DataAlt dc -> setIdUnfolding case_bndr unf
+                          where
+                                 -- See Note [Case binders and join points]
+                             unf = mkInlineUnfolding rhs
+                             rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'
+
+                      LitAlt {} -> WARN( True, text "mkDupableAlt"
+                                                <+> ppr case_bndr <+> ppr con )
+                                   case_bndr
+                           -- The case binder is alive but trivial, so why has
+                           -- it not been substituted away?
+
+              final_bndrs'
+                | isDeadBinder case_bndr = filter abstract_over bndrs'
+                | otherwise              = bndrs' ++ [case_bndr_w_unf]
+
+              abstract_over bndr
+                  | isTyVar bndr = True -- Abstract over all type variables just in case
+                  | otherwise    = not (isDeadBinder bndr)
+                        -- The deadness info on the new Ids is preserved by simplBinders
+              final_args = varsToCoreExprs final_bndrs'
+                           -- Note [Join point abstraction]
+
+                -- We make the lambdas into one-shot-lambdas.  The
+                -- join point is sure to be applied at most once, and doing so
+                -- prevents the body of the join point being floated out by
+                -- the full laziness pass
+              really_final_bndrs     = map one_shot final_bndrs'
+              one_shot v | isId v    = setOneShotLambda v
+                         | otherwise = v
+              join_rhs   = mkLams really_final_bndrs rhs'
+
+        ; join_bndr <- newJoinId final_bndrs' rhs_ty'
+
+        ; let join_call = mkApps (Var join_bndr) final_args
+              alt'      = (con, bndrs', join_call)
+
+        ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)
+                 , alt') }
+                -- See Note [Duplicated env]
+
+{-
+Note [Fusing case continuations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's important to fuse two successive case continuations when the
+first has one alternative.  That's why we call prepareCaseCont here.
+Consider this, which arises from thunk splitting (see Note [Thunk
+splitting] in WorkWrap):
+
+      let
+        x* = case (case v of {pn -> rn}) of
+               I# a -> I# a
+      in body
+
+The simplifier will find
+    (Var v) with continuation
+            Select (pn -> rn) (
+            Select [I# a -> I# a] (
+            StrictBind body Stop
+
+So we'll call mkDupableCont on
+   Select [I# a -> I# a] (StrictBind body Stop)
+There is just one alternative in the first Select, so we want to
+simplify the rhs (I# a) with continuation (StrictBind body Stop)
+Supposing that body is big, we end up with
+          let $j a = <let x = I# a in body>
+          in case v of { pn -> case rn of
+                                 I# a -> $j a }
+This is just what we want because the rn produces a box that
+the case rn cancels with.
+
+See Trac #4957 a fuller example.
+
+Note [Case binders and join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+   case (case .. ) of c {
+     I# c# -> ....c....
+
+If we make a join point with c but not c# we get
+  $j = \c -> ....c....
+
+But if later inlining scrutinises the c, thus
+
+  $j = \c -> ... case c of { I# y -> ... } ...
+
+we won't see that 'c' has already been scrutinised.  This actually
+happens in the 'tabulate' function in wave4main, and makes a significant
+difference to allocation.
+
+An alternative plan is this:
+
+   $j = \c# -> let c = I# c# in ...c....
+
+but that is bad if 'c' is *not* later scrutinised.
+
+So instead we do both: we pass 'c' and 'c#' , and record in c's inlining
+(a stable unfolding) that it's really I# c#, thus
+
+   $j = \c# -> \c[=I# c#] -> ...c....
+
+Absence analysis may later discard 'c'.
+
+NB: take great care when doing strictness analysis;
+    see Note [Lambda-bound unfoldings] in DmdAnal.
+
+Also note that we can still end up passing stuff that isn't used.  Before
+strictness analysis we have
+   let $j x y c{=(x,y)} = (h c, ...)
+   in ...
+After strictness analysis we see that h is strict, we end up with
+   let $j x y c{=(x,y)} = ($wh x y, ...)
+and c is unused.
+
+Note [Duplicated env]
+~~~~~~~~~~~~~~~~~~~~~
+Some of the alternatives are simplified, but have not been turned into a join point
+So they *must* have a zapped subst-env.  So we can't use completeNonRecX to
+bind the join point, because it might to do PostInlineUnconditionally, and
+we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,
+but zapping it (as we do in mkDupableCont, the Select case) is safe, and
+at worst delays the join-point inlining.
+
+Note [Small alternative rhs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It is worth checking for a small RHS because otherwise we
+get extra let bindings that may cause an extra iteration of the simplifier to
+inline back in place.  Quite often the rhs is just a variable or constructor.
+The Ord instance of Maybe in PrelMaybe.hs, for example, took several extra
+iterations because the version with the let bindings looked big, and so wasn't
+inlined, but after the join points had been inlined it looked smaller, and so
+was inlined.
+
+NB: we have to check the size of rhs', not rhs.
+Duplicating a small InAlt might invalidate occurrence information
+However, if it *is* dupable, we return the *un* simplified alternative,
+because otherwise we'd need to pair it up with an empty subst-env....
+but we only have one env shared between all the alts.
+(Remember we must zap the subst-env before re-simplifying something).
+Rather than do this we simply agree to re-simplify the original (small) thing later.
+
+Note [Funky mkLamTypes]
+~~~~~~~~~~~~~~~~~~~~~~
+Notice the funky mkLamTypes.  If the constructor has existentials
+it's possible that the join point will be abstracted over
+type variables as well as term variables.
+ Example:  Suppose we have
+        data T = forall t.  C [t]
+ Then faced with
+        case (case e of ...) of
+            C t xs::[t] -> rhs
+ We get the join point
+        let j :: forall t. [t] -> ...
+            j = /\t \xs::[t] -> rhs
+        in
+        case (case e of ...) of
+            C t xs::[t] -> j t xs
+
+Note [Duplicating StrictArg]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We make a StrictArg duplicable simply by making all its
+stored-up arguments (in sc_fun) trivial, by let-binding
+them.  Thus:
+        f E [..hole..]
+        ==>     let a = E
+                in f a [..hole..]
+Now if the thing in the hole is a case expression (which is when
+we'll call mkDupableCont), we'll push the function call into the
+branches, which is what we want.  Now RULES for f may fire, and
+call-pattern specialisation.  Here's an example from Trac #3116
+     go (n+1) (case l of
+                 1  -> bs'
+                 _  -> Chunk p fpc (o+1) (l-1) bs')
+If we can push the call for 'go' inside the case, we get
+call-pattern specialisation for 'go', which is *crucial* for
+this program.
+
+Here is the (&&) example:
+        && E (case x of { T -> F; F -> T })
+  ==>   let a = E in
+        case x of { T -> && a F; F -> && a T }
+Much better!
+
+Notice that
+  * Arguments to f *after* the strict one are handled by
+    the ApplyToVal case of mkDupableCont.  Eg
+        f [..hole..] E
+
+  * We can only do the let-binding of E because the function
+    part of a StrictArg continuation is an explicit syntax
+    tree.  In earlier versions we represented it as a function
+    (CoreExpr -> CoreEpxr) which we couldn't take apart.
+
+Historical aide: previously we did this (where E is a
+big argument:
+        f E [..hole..]
+        ==>     let $j = \a -> f E a
+                in $j [..hole..]
+
+But this is terrible! Here's an example:
+        && E (case x of { T -> F; F -> T })
+Now, && is strict so we end up simplifying the case with
+an ArgOf continuation.  If we let-bind it, we get
+        let $j = \v -> && E v
+        in simplExpr (case x of { T -> F; F -> T })
+                     (ArgOf (\r -> $j r)
+And after simplifying more we get
+        let $j = \v -> && E v
+        in case x of { T -> $j F; F -> $j T }
+Which is a Very Bad Thing
+
+
+Note [Duplicating StrictBind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We make a StrictBind duplicable in a very similar way to
+that for case expressions.  After all,
+   let x* = e in b   is similar to    case e of x -> b
+
+So we potentially make a join-point for the body, thus:
+   let x = [] in b   ==>   join j x = b
+                           in let x = [] in j x
+
+
+Note [Join point abstraction]  Historical note
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+NB: This note is now historical, describing how (in the past) we used
+to add a void argument to nullary join points.  But now that "join
+point" is not a fuzzy concept but a formal syntactic construct (as
+distinguished by the JoinId constructor of IdDetails), each of these
+concerns is handled separately, with no need for a vestigial extra
+argument.
+
+Join points always have at least one value argument,
+for several reasons
+
+* If we try to lift a primitive-typed something out
+  for let-binding-purposes, we will *caseify* it (!),
+  with potentially-disastrous strictness results.  So
+  instead we turn it into a function: \v -> e
+  where v::Void#.  The value passed to this function is void,
+  which generates (almost) no code.
+
+* CPR.  We used to say "&& isUnliftedType rhs_ty'" here, but now
+  we make the join point into a function whenever used_bndrs'
+  is empty.  This makes the join-point more CPR friendly.
+  Consider:       let j = if .. then I# 3 else I# 4
+                  in case .. of { A -> j; B -> j; C -> ... }
+
+  Now CPR doesn't w/w j because it's a thunk, so
+  that means that the enclosing function can't w/w either,
+  which is a lose.  Here's the example that happened in practice:
+          kgmod :: Int -> Int -> Int
+          kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0
+                      then 78
+                      else 5
+
+* Let-no-escape.  We want a join point to turn into a let-no-escape
+  so that it is implemented as a jump, and one of the conditions
+  for LNE is that it's not updatable.  In CoreToStg, see
+  Note [What is a non-escaping let]
+
+* Floating.  Since a join point will be entered once, no sharing is
+  gained by floating out, but something might be lost by doing
+  so because it might be allocated.
+
+I have seen a case alternative like this:
+        True -> \v -> ...
+It's a bit silly to add the realWorld dummy arg in this case, making
+        $j = \s v -> ...
+           True -> $j s
+(the \v alone is enough to make CPR happy) but I think it's rare
+
+There's a slight infelicity here: we pass the overall
+case_bndr to all the join points if it's used in *any* RHS,
+because we don't know its usage in each RHS separately
+
+
+
+************************************************************************
+*                                                                      *
+                    Unfoldings
+*                                                                      *
+************************************************************************
+-}
+
+simplLetUnfolding :: SimplEnv-> TopLevelFlag
+                  -> MaybeJoinCont
+                  -> InId
+                  -> OutExpr -> OutType
+                  -> Unfolding -> SimplM Unfolding
+simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty unf
+  | isStableUnfolding unf
+  = simplStableUnfolding env top_lvl cont_mb id unf rhs_ty
+  | isExitJoinId id
+  = return noUnfolding -- See Note [Do not inline exit join points] in Exitify
+  | otherwise
+  = mkLetUnfolding (seDynFlags env) top_lvl InlineRhs id new_rhs
+
+-------------------
+mkLetUnfolding :: DynFlags -> TopLevelFlag -> UnfoldingSource
+               -> InId -> OutExpr -> SimplM Unfolding
+mkLetUnfolding dflags top_lvl src id new_rhs
+  = is_bottoming `seq`  -- See Note [Force bottoming field]
+    return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs)
+            -- We make an  unfolding *even for loop-breakers*.
+            -- Reason: (a) It might be useful to know that they are WHNF
+            --         (b) In TidyPgm we currently assume that, if we want to
+            --             expose the unfolding then indeed we *have* an unfolding
+            --             to expose.  (We could instead use the RHS, but currently
+            --             we don't.)  The simple thing is always to have one.
+  where
+    is_top_lvl   = isTopLevel top_lvl
+    is_bottoming = isBottomingId id
+
+-------------------
+simplStableUnfolding :: SimplEnv -> TopLevelFlag
+                     -> MaybeJoinCont  -- Just k => a join point with continuation k
+                     -> InId
+                     -> Unfolding -> OutType -> SimplM Unfolding
+-- Note [Setting the new unfolding]
+simplStableUnfolding env top_lvl mb_cont id unf rhs_ty
+  = case unf of
+      NoUnfolding   -> return unf
+      BootUnfolding -> return unf
+      OtherCon {}   -> return unf
+
+      DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }
+        -> do { (env', bndrs') <- simplBinders unf_env bndrs
+              ; args' <- mapM (simplExpr env') args
+              ; return (mkDFunUnfolding bndrs' con args') }
+
+      CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }
+        | isStableSource src
+        -> do { expr' <- case mb_cont of -- See Note [Rules and unfolding for join points]
+                           Just cont -> simplJoinRhs unf_env id expr cont
+                           Nothing   -> simplExprC unf_env expr (mkBoringStop rhs_ty)
+              ; case guide of
+                  UnfWhen { ug_arity = arity
+                          , ug_unsat_ok = sat_ok
+                          , ug_boring_ok = boring_ok
+                          }
+                          -- Happens for INLINE things
+                     -> let guide' =
+                              UnfWhen { ug_arity = arity
+                                      , ug_unsat_ok = sat_ok
+                                      , ug_boring_ok =
+                                          boring_ok || inlineBoringOk expr'
+                                      }
+                        -- Refresh the boring-ok flag, in case expr'
+                        -- has got small. This happens, notably in the inlinings
+                        -- for dfuns for single-method classes; see
+                        -- Note [Single-method classes] in TcInstDcls.
+                        -- A test case is Trac #4138
+                        -- But retain a previous boring_ok of True; e.g. see
+                        -- the way it is set in calcUnfoldingGuidanceWithArity
+                        in return (mkCoreUnfolding src is_top_lvl expr' guide')
+                            -- See Note [Top-level flag on inline rules] in CoreUnfold
+
+                  _other              -- Happens for INLINABLE things
+                     -> mkLetUnfolding dflags top_lvl src id expr' }
+                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE
+                -- unfolding, and we need to make sure the guidance is kept up
+                -- to date with respect to any changes in the unfolding.
+
+        | otherwise -> return noUnfolding   -- Discard unstable unfoldings
+  where
+    dflags     = seDynFlags env
+    is_top_lvl = isTopLevel top_lvl
+    act        = idInlineActivation id
+    unf_env    = updMode (updModeForStableUnfoldings act) env
+         -- See Note [Simplifying inside stable unfoldings] in SimplUtils
+
+{-
+Note [Force bottoming field]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to force bottoming, or the new unfolding holds
+on to the old unfolding (which is part of the id).
+
+Note [Setting the new unfolding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we
+  should do nothing at all, but simplifying gently might get rid of
+  more crap.
+
+* If not, we make an unfolding from the new RHS.  But *only* for
+  non-loop-breakers. Making loop breakers not have an unfolding at all
+  means that we can avoid tests in exprIsConApp, for example.  This is
+  important: if exprIsConApp says 'yes' for a recursive thing, then we
+  can get into an infinite loop
+
+If there's a stable unfolding on a loop breaker (which happens for
+INLINABLE), we hang on to the inlining.  It's pretty dodgy, but the
+user did say 'INLINE'.  May need to revisit this choice.
+
+************************************************************************
+*                                                                      *
+                    Rules
+*                                                                      *
+************************************************************************
+
+Note [Rules in a letrec]
+~~~~~~~~~~~~~~~~~~~~~~~~
+After creating fresh binders for the binders of a letrec, we
+substitute the RULES and add them back onto the binders; this is done
+*before* processing any of the RHSs.  This is important.  Manuel found
+cases where he really, really wanted a RULE for a recursive function
+to apply in that function's own right-hand side.
+
+See Note [Forming Rec groups] in OccurAnal
+-}
+
+addBndrRules :: SimplEnv -> InBndr -> OutBndr
+             -> MaybeJoinCont   -- Just k for a join point binder
+                                -- Nothing otherwise
+             -> SimplM (SimplEnv, OutBndr)
+-- Rules are added back into the bin
+addBndrRules env in_id out_id mb_cont
+  | null old_rules
+  = return (env, out_id)
+  | otherwise
+  = do { new_rules <- simplRules env (Just out_id) old_rules mb_cont
+       ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules
+       ; return (modifyInScope env final_id, final_id) }
+  where
+    old_rules = ruleInfoRules (idSpecialisation in_id)
+
+simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]
+           -> MaybeJoinCont -> SimplM [CoreRule]
+simplRules env mb_new_id rules mb_cont
+  = mapM simpl_rule rules
+  where
+    simpl_rule rule@(BuiltinRule {})
+      = return rule
+
+    simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args
+                          , ru_fn = fn_name, ru_rhs = rhs })
+      = do { (env', bndrs') <- simplBinders env bndrs
+           ; let rhs_ty = substTy env' (exprType rhs)
+                 rhs_cont = case mb_cont of  -- See Note [Rules and unfolding for join points]
+                                Nothing   -> mkBoringStop rhs_ty
+                                Just cont -> ASSERT2( join_ok, bad_join_msg )
+                                             cont
+                 rule_env = updMode updModeForRules env'
+                 fn_name' = case mb_new_id of
+                              Just id -> idName id
+                              Nothing -> fn_name
+
+                 -- join_ok is an assertion check that the join-arity of the
+                 -- binder matches that of the rule, so that pushing the
+                 -- continuation into the RHS makes sense
+                 join_ok = case mb_new_id of
+                             Just id | Just join_arity <- isJoinId_maybe id
+                                     -> length args == join_arity
+                             _ -> False
+                 bad_join_msg = vcat [ ppr mb_new_id, ppr rule
+                                     , ppr (fmap isJoinId_maybe mb_new_id) ]
+
+           ; args' <- mapM (simplExpr rule_env) args
+           ; rhs'  <- simplExprC rule_env rhs rhs_cont
+           ; return (rule { ru_bndrs = bndrs'
+                          , ru_fn    = fn_name'
+                          , ru_args  = args'
+                          , ru_rhs   = rhs' }) }
diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/SimplStg.hs
@@ -0,0 +1,140 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+\section[SimplStg]{Driver for simplifying @STG@ programs}
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module SimplStg ( stg2stg ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import StgSyn
+
+import StgLint          ( lintStgTopBindings )
+import StgStats         ( showStgStats )
+import UnariseStg       ( unarise )
+import StgCse           ( stgCse )
+import StgLiftLams      ( stgLiftLams )
+import Module           ( Module )
+
+import DynFlags
+import ErrUtils
+import UniqSupply
+import Outputable
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.State.Strict
+
+newtype StgM a = StgM { _unStgM :: StateT UniqSupply IO a }
+  deriving (Functor, Applicative, Monad, MonadIO)
+
+instance MonadUnique StgM where
+  getUniqueSupplyM = StgM (state splitUniqSupply)
+  getUniqueM = StgM (state takeUniqFromSupply)
+
+runStgM :: UniqSupply -> StgM a -> IO a
+runStgM us (StgM m) = evalStateT m us
+
+stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do
+        -> Module                    -- module being compiled
+        -> [StgTopBinding]           -- input program
+        -> IO [StgTopBinding]        -- output program
+
+stg2stg dflags this_mod binds
+  = do  { showPass dflags "Stg2Stg"
+        ; us <- mkSplitUniqSupply 'g'
+
+        -- Do the main business!
+        ; binds' <- runStgM us $
+            foldM do_stg_pass binds (getStgToDo dflags)
+
+        ; dump_when Opt_D_dump_stg "STG syntax:" binds'
+
+        ; return binds'
+   }
+
+  where
+    stg_linter what
+      | gopt Opt_DoStgLinting dflags
+      = lintStgTopBindings dflags this_mod what
+      | otherwise
+      = \ _whodunnit _binds -> return ()
+
+    -------------------------------------------
+    do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]
+    do_stg_pass binds to_do
+      = case to_do of
+          StgDoNothing ->
+            return binds
+
+          StgStats ->
+            trace (showStgStats binds) (return binds)
+
+          StgCSE -> do
+            let binds' = {-# SCC "StgCse" #-} stgCse binds
+            end_pass "StgCse" binds'
+
+          StgLiftLams -> do
+            us <- getUniqueSupplyM
+            let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds
+            end_pass "StgLiftLams" binds'
+
+          StgUnarise -> do
+            liftIO (dump_when Opt_D_dump_stg "Pre unarise:" binds)
+            us <- getUniqueSupplyM
+            liftIO (stg_linter False "Pre-unarise" binds)
+            let binds' = unarise us binds
+            liftIO (stg_linter True "Unarise" binds')
+            return binds'
+
+    dump_when flag header binds
+      = dumpIfSet_dyn dflags flag header (pprStgTopBindings binds)
+
+    end_pass what binds2
+      = liftIO $ do -- report verbosely, if required
+          dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
+            (vcat (map ppr binds2))
+          stg_linter False what binds2
+          return binds2
+
+-- -----------------------------------------------------------------------------
+-- StgToDo:  abstraction of stg-to-stg passes to run.
+
+-- | Optional Stg-to-Stg passes.
+data StgToDo
+  = StgCSE
+  -- ^ Common subexpression elimination
+  | StgLiftLams
+  -- ^ Lambda lifting closure variables, trading stack/register allocation for
+  -- heap allocation
+  | StgStats
+  | StgUnarise
+  -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders
+  | StgDoNothing
+  -- ^ Useful for building up 'getStgToDo'
+  deriving Eq
+
+-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.
+getStgToDo :: DynFlags -> [StgToDo]
+getStgToDo dflags =
+  filter (/= StgDoNothing)
+    [ mandatory StgUnarise
+    -- Important that unarisation comes first
+    -- See Note [StgCse after unarisation] in StgCse
+    , optional Opt_StgCSE StgCSE
+    , optional Opt_StgLiftLams StgLiftLams
+    , optional Opt_StgStats StgStats
+    ] where
+      optional opt = runWhen (gopt opt dflags)
+      mandatory = id
+
+runWhen :: Bool -> StgToDo -> StgToDo
+runWhen True todo = todo
+runWhen _    _    = StgDoNothing
diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/StgCse.hs
@@ -0,0 +1,483 @@
+{-# LANGUAGE TypeFamilies #-}
+
+{-|
+Note [CSE for Stg]
+~~~~~~~~~~~~~~~~~~
+This module implements a simple common subexpression elimination pass for STG.
+This is useful because there are expressions that we want to common up (because
+they are operationally equivalent), but that we cannot common up in Core, because
+their types differ.
+This was originally reported as #9291.
+
+There are two types of common code occurrences that we aim for, see
+note [Case 1: CSEing allocated closures] and
+note [Case 2: CSEing case binders] below.
+
+
+Note [Case 1: CSEing allocated closures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The first kind of CSE opportunity we aim for is generated by this Haskell code:
+
+    bar :: a -> (Either Int a, Either Bool a)
+    bar x = (Right x, Right x)
+
+which produces this Core:
+
+    bar :: forall a. a -> (Either Int a, Either Bool a)
+    bar @a x = (Right @Int @a x, Right @Bool @a x)
+
+where the two components of the tuple are different terms, and cannot be
+commoned up (easily). On the STG level we have
+
+    bar [x] = let c1 = Right [x]
+                  c2 = Right [x]
+              in (c1,c2)
+
+and now it is obvious that we can write
+
+    bar [x] = let c1 = Right [x]
+              in (c1,c1)
+
+instead.
+
+
+Note [Case 2: CSEing case binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The second kind of CSE opportunity we aim for is more interesting, and
+came up in #9291 and #5344: The Haskell code
+
+    foo :: Either Int a -> Either Bool a
+    foo (Right x) = Right x
+    foo _         = Left False
+
+produces this Core
+
+    foo :: forall a. Either Int a -> Either Bool a
+    foo @a e = case e of b { Left n -> …
+                           , Right x -> Right @Bool @a x }
+
+where we cannot CSE `Right @Bool @a x` with the case binder `b` as they have
+different types. But in STG we have
+
+    foo [e] = case e of b { Left [n] -> …
+                          , Right [x] -> Right [x] }
+
+and nothing stops us from transforming that to
+
+    foo [e] = case e of b { Left [n] -> …
+                          , Right [x] -> b}
+
+
+Note [StgCse after unarisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider two unboxed sum terms:
+
+    (# 1 | #) :: (# Int | Int# #)
+    (# 1 | #) :: (# Int | Int  #)
+
+These two terms are not equal as they unarise to different unboxed
+tuples. However if we run StgCse before Unarise, it'll think the two
+terms (# 1 | #) are equal, and replace one of these with a binder to
+the other. That's bad -- Trac #15300.
+
+Solution: do unarise first.
+
+-}
+
+module StgCse (stgCse) where
+
+import GhcPrelude
+
+import DataCon
+import Id
+import StgSyn
+import Outputable
+import VarEnv
+import CoreSyn (AltCon(..))
+import Data.List (mapAccumL)
+import Data.Maybe (fromMaybe)
+import CoreMap
+import NameEnv
+import Control.Monad( (>=>) )
+
+--------------
+-- The Trie --
+--------------
+
+-- A lookup trie for data constructor applications, i.e.
+-- keys of type `(DataCon, [StgArg])`, following the patterns in TrieMap.
+
+data StgArgMap a = SAM
+    { sam_var :: DVarEnv a
+    , sam_lit :: LiteralMap a
+    }
+
+instance TrieMap StgArgMap where
+    type Key StgArgMap = StgArg
+    emptyTM  = SAM { sam_var = emptyTM
+                   , sam_lit = emptyTM }
+    lookupTM (StgVarArg var) = sam_var >.> lkDFreeVar var
+    lookupTM (StgLitArg lit) = sam_lit >.> lookupTM lit
+    alterTM  (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f }
+    alterTM  (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f }
+    foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)
+    mapTM f (SAM {sam_var = varm, sam_lit = litm}) =
+        SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm }
+
+newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) }
+
+instance TrieMap ConAppMap where
+    type Key ConAppMap = (DataCon, [StgArg])
+    emptyTM  = CAM emptyTM
+    lookupTM (dataCon, args) = un_cam >.> lkDNamed dataCon >=> lookupTM args
+    alterTM  (dataCon, args) f m =
+        m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }
+    foldTM k = un_cam >.> foldTM (foldTM k)
+    mapTM f  = un_cam >.> mapTM (mapTM f) >.> CAM
+
+-----------------
+-- The CSE Env --
+-----------------
+
+-- | The CSE environment. See note [CseEnv Example]
+data CseEnv = CseEnv
+    { ce_conAppMap :: ConAppMap OutId
+        -- ^ The main component of the environment is the trie that maps
+        --   data constructor applications (with their `OutId` arguments)
+        --   to an in-scope name that can be used instead.
+        --   This name is always either a let-bound variable or a case binder.
+    , ce_subst     :: IdEnv OutId
+        -- ^ This substitution is applied to the code as we traverse it.
+        --   Entries have one of two reasons:
+        --
+        --   * The input might have shadowing (see Note [Shadowing]), so we have
+        --     to rename some binders as we traverse the tree.
+        --   * If we remove `let x = Con z` because  `let y = Con z` is in scope,
+        --     we note this here as x ↦ y.
+    , ce_bndrMap     :: IdEnv OutId
+        -- ^ If we come across a case expression case x as b of … with a trivial
+        --   binder, we add b ↦ x to this.
+        --   This map is *only* used when looking something up in the ce_conAppMap.
+        --   See Note [Trivial case scrutinee]
+    , ce_in_scope  :: InScopeSet
+        -- ^ The third component is an in-scope set, to rename away any
+        --   shadowing binders
+    }
+
+{-|
+Note [CseEnv Example]
+~~~~~~~~~~~~~~~~~~~~~
+The following tables shows how the CseEnvironment changes as code is traversed,
+as well as the changes to that code.
+
+  InExpr                         OutExpr
+     conAppMap                   subst          in_scope
+  ───────────────────────────────────────────────────────────
+  -- empty                       {}             {}
+  case … as a of {Con x y ->     case … as a of {Con x y ->
+  -- Con x y ↦ a                 {}             {a,x,y}
+  let b = Con x y                (removed)
+  -- Con x y ↦ a                 b↦a            {a,x,y,b}
+  let c = Bar a                  let c = Bar a
+  -- Con x y ↦ a, Bar a ↦ c      b↦a            {a,x,y,b,c}
+  let c = some expression        let c' = some expression
+  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c',     {a,x,y,b,c,c'}
+  let d = Bar b                  (removed)
+  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c', d↦c {a,x,y,b,c,c',d}
+  (a, b, c d)                    (a, a, c' c)
+-}
+
+initEnv :: InScopeSet -> CseEnv
+initEnv in_scope = CseEnv
+    { ce_conAppMap = emptyTM
+    , ce_subst     = emptyVarEnv
+    , ce_bndrMap   = emptyVarEnv
+    , ce_in_scope  = in_scope
+    }
+
+envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId
+envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env)
+  where args' = map go args -- See Note [Trivial case scrutinee]
+        go (StgVarArg v  ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v)
+        go (StgLitArg lit) = StgLitArg lit
+
+addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv
+-- do not bother with nullary data constructors, they are static anyways
+addDataCon _ _ [] env = env
+addDataCon bndr dataCon args env = env { ce_conAppMap = new_env }
+  where
+    new_env = insertTM (dataCon, args) bndr (ce_conAppMap env)
+
+forgetCse :: CseEnv -> CseEnv
+forgetCse env = env { ce_conAppMap = emptyTM }
+    -- See note [Free variables of an StgClosure]
+
+addSubst :: OutId -> OutId -> CseEnv -> CseEnv
+addSubst from to env
+    = env { ce_subst = extendVarEnv (ce_subst env) from to }
+
+addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv
+addTrivCaseBndr from to env
+    = env { ce_bndrMap = extendVarEnv (ce_bndrMap env) from to }
+
+substArgs :: CseEnv -> [InStgArg] -> [OutStgArg]
+substArgs env = map (substArg env)
+
+substArg :: CseEnv -> InStgArg -> OutStgArg
+substArg env (StgVarArg from) = StgVarArg (substVar env from)
+substArg _   (StgLitArg lit)  = StgLitArg lit
+
+substVar :: CseEnv -> InId -> OutId
+substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id
+
+-- Functions to enter binders
+
+-- This is much simpler than the equivalent code in CoreSubst:
+--  * We do not substitute type variables, and
+--  * There is nothing relevant in IdInfo at this stage
+--    that needs substitutions.
+-- Therefore, no special treatment for a recursive group is required.
+
+substBndr :: CseEnv -> InId -> (CseEnv, OutId)
+substBndr env old_id
+  = (new_env, new_id)
+  where
+    new_id = uniqAway (ce_in_scope env) old_id
+    no_change = new_id == old_id
+    env' = env { ce_in_scope = ce_in_scope env `extendInScopeSet` new_id }
+    new_env | no_change = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id }
+            | otherwise = env'
+
+substBndrs :: CseEnv -> [InVar] -> (CseEnv, [OutVar])
+substBndrs env bndrs = mapAccumL substBndr env bndrs
+
+substPairs :: CseEnv -> [(InVar, a)] -> (CseEnv, [(OutVar, a)])
+substPairs env bndrs = mapAccumL go env bndrs
+  where go env (id, x) = let (env', id') = substBndr env id
+                         in (env', (id', x))
+
+-- Main entry point
+
+stgCse :: [InStgTopBinding] -> [OutStgTopBinding]
+stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds
+
+-- Top level bindings.
+--
+-- We do not CSE these, as top-level closures are allocated statically anyways.
+-- Also, they might be exported.
+-- But we still have to collect the set of in-scope variables, otherwise
+-- uniqAway might shadow a top-level closure.
+
+stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, OutStgTopBinding)
+stgCseTopLvl in_scope t@(StgTopStringLit _ _) = (in_scope, t)
+stgCseTopLvl in_scope (StgTopLifted (StgNonRec bndr rhs))
+    = (in_scope'
+      , StgTopLifted (StgNonRec bndr (stgCseTopLvlRhs in_scope rhs)))
+  where in_scope' = in_scope `extendInScopeSet` bndr
+
+stgCseTopLvl in_scope (StgTopLifted (StgRec eqs))
+    = ( in_scope'
+      , StgTopLifted (StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ]))
+  where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ]
+
+stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs
+stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body)
+    = let body' = stgCseExpr (initEnv in_scope) body
+      in  StgRhsClosure ext ccs upd args body'
+stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args)
+    = StgRhsCon ccs dataCon args
+
+------------------------------
+-- The actual AST traversal --
+------------------------------
+
+-- Trivial cases
+stgCseExpr :: CseEnv -> InStgExpr -> OutStgExpr
+stgCseExpr env (StgApp fun args)
+    = StgApp fun' args'
+  where fun' = substVar env fun
+        args' = substArgs env args
+stgCseExpr _ (StgLit lit)
+    = StgLit lit
+stgCseExpr env (StgOpApp op args tys)
+    = StgOpApp op args' tys
+  where args' = substArgs env args
+stgCseExpr _ (StgLam _ _)
+    = pprPanic "stgCseExp" (text "StgLam")
+stgCseExpr env (StgTick tick body)
+    = let body' = stgCseExpr env body
+      in StgTick tick body'
+stgCseExpr env (StgCase scrut bndr ty alts)
+    = mkStgCase scrut' bndr' ty alts'
+  where
+    scrut' = stgCseExpr env scrut
+    (env1, bndr') = substBndr env bndr
+    env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1
+                 -- See Note [Trivial case scrutinee]
+         | otherwise                         = env1
+    alts' = map (stgCseAlt env2 ty bndr') alts
+
+
+-- A constructor application.
+-- To be removed by a variable use when found in the CSE environment
+stgCseExpr env (StgConApp dataCon args tys)
+    | Just bndr' <- envLookup dataCon args' env
+    = StgApp bndr' []
+    | otherwise
+    = StgConApp dataCon args' tys
+  where args' = substArgs env args
+
+-- Let bindings
+-- The binding might be removed due to CSE (we do not want trivial bindings on
+-- the STG level), so use the smart constructor `mkStgLet` to remove the binding
+-- if empty.
+stgCseExpr env (StgLet ext binds body)
+    = let (binds', env') = stgCseBind env binds
+          body' = stgCseExpr env' body
+      in mkStgLet (StgLet ext) binds' body'
+stgCseExpr env (StgLetNoEscape ext binds body)
+    = let (binds', env') = stgCseBind env binds
+          body' = stgCseExpr env' body
+      in mkStgLet (StgLetNoEscape ext) binds' body'
+
+-- Case alternatives
+-- Extend the CSE environment
+stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt
+stgCseAlt env ty case_bndr (DataAlt dataCon, args, rhs)
+    = let (env1, args') = substBndrs env args
+          env2
+            -- To avoid dealing with unboxed sums StgCse runs after unarise and
+            -- should maintain invariants listed in Note [Post-unarisation
+            -- invariants]. One of the invariants is that some binders are not
+            -- used (unboxed tuple case binders) which is what we check with
+            -- `stgCaseBndrInScope` here. If the case binder is not in scope we
+            -- don't add it to the CSE env. See also #15300.
+            | stgCaseBndrInScope ty True -- CSE runs after unarise
+            = addDataCon case_bndr dataCon (map StgVarArg args') env1
+            | otherwise
+            = env1
+            -- see note [Case 2: CSEing case binders]
+          rhs' = stgCseExpr env2 rhs
+      in (DataAlt dataCon, args', rhs')
+stgCseAlt env _ _ (altCon, args, rhs)
+    = let (env1, args') = substBndrs env args
+          rhs' = stgCseExpr env1 rhs
+      in (altCon, args', rhs')
+
+-- Bindings
+stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv)
+stgCseBind env (StgNonRec b e)
+    = let (env1, b') = substBndr env b
+      in case stgCseRhs env1 b' e of
+        (Nothing,      env2) -> (Nothing,                env2)
+        (Just (b2,e'), env2) -> (Just (StgNonRec b2 e'), env2)
+stgCseBind env (StgRec pairs)
+    = let (env1, pairs1) = substPairs env pairs
+      in case stgCsePairs env1 pairs1 of
+        ([],     env2) -> (Nothing, env2)
+        (pairs2, env2) -> (Just (StgRec pairs2), env2)
+
+stgCsePairs :: CseEnv -> [(OutId, InStgRhs)] -> ([(OutId, OutStgRhs)], CseEnv)
+stgCsePairs env [] = ([], env)
+stgCsePairs env0 ((b,e):pairs)
+  = let (pairMB, env1) = stgCseRhs env0 b e
+        (pairs', env2) = stgCsePairs env1 pairs
+    in (pairMB `mbCons` pairs', env2)
+  where
+    mbCons = maybe id (:)
+
+-- The RHS of a binding.
+-- If it is a constructor application, either short-cut it or extend the environment
+stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv)
+stgCseRhs env bndr (StgRhsCon ccs dataCon args)
+    | Just other_bndr <- envLookup dataCon args' env
+    = let env' = addSubst bndr other_bndr env
+      in (Nothing, env')
+    | otherwise
+    = let env' = addDataCon bndr dataCon args' env
+            -- see note [Case 1: CSEing allocated closures]
+          pair = (bndr, StgRhsCon ccs dataCon args')
+      in (Just pair, env')
+  where args' = substArgs env args
+stgCseRhs env bndr (StgRhsClosure ext ccs upd args body)
+    = let (env1, args') = substBndrs env args
+          env2 = forgetCse env1 -- See note [Free variables of an StgClosure]
+          body' = stgCseExpr env2 body
+      in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env)
+
+
+mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr
+mkStgCase scrut bndr ty alts | all isBndr alts = scrut
+                             | otherwise       = StgCase scrut bndr ty alts
+
+  where
+    -- see Note [All alternatives are the binder]
+    isBndr (_, _, StgApp f []) = f == bndr
+    isBndr _                   = False
+
+
+-- Utilities
+
+-- | This function short-cuts let-bindings that are now obsolete
+mkStgLet :: (a -> b -> b) -> Maybe a -> b -> b
+mkStgLet _      Nothing      body = body
+mkStgLet stgLet (Just binds) body = stgLet binds body
+
+
+{-
+Note [All alternatives are the binder]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When all alternatives simply refer to the case binder, then we do not have
+to bother with the case expression at all (#13588). CoreSTG does this as well,
+but sometimes, types get into the way:
+
+    newtype T = MkT Int
+    f :: (Int, Int) -> (T, Int)
+    f (x, y) = (MkT x, y)
+
+Core cannot just turn this into
+
+    f p = p
+
+as this would not be well-typed. But to STG, where MkT is no longer in the way,
+we can.
+
+Note [Trivial case scrutinee]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to be able to handle nested reconstruction of constructors as in
+
+    nested :: Either Int (Either Int a) -> Either Bool (Either Bool a)
+    nested (Right (Right v)) = Right (Right v)
+    nested _ = Left True
+
+So if we come across
+
+    case x of r1
+      Right a -> case a of r2
+              Right b -> let v = Right b
+                         in Right v
+
+we first replace v with r2. Next we want to replace Right r2 with r1. But the
+ce_conAppMap contains Right a!
+
+Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use
+this substitution before looking Right r2 up in ce_conAppMap, and everything
+works out.
+
+Note [Free variables of an StgClosure]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+StgClosures (function and thunks) have an explicit list of free variables:
+
+foo [x] =
+    let not_a_free_var = Left [x]
+    let a_free_var = Right [x]
+    let closure = \[x a_free_var] -> \[y] -> bar y (Left [x]) a_free_var
+    in closure
+
+If we were to CSE `Left [x]` in the body of `closure` with `not_a_free_var`,
+then the list of free variables would be wrong, so for now, we do not CSE
+across such a closure, simply because I (Joachim) was not sure about possible
+knock-on effects. If deemed safe and worth the slight code complication of
+re-calculating this list during or after this pass, this can surely be done.
+-}
diff --git a/compiler/simplStg/StgLiftLams.hs b/compiler/simplStg/StgLiftLams.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/StgLiftLams.hs
@@ -0,0 +1,102 @@
+-- | Implements a selective lambda lifter, running late in the optimisation
+-- pipeline.
+--
+-- The transformation itself is implemented in "StgLiftLams.Transformation".
+-- If you are interested in the cost model that is employed to decide whether
+-- to lift a binding or not, look at "StgLiftLams.Analysis".
+-- "StgLiftLams.LiftM" contains the transformation monad that hides away some
+-- plumbing of the transformation.
+module StgLiftLams (
+    -- * Late lambda lifting in STG
+    -- $note
+    Transformation.stgLiftLams
+  ) where
+
+import qualified StgLiftLams.Transformation as Transformation
+
+-- Note [Late lambda lifting in STG]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- $note
+-- See also the <https://ghc.haskell.org/trac/ghc/wiki/LateLamLift wiki page>
+-- and Trac #9476.
+--
+-- The basic idea behind lambda lifting is to turn locally defined functions
+-- into top-level functions. Free variables are then passed as additional
+-- arguments at *call sites* instead of having a closure allocated for them at
+-- *definition site*. Example:
+--
+-- @
+--    let x = ...; y = ... in
+--    let f = {x y} \a -> a + x + y in
+--    let g = {f x} \b -> f b + x in
+--    g 5
+-- @
+--
+-- Lambda lifting @f@ would
+--
+--   1. Turn @f@'s free variables into formal parameters
+--   2. Update @f@'s call site within @g@ to @f x y b@
+--   3. Update @g@'s closure: Add @y@ as an additional free variable, while
+--      removing @f@, because @f@ no longer allocates and can be floated to
+--      top-level.
+--   4. Actually float the binding of @f@ to top-level, eliminating the @let@
+--      in the process.
+--
+-- This results in the following program (with free var annotations):
+--
+-- @
+--    f x y a = a + x + y;
+--    let x = ...; y = ... in
+--    let g = {x y} \b -> f x y b + x in
+--    g 5
+-- @
+--
+-- This optimisation is all about lifting only when it is beneficial to do so.
+-- The above seems like a worthwhile lift, judging from heap allocation:
+-- We eliminate @f@'s closure, saving to allocate a closure with 2 words, while
+-- not changing the size of @g@'s closure.
+--
+-- You can probably sense that there's some kind of cost model at play here.
+-- And you are right! But we also employ a couple of other heuristics for the
+-- lifting decision which are outlined in "StgLiftLams.Analysis#when".
+--
+-- The transformation is done in "StgLiftLams.Transformation", which calls out
+-- to 'StgLiftLams.Analysis.goodToLift' for its lifting decision.
+-- It relies on "StgLiftLams.LiftM", which abstracts some subtle STG invariants
+-- into a monadic substrate.
+--
+-- Suffice to say: We trade heap allocation for stack allocation.
+-- The additional arguments have to passed on the stack (or in registers,
+-- depending on architecture) every time we call the function to save a single
+-- heap allocation when entering the let binding. Nofib suggests a mean
+-- improvement of about 1% for this pass, so it seems like a worthwhile thing to
+-- do. Compile-times went up by 0.6%, so all in all a very modest change.
+--
+-- For a concrete example, look at @spectral/atom@. There's a call to 'zipWith'
+-- that is ultimately compiled to something like this
+-- (module desugaring/lowering to actual STG):
+--
+-- @
+--    propagate dt = ...;
+--    runExperiment ... =
+--      let xs = ... in
+--      let ys = ... in
+--      let go = {dt go} \xs ys -> case (xs, ys) of
+--            ([], []) -> []
+--            (x:xs', y:ys') -> propagate dt x y : go xs' ys'
+--      in go xs ys
+-- @
+--
+-- This will lambda lift @go@ to top-level, speeding up the resulting program
+-- by roughly one percent:
+--
+-- @
+--    propagate dt = ...;
+--    go dt xs ys = case (xs, ys) of
+--      ([], []) -> []
+--      (x:xs', y:ys') -> propagate dt x y : go dt xs' ys'
+--    runExperiment ... =
+--      let xs = ... in
+--      let ys = ... in
+--      in go dt xs ys
+-- @
diff --git a/compiler/simplStg/StgLiftLams/Analysis.hs b/compiler/simplStg/StgLiftLams/Analysis.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/StgLiftLams/Analysis.hs
@@ -0,0 +1,566 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DataKinds #-}
+
+-- | Provides the heuristics for when it's beneficial to lambda lift bindings.
+-- Most significantly, this employs a cost model to estimate impact on heap
+-- allocations, by looking at an STG expression's 'Skeleton'.
+module StgLiftLams.Analysis (
+    -- * #when# When to lift
+    -- $when
+
+    -- * #clogro# Estimating closure growth
+    -- $clogro
+
+    -- * AST annotation
+    Skeleton(..), BinderInfo(..), binderInfoBndr,
+    LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, tagSkeletonTopBind,
+    -- * Lifting decision
+    goodToLift,
+    closureGrowth -- Exported just for the docs
+  ) where
+
+import GhcPrelude
+
+import BasicTypes
+import Demand
+import DynFlags
+import Id
+import SMRep ( WordOff )
+import StgSyn
+import qualified StgCmmArgRep
+import qualified StgCmmClosure
+import qualified StgCmmLayout
+import Outputable
+import Util
+import VarSet
+
+import Data.Maybe ( mapMaybe )
+
+-- Note [When to lift]
+-- ~~~~~~~~~~~~~~~~~~~
+-- $when
+-- The analysis proceeds in two steps:
+--
+--   1. It tags the syntax tree with analysis information in the form of
+--      'BinderInfo' at each binder and 'Skeleton's at each let-binding
+--      by 'tagSkeletonTopBind' and friends.
+--   2. The resulting syntax tree is treated by the "StgLiftLams.Transformation"
+--      module, calling out to 'goodToLift' to decide if a binding is worthwhile
+--      to lift.
+--      'goodToLift' consults argument occurrence information in 'BinderInfo'
+--      and estimates 'closureGrowth', for which it needs the 'Skeleton'.
+--
+-- So the annotations from 'tagSkeletonTopBind' ultimately fuel 'goodToLift',
+-- which employs a number of heuristics to identify and exclude lambda lifting
+-- opportunities deemed non-beneficial:
+--
+--  [Top-level bindings] can't be lifted.
+--  [Thunks] and data constructors shouldn't be lifted in order not to destroy
+--    sharing.
+--  [Argument occurrences] #arg_occs# of binders prohibit them to be lifted.
+--    Doing the lift would re-introduce the very allocation at call sites that
+--    we tried to get rid off in the first place. We capture analysis
+--    information in 'BinderInfo'. Note that we also consider a nullary
+--    application as argument occurrence, because it would turn into an n-ary
+--    partial application created by a generic apply function. This occurs in
+--    CPS-heavy code like the CS benchmark.
+--  [Join points] should not be lifted, simply because there's no reduction in
+--    allocation to be had.
+--  [Abstracting over join points] destroys join points, because they end up as
+--    arguments to the lifted function.
+--  [Abstracting over known local functions] turns a known call into an unknown
+--    call (e.g. some @stg_ap_*@), which is generally slower. Can be turned off
+--    with @-fstg-lift-lams-known@.
+--  [Calling convention] Don't lift when the resulting function would have a
+--    higher arity than available argument registers for the calling convention.
+--    Can be influenced with @-fstg-lift-(non)rec-args(-any)@.
+--  [Closure growth] introduced when former free variables have to be available
+--    at call sites may actually lead to an increase in overall allocations
+--  resulting from a lift. Estimating closure growth is described in
+--  "StgLiftLams.Analysis#clogro" and is what most of this module is ultimately
+--  concerned with.
+--
+-- There's a <https://ghc.haskell.org/trac/ghc/wiki/LateLamLift wiki page> with
+-- some more background and history.
+
+-- Note [Estimating closure growth]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- $clogro
+-- We estimate closure growth by abstracting the syntax tree into a 'Skeleton',
+-- capturing only syntactic details relevant to 'closureGrowth', such as
+--
+--   * 'ClosureSk', representing closure allocation.
+--   * 'RhsSk', representing a RHS of a binding and how many times it's called
+--     by an appropriate 'DmdShell'.
+--   * 'AltSk', 'BothSk' and 'NilSk' for choice, sequence and empty element.
+--
+-- This abstraction is mostly so that the main analysis function 'closureGrowth'
+-- can stay simple and focused. Also, skeletons tend to be much smaller than
+-- the syntax tree they abstract, so it makes sense to construct them once and
+-- and operate on them instead of the actual syntax tree.
+--
+-- A more detailed treatment of computing closure growth, including examples,
+-- can be found in the paper referenced from the
+-- <https://ghc.haskell.org/trac/ghc/wiki/LateLamLift wiki page>.
+
+llTrace :: String -> SDoc -> a -> a
+llTrace _ _ c = c
+-- llTrace a b c = pprTrace a b c
+
+type instance BinderP      'LiftLams = BinderInfo
+type instance XRhsClosure  'LiftLams = DIdSet
+type instance XLet         'LiftLams = Skeleton
+type instance XLetNoEscape 'LiftLams = Skeleton
+
+freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet
+freeVarsOfRhs (StgRhsCon _ _ args) = mkDVarSet [ id | StgVarArg id <- args ]
+freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs
+
+-- | Captures details of the syntax tree relevant to the cost model, such as
+-- closures, multi-shot lambdas and case expressions.
+data Skeleton
+  = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton
+  | RhsSk !DmdShell {- ^ how often the RHS was entered -} !Skeleton
+  | AltSk !Skeleton !Skeleton
+  | BothSk !Skeleton !Skeleton
+  | NilSk
+
+bothSk :: Skeleton -> Skeleton -> Skeleton
+bothSk NilSk b = b
+bothSk a NilSk = a
+bothSk a b     = BothSk a b
+
+altSk :: Skeleton -> Skeleton -> Skeleton
+altSk NilSk b = b
+altSk a NilSk = a
+altSk a b     = AltSk a b
+
+rhsSk :: DmdShell -> Skeleton -> Skeleton
+rhsSk _        NilSk = NilSk
+rhsSk body_dmd skel  = RhsSk body_dmd skel
+
+-- | The type used in binder positions in 'GenStgExpr's.
+data BinderInfo
+  = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag
+                           --   indicating whether it occurs as an argument
+                           --   or in a nullary application
+                           --   (see "StgLiftLams.Analysis#arg_occs").
+  | BoringBinder !Id       -- ^ Every other kind of binder
+
+-- | Gets the bound 'Id' out a 'BinderInfo'.
+binderInfoBndr :: BinderInfo -> Id
+binderInfoBndr (BoringBinder bndr)   = bndr
+binderInfoBndr (BindsClosure bndr _) = bndr
+
+-- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating
+-- occurrences as argument or in a nullary applications otherwise.
+binderInfoOccursAsArg :: BinderInfo -> Maybe Bool
+binderInfoOccursAsArg BoringBinder{}     = Nothing
+binderInfoOccursAsArg (BindsClosure _ b) = Just b
+
+instance Outputable Skeleton where
+  ppr NilSk = text ""
+  ppr (AltSk l r) = vcat
+    [ text "{ " <+> ppr l
+    , text "ALT"
+    , text "  " <+> ppr r
+    , text "}"
+    ]
+  ppr (BothSk l r) = ppr l $$ ppr r
+  ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body)
+  ppr (RhsSk body_dmd body) = hcat
+    [ text "λ["
+    , ppr str
+    , text ", "
+    , ppr use
+    , text "]. "
+    , ppr body
+    ]
+    where
+      str
+        | isStrictDmd body_dmd = '1'
+        | otherwise = '0'
+      use
+        | isAbsDmd body_dmd = '0'
+        | isUsedOnce body_dmd = '1'
+        | otherwise = 'ω'
+
+instance Outputable BinderInfo where
+  ppr = ppr . binderInfoBndr
+
+instance OutputableBndr BinderInfo where
+  pprBndr b = pprBndr b . binderInfoBndr
+  pprPrefixOcc = pprPrefixOcc . binderInfoBndr
+  pprInfixOcc = pprInfixOcc . binderInfoBndr
+  bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr
+
+mkArgOccs :: [StgArg] -> IdSet
+mkArgOccs = mkVarSet . mapMaybe stg_arg_var
+  where
+    stg_arg_var (StgVarArg occ) = Just occ
+    stg_arg_var _               = Nothing
+
+-- | Tags every binder with its 'BinderInfo' and let bindings with their
+-- 'Skeleton's.
+tagSkeletonTopBind :: CgStgBinding -> LlStgBinding
+-- NilSk is OK when tagging top-level bindings. Also, top-level things are never
+-- lambda-lifted, so no need to track their argument occurrences. They can also
+-- never be let-no-escapes (thus we pass False).
+tagSkeletonTopBind bind = bind'
+  where
+    (_, _, _, bind') = tagSkeletonBinding False NilSk emptyVarSet bind
+
+-- | Tags binders of an 'StgExpr' with its 'BinderInfo' and let bindings with
+-- their 'Skeleton's. Additionally, returns its 'Skeleton' and the set of binder
+-- occurrences in argument and nullary application position
+-- (cf. "StgLiftLams.Analysis#arg_occs").
+tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr)
+tagSkeletonExpr (StgLit lit)
+  = (NilSk, emptyVarSet, StgLit lit)
+tagSkeletonExpr (StgConApp con args tys)
+  = (NilSk, mkArgOccs args, StgConApp con args tys)
+tagSkeletonExpr (StgOpApp op args ty)
+  = (NilSk, mkArgOccs args, StgOpApp op args ty)
+tagSkeletonExpr (StgApp f args)
+  = (NilSk, arg_occs, StgApp f args)
+  where
+    arg_occs
+      -- This checks for nullary applications, which we treat the same as
+      -- argument occurrences, see "StgLiftLams.Analysis#arg_occs".
+      | null args = unitVarSet f
+      | otherwise = mkArgOccs args
+tagSkeletonExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam")
+tagSkeletonExpr (StgCase scrut bndr ty alts)
+  = (skel, arg_occs, StgCase scrut' bndr' ty alts')
+  where
+    (scrut_skel, scrut_arg_occs, scrut') = tagSkeletonExpr scrut
+    (alt_skels, alt_arg_occss, alts') = mapAndUnzip3 tagSkeletonAlt alts
+    skel = bothSk scrut_skel (foldr altSk NilSk alt_skels)
+    arg_occs = unionVarSets (scrut_arg_occs:alt_arg_occss) `delVarSet` bndr
+    bndr' = BoringBinder bndr
+tagSkeletonExpr (StgTick t e)
+  = (skel, arg_occs, StgTick t e')
+  where
+    (skel, arg_occs, e') = tagSkeletonExpr e
+tagSkeletonExpr (StgLet _ bind body) = tagSkeletonLet False body bind
+tagSkeletonExpr (StgLetNoEscape _ bind body) = tagSkeletonLet True body bind
+
+mkLet :: Bool -> Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr
+mkLet True = StgLetNoEscape
+mkLet _    = StgLet
+
+tagSkeletonLet
+  :: Bool
+  -- ^ Is the binding a let-no-escape?
+  -> CgStgExpr
+  -- ^ Let body
+  -> CgStgBinding
+  -- ^ Binding group
+  -> (Skeleton, IdSet, LlStgExpr)
+  -- ^ RHS skeletons, argument occurrences and annotated binding
+tagSkeletonLet is_lne body bind
+  = (let_skel, arg_occs, mkLet is_lne scope bind' body')
+  where
+    (body_skel, body_arg_occs, body') = tagSkeletonExpr body
+    (let_skel, arg_occs, scope, bind')
+      = tagSkeletonBinding is_lne body_skel body_arg_occs bind
+
+tagSkeletonBinding
+  :: Bool
+  -- ^ Is the binding a let-no-escape?
+  -> Skeleton
+  -- ^ Let body skeleton
+  -> IdSet
+  -- ^ Argument occurrences in the body
+  -> CgStgBinding
+  -- ^ Binding group
+  -> (Skeleton, IdSet, Skeleton, LlStgBinding)
+  -- ^ Let skeleton, argument occurrences, scope skeleton of binding and
+  --   the annotated binding
+tagSkeletonBinding is_lne body_skel body_arg_occs (StgNonRec bndr rhs)
+  = (let_skel, arg_occs, scope, bind')
+  where
+    (rhs_skel, rhs_arg_occs, rhs') = tagSkeletonRhs bndr rhs
+    arg_occs = (body_arg_occs `unionVarSet` rhs_arg_occs) `delVarSet` bndr
+    bind_skel
+      | is_lne    = rhs_skel -- no closure is allocated for let-no-escapes
+      | otherwise = ClosureSk bndr (freeVarsOfRhs rhs) rhs_skel
+    let_skel = bothSk body_skel bind_skel
+    occurs_as_arg = bndr `elemVarSet` body_arg_occs
+    -- Compared to the recursive case, this exploits the fact that @bndr@ is
+    -- never free in @rhs@.
+    scope = body_skel
+    bind' = StgNonRec (BindsClosure bndr occurs_as_arg) rhs'
+tagSkeletonBinding is_lne body_skel body_arg_occs (StgRec pairs)
+  = (let_skel, arg_occs, scope, StgRec pairs')
+  where
+    (bndrs, _) = unzip pairs
+    -- Local recursive STG bindings also regard the defined binders as free
+    -- vars. We want to delete those for our cost model, as these are known
+    -- calls anyway when we add them to the same top-level recursive group as
+    -- the top-level binding currently being analysed.
+    skel_occs_rhss' = map (uncurry tagSkeletonRhs) pairs
+    rhss_arg_occs = map sndOf3 skel_occs_rhss'
+    scope_occs = unionVarSets (body_arg_occs:rhss_arg_occs)
+    arg_occs = scope_occs `delVarSetList` bndrs
+    -- @skel_rhss@ aren't yet wrapped in closures. We'll do that in a moment,
+    -- but we also need the un-wrapped skeletons for calculating the @scope@
+    -- of the group, as the outer closures don't contribute to closure growth
+    -- when we lift this specific binding.
+    scope = foldr (bothSk . fstOf3) body_skel skel_occs_rhss'
+    -- Now we can build the actual Skeleton for the expression just by
+    -- iterating over each bind pair.
+    (bind_skels, pairs') = unzip (zipWith single_bind bndrs skel_occs_rhss')
+    let_skel = foldr bothSk body_skel bind_skels
+    single_bind bndr (skel_rhs, _, rhs') = (bind_skel, (bndr', rhs'))
+      where
+        -- Here, we finally add the closure around each @skel_rhs@.
+        bind_skel
+          | is_lne    = skel_rhs -- no closure is allocated for let-no-escapes
+          | otherwise = ClosureSk bndr fvs skel_rhs
+        fvs = freeVarsOfRhs rhs' `dVarSetMinusVarSet` mkVarSet bndrs
+        bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs)
+
+tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs)
+tagSkeletonRhs _ (StgRhsCon ccs dc args)
+  = (NilSk, mkArgOccs args, StgRhsCon ccs dc args)
+tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body)
+  = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body')
+  where
+    bndrs' = map BoringBinder bndrs
+    (body_skel, body_arg_occs, body') = tagSkeletonExpr body
+    rhs_skel = rhsSk (rhsDmdShell bndr) body_skel
+
+-- | How many times will the lambda body of the RHS bound to the given
+-- identifier be evaluated, relative to its defining context? This function
+-- computes the answer in form of a 'DmdShell'.
+rhsDmdShell :: Id -> DmdShell
+rhsDmdShell bndr
+  | is_thunk = oneifyDmd ds
+  | otherwise = peelManyCalls (idArity bndr) cd
+  where
+    is_thunk = idArity bndr == 0
+    -- Let's pray idDemandInfo is still OK after unarise...
+    (ds, cd) = toCleanDmd (idDemandInfo bndr)
+
+tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt)
+tagSkeletonAlt (con, bndrs, rhs)
+  = (alt_skel, arg_occs, (con, map BoringBinder bndrs, rhs'))
+  where
+    (alt_skel, alt_arg_occs, rhs') = tagSkeletonExpr rhs
+    arg_occs = alt_arg_occs `delVarSetList` bndrs
+
+-- | Combines several heuristics to decide whether to lambda-lift a given
+-- @let@-binding to top-level. See "StgLiftLams.Analysis#when" for details.
+goodToLift
+  :: DynFlags
+  -> TopLevelFlag
+  -> RecFlag
+  -> (DIdSet -> DIdSet) -- ^ An expander function, turning 'InId's into
+                        -- 'OutId's. See 'StgLiftLams.LiftM.liftedIdsExpander'.
+  -> [(BinderInfo, LlStgRhs)]
+  -> Skeleton
+  -> Maybe DIdSet       -- ^ @Just abs_ids@ <=> This binding is beneficial to
+                        -- lift and @abs_ids@ are the variables it would
+                        -- abstract over
+goodToLift dflags top_lvl rec_flag expander pairs scope = decide
+  [ ("top-level", isTopLevel top_lvl) -- keep in sync with Note [When to lift]
+  , ("memoized", any_memoized)
+  , ("argument occurrences", arg_occs)
+  , ("join point", is_join_point)
+  , ("abstracts join points", abstracts_join_ids)
+  , ("abstracts known local function", abstracts_known_local_fun)
+  , ("args spill on stack", args_spill_on_stack)
+  , ("increases allocation", inc_allocs)
+  ] where
+      decide deciders
+        | not (fancy_or deciders)
+        = llTrace "stgLiftLams:lifting"
+                  (ppr bndrs <+> ppr abs_ids $$
+                   ppr allocs $$
+                   ppr scope) $
+          Just abs_ids
+        | otherwise
+        = Nothing
+      ppr_deciders = vcat . map (text . fst) . filter snd
+      fancy_or deciders
+        = llTrace "stgLiftLams:goodToLift" (ppr bndrs $$ ppr_deciders deciders) $
+          any snd deciders
+
+      bndrs = map (binderInfoBndr . fst) pairs
+      bndrs_set = mkVarSet bndrs
+      rhss = map snd pairs
+
+      -- First objective: Calculate @abs_ids@, e.g. the former free variables
+      -- the lifted binding would abstract over. We have to merge the free
+      -- variables of all RHS to get the set of variables that will have to be
+      -- passed through parameters.
+      fvs = unionDVarSets (map freeVarsOfRhs rhss)
+      -- To lift the binding to top-level, we want to delete the lifted binders
+      -- themselves from the free var set. Local let bindings track recursive
+      -- occurrences in their free variable set. We neither want to apply our
+      -- cost model to them (see 'tagSkeletonRhs'), nor pass them as parameters
+      -- when lifted, as these are known calls. We call the resulting set the
+      -- identifiers we abstract over, thus @abs_ids@. These are all 'OutId's.
+      -- We will save the set in 'LiftM.e_expansions' for each of the variables
+      -- if we perform the lift.
+      abs_ids = expander (delDVarSetList fvs bndrs)
+
+      -- We don't lift updatable thunks or constructors
+      any_memoized = any is_memoized_rhs rhss
+      is_memoized_rhs StgRhsCon{} = True
+      is_memoized_rhs (StgRhsClosure _ _ upd _ _) = isUpdatable upd
+
+      -- Don't lift binders occuring as arguments. This would result in complex
+      -- argument expressions which would have to be given a name, reintroducing
+      -- the very allocation at each call site that we wanted to get rid off in
+      -- the first place.
+      arg_occs = or (mapMaybe (binderInfoOccursAsArg . fst) pairs)
+
+      -- These don't allocate anyway.
+      is_join_point = any isJoinId bndrs
+
+      -- Abstracting over join points/let-no-escapes spoils them.
+      abstracts_join_ids = any isJoinId (dVarSetElems abs_ids)
+
+      -- Abstracting over known local functions that aren't floated themselves
+      -- turns a known, fast call into an unknown, slow call:
+      --
+      --    let f x = ...
+      --        g y = ... f x ... -- this was a known call
+      --    in g 4
+      --
+      -- After lifting @g@, but not @f@:
+      --
+      --    l_g f y = ... f y ... -- this is now an unknown call
+      --    let f x = ...
+      --    in l_g f 4
+      --
+      -- We can abuse the results of arity analysis for this:
+      -- idArity f > 0 ==> known
+      known_fun id = idArity id > 0
+      abstracts_known_local_fun
+        = not (liftLamsKnown dflags) && any known_fun (dVarSetElems abs_ids)
+
+      -- Number of arguments of a RHS in the current binding group if we decide
+      -- to lift it
+      n_args
+        = length
+        . StgCmmClosure.nonVoidIds -- void parameters don't appear in Cmm
+        . (dVarSetElems abs_ids ++)
+        . rhsLambdaBndrs
+      max_n_args
+        | isRec rec_flag = liftLamsRecArgs dflags
+        | otherwise      = liftLamsNonRecArgs dflags
+      -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess
+      -- args are passed on the stack, which means slow memory accesses
+      args_spill_on_stack
+        | Just n <- max_n_args = maximum (map n_args rhss) > n
+        | otherwise = False
+
+      -- We only perform the lift if allocations didn't increase.
+      -- Note that @clo_growth@ will be 'infinity' if there was positive growth
+      -- under a multi-shot lambda.
+      -- Also, abstracting over LNEs is unacceptable. LNEs might return
+      -- unlifted tuples, which idClosureFootprint can't cope with.
+      inc_allocs = abstracts_join_ids || allocs > 0
+      allocs = clo_growth + mkIntWithInf (negate closuresSize)
+      -- We calculate and then add up the size of each binding's closure.
+      -- GHC does not currently share closure environments, and we either lift
+      -- the entire recursive binding group or none of it.
+      closuresSize = sum $ flip map rhss $ \rhs ->
+        closureSize dflags
+        . dVarSetElems
+        . expander
+        . flip dVarSetMinusVarSet bndrs_set
+        $ freeVarsOfRhs rhs
+      clo_growth = closureGrowth expander (idClosureFootprint dflags) bndrs_set abs_ids scope
+
+rhsLambdaBndrs :: LlStgRhs -> [Id]
+rhsLambdaBndrs StgRhsCon{} = []
+rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _) = map binderInfoBndr bndrs
+
+-- | The size in words of a function closure closing over the given 'Id's,
+-- including the header.
+closureSize :: DynFlags -> [Id] -> WordOff
+closureSize dflags ids = words
+  where
+    (words, _, _)
+      -- Functions have a StdHeader (as opposed to ThunkHeader).
+      -- Note that mkVirtHeadOffsets will account for profiling headers, so
+      -- lifting decisions vary if we begin to profile stuff. Maybe we shouldn't
+      -- do this or deactivate profiling in @dflags@?
+      = StgCmmLayout.mkVirtHeapOffsets dflags StgCmmLayout.StdHeader
+      . StgCmmClosure.addIdReps
+      . StgCmmClosure.nonVoidIds
+      $ ids
+
+-- | The number of words a single 'Id' adds to a closure's size.
+-- Note that this can't handle unboxed tuples (which may still be present in
+-- let-no-escapes, even after Unarise), in which case
+-- @'StgCmmClosure.idPrimRep'@ will crash.
+idClosureFootprint:: DynFlags -> Id -> WordOff
+idClosureFootprint dflags
+  = StgCmmArgRep.argRepSizeW dflags
+  . StgCmmArgRep.idArgRep
+
+-- | @closureGrowth expander sizer f fvs@ computes the closure growth in words
+-- as a result of lifting @f@ to top-level. If there was any growing closure
+-- under a multi-shot lambda, the result will be 'infinity'.
+-- Also see "StgLiftLams.Analysis#clogro".
+closureGrowth
+  :: (DIdSet -> DIdSet)
+  -- ^ Expands outer free ids that were lifted to their free vars
+  -> (Id -> Int)
+  -- ^ Computes the closure footprint of an identifier
+  -> IdSet
+  -- ^ Binding group for which lifting is to be decided
+  -> DIdSet
+  -- ^ Free vars of the whole binding group prior to lifting it. These must be
+  --   available at call sites if we decide to lift the binding group.
+  -> Skeleton
+  -- ^ Abstraction of the scope of the function
+  -> IntWithInf
+  -- ^ Closure growth. 'infinity' indicates there was growth under a
+  --   (multi-shot) lambda.
+closureGrowth expander sizer group abs_ids = go
+  where
+    go NilSk = 0
+    go (BothSk a b) = go a + go b
+    go (AltSk a b) = max (go a) (go b)
+    go (ClosureSk _ clo_fvs rhs)
+      -- If no binder of the @group@ occurs free in the closure, the lifting
+      -- won't have any effect on it and we can omit the recursive call.
+      | n_occs == 0 = 0
+      -- Otherwise, we account the cost of allocating the closure and add it to
+      -- the closure growth of its RHS.
+      | otherwise   = mkIntWithInf cost + go rhs
+      where
+        n_occs = sizeDVarSet (clo_fvs' `dVarSetIntersectVarSet` group)
+        -- What we close over considering prior lifting decisions
+        clo_fvs' = expander clo_fvs
+        -- Variables that would additionally occur free in the closure body if
+        -- we lift @f@
+        newbies = abs_ids `minusDVarSet` clo_fvs'
+        -- Lifting @f@ removes @f@ from the closure but adds all @newbies@
+        cost = foldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs
+    go (RhsSk body_dmd body)
+      -- The conservative assumption would be that
+      --   1. Every RHS with positive growth would be called multiple times,
+      --      modulo thunks.
+      --   2. Every RHS with negative growth wouldn't be called at all.
+      --
+      -- In the first case, we'd have to return 'infinity', while in the
+      -- second case, we'd have to return 0. But we can do far better
+      -- considering information from the demand analyser, which provides us
+      -- with conservative estimates on minimum and maximum evaluation
+      -- cardinality. The @body_dmd@ part of 'RhsSk' is the result of
+      -- 'rhsDmdShell' and accurately captures the cardinality of the RHSs body
+      -- relative to its defining context.
+      | isAbsDmd body_dmd   = 0
+      | cg <= 0             = if isStrictDmd body_dmd then cg else 0
+      | isUsedOnce body_dmd = cg
+      | otherwise           = infinity
+      where
+        cg = go body
diff --git a/compiler/simplStg/StgLiftLams/LiftM.hs b/compiler/simplStg/StgLiftLams/LiftM.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/StgLiftLams/LiftM.hs
@@ -0,0 +1,348 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | Hides away distracting bookkeeping while lambda lifting into a 'LiftM'
+-- monad.
+module StgLiftLams.LiftM (
+    decomposeStgBinding, mkStgBinding,
+    Env (..),
+    -- * #floats# Handling floats
+    -- $floats
+    FloatLang (..), collectFloats, -- Exported just for the docs
+    -- * Transformation monad
+    LiftM, runLiftM, withCaffyness,
+    -- ** Adding bindings
+    startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding,
+    -- ** Substitution and binders
+    withSubstBndr, withSubstBndrs, withLiftedBndr, withLiftedBndrs,
+    -- ** Occurrences
+    substOcc, isLifted, formerFreeVars, liftedIdsExpander
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import BasicTypes
+import CostCentre ( isCurrentCCS, dontCareCCS )
+import DynFlags
+import FastString
+import Id
+import IdInfo
+import Name
+import Outputable
+import OrdList
+import StgSubst
+import StgSyn
+import Type
+import UniqSupply
+import Util
+import VarEnv
+import VarSet
+
+import Control.Arrow ( second )
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.RWS.Strict ( RWST, runRWST )
+import qualified Control.Monad.Trans.RWS.Strict as RWS
+import Control.Monad.Trans.Cont ( ContT (..) )
+import Data.ByteString ( ByteString )
+
+-- | @uncurry 'mkStgBinding' . 'decomposeStgBinding' = id@
+decomposeStgBinding :: GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)])
+decomposeStgBinding (StgRec pairs) = (Recursive, pairs)
+decomposeStgBinding (StgNonRec bndr rhs) = (NonRecursive, [(bndr, rhs)])
+
+mkStgBinding :: RecFlag -> [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass
+mkStgBinding Recursive = StgRec
+mkStgBinding NonRecursive = uncurry StgNonRec . head
+
+-- | Environment threaded around in a scoped, @Reader@-like fashion.
+data Env
+  = Env
+  { e_dflags     :: !DynFlags
+  -- ^ Read-only.
+  , e_subst      :: !Subst
+  -- ^ We need to track the renamings of local 'InId's to their lifted 'OutId',
+  -- because shadowing might make a closure's free variables unavailable at its
+  -- call sites. Consider:
+  -- @
+  --    let f y = x + y in let x = 4 in f x
+  -- @
+  -- Here, @f@ can't be lifted to top-level, because its free variable @x@ isn't
+  -- available at its call site.
+  , e_expansions :: !(IdEnv DIdSet)
+  -- ^ Lifted 'Id's don't occur as free variables in any closure anymore, because
+  -- they are bound at the top-level. Every occurrence must supply the formerly
+  -- free variables of the lifted 'Id', so they in turn become free variables of
+  -- the call sites. This environment tracks this expansion from lifted 'Id's to
+  -- their free variables.
+  --
+  -- 'InId's to 'OutId's.
+  --
+  -- Invariant: 'Id's not present in this map won't be substituted.
+  , e_in_caffy_context :: !Bool
+  -- ^ Are we currently analysing within a caffy context (e.g. the containing
+  -- top-level binder's 'idCafInfo' is 'MayHaveCafRefs')? If not, we can safely
+  -- assume that functions we lift out aren't caffy either.
+  }
+
+emptyEnv :: DynFlags -> Env
+emptyEnv dflags = Env dflags emptySubst emptyVarEnv False
+
+
+-- Note [Handling floats]
+-- ~~~~~~~~~~~~~~~~~~~~~~
+-- $floats
+-- Consider the following expression:
+--
+-- @
+--     f x =
+--       let g y = ... f y ...
+--       in g x
+-- @
+--
+-- What happens when we want to lift @g@? Normally, we'd put the lifted @l_g@
+-- binding above the binding for @f@:
+--
+-- @
+--     g f y = ... f y ...
+--     f x = g f x
+-- @
+--
+-- But this very unnecessarily turns a known call to @f@ into an unknown one, in
+-- addition to complicating matters for the analysis.
+-- Instead, we'd really like to put both functions in the same recursive group,
+-- thereby preserving the known call:
+--
+-- @
+--     Rec {
+--       g y = ... f y ...
+--       f x = g x
+--     }
+-- @
+--
+-- But we don't want this to happen for just /any/ binding. That would create
+-- possibly huge recursive groups in the process, calling for an occurrence
+-- analyser on STG.
+-- So, we need to track when we lift a binding out of a recursive RHS and add
+-- the binding to the same recursive group as the enclosing recursive binding
+-- (which must have either already been at the top-level or decided to be
+-- lifted itself in order to preserve the known call).
+--
+-- This is done by expressing this kind of nesting structure as a 'Writer' over
+-- @['FloatLang']@ and flattening this expression in 'runLiftM' by a call to
+-- 'collectFloats'.
+-- API-wise, the analysis will not need to know about the whole 'FloatLang'
+-- business and will just manipulate it indirectly through actions in 'LiftM'.
+
+-- | We need to detect when we are lifting something out of the RHS of a
+-- recursive binding (c.f. "StgLiftLams.LiftM#floats"), in which case that
+-- binding needs to be added to the same top-level recursive group. This
+-- requires we detect a certain nesting structure, which is encoded by
+-- 'StartBindingGroup' and 'EndBindingGroup'.
+--
+-- Although 'collectFloats' will only ever care if the current binding to be
+-- lifted (through 'LiftedBinding') will occur inside such a binding group or
+-- not, e.g. doesn't care about the nesting level as long as its greater than 0.
+data FloatLang
+  = StartBindingGroup
+  | EndBindingGroup
+  | PlainTopBinding OutStgTopBinding
+  | LiftedBinding OutStgBinding
+
+instance Outputable FloatLang where
+  ppr StartBindingGroup = char '('
+  ppr EndBindingGroup = char ')'
+  ppr (PlainTopBinding StgTopStringLit{}) = text "<str>"
+  ppr (PlainTopBinding (StgTopLifted b)) = ppr (LiftedBinding b)
+  ppr (LiftedBinding bind) = (if isRec rec then char 'r' else char 'n') <+> ppr (map fst pairs)
+    where
+      (rec, pairs) = decomposeStgBinding bind
+
+-- | Flattens an expression in @['FloatLang']@ into an STG program, see #floats.
+-- Important pre-conditions: The nesting of opening 'StartBindinGroup's and
+-- closing 'EndBindinGroup's is balanced. Also, it is crucial that every binding
+-- group has at least one recursive binding inside. Otherwise there's no point
+-- in announcing the binding group in the first place and an @ASSERT@ will
+-- trigger.
+collectFloats :: [FloatLang] -> [OutStgTopBinding]
+collectFloats = go (0 :: Int) []
+  where
+    go 0 [] [] = []
+    go _ _ [] = pprPanic "collectFloats" (text "unterminated group")
+    go n binds (f:rest) = case f of
+      StartBindingGroup -> go (n+1) binds rest
+      EndBindingGroup
+        | n == 0 -> pprPanic "collectFloats" (text "no group to end")
+        | n == 1 -> StgTopLifted (merge_binds binds) : go 0 [] rest
+        | otherwise -> go (n-1) binds rest
+      PlainTopBinding top_bind
+        | n == 0 -> top_bind : go n binds rest
+        | otherwise -> pprPanic "collectFloats" (text "plain top binding inside group")
+      LiftedBinding bind
+        | n == 0 -> StgTopLifted (rm_cccs bind) : go n binds rest
+        | otherwise -> go n (bind:binds) rest
+
+    map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding
+    rm_cccs = map_rhss removeRhsCCCS
+    merge_binds binds = ASSERT( any is_rec binds )
+                        StgRec (concatMap (snd . decomposeStgBinding . rm_cccs) binds)
+    is_rec StgRec{} = True
+    is_rec _ = False
+
+-- | Omitting this makes for strange closure allocation schemes that crash the
+-- GC.
+removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass
+removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body)
+  | isCurrentCCS ccs
+  = StgRhsClosure ext dontCareCCS upd bndrs body
+removeRhsCCCS (StgRhsCon ccs con args)
+  | isCurrentCCS ccs
+  = StgRhsCon dontCareCCS con args
+removeRhsCCCS rhs = rhs
+
+-- | The analysis monad consists of the following 'RWST' components:
+--
+--     * 'Env': Reader-like context. Contains a substitution, info about how
+--       how lifted identifiers are to be expanded into applications and details
+--       such as 'DynFlags' and a flag helping with determining if a lifted
+--       binding is caffy.
+--
+--     * @'OrdList' 'FloatLang'@: Writer output for the resulting STG program.
+--
+--     * No pure state component
+--
+--     * But wrapping around 'UniqSM' for generating fresh lifted binders.
+--       (The @uniqAway@ approach could give the same name to two different
+--       lifted binders, so this is necessary.)
+newtype LiftM a
+  = LiftM { unwrapLiftM :: RWST Env (OrdList FloatLang) () UniqSM a }
+  deriving (Functor, Applicative, Monad)
+
+instance HasDynFlags LiftM where
+  getDynFlags = LiftM (RWS.asks e_dflags)
+
+instance MonadUnique LiftM where
+  getUniqueSupplyM = LiftM (lift getUniqueSupplyM)
+  getUniqueM = LiftM (lift getUniqueM)
+  getUniquesM = LiftM (lift getUniquesM)
+
+runLiftM :: DynFlags -> UniqSupply -> LiftM () -> [OutStgTopBinding]
+runLiftM dflags us (LiftM m) = collectFloats (fromOL floats)
+  where
+    (_, _, floats) = initUs_ us (runRWST m (emptyEnv dflags) ())
+
+-- | Assumes a given caffyness for the execution of the passed action, which
+-- influences the 'cafInfo' of lifted bindings.
+withCaffyness :: Bool -> LiftM a -> LiftM a
+withCaffyness caffy action
+  = LiftM (RWS.local (\e -> e { e_in_caffy_context = caffy }) (unwrapLiftM action))
+
+-- | Writes a plain 'StgTopStringLit' to the output.
+addTopStringLit :: OutId -> ByteString -> LiftM ()
+addTopStringLit id = LiftM . RWS.tell . unitOL . PlainTopBinding . StgTopStringLit id
+
+-- | Starts a recursive binding group. See #floats# and 'collectFloats'.
+startBindingGroup :: LiftM ()
+startBindingGroup = LiftM $ RWS.tell $ unitOL $ StartBindingGroup
+
+-- | Ends a recursive binding group. See #floats# and 'collectFloats'.
+endBindingGroup :: LiftM ()
+endBindingGroup = LiftM $ RWS.tell $ unitOL $ EndBindingGroup
+
+-- | Lifts a binding to top-level. Depending on whether it's declared inside
+-- a recursive RHS (see #floats# and 'collectFloats'), this might be added to
+-- an existing recursive top-level binding group.
+addLiftedBinding :: OutStgBinding -> LiftM ()
+addLiftedBinding = LiftM . RWS.tell . unitOL . LiftedBinding
+
+-- | Takes a binder and a continuation which is called with the substituted
+-- binder. The continuation will be evaluated in a 'LiftM' context in which that
+-- binder is deemed in scope. Think of it as a 'RWS.local' computation: After
+-- the continuation finishes, the new binding won't be in scope anymore.
+withSubstBndr :: Id -> (Id -> LiftM a) -> LiftM a
+withSubstBndr bndr inner = LiftM $ do
+  subst <- RWS.asks e_subst
+  let (bndr', subst') = substBndr bndr subst
+  RWS.local (\e -> e { e_subst = subst' }) (unwrapLiftM (inner bndr'))
+
+-- | See 'withSubstBndr'.
+withSubstBndrs :: Traversable f => f Id -> (f Id -> LiftM a) -> LiftM a
+withSubstBndrs = runContT . traverse (ContT . withSubstBndr)
+
+-- | Similarly to 'withSubstBndr', this function takes a set of variables to
+-- abstract over, the binder to lift (and generate a fresh, substituted name
+-- for) and a continuation in which that fresh, lifted binder is in scope.
+--
+-- It takes care of all the details involved with copying and adjusting the
+-- binder, fresh name generation and caffyness.
+withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a
+withLiftedBndr abs_ids bndr inner = do
+  uniq <- getUniqueM
+  let str = "$l" ++ occNameString (getOccName bndr)
+  let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr)
+  -- When the enclosing top-level binding is not caffy, then the lifted
+  -- binding will not be caffy either. If we don't recognize this, non-caffy
+  -- things call caffy things and then codegen screws up.
+  in_caffy_ctxt <- LiftM (RWS.asks e_in_caffy_context)
+  let caf_info = if in_caffy_ctxt then MayHaveCafRefs else NoCafRefs
+  let bndr'
+        -- See Note [transferPolyIdInfo] in Id.hs. We need to do this at least
+        -- for arity information.
+        = transferPolyIdInfo bndr (dVarSetElems abs_ids)
+        -- Otherwise we confuse code gen if bndr was not caffy: the new bndr is
+        -- assumed to be caffy and will need an SRT. Transitive call sites might
+        -- not be caffy themselves and subsequently will miss a static link
+        -- field in their closure. Chaos ensues.
+        . flip setIdCafInfo caf_info
+        . mkSysLocalOrCoVar (mkFastString str) uniq
+        $ ty
+  LiftM $ RWS.local
+    (\e -> e
+      { e_subst = extendSubst bndr bndr' $ extendInScope bndr' $ e_subst e
+      , e_expansions = extendVarEnv (e_expansions e) bndr abs_ids
+      })
+    (unwrapLiftM (inner bndr'))
+
+-- | See 'withLiftedBndr'.
+withLiftedBndrs :: Traversable f => DIdSet -> f Id -> (f Id -> LiftM a) -> LiftM a
+withLiftedBndrs abs_ids = runContT . traverse (ContT . withLiftedBndr abs_ids)
+
+-- | Substitutes a binder /occurrence/, which was brought in scope earlier by
+-- 'withSubstBndr'\/'withLiftedBndr'.
+substOcc :: Id -> LiftM Id
+substOcc id = LiftM (RWS.asks (lookupIdSubst id . e_subst))
+
+-- | Whether the given binding was decided to be lambda lifted.
+isLifted :: InId -> LiftM Bool
+isLifted bndr = LiftM (RWS.asks (elemVarEnv bndr . e_expansions))
+
+-- | Returns an empty list for a binding that was not lifted and the list of all
+-- local variables the binding abstracts over (so, exactly the additional
+-- arguments at adjusted call sites) otherwise.
+formerFreeVars :: InId -> LiftM [OutId]
+formerFreeVars f = LiftM $ do
+  expansions <- RWS.asks e_expansions
+  pure $ case lookupVarEnv expansions f of
+    Nothing -> []
+    Just fvs -> dVarSetElems fvs
+
+-- | Creates an /expander function/ for the current set of lifted binders.
+-- This expander function will replace any 'InId' by their corresponding 'OutId'
+-- and, in addition, will expand any lifted binders by the former free variables
+-- it abstracts over.
+liftedIdsExpander :: LiftM (DIdSet -> DIdSet)
+liftedIdsExpander = LiftM $ do
+  expansions <- RWS.asks e_expansions
+  subst <- RWS.asks e_subst
+  -- We use @noWarnLookupIdSubst@ here in order to suppress "not in scope"
+  -- warnings generated by 'lookupIdSubst' due to local bindings within RHS.
+  -- These are not in the InScopeSet of @subst@ and extending the InScopeSet in
+  -- @goodToLift@/@closureGrowth@ before passing it on to @expander@ is too much
+  -- trouble.
+  let go set fv = case lookupVarEnv expansions fv of
+        Nothing -> extendDVarSet set (noWarnLookupIdSubst fv subst) -- Not lifted
+        Just fvs' -> unionDVarSet set fvs'
+  let expander fvs = foldl' go emptyDVarSet (dVarSetElems fvs)
+  pure expander
diff --git a/compiler/simplStg/StgLiftLams/Transformation.hs b/compiler/simplStg/StgLiftLams/Transformation.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/StgLiftLams/Transformation.hs
@@ -0,0 +1,155 @@
+{-# LANGUAGE CPP #-}
+
+-- | (Mostly) textbook instance of the lambda lifting transformation,
+-- selecting which bindings to lambda lift by consulting 'goodToLift'.
+module StgLiftLams.Transformation (stgLiftLams) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import BasicTypes
+import DynFlags
+import Id
+import IdInfo
+import StgFVs ( annBindingFreeVars )
+import StgLiftLams.Analysis
+import StgLiftLams.LiftM
+import StgSyn
+import Outputable
+import UniqSupply
+import Util
+import VarSet
+import Control.Monad ( when )
+import Data.Maybe ( isNothing )
+
+-- | Lambda lifts bindings to top-level deemed worth lifting (see 'goodToLift').
+stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]
+stgLiftLams dflags us = runLiftM dflags us . foldr liftTopLvl (pure ())
+
+liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM ()
+liftTopLvl (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do
+  addTopStringLit bndr' lit
+  rest
+liftTopLvl (StgTopLifted bind) rest = do
+  let is_rec = isRec $ fst $ decomposeStgBinding bind
+  when is_rec startBindingGroup
+  let bind_w_fvs = annBindingFreeVars bind
+  withLiftedBind TopLevel (tagSkeletonTopBind bind_w_fvs) NilSk $ \mb_bind' -> do
+    -- We signal lifting of a binding through returning Nothing.
+    -- Should never happen for a top-level binding, though, since we are already
+    -- at top-level.
+    case mb_bind' of
+      Nothing -> pprPanic "StgLiftLams" (text "Lifted top-level binding")
+      Just bind' -> addLiftedBinding bind'
+    when is_rec endBindingGroup
+    rest
+
+withLiftedBind
+  :: TopLevelFlag
+  -> LlStgBinding
+  -> Skeleton
+  -> (Maybe OutStgBinding -> LiftM a)
+  -> LiftM a
+withLiftedBind top_lvl bind scope k
+  | isTopLevel top_lvl
+  = withCaffyness (is_caffy pairs) go
+  | otherwise
+  = go
+  where
+    (rec, pairs) = decomposeStgBinding bind
+    is_caffy = any (mayHaveCafRefs . idCafInfo . binderInfoBndr . fst)
+    go = withLiftedBindPairs top_lvl rec pairs scope (k . fmap (mkStgBinding rec))
+
+withLiftedBindPairs
+  :: TopLevelFlag
+  -> RecFlag
+  -> [(BinderInfo, LlStgRhs)]
+  -> Skeleton
+  -> (Maybe [(Id, OutStgRhs)] -> LiftM a)
+  -> LiftM a
+withLiftedBindPairs top rec pairs scope k = do
+  let (infos, rhss) = unzip pairs
+  let bndrs = map binderInfoBndr infos
+  expander <- liftedIdsExpander
+  dflags <- getDynFlags
+  case goodToLift dflags top rec expander pairs scope of
+    -- @abs_ids@ is the set of all variables that need to become parameters.
+    Just abs_ids -> withLiftedBndrs abs_ids bndrs $ \bndrs' -> do
+      -- Within this block, all binders in @bndrs@ will be noted as lifted, so
+      -- that the return value of @liftedIdsExpander@ in this context will also
+      -- expand the bindings in @bndrs@ to their free variables.
+      -- Now we can recurse into the RHSs and see if we can lift any further
+      -- bindings. We pass the set of expanded free variables (thus OutIds) on
+      -- to @liftRhs@ so that it can add them as parameter binders.
+      when (isRec rec) startBindingGroup
+      rhss' <- traverse (liftRhs (Just abs_ids)) rhss
+      let pairs' = zip bndrs' rhss'
+      addLiftedBinding (mkStgBinding rec pairs')
+      when (isRec rec) endBindingGroup
+      k Nothing
+    Nothing -> withSubstBndrs bndrs $ \bndrs' -> do
+      -- Don't lift the current binding, but possibly some bindings in their
+      -- RHSs.
+      rhss' <- traverse (liftRhs Nothing) rhss
+      let pairs' = zip bndrs' rhss'
+      k (Just pairs')
+
+liftRhs
+  :: Maybe (DIdSet)
+  -- ^ @Just former_fvs@ <=> this RHS was lifted and we have to add @former_fvs@
+  -- as lambda binders, discarding all free vars.
+  -> LlStgRhs
+  -> LiftM OutStgRhs
+liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args)
+  = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ ppr rhs)
+    StgRhsCon ccs con <$> traverse liftArgs args
+liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = do
+  -- This RHS wasn't lifted.
+  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
+    StgRhsClosure noExtSilent ccs upd bndrs' <$> liftExpr body
+liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = do
+  -- This RHS was lifted. Insert extra binders for @former_fvs@.
+  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do
+    let bndrs'' = dVarSetElems former_fvs ++ bndrs'
+    StgRhsClosure noExtSilent ccs upd bndrs'' <$> liftExpr body
+
+liftArgs :: InStgArg -> LiftM OutStgArg
+liftArgs a@(StgLitArg _) = pure a
+liftArgs (StgVarArg occ) = do
+  ASSERTM2( not <$> isLifted occ, text "StgArgs should never be lifted" $$ ppr occ )
+  StgVarArg <$> substOcc occ
+
+liftExpr :: LlStgExpr -> LiftM OutStgExpr
+liftExpr (StgLit lit) = pure (StgLit lit)
+liftExpr (StgTick t e) = StgTick t <$> liftExpr e
+liftExpr (StgApp f args) = do
+  f' <- substOcc f
+  args' <- traverse liftArgs args
+  fvs' <- formerFreeVars f
+  let top_lvl_args = map StgVarArg fvs' ++ args'
+  pure (StgApp f' top_lvl_args)
+liftExpr (StgConApp con args tys) = StgConApp con <$> traverse liftArgs args <*> pure tys
+liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty
+liftExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam")
+liftExpr (StgCase scrut info ty alts) = do
+  scrut' <- liftExpr scrut
+  withSubstBndr (binderInfoBndr info) $ \bndr' -> do
+    alts' <- traverse liftAlt alts
+    pure (StgCase scrut' bndr' ty alts')
+liftExpr (StgLet scope bind body)
+  = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do
+      body' <- liftExpr body
+      case mb_bind' of
+        Nothing -> pure body' -- withLiftedBindPairs decided to lift it and already added floats
+        Just bind' -> pure (StgLet noExtSilent bind' body')
+liftExpr (StgLetNoEscape scope bind body)
+  = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do
+      body' <- liftExpr body
+      case mb_bind' of
+        Nothing -> pprPanic "stgLiftLams" (text "Should never decide to lift LNEs")
+        Just bind' -> pure (StgLetNoEscape noExtSilent bind' body')
+
+liftAlt :: LlStgAlt -> LiftM OutStgAlt
+liftAlt (con, infos, rhs) = withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->
+  (,,) con bndrs' <$> liftExpr rhs
diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/StgStats.hs
@@ -0,0 +1,173 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[StgStats]{Gathers statistical information about programs}
+
+
+The program gather statistics about
+\begin{enumerate}
+\item number of boxed cases
+\item number of unboxed cases
+\item number of let-no-escapes
+\item number of non-updatable lets
+\item number of updatable lets
+\item number of applications
+\item number of primitive applications
+\item number of closures (does not include lets bound to constructors)
+\item number of free variables in closures
+%\item number of top-level functions
+%\item number of top-level CAFs
+\item number of constructors
+\end{enumerate}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module StgStats ( showStgStats ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import StgSyn
+
+import Id (Id)
+import Panic
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+data CounterType
+  = Literals
+  | Applications
+  | ConstructorApps
+  | PrimitiveApps
+  | LetNoEscapes
+  | StgCases
+  | FreeVariables
+  | ConstructorBinds Bool{-True<=>top-level-}
+  | ReEntrantBinds   Bool{-ditto-}
+  | SingleEntryBinds Bool{-ditto-}
+  | UpdatableBinds   Bool{-ditto-}
+  deriving (Eq, Ord)
+
+type Count      = Int
+type StatEnv    = Map CounterType Count
+
+emptySE :: StatEnv
+emptySE = Map.empty
+
+combineSE :: StatEnv -> StatEnv -> StatEnv
+combineSE = Map.unionWith (+)
+
+combineSEs :: [StatEnv] -> StatEnv
+combineSEs = foldr combineSE emptySE
+
+countOne :: CounterType -> StatEnv
+countOne c = Map.singleton c 1
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Top-level list of bindings (a ``program'')}
+*                                                                      *
+************************************************************************
+-}
+
+showStgStats :: [StgTopBinding] -> String
+
+showStgStats prog
+  = "STG Statistics:\n\n"
+    ++ concat (map showc (Map.toList (gatherStgStats prog)))
+  where
+    showc (x,n) = (showString (s x) . shows n) "\n"
+
+    s Literals                = "Literals                   "
+    s Applications            = "Applications               "
+    s ConstructorApps         = "ConstructorApps            "
+    s PrimitiveApps           = "PrimitiveApps              "
+    s LetNoEscapes            = "LetNoEscapes               "
+    s StgCases                = "StgCases                   "
+    s FreeVariables           = "FreeVariables              "
+    s (ConstructorBinds True) = "ConstructorBinds_Top       "
+    s (ReEntrantBinds True)   = "ReEntrantBinds_Top         "
+    s (SingleEntryBinds True) = "SingleEntryBinds_Top       "
+    s (UpdatableBinds True)   = "UpdatableBinds_Top         "
+    s (ConstructorBinds _)    = "ConstructorBinds_Nested    "
+    s (ReEntrantBinds _)      = "ReEntrantBindsBinds_Nested "
+    s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "
+    s (UpdatableBinds _)      = "UpdatableBinds_Nested      "
+
+gatherStgStats :: [StgTopBinding] -> StatEnv
+gatherStgStats binds = combineSEs (map statTopBinding binds)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Bindings}
+*                                                                      *
+************************************************************************
+-}
+
+statTopBinding :: StgTopBinding -> StatEnv
+statTopBinding (StgTopStringLit _ _) = countOne Literals
+statTopBinding (StgTopLifted bind) = statBinding True bind
+
+statBinding :: Bool -- True <=> top-level; False <=> nested
+            -> StgBinding
+            -> StatEnv
+
+statBinding top (StgNonRec b rhs)
+  = statRhs top (b, rhs)
+
+statBinding top (StgRec pairs)
+  = combineSEs (map (statRhs top) pairs)
+
+statRhs :: Bool -> (Id, StgRhs) -> StatEnv
+
+statRhs top (_, StgRhsCon _ _ _)
+  = countOne (ConstructorBinds top)
+
+statRhs top (_, StgRhsClosure _ _ u _ body)
+  = statExpr body `combineSE`
+    countOne (
+      case u of
+        ReEntrant   -> ReEntrantBinds   top
+        Updatable   -> UpdatableBinds   top
+        SingleEntry -> SingleEntryBinds top
+    )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Expressions}
+*                                                                      *
+************************************************************************
+-}
+
+statExpr :: StgExpr -> StatEnv
+
+statExpr (StgApp _ _)     = countOne Applications
+statExpr (StgLit _)       = countOne Literals
+statExpr (StgConApp _ _ _)= countOne ConstructorApps
+statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
+statExpr (StgTick _ e)    = statExpr e
+
+statExpr (StgLetNoEscape _ binds body)
+  = statBinding False{-not top-level-} binds    `combineSE`
+    statExpr body                               `combineSE`
+    countOne LetNoEscapes
+
+statExpr (StgLet _ binds body)
+  = statBinding False{-not top-level-} binds    `combineSE`
+    statExpr body
+
+statExpr (StgCase expr _ _ alts)
+  = statExpr expr       `combineSE`
+    stat_alts alts      `combineSE`
+    countOne StgCases
+  where
+    stat_alts alts
+        = combineSEs (map statExpr [ e | (_,_,e) <- alts ])
+
+statExpr (StgLam {}) = panic "statExpr StgLam"
diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs
new file mode 100644
--- /dev/null
+++ b/compiler/simplStg/UnariseStg.hs
@@ -0,0 +1,767 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-2012
+
+Note [Unarisation]
+~~~~~~~~~~~~~~~~~~
+The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum
+binders. So for example:
+
+  f (x :: (# Int, Bool #)) = f x + f (# 1, True #)
+
+  ==>
+
+  f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True
+
+It is important that we do this at the STG level and NOT at the Core level
+because it would be very hard to make this pass Core-type-preserving. In this
+example the type of 'f' changes, for example.
+
+STG fed to the code generators *must* be unarised because the code generators do
+not support unboxed tuple and unboxed sum binders natively.
+
+In more detail: (see next note for unboxed sums)
+
+Suppose that a variable x : (# t1, t2 #).
+
+  * At the binding site for x, make up fresh vars  x1:t1, x2:t2
+
+  * Extend the UnariseEnv   x :-> MultiVal [x1,x2]
+
+  * Replace the binding with a curried binding for x1,x2
+
+       Lambda:   \x.e                ==>   \x1 x2. e
+       Case alt: MkT a b x c d -> e  ==>   MkT a b x1 x2 c d -> e
+
+  * Replace argument occurrences with a sequence of args via a lookup in
+    UnariseEnv
+
+       f a b x c d   ==>   f a b x1 x2 c d
+
+  * Replace tail-call occurrences with an unboxed tuple via a lookup in
+    UnariseEnv
+
+       x  ==>  (# x1, x2 #)
+
+    So, for example
+
+       f x = x    ==>   f x1 x2 = (# x1, x2 #)
+
+  * We /always/ eliminate a case expression when
+
+       - It scrutinises an unboxed tuple or unboxed sum
+
+       - The scrutinee is a variable (or when it is an explicit tuple, but the
+         simplifier eliminates those)
+
+    The case alternative (there can be only one) can be one of these two
+    things:
+
+      - An unboxed tuple pattern. e.g.
+
+          case v of x { (# x1, x2, x3 #) -> ... }
+
+        Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the
+        environment with
+
+          x :-> MultiVal [t1,t2,t3]
+          x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3
+
+      - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3
+
+By the end of this pass, we only have unboxed tuples in return positions.
+Unboxed sums are completely eliminated, see next note.
+
+Note [Translating unboxed sums to unboxed tuples]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unarise also eliminates unboxed sum binders, and translates unboxed sums in
+return positions to unboxed tuples. We want to overlap fields of a sum when
+translating it to a tuple to have efficient memory layout. When translating a
+sum pattern to a tuple pattern, we need to translate it so that binders of sum
+alternatives will be mapped to right arguments after the term translation. So
+translation of sum DataCon applications to tuple DataCon applications and
+translation of sum patterns to tuple patterns need to be in sync.
+
+These translations work like this. Suppose we have
+
+  (# x1 | | ... #) :: (# t1 | t2 | ... #)
+
+remember that t1, t2 ... can be sums and tuples too. So we first generate
+layouts of those. Then we "merge" layouts of each alternative, which gives us a
+sum layout with best overlapping possible.
+
+Layout of a flat type 'ty1' is just [ty1].
+Layout of a tuple is just concatenation of layouts of its fields.
+
+For layout of a sum type,
+
+  - We first get layouts of all alternatives.
+  - We sort these layouts based on their "slot types".
+  - We merge all the alternatives.
+
+For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #)
+
+  - Layouts of alternatives: [ [Word, Ptr], [Word, Word], [Word] ]
+  - Sorted: [ [Ptr, Word], [Word, Word], [Word] ]
+  - Merge all alternatives together: [ Ptr, Word, Word ]
+
+We add a slot for the tag to the first position. So our tuple type is
+
+  (# Tag#, Any, Word#, Word# #)
+  (we use Any for pointer slots)
+
+Now, any term of this sum type needs to generate a tuple of this type instead.
+The translation works by simply putting arguments to first slots that they fit
+in. Suppose we had
+
+  (# (# 42#, 'c' #) | | #)
+
+42# fits in Word#, 'c' fits in Any, so we generate this application:
+
+  (# 1#, 'c', 42#, rubbish #)
+
+Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#,
+3# fits in Word #, so we get:
+
+  (# 2#, rubbish, 2#, 3# #).
+
+Note [Types in StgConApp]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have this unboxed sum term:
+
+  (# 123 | #)
+
+What will be the unboxed tuple representation? We can't tell without knowing the
+type of this term. For example, these are all valid tuples for this:
+
+  (# 1#, 123 #)          -- when type is (# Int | String #)
+  (# 1#, 123, rubbish #) -- when type is (# Int | Float# #)
+  (# 1#, 123, rubbish, rubbish #)
+                         -- when type is (# Int | (# Int, Int, Int #) #)
+
+So we pass type arguments of the DataCon's TyCon in StgConApp to decide what
+layout to use. Note that unlifted values can't be let-bound, so we don't need
+types in StgRhsCon.
+
+Note [UnariseEnv can map to literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To avoid redundant case expressions when unarising unboxed sums, UnariseEnv
+needs to map variables to literals too. Suppose we have this Core:
+
+  f (# x | #)
+
+  ==> (CorePrep)
+
+  case (# x | #) of y {
+    _ -> f y
+  }
+
+  ==> (MultiVal)
+
+  case (# 1#, x #) of [x1, x2] {
+    _ -> f x1 x2
+  }
+
+To eliminate this case expression we need to map x1 to 1# in UnariseEnv:
+
+  x1 :-> UnaryVal 1#, x2 :-> UnaryVal x
+
+so that `f x1 x2` becomes `f 1# x`.
+
+Note [Unarisation and arity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because of unarisation, the arity that will be recorded in the generated info
+table for an Id may be larger than the idArity. Instead we record what we call
+the RepArity, which is the Arity taking into account any expanded arguments, and
+corresponds to the number of (possibly-void) *registers* arguments will arrive
+in.
+
+Note [Post-unarisation invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+STG programs after unarisation have these invariants:
+
+  * No unboxed sums at all.
+
+  * No unboxed tuple binders. Tuples only appear in return position.
+
+  * DataCon applications (StgRhsCon and StgConApp) don't have void arguments.
+    This means that it's safe to wrap `StgArg`s of DataCon applications with
+    `StgCmmEnv.NonVoid`, for example.
+
+  * Alt binders (binders in patterns) are always non-void.
+-}
+
+{-# LANGUAGE CPP, TupleSections #-}
+
+module UnariseStg (unarise) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import BasicTypes
+import CoreSyn
+import DataCon
+import FastString (FastString, mkFastString)
+import Id
+import Literal
+import MkCore (aBSENT_SUM_FIELD_ERROR_ID)
+import MkId (voidPrimId, voidArgId)
+import MonadUtils (mapAccumLM)
+import Outputable
+import RepType
+import StgSyn
+import Type
+import TysPrim (intPrimTy,wordPrimTy,word64PrimTy)
+import TysWiredIn
+import UniqSupply
+import Util
+import VarEnv
+
+import Data.Bifunctor (second)
+import Data.Maybe (mapMaybe)
+import qualified Data.IntMap as IM
+
+--------------------------------------------------------------------------------
+
+-- | A mapping from binders to the Ids they were expanded/renamed to.
+--
+--   x :-> MultiVal [a,b,c] in rho
+--
+-- iff  x's typePrimRep is not a singleton, or equivalently
+--      x's type is an unboxed tuple, sum or void.
+--
+--    x :-> UnaryVal x'
+--
+-- iff x's RepType is UnaryRep or equivalently
+--     x's type is not unboxed tuple, sum or void.
+--
+-- So
+--     x :-> MultiVal [a] in rho
+-- means x is represented by singleton tuple.
+--
+--     x :-> MultiVal [] in rho
+-- means x is void.
+--
+-- INVARIANT: OutStgArgs in the range only have NvUnaryTypes
+--            (i.e. no unboxed tuples, sums or voids)
+--
+type UnariseEnv = VarEnv UnariseVal
+
+data UnariseVal
+  = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).
+  | UnaryVal OutStgArg   -- See NOTE [Renaming during unarisation].
+
+instance Outputable UnariseVal where
+  ppr (MultiVal args) = text "MultiVal" <+> ppr args
+  ppr (UnaryVal arg)   = text "UnaryVal" <+> ppr arg
+
+-- | Extend the environment, checking the UnariseEnv invariant.
+extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv
+extendRho rho x (MultiVal args)
+  = ASSERT(all (isNvUnaryType . stgArgType) args)
+    extendVarEnv rho x (MultiVal args)
+extendRho rho x (UnaryVal val)
+  = ASSERT(isNvUnaryType (stgArgType val))
+    extendVarEnv rho x (UnaryVal val)
+
+--------------------------------------------------------------------------------
+
+unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
+unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds)
+
+unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
+unariseTopBinding rho (StgTopLifted bind)
+  = StgTopLifted <$> unariseBinding rho bind
+unariseTopBinding _ bind@StgTopStringLit{} = return bind
+
+unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding
+unariseBinding rho (StgNonRec x rhs)
+  = StgNonRec x <$> unariseRhs rho rhs
+unariseBinding rho (StgRec xrhss)
+  = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss
+
+unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs
+unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)
+  = do (rho', args1) <- unariseFunArgBinders rho args
+       expr' <- unariseExpr rho' expr
+       return (StgRhsClosure ext ccs update_flag args1 expr')
+
+unariseRhs rho (StgRhsCon ccs con args)
+  = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))
+    return (StgRhsCon ccs con (unariseConArgs rho args))
+
+--------------------------------------------------------------------------------
+
+unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr
+
+unariseExpr rho e@(StgApp f [])
+  = case lookupVarEnv rho f of
+      Just (MultiVal args)  -- Including empty tuples
+        -> return (mkTuple args)
+      Just (UnaryVal (StgVarArg f'))
+        -> return (StgApp f' [])
+      Just (UnaryVal (StgLitArg f'))
+        -> return (StgLit f')
+      Nothing
+        -> return e
+
+unariseExpr rho e@(StgApp f args)
+  = return (StgApp f' (unariseFunArgs rho args))
+  where
+    f' = case lookupVarEnv rho f of
+           Just (UnaryVal (StgVarArg f')) -> f'
+           Nothing -> f
+           err -> pprPanic "unariseExpr - app2" (ppr e $$ ppr err)
+               -- Can't happen because 'args' is non-empty, and
+               -- a tuple or sum cannot be applied to anything
+
+unariseExpr _ (StgLit l)
+  = return (StgLit l)
+
+unariseExpr rho (StgConApp dc args ty_args)
+  | Just args' <- unariseMulti_maybe rho dc args ty_args
+  = return (mkTuple args')
+
+  | otherwise
+  , let args' = unariseConArgs rho args
+  = return (StgConApp dc args' (map stgArgType args'))
+
+unariseExpr rho (StgOpApp op args ty)
+  = return (StgOpApp op (unariseFunArgs rho args) ty)
+
+unariseExpr _ e@StgLam{}
+  = pprPanic "unariseExpr: found lambda" (ppr e)
+
+unariseExpr rho (StgCase scrut bndr alt_ty alts)
+  -- tuple/sum binders in the scrutinee can always be eliminated
+  | StgApp v [] <- scrut
+  , Just (MultiVal xs) <- lookupVarEnv rho v
+  = elimCase rho xs bndr alt_ty alts
+
+  -- Handle strict lets for tuples and sums:
+  --   case (# a,b #) of r -> rhs
+  -- and analogously for sums
+  | StgConApp dc args ty_args <- scrut
+  , Just args' <- unariseMulti_maybe rho dc args ty_args
+  = elimCase rho args' bndr alt_ty alts
+
+  -- general case
+  | otherwise
+  = do scrut' <- unariseExpr rho scrut
+       alts'  <- unariseAlts rho alt_ty bndr alts
+       return (StgCase scrut' bndr alt_ty alts')
+                       -- bndr may have a unboxed sum/tuple type but it will be
+                       -- dead after unarise (checked in StgLint)
+
+unariseExpr rho (StgLet ext bind e)
+  = StgLet ext <$> unariseBinding rho bind <*> unariseExpr rho e
+
+unariseExpr rho (StgLetNoEscape ext bind e)
+  = StgLetNoEscape ext <$> unariseBinding rho bind <*> unariseExpr rho e
+
+unariseExpr rho (StgTick tick e)
+  = StgTick tick <$> unariseExpr rho e
+
+-- Doesn't return void args.
+unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]
+unariseMulti_maybe rho dc args ty_args
+  | isUnboxedTupleCon dc
+  = Just (unariseConArgs rho args)
+
+  | isUnboxedSumCon dc
+  , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args)
+  = Just (mkUbxSum dc ty_args args1)
+
+  | otherwise
+  = Nothing
+
+--------------------------------------------------------------------------------
+
+elimCase :: UnariseEnv
+         -> [OutStgArg] -- non-void args
+         -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr
+
+elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]
+  = do let rho1 = extendRho rho bndr (MultiVal args)
+           rho2
+             | isUnboxedTupleBndr bndr
+             = mapTupleIdBinders bndrs args rho1
+             | otherwise
+             = ASSERT(isUnboxedSumBndr bndr)
+               if null bndrs then rho1
+                             else mapSumIdBinders bndrs args rho1
+
+       unariseExpr rho2 rhs
+
+elimCase rho args bndr (MultiValAlt _) alts
+  | isUnboxedSumBndr bndr
+  = do let (tag_arg : real_args) = args
+       tag_bndr <- mkId (mkFastString "tag") tagTy
+          -- this won't be used but we need a binder anyway
+       let rho1 = extendRho rho bndr (MultiVal args)
+           scrut' = case tag_arg of
+                      StgVarArg v     -> StgApp v []
+                      StgLitArg l     -> StgLit l
+
+       alts' <- unariseSumAlts rho1 real_args alts
+       return (StgCase scrut' tag_bndr tagAltTy alts')
+
+elimCase _ args bndr alt_ty alts
+  = pprPanic "elimCase - unhandled case"
+      (ppr args <+> ppr bndr <+> ppr alt_ty $$ ppr alts)
+
+--------------------------------------------------------------------------------
+
+unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]
+unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]
+  | isUnboxedTupleBndr bndr
+  = do (rho', ys) <- unariseConArgBinder rho bndr
+       e' <- unariseExpr rho' e
+       return [(DataAlt (tupleDataCon Unboxed n), ys, e')]
+
+unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]
+  | isUnboxedTupleBndr bndr
+  = do (rho', ys1) <- unariseConArgBinders rho ys
+       MASSERT(ys1 `lengthIs` n)
+       let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))
+       e' <- unariseExpr rho'' e
+       return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]
+
+unariseAlts _ (MultiValAlt _) bndr alts
+  | isUnboxedTupleBndr bndr
+  = pprPanic "unariseExpr: strange multi val alts" (ppr alts)
+
+-- In this case we don't need to scrutinize the tag bit
+unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]
+  | isUnboxedSumBndr bndr
+  = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr
+       rhs' <- unariseExpr rho_sum_bndrs rhs
+       return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]
+
+unariseAlts rho (MultiValAlt _) bndr alts
+  | isUnboxedSumBndr bndr
+  = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr
+       alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts
+       let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'
+       return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),
+                 scrt_bndrs,
+                 inner_case) ]
+
+unariseAlts rho _ _ alts
+  = mapM (\alt -> unariseAlt rho alt) alts
+
+unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt
+unariseAlt rho (con, xs, e)
+  = do (rho', xs') <- unariseConArgBinders rho xs
+       (con, xs',) <$> unariseExpr rho' e
+
+--------------------------------------------------------------------------------
+
+-- | Make alternatives that match on the tag of a sum
+-- (i.e. generate LitAlts for the tag)
+unariseSumAlts :: UnariseEnv
+               -> [StgArg] -- sum components _excluding_ the tag bit.
+               -> [StgAlt] -- original alternative with sum LHS
+               -> UniqSM [StgAlt]
+unariseSumAlts env args alts
+  = do alts' <- mapM (unariseSumAlt env args) alts
+       return (mkDefaultLitAlt alts')
+
+unariseSumAlt :: UnariseEnv
+              -> [StgArg] -- sum components _excluding_ the tag bit.
+              -> StgAlt   -- original alternative with sum LHS
+              -> UniqSM StgAlt
+unariseSumAlt rho _ (DEFAULT, _, e)
+  = ( DEFAULT, [], ) <$> unariseExpr rho e
+
+unariseSumAlt rho args (DataAlt sumCon, bs, e)
+  = do let rho' = mapSumIdBinders bs args rho
+       e' <- unariseExpr rho' e
+       return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)) intPrimTy), [], e' )
+
+unariseSumAlt _ scrt alt
+  = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)
+
+--------------------------------------------------------------------------------
+
+mapTupleIdBinders
+  :: [InId]       -- Un-processed binders of a tuple alternative.
+                  -- Can have void binders.
+  -> [OutStgArg]  -- Arguments that form the tuple (after unarisation).
+                  -- Can't have void args.
+  -> UnariseEnv
+  -> UnariseEnv
+mapTupleIdBinders ids args0 rho0
+  = ASSERT(not (any (isVoidTy . stgArgType) args0))
+    let
+      ids_unarised :: [(Id, [PrimRep])]
+      ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids
+
+      map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv
+      map_ids rho [] _  = rho
+      map_ids rho ((x, x_reps) : xs) args =
+        let
+          x_arity = length x_reps
+          (x_args, args') =
+            ASSERT(args `lengthAtLeast` x_arity)
+            splitAt x_arity args
+
+          rho'
+            | x_arity == 1
+            = ASSERT(x_args `lengthIs` 1)
+              extendRho rho x (UnaryVal (head x_args))
+            | otherwise
+            = extendRho rho x (MultiVal x_args)
+        in
+          map_ids rho' xs args'
+    in
+      map_ids rho0 ids_unarised args0
+
+mapSumIdBinders
+  :: [InId]      -- Binder of a sum alternative (remember that sum patterns
+                 -- only have one binder, so this list should be a singleton)
+  -> [OutStgArg] -- Arguments that form the sum (NOT including the tag).
+                 -- Can't have void args.
+  -> UnariseEnv
+  -> UnariseEnv
+
+mapSumIdBinders [id] args rho0
+  = ASSERT(not (any (isVoidTy . stgArgType) args))
+    let
+      arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args
+      id_slots  = map primRepSlot $ typePrimRep (idType id)
+      layout1   = layoutUbxSum arg_slots id_slots
+    in
+      if isMultiValBndr id
+        then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])
+        else ASSERT(layout1 `lengthIs` 1)
+             extendRho rho0 id (UnaryVal (args !! head layout1))
+
+mapSumIdBinders ids sum_args _
+  = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args)
+
+-- | Build a unboxed sum term from arguments of an alternative.
+--
+-- Example, for (# x | #) :: (# (# #) | Int #) we call
+--
+--   mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ]
+--
+-- which returns
+--
+--   [ 1#, rubbish ]
+--
+mkUbxSum
+  :: DataCon      -- Sum data con
+  -> [Type]       -- Type arguments of the sum data con
+  -> [OutStgArg]  -- Actual arguments of the alternative.
+  -> [OutStgArg]  -- Final tuple arguments
+mkUbxSum dc ty_args args0
+  = let
+      (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args)
+        -- drop tag slot
+
+      tag = dataConTag dc
+
+      layout'  = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)
+      tag_arg  = StgLitArg (LitNumber LitNumInt (fromIntegral tag) intPrimTy)
+      arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)
+
+      mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]
+      mkTupArgs _ [] _
+        = []
+      mkTupArgs arg_idx (slot : slots_left) arg_map
+        | Just stg_arg <- IM.lookup arg_idx arg_map
+        = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map
+        | otherwise
+        = slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map
+
+      slotRubbishArg :: SlotTy -> StgArg
+      slotRubbishArg PtrSlot    = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
+                         -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in MkCore
+      slotRubbishArg WordSlot   = StgLitArg (LitNumber LitNumWord 0 wordPrimTy)
+      slotRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy)
+      slotRubbishArg FloatSlot  = StgLitArg (LitFloat 0)
+      slotRubbishArg DoubleSlot = StgLitArg (LitDouble 0)
+    in
+      tag_arg : mkTupArgs 0 sum_slots arg_idxs
+
+--------------------------------------------------------------------------------
+
+{-
+For arguments (StgArg) and binders (Id) we have two kind of unarisation:
+
+  - When unarising function arg binders and arguments, we don't want to remove
+    void binders and arguments. For example,
+
+      f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ...
+      f x y z = <body>
+
+    Here after unarise we should still get a function with arity 3. Similarly
+    in the call site we shouldn't remove void arguments:
+
+      f (# (# #), (# #) #) voidId rw
+
+    When unarising <body>, we extend the environment with these binders:
+
+      x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal []
+
+    Because their rep types are `MultiRep []` (aka. void). This means that when
+    we see `x` in a function argument position, we actually replace it with a
+    void argument. When we see it in a DataCon argument position, we just get
+    rid of it, because DataCon applications in STG are always saturated.
+
+  - When unarising case alternative binders we remove void binders, but we
+    still update the environment the same way, because those binders may be
+    used in the RHS. Example:
+
+      case x of y {
+        (# x1, x2, x3 #) -> <RHS>
+      }
+
+    We know that y can't be void, because we don't scrutinize voids, so x will
+    be unarised to some number of arguments, and those arguments will have at
+    least one non-void thing. So in the rho we will have something like:
+
+      x :-> MultiVal [xu1, xu2]
+
+    Now, after we eliminate void binders in the pattern, we get exactly the same
+    number of binders, and extend rho again with these:
+
+      x1 :-> UnaryVal xu1
+      x2 :-> MultiVal [] -- x2 is void
+      x3 :-> UnaryVal xu2
+
+    Now when we see x2 in a function argument position or in return position, we
+    generate void#. In constructor argument position, we just remove it.
+
+So in short, when we have a void id,
+
+  - We keep it if it's a lambda argument binder or
+                       in argument position of an application.
+
+  - We remove it if it's a DataCon field binder or
+                         in argument position of a DataCon application.
+-}
+
+unariseArgBinder
+    :: Bool -- data con arg?
+    -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+unariseArgBinder is_con_arg rho x =
+  case typePrimRep (idType x) of
+    []
+      | is_con_arg
+      -> return (extendRho rho x (MultiVal []), [])
+      | otherwise -- fun arg, do not remove void binders
+      -> return (extendRho rho x (MultiVal []), [voidArgId])
+
+    [rep]
+      -- Arg represented as single variable, but original type may still be an
+      -- unboxed sum/tuple, e.g. (# Void# | Void# #).
+      --
+      -- While not unarising the binder in this case does not break any programs
+      -- (because it unarises to a single variable), it triggers StgLint as we
+      -- break the the post-unarisation invariant that says unboxed tuple/sum
+      -- binders should vanish. See Note [Post-unarisation invariants].
+      | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x)
+      -> do x' <- mkId (mkFastString "us") (primRepToType rep)
+            return (extendRho rho x (MultiVal [StgVarArg x']), [x'])
+      | otherwise
+      -> return (rho, [x])
+
+    reps -> do
+      xs <- mkIds (mkFastString "us") (map primRepToType reps)
+      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)
+
+--------------------------------------------------------------------------------
+
+-- | MultiVal a function argument. Never returns an empty list.
+unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]
+unariseFunArg rho (StgVarArg x) =
+  case lookupVarEnv rho x of
+    Just (MultiVal [])  -> [voidArg]   -- NB: do not remove void args
+    Just (MultiVal as)  -> as
+    Just (UnaryVal arg) -> [arg]
+    Nothing             -> [StgVarArg x]
+unariseFunArg _ arg = [arg]
+
+unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]
+unariseFunArgs = concatMap . unariseFunArg
+
+unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
+unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs
+
+-- Result list of binders is never empty
+unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+unariseFunArgBinder = unariseArgBinder False
+
+--------------------------------------------------------------------------------
+
+-- | MultiVal a DataCon argument. Returns an empty list when argument is void.
+unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]
+unariseConArg rho (StgVarArg x) =
+  case lookupVarEnv rho x of
+    Just (UnaryVal arg) -> [arg]
+    Just (MultiVal as) -> as      -- 'as' can be empty
+    Nothing
+      | isVoidTy (idType x) -> [] -- e.g. C realWorld#
+                                  -- Here realWorld# is not in the envt, but
+                                  -- is a void, and so should be eliminated
+      | otherwise -> [StgVarArg x]
+unariseConArg _ arg@(StgLitArg lit) =
+    ASSERT(not (isVoidTy (literalType lit)))  -- We have no void literals
+    [arg]
+
+unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]
+unariseConArgs = concatMap . unariseConArg
+
+unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])
+unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs
+
+-- Different from `unariseFunArgBinder`: result list of binders may be empty.
+-- See DataCon applications case in Note [Post-unarisation invariants].
+unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])
+unariseConArgBinder = unariseArgBinder True
+
+--------------------------------------------------------------------------------
+
+mkIds :: FastString -> [UnaryType] -> UniqSM [Id]
+mkIds fs tys = mapM (mkId fs) tys
+
+mkId :: FastString -> UnaryType -> UniqSM Id
+mkId = mkSysLocalOrCoVarM
+
+isMultiValBndr :: Id -> Bool
+isMultiValBndr id
+  | [_] <- typePrimRep (idType id)
+  = False
+  | otherwise
+  = True
+
+isUnboxedSumBndr :: Id -> Bool
+isUnboxedSumBndr = isUnboxedSumType . idType
+
+isUnboxedTupleBndr :: Id -> Bool
+isUnboxedTupleBndr = isUnboxedTupleType . idType
+
+mkTuple :: [StgArg] -> StgExpr
+mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args)
+
+tagAltTy :: AltType
+tagAltTy = PrimAlt IntRep
+
+tagTy :: Type
+tagTy = intPrimTy
+
+voidArg :: StgArg
+voidArg = StgVarArg voidPrimId
+
+mkDefaultLitAlt :: [StgAlt] -> [StgAlt]
+-- We have an exhauseive list of literal alternatives
+--    1# -> e1
+--    2# -> e2
+-- Since they are exhaustive, we can replace one with DEFAULT, to avoid
+-- generating a final test. Remember, the DEFAULT comes first if it exists.
+mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")
+mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts
+mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts
+mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts)
diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/specialise/SpecConstr.hs
@@ -0,0 +1,2356 @@
+{-
+ToDo [Oct 2013]
+~~~~~~~~~~~~~~~
+1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim)
+2. Nuke NoSpecConstr
+
+
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[SpecConstr]{Specialise over constructors}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module SpecConstr(
+        specConstrProgram,
+        SpecConstrAnnotation(..)
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSyn
+import CoreSubst
+import CoreUtils
+import CoreUnfold       ( couldBeSmallEnoughToInline )
+import CoreFVs          ( exprsFreeVarsList )
+import CoreMonad
+import Literal          ( litIsLifted )
+import HscTypes         ( ModGuts(..) )
+import WwLib            ( isWorkerSmallEnough, mkWorkerArgs )
+import DataCon
+import Coercion         hiding( substCo )
+import Rules
+import Type             hiding ( substTy )
+import TyCon            ( tyConName )
+import Id
+import PprCore          ( pprParendExpr )
+import MkCore           ( mkImpossibleExpr )
+import VarEnv
+import VarSet
+import Name
+import BasicTypes
+import DynFlags         ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )
+                        , gopt, hasPprDebug )
+import Maybes           ( orElse, catMaybes, isJust, isNothing )
+import Demand
+import GHC.Serialized   ( deserializeWithData )
+import Util
+import Pair
+import UniqSupply
+import Outputable
+import FastString
+import UniqFM
+import MonadUtils
+import Control.Monad    ( zipWithM )
+import Data.List
+import PrelNames        ( specTyConName )
+import Module
+import TyCon ( TyCon )
+import GHC.Exts( SpecConstrAnnotation(..) )
+import Data.Ord( comparing )
+
+{-
+-----------------------------------------------------
+                        Game plan
+-----------------------------------------------------
+
+Consider
+        drop n []     = []
+        drop 0 xs     = []
+        drop n (x:xs) = drop (n-1) xs
+
+After the first time round, we could pass n unboxed.  This happens in
+numerical code too.  Here's what it looks like in Core:
+
+        drop n xs = case xs of
+                      []     -> []
+                      (y:ys) -> case n of
+                                  I# n# -> case n# of
+                                             0 -> []
+                                             _ -> drop (I# (n# -# 1#)) xs
+
+Notice that the recursive call has an explicit constructor as argument.
+Noticing this, we can make a specialised version of drop
+
+        RULE: drop (I# n#) xs ==> drop' n# xs
+
+        drop' n# xs = let n = I# n# in ...orig RHS...
+
+Now the simplifier will apply the specialisation in the rhs of drop', giving
+
+        drop' n# xs = case xs of
+                      []     -> []
+                      (y:ys) -> case n# of
+                                  0 -> []
+                                  _ -> drop' (n# -# 1#) xs
+
+Much better!
+
+We'd also like to catch cases where a parameter is carried along unchanged,
+but evaluated each time round the loop:
+
+        f i n = if i>0 || i>n then i else f (i*2) n
+
+Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.
+In Core, by the time we've w/wd (f is strict in i) we get
+
+        f i# n = case i# ># 0 of
+                   False -> I# i#
+                   True  -> case n of { I# n# ->
+                            case i# ># n# of
+                                False -> I# i#
+                                True  -> f (i# *# 2#) n
+
+At the call to f, we see that the argument, n is known to be (I# n#),
+and n is evaluated elsewhere in the body of f, so we can play the same
+trick as above.
+
+
+Note [Reboxing]
+~~~~~~~~~~~~~~~
+We must be careful not to allocate the same constructor twice.  Consider
+        f p = (...(case p of (a,b) -> e)...p...,
+               ...let t = (r,s) in ...t...(f t)...)
+At the recursive call to f, we can see that t is a pair.  But we do NOT want
+to make a specialised copy:
+        f' a b = let p = (a,b) in (..., ...)
+because now t is allocated by the caller, then r and s are passed to the
+recursive call, which allocates the (r,s) pair again.
+
+This happens if
+  (a) the argument p is used in other than a case-scrutinisation way.
+  (b) the argument to the call is not a 'fresh' tuple; you have to
+        look into its unfolding to see that it's a tuple
+
+Hence the "OR" part of Note [Good arguments] below.
+
+ALTERNATIVE 2: pass both boxed and unboxed versions.  This no longer saves
+allocation, but does perhaps save evals. In the RULE we'd have
+something like
+
+  f (I# x#) = f' (I# x#) x#
+
+If at the call site the (I# x) was an unfolding, then we'd have to
+rely on CSE to eliminate the duplicate allocation.... This alternative
+doesn't look attractive enough to pursue.
+
+ALTERNATIVE 3: ignore the reboxing problem.  The trouble is that
+the conservative reboxing story prevents many useful functions from being
+specialised.  Example:
+        foo :: Maybe Int -> Int -> Int
+        foo   (Just m) 0 = 0
+        foo x@(Just m) n = foo x (n-m)
+Here the use of 'x' will clearly not require boxing in the specialised function.
+
+The strictness analyser has the same problem, in fact.  Example:
+        f p@(a,b) = ...
+If we pass just 'a' and 'b' to the worker, it might need to rebox the
+pair to create (a,b).  A more sophisticated analysis might figure out
+precisely the cases in which this could happen, but the strictness
+analyser does no such analysis; it just passes 'a' and 'b', and hopes
+for the best.
+
+So my current choice is to make SpecConstr similarly aggressive, and
+ignore the bad potential of reboxing.
+
+
+Note [Good arguments]
+~~~~~~~~~~~~~~~~~~~~~
+So we look for
+
+* A self-recursive function.  Ignore mutual recursion for now,
+  because it's less common, and the code is simpler for self-recursion.
+
+* EITHER
+
+   a) At a recursive call, one or more parameters is an explicit
+      constructor application
+        AND
+      That same parameter is scrutinised by a case somewhere in
+      the RHS of the function
+
+  OR
+
+    b) At a recursive call, one or more parameters has an unfolding
+       that is an explicit constructor application
+        AND
+      That same parameter is scrutinised by a case somewhere in
+      the RHS of the function
+        AND
+      Those are the only uses of the parameter (see Note [Reboxing])
+
+
+What to abstract over
+~~~~~~~~~~~~~~~~~~~~~
+There's a bit of a complication with type arguments.  If the call
+site looks like
+
+        f p = ...f ((:) [a] x xs)...
+
+then our specialised function look like
+
+        f_spec x xs = let p = (:) [a] x xs in ....as before....
+
+This only makes sense if either
+  a) the type variable 'a' is in scope at the top of f, or
+  b) the type variable 'a' is an argument to f (and hence fs)
+
+Actually, (a) may hold for value arguments too, in which case
+we may not want to pass them.  Suppose 'x' is in scope at f's
+defn, but xs is not.  Then we'd like
+
+        f_spec xs = let p = (:) [a] x xs in ....as before....
+
+Similarly (b) may hold too.  If x is already an argument at the
+call, no need to pass it again.
+
+Finally, if 'a' is not in scope at the call site, we could abstract
+it as we do the term variables:
+
+        f_spec a x xs = let p = (:) [a] x xs in ...as before...
+
+So the grand plan is:
+
+        * abstract the call site to a constructor-only pattern
+          e.g.  C x (D (f p) (g q))  ==>  C s1 (D s2 s3)
+
+        * Find the free variables of the abstracted pattern
+
+        * Pass these variables, less any that are in scope at
+          the fn defn.  But see Note [Shadowing] below.
+
+
+NOTICE that we only abstract over variables that are not in scope,
+so we're in no danger of shadowing variables used in "higher up"
+in f_spec's RHS.
+
+
+Note [Shadowing]
+~~~~~~~~~~~~~~~~
+In this pass we gather up usage information that may mention variables
+that are bound between the usage site and the definition site; or (more
+seriously) may be bound to something different at the definition site.
+For example:
+
+        f x = letrec g y v = let x = ...
+                             in ...(g (a,b) x)...
+
+Since 'x' is in scope at the call site, we may make a rewrite rule that
+looks like
+        RULE forall a,b. g (a,b) x = ...
+But this rule will never match, because it's really a different 'x' at
+the call site -- and that difference will be manifest by the time the
+simplifier gets to it.  [A worry: the simplifier doesn't *guarantee*
+no-shadowing, so perhaps it may not be distinct?]
+
+Anyway, the rule isn't actually wrong, it's just not useful.  One possibility
+is to run deShadowBinds before running SpecConstr, but instead we run the
+simplifier.  That gives the simplest possible program for SpecConstr to
+chew on; and it virtually guarantees no shadowing.
+
+Note [Specialising for constant parameters]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This one is about specialising on a *constant* (but not necessarily
+constructor) argument
+
+    foo :: Int -> (Int -> Int) -> Int
+    foo 0 f = 0
+    foo m f = foo (f m) (+1)
+
+It produces
+
+    lvl_rmV :: GHC.Base.Int -> GHC.Base.Int
+    lvl_rmV =
+      \ (ds_dlk :: GHC.Base.Int) ->
+        case ds_dlk of wild_alH { GHC.Base.I# x_alG ->
+        GHC.Base.I# (GHC.Prim.+# x_alG 1)
+
+    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
+    GHC.Prim.Int#
+    T.$wfoo =
+      \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->
+        case ww_sme of ds_Xlw {
+          __DEFAULT ->
+        case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->
+        T.$wfoo ww1_Xmz lvl_rmV
+        };
+          0 -> 0
+        }
+
+The recursive call has lvl_rmV as its argument, so we could create a specialised copy
+with that argument baked in; that is, not passed at all.   Now it can perhaps be inlined.
+
+When is this worth it?  Call the constant 'lvl'
+- If 'lvl' has an unfolding that is a constructor, see if the corresponding
+  parameter is scrutinised anywhere in the body.
+
+- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding
+  parameter is applied (...to enough arguments...?)
+
+  Also do this is if the function has RULES?
+
+Also
+
+Note [Specialising for lambda parameters]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    foo :: Int -> (Int -> Int) -> Int
+    foo 0 f = 0
+    foo m f = foo (f m) (\n -> n-m)
+
+This is subtly different from the previous one in that we get an
+explicit lambda as the argument:
+
+    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->
+    GHC.Prim.Int#
+    T.$wfoo =
+      \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->
+        case ww_sm8 of ds_Xlr {
+          __DEFAULT ->
+        case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->
+        T.$wfoo
+          ww1_Xmq
+          (\ (n_ad3 :: GHC.Base.Int) ->
+             case n_ad3 of wild_alB { GHC.Base.I# x_alA ->
+             GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)
+             })
+        };
+          0 -> 0
+        }
+
+I wonder if SpecConstr couldn't be extended to handle this? After all,
+lambda is a sort of constructor for functions and perhaps it already
+has most of the necessary machinery?
+
+Furthermore, there's an immediate win, because you don't need to allocate the lambda
+at the call site; and if perchance it's called in the recursive call, then you
+may avoid allocating it altogether.  Just like for constructors.
+
+Looks cool, but probably rare...but it might be easy to implement.
+
+
+Note [SpecConstr for casts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+    data family T a :: *
+    data instance T Int = T Int
+
+    foo n = ...
+       where
+         go (T 0) = 0
+         go (T n) = go (T (n-1))
+
+The recursive call ends up looking like
+        go (T (I# ...) `cast` g)
+So we want to spot the constructor application inside the cast.
+That's why we have the Cast case in argToPat
+
+Note [Local recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For a *local* recursive group, we can see all the calls to the
+function, so we seed the specialisation loop from the calls in the
+body, not from the calls in the RHS.  Consider:
+
+  bar m n = foo n (n,n) (n,n) (n,n) (n,n)
+   where
+     foo n p q r s
+       | n == 0    = m
+       | n > 3000  = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }
+       | n > 2000  = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }
+       | n > 1000  = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }
+       | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }
+
+If we start with the RHSs of 'foo', we get lots and lots of specialisations,
+most of which are not needed.  But if we start with the (single) call
+in the rhs of 'bar' we get exactly one fully-specialised copy, and all
+the recursive calls go to this fully-specialised copy. Indeed, the original
+function is later collected as dead code.  This is very important in
+specialising the loops arising from stream fusion, for example in NDP where
+we were getting literally hundreds of (mostly unused) specialisations of
+a local function.
+
+In a case like the above we end up never calling the original un-specialised
+function.  (Although we still leave its code around just in case.)
+
+However, if we find any boring calls in the body, including *unsaturated*
+ones, such as
+      letrec foo x y = ....foo...
+      in map foo xs
+then we will end up calling the un-specialised function, so then we *should*
+use the calls in the un-specialised RHS as seeds.  We call these
+"boring call patterns", and callsToPats reports if it finds any of these.
+
+Note [Seeding top-level recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This seeding is done in the binding for seed_calls in specRec.
+
+1. If all the bindings in a top-level recursive group are local (not
+   exported), then all the calls are in the rest of the top-level
+   bindings.  This means we can specialise with those call patterns
+   ONLY, and NOT with the RHSs of the recursive group (exactly like
+   Note [Local recursive groups])
+
+2. But if any of the bindings are exported, the function may be called
+   with any old arguments, so (for lack of anything better) we specialise
+   based on
+     (a) the call patterns in the RHS
+     (b) the call patterns in the rest of the top-level bindings
+   NB: before Apr 15 we used (a) only, but Dimitrios had an example
+       where (b) was crucial, so I added that.
+       Adding (b) also improved nofib allocation results:
+                  multiplier: 4%   better
+                  minimax:    2.8% better
+
+Actually in case (2), instead of using the calls from the RHS, it
+would be better to specialise in the importing module.  We'd need to
+add an INLINABLE pragma to the function, and then it can be
+specialised in the importing scope, just as is done for type classes
+in Specialise.specImports. This remains to be done (#10346).
+
+Note [Top-level recursive groups]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+To get the call usage information from "the rest of the top level
+bindings" (c.f. Note [Seeding top-level recursive groups]), we work
+backwards through the top-level bindings so we see the usage before we
+get to the binding of the function.  Before we can collect the usage
+though, we go through all the bindings and add them to the
+environment. This is necessary because usage is only tracked for
+functions in the environment.  These two passes are called
+   'go' and 'goEnv'
+in specConstrProgram.  (Looks a bit revolting to me.)
+
+Note [Do not specialise diverging functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Specialising a function that just diverges is a waste of code.
+Furthermore, it broke GHC (simpl014) thus:
+   {-# STR Sb #-}
+   f = \x. case x of (a,b) -> f x
+If we specialise f we get
+   f = \x. case x of (a,b) -> fspec a b
+But fspec doesn't have decent strictness info.  As it happened,
+(f x) :: IO t, so the state hack applied and we eta expanded fspec,
+and hence f.  But now f's strictness is less than its arity, which
+breaks an invariant.
+
+
+Note [Forcing specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With stream fusion and in other similar cases, we want to fully
+specialise some (but not necessarily all!) loops regardless of their
+size and the number of specialisations.
+
+We allow a library to do this, in one of two ways (one which is
+deprecated):
+
+  1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body.
+
+  2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts,
+     and then add *that* type as a parameter to the loop body
+
+The reason #2 is deprecated is because it requires GHCi, which isn't
+available for things like a cross compiler using stage1.
+
+Here's a (simplified) example from the `vector` package. You may bring
+the special 'force specialization' type into scope by saying:
+
+  import GHC.Types (SPEC(..))
+
+or by defining your own type (again, deprecated):
+
+  data SPEC = SPEC | SPEC2
+  {-# ANN type SPEC ForceSpecConstr #-}
+
+(Note this is the exact same definition of GHC.Types.SPEC, just
+without the annotation.)
+
+After that, you say:
+
+  foldl :: (a -> b -> a) -> a -> Stream b -> a
+  {-# INLINE foldl #-}
+  foldl f z (Stream step s _) = foldl_loop SPEC z s
+    where
+      foldl_loop !sPEC z s = case step s of
+                              Yield x s' -> foldl_loop sPEC (f z x) s'
+                              Skip       -> foldl_loop sPEC z s'
+                              Done       -> z
+
+SpecConstr will spot the SPEC parameter and always fully specialise
+foldl_loop. Note that
+
+  * We have to prevent the SPEC argument from being removed by
+    w/w which is why (a) SPEC is a sum type, and (b) we have to seq on
+    the SPEC argument.
+
+  * And lastly, the SPEC argument is ultimately eliminated by
+    SpecConstr itself so there is no runtime overhead.
+
+This is all quite ugly; we ought to come up with a better design.
+
+ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set
+sc_force to True when calling specLoop. This flag does four things:
+
+  * Ignore specConstrThreshold, to specialise functions of arbitrary size
+        (see scTopBind)
+  * Ignore specConstrCount, to make arbitrary numbers of specialisations
+        (see specialise)
+  * Specialise even for arguments that are not scrutinised in the loop
+        (see argToPat; Trac #4448)
+  * Only specialise on recursive types a finite number of times
+        (see is_too_recursive; Trac #5550; Note [Limit recursive specialisation])
+
+The flag holds only for specialising a single binding group, and NOT
+for nested bindings.  (So really it should be passed around explicitly
+and not stored in ScEnv.)  Trac #14379 turned out to be caused by
+   f SPEC x = let g1 x = ...
+              in ...
+We force-specialise f (because of the SPEC), but that generates a specialised
+copy of g1 (as well as the original).  Alas g1 has a nested binding g2; and
+in each copy of g1 we get an unspecialised and specialised copy of g2; and so
+on. Result, exponential.  So the force-spec flag now only applies to one
+level of bindings at a time.
+
+Mechanism for this one-level-only thing:
+
+ - Switch it on at the call to specRec, in scExpr and scTopBinds
+ - Switch it off when doing the RHSs;
+   this can be done very conveniently in decreaseSpecCount
+
+What alternatives did I consider?
+
+* Annotating the loop itself doesn't work because (a) it is local and
+  (b) it will be w/w'ed and having w/w propagating annotations somehow
+  doesn't seem like a good idea. The types of the loop arguments
+  really seem to be the most persistent thing.
+
+* Annotating the types that make up the loop state doesn't work,
+  either, because (a) it would prevent us from using types like Either
+  or tuples here, (b) we don't want to restrict the set of types that
+  can be used in Stream states and (c) some types are fixed by the
+  user (e.g., the accumulator here) but we still want to specialise as
+  much as possible.
+
+Alternatives to ForceSpecConstr
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Instead of giving the loop an extra argument of type SPEC, we
+also considered *wrapping* arguments in SPEC, thus
+  data SPEC a = SPEC a | SPEC2
+
+  loop = \arg -> case arg of
+                     SPEC state ->
+                        case state of (x,y) -> ... loop (SPEC (x',y')) ...
+                        S2 -> error ...
+The idea is that a SPEC argument says "specialise this argument
+regardless of whether the function case-analyses it".  But this
+doesn't work well:
+  * SPEC must still be a sum type, else the strictness analyser
+    eliminates it
+  * But that means that 'loop' won't be strict in its real payload
+This loss of strictness in turn screws up specialisation, because
+we may end up with calls like
+   loop (SPEC (case z of (p,q) -> (q,p)))
+Without the SPEC, if 'loop' were strict, the case would move out
+and we'd see loop applied to a pair. But if 'loop' isn't strict
+this doesn't look like a specialisable call.
+
+Note [Limit recursive specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It is possible for ForceSpecConstr to cause an infinite loop of specialisation.
+Because there is no limit on the number of specialisations, a recursive call with
+a recursive constructor as an argument (for example, list cons) will generate
+a specialisation for that constructor. If the resulting specialisation also
+contains a recursive call with the constructor, this could proceed indefinitely.
+
+For example, if ForceSpecConstr is on:
+  loop :: [Int] -> [Int] -> [Int]
+  loop z []         = z
+  loop z (x:xs)     = loop (x:z) xs
+this example will create a specialisation for the pattern
+  loop (a:b) c      = loop' a b c
+
+  loop' a b []      = (a:b)
+  loop' a b (x:xs)  = loop (x:(a:b)) xs
+and a new pattern is found:
+  loop (a:(b:c)) d  = loop'' a b c d
+which can continue indefinitely.
+
+Roman's suggestion to fix this was to stop after a couple of times on recursive types,
+but still specialising on non-recursive types as much as possible.
+
+To implement this, we count the number of times we have gone round the
+"specialise recursively" loop ('go' in 'specRec').  Once have gone round
+more than N times (controlled by -fspec-constr-recursive=N) we check
+
+  - If sc_force is off, and sc_count is (Just max) then we don't
+    need to do anything: trim_pats will limit the number of specs
+
+  - Otherwise check if any function has now got more than (sc_count env)
+    specialisations.  If sc_count is "no limit" then we arbitrarily
+    choose 10 as the limit (ugh).
+
+See Trac #5550.   Also Trac #13623, where this test had become over-aggressive,
+and we lost a wonderful specialisation that we really wanted!
+
+Note [NoSpecConstr]
+~~~~~~~~~~~~~~~~~~~
+The ignoreDataCon stuff allows you to say
+    {-# ANN type T NoSpecConstr #-}
+to mean "don't specialise on arguments of this type".  It was added
+before we had ForceSpecConstr.  Lacking ForceSpecConstr we specialised
+regardless of size; and then we needed a way to turn that *off*.  Now
+that we have ForceSpecConstr, this NoSpecConstr is probably redundant.
+(Used only for PArray, TODO: remove?)
+
+-----------------------------------------------------
+                Stuff not yet handled
+-----------------------------------------------------
+
+Here are notes arising from Roman's work that I don't want to lose.
+
+Example 1
+~~~~~~~~~
+    data T a = T !a
+
+    foo :: Int -> T Int -> Int
+    foo 0 t = 0
+    foo x t | even x    = case t of { T n -> foo (x-n) t }
+            | otherwise = foo (x-1) t
+
+SpecConstr does no specialisation, because the second recursive call
+looks like a boxed use of the argument.  A pity.
+
+    $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
+    $wfoo_sFw =
+      \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->
+         case ww_sFo of ds_Xw6 [Just L] {
+           __DEFAULT ->
+                case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {
+                  __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;
+                  0 ->
+                    case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->
+                    case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->
+                    $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy
+                    } } };
+           0 -> 0
+
+Example 2
+~~~~~~~~~
+    data a :*: b = !a :*: !b
+    data T a = T !a
+
+    foo :: (Int :*: T Int) -> Int
+    foo (0 :*: t) = 0
+    foo (x :*: t) | even x    = case t of { T n -> foo ((x-n) :*: t) }
+                  | otherwise = foo ((x-1) :*: t)
+
+Very similar to the previous one, except that the parameters are now in
+a strict tuple. Before SpecConstr, we have
+
+    $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#
+    $wfoo_sG3 =
+      \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T
+    GHC.Base.Int) ->
+        case ww_sFU of ds_Xws [Just L] {
+          __DEFAULT ->
+        case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {
+          __DEFAULT ->
+            case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->
+            $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2             -- $wfoo1
+            };
+          0 ->
+            case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->
+            case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->
+            $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB        -- $wfoo2
+            } } };
+          0 -> 0 }
+
+We get two specialisations:
+"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}
+                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)
+                  = Foo.$s$wfoo1 a_sFB sc_sGC ;
+"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}
+                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))
+                  = Foo.$s$wfoo y_aFp sc_sGC ;
+
+But perhaps the first one isn't good.  After all, we know that tpl_B2 is
+a T (I# x) really, because T is strict and Int has one constructor.  (We can't
+unbox the strict fields, because T is polymorphic!)
+
+************************************************************************
+*                                                                      *
+\subsection{Top level wrapper stuff}
+*                                                                      *
+************************************************************************
+-}
+
+specConstrProgram :: ModGuts -> CoreM ModGuts
+specConstrProgram guts
+  = do
+      dflags <- getDynFlags
+      us     <- getUniqueSupplyM
+      annos  <- getFirstAnnotations deserializeWithData guts
+      this_mod <- getModule
+      let binds' = reverse $ fst $ initUs us $ do
+                    -- Note [Top-level recursive groups]
+                    (env, binds) <- goEnv (initScEnv dflags this_mod annos)
+                                          (mg_binds guts)
+                        -- binds is identical to (mg_binds guts), except that the
+                        -- binders on the LHS have been replaced by extendBndr
+                        --   (SPJ this seems like overkill; I don't think the binders
+                        --    will change at all; and we don't substitute in the RHSs anyway!!)
+                    go env nullUsage (reverse binds)
+
+      return (guts { mg_binds = binds' })
+  where
+    -- See Note [Top-level recursive groups]
+    goEnv env []            = return (env, [])
+    goEnv env (bind:binds)  = do (env', bind')   <- scTopBindEnv env bind
+                                 (env'', binds') <- goEnv env' binds
+                                 return (env'', bind' : binds')
+
+    -- Arg list of bindings is in reverse order
+    go _   _   []           = return []
+    go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind
+                                 binds' <- go env usg' binds
+                                 return (bind' : binds')
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Environment: goes downwards}
+*                                                                      *
+************************************************************************
+
+Note [Work-free values only in environment]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The sc_vals field keeps track of in-scope value bindings, so
+that if we come across (case x of Just y ->...) we can reduce the
+case from knowing that x is bound to a pair.
+
+But only *work-free* values are ok here. For example if the envt had
+    x -> Just (expensive v)
+then we do NOT want to expand to
+     let y = expensive v in ...
+because the x-binding still exists and we've now duplicated (expensive v).
+
+This seldom happens because let-bound constructor applications are
+ANF-ised, but it can happen as a result of on-the-fly transformations in
+SpecConstr itself.  Here is Trac #7865:
+
+        let {
+          a'_shr =
+            case xs_af8 of _ {
+              [] -> acc_af6;
+              : ds_dgt [Dmd=<L,A>] ds_dgu [Dmd=<L,A>] ->
+                (expensive x_af7, x_af7
+            } } in
+        let {
+          ds_sht =
+            case a'_shr of _ { (p'_afd, q'_afe) ->
+            TSpecConstr_DoubleInline.recursive
+              (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd)
+            } } in
+
+When processed knowing that xs_af8 was bound to a cons, we simplify to
+   a'_shr = (expensive x_af7, x_af7)
+and we do NOT want to inline that at the occurrence of a'_shr in ds_sht.
+(There are other occurrences of a'_shr.)  No no no.
+
+It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned
+into a work-free value again, thus
+   a1 = expensive x_af7
+   a'_shr = (a1, x_af7)
+but that's more work, so until its shown to be important I'm going to
+leave it for now.
+
+Note [Making SpecConstr keener]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this, in (perf/should_run/T9339)
+   last (filter odd [1..1000])
+
+After optimisation, including SpecConstr, we get:
+   f :: Int# -> Int -> Int
+   f x y = case case remInt# x 2# of
+             __DEFAULT -> case x of
+                            __DEFAULT -> f (+# wild_Xp 1#) (I# x)
+                            1000000# -> ...
+             0# -> case x of
+                     __DEFAULT -> f (+# wild_Xp 1#) y
+                    1000000#   -> y
+
+Not good!  We build an (I# x) box every time around the loop.
+SpecConstr (as described in the paper) does not specialise f, despite
+the call (f ... (I# x)) because 'y' is not scrutinied in the body.
+But it is much better to specialise f for the case where the argument
+is of form (I# x); then we build the box only when returning y, which
+is on the cold path.
+
+Another example:
+
+   f x = ...(g x)....
+
+Here 'x' is not scrutinised in f's body; but if we did specialise 'f'
+then the call (g x) might allow 'g' to be specialised in turn.
+
+So sc_keen controls whether or not we take account of whether argument is
+scrutinised in the body.  True <=> ignore that, and speicalise whenever
+the function is applied to a data constructor.
+-}
+
+data ScEnv = SCE { sc_dflags    :: DynFlags,
+                   sc_module    :: !Module,
+                   sc_size      :: Maybe Int,   -- Size threshold
+                                                -- Nothing => no limit
+
+                   sc_count     :: Maybe Int,   -- Max # of specialisations for any one fn
+                                                -- Nothing => no limit
+                                                -- See Note [Avoiding exponential blowup]
+
+                   sc_recursive :: Int,         -- Max # of specialisations over recursive type.
+                                                -- Stops ForceSpecConstr from diverging.
+
+                   sc_keen     :: Bool,         -- Specialise on arguments that are known
+                                                -- constructors, even if they are not
+                                                -- scrutinised in the body.  See
+                                                -- Note [Making SpecConstr keener]
+
+                   sc_force     :: Bool,        -- Force specialisation?
+                                                -- See Note [Forcing specialisation]
+
+                   sc_subst     :: Subst,       -- Current substitution
+                                                -- Maps InIds to OutExprs
+
+                   sc_how_bound :: HowBoundEnv,
+                        -- Binds interesting non-top-level variables
+                        -- Domain is OutVars (*after* applying the substitution)
+
+                   sc_vals      :: ValueEnv,
+                        -- Domain is OutIds (*after* applying the substitution)
+                        -- Used even for top-level bindings (but not imported ones)
+                        -- The range of the ValueEnv is *work-free* values
+                        -- such as (\x. blah), or (Just v)
+                        -- but NOT (Just (expensive v))
+                        -- See Note [Work-free values only in environment]
+
+                   sc_annotations :: UniqFM SpecConstrAnnotation
+             }
+
+---------------------
+type HowBoundEnv = VarEnv HowBound      -- Domain is OutVars
+
+---------------------
+type ValueEnv = IdEnv Value             -- Domain is OutIds
+data Value    = ConVal AltCon [CoreArg] -- _Saturated_ constructors
+                                        --   The AltCon is never DEFAULT
+              | LambdaVal               -- Inlinable lambdas or PAPs
+
+instance Outputable Value where
+   ppr (ConVal con args) = ppr con <+> interpp'SP args
+   ppr LambdaVal         = text "<Lambda>"
+
+---------------------
+initScEnv :: DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv
+initScEnv dflags this_mod anns
+  = SCE { sc_dflags      = dflags,
+          sc_module      = this_mod,
+          sc_size        = specConstrThreshold dflags,
+          sc_count       = specConstrCount     dflags,
+          sc_recursive   = specConstrRecursive dflags,
+          sc_keen        = gopt Opt_SpecConstrKeen dflags,
+          sc_force       = False,
+          sc_subst       = emptySubst,
+          sc_how_bound   = emptyVarEnv,
+          sc_vals        = emptyVarEnv,
+          sc_annotations = anns }
+
+data HowBound = RecFun  -- These are the recursive functions for which
+                        -- we seek interesting call patterns
+
+              | RecArg  -- These are those functions' arguments, or their sub-components;
+                        -- we gather occurrence information for these
+
+instance Outputable HowBound where
+  ppr RecFun = text "RecFun"
+  ppr RecArg = text "RecArg"
+
+scForce :: ScEnv -> Bool -> ScEnv
+scForce env b = env { sc_force = b }
+
+lookupHowBound :: ScEnv -> Id -> Maybe HowBound
+lookupHowBound env id = lookupVarEnv (sc_how_bound env) id
+
+scSubstId :: ScEnv -> Id -> CoreExpr
+scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v
+
+scSubstTy :: ScEnv -> Type -> Type
+scSubstTy env ty = substTy (sc_subst env) ty
+
+scSubstCo :: ScEnv -> Coercion -> Coercion
+scSubstCo env co = substCo (sc_subst env) co
+
+zapScSubst :: ScEnv -> ScEnv
+zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }
+
+extendScInScope :: ScEnv -> [Var] -> ScEnv
+        -- Bring the quantified variables into scope
+extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }
+
+        -- Extend the substitution
+extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv
+extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }
+
+extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv
+extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }
+
+extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv
+extendHowBound env bndrs how_bound
+  = env { sc_how_bound = extendVarEnvList (sc_how_bound env)
+                            [(bndr,how_bound) | bndr <- bndrs] }
+
+extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])
+extendBndrsWith how_bound env bndrs
+  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')
+  where
+    (subst', bndrs') = substBndrs (sc_subst env) bndrs
+    hb_env' = sc_how_bound env `extendVarEnvList`
+                    [(bndr,how_bound) | bndr <- bndrs']
+
+extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)
+extendBndrWith how_bound env bndr
+  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')
+  where
+    (subst', bndr') = substBndr (sc_subst env) bndr
+    hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound
+
+extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])
+extendRecBndrs env bndrs  = (env { sc_subst = subst' }, bndrs')
+                      where
+                        (subst', bndrs') = substRecBndrs (sc_subst env) bndrs
+
+extendBndr :: ScEnv -> Var -> (ScEnv, Var)
+extendBndr  env bndr  = (env { sc_subst = subst' }, bndr')
+                      where
+                        (subst', bndr') = substBndr (sc_subst env) bndr
+
+extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv
+extendValEnv env _  Nothing   = env
+extendValEnv env id (Just cv)
+ | valueIsWorkFree cv      -- Don't duplicate work!!  Trac #7865
+ = env { sc_vals = extendVarEnv (sc_vals env) id cv }
+extendValEnv env _ _ = env
+
+extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var])
+-- When we encounter
+--      case scrut of b
+--          C x y -> ...
+-- we want to bind b, to (C x y)
+-- NB1: Extends only the sc_vals part of the envt
+-- NB2: Kill the dead-ness info on the pattern binders x,y, since
+--      they are potentially made alive by the [b -> C x y] binding
+extendCaseBndrs env scrut case_bndr con alt_bndrs
+   = (env2, alt_bndrs')
+ where
+   live_case_bndr = not (isDeadBinder case_bndr)
+   env1 | Var v <- stripTicksTopE (const True) scrut
+                         = extendValEnv env v cval
+        | otherwise      = env  -- See Note [Add scrutinee to ValueEnv too]
+   env2 | live_case_bndr = extendValEnv env1 case_bndr cval
+        | otherwise      = env1
+
+   alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr }
+              = map zap alt_bndrs
+              | otherwise
+              = alt_bndrs
+
+   cval = case con of
+                DEFAULT    -> Nothing
+                LitAlt {}  -> Just (ConVal con [])
+                DataAlt {} -> Just (ConVal con vanilla_args)
+                      where
+                        vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++
+                                       varsToCoreExprs alt_bndrs
+
+   zap v | isTyVar v = v                -- See NB2 above
+         | otherwise = zapIdOccInfo v
+
+
+decreaseSpecCount :: ScEnv -> Int -> ScEnv
+-- See Note [Avoiding exponential blowup]
+decreaseSpecCount env n_specs
+  = env { sc_force = False   -- See Note [Forcing specialisation]
+        , sc_count = case sc_count env of
+                       Nothing -> Nothing
+                       Just n  -> Just (n `div` (n_specs + 1)) }
+        -- The "+1" takes account of the original function;
+        -- See Note [Avoiding exponential blowup]
+
+---------------------------------------------------
+-- See Note [Forcing specialisation]
+ignoreType    :: ScEnv -> Type   -> Bool
+ignoreDataCon  :: ScEnv -> DataCon -> Bool
+forceSpecBndr :: ScEnv -> Var    -> Bool
+
+ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc)
+
+ignoreType env ty
+  = case tyConAppTyCon_maybe ty of
+      Just tycon -> ignoreTyCon env tycon
+      _          -> False
+
+ignoreTyCon :: ScEnv -> TyCon -> Bool
+ignoreTyCon env tycon
+  = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr
+
+forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var
+
+forceSpecFunTy :: ScEnv -> Type -> Bool
+forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys
+
+forceSpecArgTy :: ScEnv -> Type -> Bool
+forceSpecArgTy env ty
+  | Just ty' <- coreView ty = forceSpecArgTy env ty'
+
+forceSpecArgTy env ty
+  | Just (tycon, tys) <- splitTyConApp_maybe ty
+  , tycon /= funTyCon
+      = tyConName tycon == specTyConName
+        || lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr
+        || any (forceSpecArgTy env) tys
+
+forceSpecArgTy _ _ = False
+
+{-
+Note [Add scrutinee to ValueEnv too]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+   case x of y
+     (a,b) -> case b of c
+                I# v -> ...(f y)...
+By the time we get to the call (f y), the ValueEnv
+will have a binding for y, and for c
+    y -> (a,b)
+    c -> I# v
+BUT that's not enough!  Looking at the call (f y) we
+see that y is pair (a,b), but we also need to know what 'b' is.
+So in extendCaseBndrs we must *also* add the binding
+   b -> I# v
+else we lose a useful specialisation for f.  This is necessary even
+though the simplifier has systematically replaced uses of 'x' with 'y'
+and 'b' with 'c' in the code.  The use of 'b' in the ValueEnv came
+from outside the case.  See Trac #4908 for the live example.
+
+Note [Avoiding exponential blowup]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The sc_count field of the ScEnv says how many times we are prepared to
+duplicate a single function.  But we must take care with recursive
+specialisations.  Consider
+
+        let $j1 = let $j2 = let $j3 = ...
+                            in
+                            ...$j3...
+                  in
+                  ...$j2...
+        in
+        ...$j1...
+
+If we specialise $j1 then in each specialisation (as well as the original)
+we can specialise $j2, and similarly $j3.  Even if we make just *one*
+specialisation of each, because we also have the original we'll get 2^n
+copies of $j3, which is not good.
+
+So when recursively specialising we divide the sc_count by the number of
+copies we are making at this level, including the original.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Usage information: flows upwards}
+*                                                                      *
+************************************************************************
+-}
+
+data ScUsage
+   = SCU {
+        scu_calls :: CallEnv,           -- Calls
+                                        -- The functions are a subset of the
+                                        --      RecFuns in the ScEnv
+
+        scu_occs :: !(IdEnv ArgOcc)     -- Information on argument occurrences
+     }                                  -- The domain is OutIds
+
+type CallEnv = IdEnv [Call]
+data Call = Call Id [CoreArg] ValueEnv
+        -- The arguments of the call, together with the
+        -- env giving the constructor bindings at the call site
+        -- We keep the function mainly for debug output
+
+instance Outputable ScUsage where
+  ppr (SCU { scu_calls = calls, scu_occs = occs })
+    = text "SCU" <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls
+                                         , text "occs =" <+> ppr occs ])
+
+instance Outputable Call where
+  ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args)
+
+nullUsage :: ScUsage
+nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }
+
+combineCalls :: CallEnv -> CallEnv -> CallEnv
+combineCalls = plusVarEnv_C (++)
+  where
+--    plus cs ds | length res > 1
+--               = pprTrace "combineCalls" (vcat [ text "cs:" <+> ppr cs
+--                                               , text "ds:" <+> ppr ds])
+--                 res
+--               | otherwise = res
+--       where
+--          res = cs ++ ds
+
+combineUsage :: ScUsage -> ScUsage -> ScUsage
+combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),
+                           scu_occs  = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }
+
+combineUsages :: [ScUsage] -> ScUsage
+combineUsages [] = nullUsage
+combineUsages us = foldr1 combineUsage us
+
+lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])
+lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs
+  = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},
+     [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])
+
+data ArgOcc = NoOcc     -- Doesn't occur at all; or a type argument
+            | UnkOcc    -- Used in some unknown way
+
+            | ScrutOcc  -- See Note [ScrutOcc]
+                 (DataConEnv [ArgOcc])   -- How the sub-components are used
+
+type DataConEnv a = UniqFM a     -- Keyed by DataCon
+
+{- Note  [ScrutOcc]
+~~~~~~~~~~~~~~~~~~~
+An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,
+is *only* taken apart or applied.
+
+  Functions, literal: ScrutOcc emptyUFM
+  Data constructors:  ScrutOcc subs,
+
+where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,
+The domain of the UniqFM is the Unique of the data constructor
+
+The [ArgOcc] is the occurrences of the *pattern-bound* components
+of the data structure.  E.g.
+        data T a = forall b. MkT a b (b->a)
+A pattern binds b, x::a, y::b, z::b->a, but not 'a'!
+
+-}
+
+instance Outputable ArgOcc where
+  ppr (ScrutOcc xs) = text "scrut-occ" <> ppr xs
+  ppr UnkOcc        = text "unk-occ"
+  ppr NoOcc         = text "no-occ"
+
+evalScrutOcc :: ArgOcc
+evalScrutOcc = ScrutOcc emptyUFM
+
+-- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so
+-- that if the thing is scrutinised anywhere then we get to see that
+-- in the overall result, even if it's also used in a boxed way
+-- This might be too aggressive; see Note [Reboxing] Alternative 3
+combineOcc :: ArgOcc -> ArgOcc -> ArgOcc
+combineOcc NoOcc         occ           = occ
+combineOcc occ           NoOcc         = occ
+combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)
+combineOcc UnkOcc        (ScrutOcc ys) = ScrutOcc ys
+combineOcc (ScrutOcc xs) UnkOcc        = ScrutOcc xs
+combineOcc UnkOcc        UnkOcc        = UnkOcc
+
+combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]
+combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys
+
+setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage
+-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee
+-- is a variable, and an interesting variable
+setScrutOcc env usg (Cast e _) occ      = setScrutOcc env usg e occ
+setScrutOcc env usg (Tick _ e) occ      = setScrutOcc env usg e occ
+setScrutOcc env usg (Var v)    occ
+  | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }
+  | otherwise                           = usg
+setScrutOcc _env usg _other _occ        -- Catch-all
+  = usg
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{The main recursive function}
+*                                                                      *
+************************************************************************
+
+The main recursive function gathers up usage information, and
+creates specialised versions of functions.
+-}
+
+scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)
+        -- The unique supply is needed when we invent
+        -- a new name for the specialised function and its args
+
+scExpr env e = scExpr' env e
+
+scExpr' env (Var v)      = case scSubstId env v of
+                            Var v' -> return (mkVarUsage env v' [], Var v')
+                            e'     -> scExpr (zapScSubst env) e'
+
+scExpr' env (Type t)     = return (nullUsage, Type (scSubstTy env t))
+scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))
+scExpr' _   e@(Lit {})   = return (nullUsage, e)
+scExpr' env (Tick t e)   = do (usg, e') <- scExpr env e
+                              return (usg, Tick t e')
+scExpr' env (Cast e co)  = do (usg, e') <- scExpr env e
+                              return (usg, mkCast e' (scSubstCo env co))
+                              -- Important to use mkCast here
+                              -- See Note [SpecConstr call patterns]
+scExpr' env e@(App _ _)  = scApp env (collectArgs e)
+scExpr' env (Lam b e)    = do let (env', b') = extendBndr env b
+                              (usg, e') <- scExpr env' e
+                              return (usg, Lam b' e')
+
+scExpr' env (Case scrut b ty alts)
+  = do  { (scrut_usg, scrut') <- scExpr env scrut
+        ; case isValue (sc_vals env) scrut' of
+                Just (ConVal con args) -> sc_con_app con args scrut'
+                _other                 -> sc_vanilla scrut_usg scrut'
+        }
+  where
+    sc_con_app con args scrut'  -- Known constructor; simplify
+     = do { let (_, bs, rhs) = findAlt con alts
+                                  `orElse` (DEFAULT, [], mkImpossibleExpr ty)
+                alt_env'     = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)
+          ; scExpr alt_env' rhs }
+
+    sc_vanilla scrut_usg scrut' -- Normal case
+     = do { let (alt_env,b') = extendBndrWith RecArg env b
+                        -- Record RecArg for the components
+
+          ; (alt_usgs, alt_occs, alts')
+                <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts
+
+          ; let scrut_occ  = foldr combineOcc NoOcc alt_occs
+                scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ
+                -- The combined usage of the scrutinee is given
+                -- by scrut_occ, which is passed to scScrut, which
+                -- in turn treats a bare-variable scrutinee specially
+
+          ; return (foldr combineUsage scrut_usg' alt_usgs,
+                    Case scrut' b' (scSubstTy env ty) alts') }
+
+    sc_alt env scrut' b' (con,bs,rhs)
+     = do { let (env1, bs1) = extendBndrsWith RecArg env bs
+                (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1
+          ; (usg, rhs') <- scExpr env2 rhs
+          ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)
+                scrut_occ = case con of
+                               DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)
+                               _          -> ScrutOcc emptyUFM
+          ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) }
+
+scExpr' env (Let (NonRec bndr rhs) body)
+  | isTyVar bndr        -- Type-lets may be created by doBeta
+  = scExpr' (extendScSubst env bndr rhs) body
+
+  | otherwise
+  = do  { let (body_env, bndr') = extendBndr env bndr
+        ; rhs_info  <- scRecRhs env (bndr',rhs)
+
+        ; let body_env2 = extendHowBound body_env [bndr'] RecFun
+                           -- Note [Local let bindings]
+              rhs'      = ri_new_rhs rhs_info
+              body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')
+
+        ; (body_usg, body') <- scExpr body_env3 body
+
+          -- NB: For non-recursive bindings we inherit sc_force flag from
+          -- the parent function (see Note [Forcing specialisation])
+        ; (spec_usg, specs) <- specNonRec env body_usg rhs_info
+
+        ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }
+                    `combineUsage` spec_usg,  -- Note [spec_usg includes rhs_usg]
+                  mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body')
+        }
+
+
+-- A *local* recursive group: see Note [Local recursive groups]
+scExpr' env (Let (Rec prs) body)
+  = do  { let (bndrs,rhss)      = unzip prs
+              (rhs_env1,bndrs') = extendRecBndrs env bndrs
+              rhs_env2          = extendHowBound rhs_env1 bndrs' RecFun
+              force_spec        = any (forceSpecBndr env) bndrs'
+                -- Note [Forcing specialisation]
+
+        ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss)
+        ; (body_usg, body')     <- scExpr rhs_env2 body
+
+        -- NB: start specLoop from body_usg
+        ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec)
+                                       body_usg rhs_infos
+                -- Do not unconditionally generate specialisations from rhs_usgs
+                -- Instead use them only if we find an unspecialised call
+                -- See Note [Local recursive groups]
+
+        ; let all_usg = spec_usg `combineUsage` body_usg  -- Note [spec_usg includes rhs_usg]
+              bind'   = Rec (concat (zipWith ruleInfoBinds rhs_infos specs))
+
+        ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
+                  Let bind' body') }
+
+{-
+Note [Local let bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+It is not uncommon to find this
+
+   let $j = \x. <blah> in ...$j True...$j True...
+
+Here $j is an arbitrary let-bound function, but it often comes up for
+join points.  We might like to specialise $j for its call patterns.
+Notice the difference from a letrec, where we look for call patterns
+in the *RHS* of the function.  Here we look for call patterns in the
+*body* of the let.
+
+At one point I predicated this on the RHS mentioning the outer
+recursive function, but that's not essential and might even be
+harmful.  I'm not sure.
+-}
+
+scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)
+
+scApp env (Var fn, args)        -- Function is a variable
+  = ASSERT( not (null args) )
+    do  { args_w_usgs <- mapM (scExpr env) args
+        ; let (arg_usgs, args') = unzip args_w_usgs
+              arg_usg = combineUsages arg_usgs
+        ; case scSubstId env fn of
+            fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')
+                        -- Do beta-reduction and try again
+
+            Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args',
+                               mkApps (Var fn') args')
+
+            other_fn' -> return (arg_usg, mkApps other_fn' args') }
+                -- NB: doing this ignores any usage info from the substituted
+                --     function, but I don't think that matters.  If it does
+                --     we can fix it.
+  where
+    doBeta :: OutExpr -> [OutExpr] -> OutExpr
+    -- ToDo: adjust for System IF
+    doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
+    doBeta fn              args         = mkApps fn args
+
+-- The function is almost always a variable, but not always.
+-- In particular, if this pass follows float-in,
+-- which it may, we can get
+--      (let f = ...f... in f) arg1 arg2
+scApp env (other_fn, args)
+  = do  { (fn_usg,   fn')   <- scExpr env other_fn
+        ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args
+        ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }
+
+----------------------
+mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage
+mkVarUsage env fn args
+  = case lookupHowBound env fn of
+        Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)]
+                           , scu_occs  = emptyVarEnv }
+        Just RecArg -> SCU { scu_calls = emptyVarEnv
+                           , scu_occs  = unitVarEnv fn arg_occ }
+        Nothing     -> nullUsage
+  where
+    -- I rather think we could use UnkOcc all the time
+    arg_occ | null args = UnkOcc
+            | otherwise = evalScrutOcc
+
+----------------------
+scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)
+scTopBindEnv env (Rec prs)
+  = do  { let (rhs_env1,bndrs') = extendRecBndrs env bndrs
+              rhs_env2          = extendHowBound rhs_env1 bndrs RecFun
+
+              prs'              = zip bndrs' rhss
+        ; return (rhs_env2, Rec prs') }
+  where
+    (bndrs,rhss) = unzip prs
+
+scTopBindEnv env (NonRec bndr rhs)
+  = do  { let (env1, bndr') = extendBndr env bndr
+              env2          = extendValEnv env1 bndr' (isValue (sc_vals env) rhs)
+        ; return (env2, NonRec bndr' rhs) }
+
+----------------------
+scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)
+
+{-
+scTopBind _ usage _
+  | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False
+  = error "false"
+-}
+
+scTopBind env body_usage (Rec prs)
+  | Just threshold <- sc_size env
+  , not force_spec
+  , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss)
+                -- No specialisation
+  = -- pprTrace "scTopBind: nospec" (ppr bndrs) $
+    do  { (rhs_usgs, rhss')   <- mapAndUnzipM (scExpr env) rhss
+        ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) }
+
+  | otherwise   -- Do specialisation
+  = do  { rhs_infos <- mapM (scRecRhs env) prs
+
+        ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec)
+                                         body_usage rhs_infos
+
+        ; return (body_usage `combineUsage` spec_usage,
+                  Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) }
+  where
+    (bndrs,rhss) = unzip prs
+    force_spec   = any (forceSpecBndr env) bndrs
+      -- Note [Forcing specialisation]
+
+scTopBind env usage (NonRec bndr rhs)   -- Oddly, we don't seem to specialise top-level non-rec functions
+  = do  { (rhs_usg', rhs') <- scExpr env rhs
+        ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') }
+
+----------------------
+scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo
+scRecRhs env (bndr,rhs)
+  = do  { let (arg_bndrs,body)       = collectBinders rhs
+              (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs
+        ; (body_usg, body')         <- scExpr body_env body
+        ; let (rhs_usg, arg_occs)    = lookupOccs body_usg arg_bndrs'
+        ; return (RI { ri_rhs_usg = rhs_usg
+                     , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body'
+                     , ri_lam_bndrs = arg_bndrs, ri_lam_body = body
+                     , ri_arg_occs = arg_occs }) }
+                -- The arg_occs says how the visible,
+                -- lambda-bound binders of the RHS are used
+                -- (including the TyVar binders)
+                -- Two pats are the same if they match both ways
+
+----------------------
+ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]
+ruleInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs })
+              (SI { si_specs = specs })
+  = [(id,rhs) | OS { os_id = id, os_rhs = rhs } <- specs] ++
+              -- First the specialised bindings
+
+    [(fn `addIdSpecialisations` rules, new_rhs)]
+              -- And now the original binding
+  where
+    rules = [r | OS { os_rule = r } <- specs]
+
+{-
+************************************************************************
+*                                                                      *
+                The specialiser itself
+*                                                                      *
+************************************************************************
+-}
+
+data RhsInfo
+  = RI { ri_fn :: OutId                 -- The binder
+       , ri_new_rhs :: OutExpr          -- The specialised RHS (in current envt)
+       , ri_rhs_usg :: ScUsage          -- Usage info from specialising RHS
+
+       , ri_lam_bndrs :: [InVar]       -- The *original* RHS (\xs.body)
+       , ri_lam_body  :: InExpr        --   Note [Specialise original body]
+       , ri_arg_occs  :: [ArgOcc]      -- Info on how the xs occur in body
+    }
+
+data SpecInfo       -- Info about specialisations for a particular Id
+  = SI { si_specs :: [OneSpec]          -- The specialisations we have generated
+
+       , si_n_specs :: Int              -- Length of si_specs; used for numbering them
+
+       , si_mb_unspec :: Maybe ScUsage  -- Just cs  => we have not yet used calls in the
+       }                                --             from calls in the *original* RHS as
+                                        --             seeds for new specialisations;
+                                        --             if you decide to do so, here is the
+                                        --             RHS usage (which has not yet been
+                                        --             unleashed)
+                                        -- Nothing => we have
+                                        -- See Note [Local recursive groups]
+                                        -- See Note [spec_usg includes rhs_usg]
+
+        -- One specialisation: Rule plus definition
+data OneSpec =
+  OS { os_pat  :: CallPat    -- Call pattern that generated this specialisation
+     , os_rule :: CoreRule   -- Rule connecting original id with the specialisation
+     , os_id   :: OutId      -- Spec id
+     , os_rhs  :: OutExpr }  -- Spec rhs
+
+noSpecInfo :: SpecInfo
+noSpecInfo = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Nothing }
+
+----------------------
+specNonRec :: ScEnv
+           -> ScUsage         -- Body usage
+           -> RhsInfo         -- Structure info usage info for un-specialised RHS
+           -> UniqSM (ScUsage, SpecInfo)       -- Usage from RHSs (specialised and not)
+                                               --     plus details of specialisations
+
+specNonRec env body_usg rhs_info
+  = specialise env (scu_calls body_usg) rhs_info
+               (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) })
+
+----------------------
+specRec :: TopLevelFlag -> ScEnv
+        -> ScUsage                         -- Body usage
+        -> [RhsInfo]                       -- Structure info and usage info for un-specialised RHSs
+        -> UniqSM (ScUsage, [SpecInfo])    -- Usage from all RHSs (specialised and not)
+                                           --     plus details of specialisations
+
+specRec top_lvl env body_usg rhs_infos
+  = go 1 seed_calls nullUsage init_spec_infos
+  where
+    (seed_calls, init_spec_infos)    -- Note [Seeding top-level recursive groups]
+       | isTopLevel top_lvl
+       , any (isExportedId . ri_fn) rhs_infos   -- Seed from body and RHSs
+       = (all_calls,     [noSpecInfo | _ <- rhs_infos])
+       | otherwise                              -- Seed from body only
+       = (calls_in_body, [noSpecInfo { si_mb_unspec = Just (ri_rhs_usg ri) }
+                         | ri <- rhs_infos])
+
+    calls_in_body = scu_calls body_usg
+    calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos
+    all_calls = calls_in_rhss `combineCalls` calls_in_body
+
+    -- Loop, specialising, until you get no new specialisations
+    go :: Int   -- Which iteration of the "until no new specialisations"
+                -- loop we are on; first iteration is 1
+       -> CallEnv   -- Seed calls
+                    -- Two accumulating parameters:
+       -> ScUsage      -- Usage from earlier specialisations
+       -> [SpecInfo]   -- Details of specialisations so far
+       -> UniqSM (ScUsage, [SpecInfo])
+    go n_iter seed_calls usg_so_far spec_infos
+      | isEmptyVarEnv seed_calls
+      = -- pprTrace "specRec1" (vcat [ ppr (map ri_fn rhs_infos)
+        --                           , ppr seed_calls
+        --                           , ppr body_usg ]) $
+        return (usg_so_far, spec_infos)
+
+      -- Limit recursive specialisation
+      -- See Note [Limit recursive specialisation]
+      | n_iter > sc_recursive env  -- Too many iterations of the 'go' loop
+      , sc_force env || isNothing (sc_count env)
+           -- If both of these are false, the sc_count
+           -- threshold will prevent non-termination
+      , any ((> the_limit) . si_n_specs) spec_infos
+      = -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $
+        return (usg_so_far, spec_infos)
+
+      | otherwise
+      = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)
+        --                           , text "iteration" <+> int n_iter
+        --                          , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)
+        --                    ]) $
+        do  { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos
+            ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg
+                  extra_usg = combineUsages extra_usg_s
+                  all_usg   = usg_so_far `combineUsage` extra_usg
+            ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos }
+
+    -- See Note [Limit recursive specialisation]
+    the_limit = case sc_count env of
+                  Nothing  -> 10    -- Ugh!
+                  Just max -> max
+
+
+----------------------
+specialise
+   :: ScEnv
+   -> CallEnv                     -- Info on newly-discovered calls to this function
+   -> RhsInfo
+   -> SpecInfo                    -- Original RHS plus patterns dealt with
+   -> UniqSM (ScUsage, SpecInfo)  -- New specialised versions and their usage
+
+-- See Note [spec_usg includes rhs_usg]
+
+-- Note: this only generates *specialised* bindings
+-- The original binding is added by ruleInfoBinds
+--
+-- Note: the rhs here is the optimised version of the original rhs
+-- So when we make a specialised copy of the RHS, we're starting
+-- from an RHS whose nested functions have been optimised already.
+
+specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
+                              , ri_lam_body = body, ri_arg_occs = arg_occs })
+               spec_info@(SI { si_specs = specs, si_n_specs = spec_count
+                             , si_mb_unspec = mb_unspec })
+  | isBottomingId fn      -- Note [Do not specialise diverging functions]
+                          -- and do not generate specialisation seeds from its RHS
+  = -- pprTrace "specialise bot" (ppr fn) $
+    return (nullUsage, spec_info)
+
+  | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation]
+    || null arg_bndrs                     -- Only specialise functions
+  = -- pprTrace "specialise inactive" (ppr fn) $
+    case mb_unspec of    -- Behave as if there was a single, boring call
+      Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing })
+                         -- See Note [spec_usg includes rhs_usg]
+      Nothing      -> return (nullUsage, spec_info)
+
+  | Just all_calls <- lookupVarEnv bind_calls fn
+  = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $
+    do  { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls
+
+        ; let n_pats = length new_pats
+--        ; if (not (null new_pats) || isJust mb_unspec) then
+--            pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns"
+--                                        , text "mb_unspec" <+> ppr (isJust mb_unspec)
+--                                        , text "arg_occs" <+> ppr arg_occs
+--                                        , text "good pats" <+> ppr new_pats])  $
+--               return ()
+--          else return ()
+
+        ; let spec_env = decreaseSpecCount env n_pats
+        ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)
+                                                 (new_pats `zip` [spec_count..])
+                -- See Note [Specialise original body]
+
+        ; let spec_usg = combineUsages spec_usgs
+
+              -- If there were any boring calls among the seeds (= all_calls), then those
+              -- calls will call the un-specialised function.  So we should use the seeds
+              -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning
+              -- then in new_usg.
+              (new_usg, mb_unspec')
+                  = case mb_unspec of
+                      Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)
+                      _                          -> (spec_usg,                      mb_unspec)
+
+--        ; pprTrace "specialise return }"
+--             (vcat [ ppr fn
+--                   , text "boring_call:" <+> ppr boring_call
+--                   , text "new calls:" <+> ppr (scu_calls new_usg)]) $
+--          return ()
+
+          ; return (new_usg, SI { si_specs = new_specs ++ specs
+                                , si_n_specs = spec_count + n_pats
+                                , si_mb_unspec = mb_unspec' }) }
+
+  | otherwise  -- No new seeds, so return nullUsage
+  = return (nullUsage, spec_info)
+
+
+
+
+---------------------
+spec_one :: ScEnv
+         -> OutId       -- Function
+         -> [InVar]     -- Lambda-binders of RHS; should match patterns
+         -> InExpr      -- Body of the original function
+         -> (CallPat, Int)
+         -> UniqSM (ScUsage, OneSpec)   -- Rule and binding
+
+-- spec_one creates a specialised copy of the function, together
+-- with a rule for using it.  I'm very proud of how short this
+-- function is, considering what it does :-).
+
+{-
+  Example
+
+     In-scope: a, x::a
+     f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...
+          [c::*, v::(b,c) are presumably bound by the (...) part]
+  ==>
+     f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->
+                  (...entire body of f...) [b -> (b,c),
+                                            y -> ((:) (a,(b,c)) (x,v) hw)]
+
+     RULE:  forall b::* c::*,           -- Note, *not* forall a, x
+                   v::(b,c),
+                   hw::[(a,(b,c))] .
+
+            f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
+-}
+
+spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
+  = do  { spec_uniq <- getUniqueM
+        ; let spec_env   = extendScSubstList (extendScInScope env qvars)
+                                             (arg_bndrs `zip` pats)
+              fn_name    = idName fn
+              fn_loc     = nameSrcSpan fn_name
+              fn_occ     = nameOccName fn_name
+              spec_occ   = mkSpecOcc fn_occ
+              -- We use fn_occ rather than fn in the rule_name string
+              -- as we don't want the uniq to end up in the rule, and
+              -- hence in the ABI, as that can cause spurious ABI
+              -- changes (#4012).
+              rule_name  = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number)
+              spec_name  = mkInternalName spec_uniq spec_occ fn_loc
+--      ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn
+--                              <+> ppr pats <+> text "-->" <+> ppr spec_name) $
+--        return ()
+
+        -- Specialise the body
+        ; (spec_usg, spec_body) <- scExpr spec_env body
+
+--      ; pprTrace "done spec_one}" (ppr fn) $
+--        return ()
+
+                -- And build the results
+        ; let (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env)
+                                                             qvars body_ty
+                -- Usual w/w hack to avoid generating
+                -- a spec_rhs of unlifted type and no args
+
+              spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args
+                -- Annotate the variables with the strictness information from
+                -- the function (see Note [Strictness information in worker binders])
+
+              spec_join_arity | isJoinId fn = Just (length spec_lam_args)
+                              | otherwise   = Nothing
+              spec_id    = mkLocalIdOrCoVar spec_name
+                                            (mkLamTypes spec_lam_args body_ty)
+                             -- See Note [Transfer strictness]
+                             `setIdStrictness` spec_str
+                             `setIdArity` count isId spec_lam_args
+                             `asJoinId_maybe` spec_join_arity
+              spec_str   = calcSpecStrictness fn spec_lam_args pats
+
+
+                -- Conditionally use result of new worker-wrapper transform
+              spec_rhs   = mkLams spec_lam_args_str spec_body
+              body_ty    = exprType spec_body
+              rule_rhs   = mkVarApps (Var spec_id) spec_call_args
+              inline_act = idInlineActivation fn
+              this_mod   = sc_module spec_env
+              rule       = mkRule this_mod True {- Auto -} True {- Local -}
+                                  rule_name inline_act fn_name qvars pats rule_rhs
+                           -- See Note [Transfer activation]
+        ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule
+                               , os_id = spec_id
+                               , os_rhs = spec_rhs }) }
+
+
+-- See Note [Strictness information in worker binders]
+handOutStrictnessInformation :: [Demand] -> [Var] -> [Var]
+handOutStrictnessInformation = go
+  where
+    go _ [] = []
+    go [] vs = vs
+    go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs
+    go dmds (v:vs) = v : go dmds vs
+
+calcSpecStrictness :: Id                     -- The original function
+                   -> [Var] -> [CoreExpr]    -- Call pattern
+                   -> StrictSig              -- Strictness of specialised thing
+-- See Note [Transfer strictness]
+calcSpecStrictness fn qvars pats
+  = mkClosedStrictSig spec_dmds topRes
+  where
+    spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]
+    StrictSig (DmdType _ dmds _) = idStrictness fn
+
+    dmd_env = go emptyVarEnv dmds pats
+
+    go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv
+    go env ds (Type {} : pats)     = go env ds pats
+    go env ds (Coercion {} : pats) = go env ds pats
+    go env (d:ds) (pat : pats)     = go (go_one env d pat) ds pats
+    go env _      _                = env
+
+    go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv
+    go_one env d   (Var v) = extendVarEnv_C bothDmd env v d
+    go_one env d e
+           | Just ds <- splitProdDmd_maybe d  -- NB: d does not have to be strict
+           , (Var _, args) <- collectArgs e = go env ds args
+    go_one env _         _ = env
+
+{-
+Note [spec_usg includes rhs_usg]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In calls to 'specialise', the returned ScUsage must include the rhs_usg in
+the passed-in SpecInfo, unless there are no calls at all to the function.
+
+The caller can, indeed must, assume this.  He should not combine in rhs_usg
+himself, or he'll get rhs_usg twice -- and that can lead to an exponential
+blowup of duplicates in the CallEnv.  This is what gave rise to the massive
+performance loss in Trac #8852.
+
+Note [Specialise original body]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The RhsInfo for a binding keeps the *original* body of the binding.  We
+must specialise that, *not* the result of applying specExpr to the RHS
+(which is also kept in RhsInfo). Otherwise we end up specialising a
+specialised RHS, and that can lead directly to exponential behaviour.
+
+Note [Transfer activation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+  This note is for SpecConstr, but exactly the same thing
+  happens in the overloading specialiser; see
+  Note [Auto-specialisation and RULES] in Specialise.
+
+In which phase should the specialise-constructor rules be active?
+Originally I made them always-active, but Manuel found that this
+defeated some clever user-written rules.  Then I made them active only
+in Phase 0; after all, currently, the specConstr transformation is
+only run after the simplifier has reached Phase 0, but that meant
+that specialisations didn't fire inside wrappers; see test
+simplCore/should_compile/spec-inline.
+
+So now I just use the inline-activation of the parent Id, as the
+activation for the specialisation RULE, just like the main specialiser;
+
+This in turn means there is no point in specialising NOINLINE things,
+so we test for that.
+
+Note [Transfer strictness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must transfer strictness information from the original function to
+the specialised one.  Suppose, for example
+
+  f has strictness     SS
+        and a RULE     f (a:as) b = f_spec a as b
+
+Now we want f_spec to have strictness  LLS, otherwise we'll use call-by-need
+when calling f_spec instead of call-by-value.  And that can result in
+unbounded worsening in space (cf the classic foldl vs foldl')
+
+See Trac #3437 for a good example.
+
+The function calcSpecStrictness performs the calculation.
+
+Note [Strictness information in worker binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+After having calculated the strictness annotation for the worker (see Note
+[Transfer strictness] above), we also want to have this information attached to
+the worker’s arguments, for the benefit of later passes. The function
+handOutStrictnessInformation decomposes the strictness annotation calculated by
+calcSpecStrictness and attaches them to the variables.
+
+************************************************************************
+*                                                                      *
+\subsection{Argument analysis}
+*                                                                      *
+************************************************************************
+
+This code deals with analysing call-site arguments to see whether
+they are constructor applications.
+
+Note [Free type variables of the qvar types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a call (f @a x True), that we want to specialise, what variables should
+we quantify over.  Clearly over 'a' and 'x', but what about any type variables
+free in x's type?  In fact we don't need to worry about them because (f @a)
+can only be a well-typed application if its type is compatible with x, so any
+variables free in x's type must be free in (f @a), and hence either be gathered
+via 'a' itself, or be in scope at f's defn.  Hence we just take
+  (exprsFreeVars pats).
+
+BUT phantom type synonyms can mess this reasoning up,
+  eg   x::T b   with  type T b = Int
+So we apply expandTypeSynonyms to the bound Ids.
+See Trac # 5458.  Yuk.
+
+Note [SpecConstr call patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A "call patterns" that we collect is going to become the LHS of a RULE.
+It's important that it doesn't have
+     e |> Refl
+or
+    e |> g1 |> g2
+because both of these will be optimised by Simplify.simplRule. In the
+former case such optimisation benign, because the rule will match more
+terms; but in the latter we may lose a binding of 'g1' or 'g2', and
+end up with a rule LHS that doesn't bind the template variables
+(Trac #10602).
+
+The simplifier eliminates such things, but SpecConstr itself constructs
+new terms by substituting.  So the 'mkCast' in the Cast case of scExpr
+is very important!
+
+Note [Choosing patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~
+If we get lots of patterns we may not want to make a specialisation
+for each of them (code bloat), so we choose as follows, implemented
+by trim_pats.
+
+* The flag -fspec-constr-count-N sets the sc_count field
+  of the ScEnv to (Just n).  This limits the total number
+  of specialisations for a given function to N.
+
+* -fno-spec-constr-count sets the sc_count field to Nothing,
+  which switches of the limit.
+
+* The ghastly ForceSpecConstr trick also switches of the limit
+  for a particular function
+
+* Otherwise we sort the patterns to choose the most general
+  ones first; more general => more widely applicable.
+
+Note [SpecConstr and casts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #14270) a call like
+
+    let f = e
+    in ... f (K @(a |> co)) ...
+
+where 'co' is a coercion variable not in scope at f's definition site.
+If we aren't caereful we'll get
+
+    let $sf a co = e (K @(a |> co))
+        RULE "SC:f" forall a co.  f (K @(a |> co)) = $sf a co
+        f = e
+    in ...
+
+But alas, when we match the call we won't bind 'co', because type-matching
+(for good reasons) discards casts).
+
+I don't know how to solve this, so for now I'm just discarding any
+call patterns that
+  * Mentions a coercion variable in a type argument
+  * That is not in scope at the binding of the function
+
+I think this is very rare.
+
+It is important (e.g. Trac #14936) that this /only/ applies to
+coercions mentioned in casts.  We don't want to be discombobulated
+by casts in terms!  For example, consider
+   f ((e1,e2) |> sym co)
+where, say,
+   f  :: Foo -> blah
+   co :: Foo ~R (Int,Int)
+
+Here we definitely do want to specialise for that pair!  We do not
+match on the structre of the coercion; instead we just match on a
+coercion variable, so the RULE looks like
+
+   forall (x::Int, y::Int, co :: (Int,Int) ~R Foo)
+     f ((x,y) |> co) = $sf x y co
+
+Often the body of f looks like
+   f arg = ...(case arg |> co' of
+                (x,y) -> blah)...
+
+so that the specialised f will turn into
+   $sf x y co = let arg = (x,y) |> co
+                in ...(case arg>| co' of
+                         (x,y) -> blah)....
+
+which will simplify to not use 'co' at all.  But we can't guarantee
+that co will end up unused, so we still pass it.  Absence analysis
+may remove it later.
+
+Note that this /also/ discards the call pattern if we have a cast in a
+/term/, although in fact Rules.match does make a very flaky and
+fragile attempt to match coercions.  e.g. a call like
+    f (Maybe Age) (Nothing |> co) blah
+    where co :: Maybe Int ~ Maybe Age
+will be discarded.  It's extremely fragile to match on the form of a
+coercion, so I think it's better just not to try.  A more complicated
+alternative would be to discard calls that mention coercion variables
+only in kind-casts, but I'm doing the simple thing for now.
+-}
+
+type CallPat = ([Var], [CoreExpr])      -- Quantified variables and arguments
+                                        -- See Note [SpecConstr call patterns]
+
+callsToNewPats :: ScEnv -> Id
+               -> SpecInfo
+               -> [ArgOcc] -> [Call]
+               -> UniqSM (Bool, [CallPat])
+        -- Result has no duplicate patterns,
+        -- nor ones mentioned in done_pats
+        -- Bool indicates that there was at least one boring pattern
+callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls
+  = do  { mb_pats <- mapM (callToPats env bndr_occs) calls
+
+        ; let have_boring_call = any isNothing mb_pats
+
+              good_pats :: [CallPat]
+              good_pats = catMaybes mb_pats
+
+              -- Remove patterns we have already done
+              new_pats = filterOut is_done good_pats
+              is_done p = any (samePat p . os_pat) done_specs
+
+              -- Remove duplicates
+              non_dups = nubBy samePat new_pats
+
+              -- Remove ones that have too many worker variables
+              small_pats = filterOut too_big non_dups
+              too_big (vars,_) = not (isWorkerSmallEnough (sc_dflags env) vars)
+                  -- We are about to construct w/w pair in 'spec_one'.
+                  -- Omit specialisation leading to high arity workers.
+                  -- See Note [Limit w/w arity] in WwLib
+
+                -- Discard specialisations if there are too many of them
+              trimmed_pats = trim_pats env fn spec_info small_pats
+
+--        ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls
+--                                       , text "done_specs:" <+> ppr (map os_pat done_specs)
+--                                       , text "good_pats:" <+> ppr good_pats ]) $
+--          return ()
+
+        ; return (have_boring_call, trimmed_pats) }
+
+
+trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat]
+-- See Note [Choosing patterns]
+trim_pats env fn (SI { si_n_specs = done_spec_count }) pats
+  | sc_force env
+    || isNothing mb_scc
+    || n_remaining >= n_pats
+  = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)
+    pats          -- No need to trim
+
+  | otherwise
+  = emit_trace $  -- Need to trim, so keep the best ones
+    take n_remaining sorted_pats
+
+  where
+    n_pats         = length pats
+    spec_count'    = n_pats + done_spec_count
+    n_remaining    = max_specs - done_spec_count
+    mb_scc         = sc_count env
+    Just max_specs = mb_scc
+
+    sorted_pats = map fst $
+                  sortBy (comparing snd) $
+                  [(pat, pat_cons pat) | pat <- pats]
+     -- Sort in order of increasing number of constructors
+     -- (i.e. decreasing generality) and pick the initial
+     -- segment of this list
+
+    pat_cons :: CallPat -> Int
+    -- How many data constructors of literals are in
+    -- the pattern.  More data-cons => less general
+    pat_cons (qs, ps) = foldr ((+) . n_cons) 0 ps
+       where
+          q_set = mkVarSet qs
+          n_cons (Var v) | v `elemVarSet` q_set = 0
+                         | otherwise            = 1
+          n_cons (Cast e _)  = n_cons e
+          n_cons (App e1 e2) = n_cons e1 + n_cons e2
+          n_cons (Lit {})    = 1
+          n_cons _           = 0
+
+    emit_trace result
+       | debugIsOn || hasPprDebug (sc_dflags env)
+         -- Suppress this scary message for ordinary users!  Trac #5125
+       = pprTrace "SpecConstr" msg result
+       | otherwise
+       = result
+    msg = vcat [ sep [ text "Function" <+> quotes (ppr fn)
+                     , nest 2 (text "has" <+>
+                               speakNOf spec_count' (text "call pattern") <> comma <+>
+                               text "but the limit is" <+> int max_specs) ]
+               , text "Use -fspec-constr-count=n to set the bound"
+               , text "done_spec_count =" <+> int done_spec_count
+               , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats
+               , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ]
+
+
+callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
+        -- The [Var] is the variables to quantify over in the rule
+        --      Type variables come first, since they may scope
+        --      over the following term variables
+        -- The [CoreExpr] are the argument patterns for the rule
+callToPats env bndr_occs call@(Call _ args con_env)
+  | args `ltLength` bndr_occs      -- Check saturated
+  = return Nothing
+  | otherwise
+  = do  { let in_scope = substInScope (sc_subst env)
+        ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs
+        ; let pat_fvs = exprsFreeVarsList pats
+                -- To get determinism we need the list of free variables in
+                -- deterministic order. Otherwise we end up creating
+                -- lambdas with different argument orders. See
+                -- determinism/simplCore/should_compile/spec-inline-determ.hs
+                -- for an example. For explanation of determinism
+                -- considerations See Note [Unique Determinism] in Unique.
+
+              in_scope_vars = getInScopeVars in_scope
+              is_in_scope v = v `elemVarSet` in_scope_vars
+              qvars         = filterOut is_in_scope pat_fvs
+                -- Quantify over variables that are not in scope
+                -- at the call site
+                -- See Note [Free type variables of the qvar types]
+                -- See Note [Shadowing] at the top
+
+              (ktvs, ids)   = partition isTyVar qvars
+              qvars'        = scopedSort ktvs ++ map sanitise ids
+                -- Order into kind variables, type variables, term variables
+                -- The kind of a type variable may mention a kind variable
+                -- and the type of a term variable may mention a type variable
+
+              sanitise id   = id `setIdType` expandTypeSynonyms (idType id)
+                -- See Note [Free type variables of the qvar types]
+
+              -- Bad coercion variables: see Note [SpecConstr and casts]
+              bad_covars :: CoVarSet
+              bad_covars = mapUnionVarSet get_bad_covars pats
+              get_bad_covars :: CoreArg -> CoVarSet
+              get_bad_covars (Type ty)
+                = filterVarSet (\v -> isId v && not (is_in_scope v)) $
+                  tyCoVarsOfType ty
+              get_bad_covars _
+                = emptyVarSet
+
+        ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $
+          WARN( not (isEmptyVarSet bad_covars)
+              , text "SpecConstr: bad covars:" <+> ppr bad_covars
+                $$ ppr call )
+          if interesting && isEmptyVarSet bad_covars
+          then return (Just (qvars', pats))
+          else return Nothing }
+
+    -- argToPat takes an actual argument, and returns an abstracted
+    -- version, consisting of just the "constructor skeleton" of the
+    -- argument, with non-constructor sub-expression replaced by new
+    -- placeholder variables.  For example:
+    --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)
+
+argToPat :: ScEnv
+         -> InScopeSet                  -- What's in scope at the fn defn site
+         -> ValueEnv                    -- ValueEnv at the call site
+         -> CoreArg                     -- A call arg (or component thereof)
+         -> ArgOcc
+         -> UniqSM (Bool, CoreArg)
+
+-- Returns (interesting, pat),
+-- where pat is the pattern derived from the argument
+--            interesting=True if the pattern is non-trivial (not a variable or type)
+-- E.g.         x:xs         --> (True, x:xs)
+--              f xs         --> (False, w)        where w is a fresh wildcard
+--              (f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard
+--              \x. x+y      --> (True, \x. x+y)
+--              lvl7         --> (True, lvl7)      if lvl7 is bound
+--                                                 somewhere further out
+
+argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ
+  = return (False, arg)
+
+argToPat env in_scope val_env (Tick _ arg) arg_occ
+  = argToPat env in_scope val_env arg arg_occ
+        -- Note [Notes in call patterns]
+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        -- Ignore Notes.  In particular, we want to ignore any InlineMe notes
+        -- Perhaps we should not ignore profiling notes, but I'm going to
+        -- ride roughshod over them all for now.
+        --- See Note [Notes in RULE matching] in Rules
+
+argToPat env in_scope val_env (Let _ arg) arg_occ
+  = argToPat env in_scope val_env arg arg_occ
+        -- See Note [Matching lets] in Rule.hs
+        -- Look through let expressions
+        -- e.g.         f (let v = rhs in (v,w))
+        -- Here we can specialise for f (v,w)
+        -- because the rule-matcher will look through the let.
+
+{- Disabled; see Note [Matching cases] in Rule.hs
+argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
+  | exprOkForSpeculation scrut  -- See Note [Matching cases] in Rule.hhs
+  = argToPat env in_scope val_env rhs arg_occ
+-}
+
+argToPat env in_scope val_env (Cast arg co) arg_occ
+  | not (ignoreType env ty2)
+  = do  { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ
+        ; if not interesting then
+                wildCardPat ty2
+          else do
+        { -- Make a wild-card pattern for the coercion
+          uniq <- getUniqueM
+        ; let co_name = mkSysTvName uniq (fsLit "sg")
+              co_var  = mkCoVar co_name (mkCoercionType Representational ty1 ty2)
+        ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }
+  where
+    Pair ty1 ty2 = coercionKind co
+
+
+
+{-      Disabling lambda specialisation for now
+        It's fragile, and the spec_loop can be infinite
+argToPat in_scope val_env arg arg_occ
+  | is_value_lam arg
+  = return (True, arg)
+  where
+    is_value_lam (Lam v e)         -- Spot a value lambda, even if
+        | isId v       = True      -- it is inside a type lambda
+        | otherwise    = is_value_lam e
+    is_value_lam other = False
+-}
+
+  -- Check for a constructor application
+  -- NB: this *precedes* the Var case, so that we catch nullary constrs
+argToPat env in_scope val_env arg arg_occ
+  | Just (ConVal (DataAlt dc) args) <- isValue val_env arg
+  , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]
+  , Just arg_occs <- mb_scrut dc
+  = do  { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args
+        ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs
+        ; return (True,
+                  mkConApp dc (ty_args ++ args')) }
+  where
+    mb_scrut dc = case arg_occ of
+                    ScrutOcc bs | Just occs <- lookupUFM bs dc
+                                -> Just (occs)  -- See Note [Reboxing]
+                    _other      | sc_force env || sc_keen env
+                                -> Just (repeat UnkOcc)
+                                | otherwise
+                                -> Nothing
+
+  -- Check if the argument is a variable that
+  --    (a) is used in an interesting way in the function body
+  --    (b) we know what its value is
+  -- In that case it counts as "interesting"
+argToPat env in_scope val_env (Var v) arg_occ
+  | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)
+    is_value,                                                            -- (b)
+       -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]
+       -- So sc_keen focused just on f (I# x), where we have freshly-allocated
+       -- box that we can eliminate in the caller
+    not (ignoreType env (varType v))
+  = return (True, Var v)
+  where
+    is_value
+        | isLocalId v = v `elemInScopeSet` in_scope
+                        && isJust (lookupVarEnv val_env v)
+                -- Local variables have values in val_env
+        | otherwise   = isValueUnfolding (idUnfolding v)
+                -- Imports have unfoldings
+
+--      I'm really not sure what this comment means
+--      And by not wild-carding we tend to get forall'd
+--      variables that are in scope, which in turn can
+--      expose the weakness in let-matching
+--      See Note [Matching lets] in Rules
+
+  -- Check for a variable bound inside the function.
+  -- Don't make a wild-card, because we may usefully share
+  --    e.g.  f a = let x = ... in f (x,x)
+  -- NB: this case follows the lambda and con-app cases!!
+-- argToPat _in_scope _val_env (Var v) _arg_occ
+--   = return (False, Var v)
+        -- SLPJ : disabling this to avoid proliferation of versions
+        -- also works badly when thinking about seeding the loop
+        -- from the body of the let
+        --       f x y = letrec g z = ... in g (x,y)
+        -- We don't want to specialise for that *particular* x,y
+
+  -- The default case: make a wild-card
+  -- We use this for coercions too
+argToPat _env _in_scope _val_env arg _arg_occ
+  = wildCardPat (exprType arg)
+
+wildCardPat :: Type -> UniqSM (Bool, CoreArg)
+wildCardPat ty
+  = do { uniq <- getUniqueM
+       ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq ty
+       ; return (False, varToCoreExpr id) }
+
+argsToPats :: ScEnv -> InScopeSet -> ValueEnv
+           -> [CoreArg] -> [ArgOcc]  -- Should be same length
+           -> UniqSM (Bool, [CoreArg])
+argsToPats env in_scope val_env args occs
+  = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs
+       ; let (interesting_s, args') = unzip stuff
+       ; return (or interesting_s, args') }
+
+isValue :: ValueEnv -> CoreExpr -> Maybe Value
+isValue _env (Lit lit)
+  | litIsLifted lit = Nothing
+  | otherwise       = Just (ConVal (LitAlt lit) [])
+
+isValue env (Var v)
+  | Just cval <- lookupVarEnv env v
+  = Just cval  -- You might think we could look in the idUnfolding here
+               -- but that doesn't take account of which branch of a
+               -- case we are in, which is the whole point
+
+  | not (isLocalId v) && isCheapUnfolding unf
+  = isValue env (unfoldingTemplate unf)
+  where
+    unf = idUnfolding v
+        -- However we do want to consult the unfolding
+        -- as well, for let-bound constructors!
+
+isValue env (Lam b e)
+  | isTyVar b = case isValue env e of
+                  Just _  -> Just LambdaVal
+                  Nothing -> Nothing
+  | otherwise = Just LambdaVal
+
+isValue env (Tick t e)
+  | not (tickishIsCode t)
+  = isValue env e
+
+isValue _env expr       -- Maybe it's a constructor application
+  | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr
+  = case isDataConWorkId_maybe fun of
+
+        Just con | args `lengthAtLeast` dataConRepArity con
+                -- Check saturated; might be > because the
+                --                  arity excludes type args
+                -> Just (ConVal (DataAlt con) args)
+
+        _other | valArgCount args < idArity fun
+                -- Under-applied function
+               -> Just LambdaVal        -- Partial application
+
+        _other -> Nothing
+
+isValue _env _expr = Nothing
+
+valueIsWorkFree :: Value -> Bool
+valueIsWorkFree LambdaVal       = True
+valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args
+
+samePat :: CallPat -> CallPat -> Bool
+samePat (vs1, as1) (vs2, as2)
+  = all2 same as1 as2
+  where
+    same (Var v1) (Var v2)
+        | v1 `elem` vs1 = v2 `elem` vs2
+        | v2 `elem` vs2 = False
+        | otherwise     = v1 == v2
+
+    same (Lit l1)    (Lit l2)    = l1==l2
+    same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2
+
+    same (Type {}) (Type {}) = True     -- Note [Ignore type differences]
+    same (Coercion {}) (Coercion {}) = True
+    same (Tick _ e1) e2 = same e1 e2  -- Ignore casts and notes
+    same (Cast e1 _) e2 = same e1 e2
+    same e1 (Tick _ e2) = same e1 e2
+    same e1 (Cast e2 _) = same e1 e2
+
+    same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
+                 False  -- Let, lambda, case should not occur
+    bad (Case {}) = True
+    bad (Let {})  = True
+    bad (Lam {})  = True
+    bad _other    = False
+
+{-
+Note [Ignore type differences]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not want to generate specialisations where the call patterns
+differ only in their type arguments!  Not only is it utterly useless,
+but it also means that (with polymorphic recursion) we can generate
+an infinite number of specialisations. Example is Data.Sequence.adjustTree,
+I think.
+-}
diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs
new file mode 100644
--- /dev/null
+++ b/compiler/specialise/Specialise.hs
@@ -0,0 +1,2456 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}
+-}
+
+{-# LANGUAGE CPP #-}
+module Specialise ( specProgram, specUnfolding ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Id
+import TcType hiding( substTy )
+import Type   hiding( substTy, extendTvSubstList )
+import Module( Module, HasModule(..) )
+import Coercion( Coercion )
+import CoreMonad
+import qualified CoreSubst
+import CoreUnfold
+import Var              ( isLocalVar )
+import VarSet
+import VarEnv
+import CoreSyn
+import Rules
+import CoreOpt          ( collectBindersPushingCo )
+import CoreUtils        ( exprIsTrivial, applyTypeToArgs, mkCast )
+import CoreFVs
+import CoreArity        ( etaExpandToJoinPointRule )
+import UniqSupply
+import Name
+import MkId             ( voidArgId, voidPrimId )
+import Maybes           ( catMaybes, isJust )
+import MonadUtils       ( foldlM )
+import BasicTypes
+import HscTypes
+import Bag
+import DynFlags
+import Util
+import Outputable
+import FastString
+import State
+import UniqDFM
+
+import Control.Monad
+import qualified Control.Monad.Fail as MonadFail
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}
+*                                                                      *
+************************************************************************
+
+These notes describe how we implement specialisation to eliminate
+overloading.
+
+The specialisation pass works on Core
+syntax, complete with all the explicit dictionary application,
+abstraction and construction as added by the type checker.  The
+existing type checker remains largely as it is.
+
+One important thought: the {\em types} passed to an overloaded
+function, and the {\em dictionaries} passed are mutually redundant.
+If the same function is applied to the same type(s) then it is sure to
+be applied to the same dictionary(s)---or rather to the same {\em
+values}.  (The arguments might look different but they will evaluate
+to the same value.)
+
+Second important thought: we know that we can make progress by
+treating dictionary arguments as static and worth specialising on.  So
+we can do without binding-time analysis, and instead specialise on
+dictionary arguments and no others.
+
+The basic idea
+~~~~~~~~~~~~~~
+Suppose we have
+
+        let f = <f_rhs>
+        in <body>
+
+and suppose f is overloaded.
+
+STEP 1: CALL-INSTANCE COLLECTION
+
+We traverse <body>, accumulating all applications of f to types and
+dictionaries.
+
+(Might there be partial applications, to just some of its types and
+dictionaries?  In principle yes, but in practice the type checker only
+builds applications of f to all its types and dictionaries, so partial
+applications could only arise as a result of transformation, and even
+then I think it's unlikely.  In any case, we simply don't accumulate such
+partial applications.)
+
+
+STEP 2: EQUIVALENCES
+
+So now we have a collection of calls to f:
+        f t1 t2 d1 d2
+        f t3 t4 d3 d4
+        ...
+Notice that f may take several type arguments.  To avoid ambiguity, we
+say that f is called at type t1/t2 and t3/t4.
+
+We take equivalence classes using equality of the *types* (ignoring
+the dictionary args, which as mentioned previously are redundant).
+
+STEP 3: SPECIALISATION
+
+For each equivalence class, choose a representative (f t1 t2 d1 d2),
+and create a local instance of f, defined thus:
+
+        f@t1/t2 = <f_rhs> t1 t2 d1 d2
+
+f_rhs presumably has some big lambdas and dictionary lambdas, so lots
+of simplification will now result.  However we don't actually *do* that
+simplification.  Rather, we leave it for the simplifier to do.  If we
+*did* do it, though, we'd get more call instances from the specialised
+RHS.  We can work out what they are by instantiating the call-instance
+set from f's RHS with the types t1, t2.
+
+Add this new id to f's IdInfo, to record that f has a specialised version.
+
+Before doing any of this, check that f's IdInfo doesn't already
+tell us about an existing instance of f at the required type/s.
+(This might happen if specialisation was applied more than once, or
+it might arise from user SPECIALIZE pragmas.)
+
+Recursion
+~~~~~~~~~
+Wait a minute!  What if f is recursive?  Then we can't just plug in
+its right-hand side, can we?
+
+But it's ok.  The type checker *always* creates non-recursive definitions
+for overloaded recursive functions.  For example:
+
+        f x = f (x+x)           -- Yes I know its silly
+
+becomes
+
+        f a (d::Num a) = let p = +.sel a d
+                         in
+                         letrec fl (y::a) = fl (p y y)
+                         in
+                         fl
+
+We still have recursion for non-overloaded functions which we
+specialise, but the recursive call should get specialised to the
+same recursive version.
+
+
+Polymorphism 1
+~~~~~~~~~~~~~~
+
+All this is crystal clear when the function is applied to *constant
+types*; that is, types which have no type variables inside.  But what if
+it is applied to non-constant types?  Suppose we find a call of f at type
+t1/t2.  There are two possibilities:
+
+(a) The free type variables of t1, t2 are in scope at the definition point
+of f.  In this case there's no problem, we proceed just as before.  A common
+example is as follows.  Here's the Haskell:
+
+        g y = let f x = x+x
+              in f y + f y
+
+After typechecking we have
+
+        g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x
+                                in +.sel a d (f a d y) (f a d y)
+
+Notice that the call to f is at type type "a"; a non-constant type.
+Both calls to f are at the same type, so we can specialise to give:
+
+        g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x
+                                in +.sel a d (f@a y) (f@a y)
+
+
+(b) The other case is when the type variables in the instance types
+are *not* in scope at the definition point of f.  The example we are
+working with above is a good case.  There are two instances of (+.sel a d),
+but "a" is not in scope at the definition of +.sel.  Can we do anything?
+Yes, we can "common them up", a sort of limited common sub-expression deal.
+This would give:
+
+        g a (d::Num a) (y::a) = let +.sel@a = +.sel a d
+                                    f@a (x::a) = +.sel@a x x
+                                in +.sel@a (f@a y) (f@a y)
+
+This can save work, and can't be spotted by the type checker, because
+the two instances of +.sel weren't originally at the same type.
+
+Further notes on (b)
+
+* There are quite a few variations here.  For example, the defn of
+  +.sel could be floated ouside the \y, to attempt to gain laziness.
+  It certainly mustn't be floated outside the \d because the d has to
+  be in scope too.
+
+* We don't want to inline f_rhs in this case, because
+that will duplicate code.  Just commoning up the call is the point.
+
+* Nothing gets added to +.sel's IdInfo.
+
+* Don't bother unless the equivalence class has more than one item!
+
+Not clear whether this is all worth it.  It is of course OK to
+simply discard call-instances when passing a big lambda.
+
+Polymorphism 2 -- Overloading
+~~~~~~~~~~~~~~
+Consider a function whose most general type is
+
+        f :: forall a b. Ord a => [a] -> b -> b
+
+There is really no point in making a version of g at Int/Int and another
+at Int/Bool, because it's only instantiating the type variable "a" which
+buys us any efficiency. Since g is completely polymorphic in b there
+ain't much point in making separate versions of g for the different
+b types.
+
+That suggests that we should identify which of g's type variables
+are constrained (like "a") and which are unconstrained (like "b").
+Then when taking equivalence classes in STEP 2, we ignore the type args
+corresponding to unconstrained type variable.  In STEP 3 we make
+polymorphic versions.  Thus:
+
+        f@t1/ = /\b -> <f_rhs> t1 b d1 d2
+
+We do this.
+
+
+Dictionary floating
+~~~~~~~~~~~~~~~~~~~
+Consider this
+
+        f a (d::Num a) = let g = ...
+                         in
+                         ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
+
+Here, g is only called at one type, but the dictionary isn't in scope at the
+definition point for g.  Usually the type checker would build a
+definition for d1 which enclosed g, but the transformation system
+might have moved d1's defn inward.  Solution: float dictionary bindings
+outwards along with call instances.
+
+Consider
+
+        f x = let g p q = p==q
+                  h r s = (r+s, g r s)
+              in
+              h x x
+
+
+Before specialisation, leaving out type abstractions we have
+
+        f df x = let g :: Eq a => a -> a -> Bool
+                     g dg p q = == dg p q
+                     h :: Num a => a -> a -> (a, Bool)
+                     h dh r s = let deq = eqFromNum dh
+                                in (+ dh r s, g deq r s)
+              in
+              h df x x
+
+After specialising h we get a specialised version of h, like this:
+
+                    h' r s = let deq = eqFromNum df
+                             in (+ df r s, g deq r s)
+
+But we can't naively make an instance for g from this, because deq is not in scope
+at the defn of g.  Instead, we have to float out the (new) defn of deq
+to widen its scope.  Notice that this floating can't be done in advance -- it only
+shows up when specialisation is done.
+
+User SPECIALIZE pragmas
+~~~~~~~~~~~~~~~~~~~~~~~
+Specialisation pragmas can be digested by the type checker, and implemented
+by adding extra definitions along with that of f, in the same way as before
+
+        f@t1/t2 = <f_rhs> t1 t2 d1 d2
+
+Indeed the pragmas *have* to be dealt with by the type checker, because
+only it knows how to build the dictionaries d1 and d2!  For example
+
+        g :: Ord a => [a] -> [a]
+        {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}
+
+Here, the specialised version of g is an application of g's rhs to the
+Ord dictionary for (Tree Int), which only the type checker can conjure
+up.  There might not even *be* one, if (Tree Int) is not an instance of
+Ord!  (All the other specialision has suitable dictionaries to hand
+from actual calls.)
+
+Problem.  The type checker doesn't have to hand a convenient <f_rhs>, because
+it is buried in a complex (as-yet-un-desugared) binding group.
+Maybe we should say
+
+        f@t1/t2 = f* t1 t2 d1 d2
+
+where f* is the Id f with an IdInfo which says "inline me regardless!".
+Indeed all the specialisation could be done in this way.
+That in turn means that the simplifier has to be prepared to inline absolutely
+any in-scope let-bound thing.
+
+
+Again, the pragma should permit polymorphism in unconstrained variables:
+
+        h :: Ord a => [a] -> b -> b
+        {-# SPECIALIZE h :: [Int] -> b -> b #-}
+
+We *insist* that all overloaded type variables are specialised to ground types,
+(and hence there can be no context inside a SPECIALIZE pragma).
+We *permit* unconstrained type variables to be specialised to
+        - a ground type
+        - or left as a polymorphic type variable
+but nothing in between.  So
+
+        {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}
+
+is *illegal*.  (It can be handled, but it adds complication, and gains the
+programmer nothing.)
+
+
+SPECIALISING INSTANCE DECLARATIONS
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+        instance Foo a => Foo [a] where
+                ...
+        {-# SPECIALIZE instance Foo [Int] #-}
+
+The original instance decl creates a dictionary-function
+definition:
+
+        dfun.Foo.List :: forall a. Foo a -> Foo [a]
+
+The SPECIALIZE pragma just makes a specialised copy, just as for
+ordinary function definitions:
+
+        dfun.Foo.List@Int :: Foo [Int]
+        dfun.Foo.List@Int = dfun.Foo.List Int dFooInt
+
+The information about what instance of the dfun exist gets added to
+the dfun's IdInfo in the same way as a user-defined function too.
+
+
+Automatic instance decl specialisation?
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Can instance decls be specialised automatically?  It's tricky.
+We could collect call-instance information for each dfun, but
+then when we specialised their bodies we'd get new call-instances
+for ordinary functions; and when we specialised their bodies, we might get
+new call-instances of the dfuns, and so on.  This all arises because of
+the unrestricted mutual recursion between instance decls and value decls.
+
+Still, there's no actual problem; it just means that we may not do all
+the specialisation we could theoretically do.
+
+Furthermore, instance decls are usually exported and used non-locally,
+so we'll want to compile enough to get those specialisations done.
+
+Lastly, there's no such thing as a local instance decl, so we can
+survive solely by spitting out *usage* information, and then reading that
+back in as a pragma when next compiling the file.  So for now,
+we only specialise instance decls in response to pragmas.
+
+
+SPITTING OUT USAGE INFORMATION
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+To spit out usage information we need to traverse the code collecting
+call-instance information for all imported (non-prelude?) functions
+and data types. Then we equivalence-class it and spit it out.
+
+This is done at the top-level when all the call instances which escape
+must be for imported functions and data types.
+
+*** Not currently done ***
+
+
+Partial specialisation by pragmas
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What about partial specialisation:
+
+        k :: (Ord a, Eq b) => [a] -> b -> b -> [a]
+        {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}
+
+or even
+
+        {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}
+
+Seems quite reasonable.  Similar things could be done with instance decls:
+
+        instance (Foo a, Foo b) => Foo (a,b) where
+                ...
+        {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}
+        {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}
+
+Ho hum.  Things are complex enough without this.  I pass.
+
+
+Requirements for the simplifier
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The simplifier has to be able to take advantage of the specialisation.
+
+* When the simplifier finds an application of a polymorphic f, it looks in
+f's IdInfo in case there is a suitable instance to call instead.  This converts
+
+        f t1 t2 d1 d2   ===>   f_t1_t2
+
+Note that the dictionaries get eaten up too!
+
+* Dictionary selection operations on constant dictionaries must be
+  short-circuited:
+
+        +.sel Int d     ===>  +Int
+
+The obvious way to do this is in the same way as other specialised
+calls: +.sel has inside it some IdInfo which tells that if it's applied
+to the type Int then it should eat a dictionary and transform to +Int.
+
+In short, dictionary selectors need IdInfo inside them for constant
+methods.
+
+* Exactly the same applies if a superclass dictionary is being
+  extracted:
+
+        Eq.sel Int d   ===>   dEqInt
+
+* Something similar applies to dictionary construction too.  Suppose
+dfun.Eq.List is the function taking a dictionary for (Eq a) to
+one for (Eq [a]).  Then we want
+
+        dfun.Eq.List Int d      ===> dEq.List_Int
+
+Where does the Eq [Int] dictionary come from?  It is built in
+response to a SPECIALIZE pragma on the Eq [a] instance decl.
+
+In short, dfun Ids need IdInfo with a specialisation for each
+constant instance of their instance declaration.
+
+All this uses a single mechanism: the SpecEnv inside an Id
+
+
+What does the specialisation IdInfo look like?
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The SpecEnv of an Id maps a list of types (the template) to an expression
+
+        [Type]  |->  Expr
+
+For example, if f has this RuleInfo:
+
+        [Int, a]  ->  \d:Ord Int. f' a
+
+it means that we can replace the call
+
+        f Int t  ===>  (\d. f' t)
+
+This chucks one dictionary away and proceeds with the
+specialised version of f, namely f'.
+
+
+What can't be done this way?
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There is no way, post-typechecker, to get a dictionary for (say)
+Eq a from a dictionary for Eq [a].  So if we find
+
+        ==.sel [t] d
+
+we can't transform to
+
+        eqList (==.sel t d')
+
+where
+        eqList :: (a->a->Bool) -> [a] -> [a] -> Bool
+
+Of course, we currently have no way to automatically derive
+eqList, nor to connect it to the Eq [a] instance decl, but you
+can imagine that it might somehow be possible.  Taking advantage
+of this is permanently ruled out.
+
+Still, this is no great hardship, because we intend to eliminate
+overloading altogether anyway!
+
+A note about non-tyvar dictionaries
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some Ids have types like
+
+        forall a,b,c. Eq a -> Ord [a] -> tau
+
+This seems curious at first, because we usually only have dictionary
+args whose types are of the form (C a) where a is a type variable.
+But this doesn't hold for the functions arising from instance decls,
+which sometimes get arguments with types of form (C (T a)) for some
+type constructor T.
+
+Should we specialise wrt this compound-type dictionary?  We used to say
+"no", saying:
+        "This is a heuristic judgement, as indeed is the fact that we
+        specialise wrt only dictionaries.  We choose *not* to specialise
+        wrt compound dictionaries because at the moment the only place
+        they show up is in instance decls, where they are simply plugged
+        into a returned dictionary.  So nothing is gained by specialising
+        wrt them."
+
+But it is simpler and more uniform to specialise wrt these dicts too;
+and in future GHC is likely to support full fledged type signatures
+like
+        f :: Eq [(a,b)] => ...
+
+
+************************************************************************
+*                                                                      *
+\subsubsection{The new specialiser}
+*                                                                      *
+************************************************************************
+
+Our basic game plan is this.  For let(rec) bound function
+        f :: (C a, D c) => (a,b,c,d) -> Bool
+
+* Find any specialised calls of f, (f ts ds), where
+  ts are the type arguments t1 .. t4, and
+  ds are the dictionary arguments d1 .. d2.
+
+* Add a new definition for f1 (say):
+
+        f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2
+
+  Note that we abstract over the unconstrained type arguments.
+
+* Add the mapping
+
+        [t1,b,t3,d]  |->  \d1 d2 -> f1 b d
+
+  to the specialisations of f.  This will be used by the
+  simplifier to replace calls
+                (f t1 t2 t3 t4) da db
+  by
+                (\d1 d1 -> f1 t2 t4) da db
+
+  All the stuff about how many dictionaries to discard, and what types
+  to apply the specialised function to, are handled by the fact that the
+  SpecEnv contains a template for the result of the specialisation.
+
+We don't build *partial* specialisations for f.  For example:
+
+  f :: Eq a => a -> a -> Bool
+  {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-}
+
+Here, little is gained by making a specialised copy of f.
+There's a distinct danger that the specialised version would
+first build a dictionary for (Eq b, Eq c), and then select the (==)
+method from it!  Even if it didn't, not a great deal is saved.
+
+We do, however, generate polymorphic, but not overloaded, specialisations:
+
+  f :: Eq a => [a] -> b -> b -> b
+  ... SPECIALISE f :: [Int] -> b -> b -> b ...
+
+Hence, the invariant is this:
+
+        *** no specialised version is overloaded ***
+
+
+************************************************************************
+*                                                                      *
+\subsubsection{The exported function}
+*                                                                      *
+************************************************************************
+-}
+
+-- | Specialise calls to type-class overloaded functions occuring in a program.
+specProgram :: ModGuts -> CoreM ModGuts
+specProgram guts@(ModGuts { mg_module = this_mod
+                          , mg_rules = local_rules
+                          , mg_binds = binds })
+  = do { dflags <- getDynFlags
+
+             -- Specialise the bindings of this module
+       ; (binds', uds) <- runSpecM dflags this_mod (go binds)
+
+             -- Specialise imported functions
+       ; hpt_rules <- getRuleBase
+       ; let rule_base = extendRuleBaseList hpt_rules local_rules
+       ; (new_rules, spec_binds) <- specImports dflags this_mod top_env emptyVarSet
+                                                [] rule_base uds
+
+       ; let final_binds
+               | null spec_binds = binds'
+               | otherwise       = Rec (flattenBinds spec_binds) : binds'
+                   -- Note [Glom the bindings if imported functions are specialised]
+
+       ; return (guts { mg_binds = final_binds
+                      , mg_rules = new_rules ++ local_rules }) }
+  where
+        -- We need to start with a Subst that knows all the things
+        -- that are in scope, so that the substitution engine doesn't
+        -- accidentally re-use a unique that's already in use
+        -- Easiest thing is to do it all at once, as if all the top-level
+        -- decls were mutually recursive
+    top_env = SE { se_subst = CoreSubst.mkEmptySubst $ mkInScopeSet $ mkVarSet $
+                              bindersOfBinds binds
+                 , se_interesting = emptyVarSet }
+
+    go []           = return ([], emptyUDs)
+    go (bind:binds) = do (binds', uds) <- go binds
+                         (bind', uds') <- specBind top_env bind uds
+                         return (bind' ++ binds', uds')
+
+{-
+Note [Wrap bindings returned by specImports]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'specImports' returns a set of specialized bindings. However, these are lacking
+necessary floated dictionary bindings, which are returned by
+UsageDetails(ud_binds). These dictionaries need to be brought into scope with
+'wrapDictBinds' before the bindings returned by 'specImports' can be used. See,
+for instance, the 'specImports' call in 'specProgram'.
+
+
+Note [Disabling cross-module specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Since GHC 7.10 we have performed specialisation of INLINABLE bindings living
+in modules outside of the current module. This can sometimes uncover user code
+which explodes in size when aggressively optimized. The
+-fno-cross-module-specialise option was introduced to allow users to being
+bitten by such instances to revert to the pre-7.10 behavior.
+
+See Trac #10491
+-}
+
+-- | Specialise a set of calls to imported bindings
+specImports :: DynFlags
+            -> Module
+            -> SpecEnv          -- Passed in so that all top-level Ids are in scope
+            -> VarSet           -- Don't specialise these ones
+                                -- See Note [Avoiding recursive specialisation]
+            -> [Id]             -- Stack of imported functions being specialised
+            -> RuleBase         -- Rules from this module and the home package
+                                -- (but not external packages, which can change)
+            -> UsageDetails     -- Calls for imported things, and floating bindings
+            -> CoreM ( [CoreRule]   -- New rules
+                     , [CoreBind] ) -- Specialised bindings
+                                    -- See Note [Wrapping bindings returned by specImports]
+specImports dflags this_mod top_env done callers rule_base
+            (MkUD { ud_binds = dict_binds, ud_calls = calls })
+  -- See Note [Disabling cross-module specialisation]
+  | not $ gopt Opt_CrossModuleSpecialise dflags
+  = return ([], [])
+
+  | otherwise
+  = do { let import_calls = dVarEnvElts calls
+       ; (rules, spec_binds) <- go rule_base import_calls
+
+             -- Don't forget to wrap the specialized bindings with
+             -- bindings for the needed dictionaries.
+             -- See Note [Wrap bindings returned by specImports]
+       ; let spec_binds' = wrapDictBinds dict_binds spec_binds
+
+       ; return (rules, spec_binds') }
+  where
+    go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind])
+    go _ [] = return ([], [])
+    go rb (cis@(CIS fn _) : other_calls)
+      = do { let ok_calls = filterCalls cis dict_binds
+                     -- Drop calls that (directly or indirectly) refer to fn
+                     -- See Note [Avoiding loops]
+--           ; debugTraceMsg (text "specImport" <+> vcat [ ppr fn
+--                                                       , text "calls" <+> ppr cis
+--                                                       , text "ud_binds =" <+> ppr dict_binds
+--                                                       , text "dump set =" <+> ppr dump_set
+--                                                       , text "filtered calls =" <+> ppr ok_calls ])
+           ; (rules1, spec_binds1) <- specImport dflags this_mod top_env
+                                                 done callers rb fn ok_calls
+
+           ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls
+           ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
+
+specImport :: DynFlags
+           -> Module
+           -> SpecEnv               -- Passed in so that all top-level Ids are in scope
+           -> VarSet                -- Don't specialise these
+                                    -- See Note [Avoiding recursive specialisation]
+           -> [Id]                  -- Stack of imported functions being specialised
+           -> RuleBase              -- Rules from this module
+           -> Id -> [CallInfo]      -- Imported function and calls for it
+           -> CoreM ( [CoreRule]    -- New rules
+                    , [CoreBind] )  -- Specialised bindings
+specImport dflags this_mod top_env done callers rb fn calls_for_fn
+  | fn `elemVarSet` done
+  = return ([], [])     -- No warning.  This actually happens all the time
+                        -- when specialising a recursive function, because
+                        -- the RHS of the specialised function contains a recursive
+                        -- call to the original function
+
+  | null calls_for_fn   -- We filtered out all the calls in deleteCallsMentioning
+  = return ([], [])
+
+  | wantSpecImport dflags unfolding
+  , Just rhs <- maybeUnfoldingTemplate unfolding
+  = do {     -- Get rules from the external package state
+             -- We keep doing this in case we "page-fault in"
+             -- more rules as we go along
+       ; hsc_env <- getHscEnv
+       ; eps <- liftIO $ hscEPS hsc_env
+       ; vis_orphs <- getVisibleOrphanMods
+       ; let full_rb = unionRuleBase rb (eps_rule_base eps)
+             rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn
+
+       ; (rules1, spec_pairs, uds)
+             <- -- pprTrace "specImport1" (vcat [ppr fn, ppr calls_for_fn, ppr rhs]) $
+                runSpecM dflags this_mod $
+                specCalls (Just this_mod) top_env rules_for_fn calls_for_fn fn rhs
+       ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
+             -- After the rules kick in we may get recursion, but
+             -- we rely on a global GlomBinds to sort that out later
+             -- See Note [Glom the bindings if imported functions are specialised]
+
+              -- Now specialise any cascaded calls
+       ; (rules2, spec_binds2) <- -- pprTrace "specImport 2" (ppr fn $$ ppr rules1 $$ ppr spec_binds1) $
+                                  specImports dflags this_mod top_env
+                                              (extendVarSet done fn)
+                                              (fn:callers)
+                                              (extendRuleBaseList rb rules1)
+                                              uds
+
+       ; let final_binds = spec_binds2 ++ spec_binds1
+
+       ; return (rules2 ++ rules1, final_binds) }
+
+  |  warnMissingSpecs dflags callers
+  = do { warnMsg (vcat [ hang (text "Could not specialise imported function" <+> quotes (ppr fn))
+                            2 (vcat [ text "when specialising" <+> quotes (ppr caller)
+                                    | caller <- callers])
+                      , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))
+                      , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])
+       ; return ([], []) }
+
+  | otherwise
+  = return ([], [])
+  where
+    unfolding = realIdUnfolding fn   -- We want to see the unfolding even for loop breakers
+
+warnMissingSpecs :: DynFlags -> [Id] -> Bool
+-- See Note [Warning about missed specialisations]
+warnMissingSpecs dflags callers
+  | wopt Opt_WarnAllMissedSpecs dflags = True
+  | not (wopt Opt_WarnMissedSpecs dflags) = False
+  | null callers                       = False
+  | otherwise                          = all has_inline_prag callers
+  where
+    has_inline_prag id = isAnyInlinePragma (idInlinePragma id)
+
+wantSpecImport :: DynFlags -> Unfolding -> Bool
+-- See Note [Specialise imported INLINABLE things]
+wantSpecImport dflags unf
+ = case unf of
+     NoUnfolding      -> False
+     BootUnfolding    -> False
+     OtherCon {}      -> False
+     DFunUnfolding {} -> True
+     CoreUnfolding { uf_src = src, uf_guidance = _guidance }
+       | gopt Opt_SpecialiseAggressively dflags -> True
+       | isStableSource src -> True
+               -- Specialise even INLINE things; it hasn't inlined yet,
+               -- so perhaps it never will.  Moreover it may have calls
+               -- inside it that we want to specialise
+       | otherwise -> False    -- Stable, not INLINE, hence INLINABLE
+
+{- Note [Warning about missed specialisations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose
+ * In module Lib, you carefully mark a function 'foo' INLINABLE
+ * Import Lib(foo) into another module M
+ * Call 'foo' at some specialised type in M
+Then you jolly well expect it to be specialised in M.  But what if
+'foo' calls another function 'Lib.bar'.  Then you'd like 'bar' to be
+specialised too.  But if 'bar' is not marked INLINABLE it may well
+not be specialised.  The warning Opt_WarnMissedSpecs warns about this.
+
+It's more noisy to warning about a missed specialisation opportunity
+for /every/ overloaded imported function, but sometimes useful. That
+is what Opt_WarnAllMissedSpecs does.
+
+ToDo: warn about missed opportunities for local functions.
+
+Note [Specialise imported INLINABLE things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What imported functions do we specialise?  The basic set is
+ * DFuns and things with INLINABLE pragmas.
+but with -fspecialise-aggressively we add
+ * Anything with an unfolding template
+
+Trac #8874 has a good example of why we want to auto-specialise DFuns.
+
+We have the -fspecialise-aggressively flag (usually off), because we
+risk lots of orphan modules from over-vigorous specialisation.
+However it's not a big deal: anything non-recursive with an
+unfolding-template will probably have been inlined already.
+
+Note [Glom the bindings if imported functions are specialised]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have an imported, *recursive*, INLINABLE function
+   f :: Eq a => a -> a
+   f = /\a \d x. ...(f a d)...
+In the module being compiled we have
+   g x = f (x::Int)
+Now we'll make a specialised function
+   f_spec :: Int -> Int
+   f_spec = \x -> ...(f Int dInt)...
+   {-# RULE  f Int _ = f_spec #-}
+   g = \x. f Int dInt x
+Note that f_spec doesn't look recursive
+After rewriting with the RULE, we get
+   f_spec = \x -> ...(f_spec)...
+BUT since f_spec was non-recursive before it'll *stay* non-recursive.
+The occurrence analyser never turns a NonRec into a Rec.  So we must
+make sure that f_spec is recursive.  Easiest thing is to make all
+the specialisations for imported bindings recursive.
+
+
+Note [Avoiding recursive specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we specialise 'f' we may find new overloaded calls to 'g', 'h' in
+'f's RHS.  So we want to specialise g,h.  But we don't want to
+specialise f any more!  It's possible that f's RHS might have a
+recursive yet-more-specialised call, so we'd diverge in that case.
+And if the call is to the same type, one specialisation is enough.
+Avoiding this recursive specialisation loop is the reason for the
+'done' VarSet passed to specImports and specImport.
+
+************************************************************************
+*                                                                      *
+\subsubsection{@specExpr@: the main function}
+*                                                                      *
+************************************************************************
+-}
+
+data SpecEnv
+  = SE { se_subst :: CoreSubst.Subst
+             -- We carry a substitution down:
+             -- a) we must clone any binding that might float outwards,
+             --    to avoid name clashes
+             -- b) we carry a type substitution to use when analysing
+             --    the RHS of specialised bindings (no type-let!)
+
+
+       , se_interesting :: VarSet
+             -- Dict Ids that we know something about
+             -- and hence may be worth specialising against
+             -- See Note [Interesting dictionary arguments]
+     }
+
+specVar :: SpecEnv -> Id -> CoreExpr
+specVar env v = CoreSubst.lookupIdSubst (text "specVar") (se_subst env) v
+
+specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
+
+---------------- First the easy cases --------------------
+specExpr env (Type ty)     = return (Type     (substTy env ty), emptyUDs)
+specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs)
+specExpr env (Var v)       = return (specVar env v, emptyUDs)
+specExpr _   (Lit lit)     = return (Lit lit,       emptyUDs)
+specExpr env (Cast e co)
+  = do { (e', uds) <- specExpr env e
+       ; return ((mkCast e' (substCo env co)), uds) }
+specExpr env (Tick tickish body)
+  = do { (body', uds) <- specExpr env body
+       ; return (Tick (specTickish env tickish) body', uds) }
+
+---------------- Applications might generate a call instance --------------------
+specExpr env expr@(App {})
+  = go expr []
+  where
+    go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg
+                               (fun', uds_app) <- go fun (arg':args)
+                               return (App fun' arg', uds_arg `plusUDs` uds_app)
+
+    go (Var f)       args = case specVar env f of
+                                Var f' -> return (Var f', mkCallUDs env f' args)
+                                e'     -> return (e', emptyUDs) -- I don't expect this!
+    go other         _    = specExpr env other
+
+---------------- Lambda/case require dumping of usage details --------------------
+specExpr env e@(Lam _ _) = do
+    (body', uds) <- specExpr env' body
+    let (free_uds, dumped_dbs) = dumpUDs bndrs' uds
+    return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds)
+  where
+    (bndrs, body) = collectBinders e
+    (env', bndrs') = substBndrs env bndrs
+        -- More efficient to collect a group of binders together all at once
+        -- and we don't want to split a lambda group with dumped bindings
+
+specExpr env (Case scrut case_bndr ty alts)
+  = do { (scrut', scrut_uds) <- specExpr env scrut
+       ; (scrut'', case_bndr', alts', alts_uds)
+             <- specCase env scrut' case_bndr alts
+       ; return (Case scrut'' case_bndr' (substTy env ty) alts'
+                , scrut_uds `plusUDs` alts_uds) }
+
+---------------- Finally, let is the interesting case --------------------
+specExpr env (Let bind body)
+  = do { -- Clone binders
+         (rhs_env, body_env, bind') <- cloneBindSM env bind
+
+         -- Deal with the body
+       ; (body', body_uds) <- specExpr body_env body
+
+        -- Deal with the bindings
+      ; (binds', uds) <- specBind rhs_env bind' body_uds
+
+        -- All done
+      ; return (foldr Let body' binds', uds) }
+
+specTickish :: SpecEnv -> Tickish Id -> Tickish Id
+specTickish env (Breakpoint ix ids)
+  = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]]
+  -- drop vars from the list if they have a non-variable substitution.
+  -- should never happen, but it's harmless to drop them anyway.
+specTickish _ other_tickish = other_tickish
+
+specCase :: SpecEnv
+         -> CoreExpr            -- Scrutinee, already done
+         -> Id -> [CoreAlt]
+         -> SpecM ( CoreExpr    -- New scrutinee
+                  , Id
+                  , [CoreAlt]
+                  , UsageDetails)
+specCase env scrut' case_bndr [(con, args, rhs)]
+  | isDictId case_bndr           -- See Note [Floating dictionaries out of cases]
+  , interestingDict env scrut'
+  , not (isDeadBinder case_bndr && null sc_args')
+  = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args')
+
+       ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg')
+                              [(con, args', Var sc_arg')]
+                       | sc_arg' <- sc_args' ]
+
+             -- Extend the substitution for RHS to map the *original* binders
+             -- to their floated versions.
+             mb_sc_flts :: [Maybe DictId]
+             mb_sc_flts = map (lookupVarEnv clone_env) args'
+             clone_env  = zipVarEnv sc_args' sc_args_flt
+             subst_prs  = (case_bndr, Var case_bndr_flt)
+                        : [ (arg, Var sc_flt)
+                          | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]
+             env_rhs' = env_rhs { se_subst = CoreSubst.extendIdSubstList (se_subst env_rhs) subst_prs
+                                , se_interesting = se_interesting env_rhs `extendVarSetList`
+                                                   (case_bndr_flt : sc_args_flt) }
+
+       ; (rhs', rhs_uds)   <- specExpr env_rhs' rhs
+       ; let scrut_bind    = mkDB (NonRec case_bndr_flt scrut')
+             case_bndr_set = unitVarSet case_bndr_flt
+             sc_binds      = [(NonRec sc_arg_flt sc_rhs, case_bndr_set)
+                             | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ]
+             flt_binds     = scrut_bind : sc_binds
+             (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds
+             all_uds = flt_binds `addDictBinds` free_uds
+             alt'    = (con, args', wrapDictBindsE dumped_dbs rhs')
+       ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
+  where
+    (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args)
+    sc_args' = filter is_flt_sc_arg args'
+
+    clone_me bndr = do { uniq <- getUniqueM
+                       ; return (mkUserLocalOrCoVar occ uniq ty loc) }
+       where
+         name = idName bndr
+         ty   = idType bndr
+         occ  = nameOccName name
+         loc  = getSrcSpan name
+
+    arg_set = mkVarSet args'
+    is_flt_sc_arg var =  isId var
+                      && not (isDeadBinder var)
+                      && isDictTy var_ty
+                      && not (tyCoVarsOfType var_ty `intersectsVarSet` arg_set)
+       where
+         var_ty = idType var
+
+
+specCase env scrut case_bndr alts
+  = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts
+       ; return (scrut, case_bndr', alts', uds_alts) }
+  where
+    (env_alt, case_bndr') = substBndr env case_bndr
+    spec_alt (con, args, rhs) = do
+          (rhs', uds) <- specExpr env_rhs rhs
+          let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds
+          return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds)
+        where
+          (env_rhs, args') = substBndrs env_alt args
+
+{-
+Note [Floating dictionaries out of cases]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   g = \d. case d of { MkD sc ... -> ...(f sc)... }
+Naively we can't float d2's binding out of the case expression,
+because 'sc' is bound by the case, and that in turn means we can't
+specialise f, which seems a pity.
+
+So we invert the case, by floating out a binding
+for 'sc_flt' thus:
+    sc_flt = case d of { MkD sc ... -> sc }
+Now we can float the call instance for 'f'.  Indeed this is just
+what'll happen if 'sc' was originally bound with a let binding,
+but case is more efficient, and necessary with equalities. So it's
+good to work with both.
+
+You might think that this won't make any difference, because the
+call instance will only get nuked by the \d.  BUT if 'g' itself is
+specialised, then transitively we should be able to specialise f.
+
+In general, given
+   case e of cb { MkD sc ... -> ...(f sc)... }
+we transform to
+   let cb_flt = e
+       sc_flt = case cb_flt of { MkD sc ... -> sc }
+   in
+   case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... }
+
+The "_flt" things are the floated binds; we use the current substitution
+to substitute sc -> sc_flt in the RHS
+
+************************************************************************
+*                                                                      *
+                     Dealing with a binding
+*                                                                      *
+************************************************************************
+-}
+
+specBind :: SpecEnv                     -- Use this for RHSs
+         -> CoreBind                    -- Binders are already cloned by cloneBindSM,
+                                        -- but RHSs are un-processed
+         -> UsageDetails                -- Info on how the scope of the binding
+         -> SpecM ([CoreBind],          -- New bindings
+                   UsageDetails)        -- And info to pass upstream
+
+-- Returned UsageDetails:
+--    No calls for binders of this bind
+specBind rhs_env (NonRec fn rhs) body_uds
+  = do { (rhs', rhs_uds) <- specExpr rhs_env rhs
+       ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds fn rhs
+
+       ; let pairs = spec_defns ++ [(fn', rhs')]
+                        -- fn' mentions the spec_defns in its rules,
+                        -- so put the latter first
+
+             combined_uds = body_uds1 `plusUDs` rhs_uds
+
+             (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds
+
+             final_binds :: [DictBind]
+             -- See Note [From non-recursive to recursive]
+             final_binds
+               | not (isEmptyBag dump_dbs)
+               , not (null spec_defns)
+               = [recWithDumpedDicts pairs dump_dbs]
+               | otherwise
+               = [mkDB $ NonRec b r | (b,r) <- pairs]
+                 ++ bagToList dump_dbs
+
+       ; if float_all then
+             -- Rather than discard the calls mentioning the bound variables
+             -- we float this (dictionary) binding along with the others
+              return ([], free_uds `snocDictBinds` final_binds)
+         else
+             -- No call in final_uds mentions bound variables,
+             -- so we can just leave the binding here
+              return (map fst final_binds, free_uds) }
+
+
+specBind rhs_env (Rec pairs) body_uds
+       -- Note [Specialising a recursive group]
+  = do { let (bndrs,rhss) = unzip pairs
+       ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss
+       ; let scope_uds = body_uds `plusUDs` rhs_uds
+                       -- Includes binds and calls arising from rhss
+
+       ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs
+
+       ; (bndrs3, spec_defns3, uds3)
+             <- if null spec_defns1  -- Common case: no specialisation
+                then return (bndrs1, [], uds1)
+                else do {            -- Specialisation occurred; do it again
+                          (bndrs2, spec_defns2, uds2)
+                              <- specDefns rhs_env uds1 (bndrs1 `zip` rhss)
+                        ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) }
+
+       ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3
+             final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss')
+                                             dumped_dbs
+
+       ; if float_all then
+              return ([], final_uds `snocDictBind` final_bind)
+         else
+              return ([fst final_bind], final_uds) }
+
+
+---------------------------
+specDefns :: SpecEnv
+          -> UsageDetails               -- Info on how it is used in its scope
+          -> [(OutId,InExpr)]           -- The things being bound and their un-processed RHS
+          -> SpecM ([OutId],            -- Original Ids with RULES added
+                    [(OutId,OutExpr)],  -- Extra, specialised bindings
+                    UsageDetails)       -- Stuff to fling upwards from the specialised versions
+
+-- Specialise a list of bindings (the contents of a Rec), but flowing usages
+-- upwards binding by binding.  Example: { f = ...g ...; g = ...f .... }
+-- Then if the input CallDetails has a specialised call for 'g', whose specialisation
+-- in turn generates a specialised call for 'f', we catch that in this one sweep.
+-- But not vice versa (it's a fixpoint problem).
+
+specDefns _env uds []
+  = return ([], [], uds)
+specDefns env uds ((bndr,rhs):pairs)
+  = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs
+       ; (bndr1, spec_defns2, uds2)  <- specDefn env uds1 bndr rhs
+       ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }
+
+---------------------------
+specDefn :: SpecEnv
+         -> UsageDetails                -- Info on how it is used in its scope
+         -> OutId -> InExpr             -- The thing being bound and its un-processed RHS
+         -> SpecM (Id,                  -- Original Id with added RULES
+                   [(Id,CoreExpr)],     -- Extra, specialised bindings
+                   UsageDetails)        -- Stuff to fling upwards from the specialised versions
+
+specDefn env body_uds fn rhs
+  = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds
+             rules_for_me = idCoreRules fn
+       ; (rules, spec_defns, spec_uds) <- specCalls Nothing env rules_for_me
+                                                    calls_for_me fn rhs
+       ; return ( fn `addIdSpecialisations` rules
+                , spec_defns
+                , body_uds_without_me `plusUDs` spec_uds) }
+                -- It's important that the `plusUDs` is this way
+                -- round, because body_uds_without_me may bind
+                -- dictionaries that are used in calls_for_me passed
+                -- to specDefn.  So the dictionary bindings in
+                -- spec_uds may mention dictionaries bound in
+                -- body_uds_without_me
+
+---------------------------
+specCalls :: Maybe Module      -- Just this_mod  =>  specialising imported fn
+                               -- Nothing        =>  specialising local fn
+          -> SpecEnv
+          -> [CoreRule]        -- Existing RULES for the fn
+          -> [CallInfo]
+          -> OutId -> InExpr
+          -> SpecM SpecInfo    -- New rules, specialised bindings, and usage details
+
+-- This function checks existing rules, and does not create
+-- duplicate ones. So the caller does not need to do this filtering.
+-- See 'already_covered'
+
+type SpecInfo = ( [CoreRule]       -- Specialisation rules
+                , [(Id,CoreExpr)]  -- Specialised definition
+                , UsageDetails )   -- Usage details from specialised RHSs
+
+specCalls mb_mod env existing_rules calls_for_me fn rhs
+        -- The first case is the interesting one
+  |  rhs_tyvars `lengthIs`      n_tyvars -- Rhs of fn's defn has right number of big lambdas
+  && rhs_bndrs1 `lengthAtLeast` n_dicts -- and enough dict args
+  && notNull calls_for_me               -- And there are some calls to specialise
+  && not (isNeverActive (idInlineActivation fn))
+        -- Don't specialise NOINLINE things
+        -- See Note [Auto-specialisation and RULES]
+
+--   && not (certainlyWillInline (idUnfolding fn))      -- And it's not small
+--      See Note [Inline specialisation] for why we do not
+--      switch off specialisation for inline functions
+
+  = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $
+    foldlM spec_call ([], [], emptyUDs) calls_for_me
+
+  | otherwise   -- No calls or RHS doesn't fit our preconceptions
+  = WARN( not (exprIsTrivial rhs) && notNull calls_for_me,
+          text "Missed specialisation opportunity for"
+                                 <+> ppr fn $$ _trace_doc )
+          -- Note [Specialisation shape]
+    -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $
+    return ([], [], emptyUDs)
+  where
+    _trace_doc = sep [ ppr rhs_tyvars, ppr n_tyvars
+                     , ppr rhs_bndrs, ppr n_dicts
+                     , ppr (idInlineActivation fn) ]
+
+    fn_type                 = idType fn
+    fn_arity                = idArity fn
+    fn_unf                  = realIdUnfolding fn  -- Ignore loop-breaker-ness here
+    (tyvars, theta, _)      = tcSplitSigmaTy fn_type
+    n_tyvars                = length tyvars
+    n_dicts                 = length theta
+    inl_prag                = idInlinePragma fn
+    inl_act                 = inlinePragmaActivation inl_prag
+    is_local                = isLocalId fn
+
+        -- Figure out whether the function has an INLINE pragma
+        -- See Note [Inline specialisations]
+
+    (rhs_bndrs, rhs_body)      = collectBindersPushingCo rhs
+                                 -- See Note [Account for casts in binding]
+    (rhs_tyvars, rhs_bndrs1)   = span isTyVar rhs_bndrs
+    (rhs_dict_ids, rhs_bndrs2) = splitAt n_dicts rhs_bndrs1
+    body                       = mkLams rhs_bndrs2 rhs_body
+                                 -- Glue back on the non-dict lambdas
+
+    in_scope = CoreSubst.substInScope (se_subst env)
+
+    already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool
+    already_covered dflags new_rules args      -- Note [Specialisations already covered]
+       = isJust (lookupRule dflags (in_scope, realIdUnfolding)
+                            (const True) fn args
+                            (new_rules ++ existing_rules))
+         -- NB: we look both in the new_rules (generated by this invocation
+         --     of specCalls), and in existing_rules (passed in to specCalls)
+
+    mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr]
+    mk_ty_args [] poly_tvs
+      = ASSERT( null poly_tvs ) []
+    mk_ty_args (Nothing : call_ts) (poly_tv : poly_tvs)
+      = Type (mkTyVarTy poly_tv) : mk_ty_args call_ts poly_tvs
+    mk_ty_args (Just ty : call_ts) poly_tvs
+      = Type ty : mk_ty_args call_ts poly_tvs
+    mk_ty_args (Nothing : _) [] = panic "mk_ty_args"
+
+    ----------------------------------------------------------
+        -- Specialise to one particular call pattern
+    spec_call :: SpecInfo                         -- Accumulating parameter
+              -> CallInfo                         -- Call instance
+              -> SpecM SpecInfo
+    spec_call spec_acc@(rules_acc, pairs_acc, uds_acc)
+              (CI { ci_key = CallKey call_ts, ci_args = call_ds })
+      = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )
+
+        -- Suppose f's defn is  f = /\ a b c -> \ d1 d2 -> rhs
+        -- Suppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2]
+
+        -- Construct the new binding
+        --      f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs)
+        -- PLUS the rule
+        --      RULE "SPEC f" forall b d1' d2'. f b d1' d2' = f1 b
+        --      In the rule, d1' and d2' are just wildcards, not used in the RHS
+        -- PLUS the usage-details
+        --      { d1' = dx1; d2' = dx2 }
+        -- where d1', d2' are cloned versions of d1,d2, with the type substitution
+        -- applied.  These auxiliary bindings just avoid duplication of dx1, dx2
+        --
+        -- Note that the substitution is applied to the whole thing.
+        -- This is convenient, but just slightly fragile.  Notably:
+        --      * There had better be no name clashes in a/b/c
+        do { let
+                -- poly_tyvars = [b] in the example above
+                -- spec_tyvars = [a,c]
+                -- ty_args     = [t1,b,t3]
+                spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts]
+                env1          = extendTvSubstList env spec_tv_binds
+                (rhs_env, poly_tyvars) = substBndrs env1
+                                            [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]
+
+             -- Clone rhs_dicts, including instantiating their types
+           ; inst_dict_ids <- mapM (newDictBndr rhs_env) rhs_dict_ids
+           ; let (rhs_env2, dx_binds, spec_dict_args)
+                            = bindAuxiliaryDicts rhs_env rhs_dict_ids call_ds inst_dict_ids
+                 ty_args    = mk_ty_args call_ts poly_tyvars
+                 ev_args    = map varToCoreExpr inst_dict_ids  -- ev_args, ev_bndrs:
+                 ev_bndrs   = exprsFreeIdsList ev_args         -- See Note [Evidence foralls]
+                 rule_args  = ty_args     ++ ev_args
+                 rule_bndrs = poly_tyvars ++ ev_bndrs
+
+           ; dflags <- getDynFlags
+           ; if already_covered dflags rules_acc rule_args
+             then return spec_acc
+             else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids
+                  --                           , text "rhs_env2" <+> ppr (se_subst rhs_env2)
+                  --                           , ppr dx_binds ]) $
+                  do
+           {    -- Figure out the type of the specialised function
+             let body_ty = applyTypeToArgs rhs fn_type rule_args
+                 (lam_args, app_args)           -- Add a dummy argument if body_ty is unlifted
+                   | isUnliftedType body_ty     -- C.f. WwLib.mkWorkerArgs
+                   , not (isJoinId fn)
+                   = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [voidPrimId])
+                   | otherwise = (poly_tyvars, poly_tyvars)
+                 spec_id_ty = mkLamTypes lam_args body_ty
+                 join_arity_change = length app_args - length rule_args
+                 spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn
+                                 = Just (orig_join_arity + join_arity_change)
+                                 | otherwise
+                                 = Nothing
+
+           ; spec_f <- newSpecIdSM fn spec_id_ty spec_join_arity
+           ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_args body)
+           ; this_mod <- getModule
+           ; let
+                -- The rule to put in the function's specialisation is:
+                --      forall b, d1',d2'.  f t1 b t3 d1' d2' = f1 b
+                herald = case mb_mod of
+                           Nothing        -- Specialising local fn
+                               -> text "SPEC"
+                           Just this_mod  -- Specialising imported fn
+                               -> text "SPEC/" <> ppr this_mod
+
+                rule_name = mkFastString $ showSDoc dflags $
+                            herald <+> ftext (occNameFS (getOccName fn))
+                                   <+> hsep (map ppr_call_key_ty call_ts)
+                            -- This name ends up in interface files, so use occNameString.
+                            -- Otherwise uniques end up there, making builds
+                            -- less deterministic (See #4012 comment:61 ff)
+
+                rule_wout_eta = mkRule
+                                  this_mod
+                                  True {- Auto generated -}
+                                  is_local
+                                  rule_name
+                                  inl_act       -- Note [Auto-specialisation and RULES]
+                                  (idName fn)
+                                  rule_bndrs
+                                  rule_args
+                                  (mkVarApps (Var spec_f) app_args)
+
+                spec_rule
+                  = case isJoinId_maybe fn of
+                      Just join_arity -> etaExpandToJoinPointRule join_arity
+                                                                  rule_wout_eta
+                      Nothing -> rule_wout_eta
+
+                -- Add the { d1' = dx1; d2' = dx2 } usage stuff
+                spec_uds = foldr consDictBind rhs_uds dx_binds
+
+                --------------------------------------
+                -- Add a suitable unfolding if the spec_inl_prag says so
+                -- See Note [Inline specialisations]
+                (spec_inl_prag, spec_unf)
+                  | not is_local && isStrongLoopBreaker (idOccInfo fn)
+                  = (neverInlinePragma, noUnfolding)
+                        -- See Note [Specialising imported functions] in OccurAnal
+
+                  | InlinePragma { inl_inline = Inlinable } <- inl_prag
+                  = (inl_prag { inl_inline = NoUserInline }, noUnfolding)
+
+                  | otherwise
+                  = (inl_prag, specUnfolding dflags poly_tyvars spec_app
+                                             arity_decrease fn_unf)
+
+                arity_decrease = length spec_dict_args
+                spec_app e = (e `mkApps` ty_args) `mkApps` spec_dict_args
+
+                --------------------------------------
+                -- Adding arity information just propagates it a bit faster
+                --      See Note [Arity decrease] in Simplify
+                -- Copy InlinePragma information from the parent Id.
+                -- So if f has INLINE[1] so does spec_f
+                spec_f_w_arity = spec_f `setIdArity`      max 0 (fn_arity - n_dicts)
+                                        `setInlinePragma` spec_inl_prag
+                                        `setIdUnfolding`  spec_unf
+                                        `asJoinId_maybe`  spec_join_arity
+
+           ; return ( spec_rule                  : rules_acc
+                    , (spec_f_w_arity, spec_rhs) : pairs_acc
+                    , spec_uds           `plusUDs` uds_acc
+                    ) } }
+
+{- Note [Account for casts in binding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f :: Eq a => a -> IO ()
+   {-# INLINABLE f
+       StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g
+     #-}
+   f = ...
+
+In f's stable unfolding we have done some modest simplification which
+has pushed the cast to the outside.  (I wonder if this is the Right
+Thing, but it's what happens now; see SimplUtils Note [Casts and
+lambdas].)  Now that stable unfolding must be specialised, so we want
+to push the cast back inside. It would be terrible if the cast
+defeated specialisation!  Hence the use of collectBindersPushingCo.
+
+Note [Evidence foralls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose (Trac #12212) that we are specialising
+   f :: forall a b. (Num a, F a ~ F b) => blah
+with a=b=Int. Then the RULE will be something like
+   RULE forall (d:Num Int) (g :: F Int ~ F Int).
+        f Int Int d g = f_spec
+But both varToCoreExpr (when constructing the LHS args), and the
+simplifier (when simplifying the LHS args), will transform to
+   RULE forall (d:Num Int) (g :: F Int ~ F Int).
+        f Int Int d <F Int> = f_spec
+by replacing g with Refl.  So now 'g' is unbound, which results in a later
+crash. So we use Refl right off the bat, and do not forall-quantify 'g':
+ * varToCoreExpr generates a Refl
+ * exprsFreeIdsList returns the Ids bound by the args,
+   which won't include g
+
+You might wonder if this will match as often, but the simplifier replaces
+complicated Refl coercions with Refl pretty aggressively.
+
+Note [Orphans and auto-generated rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we specialise an INLINABLE function, or when we have
+-fspecialise-aggressively, we auto-generate RULES that are orphans.
+We don't want to warn about these, or we'd generate a lot of warnings.
+Thus, we only warn about user-specified orphan rules.
+
+Indeed, we don't even treat the module as an orphan module if it has
+auto-generated *rule* orphans.  Orphan modules are read every time we
+compile, so they are pretty obtrusive and slow down every compilation,
+even non-optimised ones.  (Reason: for type class instances it's a
+type correctness issue.)  But specialisation rules are strictly for
+*optimisation* only so it's fine not to read the interface.
+
+What this means is that a SPEC rules from auto-specialisation in
+module M will be used in other modules only if M.hi has been read for
+some other reason, which is actually pretty likely.
+-}
+
+bindAuxiliaryDicts
+        :: SpecEnv
+        -> [DictId] -> [CoreExpr]   -- Original dict bndrs, and the witnessing expressions
+        -> [DictId]                 -- A cloned dict-id for each dict arg
+        -> (SpecEnv,                -- Substitute for all orig_dicts
+            [DictBind],             -- Auxiliary dict bindings
+            [CoreExpr])             -- Witnessing expressions (all trivial)
+-- Bind any dictionary arguments to fresh names, to preserve sharing
+bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting })
+                   orig_dict_ids call_ds inst_dict_ids
+  = (env', dx_binds, spec_dict_args)
+  where
+    (dx_binds, spec_dict_args) = go call_ds inst_dict_ids
+    env' = env { se_subst = subst `CoreSubst.extendSubstList`
+                                     (orig_dict_ids `zip` spec_dict_args)
+                                  `CoreSubst.extendInScopeList` dx_ids
+               , se_interesting = interesting `unionVarSet` interesting_dicts }
+
+    dx_ids = [dx_id | (NonRec dx_id _, _) <- dx_binds]
+    interesting_dicts = mkVarSet [ dx_id | (NonRec dx_id dx, _) <- dx_binds
+                                 , interestingDict env dx ]
+                  -- See Note [Make the new dictionaries interesting]
+
+    go :: [CoreExpr] -> [CoreBndr] -> ([DictBind], [CoreExpr])
+    go [] _  = ([], [])
+    go (dx:dxs) (dx_id:dx_ids)
+      | exprIsTrivial dx = (dx_binds,                          dx        : args)
+      | otherwise        = (mkDB (NonRec dx_id dx) : dx_binds, Var dx_id : args)
+      where
+        (dx_binds, args) = go dxs dx_ids
+             -- In the first case extend the substitution but not bindings;
+             -- in the latter extend the bindings but not the substitution.
+             -- For the former, note that we bind the *original* dict in the substitution,
+             -- overriding any d->dx_id binding put there by substBndrs
+    go _ _ = pprPanic "bindAuxiliaryDicts" (ppr orig_dict_ids $$ ppr call_ds $$ ppr inst_dict_ids)
+
+{-
+Note [Make the new dictionaries interesting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Important!  We're going to substitute dx_id1 for d
+and we want it to look "interesting", else we won't gather *any*
+consequential calls. E.g.
+    f d = ...g d....
+If we specialise f for a call (f (dfun dNumInt)), we'll get
+a consequent call (g d') with an auxiliary definition
+    d' = df dNumInt
+We want that consequent call to look interesting
+
+
+Note [From non-recursive to recursive]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Even in the non-recursive case, if any dict-binds depend on 'fn' we might
+have built a recursive knot
+
+      f a d x = <blah>
+      MkUD { ud_binds = NonRec d7  (MkD ..f..)
+           , ud_calls = ...(f T d7)... }
+
+The we generate
+
+     Rec { fs x = <blah>[T/a, d7/d]
+           f a d x = <blah>
+               RULE f T _ = fs
+           d7 = ...f... }
+
+Here the recursion is only through the RULE.
+
+However we definitely should /not/ make the Rec in this wildly common
+case:
+      d = ...
+      MkUD { ud_binds = NonRec d7 (...d...)
+           , ud_calls = ...(f T d7)... }
+
+Here we want simply to add d to the floats, giving
+      MkUD { ud_binds = NonRec d (...)
+                        NonRec d7 (...d...)
+           , ud_calls = ...(f T d7)... }
+
+In general, we need only make this Rec if
+  - there are some specialisations (spec_binds non-empty)
+  - there are some dict_binds that depend on f (dump_dbs non-empty)
+
+Note [Avoiding loops]
+~~~~~~~~~~~~~~~~~~~~~
+When specialising /dictionary functions/ we must be very careful to
+avoid building loops. Here is an example that bit us badly: Trac #3591
+
+     class Eq a => C a
+     instance Eq [a] => C [a]
+
+This translates to
+     dfun :: Eq [a] -> C [a]
+     dfun a d = MkD a d (meth d)
+
+     d4 :: Eq [T] = <blah>
+     d2 ::  C [T] = dfun T d4
+     d1 :: Eq [T] = $p1 d2
+     d3 ::  C [T] = dfun T d1
+
+None of these definitions is recursive. What happened was that we
+generated a specialisation:
+
+     RULE forall d. dfun T d = dT  :: C [T]
+     dT = (MkD a d (meth d)) [T/a, d1/d]
+        = MkD T d1 (meth d1)
+
+But now we use the RULE on the RHS of d2, to get
+
+    d2 = dT = MkD d1 (meth d1)
+    d1 = $p1 d2
+
+and now d1 is bottom!  The problem is that when specialising 'dfun' we
+should first dump "below" the binding all floated dictionary bindings
+that mention 'dfun' itself.  So d2 and d3 (and hence d1) must be
+placed below 'dfun', and thus unavailable to it when specialising
+'dfun'.  That in turn means that the call (dfun T d1) must be
+discarded.  On the other hand, the call (dfun T d4) is fine, assuming
+d4 doesn't mention dfun.
+
+Solution:
+  Discard all calls that mention dictionaries that depend
+  (directly or indirectly) on the dfun we are specialising.
+  This is done by 'filterCalls'
+
+--------------
+Here's another example, this time for an imported dfun, so the call
+to filterCalls is in specImports (Trac #13429). Suppose we have
+  class Monoid v => C v a where ...
+
+We start with a call
+   f @ [Integer] @ Integer $fC[]Integer
+
+Specialising call to 'f' gives dict bindings
+   $dMonoid_1 :: Monoid [Integer]
+   $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer
+
+   $dC_1 :: C [Integer] (Node [Integer] Integer)
+   $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1
+
+...plus a recursive call to
+   f @ [Integer] @ (Node [Integer] Integer) $dC_1
+
+Specialising that call gives
+   $dMonoid_2  :: Monoid [Integer]
+   $dMonoid_2  = M.$p1C @ [Integer] $dC_1
+
+   $dC_2 :: C [Integer] (Node [Integer] Integer)
+   $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2
+
+Now we have two calls to the imported function
+  M.$fCvNode :: Monoid v => C v a
+  M.$fCvNode @v @a m = C m some_fun
+
+But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2)
+for specialisation, else we get:
+
+  $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1
+  $dMonoid_2 = M.$p1C @ [Integer] $dC_1
+  $s$fCvNode = C $dMonoid_2 ...
+    RULE M.$fCvNode [Integer] _ _ = $s$fCvNode
+
+Now use the rule to rewrite the call in the RHS of $dC_1
+and we get a loop!
+
+--------------
+Here's yet another example
+
+  class C a where { foo,bar :: [a] -> [a] }
+
+  instance C Int where
+     foo x = r_bar x
+     bar xs = reverse xs
+
+  r_bar :: C a => [a] -> [a]
+  r_bar xs = bar (xs ++ xs)
+
+That translates to:
+
+    r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)
+
+    Rec { $fCInt :: C Int = MkC foo_help reverse
+          foo_help (xs::[Int]) = r_bar Int $fCInt xs }
+
+The call (r_bar $fCInt) mentions $fCInt,
+                        which mentions foo_help,
+                        which mentions r_bar
+But we DO want to specialise r_bar at Int:
+
+    Rec { $fCInt :: C Int = MkC foo_help reverse
+          foo_help (xs::[Int]) = r_bar Int $fCInt xs
+
+          r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)
+            RULE r_bar Int _ = r_bar_Int
+
+          r_bar_Int xs = bar Int $fCInt (xs ++ xs)
+           }
+
+Note that, because of its RULE, r_bar joins the recursive
+group.  (In this case it'll unravel a short moment later.)
+
+
+Note [Specialising a recursive group]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+    let rec { f x = ...g x'...
+            ; g y = ...f y'.... }
+    in f 'a'
+Here we specialise 'f' at Char; but that is very likely to lead to
+a specialisation of 'g' at Char.  We must do the latter, else the
+whole point of specialisation is lost.
+
+But we do not want to keep iterating to a fixpoint, because in the
+presence of polymorphic recursion we might generate an infinite number
+of specialisations.
+
+So we use the following heuristic:
+  * Arrange the rec block in dependency order, so far as possible
+    (the occurrence analyser already does this)
+
+  * Specialise it much like a sequence of lets
+
+  * Then go through the block a second time, feeding call-info from
+    the RHSs back in the bottom, as it were
+
+In effect, the ordering maxmimises the effectiveness of each sweep,
+and we do just two sweeps.   This should catch almost every case of
+monomorphic recursion -- the exception could be a very knotted-up
+recursion with multiple cycles tied up together.
+
+This plan is implemented in the Rec case of specBindItself.
+
+Note [Specialisations already covered]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We obviously don't want to generate two specialisations for the same
+argument pattern.  There are two wrinkles
+
+1. We do the already-covered test in specDefn, not when we generate
+the CallInfo in mkCallUDs.  We used to test in the latter place, but
+we now iterate the specialiser somewhat, and the Id at the call site
+might therefore not have all the RULES that we can see in specDefn
+
+2. What about two specialisations where the second is an *instance*
+of the first?  If the more specific one shows up first, we'll generate
+specialisations for both.  If the *less* specific one shows up first,
+we *don't* currently generate a specialisation for the more specific
+one.  (See the call to lookupRule in already_covered.)  Reasons:
+  (a) lookupRule doesn't say which matches are exact (bad reason)
+  (b) if the earlier specialisation is user-provided, it's
+      far from clear that we should auto-specialise further
+
+Note [Auto-specialisation and RULES]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider:
+   g :: Num a => a -> a
+   g = ...
+
+   f :: (Int -> Int) -> Int
+   f w = ...
+   {-# RULE f g = 0 #-}
+
+Suppose that auto-specialisation makes a specialised version of
+g::Int->Int That version won't appear in the LHS of the RULE for f.
+So if the specialisation rule fires too early, the rule for f may
+never fire.
+
+It might be possible to add new rules, to "complete" the rewrite system.
+Thus when adding
+        RULE forall d. g Int d = g_spec
+also add
+        RULE f g_spec = 0
+
+But that's a bit complicated.  For now we ask the programmer's help,
+by *copying the INLINE activation pragma* to the auto-specialised
+rule.  So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule
+will also not be active until phase 2.  And that's what programmers
+should jolly well do anyway, even aside from specialisation, to ensure
+that g doesn't inline too early.
+
+This in turn means that the RULE would never fire for a NOINLINE
+thing so not much point in generating a specialisation at all.
+
+Note [Specialisation shape]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We only specialise a function if it has visible top-level lambdas
+corresponding to its overloading.  E.g. if
+        f :: forall a. Eq a => ....
+then its body must look like
+        f = /\a. \d. ...
+
+Reason: when specialising the body for a call (f ty dexp), we want to
+substitute dexp for d, and pick up specialised calls in the body of f.
+
+This doesn't always work.  One example I came across was this:
+        newtype Gen a = MkGen{ unGen :: Int -> a }
+
+        choose :: Eq a => a -> Gen a
+        choose n = MkGen (\r -> n)
+
+        oneof = choose (1::Int)
+
+It's a silly example, but we get
+        choose = /\a. g `cast` co
+where choose doesn't have any dict arguments.  Thus far I have not
+tried to fix this (wait till there's a real example).
+
+Mind you, then 'choose' will be inlined (since RHS is trivial) so
+it doesn't matter.  This comes up with single-method classes
+
+   class C a where { op :: a -> a }
+   instance C a => C [a] where ....
+==>
+   $fCList :: C a => C [a]
+   $fCList = $copList |> (...coercion>...)
+   ....(uses of $fCList at particular types)...
+
+So we suppress the WARN if the rhs is trivial.
+
+Note [Inline specialisations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is what we do with the InlinePragma of the original function
+  * Activation/RuleMatchInfo: both transferred to the
+                              specialised function
+  * InlineSpec:
+       (a) An INLINE pragma is transferred
+       (b) An INLINABLE pragma is *not* transferred
+
+Why (a): transfer INLINE pragmas? The point of INLINE was precisely to
+specialise the function at its call site, and arguably that's not so
+important for the specialised copies.  BUT *pragma-directed*
+specialisation now takes place in the typechecker/desugarer, with
+manually specified INLINEs.  The specialisation here is automatic.
+It'd be very odd if a function marked INLINE was specialised (because
+of some local use), and then forever after (including importing
+modules) the specialised version wasn't INLINEd.  After all, the
+programmer said INLINE!
+
+You might wonder why we specialise INLINE functions at all.  After
+all they should be inlined, right?  Two reasons:
+
+ * Even INLINE functions are sometimes not inlined, when they aren't
+   applied to interesting arguments.  But perhaps the type arguments
+   alone are enough to specialise (even though the args are too boring
+   to trigger inlining), and it's certainly better to call the
+   specialised version.
+
+ * The RHS of an INLINE function might call another overloaded function,
+   and we'd like to generate a specialised version of that function too.
+   This actually happens a lot. Consider
+      replicateM_ :: (Monad m) => Int -> m a -> m ()
+      {-# INLINABLE replicateM_ #-}
+      replicateM_ d x ma = ...
+   The strictness analyser may transform to
+      replicateM_ :: (Monad m) => Int -> m a -> m ()
+      {-# INLINE replicateM_ #-}
+      replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma
+
+      $wreplicateM_ :: (Monad m) => Int# -> m a -> m ()
+      {-# INLINABLE $wreplicateM_ #-}
+      $wreplicateM_ = ...
+   Now an importing module has a specialised call to replicateM_, say
+   (replicateM_ dMonadIO).  We certainly want to specialise $wreplicateM_!
+   This particular example had a huge effect on the call to replicateM_
+   in nofib/shootout/n-body.
+
+Why (b): discard INLINABLE pragmas? See Trac #4874 for persuasive examples.
+Suppose we have
+    {-# INLINABLE f #-}
+    f :: Ord a => [a] -> Int
+    f xs = letrec f' = ...f'... in f'
+Then, when f is specialised and optimised we might get
+    wgo :: [Int] -> Int#
+    wgo = ...wgo...
+    f_spec :: [Int] -> Int
+    f_spec xs = case wgo xs of { r -> I# r }
+and we clearly want to inline f_spec at call sites.  But if we still
+have the big, un-optimised of f (albeit specialised) captured in an
+INLINABLE pragma for f_spec, we won't get that optimisation.
+
+So we simply drop INLINABLE pragmas when specialising. It's not really
+a complete solution; ignoring specialisation for now, INLINABLE functions
+don't get properly strictness analysed, for example. But it works well
+for examples involving specialisation, which is the dominant use of
+INLINABLE.  See Trac #4874.
+
+
+************************************************************************
+*                                                                      *
+\subsubsection{UsageDetails and suchlike}
+*                                                                      *
+************************************************************************
+-}
+
+data UsageDetails
+  = MkUD {
+      ud_binds :: !(Bag DictBind),
+               -- See Note [Floated dictionary bindings]
+               -- The order is important;
+               -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
+               -- (Remember, Bags preserve order in GHC.)
+
+      ud_calls :: !CallDetails
+
+      -- INVARIANT: suppose bs = bindersOf ud_binds
+      -- Then 'calls' may *mention* 'bs',
+      -- but there should be no calls *for* bs
+    }
+
+-- | A 'DictBind' is a binding along with a cached set containing its free
+-- variables (both type variables and dictionaries)
+type DictBind = (CoreBind, VarSet)
+
+{- Note [Floated dictionary bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We float out dictionary bindings for the reasons described under
+"Dictionary floating" above.  But not /just/ dictionary bindings.
+Consider
+
+   f :: Eq a => blah
+   f a d = rhs
+
+   $c== :: T -> T -> Bool
+   $c== x y = ...
+
+   $df :: Eq T
+   $df = Eq $c== ...
+
+   gurgle = ...(f @T $df)...
+
+We gather the call info for (f @T $df), and we don't want to drop it
+when we come across the binding for $df.  So we add $df to the floats
+and continue.  But then we have to add $c== to the floats, and so on.
+These all float above the binding for 'f', and and now we can
+successfully specialise 'f'.
+
+So the DictBinds in (ud_binds :: Bag DictBind) may contain
+non-dictionary bindings too.
+-}
+
+instance Outputable UsageDetails where
+  ppr (MkUD { ud_binds = dbs, ud_calls = calls })
+        = text "MkUD" <+> braces (sep (punctuate comma
+                [text "binds" <+> equals <+> ppr dbs,
+                 text "calls" <+> equals <+> ppr calls]))
+
+emptyUDs :: UsageDetails
+emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv }
+
+------------------------------------------------------------
+type CallDetails  = DIdEnv CallInfoSet
+  -- The order of specialized binds and rules depends on how we linearize
+  -- CallDetails, so to get determinism we must use a deterministic set here.
+  -- See Note [Deterministic UniqFM] in UniqDFM
+
+data CallInfoSet = CIS Id (Bag CallInfo)
+  -- The list of types and dictionaries is guaranteed to
+  -- match the type of f
+  -- The Bag may contain duplicate calls (i.e. f @T and another f @T)
+  -- These dups are eliminated by already_covered in specCalls
+
+data CallInfo
+  = CI { ci_key  :: CallKey     -- Type arguments
+       , ci_args :: [DictExpr]  -- Dictionary arguments
+       , ci_fvs  :: VarSet      -- Free vars of the ci_key and ci_args
+                                -- call (including tyvars)
+                                -- [*not* include the main id itself, of course]
+    }
+
+newtype CallKey   = CallKey [Maybe Type]
+  -- Nothing => unconstrained type argument
+
+type DictExpr = CoreExpr
+
+ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet
+ciSetFilter p (CIS id a) = CIS id (filterBag p a)
+
+instance Outputable CallInfoSet where
+  ppr (CIS fn map) = hang (text "CIS" <+> ppr fn)
+                        2 (ppr map)
+
+pprCallInfo :: Id -> CallInfo -> SDoc
+pprCallInfo fn (CI { ci_key = key })
+  = ppr fn <+> ppr key
+
+ppr_call_key_ty :: Maybe Type -> SDoc
+ppr_call_key_ty Nothing   = char '_'
+ppr_call_key_ty (Just ty) = char '@' <+> pprParendType ty
+
+instance Outputable CallKey where
+  ppr (CallKey ts) = brackets (fsep (map ppr_call_key_ty ts))
+
+instance Outputable CallInfo where
+  ppr (CI { ci_key = key, ci_args = args, ci_fvs = fvs })
+    = text "CI" <> braces (hsep [ ppr key, ppr args, ppr fvs ])
+
+unionCalls :: CallDetails -> CallDetails -> CallDetails
+unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2
+
+unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet
+unionCallInfoSet (CIS f calls1) (CIS _ calls2) =
+  CIS f (calls1 `unionBags` calls2)
+
+callDetailsFVs :: CallDetails -> VarSet
+callDetailsFVs calls =
+  nonDetFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls
+  -- It's OK to use nonDetFoldUDFM here because we forget the ordering
+  -- immediately by converting to a nondeterministic set.
+
+callInfoFVs :: CallInfoSet -> VarSet
+callInfoFVs (CIS _ call_info) =
+  foldrBag (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info
+
+------------------------------------------------------------
+singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails
+singleCall id tys dicts
+  = MkUD {ud_binds = emptyBag,
+          ud_calls = unitDVarEnv id $ CIS id $
+                     unitBag (CI { ci_key = CallKey tys
+                                 , ci_args = dicts
+                                 , ci_fvs  = call_fvs }) }
+  where
+    call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
+    tys_fvs  = tyCoVarsOfTypes (catMaybes tys)
+        -- The type args (tys) are guaranteed to be part of the dictionary
+        -- types, because they are just the constrained types,
+        -- and the dictionary is therefore sure to be bound
+        -- inside the binding for any type variables free in the type;
+        -- hence it's safe to neglect tyvars free in tys when making
+        -- the free-var set for this call
+        -- BUT I don't trust this reasoning; play safe and include tys_fvs
+        --
+        -- We don't include the 'id' itself.
+
+mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails
+mkCallUDs env f args
+  = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ])
+    res
+  where
+    res = mkCallUDs' env f args
+
+mkCallUDs' env f args
+  | not (want_calls_for f)  -- Imported from elsewhere
+  || null theta             -- Not overloaded
+  = emptyUDs
+
+  |  not (all type_determines_value theta)
+  || not (spec_tys `lengthIs` n_tyvars)
+  || not ( dicts   `lengthIs` n_dicts)
+  || not (any (interestingDict env) dicts)    -- Note [Interesting dictionary arguments]
+  -- See also Note [Specialisations already covered]
+  = -- pprTrace "mkCallUDs: discarding" _trace_doc
+    emptyUDs    -- Not overloaded, or no specialisation wanted
+
+  | otherwise
+  = -- pprTrace "mkCallUDs: keeping" _trace_doc
+    singleCall f spec_tys dicts
+  where
+    _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts
+                      , ppr (map (interestingDict env) dicts)]
+    (tyvars, theta, _)      = tcSplitSigmaTy (idType f)
+    constrained_tyvars      = tyCoVarsOfTypes theta
+    n_tyvars                = length tyvars
+    n_dicts                 = length theta
+
+    spec_tys = [mk_spec_ty tv ty | (tv, ty) <- tyvars `type_zip` args]
+    dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]
+
+    -- ignores Coercion arguments
+    type_zip :: [TyVar] -> [CoreExpr] -> [(TyVar, Type)]
+    type_zip tvs      (Coercion _ : args) = type_zip tvs args
+    type_zip (tv:tvs) (Type ty : args)    = (tv, ty) : type_zip tvs args
+    type_zip _        _                   = []
+
+    mk_spec_ty tyvar ty
+        | tyvar `elemVarSet` constrained_tyvars = Just ty
+        | otherwise                             = Nothing
+
+    want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f))
+         -- For imported things, we gather call instances if
+         -- there is an unfolding that we could in principle specialise
+         -- We might still decide not to use it (consulting dflags)
+         -- in specImports
+         -- Use 'realIdUnfolding' to ignore the loop-breaker flag!
+
+    type_determines_value pred    -- See Note [Type determines value]
+        = case classifyPredType pred of
+            ClassPred cls _ -> not (isIPClass cls)  -- Superclasses can't be IPs
+            EqPred {}       -> True
+            IrredPred {}    -> True   -- Things like (D []) where D is a
+                                      -- Constraint-ranged family; Trac #7785
+            ForAllPred {}   -> True
+
+{-
+Note [Type determines value]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Only specialise if all overloading is on non-IP *class* params,
+because these are the ones whose *type* determines their *value*.  In
+parrticular, with implicit params, the type args *don't* say what the
+value of the implicit param is!  See Trac #7101
+
+However, consider
+         type family D (v::*->*) :: Constraint
+         type instance D [] = ()
+         f :: D v => v Char -> Int
+If we see a call (f "foo"), we'll pass a "dictionary"
+  () |> (g :: () ~ D [])
+and it's good to specialise f at this dictionary.
+
+So the question is: can an implicit parameter "hide inside" a
+type-family constraint like (D a).  Well, no.  We don't allow
+        type instance D Maybe = ?x:Int
+Hence the IrredPred case in type_determines_value.
+See Trac #7785.
+
+Note [Interesting dictionary arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+         \a.\d:Eq a.  let f = ... in ...(f d)...
+There really is not much point in specialising f wrt the dictionary d,
+because the code for the specialised f is not improved at all, because
+d is lambda-bound.  We simply get junk specialisations.
+
+What is "interesting"?  Just that it has *some* structure.  But what about
+variables?
+
+ * A variable might be imported, in which case its unfolding
+   will tell us whether it has useful structure
+
+ * Local variables are cloned on the way down (to avoid clashes when
+   we float dictionaries), and cloning drops the unfolding
+   (cloneIdBndr).  Moreover, we make up some new bindings, and it's a
+   nuisance to give them unfoldings.  So we keep track of the
+   "interesting" dictionaries as a VarSet in SpecEnv.
+   We have to take care to put any new interesting dictionary
+   bindings in the set.
+
+We accidentally lost accurate tracking of local variables for a long
+time, because cloned variables don't have unfoldings. But makes a
+massive difference in a few cases, eg Trac #5113. For nofib as a
+whole it's only a small win: 2.2% improvement in allocation for ansi,
+1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size.
+-}
+
+interestingDict :: SpecEnv -> CoreExpr -> Bool
+-- A dictionary argument is interesting if it has *some* structure
+-- NB: "dictionary" arguments include constraints of all sorts,
+--     including equality constraints; hence the Coercion case
+interestingDict env (Var v) =  hasSomeUnfolding (idUnfolding v)
+                            || isDataConWorkId v
+                            || v `elemVarSet` se_interesting env
+interestingDict _ (Type _)                = False
+interestingDict _ (Coercion _)            = False
+interestingDict env (App fn (Type _))     = interestingDict env fn
+interestingDict env (App fn (Coercion _)) = interestingDict env fn
+interestingDict env (Tick _ a)            = interestingDict env a
+interestingDict env (Cast e _)            = interestingDict env e
+interestingDict _ _                       = True
+
+plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
+plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})
+        (MkUD {ud_binds = db2, ud_calls = calls2})
+  = MkUD { ud_binds = db1    `unionBags`   db2
+         , ud_calls = calls1 `unionCalls`  calls2 }
+
+-----------------------------
+_dictBindBndrs :: Bag DictBind -> [Id]
+_dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs
+
+-- | Construct a 'DictBind' from a 'CoreBind'
+mkDB :: CoreBind -> DictBind
+mkDB bind = (bind, bind_fvs bind)
+
+-- | Identify the free variables of a 'CoreBind'
+bind_fvs :: CoreBind -> VarSet
+bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
+bind_fvs (Rec prs)         = foldl' delVarSet rhs_fvs bndrs
+                           where
+                             bndrs = map fst prs
+                             rhs_fvs = unionVarSets (map pair_fvs prs)
+
+pair_fvs :: (Id, CoreExpr) -> VarSet
+pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs
+                       `unionVarSet` idFreeVars bndr
+        -- idFreeVars: don't forget variables mentioned in
+        -- the rules of the bndr.  C.f. OccAnal.addRuleUsage
+        -- Also tyvars mentioned in its type; they may not appear
+        -- in the RHS
+        --      type T a = Int
+        --      x :: T a = 3
+  where
+    interesting :: InterestingVarFun
+    interesting v = isLocalVar v || (isId v && isDFunId v)
+        -- Very important: include DFunIds /even/ if it is imported
+        -- Reason: See Note [Avoiding loops], the second exmaple
+        --         involving an imported dfun.  We must know whether
+        --         a dictionary binding depends on an imported dfun,
+        --         in case we try to specialise that imported dfun
+        --         Trac #13429 illustrates
+
+-- | Flatten a set of "dumped" 'DictBind's, and some other binding
+-- pairs, into a single recursive binding.
+recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind ->DictBind
+recWithDumpedDicts pairs dbs
+  = (Rec bindings, fvs)
+  where
+    (bindings, fvs) = foldrBag add
+                               ([], emptyVarSet)
+                               (dbs `snocBag` mkDB (Rec pairs))
+    add (NonRec b r, fvs') (pairs, fvs) =
+      ((b,r) : pairs, fvs `unionVarSet` fvs')
+    add (Rec prs1,   fvs') (pairs, fvs) =
+      (prs1 ++ pairs, fvs `unionVarSet` fvs')
+
+snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails
+-- Add ud_binds to the tail end of the bindings in uds
+snocDictBinds uds dbs
+  = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs }
+
+consDictBind :: DictBind -> UsageDetails -> UsageDetails
+consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds }
+
+addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
+addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds }
+
+snocDictBind :: UsageDetails -> DictBind -> UsageDetails
+snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind }
+
+wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]
+wrapDictBinds dbs binds
+  = foldrBag add binds dbs
+  where
+    add (bind,_) binds = bind : binds
+
+wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr
+wrapDictBindsE dbs expr
+  = foldrBag add expr dbs
+  where
+    add (bind,_) expr = Let bind expr
+
+----------------------
+dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind)
+-- Used at a lambda or case binder; just dump anything mentioning the binder
+dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
+  | null bndrs = (uds, emptyBag)  -- Common in case alternatives
+  | otherwise  = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $
+                 (free_uds, dump_dbs)
+  where
+    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }
+    bndr_set = mkVarSet bndrs
+    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
+    free_calls = deleteCallsMentioning dump_set $   -- Drop calls mentioning bndr_set on the floor
+                 deleteCallsFor bndrs orig_calls    -- Discard calls for bndr_set; there should be
+                                                    -- no calls for any of the dicts in dump_dbs
+
+dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)
+-- Used at a let(rec) binding.
+-- We return a boolean indicating whether the binding itself is mentioned,
+-- directly or indirectly, by any of the ud_calls; in that case we want to
+-- float the binding itself;
+-- See Note [Floated dictionary bindings]
+dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
+  = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $
+    (free_uds, dump_dbs, float_all)
+  where
+    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }
+    bndr_set = mkVarSet bndrs
+    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
+    free_calls = deleteCallsFor bndrs orig_calls
+    float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls
+
+callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])
+callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
+  = -- pprTrace ("callsForMe")
+    --          (vcat [ppr fn,
+    --                 text "Orig dbs ="     <+> ppr (_dictBindBndrs orig_dbs),
+    --                 text "Orig calls ="   <+> ppr orig_calls,
+    --                 text "Dep set ="      <+> ppr dep_set,
+    --                 text "Calls for me =" <+> ppr calls_for_me]) $
+    (uds_without_me, calls_for_me)
+  where
+    uds_without_me = MkUD { ud_binds = orig_dbs
+                          , ud_calls = delDVarEnv orig_calls fn }
+    calls_for_me = case lookupDVarEnv orig_calls fn of
+                        Nothing -> []
+                        Just cis -> filterCalls cis orig_dbs
+         -- filterCalls: drop calls that (directly or indirectly)
+         -- refer to fn.  See Note [Avoiding loops]
+
+----------------------
+filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]
+-- See Note [Avoiding loops]
+filterCalls (CIS fn call_bag) dbs
+  = filter ok_call (bagToList call_bag)
+  where
+    dump_set = foldlBag go (unitVarSet fn) dbs
+      -- This dump-set could also be computed by splitDictBinds
+      --   (_,_,dump_set) = splitDictBinds dbs {fn}
+      -- But this variant is shorter
+
+    go so_far (db,fvs) | fvs `intersectsVarSet` so_far
+                       = extendVarSetList so_far (bindersOf db)
+                       | otherwise = so_far
+
+    ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set)
+
+----------------------
+splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)
+-- splitDictBinds dbs bndrs returns
+--   (free_dbs, dump_dbs, dump_set)
+-- where
+--   * dump_dbs depends, transitively on bndrs
+--   * free_dbs does not depend on bndrs
+--   * dump_set = bndrs `union` bndrs(dump_dbs)
+splitDictBinds dbs bndr_set
+   = foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs
+                -- Important that it's foldl not foldr;
+                -- we're accumulating the set of dumped ids in dump_set
+   where
+    split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)
+        | dump_idset `intersectsVarSet` fvs     -- Dump it
+        = (free_dbs, dump_dbs `snocBag` db,
+           extendVarSetList dump_idset (bindersOf bind))
+
+        | otherwise     -- Don't dump it
+        = (free_dbs `snocBag` db, dump_dbs, dump_idset)
+
+
+----------------------
+deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
+-- Remove calls *mentioning* bs in any way
+deleteCallsMentioning bs calls
+  = mapDVarEnv (ciSetFilter keep_call) calls
+  where
+    keep_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` bs)
+
+deleteCallsFor :: [Id] -> CallDetails -> CallDetails
+-- Remove calls *for* bs
+deleteCallsFor bs calls = delDVarEnvList calls bs
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{Boring helper functions}
+*                                                                      *
+************************************************************************
+-}
+
+newtype SpecM a = SpecM (State SpecState a)
+
+data SpecState = SpecState {
+                     spec_uniq_supply :: UniqSupply,
+                     spec_module :: Module,
+                     spec_dflags :: DynFlags
+                 }
+
+instance Functor SpecM where
+    fmap = liftM
+
+instance Applicative SpecM where
+    pure x = SpecM $ return x
+    (<*>) = ap
+
+instance Monad SpecM where
+    SpecM x >>= f = SpecM $ do y <- x
+                               case f y of
+                                   SpecM z ->
+                                       z
+#if !MIN_VERSION_base(4,13,0)
+    fail = MonadFail.fail
+#endif
+
+instance MonadFail.MonadFail SpecM where
+   fail str = SpecM $ error str
+
+instance MonadUnique SpecM where
+    getUniqueSupplyM
+        = SpecM $ do st <- get
+                     let (us1, us2) = splitUniqSupply $ spec_uniq_supply st
+                     put $ st { spec_uniq_supply = us2 }
+                     return us1
+
+    getUniqueM
+        = SpecM $ do st <- get
+                     let (u,us') = takeUniqFromSupply $ spec_uniq_supply st
+                     put $ st { spec_uniq_supply = us' }
+                     return u
+
+instance HasDynFlags SpecM where
+    getDynFlags = SpecM $ liftM spec_dflags get
+
+instance HasModule SpecM where
+    getModule = SpecM $ liftM spec_module get
+
+runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a
+runSpecM dflags this_mod (SpecM spec)
+    = do us <- getUniqueSupplyM
+         let initialState = SpecState {
+                                spec_uniq_supply = us,
+                                spec_module = this_mod,
+                                spec_dflags = dflags
+                            }
+         return $ evalState spec initialState
+
+mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
+mapAndCombineSM _ []     = return ([], emptyUDs)
+mapAndCombineSM f (x:xs) = do (y, uds1) <- f x
+                              (ys, uds2) <- mapAndCombineSM f xs
+                              return (y:ys, uds1 `plusUDs` uds2)
+
+extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv
+extendTvSubstList env tv_binds
+  = env { se_subst = CoreSubst.extendTvSubstList (se_subst env) tv_binds }
+
+substTy :: SpecEnv -> Type -> Type
+substTy env ty = CoreSubst.substTy (se_subst env) ty
+
+substCo :: SpecEnv -> Coercion -> Coercion
+substCo env co = CoreSubst.substCo (se_subst env) co
+
+substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr)
+substBndr env bs = case CoreSubst.substBndr (se_subst env) bs of
+                      (subst', bs') -> (env { se_subst = subst' }, bs')
+
+substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])
+substBndrs env bs = case CoreSubst.substBndrs (se_subst env) bs of
+                      (subst', bs') -> (env { se_subst = subst' }, bs')
+
+cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)
+-- Clone the binders of the bind; return new bind with the cloned binders
+-- Return the substitution to use for RHSs, and the one to use for the body
+cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs)
+  = do { us <- getUniqueSupplyM
+       ; let (subst', bndr') = CoreSubst.cloneIdBndr subst us bndr
+             interesting' | interestingDict env rhs
+                          = interesting `extendVarSet` bndr'
+                          | otherwise = interesting
+       ; return (env, env { se_subst = subst', se_interesting = interesting' }
+                , NonRec bndr' rhs) }
+
+cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs)
+  = do { us <- getUniqueSupplyM
+       ; let (subst', bndrs') = CoreSubst.cloneRecIdBndrs subst us (map fst pairs)
+             env' = env { se_subst = subst'
+                        , se_interesting = interesting `extendVarSetList`
+                                           [ v | (v,r) <- pairs, interestingDict env r ] }
+       ; return (env', env', Rec (bndrs' `zip` map snd pairs)) }
+
+newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr
+-- Make up completely fresh binders for the dictionaries
+-- Their bindings are going to float outwards
+newDictBndr env b = do { uniq <- getUniqueM
+                       ; let n   = idName b
+                             ty' = substTy env (idType b)
+                       ; return (mkUserLocalOrCoVar (nameOccName n) uniq ty' (getSrcSpan n)) }
+
+newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id
+    -- Give the new Id a similar occurrence name to the old one
+newSpecIdSM old_id new_ty join_arity_maybe
+  = do  { uniq <- getUniqueM
+        ; let name    = idName old_id
+              new_occ = mkSpecOcc (nameOccName name)
+              new_id  = mkUserLocalOrCoVar new_occ uniq new_ty (getSrcSpan name)
+                          `asJoinId_maybe` join_arity_maybe
+        ; return new_id }
+
+{-
+                Old (but interesting) stuff about unboxed bindings
+                ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+What should we do when a value is specialised to a *strict* unboxed value?
+
+        map_*_* f (x:xs) = let h = f x
+                               t = map f xs
+                           in h:t
+
+Could convert let to case:
+
+        map_*_Int# f (x:xs) = case f x of h# ->
+                              let t = map f xs
+                              in h#:t
+
+This may be undesirable since it forces evaluation here, but the value
+may not be used in all branches of the body. In the general case this
+transformation is impossible since the mutual recursion in a letrec
+cannot be expressed as a case.
+
+There is also a problem with top-level unboxed values, since our
+implementation cannot handle unboxed values at the top level.
+
+Solution: Lift the binding of the unboxed value and extract it when it
+is used:
+
+        map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
+                                  t = map f xs
+                              in case h of
+                                 _Lift h# -> h#:t
+
+Now give it to the simplifier and the _Lifting will be optimised away.
+
+The benefit is that we have given the specialised "unboxed" values a
+very simple lifted semantics and then leave it up to the simplifier to
+optimise it --- knowing that the overheads will be removed in nearly
+all cases.
+
+In particular, the value will only be evaluated in the branches of the
+program which use it, rather than being forced at the point where the
+value is bound. For example:
+
+        filtermap_*_* p f (x:xs)
+          = let h = f x
+                t = ...
+            in case p x of
+                True  -> h:t
+                False -> t
+   ==>
+        filtermap_*_Int# p f (x:xs)
+          = let h = case (f x) of h# -> _Lift h#
+                t = ...
+            in case p x of
+                True  -> case h of _Lift h#
+                           -> h#:t
+                False -> t
+
+The binding for h can still be inlined in the one branch and the
+_Lifting eliminated.
+
+
+Question: When won't the _Lifting be eliminated?
+
+Answer: When they at the top-level (where it is necessary) or when
+inlining would duplicate work (or possibly code depending on
+options). However, the _Lifting will still be eliminated if the
+strictness analyser deems the lifted binding strict.
+-}
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -0,0 +1,935 @@
+{-# LANGUAGE CPP #-}
+
+--
+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+--
+
+--------------------------------------------------------------
+-- Converting Core to STG Syntax
+--------------------------------------------------------------
+
+-- And, as we have the info in hand, we may convert some lets to
+-- let-no-escapes.
+
+module CoreToStg ( coreToStg ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSyn
+import CoreUtils        ( exprType, findDefault, isJoinBind
+                        , exprIsTickedString_maybe )
+import CoreArity        ( manifestArity )
+import StgSyn
+
+import Type
+import RepType
+import TyCon
+import MkId             ( coercionTokenId )
+import Id
+import IdInfo
+import DataCon
+import CostCentre
+import VarEnv
+import Module
+import Name             ( isExternalName, nameOccName, nameModule_maybe )
+import OccName          ( occNameFS )
+import BasicTypes       ( Arity )
+import TysWiredIn       ( unboxedUnitDataCon, unitDataConId )
+import Literal
+import Outputable
+import MonadUtils
+import FastString
+import Util
+import DynFlags
+import ForeignCall
+import Demand           ( isUsedOnce )
+import PrimOp           ( PrimCall(..) )
+import SrcLoc           ( mkGeneralSrcSpan )
+
+import Data.List.NonEmpty (nonEmpty, toList)
+import Data.Maybe    (fromMaybe)
+import Control.Monad (liftM, ap)
+
+-- Note [Live vs free]
+-- ~~~~~~~~~~~~~~~~~~~
+--
+-- The two are not the same. Liveness is an operational property rather
+-- than a semantic one. A variable is live at a particular execution
+-- point if it can be referred to directly again. In particular, a dead
+-- variable's stack slot (if it has one):
+--
+--           - should be stubbed to avoid space leaks, and
+--           - may be reused for something else.
+--
+-- There ought to be a better way to say this. Here are some examples:
+--
+--         let v = [q] \[x] -> e
+--         in
+--         ...v...  (but no q's)
+--
+-- Just after the `in', v is live, but q is dead. If the whole of that
+-- let expression was enclosed in a case expression, thus:
+--
+--         case (let v = [q] \[x] -> e in ...v...) of
+--                 alts[...q...]
+--
+-- (ie `alts' mention `q'), then `q' is live even after the `in'; because
+-- we'll return later to the `alts' and need it.
+--
+-- Let-no-escapes make this a bit more interesting:
+--
+--         let-no-escape v = [q] \ [x] -> e
+--         in
+--         ...v...
+--
+-- Here, `q' is still live at the `in', because `v' is represented not by
+-- a closure but by the current stack state.  In other words, if `v' is
+-- live then so is `q'. Furthermore, if `e' mentions an enclosing
+-- let-no-escaped variable, then its free variables are also live if `v' is.
+
+-- Note [What are these SRTs all about?]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Consider the Core program,
+--
+--     fibs = go 1 1
+--       where go a b = let c = a + c
+--                      in c : go b c
+--     add x = map (\y -> x*y) fibs
+--
+-- In this case we have a CAF, 'fibs', which is quite large after evaluation and
+-- has only one possible user, 'add'. Consequently, we want to ensure that when
+-- all references to 'add' die we can garbage collect any bit of 'fibs' that we
+-- have evaluated.
+--
+-- However, how do we know whether there are any references to 'fibs' still
+-- around? Afterall, the only reference to it is buried in the code generated
+-- for 'add'. The answer is that we record the CAFs referred to by a definition
+-- in its info table, namely a part of it known as the Static Reference Table
+-- (SRT).
+--
+-- Since SRTs are so common, we use a special compact encoding for them in: we
+-- produce one table containing a list of CAFs in a module and then include a
+-- bitmap in each info table describing which entries of this table the closure
+-- references.
+--
+-- See also: Commentary/Rts/Storage/GC/CAFs on the GHC Wiki.
+
+-- Note [What is a non-escaping let]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- NB: Nowadays this is recognized by the occurrence analyser by turning a
+-- "non-escaping let" into a join point. The following is then an operational
+-- account of join points.
+--
+-- Consider:
+--
+--     let x = fvs \ args -> e
+--     in
+--         if ... then x else
+--            if ... then x else ...
+--
+-- `x' is used twice (so we probably can't unfold it), but when it is
+-- entered, the stack is deeper than it was when the definition of `x'
+-- happened.  Specifically, if instead of allocating a closure for `x',
+-- we saved all `x's fvs on the stack, and remembered the stack depth at
+-- that moment, then whenever we enter `x' we can simply set the stack
+-- pointer(s) to these remembered (compile-time-fixed) values, and jump
+-- to the code for `x'.
+--
+-- All of this is provided x is:
+--   1. non-updatable;
+--   2. guaranteed to be entered before the stack retreats -- ie x is not
+--      buried in a heap-allocated closure, or passed as an argument to
+--      something;
+--   3. all the enters have exactly the right number of arguments,
+--      no more no less;
+--   4. all the enters are tail calls; that is, they return to the
+--      caller enclosing the definition of `x'.
+--
+-- Under these circumstances we say that `x' is non-escaping.
+--
+-- An example of when (4) does not hold:
+--
+--     let x = ...
+--     in case x of ...alts...
+--
+-- Here, `x' is certainly entered only when the stack is deeper than when
+-- `x' is defined, but here it must return to ...alts... So we can't just
+-- adjust the stack down to `x''s recalled points, because that would lost
+-- alts' context.
+--
+-- Things can get a little more complicated.  Consider:
+--
+--     let y = ...
+--     in let x = fvs \ args -> ...y...
+--     in ...x...
+--
+-- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a
+-- non-escaping way in ...y..., then `y' is non-escaping.
+--
+-- `x' can even be recursive!  Eg:
+--
+--     letrec x = [y] \ [v] -> if v then x True else ...
+--     in
+--         ...(x b)...
+
+-- Note [Cost-centre initialization plan]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`,
+-- and the fields were then fixed by a separate pass `stgMassageForProfiling`.
+-- We now initialize these correctly. The initialization works like this:
+--
+--   - For non-top level bindings always use `currentCCS`.
+--
+--   - For top-level bindings, check if the binding is a CAF
+--
+--     - CAF:      If -fcaf-all is enabled, create a new CAF just for this CAF
+--                 and use it. Note that these new cost centres need to be
+--                 collected to be able to generate cost centre initialization
+--                 code, so `coreToTopStgRhs` now returns `CollectedCCs`.
+--
+--                 If -fcaf-all is not enabled, use "all CAFs" cost centre.
+--
+--     - Non-CAF:  Top-level (static) data is not counted in heap profiles; nor
+--                 do we set CCCS from it; so we just slam in
+--                 dontCareCostCentre.
+
+-- --------------------------------------------------------------
+-- Setting variable info: top-level, binds, RHSs
+-- --------------------------------------------------------------
+
+coreToStg :: DynFlags -> Module -> CoreProgram
+          -> ([StgTopBinding], CollectedCCs)
+coreToStg dflags this_mod pgm
+  = (pgm', final_ccs)
+  where
+    (_, (local_ccs, local_cc_stacks), pgm')
+      = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm
+
+    prof = WayProf `elem` ways dflags
+
+    final_ccs
+      | prof && gopt Opt_AutoSccsOnIndividualCafs dflags
+      = (local_ccs,local_cc_stacks)  -- don't need "all CAFs" CC
+      | prof
+      = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks)
+      | otherwise
+      = emptyCollectedCCs
+
+    (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod
+
+coreTopBindsToStg
+    :: DynFlags
+    -> Module
+    -> IdEnv HowBound           -- environment for the bindings
+    -> CollectedCCs
+    -> CoreProgram
+    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
+
+coreTopBindsToStg _      _        env ccs []
+  = (env, ccs, [])
+coreTopBindsToStg dflags this_mod env ccs (b:bs)
+  = (env2, ccs2, b':bs')
+  where
+        (env1, ccs1, b' ) =
+          coreTopBindToStg dflags this_mod env ccs b
+        (env2, ccs2, bs') =
+          coreTopBindsToStg dflags this_mod env1 ccs1 bs
+
+coreTopBindToStg
+        :: DynFlags
+        -> Module
+        -> IdEnv HowBound
+        -> CollectedCCs
+        -> CoreBind
+        -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
+
+coreTopBindToStg _ _ env ccs (NonRec id e)
+  | Just str <- exprIsTickedString_maybe e
+  -- top-level string literal
+  -- See Note [CoreSyn top-level string literals] in CoreSyn
+  = let
+        env' = extendVarEnv env id how_bound
+        how_bound = LetBound TopLet 0
+    in (env', ccs, StgTopStringLit id str)
+
+coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)
+  = let
+        env'      = extendVarEnv env id how_bound
+        how_bound = LetBound TopLet $! manifestArity rhs
+
+        (stg_rhs, ccs') =
+            initCts env $
+              coreToTopStgRhs dflags ccs this_mod (id,rhs)
+
+        bind = StgTopLifted $ StgNonRec id stg_rhs
+    in
+    ASSERT2(consistentCafInfo id bind, ppr id )
+      -- NB: previously the assertion printed 'rhs' and 'bind'
+      --     as well as 'id', but that led to a black hole
+      --     where printing the assertion error tripped the
+      --     assertion again!
+    (env', ccs', bind)
+
+coreTopBindToStg dflags this_mod env ccs (Rec pairs)
+  = ASSERT( not (null pairs) )
+    let
+        binders = map fst pairs
+
+        extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
+                     | (b, rhs) <- pairs ]
+        env' = extendVarEnvList env extra_env'
+
+        -- generate StgTopBindings and CAF cost centres created for CAFs
+        (ccs', stg_rhss)
+          = initCts env' $ do
+               mapAccumLM (\ccs rhs -> do
+                            (rhs', ccs') <-
+                              coreToTopStgRhs dflags ccs this_mod rhs
+                            return (ccs', rhs'))
+                          ccs
+                          pairs
+
+        bind = StgTopLifted $ StgRec (zip binders stg_rhss)
+    in
+    ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
+    (env', ccs', bind)
+
+
+-- Assertion helper: this checks that the CafInfo on the Id matches
+-- what CoreToStg has figured out about the binding's SRT.  The
+-- CafInfo will be exact in all cases except when CorePrep has
+-- floated out a binding, in which case it will be approximate.
+consistentCafInfo :: Id -> StgTopBinding -> Bool
+consistentCafInfo id bind
+  = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
+    safe
+  where
+    safe  = id_marked_caffy || not binding_is_caffy
+    exact = id_marked_caffy == binding_is_caffy
+    id_marked_caffy  = mayHaveCafRefs (idCafInfo id)
+    binding_is_caffy = topStgBindHasCafRefs bind
+    is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
+
+coreToTopStgRhs
+        :: DynFlags
+        -> CollectedCCs
+        -> Module
+        -> (Id,CoreExpr)
+        -> CtsM (StgRhs, CollectedCCs)
+
+coreToTopStgRhs dflags ccs this_mod (bndr, rhs)
+  = do { new_rhs <- coreToStgExpr rhs
+
+       ; let (stg_rhs, ccs') =
+               mkTopStgRhs dflags this_mod ccs bndr new_rhs
+             stg_arity =
+               stgRhsArity stg_rhs
+
+       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
+                 ccs') }
+  where
+        -- It's vital that the arity on a top-level Id matches
+        -- the arity of the generated STG binding, else an importing
+        -- module will use the wrong calling convention
+        --      (Trac #2844 was an example where this happened)
+        -- NB1: we can't move the assertion further out without
+        --      blocking the "knot" tied in coreTopBindsToStg
+        -- NB2: the arity check is only needed for Ids with External
+        --      Names, because they are externally visible.  The CorePrep
+        --      pass introduces "sat" things with Local Names and does
+        --      not bother to set their Arity info, so don't fail for those
+    arity_ok stg_arity
+       | isExternalName (idName bndr) = id_arity == stg_arity
+       | otherwise                    = True
+    id_arity  = idArity bndr
+    mk_arity_msg stg_arity
+        = vcat [ppr bndr,
+                text "Id arity:" <+> ppr id_arity,
+                text "STG arity:" <+> ppr stg_arity]
+
+-- ---------------------------------------------------------------------------
+-- Expressions
+-- ---------------------------------------------------------------------------
+
+coreToStgExpr
+        :: CoreExpr
+        -> CtsM StgExpr
+
+-- The second and third components can be derived in a simple bottom up pass, not
+-- dependent on any decisions about which variables will be let-no-escaped or
+-- not.  The first component, that is, the decorated expression, may then depend
+-- on these components, but it in turn is not scrutinised as the basis for any
+-- decisions.  Hence no black holes.
+
+-- No LitInteger's or LitNatural's should be left by the time this is called.
+-- CorePrep should have converted them all to a real core representation.
+coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger"
+coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural"
+coreToStgExpr (Lit l)      = return (StgLit l)
+coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type)
+  -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in
+  -- a STG to Cmm pass.
+  = coreToStgExpr (Var unitDataConId)
+coreToStgExpr (Var v)      = coreToStgApp Nothing v               [] []
+coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []
+
+coreToStgExpr expr@(App _ _)
+  = coreToStgApp Nothing f args ticks
+  where
+    (f, args, ticks) = myCollectArgs expr
+
+coreToStgExpr expr@(Lam _ _)
+  = let
+        (args, body) = myCollectBinders expr
+        args'        = filterStgBinders args
+    in
+    extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
+    body' <- coreToStgExpr body
+    let
+        result_expr = case nonEmpty args' of
+          Nothing     -> body'
+          Just args'' -> StgLam args'' body'
+
+    return result_expr
+
+coreToStgExpr (Tick tick expr)
+  = do case tick of
+         HpcTick{}    -> return ()
+         ProfNote{}   -> return ()
+         SourceNote{} -> return ()
+         Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
+       expr2 <- coreToStgExpr expr
+       return (StgTick tick expr2)
+
+coreToStgExpr (Cast expr _)
+  = coreToStgExpr expr
+
+-- Cases require a little more real work.
+
+coreToStgExpr (Case scrut _ _ [])
+  = coreToStgExpr scrut
+    -- See Note [Empty case alternatives] in CoreSyn If the case
+    -- alternatives are empty, the scrutinee must diverge or raise an
+    -- exception, so we can just dive into it.
+    --
+    -- Of course this may seg-fault if the scrutinee *does* return.  A
+    -- belt-and-braces approach would be to move this case into the
+    -- code generator, and put a return point anyway that calls a
+    -- runtime system error function.
+
+
+coreToStgExpr (Case scrut bndr _ alts) = do
+    alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
+    scrut2 <- coreToStgExpr scrut
+    return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2)
+  where
+    vars_alt (con, binders, rhs)
+      | DataAlt c <- con, c == unboxedUnitDataCon
+      = -- This case is a bit smelly.
+        -- See Note [Nullary unboxed tuple] in Type.hs
+        -- where a nullary tuple is mapped to (State# World#)
+        ASSERT( null binders )
+        do { rhs2 <- coreToStgExpr rhs
+           ; return (DEFAULT, [], rhs2)  }
+      | otherwise
+      = let     -- Remove type variables
+            binders' = filterStgBinders binders
+        in
+        extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do
+        rhs2 <- coreToStgExpr rhs
+        return (con, binders', rhs2)
+
+coreToStgExpr (Let bind body) = do
+    coreToStgLet bind body
+
+coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)
+
+mkStgAltType :: Id -> [CoreAlt] -> AltType
+mkStgAltType bndr alts
+  | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty
+  = MultiValAlt (length prim_reps)  -- always use MultiValAlt for unboxed tuples
+
+  | otherwise
+  = case prim_reps of
+      [LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of
+        Just tc
+          | isAbstractTyCon tc -> look_for_better_tycon
+          | isAlgTyCon tc      -> AlgAlt tc
+          | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )
+                                  PolyAlt
+        Nothing                -> PolyAlt
+      [unlifted] -> PrimAlt unlifted
+      not_unary  -> MultiValAlt (length not_unary)
+  where
+   bndr_ty   = idType bndr
+   prim_reps = typePrimRep bndr_ty
+
+   _is_poly_alt_tycon tc
+        =  isFunTyCon tc
+        || isPrimTyCon tc   -- "Any" is lifted but primitive
+        || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict
+                            -- function application where argument has a
+                            -- type-family type
+
+   -- Sometimes, the TyCon is a AbstractTyCon which may not have any
+   -- constructors inside it.  Then we may get a better TyCon by
+   -- grabbing the one from a constructor alternative
+   -- if one exists.
+   look_for_better_tycon
+        | ((DataAlt con, _, _) : _) <- data_alts =
+                AlgAlt (dataConTyCon con)
+        | otherwise =
+                ASSERT(null data_alts)
+                PolyAlt
+        where
+                (data_alts, _deflt) = findDefault alts
+
+-- ---------------------------------------------------------------------------
+-- Applications
+-- ---------------------------------------------------------------------------
+
+coreToStgApp
+         :: Maybe UpdateFlag            -- Just upd <=> this application is
+                                        -- the rhs of a thunk binding
+                                        --      x = [...] \upd [] -> the_app
+                                        -- with specified update flag
+        -> Id                           -- Function
+        -> [CoreArg]                    -- Arguments
+        -> [Tickish Id]                 -- Debug ticks
+        -> CtsM StgExpr
+
+
+coreToStgApp _ f args ticks = do
+    (args', ticks') <- coreToStgArgs args
+    how_bound <- lookupVarCts f
+
+    let
+        n_val_args       = valArgCount args
+
+        -- Mostly, the arity info of a function is in the fn's IdInfo
+        -- But new bindings introduced by CoreSat may not have no
+        -- arity info; it would do us no good anyway.  For example:
+        --      let f = \ab -> e in f
+        -- No point in having correct arity info for f!
+        -- Hence the hasArity stuff below.
+        -- NB: f_arity is only consulted for LetBound things
+        f_arity   = stgArity f how_bound
+        saturated = f_arity <= n_val_args
+
+        res_ty = exprType (mkApps (Var f) args)
+        app = case idDetails f of
+                DataConWorkId dc
+                  | saturated    -> StgConApp dc args'
+                                      (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))
+
+                -- Some primitive operator that might be implemented as a library call.
+                PrimOpId op      -> ASSERT( saturated )
+                                    StgOpApp (StgPrimOp op) args' res_ty
+
+                -- A call to some primitive Cmm function.
+                FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)
+                                          PrimCallConv _))
+                                 -> ASSERT( saturated )
+                                    StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
+
+                -- A regular foreign call.
+                FCallId call     -> ASSERT( saturated )
+                                    StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
+
+                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
+                _other           -> StgApp f args'
+
+        tapp = foldr StgTick app (ticks ++ ticks')
+
+    -- Forcing these fixes a leak in the code generator, noticed while
+    -- profiling for trac #4367
+    app `seq` return tapp
+
+-- ---------------------------------------------------------------------------
+-- Argument lists
+-- This is the guy that turns applications into A-normal form
+-- ---------------------------------------------------------------------------
+
+coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id])
+coreToStgArgs []
+  = return ([], [])
+
+coreToStgArgs (Type _ : args) = do     -- Type argument
+    (args', ts) <- coreToStgArgs args
+    return (args', ts)
+
+coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder
+  = do { (args', ts) <- coreToStgArgs args
+       ; return (StgVarArg coercionTokenId : args', ts) }
+
+coreToStgArgs (Tick t e : args)
+  = ASSERT( not (tickishIsCode t) )
+    do { (args', ts) <- coreToStgArgs (e : args)
+       ; return (args', t:ts) }
+
+coreToStgArgs (arg : args) = do         -- Non-type argument
+    (stg_args, ticks) <- coreToStgArgs args
+    arg' <- coreToStgExpr arg
+    let
+        (aticks, arg'') = stripStgTicksTop tickishFloatable arg'
+        stg_arg = case arg'' of
+                       StgApp v []        -> StgVarArg v
+                       StgConApp con [] _ -> StgVarArg (dataConWorkId con)
+                       StgLit lit         -> StgLitArg lit
+                       _                  -> pprPanic "coreToStgArgs" (ppr arg)
+
+        -- WARNING: what if we have an argument like (v `cast` co)
+        --          where 'co' changes the representation type?
+        --          (This really only happens if co is unsafe.)
+        -- Then all the getArgAmode stuff in CgBindery will set the
+        -- cg_rep of the CgIdInfo based on the type of v, rather
+        -- than the type of 'co'.
+        -- This matters particularly when the function is a primop
+        -- or foreign call.
+        -- Wanted: a better solution than this hacky warning
+    let
+        arg_ty = exprType arg
+        stg_arg_ty = stgArgType stg_arg
+        bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty))
+                || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)
+        -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),
+        -- and pass it to a function expecting an HValue (arg_ty).  This is ok because
+        -- we can treat an unlifted value as lifted.  But the other way round
+        -- we complain.
+        -- We also want to check if a pointer is cast to a non-ptr etc
+
+    WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )
+     return (stg_arg : stg_args, ticks ++ aticks)
+
+
+-- ---------------------------------------------------------------------------
+-- The magic for lets:
+-- ---------------------------------------------------------------------------
+
+coreToStgLet
+         :: CoreBind     -- bindings
+         -> CoreExpr     -- body
+         -> CtsM StgExpr -- new let
+
+coreToStgLet bind body = do
+    (bind2, body2)
+       <- do
+
+          ( bind2, env_ext)
+                <- vars_bind bind
+
+          -- Do the body
+          extendVarEnvCts env_ext $ do
+             body2 <- coreToStgExpr body
+
+             return (bind2, body2)
+
+        -- Compute the new let-expression
+    let
+        new_let | isJoinBind bind = StgLetNoEscape noExtSilent bind2 body2
+                | otherwise       = StgLet noExtSilent bind2 body2
+
+    return new_let
+  where
+    mk_binding binder rhs
+        = (binder, LetBound NestedLet (manifestArity rhs))
+
+    vars_bind :: CoreBind
+              -> CtsM (StgBinding,
+                       [(Id, HowBound)])  -- extension to environment
+
+    vars_bind (NonRec binder rhs) = do
+        rhs2 <- coreToStgRhs (binder,rhs)
+        let
+            env_ext_item = mk_binding binder rhs
+
+        return (StgNonRec binder rhs2, [env_ext_item])
+
+    vars_bind (Rec pairs)
+      =    let
+                binders = map fst pairs
+                env_ext = [ mk_binding b rhs
+                          | (b,rhs) <- pairs ]
+           in
+           extendVarEnvCts env_ext $ do
+              rhss2 <- mapM coreToStgRhs pairs
+              return (StgRec (binders `zip` rhss2), env_ext)
+
+coreToStgRhs :: (Id,CoreExpr)
+             -> CtsM StgRhs
+
+coreToStgRhs (bndr, rhs) = do
+    new_rhs <- coreToStgExpr rhs
+    return (mkStgRhs bndr new_rhs)
+
+-- Generate a top-level RHS. Any new cost centres generated for CAFs will be
+-- appended to `CollectedCCs` argument.
+mkTopStgRhs :: DynFlags -> Module -> CollectedCCs
+            -> Id -> StgExpr -> (StgRhs, CollectedCCs)
+
+mkTopStgRhs dflags this_mod ccs bndr rhs
+  | StgLam bndrs body <- rhs
+  = -- StgLam can't have empty arguments, so not CAF
+    ( StgRhsClosure noExtSilent
+                    dontCareCCS
+                    ReEntrant
+                    (toList bndrs) body
+    , ccs )
+
+  | StgConApp con args _ <- unticked_rhs
+  , -- Dynamic StgConApps are updatable
+    not (isDllConApp dflags this_mod con args)
+  = -- CorePrep does this right, but just to make sure
+    ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con)
+           , ppr bndr $$ ppr con $$ ppr args)
+    ( StgRhsCon dontCareCCS con args, ccs )
+
+  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].
+  | gopt Opt_AutoSccsOnIndividualCafs dflags
+  = ( StgRhsClosure noExtSilent
+                    caf_ccs
+                    upd_flag [] rhs
+    , collectCC caf_cc caf_ccs ccs )
+
+  | otherwise
+  = ( StgRhsClosure noExtSilent
+                    all_cafs_ccs
+                    upd_flag [] rhs
+    , ccs )
+
+  where
+    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
+
+    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
+             | otherwise                      = Updatable
+
+    -- CAF cost centres generated for -fcaf-all
+    caf_cc = mkAutoCC bndr modl
+    caf_ccs = mkSingletonCCS caf_cc
+           -- careful: the binder might be :Main.main,
+           -- which doesn't belong to module mod_name.
+           -- bug #249, tests prof001, prof002
+    modl | Just m <- nameModule_maybe (idName bndr) = m
+         | otherwise = this_mod
+
+    -- default CAF cost centre
+    (_, all_cafs_ccs) = getAllCAFsCC this_mod
+
+-- Generate a non-top-level RHS. Cost-centre is always currentCCS,
+-- see Note [Cost-centre initialzation plan].
+mkStgRhs :: Id -> StgExpr -> StgRhs
+mkStgRhs bndr rhs
+  | StgLam bndrs body <- rhs
+  = StgRhsClosure noExtSilent
+                  currentCCS
+                  ReEntrant
+                  (toList bndrs) body
+
+  | isJoinId bndr -- must be a nullary join point
+  = ASSERT(idJoinArity bndr == 0)
+    StgRhsClosure noExtSilent
+                  currentCCS
+                  ReEntrant -- ignored for LNE
+                  [] rhs
+
+  | StgConApp con args _ <- unticked_rhs
+  = StgRhsCon currentCCS con args
+
+  | otherwise
+  = StgRhsClosure noExtSilent
+                  currentCCS
+                  upd_flag [] rhs
+  where
+    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
+
+    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
+             | otherwise                      = Updatable
+
+  {-
+    SDM: disabled.  Eval/Apply can't handle functions with arity zero very
+    well; and making these into simple non-updatable thunks breaks other
+    assumptions (namely that they will be entered only once).
+
+    upd_flag | isPAP env rhs  = ReEntrant
+             | otherwise      = Updatable
+
+-- Detect thunks which will reduce immediately to PAPs, and make them
+-- non-updatable.  This has several advantages:
+--
+--         - the non-updatable thunk behaves exactly like the PAP,
+--
+--         - the thunk is more efficient to enter, because it is
+--           specialised to the task.
+--
+--         - we save one update frame, one stg_update_PAP, one update
+--           and lots of PAP_enters.
+--
+--         - in the case where the thunk is top-level, we save building
+--           a black hole and furthermore the thunk isn't considered to
+--           be a CAF any more, so it doesn't appear in any SRTs.
+--
+-- We do it here, because the arity information is accurate, and we need
+-- to do it before the SRT pass to save the SRT entries associated with
+-- any top-level PAPs.
+
+isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
+                              where
+                                 arity = stgArity f (lookupBinding env f)
+isPAP env _               = False
+
+-}
+
+{- ToDo:
+          upd = if isOnceDem dem
+                    then (if isNotTop toplev
+                            then SingleEntry    -- HA!  Paydirt for "dem"
+                            else
+                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $
+                     Updatable)
+                else Updatable
+        -- For now we forbid SingleEntry CAFs; they tickle the
+        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,
+        -- and I don't understand why.  There's only one SE_CAF (well,
+        -- only one that tickled a great gaping bug in an earlier attempt
+        -- at ClosureInfo.getEntryConvention) in the whole of nofib,
+        -- specifically Main.lvl6 in spectral/cryptarithm2.
+        -- So no great loss.  KSW 2000-07.
+-}
+
+-- ---------------------------------------------------------------------------
+-- A monad for the core-to-STG pass
+-- ---------------------------------------------------------------------------
+
+-- There's a lot of stuff to pass around, so we use this CtsM
+-- ("core-to-STG monad") monad to help.  All the stuff here is only passed
+-- *down*.
+
+newtype CtsM a = CtsM
+    { unCtsM :: IdEnv HowBound
+             -> a
+    }
+
+data HowBound
+  = ImportBound         -- Used only as a response to lookupBinding; never
+                        -- exists in the range of the (IdEnv HowBound)
+
+  | LetBound            -- A let(rec) in this module
+        LetInfo         -- Whether top level or nested
+        Arity           -- Its arity (local Ids don't have arity info at this point)
+
+  | LambdaBound         -- Used for both lambda and case
+  deriving (Eq)
+
+data LetInfo
+  = TopLet              -- top level things
+  | NestedLet
+  deriving (Eq)
+
+-- For a let(rec)-bound variable, x, we record LiveInfo, the set of
+-- variables that are live if x is live.  This LiveInfo comprises
+--         (a) dynamic live variables (ones with a non-top-level binding)
+--         (b) static live variabes (CAFs or things that refer to CAFs)
+--
+-- For "normal" variables (a) is just x alone.  If x is a let-no-escaped
+-- variable then x is represented by a code pointer and a stack pointer
+-- (well, one for each stack).  So all of the variables needed in the
+-- execution of x are live if x is, and are therefore recorded in the
+-- LetBound constructor; x itself *is* included.
+--
+-- The set of dynamic live variables is guaranteed ot have no further
+-- let-no-escaped variables in it.
+
+-- The std monad functions:
+
+initCts :: IdEnv HowBound -> CtsM a -> a
+initCts env m = unCtsM m env
+
+
+
+{-# INLINE thenCts #-}
+{-# INLINE returnCts #-}
+
+returnCts :: a -> CtsM a
+returnCts e = CtsM $ \_ -> e
+
+thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
+thenCts m k = CtsM $ \env
+  -> unCtsM (k (unCtsM m env)) env
+
+instance Functor CtsM where
+    fmap = liftM
+
+instance Applicative CtsM where
+    pure = returnCts
+    (<*>) = ap
+
+instance Monad CtsM where
+    (>>=)  = thenCts
+
+-- Functions specific to this monad:
+
+extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
+extendVarEnvCts ids_w_howbound expr
+   =    CtsM $   \env
+   -> unCtsM expr (extendVarEnvList env ids_w_howbound)
+
+lookupVarCts :: Id -> CtsM HowBound
+lookupVarCts v = CtsM $ \env -> lookupBinding env v
+
+lookupBinding :: IdEnv HowBound -> Id -> HowBound
+lookupBinding env v = case lookupVarEnv env v of
+                        Just xx -> xx
+                        Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
+
+getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)
+getAllCAFsCC this_mod =
+    let
+      span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
+      all_cafs_cc  = mkAllCafsCC this_mod span
+      all_cafs_ccs = mkSingletonCCS all_cafs_cc
+    in
+      (all_cafs_cc, all_cafs_ccs)
+
+-- Misc.
+
+filterStgBinders :: [Var] -> [Var]
+filterStgBinders bndrs = filter isId bndrs
+
+myCollectBinders :: Expr Var -> ([Var], Expr Var)
+myCollectBinders expr
+  = go [] expr
+  where
+    go bs (Lam b e)          = go (b:bs) e
+    go bs (Cast e _)         = go bs e
+    go bs e                  = (reverse bs, e)
+
+-- | Precondition: argument expression is an 'App', and there is a 'Var' at the
+-- head of the 'App' chain.
+myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id])
+myCollectArgs expr
+  = go expr [] []
+  where
+    go (Var v)          as ts = (v, as, ts)
+    go (App f a)        as ts = go f (a:as) ts
+    go (Tick t e)       as ts = ASSERT( all isTypeArg as )
+                                go e as (t:ts) -- ticks can appear in type apps
+    go (Cast e _)       as ts = go e as ts
+    go (Lam b e)        as ts
+       | isTyVar b            = go e as ts -- Note [Collect args]
+    go _                _  _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
+
+-- Note [Collect args]
+-- ~~~~~~~~~~~~~~~~~~~
+--
+-- This big-lambda case occurred following a rather obscure eta expansion.
+-- It all seems a bit yukky to me.
+
+stgArity :: Id -> HowBound -> Arity
+stgArity _ (LetBound _ arity) = arity
+stgArity f ImportBound        = idArity f
+stgArity _ LambdaBound        = 0
diff --git a/compiler/stgSyn/StgFVs.hs b/compiler/stgSyn/StgFVs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stgSyn/StgFVs.hs
@@ -0,0 +1,130 @@
+-- | Free variable analysis on STG terms.
+module StgFVs (
+    annTopBindingsFreeVars,
+    annBindingFreeVars
+  ) where
+
+import GhcPrelude
+
+import StgSyn
+import Id
+import VarSet
+import CoreSyn    ( Tickish(Breakpoint) )
+import Outputable
+import Util
+
+import Data.Maybe ( mapMaybe )
+
+newtype Env
+  = Env
+  { locals :: IdSet
+  }
+
+emptyEnv :: Env
+emptyEnv = Env emptyVarSet
+
+addLocals :: [Id] -> Env -> Env
+addLocals bndrs env
+  = env { locals = extendVarSetList (locals env) bndrs }
+
+-- | Annotates a top-level STG binding group with its free variables.
+annTopBindingsFreeVars :: [StgTopBinding] -> [CgStgTopBinding]
+annTopBindingsFreeVars = map go
+  where
+    go (StgTopStringLit id bs) = StgTopStringLit id bs
+    go (StgTopLifted bind)
+      = StgTopLifted (annBindingFreeVars bind)
+
+-- | Annotates an STG binding with its free variables.
+annBindingFreeVars :: StgBinding -> CgStgBinding
+annBindingFreeVars = fst . binding emptyEnv emptyDVarSet
+
+boundIds :: StgBinding -> [Id]
+boundIds (StgNonRec b _) = [b]
+boundIds (StgRec pairs)  = map fst pairs
+
+-- Note [Tracking local binders]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- 'locals' contains non-toplevel, non-imported binders.
+-- We maintain the set in 'expr', 'alt' and 'rhs', which are the only
+-- places where new local binders are introduced.
+-- Why do it there rather than in 'binding'? Two reasons:
+--
+--   1. We call 'binding' from 'annTopBindingsFreeVars', which would
+--      add top-level bindings to the 'locals' set.
+--   2. In the let(-no-escape) case, we need to extend the environment
+--      prior to analysing the body, but we also need the fvs from the
+--      body to analyse the RHSs. No way to do this without some
+--      knot-tying.
+
+-- | This makes sure that only local, non-global free vars make it into the set.
+mkFreeVarSet :: Env -> [Id] -> DIdSet
+mkFreeVarSet env = mkDVarSet . filter (`elemVarSet` locals env)
+
+args :: Env -> [StgArg] -> DIdSet
+args env = mkFreeVarSet env . mapMaybe f
+  where
+    f (StgVarArg occ) = Just occ
+    f _               = Nothing
+
+binding :: Env -> DIdSet -> StgBinding -> (CgStgBinding, DIdSet)
+binding env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs)
+  where
+    -- See Note [Tacking local binders]
+    (r', rhs_fvs) = rhs env r
+    fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_fvs
+binding env body_fv (StgRec pairs) = (StgRec pairs', fvs)
+  where
+    -- See Note [Tacking local binders]
+    bndrs = map fst pairs
+    (rhss, rhs_fvss) = mapAndUnzip (rhs env . snd) pairs
+    pairs' = zip bndrs rhss
+    fvs = delDVarSetList (unionDVarSets (body_fv:rhs_fvss)) bndrs
+
+expr :: Env -> StgExpr -> (CgStgExpr, DIdSet)
+expr env = go
+  where
+    go (StgApp occ as)
+      = (StgApp occ as, unionDVarSet (args env as) (mkFreeVarSet env [occ]))
+    go (StgLit lit) = (StgLit lit, emptyDVarSet)
+    go (StgConApp dc as tys) = (StgConApp dc as tys, args env as)
+    go (StgOpApp op as ty) = (StgOpApp op as ty, args env as)
+    go StgLam{} = pprPanic "StgFVs: StgLam" empty
+    go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs)
+      where
+        (scrut', scrut_fvs) = go scrut
+        -- See Note [Tacking local binders]
+        (alts', alt_fvss) = mapAndUnzip (alt (addLocals [bndr] env)) alts
+        alt_fvs = unionDVarSets alt_fvss
+        fvs = delDVarSet (unionDVarSet scrut_fvs alt_fvs) bndr
+    go (StgLet ext bind body) = go_bind (StgLet ext) bind body
+    go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body
+    go (StgTick tick e) = (StgTick tick e', fvs')
+      where
+        (e', fvs) = go e
+        fvs' = unionDVarSet (tickish tick) fvs
+        tickish (Breakpoint _ ids) = mkDVarSet ids
+        tickish _                  = emptyDVarSet
+
+    go_bind dc bind body = (dc bind' body', fvs)
+      where
+        -- See Note [Tacking local binders]
+        env' = addLocals (boundIds bind) env
+        (body', body_fvs) = expr env' body
+        (bind', fvs) = binding env' body_fvs bind
+
+rhs :: Env -> StgRhs -> (CgStgRhs, DIdSet)
+rhs env (StgRhsClosure _ ccs uf bndrs body)
+  = (StgRhsClosure fvs ccs uf bndrs body', fvs)
+  where
+    -- See Note [Tacking local binders]
+    (body', body_fvs) = expr (addLocals bndrs env) body
+    fvs = delDVarSetList body_fvs bndrs
+rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as)
+
+alt :: Env -> StgAlt -> (CgStgAlt, DIdSet)
+alt env (con, bndrs, e) = ((con, bndrs, e'), fvs)
+  where
+    -- See Note [Tacking local binders]
+    (e', rhs_fvs) = expr (addLocals bndrs env) e
+    fvs = delDVarSetList rhs_fvs bndrs
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stgSyn/StgLint.hs
@@ -0,0 +1,397 @@
+{- |
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+A lint pass to check basic STG invariants:
+
+- Variables should be defined before used.
+
+- Let bindings should not have unboxed types (unboxed bindings should only
+  appear in case), except when they're join points (see Note [CoreSyn let/app
+  invariant] and #14117).
+
+- If linting after unarisation, invariants listed in Note [Post-unarisation
+  invariants].
+
+Because we don't have types and coercions in STG we can't really check types
+here.
+
+Some history:
+
+StgLint used to check types, but it never worked and so it was disabled in 2000
+with this note:
+
+    WARNING:
+    ~~~~~~~~
+
+    This module has suffered bit-rot; it is likely to yield lint errors
+    for Stg code that is currently perfectly acceptable for code
+    generation.  Solution: don't use it!  (KSW 2000-05).
+
+Since then there were some attempts at enabling it again, as summarised in
+#14787. It's finally decided that we remove all type checking and only look for
+basic properties listed above.
+-}
+
+{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies #-}
+
+module StgLint ( lintStgTopBindings ) where
+
+import GhcPrelude
+
+import StgSyn
+
+import DynFlags
+import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
+import BasicTypes       ( TopLevelFlag(..), isTopLevel )
+import CostCentre       ( isCurrentCCS )
+import Id               ( Id, idType, isJoinId, idName )
+import VarSet
+import DataCon
+import CoreSyn          ( AltCon(..) )
+import Name             ( getSrcLoc, nameIsLocalOrFrom )
+import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )
+import Type
+import RepType
+import SrcLoc
+import Outputable
+import Module           ( Module )
+import qualified ErrUtils as Err
+import Control.Applicative ((<|>))
+import Control.Monad
+
+lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)
+                   => DynFlags
+                   -> Module -- ^ module being compiled
+                   -> Bool   -- ^ have we run Unarise yet?
+                   -> String -- ^ who produced the STG?
+                   -> [GenStgTopBinding a]
+                   -> IO ()
+
+lintStgTopBindings dflags this_mod unarised whodunnit binds
+  = {-# SCC "StgLint" #-}
+    case initL this_mod unarised top_level_binds (lint_binds binds) of
+      Nothing  ->
+        return ()
+      Just msg -> do
+        putLogMsg dflags NoReason Err.SevDump noSrcSpan
+          (defaultDumpStyle dflags)
+          (vcat [ text "*** Stg Lint ErrMsgs: in" <+>
+                        text whodunnit <+> text "***",
+                  msg,
+                  text "*** Offending Program ***",
+                  pprGenStgTopBindings binds,
+                  text "*** End of Offense ***"])
+        Err.ghcExit dflags 1
+  where
+    -- Bring all top-level binds into scope because CoreToStg does not generate
+    -- bindings in dependency order (so we may see a use before its definition).
+    top_level_binds = mkVarSet (bindersOfTopBinds binds)
+
+    lint_binds :: [GenStgTopBinding a] -> LintM ()
+
+    lint_binds [] = return ()
+    lint_binds (bind:binds) = do
+        binders <- lint_bind bind
+        addInScopeVars binders $
+            lint_binds binds
+
+    lint_bind (StgTopLifted bind) = lintStgBinds TopLevel bind
+    lint_bind (StgTopStringLit v _) = return [v]
+
+lintStgArg :: StgArg -> LintM ()
+lintStgArg (StgLitArg _) = return ()
+lintStgArg (StgVarArg v) = lintStgVar v
+
+lintStgVar :: Id -> LintM ()
+lintStgVar id = checkInScope id
+
+lintStgBinds
+    :: (OutputablePass a, BinderP a ~ Id)
+    => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders
+lintStgBinds top_lvl (StgNonRec binder rhs) = do
+    lint_binds_help top_lvl (binder,rhs)
+    return [binder]
+
+lintStgBinds top_lvl (StgRec pairs)
+  = addInScopeVars binders $ do
+        mapM_ (lint_binds_help top_lvl) pairs
+        return binders
+  where
+    binders = [b | (b,_) <- pairs]
+
+lint_binds_help
+    :: (OutputablePass a, BinderP a ~ Id)
+    => TopLevelFlag
+    -> (Id, GenStgRhs a)
+    -> LintM ()
+lint_binds_help top_lvl (binder, rhs)
+  = addLoc (RhsOf binder) $ do
+        when (isTopLevel top_lvl) (checkNoCurrentCCS rhs)
+        lintStgRhs rhs
+        -- Check binder doesn't have unlifted type or it's a join point
+        checkL (isJoinId binder || not (isUnliftedType (idType binder)))
+               (mkUnliftedTyMsg binder rhs)
+
+-- | Top-level bindings can't inherit the cost centre stack from their
+-- (static) allocation site.
+checkNoCurrentCCS
+    :: (OutputablePass a, BinderP a ~ Id)
+    => GenStgRhs a
+    -> LintM ()
+checkNoCurrentCCS rhs@(StgRhsClosure _ ccs _ _ _)
+  | isCurrentCCS ccs
+  = addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ ppr rhs)
+checkNoCurrentCCS rhs@(StgRhsCon ccs _ _)
+  | isCurrentCCS ccs
+  = addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ ppr rhs)
+checkNoCurrentCCS _
+  = return ()
+
+lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()
+
+lintStgRhs (StgRhsClosure _ _ _ [] expr)
+  = lintStgExpr expr
+
+lintStgRhs (StgRhsClosure _ _ _ binders expr)
+  = addLoc (LambdaBodyOf binders) $
+      addInScopeVars binders $
+        lintStgExpr expr
+
+lintStgRhs rhs@(StgRhsCon _ con args) = do
+    when (isUnboxedTupleCon con || isUnboxedSumCon con) $
+      addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$
+               ppr rhs)
+    mapM_ lintStgArg args
+    mapM_ checkPostUnariseConArg args
+
+lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()
+
+lintStgExpr (StgLit _) = return ()
+
+lintStgExpr (StgApp fun args) = do
+    lintStgVar fun
+    mapM_ lintStgArg args
+
+lintStgExpr app@(StgConApp con args _arg_tys) = do
+    -- unboxed sums should vanish during unarise
+    lf <- getLintFlags
+    when (lf_unarised lf && isUnboxedSumCon con) $
+      addErrL (text "Unboxed sum after unarise:" $$
+               ppr app)
+    mapM_ lintStgArg args
+    mapM_ checkPostUnariseConArg args
+
+lintStgExpr (StgOpApp _ args _) =
+    mapM_ lintStgArg args
+
+lintStgExpr lam@(StgLam _ _) =
+    addErrL (text "Unexpected StgLam" <+> ppr lam)
+
+lintStgExpr (StgLet _ binds body) = do
+    binders <- lintStgBinds NotTopLevel binds
+    addLoc (BodyOfLetRec binders) $
+      addInScopeVars binders $
+        lintStgExpr body
+
+lintStgExpr (StgLetNoEscape _ binds body) = do
+    binders <- lintStgBinds NotTopLevel binds
+    addLoc (BodyOfLetRec binders) $
+      addInScopeVars binders $
+        lintStgExpr body
+
+lintStgExpr (StgTick _ expr) = lintStgExpr expr
+
+lintStgExpr (StgCase scrut bndr alts_type alts) = do
+    lintStgExpr scrut
+
+    lf <- getLintFlags
+    let in_scope = stgCaseBndrInScope alts_type (lf_unarised lf)
+
+    addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts)
+
+lintAlt
+    :: (OutputablePass a, BinderP a ~ Id)
+    => (AltCon, [Id], GenStgExpr a) -> LintM ()
+
+lintAlt (DEFAULT, _, rhs) =
+    lintStgExpr rhs
+
+lintAlt (LitAlt _, _, rhs) =
+    lintStgExpr rhs
+
+lintAlt (DataAlt _, bndrs, rhs) = do
+    mapM_ checkPostUnariseBndr bndrs
+    addInScopeVars bndrs (lintStgExpr rhs)
+
+{-
+************************************************************************
+*                                                                      *
+Utilities
+*                                                                      *
+************************************************************************
+-}
+
+bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id]
+bindersOf (StgNonRec binder _) = [binder]
+bindersOf (StgRec pairs)       = [binder | (binder, _) <- pairs]
+
+bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]
+bindersOfTop (StgTopLifted bind) = bindersOf bind
+bindersOfTop (StgTopStringLit binder _) = [binder]
+
+bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id]
+bindersOfTopBinds = foldr ((++) . bindersOfTop) []
+
+{-
+************************************************************************
+*                                                                      *
+The Lint monad
+*                                                                      *
+************************************************************************
+-}
+
+newtype LintM a = LintM
+    { unLintM :: Module
+              -> LintFlags
+              -> [LintLocInfo]     -- Locations
+              -> IdSet             -- Local vars in scope
+              -> Bag MsgDoc        -- Error messages so far
+              -> (a, Bag MsgDoc)   -- Result and error messages (if any)
+    }
+
+data LintFlags = LintFlags { lf_unarised :: !Bool
+                             -- ^ have we run the unariser yet?
+                           }
+
+data LintLocInfo
+  = RhsOf Id            -- The variable bound
+  | LambdaBodyOf [Id]   -- The lambda-binder
+  | BodyOfLetRec [Id]   -- One of the binders
+
+dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)
+dumpLoc (RhsOf v) =
+  (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' )
+dumpLoc (LambdaBodyOf bs) =
+  (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' )
+
+dumpLoc (BodyOfLetRec bs) =
+  (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' )
+
+
+pp_binders :: [Id] -> SDoc
+pp_binders bs
+  = sep (punctuate comma (map pp_binder bs))
+  where
+    pp_binder b
+      = hsep [ppr b, dcolon, ppr (idType b)]
+
+initL :: Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc
+initL this_mod unarised locals (LintM m) = do
+  let (_, errs) = m this_mod (LintFlags unarised) [] locals emptyBag
+  if isEmptyBag errs then
+      Nothing
+  else
+      Just (vcat (punctuate blankLine (bagToList errs)))
+
+instance Functor LintM where
+      fmap = liftM
+
+instance Applicative LintM where
+      pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs)
+      (<*>) = ap
+      (*>)  = thenL_
+
+instance Monad LintM where
+    (>>=) = thenL
+    (>>)  = (*>)
+
+thenL :: LintM a -> (a -> LintM b) -> LintM b
+thenL m k = LintM $ \mod lf loc scope errs
+  -> case unLintM m mod lf loc scope errs of
+      (r, errs') -> unLintM (k r) mod lf loc scope errs'
+
+thenL_ :: LintM a -> LintM b -> LintM b
+thenL_ m k = LintM $ \mod lf loc scope errs
+  -> case unLintM m mod lf loc scope errs of
+      (_, errs') -> unLintM k mod lf loc scope errs'
+
+checkL :: Bool -> MsgDoc -> LintM ()
+checkL True  _   = return ()
+checkL False msg = addErrL msg
+
+-- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders.
+checkPostUnariseBndr :: Id -> LintM ()
+checkPostUnariseBndr bndr = do
+    lf <- getLintFlags
+    when (lf_unarised lf) $
+      forM_ (checkPostUnariseId bndr) $ \unexpected ->
+        addErrL $
+          text "After unarisation, binder " <>
+          ppr bndr <> text " has " <> text unexpected <> text " type " <>
+          ppr (idType bndr)
+
+-- Arguments shouldn't have sum, tuple, or void types.
+checkPostUnariseConArg :: StgArg -> LintM ()
+checkPostUnariseConArg arg = case arg of
+    StgLitArg _ ->
+      return ()
+    StgVarArg id -> do
+      lf <- getLintFlags
+      when (lf_unarised lf) $
+        forM_ (checkPostUnariseId id) $ \unexpected ->
+          addErrL $
+            text "After unarisation, arg " <>
+            ppr id <> text " has " <> text unexpected <> text " type " <>
+            ppr (idType id)
+
+-- Post-unarisation args and case alt binders should not have unboxed tuple,
+-- unboxed sum, or void types. Return what the binder is if it is one of these.
+checkPostUnariseId :: Id -> Maybe String
+checkPostUnariseId id =
+    let
+      id_ty = idType id
+      is_sum, is_tuple, is_void :: Maybe String
+      is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum"
+      is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple"
+      is_void = guard (isVoidTy id_ty) >> return "void"
+    in
+      is_sum <|> is_tuple <|> is_void
+
+addErrL :: MsgDoc -> LintM ()
+addErrL msg = LintM $ \_mod _lf loc _scope errs -> ((), addErr errs msg loc)
+
+addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc
+addErr errs_so_far msg locs
+  = errs_so_far `snocBag` mk_msg locs
+  where
+    mk_msg (loc:_) = let (l,hdr) = dumpLoc loc
+                     in  mkLocMessage SevWarning l (hdr $$ msg)
+    mk_msg []      = msg
+
+addLoc :: LintLocInfo -> LintM a -> LintM a
+addLoc extra_loc m = LintM $ \mod lf loc scope errs
+   -> unLintM m mod lf (extra_loc:loc) scope errs
+
+addInScopeVars :: [Id] -> LintM a -> LintM a
+addInScopeVars ids m = LintM $ \mod lf loc scope errs
+ -> let
+        new_set = mkVarSet ids
+    in unLintM m mod lf loc (scope `unionVarSet` new_set) errs
+
+getLintFlags :: LintM LintFlags
+getLintFlags = LintM $ \_mod lf _loc _scope errs -> (lf, errs)
+
+checkInScope :: Id -> LintM ()
+checkInScope id = LintM $ \mod _lf loc scope errs
+ -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then
+        ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),
+                                text "is out of scope"]) loc)
+    else
+        ((), errs)
+
+mkUnliftedTyMsg :: OutputablePass a => Id -> GenStgRhs a -> SDoc
+mkUnliftedTyMsg binder rhs
+  = (text "Let(rec) binder" <+> quotes (ppr binder) <+>
+     text "has unlifted type" <+> quotes (ppr (idType binder)))
+    $$
+    (text "RHS:" <+> ppr rhs)
diff --git a/compiler/stgSyn/StgSubst.hs b/compiler/stgSyn/StgSubst.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stgSyn/StgSubst.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE CPP #-}
+
+module StgSubst where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Id
+import VarEnv
+import Control.Monad.Trans.State.Strict
+import Outputable
+import Util
+
+-- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not
+-- maintaining pairs of substitutions. Like @"CoreSubst".'CoreSubst.Subst'@, but
+-- with the domain being 'Id's instead of entire 'CoreExpr'.
+data Subst = Subst InScopeSet IdSubstEnv
+
+type IdSubstEnv = IdEnv Id
+
+-- | @emptySubst = 'mkEmptySubst' 'emptyInScopeSet'@
+emptySubst :: Subst
+emptySubst = mkEmptySubst emptyInScopeSet
+
+-- | Constructs a new 'Subst' assuming the variables in the given 'InScopeSet'
+-- are in scope.
+mkEmptySubst :: InScopeSet -> Subst
+mkEmptySubst in_scope = Subst in_scope emptyVarEnv
+
+-- | Substitutes an 'Id' for another one according to the 'Subst' given in a way
+-- that avoids shadowing the 'InScopeSet', returning the result and an updated
+-- 'Subst' that should be used by subsequent substitutions.
+substBndr :: Id -> Subst -> (Id, Subst)
+substBndr id (Subst in_scope env)
+  = (new_id, Subst new_in_scope new_env)
+  where
+    new_id = uniqAway in_scope id
+    no_change = new_id == id -- in case nothing shadowed
+    new_in_scope = in_scope `extendInScopeSet` new_id
+    new_env
+      | no_change = delVarEnv env id
+      | otherwise = extendVarEnv env id new_id
+
+-- | @substBndrs = runState . traverse (state . substBndr)@
+substBndrs :: Traversable f => f Id -> Subst -> (f Id, Subst)
+substBndrs = runState . traverse (state . substBndr)
+
+-- | Substitutes an occurrence of an identifier for its counterpart recorded
+-- in the 'Subst'.
+lookupIdSubst :: HasCallStack => Id -> Subst -> Id
+lookupIdSubst id (Subst in_scope env)
+  | not (isLocalId id) = id
+  | Just id' <- lookupVarEnv env id = id'
+  | Just id' <- lookupInScope in_scope id = id'
+  | otherwise = WARN( True, text "StgSubst.lookupIdSubst" <+> ppr id $$ ppr in_scope)
+                id
+
+-- | Substitutes an occurrence of an identifier for its counterpart recorded
+-- in the 'Subst'. Does not generate a debug warning if the identifier to
+-- to substitute wasn't in scope.
+noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id
+noWarnLookupIdSubst id (Subst in_scope env)
+  | not (isLocalId id) = id
+  | Just id' <- lookupVarEnv env id = id'
+  | Just id' <- lookupInScope in_scope id = id'
+  | otherwise = id
+
+-- | Add the 'Id' to the in-scope set and remove any existing substitutions for
+-- it.
+extendInScope :: Id -> Subst -> Subst
+extendInScope id (Subst in_scope env) = Subst (in_scope `extendInScopeSet` id) env
+
+-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the
+-- in-scope set is such that TyCORep Note [The substitution invariant]
+-- holds after extending the substitution like this.
+extendSubst :: Id -> Id -> Subst -> Subst
+extendSubst id new_id (Subst in_scope env)
+  = ASSERT2( new_id `elemInScopeSet` in_scope, ppr id <+> ppr new_id $$ ppr in_scope )
+    Subst in_scope (extendVarEnv env id new_id)
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stgSyn/StgSyn.hs
@@ -0,0 +1,879 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}
+
+This data type represents programs just before code generation (conversion to
+@Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style
+being one that happens to be ideally suited to spineless tagless code
+generation.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds #-}
+
+module StgSyn (
+        StgArg(..),
+
+        GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
+        GenStgAlt, AltType(..),
+
+        StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape,
+        NoExtSilent, noExtSilent,
+        OutputablePass,
+
+        UpdateFlag(..), isUpdatable,
+
+        -- a set of synonyms for the vanilla parameterisation
+        StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt,
+
+        -- a set of synonyms for the code gen parameterisation
+        CgStgTopBinding, CgStgBinding, CgStgExpr, CgStgRhs, CgStgAlt,
+
+        -- a set of synonyms for the lambda lifting parameterisation
+        LlStgTopBinding, LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt,
+
+        -- a set of synonyms to distinguish in- and out variants
+        InStgArg,  InStgTopBinding,  InStgBinding,  InStgExpr,  InStgRhs,  InStgAlt,
+        OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt,
+
+        -- StgOp
+        StgOp(..),
+
+        -- utils
+        topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
+        isDllConApp,
+        stgArgType,
+        stripStgTicksTop,
+        stgCaseBndrInScope,
+
+        pprStgBinding, pprGenStgTopBindings, pprStgTopBindings
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSyn     ( AltCon, Tickish )
+import CostCentre  ( CostCentreStack )
+import Data.ByteString ( ByteString )
+import Data.Data   ( Data )
+import Data.List   ( intersperse )
+import DataCon
+import DynFlags
+import FastString
+import ForeignCall ( ForeignCall )
+import Id
+import IdInfo      ( mayHaveCafRefs )
+import VarSet
+import Literal     ( Literal, literalType )
+import Module      ( Module )
+import Outputable
+import Packages    ( isDllName )
+import Platform
+import PprCore     ( {- instances -} )
+import PrimOp      ( PrimOp, PrimCall )
+import TyCon       ( PrimRep(..), TyCon )
+import Type        ( Type )
+import RepType     ( typePrimRep1 )
+import Unique      ( Unique )
+import Util
+
+import Data.List.NonEmpty ( NonEmpty, toList )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{@GenStgBinding@}
+*                                                                      *
+************************************************************************
+
+As usual, expressions are interesting; other things are boring. Here
+are the boring things [except note the @GenStgRhs@], parameterised
+with respect to binder and occurrence information (just as in
+@CoreSyn@):
+-}
+
+-- | A top-level binding.
+data GenStgTopBinding pass
+-- See Note [CoreSyn top-level string literals]
+  = StgTopLifted (GenStgBinding pass)
+  | StgTopStringLit Id ByteString
+
+data GenStgBinding pass
+  = StgNonRec (BinderP pass) (GenStgRhs pass)
+  | StgRec    [(BinderP pass, GenStgRhs pass)]
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{@StgArg@}
+*                                                                      *
+************************************************************************
+-}
+
+data StgArg
+  = StgVarArg  Id
+  | StgLitArg  Literal
+
+-- | Does this constructor application refer to
+-- anything in a different *Windows* DLL?
+-- If so, we can't allocate it statically
+isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool
+isDllConApp dflags this_mod con args
+ | platformOS (targetPlatform dflags) == OSMinGW32
+    = isDllName dflags this_mod (dataConName con) || any is_dll_arg args
+ | otherwise = False
+  where
+    -- NB: typePrimRep1 is legit because any free variables won't have
+    -- unlifted type (there are no unlifted things at top level)
+    is_dll_arg :: StgArg -> Bool
+    is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep1 (idType v))
+                             && isDllName dflags this_mod (idName v)
+    is_dll_arg _             = False
+
+-- True of machine addresses; these are the things that don't
+-- work across DLLs. The key point here is that VoidRep comes
+-- out False, so that a top level nullary GADT constructor is
+-- False for isDllConApp
+--    data T a where
+--      T1 :: T Int
+-- gives
+--    T1 :: forall a. (a~Int) -> T a
+-- and hence the top-level binding
+--    $WT1 :: T Int
+--    $WT1 = T1 Int (Coercion (Refl Int))
+-- The coercion argument here gets VoidRep
+isAddrRep :: PrimRep -> Bool
+isAddrRep AddrRep     = True
+isAddrRep LiftedRep   = True
+isAddrRep UnliftedRep = True
+isAddrRep _           = False
+
+-- | Type of an @StgArg@
+--
+-- Very half baked because we have lost the type arguments.
+stgArgType :: StgArg -> Type
+stgArgType (StgVarArg v)   = idType v
+stgArgType (StgLitArg lit) = literalType lit
+
+
+-- | Strip ticks of a given type from an STG expression
+stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p)
+stripStgTicksTop p = go []
+   where go ts (StgTick t e) | p t = go (t:ts) e
+         go ts other               = (reverse ts, other)
+
+-- | Given an alt type and whether the program is unarised, return whether the
+-- case binder is in scope.
+--
+-- Case binders of unboxed tuple or unboxed sum type always dead after the
+-- unariser has run. See Note [Post-unarisation invariants].
+stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool
+stgCaseBndrInScope alt_ty unarised =
+    case alt_ty of
+      AlgAlt _      -> True
+      PrimAlt _     -> True
+      MultiValAlt _ -> not unarised
+      PolyAlt       -> True
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{STG expressions}
+*                                                                      *
+************************************************************************
+
+The @GenStgExpr@ data type is parameterised on binder and occurrence
+info, as before.
+
+************************************************************************
+*                                                                      *
+\subsubsection{@GenStgExpr@ application}
+*                                                                      *
+************************************************************************
+
+An application is of a function to a list of atoms [not expressions].
+Operationally, we want to push the arguments on the stack and call the
+function. (If the arguments were expressions, we would have to build
+their closures first.)
+
+There is no constructor for a lone variable; it would appear as
+@StgApp var []@.
+-}
+
+data GenStgExpr pass
+  = StgApp
+        Id       -- function
+        [StgArg] -- arguments; may be empty
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
+*                                                                      *
+************************************************************************
+
+There are specialised forms of application, for constructors,
+primitives, and literals.
+-}
+
+  | StgLit      Literal
+
+        -- StgConApp is vital for returning unboxed tuples or sums
+        -- which can't be let-bound first
+  | StgConApp   DataCon
+                [StgArg] -- Saturated
+                [Type]   -- See Note [Types in StgConApp] in UnariseStg
+
+  | StgOpApp    StgOp    -- Primitive op or foreign call
+                [StgArg] -- Saturated.
+                Type     -- Result type
+                         -- We need to know this so that we can
+                         -- assign result registers
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{@StgLam@}
+*                                                                      *
+************************************************************************
+
+StgLam is used *only* during CoreToStg's work. Before CoreToStg has
+finished it encodes (\x -> e) as (let f = \x -> e in f)
+TODO: Encode this via an extension to GenStgExpr à la TTG.
+-}
+
+  | StgLam
+        (NonEmpty (BinderP pass))
+        StgExpr    -- Body of lambda
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{@GenStgExpr@: case-expressions}
+*                                                                      *
+************************************************************************
+
+This has the same boxed/unboxed business as Core case expressions.
+-}
+
+  | StgCase
+        (GenStgExpr pass) -- the thing to examine
+        (BinderP pass) -- binds the result of evaluating the scrutinee
+        AltType
+        [GenStgAlt pass]
+                    -- The DEFAULT case is always *first*
+                    -- if it is there at all
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{@GenStgExpr@: @let(rec)@-expressions}
+*                                                                      *
+************************************************************************
+
+The various forms of let(rec)-expression encode most of the
+interesting things we want to do.
+\begin{enumerate}
+\item
+\begin{verbatim}
+let-closure x = [free-vars] [args] expr
+in e
+\end{verbatim}
+is equivalent to
+\begin{verbatim}
+let x = (\free-vars -> \args -> expr) free-vars
+\end{verbatim}
+\tr{args} may be empty (and is for most closures).  It isn't under
+circumstances like this:
+\begin{verbatim}
+let x = (\y -> y+z)
+\end{verbatim}
+This gets mangled to
+\begin{verbatim}
+let-closure x = [z] [y] (y+z)
+\end{verbatim}
+The idea is that we compile code for @(y+z)@ in an environment in which
+@z@ is bound to an offset from \tr{Node}, and @y@ is bound to an
+offset from the stack pointer.
+
+(A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)
+
+\item
+\begin{verbatim}
+let-constructor x = Constructor [args]
+in e
+\end{verbatim}
+
+(A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)
+
+\item
+Letrec-expressions are essentially the same deal as
+let-closure/let-constructor, so we use a common structure and
+distinguish between them with an @is_recursive@ boolean flag.
+
+\item
+\begin{verbatim}
+let-unboxed u = an arbitrary arithmetic expression in unboxed values
+in e
+\end{verbatim}
+All the stuff on the RHS must be fully evaluated.
+No function calls either!
+
+(We've backed away from this toward case-expressions with
+suitably-magical alts ...)
+
+\item
+~[Advanced stuff here! Not to start with, but makes pattern matching
+generate more efficient code.]
+
+\begin{verbatim}
+let-escapes-not fail = expr
+in e'
+\end{verbatim}
+Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,
+or pass it to another function. All @e'@ will ever do is tail-call @fail@.
+Rather than build a closure for @fail@, all we need do is to record the stack
+level at the moment of the @let-escapes-not@; then entering @fail@ is just
+a matter of adjusting the stack pointer back down to that point and entering
+the code for it.
+
+Another example:
+\begin{verbatim}
+f x y = let z = huge-expression in
+        if y==1 then z else
+        if y==2 then z else
+        1
+\end{verbatim}
+
+(A let-escapes-not is an @StgLetNoEscape@.)
+
+\item
+We may eventually want:
+\begin{verbatim}
+let-literal x = Literal
+in e
+\end{verbatim}
+\end{enumerate}
+
+And so the code for let(rec)-things:
+-}
+
+  | StgLet
+        (XLet pass)
+        (GenStgBinding pass)    -- right hand sides (see below)
+        (GenStgExpr pass)       -- body
+
+  | StgLetNoEscape
+        (XLetNoEscape pass)
+        (GenStgBinding pass)    -- right hand sides (see below)
+        (GenStgExpr pass)       -- body
+
+{-
+%************************************************************************
+%*                                                                      *
+\subsubsection{@GenStgExpr@: @hpc@, @scc@ and other debug annotations}
+%*                                                                      *
+%************************************************************************
+
+Finally for @hpc@ expressions we introduce a new STG construct.
+-}
+
+  | StgTick
+    (Tickish Id)
+    (GenStgExpr pass)       -- sub expression
+
+-- END of GenStgExpr
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{STG right-hand sides}
+*                                                                      *
+************************************************************************
+
+Here's the rest of the interesting stuff for @StgLet@s; the first
+flavour is for closures:
+-}
+
+data GenStgRhs pass
+  = StgRhsClosure
+        (XRhsClosure pass) -- ^ Extension point for non-global free var
+                           --   list just before 'CodeGen'.
+        CostCentreStack    -- ^ CCS to be attached (default is CurrentCCS)
+        !UpdateFlag        -- ^ 'ReEntrant' | 'Updatable' | 'SingleEntry'
+        [BinderP pass]     -- ^ arguments; if empty, then not a function;
+                           --   as above, order is important.
+        (GenStgExpr pass)  -- ^ body
+
+{-
+An example may be in order.  Consider:
+\begin{verbatim}
+let t = \x -> \y -> ... x ... y ... p ... q in e
+\end{verbatim}
+Pulling out the free vars and stylising somewhat, we get the equivalent:
+\begin{verbatim}
+let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q
+\end{verbatim}
+Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are
+offsets from @Node@ into the closure, and the code ptr for the closure
+will be exactly that in parentheses above.
+
+The second flavour of right-hand-side is for constructors (simple but important):
+-}
+
+  | StgRhsCon
+        CostCentreStack -- CCS to be attached (default is CurrentCCS).
+                        -- Top-level (static) ones will end up with
+                        -- DontCareCCS, because we don't count static
+                        -- data in heap profiles, and we don't set CCCS
+                        -- from static closure.
+        DataCon         -- Constructor. Never an unboxed tuple or sum, as those
+                        -- are not allocated.
+        [StgArg]        -- Args
+
+-- | Used as a data type index for the stgSyn AST
+data StgPass
+  = Vanilla
+  | LiftLams
+  | CodeGen
+
+-- | Like 'HsExpression.NoExt', but with an 'Outputable' instance that returns
+-- 'empty'.
+data NoExtSilent = NoExtSilent
+  deriving (Data, Eq, Ord)
+
+instance Outputable NoExtSilent where
+  ppr _ = empty
+
+-- | Used when constructing a term with an unused extension point that should
+-- not appear in pretty-printed output at all.
+noExtSilent :: NoExtSilent
+noExtSilent = NoExtSilent
+-- TODO: Maybe move this to HsExtensions? I'm not sure about the implications
+-- on build time...
+
+-- TODO: Do we really want to the extension point type families to have a closed
+-- domain?
+type family BinderP (pass :: StgPass)
+type instance BinderP 'Vanilla = Id
+type instance BinderP 'CodeGen = Id
+
+type family XRhsClosure (pass :: StgPass)
+type instance XRhsClosure 'Vanilla = NoExtSilent
+-- | Code gen needs to track non-global free vars
+type instance XRhsClosure 'CodeGen = DIdSet
+
+type family XLet (pass :: StgPass)
+type instance XLet 'Vanilla = NoExtSilent
+type instance XLet 'CodeGen = NoExtSilent
+
+type family XLetNoEscape (pass :: StgPass)
+type instance XLetNoEscape 'Vanilla = NoExtSilent
+type instance XLetNoEscape 'CodeGen = NoExtSilent
+
+stgRhsArity :: StgRhs -> Int
+stgRhsArity (StgRhsClosure _ _ _ bndrs _)
+  = ASSERT( all isId bndrs ) length bndrs
+  -- The arity never includes type parameters, but they should have gone by now
+stgRhsArity (StgRhsCon _ _ _) = 0
+
+-- Note [CAF consistency]
+-- ~~~~~~~~~~~~~~~~~~~~~~
+--
+-- `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in
+-- `CoreToStg`) to make sure CAF-ness predicted by `TidyPgm` is consistent with
+-- reality.
+--
+-- Specifically, if the RHS mentions any Id that itself is marked
+-- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the
+-- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble
+-- is that `TidyPgm` computed the CAF info on the `Id` but some transformations
+-- have taken place since then.
+
+topStgBindHasCafRefs :: GenStgTopBinding pass -> Bool
+topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs))
+  = topRhsHasCafRefs rhs
+topStgBindHasCafRefs (StgTopLifted (StgRec binds))
+  = any topRhsHasCafRefs (map snd binds)
+topStgBindHasCafRefs StgTopStringLit{}
+  = False
+
+topRhsHasCafRefs :: GenStgRhs pass -> Bool
+topRhsHasCafRefs (StgRhsClosure _ _ upd _ body)
+  = -- See Note [CAF consistency]
+    isUpdatable upd || exprHasCafRefs body
+topRhsHasCafRefs (StgRhsCon _ _ args)
+  = any stgArgHasCafRefs args
+
+exprHasCafRefs :: GenStgExpr pass -> Bool
+exprHasCafRefs (StgApp f args)
+  = stgIdHasCafRefs f || any stgArgHasCafRefs args
+exprHasCafRefs StgLit{}
+  = False
+exprHasCafRefs (StgConApp _ args _)
+  = any stgArgHasCafRefs args
+exprHasCafRefs (StgOpApp _ args _)
+  = any stgArgHasCafRefs args
+exprHasCafRefs (StgLam _ body)
+  = exprHasCafRefs body
+exprHasCafRefs (StgCase scrt _ _ alts)
+  = exprHasCafRefs scrt || any altHasCafRefs alts
+exprHasCafRefs (StgLet _ bind body)
+  = bindHasCafRefs bind || exprHasCafRefs body
+exprHasCafRefs (StgLetNoEscape _ bind body)
+  = bindHasCafRefs bind || exprHasCafRefs body
+exprHasCafRefs (StgTick _ expr)
+  = exprHasCafRefs expr
+
+bindHasCafRefs :: GenStgBinding pass -> Bool
+bindHasCafRefs (StgNonRec _ rhs)
+  = rhsHasCafRefs rhs
+bindHasCafRefs (StgRec binds)
+  = any rhsHasCafRefs (map snd binds)
+
+rhsHasCafRefs :: GenStgRhs pass -> Bool
+rhsHasCafRefs (StgRhsClosure _ _ _ _ body)
+  = exprHasCafRefs body
+rhsHasCafRefs (StgRhsCon _ _ args)
+  = any stgArgHasCafRefs args
+
+altHasCafRefs :: GenStgAlt pass -> Bool
+altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs
+
+stgArgHasCafRefs :: StgArg -> Bool
+stgArgHasCafRefs (StgVarArg id)
+  = stgIdHasCafRefs id
+stgArgHasCafRefs _
+  = False
+
+stgIdHasCafRefs :: Id -> Bool
+stgIdHasCafRefs id =
+  -- We are looking for occurrences of an Id that is bound at top level, and may
+  -- have CAF refs. At this point (after TidyPgm) top-level Ids (whether
+  -- imported or defined in this module) are GlobalIds, so the test is easy.
+  isGlobalId id && mayHaveCafRefs (idCafInfo id)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[Stg-case-alternatives]{STG case alternatives}
+*                                                                      *
+************************************************************************
+
+Very like in @CoreSyntax@ (except no type-world stuff).
+
+The type constructor is guaranteed not to be abstract; that is, we can
+see its representation. This is important because the code generator
+uses it to determine return conventions etc. But it's not trivial
+where there's a module loop involved, because some versions of a type
+constructor might not have all the constructors visible. So
+mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the
+constructors or literals (which are guaranteed to have the Real McCoy)
+rather than from the scrutinee type.
+-}
+
+type GenStgAlt pass
+  = (AltCon,          -- alts: data constructor,
+     [BinderP pass],  -- constructor's parameters,
+     GenStgExpr pass) -- ...right-hand side.
+
+data AltType
+  = PolyAlt             -- Polymorphic (a lifted type variable)
+  | MultiValAlt Int     -- Multi value of this arity (unboxed tuple or sum)
+                        -- the arity could indeed be 1 for unary unboxed tuple
+                        -- or enum-like unboxed sums
+  | AlgAlt      TyCon   -- Algebraic data type; the AltCons will be DataAlts
+  | PrimAlt     PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[Stg]{The Plain STG parameterisation}
+*                                                                      *
+************************************************************************
+
+This happens to be the only one we use at the moment.
+-}
+
+type StgTopBinding = GenStgTopBinding 'Vanilla
+type StgBinding    = GenStgBinding    'Vanilla
+type StgExpr       = GenStgExpr       'Vanilla
+type StgRhs        = GenStgRhs        'Vanilla
+type StgAlt        = GenStgAlt        'Vanilla
+
+type LlStgTopBinding = GenStgTopBinding 'LiftLams
+type LlStgBinding    = GenStgBinding    'LiftLams
+type LlStgExpr       = GenStgExpr       'LiftLams
+type LlStgRhs        = GenStgRhs        'LiftLams
+type LlStgAlt        = GenStgAlt        'LiftLams
+
+type CgStgTopBinding = GenStgTopBinding 'CodeGen
+type CgStgBinding    = GenStgBinding    'CodeGen
+type CgStgExpr       = GenStgExpr       'CodeGen
+type CgStgRhs        = GenStgRhs        'CodeGen
+type CgStgAlt        = GenStgAlt        'CodeGen
+
+{- Many passes apply a substitution, and it's very handy to have type
+   synonyms to remind us whether or not the substitution has been applied.
+   See CoreSyn for precedence in Core land
+-}
+
+type InStgTopBinding  = StgTopBinding
+type InStgBinding     = StgBinding
+type InStgArg         = StgArg
+type InStgExpr        = StgExpr
+type InStgRhs         = StgRhs
+type InStgAlt         = StgAlt
+type OutStgTopBinding = StgTopBinding
+type OutStgBinding    = StgBinding
+type OutStgArg        = StgArg
+type OutStgExpr       = StgExpr
+type OutStgRhs        = StgRhs
+type OutStgAlt        = StgAlt
+
+{-
+
+************************************************************************
+*                                                                      *
+\subsubsection[UpdateFlag-datatype]{@UpdateFlag@}
+*                                                                      *
+************************************************************************
+
+This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
+
+A @ReEntrant@ closure may be entered multiple times, but should not be
+updated or blackholed. An @Updatable@ closure should be updated after
+evaluation (and may be blackholed during evaluation). A @SingleEntry@
+closure will only be entered once, and so need not be updated but may
+safely be blackholed.
+-}
+
+data UpdateFlag = ReEntrant | Updatable | SingleEntry
+
+instance Outputable UpdateFlag where
+    ppr u = char $ case u of
+                       ReEntrant   -> 'r'
+                       Updatable   -> 'u'
+                       SingleEntry -> 's'
+
+isUpdatable :: UpdateFlag -> Bool
+isUpdatable ReEntrant   = False
+isUpdatable SingleEntry = False
+isUpdatable Updatable   = True
+
+{-
+************************************************************************
+*                                                                      *
+\subsubsection{StgOp}
+*                                                                      *
+************************************************************************
+
+An StgOp allows us to group together PrimOps and ForeignCalls.
+It's quite useful to move these around together, notably
+in StgOpApp and COpStmt.
+-}
+
+data StgOp
+  = StgPrimOp  PrimOp
+
+  | StgPrimCallOp PrimCall
+
+  | StgFCallOp ForeignCall Unique
+        -- The Unique is occasionally needed by the C pretty-printer
+        -- (which lacks a unique supply), notably when generating a
+        -- typedef for foreign-export-dynamic
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[Stg-pretty-printing]{Pretty-printing}
+*                                                                      *
+************************************************************************
+
+Robin Popplestone asked for semi-colon separators on STG binds; here's
+hoping he likes terminators instead...  Ditto for case alternatives.
+-}
+
+type OutputablePass pass =
+  ( Outputable (XLet pass)
+  , Outputable (XLetNoEscape pass)
+  , Outputable (XRhsClosure pass)
+  , OutputableBndr (BinderP pass)
+  )
+
+pprGenStgTopBinding
+  :: OutputablePass pass => GenStgTopBinding pass -> SDoc
+pprGenStgTopBinding (StgTopStringLit bndr str)
+  = hang (hsep [pprBndr LetBind bndr, equals])
+        4 (pprHsBytes str <> semi)
+pprGenStgTopBinding (StgTopLifted bind)
+  = pprGenStgBinding bind
+
+pprGenStgBinding
+  :: OutputablePass pass => GenStgBinding pass -> SDoc
+
+pprGenStgBinding (StgNonRec bndr rhs)
+  = hang (hsep [pprBndr LetBind bndr, equals])
+        4 (ppr rhs <> semi)
+
+pprGenStgBinding (StgRec pairs)
+  = vcat [ text "Rec {"
+         , vcat (map ppr_bind pairs)
+         , text "end Rec }" ]
+  where
+    ppr_bind (bndr, expr)
+      = hang (hsep [pprBndr LetBind bndr, equals])
+             4 (ppr expr <> semi)
+
+pprGenStgTopBindings
+  :: (OutputablePass pass) => [GenStgTopBinding pass] -> SDoc
+pprGenStgTopBindings binds
+  = vcat $ intersperse blankLine (map pprGenStgTopBinding binds)
+
+pprStgBinding :: StgBinding -> SDoc
+pprStgBinding = pprGenStgBinding
+
+pprStgTopBindings :: [StgTopBinding] -> SDoc
+pprStgTopBindings = pprGenStgTopBindings
+
+instance Outputable StgArg where
+    ppr = pprStgArg
+
+instance OutputablePass pass => Outputable (GenStgTopBinding pass) where
+    ppr = pprGenStgTopBinding
+
+instance OutputablePass pass => Outputable (GenStgBinding pass) where
+    ppr = pprGenStgBinding
+
+instance OutputablePass pass => Outputable (GenStgExpr pass) where
+    ppr = pprStgExpr
+
+instance OutputablePass pass => Outputable (GenStgRhs pass) where
+    ppr rhs = pprStgRhs rhs
+
+pprStgArg :: StgArg -> SDoc
+pprStgArg (StgVarArg var) = ppr var
+pprStgArg (StgLitArg con) = ppr con
+
+pprStgExpr :: OutputablePass pass => GenStgExpr pass -> SDoc
+-- special case
+pprStgExpr (StgLit lit)     = ppr lit
+
+-- general case
+pprStgExpr (StgApp func args)
+  = hang (ppr func) 4 (sep (map (ppr) args))
+
+pprStgExpr (StgConApp con args _)
+  = hsep [ ppr con, brackets (interppSP args) ]
+
+pprStgExpr (StgOpApp op args _)
+  = hsep [ pprStgOp op, brackets (interppSP args)]
+
+pprStgExpr (StgLam bndrs body)
+  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs))
+            <+> text "->",
+         pprStgExpr body ]
+  where ppr_list = brackets . fsep . punctuate comma
+
+-- special case: let v = <very specific thing>
+--               in
+--               let ...
+--               in
+--               ...
+--
+-- Very special!  Suspicious! (SLPJ)
+
+{-
+pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
+                        expr@(StgLet _ _))
+  = ($$)
+      (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "),
+                          ppr cc,
+                          pp_binder_info bi,
+                          text " [", whenPprDebug (interppSP free_vars), ptext (sLit "] \\"),
+                          ppr upd_flag, text " [",
+                          interppSP args, char ']'])
+            8 (sep [hsep [ppr rhs, text "} in"]]))
+      (ppr expr)
+-}
+
+-- special case: let ... in let ...
+
+pprStgExpr (StgLet ext bind expr@StgLet{})
+  = ($$)
+      (sep [hang (text "let" <+> ppr ext <+> text "{")
+                2 (hsep [pprGenStgBinding bind, text "} in"])])
+      (ppr expr)
+
+-- general case
+pprStgExpr (StgLet ext bind expr)
+  = sep [hang (text "let" <+> ppr ext <+> text "{") 2 (pprGenStgBinding bind),
+           hang (text "} in ") 2 (ppr expr)]
+
+pprStgExpr (StgLetNoEscape ext bind expr)
+  = sep [hang (text "let-no-escape" <+> ppr ext <+> text "{")
+                2 (pprGenStgBinding bind),
+           hang (text "} in ")
+                2 (ppr expr)]
+
+pprStgExpr (StgTick tickish expr)
+  = sdocWithDynFlags $ \dflags ->
+    if gopt Opt_SuppressTicks dflags
+    then pprStgExpr expr
+    else sep [ ppr tickish, pprStgExpr expr ]
+
+
+pprStgExpr (StgCase expr bndr alt_type alts)
+  = sep [sep [text "case",
+           nest 4 (hsep [pprStgExpr expr,
+             whenPprDebug (dcolon <+> ppr alt_type)]),
+           text "of", pprBndr CaseBind bndr, char '{'],
+           nest 2 (vcat (map pprStgAlt alts)),
+           char '}']
+
+pprStgAlt :: OutputablePass pass => GenStgAlt pass -> SDoc
+pprStgAlt (con, params, expr)
+  = hang (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])
+         4 (ppr expr <> semi)
+
+pprStgOp :: StgOp -> SDoc
+pprStgOp (StgPrimOp  op)   = ppr op
+pprStgOp (StgPrimCallOp op)= ppr op
+pprStgOp (StgFCallOp op _) = ppr op
+
+instance Outputable AltType where
+  ppr PolyAlt         = text "Polymorphic"
+  ppr (MultiValAlt n) = text "MultiAlt" <+> ppr n
+  ppr (AlgAlt tc)     = text "Alg"    <+> ppr tc
+  ppr (PrimAlt tc)    = text "Prim"   <+> ppr tc
+
+pprStgRhs :: OutputablePass pass => GenStgRhs pass -> SDoc
+
+-- special case
+pprStgRhs (StgRhsClosure ext cc upd_flag [{-no args-}] (StgApp func []))
+  = sdocWithDynFlags $ \dflags ->
+    hsep [ ppr cc,
+           if not $ gopt Opt_SuppressStgExts dflags
+             then ppr ext else empty,
+           text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]
+
+-- general case
+pprStgRhs (StgRhsClosure ext cc upd_flag args body)
+  = sdocWithDynFlags $ \dflags ->
+    hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
+                if not $ gopt Opt_SuppressStgExts dflags
+                  then ppr ext else empty,
+                char '\\' <> ppr upd_flag, brackets (interppSP args)])
+         4 (ppr body)
+
+pprStgRhs (StgRhsCon cc con args)
+  = hcat [ ppr cc,
+           space, ppr con, text "! ", brackets (interppSP args)]
diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stranal/DmdAnal.hs
@@ -0,0 +1,1466 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+
+                        -----------------
+                        A demand analysis
+                        -----------------
+-}
+
+{-# LANGUAGE CPP #-}
+
+module DmdAnal ( dmdAnalProgram ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import DynFlags
+import WwLib            ( findTypeShape, deepSplitProductType_maybe )
+import Demand   -- All of it
+import CoreSyn
+import CoreSeq          ( seqBinds )
+import Outputable
+import VarEnv
+import BasicTypes
+import Data.List
+import DataCon
+import Id
+import CoreUtils        ( exprIsHNF, exprType, exprIsTrivial, exprOkForSpeculation )
+import TyCon
+import Type
+import Coercion         ( Coercion, coVarsOfCo )
+import FamInstEnv
+import Util
+import Maybes           ( isJust )
+import TysWiredIn
+import TysPrim          ( realWorldStatePrimTy )
+import ErrUtils         ( dumpIfSet_dyn )
+import Name             ( getName, stableNameCmp )
+import Data.Function    ( on )
+import UniqSet
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Top level stuff}
+*                                                                      *
+************************************************************************
+-}
+
+dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram
+dmdAnalProgram dflags fam_envs binds
+  = do {
+        let { binds_plus_dmds = do_prog binds } ;
+        dumpIfSet_dyn dflags Opt_D_dump_str_signatures
+                      "Strictness signatures" $
+            dumpStrSig binds_plus_dmds ;
+        -- See Note [Stamp out space leaks in demand analysis]
+        seqBinds binds_plus_dmds `seq` return binds_plus_dmds
+    }
+  where
+    do_prog :: CoreProgram -> CoreProgram
+    do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags fam_envs) binds
+
+-- Analyse a (group of) top-level binding(s)
+dmdAnalTopBind :: AnalEnv
+               -> CoreBind
+               -> (AnalEnv, CoreBind)
+dmdAnalTopBind env (NonRec id rhs)
+  = (extendAnalEnv TopLevel env id2 (idStrictness id2), NonRec id2 rhs2)
+  where
+    ( _, _,   rhs1) = dmdAnalRhsLetDown TopLevel Nothing env             cleanEvalDmd id rhs
+    ( _, id2, rhs2) = dmdAnalRhsLetDown TopLevel Nothing (nonVirgin env) cleanEvalDmd id rhs1
+        -- Do two passes to improve CPR information
+        -- See Note [CPR for thunks]
+        -- See Note [Optimistic CPR in the "virgin" case]
+        -- See Note [Initial CPR for strict binders]
+
+dmdAnalTopBind env (Rec pairs)
+  = (env', Rec pairs')
+  where
+    (env', _, pairs')  = dmdFix TopLevel env cleanEvalDmd pairs
+                -- We get two iterations automatically
+                -- c.f. the NonRec case above
+
+{- Note [Stamp out space leaks in demand analysis]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The demand analysis pass outputs a new copy of the Core program in
+which binders have been annotated with demand and strictness
+information. It's tiresome to ensure that this information is fully
+evaluated everywhere that we produce it, so we just run a single
+seqBinds over the output before returning it, to ensure that there are
+no references holding on to the input Core program.
+
+This makes a ~30% reduction in peak memory usage when compiling
+DynFlags (cf Trac #9675 and #13426).
+
+This is particularly important when we are doing late demand analysis,
+since we don't do a seqBinds at any point thereafter. Hence code
+generation would hold on to an extra copy of the Core program, via
+unforced thunks in demand or strictness information; and it is the
+most memory-intensive part of the compilation process, so this added
+seqBinds makes a big difference in peak memory usage.
+-}
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{The analyser itself}
+*                                                                      *
+************************************************************************
+
+Note [Ensure demand is strict]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's important not to analyse e with a lazy demand because
+a) When we encounter   case s of (a,b) ->
+        we demand s with U(d1d2)... but if the overall demand is lazy
+        that is wrong, and we'd need to reduce the demand on s,
+        which is inconvenient
+b) More important, consider
+        f (let x = R in x+x), where f is lazy
+   We still want to mark x as demanded, because it will be when we
+   enter the let.  If we analyse f's arg with a Lazy demand, we'll
+   just mark x as Lazy
+c) The application rule wouldn't be right either
+   Evaluating (f x) in a L demand does *not* cause
+   evaluation of f in a C(L) demand!
+-}
+
+-- If e is complicated enough to become a thunk, its contents will be evaluated
+-- at most once, so oneify it.
+dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand
+dmdTransformThunkDmd e
+  | exprIsTrivial e = id
+  | otherwise       = oneifyDmd
+
+-- Do not process absent demands
+-- Otherwise act like in a normal demand analysis
+-- See ↦* relation in the Cardinality Analysis paper
+dmdAnalStar :: AnalEnv
+            -> Demand   -- This one takes a *Demand*
+            -> CoreExpr -- Should obey the let/app invariatn
+            -> (BothDmdArg, CoreExpr)
+dmdAnalStar env dmd e
+  | (dmd_shell, cd) <- toCleanDmd dmd
+  , (dmd_ty, e')    <- dmdAnal env cd e
+  = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )
+    -- The argument 'e' should satisfy the let/app invariant
+    -- See Note [Analysing with absent demand] in Demand.hs
+    (postProcessDmdType dmd_shell dmd_ty, e')
+
+-- Main Demand Analsysis machinery
+dmdAnal, dmdAnal' :: AnalEnv
+        -> CleanDemand         -- The main one takes a *CleanDemand*
+        -> CoreExpr -> (DmdType, CoreExpr)
+
+-- The CleanDemand is always strict and not absent
+--    See Note [Ensure demand is strict]
+
+dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
+                  dmdAnal' env d e
+
+dmdAnal' _ _ (Lit lit)     = (nopDmdType, Lit lit)
+dmdAnal' _ _ (Type ty)     = (nopDmdType, Type ty)      -- Doesn't happen, in fact
+dmdAnal' _ _ (Coercion co)
+  = (unitDmdType (coercionDmdEnv co), Coercion co)
+
+dmdAnal' env dmd (Var var)
+  = (dmdTransform env var dmd, Var var)
+
+dmdAnal' env dmd (Cast e co)
+  = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co)
+  where
+    (dmd_ty, e') = dmdAnal env dmd e
+
+dmdAnal' env dmd (Tick t e)
+  = (dmd_ty, Tick t e')
+  where
+    (dmd_ty, e') = dmdAnal env dmd e
+
+dmdAnal' env dmd (App fun (Type ty))
+  = (fun_ty, App fun' (Type ty))
+  where
+    (fun_ty, fun') = dmdAnal env dmd fun
+
+-- Lots of the other code is there to make this
+-- beautiful, compositional, application rule :-)
+dmdAnal' env dmd (App fun arg)
+  = -- This case handles value arguments (type args handled above)
+    -- Crucially, coercions /are/ handled here, because they are
+    -- value arguments (Trac #10288)
+    let
+        call_dmd          = mkCallDmd dmd
+        (fun_ty, fun')    = dmdAnal env call_dmd fun
+        (arg_dmd, res_ty) = splitDmdTy fun_ty
+        (arg_ty, arg')    = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg
+    in
+--    pprTrace "dmdAnal:app" (vcat
+--         [ text "dmd =" <+> ppr dmd
+--         , text "expr =" <+> ppr (App fun arg)
+--         , text "fun dmd_ty =" <+> ppr fun_ty
+--         , text "arg dmd =" <+> ppr arg_dmd
+--         , text "arg dmd_ty =" <+> ppr arg_ty
+--         , text "res dmd_ty =" <+> ppr res_ty
+--         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])
+    (res_ty `bothDmdType` arg_ty, App fun' arg')
+
+-- this is an anonymous lambda, since @dmdAnalRhsLetDown@ uses @collectBinders@
+dmdAnal' env dmd (Lam var body)
+  | isTyVar var
+  = let
+        (body_ty, body') = dmdAnal env dmd body
+    in
+    (body_ty, Lam var body')
+
+  | otherwise
+  = let (body_dmd, defer_and_use) = peelCallDmd dmd
+          -- body_dmd: a demand to analyze the body
+
+        env'             = extendSigsWithLam env var
+        (body_ty, body') = dmdAnal env' body_dmd body
+        (lam_ty, var')   = annotateLamIdBndr env notArgOfDfun body_ty var
+    in
+    (postProcessUnsat defer_and_use lam_ty, Lam var' body')
+
+dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
+  -- Only one alternative with a product constructor
+  | let tycon = dataConTyCon dc
+  , isJust (isDataProductTyCon_maybe tycon)
+  , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon
+  = let
+        env_w_tc                 = env { ae_rec_tc = rec_tc' }
+        env_alt                  = extendEnvForProdAlt env_w_tc scrut case_bndr dc bndrs
+        (rhs_ty, rhs')           = dmdAnal env_alt dmd rhs
+        (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs
+        (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr
+        id_dmds                  = addCaseBndrDmd case_bndr_dmd dmds
+        alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2
+                | otherwise                   = alt_ty2
+
+        -- Compute demand on the scrutinee
+        -- See Note [Demand on scrutinee of a product case]
+        scrut_dmd          = mkProdDmd id_dmds
+        (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut
+        res_ty             = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty
+        case_bndr'         = setIdDemandInfo case_bndr case_bndr_dmd
+        bndrs'             = setBndrsDemandInfo bndrs id_dmds
+    in
+--    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut
+--                                   , text "dmd" <+> ppr dmd
+--                                   , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')
+--                                   , text "id_dmds" <+> ppr id_dmds
+--                                   , text "scrut_dmd" <+> ppr scrut_dmd
+--                                   , text "scrut_ty" <+> ppr scrut_ty
+--                                   , text "alt_ty" <+> ppr alt_ty2
+--                                   , text "res_ty" <+> ppr res_ty ]) $
+    (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')])
+
+dmdAnal' env dmd (Case scrut case_bndr ty alts)
+  = let      -- Case expression with multiple alternatives
+        (alt_tys, alts')     = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts
+        (scrut_ty, scrut')   = dmdAnal env cleanEvalDmd scrut
+        (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr
+                               -- NB: Base case is botDmdType, for empty case alternatives
+                               --     This is a unit for lubDmdType, and the right result
+                               --     when there really are no alternatives
+        res_ty               = alt_ty `bothDmdType` toBothDmdArg scrut_ty
+    in
+--    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
+--                                   , text "scrut_ty" <+> ppr scrut_ty
+--                                   , text "alt_tys" <+> ppr alt_tys
+--                                   , text "alt_ty" <+> ppr alt_ty
+--                                   , text "res_ty" <+> ppr res_ty ]) $
+    (res_ty, Case scrut' case_bndr' ty alts')
+
+-- Let bindings can be processed in two ways:
+-- Down (RHS before body) or Up (body before RHS).
+-- The following case handle the up variant.
+--
+-- It is very simple. For  let x = rhs in body
+--   * Demand-analyse 'body' in the current environment
+--   * Find the demand, 'rhs_dmd' placed on 'x' by 'body'
+--   * Demand-analyse 'rhs' in 'rhs_dmd'
+--
+-- This is used for a non-recursive local let without manifest lambdas.
+-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.
+dmdAnal' env dmd (Let (NonRec id rhs) body)
+  | useLetUp id rhs
+  , Nothing <- unpackTrivial rhs
+      -- dmdAnalRhsLetDown treats trivial right hand sides specially
+      -- so if we have a trival right hand side, fall through to that.
+  = (final_ty, Let (NonRec id' rhs') body')
+  where
+    (body_ty, body')   = dmdAnal env dmd body
+    (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id
+    id'                = setIdDemandInfo id id_dmd
+
+    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs
+    final_ty           = body_ty' `bothDmdType` rhs_ty
+
+dmdAnal' env dmd (Let (NonRec id rhs) body)
+  = (body_ty2, Let (NonRec id2 rhs') body')
+  where
+    (lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env dmd id rhs
+    env1                 = extendAnalEnv NotTopLevel env id1 (idStrictness id1)
+    (body_ty, body')     = dmdAnal env1 dmd body
+    (body_ty1, id2)      = annotateBndr env body_ty id1
+    body_ty2             = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]
+
+        -- If the actual demand is better than the vanilla call
+        -- demand, you might think that we might do better to re-analyse
+        -- the RHS with the stronger demand.
+        -- But (a) That seldom happens, because it means that *every* path in
+        --         the body of the let has to use that stronger demand
+        -- (b) It often happens temporarily in when fixpointing, because
+        --     the recursive function at first seems to place a massive demand.
+        --     But we don't want to go to extra work when the function will
+        --     probably iterate to something less demanding.
+        -- In practice, all the times the actual demand on id2 is more than
+        -- the vanilla call demand seem to be due to (b).  So we don't
+        -- bother to re-analyse the RHS.
+
+dmdAnal' env dmd (Let (Rec pairs) body)
+  = let
+        (env', lazy_fv, pairs') = dmdFix NotTopLevel env dmd pairs
+        (body_ty, body')        = dmdAnal env' dmd body
+        body_ty1                = deleteFVs body_ty (map fst pairs)
+        body_ty2                = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]
+    in
+    body_ty2 `seq`
+    (body_ty2,  Let (Rec pairs') body')
+
+io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool
+-- See Note [IO hack in the demand analyser]
+io_hack_reqd scrut con bndrs
+  | (bndr:_) <- bndrs
+  , con == tupleDataCon Unboxed 2
+  , idType bndr `eqType` realWorldStatePrimTy
+  , (fun, _) <- collectArgs scrut
+  = case fun of
+      Var f -> not (isPrimOpId f)
+      _     -> True
+  | otherwise
+  = False
+
+dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var)
+dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)
+  | null bndrs    -- Literals, DEFAULT, and nullary constructors
+  , (rhs_ty, rhs') <- dmdAnal env dmd rhs
+  = (rhs_ty, (con, [], rhs'))
+
+  | otherwise     -- Non-nullary data constructors
+  , (rhs_ty, rhs') <- dmdAnal env dmd rhs
+  , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs
+  , let case_bndr_dmd = findIdDemand alt_ty case_bndr
+        id_dmds       = addCaseBndrDmd case_bndr_dmd dmds
+  = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs'))
+
+
+{- Note [IO hack in the demand analyser]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There's a hack here for I/O operations.  Consider
+
+     case foo x s of { (# s', r #) -> y }
+
+Is this strict in 'y'? Often not! If foo x s performs some observable action
+(including raising an exception with raiseIO#, modifying a mutable variable, or
+even ending the program normally), then we must not force 'y' (which may fail
+to terminate) until we have performed foo x s.
+
+Hackish solution: spot the IO-like situation and add a virtual branch,
+as if we had
+     case foo x s of
+        (# s, r #) -> y
+        other      -> return ()
+So the 'y' isn't necessarily going to be evaluated
+
+A more complete example (Trac #148, #1592) where this shows up is:
+     do { let len = <expensive> ;
+        ; when (...) (exitWith ExitSuccess)
+        ; print len }
+
+However, consider
+  f x s = case getMaskingState# s of
+            (# s, r #) ->
+          case x of I# x2 -> ...
+
+Here it is terribly sad to make 'f' lazy in 's'.  After all,
+getMaskingState# is not going to diverge or throw an exception!  This
+situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle
+(on an MVar not an Int), and made a material difference.
+
+So if the scrutinee is a primop call, we *don't* apply the
+state hack:
+  - If it is a simple, terminating one like getMaskingState,
+    applying the hack is over-conservative.
+  - If the primop is raise# then it returns bottom, so
+    the case alternatives are already discarded.
+  - If the primop can raise a non-IO exception, like
+    divide by zero or seg-fault (eg writing an array
+    out of bounds) then we don't mind evaluating 'x' first.
+
+Note [Demand on the scrutinee of a product case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When figuring out the demand on the scrutinee of a product case,
+we use the demands of the case alternative, i.e. id_dmds.
+But note that these include the demand on the case binder;
+see Note [Demand on case-alternative binders] in Demand.hs.
+This is crucial. Example:
+   f x = case x of y { (a,b) -> k y a }
+If we just take scrut_demand = U(L,A), then we won't pass x to the
+worker, so the worker will rebuild
+     x = (a, absent-error)
+and that'll crash.
+
+Note [Aggregated demand for cardinality]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We use different strategies for strictness and usage/cardinality to
+"unleash" demands captured on free variables by bindings. Let us
+consider the example:
+
+f1 y = let {-# NOINLINE h #-}
+           h = y
+       in  (h, h)
+
+We are interested in obtaining cardinality demand U1 on |y|, as it is
+used only in a thunk, and, therefore, is not going to be updated any
+more. Therefore, the demand on |y|, captured and unleashed by usage of
+|h| is U1. However, if we unleash this demand every time |h| is used,
+and then sum up the effects, the ultimate demand on |y| will be U1 +
+U1 = U. In order to avoid it, we *first* collect the aggregate demand
+on |h| in the body of let-expression, and only then apply the demand
+transformer:
+
+transf[x](U) = {y |-> U1}
+
+so the resulting demand on |y| is U1.
+
+The situation is, however, different for strictness, where this
+aggregating approach exhibits worse results because of the nature of
+|both| operation for strictness. Consider the example:
+
+f y c =
+  let h x = y |seq| x
+   in case of
+        True  -> h True
+        False -> y
+
+It is clear that |f| is strict in |y|, however, the suggested analysis
+will infer from the body of |let| that |h| is used lazily (as it is
+used in one branch only), therefore lazy demand will be put on its
+free variable |y|. Conversely, if the demand on |h| is unleashed right
+on the spot, we will get the desired result, namely, that |f| is
+strict in |y|.
+
+
+************************************************************************
+*                                                                      *
+                    Demand transformer
+*                                                                      *
+************************************************************************
+-}
+
+dmdTransform :: AnalEnv         -- The strictness environment
+             -> Id              -- The function
+             -> CleanDemand     -- The demand on the function
+             -> DmdType         -- The demand type of the function in this context
+        -- Returned DmdEnv includes the demand on
+        -- this function plus demand on its free variables
+
+dmdTransform env var dmd
+  | isDataConWorkId var                          -- Data constructor
+  = dmdTransformDataConSig (idArity var) (idStrictness var) dmd
+
+  | gopt Opt_DmdTxDictSel (ae_dflags env),
+    Just _ <- isClassOpId_maybe var -- Dictionary component selector
+  = dmdTransformDictSelSig (idStrictness var) dmd
+
+  | isGlobalId var                               -- Imported function
+  = let res = dmdTransformSig (idStrictness var) dmd in
+--    pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])
+    res
+
+  | Just (sig, top_lvl) <- lookupSigEnv env var  -- Local letrec bound thing
+  , let fn_ty = dmdTransformSig sig dmd
+  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
+    if isTopLevel top_lvl
+    then fn_ty   -- Don't record top level things
+    else addVarDmd fn_ty var (mkOnceUsedDmd dmd)
+
+  | otherwise                                    -- Local non-letrec-bound thing
+  = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Bindings}
+*                                                                      *
+************************************************************************
+-}
+
+-- Recursive bindings
+dmdFix :: TopLevelFlag
+       -> AnalEnv                            -- Does not include bindings for this binding
+       -> CleanDemand
+       -> [(Id,CoreExpr)]
+       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info
+
+dmdFix top_lvl env let_dmd orig_pairs
+  = loop 1 initial_pairs
+  where
+    bndrs = map fst orig_pairs
+
+    -- See Note [Initialising strictness]
+    initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]
+                  | otherwise     = orig_pairs
+
+    -- If fixed-point iteration does not yield a result we use this instead
+    -- See Note [Safe abortion in the fixed-point iteration]
+    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])
+    abort = (env, lazy_fv', zapped_pairs)
+      where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)
+            -- Note [Lazy and unleashable free variables]
+            non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'
+            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs
+            zapped_pairs = zapIdStrictness pairs'
+
+    -- The fixed-point varies the idStrictness field of the binders, and terminates if that
+    -- annotation does not change any more.
+    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
+    loop n pairs
+      | found_fixpoint = (final_anal_env, lazy_fv, pairs')
+      | n == 10        = abort
+      | otherwise      = loop (n+1) pairs'
+      where
+        found_fixpoint    = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs
+        first_round       = n == 1
+        (lazy_fv, pairs') = step first_round pairs
+        final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')
+
+    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])
+    step first_round pairs = (lazy_fv, pairs')
+      where
+        -- In all but the first iteration, delete the virgin flag
+        start_env | first_round = env
+                  | otherwise   = nonVirgin env
+
+        start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)
+
+        ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs
+                -- mapAccumL: Use the new signature to do the next pair
+                -- The occurrence analyser has arranged them in a good order
+                -- so this can significantly reduce the number of iterations needed
+
+        my_downRhs (env, lazy_fv) (id,rhs)
+          = ((env', lazy_fv'), (id', rhs'))
+          where
+            (lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env let_dmd id rhs
+            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1
+            env'                  = extendAnalEnv top_lvl env id (idStrictness id')
+
+
+    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
+    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]
+
+{-
+Note [Safe abortion in the fixed-point iteration]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Fixed-point iteration may fail to terminate. But we cannot simply give up and
+return the environment and code unchanged! We still need to do one additional
+round, for two reasons:
+
+ * To get information on used free variables (both lazy and strict!)
+   (see Note [Lazy and unleashable free variables])
+ * To ensure that all expressions have been traversed at least once, and any left-over
+   strictness annotations have been updated.
+
+This final iteration does not add the variables to the strictness signature
+environment, which effectively assigns them 'nopSig' (see "getStrictness")
+
+-}
+
+-- Trivial RHS
+-- See Note [Demand analysis for trivial right-hand sides]
+dmdAnalTrivialRhs ::
+    AnalEnv -> Id -> CoreExpr -> Var ->
+    (DmdEnv, Id, CoreExpr)
+dmdAnalTrivialRhs env id rhs fn
+  = (fn_fv, set_idStrictness env id fn_str, rhs)
+  where
+    fn_str = getStrictness env fn
+    fn_fv | isLocalId fn = unitVarEnv fn topDmd
+          | otherwise    = emptyDmdEnv
+    -- Note [Remember to demand the function itself]
+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    -- fn_fv: don't forget to produce a demand for fn itself
+    -- Lacking this caused Trac #9128
+    -- The demand is very conservative (topDmd), but that doesn't
+    -- matter; trivial bindings are usually inlined, so it only
+    -- kicks in for top-level bindings and NOINLINE bindings
+
+-- Let bindings can be processed in two ways:
+-- Down (RHS before body) or Up (body before RHS).
+-- dmdAnalRhsLetDown implements the Down variant:
+--  * assuming a demand of <L,U>
+--  * looking at the definition
+--  * determining a strictness signature
+--
+-- It is used for toplevel definition, recursive definitions and local
+-- non-recursive definitions that have manifest lambdas.
+-- Local non-recursive definitions without a lambda are handled with LetUp.
+--
+-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.
+dmdAnalRhsLetDown :: TopLevelFlag
+           -> Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive
+           -> AnalEnv -> CleanDemand
+           -> Id -> CoreExpr
+           -> (DmdEnv, Id, CoreExpr)
+-- Process the RHS of the binding, add the strictness signature
+-- to the Id, and augment the environment with the signature as well.
+dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs
+  | Just fn <- unpackTrivial rhs   -- See Note [Demand analysis for trivial right-hand sides]
+  = dmdAnalTrivialRhs env id rhs fn
+
+  | otherwise
+  = (lazy_fv, id', mkLams bndrs' body')
+  where
+    (bndrs, body, body_dmd)
+       = case isJoinId_maybe id of
+           Just join_arity  -- See Note [Demand analysis for join points]
+                   | (bndrs, body) <- collectNBinders join_arity rhs
+                   -> (bndrs, body, let_dmd)
+
+           Nothing | (bndrs, body) <- collectBinders rhs
+                   -> (bndrs, body, mkBodyDmd env body)
+
+    env_body         = foldl' extendSigsWithLam env bndrs
+    (body_ty, body') = dmdAnal env_body body_dmd body
+    body_ty'         = removeDmdTyArgs body_ty -- zap possible deep CPR info
+    (DmdType rhs_fv rhs_dmds rhs_res, bndrs')
+                     = annotateLamBndrs env (isDFunId id) body_ty' bndrs
+    sig_ty           = mkStrictSig (mkDmdType sig_fv rhs_dmds rhs_res')
+    id'              = set_idStrictness env id sig_ty
+        -- See Note [NOINLINE and strictness]
+
+
+    -- See Note [Aggregated demand for cardinality]
+    rhs_fv1 = case rec_flag of
+                Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
+                Nothing -> rhs_fv
+
+    -- See Note [Lazy and unleashable free variables]
+    (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1
+
+    rhs_res'  = trimCPRInfo trim_all trim_sums rhs_res
+    trim_all  = is_thunk && not_strict
+    trim_sums = not (isTopLevel top_lvl) -- See Note [CPR for sum types]
+
+    -- See Note [CPR for thunks]
+    is_thunk = not (exprIsHNF rhs) && not (isJoinId id)
+    not_strict
+       =  isTopLevel top_lvl  -- Top level and recursive things don't
+       || isJust rec_flag     -- get their demandInfo set at all
+       || not (isStrictDmd (idDemandInfo id) || ae_virgin env)
+          -- See Note [Optimistic CPR in the "virgin" case]
+
+mkBodyDmd :: AnalEnv -> CoreExpr -> CleanDemand
+-- See Note [Product demands for function body]
+mkBodyDmd env body
+  = case deepSplitProductType_maybe (ae_fam_envs env) (exprType body) of
+       Nothing            -> cleanEvalDmd
+       Just (dc, _, _, _) -> cleanEvalProdDmd (dataConRepArity dc)
+
+unpackTrivial :: CoreExpr -> Maybe Id
+-- Returns (Just v) if the arg is really equal to v, modulo
+-- casts, type applications etc
+-- See Note [Demand analysis for trivial right-hand sides]
+unpackTrivial (Var v)                 = Just v
+unpackTrivial (Cast e _)              = unpackTrivial e
+unpackTrivial (Lam v e) | isTyVar v   = unpackTrivial e
+unpackTrivial (App e a) | isTypeArg a = unpackTrivial e
+unpackTrivial _                       = Nothing
+
+-- | If given the RHS of a let-binding, this 'useLetUp' determines
+-- whether we should process the binding up (body before rhs) or
+-- down (rhs before body).
+--
+-- We use LetDown if there is a chance to get a useful strictness signature.
+-- This is the case when there are manifest value lambdas or the binding is a
+-- join point (hence always acts like a function, not a value).
+useLetUp :: Var -> CoreExpr -> Bool
+useLetUp f _         | isJoinId f = False
+useLetUp f (Lam v e) | isTyVar v  = useLetUp f e
+useLetUp _ (Lam _ _)              = False
+useLetUp _ _                      = True
+
+
+{- Note [Demand analysis for join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   g :: (Int,Int) -> Int
+   g (p,q) = p+q
+
+   f :: T -> Int -> Int
+   f x p = g (join j y = (p,y)
+              in case x of
+                   A -> j 3
+                   B -> j 4
+                   C -> (p,7))
+
+If j was a vanilla function definition, we'd analyse its body with
+evalDmd, and think that it was lazy in p.  But for join points we can
+do better!  We know that j's body will (if called at all) be evaluated
+with the demand that consumes the entire join-binding, in this case
+the argument demand from g.  Whizzo!  g evaluates both components of
+its argument pair, so p will certainly be evaluated if j is called.
+
+For f to be strict in p, we need /all/ paths to evaluate p; in this
+case the C branch does so too, so we are fine.  So, as usual, we need
+to transport demands on free variables to the call site(s).  Compare
+Note [Lazy and unleashable free variables].
+
+The implementation is easy.  When analysing a join point, we can
+analyse its body with the demand from the entire join-binding (written
+let_dmd here).
+
+Another win for join points!  Trac #13543.
+
+Note [Demand analysis for trivial right-hand sides]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+        foo = plusInt |> co
+where plusInt is an arity-2 function with known strictness.  Clearly
+we want plusInt's strictness to propagate to foo!  But because it has
+no manifest lambdas, it won't do so automatically, and indeed 'co' might
+have type (Int->Int->Int) ~ T, so we *can't* eta-expand.  So we have a
+special case for right-hand sides that are "trivial", namely variables,
+casts, type applications, and the like.
+
+Note that this can mean that 'foo' has an arity that is smaller than that
+indicated by its demand info.  e.g. if co :: (Int->Int->Int) ~ T, then
+foo's arity will be zero (see Note [exprArity invariant] in CoreArity),
+but its demand signature will be that of plusInt. A small example is the
+test case of Trac #8963.
+
+
+Note [Product demands for function body]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This example comes from shootout/binary_trees:
+
+    Main.check' = \ b z ds. case z of z' { I# ip ->
+                                case ds_d13s of
+                                  Main.Nil -> z'
+                                  Main.Node s14k s14l s14m ->
+                                    Main.check' (not b)
+                                      (Main.check' b
+                                         (case b {
+                                            False -> I# (-# s14h s14k);
+                                            True  -> I# (+# s14h s14k)
+                                          })
+                                         s14l)
+                                     s14m   }   }   }
+
+Here we *really* want to unbox z, even though it appears to be used boxed in
+the Nil case.  Partly the Nil case is not a hot path.  But more specifically,
+the whole function gets the CPR property if we do.
+
+So for the demand on the body of a RHS we use a product demand if it's
+a product type.
+
+************************************************************************
+*                                                                      *
+\subsection{Strictness signatures and types}
+*                                                                      *
+************************************************************************
+-}
+
+unitDmdType :: DmdEnv -> DmdType
+unitDmdType dmd_env = DmdType dmd_env [] topRes
+
+coercionDmdEnv :: Coercion -> DmdEnv
+coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)
+                    -- The VarSet from coVarsOfCo is really a VarEnv Var
+
+addVarDmd :: DmdType -> Var -> Demand -> DmdType
+addVarDmd (DmdType fv ds res) var dmd
+  = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res
+
+addLazyFVs :: DmdType -> DmdEnv -> DmdType
+addLazyFVs dmd_ty lazy_fvs
+  = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs
+        -- Using bothDmdType (rather than just both'ing the envs)
+        -- is vital.  Consider
+        --      let f = \x -> (x,y)
+        --      in  error (f 3)
+        -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L
+        -- demand with the bottom coming up from 'error'
+        --
+        -- I got a loop in the fixpointer without this, due to an interaction
+        -- with the lazy_fv filtering in dmdAnalRhsLetDown.  Roughly, it was
+        --      letrec f n x
+        --          = letrec g y = x `fatbar`
+        --                         letrec h z = z + ...g...
+        --                         in h (f (n-1) x)
+        --      in ...
+        -- In the initial iteration for f, f=Bot
+        -- Suppose h is found to be strict in z, but the occurrence of g in its RHS
+        -- is lazy.  Now consider the fixpoint iteration for g, esp the demands it
+        -- places on its free variables.  Suppose it places none.  Then the
+        --      x `fatbar` ...call to h...
+        -- will give a x->V demand for x.  That turns into a L demand for x,
+        -- which floats out of the defn for h.  Without the modifyEnv, that
+        -- L demand doesn't get both'd with the Bot coming up from the inner
+        -- call to f.  So we just get an L demand for x for g.
+
+{-
+Note [Do not strictify the argument dictionaries of a dfun]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The typechecker can tie recursive knots involving dfuns, so we do the
+conservative thing and refrain from strictifying a dfun's argument
+dictionaries.
+-}
+
+setBndrsDemandInfo :: [Var] -> [Demand] -> [Var]
+setBndrsDemandInfo (b:bs) (d:ds)
+  | isTyVar b = b : setBndrsDemandInfo bs (d:ds)
+  | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds
+setBndrsDemandInfo [] ds = ASSERT( null ds ) []
+setBndrsDemandInfo bs _  = pprPanic "setBndrsDemandInfo" (ppr bs)
+
+annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)
+-- The returned env has the var deleted
+-- The returned var is annotated with demand info
+-- according to the result demand of the provided demand type
+-- No effect on the argument demands
+annotateBndr env dmd_ty var
+  | isId var  = (dmd_ty', setIdDemandInfo var dmd)
+  | otherwise = (dmd_ty, var)
+  where
+    (dmd_ty', dmd) = findBndrDmd env False dmd_ty var
+
+annotateLamBndrs :: AnalEnv -> DFunFlag -> DmdType -> [Var] -> (DmdType, [Var])
+annotateLamBndrs env args_of_dfun ty bndrs = mapAccumR annotate ty bndrs
+  where
+    annotate dmd_ty bndr
+      | isId bndr = annotateLamIdBndr env args_of_dfun dmd_ty bndr
+      | otherwise = (dmd_ty, bndr)
+
+annotateLamIdBndr :: AnalEnv
+                  -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?
+                  -> DmdType    -- Demand type of body
+                  -> Id         -- Lambda binder
+                  -> (DmdType,  -- Demand type of lambda
+                      Id)       -- and binder annotated with demand
+
+annotateLamIdBndr env arg_of_dfun dmd_ty id
+-- For lambdas we add the demand to the argument demands
+-- Only called for Ids
+  = ASSERT( isId id )
+    -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $
+    (final_ty, setIdDemandInfo id dmd)
+  where
+      -- Watch out!  See note [Lambda-bound unfoldings]
+    final_ty = case maybeUnfoldingTemplate (idUnfolding id) of
+                 Nothing  -> main_ty
+                 Just unf -> main_ty `bothDmdType` unf_ty
+                          where
+                             (unf_ty, _) = dmdAnalStar env dmd unf
+
+    main_ty = addDemand dmd dmd_ty'
+    (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id
+
+deleteFVs :: DmdType -> [Var] -> DmdType
+deleteFVs (DmdType fvs dmds res) bndrs
+  = DmdType (delVarEnvList fvs bndrs) dmds res
+
+{-
+Note [CPR for sum types]
+~~~~~~~~~~~~~~~~~~~~~~~~
+At the moment we do not do CPR for let-bindings that
+   * non-top level
+   * bind a sum type
+Reason: I found that in some benchmarks we were losing let-no-escapes,
+which messed it all up.  Example
+   let j = \x. ....
+   in case y of
+        True  -> j False
+        False -> j True
+If we w/w this we get
+   let j' = \x. ....
+   in case y of
+        True  -> case j' False of { (# a #) -> Just a }
+        False -> case j' True of { (# a #) -> Just a }
+Notice that j' is not a let-no-escape any more.
+
+However this means in turn that the *enclosing* function
+may be CPR'd (via the returned Justs).  But in the case of
+sums, there may be Nothing alternatives; and that messes
+up the sum-type CPR.
+
+Conclusion: only do this for products.  It's still not
+guaranteed OK for products, but sums definitely lose sometimes.
+
+Note [CPR for thunks]
+~~~~~~~~~~~~~~~~~~~~~
+If the rhs is a thunk, we usually forget the CPR info, because
+it is presumably shared (else it would have been inlined, and
+so we'd lose sharing if w/w'd it into a function).  E.g.
+
+        let r = case expensive of
+                  (a,b) -> (b,a)
+        in ...
+
+If we marked r as having the CPR property, then we'd w/w into
+
+        let $wr = \() -> case expensive of
+                            (a,b) -> (# b, a #)
+            r = case $wr () of
+                  (# b,a #) -> (b,a)
+        in ...
+
+But now r is a thunk, which won't be inlined, so we are no further ahead.
+But consider
+
+        f x = let r = case expensive of (a,b) -> (b,a)
+              in if foo r then r else (x,x)
+
+Does f have the CPR property?  Well, no.
+
+However, if the strictness analyser has figured out (in a previous
+iteration) that it's strict, then we DON'T need to forget the CPR info.
+Instead we can retain the CPR info and do the thunk-splitting transform
+(see WorkWrap.splitThunk).
+
+This made a big difference to PrelBase.modInt, which had something like
+        modInt = \ x -> let r = ... -> I# v in
+                        ...body strict in r...
+r's RHS isn't a value yet; but modInt returns r in various branches, so
+if r doesn't have the CPR property then neither does modInt
+Another case I found in practice (in Complex.magnitude), looks like this:
+                let k = if ... then I# a else I# b
+                in ... body strict in k ....
+(For this example, it doesn't matter whether k is returned as part of
+the overall result; but it does matter that k's RHS has the CPR property.)
+Left to itself, the simplifier will make a join point thus:
+                let $j k = ...body strict in k...
+                if ... then $j (I# a) else $j (I# b)
+With thunk-splitting, we get instead
+                let $j x = let k = I#x in ...body strict in k...
+                in if ... then $j a else $j b
+This is much better; there's a good chance the I# won't get allocated.
+
+The difficulty with this is that we need the strictness type to
+look at the body... but we now need the body to calculate the demand
+on the variable, so we can decide whether its strictness type should
+have a CPR in it or not.  Simple solution:
+        a) use strictness info from the previous iteration
+        b) make sure we do at least 2 iterations, by doing a second
+           round for top-level non-recs.  Top level recs will get at
+           least 2 iterations except for totally-bottom functions
+           which aren't very interesting anyway.
+
+NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.
+
+Note [Optimistic CPR in the "virgin" case]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Demand and strictness info are initialized by top elements. However,
+this prevents from inferring a CPR property in the first pass of the
+analyser, so we keep an explicit flag ae_virgin in the AnalEnv
+datatype.
+
+We can't start with 'not-demanded' (i.e., top) because then consider
+        f x = let
+                  t = ... I# x
+              in
+              if ... then t else I# y else f x'
+
+In the first iteration we'd have no demand info for x, so assume
+not-demanded; then we'd get TopRes for f's CPR info.  Next iteration
+we'd see that t was demanded, and so give it the CPR property, but by
+now f has TopRes, so it will stay TopRes.  Instead, by checking the
+ae_virgin flag at the first time round, we say 'yes t is demanded' the
+first time.
+
+However, this does mean that for non-recursive bindings we must
+iterate twice to be sure of not getting over-optimistic CPR info,
+in the case where t turns out to be not-demanded.  This is handled
+by dmdAnalTopBind.
+
+
+Note [NOINLINE and strictness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The strictness analyser used to have a HACK which ensured that NOINLNE
+things were not strictness-analysed.  The reason was unsafePerformIO.
+Left to itself, the strictness analyser would discover this strictness
+for unsafePerformIO:
+        unsafePerformIO:  C(U(AV))
+But then consider this sub-expression
+        unsafePerformIO (\s -> let r = f x in
+                               case writeIORef v r s of (# s1, _ #) ->
+                               (# s1, r #)
+The strictness analyser will now find that r is sure to be eval'd,
+and may then hoist it out.  This makes tests/lib/should_run/memo002
+deadlock.
+
+Solving this by making all NOINLINE things have no strictness info is overkill.
+In particular, it's overkill for runST, which is perfectly respectable.
+Consider
+        f x = runST (return x)
+This should be strict in x.
+
+So the new plan is to define unsafePerformIO using the 'lazy' combinator:
+
+        unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)
+
+Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is
+magically NON-STRICT, and is inlined after strictness analysis.  So
+unsafePerformIO will look non-strict, and that's what we want.
+
+Now we don't need the hack in the strictness analyser.  HOWEVER, this
+decision does mean that even a NOINLINE function is not entirely
+opaque: some aspect of its implementation leaks out, notably its
+strictness.  For example, if you have a function implemented by an
+error stub, but which has RULES, you may want it not to be eliminated
+in favour of error!
+
+Note [Lazy and unleashable free variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We put the strict and once-used FVs in the DmdType of the Id, so
+that at its call sites we unleash demands on its strict fvs.
+An example is 'roll' in imaginary/wheel-sieve2
+Something like this:
+        roll x = letrec
+                     go y = if ... then roll (x-1) else x+1
+                 in
+                 go ms
+We want to see that roll is strict in x, which is because
+go is called.   So we put the DmdEnv for x in go's DmdType.
+
+Another example:
+
+        f :: Int -> Int -> Int
+        f x y = let t = x+1
+            h z = if z==0 then t else
+                  if z==1 then x+1 else
+                  x + h (z-1)
+        in h y
+
+Calling h does indeed evaluate x, but we can only see
+that if we unleash a demand on x at the call site for t.
+
+Incidentally, here's a place where lambda-lifting h would
+lose the cigar --- we couldn't see the joint strictness in t/x
+
+        ON THE OTHER HAND
+
+We don't want to put *all* the fv's from the RHS into the
+DmdType. Because
+
+ * it makes the strictness signatures larger, and hence slows down fixpointing
+
+and
+
+ * it is useless information at the call site anyways:
+   For lazy, used-many times fv's we will never get any better result than
+   that, no matter how good the actual demand on the function at the call site
+   is (unless it is always absent, but then the whole binder is useless).
+
+Therefore we exclude lazy multiple-used fv's from the environment in the
+DmdType.
+
+But now the signature lies! (Missing variables are assumed to be absent.) To
+make up for this, the code that analyses the binding keeps the demand on those
+variable separate (usually called "lazy_fv") and adds it to the demand of the
+whole binding later.
+
+What if we decide _not_ to store a strictness signature for a binding at all, as
+we do when aborting a fixed-point iteration? The we risk losing the information
+that the strict variables are being used. In that case, we take all free variables
+mentioned in the (unsound) strictness signature, conservatively approximate the
+demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".
+
+
+Note [Lambda-bound unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We allow a lambda-bound variable to carry an unfolding, a facility that is used
+exclusively for join points; see Note [Case binders and join points].  If so,
+we must be careful to demand-analyse the RHS of the unfolding!  Example
+   \x. \y{=Just x}. <body>
+Then if <body> uses 'y', then transitively it uses 'x', and we must not
+forget that fact, otherwise we might make 'x' absent when it isn't.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Strictness signatures}
+*                                                                      *
+************************************************************************
+-}
+
+type DFunFlag = Bool  -- indicates if the lambda being considered is in the
+                      -- sequence of lambdas at the top of the RHS of a dfun
+notArgOfDfun :: DFunFlag
+notArgOfDfun = False
+
+data AnalEnv
+  = AE { ae_dflags :: DynFlags
+       , ae_sigs   :: SigEnv
+       , ae_virgin :: Bool    -- True on first iteration only
+                              -- See Note [Initialising strictness]
+       , ae_rec_tc :: RecTcChecker
+       , ae_fam_envs :: FamInstEnvs
+ }
+
+        -- We use the se_env to tell us whether to
+        -- record info about a variable in the DmdEnv
+        -- We do so if it's a LocalId, but not top-level
+        --
+        -- The DmdEnv gives the demand on the free vars of the function
+        -- when it is given enough args to satisfy the strictness signature
+
+type SigEnv = VarEnv (StrictSig, TopLevelFlag)
+
+instance Outputable AnalEnv where
+  ppr (AE { ae_sigs = env, ae_virgin = virgin })
+    = text "AE" <+> braces (vcat
+         [ text "ae_virgin =" <+> ppr virgin
+         , text "ae_sigs =" <+> ppr env ])
+
+emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv
+emptyAnalEnv dflags fam_envs
+    = AE { ae_dflags = dflags
+         , ae_sigs = emptySigEnv
+         , ae_virgin = True
+         , ae_rec_tc = initRecTc
+         , ae_fam_envs = fam_envs
+         }
+
+emptySigEnv :: SigEnv
+emptySigEnv = emptyVarEnv
+
+-- | Extend an environment with the strictness IDs attached to the id
+extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv
+extendAnalEnvs top_lvl env vars
+  = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }
+
+extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv
+extendSigEnvs top_lvl sigs vars
+  = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars]
+
+extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv
+extendAnalEnv top_lvl env var sig
+  = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig }
+
+extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv
+extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)
+
+lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)
+lookupSigEnv env id = lookupVarEnv (ae_sigs env) id
+
+getStrictness :: AnalEnv -> Id -> StrictSig
+getStrictness env fn
+  | isGlobalId fn                        = idStrictness fn
+  | Just (sig, _) <- lookupSigEnv env fn = sig
+  | otherwise                            = nopSig
+
+nonVirgin :: AnalEnv -> AnalEnv
+nonVirgin env = env { ae_virgin = False }
+
+extendSigsWithLam :: AnalEnv -> Id -> AnalEnv
+-- Extend the AnalEnv when we meet a lambda binder
+extendSigsWithLam env id
+  | isId id
+  , isStrictDmd (idDemandInfo id) || ae_virgin env
+       -- See Note [Optimistic CPR in the "virgin" case]
+       -- See Note [Initial CPR for strict binders]
+  , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id
+  = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))
+
+  | otherwise
+  = env
+
+extendEnvForProdAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv
+-- See Note [CPR in a product case alternative]
+extendEnvForProdAlt env scrut case_bndr dc bndrs
+  = foldl' do_con_arg env1 ids_w_strs
+  where
+    env1 = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig
+
+    ids_w_strs    = filter isId bndrs `zip` dataConRepStrictness dc
+    case_bndr_sig = cprProdSig (dataConRepArity dc)
+    fam_envs      = ae_fam_envs env
+
+    do_con_arg env (id, str)
+       | let is_strict = isStrictDmd (idDemandInfo id) || isMarkedStrict str
+       , ae_virgin env || (is_var_scrut && is_strict)  -- See Note [CPR in a product case alternative]
+       , Just (dc,_,_,_) <- deepSplitProductType_maybe fam_envs $ idType id
+       = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))
+       | otherwise
+       = env
+
+    is_var_scrut = is_var scrut
+    is_var (Cast e _) = is_var e
+    is_var (Var v)    = isLocalId v
+    is_var _          = False
+
+findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand])
+-- Return the demands on the Ids in the [Var]
+findBndrsDmds env dmd_ty bndrs
+  = go dmd_ty bndrs
+  where
+    go dmd_ty []  = (dmd_ty, [])
+    go dmd_ty (b:bs)
+      | isId b    = let (dmd_ty1, dmds) = go dmd_ty bs
+                        (dmd_ty2, dmd)  = findBndrDmd env False dmd_ty1 b
+                    in (dmd_ty2, dmd : dmds)
+      | otherwise = go dmd_ty bs
+
+findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)
+-- See Note [Trimming a demand to a type] in Demand.hs
+findBndrDmd env arg_of_dfun dmd_ty id
+  = (dmd_ty', dmd')
+  where
+    dmd' = killUsageDemand (ae_dflags env) $
+           strictify $
+           trimToType starting_dmd (findTypeShape fam_envs id_ty)
+
+    (dmd_ty', starting_dmd) = peelFV dmd_ty id
+
+    id_ty = idType id
+
+    strictify dmd
+      | gopt Opt_DictsStrict (ae_dflags env)
+             -- We never want to strictify a recursive let. At the moment
+             -- annotateBndr is only call for non-recursive lets; if that
+             -- changes, we need a RecFlag parameter and another guard here.
+      , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun]
+      = strictifyDictDmd id_ty dmd
+      | otherwise
+      = dmd
+
+    fam_envs = ae_fam_envs env
+
+set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id
+set_idStrictness env id sig
+  = setIdStrictness id (killUsageSig (ae_dflags env) sig)
+
+dumpStrSig :: CoreProgram -> SDoc
+dumpStrSig binds = vcat (map printId ids)
+  where
+  ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)
+  getIds (NonRec i _) = [ i ]
+  getIds (Rec bs)     = map fst bs
+  printId id | isExportedId id = ppr id <> colon <+> pprIfaceStrictSig (idStrictness id)
+             | otherwise       = empty
+
+{- Note [CPR in a product case alternative]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a case alternative for a product type, we want to give some of the
+binders the CPR property.  Specifically
+
+ * The case binder; inside the alternative, the case binder always has
+   the CPR property, meaning that a case on it will successfully cancel.
+   Example:
+        f True  x = case x of y { I# x' -> if x' ==# 3
+                                           then y
+                                           else I# 8 }
+        f False x = I# 3
+
+   By giving 'y' the CPR property, we ensure that 'f' does too, so we get
+        f b x = case fw b x of { r -> I# r }
+        fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }
+        fw False x = 3
+
+   Of course there is the usual risk of re-boxing: we have 'x' available
+   boxed and unboxed, but we return the unboxed version for the wrapper to
+   box.  If the wrapper doesn't cancel with its caller, we'll end up
+   re-boxing something that we did have available in boxed form.
+
+ * Any strict binders with product type, can use
+   Note [Initial CPR for strict binders].  But we can go a little
+   further. Consider
+
+      data T = MkT !Int Int
+
+      f2 (MkT x y) | y>0       = f2 (MkT x (y-1))
+                   | otherwise = x
+
+   For $wf2 we are going to unbox the MkT *and*, since it is strict, the
+   first argument of the MkT; see Note [Add demands for strict constructors]
+   in WwLib. But then we don't want box it up again when returning it! We want
+   'f2' to have the CPR property, so we give 'x' the CPR property.
+
+ * It's a bit delicate because if this case is scrutinising something other
+   than an argument the original function, we really don't have the unboxed
+   version available.  E.g
+      g v = case foo v of
+              MkT x y | y>0       -> ...
+                      | otherwise -> x
+   Here we don't have the unboxed 'x' available.  Hence the
+   is_var_scrut test when making use of the strictness annotation.
+   Slightly ad-hoc, because even if the scrutinee *is* a variable it
+   might not be a onre of the arguments to the original function, or a
+   sub-component thereof.  But it's simple, and nothing terrible
+   happens if we get it wrong.  e.g. Trac #10694.
+
+
+Note [Initial CPR for strict binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+CPR is initialized for a lambda binder in an optimistic manner, i.e,
+if the binder is used strictly and at least some of its components as
+a product are used, which is checked by the value of the absence
+demand.
+
+If the binder is marked demanded with a strict demand, then give it a
+CPR signature. Here's a concrete example ('f1' in test T10482a),
+assuming h is strict:
+
+  f1 :: Int -> Int
+  f1 x = case h x of
+          A -> x
+          B -> f1 (x-1)
+          C -> x+1
+
+If we notice that 'x' is used strictly, we can give it the CPR
+property; and hence f1 gets the CPR property too.  It's sound (doesn't
+change strictness) to give it the CPR property because by the time 'x'
+is returned (case A above), it'll have been evaluated (by the wrapper
+of 'h' in the example).
+
+Moreover, if f itself is strict in x, then we'll pass x unboxed to
+f1, and so the boxed version *won't* be available; in that case it's
+very helpful to give 'x' the CPR property.
+
+Note that
+
+  * We only want to do this for something that definitely
+    has product type, else we may get over-optimistic CPR results
+    (e.g. from \x -> x!).
+
+  * See Note [CPR examples]
+
+Note [CPR examples]
+~~~~~~~~~~~~~~~~~~~~
+Here are some examples (stranal/should_compile/T10482a) of the
+usefulness of Note [CPR in a product case alternative].  The main
+point: all of these functions can have the CPR property.
+
+    ------- f1 -----------
+    -- x is used strictly by h, so it'll be available
+    -- unboxed before it is returned in the True branch
+
+    f1 :: Int -> Int
+    f1 x = case h x x of
+            True  -> x
+            False -> f1 (x-1)
+
+
+    ------- f2 -----------
+    -- x is a strict field of MkT2, so we'll pass it unboxed
+    -- to $wf2, so it's available unboxed.  This depends on
+    -- the case expression analysing (a subcomponent of) one
+    -- of the original arguments to the function, so it's
+    -- a bit more delicate.
+
+    data T2 = MkT2 !Int Int
+
+    f2 :: T2 -> Int
+    f2 (MkT2 x y) | y>0       = f2 (MkT2 x (y-1))
+                  | otherwise = x
+
+
+    ------- f3 -----------
+    -- h is strict in x, so x will be unboxed before it
+    -- is rerturned in the otherwise case.
+
+    data T3 = MkT3 Int Int
+
+    f1 :: T3 -> Int
+    f1 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))
+                  | otherwise = x
+
+
+    ------- f4 -----------
+    -- Just like f2, but MkT4 can't unbox its strict
+    -- argument automatically, as f2 can
+
+    data family Foo a
+    newtype instance Foo Int = Foo Int
+
+    data T4 a = MkT4 !(Foo a) Int
+
+    f4 :: T4 Int -> Int
+    f4 (MkT4 x@(Foo v) y) | y>0       = f4 (MkT4 x (y-1))
+                          | otherwise = v
+
+
+Note [Initialising strictness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See section 9.2 (Finding fixpoints) of the paper.
+
+Our basic plan is to initialise the strictness of each Id in a
+recursive group to "bottom", and find a fixpoint from there.  However,
+this group B might be inside an *enclosing* recursive group A, in
+which case we'll do the entire fixpoint shebang on for each iteration
+of A. This can be illustrated by the following example:
+
+Example:
+
+  f [] = []
+  f (x:xs) = let g []     = f xs
+                 g (y:ys) = y+1 : g ys
+              in g (h x)
+
+At each iteration of the fixpoint for f, the analyser has to find a
+fixpoint for the enclosed function g. In the meantime, the demand
+values for g at each iteration for f are *greater* than those we
+encountered in the previous iteration for f. Therefore, we can begin
+the fixpoint for g not with the bottom value but rather with the
+result of the previous analysis. I.e., when beginning the fixpoint
+process for g, we can start from the demand signature computed for g
+previously and attached to the binding occurrence of g.
+
+To speed things up, we initialise each iteration of A (the enclosing
+one) from the result of the last one, which is neatly recorded in each
+binder.  That way we make use of earlier iterations of the fixpoint
+algorithm. (Cunning plan.)
+
+But on the *first* iteration we want to *ignore* the current strictness
+of the Id, and start from "bottom".  Nowadays the Id can have a current
+strictness, because interface files record strictness for nested bindings.
+To know when we are in the first iteration, we look at the ae_virgin
+field of the AnalEnv.
+
+
+Note [Final Demand Analyser run]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some of the information that the demand analyser determines is not always
+preserved by the simplifier.  For example, the simplifier will happily rewrite
+  \y [Demand=1*U] let x = y in x + x
+to
+  \y [Demand=1*U] y + y
+which is quite a lie.
+
+The once-used information is (currently) only used by the code
+generator, though.  So:
+
+ * We zap the used-once info in the worker-wrapper;
+   see Note [Zapping Used Once info in WorkWrap] in WorkWrap. If it's
+   not reliable, it's better not to have it at all.
+
+ * Just before TidyCore, we add a pass of the demand analyser,
+      but WITHOUT subsequent worker/wrapper and simplifier,
+   right before TidyCore.  See SimplCore.getCoreToDo.
+
+   This way, correct information finds its way into the module interface
+   (strictness signatures!) and the code generator (single-entry thunks!)
+
+Note that, in contrast, the single-call information (C1(..)) /can/ be
+relied upon, as the simplifier tends to be very careful about not
+duplicating actual function calls.
+
+Also see #11731.
+-}
diff --git a/compiler/stranal/WorkWrap.hs b/compiler/stranal/WorkWrap.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stranal/WorkWrap.hs
@@ -0,0 +1,696 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
+-}
+
+{-# LANGUAGE CPP #-}
+module WorkWrap ( wwTopBinds ) where
+
+import GhcPrelude
+
+import CoreSyn
+import CoreUnfold       ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding )
+import CoreUtils        ( exprType, exprIsHNF )
+import CoreFVs          ( exprFreeVars )
+import Var
+import Id
+import IdInfo
+import Type
+import UniqSupply
+import BasicTypes
+import DynFlags
+import Demand
+import WwLib
+import Util
+import Outputable
+import FamInstEnv
+import MonadUtils
+
+#include "HsVersions.h"
+
+{-
+We take Core bindings whose binders have:
+
+\begin{enumerate}
+
+\item Strictness attached (by the front-end of the strictness
+analyser), and / or
+
+\item Constructed Product Result information attached by the CPR
+analysis pass.
+
+\end{enumerate}
+
+and we return some ``plain'' bindings which have been
+worker/wrapper-ified, meaning:
+
+\begin{enumerate}
+
+\item Functions have been split into workers and wrappers where
+appropriate.  If a function has both strictness and CPR properties
+then only one worker/wrapper doing both transformations is produced;
+
+\item Binders' @IdInfos@ have been updated to reflect the existence of
+these workers/wrappers (this is where we get STRICTNESS and CPR pragma
+info for exported values).
+\end{enumerate}
+-}
+
+wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram
+
+wwTopBinds dflags fam_envs us top_binds
+  = initUs_ us $ do
+    top_binds' <- mapM (wwBind dflags fam_envs) top_binds
+    return (concat top_binds')
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@}
+*                                                                      *
+************************************************************************
+
+@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in
+turn.  Non-recursive case first, then recursive...
+-}
+
+wwBind  :: DynFlags
+        -> FamInstEnvs
+        -> CoreBind
+        -> UniqSM [CoreBind]    -- returns a WwBinding intermediate form;
+                                -- the caller will convert to Expr/Binding,
+                                -- as appropriate.
+
+wwBind dflags fam_envs (NonRec binder rhs) = do
+    new_rhs <- wwExpr dflags fam_envs rhs
+    new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs
+    return [NonRec b e | (b,e) <- new_pairs]
+      -- Generated bindings must be non-recursive
+      -- because the original binding was.
+
+wwBind dflags fam_envs (Rec pairs)
+  = return . Rec <$> concatMapM do_one pairs
+  where
+    do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs
+                              tryWW dflags fam_envs Recursive binder new_rhs
+
+{-
+@wwExpr@ basically just walks the tree, looking for appropriate
+annotations that can be used. Remember it is @wwBind@ that does the
+matching by looking for strict arguments of the correct type.
+@wwExpr@ is a version that just returns the ``Plain'' Tree.
+-}
+
+wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr
+
+wwExpr _      _ e@(Type {}) = return e
+wwExpr _      _ e@(Coercion {}) = return e
+wwExpr _      _ e@(Lit  {}) = return e
+wwExpr _      _ e@(Var  {}) = return e
+
+wwExpr dflags fam_envs (Lam binder expr)
+  = Lam new_binder <$> wwExpr dflags fam_envs expr
+  where new_binder | isId binder = zapIdUsedOnceInfo binder
+                   | otherwise   = binder
+  -- See Note [Zapping Used Once info in WorkWrap]
+
+wwExpr dflags fam_envs (App f a)
+  = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a
+
+wwExpr dflags fam_envs (Tick note expr)
+  = Tick note <$> wwExpr dflags fam_envs expr
+
+wwExpr dflags fam_envs (Cast expr co) = do
+    new_expr <- wwExpr dflags fam_envs expr
+    return (Cast new_expr co)
+
+wwExpr dflags fam_envs (Let bind expr)
+  = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr
+
+wwExpr dflags fam_envs (Case expr binder ty alts) = do
+    new_expr <- wwExpr dflags fam_envs expr
+    new_alts <- mapM ww_alt alts
+    let new_binder = zapIdUsedOnceInfo binder
+      -- See Note [Zapping Used Once info in WorkWrap]
+    return (Case new_expr new_binder ty new_alts)
+  where
+    ww_alt (con, binders, rhs) = do
+        new_rhs <- wwExpr dflags fam_envs rhs
+        let new_binders = [ if isId b then zapIdUsedOnceInfo b else b
+                          | b <- binders ]
+           -- See Note [Zapping Used Once info in WorkWrap]
+        return (con, new_binders, new_rhs)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair}
+*                                                                      *
+************************************************************************
+
+@tryWW@ just accumulates arguments, converts strictness info from the
+front-end into the proper form, then calls @mkWwBodies@ to do
+the business.
+
+The only reason this is monadised is for the unique supply.
+
+Note [Don't w/w INLINE things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's very important to refrain from w/w-ing an INLINE function (ie one
+with a stable unfolding) because the wrapper will then overwrite the
+old stable unfolding with the wrapper code.
+
+Furthermore, if the programmer has marked something as INLINE,
+we may lose by w/w'ing it.
+
+If the strictness analyser is run twice, this test also prevents
+wrappers (which are INLINEd) from being re-done.  (You can end up with
+several liked-named Ids bouncing around at the same time---absolute
+mischief.)
+
+Notice that we refrain from w/w'ing an INLINE function even if it is
+in a recursive group.  It might not be the loop breaker.  (We could
+test for loop-breaker-hood, but I'm not sure that ever matters.)
+
+Note [Worker-wrapper for INLINABLE functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+  {-# INLINABLE f #-}
+  f :: Ord a => [a] -> Int -> a
+  f x y = ....f....
+
+where f is strict in y, we might get a more efficient loop by w/w'ing
+f.  But that would make a new unfolding which would overwrite the old
+one! So the function would no longer be INLNABLE, and in particular
+will not be specialised at call sites in other modules.
+
+This comes in practice (Trac #6056).
+
+Solution: do the w/w for strictness analysis, but transfer the Stable
+unfolding to the *worker*.  So we will get something like this:
+
+  {-# INLINE[0] f #-}
+  f :: Ord a => [a] -> Int -> a
+  f d x y = case y of I# y' -> fw d x y'
+
+  {-# INLINABLE[0] fw #-}
+  fw :: Ord a => [a] -> Int# -> a
+  fw d x y' = let y = I# y' in ...f...
+
+How do we "transfer the unfolding"? Easy: by using the old one, wrapped
+in work_fn! See CoreUnfold.mkWorkerUnfolding.
+
+Note [Worker-wrapper for NOINLINE functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used to disable worker/wrapper for NOINLINE things, but it turns out
+this can cause unnecessary reboxing of values. Consider
+
+  {-# NOINLINE f #-}
+  f :: Int -> a
+  f x = error (show x)
+
+  g :: Bool -> Bool -> Int -> Int
+  g True  True  p = f p
+  g False True  p = p + 1
+  g b     False p = g b True p
+
+the strictness analysis will discover f and g are strict, but because f
+has no wrapper, the worker for g will rebox p. So we get
+
+  $wg x y p# =
+    let p = I# p# in  -- Yikes! Reboxing!
+    case x of
+      False ->
+        case y of
+          False -> $wg False True p#
+          True -> +# p# 1#
+      True ->
+        case y of
+          False -> $wg True True p#
+          True -> case f p of { }
+
+  g x y p = case p of (I# p#) -> $wg x y p#
+
+Now, in this case the reboxing will float into the True branch, and so
+the allocation will only happen on the error path. But it won't float
+inwards if there are multiple branches that call (f p), so the reboxing
+will happen on every call of g. Disaster.
+
+Solution: do worker/wrapper even on NOINLINE things; but move the
+NOINLINE pragma to the worker.
+
+(See Trac #13143 for a real-world example.)
+
+Note [Worker activation]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Follows on from Note [Worker-wrapper for INLINABLE functions]
+
+It is *vital* that if the worker gets an INLINABLE pragma (from the
+original function), then the worker has the same phase activation as
+the wrapper (or later).  That is necessary to allow the wrapper to
+inline into the worker's unfolding: see SimplUtils
+Note [Simplifying inside stable unfoldings].
+
+If the original is NOINLINE, it's important that the work inherit the
+original activation. Consider
+
+  {-# NOINLINE expensive #-}
+  expensive x = x + 1
+
+  f y = let z = expensive y in ...
+
+If expensive's worker inherits the wrapper's activation,
+we'll get this (because of the compromise in point (2) of
+Note [Wrapper activation])
+
+  {-# NOINLINE[0] $wexpensive #-}
+  $wexpensive x = x + 1
+  {-# INLINE[0] expensive #-}
+  expensive x = $wexpensive x
+
+  f y = let z = expensive y in ...
+
+and $wexpensive will be immediately inlined into expensive, followed by
+expensive into f. This effectively removes the original NOINLINE!
+
+Otherwise, nothing is lost by giving the worker the same activation as the
+wrapper, because the worker won't have any chance of inlining until the
+wrapper does; there's no point in giving it an earlier activation.
+
+Note [Don't w/w inline small non-loop-breaker things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general, we refrain from w/w-ing *small* functions, which are not
+loop breakers, because they'll inline anyway.  But we must take care:
+it may look small now, but get to be big later after other inlining
+has happened.  So we take the precaution of adding an INLINE pragma to
+any such functions.
+
+I made this change when I observed a big function at the end of
+compilation with a useful strictness signature but no w-w.  (It was
+small during demand analysis, we refrained from w/w, and then got big
+when something was inlined in its rhs.) When I measured it on nofib,
+it didn't make much difference; just a few percent improved allocation
+on one benchmark (bspt/Euclid.space).  But nothing got worse.
+
+There is an infelicity though.  We may get something like
+      f = g val
+==>
+      g x = case gw x of r -> I# r
+
+      f {- InlineStable, Template = g val -}
+      f = case gw x of r -> I# r
+
+The code for f duplicates that for g, without any real benefit. It
+won't really be executed, because calls to f will go via the inlining.
+
+Note [Don't CPR join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+There's no point in doing CPR on a join point. If the whole function is getting
+CPR'd, then the case expression around the worker function will get pushed into
+the join point by the simplifier, which will have the same effect that CPR would
+have - the result will be returned in an unboxed tuple.
+
+  f z = let join j x y = (x+1, y+1)
+        in case z of A -> j 1 2
+                     B -> j 2 3
+
+  =>
+
+  f z = case $wf z of (# a, b #) -> (a, b)
+  $wf z = case (let join j x y = (x+1, y+1)
+                in case z of A -> j 1 2
+                             B -> j 2 3) of (a, b) -> (# a, b #)
+
+  =>
+
+  f z = case $wf z of (# a, b #) -> (a, b)
+  $wf z = let join j x y = (# x+1, y+1 #)
+          in case z of A -> j 1 2
+                       B -> j 2 3
+
+Doing CPR on a join point would be tricky anyway, as the worker could not be
+a join point because it would not be tail-called. However, doing the *argument*
+part of W/W still works for join points, since the wrapper body will make a tail
+call:
+
+  f z = let join j x y = x + y
+        in ...
+
+  =>
+
+  f z = let join $wj x# y# = x# +# y#
+                 j x y = case x of I# x# ->
+                         case y of I# y# ->
+                         $wj x# y#
+        in ...
+
+Note [Wrapper activation]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+When should the wrapper inlining be active?
+
+1. It must not be active earlier than the current Activation of the
+   Id
+
+2. It should be active at some point, despite (1) because of
+   Note [Worker-wrapper for NOINLINE functions]
+
+3. For ordinary functions with no pragmas we want to inline the
+   wrapper as early as possible (Trac #15056).  Suppose another module
+   defines    f x = g x x
+   and suppose there is some RULE for (g True True).  Then if we have
+   a call (f True), we'd expect to inline 'f' and the RULE will fire.
+   But if f is w/w'd (which it might be), we want the inlining to
+   occur just as if it hadn't been.
+
+   (This only matters if f's RHS is big enough to w/w, but small
+   enough to inline given the call site, but that can happen.)
+
+4. We do not want to inline the wrapper before specialisation.
+         module Foo where
+           f :: Num a => a -> Int -> a
+           f n 0 = n              -- Strict in the Int, hence wrapper
+           f n x = f (n+n) (x-1)
+
+           g :: Int -> Int
+           g x = f x x            -- Provokes a specialisation for f
+
+         module Bar where
+           import Foo
+
+           h :: Int -> Int
+           h x = f 3 x
+
+   In module Bar we want to give specialisations a chance to fire
+   before inlining f's wrapper.
+
+Reminder: Note [Don't w/w INLINE things], so we don't need to worry
+          about INLINE things here.
+
+Conclusion:
+  - If the user said NOINLINE[n], respect that
+  - If the user said NOINLINE, inline the wrapper as late as
+    poss (phase 0). This is a compromise driven by (2) above
+  - Otherwise inline wrapper in phase 2.  That allows the
+    'gentle' simplification pass to apply specialisation rules
+
+Historical note: At one stage I tried making the wrapper inlining
+always-active, and that had a very bad effect on nofib/imaginary/x2n1;
+a wrapper was inlined before the specialisation fired.
+
+Note [Wrapper NoUserInline]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The use an inl_inline of NoUserInline on the wrapper distinguishes
+this pragma from one that was given by the user. In particular, CSE
+will not happen if there is a user-specified pragma, but should happen
+for w/w’ed things (#14186).
+-}
+
+tryWW   :: DynFlags
+        -> FamInstEnvs
+        -> RecFlag
+        -> Id                           -- The fn binder
+        -> CoreExpr                     -- The bound rhs; its innards
+                                        --   are already ww'd
+        -> UniqSM [(Id, CoreExpr)]      -- either *one* or *two* pairs;
+                                        -- if one, then no worker (only
+                                        -- the orig "wrapper" lives on);
+                                        -- if two, then a worker and a
+                                        -- wrapper.
+tryWW dflags fam_envs is_rec fn_id rhs
+  -- See Note [Worker-wrapper for NOINLINE functions]
+
+  | Just stable_unf <- certainlyWillInline dflags fn_info
+  = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ]
+        -- See Note [Don't w/w INLINE things]
+        -- See Note [Don't w/w inline small non-loop-breaker things]
+
+  | is_fun
+  = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds res_info rhs
+
+  | is_thunk                                   -- See Note [Thunk splitting]
+  = splitThunk dflags fam_envs is_rec new_fn_id rhs
+
+  | otherwise
+  = return [ (new_fn_id, rhs) ]
+
+  where
+    fn_info      = idInfo fn_id
+    (wrap_dmds, res_info) = splitStrictSig (strictnessInfo fn_info)
+
+    new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id)
+        -- See Note [Zapping DmdEnv after Demand Analyzer] and
+        -- See Note [Zapping Used Once info in WorkWrap]
+
+    is_fun    = notNull wrap_dmds || isJoinId fn_id
+    is_thunk  = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id)
+                           && not (isUnliftedType (idType fn_id))
+
+{-
+Note [Zapping DmdEnv after Demand Analyzer]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the worker-wrapper pass we zap the DmdEnv.  Why?
+ (a) it is never used again
+ (b) it wastes space
+ (c) it becomes incorrect as things are cloned, because
+     we don't push the substitution into it
+
+Why here?
+ * Because we don’t want to do it in the Demand Analyzer, as we never know
+   there when we are doing the last pass.
+ * We want them to be still there at the end of DmdAnal, so that
+   -ddump-str-anal contains them.
+ * We don’t want a second pass just for that.
+ * WorkWrap looks at all bindings anyway.
+
+We also need to do it in TidyCore.tidyLetBndr to clean up after the
+final, worker/wrapper-less run of the demand analyser (see
+Note [Final Demand Analyser run] in DmdAnal).
+
+Note [Zapping Used Once info in WorkWrap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the worker-wrapper pass we zap the used once info in demands and in
+strictness signatures.
+
+Why?
+ * The simplifier may happen to transform code in a way that invalidates the
+   data (see #11731 for an example).
+ * It is not used in later passes, up to code generation.
+
+So as the data is useless and possibly wrong, we want to remove it. The most
+convenient place to do that is the worker wrapper phase, as it runs after every
+run of the demand analyser besides the very last one (which is the one where we
+want to _keep_ the info for the code generator).
+
+We do not do it in the demand analyser for the same reasons outlined in
+Note [Zapping DmdEnv after Demand Analyzer] above.
+-}
+
+
+---------------------
+splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr
+         -> UniqSM [(Id, CoreExpr)]
+splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs
+  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do
+    -- The arity should match the signature
+    stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_res_info
+    case stuff of
+      Just (work_demands, join_arity, wrap_fn, work_fn) -> do
+        work_uniq <- getUniqueM
+        let work_rhs = work_fn rhs
+            work_act = case fn_inline_spec of  -- See Note [Worker activation]
+                          NoInline -> fn_act
+                          _        -> wrap_act
+
+            work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"
+                                     , inl_inline = fn_inline_spec
+                                     , inl_sat    = Nothing
+                                     , inl_act    = work_act
+                                     , inl_rule   = FunLike }
+              -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions]
+              -- inl_act:    see Note [Worker activation]
+              -- inl_rule:   it does not make sense for workers to be constructorlike.
+
+            work_join_arity | isJoinId fn_id = Just join_arity
+                            | otherwise      = Nothing
+              -- worker is join point iff wrapper is join point
+              -- (see Note [Don't CPR join points])
+
+            work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs)
+                        `setIdOccInfo` occInfo fn_info
+                                -- Copy over occurrence info from parent
+                                -- Notably whether it's a loop breaker
+                                -- Doesn't matter much, since we will simplify next, but
+                                -- seems right-er to do so
+
+                        `setInlinePragma` work_prag
+
+                        `setIdUnfolding` mkWorkerUnfolding dflags work_fn fn_unfolding
+                                -- See Note [Worker-wrapper for INLINABLE functions]
+
+                        `setIdStrictness` mkClosedStrictSig work_demands work_res_info
+                                -- Even though we may not be at top level,
+                                -- it's ok to give it an empty DmdEnv
+
+                        `setIdDemandInfo` worker_demand
+
+                        `setIdArity` work_arity
+                                -- Set the arity so that the Core Lint check that the
+                                -- arity is consistent with the demand type goes
+                                -- through
+                        `asJoinId_maybe` work_join_arity
+
+            work_arity = length work_demands
+
+            -- See Note [Demand on the Worker]
+            single_call = saturatedByOneShots arity (demandInfo fn_info)
+            worker_demand | single_call = mkWorkerDemand work_arity
+                          | otherwise   = topDmd
+
+            wrap_rhs  = wrap_fn work_id
+            wrap_act  = case fn_act of  -- See Note [Wrapper activation]
+                           ActiveAfter {} -> fn_act
+                           NeverActive    -> activeDuringFinal
+                           _              -> activeAfterInitial
+            wrap_prag = InlinePragma { inl_src    = SourceText "{-# INLINE"
+                                     , inl_inline = NoUserInline
+                                     , inl_sat    = Nothing
+                                     , inl_act    = wrap_act
+                                     , inl_rule   = rule_match_info }
+                -- inl_act:    see Note [Wrapper activation]
+                -- inl_inline: see Note [Wrapper NoUserInline]
+                -- inl_rule:   RuleMatchInfo is (and must be) unaffected
+
+            wrap_id   = fn_id `setIdUnfolding`  mkWwInlineRule dflags wrap_rhs arity
+                              `setInlinePragma` wrap_prag
+                              `setIdOccInfo`    noOccInfo
+                                -- Zap any loop-breaker-ness, to avoid bleating from Lint
+                                -- about a loop breaker with an INLINE rule
+
+
+
+        return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)]
+            -- Worker first, because wrapper mentions it
+
+      Nothing -> return [(fn_id, rhs)]
+  where
+    rhs_fvs         = exprFreeVars rhs
+    fn_inl_prag     = inlinePragInfo fn_info
+    fn_inline_spec  = inl_inline fn_inl_prag
+    fn_act          = inl_act fn_inl_prag
+    rule_match_info = inlinePragmaRuleMatchInfo fn_inl_prag
+    fn_unfolding    = unfoldingInfo fn_info
+    arity           = arityInfo fn_info
+                    -- The arity is set by the simplifier using exprEtaExpandArity
+                    -- So it may be more than the number of top-level-visible lambdas
+
+    use_res_info  | isJoinId fn_id = topRes -- Note [Don't CPR join points]
+                  | otherwise      = res_info
+    work_res_info | isJoinId fn_id = res_info -- Worker remains CPR-able
+                  | otherwise
+                  = case returnsCPR_maybe res_info of
+                       Just _  -> topRes    -- Cpr stuff done by wrapper; kill it here
+                       Nothing -> res_info  -- Preserve exception/divergence
+
+
+{-
+Note [Demand on the worker]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+If the original function is called once, according to its demand info, then
+so is the worker. This is important so that the occurrence analyser can
+attach OneShot annotations to the worker’s lambda binders.
+
+
+Example:
+
+  -- Original function
+  f [Demand=<L,1*C1(U)>] :: (a,a) -> a
+  f = \p -> ...
+
+  -- Wrapper
+  f [Demand=<L,1*C1(U)>] :: a -> a -> a
+  f = \p -> case p of (a,b) -> $wf a b
+
+  -- Worker
+  $wf [Demand=<L,1*C1(C1(U))>] :: Int -> Int
+  $wf = \a b -> ...
+
+We need to check whether the original function is called once, with
+sufficiently many arguments. This is done using saturatedByOneShots, which
+takes the arity of the original function (resp. the wrapper) and the demand on
+the original function.
+
+The demand on the worker is then calculated using mkWorkerDemand, and always of
+the form [Demand=<L,1*(C1(...(C1(U))))>]
+
+
+Note [Do not split void functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this rather common form of binding:
+        $j = \x:Void# -> ...no use of x...
+
+Since x is not used it'll be marked as absent.  But there is no point
+in w/w-ing because we'll simply add (\y:Void#), see WwLib.mkWorerArgs.
+
+If x has a more interesting type (eg Int, or Int#), there *is* a point
+in w/w so that we don't pass the argument at all.
+
+Note [Thunk splitting]
+~~~~~~~~~~~~~~~~~~~~~~
+Suppose x is used strictly (never mind whether it has the CPR
+property).
+
+      let
+        x* = x-rhs
+      in body
+
+splitThunk transforms like this:
+
+      let
+        x* = case x-rhs of { I# a -> I# a }
+      in body
+
+Now simplifier will transform to
+
+      case x-rhs of
+        I# a -> let x* = I# a
+                in body
+
+which is what we want. Now suppose x-rhs is itself a case:
+
+        x-rhs = case e of { T -> I# a; F -> I# b }
+
+The join point will abstract over a, rather than over (which is
+what would have happened before) which is fine.
+
+Notice that x certainly has the CPR property now!
+
+In fact, splitThunk uses the function argument w/w splitting
+function, so that if x's demand is deeper (say U(U(L,L),L))
+then the splitting will go deeper too.
+-}
+
+-- See Note [Thunk splitting]
+-- splitThunk converts the *non-recursive* binding
+--      x = e
+-- into
+--      x = let x = e
+--          in case x of
+--               I# y -> let x = I# y in x }
+-- See comments above. Is it not beautifully short?
+-- Moreover, it works just as well when there are
+-- several binders, and if the binders are lifted
+-- E.g.     x = e
+--     -->  x = let x = e in
+--              case x of (a,b) -> let x = (a,b)  in x
+
+splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]
+splitThunk dflags fam_envs is_rec fn_id rhs
+  = ASSERT(not (isJoinId fn_id))
+    do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [fn_id]
+       ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
+       ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive
+                   return res
+                   else return [(fn_id, rhs)] }
diff --git a/compiler/stranal/WwLib.hs b/compiler/stranal/WwLib.hs
new file mode 100644
--- /dev/null
+++ b/compiler/stranal/WwLib.hs
@@ -0,0 +1,1192 @@
+{-
+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+
+\section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser}
+-}
+
+{-# LANGUAGE CPP #-}
+
+module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs
+             , deepSplitProductType_maybe, findTypeShape
+             , isWorkerSmallEnough
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import CoreSyn
+import CoreUtils        ( exprType, mkCast )
+import Id
+import IdInfo           ( JoinArity )
+import DataCon
+import Demand
+import MkCore           ( mkAbsentErrorApp, mkCoreUbxTup
+                        , mkCoreApp, mkCoreLet )
+import MkId             ( voidArgId, voidPrimId )
+import TysWiredIn       ( tupleDataCon )
+import TysPrim          ( voidPrimTy )
+import Literal          ( absentLiteralOf, rubbishLit )
+import VarEnv           ( mkInScopeSet )
+import VarSet           ( VarSet )
+import Type
+import RepType          ( isVoidTy, typePrimRep )
+import Coercion
+import FamInstEnv
+import BasicTypes       ( Boxity(..) )
+import TyCon
+import UniqSupply
+import Unique
+import Maybes
+import Util
+import Outputable
+import DynFlags
+import FastString
+import ListSetOps
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}
+*                                                                      *
+************************************************************************
+
+Here's an example.  The original function is:
+
+\begin{verbatim}
+g :: forall a . Int -> [a] -> a
+
+g = \/\ a -> \ x ys ->
+        case x of
+          0 -> head ys
+          _ -> head (tail ys)
+\end{verbatim}
+
+From this, we want to produce:
+\begin{verbatim}
+-- wrapper (an unfolding)
+g :: forall a . Int -> [a] -> a
+
+g = \/\ a -> \ x ys ->
+        case x of
+          I# x# -> $wg a x# ys
+            -- call the worker; don't forget the type args!
+
+-- worker
+$wg :: forall a . Int# -> [a] -> a
+
+$wg = \/\ a -> \ x# ys ->
+        let
+            x = I# x#
+        in
+            case x of               -- note: body of g moved intact
+              0 -> head ys
+              _ -> head (tail ys)
+\end{verbatim}
+
+Something we have to be careful about:  Here's an example:
+
+\begin{verbatim}
+-- "f" strictness: U(P)U(P)
+f (I# a) (I# b) = a +# b
+
+g = f   -- "g" strictness same as "f"
+\end{verbatim}
+
+\tr{f} will get a worker all nice and friendly-like; that's good.
+{\em But we don't want a worker for \tr{g}}, even though it has the
+same strictness as \tr{f}.  Doing so could break laziness, at best.
+
+Consequently, we insist that the number of strictness-info items is
+exactly the same as the number of lambda-bound arguments.  (This is
+probably slightly paranoid, but OK in practice.)  If it isn't the
+same, we ``revise'' the strictness info, so that we won't propagate
+the unusable strictness-info into the interfaces.
+
+
+************************************************************************
+*                                                                      *
+\subsection{The worker wrapper core}
+*                                                                      *
+************************************************************************
+
+@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.
+-}
+
+type WwResult
+  = ([Demand],              -- Demands for worker (value) args
+     JoinArity,             -- Number of worker (type OR value) args
+     Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id
+     CoreExpr -> CoreExpr)  -- Worker body, lacking the original function rhs
+
+mkWwBodies :: DynFlags
+           -> FamInstEnvs
+           -> VarSet         -- Free vars of RHS
+                             -- See Note [Freshen WW arguments]
+           -> Id             -- The original function
+           -> [Demand]       -- Strictness of original function
+           -> DmdResult      -- Info about function result
+           -> UniqSM (Maybe WwResult)
+
+-- wrap_fn_args E       = \x y -> E
+-- work_fn_args E       = E x y
+
+-- wrap_fn_str E        = case x of { (a,b) ->
+--                        case a of { (a1,a2) ->
+--                        E a1 a2 b y }}
+-- work_fn_str E        = \a2 a2 b y ->
+--                        let a = (a1,a2) in
+--                        let x = (a,b) in
+--                        E
+
+mkWwBodies dflags fam_envs rhs_fvs fun_id demands res_info
+  = do  { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)
+                -- See Note [Freshen WW arguments]
+
+        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
+             <- mkWWargs empty_subst fun_ty demands
+        ; (useful1, work_args, wrap_fn_str, work_fn_str)
+             <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args
+
+        -- Do CPR w/w.  See Note [Always do CPR w/w]
+        ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)
+              <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty res_info
+
+        ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty
+              worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]
+              wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var
+              worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args
+
+        ; if isWorkerSmallEnough dflags work_args
+             && not (too_many_args_for_join_point wrap_args)
+             && ((useful1 && not only_one_void_argument) || useful2)
+          then return (Just (worker_args_dmds, length work_call_args,
+                       wrapper_body, worker_body))
+          else return Nothing
+        }
+        -- We use an INLINE unconditionally, even if the wrapper turns out to be
+        -- something trivial like
+        --      fw = ...
+        --      f = __inline__ (coerce T fw)
+        -- The point is to propagate the coerce to f's call sites, so even though
+        -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
+        -- fw from being inlined into f's RHS
+  where
+    fun_ty        = idType fun_id
+    mb_join_arity = isJoinId_maybe fun_id
+    has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id)
+                          -- See Note [Do not unpack class dictionaries]
+
+    -- Note [Do not split void functions]
+    only_one_void_argument
+      | [d] <- demands
+      , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty
+      , isAbsDmd d && isVoidTy arg_ty1
+      = True
+      | otherwise
+      = False
+
+    -- Note [Join points returning functions]
+    too_many_args_for_join_point wrap_args
+      | Just join_arity <- mb_join_arity
+      , wrap_args `lengthExceeds` join_arity
+      = WARN(True, text "Unable to worker/wrapper join point with arity " <+>
+                     int join_arity <+> text "but" <+>
+                     int (length wrap_args) <+> text "args")
+        True
+      | otherwise
+      = False
+
+-- See Note [Limit w/w arity]
+isWorkerSmallEnough :: DynFlags -> [Var] -> Bool
+isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags
+    -- We count only Free variables (isId) to skip Type, Kind
+    -- variables which have no runtime representation.
+
+{-
+Note [Always do CPR w/w]
+~~~~~~~~~~~~~~~~~~~~~~~~
+At one time we refrained from doing CPR w/w for thunks, on the grounds that
+we might duplicate work.  But that is already handled by the demand analyser,
+which doesn't give the CPR proprety if w/w might waste work: see
+Note [CPR for thunks] in DmdAnal.
+
+And if something *has* been given the CPR property and we don't w/w, it's
+a disaster, because then the enclosing function might say it has the CPR
+property, but now doesn't and there a cascade of disaster.  A good example
+is Trac #5920.
+
+Note [Limit w/w arity]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Guard against high worker arity as it generates a lot of stack traffic.
+A simplified example is Trac #11565#comment:6
+
+Current strategy is very simple: don't perform w/w transformation at all
+if the result produces a wrapper with arity higher than -fmax-worker-args=.
+
+It is a bit all or nothing, consider
+
+        f (x,y) (a,b,c,d,e ... , z) = rhs
+
+Currently we will remove all w/w ness entirely. But actually we could
+w/w on the (x,y) pair... it's the huge product that is the problem.
+
+Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd
+solve f. But we can get a lot of args from deeply-nested products:
+
+        g (a, (b, (c, (d, ...)))) = rhs
+
+This is harder to spot on an arg-by-arg basis. Previously mkWwStr was
+given some "fuel" saying how many arguments it could add; when we ran
+out of fuel it would stop w/wing.
+Still not very clever because it had a left-right bias.
+
+************************************************************************
+*                                                                      *
+\subsection{Making wrapper args}
+*                                                                      *
+************************************************************************
+
+During worker-wrapper stuff we may end up with an unlifted thing
+which we want to let-bind without losing laziness.  So we
+add a void argument.  E.g.
+
+        f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z
+==>
+        fw = /\ a -> \void -> E
+        f  = /\ a -> \x y z -> fw realworld
+
+We use the state-token type which generates no code.
+-}
+
+mkWorkerArgs :: DynFlags -> [Var]
+             -> Type    -- Type of body
+             -> ([Var], -- Lambda bound args
+                 [Var]) -- Args at call site
+mkWorkerArgs dflags args res_ty
+    | any isId args || not needsAValueLambda
+    = (args, args)
+    | otherwise
+    = (args ++ [voidArgId], args ++ [voidPrimId])
+    where
+      -- See "Making wrapper args" section above
+      needsAValueLambda =
+        lifted
+        -- We may encounter a levity-polymorphic result, in which case we
+        -- conservatively assume that we have laziness that needs preservation.
+        -- See #15186.
+        || not (gopt Opt_FunToThunk dflags)
+           -- see Note [Protecting the last value argument]
+
+      -- Might the result be lifted?
+      lifted =
+        case isLiftedType_maybe res_ty of
+          Just lifted -> lifted
+          Nothing     -> True
+
+{-
+Note [Protecting the last value argument]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the user writes (\_ -> E), they might be intentionally disallowing
+the sharing of E. Since absence analysis and worker-wrapper are keen
+to remove such unused arguments, we add in a void argument to prevent
+the function from becoming a thunk.
+
+The user can avoid adding the void argument with the -ffun-to-thunk
+flag. However, this can create sharing, which may be bad in two ways. 1) It can
+create a space leak. 2) It can prevent inlining *under a lambda*. If w/w
+removes the last argument from a function f, then f now looks like a thunk, and
+so f can't be inlined *under a lambda*.
+
+Note [Join points and beta-redexes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Originally, the worker would invoke the original function by calling it with
+arguments, thus producing a beta-redex for the simplifier to munch away:
+
+  \x y z -> e => (\x y z -> e) wx wy wz
+
+Now that we have special rules about join points, however, this is Not Good if
+the original function is itself a join point, as then it may contain invocations
+of other join points:
+
+  join j1 x = ...
+  join j2 y = if y == 0 then 0 else j1 y
+
+  =>
+
+  join j1 x = ...
+  join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy
+  join j2 y = case y of I# y# -> jump $wj2 y#
+
+There can't be an intervening lambda between a join point's declaration and its
+occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:
+
+  ...
+  let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y
+  ...
+
+Hence we simply do the beta-reduction here. (This would be harder if we had to
+worry about hygiene, but luckily wy is freshly generated.)
+
+Note [Join points returning functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+It is crucial that the arity of a join point depends on its *callers,* not its
+own syntax. What this means is that a join point can have "extra lambdas":
+
+f :: Int -> Int -> (Int, Int) -> Int
+f x y = join j (z, w) = \(u, v) -> ...
+        in jump j (x, y)
+
+Typically this happens with functions that are seen as computing functions,
+rather than being curried. (The real-life example was GraphOps.addConflicts.)
+
+When we create the wrapper, it *must* be in "eta-contracted" form so that the
+jump has the right number of arguments:
+
+f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...
+             j (z, w)  = jump $wj z w
+
+(See Note [Join points and beta-redexes] for where the lets come from.) If j
+were a function, we would instead say
+
+f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...
+            j (z, w) (u, v) = $wj z w u v
+
+Notice that the worker ends up with the same lambdas; it's only the wrapper we
+have to be concerned about.
+
+FIXME Currently the functionality to produce "eta-contracted" wrappers is
+unimplemented; we simply give up.
+
+************************************************************************
+*                                                                      *
+\subsection{Coercion stuff}
+*                                                                      *
+************************************************************************
+
+We really want to "look through" coerces.
+Reason: I've seen this situation:
+
+        let f = coerce T (\s -> E)
+        in \x -> case x of
+                    p -> coerce T' f
+                    q -> \s -> E2
+                    r -> coerce T' f
+
+If only we w/w'd f, we'd get
+        let f = coerce T (\s -> fw s)
+            fw = \s -> E
+        in ...
+
+Now we'll inline f to get
+
+        let fw = \s -> E
+        in \x -> case x of
+                    p -> fw
+                    q -> \s -> E2
+                    r -> fw
+
+Now we'll see that fw has arity 1, and will arity expand
+the \x to get what we want.
+-}
+
+-- mkWWargs just does eta expansion
+-- is driven off the function type and arity.
+-- It chomps bites off foralls, arrows, newtypes
+-- and keeps repeating that until it's satisfied the supplied arity
+
+mkWWargs :: TCvSubst            -- Freshening substitution to apply to the type
+                                --   See Note [Freshen WW arguments]
+         -> Type                -- The type of the function
+         -> [Demand]     -- Demands and one-shot info for value arguments
+         -> UniqSM  ([Var],            -- Wrapper args
+                     CoreExpr -> CoreExpr,      -- Wrapper fn
+                     CoreExpr -> CoreExpr,      -- Worker fn
+                     Type)                      -- Type of wrapper body
+
+mkWWargs subst fun_ty demands
+  | null demands
+  = return ([], id, id, substTy subst fun_ty)
+
+  | (dmd:demands') <- demands
+  , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
+  = do  { uniq <- getUniqueM
+        ; let arg_ty' = substTy subst arg_ty
+              id = mk_wrap_arg uniq arg_ty' dmd
+        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
+              <- mkWWargs subst fun_ty' demands'
+        ; return (id : wrap_args,
+                  Lam id . wrap_fn_args,
+                  apply_or_bind_then work_fn_args (varToCoreExpr id),
+                  res_ty) }
+
+  | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty
+  = do  { uniq <- getUniqueM
+        ; let (subst', tv') = cloneTyVarBndr subst tv uniq
+                -- See Note [Freshen WW arguments]
+        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
+             <- mkWWargs subst' fun_ty' demands
+        ; return (tv' : wrap_args,
+                  Lam tv' . wrap_fn_args,
+                  apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')),
+                  res_ty) }
+
+  | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty
+        -- The newtype case is for when the function has
+        -- a newtype after the arrow (rare)
+        --
+        -- It's also important when we have a function returning (say) a pair
+        -- wrapped in a  newtype, at least if CPR analysis can look
+        -- through such newtypes, which it probably can since they are
+        -- simply coerces.
+
+  = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)
+            <-  mkWWargs subst rep_ty demands
+       ; let co' = substCo subst co
+       ; return (wrap_args,
+                  \e -> Cast (wrap_fn_args e) (mkSymCo co'),
+                  \e -> work_fn_args (Cast e co'),
+                  res_ty) }
+
+  | otherwise
+  = WARN( True, ppr fun_ty )                    -- Should not happen: if there is a demand
+    return ([], id, id, substTy subst fun_ty)   -- then there should be a function arrow
+  where
+    -- See Note [Join points and beta-redexes]
+    apply_or_bind_then k arg (Lam bndr body)
+      = mkCoreLet (NonRec bndr arg) (k body)    -- Important that arg is fresh!
+    apply_or_bind_then k arg fun
+      = k $ mkCoreApp (text "mkWWargs") fun arg
+applyToVars :: [Var] -> CoreExpr -> CoreExpr
+applyToVars vars fn = mkVarApps fn vars
+
+mk_wrap_arg :: Unique -> Type -> Demand -> Id
+mk_wrap_arg uniq ty dmd
+  = mkSysLocalOrCoVar (fsLit "w") uniq ty
+       `setIdDemandInfo` dmd
+
+{- Note [Freshen WW arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Wen we do a worker/wrapper split, we must not in-scope names as the arguments
+of the worker, else we'll get name capture.  E.g.
+
+   -- y1 is in scope from further out
+   f x = ..y1..
+
+If we accidentally choose y1 as a worker argument disaster results:
+
+   fww y1 y2 = let x = (y1,y2) in ...y1...
+
+To avoid this:
+
+  * We use a fresh unique for both type-variable and term-variable binders
+    Originally we lacked this freshness for type variables, and that led
+    to the very obscure Trac #12562.  (A type variable in the worker shadowed
+    an outer term-variable binding.)
+
+  * Because of this cloning we have to substitute in the type/kind of the
+    new binders.  That's why we carry the TCvSubst through mkWWargs.
+
+    So we need a decent in-scope set, just in case that type/kind
+    itself has foralls.  We get this from the free vars of the RHS of the
+    function since those are the only variables that might be captured.
+    It's a lazy thunk, which will only be poked if the type/kind has a forall.
+
+    Another tricky case was when f :: forall a. a -> forall a. a->a
+    (i.e. with shadowing), and then the worker used the same 'a' twice.
+
+************************************************************************
+*                                                                      *
+\subsection{Strictness stuff}
+*                                                                      *
+************************************************************************
+-}
+
+mkWWstr :: DynFlags
+        -> FamInstEnvs
+        -> Bool    -- True <=> INLINEABLE pragma on this function defn
+                   -- See Note [Do not unpack class dictionaries]
+        -> [Var]                                -- Wrapper args; have their demand info on them
+                                                --  *Includes type variables*
+        -> UniqSM (Bool,                        -- Is this useful
+                   [Var],                       -- Worker args
+                   CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call
+                                                -- and without its lambdas
+                                                -- This fn adds the unboxing
+
+                   CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,
+                                                -- and lacking its lambdas.
+                                                -- This fn does the reboxing
+mkWWstr dflags fam_envs has_inlineable_prag args
+  = go args
+  where
+    go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg
+
+    go []           = return (False, [], nop_fn, nop_fn)
+    go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg
+                         ; (useful2, args2, wrap_fn2, work_fn2) <- go args
+                         ; return ( useful1 || useful2
+                                  , args1 ++ args2
+                                  , wrap_fn1 . wrap_fn2
+                                  , work_fn1 . work_fn2) }
+
+{-
+Note [Unpacking arguments with product and polymorphic demands]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The argument is unpacked in a case if it has a product type and has a
+strict *and* used demand put on it. I.e., arguments, with demands such
+as the following ones:
+
+   <S,U(U, L)>
+   <S(L,S),U>
+
+will be unpacked, but
+
+   <S,U> or <B,U>
+
+will not, because the pieces aren't used. This is quite important otherwise
+we end up unpacking massive tuples passed to the bottoming function. Example:
+
+        f :: ((Int,Int) -> String) -> (Int,Int) -> a
+        f g pr = error (g pr)
+
+        main = print (f fst (1, error "no"))
+
+Does 'main' print "error 1" or "error no"?  We don't really want 'f'
+to unbox its second argument.  This actually happened in GHC's onwn
+source code, in Packages.applyPackageFlag, which ended up un-boxing
+the enormous DynFlags tuple, and being strict in the
+as-yet-un-filled-in pkgState files.
+-}
+
+----------------------
+-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)
+--   *  wrap_fn assumes wrap_arg is in scope,
+--        brings into scope work_args (via cases)
+--   * work_fn assumes work_args are in scope, a
+--        brings into scope wrap_arg (via lets)
+-- See Note [How to do the worker/wrapper split]
+mkWWstr_one :: DynFlags -> FamInstEnvs
+            -> Bool    -- True <=> INLINEABLE pragma on this function defn
+                       -- See Note [Do not unpack class dictionaries]
+            -> Var
+            -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
+mkWWstr_one dflags fam_envs has_inlineable_prag arg
+  | isTyVar arg
+  = return (False, [arg],  nop_fn, nop_fn)
+
+  | isAbsDmd dmd
+  , Just work_fn <- mk_absent_let dflags arg
+     -- Absent case.  We can't always handle absence for arbitrary
+     -- unlifted types, so we need to choose just the cases we can
+     -- (that's what mk_absent_let does)
+  = return (True, [], nop_fn, work_fn)
+
+  | isStrictDmd dmd
+  , Just cs <- splitProdDmd_maybe dmd
+      -- See Note [Unpacking arguments with product and polymorphic demands]
+  , not (has_inlineable_prag && isClassPred arg_ty)
+      -- See Note [Do not unpack class dictionaries]
+  , Just stuff@(_, _, inst_con_arg_tys, _) <- deepSplitProductType_maybe fam_envs arg_ty
+  , cs `equalLength` inst_con_arg_tys
+      -- See Note [mkWWstr and unsafeCoerce]
+  = unbox_one dflags fam_envs arg cs stuff
+
+  | isSeqDmd dmd   -- For seqDmd, splitProdDmd_maybe will return Nothing, but
+                   -- it should behave like <S, U(AAAA)>, for some suitable arity
+  , Just stuff@(_, _, inst_con_arg_tys, _) <- deepSplitProductType_maybe fam_envs arg_ty
+  , let abs_dmds = map (const absDmd) inst_con_arg_tys
+  = unbox_one dflags fam_envs arg abs_dmds stuff
+
+  | otherwise   -- Other cases
+  = return (False, [arg], nop_fn, nop_fn)
+
+  where
+    arg_ty = idType arg
+    dmd    = idDemandInfo arg
+
+unbox_one :: DynFlags -> FamInstEnvs -> Var
+          -> [Demand]
+          -> (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
+          -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
+unbox_one dflags fam_envs arg cs
+          (data_con, inst_tys, inst_con_arg_tys, co)
+  = do { (uniq1:uniqs) <- getUniquesM
+        ; let   -- See Note [Add demands for strict constructors]
+                cs'       = addDataConStrictness data_con cs
+                unpk_args = zipWith3 mk_ww_arg uniqs inst_con_arg_tys cs'
+                unbox_fn  = mkUnpackCase (Var arg) co uniq1
+                                         data_con unpk_args
+                arg_no_unf = zapStableUnfolding arg
+                             -- See Note [Zap unfolding when beta-reducing]
+                             -- in Simplify.hs; and see Trac #13890
+                rebox_fn   = Let (NonRec arg_no_unf con_app)
+                con_app    = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co
+         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args
+         ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }
+                           -- Don't pass the arg, rebox instead
+  where
+    mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd
+
+----------------------
+nop_fn :: CoreExpr -> CoreExpr
+nop_fn body = body
+
+addDataConStrictness :: DataCon -> [Demand] -> [Demand]
+-- See Note [Add demands for strict constructors]
+addDataConStrictness con ds
+  = ASSERT2( equalLength strs ds, ppr con $$ ppr strs $$ ppr ds )
+    zipWith add ds strs
+  where
+    strs = dataConRepStrictness con
+    add dmd str | isMarkedStrict str = strictifyDmd dmd
+                | otherwise          = dmd
+
+{- Note [How to do the worker/wrapper split]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The worker-wrapper transformation, mkWWstr_one, takes into account
+several possibilities to decide if the function is worthy for
+splitting:
+
+1. If an argument is absent, it would be silly to pass it to
+   the worker.  Hence the isAbsDmd case.  This case must come
+   first because a demand like <S,A> or <B,A> is possible.
+   E.g. <B,A> comes from a function like
+       f x = error "urk"
+   and <S,A> can come from Note [Add demands for strict constructors]
+
+2. If the argument is evaluated strictly, and we can split the
+   product demand (splitProdDmd_maybe), then unbox it and w/w its
+   pieces.  For example
+
+    f :: (Int, Int) -> Int
+    f p = (case p of (a,b) -> a) + 1
+  is split to
+    f :: (Int, Int) -> Int
+    f p = case p of (a,b) -> $wf a
+
+    $wf :: Int -> Int
+    $wf a = a + 1
+
+  and
+    g :: Bool -> (Int, Int) -> Int
+    g c p = case p of (a,b) ->
+               if c then a else b
+  is split to
+   g c p = case p of (a,b) -> $gw c a b
+   $gw c a b = if c then a else b
+
+2a But do /not/ split if the components are not used; that is, the
+   usage is just 'Used' rather than 'UProd'. In this case
+   splitProdDmd_maybe returns Nothing.  Otherwise we risk decomposing
+   a massive tuple which is barely used.  Example:
+
+        f :: ((Int,Int) -> String) -> (Int,Int) -> a
+        f g pr = error (g pr)
+
+        main = print (f fst (1, error "no"))
+
+   Here, f does not take 'pr' apart, and it's stupid to do so.
+   Imagine that it had millions of fields. This actually happened
+   in GHC itself where the tuple was DynFlags
+
+3. A plain 'seqDmd', which is head-strict with usage UHead, can't
+   be split by splitProdDmd_maybe.  But we want it to behave just
+   like U(AAAA) for suitable number of absent demands. So we have
+   a special case for it, with arity coming from the data constructor.
+
+Note [Worker-wrapper for bottoming functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used not to split if the result is bottom.
+[Justification:  there's no efficiency to be gained.]
+
+But it's sometimes bad not to make a wrapper.  Consider
+        fw = \x# -> let x = I# x# in case e of
+                                        p1 -> error_fn x
+                                        p2 -> error_fn x
+                                        p3 -> the real stuff
+The re-boxing code won't go away unless error_fn gets a wrapper too.
+[We don't do reboxing now, but in general it's better to pass an
+unboxed thing to f, and have it reboxed in the error cases....]
+
+Note [Add demands for strict constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this program (due to Roman):
+
+    data X a = X !a
+
+    foo :: X Int -> Int -> Int
+    foo (X a) n = go 0
+     where
+       go i | i < n     = a + go (i+1)
+            | otherwise = 0
+
+We want the worker for 'foo' too look like this:
+
+    $wfoo :: Int# -> Int# -> Int#
+
+with the first argument unboxed, so that it is not eval'd each time
+around the 'go' loop (which would otherwise happen, since 'foo' is not
+strict in 'a').  It is sound for the wrapper to pass an unboxed arg
+because X is strict, so its argument must be evaluated.  And if we
+*don't* pass an unboxed argument, we can't even repair it by adding a
+`seq` thus:
+
+    foo (X a) n = a `seq` go 0
+
+because the seq is discarded (very early) since X is strict!
+
+So here's what we do
+
+* We leave the demand-analysis alone.  The demand on 'a' in the
+  definition of 'foo' is <L, U(U)>; the strictness info is Lazy
+  because foo's body may or may not evaluate 'a'; but the usage info
+  says that 'a' is unpacked and its content is used.
+
+* During worker/wrapper, if we unpack a strict constructor (as we do
+  for 'foo'), we use 'addDataConStrictness' to bump up the strictness on
+  the strict arguments of the data constructor.
+
+* That in turn means that, if the usage info supports doing so
+  (i.e. splitProdDmd_maybe returns Just), we will unpack that argument
+  -- even though the original demand (e.g. on 'a') was lazy.
+
+* What does "bump up the strictness" mean?  Just add a head-strict
+  demand to the strictness!  Even for a demand like <L,A> we can
+  safely turn it into <S,A>; remember case (1) of
+  Note [How to do the worker/wrapper split].
+
+The net effect is that the w/w transformation is more aggressive about
+unpacking the strict arguments of a data constructor, when that
+eagerness is supported by the usage info.
+
+There is the usual danger of reboxing, which as usual we ignore. But
+if X is monomorphic, and has an UNPACK pragma, then this optimisation
+is even more important.  We don't want the wrapper to rebox an unboxed
+argument, and pass an Int to $wfoo!
+
+This works in nested situations like
+
+    data family Bar a
+    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
+    newtype instance Bar Int = Bar Int
+
+    foo :: Bar ((Int, Int), Int) -> Int -> Int
+    foo f k = case f of BarPair x y ->
+              case burble of
+                 True -> case x of
+                           BarPair p q -> ...
+                 False -> ...
+
+The extra eagerness lets us produce a worker of type:
+     $wfoo :: Int# -> Int# -> Int# -> Int -> Int
+     $wfoo p# q# y# = ...
+
+even though the `case x` is only lazily evaluated.
+
+--------- Historical note ------------
+We used to add data-con strictness demands when demand analysing case
+expression. However, it was noticed in #15696 that this misses some cases. For
+instance, consider the program (from T10482)
+
+    data family Bar a
+    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)
+    newtype instance Bar Int = Bar Int
+
+    foo :: Bar ((Int, Int), Int) -> Int -> Int
+    foo f k =
+      case f of
+        BarPair x y -> case burble of
+                          True -> case x of
+                                    BarPair p q -> ...
+                          False -> ...
+
+We really should be able to assume that `p` is already evaluated since it came
+from a strict field of BarPair. This strictness would allow us to produce a
+worker of type:
+
+    $wfoo :: Int# -> Int# -> Int# -> Int -> Int
+    $wfoo p# q# y# = ...
+
+even though the `case x` is only lazily evaluated
+
+Indeed before we fixed #15696 this would happen since we would float the inner
+`case x` through the `case burble` to get:
+
+    foo f k =
+      case f of
+        BarPair x y -> case x of
+                          BarPair p q -> case burble of
+                                          True -> ...
+                                          False -> ...
+
+However, after fixing #15696 this could no longer happen (for the reasons
+discussed in ticket:15696#comment:76). This means that the demand placed on `f`
+would then be significantly weaker (since the False branch of the case on
+`burble` is not strict in `p` or `q`).
+
+Consequently, we now instead account for data-con strictness in mkWWstr_one,
+applying the strictness demands to the final result of DmdAnal. The result is
+that we get the strict demand signature we wanted even if we can't float
+the case on `x` up through the case on `burble`.
+
+
+Note [mkWWstr and unsafeCoerce]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+By using unsafeCoerce, it is possible to make the number of demands fail to
+match the number of constructor arguments; this happened in Trac #8037.
+If so, the worker/wrapper split doesn't work right and we get a Core Lint
+bug.  The fix here is simply to decline to do w/w if that happens.
+
+Note [Record evaluated-ness in worker/wrapper]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+   data T = MkT !Int Int
+
+   f :: T -> T
+   f x = e
+
+and f's is strict, and has the CPR property.  The we are going to generate
+this w/w split
+
+   f x = case x of
+           MkT x1 x2 -> case $wf x1 x2 of
+                           (# r1, r2 #) -> MkT r1 r2
+
+   $wfw x1 x2 = let x = MkT x1 x2 in
+                case e of
+                  MkT r1 r2 -> (# r1, r2 #)
+
+Note that
+
+* In the worker $wf, inside 'e' we can be sure that x1 will be
+  evaluated (it came from unpacking the argument MkT.  But that's no
+  immediately apparent in $wf
+
+* In the wrapper 'f', which we'll inline at call sites, we can be sure
+  that 'r1' has been evaluated (because it came from unpacking the result
+  MkT.  But that is not immediately apparent from the wrapper code.
+
+Missing these facts isn't unsound, but it loses possible future
+opportunities for optimisation.
+
+Solution: use setCaseBndrEvald when creating
+ (A) The arg binders x1,x2 in mkWstr_one
+         See Trac #13077, test T13077
+ (B) The result binders r1,r2 in mkWWcpr_help
+         See Trace #13077, test T13077a
+         And Trac #13027 comment:20, item (4)
+to record that the relevant binder is evaluated.
+
+
+************************************************************************
+*                                                                      *
+         Type scrutiny that is specific to demand analysis
+*                                                                      *
+************************************************************************
+
+Note [Do not unpack class dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have
+   f :: Ord a => [a] -> Int -> a
+   {-# INLINABLE f #-}
+and we worker/wrapper f, we'll get a worker with an INLINABLE pragma
+(see Note [Worker-wrapper for INLINABLE functions] in WorkWrap), which
+can still be specialised by the type-class specialiser, something like
+   fw :: Ord a => [a] -> Int# -> a
+
+BUT if f is strict in the Ord dictionary, we might unpack it, to get
+   fw :: (a->a->Bool) -> [a] -> Int# -> a
+and the type-class specialiser can't specialise that.  An example is
+Trac #6056.
+
+But in any other situation a dictionary is just an ordinary value,
+and can be unpacked.  So we track the INLINABLE pragma, and switch
+off the unpacking in mkWWstr_one (see the isClassPred test).
+
+Historical note: Trac #14955 describes how I got this fix wrong
+the first time.
+-}
+
+deepSplitProductType_maybe
+    :: FamInstEnvs -> Type
+    -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
+-- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)
+-- then  dc @ tys (args::arg_tys) :: rep_ty
+--       co :: ty ~ rep_ty
+-- Why do we return the strictness of the data-con arguments?
+-- Answer: see Note [Record evaluated-ness in worker/wrapper]
+deepSplitProductType_maybe fam_envs ty
+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty
+                    `orElse` (mkRepReflCo ty, ty)
+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1
+  , Just con <- isDataProductTyCon_maybe tc
+  , let arg_tys = dataConInstArgTys con tc_args
+        strict_marks = dataConRepStrictness con
+  = Just (con, tc_args, zipEqual "dspt" arg_tys strict_marks, co)
+deepSplitProductType_maybe _ _ = Nothing
+
+deepSplitCprType_maybe
+    :: FamInstEnvs -> ConTag -> Type
+    -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)
+-- If    deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)
+-- then  dc @ tys (args::arg_tys) :: rep_ty
+--       co :: ty ~ rep_ty
+-- Why do we return the strictness of the data-con arguments?
+-- Answer: see Note [Record evaluated-ness in worker/wrapper]
+deepSplitCprType_maybe fam_envs con_tag ty
+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty
+                    `orElse` (mkRepReflCo ty, ty)
+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1
+  , isDataTyCon tc
+  , let cons = tyConDataCons tc
+  , cons `lengthAtLeast` con_tag -- This might not be true if we import the
+                                 -- type constructor via a .hs-bool file (#8743)
+  , let con = cons `getNth` (con_tag - fIRST_TAG)
+        arg_tys = dataConInstArgTys con tc_args
+        strict_marks = dataConRepStrictness con
+  = Just (con, tc_args, zipEqual "dsct" arg_tys strict_marks, co)
+deepSplitCprType_maybe _ _ _ = Nothing
+
+findTypeShape :: FamInstEnvs -> Type -> TypeShape
+-- Uncover the arrow and product shape of a type
+-- The data type TypeShape is defined in Demand
+-- See Note [Trimming a demand to a type] in Demand
+findTypeShape fam_envs ty
+  | Just (tc, tc_args)  <- splitTyConApp_maybe ty
+  , Just con <- isDataProductTyCon_maybe tc
+  = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args)
+
+  | Just (_, res) <- splitFunTy_maybe ty
+  = TsFun (findTypeShape fam_envs res)
+
+  | Just (_, ty') <- splitForAllTy_maybe ty
+  = findTypeShape fam_envs ty'
+
+  | Just (_, ty') <- topNormaliseType_maybe fam_envs ty
+  = findTypeShape fam_envs ty'
+
+  | otherwise
+  = TsUnk
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{CPR stuff}
+*                                                                      *
+************************************************************************
+
+
+@mkWWcpr@ takes the worker/wrapper pair produced from the strictness
+info and adds in the CPR transformation.  The worker returns an
+unboxed tuple containing non-CPR components.  The wrapper takes this
+tuple and re-produces the correct structured output.
+
+The non-CPR results appear ordered in the unboxed tuple as if by a
+left-to-right traversal of the result structure.
+-}
+
+mkWWcpr :: Bool
+        -> FamInstEnvs
+        -> Type                              -- function body type
+        -> DmdResult                         -- CPR analysis results
+        -> UniqSM (Bool,                     -- Is w/w'ing useful?
+                   CoreExpr -> CoreExpr,     -- New wrapper
+                   CoreExpr -> CoreExpr,     -- New worker
+                   Type)                     -- Type of worker's body
+
+mkWWcpr opt_CprAnal fam_envs body_ty res
+    -- CPR explicitly turned off (or in -O0)
+  | not opt_CprAnal = return (False, id, id, body_ty)
+    -- CPR is turned on by default for -O and O2
+  | otherwise
+  = case returnsCPR_maybe res of
+       Nothing      -> return (False, id, id, body_ty)  -- No CPR info
+       Just con_tag | Just stuff <- deepSplitCprType_maybe fam_envs con_tag body_ty
+                    -> mkWWcpr_help stuff
+                    |  otherwise
+                       -- See Note [non-algebraic or open body type warning]
+                    -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
+                       return (False, id, id, body_ty)
+
+mkWWcpr_help :: (DataCon, [Type], [(Type,StrictnessMark)], Coercion)
+             -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)
+
+mkWWcpr_help (data_con, inst_tys, arg_tys, co)
+  | [arg1@(arg_ty1, _)] <- arg_tys
+  , isUnliftedType arg_ty1
+        -- Special case when there is a single result of unlifted type
+        --
+        -- Wrapper:     case (..call worker..) of x -> C x
+        -- Worker:      case (   ..body..    ) of C x -> x
+  = do { (work_uniq : arg_uniq : _) <- getUniquesM
+       ; let arg       = mk_ww_local arg_uniq arg1
+             con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co
+
+       ; return ( True
+                , \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]
+                , \ body     -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg)
+                                -- varToCoreExpr important here: arg can be a coercion
+                                -- Lacking this caused Trac #10658
+                , arg_ty1 ) }
+
+  | otherwise   -- The general case
+        -- Wrapper: case (..call worker..) of (# a, b #) -> C a b
+        -- Worker:  case (   ...body...  ) of C a b -> (# a, b #)
+  = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM
+       ; let wrap_wild   = mk_ww_local wild_uniq (ubx_tup_ty,MarkedStrict)
+             args        = zipWith mk_ww_local uniqs arg_tys
+             ubx_tup_ty  = exprType ubx_tup_app
+             ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args)
+             con_app     = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co
+
+       ; return (True
+                , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt (tupleDataCon Unboxed (length arg_tys)), args, con_app)]
+                , \ body     -> mkUnpackCase body co work_uniq data_con args ubx_tup_app
+                , ubx_tup_ty ) }
+
+mkUnpackCase ::  CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr
+-- (mkUnpackCase e co uniq Con args body)
+--      returns
+-- case e |> co of bndr { Con args -> body }
+
+mkUnpackCase (Tick tickish e) co uniq con args body   -- See Note [Profiling and unpacking]
+  = Tick tickish (mkUnpackCase e co uniq con args body)
+mkUnpackCase scrut co uniq boxing_con unpk_args body
+  = Case casted_scrut bndr (exprType body)
+         [(DataAlt boxing_con, unpk_args, body)]
+  where
+    casted_scrut = scrut `mkCast` co
+    bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict)
+
+{-
+Note [non-algebraic or open body type warning]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+There are a few cases where the W/W transformation is told that something
+returns a constructor, but the type at hand doesn't really match this. One
+real-world example involves unsafeCoerce:
+  foo = IO a
+  foo = unsafeCoerce c_exit
+  foreign import ccall "c_exit" c_exit :: IO ()
+Here CPR will tell you that `foo` returns a () constructor for sure, but trying
+to create a worker/wrapper for type `a` obviously fails.
+(This was a real example until ee8e792  in libraries/base.)
+
+It does not seem feasible to avoid all such cases already in the analyser (and
+after all, the analysis is not really wrong), so we simply do nothing here in
+mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch
+other cases where something went avoidably wrong.
+
+
+Note [Profiling and unpacking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the original function looked like
+        f = \ x -> {-# SCC "foo" #-} E
+
+then we want the CPR'd worker to look like
+        \ x -> {-# SCC "foo" #-} (case E of I# x -> x)
+and definitely not
+        \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)
+
+This transform doesn't move work or allocation
+from one cost centre to another.
+
+Later [SDM]: presumably this is because we want the simplifier to
+eliminate the case, and the scc would get in the way?  I'm ok with
+including the case itself in the cost centre, since it is morally
+part of the function (post transformation) anyway.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Utilities}
+*                                                                      *
+************************************************************************
+
+Note [Absent errors]
+~~~~~~~~~~~~~~~~~~~~
+We make a new binding for Ids that are marked absent, thus
+   let x = absentError "x :: Int"
+The idea is that this binding will never be used; but if it
+buggily is used we'll get a runtime error message.
+
+Coping with absence for *unlifted* types is important; see, for
+example, Trac #4306 and Trac #15627.  In the UnliftedRep case, we can
+use LitRubbish, which we need to apply to the required type.
+For the unlifted types of singleton kind like Float#, Addr#, etc. we
+also find a suitable literal, using Literal.absentLiteralOf.  We don't
+have literals for every primitive type, so the function is partial.
+
+Note: I did try the experiment of using an error thunk for unlifted
+things too, relying on the simplifier to drop it as dead code.
+But this is fragile
+
+ - It fails when profiling is on, which disables various optimisations
+
+ - It fails when reboxing happens. E.g.
+      data T = MkT Int Int#
+      f p@(MkT a _) = ...g p....
+   where g is /lazy/ in 'p', but only uses the first component.  Then
+   'f' is /strict/ in 'p', and only uses the first component.  So we only
+   pass that component to the worker for 'f', which reconstructs 'p' to
+   pass it to 'g'.  Alas we can't say
+       ...f (MkT a (absentError Int# "blah"))...
+   bacause `MkT` is strict in its Int# argument, so we get an absentError
+   exception when we shouldn't.  Very annoying!
+
+So absentError is only used for lifted types.
+-}
+
+-- | Tries to find a suitable dummy RHS to bind the given absent identifier to.
+--
+-- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding
+-- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be
+-- found (currently only happens for bindings of 'VecRep' representation).
+mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)
+mk_absent_let dflags arg
+  -- The lifted case: Bind 'absentError'
+  -- See Note [Absent errors]
+  | not (isUnliftedType arg_ty)
+  = Just (Let (NonRec lifted_arg abs_rhs))
+  -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@
+  -- See Note [Absent errors]
+  | [UnliftedRep] <- typePrimRep arg_ty
+  = Just (Let (NonRec arg unlifted_rhs))
+  -- The monomorphic unlifted cases: Bind to some literal, if possible
+  -- See Note [Absent errors]
+  | Just tc <- tyConAppTyCon_maybe arg_ty
+  , Just lit <- absentLiteralOf tc
+  = Just (Let (NonRec arg (Lit lit)))
+  | arg_ty `eqType` voidPrimTy
+  = Just (Let (NonRec arg (Var voidPrimId)))
+  | otherwise
+  = WARN( True, text "No absent value for" <+> ppr arg_ty )
+    Nothing -- Can happen for 'State#' and things of 'VecRep'
+  where
+    lifted_arg   = arg `setIdStrictness` exnSig
+              -- Note in strictness signature that this is bottoming
+              -- (for the sake of the "empty case scrutinee not known to
+              -- diverge for sure lint" warning)
+    arg_ty       = idType arg
+    abs_rhs      = mkAbsentErrorApp arg_ty msg
+    msg          = showSDoc (gopt_set dflags Opt_SuppressUniques)
+                          (ppr arg <+> ppr (idType arg))
+              -- We need to suppress uniques here because otherwise they'd
+              -- end up in the generated code as strings. This is bad for
+              -- determinism, because with different uniques the strings
+              -- will have different lengths and hence different costs for
+              -- the inliner leading to different inlining.
+              -- See also Note [Unique Determinism] in Unique
+    unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty]
+
+mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id
+-- The StrictnessMark comes form the data constructor and says
+-- whether this field is strict
+-- See Note [Record evaluated-ness in worker/wrapper]
+mk_ww_local uniq (ty,str)
+  = setCaseBndrEvald str $
+    mkSysLocalOrCoVar (fsLit "ww") uniq ty
diff --git a/compiler/typecheck/ClsInst.hs b/compiler/typecheck/ClsInst.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/ClsInst.hs
@@ -0,0 +1,699 @@
+{-# LANGUAGE CPP #-}
+
+module ClsInst (
+     matchGlobalInst,
+     ClsInstResult(..),
+     InstanceWhat(..), safeOverlap,
+     AssocInstInfo(..), isNotAssociated
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcEnv
+import TcRnMonad
+import TcType
+import TcMType
+import TcEvidence
+import RnEnv( addUsedGRE )
+import RdrName( lookupGRE_FieldLabel )
+import InstEnv
+import Inst( instDFunType )
+import FamInst( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )
+
+import TysWiredIn
+import TysPrim( eqPrimTyCon, eqReprPrimTyCon )
+import PrelNames
+
+import Id
+import Type
+import MkCore ( mkStringExprFS, mkNaturalExpr )
+
+import Name   ( Name )
+import VarEnv ( VarEnv )
+import DataCon
+import TyCon
+import Class
+import DynFlags
+import Outputable
+import Util( splitAtList, fstOf3 )
+import Data.Maybe
+
+{- *******************************************************************
+*                                                                    *
+              A helper for associated types within
+              class instance declarations
+*                                                                    *
+**********************************************************************-}
+
+-- | Extra information about the parent instance declaration, needed
+-- when type-checking associated types. The 'Class' is the enclosing
+-- class, the [TyVar] are the /scoped/ type variable of the instance decl.
+-- The @VarEnv Type@ maps class variables to their instance types.
+data AssocInstInfo
+  = NotAssociated
+  | InClsInst { ai_class    :: Class
+              , ai_tyvars   :: [TyVar]      -- ^ The /scoped/ tyvars of the instance
+                                            -- Why scoped?  See bind_me in
+                                            -- TcValidity.checkConsistentFamInst
+              , ai_inst_env :: VarEnv Type  -- ^ Maps /class/ tyvars to their instance types
+                -- See Note [Matching in the consistent-instantation check]
+    }
+
+isNotAssociated :: AssocInstInfo -> Bool
+isNotAssociated NotAssociated  = True
+isNotAssociated (InClsInst {}) = False
+
+
+{- *******************************************************************
+*                                                                    *
+                       Class lookup
+*                                                                    *
+**********************************************************************-}
+
+-- | Indicates if Instance met the Safe Haskell overlapping instances safety
+-- check.
+--
+-- See Note [Safe Haskell Overlapping Instances] in TcSimplify
+-- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify
+type SafeOverlapping = Bool
+
+data ClsInstResult
+  = NoInstance   -- Definitely no instance
+
+  | OneInst { cir_new_theta :: [TcPredType]
+            , cir_mk_ev     :: [EvExpr] -> EvTerm
+            , cir_what      :: InstanceWhat }
+
+  | NotSure      -- Multiple matches and/or one or more unifiers
+
+data InstanceWhat
+  = BuiltinInstance
+  | LocalInstance
+  | TopLevInstance { iw_dfun_id   :: DFunId
+                   , iw_safe_over :: SafeOverlapping }
+
+instance Outputable ClsInstResult where
+  ppr NoInstance = text "NoInstance"
+  ppr NotSure    = text "NotSure"
+  ppr (OneInst { cir_new_theta = ev
+               , cir_what = what })
+    = text "OneInst" <+> vcat [ppr ev, ppr what]
+
+instance Outputable InstanceWhat where
+  ppr BuiltinInstance = text "built-in instance"
+  ppr LocalInstance   = text "locally-quantified instance"
+  ppr (TopLevInstance { iw_safe_over = so })
+     = text "top-level instance" <+> (text $ if so then "[safe]" else "[unsafe]")
+
+safeOverlap :: InstanceWhat -> Bool
+safeOverlap (TopLevInstance { iw_safe_over = so }) = so
+safeOverlap _                                      = True
+
+matchGlobalInst :: DynFlags
+                -> Bool      -- True <=> caller is the short-cut solver
+                             -- See Note [Shortcut solving: overlap]
+                -> Class -> [Type] -> TcM ClsInstResult
+matchGlobalInst dflags short_cut clas tys
+  | cls_name == knownNatClassName
+  = matchKnownNat    dflags short_cut clas tys
+  | cls_name == knownSymbolClassName
+  = matchKnownSymbol dflags short_cut clas tys
+  | isCTupleClass clas                = matchCTuple          clas tys
+  | cls_name == typeableClassName     = matchTypeable        clas tys
+  | clas `hasKey` heqTyConKey         = matchHeteroEquality       tys
+  | clas `hasKey` eqTyConKey          = matchHomoEquality         tys
+  | clas `hasKey` coercibleTyConKey   = matchCoercible            tys
+  | cls_name == hasFieldClassName     = matchHasField dflags short_cut clas tys
+  | otherwise                         = matchInstEnv dflags short_cut clas tys
+  where
+    cls_name = className clas
+
+
+{- ********************************************************************
+*                                                                     *
+                   Looking in the instance environment
+*                                                                     *
+***********************************************************************-}
+
+
+matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
+matchInstEnv dflags short_cut_solver clas tys
+   = do { instEnvs <- tcGetInstEnvs
+        ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy]
+              (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys
+              safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps)
+        ; traceTc "matchInstEnv" $
+            vcat [ text "goal:" <+> ppr clas <+> ppr tys
+                 , text "matches:" <+> ppr matches
+                 , text "unify:" <+> ppr unify ]
+        ; case (matches, unify, safeHaskFail) of
+
+            -- Nothing matches
+            ([], [], _)
+                -> do { traceTc "matchClass not matching" (ppr pred)
+                      ; return NoInstance }
+
+            -- A single match (& no safe haskell failure)
+            ([(ispec, inst_tys)], [], False)
+                | short_cut_solver      -- Called from the short-cut solver
+                , isOverlappable ispec
+                -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT
+                -- then don't let the short-cut solver choose it, because a
+                -- later instance might overlap it.  Trac #14434 is an example
+                -- See Note [Shortcut solving: overlap]
+                -> do { traceTc "matchClass: ignoring overlappable" (ppr pred)
+                      ; return NotSure }
+
+                | otherwise
+                -> do { let dfun_id = instanceDFunId ispec
+                      ; traceTc "matchClass success" $
+                        vcat [text "dict" <+> ppr pred,
+                              text "witness" <+> ppr dfun_id
+                                             <+> ppr (idType dfun_id) ]
+                                -- Record that this dfun is needed
+                      ; match_one (null unsafeOverlaps) dfun_id inst_tys }
+
+            -- More than one matches (or Safe Haskell fail!). Defer any
+            -- reactions of a multitude until we learn more about the reagent
+            _   -> do { traceTc "matchClass multiple matches, deferring choice" $
+                        vcat [text "dict" <+> ppr pred,
+                              text "matches" <+> ppr matches]
+                      ; return NotSure } }
+   where
+     pred = mkClassPred clas tys
+
+match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcM ClsInstResult
+             -- See Note [DFunInstType: instantiating types] in InstEnv
+match_one so dfun_id mb_inst_tys
+  = do { traceTc "match_one" (ppr dfun_id $$ ppr mb_inst_tys)
+       ; (tys, theta) <- instDFunType dfun_id mb_inst_tys
+       ; traceTc "match_one 2" (ppr dfun_id $$ ppr tys $$ ppr theta)
+       ; return $ OneInst { cir_new_theta = theta
+                          , cir_mk_ev     = evDFunApp dfun_id tys
+                          , cir_what      = TopLevInstance { iw_dfun_id = dfun_id
+                                                           , iw_safe_over = so } } }
+
+
+{- Note [Shortcut solving: overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+  instance {-# OVERLAPPABLE #-} C a where ...
+and we are typechecking
+  f :: C a => a -> a
+  f = e  -- Gives rise to [W] C a
+
+We don't want to solve the wanted constraint with the overlappable
+instance; rather we want to use the supplied (C a)! That was the whole
+point of it being overlappable!  Trac #14434 wwas an example.
+
+Alas even if the instance has no overlap flag, thus
+  instance C a where ...
+there is nothing to stop it being overlapped. GHC provides no way to
+declare an instance as "final" so it can't be overlapped.  But really
+only final instances are OK for short-cut solving.  Sigh. Trac #15135
+was a puzzling example.
+-}
+
+
+{- ********************************************************************
+*                                                                     *
+                   Class lookup for CTuples
+*                                                                     *
+***********************************************************************-}
+
+matchCTuple :: Class -> [Type] -> TcM ClsInstResult
+matchCTuple clas tys   -- (isCTupleClass clas) holds
+  = return (OneInst { cir_new_theta = tys
+                    , cir_mk_ev     = tuple_ev
+                    , cir_what      = BuiltinInstance })
+            -- The dfun *is* the data constructor!
+  where
+     data_con = tyConSingleDataCon (classTyCon clas)
+     tuple_ev = evDFunApp (dataConWrapId data_con) tys
+
+{- ********************************************************************
+*                                                                     *
+                   Class lookup for Literals
+*                                                                     *
+***********************************************************************-}
+
+{-
+Note [KnownNat & KnownSymbol and EvLit]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A part of the type-level literals implementation are the classes
+"KnownNat" and "KnownSymbol", which provide a "smart" constructor for
+defining singleton values.  Here is the key stuff from GHC.TypeLits
+
+  class KnownNat (n :: Nat) where
+    natSing :: SNat n
+
+  newtype SNat (n :: Nat) = SNat Integer
+
+Conceptually, this class has infinitely many instances:
+
+  instance KnownNat 0       where natSing = SNat 0
+  instance KnownNat 1       where natSing = SNat 1
+  instance KnownNat 2       where natSing = SNat 2
+  ...
+
+In practice, we solve `KnownNat` predicates in the type-checker
+(see typecheck/TcInteract.hs) because we can't have infinitely many instances.
+The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`.
+
+We make the following assumptions about dictionaries in GHC:
+  1. The "dictionary" for classes with a single method---like `KnownNat`---is
+     a newtype for the type of the method, so using a evidence amounts
+     to a coercion, and
+  2. Newtypes use the same representation as their definition types.
+
+So, the evidence for `KnownNat` is just a value of the representation type,
+wrapped in two newtype constructors: one to make it into a `SNat` value,
+and another to make it into a `KnownNat` dictionary.
+
+Also note that `natSing` and `SNat` are never actually exposed from the
+library---they are just an implementation detail.  Instead, users see
+a more convenient function, defined in terms of `natSing`:
+
+  natVal :: KnownNat n => proxy n -> Integer
+
+The reason we don't use this directly in the class is that it is simpler
+and more efficient to pass around an integer rather than an entire function,
+especially when the `KnowNat` evidence is packaged up in an existential.
+
+The story for kind `Symbol` is analogous:
+  * class KnownSymbol
+  * newtype SSymbol
+  * Evidence: a Core literal (e.g. mkNaturalExpr)
+
+
+Note [Fabricating Evidence for Literals in Backpack]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Let `T` be a type of kind `Nat`. When solving for a purported instance
+of `KnownNat T`, ghc tries to resolve the type `T` to an integer `n`,
+in which case the evidence `EvLit (EvNum n)` is generated on the
+fly. It might appear that this is sufficient as users cannot define
+their own instances of `KnownNat`. However, for backpack module this
+would not work (see issue #15379). Consider the signature `Abstract`
+
+> signature Abstract where
+>   data T :: Nat
+>   instance KnownNat T
+
+and a module `Util` that depends on it:
+
+> module Util where
+>  import Abstract
+>  printT :: IO ()
+>  printT = do print $ natVal (Proxy :: Proxy T)
+
+Clearly, we need to "use" the dictionary associated with `KnownNat T`
+in the module `Util`, but it is too early for the compiler to produce
+a real dictionary as we still have not fixed what `T` is. Only when we
+mixin a concrete module
+
+> module Concrete where
+>   type T = 42
+
+do we really get hold of the underlying integer. So the strategy that
+we follow is the following
+
+1. If T is indeed available as a type alias for an integer constant,
+   generate the dictionary on the fly, failing which
+
+2. Look up the type class environment for the evidence.
+
+Finally actual code gets generate for Util only when a module like
+Concrete gets "mixed-in" in place of the signature Abstract. As a
+result all things, including the typeclass instances, in Concrete gets
+reexported. So `KnownNat` gets resolved the normal way post-Backpack.
+
+A similar generation works for `KnownSymbol` as well
+
+-}
+
+matchKnownNat :: DynFlags
+              -> Bool      -- True <=> caller is the short-cut solver
+                           -- See Note [Shortcut solving: overlap]
+              -> Class -> [Type] -> TcM ClsInstResult
+matchKnownNat _ _ clas [ty]     -- clas = KnownNat
+  | Just n <- isNumLitTy ty = do
+        et <- mkNaturalExpr n
+        makeLitDict clas ty et
+matchKnownNat df sc clas tys = matchInstEnv df sc clas tys
+ -- See Note [Fabricating Evidence for Literals in Backpack] for why
+ -- this lookup into the instance environment is required.
+
+matchKnownSymbol :: DynFlags
+                 -> Bool      -- True <=> caller is the short-cut solver
+                              -- See Note [Shortcut solving: overlap]
+                 -> Class -> [Type] -> TcM ClsInstResult
+matchKnownSymbol _ _ clas [ty]  -- clas = KnownSymbol
+  | Just s <- isStrLitTy ty = do
+        et <- mkStringExprFS s
+        makeLitDict clas ty et
+matchKnownSymbol df sc clas tys = matchInstEnv df sc clas tys
+ -- See Note [Fabricating Evidence for Literals in Backpack] for why
+ -- this lookup into the instance environment is required.
+
+makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult
+-- makeLitDict adds a coercion that will convert the literal into a dictionary
+-- of the appropriate type.  See Note [KnownNat & KnownSymbol and EvLit]
+-- in TcEvidence.  The coercion happens in 2 steps:
+--
+--     Integer -> SNat n     -- representation of literal to singleton
+--     SNat n  -> KnownNat n -- singleton to dictionary
+--
+--     The process is mirrored for Symbols:
+--     String    -> SSymbol n
+--     SSymbol n -> KnownSymbol n
+makeLitDict clas ty et
+    | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]
+          -- co_dict :: KnownNat n ~ SNat n
+    , [ meth ]   <- classMethods clas
+    , Just tcRep <- tyConAppTyCon_maybe -- SNat
+                      $ funResultTy         -- SNat n
+                      $ dropForAlls         -- KnownNat n => SNat n
+                      $ idType meth         -- forall n. KnownNat n => SNat n
+    , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
+          -- SNat n ~ Integer
+    , let ev_tm = mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep))
+    = return $ OneInst { cir_new_theta = []
+                       , cir_mk_ev     = \_ -> ev_tm
+                       , cir_what      = BuiltinInstance }
+
+    | otherwise
+    = pprPanic "makeLitDict" $
+      text "Unexpected evidence for" <+> ppr (className clas)
+      $$ vcat (map (ppr . idType) (classMethods clas))
+
+{- ********************************************************************
+*                                                                     *
+                   Class lookup for Typeable
+*                                                                     *
+***********************************************************************-}
+
+-- | Assumes that we've checked that this is the 'Typeable' class,
+-- and it was applied to the correct argument.
+matchTypeable :: Class -> [Type] -> TcM ClsInstResult
+matchTypeable clas [k,t]  -- clas = Typeable
+  -- For the first two cases, See Note [No Typeable for polytypes or qualified types]
+  | isForAllTy k                      = return NoInstance   -- Polytype
+  | isJust (tcSplitPredFunTy_maybe t) = return NoInstance   -- Qualified type
+
+  -- Now cases that do work
+  | k `eqType` typeNatKind                 = doTyLit knownNatClassName         t
+  | k `eqType` typeSymbolKind              = doTyLit knownSymbolClassName      t
+  | tcIsConstraintKind t                   = doTyConApp clas t constraintKindTyCon []
+  | Just (arg,ret) <- splitFunTy_maybe t   = doFunTy    clas t arg ret
+  | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)]
+  , onlyNamedBndrsApplied tc ks            = doTyConApp clas t tc ks
+  | Just (f,kt)   <- splitAppTy_maybe t    = doTyApp    clas t f kt
+
+matchTypeable _ _ = return NoInstance
+
+-- | Representation for a type @ty@ of the form @arg -> ret@.
+doFunTy :: Class -> Type -> Type -> Type -> TcM ClsInstResult
+doFunTy clas ty arg_ty ret_ty
+  = return $ OneInst { cir_new_theta = preds
+                     , cir_mk_ev     = mk_ev
+                     , cir_what      = BuiltinInstance }
+  where
+    preds = map (mk_typeable_pred clas) [arg_ty, ret_ty]
+    mk_ev [arg_ev, ret_ev] = evTypeable ty $
+                             EvTypeableTrFun (EvExpr arg_ev) (EvExpr ret_ev)
+    mk_ev _ = panic "TcInteract.doFunTy"
+
+
+-- | Representation for type constructor applied to some kinds.
+-- 'onlyNamedBndrsApplied' has ensured that this application results in a type
+-- of monomorphic kind (e.g. all kind variables have been instantiated).
+doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult
+doTyConApp clas ty tc kind_args
+  | Just _ <- tyConRepName_maybe tc
+  = return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args)
+                     , cir_mk_ev     = mk_ev
+                     , cir_what      = BuiltinInstance }
+  | otherwise
+  = return NoInstance
+  where
+    mk_ev kinds = evTypeable ty $ EvTypeableTyCon tc (map EvExpr kinds)
+
+-- | Representation for TyCon applications of a concrete kind. We just use the
+-- kind itself, but first we must make sure that we've instantiated all kind-
+-- polymorphism, but no more.
+onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool
+onlyNamedBndrsApplied tc ks
+ = all isNamedTyConBinder used_bndrs &&
+   not (any isNamedTyConBinder leftover_bndrs)
+ where
+   bndrs                        = tyConBinders tc
+   (used_bndrs, leftover_bndrs) = splitAtList ks bndrs
+
+doTyApp :: Class -> Type -> Type -> KindOrType -> TcM ClsInstResult
+-- Representation for an application of a type to a type-or-kind.
+--  This may happen when the type expression starts with a type variable.
+--  Example (ignoring kind parameter):
+--    Typeable (f Int Char)                      -->
+--    (Typeable (f Int), Typeable Char)          -->
+--    (Typeable f, Typeable Int, Typeable Char)  --> (after some simp. steps)
+--    Typeable f
+doTyApp clas ty f tk
+  | isForAllTy (tcTypeKind f)
+  = return NoInstance -- We can't solve until we know the ctr.
+  | otherwise
+  = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) [f, tk]
+                     , cir_mk_ev     = mk_ev
+                     , cir_what      = BuiltinInstance }
+  where
+    mk_ev [t1,t2] = evTypeable ty $ EvTypeableTyApp (EvExpr t1) (EvExpr t2)
+    mk_ev _ = panic "doTyApp"
+
+
+-- Emit a `Typeable` constraint for the given type.
+mk_typeable_pred :: Class -> Type -> PredType
+mk_typeable_pred clas ty = mkClassPred clas [ tcTypeKind ty, ty ]
+
+  -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal
+  -- we generate a sub-goal for the appropriate class.
+  -- See Note [Typeable for Nat and Symbol]
+doTyLit :: Name -> Type -> TcM ClsInstResult
+doTyLit kc t = do { kc_clas <- tcLookupClass kc
+                  ; let kc_pred    = mkClassPred kc_clas [ t ]
+                        mk_ev [ev] = evTypeable t $ EvTypeableTyLit (EvExpr ev)
+                        mk_ev _    = panic "doTyLit"
+                  ; return (OneInst { cir_new_theta = [kc_pred]
+                                    , cir_mk_ev     = mk_ev
+                                    , cir_what      = BuiltinInstance }) }
+
+{- Note [Typeable (T a b c)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For type applications we always decompose using binary application,
+via doTyApp, until we get to a *kind* instantiation.  Example
+   Proxy :: forall k. k -> *
+
+To solve Typeable (Proxy (* -> *) Maybe) we
+  - First decompose with doTyApp,
+    to get (Typeable (Proxy (* -> *))) and Typeable Maybe
+  - Then solve (Typeable (Proxy (* -> *))) with doTyConApp
+
+If we attempt to short-cut by solving it all at once, via
+doTyConApp
+
+(this note is sadly truncated FIXME)
+
+
+Note [No Typeable for polytypes or qualified types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not support impredicative typeable, such as
+   Typeable (forall a. a->a)
+   Typeable (Eq a => a -> a)
+   Typeable (() => Int)
+   Typeable (((),()) => Int)
+
+See Trac #9858.  For forall's the case is clear: we simply don't have
+a TypeRep for them.  For qualified but not polymorphic types, like
+(Eq a => a -> a), things are murkier.  But:
+
+ * We don't need a TypeRep for these things.  TypeReps are for
+   monotypes only.
+
+ * Perhaps we could treat `=>` as another type constructor for `Typeable`
+   purposes, and thus support things like `Eq Int => Int`, however,
+   at the current state of affairs this would be an odd exception as
+   no other class works with impredicative types.
+   For now we leave it off, until we have a better story for impredicativity.
+
+
+Note [Typeable for Nat and Symbol]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have special Typeable instances for Nat and Symbol.  Roughly we
+have this instance, implemented here by doTyLit:
+      instance KnownNat n => Typeable (n :: Nat) where
+         typeRep = typeNatTypeRep @n
+where
+   Data.Typeable.Internals.typeNatTypeRep :: KnownNat a => TypeRep a
+
+Ultimately typeNatTypeRep uses 'natSing' from KnownNat to get a
+runtime value 'n'; it turns it into a string with 'show' and uses
+that to whiz up a TypeRep TyCon for 'n', with mkTypeLitTyCon.
+See #10348.
+
+Because of this rule it's inadvisable (see #15322) to have a constraint
+    f :: (Typeable (n :: Nat)) => blah
+in a function signature; it gives rise to overlap problems just as
+if you'd written
+    f :: Eq [a] => blah
+-}
+
+{- ********************************************************************
+*                                                                     *
+                   Class lookup for lifted equality
+*                                                                     *
+***********************************************************************-}
+
+-- See also Note [The equality types story] in TysPrim
+matchHeteroEquality :: [Type] -> TcM ClsInstResult
+-- Solves (t1 ~~ t2)
+matchHeteroEquality args
+  = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon args ]
+                    , cir_mk_ev     = evDataConApp heqDataCon args
+                    , cir_what      = BuiltinInstance })
+
+matchHomoEquality :: [Type] -> TcM ClsInstResult
+-- Solves (t1 ~ t2)
+matchHomoEquality args@[k,t1,t2]
+  = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon [k,k,t1,t2] ]
+                    , cir_mk_ev     = evDataConApp eqDataCon args
+                    , cir_what      = BuiltinInstance })
+matchHomoEquality args = pprPanic "matchHomoEquality" (ppr args)
+
+-- See also Note [The equality types story] in TysPrim
+matchCoercible :: [Type] -> TcM ClsInstResult
+matchCoercible args@[k, t1, t2]
+  = return (OneInst { cir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ]
+                    , cir_mk_ev     = evDataConApp coercibleDataCon args
+                    , cir_what      = BuiltinInstance })
+  where
+    args' = [k, k, t1, t2]
+matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args)
+
+
+{- ********************************************************************
+*                                                                     *
+              Class lookup for overloaded record fields
+*                                                                     *
+***********************************************************************-}
+
+{-
+Note [HasField instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+    data T y = MkT { foo :: [y] }
+
+and `foo` is in scope.  Then GHC will automatically solve a constraint like
+
+    HasField "foo" (T Int) b
+
+by emitting a new wanted
+
+    T alpha -> [alpha] ~# T Int -> b
+
+and building a HasField dictionary out of the selector function `foo`,
+appropriately cast.
+
+The HasField class is defined (in GHC.Records) thus:
+
+    class HasField (x :: k) r a | x r -> a where
+      getField :: r -> a
+
+Since this is a one-method class, it is represented as a newtype.
+Hence we can solve `HasField "foo" (T Int) b` by taking an expression
+of type `T Int -> b` and casting it using the newtype coercion.
+Note that
+
+    foo :: forall y . T y -> [y]
+
+so the expression we construct is
+
+    foo @alpha |> co
+
+where
+
+    co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b
+
+is built from
+
+    co1 :: (T alpha -> [alpha]) ~# (T Int -> b)
+
+which is the new wanted, and
+
+    co2 :: (T Int -> b) ~# HasField "foo" (T Int) b
+
+which can be derived from the newtype coercion.
+
+If `foo` is not in scope, or has a higher-rank or existentially
+quantified type, then the constraint is not solved automatically, but
+may be solved by a user-supplied HasField instance.  Similarly, if we
+encounter a HasField constraint where the field is not a literal
+string, or does not belong to the type, then we fall back on the
+normal constraint solver behaviour.
+-}
+
+-- See Note [HasField instances]
+matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
+matchHasField dflags short_cut clas tys
+  = do { fam_inst_envs <- tcGetFamInstEnvs
+       ; rdr_env       <- getGlobalRdrEnv
+       ; case tys of
+           -- We are matching HasField {k} x r a...
+           [_k_ty, x_ty, r_ty, a_ty]
+               -- x should be a literal string
+             | Just x <- isStrLitTy x_ty
+               -- r should be an applied type constructor
+             , Just (tc, args) <- tcSplitTyConApp_maybe r_ty
+               -- use representation tycon (if data family); it has the fields
+             , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)
+               -- x should be a field of r
+             , Just fl <- lookupTyConFieldLabel x r_tc
+               -- the field selector should be in scope
+             , Just gre <- lookupGRE_FieldLabel rdr_env fl
+
+             -> do { sel_id <- tcLookupId (flSelector fl)
+                   ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id
+
+                         -- The first new wanted constraint equates the actual
+                         -- type of the selector with the type (r -> a) within
+                         -- the HasField x r a dictionary.  The preds will
+                         -- typically be empty, but if the datatype has a
+                         -- "stupid theta" then we have to include it here.
+                   ; let theta = mkPrimEqPred sel_ty (mkFunTy r_ty a_ty) : preds
+
+                         -- Use the equality proof to cast the selector Id to
+                         -- type (r -> a), then use the newtype coercion to cast
+                         -- it to a HasField dictionary.
+                         mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co
+                           where
+                             co = mkTcSubCo (evTermCoercion (EvExpr ev1))
+                                      `mkTcTransCo` mkTcSymCo co2
+                         mk_ev [] = panic "matchHasField.mk_ev"
+
+                         Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas)
+                                                              tys
+
+                         tvs = mkTyVarTys (map snd tv_prs)
+
+                     -- The selector must not be "naughty" (i.e. the field
+                     -- cannot have an existentially quantified type), and
+                     -- it must not be higher-rank.
+                   ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty
+                     then do { addUsedGRE True gre
+                             ; return OneInst { cir_new_theta = theta
+                                              , cir_mk_ev     = mk_ev
+                                              , cir_what      = BuiltinInstance } }
+                     else matchInstEnv dflags short_cut clas tys }
+
+           _ -> matchInstEnv dflags short_cut clas tys }
diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/FamInst.hs
@@ -0,0 +1,953 @@
+-- The @FamInst@ type: family instance heads
+
+{-# LANGUAGE CPP, GADTs #-}
+
+module FamInst (
+        FamInstEnvs, tcGetFamInstEnvs,
+        checkFamInstConsistency, tcExtendLocalFamInstEnv,
+        tcLookupDataFamInst, tcLookupDataFamInst_maybe,
+        tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,
+        newFamInst,
+
+        -- * Injectivity
+        makeInjectivityErrors, injTyVarsOfType, injTyVarsOfTypes
+    ) where
+
+import GhcPrelude
+
+import HscTypes
+import FamInstEnv
+import InstEnv( roughMatchTcs )
+import Coercion
+import CoreLint
+import TcEvidence
+import LoadIface
+import TcRnMonad
+import SrcLoc
+import TyCon
+import TcType
+import CoAxiom
+import DynFlags
+import Module
+import Outputable
+import Util
+import RdrName
+import DataCon ( dataConName )
+import Maybes
+import Type
+import TyCoRep
+import TcMType
+import Name
+import Pair
+import Panic
+import VarSet
+import Bag( Bag, unionBags, unitBag )
+import Control.Monad
+
+#include "HsVersions.h"
+
+{- Note [The type family instance consistency story]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+To preserve type safety we must ensure that for any given module, all
+the type family instances used either in that module or in any module
+it directly or indirectly imports are consistent. For example, consider
+
+  module F where
+    type family F a
+
+  module A where
+    import F( F )
+    type instance F Int = Bool
+    f :: F Int -> Bool
+    f x = x
+
+  module B where
+    import F( F )
+    type instance F Int = Char
+    g :: Char -> F Int
+    g x = x
+
+  module Bad where
+    import A( f )
+    import B( g )
+    bad :: Char -> Int
+    bad c = f (g c)
+
+Even though module Bad never mentions the type family F at all, by
+combining the functions f and g that were type checked in contradictory
+type family instance environments, the function bad is able to coerce
+from one type to another. So when we type check Bad we must verify that
+the type family instances defined in module A are consistent with those
+defined in module B.
+
+How do we ensure that we maintain the necessary consistency?
+
+* Call a module which defines at least one type family instance a
+  "family instance module". This flag `mi_finsts` is recorded in the
+  interface file.
+
+* For every module we calculate the set of all of its direct and
+  indirect dependencies that are family instance modules. This list
+  `dep_finsts` is also recorded in the interface file so we can compute
+  this list for a module from the lists for its direct dependencies.
+
+* When type checking a module M we check consistency of all the type
+  family instances that are either provided by its `dep_finsts` or
+  defined in the module M itself. This is a pairwise check, i.e., for
+  every pair of instances we must check that they are consistent.
+
+  - For family instances coming from `dep_finsts`, this is checked in
+    checkFamInstConsistency, called from tcRnImports. See Note
+    [Checking family instance consistency] for details on this check
+    (and in particular how we avoid having to do all these checks for
+    every module we compile).
+
+  - That leaves checking the family instances defined in M itself
+    against instances defined in either M or its `dep_finsts`. This is
+    checked in `tcExtendLocalFamInstEnv'.
+
+There are four subtle points in this scheme which have not been
+addressed yet.
+
+* We have checked consistency of the family instances *defined* by M
+  or its imports, but this is not by definition the same thing as the
+  family instances *used* by M or its imports.  Specifically, we need to
+  ensure when we use a type family instance while compiling M that this
+  instance was really defined from either M or one of its imports,
+  rather than being an instance that we happened to know about from
+  reading an interface file in the course of compiling an unrelated
+  module. Otherwise, we'll end up with no record of the fact that M
+  depends on this family instance and type safety will be compromised.
+  See #13102.
+
+* It can also happen that M uses a function defined in another module
+  which is not transitively imported by M. Examples include the
+  desugaring of various overloaded constructs, and references inserted
+  by Template Haskell splices. If that function's definition makes use
+  of type family instances which are not checked against those visible
+  from M, type safety can again be compromised. See #13251.
+
+* When a module C imports a boot module B.hs-boot, we check that C's
+  type family instances are compatible with those visible from
+  B.hs-boot. However, C will eventually be linked against a different
+  module B.hs, which might define additional type family instances which
+  are inconsistent with C's. This can also lead to loss of type safety.
+  See #9562.
+
+* The call to checkFamConsistency for imported functions occurs very
+  early (in tcRnImports) and that causes problems if the imported
+  instances use type declared in the module being compiled.
+  See Note [Loading your own hi-boot file] in LoadIface.
+-}
+
+{-
+************************************************************************
+*                                                                      *
+                 Making a FamInst
+*                                                                      *
+************************************************************************
+-}
+
+-- All type variables in a FamInst must be fresh. This function
+-- creates the fresh variables and applies the necessary substitution
+-- It is defined here to avoid a dependency from FamInstEnv on the monad
+-- code.
+
+newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst
+-- Freshen the type variables of the FamInst branches
+newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc })
+  = ASSERT2( tyCoVarsOfTypes lhs `subVarSet` tcv_set, text "lhs" <+> pp_ax )
+    ASSERT2( tyCoVarsOfType  rhs `subVarSet` tcv_set, text "rhs" <+> pp_ax )
+    ASSERT2( lhs_kind `eqType` rhs_kind, text "kind" <+> pp_ax $$ ppr lhs_kind $$ ppr rhs_kind )
+    do { (subst, tvs') <- freshenTyVarBndrs tvs
+       ; (subst, cvs') <- freshenCoVarBndrsX subst cvs
+       ; dflags <- getDynFlags
+       ; let lhs'     = substTys subst lhs
+             rhs'     = substTy  subst rhs
+             tcvs'    = tvs' ++ cvs'
+       ; ifErrsM (return ()) $ -- Don't lint when there are errors, because
+                               -- errors might mean TcTyCons.
+                               -- See Note [Recover from validity error] in TcTyClsDecls
+         when (gopt Opt_DoCoreLinting dflags) $
+           -- Check that the types involved in this instance are well formed.
+           -- Do /not/ expand type synonyms, for the reasons discussed in
+           -- Note [Linting type synonym applications].
+           case lintTypes dflags tcvs' (rhs':lhs') of
+             Nothing       -> pure ()
+             Just fail_msg -> pprPanic "Core Lint error" (vcat [ fail_msg
+                                                               , ppr fam_tc
+                                                               , ppr subst
+                                                               , ppr tvs'
+                                                               , ppr cvs'
+                                                               , ppr lhs'
+                                                               , ppr rhs' ])
+       ; return (FamInst { fi_fam      = tyConName fam_tc
+                         , fi_flavor   = flavor
+                         , fi_tcs      = roughMatchTcs lhs
+                         , fi_tvs      = tvs'
+                         , fi_cvs      = cvs'
+                         , fi_tys      = lhs'
+                         , fi_rhs      = rhs'
+                         , fi_axiom    = axiom }) }
+  where
+    lhs_kind = tcTypeKind (mkTyConApp fam_tc lhs)
+    rhs_kind = tcTypeKind rhs
+    tcv_set  = mkVarSet (tvs ++ cvs)
+    pp_ax    = pprCoAxiom axiom
+    CoAxBranch { cab_tvs = tvs
+               , cab_cvs = cvs
+               , cab_lhs = lhs
+               , cab_rhs = rhs } = coAxiomSingleBranch axiom
+
+
+{-
+************************************************************************
+*                                                                      *
+        Optimised overlap checking for family instances
+*                                                                      *
+************************************************************************
+
+Note [Checking family instance consistency]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For any two family instance modules that we import directly or indirectly, we
+check whether the instances in the two modules are consistent, *unless* we can
+be certain that the instances of the two modules have already been checked for
+consistency during the compilation of modules that we import.
+
+Why do we need to check?  Consider
+   module X1 where                module X2 where
+    data T1                         data T2
+    type instance F T1 b = Int      type instance F a T2 = Char
+    f1 :: F T1 a -> Int             f2 :: Char -> F a T2
+    f1 x = x                        f2 x = x
+
+Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char.
+Notice that neither instance is an orphan.
+
+How do we know which pairs of modules have already been checked? For each
+module M we directly import, we look up the family instance modules that M
+imports (directly or indirectly), say F1, ..., FN. For any two modules
+among M, F1, ..., FN, we know that the family instances defined in those
+two modules are consistent--because we checked that when we compiled M.
+
+For every other pair of family instance modules we import (directly or
+indirectly), we check that they are consistent now. (So that we can be
+certain that the modules in our `HscTypes.dep_finsts' are consistent.)
+
+There is some fancy footwork regarding hs-boot module loops, see
+Note [Don't check hs-boot type family instances too early]
+
+Note [Checking family instance optimization]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As explained in Note [Checking family instance consistency]
+we need to ensure that every pair of transitive imports that define type family
+instances is consistent.
+
+Let's define df(A) = transitive imports of A that define type family instances
++ A, if A defines type family instances
+
+Then for every direct import A, df(A) is already consistent.
+
+Let's name the current module M.
+
+We want to make sure that df(M) is consistent.
+df(M) = df(D_1) U df(D_2) U ... U df(D_i) where D_1 .. D_i are direct imports.
+
+We perform the check iteratively, maintaining a set of consistent modules 'C'
+and trying to add df(D_i) to it.
+
+The key part is how to ensure that the union C U df(D_i) is consistent.
+
+Let's consider two modules: A and B from C U df(D_i).
+There are nine possible ways to choose A and B from C U df(D_i):
+
+             | A in C only      | A in C and B in df(D_i) | A in df(D_i) only
+--------------------------------------------------------------------------------
+B in C only  | Already checked  | Already checked         | Needs to be checked
+             | when checking C  | when checking C         |
+--------------------------------------------------------------------------------
+B in C and   | Already checked  | Already checked         | Already checked when
+B in df(D_i) | when checking C  | when checking C         | checking df(D_i)
+--------------------------------------------------------------------------------
+B in df(D_i) | Needs to be      | Already checked         | Already checked when
+only         | checked          | when checking df(D_i)   | checking df(D_i)
+
+That means to ensure that C U df(D_i) is consistent we need to check every
+module from C - df(D_i) against every module from df(D_i) - C and
+every module from df(D_i) - C against every module from C - df(D_i).
+But since the checks are symmetric it suffices to pick A from C - df(D_i)
+and B from df(D_i) - C.
+
+In other words these are the modules we need to check:
+  [ (m1, m2) | m1 <- C, m1 not in df(D_i)
+             , m2 <- df(D_i), m2 not in C ]
+
+One final thing to note here is that if there's lot of overlap between
+subsequent df(D_i)'s then we expect those set differences to be small.
+That situation should be pretty common in practice, there's usually
+a set of utility modules that every module imports directly or indirectly.
+
+This is basically the idea from #13092, comment:14.
+-}
+
+-- This function doesn't check ALL instances for consistency,
+-- only ones that aren't involved in recursive knot-tying
+-- loops; see Note [Don't check hs-boot type family instances too early].
+-- We don't need to check the current module, this is done in
+-- tcExtendLocalFamInstEnv.
+-- See Note [The type family instance consistency story].
+checkFamInstConsistency :: [Module] -> TcM ()
+checkFamInstConsistency directlyImpMods
+  = do { dflags     <- getDynFlags
+       ; (eps, hpt) <- getEpsAndHpt
+       ; traceTc "checkFamInstConsistency" (ppr directlyImpMods)
+       ; let { -- Fetch the iface of a given module.  Must succeed as
+               -- all directly imported modules must already have been loaded.
+               modIface mod =
+                 case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of
+                   Nothing    -> panicDoc "FamInst.checkFamInstConsistency"
+                                          (ppr mod $$ pprHPT hpt)
+                   Just iface -> iface
+
+               -- Which family instance modules were checked for consistency
+               -- when we compiled `mod`?
+               -- Itself (if a family instance module) and its dep_finsts.
+               -- This is df(D_i) from
+               -- Note [Checking family instance optimization]
+             ; modConsistent :: Module -> [Module]
+             ; modConsistent mod =
+                 if mi_finsts (modIface mod) then mod:deps else deps
+                 where
+                 deps = dep_finsts . mi_deps . modIface $ mod
+
+             ; hmiModule     = mi_module . hm_iface
+             ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv
+                               . md_fam_insts . hm_details
+             ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)
+                                           | hmi <- eltsHpt hpt]
+
+             }
+
+       ; checkMany hpt_fam_insts modConsistent directlyImpMods
+       }
+  where
+    -- See Note [Checking family instance optimization]
+    checkMany
+      :: ModuleEnv FamInstEnv   -- home package family instances
+      -> (Module -> [Module])   -- given A, modules checked when A was checked
+      -> [Module]               -- modules to process
+      -> TcM ()
+    checkMany hpt_fam_insts modConsistent mods = go [] emptyModuleSet mods
+      where
+      go :: [Module] -- list of consistent modules
+         -> ModuleSet -- set of consistent modules, same elements as the
+                      -- list above
+         -> [Module] -- modules to process
+         -> TcM ()
+      go _ _ [] = return ()
+      go consistent consistent_set (mod:mods) = do
+        sequence_
+          [ check hpt_fam_insts m1 m2
+          | m1 <- to_check_from_mod
+            -- loop over toCheckFromMod first, it's usually smaller,
+            -- it may even be empty
+          , m2 <- to_check_from_consistent
+          ]
+        go consistent' consistent_set' mods
+        where
+        mod_deps_consistent =  modConsistent mod
+        mod_deps_consistent_set = mkModuleSet mod_deps_consistent
+        consistent' = to_check_from_mod ++ consistent
+        consistent_set' =
+          extendModuleSetList consistent_set to_check_from_mod
+        to_check_from_consistent =
+          filterOut (`elemModuleSet` mod_deps_consistent_set) consistent
+        to_check_from_mod =
+          filterOut (`elemModuleSet` consistent_set) mod_deps_consistent
+        -- Why don't we just minusModuleSet here?
+        -- We could, but doing so means one of two things:
+        --
+        --   1. When looping over the cartesian product we convert
+        --   a set into a non-deterministicly ordered list. Which
+        --   happens to be fine for interface file determinism
+        --   in this case, today, because the order only
+        --   determines the order of deferred checks. But such
+        --   invariants are hard to keep.
+        --
+        --   2. When looping over the cartesian product we convert
+        --   a set into a deterministically ordered list - this
+        --   adds some additional cost of sorting for every
+        --   direct import.
+        --
+        --   That also explains why we need to keep both 'consistent'
+        --   and 'consistentSet'.
+        --
+        --   See also Note [ModuleEnv performance and determinism].
+    check hpt_fam_insts m1 m2
+      = do { env1' <- getFamInsts hpt_fam_insts m1
+           ; env2' <- getFamInsts hpt_fam_insts m2
+           -- We're checking each element of env1 against env2.
+           -- The cost of that is dominated by the size of env1, because
+           -- for each instance in env1 we look it up in the type family
+           -- environment env2, and lookup is cheap.
+           -- The code below ensures that env1 is the smaller environment.
+           ; let sizeE1 = famInstEnvSize env1'
+                 sizeE2 = famInstEnvSize env2'
+                 (env1, env2) = if sizeE1 < sizeE2 then (env1', env2')
+                                                   else (env2', env1')
+           -- Note [Don't check hs-boot type family instances too early]
+           -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+           -- Family instance consistency checking involves checking that
+           -- the family instances of our imported modules are consistent with
+           -- one another; this might lead you to think that this process
+           -- has nothing to do with the module we are about to typecheck.
+           -- Not so!  Consider the following case:
+           --
+           --   -- A.hs-boot
+           --   type family F a
+           --
+           --   -- B.hs
+           --   import {-# SOURCE #-} A
+           --   type instance F Int = Bool
+           --
+           --   -- A.hs
+           --   import B
+           --   type family F a
+           --
+           -- When typechecking A, we are NOT allowed to poke the TyThing
+           -- for F until we have typechecked the family.  Thus, we
+           -- can't do consistency checking for the instance in B
+           -- (checkFamInstConsistency is called during renaming).
+           -- Failing to defer the consistency check lead to #11062.
+           --
+           -- Additionally, we should also defer consistency checking when
+           -- type from the hs-boot file of the current module occurs on
+           -- the left hand side, as we will poke its TyThing when checking
+           -- for overlap.
+           --
+           --   -- F.hs
+           --   type family F a
+           --
+           --   -- A.hs-boot
+           --   import F
+           --   data T
+           --
+           --   -- B.hs
+           --   import {-# SOURCE #-} A
+           --   import F
+           --   type instance F T = Int
+           --
+           --   -- A.hs
+           --   import B
+           --   data T = MkT
+           --
+           -- In fact, it is even necessary to defer for occurrences in
+           -- the RHS, because we may test for *compatibility* in event
+           -- of an overlap.
+           --
+           -- Why don't we defer ALL of the checks to later?  Well, many
+           -- instances aren't involved in the recursive loop at all.  So
+           -- we might as well check them immediately; and there isn't
+           -- a good time to check them later in any case: every time
+           -- we finish kind-checking a type declaration and add it to
+           -- a context, we *then* consistency check all of the instances
+           -- which mentioned that type.  We DO want to check instances
+           -- as quickly as possible, so that we aren't typechecking
+           -- values with inconsistent axioms in scope.
+           --
+           -- See also Note [Tying the knot]
+           -- for why we are doing this at all.
+           ; let check_now = famInstEnvElts env1
+           ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))           check_now
+           ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now
+ }
+
+getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
+getFamInsts hpt_fam_insts mod
+  | Just env <- lookupModuleEnv hpt_fam_insts mod = return env
+  | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)
+                   ; eps <- getEps
+                   ; return (expectJust "checkFamInstConsistency" $
+                             lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
+  where
+    doc = ppr mod <+> text "is a family-instance module"
+
+{-
+************************************************************************
+*                                                                      *
+        Lookup
+*                                                                      *
+************************************************************************
+
+-}
+
+-- | If @co :: T ts ~ rep_ty@ then:
+--
+-- > instNewTyCon_maybe T ts = Just (rep_ty, co)
+--
+-- Checks for a newtype, and for being saturated
+-- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion
+tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion)
+tcInstNewTyCon_maybe = instNewTyCon_maybe
+
+-- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if
+-- there is no data family to unwrap.
+-- Returns a Representational coercion
+tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType]
+                    -> (TyCon, [TcType], Coercion)
+tcLookupDataFamInst fam_inst_envs tc tc_args
+  | Just (rep_tc, rep_args, co)
+      <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
+  = (rep_tc, rep_args, co)
+  | otherwise
+  = (tc, tc_args, mkRepReflCo (mkTyConApp tc tc_args))
+
+tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType]
+                          -> Maybe (TyCon, [TcType], Coercion)
+-- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a)
+-- and returns a coercion between the two: co :: F [a] ~R FList a.
+tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
+  | isDataFamilyTyCon tc
+  , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args
+  , FamInstMatch { fim_instance = rep_fam@(FamInst { fi_axiom = ax
+                                                   , fi_cvs   = cvs })
+                 , fim_tys      = rep_args
+                 , fim_cos      = rep_cos } <- match
+  , let rep_tc = dataFamInstRepTyCon rep_fam
+        co     = mkUnbranchedAxInstCo Representational ax rep_args
+                                      (mkCoVarCos cvs)
+  = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in FamInstEnv
+    Just (rep_tc, rep_args, co)
+
+  | otherwise
+  = Nothing
+
+-- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes,
+-- potentially looking through newtype /instances/.
+--
+-- It is only used by the type inference engine (specifically, when
+-- solving representational equality), and hence it is careful to unwrap
+-- only if the relevant data constructor is in scope.  That's why
+-- it get a GlobalRdrEnv argument.
+--
+-- It is careful not to unwrap data/newtype instances if it can't
+-- continue unwrapping.  Such care is necessary for proper error
+-- messages.
+--
+-- It does not look through type families.
+-- It does not normalise arguments to a tycon.
+--
+-- If the result is Just (rep_ty, (co, gres), rep_ty), then
+--    co : ty ~R rep_ty
+--    gres are the GREs for the data constructors that
+--                          had to be in scope
+tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs
+                              -> GlobalRdrEnv
+                              -> Type
+                              -> Maybe ((Bag GlobalRdrElt, TcCoercion), Type)
+tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty
+-- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe
+  = topNormaliseTypeX stepper plus ty
+  where
+    plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion)
+         -> (Bag GlobalRdrElt, TcCoercion)
+    plus (gres1, co1) (gres2, co2) = ( gres1 `unionBags` gres2
+                                     , co1 `mkTransCo` co2 )
+
+    stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
+    stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance
+
+    -- For newtype instances we take a double step or nothing, so that
+    -- we don't return the representation type of the newtype instance,
+    -- which would lead to terrible error messages
+    unwrap_newtype_instance rec_nts tc tys
+      | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys
+      = mapStepResult (\(gres, co1) -> (gres, co `mkTransCo` co1)) $
+        unwrap_newtype rec_nts tc' tys'
+      | otherwise = NS_Done
+
+    unwrap_newtype rec_nts tc tys
+      | Just con <- newTyConDataCon_maybe tc
+      , Just gre <- lookupGRE_Name rdr_env (dataConName con)
+           -- This is where we check that the
+           -- data constructor is in scope
+      = mapStepResult (\co -> (unitBag gre, co)) $
+        unwrapNewTypeStepper rec_nts tc tys
+
+      | otherwise
+      = NS_Done
+
+{-
+************************************************************************
+*                                                                      *
+        Extending the family instance environment
+*                                                                      *
+************************************************************************
+-}
+
+-- Add new locally-defined family instances, checking consistency with
+-- previous locally-defined family instances as well as all instances
+-- available from imported modules. This requires loading all of our
+-- imports that define family instances (if we haven't loaded them already).
+tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
+
+-- If we weren't actually given any instances to add, then we don't want
+-- to go to the bother of loading family instance module dependencies.
+tcExtendLocalFamInstEnv [] thing_inside = thing_inside
+
+-- Otherwise proceed...
+tcExtendLocalFamInstEnv fam_insts thing_inside
+ = do { -- Load family-instance modules "below" this module, so that
+        -- allLocalFamInst can check for consistency with them
+        -- See Note [The type family instance consistency story]
+        loadDependentFamInstModules fam_insts
+
+        -- Now add the instances one by one
+      ; env <- getGblEnv
+      ; (inst_env', fam_insts') <- foldlM addLocalFamInst
+                                       (tcg_fam_inst_env env, tcg_fam_insts env)
+                                       fam_insts
+
+      ; let env' = env { tcg_fam_insts    = fam_insts'
+                       , tcg_fam_inst_env = inst_env' }
+      ; setGblEnv env' thing_inside
+      }
+
+loadDependentFamInstModules :: [FamInst] -> TcM ()
+-- Load family-instance modules "below" this module, so that
+-- allLocalFamInst can check for consistency with them
+-- See Note [The type family instance consistency story]
+loadDependentFamInstModules fam_insts
+ = do { env <- getGblEnv
+      ; let this_mod = tcg_mod env
+            imports  = tcg_imports env
+
+            want_module mod  -- See Note [Home package family instances]
+              | mod == this_mod = False
+              | home_fams_only  = moduleUnitId mod == moduleUnitId this_mod
+              | otherwise       = True
+            home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts
+
+      ; loadModuleInterfaces (text "Loading family-instance modules") $
+        filter want_module (imp_finsts imports) }
+
+{- Note [Home package family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Optimization: If we're only defining type family instances
+for type families *defined in the home package*, then we
+only have to load interface files that belong to the home
+package. The reason is that there's no recursion between
+packages, so modules in other packages can't possibly define
+instances for our type families.
+
+(Within the home package, we could import a module M that
+imports us via an hs-boot file, and thereby defines an
+instance of a type family defined in this module. So we can't
+apply the same logic to avoid reading any interface files at
+all, when we define an instances for type family defined in
+the current module.
+-}
+
+-- Check that the proposed new instance is OK,
+-- and then add it to the home inst env
+-- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match]
+-- in FamInstEnv.hs
+addLocalFamInst :: (FamInstEnv,[FamInst])
+                -> FamInst
+                -> TcM (FamInstEnv, [FamInst])
+addLocalFamInst (home_fie, my_fis) fam_inst
+        -- home_fie includes home package and this module
+        -- my_fies is just the ones from this module
+  = do { traceTc "addLocalFamInst" (ppr fam_inst)
+
+           -- Unlike the case of class instances, don't override existing
+           -- instances in GHCi; it's unsound. See #7102.
+
+       ; mod <- getModule
+       ; traceTc "alfi" (ppr mod)
+
+           -- Fetch imported instances, so that we report
+           -- overlaps correctly.
+           -- Really we ought to only check consistency with
+           -- those instances which are transitively imported
+           -- by the current module, rather than every instance
+           -- we've ever seen. Fixing this is part of #13102.
+       ; eps <- getEps
+       ; let inst_envs = (eps_fam_inst_env eps, home_fie)
+             home_fie' = extendFamInstEnv home_fie fam_inst
+
+           -- Check for conflicting instance decls and injectivity violations
+       ; no_conflict    <- checkForConflicts            inst_envs fam_inst
+       ; injectivity_ok <- checkForInjectivityConflicts inst_envs fam_inst
+
+       ; if no_conflict && injectivity_ok then
+            return (home_fie', fam_inst : my_fis)
+         else
+            return (home_fie,  my_fis) }
+
+{-
+************************************************************************
+*                                                                      *
+        Checking an instance against conflicts with an instance env
+*                                                                      *
+************************************************************************
+
+Check whether a single family instance conflicts with those in two instance
+environments (one for the EPS and one for the HPT).
+-}
+
+checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool
+checkForConflicts inst_envs fam_inst
+  = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst
+       ; traceTc "checkForConflicts" $
+         vcat [ ppr (map fim_instance conflicts)
+              , ppr fam_inst
+              -- , ppr inst_envs
+         ]
+       ; reportConflictInstErr fam_inst conflicts
+       ; return (null conflicts) }
+
+-- | Check whether a new open type family equation can be added without
+-- violating injectivity annotation supplied by the user. Returns True when
+-- this is possible and False if adding this equation would violate injectivity
+-- annotation.
+checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM Bool
+checkForInjectivityConflicts instEnvs famInst
+    | isTypeFamilyTyCon tycon
+    -- type family is injective in at least one argument
+    , Injective inj <- tyConInjectivityInfo tycon = do
+    { let axiom = coAxiomSingleBranch fi_ax
+          conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst
+          -- see Note [Verifying injectivity annotation] in FamInstEnv
+          errs = makeInjectivityErrors fi_ax axiom inj conflicts
+    ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) errs
+    ; return (null errs)
+    }
+
+    -- if there was no injectivity annotation or tycon does not represent a
+    -- type family we report no conflicts
+    | otherwise = return True
+    where tycon = famInstTyCon famInst
+          fi_ax = fi_axiom famInst
+
+-- | Build a list of injectivity errors together with their source locations.
+makeInjectivityErrors
+   :: CoAxiom br   -- ^ Type family for which we generate errors
+   -> CoAxBranch   -- ^ Currently checked equation (represented by axiom)
+   -> [Bool]       -- ^ Injectivity annotation
+   -> [CoAxBranch] -- ^ List of injectivity conflicts
+   -> [(SDoc, SrcSpan)]
+makeInjectivityErrors fi_ax axiom inj conflicts
+  = ASSERT2( any id inj, text "No injective type variables" )
+    let lhs             = coAxBranchLHS axiom
+        rhs             = coAxBranchRHS axiom
+        fam_tc          = coAxiomTyCon fi_ax
+        are_conflicts   = not $ null conflicts
+        unused_inj_tvs  = unusedInjTvsInRHS fam_tc inj lhs rhs
+        inj_tvs_unused  = not $ and (isEmptyVarSet <$> unused_inj_tvs)
+        tf_headed       = isTFHeaded rhs
+        bare_variables  = bareTvInRHSViolated lhs rhs
+        wrong_bare_rhs  = not $ null bare_variables
+
+        err_builder herald eqns
+                        = ( hang herald
+                               2 (vcat (map (pprCoAxBranchUser fam_tc) eqns))
+                          , coAxBranchSpan (head eqns) )
+        errorIf p f     = if p then [f err_builder axiom] else []
+     in    errorIf are_conflicts  (conflictInjInstErr     conflicts     )
+        ++ errorIf inj_tvs_unused (unusedInjectiveVarsErr unused_inj_tvs)
+        ++ errorIf tf_headed       tfHeadedErr
+        ++ errorIf wrong_bare_rhs (bareVariableInRHSErr   bare_variables)
+
+
+-- | Return a list of type variables that the function is injective in and that
+-- do not appear on injective positions in the RHS of a family instance
+-- declaration. The returned Pair includes invisible vars followed by visible ones
+unusedInjTvsInRHS :: TyCon -> [Bool] -> [Type] -> Type -> Pair TyVarSet
+-- INVARIANT: [Bool] list contains at least one True value
+-- See Note [Verifying injectivity annotation]. This function implements fourth
+-- check described there.
+-- In theory, instead of implementing this whole check in this way, we could
+-- attempt to unify equation with itself.  We would reject exactly the same
+-- equations but this method gives us more precise error messages by returning
+-- precise names of variables that are not mentioned in the RHS.
+unusedInjTvsInRHS tycon injList lhs rhs =
+  (`minusVarSet` injRhsVars) <$> injLHSVars
+    where
+      inj_pairs :: [(Type, ArgFlag)]
+      -- All the injective arguments, paired with their visibility
+      inj_pairs = ASSERT2( injList `equalLength` lhs
+                         , ppr tycon $$ ppr injList $$ ppr lhs )
+                  filterByList injList (lhs `zip` tyConArgFlags tycon lhs)
+
+      -- set of type and kind variables in which type family is injective
+      invis_lhs, vis_lhs :: [Type]
+      (invis_lhs, vis_lhs) = partitionInvisibles inj_pairs
+
+      invis_vars = tyCoVarsOfTypes invis_lhs
+      Pair invis_vars' vis_vars = splitVisVarsOfTypes vis_lhs
+      injLHSVars
+        = Pair (invis_vars `minusVarSet` vis_vars `unionVarSet` invis_vars')
+               vis_vars
+
+      -- set of type variables appearing in the RHS on an injective position.
+      -- For all returned variables we assume their associated kind variables
+      -- also appear in the RHS.
+      injRhsVars = injTyVarsOfType rhs
+
+injTyVarsOfType :: TcTauType -> TcTyVarSet
+-- Collect all type variables that are either arguments to a type
+--   constructor or to /injective/ type families.
+-- Determining the overall type determines thes variables
+--
+-- E.g.   Suppose F is injective in its second arg, but not its first
+--        then injVarOfType (Either a (F [b] (a,c))) = {a,c}
+--        Determining the overall type determines a,c but not b.
+injTyVarsOfType ty
+  | Just ty' <- coreView ty -- #12430
+  = injTyVarsOfType ty'
+injTyVarsOfType (TyVarTy v)
+  = unitVarSet v `unionVarSet` injTyVarsOfType (tyVarKind v)
+injTyVarsOfType (TyConApp tc tys)
+  | isTypeFamilyTyCon tc
+   = case tyConInjectivityInfo tc of
+        NotInjective  -> emptyVarSet
+        Injective inj -> injTyVarsOfTypes (filterByList inj tys)
+  | otherwise
+  = injTyVarsOfTypes tys
+injTyVarsOfType (LitTy {})
+  = emptyVarSet
+injTyVarsOfType (FunTy arg res)
+  = injTyVarsOfType arg `unionVarSet` injTyVarsOfType res
+injTyVarsOfType (AppTy fun arg)
+  = injTyVarsOfType fun `unionVarSet` injTyVarsOfType arg
+-- No forall types in the RHS of a type family
+injTyVarsOfType (CastTy ty _)   = injTyVarsOfType ty
+injTyVarsOfType (CoercionTy {}) = emptyVarSet
+injTyVarsOfType (ForAllTy {})    =
+    panic "unusedInjTvsInRHS.injTyVarsOfType"
+
+injTyVarsOfTypes :: [Type] -> VarSet
+injTyVarsOfTypes tys = mapUnionVarSet injTyVarsOfType tys
+
+-- | Is type headed by a type family application?
+isTFHeaded :: Type -> Bool
+-- See Note [Verifying injectivity annotation]. This function implements third
+-- check described there.
+isTFHeaded ty | Just ty' <- coreView ty
+              = isTFHeaded ty'
+isTFHeaded ty | (TyConApp tc args) <- ty
+              , isTypeFamilyTyCon tc
+              = args `lengthIs` tyConArity tc
+isTFHeaded _  = False
+
+
+-- | If a RHS is a bare type variable return a set of LHS patterns that are not
+-- bare type variables.
+bareTvInRHSViolated :: [Type] -> Type -> [Type]
+-- See Note [Verifying injectivity annotation]. This function implements second
+-- check described there.
+bareTvInRHSViolated pats rhs | isTyVarTy rhs
+   = filter (not . isTyVarTy) pats
+bareTvInRHSViolated _ _ = []
+
+
+-- | Type of functions that use error message and a list of axioms to build full
+-- error message (with a source location) for injective type families.
+type InjErrorBuilder = SDoc -> [CoAxBranch] -> (SDoc, SrcSpan)
+
+-- | Build injecivity error herald common to all injectivity errors.
+injectivityErrorHerald :: Bool -> SDoc
+injectivityErrorHerald isSingular =
+  text "Type family equation" <> s isSingular <+> text "violate" <>
+  s (not isSingular) <+> text "injectivity annotation" <>
+  if isSingular then dot else colon
+  -- Above is an ugly hack.  We want this: "sentence. herald:" (note the dot and
+  -- colon).  But if herald is empty we want "sentence:" (note the colon).  We
+  -- can't test herald for emptiness so we rely on the fact that herald is empty
+  -- only when isSingular is False.  If herald is non empty it must end with a
+  -- colon.
+    where
+      s False = text "s"
+      s True  = empty
+
+-- | Build error message for a pair of equations violating an injectivity
+-- annotation.
+conflictInjInstErr :: [CoAxBranch] -> InjErrorBuilder -> CoAxBranch
+                   -> (SDoc, SrcSpan)
+conflictInjInstErr conflictingEqns errorBuilder tyfamEqn
+  | confEqn : _ <- conflictingEqns
+  = errorBuilder (injectivityErrorHerald False) [confEqn, tyfamEqn]
+  | otherwise
+  = panic "conflictInjInstErr"
+
+-- | Build error message for equation with injective type variables unused in
+-- the RHS.
+unusedInjectiveVarsErr :: Pair TyVarSet -> InjErrorBuilder -> CoAxBranch
+                       -> (SDoc, SrcSpan)
+unusedInjectiveVarsErr (Pair invis_vars vis_vars) errorBuilder tyfamEqn
+  = let (doc, loc) = errorBuilder (injectivityErrorHerald True $$ msg)
+                                  [tyfamEqn]
+    in (pprWithExplicitKindsWhen has_kinds doc, loc)
+    where
+      tvs = invis_vars `unionVarSet` vis_vars
+      has_types = not $ isEmptyVarSet vis_vars
+      has_kinds = not $ isEmptyVarSet invis_vars
+
+      doc = sep [ what <+> text "variable" <>
+                  pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort)
+                , text "cannot be inferred from the right-hand side." ]
+      what = case (has_types, has_kinds) of
+               (True, True)   -> text "Type and kind"
+               (True, False)  -> text "Type"
+               (False, True)  -> text "Kind"
+               (False, False) -> pprPanic "mkUnusedInjectiveVarsErr" $ ppr tvs
+      msg = doc $$ text "In the type family equation:"
+
+-- | Build error message for equation that has a type family call at the top
+-- level of RHS
+tfHeadedErr :: InjErrorBuilder -> CoAxBranch
+            -> (SDoc, SrcSpan)
+tfHeadedErr errorBuilder famInst
+  = errorBuilder (injectivityErrorHerald True $$
+                  text "RHS of injective type family equation cannot" <+>
+                  text "be a type family:") [famInst]
+
+-- | Build error message for equation that has a bare type variable in the RHS
+-- but LHS pattern is not a bare type variable.
+bareVariableInRHSErr :: [Type] -> InjErrorBuilder -> CoAxBranch
+                     -> (SDoc, SrcSpan)
+bareVariableInRHSErr tys errorBuilder famInst
+  = errorBuilder (injectivityErrorHerald True $$
+                  text "RHS of injective type family equation is a bare" <+>
+                  text "type variable" $$
+                  text "but these LHS type and kind patterns are not bare" <+>
+                  text "variables:" <+> pprQuotedList tys) [famInst]
+
+
+reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn ()
+reportConflictInstErr _ []
+  = return ()  -- No conflicts
+reportConflictInstErr fam_inst (match1 : _)
+  | FamInstMatch { fim_instance = conf_inst } <- match1
+  , let sorted  = sortWith getSpan [fam_inst, conf_inst]
+        fi1     = head sorted
+        span    = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))
+  = setSrcSpan span $ addErr $
+    hang (text "Conflicting family instance declarations:")
+       2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)
+               | fi <- sorted
+               , let ax = famInstAxiom fi ])
+ where
+   getSpan = getSrcLoc . famInstAxiom
+   -- The sortWith just arranges that instances are dislayed in order
+   -- of source location, which reduced wobbling in error messages,
+   -- and is better for users
+
+tcGetFamInstEnvs :: TcM FamInstEnvs
+-- Gets both the external-package inst-env
+-- and the home-pkg inst env (includes module being compiled)
+tcGetFamInstEnvs
+  = do { eps <- getEps; env <- getGblEnv
+       ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/FunDeps.hs
@@ -0,0 +1,675 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 2000
+
+
+FunDeps - functional dependencies
+
+It's better to read it as: "if we know these, then we're going to know these"
+-}
+
+{-# LANGUAGE CPP #-}
+
+module FunDeps (
+        FunDepEqn(..), pprEquation,
+        improveFromInstEnv, improveFromAnother,
+        checkInstCoverage, checkFunDeps,
+        pprFundeps
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Name
+import Var
+import Class
+import Type
+import TcType( transSuperClasses )
+import CoAxiom( TypeEqn )
+import Unify
+import FamInst( injTyVarsOfTypes )
+import InstEnv
+import VarSet
+import VarEnv
+import Outputable
+import ErrUtils( Validity(..), allValid )
+import SrcLoc
+import Util
+
+import Pair             ( Pair(..) )
+import Data.List        ( nubBy )
+import Data.Maybe
+import Data.Foldable    ( fold )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Generate equations from functional dependencies}
+*                                                                      *
+************************************************************************
+
+
+Each functional dependency with one variable in the RHS is responsible
+for generating a single equality. For instance:
+     class C a b | a -> b
+The constraints ([Wanted] C Int Bool) and [Wanted] C Int alpha
+will generate the following FunDepEqn
+     FDEqn { fd_qtvs = []
+           , fd_eqs  = [Pair Bool alpha]
+           , fd_pred1 = C Int Bool
+           , fd_pred2 = C Int alpha
+           , fd_loc = ... }
+However notice that a functional dependency may have more than one variable
+in the RHS which will create more than one pair of types in fd_eqs. Example:
+     class C a b c | a -> b c
+     [Wanted] C Int alpha alpha
+     [Wanted] C Int Bool beta
+Will generate:
+     FDEqn { fd_qtvs = []
+           , fd_eqs  = [Pair Bool alpha, Pair alpha beta]
+           , fd_pred1 = C Int Bool
+           , fd_pred2 = C Int alpha
+           , fd_loc = ... }
+
+INVARIANT: Corresponding types aren't already equal
+That is, there exists at least one non-identity equality in FDEqs.
+
+Assume:
+       class C a b c | a -> b c
+       instance C Int x x
+And:   [Wanted] C Int Bool alpha
+We will /match/ the LHS of fundep equations, producing a matching substitution
+and create equations for the RHS sides. In our last example we'd have generated:
+      ({x}, [fd1,fd2])
+where
+       fd1 = FDEq 1 Bool x
+       fd2 = FDEq 2 alpha x
+To ``execute'' the equation, make fresh type variable for each tyvar in the set,
+instantiate the two types with these fresh variables, and then unify or generate
+a new constraint. In the above example we would generate a new unification
+variable 'beta' for x and produce the following constraints:
+     [Wanted] (Bool ~ beta)
+     [Wanted] (alpha ~ beta)
+
+Notice the subtle difference between the above class declaration and:
+       class C a b c | a -> b, a -> c
+where we would generate:
+      ({x},[fd1]),({x},[fd2])
+This means that the template variable would be instantiated to different
+unification variables when producing the FD constraints.
+
+Finally, the position parameters will help us rewrite the wanted constraint ``on the spot''
+-}
+
+data FunDepEqn loc
+  = FDEqn { fd_qtvs :: [TyVar]   -- Instantiate these type and kind vars
+                                 --   to fresh unification vars,
+                                 -- Non-empty only for FunDepEqns arising from instance decls
+
+          , fd_eqs   :: [TypeEqn]  -- Make these pairs of types equal
+          , fd_pred1 :: PredType   -- The FunDepEqn arose from
+          , fd_pred2 :: PredType   --  combining these two constraints
+          , fd_loc   :: loc  }
+
+{-
+Given a bunch of predicates that must hold, such as
+
+        C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5
+
+improve figures out what extra equations must hold.
+For example, if we have
+
+        class C a b | a->b where ...
+
+then improve will return
+
+        [(t1,t2), (t4,t5)]
+
+NOTA BENE:
+
+  * improve does not iterate.  It's possible that when we make
+    t1=t2, for example, that will in turn trigger a new equation.
+    This would happen if we also had
+        C t1 t7, C t2 t8
+    If t1=t2, we also get t7=t8.
+
+    improve does *not* do this extra step.  It relies on the caller
+    doing so.
+
+  * The equations unify types that are not already equal.  So there
+    is no effect iff the result of improve is empty
+-}
+
+instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type
+-- (instFD fd tvs tys) returns fd instantiated with (tvs -> tys)
+instFD (ls,rs) tvs tys
+  = (map lookup ls, map lookup rs)
+  where
+    env       = zipVarEnv tvs tys
+    lookup tv = lookupVarEnv_NF env tv
+
+zipAndComputeFDEqs :: (Type -> Type -> Bool) -- Discard this FDEq if true
+                   -> [Type] -> [Type]
+                   -> [TypeEqn]
+-- Create a list of (Type,Type) pairs from two lists of types,
+-- making sure that the types are not already equal
+zipAndComputeFDEqs discard (ty1:tys1) (ty2:tys2)
+ | discard ty1 ty2 = zipAndComputeFDEqs discard tys1 tys2
+ | otherwise       = Pair ty1 ty2 : zipAndComputeFDEqs discard tys1 tys2
+zipAndComputeFDEqs _ _ _ = []
+
+-- Improve a class constraint from another class constraint
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+improveFromAnother :: loc
+                   -> PredType -- Template item (usually given, or inert)
+                   -> PredType -- Workitem [that can be improved]
+                   -> [FunDepEqn loc]
+-- Post: FDEqs always oriented from the other to the workitem
+--       Equations have empty quantified variables
+improveFromAnother loc pred1 pred2
+  | Just (cls1, tys1) <- getClassPredTys_maybe pred1
+  , Just (cls2, tys2) <- getClassPredTys_maybe pred2
+  , cls1 == cls2
+  = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2, fd_loc = loc }
+    | let (cls_tvs, cls_fds) = classTvsFds cls1
+    , fd <- cls_fds
+    , let (ltys1, rs1) = instFD fd cls_tvs tys1
+          (ltys2, rs2) = instFD fd cls_tvs tys2
+    , eqTypes ltys1 ltys2               -- The LHSs match
+    , let eqs = zipAndComputeFDEqs eqType rs1 rs2
+    , not (null eqs) ]
+
+improveFromAnother _ _ _ = []
+
+
+-- Improve a class constraint from instance declarations
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+instance Outputable (FunDepEqn a) where
+  ppr = pprEquation
+
+pprEquation :: FunDepEqn a -> SDoc
+pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs })
+  = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs),
+          nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2
+                       | Pair t1 t2 <- pairs])]
+
+improveFromInstEnv :: InstEnvs
+                   -> (PredType -> SrcSpan -> loc)
+                   -> PredType
+                   -> [FunDepEqn loc] -- Needs to be a FunDepEqn because
+                                      -- of quantified variables
+-- Post: Equations oriented from the template (matching instance) to the workitem!
+improveFromInstEnv inst_env mk_loc pred
+  | Just (cls, tys) <- ASSERT2( isClassPred pred, ppr pred )
+                       getClassPredTys_maybe pred
+  , let (cls_tvs, cls_fds) = classTvsFds cls
+        instances          = classInstances inst_env cls
+        rough_tcs          = roughMatchTcs tys
+  = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs
+            , fd_pred1 = p_inst, fd_pred2 = pred
+            , fd_loc = mk_loc p_inst (getSrcSpan (is_dfun ispec)) }
+    | fd <- cls_fds             -- Iterate through the fundeps first,
+                                -- because there often are none!
+    , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs
+                -- Trim the rough_tcs based on the head of the fundep.
+                -- Remember that instanceCantMatch treats both arguments
+                -- symmetrically, so it's ok to trim the rough_tcs,
+                -- rather than trimming each inst_tcs in turn
+    , ispec <- instances
+    , (meta_tvs, eqs) <- improveClsFD cls_tvs fd ispec
+                                      tys trimmed_tcs -- NB: orientation
+    , let p_inst = mkClassPred cls (is_tys ispec)
+    ]
+improveFromInstEnv _ _ _ = []
+
+
+improveClsFD :: [TyVar] -> FunDep TyVar    -- One functional dependency from the class
+             -> ClsInst                    -- An instance template
+             -> [Type] -> [Maybe Name]     -- Arguments of this (C tys) predicate
+             -> [([TyCoVar], [TypeEqn])]   -- Empty or singleton
+
+improveClsFD clas_tvs fd
+             (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst })
+             tys_actual rough_tcs_actual
+
+-- Compare instance      {a,b}    C sx sp sy sq
+--         with wanted     [W] C tx tp ty tq
+--         for fundep (x,y -> p,q)  from class  (C x p y q)
+-- If (sx,sy) unifies with (tx,ty), take the subst S
+
+-- 'qtvs' are the quantified type variables, the ones which can be instantiated
+-- to make the types match.  For example, given
+--      class C a b | a->b where ...
+--      instance C (Maybe x) (Tree x) where ..
+--
+-- and a wanted constraint of form (C (Maybe t1) t2),
+-- then we will call checkClsFD with
+--
+--      is_qtvs = {x}, is_tys = [Maybe x,  Tree x]
+--                     tys_actual = [Maybe t1, t2]
+--
+-- We can instantiate x to t1, and then we want to force
+--      (Tree x) [t1/x]  ~   t2
+
+  | instanceCantMatch rough_tcs_inst rough_tcs_actual
+  = []          -- Filter out ones that can't possibly match,
+
+  | otherwise
+  = ASSERT2( equalLength tys_inst tys_actual &&
+             equalLength tys_inst clas_tvs
+            , ppr tys_inst <+> ppr tys_actual )
+
+    case tcMatchTyKis ltys1 ltys2 of
+        Nothing  -> []
+        Just subst | isJust (tcMatchTyKisX subst rtys1 rtys2)
+                        -- Don't include any equations that already hold.
+                        -- Reason: then we know if any actual improvement has happened,
+                        --         in which case we need to iterate the solver
+                        -- In making this check we must taking account of the fact that any
+                        -- qtvs that aren't already instantiated can be instantiated to anything
+                        -- at all
+                        -- NB: We can't do this 'is-useful-equation' check element-wise
+                        --     because of:
+                        --           class C a b c | a -> b c
+                        --           instance C Int x x
+                        --           [Wanted] C Int alpha Int
+                        -- We would get that  x -> alpha  (isJust) and x -> Int (isJust)
+                        -- so we would produce no FDs, which is clearly wrong.
+                  -> []
+
+                  | null fdeqs
+                  -> []
+
+                  | otherwise
+                  -> -- pprTrace "iproveClsFD" (vcat
+                     --  [ text "is_tvs =" <+> ppr qtvs
+                     --  , text "tys_inst =" <+> ppr tys_inst
+                     --  , text "tys_actual =" <+> ppr tys_actual
+                     --  , text "ltys1 =" <+> ppr ltys1
+                     --  , text "ltys2 =" <+> ppr ltys2
+                     --  , text "subst =" <+> ppr subst ]) $
+                     [(meta_tvs, fdeqs)]
+                        -- We could avoid this substTy stuff by producing the eqn
+                        -- (qtvs, ls1++rs1, ls2++rs2)
+                        -- which will re-do the ls1/ls2 unification when the equation is
+                        -- executed.  What we're doing instead is recording the partial
+                        -- work of the ls1/ls2 unification leaving a smaller unification problem
+                  where
+                    rtys1' = map (substTyUnchecked subst) rtys1
+
+                    fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2
+                        -- Don't discard anything!
+                        -- We could discard equal types but it's an overkill to call
+                        -- eqType again, since we know for sure that /at least one/
+                        -- equation in there is useful)
+
+                    meta_tvs = [ setVarType tv (substTyUnchecked subst (varType tv))
+                               | tv <- qtvs, tv `notElemTCvSubst` subst ]
+                        -- meta_tvs are the quantified type variables
+                        -- that have not been substituted out
+                        --
+                        -- Eg.  class C a b | a -> b
+                        --      instance C Int [y]
+                        -- Given constraint C Int z
+                        -- we generate the equation
+                        --      ({y}, [y], z)
+                        --
+                        -- But note (a) we get them from the dfun_id, so they are *in order*
+                        --              because the kind variables may be mentioned in the
+                        --              type variabes' kinds
+                        --          (b) we must apply 'subst' to the kinds, in case we have
+                        --              matched out a kind variable, but not a type variable
+                        --              whose kind mentions that kind variable!
+                        --          Trac #6015, #6068
+  where
+    (ltys1, rtys1) = instFD fd clas_tvs tys_inst
+    (ltys2, rtys2) = instFD fd clas_tvs tys_actual
+
+{-
+%************************************************************************
+%*                                                                      *
+        The Coverage condition for instance declarations
+*                                                                      *
+************************************************************************
+
+Note [Coverage condition]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Example
+      class C a b | a -> b
+      instance theta => C t1 t2
+
+For the coverage condition, we check
+   (normal)    fv(t2) `subset` fv(t1)
+   (liberal)   fv(t2) `subset` oclose(fv(t1), theta)
+
+The liberal version  ensures the self-consistency of the instance, but
+it does not guarantee termination. Example:
+
+   class Mul a b c | a b -> c where
+        (.*.) :: a -> b -> c
+
+   instance Mul Int Int Int where (.*.) = (*)
+   instance Mul Int Float Float where x .*. y = fromIntegral x * y
+   instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v
+
+In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]).
+But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) )
+
+But it is a mistake to accept the instance because then this defn:
+        f = \ b x y -> if b then x .*. [y] else y
+makes instance inference go into a loop, because it requires the constraint
+        Mul a [b] b
+-}
+
+checkInstCoverage :: Bool   -- Be liberal
+                  -> Class -> [PredType] -> [Type]
+                  -> Validity
+-- "be_liberal" flag says whether to use "liberal" coverage of
+--              See Note [Coverage Condition] below
+--
+-- Return values
+--    Nothing  => no problems
+--    Just msg => coverage problem described by msg
+
+checkInstCoverage be_liberal clas theta inst_taus
+  = allValid (map fundep_ok fds)
+  where
+    (tyvars, fds) = classTvsFds clas
+    fundep_ok fd
+       | and (isEmptyVarSet <$> undetermined_tvs) = IsValid
+       | otherwise                                = NotValid msg
+       where
+         (ls,rs) = instFD fd tyvars inst_taus
+         ls_tvs = tyCoVarsOfTypes ls
+         rs_tvs = splitVisVarsOfTypes rs
+
+         undetermined_tvs | be_liberal = liberal_undet_tvs
+                          | otherwise  = conserv_undet_tvs
+
+         closed_ls_tvs = oclose theta ls_tvs
+         liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs
+         conserv_undet_tvs = (`minusVarSet` ls_tvs)        <$> rs_tvs
+
+         undet_set = fold undetermined_tvs
+
+         msg = pprWithExplicitKindsWhen
+                 (isEmptyVarSet $ pSnd undetermined_tvs) $
+               vcat [ -- text "ls_tvs" <+> ppr ls_tvs
+                      -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs)
+                      -- , text "theta" <+> ppr theta
+                      -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs))
+                      -- , text "rs_tvs" <+> ppr rs_tvs
+                      sep [ text "The"
+                            <+> ppWhen be_liberal (text "liberal")
+                            <+> text "coverage condition fails in class"
+                            <+> quotes (ppr clas)
+                          , nest 2 $ text "for functional dependency:"
+                            <+> quotes (pprFunDep fd) ]
+                    , sep [ text "Reason: lhs type"<>plural ls <+> pprQuotedList ls
+                          , nest 2 $
+                            (if isSingleton ls
+                             then text "does not"
+                             else text "do not jointly")
+                            <+> text "determine rhs type"<>plural rs
+                            <+> pprQuotedList rs ]
+                    , text "Un-determined variable" <> pluralVarSet undet_set <> colon
+                            <+> pprVarSet undet_set (pprWithCommas ppr)
+                    , ppWhen (not be_liberal &&
+                              and (isEmptyVarSet <$> liberal_undet_tvs)) $
+                      text "Using UndecidableInstances might help" ]
+
+{- Note [Closing over kinds in coverage]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have a fundep  (a::k) -> b
+Then if 'a' is instantiated to (x y), where x:k2->*, y:k2,
+then fixing x really fixes k2 as well, and so k2 should be added to
+the lhs tyvars in the fundep check.
+
+Example (Trac #8391), using liberal coverage
+      data Foo a = ...  -- Foo :: forall k. k -> *
+      class Bar a b | a -> b
+      instance Bar a (Foo a)
+
+    In the instance decl, (a:k) does fix (Foo k a), but only if we notice
+    that (a:k) fixes k.  Trac #10109 is another example.
+
+Here is a more subtle example, from HList-0.4.0.0 (Trac #10564)
+
+  class HasFieldM (l :: k) r (v :: Maybe *)
+        | l r -> v where ...
+  class HasFieldM1 (b :: Maybe [*]) (l :: k) r v
+        | b l r -> v where ...
+  class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k])
+        | e1 l -> r
+
+  data Label :: k -> *
+  type family LabelsOf (a :: [*]) ::  *
+
+  instance (HMemberM (Label {k} (l::k)) (LabelsOf xs) b,
+            HasFieldM1 b l (r xs) v)
+         => HasFieldM l (r xs) v where
+
+Is the instance OK? Does {l,r,xs} determine v?  Well:
+
+  * From the instance constraint HMemberM (Label k l) (LabelsOf xs) b,
+    plus the fundep "| el l -> r" in class HMameberM,
+    we get {l,k,xs} -> b
+
+  * Note the 'k'!! We must call closeOverKinds on the seed set
+    ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b
+    fundep won't fire.  This was the reason for #10564.
+
+  * So starting from seeds {l,r,xs,k} we do oclose to get
+    first {l,r,xs,k,b}, via the HMemberM constraint, and then
+    {l,r,xs,k,b,v}, via the HasFieldM1 constraint.
+
+  * And that fixes v.
+
+However, we must closeOverKinds whenever augmenting the seed set
+in oclose!  Consider Trac #10109:
+
+  data Succ a   -- Succ :: forall k. k -> *
+  class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab
+  instance (Add a b ab) => Add (Succ {k1} (a :: k1))
+                               b
+                               (Succ {k3} (ab :: k3})
+
+We start with seed set {a:k1,b:k2} and closeOverKinds to {a,k1,b,k2}.
+Now use the fundep to extend to {a,k1,b,k2,ab}.  But we need to
+closeOverKinds *again* now to {a,k1,b,k2,ab,k3}, so that we fix all
+the variables free in (Succ {k3} ab).
+
+Bottom line:
+  * closeOverKinds on initial seeds (done automatically
+    by tyCoVarsOfTypes in checkInstCoverage)
+  * and closeOverKinds whenever extending those seeds (in oclose)
+
+Note [The liberal coverage condition]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(oclose preds tvs) closes the set of type variables tvs,
+wrt functional dependencies in preds.  The result is a superset
+of the argument set.  For example, if we have
+        class C a b | a->b where ...
+then
+        oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z}
+because if we know x and y then that fixes z.
+
+We also use equality predicates in the predicates; if we have an
+assumption `t1 ~ t2`, then we use the fact that if we know `t1` we
+also know `t2` and the other way.
+  eg    oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x}
+
+oclose is used (only) when checking the coverage condition for
+an instance declaration
+
+Note [Equality superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+  class (a ~ [b]) => C a b
+
+Remember from Note [The equality types story] in TysPrim, that
+  * (a ~~ b) is a superclass of (a ~ b)
+  * (a ~# b) is a superclass of (a ~~ b)
+
+So when oclose expands superclasses we'll get a (a ~# [b]) superclass.
+But that's an EqPred not a ClassPred, and we jolly well do want to
+account for the mutual functional dependencies implied by (t1 ~# t2).
+Hence the EqPred handling in oclose.  See Trac #10778.
+
+Note [Care with type functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #12803)
+  class C x y | x -> y
+  type family F a b
+  type family G c d = r | r -> d
+
+Now consider
+  oclose (C (F a b) (G c d)) {a,b}
+
+Knowing {a,b} fixes (F a b) regardless of the injectivity of F.
+But knowing (G c d) fixes only {d}, because G is only injective
+in its second parameter.
+
+Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds.
+-}
+
+oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet
+-- See Note [The liberal coverage condition]
+oclose preds fixed_tvs
+  | null tv_fds = fixed_tvs -- Fast escape hatch for common case.
+  | otherwise   = fixVarSet extend fixed_tvs
+  where
+    extend fixed_tvs = foldl' add fixed_tvs tv_fds
+       where
+          add fixed_tvs (ls,rs)
+            | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` closeOverKinds rs
+            | otherwise                = fixed_tvs
+            -- closeOverKinds: see Note [Closing over kinds in coverage]
+
+    tv_fds  :: [(TyCoVarSet,TyCoVarSet)]
+    tv_fds  = [ (tyCoVarsOfTypes ls, injTyVarsOfTypes rs)
+                  -- See Note [Care with type functions]
+              | pred <- preds
+              , pred' <- pred : transSuperClasses pred
+                   -- Look for fundeps in superclasses too
+              , (ls, rs) <- determined pred' ]
+
+    determined :: PredType -> [([Type],[Type])]
+    determined pred
+       = case classifyPredType pred of
+            EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])]
+               -- See Note [Equality superclasses]
+            ClassPred cls tys  -> [ instFD fd cls_tvs tys
+                                  | let (cls_tvs, cls_fds) = classTvsFds cls
+                                  , fd <- cls_fds ]
+            _ -> []
+
+
+{- *********************************************************************
+*                                                                      *
+        Check that a new instance decl is OK wrt fundeps
+*                                                                      *
+************************************************************************
+
+Here is the bad case:
+        class C a b | a->b where ...
+        instance C Int Bool where ...
+        instance C Int Char where ...
+
+The point is that a->b, so Int in the first parameter must uniquely
+determine the second.  In general, given the same class decl, and given
+
+        instance C s1 s2 where ...
+        instance C t1 t2 where ...
+
+Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2).
+
+Matters are a little more complicated if there are free variables in
+the s2/t2.
+
+        class D a b c | a -> b
+        instance D a b => D [(a,a)] [b] Int
+        instance D a b => D [a]     [b] Bool
+
+The instance decls don't overlap, because the third parameter keeps
+them separate.  But we want to make sure that given any constraint
+        D s1 s2 s3
+if s1 matches
+
+Note [Bogus consistency check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In checkFunDeps we check that a new ClsInst is consistent with all the
+ClsInsts in the environment.
+
+The bogus aspect is discussed in Trac #10675. Currenty it if the two
+types are *contradicatory*, using (isNothing . tcUnifyTys).  But all
+the papers say we should check if the two types are *equal* thus
+   not (substTys subst rtys1 `eqTypes` substTys subst rtys2)
+For now I'm leaving the bogus form because that's the way it has
+been for years.
+-}
+
+checkFunDeps :: InstEnvs -> ClsInst -> [ClsInst]
+-- The Consistency Check.
+-- Check whether adding DFunId would break functional-dependency constraints
+-- Used only for instance decls defined in the module being compiled
+-- Returns a list of the ClsInst in InstEnvs that are inconsistent
+-- with the proposed new ClsInst
+checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls
+                                , is_tys = tys1, is_tcs = rough_tcs1 })
+  | null fds
+  = []
+  | otherwise
+  = nubBy eq_inst $
+    [ ispec | ispec <- cls_insts
+            , fd    <- fds
+            , is_inconsistent fd ispec ]
+  where
+    cls_insts      = classInstances inst_envs cls
+    (cls_tvs, fds) = classTvsFds cls
+    qtv_set1       = mkVarSet qtvs1
+
+    is_inconsistent fd (ClsInst { is_tvs = qtvs2, is_tys = tys2, is_tcs = rough_tcs2 })
+      | instanceCantMatch trimmed_tcs rough_tcs2
+      = False
+      | otherwise
+      = case tcUnifyTyKis bind_fn ltys1 ltys2 of
+          Nothing         -> False
+          Just subst
+            -> isNothing $   -- Bogus legacy test (Trac #10675)
+                             -- See Note [Bogus consistency check]
+               tcUnifyTyKis bind_fn (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2)
+
+      where
+        trimmed_tcs    = trimRoughMatchTcs cls_tvs fd rough_tcs1
+        (ltys1, rtys1) = instFD fd cls_tvs tys1
+        (ltys2, rtys2) = instFD fd cls_tvs tys2
+        qtv_set2       = mkVarSet qtvs2
+        bind_fn tv | tv `elemVarSet` qtv_set1 = BindMe
+                   | tv `elemVarSet` qtv_set2 = BindMe
+                   | otherwise                = Skolem
+
+    eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2
+        -- A single instance may appear twice in the un-nubbed conflict list
+        -- because it may conflict with more than one fundep.  E.g.
+        --      class C a b c | a -> b, a -> c
+        --      instance C Int Bool Bool
+        --      instance C Int Char Char
+        -- The second instance conflicts with the first by *both* fundeps
+
+trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name]
+-- Computing rough_tcs for a particular fundep
+--     class C a b c | a -> b where ...
+-- For each instance .... => C ta tb tc
+-- we want to match only on the type ta; so our
+-- rough-match thing must similarly be filtered.
+-- Hence, we Nothing-ise the tb and tc types right here
+--
+-- Result list is same length as input list, just with more Nothings
+trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs
+  = zipWith select clas_tvs mb_tcs
+  where
+    select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc
+                         | otherwise           = Nothing
diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/Inst.hs
@@ -0,0 +1,940 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+The @Inst@ type: dictionaries or method instances
+-}
+
+{-# LANGUAGE CPP, MultiWayIf, TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Inst (
+       deeplySkolemise,
+       topInstantiate, topInstantiateInferred, deeplyInstantiate,
+       instCall, instDFunType, instStupidTheta, instTyVarsWith,
+       newWanted, newWanteds,
+
+       tcInstTyBinders, tcInstTyBinder,
+
+       newOverloadedLit, mkOverLit,
+
+       newClsInst,
+       tcGetInsts, tcGetInstEnvs, getOverlapFlag,
+       tcExtendLocalInstEnv,
+       instCallConstraints, newMethodFromName,
+       tcSyntaxName,
+
+       -- Simple functions over evidence variables
+       tyCoVarsOfWC,
+       tyCoVarsOfCt, tyCoVarsOfCts,
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcSyntaxOp )
+import {-# SOURCE #-}   TcUnify( unifyType, unifyKind )
+
+import BasicTypes ( IntegralLit(..), SourceText(..) )
+import FastString
+import HsSyn
+import TcHsSyn
+import TcRnMonad
+import TcEnv
+import TcEvidence
+import InstEnv
+import TysWiredIn  ( heqDataCon, eqDataCon )
+import CoreSyn     ( isOrphan )
+import FunDeps
+import TcMType
+import Type
+import TyCoRep
+import TcType
+import HscTypes
+import Class( Class )
+import MkId( mkDictFunId )
+import CoreSyn( Expr(..) )  -- For the Coercion constructor
+import Id
+import Name
+import Var      ( EvVar, mkTyVar, tyVarName, VarBndr(..) )
+import DataCon
+import VarEnv
+import PrelNames
+import SrcLoc
+import DynFlags
+import Util
+import Outputable
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad( unless )
+
+{-
+************************************************************************
+*                                                                      *
+                Creating and emittind constraints
+*                                                                      *
+************************************************************************
+-}
+
+newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr GhcTcId)
+-- Used when Name is the wired-in name for a wired-in class method,
+-- so the caller knows its type for sure, which should be of form
+--    forall a. C a => <blah>
+-- newMethodFromName is supposed to instantiate just the outer
+-- type variable and constraint
+
+newMethodFromName origin name inst_ty
+  = do { id <- tcLookupId name
+              -- Use tcLookupId not tcLookupGlobalId; the method is almost
+              -- always a class op, but with -XRebindableSyntax GHC is
+              -- meant to find whatever thing is in scope, and that may
+              -- be an ordinary function.
+
+       ; let ty = piResultTy (idType id) inst_ty
+             (theta, _caller_knows_this) = tcSplitPhiTy ty
+       ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
+                 instCall origin [inst_ty] theta
+
+       ; return (mkHsWrap wrap (HsVar noExt (noLoc id))) }
+
+{-
+************************************************************************
+*                                                                      *
+        Deep instantiation and skolemisation
+*                                                                      *
+************************************************************************
+
+Note [Deep skolemisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+deeplySkolemise decomposes and skolemises a type, returning a type
+with all its arrows visible (ie not buried under foralls)
+
+Examples:
+
+  deeplySkolemise (Int -> forall a. Ord a => blah)
+    =  ( wp, [a], [d:Ord a], Int -> blah )
+    where wp = \x:Int. /\a. \(d:Ord a). <hole> x
+
+  deeplySkolemise  (forall a. Ord a => Maybe a -> forall b. Eq b => blah)
+    =  ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )
+    where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x
+
+In general,
+  if      deeplySkolemise ty = (wrap, tvs, evs, rho)
+    and   e :: rho
+  then    wrap e :: ty
+    and   'wrap' binds tvs, evs
+
+ToDo: this eta-abstraction plays fast and loose with termination,
+      because it can introduce extra lambdas.  Maybe add a `seq` to
+      fix this
+-}
+
+deeplySkolemise :: TcSigmaType
+                -> TcM ( HsWrapper
+                       , [(Name,TyVar)]     -- All skolemised variables
+                       , [EvVar]            -- All "given"s
+                       , TcRhoType )
+
+deeplySkolemise ty
+  = go init_subst ty
+  where
+    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))
+
+    go subst ty
+      | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
+      = do { let arg_tys' = substTys subst arg_tys
+           ; ids1           <- newSysLocalIds (fsLit "dk") arg_tys'
+           ; (subst', tvs1) <- tcInstSkolTyVarsX subst tvs
+           ; ev_vars1       <- newEvVars (substTheta subst' theta)
+           ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'
+           ; let tv_prs1 = map tyVarName tvs `zip` tvs1
+           ; return ( mkWpLams ids1
+                      <.> mkWpTyLams tvs1
+                      <.> mkWpLams ev_vars1
+                      <.> wrap
+                      <.> mkWpEvVarApps ids1
+                    , tv_prs1  ++ tvs_prs2
+                    , ev_vars1 ++ ev_vars2
+                    , mkFunTys arg_tys' rho ) }
+
+      | otherwise
+      = return (idHsWrapper, [], [], substTy subst ty)
+        -- substTy is a quick no-op on an empty substitution
+
+-- | Instantiate all outer type variables
+-- and any context. Never looks through arrows.
+topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+-- if    topInstantiate ty = (wrap, rho)
+-- and   e :: ty
+-- then  wrap e :: rho  (that is, wrap :: ty "->" rho)
+topInstantiate = top_instantiate True
+
+-- | Instantiate all outer 'Inferred' binders
+-- and any context. Never looks through arrows or specified type variables.
+-- Used for visible type application.
+topInstantiateInferred :: CtOrigin -> TcSigmaType
+                       -> TcM (HsWrapper, TcSigmaType)
+-- if    topInstantiate ty = (wrap, rho)
+-- and   e :: ty
+-- then  wrap e :: rho
+topInstantiateInferred = top_instantiate False
+
+top_instantiate :: Bool   -- True  <=> instantiate *all* variables
+                          -- False <=> instantiate only the inferred ones
+                -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+top_instantiate inst_all orig ty
+  | not (null binders && null theta)
+  = do { let (inst_bndrs, leave_bndrs) = span should_inst binders
+             (inst_theta, leave_theta)
+               | null leave_bndrs = (theta, [])
+               | otherwise        = ([], theta)
+             in_scope    = mkInScopeSet (tyCoVarsOfType ty)
+             empty_subst = mkEmptyTCvSubst in_scope
+             inst_tvs    = binderVars inst_bndrs
+       ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs
+       ; let inst_theta' = substTheta subst inst_theta
+             sigma'      = substTy subst (mkForAllTys leave_bndrs $
+                                          mkFunTys leave_theta rho)
+             inst_tv_tys' = mkTyVarTys inst_tvs'
+
+       ; wrap1 <- instCall orig inst_tv_tys' inst_theta'
+       ; traceTc "Instantiating"
+                 (vcat [ text "all tyvars?" <+> ppr inst_all
+                       , text "origin" <+> pprCtOrigin orig
+                       , text "type" <+> debugPprType ty
+                       , text "theta" <+> ppr theta
+                       , text "leave_bndrs" <+> ppr leave_bndrs
+                       , text "with" <+> vcat (map debugPprType inst_tv_tys')
+                       , text "theta:" <+>  ppr inst_theta' ])
+
+       ; (wrap2, rho2) <-
+           if null leave_bndrs
+
+         -- account for types like forall a. Num a => forall b. Ord b => ...
+           then top_instantiate inst_all orig sigma'
+
+         -- but don't loop if there were any un-inst'able tyvars
+           else return (idHsWrapper, sigma')
+
+       ; return (wrap2 <.> wrap1, rho2) }
+
+  | otherwise = return (idHsWrapper, ty)
+  where
+    (binders, phi) = tcSplitForAllVarBndrs ty
+    (theta, rho)   = tcSplitPhiTy phi
+
+    should_inst bndr
+      | inst_all  = True
+      | otherwise = binderArgFlag bndr == Inferred
+
+deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+--   Int -> forall a. a -> a  ==>  (\x:Int. [] x alpha) :: Int -> alpha
+-- In general if
+-- if    deeplyInstantiate ty = (wrap, rho)
+-- and   e :: ty
+-- then  wrap e :: rho
+-- That is, wrap :: ty ~> rho
+--
+-- If you don't need the HsWrapper returned from this function, consider
+-- using tcSplitNestedSigmaTys in TcType, which is a pure alternative that
+-- only computes the returned TcRhoType.
+
+deeplyInstantiate orig ty =
+  deeply_instantiate orig
+                     (mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)))
+                     ty
+
+deeply_instantiate :: CtOrigin
+                   -> TCvSubst
+                   -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+-- Internal function to deeply instantiate that builds on an existing subst.
+-- It extends the input substitution and applies the final subtitution to
+-- the types on return.  See #12549.
+
+deeply_instantiate orig subst ty
+  | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
+  = do { (subst', tvs') <- newMetaTyVarsX subst tvs
+       ; let arg_tys' = substTys   subst' arg_tys
+             theta'   = substTheta subst' theta
+       ; ids1  <- newSysLocalIds (fsLit "di") arg_tys'
+       ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
+       ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig
+                                                , text "type" <+> ppr ty
+                                                , text "with" <+> ppr tvs'
+                                                , text "args:" <+> ppr ids1
+                                                , text "theta:" <+>  ppr theta'
+                                                , text "subst:" <+> ppr subst'])
+       ; (wrap2, rho2) <- deeply_instantiate orig subst' rho
+       ; return (mkWpLams ids1
+                    <.> wrap2
+                    <.> wrap1
+                    <.> mkWpEvVarApps ids1,
+                 mkFunTys arg_tys' rho2) }
+
+  | otherwise
+  = do { let ty' = substTy subst ty
+       ; traceTc "deeply_instantiate final subst"
+                 (vcat [ text "origin:"   <+> pprCtOrigin orig
+                       , text "type:"     <+> ppr ty
+                       , text "new type:" <+> ppr ty'
+                       , text "subst:"    <+> ppr subst ])
+      ; return (idHsWrapper, ty') }
+
+
+instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst
+-- Use this when you want to instantiate (forall a b c. ty) with
+-- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might
+-- not yet match (perhaps because there are unsolved constraints; Trac #14154)
+-- If they don't match, emit a kind-equality to promise that they will
+-- eventually do so, and thus make a kind-homongeneous substitution.
+instTyVarsWith orig tvs tys
+  = go empty_subst tvs tys
+  where
+    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes tys))
+
+    go subst [] []
+      = return subst
+    go subst (tv:tvs) (ty:tys)
+      | tv_kind `tcEqType` ty_kind
+      = go (extendTCvSubst subst tv ty) tvs tys
+      | otherwise
+      = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind
+           ; go (extendTCvSubst subst tv (ty `mkCastTy` co)) tvs tys }
+      where
+        tv_kind = substTy subst (tyVarKind tv)
+        ty_kind = tcTypeKind ty
+
+    go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys)
+
+{-
+************************************************************************
+*                                                                      *
+            Instantiating a call
+*                                                                      *
+************************************************************************
+
+Note [Handling boxed equality]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The solver deals entirely in terms of unboxed (primitive) equality.
+There should never be a boxed Wanted equality. Ever. But, what if
+we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality
+is boxed, so naive treatment here would emit a boxed Wanted equality.
+
+So we simply check for this case and make the right boxing of evidence.
+
+-}
+
+----------------
+instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
+-- Instantiate the constraints of a call
+--      (instCall o tys theta)
+-- (a) Makes fresh dictionaries as necessary for the constraints (theta)
+-- (b) Throws these dictionaries into the LIE
+-- (c) Returns an HsWrapper ([.] tys dicts)
+
+instCall orig tys theta
+  = do  { dict_app <- instCallConstraints orig theta
+        ; return (dict_app <.> mkWpTyApps tys) }
+
+----------------
+instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
+-- Instantiates the TcTheta, puts all constraints thereby generated
+-- into the LIE, and returns a HsWrapper to enclose the call site.
+
+instCallConstraints orig preds
+  | null preds
+  = return idHsWrapper
+  | otherwise
+  = do { evs <- mapM go preds
+       ; traceTc "instCallConstraints" (ppr evs)
+       ; return (mkWpEvApps evs) }
+  where
+    go :: TcPredType -> TcM EvTerm
+    go pred
+     | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
+     = do  { co <- unifyType Nothing ty1 ty2
+           ; return (evCoercion co) }
+
+       -- Try short-cut #2
+     | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
+     , tc `hasKey` heqTyConKey
+     = do { co <- unifyType Nothing ty1 ty2
+          ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) }
+
+     | otherwise
+     = emitWanted orig pred
+
+instDFunType :: DFunId -> [DFunInstType]
+             -> TcM ( [TcType]      -- instantiated argument types
+                    , TcThetaType ) -- instantiated constraint
+-- See Note [DFunInstType: instantiating types] in InstEnv
+instDFunType dfun_id dfun_inst_tys
+  = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys
+       ; return (inst_tys, substTheta subst dfun_theta) }
+  where
+    dfun_ty = idType dfun_id
+    (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty
+    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty))
+                  -- With quantified constraints, the
+                  -- type of a dfun may not be closed
+
+    go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])
+    go subst [] [] = return (subst, [])
+    go subst (tv:tvs) (Just ty : mb_tys)
+      = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty)
+                                 tvs
+                                 mb_tys
+           ; return (subst', ty : tys) }
+    go subst (tv:tvs) (Nothing : mb_tys)
+      = do { (subst', tv') <- newMetaTyVarX subst tv
+           ; (subst'', tys) <- go subst' tvs mb_tys
+           ; return (subst'', mkTyVarTy tv' : tys) }
+    go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)
+
+----------------
+instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
+-- Similar to instCall, but only emit the constraints in the LIE
+-- Used exclusively for the 'stupid theta' of a data constructor
+instStupidTheta orig theta
+  = do  { _co <- instCallConstraints orig theta -- Discard the coercion
+        ; return () }
+
+{-
+************************************************************************
+*                                                                      *
+         Instantiating Kinds
+*                                                                      *
+************************************************************************
+
+Note [Constraints handled in types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally, we cannot handle constraints written in types. For example,
+if we declare
+
+  data C a where
+    MkC :: Show a => a -> C a
+
+we will not be able to use MkC in types, as we have no way of creating
+a type-level Show dictionary.
+
+However, we make an exception for equality types. Consider
+
+  data T1 a where
+    MkT1 :: T1 Bool
+
+  data T2 a where
+    MkT2 :: a ~ Bool => T2 a
+
+MkT1 has a constrained return type, while MkT2 uses an explicit equality
+constraint. These two types are often written interchangeably, with a
+reasonable expectation that they mean the same thing. For this to work --
+and for us to be able to promote GADTs -- we need to be able to instantiate
+equality constraints in types.
+
+One wrinkle is that the equality in MkT2 is *lifted*. But, for proper
+GADT equalities, GHC produces *unlifted* constraints. (This unlifting comes
+from DataCon.eqSpecPreds, which uses mkPrimEqPred.) And, perhaps a wily
+user will use (~~) for a heterogeneous equality. We thus must support
+all of (~), (~~), and (~#) in types. (See Note [The equality types story]
+in TysPrim for a primer on these equality types.)
+
+The get_eq_tys_maybe function recognizes these three forms of equality,
+returning a suitable type formation function and the two types related
+by the equality constraint. In the lifted case, it uses mkHEqBoxTy or
+mkEqBoxTy, which promote the datacons of the (~~) or (~) datatype,
+respectively.
+
+One might reasonably wonder who *unpacks* these boxes once they are
+made. After all, there is no type-level `case` construct. The surprising
+answer is that no one ever does. Instead, if a GADT constructor is used
+on the left-hand side of a type family equation, that occurrence forces
+GHC to unify the types in question. For example:
+
+  data G a where
+    MkG :: G Bool
+
+  type family F (x :: G a) :: a where
+    F MkG = False
+
+When checking the LHS `F MkG`, GHC sees the MkG constructor and then must
+unify F's implicit parameter `a` with Bool. This succeeds, making the equation
+
+    F Bool (MkG @Bool <Bool>) = False
+
+Note that we never need unpack the coercion. This is because type family
+equations are *not* parametric in their kind variables. That is, we could have
+just said
+
+  type family H (x :: G a) :: a where
+    H _ = False
+
+The presence of False on the RHS also forces `a` to become Bool, giving us
+
+    H Bool _ = False
+
+The fact that any of this works stems from the lack of phase separation between
+types and kinds (unlike the very present phase separation between terms and types).
+
+Once we have the ability to pattern-match on types below top-level, this will
+no longer cut it, but it seems fine for now.
+
+-}
+
+---------------------------
+-- | Instantantiate the TyConBinders of a forall type,
+--   given its decomposed form (tvs, ty)
+tcInstTyBinders :: HasDebugCallStack
+              => ([TyCoBinder], TcKind)   -- ^ The type (forall bs. ty)
+              -> TcM ([TcType], TcKind)   -- ^ Instantiated bs, substituted ty
+-- Takes a pair because that is what splitPiTysInvisible returns
+-- See also Note [Bidirectional type checking]
+tcInstTyBinders (bndrs, ty)
+  | null bndrs        -- It's fine for bndrs to be empty e.g.
+  = return ([], ty)   -- Check that (Maybe :: forall {k}. k->*),
+                      --       and see the call to instTyBinders in checkExpectedKind
+                      -- A user bug to be reported as such; it is not a compiler crash!
+
+  | otherwise
+  = do { (subst, args) <- mapAccumLM (tcInstTyBinder Nothing) empty_subst bndrs
+       ; ty' <- zonkTcType (substTy subst ty)
+                   -- Why zonk the result? So that tcTyVar can
+                   -- obey (IT6) of Note [The tcType invariant] in TcHsType
+                   -- ToDo: SLPJ: I don't think this is needed
+       ; return (args, ty') }
+  where
+     empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))
+
+-- | Used only in *types*
+tcInstTyBinder :: Maybe (VarEnv Kind)
+               -> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
+tcInstTyBinder mb_kind_info subst (Named (Bndr tv _))
+  = case lookup_tv tv of
+      Just ki -> return (extendTvSubstAndInScope subst tv ki, ki)
+      Nothing -> do { (subst', tv') <- newMetaTyVarX subst tv
+                    ; return (subst', mkTyVarTy tv') }
+  where
+    lookup_tv tv = do { env <- mb_kind_info   -- `Maybe` monad
+                      ; lookupVarEnv env tv }
+
+
+tcInstTyBinder _ subst (Anon ty)
+     -- This is the *only* constraint currently handled in types.
+  | Just (mk, k1, k2) <- get_eq_tys_maybe substed_ty
+  = do { co <- unifyKind Nothing k1 k2
+       ; arg' <- mk co
+       ; return (subst, arg') }
+
+  | isPredTy substed_ty
+  = do { let (env, tidy_ty) = tidyOpenType emptyTidyEnv substed_ty
+       ; addErrTcM (env, text "Illegal constraint in a kind:" <+> ppr tidy_ty)
+
+         -- just invent a new variable so that we can continue
+       ; u <- newUnique
+       ; let name = mkSysTvName u (fsLit "dict")
+       ; return (subst, mkTyVarTy $ mkTyVar name substed_ty) }
+
+
+  | otherwise
+  = do { tv_ty <- newFlexiTyVarTy substed_ty
+       ; return (subst, tv_ty) }
+
+  where
+    substed_ty = substTy subst ty
+
+      -- See Note [Constraints handled in types]
+    get_eq_tys_maybe :: Type
+                     -> Maybe ( Coercion -> TcM Type
+                                 -- given a coercion proving t1 ~# t2, produce the
+                                 -- right instantiation for the TyBinder at hand
+                              , Type  -- t1
+                              , Type  -- t2
+                              )
+    get_eq_tys_maybe ty
+        -- unlifted equality (~#)
+      | Just (Nominal, k1, k2) <- getEqPredTys_maybe ty
+      = Just (\co -> return $ mkCoercionTy co, k1, k2)
+
+        -- lifted heterogeneous equality (~~)
+      | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty
+      = if | tc `hasKey` heqTyConKey
+             -> Just (\co -> mkHEqBoxTy co k1 k2, k1, k2)
+           | otherwise
+             -> Nothing
+
+        -- lifted homogeneous equality (~)
+      | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty
+      = if | tc `hasKey` eqTyConKey
+             -> Just (\co -> mkEqBoxTy co k1 k2, k1, k2)
+           | otherwise
+             -> Nothing
+
+      | otherwise
+      = Nothing
+
+-------------------------------
+-- | This takes @a ~# b@ and returns @a ~~ b@.
+mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
+-- monadic just for convenience with mkEqBoxTy
+mkHEqBoxTy co ty1 ty2
+  = return $
+    mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co]
+  where k1 = tcTypeKind ty1
+        k2 = tcTypeKind ty2
+
+-- | This takes @a ~# b@ and returns @a ~ b@.
+mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
+mkEqBoxTy co ty1 ty2
+  = return $
+    mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co]
+  where k = tcTypeKind ty1
+
+{-
+************************************************************************
+*                                                                      *
+                Literals
+*                                                                      *
+************************************************************************
+
+-}
+
+{-
+In newOverloadedLit we convert directly to an Int or Integer if we
+know that's what we want.  This may save some time, by not
+temporarily generating overloaded literals, but it won't catch all
+cases (the rest are caught in lookupInst).
+
+-}
+
+newOverloadedLit :: HsOverLit GhcRn
+                 -> ExpRhoType
+                 -> TcM (HsOverLit GhcTcId)
+newOverloadedLit
+  lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty
+  | not rebindable
+    -- all built-in overloaded lits are tau-types, so we can just
+    -- tauify the ExpType
+  = do { res_ty <- expTypeToType res_ty
+       ; dflags <- getDynFlags
+       ; case shortCutLit dflags val res_ty of
+        -- Do not generate a LitInst for rebindable syntax.
+        -- Reason: If we do, tcSimplify will call lookupInst, which
+        --         will call tcSyntaxName, which does unification,
+        --         which tcSimplify doesn't like
+           Just expr -> return (lit { ol_witness = expr
+                                    , ol_ext = OverLitTc False res_ty })
+           Nothing   -> newNonTrivialOverloadedLit orig lit
+                                                   (mkCheckExpType res_ty) }
+
+  | otherwise
+  = newNonTrivialOverloadedLit orig lit res_ty
+  where
+    orig = LiteralOrigin lit
+newOverloadedLit XOverLit{} _ = panic "newOverloadedLit"
+
+-- Does not handle things that 'shortCutLit' can handle. See also
+-- newOverloadedLit in TcUnify
+newNonTrivialOverloadedLit :: CtOrigin
+                           -> HsOverLit GhcRn
+                           -> ExpRhoType
+                           -> TcM (HsOverLit GhcTcId)
+newNonTrivialOverloadedLit orig
+  lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)
+               , ol_ext = rebindable }) res_ty
+  = do  { hs_lit <- mkOverLit val
+        ; let lit_ty = hsLitType hs_lit
+        ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
+                                      [synKnownType lit_ty] res_ty $
+                      \_ -> return ()
+        ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
+        ; res_ty <- readExpType res_ty
+        ; return (lit { ol_witness = witness
+                      , ol_ext = OverLitTc rebindable res_ty }) }
+newNonTrivialOverloadedLit _ lit _
+  = pprPanic "newNonTrivialOverloadedLit" (ppr lit)
+
+------------
+mkOverLit ::OverLitVal -> TcM (HsLit GhcTc)
+mkOverLit (HsIntegral i)
+  = do  { integer_ty <- tcMetaTy integerTyConName
+        ; return (HsInteger (il_text i)
+                            (il_value i) integer_ty) }
+
+mkOverLit (HsFractional r)
+  = do  { rat_ty <- tcMetaTy rationalTyConName
+        ; return (HsRat noExt r rat_ty) }
+
+mkOverLit (HsIsString src s) = return (HsString src s)
+
+{-
+************************************************************************
+*                                                                      *
+                Re-mappable syntax
+
+     Used only for arrow syntax -- find a way to nuke this
+*                                                                      *
+************************************************************************
+
+Suppose we are doing the -XRebindableSyntax thing, and we encounter
+a do-expression.  We have to find (>>) in the current environment, which is
+done by the rename. Then we have to check that it has the same type as
+Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
+this:
+
+  (>>) :: HB m n mn => m a -> n b -> mn b
+
+So the idea is to generate a local binding for (>>), thus:
+
+        let then72 :: forall a b. m a -> m b -> m b
+            then72 = ...something involving the user's (>>)...
+        in
+        ...the do-expression...
+
+Now the do-expression can proceed using then72, which has exactly
+the expected type.
+
+In fact tcSyntaxName just generates the RHS for then72, because we only
+want an actual binding in the do-expression case. For literals, we can
+just use the expression inline.
+-}
+
+tcSyntaxName :: CtOrigin
+             -> TcType                 -- ^ Type to instantiate it at
+             -> (Name, HsExpr GhcRn)   -- ^ (Standard name, user name)
+             -> TcM (Name, HsExpr GhcTcId)
+                                       -- ^ (Standard name, suitable expression)
+-- USED ONLY FOR CmdTop (sigh) ***
+-- See Note [CmdSyntaxTable] in HsExpr
+
+tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))
+  | std_nm == user_nm
+  = do rhs <- newMethodFromName orig std_nm ty
+       return (std_nm, rhs)
+
+tcSyntaxName orig ty (std_nm, user_nm_expr) = do
+    std_id <- tcLookupId std_nm
+    let
+        -- C.f. newMethodAtLoc
+        ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
+        sigma1         = substTyWith [tv] [ty] tau
+        -- Actually, the "tau-type" might be a sigma-type in the
+        -- case of locally-polymorphic methods.
+
+    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
+
+        -- Check that the user-supplied thing has the
+        -- same type as the standard one.
+        -- Tiresome jiggling because tcCheckSigma takes a located expression
+     span <- getSrcSpanM
+     expr <- tcPolyExpr (L span user_nm_expr) sigma1
+     return (std_nm, unLoc expr)
+
+syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv
+               -> TcRn (TidyEnv, SDoc)
+syntaxNameCtxt name orig ty tidy_env
+  = do { inst_loc <- getCtLocM orig (Just TypeLevel)
+       ; let msg = vcat [ text "When checking that" <+> quotes (ppr name)
+                          <+> text "(needed by a syntactic construct)"
+                        , nest 2 (text "has the required type:"
+                                  <+> ppr (tidyType tidy_env ty))
+                        , nest 2 (pprCtLoc inst_loc) ]
+       ; return (tidy_env, msg) }
+
+{-
+************************************************************************
+*                                                                      *
+                Instances
+*                                                                      *
+************************************************************************
+-}
+
+getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
+-- Construct the OverlapFlag from the global module flags,
+-- but if the overlap_mode argument is (Just m),
+--     set the OverlapMode to 'm'
+getOverlapFlag overlap_mode
+  = do  { dflags <- getDynFlags
+        ; let overlap_ok    = xopt LangExt.OverlappingInstances dflags
+              incoherent_ok = xopt LangExt.IncoherentInstances  dflags
+              use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
+                                  , overlapMode   = x }
+              default_oflag | incoherent_ok = use (Incoherent NoSourceText)
+                            | overlap_ok    = use (Overlaps NoSourceText)
+                            | otherwise     = use (NoOverlap NoSourceText)
+
+              final_oflag = setOverlapModeMaybe default_oflag overlap_mode
+        ; return final_oflag }
+
+tcGetInsts :: TcM [ClsInst]
+-- Gets the local class instances.
+tcGetInsts = fmap tcg_insts getGblEnv
+
+newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
+           -> Class -> [Type] -> TcM ClsInst
+newClsInst overlap_mode dfun_name tvs theta clas tys
+  = do { (subst, tvs') <- freshenTyVarBndrs tvs
+             -- Be sure to freshen those type variables,
+             -- so they are sure not to appear in any lookup
+       ; let tys' = substTys subst tys
+
+             dfun = mkDictFunId dfun_name tvs theta clas tys
+             -- The dfun uses the original 'tvs' because
+             -- (a) they don't need to be fresh
+             -- (b) they may be mentioned in the ib_binds field of
+             --     an InstInfo, and in TcEnv.pprInstInfoDetails it's
+             --     helpful to use the same names
+
+       ; oflag <- getOverlapFlag overlap_mode
+       ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
+       ; warnIfFlag Opt_WarnOrphans
+                    (isOrphan (is_orphan inst))
+                    (instOrphWarn inst)
+       ; return inst }
+
+instOrphWarn :: ClsInst -> SDoc
+instOrphWarn inst
+  = hang (text "Orphan instance:") 2 (pprInstanceHdr inst)
+    $$ text "To avoid this"
+    $$ nest 4 (vcat possibilities)
+  where
+    possibilities =
+      text "move the instance declaration to the module of the class or of the type, or" :
+      text "wrap the type with a newtype and declare the instance on the new type." :
+      []
+
+tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
+  -- Add new locally-defined instances
+tcExtendLocalInstEnv dfuns thing_inside
+ = do { traceDFuns dfuns
+      ; env <- getGblEnv
+      ; (inst_env', cls_insts') <- foldlM addLocalInst
+                                          (tcg_inst_env env, tcg_insts env)
+                                          dfuns
+      ; let env' = env { tcg_insts    = cls_insts'
+                       , tcg_inst_env = inst_env' }
+      ; setGblEnv env' thing_inside }
+
+addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
+-- Check that the proposed new instance is OK,
+-- and then add it to the home inst env
+-- If overwrite_inst, then we can overwrite a direct match
+addLocalInst (home_ie, my_insts) ispec
+   = do {
+             -- Load imported instances, so that we report
+             -- duplicates correctly
+
+             -- 'matches'  are existing instance declarations that are less
+             --            specific than the new one
+             -- 'dups'     are those 'matches' that are equal to the new one
+         ; isGHCi <- getIsGHCi
+         ; eps    <- getEps
+         ; tcg_env <- getGblEnv
+
+           -- In GHCi, we *override* any identical instances
+           -- that are also defined in the interactive context
+           -- See Note [Override identical instances in GHCi]
+         ; let home_ie'
+                 | isGHCi    = deleteFromInstEnv home_ie ispec
+                 | otherwise = home_ie
+
+               global_ie = eps_inst_env eps
+               inst_envs = InstEnvs { ie_global  = global_ie
+                                    , ie_local   = home_ie'
+                                    , ie_visible = tcVisibleOrphanMods tcg_env }
+
+             -- Check for inconsistent functional dependencies
+         ; let inconsistent_ispecs = checkFunDeps inst_envs ispec
+         ; unless (null inconsistent_ispecs) $
+           funDepErr ispec inconsistent_ispecs
+
+             -- Check for duplicate instance decls.
+         ; let (_tvs, cls, tys) = instanceHead ispec
+               (matches, _, _)  = lookupInstEnv False inst_envs cls tys
+               dups             = filter (identicalClsInstHead ispec) (map fst matches)
+         ; unless (null dups) $
+           dupInstErr ispec (head dups)
+
+         ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
+
+{-
+Note [Signature files and type class instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Instances in signature files do not have an effect when compiling:
+when you compile a signature against an implementation, you will
+see the instances WHETHER OR NOT the instance is declared in
+the file (this is because the signatures go in the EPS and we
+can't filter them out easily.)  This is also why we cannot
+place the instance in the hi file: it would show up as a duplicate,
+and we don't have instance reexports anyway.
+
+However, you might find them useful when typechecking against
+a signature: the instance is a way of indicating to GHC that
+some instance exists, in case downstream code uses it.
+
+Implementing this is a little tricky.  Consider the following
+situation (sigof03):
+
+ module A where
+     instance C T where ...
+
+ module ASig where
+     instance C T
+
+When compiling ASig, A.hi is loaded, which brings its instances
+into the EPS.  When we process the instance declaration in ASig,
+we should ignore it for the purpose of doing a duplicate check,
+since it's not actually a duplicate. But don't skip the check
+entirely, we still want this to fail (tcfail221):
+
+ module ASig where
+     instance C T
+     instance C T
+
+Note that in some situations, the interface containing the type
+class instances may not have been loaded yet at all.  The usual
+situation when A imports another module which provides the
+instances (sigof02m):
+
+ module A(module B) where
+     import B
+
+See also Note [Signature lazy interface loading].  We can't
+rely on this, however, since sometimes we'll have spurious
+type class instances in the EPS, see #9422 (sigof02dm)
+
+************************************************************************
+*                                                                      *
+        Errors and tracing
+*                                                                      *
+************************************************************************
+-}
+
+traceDFuns :: [ClsInst] -> TcRn ()
+traceDFuns ispecs
+  = traceTc "Adding instances:" (vcat (map pp ispecs))
+  where
+    pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
+                  2 (ppr ispec)
+        -- Print the dfun name itself too
+
+funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
+funDepErr ispec ispecs
+  = addClsInstsErr (text "Functional dependencies conflict between instance declarations:")
+                    (ispec : ispecs)
+
+dupInstErr :: ClsInst -> ClsInst -> TcRn ()
+dupInstErr ispec dup_ispec
+  = addClsInstsErr (text "Duplicate instance declarations:")
+                    [ispec, dup_ispec]
+
+addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
+addClsInstsErr herald ispecs
+  = setSrcSpan (getSrcSpan (head sorted)) $
+    addErr (hang herald 2 (pprInstances sorted))
+ where
+   sorted = sortWith getSrcLoc ispecs
+   -- The sortWith just arranges that instances are dislayed in order
+   -- of source location, which reduced wobbling in error messages,
+   -- and is better for users
diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcAnnotations.hs
@@ -0,0 +1,79 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+\section[TcAnnotations]{Typechecking annotations}
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcAnnotations ( tcAnnotations, annCtxt ) where
+
+import GhcPrelude
+
+import {-# SOURCE #-} TcSplice ( runAnnotation )
+import Module
+import DynFlags
+import Control.Monad ( when )
+
+import HsSyn
+import Name
+import Annotations
+import TcRnMonad
+import SrcLoc
+import Outputable
+
+-- Some platforms don't support the external interpreter, and
+-- compilation on those platforms shouldn't fail just due to
+-- annotations
+#ifndef GHCI
+tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation]
+tcAnnotations anns = do
+  dflags <- getDynFlags
+  case gopt Opt_ExternalInterpreter dflags of
+    True  -> tcAnnotations' anns
+    False -> warnAnns anns
+warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation]
+--- No GHCI; emit a warning (not an error) and ignore. cf Trac #4268
+warnAnns [] = return []
+warnAnns anns@(L loc _ : _)
+  = do { setSrcSpan loc $ addWarnTc NoReason $
+             (text "Ignoring ANN annotation" <> plural anns <> comma
+             <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi")
+       ; return [] }
+#else
+tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation]
+tcAnnotations = tcAnnotations'
+#endif
+
+tcAnnotations' :: [LAnnDecl GhcRn] -> TcM [Annotation]
+tcAnnotations' anns = mapM tcAnnotation anns
+
+tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation
+tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do
+    -- Work out what the full target of this annotation was
+    mod <- getModule
+    let target = annProvenanceToTarget mod provenance
+
+    -- Run that annotation and construct the full Annotation data structure
+    setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do
+      -- See #10826 -- Annotations allow one to bypass Safe Haskell.
+      dflags <- getDynFlags
+      when (safeLanguageOn dflags) $ failWithTc safeHsErr
+      runAnnotation target expr
+    where
+      safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell."
+                  , text "See https://ghc.haskell.org/trac/ghc/ticket/10826" ]
+tcAnnotation (L _ (XAnnDecl _)) = panic "tcAnnotation"
+
+annProvenanceToTarget :: Module -> AnnProvenance Name
+                      -> AnnTarget Name
+annProvenanceToTarget _   (ValueAnnProvenance (L _ name)) = NamedTarget name
+annProvenanceToTarget _   (TypeAnnProvenance (L _ name))  = NamedTarget name
+annProvenanceToTarget mod ModuleAnnProvenance             = ModuleTarget mod
+
+annCtxt :: (OutputableBndrId (GhcPass p)) => AnnDecl (GhcPass p) -> SDoc
+annCtxt ann
+  = hang (text "In the annotation:") 2 (ppr ann)
diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcArrows.hs
@@ -0,0 +1,440 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+Typecheck arrow notation
+-}
+
+{-# LANGUAGE RankNTypes, TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcArrows ( tcProc ) where
+
+import GhcPrelude
+
+import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr )
+
+import HsSyn
+import TcMatches
+import TcHsSyn( hsLPatType )
+import TcType
+import TcMType
+import TcBinds
+import TcPat
+import TcUnify
+import TcRnMonad
+import TcEnv
+import TcEvidence
+import Id( mkLocalId )
+import Inst
+import Name
+import TysWiredIn
+import VarSet
+import TysPrim
+import BasicTypes( Arity )
+import SrcLoc
+import Outputable
+import Util
+
+import Control.Monad
+
+{-
+Note [Arrow overview]
+~~~~~~~~~~~~~~~~~~~~~
+Here's a summary of arrows and how they typecheck.  First, here's
+a cut-down syntax:
+
+  expr ::= ....
+        |  proc pat cmd
+
+  cmd ::= cmd exp                    -- Arrow application
+       |  \pat -> cmd                -- Arrow abstraction
+       |  (| exp cmd1 ... cmdn |)    -- Arrow form, n>=0
+       |  ... -- If, case in the usual way
+
+  cmd_type ::= carg_type --> type
+
+  carg_type ::= ()
+             |  (type, carg_type)
+
+Note that
+ * The 'exp' in an arrow form can mention only
+   "arrow-local" variables
+
+ * An "arrow-local" variable is bound by an enclosing
+   cmd binding form (eg arrow abstraction)
+
+ * A cmd_type is here written with a funny arrow "-->",
+   The bit on the left is a carg_type (command argument type)
+   which itself is a nested tuple, finishing with ()
+
+ * The arrow-tail operator (e1 -< e2) means
+       (| e1 <<< arr snd |) e2
+
+
+************************************************************************
+*                                                                      *
+                Proc
+*                                                                      *
+************************************************************************
+-}
+
+tcProc :: InPat GhcRn -> LHsCmdTop GhcRn        -- proc pat -> expr
+       -> ExpRhoType                            -- Expected type of whole proc expression
+       -> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion)
+
+tcProc pat cmd exp_ty
+  = newArrowScope $
+    do  { exp_ty <- expTypeToType exp_ty  -- no higher-rank stuff with arrows
+        ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
+        ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
+        ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
+        ; (pat', cmd') <- tcPat ProcExpr pat (mkCheckExpType arg_ty) $
+                          tcCmdTop cmd_env cmd (unitTy, res_ty)
+        ; let res_co = mkTcTransCo co
+                         (mkTcAppCo co1 (mkTcNomReflCo res_ty))
+        ; return (pat', cmd', res_co) }
+
+{-
+************************************************************************
+*                                                                      *
+                Commands
+*                                                                      *
+************************************************************************
+-}
+
+-- See Note [Arrow overview]
+type CmdType    = (CmdArgType, TcTauType)    -- cmd_type
+type CmdArgType = TcTauType                  -- carg_type, a nested tuple
+
+data CmdEnv
+  = CmdEnv {
+        cmd_arr :: TcType -- arrow type constructor, of kind *->*->*
+    }
+
+mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
+mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
+
+---------------------------------------
+tcCmdTop :: CmdEnv
+         -> LHsCmdTop GhcRn
+         -> CmdType
+         -> TcM (LHsCmdTop GhcTcId)
+
+tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty)
+  = setSrcSpan loc $
+    do  { cmd'   <- tcCmd env cmd cmd_ty
+        ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names
+        ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') }
+tcCmdTop _ (L _ XCmdTop{}) _ = panic "tcCmdTop"
+
+----------------------------------------
+tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId)
+        -- The main recursive function
+tcCmd env (L loc cmd) res_ty
+  = setSrcSpan loc $ do
+        { cmd' <- tc_cmd env cmd res_ty
+        ; return (L loc cmd') }
+
+tc_cmd :: CmdEnv -> HsCmd GhcRn  -> CmdType -> TcM (HsCmd GhcTcId)
+tc_cmd env (HsCmdPar x cmd) res_ty
+  = do  { cmd' <- tcCmd env cmd res_ty
+        ; return (HsCmdPar x cmd') }
+
+tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty
+  = do  { (binds', body') <- tcLocalBinds binds         $
+                             setSrcSpan body_loc        $
+                             tc_cmd env body res_ty
+        ; return (HsCmdLet x (L l binds') (L body_loc body')) }
+
+tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)
+  = addErrCtxt (cmdCtxt in_cmd) $ do
+      (scrut', scrut_ty) <- tcInferRho scrut
+      matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty)
+      return (HsCmdCase x scrut' matches')
+  where
+    match_ctxt = MC { mc_what = CaseAlt,
+                      mc_body = mc_body }
+    mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'
+                              ; tcCmd env body (stk, res_ty') }
+
+tc_cmd env (HsCmdIf x Nothing pred b1 b2) res_ty    -- Ordinary 'if'
+  = do  { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
+        ; b1'   <- tcCmd env b1 res_ty
+        ; b2'   <- tcCmd env b2 res_ty
+        ; return (HsCmdIf x Nothing pred' b1' b2')
+    }
+
+tc_cmd env (HsCmdIf x (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
+  = do  { pred_ty <- newOpenFlexiTyVarTy
+        -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r
+        -- because we're going to apply it to the environment, not
+        -- the return value.
+        ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar]
+        ; let r_ty = mkTyVarTy r_tv
+        ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty))
+                  (text "Predicate type of `ifThenElse' depends on result type")
+        ; (pred', fun')
+            <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty])
+                                       (mkCheckExpType r_ty) $ \ _ ->
+               tcMonoExpr pred (mkCheckExpType pred_ty)
+
+        ; b1'   <- tcCmd env b1 res_ty
+        ; b2'   <- tcCmd env b2 res_ty
+        ; return (HsCmdIf x (Just fun') pred' b1' b2')
+    }
+
+-------------------------------------------
+--              Arrow application
+--          (f -< a)   or   (f -<< a)
+--
+--   D   |- fun :: a t1 t2
+--   D,G |- arg :: t1
+--  ------------------------
+--   D;G |-a  fun -< arg :: stk --> t2
+--
+--   D,G |- fun :: a t1 t2
+--   D,G |- arg :: t1
+--  ------------------------
+--   D;G |-a  fun -<< arg :: stk --> t2
+--
+-- (plus -<< requires ArrowApply)
+
+tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty)
+  = addErrCtxt (cmdCtxt cmd)    $
+    do  { arg_ty <- newOpenFlexiTyVarTy
+        ; let fun_ty = mkCmdArrTy env arg_ty res_ty
+        ; fun' <- select_arrow_scope (tcMonoExpr fun (mkCheckExpType fun_ty))
+
+        ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty)
+
+        ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) }
+  where
+       -- Before type-checking f, use the environment of the enclosing
+       -- proc for the (-<) case.
+       -- Local bindings, inside the enclosing proc, are not in scope
+       -- inside f.  In the higher-order case (-<<), they are.
+       -- See Note [Escaping the arrow scope] in TcRnTypes
+    select_arrow_scope tc = case ho_app of
+        HsHigherOrderApp -> tc
+        HsFirstOrderApp  -> escapeArrowScope tc
+
+-------------------------------------------
+--              Command application
+--
+-- D,G |-  exp : t
+-- D;G |-a cmd : (t,stk) --> res
+-- -----------------------------
+-- D;G |-a cmd exp : stk --> res
+
+tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty)
+  = addErrCtxt (cmdCtxt cmd)    $
+    do  { arg_ty <- newOpenFlexiTyVarTy
+        ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)
+        ; arg'   <- tcMonoExpr arg (mkCheckExpType arg_ty)
+        ; return (HsCmdApp x fun' arg') }
+
+-------------------------------------------
+--              Lambda
+--
+-- D;G,x:t |-a cmd : stk --> res
+-- ------------------------------
+-- D;G |-a (\x.cmd) : (t,stk) --> res
+
+tc_cmd env
+       (HsCmdLam x (MG { mg_alts = L l [L mtch_loc
+                                   (match@(Match { m_pats = pats, m_grhss = grhss }))],
+                         mg_origin = origin }))
+       (cmd_stk, res_ty)
+  = addErrCtxt (pprMatchInCtxt match)        $
+    do  { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk
+
+                -- Check the patterns, and the GRHSs inside
+        ; (pats', grhss') <- setSrcSpan mtch_loc                                 $
+                             tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $
+                             tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)
+
+        ; let match' = L mtch_loc (Match { m_ext = noExt
+                                         , m_ctxt = LambdaExpr, m_pats = pats'
+                                         , m_grhss = grhss' })
+              arg_tys = map hsLPatType pats'
+              cmd' = HsCmdLam x (MG { mg_alts = L l [match']
+                                    , mg_ext = MatchGroupTc arg_tys res_ty
+                                    , mg_origin = origin })
+        ; return (mkHsCmdWrap (mkWpCastN co) cmd') }
+  where
+    n_pats     = length pats
+    match_ctxt = (LambdaExpr :: HsMatchContext Name)    -- Maybe KappaExpr?
+    pg_ctxt    = PatGuard match_ctxt
+
+    tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty
+        = do { (binds', grhss') <- tcLocalBinds binds $
+                                   mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss
+             ; return (GRHSs x grhss' (L l binds')) }
+    tc_grhss (XGRHSs _) _ _ = panic "tc_grhss"
+
+    tc_grhs stk_ty res_ty (GRHS x guards body)
+        = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
+                                  \ res_ty -> tcCmd env body
+                                                (stk_ty, checkingExpType "tc_grhs" res_ty)
+             ; return (GRHS x guards' rhs') }
+    tc_grhs _ _ (XGRHS _) = panic "tc_grhs"
+
+-------------------------------------------
+--              Do notation
+
+tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty)
+  = do  { co <- unifyType Nothing unitTy cmd_stk  -- Expecting empty argument stack
+        ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty
+        ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) }
+
+
+-----------------------------------------------------------------
+--      Arrow ``forms''       (| e c1 .. cn |)
+--
+--      D; G |-a1 c1 : stk1 --> r1
+--      ...
+--      D; G |-an cn : stkn --> rn
+--      D |-  e :: forall e. a1 (e, stk1) t1
+--                                ...
+--                        -> an (e, stkn) tn
+--                        -> a  (e, stk) t
+--      e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn)
+--      ----------------------------------------------
+--      D; G |-a  (| e c1 ... cn |)  :  stk --> t
+
+tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)
+  = addErrCtxt (cmdCtxt cmd)    $
+    do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args
+                              -- We use alphaTyVar for 'w'
+        ; let e_ty = mkInvForAllTy alphaTyVar $
+                     mkFunTys cmd_tys $
+                     mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty
+        ; expr' <- tcPolyExpr expr e_ty
+        ; return (HsCmdArrForm x expr' f fixity cmd_args') }
+
+  where
+    tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType)
+    tc_cmd_arg cmd
+       = do { arr_ty <- newFlexiTyVarTy arrowTyConKind
+            ; stk_ty <- newFlexiTyVarTy liftedTypeKind
+            ; res_ty <- newFlexiTyVarTy liftedTypeKind
+            ; let env' = env { cmd_arr = arr_ty }
+            ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty)
+            ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }
+
+tc_cmd _ (XCmd {}) _ = panic "tc_cmd"
+
+-----------------------------------------------------------------
+--              Base case for illegal commands
+-- This is where expressions that aren't commands get rejected
+
+tc_cmd _ cmd _
+  = failWithTc (vcat [text "The expression", nest 2 (ppr cmd),
+                      text "was found where an arrow command was expected"])
+
+
+matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType)
+matchExpectedCmdArgs 0 ty
+  = return (mkTcNomReflCo ty, [], ty)
+matchExpectedCmdArgs n ty
+  = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty
+       ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2
+       ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) }
+
+{-
+************************************************************************
+*                                                                      *
+                Stmts
+*                                                                      *
+************************************************************************
+-}
+
+--------------------------------
+--      Mdo-notation
+-- The distinctive features here are
+--      (a) RecStmts, and
+--      (b) no rebindable syntax
+
+tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker
+tcArrDoStmt env _ (LastStmt x rhs noret _) res_ty thing_inside
+  = do  { rhs' <- tcCmd env rhs (unitTy, res_ty)
+        ; thing <- thing_inside (panic "tcArrDoStmt")
+        ; return (LastStmt x rhs' noret noSyntaxExpr, thing) }
+
+tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside
+  = do  { (rhs', elt_ty) <- tc_arr_rhs env rhs
+        ; thing          <- thing_inside res_ty
+        ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) }
+
+tcArrDoStmt env ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside
+  = do  { (rhs', pat_ty) <- tc_arr_rhs env rhs
+        ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
+                            thing_inside res_ty
+        ; return (mkTcBindStmt pat' rhs', thing) }
+
+tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
+                            , recS_rec_ids = rec_names }) res_ty thing_inside
+  = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
+        ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
+        ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
+        ; tcExtendIdEnv tup_ids $ do
+        { (stmts', tup_rets)
+                <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty   $ \ _res_ty' ->
+                        -- ToDo: res_ty not really right
+                   zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys)
+
+        ; thing <- thing_inside res_ty
+                -- NB:  The rec_ids for the recursive things
+                --      already scope over this part. This binding may shadow
+                --      some of them with polymorphic things with the same Name
+                --      (see note [RecStmt] in HsExpr)
+
+        ; let rec_ids = takeList rec_names tup_ids
+        ; later_ids <- tcLookupLocalIds later_names
+
+        ; let rec_rets = takeList rec_names tup_rets
+        ; let ret_table = zip tup_ids tup_rets
+        ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j]
+
+        ; return (emptyRecStmtId { recS_stmts = stmts'
+                                 , recS_later_ids = later_ids
+                                 , recS_rec_ids = rec_ids
+                                 , recS_ext = unitRecStmtTc
+                                     { recS_later_rets = later_rets
+                                     , recS_rec_rets = rec_rets
+                                     , recS_ret_ty = res_ty} }, thing)
+        }}
+
+tcArrDoStmt _ _ stmt _ _
+  = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt)
+
+tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTcId, TcType)
+tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind
+                        ; rhs' <- tcCmd env rhs (unitTy, ty)
+                        ; return (rhs', ty) }
+
+{-
+************************************************************************
+*                                                                      *
+                Helpers
+*                                                                      *
+************************************************************************
+-}
+
+mkPairTy :: Type -> Type -> Type
+mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]
+
+arrowTyConKind :: Kind          --  *->*->*
+arrowTyConKind = mkFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind
+
+{-
+************************************************************************
+*                                                                      *
+                Errors
+*                                                                      *
+************************************************************************
+-}
+
+cmdCtxt :: HsCmd GhcRn -> SDoc
+cmdCtxt cmd = text "In the command:" <+> ppr cmd
diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcBackpack.hs
@@ -0,0 +1,1000 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module TcBackpack (
+    findExtraSigImports',
+    findExtraSigImports,
+    implicitRequirements',
+    implicitRequirements,
+    checkUnitId,
+    tcRnCheckUnitId,
+    tcRnMergeSignatures,
+    mergeSignatures,
+    tcRnInstantiateSignature,
+    instantiateSignature,
+) where
+
+import GhcPrelude
+
+import BasicTypes (defaultFixity)
+import Packages
+import TcRnExports
+import DynFlags
+import HsSyn
+import RdrName
+import TcRnMonad
+import TcTyDecls
+import InstEnv
+import FamInstEnv
+import Inst
+import TcIface
+import TcMType
+import TcType
+import TcSimplify
+import LoadIface
+import RnNames
+import ErrUtils
+import Id
+import Module
+import Name
+import NameEnv
+import NameSet
+import Avail
+import SrcLoc
+import HscTypes
+import Outputable
+import Type
+import FastString
+import RnFixity ( lookupFixityRn )
+import Maybes
+import TcEnv
+import Var
+import IfaceSyn
+import PrelNames
+import qualified Data.Map as Map
+
+import Finder
+import UniqDSet
+import NameShape
+import TcErrors
+import TcUnify
+import RnModIface
+import Util
+
+import Control.Monad
+import Data.List (find)
+
+import {-# SOURCE #-} TcRnDriver
+
+#include "HsVersions.h"
+
+fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc
+fixityMisMatch real_thing real_fixity sig_fixity =
+    vcat [ppr real_thing <+> text "has conflicting fixities in the module",
+          text "and its hsig file",
+          text "Main module:" <+> ppr_fix real_fixity,
+          text "Hsig file:" <+> ppr_fix sig_fixity]
+  where
+    ppr_fix f =
+        ppr f <+>
+        (if f == defaultFixity
+            then parens (text "default")
+            else empty)
+
+checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()
+checkHsigDeclM sig_iface sig_thing real_thing = do
+    let name = getName real_thing
+    -- TODO: Distinguish between signature merging and signature
+    -- implementation cases.
+    checkBootDeclM False sig_thing real_thing
+    real_fixity <- lookupFixityRn name
+    let sig_fixity = case mi_fix_fn sig_iface (occName name) of
+                        Nothing -> defaultFixity
+                        Just f -> f
+    when (real_fixity /= sig_fixity) $
+      addErrAt (nameSrcSpan name)
+        (fixityMisMatch real_thing real_fixity sig_fixity)
+
+-- | Given a 'ModDetails' of an instantiated signature (note that the
+-- 'ModDetails' must be knot-tied consistently with the actual implementation)
+-- and a 'GlobalRdrEnv' constructed from the implementor of this interface,
+-- verify that the actual implementation actually matches the original
+-- interface.
+--
+-- Note that it is already assumed that the implementation *exports*
+-- a sufficient set of entities, since otherwise the renaming and then
+-- typechecking of the signature 'ModIface' would have failed.
+checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn ()
+checkHsigIface tcg_env gr sig_iface
+  ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,
+               md_types = sig_type_env, md_exports = sig_exports   } = do
+    traceTc "checkHsigIface" $ vcat
+        [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]
+    mapM_ check_export (map availName sig_exports)
+    unless (null sig_fam_insts) $
+        panic ("TcRnDriver.checkHsigIface: Cannot handle family " ++
+               "instances in hsig files yet...")
+    -- Delete instances so we don't look them up when
+    -- checking instance satisfiability
+    -- TODO: this should not be necessary
+    tcg_env <- getGblEnv
+    setGblEnv tcg_env { tcg_inst_env = emptyInstEnv,
+                        tcg_fam_inst_env = emptyFamInstEnv,
+                        tcg_insts = [],
+                        tcg_fam_insts = [] } $ do
+    mapM_ check_inst sig_insts
+    failIfErrsM
+  where
+    -- NB: the Names in sig_type_env are bogus.  Let's say we have H.hsig
+    -- in package p that defines T; and we implement with himpl:H.  Then the
+    -- Name is p[himpl:H]:H.T, NOT himplH:H.T.  That's OK but we just
+    -- have to look up the right name.
+    sig_type_occ_env = mkOccEnv
+                     . map (\t -> (nameOccName (getName t), t))
+                     $ nameEnvElts sig_type_env
+    dfun_names = map getName sig_insts
+    check_export name
+      -- Skip instances, we'll check them later
+      -- TODO: Actually this should never happen, because DFuns are
+      -- never exported...
+      | name `elem` dfun_names = return ()
+      -- See if we can find the type directly in the hsig ModDetails
+      -- TODO: need to special case wired in names
+      | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do
+        -- NB: We use tcLookupImported_maybe because we want to EXCLUDE
+        -- tcg_env (TODO: but maybe this isn't relevant anymore).
+        r <- tcLookupImported_maybe name
+        case r of
+          Failed err -> addErr err
+          Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing
+
+      -- The hsig did NOT define this function; that means it must
+      -- be a reexport.  In this case, make sure the 'Name' of the
+      -- reexport matches the 'Name exported here.
+      | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) =
+        when (name /= name') $ do
+            -- See Note [Error reporting bad reexport]
+            -- TODO: Actually this error swizzle doesn't work
+            let p (L _ ie) = name `elem` ieNames ie
+                loc = case tcg_rn_exports tcg_env of
+                       Just es | Just e <- find p (map fst es)
+                         -- TODO: maybe we can be a little more
+                         -- precise here and use the Located
+                         -- info for the *specific* name we matched.
+                         -> getLoc e
+                       _ -> nameSrcSpan name
+            dflags <- getDynFlags
+            addErrAt loc
+                (badReexportedBootThing dflags False name name')
+      -- This should actually never happen, but whatever...
+      | otherwise =
+        addErrAt (nameSrcSpan name)
+            (missingBootThing False name "exported by")
+
+-- Note [Error reporting bad reexport]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- NB: You want to be a bit careful about what location you report on reexports.
+-- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the
+-- correct source location.  However, if it was *reexported*, obviously the name
+-- is not going to have the right location.  In this case, we need to grovel in
+-- tcg_rn_exports to figure out where the reexport came from.
+
+
+
+-- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't
+-- assume that the implementing file actually implemented the instances (they
+-- may be reexported from elsewhere).  Where should we look for the instances?
+-- We do the same as we would otherwise: consult the EPS.  This isn't perfect
+-- (we might conclude the module exports an instance when it doesn't, see
+-- #9422), but we will never refuse to compile something.
+check_inst :: ClsInst -> TcM ()
+check_inst sig_inst = do
+    -- TODO: This could be very well generalized to support instance
+    -- declarations in boot files.
+    tcg_env <- getGblEnv
+    -- NB: Have to tug on the interface, not necessarily
+    -- tugged... but it didn't work?
+    mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst))
+    -- Based off of 'simplifyDeriv'
+    let ty = idType (instanceDFunId sig_inst)
+        skol_info = InstSkol
+        -- Based off of tcSplitDFunTy
+        (tvs, theta, pred) =
+           case tcSplitForAllTys ty of { (tvs, rho)   ->
+           case splitFunTys rho     of { (theta, pred) ->
+           (tvs, theta, pred) }}
+        origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst
+    (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
+    (tclvl,cts) <- pushTcLevelM $ do
+       wanted <- newWanted origin
+                           (Just TypeLevel)
+                           (substTy skol_subst pred)
+       givens <- forM theta $ \given -> do
+           loc <- getCtLocM origin (Just TypeLevel)
+           let given_pred = substTy skol_subst given
+           new_ev <- newEvVar given_pred
+           return CtGiven { ctev_pred = given_pred
+                          -- Doesn't matter, make something up
+                          , ctev_evar = new_ev
+                          , ctev_loc = loc
+                          }
+       return $ wanted : givens
+    unsolved <- simplifyWantedsTcM cts
+
+    (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved
+    reportAllUnsolved (mkImplicWC implic)
+
+-- | Return this list of requirement interfaces that need to be merged
+-- to form @mod_name@, or @[]@ if this is not a requirement.
+requirementMerges :: DynFlags -> ModuleName -> [IndefModule]
+requirementMerges dflags mod_name =
+    fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags)))
+
+-- | For a module @modname@ of type 'HscSource', determine the list
+-- of extra "imports" of other requirements which should be considered part of
+-- the import of the requirement, because it transitively depends on those
+-- requirements by imports of modules from other packages.  The situation
+-- is something like this:
+--
+--      unit p where
+--          signature A
+--          signature B
+--              import A
+--
+--      unit q where
+--          dependency p[A=<A>,B=<B>]
+--          signature A
+--          signature B
+--
+-- Although q's B does not directly import A, we still have to make sure we
+-- process A first, because the merging process will cause B to indirectly
+-- import A.  This function finds the TRANSITIVE closure of all such imports
+-- we need to make.
+findExtraSigImports' :: HscEnv
+                     -> HscSource
+                     -> ModuleName
+                     -> IO (UniqDSet ModuleName)
+findExtraSigImports' hsc_env HsigFile modname =
+    fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) ->
+        (initIfaceLoad hsc_env
+            . withException
+            $ moduleFreeHolesPrecise (text "findExtraSigImports")
+                (mkModule (IndefiniteUnitId iuid) mod_name)))
+  where
+    reqs = requirementMerges (hsc_dflags hsc_env) modname
+
+findExtraSigImports' _ _ _ = return emptyUniqDSet
+
+-- | 'findExtraSigImports', but in a convenient form for "GhcMake" and
+-- "TcRnDriver".
+findExtraSigImports :: HscEnv -> HscSource -> ModuleName
+                    -> IO [(Maybe FastString, Located ModuleName)]
+findExtraSigImports hsc_env hsc_src modname = do
+    extra_requirements <- findExtraSigImports' hsc_env hsc_src modname
+    return [ (Nothing, noLoc mod_name)
+           | mod_name <- uniqDSetToList extra_requirements ]
+
+-- A version of 'implicitRequirements'' which is more friendly
+-- for "GhcMake" and "TcRnDriver".
+implicitRequirements :: HscEnv
+                     -> [(Maybe FastString, Located ModuleName)]
+                     -> IO [(Maybe FastString, Located ModuleName)]
+implicitRequirements hsc_env normal_imports
+  = do mns <- implicitRequirements' hsc_env normal_imports
+       return [ (Nothing, noLoc mn) | mn <- mns ]
+
+-- Given a list of 'import M' statements in a module, figure out
+-- any extra implicit requirement imports they may have.  For
+-- example, if they 'import M' and M resolves to p[A=<B>], then
+-- they actually also import the local requirement B.
+implicitRequirements' :: HscEnv
+                     -> [(Maybe FastString, Located ModuleName)]
+                     -> IO [ModuleName]
+implicitRequirements' hsc_env normal_imports
+  = fmap concat $
+    forM normal_imports $ \(mb_pkg, L _ imp) -> do
+        found <- findImportedModule hsc_env imp mb_pkg
+        case found of
+            Found _ mod | thisPackage dflags /= moduleUnitId mod ->
+                return (uniqDSetToList (moduleFreeHoles mod))
+            _ -> return []
+  where dflags = hsc_dflags hsc_env
+
+-- | Given a 'UnitId', make sure it is well typed.  This is because
+-- unit IDs come from Cabal, which does not know if things are well-typed or
+-- not; a component may have been filled with implementations for the holes
+-- that don't actually fulfill the requirements.
+--
+-- INVARIANT: the UnitId is NOT a InstalledUnitId
+checkUnitId :: UnitId -> TcM ()
+checkUnitId uid = do
+    case splitUnitIdInsts uid of
+      (_, Just indef) ->
+        let insts = indefUnitIdInsts indef in
+        forM_ insts $ \(mod_name, mod) ->
+            -- NB: direct hole instantiations are well-typed by construction
+            -- (because we FORCE things to be merged in), so don't check them
+            when (not (isHoleModule mod)) $ do
+                checkUnitId (moduleUnitId mod)
+                _ <- mod `checkImplements` IndefModule indef mod_name
+                return ()
+      _ -> return () -- if it's hashed, must be well-typed
+
+-- | Top-level driver for signature instantiation (run when compiling
+-- an @hsig@ file.)
+tcRnCheckUnitId ::
+    HscEnv -> UnitId ->
+    IO (Messages, Maybe ())
+tcRnCheckUnitId hsc_env uid =
+   withTiming (pure dflags)
+              (text "Check unit id" <+> ppr uid)
+              (const ()) $
+   initTc hsc_env
+          HsigFile -- bogus
+          False
+          mAIN -- bogus
+          (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus
+    $ checkUnitId uid
+  where
+   dflags = hsc_dflags hsc_env
+   loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid)
+
+-- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear...
+
+-- | Top-level driver for signature merging (run after typechecking
+-- an @hsig@ file).
+tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface
+                    -> IO (Messages, Maybe TcGblEnv)
+tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =
+  withTiming (pure dflags)
+             (text "Signature merging" <+> brackets (ppr this_mod))
+             (const ()) $
+  initTc hsc_env HsigFile False this_mod real_loc $
+    mergeSignatures hpm orig_tcg_env iface
+ where
+  dflags   = hsc_dflags hsc_env
+  this_mod = mi_module iface
+  real_loc = tcg_top_loc orig_tcg_env
+
+thinModIface :: [AvailInfo] -> ModIface -> ModIface
+thinModIface avails iface =
+    iface {
+        mi_exports = avails,
+        -- mi_fixities = ...,
+        -- mi_warns = ...,
+        -- mi_anns = ...,
+        -- TODO: The use of nameOccName here is a bit dodgy, because
+        -- perhaps there might be two IfaceTopBndr that are the same
+        -- OccName but different Name.  Requires better understanding
+        -- of invariants here.
+        mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls
+        -- mi_insts = ...,
+        -- mi_fam_insts = ...,
+    }
+  where
+    decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs
+    filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface)
+
+    exported_occs = mkOccSet [ occName n
+                             | a <- avails
+                             , n <- availNames a ]
+    exported_decls = filter_decls exported_occs
+
+    non_exported_occs = mkOccSet [ occName n
+                                 | (_, d) <- exported_decls
+                                 , n <- ifaceDeclNeverExportedRefs d ]
+    non_exported_decls = filter_decls non_exported_occs
+
+    dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True
+    dfun_pred _ = False
+    dfun_decls = filter (dfun_pred . snd) (mi_decls iface)
+
+-- | The list of 'Name's of *non-exported* 'IfaceDecl's which this
+-- 'IfaceDecl' may refer to.  A non-exported 'IfaceDecl' should be kept
+-- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps)
+-- refers to it; we can't decide to keep it by looking at the exports
+-- of a module after thinning.  Keep this synchronized with
+-- 'rnIfaceDecl'.
+ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name]
+ifaceDeclNeverExportedRefs d@IfaceFamily{} =
+    case ifFamFlav d of
+        IfaceClosedSynFamilyTyCon (Just (n, _))
+            -> [n]
+        _   -> []
+ifaceDeclNeverExportedRefs _ = []
+
+
+-- Note [Blank hsigs for all requirements]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- One invariant that a client of GHC must uphold is that there
+-- must be an hsig file for every requirement (according to
+-- @-this-unit-id@); this ensures that for every interface
+-- file (hi), there is a source file (hsig), which helps grease
+-- the wheels of recompilation avoidance which assumes that
+-- source files always exist.
+
+{-
+inheritedSigPvpWarning :: WarningTxt
+inheritedSigPvpWarning =
+    WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))]
+  where
+    msg = "Inherited requirements from non-signature libraries (libraries " ++
+          "with modules) should not be used, as this mode of use is not " ++
+          "compatible with PVP-style version bounds.  Instead, copy the " ++
+          "declaration to the local hsig file or move the signature to a " ++
+          "library of its own and add that library as a dependency."
+-}
+
+-- Note [Handling never-exported TyThings under Backpack]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--   DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will
+--   never be mentioned in the export list of a module (mi_avails).
+--   Unlike implicit TyThings (Note [Implicit TyThings]), non-exported
+--   TyThings DO have a standalone IfaceDecl declaration in their
+--   interface file.
+--
+-- Originally, Backpack was designed under the assumption that anything
+-- you could declare in a module could also be exported; thus, merging
+-- the export lists of two signatures is just merging the declarations
+-- of two signatures writ small.  Of course, in GHC Haskell, there are a
+-- few important things which are not explicitly exported but still can
+-- be used:  in particular, dictionary functions for instances, Typeable
+-- TyCon bindings, and coercion axioms for type families also count.
+--
+-- When handling these non-exported things, there two primary things
+-- we need to watch out for:
+--
+--  * Signature matching/merging is done by comparing each
+--    of the exported entities of a signature and a module.  These exported
+--    entities may refer to non-exported TyThings which must be tested for
+--    consistency.  For example, an instance (ClsInst) will refer to a
+--    non-exported DFunId.  In this case, 'checkBootDeclM' directly compares the
+--    embedded 'DFunId' in 'is_dfun'.
+--
+--    For this to work at all, we must ensure that pointers in 'is_dfun' refer
+--    to DISTINCT 'DFunId's, even though the 'Name's (may) be the same.
+--    Unfortunately, this is the OPPOSITE of how we treat most other references
+--    to 'Name's, so this case needs to be handled specially.
+--
+--    The details are in the documentation for 'typecheckIfacesForMerging'.
+--    and the Note [Resolving never-exported Names in TcIface].
+--
+--  * When we rename modules and signatures, we use the export lists to
+--    decide how the declarations should be renamed.  However, this
+--    means we don't get any guidance for how to rename non-exported
+--    entities.  Fortunately, we only need to rename these entities
+--    *consistently*, so that 'typecheckIfacesForMerging' can wire them
+--    up as needed.
+--
+--    The details are in Note [rnIfaceNeverExported] in 'RnModIface'.
+--
+-- The root cause for all of these complications is the fact that these
+-- logically "implicit" entities are defined indirectly in an interface
+-- file.  #13151 gives a proposal to make these *truly* implicit.
+
+merge_msg :: ModuleName -> [IndefModule] -> SDoc
+merge_msg mod_name [] =
+    text "while checking the local signature" <+> ppr mod_name <+>
+    text "for consistency"
+merge_msg mod_name reqs =
+  hang (text "while merging the signatures from" <> colon)
+   2 (vcat [ bullet <+> ppr req | req <- reqs ] $$
+      bullet <+> text "...and the local signature for" <+> ppr mod_name)
+
+-- | Given a local 'ModIface', merge all inherited requirements
+-- from 'requirementMerges' into this signature, producing
+-- a final 'TcGblEnv' that matches the local signature and
+-- all required signatures.
+mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv
+mergeSignatures
+  (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }),
+                    hpm_src_files = src_files })
+  orig_tcg_env lcl_iface0 = setSrcSpan loc $ do
+    -- The lcl_iface0 is the ModIface for the local hsig
+    -- file, which is guaranteed to exist, see
+    -- Note [Blank hsigs for all requirements]
+    hsc_env <- getTopEnv
+    dflags  <- getDynFlags
+
+    -- Copy over some things from the original TcGblEnv that
+    -- we want to preserve
+    updGblEnv (\env -> env {
+        -- Renamed imports/declarations are often used
+        -- by programs that use the GHC API, e.g., Haddock.
+        -- These won't get filled by the merging process (since
+        -- we don't actually rename the parsed module again) so
+        -- we need to take them directly from the previous
+        -- typechecking.
+        --
+        -- NB: the export declarations aren't in their final
+        -- form yet.  We'll fill those in when we reprocess
+        -- the export declarations.
+        tcg_rn_imports = tcg_rn_imports orig_tcg_env,
+        tcg_rn_decls   = tcg_rn_decls   orig_tcg_env,
+        -- Annotations
+        tcg_ann_env    = tcg_ann_env    orig_tcg_env,
+        -- Documentation header
+        tcg_doc_hdr    = tcg_doc_hdr orig_tcg_env
+        -- tcg_dus?
+        -- tcg_th_used           = tcg_th_used orig_tcg_env,
+        -- tcg_th_splice_used    = tcg_th_splice_used orig_tcg_env
+        -- tcg_th_top_level_locs = tcg_th_top_level_locs orig_tcg_env
+       }) $ do
+    tcg_env <- getGblEnv
+
+    let outer_mod = tcg_mod tcg_env
+        inner_mod = tcg_semantic_mod tcg_env
+        mod_name = moduleName (tcg_mod tcg_env)
+
+    -- STEP 1: Figure out all of the external signature interfaces
+    -- we are going to merge in.
+    let reqs = requirementMerges dflags mod_name
+
+    addErrCtxt (merge_msg mod_name reqs) $ do
+
+    -- STEP 2: Read in the RAW forms of all of these interfaces
+    ireq_ifaces0 <- forM reqs $ \(IndefModule iuid mod_name) ->
+        let m = mkModule (IndefiniteUnitId iuid) mod_name
+            im = fst (splitModuleInsts m)
+        in fmap fst
+         . withException
+         $ findAndReadIface (text "mergeSignatures") im m False
+
+    -- STEP 3: Get the unrenamed exports of all these interfaces,
+    -- thin it according to the export list, and do shaping on them.
+    let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as
+        -- This function gets run on every inherited interface, and
+        -- it's responsible for:
+        --
+        --  1. Merging the exports of the interface into @nsubst@,
+        --  2. Adding these exports to the "OK to import" set (@oks@)
+        --  if they came from a package with no exposed modules
+        --  (this means we won't report a PVP error in this case), and
+        --  3. Thinning the interface according to an explicit export
+        --  list.
+        --
+        gen_subst (nsubst,oks,ifaces) (imod@(IndefModule iuid _), ireq_iface) = do
+            let insts = indefUnitIdInsts iuid
+                isFromSignaturePackage =
+                    let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid))
+                        pkg = getInstalledPackageDetails dflags inst_uid
+                    in null (exposedModules pkg)
+            -- 3(a). Rename the exports according to how the dependency
+            -- was instantiated.  The resulting export list will be accurate
+            -- except for exports *from the signature itself* (which may
+            -- be subsequently updated by exports from other signatures in
+            -- the merge.
+            as1 <- tcRnModExports insts ireq_iface
+            -- 3(b). Thin the interface if it comes from a signature package.
+            (thinned_iface, as2) <- case mb_exports of
+                    Just (L loc _)
+                      -- Check if the package containing this signature is
+                      -- a signature package (i.e., does not expose any
+                      -- modules.)  If so, we can thin it.
+                      | isFromSignaturePackage
+                      -> setSrcSpan loc $ do
+                        -- Suppress missing errors; they might be used to refer
+                        -- to entities from other signatures we are merging in.
+                        -- If an identifier truly doesn't exist in any of the
+                        -- signatures that are merged in, we will discover this
+                        -- when we run exports_from_avail on the final merged
+                        -- export list.
+                        (msgs, mb_r) <- tryTc $ do
+                            -- Suppose that we have written in a signature:
+                            --  signature A ( module A ) where {- empty -}
+                            -- If I am also inheriting a signature from a
+                            -- signature package, does 'module A' scope over
+                            -- all of its exports?
+                            --
+                            -- There are two possible interpretations:
+                            --
+                            --  1. For non self-reexports, a module reexport
+                            --  is interpreted only in terms of the local
+                            --  signature module, and not any of the inherited
+                            --  ones.  The reason for this is because after
+                            --  typechecking, module exports are completely
+                            --  erased from the interface of a file, so we
+                            --  have no way of "interpreting" a module reexport.
+                            --  Thus, it's only useful for the local signature
+                            --  module (where we have a useful GlobalRdrEnv.)
+                            --
+                            --  2. On the other hand, a common idiom when
+                            --  you want to "export everything, plus a reexport"
+                            --  in modules is to say module A ( module A, reex ).
+                            --  This applies to signature modules too; and in
+                            --  particular, you probably still want the entities
+                            --  from the inherited signatures to be preserved
+                            --  too.
+                            --
+                            -- We think it's worth making a special case for
+                            -- self reexports to make use case (2) work.  To
+                            -- do this, we take the exports of the inherited
+                            -- signature @as1@, and bundle them into a
+                            -- GlobalRdrEnv where we treat them as having come
+                            -- from the import @import A@.  Thus, we will
+                            -- pick them up if they are referenced explicitly
+                            -- (@foo@) or even if we do a module reexport
+                            -- (@module A@).
+                            let ispec = ImpSpec ImpDeclSpec{
+                                            -- NB: This needs to be mod name
+                                            -- of the local signature, not
+                                            -- the (original) module name of
+                                            -- the inherited signature,
+                                            -- because we need module
+                                            -- LocalSig (from the local
+                                            -- export list) to match it!
+                                            is_mod  = mod_name,
+                                            is_as   = mod_name,
+                                            is_qual = False,
+                                            is_dloc = loc
+                                          } ImpAll
+                                rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1)
+                            setGblEnv tcg_env {
+                                tcg_rdr_env = rdr_env
+                            } $ exports_from_avail mb_exports rdr_env
+                                    -- NB: tcg_imports is also empty!
+                                    emptyImportAvails
+                                    (tcg_semantic_mod tcg_env)
+                        case mb_r of
+                            Just (_, as2) -> return (thinModIface as2 ireq_iface, as2)
+                            Nothing -> addMessages msgs >> failM
+                    -- We can't think signatures from non signature packages
+                    _ -> return (ireq_iface, as1)
+            -- 3(c). Only identifiers from signature packages are "ok" to
+            -- import (that is, they are safe from a PVP perspective.)
+            -- (NB: This code is actually dead right now.)
+            let oks' | isFromSignaturePackage
+                     = extendOccSetList oks (exportOccs as2)
+                     | otherwise
+                     = oks
+            -- 3(d). Extend the name substitution (performing shaping)
+            mb_r <- extend_ns nsubst as2
+            case mb_r of
+                Left err -> failWithTc err
+                Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces)
+        nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0)
+        ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0))
+    -- Process each interface, getting the thinned interfaces as well as
+    -- the final, full set of exports @nsubst@ and the exports which are
+    -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.)
+    (nsubst, ok_to_use, rev_thinned_ifaces)
+        <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0)
+    let thinned_ifaces = reverse rev_thinned_ifaces
+        exports        = nameShapeExports nsubst
+        rdr_env        = mkGlobalRdrEnv (gresFromAvails Nothing exports)
+        _warn_occs     = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports)
+        warns          = NoWarnings
+        {-
+        -- TODO: Warnings are transitive, but this is not what we want here:
+        -- if a module reexports an entity from a signature, that should be OK.
+        -- Not supported in current warning framework
+        warns | null warn_occs = NoWarnings
+              | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs
+        -}
+    setGblEnv tcg_env {
+        -- The top-level GlobalRdrEnv is quite interesting.  It consists
+        -- of two components:
+        --  1. First, we reuse the GlobalRdrEnv of the local signature.
+        --     This is very useful, because it means that if we have
+        --     to print a message involving some entity that the local
+        --     signature imported, we'll qualify it accordingly.
+        --  2. Second, we need to add all of the declarations we are
+        --     going to merge in (as they need to be in scope for the
+        --     final test of the export list.)
+        tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env,
+        -- Inherit imports from the local signature, so that module
+        -- rexports are picked up correctly
+        tcg_imports = tcg_imports orig_tcg_env,
+        tcg_exports = exports,
+        tcg_dus     = usesOnly (availsToNameSetWithSelectors exports),
+        tcg_warns   = warns
+        } $ do
+    tcg_env <- getGblEnv
+
+    -- Make sure we didn't refer to anything that doesn't actually exist
+    -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return ()
+    (mb_lies, _) <- exports_from_avail mb_exports rdr_env
+                        (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)
+
+    {- -- NB: This is commented out, because warns above is disabled.
+    -- If you tried to explicitly export an identifier that has a warning
+    -- attached to it, that's probably a mistake.  Warn about it.
+    case mb_lies of
+      Nothing -> return ()
+      Just lies ->
+        forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) ->
+          setSrcSpan loc $
+            unless (nameOccName n `elemOccSet` ok_to_use) $
+                addWarn NoReason $ vcat [
+                    text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.",
+                    parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.")
+                    ]
+    -}
+
+    failIfErrsM
+
+    -- Save the exports
+    setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do
+    tcg_env <- getGblEnv
+
+    -- STEP 4: Rename the interfaces
+    ext_ifaces <- forM thinned_ifaces $ \((IndefModule iuid _), ireq_iface) ->
+        tcRnModIface (indefUnitIdInsts iuid) (Just nsubst) ireq_iface
+    lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0
+    let ifaces = lcl_iface : ext_ifaces
+
+    -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env
+    let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
+                            | (occ, f) <- concatMap mi_fixities ifaces
+                            , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ]
+
+    -- STEP 5: Typecheck the interfaces
+    let type_env_var = tcg_type_env_var tcg_env
+
+    -- typecheckIfacesForMerging does two things:
+    --      1. It merges the all of the ifaces together, and typechecks the
+    --      result to type_env.
+    --      2. It typechecks each iface individually, but with their 'Name's
+    --      resolving to the merged type_env from (1).
+    -- See typecheckIfacesForMerging for more details.
+    (type_env, detailss) <- initIfaceTcRn $
+                            typecheckIfacesForMerging inner_mod ifaces type_env_var
+    let infos = zip ifaces detailss
+
+    -- Test for cycles
+    checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) []
+
+    -- NB on type_env: it contains NO dfuns.  DFuns are recorded inside
+    -- detailss, and given a Name that doesn't correspond to anything real.  See
+    -- also Note [Signature merging DFuns]
+
+    -- Add the merged type_env to TcGblEnv, so that it gets serialized
+    -- out when we finally write out the interface.
+    --
+    -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly,
+    -- rather than use tcExtendGlobalEnv (the normal method to add newly
+    -- defined types to TcGblEnv?)  tcExtendGlobalEnv adds these
+    -- TyThings to 'tcg_type_env_var', which is consulted when
+    -- we read in interfaces to tie the knot.  But *these TyThings themselves
+    -- come from interface*, so that would result in deadlock.  Don't
+    -- update it!
+    setGblEnv tcg_env {
+        tcg_tcs = typeEnvTyCons type_env,
+        tcg_patsyns = typeEnvPatSyns type_env,
+        tcg_type_env = type_env,
+        tcg_fix_env = fix_env
+        } $ do
+    tcg_env <- getGblEnv
+
+    -- STEP 6: Check for compatibility/merge things
+    tcg_env <- (\x -> foldM x tcg_env infos)
+             $ \tcg_env (iface, details) -> do
+
+        let check_export name
+              | Just sig_thing <- lookupTypeEnv (md_types details) name
+              = case lookupTypeEnv type_env (getName sig_thing) of
+                  Just thing -> checkHsigDeclM iface sig_thing thing
+                  Nothing -> panic "mergeSignatures: check_export"
+              -- Oops! We're looking for this export but it's
+              -- not actually in the type environment of the signature's
+              -- ModDetails.
+              --
+              -- NB: This case happens because the we're iterating
+              -- over the union of all exports, so some interfaces
+              -- won't have everything.  Note that md_exports is nonsense
+              -- (it's the same as exports); maybe we should fix this
+              -- eventually.
+              | otherwise
+              = return ()
+        mapM_ check_export (map availName exports)
+
+        -- Note [Signature merging instances]
+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        -- Merge instances into the global environment.  The algorithm here is
+        -- dumb and simple: if an instance has exactly the same DFun type
+        -- (tested by 'memberInstEnv') as an existing instance, we drop it;
+        -- otherwise, we add it even, even if this would cause overlap.
+        --
+        -- Why don't we deduplicate instances with identical heads?  There's no
+        -- good choice if they have premises:
+        --
+        --      instance K1 a => K (T a)
+        --      instance K2 a => K (T a)
+        --
+        -- Why not eagerly error in this case?  The overlapping head does not
+        -- necessarily mean that the instances are unimplementable: in fact,
+        -- they may be implemented without overlap (if, for example, the
+        -- implementing module has 'instance K (T a)'; both are implemented in
+        -- this case.)  The implements test just checks that the wanteds are
+        -- derivable assuming the givens.
+        --
+        -- Still, overlapping instances with hypotheses like above are going
+        -- to be a bad deal, because instance resolution when we're typechecking
+        -- against the merged signature is going to have a bad time when
+        -- there are overlapping heads like this: we never backtrack, so it
+        -- may be difficult to see that a wanted is derivable.  For now,
+        -- we hope that we get lucky / the overlapping instances never
+        -- get used, but it is not a very good situation to be in.
+        --
+        let merge_inst (insts, inst_env) inst
+                | memberInstEnv inst_env inst -- test DFun Type equality
+                = (insts, inst_env)
+                | otherwise
+                -- NB: is_dfun_name inst is still nonsense here,
+                -- see Note [Signature merging DFuns]
+                = (inst:insts, extendInstEnv inst_env inst)
+            (insts, inst_env) = foldl' merge_inst
+                                    (tcg_insts tcg_env, tcg_inst_env tcg_env)
+                                    (md_insts details)
+            -- This is a HACK to prevent calculateAvails from including imp_mod
+            -- in the listing.  We don't want it because a module is NOT
+            -- supposed to include itself in its dep_orphs/dep_finsts.  See #13214
+            iface' = iface { mi_orphan = False, mi_finsts = False }
+            avails = plusImportAvails (tcg_imports tcg_env) $
+                        calculateAvails dflags iface' False False ImportedBySystem
+        return tcg_env {
+            tcg_inst_env = inst_env,
+            tcg_insts    = insts,
+            tcg_imports  = avails,
+            tcg_merged   =
+                if outer_mod == mi_module iface
+                    -- Don't add ourselves!
+                    then tcg_merged tcg_env
+                    else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env
+            }
+
+    -- Note [Signature merging DFuns]
+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    -- Once we know all of instances which will be defined by this merged
+    -- signature, we go through each of the DFuns and rename them with a fresh,
+    -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing
+    -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'.
+    --
+    -- We can't do this fixup earlier, because we need a way to identify each
+    -- source DFun (from each of the signatures we are merging in) so that
+    -- when we have a ClsInst, we can pull up the correct DFun to check if
+    -- the types match.
+    --
+    -- See also Note [rnIfaceNeverExported] in RnModIface
+    dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do
+        n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst))
+        let dfun = setVarName (is_dfun inst) n
+        return (dfun, inst { is_dfun_name = n, is_dfun = dfun })
+    tcg_env <- return tcg_env {
+            tcg_insts = map snd dfun_insts,
+            tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts)
+        }
+
+    addDependentFiles src_files
+
+    return tcg_env
+
+-- | Top-level driver for signature instantiation (run when compiling
+-- an @hsig@ file.)
+tcRnInstantiateSignature ::
+    HscEnv -> Module -> RealSrcSpan ->
+    IO (Messages, Maybe TcGblEnv)
+tcRnInstantiateSignature hsc_env this_mod real_loc =
+   withTiming (pure dflags)
+              (text "Signature instantiation"<+>brackets (ppr this_mod))
+              (const ()) $
+   initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature
+  where
+   dflags = hsc_dflags hsc_env
+
+exportOccs :: [AvailInfo] -> [OccName]
+exportOccs = concatMap (map occName . availNames)
+
+impl_msg :: Module -> IndefModule -> SDoc
+impl_msg impl_mod (IndefModule req_uid req_mod_name) =
+  text "while checking that" <+> ppr impl_mod <+>
+  text "implements signature" <+> ppr req_mod_name <+>
+  text "in" <+> ppr req_uid
+
+-- | Check if module implements a signature.  (The signature is
+-- always un-hashed, which is why its components are specified
+-- explicitly.)
+checkImplements :: Module -> IndefModule -> TcRn TcGblEnv
+checkImplements impl_mod req_mod@(IndefModule uid mod_name) =
+  addErrCtxt (impl_msg impl_mod req_mod) $ do
+    let insts = indefUnitIdInsts uid
+
+    -- STEP 1: Load the implementing interface, and make a RdrEnv
+    -- for its exports.  Also, add its 'ImportAvails' to 'tcg_imports',
+    -- so that we treat all orphan instances it provides as visible
+    -- when we verify that all instances are checked (see #12945), and so that
+    -- when we eventually write out the interface we record appropriate
+    -- dependency information.
+    impl_iface <- initIfaceTcRn $
+        loadSysInterface (text "checkImplements 1") impl_mod
+    let impl_gr = mkGlobalRdrEnv
+                    (gresFromAvails Nothing (mi_exports impl_iface))
+        nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface)
+
+    -- Load all the orphans, so the subsequent 'checkHsigIface' sees
+    -- all the instances it needs to
+    loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")
+                         (dep_orphs (mi_deps impl_iface))
+
+    dflags <- getDynFlags
+    let avails = calculateAvails dflags
+                    impl_iface False{- safe -} False{- boot -} ImportedBySystem
+        fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)
+                            | (occ, f) <- mi_fixities impl_iface
+                            , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ]
+    updGblEnv (\tcg_env -> tcg_env {
+        -- Setting tcg_rdr_env to treat all exported entities from
+        -- the implementing module as in scope improves error messages,
+        -- as it reduces the amount of qualification we need.  Unfortunately,
+        -- we still end up qualifying references to external modules
+        -- (see bkpfail07 for an example); we'd need to record more
+        -- information in ModIface to solve this.
+        tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr,
+        tcg_imports = tcg_imports tcg_env `plusImportAvails` avails,
+        -- This is here so that when we call 'lookupFixityRn' for something
+        -- directly implemented by the module, we grab the right thing
+        tcg_fix_env = fix_env
+        }) $ do
+
+    -- STEP 2: Load the *unrenamed, uninstantiated* interface for
+    -- the ORIGINAL signature.  We are going to eventually rename it,
+    -- but we must proceed slowly, because it is NOT known if the
+    -- instantiation is correct.
+    let sig_mod = mkModule (IndefiniteUnitId uid) mod_name
+        isig_mod = fst (splitModuleInsts sig_mod)
+    mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod False
+    isig_iface <- case mb_isig_iface of
+        Succeeded (iface, _) -> return iface
+        Failed err -> failWithTc $
+            hang (text "Could not find hi interface for signature" <+>
+                  quotes (ppr isig_mod) <> colon) 4 err
+
+    -- STEP 3: Check that the implementing interface exports everything
+    -- we need.  (Notice we IGNORE the Modules in the AvailInfos.)
+    forM_ (exportOccs (mi_exports isig_iface)) $ \occ ->
+        case lookupGlobalRdrEnv impl_gr occ of
+            [] -> addErr $ quotes (ppr occ)
+                    <+> text "is exported by the hsig file, but not"
+                    <+> text "exported by the implementing module"
+                    <+> quotes (ppr impl_mod)
+            _ -> return ()
+    failIfErrsM
+
+    -- STEP 4: Now that the export is complete, rename the interface...
+    sig_iface <- tcRnModIface insts (Just nsubst) isig_iface
+
+    -- STEP 5: ...and typecheck it.  (Note that in both cases, the nsubst
+    -- lets us determine how top-level identifiers should be handled.)
+    sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface
+
+    -- STEP 6: Check that it's sufficient
+    tcg_env <- getGblEnv
+    checkHsigIface tcg_env impl_gr sig_iface sig_details
+
+    -- STEP 7: Return the updated 'TcGblEnv' with the signature exports,
+    -- so we write them out.
+    return tcg_env {
+        tcg_exports = mi_exports sig_iface
+        }
+
+-- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite
+-- library to use the actual implementations of the relevant entities,
+-- checking that the implementation matches the signature.
+instantiateSignature :: TcRn TcGblEnv
+instantiateSignature = do
+    tcg_env <- getGblEnv
+    dflags <- getDynFlags
+    let outer_mod = tcg_mod tcg_env
+        inner_mod = tcg_semantic_mod tcg_env
+    -- TODO: setup the local RdrEnv so the error messages look a little better.
+    -- But this information isn't stored anywhere. Should we RETYPECHECK
+    -- the local one just to get the information?  Hmm...
+    MASSERT( moduleUnitId outer_mod == thisPackage dflags )
+    inner_mod `checkImplements`
+        IndefModule
+            (newIndefUnitId (thisComponentId dflags)
+                            (thisUnitIdInsts dflags))
+            (moduleName outer_mod)
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcBinds.hs
@@ -0,0 +1,1736 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[TcBinds]{TcBinds}
+-}
+
+{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds,
+                 tcHsBootSigs, tcPolyCheck,
+                 addTypecheckedBinds,
+                 chooseInferredQuantifiers,
+                 badBootDeclErr ) where
+
+import GhcPrelude
+
+import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
+import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
+import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind )
+import CoreSyn (Tickish (..))
+import CostCentre (mkUserCC, CCFlavour(DeclCC))
+import DynFlags
+import FastString
+import HsSyn
+import HscTypes( isHsBootOrSig )
+import TcSigs
+import TcRnMonad
+import TcEnv
+import TcUnify
+import TcSimplify
+import TcEvidence
+import TcHsType
+import TcPat
+import TcMType
+import FamInstEnv( normaliseType )
+import FamInst( tcGetFamInstEnvs )
+import TyCon
+import TcType
+import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy)
+import TysPrim
+import TysWiredIn( mkBoxedTupleTy )
+import Id
+import Var
+import VarSet
+import VarEnv( TidyEnv )
+import Module
+import Name
+import NameSet
+import NameEnv
+import SrcLoc
+import Bag
+import ErrUtils
+import Digraph
+import Maybes
+import Util
+import BasicTypes
+import Outputable
+import PrelNames( ipClassName )
+import TcValidity (checkValidType)
+import UniqFM
+import UniqSet
+import qualified GHC.LanguageExtensions as LangExt
+import ConLike
+
+import Control.Monad
+
+#include "HsVersions.h"
+
+{- *********************************************************************
+*                                                                      *
+               A useful helper function
+*                                                                      *
+********************************************************************* -}
+
+addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
+addTypecheckedBinds tcg_env binds
+  | isHsBootOrSig (tcg_src tcg_env) = tcg_env
+    -- Do not add the code for record-selector bindings
+    -- when compiling hs-boot files
+  | otherwise = tcg_env { tcg_binds = foldr unionBags
+                                            (tcg_binds tcg_env)
+                                            binds }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Type-checking bindings}
+*                                                                      *
+************************************************************************
+
+@tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
+it needs to know something about the {\em usage} of the things bound,
+so that it can create specialisations of them.  So @tcBindsAndThen@
+takes a function which, given an extended environment, E, typechecks
+the scope of the bindings returning a typechecked thing and (most
+important) an LIE.  It is this LIE which is then used as the basis for
+specialising the things bound.
+
+@tcBindsAndThen@ also takes a "combiner" which glues together the
+bindings and the "thing" to make a new "thing".
+
+The real work is done by @tcBindWithSigsAndThen@.
+
+Recursive and non-recursive binds are handled in essentially the same
+way: because of uniques there are no scoping issues left.  The only
+difference is that non-recursive bindings can bind primitive values.
+
+Even for non-recursive binding groups we add typings for each binder
+to the LVE for the following reason.  When each individual binding is
+checked the type of its LHS is unified with that of its RHS; and
+type-checking the LHS of course requires that the binder is in scope.
+
+At the top-level the LIE is sure to contain nothing but constant
+dictionaries, which we resolve at the module level.
+
+Note [Polymorphic recursion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The game plan for polymorphic recursion in the code above is
+
+        * Bind any variable for which we have a type signature
+          to an Id with a polymorphic type.  Then when type-checking
+          the RHSs we'll make a full polymorphic call.
+
+This fine, but if you aren't a bit careful you end up with a horrendous
+amount of partial application and (worse) a huge space leak. For example:
+
+        f :: Eq a => [a] -> [a]
+        f xs = ...f...
+
+If we don't take care, after typechecking we get
+
+        f = /\a -> \d::Eq a -> let f' = f a d
+                               in
+                               \ys:[a] -> ...f'...
+
+Notice the stupid construction of (f a d), which is of course
+identical to the function we're executing.  In this case, the
+polymorphic recursion isn't being used (but that's a very common case).
+This can lead to a massive space leak, from the following top-level defn
+(post-typechecking)
+
+        ff :: [Int] -> [Int]
+        ff = f Int dEqInt
+
+Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
+f' is another thunk which evaluates to the same thing... and you end
+up with a chain of identical values all hung onto by the CAF ff.
+
+        ff = f Int dEqInt
+
+           = let f' = f Int dEqInt in \ys. ...f'...
+
+           = let f' = let f' = f Int dEqInt in \ys. ...f'...
+                      in \ys. ...f'...
+
+Etc.
+
+NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
+which would make the space leak go away in this case
+
+Solution: when typechecking the RHSs we always have in hand the
+*monomorphic* Ids for each binding.  So we just need to make sure that
+if (Method f a d) shows up in the constraints emerging from (...f...)
+we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
+to the "givens" when simplifying constraints.  That's what the "lies_avail"
+is doing.
+
+Then we get
+
+        f = /\a -> \d::Eq a -> letrec
+                                 fm = \ys:[a] -> ...fm...
+                               in
+                               fm
+-}
+
+tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
+           -> TcM (TcGblEnv, TcLclEnv)
+-- The TcGblEnv contains the new tcg_binds and tcg_spects
+-- The TcLclEnv has an extended type envt for the new bindings
+tcTopBinds binds sigs
+  = do  { -- Pattern synonym bindings populate the global environment
+          (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
+            do { gbl <- getGblEnv
+               ; lcl <- getLclEnv
+               ; return (gbl, lcl) }
+        ; specs <- tcImpPrags sigs   -- SPECIALISE prags for imported Ids
+
+        ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs
+        ; traceTc "complete_matches" (ppr binds $$ ppr sigs)
+        ; traceTc "complete_matches" (ppr complete_matches)
+
+        ; let { tcg_env' = tcg_env { tcg_imp_specs
+                                      = specs ++ tcg_imp_specs tcg_env
+                                   , tcg_complete_matches
+                                      = complete_matches
+                                          ++ tcg_complete_matches tcg_env }
+                           `addTypecheckedBinds` map snd binds' }
+
+        ; return (tcg_env', tcl_env) }
+        -- The top level bindings are flattened into a giant
+        -- implicitly-mutually-recursive LHsBinds
+
+
+-- Note [Typechecking Complete Matches]
+-- Much like when a user bundled a pattern synonym, the result types of
+-- all the constructors in the match pragma must be consistent.
+--
+-- If we allowed pragmas with inconsistent types then it would be
+-- impossible to ever match every constructor in the list and so
+-- the pragma would be useless.
+
+
+
+
+
+-- This is only used in `tcCompleteSig`. We fold over all the conlikes,
+-- this accumulator keeps track of the first `ConLike` with a concrete
+-- return type. After fixing the return type, all other constructors with
+-- a fixed return type must agree with this.
+--
+-- The fields of `Fixed` cache the first conlike and its return type so
+-- that that we can compare all the other conlikes to it. The conlike is
+-- stored for error messages.
+--
+-- `Nothing` in the case that the type is fixed by a type signature
+data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon
+
+tcCompleteSigs  :: [LSig GhcRn] -> TcM [CompleteMatch]
+tcCompleteSigs sigs =
+  let
+      doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch)
+      doOne c@(CompleteMatchSig _ _ lns mtc)
+        = fmap Just $ do
+           addErrCtxt (text "In" <+> ppr c) $
+            case mtc of
+              Nothing -> infer_complete_match
+              Just tc -> check_complete_match tc
+        where
+
+          checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns)
+
+          infer_complete_match = do
+            (res, cls) <- checkCLTypes AcceptAny
+            case res of
+              AcceptAny -> failWithTc ambiguousError
+              Fixed _ tc  -> return $ mkMatch cls tc
+
+          check_complete_match tc_name = do
+            ty_con <- tcLookupLocatedTyCon tc_name
+            (_, cls) <- checkCLTypes (Fixed Nothing ty_con)
+            return $ mkMatch cls ty_con
+
+          mkMatch :: [ConLike] -> TyCon -> CompleteMatch
+          mkMatch cls ty_con = CompleteMatch {
+            completeMatchConLikes = map conLikeName cls,
+            completeMatchTyCon = tyConName ty_con
+            }
+      doOne _ = return Nothing
+
+      ambiguousError :: SDoc
+      ambiguousError =
+        text "A type signature must be provided for a set of polymorphic"
+          <+> text "pattern synonyms."
+
+
+      -- See note [Typechecking Complete Matches]
+      checkCLType :: (CompleteSigType, [ConLike]) -> Located Name
+                  -> TcM (CompleteSigType, [ConLike])
+      checkCLType (cst, cs) n = do
+        cl <- addLocM tcLookupConLike n
+        let   (_,_,_,_,_,_, res_ty) = conLikeFullSig cl
+              res_ty_con = fst <$> splitTyConApp_maybe res_ty
+        case (cst, res_ty_con) of
+          (AcceptAny, Nothing) -> return (AcceptAny, cl:cs)
+          (AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs)
+          (Fixed mfcl tc, Nothing)  -> return (Fixed mfcl tc, cl:cs)
+          (Fixed mfcl tc, Just tc') ->
+            if tc == tc'
+              then return (Fixed mfcl tc, cl:cs)
+              else case mfcl of
+                     Nothing ->
+                      addErrCtxt (text "In" <+> ppr cl) $
+                        failWithTc typeSigErrMsg
+                     Just cl -> failWithTc (errMsg cl)
+             where
+              typeSigErrMsg :: SDoc
+              typeSigErrMsg =
+                text "Couldn't match expected type"
+                      <+> quotes (ppr tc)
+                      <+> text "with"
+                      <+> quotes (ppr tc')
+
+              errMsg :: ConLike -> SDoc
+              errMsg fcl =
+                text "Cannot form a group of complete patterns from patterns"
+                  <+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl)
+                  <+> text "as they match different type constructors"
+                  <+> parens (quotes (ppr tc)
+                               <+> text "resp."
+                               <+> quotes (ppr tc'))
+  in  mapMaybeM (addLocM doOne) sigs
+
+tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]
+-- A hs-boot file has only one BindGroup, and it only has type
+-- signatures in it.  The renamer checked all this
+tcHsBootSigs binds sigs
+  = do  { checkTc (null binds) badBootDeclErr
+        ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
+  where
+    tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames
+      where
+        f (dL->L _ name)
+          = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty
+               ; return (mkVanillaGlobal name sigma_ty) }
+        -- Notice that we make GlobalIds, not LocalIds
+    tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
+
+badBootDeclErr :: MsgDoc
+badBootDeclErr = text "Illegal declarations in an hs-boot file"
+
+------------------------
+tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing
+             -> TcM (HsLocalBinds GhcTcId, thing)
+
+tcLocalBinds (EmptyLocalBinds x) thing_inside
+  = do  { thing <- thing_inside
+        ; return (EmptyLocalBinds x, thing) }
+
+tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside
+  = do  { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
+        ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) }
+tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds"
+
+tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside
+  = do  { ipClass <- tcLookupClass ipClassName
+        ; (given_ips, ip_binds') <-
+            mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds
+
+        -- If the binding binds ?x = E, we  must now
+        -- discharge any ?x constraints in expr_lie
+        -- See Note [Implicit parameter untouchables]
+        ; (ev_binds, result) <- checkConstraints (IPSkol ips)
+                                  [] given_ips thing_inside
+
+        ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) }
+  where
+    ips = [ip | (dL->L _ (IPBind _ (Left (dL->L _ ip)) _)) <- ip_binds]
+
+        -- I wonder if we should do these one at at time
+        -- Consider     ?x = 4
+        --              ?y = ?x + 1
+    tc_ip_bind ipClass (IPBind _ (Left (dL->L _ ip)) expr)
+       = do { ty <- newOpenFlexiTyVarTy
+            ; let p = mkStrLitTy $ hsIPNameFS ip
+            ; ip_id <- newDict ipClass [ p, ty ]
+            ; expr' <- tcMonoExpr expr (mkCheckExpType ty)
+            ; let d = toDict ipClass p ty `fmap` expr'
+            ; return (ip_id, (IPBind noExt (Right ip_id) d)) }
+    tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"
+    tc_ip_bind _ (XIPBind _) = panic "tc_ip_bind"
+
+    -- Coerces a `t` into a dictionry for `IP "x" t`.
+    -- co : t -> IP "x" t
+    toDict ipClass x ty = mkHsWrap $ mkWpCastR $
+                          wrapIP $ mkClassPred ipClass [x,ty]
+
+tcLocalBinds (HsIPBinds _ (XHsIPBinds _ )) _ = panic "tcLocalBinds"
+tcLocalBinds (XHsLocalBindsLR _)           _ = panic "tcLocalBinds"
+
+{- Note [Implicit parameter untouchables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We add the type variables in the types of the implicit parameters
+as untouchables, not so much because we really must not unify them,
+but rather because we otherwise end up with constraints like this
+    Num alpha, Implic { wanted = alpha ~ Int }
+The constraint solver solves alpha~Int by unification, but then
+doesn't float that solved constraint out (it's not an unsolved
+wanted).  Result disaster: the (Num alpha) is again solved, this
+time by defaulting.  No no no.
+
+However [Oct 10] this is all handled automatically by the
+untouchable-range idea.
+-}
+
+tcValBinds :: TopLevelFlag
+           -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]
+           -> TcM thing
+           -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)
+
+tcValBinds top_lvl binds sigs thing_inside
+  = do  { let patsyns = getPatSynBinds binds
+
+            -- Typecheck the signature
+        ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
+                                tcTySigs sigs
+
+        ; let prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)
+
+                -- Extend the envt right away with all the Ids
+                -- declared with complete type signatures
+                -- Do not extend the TcBinderStack; instead
+                -- we extend it on a per-rhs basis in tcExtendForRhs
+        ; tcExtendSigIds top_lvl poly_ids $ do
+            { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
+                   { thing <- thing_inside
+                     -- See Note [Pattern synonym builders don't yield dependencies]
+                     --     in RnBinds
+                   ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns
+                   ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]
+                   ; return (extra_binds, thing) }
+            ; return (binds' ++ extra_binds', thing) }}
+
+------------------------
+tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
+             -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing
+             -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)
+-- Typecheck a whole lot of value bindings,
+-- one strongly-connected component at a time
+-- Here a "strongly connected component" has the strightforward
+-- meaning of a group of bindings that mention each other,
+-- ignoring type signatures (that part comes later)
+
+tcBindGroups _ _ _ [] thing_inside
+  = do  { thing <- thing_inside
+        ; return ([], thing) }
+
+tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
+  = do  { -- See Note [Closed binder groups]
+          type_env <- getLclTypeEnv
+        ; let closed = isClosedBndrGroup type_env (snd group)
+        ; (group', (groups', thing))
+                <- tc_group top_lvl sig_fn prag_fn group closed $
+                   tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
+        ; return (group' ++ groups', thing) }
+
+-- Note [Closed binder groups]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+--  A mutually recursive group is "closed" if all of the free variables of
+--  the bindings are closed. For example
+--
+-- >  h = \x -> let f = ...g...
+-- >                g = ....f...x...
+-- >             in ...
+--
+-- Here @g@ is not closed because it mentions @x@; and hence neither is @f@
+-- closed.
+--
+-- So we need to compute closed-ness on each strongly connected components,
+-- before we sub-divide it based on what type signatures it has.
+--
+
+------------------------
+tc_group :: forall thing.
+            TopLevelFlag -> TcSigFun -> TcPragEnv
+         -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing
+         -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)
+
+-- Typecheck one strongly-connected component of the original program.
+-- We get a list of groups back, because there may
+-- be specialisations etc as well
+
+tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside
+        -- A single non-recursive binding
+        -- We want to keep non-recursive things non-recursive
+        -- so that we desugar unlifted bindings correctly
+  = do { let bind = case bagToList binds of
+                 [bind] -> bind
+                 []     -> panic "tc_group: empty list of binds"
+                 _      -> panic "tc_group: NonRecursive binds is not a singleton bag"
+       ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed
+                                     thing_inside
+       ; return ( [(NonRecursive, bind')], thing) }
+
+tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside
+  =     -- To maximise polymorphism, we do a new
+        -- strongly-connected-component analysis, this time omitting
+        -- any references to variables with type signatures.
+        -- (This used to be optional, but isn't now.)
+        -- See Note [Polymorphic recursion] in HsBinds.
+    do  { traceTc "tc_group rec" (pprLHsBinds binds)
+        ; when hasPatSyn $ recursivePatSynErr binds
+        ; (binds1, thing) <- go sccs
+        ; return ([(Recursive, binds1)], thing) }
+                -- Rec them all together
+  where
+    hasPatSyn = anyBag (isPatSyn . unLoc) binds
+    isPatSyn PatSynBind{} = True
+    isPatSyn _ = False
+
+    sccs :: [SCC (LHsBind GhcRn)]
+    sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds)
+
+    go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTcId, thing)
+    go (scc:sccs) = do  { (binds1, ids1) <- tc_scc scc
+                        ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn
+                                                            closed ids1 $
+                                             go sccs
+                        ; return (binds1 `unionBags` binds2, thing) }
+    go []         = do  { thing <- thing_inside; return (emptyBag, thing) }
+
+    tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
+    tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds
+
+    tc_sub_group rec_tc binds =
+      tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds
+
+recursivePatSynErr :: OutputableBndrId (GhcPass p) =>
+                      LHsBinds (GhcPass p) -> TcM a
+recursivePatSynErr binds
+  = failWithTc $
+    hang (text "Recursive pattern synonym definition with following bindings:")
+       2 (vcat $ map pprLBind . bagToList $ binds)
+  where
+    pprLoc loc  = parens (text "defined at" <+> ppr loc)
+    pprLBind (dL->L loc bind) = pprWithCommas ppr (collectHsBindBinders bind)
+                                <+> pprLoc loc
+
+tc_single :: forall thing.
+            TopLevelFlag -> TcSigFun -> TcPragEnv
+          -> LHsBind GhcRn -> IsGroupClosed -> TcM thing
+          -> TcM (LHsBinds GhcTcId, thing)
+tc_single _top_lvl sig_fn _prag_fn
+          (dL->L _ (PatSynBind _ psb@PSB{ psb_id = (dL->L _ name) }))
+          _ thing_inside
+  = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name)
+       ; thing <- setGblEnv tcg_env thing_inside
+       ; return (aux_binds, thing)
+       }
+
+tc_single top_lvl sig_fn prag_fn lbind closed thing_inside
+  = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn
+                                      NonRecursive NonRecursive
+                                      closed
+                                      [lbind]
+       ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside
+       ; return (binds1, thing) }
+
+------------------------
+type BKey = Int -- Just number off the bindings
+
+mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]
+-- See Note [Polymorphic recursion] in HsBinds.
+mkEdges sig_fn binds
+  = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),
+                         Just key <- [lookupNameEnv key_map n], no_sig n ]
+    | (bind, key) <- keyd_binds
+    ]
+    -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices
+    -- is still deterministic even if the edges are in nondeterministic order
+    -- as explained in Note [Deterministic SCC] in Digraph.
+  where
+    bind_fvs (FunBind { fun_ext = fvs }) = fvs
+    bind_fvs (PatBind { pat_ext = fvs }) = fvs
+    bind_fvs _                           = emptyNameSet
+
+    no_sig :: Name -> Bool
+    no_sig n = not (hasCompleteSig sig_fn n)
+
+    keyd_binds = bagToList binds `zip` [0::BKey ..]
+
+    key_map :: NameEnv BKey     -- Which binding it comes from
+    key_map = mkNameEnv [(bndr, key) | (dL->L _ bind, key) <- keyd_binds
+                                     , bndr <- collectHsBindBinders bind ]
+
+------------------------
+tcPolyBinds :: TcSigFun -> TcPragEnv
+            -> RecFlag         -- Whether the group is really recursive
+            -> RecFlag         -- Whether it's recursive after breaking
+                               -- dependencies based on type signatures
+            -> IsGroupClosed   -- Whether the group is closed
+            -> [LHsBind GhcRn]  -- None are PatSynBind
+            -> TcM (LHsBinds GhcTcId, [TcId])
+
+-- Typechecks a single bunch of values bindings all together,
+-- and generalises them.  The bunch may be only part of a recursive
+-- group, because we use type signatures to maximise polymorphism
+--
+-- Returns a list because the input may be a single non-recursive binding,
+-- in which case the dependency order of the resulting bindings is
+-- important.
+--
+-- Knows nothing about the scope of the bindings
+-- None of the bindings are pattern synonyms
+
+tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list
+  = setSrcSpan loc                              $
+    recoverM (recoveryCode binder_names sig_fn) $ do
+        -- Set up main recover; take advantage of any type sigs
+
+    { traceTc "------------------------------------------------" Outputable.empty
+    ; traceTc "Bindings for {" (ppr binder_names)
+    ; dflags   <- getDynFlags
+    ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn
+    ; traceTc "Generalisation plan" (ppr plan)
+    ; result@(_, poly_ids) <- case plan of
+         NoGen              -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
+         InferGen mn        -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list
+         CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind
+
+    ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group
+                                            , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]
+                                          ])
+
+    ; return result }
+  where
+    binder_names = collectHsBindListBinders bind_list
+    loc = foldr1 combineSrcSpans (map getLoc bind_list)
+         -- The mbinds have been dependency analysed and
+         -- may no longer be adjacent; so find the narrowest
+         -- span that includes them all
+
+--------------
+-- If typechecking the binds fails, then return with each
+-- signature-less binder given type (forall a.a), to minimise
+-- subsequent error messages
+recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTcId, [Id])
+recoveryCode binder_names sig_fn
+  = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
+        ; let poly_ids = map mk_dummy binder_names
+        ; return (emptyBag, poly_ids) }
+  where
+    mk_dummy name
+      | Just sig <- sig_fn name
+      , Just poly_id <- completeSigPolyId_maybe sig
+      = poly_id
+      | otherwise
+      = mkLocalId name forall_a_a
+
+forall_a_a :: TcType
+-- At one point I had (forall r (a :: TYPE r). a), but of course
+-- that type is ill-formed: its mentions 'r' which escapes r's scope.
+-- Another alternative would be (forall (a :: TYPE kappa). a), where
+-- kappa is a unification variable. But I don't think we need that
+-- complication here. I'm going to just use (forall (a::*). a).
+-- See Trac #15276
+forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy
+
+{- *********************************************************************
+*                                                                      *
+                         tcPolyNoGen
+*                                                                      *
+********************************************************************* -}
+
+tcPolyNoGen     -- No generalisation whatsoever
+  :: RecFlag       -- Whether it's recursive after breaking
+                   -- dependencies based on type signatures
+  -> TcPragEnv -> TcSigFun
+  -> [LHsBind GhcRn]
+  -> TcM (LHsBinds GhcTcId, [TcId])
+
+tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
+  = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn
+                                             (LetGblBndr prag_fn)
+                                             bind_list
+       ; mono_ids' <- mapM tc_mono_info mono_infos
+       ; return (binds', mono_ids') }
+  where
+    tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id })
+      = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name)
+           ; return mono_id }
+           -- NB: tcPrags generates error messages for
+           --     specialisation pragmas for non-overloaded sigs
+           -- Indeed that is why we call it here!
+           -- So we can safely ignore _specs
+
+
+{- *********************************************************************
+*                                                                      *
+                         tcPolyCheck
+*                                                                      *
+********************************************************************* -}
+
+tcPolyCheck :: TcPragEnv
+            -> TcIdSigInfo     -- Must be a complete signature
+            -> LHsBind GhcRn   -- Must be a FunBind
+            -> TcM (LHsBinds GhcTcId, [TcId])
+-- There is just one binding,
+--   it is a Funbind
+--   it has a complete type signature,
+tcPolyCheck prag_fn
+            (CompleteSig { sig_bndr  = poly_id
+                         , sig_ctxt  = ctxt
+                         , sig_loc   = sig_loc })
+            (dL->L loc (FunBind { fun_id = (dL->L nm_loc name)
+                                , fun_matches = matches }))
+  = setSrcSpan sig_loc $
+    do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
+       ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id
+                -- See Note [Instantiate sig with fresh variables]
+
+       ; mono_name <- newNameAt (nameOccName name) nm_loc
+       ; ev_vars   <- newEvVars theta
+       ; let mono_id   = mkLocalId mono_name tau
+             skol_info = SigSkol ctxt (idType poly_id) tv_prs
+             skol_tvs  = map snd tv_prs
+
+       ; (ev_binds, (co_fn, matches'))
+            <- checkConstraints skol_info skol_tvs ev_vars $
+               tcExtendBinderStack [TcIdBndr mono_id NotTopLevel]  $
+               tcExtendNameTyVarEnv tv_prs $
+               setSrcSpan loc           $
+               tcMatchesFun (cL nm_loc mono_name) matches (mkCheckExpType tau)
+
+       ; let prag_sigs = lookupPragEnv prag_fn name
+       ; spec_prags <- tcSpecPrags poly_id prag_sigs
+       ; poly_id    <- addInlinePrags poly_id prag_sigs
+
+       ; mod <- getModule
+       ; tick <- funBindTicks nm_loc mono_id mod prag_sigs
+       ; let bind' = FunBind { fun_id      = cL nm_loc mono_id
+                             , fun_matches = matches'
+                             , fun_co_fn   = co_fn
+                             , fun_ext     = placeHolderNamesTc
+                             , fun_tick    = tick }
+
+             export = ABE { abe_ext = noExt
+                          , abe_wrap = idHsWrapper
+                          , abe_poly  = poly_id
+                          , abe_mono  = mono_id
+                          , abe_prags = SpecPrags spec_prags }
+
+             abs_bind = cL loc $
+                        AbsBinds { abs_ext = noExt
+                                 , abs_tvs      = skol_tvs
+                                 , abs_ev_vars  = ev_vars
+                                 , abs_ev_binds = [ev_binds]
+                                 , abs_exports  = [export]
+                                 , abs_binds    = unitBag (cL loc bind')
+                                 , abs_sig      = True }
+
+       ; return (unitBag abs_bind, [poly_id]) }
+
+tcPolyCheck _prag_fn sig bind
+  = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)
+
+funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]
+             -> TcM [Tickish TcId]
+funBindTicks loc fun_id mod sigs
+  | (mb_cc_str : _) <- [ cc_name | (dL->L _ (SCCFunSig _ _ _ cc_name)) <- sigs ]
+      -- this can only be a singleton list, as duplicate pragmas are rejected
+      -- by the renamer
+  , let cc_str
+          | Just cc_str <- mb_cc_str
+          = sl_fs $ unLoc cc_str
+          | otherwise
+          = getOccFS (Var.varName fun_id)
+        cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str
+  = do
+      flavour <- DeclCC <$> getCCIndexM cc_name
+      let cc = mkUserCC cc_name mod loc flavour
+      return [ProfNote cc True True]
+  | otherwise
+  = return []
+
+{- Note [Instantiate sig with fresh variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's vital to instantiate a type signature with fresh variables.
+For example:
+      type T = forall a. [a] -> [a]
+      f :: T;
+      f = g where { g :: T; g = <rhs> }
+
+ We must not use the same 'a' from the defn of T at both places!!
+(Instantiation is only necessary because of type synonyms.  Otherwise,
+it's all cool; each signature has distinct type variables from the renamer.)
+-}
+
+
+{- *********************************************************************
+*                                                                      *
+                         tcPolyInfer
+*                                                                      *
+********************************************************************* -}
+
+tcPolyInfer
+  :: RecFlag       -- Whether it's recursive after breaking
+                   -- dependencies based on type signatures
+  -> TcPragEnv -> TcSigFun
+  -> Bool         -- True <=> apply the monomorphism restriction
+  -> [LHsBind GhcRn]
+  -> TcM (LHsBinds GhcTcId, [TcId])
+tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
+  = do { (tclvl, wanted, (binds', mono_infos))
+             <- pushLevelAndCaptureConstraints  $
+                tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
+
+       ; let name_taus  = [ (mbi_poly_name info, idType (mbi_mono_id info))
+                          | info <- mono_infos ]
+             sigs       = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]
+             infer_mode = if mono then ApplyMR else NoRestrictions
+
+       ; mapM_ (checkOverloadedSig mono) sigs
+
+       ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)
+       ; (qtvs, givens, ev_binds, residual, insoluble)
+                 <- simplifyInfer tclvl infer_mode sigs name_taus wanted
+       ; emitConstraints residual
+
+       ; let inferred_theta = map evVarPred givens
+       ; exports <- checkNoErrs $
+                    mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos
+
+       ; loc <- getSrcSpanM
+       ; let poly_ids = map abe_poly exports
+             abs_bind = cL loc $
+                        AbsBinds { abs_ext = noExt
+                                 , abs_tvs = qtvs
+                                 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]
+                                 , abs_exports = exports, abs_binds = binds'
+                                 , abs_sig = False }
+
+       ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
+       ; return (unitBag abs_bind, poly_ids) }
+         -- poly_ids are guaranteed zonked by mkExport
+
+--------------
+mkExport :: TcPragEnv
+         -> Bool                        -- True <=> there was an insoluble type error
+                                        --          when typechecking the bindings
+         -> [TyVar] -> TcThetaType      -- Both already zonked
+         -> MonoBindInfo
+         -> TcM (ABExport GhcTc)
+-- Only called for generalisation plan InferGen, not by CheckGen or NoGen
+--
+-- mkExport generates exports with
+--      zonked type variables,
+--      zonked poly_ids
+-- The former is just because no further unifications will change
+-- the quantified type variables, so we can fix their final form
+-- right now.
+-- The latter is needed because the poly_ids are used to extend the
+-- type environment; see the invariant on TcEnv.tcExtendIdEnv
+
+-- Pre-condition: the qtvs and theta are already zonked
+
+mkExport prag_fn insoluble qtvs theta
+         mono_info@(MBI { mbi_poly_name = poly_name
+                        , mbi_sig       = mb_sig
+                        , mbi_mono_id   = mono_id })
+  = do  { mono_ty <- zonkTcType (idType mono_id)
+        ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty
+
+        -- NB: poly_id has a zonked type
+        ; poly_id <- addInlinePrags poly_id prag_sigs
+        ; spec_prags <- tcSpecPrags poly_id prag_sigs
+                -- tcPrags requires a zonked poly_id
+
+        -- See Note [Impedance matching]
+        -- NB: we have already done checkValidType, including an ambiguity check,
+        --     on the type; either when we checked the sig or in mkInferredPolyId
+        ; let poly_ty     = idType poly_id
+              sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty
+                -- This type is just going into tcSubType,
+                -- so Inferred vs. Specified doesn't matter
+
+        ; wrap <- if sel_poly_ty `eqType` poly_ty  -- NB: eqType ignores visibility
+                  then return idHsWrapper  -- Fast path; also avoids complaint when we infer
+                                           -- an ambiguous type and have AllowAmbiguousType
+                                           -- e..g infer  x :: forall a. F a -> Int
+                  else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $
+                       tcSubType_NC sig_ctxt sel_poly_ty poly_ty
+
+        ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures
+        ; when warn_missing_sigs $
+              localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig
+
+        ; return (ABE { abe_ext = noExt
+                      , abe_wrap = wrap
+                        -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)
+                      , abe_poly  = poly_id
+                      , abe_mono  = mono_id
+                      , abe_prags = SpecPrags spec_prags }) }
+  where
+    prag_sigs = lookupPragEnv prag_fn poly_name
+    sig_ctxt  = InfSigCtxt poly_name
+
+mkInferredPolyId :: Bool  -- True <=> there was an insoluble error when
+                          --          checking the binding group for this Id
+                 -> [TyVar] -> TcThetaType
+                 -> Name -> Maybe TcIdSigInst -> TcType
+                 -> TcM TcId
+mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty
+  | Just (TISI { sig_inst_sig = sig })  <- mb_sig_inst
+  , CompleteSig { sig_bndr = poly_id } <- sig
+  = return poly_id
+
+  | otherwise  -- Either no type sig or partial type sig
+  = checkNoErrs $  -- The checkNoErrs ensures that if the type is ambiguous
+                   -- we don't carry on to the impedance matching, and generate
+                   -- a duplicate ambiguity error.  There is a similar
+                   -- checkNoErrs for complete type signatures too.
+    do { fam_envs <- tcGetFamInstEnvs
+       ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty
+               -- Unification may not have normalised the type,
+               -- (see Note [Lazy flattening] in TcFlatten) so do it
+               -- here to make it as uncomplicated as possible.
+               -- Example: f :: [F Int] -> Bool
+               -- should be rewritten to f :: [Char] -> Bool, if possible
+               --
+               -- We can discard the coercion _co, because we'll reconstruct
+               -- it in the call to tcSubType below
+
+       ; (binders, theta') <- chooseInferredQuantifiers inferred_theta
+                                (tyCoVarsOfType mono_ty') qtvs mb_sig_inst
+
+       ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty')
+
+       ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta'
+                                          , ppr inferred_poly_ty])
+       ; unless insoluble $
+         addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $
+         checkValidType (InfSigCtxt poly_name) inferred_poly_ty
+         -- See Note [Validity of inferred types]
+         -- If we found an insoluble error in the function definition, don't
+         -- do this check; otherwise (Trac #14000) we may report an ambiguity
+         -- error for a rather bogus type.
+
+       ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }
+
+
+chooseInferredQuantifiers :: TcThetaType   -- inferred
+                          -> TcTyVarSet    -- tvs free in tau type
+                          -> [TcTyVar]     -- inferred quantified tvs
+                          -> Maybe TcIdSigInst
+                          -> TcM ([TyVarBinder], TcThetaType)
+chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing
+  = -- No type signature (partial or complete) for this binder,
+    do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)
+                        -- Include kind variables!  Trac #7916
+             my_theta = pickCapturedPreds free_tvs inferred_theta
+             binders  = [ mkTyVarBinder Inferred tv
+                        | tv <- qtvs
+                        , tv `elemVarSet` free_tvs ]
+       ; return (binders, my_theta) }
+
+chooseInferredQuantifiers inferred_theta tau_tvs qtvs
+                          (Just (TISI { sig_inst_sig   = sig  -- Always PartialSig
+                                      , sig_inst_wcx   = wcx
+                                      , sig_inst_theta = annotated_theta
+                                      , sig_inst_skols = annotated_tvs }))
+  = -- Choose quantifiers for a partial type signature
+    do { psig_qtv_prs <- zonkTyVarTyVarPairs annotated_tvs
+
+            -- Check whether the quantified variables of the
+            -- partial signature have been unified together
+            -- See Note [Quantified variables in partial type signatures]
+       ; mapM_ report_dup_tyvar_tv_err  (findDupTyVarTvs psig_qtv_prs)
+
+            -- Check whether a quantified variable of the partial type
+            -- signature is not actually quantified.  How can that happen?
+            -- See Note [Quantification and partial signatures] Wrinkle 4
+            --     in TcSimplify
+       ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs
+                                          , not (tv `elem` qtvs) ]
+
+       ; let psig_qtvs = mkVarSet (map snd psig_qtv_prs)
+
+       ; annotated_theta      <- zonkTcTypes annotated_theta
+       ; (free_tvs, my_theta) <- choose_psig_context psig_qtvs annotated_theta wcx
+
+       ; let keep_me    = free_tvs `unionVarSet` psig_qtvs
+             final_qtvs = [ mkTyVarBinder vis tv
+                          | tv <- qtvs -- Pulling from qtvs maintains original order
+                          , tv `elemVarSet` keep_me
+                          , let vis | tv `elemVarSet` psig_qtvs = Specified
+                                    | otherwise                 = Inferred ]
+
+       ; return (final_qtvs, my_theta) }
+  where
+    report_dup_tyvar_tv_err (n1,n2)
+      | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig
+      = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1)
+                        <+> text "with" <+> quotes (ppr n2))
+                     2 (hang (text "both bound by the partial type signature:")
+                           2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))
+
+      | otherwise -- Can't happen; by now we know it's a partial sig
+      = pprPanic "report_tyvar_tv_err" (ppr sig)
+
+    report_mono_sig_tv_err n
+      | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig
+      = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n))
+                     2 (hang (text "bound by the partial type signature:")
+                           2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))
+      | otherwise -- Can't happen; by now we know it's a partial sig
+      = pprPanic "report_mono_sig_tv_err" (ppr sig)
+
+    choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType
+                        -> TcM (VarSet, TcThetaType)
+    choose_psig_context _ annotated_theta Nothing
+      = do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
+                                            `unionVarSet` tau_tvs)
+           ; return (free_tvs, annotated_theta) }
+
+    choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty)
+      = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)
+                            -- growThetaVars just like the no-type-sig case
+                            -- Omitting this caused #12844
+                 seed_tvs = tyCoVarsOfTypes annotated_theta  -- These are put there
+                            `unionVarSet` tau_tvs            --       by the user
+
+           ; let keep_me  = psig_qtvs `unionVarSet` free_tvs
+                 my_theta = pickCapturedPreds keep_me inferred_theta
+
+           -- Fill in the extra-constraints wildcard hole with inferred_theta,
+           -- so that the Hole constraint we have already emitted
+           -- (in tcHsPartialSigType) can report what filled it in.
+           -- NB: my_theta already includes all the annotated constraints
+           ; let inferred_diff = [ pred
+                                 | pred <- my_theta
+                                 , all (not . (`eqType` pred)) annotated_theta ]
+           ; ctuple <- mk_ctuple inferred_diff
+
+           ; case tcGetCastedTyVar_maybe wc_var_ty of
+               -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it
+               -- comes from the checkExpectedKind in TcHsType.tcWildCardOcc. So, to
+               -- make the kinds work out, we reverse the cast here.
+               Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co)
+               Nothing              -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty)
+
+           ; traceTc "completeTheta" $
+                vcat [ ppr sig
+                     , ppr annotated_theta, ppr inferred_theta
+                     , ppr inferred_diff ]
+           ; return (free_tvs, my_theta) }
+
+    mk_ctuple preds = return (mkBoxedTupleTy preds)
+       -- Hack alert!  See TcHsType:
+       -- Note [Extra-constraint holes in partial type signatures]
+
+
+mk_impedance_match_msg :: MonoBindInfo
+                       -> TcType -> TcType
+                       -> TidyEnv -> TcM (TidyEnv, SDoc)
+-- This is a rare but rather awkward error messages
+mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })
+                       inf_ty sig_ty tidy_env
+ = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env  inf_ty
+      ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty
+      ; let msg = vcat [ text "When checking that the inferred type"
+                       , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty
+                       , text "is as general as its" <+> what <+> text "signature"
+                       , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]
+      ; return (tidy_env2, msg) }
+  where
+    what = case mb_sig of
+             Nothing                     -> text "inferred"
+             Just sig | isPartialSig sig -> text "(partial)"
+                      | otherwise        -> empty
+
+
+mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
+mk_inf_msg poly_name poly_ty tidy_env
+ = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty
+      ; let msg = vcat [ text "When checking the inferred type"
+                       , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]
+      ; return (tidy_env1, msg) }
+
+
+-- | Warn the user about polymorphic local binders that lack type signatures.
+localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM ()
+localSigWarn flag id mb_sig
+  | Just _ <- mb_sig               = return ()
+  | not (isSigmaTy (idType id))    = return ()
+  | otherwise                      = warnMissingSignatures flag msg id
+  where
+    msg = text "Polymorphic local binding with no type signature:"
+
+warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM ()
+warnMissingSignatures flag msg id
+  = do  { env0 <- tcInitTidyEnv
+        ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
+        ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) }
+  where
+    mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]
+
+checkOverloadedSig :: Bool -> TcIdSigInst -> TcM ()
+-- Example:
+--   f :: Eq a => a -> a
+--   K f = e
+-- The MR applies, but the signature is overloaded, and it's
+-- best to complain about this directly
+-- c.f Trac #11339
+checkOverloadedSig monomorphism_restriction_applies sig
+  | not (null (sig_inst_theta sig))
+  , monomorphism_restriction_applies
+  , let orig_sig = sig_inst_sig sig
+  = setSrcSpan (sig_loc orig_sig) $
+    failWith $
+    hang (text "Overloaded signature conflicts with monomorphism restriction")
+       2 (ppr orig_sig)
+  | otherwise
+  = return ()
+
+{- Note [Partial type signatures and generalisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If /any/ of the signatures in the gropu is a partial type signature
+   f :: _ -> Int
+then we *always* use the InferGen plan, and hence tcPolyInfer.
+We do this even for a local binding with -XMonoLocalBinds, when
+we normally use NoGen.
+
+Reasons:
+  * The TcSigInfo for 'f' has a unification variable for the '_',
+    whose TcLevel is one level deeper than the current level.
+    (See pushTcLevelM in tcTySig.)  But NoGen doesn't increase
+    the TcLevel like InferGen, so we lose the level invariant.
+
+  * The signature might be   f :: forall a. _ -> a
+    so it really is polymorphic.  It's not clear what it would
+    mean to use NoGen on this, and indeed the ASSERT in tcLhs,
+    in the (Just sig) case, checks that if there is a signature
+    then we are using LetLclBndr, and hence a nested AbsBinds with
+    increased TcLevel
+
+It might be possible to fix these difficulties somehow, but there
+doesn't seem much point.  Indeed, adding a partial type signature is a
+way to get per-binding inferred generalisation.
+
+We apply the MR if /all/ of the partial signatures lack a context.
+In particular (Trac #11016):
+   f2 :: (?loc :: Int) => _
+   f2 = ?loc
+It's stupid to apply the MR here.  This test includes an extra-constraints
+wildcard; that is, we don't apply the MR if you write
+   f3 :: _ => blah
+
+Note [Quantified variables in partial type signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f :: forall a. a -> a -> _
+  f x y = g x y
+  g :: forall b. b -> b -> _
+  g x y = [x, y]
+
+Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b'
+together, which is fine.  So we bind 'a' and 'b' to TyVarTvs, which can then
+unify with each other.
+
+But now consider:
+  f :: forall a b. a -> b -> _
+  f x y = [x, y]
+
+We want to get an error from this, because 'a' and 'b' get unified.
+So we make a test, one per parital signature, to check that the
+explicitly-quantified type variables have not been unified together.
+Trac #14449 showed this up.
+
+
+Note [Validity of inferred types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to check inferred type for validity, in case it uses language
+extensions that are not turned on.  The principle is that if the user
+simply adds the inferred type to the program source, it'll compile fine.
+See #8883.
+
+Examples that might fail:
+ - the type might be ambiguous
+
+ - an inferred theta that requires type equalities e.g. (F a ~ G b)
+                                or multi-parameter type classes
+ - an inferred type that includes unboxed tuples
+
+
+Note [Impedance matching]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f 0 x = x
+   f n x = g [] (not x)
+
+   g [] y = f 10 y
+   g _  y = f 9  y
+
+After typechecking we'll get
+  f_mono_ty :: a -> Bool -> Bool
+  g_mono_ty :: [b] -> Bool -> Bool
+with constraints
+  (Eq a, Num a)
+
+Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.
+The types we really want for f and g are
+   f :: forall a. (Eq a, Num a) => a -> Bool -> Bool
+   g :: forall b. [b] -> Bool -> Bool
+
+We can get these by "impedance matching":
+   tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)
+   tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)
+
+   f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f
+   g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g
+
+Suppose the shared quantified tyvars are qtvs and constraints theta.
+Then we want to check that
+     forall qtvs. theta => f_mono_ty   is more polymorphic than   f's polytype
+and the proof is the impedance matcher.
+
+Notice that the impedance matcher may do defaulting.  See Trac #7173.
+
+It also cleverly does an ambiguity check; for example, rejecting
+   f :: F a -> F a
+where F is a non-injective type function.
+-}
+
+
+{-
+Note [SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+There is no point in a SPECIALISE pragma for a non-overloaded function:
+   reverse :: [a] -> [a]
+   {-# SPECIALISE reverse :: [Int] -> [Int] #-}
+
+But SPECIALISE INLINE *can* make sense for GADTS:
+   data Arr e where
+     ArrInt :: !Int -> ByteArray# -> Arr Int
+     ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)
+
+   (!:) :: Arr e -> Int -> e
+   {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
+   {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
+   (ArrInt _ ba)     !: (I# i) = I# (indexIntArray# ba i)
+   (ArrPair _ a1 a2) !: i      = (a1 !: i, a2 !: i)
+
+When (!:) is specialised it becomes non-recursive, and can usefully
+be inlined.  Scary!  So we only warn for SPECIALISE *without* INLINE
+for a non-overloaded function.
+
+************************************************************************
+*                                                                      *
+                         tcMonoBinds
+*                                                                      *
+************************************************************************
+
+@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
+The signatures have been dealt with already.
+-}
+
+data MonoBindInfo = MBI { mbi_poly_name :: Name
+                        , mbi_sig       :: Maybe TcIdSigInst
+                        , mbi_mono_id   :: TcId }
+
+tcMonoBinds :: RecFlag  -- Whether the binding is recursive for typechecking purposes
+                        -- i.e. the binders are mentioned in their RHSs, and
+                        --      we are not rescued by a type signature
+            -> TcSigFun -> LetBndrSpec
+            -> [LHsBind GhcRn]
+            -> TcM (LHsBinds GhcTcId, [MonoBindInfo])
+tcMonoBinds is_rec sig_fn no_gen
+           [ dL->L b_loc (FunBind { fun_id = (dL->L nm_loc name)
+                                  , fun_matches = matches
+                                  , fun_ext = fvs })]
+                             -- Single function binding,
+  | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
+  , Nothing <- sig_fn name   -- ...with no type signature
+  =     -- Note [Single function non-recursive binding special-case]
+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        -- In this very special case we infer the type of the
+        -- right hand side first (it may have a higher-rank type)
+        -- and *then* make the monomorphic Id for the LHS
+        -- e.g.         f = \(x::forall a. a->a) -> <body>
+        --      We want to infer a higher-rank type for f
+    setSrcSpan b_loc    $
+    do  { ((co_fn, matches'), rhs_ty)
+            <- tcInferInst $ \ exp_ty ->
+                  -- tcInferInst: see TcUnify,
+                  -- Note [Deep instantiation of InferResult]
+               tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $
+                  -- We extend the error context even for a non-recursive
+                  -- function so that in type error messages we show the
+                  -- type of the thing whose rhs we are type checking
+               tcMatchesFun (cL nm_loc name) matches exp_ty
+
+        ; mono_id <- newLetBndr no_gen name rhs_ty
+        ; return (unitBag $ cL b_loc $
+                     FunBind { fun_id = cL nm_loc mono_id,
+                               fun_matches = matches', fun_ext = fvs,
+                               fun_co_fn = co_fn, fun_tick = [] },
+                  [MBI { mbi_poly_name = name
+                       , mbi_sig       = Nothing
+                       , mbi_mono_id   = mono_id }]) }
+
+tcMonoBinds _ sig_fn no_gen binds
+  = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
+
+        -- Bring the monomorphic Ids, into scope for the RHSs
+        ; let mono_infos = getMonoBindInfo tc_binds
+              rhs_id_env = [ (name, mono_id)
+                           | MBI { mbi_poly_name = name
+                                 , mbi_sig       = mb_sig
+                                 , mbi_mono_id   = mono_id } <- mono_infos
+                           , case mb_sig of
+                               Just sig -> isPartialSig sig
+                               Nothing  -> True ]
+                -- A monomorphic binding for each term variable that lacks
+                -- a complete type sig.  (Ones with a sig are already in scope.)
+
+        ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
+                                       | (n,id) <- rhs_id_env]
+        ; binds' <- tcExtendRecIds rhs_id_env $
+                    mapM (wrapLocM tcRhs) tc_binds
+
+        ; return (listToBag binds', mono_infos) }
+
+
+------------------------
+-- tcLhs typechecks the LHS of the bindings, to construct the environment in which
+-- we typecheck the RHSs.  Basically what we are doing is this: for each binder:
+--      if there's a signature for it, use the instantiated signature type
+--      otherwise invent a type variable
+-- You see that quite directly in the FunBind case.
+--
+-- But there's a complication for pattern bindings:
+--      data T = MkT (forall a. a->a)
+--      MkT f = e
+-- Here we can guess a type variable for the entire LHS (which will be refined to T)
+-- but we want to get (f::forall a. a->a) as the RHS environment.
+-- The simplest way to do this is to typecheck the pattern, and then look up the
+-- bound mono-ids.  Then we want to retain the typechecked pattern to avoid re-doing
+-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
+
+data TcMonoBind         -- Half completed; LHS done, RHS not done
+  = TcFunBind  MonoBindInfo  SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn))
+  | TcPatBind [MonoBindInfo] (LPat GhcTcId) (GRHSs GhcRn (LHsExpr GhcRn))
+              TcSigmaType
+
+tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind
+-- Only called with plan InferGen (LetBndrSpec = LetLclBndr)
+--                    or NoGen    (LetBndrSpec = LetGblBndr)
+-- CheckGen is used only for functions with a complete type signature,
+--          and tcPolyCheck doesn't use tcMonoBinds at all
+
+tcLhs sig_fn no_gen (FunBind { fun_id = (dL->L nm_loc name)
+                             , fun_matches = matches })
+  | Just (TcIdSig sig) <- sig_fn name
+  = -- There is a type signature.
+    -- It must be partial; if complete we'd be in tcPolyCheck!
+    --    e.g.   f :: _ -> _
+    --           f x = ...g...
+    --           Just g = ...f...
+    -- Hence always typechecked with InferGen
+    do { mono_info <- tcLhsSigId no_gen (name, sig)
+       ; return (TcFunBind mono_info nm_loc matches) }
+
+  | otherwise  -- No type signature
+  = do { mono_ty <- newOpenFlexiTyVarTy
+       ; mono_id <- newLetBndr no_gen name mono_ty
+       ; let mono_info = MBI { mbi_poly_name = name
+                             , mbi_sig       = Nothing
+                             , mbi_mono_id   = mono_id }
+       ; return (TcFunBind mono_info nm_loc matches) }
+
+tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
+  = -- See Note [Typechecking pattern bindings]
+    do  { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names
+
+        ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $
+                             [ (mbi_poly_name mbi, mbi_mono_id mbi)
+                             | mbi <- sig_mbis ]
+
+            -- See Note [Existentials in pattern bindings]
+        ; ((pat', nosig_mbis), pat_ty)
+            <- addErrCtxt (patMonoBindsCtxt pat grhss) $
+               tcInferNoInst $ \ exp_ty ->
+               tcLetPat inst_sig_fun no_gen pat exp_ty $
+               mapM lookup_info nosig_names
+
+        ; let mbis = sig_mbis ++ nosig_mbis
+
+        ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id)
+                                | mbi <- mbis, let id = mbi_mono_id mbi ]
+                           $$ ppr no_gen)
+
+        ; return (TcPatBind mbis pat' grhss pat_ty) }
+  where
+    bndr_names = collectPatBinders pat
+    (nosig_names, sig_names) = partitionWith find_sig bndr_names
+
+    find_sig :: Name -> Either Name (Name, TcIdSigInfo)
+    find_sig name = case sig_fn name of
+                      Just (TcIdSig sig) -> Right (name, sig)
+                      _                  -> Left name
+
+      -- After typechecking the pattern, look up the binder
+      -- names that lack a signature, which the pattern has brought
+      -- into scope.
+    lookup_info :: Name -> TcM MonoBindInfo
+    lookup_info name
+      = do { mono_id <- tcLookupId name
+           ; return (MBI { mbi_poly_name = name
+                         , mbi_sig       = Nothing
+                         , mbi_mono_id   = mono_id }) }
+
+tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
+        -- AbsBind, VarBind impossible
+
+-------------------
+tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo
+tcLhsSigId no_gen (name, sig)
+  = do { inst_sig <- tcInstSig sig
+       ; mono_id <- newSigLetBndr no_gen name inst_sig
+       ; return (MBI { mbi_poly_name = name
+                     , mbi_sig       = Just inst_sig
+                     , mbi_mono_id   = mono_id }) }
+
+------------
+newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId
+newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig })
+  | CompleteSig { sig_bndr = poly_id } <- id_sig
+  = addInlinePrags poly_id (lookupPragEnv prags name)
+newSigLetBndr no_gen name (TISI { sig_inst_tau = tau })
+  = newLetBndr no_gen name tau
+
+-------------------
+tcRhs :: TcMonoBind -> TcM (HsBind GhcTcId)
+tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
+                 loc matches)
+  = tcExtendIdBinderStackForRhs [info]  $
+    tcExtendTyVarEnvForRhs mb_sig       $
+    do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
+        ; (co_fn, matches') <- tcMatchesFun (cL loc (idName mono_id))
+                                 matches (mkCheckExpType $ idType mono_id)
+        ; return ( FunBind { fun_id = cL loc mono_id
+                           , fun_matches = matches'
+                           , fun_co_fn = co_fn
+                           , fun_ext = placeHolderNamesTc
+                           , fun_tick = [] } ) }
+
+tcRhs (TcPatBind infos pat' grhss pat_ty)
+  = -- When we are doing pattern bindings we *don't* bring any scoped
+    -- type variables into scope unlike function bindings
+    -- Wny not?  They are not completely rigid.
+    -- That's why we have the special case for a single FunBind in tcMonoBinds
+    tcExtendIdBinderStackForRhs infos        $
+    do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
+        ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
+                    tcGRHSsPat grhss pat_ty
+        ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
+                           , pat_ext = NPatBindTc placeHolderNamesTc pat_ty
+                           , pat_ticks = ([],[]) } )}
+
+tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a
+tcExtendTyVarEnvForRhs Nothing thing_inside
+  = thing_inside
+tcExtendTyVarEnvForRhs (Just sig) thing_inside
+  = tcExtendTyVarEnvFromSig sig thing_inside
+
+tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a
+tcExtendTyVarEnvFromSig sig_inst thing_inside
+  | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst
+  = tcExtendNameTyVarEnv wcs $
+    tcExtendNameTyVarEnv skol_prs $
+    thing_inside
+
+tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a
+-- Extend the TcBinderStack for the RHS of the binding, with
+-- the monomorphic Id.  That way, if we have, say
+--     f = \x -> blah
+-- and something goes wrong in 'blah', we get a "relevant binding"
+-- looking like  f :: alpha -> beta
+-- This applies if 'f' has a type signature too:
+--    f :: forall a. [a] -> [a]
+--    f x = True
+-- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]
+-- If we had the *polymorphic* version of f in the TcBinderStack, it
+-- would not be reported as relevant, because its type is closed
+tcExtendIdBinderStackForRhs infos thing_inside
+  = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
+                        | MBI { mbi_mono_id = mono_id } <- infos ]
+                        thing_inside
+    -- NotTopLevel: it's a monomorphic binding
+
+---------------------
+getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
+getMonoBindInfo tc_binds
+  = foldr (get_info . unLoc) [] tc_binds
+  where
+    get_info (TcFunBind info _ _)    rest = info : rest
+    get_info (TcPatBind infos _ _ _) rest = infos ++ rest
+
+
+{- Note [Typechecking pattern bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Look at:
+   - typecheck/should_compile/ExPat
+   - Trac #12427, typecheck/should_compile/T12427{a,b}
+
+  data T where
+    MkT :: Integral a => a -> Int -> T
+
+and suppose t :: T.  Which of these pattern bindings are ok?
+
+  E1. let { MkT p _ = t } in <body>
+
+  E2. let { MkT _ q = t } in <body>
+
+  E3. let { MkT (toInteger -> r) _ = t } in <body>
+
+* (E1) is clearly wrong because the existential 'a' escapes.
+  What type could 'p' possibly have?
+
+* (E2) is fine, despite the existential pattern, because
+  q::Int, and nothing escapes.
+
+* Even (E3) is fine.  The existential pattern binds a dictionary
+  for (Integral a) which the view pattern can use to convert the
+  a-valued field to an Integer, so r :: Integer.
+
+An easy way to see all three is to imagine the desugaring.
+For (E2) it would look like
+    let q = case t of MkT _ q' -> q'
+    in <body>
+
+
+We typecheck pattern bindings as follows.  First tcLhs does this:
+
+  1. Take each type signature q :: ty, partial or complete, and
+     instantiate it (with tcLhsSigId) to get a MonoBindInfo.  This
+     gives us a fresh "mono_id" qm :: instantiate(ty), where qm has
+     a fresh name.
+
+     Any fresh unification variables in instantiate(ty) born here, not
+     deep under implications as would happen if we allocated them when
+     we encountered q during tcPat.
+
+  2. Build a little environment mapping "q" -> "qm" for those Ids
+     with signatures (inst_sig_fun)
+
+  3. Invoke tcLetPat to typecheck the pattern.
+
+     - We pass in the current TcLevel.  This is captured by
+       TcPat.tcLetPat, and put into the pc_lvl field of PatCtxt, in
+       PatEnv.
+
+     - When tcPat finds an existential constructor, it binds fresh
+       type variables and dictionaries as usual, increments the TcLevel,
+       and emits an implication constraint.
+
+     - When we come to a binder (TcPat.tcPatBndr), it looks it up
+       in the little environment (the pc_sig_fn field of PatCtxt).
+
+         Success => There was a type signature, so just use it,
+                    checking compatibility with the expected type.
+
+         Failure => No type sigature.
+             Infer case: (happens only outside any constructor pattern)
+                         use a unification variable
+                         at the outer level pc_lvl
+
+             Check case: use promoteTcType to promote the type
+                         to the outer level pc_lvl.  This is the
+                         place where we emit a constraint that'll blow
+                         up if existential capture takes place
+
+       Result: the type of the binder is always at pc_lvl. This is
+       crucial.
+
+  4. Throughout, when we are making up an Id for the pattern-bound variables
+     (newLetBndr), we have two cases:
+
+     - If we are generalising (generalisation plan is InferGen or
+       CheckGen), then the let_bndr_spec will be LetLclBndr.  In that case
+       we want to bind a cloned, local version of the variable, with the
+       type given by the pattern context, *not* by the signature (even if
+       there is one; see Trac #7268). The mkExport part of the
+       generalisation step will do the checking and impedance matching
+       against the signature.
+
+     - If for some some reason we are not generalising (plan = NoGen), the
+       LetBndrSpec will be LetGblBndr.  In that case we must bind the
+       global version of the Id, and do so with precisely the type given
+       in the signature.  (Then we unify with the type from the pattern
+       context type.)
+
+
+And that's it!  The implication constraints check for the skolem
+escape.  It's quite simple and neat, and more expressive than before
+e.g. GHC 8.0 rejects (E2) and (E3).
+
+Example for (E1), starting at level 1.  We generate
+     p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta)
+The (a~beta) can't float (because of the 'a'), nor be solved (because
+beta is untouchable.)
+
+Example for (E2), we generate
+     q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta)
+The beta is untoucable, but floats out of the constraint and can
+be solved absolutely fine.
+
+
+************************************************************************
+*                                                                      *
+                Generalisation
+*                                                                      *
+********************************************************************* -}
+
+data GeneralisationPlan
+  = NoGen               -- No generalisation, no AbsBinds
+
+  | InferGen            -- Implicit generalisation; there is an AbsBinds
+       Bool             --   True <=> apply the MR; generalise only unconstrained type vars
+
+  | CheckGen (LHsBind GhcRn) TcIdSigInfo
+                        -- One FunBind with a signature
+                        -- Explicit generalisation
+
+-- A consequence of the no-AbsBinds choice (NoGen) is that there is
+-- no "polymorphic Id" and "monmomorphic Id"; there is just the one
+
+instance Outputable GeneralisationPlan where
+  ppr NoGen          = text "NoGen"
+  ppr (InferGen b)   = text "InferGen" <+> ppr b
+  ppr (CheckGen _ s) = text "CheckGen" <+> ppr s
+
+decideGeneralisationPlan
+   :: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun
+   -> GeneralisationPlan
+decideGeneralisationPlan dflags lbinds closed sig_fn
+  | has_partial_sigs                         = InferGen (and partial_sig_mrs)
+  | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig
+  | do_not_generalise closed                 = NoGen
+  | otherwise                                = InferGen mono_restriction
+  where
+    binds = map unLoc lbinds
+
+    partial_sig_mrs :: [Bool]
+    -- One for each partial signature (so empty => no partial sigs)
+    -- The Bool is True if the signature has no constraint context
+    --      so we should apply the MR
+    -- See Note [Partial type signatures and generalisation]
+    partial_sig_mrs
+      = [ null theta
+        | TcIdSig (PartialSig { psig_hs_ty = hs_ty })
+            <- mapMaybe sig_fn (collectHsBindListBinders lbinds)
+        , let (_, dL->L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]
+
+    has_partial_sigs   = not (null partial_sig_mrs)
+
+    mono_restriction  = xopt LangExt.MonomorphismRestriction dflags
+                     && any restricted binds
+
+    do_not_generalise (IsGroupClosed _ True) = False
+        -- The 'True' means that all of the group's
+        -- free vars have ClosedTypeId=True; so we can ignore
+        -- -XMonoLocalBinds, and generalise anyway
+    do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags
+
+    -- With OutsideIn, all nested bindings are monomorphic
+    -- except a single function binding with a signature
+    one_funbind_with_sig
+      | [lbind@(dL->L _ (FunBind { fun_id = v }))] <- lbinds
+      , Just (TcIdSig sig) <- sig_fn (unLoc v)
+      = Just (lbind, sig)
+      | otherwise
+      = Nothing
+
+    -- The Haskell 98 monomorphism restriction
+    restricted (PatBind {})                              = True
+    restricted (VarBind { var_id = v })                  = no_sig v
+    restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
+                                                           && no_sig (unLoc v)
+    restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b)
+
+    restricted_match mg = matchGroupArity mg == 0
+        -- No args => like a pattern binding
+        -- Some args => a function binding
+
+    no_sig n = not (hasCompleteSig sig_fn n)
+
+isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed
+isClosedBndrGroup type_env binds
+  = IsGroupClosed fv_env type_closed
+  where
+    type_closed = allUFM (nameSetAll is_closed_type_id) fv_env
+
+    fv_env :: NameEnv NameSet
+    fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds
+
+    bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]
+    bindFvs (FunBind { fun_id = (dL->L _ f)
+                     , fun_ext = fvs })
+       = let open_fvs = get_open_fvs fvs
+         in [(f, open_fvs)]
+    bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs })
+       = let open_fvs = get_open_fvs fvs
+         in [(b, open_fvs) | b <- collectPatBinders pat]
+    bindFvs _
+       = []
+
+    get_open_fvs fvs = filterNameSet (not . is_closed) fvs
+
+    is_closed :: Name -> ClosedTypeId
+    is_closed name
+      | Just thing <- lookupNameEnv type_env name
+      = case thing of
+          AGlobal {}                     -> True
+          ATcId { tct_info = ClosedLet } -> True
+          _                              -> False
+
+      | otherwise
+      = True  -- The free-var set for a top level binding mentions
+
+
+    is_closed_type_id :: Name -> Bool
+    -- We're already removed Global and ClosedLet Ids
+    is_closed_type_id name
+      | Just thing <- lookupNameEnv type_env name
+      = case thing of
+          ATcId { tct_info = NonClosedLet _ cl } -> cl
+          ATcId { tct_info = NotLetBound }       -> False
+          ATyVar {}                              -> False
+               -- In-scope type variables are not closed!
+          _ -> pprPanic "is_closed_id" (ppr name)
+
+      | otherwise
+      = True   -- The free-var set for a top level binding mentions
+               -- imported things too, so that we can report unused imports
+               -- These won't be in the local type env.
+               -- Ditto class method etc from the current module
+
+
+{- *********************************************************************
+*                                                                      *
+               Error contexts and messages
+*                                                                      *
+********************************************************************* -}
+
+-- This one is called on LHS, when pat and grhss are both Name
+-- and on RHS, when pat is TcId and grhss is still Name
+patMonoBindsCtxt :: (OutputableBndrId (GhcPass p), Outputable body)
+                 => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc
+patMonoBindsCtxt pat grhss
+  = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcCanonical.hs
@@ -0,0 +1,2465 @@
+{-# LANGUAGE CPP #-}
+
+module TcCanonical(
+     canonicalize,
+     unifyDerived,
+     makeSuperClasses, maybeSym,
+     StopOrContinue(..), stopWith, continueWith,
+     solveCallStack    -- For TcSimplify
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnTypes
+import TcUnify( swapOverTyVars, metaTyVarUpdateOK )
+import TcType
+import Type
+import TcFlatten
+import TcSMonad
+import TcEvidence
+import TcEvTerm
+import Class
+import TyCon
+import TyCoRep   -- cleverly decomposes types, good for completeness checking
+import Coercion
+import CoreSyn
+import Id( idType, mkTemplateLocals )
+import FamInstEnv ( FamInstEnvs )
+import FamInst ( tcTopNormaliseNewTypeTF_maybe )
+import Var
+import VarEnv( mkInScopeSet )
+import VarSet( delVarSetList )
+import Outputable
+import DynFlags( DynFlags )
+import NameSet
+import RdrName
+import HsTypes( HsIPName(..) )
+
+import Pair
+import Util
+import Bag
+import MonadUtils
+import Control.Monad
+import Data.Maybe ( isJust )
+import Data.List  ( zip4 )
+import BasicTypes
+
+import Data.Bifunctor ( bimap )
+
+{-
+************************************************************************
+*                                                                      *
+*                      The Canonicaliser                               *
+*                                                                      *
+************************************************************************
+
+Note [Canonicalization]
+~~~~~~~~~~~~~~~~~~~~~~~
+
+Canonicalization converts a simple constraint to a canonical form. It is
+unary (i.e. treats individual constraints one at a time).
+
+Constraints originating from user-written code come into being as
+CNonCanonicals (except for CHoleCans, arising from holes). We know nothing
+about these constraints. So, first:
+
+     Classify CNonCanoncal constraints, depending on whether they
+     are equalities, class predicates, or other.
+
+Then proceed depending on the shape of the constraint. Generally speaking,
+each constraint gets flattened and then decomposed into one of several forms
+(see type Ct in TcRnTypes).
+
+When an already-canonicalized constraint gets kicked out of the inert set,
+it must be recanonicalized. But we know a bit about its shape from the
+last time through, so we can skip the classification step.
+
+-}
+
+-- Top-level canonicalization
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+canonicalize :: Ct -> TcS (StopOrContinue Ct)
+canonicalize (CNonCanonical { cc_ev = ev })
+  = {-# SCC "canNC" #-}
+    case classifyPredType pred of
+      ClassPred cls tys     -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)
+                                  canClassNC ev cls tys
+      EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)
+                                  canEqNC    ev eq_rel ty1 ty2
+      IrredPred {}          -> do traceTcS "canEvNC:irred" (ppr pred)
+                                  canIrred ev
+      ForAllPred _ _ pred   -> do traceTcS "canEvNC:forall" (ppr pred)
+                                  canForAll ev (isClassPred pred)
+  where
+    pred = ctEvPred ev
+
+canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))
+  = canForAll ev pend_sc
+
+canonicalize (CIrredCan { cc_ev = ev })
+  | EqPred eq_rel ty1 ty2 <- classifyPredType (ctEvPred ev)
+  = -- For insolubles (all of which are equalities, do /not/ flatten the arguments
+    -- In Trac #14350 doing so led entire-unnecessary and ridiculously large
+    -- type function expansion.  Instead, canEqNC just applies
+    -- the substitution to the predicate, and may do decomposition;
+    --    e.g. a ~ [a], where [G] a ~ [Int], can decompose
+    canEqNC ev eq_rel ty1 ty2
+
+  | otherwise
+  = canIrred ev
+
+canonicalize (CDictCan { cc_ev = ev, cc_class  = cls
+                       , cc_tyargs = xis, cc_pend_sc = pend_sc })
+  = {-# SCC "canClass" #-}
+    canClass ev cls xis pend_sc
+
+canonicalize (CTyEqCan { cc_ev = ev
+                       , cc_tyvar  = tv
+                       , cc_rhs    = xi
+                       , cc_eq_rel = eq_rel })
+  = {-# SCC "canEqLeafTyVarEq" #-}
+    canEqNC ev eq_rel (mkTyVarTy tv) xi
+      -- NB: Don't use canEqTyVar because that expects flattened types,
+      -- and tv and xi may not be flat w.r.t. an updated inert set
+
+canonicalize (CFunEqCan { cc_ev = ev
+                        , cc_fun    = fn
+                        , cc_tyargs = xis1
+                        , cc_fsk    = fsk })
+  = {-# SCC "canEqLeafFunEq" #-}
+    canCFunEqCan ev fn xis1 fsk
+
+canonicalize (CHoleCan { cc_ev = ev, cc_hole = hole })
+  = canHole ev hole
+
+{-
+************************************************************************
+*                                                                      *
+*                      Class Canonicalization
+*                                                                      *
+************************************************************************
+-}
+
+canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)
+-- "NC" means "non-canonical"; that is, we have got here
+-- from a NonCanonical constraint, not from a CDictCan
+-- Precondition: EvVar is class evidence
+canClassNC ev cls tys
+  | isGiven ev  -- See Note [Eagerly expand given superclasses]
+  = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys
+       ; emitWork sc_cts
+       ; canClass ev cls tys False }
+
+  | isWanted ev
+  , Just ip_name <- isCallStackPred cls tys
+  , OccurrenceOf func <- ctLocOrigin loc
+  -- If we're given a CallStack constraint that arose from a function
+  -- call, we need to push the current call-site onto the stack instead
+  -- of solving it directly from a given.
+  -- See Note [Overview of implicit CallStacks] in TcEvidence
+  -- and Note [Solving CallStack constraints] in TcSMonad
+  = do { -- First we emit a new constraint that will capture the
+         -- given CallStack.
+       ; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))
+                            -- We change the origin to IPOccOrigin so
+                            -- this rule does not fire again.
+                            -- See Note [Overview of implicit CallStacks]
+
+       ; new_ev <- newWantedEvVarNC new_loc pred
+
+         -- Then we solve the wanted by pushing the call-site
+         -- onto the newly emitted CallStack
+       ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev)
+       ; solveCallStack ev ev_cs
+
+       ; canClass new_ev cls tys False }
+
+  | otherwise
+  = canClass ev cls tys (has_scs cls)
+
+  where
+    has_scs cls = not (null (classSCTheta cls))
+    loc  = ctEvLoc ev
+    pred = ctEvPred ev
+
+solveCallStack :: CtEvidence -> EvCallStack -> TcS ()
+-- Also called from TcSimplify when defaulting call stacks
+solveCallStack ev ev_cs = do
+  -- We're given ev_cs :: CallStack, but the evidence term should be a
+  -- dictionary, so we have to coerce ev_cs to a dictionary for
+  -- `IP ip CallStack`. See Note [Overview of implicit CallStacks]
+  cs_tm <- evCallStack ev_cs
+  let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))
+  setEvBindIfWanted ev ev_tm
+
+canClass :: CtEvidence
+         -> Class -> [Type]
+         -> Bool            -- True <=> un-explored superclasses
+         -> TcS (StopOrContinue Ct)
+-- Precondition: EvVar is class evidence
+
+canClass ev cls tys pend_sc
+  =   -- all classes do *nominal* matching
+    ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )
+    do { (xis, cos, _kind_co) <- flattenArgsNom ev cls_tc tys
+       ; MASSERT( isTcReflCo _kind_co )
+       ; let co = mkTcTyConAppCo Nominal cls_tc cos
+             xi = mkClassPred cls xis
+             mk_ct new_ev = CDictCan { cc_ev = new_ev
+                                     , cc_tyargs = xis
+                                     , cc_class = cls
+                                     , cc_pend_sc = pend_sc }
+       ; mb <- rewriteEvidence ev xi co
+       ; traceTcS "canClass" (vcat [ ppr ev
+                                   , ppr xi, ppr mb ])
+       ; return (fmap mk_ct mb) }
+  where
+    cls_tc = classTyCon cls
+
+{- Note [The superclass story]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to add superclass constraints for two reasons:
+
+* For givens [G], they give us a route to proof.  E.g.
+    f :: Ord a => a -> Bool
+    f x = x == x
+  We get a Wanted (Eq a), which can only be solved from the superclass
+  of the Given (Ord a).
+
+* For wanteds [W], and deriveds [WD], [D], they may give useful
+  functional dependencies.  E.g.
+     class C a b | a -> b where ...
+     class C a b => D a b where ...
+  Now a [W] constraint (D Int beta) has (C Int beta) as a superclass
+  and that might tell us about beta, via C's fundeps.  We can get this
+  by generating a [D] (C Int beta) constraint.  It's derived because
+  we don't actually have to cough up any evidence for it; it's only there
+  to generate fundep equalities.
+
+See Note [Why adding superclasses can help].
+
+For these reasons we want to generate superclass constraints for both
+Givens and Wanteds. But:
+
+* (Minor) they are often not needed, so generating them aggressively
+  is a waste of time.
+
+* (Major) if we want recursive superclasses, there would be an infinite
+  number of them.  Here is a real-life example (Trac #10318);
+
+     class (Frac (Frac a) ~ Frac a,
+            Fractional (Frac a),
+            IntegralDomain (Frac a))
+         => IntegralDomain a where
+      type Frac a :: *
+
+  Notice that IntegralDomain has an associated type Frac, and one
+  of IntegralDomain's superclasses is another IntegralDomain constraint.
+
+So here's the plan:
+
+1. Eagerly generate superclasses for given (but not wanted)
+   constraints; see Note [Eagerly expand given superclasses].
+   This is done using mkStrictSuperClasses in canClassNC, when
+   we take a non-canonical Given constraint and cannonicalise it.
+
+   However stop if you encounter the same class twice.  That is,
+   mkStrictSuperClasses expands eagerly, but has a conservative
+   termination condition: see Note [Expanding superclasses] in TcType.
+
+2. Solve the wanteds as usual, but do no further expansion of
+   superclasses for canonical CDictCans in solveSimpleGivens or
+   solveSimpleWanteds; Note [Danger of adding superclasses during solving]
+
+   However, /do/ continue to eagerly expand superlasses for new /given/
+   /non-canonical/ constraints (canClassNC does this).  As Trac #12175
+   showed, a type-family application can expand to a class constraint,
+   and we want to see its superclasses for just the same reason as
+   Note [Eagerly expand given superclasses].
+
+3. If we have any remaining unsolved wanteds
+        (see Note [When superclasses help] in TcRnTypes)
+   try harder: take both the Givens and Wanteds, and expand
+   superclasses again.  See the calls to expandSuperClasses in
+   TcSimplify.simpl_loop and solveWanteds.
+
+   This may succeed in generating (a finite number of) extra Givens,
+   and extra Deriveds. Both may help the proof.
+
+3a An important wrinkle: only expand Givens from the current level.
+   Two reasons:
+      - We only want to expand it once, and that is best done at
+        the level it is bound, rather than repeatedly at the leaves
+        of the implication tree
+      - We may be inside a type where we can't create term-level
+        evidence anyway, so we can't superclass-expand, say,
+        (a ~ b) to get (a ~# b).  This happened in Trac #15290.
+
+4. Go round to (2) again.  This loop (2,3,4) is implemented
+   in TcSimplify.simpl_loop.
+
+The cc_pend_sc flag in a CDictCan records whether the superclasses of
+this constraint have been expanded.  Specifically, in Step 3 we only
+expand superclasses for constraints with cc_pend_sc set to true (i.e.
+isPendingScDict holds).
+
+Why do we do this?  Two reasons:
+
+* To avoid repeated work, by repeatedly expanding the superclasses of
+  same constraint,
+
+* To terminate the above loop, at least in the -XNoRecursiveSuperClasses
+  case.  If there are recursive superclasses we could, in principle,
+  expand forever, always encountering new constraints.
+
+When we take a CNonCanonical or CIrredCan, but end up classifying it
+as a CDictCan, we set the cc_pend_sc flag to False.
+
+Note [Superclass loops]
+~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+  class C a => D a
+  class D a => C a
+
+Then, when we expand superclasses, we'll get back to the self-same
+predicate, so we have reached a fixpoint in expansion and there is no
+point in fruitlessly expanding further.  This case just falls out from
+our strategy.  Consider
+  f :: C a => a -> Bool
+  f x = x==x
+Then canClassNC gets the [G] d1: C a constraint, and eager emits superclasses
+G] d2: D a, [G] d3: C a (psc).  (The "psc" means it has its sc_pend flag set.)
+When processing d3 we find a match with d1 in the inert set, and we always
+keep the inert item (d1) if possible: see Note [Replacement vs keeping] in
+TcInteract.  So d3 dies a quick, happy death.
+
+Note [Eagerly expand given superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In step (1) of Note [The superclass story], why do we eagerly expand
+Given superclasses by one layer?  (By "one layer" we mean expand transitively
+until you meet the same class again -- the conservative criterion embodied
+in expandSuperClasses.  So a "layer" might be a whole stack of superclasses.)
+We do this eagerly for Givens mainly because of some very obscure
+cases like this:
+
+   instance Bad a => Eq (T a)
+
+   f :: (Ord (T a)) => blah
+   f x = ....needs Eq (T a), Ord (T a)....
+
+Here if we can't satisfy (Eq (T a)) from the givens we'll use the
+instance declaration; but then we are stuck with (Bad a).  Sigh.
+This is really a case of non-confluent proofs, but to stop our users
+complaining we expand one layer in advance.
+
+Note [Instance and Given overlap] in TcInteract.
+
+We also want to do this if we have
+
+   f :: F (T a) => blah
+
+where
+   type instance F (T a) = Ord (T a)
+
+So we may need to do a little work on the givens to expose the
+class that has the superclasses.  That's why the superclass
+expansion for Givens happens in canClassNC.
+
+Note [Why adding superclasses can help]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Examples of how adding superclasses can help:
+
+    --- Example 1
+        class C a b | a -> b
+    Suppose we want to solve
+         [G] C a b
+         [W] C a beta
+    Then adding [D] beta~b will let us solve it.
+
+    -- Example 2 (similar but using a type-equality superclass)
+        class (F a ~ b) => C a b
+    And try to sllve:
+         [G] C a b
+         [W] C a beta
+    Follow the superclass rules to add
+         [G] F a ~ b
+         [D] F a ~ beta
+    Now we get [D] beta ~ b, and can solve that.
+
+    -- Example (tcfail138)
+      class L a b | a -> b
+      class (G a, L a b) => C a b
+
+      instance C a b' => G (Maybe a)
+      instance C a b  => C (Maybe a) a
+      instance L (Maybe a) a
+
+    When solving the superclasses of the (C (Maybe a) a) instance, we get
+      [G] C a b, and hance by superclasses, [G] G a, [G] L a b
+      [W] G (Maybe a)
+    Use the instance decl to get
+      [W] C a beta
+    Generate its derived superclass
+      [D] L a beta.  Now using fundeps, combine with [G] L a b to get
+      [D] beta ~ b
+    which is what we want.
+
+Note [Danger of adding superclasses during solving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here's a serious, but now out-dated example, from Trac #4497:
+
+   class Num (RealOf t) => Normed t
+   type family RealOf x
+
+Assume the generated wanted constraint is:
+   [W] RealOf e ~ e
+   [W] Normed e
+
+If we were to be adding the superclasses during simplification we'd get:
+   [W] RealOf e ~ e
+   [W] Normed e
+   [D] RealOf e ~ fuv
+   [D] Num fuv
+==>
+   e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv
+
+While looks exactly like our original constraint. If we add the
+superclass of (Normed fuv) again we'd loop.  By adding superclasses
+definitely only once, during canonicalisation, this situation can't
+happen.
+
+Mind you, now that Wanteds cannot rewrite Derived, I think this particular
+situation can't happen.
+  -}
+
+makeSuperClasses :: [Ct] -> TcS [Ct]
+-- Returns strict superclasses, transitively, see Note [The superclasses story]
+-- See Note [The superclass story]
+-- The loop-breaking here follows Note [Expanding superclasses] in TcType
+-- Specifically, for an incoming (C t) constraint, we return all of (C t)'s
+--    superclasses, up to /and including/ the first repetition of C
+--
+-- Example:  class D a => C a
+--           class C [a] => D a
+-- makeSuperClasses (C x) will return (D x, C [x])
+--
+-- NB: the incoming constraints have had their cc_pend_sc flag already
+--     flipped to False, by isPendingScDict, so we are /obliged/ to at
+--     least produce the immediate superclasses
+makeSuperClasses cts = concatMapM go cts
+  where
+    go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
+      = mkStrictSuperClasses ev [] [] cls tys
+    go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev }))
+      = ASSERT2( isClassPred pred, ppr pred )  -- The cts should all have
+                                               -- class pred heads
+        mkStrictSuperClasses ev tvs theta cls tys
+      where
+        (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)
+    go ct = pprPanic "makeSuperClasses" (ppr ct)
+
+mkStrictSuperClasses
+    :: CtEvidence
+    -> [TyVar] -> ThetaType  -- These two args are non-empty only when taking
+                             -- superclasses of a /quantified/ constraint
+    -> Class -> [Type] -> TcS [Ct]
+-- Return constraints for the strict superclasses of
+--   ev :: forall as. theta => cls tys
+mkStrictSuperClasses ev tvs theta cls tys
+  = mk_strict_superclasses (unitNameSet (className cls))
+                           ev tvs theta cls tys
+
+mk_strict_superclasses :: NameSet -> CtEvidence
+                       -> [TyVar] -> ThetaType
+                       -> Class -> [Type] -> TcS [Ct]
+-- Always return the immediate superclasses of (cls tys);
+-- and expand their superclasses, provided none of them are in rec_clss
+-- nor are repeated
+mk_strict_superclasses rec_clss ev tvs theta cls tys
+  | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev
+  = concatMapM (do_one_given evar (mk_given_loc loc)) $
+    classSCSelIds cls
+  where
+    dict_ids  = mkTemplateLocals theta
+    size      = sizeTypes tys
+
+    do_one_given evar given_loc sel_id
+      | isUnliftedType sc_pred
+      , not (null tvs && null theta)
+      = -- See Note [Equality superclasses in quantified constraints]
+        return []
+      | otherwise
+      = do { given_ev <- newGivenEvVar given_loc $
+                         (given_ty, mk_sc_sel evar sel_id)
+           ; mk_superclasses rec_clss given_ev tvs theta sc_pred }
+      where
+        sc_pred  = funResultTy (piResultTys (idType sel_id) tys)
+        given_ty = mkInfSigmaTy tvs theta sc_pred
+
+    mk_sc_sel evar sel_id
+      = EvExpr $ mkLams tvs $ mkLams dict_ids $
+        Var sel_id `mkTyApps` tys `App`
+        (evId evar `mkTyApps` mkTyVarTys tvs `mkVarApps` dict_ids)
+
+    mk_given_loc loc
+       | isCTupleClass cls
+       = loc   -- For tuple predicates, just take them apart, without
+               -- adding their (large) size into the chain.  When we
+               -- get down to a base predicate, we'll include its size.
+               -- Trac #10335
+
+       | GivenOrigin skol_info <- ctLocOrigin loc
+         -- See Note [Solving superclass constraints] in TcInstDcls
+         -- for explantation of this transformation for givens
+       = case skol_info of
+            InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) }
+            InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) }
+            _        -> loc
+
+       | otherwise  -- Probably doesn't happen, since this function
+       = loc        -- is only used for Givens, but does no harm
+
+mk_strict_superclasses rec_clss ev tvs theta cls tys
+  | all noFreeVarsOfType tys
+  = return [] -- Wanteds with no variables yield no deriveds.
+              -- See Note [Improvement from Ground Wanteds]
+
+  | otherwise -- Wanted/Derived case, just add Derived superclasses
+              -- that can lead to improvement.
+  = ASSERT2( null tvs && null theta, ppr tvs $$ ppr theta )
+    concatMapM do_one_derived (immSuperClasses cls tys)
+  where
+    loc = ctEvLoc ev
+
+    do_one_derived sc_pred
+      = do { sc_ev <- newDerivedNC loc sc_pred
+           ; mk_superclasses rec_clss sc_ev [] [] sc_pred }
+
+mk_superclasses :: NameSet -> CtEvidence
+                -> [TyVar] -> ThetaType -> PredType -> TcS [Ct]
+-- Return this constraint, plus its superclasses, if any
+mk_superclasses rec_clss ev tvs theta pred
+  | ClassPred cls tys <- classifyPredType pred
+  = mk_superclasses_of rec_clss ev tvs theta cls tys
+
+  | otherwise   -- Superclass is not a class predicate
+  = return [mkNonCanonical ev]
+
+mk_superclasses_of :: NameSet -> CtEvidence
+                   -> [TyVar] -> ThetaType -> Class -> [Type]
+                   -> TcS [Ct]
+-- Always return this class constraint,
+-- and expand its superclasses
+mk_superclasses_of rec_clss ev tvs theta cls tys
+  | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)
+                    ; return [this_ct] }  -- cc_pend_sc of this_ct = True
+  | otherwise  = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys
+                                                          , ppr (isCTupleClass cls)
+                                                          , ppr rec_clss
+                                                          ])
+                    ; sc_cts <- mk_strict_superclasses rec_clss' ev tvs theta cls tys
+                    ; return (this_ct : sc_cts) }
+                                   -- cc_pend_sc of this_ct = False
+  where
+    cls_nm     = className cls
+    loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss
+                 -- Tuples never contribute to recursion, and can be nested
+    rec_clss'  = rec_clss `extendNameSet` cls_nm
+
+    this_ct | null tvs, null theta
+            = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys
+                       , cc_pend_sc = loop_found }
+                 -- NB: If there is a loop, we cut off, so we have not
+                 --     added the superclasses, hence cc_pend_sc = True
+            | otherwise
+            = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys
+                             , qci_ev = ev
+                             , qci_pend_sc = loop_found })
+
+
+{- Note [Equality superclasses in quantified constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #15359, #15593, #15625)
+  f :: (forall a. theta => a ~ b) => stuff
+
+It's a bit odd to have a local, quantified constraint for `(a~b)`,
+but some people want such a thing (see the tickets). And for
+Coercible it is definitely useful
+  f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q)))
+                 => stuff
+
+Moreover it's not hard to arrange; we just need to look up /equality/
+constraints in the quantified-constraint environment, which we do in
+TcInteract.doTopReactOther.
+
+There is a wrinkle though, in the case where 'theta' is empty, so
+we have
+  f :: (forall a. a~b) => stuff
+
+Now, potentially, the superclass machinery kicks in, in
+makeSuperClasses, giving us a a second quantified constrait
+       (forall a. a ~# b)
+BUT this is an unboxed value!  And nothing has prepared us for
+dictionary "functions" that are unboxed.  Actually it does just
+about work, but the simplier ends up with stuff like
+   case (/\a. eq_sel d) of df -> ...(df @Int)...
+and fails to simplify that any further.  And it doesn't satisfy
+isPredTy any more.
+
+So for now we simply decline to take superclasses in the quantified
+case.  Instead we have a special case in TcInteract.doTopReactOther,
+which looks for primitive equalities specially in the quantified
+constraints.
+
+See also Note [Evidence for quantified constraints] in Type.
+
+
+************************************************************************
+*                                                                      *
+*                      Irreducibles canonicalization
+*                                                                      *
+************************************************************************
+-}
+
+canIrred :: CtEvidence -> TcS (StopOrContinue Ct)
+-- Precondition: ty not a tuple and no other evidence form
+canIrred ev
+  = do { let pred = ctEvPred ev
+       ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)
+       ; (xi,co) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred
+       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->
+    do { -- Re-classify, in case flattening has improved its shape
+       ; case classifyPredType (ctEvPred new_ev) of
+           ClassPred cls tys     -> canClassNC new_ev cls tys
+           EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2
+           _                     -> continueWith $
+                                    mkIrredCt new_ev } }
+
+canHole :: CtEvidence -> Hole -> TcS (StopOrContinue Ct)
+canHole ev hole
+  = do { let pred = ctEvPred ev
+       ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred
+       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->
+    do { updInertIrreds (`snocCts` (CHoleCan { cc_ev = new_ev
+                                             , cc_hole = hole }))
+       ; stopWith new_ev "Emit insoluble hole" } }
+
+
+{- *********************************************************************
+*                                                                      *
+*                      Quantified predicates
+*                                                                      *
+********************************************************************* -}
+
+{- Note [Quantified constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The -XQuantifiedConstraints extension allows type-class contexts like this:
+
+  data Rose f x = Rose x (f (Rose f x))
+
+  instance (Eq a, forall b. Eq b => Eq (f b))
+        => Eq (Rose f a)  where
+    (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2
+
+Note the (forall b. Eq b => Eq (f b)) in the instance contexts.
+This quantified constraint is needed to solve the
+ [W] (Eq (f (Rose f x)))
+constraint which arises form the (==) definition.
+
+The wiki page is
+  https://ghc.haskell.org/trac/ghc/wiki/QuantifiedConstraints
+which in turn contains a link to the GHC Proposal where the change
+is specified, and a Haskell Symposium paper about it.
+
+We implement two main extensions to the design in the paper:
+
+ 1. We allow a variable in the instance head, e.g.
+      f :: forall m a. (forall b. m b) => D (m a)
+    Notice the 'm' in the head of the quantified constraint, not
+    a class.
+
+ 2. We suport superclasses to quantified constraints.
+    For example (contrived):
+      f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool
+      f x y = x==y
+    Here we need (Eq (m a)); but the quantifed constraint deals only
+    with Ord.  But we can make it work by using its superclass.
+
+Here are the moving parts
+  * Language extension {-# LANGUAGE QuantifiedConstraints #-}
+    and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension
+
+  * A new form of evidence, EvDFun, that is used to discharge
+    such wanted constraints
+
+  * checkValidType gets some changes to accept forall-constraints
+    only in the right places.
+
+  * Type.PredTree gets a new constructor ForAllPred, and
+    and classifyPredType analyses a PredType to decompose
+    the new forall-constraints
+
+  * TcSMonad.InertCans gets an extra field, inert_insts,
+    which holds all the Given forall-constraints.  In effect,
+    such Given constraints are like local instance decls.
+
+  * When trying to solve a class constraint, via
+    TcInteract.matchInstEnv, use the InstEnv from inert_insts
+    so that we include the local Given forall-constraints
+    in the lookup.  (See TcSMonad.getInstEnvs.)
+
+  * TcCanonical.canForAll deals with solving a
+    forall-constraint.  See
+       Note [Solving a Wanted forall-constraint]
+
+  * We augment the kick-out code to kick out an inert
+    forall constraint if it can be rewritten by a new
+    type equality; see TcSMonad.kick_out_rewritable
+
+Note that a quantified constraint is never /inferred/
+(by TcSimplify.simplifyInfer).  A function can only have a
+quantified constraint in its type if it is given an explicit
+type signature.
+
+Note that we implement
+-}
+
+canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct)
+-- We have a constraint (forall as. blah => C tys)
+canForAll ev pend_sc
+  = do { -- First rewrite it to apply the current substitution
+         -- Do not bother with type-family reductions; we can't
+         -- do them under a forall anyway (c.f. Flatten.flatten_one
+         -- on a forall type)
+         let pred = ctEvPred ev
+       ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred
+       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->
+
+    do { -- Now decompose into its pieces and solve it
+         -- (It takes a lot less code to flatten before decomposing.)
+       ; case classifyPredType (ctEvPred new_ev) of
+           ForAllPred tv_bndrs theta pred
+              -> solveForAll new_ev tv_bndrs theta pred pend_sc
+           _  -> pprPanic "canForAll" (ppr new_ev)
+    } }
+
+solveForAll :: CtEvidence -> [TyVarBinder] -> TcThetaType -> PredType -> Bool
+            -> TcS (StopOrContinue Ct)
+solveForAll ev tv_bndrs theta pred pend_sc
+  | CtWanted { ctev_dest = dest } <- ev
+  = -- See Note [Solving a Wanted forall-constraint]
+    do { let skol_info = QuantCtxtSkol
+             empty_subst = mkEmptyTCvSubst $ mkInScopeSet $
+                           tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs
+       ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs
+       ; given_ev_vars <- mapM newEvVar (substTheta subst theta)
+
+       ; (w_id, ev_binds)
+             <- checkConstraintsTcS skol_info skol_tvs given_ev_vars $
+                do { wanted_ev <- newWantedEvVarNC loc $
+                                  substTy subst pred
+                   ; return ( ctEvEvId wanted_ev
+                            , unitBag (mkNonCanonical wanted_ev)) }
+
+      ; setWantedEvTerm dest $
+        EvFun { et_tvs = skol_tvs, et_given = given_ev_vars
+              , et_binds = ev_binds, et_body = w_id }
+
+      ; stopWith ev "Wanted forall-constraint" }
+
+  | isGiven ev   -- See Note [Solving a Given forall-constraint]
+  = do { addInertForAll qci
+       ; stopWith ev "Given forall-constraint" }
+
+  | otherwise
+  = stopWith ev "Derived forall-constraint"
+  where
+    loc = ctEvLoc ev
+    tvs = binderVars tv_bndrs
+    qci = QCI { qci_ev = ev, qci_tvs = tvs
+              , qci_pred = pred, qci_pend_sc = pend_sc }
+
+{- Note [Solving a Wanted forall-constraint]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Solving a wanted forall (quantified) constraint
+  [W] df :: forall ab. (Eq a, Ord b) => C x a b
+is delightfully easy.   Just build an implication constraint
+    forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a
+and discharge df thus:
+    df = /\ab. \g1 g2. let <binds> in d
+where <binds> is filled in by solving the implication constraint.
+All the machinery is to hand; there is little to do.
+
+Note [Solving a Given forall-constraint]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For a Given constraint
+  [G] df :: forall ab. (Eq a, Ord b) => C x a b
+we just add it to TcS's local InstEnv of known instances,
+via addInertForall.  Then, if we look up (C x Int Bool), say,
+we'll find a match in the InstEnv.
+
+
+************************************************************************
+*                                                                      *
+*        Equalities
+*                                                                      *
+************************************************************************
+
+Note [Canonicalising equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In order to canonicalise an equality, we look at the structure of the
+two types at hand, looking for similarities. A difficulty is that the
+types may look dissimilar before flattening but similar after flattening.
+However, we don't just want to jump in and flatten right away, because
+this might be wasted effort. So, after looking for similarities and failing,
+we flatten and then try again. Of course, we don't want to loop, so we
+track whether or not we've already flattened.
+
+It is conceivable to do a better job at tracking whether or not a type
+is flattened, but this is left as future work. (Mar '15)
+
+
+Note [FunTy and decomposing tycon applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When can_eq_nc' attempts to decompose a tycon application we haven't yet zonked.
+This means that we may very well have a FunTy containing a type of some unknown
+kind. For instance, we may have,
+
+    FunTy (a :: k) Int
+
+Where k is a unification variable. tcRepSplitTyConApp_maybe panics in the event
+that it sees such a type as it cannot determine the RuntimeReps which the (->)
+is applied to. Consequently, it is vital that we instead use
+tcRepSplitTyConApp_maybe', which simply returns Nothing in such a case.
+
+When this happens can_eq_nc' will fail to decompose, zonk, and try again.
+Zonking should fill the variable k, meaning that decomposition will succeed the
+second time around.
+-}
+
+canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct)
+canEqNC ev eq_rel ty1 ty2
+  = do { result <- zonk_eq_types ty1 ty2
+       ; case result of
+           Left (Pair ty1' ty2') -> can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2
+           Right ty              -> canEqReflexive ev eq_rel ty }
+
+can_eq_nc
+   :: Bool            -- True => both types are flat
+   -> CtEvidence
+   -> EqRel
+   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp
+   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp
+   -> TcS (StopOrContinue Ct)
+can_eq_nc flat ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+  = do { traceTcS "can_eq_nc" $
+         vcat [ ppr flat, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ]
+       ; rdr_env <- getGlobalRdrEnvTcS
+       ; fam_insts <- getFamInstEnvs
+       ; can_eq_nc' flat rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 }
+
+can_eq_nc'
+   :: Bool           -- True => both input types are flattened
+   -> GlobalRdrEnv   -- needed to see which newtypes are in scope
+   -> FamInstEnvs    -- needed to unwrap data instances
+   -> CtEvidence
+   -> EqRel
+   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp
+   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp
+   -> TcS (StopOrContinue Ct)
+
+-- Expand synonyms first; see Note [Type synonyms and canonicalization]
+can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+  | Just ty1' <- tcView ty1 = can_eq_nc flat ev eq_rel ty1' ps_ty1 ty2  ps_ty2
+  | Just ty2' <- tcView ty2 = can_eq_nc flat ev eq_rel ty1  ps_ty1 ty2' ps_ty2
+
+-- need to check for reflexivity in the ReprEq case.
+-- See Note [Eager reflexivity check]
+-- Check only when flat because the zonk_eq_types check in canEqNC takes
+-- care of the non-flat case.
+can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _
+  | ty1 `tcEqType` ty2
+  = canEqReflexive ev ReprEq ty1
+
+-- When working with ReprEq, unwrap newtypes.
+-- See Note [Unwrap newtypes first]
+can_eq_nc' _flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
+  | ReprEq <- eq_rel
+  , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1
+  = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2
+
+  | ReprEq <- eq_rel
+  , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2
+  = can_eq_newtype_nc ev IsSwapped  ty2 stuff2 ty1 ps_ty1
+
+-- Then, get rid of casts
+can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2
+  = canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2
+can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _
+  = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1
+
+-- NB: pattern match on True: we want only flat types sent to canEqTyVar.
+-- See also Note [No top-level newtypes on RHS of representational equalities]
+can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2
+  = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2
+can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2
+  = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1
+
+----------------------
+-- Otherwise try to decompose
+----------------------
+
+-- Literals
+can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
+ | l1 == l2
+  = do { setEvBindIfWanted ev (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1)
+       ; stopWith ev "Equal LitTy" }
+
+-- Try to decompose type constructor applications
+-- Including FunTy (s -> t)
+can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1 _ ty2 _
+    --- See Note [FunTy and decomposing type constructor applications].
+  | Just (tc1, tys1) <- tcRepSplitTyConApp_maybe' ty1
+  , Just (tc2, tys2) <- tcRepSplitTyConApp_maybe' ty2
+  , not (isTypeFamilyTyCon tc1)
+  , not (isTypeFamilyTyCon tc2)
+  = canTyConApp ev eq_rel tc1 tys1 tc2 tys2
+
+can_eq_nc' _flat _rdr_env _envs ev eq_rel
+           s1@(ForAllTy {}) _ s2@(ForAllTy {}) _
+  = can_eq_nc_forall ev eq_rel s1 s2
+
+-- See Note [Canonicalising type applications] about why we require flat types
+can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _
+  | NomEq <- eq_rel
+  , Just (t2, s2) <- tcSplitAppTy_maybe ty2
+  = can_eq_app ev t1 s1 t2 s2
+can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _
+  | NomEq <- eq_rel
+  , Just (t1, s1) <- tcSplitAppTy_maybe ty1
+  = can_eq_app ev t1 s1 t2 s2
+
+-- No similarity in type structure detected. Flatten and try again.
+can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2
+  = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1
+       ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2
+       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2
+       ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }
+
+-- We've flattened and the types don't match. Give up.
+can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2
+  = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2)
+       ; case eq_rel of -- See Note [Unsolved equalities]
+            ReprEq -> continueWith (mkIrredCt ev)
+            NomEq  -> continueWith (mkInsolubleCt ev) }
+          -- No need to call canEqFailure/canEqHardFailure because they
+          -- flatten, and the types involved here are already flat
+
+{- Note [Unsolved equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have an unsolved equality like
+  (a b ~R# Int)
+that is not necessarily insoluble!  Maybe 'a' will turn out to be a newtype.
+So we want to make it a potentially-soluble Irred not an insoluble one.
+Missing this point is what caused Trac #15431
+-}
+
+---------------------------------
+can_eq_nc_forall :: CtEvidence -> EqRel
+                 -> Type -> Type    -- LHS and RHS
+                 -> TcS (StopOrContinue Ct)
+-- (forall as. phi1) ~ (forall bs. phi2)
+-- Check for length match of as, bs
+-- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs]
+-- But remember also to unify the kinds of as and bs
+--  (this is the 'go' loop), and actually substitute phi2[as |> cos / bs]
+-- Remember also that we might have forall z (a:z). blah
+--  so we must proceed one binder at a time (Trac #13879)
+
+can_eq_nc_forall ev eq_rel s1 s2
+ | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev
+ = do { let free_tvs       = tyCoVarsOfTypes [s1,s2]
+            (bndrs1, phi1) = tcSplitForAllVarBndrs s1
+            (bndrs2, phi2) = tcSplitForAllVarBndrs s2
+      ; if not (equalLength bndrs1 bndrs2)
+        then do { traceTcS "Forall failure" $
+                     vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2
+                          , ppr (map binderArgFlag bndrs1)
+                          , ppr (map binderArgFlag bndrs2) ]
+                ; canEqHardFailure ev s1 s2 }
+        else
+   do { traceTcS "Creating implication for polytype equality" $ ppr ev
+      ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs
+      ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $
+                              binderVars bndrs1
+
+      ; let skol_info = UnifyForAllSkol phi1
+            phi1' = substTy subst1 phi1
+
+            -- Unify the kinds, extend the substitution
+            go :: [TcTyVar] -> TCvSubst -> [TyVarBinder]
+               -> TcS (TcCoercion, Cts)
+            go (skol_tv:skol_tvs) subst (bndr2:bndrs2)
+              = do { let tv2 = binderVar bndr2
+                   ; (kind_co, wanteds1) <- unify loc Nominal (tyVarKind skol_tv)
+                                                  (substTy subst (tyVarKind tv2))
+                   ; let subst' = extendTvSubst subst tv2
+                                       (mkCastTy (mkTyVarTy skol_tv) kind_co)
+                   ; (co, wanteds2) <- go skol_tvs subst' bndrs2
+                   ; return ( mkTcForAllCo skol_tv kind_co co
+                            , wanteds1 `unionBags` wanteds2 ) }
+
+            -- Done: unify phi1 ~ phi2
+            go [] subst bndrs2
+              = ASSERT( null bndrs2 )
+                unify loc (eqRelRole eq_rel) phi1' (substTy subst phi2)
+
+            go _ _ _ = panic "cna_eq_nc_forall"  -- case (s:ss) []
+
+            empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1)
+
+      ; all_co <- checkTvConstraintsTcS skol_info skol_tvs $
+                  go skol_tvs empty_subst2 bndrs2
+
+      ; setWantedEq orig_dest all_co
+      ; stopWith ev "Deferred polytype equality" } }
+
+ | otherwise
+ = do { traceTcS "Omitting decomposition of given polytype equality" $
+        pprEq s1 s2    -- See Note [Do not decompose given polytype equalities]
+      ; stopWith ev "Discard given polytype equality" }
+
+ where
+    unify :: CtLoc -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts)
+    -- This version returns the wanted constraint rather
+    -- than putting it in the work list
+    unify loc role ty1 ty2
+      | ty1 `tcEqType` ty2
+      = return (mkTcReflCo role ty1, emptyBag)
+      | otherwise
+      = do { (wanted, co) <- newWantedEq loc role ty1 ty2
+           ; return (co, unitBag (mkNonCanonical wanted)) }
+
+---------------------------------
+-- | Compare types for equality, while zonking as necessary. Gives up
+-- as soon as it finds that two types are not equal.
+-- This is quite handy when some unification has made two
+-- types in an inert wanted to be equal. We can discover the equality without
+-- flattening, which is sometimes very expensive (in the case of type functions).
+-- In particular, this function makes a ~20% improvement in test case
+-- perf/compiler/T5030.
+--
+-- Returns either the (partially zonked) types in the case of
+-- inequality, or the one type in the case of equality. canEqReflexive is
+-- a good next step in the 'Right' case. Returning 'Left' is always safe.
+--
+-- NB: This does *not* look through type synonyms. In fact, it treats type
+-- synonyms as rigid constructors. In the future, it might be convenient
+-- to look at only those arguments of type synonyms that actually appear
+-- in the synonym RHS. But we're not there yet.
+zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType)
+zonk_eq_types = go
+  where
+    go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2
+    go (TyVarTy tv1) ty2           = tyvar NotSwapped tv1 ty2
+    go ty1 (TyVarTy tv2)           = tyvar IsSwapped  tv2 ty1
+
+    -- We handle FunTys explicitly here despite the fact that they could also be
+    -- treated as an application. Why? Well, for one it's cheaper to just look
+    -- at two types (the argument and result types) than four (the argument,
+    -- result, and their RuntimeReps). Also, we haven't completely zonked yet,
+    -- so we may run into an unzonked type variable while trying to compute the
+    -- RuntimeReps of the argument and result types. This can be observed in
+    -- testcase tc269.
+    go ty1 ty2
+      | Just (arg1, res1) <- split1
+      , Just (arg2, res2) <- split2
+      = do { res_a <- go arg1 arg2
+           ; res_b <- go res1 res2
+           ; return $ combine_rev mkFunTy res_b res_a
+           }
+      | isJust split1 || isJust split2
+      = bale_out ty1 ty2
+      where
+        split1 = tcSplitFunTy_maybe ty1
+        split2 = tcSplitFunTy_maybe ty2
+
+    go ty1 ty2
+      | Just (tc1, tys1) <- tcRepSplitTyConApp_maybe ty1
+      , Just (tc2, tys2) <- tcRepSplitTyConApp_maybe ty2
+      = if tc1 == tc2 && tys1 `equalLength` tys2
+          -- Crucial to check for equal-length args, because
+          -- we cannot assume that the two args to 'go' have
+          -- the same kind.  E.g go (Proxy *      (Maybe Int))
+          --                        (Proxy (*->*) Maybe)
+          -- We'll call (go (Maybe Int) Maybe)
+          -- See Trac #13083
+        then tycon tc1 tys1 tys2
+        else bale_out ty1 ty2
+
+    go ty1 ty2
+      | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1
+      , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2
+      = do { res_a <- go ty1a ty2a
+           ; res_b <- go ty1b ty2b
+           ; return $ combine_rev mkAppTy res_b res_a }
+
+    go ty1@(LitTy lit1) (LitTy lit2)
+      | lit1 == lit2
+      = return (Right ty1)
+
+    go ty1 ty2 = bale_out ty1 ty2
+      -- We don't handle more complex forms here
+
+    bale_out ty1 ty2 = return $ Left (Pair ty1 ty2)
+
+    tyvar :: SwapFlag -> TcTyVar -> TcType
+          -> TcS (Either (Pair TcType) TcType)
+      -- Try to do as little as possible, as anything we do here is redundant
+      -- with flattening. In particular, no need to zonk kinds. That's why
+      -- we don't use the already-defined zonking functions
+    tyvar swapped tv ty
+      = case tcTyVarDetails tv of
+          MetaTv { mtv_ref = ref }
+            -> do { cts <- readTcRef ref
+                  ; case cts of
+                      Flexi        -> give_up
+                      Indirect ty' -> do { trace_indirect tv ty'
+                                         ; unSwap swapped go ty' ty } }
+          _ -> give_up
+      where
+        give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty
+
+    tyvar_tyvar tv1 tv2
+      | tv1 == tv2 = return (Right (mkTyVarTy tv1))
+      | otherwise  = do { (ty1', progress1) <- quick_zonk tv1
+                        ; (ty2', progress2) <- quick_zonk tv2
+                        ; if progress1 || progress2
+                          then go ty1' ty2'
+                          else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) }
+
+    trace_indirect tv ty
+       = traceTcS "Following filled tyvar (zonk_eq_types)"
+                  (ppr tv <+> equals <+> ppr ty)
+
+    quick_zonk tv = case tcTyVarDetails tv of
+      MetaTv { mtv_ref = ref }
+        -> do { cts <- readTcRef ref
+              ; case cts of
+                  Flexi        -> return (TyVarTy tv, False)
+                  Indirect ty' -> do { trace_indirect tv ty'
+                                     ; return (ty', True) } }
+      _ -> return (TyVarTy tv, False)
+
+      -- This happens for type families, too. But recall that failure
+      -- here just means to try harder, so it's OK if the type function
+      -- isn't injective.
+    tycon :: TyCon -> [TcType] -> [TcType]
+          -> TcS (Either (Pair TcType) TcType)
+    tycon tc tys1 tys2
+      = do { results <- zipWithM go tys1 tys2
+           ; return $ case combine_results results of
+               Left tys  -> Left (mkTyConApp tc <$> tys)
+               Right tys -> Right (mkTyConApp tc tys) }
+
+    combine_results :: [Either (Pair TcType) TcType]
+                    -> Either (Pair [TcType]) [TcType]
+    combine_results = bimap (fmap reverse) reverse .
+                      foldl' (combine_rev (:)) (Right [])
+
+      -- combine (in reverse) a new result onto an already-combined result
+    combine_rev :: (a -> b -> c)
+                -> Either (Pair b) b
+                -> Either (Pair a) a
+                -> Either (Pair c) c
+    combine_rev f (Left list) (Left elt) = Left (f <$> elt     <*> list)
+    combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list)
+    combine_rev f (Right tys) (Left elt) = Left (f <$> elt     <*> pure tys)
+    combine_rev f (Right tys) (Right ty) = Right (f ty tys)
+
+{- See Note [Unwrap newtypes first]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  newtype N m a = MkN (m a)
+Then N will get a conservative, Nominal role for its second parameter 'a',
+because it appears as an argument to the unknown 'm'. Now consider
+  [W] N Maybe a  ~R#  N Maybe b
+
+If we decompose, we'll get
+  [W] a ~N# b
+
+But if instead we unwrap we'll get
+  [W] Maybe a ~R# Maybe b
+which in turn gives us
+  [W] a ~R# b
+which is easier to satisfy.
+
+Bottom line: unwrap newtypes before decomposing them!
+c.f. Trac #9123 comment:52,53 for a compelling example.
+
+Note [Newtypes can blow the stack]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+  newtype X = MkX (Int -> X)
+  newtype Y = MkY (Int -> Y)
+
+and now wish to prove
+
+  [W] X ~R Y
+
+This Wanted will loop, expanding out the newtypes ever deeper looking
+for a solid match or a solid discrepancy. Indeed, there is something
+appropriate to this looping, because X and Y *do* have the same representation,
+in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized
+coercion will ever witness it. This loop won't actually cause GHC to hang,
+though, because we check our depth when unwrapping newtypes.
+
+Note [Eager reflexivity check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+  newtype X = MkX (Int -> X)
+
+and
+
+  [W] X ~R X
+
+Naively, we would start unwrapping X and end up in a loop. Instead,
+we do this eager reflexivity check. This is necessary only for representational
+equality because the flattener technology deals with the similar case
+(recursive type families) for nominal equality.
+
+Note that this check does not catch all cases, but it will catch the cases
+we're most worried about, types like X above that are actually inhabited.
+
+Here's another place where this reflexivity check is key:
+Consider trying to prove (f a) ~R (f a). The AppTys in there can't
+be decomposed, because representational equality isn't congruent with respect
+to AppTy. So, when canonicalising the equality above, we get stuck and
+would normally produce a CIrredCan. However, we really do want to
+be able to solve (f a) ~R (f a). So, in the representational case only,
+we do a reflexivity check.
+
+(This would be sound in the nominal case, but unnecessary, and I [Richard
+E.] am worried that it would slow down the common case.)
+-}
+
+------------------------
+-- | We're able to unwrap a newtype. Update the bits accordingly.
+can_eq_newtype_nc :: CtEvidence           -- ^ :: ty1 ~ ty2
+                  -> SwapFlag
+                  -> TcType                                    -- ^ ty1
+                  -> ((Bag GlobalRdrElt, TcCoercion), TcType)  -- ^ :: ty1 ~ ty1'
+                  -> TcType               -- ^ ty2
+                  -> TcType               -- ^ ty2, with type synonyms
+                  -> TcS (StopOrContinue Ct)
+can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2
+  = do { traceTcS "can_eq_newtype_nc" $
+         vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ]
+
+         -- check for blowing our stack:
+         -- See Note [Newtypes can blow the stack]
+       ; checkReductionDepth (ctEvLoc ev) ty1
+       ; addUsedGREs (bagToList gres)
+           -- we have actually used the newtype constructor here, so
+           -- make sure we don't warn about importing it!
+
+       ; new_ev <- rewriteEqEvidence ev swapped ty1' ps_ty2
+                                     (mkTcSymCo co) (mkTcReflCo Representational ps_ty2)
+       ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }
+
+---------
+-- ^ Decompose a type application.
+-- All input types must be flat. See Note [Canonicalising type applications]
+-- Nominal equality only!
+can_eq_app :: CtEvidence       -- :: s1 t1 ~N s2 t2
+           -> Xi -> Xi         -- s1 t1
+           -> Xi -> Xi         -- s2 t2
+           -> TcS (StopOrContinue Ct)
+
+-- AppTys only decompose for nominal equality, so this case just leads
+-- to an irreducible constraint; see typecheck/should_compile/T10494
+-- See Note [Decomposing equality], note {4}
+can_eq_app ev s1 t1 s2 t2
+  | CtDerived { ctev_loc = loc } <- ev
+  = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2]
+       ; stopWith ev "Decomposed [D] AppTy" }
+  | CtWanted { ctev_dest = dest, ctev_loc = loc } <- ev
+  = do { co_s <- unifyWanted loc Nominal s1 s2
+       ; let arg_loc
+               | isNextArgVisible s1 = loc
+               | otherwise           = updateCtLocOrigin loc toInvisibleOrigin
+       ; co_t <- unifyWanted arg_loc Nominal t1 t2
+       ; let co = mkAppCo co_s co_t
+       ; setWantedEq dest co
+       ; stopWith ev "Decomposed [W] AppTy" }
+
+    -- If there is a ForAll/(->) mismatch, the use of the Left coercion
+    -- below is ill-typed, potentially leading to a panic in splitTyConApp
+    -- Test case: typecheck/should_run/Typeable1
+    -- We could also include this mismatch check above (for W and D), but it's slow
+    -- and we'll get a better error message not doing it
+  | s1k `mismatches` s2k
+  = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2)
+
+  | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev
+  = do { let co   = mkTcCoVarCo evar
+             co_s = mkTcLRCo CLeft  co
+             co_t = mkTcLRCo CRight co
+       ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2
+                                     , evCoercion co_s )
+       ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2
+                                     , evCoercion co_t )
+       ; emitWorkNC [evar_t]
+       ; canEqNC evar_s NomEq s1 s2 }
+
+  where
+    s1k = tcTypeKind s1
+    s2k = tcTypeKind s2
+
+    k1 `mismatches` k2
+      =  isForAllTy k1 && not (isForAllTy k2)
+      || not (isForAllTy k1) && isForAllTy k2
+
+-----------------------
+-- | Break apart an equality over a casted type
+-- looking like   (ty1 |> co1) ~ ty2   (modulo a swap-flag)
+canEqCast :: Bool         -- are both types flat?
+          -> CtEvidence
+          -> EqRel
+          -> SwapFlag
+          -> TcType -> Coercion   -- LHS (res. RHS), ty1 |> co1
+          -> TcType -> TcType     -- RHS (res. LHS), ty2 both normal and pretty
+          -> TcS (StopOrContinue Ct)
+canEqCast flat ev eq_rel swapped ty1 co1 ty2 ps_ty2
+  = do { traceTcS "Decomposing cast" (vcat [ ppr ev
+                                           , ppr ty1 <+> text "|>" <+> ppr co1
+                                           , ppr ps_ty2 ])
+       ; new_ev <- rewriteEqEvidence ev swapped ty1 ps_ty2
+                                     (mkTcGReflRightCo role ty1 co1)
+                                     (mkTcReflCo role ps_ty2)
+       ; can_eq_nc flat new_ev eq_rel ty1 ty1 ty2 ps_ty2 }
+  where
+    role = eqRelRole eq_rel
+
+------------------------
+canTyConApp :: CtEvidence -> EqRel
+            -> TyCon -> [TcType]
+            -> TyCon -> [TcType]
+            -> TcS (StopOrContinue Ct)
+-- See Note [Decomposing TyConApps]
+canTyConApp ev eq_rel tc1 tys1 tc2 tys2
+  | tc1 == tc2
+  , tys1 `equalLength` tys2
+  = do { inerts <- getTcSInerts
+       ; if can_decompose inerts
+         then do { traceTcS "canTyConApp"
+                       (ppr ev $$ ppr eq_rel $$ ppr tc1 $$ ppr tys1 $$ ppr tys2)
+                 ; canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2
+                 ; stopWith ev "Decomposed TyConApp" }
+         else canEqFailure ev eq_rel ty1 ty2 }
+
+  -- See Note [Skolem abstract data] (at tyConSkolem)
+  | tyConSkolem tc1 || tyConSkolem tc2
+  = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2)
+       ; continueWith (mkIrredCt ev) }
+
+  -- Fail straight away for better error messages
+  -- See Note [Use canEqFailure in canDecomposableTyConApp]
+  | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational &&
+                             isGenerativeTyCon tc2 Representational)
+  = canEqFailure ev eq_rel ty1 ty2
+  | otherwise
+  = canEqHardFailure ev ty1 ty2
+  where
+    ty1 = mkTyConApp tc1 tys1
+    ty2 = mkTyConApp tc2 tys2
+
+    loc  = ctEvLoc ev
+    pred = ctEvPred ev
+
+     -- See Note [Decomposing equality]
+    can_decompose inerts
+      =  isInjectiveTyCon tc1 (eqRelRole eq_rel)
+      || (ctEvFlavour ev /= Given && isEmptyBag (matchableGivens loc pred inerts))
+
+{-
+Note [Use canEqFailure in canDecomposableTyConApp]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must use canEqFailure, not canEqHardFailure here, because there is
+the possibility of success if working with a representational equality.
+Here is one case:
+
+  type family TF a where TF Char = Bool
+  data family DF a
+  newtype instance DF Bool = MkDF Int
+
+Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet
+know `a`. This is *not* a hard failure, because we might soon learn
+that `a` is, in fact, Char, and then the equality succeeds.
+
+Here is another case:
+
+  [G] Age ~R Int
+
+where Age's constructor is not in scope. We don't want to report
+an "inaccessible code" error in the context of this Given!
+
+For example, see typecheck/should_compile/T10493, repeated here:
+
+  import Data.Ord (Down)  -- no constructor
+
+  foo :: Coercible (Down Int) Int => Down Int -> Int
+  foo = coerce
+
+That should compile, but only because we use canEqFailure and not
+canEqHardFailure.
+
+Note [Decomposing equality]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have a constraint (of any flavour and role) that looks like
+T tys1 ~ T tys2, what can we conclude about tys1 and tys2? The answer,
+of course, is "it depends". This Note spells it all out.
+
+In this Note, "decomposition" refers to taking the constraint
+  [fl] (T tys1 ~X T tys2)
+(for some flavour fl and some role X) and replacing it with
+  [fls'] (tys1 ~Xs' tys2)
+where that notation indicates a list of new constraints, where the
+new constraints may have different flavours and different roles.
+
+The key property to consider is injectivity. When decomposing a Given the
+decomposition is sound if and only if T is injective in all of its type
+arguments. When decomposing a Wanted, the decomposition is sound (assuming the
+correct roles in the produced equality constraints), but it may be a guess --
+that is, an unforced decision by the constraint solver. Decomposing Wanteds
+over injective TyCons does not entail guessing. But sometimes we want to
+decompose a Wanted even when the TyCon involved is not injective! (See below.)
+
+So, in broad strokes, we want this rule:
+
+(*) Decompose a constraint (T tys1 ~X T tys2) if and only if T is injective
+at role X.
+
+Pursuing the details requires exploring three axes:
+* Flavour: Given vs. Derived vs. Wanted
+* Role: Nominal vs. Representational
+* TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable
+
+(So a type variable isn't a TyCon, but it's convenient to put the AppTy case
+in the same table.)
+
+Right away, we can say that Derived behaves just as Wanted for the purposes
+of decomposition. The difference between Derived and Wanted is the handling of
+evidence. Since decomposition in these cases isn't a matter of soundness but of
+guessing, we want the same behavior regardless of evidence.
+
+Here is a table (discussion following) detailing where decomposition of
+   (T s1 ... sn) ~r (T t1 .. tn)
+is allowed.  The first four lines (Data types ... type family) refer
+to TyConApps with various TyCons T; the last line is for AppTy, where
+there is presumably a type variable at the head, so it's actually
+   (s s1 ... sn) ~r (t t1 .. tn)
+
+NOMINAL               GIVEN                       WANTED
+
+Datatype               YES                         YES
+Newtype                YES                         YES
+Data family            YES                         YES
+Type family            YES, in injective args{1}   YES, in injective args{1}
+Type variable          YES                         YES
+
+REPRESENTATIONAL      GIVEN                       WANTED
+
+Datatype               YES                         YES
+Newtype                NO{2}                      MAYBE{2}
+Data family            NO{3}                      MAYBE{3}
+Type family             NO                          NO
+Type variable          NO{4}                       NO{4}
+
+{1}: Type families can be injective in some, but not all, of their arguments,
+so we want to do partial decomposition. This is quite different than the way
+other decomposition is done, where the decomposed equalities replace the original
+one. We thus proceed much like we do with superclasses: emitting new Givens
+when "decomposing" a partially-injective type family Given and new Deriveds
+when "decomposing" a partially-injective type family Wanted. (As of the time of
+writing, 13 June 2015, the implementation of injective type families has not
+been merged, but it should be soon. Please delete this parenthetical if the
+implementation is indeed merged.)
+
+{2}: See Note [Decomposing newtypes at representational role]
+
+{3}: Because of the possibility of newtype instances, we must treat
+data families like newtypes. See also Note [Decomposing newtypes at
+representational role]. See #10534 and test case
+typecheck/should_fail/T10534.
+
+{4}: Because type variables can stand in for newtypes, we conservatively do not
+decompose AppTys over representational equality.
+
+In the implementation of can_eq_nc and friends, we don't directly pattern
+match using lines like in the tables above, as those tables don't cover
+all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity,
+boiling the tables above down to rule (*). The exceptions to rule (*) are for
+injective type families, which are handled separately from other decompositions,
+and the MAYBE entries above.
+
+Note [Decomposing newtypes at representational role]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This note discusses the 'newtype' line in the REPRESENTATIONAL table
+in Note [Decomposing equality]. (At nominal role, newtypes are fully
+decomposable.)
+
+Here is a representative example of why representational equality over
+newtypes is tricky:
+
+  newtype Nt a = Mk Bool         -- NB: a is not used in the RHS,
+  type role Nt representational  -- but the user gives it an R role anyway
+
+If we have [W] Nt alpha ~R Nt beta, we *don't* want to decompose to
+[W] alpha ~R beta, because it's possible that alpha and beta aren't
+representationally equal. Here's another example.
+
+  newtype Nt a = MkNt (Id a)
+  type family Id a where Id a = a
+
+  [W] Nt Int ~R Nt Age
+
+Because of its use of a type family, Nt's parameter will get inferred to have
+a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age, which
+is unsatisfiable. Unwrapping, though, leads to a solution.
+
+Conclusion:
+ * Unwrap newtypes before attempting to decompose them.
+   This is done in can_eq_nc'.
+
+It all comes from the fact that newtypes aren't necessarily injective
+w.r.t. representational equality.
+
+Furthermore, as explained in Note [NthCo and newtypes] in TyCoRep, we can't use
+NthCo on representational coercions over newtypes. NthCo comes into play
+only when decomposing givens.
+
+Conclusion:
+ * Do not decompose [G] N s ~R N t
+
+Is it sensible to decompose *Wanted* constraints over newtypes?  Yes!
+It's the only way we could ever prove (IO Int ~R IO Age), recalling
+that IO is a newtype.
+
+However we must be careful.  Consider
+
+  type role Nt representational
+
+  [G] Nt a ~R Nt b       (1)
+  [W] NT alpha ~R Nt b   (2)
+  [W] alpha ~ a          (3)
+
+If we focus on (3) first, we'll substitute in (2), and now it's
+identical to the given (1), so we succeed.  But if we focus on (2)
+first, and decompose it, we'll get (alpha ~R b), which is not soluble.
+This is exactly like the question of overlapping Givens for class
+constraints: see Note [Instance and Given overlap] in TcInteract.
+
+Conclusion:
+  * Decompose [W] N s ~R N t  iff there no given constraint that could
+    later solve it.
+-}
+
+canDecomposableTyConAppOK :: CtEvidence -> EqRel
+                          -> TyCon -> [TcType] -> [TcType]
+                          -> TcS ()
+-- Precondition: tys1 and tys2 are the same length, hence "OK"
+canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
+  = ASSERT( tys1 `equalLength` tys2 )
+    case ev of
+     CtDerived {}
+        -> unifyDeriveds loc tc_roles tys1 tys2
+
+     CtWanted { ctev_dest = dest }
+                   -- new_locs and tc_roles are both infinite, so
+                   -- we are guaranteed that cos has the same length
+                   -- as tys1 and tys2
+        -> do { cos <- zipWith4M unifyWanted new_locs tc_roles tys1 tys2
+              ; setWantedEq dest (mkTyConAppCo role tc cos) }
+
+     CtGiven { ctev_evar = evar }
+        -> do { let ev_co = mkCoVarCo evar
+              ; given_evs <- newGivenEvVars loc $
+                             [ ( mkPrimEqPredRole r ty1 ty2
+                               , evCoercion $ mkNthCo r i ev_co )
+                             | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..]
+                             , r /= Phantom
+                             , not (isCoercionTy ty1) && not (isCoercionTy ty2) ]
+              ; emitWorkNC given_evs }
+  where
+    loc        = ctEvLoc ev
+    role       = eqRelRole eq_rel
+
+      -- infinite, as tyConRolesX returns an infinite tail of Nominal
+    tc_roles   = tyConRolesX role tc
+
+      -- Add nuances to the location during decomposition:
+      --  * if the argument is a kind argument, remember this, so that error
+      --    messages say "kind", not "type". This is determined based on whether
+      --    the corresponding tyConBinder is named (that is, dependent)
+      --  * if the argument is invisible, note this as well, again by
+      --    looking at the corresponding binder
+      -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't
+      -- do either of these changes. (Forgetting to do so led to #16188)
+      --
+      -- NB: infinite in length
+    new_locs = [ new_loc
+               | bndr <- tyConBinders tc
+               , let new_loc0 | isNamedTyConBinder bndr = toKindLoc loc
+                              | otherwise               = loc
+                     new_loc  | isVisibleTyConBinder bndr
+                              = updateCtLocOrigin new_loc0 toInvisibleOrigin
+                              | otherwise
+                              = new_loc0 ]
+               ++ repeat loc
+
+-- | Call when canonicalizing an equality fails, but if the equality is
+-- representational, there is some hope for the future.
+-- Examples in Note [Use canEqFailure in canDecomposableTyConApp]
+canEqFailure :: CtEvidence -> EqRel
+             -> TcType -> TcType -> TcS (StopOrContinue Ct)
+canEqFailure ev NomEq ty1 ty2
+  = canEqHardFailure ev ty1 ty2
+canEqFailure ev ReprEq ty1 ty2
+  = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1
+       ; (xi2, co2) <- flatten FM_FlattenAll ev ty2
+            -- We must flatten the types before putting them in the
+            -- inert set, so that we are sure to kick them out when
+            -- new equalities become available
+       ; traceTcS "canEqFailure with ReprEq" $
+         vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ]
+       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2
+       ; continueWith (mkIrredCt new_ev) }
+
+-- | Call when canonicalizing an equality fails with utterly no hope.
+canEqHardFailure :: CtEvidence
+                 -> TcType -> TcType -> TcS (StopOrContinue Ct)
+-- See Note [Make sure that insolubles are fully rewritten]
+canEqHardFailure ev ty1 ty2
+  = do { (s1, co1) <- flatten FM_SubstOnly ev ty1
+       ; (s2, co2) <- flatten FM_SubstOnly ev ty2
+       ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2
+       ; continueWith (mkInsolubleCt new_ev) }
+
+{-
+Note [Decomposing TyConApps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see (T s1 t1 ~ T s2 t2), then we can just decompose to
+  (s1 ~ s2, t1 ~ t2)
+and push those back into the work list.  But if
+  s1 = K k1    s2 = K k2
+then we will just decomopose s1~s2, and it might be better to
+do so on the spot.  An important special case is where s1=s2,
+and we get just Refl.
+
+So canDecomposableTyCon is a fast-path decomposition that uses
+unifyWanted etc to short-cut that work.
+
+Note [Canonicalising type applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given (s1 t1) ~ ty2, how should we proceed?
+The simple things is to see if ty2 is of form (s2 t2), and
+decompose.  By this time s1 and s2 can't be saturated type
+function applications, because those have been dealt with
+by an earlier equation in can_eq_nc, so it is always sound to
+decompose.
+
+However, over-eager decomposition gives bad error messages
+for things like
+   a b ~ Maybe c
+   e f ~ p -> q
+Suppose (in the first example) we already know a~Array.  Then if we
+decompose the application eagerly, yielding
+   a ~ Maybe
+   b ~ c
+we get an error        "Can't match Array ~ Maybe",
+but we'd prefer to get "Can't match Array b ~ Maybe c".
+
+So instead can_eq_wanted_app flattens the LHS and RHS, in the hope of
+replacing (a b) by (Array b), before using try_decompose_app to
+decompose it.
+
+Note [Make sure that insolubles are fully rewritten]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When an equality fails, we still want to rewrite the equality
+all the way down, so that it accurately reflects
+ (a) the mutable reference substitution in force at start of solving
+ (b) any ty-binds in force at this point in solving
+See Note [Rewrite insolubles] in TcSMonad.
+And if we don't do this there is a bad danger that
+TcSimplify.applyTyVarDefaulting will find a variable
+that has in fact been substituted.
+
+Note [Do not decompose Given polytype equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider [G] (forall a. t1 ~ forall a. t2).  Can we decompose this?
+No -- what would the evidence look like?  So instead we simply discard
+this given evidence.
+
+
+Note [Combining insoluble constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As this point we have an insoluble constraint, like Int~Bool.
+
+ * If it is Wanted, delete it from the cache, so that subsequent
+   Int~Bool constraints give rise to separate error messages
+
+ * But if it is Derived, DO NOT delete from cache.  A class constraint
+   may get kicked out of the inert set, and then have its functional
+   dependency Derived constraints generated a second time. In that
+   case we don't want to get two (or more) error messages by
+   generating two (or more) insoluble fundep constraints from the same
+   class constraint.
+
+Note [No top-level newtypes on RHS of representational equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we're in this situation:
+
+ work item:  [W] c1 : a ~R b
+     inert:  [G] c2 : b ~R Id a
+
+where
+  newtype Id a = Id a
+
+We want to make sure canEqTyVar sees [W] a ~R a, after b is flattened
+and the Id newtype is unwrapped. This is assured by requiring only flat
+types in canEqTyVar *and* having the newtype-unwrapping check above
+the tyvar check in can_eq_nc.
+
+Note [Occurs check error]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have an occurs check error, are we necessarily hosed? Say our
+tyvar is tv1 and the type it appears in is xi2. Because xi2 is function
+free, then if we're computing w.r.t. nominal equality, then, yes, we're
+hosed. Nothing good can come from (a ~ [a]). If we're computing w.r.t.
+representational equality, this is a little subtler. Once again, (a ~R [a])
+is a bad thing, but (a ~R N a) for a newtype N might be just fine. This
+means also that (a ~ b a) might be fine, because `b` might become a newtype.
+
+So, we must check: does tv1 appear in xi2 under any type constructor
+that is generative w.r.t. representational equality? That's what
+isInsolubleOccursCheck does.
+
+See also #10715, which induced this addition.
+
+Note [canCFunEqCan]
+~~~~~~~~~~~~~~~~~~~
+Flattening the arguments to a type family can change the kind of the type
+family application. As an easy example, consider (Any k) where (k ~ Type)
+is in the inert set. The original (Any k :: k) becomes (Any Type :: Type).
+The problem here is that the fsk in the CFunEqCan will have the old kind.
+
+The solution is to come up with a new fsk/fmv of the right kind. For
+givens, this is easy: just introduce a new fsk and update the flat-cache
+with the new one. For wanteds, we want to solve the old one if favor of
+the new one, so we use dischargeFmv. This also kicks out constraints
+from the inert set; this behavior is correct, as the kind-change may
+allow more constraints to be solved.
+
+We use `isTcReflexiveCo`, to ensure that we only use the hetero-kinded case
+if we really need to.  Of course `flattenArgsNom` should return `Refl`
+whenever possible, but Trac #15577 was an infinite loop because even
+though the coercion was homo-kinded, `kind_co` was not `Refl`, so we
+made a new (identical) CFunEqCan, and then the entire process repeated.
+-}
+
+canCFunEqCan :: CtEvidence
+             -> TyCon -> [TcType]   -- LHS
+             -> TcTyVar             -- RHS
+             -> TcS (StopOrContinue Ct)
+-- ^ Canonicalise a CFunEqCan.  We know that
+--     the arg types are already flat,
+-- and the RHS is a fsk, which we must *not* substitute.
+-- So just substitute in the LHS
+canCFunEqCan ev fn tys fsk
+  = do { (tys', cos, kind_co) <- flattenArgsNom ev fn tys
+                        -- cos :: tys' ~ tys
+
+       ; let lhs_co  = mkTcTyConAppCo Nominal fn cos
+                        -- :: F tys' ~ F tys
+             new_lhs = mkTyConApp fn tys'
+
+             flav    = ctEvFlavour ev
+       ; (ev', fsk')
+           <- if isTcReflexiveCo kind_co   -- See Note [canCFunEqCan]
+              then do { traceTcS "canCFunEqCan: refl" (ppr new_lhs)
+                      ; let fsk_ty = mkTyVarTy fsk
+                      ; ev' <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty
+                                                 lhs_co (mkTcNomReflCo fsk_ty)
+                      ; return (ev', fsk) }
+              else do { traceTcS "canCFunEqCan: non-refl" $
+                        vcat [ text "Kind co:" <+> ppr kind_co
+                             , text "RHS:" <+> ppr fsk <+> dcolon <+> ppr (tyVarKind fsk)
+                             , text "LHS:" <+> hang (ppr (mkTyConApp fn tys))
+                                                  2 (dcolon <+> ppr (tcTypeKind (mkTyConApp fn tys)))
+                             , text "New LHS" <+> hang (ppr new_lhs)
+                                                     2 (dcolon <+> ppr (tcTypeKind new_lhs)) ]
+                      ; (ev', new_co, new_fsk)
+                          <- newFlattenSkolem flav (ctEvLoc ev) fn tys'
+                      ; let xi = mkTyVarTy new_fsk `mkCastTy` kind_co
+                               -- sym lhs_co :: F tys ~ F tys'
+                               -- new_co     :: F tys' ~ new_fsk
+                               -- co         :: F tys ~ (new_fsk |> kind_co)
+                            co = mkTcSymCo lhs_co `mkTcTransCo`
+                                 mkTcCoherenceRightCo Nominal
+                                                      (mkTyVarTy new_fsk)
+                                                      kind_co
+                                                      new_co
+
+                      ; traceTcS "Discharging fmv/fsk due to hetero flattening" (ppr ev)
+                      ; dischargeFunEq ev fsk co xi
+                      ; return (ev', new_fsk) }
+
+       ; extendFlatCache fn tys' (ctEvCoercion ev', mkTyVarTy fsk', ctEvFlavour ev')
+       ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn
+                                 , cc_tyargs = tys', cc_fsk = fsk' }) }
+
+---------------------
+canEqTyVar :: CtEvidence          -- ev :: lhs ~ rhs
+           -> EqRel -> SwapFlag
+           -> TcTyVar               -- tv1
+           -> TcType                -- lhs: pretty lhs, already flat
+           -> TcType -> TcType      -- rhs: already flat
+           -> TcS (StopOrContinue Ct)
+canEqTyVar ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
+  | k1 `tcEqType` k2
+  = canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2
+
+         -- Note [Flattening] in TcFlatten gives us (F2), which says that
+         -- flattening is always homogeneous (doesn't change kinds). But
+         -- perhaps by flattening the kinds of the two sides of the equality
+         -- at hand makes them equal. So let's try that.
+  | otherwise
+  = do { (flat_k1, k1_co) <- flattenKind loc flav k1  -- k1_co :: flat_k1 ~N kind(xi1)
+       ; (flat_k2, k2_co) <- flattenKind loc flav k2  -- k2_co :: flat_k2 ~N kind(xi2)
+       ; traceTcS "canEqTyVar tried flattening kinds"
+                  (vcat [ sep [ parens (ppr tv1 <+> dcolon <+> ppr k1)
+                              , text "~"
+                              , parens (ppr xi2 <+> dcolon <+> ppr k2) ]
+                        , ppr flat_k1
+                        , ppr k1_co
+                        , ppr flat_k2
+                        , ppr k2_co ])
+
+         -- we know the LHS is a tyvar. So let's dump all the coercions on the RHS
+         -- If flat_k1 == flat_k2, let's dump all the coercions on the RHS and
+         -- then call canEqTyVarHomo. If they don't equal, just rewriteEqEvidence
+         -- (as an optimization, so that we don't have to flatten the kinds again)
+         -- and then emit a kind equality in canEqTyVarHetero.
+         -- See Note [Equalities with incompatible kinds]
+
+       ; let role = eqRelRole eq_rel
+       ; if flat_k1 `tcEqType` flat_k2
+         then do { let rhs_kind_co = mkTcSymCo k2_co `mkTcTransCo` k1_co
+                         -- :: kind(xi2) ~N kind(xi1)
+
+                       new_rhs     = xi2 `mkCastTy` rhs_kind_co
+                       ps_rhs      = ps_xi2 `mkCastTy` rhs_kind_co
+                       rhs_co      = mkTcGReflLeftCo role xi2 rhs_kind_co
+
+                 ; new_ev <- rewriteEqEvidence ev swapped xi1 new_rhs
+                                               (mkTcReflCo role xi1) rhs_co
+                       -- NB: rewriteEqEvidence executes a swap, if any, so we're
+                       -- NotSwapped now.
+                 ; canEqTyVarHomo new_ev eq_rel NotSwapped tv1 ps_ty1 new_rhs ps_rhs }
+         else
+    do { let sym_k1_co = mkTcSymCo k1_co  -- :: kind(xi1) ~N flat_k1
+             sym_k2_co = mkTcSymCo k2_co  -- :: kind(xi2) ~N flat_k2
+
+             new_lhs = xi1 `mkCastTy` sym_k1_co  -- :: flat_k1
+             new_rhs = xi2 `mkCastTy` sym_k2_co  -- :: flat_k2
+             ps_rhs  = ps_xi2 `mkCastTy` sym_k2_co
+
+             lhs_co = mkTcGReflLeftCo role xi1 sym_k1_co
+             rhs_co = mkTcGReflLeftCo role xi2 sym_k2_co
+               -- lhs_co :: (xi1 |> sym k1_co) ~ xi1
+               -- rhs_co :: (xi2 |> sym k2_co) ~ xi2
+
+       ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co
+         -- no longer swapped, due to rewriteEqEvidence
+       ; canEqTyVarHetero new_ev eq_rel tv1 sym_k1_co flat_k1 ps_ty1
+                                        new_rhs flat_k2 ps_rhs } }
+  where
+    xi1 = mkTyVarTy tv1
+
+    k1 = tyVarKind tv1
+    k2 = tcTypeKind xi2
+
+    loc  = ctEvLoc ev
+    flav = ctEvFlavour ev
+
+canEqTyVarHetero :: CtEvidence   -- :: (tv1 |> co1 :: ki1) ~ (xi2 :: ki2)
+                 -> EqRel
+                 -> TcTyVar -> TcCoercionN -> TcKind  -- tv1 |> co1 :: ki1
+                 -> TcType            -- pretty tv1 (*without* the coercion)
+                 -> TcType -> TcKind  -- xi2 :: ki2
+                 -> TcType            -- pretty xi2
+                 -> TcS (StopOrContinue Ct)
+canEqTyVarHetero ev eq_rel tv1 co1 ki1 ps_tv1 xi2 ki2 ps_xi2
+  -- See Note [Equalities with incompatible kinds]
+  | CtGiven { ctev_evar = evar } <- ev
+    -- unswapped: tm :: (lhs :: ki1) ~ (rhs :: ki2)
+    -- swapped  : tm :: (rhs :: ki2) ~ (lhs :: ki1)
+  = do { let kind_co = mkTcKindCo (mkTcCoVarCo evar)
+       ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)
+       ; let  -- kind_ev :: (ki1 :: *) ~ (ki2 :: *)   (whether swapped or not)
+              -- co1     :: kind(tv1) ~N ki1
+              -- homo_co :: ki2 ~N kind(tv1)
+             homo_co = mkTcSymCo (ctEvCoercion kind_ev) `mkTcTransCo` mkTcSymCo co1
+             rhs'    = mkCastTy xi2 homo_co     -- :: kind(tv1)
+             ps_rhs' = mkCastTy ps_xi2 homo_co  -- :: kind(tv1)
+             rhs_co  = mkTcGReflLeftCo role xi2 homo_co
+               -- rhs_co :: (xi2 |> homo_co :: kind(tv1)) ~ xi2
+
+             lhs'   = mkTyVarTy tv1       -- :: kind(tv1)
+             lhs_co = mkTcGReflRightCo role lhs' co1
+               -- lhs_co :: (tv1 :: kind(tv1)) ~ (tv1 |> co1 :: ki1)
+
+       ; traceTcS "Hetero equality gives rise to given kind equality"
+           (ppr kind_ev <+> dcolon <+> ppr kind_pty)
+       ; emitWorkNC [kind_ev]
+       ; type_ev <- rewriteEqEvidence ev NotSwapped lhs' rhs' lhs_co rhs_co
+       ; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' }
+
+  -- See Note [Equalities with incompatible kinds]
+  | otherwise   -- Wanted and Derived
+                  -- NB: all kind equalities are Nominal
+  = do { emitNewDerivedEq kind_loc Nominal ki1 ki2
+             -- kind_ev :: (ki1 :: *) ~ (ki2 :: *)
+       ; traceTcS "Hetero equality gives rise to derived kind equality" $
+           ppr ev
+       ; continueWith (mkIrredCt ev) }
+
+  where
+    kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki1 ki2
+    kind_loc = mkKindLoc (mkTyVarTy tv1 `mkCastTy` co1) xi2 loc
+
+    loc  = ctev_loc ev
+    role = eqRelRole eq_rel
+
+-- guaranteed that tcTypeKind lhs == tcTypeKind rhs
+canEqTyVarHomo :: CtEvidence
+               -> EqRel -> SwapFlag
+               -> TcTyVar                -- lhs: tv1
+               -> TcType                 -- pretty lhs
+               -> TcType -> TcType       -- rhs (might not be flat)
+               -> TcS (StopOrContinue Ct)
+canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 ty2 _
+  | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2
+  , tv1 == tv2
+  = canEqReflexive ev eq_rel (mkTyVarTy tv1)
+    -- we don't need to check co because it must be reflexive
+
+  | Just (tv2, co2) <- tcGetCastedTyVar_maybe ty2
+  , swapOverTyVars tv1 tv2
+  = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)
+         -- FM_Avoid commented out: see Note [Lazy flattening] in TcFlatten
+         -- let fmode = FE { fe_ev = ev, fe_mode = FM_Avoid tv1' True }
+         -- Flatten the RHS less vigorously, to avoid gratuitous flattening
+         -- True <=> xi2 should not itself be a type-function application
+
+       ; let role    = eqRelRole eq_rel
+             sym_co2 = mkTcSymCo co2
+             ty1     = mkTyVarTy tv1
+             new_lhs = ty1 `mkCastTy` sym_co2
+             lhs_co  = mkTcGReflLeftCo role ty1 sym_co2
+
+             new_rhs = mkTyVarTy tv2
+             rhs_co  = mkTcGReflRightCo role new_rhs co2
+
+       ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co
+
+       ; dflags <- getDynFlags
+       ; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_ty1 `mkCastTy` sym_co2) }
+
+canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_ty2
+  = do { dflags <- getDynFlags
+       ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_ty2 }
+
+-- The RHS here is either not a casted tyvar, or it's a tyvar but we want
+-- to rewrite the LHS to the RHS (as per swapOverTyVars)
+canEqTyVar2 :: DynFlags
+            -> CtEvidence   -- lhs ~ rhs (or, if swapped, orhs ~ olhs)
+            -> EqRel
+            -> SwapFlag
+            -> TcTyVar                  -- lhs = tv, flat
+            -> TcType                   -- rhs
+            -> TcS (StopOrContinue Ct)
+-- LHS is an inert type variable,
+-- and RHS is fully rewritten, but with type synonyms
+-- preserved as much as possible
+canEqTyVar2 dflags ev eq_rel swapped tv1 rhs
+  | Just rhs' <- metaTyVarUpdateOK dflags tv1 rhs  -- No occurs check
+     -- Must do the occurs check even on tyvar/tyvar
+     -- equalities, in case have  x ~ (y :: ..x...)
+     -- Trac #12593
+  = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2
+       ; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1
+                                , cc_rhs = rhs', cc_eq_rel = eq_rel }) }
+
+  | otherwise  -- For some reason (occurs check, or forall) we can't unify
+               -- We must not use it for further rewriting!
+  = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs)
+       ; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2
+       ; if isInsolubleOccursCheck eq_rel tv1 rhs
+         then continueWith (mkInsolubleCt new_ev)
+             -- If we have a ~ [a], it is not canonical, and in particular
+             -- we don't want to rewrite existing inerts with it, otherwise
+             -- we'd risk divergence in the constraint solver
+
+         else continueWith (mkIrredCt new_ev) }
+             -- A representational equality with an occurs-check problem isn't
+             -- insoluble! For example:
+             --   a ~R b a
+             -- We might learn that b is the newtype Id.
+             -- But, the occurs-check certainly prevents the equality from being
+             -- canonical, and we might loop if we were to use it in rewriting.
+  where
+    role = eqRelRole eq_rel
+
+    lhs = mkTyVarTy tv1
+
+    rewrite_co1  = mkTcReflCo role lhs
+    rewrite_co2  = mkTcReflCo role rhs
+
+-- | Solve a reflexive equality constraint
+canEqReflexive :: CtEvidence    -- ty ~ ty
+               -> EqRel
+               -> TcType        -- ty
+               -> TcS (StopOrContinue Ct)   -- always Stop
+canEqReflexive ev eq_rel ty
+  = do { setEvBindIfWanted ev (evCoercion $
+                               mkTcReflCo (eqRelRole eq_rel) ty)
+       ; stopWith ev "Solved by reflexivity" }
+
+{-
+Note [Canonical orientation for tyvar/tyvar equality constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we have a ~ b where both 'a' and 'b' are TcTyVars, which way
+round should be oriented in the CTyEqCan?  The rules, implemented by
+canEqTyVarTyVar, are these
+
+ * If either is a flatten-meta-variables, it goes on the left.
+
+ * Put a meta-tyvar on the left if possible
+       alpha[3] ~ r
+
+ * If both are meta-tyvars, put the more touchable one (deepest level
+   number) on the left, so there is the best chance of unifying it
+        alpha[3] ~ beta[2]
+
+ * If both are meta-tyvars and both at the same level, put a TyVarTv
+   on the right if possible
+        alpha[2] ~ beta[2](sig-tv)
+   That way, when we unify alpha := beta, we don't lose the TyVarTv flag.
+
+ * Put a meta-tv with a System Name on the left if possible so it
+   gets eliminated (improves error messages)
+
+ * If one is a flatten-skolem, put it on the left so that it is
+   substituted out  Note [Eliminate flat-skols] in TcUinfy
+        fsk ~ a
+
+Note [Equalities with incompatible kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What do we do when we have an equality
+
+  (tv :: k1) ~ (rhs :: k2)
+
+where k1 and k2 differ? This Note explores this treacherous area.
+
+First off, the question above is slightly the wrong question. Flattening
+a tyvar will flatten its kind (Note [Flattening] in TcFlatten); flattening
+the kind might introduce a cast. So we might have a casted tyvar on the
+left. We thus revise our test case to
+
+  (tv |> co :: k1) ~ (rhs :: k2)
+
+We must proceed differently here depending on whether we have a Wanted
+or a Given. Consider this:
+
+ [W] w :: (alpha :: k) ~ (Int :: Type)
+
+where k is a skolem. One possible way forward is this:
+
+ [W] co :: k ~ Type
+ [W] w :: (alpha :: k) ~ (Int |> sym co :: k)
+
+The next step will be to unify
+
+  alpha := Int |> sym co
+
+Now, consider what error we'll report if we can't solve the "co"
+wanted. Its CtOrigin is the w wanted... which now reads (after zonking)
+Int ~ Int. The user thus sees that GHC can't solve Int ~ Int, which
+is embarrassing. See #11198 for more tales of destruction.
+
+The reason for this odd behavior is much the same as
+Note [Wanteds do not rewrite Wanteds] in TcRnTypes: note that the
+new `co` is a Wanted.
+
+   The solution is then not to use `co` to "rewrite" -- that is, cast
+   -- `w`, but instead to keep `w` heterogeneous and
+   irreducible. Given that we're not using `co`, there is no reason to
+   collect evidence for it, so `co` is born a Derived, with a CtOrigin
+   of KindEqOrigin.
+
+When the Derived is solved (by unification), the original wanted (`w`)
+will get kicked out.
+
+Note that, if we had [G] co1 :: k ~ Type available, then none of this code would
+trigger, because flattening would have rewritten k to Type. That is,
+`w` would look like [W] (alpha |> co1 :: Type) ~ (Int :: Type), and the tyvar
+case will trigger, correctly rewriting alpha to (Int |> sym co1).
+
+Successive canonicalizations of the same Wanted may produce
+duplicate Deriveds. Similar duplications can happen with fundeps, and there
+seems to be no easy way to avoid. I expect this case to be rare.
+
+For Givens, this problem doesn't bite, so a heterogeneous Given gives
+rise to a Given kind equality. No Deriveds here. We thus homogenise
+the Given (see the "homo_co" in the Given case in canEqTyVar) and
+carry on with a homogeneous equality constraint.
+
+Separately, I (Richard E) spent some time pondering what to do in the case
+that we have [W] (tv |> co1 :: k1) ~ (tv |> co2 :: k2) where k1 and k2
+differ. Note that the tv is the same. (This case is handled as the first
+case in canEqTyVarHomo.) At one point, I thought we could solve this limited
+form of heterogeneous Wanted, but I then reconsidered and now treat this case
+just like any other heterogeneous Wanted.
+
+Note [Type synonyms and canonicalization]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We treat type synonym applications as xi types, that is, they do not
+count as type function applications.  However, we do need to be a bit
+careful with type synonyms: like type functions they may not be
+generative or injective.  However, unlike type functions, they are
+parametric, so there is no problem in expanding them whenever we see
+them, since we do not need to know anything about their arguments in
+order to expand them; this is what justifies not having to treat them
+as specially as type function applications.  The thing that causes
+some subtleties is that we prefer to leave type synonym applications
+*unexpanded* whenever possible, in order to generate better error
+messages.
+
+If we encounter an equality constraint with type synonym applications
+on both sides, or a type synonym application on one side and some sort
+of type application on the other, we simply must expand out the type
+synonyms in order to continue decomposing the equality constraint into
+primitive equality constraints.  For example, suppose we have
+
+  type F a = [Int]
+
+and we encounter the equality
+
+  F a ~ [b]
+
+In order to continue we must expand F a into [Int], giving us the
+equality
+
+  [Int] ~ [b]
+
+which we can then decompose into the more primitive equality
+constraint
+
+  Int ~ b.
+
+However, if we encounter an equality constraint with a type synonym
+application on one side and a variable on the other side, we should
+NOT (necessarily) expand the type synonym, since for the purpose of
+good error messages we want to leave type synonyms unexpanded as much
+as possible.  Hence the ps_ty1, ps_ty2 argument passed to canEqTyVar.
+
+-}
+
+{-
+************************************************************************
+*                                                                      *
+                  Evidence transformation
+*                                                                      *
+************************************************************************
+-}
+
+data StopOrContinue a
+  = ContinueWith a    -- The constraint was not solved, although it may have
+                      --   been rewritten
+
+  | Stop CtEvidence   -- The (rewritten) constraint was solved
+         SDoc         -- Tells how it was solved
+                      -- Any new sub-goals have been put on the work list
+
+instance Functor StopOrContinue where
+  fmap f (ContinueWith x) = ContinueWith (f x)
+  fmap _ (Stop ev s)      = Stop ev s
+
+instance Outputable a => Outputable (StopOrContinue a) where
+  ppr (Stop ev s)      = text "Stop" <> parens s <+> ppr ev
+  ppr (ContinueWith w) = text "ContinueWith" <+> ppr w
+
+continueWith :: a -> TcS (StopOrContinue a)
+continueWith = return . ContinueWith
+
+stopWith :: CtEvidence -> String -> TcS (StopOrContinue a)
+stopWith ev s = return (Stop ev (text s))
+
+andWhenContinue :: TcS (StopOrContinue a)
+                -> (a -> TcS (StopOrContinue b))
+                -> TcS (StopOrContinue b)
+andWhenContinue tcs1 tcs2
+  = do { r <- tcs1
+       ; case r of
+           Stop ev s       -> return (Stop ev s)
+           ContinueWith ct -> tcs2 ct }
+infixr 0 `andWhenContinue`    -- allow chaining with ($)
+
+rewriteEvidence :: CtEvidence   -- old evidence
+                -> TcPredType   -- new predicate
+                -> TcCoercion   -- Of type :: new predicate ~ <type of old evidence>
+                -> TcS (StopOrContinue CtEvidence)
+-- Returns Just new_ev iff either (i)  'co' is reflexivity
+--                             or (ii) 'co' is not reflexivity, and 'new_pred' not cached
+-- In either case, there is nothing new to do with new_ev
+{-
+     rewriteEvidence old_ev new_pred co
+Main purpose: create new evidence for new_pred;
+              unless new_pred is cached already
+* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev
+* If old_ev was wanted, create a binding for old_ev, in terms of new_ev
+* If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev
+* Returns Nothing if new_ev is already cached
+
+        Old evidence    New predicate is               Return new evidence
+        flavour                                        of same flavor
+        -------------------------------------------------------------------
+        Wanted          Already solved or in inert     Nothing
+        or Derived      Not                            Just new_evidence
+
+        Given           Already in inert               Nothing
+                        Not                            Just new_evidence
+
+Note [Rewriting with Refl]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the coercion is just reflexivity then you may re-use the same
+variable.  But be careful!  Although the coercion is Refl, new_pred
+may reflect the result of unification alpha := ty, so new_pred might
+not _look_ the same as old_pred, and it's vital to proceed from now on
+using new_pred.
+
+qThe flattener preserves type synonyms, so they should appear in new_pred
+as well as in old_pred; that is important for good error messages.
+ -}
+
+
+rewriteEvidence old_ev@(CtDerived {}) new_pred _co
+  = -- If derived, don't even look at the coercion.
+    -- This is very important, DO NOT re-order the equations for
+    -- rewriteEvidence to put the isTcReflCo test first!
+    -- Why?  Because for *Derived* constraints, c, the coercion, which
+    -- was produced by flattening, may contain suspended calls to
+    -- (ctEvExpr c), which fails for Derived constraints.
+    -- (Getting this wrong caused Trac #7384.)
+    continueWith (old_ev { ctev_pred = new_pred })
+
+rewriteEvidence old_ev new_pred co
+  | isTcReflCo co -- See Note [Rewriting with Refl]
+  = continueWith (old_ev { ctev_pred = new_pred })
+
+rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co
+  = do { new_ev <- newGivenEvVar loc (new_pred, new_tm)
+       ; continueWith new_ev }
+  where
+    -- mkEvCast optimises ReflCo
+    new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational
+                                                       (ctEvRole ev)
+                                                       (mkTcSymCo co))
+
+rewriteEvidence ev@(CtWanted { ctev_dest = dest
+                             , ctev_loc = loc }) new_pred co
+  = do { mb_new_ev <- newWanted loc new_pred
+       ; MASSERT( tcCoercionRole co == ctEvRole ev )
+       ; setWantedEvTerm dest
+            (mkEvCast (getEvExpr mb_new_ev)
+                      (tcDowngradeRole Representational (ctEvRole ev) co))
+       ; case mb_new_ev of
+            Fresh  new_ev -> continueWith new_ev
+            Cached _      -> stopWith ev "Cached wanted" }
+
+
+rewriteEqEvidence :: CtEvidence         -- Old evidence :: olhs ~ orhs (not swapped)
+                                        --              or orhs ~ olhs (swapped)
+                  -> SwapFlag
+                  -> TcType -> TcType   -- New predicate  nlhs ~ nrhs
+                                        -- Should be zonked, because we use tcTypeKind on nlhs/nrhs
+                  -> TcCoercion         -- lhs_co, of type :: nlhs ~ olhs
+                  -> TcCoercion         -- rhs_co, of type :: nrhs ~ orhs
+                  -> TcS CtEvidence     -- Of type nlhs ~ nrhs
+-- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co)
+-- we generate
+-- If not swapped
+--      g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co
+-- If 'swapped'
+--      g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co
+--
+-- For (Wanted w) we do the dual thing.
+-- New  w1 : nlhs ~ nrhs
+-- If not swapped
+--      w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co
+-- If swapped
+--      w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co
+--
+-- It's all a form of rewwriteEvidence, specialised for equalities
+rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co
+  | CtDerived {} <- old_ev  -- Don't force the evidence for a Derived
+  = return (old_ev { ctev_pred = new_pred })
+
+  | NotSwapped <- swapped
+  , isTcReflCo lhs_co      -- See Note [Rewriting with Refl]
+  , isTcReflCo rhs_co
+  = return (old_ev { ctev_pred = new_pred })
+
+  | CtGiven { ctev_evar = old_evar } <- old_ev
+  = do { let new_tm = evCoercion (lhs_co
+                                  `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar)
+                                  `mkTcTransCo` mkTcSymCo rhs_co)
+       ; newGivenEvVar loc' (new_pred, new_tm) }
+
+  | CtWanted { ctev_dest = dest } <- old_ev
+  = do { (new_ev, hole_co) <- newWantedEq loc' (ctEvRole old_ev) nlhs nrhs
+       ; let co = maybeSym swapped $
+                  mkSymCo lhs_co
+                  `mkTransCo` hole_co
+                  `mkTransCo` rhs_co
+       ; setWantedEq dest co
+       ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])
+       ; return new_ev }
+
+  | otherwise
+  = panic "rewriteEvidence"
+  where
+    new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs
+
+      -- equality is like a type class. Bumping the depth is necessary because
+      -- of recursive newtypes, where "reducing" a newtype can actually make
+      -- it bigger. See Note [Newtypes can blow the stack].
+    loc      = ctEvLoc old_ev
+    loc'     = bumpCtLocDepth loc
+
+{- Note [unifyWanted and unifyDerived]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When decomposing equalities we often create new wanted constraints for
+(s ~ t).  But what if s=t?  Then it'd be faster to return Refl right away.
+Similar remarks apply for Derived.
+
+Rather than making an equality test (which traverses the structure of the
+type, perhaps fruitlessly), unifyWanted traverses the common structure, and
+bales out when it finds a difference by creating a new Wanted constraint.
+But where it succeeds in finding common structure, it just builds a coercion
+to reflect it.
+-}
+
+unifyWanted :: CtLoc -> Role
+            -> TcType -> TcType -> TcS Coercion
+-- Return coercion witnessing the equality of the two types,
+-- emitting new work equalities where necessary to achieve that
+-- Very good short-cut when the two types are equal, or nearly so
+-- See Note [unifyWanted and unifyDerived]
+-- The returned coercion's role matches the input parameter
+unifyWanted loc Phantom ty1 ty2
+  = do { kind_co <- unifyWanted loc Nominal (tcTypeKind ty1) (tcTypeKind ty2)
+       ; return (mkPhantomCo kind_co ty1 ty2) }
+
+unifyWanted loc role orig_ty1 orig_ty2
+  = go orig_ty1 orig_ty2
+  where
+    go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2
+    go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'
+
+    go (FunTy s1 t1) (FunTy s2 t2)
+      = do { co_s <- unifyWanted loc role s1 s2
+           ; co_t <- unifyWanted loc role t1 t2
+           ; return (mkFunCo role co_s co_t) }
+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+      | tc1 == tc2, tys1 `equalLength` tys2
+      , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality
+      = do { cos <- zipWith3M (unifyWanted loc)
+                              (tyConRolesX role tc1) tys1 tys2
+           ; return (mkTyConAppCo role tc1 cos) }
+
+    go ty1@(TyVarTy tv) ty2
+      = do { mb_ty <- isFilledMetaTyVar_maybe tv
+           ; case mb_ty of
+                Just ty1' -> go ty1' ty2
+                Nothing   -> bale_out ty1 ty2}
+    go ty1 ty2@(TyVarTy tv)
+      = do { mb_ty <- isFilledMetaTyVar_maybe tv
+           ; case mb_ty of
+                Just ty2' -> go ty1 ty2'
+                Nothing   -> bale_out ty1 ty2 }
+
+    go ty1@(CoercionTy {}) (CoercionTy {})
+      = return (mkReflCo role ty1) -- we just don't care about coercions!
+
+    go ty1 ty2 = bale_out ty1 ty2
+
+    bale_out ty1 ty2
+       | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1)
+        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)
+       | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2
+
+unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS ()
+-- See Note [unifyWanted and unifyDerived]
+unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2
+
+unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS ()
+-- See Note [unifyWanted and unifyDerived]
+unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2
+
+unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS ()
+-- Create new Derived and put it in the work list
+-- Should do nothing if the two types are equal
+-- See Note [unifyWanted and unifyDerived]
+unify_derived _   Phantom _        _        = return ()
+unify_derived loc role    orig_ty1 orig_ty2
+  = go orig_ty1 orig_ty2
+  where
+    go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2
+    go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'
+
+    go (FunTy s1 t1) (FunTy s2 t2)
+      = do { unify_derived loc role s1 s2
+           ; unify_derived loc role t1 t2 }
+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+      | tc1 == tc2, tys1 `equalLength` tys2
+      , isInjectiveTyCon tc1 role
+      = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2
+    go ty1@(TyVarTy tv) ty2
+      = do { mb_ty <- isFilledMetaTyVar_maybe tv
+           ; case mb_ty of
+                Just ty1' -> go ty1' ty2
+                Nothing   -> bale_out ty1 ty2 }
+    go ty1 ty2@(TyVarTy tv)
+      = do { mb_ty <- isFilledMetaTyVar_maybe tv
+           ; case mb_ty of
+                Just ty2' -> go ty1 ty2'
+                Nothing   -> bale_out ty1 ty2 }
+    go ty1 ty2 = bale_out ty1 ty2
+
+    bale_out ty1 ty2
+       | ty1 `tcEqType` ty2 = return ()
+        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)
+       | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2
+
+maybeSym :: SwapFlag -> TcCoercion -> TcCoercion
+maybeSym IsSwapped  co = mkTcSymCo co
+maybeSym NotSwapped co = co
diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcClassDcl.hs
@@ -0,0 +1,551 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Typechecking class declarations
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcClassDcl ( tcClassSigs, tcClassDecl2,
+                    findMethodBind, instantiateMethod,
+                    tcClassMinimalDef,
+                    HsSigFun, mkHsSigFun,
+                    tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr,
+                    instDeclCtxt1, instDeclCtxt2, instDeclCtxt3,
+                    tcATDefault
+                  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import TcEnv
+import TcSigs
+import TcEvidence ( idHsWrapper )
+import TcBinds
+import TcUnify
+import TcHsType
+import TcMType
+import Type     ( getClassPredTys_maybe, piResultTys )
+import TcType
+import TcRnMonad
+import DriverPhases (HscSource(..))
+import BuildTyCl( TcMethInfo )
+import Class
+import Coercion ( pprCoAxiom )
+import DynFlags
+import FamInst
+import FamInstEnv
+import Id
+import Name
+import NameEnv
+import NameSet
+import Var
+import VarEnv
+import Outputable
+import SrcLoc
+import TyCon
+import Maybes
+import BasicTypes
+import Bag
+import FastString
+import BooleanFormula
+import Util
+
+import Control.Monad
+import Data.List ( mapAccumL, partition )
+
+{-
+Dictionary handling
+~~~~~~~~~~~~~~~~~~~
+Every class implicitly declares a new data type, corresponding to dictionaries
+of that class. So, for example:
+
+        class (D a) => C a where
+          op1 :: a -> a
+          op2 :: forall b. Ord b => a -> b -> b
+
+would implicitly declare
+
+        data CDict a = CDict (D a)
+                             (a -> a)
+                             (forall b. Ord b => a -> b -> b)
+
+(We could use a record decl, but that means changing more of the existing apparatus.
+One step at at time!)
+
+For classes with just one superclass+method, we use a newtype decl instead:
+
+        class C a where
+          op :: forallb. a -> b -> b
+
+generates
+
+        newtype CDict a = CDict (forall b. a -> b -> b)
+
+Now DictTy in Type is just a form of type synomym:
+        DictTy c t = TyConTy CDict `AppTy` t
+
+Death to "ExpandingDicts".
+
+
+************************************************************************
+*                                                                      *
+                Type-checking the class op signatures
+*                                                                      *
+************************************************************************
+-}
+
+illegalHsigDefaultMethod :: Name -> SDoc
+illegalHsigDefaultMethod n =
+    text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file"
+
+tcClassSigs :: Name                -- Name of the class
+            -> [LSig GhcRn]
+            -> LHsBinds GhcRn
+            -> TcM [TcMethInfo]    -- Exactly one for each method
+tcClassSigs clas sigs def_methods
+  = do { traceTc "tcClassSigs 1" (ppr clas)
+
+       ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
+       ; let gen_dm_env :: NameEnv (SrcSpan, Type)
+             gen_dm_env = mkNameEnv gen_dm_prs
+
+       ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
+
+       ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
+       ; sequence_ [ failWithTc (badMethodErr clas n)
+                   | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
+                   -- Value binding for non class-method (ie no TypeSig)
+
+       ; tcg_env <- getGblEnv
+       ; if tcg_src tcg_env == HsigFile
+            then
+               -- Error if we have value bindings
+               -- (Generic signatures without value bindings indicate
+               -- that a default of this form is expected to be
+               -- provided.)
+               when (not (null def_methods)) $
+                failWithTc (illegalHsigDefaultMethod clas)
+            else
+               -- Error for each generic signature without value binding
+               sequence_ [ failWithTc (badGenericMethod clas n)
+                         | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
+
+       ; traceTc "tcClassSigs 2" (ppr clas)
+       ; return op_info }
+  where
+    vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs]
+    gen_sigs     = [L loc (nm,ty) | L loc (ClassOpSig _ True  nm ty) <- sigs]
+    dm_bind_names :: [Name] -- These ones have a value binding in the class decl
+    dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
+
+    skol_info = TyConSkol ClassFlavour clas
+
+    tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn)
+           -> TcM [TcMethInfo]
+    tc_sig gen_dm_env (op_names, op_hs_ty)
+      = do { traceTc "ClsSig 1" (ppr op_names)
+           ; op_ty <- tcClassSigType skol_info op_names op_hs_ty
+                   -- Class tyvars already in scope
+
+           ; traceTc "ClsSig 2" (ppr op_names)
+           ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }
+           where
+             f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty)
+                  | nm `elem` dm_bind_names                 = Just VanillaDM
+                  | otherwise                               = Nothing
+
+    tc_gen_sig (op_names, gen_hs_ty)
+      = do { gen_op_ty <- tcClassSigType skol_info op_names gen_hs_ty
+           ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] }
+
+{-
+************************************************************************
+*                                                                      *
+                Class Declarations
+*                                                                      *
+************************************************************************
+-}
+
+tcClassDecl2 :: LTyClDecl GhcRn          -- The class declaration
+             -> TcM (LHsBinds GhcTcId)
+
+tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
+                                tcdMeths = default_binds}))
+  = recoverM (return emptyLHsBinds)     $
+    setSrcSpan (getLoc class_name)      $
+    do  { clas <- tcLookupLocatedClass class_name
+
+        -- We make a separate binding for each default method.
+        -- At one time I used a single AbsBinds for all of them, thus
+        -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
+        -- But that desugars into
+        --      ds = \d -> (..., ..., ...)
+        --      dm1 = \d -> case ds d of (a,b,c) -> a
+        -- And since ds is big, it doesn't get inlined, so we don't get good
+        -- default methods.  Better to make separate AbsBinds for each
+        ; let (tyvars, _, _, op_items) = classBigSig clas
+              prag_fn     = mkPragEnv sigs default_binds
+              sig_fn      = mkHsSigFun sigs
+              clas_tyvars = snd (tcSuperSkolTyVars tyvars)
+              pred        = mkClassPred clas (mkTyVarTys clas_tyvars)
+        ; this_dict <- newEvVar pred
+
+        ; let tc_item = tcDefMeth clas clas_tyvars this_dict
+                                  default_binds sig_fn prag_fn
+        ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
+                      mapM tc_item op_items
+
+        ; return (unionManyBags dm_binds) }
+
+tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
+
+tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn
+          -> HsSigFun -> TcPragEnv -> ClassOpItem
+          -> TcM (LHsBinds GhcTcId)
+-- Generate code for default methods
+-- This is incompatible with Hugs, which expects a polymorphic
+-- default method for every class op, regardless of whether or not
+-- the programmer supplied an explicit default decl for the class.
+-- (If necessary we can fix that, but we don't have a convenient Id to hand.)
+
+tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)
+  = do { -- No default method
+         mapM_ (addLocM (badDmPrag sel_id))
+               (lookupPragEnv prag_fn (idName sel_id))
+       ; return emptyBag }
+
+tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
+          (sel_id, Just (dm_name, dm_spec))
+  | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn
+  = do { -- First look up the default method; it should be there!
+         -- It can be the orinary default method
+         -- or the generic-default method.  E.g of the latter
+         --      class C a where
+         --        op :: a -> a -> Bool
+         --        default op :: Eq a => a -> a -> Bool
+         --        op x y = x==y
+         -- The default method we generate is
+         --    $gm :: (C a, Eq a) => a -> a -> Bool
+         --    $gm x y = x==y
+
+         global_dm_id  <- tcLookupId dm_name
+       ; global_dm_id  <- addInlinePrags global_dm_id prags
+       ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc
+            -- Base the local_dm_name on the selector name, because
+            -- type errors from tcInstanceMethodBody come from here
+
+       ; spec_prags <- discardConstraints $
+                       tcSpecPrags global_dm_id prags
+       ; warnTc NoReason
+                (not (null spec_prags))
+                (text "Ignoring SPECIALISE pragmas on default method"
+                 <+> quotes (ppr sel_name))
+
+       ; let hs_ty = hs_sig_fn sel_name
+                     `orElse` pprPanic "tc_dm" (ppr sel_name)
+             -- We need the HsType so that we can bring the right
+             -- type variables into scope
+             --
+             -- Eg.   class C a where
+             --          op :: forall b. Eq b => a -> [b] -> a
+             --          gen_op :: a -> a
+             --          generic gen_op :: D a => a -> a
+             -- The "local_dm_ty" is precisely the type in the above
+             -- type signatures, ie with no "forall a. C a =>" prefix
+
+             local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)
+
+             lm_bind     = dm_bind { fun_id = L bind_loc local_dm_name }
+                             -- Substitute the local_meth_name for the binder
+                             -- NB: the binding is always a FunBind
+
+             warn_redundant = case dm_spec of
+                                GenericDM {} -> True
+                                VanillaDM    -> False
+                -- For GenericDM, warn if the user specifies a signature
+                -- with redundant constraints; but not for VanillaDM, where
+                -- the default method may well be 'error' or something
+
+             ctxt = FunSigCtxt sel_name warn_redundant
+
+       ; let local_dm_id = mkLocalId local_dm_name local_dm_ty
+             local_dm_sig = CompleteSig { sig_bndr = local_dm_id
+                                        , sig_ctxt  = ctxt
+                                        , sig_loc   = getLoc (hsSigType hs_ty) }
+
+       ; (ev_binds, (tc_bind, _))
+               <- checkConstraints (TyConSkol ClassFlavour (getName clas)) tyvars [this_dict] $
+                  tcPolyCheck no_prag_fn local_dm_sig
+                              (L bind_loc lm_bind)
+
+       ; let export = ABE { abe_ext   = noExt
+                          , abe_poly  = global_dm_id
+                          , abe_mono  = local_dm_id
+                          , abe_wrap  = idHsWrapper
+                          , abe_prags = IsDefaultMethod }
+             full_bind = AbsBinds { abs_ext      = noExt
+                                  , abs_tvs      = tyvars
+                                  , abs_ev_vars  = [this_dict]
+                                  , abs_exports  = [export]
+                                  , abs_ev_binds = [ev_binds]
+                                  , abs_binds    = tc_bind
+                                  , abs_sig      = True }
+
+       ; return (unitBag (L bind_loc full_bind)) }
+
+  | otherwise = pprPanic "tcDefMeth" (ppr sel_id)
+  where
+    sel_name = idName sel_id
+    no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;
+                                -- they are all for meth_id
+
+---------------
+tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef
+tcClassMinimalDef _clas sigs op_info
+  = case findMinimalDef sigs of
+      Nothing -> return defMindef
+      Just mindef -> do
+        -- Warn if the given mindef does not imply the default one
+        -- That is, the given mindef should at least ensure that the
+        -- class ops without default methods are required, since we
+        -- have no way to fill them in otherwise
+        tcg_env <- getGblEnv
+        -- However, only do this test when it's not an hsig file,
+        -- since you can't write a default implementation.
+        when (tcg_src tcg_env /= HsigFile) $
+            whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
+                       (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf))
+        return mindef
+  where
+    -- By default require all methods without a default implementation
+    defMindef :: ClassMinimalDef
+    defMindef = mkAnd [ noLoc (mkVar name)
+                      | (name, _, Nothing) <- op_info ]
+
+instantiateMethod :: Class -> TcId -> [TcType] -> TcType
+-- Take a class operation, say
+--      op :: forall ab. C a => forall c. Ix c => (b,c) -> a
+-- Instantiate it at [ty1,ty2]
+-- Return the "local method type":
+--      forall c. Ix x => (ty2,c) -> ty1
+instantiateMethod clas sel_id inst_tys
+  = ASSERT( ok_first_pred ) local_meth_ty
+  where
+    rho_ty = piResultTys (idType sel_id) inst_tys
+    (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
+                `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
+
+    ok_first_pred = case getClassPredTys_maybe first_pred of
+                      Just (clas1, _tys) -> clas == clas1
+                      Nothing -> False
+              -- The first predicate should be of form (C a b)
+              -- where C is the class in question
+
+
+---------------------------
+type HsSigFun = Name -> Maybe (LHsSigType GhcRn)
+
+mkHsSigFun :: [LSig GhcRn] -> HsSigFun
+mkHsSigFun sigs = lookupNameEnv env
+  where
+    env = mkHsSigEnv get_classop_sig sigs
+
+    get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn)
+    get_classop_sig  (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty)
+    get_classop_sig  _                               = Nothing
+
+---------------------------
+findMethodBind  :: Name                 -- Selector
+                -> LHsBinds GhcRn       -- A group of bindings
+                -> TcPragEnv
+                -> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn])
+                -- Returns the binding, the binding
+                -- site of the method binder, and any inline or
+                -- specialisation pragmas
+findMethodBind sel_name binds prag_fn
+  = foldlBag mplus Nothing (mapBag f binds)
+  where
+    prags    = lookupPragEnv prag_fn sel_name
+
+    f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
+      | op_name == sel_name
+             = Just (bind, bndr_loc, prags)
+    f _other = Nothing
+
+---------------------------
+findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
+findMinimalDef = firstJusts . map toMinimalDef
+  where
+    toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
+    toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf)
+    toMinimalDef _                               = Nothing
+
+{-
+Note [Polymorphic methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+    class Foo a where
+        op :: forall b. Ord b => a -> b -> b -> b
+    instance Foo c => Foo [c] where
+        op = e
+
+When typechecking the binding 'op = e', we'll have a meth_id for op
+whose type is
+      op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
+
+So tcPolyBinds must be capable of dealing with nested polytypes;
+and so it is. See TcBinds.tcMonoBinds (with type-sig case).
+
+Note [Silly default-method bind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we pass the default method binding to the type checker, it must
+look like    op2 = e
+not          $dmop2 = e
+otherwise the "$dm" stuff comes out error messages.  But we want the
+"$dm" to come out in the interface file.  So we typecheck the former,
+and wrap it in a let, thus
+          $dmop2 = let op2 = e in op2
+This makes the error messages right.
+
+
+************************************************************************
+*                                                                      *
+                Error messages
+*                                                                      *
+************************************************************************
+-}
+
+tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc
+tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl,
+                      text "declaration for", quotes (ppr (tcdName decl))]
+
+tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a
+tcAddDeclCtxt decl thing_inside
+  = addErrCtxt (tcMkDeclCtxt decl) thing_inside
+
+badMethodErr :: Outputable a => a -> Name -> SDoc
+badMethodErr clas op
+  = hsep [text "Class", quotes (ppr clas),
+          text "does not have a method", quotes (ppr op)]
+
+badGenericMethod :: Outputable a => a -> Name -> SDoc
+badGenericMethod clas op
+  = hsep [text "Class", quotes (ppr clas),
+          text "has a generic-default signature without a binding", quotes (ppr op)]
+
+{-
+badGenericInstanceType :: LHsBinds Name -> SDoc
+badGenericInstanceType binds
+  = vcat [text "Illegal type pattern in the generic bindings",
+          nest 2 (ppr binds)]
+
+missingGenericInstances :: [Name] -> SDoc
+missingGenericInstances missing
+  = text "Missing type patterns for" <+> pprQuotedList missing
+
+dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
+dupGenericInsts tc_inst_infos
+  = vcat [text "More than one type pattern for a single generic type constructor:",
+          nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
+          text "All the type patterns for a generic type constructor must be identical"
+    ]
+  where
+    ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
+-}
+badDmPrag :: TcId -> Sig GhcRn -> TcM ()
+badDmPrag sel_id prag
+  = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method")
+              <+> quotes (ppr sel_id)
+              <+> text "lacks an accompanying binding")
+
+warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
+warningMinimalDefIncomplete mindef
+  = vcat [ text "The MINIMAL pragma does not require:"
+         , nest 2 (pprBooleanFormulaNice mindef)
+         , text "but there is no default implementation." ]
+
+instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
+instDeclCtxt1 hs_inst_ty
+  = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
+
+instDeclCtxt2 :: Type -> SDoc
+instDeclCtxt2 dfun_ty
+  = instDeclCtxt3 cls tys
+  where
+    (_,_,cls,tys) = tcSplitDFunTy dfun_ty
+
+instDeclCtxt3 :: Class -> [Type] -> SDoc
+instDeclCtxt3 cls cls_tys
+  = inst_decl_ctxt (ppr (mkClassPred cls cls_tys))
+
+inst_decl_ctxt :: SDoc -> SDoc
+inst_decl_ctxt doc = hang (text "In the instance declaration for")
+                        2 (quotes doc)
+
+tcATDefault :: SrcSpan
+            -> TCvSubst
+            -> NameSet
+            -> ClassATItem
+            -> TcM [FamInst]
+-- ^ Construct default instances for any associated types that
+-- aren't given a user definition
+-- Returns [] or singleton
+tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)
+  -- User supplied instances ==> everything is OK
+  | tyConName fam_tc `elemNameSet` defined_ats
+  = return []
+
+  -- No user instance, have defaults ==> instantiate them
+   -- Example:   class C a where { type F a b :: *; type F a b = () }
+   --            instance C [x]
+   -- Then we want to generate the decl:   type F [x] b = ()
+  | Just (rhs_ty, _loc) <- defs
+  = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst
+                                            (tyConTyVars fam_tc)
+             rhs'     = substTyUnchecked subst' rhs_ty
+             tcv' = tyCoVarsOfTypesList pat_tys'
+             (tv', cv') = partition isTyVar tcv'
+             tvs'     = scopedSort tv'
+             cvs'     = scopedSort cv'
+       ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys'
+       ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs'
+                                     fam_tc pat_tys' rhs'
+           -- NB: no validity check. We check validity of default instances
+           -- in the class definition. Because type instance arguments cannot
+           -- be type family applications and cannot be polytypes, the
+           -- validity check is redundant.
+
+       ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty
+                                              , pprCoAxiom axiom ])
+       ; fam_inst <- newFamInst SynFamilyInst axiom
+       ; return [fam_inst] }
+
+   -- No defaults ==> generate a warning
+  | otherwise  -- defs = Nothing
+  = do { warnMissingAT (tyConName fam_tc)
+       ; return [] }
+  where
+    subst_tv subst tc_tv
+      | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
+      = (subst, ty)
+      | otherwise
+      = (extendTvSubst subst tc_tv ty', ty')
+      where
+        ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv)
+
+warnMissingAT :: Name -> TcM ()
+warnMissingAT name
+  = do { warn <- woptM Opt_WarnMissingMethods
+       ; traceTc "warn" (ppr name <+> ppr warn)
+       ; hsc_src <- fmap tcg_src getGblEnv
+       -- Warn only if -Wmissing-methods AND not a signature
+       ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile)
+                (text "No explicit" <+> text "associated type"
+                    <+> text "or default declaration for"
+                    <+> quotes (ppr name)) }
diff --git a/compiler/typecheck/TcDefaults.hs b/compiler/typecheck/TcDefaults.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcDefaults.hs
@@ -0,0 +1,110 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+\section[TcDefaults]{Typechecking \tr{default} declarations}
+-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcDefaults ( tcDefaults ) where
+
+import GhcPrelude
+
+import HsSyn
+import Class
+import TcRnMonad
+import TcEnv
+import TcHsType
+import TcHsSyn
+import TcSimplify
+import TcValidity
+import TcType
+import PrelNames
+import SrcLoc
+import Outputable
+import FastString
+import qualified GHC.LanguageExtensions as LangExt
+
+tcDefaults :: [LDefaultDecl GhcRn]
+           -> TcM (Maybe [Type])    -- Defaulting types to heave
+                                    -- into Tc monad for later use
+                                    -- in Disambig.
+
+tcDefaults []
+  = getDeclaredDefaultTys       -- No default declaration, so get the
+                                -- default types from the envt;
+                                -- i.e. use the current ones
+                                -- (the caller will put them back there)
+        -- It's important not to return defaultDefaultTys here (which
+        -- we used to do) because in a TH program, tcDefaults [] is called
+        -- repeatedly, once for each group of declarations between top-level
+        -- splices.  We don't want to carefully set the default types in
+        -- one group, only for the next group to ignore them and install
+        -- defaultDefaultTys
+
+tcDefaults [L _ (DefaultDecl _ [])]
+  = return (Just [])            -- Default declaration specifying no types
+
+tcDefaults [L locn (DefaultDecl _ mono_tys)]
+  = setSrcSpan locn                     $
+    addErrCtxt defaultDeclCtxt          $
+    do  { ovl_str   <- xoptM LangExt.OverloadedStrings
+        ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules
+        ; num_class    <- tcLookupClass numClassName
+        ; deflt_str <- if ovl_str
+                       then mapM tcLookupClass [isStringClassName]
+                       else return []
+        ; deflt_interactive <- if ext_deflt
+                               then mapM tcLookupClass interactiveClassNames
+                               else return []
+        ; let deflt_clss = num_class : deflt_str ++ deflt_interactive
+
+        ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys
+
+        ; return (Just tau_tys) }
+
+tcDefaults decls@(L locn (DefaultDecl _ _) : _)
+  = setSrcSpan locn $
+    failWithTc (dupDefaultDeclErr decls)
+tcDefaults (L _ (XDefaultDecl _):_) = panic "tcDefaults"
+
+
+tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type
+tc_default_ty deflt_clss hs_ty
+ = do   { (ty, _kind) <- solveEqualities $
+                         tcLHsType hs_ty
+        ; ty <- zonkTcTypeToType ty   -- establish Type invariants
+        ; checkValidType DefaultDeclCtxt ty
+
+        -- Check that the type is an instance of at least one of the deflt_clss
+        ; oks <- mapM (check_instance ty) deflt_clss
+        ; checkTc (or oks) (badDefaultTy ty deflt_clss)
+        ; return ty }
+
+check_instance :: Type -> Class -> TcM Bool
+  -- Check that ty is an instance of cls
+  -- We only care about whether it worked or not; return a boolean
+check_instance ty cls
+  = do  { (_, success) <- discardErrs $
+                          askNoErrs $
+                          simplifyDefault [mkClassPred cls [ty]]
+        ; return success }
+
+defaultDeclCtxt :: SDoc
+defaultDeclCtxt = text "When checking the types in a default declaration"
+
+dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc
+dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things)
+  = hang (text "Multiple default declarations")
+       2 (vcat (map pp dup_things))
+  where
+    pp (L locn (DefaultDecl _ _))
+      = text "here was another default declaration" <+> ppr locn
+    pp (L _ (XDefaultDecl _)) = panic "dupDefaultDeclErr"
+dupDefaultDeclErr (L _ (XDefaultDecl _) : _) = panic "dupDefaultDeclErr"
+dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"
+
+badDefaultTy :: Type -> [Class] -> SDoc
+badDefaultTy ty deflt_clss
+  = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))
+       2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss))
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcDeriv.hs
@@ -0,0 +1,2241 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Handles @deriving@ clauses on @data@ declarations.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import DynFlags
+
+import TcRnMonad
+import FamInst
+import TcDerivInfer
+import TcDerivUtils
+import TcValidity( allDistinctTyVars )
+import TcClassDcl( instDeclCtxt3, tcATDefault, tcMkDeclCtxt )
+import TcEnv
+import TcGenDeriv                       -- Deriv stuff
+import TcValidity( checkValidInstHead )
+import InstEnv
+import Inst
+import FamInstEnv
+import TcHsType
+import TyCoRep
+
+import RnNames( extendGlobalRdrEnvRn )
+import RnBinds
+import RnEnv
+import RnUtils    ( bindLocalNamesFV )
+import RnSource   ( addTcgDUs )
+import Avail
+
+import Unify( tcUnifyTy )
+import Class
+import Type
+import ErrUtils
+import DataCon
+import Maybes
+import RdrName
+import Name
+import NameSet
+import TyCon
+import TcType
+import Var
+import VarEnv
+import VarSet
+import PrelNames
+import SrcLoc
+import Util
+import Outputable
+import FastString
+import Bag
+import Pair
+import FV (fvVarList, unionFV, mkFVs)
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Reader
+import Data.List
+
+{-
+************************************************************************
+*                                                                      *
+                Overview
+*                                                                      *
+************************************************************************
+
+Overall plan
+~~~~~~~~~~~~
+1.  Convert the decls (i.e. data/newtype deriving clauses,
+    plus standalone deriving) to [EarlyDerivSpec]
+
+2.  Infer the missing contexts for the InferTheta's
+
+3.  Add the derived bindings, generating InstInfos
+-}
+
+data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])
+                    | GivenTheta (DerivSpec ThetaType)
+        -- InferTheta ds => the context for the instance should be inferred
+        --      In this case ds_theta is the list of all the sets of
+        --      constraints needed, such as (Eq [a], Eq a), together with a
+        --      suitable CtLoc to get good error messages.
+        --      The inference process is to reduce this to a
+        --      simpler form (e.g. Eq a)
+        --
+        -- GivenTheta ds => the exact context for the instance is supplied
+        --                  by the programmer; it is ds_theta
+        -- See Note [Inferring the instance context] in TcDerivInfer
+
+earlyDSLoc :: EarlyDerivSpec -> SrcSpan
+earlyDSLoc (InferTheta spec) = ds_loc spec
+earlyDSLoc (GivenTheta spec) = ds_loc spec
+
+splitEarlyDerivSpec :: [EarlyDerivSpec]
+                    -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])
+splitEarlyDerivSpec [] = ([],[])
+splitEarlyDerivSpec (InferTheta spec : specs) =
+    case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)
+splitEarlyDerivSpec (GivenTheta spec : specs) =
+    case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)
+
+instance Outputable EarlyDerivSpec where
+  ppr (InferTheta spec) = ppr spec <+> text "(Infer)"
+  ppr (GivenTheta spec) = ppr spec <+> text "(Given)"
+
+{-
+Note [Data decl contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
+
+We will need an instance decl like:
+
+        instance (Read a, RealFloat a) => Read (Complex a) where
+          ...
+
+The RealFloat in the context is because the read method for Complex is bound
+to construct a Complex, and doing that requires that the argument type is
+in RealFloat.
+
+But this ain't true for Show, Eq, Ord, etc, since they don't construct
+a Complex; they only take them apart.
+
+Our approach: identify the offending classes, and add the data type
+context to the instance decl.  The "offending classes" are
+
+        Read, Enum?
+
+FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that
+pattern matching against a constructor from a data type with a context
+gives rise to the constraints for that context -- or at least the thinned
+version.  So now all classes are "offending".
+
+Note [Newtype deriving]
+~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+    class C a b
+    instance C [a] Char
+    newtype T = T Char deriving( C [a] )
+
+Notice the free 'a' in the deriving.  We have to fill this out to
+    newtype T = T Char deriving( forall a. C [a] )
+
+And then translate it to:
+    instance C [a] Char => C [a] T where ...
+
+
+Note [Newtype deriving superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(See also Trac #1220 for an interesting exchange on newtype
+deriving and superclasses.)
+
+The 'tys' here come from the partial application in the deriving
+clause. The last arg is the new instance type.
+
+We must pass the superclasses; the newtype might be an instance
+of them in a different way than the representation type
+E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )
+Then the Show instance is not done via Coercible; it shows
+        Foo 3 as "Foo 3"
+The Num instance is derived via Coercible, but the Show superclass
+dictionary must the Show instance for Foo, *not* the Show dictionary
+gotten from the Num dictionary. So we must build a whole new dictionary
+not just use the Num one.  The instance we want is something like:
+     instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
+        (+) = ((+)@a)
+        ...etc...
+There may be a coercion needed which we get from the tycon for the newtype
+when the dict is constructed in TcInstDcls.tcInstDecl2
+
+
+Note [Unused constructors and deriving clauses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Trac #3221.  Consider
+   data T = T1 | T2 deriving( Show )
+Are T1 and T2 unused?  Well, no: the deriving clause expands to mention
+both of them.  So we gather defs/uses from deriving just like anything else.
+
+-}
+
+-- | Stuff needed to process a datatype's `deriving` clauses
+data DerivInfo = DerivInfo { di_rep_tc  :: TyCon
+                             -- ^ The data tycon for normal datatypes,
+                             -- or the *representation* tycon for data families
+                           , di_clauses :: [LHsDerivingClause GhcRn]
+                           , di_ctxt    :: SDoc -- ^ error context
+                           }
+
+-- | Extract `deriving` clauses of proper data type (skips data families)
+mkDerivInfos :: [LTyClDecl GhcRn] -> TcM [DerivInfo]
+mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls
+  where
+
+    mk_deriv decl@(DataDecl { tcdLName = L _ data_name
+                            , tcdDataDefn =
+                                HsDataDefn { dd_derivs = L _ clauses } })
+      = do { tycon <- tcLookupTyCon data_name
+           ; return [DerivInfo { di_rep_tc = tycon, di_clauses = clauses
+                               , di_ctxt = tcMkDeclCtxt decl }] }
+    mk_deriv _ = return []
+
+{-
+
+************************************************************************
+*                                                                      *
+\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
+*                                                                      *
+************************************************************************
+-}
+
+tcDeriving  :: [DerivInfo]       -- All `deriving` clauses
+            -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations
+            -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)
+tcDeriving deriv_infos deriv_decls
+  = recoverM (do { g <- getGblEnv
+                 ; return (g, emptyBag, emptyValBindsOut)}) $
+    do  {       -- Fish the "deriving"-related information out of the TcEnv
+                -- And make the necessary "equations".
+          is_boot <- tcIsHsBootOrSig
+        ; traceTc "tcDeriving" (ppr is_boot)
+
+        ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls
+        ; traceTc "tcDeriving 1" (ppr early_specs)
+
+        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs
+        ; insts1 <- mapM genInst given_specs
+        ; insts2 <- mapM genInst infer_specs
+
+        ; dflags <- getDynFlags
+
+        ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2)
+        ; loc <- getSrcSpanM
+        ; let (binds, famInsts) = genAuxBinds dflags loc
+                                    (unionManyBags deriv_stuff)
+
+        ; let mk_inst_infos1 = map fstOf3 insts1
+        ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs
+
+          -- We must put all the derived type family instances (from both
+          -- infer_specs and given_specs) in the local instance environment
+          -- before proceeding, or else simplifyInstanceContexts might
+          -- get stuck if it has to reason about any of those family instances.
+          -- See Note [Staging of tcDeriving]
+        ; tcExtendLocalFamInstEnv (bagToList famInsts) $
+          -- NB: only call tcExtendLocalFamInstEnv once, as it performs
+          -- validity checking for all of the family instances you give it.
+          -- If the family instances have errors, calling it twice will result
+          -- in duplicate error messages!
+
+     do {
+        -- the stand-alone derived instances (@inst_infos1@) are used when
+        -- inferring the contexts for "deriving" clauses' instances
+        -- (@infer_specs@)
+        ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $
+                         simplifyInstanceContexts infer_specs
+
+        ; let mk_inst_infos2 = map fstOf3 insts2
+        ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs
+        ; let inst_infos = inst_infos1 ++ inst_infos2
+
+        ; (inst_info, rn_binds, rn_dus) <-
+            renameDeriv is_boot inst_infos binds
+
+        ; unless (isEmptyBag inst_info) $
+             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
+                        (ddump_deriving inst_info rn_binds famInsts))
+
+        ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))
+                                          getGblEnv
+        ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs)
+        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } }
+  where
+    ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn
+                   -> Bag FamInst             -- ^ Rep type family instances
+                   -> SDoc
+    ddump_deriving inst_infos extra_binds repFamInsts
+      =    hang (text "Derived class instances:")
+              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))
+                 $$ ppr extra_binds)
+        $$ hangP "Derived type family instances:"
+             (vcat (map pprRepTy (bagToList repFamInsts)))
+
+    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
+
+    -- Apply the suspended computations given by genInst calls.
+    -- See Note [Staging of tcDeriving]
+    apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)]
+                     -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]
+    apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds))
+
+-- Prints the representable type family instance
+pprRepTy :: FamInst -> SDoc
+pprRepTy fi@(FamInst { fi_tys = lhs })
+  = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
+      equals <+> ppr rhs
+  where rhs = famInstRHS fi
+
+renameDeriv :: Bool
+            -> [InstInfo GhcPs]
+            -> Bag (LHsBind GhcPs, LSig GhcPs)
+            -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)
+renameDeriv is_boot inst_infos bagBinds
+  | is_boot     -- If we are compiling a hs-boot file, don't generate any derived bindings
+                -- The inst-info bindings will all be empty, but it's easier to
+                -- just use rn_inst_info to change the type appropriately
+  = do  { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
+        ; return ( listToBag rn_inst_infos
+                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }
+
+  | otherwise
+  = discardWarnings $
+    -- Discard warnings about unused bindings etc
+    setXOptM LangExt.EmptyCase $
+    -- Derived decls (for empty types) can have
+    --    case x of {}
+    setXOptM LangExt.ScopedTypeVariables $
+    setXOptM LangExt.KindSignatures $
+    -- Derived decls (for newtype-deriving) can use ScopedTypeVariables &
+    -- KindSignatures
+    setXOptM LangExt.TypeApplications $
+    -- GND/DerivingVia uses TypeApplications in generated code
+    -- (See Note [Newtype-deriving instances] in TcGenDeriv)
+    unsetXOptM LangExt.RebindableSyntax $
+    -- See Note [Avoid RebindableSyntax when deriving]
+    do  {
+        -- Bring the extra deriving stuff into scope
+        -- before renaming the instances themselves
+        ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))
+        ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
+        ; let aux_val_binds = ValBinds noExt aux_binds (bagToList aux_sigs)
+        ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
+        ; let bndrs = collectHsValBinders rn_aux_lhs
+        ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;
+        ; setEnvs envs $
+    do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs
+        ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
+        ; return (listToBag rn_inst_infos, rn_aux,
+                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
+
+  where
+    rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars)
+    rn_inst_info
+      inst_info@(InstInfo { iSpec = inst
+                          , iBinds = InstBindings
+                            { ib_binds = binds
+                            , ib_tyvars = tyvars
+                            , ib_pragmas = sigs
+                            , ib_extensions = exts -- Only for type-checking
+                            , ib_derived = sa } })
+        =  ASSERT( null sigs )
+           bindLocalNamesFV tyvars $
+           do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []
+              ; let binds' = InstBindings { ib_binds = rn_binds
+                                          , ib_tyvars = tyvars
+                                          , ib_pragmas = []
+                                          , ib_extensions = exts
+                                          , ib_derived = sa }
+              ; return (inst_info { iBinds = binds' }, fvs) }
+
+{-
+Note [Newtype deriving and unused constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (see Trac #1954):
+
+  module Bug(P) where
+  newtype P a = MkP (IO a) deriving Monad
+
+If you compile with -Wunused-binds you do not expect the warning
+"Defined but not used: data constructor MkP". Yet the newtype deriving
+code does not explicitly mention MkP, but it should behave as if you
+had written
+  instance Monad P where
+     return x = MkP (return x)
+     ...etc...
+
+So we want to signal a user of the data constructor 'MkP'.
+This is the reason behind the [Name] part of the return type
+of genInst.
+
+Note [Staging of tcDeriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here's a tricky corner case for deriving (adapted from Trac #2721):
+
+    class C a where
+      type T a
+      foo :: a -> T a
+
+    instance C Int where
+      type T Int = Int
+      foo = id
+
+    newtype N = N Int deriving C
+
+This will produce an instance something like this:
+
+    instance C N where
+      type T N = T Int
+      foo = coerce (foo :: Int -> T Int) :: N -> T N
+
+We must be careful in order to typecheck this code. When determining the
+context for the instance (in simplifyInstanceContexts), we need to determine
+that T N and T Int have the same representation, but to do that, the T N
+instance must be in the local family instance environment. Otherwise, GHC
+would be unable to conclude that T Int is representationally equivalent to
+T Int, and simplifyInstanceContexts would get stuck.
+
+Previously, tcDeriving would defer adding any derived type family instances to
+the instance environment until the very end, which meant that
+simplifyInstanceContexts would get called without all the type family instances
+it needed in the environment in order to properly simplify instance like
+the C N instance above.
+
+To avoid this scenario, we carefully structure the order of events in
+tcDeriving. We first call genInst on the standalone derived instance specs and
+the instance specs obtained from deriving clauses. Note that the return type of
+genInst is a triple:
+
+    TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name)
+
+The type family instances are in the BagDerivStuff. The first field of the
+triple is a suspended computation which, given an instance context, produces
+the rest of the instance. The fact that it is suspended is important, because
+right now, we don't have ThetaTypes for the instances that use deriving clauses
+(only the standalone-derived ones).
+
+Now we can can collect the type family instances and extend the local instance
+environment. At this point, it is safe to run simplifyInstanceContexts on the
+deriving-clause instance specs, which gives us the ThetaTypes for the
+deriving-clause instances. Now we can feed all the ThetaTypes to the
+suspended computations and obtain our InstInfos, at which point
+tcDeriving is done.
+
+An alternative design would be to split up genInst so that the
+family instances are generated separately from the InstInfos. But this would
+require carving up a lot of the GHC deriving internals to accommodate the
+change. On the other hand, we can keep all of the InstInfo and type family
+instance logic together in genInst simply by converting genInst to
+continuation-returning style, so we opt for that route.
+
+Note [Why we don't pass rep_tc into deriveTyData]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Down in the bowels of mkEqnHelp, we need to convert the fam_tc back into
+the rep_tc by means of a lookup. And yet we have the rep_tc right here!
+Why look it up again? Answer: it's just easier this way.
+We drop some number of arguments from the end of the datatype definition
+in deriveTyData. The arguments are dropped from the fam_tc.
+This action may drop a *different* number of arguments
+passed to the rep_tc, depending on how many free variables, etc., the
+dropped patterns have.
+
+Also, this technique carries over the kind substitution from deriveTyData
+nicely.
+
+Note [Avoid RebindableSyntax when deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The RebindableSyntax extension interacts awkwardly with the derivation of
+any stock class whose methods require the use of string literals. The Show
+class is a simple example (see Trac #12688):
+
+  {-# LANGUAGE RebindableSyntax, OverloadedStrings #-}
+  newtype Text = Text String
+  fromString :: String -> Text
+  fromString = Text
+
+  data Foo = Foo deriving Show
+
+This will generate code to the effect of:
+
+  instance Show Foo where
+    showsPrec _ Foo = showString "Foo"
+
+But because RebindableSyntax and OverloadedStrings are enabled, the "Foo"
+string literal is now of type Text, not String, which showString doesn't
+accept! This causes the generated Show instance to fail to typecheck.
+
+To avoid this kind of scenario, we simply turn off RebindableSyntax entirely
+in derived code.
+
+************************************************************************
+*                                                                      *
+                From HsSyn to DerivSpec
+*                                                                      *
+************************************************************************
+
+@makeDerivSpecs@ fishes around to find the info about needed derived instances.
+-}
+
+makeDerivSpecs :: Bool
+               -> [DerivInfo]
+               -> [LDerivDecl GhcRn]
+               -> TcM [EarlyDerivSpec]
+makeDerivSpecs is_boot deriv_infos deriv_decls
+  = do  { -- We carefully set up uses of recoverM to minimize error message
+          -- cascades. See Note [Flattening deriving clauses].
+        ; eqns1 <- sequenceA
+                     [ recoverM (pure Nothing)
+                                (deriveClause rep_tc (fmap unLoc dcs)
+                                                      pred err_ctxt)
+                     | DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses
+                                 , di_ctxt = err_ctxt } <- deriv_infos
+                     , L _ (HsDerivingClause { deriv_clause_strategy = dcs
+                                             , deriv_clause_tys = L _ preds })
+                         <- clauses
+                     , pred <- preds
+                     ]
+        ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls
+        ; let eqns = catMaybes (eqns1 ++ eqns2)
+
+        ; if is_boot then   -- No 'deriving' at all in hs-boot files
+              do { unless (null eqns) (add_deriv_err (head eqns))
+                 ; return [] }
+          else return eqns }
+  where
+    add_deriv_err eqn
+       = setSrcSpan (earlyDSLoc eqn) $
+         addErr (hang (text "Deriving not permitted in hs-boot file")
+                    2 (text "Use an instance declaration instead"))
+
+{-
+Note [Flattening deriving clauses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider what happens if you run this program (from Trac #10684) without
+DeriveGeneric enabled:
+
+    data A = A deriving (Show, Generic)
+    data B = B A deriving (Show)
+
+Naturally, you'd expect GHC to give an error to the effect of:
+
+    Can't make a derived instance of `Generic A':
+      You need -XDeriveGeneric to derive an instance for this class
+
+And *only* that error, since the other two derived Show instances appear to be
+independent of this derived Generic instance. Yet GHC also used to give this
+additional error on the program above:
+
+    No instance for (Show A)
+      arising from the 'deriving' clause of a data type declaration
+    When deriving the instance for (Show B)
+
+This was happening because when GHC encountered any error within a single
+data type's set of deriving clauses, it would call recoverM and move on
+to the next data type's deriving clauses. One unfortunate consequence of
+this design is that if A's derived Generic instance failed, so its derived
+Show instance would be skipped entirely, leading to the "No instance for
+(Show A)" error cascade.
+
+The solution to this problem is to "flatten" the set of classes that are
+derived for a particular data type via deriving clauses. That is, if
+you have:
+
+    newtype C = C D
+      deriving (E, F, G)
+      deriving anyclass (H, I, J)
+      deriving newtype  (K, L, M)
+
+Then instead of processing instances E through M under the scope of a single
+recoverM, we flatten these deriving clauses into the list:
+
+    [ E (Nothing)
+    , F (Nothing)
+    , G (Nothing)
+    , H (Just anyclass)
+    , I (Just anyclass)
+    , J (Just anyclass)
+    , K (Just newtype)
+    , L (Just newtype)
+    , M (Just newtype) ]
+
+And then process each class individually, under its own recoverM scope. That
+way, failure to derive one class doesn't cancel out other classes in the
+same set of clause-derived classes.
+-}
+
+------------------------------------------------------------------
+-- | Process a single class in a `deriving` clause.
+deriveClause :: TyCon -> Maybe (DerivStrategy GhcRn)
+             -> LHsSigType GhcRn -> SDoc
+             -> TcM (Maybe EarlyDerivSpec)
+deriveClause rep_tc mb_strat pred err_ctxt
+  = addErrCtxt err_ctxt $
+    deriveTyData tvs tc tys mb_strat pred
+  where
+    tvs = tyConTyVars rep_tc
+    (tc, tys) = case tyConFamInstSig_maybe rep_tc of
+                        -- data family:
+                  Just (fam_tc, pats, _) -> (fam_tc, pats)
+      -- NB: deriveTyData wants the *user-specified*
+      -- name. See Note [Why we don't pass rep_tc into deriveTyData]
+
+                  _ -> (rep_tc, mkTyVarTys tvs)     -- datatype
+
+------------------------------------------------------------------
+deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
+-- Process a single standalone deriving declaration
+--  e.g.   deriving instance Show a => Show (T a)
+-- Rather like tcLocalInstDecl
+--
+-- This returns a Maybe because the user might try to derive Typeable, which is
+-- a no-op nowadays.
+deriveStandalone (L loc (DerivDecl _ deriv_ty mbl_deriv_strat overlap_mode))
+  = setSrcSpan loc                   $
+    addErrCtxt (standaloneCtxt deriv_ty)  $
+    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
+       ; let mb_deriv_strat = fmap unLoc mbl_deriv_strat
+             ctxt           = TcType.InstDeclCtxt True
+       ; traceTc "Deriving strategy (standalone deriving)" $
+           vcat [ppr mb_deriv_strat, ppr deriv_ty]
+       ; (mb_deriv_strat', tvs', (deriv_ctxt', cls, inst_tys'))
+           <- tcDerivStrategy mb_deriv_strat $ do
+                (tvs, deriv_ctxt, cls, inst_tys)
+                  <- tcStandaloneDerivInstType ctxt deriv_ty
+                pure (tvs, (deriv_ctxt, cls, inst_tys))
+       ; checkTc (not (null inst_tys')) derivingNullaryErr
+       ; let inst_ty' = last inst_tys'
+         -- See Note [Unify kinds in deriving]
+       ; (tvs, deriv_ctxt, inst_tys) <-
+           case mb_deriv_strat' of
+             -- Perform an additional unification with the kind of the `via`
+             -- type and the result of the previous kind unification.
+             Just (ViaStrategy via_ty) -> do
+               let via_kind     = tcTypeKind via_ty
+                   inst_ty_kind = tcTypeKind inst_ty'
+                   mb_match     = tcUnifyTy inst_ty_kind via_kind
+
+               checkTc (isJust mb_match)
+                       (derivingViaKindErr cls inst_ty_kind
+                                           via_ty via_kind)
+
+               let Just kind_subst = mb_match
+                   ki_subst_range  = getTCvSubstRangeFVs kind_subst
+                   -- See Note [Unification of two kind variables in deriving]
+                   unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst
+                                        && not (v `elemVarSet` ki_subst_range))
+                                          tvs'
+                   (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs
+                   (final_deriv_ctxt, final_deriv_ctxt_tys)
+                     = case deriv_ctxt' of
+                         InferContext wc -> (InferContext wc, [])
+                         SupplyContext theta ->
+                           let final_theta = substTheta subst theta
+                           in (SupplyContext final_theta, final_theta)
+                   final_inst_tys   = substTys subst inst_tys'
+                   final_tvs        = tyCoVarsOfTypesWellScoped $
+                                      final_deriv_ctxt_tys ++ final_inst_tys
+               pure (final_tvs, final_deriv_ctxt, final_inst_tys)
+
+             _ -> pure (tvs', deriv_ctxt', inst_tys')
+       ; let cls_tys = take (length inst_tys - 1) inst_tys
+             inst_ty = last inst_tys
+       ; traceTc "Standalone deriving;" $ vcat
+              [ text "tvs:" <+> ppr tvs
+              , text "mb_deriv_strat:" <+> ppr mb_deriv_strat'
+              , text "deriv_ctxt:" <+> ppr deriv_ctxt
+              , text "cls:" <+> ppr cls
+              , text "tys:" <+> ppr inst_tys ]
+                -- C.f. TcInstDcls.tcLocalInstDecl1
+       ; traceTc "Standalone deriving:" $ vcat
+              [ text "class:" <+> ppr cls
+              , text "class types:" <+> ppr cls_tys
+              , text "type:" <+> ppr inst_ty ]
+
+       ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys
+                              inst_ty mb_deriv_strat' msg)
+
+       ; case tcSplitTyConApp_maybe inst_ty of
+           Just (tc, tc_args)
+              | className cls == typeableClassName
+              -> do warnUselessTypeable
+                    return Nothing
+
+              | otherwise
+              -> Just <$> mkEqnHelp (fmap unLoc overlap_mode)
+                                    tvs cls cls_tys tc tc_args
+                                    deriv_ctxt mb_deriv_strat'
+
+           _  -> -- Complain about functions, primitive types, etc,
+                 bale_out $
+                 text "The last argument of the instance must be a data or newtype application"
+        }
+deriveStandalone (L _ (XDerivDecl _)) = panic "deriveStandalone"
+
+-- Typecheck the type in a standalone deriving declaration.
+--
+-- This may appear dense, but it's mostly huffing and puffing to recognize
+-- the special case of a type with an extra-constraints wildcard context, e.g.,
+--
+--   deriving instance _ => Eq (Foo a)
+--
+-- If there is such a wildcard, we typecheck this as if we had written
+-- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@,
+-- as the 'DerivContext', where loc is the location of the wildcard used for
+-- error reporting. This indicates that we should infer the context as if we
+-- were deriving Eq via a deriving clause
+-- (see Note [Inferring the instance context] in TcDerivInfer).
+--
+-- If there is no wildcard, then proceed as normal, and instead return
+-- @'SupplyContext' theta@, where theta is the typechecked context.
+--
+-- Note that this will never return @'InferContext' 'Nothing'@, as that can
+-- only happen with @deriving@ clauses.
+tcStandaloneDerivInstType
+  :: UserTypeCtxt -> LHsSigWcType GhcRn
+  -> TcM ([TyVar], DerivContext, Class, [Type])
+tcStandaloneDerivInstType ctxt
+    (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars
+                                       , hsib_body   = deriv_ty_body })})
+  | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body
+  , L _ [wc_pred] <- theta
+  , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred
+  = do dfun_ty <- tcHsClsInstType ctxt $
+                  HsIB { hsib_ext = vars
+                       , hsib_body
+                           = L (getLoc deriv_ty_body) $
+                             HsForAllTy { hst_bndrs = tvs
+                                        , hst_xforall = noExt
+                                        , hst_body  = rho }}
+       let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
+       pure (tvs, InferContext (Just wc_span), cls, inst_tys)
+  | otherwise
+  = do dfun_ty <- tcHsClsInstType ctxt deriv_ty
+       let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty
+       pure (tvs, SupplyContext theta, cls, inst_tys)
+
+tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs _))
+  = panic "tcStandaloneDerivInstType"
+tcStandaloneDerivInstType _ (XHsWildCardBndrs _)
+  = panic "tcStandaloneDerivInstType"
+
+warnUselessTypeable :: TcM ()
+warnUselessTypeable
+  = do { warn <- woptM Opt_WarnDerivingTypeable
+       ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable)
+                   $ text "Deriving" <+> quotes (ppr typeableClassName) <+>
+                     text "has no effect: all types now auto-derive Typeable" }
+
+------------------------------------------------------------------
+deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance
+                    -- Can be a data instance, hence [Type] args
+                    -- and in that case the TyCon is the /family/ tycon
+             -> Maybe (DerivStrategy GhcRn)  -- The optional deriving strategy
+             -> LHsSigType GhcRn             -- The deriving predicate
+             -> TcM (Maybe EarlyDerivSpec)
+-- The deriving clause of a data or newtype declaration
+-- I.e. not standalone deriving
+--
+-- This returns a Maybe because the user might try to derive Typeable, which is
+-- a no-op nowadays.
+deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred
+  = setSrcSpan (getLoc (hsSigType deriv_pred)) $
+    -- Use loc of the 'deriving' item
+    do  { (mb_deriv_strat', deriv_tvs, (cls, cls_tys, cls_arg_kinds))
+                <- tcExtendTyVarEnv tvs $
+                -- Deriving preds may (now) mention
+                -- the type variables for the type constructor, hence tcExtendTyVarenv
+                -- The "deriv_pred" is a LHsType to take account of the fact that for
+                -- newtype deriving we allow deriving (forall a. C [a]).
+
+                -- Typeable is special, because Typeable :: forall k. k -> Constraint
+                -- so the argument kind 'k' is not decomposable by splitKindFunTys
+                -- as is the case for all other derivable type classes
+                     tcDerivStrategy mb_deriv_strat $
+                     tcHsDeriv deriv_pred
+
+        ; when (cls_arg_kinds `lengthIsNot` 1) $
+            failWithTc (nonUnaryErr deriv_pred)
+        ; let [cls_arg_kind] = cls_arg_kinds
+        ; if className cls == typeableClassName
+          then do warnUselessTypeable
+                  return Nothing
+          else
+
+     do {  -- Given data T a b c = ... deriving( C d ),
+           -- we want to drop type variables from T so that (C d (T a)) is well-kinded
+          let (arg_kinds, _)  = splitFunTys cls_arg_kind
+              n_args_to_drop  = length arg_kinds
+              n_args_to_keep  = length tc_args - n_args_to_drop
+                                -- See Note [tc_args and tycon arity]
+              (tc_args_to_keep, args_to_drop)
+                              = splitAt n_args_to_keep tc_args
+              inst_ty_kind    = tcTypeKind (mkTyConApp tc tc_args_to_keep)
+
+              -- Match up the kinds, and apply the resulting kind substitution
+              -- to the types.  See Note [Unify kinds in deriving]
+              -- We are assuming the tycon tyvars and the class tyvars are distinct
+              mb_match        = tcUnifyTy inst_ty_kind cls_arg_kind
+              enough_args     = n_args_to_keep >= 0
+
+        -- Check that the result really is well-kinded
+        ; checkTc (enough_args && isJust mb_match)
+                  (derivingKindErr tc cls cls_tys cls_arg_kind enough_args)
+
+        ; let propagate_subst kind_subst tkvs' cls_tys' tc_args'
+                = (final_tkvs, final_cls_tys, final_tc_args)
+                where
+                  ki_subst_range  = getTCvSubstRangeFVs kind_subst
+                  -- See Note [Unification of two kind variables in deriving]
+                  unmapped_tkvs   = filter (\v -> v `notElemTCvSubst` kind_subst
+                                         && not (v `elemVarSet` ki_subst_range))
+                                           tkvs'
+                  (subst, _)      = substTyVarBndrs kind_subst unmapped_tkvs
+                  final_tc_args   = substTys subst tc_args'
+                  final_cls_tys   = substTys subst cls_tys'
+                  final_tkvs      = tyCoVarsOfTypesWellScoped $
+                                    final_cls_tys ++ final_tc_args
+
+        ; let tkvs = scopedSort $ fvVarList $
+                     unionFV (tyCoFVsOfTypes tc_args_to_keep)
+                             (FV.mkFVs deriv_tvs)
+              Just kind_subst = mb_match
+              (tkvs', final_cls_tys', final_tc_args')
+                = propagate_subst kind_subst tkvs cls_tys tc_args_to_keep
+
+          -- See Note [Unify kinds in deriving]
+        ; (tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <-
+            case mb_deriv_strat' of
+              -- Perform an additional unification with the kind of the `via`
+              -- type and the result of the previous kind unification.
+              Just (ViaStrategy via_ty) -> do
+                let final_via_ty   = via_ty
+                    final_via_kind = tcTypeKind final_via_ty
+                    final_inst_ty_kind
+                              = tcTypeKind (mkTyConApp tc final_tc_args')
+                    via_match = tcUnifyTy final_inst_ty_kind final_via_kind
+
+                checkTc (isJust via_match)
+                        (derivingViaKindErr cls final_inst_ty_kind
+                                            final_via_ty final_via_kind)
+
+                let Just via_subst = via_match
+                    (final_tkvs, final_cls_tys, final_tc_args)
+                      = propagate_subst via_subst tkvs'
+                                        final_cls_tys' final_tc_args'
+                pure ( final_tkvs, final_cls_tys, final_tc_args
+                     , Just $ ViaStrategy $ substTy via_subst via_ty
+                     )
+
+              _ -> pure ( tkvs', final_cls_tys', final_tc_args'
+                        , mb_deriv_strat' )
+
+        ; traceTc "Deriving strategy (deriving clause)" $
+            vcat [ppr final_mb_deriv_strat, ppr deriv_pred]
+
+        ; traceTc "derivTyData1" (vcat [ pprTyVars tvs, ppr tc, ppr tc_args
+                                       , ppr deriv_pred
+                                       , pprTyVars (tyCoVarsOfTypesList tc_args)
+                                       , ppr n_args_to_keep, ppr n_args_to_drop
+                                       , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match
+                                       , ppr final_tc_args, ppr final_cls_tys ])
+
+        ; traceTc "derivTyData2" (vcat [ ppr tkvs ])
+
+        ; let final_tc_app = mkTyConApp tc final_tc_args
+        ; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop)     -- (a, b, c)
+                  (derivingEtaErr cls final_cls_tys final_tc_app)
+                -- Check that
+                --  (a) The args to drop are all type variables; eg reject:
+                --              data instance T a Int = .... deriving( Monad )
+                --  (b) The args to drop are all *distinct* type variables; eg reject:
+                --              class C (a :: * -> * -> *) where ...
+                --              data instance T a a = ... deriving( C )
+                --  (c) The type class args, or remaining tycon args,
+                --      do not mention any of the dropped type variables
+                --              newtype T a s = ... deriving( ST s )
+                --              newtype instance K a a = ... deriving( Monad )
+                --
+                -- It is vital that the implementation of allDistinctTyVars
+                -- expand any type synonyms.
+                -- See Note [Eta-reducing type synonyms]
+
+        ; checkValidInstHead DerivClauseCtxt cls $
+                             final_cls_tys ++ [final_tc_app]
+                -- Check that we aren't deriving an instance of a magical
+                -- type like (~) or Coercible (#14916).
+
+        ; spec <- mkEqnHelp Nothing tkvs
+                            cls final_cls_tys tc final_tc_args
+                            (InferContext Nothing) final_mb_deriv_strat
+        ; traceTc "derivTyData" (ppr spec)
+        ; return $ Just spec } }
+
+
+{- Note [tc_args and tycon arity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might wonder if we could use (tyConArity tc) at this point, rather
+than (length tc_args).  But for data families the two can differ!  The
+tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which
+in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them
+from DataFamInstTyCon:
+
+| DataFamInstTyCon          -- See Note [Data type families]
+      (CoAxiom Unbranched)
+      TyCon   -- The family TyCon
+      [Type]  -- Argument types (mentions the tyConTyVars of this TyCon)
+              -- No shorter in length than the tyConTyVars of the family TyCon
+              -- How could it be longer? See [Arity of data families] in FamInstEnv
+
+Notice that the arg tys might not be the same as the family tycon arity
+(= length tyConTyVars).
+
+Note [Unify kinds in deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #8534)
+    data T a b = MkT a deriving( Functor )
+    -- where Functor :: (*->*) -> Constraint
+
+So T :: forall k. * -> k -> *.   We want to get
+    instance Functor (T * (a:*)) where ...
+Notice the '*' argument to T.
+
+Moreover, as well as instantiating T's kind arguments, we may need to instantiate
+C's kind args.  Consider (Trac #8865):
+  newtype T a b = MkT (Either a b) deriving( Category )
+where
+  Category :: forall k. (k -> k -> *) -> Constraint
+We need to generate the instance
+  instance Category * (Either a) where ...
+Notice the '*' argument to Category.
+
+So we need to
+ * drop arguments from (T a b) to match the number of
+   arrows in the (last argument of the) class;
+ * and then *unify* kind of the remaining type against the
+   expected kind, to figure out how to instantiate C's and T's
+   kind arguments.
+
+In the two examples,
+ * we unify   kind-of( T k (a:k) ) ~ kind-of( Functor )
+         i.e.      (k -> *) ~ (* -> *)   to find k:=*.
+         yielding  k:=*
+
+ * we unify   kind-of( Either ) ~ kind-of( Category )
+         i.e.      (* -> * -> *)  ~ (k -> k -> k)
+         yielding  k:=*
+
+Now we get a kind substitution.  We then need to:
+
+  1. Remove the substituted-out kind variables from the quantified kind vars
+
+  2. Apply the substitution to the kinds of quantified *type* vars
+     (and extend the substitution to reflect this change)
+
+  3. Apply that extended substitution to the non-dropped args (types and
+     kinds) of the type and class
+
+Forgetting step (2) caused Trac #8893:
+  data V a = V [a] deriving Functor
+  data P (x::k->*) (a:k) = P (x a) deriving Functor
+  data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor
+
+When deriving Functor for P, we unify k to *, but we then want
+an instance   $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*))
+and similarly for C.  Notice the modified kind of x, both at binding
+and occurrence sites.
+
+This can lead to some surprising results when *visible* kind binder is
+unified (in contrast to the above examples, in which only non-visible kind
+binders were considered). Consider this example from Trac #11732:
+
+    data T k (a :: k) = MkT deriving Functor
+
+Since unification yields k:=*, this results in a generated instance of:
+
+    instance Functor (T *) where ...
+
+which looks odd at first glance, since one might expect the instance head
+to be of the form Functor (T k). Indeed, one could envision an alternative
+generated instance of:
+
+    instance (k ~ *) => Functor (T k) where
+
+But this does not typecheck by design: kind equalities are not allowed to be
+bound in types, only terms. But in essence, the two instance declarations are
+entirely equivalent, since even though (T k) matches any kind k, the only
+possibly value for k is *, since anything else is ill-typed. As a result, we can
+just as comfortably use (T *).
+
+Another way of thinking about is: deriving clauses often infer constraints.
+For example:
+
+    data S a = S a deriving Eq
+
+infers an (Eq a) constraint in the derived instance. By analogy, when we
+are deriving Functor, we might infer an equality constraint (e.g., k ~ *).
+The only distinction is that GHC instantiates equality constraints directly
+during the deriving process.
+
+Another quirk of this design choice manifests when typeclasses have visible
+kind parameters. Consider this code (also from Trac #11732):
+
+    class Cat k (cat :: k -> k -> *) where
+      catId   :: cat a a
+      catComp :: cat b c -> cat a b -> cat a c
+
+    instance Cat * (->) where
+      catId   = id
+      catComp = (.)
+
+    newtype Fun a b = Fun (a -> b) deriving (Cat k)
+
+Even though we requested a derived instance of the form (Cat k Fun), the
+kind unification will actually generate (Cat * Fun) (i.e., the same thing as if
+the user wrote deriving (Cat *)).
+
+What happens with DerivingVia, when you have yet another type? Consider:
+
+  newtype Foo (a :: Type) = MkFoo (Proxy a)
+    deriving Functor via Proxy
+
+As before, we unify the kind of Foo (* -> *) with the kind of the argument to
+Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind
+(k -> *), which is more general than what we want. So we must additionally
+unify (k -> *) with (* -> *).
+
+Currently, all of this unification is implemented kludgily with the pure
+unifier, which is rather tiresome. Trac #14331 lays out a plan for how this
+might be made cleaner.
+
+Note [Unification of two kind variables in deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As a special case of the Note above, it is possible to derive an instance of
+a poly-kinded typeclass for a poly-kinded datatype. For example:
+
+    class Category (cat :: k -> k -> *) where
+    newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category
+
+This case is suprisingly tricky. To see why, let's write out what instance GHC
+will attempt to derive (using -fprint-explicit-kinds syntax):
+
+    instance Category k1 (T k2 c) where ...
+
+GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst)
+that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to
+the type variable binder for c, since its kind is (k2 -> k2 -> *).
+
+We used to accomplish this by doing the following:
+
+    unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs
+    (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs
+
+Where all_tkvs contains all kind variables in the class and instance types (in
+this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping,
+this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped
+to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new].
+This is bad, because applying that substitution yields the following instance:
+
+   instance Category k_new (T k1 c) where ...
+
+In other words, keeping k1 in unmapped_tvks taints the substitution, resulting
+in an ill-kinded instance (this caused Trac #11837).
+
+To prevent this, we need to filter out any variable from all_tkvs which either
+
+1. Appears in the domain of kind_subst. notElemTCvSubst checks this.
+2. Appears in the range of kind_subst. To do this, we compute the free
+   variable set of the range of kind_subst with getTCvSubstRangeFVs, and check
+   if a kind variable appears in that set.
+
+Note [Eta-reducing type synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+One can instantiate a type in a data family instance with a type synonym that
+mentions other type variables:
+
+  type Const a b = a
+  data family Fam (f :: * -> *) (a :: *)
+  newtype instance Fam f (Const a f) = Fam (f a) deriving Functor
+
+It is also possible to define kind synonyms, and they can mention other types in
+a datatype declaration. For example,
+
+  type Const a b = a
+  newtype T f (a :: Const * f) = T (f a) deriving Functor
+
+When deriving, we need to perform eta-reduction analysis to ensure that none of
+the eta-reduced type variables are mentioned elsewhere in the declaration. But
+we need to be careful, because if we don't expand through the Const type
+synonym, we will mistakenly believe that f is an eta-reduced type variable and
+fail to derive Functor, even though the code above is correct (see Trac #11416,
+where this was first noticed). For this reason, we expand the type synonyms in
+the eta-reduced types before doing any analysis.
+-}
+
+mkEqnHelp :: Maybe OverlapMode
+          -> [TyVar]
+          -> Class -> [Type]
+          -> TyCon -> [Type]
+          -> DerivContext
+               -- SupplyContext => context supplied (standalone deriving)
+               -- InferContext  => context inferred (deriving on data decl, or
+               --                  standalone deriving decl with a wildcard)
+          -> Maybe (DerivStrategy GhcTc)
+          -> TcRn EarlyDerivSpec
+-- Make the EarlyDerivSpec for an instance
+--      forall tvs. theta => cls (tys ++ [ty])
+-- where the 'theta' is optional (that's the Maybe part)
+-- Assumes that this declaration is well-kinded
+
+mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args deriv_ctxt deriv_strat
+  = do {      -- Find the instance of a data family
+              -- Note [Looking up family instances for deriving]
+         fam_envs <- tcGetFamInstEnvs
+       ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args
+              -- If it's still a data family, the lookup failed; i.e no instance exists
+       ; when (isDataFamilyTyCon rep_tc)
+              (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))
+       ; is_boot <- tcIsHsBootOrSig
+       ; when is_boot $
+              bale_out (text "Cannot derive instances in hs-boot files"
+                    $+$ text "Write an instance declaration instead")
+
+       ; let deriv_env = DerivEnv
+                         { denv_overlap_mode = overlap_mode
+                         , denv_tvs          = tvs
+                         , denv_cls          = cls
+                         , denv_cls_tys      = cls_tys
+                         , denv_tc           = tycon
+                         , denv_tc_args      = tc_args
+                         , denv_rep_tc       = rep_tc
+                         , denv_rep_tc_args  = rep_tc_args
+                         , denv_ctxt         = deriv_ctxt
+                         , denv_strat        = deriv_strat }
+       ; flip runReaderT deriv_env $
+         if isNewTyCon rep_tc then mkNewTypeEqn else mkDataTypeEqn }
+  where
+     bale_out msg = failWithTc (derivingThingErr False cls cls_tys
+                      (mkTyConApp tycon tc_args) deriv_strat msg)
+
+{-
+Note [Looking up family instances for deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcLookupFamInstExact is an auxiliary lookup wrapper which requires
+that looked-up family instances exist.  If called with a vanilla
+tycon, the old type application is simply returned.
+
+If we have
+  data instance F () = ... deriving Eq
+  data instance F () = ... deriving Eq
+then tcLookupFamInstExact will be confused by the two matches;
+but that can't happen because tcInstDecls1 doesn't call tcDeriving
+if there are any overlaps.
+
+There are two other things that might go wrong with the lookup.
+First, we might see a standalone deriving clause
+   deriving Eq (F ())
+when there is no data instance F () in scope.
+
+Note that it's OK to have
+  data instance F [a] = ...
+  deriving Eq (F [(a,b)])
+where the match is not exact; the same holds for ordinary data types
+with standalone deriving declarations.
+
+Note [Deriving, type families, and partial applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When there are no type families, it's quite easy:
+
+    newtype S a = MkS [a]
+    -- :CoS :: S  ~ []  -- Eta-reduced
+
+    instance Eq [a] => Eq (S a)         -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
+    instance Monad [] => Monad S        -- by coercion sym (Monad :CoS)  : Monad [] ~ Monad S
+
+When type familes are involved it's trickier:
+
+    data family T a b
+    newtype instance T Int a = MkT [a] deriving( Eq, Monad )
+    -- :RT is the representation type for (T Int a)
+    --  :Co:RT    :: :RT ~ []          -- Eta-reduced!
+    --  :CoF:RT a :: T Int a ~ :RT a   -- Also eta-reduced!
+
+    instance Eq [a] => Eq (T Int a)     -- easy by coercion
+       -- d1 :: Eq [a]
+       -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a))
+
+    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
+       -- d1 :: Monad []
+       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))
+
+Note the need for the eta-reduced rule axioms.  After all, we can
+write it out
+    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
+      return x = MkT [x]
+      ... etc ...
+
+See Note [Eta reduction for data families] in FamInstEnv
+
+%************************************************************************
+%*                                                                      *
+                Deriving data types
+*                                                                      *
+************************************************************************
+-}
+
+-- | Derive an instance for a data type (i.e., non-newtype).
+mkDataTypeEqn :: DerivM EarlyDerivSpec
+mkDataTypeEqn
+  = do mb_strat <- asks denv_strat
+       let bale_out msg = do err <- derivingThingErrM False msg
+                             lift $ failWithTc err
+       case mb_strat of
+         Just StockStrategy    -> mk_eqn_stock    mk_originative_eqn bale_out
+         Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out
+         Just (ViaStrategy ty) -> mk_eqn_via ty
+         -- GeneralizedNewtypeDeriving makes no sense for non-newtypes
+         Just NewtypeStrategy  -> bale_out gndNonNewtypeErr
+         -- Lacking a user-requested deriving strategy, we will try to pick
+         -- between the stock or anyclass strategies
+         Nothing -> mk_eqn_no_mechanism mk_originative_eqn bale_out
+
+-- Derive an instance by way of an originative deriving strategy
+-- (stock or anyclass).
+--
+-- See Note [Deriving strategies]
+mk_originative_eqn
+  :: DerivSpecMechanism -- Invariant: This will be DerivSpecStock or
+                        -- DerivSpecAnyclass
+  -> DerivM EarlyDerivSpec
+mk_originative_eqn mechanism
+  = do DerivEnv { denv_overlap_mode = overlap_mode
+                , denv_tvs          = tvs
+                , denv_tc           = tc
+                , denv_tc_args      = tc_args
+                , denv_rep_tc       = rep_tc
+                , denv_cls          = cls
+                , denv_cls_tys      = cls_tys
+                , denv_ctxt         = deriv_ctxt } <- ask
+       let inst_ty  = mkTyConApp tc tc_args
+           inst_tys = cls_tys ++ [inst_ty]
+       doDerivInstErrorChecks1 mechanism
+       loc       <- lift getSrcSpanM
+       dfun_name <- lift $ newDFunName' cls tc
+       case deriv_ctxt of
+        InferContext wildcard ->
+          do { (inferred_constraints, tvs', inst_tys')
+                 <- inferConstraints mechanism
+             ; return $ InferTheta $ DS
+                   { ds_loc = loc
+                   , ds_name = dfun_name, ds_tvs = tvs'
+                   , ds_cls = cls, ds_tys = inst_tys'
+                   , ds_tc = rep_tc
+                   , ds_theta = inferred_constraints
+                   , ds_overlap = overlap_mode
+                   , ds_standalone_wildcard = wildcard
+                   , ds_mechanism = mechanism } }
+
+        SupplyContext theta ->
+            return $ GivenTheta $ DS
+                   { ds_loc = loc
+                   , ds_name = dfun_name, ds_tvs = tvs
+                   , ds_cls = cls, ds_tys = inst_tys
+                   , ds_tc = rep_tc
+                   , ds_theta = theta
+                   , ds_overlap = overlap_mode
+                   , ds_standalone_wildcard = Nothing
+                   , ds_mechanism = mechanism }
+
+-- Derive an instance by way of a coerce-based deriving strategy
+-- (newtype or via).
+--
+-- See Note [Deriving strategies]
+mk_coerce_based_eqn
+  :: (Type -> DerivSpecMechanism) -- Invariant: This will be DerivSpecNewtype
+                                  -- or DerivSpecVia
+  -> Type -- The type to coerce
+  -> DerivM EarlyDerivSpec
+mk_coerce_based_eqn mk_mechanism coerced_ty
+  = do DerivEnv { denv_overlap_mode = overlap_mode
+                , denv_tvs          = tvs
+                , denv_tc           = tycon
+                , denv_tc_args      = tc_args
+                , denv_rep_tc       = rep_tycon
+                , denv_cls          = cls
+                , denv_cls_tys      = cls_tys
+                , denv_ctxt         = deriv_ctxt } <- ask
+       sa_wildcard <- isStandaloneWildcardDeriv
+       let -- The following functions are polymorphic over the representation
+           -- type, since we might either give it the underlying type of a
+           -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type
+           -- (for DerivingVia).
+           rep_tys ty  = cls_tys ++ [ty]
+           rep_pred ty = mkClassPred cls (rep_tys ty)
+           rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty)
+                   -- rep_pred is the representation dictionary, from where
+                   -- we are going to get all the methods for the final
+                   -- dictionary
+
+           -- Next we figure out what superclass dictionaries to use
+           -- See Note [Newtype deriving superclasses] above
+           sc_preds   :: [PredOrigin]
+           cls_tyvars = classTyVars cls
+           inst_ty    = mkTyConApp tycon tc_args
+           inst_tys   = cls_tys ++ [inst_ty]
+           sc_preds   = map (mkPredOrigin deriv_origin TypeLevel) $
+                        substTheta (zipTvSubst cls_tyvars inst_tys) $
+                        classSCTheta cls
+           deriv_origin = mkDerivOrigin sa_wildcard
+
+           -- Next we collect constraints for the class methods
+           -- If there are no methods, we don't need any constraints
+           -- Otherwise we need (C rep_ty), for the representation methods,
+           -- and constraints to coerce each individual method
+           meth_preds :: Type -> [PredOrigin]
+           meths = classMethods cls
+           meth_preds ty
+             | null meths = [] -- No methods => no constraints
+                               -- (Trac #12814)
+             | otherwise = rep_pred_o ty : coercible_constraints ty
+           coercible_constraints ty
+             = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard)
+                              TypeLevel (mkReprPrimEqPred t1 t2)
+               | meth <- meths
+               , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs
+                                            inst_tys ty meth ]
+
+           all_thetas :: Type -> [ThetaOrigin]
+           all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty ++ sc_preds]
+
+           inferred_thetas = all_thetas coerced_ty
+       lift $ traceTc "newtype deriving:" $
+         ppr tycon <+> ppr (rep_tys coerced_ty) <+> ppr inferred_thetas
+       let mechanism = mk_mechanism coerced_ty
+           bale_out msg = do err <- derivingThingErrMechanism mechanism msg
+                             lift $ failWithTc err
+       atf_coerce_based_error_checks cls bale_out
+       doDerivInstErrorChecks1 mechanism
+       dfun_name <- lift $ newDFunName' cls tycon
+       loc       <- lift getSrcSpanM
+       case deriv_ctxt of
+        SupplyContext theta -> return $ GivenTheta $ DS
+            { ds_loc = loc
+            , ds_name = dfun_name, ds_tvs = tvs
+            , ds_cls = cls, ds_tys = inst_tys
+            , ds_tc = rep_tycon
+            , ds_theta = theta
+            , ds_overlap = overlap_mode
+            , ds_standalone_wildcard = Nothing
+            , ds_mechanism = mechanism }
+        InferContext wildcard -> return $ InferTheta $ DS
+            { ds_loc = loc
+            , ds_name = dfun_name, ds_tvs = tvs
+            , ds_cls = cls, ds_tys = inst_tys
+            , ds_tc = rep_tycon
+            , ds_theta = inferred_thetas
+            , ds_overlap = overlap_mode
+            , ds_standalone_wildcard = wildcard
+            , ds_mechanism = mechanism }
+
+-- Ensure that a class's associated type variables are suitable for
+-- GeneralizedNewtypeDeriving or DerivingVia.
+--
+-- See Note [GND and associated type families]
+atf_coerce_based_error_checks
+  :: Class
+  -> (SDoc -> DerivM ())
+  -> DerivM ()
+atf_coerce_based_error_checks cls bale_out
+  = let cls_tyvars = classTyVars cls
+
+        ats_look_sensible
+           =  -- Check (a) from Note [GND and associated type families]
+              no_adfs
+              -- Check (b) from Note [GND and associated type families]
+           && isNothing at_without_last_cls_tv
+              -- Check (d) from Note [GND and associated type families]
+           && isNothing at_last_cls_tv_in_kinds
+
+        (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs
+        no_adfs            = null adf_tcs
+               -- We cannot newtype-derive data family instances
+
+        at_without_last_cls_tv
+          = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs
+        at_last_cls_tv_in_kinds
+          = find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind)
+                             (tyConTyVars tc)
+                      || at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs
+        at_last_cls_tv_in_kind kind
+          = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind
+        at_tcs = classATs cls
+        last_cls_tv = ASSERT( notNull cls_tyvars )
+                      last cls_tyvars
+
+        cant_derive_err
+           = vcat [ ppUnless no_adfs adfs_msg
+                  , maybe empty at_without_last_cls_tv_msg
+                          at_without_last_cls_tv
+                  , maybe empty at_last_cls_tv_in_kinds_msg
+                          at_last_cls_tv_in_kinds
+                  ]
+        adfs_msg  = text "the class has associated data types"
+        at_without_last_cls_tv_msg at_tc = hang
+          (text "the associated type" <+> quotes (ppr at_tc)
+           <+> text "is not parameterized over the last type variable")
+          2 (text "of the class" <+> quotes (ppr cls))
+        at_last_cls_tv_in_kinds_msg at_tc = hang
+          (text "the associated type" <+> quotes (ppr at_tc)
+           <+> text "contains the last type variable")
+         2 (text "of the class" <+> quotes (ppr cls)
+           <+> text "in a kind, which is not (yet) allowed")
+    in unless ats_look_sensible $ bale_out cant_derive_err
+
+mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
+             -> (SDoc -> DerivM EarlyDerivSpec)
+             -> DerivM EarlyDerivSpec
+mk_eqn_stock go_for_it bale_out
+  = do DerivEnv { denv_tc      = tc
+                , denv_rep_tc  = rep_tc
+                , denv_cls     = cls
+                , denv_cls_tys = cls_tys
+                , denv_ctxt    = deriv_ctxt } <- ask
+       dflags <- getDynFlags
+       case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
+                                           tc rep_tc of
+         CanDeriveStock gen_fn -> go_for_it $ DerivSpecStock gen_fn
+         StockClassError msg   -> bale_out msg
+         _                     -> bale_out (nonStdErr cls)
+
+mk_eqn_anyclass :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
+                -> (SDoc -> DerivM EarlyDerivSpec)
+                -> DerivM EarlyDerivSpec
+mk_eqn_anyclass go_for_it bale_out
+  = do dflags <- getDynFlags
+       case canDeriveAnyClass dflags of
+         IsValid      -> go_for_it DerivSpecAnyClass
+         NotValid msg -> bale_out msg
+
+mk_eqn_newtype :: Type -- The newtype's representation type
+               -> DerivM EarlyDerivSpec
+mk_eqn_newtype = mk_coerce_based_eqn DerivSpecNewtype
+
+mk_eqn_via :: Type -- The @via@ type
+           -> DerivM EarlyDerivSpec
+mk_eqn_via = mk_coerce_based_eqn DerivSpecVia
+
+mk_eqn_no_mechanism :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)
+                    -> (SDoc -> DerivM EarlyDerivSpec)
+                    -> DerivM EarlyDerivSpec
+mk_eqn_no_mechanism go_for_it bale_out
+  = do DerivEnv { denv_tc      = tc
+                , denv_rep_tc  = rep_tc
+                , denv_cls     = cls
+                , denv_cls_tys = cls_tys
+                , denv_ctxt    = deriv_ctxt } <- ask
+       dflags <- getDynFlags
+
+           -- See Note [Deriving instances for classes themselves]
+       let dac_error msg
+             | isClassTyCon rep_tc
+             = quotes (ppr tc) <+> text "is a type class,"
+                               <+> text "and can only have a derived instance"
+                               $+$ text "if DeriveAnyClass is enabled"
+             | otherwise
+             = nonStdErr cls $$ msg
+
+       case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
+                                           tc rep_tc of
+           -- NB: pass the *representation* tycon to
+           -- checkOriginativeSideConditions
+           NonDerivableClass   msg -> bale_out (dac_error msg)
+           StockClassError msg     -> bale_out msg
+           CanDeriveStock gen_fn   -> go_for_it $ DerivSpecStock gen_fn
+           CanDeriveAnyClass       -> go_for_it DerivSpecAnyClass
+
+{-
+************************************************************************
+*                                                                      *
+            GeneralizedNewtypeDeriving and DerivingVia
+*                                                                      *
+************************************************************************
+-}
+
+-- | Derive an instance for a newtype.
+mkNewTypeEqn :: DerivM EarlyDerivSpec
+mkNewTypeEqn
+-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
+  = do DerivEnv { denv_tc           = tycon
+                , denv_rep_tc       = rep_tycon
+                , denv_rep_tc_args  = rep_tc_args
+                , denv_cls          = cls
+                , denv_cls_tys      = cls_tys
+                , denv_ctxt         = deriv_ctxt
+                , denv_strat        = mb_strat } <- ask
+       dflags <- getDynFlags
+
+       let newtype_deriving  = xopt LangExt.GeneralizedNewtypeDeriving dflags
+           deriveAnyClass    = xopt LangExt.DeriveAnyClass             dflags
+           bale_out        = bale_out' newtype_deriving
+           bale_out' b msg = do err <- derivingThingErrM b msg
+                                lift $ failWithTc err
+
+           non_std     = nonStdErr cls
+           suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's"
+                     <+> text "newtype-deriving extension"
+
+           -- Here is the plan for newtype derivings.  We see
+           --        newtype T a1...an = MkT (t ak+1...an)
+           --          deriving (.., C s1 .. sm, ...)
+           -- where t is a type,
+           --       ak+1...an is a suffix of a1..an, and are all tyvars
+           --       ak+1...an do not occur free in t, nor in the s1..sm
+           --       (C s1 ... sm) is a  *partial applications* of class C
+           --                      with the last parameter missing
+           --       (T a1 .. ak) matches the kind of C's last argument
+           --              (and hence so does t)
+           -- The latter kind-check has been done by deriveTyData already,
+           -- and tc_args are already trimmed
+           --
+           -- We generate the instance
+           --       instance forall ({a1..ak} u fvs(s1..sm)).
+           --                C s1 .. sm t => C s1 .. sm (T a1...ak)
+           -- where T a1...ap is the partial application of
+           --       the LHS of the correct kind and p >= k
+           --
+           --      NB: the variables below are:
+           --              tc_tvs = [a1, ..., an]
+           --              tyvars_to_keep = [a1, ..., ak]
+           --              rep_ty = t ak .. an
+           --              deriv_tvs = fvs(s1..sm) \ tc_tvs
+           --              tys = [s1, ..., sm]
+           --              rep_fn' = t
+           --
+           -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
+           -- We generate the instance
+           --      instance Monad (ST s) => Monad (T s) where
+
+           nt_eta_arity = newTyConEtadArity rep_tycon
+                   -- For newtype T a b = MkT (S a a b), the TyCon
+                   -- machinery already eta-reduces the representation type, so
+                   -- we know that
+                   --      T a ~ S a a
+                   -- That's convenient here, because we may have to apply
+                   -- it to fewer than its original complement of arguments
+
+           -- Note [Newtype representation]
+           -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+           -- Need newTyConRhs (*not* a recursive representation finder)
+           -- to get the representation type. For example
+           --      newtype B = MkB Int
+           --      newtype A = MkA B deriving( Num )
+           -- We want the Num instance of B, *not* the Num instance of Int,
+           -- when making the Num instance of A!
+           rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
+
+           -------------------------------------------------------------------
+           --  Figuring out whether we can only do this newtype-deriving thing
+
+           -- See Note [Determining whether newtype-deriving is appropriate]
+           might_be_newtype_derivable
+              =  not (non_coercible_class cls)
+              && eta_ok
+--            && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]
+
+           -- Check that eta reduction is OK
+           eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity
+             -- The newtype can be eta-reduced to match the number
+             --     of type argument actually supplied
+             --        newtype T a b = MkT (S [a] b) deriving( Monad )
+             --     Here the 'b' must be the same in the rep type (S [a] b)
+             --     And the [a] must not mention 'b'.  That's all handled
+             --     by nt_eta_rity.
+
+           cant_derive_err = ppUnless eta_ok  eta_msg
+           eta_msg = text "cannot eta-reduce the representation type enough"
+
+       MASSERT( cls_tys `lengthIs` (classArity cls - 1) )
+       case mb_strat of
+         Just StockStrategy    -> mk_eqn_stock    mk_originative_eqn bale_out
+         Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out
+         Just NewtypeStrategy  ->
+           -- Since the user explicitly asked for GeneralizedNewtypeDeriving,
+           -- we don't need to perform all of the checks we normally would,
+           -- such as if the class being derived is known to produce ill-roled
+           -- coercions (e.g., Traversable), since we can just derive the
+           -- instance and let it error if need be.
+           -- See Note [Determining whether newtype-deriving is appropriate]
+           if eta_ok && newtype_deriving
+             then mk_eqn_newtype rep_inst_ty
+             else bale_out (cant_derive_err $$
+                            if newtype_deriving then empty else suggest_gnd)
+         Just (ViaStrategy via_ty) ->
+           -- NB: For DerivingVia, we don't need to any eta-reduction checking,
+           -- since the @via@ type is already "eta-reduced".
+           mk_eqn_via via_ty
+         Nothing
+           | might_be_newtype_derivable
+             && ((newtype_deriving && not deriveAnyClass)
+                  || std_class_via_coercible cls)
+          -> mk_eqn_newtype rep_inst_ty
+           | otherwise
+          -> case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys
+                                                 tycon rep_tycon of
+               StockClassError msg
+                 -- There's a particular corner case where
+                 --
+                 -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are
+                 --    both enabled at the same time
+                 -- 2. We're deriving a particular stock derivable class
+                 --    (such as Functor)
+                 --
+                 -- and the previous cases won't catch it. This fixes the bug
+                 -- reported in Trac #10598.
+                 | might_be_newtype_derivable && newtype_deriving
+                -> mk_eqn_newtype rep_inst_ty
+                 -- Otherwise, throw an error for a stock class
+                 | might_be_newtype_derivable && not newtype_deriving
+                -> bale_out (msg $$ suggest_gnd)
+                 | otherwise
+                -> bale_out msg
+
+               -- Must use newtype deriving or DeriveAnyClass
+               NonDerivableClass _msg
+                 -- Too hard, even with newtype deriving
+                 | newtype_deriving           -> bale_out cant_derive_err
+                 -- Try newtype deriving!
+                 -- Here we suggest GeneralizedNewtypeDeriving even in cases
+                 -- where it may not be applicable. See Trac #9600.
+                 | otherwise                  -> bale_out (non_std $$ suggest_gnd)
+
+               -- DeriveAnyClass
+               CanDeriveAnyClass -> do
+                 -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are
+                 -- enabled, we take the diplomatic approach of defaulting to
+                 -- DeriveAnyClass, but emitting a warning about the choice.
+                 -- See Note [Deriving strategies]
+                 when (newtype_deriving && deriveAnyClass) $
+                   lift $ addWarnTc NoReason $ sep
+                     [ text "Both DeriveAnyClass and"
+                       <+> text "GeneralizedNewtypeDeriving are enabled"
+                     , text "Defaulting to the DeriveAnyClass strategy"
+                       <+> text "for instantiating" <+> ppr cls
+                     , text "Use DerivingStrategies to pick"
+                       <+> text "a different strategy"
+                      ]
+                 mk_originative_eqn DerivSpecAnyClass
+               -- CanDeriveStock
+               CanDeriveStock gen_fn -> mk_originative_eqn $
+                                        DerivSpecStock gen_fn
+
+{-
+Note [Recursive newtypes]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Newtype deriving works fine, even if the newtype is recursive.
+e.g.    newtype S1 = S1 [T1 ()]
+        newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
+Remember, too, that type families are currently (conservatively) given
+a recursive flag, so this also allows newtype deriving to work
+for type famillies.
+
+We used to exclude recursive types, because we had a rather simple
+minded way of generating the instance decl:
+   newtype A = MkA [A]
+   instance Eq [A] => Eq A      -- Makes typechecker loop!
+But now we require a simple context, so it's ok.
+
+Note [Determining whether newtype-deriving is appropriate]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we see
+  newtype NT = MkNT Foo
+    deriving C
+we have to decide how to perform the deriving. Do we do newtype deriving,
+or do we do normal deriving? In general, we prefer to do newtype deriving
+wherever possible. So, we try newtype deriving unless there's a glaring
+reason not to.
+
+"Glaring reasons not to" include trying to derive a class for which a
+coercion-based instance doesn't make sense. These classes are listed in
+the definition of non_coercible_class. They include Show (since it must
+show the name of the datatype) and Traversable (since a coercion-based
+Traversable instance is ill-roled).
+
+However, non_coercible_class is ignored if the user explicitly requests
+to derive an instance with GeneralizedNewtypeDeriving using the newtype
+deriving strategy. In such a scenario, GHC will unquestioningly try to
+derive the instance via coercions (even if the final generated code is
+ill-roled!). See Note [Deriving strategies].
+
+Note that newtype deriving might fail, even after we commit to it. This
+is because the derived instance uses `coerce`, which must satisfy its
+`Coercible` constraint. This is different than other deriving scenarios,
+where we're sure that the resulting instance will type-check.
+
+Note [GND and associated type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for
+classes with associated type families. A general recipe is:
+
+    class C x y z where
+      type T y z x
+      op :: x -> [y] -> z
+
+    newtype N a = MkN <rep-type> deriving( C )
+
+    =====>
+
+    instance C x y <rep-type> => C x y (N a) where
+      type T y (N a) x = T y <rep-type> x
+      op = coerce (op :: x -> [y] -> <rep-type>)
+
+However, we must watch out for three things:
+
+(a) The class must not contain any data families. If it did, we'd have to
+    generate a fresh data constructor name for the derived data family
+    instance, and it's not clear how to do this.
+
+(b) Each associated type family's type variables must mention the last type
+    variable of the class. As an example, you wouldn't be able to use GND to
+    derive an instance of this class:
+
+      class C a b where
+        type T a
+
+    But you would be able to derive an instance of this class:
+
+      class C a b where
+        type T b
+
+    The difference is that in the latter T mentions the last parameter of C
+    (i.e., it mentions b), but the former T does not. If you tried, e.g.,
+
+      newtype Foo x = Foo x deriving (C a)
+
+    with the former definition of C, you'd end up with something like this:
+
+      instance C a (Foo x) where
+        type T a = T ???
+
+    This T family instance doesn't mention the newtype (or its representation
+    type) at all, so we disallow such constructions with GND.
+
+(c) UndecidableInstances might need to be enabled. Here's a case where it is
+    most definitely necessary:
+
+      class C a where
+        type T a
+      newtype Loop = Loop MkLoop deriving C
+
+      =====>
+
+      instance C Loop where
+        type T Loop = T Loop
+
+    Obviously, T Loop would send the typechecker into a loop. Unfortunately,
+    you might even need UndecidableInstances even in cases where the
+    typechecker would be guaranteed to terminate. For example:
+
+      instance C Int where
+        type C Int = Int
+      newtype MyInt = MyInt Int deriving C
+
+      =====>
+
+      instance C MyInt where
+        type T MyInt = T Int
+
+    GHC's termination checker isn't sophisticated enough to conclude that the
+    definition of T MyInt terminates, so UndecidableInstances is required.
+
+(d) For the time being, we do not allow the last type variable of the class to
+    appear in a /kind/ of an associated type family definition. For instance:
+
+    class C a where
+      type T1 a        -- OK
+      type T2 (x :: a) -- Illegal: a appears in the kind of x
+      type T3 y :: a   -- Illegal: a appears in the kind of (T3 y)
+
+    The reason we disallow this is because our current approach to deriving
+    associated type family instances—i.e., by unwrapping the newtype's type
+    constructor as shown above—is ill-equipped to handle the scenario when
+    the last type variable appears as an implicit argument. In the worst case,
+    allowing the last variable to appear in a kind can result in improper Core
+    being generated (see #14728).
+
+    There is hope for this feature being added some day, as one could
+    conceivably take a newtype axiom (which witnesses a coercion between a
+    newtype and its representation type) at lift that through each associated
+    type at the Core level. See #14728, comment:3 for a sketch of how this
+    might work. Until then, we disallow this featurette wholesale.
+
+The same criteria apply to DerivingVia.
+
+************************************************************************
+*                                                                      *
+\subsection[TcDeriv-normal-binds]{Bindings for the various classes}
+*                                                                      *
+************************************************************************
+
+After all the trouble to figure out the required context for the
+derived instance declarations, all that's left is to chug along to
+produce them.  They will then be shoved into @tcInstDecls2@, which
+will do all its usual business.
+
+There are lots of possibilities for code to generate.  Here are
+various general remarks.
+
+PRINCIPLES:
+\begin{itemize}
+\item
+We want derived instances of @Eq@ and @Ord@ (both v common) to be
+``you-couldn't-do-better-by-hand'' efficient.
+
+\item
+Deriving @Show@---also pretty common--- should also be reasonable good code.
+
+\item
+Deriving for the other classes isn't that common or that big a deal.
+\end{itemize}
+
+PRAGMATICS:
+
+\begin{itemize}
+\item
+Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
+
+\item
+Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
+
+\item
+We {\em normally} generate code only for the non-defaulted methods;
+there are some exceptions for @Eq@ and (especially) @Ord@...
+
+\item
+Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
+constructor's numeric (@Int#@) tag.  These are generated by
+@gen_tag_n_con_binds@, and the heuristic for deciding if one of
+these is around is given by @hasCon2TagFun@.
+
+The examples under the different sections below will make this
+clearer.
+
+\item
+Much less often (really just for deriving @Ix@), we use a
+@_tag2con_<tycon>@ function.  See the examples.
+
+\item
+We use the renamer!!!  Reason: we're supposed to be
+producing @LHsBinds Name@ for the methods, but that means
+producing correctly-uniquified code on the fly.  This is entirely
+possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
+So, instead, we produce @MonoBinds RdrName@ then heave 'em through
+the renamer.  What a great hack!
+\end{itemize}
+-}
+
+-- Generate the InstInfo for the required instance paired with the
+--   *representation* tycon for that instance,
+-- plus any auxiliary bindings required
+--
+-- Representation tycons differ from the tycon in the instance signature in
+-- case of instances for indexed families.
+--
+genInst :: DerivSpec theta
+        -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])
+-- We must use continuation-returning style here to get the order in which we
+-- typecheck family instances and derived instances right.
+-- See Note [Staging of tcDeriving]
+genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon
+                 , ds_mechanism = mechanism, ds_tys = tys
+                 , ds_cls = clas, ds_loc = loc
+                 , ds_standalone_wildcard = wildcard })
+  = do (meth_binds, deriv_stuff, unusedNames)
+         <- set_span_and_ctxt $
+            genDerivStuff mechanism loc clas rep_tycon tys tvs
+       let mk_inst_info theta = set_span_and_ctxt $ do
+             inst_spec <- newDerivClsInst theta spec
+             doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism
+             traceTc "newder" (ppr inst_spec)
+             return $ InstInfo
+                       { iSpec   = inst_spec
+                       , iBinds  = InstBindings
+                                     { ib_binds = meth_binds
+                                     , ib_tyvars = map Var.varName tvs
+                                     , ib_pragmas = []
+                                     , ib_extensions = extensions
+                                     , ib_derived = True } }
+       return (mk_inst_info, deriv_stuff, unusedNames)
+  where
+    extensions :: [LangExt.Extension]
+    extensions
+      | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism
+        -- Both these flags are needed for higher-rank uses of coerce
+        -- See Note [Newtype-deriving instances] in TcGenDeriv
+      = [LangExt.ImpredicativeTypes, LangExt.RankNTypes]
+      | otherwise
+      = []
+
+    set_span_and_ctxt :: TcM a -> TcM a
+    set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)
+
+doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()
+doDerivInstErrorChecks1 mechanism = do
+    DerivEnv { denv_tc      = tc
+             , denv_rep_tc  = rep_tc } <- ask
+    standalone <- isStandaloneDeriv
+    let anyclass_strategy = isDerivSpecAnyClass mechanism
+        via_strategy      = isDerivSpecVia mechanism
+        bale_out msg = do err <- derivingThingErrMechanism mechanism msg
+                          lift $ failWithTc err
+
+    -- For standalone deriving, check that all the data constructors are in
+    -- scope...
+    rdr_env <- lift getGlobalRdrEnv
+    let data_con_names = map dataConName (tyConDataCons rep_tc)
+        hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&
+                           (isAbstractTyCon rep_tc ||
+                            any not_in_scope data_con_names)
+        not_in_scope dc  = isNothing (lookupGRE_Name rdr_env dc)
+
+    lift $ addUsedDataCons rdr_env rep_tc
+
+    -- ...however, we don't perform this check if we're using DeriveAnyClass,
+    -- since it doesn't generate any code that requires use of a data
+    -- constructor. Nor do we perform this check with @deriving via@, as it
+    -- doesn't explicitly require the constructors to be in scope.
+    unless (anyclass_strategy || via_strategy
+            || not standalone || not hidden_data_cons) $
+           bale_out $ derivingHiddenErr tc
+
+doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan
+                        -> DerivSpecMechanism -> TcM ()
+doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism
+  = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst)
+       ; dflags <- getDynFlags
+       ; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures
+       ; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures
+
+         -- Error if PartialTypeSignatures isn't enabled when a user tries
+         -- to write @deriving instance _ => Eq (Foo a)@. Or, if that
+         -- extension is enabled, give a warning if -Wpartial-type-signatures
+         -- is enabled.
+       ; case wildcard of
+           Nothing -> pure ()
+           Just span -> setSrcSpan span $ do
+             checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion)
+             warnTc (Reason Opt_WarnPartialTypeSignatures)
+                    wpartial_sigs partial_sig_msg
+
+         -- Check for Generic instances that are derived with an exotic
+         -- deriving strategy like DAC
+         -- See Note [Deriving strategies]
+       ; when (exotic_mechanism && className clas `elem` genericClassNames) $
+         do { failIfTc (safeLanguageOn dflags) gen_inst_err
+            ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } }
+  where
+    exotic_mechanism = not $ isDerivSpecStock mechanism
+
+    partial_sig_msg = text "Found type wildcard" <+> quotes (char '_')
+                  <+> text "standing for" <+> quotes (pprTheta theta)
+
+    pts_suggestion
+      = text "To use the inferred type, enable PartialTypeSignatures"
+
+    gen_inst_err = text "Generic instances can only be derived in"
+               <+> text "Safe Haskell using the stock strategy."
+
+genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class
+              -> TyCon -> [Type] -> [TyVar]
+              -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
+genDerivStuff mechanism loc clas tycon inst_tys tyvars
+  = case mechanism of
+      -- See Note [Bindings for Generalised Newtype Deriving]
+      DerivSpecNewtype rhs_ty -> gen_newtype_or_via rhs_ty
+
+      -- Try a stock deriver
+      DerivSpecStock gen_fn -> gen_fn loc tycon inst_tys
+
+      -- Try DeriveAnyClass
+      DerivSpecAnyClass -> do
+        let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)
+            mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
+        dflags <- getDynFlags
+        tyfam_insts <-
+          -- canDeriveAnyClass should ensure that this code can't be reached
+          -- unless -XDeriveAnyClass is enabled.
+          ASSERT2( isValid (canDeriveAnyClass dflags)
+                 , ppr "genDerivStuff: bad derived class" <+> ppr clas )
+          mapM (tcATDefault loc mini_subst emptyNameSet)
+               (classATItems clas)
+        return ( emptyBag -- No method bindings are needed...
+               , listToBag (map DerivFamInst (concat tyfam_insts))
+               -- ...but we may need to generate binding for associated type
+               -- family default instances.
+               -- See Note [DeriveAnyClass and default family instances]
+               , [] )
+
+      -- Try DerivingVia
+      DerivSpecVia via_ty -> gen_newtype_or_via via_ty
+  where
+    gen_newtype_or_via ty = do
+      (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty
+      return (binds, faminsts, maybeToList unusedConName)
+
+    unusedConName :: Maybe Name
+    unusedConName
+      | isDerivSpecNewtype mechanism
+        -- See Note [Newtype deriving and unused constructors]
+      = Just $ getName $ head $ tyConDataCons tycon
+      | otherwise
+      = Nothing
+
+{-
+Note [Bindings for Generalised Newtype Deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  class Eq a => C a where
+     f :: a -> a
+  newtype N a = MkN [a] deriving( C )
+  instance Eq (N a) where ...
+
+The 'deriving C' clause generates, in effect
+  instance (C [a], Eq a) => C (N a) where
+     f = coerce (f :: [a] -> [a])
+
+This generates a cast for each method, but allows the superclasse to
+be worked out in the usual way.  In this case the superclass (Eq (N
+a)) will be solved by the explicit Eq (N a) instance.  We do *not*
+create the superclasses by casting the superclass dictionaries for the
+representation type.
+
+See the paper "Safe zero-cost coercions for Haskell".
+
+Note [DeriveAnyClass and default family instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When a class has a associated type family with a default instance, e.g.:
+
+  class C a where
+    type T a
+    type T a = Char
+
+then there are a couple of scenarios in which a user would expect T a to
+default to Char. One is when an instance declaration for C is given without
+an implementation for T:
+
+  instance C Int
+
+Another scenario in which this can occur is when the -XDeriveAnyClass extension
+is used:
+
+  data Example = Example deriving (C, Generic)
+
+In the latter case, we must take care to check if C has any associated type
+families with default instances, because -XDeriveAnyClass will never provide
+an implementation for them. We "fill in" the default instances using the
+tcATDefault function from TcClassDcl (which is also used in TcInstDcls to
+handle the empty instance declaration case).
+
+Note [Deriving strategies]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHC has a notion of deriving strategies, which allow the user to explicitly
+request which approach to use when deriving an instance (enabled with the
+-XDerivingStrategies language extension). For more information, refer to the
+original Trac ticket (#10598) or the associated wiki page:
+https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies
+
+A deriving strategy can be specified in a deriving clause:
+
+    newtype Foo = MkFoo Bar
+      deriving newtype C
+
+Or in a standalone deriving declaration:
+
+    deriving anyclass instance C Foo
+
+-XDerivingStrategies also allows the use of multiple deriving clauses per data
+declaration so that a user can derive some instance with one deriving strategy
+and other instances with another deriving strategy. For example:
+
+    newtype Baz = Baz Quux
+      deriving          (Eq, Ord)
+      deriving stock    (Read, Show)
+      deriving newtype  (Num, Floating)
+      deriving anyclass C
+
+Currently, the deriving strategies are:
+
+* stock: Have GHC implement a "standard" instance for a data type, if possible
+  (e.g., Eq, Ord, Generic, Data, Functor, etc.)
+
+* anyclass: Use -XDeriveAnyClass
+
+* newtype: Use -XGeneralizedNewtypeDeriving
+
+* via: Use -XDerivingVia
+
+The latter two strategies (newtype and via) are referred to as the
+"coerce-based" strategies, since they generate code that relies on the `coerce`
+function. The former two strategies (stock and anyclass), in contrast, are
+referred to as the "originative" strategies, since they create "original"
+instances instead of "reusing" old instances (by way of `coerce`).
+
+If an explicit deriving strategy is not given, GHC has an algorithm it uses to
+determine which strategy it will actually use. The algorithm is quite long,
+so it lives in the Haskell wiki at
+https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies
+("The deriving strategy resolution algorithm" section).
+
+Internally, GHC uses the DerivStrategy datatype to denote a user-requested
+deriving strategy, and it uses the DerivSpecMechanism datatype to denote what
+GHC will use to derive the instance after taking the above steps. In other
+words, GHC will always settle on a DerivSpecMechnism, even if the user did not
+ask for a particular DerivStrategy (using the algorithm linked to above).
+
+Note [Deriving instances for classes themselves]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Much of the code in TcDeriv assumes that deriving only works on data types.
+But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly
+reasonable to do something like this:
+
+  {-# LANGUAGE DeriveAnyClass #-}
+  class C1 (a :: Constraint) where
+  class C2 where
+  deriving instance C1 C2
+    -- This is equivalent to `instance C1 C2`
+
+If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock
+deriving), we throw a special error message indicating that DeriveAnyClass is
+the only way to go. We don't bother throwing this error if an explicit 'stock'
+or 'newtype' keyword is used, since both options have their own perfectly
+sensible error messages in the case of the above code (as C1 isn't a stock
+derivable class, and C2 isn't a newtype).
+
+************************************************************************
+*                                                                      *
+\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
+*                                                                      *
+************************************************************************
+-}
+
+nonUnaryErr :: LHsSigType GhcRn -> SDoc
+nonUnaryErr ct = quotes (ppr ct)
+  <+> text "is not a unary constraint, as expected by a deriving clause"
+
+nonStdErr :: Class -> SDoc
+nonStdErr cls =
+      quotes (ppr cls)
+  <+> text "is not a stock derivable class (Eq, Show, etc.)"
+
+gndNonNewtypeErr :: SDoc
+gndNonNewtypeErr =
+  text "GeneralizedNewtypeDeriving cannot be used on non-newtypes"
+
+derivingNullaryErr :: MsgDoc
+derivingNullaryErr = text "Cannot derive instances for nullary classes"
+
+derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc
+derivingKindErr tc cls cls_tys cls_kind enough_args
+  = sep [ hang (text "Cannot derive well-kinded instance of form"
+                      <+> quotes (pprClassPred cls cls_tys
+                                    <+> parens (ppr tc <+> text "...")))
+               2 gen1_suggestion
+        , nest 2 (text "Class" <+> quotes (ppr cls)
+                      <+> text "expects an argument of kind"
+                      <+> quotes (pprKind cls_kind))
+        ]
+  where
+    gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args
+                    = text "(Perhaps you intended to use PolyKinds)"
+                    | otherwise = Outputable.empty
+
+derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc
+derivingViaKindErr cls cls_kind via_ty via_kind
+  = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty))
+       2 (text "Class" <+> quotes (ppr cls)
+               <+> text "expects an argument of kind"
+               <+> quotes (pprKind cls_kind) <> char ','
+      $+$ text "but" <+> quotes (pprType via_ty)
+               <+> text "has kind" <+> quotes (pprKind via_kind))
+
+derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc
+derivingEtaErr cls cls_tys inst_ty
+  = sep [text "Cannot eta-reduce to an instance of form",
+         nest 2 (text "instance (...) =>"
+                <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
+
+derivingThingErr :: Bool -> Class -> [Type] -> Type
+                 -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc
+derivingThingErr newtype_deriving cls cls_tys inst_ty mb_strat why
+  = derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat
+                      (maybe empty derivStrategyName mb_strat) why
+
+derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc
+derivingThingErrM newtype_deriving why
+  = do DerivEnv { denv_tc      = tc
+                , denv_tc_args = tc_args
+                , denv_cls     = cls
+                , denv_cls_tys = cls_tys
+                , denv_strat   = mb_strat } <- ask
+       pure $ derivingThingErr newtype_deriving cls cls_tys
+                               (mkTyConApp tc tc_args) mb_strat why
+
+derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc
+derivingThingErrMechanism mechanism why
+  = do DerivEnv { denv_tc      = tc
+                , denv_tc_args = tc_args
+                , denv_cls     = cls
+                , denv_cls_tys = cls_tys
+                , denv_strat   = mb_strat } <- ask
+       pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_tys
+                (mkTyConApp tc tc_args) mb_strat
+                (derivStrategyName $ derivSpecMechanismToStrategy mechanism)
+                why
+
+derivingThingErr' :: Bool -> Class -> [Type] -> Type
+                  -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc
+derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat strat_msg why
+  = sep [(hang (text "Can't make a derived instance of")
+             2 (quotes (ppr pred) <+> via_mechanism)
+          $$ nest 2 extra) <> colon,
+         nest 2 why]
+  where
+    strat_used = isJust mb_strat
+    extra | not strat_used, newtype_deriving
+          = text "(even with cunning GeneralizedNewtypeDeriving)"
+          | otherwise = empty
+    pred = mkClassPred cls (cls_tys ++ [inst_ty])
+    via_mechanism | strat_used
+                  = text "with the" <+> strat_msg <+> text "strategy"
+                  | otherwise
+                  = empty
+
+derivingHiddenErr :: TyCon -> SDoc
+derivingHiddenErr tc
+  = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
+       2 (text "so you cannot derive an instance for it")
+
+standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
+standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")
+                       2 (quotes (ppr ty))
diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcDerivInfer.hs
@@ -0,0 +1,973 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Functions for inferring (and simplifying) the context for derived instances.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MultiWayIf #-}
+
+module TcDerivInfer (inferConstraints, simplifyInstanceContexts) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Bag
+import BasicTypes
+import Class
+import DataCon
+import ErrUtils
+import Inst
+import Outputable
+import PrelNames
+import TcDerivUtils
+import TcEnv
+import TcGenFunctor
+import TcGenGenerics
+import TcMType
+import TcRnMonad
+import TcType
+import TyCon
+import Type
+import TcSimplify
+import TcValidity (validDerivPred)
+import TcUnify (buildImplicationFor, checkConstraints)
+import Unify (tcUnifyTy)
+import Util
+import Var
+import VarSet
+
+import Control.Monad
+import Control.Monad.Trans.Class  (lift)
+import Control.Monad.Trans.Reader (ask)
+import Data.List
+import Data.Maybe
+
+----------------------
+
+inferConstraints :: DerivSpecMechanism
+                 -> DerivM ([ThetaOrigin], [TyVar], [TcType])
+-- inferConstraints figures out the constraints needed for the
+-- instance declaration generated by a 'deriving' clause on a
+-- data type declaration. It also returns the new in-scope type
+-- variables and instance types, in case they were changed due to
+-- the presence of functor-like constraints.
+-- See Note [Inferring the instance context]
+
+-- e.g. inferConstraints
+--        C Int (T [a])    -- Class and inst_tys
+--        :RTList a        -- Rep tycon and its arg tys
+-- where T [a] ~R :RTList a
+--
+-- Generate a sufficiently large set of constraints that typechecking the
+-- generated method definitions should succeed.   This set will be simplified
+-- before being used in the instance declaration
+inferConstraints mechanism
+  = do { DerivEnv { denv_tc          = tc
+                  , denv_tc_args     = tc_args
+                  , denv_cls         = main_cls
+                  , denv_cls_tys     = cls_tys } <- ask
+       ; wildcard <- isStandaloneWildcardDeriv
+       ; let is_anyclass = isDerivSpecAnyClass mechanism
+             infer_constraints
+               | is_anyclass = inferConstraintsDAC inst_tys
+               | otherwise   = inferConstraintsDataConArgs inst_ty inst_tys
+
+             inst_ty  = mkTyConApp tc tc_args
+             inst_tys = cls_tys ++ [inst_ty]
+
+             -- Constraints arising from superclasses
+             -- See Note [Superclasses of derived instance]
+             cls_tvs  = classTyVars main_cls
+             sc_constraints = ASSERT2( equalLength cls_tvs inst_tys
+                                     , ppr main_cls <+> ppr inst_tys )
+                              [ mkThetaOrigin (mkDerivOrigin wildcard)
+                                              TypeLevel [] [] [] $
+                                substTheta cls_subst (classSCTheta main_cls) ]
+             cls_subst = ASSERT( equalLength cls_tvs inst_tys )
+                         zipTvSubst cls_tvs inst_tys
+
+       ; (inferred_constraints, tvs', inst_tys') <- infer_constraints
+       ; lift $ traceTc "inferConstraints" $ vcat
+              [ ppr main_cls <+> ppr inst_tys'
+              , ppr inferred_constraints
+              ]
+       ; return ( sc_constraints ++ inferred_constraints
+                , tvs', inst_tys' ) }
+
+-- | Like 'inferConstraints', but used only in the case of deriving strategies
+-- where the constraints are inferred by inspecting the fields of each data
+-- constructor (i.e., stock- and newtype-deriving).
+inferConstraintsDataConArgs :: TcType -> [TcType]
+                            -> DerivM ([ThetaOrigin], [TyVar], [TcType])
+inferConstraintsDataConArgs inst_ty inst_tys
+  = do DerivEnv { denv_tvs         = tvs
+                , denv_rep_tc      = rep_tc
+                , denv_rep_tc_args = rep_tc_args
+                , denv_cls         = main_cls
+                , denv_cls_tys     = cls_tys } <- ask
+       wildcard <- isStandaloneWildcardDeriv
+
+       let tc_binders = tyConBinders rep_tc
+           choose_level bndr
+             | isNamedTyConBinder bndr = KindLevel
+             | otherwise               = TypeLevel
+           t_or_ks = map choose_level tc_binders ++ repeat TypeLevel
+              -- want to report *kind* errors when possible
+
+              -- Constraints arising from the arguments of each constructor
+           con_arg_constraints
+             :: (CtOrigin -> TypeOrKind
+                          -> Type
+                          -> [([PredOrigin], Maybe TCvSubst)])
+             -> ([ThetaOrigin], [TyVar], [TcType])
+           con_arg_constraints get_arg_constraints
+             = let (predss, mbSubsts) = unzip
+                     [ preds_and_mbSubst
+                     | data_con <- tyConDataCons rep_tc
+                     , (arg_n, arg_t_or_k, arg_ty)
+                         <- zip3 [1..] t_or_ks $
+                            dataConInstOrigArgTys data_con all_rep_tc_args
+                       -- No constraints for unlifted types
+                       -- See Note [Deriving and unboxed types]
+                     , not (isUnliftedType arg_ty)
+                     , let orig = DerivOriginDC data_con arg_n wildcard
+                     , preds_and_mbSubst
+                         <- get_arg_constraints orig arg_t_or_k arg_ty
+                     ]
+                   preds = concat predss
+                   -- If the constraints require a subtype to be of kind
+                   -- (* -> *) (which is the case for functor-like
+                   -- constraints), then we explicitly unify the subtype's
+                   -- kinds with (* -> *).
+                   -- See Note [Inferring the instance context]
+                   subst        = foldl' composeTCvSubst
+                                         emptyTCvSubst (catMaybes mbSubsts)
+                   unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst
+                                             && not (v `isInScope` subst)) tvs
+                   (subst', _)  = substTyVarBndrs subst unmapped_tvs
+                   preds'       = map (substPredOrigin subst') preds
+                   inst_tys'    = substTys subst' inst_tys
+                   tvs'         = tyCoVarsOfTypesWellScoped inst_tys'
+               in ([mkThetaOriginFromPreds preds'], tvs', inst_tys')
+
+           is_generic  = main_cls `hasKey` genClassKey
+           is_generic1 = main_cls `hasKey` gen1ClassKey
+           -- is_functor_like: see Note [Inferring the instance context]
+           is_functor_like = tcTypeKind inst_ty `tcEqKind` typeToTypeKind
+                          || is_generic1
+
+           get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type
+                                -> [([PredOrigin], Maybe TCvSubst)]
+           get_gen1_constraints functor_cls orig t_or_k ty
+              = mk_functor_like_constraints orig t_or_k functor_cls $
+                get_gen1_constrained_tys last_tv ty
+
+           get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type
+                                   -> [([PredOrigin], Maybe TCvSubst)]
+           get_std_constrained_tys orig t_or_k ty
+               | is_functor_like
+               = mk_functor_like_constraints orig t_or_k main_cls $
+                 deepSubtypesContaining last_tv ty
+               | otherwise
+               = [( [mk_cls_pred orig t_or_k main_cls ty]
+                  , Nothing )]
+
+           mk_functor_like_constraints :: CtOrigin -> TypeOrKind
+                                       -> Class -> [Type]
+                                       -> [([PredOrigin], Maybe TCvSubst)]
+           -- 'cls' is usually main_cls (Functor or Traversable etc), but if
+           -- main_cls = Generic1, then 'cls' can be Functor; see
+           -- get_gen1_constraints
+           --
+           -- For each type, generate two constraints,
+           -- [cls ty, kind(ty) ~ (*->*)], and a kind substitution that results
+           -- from unifying  kind(ty) with * -> *. If the unification is
+           -- successful, it will ensure that the resulting instance is well
+           -- kinded. If not, the second constraint will result in an error
+           -- message which points out the kind mismatch.
+           -- See Note [Inferring the instance context]
+           mk_functor_like_constraints orig t_or_k cls
+              = map $ \ty -> let ki = tcTypeKind ty in
+                             ( [ mk_cls_pred orig t_or_k cls ty
+                               , mkPredOrigin orig KindLevel
+                                   (mkPrimEqPred ki typeToTypeKind) ]
+                             , tcUnifyTy ki typeToTypeKind
+                             )
+
+           rep_tc_tvs      = tyConTyVars rep_tc
+           last_tv         = last rep_tc_tvs
+           -- When we first gather up the constraints to solve, most of them
+           -- contain rep_tc_tvs, i.e., the type variables from the derived
+           -- datatype's type constructor. We don't want these type variables
+           -- to appear in the final instance declaration, so we must
+           -- substitute each type variable with its counterpart in the derived
+           -- instance. rep_tc_args lists each of these counterpart types in
+           -- the same order as the type variables.
+           all_rep_tc_args
+             = rep_tc_args ++ map mkTyVarTy
+                                  (drop (length rep_tc_args) rep_tc_tvs)
+
+               -- Stupid constraints
+           stupid_constraints
+             = [ mkThetaOrigin deriv_origin TypeLevel [] [] [] $
+                 substTheta tc_subst (tyConStupidTheta rep_tc) ]
+           tc_subst = -- See the comment with all_rep_tc_args for an
+                      -- explanation of this assertion
+                      ASSERT( equalLength rep_tc_tvs all_rep_tc_args )
+                      zipTvSubst rep_tc_tvs all_rep_tc_args
+
+           -- Extra Data constraints
+           -- The Data class (only) requires that for
+           --    instance (...) => Data (T t1 t2)
+           -- IF   t1:*, t2:*
+           -- THEN (Data t1, Data t2) are among the (...) constraints
+           -- Reason: when the IF holds, we generate a method
+           --             dataCast2 f = gcast2 f
+           --         and we need the Data constraints to typecheck the method
+           extra_constraints = [mkThetaOriginFromPreds constrs]
+             where
+               constrs
+                 | main_cls `hasKey` dataClassKey
+                 , all (isLiftedTypeKind . tcTypeKind) rep_tc_args
+                 = [ mk_cls_pred deriv_origin t_or_k main_cls ty
+                   | (t_or_k, ty) <- zip t_or_ks rep_tc_args]
+                 | otherwise
+                 = []
+
+           mk_cls_pred orig t_or_k cls ty
+                -- Don't forget to apply to cls_tys' too
+              = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty]))
+           cls_tys' | is_generic1 = []
+                      -- In the awkward Generic1 case, cls_tys' should be
+                      -- empty, since we are applying the class Functor.
+
+                    | otherwise   = cls_tys
+
+           deriv_origin = mkDerivOrigin wildcard
+
+       if    -- Generic constraints are easy
+          |  is_generic
+           -> return ([], tvs, inst_tys)
+
+             -- Generic1 needs Functor
+             -- See Note [Getting base classes]
+          |  is_generic1
+           -> ASSERT( rep_tc_tvs `lengthExceeds` 0 )
+              -- Generic1 has a single kind variable
+              ASSERT( cls_tys `lengthIs` 1 )
+              do { functorClass <- lift $ tcLookupClass functorClassName
+                 ; pure $ con_arg_constraints
+                        $ get_gen1_constraints functorClass }
+
+             -- The others are a bit more complicated
+          |  otherwise
+           -> -- See the comment with all_rep_tc_args for an explanation of
+              -- this assertion
+              ASSERT2( equalLength rep_tc_tvs all_rep_tc_args
+                     , ppr main_cls <+> ppr rep_tc
+                       $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )
+                do { let (arg_constraints, tvs', inst_tys')
+                           = con_arg_constraints get_std_constrained_tys
+                   ; lift $ traceTc "inferConstraintsDataConArgs" $ vcat
+                          [ ppr main_cls <+> ppr inst_tys'
+                          , ppr arg_constraints
+                          ]
+                   ; return ( stupid_constraints ++ extra_constraints
+                                                 ++ arg_constraints
+                            , tvs', inst_tys') }
+
+typeToTypeKind :: Kind
+typeToTypeKind = liftedTypeKind `mkFunTy` liftedTypeKind
+
+-- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@,
+-- which gathers its constraints based on the type signatures of the class's
+-- methods instead of the types of the data constructor's field.
+--
+-- See Note [Gathering and simplifying constraints for DeriveAnyClass]
+-- for an explanation of how these constraints are used to determine the
+-- derived instance context.
+inferConstraintsDAC :: [TcType] -> DerivM ([ThetaOrigin], [TyVar], [TcType])
+inferConstraintsDAC inst_tys
+  = do { DerivEnv { denv_tvs = tvs
+                  , denv_cls = cls } <- ask
+       ; wildcard <- isStandaloneWildcardDeriv
+
+       ; let gen_dms = [ (sel_id, dm_ty)
+                       | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]
+
+             cls_tvs = classTyVars cls
+
+             do_one_meth :: (Id, Type) -> TcM ThetaOrigin
+               -- (Id,Type) are the selector Id and the generic default method type
+               -- NB: the latter is /not/ quantified over the class variables
+               -- See Note [Gathering and simplifying constraints for DeriveAnyClass]
+             do_one_meth (sel_id, gen_dm_ty)
+               = do { let (sel_tvs, _cls_pred, meth_ty)
+                                   = tcSplitMethodTy (varType sel_id)
+                          meth_ty' = substTyWith sel_tvs inst_tys meth_ty
+                          (meth_tvs, meth_theta, meth_tau)
+                                   = tcSplitNestedSigmaTys meth_ty'
+
+                          gen_dm_ty' = substTyWith cls_tvs inst_tys gen_dm_ty
+                          (dm_tvs, dm_theta, dm_tau)
+                                     = tcSplitNestedSigmaTys gen_dm_ty'
+                          tau_eq     = mkPrimEqPred meth_tau dm_tau
+                    ; return (mkThetaOrigin (mkDerivOrigin wildcard) TypeLevel
+                                meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) }
+
+       ; theta_origins <- lift $ mapM do_one_meth gen_dms
+       ; return (theta_origins, tvs, inst_tys) }
+
+{- Note [Inferring the instance context]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are two sorts of 'deriving', as represented by the two constructors
+for DerivContext:
+
+  * InferContext mb_wildcard: This can either be:
+    - The deriving clause for a data type.
+        (e.g, data T a = T1 a deriving( Eq ))
+      In this case, mb_wildcard = Nothing.
+    - A standalone declaration with an extra-constraints wildcard
+        (e.g., deriving instance _ => Eq (Foo a))
+      In this case, mb_wildcard = Just loc, where loc is the location
+      of the extra-constraints wildcard.
+
+    Here we must infer an instance context,
+    and generate instance declaration
+      instance Eq a => Eq (T a) where ...
+
+  * SupplyContext theta: standalone deriving
+      deriving instance Eq a => Eq (T a)
+    Here we only need to fill in the bindings;
+    the instance context (theta) is user-supplied
+
+For the InferContext case, we must figure out the
+instance context (inferConstraintsDataConArgs). Suppose we are inferring
+the instance context for
+    C t1 .. tn (T s1 .. sm)
+There are two cases
+
+  * (T s1 .. sm) :: *         (the normal case)
+    Then we behave like Eq and guess (C t1 .. tn t)
+    for each data constructor arg of type t.  More
+    details below.
+
+  * (T s1 .. sm) :: * -> *    (the functor-like case)
+    Then we behave like Functor.
+
+In both cases we produce a bunch of un-simplified constraints
+and them simplify them in simplifyInstanceContexts; see
+Note [Simplifying the instance context].
+
+In the functor-like case, we may need to unify some kind variables with * in
+order for the generated instance to be well-kinded. An example from
+Trac #10524:
+
+  newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)
+    = Compose (f (g a)) deriving Functor
+
+Earlier in the deriving pipeline, GHC unifies the kind of Compose f g
+(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this
+alone isn't enough, since k2 wasn't unified with *:
+
+  instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) =>
+    Functor (Compose f g) where ...
+
+The two Functor constraints are ill-kinded. To ensure this doesn't happen, we:
+
+  1. Collect all of a datatype's subtypes which require functor-like
+     constraints.
+  2. For each subtype, create a substitution by unifying the subtype's kind
+     with (* -> *).
+  3. Compose all the substitutions into one, then apply that substitution to
+     all of the in-scope type variables and the instance types.
+
+Note [Getting base classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Functor and Typeable are defined in package 'base', and that is not available
+when compiling 'ghc-prim'.  So we must be careful that 'deriving' for stuff in
+ghc-prim does not use Functor or Typeable implicitly via these lookups.
+
+Note [Deriving and unboxed types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have some special hacks to support things like
+   data T = MkT Int# deriving ( Show )
+
+Specifically, we use TcGenDeriv.box to box the Int# into an Int
+(which we know how to show), and append a '#'. Parentheses are not required
+for unboxed values (`MkT -3#` is a valid expression).
+
+Note [Superclasses of derived instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general, a derived instance decl needs the superclasses of the derived
+class too.  So if we have
+        data T a = ...deriving( Ord )
+then the initial context for Ord (T a) should include Eq (T a).  Often this is
+redundant; we'll also generate an Ord constraint for each constructor argument,
+and that will probably generate enough constraints to make the Eq (T a) constraint
+be satisfied too.  But not always; consider:
+
+ data S a = S
+ instance Eq (S a)
+ instance Ord (S a)
+
+ data T a = MkT (S a) deriving( Ord )
+ instance Num a => Eq (T a)
+
+The derived instance for (Ord (T a)) must have a (Num a) constraint!
+Similarly consider:
+        data T a = MkT deriving( Data )
+Here there *is* no argument field, but we must nevertheless generate
+a context for the Data instances:
+        instance Typeable a => Data (T a) where ...
+
+
+************************************************************************
+*                                                                      *
+         Finding the fixed point of deriving equations
+*                                                                      *
+************************************************************************
+
+Note [Simplifying the instance context]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+        data T a b = C1 (Foo a) (Bar b)
+                   | C2 Int (T b a)
+                   | C3 (T a a)
+                   deriving (Eq)
+
+We want to come up with an instance declaration of the form
+
+        instance (Ping a, Pong b, ...) => Eq (T a b) where
+                x == y = ...
+
+It is pretty easy, albeit tedious, to fill in the code "...".  The
+trick is to figure out what the context for the instance decl is,
+namely Ping, Pong and friends.
+
+Let's call the context reqd for the T instance of class C at types
+(a,b, ...)  C (T a b).  Thus:
+
+        Eq (T a b) = (Ping a, Pong b, ...)
+
+Now we can get a (recursive) equation from the data decl.  This part
+is done by inferConstraintsDataConArgs.
+
+        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
+                   u Eq (T b a) u Eq Int        -- From C2
+                   u Eq (T a a)                 -- From C3
+
+
+Foo and Bar may have explicit instances for Eq, in which case we can
+just substitute for them.  Alternatively, either or both may have
+their Eq instances given by deriving clauses, in which case they
+form part of the system of equations.
+
+Now all we need do is simplify and solve the equations, iterating to
+find the least fixpoint.  This is done by simplifyInstanceConstraints.
+Notice that the order of the arguments can
+switch around, as here in the recursive calls to T.
+
+Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
+
+We start with:
+
+        Eq (T a b) = {}         -- The empty set
+
+Next iteration:
+        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
+                   u Eq (T b a) u Eq Int        -- From C2
+                   u Eq (T a a)                 -- From C3
+
+        After simplification:
+                   = Eq a u Ping b u {} u {} u {}
+                   = Eq a u Ping b
+
+Next iteration:
+
+        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
+                   u Eq (T b a) u Eq Int        -- From C2
+                   u Eq (T a a)                 -- From C3
+
+        After simplification:
+                   = Eq a u Ping b
+                   u (Eq b u Ping a)
+                   u (Eq a u Ping a)
+
+                   = Eq a u Ping b u Eq b u Ping a
+
+The next iteration gives the same result, so this is the fixpoint.  We
+need to make a canonical form of the RHS to ensure convergence.  We do
+this by simplifying the RHS to a form in which
+
+        - the classes constrain only tyvars
+        - the list is sorted by tyvar (major key) and then class (minor key)
+        - no duplicates, of course
+
+Note [Deterministic simplifyInstanceContexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Canonicalisation uses nonDetCmpType which is nondeterministic. Sorting
+with nonDetCmpType puts the returned lists in a nondeterministic order.
+If we were to return them, we'd get class constraints in
+nondeterministic order.
+
+Consider:
+
+  data ADT a b = Z a b deriving Eq
+
+The generated code could be either:
+
+  instance (Eq a, Eq b) => Eq (Z a b) where
+
+Or:
+
+  instance (Eq b, Eq a) => Eq (Z a b) where
+
+To prevent the order from being nondeterministic we only
+canonicalize when comparing and return them in the same order as
+simplifyDeriv returned them.
+See also Note [nonDetCmpType nondeterminism]
+-}
+
+
+simplifyInstanceContexts :: [DerivSpec [ThetaOrigin]]
+                         -> TcM [DerivSpec ThetaType]
+-- Used only for deriving clauses or standalone deriving with an
+-- extra-constraints wildcard (InferContext)
+-- See Note [Simplifying the instance context]
+
+simplifyInstanceContexts [] = return []
+
+simplifyInstanceContexts infer_specs
+  = do  { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
+        ; iterate_deriv 1 initial_solutions }
+  where
+    ------------------------------------------------------------------
+        -- The initial solutions for the equations claim that each
+        -- instance has an empty context; this solution is certainly
+        -- in canonical form.
+    initial_solutions :: [ThetaType]
+    initial_solutions = [ [] | _ <- infer_specs ]
+
+    ------------------------------------------------------------------
+        -- iterate_deriv calculates the next batch of solutions,
+        -- compares it with the current one; finishes if they are the
+        -- same, otherwise recurses with the new solutions.
+        -- It fails if any iteration fails
+    iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType]
+    iterate_deriv n current_solns
+      | n > 20  -- Looks as if we are in an infinite loop
+                -- This can happen if we have -XUndecidableInstances
+                -- (See TcSimplify.tcSimplifyDeriv.)
+      = pprPanic "solveDerivEqns: probable loop"
+                 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
+      | otherwise
+      = do {      -- Extend the inst info from the explicit instance decls
+                  -- with the current set of solutions, and simplify each RHS
+             inst_specs <- zipWithM newDerivClsInst current_solns infer_specs
+           ; new_solns <- checkNoErrs $
+                          extendLocalInstEnv inst_specs $
+                          mapM gen_soln infer_specs
+
+           ; if (current_solns `eqSolution` new_solns) then
+                return [ spec { ds_theta = soln }
+                       | (spec, soln) <- zip infer_specs current_solns ]
+             else
+                iterate_deriv (n+1) new_solns }
+
+    eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b)
+       -- Canonicalise for comparison
+       -- See Note [Deterministic simplifyInstanceContexts]
+    canSolution = map (sortBy nonDetCmpType)
+    ------------------------------------------------------------------
+    gen_soln :: DerivSpec [ThetaOrigin] -> TcM ThetaType
+    gen_soln (DS { ds_loc = loc, ds_tvs = tyvars
+                 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
+      = setSrcSpan loc  $
+        addErrCtxt (derivInstCtxt the_pred) $
+        do { theta <- simplifyDeriv the_pred tyvars deriv_rhs
+                -- checkValidInstance tyvars theta clas inst_tys
+                -- Not necessary; see Note [Exotic derived instance contexts]
+
+           ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
+                -- Claim: the result instance declaration is guaranteed valid
+                -- Hence no need to call:
+                --   checkValidInstance tyvars theta clas inst_tys
+           ; return theta }
+      where
+        the_pred = mkClassPred clas inst_tys
+
+derivInstCtxt :: PredType -> MsgDoc
+derivInstCtxt pred
+  = text "When deriving the instance for" <+> parens (ppr pred)
+
+{-
+***********************************************************************************
+*                                                                                 *
+*            Simplify derived constraints
+*                                                                                 *
+***********************************************************************************
+-}
+
+-- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much
+-- as possible. Fail if not possible.
+simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are
+                          -- deriving.  Only used for SkolemInfo.
+              -> [TyVar]  -- ^ The tyvars bound by @inst_ty@.
+              -> [ThetaOrigin] -- ^ Given and wanted constraints
+              -> TcM ThetaType -- ^ Needed constraints (after simplification),
+                               -- i.e. @['PredType']@.
+simplifyDeriv pred tvs thetas
+  = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
+                -- The constraint solving machinery
+                -- expects *TcTyVars* not TyVars.
+                -- We use *non-overlappable* (vanilla) skolems
+                -- See Note [Overlap and deriving]
+
+       ; let skol_set  = mkVarSet tvs_skols
+             skol_info = DerivSkol pred
+             doc = text "deriving" <+> parens (ppr pred)
+
+             mk_given_ev :: PredType -> TcM EvVar
+             mk_given_ev given =
+               let given_pred = substTy skol_subst given
+               in newEvVar given_pred
+
+             emit_wanted_constraints :: [TyVar] -> [PredOrigin] -> TcM ()
+             emit_wanted_constraints metas_to_be preds
+               = do { -- We instantiate metas_to_be with fresh meta type
+                      -- variables. Currently, these can only be type variables
+                      -- quantified in generic default type signatures.
+                      -- See Note [Gathering and simplifying constraints for
+                      -- DeriveAnyClass]
+                      (meta_subst, _meta_tvs) <- newMetaTyVars metas_to_be
+
+                    -- Now make a constraint for each of the instantiated predicates
+                    ; let wanted_subst = skol_subst `unionTCvSubst` meta_subst
+                          mk_wanted_ct (PredOrigin wanted orig t_or_k)
+                            = do { ev <- newWanted orig (Just t_or_k) $
+                                         substTyUnchecked wanted_subst wanted
+                                 ; return (mkNonCanonical ev) }
+                    ; cts <- mapM mk_wanted_ct preds
+
+                    -- And emit them into the monad
+                    ; emitSimples (listToCts cts) }
+
+             -- Create the implications we need to solve. For stock and newtype
+             -- deriving, these implication constraints will be simple class
+             -- constraints like (C a, Ord b).
+             -- But with DeriveAnyClass, we make an implication constraint.
+             -- See Note [Gathering and simplifying constraints for DeriveAnyClass]
+             mk_wanteds :: ThetaOrigin -> TcM WantedConstraints
+             mk_wanteds (ThetaOrigin { to_anyclass_skols  = ac_skols
+                                     , to_anyclass_metas  = ac_metas
+                                     , to_anyclass_givens = ac_givens
+                                     , to_wanted_origins  = preds })
+               = do { ac_given_evs <- mapM mk_given_ev ac_givens
+                    ; (_, wanteds)
+                        <- captureConstraints $
+                           checkConstraints skol_info ac_skols ac_given_evs $
+                              -- The checkConstraints bumps the TcLevel, and
+                              -- wraps the wanted constraints in an implication,
+                              -- when (but only when) necessary
+                           emit_wanted_constraints ac_metas preds
+                    ; pure wanteds }
+
+       -- See [STEP DAC BUILD]
+       -- Generate the implication constraints, one for each method, to solve
+       -- with the skolemized variables.  Start "one level down" because
+       -- we are going to wrap the result in an implication with tvs_skols,
+       -- in step [DAC RESIDUAL]
+       ; (tc_lvl, wanteds) <- pushTcLevelM $
+                              mapM mk_wanteds thetas
+
+       ; traceTc "simplifyDeriv inputs" $
+         vcat [ pprTyVars tvs $$ ppr thetas $$ ppr wanteds, doc ]
+
+       -- See [STEP DAC SOLVE]
+       -- Simplify the constraints, starting at the same level at which
+       -- they are generated (c.f. the call to runTcSWithEvBinds in
+       -- simplifyInfer)
+       ; solved_wanteds <- setTcLevel tc_lvl   $
+                           runTcSDeriveds      $
+                           solveWantedsAndDrop $
+                           unionsWC wanteds
+
+       -- It's not yet zonked!  Obviously zonk it before peering at it
+       ; solved_wanteds <- zonkWC solved_wanteds
+
+       -- See [STEP DAC HOIST]
+       -- Split the resulting constraints into bad and good constraints,
+       -- building an @unsolved :: WantedConstraints@ representing all
+       -- the constraints we can't just shunt to the predicates.
+       -- See Note [Exotic derived instance contexts]
+       ; let residual_simple = approximateWC True solved_wanteds
+             (bad, good) = partitionBagWith get_good residual_simple
+
+             get_good :: Ct -> Either Ct PredType
+             get_good ct | validDerivPred skol_set p
+                         , isWantedCt ct
+                         = Right p
+                          -- TODO: This is wrong
+                          -- NB re 'isWantedCt': residual_wanted may contain
+                          -- unsolved CtDerived and we stick them into the
+                          -- bad set so that reportUnsolved may decide what
+                          -- to do with them
+                         | otherwise
+                         = Left ct
+                           where p = ctPred ct
+
+       ; traceTc "simplifyDeriv outputs" $
+         vcat [ ppr tvs_skols, ppr residual_simple, ppr good, ppr bad ]
+
+       -- Return the good unsolved constraints (unskolemizing on the way out.)
+       ; let min_theta = mkMinimalBySCs id (bagToList good)
+             -- An important property of mkMinimalBySCs (used above) is that in
+             -- addition to removing constraints that are made redundant by
+             -- superclass relationships, it also removes _duplicate_
+             -- constraints.
+             -- See Note [Gathering and simplifying constraints for
+             --           DeriveAnyClass]
+             subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs
+                          -- The reverse substitution (sigh)
+
+       -- See [STEP DAC RESIDUAL]
+       ; min_theta_vars <- mapM newEvVar min_theta
+       ; (leftover_implic, _)
+           <- buildImplicationFor tc_lvl skol_info tvs_skols
+                                  min_theta_vars solved_wanteds
+       -- This call to simplifyTop is purely for error reporting
+       -- See Note [Error reporting for deriving clauses]
+       -- See also Note [Exotic derived instance contexts], which are caught
+       -- in this line of code.
+       ; simplifyTopImplic leftover_implic
+
+       ; return (substTheta subst_skol min_theta) }
+
+{-
+Note [Overlap and deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider some overlapping instances:
+  instance Show a => Show [a] where ..
+  instance Show [Char] where ...
+
+Now a data type with deriving:
+  data T a = MkT [a] deriving( Show )
+
+We want to get the derived instance
+  instance Show [a] => Show (T a) where...
+and NOT
+  instance Show a => Show (T a) where...
+so that the (Show (T Char)) instance does the Right Thing
+
+It's very like the situation when we're inferring the type
+of a function
+   f x = show [x]
+and we want to infer
+   f :: Show [a] => a -> String
+
+BOTTOM LINE: use vanilla, non-overlappable skolems when inferring
+             the context for the derived instance.
+             Hence tcInstSkolTyVars not tcInstSuperSkolTyVars
+
+Note [Gathering and simplifying constraints for DeriveAnyClass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+DeriveAnyClass works quite differently from stock and newtype deriving in
+the way it gathers and simplifies constraints to be used in a derived
+instance's context. Stock and newtype deriving gather constraints by looking
+at the data constructors of the data type for which we are deriving an
+instance. But DeriveAnyClass doesn't need to know about a data type's
+definition at all!
+
+To see why, consider this example of DeriveAnyClass:
+
+  class Foo a where
+    bar :: forall b. Ix b => a -> b -> String
+    default bar :: (Show a, Ix c) => a -> c -> String
+    bar x y = show x ++ show (range (y,y))
+
+    baz :: Eq a => a -> a -> Bool
+    default baz :: (Ord a, Show a) => a -> a -> Bool
+    baz x y = compare x y == EQ
+
+Because 'bar' and 'baz' have default signatures, this generates a top-level
+definition for these generic default methods
+
+  $gdm_bar :: forall a. Foo a
+           => forall c. (Show a, Ix c)
+           => a -> c -> String
+  $gdm_bar x y = show x ++ show (range (y,y))
+
+(and similarly for baz).  Now consider a 'deriving' clause
+  data Maybe s = ... deriving Foo
+
+This derives an instance of the form:
+  instance (CX) => Foo (Maybe s) where
+    bar = $gdm_bar
+    baz = $gdm_baz
+
+Now it is GHC's job to fill in a suitable instance context (CX).  If
+GHC were typechecking the binding
+   bar = $gdm bar
+it would
+   * skolemise the expected type of bar
+   * instantiate the type of $gdm_bar with meta-type variables
+   * build an implication constraint
+
+[STEP DAC BUILD]
+So that's what we do.  We build the constraint (call it C1)
+
+   forall[2] b. Ix b => (Show (Maybe s), Ix cc,
+                        Maybe s -> b -> String
+                            ~ Maybe s -> cc -> String)
+
+Here:
+* The level of this forall constraint is forall[2], because we are later
+  going to wrap it in a forall[1] in [STEP DAC RESIDUAL]
+
+* The 'b' comes from the quantified type variable in the expected type
+  of bar (i.e., 'to_anyclass_skols' in 'ThetaOrigin'). The 'cc' is a unification
+  variable that comes from instantiating the quantified type variable 'c' in
+  $gdm_bar's type (i.e., 'to_anyclass_metas' in 'ThetaOrigin).
+
+* The (Ix b) constraint comes from the context of bar's type
+  (i.e., 'to_wanted_givens' in 'ThetaOrigin'). The (Show (Maybe s)) and (Ix cc)
+  constraints come from the context of $gdm_bar's type
+  (i.e., 'to_anyclass_givens' in 'ThetaOrigin').
+
+* The equality constraint (Maybe s -> b -> String) ~ (Maybe s -> cc -> String)
+  comes from marrying up the instantiated type of $gdm_bar with the specified
+  type of bar. Notice that the type variables from the instance, 's' in this
+  case, are global to this constraint.
+
+Note that it is vital that we instantiate the `c` in $gdm_bar's type with a new
+unification variable for each iteration of simplifyDeriv. If we re-use the same
+unification variable across multiple iterations, then bad things can happen,
+such as Trac #14933.
+
+Similarly for 'baz', givng the constraint C2
+
+   forall[2]. Eq (Maybe s) => (Ord a, Show a,
+                              Maybe s -> Maybe s -> Bool
+                                ~ Maybe s -> Maybe s -> Bool)
+
+In this case baz has no local quantification, so the implication
+constraint has no local skolems and there are no unification
+variables.
+
+[STEP DAC SOLVE]
+We can combine these two implication constraints into a single
+constraint (C1, C2), and simplify, unifying cc:=b, to get:
+
+   forall[2] b. Ix b => Show a
+   /\
+   forall[2]. Eq (Maybe s) => (Ord a, Show a)
+
+[STEP DAC HOIST]
+Let's call that (C1', C2').  Now we need to hoist the unsolved
+constraints out of the implications to become our candidate for
+(CX). That is done by approximateWC, which will return:
+
+  (Show a, Ord a, Show a)
+
+Now we can use mkMinimalBySCs to remove superclasses and duplicates, giving
+
+  (Show a, Ord a)
+
+And that's what GHC uses for CX.
+
+[STEP DAC RESIDUAL]
+In this case we have solved all the leftover constraints, but what if
+we don't?  Simple!  We just form the final residual constraint
+
+   forall[1] s. CX => (C1',C2')
+
+and simplify that. In simple cases it'll succeed easily, because CX
+literally contains the constraints in C1', C2', but if there is anything
+more complicated it will be reported in a civilised way.
+
+Note [Error reporting for deriving clauses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A suprisingly tricky aspect of deriving to get right is reporting sensible
+error messages. In particular, if simplifyDeriv reaches a constraint that it
+cannot solve, which might include:
+
+1. Insoluble constraints
+2. "Exotic" constraints (See Note [Exotic derived instance contexts])
+
+Then we report an error immediately in simplifyDeriv.
+
+Another possible choice is to punt and let another part of the typechecker
+(e.g., simplifyInstanceContexts) catch the errors. But this tends to lead
+to worse error messages, so we do it directly in simplifyDeriv.
+
+simplifyDeriv checks for errors in a clever way. If the deriving machinery
+infers the context (Foo a)--that is, if this instance is to be generated:
+
+  instance Foo a => ...
+
+Then we form an implication of the form:
+
+  forall a. Foo a => <residual_wanted_constraints>
+
+And pass it to the simplifier. If the context (Foo a) is enough to discharge
+all the constraints in <residual_wanted_constraints>, then everything is
+hunky-dory. But if <residual_wanted_constraints> contains, say, an insoluble
+constraint, then (Foo a) won't be able to solve it, causing GHC to error.
+
+Note [Exotic derived instance contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a 'derived' instance declaration, we *infer* the context.  It's a
+bit unclear what rules we should apply for this; the Haskell report is
+silent.  Obviously, constraints like (Eq a) are fine, but what about
+        data T f a = MkT (f a) deriving( Eq )
+where we'd get an Eq (f a) constraint.  That's probably fine too.
+
+One could go further: consider
+        data T a b c = MkT (Foo a b c) deriving( Eq )
+        instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)
+
+Notice that this instance (just) satisfies the Paterson termination
+conditions.  Then we *could* derive an instance decl like this:
+
+        instance (C Int a, Eq b, Eq c) => Eq (T a b c)
+even though there is no instance for (C Int a), because there just
+*might* be an instance for, say, (C Int Bool) at a site where we
+need the equality instance for T's.
+
+However, this seems pretty exotic, and it's quite tricky to allow
+this, and yet give sensible error messages in the (much more common)
+case where we really want that instance decl for C.
+
+So for now we simply require that the derived instance context
+should have only type-variable constraints.
+
+Here is another example:
+        data Fix f = In (f (Fix f)) deriving( Eq )
+Here, if we are prepared to allow -XUndecidableInstances we
+could derive the instance
+        instance Eq (f (Fix f)) => Eq (Fix f)
+but this is so delicate that I don't think it should happen inside
+'deriving'. If you want this, write it yourself!
+
+NB: if you want to lift this condition, make sure you still meet the
+termination conditions!  If not, the deriving mechanism generates
+larger and larger constraints.  Example:
+  data Succ a = S a
+  data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show
+
+Note the lack of a Show instance for Succ.  First we'll generate
+  instance (Show (Succ a), Show a) => Show (Seq a)
+and then
+  instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)
+and so on.  Instead we want to complain of no instance for (Show (Succ a)).
+
+The bottom line
+~~~~~~~~~~~~~~~
+Allow constraints which consist only of type variables, with no repeats.
+-}
diff --git a/compiler/typecheck/TcDerivUtils.hs b/compiler/typecheck/TcDerivUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcDerivUtils.hs
@@ -0,0 +1,974 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Error-checking and other utilities for @deriving@ clauses or declarations.
+-}
+
+{-# LANGUAGE TypeFamilies #-}
+
+module TcDerivUtils (
+        DerivM, DerivEnv(..),
+        DerivSpec(..), pprDerivSpec,
+        DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,
+        isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia,
+        DerivContext(..), OriginativeDerivStatus(..),
+        isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin,
+        PredOrigin(..), ThetaOrigin(..), mkPredOrigin,
+        mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin,
+        checkOriginativeSideConditions, hasStockDeriving,
+        canDeriveAnyClass,
+        std_class_via_coercible, non_coercible_class,
+        newDerivClsInst, extendLocalInstEnv
+    ) where
+
+import GhcPrelude
+
+import Bag
+import BasicTypes
+import Class
+import DataCon
+import DynFlags
+import ErrUtils
+import HscTypes (lookupFixity, mi_fix)
+import HsSyn
+import Inst
+import InstEnv
+import LoadIface (loadInterfaceForName)
+import Module (getModule)
+import Name
+import Outputable
+import PrelNames
+import SrcLoc
+import TcGenDeriv
+import TcGenFunctor
+import TcGenGenerics
+import TcRnMonad
+import TcType
+import THNames (liftClassKey)
+import TyCon
+import Type
+import Util
+import VarSet
+
+import Control.Monad.Trans.Reader
+import Data.Maybe
+import qualified GHC.LanguageExtensions as LangExt
+import ListSetOps (assocMaybe)
+
+-- | To avoid having to manually plumb everything in 'DerivEnv' throughout
+-- various functions in @TcDeriv@ and @TcDerivInfer@, we use 'DerivM', which
+-- is a simple reader around 'TcRn'.
+type DerivM = ReaderT DerivEnv TcRn
+
+-- | Is GHC processing a standalone deriving declaration?
+isStandaloneDeriv :: DerivM Bool
+isStandaloneDeriv = asks (go . denv_ctxt)
+  where
+    go :: DerivContext -> Bool
+    go (InferContext wildcard) = isJust wildcard
+    go (SupplyContext {})      = True
+
+-- | Is GHC processing a standalone deriving declaration with an
+-- extra-constraints wildcard as the context?
+-- (e.g., @deriving instance _ => Eq (Foo a)@)
+isStandaloneWildcardDeriv :: DerivM Bool
+isStandaloneWildcardDeriv = asks (go . denv_ctxt)
+  where
+    go :: DerivContext -> Bool
+    go (InferContext wildcard) = isJust wildcard
+    go (SupplyContext {})      = False
+
+-- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True',
+-- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting.
+mkDerivOrigin :: Bool -> CtOrigin
+mkDerivOrigin standalone_wildcard
+  | standalone_wildcard = StandAloneDerivOrigin
+  | otherwise           = DerivClauseOrigin
+
+-- | Contains all of the information known about a derived instance when
+-- determining what its @EarlyDerivSpec@ should be.
+data DerivEnv = DerivEnv
+  { denv_overlap_mode :: Maybe OverlapMode
+    -- ^ Is this an overlapping instance?
+  , denv_tvs          :: [TyVar]
+    -- ^ Universally quantified type variables in the instance
+  , denv_cls          :: Class
+    -- ^ Class for which we need to derive an instance
+  , denv_cls_tys      :: [Type]
+    -- ^ Other arguments to the class except the last
+  , denv_tc           :: TyCon
+    -- ^ Type constructor for which the instance is requested
+    --   (last arguments to the type class)
+  , denv_tc_args      :: [Type]
+    -- ^ Arguments to the type constructor
+  , denv_rep_tc       :: TyCon
+    -- ^ The representation tycon for 'denv_tc'
+    --   (for data family instances)
+  , denv_rep_tc_args  :: [Type]
+    -- ^ The representation types for 'denv_tc_args'
+    --   (for data family instances)
+  , denv_ctxt         :: DerivContext
+    -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the
+    --   context of the instance).
+    --   'InferContext' for @deriving@ clauses, or for standalone deriving that
+    --   uses a wildcard constraint.
+    --   See @Note [Inferring the instance context]@.
+  , denv_strat        :: Maybe (DerivStrategy GhcTc)
+    -- ^ 'Just' if user requests a particular deriving strategy.
+    --   Otherwise, 'Nothing'.
+  }
+
+instance Outputable DerivEnv where
+  ppr (DerivEnv { denv_overlap_mode = overlap_mode
+                , denv_tvs          = tvs
+                , denv_cls          = cls
+                , denv_cls_tys      = cls_tys
+                , denv_tc           = tc
+                , denv_tc_args      = tc_args
+                , denv_rep_tc       = rep_tc
+                , denv_rep_tc_args  = rep_tc_args
+                , denv_ctxt         = ctxt
+                , denv_strat        = mb_strat })
+    = hang (text "DerivEnv")
+         2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode
+                 , text "denv_tvs"          <+> ppr tvs
+                 , text "denv_cls"          <+> ppr cls
+                 , text "denv_cls_tys"      <+> ppr cls_tys
+                 , text "denv_tc"           <+> ppr tc
+                 , text "denv_tc_args"      <+> ppr tc_args
+                 , text "denv_rep_tc"       <+> ppr rep_tc
+                 , text "denv_rep_tc_args"  <+> ppr rep_tc_args
+                 , text "denv_ctxt"         <+> ppr ctxt
+                 , text "denv_strat"        <+> ppr mb_strat ])
+
+data DerivSpec theta = DS { ds_loc                 :: SrcSpan
+                          , ds_name                :: Name         -- DFun name
+                          , ds_tvs                 :: [TyVar]
+                          , ds_theta               :: theta
+                          , ds_cls                 :: Class
+                          , ds_tys                 :: [Type]
+                          , ds_tc                  :: TyCon
+                          , ds_overlap             :: Maybe OverlapMode
+                          , ds_standalone_wildcard :: Maybe SrcSpan
+                              -- See Note [Inferring the instance context]
+                              -- in TcDerivInfer
+                          , ds_mechanism           :: DerivSpecMechanism }
+        -- This spec implies a dfun declaration of the form
+        --       df :: forall tvs. theta => C tys
+        -- The Name is the name for the DFun we'll build
+        -- The tyvars bind all the variables in the theta
+        -- For type families, the tycon in
+        --       in ds_tys is the *family* tycon
+        --       in ds_tc is the *representation* type
+        -- For non-family tycons, both are the same
+
+        -- the theta is either the given and final theta, in standalone deriving,
+        -- or the not-yet-simplified list of constraints together with their origin
+
+        -- ds_mechanism specifies the means by which GHC derives the instance.
+        -- See Note [Deriving strategies] in TcDeriv
+
+{-
+Example:
+
+     newtype instance T [a] = MkT (Tree a) deriving( C s )
+==>
+     axiom T [a] = :RTList a
+     axiom :RTList a = Tree a
+
+     DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
+        , ds_tc = :RTList, ds_mechanism = DerivSpecNewtype (Tree a) }
+-}
+
+pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc
+pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,
+                   ds_tys = tys, ds_theta = rhs,
+                   ds_standalone_wildcard = wildcard, ds_mechanism = mech })
+  = hang (text "DerivSpec")
+       2 (vcat [ text "ds_loc                  =" <+> ppr l
+               , text "ds_name                 =" <+> ppr n
+               , text "ds_tvs                  =" <+> ppr tvs
+               , text "ds_cls                  =" <+> ppr c
+               , text "ds_tys                  =" <+> ppr tys
+               , text "ds_theta                =" <+> ppr rhs
+               , text "ds_standalone_wildcard  =" <+> ppr wildcard
+               , text "ds_mechanism            =" <+> ppr mech ])
+
+instance Outputable theta => Outputable (DerivSpec theta) where
+  ppr = pprDerivSpec
+
+-- What action to take in order to derive a class instance.
+-- See Note [Deriving strategies] in TcDeriv
+data DerivSpecMechanism
+  = DerivSpecStock   -- "Standard" classes
+      (SrcSpan -> TyCon
+               -> [Type]
+               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
+      -- This function returns three things:
+      --
+      -- 1. @LHsBinds GhcPs@: The derived instance's function bindings
+      --    (e.g., @compare (T x) (T y) = compare x y@)
+      -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived
+      --    instance. As examples, derived 'Generic' instances require
+      --    associated type family instances, and derived 'Eq' and 'Ord'
+      --    instances require top-level @con2tag@ functions.
+      --    See Note [Auxiliary binders] in TcGenDeriv.
+      -- 3. @[Name]@: A list of Names for which @-Wunused-binds@ should be
+      --    suppressed. This is used to suppress unused warnings for record
+      --    selectors when deriving 'Read', 'Show', or 'Generic'.
+      --    See Note [Deriving and unused record selectors].
+
+  | DerivSpecNewtype -- -XGeneralizedNewtypeDeriving
+      Type -- The newtype rep type
+
+  | DerivSpecAnyClass -- -XDeriveAnyClass
+
+  | DerivSpecVia -- -XDerivingVia
+      Type -- The @via@ type
+
+-- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'.
+derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc
+derivSpecMechanismToStrategy DerivSpecStock{}   = StockStrategy
+derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy
+derivSpecMechanismToStrategy DerivSpecAnyClass  = AnyclassStrategy
+derivSpecMechanismToStrategy (DerivSpecVia t)   = ViaStrategy t
+
+isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia
+  :: DerivSpecMechanism -> Bool
+isDerivSpecStock (DerivSpecStock{}) = True
+isDerivSpecStock _                  = False
+
+isDerivSpecNewtype (DerivSpecNewtype{}) = True
+isDerivSpecNewtype _                    = False
+
+isDerivSpecAnyClass DerivSpecAnyClass = True
+isDerivSpecAnyClass _                 = False
+
+isDerivSpecVia (DerivSpecVia{}) = True
+isDerivSpecVia _                = False
+
+instance Outputable DerivSpecMechanism where
+  ppr (DerivSpecStock{})   = text "DerivSpecStock"
+  ppr (DerivSpecNewtype t) = text "DerivSpecNewtype" <> colon <+> ppr t
+  ppr DerivSpecAnyClass    = text "DerivSpecAnyClass"
+  ppr (DerivSpecVia t)     = text "DerivSpecVia" <> colon <+> ppr t
+
+-- | Whether GHC is processing a @deriving@ clause or a standalone deriving
+-- declaration.
+data DerivContext
+  = InferContext (Maybe SrcSpan) -- ^ @'InferContext mb_wildcard@ is either:
+                                 --
+                                 -- * A @deriving@ clause (in which case
+                                 --   @mb_wildcard@ is 'Nothing').
+                                 --
+                                 -- * A standalone deriving declaration with
+                                 --   an extra-constraints wildcard as the
+                                 --   context (in which case @mb_wildcard@ is
+                                 --   @'Just' loc@, where @loc@ is the location
+                                 --   of the wildcard.
+                                 --
+                                 -- GHC should infer the context.
+
+  | SupplyContext ThetaType      -- ^ @'SupplyContext' theta@ is a standalone
+                                 -- deriving declaration, where @theta@ is the
+                                 -- context supplied by the user.
+
+instance Outputable DerivContext where
+  ppr (InferContext standalone) = text "InferContext"  <+> ppr standalone
+  ppr (SupplyContext theta)     = text "SupplyContext" <+> ppr theta
+
+-- | Records whether a particular class can be derived by way of an
+-- /originative/ deriving strategy (i.e., @stock@ or @anyclass@).
+--
+-- See @Note [Deriving strategies]@ in "TcDeriv".
+data OriginativeDerivStatus
+  = CanDeriveStock            -- Stock class, can derive
+      (SrcSpan -> TyCon -> [Type]
+               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
+  | StockClassError SDoc      -- Stock class, but can't do it
+  | CanDeriveAnyClass         -- See Note [Deriving any class]
+  | NonDerivableClass SDoc    -- Cannot derive with either stock or anyclass
+
+-- A stock class is one either defined in the Haskell report or for which GHC
+-- otherwise knows how to generate code for (possibly requiring the use of a
+-- language extension), such as Eq, Ord, Ix, Data, Generic, etc.)
+
+-- | A 'PredType' annotated with the origin of the constraint 'CtOrigin',
+-- and whether or the constraint deals in types or kinds.
+data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind
+
+-- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') to
+-- simplify when inferring a derived instance's context. These are used in all
+-- deriving strategies, but in the particular case of @DeriveAnyClass@, we
+-- need extra information. In particular, we need:
+--
+-- * 'to_anyclass_skols', the list of type variables bound by a class method's
+--   regular type signature, which should be rigid.
+--
+-- * 'to_anyclass_metas', the list of type variables bound by a class method's
+--   default type signature. These can be unified as necessary.
+--
+-- * 'to_anyclass_givens', the list of constraints from a class method's
+--   regular type signature, which can be used to help solve constraints
+--   in the 'to_wanted_origins'.
+--
+-- (Note that 'to_wanted_origins' will likely contain type variables from the
+-- derived type class or data type, neither of which will appear in
+-- 'to_anyclass_skols' or 'to_anyclass_metas'.)
+--
+-- For all other deriving strategies, it is always the case that
+-- 'to_anyclass_skols', 'to_anyclass_metas', and 'to_anyclass_givens' are
+-- empty.
+--
+-- Here is an example to illustrate this:
+--
+-- @
+-- class Foo a where
+--   bar :: forall b. Ix b => a -> b -> String
+--   default bar :: forall y. (Show a, Ix y) => a -> y -> String
+--   bar x y = show x ++ show (range (y, y))
+--
+--   baz :: Eq a => a -> a -> Bool
+--   default baz :: Ord a => a -> a -> Bool
+--   baz x y = compare x y == EQ
+--
+-- data Quux q = Quux deriving anyclass Foo
+-- @
+--
+-- Then it would generate two 'ThetaOrigin's, one for each method:
+--
+-- @
+-- [ ThetaOrigin { to_anyclass_skols  = [b]
+--               , to_anyclass_metas  = [y]
+--               , to_anyclass_givens = [Ix b]
+--               , to_wanted_origins  = [ Show (Quux q), Ix y
+--                                      , (Quux q -> b -> String) ~
+--                                        (Quux q -> y -> String)
+--                                      ] }
+-- , ThetaOrigin { to_anyclass_skols  = []
+--               , to_anyclass_metas  = []
+--               , to_anyclass_givens = [Eq (Quux q)]
+--               , to_wanted_origins  = [ Ord (Quux q)
+--                                      , (Quux q -> Quux q -> Bool) ~
+--                                        (Quux q -> Quux q -> Bool)
+--                                      ] }
+-- ]
+-- @
+--
+-- (Note that the type variable @q@ is bound by the data type @Quux@, and thus
+-- it appears in neither 'to_anyclass_skols' nor 'to_anyclass_metas'.)
+--
+-- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@
+-- in "TcDerivInfer" for an explanation of how 'to_wanted_origins' are
+-- determined in @DeriveAnyClass@, as well as how 'to_anyclass_skols',
+-- 'to_anyclass_metas', and 'to_anyclass_givens' are used.
+data ThetaOrigin
+  = ThetaOrigin { to_anyclass_skols  :: [TyVar]
+                , to_anyclass_metas  :: [TyVar]
+                , to_anyclass_givens :: ThetaType
+                , to_wanted_origins  :: [PredOrigin] }
+
+instance Outputable PredOrigin where
+  ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging
+
+instance Outputable ThetaOrigin where
+  ppr (ThetaOrigin { to_anyclass_skols  = ac_skols
+                   , to_anyclass_metas  = ac_metas
+                   , to_anyclass_givens = ac_givens
+                   , to_wanted_origins  = wanted_origins })
+    = hang (text "ThetaOrigin")
+         2 (vcat [ text "to_anyclass_skols  =" <+> ppr ac_skols
+                 , text "to_anyclass_metas  =" <+> ppr ac_metas
+                 , text "to_anyclass_givens =" <+> ppr ac_givens
+                 , text "to_wanted_origins  =" <+> ppr wanted_origins ])
+
+mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin
+mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k
+
+mkThetaOrigin :: CtOrigin -> TypeOrKind
+              -> [TyVar] -> [TyVar] -> ThetaType -> ThetaType
+              -> ThetaOrigin
+mkThetaOrigin origin t_or_k skols metas givens
+  = ThetaOrigin skols metas givens . map (mkPredOrigin origin t_or_k)
+
+-- A common case where the ThetaOrigin only contains wanted constraints, with
+-- no givens or locally scoped type variables.
+mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin
+mkThetaOriginFromPreds = ThetaOrigin [] [] []
+
+substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin
+substPredOrigin subst (PredOrigin pred origin t_or_k)
+  = PredOrigin (substTy subst pred) origin t_or_k
+
+{-
+************************************************************************
+*                                                                      *
+                Class deriving diagnostics
+*                                                                      *
+************************************************************************
+
+Only certain blessed classes can be used in a deriving clause (without the
+assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes
+are listed below in the definition of hasStockDeriving. The stockSideConditions
+function determines the criteria that needs to be met in order for a particular
+stock class to be able to be derived successfully.
+
+A class might be able to be used in a deriving clause if -XDeriveAnyClass
+is willing to support it. The canDeriveAnyClass function checks if this is the
+case.
+-}
+
+hasStockDeriving
+  :: Class -> Maybe (SrcSpan
+                     -> TyCon
+                     -> [Type]
+                     -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
+hasStockDeriving clas
+  = assocMaybe gen_list (getUnique clas)
+  where
+    gen_list
+      :: [(Unique, SrcSpan
+                   -> TyCon
+                   -> [Type]
+                   -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))]
+    gen_list = [ (eqClassKey,          simpleM gen_Eq_binds)
+               , (ordClassKey,         simpleM gen_Ord_binds)
+               , (enumClassKey,        simpleM gen_Enum_binds)
+               , (boundedClassKey,     simple gen_Bounded_binds)
+               , (ixClassKey,          simpleM gen_Ix_binds)
+               , (showClassKey,        read_or_show gen_Show_binds)
+               , (readClassKey,        read_or_show gen_Read_binds)
+               , (dataClassKey,        simpleM gen_Data_binds)
+               , (functorClassKey,     simple gen_Functor_binds)
+               , (foldableClassKey,    simple gen_Foldable_binds)
+               , (traversableClassKey, simple gen_Traversable_binds)
+               , (liftClassKey,        simple gen_Lift_binds)
+               , (genClassKey,         generic (gen_Generic_binds Gen0))
+               , (gen1ClassKey,        generic (gen_Generic_binds Gen1)) ]
+
+    simple gen_fn loc tc _
+      = let (binds, deriv_stuff) = gen_fn loc tc
+        in return (binds, deriv_stuff, [])
+
+    simpleM gen_fn loc tc _
+      = do { (binds, deriv_stuff) <- gen_fn loc tc
+           ; return (binds, deriv_stuff, []) }
+
+    read_or_show gen_fn loc tc _
+      = do { fix_env <- getDataConFixityFun tc
+           ; let (binds, deriv_stuff) = gen_fn fix_env loc tc
+                 field_names          = all_field_names tc
+           ; return (binds, deriv_stuff, field_names) }
+
+    generic gen_fn _ tc inst_tys
+      = do { (binds, faminst) <- gen_fn tc inst_tys
+           ; let field_names = all_field_names tc
+           ; return (binds, unitBag (DerivFamInst faminst), field_names) }
+
+    -- See Note [Deriving and unused record selectors]
+    all_field_names = map flSelector . concatMap dataConFieldLabels
+                                     . tyConDataCons
+
+{-
+Note [Deriving and unused record selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (see Trac #13919):
+
+  module Main (main) where
+
+  data Foo = MkFoo {bar :: String} deriving Show
+
+  main :: IO ()
+  main = print (Foo "hello")
+
+Strictly speaking, the record selector `bar` is unused in this module, since
+neither `main` nor the derived `Show` instance for `Foo` mention `bar`.
+However, the behavior of `main` is affected by the presence of `bar`, since
+it will print different output depending on whether `MkFoo` is defined using
+record selectors or not. Therefore, we do not to issue a
+"Defined but not used: ‘bar’" warning for this module, since removing `bar`
+changes the program's behavior. This is the reason behind the [Name] part of
+the return type of `hasStockDeriving`—it tracks all of the record selector
+`Name`s for which -Wunused-binds should be suppressed.
+
+Currently, the only three stock derived classes that require this are Read,
+Show, and Generic, as their derived code all depend on the record selectors
+of the derived data type's constructors.
+
+See also Note [Newtype deriving and unused constructors] in TcDeriv for
+another example of a similar trick.
+-}
+
+getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
+-- If the TyCon is locally defined, we want the local fixity env;
+-- but if it is imported (which happens for standalone deriving)
+-- we need to get the fixity env from the interface file
+-- c.f. RnEnv.lookupFixity, and Trac #9830
+getDataConFixityFun tc
+  = do { this_mod <- getModule
+       ; if nameIsLocalOrFrom this_mod name
+         then do { fix_env <- getFixityEnv
+                 ; return (lookupFixity fix_env) }
+         else do { iface <- loadInterfaceForName doc name
+                            -- Should already be loaded!
+                 ; return (mi_fix iface . nameOccName) } }
+  where
+    name = tyConName tc
+    doc = text "Data con fixities for" <+> ppr name
+
+------------------------------------------------------------------
+-- Check side conditions that dis-allow derivability for the originative
+-- deriving strategies (stock and anyclass).
+-- See Note [Deriving strategies] in TcDeriv for an explanation of what
+-- "originative" means.
+--
+-- This is *apart* from the coerce-based strategies, newtype and via.
+--
+-- Here we get the representation tycon in case of family instances as it has
+-- the data constructors - but we need to be careful to fall back to the
+-- family tycon (with indexes) in error messages.
+
+checkOriginativeSideConditions
+  :: DynFlags -> DerivContext -> Class -> [TcType]
+  -> TyCon -> TyCon
+  -> OriginativeDerivStatus
+checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc
+    -- First, check if stock deriving is possible...
+  | Just cond <- stockSideConditions deriv_ctxt cls
+  = case (cond dflags tc rep_tc) of
+        NotValid err -> StockClassError err  -- Class-specific error
+        IsValid  | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)
+                   -- All stock derivable classes are unary in the sense that
+                   -- there should be not types in cls_tys (i.e., no type args
+                   -- other than last). Note that cls_types can contain
+                   -- invisible types as well (e.g., for Generic1, which is
+                   -- poly-kinded), so make sure those are not counted.
+                 , Just gen_fn <- hasStockDeriving cls
+                   -> CanDeriveStock gen_fn
+                 | otherwise -> StockClassError (classArgsErr cls cls_tys)
+                   -- e.g. deriving( Eq s )
+
+    -- ...if not, try falling back on DeriveAnyClass.
+  | NotValid err <- canDeriveAnyClass dflags
+  = NonDerivableClass err  -- Neither anyclass nor stock work
+
+  | otherwise
+  = CanDeriveAnyClass   -- DeriveAnyClass should work
+
+classArgsErr :: Class -> [Type] -> SDoc
+classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class"
+
+-- Side conditions (whether the datatype must have at least one constructor,
+-- required language extensions, etc.) for using GHC's stock deriving
+-- mechanism on certain classes (as opposed to classes that require
+-- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a
+-- class for which stock deriving isn't possible.
+stockSideConditions :: DerivContext -> Class -> Maybe Condition
+stockSideConditions deriv_ctxt cls
+  | cls_key == eqClassKey          = Just (cond_std `andCond` cond_args cls)
+  | cls_key == ordClassKey         = Just (cond_std `andCond` cond_args cls)
+  | cls_key == showClassKey        = Just (cond_std `andCond` cond_args cls)
+  | cls_key == readClassKey        = Just (cond_std `andCond` cond_args cls)
+  | cls_key == enumClassKey        = Just (cond_std `andCond` cond_isEnumeration)
+  | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct cls)
+  | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct cls)
+  | cls_key == dataClassKey        = Just (checkFlag LangExt.DeriveDataTypeable `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_args cls)
+  | cls_key == functorClassKey     = Just (checkFlag LangExt.DeriveFunctor `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_functorOK True False)
+  | cls_key == foldableClassKey    = Just (checkFlag LangExt.DeriveFoldable `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_functorOK False True)
+                                           -- Functor/Fold/Trav works ok
+                                           -- for rank-n types
+  | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_functorOK False False)
+  | cls_key == genClassKey         = Just (checkFlag LangExt.DeriveGeneric `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_RepresentableOk)
+  | cls_key == gen1ClassKey        = Just (checkFlag LangExt.DeriveGeneric `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_Representable1Ok)
+  | cls_key == liftClassKey        = Just (checkFlag LangExt.DeriveLift `andCond`
+                                           cond_vanilla `andCond`
+                                           cond_args cls)
+  | otherwise                      = Nothing
+  where
+    cls_key = getUnique cls
+    cond_std     = cond_stdOK deriv_ctxt False
+      -- Vanilla data constructors, at least one, and monotype arguments
+    cond_vanilla = cond_stdOK deriv_ctxt True
+      -- Vanilla data constructors but allow no data cons or polytype arguments
+
+canDeriveAnyClass :: DynFlags -> Validity
+-- IsValid: we can (try to) derive it via an empty instance declaration
+-- NotValid s:  we can't, reason s
+canDeriveAnyClass dflags
+  | not (xopt LangExt.DeriveAnyClass dflags)
+  = NotValid (text "Try enabling DeriveAnyClass")
+  | otherwise
+  = IsValid   -- OK!
+
+type Condition
+   = DynFlags
+
+  -> TyCon    -- ^ The data type's 'TyCon'. For data families, this is the
+              -- family 'TyCon'.
+
+  -> TyCon    -- ^ For data families, this is the representation 'TyCon'.
+              -- Otherwise, this is the same as the other 'TyCon' argument.
+
+  -> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is
+              -- possible. Otherwise, it's @'NotValid' err@, where @err@
+              -- explains what went wrong.
+
+orCond :: Condition -> Condition -> Condition
+orCond c1 c2 dflags tc rep_tc
+  = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of
+     (IsValid,    _)          -> IsValid    -- c1 succeeds
+     (_,          IsValid)    -> IsValid    -- c21 succeeds
+     (NotValid x, NotValid y) -> NotValid (x $$ text "  or" $$ y)
+                                            -- Both fail
+
+andCond :: Condition -> Condition -> Condition
+andCond c1 c2 dflags tc rep_tc
+  = c1 dflags tc rep_tc `andValid` c2 dflags tc rep_tc
+
+-- | Some common validity checks shared among stock derivable classes. One
+-- check that absolutely must hold is that if an instance @C (T a)@ is being
+-- derived, then @T@ must be a tycon for a data type or a newtype. The
+-- remaining checks are only performed if using a @deriving@ clause (i.e.,
+-- they're ignored if using @StandaloneDeriving@):
+--
+-- 1. The data type must have at least one constructor (this check is ignored
+--    if using @EmptyDataDeriving@).
+--
+-- 2. The data type cannot have any GADT constructors.
+--
+-- 3. The data type cannot have any constructors with existentially quantified
+--    type variables.
+--
+-- 4. The data type cannot have a context (e.g., @data Foo a = Eq a => MkFoo@).
+--
+-- 5. The data type cannot have fields with higher-rank types.
+cond_stdOK
+  :: DerivContext -- ^ 'SupplyContext' if this is standalone deriving with a
+                  -- user-supplied context, 'InferContext' if not.
+                  -- If it is the former, we relax some of the validity checks
+                  -- we would otherwise perform (i.e., "just go for it").
+
+  -> Bool         -- ^ 'True' <=> allow higher rank arguments and empty data
+                  -- types (with no data constructors) even in the absence of
+                  -- the -XEmptyDataDeriving extension.
+
+  -> Condition
+cond_stdOK deriv_ctxt permissive dflags tc rep_tc
+  = valid_ADT `andValid` valid_misc
+  where
+    valid_ADT, valid_misc :: Validity
+    valid_ADT
+      | isAlgTyCon tc || isDataFamilyTyCon tc
+      = IsValid
+      | otherwise
+        -- Complain about functions, primitive types, and other tycons that
+        -- stock deriving can't handle.
+      = NotValid $ text "The last argument of the instance must be a"
+               <+> text "data or newtype application"
+
+    valid_misc
+      = case deriv_ctxt of
+         SupplyContext _ -> IsValid
+                -- Don't check these conservative conditions for
+                -- standalone deriving; just generate the code
+                -- and let the typechecker handle the result
+         InferContext wildcard
+           | null data_cons -- 1.
+           , not permissive
+           -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid`
+              NotValid (no_cons_why rep_tc $$ empty_data_suggestion)
+           | not (null con_whys)
+           -> NotValid (vcat con_whys $$ possible_fix_suggestion wildcard)
+           | otherwise
+           -> IsValid
+
+    empty_data_suggestion =
+      text "Use EmptyDataDeriving to enable deriving for empty data types"
+    possible_fix_suggestion wildcard
+      = case wildcard of
+          Just _ ->
+            text "Possible fix: fill in the wildcard constraint yourself"
+          Nothing ->
+            text "Possible fix: use a standalone deriving declaration instead"
+    data_cons  = tyConDataCons rep_tc
+    con_whys   = getInvalids (map check_con data_cons)
+
+    check_con :: DataCon -> Validity
+    check_con con
+      | not (null eq_spec) -- 2.
+      = bad "is a GADT"
+      | not (null ex_tvs) -- 3.
+      = bad "has existential type variables in its type"
+      | not (null theta) -- 4.
+      = bad "has constraints in its type"
+      | not (permissive || all isTauTy (dataConOrigArgTys con)) -- 5.
+      = bad "has a higher-rank type"
+      | otherwise
+      = IsValid
+      where
+        (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con
+        bad msg = NotValid (badCon con (text msg))
+
+no_cons_why :: TyCon -> SDoc
+no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
+                     text "must have at least one data constructor"
+
+cond_RepresentableOk :: Condition
+cond_RepresentableOk _ _ rep_tc = canDoGenerics rep_tc
+
+cond_Representable1Ok :: Condition
+cond_Representable1Ok _ _ rep_tc = canDoGenerics1 rep_tc
+
+cond_enumOrProduct :: Class -> Condition
+cond_enumOrProduct cls = cond_isEnumeration `orCond`
+                         (cond_isProduct `andCond` cond_args cls)
+
+cond_args :: Class -> Condition
+-- For some classes (eg Eq, Ord) we allow unlifted arg types
+-- by generating specialised code.  For others (eg Data) we don't.
+cond_args cls _ _ rep_tc
+  = case bad_args of
+      []     -> IsValid
+      (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls))
+                             2 (text "for type" <+> quotes (ppr ty)))
+  where
+    bad_args = [ arg_ty | con <- tyConDataCons rep_tc
+                        , arg_ty <- dataConOrigArgTys con
+                        , isUnliftedType arg_ty
+                        , not (ok_ty arg_ty) ]
+
+    cls_key = classKey cls
+    ok_ty arg_ty
+     | cls_key == eqClassKey   = check_in arg_ty ordOpTbl
+     | cls_key == ordClassKey  = check_in arg_ty ordOpTbl
+     | cls_key == showClassKey = check_in arg_ty boxConTbl
+     | cls_key == liftClassKey = check_in arg_ty litConTbl
+     | otherwise               = False    -- Read, Ix etc
+
+    check_in :: Type -> [(Type,a)] -> Bool
+    check_in arg_ty tbl = any (eqType arg_ty . fst) tbl
+
+
+cond_isEnumeration :: Condition
+cond_isEnumeration _ _ rep_tc
+  | isEnumerationTyCon rep_tc = IsValid
+  | otherwise                 = NotValid why
+  where
+    why = sep [ quotes (pprSourceTyCon rep_tc) <+>
+                  text "must be an enumeration type"
+              , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]
+                  -- See Note [Enumeration types] in TyCon
+
+cond_isProduct :: Condition
+cond_isProduct _ _ rep_tc
+  | isProductTyCon rep_tc = IsValid
+  | otherwise             = NotValid why
+  where
+    why = quotes (pprSourceTyCon rep_tc) <+>
+          text "must have precisely one constructor"
+
+cond_functorOK :: Bool -> Bool -> Condition
+-- OK for Functor/Foldable/Traversable class
+-- Currently: (a) at least one argument
+--            (b) don't use argument contravariantly
+--            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
+--            (d) optionally: don't use function types
+--            (e) no "stupid context" on data type
+cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc
+  | null tc_tvs
+  = NotValid (text "Data type" <+> quotes (ppr rep_tc)
+              <+> text "must have some type parameters")
+
+  | not (null bad_stupid_theta)
+  = NotValid (text "Data type" <+> quotes (ppr rep_tc)
+              <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)
+
+  | otherwise
+  = allValid (map check_con data_cons)
+  where
+    tc_tvs            = tyConTyVars rep_tc
+    Just (_, last_tv) = snocView tc_tvs
+    bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)
+    is_bad pred       = last_tv `elemVarSet` exactTyCoVarsOfType pred
+      -- See Note [Check that the type variable is truly universal]
+
+    data_cons = tyConDataCons rep_tc
+    check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con)
+
+    check_universal :: DataCon -> Validity
+    check_universal con
+      | allowExQuantifiedLastTyVar
+      = IsValid -- See Note [DeriveFoldable with ExistentialQuantification]
+                -- in TcGenFunctor
+      | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))
+      , tv `elem` dataConUnivTyVars con
+      , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con))
+      = IsValid   -- See Note [Check that the type variable is truly universal]
+      | otherwise
+      = NotValid (badCon con existential)
+
+    ft_check :: DataCon -> FFoldType Validity
+    ft_check con = FT { ft_triv = IsValid, ft_var = IsValid
+                      , ft_co_var = NotValid (badCon con covariant)
+                      , ft_fun = \x y -> if allowFunctions then x `andValid` y
+                                                           else NotValid (badCon con functions)
+                      , ft_tup = \_ xs  -> allValid xs
+                      , ft_ty_app = \_ x   -> x
+                      , ft_bad_app = NotValid (badCon con wrong_arg)
+                      , ft_forall = \_ x   -> x }
+
+    existential = text "must be truly polymorphic in the last argument of the data type"
+    covariant   = text "must not use the type variable in a function argument"
+    functions   = text "must not contain function types"
+    wrong_arg   = text "must use the type variable only as the last argument of a data type"
+
+checkFlag :: LangExt.Extension -> Condition
+checkFlag flag dflags _ _
+  | xopt flag dflags = IsValid
+  | otherwise        = NotValid why
+  where
+    why = text "You need " <> text flag_str
+          <+> text "to derive an instance for this class"
+    flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of
+                 [s]   -> s
+                 other -> pprPanic "checkFlag" (ppr other)
+
+std_class_via_coercible :: Class -> Bool
+-- These standard classes can be derived for a newtype
+-- using the coercible trick *even if no -XGeneralizedNewtypeDeriving
+-- because giving so gives the same results as generating the boilerplate
+std_class_via_coercible clas
+  = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
+        -- Not Read/Show because they respect the type
+        -- Not Enum, because newtypes are never in Enum
+
+
+non_coercible_class :: Class -> Bool
+-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift
+-- by Coercible, even with -XGeneralizedNewtypeDeriving
+-- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived
+-- instance behave differently if there's a non-lawful Applicative out there.
+-- Besides, with roles, Coercible-deriving Traversable is ill-roled.
+non_coercible_class cls
+  = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey
+                         , genClassKey, gen1ClassKey, typeableClassKey
+                         , traversableClassKey, liftClassKey ])
+
+badCon :: DataCon -> SDoc -> SDoc
+badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg
+
+------------------------------------------------------------------
+
+newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst
+newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode
+                          , ds_tvs = tvs, ds_cls = clas, ds_tys = tys })
+  = newClsInst overlap_mode dfun_name tvs theta clas tys
+
+extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
+-- Add new locally-defined instances; don't bother to check
+-- for functional dependency errors -- that'll happen in TcInstDcls
+extendLocalInstEnv dfuns thing_inside
+ = do { env <- getGblEnv
+      ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
+             env'      = env { tcg_inst_env = inst_env' }
+      ; setGblEnv env' thing_inside }
+
+{-
+Note [Deriving any class]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Classic uses of a deriving clause, or a standalone-deriving declaration, are
+for:
+  * a stock class like Eq or Show, for which GHC knows how to generate
+    the instance code
+  * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving
+
+The DeriveAnyClass extension adds a third way to derive instances, based on
+empty instance declarations.
+
+The canonical use case is in combination with GHC.Generics and default method
+signatures. These allow us to have instance declarations being empty, but still
+useful, e.g.
+
+  data T a = ...blah..blah... deriving( Generic )
+  instance C a => C (T a)  -- No 'where' clause
+
+where C is some "random" user-defined class.
+
+This boilerplate code can be replaced by the more compact
+
+  data T a = ...blah..blah... deriving( Generic, C )
+
+if DeriveAnyClass is enabled.
+
+This is not restricted to Generics; any class can be derived, simply giving
+rise to an empty instance.
+
+Unfortunately, it is not clear how to determine the context (when using a
+deriving clause; in standalone deriving, the user provides the context).
+GHC uses the same heuristic for figuring out the class context that it uses for
+Eq in the case of *-kinded classes, and for Functor in the case of
+* -> *-kinded classes. That may not be optimal or even wrong. But in such
+cases, standalone deriving can still be used.
+
+Note [Check that the type variable is truly universal]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For Functor and Traversable instances, we must check that the *last argument*
+of the type constructor is used truly universally quantified.  Example
+
+   data T a b where
+     T1 :: a -> b -> T a b      -- Fine! Vanilla H-98
+     T2 :: b -> c -> T a b      -- Fine! Existential c, but we can still map over 'b'
+     T3 :: b -> T Int b         -- Fine! Constraint 'a', but 'b' is still polymorphic
+     T4 :: Ord b => b -> T a b  -- No!  'b' is constrained
+     T5 :: b -> T b b           -- No!  'b' is constrained
+     T6 :: T a (b,b)            -- No!  'b' is constrained
+
+Notice that only the first of these constructors is vanilla H-98. We only
+need to take care about the last argument (b in this case).  See Trac #8678.
+Eg. for T1-T3 we can write
+
+     fmap f (T1 a b) = T1 a (f b)
+     fmap f (T2 b c) = T2 (f b) c
+     fmap f (T3 x)   = T3 (f x)
+
+We need not perform these checks for Foldable instances, however, since
+functions in Foldable can only consume existentially quantified type variables,
+rather than produce them (as is the case in Functor and Traversable functions.)
+As a result, T can have a derived Foldable instance:
+
+    foldr f z (T1 a b) = f b z
+    foldr f z (T2 b c) = f b z
+    foldr f z (T3 x)   = f x z
+    foldr f z (T4 x)   = f x z
+    foldr f z (T5 x)   = f x z
+    foldr _ z T6       = z
+
+See Note [DeriveFoldable with ExistentialQuantification] in TcGenFunctor.
+
+For Functor and Traversable, we must take care not to let type synonyms
+unfairly reject a type for not being truly universally quantified. An
+example of this is:
+
+    type C (a :: Constraint) b = a
+    data T a b = C (Show a) b => MkT b
+
+Here, the existential context (C (Show a) b) does technically mention the last
+type variable b. But this is OK, because expanding the type synonym C would
+give us the context (Show a), which doesn't mention b. Therefore, we must make
+sure to expand type synonyms before performing this check. Not doing so led to
+Trac #13813.
+-}
diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcEnv.hs
@@ -0,0 +1,1149 @@
+-- (c) The University of Glasgow 2006
+{-# LANGUAGE CPP, FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an
+                                       -- orphan
+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
+                                      -- in module PlaceHolder
+{-# LANGUAGE TypeFamilies #-}
+
+module TcEnv(
+        TyThing(..), TcTyThing(..), TcId,
+
+        -- Instance environment, and InstInfo type
+        InstInfo(..), iDFunId, pprInstInfoDetails,
+        simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
+        InstBindings(..),
+
+        -- Global environment
+        tcExtendGlobalEnv, tcExtendTyConEnv,
+        tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
+        tcExtendGlobalValEnv,
+        tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,
+        tcLookupTyCon, tcLookupClass,
+        tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
+        tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
+        tcLookupLocatedClass, tcLookupAxiom,
+        lookupGlobal, ioLookupDataCon,
+
+        -- Local environment
+        tcExtendKindEnv, tcExtendKindEnvList,
+        tcExtendTyVarEnv, tcExtendNameTyVarEnv,
+        tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,
+        tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
+        tcExtendBinderStack, tcExtendLocalTypeEnv,
+        isTypeClosedLetBndr,
+
+        tcLookup, tcLookupLocated, tcLookupLocalIds,
+        tcLookupId, tcLookupIdMaybe, tcLookupTyVar,
+        tcLookupLcl_maybe,
+        getInLocalScope,
+        wrongThingErr, pprBinders,
+
+        tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,
+        getTypeSigNames,
+        tcExtendRecEnv,         -- For knot-tying
+
+        -- Tidying
+        tcInitTidyEnv, tcInitOpenTidyEnv,
+
+        -- Instances
+        tcLookupInstance, tcGetInstEnvs,
+
+        -- Rules
+        tcExtendRules,
+
+        -- Defaults
+        tcGetDefaultTys,
+
+        -- Global type variables
+        tcGetGlobalTyCoVars,
+
+        -- Template Haskell stuff
+        checkWellStaged, tcMetaTy, thLevel,
+        topIdLvl, isBrackStage,
+
+        -- New Ids
+        newDFunName, newDFunName', newFamInstTyConName,
+        newFamInstAxiomName,
+        mkStableIdFromString, mkStableIdFromName,
+        mkWrapperName
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import IfaceEnv
+import TcRnMonad
+import TcMType
+import TcType
+import LoadIface
+import PrelNames
+import TysWiredIn
+import Id
+import Var
+import VarSet
+import RdrName
+import InstEnv
+import DataCon ( DataCon )
+import PatSyn  ( PatSyn )
+import ConLike
+import TyCon
+import Type
+import CoAxiom
+import Class
+import Name
+import NameSet
+import NameEnv
+import VarEnv
+import HscTypes
+import DynFlags
+import SrcLoc
+import BasicTypes hiding( SuccessFlag(..) )
+import Module
+import Outputable
+import Encoding
+import FastString
+import ListSetOps
+import ErrUtils
+import Util
+import Maybes( MaybeErr(..), orElse )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.IORef
+import Data.List
+import Control.Monad
+
+{- *********************************************************************
+*                                                                      *
+            An IO interface to looking up globals
+*                                                                      *
+********************************************************************* -}
+
+lookupGlobal :: HscEnv -> Name -> IO TyThing
+-- A variant of lookupGlobal_maybe for the clients which are not
+-- interested in recovering from lookup failure and accept panic.
+lookupGlobal hsc_env name
+  = do  {
+          mb_thing <- lookupGlobal_maybe hsc_env name
+        ; case mb_thing of
+            Succeeded thing -> return thing
+            Failed msg      -> pprPanic "lookupGlobal" msg
+        }
+
+lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
+-- This may look up an Id that one one has previously looked up.
+-- If so, we are going to read its interface file, and add its bindings
+-- to the ExternalPackageTable.
+lookupGlobal_maybe hsc_env name
+  = do  {    -- Try local envt
+          let mod = icInteractiveModule (hsc_IC hsc_env)
+              dflags = hsc_dflags hsc_env
+              tcg_semantic_mod = canonicalizeModuleIfHome dflags mod
+
+        ; if nameIsLocalOrFrom tcg_semantic_mod name
+              then (return
+                (Failed (text "Can't find local name: " <+> ppr name)))
+                  -- Internal names can happen in GHCi
+              else
+           -- Try home package table and external package table
+          lookupImported_maybe hsc_env name
+        }
+
+lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
+-- Returns (Failed err) if we can't find the interface file for the thing
+lookupImported_maybe hsc_env name
+  = do  { mb_thing <- lookupTypeHscEnv hsc_env name
+        ; case mb_thing of
+            Just thing -> return (Succeeded thing)
+            Nothing    -> importDecl_maybe hsc_env name
+            }
+
+importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)
+importDecl_maybe hsc_env name
+  | Just thing <- wiredInNameTyThing_maybe name
+  = do  { when (needWiredInHomeIface thing)
+               (initIfaceLoad hsc_env (loadWiredInHomeIface name))
+                -- See Note [Loading instances for wired-in things]
+        ; return (Succeeded thing) }
+  | otherwise
+  = initIfaceLoad hsc_env (importDecl name)
+
+ioLookupDataCon :: HscEnv -> Name -> IO DataCon
+ioLookupDataCon hsc_env name = do
+  mb_thing <- ioLookupDataCon_maybe hsc_env name
+  case mb_thing of
+    Succeeded thing -> return thing
+    Failed msg      -> pprPanic "lookupDataConIO" msg
+
+ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon)
+ioLookupDataCon_maybe hsc_env name = do
+    thing <- lookupGlobal hsc_env name
+    return $ case thing of
+        AConLike (RealDataCon con) -> Succeeded con
+        _                          -> Failed $
+          pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+>
+                text "used as a data constructor"
+
+{-
+************************************************************************
+*                                                                      *
+*                      tcLookupGlobal                                  *
+*                                                                      *
+************************************************************************
+
+Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
+unless you know that the SrcSpan in the monad is already set to the
+span of the Name.
+-}
+
+
+tcLookupLocatedGlobal :: Located Name -> TcM TyThing
+-- c.f. IfaceEnvEnv.tcIfaceGlobal
+tcLookupLocatedGlobal name
+  = addLocM tcLookupGlobal name
+
+tcLookupGlobal :: Name -> TcM TyThing
+-- The Name is almost always an ExternalName, but not always
+-- In GHCi, we may make command-line bindings (ghci> let x = True)
+-- that bind a GlobalId, but with an InternalName
+tcLookupGlobal name
+  = do  {    -- Try local envt
+          env <- getGblEnv
+        ; case lookupNameEnv (tcg_type_env env) name of {
+                Just thing -> return thing ;
+                Nothing    ->
+
+                -- Should it have been in the local envt?
+                -- (NB: use semantic mod here, since names never use
+                -- identity module, see Note [Identity versus semantic module].)
+          if nameIsLocalOrFrom (tcg_semantic_mod env) name
+          then notFound name  -- Internal names can happen in GHCi
+          else
+
+           -- Try home package table and external package table
+    do  { mb_thing <- tcLookupImported_maybe name
+        ; case mb_thing of
+            Succeeded thing -> return thing
+            Failed msg      -> failWithTc msg
+        }}}
+
+-- Look up only in this module's global env't. Don't look in imports, etc.
+-- Panic if it's not there.
+tcLookupGlobalOnly :: Name -> TcM TyThing
+tcLookupGlobalOnly name
+  = do { env <- getGblEnv
+       ; return $ case lookupNameEnv (tcg_type_env env) name of
+                    Just thing -> thing
+                    Nothing    -> pprPanic "tcLookupGlobalOnly" (ppr name) }
+
+tcLookupDataCon :: Name -> TcM DataCon
+tcLookupDataCon name = do
+    thing <- tcLookupGlobal name
+    case thing of
+        AConLike (RealDataCon con) -> return con
+        _                          -> wrongThingErr "data constructor" (AGlobal thing) name
+
+tcLookupPatSyn :: Name -> TcM PatSyn
+tcLookupPatSyn name = do
+    thing <- tcLookupGlobal name
+    case thing of
+        AConLike (PatSynCon ps) -> return ps
+        _                       -> wrongThingErr "pattern synonym" (AGlobal thing) name
+
+tcLookupConLike :: Name -> TcM ConLike
+tcLookupConLike name = do
+    thing <- tcLookupGlobal name
+    case thing of
+        AConLike cl -> return cl
+        _           -> wrongThingErr "constructor-like thing" (AGlobal thing) name
+
+tcLookupClass :: Name -> TcM Class
+tcLookupClass name = do
+    thing <- tcLookupGlobal name
+    case thing of
+        ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls
+        _                                           -> wrongThingErr "class" (AGlobal thing) name
+
+tcLookupTyCon :: Name -> TcM TyCon
+tcLookupTyCon name = do
+    thing <- tcLookupGlobal name
+    case thing of
+        ATyCon tc -> return tc
+        _         -> wrongThingErr "type constructor" (AGlobal thing) name
+
+tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
+tcLookupAxiom name = do
+    thing <- tcLookupGlobal name
+    case thing of
+        ACoAxiom ax -> return ax
+        _           -> wrongThingErr "axiom" (AGlobal thing) name
+
+tcLookupLocatedGlobalId :: Located Name -> TcM Id
+tcLookupLocatedGlobalId = addLocM tcLookupId
+
+tcLookupLocatedClass :: Located Name -> TcM Class
+tcLookupLocatedClass = addLocM tcLookupClass
+
+tcLookupLocatedTyCon :: Located Name -> TcM TyCon
+tcLookupLocatedTyCon = addLocM tcLookupTyCon
+
+-- Find the instance that exactly matches a type class application.  The class arguments must be precisely
+-- the same as in the instance declaration (modulo renaming & casts).
+--
+tcLookupInstance :: Class -> [Type] -> TcM ClsInst
+tcLookupInstance cls tys
+  = do { instEnv <- tcGetInstEnvs
+       ; case lookupUniqueInstEnv instEnv cls tys of
+           Left err             -> failWithTc $ text "Couldn't match instance:" <+> err
+           Right (inst, tys)
+             | uniqueTyVars tys -> return inst
+             | otherwise        -> failWithTc errNotExact
+       }
+  where
+    errNotExact = text "Not an exact match (i.e., some variables get instantiated)"
+
+    uniqueTyVars tys = all isTyVarTy tys
+                    && hasNoDups (map (getTyVar "tcLookupInstance") tys)
+
+tcGetInstEnvs :: TcM InstEnvs
+-- Gets both the external-package inst-env
+-- and the home-pkg inst env (includes module being compiled)
+tcGetInstEnvs = do { eps <- getEps
+                   ; env <- getGblEnv
+                   ; return (InstEnvs { ie_global  = eps_inst_env eps
+                                      , ie_local   = tcg_inst_env env
+                                      , ie_visible = tcVisibleOrphanMods env }) }
+
+instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
+    lookupThing = tcLookupGlobal
+
+{-
+************************************************************************
+*                                                                      *
+                Extending the global environment
+*                                                                      *
+************************************************************************
+-}
+
+setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
+-- Use this to update the global type env
+-- It updates both  * the normal tcg_type_env field
+--                  * the tcg_type_env_var field seen by interface files
+setGlobalTypeEnv tcg_env new_type_env
+  = do  {     -- Sync the type-envt variable seen by interface files
+           writeMutVar (tcg_type_env_var tcg_env) new_type_env
+         ; return (tcg_env { tcg_type_env = new_type_env }) }
+
+
+tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
+  -- Just extend the global environment with some TyThings
+  -- Do not extend tcg_tcs, tcg_patsyns etc
+tcExtendGlobalEnvImplicit things thing_inside
+   = do { tcg_env <- getGblEnv
+        ; let ge'  = extendTypeEnvList (tcg_type_env tcg_env) things
+        ; tcg_env' <- setGlobalTypeEnv tcg_env ge'
+        ; setGblEnv tcg_env' thing_inside }
+
+tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
+  -- Given a mixture of Ids, TyCons, Classes, all defined in the
+  -- module being compiled, extend the global environment
+tcExtendGlobalEnv things thing_inside
+  = do { env <- getGblEnv
+       ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env,
+                          tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env }
+       ; setGblEnv env' $
+            tcExtendGlobalEnvImplicit things thing_inside
+       }
+
+tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r
+  -- Given a mixture of Ids, TyCons, Classes, all defined in the
+  -- module being compiled, extend the global environment
+tcExtendTyConEnv tycons thing_inside
+  = do { env <- getGblEnv
+       ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env }
+       ; setGblEnv env' $
+         tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside
+       }
+
+tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
+  -- Same deal as tcExtendGlobalEnv, but for Ids
+tcExtendGlobalValEnv ids thing_inside
+  = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside
+
+tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
+-- Extend the global environments for the type/class knot tying game
+-- Just like tcExtendGlobalEnv, except the argument is a list of pairs
+tcExtendRecEnv gbl_stuff thing_inside
+ = do  { tcg_env <- getGblEnv
+       ; let ge'      = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff
+             tcg_env' = tcg_env { tcg_type_env = ge' }
+         -- No need for setGlobalTypeEnv (which side-effects the
+         -- tcg_type_env_var); tcExtendRecEnv is used just
+         -- when kind-check a group of type/class decls. It would
+         -- in any case be wrong for an interface-file decl to end up
+         -- with a TcTyCon in it!
+       ; setGblEnv tcg_env' thing_inside }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{The local environment}
+*                                                                      *
+************************************************************************
+-}
+
+tcLookupLocated :: Located Name -> TcM TcTyThing
+tcLookupLocated = addLocM tcLookup
+
+tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
+tcLookupLcl_maybe name
+  = do { local_env <- getLclTypeEnv
+       ; return (lookupNameEnv local_env name) }
+
+tcLookup :: Name -> TcM TcTyThing
+tcLookup name = do
+    local_env <- getLclTypeEnv
+    case lookupNameEnv local_env name of
+        Just thing -> return thing
+        Nothing    -> AGlobal <$> tcLookupGlobal name
+
+tcLookupTyVar :: Name -> TcM TcTyVar
+tcLookupTyVar name
+  = do { thing <- tcLookup name
+       ; case thing of
+           ATyVar _ tv -> return tv
+           _           -> pprPanic "tcLookupTyVar" (ppr name) }
+
+tcLookupId :: Name -> TcM Id
+-- Used when we aren't interested in the binding level, nor refinement.
+-- The "no refinement" part means that we return the un-refined Id regardless
+--
+-- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)
+tcLookupId name = do
+    thing <- tcLookupIdMaybe name
+    case thing of
+        Just id -> return id
+        _       -> pprPanic "tcLookupId" (ppr name)
+
+tcLookupIdMaybe :: Name -> TcM (Maybe Id)
+tcLookupIdMaybe name
+  = do { thing <- tcLookup name
+       ; case thing of
+           ATcId { tct_id = id} -> return $ Just id
+           AGlobal (AnId id)    -> return $ Just id
+           _                    -> return Nothing }
+
+tcLookupLocalIds :: [Name] -> TcM [TcId]
+-- We expect the variables to all be bound, and all at
+-- the same level as the lookup.  Only used in one place...
+tcLookupLocalIds ns
+  = do { env <- getLclEnv
+       ; return (map (lookup (tcl_env env)) ns) }
+  where
+    lookup lenv name
+        = case lookupNameEnv lenv name of
+                Just (ATcId { tct_id = id }) ->  id
+                _ -> pprPanic "tcLookupLocalIds" (ppr name)
+
+getInLocalScope :: TcM (Name -> Bool)
+getInLocalScope = do { lcl_env <- getLclTypeEnv
+                     ; return (`elemNameEnv` lcl_env) }
+
+tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r
+-- Used only during kind checking, for TcThings that are
+--      ATcTyCon or APromotionErr
+-- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr
+tcExtendKindEnvList things thing_inside
+  = do { traceTc "tcExtendKindEnvList" (ppr things)
+       ; updLclEnv upd_env thing_inside }
+  where
+    upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }
+
+tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r
+-- A variant of tcExtendKindEvnList
+tcExtendKindEnv extra_env thing_inside
+  = do { traceTc "tcExtendKindEnv" (ppr extra_env)
+       ; updLclEnv upd_env thing_inside }
+  where
+    upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env }
+
+-----------------------
+-- Scoped type and kind variables
+tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
+tcExtendTyVarEnv tvs thing_inside
+  = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside
+
+tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r
+tcExtendNameTyVarEnv binds thing_inside
+  -- this should be used only for explicitly mentioned scoped variables.
+  -- thus, no coercion variables
+  = do { tc_extend_local_env NotTopLevel
+                    [(name, ATyVar name tv) | (name, tv) <- binds] $
+         tcExtendBinderStack tv_binds $
+         thing_inside }
+  where
+    tv_binds :: [TcBinder]
+    tv_binds = [TcTvBndr name tv | (name,tv) <- binds]
+
+isTypeClosedLetBndr :: Id -> Bool
+-- See Note [Bindings with closed types] in TcRnTypes
+isTypeClosedLetBndr = noFreeVarsOfType . idType
+
+tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
+-- Used for binding the recurive uses of Ids in a binding
+-- both top-level value bindings and and nested let/where-bindings
+-- Does not extend the TcBinderStack
+tcExtendRecIds pairs thing_inside
+  = tc_extend_local_env NotTopLevel
+          [ (name, ATcId { tct_id   = let_id
+                         , tct_info = NonClosedLet emptyNameSet False })
+          | (name, let_id) <- pairs ] $
+    thing_inside
+
+tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
+-- Used for binding the Ids that have a complete user type signature
+-- Does not extend the TcBinderStack
+tcExtendSigIds top_lvl sig_ids thing_inside
+  = tc_extend_local_env top_lvl
+          [ (idName id, ATcId { tct_id   = id
+                              , tct_info = info })
+          | id <- sig_ids
+          , let closed = isTypeClosedLetBndr id
+                info   = NonClosedLet emptyNameSet closed ]
+     thing_inside
+
+
+tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
+                  -> [TcId] -> TcM a -> TcM a
+-- Used for both top-level value bindings and and nested let/where-bindings
+-- Adds to the TcBinderStack too
+tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)
+               ids thing_inside
+  = tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $
+    tc_extend_local_env top_lvl
+          [ (idName id, ATcId { tct_id   = id
+                              , tct_info = mk_tct_info id })
+          | id <- ids ]
+    thing_inside
+  where
+    mk_tct_info id
+      | type_closed && isEmptyNameSet rhs_fvs = ClosedLet
+      | otherwise                             = NonClosedLet rhs_fvs type_closed
+      where
+        name        = idName id
+        rhs_fvs     = lookupNameEnv fvs name `orElse` emptyNameSet
+        type_closed = isTypeClosedLetBndr id &&
+                      (fv_type_closed || hasCompleteSig sig_fn name)
+
+tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
+-- For lambda-bound and case-bound Ids
+-- Extends the TcBinderStack as well
+tcExtendIdEnv ids thing_inside
+  = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
+
+tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
+-- Exactly like tcExtendIdEnv2, but for a single (name,id) pair
+tcExtendIdEnv1 name id thing_inside
+  = tcExtendIdEnv2 [(name,id)] thing_inside
+
+tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
+tcExtendIdEnv2 names_w_ids thing_inside
+  = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel
+                        | (_,mono_id) <- names_w_ids ] $
+    tc_extend_local_env NotTopLevel
+            [ (name, ATcId { tct_id = id
+                           , tct_info    = NotLetBound })
+            | (name,id) <- names_w_ids]
+    thing_inside
+
+tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
+tc_extend_local_env top_lvl extra_env thing_inside
+-- Precondition: the argument list extra_env has TcTyThings
+--               that ATcId or ATyVar, but nothing else
+--
+-- Invariant: the ATcIds are fully zonked. Reasons:
+--      (a) The kinds of the forall'd type variables are defaulted
+--          (see Kind.defaultKind, done in skolemiseQuantifiedTyVar)
+--      (b) There are no via-Indirect occurrences of the bound variables
+--          in the types, because instantiation does not look through such things
+--      (c) The call to tyCoVarsOfTypes is ok without looking through refs
+
+-- The second argument of type TyVarSet is a set of type variables
+-- that are bound together with extra_env and should not be regarded
+-- as free in the types of extra_env.
+  = do  { traceTc "tc_extend_local_env" (ppr extra_env)
+        ; env0 <- getLclEnv
+        ; env1 <- tcExtendLocalTypeEnv env0 extra_env
+        ; stage <- getStage
+        ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1
+        ; setLclEnv env2 thing_inside }
+  where
+    extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv
+    -- Extend the local LocalRdrEnv and Template Haskell staging env simultaneously
+    -- Reason for extending LocalRdrEnv: after running a TH splice we need
+    -- to do renaming.
+    extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env
+                                               , tcl_th_bndrs = th_bndrs })
+      = env { tcl_rdr      = extendLocalRdrEnvList rdr_env
+                                [ n | (n, _) <- pairs, isInternalName n ]
+                                -- The LocalRdrEnv contains only non-top-level names
+                                -- (GlobalRdrEnv handles the top level)
+            , tcl_th_bndrs = extendNameEnvList th_bndrs  -- We only track Ids in tcl_th_bndrs
+                                 [(n, thlvl) | (n, ATcId {}) <- pairs] }
+
+tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcM TcLclEnv
+tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
+  | isEmptyVarSet extra_tvs
+  = return (lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things })
+  | otherwise
+  = do { global_tvs <- readMutVar (tcl_tyvars lcl_env)
+       ; new_g_var  <- newMutVar (global_tvs `unionVarSet` extra_tvs)
+       ; return (lcl_env { tcl_tyvars = new_g_var
+                         , tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) }
+  where
+    extra_tvs = foldr get_tvs emptyVarSet tc_ty_things
+
+    get_tvs (_, ATcId { tct_id = id, tct_info = closed }) tvs
+      = case closed of
+          ClosedLet -> ASSERT2( is_closed_type, ppr id $$ ppr (idType id) )
+                       tvs
+          _other    -> tvs `unionVarSet` id_tvs
+        where
+           id_ty          = idType id
+           id_tvs         = tyCoVarsOfType id_ty
+           id_co_tvs      = closeOverKinds (coVarsOfType id_ty)
+           is_closed_type = not (anyVarSet isTyVar (id_tvs `minusVarSet` id_co_tvs))
+           -- We only care about being closed wrt /type/ variables
+           -- E.g. a top-level binding might have a type like
+           --          foo :: t |> co
+           -- where co :: * ~ *
+           -- or some other as-yet-unsolved kind coercion
+
+    get_tvs (_, ATyVar _ tv) tvs          -- See Note [Global TyVars]
+      = tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) `extendVarSet` tv
+
+    get_tvs (_, ATcTyCon tc) tvs = tvs `unionVarSet` tyCoVarsOfType (tyConKind tc)
+
+    get_tvs (_, AGlobal {})       tvs = tvs
+    get_tvs (_, APromotionErr {}) tvs = tvs
+
+        -- Note [Global TyVars]
+        -- It's important to add the in-scope tyvars to the global tyvar set
+        -- as well.  Consider
+        --      f (_::r) = let g y = y::r in ...
+        -- Here, g mustn't be generalised.  This is also important during
+        -- class and instance decls, when we mustn't generalise the class tyvars
+        -- when typechecking the methods.
+        --
+        -- Nor must we generalise g over any kind variables free in r's kind
+
+
+{- *********************************************************************
+*                                                                      *
+             The TcBinderStack
+*                                                                      *
+********************************************************************* -}
+
+tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a
+tcExtendBinderStack bndrs thing_inside
+  = do { traceTc "tcExtendBinderStack" (ppr bndrs)
+       ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })
+                   thing_inside }
+
+tcInitTidyEnv :: TcM TidyEnv
+-- We initialise the "tidy-env", used for tidying types before printing,
+-- by building a reverse map from the in-scope type variables to the
+-- OccName that the programmer originally used for them
+tcInitTidyEnv
+  = do  { lcl_env <- getLclEnv
+        ; go emptyTidyEnv (tcl_bndrs lcl_env) }
+  where
+    go (env, subst) []
+      = return (env, subst)
+    go (env, subst) (b : bs)
+      | TcTvBndr name tyvar <- b
+       = do { let (env', occ') = tidyOccName env (nameOccName name)
+                  name'  = tidyNameOcc name occ'
+                  tyvar1 = setTyVarName tyvar name'
+            ; tyvar2 <- zonkTcTyVarToTyVar tyvar1
+              -- Be sure to zonk here!  Tidying applies to zonked
+              -- types, so if we don't zonk we may create an
+              -- ill-kinded type (Trac #14175)
+            ; go (env', extendVarEnv subst tyvar tyvar2) bs }
+      | otherwise
+      = go (env, subst) bs
+
+-- | Get a 'TidyEnv' that includes mappings for all vars free in the given
+-- type. Useful when tidying open types.
+tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
+tcInitOpenTidyEnv tvs
+  = do { env1 <- tcInitTidyEnv
+       ; let env2 = tidyFreeTyCoVars env1 tvs
+       ; return env2 }
+
+
+
+{- *********************************************************************
+*                                                                      *
+             Adding placeholders
+*                                                                      *
+********************************************************************* -}
+
+tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a
+-- See Note [AFamDataCon: not promoting data family constructors]
+tcAddDataFamConPlaceholders inst_decls thing_inside
+  = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE)
+                        | lid <- inst_decls, con <- get_cons lid ]
+      thing_inside
+      -- Note [AFamDataCon: not promoting data family constructors]
+  where
+    -- get_cons extracts the *constructor* bindings of the declaration
+    get_cons :: LInstDecl GhcRn -> [Name]
+    get_cons (L _ (TyFamInstD {}))                     = []
+    get_cons (L _ (DataFamInstD { dfid_inst = fid }))  = get_fi_cons fid
+    get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
+      = concatMap (get_fi_cons . unLoc) fids
+    get_cons (L _ (ClsInstD _ (XClsInstDecl _))) = panic "get_cons"
+    get_cons (L _ (XInstDecl _)) = panic "get_cons"
+
+    get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
+    get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+                  FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}})
+      = map unLoc $ concatMap (getConNames . unLoc) cons
+    get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
+                  FamEqn { feqn_rhs = XHsDataDefn _ }}})
+      = panic "get_fi_cons"
+    get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn _))) = panic "get_fi_cons"
+    get_fi_cons (DataFamInstDecl (XHsImplicitBndrs _)) = panic "get_fi_cons"
+
+
+tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
+-- See Note [Don't promote pattern synonyms]
+tcAddPatSynPlaceholders pat_syns thing_inside
+  = tcExtendKindEnvList [ (name, APromotionErr PatSynPE)
+                        | PSB{ psb_id = L _ name } <- pat_syns ]
+       thing_inside
+
+getTypeSigNames :: [LSig GhcRn] -> NameSet
+-- Get the names that have a user type sig
+getTypeSigNames sigs
+  = foldr get_type_sig emptyNameSet sigs
+  where
+    get_type_sig :: LSig GhcRn -> NameSet -> NameSet
+    get_type_sig sig ns =
+      case sig of
+        L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names)
+        L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names)
+        _ -> ns
+
+
+{- Note [AFamDataCon: not promoting data family constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data family T a
+  data instance T Int = MkT
+  data Proxy (a :: k)
+  data S = MkS (Proxy 'MkT)
+
+Is it ok to use the promoted data family instance constructor 'MkT' in
+the data declaration for S (where both declarations live in the same module)?
+No, we don't allow this. It *might* make sense, but at least it would mean that
+we'd have to interleave typechecking instances and data types, whereas at
+present we do data types *then* instances.
+
+So to check for this we put in the TcLclEnv a binding for all the family
+constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
+type checking 'S' we'll produce a decent error message.
+
+Trac #12088 describes this limitation. Of course, when MkT and S live in
+different modules then all is well.
+
+Note [Don't promote pattern synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We never promote pattern synonyms.
+
+Consider this (Trac #11265):
+  pattern A = True
+  instance Eq A
+We want a civilised error message from the occurrence of 'A'
+in the instance, yet 'A' really has not yet been type checked.
+
+Similarly (Trac #9161)
+  {-# LANGUAGE PatternSynonyms, DataKinds #-}
+  pattern A = ()
+  b :: A
+  b = undefined
+Here, the type signature for b mentions A.  But A is a pattern
+synonym, which is typechecked as part of a group of bindings (for very
+good reasons; a view pattern in the RHS may mention a value binding).
+It is entirely reasonable to reject this, but to do so we need A to be
+in the kind environment when kind-checking the signature for B.
+
+Hence tcAddPatSynPlaceholers adds a binding
+    A -> APromotionErr PatSynPE
+to the environment. Then TcHsType.tcTyVar will find A in the kind
+environment, and will give a 'wrongThingErr' as a result.  But the
+lookup of A won't fail.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Rules}
+*                                                                      *
+************************************************************************
+-}
+
+tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a
+        -- Just pop the new rules into the EPS and envt resp
+        -- All the rules come from an interface file, not source
+        -- Nevertheless, some may be for this module, if we read
+        -- its interface instead of its source code
+tcExtendRules lcl_rules thing_inside
+ = do { env <- getGblEnv
+      ; let
+          env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
+      ; setGblEnv env' thing_inside }
+
+{-
+************************************************************************
+*                                                                      *
+                Meta level
+*                                                                      *
+************************************************************************
+-}
+
+checkWellStaged :: SDoc         -- What the stage check is for
+                -> ThLevel      -- Binding level (increases inside brackets)
+                -> ThLevel      -- Use stage
+                -> TcM ()       -- Fail if badly staged, adding an error
+checkWellStaged pp_thing bind_lvl use_lvl
+  | use_lvl >= bind_lvl         -- OK! Used later than bound
+  = return ()                   -- E.g.  \x -> [| $(f x) |]
+
+  | bind_lvl == outerLevel      -- GHC restriction on top level splices
+  = stageRestrictionError pp_thing
+
+  | otherwise                   -- Badly staged
+  = failWithTc $                -- E.g.  \x -> $(f x)
+    text "Stage error:" <+> pp_thing <+>
+        hsep   [text "is bound at stage" <+> ppr bind_lvl,
+                text "but used at stage" <+> ppr use_lvl]
+
+stageRestrictionError :: SDoc -> TcM a
+stageRestrictionError pp_thing
+  = failWithTc $
+    sep [ text "GHC stage restriction:"
+        , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"
+                       , text "and must be imported, not defined locally"])]
+
+topIdLvl :: Id -> ThLevel
+-- Globals may either be imported, or may be from an earlier "chunk"
+-- (separated by declaration splices) of this module.  The former
+--  *can* be used inside a top-level splice, but the latter cannot.
+-- Hence we give the former impLevel, but the latter topLevel
+-- E.g. this is bad:
+--      x = [| foo |]
+--      $( f x )
+-- By the time we are prcessing the $(f x), the binding for "x"
+-- will be in the global env, not the local one.
+topIdLvl id | isLocalId id = outerLevel
+            | otherwise    = impLevel
+
+tcMetaTy :: Name -> TcM Type
+-- Given the name of a Template Haskell data type,
+-- return the type
+-- E.g. given the name "Expr" return the type "Expr"
+tcMetaTy tc_name = do
+    t <- tcLookupTyCon tc_name
+    return (mkTyConApp t [])
+
+isBrackStage :: ThStage -> Bool
+isBrackStage (Brack {}) = True
+isBrackStage _other     = False
+
+{-
+************************************************************************
+*                                                                      *
+                 getDefaultTys
+*                                                                      *
+************************************************************************
+-}
+
+tcGetDefaultTys :: TcM ([Type], -- Default types
+                        (Bool,  -- True <=> Use overloaded strings
+                         Bool)) -- True <=> Use extended defaulting rules
+tcGetDefaultTys
+  = do  { dflags <- getDynFlags
+        ; let ovl_strings = xopt LangExt.OverloadedStrings dflags
+              extended_defaults = xopt LangExt.ExtendedDefaultRules dflags
+                                        -- See also Trac #1974
+              flags = (ovl_strings, extended_defaults)
+
+        ; mb_defaults <- getDeclaredDefaultTys
+        ; case mb_defaults of {
+           Just tys -> return (tys, flags) ;
+                                -- User-supplied defaults
+           Nothing  -> do
+
+        -- No use-supplied default
+        -- Use [Integer, Double], plus modifications
+        { integer_ty <- tcMetaTy integerTyConName
+        ; list_ty <- tcMetaTy listTyConName
+        ; checkWiredInTyCon doubleTyCon
+        ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]
+                          -- Note [Extended defaults]
+                          ++ [integer_ty, doubleTy]
+                          ++ opt_deflt ovl_strings [stringTy]
+        ; return (deflt_tys, flags) } } }
+  where
+    opt_deflt True  xs = xs
+    opt_deflt False _  = []
+
+{-
+Note [Extended defaults]
+~~~~~~~~~~~~~~~~~~~~~
+In interative mode (or with -XExtendedDefaultRules) we add () as the first type we
+try when defaulting.  This has very little real impact, except in the following case.
+Consider:
+        Text.Printf.printf "hello"
+This has type (forall a. IO a); it prints "hello", and returns 'undefined'.  We don't
+want the GHCi repl loop to try to print that 'undefined'.  The neatest thing is to
+default the 'a' to (), rather than to Integer (which is what would otherwise happen;
+and then GHCi doesn't attempt to print the ().  So in interactive mode, we add
+() to the list of defaulting types.  See Trac #1200.
+
+Additionally, the list type [] is added as a default specialization for
+Traversable and Foldable. As such the default default list now has types of
+varying kinds, e.g. ([] :: * -> *)  and (Integer :: *).
+
+************************************************************************
+*                                                                      *
+\subsection{The InstInfo type}
+*                                                                      *
+************************************************************************
+
+The InstInfo type summarises the information in an instance declaration
+
+    instance c => k (t tvs) where b
+
+It is used just for *local* instance decls (not ones from interface files).
+But local instance decls includes
+        - derived ones
+        - generic ones
+as well as explicit user written ones.
+-}
+
+data InstInfo a
+  = InstInfo
+      { iSpec   :: ClsInst          -- Includes the dfun id
+      , iBinds  :: InstBindings a
+      }
+
+iDFunId :: InstInfo a -> DFunId
+iDFunId info = instanceDFunId (iSpec info)
+
+data InstBindings a
+  = InstBindings
+      { ib_tyvars  :: [Name]   -- Names of the tyvars from the instance head
+                               -- that are lexically in scope in the bindings
+                               -- Must correspond 1-1 with the forall'd tyvars
+                               -- of the dfun Id.  When typechecking, we are
+                               -- going to extend the typechecker's envt with
+                               --     ib_tyvars -> dfun_forall_tyvars
+
+      , ib_binds   :: LHsBinds a    -- Bindings for the instance methods
+
+      , ib_pragmas :: [LSig a]      -- User pragmas recorded for generating
+                                    -- specialised instances
+
+      , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should
+                                             -- be enabled when type-checking
+                                             -- this instance; needed for
+                                             -- GeneralizedNewtypeDeriving
+
+      , ib_derived :: Bool
+           -- True <=> This code was generated by GHC from a deriving clause
+           --          or standalone deriving declaration
+           --          Used only to improve error messages
+      }
+
+instance (OutputableBndrId (GhcPass a))
+       => Outputable (InstInfo (GhcPass a)) where
+    ppr = pprInstInfoDetails
+
+pprInstInfoDetails :: (OutputableBndrId (GhcPass a))
+                   => InstInfo (GhcPass a) -> SDoc
+pprInstInfoDetails info
+   = hang (pprInstanceHdr (iSpec info) <+> text "where")
+        2 (details (iBinds info))
+  where
+    details (InstBindings { ib_binds = b }) = pprLHsBinds b
+
+simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
+simpleInstInfoClsTy info = case instanceHead (iSpec info) of
+                           (_, cls, [ty]) -> (cls, ty)
+                           _ -> panic "simpleInstInfoClsTy"
+
+simpleInstInfoTy :: InstInfo a -> Type
+simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
+
+simpleInstInfoTyCon :: InstInfo a -> TyCon
+  -- Gets the type constructor for a simple instance declaration,
+  -- i.e. one of the form       instance (...) => C (T a b c) where ...
+simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
+
+-- | Make a name for the dict fun for an instance decl.  It's an *external*
+-- name, like other top-level names, and hence must be made with
+-- newGlobalBinder.
+newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
+newDFunName clas tys loc
+  = do  { is_boot <- tcIsHsBootOrSig
+        ; mod     <- getModule
+        ; let info_string = occNameString (getOccName clas) ++
+                            concatMap (occNameString.getDFunTyKey) tys
+        ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
+        ; newGlobalBinder mod dfun_occ loc }
+
+-- | Special case of 'newDFunName' to generate dict fun name for a single TyCon.
+newDFunName' :: Class -> TyCon -> TcM Name
+newDFunName' clas tycon        -- Just a simple wrapper
+  = do { loc <- getSrcSpanM     -- The location of the instance decl,
+                                -- not of the tycon
+       ; newDFunName clas [mkTyConApp tycon []] loc }
+       -- The type passed to newDFunName is only used to generate
+       -- a suitable string; hence the empty type arg list
+
+{-
+Make a name for the representation tycon of a family instance.  It's an
+*external* name, like other top-level names, and hence must be made with
+newGlobalBinder.
+-}
+
+newFamInstTyConName :: Located Name -> [Type] -> TcM Name
+newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys]
+
+newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name
+newFamInstAxiomName (L loc name) branches
+  = mk_fam_inst_name mkInstTyCoOcc loc name branches
+
+mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
+mk_fam_inst_name adaptOcc loc tc_name tyss
+  = do  { mod   <- getModule
+        ; let info_string = occNameString (getOccName tc_name) ++
+                            intercalate "|" ty_strings
+        ; occ   <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
+        ; newGlobalBinder mod (adaptOcc occ) loc }
+  where
+    ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss
+
+{-
+Stable names used for foreign exports and annotations.
+For stable names, the name must be unique (see #1533).  If the
+same thing has several stable Ids based on it, the
+top-level bindings generated must not have the same name.
+Hence we create an External name (doesn't change), and we
+append a Unique to the string right here.
+-}
+
+mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
+mkStableIdFromString str sig_ty loc occ_wrapper = do
+    uniq <- newUnique
+    mod <- getModule
+    name <- mkWrapperName "stable" str
+    let occ = mkVarOccFS name :: OccName
+        gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name
+        id  = mkExportedVanillaId gnm sig_ty :: Id
+    return id
+
+mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
+mkStableIdFromName nm = mkStableIdFromString (getOccString nm)
+
+mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)
+              => String -> String -> m FastString
+mkWrapperName what nameBase
+    = do dflags <- getDynFlags
+         thisMod <- getModule
+         let -- Note [Generating fresh names for ccall wrapper]
+             wrapperRef = nextWrapperNum dflags
+             pkg = unitIdString  (moduleUnitId thisMod)
+             mod = moduleNameString (moduleName      thisMod)
+         wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
+             let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
+                 mod_env' = extendModuleEnv mod_env thisMod (num+1)
+             in (mod_env', num)
+         let components = [what, show wrapperNum, pkg, mod, nameBase]
+         return $ mkFastString $ zEncodeString $ intercalate ":" components
+
+{-
+Note [Generating fresh names for FFI wrappers]
+
+We used to use a unique, rather than nextWrapperNum, to distinguish
+between FFI wrapper functions. However, the wrapper names that we
+generate are external names. This means that if a call to them ends up
+in an unfolding, then we can't alpha-rename them, and thus if the
+unique randomly changes from one compile to another then we get a
+spurious ABI change (#4012).
+
+The wrapper counter has to be per-module, not global, so that the number we end
+up using is not dependent on the modules compiled before the current one.
+-}
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Errors}
+*                                                                      *
+************************************************************************
+-}
+
+pprBinders :: [Name] -> SDoc
+-- Used in error messages
+-- Use quotes for a single one; they look a bit "busy" for several
+pprBinders [bndr] = quotes (ppr bndr)
+pprBinders bndrs  = pprWithCommas ppr bndrs
+
+notFound :: Name -> TcM TyThing
+notFound name
+  = do { lcl_env <- getLclEnv
+       ; let stage = tcl_th_ctxt lcl_env
+       ; case stage of   -- See Note [Out of scope might be a staging error]
+           Splice {}
+             | isUnboundName name -> failM  -- If the name really isn't in scope
+                                            -- don't report it again (Trac #11941)
+             | otherwise -> stageRestrictionError (quotes (ppr name))
+           _ -> failWithTc $
+                vcat[text "GHC internal error:" <+> quotes (ppr name) <+>
+                     text "is not in scope during type checking, but it passed the renamer",
+                     text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)]
+                       -- Take care: printing the whole gbl env can
+                       -- cause an infinite loop, in the case where we
+                       -- are in the middle of a recursive TyCon/Class group;
+                       -- so let's just not print it!  Getting a loop here is
+                       -- very unhelpful, because it hides one compiler bug with another
+       }
+
+wrongThingErr :: String -> TcTyThing -> Name -> TcM a
+-- It's important that this only calls pprTcTyThingCategory, which in
+-- turn does not look at the details of the TcTyThing.
+-- See Note [Placeholder PatSyn kinds] in TcBinds
+wrongThingErr expected thing name
+  = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
+                text "used as a" <+> text expected)
+
+{- Note [Out of scope might be a staging error]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  x = 3
+  data T = MkT $(foo x)
+
+where 'foo' is imported from somewhere.
+
+This is really a staging error, because we can't run code involving 'x'.
+But in fact the type checker processes types first, so 'x' won't even be
+in the type envt when we look for it in $(foo x).  So inside splices we
+report something missing from the type env as a staging error.
+See Trac #5752 and #5795.
+-}
diff --git a/compiler/typecheck/TcEnv.hs-boot b/compiler/typecheck/TcEnv.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcEnv.hs-boot
@@ -0,0 +1,10 @@
+module TcEnv where
+
+import TcRnTypes( TcM )
+import VarEnv( TidyEnv )
+
+-- Annoyingly, there's a recursion between tcInitTidyEnv
+-- (which does zonking and hence needs TcMType) and
+-- addErrTc etc which live in TcRnMonad.  Rats.
+tcInitTidyEnv :: TcM TidyEnv
+
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcErrors.hs
@@ -0,0 +1,3112 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcErrors(
+       reportUnsolved, reportAllUnsolved, warnAllUnsolved,
+       warnDefaulting,
+
+       solverDepthErrorTcS
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnTypes
+import TcRnMonad
+import TcMType
+import TcUnify( occCheckForErrors, OccCheckResult(..) )
+import TcEnv( tcInitTidyEnv )
+import TcType
+import RnUnbound ( unknownNameSuggestions )
+import Type
+import TyCoRep
+import Unify            ( tcMatchTys )
+import Module
+import FamInst
+import FamInstEnv       ( flattenTys )
+import Inst
+import InstEnv
+import TyCon
+import Class
+import DataCon
+import TcEvidence
+import TcEvTerm
+import HsExpr  ( UnboundVar(..) )
+import HsBinds ( PatSynBind(..) )
+import Name
+import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv
+               , mkRdrUnqual, isLocalGRE, greSrcSpan )
+import PrelNames ( typeableClassName )
+import Id
+import Var
+import VarSet
+import VarEnv
+import NameSet
+import Bag
+import ErrUtils         ( ErrMsg, errDoc, pprLocErrMsg )
+import BasicTypes
+import ConLike          ( ConLike(..))
+import Util
+import FastString
+import Outputable
+import SrcLoc
+import DynFlags
+import ListSetOps       ( equivClasses )
+import Maybes
+import Pair
+import qualified GHC.LanguageExtensions as LangExt
+import FV ( fvVarList, unionFV )
+
+import Control.Monad    ( when )
+import Data.Foldable    ( toList )
+import Data.List        ( partition, mapAccumL, nub, sortBy, unfoldr )
+import qualified Data.Set as Set
+
+import {-# SOURCE #-} TcHoleErrors ( findValidHoleFits )
+
+-- import Data.Semigroup   ( Semigroup )
+import qualified Data.Semigroup as Semigroup
+
+
+{-
+************************************************************************
+*                                                                      *
+\section{Errors and contexts}
+*                                                                      *
+************************************************************************
+
+ToDo: for these error messages, should we note the location as coming
+from the insts, or just whatever seems to be around in the monad just
+now?
+
+Note [Deferring coercion errors to runtime]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+While developing, sometimes it is desirable to allow compilation to succeed even
+if there are type errors in the code. Consider the following case:
+
+  module Main where
+
+  a :: Int
+  a = 'a'
+
+  main = print "b"
+
+Even though `a` is ill-typed, it is not used in the end, so if all that we're
+interested in is `main` it is handy to be able to ignore the problems in `a`.
+
+Since we treat type equalities as evidence, this is relatively simple. Whenever
+we run into a type mismatch in TcUnify, we normally just emit an error. But it
+is always safe to defer the mismatch to the main constraint solver. If we do
+that, `a` will get transformed into
+
+  co :: Int ~ Char
+  co = ...
+
+  a :: Int
+  a = 'a' `cast` co
+
+The constraint solver would realize that `co` is an insoluble constraint, and
+emit an error with `reportUnsolved`. But we can also replace the right-hand side
+of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program
+to compile, and it will run fine unless we evaluate `a`. This is what
+`deferErrorsToRuntime` does.
+
+It does this by keeping track of which errors correspond to which coercion
+in TcErrors. TcErrors.reportTidyWanteds does not print the errors
+and does not fail if -fdefer-type-errors is on, so that we can continue
+compilation. The errors are turned into warnings in `reportUnsolved`.
+-}
+
+-- | Report unsolved goals as errors or warnings. We may also turn some into
+-- deferred run-time errors if `-fdefer-type-errors` is on.
+reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)
+reportUnsolved wanted
+  = do { binds_var <- newTcEvBinds
+       ; defer_errors <- goptM Opt_DeferTypeErrors
+       ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283
+       ; let type_errors | not defer_errors = TypeError
+                         | warn_errors      = TypeWarn (Reason Opt_WarnDeferredTypeErrors)
+                         | otherwise        = TypeDefer
+
+       ; defer_holes <- goptM Opt_DeferTypedHoles
+       ; warn_holes  <- woptM Opt_WarnTypedHoles
+       ; let expr_holes | not defer_holes = HoleError
+                        | warn_holes      = HoleWarn
+                        | otherwise       = HoleDefer
+
+       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures
+       ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
+       ; let type_holes | not partial_sigs  = HoleError
+                        | warn_partial_sigs = HoleWarn
+                        | otherwise         = HoleDefer
+
+       ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables
+       ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables
+       ; let out_of_scope_holes | not defer_out_of_scope = HoleError
+                                | warn_out_of_scope      = HoleWarn
+                                | otherwise              = HoleDefer
+
+       ; report_unsolved type_errors expr_holes
+                         type_holes out_of_scope_holes
+                         binds_var wanted
+
+       ; ev_binds <- getTcEvBindsMap binds_var
+       ; return (evBindMapBinds ev_binds)}
+
+-- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on
+-- However, do not make any evidence bindings, because we don't
+-- have any convenient place to put them.
+-- See Note [Deferring coercion errors to runtime]
+-- Used by solveEqualities for kind equalities
+--      (see Note [Fail fast on kind errors] in TcSimplify]
+-- and for simplifyDefault.
+reportAllUnsolved :: WantedConstraints -> TcM ()
+reportAllUnsolved wanted
+  = do { ev_binds <- newNoTcEvBinds
+       ; report_unsolved TypeError HoleError HoleError HoleError
+                         ev_binds wanted }
+
+-- | Report all unsolved goals as warnings (but without deferring any errors to
+-- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in
+-- TcSimplify
+warnAllUnsolved :: WantedConstraints -> TcM ()
+warnAllUnsolved wanted
+  = do { ev_binds <- newTcEvBinds
+       ; report_unsolved (TypeWarn NoReason) HoleWarn HoleWarn HoleWarn
+                         ev_binds wanted }
+
+-- | Report unsolved goals as errors or warnings.
+report_unsolved :: TypeErrorChoice   -- Deferred type errors
+                -> HoleChoice        -- Expression holes
+                -> HoleChoice        -- Type holes
+                -> HoleChoice        -- Out of scope holes
+                -> EvBindsVar        -- cec_binds
+                -> WantedConstraints -> TcM ()
+report_unsolved type_errors expr_holes
+    type_holes out_of_scope_holes binds_var wanted
+  | isEmptyWC wanted
+  = return ()
+  | otherwise
+  = do { traceTc "reportUnsolved {" $
+         vcat [ text "type errors:" <+> ppr type_errors
+              , text "expr holes:" <+> ppr expr_holes
+              , text "type holes:" <+> ppr type_holes
+              , text "scope holes:" <+> ppr out_of_scope_holes ]
+       ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)
+
+       ; wanted <- zonkWC wanted   -- Zonk to reveal all information
+       ; env0 <- tcInitTidyEnv
+            -- If we are deferring we are going to need /all/ evidence around,
+            -- including the evidence produced by unflattening (zonkWC)
+       ; let tidy_env = tidyFreeTyCoVars env0 free_tvs
+             free_tvs = tyCoVarsOfWCList wanted
+
+       ; traceTc "reportUnsolved (after zonking):" $
+         vcat [ text "Free tyvars:" <+> pprTyVars free_tvs
+              , text "Tidy env:" <+> ppr tidy_env
+              , text "Wanted:" <+> ppr wanted ]
+
+       ; warn_redundant <- woptM Opt_WarnRedundantConstraints
+       ; let err_ctxt = CEC { cec_encl  = []
+                            , cec_tidy  = tidy_env
+                            , cec_defer_type_errors = type_errors
+                            , cec_expr_holes = expr_holes
+                            , cec_type_holes = type_holes
+                            , cec_out_of_scope_holes = out_of_scope_holes
+                            , cec_suppress = insolubleWC wanted
+                                 -- See Note [Suppressing error messages]
+                                 -- Suppress low-priority errors if there
+                                 -- are insolule errors anywhere;
+                                 -- See Trac #15539 and c.f. setting ic_status
+                                 -- in TcSimplify.setImplicationStatus
+                            , cec_warn_redundant = warn_redundant
+                            , cec_binds    = binds_var }
+
+       ; tc_lvl <- getTcLevel
+       ; reportWanteds err_ctxt tc_lvl wanted
+       ; traceTc "reportUnsolved }" empty }
+
+--------------------------------------------
+--      Internal functions
+--------------------------------------------
+
+-- | An error Report collects messages categorised by their importance.
+-- See Note [Error report] for details.
+data Report
+  = Report { report_important :: [SDoc]
+           , report_relevant_bindings :: [SDoc]
+           , report_valid_hole_fits :: [SDoc]
+           }
+
+instance Outputable Report where   -- Debugging only
+  ppr (Report { report_important = imp
+              , report_relevant_bindings = rel
+              , report_valid_hole_fits = val })
+    = vcat [ text "important:" <+> vcat imp
+           , text "relevant:"  <+> vcat rel
+           , text "valid:"  <+> vcat val ]
+
+{- Note [Error report]
+The idea is that error msgs are divided into three parts: the main msg, the
+context block (\"In the second argument of ...\"), and the relevant bindings
+block, which are displayed in that order, with a mark to divide them.  The
+idea is that the main msg ('report_important') varies depending on the error
+in question, but context and relevant bindings are always the same, which
+should simplify visual parsing.
+
+The context is added when the Report is passed off to 'mkErrorReport'.
+Unfortunately, unlike the context, the relevant bindings are added in
+multiple places so they have to be in the Report.
+-}
+
+instance Semigroup Report where
+    Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2)
+
+instance Monoid Report where
+    mempty = Report [] [] []
+    mappend = (Semigroup.<>)
+
+-- | Put a doc into the important msgs block.
+important :: SDoc -> Report
+important doc = mempty { report_important = [doc] }
+
+-- | Put a doc into the relevant bindings block.
+relevant_bindings :: SDoc -> Report
+relevant_bindings doc = mempty { report_relevant_bindings = [doc] }
+
+-- | Put a doc into the valid hole fits block.
+valid_hole_fits :: SDoc -> Report
+valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] }
+
+data TypeErrorChoice   -- What to do for type errors found by the type checker
+  = TypeError     -- A type error aborts compilation with an error message
+  | TypeWarn WarnReason
+                  -- A type error is deferred to runtime, plus a compile-time warning
+                  -- The WarnReason should usually be (Reason Opt_WarnDeferredTypeErrors)
+                  -- but it isn't for the Safe Haskell Overlapping Instances warnings
+                  -- see warnAllUnsolved
+  | TypeDefer     -- A type error is deferred to runtime; no error or warning at compile time
+
+data HoleChoice
+  = HoleError     -- A hole is a compile-time error
+  | HoleWarn      -- Defer to runtime, emit a compile-time warning
+  | HoleDefer     -- Defer to runtime, no warning
+
+instance Outputable HoleChoice where
+  ppr HoleError = text "HoleError"
+  ppr HoleWarn  = text "HoleWarn"
+  ppr HoleDefer = text "HoleDefer"
+
+instance Outputable TypeErrorChoice  where
+  ppr TypeError         = text "TypeError"
+  ppr (TypeWarn reason) = text "TypeWarn" <+> ppr reason
+  ppr TypeDefer         = text "TypeDefer"
+
+data ReportErrCtxt
+    = CEC { cec_encl :: [Implication]  -- Enclosing implications
+                                       --   (innermost first)
+                                       -- ic_skols and givens are tidied, rest are not
+          , cec_tidy  :: TidyEnv
+
+          , cec_binds :: EvBindsVar    -- Make some errors (depending on cec_defer)
+                                       -- into warnings, and emit evidence bindings
+                                       -- into 'cec_binds' for unsolved constraints
+
+          , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime
+
+          -- cec_expr_holes is a union of:
+          --   cec_type_holes - a set of typed holes: '_', '_a', '_foo'
+          --   cec_out_of_scope_holes - a set of variables which are
+          --                            out of scope: 'x', 'y', 'bar'
+          , cec_expr_holes :: HoleChoice           -- Holes in expressions
+          , cec_type_holes :: HoleChoice           -- Holes in types
+          , cec_out_of_scope_holes :: HoleChoice   -- Out of scope holes
+
+          , cec_warn_redundant :: Bool    -- True <=> -Wredundant-constraints
+
+          , cec_suppress :: Bool    -- True <=> More important errors have occurred,
+                                    --          so create bindings if need be, but
+                                    --          don't issue any more errors/warnings
+                                    -- See Note [Suppressing error messages]
+      }
+
+instance Outputable ReportErrCtxt where
+  ppr (CEC { cec_binds              = bvar
+           , cec_defer_type_errors  = dte
+           , cec_expr_holes         = eh
+           , cec_type_holes         = th
+           , cec_out_of_scope_holes = osh
+           , cec_warn_redundant     = wr
+           , cec_suppress           = sup })
+    = text "CEC" <+> braces (vcat
+         [ text "cec_binds"              <+> equals <+> ppr bvar
+         , text "cec_defer_type_errors"  <+> equals <+> ppr dte
+         , text "cec_expr_holes"         <+> equals <+> ppr eh
+         , text "cec_type_holes"         <+> equals <+> ppr th
+         , text "cec_out_of_scope_holes" <+> equals <+> ppr osh
+         , text "cec_warn_redundant"     <+> equals <+> ppr wr
+         , text "cec_suppress"           <+> equals <+> ppr sup ])
+
+-- | Returns True <=> the ReportErrCtxt indicates that something is deferred
+deferringAnyBindings :: ReportErrCtxt -> Bool
+  -- Don't check cec_type_holes, as these don't cause bindings to be deferred
+deferringAnyBindings (CEC { cec_defer_type_errors  = TypeError
+                          , cec_expr_holes         = HoleError
+                          , cec_out_of_scope_holes = HoleError }) = False
+deferringAnyBindings _                                            = True
+
+-- | Transforms a 'ReportErrCtxt' into one that does not defer any bindings
+-- at all.
+noDeferredBindings :: ReportErrCtxt -> ReportErrCtxt
+noDeferredBindings ctxt = ctxt { cec_defer_type_errors  = TypeError
+                               , cec_expr_holes         = HoleError
+                               , cec_out_of_scope_holes = HoleError }
+
+{- Note [Suppressing error messages]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The cec_suppress flag says "don't report any errors".  Instead, just create
+evidence bindings (as usual).  It's used when more important errors have occurred.
+
+Specifically (see reportWanteds)
+  * If there are insoluble Givens, then we are in unreachable code and all bets
+    are off.  So don't report any further errors.
+  * If there are any insolubles (eg Int~Bool), here or in a nested implication,
+    then suppress errors from the simple constraints here.  Sometimes the
+    simple-constraint errors are a knock-on effect of the insolubles.
+
+This suppression behaviour is controlled by the Bool flag in
+ReportErrorSpec, as used in reportWanteds.
+
+But we need to take care: flags can turn errors into warnings, and we
+don't want those warnings to suppress subsequent errors (including
+suppressing the essential addTcEvBind for them: Trac #15152). So in
+tryReporter we use askNoErrs to see if any error messages were
+/actually/ produced; if not, we don't switch on suppression.
+
+A consequence is that warnings never suppress warnings, so turning an
+error into a warning may allow subsequent warnings to appear that were
+previously suppressed.   (e.g. partial-sigs/should_fail/T14584)
+-}
+
+reportImplic :: ReportErrCtxt -> Implication -> TcM ()
+reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope
+                                 , ic_given = given
+                                 , ic_wanted = wanted, ic_binds = evb
+                                 , ic_status = status, ic_info = info
+                                 , ic_tclvl = tc_lvl })
+  | BracketSkol <- info
+  , not insoluble
+  = return ()        -- For Template Haskell brackets report only
+                     -- definite errors. The whole thing will be re-checked
+                     -- later when we plug it in, and meanwhile there may
+                     -- certainly be un-satisfied constraints
+
+  | otherwise
+  = do { traceTc "reportImplic" (ppr implic')
+       ; reportWanteds ctxt' tc_lvl wanted
+       ; when (cec_warn_redundant ctxt) $
+         warnRedundantConstraints ctxt' tcl_env info' dead_givens
+       ; when bad_telescope $ reportBadTelescope ctxt tcl_env m_telescope tvs }
+  where
+    tcl_env      = implicLclEnv implic
+    insoluble    = isInsolubleStatus status
+    (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) tvs
+    info'        = tidySkolemInfo env1 info
+    implic' = implic { ic_skols = tvs'
+                     , ic_given = map (tidyEvVar env1) given
+                     , ic_info  = info' }
+    ctxt1 | CoEvBindsVar{} <- evb    = noDeferredBindings ctxt
+          | otherwise                = ctxt
+          -- If we go inside an implication that has no term
+          -- evidence (e.g. unifying under a forall), we can't defer
+          -- type errors.  You could imagine using the /enclosing/
+          -- bindings (in cec_binds), but that may not have enough stuff
+          -- in scope for the bindings to be well typed.  So we just
+          -- switch off deferred type errors altogether.  See Trac #14605.
+
+    ctxt' = ctxt1 { cec_tidy     = env1
+                  , cec_encl     = implic' : cec_encl ctxt
+
+                  , cec_suppress = insoluble || cec_suppress ctxt
+                        -- Suppress inessential errors if there
+                        -- are insolubles anywhere in the
+                        -- tree rooted here, or we've come across
+                        -- a suppress-worthy constraint higher up (Trac #11541)
+
+                  , cec_binds    = evb }
+
+    dead_givens = case status of
+                    IC_Solved { ics_dead = dead } -> dead
+                    _                             -> []
+
+    bad_telescope = case status of
+              IC_BadTelescope -> True
+              _               -> False
+
+warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()
+-- See Note [Tracking redundant constraints] in TcSimplify
+warnRedundantConstraints ctxt env info ev_vars
+ | null redundant_evs
+ = return ()
+
+ | SigSkol {} <- info
+ = setLclEnv env $  -- We want to add "In the type signature for f"
+                    -- to the error context, which is a bit tiresome
+   addErrCtxt (text "In" <+> ppr info) $
+   do { env <- getLclEnv
+      ; msg <- mkErrorReport ctxt env (important doc)
+      ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }
+
+ | otherwise  -- But for InstSkol there already *is* a surrounding
+              -- "In the instance declaration for Eq [a]" context
+              -- and we don't want to say it twice. Seems a bit ad-hoc
+ = do { msg <- mkErrorReport ctxt env (important doc)
+      ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }
+ where
+   doc = text "Redundant constraint" <> plural redundant_evs <> colon
+         <+> pprEvVarTheta redundant_evs
+
+   redundant_evs =
+       filterOut is_type_error $
+       case info of -- See Note [Redundant constraints in instance decls]
+         InstSkol -> filterOut (improving . idType) ev_vars
+         _        -> ev_vars
+
+   -- See #15232
+   is_type_error = isJust . userTypeError_maybe . idType
+
+   improving pred -- (transSuperClasses p) does not include p
+     = any isImprovementPred (pred : transSuperClasses pred)
+
+reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TcTyVar] -> TcM ()
+reportBadTelescope ctxt env (Just telescope) skols
+  = do { msg <- mkErrorReport ctxt env (important doc)
+       ; reportError msg }
+  where
+    doc = hang (text "These kind and type variables:" <+> telescope $$
+                text "are out of dependency order. Perhaps try this ordering:")
+             2 (pprTyVars sorted_tvs)
+
+    sorted_tvs = scopedSort skols
+
+reportBadTelescope _ _ Nothing skols
+  = pprPanic "reportBadTelescope" (ppr skols)
+
+{- Note [Redundant constraints in instance decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For instance declarations, we don't report unused givens if
+they can give rise to improvement.  Example (Trac #10100):
+    class Add a b ab | a b -> ab, a ab -> b
+    instance Add Zero b b
+    instance Add a b ab => Add (Succ a) b (Succ ab)
+The context (Add a b ab) for the instance is clearly unused in terms
+of evidence, since the dictionary has no fields.  But it is still
+needed!  With the context, a wanted constraint
+   Add (Succ Zero) beta (Succ Zero)
+we will reduce to (Add Zero beta Zero), and thence we get beta := Zero.
+But without the context we won't find beta := Zero.
+
+This only matters in instance declarations..
+-}
+
+reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()
+reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics })
+  = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples
+                                       , text "Suppress =" <+> ppr (cec_suppress ctxt)])
+       ; traceTc "rw2" (ppr tidy_cts)
+
+         -- First deal with things that are utterly wrong
+         -- Like Int ~ Bool (incl nullary TyCons)
+         -- or  Int ~ t a   (AppTy on one side)
+         -- These /ones/ are not suppressed by the incoming context
+       ; let ctxt_for_insols = ctxt { cec_suppress = False }
+       ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts
+
+         -- Now all the other constraints.  We suppress errors here if
+         -- any of the first batch failed, or if the enclosing context
+         -- says to suppress
+       ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }
+       ; (_, leftovers) <- tryReporters ctxt2 report2 cts1
+       ; MASSERT2( null leftovers, ppr leftovers )
+
+            -- All the Derived ones have been filtered out of simples
+            -- by the constraint solver. This is ok; we don't want
+            -- to report unsolved Derived goals as errors
+            -- See Note [Do not report derived but soluble errors]
+
+     ; mapBagM_ (reportImplic ctxt2) implics }
+            -- NB ctxt1: don't suppress inner insolubles if there's only a
+            -- wanted insoluble here; but do suppress inner insolubles
+            -- if there's a *given* insoluble here (= inaccessible code)
+ where
+    env = cec_tidy ctxt
+    tidy_cts = bagToList (mapBag (tidyCt env) simples)
+
+    -- report1: ones that should *not* be suppresed by
+    --          an insoluble somewhere else in the tree
+    -- It's crucial that anything that is considered insoluble
+    -- (see TcRnTypes.insolubleCt) is caught here, otherwise
+    -- we might suppress its error message, and proceed on past
+    -- type checking to get a Lint error later
+    report1 = [ ("Out of scope", is_out_of_scope,    True,  mkHoleReporter tidy_cts)
+              , ("Holes",        is_hole,            False, mkHoleReporter tidy_cts)
+              , ("custom_error", is_user_type_error, True,  mkUserTypeErrorReporter)
+
+              , given_eq_spec
+              , ("insoluble2",   utterly_wrong,  True, mkGroupReporter mkEqErr)
+              , ("skolem eq1",   very_wrong,     True, mkSkolReporter)
+              , ("skolem eq2",   skolem_eq,      True, mkSkolReporter)
+              , ("non-tv eq",    non_tv_eq,      True, mkSkolReporter)
+
+                  -- The only remaining equalities are alpha ~ ty,
+                  -- where alpha is untouchable; and representational equalities
+                  -- Prefer homogeneous equalities over hetero, because the
+                  -- former might be holding up the latter.
+                  -- See Note [Equalities with incompatible kinds] in TcCanonical
+              , ("Homo eqs",      is_homo_equality, True,  mkGroupReporter mkEqErr)
+              , ("Other eqs",     is_equality,      False, mkGroupReporter mkEqErr) ]
+
+    -- report2: we suppress these if there are insolubles elsewhere in the tree
+    report2 = [ ("Implicit params", is_ip,           False, mkGroupReporter mkIPErr)
+              , ("Irreds",          is_irred,        False, mkGroupReporter mkIrredErr)
+              , ("Dicts",           is_dict,         False, mkGroupReporter mkDictErr) ]
+
+    -- rigid_nom_eq, rigid_nom_tv_eq,
+    is_hole, is_dict,
+      is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool
+
+    is_given_eq ct pred
+       | EqPred {} <- pred = arisesFromGivens ct
+       | otherwise         = False
+       -- I think all given residuals are equalities
+
+    -- Things like (Int ~N Bool)
+    utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2
+    utterly_wrong _ _                      = False
+
+    -- Things like (a ~N Int)
+    very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2
+    very_wrong _ _                      = False
+
+    -- Things like (a ~N b) or (a  ~N  F Bool)
+    skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1
+    skolem_eq _ _                    = False
+
+    -- Things like (F a  ~N  Int)
+    non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1)
+    non_tv_eq _ _                    = False
+
+    is_out_of_scope ct _ = isOutOfScopeCt ct
+    is_hole         ct _ = isHoleCt ct
+
+    is_user_type_error ct _ = isUserTypeErrorCt ct
+
+    is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2
+    is_homo_equality _ _                  = False
+
+    is_equality _ (EqPred {}) = True
+    is_equality _ _           = False
+
+    is_dict _ (ClassPred {}) = True
+    is_dict _ _              = False
+
+    is_ip _ (ClassPred cls _) = isIPClass cls
+    is_ip _ _                 = False
+
+    is_irred _ (IrredPred {}) = True
+    is_irred _ _              = False
+
+    given_eq_spec  -- See Note [Given errors]
+      | has_gadt_match (cec_encl ctxt)
+      = ("insoluble1a", is_given_eq, True,  mkGivenErrorReporter)
+      | otherwise
+      = ("insoluble1b", is_given_eq, False, ignoreErrorReporter)
+          -- False means don't suppress subsequent errors
+          -- Reason: we don't report all given errors
+          --         (see mkGivenErrorReporter), and we should only suppress
+          --         subsequent errors if we actually report this one!
+          --         Trac #13446 is an example
+
+    -- See Note [Given errors]
+    has_gadt_match [] = False
+    has_gadt_match (implic : implics)
+      | PatSkol {} <- ic_info implic
+      , not (ic_no_eqs implic)
+      , wopt Opt_WarnInaccessibleCode (implicDynFlags implic)
+          -- Don't bother doing this if -Winaccessible-code isn't enabled.
+          -- See Note [Avoid -Winaccessible-code when deriving] in TcInstDcls.
+      = True
+      | otherwise
+      = has_gadt_match implics
+
+---------------
+isSkolemTy :: TcLevel -> Type -> Bool
+-- The type is a skolem tyvar
+isSkolemTy tc_lvl ty
+  | Just tv <- getTyVar_maybe ty
+  =  isSkolemTyVar tv
+  || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv)
+     -- The last case is for touchable TyVarTvs
+     -- we postpone untouchables to a latter test (too obscure)
+
+  | otherwise
+  = False
+
+isTyFun_maybe :: Type -> Maybe TyCon
+isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of
+                      Just (tc,_) | isTypeFamilyTyCon tc -> Just tc
+                      _ -> Nothing
+
+--------------------------------------------
+--      Reporters
+--------------------------------------------
+
+type Reporter
+  = ReportErrCtxt -> [Ct] -> TcM ()
+type ReporterSpec
+  = ( String                     -- Name
+    , Ct -> PredTree -> Bool     -- Pick these ones
+    , Bool                       -- True <=> suppress subsequent reporters
+    , Reporter)                  -- The reporter itself
+
+mkSkolReporter :: Reporter
+-- Suppress duplicates with either the same LHS, or same location
+mkSkolReporter ctxt cts
+  = mapM_ (reportGroup mkEqErr ctxt) (group cts)
+  where
+     group [] = []
+     group (ct:cts) = (ct : yeses) : group noes
+        where
+          (yeses, noes) = partition (group_with ct) cts
+
+     group_with ct1 ct2
+       | EQ <- cmp_loc ct1 ct2 = True
+       | eq_lhs_type   ct1 ct2 = True
+       | otherwise             = False
+
+mkHoleReporter :: [Ct] -> Reporter
+-- Reports errors one at a time
+mkHoleReporter tidy_simples ctxt
+  = mapM_ $ \ct -> do { err <- mkHoleError tidy_simples ctxt ct
+                      ; maybeReportHoleError ctxt ct err
+                      ; maybeAddDeferredHoleBinding ctxt err ct }
+
+mkUserTypeErrorReporter :: Reporter
+mkUserTypeErrorReporter ctxt
+  = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct
+                      ; maybeReportError ctxt err
+                      ; addDeferredBinding ctxt err ct }
+
+mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg
+mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct
+                        $ important
+                        $ pprUserTypeErrorTy
+                        $ case getUserTypeErrorMsg ct of
+                            Just msg -> msg
+                            Nothing  -> pprPanic "mkUserTypeError" (ppr ct)
+
+
+mkGivenErrorReporter :: Reporter
+-- See Note [Given errors]
+mkGivenErrorReporter ctxt cts
+  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
+       ; dflags <- getDynFlags
+       ; let (implic:_) = cec_encl ctxt
+                 -- Always non-empty when mkGivenErrorReporter is called
+             ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (implicLclEnv implic))
+                   -- For given constraints we overwrite the env (and hence src-loc)
+                   -- with one from the immediately-enclosing implication.
+                   -- See Note [Inaccessible code]
+
+             inaccessible_msg = hang (text "Inaccessible code in")
+                                   2 (ppr (ic_info implic))
+             report = important inaccessible_msg `mappend`
+                      relevant_bindings binds_msg
+
+       ; err <- mkEqErr_help dflags ctxt report ct'
+                             Nothing ty1 ty2
+
+       ; traceTc "mkGivenErrorReporter" (ppr ct)
+       ; reportWarning (Reason Opt_WarnInaccessibleCode) err }
+  where
+    (ct : _ )  = cts    -- Never empty
+    (ty1, ty2) = getEqPredTys (ctPred ct)
+
+ignoreErrorReporter :: Reporter
+-- Discard Given errors that don't come from
+-- a pattern match; maybe we should warn instead?
+ignoreErrorReporter ctxt cts
+  = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt))
+       ; return () }
+
+
+{- Note [Given errors]
+~~~~~~~~~~~~~~~~~~~~~~
+Given constraints represent things for which we have (or will have)
+evidence, so they aren't errors.  But if a Given constraint is
+insoluble, this code is inaccessible, and we might want to at least
+warn about that.  A classic case is
+
+   data T a where
+     T1 :: T Int
+     T2 :: T a
+     T3 :: T Bool
+
+   f :: T Int -> Bool
+   f T1 = ...
+   f T2 = ...
+   f T3 = ...  -- We want to report this case as inaccessible
+
+We'd like to point out that the T3 match is inaccessible. It
+will have a Given constraint [G] Int ~ Bool.
+
+But we don't want to report ALL insoluble Given constraints.  See Trac
+#12466 for a long discussion.  For example, if we aren't careful
+we'll complain about
+   f :: ((Int ~ Bool) => a -> a) -> Int
+which arguably is OK.  It's more debatable for
+   g :: (Int ~ Bool) => Int -> Int
+but it's tricky to distinguish these cases so we don't report
+either.
+
+The bottom line is this: has_gadt_match looks for an enclosing
+pattern match which binds some equality constraints.  If we
+find one, we report the insoluble Given.
+-}
+
+mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
+                             -- Make error message for a group
+                -> Reporter  -- Deal with lots of constraints
+-- Group together errors from same location,
+-- and report only the first (to avoid a cascade)
+mkGroupReporter mk_err ctxt cts
+  = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)
+
+eq_lhs_type :: Ct -> Ct -> Bool
+eq_lhs_type ct1 ct2
+  = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of
+       (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->
+         (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2)
+       _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)
+
+cmp_loc :: Ct -> Ct -> Ordering
+cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)
+
+reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt
+            -> [Ct] -> TcM ()
+reportGroup mk_err ctxt cts =
+  case partition isMonadFailInstanceMissing cts of
+        -- Only warn about missing MonadFail constraint when
+        -- there are no other missing constraints!
+        (monadFailCts, []) ->
+            do { err <- mk_err ctxt monadFailCts
+               ; reportWarning (Reason Opt_WarnMissingMonadFailInstances) err }
+
+        (_, cts') -> do { err <- mk_err ctxt cts'
+                        ; traceTc "About to maybeReportErr" $
+                          vcat [ text "Constraint:"             <+> ppr cts'
+                               , text "cec_suppress ="          <+> ppr (cec_suppress ctxt)
+                               , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]
+                        ; maybeReportError ctxt err
+                            -- But see Note [Always warn with -fdefer-type-errors]
+                        ; traceTc "reportGroup" (ppr cts')
+                        ; mapM_ (addDeferredBinding ctxt err) cts' }
+                            -- Add deferred bindings for all
+                            -- Redundant if we are going to abort compilation,
+                            -- but that's hard to know for sure, and if we don't
+                            -- abort, we need bindings for all (e.g. Trac #12156)
+  where
+    isMonadFailInstanceMissing ct =
+        case ctLocOrigin (ctLoc ct) of
+            FailablePattern _pat -> True
+            _otherwise           -> False
+
+maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()
+-- Unlike maybeReportError, these "hole" errors are
+-- /not/ suppressed by cec_suppress.  We want to see them!
+maybeReportHoleError ctxt ct err
+  -- When -XPartialTypeSignatures is on, warnings (instead of errors) are
+  -- generated for holes in partial type signatures.
+  -- Unless -fwarn_partial_type_signatures is not on,
+  -- in which case the messages are discarded.
+  | isTypeHoleCt ct
+  = -- For partial type signatures, generate warnings only, and do that
+    -- only if -fwarn_partial_type_signatures is on
+    case cec_type_holes ctxt of
+       HoleError -> reportError err
+       HoleWarn  -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err
+       HoleDefer -> return ()
+
+  -- Always report an error for out-of-scope variables
+  -- Unless -fdefer-out-of-scope-variables is on,
+  -- in which case the messages are discarded.
+  -- See Trac #12170, #12406
+  | isOutOfScopeCt ct
+  = -- If deferring, report a warning only if -Wout-of-scope-variables is on
+    case cec_out_of_scope_holes ctxt of
+      HoleError -> reportError err
+      HoleWarn  ->
+        reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err
+      HoleDefer -> return ()
+
+  -- Otherwise this is a typed hole in an expression,
+  -- but not for an out-of-scope variable
+  | otherwise
+  = -- If deferring, report a warning only if -Wtyped-holes is on
+    case cec_expr_holes ctxt of
+       HoleError -> reportError err
+       HoleWarn  -> reportWarning (Reason Opt_WarnTypedHoles) err
+       HoleDefer -> return ()
+
+maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()
+-- Report the error and/or make a deferred binding for it
+maybeReportError ctxt err
+  | cec_suppress ctxt    -- Some worse error has occurred;
+  = return ()            -- so suppress this error/warning
+
+  | otherwise
+  = case cec_defer_type_errors ctxt of
+      TypeDefer       -> return ()
+      TypeWarn reason -> reportWarning reason err
+      TypeError       -> reportError err
+
+addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
+-- See Note [Deferring coercion errors to runtime]
+addDeferredBinding ctxt err ct
+  | deferringAnyBindings ctxt
+  , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct
+    -- Only add deferred bindings for Wanted constraints
+  = do { dflags <- getDynFlags
+       ; let err_msg = pprLocErrMsg err
+             err_fs  = mkFastString $ showSDoc dflags $
+                       err_msg $$ text "(deferred type error)"
+             err_tm  = evDelayedError pred err_fs
+             ev_binds_var = cec_binds ctxt
+
+       ; case dest of
+           EvVarDest evar
+             -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm
+           HoleDest hole
+             -> do { -- See Note [Deferred errors for coercion holes]
+                     let co_var = coHoleCoVar hole
+                   ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm
+                   ; fillCoercionHole hole (mkTcCoVarCo co_var) }}
+
+  | otherwise   -- Do not set any evidence for Given/Derived
+  = return ()
+
+maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()
+maybeAddDeferredHoleBinding ctxt err ct
+  | isExprHoleCt ct
+  = addDeferredBinding ctxt err ct  -- Only add bindings for holes in expressions
+  | otherwise                       -- not for holes in partial type signatures
+  = return ()
+
+tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
+-- Use the first reporter in the list whose predicate says True
+tryReporters ctxt reporters cts
+  = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts
+       ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts)
+       ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts
+       ; traceTc "tryReporters }" (ppr cts')
+       ; return (ctxt', cts') }
+  where
+    go ctxt [] vis_cts invis_cts
+      = return (ctxt, vis_cts ++ invis_cts)
+
+    go ctxt (r : rs) vis_cts invis_cts
+       -- always look at *visible* Origins before invisible ones
+       -- this is the whole point of isVisibleOrigin
+      = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts
+           ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts
+           ; go ctxt'' rs vis_cts' invis_cts' }
+                -- Carry on with the rest, because we must make
+                -- deferred bindings for them if we have -fdefer-type-errors
+                -- But suppress their error messages
+
+tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])
+tryReporter ctxt (str, keep_me,  suppress_after, reporter) cts
+  | null yeses
+  = return (ctxt, cts)
+  | otherwise
+  = do { traceTc "tryReporter{ " (text str <+> ppr yeses)
+       ; (_, no_errs) <- askNoErrs (reporter ctxt yeses)
+       ; let suppress_now = not no_errs && suppress_after
+                            -- See Note [Suppressing error messages]
+             ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt }
+       ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after)
+       ; return (ctxt', nos) }
+  where
+    (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts
+
+
+pprArising :: CtOrigin -> SDoc
+-- Used for the main, top-level error message
+-- We've done special processing for TypeEq, KindEq, Given
+pprArising (TypeEqOrigin {}) = empty
+pprArising (KindEqOrigin {}) = empty
+pprArising (GivenOrigin {})  = empty
+pprArising orig              = pprCtOrigin orig
+
+-- Add the "arising from..." part to a message about bunch of dicts
+addArising :: CtOrigin -> SDoc -> SDoc
+addArising orig msg = hang msg 2 (pprArising orig)
+
+pprWithArising :: [Ct] -> (CtLoc, SDoc)
+-- Print something like
+--    (Eq a) arising from a use of x at y
+--    (Show a) arising from a use of p at q
+-- Also return a location for the error message
+-- Works for Wanted/Derived only
+pprWithArising []
+  = panic "pprWithArising"
+pprWithArising (ct:cts)
+  | null cts
+  = (loc, addArising (ctLocOrigin loc)
+                     (pprTheta [ctPred ct]))
+  | otherwise
+  = (loc, vcat (map ppr_one (ct:cts)))
+  where
+    loc = ctLoc ct
+    ppr_one ct' = hang (parens (pprType (ctPred ct')))
+                     2 (pprCtLoc (ctLoc ct'))
+
+mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg
+mkErrorMsgFromCt ctxt ct report
+  = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report
+
+mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg
+mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs)
+  = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
+       ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env))
+            (errDoc important [context] (relevant_bindings ++ valid_subs))
+       }
+
+type UserGiven = Implication
+
+getUserGivens :: ReportErrCtxt -> [UserGiven]
+-- One item for each enclosing implication
+getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics
+
+getUserGivensFromImplics :: [Implication] -> [UserGiven]
+getUserGivensFromImplics implics
+  = reverse (filterOut (null . ic_given) implics)
+
+{- Note [Always warn with -fdefer-type-errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When -fdefer-type-errors is on we warn about *all* type errors, even
+if cec_suppress is on.  This can lead to a lot more warnings than you
+would get errors without -fdefer-type-errors, but if we suppress any of
+them you might get a runtime error that wasn't warned about at compile
+time.
+
+This is an easy design choice to change; just flip the order of the
+first two equations for maybeReportError
+
+To be consistent, we should also report multiple warnings from a single
+location in mkGroupReporter, when -fdefer-type-errors is on.  But that
+is perhaps a bit *over*-consistent! Again, an easy choice to change.
+
+With #10283, you can now opt out of deferred type error warnings.
+
+Note [Deferred errors for coercion holes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we need to defer a type error where the destination for the evidence
+is a coercion hole. We can't just put the error in the hole, because we can't
+make an erroneous coercion. (Remember that coercions are erased for runtime.)
+Instead, we invent a new EvVar, bind it to an error and then make a coercion
+from that EvVar, filling the hole with that coercion. Because coercions'
+types are unlifted, the error is guaranteed to be hit before we get to the
+coercion.
+
+Note [Do not report derived but soluble errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The wc_simples include Derived constraints that have not been solved,
+but are not insoluble (in that case they'd be reported by 'report1').
+We do not want to report these as errors:
+
+* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have
+  an unsolved [D] Eq a, and we do not want to report that; it's just noise.
+
+* Functional dependencies.  For givens, consider
+      class C a b | a -> b
+      data T a where
+         MkT :: C a d => [d] -> T a
+      f :: C a b => T a -> F Int
+      f (MkT xs) = length xs
+  Then we get a [D] b~d.  But there *is* a legitimate call to
+  f, namely   f (MkT [True]) :: T Bool, in which b=d.  So we should
+  not reject the program.
+
+  For wanteds, something similar
+      data T a where
+        MkT :: C Int b => a -> b -> T a
+      g :: C Int c => c -> ()
+      f :: T a -> ()
+      f (MkT x y) = g x
+  Here we get [G] C Int b, [W] C Int a, hence [D] a~b.
+  But again f (MkT True True) is a legitimate call.
+
+(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose
+derived superclasses between iterations of the solver.)
+
+For functional dependencies, here is a real example,
+stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs
+
+  class C a b | a -> b
+  g :: C a b => a -> b -> ()
+  f :: C a b => a -> b -> ()
+  f xa xb =
+      let loop = g xa
+      in loop xb
+
+We will first try to infer a type for loop, and we will succeed:
+    C a b' => b' -> ()
+Subsequently, we will type check (loop xb) and all is good. But,
+recall that we have to solve a final implication constraint:
+    C a b => (C a b' => .... cts from body of loop .... ))
+And now we have a problem as we will generate an equality b ~ b' and fail to
+solve it.
+
+
+************************************************************************
+*                                                                      *
+                Irreducible predicate errors
+*                                                                      *
+************************************************************************
+-}
+
+mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
+mkIrredErr ctxt cts
+  = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
+       ; let orig = ctOrigin ct1
+             msg  = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig)
+       ; mkErrorMsgFromCt ctxt ct1 $
+            important msg `mappend` relevant_bindings binds_msg }
+  where
+    (ct1:_) = cts
+
+----------------
+mkHoleError :: [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg
+mkHoleError _ _ ct@(CHoleCan { cc_hole = ExprHole (OutOfScope occ rdr_env0) })
+  -- Out-of-scope variables, like 'a', where 'a' isn't bound; suggest possible
+  -- in-scope variables in the message, and note inaccessible exact matches
+  = do { dflags   <- getDynFlags
+       ; imp_info <- getImports
+       ; curr_mod <- getModule
+       ; hpt <- getHpt
+       ; let suggs_msg = unknownNameSuggestions dflags hpt curr_mod rdr_env0
+                                                (tcl_rdr lcl_env) imp_info rdr
+       ; rdr_env     <- getGlobalRdrEnv
+       ; splice_locs <- getTopLevelSpliceLocs
+       ; let match_msgs = mk_match_msgs rdr_env splice_locs
+       ; mkErrDocAt (RealSrcSpan err_loc) $
+                    errDoc [out_of_scope_msg] [] (match_msgs ++ [suggs_msg]) }
+
+  where
+    rdr         = mkRdrUnqual occ
+    ct_loc      = ctLoc ct
+    lcl_env     = ctLocEnv ct_loc
+    err_loc     = tcl_loc lcl_env
+    hole_ty     = ctEvPred (ctEvidence ct)
+    boring_type = isTyVarTy hole_ty
+
+    out_of_scope_msg -- Print v :: ty only if the type has structure
+      | boring_type = hang herald 2 (ppr occ)
+      | otherwise   = hang herald 2 (pp_with_type occ hole_ty)
+
+    herald | isDataOcc occ = text "Data constructor not in scope:"
+           | otherwise     = text "Variable not in scope:"
+
+    -- Indicate if the out-of-scope variable exactly (and unambiguously) matches
+    -- a top-level binding in a later inter-splice group; see Note [OutOfScope
+    -- exact matches]
+    mk_match_msgs rdr_env splice_locs
+      = let gres = filter isLocalGRE (lookupGlobalRdrEnv rdr_env occ)
+        in case gres of
+             [gre]
+               |  RealSrcSpan bind_loc <- greSrcSpan gre
+                  -- Find splice between the unbound variable and the match; use
+                  -- lookupLE, not lookupLT, since match could be in the splice
+               ,  Just th_loc <- Set.lookupLE bind_loc splice_locs
+               ,  err_loc < th_loc
+               -> [mk_bind_scope_msg bind_loc th_loc]
+             _ -> []
+
+    mk_bind_scope_msg bind_loc th_loc
+      | is_th_bind
+      = hang (quotes (ppr occ) <+> parens (text "splice on" <+> th_rng))
+           2 (text "is not in scope before line" <+> int th_start_ln)
+      | otherwise
+      = hang (quotes (ppr occ) <+> bind_rng <+> text "is not in scope")
+           2 (text "before the splice on" <+> th_rng)
+      where
+        bind_rng = parens (text "line" <+> int bind_ln)
+        th_rng
+          | th_start_ln == th_end_ln = single
+          | otherwise                = multi
+        single = text "line"  <+> int th_start_ln
+        multi  = text "lines" <+> int th_start_ln <> text "-" <> int th_end_ln
+        bind_ln     = srcSpanStartLine bind_loc
+        th_start_ln = srcSpanStartLine th_loc
+        th_end_ln   = srcSpanEndLine   th_loc
+        is_th_bind = th_loc `containsSpan` bind_loc
+
+mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_hole = hole })
+  -- Explicit holes, like "_" or "_f"
+  = do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct
+               -- The 'False' means "don't filter the bindings"; see Trac #8191
+
+       ; show_hole_constraints <- goptM Opt_ShowHoleConstraints
+       ; let constraints_msg
+               | isExprHoleCt ct, show_hole_constraints
+                  = givenConstraintsMsg ctxt
+               | otherwise = empty
+
+       ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits
+       ; (ctxt, sub_msg) <- if show_valid_hole_fits
+                            then validHoleFits ctxt tidy_simples ct
+                            else return (ctxt, empty)
+       ; mkErrorMsgFromCt ctxt ct $
+            important hole_msg `mappend`
+            relevant_bindings (binds_msg $$ constraints_msg) `mappend`
+            valid_hole_fits sub_msg}
+
+  where
+    occ       = holeOcc hole
+    hole_ty   = ctEvPred (ctEvidence ct)
+    hole_kind = tcTypeKind hole_ty
+    tyvars    = tyCoVarsOfTypeList hole_ty
+
+    hole_msg = case hole of
+      ExprHole {} -> vcat [ hang (text "Found hole:")
+                               2 (pp_with_type occ hole_ty)
+                          , tyvars_msg, expr_hole_hint ]
+      TypeHole {} -> vcat [ hang (text "Found type wildcard" <+>
+                                  quotes (ppr occ))
+                               2 (text "standing for" <+>
+                                  quotes pp_hole_type_with_kind)
+                          , tyvars_msg, type_hole_hint ]
+
+    pp_hole_type_with_kind
+      | isLiftedTypeKind hole_kind
+        || isCoVarType hole_ty -- Don't print the kind of unlifted
+                               -- equalities (#15039)
+      = pprType hole_ty
+      | otherwise
+      = pprType hole_ty <+> dcolon <+> pprKind hole_kind
+
+    tyvars_msg = ppUnless (null tyvars) $
+                 text "Where:" <+> (vcat (map loc_msg other_tvs)
+                                    $$ pprSkols ctxt skol_tvs)
+       where
+         (skol_tvs, other_tvs) = partition is_skol tyvars
+         is_skol tv = isTcTyVar tv && isSkolemTyVar tv
+                      -- Coercion variables can be free in the
+                      -- hole, via kind casts
+
+    type_hole_hint
+         | HoleError <- cec_type_holes ctxt
+         = text "To use the inferred type, enable PartialTypeSignatures"
+         | otherwise
+         = empty
+
+    expr_hole_hint                       -- Give hint for, say,   f x = _x
+         | lengthFS (occNameFS occ) > 1  -- Don't give this hint for plain "_"
+         = text "Or perhaps" <+> quotes (ppr occ)
+           <+> text "is mis-spelled, or not in scope"
+         | otherwise
+         = empty
+
+    loc_msg tv
+       | isTyVar tv
+       = case tcTyVarDetails tv of
+           MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable"
+           _         -> empty  -- Skolems dealt with already
+       | otherwise  -- A coercion variable can be free in the hole type
+       = sdocWithDynFlags $ \dflags ->
+         if gopt Opt_PrintExplicitCoercions dflags
+         then quotes (ppr tv) <+> text "is a coercion variable"
+         else empty
+
+mkHoleError _ _ ct = pprPanic "mkHoleError" (ppr ct)
+
+-- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module
+-- imports
+validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the
+                                        -- implications and the tidy environment
+                       -> [Ct]          -- Unsolved simple constraints
+                       -> Ct            -- The hole constraint.
+                       -> TcM (ReportErrCtxt, SDoc) -- We return the new context
+                                                    -- with a possibly updated
+                                                    -- tidy environment, and
+                                                    -- the message.
+validHoleFits ctxt@(CEC {cec_encl = implics
+                             , cec_tidy = lcl_env}) simps ct
+  = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps ct
+       ; return (ctxt {cec_tidy = tidy_env}, msg) }
+
+-- See Note [Constraints include ...]
+givenConstraintsMsg :: ReportErrCtxt -> SDoc
+givenConstraintsMsg ctxt =
+    let constraints :: [(Type, RealSrcSpan)]
+        constraints =
+          do { implic@Implic{ ic_given = given } <- cec_encl ctxt
+             ; constraint <- given
+             ; return (varType constraint, tcl_loc (implicLclEnv implic)) }
+
+        pprConstraint (constraint, loc) =
+          ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))
+
+    in ppUnless (null constraints) $
+         hang (text "Constraints include")
+            2 (vcat $ map pprConstraint constraints)
+
+pp_with_type :: OccName -> Type -> SDoc
+pp_with_type occ ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType ty)
+
+----------------
+mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
+mkIPErr ctxt cts
+  = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1
+       ; let orig    = ctOrigin ct1
+             preds   = map ctPred cts
+             givens  = getUserGivens ctxt
+             msg | null givens
+                 = addArising orig $
+                   sep [ text "Unbound implicit parameter" <> plural cts
+                       , nest 2 (pprParendTheta preds) ]
+                 | otherwise
+                 = couldNotDeduce givens (preds, orig)
+
+       ; mkErrorMsgFromCt ctxt ct1 $
+            important msg `mappend` relevant_bindings binds_msg }
+  where
+    (ct1:_) = cts
+
+{-
+
+Note [Constraints include ...]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'givenConstraintsMsg' returns the "Constraints include ..." message enabled by
+-fshow-hole-constraints. For example, the following hole:
+
+    foo :: (Eq a, Show a) => a -> String
+    foo x = _
+
+would generate the message:
+
+    Constraints include
+      Eq a (from foo.hs:1:1-36)
+      Show a (from foo.hs:1:1-36)
+
+Constraints are displayed in order from innermost (closest to the hole) to
+outermost. There's currently no filtering or elimination of duplicates.
+
+
+Note [OutOfScope exact matches]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When constructing an out-of-scope error message, we not only generate a list of
+possible in-scope alternatives but also search for an exact, unambiguous match
+in a later inter-splice group.  If we find such a match, we report its presence
+(and indirectly, its scope) in the message.  For example, if a module A contains
+the following declarations,
+
+   foo :: Int
+   foo = x
+
+   $(return [])  -- Empty top-level splice
+
+   x :: Int
+   x = 23
+
+we will issue an error similar to
+
+   A.hs:6:7: error:
+       • Variable not in scope: x :: Int
+       • ‘x’ (line 11) is not in scope before the splice on line 8
+
+By providing information about the match, we hope to clarify why declaring a
+variable after a top-level splice but using it before the splice generates an
+out-of-scope error (a situation which is often confusing to Haskell newcomers).
+
+Note that if we find multiple exact matches to the out-of-scope variable
+(hereafter referred to as x), we report nothing.  Such matches can only be
+duplicate record fields, as the presence of any other duplicate top-level
+declarations would have already halted compilation.  But if these record fields
+are declared in a later inter-splice group, then so too are their corresponding
+types.  Thus, these types must not occur in the inter-splice group containing x
+(any unknown types would have already been reported), and so the matches to the
+record fields are most likely coincidental.
+
+One oddity of the exact match portion of the error message is that we specify
+where the match to x is NOT in scope.  Why not simply state where the match IS
+in scope?  It most cases, this would be just as easy and perhaps a little
+clearer for the user.  But now consider the following example:
+
+    {-# LANGUAGE TemplateHaskell #-}
+
+    module A where
+
+    import Language.Haskell.TH
+    import Language.Haskell.TH.Syntax
+
+    foo = x
+
+    $(do -------------------------------------------------
+        ds <- [d| ok1 = x
+                |]
+        addTopDecls ds
+        return [])
+
+    bar = $(do
+            ds <- [d| x = 23
+                      ok2 = x
+                    |]
+            addTopDecls ds
+            litE $ stringL "hello")
+
+    $(return []) -----------------------------------------
+
+    ok3 = x
+
+Here, x is out-of-scope in the declaration of foo, and so we report
+
+    A.hs:8:7: error:
+        • Variable not in scope: x
+        • ‘x’ (line 16) is not in scope before the splice on lines 10-14
+
+If we instead reported where x IS in scope, we would have to state that it is in
+scope after the second top-level splice as well as among all the top-level
+declarations added by both calls to addTopDecls.  But doing so would not only
+add complexity to the code but also overwhelm the user with unneeded
+information.
+
+The logic which determines where x is not in scope is straightforward: it simply
+finds the last top-level splice which occurs after x but before (or at) the
+match to x (assuming such a splice exists).  In most cases, the check that the
+splice occurs after x acts only as a sanity check.  For example, when the match
+to x is a non-TH top-level declaration and a splice S occurs before the match,
+then x must precede S; otherwise, it would be in scope.  But when dealing with
+addTopDecls, this check serves a practical purpose.  Consider the following
+declarations:
+
+    $(do
+        ds <- [d| ok = x
+                  x = 23
+                |]
+        addTopDecls ds
+        return [])
+
+    foo = x
+
+In this case, x is not in scope in the declaration for foo.  Since x occurs
+AFTER the splice containing the match, the logic does not find any splices after
+x but before or at its match, and so we report nothing about x's scope.  If we
+had not checked whether x occurs before the splice, we would have instead
+reported that x is not in scope before the splice.  While correct, such an error
+message is more likely to confuse than to enlighten.
+-}
+
+{-
+************************************************************************
+*                                                                      *
+                Equality errors
+*                                                                      *
+************************************************************************
+
+Note [Inaccessible code]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   data T a where
+     T1 :: T a
+     T2 :: T Bool
+
+   f :: (a ~ Int) => T a -> Int
+   f T1 = 3
+   f T2 = 4   -- Unreachable code
+
+Here the second equation is unreachable. The original constraint
+(a~Int) from the signature gets rewritten by the pattern-match to
+(Bool~Int), so the danger is that we report the error as coming from
+the *signature* (Trac #7293).  So, for Given errors we replace the
+env (and hence src-loc) on its CtLoc with that from the immediately
+enclosing implication.
+
+Note [Error messages for untouchables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #9109)
+  data G a where { GBool :: G Bool }
+  foo x = case x of GBool -> True
+
+Here we can't solve (t ~ Bool), where t is the untouchable result
+meta-var 't', because of the (a ~ Bool) from the pattern match.
+So we infer the type
+   f :: forall a t. G a -> t
+making the meta-var 't' into a skolem.  So when we come to report
+the unsolved (t ~ Bool), t won't look like an untouchable meta-var
+any more.  So we don't assert that it is.
+-}
+
+-- Don't have multiple equality errors from the same location
+-- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!
+mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
+mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct
+mkEqErr _ [] = panic "mkEqErr"
+
+mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg
+mkEqErr1 ctxt ct   -- Wanted or derived;
+                   -- givens handled in mkGivenErrorReporter
+  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
+       ; rdr_env <- getGlobalRdrEnv
+       ; fam_envs <- tcGetFamInstEnvs
+       ; exp_syns <- goptM Opt_PrintExpandedSynonyms
+       ; let (keep_going, is_oriented, wanted_msg)
+                           = mk_wanted_extra (ctLoc ct) exp_syns
+             coercible_msg = case ctEqRel ct of
+               NomEq  -> empty
+               ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2
+       ; dflags <- getDynFlags
+       ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct) $$ ppr keep_going)
+       ; let report = mconcat [important wanted_msg, important coercible_msg,
+                               relevant_bindings binds_msg]
+       ; if keep_going
+         then mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2
+         else mkErrorMsgFromCt ctxt ct report }
+  where
+    (ty1, ty2) = getEqPredTys (ctPred ct)
+
+       -- If the types in the error message are the same as the types
+       -- we are unifying, don't add the extra expected/actual message
+    mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc)
+    mk_wanted_extra loc expandSyns
+      = case ctLocOrigin loc of
+          orig@TypeEqOrigin {} -> mkExpectedActualMsg ty1 ty2 orig
+                                                      t_or_k expandSyns
+            where
+              t_or_k = ctLocTypeOrKind_maybe loc
+
+          KindEqOrigin cty1 mb_cty2 sub_o sub_t_or_k
+            -> (True, Nothing, msg1 $$ msg2)
+            where
+              sub_what = case sub_t_or_k of Just KindLevel -> text "kinds"
+                                            _              -> text "types"
+              msg1 = sdocWithDynFlags $ \dflags ->
+                     case mb_cty2 of
+                       Just cty2
+                         |  gopt Opt_PrintExplicitCoercions dflags
+                         || not (cty1 `pickyEqType` cty2)
+                         -> hang (text "When matching" <+> sub_what)
+                               2 (vcat [ ppr cty1 <+> dcolon <+>
+                                         ppr (tcTypeKind cty1)
+                                       , ppr cty2 <+> dcolon <+>
+                                         ppr (tcTypeKind cty2) ])
+                       _ -> text "When matching the kind of" <+> quotes (ppr cty1)
+              msg2 = case sub_o of
+                       TypeEqOrigin {}
+                         | Just cty2 <- mb_cty2 ->
+                         thdOf3 (mkExpectedActualMsg cty1 cty2 sub_o sub_t_or_k
+                                                     expandSyns)
+                       _ -> empty
+          _ -> (True, Nothing, empty)
+
+-- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint
+-- is left over.
+mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs
+                       -> TcType -> TcType -> SDoc
+mkCoercibleExplanation rdr_env fam_envs ty1 ty2
+  | Just (tc, tys) <- tcSplitTyConApp_maybe ty1
+  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
+  , Just msg <- coercible_msg_for_tycon rep_tc
+  = msg
+  | Just (tc, tys) <- splitTyConApp_maybe ty2
+  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys
+  , Just msg <- coercible_msg_for_tycon rep_tc
+  = msg
+  | Just (s1, _) <- tcSplitAppTy_maybe ty1
+  , Just (s2, _) <- tcSplitAppTy_maybe ty2
+  , s1 `eqType` s2
+  , has_unknown_roles s1
+  = hang (text "NB: We cannot know what roles the parameters to" <+>
+          quotes (ppr s1) <+> text "have;")
+       2 (text "we must assume that the role is nominal")
+  | otherwise
+  = empty
+  where
+    coercible_msg_for_tycon tc
+        | isAbstractTyCon tc
+        = Just $ hsep [ text "NB: The type constructor"
+                      , quotes (pprSourceTyCon tc)
+                      , text "is abstract" ]
+        | isNewTyCon tc
+        , [data_con] <- tyConDataCons tc
+        , let dc_name = dataConName data_con
+        , isNothing (lookupGRE_Name rdr_env dc_name)
+        = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name))
+                    2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)
+                           , text "is not in scope" ])
+        | otherwise = Nothing
+
+    has_unknown_roles ty
+      | Just (tc, tys) <- tcSplitTyConApp_maybe ty
+      = tys `lengthAtLeast` tyConArity tc  -- oversaturated tycon
+      | Just (s, _) <- tcSplitAppTy_maybe ty
+      = has_unknown_roles s
+      | isTyVarTy ty
+      = True
+      | otherwise
+      = False
+
+{-
+-- | Make a listing of role signatures for all the parameterised tycons
+-- used in the provided types
+
+
+-- SLPJ Jun 15: I could not convince myself that these hints were really
+-- useful.  Maybe they are, but I think we need more work to make them
+-- actually helpful.
+mkRoleSigs :: Type -> Type -> SDoc
+mkRoleSigs ty1 ty2
+  = ppUnless (null role_sigs) $
+    hang (text "Relevant role signatures:")
+       2 (vcat role_sigs)
+  where
+    tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2
+    role_sigs = mapMaybe ppr_role_sig tcs
+
+    ppr_role_sig tc
+      | null roles  -- if there are no parameters, don't bother printing
+      = Nothing
+      | isBuiltInSyntax (tyConName tc)  -- don't print roles for (->), etc.
+      = Nothing
+      | otherwise
+      = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles
+      where
+        roles = tyConRoles tc
+-}
+
+mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report
+             -> Ct
+             -> Maybe SwapFlag   -- Nothing <=> not sure
+             -> TcType -> TcType -> TcM ErrMsg
+mkEqErr_help dflags ctxt report ct oriented ty1 ty2
+  | Just (tv1, co1) <- tcGetCastedTyVar_maybe ty1
+  = mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2
+  | Just (tv2, co2) <- tcGetCastedTyVar_maybe ty2
+  = mkTyVarEqErr dflags ctxt report ct swapped  tv2 co2 ty1
+  | otherwise
+  = reportEqErr ctxt report ct oriented ty1 ty2
+  where
+    swapped = fmap flipSwap oriented
+
+reportEqErr :: ReportErrCtxt -> Report
+            -> Ct
+            -> Maybe SwapFlag   -- Nothing <=> not sure
+            -> TcType -> TcType -> TcM ErrMsg
+reportEqErr ctxt report ct oriented ty1 ty2
+  = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo])
+  where misMatch = important $ misMatchOrCND ctxt ct oriented ty1 ty2
+        eqInfo = important $ mkEqInfoMsg ct ty1 ty2
+
+mkTyVarEqErr, mkTyVarEqErr'
+  :: DynFlags -> ReportErrCtxt -> Report -> Ct
+             -> Maybe SwapFlag -> TcTyVar -> TcCoercionN -> TcType -> TcM ErrMsg
+-- tv1 and ty2 are already tidied
+mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2
+  = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr co1 $$ ppr ty2)
+       ; mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2 }
+
+mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2
+  | not insoluble_occurs_check   -- See Note [Occurs check wins]
+  , isUserSkolem ctxt tv1   -- ty2 won't be a meta-tyvar, or else the thing would
+                            -- be oriented the other way round;
+                            -- see TcCanonical.canEqTyVarTyVar
+    || isTyVarTyVar tv1 && not (isTyVarTy ty2)
+    || ctEqRel ct == ReprEq
+     -- the cases below don't really apply to ReprEq (except occurs check)
+  = mkErrorMsgFromCt ctxt ct $ mconcat
+        [ important $ misMatchOrCND ctxt ct oriented ty1 ty2
+        , important $ extraTyVarEqInfo ctxt tv1 ty2
+        , report
+        ]
+
+  | OC_Occurs <- occ_check_expand
+    -- We report an "occurs check" even for  a ~ F t a, where F is a type
+    -- function; it's not insoluble (because in principle F could reduce)
+    -- but we have certainly been unable to solve it
+    -- See Note [Occurs check error] in TcCanonical
+  = do { let main_msg = addArising (ctOrigin ct) $
+                        hang (text "Occurs check: cannot construct the infinite" <+> what <> colon)
+                              2 (sep [ppr ty1, char '~', ppr ty2])
+
+             extra2 = important $ mkEqInfoMsg ct ty1 ty2
+
+             interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $
+                                  filter isTyVar $
+                                  fvVarList $
+                                  tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2
+             extra3 = relevant_bindings $
+                      ppWhen (not (null interesting_tyvars)) $
+                      hang (text "Type variable kinds:") 2 $
+                      vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))
+                                interesting_tyvars)
+
+             tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
+       ; mkErrorMsgFromCt ctxt ct $
+         mconcat [important main_msg, extra2, extra3, report] }
+
+  | OC_Bad <- occ_check_expand
+  = do { let msg = vcat [ text "Cannot instantiate unification variable"
+                          <+> quotes (ppr tv1)
+                        , hang (text "with a" <+> what <+> text "involving foralls:") 2 (ppr ty2)
+                        , nest 2 (text "GHC doesn't yet support impredicative polymorphism") ]
+       -- Unlike the other reports, this discards the old 'report_important'
+       -- instead of augmenting it.  This is because the details are not likely
+       -- to be helpful since this is just an unimplemented feature.
+       ; mkErrorMsgFromCt ctxt ct $ report { report_important = [msg] } }
+
+   -- check for heterogeneous equality next; see Note [Equalities with incompatible kinds]
+   -- in TcCanonical
+  | not (k1 `tcEqType` k2)
+  = do { let main_msg = addArising (ctOrigin ct) $
+                        vcat [ hang (text "Kind mismatch: cannot unify" <+>
+                                     parens (ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)) <+>
+                                     text "with:")
+                                  2 (sep [ppr ty2, dcolon, ppr k2])
+                             , text "Their kinds differ." ]
+             cast_msg
+               | isTcReflexiveCo co1 = empty
+               | otherwise           = text "NB:" <+> ppr tv1 <+>
+                                       text "was casted to have kind" <+>
+                                       quotes (ppr k1)
+
+       ; mkErrorMsgFromCt ctxt ct (mconcat [important main_msg, important cast_msg, report]) }
+
+  -- If the immediately-enclosing implication has 'tv' a skolem, and
+  -- we know by now its an InferSkol kind of skolem, then presumably
+  -- it started life as a TyVarTv, else it'd have been unified, given
+  -- that there's no occurs-check or forall problem
+  | (implic:_) <- cec_encl ctxt
+  , Implic { ic_skols = skols } <- implic
+  , tv1 `elem` skols
+  = mkErrorMsgFromCt ctxt ct $ mconcat
+        [ important $ misMatchMsg ct oriented ty1 ty2
+        , important $ extraTyVarEqInfo ctxt tv1 ty2
+        , report
+        ]
+
+  -- Check for skolem escape
+  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
+  , Implic { ic_skols = skols, ic_info = skol_info } <- implic
+  , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols
+  , not (null esc_skols)
+  = do { let msg = important $ misMatchMsg ct oriented ty1 ty2
+             esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols
+                             <+> pprQuotedList esc_skols
+                           , text "would escape" <+>
+                             if isSingleton esc_skols then text "its scope"
+                                                      else text "their scope" ]
+             tv_extra = important $
+                        vcat [ nest 2 $ esc_doc
+                             , sep [ (if isSingleton esc_skols
+                                      then text "This (rigid, skolem)" <+>
+                                           what <+> text "variable is"
+                                      else text "These (rigid, skolem)" <+>
+                                           what <+> text "variables are")
+                               <+> text "bound by"
+                             , nest 2 $ ppr skol_info
+                             , nest 2 $ text "at" <+>
+                               ppr (tcl_loc (implicLclEnv implic)) ] ]
+       ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) }
+
+  -- Nastiest case: attempt to unify an untouchable variable
+  -- So tv is a meta tyvar (or started that way before we
+  -- generalised it).  So presumably it is an *untouchable*
+  -- meta tyvar or a TyVarTv, else it'd have been unified
+  -- See Note [Error messages for untouchables]
+  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
+  , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic
+  = ASSERT2( not (isTouchableMetaTyVar lvl tv1)
+           , ppr tv1 $$ ppr lvl )  -- See Note [Error messages for untouchables]
+    do { let msg = important $ misMatchMsg ct oriented ty1 ty2
+             tclvl_extra = important $
+                  nest 2 $
+                  sep [ quotes (ppr tv1) <+> text "is untouchable"
+                      , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given
+                      , nest 2 $ text "bound by" <+> ppr skol_info
+                      , nest 2 $ text "at" <+>
+                        ppr (tcl_loc (implicLclEnv implic)) ]
+             tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2
+             add_sig  = important $ suggestAddSig ctxt ty1 ty2
+       ; mkErrorMsgFromCt ctxt ct $ mconcat
+            [msg, tclvl_extra, tv_extra, add_sig, report] }
+
+  | otherwise
+  = reportEqErr ctxt report ct oriented (mkTyVarTy tv1) ty2
+        -- This *can* happen (Trac #6123, and test T2627b)
+        -- Consider an ambiguous top-level constraint (a ~ F a)
+        -- Not an occurs check, because F is a type function.
+  where
+    Pair _ k1 = tcCoercionKind co1
+    k2        = tcTypeKind ty2
+
+    ty1 = mkTyVarTy tv1
+    occ_check_expand       = occCheckForErrors dflags tv1 ty2
+    insoluble_occurs_check = isInsolubleOccursCheck (ctEqRel ct) tv1 ty2
+
+    what = case ctLocTypeOrKind_maybe (ctLoc ct) of
+      Just KindLevel -> text "kind"
+      _              -> text "type"
+
+mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc
+-- Report (a) ambiguity if either side is a type function application
+--            e.g. F a0 ~ Int
+--        (b) warning about injectivity if both sides are the same
+--            type function application   F a ~ F b
+--            See Note [Non-injective type functions]
+mkEqInfoMsg ct ty1 ty2
+  = tyfun_msg $$ ambig_msg
+  where
+    mb_fun1 = isTyFun_maybe ty1
+    mb_fun2 = isTyFun_maybe ty2
+
+    ambig_msg | isJust mb_fun1 || isJust mb_fun2
+              = snd (mkAmbigMsg False ct)
+              | otherwise = empty
+
+    tyfun_msg | Just tc1 <- mb_fun1
+              , Just tc2 <- mb_fun2
+              , tc1 == tc2
+              , not (isInjectiveTyCon tc1 Nominal)
+              = text "NB:" <+> quotes (ppr tc1)
+                <+> text "is a non-injective type family"
+              | otherwise = empty
+
+isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool
+-- See Note [Reporting occurs-check errors]
+isUserSkolem ctxt tv
+  = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt)
+  where
+    is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info })
+      = tv `elem` sks && is_user_skol_info skol_info
+
+    is_user_skol_info (InferSkol {}) = False
+    is_user_skol_info _ = True
+
+misMatchOrCND :: ReportErrCtxt -> Ct
+              -> Maybe SwapFlag -> TcType -> TcType -> SDoc
+-- If oriented then ty1 is actual, ty2 is expected
+misMatchOrCND ctxt ct oriented ty1 ty2
+  | null givens ||
+    (isRigidTy ty1 && isRigidTy ty2) ||
+    isGivenCt ct
+       -- If the equality is unconditionally insoluble
+       -- or there is no context, don't report the context
+  = misMatchMsg ct oriented ty1 ty2
+  | otherwise
+  = couldNotDeduce givens ([eq_pred], orig)
+  where
+    ev      = ctEvidence ct
+    eq_pred = ctEvPred ev
+    orig    = ctEvOrigin ev
+    givens  = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)]
+              -- Keep only UserGivens that have some equalities.
+              -- See Note [Suppress redundant givens during error reporting]
+
+couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc
+couldNotDeduce givens (wanteds, orig)
+  = vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds)
+         , vcat (pp_givens givens)]
+
+pp_givens :: [UserGiven] -> [SDoc]
+pp_givens givens
+   = case givens of
+         []     -> []
+         (g:gs) ->      ppr_given (text "from the context:") g
+                 : map (ppr_given (text "or from:")) gs
+    where
+       ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info })
+           = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs))
+             -- See Note [Suppress redundant givens during error reporting]
+             -- for why we use mkMinimalBySCs above.
+                2 (sep [ text "bound by" <+> ppr skol_info
+                       , text "at" <+> ppr (tcl_loc (implicLclEnv implic)) ])
+
+{-
+Note [Suppress redundant givens during error reporting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When GHC is unable to solve a constraint and prints out an error message, it
+will print out what given constraints are in scope to provide some context to
+the programmer. But we shouldn't print out /every/ given, since some of them
+are not terribly helpful to diagnose type errors. Consider this example:
+
+  foo :: Int :~: Int -> a :~: b -> a :~: c
+  foo Refl Refl = Refl
+
+When reporting that GHC can't solve (a ~ c), there are two givens in scope:
+(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e.,
+redundant), so it's not terribly useful to report it in an error message.
+To accomplish this, we discard any Implications that do not bind any
+equalities by filtering the `givens` selected in `misMatchOrCND` (based on
+the `ic_no_eqs` field of the Implication).
+
+But this is not enough to avoid all redundant givens! Consider this example,
+from #15361:
+
+  goo :: forall (a :: Type) (b :: Type) (c :: Type).
+         a :~~: b -> a :~~: c
+  goo HRefl = HRefl
+
+Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope.
+The (* ~ *) part arises due the kinds of (:~~:) being unified. More
+importantly, (* ~ *) is redundant, so we'd like not to report it. However,
+the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its
+ic_no_eqs field), so the test above will keep it wholesale.
+
+To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b)
+part. This works because mkMinimalBySCs eliminates reflexive equalities in
+addition to superclasses (see Note [Remove redundant provided dicts]
+in TcPatSyn).
+-}
+
+extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc
+-- Add on extra info about skolem constants
+-- NB: The types themselves are already tidied
+extraTyVarEqInfo ctxt tv1 ty2
+  = extraTyVarInfo ctxt tv1 $$ ty_extra ty2
+  where
+    ty_extra ty = case tcGetTyVar_maybe ty of
+                    Just tv -> extraTyVarInfo ctxt tv
+                    Nothing -> empty
+
+extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc
+extraTyVarInfo ctxt tv
+  = ASSERT2( isTyVar tv, ppr tv )
+    case tcTyVarDetails tv of
+          SkolemTv {}   -> pprSkols ctxt [tv]
+          RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem"
+          MetaTv {}     -> empty
+
+suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc
+-- See Note [Suggest adding a type signature]
+suggestAddSig ctxt ty1 ty2
+  | null inferred_bndrs
+  = empty
+  | [bndr] <- inferred_bndrs
+  = text "Possible fix: add a type signature for" <+> quotes (ppr bndr)
+  | otherwise
+  = text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs)
+  where
+    inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2)
+    get_inf ty | Just tv <- tcGetTyVar_maybe ty
+               , isSkolemTyVar tv
+               , (implic, _) : _ <- getSkolemInfo (cec_encl ctxt) [tv]
+               , InferSkol prs <- ic_info implic
+               = map fst prs
+               | otherwise
+               = []
+
+--------------------
+misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc
+-- Types are already tidy
+-- If oriented then ty1 is actual, ty2 is expected
+misMatchMsg ct oriented ty1 ty2
+  | Just NotSwapped <- oriented
+  = misMatchMsg ct (Just IsSwapped) ty2 ty1
+
+  -- These next two cases are when we're about to report, e.g., that
+  -- 'LiftedRep doesn't match 'VoidRep. Much better just to say
+  -- lifted vs. unlifted
+  | isLiftedRuntimeRep ty1
+  = lifted_vs_unlifted
+
+  | isLiftedRuntimeRep ty2
+  = lifted_vs_unlifted
+
+  | otherwise  -- So now we have Nothing or (Just IsSwapped)
+               -- For some reason we treat Nothing like IsSwapped
+  = addArising orig $
+    pprWithExplicitKindsWhenMismatch ty1 ty2 (ctOrigin ct) $
+    sep [ text herald1 <+> quotes (ppr ty1)
+        , nest padding $
+          text herald2 <+> quotes (ppr ty2)
+        , sameOccExtra ty2 ty1 ]
+  where
+    herald1 = conc [ "Couldn't match"
+                   , if is_repr     then "representation of" else ""
+                   , if is_oriented then "expected"          else ""
+                   , what ]
+    herald2 = conc [ "with"
+                   , if is_repr     then "that of"           else ""
+                   , if is_oriented then ("actual " ++ what) else "" ]
+    padding = length herald1 - length herald2
+
+    is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False }
+    is_oriented = isJust oriented
+
+    orig = ctOrigin ct
+    what = case ctLocTypeOrKind_maybe (ctLoc ct) of
+      Just KindLevel -> "kind"
+      _              -> "type"
+
+    conc :: [String] -> String
+    conc = foldr1 add_space
+
+    add_space :: String -> String -> String
+    add_space s1 s2 | null s1   = s2
+                    | null s2   = s1
+                    | otherwise = s1 ++ (' ' : s2)
+
+    lifted_vs_unlifted
+      = addArising orig $
+        text "Couldn't match a lifted type with an unlifted type"
+
+-- | Prints explicit kinds (with @-fprint-explicit-kinds@) in an 'SDoc' when a
+-- type mismatch occurs to due invisible kind arguments.
+--
+-- This function first checks to see if the 'CtOrigin' argument is a
+-- 'TypeEqOrigin', and if so, uses the expected/actual types from that to
+-- check for a kind mismatch (as these types typically have more surrounding
+-- types and are likelier to be able to glean information about whether a
+-- mismatch occurred in an invisible argument position or not). If the
+-- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types
+-- themselves.
+pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin
+                                 -> SDoc -> SDoc
+pprWithExplicitKindsWhenMismatch ty1 ty2 ct =
+  pprWithExplicitKindsWhen mismatch
+  where
+    (act_ty, exp_ty) = case ct of
+      TypeEqOrigin { uo_actual = act
+                   , uo_expected = exp } -> (act, exp)
+      _                                  -> (ty1, ty2)
+    mismatch | Just vis <- tcEqTypeVis act_ty exp_ty
+             = not vis
+             | otherwise
+             = False
+
+mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool
+                    -> (Bool, Maybe SwapFlag, SDoc)
+-- NotSwapped means (actual, expected), IsSwapped is the reverse
+-- First return val is whether or not to print a herald above this msg
+mkExpectedActualMsg ty1 ty2 ct@(TypeEqOrigin { uo_actual = act
+                                             , uo_expected = exp
+                                             , uo_thing = maybe_thing })
+                    m_level printExpanded
+  | KindLevel <- level, occurs_check_error       = (True, Nothing, empty)
+  | isUnliftedTypeKind act, isLiftedTypeKind exp = (False, Nothing, msg2)
+  | isLiftedTypeKind act, isUnliftedTypeKind exp = (False, Nothing, msg3)
+  | tcIsLiftedTypeKind exp                       = (False, Nothing, msg4)
+  | Just msg <- num_args_msg                     = (False, Nothing, msg $$ msg1)
+  | KindLevel <- level, Just th <- maybe_thing   = (False, Nothing, msg5 th)
+  | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (True, Just NotSwapped, empty)
+  | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (True, Just IsSwapped, empty)
+  | otherwise                                    = (True, Nothing, msg1)
+  where
+    level = m_level `orElse` TypeLevel
+
+    occurs_check_error
+      | Just act_tv <- tcGetTyVar_maybe act
+      , act_tv `elemVarSet` tyCoVarsOfType exp
+      = True
+      | Just exp_tv <- tcGetTyVar_maybe exp
+      , exp_tv `elemVarSet` tyCoVarsOfType act
+      = True
+      | otherwise
+      = False
+
+    sort = case level of
+      TypeLevel -> text "type"
+      KindLevel -> text "kind"
+
+    msg1 = case level of
+      KindLevel
+        | Just th <- maybe_thing
+        -> msg5 th
+
+      _ | not (act `pickyEqType` exp)
+        -> pprWithExplicitKindsWhenMismatch ty1 ty2 ct $
+           vcat [ text "Expected" <+> sort <> colon <+> ppr exp
+                , text "  Actual" <+> sort <> colon <+> ppr act
+                , if printExpanded then expandedTys else empty ]
+
+        | otherwise
+        -> empty
+
+    thing_msg = case maybe_thing of
+                  Just thing -> \_ -> quotes thing <+> text "is"
+                  Nothing    -> \vowel -> text "got a" <>
+                                          if vowel then char 'n' else empty
+    msg2 = sep [ text "Expecting a lifted type, but"
+               , thing_msg True, text "unlifted" ]
+    msg3 = sep [ text "Expecting an unlifted type, but"
+               , thing_msg False, text "lifted" ]
+    msg4 = maybe_num_args_msg $$
+           sep [ text "Expected a type, but"
+               , maybe (text "found something with kind")
+                       (\thing -> quotes thing <+> text "has kind")
+                       maybe_thing
+               , quotes (pprWithTYPE act) ]
+
+    msg5 th = pprWithExplicitKindsWhenMismatch ty1 ty2 ct $
+              hang (text "Expected" <+> kind_desc <> comma)
+                 2 (text "but" <+> quotes th <+> text "has kind" <+>
+                    quotes (ppr act))
+      where
+        kind_desc | tcIsConstraintKind exp = text "a constraint"
+
+                    -- TYPE t0
+                  | Just arg <- kindRep_maybe exp
+                  , tcIsTyVarTy arg = sdocWithDynFlags $ \dflags ->
+                                      if gopt Opt_PrintExplicitRuntimeReps dflags
+                                      then text "kind" <+> quotes (ppr exp)
+                                      else text "a type"
+
+                  | otherwise       = text "kind" <+> quotes (ppr exp)
+
+    num_args_msg = case level of
+      KindLevel
+        | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act)
+           -- if one is a meta-tyvar, then it's possible that the user
+           -- has asked for something impredicative, and we couldn't unify.
+           -- Don't bother with counting arguments.
+        -> let n_act = count_args act
+               n_exp = count_args exp in
+           case n_act - n_exp of
+             n | n > 0   -- we don't know how many args there are, so don't
+                         -- recommend removing args that aren't
+               , Just thing <- maybe_thing
+               -> Just $ text "Expecting" <+> speakN (abs n) <+>
+                         more <+> quotes thing
+               where
+                 more
+                  | n == 1    = text "more argument to"
+                  | otherwise = text "more arguments to"  -- n > 1
+             _ -> Nothing
+
+      _ -> Nothing
+
+    maybe_num_args_msg = case num_args_msg of
+      Nothing -> empty
+      Just m  -> m
+
+    count_args ty = count isVisibleBinder $ fst $ splitPiTys ty
+
+    expandedTys =
+      ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat
+        [ text "Type synonyms expanded:"
+        , text "Expected type:" <+> ppr expTy1
+        , text "  Actual type:" <+> ppr expTy2
+        ]
+
+    (expTy1, expTy2) = expandSynonymsToMatch exp act
+
+mkExpectedActualMsg _ _ _ _ _ = panic "mkExpectedAcutalMsg"
+
+{- Note [Insoluble occurs check wins]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider [G] a ~ [a],  [W] a ~ [a] (Trac #13674).  The Given is insoluble
+so we don't use it for rewriting.  The Wanted is also insoluble, and
+we don't solve it from the Given.  It's very confusing to say
+    Cannot solve a ~ [a] from given constraints a ~ [a]
+
+And indeed even thinking about the Givens is silly; [W] a ~ [a] is
+just as insoluble as Int ~ Bool.
+
+Conclusion: if there's an insoluble occurs check (isInsolubleOccursCheck)
+then report it first.
+
+(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't
+want to be as draconian with them.)
+
+Note [Expanding type synonyms to make types similar]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In type error messages, if -fprint-expanded-types is used, we want to expand
+type synonyms to make expected and found types as similar as possible, but we
+shouldn't expand types too much to make type messages even more verbose and
+harder to understand. The whole point here is to make the difference in expected
+and found types clearer.
+
+`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms
+only as much as necessary. Given two types t1 and t2:
+
+  * If they're already same, it just returns the types.
+
+  * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are
+    type constructors), it expands C1 and C2 if they're different type synonyms.
+    Then it recursively does the same thing on expanded types. If C1 and C2 are
+    same, then it applies the same procedure to arguments of C1 and arguments of
+    C2 to make them as similar as possible.
+
+    Most important thing here is to keep number of synonym expansions at
+    minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3,
+    Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and
+    `T (T3, T3, Bool)`.
+
+  * Otherwise types don't have same shapes and so the difference is clearly
+    visible. It doesn't do any expansions and show these types.
+
+Note that we only expand top-layer type synonyms. Only when top-layer
+constructors are the same we start expanding inner type synonyms.
+
+Suppose top-layer type synonyms of t1 and t2 can expand N and M times,
+respectively. If their type-synonym-expanded forms will meet at some point (i.e.
+will have same shapes according to `sameShapes` function), it's possible to find
+where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M))
+comparisons. We first collect all the top-layer expansions of t1 and t2 in two
+lists, then drop the prefix of the longer list so that they have same lengths.
+Then we search through both lists in parallel, and return the first pair of
+types that have same shapes. Inner types of these two types with same shapes
+are then expanded using the same algorithm.
+
+In case they don't meet, we return the last pair of types in the lists, which
+has top-layer type synonyms completely expanded. (in this case the inner types
+are not expanded at all, as the current form already shows the type error)
+-}
+
+-- | Expand type synonyms in given types only enough to make them as similar as
+-- possible. Returned types are the same in terms of used type synonyms.
+--
+-- To expand all synonyms, see 'Type.expandTypeSynonyms'.
+--
+-- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for
+-- some examples of how this should work.
+expandSynonymsToMatch :: Type -> Type -> (Type, Type)
+expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)
+  where
+    (ty1_ret, ty2_ret) = go ty1 ty2
+
+    -- | Returns (type synonym expanded version of first type,
+    --            type synonym expanded version of second type)
+    go :: Type -> Type -> (Type, Type)
+    go t1 t2
+      | t1 `pickyEqType` t2 =
+        -- Types are same, nothing to do
+        (t1, t2)
+
+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+      | tc1 == tc2 =
+        -- Type constructors are same. They may be synonyms, but we don't
+        -- expand further.
+        let (tys1', tys2') =
+              unzip (zipWith (\ty1 ty2 -> go ty1 ty2) tys1 tys2)
+         in (TyConApp tc1 tys1', TyConApp tc2 tys2')
+
+    go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =
+      let (t1_1', t2_1') = go t1_1 t2_1
+          (t1_2', t2_2') = go t1_2 t2_2
+       in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')
+
+    go (FunTy t1_1 t1_2) (FunTy t2_1 t2_2) =
+      let (t1_1', t2_1') = go t1_1 t2_1
+          (t1_2', t2_2') = go t1_2 t2_2
+       in (mkFunTy t1_1' t1_2', mkFunTy t2_1' t2_2')
+
+    go (ForAllTy b1 t1) (ForAllTy b2 t2) =
+      -- NOTE: We may have a bug here, but we just can't reproduce it easily.
+      -- See D1016 comments for details and our attempts at producing a test
+      -- case. Short version: We probably need RnEnv2 to really get this right.
+      let (t1', t2') = go t1 t2
+       in (ForAllTy b1 t1', ForAllTy b2 t2')
+
+    go (CastTy ty1 _) ty2 = go ty1 ty2
+    go ty1 (CastTy ty2 _) = go ty1 ty2
+
+    go t1 t2 =
+      -- See Note [Expanding type synonyms to make types similar] for how this
+      -- works
+      let
+        t1_exp_tys = t1 : tyExpansions t1
+        t2_exp_tys = t2 : tyExpansions t2
+        t1_exps    = length t1_exp_tys
+        t2_exps    = length t2_exp_tys
+        dif        = abs (t1_exps - t2_exps)
+      in
+        followExpansions $
+          zipEqual "expandSynonymsToMatch.go"
+            (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys)
+            (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys)
+
+    -- | Expand the top layer type synonyms repeatedly, collect expansions in a
+    -- list. The list does not include the original type.
+    --
+    -- Example, if you have:
+    --
+    --   type T10 = T9
+    --   type T9  = T8
+    --   ...
+    --   type T0  = Int
+    --
+    -- `tyExpansions T10` returns [T9, T8, T7, ... Int]
+    --
+    -- This only expands the top layer, so if you have:
+    --
+    --   type M a = Maybe a
+    --
+    -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded)
+    tyExpansions :: Type -> [Type]
+    tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t)
+
+    -- | Drop the type pairs until types in a pair look alike (i.e. the outer
+    -- constructors are the same).
+    followExpansions :: [(Type, Type)] -> (Type, Type)
+    followExpansions [] = pprPanic "followExpansions" empty
+    followExpansions [(t1, t2)]
+      | sameShapes t1 t2 = go t1 t2 -- expand subtrees
+      | otherwise        = (t1, t2) -- the difference is already visible
+    followExpansions ((t1, t2) : tss)
+      -- Traverse subtrees when the outer shapes are the same
+      | sameShapes t1 t2 = go t1 t2
+      -- Otherwise follow the expansions until they look alike
+      | otherwise = followExpansions tss
+
+    sameShapes :: Type -> Type -> Bool
+    sameShapes AppTy{}          AppTy{}          = True
+    sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2
+    sameShapes (FunTy {})       (FunTy {})       = True
+    sameShapes (ForAllTy {})    (ForAllTy {})    = True
+    sameShapes (CastTy ty1 _)   ty2              = sameShapes ty1 ty2
+    sameShapes ty1              (CastTy ty2 _)   = sameShapes ty1 ty2
+    sameShapes _                _                = False
+
+sameOccExtra :: TcType -> TcType -> SDoc
+-- See Note [Disambiguating (X ~ X) errors]
+sameOccExtra ty1 ty2
+  | Just (tc1, _) <- tcSplitTyConApp_maybe ty1
+  , Just (tc2, _) <- tcSplitTyConApp_maybe ty2
+  , let n1 = tyConName tc1
+        n2 = tyConName tc2
+        same_occ = nameOccName n1                   == nameOccName n2
+        same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2)
+  , n1 /= n2   -- Different Names
+  , same_occ   -- but same OccName
+  = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)
+  | otherwise
+  = empty
+  where
+    ppr_from same_pkg nm
+      | isGoodSrcSpan loc
+      = hang (quotes (ppr nm) <+> text "is defined at")
+           2 (ppr loc)
+      | otherwise  -- Imported things have an UnhelpfulSrcSpan
+      = hang (quotes (ppr nm))
+           2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod))
+                  , ppUnless (same_pkg || pkg == mainUnitId) $
+                    nest 4 $ text "in package" <+> quotes (ppr pkg) ])
+       where
+         pkg = moduleUnitId mod
+         mod = nameModule nm
+         loc = nameSrcSpan nm
+
+{-
+Note [Suggest adding a type signature]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The OutsideIn algorithm rejects GADT programs that don't have a principal
+type, and indeed some that do.  Example:
+   data T a where
+     MkT :: Int -> T Int
+
+   f (MkT n) = n
+
+Does this have type f :: T a -> a, or f :: T a -> Int?
+The error that shows up tends to be an attempt to unify an
+untouchable type variable.  So suggestAddSig sees if the offending
+type variable is bound by an *inferred* signature, and suggests
+adding a declared signature instead.
+
+This initially came up in Trac #8968, concerning pattern synonyms.
+
+Note [Disambiguating (X ~ X) errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Trac #8278
+
+Note [Reporting occurs-check errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied
+type signature, then the best thing is to report that we can't unify
+a with [a], because a is a skolem variable.  That avoids the confusing
+"occur-check" error message.
+
+But nowadays when inferring the type of a function with no type signature,
+even if there are errors inside, we still generalise its signature and
+carry on. For example
+   f x = x:x
+Here we will infer something like
+   f :: forall a. a -> [a]
+with a deferred error of (a ~ [a]).  So in the deferred unsolved constraint
+'a' is now a skolem, but not one bound by the programmer in the context!
+Here we really should report an occurs check.
+
+So isUserSkolem distinguishes the two.
+
+Note [Non-injective type functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's very confusing to get a message like
+     Couldn't match expected type `Depend s'
+            against inferred type `Depend s1'
+so mkTyFunInfoMsg adds:
+       NB: `Depend' is type function, and hence may not be injective
+
+Warn of loopy local equalities that were dropped.
+
+
+************************************************************************
+*                                                                      *
+                 Type-class errors
+*                                                                      *
+************************************************************************
+-}
+
+mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg
+mkDictErr ctxt cts
+  = ASSERT( not (null cts) )
+    do { inst_envs <- tcGetInstEnvs
+       ; let (ct1:_) = cts  -- ct1 just for its location
+             min_cts = elim_superclasses cts
+             lookups = map (lookup_cls_inst inst_envs) min_cts
+             (no_inst_cts, overlap_cts) = partition is_no_inst lookups
+
+       -- Report definite no-instance errors,
+       -- or (iff there are none) overlap errors
+       -- But we report only one of them (hence 'head') because they all
+       -- have the same source-location origin, to try avoid a cascade
+       -- of error from one location
+       ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))
+       ; mkErrorMsgFromCt ctxt ct1 (important err) }
+  where
+    no_givens = null (getUserGivens ctxt)
+
+    is_no_inst (ct, (matches, unifiers, _))
+      =  no_givens
+      && null matches
+      && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct))
+
+    lookup_cls_inst inst_envs ct
+                -- Note [Flattening in error message generation]
+      = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys))
+      where
+        (clas, tys) = getClassPredTys (ctPred ct)
+
+
+    -- When simplifying [W] Ord (Set a), we need
+    --    [W] Eq a, [W] Ord a
+    -- but we really only want to report the latter
+    elim_superclasses cts = mkMinimalBySCs ctPred cts
+
+mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)
+            -> TcM (ReportErrCtxt, SDoc)
+-- Report an overlap error if this class constraint results
+-- from an overlap (returning Left clas), otherwise return (Right pred)
+mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped))
+  | null matches  -- No matches but perhaps several unifiers
+  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct
+       ; candidate_insts <- get_candidate_instances
+       ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) }
+
+  | null unsafe_overlapped   -- Some matches => overlap errors
+  = return (ctxt, overlap_msg)
+
+  | otherwise
+  = return (ctxt, safe_haskell_msg)
+  where
+    orig          = ctOrigin ct
+    pred          = ctPred ct
+    (clas, tys)   = getClassPredTys pred
+    ispecs        = [ispec | (ispec, _) <- matches]
+    unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]
+    useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics)
+         -- useful_givens are the enclosing implications with non-empty givens,
+         -- modulo the horrid discardProvCtxtGivens
+
+    get_candidate_instances :: TcM [ClsInst]
+    -- See Note [Report candidate instances]
+    get_candidate_instances
+      | [ty] <- tys   -- Only try for single-parameter classes
+      = do { instEnvs <- tcGetInstEnvs
+           ; return (filter (is_candidate_inst ty)
+                            (classInstances instEnvs clas)) }
+      | otherwise = return []
+
+    is_candidate_inst ty inst -- See Note [Report candidate instances]
+      | [other_ty] <- is_tys inst
+      , Just (tc1, _) <- tcSplitTyConApp_maybe ty
+      , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty
+      = let n1 = tyConName tc1
+            n2 = tyConName tc2
+            different_names = n1 /= n2
+            same_occ_names = nameOccName n1 == nameOccName n2
+        in different_names && same_occ_names
+      | otherwise = False
+
+    cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc
+    cannot_resolve_msg ct candidate_insts binds_msg
+      = vcat [ no_inst_msg
+             , nest 2 extra_note
+             , vcat (pp_givens useful_givens)
+             , mb_patsyn_prov `orElse` empty
+             , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens))
+               (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ])
+
+             , ppWhen (isNothing mb_patsyn_prov) $
+                   -- Don't suggest fixes for the provided context of a pattern
+                   -- synonym; the right fix is to bind more in the pattern
+               show_fixes (ctxtFixes has_ambig_tvs pred implics
+                           ++ drv_fixes)
+             , ppWhen (not (null candidate_insts))
+               (hang (text "There are instances for similar types:")
+                   2 (vcat (map ppr candidate_insts))) ]
+                   -- See Note [Report candidate instances]
+      where
+        orig = ctOrigin ct
+        -- See Note [Highlighting ambiguous type variables]
+        lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs)
+                        && not (null unifiers) && null useful_givens
+
+        (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct
+        ambig_tvs = uncurry (++) (getAmbigTkvs ct)
+
+        no_inst_msg
+          | lead_with_ambig
+          = ambig_msg <+> pprArising orig
+              $$ text "prevents the constraint" <+>  quotes (pprParendType pred)
+              <+> text "from being solved."
+
+          | null useful_givens
+          = addArising orig $ text "No instance for"
+            <+> pprParendType pred
+
+          | otherwise
+          = addArising orig $ text "Could not deduce"
+            <+> pprParendType pred
+
+        potential_msg
+          = ppWhen (not (null unifiers) && want_potential orig) $
+            sdocWithDynFlags $ \dflags ->
+            getPprStyle $ \sty ->
+            pprPotentials dflags sty potential_hdr unifiers
+
+        potential_hdr
+          = vcat [ ppWhen lead_with_ambig $
+                     text "Probable fix: use a type annotation to specify what"
+                     <+> pprQuotedList ambig_tvs <+> text "should be."
+                 , text "These potential instance" <> plural unifiers
+                   <+> text "exist:"]
+
+        mb_patsyn_prov :: Maybe SDoc
+        mb_patsyn_prov
+          | not lead_with_ambig
+          , ProvCtxtOrigin PSB{ psb_def = (dL->L _ pat) } <- orig
+          = Just (vcat [ text "In other words, a successful match on the pattern"
+                       , nest 2 $ ppr pat
+                       , text "does not provide the constraint" <+> pprParendType pred ])
+          | otherwise = Nothing
+
+    -- Report "potential instances" only when the constraint arises
+    -- directly from the user's use of an overloaded function
+    want_potential (TypeEqOrigin {}) = False
+    want_potential _                 = True
+
+    extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys)
+               = text "(maybe you haven't applied a function to enough arguments?)"
+               | className clas == typeableClassName  -- Avoid mysterious "No instance for (Typeable T)
+               , [_,ty] <- tys                        -- Look for (Typeable (k->*) (T k))
+               , Just (tc,_) <- tcSplitTyConApp_maybe ty
+               , not (isTypeFamilyTyCon tc)
+               = hang (text "GHC can't yet do polykinded")
+                    2 (text "Typeable" <+>
+                       parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty)))
+               | otherwise
+               = empty
+
+    drv_fixes = case orig of
+                   DerivClauseOrigin                  -> [drv_fix False]
+                   StandAloneDerivOrigin              -> [drv_fix True]
+                   DerivOriginDC _ _       standalone -> [drv_fix standalone]
+                   DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone]
+                   _                -> []
+
+    drv_fix standalone_wildcard
+      | standalone_wildcard
+      = text "fill in the wildcard constraint yourself"
+      | otherwise
+      = hang (text "use a standalone 'deriving instance' declaration,")
+           2 (text "so you can specify the instance context yourself")
+
+    -- Normal overlap error
+    overlap_msg
+      = ASSERT( not (null matches) )
+        vcat [  addArising orig (text "Overlapping instances for"
+                                <+> pprType (mkClassPred clas tys))
+
+             ,  ppUnless (null matching_givens) $
+                  sep [text "Matching givens (or their superclasses):"
+                      , nest 2 (vcat matching_givens)]
+
+             ,  sdocWithDynFlags $ \dflags ->
+                getPprStyle $ \sty ->
+                pprPotentials dflags sty (text "Matching instances:") $
+                ispecs ++ unifiers
+
+             ,  ppWhen (null matching_givens && isSingleton matches && null unifiers) $
+                -- Intuitively, some given matched the wanted in their
+                -- flattened or rewritten (from given equalities) form
+                -- but the matcher can't figure that out because the
+                -- constraints are non-flat and non-rewritten so we
+                -- simply report back the whole given
+                -- context. Accelerate Smart.hs showed this problem.
+                  sep [ text "There exists a (perhaps superclass) match:"
+                      , nest 2 (vcat (pp_givens useful_givens))]
+
+             ,  ppWhen (isSingleton matches) $
+                parens (vcat [ text "The choice depends on the instantiation of" <+>
+                                  quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys))
+                             , ppWhen (null (matching_givens)) $
+                               vcat [ text "To pick the first instance above, use IncoherentInstances"
+                                    , text "when compiling the other instance declarations"]
+                        ])]
+
+    matching_givens = mapMaybe matchable useful_givens
+
+    matchable implic@(Implic { ic_given = evvars, ic_info = skol_info })
+      = case ev_vars_matching of
+             [] -> Nothing
+             _  -> Just $ hang (pprTheta ev_vars_matching)
+                            2 (sep [ text "bound by" <+> ppr skol_info
+                                   , text "at" <+>
+                                     ppr (tcl_loc (implicLclEnv implic)) ])
+        where ev_vars_matching = filter ev_var_matches (map evVarPred evvars)
+              ev_var_matches ty = case getClassPredTys_maybe ty of
+                 Just (clas', tys')
+                   | clas' == clas
+                   , Just _ <- tcMatchTys tys tys'
+                   -> True
+                   | otherwise
+                   -> any ev_var_matches (immSuperClasses clas' tys')
+                 Nothing -> False
+
+    -- Overlap error because of Safe Haskell (first
+    -- match should be the most specific match)
+    safe_haskell_msg
+     = ASSERT( matches `lengthIs` 1 && not (null unsafe_ispecs) )
+       vcat [ addArising orig (text "Unsafe overlapping instances for"
+                       <+> pprType (mkClassPred clas tys))
+            , sep [text "The matching instance is:",
+                   nest 2 (pprInstance $ head ispecs)]
+            , vcat [ text "It is compiled in a Safe module and as such can only"
+                   , text "overlap instances from the same module, however it"
+                   , text "overlaps the following instances from different" <+>
+                     text "modules:"
+                   , nest 2 (vcat [pprInstances $ unsafe_ispecs])
+                   ]
+            ]
+
+
+ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc]
+ctxtFixes has_ambig_tvs pred implics
+  | not has_ambig_tvs
+  , isTyVarClassPred pred
+  , (skol:skols) <- usefulContext implics pred
+  , let what | null skols
+             , SigSkol (PatSynCtxt {}) _ _ <- skol
+             = text "\"required\""
+             | otherwise
+             = empty
+  = [sep [ text "add" <+> pprParendType pred
+           <+> text "to the" <+> what <+> text "context of"
+         , nest 2 $ ppr_skol skol $$
+                    vcat [ text "or" <+> ppr_skol skol
+                         | skol <- skols ] ] ]
+  | otherwise = []
+  where
+    ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc)
+    ppr_skol (PatSkol (PatSynCon ps)   _) = text "the pattern synonym"  <+> quotes (ppr ps)
+    ppr_skol skol_info = ppr skol_info
+
+discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven]
+discardProvCtxtGivens orig givens  -- See Note [discardProvCtxtGivens]
+  | ProvCtxtOrigin (PSB {psb_id = (dL->L _ name)}) <- orig
+  = filterOut (discard name) givens
+  | otherwise
+  = givens
+  where
+    discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n'
+    discard _ _                                                  = False
+
+usefulContext :: [Implication] -> PredType -> [SkolemInfo]
+-- usefulContext picks out the implications whose context
+-- the programmer might plausibly augment to solve 'pred'
+usefulContext implics pred
+  = go implics
+  where
+    pred_tvs = tyCoVarsOfType pred
+    go [] = []
+    go (ic : ics)
+       | implausible ic = rest
+       | otherwise      = ic_info ic : rest
+       where
+          -- Stop when the context binds a variable free in the predicate
+          rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []
+               | otherwise                                 = go ics
+
+    implausible ic
+      | null (ic_skols ic)            = True
+      | implausible_info (ic_info ic) = True
+      | otherwise                     = False
+
+    implausible_info (SigSkol (InfSigCtxt {}) _ _) = True
+    implausible_info _                             = False
+    -- Do not suggest adding constraints to an *inferred* type signature
+
+{- Note [Report candidate instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we have an unsolved (Num Int), where `Int` is not the Prelude Int,
+but comes from some other module, then it may be helpful to point out
+that there are some similarly named instances elsewhere.  So we get
+something like
+    No instance for (Num Int) arising from the literal ‘3’
+    There are instances for similar types:
+      instance Num GHC.Types.Int -- Defined in ‘GHC.Num’
+Discussion in Trac #9611.
+
+Note [Highlighting ambiguous type variables]
+~-------------------------------------------
+When we encounter ambiguous type variables (i.e. type variables
+that remain metavariables after type inference), we need a few more
+conditions before we can reason that *ambiguity* prevents constraints
+from being solved:
+  - We can't have any givens, as encountering a typeclass error
+    with given constraints just means we couldn't deduce
+    a solution satisfying those constraints and as such couldn't
+    bind the type variable to a known type.
+  - If we don't have any unifiers, we don't even have potential
+    instances from which an ambiguity could arise.
+  - Lastly, I don't want to mess with error reporting for
+    unknown runtime types so we just fall back to the old message there.
+Once these conditions are satisfied, we can safely say that ambiguity prevents
+the constraint from being solved.
+
+Note [discardProvCtxtGivens]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In most situations we call all enclosing implications "useful". There is one
+exception, and that is when the constraint that causes the error is from the
+"provided" context of a pattern synonym declaration:
+
+  pattern Pat :: (Num a, Eq a) => Show a   => a -> Maybe a
+             --  required      => provided => type
+  pattern Pat x <- (Just x, 4)
+
+When checking the pattern RHS we must check that it does actually bind all
+the claimed "provided" constraints; in this case, does the pattern (Just x, 4)
+bind the (Show a) constraint.  Answer: no!
+
+But the implication we generate for this will look like
+   forall a. (Num a, Eq a) => [W] Show a
+because when checking the pattern we must make the required
+constraints available, since they are needed to match the pattern (in
+this case the literal '4' needs (Num a, Eq a)).
+
+BUT we don't want to suggest adding (Show a) to the "required" constraints
+of the pattern synonym, thus:
+  pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a
+It would then typecheck but it's silly.  We want the /pattern/ to bind
+the alleged "provided" constraints, Show a.
+
+So we suppress that Implication in discardProvCtxtGivens.  It's
+painfully ad-hoc but the truth is that adding it to the "required"
+constraints would work.  Suprressing it solves two problems.  First,
+we never tell the user that we could not deduce a "provided"
+constraint from the "required" context. Second, we never give a
+possible fix that suggests to add a "provided" constraint to the
+"required" context.
+
+For example, without this distinction the above code gives a bad error
+message (showing both problems):
+
+  error: Could not deduce (Show a) ... from the context: (Eq a)
+         ... Possible fix: add (Show a) to the context of
+         the signature for pattern synonym `Pat' ...
+
+-}
+
+show_fixes :: [SDoc] -> SDoc
+show_fixes []     = empty
+show_fixes (f:fs) = sep [ text "Possible fix:"
+                        , nest 2 (vcat (f : map (text "or" <+>) fs))]
+
+pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc
+-- See Note [Displaying potential instances]
+pprPotentials dflags sty herald insts
+  | null insts
+  = empty
+
+  | null show_these
+  = hang herald
+       2 (vcat [ not_in_scope_msg empty
+               , flag_hint ])
+
+  | otherwise
+  = hang herald
+       2 (vcat [ pprInstances show_these
+               , ppWhen (n_in_scope_hidden > 0) $
+                 text "...plus"
+                   <+> speakNOf n_in_scope_hidden (text "other")
+               , not_in_scope_msg (text "...plus")
+               , flag_hint ])
+  where
+    n_show = 3 :: Int
+    show_potentials = gopt Opt_PrintPotentialInstances dflags
+
+    (in_scope, not_in_scope) = partition inst_in_scope insts
+    sorted = sortBy fuzzyClsInstCmp in_scope
+    show_these | show_potentials = sorted
+               | otherwise       = take n_show sorted
+    n_in_scope_hidden = length sorted - length show_these
+
+       -- "in scope" means that all the type constructors
+       -- are lexically in scope; these instances are likely
+       -- to be more useful
+    inst_in_scope :: ClsInst -> Bool
+    inst_in_scope cls_inst = nameSetAll name_in_scope $
+                             orphNamesOfTypes (is_tys cls_inst)
+
+    name_in_scope name
+      | isBuiltInSyntax name
+      = True -- E.g. (->)
+      | Just mod <- nameModule_maybe name
+      = qual_in_scope (qualName sty mod (nameOccName name))
+      | otherwise
+      = True
+
+    qual_in_scope :: QualifyName -> Bool
+    qual_in_scope NameUnqual    = True
+    qual_in_scope (NameQual {}) = True
+    qual_in_scope _             = False
+
+    not_in_scope_msg herald
+      | null not_in_scope
+      = empty
+      | otherwise
+      = hang (herald <+> speakNOf (length not_in_scope) (text "instance")
+                     <+> text "involving out-of-scope types")
+           2 (ppWhen show_potentials (pprInstances not_in_scope))
+
+    flag_hint = ppUnless (show_potentials || equalLength show_these insts) $
+                text "(use -fprint-potential-instances to see them all)"
+
+{- Note [Displaying potential instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When showing a list of instances for
+  - overlapping instances (show ones that match)
+  - no such instance (show ones that could match)
+we want to give it a bit of structure.  Here's the plan
+
+* Say that an instance is "in scope" if all of the
+  type constructors it mentions are lexically in scope.
+  These are the ones most likely to be useful to the programmer.
+
+* Show at most n_show in-scope instances,
+  and summarise the rest ("plus 3 others")
+
+* Summarise the not-in-scope instances ("plus 4 not in scope")
+
+* Add the flag -fshow-potential-instances which replaces the
+  summary with the full list
+-}
+
+{-
+Note [Flattening in error message generation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (C (Maybe (F x))), where F is a type function, and we have
+instances
+                C (Maybe Int) and C (Maybe a)
+Since (F x) might turn into Int, this is an overlap situation, and
+indeed (because of flattening) the main solver will have refrained
+from solving.  But by the time we get to error message generation, we've
+un-flattened the constraint.  So we must *re*-flatten it before looking
+up in the instance environment, lest we only report one matching
+instance when in fact there are two.
+
+Re-flattening is pretty easy, because we don't need to keep track of
+evidence.  We don't re-use the code in TcCanonical because that's in
+the TcS monad, and we are in TcM here.
+
+Note [Kind arguments in error messages]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It can be terribly confusing to get an error message like (Trac #9171)
+
+    Couldn't match expected type ‘GetParam Base (GetParam Base Int)’
+                with actual type ‘GetParam Base (GetParam Base Int)’
+
+The reason may be that the kinds don't match up.  Typically you'll get
+more useful information, but not when it's as a result of ambiguity.
+
+To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag
+whenever any error message arises due to a kind mismatch. This means that
+the above error message would instead be displayed as:
+
+    Couldn't match expected type
+                  ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’
+                with actual type
+                  ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’
+
+Which makes it clearer that the culprit is the mismatch between `k2` and `k20`.
+-}
+
+mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence
+           -> Ct -> (Bool, SDoc)
+mkAmbigMsg prepend_msg ct
+  | null ambig_kvs && null ambig_tvs = (False, empty)
+  | otherwise                        = (True,  msg)
+  where
+    (ambig_kvs, ambig_tvs) = getAmbigTkvs ct
+
+    msg |  any isRuntimeUnkSkol ambig_kvs  -- See Note [Runtime skolems]
+        || any isRuntimeUnkSkol ambig_tvs
+        = vcat [ text "Cannot resolve unknown runtime type"
+                 <> plural ambig_tvs <+> pprQuotedList ambig_tvs
+               , text "Use :print or :force to determine these types"]
+
+        | not (null ambig_tvs)
+        = pp_ambig (text "type") ambig_tvs
+
+        | otherwise
+        = pp_ambig (text "kind") ambig_kvs
+
+    pp_ambig what tkvs
+      | prepend_msg -- "Ambiguous type variable 't0'"
+      = text "Ambiguous" <+> what <+> text "variable"
+        <> plural tkvs <+> pprQuotedList tkvs
+
+      | otherwise -- "The type variable 't0' is ambiguous"
+      = text "The" <+> what <+> text "variable" <> plural tkvs
+        <+> pprQuotedList tkvs <+> is_or_are tkvs <+> text "ambiguous"
+
+    is_or_are [_] = text "is"
+    is_or_are _   = text "are"
+
+pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc
+pprSkols ctxt tvs
+  = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs))
+  where
+    pp_one (Implic { ic_info = skol_info }, tvs)
+      | UnkSkol <- skol_info
+      = hang (pprQuotedList tvs)
+           2 (is_or_are tvs "an" "unknown")
+      | otherwise
+      = vcat [ hang (pprQuotedList tvs)
+                  2 (is_or_are tvs "a"  "rigid" <+> text "bound by")
+             , nest 2 (pprSkolInfo skol_info)
+             , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ]
+
+    is_or_are [_] article adjective = text "is" <+> text article <+> text adjective
+                                      <+> text "type variable"
+    is_or_are _   _       adjective = text "are" <+> text adjective
+                                      <+> text "type variables"
+
+getAmbigTkvs :: Ct -> ([Var],[Var])
+getAmbigTkvs ct
+  = partition (`elemVarSet` dep_tkv_set) ambig_tkvs
+  where
+    tkvs       = tyCoVarsOfCtList ct
+    ambig_tkvs = filter isAmbiguousTyVar tkvs
+    dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs)
+
+getSkolemInfo :: [Implication] -> [TcTyVar]
+              -> [(Implication, [TcTyVar])]
+-- Get the skolem info for some type variables
+-- from the implication constraints that bind them
+--
+-- In the returned (implic, tvs) pairs, the 'tvs' part is non-empty
+getSkolemInfo _ []
+  = []
+
+getSkolemInfo [] tvs
+  = pprPanic "No skolem info:" (ppr tvs)
+
+getSkolemInfo (implic:implics) tvs
+  | null tvs_here =                      getSkolemInfo implics tvs
+  | otherwise     = (implic, tvs_here) : getSkolemInfo implics tvs_other
+  where
+    (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs
+
+-----------------------
+-- relevantBindings looks at the value environment and finds values whose
+-- types mention any of the offending type variables.  It has to be
+-- careful to zonk the Id's type first, so it has to be in the monad.
+-- We must be careful to pass it a zonked type variable, too.
+--
+-- We always remove closed top-level bindings, though,
+-- since they are never relevant (cf Trac #8233)
+
+relevantBindings :: Bool  -- True <=> filter by tyvar; False <=> no filtering
+                          -- See Trac #8191
+                 -> ReportErrCtxt -> Ct
+                 -> TcM (ReportErrCtxt, SDoc, Ct)
+-- Also returns the zonked and tidied CtOrigin of the constraint
+relevantBindings want_filtering ctxt ct
+  = do { dflags <- getDynFlags
+       ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
+       ; let ct_tvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs
+
+             -- For *kind* errors, report the relevant bindings of the
+             -- enclosing *type* equality, because that's more useful for the programmer
+             extra_tvs = case tidy_orig of
+                             KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $
+                                                         t1 : maybeToList m_t2
+                             _                        -> emptyVarSet
+       ; traceTc "relevantBindings" $
+           vcat [ ppr ct
+                , pprCtOrigin (ctLocOrigin loc)
+                , ppr ct_tvs
+                , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id)
+                                   | TcIdBndr id _ <- tcl_bndrs lcl_env ]
+                , pprWithCommas id
+                    [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ]
+
+       ; (tidy_env', docs, discards)
+              <- go dflags env1 ct_tvs (maxRelevantBinds dflags)
+                    emptyVarSet [] False
+                    (removeBindingShadowing $ tcl_bndrs lcl_env)
+         -- tcl_bndrs has the innermost bindings first,
+         -- which are probably the most relevant ones
+
+       ; let doc = ppUnless (null docs) $
+                   hang (text "Relevant bindings include")
+                      2 (vcat docs $$ ppWhen discards discardMsg)
+
+             -- Put a zonked, tidied CtOrigin into the Ct
+             loc'  = setCtLocOrigin loc tidy_orig
+             ct'   = setCtLoc ct loc'
+             ctxt' = ctxt { cec_tidy = tidy_env' }
+
+       ; return (ctxt', doc, ct') }
+  where
+    ev      = ctEvidence ct
+    loc     = ctEvLoc ev
+    lcl_env = ctLocEnv loc
+
+    run_out :: Maybe Int -> Bool
+    run_out Nothing = False
+    run_out (Just n) = n <= 0
+
+    dec_max :: Maybe Int -> Maybe Int
+    dec_max = fmap (\n -> n - 1)
+
+
+    go :: DynFlags -> TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc]
+       -> Bool                          -- True <=> some filtered out due to lack of fuel
+       -> [TcBinder]
+       -> TcM (TidyEnv, [SDoc], Bool)   -- The bool says if we filtered any out
+                                        -- because of lack of fuel
+    go _ tidy_env _ _ _ docs discards []
+      = return (tidy_env, reverse docs, discards)
+    go dflags tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs)
+      = case tc_bndr of
+          TcTvBndr {} -> discard_it
+          TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl
+          TcIdBndr_ExpType name et top_lvl ->
+            do { mb_ty <- readExpType_maybe et
+                   -- et really should be filled in by now. But there's a chance
+                   -- it hasn't, if, say, we're reporting a kind error en route to
+                   -- checking a term. See test indexed-types/should_fail/T8129
+                   -- Or we are reporting errors from the ambiguity check on
+                   -- a local type signature
+               ; case mb_ty of
+                   Just ty -> go2 name ty top_lvl
+                   Nothing -> discard_it  -- No info; discard
+               }
+      where
+        discard_it = go dflags tidy_env ct_tvs n_left tvs_seen docs
+                        discards tc_bndrs
+        go2 id_name id_type top_lvl
+          = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type
+               ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty)
+               ; let id_tvs = tyCoVarsOfType tidy_ty
+                     doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty
+                               , nest 2 (parens (text "bound at"
+                                    <+> ppr (getSrcLoc id_name)))]
+                     new_seen = tvs_seen `unionVarSet` id_tvs
+
+               ; if (want_filtering && not (hasPprDebug dflags)
+                                    && id_tvs `disjointVarSet` ct_tvs)
+                          -- We want to filter out this binding anyway
+                          -- so discard it silently
+                 then discard_it
+
+                 else if isTopLevel top_lvl && not (isNothing n_left)
+                          -- It's a top-level binding and we have not specified
+                          -- -fno-max-relevant-bindings, so discard it silently
+                 then discard_it
+
+                 else if run_out n_left && id_tvs `subVarSet` tvs_seen
+                          -- We've run out of n_left fuel and this binding only
+                          -- mentions already-seen type variables, so discard it
+                 then go dflags tidy_env ct_tvs n_left tvs_seen docs
+                         True      -- Record that we have now discarded something
+                         tc_bndrs
+
+                          -- Keep this binding, decrement fuel
+                 else go dflags tidy_env' ct_tvs (dec_max n_left) new_seen
+                         (doc:docs) discards tc_bndrs }
+
+
+discardMsg :: SDoc
+discardMsg = text "(Some bindings suppressed;" <+>
+             text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"
+
+-----------------------
+warnDefaulting :: [Ct] -> Type -> TcM ()
+warnDefaulting wanteds default_ty
+  = do { warn_default <- woptM Opt_WarnTypeDefaults
+       ; env0 <- tcInitTidyEnv
+       ; let tidy_env = tidyFreeTyCoVars env0 $
+                        tyCoVarsOfCtsList (listToBag wanteds)
+             tidy_wanteds = map (tidyCt tidy_env) wanteds
+             (loc, ppr_wanteds) = pprWithArising tidy_wanteds
+             warn_msg =
+                hang (hsep [ text "Defaulting the following"
+                           , text "constraint" <> plural tidy_wanteds
+                           , text "to type"
+                           , quotes (ppr default_ty) ])
+                     2
+                     ppr_wanteds
+       ; setCtLocM loc $ warnTc (Reason Opt_WarnTypeDefaults) warn_default warn_msg }
+
+{-
+Note [Runtime skolems]
+~~~~~~~~~~~~~~~~~~~~~~
+We want to give a reasonably helpful error message for ambiguity
+arising from *runtime* skolems in the debugger.  These
+are created by in RtClosureInspect.zonkRTTIType.
+
+************************************************************************
+*                                                                      *
+                 Error from the canonicaliser
+         These ones are called *during* constraint simplification
+*                                                                      *
+************************************************************************
+-}
+
+solverDepthErrorTcS :: CtLoc -> TcType -> TcM a
+solverDepthErrorTcS loc ty
+  = setCtLocM loc $
+    do { ty <- zonkTcType ty
+       ; env0 <- tcInitTidyEnv
+       ; let tidy_env     = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty)
+             tidy_ty      = tidyType tidy_env ty
+             msg
+               = vcat [ text "Reduction stack overflow; size =" <+> ppr depth
+                      , hang (text "When simplifying the following type:")
+                           2 (ppr tidy_ty)
+                      , note ]
+       ; failWithTcM (tidy_env, msg) }
+  where
+    depth = ctLocDepth loc
+    note = vcat
+      [ text "Use -freduction-depth=0 to disable this check"
+      , text "(any upper bound you could choose might fail unpredictably with"
+      , text " minor updates to GHC, so disabling the check is recommended if"
+      , text " you're sure that type checking should terminate)" ]
diff --git a/compiler/typecheck/TcEvTerm.hs b/compiler/typecheck/TcEvTerm.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcEvTerm.hs
@@ -0,0 +1,70 @@
+
+-- (those who have too heavy dependencies for TcEvidence)
+module TcEvTerm
+    ( evDelayedError, evCallStack )
+where
+
+import GhcPrelude
+
+import FastString
+import Type
+import CoreSyn
+import MkCore
+import Literal ( Literal(..) )
+import TcEvidence
+import HscTypes
+import DynFlags
+import Name
+import Module
+import CoreUtils
+import PrelNames
+import SrcLoc
+
+-- Used with Opt_DeferTypeErrors
+-- See Note [Deferring coercion errors to runtime]
+-- in TcSimplify
+evDelayedError :: Type -> FastString -> EvTerm
+evDelayedError ty msg
+  = EvExpr $
+    Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]
+  where
+    errorId = tYPE_ERROR_ID
+    litMsg  = Lit (LitString (fastStringToByteString msg))
+
+-- Dictionary for CallStack implicit parameters
+evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>
+    EvCallStack -> m EvExpr
+-- See Note [Overview of implicit CallStacks] in TcEvidence.hs
+evCallStack cs = do
+  df            <- getDynFlags
+  m             <- getModule
+  srcLocDataCon <- lookupDataCon srcLocDataConName
+  let mkSrcLoc l = mkCoreConApps srcLocDataCon <$>
+               sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)
+                        , mkStringExprFS (moduleNameFS $ moduleName m)
+                        , mkStringExprFS (srcSpanFile l)
+                        , return $ mkIntExprInt df (srcSpanStartLine l)
+                        , return $ mkIntExprInt df (srcSpanStartCol l)
+                        , return $ mkIntExprInt df (srcSpanEndLine l)
+                        , return $ mkIntExprInt df (srcSpanEndCol l)
+                        ]
+
+  emptyCS <- Var <$> lookupId emptyCallStackName
+
+  pushCSVar <- lookupId pushCallStackName
+  let pushCS name loc rest =
+        mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]
+
+  let mkPush name loc tm = do
+        nameExpr <- mkStringExprFS name
+        locExpr <- mkSrcLoc loc
+        -- at this point tm :: IP sym CallStack
+        -- but we need the actual CallStack to pass to pushCS,
+        -- so we use unwrapIP to strip the dictionary wrapper
+        -- See Note [Overview of implicit CallStacks]
+        let ip_co = unwrapIP (exprType tm)
+        return (pushCS nameExpr locExpr (Cast tm ip_co))
+
+  case cs of
+    EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
+    EvCsEmpty -> return emptyCS
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcExpr.hs
@@ -0,0 +1,2915 @@
+{-
+%
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[TcExpr]{Typecheck an expression}
+-}
+
+{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC,
+                tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC,
+                tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
+                tcCheckId,
+                addExprErrCtxt,
+                getFixedTyVars ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
+import THNames( liftStringName, liftName )
+
+import HsSyn
+import TcHsSyn
+import TcRnMonad
+import TcUnify
+import BasicTypes
+import Inst
+import TcBinds          ( chooseInferredQuantifiers, tcLocalBinds )
+import TcSigs           ( tcUserTypeSig, tcInstSig )
+import TcSimplify       ( simplifyInfer, InferMode(..) )
+import FamInst          ( tcGetFamInstEnvs, tcLookupDataFamInst )
+import FamInstEnv       ( FamInstEnvs )
+import RnEnv            ( addUsedGRE )
+import RnUtils          ( addNameClashErrRn, unknownSubordinateErr )
+import TcEnv
+import TcArrows
+import TcMatches
+import TcHsType
+import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr )
+import TcPat
+import TcMType
+import TcType
+import Id
+import IdInfo
+import ConLike
+import DataCon
+import PatSyn
+import Name
+import NameEnv
+import NameSet
+import RdrName
+import TyCon
+import TyCoRep
+import Type
+import TcEvidence
+import VarSet
+import MkId( seqId )
+import TysWiredIn
+import TysPrim( intPrimTy, mkTemplateTyVars, tYPE )
+import PrimOp( tagToEnumKey )
+import PrelNames
+import DynFlags
+import SrcLoc
+import Util
+import VarEnv  ( emptyTidyEnv, mkInScopeSet )
+import ListSetOps
+import Maybes
+import Outputable
+import FastString
+import Control.Monad
+import Class(classTyCon)
+import UniqSet ( nonDetEltsUniqSet )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.Function
+import Data.List
+import qualified Data.Set as Set
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Main wrappers}
+*                                                                      *
+************************************************************************
+-}
+
+tcPolyExpr, tcPolyExprNC
+  :: LHsExpr GhcRn         -- Expression to type check
+  -> TcSigmaType           -- Expected type (could be a polytype)
+  -> TcM (LHsExpr GhcTcId) -- Generalised expr with expected type
+
+-- tcPolyExpr is a convenient place (frequent but not too frequent)
+-- place to add context information.
+-- The NC version does not do so, usually because the caller wants
+-- to do so himself.
+
+tcPolyExpr   expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty)
+tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty)
+
+-- these versions take an ExpType
+tc_poly_expr, tc_poly_expr_nc :: LHsExpr GhcRn -> ExpSigmaType
+                              -> TcM (LHsExpr GhcTcId)
+tc_poly_expr expr res_ty
+  = addExprErrCtxt expr $
+    do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty }
+
+tc_poly_expr_nc (L loc expr) res_ty
+  = setSrcSpan loc $
+    do { traceTc "tcPolyExprNC" (ppr res_ty)
+       ; (wrap, expr')
+           <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->
+              tcExpr expr res_ty
+       ; return $ L loc (mkHsWrap wrap expr') }
+
+---------------
+tcMonoExpr, tcMonoExprNC
+    :: LHsExpr GhcRn     -- Expression to type check
+    -> ExpRhoType        -- Expected type
+                         -- Definitely no foralls at the top
+    -> TcM (LHsExpr GhcTcId)
+
+tcMonoExpr expr res_ty
+  = addErrCtxt (exprCtxt expr) $
+    tcMonoExprNC expr res_ty
+
+tcMonoExprNC (L loc expr) res_ty
+  = setSrcSpan loc $
+    do  { expr' <- tcExpr expr res_ty
+        ; return (L loc expr') }
+
+---------------
+tcInferSigma, tcInferSigmaNC :: LHsExpr GhcRn -> TcM ( LHsExpr GhcTcId
+                                                    , TcSigmaType )
+-- Infer a *sigma*-type.
+tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr)
+
+tcInferSigmaNC (L loc expr)
+  = setSrcSpan loc $
+    do { (expr', sigma) <- tcInferNoInst (tcExpr expr)
+       ; return (L loc expr', sigma) }
+
+tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcRhoType)
+-- Infer a *rho*-type. The return type is always (shallowly) instantiated.
+tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)
+
+tcInferRhoNC expr
+  = do { (expr', sigma) <- tcInferSigmaNC expr
+       ; (wrap, rho) <- topInstantiate (lexprCtOrigin expr) sigma
+       ; return (mkLHsWrap wrap expr', rho) }
+
+
+{-
+************************************************************************
+*                                                                      *
+        tcExpr: the main expression typechecker
+*                                                                      *
+************************************************************************
+
+NB: The res_ty is always deeply skolemised.
+-}
+
+tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
+tcExpr (HsVar _ (L _ name))   res_ty = tcCheckId name res_ty
+tcExpr e@(HsUnboundVar _ uv)  res_ty = tcUnboundId e uv res_ty
+
+tcExpr e@(HsApp {})     res_ty = tcApp1 e res_ty
+tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty
+
+tcExpr e@(HsLit x lit) res_ty
+  = do { let lit_ty = hsLitType lit
+       ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty }
+
+tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
+                                  ; return (HsPar x expr') }
+
+tcExpr (HsSCC x src lbl expr) res_ty
+  = do { expr' <- tcMonoExpr expr res_ty
+       ; return (HsSCC x src lbl expr') }
+
+tcExpr (HsTickPragma x src info srcInfo expr) res_ty
+  = do { expr' <- tcMonoExpr expr res_ty
+       ; return (HsTickPragma x src info srcInfo expr') }
+
+tcExpr (HsCoreAnn x src lbl expr) res_ty
+  = do  { expr' <- tcMonoExpr expr res_ty
+        ; return (HsCoreAnn x src lbl expr') }
+
+tcExpr (HsOverLit x lit) res_ty
+  = do  { lit' <- newOverloadedLit lit res_ty
+        ; return (HsOverLit x lit') }
+
+tcExpr (NegApp x expr neg_expr) res_ty
+  = do  { (expr', neg_expr')
+            <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $
+               \[arg_ty] ->
+               tcMonoExpr expr (mkCheckExpType arg_ty)
+        ; return (NegApp x expr' neg_expr') }
+
+tcExpr e@(HsIPVar _ x) res_ty
+  = do {   {- Implicit parameters must have a *tau-type* not a
+              type scheme.  We enforce this by creating a fresh
+              type variable as its type.  (Because res_ty may not
+              be a tau-type.) -}
+         ip_ty <- newOpenFlexiTyVarTy
+       ; let ip_name = mkStrLitTy (hsIPNameFS x)
+       ; ipClass <- tcLookupClass ipClassName
+       ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
+       ; tcWrapResult e
+                   (fromDict ipClass ip_name ip_ty (HsVar noExt (noLoc ip_var)))
+                   ip_ty res_ty }
+  where
+  -- Coerces a dictionary for `IP "x" t` into `t`.
+  fromDict ipClass x ty = mkHsWrap $ mkWpCastR $
+                          unwrapIP $ mkClassPred ipClass [x,ty]
+  origin = IPOccOrigin x
+
+tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty
+  = do { -- See Note [Type-checking overloaded labels]
+         loc <- getSrcSpanM
+       ; case mb_fromLabel of
+           Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty
+           Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName
+                         ; alpha <- newFlexiTyVarTy liftedTypeKind
+                         ; let pred = mkClassPred isLabelClass [lbl, alpha]
+                         ; loc <- getSrcSpanM
+                         ; var <- emitWantedEvVar origin pred
+                         ; tcWrapResult e
+                                       (fromDict pred (HsVar noExt (L loc var)))
+                                        alpha res_ty } }
+  where
+  -- Coerces a dictionary for `IsLabel "x" t` into `t`,
+  -- or `HasField "x" r a into `r -> a`.
+  fromDict pred = mkHsWrap $ mkWpCastR $ unwrapIP pred
+  origin = OverLabelOrigin l
+  lbl = mkStrLitTy l
+
+  applyFromLabel loc fromLabel =
+    HsAppType noExt
+         (L loc (HsVar noExt (L loc fromLabel)))
+         (mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l))))
+
+tcExpr (HsLam x match) res_ty
+  = do  { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty
+        ; return (mkHsWrap wrap (HsLam x match')) }
+  where
+    match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
+    herald = sep [ text "The lambda expression" <+>
+                   quotes (pprSetDepth (PartWay 1) $
+                           pprMatches match),
+                        -- The pprSetDepth makes the abstraction print briefly
+                   text "has"]
+
+tcExpr e@(HsLamCase x matches) res_ty
+  = do { (matches', wrap)
+           <- tcMatchLambda msg match_ctxt matches res_ty
+           -- The laziness annotation is because we don't want to fail here
+           -- if there are multiple arguments
+       ; return (mkHsWrap wrap $ HsLamCase x matches') }
+  where
+    msg = sep [ text "The function" <+> quotes (ppr e)
+              , text "requires"]
+    match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
+
+tcExpr e@(ExprWithTySig _ expr sig_ty) res_ty
+  = do { let loc = getLoc (hsSigWcType sig_ty)
+       ; sig_info <- checkNoErrs $  -- Avoid error cascade
+                     tcUserTypeSig loc sig_ty Nothing
+       ; (expr', poly_ty) <- tcExprSig expr sig_info
+       ; let expr'' = ExprWithTySig noExt expr' sig_ty
+       ; tcWrapResult e expr'' poly_ty res_ty }
+
+{-
+Note [Type-checking overloaded labels]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Recall that we have
+
+  module GHC.OverloadedLabels where
+    class IsLabel (x :: Symbol) a where
+      fromLabel :: a
+
+We translate `#foo` to `fromLabel @"foo"`, where we use
+
+ * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not
+ * `GHC.OverloadedLabels.fromLabel`.
+
+In the `RebindableSyntax` case, the renamer will have filled in the
+first field of `HsOverLabel` with the `fromLabel` function to use, and
+we simply apply it to the appropriate visible type argument.
+
+In the `OverloadedLabels` case, when we see an overloaded label like
+`#foo`, we generate a fresh variable `alpha` for the type and emit an
+`IsLabel "foo" alpha` constraint.  Because the `IsLabel` class has a
+single method, it is represented by a newtype, so we can coerce
+`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters).
+
+-}
+
+
+{-
+************************************************************************
+*                                                                      *
+                Infix operators and sections
+*                                                                      *
+************************************************************************
+
+Note [Left sections]
+~~~~~~~~~~~~~~~~~~~~
+Left sections, like (4 *), are equivalent to
+        \ x -> (*) 4 x,
+or, if PostfixOperators is enabled, just
+        (*) 4
+With PostfixOperators we don't actually require the function to take
+two arguments at all.  For example, (x `not`) means (not x); you get
+postfix operators!  Not Haskell 98, but it's less work and kind of
+useful.
+
+Note [Typing rule for ($)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+People write
+   runST $ blah
+so much, where
+   runST :: (forall s. ST s a) -> a
+that I have finally given in and written a special type-checking
+rule just for saturated applications of ($).
+  * Infer the type of the first argument
+  * Decompose it; should be of form (arg2_ty -> res_ty),
+       where arg2_ty might be a polytype
+  * Use arg2_ty to typecheck arg2
+
+Note [Typing rule for seq]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to allow
+       x `seq` (# p,q #)
+which suggests this type for seq:
+   seq :: forall (a:*) (b:Open). a -> b -> b,
+with (b:Open) meaning that be can be instantiated with an unboxed
+tuple.  The trouble is that this might accept a partially-applied
+'seq', and I'm just not certain that would work.  I'm only sure it's
+only going to work when it's fully applied, so it turns into
+    case x of _ -> (# p,q #)
+
+So it seems more uniform to treat 'seq' as if it was a language
+construct.
+
+See also Note [seqId magic] in MkId
+-}
+
+tcExpr expr@(OpApp fix arg1 op arg2) res_ty
+  | (L loc (HsVar _ (L lv op_name))) <- op
+  , op_name `hasKey` seqIdKey           -- Note [Typing rule for seq]
+  = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
+       ; let arg2_exp_ty = res_ty
+       ; arg1' <- tcArg op arg1 arg1_ty 1
+       ; arg2' <- addErrCtxt (funAppCtxt op arg2 2) $
+                  tc_poly_expr_nc arg2 arg2_exp_ty
+       ; arg2_ty <- readExpType arg2_exp_ty
+       ; op_id <- tcLookupId op_name
+       ; let op' = L loc (mkHsWrap (mkWpTyApps [arg1_ty, arg2_ty])
+                                   (HsVar noExt (L lv op_id)))
+       ; return $ OpApp fix arg1' op' arg2' }
+
+  | (L loc (HsVar _ (L lv op_name))) <- op
+  , op_name `hasKey` dollarIdKey        -- Note [Typing rule for ($)]
+  = do { traceTc "Application rule" (ppr op)
+       ; (arg1', arg1_ty) <- tcInferSigma arg1
+
+       ; let doc   = text "The first argument of ($) takes"
+             orig1 = lexprCtOrigin arg1
+       ; (wrap_arg1, [arg2_sigma], op_res_ty) <-
+           matchActualFunTys doc orig1 (Just (unLoc arg1)) 1 arg1_ty
+
+         -- We have (arg1 $ arg2)
+         -- So: arg1_ty = arg2_ty -> op_res_ty
+         -- where arg2_sigma maybe polymorphic; that's the point
+
+       ; arg2'  <- tcArg op arg2 arg2_sigma 2
+
+       -- Make sure that the argument type has kind '*'
+       --   ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b
+       -- Eg we do not want to allow  (D#  $  4.0#)   Trac #5570
+       --    (which gives a seg fault)
+       --
+       -- The *result* type can have any kind (Trac #8739),
+       -- so we don't need to check anything for that
+       ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma))
+                        (tcTypeKind arg2_sigma) liftedTypeKind
+           -- ignore the evidence. arg2_sigma must have type * or #,
+           -- because we know arg2_sigma -> or_res_ty is well-kinded
+           -- (because otherwise matchActualFunTys would fail)
+           -- There's no possibility here of, say, a kind family reducing to *.
+
+       ; wrap_res <- tcSubTypeHR orig1 (Just expr) op_res_ty res_ty
+                       -- op_res -> res
+
+       ; op_id  <- tcLookupId op_name
+       ; res_ty <- readExpType res_ty
+       ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep res_ty
+                                               , arg2_sigma
+                                               , res_ty])
+                                   (HsVar noExt (L lv op_id)))
+             -- arg1' :: arg1_ty
+             -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)
+             -- wrap_res :: op_res_ty "->" res_ty
+             -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty
+
+             -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty)
+             wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty doc
+                     <.> wrap_arg1
+             doc = text "When looking at the argument to ($)"
+
+       ; return (OpApp fix (mkLHsWrap wrap1 arg1') op' arg2') }
+
+  | (L loc (HsRecFld _ (Ambiguous _ lbl))) <- op
+  , Just sig_ty <- obviousSig (unLoc arg1)
+    -- See Note [Disambiguating record fields]
+  = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
+       ; sel_name <- disambiguateSelector lbl sig_tc_ty
+       ; let op' = L loc (HsRecFld noExt (Unambiguous sel_name lbl))
+       ; tcExpr (OpApp fix arg1 op' arg2) res_ty
+       }
+
+  | otherwise
+  = do { traceTc "Non Application rule" (ppr op)
+       ; (wrap, op', [HsValArg arg1', HsValArg arg2'])
+           <- tcApp (Just $ mk_op_msg op)
+                     op [HsValArg arg1, HsValArg arg2] res_ty
+       ; return (mkHsWrap wrap $ OpApp fix arg1' op' arg2') }
+
+-- Right sections, equivalent to \ x -> x `op` expr, or
+--      \ x -> op x expr
+
+tcExpr expr@(SectionR x op arg2) res_ty
+  = do { (op', op_ty) <- tcInferFun op
+       ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty)
+                  <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty
+       ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
+                                 (mkFunTy arg1_ty op_res_ty) res_ty
+       ; arg2' <- tcArg op arg2 arg2_ty 2
+       ; return ( mkHsWrap wrap_res $
+                  SectionR x (mkLHsWrap wrap_fun op') arg2' ) }
+  where
+    fn_orig = lexprCtOrigin op
+    -- It's important to use the origin of 'op', so that call-stacks
+    -- come out right; they are driven by the OccurrenceOf CtOrigin
+    -- See Trac #13285
+
+tcExpr expr@(SectionL x arg1 op) res_ty
+  = do { (op', op_ty) <- tcInferFun op
+       ; dflags <- getDynFlags      -- Note [Left sections]
+       ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1
+                         | otherwise                            = 2
+
+       ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
+           <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op))
+                                n_reqd_args op_ty
+       ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
+                                 (mkFunTys arg_tys op_res_ty) res_ty
+       ; arg1' <- tcArg op arg1 arg1_ty 1
+       ; return ( mkHsWrap wrap_res $
+                  SectionL x arg1' (mkLHsWrap wrap_fn op') ) }
+  where
+    fn_orig = lexprCtOrigin op
+    -- It's important to use the origin of 'op', so that call-stacks
+    -- come out right; they are driven by the OccurrenceOf CtOrigin
+    -- See Trac #13285
+
+tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty
+  | all tupArgPresent tup_args
+  = do { let arity  = length tup_args
+             tup_tc = tupleTyCon boxity arity
+       ; res_ty <- expTypeToType res_ty
+       ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
+                           -- Unboxed tuples have RuntimeRep vars, which we
+                           -- don't care about here
+                           -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+       ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys
+                                       Boxed   -> arg_tys
+       ; tup_args1 <- tcTupArgs tup_args arg_tys'
+       ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) }
+
+  | otherwise
+  = -- The tup_args are a mixture of Present and Missing (for tuple sections)
+    do { let arity = length tup_args
+
+       ; arg_tys <- case boxity of
+           { Boxed   -> newFlexiTyVarTys arity liftedTypeKind
+           ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }
+       ; let actual_res_ty
+                 = mkFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args]
+                            (mkTupleTy boxity arg_tys)
+
+       ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple")
+                             (Just expr)
+                             actual_res_ty res_ty
+
+       -- Handle tuple sections where
+       ; tup_args1 <- tcTupArgs tup_args arg_tys
+
+       ; return $ mkHsWrap wrap (ExplicitTuple x tup_args1 boxity) }
+
+tcExpr (ExplicitSum _ alt arity expr) res_ty
+  = do { let sum_tc = sumTyCon arity
+       ; res_ty <- expTypeToType res_ty
+       ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty
+       ; -- Drop levity vars, we don't care about them here
+         let arg_tys' = drop arity arg_tys
+       ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1))
+       ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }
+
+tcExpr (ExplicitList _ witness exprs) res_ty
+  = case witness of
+      Nothing   -> do  { res_ty <- expTypeToType res_ty
+                       ; (coi, elt_ty) <- matchExpectedListTy res_ty
+                       ; exprs' <- mapM (tc_elt elt_ty) exprs
+                       ; return $
+                         mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' }
+
+      Just fln -> do { ((exprs', elt_ty), fln')
+                         <- tcSyntaxOp ListOrigin fln
+                                       [synKnownType intTy, SynList] res_ty $
+                            \ [elt_ty] ->
+                            do { exprs' <-
+                                    mapM (tc_elt elt_ty) exprs
+                               ; return (exprs', elt_ty) }
+
+                     ; return $ ExplicitList elt_ty (Just fln') exprs' }
+     where tc_elt elt_ty expr = tcPolyExpr expr elt_ty
+
+{-
+************************************************************************
+*                                                                      *
+                Let, case, if, do
+*                                                                      *
+************************************************************************
+-}
+
+tcExpr (HsLet x (L l binds) expr) res_ty
+  = do  { (binds', expr') <- tcLocalBinds binds $
+                             tcMonoExpr expr res_ty
+        ; return (HsLet x (L l binds') expr') }
+
+tcExpr (HsCase x scrut matches) res_ty
+  = do  {  -- We used to typecheck the case alternatives first.
+           -- The case patterns tend to give good type info to use
+           -- when typechecking the scrutinee.  For example
+           --   case (map f) of
+           --     (x:xs) -> ...
+           -- will report that map is applied to too few arguments
+           --
+           -- But now, in the GADT world, we need to typecheck the scrutinee
+           -- first, to get type info that may be refined in the case alternatives
+          (scrut', scrut_ty) <- tcInferRho scrut
+
+        ; traceTc "HsCase" (ppr scrut_ty)
+        ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
+        ; return (HsCase x scrut' matches') }
+ where
+    match_ctxt = MC { mc_what = CaseAlt,
+                      mc_body = tcBody }
+
+tcExpr (HsIf x Nothing pred b1 b2) res_ty    -- Ordinary 'if'
+  = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
+       ; res_ty <- tauifyExpType res_ty
+           -- Just like Note [Case branches must never infer a non-tau type]
+           -- in TcMatches (See #10619)
+
+       ; b1' <- tcMonoExpr b1 res_ty
+       ; b2' <- tcMonoExpr b2 res_ty
+       ; return (HsIf x Nothing pred' b1' b2') }
+
+tcExpr (HsIf x (Just fun) pred b1 b2) res_ty
+  = do { ((pred', b1', b2'), fun')
+           <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $
+              \ [pred_ty, b1_ty, b2_ty] ->
+              do { pred' <- tcPolyExpr pred pred_ty
+                 ; b1'   <- tcPolyExpr b1   b1_ty
+                 ; b2'   <- tcPolyExpr b2   b2_ty
+                 ; return (pred', b1', b2') }
+       ; return (HsIf x (Just fun') pred' b1' b2') }
+
+tcExpr (HsMultiIf _ alts) res_ty
+  = do { res_ty <- if isSingleton alts
+                   then return res_ty
+                   else tauifyExpType res_ty
+             -- Just like TcMatches
+             -- Note [Case branches must never infer a non-tau type]
+
+       ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
+       ; res_ty <- readExpType res_ty
+       ; return (HsMultiIf res_ty alts') }
+  where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
+
+tcExpr (HsDo _ do_or_lc stmts) res_ty
+  = do { expr' <- tcDoStmts do_or_lc stmts res_ty
+       ; return expr' }
+
+tcExpr (HsProc x pat cmd) res_ty
+  = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
+        ; return $ mkHsWrapCo coi (HsProc x pat' cmd') }
+
+-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
+-- See Note [Grand plan for static forms] in StaticPtrTable for an overview.
+-- To type check
+--      (static e) :: p a
+-- we want to check (e :: a),
+-- and wrap (static e) in a call to
+--    fromStaticPtr :: IsStatic p => StaticPtr a -> p a
+
+tcExpr (HsStatic fvs expr) res_ty
+  = do  { res_ty          <- expTypeToType res_ty
+        ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty
+        ; (expr', lie)    <- captureConstraints $
+            addErrCtxt (hang (text "In the body of a static form:")
+                             2 (ppr expr)
+                       ) $
+            tcPolyExprNC expr expr_ty
+
+        -- Check that the free variables of the static form are closed.
+        -- It's OK to use nonDetEltsUniqSet here as the only side effects of
+        -- checkClosedInStaticForm are error messages.
+        ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs
+
+        -- Require the type of the argument to be Typeable.
+        -- The evidence is not used, but asking the constraint ensures that
+        -- the current implementation is as restrictive as future versions
+        -- of the StaticPointers extension.
+        ; typeableClass <- tcLookupClass typeableClassName
+        ; _ <- emitWantedEvVar StaticOrigin $
+                  mkTyConApp (classTyCon typeableClass)
+                             [liftedTypeKind, expr_ty]
+
+        -- Insert the constraints of the static form in a global list for later
+        -- validation.
+        ; emitStaticConstraints lie
+
+        -- Wrap the static form with the 'fromStaticPtr' call.
+        ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty
+        ; let wrap = mkWpTyApps [expr_ty]
+        ; loc <- getSrcSpanM
+        ; return $ mkHsWrapCo co $ HsApp noExt
+                                         (L loc $ mkHsWrap wrap fromStaticPtr)
+                                         (L loc (HsStatic fvs expr'))
+        }
+
+{-
+************************************************************************
+*                                                                      *
+                Record construction and update
+*                                                                      *
+************************************************************************
+-}
+
+tcExpr expr@(RecordCon { rcon_con_name = L loc con_name
+                       , rcon_flds = rbinds }) res_ty
+  = do  { con_like <- tcLookupConLike con_name
+
+        -- Check for missing fields
+        ; checkMissingFields con_like rbinds
+
+        ; (con_expr, con_sigma) <- tcInferId con_name
+        ; (con_wrap, con_tau) <-
+            topInstantiate (OccurrenceOf con_name) con_sigma
+              -- a shallow instantiation should really be enough for
+              -- a data constructor.
+        ; let arity = conLikeArity con_like
+              Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau
+        ; case conLikeWrapId_maybe con_like of
+               Nothing -> nonBidirectionalErr (conLikeName con_like)
+               Just con_id -> do {
+                  res_wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "RecordCon")
+                                          (Just expr) actual_res_ty res_ty
+                ; rbinds' <- tcRecordBinds con_like arg_tys rbinds
+                ; return $
+                  mkHsWrap res_wrap $
+                  RecordCon { rcon_ext = RecordConTc
+                                 { rcon_con_like = con_like
+                                 , rcon_con_expr = mkHsWrap con_wrap con_expr }
+                            , rcon_con_name = L loc con_id
+                            , rcon_flds = rbinds' } } }
+
+{-
+Note [Type of a record update]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The main complication with RecordUpd is that we need to explicitly
+handle the *non-updated* fields.  Consider:
+
+        data T a b c = MkT1 { fa :: a, fb :: (b,c) }
+                     | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
+                     | MkT3 { fd :: a }
+
+        upd :: T a b c -> (b',c) -> T a b' c
+        upd t x = t { fb = x}
+
+The result type should be (T a b' c)
+not (T a b c),   because 'b' *is not* mentioned in a non-updated field
+not (T a b' c'), because 'c' *is*     mentioned in a non-updated field
+NB that it's not good enough to look at just one constructor; we must
+look at them all; cf Trac #3219
+
+After all, upd should be equivalent to:
+        upd t x = case t of
+                        MkT1 p q -> MkT1 p x
+                        MkT2 a b -> MkT2 p b
+                        MkT3 d   -> error ...
+
+So we need to give a completely fresh type to the result record,
+and then constrain it by the fields that are *not* updated ("p" above).
+We call these the "fixed" type variables, and compute them in getFixedTyVars.
+
+Note that because MkT3 doesn't contain all the fields being updated,
+its RHS is simply an error, so it doesn't impose any type constraints.
+Hence the use of 'relevant_cont'.
+
+Note [Implicit type sharing]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We also take into account any "implicit" non-update fields.  For example
+        data T a b where { MkT { f::a } :: T a a; ... }
+So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
+
+Then consider
+        upd t x = t { f=x }
+We infer the type
+        upd :: T a b -> a -> T a b
+        upd (t::T a b) (x::a)
+           = case t of { MkT (co:a~b) (_:a) -> MkT co x }
+We can't give it the more general type
+        upd :: T a b -> c -> T c b
+
+Note [Criteria for update]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to allow update for existentials etc, provided the updated
+field isn't part of the existential. For example, this should be ok.
+  data T a where { MkT { f1::a, f2::b->b } :: T a }
+  f :: T a -> b -> T b
+  f t b = t { f1=b }
+
+The criterion we use is this:
+
+  The types of the updated fields
+  mention only the universally-quantified type variables
+  of the data constructor
+
+NB: this is not (quite) the same as being a "naughty" record selector
+(See Note [Naughty record selectors]) in TcTyClsDecls), at least
+in the case of GADTs. Consider
+   data T a where { MkT :: { f :: a } :: T [a] }
+Then f is not "naughty" because it has a well-typed record selector.
+But we don't allow updates for 'f'.  (One could consider trying to
+allow this, but it makes my head hurt.  Badly.  And no one has asked
+for it.)
+
+In principle one could go further, and allow
+  g :: T a -> T a
+  g t = t { f2 = \x -> x }
+because the expression is polymorphic...but that seems a bridge too far.
+
+Note [Data family example]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+    data instance T (a,b) = MkT { x::a, y::b }
+  --->
+    data :TP a b = MkT { a::a, y::b }
+    coTP a b :: T (a,b) ~ :TP a b
+
+Suppose r :: T (t1,t2), e :: t3
+Then  r { x=e } :: T (t3,t1)
+  --->
+      case r |> co1 of
+        MkT x y -> MkT e y |> co2
+      where co1 :: T (t1,t2) ~ :TP t1 t2
+            co2 :: :TP t3 t2 ~ T (t3,t2)
+The wrapping with co2 is done by the constructor wrapper for MkT
+
+Outgoing invariants
+~~~~~~~~~~~~~~~~~~~
+In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
+
+  * cons are the data constructors to be updated
+
+  * in_inst_tys, out_inst_tys have same length, and instantiate the
+        *representation* tycon of the data cons.  In Note [Data
+        family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
+
+Note [Mixed Record Field Updates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following pattern synonym.
+
+  data MyRec = MyRec { foo :: Int, qux :: String }
+
+  pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}
+
+This allows updates such as the following
+
+  updater :: MyRec -> MyRec
+  updater a = a {f1 = 1 }
+
+It would also make sense to allow the following update (which we reject).
+
+  updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"
+
+This leads to confusing behaviour when the selectors in fact refer the same
+field.
+
+  updater a = a {f1 = 1, foo = 2} ==? ???
+
+For this reason, we reject a mixture of pattern synonym and normal record
+selectors in the same update block. Although of course we still allow the
+following.
+
+  updater a = (a {f1 = 1}) {foo = 2}
+
+  > updater (MyRec 0 "str")
+  MyRec 2 "str"
+
+-}
+
+tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
+  = ASSERT( notNull rbnds )
+    do  { -- STEP -2: typecheck the record_expr, the record to be updated
+          (record_expr', record_rho) <- tcInferRho record_expr
+
+        -- STEP -1  See Note [Disambiguating record fields]
+        -- After this we know that rbinds is unambiguous
+        ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty
+        ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds
+              upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds
+              sel_ids      = map selectorAmbiguousFieldOcc upd_flds
+        -- STEP 0
+        -- Check that the field names are really field names
+        -- and they are all field names for proper records or
+        -- all field names for pattern synonyms.
+        ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
+                         | fld <- rbinds,
+                           -- Excludes class ops
+                           let L loc sel_id = hsRecUpdFieldId (unLoc fld),
+                           not (isRecordSelector sel_id),
+                           let fld_name = idName sel_id ]
+        ; unless (null bad_guys) (sequence bad_guys >> failM)
+        -- See note [Mixed Record Selectors]
+        ; let (data_sels, pat_syn_sels) =
+                partition isDataConRecordSelector sel_ids
+        ; MASSERT( all isPatSynRecordSelector pat_syn_sels )
+        ; checkTc ( null data_sels || null pat_syn_sels )
+                  ( mixedSelectors data_sels pat_syn_sels )
+
+        -- STEP 1
+        -- Figure out the tycon and data cons from the first field name
+        ; let   -- It's OK to use the non-tc splitters here (for a selector)
+              sel_id : _  = sel_ids
+
+              mtycon :: Maybe TyCon
+              mtycon = case idDetails sel_id of
+                          RecSelId (RecSelData tycon) _ -> Just tycon
+                          _ -> Nothing
+
+              con_likes :: [ConLike]
+              con_likes = case idDetails sel_id of
+                             RecSelId (RecSelData tc) _
+                                -> map RealDataCon (tyConDataCons tc)
+                             RecSelId (RecSelPatSyn ps) _
+                                -> [PatSynCon ps]
+                             _  -> panic "tcRecordUpd"
+                -- NB: for a data type family, the tycon is the instance tycon
+
+              relevant_cons = conLikesWithFields con_likes upd_fld_occs
+                -- A constructor is only relevant to this process if
+                -- it contains *all* the fields that are being updated
+                -- Other ones will cause a runtime error if they occur
+
+        -- Step 2
+        -- Check that at least one constructor has all the named fields
+        -- i.e. has an empty set of bad fields returned by badFields
+        ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)
+
+        -- Take apart a representative constructor
+        ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
+              (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _)
+                 = conLikeFullSig con1
+              con1_flds   = map flLabel $ conLikeFieldLabels con1
+              con1_tv_tys = mkTyVarTys con1_tvs
+              con1_res_ty = case mtycon of
+                              Just tc -> mkFamilyTyConApp tc con1_tv_tys
+                              Nothing -> conLikeResTy con1 con1_tv_tys
+
+        -- Check that we're not dealing with a unidirectional pattern
+        -- synonym
+        ; unless (isJust $ conLikeWrapId_maybe con1)
+                  (nonBidirectionalErr (conLikeName con1))
+
+        -- STEP 3    Note [Criteria for update]
+        -- Check that each updated field is polymorphic; that is, its type
+        -- mentions only the universally-quantified variables of the data con
+        ; let flds1_w_tys  = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
+              bad_upd_flds = filter bad_fld flds1_w_tys
+              con1_tv_set  = mkVarSet con1_tvs
+              bad_fld (fld, ty) = fld `elem` upd_fld_occs &&
+                                      not (tyCoVarsOfType ty `subVarSet` con1_tv_set)
+        ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
+
+        -- STEP 4  Note [Type of a record update]
+        -- Figure out types for the scrutinee and result
+        -- Both are of form (T a b c), with fresh type variables, but with
+        -- common variables where the scrutinee and result must have the same type
+        -- These are variables that appear in *any* arg of *any* of the
+        -- relevant constructors *except* in the updated fields
+        --
+        ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons
+              is_fixed_tv tv = tv `elemVarSet` fixed_tvs
+
+              mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)
+              -- Deals with instantiation of kind variables
+              --   c.f. TcMType.newMetaTyVars
+              mk_inst_ty subst (tv, result_inst_ty)
+                | is_fixed_tv tv   -- Same as result type
+                = return (extendTvSubst subst tv result_inst_ty, result_inst_ty)
+                | otherwise        -- Fresh type, of correct kind
+                = do { (subst', new_tv) <- newMetaTyVarX subst tv
+                     ; return (subst', mkTyVarTy new_tv) }
+
+        ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs
+        ; let result_inst_tys = mkTyVarTys con1_tvs'
+              init_subst = mkEmptyTCvSubst (getTCvInScope result_subst)
+
+        ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst
+                                                      (con1_tvs `zip` result_inst_tys)
+
+        ; let rec_res_ty    = TcType.substTy result_subst con1_res_ty
+              scrut_ty      = TcType.substTy scrut_subst  con1_res_ty
+              con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
+
+        ; wrap_res <- tcSubTypeHR (exprCtOrigin expr)
+                                  (Just expr) rec_res_ty res_ty
+        ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty
+                -- NB: normal unification is OK here (as opposed to subsumption),
+                -- because for this to work out, both record_rho and scrut_ty have
+                -- to be normal datatypes -- no contravariant stuff can go on
+
+        -- STEP 5
+        -- Typecheck the bindings
+        ; rbinds'      <- tcRecordUpd con1 con1_arg_tys' rbinds
+
+        -- STEP 6: Deal with the stupid theta
+        ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1)
+        ; instStupidTheta RecordUpdOrigin theta'
+
+        -- Step 7: make a cast for the scrutinee, in the
+        --         case that it's from a data family
+        ; let fam_co :: HsWrapper   -- RepT t1 .. tn ~R scrut_ty
+              fam_co | Just tycon <- mtycon
+                     , Just co_con <- tyConFamilyCoercion_maybe tycon
+                     = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys [])
+                     | otherwise
+                     = idHsWrapper
+
+        -- Step 8: Check that the req constraints are satisfied
+        -- For normal data constructors req_theta is empty but we must do
+        -- this check for pattern synonyms.
+        ; let req_theta' = substThetaUnchecked scrut_subst req_theta
+        ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta'
+
+        -- Phew!
+        ; return $
+          mkHsWrap wrap_res $
+          RecordUpd { rupd_expr
+                          = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr')
+                    , rupd_flds = rbinds'
+                    , rupd_ext = RecordUpdTc
+                        { rupd_cons = relevant_cons
+                        , rupd_in_tys = scrut_inst_tys
+                        , rupd_out_tys = result_inst_tys
+                        , rupd_wrap = req_wrap }} }
+
+tcExpr e@(HsRecFld _ f) res_ty
+    = tcCheckRecSelId e f res_ty
+
+{-
+************************************************************************
+*                                                                      *
+        Arithmetic sequences                    e.g. [a,b..]
+        and their parallel-array counterparts   e.g. [: a,b.. :]
+
+*                                                                      *
+************************************************************************
+-}
+
+tcExpr (ArithSeq _ witness seq) res_ty
+  = tcArithSeq witness seq res_ty
+
+{-
+************************************************************************
+*                                                                      *
+                Template Haskell
+*                                                                      *
+************************************************************************
+-}
+
+-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceExpr'.
+-- Here we get rid of it and add the finalizers to the global environment.
+--
+-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
+tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))
+       res_ty
+  = do addModFinalizersWithLclEnv mod_finalizers
+       tcExpr expr res_ty
+tcExpr (HsSpliceE _ splice)          res_ty
+  = tcSpliceExpr splice res_ty
+tcExpr e@(HsBracket _ brack)         res_ty
+  = tcTypedBracket e brack res_ty
+tcExpr e@(HsRnBracketOut _ brack ps) res_ty
+  = tcUntypedBracket e brack ps res_ty
+
+{-
+************************************************************************
+*                                                                      *
+                Catch-all
+*                                                                      *
+************************************************************************
+-}
+
+tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
+  -- Include ArrForm, ArrApp, which shouldn't appear at all
+  -- Also HsTcBracketOut, HsQuasiQuoteE
+
+{-
+************************************************************************
+*                                                                      *
+                Arithmetic sequences [a..b] etc
+*                                                                      *
+************************************************************************
+-}
+
+tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType
+           -> TcM (HsExpr GhcTcId)
+
+tcArithSeq witness seq@(From expr) res_ty
+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
+       ; expr' <- tcPolyExpr expr elt_ty
+       ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
+                              enumFromName elt_ty
+       ; return $ mkHsWrap wrap $
+         ArithSeq enum_from wit' (From expr') }
+
+tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
+       ; expr1' <- tcPolyExpr expr1 elt_ty
+       ; expr2' <- tcPolyExpr expr2 elt_ty
+       ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
+                              enumFromThenName elt_ty
+       ; return $ mkHsWrap wrap $
+         ArithSeq enum_from_then wit' (FromThen expr1' expr2') }
+
+tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
+       ; expr1' <- tcPolyExpr expr1 elt_ty
+       ; expr2' <- tcPolyExpr expr2 elt_ty
+       ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
+                              enumFromToName elt_ty
+       ; return $ mkHsWrap wrap $
+         ArithSeq enum_from_to wit' (FromTo expr1' expr2') }
+
+tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
+        ; expr1' <- tcPolyExpr expr1 elt_ty
+        ; expr2' <- tcPolyExpr expr2 elt_ty
+        ; expr3' <- tcPolyExpr expr3 elt_ty
+        ; eft <- newMethodFromName (ArithSeqOrigin seq)
+                              enumFromThenToName elt_ty
+        ; return $ mkHsWrap wrap $
+          ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }
+
+-----------------
+arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType
+                -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr GhcTc))
+arithSeqEltType Nothing res_ty
+  = do { res_ty <- expTypeToType res_ty
+       ; (coi, elt_ty) <- matchExpectedListTy res_ty
+       ; return (mkWpCastN coi, elt_ty, Nothing) }
+arithSeqEltType (Just fl) res_ty
+  = do { (elt_ty, fl')
+           <- tcSyntaxOp ListOrigin fl [SynList] res_ty $
+              \ [elt_ty] -> return elt_ty
+       ; return (idHsWrapper, elt_ty, Just fl') }
+
+{-
+************************************************************************
+*                                                                      *
+                Applications
+*                                                                      *
+************************************************************************
+-}
+
+-- HsArg is defined in HsTypes.hs
+
+wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn)
+           => LHsExpr (GhcPass id)
+           -> [HsArg (LHsExpr (GhcPass id)) (LHsWcType GhcRn)]
+           -> LHsExpr (GhcPass id)
+wrapHsArgs f []                     = f
+wrapHsArgs f (HsValArg  a : args)   = wrapHsArgs (mkHsApp f a)          args
+wrapHsArgs f (HsTypeArg _ t : args) = wrapHsArgs (mkHsAppType f t)      args
+wrapHsArgs f (HsArgPar sp : args)   = wrapHsArgs (L sp $ HsPar noExt f) args
+
+isHsValArg :: HsArg tm ty -> Bool
+isHsValArg (HsValArg {})  = True
+isHsValArg (HsTypeArg {}) = False
+isHsValArg (HsArgPar {})  = False
+
+isArgPar :: HsArg tm ty -> Bool
+isArgPar (HsArgPar {})  = True
+isArgPar (HsValArg {})  = False
+isArgPar (HsTypeArg {}) = False
+
+isArgPar_maybe :: HsArg a b -> Maybe (HsArg c d)
+isArgPar_maybe (HsArgPar sp) = Just $ HsArgPar sp
+isArgPar_maybe _ = Nothing
+
+type LHsExprArgIn  = HsArg (LHsExpr GhcRn)   (LHsWcType GhcRn)
+type LHsExprArgOut = HsArg (LHsExpr GhcTcId) (LHsWcType GhcRn)
+
+tcApp1 :: HsExpr GhcRn  -- either HsApp or HsAppType
+       -> ExpRhoType -> TcM (HsExpr GhcTcId)
+tcApp1 e res_ty
+  = do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty
+       ; return (mkHsWrap wrap $ unLoc $ wrapHsArgs fun args) }
+
+tcApp :: Maybe SDoc  -- like "The function `f' is applied to"
+                     -- or leave out to get exactly that message
+      -> LHsExpr GhcRn -> [LHsExprArgIn] -- Function and args
+      -> ExpRhoType -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
+           -- (wrap, fun, args). For an ordinary function application,
+           -- these should be assembled as (wrap (fun args)).
+           -- But OpApp is slightly different, so that's why the caller
+           -- must assemble
+
+tcApp m_herald (L sp (HsPar _ fun)) args res_ty
+  = tcApp m_herald fun (HsArgPar sp : args) res_ty
+
+tcApp m_herald (L _ (HsApp _ fun arg1)) args res_ty
+  = tcApp m_herald fun (HsValArg arg1 : args) res_ty
+
+tcApp m_herald (L _ (HsAppType _ fun ty1)) args res_ty
+  = tcApp m_herald fun (HsTypeArg noSrcSpan ty1 : args) res_ty
+
+tcApp m_herald fun@(L loc (HsRecFld _ fld_lbl)) args res_ty
+  | Ambiguous _ lbl        <- fld_lbl  -- Still ambiguous
+  , HsValArg (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first
+  , Just sig_ty     <- obviousSig arg  -- A type sig on the arg disambiguates
+  = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
+       ; sel_name  <- disambiguateSelector lbl sig_tc_ty
+       ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl)
+       ; tcFunApp m_herald fun (L loc tc_fun) fun_ty args res_ty }
+
+tcApp m_herald fun@(L loc (HsVar _ (L _ fun_id))) args res_ty
+  -- Special typing rule for tagToEnum#
+  | fun_id `hasKey` tagToEnumKey
+  , n_val_args == 1
+  = tcTagToEnum loc fun_id args res_ty
+
+  -- Special typing rule for 'seq'
+  -- In the saturated case, behave as if seq had type
+  --    forall a (b::TYPE r). a -> b -> b
+  -- for some type r.  See Note [Typing rule for seq]
+  | fun_id `hasKey` seqIdKey
+  , n_val_args == 2
+  = do { rep <- newFlexiTyVarTy runtimeRepTy
+       ; let [alpha, beta] = mkTemplateTyVars [liftedTypeKind, tYPE rep]
+             seq_ty = mkSpecForAllTys [alpha,beta]
+                      (mkTyVarTy alpha `mkFunTy` mkTyVarTy beta `mkFunTy` mkTyVarTy beta)
+             seq_fun = L loc (HsVar noExt (L loc seqId))
+             -- seq_ty = forall (a:*) (b:TYPE r). a -> b -> b
+             -- where 'r' is a meta type variable
+        ; tcFunApp m_herald fun seq_fun seq_ty args res_ty }
+  where
+    n_val_args = count isHsValArg args
+
+tcApp _ (L loc (ExplicitList _ Nothing [])) [HsTypeArg _ ty_arg] res_ty
+  -- See Note [Visible type application for the empty list constructor]
+  = do { ty_arg' <- tcHsTypeApp ty_arg liftedTypeKind
+       ; let list_ty = TyConApp listTyCon [ty_arg']
+       ; _ <- tcSubTypeDS (OccurrenceOf nilDataConName) GenSigCtxt
+                          list_ty res_ty
+       ; let expr :: LHsExpr GhcTcId
+             expr = L loc $ ExplicitList ty_arg' Nothing []
+       ; return (idHsWrapper, expr, []) }
+
+tcApp m_herald fun args res_ty
+  = do { (tc_fun, fun_ty) <- tcInferFun fun
+       ; tcFunApp m_herald fun tc_fun fun_ty args res_ty }
+
+---------------------
+tcFunApp :: Maybe SDoc  -- like "The function `f' is applied to"
+                        -- or leave out to get exactly that message
+         -> LHsExpr GhcRn                  -- Renamed function
+         -> LHsExpr GhcTcId -> TcSigmaType -- Function and its type
+         -> [LHsExprArgIn]                 -- Arguments
+         -> ExpRhoType                     -- Overall result type
+         -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
+            -- (wrapper-for-result, fun, args)
+            -- For an ordinary function application,
+            -- these should be assembled as wrap_res[ fun args ]
+            -- But OpApp is slightly different, so that's why the caller
+            -- must assemble
+
+-- tcFunApp deals with the general case;
+-- the special cases are handled by tcApp
+tcFunApp m_herald rn_fun tc_fun fun_sigma rn_args res_ty
+  = do { let orig = lexprCtOrigin rn_fun
+
+       ; traceTc "tcFunApp" (ppr rn_fun <+> dcolon <+> ppr fun_sigma $$ ppr rn_args $$ ppr res_ty)
+       ; (wrap_fun, tc_args, actual_res_ty)
+           <- tcArgs rn_fun fun_sigma orig rn_args
+                     (m_herald `orElse` mk_app_msg rn_fun rn_args)
+
+            -- this is just like tcWrapResult, but the types don't line
+            -- up to call that function
+       ; wrap_res <- addFunResCtxt True (unLoc rn_fun) actual_res_ty res_ty $
+                     tcSubTypeDS_NC_O orig GenSigCtxt
+                       (Just $ unLoc $ wrapHsArgs rn_fun rn_args)
+                       actual_res_ty res_ty
+
+       ; return (wrap_res, mkLHsWrap wrap_fun tc_fun, tc_args) }
+
+mk_app_msg :: LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc
+mk_app_msg fun args = sep [ text "The" <+> text what <+> quotes (ppr expr)
+                          , text "is applied to"]
+  where
+    what | null type_app_args = "function"
+         | otherwise          = "expression"
+    -- Include visible type arguments (but not other arguments) in the herald.
+    -- See Note [Herald for matchExpectedFunTys] in TcUnify.
+    expr = mkHsAppTypes fun type_app_args
+    type_app_args = [hs_ty | HsTypeArg _ hs_ty <- args]
+
+mk_op_msg :: LHsExpr GhcRn -> SDoc
+mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes"
+
+{-
+Note [Visible type application for the empty list constructor]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Getting the expression [] @Int to typecheck is slightly tricky since [] isn't
+an ordinary data constructor. By default, when tcExpr typechecks a list
+expression, it wraps the expression in a coercion, which gives it a type to the
+effect of p[a]. It isn't until later zonking that the type becomes
+forall a. [a], but that's too late for visible type application.
+
+The workaround is to check for empty list expressions that have a visible type
+argument in tcApp, and if so, directly typecheck [] @ty data constructor name.
+This avoids the intermediate coercion and produces an expression of type [ty],
+as one would intuitively expect.
+
+Unfortunately, this workaround isn't terribly robust, since more involved
+expressions such as (let in []) @Int won't work. Until a more elegant fix comes
+along, however, this at least allows direct type application on [] to work,
+which is better than before.
+-}
+
+----------------
+tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)
+-- Infer type of a function
+tcInferFun (L loc (HsVar _ (L _ name)))
+  = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
+               -- Don't wrap a context around a plain Id
+       ; return (L loc fun, ty) }
+
+tcInferFun (L loc (HsRecFld _ f))
+  = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f)
+               -- Don't wrap a context around a plain Id
+       ; return (L loc fun, ty) }
+
+tcInferFun fun
+  = tcInferSigma fun
+      -- NB: tcInferSigma; see TcUnify
+      -- Note [Deep instantiation of InferResult]
+
+
+----------------
+-- | Type-check the arguments to a function, possibly including visible type
+-- applications
+tcArgs :: LHsExpr GhcRn   -- ^ The function itself (for err msgs only)
+       -> TcSigmaType    -- ^ the (uninstantiated) type of the function
+       -> CtOrigin       -- ^ the origin for the function's type
+       -> [LHsExprArgIn] -- ^ the args
+       -> SDoc           -- ^ the herald for matchActualFunTys
+       -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
+          -- ^ (a wrapper for the function, the tc'd args, result type)
+tcArgs fun orig_fun_ty fun_orig orig_args herald
+  = go [] 1 orig_fun_ty orig_args
+  where
+    -- Don't count visible type arguments when determining how many arguments
+    -- an expression is given in an arity mismatch error, since visible type
+    -- arguments reported as a part of the expression herald itself.
+    -- See Note [Herald for matchExpectedFunTys] in TcUnify.
+    orig_expr_args_arity = count isHsValArg orig_args
+
+    go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty)
+
+    go acc_args n fun_ty (HsArgPar sp : args)
+      = do { (inner_wrap, args', res_ty) <- go acc_args n fun_ty args
+           ; return (inner_wrap, HsArgPar sp : args', res_ty)
+           }
+
+    go acc_args n fun_ty (HsTypeArg l hs_ty_arg : args)
+      = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty
+               -- wrap1 :: fun_ty "->" upsilon_ty
+           ; case tcSplitForAllTy_maybe upsilon_ty of
+               Just (tvb, inner_ty)
+                 | binderArgFlag tvb == Specified ->
+                   -- It really can't be Inferred, because we've justn
+                   -- instantiated those. But, oddly, it might just be Required.
+                   -- See Note [Required quantifiers in the type of a term]
+                 do { let tv   = binderVar tvb
+                          kind = tyVarKind tv
+                    ; ty_arg <- tcHsTypeApp hs_ty_arg kind
+
+                    ; inner_ty <- zonkTcType inner_ty
+                          -- See Note [Visible type application zonk]
+                    ; let in_scope  = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg])
+
+                          insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty
+                                      -- NB: tv and ty_arg have the same kind, so this
+                                      --     substitution is kind-respecting
+                    ; traceTc "VTA" (vcat [ppr tv, debugPprType kind
+                                          , debugPprType ty_arg
+                                          , debugPprType (tcTypeKind ty_arg)
+                                          , debugPprType inner_ty
+                                          , debugPprType insted_ty ])
+
+                    ; (inner_wrap, args', res_ty)
+                        <- go acc_args (n+1) insted_ty args
+                   -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty
+                    ; let inst_wrap = mkWpTyApps [ty_arg]
+                    ; return ( inner_wrap <.> inst_wrap <.> wrap1
+                             , HsTypeArg l hs_ty_arg : args'
+                             , res_ty ) }
+               _ -> ty_app_err upsilon_ty hs_ty_arg }
+
+    go acc_args n fun_ty (HsValArg arg : args)
+      = do { (wrap, [arg_ty], res_ty)
+               <- matchActualFunTysPart herald fun_orig (Just (unLoc fun)) 1 fun_ty
+                                        acc_args orig_expr_args_arity
+               -- wrap :: fun_ty "->" arg_ty -> res_ty
+           ; arg' <- tcArg fun arg arg_ty n
+           ; (inner_wrap, args', inner_res_ty)
+               <- go (arg_ty : acc_args) (n+1) res_ty args
+               -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty
+           ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty doc <.> wrap
+                    , HsValArg arg' : args'
+                    , inner_res_ty ) }
+      where
+        doc = text "When checking the" <+> speakNth n <+>
+              text "argument to" <+> quotes (ppr fun)
+
+    ty_app_err ty arg
+      = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty
+           ; failWith $
+               text "Cannot apply expression of type" <+> quotes (ppr ty) $$
+               text "to a visible type argument" <+> quotes (ppr arg) }
+
+{- Note [Required quantifiers in the type of a term]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #15859)
+
+  data A k :: k -> Type      -- A      :: forall k -> k -> Type
+  type KindOf (a :: k) = k   -- KindOf :: forall k. k -> Type
+  a = (undefind :: KindOf A) @Int
+
+With ImpredicativeTypes (thin ice, I know), we instantiate
+KindOf at type (forall k -> k -> Type), so
+  KindOf A = forall k -> k -> Type
+whose first argument is Required
+
+We want to reject this type application to Int, but in earlier
+GHCs we had an ASSERT that Required could not occur here.
+
+The ice is thin; c.f. Note [No Required TyCoBinder in terms]
+in TyCoRep.
+
+Note [Visible type application zonk]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg).
+
+* tcHsTypeApp only guarantees that
+    - ty_arg is zonked
+    - kind(zonk(tv)) = kind(ty_arg)
+  (checkExpectedKind zonks as it goes).
+
+So we must zonk inner_ty as well, to guarantee consistency between zonk(tv)
+and inner_ty.  Otherwise we can build an ill-kinded type.  An example was
+Trac #14158, where we had:
+   id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a
+and we had the visible type application
+  id @(->)
+
+* We instantiated k := kappa, yielding
+    forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a
+* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *).
+* That instantiated (->) as ((->) q1 q1), and unified kappa := q1,
+  Here q1 :: RuntimeRep
+* Now we substitute
+     cat  :->  (->) q1 q1 :: TYPE q1 -> TYPE q1 -> *
+  but we must first zonk the inner_ty to get
+      forall (a :: TYPE q1). cat a a
+  so that the result of substitution is well-kinded
+  Failing to do so led to Trac #14158.
+-}
+
+----------------
+tcArg :: LHsExpr GhcRn                   -- The function (for error messages)
+      -> LHsExpr GhcRn                   -- Actual arguments
+      -> TcRhoType                       -- expected arg type
+      -> Int                             -- # of argument
+      -> TcM (LHsExpr GhcTcId)           -- Resulting argument
+tcArg fun arg ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $
+                          tcPolyExprNC arg ty
+
+----------------
+tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTcId]
+tcTupArgs args tys
+  = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
+  where
+    go (L l (Missing {}),   arg_ty) = return (L l (Missing arg_ty))
+    go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
+                                           ; return (L l (Present x expr')) }
+    go (L _ (XTupArg{}), _) = panic "tcTupArgs"
+
+---------------------------
+-- See TcType.SyntaxOpType also for commentary
+tcSyntaxOp :: CtOrigin
+           -> SyntaxExpr GhcRn
+           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments
+           -> ExpRhoType               -- ^ overall result type
+           -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments
+           -> TcM (a, SyntaxExpr GhcTcId)
+-- ^ Typecheck a syntax operator
+-- The operator is a variable or a lambda at this stage (i.e. renamer
+-- output)
+tcSyntaxOp orig expr arg_tys res_ty
+  = tcSyntaxOpGen orig expr arg_tys (SynType res_ty)
+
+-- | Slightly more general version of 'tcSyntaxOp' that allows the caller
+-- to specify the shape of the result of the syntax operator
+tcSyntaxOpGen :: CtOrigin
+              -> SyntaxExpr GhcRn
+              -> [SyntaxOpType]
+              -> SyntaxOpType
+              -> ([TcSigmaType] -> TcM a)
+              -> TcM (a, SyntaxExpr GhcTcId)
+tcSyntaxOpGen orig op arg_tys res_ty thing_inside
+  = do { (expr, sigma) <- tcInferSigma $ noLoc $ syn_expr op
+       ; (result, expr_wrap, arg_wraps, res_wrap)
+           <- tcSynArgA orig sigma arg_tys res_ty $
+              thing_inside
+       ; return (result, SyntaxExpr { syn_expr = mkHsWrap expr_wrap $ unLoc expr
+                                    , syn_arg_wraps = arg_wraps
+                                    , syn_res_wrap  = res_wrap }) }
+
+{-
+Note [tcSynArg]
+~~~~~~~~~~~~~~~
+Because of the rich structure of SyntaxOpType, we must do the
+contra-/covariant thing when working down arrows, to get the
+instantiation vs. skolemisation decisions correct (and, more
+obviously, the orientation of the HsWrappers). We thus have
+two tcSynArgs.
+-}
+
+-- works on "expected" types, skolemising where necessary
+-- See Note [tcSynArg]
+tcSynArgE :: CtOrigin
+          -> TcSigmaType
+          -> SyntaxOpType                -- ^ shape it is expected to have
+          -> ([TcSigmaType] -> TcM a)    -- ^ check the arguments
+          -> TcM (a, HsWrapper)
+           -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
+tcSynArgE orig sigma_ty syn_ty thing_inside
+  = do { (skol_wrap, (result, ty_wrapper))
+           <- tcSkolemise GenSigCtxt sigma_ty $ \ _ rho_ty ->
+              go rho_ty syn_ty
+       ; return (result, skol_wrap <.> ty_wrapper) }
+    where
+    go rho_ty SynAny
+      = do { result <- thing_inside [rho_ty]
+           ; return (result, idHsWrapper) }
+
+    go rho_ty SynRho   -- same as SynAny, because we skolemise eagerly
+      = do { result <- thing_inside [rho_ty]
+           ; return (result, idHsWrapper) }
+
+    go rho_ty SynList
+      = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty
+           ; result <- thing_inside [elt_ty]
+           ; return (result, mkWpCastN list_co) }
+
+    go rho_ty (SynFun arg_shape res_shape)
+      = do { ( ( ( (result, arg_ty, res_ty)
+                 , res_wrapper )                   -- :: res_ty_out "->" res_ty
+               , arg_wrapper1, [], arg_wrapper2 )  -- :: arg_ty "->" arg_ty_out
+             , match_wrapper )         -- :: (arg_ty -> res_ty) "->" rho_ty
+               <- matchExpectedFunTys herald 1 (mkCheckExpType rho_ty) $
+                  \ [arg_ty] res_ty ->
+                  do { arg_tc_ty <- expTypeToType arg_ty
+                     ; res_tc_ty <- expTypeToType res_ty
+
+                         -- another nested arrow is too much for now,
+                         -- but I bet we'll never need this
+                     ; MASSERT2( case arg_shape of
+                                   SynFun {} -> False;
+                                   _         -> True
+                               , text "Too many nested arrows in SyntaxOpType" $$
+                                 pprCtOrigin orig )
+
+                     ; tcSynArgA orig arg_tc_ty [] arg_shape $
+                       \ arg_results ->
+                       tcSynArgE orig res_tc_ty res_shape $
+                       \ res_results ->
+                       do { result <- thing_inside (arg_results ++ res_results)
+                          ; return (result, arg_tc_ty, res_tc_ty) }}
+
+           ; return ( result
+                    , match_wrapper <.>
+                      mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper
+                              arg_ty res_ty doc ) }
+      where
+        herald = text "This rebindable syntax expects a function with"
+        doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig
+
+    go rho_ty (SynType the_ty)
+      = do { wrap   <- tcSubTypeET orig GenSigCtxt the_ty rho_ty
+           ; result <- thing_inside []
+           ; return (result, wrap) }
+
+-- works on "actual" types, instantiating where necessary
+-- See Note [tcSynArg]
+tcSynArgA :: CtOrigin
+          -> TcSigmaType
+          -> [SyntaxOpType]              -- ^ argument shapes
+          -> SyntaxOpType                -- ^ result shape
+          -> ([TcSigmaType] -> TcM a)    -- ^ check the arguments
+          -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
+            -- ^ returns a wrapper to be applied to the original function,
+            -- wrappers to be applied to arguments
+            -- and a wrapper to be applied to the overall expression
+tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside
+  = do { (match_wrapper, arg_tys, res_ty)
+           <- matchActualFunTys herald orig Nothing (length arg_shapes) sigma_ty
+              -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
+       ; ((result, res_wrapper), arg_wrappers)
+           <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results ->
+              tc_syn_arg    res_ty  res_shape  $ \ res_results ->
+              thing_inside (arg_results ++ res_results)
+       ; return (result, match_wrapper, arg_wrappers, res_wrapper) }
+  where
+    herald = text "This rebindable syntax expects a function with"
+
+    tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]
+                  -> ([TcSigmaType] -> TcM a)
+                  -> TcM (a, [HsWrapper])
+                    -- the wrappers are for arguments
+    tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside
+      = do { ((result, arg_wraps), arg_wrap)
+               <- tcSynArgE     orig arg_ty  arg_shape  $ \ arg1_results ->
+                  tc_syn_args_e      arg_tys arg_shapes $ \ args_results ->
+                  thing_inside (arg1_results ++ args_results)
+           ; return (result, arg_wrap : arg_wraps) }
+    tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside []
+
+    tc_syn_arg :: TcSigmaType -> SyntaxOpType
+               -> ([TcSigmaType] -> TcM a)
+               -> TcM (a, HsWrapper)
+                  -- the wrapper applies to the overall result
+    tc_syn_arg res_ty SynAny thing_inside
+      = do { result <- thing_inside [res_ty]
+           ; return (result, idHsWrapper) }
+    tc_syn_arg res_ty SynRho thing_inside
+      = do { (inst_wrap, rho_ty) <- deeplyInstantiate orig res_ty
+               -- inst_wrap :: res_ty "->" rho_ty
+           ; result <- thing_inside [rho_ty]
+           ; return (result, inst_wrap) }
+    tc_syn_arg res_ty SynList thing_inside
+      = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
+               -- inst_wrap :: res_ty "->" rho_ty
+           ; (list_co, elt_ty)   <- matchExpectedListTy rho_ty
+               -- list_co :: [elt_ty] ~N rho_ty
+           ; result <- thing_inside [elt_ty]
+           ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) }
+    tc_syn_arg _ (SynFun {}) _
+      = pprPanic "tcSynArgA hits a SynFun" (ppr orig)
+    tc_syn_arg res_ty (SynType the_ty) thing_inside
+      = do { wrap   <- tcSubTypeO orig GenSigCtxt res_ty the_ty
+           ; result <- thing_inside []
+           ; return (result, wrap) }
+
+{-
+Note [Push result type in]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unify with expected result before type-checking the args so that the
+info from res_ty percolates to args.  This is when we might detect a
+too-few args situation.  (One can think of cases when the opposite
+order would give a better error message.)
+experimenting with putting this first.
+
+Here's an example where it actually makes a real difference
+
+   class C t a b | t a -> b
+   instance C Char a Bool
+
+   data P t a = forall b. (C t a b) => MkP b
+   data Q t   = MkQ (forall a. P t a)
+
+   f1, f2 :: Q Char;
+   f1 = MkQ (MkP True)
+   f2 = MkQ (MkP True :: forall a. P Char a)
+
+With the change, f1 will type-check, because the 'Char' info from
+the signature is propagated into MkQ's argument. With the check
+in the other order, the extra signature in f2 is reqd.
+
+************************************************************************
+*                                                                      *
+                Expressions with a type signature
+                        expr :: type
+*                                                                      *
+********************************************************************* -}
+
+tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTcId, TcType)
+tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })
+  = setSrcSpan loc $   -- Sets the location for the implication constraint
+    do { (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id
+       ; given <- newEvVars theta
+       ; traceTc "tcExprSig: CompleteSig" $
+         vcat [ text "poly_id:" <+> ppr poly_id <+> dcolon <+> ppr (idType poly_id)
+              , text "tv_prs:" <+> ppr tv_prs ]
+
+       ; let skol_info = SigSkol ExprSigCtxt (idType poly_id) tv_prs
+             skol_tvs  = map snd tv_prs
+       ; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $
+                              tcExtendNameTyVarEnv tv_prs $
+                              tcPolyExprNC expr tau
+
+       ; let poly_wrap = mkWpTyLams   skol_tvs
+                         <.> mkWpLams given
+                         <.> mkWpLet  ev_binds
+       ; return (mkLHsWrap poly_wrap expr', idType poly_id) }
+
+tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })
+  = setSrcSpan loc $   -- Sets the location for the implication constraint
+    do { (tclvl, wanted, (expr', sig_inst))
+             <- pushLevelAndCaptureConstraints  $
+                do { sig_inst <- tcInstSig sig
+                   ; expr' <- tcExtendNameTyVarEnv (sig_inst_skols sig_inst) $
+                              tcExtendNameTyVarEnv (sig_inst_wcs   sig_inst) $
+                              tcPolyExprNC expr (sig_inst_tau sig_inst)
+                   ; return (expr', sig_inst) }
+       -- See Note [Partial expression signatures]
+       ; let tau = sig_inst_tau sig_inst
+             infer_mode | null (sig_inst_theta sig_inst)
+                        , isNothing (sig_inst_wcx sig_inst)
+                        = ApplyMR
+                        | otherwise
+                        = NoRestrictions
+       ; (qtvs, givens, ev_binds, residual, _)
+                 <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted
+       ; emitConstraints residual
+
+       ; tau <- zonkTcType tau
+       ; let inferred_theta = map evVarPred givens
+             tau_tvs        = tyCoVarsOfType tau
+       ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta
+                                   tau_tvs qtvs (Just sig_inst)
+       ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau
+             my_sigma       = mkForAllTys binders (mkPhiTy  my_theta tau)
+       ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis.
+                 then return idHsWrapper  -- Fast path; also avoids complaint when we infer
+                                          -- an ambiguous type and have AllowAmbiguousType
+                                          -- e..g infer  x :: forall a. F a -> Int
+                 else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma
+
+       ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)
+       ; let poly_wrap = wrap
+                         <.> mkWpTyLams qtvs
+                         <.> mkWpLams givens
+                         <.> mkWpLet  ev_binds
+       ; return (mkLHsWrap poly_wrap expr', my_sigma) }
+
+
+{- Note [Partial expression signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Partial type signatures on expressions are easy to get wrong.  But
+here is a guiding principile
+    e :: ty
+should behave like
+    let x :: ty
+        x = e
+    in x
+
+So for partial signatures we apply the MR if no context is given.  So
+   e :: IO _          apply the MR
+   e :: _ => IO _     do not apply the MR
+just like in TcBinds.decideGeneralisationPlan
+
+This makes a difference (Trac #11670):
+   peek :: Ptr a -> IO CLong
+   peek ptr = peekElemOff undefined 0 :: _
+from (peekElemOff undefined 0) we get
+          type: IO w
+   constraints: Storable w
+
+We must NOT try to generalise over 'w' because the signature specifies
+no constraints so we'll complain about not being able to solve
+Storable w.  Instead, don't generalise; then _ gets instantiated to
+CLong, as it should.
+-}
+
+{- *********************************************************************
+*                                                                      *
+                 tcInferId
+*                                                                      *
+********************************************************************* -}
+
+tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId)
+tcCheckId name res_ty
+  = do { (expr, actual_res_ty) <- tcInferId name
+       ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
+       ; addFunResCtxt False (HsVar noExt (noLoc name)) actual_res_ty res_ty $
+         tcWrapResultO (OccurrenceOf name) (HsVar noExt (noLoc name)) expr
+                                                          actual_res_ty res_ty }
+
+tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
+tcCheckRecSelId rn_expr f@(Unambiguous _ (L _ lbl)) res_ty
+  = do { (expr, actual_res_ty) <- tcInferRecSelId f
+       ; addFunResCtxt False (HsRecFld noExt f) actual_res_ty res_ty $
+         tcWrapResultO (OccurrenceOfRecSel lbl) rn_expr expr actual_res_ty res_ty }
+tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty
+  = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of
+      Nothing       -> ambiguousSelector lbl
+      Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg
+                          ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl)
+                                                    res_ty }
+tcCheckRecSelId _ (XAmbiguousFieldOcc _) _ = panic "tcCheckRecSelId"
+
+------------------------
+tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType)
+tcInferRecSelId (Unambiguous sel (L _ lbl))
+  = do { (expr', ty) <- tc_infer_id lbl sel
+       ; return (expr', ty) }
+tcInferRecSelId (Ambiguous _ lbl)
+  = ambiguousSelector lbl
+tcInferRecSelId (XAmbiguousFieldOcc _) = panic "tcInferRecSelId"
+
+------------------------
+tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
+-- Look up an occurrence of an Id
+-- Do not instantiate its type
+tcInferId id_name
+  | id_name `hasKey` tagToEnumKey
+  = failWithTc (text "tagToEnum# must appear applied to one argument")
+        -- tcApp catches the case (tagToEnum# arg)
+
+  | id_name `hasKey` assertIdKey
+  = do { dflags <- getDynFlags
+       ; if gopt Opt_IgnoreAsserts dflags
+         then tc_infer_id (nameRdrName id_name) id_name
+         else tc_infer_assert id_name }
+
+  | otherwise
+  = do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name
+       ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)
+       ; return (expr, ty) }
+
+tc_infer_assert :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)
+-- Deal with an occurrence of 'assert'
+-- See Note [Adding the implicit parameter to 'assert']
+tc_infer_assert assert_name
+  = do { assert_error_id <- tcLookupId assertErrorName
+       ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
+                                          (idType assert_error_id)
+       ; return (mkHsWrap wrap (HsVar noExt (noLoc assert_error_id)), id_rho)
+       }
+
+tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)
+tc_infer_id lbl id_name
+ = do { thing <- tcLookup id_name
+      ; case thing of
+             ATcId { tct_id = id }
+               -> do { check_naughty id        -- Note [Local record selectors]
+                     ; checkThLocalId id
+                     ; return_id id }
+
+             AGlobal (AnId id)
+               -> do { check_naughty id
+                     ; return_id id }
+                    -- A global cannot possibly be ill-staged
+                    -- nor does it need the 'lifting' treatment
+                    -- hence no checkTh stuff here
+
+             AGlobal (AConLike cl) -> case cl of
+                 RealDataCon con -> return_data_con con
+                 PatSynCon ps    -> tcPatSynBuilderOcc ps
+
+             _ -> failWithTc $
+                  ppr thing <+> text "used where a value identifier was expected" }
+  where
+    return_id id = return (HsVar noExt (noLoc id), idType id)
+
+    return_data_con con
+       -- For data constructors, must perform the stupid-theta check
+      | null stupid_theta
+      = return (HsConLikeOut noExt (RealDataCon con), con_ty)
+
+      | otherwise
+       -- See Note [Instantiating stupid theta]
+      = do { let (tvs, theta, rho) = tcSplitSigmaTy con_ty
+           ; (subst, tvs') <- newMetaTyVars tvs
+           ; let tys'   = mkTyVarTys tvs'
+                 theta' = substTheta subst theta
+                 rho'   = substTy subst rho
+           ; wrap <- instCall (OccurrenceOf id_name) tys' theta'
+           ; addDataConStupidTheta con tys'
+           ; return ( mkHsWrap wrap (HsConLikeOut noExt (RealDataCon con))
+                    , rho') }
+
+      where
+        con_ty         = dataConUserType con
+        stupid_theta   = dataConStupidTheta con
+
+    check_naughty id
+      | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)
+      | otherwise                  = return ()
+
+
+tcUnboundId :: HsExpr GhcRn -> UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId)
+-- Typecheck an occurrence of an unbound Id
+--
+-- Some of these started life as a true expression hole "_".
+-- Others might simply be variables that accidentally have no binding site
+--
+-- We turn all of them into HsVar, since HsUnboundVar can't contain an
+-- Id; and indeed the evidence for the CHoleCan does bind it, so it's
+-- not unbound any more!
+tcUnboundId rn_expr unbound res_ty
+ = do { ty <- newOpenFlexiTyVarTy  -- Allow Int# etc (Trac #12531)
+      ; let occ = unboundVarOcc unbound
+      ; name <- newSysName occ
+      ; let ev = mkLocalId name ty
+      ; can <- newHoleCt (ExprHole unbound) ev ty
+      ; emitInsoluble can
+      ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar noExt (noLoc ev))
+                                                                     ty res_ty }
+
+
+{-
+Note [Adding the implicit parameter to 'assert']
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The typechecker transforms (assert e1 e2) to (assertError e1 e2).
+This isn't really the Right Thing because there's no way to "undo"
+if you want to see the original source code in the typechecker
+output.  We'll have fix this in due course, when we care more about
+being able to reconstruct the exact original program.
+
+Note [tagToEnum#]
+~~~~~~~~~~~~~~~~~
+Nasty check to ensure that tagToEnum# is applied to a type that is an
+enumeration TyCon.  Unification may refine the type later, but this
+check won't see that, alas.  It's crude, because it relies on our
+knowing *now* that the type is ok, which in turn relies on the
+eager-unification part of the type checker pushing enough information
+here.  In theory the Right Thing to do is to have a new form of
+constraint but I definitely cannot face that!  And it works ok as-is.
+
+Here's are two cases that should fail
+        f :: forall a. a
+        f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
+
+        g :: Int
+        g = tagToEnum# 0        -- Int is not an enumeration
+
+When data type families are involved it's a bit more complicated.
+     data family F a
+     data instance F [Int] = A | B | C
+Then we want to generate something like
+     tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
+Usually that coercion is hidden inside the wrappers for
+constructors of F [Int] but here we have to do it explicitly.
+
+It's all grotesquely complicated.
+
+Note [Instantiating stupid theta]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Normally, when we infer the type of an Id, we don't instantiate,
+because we wish to allow for visible type application later on.
+But if a datacon has a stupid theta, we're a bit stuck. We need
+to emit the stupid theta constraints with instantiated types. It's
+difficult to defer this to the lazy instantiation, because a stupid
+theta has no spot to put it in a type. So we just instantiate eagerly
+in this case. Thus, users cannot use visible type application with
+a data constructor sporting a stupid theta. I won't feel so bad for
+the users that complain.
+
+-}
+
+tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType
+            -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])
+-- tagToEnum# :: forall a. Int# -> a
+-- See Note [tagToEnum#]   Urgh!
+tcTagToEnum loc fun_name args res_ty
+  = do { fun <- tcLookupId fun_name
+
+       ; let pars1 = mapMaybe isArgPar_maybe before
+             pars2 = mapMaybe isArgPar_maybe after
+             -- args contains exactly one HsValArg
+             (before, _:after) = break isHsValArg args
+
+       ; arg <- case filterOut isArgPar args of
+           [HsTypeArg _ hs_ty_arg, HsValArg term_arg]
+             -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind
+                   ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg res_ty
+                     -- other than influencing res_ty, we just
+                     -- don't care about a type arg passed in.
+                     -- So drop the evidence.
+                   ; return term_arg }
+           [HsValArg term_arg] -> do { _ <- expTypeToType res_ty
+                                     ; return term_arg }
+           _          -> too_many_args "tagToEnum#" args
+
+       ; res_ty <- readExpType res_ty
+       ; ty'    <- zonkTcType res_ty
+
+       -- Check that the type is algebraic
+       ; let mb_tc_app = tcSplitTyConApp_maybe ty'
+             Just (tc, tc_args) = mb_tc_app
+       ; checkTc (isJust mb_tc_app)
+                 (mk_error ty' doc1)
+
+       -- Look through any type family
+       ; fam_envs <- tcGetFamInstEnvs
+       ; let (rep_tc, rep_args, coi)
+               = tcLookupDataFamInst fam_envs tc tc_args
+            -- coi :: tc tc_args ~R rep_tc rep_args
+
+       ; checkTc (isEnumerationTyCon rep_tc)
+                 (mk_error ty' doc2)
+
+       ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy)
+       ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExt (L loc fun)))
+             rep_ty = mkTyConApp rep_tc rep_args
+             out_args = concat
+              [ pars1
+              , [HsValArg arg']
+              , pars2
+              ]
+
+       ; return (mkWpCastR (mkTcSymCo coi), fun', out_args) }
+                 -- coi is a Representational coercion
+  where
+    doc1 = vcat [ text "Specify the type by giving a type signature"
+                , text "e.g. (tagToEnum# x) :: Bool" ]
+    doc2 = text "Result type must be an enumeration type"
+
+    mk_error :: TcType -> SDoc -> SDoc
+    mk_error ty what
+      = hang (text "Bad call to tagToEnum#"
+               <+> text "at type" <+> ppr ty)
+           2 what
+
+too_many_args :: String -> [LHsExprArgIn] -> TcM a
+too_many_args fun args
+  = failWith $
+    hang (text "Too many type arguments to" <+> text fun <> colon)
+       2 (sep (map pp args))
+  where
+    pp (HsValArg e)                             = ppr e
+    pp (HsTypeArg _ (HsWC { hswc_body = L _ t })) = pprHsType t
+    pp (HsTypeArg _ (XHsWildCardBndrs _)) = panic "too_many_args"
+    pp (HsArgPar _) = empty
+
+
+{-
+************************************************************************
+*                                                                      *
+                 Template Haskell checks
+*                                                                      *
+************************************************************************
+-}
+
+checkThLocalId :: Id -> TcM ()
+checkThLocalId id
+  = do  { mb_local_use <- getStageAndBindLevel (idName id)
+        ; case mb_local_use of
+             Just (top_lvl, bind_lvl, use_stage)
+                | thLevel use_stage > bind_lvl
+                -> checkCrossStageLifting top_lvl id use_stage
+             _  -> return ()   -- Not a locally-bound thing, or
+                               -- no cross-stage link
+    }
+
+--------------------------------------
+checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
+-- If we are inside typed brackets, and (use_lvl > bind_lvl)
+-- we must check whether there's a cross-stage lift to do
+-- Examples   \x -> [|| x ||]
+--            [|| map ||]
+-- There is no error-checking to do, because the renamer did that
+--
+-- This is similar to checkCrossStageLifting in RnSplice, but
+-- this code is applied to *typed* brackets.
+
+checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var))
+  | isTopLevel top_lvl
+  = when (isExternalName id_name) (keepAlive id_name)
+    -- See Note [Keeping things alive for Template Haskell] in RnSplice
+
+  | otherwise
+  =     -- Nested identifiers, such as 'x' in
+        -- E.g. \x -> [|| h x ||]
+        -- We must behave as if the reference to x was
+        --      h $(lift x)
+        -- We use 'x' itself as the splice proxy, used by
+        -- the desugarer to stitch it all back together.
+        -- If 'x' occurs many times we may get many identical
+        -- bindings of the same splice proxy, but that doesn't
+        -- matter, although it's a mite untidy.
+    do  { let id_ty = idType id
+        ; checkTc (isTauTy id_ty) (polySpliceErr id)
+               -- If x is polymorphic, its occurrence sites might
+               -- have different instantiations, so we can't use plain
+               -- 'x' as the splice proxy name.  I don't know how to
+               -- solve this, and it's probably unimportant, so I'm
+               -- just going to flag an error for now
+
+        ; lift <- if isStringTy id_ty then
+                     do { sid <- tcLookupId THNames.liftStringName
+                                     -- See Note [Lifting strings]
+                        ; return (HsVar noExt (noLoc sid)) }
+                  else
+                     setConstraintVar lie_var   $
+                          -- Put the 'lift' constraint into the right LIE
+                     newMethodFromName (OccurrenceOf id_name)
+                                       THNames.liftName id_ty
+
+                   -- Update the pending splices
+        ; ps <- readMutVar ps_var
+        ; let pending_splice = PendingTcSplice id_name
+                                 (nlHsApp (noLoc lift) (nlHsVar id))
+        ; writeMutVar ps_var (pending_splice : ps)
+
+        ; return () }
+  where
+    id_name = idName id
+
+checkCrossStageLifting _ _ _ = return ()
+
+polySpliceErr :: Id -> SDoc
+polySpliceErr id
+  = text "Can't splice the polymorphic local variable" <+> quotes (ppr id)
+
+{-
+Note [Lifting strings]
+~~~~~~~~~~~~~~~~~~~~~~
+If we see $(... [| s |] ...) where s::String, we don't want to
+generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
+So this conditional short-circuits the lifting mechanism to generate
+(liftString "xy") in that case.  I didn't want to use overlapping instances
+for the Lift class in TH.Syntax, because that can lead to overlapping-instance
+errors in a polymorphic situation.
+
+If this check fails (which isn't impossible) we get another chance; see
+Note [Converting strings] in Convert.hs
+
+Local record selectors
+~~~~~~~~~~~~~~~~~~~~~~
+Record selectors for TyCons in this module are ordinary local bindings,
+which show up as ATcIds rather than AGlobals.  So we need to check for
+naughtiness in both branches.  c.f. TcTyClsBindings.mkAuxBinds.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Record bindings}
+*                                                                      *
+************************************************************************
+-}
+
+getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet
+-- These tyvars must not change across the updates
+getFixedTyVars upd_fld_occs univ_tvs cons
+      = mkVarSet [tv1 | con <- cons
+                      , let (u_tvs, _, eqspec, prov_theta
+                             , req_theta, arg_tys, _)
+                              = conLikeFullSig con
+                            theta = eqSpecPreds eqspec
+                                     ++ prov_theta
+                                     ++ req_theta
+                            flds = conLikeFieldLabels con
+                            fixed_tvs = exactTyCoVarsOfTypes fixed_tys
+                                    -- fixed_tys: See Note [Type of a record update]
+                                        `unionVarSet` tyCoVarsOfTypes theta
+                                    -- Universally-quantified tyvars that
+                                    -- appear in any of the *implicit*
+                                    -- arguments to the constructor are fixed
+                                    -- See Note [Implicit type sharing]
+
+                            fixed_tys = [ty | (fl, ty) <- zip flds arg_tys
+                                            , not (flLabel fl `elem` upd_fld_occs)]
+                      , (tv1,tv) <- univ_tvs `zip` u_tvs
+                      , tv `elemVarSet` fixed_tvs ]
+
+{-
+Note [Disambiguating record fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the -XDuplicateRecordFields extension is used, and the renamer
+encounters a record selector or update that it cannot immediately
+disambiguate (because it involves fields that belong to multiple
+datatypes), it will defer resolution of the ambiguity to the
+typechecker.  In this case, the `Ambiguous` constructor of
+`AmbiguousFieldOcc` is used.
+
+Consider the following definitions:
+
+        data S = MkS { foo :: Int }
+        data T = MkT { foo :: Int, bar :: Int }
+        data U = MkU { bar :: Int, baz :: Int }
+
+When the renamer sees `foo` as a selector or an update, it will not
+know which parent datatype is in use.
+
+For selectors, there are two possible ways to disambiguate:
+
+1. Check if the pushed-in type is a function whose domain is a
+   datatype, for example:
+
+       f s = (foo :: S -> Int) s
+
+       g :: T -> Int
+       g = foo
+
+    This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.
+
+2. Check if the selector is applied to an argument that has a type
+   signature, for example:
+
+       h = foo (s :: S)
+
+    This is checked by `tcApp`.
+
+
+Updates are slightly more complex.  The `disambiguateRecordBinds`
+function tries to determine the parent datatype in three ways:
+
+1. Check for types that have all the fields being updated. For example:
+
+        f x = x { foo = 3, bar = 2 }
+
+   Here `f` must be updating `T` because neither `S` nor `U` have
+   both fields. This may also discover that no possible type exists.
+   For example the following will be rejected:
+
+        f' x = x { foo = 3, baz = 3 }
+
+2. Use the type being pushed in, if it is already a TyConApp. The
+   following are valid updates to `T`:
+
+        g :: T -> T
+        g x = x { foo = 3 }
+
+        g' x = x { foo = 3 } :: T
+
+3. Use the type signature of the record expression, if it exists and
+   is a TyConApp. Thus this is valid update to `T`:
+
+        h x = (x :: T) { foo = 3 }
+
+
+Note that we do not look up the types of variables being updated, and
+no constraint-solving is performed, so for example the following will
+be rejected as ambiguous:
+
+     let bad (s :: S) = foo s
+
+     let r :: T
+         r = blah
+     in r { foo = 3 }
+
+     \r. (r { foo = 3 },  r :: T )
+
+We could add further tests, of a more heuristic nature. For example,
+rather than looking for an explicit signature, we could try to infer
+the type of the argument to a selector or the record expression being
+updated, in case we are lucky enough to get a TyConApp straight
+away. However, it might be hard for programmers to predict whether a
+particular update is sufficiently obvious for the signature to be
+omitted. Moreover, this might change the behaviour of typechecker in
+non-obvious ways.
+
+See also Note [HsRecField and HsRecUpdField] in HsPat.
+-}
+
+-- Given a RdrName that refers to multiple record fields, and the type
+-- of its argument, try to determine the name of the selector that is
+-- meant.
+disambiguateSelector :: Located RdrName -> Type -> TcM Name
+disambiguateSelector lr@(L _ rdr) parent_type
+ = do { fam_inst_envs <- tcGetFamInstEnvs
+      ; case tyConOf fam_inst_envs parent_type of
+          Nothing -> ambiguousSelector lr
+          Just p  ->
+            do { xs <- lookupParents rdr
+               ; let parent = RecSelData p
+               ; case lookup parent xs of
+                   Just gre -> do { addUsedGRE True gre
+                                  ; return (gre_name gre) }
+                   Nothing  -> failWithTc (fieldNotInType parent rdr) } }
+
+-- This field name really is ambiguous, so add a suitable "ambiguous
+-- occurrence" error, then give up.
+ambiguousSelector :: Located RdrName -> TcM a
+ambiguousSelector (L _ rdr)
+  = do { env <- getGlobalRdrEnv
+       ; let gres = lookupGRE_RdrName rdr env
+       ; setErrCtxt [] $ addNameClashErrRn rdr gres
+       ; failM }
+
+-- Disambiguate the fields in a record update.
+-- See Note [Disambiguating record fields]
+disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType
+                 -> [LHsRecUpdField GhcRn] -> ExpRhoType
+                 -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
+disambiguateRecordBinds record_expr record_rho rbnds res_ty
+    -- Are all the fields unambiguous?
+  = case mapM isUnambiguous rbnds of
+                     -- If so, just skip to looking up the Ids
+                     -- Always the case if DuplicateRecordFields is off
+      Just rbnds' -> mapM lookupSelector rbnds'
+      Nothing     -> -- If not, try to identify a single parent
+        do { fam_inst_envs <- tcGetFamInstEnvs
+             -- Look up the possible parents for each field
+           ; rbnds_with_parents <- getUpdFieldsParents
+           ; let possible_parents = map (map fst . snd) rbnds_with_parents
+             -- Identify a single parent
+           ; p <- identifyParent fam_inst_envs possible_parents
+             -- Pick the right selector with that parent for each field
+           ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }
+  where
+    -- Extract the selector name of a field update if it is unambiguous
+    isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)
+    isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of
+                        Unambiguous sel_name _ -> Just (x, sel_name)
+                        Ambiguous{}            -> Nothing
+                        XAmbiguousFieldOcc{}   -> Nothing
+
+    -- Look up the possible parents and selector GREs for each field
+    getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn
+                                , [(RecSelParent, GlobalRdrElt)])]
+    getUpdFieldsParents
+      = fmap (zip rbnds) $ mapM
+          (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc)
+          rbnds
+
+    -- Given a the lists of possible parents for each field,
+    -- identify a single parent
+    identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
+    identifyParent fam_inst_envs possible_parents
+      = case foldr1 intersect possible_parents of
+        -- No parents for all fields: record update is ill-typed
+        []  -> failWithTc (noPossibleParents rbnds)
+
+        -- Exactly one datatype with all the fields: use that
+        [p] -> return p
+
+        -- Multiple possible parents: try harder to disambiguate
+        -- Can we get a parent TyCon from the pushed-in type?
+        _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p)
+
+        -- Does the expression being updated have a type signature?
+        -- If so, try to extract a parent TyCon from it
+            | Just {} <- obviousSig (unLoc record_expr)
+            , Just tc <- tyConOf fam_inst_envs record_rho
+            -> return (RecSelData tc)
+
+        -- Nothing else we can try...
+        _ -> failWithTc badOverloadedUpdate
+
+    -- Make a field unambiguous by choosing the given parent.
+    -- Emits an error if the field cannot have that parent,
+    -- e.g. if the user writes
+    --     r { x = e } :: T
+    -- where T does not have field x.
+    pickParent :: RecSelParent
+               -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
+               -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
+    pickParent p (upd, xs)
+      = case lookup p xs of
+                      -- Phew! The parent is valid for this field.
+                      -- Previously ambiguous fields must be marked as
+                      -- used now that we know which one is meant, but
+                      -- unambiguous ones shouldn't be recorded again
+                      -- (giving duplicate deprecation warnings).
+          Just gre -> do { unless (null (tail xs)) $ do
+                             let L loc _ = hsRecFieldLbl (unLoc upd)
+                             setSrcSpan loc $ addUsedGRE True gre
+                         ; lookupSelector (upd, gre_name gre) }
+                      -- The field doesn't belong to this parent, so report
+                      -- an error but keep going through all the fields
+          Nothing  -> do { addErrTc (fieldNotInType p
+                                      (unLoc (hsRecUpdFieldRdr (unLoc upd))))
+                         ; lookupSelector (upd, gre_name (snd (head xs))) }
+
+    -- Given a (field update, selector name) pair, look up the
+    -- selector to give a field update with an unambiguous Id
+    lookupSelector :: (LHsRecUpdField GhcRn, Name)
+                 -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
+    lookupSelector (L l upd, n)
+      = do { i <- tcLookupId n
+           ; let L loc af = hsRecFieldLbl upd
+                 lbl      = rdrNameAmbiguousFieldOcc af
+           ; return $ L l upd { hsRecFieldLbl
+                                  = L loc (Unambiguous i (L loc lbl)) } }
+
+
+-- Extract the outermost TyCon of a type, if there is one; for
+-- data families this is the representation tycon (because that's
+-- where the fields live).
+tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
+tyConOf fam_inst_envs ty0
+  = case tcSplitTyConApp_maybe ty of
+      Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
+      Nothing        -> Nothing
+  where
+    (_, _, ty) = tcSplitSigmaTy ty0
+
+-- Variant of tyConOf that works for ExpTypes
+tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
+tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0
+
+-- For an ambiguous record field, find all the candidate record
+-- selectors (as GlobalRdrElts) and their parents.
+lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
+lookupParents rdr
+  = do { env <- getGlobalRdrEnv
+       ; let gres = lookupGRE_RdrName rdr env
+       ; mapM lookupParent gres }
+  where
+    lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
+    lookupParent gre = do { id <- tcLookupId (gre_name gre)
+                          ; if isRecordSelector id
+                              then return (recordSelectorTyCon id, gre)
+                              else failWithTc (notSelector (gre_name gre)) }
+
+-- A type signature on the argument of an ambiguous record selector or
+-- the record expression in an update must be "obvious", i.e. the
+-- outermost constructor ignoring parentheses.
+obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
+obviousSig (ExprWithTySig _ _ ty) = Just ty
+obviousSig (HsPar _ p)          = obviousSig (unLoc p)
+obviousSig _                    = Nothing
+
+
+{-
+Game plan for record bindings
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+1. Find the TyCon for the bindings, from the first field label.
+
+2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
+
+For each binding field = value
+
+3. Instantiate the field type (from the field label) using the type
+   envt from step 2.
+
+4  Type check the value using tcArg, passing the field type as
+   the expected argument type.
+
+This extends OK when the field types are universally quantified.
+-}
+
+tcRecordBinds
+        :: ConLike
+        -> [TcType]     -- Expected type for each field
+        -> HsRecordBinds GhcRn
+        -> TcM (HsRecordBinds GhcTcId)
+
+tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)
+  = do  { mb_binds <- mapM do_bind rbinds
+        ; return (HsRecFields (catMaybes mb_binds) dd) }
+  where
+    fields = map flSelector $ conLikeFieldLabels con_like
+    flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys
+
+    do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
+            -> TcM (Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId)))
+    do_bind (L l fld@(HsRecField { hsRecFieldLbl = f
+                                 , hsRecFieldArg = rhs }))
+
+      = do { mb <- tcRecordField con_like flds_w_tys f rhs
+           ; case mb of
+               Nothing         -> return Nothing
+               Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'
+                                                          , hsRecFieldArg = rhs' }))) }
+
+tcRecordUpd
+        :: ConLike
+        -> [TcType]     -- Expected type for each field
+        -> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
+        -> TcM [LHsRecUpdField GhcTcId]
+
+tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
+  where
+    fields = map flSelector $ conLikeFieldLabels con_like
+    flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys
+
+    do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
+            -> TcM (Maybe (LHsRecUpdField GhcTcId))
+    do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af
+                                 , hsRecFieldArg = rhs }))
+      = do { let lbl = rdrNameAmbiguousFieldOcc af
+                 sel_id = selectorAmbiguousFieldOcc af
+                 f = L loc (FieldOcc (idName sel_id) (L loc lbl))
+           ; mb <- tcRecordField con_like flds_w_tys f rhs
+           ; case mb of
+               Nothing         -> return Nothing
+               Just (f', rhs') ->
+                 return (Just
+                         (L l (fld { hsRecFieldLbl
+                                      = L loc (Unambiguous
+                                               (extFieldOcc (unLoc f'))
+                                               (L loc lbl))
+                                   , hsRecFieldArg = rhs' }))) }
+
+tcRecordField :: ConLike -> Assoc Name Type
+              -> LFieldOcc GhcRn -> LHsExpr GhcRn
+              -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
+tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
+  | Just field_ty <- assocMaybe flds_w_tys sel_name
+      = addErrCtxt (fieldCtxt field_lbl) $
+        do { rhs' <- tcPolyExprNC rhs field_ty
+           ; let field_id = mkUserLocal (nameOccName sel_name)
+                                        (nameUnique sel_name)
+                                        field_ty loc
+                -- Yuk: the field_id has the *unique* of the selector Id
+                --          (so we can find it easily)
+                --      but is a LocalId with the appropriate type of the RHS
+                --          (so the desugarer knows the type of local binder to make)
+           ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }
+      | otherwise
+      = do { addErrTc (badFieldCon con_like field_lbl)
+           ; return Nothing }
+  where
+        field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
+tcRecordField _ _ (L _ (XFieldOcc _)) _ = panic "tcRecordField"
+
+
+checkMissingFields ::  ConLike -> HsRecordBinds GhcRn -> TcM ()
+checkMissingFields con_like rbinds
+  | null field_labels   -- Not declared as a record;
+                        -- But C{} is still valid if no strict fields
+  = if any isBanged field_strs then
+        -- Illegal if any arg is strict
+        addErrTc (missingStrictFields con_like [])
+    else do
+        warn <- woptM Opt_WarnMissingFields
+        when (warn && notNull field_strs && null field_labels)
+             (warnTc (Reason Opt_WarnMissingFields) True
+                 (missingFields con_like []))
+
+  | otherwise = do              -- A record
+    unless (null missing_s_fields)
+           (addErrTc (missingStrictFields con_like missing_s_fields))
+
+    warn <- woptM Opt_WarnMissingFields
+    when (warn && notNull missing_ns_fields)
+         (warnTc (Reason Opt_WarnMissingFields) True
+             (missingFields con_like missing_ns_fields))
+
+  where
+    missing_s_fields
+        = [ flLabel fl | (fl, str) <- field_info,
+                 isBanged str,
+                 not (fl `elemField` field_names_used)
+          ]
+    missing_ns_fields
+        = [ flLabel fl | (fl, str) <- field_info,
+                 not (isBanged str),
+                 not (fl `elemField` field_names_used)
+          ]
+
+    field_names_used = hsRecFields rbinds
+    field_labels     = conLikeFieldLabels con_like
+
+    field_info = zipEqual "missingFields"
+                          field_labels
+                          field_strs
+
+    field_strs = conLikeImplBangs con_like
+
+    fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Errors and contexts}
+*                                                                      *
+************************************************************************
+
+Boring and alphabetical:
+-}
+
+addExprErrCtxt :: LHsExpr GhcRn -> TcM a -> TcM a
+addExprErrCtxt expr = addErrCtxt (exprCtxt expr)
+
+exprCtxt :: LHsExpr GhcRn -> SDoc
+exprCtxt expr
+  = hang (text "In the expression:") 2 (ppr expr)
+
+fieldCtxt :: FieldLabelString -> SDoc
+fieldCtxt field_name
+  = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
+
+addFunResCtxt :: Bool  -- There is at least one argument
+              -> HsExpr GhcRn -> TcType -> ExpRhoType
+              -> TcM a -> TcM a
+-- When we have a mis-match in the return type of a function
+-- try to give a helpful message about too many/few arguments
+--
+-- Used for naked variables too; but with has_args = False
+addFunResCtxt has_args fun fun_res_ty env_ty
+  = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg)
+      -- NB: use a landmark error context, so that an empty context
+      -- doesn't suppress some more useful context
+  where
+    mk_msg
+      = do { mb_env_ty <- readExpType_maybe env_ty
+                     -- by the time the message is rendered, the ExpType
+                     -- will be filled in (except if we're debugging)
+           ; fun_res' <- zonkTcType fun_res_ty
+           ; env'     <- case mb_env_ty of
+                           Just env_ty -> zonkTcType env_ty
+                           Nothing     ->
+                             do { dumping <- doptM Opt_D_dump_tc_trace
+                                ; MASSERT( dumping )
+                                ; newFlexiTyVarTy liftedTypeKind }
+           ; let -- See Note [Splitting nested sigma types in mismatched
+                 --           function types]
+                 (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res'
+                 -- No need to call tcSplitNestedSigmaTys here, since env_ty is
+                 -- an ExpRhoTy, i.e., it's already deeply instantiated.
+                 (_, _, env_tau) = tcSplitSigmaTy env'
+                 (args_fun, res_fun) = tcSplitFunTys fun_tau
+                 (args_env, res_env) = tcSplitFunTys env_tau
+                 n_fun = length args_fun
+                 n_env = length args_env
+                 info  | n_fun == n_env = Outputable.empty
+                       | n_fun > n_env
+                       , not_fun res_env
+                       = text "Probable cause:" <+> quotes (ppr fun)
+                         <+> text "is applied to too few arguments"
+
+                       | has_args
+                       , not_fun res_fun
+                       = text "Possible cause:" <+> quotes (ppr fun)
+                         <+> text "is applied to too many arguments"
+
+                       | otherwise
+                       = Outputable.empty  -- Never suggest that a naked variable is                                         -- applied to too many args!
+           ; return info }
+      where
+        not_fun ty   -- ty is definitely not an arrow type,
+                     -- and cannot conceivably become one
+          = case tcSplitTyConApp_maybe ty of
+              Just (tc, _) -> isAlgTyCon tc
+              Nothing      -> False
+
+{-
+Note [Splitting nested sigma types in mismatched function types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When one applies a function to too few arguments, GHC tries to determine this
+fact if possible so that it may give a helpful error message. It accomplishes
+this by checking if the type of the applied function has more argument types
+than supplied arguments.
+
+Previously, GHC computed the number of argument types through tcSplitSigmaTy.
+This is incorrect in the face of nested foralls, however! This caused Trac
+#13311, for instance:
+
+  f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b
+
+If one uses `f` like so:
+
+  do { f; putChar 'a' }
+
+Then tcSplitSigmaTy will decompose the type of `f` into:
+
+  Tyvars: [a]
+  Context: (Monoid a)
+  Argument types: []
+  Return type: forall b. Monoid b => Maybe a -> Maybe b
+
+That is, it will conclude that there are *no* argument types, and since `f`
+was given no arguments, it won't print a helpful error message. On the other
+hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to:
+
+  Tyvars: [a, b]
+  Context: (Monoid a, Monoid b)
+  Argument types: [Maybe a]
+  Return type: Maybe b
+
+So now GHC recognizes that `f` has one more argument type than it was actually
+provided.
+-}
+
+badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
+badFieldTypes prs
+  = hang (text "Record update for insufficiently polymorphic field"
+                         <> plural prs <> colon)
+       2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
+
+badFieldsUpd
+  :: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
+               -- Field names that don't belong to a single datacon
+  -> [ConLike] -- Data cons of the type which the first field name belongs to
+  -> SDoc
+badFieldsUpd rbinds data_cons
+  = hang (text "No constructor has all these fields:")
+       2 (pprQuotedList conflictingFields)
+          -- See Note [Finding the conflicting fields]
+  where
+    -- A (preferably small) set of fields such that no constructor contains
+    -- all of them.  See Note [Finding the conflicting fields]
+    conflictingFields = case nonMembers of
+        -- nonMember belongs to a different type.
+        (nonMember, _) : _ -> [aMember, nonMember]
+        [] -> let
+            -- All of rbinds belong to one type. In this case, repeatedly add
+            -- a field to the set until no constructor contains the set.
+
+            -- Each field, together with a list indicating which constructors
+            -- have all the fields so far.
+            growingSets :: [(FieldLabelString, [Bool])]
+            growingSets = scanl1 combine membership
+            combine (_, setMem) (field, fldMem)
+              = (field, zipWith (&&) setMem fldMem)
+            in
+            -- Fields that don't change the membership status of the set
+            -- are redundant and can be dropped.
+            map (fst . head) $ groupBy ((==) `on` snd) growingSets
+
+    aMember = ASSERT( not (null members) ) fst (head members)
+    (members, nonMembers) = partition (or . snd) membership
+
+    -- For each field, which constructors contain the field?
+    membership :: [(FieldLabelString, [Bool])]
+    membership = sortMembership $
+        map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $
+          map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds
+
+    fieldLabelSets :: [Set.Set FieldLabelString]
+    fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons
+
+    -- Sort in order of increasing number of True, so that a smaller
+    -- conflicting set can be found.
+    sortMembership =
+      map snd .
+      sortBy (compare `on` fst) .
+      map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))
+
+    countTrue = count id
+
+{-
+Note [Finding the conflicting fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+  data A = A {a0, a1 :: Int}
+         | B {b0, b1 :: Int}
+and we see a record update
+  x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }
+Then we'd like to find the smallest subset of fields that no
+constructor has all of.  Here, say, {a0,b0}, or {a0,b1}, etc.
+We don't really want to report that no constructor has all of
+{a0,a1,b0,b1}, because when there are hundreds of fields it's
+hard to see what was really wrong.
+
+We may need more than two fields, though; eg
+  data T = A { x,y :: Int, v::Int }
+          | B { y,z :: Int, v::Int }
+          | C { z,x :: Int, v::Int }
+with update
+   r { x=e1, y=e2, z=e3 }, we
+
+Finding the smallest subset is hard, so the code here makes
+a decent stab, no more.  See Trac #7989.
+-}
+
+naughtyRecordSel :: RdrName -> SDoc
+naughtyRecordSel sel_id
+  = text "Cannot use record selector" <+> quotes (ppr sel_id) <+>
+    text "as a function due to escaped type variables" $$
+    text "Probable fix: use pattern-matching syntax instead"
+
+notSelector :: Name -> SDoc
+notSelector field
+  = hsep [quotes (ppr field), text "is not a record selector"]
+
+mixedSelectors :: [Id] -> [Id] -> SDoc
+mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)
+  = ptext
+      (sLit "Cannot use a mixture of pattern synonym and record selectors") $$
+    text "Record selectors defined by"
+      <+> quotes (ppr (tyConName rep_dc))
+      <> text ":"
+      <+> pprWithCommas ppr data_sels $$
+    text "Pattern synonym selectors defined by"
+      <+> quotes (ppr (patSynName rep_ps))
+      <> text ":"
+      <+> pprWithCommas ppr pat_syn_sels
+  where
+    RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id
+    RecSelData rep_dc = recordSelectorTyCon dc_rep_id
+mixedSelectors _ _ = panic "TcExpr: mixedSelectors emptylists"
+
+
+missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc
+missingStrictFields con fields
+  = header <> rest
+  where
+    rest | null fields = Outputable.empty  -- Happens for non-record constructors
+                                           -- with strict fields
+         | otherwise   = colon <+> pprWithCommas ppr fields
+
+    header = text "Constructor" <+> quotes (ppr con) <+>
+             text "does not have the required strict field(s)"
+
+missingFields :: ConLike -> [FieldLabelString] -> SDoc
+missingFields con fields
+  = header <> rest
+  where
+    rest | null fields = Outputable.empty
+         | otherwise = colon <+> pprWithCommas ppr fields
+    header = text "Fields of" <+> quotes (ppr con) <+>
+             text "not initialised"
+
+-- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args))
+
+noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc
+noPossibleParents rbinds
+  = hang (text "No type has all these fields:")
+       2 (pprQuotedList fields)
+  where
+    fields = map (hsRecFieldLbl . unLoc) rbinds
+
+badOverloadedUpdate :: SDoc
+badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature"
+
+fieldNotInType :: RecSelParent -> RdrName -> SDoc
+fieldNotInType p rdr
+  = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Static Pointers}
+*                                                                      *
+************************************************************************
+-}
+
+-- | A data type to describe why a variable is not closed.
+data NotClosedReason = NotLetBoundReason
+                     | NotTypeClosed VarSet
+                     | NotClosed Name NotClosedReason
+
+-- | Checks if the given name is closed and emits an error if not.
+--
+-- See Note [Not-closed error messages].
+checkClosedInStaticForm :: Name -> TcM ()
+checkClosedInStaticForm name = do
+    type_env <- getLclTypeEnv
+    case checkClosed type_env name of
+      Nothing -> return ()
+      Just reason -> addErrTc $ explain name reason
+  where
+    -- See Note [Checking closedness].
+    checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
+    checkClosed type_env n = checkLoop type_env (unitNameSet n) n
+
+    checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
+    checkLoop type_env visited n = do
+      -- The @visited@ set is an accumulating parameter that contains the set of
+      -- visited nodes, so we avoid repeating cycles in the traversal.
+      case lookupNameEnv type_env n of
+        Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of
+          ClosedLet   -> Nothing
+          NotLetBound -> Just NotLetBoundReason
+          NonClosedLet fvs type_closed -> listToMaybe $
+            -- Look for a non-closed variable in fvs
+            [ NotClosed n' reason
+            | n' <- nameSetElemsStable fvs
+            , not (elemNameSet n' visited)
+            , Just reason <- [checkLoop type_env (extendNameSet visited n') n']
+            ] ++
+            if type_closed then
+              []
+            else
+              -- We consider non-let-bound variables easier to figure out than
+              -- non-closed types, so we report non-closed types to the user
+              -- only if we cannot spot the former.
+              [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ]
+        -- The binding is closed.
+        _ -> Nothing
+
+    -- Converts a reason into a human-readable sentence.
+    --
+    -- @explain name reason@ starts with
+    --
+    -- "<name> is used in a static form but it is not closed because it"
+    --
+    -- and then follows a list of causes. For each id in the path, the text
+    --
+    -- "uses <id> which"
+    --
+    -- is appended, yielding something like
+    --
+    -- "uses <id> which uses <id1> which uses <id2> which"
+    --
+    -- until the end of the path is reached, which is reported as either
+    --
+    -- "is not let-bound"
+    --
+    -- when the final node is not let-bound, or
+    --
+    -- "has a non-closed type because it contains the type variables:
+    -- v1, v2, v3"
+    --
+    -- when the final node has a non-closed type.
+    --
+    explain :: Name -> NotClosedReason -> SDoc
+    explain name reason =
+      quotes (ppr name) <+> text "is used in a static form but it is not closed"
+                        <+> text "because it"
+                        $$
+                        sep (causes reason)
+
+    causes :: NotClosedReason -> [SDoc]
+    causes NotLetBoundReason = [text "is not let-bound."]
+    causes (NotTypeClosed vs) =
+      [ text "has a non-closed type because it contains the"
+      , text "type variables:" <+>
+        pprVarSet vs (hsep . punctuate comma . map (quotes . ppr))
+      ]
+    causes (NotClosed n reason) =
+      let msg = text "uses" <+> quotes (ppr n) <+> text "which"
+       in case reason of
+            NotClosed _ _ -> msg : causes reason
+            _   -> let (xs0, xs1) = splitAt 1 $ causes reason
+                    in fmap (msg <+>) xs0 ++ xs1
+
+-- Note [Not-closed error messages]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- When variables in a static form are not closed, we go through the trouble
+-- of explaining why they aren't.
+--
+-- Thus, the following program
+--
+-- > {-# LANGUAGE StaticPointers #-}
+-- > module M where
+-- >
+-- > f x = static g
+-- >   where
+-- >     g = h
+-- >     h = x
+--
+-- produces the error
+--
+--    'g' is used in a static form but it is not closed because it
+--    uses 'h' which uses 'x' which is not let-bound.
+--
+-- And a program like
+--
+-- > {-# LANGUAGE StaticPointers #-}
+-- > module M where
+-- >
+-- > import Data.Typeable
+-- > import GHC.StaticPtr
+-- >
+-- > f :: Typeable a => a -> StaticPtr TypeRep
+-- > f x = const (static (g undefined)) (h x)
+-- >   where
+-- >     g = h
+-- >     h = typeOf
+--
+-- produces the error
+--
+--    'g' is used in a static form but it is not closed because it
+--    uses 'h' which has a non-closed type because it contains the
+--    type variables: 'a'
+--
+
+-- Note [Checking closedness]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- @checkClosed@ checks if a binding is closed and returns a reason if it is
+-- not.
+--
+-- The bindings define a graph where the nodes are ids, and there is an edge
+-- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free
+-- variables.
+--
+-- When @n@ is not closed, it has to exist in the graph some node reachable
+-- from @n@ that it is not a let-bound variable or that it has a non-closed
+-- type. Thus, the "reason" is a path from @n@ to this offending node.
+--
+-- When @n@ is not closed, we traverse the graph reachable from @n@ to build
+-- the reason.
+--
diff --git a/compiler/typecheck/TcExpr.hs-boot b/compiler/typecheck/TcExpr.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcExpr.hs-boot
@@ -0,0 +1,41 @@
+module TcExpr where
+import Name
+import HsSyn    ( HsExpr, LHsExpr, SyntaxExpr )
+import TcType   ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType )
+import TcRnTypes( TcM, CtOrigin )
+import HsExtension ( GhcRn, GhcTcId )
+
+tcPolyExpr ::
+          LHsExpr GhcRn
+       -> TcSigmaType
+       -> TcM (LHsExpr GhcTcId)
+
+tcMonoExpr, tcMonoExprNC ::
+          LHsExpr GhcRn
+       -> ExpRhoType
+       -> TcM (LHsExpr GhcTcId)
+
+tcInferSigma, tcInferSigmaNC ::
+          LHsExpr GhcRn
+       -> TcM (LHsExpr GhcTcId, TcSigmaType)
+
+tcInferRho ::
+          LHsExpr GhcRn
+       -> TcM (LHsExpr GhcTcId, TcRhoType)
+
+tcSyntaxOp :: CtOrigin
+           -> SyntaxExpr GhcRn
+           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments
+           -> ExpType                  -- ^ overall result type
+           -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments
+           -> TcM (a, SyntaxExpr GhcTcId)
+
+tcSyntaxOpGen :: CtOrigin
+              -> SyntaxExpr GhcRn
+              -> [SyntaxOpType]
+              -> SyntaxOpType
+              -> ([TcSigmaType] -> TcM a)
+              -> TcM (a, SyntaxExpr GhcTcId)
+
+
+tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId)
diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcFlatten.hs
@@ -0,0 +1,1890 @@
+{-# LANGUAGE CPP, ViewPatterns, BangPatterns #-}
+
+module TcFlatten(
+   FlattenMode(..),
+   flatten, flattenKind, flattenArgsNom,
+
+   unflattenWanteds
+ ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnTypes
+import TcType
+import Type
+import TcEvidence
+import TyCon
+import TyCoRep   -- performs delicate algorithm on types
+import Coercion
+import Var
+import VarSet
+import VarEnv
+import Outputable
+import TcSMonad as TcS
+import BasicTypes( SwapFlag(..) )
+
+import Util
+import Bag
+import Control.Monad
+import MonadUtils    ( zipWith3M )
+
+import Control.Arrow ( first )
+
+{-
+Note [The flattening story]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* A CFunEqCan is either of form
+     [G] <F xis> : F xis ~ fsk   -- fsk is a FlatSkolTv
+     [W]       x : F xis ~ fmv   -- fmv is a FlatMetaTv
+  where
+     x is the witness variable
+     xis are function-free
+     fsk/fmv is a flatten skolem;
+        it is always untouchable (level 0)
+
+* CFunEqCans can have any flavour: [G], [W], [WD] or [D]
+
+* KEY INSIGHTS:
+
+   - A given flatten-skolem, fsk, is known a-priori to be equal to
+     F xis (the LHS), with <F xis> evidence.  The fsk is still a
+     unification variable, but it is "owned" by its CFunEqCan, and
+     is filled in (unflattened) only by unflattenGivens.
+
+   - A unification flatten-skolem, fmv, stands for the as-yet-unknown
+     type to which (F xis) will eventually reduce.  It is filled in
+
+
+   - All fsk/fmv variables are "untouchable".  To make it simple to test,
+     we simply give them TcLevel=0.  This means that in a CTyVarEq, say,
+       fmv ~ Int
+     we NEVER unify fmv.
+
+   - A unification flatten-skolem, fmv, ONLY gets unified when either
+       a) The CFunEqCan takes a step, using an axiom
+       b) By unflattenWanteds
+    They are never unified in any other form of equality.
+    For example [W] ffmv ~ Int  is stuck; it does not unify with fmv.
+
+* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan.
+  That would destroy the invariant about the shape of a CFunEqCan,
+  and it would risk wanted/wanted interactions. The only way we
+  learn information about fsk is when the CFunEqCan takes a step.
+
+  However we *do* substitute in the LHS of a CFunEqCan (else it
+  would never get to fire!)
+
+* Unflattening:
+   - We unflatten Givens when leaving their scope (see unflattenGivens)
+   - We unflatten Wanteds at the end of each attempt to simplify the
+     wanteds; see unflattenWanteds, called from solveSimpleWanteds.
+
+* Ownership of fsk/fmv.  Each canonical [G], [W], or [WD]
+       CFunEqCan x : F xis ~ fsk/fmv
+  "owns" a distinct evidence variable x, and flatten-skolem fsk/fmv.
+  Why? We make a fresh fsk/fmv when the constraint is born;
+  and we never rewrite the RHS of a CFunEqCan.
+
+  In contrast a [D] CFunEqCan /shares/ its fmv with its partner [W],
+  but does not "own" it.  If we reduce a [D] F Int ~ fmv, where
+  say type instance F Int = ty, then we don't discharge fmv := ty.
+  Rather we simply generate [D] fmv ~ ty (in TcInteract.reduce_top_fun_eq,
+  and dischargeFmv)
+
+* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2
+                       then xis1 /= xis2
+  i.e. at most one CFunEqCan with a particular LHS
+
+* Function applications can occur in the RHS of a CTyEqCan.  No reason
+  not allow this, and it reduces the amount of flattening that must occur.
+
+* Flattening a type (F xis):
+    - If we are flattening in a Wanted/Derived constraint
+      then create new [W] x : F xis ~ fmv
+      else create new [G] x : F xis ~ fsk
+      with fresh evidence variable x and flatten-skolem fsk/fmv
+
+    - Add it to the work list
+
+    - Replace (F xis) with fsk/fmv in the type you are flattening
+
+    - You can also add the CFunEqCan to the "flat cache", which
+      simply keeps track of all the function applications you
+      have flattened.
+
+    - If (F xis) is in the cache already, just
+      use its fsk/fmv and evidence x, and emit nothing.
+
+    - No need to substitute in the flat-cache. It's not the end
+      of the world if we start with, say (F alpha ~ fmv1) and
+      (F Int ~ fmv2) and then find alpha := Int.  Athat will
+      simply give rise to fmv1 := fmv2 via [Interacting rule] below
+
+* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv
+    - Flatten xis (to substitute any tyvars; there are already no functions)
+                  cos :: xis ~ flat_xis
+    - New wanted  x2 :: F flat_xis ~ fsk/fmv
+    - Add new wanted to flat cache
+    - Discharge x = F cos ; x2
+
+* [Interacting rule]
+    (inert)     [W] x1 : F tys ~ fmv1
+    (work item) [W] x2 : F tys ~ fmv2
+  Just solve one from the other:
+    x2 := x1
+    fmv2 := fmv1
+  This just unites the two fsks into one.
+  Always solve given from wanted if poss.
+
+* For top-level reductions, see Note [Top-level reductions for type functions]
+  in TcInteract
+
+
+Why given-fsks, alone, doesn't work
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Could we get away with only flatten meta-tyvars, with no flatten-skolems? No.
+
+  [W] w : alpha ~ [F alpha Int]
+
+---> flatten
+  w = ...w'...
+  [W] w' : alpha ~ [fsk]
+  [G] <F alpha Int> : F alpha Int ~ fsk
+
+--> unify (no occurs check)
+  alpha := [fsk]
+
+But since fsk = F alpha Int, this is really an occurs check error.  If
+that is all we know about alpha, we will succeed in constraint
+solving, producing a program with an infinite type.
+
+Even if we did finally get (g : fsk ~ Bool) by solving (F alpha Int ~ fsk)
+using axiom, zonking would not see it, so (x::alpha) sitting in the
+tree will get zonked to an infinite type.  (Zonking always only does
+refl stuff.)
+
+Why flatten-meta-vars, alone doesn't work
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Look at Simple13, with unification-fmvs only
+
+  [G] g : a ~ [F a]
+
+---> Flatten given
+  g' = g;[x]
+  [G] g'  : a ~ [fmv]
+  [W] x : F a ~ fmv
+
+--> subst a in x
+  g' = g;[x]
+  x = F g' ; x2
+  [W] x2 : F [fmv] ~ fmv
+
+And now we have an evidence cycle between g' and x!
+
+If we used a given instead (ie current story)
+
+  [G] g : a ~ [F a]
+
+---> Flatten given
+  g' = g;[x]
+  [G] g'  : a ~ [fsk]
+  [G] <F a> : F a ~ fsk
+
+---> Substitute for a
+  [G] g'  : a ~ [fsk]
+  [G] F (sym g'); <F a> : F [fsk] ~ fsk
+
+
+Why is it right to treat fmv's differently to ordinary unification vars?
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  f :: forall a. a -> a -> Bool
+  g :: F Int -> F Int -> Bool
+
+Consider
+  f (x:Int) (y:Bool)
+This gives alpha~Int, alpha~Bool.  There is an inconsistency,
+but really only one error.  SherLoc may tell you which location
+is most likely, based on other occurrences of alpha.
+
+Consider
+  g (x:Int) (y:Bool)
+Here we get (F Int ~ Int, F Int ~ Bool), which flattens to
+  (fmv ~ Int, fmv ~ Bool)
+But there are really TWO separate errors.
+
+  ** We must not complain about Int~Bool. **
+
+Moreover these two errors could arise in entirely unrelated parts of
+the code.  (In the alpha case, there must be *some* connection (eg
+v:alpha in common envt).)
+
+Note [Unflattening can force the solver to iterate]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Look at Trac #10340:
+   type family Any :: *   -- No instances
+   get :: MonadState s m => m s
+   instance MonadState s (State s) where ...
+
+   foo :: State Any Any
+   foo = get
+
+For 'foo' we instantiate 'get' at types mm ss
+   [WD] MonadState ss mm, [WD] mm ss ~ State Any Any
+Flatten, and decompose
+   [WD] MonadState ss mm, [WD] Any ~ fmv
+   [WD] mm ~ State fmv, [WD] fmv ~ ss
+Unify mm := State fmv:
+   [WD] MonadState ss (State fmv)
+   [WD] Any ~ fmv, [WD] fmv ~ ss
+Now we are stuck; the instance does not match!!  So unflatten:
+   fmv := Any
+   ss := Any    (*)
+   [WD] MonadState Any (State Any)
+
+The unification (*) represents progress, so we must do a second
+round of solving; this time it succeeds. This is done by the 'go'
+loop in solveSimpleWanteds.
+
+This story does not feel right but it's the best I can do; and the
+iteration only happens in pretty obscure circumstances.
+
+
+************************************************************************
+*                                                                      *
+*                  Examples
+     Here is a long series of examples I had to work through
+*                                                                      *
+************************************************************************
+
+Simple20
+~~~~~~~~
+axiom F [a] = [F a]
+
+ [G] F [a] ~ a
+-->
+ [G] fsk ~ a
+ [G] [F a] ~ fsk  (nc)
+-->
+ [G] F a ~ fsk2
+ [G] fsk ~ [fsk2]
+ [G] fsk ~ a
+-->
+ [G] F a ~ fsk2
+ [G] a ~ [fsk2]
+ [G] fsk ~ a
+
+----------------------------------------
+indexed-types/should_compile/T44984
+
+  [W] H (F Bool) ~ H alpha
+  [W] alpha ~ F Bool
+-->
+  F Bool  ~ fmv0
+  H fmv0  ~ fmv1
+  H alpha ~ fmv2
+
+  fmv1 ~ fmv2
+  fmv0 ~ alpha
+
+flatten
+~~~~~~~
+  fmv0  := F Bool
+  fmv1  := H (F Bool)
+  fmv2  := H alpha
+  alpha := F Bool
+plus
+  fmv1 ~ fmv2
+
+But these two are equal under the above assumptions.
+Solve by Refl.
+
+
+--- under plan B, namely solve fmv1:=fmv2 eagerly ---
+  [W] H (F Bool) ~ H alpha
+  [W] alpha ~ F Bool
+-->
+  F Bool  ~ fmv0
+  H fmv0  ~ fmv1
+  H alpha ~ fmv2
+
+  fmv1 ~ fmv2
+  fmv0 ~ alpha
+-->
+  F Bool  ~ fmv0
+  H fmv0  ~ fmv1
+  H alpha ~ fmv2    fmv2 := fmv1
+
+  fmv0 ~ alpha
+
+flatten
+  fmv0 := F Bool
+  fmv1 := H fmv0 = H (F Bool)
+  retain   H alpha ~ fmv2
+    because fmv2 has been filled
+  alpha := F Bool
+
+
+----------------------------
+indexed-types/should_failt/T4179
+
+after solving
+  [W] fmv_1 ~ fmv_2
+  [W] A3 (FCon x)           ~ fmv_1    (CFunEqCan)
+  [W] A3 (x (aoa -> fmv_2)) ~ fmv_2    (CFunEqCan)
+
+----------------------------------------
+indexed-types/should_fail/T7729a
+
+a)  [W]   BasePrimMonad (Rand m) ~ m1
+b)  [W]   tt m1 ~ BasePrimMonad (Rand m)
+
+--->  process (b) first
+    BasePrimMonad (Ramd m) ~ fmv_atH
+    fmv_atH ~ tt m1
+
+--->  now process (a)
+    m1 ~ s_atH ~ tt m1    -- An obscure occurs check
+
+
+----------------------------------------
+typecheck/TcTypeNatSimple
+
+Original constraint
+  [W] x + y ~ x + alpha  (non-canonical)
+==>
+  [W] x + y     ~ fmv1   (CFunEqCan)
+  [W] x + alpha ~ fmv2   (CFuneqCan)
+  [W] fmv1 ~ fmv2        (CTyEqCan)
+
+(sigh)
+
+----------------------------------------
+indexed-types/should_fail/GADTwrong1
+
+  [G] Const a ~ ()
+==> flatten
+  [G] fsk ~ ()
+  work item: Const a ~ fsk
+==> fire top rule
+  [G] fsk ~ ()
+  work item fsk ~ ()
+
+Surely the work item should rewrite to () ~ ()?  Well, maybe not;
+it'a very special case.  More generally, our givens look like
+F a ~ Int, where (F a) is not reducible.
+
+
+----------------------------------------
+indexed_types/should_fail/T8227:
+
+Why using a different can-rewrite rule in CFunEqCan heads
+does not work.
+
+Assuming NOT rewriting wanteds with wanteds
+
+   Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk
+          [W] fmv_aBk ~ fsk_aBh
+
+          [G] Scalar fsk_aBg ~ fsk_aBh
+          [G] V a ~ f_aBg
+
+   Worklist includes  [W] Scalar fmv_aBi ~ fmv_aBk
+   fmv_aBi, fmv_aBk are flatten unification variables
+
+   Work item: [W] V fsk_aBh ~ fmv_aBi
+
+Note that the inert wanteds are cyclic, because we do not rewrite
+wanteds with wanteds.
+
+
+Then we go into a loop when normalise the work-item, because we
+use rewriteOrSame on the argument of V.
+
+Conclusion: Don't make canRewrite context specific; instead use
+[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable.
+
+
+----------------------------------------
+
+Here is a somewhat similar case:
+
+   type family G a :: *
+
+   blah :: (G a ~ Bool, Eq (G a)) => a -> a
+   blah = error "urk"
+
+   foo x = blah x
+
+For foo we get
+   [W] Eq (G a), G a ~ Bool
+Flattening
+   [W] G a ~ fmv, Eq fmv, fmv ~ Bool
+We can't simplify away the Eq Bool unless we substitute for fmv.
+Maybe that doesn't matter: we would still be left with unsolved
+G a ~ Bool.
+
+--------------------------
+Trac #9318 has a very simple program leading to
+
+  [W] F Int ~ Int
+  [W] F Int ~ Bool
+
+We don't want to get "Error Int~Bool".  But if fmv's can rewrite
+wanteds, we will
+
+  [W] fmv ~ Int
+  [W] fmv ~ Bool
+--->
+  [W] Int ~ Bool
+
+
+************************************************************************
+*                                                                      *
+*                FlattenEnv & FlatM
+*             The flattening environment & monad
+*                                                                      *
+************************************************************************
+
+-}
+
+type FlatWorkListRef = TcRef [Ct]  -- See Note [The flattening work list]
+
+data FlattenEnv
+  = FE { fe_mode    :: !FlattenMode
+       , fe_loc     :: !CtLoc             -- See Note [Flattener CtLoc]
+       , fe_flavour :: !CtFlavour
+       , fe_eq_rel  :: !EqRel             -- See Note [Flattener EqRels]
+       , fe_work    :: !FlatWorkListRef } -- See Note [The flattening work list]
+
+data FlattenMode  -- Postcondition for all three: inert wrt the type substitution
+  = FM_FlattenAll          -- Postcondition: function-free
+  | FM_SubstOnly           -- See Note [Flattening under a forall]
+
+--  | FM_Avoid TcTyVar Bool  -- See Note [Lazy flattening]
+--                           -- Postcondition:
+--                           --  * tyvar is only mentioned in result under a rigid path
+--                           --    e.g.   [a] is ok, but F a won't happen
+--                           --  * If flat_top is True, top level is not a function application
+--                           --   (but under type constructors is ok e.g. [F a])
+
+instance Outputable FlattenMode where
+  ppr FM_FlattenAll = text "FM_FlattenAll"
+  ppr FM_SubstOnly  = text "FM_SubstOnly"
+
+eqFlattenMode :: FlattenMode -> FlattenMode -> Bool
+eqFlattenMode FM_FlattenAll FM_FlattenAll = True
+eqFlattenMode FM_SubstOnly  FM_SubstOnly  = True
+--  FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2
+eqFlattenMode _  _ = False
+
+-- | The 'FlatM' monad is a wrapper around 'TcS' with the following
+-- extra capabilities: (1) it offers access to a 'FlattenEnv';
+-- and (2) it maintains the flattening worklist.
+-- See Note [The flattening work list].
+newtype FlatM a
+  = FlatM { runFlatM :: FlattenEnv -> TcS a }
+
+instance Monad FlatM where
+  m >>= k  = FlatM $ \env ->
+             do { a  <- runFlatM m env
+                ; runFlatM (k a) env }
+
+instance Functor FlatM where
+  fmap = liftM
+
+instance Applicative FlatM where
+  pure x = FlatM $ const (pure x)
+  (<*>) = ap
+
+liftTcS :: TcS a -> FlatM a
+liftTcS thing_inside
+  = FlatM $ const thing_inside
+
+emitFlatWork :: Ct -> FlatM ()
+-- See Note [The flattening work list]
+emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :)
+
+-- convenient wrapper when you have a CtEvidence describing
+-- the flattening operation
+runFlattenCtEv :: FlattenMode -> CtEvidence -> FlatM a -> TcS a
+runFlattenCtEv mode ev
+  = runFlatten mode (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev)
+
+-- Run thing_inside (which does flattening), and put all
+-- the work it generates onto the main work list
+-- See Note [The flattening work list]
+runFlatten :: FlattenMode -> CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a
+runFlatten mode loc flav eq_rel thing_inside
+  = do { flat_ref <- newTcRef []
+       ; let fmode = FE { fe_mode = mode
+                        , fe_loc  = loc
+                        , fe_flavour = flav
+                        , fe_eq_rel = eq_rel
+                        , fe_work = flat_ref }
+       ; res <- runFlatM thing_inside fmode
+       ; new_flats <- readTcRef flat_ref
+       ; updWorkListTcS (add_flats new_flats)
+       ; return res }
+  where
+    add_flats new_flats wl
+      = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) }
+
+    add_funeqs []     wl = wl
+    add_funeqs (f:fs) wl = add_funeqs fs (f:wl)
+      -- add_funeqs fs ws = reverse fs ++ ws
+      -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4]
+      --        = [f3,f2,f1,w1,w2,w3,w4]
+
+traceFlat :: String -> SDoc -> FlatM ()
+traceFlat herald doc = liftTcS $ traceTcS herald doc
+
+getFlatEnvField :: (FlattenEnv -> a) -> FlatM a
+getFlatEnvField accessor
+  = FlatM $ \env -> return (accessor env)
+
+getEqRel :: FlatM EqRel
+getEqRel = getFlatEnvField fe_eq_rel
+
+getRole :: FlatM Role
+getRole = eqRelRole <$> getEqRel
+
+getFlavour :: FlatM CtFlavour
+getFlavour = getFlatEnvField fe_flavour
+
+getFlavourRole :: FlatM CtFlavourRole
+getFlavourRole
+  = do { flavour <- getFlavour
+       ; eq_rel <- getEqRel
+       ; return (flavour, eq_rel) }
+
+getMode :: FlatM FlattenMode
+getMode = getFlatEnvField fe_mode
+
+getLoc :: FlatM CtLoc
+getLoc = getFlatEnvField fe_loc
+
+checkStackDepth :: Type -> FlatM ()
+checkStackDepth ty
+  = do { loc <- getLoc
+       ; liftTcS $ checkReductionDepth loc ty }
+
+-- | Change the 'EqRel' in a 'FlatM'.
+setEqRel :: EqRel -> FlatM a -> FlatM a
+setEqRel new_eq_rel thing_inside
+  = FlatM $ \env ->
+    if new_eq_rel == fe_eq_rel env
+    then runFlatM thing_inside env
+    else runFlatM thing_inside (env { fe_eq_rel = new_eq_rel })
+
+-- | Change the 'FlattenMode' in a 'FlattenEnv'.
+setMode :: FlattenMode -> FlatM a -> FlatM a
+setMode new_mode thing_inside
+  = FlatM $ \env ->
+    if new_mode `eqFlattenMode` fe_mode env
+    then runFlatM thing_inside env
+    else runFlatM thing_inside (env { fe_mode = new_mode })
+
+-- | Make sure that flattening actually produces a coercion (in other
+-- words, make sure our flavour is not Derived)
+-- Note [No derived kind equalities]
+noBogusCoercions :: FlatM a -> FlatM a
+noBogusCoercions thing_inside
+  = FlatM $ \env ->
+    -- No new thunk is made if the flavour hasn't changed (note the bang).
+    let !env' = case fe_flavour env of
+          Derived -> env { fe_flavour = Wanted WDeriv }
+          _       -> env
+    in
+    runFlatM thing_inside env'
+
+bumpDepth :: FlatM a -> FlatM a
+bumpDepth (FlatM thing_inside)
+  = FlatM $ \env -> do
+      -- bumpDepth can be called a lot during flattening so we force the
+      -- new env to avoid accumulating thunks.
+      { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) }
+      ; thing_inside env' }
+
+{-
+Note [The flattening work list]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The "flattening work list", held in the fe_work field of FlattenEnv,
+is a list of CFunEqCans generated during flattening.  The key idea
+is this.  Consider flattening (Eq (F (G Int) (H Bool)):
+  * The flattener recursively calls itself on sub-terms before building
+    the main term, so it will encounter the terms in order
+              G Int
+              H Bool
+              F (G Int) (H Bool)
+    flattening to sub-goals
+              w1: G Int ~ fuv0
+              w2: H Bool ~ fuv1
+              w3: F fuv0 fuv1 ~ fuv2
+
+  * Processing w3 first is BAD, because we can't reduce i t,so it'll
+    get put into the inert set, and later kicked out when w1, w2 are
+    solved.  In Trac #9872 this led to inert sets containing hundreds
+    of suspended calls.
+
+  * So we want to process w1, w2 first.
+
+  * So you might think that we should just use a FIFO deque for the work-list,
+    so that putting adding goals in order w1,w2,w3 would mean we processed
+    w1 first.
+
+  * BUT suppose we have 'type instance G Int = H Char'.  Then processing
+    w1 leads to a new goal
+                w4: H Char ~ fuv0
+    We do NOT want to put that on the far end of a deque!  Instead we want
+    to put it at the *front* of the work-list so that we continue to work
+    on it.
+
+So the work-list structure is this:
+
+  * The wl_funeqs (in TcS) is a LIFO stack; we push new goals (such as w4) on
+    top (extendWorkListFunEq), and take new work from the top
+    (selectWorkItem).
+
+  * When flattening, emitFlatWork pushes new flattening goals (like
+    w1,w2,w3) onto the flattening work list, fe_work, another
+    push-down stack.
+
+  * When we finish flattening, we *reverse* the fe_work stack
+    onto the wl_funeqs stack (which brings w1 to the top).
+
+The function runFlatten initialises the fe_work stack, and reverses
+it onto wl_fun_eqs at the end.
+
+Note [Flattener EqRels]
+~~~~~~~~~~~~~~~~~~~~~~~
+When flattening, we need to know which equality relation -- nominal
+or representation -- we should be respecting. The only difference is
+that we rewrite variables by representational equalities when fe_eq_rel
+is ReprEq, and that we unwrap newtypes when flattening w.r.t.
+representational equality.
+
+Note [Flattener CtLoc]
+~~~~~~~~~~~~~~~~~~~~~~
+The flattener does eager type-family reduction.
+Type families might loop, and we
+don't want GHC to do so. A natural solution is to have a bounded depth
+to these processes. A central difficulty is that such a solution isn't
+quite compositional. For example, say it takes F Int 10 steps to get to Bool.
+How many steps does it take to get from F Int -> F Int to Bool -> Bool?
+10? 20? What about getting from Const Char (F Int) to Char? 11? 1? Hard to
+know and hard to track. So, we punt, essentially. We store a CtLoc in
+the FlattenEnv and just update the environment when recurring. In the
+TyConApp case, where there may be multiple type families to flatten,
+we just copy the current CtLoc into each branch. If any branch hits the
+stack limit, then the whole thing fails.
+
+A consequence of this is that setting the stack limits appropriately
+will be essentially impossible. So, the official recommendation if a
+stack limit is hit is to disable the check entirely. Otherwise, there
+will be baffling, unpredictable errors.
+
+Note [Lazy flattening]
+~~~~~~~~~~~~~~~~~~~~~~
+The idea of FM_Avoid mode is to flatten less aggressively.  If we have
+       a ~ [F Int]
+there seems to be no great merit in lifting out (F Int).  But if it was
+       a ~ [G a Int]
+then we *do* want to lift it out, in case (G a Int) reduces to Bool, say,
+which gets rid of the occurs-check problem.  (For the flat_top Bool, see
+comments above and at call sites.)
+
+HOWEVER, the lazy flattening actually seems to make type inference go
+*slower*, not faster.  perf/compiler/T3064 is a case in point; it gets
+*dramatically* worse with FM_Avoid.  I think it may be because
+floating the types out means we normalise them, and that often makes
+them smaller and perhaps allows more re-use of previously solved
+goals.  But to be honest I'm not absolutely certain, so I am leaving
+FM_Avoid in the code base.  What I'm removing is the unique place
+where it is *used*, namely in TcCanonical.canEqTyVar.
+
+See also Note [Conservative unification check] in TcUnify, which gives
+other examples where lazy flattening caused problems.
+
+Bottom line: FM_Avoid is unused for now (Nov 14).
+Note: T5321Fun got faster when I disabled FM_Avoid
+      T5837 did too, but it's pathalogical anyway
+
+Note [Phantoms in the flattener]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+data Proxy p = Proxy
+
+and we're flattening (Proxy ty) w.r.t. ReprEq. Then, we know that `ty`
+is really irrelevant -- it will be ignored when solving for representational
+equality later on. So, we omit flattening `ty` entirely. This may
+violate the expectation of "xi"s for a bit, but the canonicaliser will
+soon throw out the phantoms when decomposing a TyConApp. (Or, the
+canonicaliser will emit an insoluble, in which case the unflattened version
+yields a better error message anyway.)
+
+Note [No derived kind equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A kind-level coercion can appear in types, via mkCastTy. So, whenever
+we are generating a coercion in a dependent context (in other words,
+in a kind) we need to make sure that our flavour is never Derived
+(as Derived constraints have no evidence). The noBogusCoercions function
+changes the flavour from Derived just for this purpose.
+
+-}
+
+{- *********************************************************************
+*                                                                      *
+*      Externally callable flattening functions                        *
+*                                                                      *
+*  They are all wrapped in runFlatten, so their                        *
+*  flattening work gets put into the work list                         *
+*                                                                      *
+********************************************************************* -}
+
+flatten :: FlattenMode -> CtEvidence -> TcType
+        -> TcS (Xi, TcCoercion)
+flatten mode ev ty
+  = do { traceTcS "flatten {" (ppr mode <+> ppr ty)
+       ; (ty', co) <- runFlattenCtEv mode ev (flatten_one ty)
+       ; traceTcS "flatten }" (ppr ty')
+       ; return (ty', co) }
+
+-- specialized to flattening kinds: never Derived, always Nominal
+-- See Note [No derived kind equalities]
+flattenKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN)
+flattenKind loc flav ty
+  = do { traceTcS "flattenKind {" (ppr flav <+> ppr ty)
+       ; let flav' = case flav of
+                       Derived -> Wanted WDeriv  -- the WDeriv/WOnly choice matters not
+                       _       -> flav
+       ; (ty', co) <- runFlatten FM_FlattenAll loc flav' NomEq (flatten_one ty)
+       ; traceTcS "flattenKind }" (ppr ty' $$ ppr co) -- co is never a panic
+       ; return (ty', co) }
+
+flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN)
+-- Externally-callable, hence runFlatten
+-- Flatten a vector of types all at once; in fact they are
+-- always the arguments of type family or class, so
+--      ctEvFlavour ev = Nominal
+-- and we want to flatten all at nominal role
+-- The kind passed in is the kind of the type family or class, call it T
+-- The last coercion returned has type (tcTypeKind(T xis) ~N tcTypeKind(T tys))
+--
+-- For Derived constraints the returned coercion may be undefined
+-- because flattening may use a Derived equality ([D] a ~ ty)
+flattenArgsNom ev tc tys
+  = do { traceTcS "flatten_args {" (vcat (map ppr tys))
+       ; (tys', cos, kind_co)
+           <- runFlattenCtEv FM_FlattenAll ev (flatten_args_tc tc (repeat Nominal) tys)
+       ; traceTcS "flatten }" (vcat (map ppr tys'))
+       ; return (tys', cos, kind_co) }
+
+
+{- *********************************************************************
+*                                                                      *
+*           The main flattening functions
+*                                                                      *
+********************************************************************* -}
+
+{- Note [Flattening]
+~~~~~~~~~~~~~~~~~~~~
+  flatten ty  ==>   (xi, co)
+    where
+      xi has no type functions, unless they appear under ForAlls
+         has no skolems that are mapped in the inert set
+         has no filled-in metavariables
+      co :: xi ~ ty
+
+Key invariants:
+  (F0) co :: xi ~ zonk(ty)
+  (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind
+  (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty))
+
+Note that it is flatten's job to flatten *every type function it sees*.
+flatten is only called on *arguments* to type functions, by canEqGiven.
+
+Flattening also:
+  * zonks, removing any metavariables, and
+  * applies the substitution embodied in the inert set
+
+Because flattening zonks and the returned coercion ("co" above) is also
+zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead,
+we can rely on this fact:
+
+  (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind
+
+Note that the left-hand type of co is *always* precisely xi. The right-hand
+type may or may not be ty, however: if ty has unzonked filled-in metavariables,
+then the right-hand type of co will be the zonked version of ty.
+It is for this reason that we
+occasionally have to explicitly zonk, when (co :: xi ~ ty) is important
+even before we zonk the whole program. For example, see the FTRNotFollowed
+case in flattenTyVar.
+
+Why have these invariants on flattening? Because we sometimes use tcTypeKind
+during canonicalisation, and we want this kind to be zonked (e.g., see
+TcCanonical.canEqTyVar).
+
+Flattening is always homogeneous. That is, the kind of the result of flattening is
+always the same as the kind of the input, modulo zonking. More formally:
+
+  (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty))
+
+This invariant means that the kind of a flattened type might not itself be flat.
+
+Recall that in comments we use alpha[flat = ty] to represent a
+flattening skolem variable alpha which has been generated to stand in
+for ty.
+
+----- Example of flattening a constraint: ------
+  flatten (List (F (G Int)))  ==>  (xi, cc)
+    where
+      xi  = List alpha
+      cc  = { G Int ~ beta[flat = G Int],
+              F beta ~ alpha[flat = F beta] }
+Here
+  * alpha and beta are 'flattening skolem variables'.
+  * All the constraints in cc are 'given', and all their coercion terms
+    are the identity.
+
+NB: Flattening Skolems only occur in canonical constraints, which
+are never zonked, so we don't need to worry about zonking doing
+accidental unflattening.
+
+Note that we prefer to leave type synonyms unexpanded when possible,
+so when the flattener encounters one, it first asks whether its
+transitive expansion contains any type function applications.  If so,
+it expands the synonym and proceeds; if not, it simply returns the
+unexpanded synonym.
+
+Note [flatten_args performance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In programs with lots of type-level evaluation, flatten_args becomes
+part of a tight loop. For example, see test perf/compiler/T9872a, which
+calls flatten_args a whopping 7,106,808 times. It is thus important
+that flatten_args be efficient.
+
+Performance testing showed that the current implementation is indeed
+efficient. It's critically important that zipWithAndUnzipM be
+specialized to TcS, and it's also quite helpful to actually `inline`
+it. On test T9872a, here are the allocation stats (Dec 16, 2014):
+
+ * Unspecialized, uninlined:     8,472,613,440 bytes allocated in the heap
+ * Specialized, uninlined:       6,639,253,488 bytes allocated in the heap
+ * Specialized, inlined:         6,281,539,792 bytes allocated in the heap
+
+To improve performance even further, flatten_args_nom is split off
+from flatten_args, as nominal equality is the common case. This would
+be natural to write using mapAndUnzipM, but even inlined, that function
+is not as performant as a hand-written loop.
+
+ * mapAndUnzipM, inlined:        7,463,047,432 bytes allocated in the heap
+ * hand-written recursion:       5,848,602,848 bytes allocated in the heap
+
+If you make any change here, pay close attention to the T9872{a,b,c} tests
+and T5321Fun.
+
+If we need to make this yet more performant, a possible way forward is to
+duplicate the flattener code for the nominal case, and make that case
+faster. This doesn't seem quite worth it, yet.
+
+Note [flatten_exact_fam_app_fully performance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The refactor of GRefl seems to cause performance trouble for T9872x: the allocation of flatten_exact_fam_app_fully_performance increased. See note [Generalized reflexive coercion] in TyCoRep for more information about GRefl and Trac #15192 for the current state.
+
+The explicit pattern match in homogenise_result helps with T9872a, b, c.
+
+Still, it increases the expected allocation of T9872d by ~2%.
+
+TODO: a step-by-step replay of the refactor to analyze the performance.
+
+-}
+
+{-# INLINE flatten_args_tc #-}
+flatten_args_tc
+  :: TyCon         -- T
+  -> [Role]        -- Role r
+  -> [Type]        -- Arg types [t1,..,tn]
+  -> FlatM ( [Xi]  -- List of flattened args [x1,..,xn]
+                   -- 1-1 corresp with [t1,..,tn]
+           , [Coercion]  -- List of arg coercions [co1,..,con]
+                         -- 1-1 corresp with [t1,..,tn]
+                         --    coi :: xi ~r ti
+           , CoercionN)  -- Result coercion, rco
+                         --    rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con))
+flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet
+  -- NB: TyCon kinds are always closed
+  where
+    (bndrs, named)
+      = ty_con_binders_ty_binders' (tyConBinders tc)
+    -- it's possible that the result kind has arrows (for, e.g., a type family)
+    -- so we must split it
+    (inner_bndrs, inner_ki, inner_named) = split_pi_tys' (tyConResKind tc)
+    !all_bndrs                           = bndrs `chkAppend` inner_bndrs
+    !any_named_bndrs                     = named || inner_named
+    -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%.
+
+{-# INLINE flatten_args #-}
+flatten_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are
+                                     -- named.
+             -> Kind -> TcTyCoVarSet -- function kind; kind's free vars
+             -> [Role] -> [Type]     -- these are in 1-to-1 correspondence
+             -> FlatM ([Xi], [Coercion], CoercionN)
+-- Coercions :: Xi ~ Type, at roles given
+-- Third coercion :: tcTypeKind(fun xis) ~N tcTypeKind(fun tys)
+-- That is, the third coercion relates the kind of some function (whose kind is
+-- passed as the first parameter) instantiated at xis to the kind of that
+-- function instantiated at the tys. This is useful in keeping flattening
+-- homoegeneous. The list of roles must be at least as long as the list of
+-- types.
+flatten_args orig_binders
+             any_named_bndrs
+             orig_inner_ki
+             orig_fvs
+             orig_roles
+             orig_tys
+  = if any_named_bndrs
+    then flatten_args_slow orig_binders
+                           orig_inner_ki
+                           orig_fvs
+                           orig_roles
+                           orig_tys
+    else flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys
+
+{-# INLINE flatten_args_fast #-}
+-- | fast path flatten_args, in which none of the binders are named and
+-- therefore we can avoid tracking a lifting context.
+-- There are many bang patterns in here. It's been observed that they
+-- greatly improve performance of an optimized build.
+-- The T9872 test cases are good witnesses of this fact.
+flatten_args_fast :: [TyCoBinder]
+                  -> Kind
+                  -> [Role]
+                  -> [Type]
+                  -> FlatM ([Xi], [Coercion], CoercionN)
+flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys
+  = fmap finish (iterate orig_tys orig_roles orig_binders)
+  where
+
+    iterate :: [Type]
+            -> [Role]
+            -> [TyCoBinder]
+            -> FlatM ([Xi], [Coercion], [TyCoBinder])
+    iterate (ty:tys) (role:roles) (_:binders) = do
+      (xi, co) <- go role ty
+      (xis, cos, binders) <- iterate tys roles binders
+      pure (xi : xis, co : cos, binders)
+    iterate [] _ binders = pure ([], [], binders)
+    iterate _ _ _ = pprPanic
+        "flatten_args wandered into deeper water than usual" (vcat [])
+           -- This debug information is commented out because leaving it in
+           -- causes a ~2% increase in allocations in T9872{a,c,d}.
+           {-
+             (vcat [ppr orig_binders,
+                    ppr orig_inner_ki,
+                    ppr (take 10 orig_roles), -- often infinite!
+                    ppr orig_tys])
+           -}
+
+    {-# INLINE go #-}
+    go :: Role
+       -> Type
+       -> FlatM (Xi, Coercion)
+    go role ty
+      = case role of
+          -- In the slow path we bind the Xi and Coercion from the recursive
+          -- call and then use it such
+          --
+          --   let kind_co = mkTcSymCo $ mkReflCo Nominal (tyBinderType binder)
+          --       casted_xi = xi `mkCastTy` kind_co
+          --       casted_co = xi |> kind_co ~r xi ; co
+          --
+          -- but this isn't necessary:
+          --   mkTcSymCo (Refl a b) = Refl a b,
+          --   mkCastTy x (Refl _ _) = x
+          --   mkTcGReflLeftCo _ ty (Refl _ _) `mkTransCo` co = co
+          --
+          -- Also, no need to check isAnonTyCoBinder or isNamedBinder, since
+          -- we've already established that they're all anonymous.
+          Nominal          -> setEqRel NomEq  $ flatten_one ty
+          Representational -> setEqRel ReprEq $ flatten_one ty
+          Phantom          -> -- See Note [Phantoms in the flattener]
+                              do { ty <- liftTcS $ zonkTcType ty
+                                 ; return (ty, mkReflCo Phantom ty) }
+
+
+    {-# INLINE finish #-}
+    finish :: ([Xi], [Coercion], [TyCoBinder]) -> ([Xi], [Coercion], CoercionN)
+    finish (xis, cos, binders) = (xis, cos, kind_co)
+      where
+        final_kind = mkPiTys binders orig_inner_ki
+        kind_co    = mkNomReflCo final_kind
+
+{-# INLINE flatten_args_slow #-}
+-- | Slow path, compared to flatten_args_fast, because this one must track
+-- a lifting context.
+flatten_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet
+                  -> [Role] -> [Type]
+                  -> FlatM ([Xi], [Coercion], CoercionN)
+flatten_args_slow binders inner_ki fvs roles tys
+-- Arguments used dependently must be flattened with proper coercions, but
+-- we're not guaranteed to get a proper coercion when flattening with the
+-- "Derived" flavour. So we must call noBogusCoercions when flattening arguments
+-- corresponding to binders that are dependent. However, we might legitimately
+-- have *more* arguments than binders, in the case that the inner_ki is a variable
+-- that gets instantiated with a Π-type. We conservatively choose not to produce
+-- bogus coercions for these, too. Note that this might miss an opportunity for
+-- a Derived rewriting a Derived. The solution would be to generate evidence for
+-- Deriveds, thus avoiding this whole noBogusCoercions idea. See also
+-- Note [No derived kind equalities]
+  = do { flattened_args <- zipWith3M fl (map isNamedBinder binders ++ repeat True)
+                                        roles tys
+       ; return (simplifyArgsWorker binders inner_ki fvs roles flattened_args) }
+  where
+    {-# INLINE fl #-}
+    fl :: Bool   -- must we ensure to produce a real coercion here?
+                  -- see comment at top of function
+       -> Role -> Type -> FlatM (Xi, Coercion)
+    fl True  r ty = noBogusCoercions $ fl1 r ty
+    fl False r ty =                    fl1 r ty
+
+    {-# INLINE fl1 #-}
+    fl1 :: Role -> Type -> FlatM (Xi, Coercion)
+    fl1 Nominal ty
+      = setEqRel NomEq $
+        flatten_one ty
+
+    fl1 Representational ty
+      = setEqRel ReprEq $
+        flatten_one ty
+
+    fl1 Phantom ty
+    -- See Note [Phantoms in the flattener]
+      = do { ty <- liftTcS $ zonkTcType ty
+           ; return (ty, mkReflCo Phantom ty) }
+
+------------------
+flatten_one :: TcType -> FlatM (Xi, Coercion)
+-- Flatten a type to get rid of type function applications, returning
+-- the new type-function-free type, and a collection of new equality
+-- constraints.  See Note [Flattening] for more detail.
+--
+-- Postcondition: Coercion :: Xi ~ TcType
+-- The role on the result coercion matches the EqRel in the FlattenEnv
+
+flatten_one xi@(LitTy {})
+  = do { role <- getRole
+       ; return (xi, mkReflCo role xi) }
+
+flatten_one (TyVarTy tv)
+  = flattenTyVar tv
+
+flatten_one (AppTy ty1 ty2)
+  = flatten_app_tys ty1 [ty2]
+
+flatten_one (TyConApp tc tys)
+  -- Expand type synonyms that mention type families
+  -- on the RHS; see Note [Flattening synonyms]
+  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
+  , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'
+  = do { mode <- getMode
+       ; case mode of
+           FM_FlattenAll | not (isFamFreeTyCon tc)
+                         -> flatten_one expanded_ty
+           _             -> flatten_ty_con_app tc tys }
+
+  -- Otherwise, it's a type function application, and we have to
+  -- flatten it away as well, and generate a new given equality constraint
+  -- between the application and a newly generated flattening skolem variable.
+  | isTypeFamilyTyCon tc
+  = flatten_fam_app tc tys
+
+  -- For * a normal data type application
+  --     * data family application
+  -- we just recursively flatten the arguments.
+  | otherwise
+-- FM_Avoid stuff commented out; see Note [Lazy flattening]
+--  , let fmode' = case fmode of  -- Switch off the flat_top bit in FM_Avoid
+--                   FE { fe_mode = FM_Avoid tv _ }
+--                     -> fmode { fe_mode = FM_Avoid tv False }
+--                   _ -> fmode
+  = flatten_ty_con_app tc tys
+
+flatten_one (FunTy ty1 ty2)
+  = do { (xi1,co1) <- flatten_one ty1
+       ; (xi2,co2) <- flatten_one ty2
+       ; role <- getRole
+       ; return (mkFunTy xi1 xi2, mkFunCo role co1 co2) }
+
+flatten_one ty@(ForAllTy {})
+-- TODO (RAE): This is inadequate, as it doesn't flatten the kind of
+-- the bound tyvar. Doing so will require carrying around a substitution
+-- and the usual substTyVarBndr-like silliness. Argh.
+
+-- We allow for-alls when, but only when, no type function
+-- applications inside the forall involve the bound type variables.
+  = do { let (bndrs, rho) = tcSplitForAllVarBndrs ty
+             tvs           = binderVars bndrs
+       ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho
+                         -- Substitute only under a forall
+                         -- See Note [Flattening under a forall]
+       ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) }
+
+flatten_one (CastTy ty g)
+  = do { (xi, co) <- flatten_one ty
+       ; (g', _)   <- flatten_co g
+
+       ; role <- getRole
+       ; return (mkCastTy xi g', castCoercionKind co role xi ty g' g) }
+
+flatten_one (CoercionTy co) = first mkCoercionTy <$> flatten_co co
+
+-- | "Flatten" a coercion. Really, just zonk it so we can uphold
+-- (F1) of Note [Flattening]
+flatten_co :: Coercion -> FlatM (Coercion, Coercion)
+flatten_co co
+  = do { co <- liftTcS $ zonkCo co
+       ; env_role <- getRole
+       ; let co' = mkTcReflCo env_role (mkCoercionTy co)
+       ; return (co, co') }
+
+-- flatten (nested) AppTys
+flatten_app_tys :: Type -> [Type] -> FlatM (Xi, Coercion)
+-- commoning up nested applications allows us to look up the function's kind
+-- only once. Without commoning up like this, we would spend a quadratic amount
+-- of time looking up functions' types
+flatten_app_tys (AppTy ty1 ty2) tys = flatten_app_tys ty1 (ty2:tys)
+flatten_app_tys fun_ty arg_tys
+  = do { (fun_xi, fun_co) <- flatten_one fun_ty
+       ; flatten_app_ty_args fun_xi fun_co arg_tys }
+
+-- Given a flattened function (with the coercion produced by flattening) and
+-- a bunch of unflattened arguments, flatten the arguments and apply.
+-- The coercion argument's role matches the role stored in the FlatM monad.
+--
+-- The bang patterns used here were observed to improve performance. If you
+-- wish to remove them, be sure to check for regeressions in allocations.
+flatten_app_ty_args :: Xi -> Coercion -> [Type] -> FlatM (Xi, Coercion)
+flatten_app_ty_args fun_xi fun_co []
+  -- this will be a common case when called from flatten_fam_app, so shortcut
+  = return (fun_xi, fun_co)
+flatten_app_ty_args fun_xi fun_co arg_tys
+  = do { (xi, co, kind_co) <- case tcSplitTyConApp_maybe fun_xi of
+           Just (tc, xis) ->
+             do { let tc_roles  = tyConRolesRepresentational tc
+                      arg_roles = dropList xis tc_roles
+                ; (arg_xis, arg_cos, kind_co)
+                    <- flatten_vector (tcTypeKind fun_xi) arg_roles arg_tys
+
+                  -- Here, we have fun_co :: T xi1 xi2 ~ ty
+                  -- and we need to apply fun_co to the arg_cos. The problem is
+                  -- that using mkAppCo is wrong because that function expects
+                  -- its second coercion to be Nominal, and the arg_cos might
+                  -- not be. The solution is to use transitivity:
+                  -- T <xi1> <xi2> arg_cos ;; fun_co <arg_tys>
+                ; eq_rel <- getEqRel
+                ; let app_xi = mkTyConApp tc (xis ++ arg_xis)
+                      app_co = case eq_rel of
+                        NomEq  -> mkAppCos fun_co arg_cos
+                        ReprEq -> mkTcTyConAppCo Representational tc
+                                    (zipWith mkReflCo tc_roles xis ++ arg_cos)
+                                  `mkTcTransCo`
+                                  mkAppCos fun_co (map mkNomReflCo arg_tys)
+                ; return (app_xi, app_co, kind_co) }
+           Nothing ->
+             do { (arg_xis, arg_cos, kind_co)
+                    <- flatten_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys
+                ; let arg_xi = mkAppTys fun_xi arg_xis
+                      arg_co = mkAppCos fun_co arg_cos
+                ; return (arg_xi, arg_co, kind_co) }
+
+       ; role <- getRole
+       ; return (homogenise_result xi co role kind_co) }
+
+flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
+flatten_ty_con_app tc tys
+  = do { role <- getRole
+       ; (xis, cos, kind_co) <- flatten_args_tc tc (tyConRolesX role tc) tys
+       ; let tyconapp_xi = mkTyConApp tc xis
+             tyconapp_co = mkTyConAppCo role tc cos
+       ; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) }
+
+-- Make the result of flattening homogeneous (Note [Flattening] (F2))
+homogenise_result :: Xi              -- a flattened type
+                  -> Coercion        -- :: xi ~r original ty
+                  -> Role            -- r
+                  -> CoercionN       -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty)
+                  -> (Xi, Coercion)  -- (xi |> kind_co, (xi |> kind_co)
+                                     --   ~r original ty)
+homogenise_result xi co r kind_co
+  -- the explicit pattern match here improves the performance of T9872a, b, c by
+  -- ~2%
+  | isGReflCo kind_co = (xi `mkCastTy` kind_co, co)
+  | otherwise         = (xi `mkCastTy` kind_co
+                        , (mkSymCo $ GRefl r xi (MCo kind_co)) `mkTransCo` co)
+{-# INLINE homogenise_result #-}
+
+-- Flatten a vector (list of arguments).
+flatten_vector :: Kind   -- of the function being applied to these arguments
+               -> [Role] -- If we're flatten w.r.t. ReprEq, what roles do the
+                         -- args have?
+               -> [Type] -- the args to flatten
+               -> FlatM ([Xi], [Coercion], CoercionN)
+flatten_vector ki roles tys
+  = do { eq_rel <- getEqRel
+       ; case eq_rel of
+           NomEq  -> flatten_args bndrs
+                                  any_named_bndrs
+                                  inner_ki
+                                  fvs
+                                  (repeat Nominal)
+                                  tys
+           ReprEq -> flatten_args bndrs
+                                  any_named_bndrs
+                                  inner_ki
+                                  fvs
+                                  roles
+                                  tys
+       }
+  where
+    (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki
+    fvs                                = tyCoVarsOfType ki
+{-# INLINE flatten_vector #-}
+
+{-
+Note [Flattening synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Not expanding synonyms aggressively improves error messages, and
+keeps types smaller. But we need to take care.
+
+Suppose
+   type T a = a -> a
+and we want to flatten the type (T (F a)).  Then we can safely flatten
+the (F a) to a skolem, and return (T fsk).  We don't need to expand the
+synonym.  This works because TcTyConAppCo can deal with synonyms
+(unlike TyConAppCo), see Note [TcCoercions] in TcEvidence.
+
+But (Trac #8979) for
+   type T a = (F a, a)    where F is a type function
+we must expand the synonym in (say) T Int, to expose the type function
+to the flattener.
+
+
+Note [Flattening under a forall]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Under a forall, we
+  (a) MUST apply the inert substitution
+  (b) MUST NOT flatten type family applications
+Hence FMSubstOnly.
+
+For (a) consider   c ~ a, a ~ T (forall b. (b, [c]))
+If we don't apply the c~a substitution to the second constraint
+we won't see the occurs-check error.
+
+For (b) consider  (a ~ forall b. F a b), we don't want to flatten
+to     (a ~ forall b.fsk, F a b ~ fsk)
+because now the 'b' has escaped its scope.  We'd have to flatten to
+       (a ~ forall b. fsk b, forall b. F a b ~ fsk b)
+and we have not begun to think about how to make that work!
+
+************************************************************************
+*                                                                      *
+             Flattening a type-family application
+*                                                                      *
+************************************************************************
+-}
+
+flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
+  --   flatten_fam_app            can be over-saturated
+  --   flatten_exact_fam_app       is exactly saturated
+  --   flatten_exact_fam_app_fully lifts out the application to top level
+  -- Postcondition: Coercion :: Xi ~ F tys
+flatten_fam_app tc tys  -- Can be over-saturated
+    = ASSERT2( tys `lengthAtLeast` tyConArity tc
+             , ppr tc $$ ppr (tyConArity tc) $$ ppr tys)
+
+      do { mode <- getMode
+         ; case mode of
+             { FM_SubstOnly  -> flatten_ty_con_app tc tys
+             ; FM_FlattenAll ->
+
+                 -- Type functions are saturated
+                 -- The type function might be *over* saturated
+                 -- in which case the remaining arguments should
+                 -- be dealt with by AppTys
+      do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys
+         ; (xi1, co1) <- flatten_exact_fam_app_fully tc tys1
+               -- co1 :: xi1 ~ F tys1
+
+         ; flatten_app_ty_args xi1 co1 tys_rest } } }
+
+-- the [TcType] exactly saturate the TyCon
+-- See note [flatten_exact_fam_app_fully performance]
+flatten_exact_fam_app_fully :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
+flatten_exact_fam_app_fully tc tys
+  -- See Note [Reduce type family applications eagerly]
+     -- the following tcTypeKind should never be evaluated, as it's just used in
+     -- casting, and casts by refl are dropped
+  = do { let reduce_co = mkNomReflCo (tcTypeKind (mkTyConApp tc tys))
+       ; mOut <- try_to_reduce_nocache tc tys reduce_co id
+       ; case mOut of
+           Just out -> pure out
+           Nothing -> do
+               { -- First, flatten the arguments
+               ; (xis, cos, kind_co)
+                   <- setEqRel NomEq $  -- just do this once, instead of for
+                                        -- each arg
+                      flatten_args_tc tc (repeat Nominal) tys
+                      -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys)
+               ; eq_rel   <- getEqRel
+               ; cur_flav <- getFlavour
+               ; let role   = eqRelRole eq_rel
+                     ret_co = mkTyConAppCo role tc cos
+                      -- ret_co :: F xis ~ F tys; might be heterogeneous
+
+                -- Now, look in the cache
+               ; mb_ct <- liftTcS $ lookupFlatCache tc xis
+               ; case mb_ct of
+                   Just (co, rhs_ty, flav)  -- co :: F xis ~ fsk
+                        -- flav is [G] or [WD]
+                        -- See Note [Type family equations] in TcSMonad
+                     | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav
+                     ->  -- Usable hit in the flat-cache
+                        do { traceFlat "flatten/flat-cache hit" $
+                               (ppr tc <+> ppr xis $$ ppr rhs_ty)
+                           ; (fsk_xi, fsk_co) <- flatten_one rhs_ty
+                                  -- The fsk may already have been unified, so
+                                  -- flatten it
+                                  -- fsk_co :: fsk_xi ~ fsk
+                           ; let xi  = fsk_xi `mkCastTy` kind_co
+                                 co' = mkTcCoherenceLeftCo role fsk_xi kind_co fsk_co
+                                       `mkTransCo`
+                                       maybeSubCo eq_rel (mkSymCo co)
+                                       `mkTransCo` ret_co
+                           ; return (xi, co')
+                           }
+                                            -- :: fsk_xi ~ F xis
+
+                   -- Try to reduce the family application right now
+                   -- See Note [Reduce type family applications eagerly]
+                   _ -> do { mOut <- try_to_reduce tc
+                                                   xis
+                                                   kind_co
+                                                   (`mkTransCo` ret_co)
+                           ; case mOut of
+                               Just out -> pure out
+                               Nothing -> do
+                                 { loc <- getLoc
+                                 ; (ev, co, fsk) <- liftTcS $
+                                     newFlattenSkolem cur_flav loc tc xis
+
+                                 -- The new constraint (F xis ~ fsk) is not
+                                 -- necessarily inert (e.g. the LHS may be a
+                                 -- redex) so we must put it in the work list
+                                 ; let ct = CFunEqCan { cc_ev     = ev
+                                                      , cc_fun    = tc
+                                                      , cc_tyargs = xis
+                                                      , cc_fsk    = fsk }
+                                 ; emitFlatWork ct
+
+                                 ; traceFlat "flatten/flat-cache miss" $
+                                     (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev)
+
+                                 -- NB: fsk's kind is already flattened because
+                                 --     the xis are flattened
+                                 ; let fsk_ty = mkTyVarTy fsk
+                                       xi = fsk_ty `mkCastTy` kind_co
+                                       co' = mkTcCoherenceLeftCo role fsk_ty kind_co (maybeSubCo eq_rel (mkSymCo co))
+                                             `mkTransCo` ret_co
+                                 ; return (xi, co')
+                                 }
+                           }
+               }
+        }
+
+  where
+
+    -- try_to_reduce and try_to_reduce_nocache (below) could be unified into
+    -- a more general definition, but it was observed that separating them
+    -- gives better performance (lower allocation numbers in T9872x).
+
+    try_to_reduce :: TyCon   -- F, family tycon
+                  -> [Type]  -- args, not necessarily flattened
+                  -> CoercionN -- kind_co :: tcTypeKind(F args) ~N
+                               --            tcTypeKind(F orig_args)
+                               -- where
+                               -- orig_args is what was passed to the outer
+                               -- function
+                  -> (   Coercion     -- :: (xi |> kind_co) ~ F args
+                      -> Coercion )   -- what to return from outer function
+                  -> FlatM (Maybe (Xi, Coercion))
+    try_to_reduce tc tys kind_co update_co
+      = do { checkStackDepth (mkTyConApp tc tys)
+           ; mb_match <- liftTcS $ matchFam tc tys
+           ; case mb_match of
+                 -- NB: norm_co will always be homogeneous. All type families
+                 -- are homogeneous.
+               Just (norm_co, norm_ty)
+                 -> do { traceFlat "Eager T.F. reduction success" $
+                         vcat [ ppr tc, ppr tys, ppr norm_ty
+                              , ppr norm_co <+> dcolon
+                                            <+> ppr (coercionKind norm_co)
+                              ]
+                       ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty
+                       ; eq_rel <- getEqRel
+                       ; let co = maybeSubCo eq_rel norm_co
+                                   `mkTransCo` mkSymCo final_co
+                       ; flavour <- getFlavour
+                           -- NB: only extend cache with nominal equalities
+                       ; when (eq_rel == NomEq) $
+                         liftTcS $
+                         extendFlatCache tc tys ( co, xi, flavour )
+                       ; let role = eqRelRole eq_rel
+                             xi' = xi `mkCastTy` kind_co
+                             co' = update_co $
+                                   mkTcCoherenceLeftCo role xi kind_co (mkSymCo co)
+                       ; return $ Just (xi', co') }
+               Nothing -> pure Nothing }
+
+    try_to_reduce_nocache :: TyCon   -- F, family tycon
+                          -> [Type]  -- args, not necessarily flattened
+                          -> CoercionN -- kind_co :: tcTypeKind(F args)
+                                       --            ~N tcTypeKind(F orig_args)
+                                       -- where
+                                       -- orig_args is what was passed to the
+                                       -- outer function
+                          -> (   Coercion     -- :: (xi |> kind_co) ~ F args
+                              -> Coercion )   -- what to return from outer
+                                              -- function
+                          -> FlatM (Maybe (Xi, Coercion))
+    try_to_reduce_nocache tc tys kind_co update_co
+      = do { checkStackDepth (mkTyConApp tc tys)
+           ; mb_match <- liftTcS $ matchFam tc tys
+           ; case mb_match of
+                 -- NB: norm_co will always be homogeneous. All type families
+                 -- are homogeneous.
+               Just (norm_co, norm_ty)
+                 -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty
+                       ; eq_rel <- getEqRel
+                       ; let co  = maybeSubCo eq_rel norm_co
+                                    `mkTransCo` mkSymCo final_co
+                             role = eqRelRole eq_rel
+                             xi' = xi `mkCastTy` kind_co
+                             co' = update_co $
+                                   mkTcCoherenceLeftCo role xi kind_co (mkSymCo co)
+                       ; return $ Just (xi', co') }
+               Nothing -> pure Nothing }
+
+{- Note [Reduce type family applications eagerly]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we come across a type-family application like (Append (Cons x Nil) t),
+then, rather than flattening to a skolem etc, we may as well just reduce
+it on the spot to (Cons x t).  This saves a lot of intermediate steps.
+Examples that are helped are tests T9872, and T5321Fun.
+
+Performance testing indicates that it's best to try this *twice*, once
+before flattening arguments and once after flattening arguments.
+Adding the extra reduction attempt before flattening arguments cut
+the allocation amounts for the T9872{a,b,c} tests by half.
+
+An example of where the early reduction appears helpful:
+
+  type family Last x where
+    Last '[x]     = x
+    Last (h ': t) = Last t
+
+  workitem: (x ~ Last '[1,2,3,4,5,6])
+
+Flattening the argument never gets us anywhere, but trying to flatten
+it at every step is quadratic in the length of the list. Reducing more
+eagerly makes simplifying the right-hand type linear in its length.
+
+Testing also indicated that the early reduction should *not* use the
+flat-cache, but that the later reduction *should*. (Although the
+effect was not large.)  Hence the Bool argument to try_to_reduce.  To
+me (SLPJ) this seems odd; I get that eager reduction usually succeeds;
+and if don't use the cache for eager reduction, we will miss most of
+the opportunities for using it at all.  More exploration would be good
+here.
+
+At the end, once we've got a flat rhs, we extend the flatten-cache to record
+the result. Doing so can save lots of work when the same redex shows up more
+than once. Note that we record the link from the redex all the way to its
+*final* value, not just the single step reduction. Interestingly, using the
+flat-cache for the first reduction resulted in an increase in allocations
+of about 3% for the four T9872x tests. However, using the flat-cache in
+the later reduction is a similar gain. I (Richard E) don't currently (Dec '14)
+have any knowledge as to *why* these facts are true.
+
+************************************************************************
+*                                                                      *
+             Flattening a type variable
+*                                                                      *
+********************************************************************* -}
+
+-- | The result of flattening a tyvar "one step".
+data FlattenTvResult
+  = FTRNotFollowed
+      -- ^ The inert set doesn't make the tyvar equal to anything else
+
+  | FTRFollowed TcType Coercion
+      -- ^ The tyvar flattens to a not-necessarily flat other type.
+      -- co :: new type ~r old type, where the role is determined by
+      -- the FlattenEnv
+
+flattenTyVar :: TyVar -> FlatM (Xi, Coercion)
+flattenTyVar tv
+  = do { mb_yes <- flatten_tyvar1 tv
+       ; case mb_yes of
+           FTRFollowed ty1 co1  -- Recur
+             -> do { (ty2, co2) <- flatten_one ty1
+                   -- ; traceFlat "flattenTyVar2" (ppr tv $$ ppr ty2)
+                   ; return (ty2, co2 `mkTransCo` co1) }
+
+           FTRNotFollowed   -- Done, but make sure the kind is zonked
+                            -- Note [Flattening] invariant (F1)
+             -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv
+                   ; role <- getRole
+                   ; let ty' = mkTyVarTy tv'
+                   ; return (ty', mkTcReflCo role ty') } }
+
+flatten_tyvar1 :: TcTyVar -> FlatM FlattenTvResult
+-- "Flattening" a type variable means to apply the substitution to it
+-- Specifically, look up the tyvar in
+--   * the internal MetaTyVar box
+--   * the inerts
+-- See also the documentation for FlattenTvResult
+
+flatten_tyvar1 tv
+  = do { mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv
+       ; case mb_ty of
+           Just ty -> do { traceFlat "Following filled tyvar"
+                             (ppr tv <+> equals <+> ppr ty)
+                         ; role <- getRole
+                         ; return (FTRFollowed ty (mkReflCo role ty)) } ;
+           Nothing -> do { traceFlat "Unfilled tyvar" (ppr tv)
+                         ; fr <- getFlavourRole
+                         ; flatten_tyvar2 tv fr } }
+
+flatten_tyvar2 :: TcTyVar -> CtFlavourRole -> FlatM FlattenTvResult
+-- The tyvar is not a filled-in meta-tyvar
+-- Try in the inert equalities
+-- See Definition [Applying a generalised substitution] in TcSMonad
+-- See Note [Stability of flattening] in TcSMonad
+
+flatten_tyvar2 tv fr@(_, eq_rel)
+  = do { ieqs <- liftTcS $ getInertEqs
+       ; mode <- getMode
+       ; case lookupDVarEnv ieqs tv of
+           Just (ct:_)   -- If the first doesn't work,
+                         -- the subsequent ones won't either
+             | CTyEqCan { cc_ev = ctev, cc_tyvar = tv
+                        , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct
+             , let ct_fr = (ctEvFlavour ctev, ct_eq_rel)
+             , ct_fr `eqCanRewriteFR` fr  -- This is THE key call of eqCanRewriteFR
+             ->  do { traceFlat "Following inert tyvar"
+                        (ppr mode <+>
+                         ppr tv <+>
+                         equals <+>
+                         ppr rhs_ty $$ ppr ctev)
+                    ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev)
+                          rewrite_co  = case (ct_eq_rel, eq_rel) of
+                            (ReprEq, _rel)  -> ASSERT( _rel == ReprEq )
+                                    -- if this ASSERT fails, then
+                                    -- eqCanRewriteFR answered incorrectly
+                                               rewrite_co1
+                            (NomEq, NomEq)  -> rewrite_co1
+                            (NomEq, ReprEq) -> mkSubCo rewrite_co1
+
+                    ; return (FTRFollowed rhs_ty rewrite_co) }
+                    -- NB: ct is Derived then fmode must be also, hence
+                    -- we are not going to touch the returned coercion
+                    -- so ctEvCoercion is fine.
+
+           _other -> return FTRNotFollowed }
+
+{-
+Note [An alternative story for the inert substitution]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(This entire note is just background, left here in case we ever want
+ to return the previous state of affairs)
+
+We used (GHC 7.8) to have this story for the inert substitution inert_eqs
+
+ * 'a' is not in fvs(ty)
+ * They are *inert* in the weaker sense that there is no infinite chain of
+   (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc
+
+This means that flattening must be recursive, but it does allow
+  [G] a ~ [b]
+  [G] b ~ Maybe c
+
+This avoids "saturating" the Givens, which can save a modest amount of work.
+It is easy to implement, in TcInteract.kick_out, by only kicking out an inert
+only if (a) the work item can rewrite the inert AND
+        (b) the inert cannot rewrite the work item
+
+This is significantly harder to think about. It can save a LOT of work
+in occurs-check cases, but we don't care about them much.  Trac #5837
+is an example; all the constraints here are Givens
+
+             [G] a ~ TF (a,Int)
+    -->
+    work     TF (a,Int) ~ fsk
+    inert    fsk ~ a
+
+    --->
+    work     fsk ~ (TF a, TF Int)
+    inert    fsk ~ a
+
+    --->
+    work     a ~ (TF a, TF Int)
+    inert    fsk ~ a
+
+    ---> (attempting to flatten (TF a) so that it does not mention a
+    work     TF a ~ fsk2
+    inert    a ~ (fsk2, TF Int)
+    inert    fsk ~ (fsk2, TF Int)
+
+    ---> (substitute for a)
+    work     TF (fsk2, TF Int) ~ fsk2
+    inert    a ~ (fsk2, TF Int)
+    inert    fsk ~ (fsk2, TF Int)
+
+    ---> (top-level reduction, re-orient)
+    work     fsk2 ~ (TF fsk2, TF Int)
+    inert    a ~ (fsk2, TF Int)
+    inert    fsk ~ (fsk2, TF Int)
+
+    ---> (attempt to flatten (TF fsk2) to get rid of fsk2
+    work     TF fsk2 ~ fsk3
+    work     fsk2 ~ (fsk3, TF Int)
+    inert    a   ~ (fsk2, TF Int)
+    inert    fsk ~ (fsk2, TF Int)
+
+    --->
+    work     TF fsk2 ~ fsk3
+    inert    fsk2 ~ (fsk3, TF Int)
+    inert    a   ~ ((fsk3, TF Int), TF Int)
+    inert    fsk ~ ((fsk3, TF Int), TF Int)
+
+Because the incoming given rewrites all the inert givens, we get more and
+more duplication in the inert set.  But this really only happens in pathalogical
+casee, so we don't care.
+
+
+************************************************************************
+*                                                                      *
+             Unflattening
+*                                                                      *
+************************************************************************
+
+An unflattening example:
+    [W] F a ~ alpha
+flattens to
+    [W] F a ~ fmv   (CFunEqCan)
+    [W] fmv ~ alpha (CTyEqCan)
+We must solve both!
+-}
+
+unflattenWanteds :: Cts -> Cts -> TcS Cts
+unflattenWanteds tv_eqs funeqs
+ = do { tclvl    <- getTcLevel
+
+      ; traceTcS "Unflattening" $ braces $
+        vcat [ text "Funeqs =" <+> pprCts funeqs
+             , text "Tv eqs =" <+> pprCts tv_eqs ]
+
+         -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check
+         -- Occurs check: consider  [W] alpha ~ [F alpha]
+         --                 ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv]
+         --                 ==> (unify)   [W] F [fmv] ~ fmv
+         -- See Note [Unflatten using funeqs first]
+      ; funeqs <- foldrBagM unflatten_funeq emptyCts funeqs
+      ; traceTcS "Unflattening 1" $ braces (pprCts funeqs)
+
+          -- Step 2: unify the tv_eqs, if possible
+      ; tv_eqs  <- foldrBagM (unflatten_eq tclvl) emptyCts tv_eqs
+      ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs)
+
+          -- Step 3: fill any remaining fmvs with fresh unification variables
+      ; funeqs <- mapBagM finalise_funeq funeqs
+      ; traceTcS "Unflattening 3" $ braces (pprCts funeqs)
+
+          -- Step 4: remove any tv_eqs that look like ty ~ ty
+      ; tv_eqs <- foldrBagM finalise_eq emptyCts tv_eqs
+
+      ; let all_flat = tv_eqs `andCts` funeqs
+      ; traceTcS "Unflattening done" $ braces (pprCts all_flat)
+
+      ; return all_flat }
+  where
+    ----------------
+    unflatten_funeq :: Ct -> Cts -> TcS Cts
+    unflatten_funeq ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis
+                                  , cc_fsk = fmv, cc_ev = ev }) rest
+      = do {   -- fmv should be an un-filled flatten meta-tv;
+               -- we now fix its final value by filling it, being careful
+               -- to observe the occurs check.  Zonking will eliminate it
+               -- altogether in due course
+             rhs' <- zonkTcType (mkTyConApp tc xis)
+           ; case occCheckExpand [fmv] rhs' of
+               Just rhs''    -- Normal case: fill the tyvar
+                 -> do { setReflEvidence ev NomEq rhs''
+                       ; unflattenFmv fmv rhs''
+                       ; return rest }
+
+               Nothing ->  -- Occurs check
+                          return (ct `consCts` rest) }
+
+    unflatten_funeq other_ct _
+      = pprPanic "unflatten_funeq" (ppr other_ct)
+
+    ----------------
+    finalise_funeq :: Ct -> TcS Ct
+    finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev })
+      = do { demoteUnfilledFmv fmv
+           ; return (mkNonCanonical ev) }
+    finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct)
+
+    ----------------
+    unflatten_eq :: TcLevel -> Ct -> Cts -> TcS Cts
+    unflatten_eq tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv
+                                    , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest
+
+      | NomEq <- eq_rel -- See Note [Do not unify representational equalities]
+                        --     in TcInteract
+      , isFmvTyVar tv   -- Previously these fmvs were untouchable,
+                        -- but now they are touchable
+                        -- NB: unlike unflattenFmv, filling a fmv here /does/
+                        --     bump the unification count; it is "improvement"
+                        -- Note [Unflattening can force the solver to iterate]
+      = ASSERT2( tyVarKind tv `eqType` tcTypeKind rhs, ppr ct )
+           -- CTyEqCan invariant should ensure this is true
+        do { is_filled <- isFilledMetaTyVar tv
+           ; elim <- case is_filled of
+               False -> do { traceTcS "unflatten_eq 2" (ppr ct)
+                           ; tryFill ev tv rhs }
+               True  -> do { traceTcS "unflatten_eq 3" (ppr ct)
+                           ; try_fill_rhs ev tclvl tv rhs }
+           ; if elim
+             then do { setReflEvidence ev eq_rel (mkTyVarTy tv)
+                     ; return rest }
+             else return (ct `consCts` rest) }
+
+      | otherwise
+      = return (ct `consCts` rest)
+
+    unflatten_eq _ ct _ = pprPanic "unflatten_irred" (ppr ct)
+
+    ----------------
+    try_fill_rhs ev tclvl lhs_tv rhs
+         -- Constraint is lhs_tv ~ rhs_tv,
+         -- and lhs_tv is filled, so try RHS
+      | Just (rhs_tv, co) <- getCastedTyVar_maybe rhs
+                             -- co :: kind(rhs_tv) ~ kind(lhs_tv)
+      , isFmvTyVar rhs_tv || (isTouchableMetaTyVar tclvl rhs_tv
+                              && not (isTyVarTyVar rhs_tv))
+                              -- LHS is a filled fmv, and so is a type
+                              -- family application, which a TyVarTv should
+                              -- not unify with
+      = do { is_filled <- isFilledMetaTyVar rhs_tv
+           ; if is_filled then return False
+             else tryFill ev rhs_tv
+                          (mkTyVarTy lhs_tv `mkCastTy` mkSymCo co) }
+
+      | otherwise
+      = return False
+
+    ----------------
+    finalise_eq :: Ct -> Cts -> TcS Cts
+    finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv
+                          , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest
+      | isFmvTyVar tv
+      = do { ty1 <- zonkTcTyVar tv
+           ; rhs' <- zonkTcType rhs
+           ; if ty1 `tcEqType` rhs'
+             then do { setReflEvidence ev eq_rel rhs'
+                     ; return rest }
+             else return (mkNonCanonical ev `consCts` rest) }
+
+      | otherwise
+      = return (mkNonCanonical ev `consCts` rest)
+
+    finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct)
+
+tryFill :: CtEvidence -> TcTyVar -> TcType -> TcS Bool
+-- (tryFill tv rhs ev) assumes 'tv' is an /un-filled/ MetaTv
+-- If tv does not appear in 'rhs', it set tv := rhs,
+-- binds the evidence (which should be a CtWanted) to Refl<rhs>
+-- and return True.  Otherwise returns False
+tryFill ev tv rhs
+  = ASSERT2( not (isGiven ev), ppr ev )
+    do { rhs' <- zonkTcType rhs
+       ; case () of
+            _ | Just tv' <- tcGetTyVar_maybe rhs'
+              , tv == tv'   -- tv == rhs
+              -> return True
+
+            _ | Just rhs'' <- occCheckExpand [tv] rhs'
+              -> do {       -- Fill the tyvar
+                      unifyTyVar tv rhs''
+                    ; return True }
+
+            _ | otherwise   -- Occurs check
+              -> return False
+    }
+
+setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS ()
+setReflEvidence ev eq_rel rhs
+  = setEvBindIfWanted ev (evCoercion refl_co)
+  where
+    refl_co = mkTcReflCo (eqRelRole eq_rel) rhs
+
+{-
+Note [Unflatten using funeqs first]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    [W] G a ~ Int
+    [W] F (G a) ~ G a
+
+do not want to end up with
+    [W] F Int ~ Int
+because that might actually hold!  Better to end up with the two above
+unsolved constraints.  The flat form will be
+
+    G a ~ fmv1     (CFunEqCan)
+    F fmv1 ~ fmv2  (CFunEqCan)
+    fmv1 ~ Int     (CTyEqCan)
+    fmv1 ~ fmv2    (CTyEqCan)
+
+Flatten using the fun-eqs first.
+-}
+
+-- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at
+-- least one named binder.
+split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool)
+split_pi_tys' ty = split ty ty
+  where
+  split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty'
+  split _       (ForAllTy b res) = let (bs, ty, _) = split res res
+                                   in  (Named b : bs, ty, True)
+  split _       (FunTy arg res)  = let (bs, ty, named) = split res res
+                                   in  (Anon arg : bs, ty, named)
+  split orig_ty _                = ([], orig_ty, False)
+{-# INLINE split_pi_tys' #-}
+
+-- | Like 'tyConBindersTyCoBinders' but you also get a 'Bool' which is true iff
+-- there is at least one named binder.
+ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool)
+ty_con_binders_ty_binders' = foldr go ([], False)
+  where
+    go (Bndr tv (NamedTCB vis)) (bndrs, _)
+      = (Named (Bndr tv vis) : bndrs, True)
+    go (Bndr tv AnonTCB)        (bndrs, n)
+      = (Anon (tyVarKind tv)   : bndrs, n)
+    {-# INLINE go #-}
+{-# INLINE ty_con_binders_ty_binders' #-}
diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcForeign.hs
@@ -0,0 +1,569 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1998
+
+\section[TcForeign]{Typechecking \tr{foreign} declarations}
+
+A foreign declaration is used to either give an externally
+implemented function a Haskell type (and calling interface) or
+give a Haskell function an external calling interface. Either way,
+the range of argument and result types these functions can accommodate
+is restricted to what the outside world understands (read C), and this
+module checks to see if a foreign declaration has got a legal type.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcForeign
+        ( tcForeignImports
+        , tcForeignExports
+
+        -- Low-level exports for hooks
+        , isForeignImport, isForeignExport
+        , tcFImport, tcFExport
+        , tcForeignImports'
+        , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes
+        , normaliseFfiType
+        , nonIOok, mustBeIO
+        , checkSafe, noCheckSafe
+        , tcForeignExports'
+        , tcCheckFEType
+        ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+
+import TcRnMonad
+import TcHsType
+import TcExpr
+import TcEnv
+
+import FamInst
+import FamInstEnv
+import Coercion
+import Type
+import ForeignCall
+import ErrUtils
+import Id
+import Name
+import RdrName
+import DataCon
+import TyCon
+import TcType
+import PrelNames
+import DynFlags
+import Outputable
+import Platform
+import SrcLoc
+import Bag
+import Hooks
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Data.Maybe
+
+-- Defines a binding
+isForeignImport :: LForeignDecl name -> Bool
+isForeignImport (L _ (ForeignImport {})) = True
+isForeignImport _                        = False
+
+-- Exports a binding
+isForeignExport :: LForeignDecl name -> Bool
+isForeignExport (L _ (ForeignExport {})) = True
+isForeignExport _                        = False
+
+{-
+Note [Don't recur in normaliseFfiType']
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+normaliseFfiType' is the workhorse for normalising a type used in a foreign
+declaration. If we have
+
+newtype Age = MkAge Int
+
+we want to see that Age -> IO () is the same as Int -> IO (). But, we don't
+need to recur on any type parameters, because no paramaterized types (with
+interesting parameters) are marshalable! The full list of marshalable types
+is in the body of boxedMarshalableTyCon in TcType. The only members of that
+list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled
+the same way regardless of type parameter. So, no need to recur into
+parameters.
+
+Similarly, we don't need to look in AppTy's, because nothing headed by
+an AppTy will be marshalable.
+
+Note [FFI type roles]
+~~~~~~~~~~~~~~~~~~~~~
+The 'go' helper function within normaliseFfiType' always produces
+representational coercions. But, in the "children_only" case, we need to
+use these coercions in a TyConAppCo. Accordingly, the roles on the coercions
+must be twiddled to match the expectation of the enclosing TyCon. However,
+we cannot easily go from an R coercion to an N one, so we forbid N roles
+on FFI type constructors. Currently, only two such type constructors exist:
+IO and FunPtr. Thus, this is not an onerous burden.
+
+If we ever want to lift this restriction, we would need to make 'go' take
+the target role as a parameter. This wouldn't be hard, but it's a complication
+not yet necessary and so is not yet implemented.
+-}
+
+-- normaliseFfiType takes the type from an FFI declaration, and
+-- evaluates any type synonyms, type functions, and newtypes. However,
+-- we are only allowed to look through newtypes if the constructor is
+-- in scope.  We return a bag of all the newtype constructors thus found.
+-- Always returns a Representational coercion
+normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
+normaliseFfiType ty
+    = do fam_envs <- tcGetFamInstEnvs
+         normaliseFfiType' fam_envs ty
+
+normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
+normaliseFfiType' env ty0 = go initRecTc ty0
+  where
+    go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)
+    go rec_nts ty
+      | Just ty' <- tcView ty     -- Expand synonyms
+      = go rec_nts ty'
+
+      | Just (tc, tys) <- splitTyConApp_maybe ty
+      = go_tc_app rec_nts tc tys
+
+      | (bndrs, inner_ty) <- splitForAllVarBndrs ty
+      , not (null bndrs)
+      = do (coi, nty1, gres1) <- go rec_nts inner_ty
+           return ( mkHomoForAllCos (binderVars bndrs) coi
+                  , mkForAllTys bndrs nty1, gres1 )
+
+      | otherwise -- see Note [Don't recur in normaliseFfiType']
+      = return (mkRepReflCo ty, ty, emptyBag)
+
+    go_tc_app :: RecTcChecker -> TyCon -> [Type]
+              -> TcM (Coercion, Type, Bag GlobalRdrElt)
+    go_tc_app rec_nts tc tys
+        -- We don't want to look through the IO newtype, even if it is
+        -- in scope, so we have a special case for it:
+        | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey]
+                  -- These *must not* have nominal roles on their parameters!
+                  -- See Note [FFI type roles]
+        = children_only
+
+        | isNewTyCon tc         -- Expand newtypes
+        , Just rec_nts' <- checkRecTc rec_nts tc
+                   -- See Note [Expanding newtypes] in TyCon.hs
+                   -- We can't just use isRecursiveTyCon; sometimes recursion is ok:
+                   --     newtype T = T (Ptr T)
+                   --   Here, we don't reject the type for being recursive.
+                   -- If this is a recursive newtype then it will normally
+                   -- be rejected later as not being a valid FFI type.
+        = do { rdr_env <- getGlobalRdrEnv
+             ; case checkNewtypeFFI rdr_env tc of
+                 Nothing  -> nothing
+                 Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs
+                                ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } }
+
+        | isFamilyTyCon tc              -- Expand open tycons
+        , (co, ty) <- normaliseTcApp env Representational tc tys
+        , not (isReflexiveCo co)
+        = do (co', ty', gres) <- go rec_nts ty
+             return (mkTransCo co co', ty', gres)
+
+        | otherwise
+        = nothing -- see Note [Don't recur in normaliseFfiType']
+        where
+          tc_key = getUnique tc
+          children_only
+            = do xs <- mapM (go rec_nts) tys
+                 let (cos, tys', gres) = unzip3 xs
+                        -- the (repeat Representational) is because 'go' always
+                        -- returns R coercions
+                     cos' = zipWith3 downgradeRole (tyConRoles tc)
+                                     (repeat Representational) cos
+                 return ( mkTyConAppCo Representational tc cos'
+                        , mkTyConApp tc tys', unionManyBags gres)
+          nt_co  = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys []
+          nt_rhs = newTyConInstRhs tc tys
+
+          ty      = mkTyConApp tc tys
+          nothing = return (mkRepReflCo ty, ty, emptyBag)
+
+checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
+checkNewtypeFFI rdr_env tc
+  | Just con <- tyConSingleDataCon_maybe tc
+  , Just gre <- lookupGRE_Name rdr_env (dataConName con)
+  = Just gre    -- See Note [Newtype constructor usage in foreign declarations]
+  | otherwise
+  = Nothing
+
+{-
+Note [Newtype constructor usage in foreign declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHC automatically "unwraps" newtype constructors in foreign import/export
+declarations.  In effect that means that a newtype data constructor is
+used even though it is not mentioned expclitly in the source, so we don't
+want to report it as "defined but not used" or "imported but not used".
+eg     newtype D = MkD Int
+       foreign import foo :: D -> IO ()
+Here 'MkD' us used.  See Trac #7408.
+
+GHC also expands type functions during this process, so it's not enough
+just to look at the free variables of the declaration.
+eg     type instance F Bool = D
+       foreign import bar :: F Bool -> IO ()
+Here again 'MkD' is used.
+
+So we really have wait until the type checker to decide what is used.
+That's why tcForeignImports and tecForeignExports return a (Bag GRE)
+for the newtype constructors they see. Then TcRnDriver can add them
+to the module's usages.
+
+
+************************************************************************
+*                                                                      *
+\subsection{Imports}
+*                                                                      *
+************************************************************************
+-}
+
+tcForeignImports :: [LForeignDecl GhcRn]
+                 -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
+tcForeignImports decls
+  = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls)
+
+tcForeignImports' :: [LForeignDecl GhcRn]
+                  -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
+-- For the (Bag GlobalRdrElt) result,
+-- see Note [Newtype constructor usage in foreign declarations]
+tcForeignImports' decls
+  = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $
+                               filter isForeignImport decls
+       ; return (ids, decls, unionManyBags gres) }
+
+tcFImport :: LForeignDecl GhcRn
+          -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
+tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
+                                    , fd_fi = imp_decl }))
+  = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo)  $
+    do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+       ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty
+       ; let
+           -- Drop the foralls before inspecting the
+           -- structure of the foreign type.
+             (bndrs, res_ty)   = tcSplitPiTys norm_sig_ty
+             arg_tys           = mapMaybe binderRelevantType_maybe bndrs
+             id                = mkLocalId nm sig_ty
+                 -- Use a LocalId to obey the invariant that locally-defined
+                 -- things are LocalIds.  However, it does not need zonking,
+                 -- (so TcHsSyn.zonkForeignExports ignores it).
+
+       ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl
+          -- Can't use sig_ty here because sig_ty :: Type and
+          -- we need HsType Id hence the undefined
+       ; let fi_decl = ForeignImport { fd_name = L nloc id
+                                     , fd_sig_ty = undefined
+                                     , fd_i_ext = mkSymCo norm_co
+                                     , fd_fi = imp_decl' }
+       ; return (id, L dloc fi_decl, gres) }
+tcFImport d = pprPanic "tcFImport" (ppr d)
+
+-- ------------ Checking types for foreign import ----------------------
+
+tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport
+
+tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src)
+  -- Foreign import label
+  = do checkCg checkCOrAsmOrLlvmOrInterp
+       -- NB check res_ty not sig_ty!
+       --    In case sig_ty is (forall a. ForeignPtr a)
+       check (isFFILabelTy (mkFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)
+       cconv' <- checkCConv cconv
+       return (CImport (L lc cconv') safety mh l src)
+
+tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do
+        -- Foreign wrapper (former f.e.d.)
+        -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid
+        -- foreign type.  For legacy reasons ft -> IO (Ptr ft) is accepted, too.
+        -- The use of the latter form is DEPRECATED, though.
+    checkCg checkCOrAsmOrLlvmOrInterp
+    cconv' <- checkCConv cconv
+    case arg_tys of
+        [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
+                        checkForeignRes nonIOok  checkSafe isFFIExportResultTy res1_ty
+                        checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty
+                  where
+                     (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
+        _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected"))
+    return (CImport (L lc cconv') safety mh CWrapper src)
+
+tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
+                                            (CFunction target) src)
+  | isDynamicTarget target = do -- Foreign import dynamic
+      checkCg checkCOrAsmOrLlvmOrInterp
+      cconv' <- checkCConv cconv
+      case arg_tys of           -- The first arg must be Ptr or FunPtr
+        []                ->
+          addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected"))
+        (arg1_ty:arg_tys) -> do
+          dflags <- getDynFlags
+          let curried_res_ty = mkFunTys arg_tys res_ty
+          check (isFFIDynTy curried_res_ty arg1_ty)
+                (illegalForeignTyErr argument)
+          checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
+          checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
+      return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
+  | cconv == PrimCallConv = do
+      dflags <- getDynFlags
+      checkTc (xopt LangExt.GHCForeignImportPrim dflags)
+              (text "Use GHCForeignImportPrim to allow `foreign import prim'.")
+      checkCg checkCOrAsmOrLlvmOrInterp
+      checkCTarget target
+      checkTc (playSafe safety)
+              (text "The safe/unsafe annotation should not be used with `foreign import prim'.")
+      checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
+      -- prim import result is more liberal, allows (#,,#)
+      checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
+      return idecl
+  | otherwise = do              -- Normal foreign import
+      checkCg checkCOrAsmOrLlvmOrInterp
+      cconv' <- checkCConv cconv
+      checkCTarget target
+      dflags <- getDynFlags
+      checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
+      checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
+      checkMissingAmpersand dflags arg_tys res_ty
+      case target of
+          StaticTarget _ _ _ False
+           | not (null arg_tys) ->
+              addErrTc (text "`value' imports cannot have function types")
+          _ -> return ()
+      return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
+
+
+-- This makes a convenient place to check
+-- that the C identifier is valid for C
+checkCTarget :: CCallTarget -> TcM ()
+checkCTarget (StaticTarget _ str _ _) = do
+    checkCg checkCOrAsmOrLlvmOrInterp
+    checkTc (isCLabelString str) (badCName str)
+
+checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
+
+
+checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()
+checkMissingAmpersand dflags arg_tys res_ty
+  | null arg_tys && isFunPtrTy res_ty &&
+    wopt Opt_WarnDodgyForeignImports dflags
+  = addWarn (Reason Opt_WarnDodgyForeignImports)
+        (text "possible missing & in foreign import of FunPtr")
+  | otherwise
+  = return ()
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Exports}
+*                                                                      *
+************************************************************************
+-}
+
+tcForeignExports :: [LForeignDecl GhcRn]
+             -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt)
+tcForeignExports decls =
+  getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls)
+
+tcForeignExports' :: [LForeignDecl GhcRn]
+             -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt)
+-- For the (Bag GlobalRdrElt) result,
+-- see Note [Newtype constructor usage in foreign declarations]
+tcForeignExports' decls
+  = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls)
+  where
+   combine (binds, fs, gres1) (L loc fe) = do
+       (b, f, gres2) <- setSrcSpan loc (tcFExport fe)
+       return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)
+
+tcFExport :: ForeignDecl GhcRn
+          -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
+tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec })
+  = addErrCtxt (foreignDeclCtxt fo) $ do
+
+    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+    rhs <- tcPolyExpr (nlHsVar nm) sig_ty
+
+    (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty
+
+    spec' <- tcCheckFEType norm_sig_ty spec
+
+           -- we're exporting a function, but at a type possibly more
+           -- constrained than its declared/inferred type. Hence the need
+           -- to create a local binding which will call the exported function
+           -- at a particular type (and, maybe, overloading).
+
+
+    -- We need to give a name to the new top-level binding that
+    -- is *stable* (i.e. the compiler won't change it later),
+    -- because this name will be referred to by the C code stub.
+    id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
+    return ( mkVarBind id rhs
+           , ForeignExport { fd_name = L loc id
+                           , fd_sig_ty = undefined
+                           , fd_e_ext = norm_co, fd_fe = spec' }
+           , gres)
+tcFExport d = pprPanic "tcFExport" (ppr d)
+
+-- ------------ Checking argument types for foreign export ----------------------
+
+tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
+tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do
+    checkCg checkCOrAsmOrLlvm
+    checkTc (isCLabelString str) (badCName str)
+    cconv' <- checkCConv cconv
+    checkForeignArgs isFFIExternalTy arg_tys
+    checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
+    return (CExport (L l (CExportStatic esrc str cconv')) src)
+  where
+      -- Drop the foralls before inspecting n
+      -- the structure of the foreign type.
+    (bndrs, res_ty) = tcSplitPiTys sig_ty
+    arg_tys         = mapMaybe binderRelevantType_maybe bndrs
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Miscellaneous}
+*                                                                      *
+************************************************************************
+-}
+
+------------ Checking argument types for foreign import ----------------------
+checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM ()
+checkForeignArgs pred tys = mapM_ go tys
+  where
+    go ty = check (pred ty) (illegalForeignTyErr argument)
+
+------------ Checking result types for foreign calls ----------------------
+-- | Check that the type has the form
+--    (IO t) or (t) , and that t satisfies the given predicate.
+-- When calling this function, any newtype wrappers (should) have been
+-- already dealt with by normaliseFfiType.
+--
+-- We also check that the Safe Haskell condition of FFI imports having
+-- results in the IO monad holds.
+--
+checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
+checkForeignRes non_io_result_ok check_safe pred_res_ty ty
+  | Just (_, res_ty) <- tcSplitIOType_maybe ty
+  =     -- Got an IO result type, that's always fine!
+     check (pred_res_ty res_ty) (illegalForeignTyErr result)
+
+  -- Case for non-IO result type with FFI Import
+  | not non_io_result_ok
+  = addErrTc $ illegalForeignTyErr result (text "IO result type expected")
+
+  | otherwise
+  = do { dflags <- getDynFlags
+       ; case pred_res_ty ty of
+                -- Handle normal typecheck fail, we want to handle this first and
+                -- only report safe haskell errors if the normal type check is OK.
+           NotValid msg -> addErrTc $ illegalForeignTyErr result msg
+
+           -- handle safe infer fail
+           _ | check_safe && safeInferOn dflags
+               -> recordUnsafeInfer emptyBag
+
+           -- handle safe language typecheck fail
+           _ | check_safe && safeLanguageOn dflags
+               -> addErrTc (illegalForeignTyErr result safeHsErr)
+
+           -- success! non-IO return is fine
+           _ -> return () }
+  where
+    safeHsErr =
+      text "Safe Haskell is on, all FFI imports must be in the IO monad"
+
+nonIOok, mustBeIO :: Bool
+nonIOok  = True
+mustBeIO = False
+
+checkSafe, noCheckSafe :: Bool
+checkSafe   = True
+noCheckSafe = False
+
+-- Checking a supported backend is in use
+
+checkCOrAsmOrLlvm :: HscTarget -> Validity
+checkCOrAsmOrLlvm HscC    = IsValid
+checkCOrAsmOrLlvm HscAsm  = IsValid
+checkCOrAsmOrLlvm HscLlvm = IsValid
+checkCOrAsmOrLlvm _
+  = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")
+
+checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity
+checkCOrAsmOrLlvmOrInterp HscC           = IsValid
+checkCOrAsmOrLlvmOrInterp HscAsm         = IsValid
+checkCOrAsmOrLlvmOrInterp HscLlvm        = IsValid
+checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid
+checkCOrAsmOrLlvmOrInterp _
+  = NotValid (text "requires interpreted, unregisterised, llvm or native code generation")
+
+checkCg :: (HscTarget -> Validity) -> TcM ()
+checkCg check = do
+    dflags <- getDynFlags
+    let target = hscTarget dflags
+    case target of
+      HscNothing -> return ()
+      _ ->
+        case check target of
+          IsValid      -> return ()
+          NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err)
+
+-- Calling conventions
+
+checkCConv :: CCallConv -> TcM CCallConv
+checkCConv CCallConv    = return CCallConv
+checkCConv CApiConv     = return CApiConv
+checkCConv StdCallConv  = do dflags <- getDynFlags
+                             let platform = targetPlatform dflags
+                             if platformArch platform == ArchX86
+                                 then return StdCallConv
+                                 else do -- This is a warning, not an error. see #3336
+                                         when (wopt Opt_WarnUnsupportedCallingConventions dflags) $
+                                             addWarnTc (Reason Opt_WarnUnsupportedCallingConventions)
+                                                 (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
+                                         return CCallConv
+checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
+                             return PrimCallConv
+checkCConv JavaScriptCallConv = do dflags <- getDynFlags
+                                   if platformArch (targetPlatform dflags) == ArchJavaScript
+                                       then return JavaScriptCallConv
+                                       else do addErrTc (text "The `javascript' calling convention is unsupported on this platform")
+                                               return JavaScriptCallConv
+
+-- Warnings
+
+check :: Validity -> (MsgDoc -> MsgDoc) -> TcM ()
+check IsValid _             = return ()
+check (NotValid doc) err_fn = addErrTc (err_fn doc)
+
+illegalForeignTyErr :: SDoc -> SDoc -> SDoc
+illegalForeignTyErr arg_or_res extra
+  = hang msg 2 extra
+  where
+    msg = hsep [ text "Unacceptable", arg_or_res
+               , text "type in foreign declaration:"]
+
+-- Used for 'arg_or_res' argument to illegalForeignTyErr
+argument, result :: SDoc
+argument = text "argument"
+result   = text "result"
+
+badCName :: CLabelString -> MsgDoc
+badCName target
+  = sep [quotes (ppr target) <+> text "is not a valid C identifier"]
+
+foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc
+foreignDeclCtxt fo
+  = hang (text "When checking declaration:")
+       2 (ppr fo)
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -0,0 +1,2436 @@
+{-
+    %
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+TcGenDeriv: Generating derived instance declarations
+
+This module is nominally ``subordinate'' to @TcDeriv@, which is the
+``official'' interface to deriving-related things.
+
+This is where we do all the grimy bindings' generation.
+-}
+
+{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcGenDeriv (
+        BagDerivStuff, DerivStuff(..),
+
+        gen_Eq_binds,
+        gen_Ord_binds,
+        gen_Enum_binds,
+        gen_Bounded_binds,
+        gen_Ix_binds,
+        gen_Show_binds,
+        gen_Read_binds,
+        gen_Data_binds,
+        gen_Lift_binds,
+        gen_Newtype_binds,
+        mkCoerceClassMethEqn,
+        genAuxBinds,
+        ordOpTbl, boxConTbl, litConTbl,
+        mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnMonad
+import HsSyn
+import RdrName
+import BasicTypes
+import DataCon
+import Name
+import Fingerprint
+import Encoding
+
+import DynFlags
+import PrelInfo
+import FamInst
+import FamInstEnv
+import PrelNames
+import THNames
+import Module ( moduleName, moduleNameString
+              , moduleUnitId, unitIdString )
+import MkId ( coerceId )
+import PrimOp
+import SrcLoc
+import TyCon
+import TcEnv
+import TcType
+import TcValidity ( checkValidCoAxBranch )
+import CoAxiom    ( coAxiomSingleBranch )
+import TysPrim
+import TysWiredIn
+import Type
+import Class
+import VarSet
+import VarEnv
+import Util
+import Var
+import Outputable
+import Lexeme
+import FastString
+import Pair
+import Bag
+
+import Data.List  ( find, partition, intersperse )
+
+type BagDerivStuff = Bag DerivStuff
+
+data AuxBindSpec
+  = DerivCon2Tag TyCon  -- The con2Tag for given TyCon
+  | DerivTag2Con TyCon  -- ...ditto tag2Con
+  | DerivMaxTag  TyCon  -- ...and maxTag
+  deriving( Eq )
+  -- All these generate ZERO-BASED tag operations
+  -- I.e first constructor has tag 0
+
+data DerivStuff     -- Please add this auxiliary stuff
+  = DerivAuxBind AuxBindSpec
+
+  -- Generics and DeriveAnyClass
+  | DerivFamInst FamInst               -- New type family instances
+
+  -- New top-level auxiliary bindings
+  | DerivHsBind (LHsBind GhcPs, LSig GhcPs) -- Also used for SYB
+
+
+{-
+************************************************************************
+*                                                                      *
+                Eq instances
+*                                                                      *
+************************************************************************
+
+Here are the heuristics for the code we generate for @Eq@. Let's
+assume we have a data type with some (possibly zero) nullary data
+constructors and some ordinary, non-nullary ones (the rest, also
+possibly zero of them).  Here's an example, with both \tr{N}ullary and
+\tr{O}rdinary data cons.
+
+  data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
+
+* For the ordinary constructors (if any), we emit clauses to do The
+  Usual Thing, e.g.,:
+
+    (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
+    (==) (O2 a1)       (O2 a2)       = a1 == a2
+    (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
+
+  Note: if we're comparing unlifted things, e.g., if 'a1' and
+  'a2' are Float#s, then we have to generate
+       case (a1 `eqFloat#` a2) of r -> r
+  for that particular test.
+
+* If there are a lot of (more than ten) nullary constructors, we emit a
+  catch-all clause of the form:
+
+      (==) a b  = case (con2tag_Foo a) of { a# ->
+                  case (con2tag_Foo b) of { b# ->
+                  case (a# ==# b#)     of {
+                    r -> r }}}
+
+  If con2tag gets inlined this leads to join point stuff, so
+  it's better to use regular pattern matching if there aren't too
+  many nullary constructors.  "Ten" is arbitrary, of course
+
+* If there aren't any nullary constructors, we emit a simpler
+  catch-all:
+
+     (==) a b  = False
+
+* For the @(/=)@ method, we normally just use the default method.
+  If the type is an enumeration type, we could/may/should? generate
+  special code that calls @con2tag_Foo@, much like for @(==)@ shown
+  above.
+
+We thought about doing this: If we're also deriving 'Ord' for this
+tycon, we generate:
+  instance ... Eq (Foo ...) where
+    (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
+    (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
+However, that requires that (Ord <whatever>) was put in the context
+for the instance decl, which it probably wasn't, so the decls
+produced don't get through the typechecker.
+-}
+
+gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Eq_binds loc tycon = do
+    dflags <- getDynFlags
+    return (method_binds dflags, aux_binds)
+  where
+    all_cons = tyConDataCons tycon
+    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
+
+    -- If there are ten or more (arbitrary number) nullary constructors,
+    -- use the con2tag stuff.  For small types it's better to use
+    -- ordinary pattern matching.
+    (tag_match_cons, pat_match_cons)
+       | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons)
+       | otherwise                       = ([],           all_cons)
+
+    no_tag_match_cons = null tag_match_cons
+
+    fall_through_eqn dflags
+      | no_tag_match_cons   -- All constructors have arguments
+      = case pat_match_cons of
+          []  -> []   -- No constructors; no fall-though case
+          [_] -> []   -- One constructor; no fall-though case
+          _   ->      -- Two or more constructors; add fall-through of
+                      --       (==) _ _ = False
+                 [([nlWildPat, nlWildPat], false_Expr)]
+
+      | otherwise -- One or more tag_match cons; add fall-through of
+                  -- extract tags compare for equality
+      = [([a_Pat, b_Pat],
+         untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
+                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
+
+    aux_binds | no_tag_match_cons = emptyBag
+              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
+
+    method_binds dflags = unitBag (eq_bind dflags)
+    eq_bind dflags = mkFunBindEC 2 loc eq_RDR (const true_Expr)
+                                 (map pats_etc pat_match_cons
+                                   ++ fall_through_eqn dflags)
+
+    ------------------------------------------------------------------
+    pats_etc data_con
+      = let
+            con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed
+            con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed
+
+            data_con_RDR = getRdrName data_con
+            con_arity   = length tys_needed
+            as_needed   = take con_arity as_RDRs
+            bs_needed   = take con_arity bs_RDRs
+            tys_needed  = dataConOrigArgTys data_con
+        in
+        ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
+      where
+        nested_eq_expr []  [] [] = true_Expr
+        nested_eq_expr tys as bs
+          = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
+          -- Using 'foldr1' here ensures that the derived code is correctly
+          -- associated. See Trac #10859.
+          where
+            nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b))
+
+{-
+************************************************************************
+*                                                                      *
+        Ord instances
+*                                                                      *
+************************************************************************
+
+Note [Generating Ord instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose constructors are K1..Kn, and some are nullary.
+The general form we generate is:
+
+* Do case on first argument
+        case a of
+          K1 ... -> rhs_1
+          K2 ... -> rhs_2
+          ...
+          Kn ... -> rhs_n
+          _ -> nullary_rhs
+
+* To make rhs_i
+     If i = 1, 2, n-1, n, generate a single case.
+        rhs_2    case b of
+                   K1 {}  -> LT
+                   K2 ... -> ...eq_rhs(K2)...
+                   _      -> GT
+
+     Otherwise do a tag compare against the bigger range
+     (because this is the one most likely to succeed)
+        rhs_3    case tag b of tb ->
+                 if 3 <# tg then GT
+                 else case b of
+                         K3 ... -> ...eq_rhs(K3)....
+                         _      -> LT
+
+* To make eq_rhs(K), which knows that
+    a = K a1 .. av
+    b = K b1 .. bv
+  we just want to compare (a1,b1) then (a2,b2) etc.
+  Take care on the last field to tail-call into comparing av,bv
+
+* To make nullary_rhs generate this
+     case con2tag a of a# ->
+     case con2tag b of ->
+     a# `compare` b#
+
+Several special cases:
+
+* Two or fewer nullary constructors: don't generate nullary_rhs
+
+* Be careful about unlifted comparisons.  When comparing unboxed
+  values we can't call the overloaded functions.
+  See function unliftedOrdOp
+
+Note [Game plan for deriving Ord]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's a bad idea to define only 'compare', and build the other binary
+comparisons on top of it; see Trac #2130, #4019.  Reason: we don't
+want to laboriously make a three-way comparison, only to extract a
+binary result, something like this:
+     (>) (I# x) (I# y) = case <# x y of
+                            True -> False
+                            False -> case ==# x y of
+                                       True  -> False
+                                       False -> True
+
+This being said, we can get away with generating full code only for
+'compare' and '<' thus saving us generation of other three operators.
+Other operators can be cheaply expressed through '<':
+a <= b = not $ b < a
+a > b = b < a
+a >= b = not $ a < b
+
+So for sufficiently small types (few constructors, or all nullary)
+we generate all methods; for large ones we just use 'compare'.
+
+-}
+
+data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
+
+------------
+ordMethRdr :: OrdOp -> RdrName
+ordMethRdr op
+  = case op of
+       OrdCompare -> compare_RDR
+       OrdLT      -> lt_RDR
+       OrdLE      -> le_RDR
+       OrdGE      -> ge_RDR
+       OrdGT      -> gt_RDR
+
+------------
+ltResult :: OrdOp -> LHsExpr GhcPs
+-- Knowing a<b, what is the result for a `op` b?
+ltResult OrdCompare = ltTag_Expr
+ltResult OrdLT      = true_Expr
+ltResult OrdLE      = true_Expr
+ltResult OrdGE      = false_Expr
+ltResult OrdGT      = false_Expr
+
+------------
+eqResult :: OrdOp -> LHsExpr GhcPs
+-- Knowing a=b, what is the result for a `op` b?
+eqResult OrdCompare = eqTag_Expr
+eqResult OrdLT      = false_Expr
+eqResult OrdLE      = true_Expr
+eqResult OrdGE      = true_Expr
+eqResult OrdGT      = false_Expr
+
+------------
+gtResult :: OrdOp -> LHsExpr GhcPs
+-- Knowing a>b, what is the result for a `op` b?
+gtResult OrdCompare = gtTag_Expr
+gtResult OrdLT      = false_Expr
+gtResult OrdLE      = false_Expr
+gtResult OrdGE      = true_Expr
+gtResult OrdGT      = true_Expr
+
+------------
+gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Ord_binds loc tycon = do
+    dflags <- getDynFlags
+    return $ if null tycon_data_cons -- No data-cons => invoke bale-out case
+      then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []
+           , emptyBag)
+      else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags
+           , aux_binds)
+  where
+    aux_binds | single_con_type = emptyBag
+              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
+
+        -- Note [Game plan for deriving Ord]
+    other_ops dflags
+      | (last_tag - first_tag) <= 2     -- 1-3 constructors
+        || null non_nullary_cons        -- Or it's an enumeration
+      = listToBag [mkOrdOp dflags OrdLT, lE, gT, gE]
+      | otherwise
+      = emptyBag
+
+    negate_expr = nlHsApp (nlHsVar not_RDR)
+    lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $
+        negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)
+    gT = mk_easy_FunBind loc gt_RDR [a_Pat, b_Pat] $
+        nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr
+    gE = mk_easy_FunBind loc ge_RDR [a_Pat, b_Pat] $
+        negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr)
+
+    get_tag con = dataConTag con - fIRST_TAG
+        -- We want *zero-based* tags, because that's what
+        -- con2Tag returns (generated by untag_Expr)!
+
+    tycon_data_cons = tyConDataCons tycon
+    single_con_type = isSingleton tycon_data_cons
+    (first_con : _) = tycon_data_cons
+    (last_con : _)  = reverse tycon_data_cons
+    first_tag       = get_tag first_con
+    last_tag        = get_tag last_con
+
+    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
+
+
+    mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs
+    -- Returns a binding   op a b = ... compares a and b according to op ....
+    mkOrdOp dflags op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat]
+                                        (mkOrdOpRhs dflags op)
+
+    mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs
+    mkOrdOpRhs dflags op       -- RHS for comparing 'a' and 'b' according to op
+      | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases
+      = nlHsCase (nlHsVar a_RDR) $
+        map (mkOrdOpAlt dflags op) tycon_data_cons
+        -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
+        --                   C2 x   -> case b of C2 x -> ....comopare x.... }
+
+      | null non_nullary_cons    -- All nullary, so go straight to comparing tags
+      = mkTagCmp dflags op
+
+      | otherwise                -- Mixed nullary and non-nullary
+      = nlHsCase (nlHsVar a_RDR) $
+        (map (mkOrdOpAlt dflags op) non_nullary_cons
+         ++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)])
+
+
+    mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon
+                  -> LMatch GhcPs (LHsExpr GhcPs)
+    -- Make the alternative  (Ki a1 a2 .. av ->
+    mkOrdOpAlt dflags op data_con
+      = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
+                    (mkInnerRhs dflags op data_con)
+      where
+        as_needed    = take (dataConSourceArity data_con) as_RDRs
+        data_con_RDR = getRdrName data_con
+
+    mkInnerRhs dflags op data_con
+      | single_con_type
+      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]
+
+      | tag == first_tag
+      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
+      | tag == last_tag
+      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
+
+      | tag == first_tag + 1
+      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)
+                                             (gtResult op)
+                                 , mkInnerEqAlt op data_con
+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
+      | tag == last_tag - 1
+      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)
+                                             (ltResult op)
+                                 , mkInnerEqAlt op data_con
+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
+
+      | tag > last_tag `div` 2  -- lower range is larger
+      = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
+        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
+               (gtResult op) $  -- Definitely GT
+        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
+
+      | otherwise               -- upper range is larger
+      = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
+        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
+               (ltResult op) $  -- Definitely LT
+        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
+      where
+        tag     = get_tag data_con
+        tag_lit = noLoc (HsLit noExt (HsIntPrim NoSourceText (toInteger tag)))
+
+    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
+    -- First argument 'a' known to be built with K
+    -- Returns a case alternative  Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
+    mkInnerEqAlt op data_con
+      = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
+        mkCompareFields op (dataConOrigArgTys data_con)
+      where
+        data_con_RDR = getRdrName data_con
+        bs_needed    = take (dataConSourceArity data_con) bs_RDRs
+
+    mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs
+    -- Both constructors known to be nullary
+    -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
+    mkTagCmp dflags op =
+      untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
+        unliftedOrdOp intPrimTy op ah_RDR bh_RDR
+
+mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs
+-- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
+-- where the ai,bi have the given types
+mkCompareFields op tys
+  = go tys as_RDRs bs_RDRs
+  where
+    go []   _      _          = eqResult op
+    go [ty] (a:_)  (b:_)
+      | isUnliftedType ty     = unliftedOrdOp ty op a b
+      | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
+    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
+                                  (ltResult op)
+                                  (go tys as bs)
+                                  (gtResult op)
+    go _ _ _ = panic "mkCompareFields"
+
+    -- (mk_compare ty a b) generates
+    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
+    -- but with suitable special cases for
+    mk_compare ty a b lt eq gt
+      | isUnliftedType ty
+      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
+      | otherwise
+      = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
+          [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,
+           mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,
+           mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]
+      where
+        a_expr = nlHsVar a
+        b_expr = nlHsVar b
+        (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty
+
+unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
+unliftedOrdOp ty op a b
+  = case op of
+       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
+                                     ltTag_Expr eqTag_Expr gtTag_Expr
+       OrdLT      -> wrap lt_op
+       OrdLE      -> wrap le_op
+       OrdGE      -> wrap ge_op
+       OrdGT      -> wrap gt_op
+  where
+   (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty
+   wrap prim_op = genPrimOpApp a_expr prim_op b_expr
+   a_expr = nlHsVar a
+   b_expr = nlHsVar b
+
+unliftedCompare :: RdrName -> RdrName
+                -> LHsExpr GhcPs -> LHsExpr GhcPs   -- What to cmpare
+                -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+                                                    -- Three results
+                -> LHsExpr GhcPs
+-- Return (if a < b then lt else if a == b then eq else gt)
+unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
+  = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $
+                        -- Test (<) first, not (==), because the latter
+                        -- is true less often, so putting it first would
+                        -- mean more tests (dynamically)
+        nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt
+  where
+    ascribeBool e = nlExprWithTySig e boolTy
+
+nlConWildPat :: DataCon -> LPat GhcPs
+-- The pattern (K {})
+nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
+                                   (RecCon (HsRecFields { rec_flds = []
+                                                        , rec_dotdot = Nothing })))
+
+{-
+************************************************************************
+*                                                                      *
+        Enum instances
+*                                                                      *
+************************************************************************
+
+@Enum@ can only be derived for enumeration types.  For a type
+\begin{verbatim}
+data Foo ... = N1 | N2 | ... | Nn
+\end{verbatim}
+
+we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
+@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
+
+\begin{verbatim}
+instance ... Enum (Foo ...) where
+    succ x   = toEnum (1 + fromEnum x)
+    pred x   = toEnum (fromEnum x - 1)
+
+    toEnum i = tag2con_Foo i
+
+    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
+
+    -- or, really...
+    enumFrom a
+      = case con2tag_Foo a of
+          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
+
+   enumFromThen a b
+     = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
+
+    -- or, really...
+    enumFromThen a b
+      = case con2tag_Foo a of { a# ->
+        case con2tag_Foo b of { b# ->
+        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
+        }}
+\end{verbatim}
+
+For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
+-}
+
+gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Enum_binds loc tycon = do
+    dflags <- getDynFlags
+    return (method_binds dflags, aux_binds)
+  where
+    method_binds dflags = listToBag
+      [ succ_enum      dflags
+      , pred_enum      dflags
+      , to_enum        dflags
+      , enum_from      dflags
+      , enum_from_then dflags
+      , from_enum      dflags
+      ]
+    aux_binds = listToBag $ map DerivAuxBind
+                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
+
+    occ_nm = getOccString tycon
+
+    succ_enum dflags
+      = mk_easy_FunBind loc succ_RDR [a_Pat] $
+        untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
+        nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon),
+                               nlHsVarApps intDataCon_RDR [ah_RDR]])
+             (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
+             (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
+                    (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
+                                        nlHsIntLit 1]))
+
+    pred_enum dflags
+      = mk_easy_FunBind loc pred_RDR [a_Pat] $
+        untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
+        nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
+                               nlHsVarApps intDataCon_RDR [ah_RDR]])
+             (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
+             (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
+                      (nlHsApps plus_RDR
+                            [ nlHsVarApps intDataCon_RDR [ah_RDR]
+                            , nlHsLit (HsInt noExt
+                                                (mkIntegralLit (-1 :: Int)))]))
+
+    to_enum dflags
+      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
+        nlHsIf (nlHsApps and_RDR
+                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
+                 nlHsApps le_RDR [ nlHsVar a_RDR
+                                 , nlHsVar (maxtag_RDR dflags tycon)]])
+             (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR])
+             (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon))
+
+    enum_from dflags
+      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
+          nlHsApps map_RDR
+                [nlHsVar (tag2con_RDR dflags tycon),
+                 nlHsPar (enum_from_to_Expr
+                            (nlHsVarApps intDataCon_RDR [ah_RDR])
+                            (nlHsVar (maxtag_RDR dflags tycon)))]
+
+    enum_from_then dflags
+      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
+          untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
+          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
+            nlHsPar (enum_from_then_to_Expr
+                    (nlHsVarApps intDataCon_RDR [ah_RDR])
+                    (nlHsVarApps intDataCon_RDR [bh_RDR])
+                    (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
+                                               nlHsVarApps intDataCon_RDR [bh_RDR]])
+                           (nlHsIntLit 0)
+                           (nlHsVar (maxtag_RDR dflags tycon))
+                           ))
+
+    from_enum dflags
+      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
+          (nlHsVarApps intDataCon_RDR [ah_RDR])
+
+{-
+************************************************************************
+*                                                                      *
+        Bounded instances
+*                                                                      *
+************************************************************************
+-}
+
+gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Bounded_binds loc tycon
+  | isEnumerationTyCon tycon
+  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
+  | otherwise
+  = ASSERT(isSingleton data_cons)
+    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
+  where
+    data_cons = tyConDataCons tycon
+
+    ----- enum-flavored: ---------------------------
+    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
+    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
+
+    data_con_1     = head data_cons
+    data_con_N     = last data_cons
+    data_con_1_RDR = getRdrName data_con_1
+    data_con_N_RDR = getRdrName data_con_N
+
+    ----- single-constructor-flavored: -------------
+    arity          = dataConSourceArity data_con_1
+
+    min_bound_1con = mkHsVarBind loc minBound_RDR $
+                     nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
+    max_bound_1con = mkHsVarBind loc maxBound_RDR $
+                     nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
+
+{-
+************************************************************************
+*                                                                      *
+        Ix instances
+*                                                                      *
+************************************************************************
+
+Deriving @Ix@ is only possible for enumeration types and
+single-constructor types.  We deal with them in turn.
+
+For an enumeration type, e.g.,
+\begin{verbatim}
+    data Foo ... = N1 | N2 | ... | Nn
+\end{verbatim}
+things go not too differently from @Enum@:
+\begin{verbatim}
+instance ... Ix (Foo ...) where
+    range (a, b)
+      = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
+
+    -- or, really...
+    range (a, b)
+      = case (con2tag_Foo a) of { a# ->
+        case (con2tag_Foo b) of { b# ->
+        map tag2con_Foo (enumFromTo (I# a#) (I# b#))
+        }}
+
+    -- Generate code for unsafeIndex, because using index leads
+    -- to lots of redundant range tests
+    unsafeIndex c@(a, b) d
+      = case (con2tag_Foo d -# con2tag_Foo a) of
+               r# -> I# r#
+
+    inRange (a, b) c
+      = let
+            p_tag = con2tag_Foo c
+        in
+        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
+
+    -- or, really...
+    inRange (a, b) c
+      = case (con2tag_Foo a)   of { a_tag ->
+        case (con2tag_Foo b)   of { b_tag ->
+        case (con2tag_Foo c)   of { c_tag ->
+        if (c_tag >=# a_tag) then
+          c_tag <=# b_tag
+        else
+          False
+        }}}
+\end{verbatim}
+(modulo suitable case-ification to handle the unlifted tags)
+
+For a single-constructor type (NB: this includes all tuples), e.g.,
+\begin{verbatim}
+    data Foo ... = MkFoo a b Int Double c c
+\end{verbatim}
+we follow the scheme given in Figure~19 of the Haskell~1.2 report
+(p.~147).
+-}
+
+gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
+
+gen_Ix_binds loc tycon = do
+    dflags <- getDynFlags
+    return $ if isEnumerationTyCon tycon
+      then (enum_ixes dflags, listToBag $ map DerivAuxBind
+                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
+      else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
+  where
+    --------------------------------------------------------------
+    enum_ixes dflags = listToBag
+      [ enum_range   dflags
+      , enum_index   dflags
+      , enum_inRange dflags
+      ]
+
+    enum_range dflags
+      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
+          untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
+          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
+              nlHsPar (enum_from_to_Expr
+                        (nlHsVarApps intDataCon_RDR [ah_RDR])
+                        (nlHsVarApps intDataCon_RDR [bh_RDR]))
+
+    enum_index dflags
+      = mk_easy_FunBind loc unsafeIndex_RDR
+                [noLoc (AsPat noExt (noLoc c_RDR)
+                           (nlTuplePat [a_Pat, nlWildPat] Boxed)),
+                                d_Pat] (
+           untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
+           untag_Expr dflags tycon [(d_RDR, dh_RDR)] (
+           let
+                rhs = nlHsVarApps intDataCon_RDR [c_RDR]
+           in
+           nlHsCase
+             (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
+             [mkHsCaseAlt (nlVarPat c_RDR) rhs]
+           ))
+        )
+
+    -- This produces something like `(ch >= ah) && (ch <= bh)`
+    enum_inRange dflags
+      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
+          untag_Expr dflags tycon [(b_RDR, bh_RDR)] (
+          untag_Expr dflags tycon [(c_RDR, ch_RDR)] (
+          -- This used to use `if`, which interacts badly with RebindableSyntax.
+          -- See #11396.
+          nlHsApps and_RDR
+              [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)
+              , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)
+              ]
+          )))
+
+    --------------------------------------------------------------
+    single_con_ixes
+      = listToBag [single_con_range, single_con_index, single_con_inRange]
+
+    data_con
+      = case tyConSingleDataCon_maybe tycon of -- just checking...
+          Nothing -> panic "get_Ix_binds"
+          Just dc -> dc
+
+    con_arity    = dataConSourceArity data_con
+    data_con_RDR = getRdrName data_con
+
+    as_needed = take con_arity as_RDRs
+    bs_needed = take con_arity bs_RDRs
+    cs_needed = take con_arity cs_RDRs
+
+    con_pat  xs  = nlConVarPat data_con_RDR xs
+    con_expr     = nlHsVarApps data_con_RDR cs_needed
+
+    --------------------------------------------------------------
+    single_con_range
+      = mk_easy_FunBind loc range_RDR
+          [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
+        noLoc (mkHsComp ListComp stmts con_expr)
+      where
+        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
+
+        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
+                                 (nlHsApp (nlHsVar range_RDR)
+                                          (mkLHsVarTuple [a,b]))
+
+    ----------------
+    single_con_index
+      = mk_easy_FunBind loc unsafeIndex_RDR
+                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
+                 con_pat cs_needed]
+        -- We need to reverse the order we consider the components in
+        -- so that
+        --     range (l,u) !! index (l,u) i == i   -- when i is in range
+        -- (from http://haskell.org/onlinereport/ix.html) holds.
+                (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
+      where
+        -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
+        mk_index []        = nlHsIntLit 0
+        mk_index [(l,u,i)] = mk_one l u i
+        mk_index ((l,u,i) : rest)
+          = genOpApp (
+                mk_one l u i
+            ) plus_RDR (
+                genOpApp (
+                    (nlHsApp (nlHsVar unsafeRangeSize_RDR)
+                             (mkLHsVarTuple [l,u]))
+                ) times_RDR (mk_index rest)
+           )
+        mk_one l u i
+          = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
+
+    ------------------
+    single_con_inRange
+      = mk_easy_FunBind loc inRange_RDR
+                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
+                 con_pat cs_needed] $
+          if con_arity == 0
+             -- If the product type has no fields, inRange is trivially true
+             -- (see Trac #12853).
+             then true_Expr
+             else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range
+                    as_needed bs_needed cs_needed)
+      where
+        in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
+
+{-
+************************************************************************
+*                                                                      *
+        Read instances
+*                                                                      *
+************************************************************************
+
+Example
+
+  infix 4 %%
+  data T = Int %% Int
+         | T1 { f1 :: Int }
+         | T2 T
+
+instance Read T where
+  readPrec =
+    parens
+    ( prec 4 (
+        do x <- ReadP.step Read.readPrec
+           expectP (Symbol "%%")
+           y <- ReadP.step Read.readPrec
+           return (x %% y))
+      +++
+      prec (appPrec+1) (
+        -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
+        -- Record construction binds even more tightly than application
+        do expectP (Ident "T1")
+           expectP (Punc '{')
+           x          <- Read.readField "f1" (ReadP.reset readPrec)
+           expectP (Punc '}')
+           return (T1 { f1 = x }))
+      +++
+      prec appPrec (
+        do expectP (Ident "T2")
+           x <- ReadP.step Read.readPrec
+           return (T2 x))
+    )
+
+  readListPrec = readListPrecDefault
+  readList     = readListDefault
+
+
+Note [Use expectP]
+~~~~~~~~~~~~~~~~~~
+Note that we use
+   expectP (Ident "T1")
+rather than
+   Ident "T1" <- lexP
+The latter desugares to inline code for matching the Ident and the
+string, and this can be very voluminous. The former is much more
+compact.  Cf Trac #7258, although that also concerned non-linearity in
+the occurrence analyser, a separate issue.
+
+Note [Read for empty data types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What should we get for this?  (Trac #7931)
+   data Emp deriving( Read )   -- No data constructors
+
+Here we want
+  read "[]" :: [Emp]   to succeed, returning []
+So we do NOT want
+   instance Read Emp where
+     readPrec = error "urk"
+Rather we want
+   instance Read Emp where
+     readPred = pfail   -- Same as choose []
+
+Because 'pfail' allows the parser to backtrack, but 'error' doesn't.
+These instances are also useful for Read (Either Int Emp), where
+we want to be able to parse (Left 3) just fine.
+-}
+
+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
+               -> (LHsBinds GhcPs, BagDerivStuff)
+
+gen_Read_binds get_fixity loc tycon
+  = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
+  where
+    -----------------------------------------------------------------------
+    default_readlist
+        = mkHsVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
+
+    default_readlistprec
+        = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
+    -----------------------------------------------------------------------
+
+    data_cons = tyConDataCons tycon
+    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
+
+    read_prec = mkHsVarBind loc readPrec_RDR rhs
+      where
+        rhs | null data_cons -- See Note [Read for empty data types]
+            = nlHsVar pfail_RDR
+            | otherwise
+            = nlHsApp (nlHsVar parens_RDR)
+                      (foldr1 mk_alt (read_nullary_cons ++
+                                      read_non_nullary_cons))
+
+    read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
+
+    read_nullary_cons
+      = case nullary_cons of
+            []    -> []
+            [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
+            _     -> [nlHsApp (nlHsVar choose_RDR)
+                              (nlList (map mk_pair nullary_cons))]
+        -- NB For operators the parens around (:=:) are matched by the
+        -- enclosing "parens" call, so here we must match the naked
+        -- data_con_str con
+
+    match_con con | isSym con_str = [symbol_pat con_str]
+                  | otherwise     = ident_h_pat  con_str
+                  where
+                    con_str = data_con_str con
+        -- For nullary constructors we must match Ident s for normal constrs
+        -- and   Symbol s   for operators
+
+    mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
+                                  result_expr con []]
+
+    read_non_nullary_con data_con
+      | is_infix  = mk_parser infix_prec  infix_stmts  body
+      | is_record = mk_parser record_prec record_stmts body
+--              Using these two lines instead allows the derived
+--              read for infix and record bindings to read the prefix form
+--      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
+--      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
+      | otherwise = prefix_parser
+      where
+        body = result_expr data_con as_needed
+        con_str = data_con_str data_con
+
+        prefix_parser = mk_parser prefix_prec prefix_stmts body
+
+        read_prefix_con
+            | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
+            | otherwise     = ident_h_pat con_str
+
+        read_infix_con
+            | isSym con_str = [symbol_pat con_str]
+            | otherwise     = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
+
+        prefix_stmts            -- T a b c
+          = read_prefix_con ++ read_args
+
+        infix_stmts             -- a %% b, or  a `T` b
+          = [read_a1]
+            ++ read_infix_con
+            ++ [read_a2]
+
+        record_stmts            -- T { f1 = a, f2 = b }
+          = read_prefix_con
+            ++ [read_punc "{"]
+            ++ concat (intersperse [read_punc ","] field_stmts)
+            ++ [read_punc "}"]
+
+        field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
+
+        con_arity    = dataConSourceArity data_con
+        labels       = map flLabel $ dataConFieldLabels data_con
+        dc_nm        = getName data_con
+        is_infix     = dataConIsInfix data_con
+        is_record    = labels `lengthExceeds` 0
+        as_needed    = take con_arity as_RDRs
+        read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
+        (read_a1:read_a2:_) = read_args
+
+        prefix_prec = appPrecedence
+        infix_prec  = getPrecedence get_fixity dc_nm
+        record_prec = appPrecedence + 1 -- Record construction binds even more tightly
+                                        -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
+
+    ------------------------------------------------------------------------
+    --          Helpers
+    ------------------------------------------------------------------------
+    mk_alt e1 e2       = genOpApp e1 alt_RDR e2                         -- e1 +++ e2
+    mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p                -- prec p (do { ss ; b })
+                                           , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
+    con_app con as     = nlHsVarApps (getRdrName con) as                -- con as
+    result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
+
+    -- For constructors and field labels ending in '#', we hackily
+    -- let the lexer generate two tokens, and look for both in sequence
+    -- Thus [Ident "I"; Symbol "#"].  See Trac #5041
+    ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
+                  | otherwise                    = [ ident_pat s ]
+
+    bindLex pat  = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat))  -- expectP p
+                   -- See Note [Use expectP]
+    ident_pat  s = bindLex $ nlHsApps ident_RDR  [nlHsLit (mkHsString s)]  -- expectP (Ident "foo")
+    symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)]  -- expectP (Symbol ">>")
+    read_punc c  = bindLex $ nlHsApps punc_RDR   [nlHsLit (mkHsString c)]  -- expectP (Punc "<")
+
+    data_con_str con = occNameString (getOccName con)
+
+    read_arg a ty = ASSERT( not (isUnliftedType ty) )
+                    noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
+
+    -- When reading field labels we might encounter
+    --      a  = 3
+    --      _a = 3
+    -- or   (#) = 4
+    -- Note the parens!
+    read_field lbl a =
+        [noLoc
+          (mkBindStmt
+            (nlVarPat a)
+            (nlHsApp
+              read_field
+              (nlHsVarApps reset_RDR [readPrec_RDR])
+            )
+          )
+        ]
+        where
+          lbl_str = unpackFS lbl
+          mk_read_field read_field_rdr lbl
+              = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)]
+          read_field
+              | isSym lbl_str
+              = mk_read_field readSymField_RDR lbl_str
+              | Just (ss, '#') <- snocView lbl_str -- #14918
+              = mk_read_field readFieldHash_RDR ss
+              | otherwise
+              = mk_read_field readField_RDR lbl_str
+
+{-
+************************************************************************
+*                                                                      *
+        Show instances
+*                                                                      *
+************************************************************************
+
+Example
+
+    infixr 5 :^:
+
+    data Tree a =  Leaf a  |  Tree a :^: Tree a
+
+    instance (Show a) => Show (Tree a) where
+
+        showsPrec d (Leaf m) = showParen (d > app_prec) showStr
+          where
+             showStr = showString "Leaf " . showsPrec (app_prec+1) m
+
+        showsPrec d (u :^: v) = showParen (d > up_prec) showStr
+          where
+             showStr = showsPrec (up_prec+1) u .
+                       showString " :^: "      .
+                       showsPrec (up_prec+1) v
+                -- Note: right-associativity of :^: ignored
+
+    up_prec  = 5    -- Precedence of :^:
+    app_prec = 10   -- Application has precedence one more than
+                    -- the most tightly-binding operator
+-}
+
+gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
+               -> (LHsBinds GhcPs, BagDerivStuff)
+
+gen_Show_binds get_fixity loc tycon
+  = (unitBag shows_prec, emptyBag)
+  where
+    data_cons = tyConDataCons tycon
+    shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)
+    comma_space = nlHsVar showCommaSpace_RDR
+
+    pats_etc data_con
+      | nullary_con =  -- skip the showParen junk...
+         ASSERT(null bs_needed)
+         ([nlWildPat, con_pat], mk_showString_app op_con_str)
+      | otherwise   =
+         ([a_Pat, con_pat],
+          showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit
+                         (HsInt noExt (mkIntegralLit con_prec_plus_one))))
+                         (nlHsPar (nested_compose_Expr show_thingies)))
+        where
+             data_con_RDR  = getRdrName data_con
+             con_arity     = dataConSourceArity data_con
+             bs_needed     = take con_arity bs_RDRs
+             arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
+             con_pat       = nlConVarPat data_con_RDR bs_needed
+             nullary_con   = con_arity == 0
+             labels        = map flLabel $ dataConFieldLabels data_con
+             lab_fields    = length labels
+             record_syntax = lab_fields > 0
+
+             dc_nm          = getName data_con
+             dc_occ_nm      = getOccName data_con
+             con_str        = occNameString dc_occ_nm
+             op_con_str     = wrapOpParens con_str
+             backquote_str  = wrapOpBackquotes con_str
+
+             show_thingies
+                | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
+                | record_syntax = mk_showString_app (op_con_str ++ " {") :
+                                  show_record_args ++ [mk_showString_app "}"]
+                | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
+
+             show_label l = mk_showString_app (nm ++ " = ")
+                        -- Note the spaces around the "=" sign.  If we
+                        -- don't have them then we get Foo { x=-1 } and
+                        -- the "=-" parses as a single lexeme.  Only the
+                        -- space after the '=' is necessary, but it
+                        -- seems tidier to have them both sides.
+                 where
+                   nm       = wrapOpParens (unpackFS l)
+
+             show_args               = zipWith show_arg bs_needed arg_tys
+             (show_arg1:show_arg2:_) = show_args
+             show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
+
+                -- Assumption for record syntax: no of fields == no of
+                -- labelled fields (and in same order)
+             show_record_args = concat $
+                                intersperse [comma_space] $
+                                [ [show_label lbl, arg]
+                                | (lbl,arg) <- zipEqual "gen_Show_binds"
+                                                        labels show_args ]
+
+             show_arg :: RdrName -> Type -> LHsExpr GhcPs
+             show_arg b arg_ty
+                 | isUnliftedType arg_ty
+                 -- See Note [Deriving and unboxed types] in TcDerivInfer
+                 = with_conv $
+                    nlHsApps compose_RDR
+                        [mk_shows_app boxed_arg, mk_showString_app postfixMod]
+                 | otherwise
+                 = mk_showsPrec_app arg_prec arg
+               where
+                 arg        = nlHsVar b
+                 boxed_arg  = box "Show" arg arg_ty
+                 postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty
+                 with_conv expr
+                    | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty =
+                        nested_compose_Expr
+                            [ mk_showString_app ("(" ++ conv ++ " ")
+                            , expr
+                            , mk_showString_app ")"
+                            ]
+                    | otherwise = expr
+
+                -- Fixity stuff
+             is_infix = dataConIsInfix data_con
+             con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
+             arg_prec | record_syntax = 0  -- Record fields don't need parens
+                      | otherwise     = con_prec_plus_one
+
+wrapOpParens :: String -> String
+wrapOpParens s | isSym s   = '(' : s ++ ")"
+               | otherwise = s
+
+wrapOpBackquotes :: String -> String
+wrapOpBackquotes s | isSym s   = s
+                   | otherwise = '`' : s ++ "`"
+
+isSym :: String -> Bool
+isSym ""      = False
+isSym (c : _) = startsVarSym c || startsConSym c
+
+-- | showString :: String -> ShowS
+mk_showString_app :: String -> LHsExpr GhcPs
+mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
+
+-- | showsPrec :: Show a => Int -> a -> ShowS
+mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs
+mk_showsPrec_app p x
+  = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExt (mkIntegralLit p)), x]
+
+-- | shows :: Show a => a -> ShowS
+mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
+mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
+
+getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
+getPrec is_infix get_fixity nm
+  | not is_infix   = appPrecedence
+  | otherwise      = getPrecedence get_fixity nm
+
+appPrecedence :: Integer
+appPrecedence = fromIntegral maxPrecedence + 1
+  -- One more than the precedence of the most
+  -- tightly-binding operator
+
+getPrecedence :: (Name -> Fixity) -> Name -> Integer
+getPrecedence get_fixity nm
+   = case get_fixity nm of
+        Fixity _ x _assoc -> fromIntegral x
+          -- NB: the Report says that associativity is not taken
+          --     into account for either Read or Show; hence we
+          --     ignore associativity here
+
+{-
+************************************************************************
+*                                                                      *
+        Data instances
+*                                                                      *
+************************************************************************
+
+From the data type
+
+  data T a b = T1 a b | T2
+
+we generate
+
+  $cT1 = mkDataCon $dT "T1" Prefix
+  $cT2 = mkDataCon $dT "T2" Prefix
+  $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
+  -- the [] is for field labels.
+
+  instance (Data a, Data b) => Data (T a b) where
+    gfoldl k z (T1 a b) = z T `k` a `k` b
+    gfoldl k z T2           = z T2
+    -- ToDo: add gmapT,Q,M, gfoldr
+
+    gunfold k z c = case conIndex c of
+                        I# 1# -> k (k (z T1))
+                        I# 2# -> z T2
+
+    toConstr (T1 _ _) = $cT1
+    toConstr T2       = $cT2
+
+    dataTypeOf _ = $dT
+
+    dataCast1 = gcast1   -- If T :: * -> *
+    dataCast2 = gcast2   -- if T :: * -> * -> *
+-}
+
+gen_Data_binds :: SrcSpan
+               -> TyCon                 -- For data families, this is the
+                                        --  *representation* TyCon
+               -> TcM (LHsBinds GhcPs,  -- The method bindings
+                       BagDerivStuff)   -- Auxiliary bindings
+gen_Data_binds loc rep_tc
+  = do { dflags  <- getDynFlags
+
+       -- Make unique names for the data type and constructor
+       -- auxiliary bindings.  Start with the name of the TyCon/DataCon
+       -- but that might not be unique: see Trac #12245.
+       ; dt_occ  <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc))
+       ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName)
+                         (tyConDataCons rep_tc)
+       ; let dt_rdr  = mkRdrUnqual dt_occ
+             dc_rdrs = map mkRdrUnqual dc_occs
+
+       -- OK, now do the work
+       ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) }
+
+gen_data :: DynFlags -> RdrName -> [RdrName]
+         -> SrcSpan -> TyCon
+         -> (LHsBinds GhcPs,      -- The method bindings
+             BagDerivStuff)       -- Auxiliary bindings
+gen_data dflags data_type_name constr_names loc rep_tc
+  = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
+     `unionBags` gcast_binds,
+                -- Auxiliary definitions: the data type and constructors
+     listToBag ( genDataTyCon
+               : zipWith genDataDataCon data_cons constr_names ) )
+  where
+    data_cons  = tyConDataCons rep_tc
+    n_cons     = length data_cons
+    one_constr = n_cons == 1
+    genDataTyCon :: DerivStuff
+    genDataTyCon        --  $dT
+      = DerivHsBind (mkHsVarBind loc data_type_name rhs,
+                     L loc (TypeSig noExt [L loc data_type_name] sig_ty))
+
+    sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
+    rhs    = nlHsVar mkDataType_RDR
+             `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
+             `nlHsApp` nlList (map nlHsVar constr_names)
+
+    genDataDataCon :: DataCon -> RdrName -> DerivStuff
+    genDataDataCon dc constr_name       --  $cT1 etc
+      = DerivHsBind (mkHsVarBind loc constr_name rhs,
+                     L loc (TypeSig noExt [L loc constr_name] sig_ty))
+      where
+        sig_ty   = mkLHsSigWcType (nlHsTyVar constr_RDR)
+        rhs      = nlHsApps mkConstr_RDR constr_args
+
+        constr_args
+           = [ -- nlHsIntLit (toInteger (dataConTag dc)),   -- Tag
+               nlHsVar (data_type_name)                     -- DataType
+             , nlHsLit (mkHsString (occNameString dc_occ))  -- String name
+             , nlList  labels                               -- Field labels
+             , nlHsVar fixity ]                             -- Fixity
+
+        labels   = map (nlHsLit . mkHsString . unpackFS . flLabel)
+                       (dataConFieldLabels dc)
+        dc_occ   = getOccName dc
+        is_infix = isDataSymOcc dc_occ
+        fixity | is_infix  = infix_RDR
+               | otherwise = prefix_RDR
+
+        ------------ gfoldl
+    gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons)
+
+    gfoldl_eqn con
+      = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
+                   foldl' mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed)
+                   where
+                     con_name ::  RdrName
+                     con_name = getRdrName con
+                     as_needed = take (dataConSourceArity con) as_RDRs
+                     mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
+
+        ------------ gunfold
+    gunfold_bind = mk_easy_FunBind loc
+                     gunfold_RDR
+                     [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat]
+                     gunfold_rhs
+
+    gunfold_rhs
+        | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
+        | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
+                                (map gunfold_alt data_cons)
+
+    gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
+    mk_unfold_rhs dc = foldr nlHsApp
+                           (z_Expr `nlHsApp` nlHsVar (getRdrName dc))
+                           (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
+
+    mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
+                        -- redundant test, and annoying warning
+      | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
+      | otherwise = nlConPat intDataCon_RDR
+                             [nlLitPat (HsIntPrim NoSourceText (toInteger tag))]
+      where
+        tag = dataConTag dc
+
+        ------------ toConstr
+    toCon_bind = mkFunBindEC 1 loc toConstr_RDR id
+                     (zipWith to_con_eqn data_cons constr_names)
+    to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
+
+        ------------ dataTypeOf
+    dataTypeOf_bind = mk_easy_FunBind
+                        loc
+                        dataTypeOf_RDR
+                        [nlWildPat]
+                        (nlHsVar data_type_name)
+
+        ------------ gcast1/2
+        -- Make the binding    dataCast1 x = gcast1 x  -- if T :: * -> *
+        --               or    dataCast2 x = gcast2 s  -- if T :: * -> * -> *
+        -- (or nothing if T has neither of these two types)
+
+        -- But care is needed for data families:
+        -- If we have   data family D a
+        --              data instance D (a,b,c) = A | B deriving( Data )
+        -- and we want  instance ... => Data (D [(a,b,c)]) where ...
+        -- then we need     dataCast1 x = gcast1 x
+        -- because D :: * -> *
+        -- even though rep_tc has kind * -> * -> * -> *
+        -- Hence looking for the kind of fam_tc not rep_tc
+        -- See Trac #4896
+    tycon_kind = case tyConFamInst_maybe rep_tc of
+                    Just (fam_tc, _) -> tyConKind fam_tc
+                    Nothing          -> tyConKind rep_tc
+    gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
+                | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
+                | otherwise                 = emptyBag
+    mk_gcast dataCast_RDR gcast_RDR
+      = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
+                                 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
+
+
+kind1, kind2 :: Kind
+kind1 = liftedTypeKind `mkFunTy` liftedTypeKind
+kind2 = liftedTypeKind `mkFunTy` kind1
+
+gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
+    mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
+    dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
+    constr_RDR, dataType_RDR,
+    eqChar_RDR  , ltChar_RDR  , geChar_RDR  , gtChar_RDR  , leChar_RDR  ,
+    eqInt_RDR   , ltInt_RDR   , geInt_RDR   , gtInt_RDR   , leInt_RDR   ,
+    eqInt8_RDR  , ltInt8_RDR  , geInt8_RDR  , gtInt8_RDR  , leInt8_RDR  ,
+    eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR ,
+    eqWord_RDR  , ltWord_RDR  , geWord_RDR  , gtWord_RDR  , leWord_RDR  ,
+    eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR ,
+    eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR,
+    eqAddr_RDR  , ltAddr_RDR  , geAddr_RDR  , gtAddr_RDR  , leAddr_RDR  ,
+    eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
+    eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,
+    extendWord8_RDR, extendInt8_RDR,
+    extendWord16_RDR, extendInt16_RDR :: RdrName
+gfoldl_RDR     = varQual_RDR  gENERICS (fsLit "gfoldl")
+gunfold_RDR    = varQual_RDR  gENERICS (fsLit "gunfold")
+toConstr_RDR   = varQual_RDR  gENERICS (fsLit "toConstr")
+dataTypeOf_RDR = varQual_RDR  gENERICS (fsLit "dataTypeOf")
+dataCast1_RDR  = varQual_RDR  gENERICS (fsLit "dataCast1")
+dataCast2_RDR  = varQual_RDR  gENERICS (fsLit "dataCast2")
+gcast1_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast1")
+gcast2_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast2")
+mkConstr_RDR   = varQual_RDR  gENERICS (fsLit "mkConstr")
+constr_RDR     = tcQual_RDR   gENERICS (fsLit "Constr")
+mkDataType_RDR = varQual_RDR  gENERICS (fsLit "mkDataType")
+dataType_RDR   = tcQual_RDR   gENERICS (fsLit "DataType")
+conIndex_RDR   = varQual_RDR  gENERICS (fsLit "constrIndex")
+prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")
+infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")
+
+eqChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqChar#")
+ltChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltChar#")
+leChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "leChar#")
+gtChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtChar#")
+geChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "geChar#")
+
+eqInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "==#")
+ltInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<#" )
+leInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<=#")
+gtInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">#" )
+geInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">=#")
+
+eqInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqInt8#")
+ltInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltInt8#" )
+leInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "leInt8#")
+gtInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtInt8#" )
+geInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "geInt8#")
+
+eqInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqInt16#")
+ltInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltInt16#" )
+leInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "leInt16#")
+gtInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtInt16#" )
+geInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "geInt16#")
+
+eqWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqWord#")
+ltWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltWord#")
+leWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "leWord#")
+gtWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtWord#")
+geWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "geWord#")
+
+eqWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqWord8#")
+ltWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltWord8#" )
+leWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "leWord8#")
+gtWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtWord8#" )
+geWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "geWord8#")
+
+eqWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "eqWord16#")
+ltWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "ltWord16#" )
+leWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "leWord16#")
+gtWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "gtWord16#" )
+geWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "geWord16#")
+
+eqAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqAddr#")
+ltAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltAddr#")
+leAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "leAddr#")
+gtAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtAddr#")
+geAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "geAddr#")
+
+eqFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqFloat#")
+ltFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltFloat#")
+leFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "leFloat#")
+gtFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtFloat#")
+geFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "geFloat#")
+
+eqDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "==##")
+ltDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<##" )
+leDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<=##")
+gtDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">##" )
+geDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">=##")
+
+extendWord8_RDR = varQual_RDR  gHC_PRIM (fsLit "extendWord8#")
+extendInt8_RDR  = varQual_RDR  gHC_PRIM (fsLit "extendInt8#")
+
+extendWord16_RDR = varQual_RDR  gHC_PRIM (fsLit "extendWord16#")
+extendInt16_RDR  = varQual_RDR  gHC_PRIM (fsLit "extendInt16#")
+
+
+{-
+************************************************************************
+*                                                                      *
+                        Lift instances
+*                                                                      *
+************************************************************************
+
+Example:
+
+    data Foo a = Foo a | a :^: a deriving Lift
+
+    ==>
+
+    instance (Lift a) => Lift (Foo a) where
+        lift (Foo a)
+          = appE
+              (conE
+                (mkNameG_d "package-name" "ModuleName" "Foo"))
+              (lift a)
+        lift (u :^: v)
+          = infixApp
+              (lift u)
+              (conE
+                (mkNameG_d "package-name" "ModuleName" ":^:"))
+              (lift v)
+
+Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
+'Foo would be when using the -XTemplateHaskell extension. To make sure that
+-XDeriveLift can be used on stage-1 compilers, however, we explicitly invoke
+makeG_d.
+-}
+
+gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Lift_binds loc tycon = (unitBag lift_bind, emptyBag)
+  where
+    lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
+                            (map pats_etc data_cons)
+    data_cons = tyConDataCons tycon
+
+    pats_etc data_con
+      = ([con_pat], lift_Expr)
+       where
+            con_pat      = nlConVarPat data_con_RDR as_needed
+            data_con_RDR = getRdrName data_con
+            con_arity    = dataConSourceArity data_con
+            as_needed    = take con_arity as_RDRs
+            lifted_as    = zipWithEqual "mk_lift_app" mk_lift_app
+                             tys_needed as_needed
+            tycon_name   = tyConName tycon
+            is_infix     = dataConIsInfix data_con
+            tys_needed   = dataConOrigArgTys data_con
+
+            mk_lift_app ty a
+              | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)
+                                                  (nlHsVar a)
+              | otherwise = nlHsApp (nlHsVar litE_RDR)
+                              (primLitOp (mkBoxExp (nlHsVar a)))
+              where (primLitOp, mkBoxExp) = primLitOps "Lift" ty
+
+            pkg_name = unitIdString . moduleUnitId
+                     . nameModule $ tycon_name
+            mod_name = moduleNameString . moduleName . nameModule $ tycon_name
+            con_name = occNameString . nameOccName . dataConName $ data_con
+
+            conE_Expr = nlHsApp (nlHsVar conE_RDR)
+                                (nlHsApps mkNameG_dRDR
+                                  (map (nlHsLit . mkHsString)
+                                    [pkg_name, mod_name, con_name]))
+
+            lift_Expr
+              | is_infix  = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
+              | otherwise = foldl' mk_appE_app conE_Expr lifted_as
+            (a1:a2:_) = lifted_as
+
+mk_appE_app :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+mk_appE_app a b = nlHsApps appE_RDR [a, b]
+
+{-
+************************************************************************
+*                                                                      *
+                     Newtype-deriving instances
+*                                                                      *
+************************************************************************
+
+Note [Newtype-deriving instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We take every method in the original instance and `coerce` it to fit
+into the derived instance. We need type applications on the argument
+to `coerce` to make it obvious what instantiation of the method we're
+coercing from.  So from, say,
+
+  class C a b where
+    op :: forall c. a -> [b] -> c -> Int
+
+  newtype T x = MkT <rep-ty>
+
+  instance C a <rep-ty> => C a (T x) where
+    op = coerce @ (a -> [<rep-ty>] -> c -> Int)
+                @ (a -> [T x]      -> c -> Int)
+                op :: forall c. a -> [T x] -> c -> Int
+
+In addition to the type applications, we also have an explicit
+type signature on the entire RHS. This brings the method-bound variable
+`c` into scope over the two type applications.
+See Note [GND and QuantifiedConstraints] for more information on why this
+is important.
+
+Giving 'coerce' two explicitly-visible type arguments grants us finer control
+over how it should be instantiated. Recall
+
+  coerce :: Coercible a b => a -> b
+
+By giving it explicit type arguments we deal with the case where
+'op' has a higher rank type, and so we must instantiate 'coerce' with
+a polytype.  E.g.
+
+   class C a where op :: a -> forall b. b -> b
+   newtype T x = MkT <rep-ty>
+   instance C <rep-ty> => C (T x) where
+     op = coerce @ (<rep-ty> -> forall b. b -> b)
+                 @ (T x      -> forall b. b -> b)
+                op :: T x -> forall b. b -> b
+
+The use of type applications is crucial here. If we had tried using only
+explicit type signatures, like so:
+
+   instance C <rep-ty> => C (T x) where
+     op = coerce (op :: <rep-ty> -> forall b. b -> b)
+                     :: T x      -> forall b. b -> b
+
+Then GHC will attempt to deeply skolemize the two type signatures, which will
+wreak havoc with the Coercible solver. Therefore, we instead use type
+applications, which do not deeply skolemize and thus avoid this issue.
+The downside is that we currently require -XImpredicativeTypes to permit this
+polymorphic type instantiation, so we have to switch that flag on locally in
+TcDeriv.genInst. See #8503 for more discussion.
+
+Note [Newtype-deriving trickiness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #12768):
+  class C a where { op :: D a => a -> a }
+
+  instance C a  => C [a] where { op = opList }
+
+  opList :: (C a, D [a]) => [a] -> [a]
+  opList = ...
+
+Now suppose we try GND on this:
+  newtype N a = MkN [a] deriving( C )
+
+The GND is expecting to get an implementation of op for N by
+coercing opList, thus:
+
+  instance C a => C (N a) where { op = opN }
+
+  opN :: (C a, D (N a)) => N a -> N a
+  opN = coerce @([a]   -> [a])
+               @([N a] -> [N a]
+               opList :: D (N a) => [N a] -> [N a]
+
+But there is no reason to suppose that (D [a]) and (D (N a))
+are inter-coercible; these instances might completely different.
+So GHC rightly rejects this code.
+
+Note [GND and QuantifiedConstraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following example from #15290:
+
+  class C m where
+    join :: m (m a) -> m a
+
+  newtype T m a = MkT (m a)
+
+  deriving instance
+    (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
+    C (T m)
+
+The code that GHC used to generate for this was:
+
+  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
+      C (T m) where
+    join = coerce @(forall a.   m   (m a) ->   m a)
+                  @(forall a. T m (T m a) -> T m a)
+                  join
+
+This instantiates `coerce` at a polymorphic type, a form of impredicative
+polymorphism, so we're already on thin ice. And in fact the ice breaks,
+as we'll explain:
+
+The call to `coerce` gives rise to:
+
+  Coercible (forall a.   m   (m a) ->   m a)
+            (forall a. T m (T m a) -> T m a)
+
+And that simplified to the following implication constraint:
+
+  forall a <no-ev>. m (T m a) ~R# m (m a)
+
+But because this constraint is under a `forall`, inside a type, we have to
+prove it *without computing any term evidence* (hence the <no-ev>). Alas, we
+*must* generate a term-level evidence binding in order to instantiate the
+quantified constraint! In response, GHC currently chooses not to use such
+a quantified constraint.
+See Note [Instances in no-evidence implications] in TcInteract.
+
+But this isn't the death knell for combining QuantifiedConstraints with GND.
+On the contrary, if we generate GND bindings in a slightly different way, then
+we can avoid this situation altogether. Instead of applying `coerce` to two
+polymorphic types, we instead let an explicit type signature do the polymorphic
+instantiation, and omit the `forall`s in the type applications.
+More concretely, we generate the following code instead:
+
+  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
+      C (T m) where
+    join = coerce @(  m   (m a) ->   m a)
+                  @(T m (T m a) -> T m a)
+                  join :: forall a. T m (T m a) -> T m a
+
+Now the visible type arguments are both monotypes, so we need do any of this
+funny quantified constraint instantiation business.
+
+You might think that that second @(T m (T m a) -> T m a) argument is redundant
+in the presence of the explicit `:: forall a. T m (T m a) -> T m a` type
+signature, but in fact leaving it off will break this example (from the
+T15290d test case):
+
+  class C a where
+    c :: Int -> forall b. b -> a
+
+  instance C Int
+
+  instance C Age where
+    c = coerce @(Int -> forall b. b -> Int)
+               c :: Int -> forall b. b -> Age
+
+That is because the explicit type signature deeply skolemizes the forall-bound
+`b`, which wreaks havoc with the `Coercible` solver. An additional visible type
+argument of @(Int -> forall b. b -> Age) is enough to prevent this.
+
+Be aware that the use of an explicit type signature doesn't /solve/ this
+problem; it just makes it less likely to occur. For example, if a class has
+a truly higher-rank type like so:
+
+  class CProblem m where
+    op :: (forall b. ... (m b) ...) -> Int
+
+Then the same situation will arise again. But at least it won't arise for the
+common case of methods with ordinary, prenex-quantified types.
+
+Note [GND and ambiguity]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We make an effort to make the code generated through GND be robust w.r.t.
+ambiguous type variables. As one example, consider the following example
+(from #15637):
+
+  class C a where f :: String
+  instance C () where f = "foo"
+  newtype T = T () deriving C
+
+A naïve attempt and generating a C T instance would be:
+
+  instance C T where
+    f = coerce @String @String f
+          :: String
+
+This isn't going to typecheck, however, since GHC doesn't know what to
+instantiate the type variable `a` with in the call to `f` in the method body.
+(Note that `f :: forall a. String`!) To compensate for the possibility of
+ambiguity here, we explicitly instantiate `a` like so:
+
+  instance C T where
+    f = coerce @String @String (f @())
+          :: String
+
+All better now.
+-}
+
+gen_Newtype_binds :: SrcSpan
+                  -> Class   -- the class being derived
+                  -> [TyVar] -- the tvs in the instance head (this includes
+                             -- the tvs from both the class types and the
+                             -- newtype itself)
+                  -> [Type]  -- instance head parameters (incl. newtype)
+                  -> Type    -- the representation type
+                  -> TcM (LHsBinds GhcPs, BagDerivStuff)
+-- See Note [Newtype-deriving instances]
+gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
+  = do let ats = classATs cls
+       atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )
+                    mapM mk_atf_inst ats
+       return ( listToBag $ map mk_bind (classMethods cls)
+              , listToBag $ map DerivFamInst atf_insts )
+  where
+    mk_bind :: Id -> LHsBind GhcPs
+    mk_bind meth_id
+      = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
+                                          (mkPrefixFunRhs (L loc meth_RDR))
+                                          [] rhs_expr]
+      where
+        Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
+        (_, _, from_tau) = tcSplitSigmaTy from_ty
+        (_, _, to_tau)   = tcSplitSigmaTy to_ty
+
+        meth_RDR = getRdrName meth_id
+
+        rhs_expr = nlHsVar (getRdrName coerceId)
+                                      `nlHsAppType`     from_tau
+                                      `nlHsAppType`     to_tau
+                                      `nlHsApp`         meth_app
+                                      `nlExprWithTySig` to_ty
+
+        -- The class method, applied to all of the class instance types
+        -- (including the representation type) to avoid potential ambiguity.
+        -- See Note [GND and ambiguity]
+        meth_app = foldl' nlHsAppType (nlHsVar meth_RDR) $
+                   filterOutInferredTypes (classTyCon cls) underlying_inst_tys
+                     -- Filter out any inferred arguments, since they can't be
+                     -- applied with visible type application.
+
+    mk_atf_inst :: TyCon -> TcM FamInst
+    mk_atf_inst fam_tc = do
+        rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc))
+                                           rep_lhs_tys
+        let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs'
+                                    fam_tc rep_lhs_tys rep_rhs_ty
+        -- Check (c) from Note [GND and associated type families] in TcDeriv
+        checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom)
+        newFamInst SynFamilyInst axiom
+      where
+        cls_tvs     = classTyVars cls
+        in_scope    = mkInScopeSet $ mkVarSet inst_tvs
+        lhs_env     = zipTyEnv cls_tvs inst_tys
+        lhs_subst   = mkTvSubst in_scope lhs_env
+        rhs_env     = zipTyEnv cls_tvs underlying_inst_tys
+        rhs_subst   = mkTvSubst in_scope rhs_env
+        fam_tvs     = tyConTyVars fam_tc
+        rep_lhs_tys = substTyVars lhs_subst fam_tvs
+        rep_rhs_tys = substTyVars rhs_subst fam_tvs
+        rep_rhs_ty  = mkTyConApp fam_tc rep_rhs_tys
+        rep_tcvs    = tyCoVarsOfTypesList rep_lhs_tys
+        (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs
+        rep_tvs'    = scopedSort rep_tvs
+        rep_cvs'    = scopedSort rep_cvs
+
+    -- Same as inst_tys, but with the last argument type replaced by the
+    -- representation type.
+    underlying_inst_tys :: [Type]
+    underlying_inst_tys = changeLast inst_tys rhs_ty
+
+nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
+nlHsAppType e s = noLoc (HsAppType noExt e hs_ty)
+  where
+    hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s)
+
+nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
+nlExprWithTySig e s = noLoc $ ExprWithTySig noExt (parenthesizeHsExpr sigPrec e) hs_ty
+  where
+    hs_ty = mkLHsSigWcType (typeToLHsType s)
+
+mkCoerceClassMethEqn :: Class   -- the class being derived
+                     -> [TyVar] -- the tvs in the instance head (this includes
+                                -- the tvs from both the class types and the
+                                -- newtype itself)
+                     -> [Type]  -- instance head parameters (incl. newtype)
+                     -> Type    -- the representation type
+                     -> Id      -- the method to look at
+                     -> Pair Type
+-- See Note [Newtype-deriving instances]
+-- See also Note [Newtype-deriving trickiness]
+-- The pair is the (from_type, to_type), where to_type is
+-- the type of the method we are trying to get
+mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id
+  = Pair (substTy rhs_subst user_meth_ty)
+         (substTy lhs_subst user_meth_ty)
+  where
+    cls_tvs = classTyVars cls
+    in_scope = mkInScopeSet $ mkVarSet inst_tvs
+    lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys)
+    rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty))
+    (_class_tvs, _class_constraint, user_meth_ty)
+      = tcSplitMethodTy (varType id)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Generating extra binds (@con2tag@ and @tag2con@)}
+*                                                                      *
+************************************************************************
+
+\begin{verbatim}
+data Foo ... = ...
+
+con2tag_Foo :: Foo ... -> Int#
+tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
+maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
+\end{verbatim}
+
+The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
+fiddling around.
+-}
+
+genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec
+                  -> (LHsBind GhcPs, LSig GhcPs)
+genAuxBindSpec dflags loc (DerivCon2Tag tycon)
+  = (mkFunBindSE 0 loc rdr_name eqns,
+     L loc (TypeSig noExt [L loc rdr_name] sig_ty))
+  where
+    rdr_name = con2tag_RDR dflags tycon
+
+    sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $
+             mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
+             mkParentType tycon `mkFunTy` intPrimTy
+
+    lots_of_constructors = tyConFamilySize tycon > 8
+                        -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
+                        -- but we don't do vectored returns any more.
+
+    eqns | lots_of_constructors = [get_tag_eqn]
+         | otherwise = map mk_eqn (tyConDataCons tycon)
+
+    get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
+
+    mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs)
+    mk_eqn con = ([nlWildConPat con],
+                  nlHsLit (HsIntPrim NoSourceText
+                                    (toInteger ((dataConTag con) - fIRST_TAG))))
+
+genAuxBindSpec dflags loc (DerivTag2Con tycon)
+  = (mkFunBindSE 0 loc rdr_name
+        [([nlConVarPat intDataCon_RDR [a_RDR]],
+           nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
+     L loc (TypeSig noExt [L loc rdr_name] sig_ty))
+  where
+    sig_ty = mkLHsSigWcType $ L loc $
+             XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
+             intTy `mkFunTy` mkParentType tycon
+
+    rdr_name = tag2con_RDR dflags tycon
+
+genAuxBindSpec dflags loc (DerivMaxTag tycon)
+  = (mkHsVarBind loc rdr_name rhs,
+     L loc (TypeSig noExt [L loc rdr_name] sig_ty))
+  where
+    rdr_name = maxtag_RDR dflags tycon
+    sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))
+    rhs = nlHsApp (nlHsVar intDataCon_RDR)
+                  (nlHsLit (HsIntPrim NoSourceText max_tag))
+    max_tag =  case (tyConDataCons tycon) of
+                 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
+
+type SeparateBagsDerivStuff =
+  -- AuxBinds and SYB bindings
+  ( Bag (LHsBind GhcPs, LSig GhcPs)
+  -- Extra family instances (used by Generic and DeriveAnyClass)
+  , Bag (FamInst) )
+
+genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
+genAuxBinds dflags loc b = genAuxBinds' b2 where
+  (b1,b2) = partitionBagWith splitDerivAuxBind b
+  splitDerivAuxBind (DerivAuxBind x) = Left x
+  splitDerivAuxBind  x               = Right x
+
+  rm_dups = foldrBag dup_check emptyBag
+  dup_check a b = if anyBag (== a) b then b else consBag a b
+
+  genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
+  genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)
+                            , emptyBag )
+  f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
+  f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
+  f (DerivHsBind  b) = add1 b
+  f (DerivFamInst t) = add2 t
+
+  add1 x (a,b) = (x `consBag` a,b)
+  add2 x (a,b) = (a,x `consBag` b)
+
+mkParentType :: TyCon -> Type
+-- Turn the representation tycon of a family into
+-- a use of its family constructor
+mkParentType tc
+  = case tyConFamInst_maybe tc of
+       Nothing  -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
+       Just (fam_tc,tys) -> mkTyConApp fam_tc tys
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Utility bits for generating bindings}
+*                                                                      *
+************************************************************************
+-}
+
+-- | Make a function binding. If no equations are given, produce a function
+-- with the given arity that produces a stock error.
+mkFunBindSE :: Arity -> SrcSpan -> RdrName
+             -> [([LPat GhcPs], LHsExpr GhcPs)]
+             -> LHsBind GhcPs
+mkFunBindSE arity loc fun pats_and_exprs
+  = mkRdrFunBindSE arity (L loc fun) matches
+  where
+    matches = [mkMatch (mkPrefixFunRhs (L loc fun))
+                               (map (parenthesizePat appPrec) p) e
+                               (noLoc emptyLocalBinds)
+              | (p,e) <-pats_and_exprs]
+
+mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
+             -> LHsBind GhcPs
+mkRdrFunBind fun@(L loc _fun_rdr) matches
+  = L loc (mkFunBind fun matches)
+
+-- | Make a function binding. If no equations are given, produce a function
+-- with the given arity that uses an empty case expression for the last
+-- argument that is passes to the given function to produce the right-hand
+-- side.
+mkFunBindEC :: Arity -> SrcSpan -> RdrName
+            -> (LHsExpr GhcPs -> LHsExpr GhcPs)
+            -> [([LPat GhcPs], LHsExpr GhcPs)]
+            -> LHsBind GhcPs
+mkFunBindEC arity loc fun catch_all pats_and_exprs
+  = mkRdrFunBindEC arity catch_all (L loc fun) matches
+  where
+    matches = [ mkMatch (mkPrefixFunRhs (L loc fun))
+                                (map (parenthesizePat appPrec) p) e
+                                (noLoc emptyLocalBinds)
+              | (p,e) <- pats_and_exprs ]
+
+-- | Produces a function binding. When no equations are given, it generates
+-- a binding of the given arity and an empty case expression
+-- for the last argument that it passes to the given function to produce
+-- the right-hand side.
+mkRdrFunBindEC :: Arity
+               -> (LHsExpr GhcPs -> LHsExpr GhcPs)
+               -> Located RdrName
+               -> [LMatch GhcPs (LHsExpr GhcPs)]
+               -> LHsBind GhcPs
+mkRdrFunBindEC arity catch_all
+                 fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches')
+ where
+   -- Catch-all eqn looks like
+   --     fmap _ z = case z of {}
+   -- or
+   --     traverse _ z = pure (case z of)
+   -- or
+   --     foldMap _ z = mempty
+   -- It's needed if there no data cons at all,
+   -- which can happen with -XEmptyDataDecls
+   -- See Trac #4302
+   matches' = if null matches
+              then [mkMatch (mkPrefixFunRhs fun)
+                            (replicate (arity - 1) nlWildPat ++ [z_Pat])
+                            (catch_all $ nlHsCase z_Expr [])
+                            (noLoc emptyLocalBinds)]
+              else matches
+
+-- | Produces a function binding. When there are no equations, it generates
+-- a binding with the given arity that produces an error based on the name of
+-- the type of the last argument.
+mkRdrFunBindSE :: Arity -> Located RdrName ->
+                    [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
+mkRdrFunBindSE arity
+                 fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
+ where
+   -- Catch-all eqn looks like
+   --     compare _ _ = error "Void compare"
+   -- It's needed if there no data cons at all,
+   -- which can happen with -XEmptyDataDecls
+   -- See Trac #4302
+   matches' = if null matches
+              then [mkMatch (mkPrefixFunRhs fun)
+                            (replicate arity nlWildPat)
+                            (error_Expr str) (noLoc emptyLocalBinds)]
+              else matches
+   str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
+
+
+box ::         String           -- The class involved
+            -> LHsExpr GhcPs    -- The argument
+            -> Type             -- The argument type
+            -> LHsExpr GhcPs    -- Boxed version of the arg
+-- See Note [Deriving and unboxed types] in TcDerivInfer
+box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg
+
+---------------------
+primOrdOps :: String    -- The class involved
+           -> Type      -- The type
+           -> (RdrName, RdrName, RdrName, RdrName, RdrName)  -- (lt,le,eq,ge,gt)
+-- See Note [Deriving and unboxed types] in TcDerivInfer
+primOrdOps str ty = assoc_ty_id str ordOpTbl ty
+
+primLitOps :: String -- The class involved
+           -> Type   -- The type
+           -> ( LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a Q Exp value
+              , LHsExpr GhcPs -> LHsExpr GhcPs -- Constructs a boxed value
+              )
+primLitOps str ty = (assoc_ty_id str litConTbl ty, \v -> boxed v)
+  where
+    boxed v
+      | ty `eqType` addrPrimTy = nlHsVar unpackCString_RDR `nlHsApp` v
+      | otherwise = assoc_ty_id str boxConTbl ty v
+
+ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
+ordOpTbl
+ =  [(charPrimTy  , (ltChar_RDR  , leChar_RDR
+     , eqChar_RDR  , geChar_RDR  , gtChar_RDR  ))
+    ,(intPrimTy   , (ltInt_RDR   , leInt_RDR
+     , eqInt_RDR   , geInt_RDR   , gtInt_RDR   ))
+    ,(int8PrimTy  , (ltInt8_RDR  , leInt8_RDR
+     , eqInt8_RDR  , geInt8_RDR  , gtInt8_RDR   ))
+    ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR
+     , eqInt16_RDR , geInt16_RDR , gtInt16_RDR   ))
+    ,(wordPrimTy  , (ltWord_RDR  , leWord_RDR
+     , eqWord_RDR  , geWord_RDR  , gtWord_RDR  ))
+    ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR
+     , eqWord8_RDR , geWord8_RDR , gtWord8_RDR   ))
+    ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR
+     , eqWord16_RDR, geWord16_RDR, gtWord16_RDR  ))
+    ,(addrPrimTy  , (ltAddr_RDR  , leAddr_RDR
+     , eqAddr_RDR  , geAddr_RDR  , gtAddr_RDR  ))
+    ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR
+     , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
+    ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR
+     , eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
+
+-- A mapping from a primitive type to a function that constructs its boxed
+-- version.
+-- NOTE: Int8#/Word8# will become Int/Word.
+boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
+boxConTbl =
+    [ (charPrimTy  , nlHsApp (nlHsVar $ getRdrName charDataCon))
+    , (intPrimTy   , nlHsApp (nlHsVar $ getRdrName intDataCon))
+    , (wordPrimTy  , nlHsApp (nlHsVar $ getRdrName wordDataCon ))
+    , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon ))
+    , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon))
+    , (int8PrimTy,
+        nlHsApp (nlHsVar $ getRdrName intDataCon)
+        . nlHsApp (nlHsVar extendInt8_RDR))
+    , (word8PrimTy,
+        nlHsApp (nlHsVar $ getRdrName wordDataCon)
+        .  nlHsApp (nlHsVar extendWord8_RDR))
+    , (int16PrimTy,
+        nlHsApp (nlHsVar $ getRdrName intDataCon)
+        . nlHsApp (nlHsVar extendInt16_RDR))
+    , (word16PrimTy,
+        nlHsApp (nlHsVar $ getRdrName wordDataCon)
+        .  nlHsApp (nlHsVar extendWord16_RDR))
+    ]
+
+
+-- | A table of postfix modifiers for unboxed values.
+postfixModTbl :: [(Type, String)]
+postfixModTbl
+  = [(charPrimTy  , "#" )
+    ,(intPrimTy   , "#" )
+    ,(wordPrimTy  , "##")
+    ,(floatPrimTy , "#" )
+    ,(doublePrimTy, "##")
+    ,(int8PrimTy, "#")
+    ,(word8PrimTy, "##")
+    ,(int16PrimTy, "#")
+    ,(word16PrimTy, "##")
+    ]
+
+primConvTbl :: [(Type, String)]
+primConvTbl =
+    [ (int8PrimTy, "narrowInt8#")
+    , (word8PrimTy, "narrowWord8#")
+    , (int16PrimTy, "narrowInt16#")
+    , (word16PrimTy, "narrowWord16#")
+    ]
+
+litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
+litConTbl
+  = [(charPrimTy  , nlHsApp (nlHsVar charPrimL_RDR))
+    ,(intPrimTy   , nlHsApp (nlHsVar intPrimL_RDR)
+                      . nlHsApp (nlHsVar toInteger_RDR))
+    ,(wordPrimTy  , nlHsApp (nlHsVar wordPrimL_RDR)
+                      . nlHsApp (nlHsVar toInteger_RDR))
+    ,(addrPrimTy  , nlHsApp (nlHsVar stringPrimL_RDR)
+                      . nlHsApp (nlHsApp
+                          (nlHsVar map_RDR)
+                          (compose_RDR `nlHsApps`
+                            [ nlHsVar fromIntegral_RDR
+                            , nlHsVar fromEnum_RDR
+                            ])))
+    ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
+                      . nlHsApp (nlHsVar toRational_RDR))
+    ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
+                      . nlHsApp (nlHsVar toRational_RDR))
+    ]
+
+-- | Lookup `Type` in an association list.
+assoc_ty_id :: HasCallStack => String           -- The class involved
+            -> [(Type,a)]       -- The table
+            -> Type             -- The type
+            -> a                -- The result of the lookup
+assoc_ty_id cls_str tbl ty
+  | Just a <- assoc_ty_id_maybe tbl ty = a
+  | otherwise =
+      pprPanic "Error in deriving:"
+          (text "Can't derive" <+> text cls_str <+>
+           text "for primitive type" <+> ppr ty)
+
+-- | Lookup `Type` in an association list.
+assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a
+assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl
+
+-----------------------------------------------------------------------
+
+and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+and_Expr a b = genOpApp a and_RDR    b
+
+-----------------------------------------------------------------------
+
+eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+eq_Expr ty a b
+    | not (isUnliftedType ty) = genOpApp a eq_RDR b
+    | otherwise               = genPrimOpApp a prim_eq b
+ where
+   (_, _, prim_eq, _, _) = primOrdOps "Eq" ty
+
+untag_Expr :: DynFlags -> TyCon -> [( RdrName,  RdrName)]
+              -> LHsExpr GhcPs -> LHsExpr GhcPs
+untag_Expr _ _ [] expr = expr
+untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr
+  = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon)
+                                   [untag_this])) {-of-}
+      [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)]
+
+enum_from_to_Expr
+        :: LHsExpr GhcPs -> LHsExpr GhcPs
+        -> LHsExpr GhcPs
+enum_from_then_to_Expr
+        :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+        -> LHsExpr GhcPs
+
+enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
+enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
+
+showParen_Expr
+        :: LHsExpr GhcPs -> LHsExpr GhcPs
+        -> LHsExpr GhcPs
+
+showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
+
+nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
+
+nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
+nested_compose_Expr [e] = parenify e
+nested_compose_Expr (e:es)
+  = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
+
+-- impossible_Expr is used in case RHSs that should never happen.
+-- We generate these to keep the desugarer from complaining that they *might* happen!
+error_Expr :: String -> LHsExpr GhcPs
+error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
+
+-- illegal_Expr is used when signalling error conditions in the RHS of a derived
+-- method. It is currently only used by Enum.{succ,pred}
+illegal_Expr :: String -> String -> String -> LHsExpr GhcPs
+illegal_Expr meth tp msg =
+   nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
+
+-- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
+-- to include the value of a_RDR in the error string.
+illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs
+illegal_toEnum_tag tp maxtag =
+   nlHsApp (nlHsVar error_RDR)
+           (nlHsApp (nlHsApp (nlHsVar append_RDR)
+                       (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
+                    (nlHsApp (nlHsApp (nlHsApp
+                           (nlHsVar showsPrec_RDR)
+                           (nlHsIntLit 0))
+                           (nlHsVar a_RDR))
+                           (nlHsApp (nlHsApp
+                               (nlHsVar append_RDR)
+                               (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
+                               (nlHsApp (nlHsApp (nlHsApp
+                                        (nlHsVar showsPrec_RDR)
+                                        (nlHsIntLit 0))
+                                        (nlHsVar maxtag))
+                                        (nlHsLit (mkHsString ")"))))))
+
+parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
+parenify e@(L _ (HsVar _ _)) = e
+parenify e                   = mkHsPar e
+
+-- genOpApp wraps brackets round the operator application, so that the
+-- renamer won't subsequently try to re-associate it.
+genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
+genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
+
+genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
+genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
+
+a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
+    :: RdrName
+a_RDR           = mkVarUnqual (fsLit "a")
+b_RDR           = mkVarUnqual (fsLit "b")
+c_RDR           = mkVarUnqual (fsLit "c")
+d_RDR           = mkVarUnqual (fsLit "d")
+f_RDR           = mkVarUnqual (fsLit "f")
+k_RDR           = mkVarUnqual (fsLit "k")
+z_RDR           = mkVarUnqual (fsLit "z")
+ah_RDR          = mkVarUnqual (fsLit "a#")
+bh_RDR          = mkVarUnqual (fsLit "b#")
+ch_RDR          = mkVarUnqual (fsLit "c#")
+dh_RDR          = mkVarUnqual (fsLit "d#")
+
+as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
+as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
+bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
+cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
+
+a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
+    true_Expr, pure_Expr :: LHsExpr GhcPs
+a_Expr          = nlHsVar a_RDR
+b_Expr          = nlHsVar b_RDR
+c_Expr          = nlHsVar c_RDR
+z_Expr          = nlHsVar z_RDR
+ltTag_Expr      = nlHsVar ltTag_RDR
+eqTag_Expr      = nlHsVar eqTag_RDR
+gtTag_Expr      = nlHsVar gtTag_RDR
+false_Expr      = nlHsVar false_RDR
+true_Expr       = nlHsVar true_RDR
+pure_Expr       = nlHsVar pure_RDR
+
+a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs
+a_Pat           = nlVarPat a_RDR
+b_Pat           = nlVarPat b_RDR
+c_Pat           = nlVarPat c_RDR
+d_Pat           = nlVarPat d_RDR
+k_Pat           = nlVarPat k_RDR
+z_Pat           = nlVarPat z_RDR
+
+minusInt_RDR, tagToEnum_RDR :: RdrName
+minusInt_RDR  = getRdrName (primOpId IntSubOp   )
+tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
+
+con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName
+-- Generates Orig s RdrName, for the binding positions
+con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc
+tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc
+maxtag_RDR  dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc
+
+mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName
+mk_tc_deriv_name dflags tycon occ_fun =
+   mkAuxBinderName dflags (tyConName tycon) occ_fun
+
+mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName
+-- ^ Make a top-level binder name for an auxiliary binding for a parent name
+-- See Note [Auxiliary binders]
+mkAuxBinderName dflags parent occ_fun
+  = mkRdrUnqual (occ_fun stable_parent_occ)
+  where
+    stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
+    stable_string
+      | hasPprDebug dflags = parent_stable
+      | otherwise          = parent_stable_hash
+    parent_stable = nameStableString parent
+    parent_stable_hash =
+      let Fingerprint high low = fingerprintString parent_stable
+      in toBase62 high ++ toBase62Padded low
+      -- See Note [Base 62 encoding 128-bit integers] in Encoding
+    parent_occ  = nameOccName parent
+
+
+{-
+Note [Auxiliary binders]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We often want to make a top-level auxiliary binding.  E.g. for comparison we haev
+
+  instance Ord T where
+    compare a b = $con2tag a `compare` $con2tag b
+
+  $con2tag :: T -> Int
+  $con2tag = ...code....
+
+Of course these top-level bindings should all have distinct name, and we are
+generating RdrNames here.  We can't just use the TyCon or DataCon to distinguish
+because with standalone deriving two imported TyCons might both be called T!
+(See Trac #7947.)
+
+So we use package name, module name and the name of the parent
+(T in this example) as part of the OccName we generate for the new binding.
+To make the symbol names short we take a base62 hash of the full name.
+
+In the past we used the *unique* from the parent, but that's not stable across
+recompilations as uniques are nondeterministic.
+-}
diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcGenFunctor.hs
@@ -0,0 +1,1292 @@
+{-
+(c) The University of Glasgow 2011
+
+
+The deriving code for the Functor, Foldable, and Traversable classes
+(equivalent to the code in TcGenDeriv, for other classes)
+-}
+
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+
+module TcGenFunctor (
+        FFoldType(..), functorLikeTraverse,
+        deepSubtypesContaining, foldDataConArgs,
+
+        gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds
+    ) where
+
+import GhcPrelude
+
+import Bag
+import DataCon
+import FastString
+import HsSyn
+import Panic
+import PrelNames
+import RdrName
+import SrcLoc
+import State
+import TcGenDeriv
+import TcType
+import TyCon
+import TyCoRep
+import Type
+import Util
+import Var
+import VarSet
+import MkId (coerceId)
+import TysWiredIn (true_RDR, false_RDR)
+
+import Data.Maybe (catMaybes, isJust)
+
+{-
+************************************************************************
+*                                                                      *
+                        Functor instances
+
+ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
+
+*                                                                      *
+************************************************************************
+
+For the data type:
+
+  data T a = T1 Int a | T2 (T a)
+
+We generate the instance:
+
+  instance Functor T where
+      fmap f (T1 b1 a) = T1 b1 (f a)
+      fmap f (T2 ta)   = T2 (fmap f ta)
+
+Notice that we don't simply apply 'fmap' to the constructor arguments.
+Rather
+  - Do nothing to an argument whose type doesn't mention 'a'
+  - Apply 'f' to an argument of type 'a'
+  - Apply 'fmap f' to other arguments
+That's why we have to recurse deeply into the constructor argument types,
+rather than just one level, as we typically do.
+
+What about types with more than one type parameter?  In general, we only
+derive Functor for the last position:
+
+  data S a b = S1 [b] | S2 (a, T a b)
+  instance Functor (S a) where
+    fmap f (S1 bs)    = S1 (fmap f bs)
+    fmap f (S2 (p,q)) = S2 (a, fmap f q)
+
+However, we have special cases for
+         - tuples
+         - functions
+
+More formally, we write the derivation of fmap code over type variable
+'a for type 'b as ($fmap 'a 'b).  In this general notation the derived
+instance for T is:
+
+  instance Functor T where
+      fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
+      fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)
+
+  $(fmap 'a 'b)          =  \x -> x     -- when b does not contain a
+  $(fmap 'a 'a)          =  f
+  $(fmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
+  $(fmap 'a '(T b1 b2))  =  fmap $(fmap 'a 'b2)   -- when a only occurs in the last parameter, b2
+  $(fmap 'a '(b -> c))   =  \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
+
+For functions, the type parameter 'a can occur in a contravariant position,
+which means we need to derive a function like:
+
+  cofmap :: (a -> b) -> (f b -> f a)
+
+This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
+
+  $(cofmap 'a 'b)          =  \x -> x     -- when b does not contain a
+  $(cofmap 'a 'a)          =  error "type variable in contravariant position"
+  $(cofmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
+  $(cofmap 'a '[b])        =  map $(cofmap 'a 'b)
+  $(cofmap 'a '(T b1 b2))  =  fmap $(cofmap 'a 'b2)   -- when a only occurs in the last parameter, b2
+  $(cofmap 'a '(b -> c))   =  \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
+
+Note that the code produced by $(fmap _ _) is always a higher order function,
+with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern
+matching on the type, this means create a lambda function (see the (,) case above).
+The resulting code for fmap can look a bit weird, for example:
+
+  data X a = X (a,Int)
+  -- generated instance
+  instance Functor X where
+      fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x
+
+The optimizer should be able to simplify this code by simple inlining.
+
+An older version of the deriving code tried to avoid these applied
+lambda functions by producing a meta level function. But the function to
+be mapped, `f`, is a function on the code level, not on the meta level,
+so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.
+It is better to produce too many lambdas than to eta expand, see ticket #7436.
+-}
+
+gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+-- When the argument is phantom, we can use  fmap _ = coerce
+-- See Note [Phantom types with Functor, Foldable, and Traversable]
+gen_Functor_binds loc tycon
+  | Phantom <- last (tyConRoles tycon)
+  = (unitBag fmap_bind, emptyBag)
+  where
+    fmap_name = L loc fmap_RDR
+    fmap_bind = mkRdrFunBind fmap_name fmap_eqns
+    fmap_eqns = [mkSimpleMatch fmap_match_ctxt
+                               [nlWildPat]
+                               coerce_Expr]
+    fmap_match_ctxt = mkPrefixFunRhs fmap_name
+
+gen_Functor_binds loc tycon
+  = (listToBag [fmap_bind, replace_bind], emptyBag)
+  where
+    data_cons = tyConDataCons tycon
+    fmap_name = L loc fmap_RDR
+
+    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
+    fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns
+    fmap_match_ctxt = mkPrefixFunRhs fmap_name
+
+    fmap_eqn con = flip evalState bs_RDRs $
+                     match_for_con fmap_match_ctxt [f_Pat] con =<< parts
+      where
+        parts = sequence $ foldDataConArgs ft_fmap con
+
+    fmap_eqns = map fmap_eqn data_cons
+
+    ft_fmap :: FFoldType (State [RdrName] (LHsExpr GhcPs))
+    ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x
+                   -- fmap f = \x -> x
+                 , ft_var  = return f_Expr
+                   -- fmap f = f
+                 , ft_fun  = \g h -> do
+                     gg <- g
+                     hh <- h
+                     mkSimpleLam2 $ \x b -> return $
+                       nlHsApp hh (nlHsApp x (nlHsApp gg b))
+                   -- fmap f = \x b -> h (x (g b))
+                 , ft_tup = \t gs -> do
+                     gg <- sequence gs
+                     mkSimpleLam $ mkSimpleTupleCase (match_for_con CaseAlt) t gg
+                   -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
+                 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g
+                   -- fmap f = fmap g
+                 , ft_forall = \_ g -> g
+                 , ft_bad_app = panic "in other argument in ft_fmap"
+                 , ft_co_var = panic "contravariant in ft_fmap" }
+
+    -- See Note [Deriving <$]
+    replace_name = L loc replace_RDR
+
+    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
+    replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns
+    replace_match_ctxt = mkPrefixFunRhs replace_name
+
+    replace_eqn con = flip evalState bs_RDRs $
+        match_for_con replace_match_ctxt [z_Pat] con =<< parts
+      where
+        parts = traverse (fmap replace) $ foldDataConArgs ft_replace con
+
+    replace_eqns = map replace_eqn data_cons
+
+    ft_replace :: FFoldType (State [RdrName] Replacer)
+    ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam $ \x -> return x
+                   -- (p <$) = \x -> x
+                 , ft_var  = fmap Immediate $ mkSimpleLam $ \_ -> return z_Expr
+                   -- (p <$) = const p
+                 , ft_fun  = \g h -> do
+                     gg <- replace <$> g
+                     hh <- replace <$> h
+                     fmap Nested $ mkSimpleLam2 $ \x b -> return $
+                       nlHsApp hh (nlHsApp x (nlHsApp gg b))
+                   -- (<$) p = \x b -> h (x (g b))
+                 , ft_tup = \t gs -> do
+                     gg <- traverse (fmap replace) gs
+                     fmap Nested . mkSimpleLam $
+                          mkSimpleTupleCase (match_for_con CaseAlt) t gg
+                   -- (p <$) = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
+                 , ft_ty_app = \_ gm -> do
+                       g <- gm
+                       case g of
+                         Nested g' -> pure . Nested $
+                                          nlHsApp fmap_Expr $ g'
+                         Immediate _ -> pure . Nested $
+                                          nlHsApp replace_Expr z_Expr
+                   -- (p <$) = fmap (p <$)
+                 , ft_forall = \_ g -> g
+                 , ft_bad_app = panic "in other argument in ft_replace"
+                 , ft_co_var = panic "contravariant in ft_replace" }
+
+    -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
+    match_for_con :: HsMatchContext RdrName
+                  -> [LPat GhcPs] -> DataCon -> [LHsExpr GhcPs]
+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
+    match_for_con ctxt = mkSimpleConMatch ctxt $
+        \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..
+
+-- See Note [Deriving <$]
+data Replacer = Immediate {replace :: LHsExpr GhcPs}
+              | Nested {replace :: LHsExpr GhcPs}
+
+{- Note [Deriving <$]
+   ~~~~~~~~~~~~~~~~~~
+
+We derive the definition of <$. Allowing this to take the default definition
+can lead to memory leaks: mapping over a structure with a constant function can
+fill the result structure with trivial thunks that retain the values from the
+original structure. The simplifier seems to handle this all right for simple
+types, but not for recursive ones. Consider
+
+data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor
+
+-- fmap _ Tip = Tip
+-- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r)
+
+Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that
+simplifies no further. Why is that? `fmap` is defined recursively, so GHC
+cannot inline it. The static argument transformation would turn the definition
+into a non-recursive one
+
+-- fmap f = go where
+--   go Tip = Tip
+--   go (Bin l v r) = Bin (go l) (f v) (go r)
+
+which GHC could inline, producing an efficient definion of `<$`. But there are
+several problems. First, GHC does not perform the static argument transformation
+by default, even with -O2. Second, even when it does perform the static argument
+transformation, it does so only when there are at least two static arguments,
+which is not the case for fmap. Finally, when the type in question is
+non-regular, such as
+
+data Nesty a = Z a | S (Nesty a) (Nest (a, a))
+
+the function argument is no longer (entirely) static, so the static argument
+transformation will do nothing for us.
+
+Applying the default definition of `<$` will produce a tree full of thunks that
+look like ((\_ -> x) x0), which represents unnecessary thunk allocation and
+also retention of the previous value, potentially leaking memory. Instead, we
+derive <$ separately. Two aspects are different from fmap: the case of the
+sought type variable (ft_var) and the case of a type application (ft_ty_app).
+The interesting one is ft_ty_app. We have to distinguish two cases: the
+"immediate" case where the type argument *is* the sought type variable, and
+the "nested" case where the type argument *contains* the sought type variable.
+
+The immediate case:
+
+Suppose we have
+
+data Imm a = Imm (F ... a)
+
+Then we want to define
+
+x <$ Imm q = Imm (x <$ q)
+
+The nested case:
+
+Suppose we have
+
+data Nes a = Nes (F ... (G a))
+
+Then we want to define
+
+x <$ Nes q = Nes (fmap (x <$) q)
+
+We use the Replacer type to tag whether the expression derived for applying
+<$ to the last type variable was the ft_var case (immediate) or one of the
+others (letting ft_forall pass through as usual).
+
+We could, but do not, give tuples special treatment to improve efficiency
+in some cases. Suppose we have
+
+data Nest a = Z a | S (Nest (a,a))
+
+The optimal definition would be
+
+x <$ Z _ = Z x
+x <$ S t = S ((x, x) <$ t)
+
+which produces a result with maximal internal sharing. The reason we do not
+attempt to treat this case specially is that we have no way to give
+user-provided tuple-like types similar treatment. If the user changed the
+definition to
+
+data Pair a = Pair a a
+data Nest a = Z a | S (Nest (Pair a))
+
+they would experience a surprising degradation in performance. -}
+
+
+{-
+Utility functions related to Functor deriving.
+
+Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
+This function works like a fold: it makes a value of type 'a' in a bottom up way.
+-}
+
+-- Generic traversal for Functor deriving
+-- See Note [FFoldType and functorLikeTraverse]
+data FFoldType a      -- Describes how to fold over a Type in a functor like way
+   = FT { ft_triv    :: a
+          -- ^ Does not contain variable
+        , ft_var     :: a
+          -- ^ The variable itself
+        , ft_co_var  :: a
+          -- ^ The variable itself, contravariantly
+        , ft_fun     :: a -> a -> a
+          -- ^ Function type
+        , ft_tup     :: TyCon -> [a] -> a
+          -- ^ Tuple type
+        , ft_ty_app  :: Type -> a -> a
+          -- ^ Type app, variable only in last argument
+        , ft_bad_app :: a
+          -- ^ Type app, variable other than in last argument
+        , ft_forall  :: TcTyVar -> a -> a
+          -- ^ Forall type
+     }
+
+functorLikeTraverse :: forall a.
+                       TyVar         -- ^ Variable to look for
+                    -> FFoldType a   -- ^ How to fold
+                    -> Type          -- ^ Type to process
+                    -> a
+functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar
+                            , ft_co_var = caseCoVar,     ft_fun = caseFun
+                            , ft_tup = caseTuple,        ft_ty_app = caseTyApp
+                            , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
+                    ty
+  = fst (go False ty)
+  where
+    go :: Bool        -- Covariant or contravariant context
+       -> Type
+       -> (a, Bool)   -- (result of type a, does type contain var)
+
+    go co ty | Just ty' <- tcView ty = go co ty'
+    go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)
+    go co (FunTy x y)  | isPredTy x = go co y
+                       | xc || yc   = (caseFun xr yr,True)
+        where (xr,xc) = go (not co) x
+              (yr,yc) = go co       y
+    go co (AppTy    x y) | xc = (caseWrongArg,   True)
+                         | yc = (caseTyApp x yr, True)
+        where (_, xc) = go co x
+              (yr,yc) = go co y
+    go co ty@(TyConApp con args)
+       | not (or xcs)     = (caseTrivial, False)   -- Variable does not occur
+       -- At this point we know that xrs, xcs is not empty,
+       -- and at least one xr is True
+       | isTupleTyCon con = (caseTuple con xrs, True)
+       | or (init xcs)    = (caseWrongArg, True)         -- T (..var..)    ty
+       | Just (fun_ty, _) <- splitAppTy_maybe ty         -- T (..no var..) ty
+                          = (caseTyApp fun_ty (last xrs), True)
+       | otherwise        = (caseWrongArg, True)   -- Non-decomposable (eg type function)
+       where
+         -- When folding over an unboxed tuple, we must explicitly drop the
+         -- runtime rep arguments, or else GHC will generate twice as many
+         -- variables in a unboxed tuple pattern match and expression as it
+         -- actually needs. See Trac #12399
+         (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args))
+    go co (ForAllTy (Bndr v vis) x)
+       | isVisibleArgFlag vis = panic "unexpected visible binder"
+       | v /= var && xc       = (caseForAll v xr,True)
+       where (xr,xc) = go co x
+
+    go _ _ = (caseTrivial,False)
+
+-- Return all syntactic subterms of ty that contain var somewhere
+-- These are the things that should appear in instance constraints
+deepSubtypesContaining :: TyVar -> Type -> [TcType]
+deepSubtypesContaining tv
+  = functorLikeTraverse tv
+        (FT { ft_triv = []
+            , ft_var = []
+            , ft_fun = (++)
+            , ft_tup = \_ xs -> concat xs
+            , ft_ty_app = (:)
+            , ft_bad_app = panic "in other argument in deepSubtypesContaining"
+            , ft_co_var = panic "contravariant in deepSubtypesContaining"
+            , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
+
+
+foldDataConArgs :: FFoldType a -> DataCon -> [a]
+-- Fold over the arguments of the datacon
+foldDataConArgs ft con
+  = map foldArg (dataConOrigArgTys con)
+  where
+    foldArg
+      = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
+             Just tv -> functorLikeTraverse tv ft
+             Nothing -> const (ft_triv ft)
+    -- If we are deriving Foldable for a GADT, there is a chance that the last
+    -- type variable in the data type isn't actually a type variable at all.
+    -- (for example, this can happen if the last type variable is refined to
+    -- be a concrete type such as Int). If the last type variable is refined
+    -- to be a specific type, then getTyVar_maybe will return Nothing.
+    -- See Note [DeriveFoldable with ExistentialQuantification]
+    --
+    -- The kind checks have ensured the last type parameter is of kind *.
+
+-- Make a HsLam using a fresh variable from a State monad
+mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
+            -> State [RdrName] (LHsExpr GhcPs)
+-- (mkSimpleLam fn) returns (\x. fn(x))
+mkSimpleLam lam =
+    get >>= \case
+      n:names -> do
+        put names
+        body <- lam (nlHsVar n)
+        return (mkHsLam [nlVarPat n] body)
+      _ -> panic "mkSimpleLam"
+
+mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs
+             -> State [RdrName] (LHsExpr GhcPs))
+             -> State [RdrName] (LHsExpr GhcPs)
+mkSimpleLam2 lam =
+    get >>= \case
+      n1:n2:names -> do
+        put names
+        body <- lam (nlHsVar n1) (nlHsVar n2)
+        return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
+      _ -> panic "mkSimpleLam2"
+
+-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
+--
+-- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in
+-- which the LHS pattern-matches on @extra_pats@, followed by a match on the
+-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
+-- and its arguments, applying an expression (from @insides@) to each of the
+-- respective arguments of @con@.
+mkSimpleConMatch :: Monad m => HsMatchContext RdrName
+                 -> (RdrName -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
+                 -> [LPat GhcPs]
+                 -> DataCon
+                 -> [LHsExpr GhcPs]
+                 -> m (LMatch GhcPs (LHsExpr GhcPs))
+mkSimpleConMatch ctxt fold extra_pats con insides = do
+    let con_name = getRdrName con
+    let vars_needed = takeList insides as_RDRs
+    let bare_pat = nlConVarPat con_name vars_needed
+    let pat = if null vars_needed
+          then bare_pat
+          else nlParPat bare_pat
+    rhs <- fold con_name
+                (zipWith (\i v -> i `nlHsApp` nlHsVar v) insides vars_needed)
+    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
+                     (noLoc emptyLocalBinds)
+
+-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
+--
+-- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to
+-- 'mkSimpleConMatch', with two key differences:
+--
+-- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a
+--    @[LHsExpr RdrName]@. This is because it filters out the expressions
+--    corresponding to arguments whose types do not mention the last type
+--    variable in a derived 'Foldable' or 'Traversable' instance (i.e., the
+--    'Nothing' elements of @insides@).
+--
+-- 2. @fold@ takes an expression as its first argument instead of a
+--    constructor name. This is because it uses a specialized
+--    constructor function expression that only takes as many parameters as
+--    there are argument types that mention the last type variable.
+--
+-- See Note [Generated code for DeriveFoldable and DeriveTraversable]
+mkSimpleConMatch2 :: Monad m
+                  => HsMatchContext RdrName
+                  -> (LHsExpr GhcPs -> [LHsExpr GhcPs]
+                                      -> m (LHsExpr GhcPs))
+                  -> [LPat GhcPs]
+                  -> DataCon
+                  -> [Maybe (LHsExpr GhcPs)]
+                  -> m (LMatch GhcPs (LHsExpr GhcPs))
+mkSimpleConMatch2 ctxt fold extra_pats con insides = do
+    let con_name = getRdrName con
+        vars_needed = takeList insides as_RDRs
+        pat = nlConVarPat con_name vars_needed
+        -- Make sure to zip BEFORE invoking catMaybes. We want the variable
+        -- indicies in each expression to match up with the argument indices
+        -- in con_expr (defined below).
+        exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i)
+                                   insides vars_needed
+        -- An element of argTysTyVarInfo is True if the constructor argument
+        -- with the same index has a type which mentions the last type
+        -- variable.
+        argTysTyVarInfo = map isJust insides
+        (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars
+
+        con_expr
+          | null asWithTyVar = nlHsApps con_name asWithoutTyVar
+          | otherwise =
+              let bs   = filterByList  argTysTyVarInfo bs_RDRs
+                  vars = filterByLists argTysTyVarInfo bs_Vars as_Vars
+              in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)
+
+    rhs <- fold con_expr exps
+    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
+                     (noLoc emptyLocalBinds)
+
+-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
+mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a]
+                                 -> m (LMatch GhcPs (LHsExpr GhcPs)))
+                  -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
+mkSimpleTupleCase match_for_con tc insides x
+  = do { let data_con = tyConSingleDataCon tc
+       ; match <- match_for_con [] data_con insides
+       ; return $ nlHsCase x [match] }
+
+{-
+************************************************************************
+*                                                                      *
+                        Foldable instances
+
+ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
+
+*                                                                      *
+************************************************************************
+
+Deriving Foldable instances works the same way as Functor instances,
+only Foldable instances are not possible for function types at all.
+Given (data T a = T a a (T a) deriving Foldable), we get:
+
+  instance Foldable T where
+      foldr f z (T x1 x2 x3) =
+        $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) )
+
+-XDeriveFoldable is different from -XDeriveFunctor in that it filters out
+arguments to the constructor that would produce useless code in a Foldable
+instance. For example, the following datatype:
+
+  data Foo a = Foo Int a Int deriving Foldable
+
+would have the following generated Foldable instance:
+
+  instance Foldable Foo where
+    foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2
+
+since neither of the two Int arguments are folded over.
+
+The cases are:
+
+  $(foldr 'a 'a)         =  f
+  $(foldr 'a '(b1,b2))   =  \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
+  $(foldr 'a '(T b1 b2)) =  \x z -> foldr $(foldr 'a 'b2) z x  -- when a only occurs in the last parameter, b2
+
+Note that the arguments to the real foldr function are the wrong way around,
+since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
+
+One can envision a case for types that don't contain the last type variable:
+
+  $(foldr 'a 'b)         =  \x z -> z     -- when b does not contain a
+
+But this case will never materialize, since the aforementioned filtering
+removes all such types from consideration.
+See Note [Generated code for DeriveFoldable and DeriveTraversable].
+
+Foldable instances differ from Functor and Traversable instances in that
+Foldable instances can be derived for data types in which the last type
+variable is existentially quantified. In particular, if the last type variable
+is refined to a more specific type in a GADT:
+
+  data GADT a where
+      G :: a ~ Int => a -> G Int
+
+then the deriving machinery does not attempt to check that the type a contains
+Int, since it is not syntactically equal to a type variable. That is, the
+derived Foldable instance for GADT is:
+
+  instance Foldable GADT where
+      foldr _ z (GADT _) = z
+
+See Note [DeriveFoldable with ExistentialQuantification].
+
+Note [Deriving null]
+~~~~~~~~~~~~~~~~~~~~
+
+In some cases, deriving the definition of 'null' can produce much better
+results than the default definition. For example, with
+
+  data SnocList a = Nil | Snoc (SnocList a) a
+
+the default definition of 'null' would walk the entire spine of a
+nonempty snoc-list before concluding that it is not null. But looking at
+the Snoc constructor, we can immediately see that it contains an 'a', and
+so 'null' can return False immediately if it matches on Snoc. When we
+derive 'null', we keep track of things that cannot be null. The interesting
+case is type application. Given
+
+  data Wrap a = Wrap (Foo (Bar a))
+
+we use
+
+  null (Wrap fba) = all null fba
+
+but if we see
+
+  data Wrap a = Wrap (Foo a)
+
+we can just use
+
+  null (Wrap fa) = null fa
+
+Indeed, we allow this to happen even for tuples:
+
+  data Wrap a = Wrap (Foo (a, Int))
+
+produces
+
+  null (Wrap fa) = null fa
+
+As explained in Note [Deriving <$], giving tuples special performance treatment
+could surprise users if they switch to other types, but Ryan Scott seems to
+think it's okay to do it for now.
+-}
+
+gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+-- When the parameter is phantom, we can use foldMap _ _ = mempty
+-- See Note [Phantom types with Functor, Foldable, and Traversable]
+gen_Foldable_binds loc tycon
+  | Phantom <- last (tyConRoles tycon)
+  = (unitBag foldMap_bind, emptyBag)
+  where
+    foldMap_name = L loc foldMap_RDR
+    foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns
+    foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt
+                                  [nlWildPat, nlWildPat]
+                                  mempty_Expr]
+    foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
+
+gen_Foldable_binds loc tycon
+  | null data_cons  -- There's no real point producing anything but
+                    -- foldMap for a type with no constructors.
+  = (unitBag foldMap_bind, emptyBag)
+
+  | otherwise
+  = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag)
+  where
+    data_cons = tyConDataCons tycon
+
+    foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
+    eqns = map foldr_eqn data_cons
+    foldr_eqn con
+      = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
+      where
+        parts = sequence $ foldDataConArgs ft_foldr con
+
+    foldMap_name = L loc foldMap_RDR
+
+    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
+    foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr)
+                      foldMap_name foldMap_eqns
+
+    foldMap_eqns = map foldMap_eqn data_cons
+
+    foldMap_eqn con
+      = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
+      where
+        parts = sequence $ foldDataConArgs ft_foldMap con
+
+    -- Given a list of NullM results, produce Nothing if any of
+    -- them is NotNull, and otherwise produce a list of Maybes
+    -- with Justs representing unknowns and Nothings representing
+    -- things that are definitely null.
+    convert :: [NullM a] -> Maybe [Maybe a]
+    convert = traverse go where
+      go IsNull = Just Nothing
+      go NotNull = Nothing
+      go (NullM a) = Just (Just a)
+
+    null_name = L loc null_RDR
+    null_match_ctxt = mkPrefixFunRhs null_name
+    null_bind = mkRdrFunBind null_name null_eqns
+    null_eqns = map null_eqn data_cons
+    null_eqn con
+      = flip evalState bs_RDRs $ do
+          parts <- sequence $ foldDataConArgs ft_null con
+          case convert parts of
+            Nothing -> return $
+              mkMatch null_match_ctxt [nlParPat (nlWildConPat con)]
+                false_Expr (noLoc emptyLocalBinds)
+            Just cp -> match_null [] con cp
+
+    -- Yields 'Just' an expression if we're folding over a type that mentions
+    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
+    -- See Note [FFoldType and functorLikeTraverse]
+    ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
+    ft_foldr
+      = FT { ft_triv    = return Nothing
+             -- foldr f = \x z -> z
+           , ft_var     = return $ Just f_Expr
+             -- foldr f = f
+           , ft_tup     = \t g -> do
+               gg  <- sequence g
+               lam <- mkSimpleLam2 $ \x z ->
+                 mkSimpleTupleCase (match_foldr z) t gg x
+               return (Just lam)
+             -- foldr f = (\x z -> case x of ...)
+           , ft_ty_app  = \_ g -> do
+               gg <- g
+               mapM (\gg' -> mkSimpleLam2 $ \x z -> return $
+                 nlHsApps foldable_foldr_RDR [gg',z,x]) gg
+             -- foldr f = (\x z -> foldr g z x)
+           , ft_forall  = \_ g -> g
+           , ft_co_var  = panic "contravariant in ft_foldr"
+           , ft_fun     = panic "function in ft_foldr"
+           , ft_bad_app = panic "in other argument in ft_foldr" }
+
+    match_foldr :: LHsExpr GhcPs
+                -> [LPat GhcPs]
+                -> DataCon
+                -> [Maybe (LHsExpr GhcPs)]
+                -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
+    match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)
+      where
+        -- g1 v1 (g2 v2 (.. z))
+        mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
+        mkFoldr = foldr nlHsApp z
+
+    -- See Note [FFoldType and functorLikeTraverse]
+    ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
+    ft_foldMap
+      = FT { ft_triv = return Nothing
+             -- foldMap f = \x -> mempty
+           , ft_var  = return (Just f_Expr)
+             -- foldMap f = f
+           , ft_tup  = \t g -> do
+               gg  <- sequence g
+               lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
+               return (Just lam)
+             -- foldMap f = \x -> case x of (..,)
+           , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g
+             -- foldMap f = foldMap g
+           , ft_forall = \_ g -> g
+           , ft_co_var = panic "contravariant in ft_foldMap"
+           , ft_fun = panic "function in ft_foldMap"
+           , ft_bad_app = panic "in other argument in ft_foldMap" }
+
+    match_foldMap :: [LPat GhcPs]
+                  -> DataCon
+                  -> [Maybe (LHsExpr GhcPs)]
+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
+    match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)
+      where
+        -- mappend v1 (mappend v2 ..)
+        mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs
+        mkFoldMap [] = mempty_Expr
+        mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
+
+    -- See Note [FFoldType and functorLikeTraverse]
+    -- Yields NullM an expression if we're folding over an expression
+    -- that may or may not be null. Yields IsNull if it's certainly
+    -- null, and yields NotNull if it's certainly not null.
+    -- See Note [Deriving null]
+    ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs)))
+    ft_null
+      = FT { ft_triv = return IsNull
+             -- null = \_ -> True
+           , ft_var  = return NotNull
+             -- null = \_ -> False
+           , ft_tup  = \t g -> do
+               gg  <- sequence g
+               case convert gg of
+                 Nothing -> pure NotNull
+                 Just ggg ->
+                   NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg)
+             -- null = \x -> case x of (..,)
+           , ft_ty_app = \_ g -> flip fmap g $ \nestedResult ->
+                              case nestedResult of
+                                -- If e definitely contains the parameter,
+                                -- then we can test if (G e) contains it by
+                                -- simply checking if (G e) is null
+                                NotNull -> NullM null_Expr
+                                -- This case is unreachable--it will actually be
+                                -- caught by ft_triv
+                                IsNull -> IsNull
+                                -- The general case uses (all null),
+                                -- (all (all null)), etc.
+                                NullM nestedTest -> NullM $
+                                                    nlHsApp all_Expr nestedTest
+             -- null fa = null fa, or null fa = all null fa, or null fa = True
+           , ft_forall = \_ g -> g
+           , ft_co_var = panic "contravariant in ft_null"
+           , ft_fun = panic "function in ft_null"
+           , ft_bad_app = panic "in other argument in ft_null" }
+
+    match_null :: [LPat GhcPs]
+                  -> DataCon
+                  -> [Maybe (LHsExpr GhcPs)]
+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
+    match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs)
+      where
+        -- v1 && v2 && ..
+        mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs
+        mkNull [] = true_Expr
+        mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs
+
+data NullM a =
+    IsNull   -- Definitely null
+  | NotNull  -- Definitely not null
+  | NullM a  -- Unknown
+
+{-
+************************************************************************
+*                                                                      *
+                        Traversable instances
+
+ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
+*                                                                      *
+************************************************************************
+
+Again, Traversable is much like Functor and Foldable.
+
+The cases are:
+
+  $(traverse 'a 'a)          =  f
+  $(traverse 'a '(b1,b2))    =  \x -> case x of (x1,x2) ->
+     liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2)
+  $(traverse 'a '(T b1 b2))  =  traverse $(traverse 'a 'b2)  -- when a only occurs in the last parameter, b2
+
+Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types
+do not mention the last type parameter. Therefore, the following datatype:
+
+  data Foo a = Foo Int a Int
+
+would have the following derived Traversable instance:
+
+  instance Traversable Foo where
+    traverse f (Foo x1 x2 x3) =
+      fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 )
+
+since the two Int arguments do not produce any effects in a traversal.
+
+One can envision a case for types that do not mention the last type parameter:
+
+  $(traverse 'a 'b)          =  pure     -- when b does not contain a
+
+But this case will never materialize, since the aforementioned filtering
+removes all such types from consideration.
+See Note [Generated code for DeriveFoldable and DeriveTraversable].
+-}
+
+gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+-- When the argument is phantom, we can use traverse = pure . coerce
+-- See Note [Phantom types with Functor, Foldable, and Traversable]
+gen_Traversable_binds loc tycon
+  | Phantom <- last (tyConRoles tycon)
+  = (unitBag traverse_bind, emptyBag)
+  where
+    traverse_name = L loc traverse_RDR
+    traverse_bind = mkRdrFunBind traverse_name traverse_eqns
+    traverse_eqns =
+        [mkSimpleMatch traverse_match_ctxt
+                       [nlWildPat, z_Pat]
+                       (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
+    traverse_match_ctxt = mkPrefixFunRhs traverse_name
+
+gen_Traversable_binds loc tycon
+  = (unitBag traverse_bind, emptyBag)
+  where
+    data_cons = tyConDataCons tycon
+
+    traverse_name = L loc traverse_RDR
+
+    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
+    traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr)
+                                   traverse_name traverse_eqns
+    traverse_eqns = map traverse_eqn data_cons
+    traverse_eqn con
+      = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
+      where
+        parts = sequence $ foldDataConArgs ft_trav con
+
+    -- Yields 'Just' an expression if we're folding over a type that mentions
+    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
+    -- See Note [FFoldType and functorLikeTraverse]
+    ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
+    ft_trav
+      = FT { ft_triv    = return Nothing
+             -- traverse f = pure x
+           , ft_var     = return (Just f_Expr)
+             -- traverse f = f x
+           , ft_tup     = \t gs -> do
+               gg  <- sequence gs
+               lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
+               return (Just lam)
+             -- traverse f = \x -> case x of (a1,a2,..) ->
+             --                           liftA2 (,,) (g1 a1) (g2 a2) <*> ..
+           , ft_ty_app  = \_ g -> fmap (nlHsApp traverse_Expr) <$> g
+             -- traverse f = traverse g
+           , ft_forall  = \_ g -> g
+           , ft_co_var  = panic "contravariant in ft_trav"
+           , ft_fun     = panic "function in ft_trav"
+           , ft_bad_app = panic "in other argument in ft_trav" }
+
+    -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
+    --                    (g2 a2) <*> ...
+    match_for_con :: [LPat GhcPs]
+                  -> DataCon
+                  -> [Maybe (LHsExpr GhcPs)]
+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
+    match_for_con = mkSimpleConMatch2 CaseAlt $
+                                             \con xs -> return (mkApCon con xs)
+      where
+        -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
+        mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
+        mkApCon con [] = nlHsApps pure_RDR [con]
+        mkApCon con [x] = nlHsApps fmap_RDR [con,x]
+        mkApCon con (x1:x2:xs) =
+            foldl' appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs
+          where appAp x y = nlHsApps ap_RDR [x,y]
+
+-----------------------------------------------------------------------
+
+f_Expr, z_Expr, fmap_Expr, replace_Expr, mempty_Expr, foldMap_Expr,
+    traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr,
+    all_Expr, null_Expr :: LHsExpr GhcPs
+f_Expr        = nlHsVar f_RDR
+z_Expr        = nlHsVar z_RDR
+fmap_Expr     = nlHsVar fmap_RDR
+replace_Expr  = nlHsVar replace_RDR
+mempty_Expr   = nlHsVar mempty_RDR
+foldMap_Expr  = nlHsVar foldMap_RDR
+traverse_Expr = nlHsVar traverse_RDR
+coerce_Expr   = nlHsVar (getRdrName coerceId)
+pure_Expr     = nlHsVar pure_RDR
+true_Expr     = nlHsVar true_RDR
+false_Expr    = nlHsVar false_RDR
+all_Expr      = nlHsVar all_RDR
+null_Expr     = nlHsVar null_RDR
+
+f_RDR, z_RDR :: RdrName
+f_RDR = mkVarUnqual (fsLit "f")
+z_RDR = mkVarUnqual (fsLit "z")
+
+as_RDRs, bs_RDRs :: [RdrName]
+as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
+bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
+
+as_Vars, bs_Vars :: [LHsExpr GhcPs]
+as_Vars = map nlHsVar as_RDRs
+bs_Vars = map nlHsVar bs_RDRs
+
+f_Pat, z_Pat :: LPat GhcPs
+f_Pat = nlVarPat f_RDR
+z_Pat = nlVarPat z_RDR
+
+{-
+Note [DeriveFoldable with ExistentialQuantification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Functor and Traversable instances can only be derived for data types whose
+last type parameter is truly universally polymorphic. For example:
+
+  data T a b where
+    T1 ::                 b   -> T a b   -- YES, b is unconstrained
+    T2 :: Ord b   =>      b   -> T a b   -- NO, b is constrained by (Ord b)
+    T3 :: b ~ Int =>      b   -> T a b   -- NO, b is constrained by (b ~ Int)
+    T4 ::                 Int -> T a Int -- NO, this is just like T3
+    T5 :: Ord a   => a -> b   -> T a b   -- YES, b is unconstrained, even
+                                         -- though a is existential
+    T6 ::                 Int -> T Int b -- YES, b is unconstrained
+
+For Foldable instances, however, we can completely lift the constraint that
+the last type parameter be truly universally polymorphic. This means that T
+(as defined above) can have a derived Foldable instance:
+
+  instance Foldable (T a) where
+    foldr f z (T1 b)   = f b z
+    foldr f z (T2 b)   = f b z
+    foldr f z (T3 b)   = f b z
+    foldr f z (T4 b)   = z
+    foldr f z (T5 a b) = f b z
+    foldr f z (T6 a)   = z
+
+    foldMap f (T1 b)   = f b
+    foldMap f (T2 b)   = f b
+    foldMap f (T3 b)   = f b
+    foldMap f (T4 b)   = mempty
+    foldMap f (T5 a b) = f b
+    foldMap f (T6 a)   = mempty
+
+In a Foldable instance, it is safe to fold over an occurrence of the last type
+parameter that is not truly universally polymorphic. However, there is a bit
+of subtlety in determining what is actually an occurrence of a type parameter.
+T3 and T4, as defined above, provide one example:
+
+  data T a b where
+    ...
+    T3 :: b ~ Int => b   -> T a b
+    T4 ::            Int -> T a Int
+    ...
+
+  instance Foldable (T a) where
+    ...
+    foldr f z (T3 b) = f b z
+    foldr f z (T4 b) = z
+    ...
+    foldMap f (T3 b) = f b
+    foldMap f (T4 b) = mempty
+    ...
+
+Notice that the argument of T3 is folded over, whereas the argument of T4 is
+not. This is because we only fold over constructor arguments that
+syntactically mention the universally quantified type parameter of that
+particular data constructor. See foldDataConArgs for how this is implemented.
+
+As another example, consider the following data type. The argument of each
+constructor has the same type as the last type parameter:
+
+  data E a where
+    E1 :: (a ~ Int) => a   -> E a
+    E2 ::              Int -> E Int
+    E3 :: (a ~ Int) => a   -> E Int
+    E4 :: (a ~ Int) => Int -> E a
+
+Only E1's argument is an occurrence of a universally quantified type variable
+that is syntactically equivalent to the last type parameter, so only E1's
+argument will be folded over in a derived Foldable instance.
+
+See Trac #10447 for the original discussion on this feature. Also see
+https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
+for a more in-depth explanation.
+
+Note [FFoldType and functorLikeTraverse]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Deriving Functor, Foldable, and Traversable all require generating expressions
+which perform an operation on each argument of a data constructor depending
+on the argument's type. In particular, a generated operation can be different
+depending on whether the type mentions the last type variable of the datatype
+(e.g., if you have data T a = MkT a Int, then a generated foldr expression would
+fold over the first argument of MkT, but not the second).
+
+This pattern is abstracted with the FFoldType datatype, which provides hooks
+for the user to specify how a constructor argument should be folded when it
+has a type with a particular "shape". The shapes are as follows (assume that
+a is the last type variable in a given datatype):
+
+* ft_triv:    The type does not mention the last type variable at all.
+              Examples: Int, b
+
+* ft_var:     The type is syntactically equal to the last type variable.
+              Moreover, the type appears in a covariant position (see
+              the Deriving Functor instances section of the user's guide
+              for an in-depth explanation of covariance vs. contravariance).
+              Example: a (covariantly)
+
+* ft_co_var:  The type is syntactically equal to the last type variable.
+              Moreover, the type appears in a contravariant position.
+              Example: a (contravariantly)
+
+* ft_fun:     A function type which mentions the last type variable in
+              the argument position, result position or both.
+              Examples: a -> Int, Int -> a, Maybe a -> [a]
+
+* ft_tup:     A tuple type which mentions the last type variable in at least
+              one of its fields. The TyCon argument of ft_tup represents the
+              particular tuple's type constructor.
+              Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #)
+
+* ft_ty_app:  A type is being applied to the last type parameter, where the
+              applied type does not mention the last type parameter (if it
+              did, it would fall under ft_bad_app). The Type argument to
+              ft_ty_app represents the applied type.
+
+              Note that functions, tuples, and foralls are distinct cases
+              and take precedence of ft_ty_app. (For example, (Int -> a) would
+              fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).
+              Examples: Maybe a, Either b a
+
+* ft_bad_app: A type application uses the last type parameter in a position
+              other than the last argument. This case is singled out because
+              Functor, Foldable, and Traversable instances cannot be derived
+              for datatypes containing arguments with such types.
+              Examples: Either a Int, Const a b
+
+* ft_forall:  A forall'd type mentions the last type parameter on its right-
+              hand side (and is not quantified on the left-hand side). This
+              case is present mostly for plumbing purposes.
+              Example: forall b. Either b a
+
+If FFoldType describes a strategy for folding subcomponents of a Type, then
+functorLikeTraverse is the function that applies that strategy to the entirety
+of a Type, returning the final folded-up result.
+
+foldDataConArgs applies functorLikeTraverse to every argument type of a
+constructor, returning a list of the fold results. This makes foldDataConArgs
+a natural way to generate the subexpressions in a generated fmap, foldr,
+foldMap, or traverse definition (the subexpressions must then be combined in
+a method-specific fashion to form the final generated expression).
+
+Deriving Generic1 also does validity checking by looking for the last type
+variable in certain positions of a constructor's argument types, so it also
+uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics.
+
+Note [Generated code for DeriveFoldable and DeriveTraversable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on
+that of -XDeriveFunctor. However, there an important difference between deriving
+the former two typeclasses and the latter one, which is best illustrated by the
+following scenario:
+
+  data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable)
+
+The generated code for the Functor instance is straightforward:
+
+  instance Functor WithInt where
+    fmap f (WithInt a i) = WithInt (f a) i
+
+But if we use too similar of a strategy for deriving the Foldable and
+Traversable instances, we end up with this code:
+
+  instance Foldable WithInt where
+    foldMap f (WithInt a i) = f a <> mempty
+
+  instance Traversable WithInt where
+    traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i
+
+This is unsatisfying for two reasons:
+
+1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure
+   expects an argument whose type is of kind *. This effectively prevents
+   Traversable from being derived for any datatype with an unlifted argument
+   type (Trac #11174).
+
+2. The generated code contains superfluous expressions. By the Monoid laws,
+   we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can
+   reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)).
+
+We can fix both of these issues by incorporating a slight twist to the usual
+algorithm that we use for -XDeriveFunctor. The differences can be summarized
+as follows:
+
+1. In the generated expression, we only fold over arguments whose types
+   mention the last type parameter. Any other argument types will simply
+   produce useless 'mempty's or 'pure's, so they can be safely ignored.
+
+2. In the case of -XDeriveTraversable, instead of applying ConName,
+   we apply (\b_i ... b_k -> ConName a_1 ... a_n), where
+
+   * ConName has n arguments
+   * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond
+     to the arguments whose types mention the last type parameter. As a
+     consequence, taking the difference of {a_1, ..., a_n} and
+     {b_i, ..., b_k} yields the all the argument values of ConName whose types
+     do not mention the last type parameter. Note that [i, ..., k] is a
+     strictly increasing—but not necessarily consecutive—integer sequence.
+
+     For example, the datatype
+
+       data Foo a = Foo Int a Int a
+
+     would generate the following Traversable instance:
+
+       instance Traversable Foo where
+         traverse f (Foo a1 a2 a3 a4) =
+           fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4
+
+Technically, this approach would also work for -XDeriveFunctor as well, but we
+decide not to do so because:
+
+1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a))
+   instead of (WithInt (f a) i).
+
+2. There would be certain datatypes for which the above strategy would
+   generate Functor code that would fail to typecheck. For example:
+
+     data Bar f a = Bar (forall f. Functor f => f a) deriving Functor
+
+   With the conventional algorithm, it would generate something like:
+
+     fmap f (Bar a) = Bar (fmap f a)
+
+   which typechecks. But with the strategy mentioned above, it would generate:
+
+     fmap f (Bar a) = (\b -> Bar b) (fmap f a)
+
+   which does not typecheck, since GHC cannot unify the rank-2 type variables
+   in the types of b and (fmap f a).
+
+Note [Phantom types with Functor, Foldable, and Traversable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Given a type F :: * -> * whose type argument has a phantom role, we can always
+produce lawful Functor and Traversable instances using
+
+    fmap _ = coerce
+    traverse _ = pure . coerce
+
+Indeed, these are equivalent to any *strictly lawful* instances one could
+write, except that this definition of 'traverse' may be lazier.  That is, if
+instances obey the laws under true equality (rather than up to some equivalence
+relation), then they will be essentially equivalent to these. These definitions
+are incredibly cheap, so we want to use them even if it means ignoring some
+non-strictly-lawful instance in an embedded type.
+
+Foldable has far fewer laws to work with, which leaves us unwelcome
+freedom in implementing it. At a minimum, we would like to ensure that
+a derived foldMap is always at least as good as foldMapDefault with a
+derived traverse. To accomplish that, we must define
+
+   foldMap _ _ = mempty
+
+in these cases.
+
+This may have different strictness properties from a standard derivation.
+Consider
+
+   data NotAList a = Nil | Cons (NotAList a) deriving Foldable
+
+The usual deriving mechanism would produce
+
+   foldMap _ Nil = mempty
+   foldMap f (Cons x) = foldMap f x
+
+which is strict in the entire spine of the NotAList.
+
+Final point: why do we even care about such types? Users will rarely if ever
+map, fold, or traverse over such things themselves, but other derived
+instances may:
+
+   data Hasn'tAList a = NotHere a (NotAList a) deriving Foldable
+
+Note [EmptyDataDecls with Functor, Foldable, and Traversable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+There are some slightly tricky decisions to make about how to handle
+Functor, Foldable, and Traversable instances for types with no constructors.
+For fmap, the two basic options are
+
+   fmap _ _ = error "Sorry, no constructors"
+
+or
+
+   fmap _ z = case z of
+
+In most cases, the latter is more helpful: if the thunk passed to fmap
+throws an exception, we're generally going to be much more interested in
+that exception than in the fact that there aren't any constructors.
+
+In order to match the semantics for phantoms (see note above), we need to
+be a bit careful about 'traverse'. The obvious definition would be
+
+   traverse _ z = case z of
+
+but this is stricter than the one for phantoms. We instead use
+
+   traverse _ z = pure $ case z of
+
+For foldMap, the obvious choices are
+
+   foldMap _ _ = mempty
+
+or
+
+   foldMap _ z = case z of
+
+We choose the first one to be consistent with what foldMapDefault does for
+a derived Traversable instance.
+-}
diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcGenGenerics.hs
@@ -0,0 +1,1043 @@
+{-
+(c) The University of Glasgow 2011
+
+
+The deriving code for the Generic class
+(equivalent to the code in TcGenDeriv, for other classes)
+-}
+
+{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcGenGenerics (canDoGenerics, canDoGenerics1,
+                      GenericKind(..),
+                      gen_Generic_binds, get_gen1_constrained_tys) where
+
+import GhcPrelude
+
+import HsSyn
+import Type
+import TcType
+import TcGenDeriv
+import TcGenFunctor
+import DataCon
+import TyCon
+import FamInstEnv       ( FamInst, FamFlavor(..), mkSingleCoAxiom )
+import FamInst
+import Module           ( moduleName, moduleNameFS
+                        , moduleUnitId, unitIdFS, getModule )
+import IfaceEnv         ( newGlobalBinder )
+import Name      hiding ( varName )
+import RdrName
+import BasicTypes
+import TysPrim
+import TysWiredIn
+import PrelNames
+import TcEnv
+import TcRnMonad
+import HscTypes
+import ErrUtils( Validity(..), andValid )
+import SrcLoc
+import Bag
+import VarEnv
+import VarSet (elemVarSet)
+import Outputable
+import FastString
+import Util
+
+import Control.Monad (mplus)
+import Data.List (zip4, partition)
+import Data.Maybe (isJust)
+
+#include "HsVersions.h"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Bindings for the new generic deriving mechanism}
+*                                                                      *
+************************************************************************
+
+For the generic representation we need to generate:
+\begin{itemize}
+\item A Generic instance
+\item A Rep type instance
+\item Many auxiliary datatypes and instances for them (for the meta-information)
+\end{itemize}
+-}
+
+gen_Generic_binds :: GenericKind -> TyCon -> [Type]
+                 -> TcM (LHsBinds GhcPs, FamInst)
+gen_Generic_binds gk tc inst_tys = do
+  repTyInsts <- tc_mkRepFamInsts gk tc inst_tys
+  return (mkBindsRep gk tc, repTyInsts)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Generating representation types}
+*                                                                      *
+************************************************************************
+-}
+
+get_gen1_constrained_tys :: TyVar -> Type -> [Type]
+-- called by TcDeriv.inferConstraints; generates a list of types, each of which
+-- must be a Functor in order for the Generic1 instance to work.
+get_gen1_constrained_tys argVar
+  = argTyFold argVar $ ArgTyAlg { ata_rec0 = const []
+                                , ata_par1 = [], ata_rec1 = const []
+                                , ata_comp = (:) }
+
+{-
+
+Note [Requirements for deriving Generic and Rep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+In the following, T, Tfun, and Targ are "meta-variables" ranging over type
+expressions.
+
+(Generic T) and (Rep T) are derivable for some type expression T if the
+following constraints are satisfied.
+
+  (a) D is a type constructor *value*. In other words, D is either a type
+      constructor or it is equivalent to the head of a data family instance (up to
+      alpha-renaming).
+
+  (b) D cannot have a "stupid context".
+
+  (c) The right-hand side of D cannot include existential types, universally
+      quantified types, or "exotic" unlifted types. An exotic unlifted type
+      is one which is not listed in the definition of allowedUnliftedTy
+      (i.e., one for which we have no representation type).
+      See Note [Generics and unlifted types]
+
+  (d) T :: *.
+
+(Generic1 T) and (Rep1 T) are derivable for some type expression T if the
+following constraints are satisfied.
+
+  (a),(b),(c) As above.
+
+  (d) T must expect arguments, and its last parameter must have kind *.
+
+      We use `a' to denote the parameter of D that corresponds to the last
+      parameter of T.
+
+  (e) For any type-level application (Tfun Targ) in the right-hand side of D
+      where the head of Tfun is not a tuple constructor:
+
+      (b1) `a' must not occur in Tfun.
+
+      (b2) If `a' occurs in Targ, then Tfun :: * -> *.
+
+-}
+
+canDoGenerics :: TyCon -> Validity
+-- canDoGenerics determines if Generic/Rep can be derived.
+--
+-- Check (a) from Note [Requirements for deriving Generic and Rep] is taken
+-- care of because canDoGenerics is applied to rep tycons.
+--
+-- It returns IsValid if deriving is possible. It returns (NotValid reason)
+-- if not.
+canDoGenerics tc
+  = mergeErrors (
+          -- Check (b) from Note [Requirements for deriving Generic and Rep].
+              (if (not (null (tyConStupidTheta tc)))
+                then (NotValid (tc_name <+> text "must not have a datatype context"))
+                else IsValid)
+          -- See comment below
+            : (map bad_con (tyConDataCons tc)))
+  where
+    -- The tc can be a representation tycon. When we want to display it to the
+    -- user (in an error message) we should print its parent
+    tc_name = ppr $ case tyConFamInst_maybe tc of
+        Just (ptc, _) -> ptc
+        _             -> tc
+
+        -- Check (c) from Note [Requirements for deriving Generic and Rep].
+        --
+        -- If any of the constructors has an exotic unlifted type as argument,
+        -- then we can't build the embedding-projection pair, because
+        -- it relies on instantiating *polymorphic* sum and product types
+        -- at the argument types of the constructors
+    bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
+                  then (NotValid (ppr dc <+> text
+                    "must not have exotic unlifted or polymorphic arguments"))
+                  else (if (not (isVanillaDataCon dc))
+                          then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))
+                          else IsValid)
+
+        -- Nor can we do the job if it's an existential data constructor,
+        -- Nor if the args are polymorphic types (I don't think)
+    bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty))
+                      || not (isTauTy ty)
+
+-- Returns True the Type argument is an unlifted type which has a
+-- corresponding generic representation type. For example,
+-- (allowedUnliftedTy Int#) would return True since there is the UInt
+-- representation type.
+allowedUnliftedTy :: Type -> Bool
+allowedUnliftedTy = isJust . unboxedRepRDRs
+
+mergeErrors :: [Validity] -> Validity
+mergeErrors []             = IsValid
+mergeErrors (NotValid s:t) = case mergeErrors t of
+  IsValid     -> NotValid s
+  NotValid s' -> NotValid (s <> text ", and" $$ s')
+mergeErrors (IsValid : t) = mergeErrors t
+
+-- A datatype used only inside of canDoGenerics1. It's the result of analysing
+-- a type term.
+data Check_for_CanDoGenerics1 = CCDG1
+  { _ccdg1_hasParam :: Bool       -- does the parameter of interest occurs in
+                                  -- this type?
+  , _ccdg1_errors   :: Validity   -- errors generated by this type
+  }
+
+{-
+
+Note [degenerate use of FFoldType]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We use foldDataConArgs here only for its ability to treat tuples
+specially. foldDataConArgs also tracks covariance (though it assumes all
+higher-order type parameters are covariant) and has hooks for special handling
+of functions and polytypes, but we do *not* use those.
+
+The key issue is that Generic1 deriving currently offers no sophisticated
+support for functions. For example, we cannot handle
+
+  data F a = F ((a -> Int) -> Int)
+
+even though a is occurring covariantly.
+
+In fact, our rule is harsh: a is simply not allowed to occur within the first
+argument of (->). We treat (->) the same as any other non-tuple tycon.
+
+Unfortunately, this means we have to track "the parameter occurs in this type"
+explicitly, even though foldDataConArgs is also doing this internally.
+
+-}
+
+-- canDoGenerics1 determines if a Generic1/Rep1 can be derived.
+--
+-- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep]
+-- are taken care of by the call to canDoGenerics.
+--
+-- It returns IsValid if deriving is possible. It returns (NotValid reason)
+-- if not.
+canDoGenerics1 :: TyCon -> Validity
+canDoGenerics1 rep_tc =
+  canDoGenerics rep_tc `andValid` additionalChecks
+  where
+    additionalChecks
+        -- check (d) from Note [Requirements for deriving Generic and Rep]
+      | null (tyConTyVars rep_tc) = NotValid $
+          text "Data type" <+> quotes (ppr rep_tc)
+      <+> text "must have some type parameters"
+
+      | otherwise = mergeErrors $ concatMap check_con data_cons
+
+    data_cons = tyConDataCons rep_tc
+    check_con con = case check_vanilla con of
+      j@(NotValid {}) -> [j]
+      IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con
+
+    bad :: DataCon -> SDoc -> SDoc
+    bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg
+
+    check_vanilla :: DataCon -> Validity
+    check_vanilla con | isVanillaDataCon con = IsValid
+                      | otherwise            = NotValid (bad con existential)
+
+    bmzero      = CCDG1 False IsValid
+    bmbad con s = CCDG1 True $ NotValid $ bad con s
+    bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2)
+
+    -- check (e) from Note [Requirements for deriving Generic and Rep]
+    -- See also Note [degenerate use of FFoldType]
+    ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1
+    ft_check con = FT
+      { ft_triv = bmzero
+
+      , ft_var = caseVar, ft_co_var = caseVar
+
+      -- (component_0,component_1,...,component_n)
+      , ft_tup = \_ components -> if any _ccdg1_hasParam (init components)
+                                  then bmbad con wrong_arg
+                                  else foldr bmplus bmzero components
+
+      -- (dom -> rng), where the head of ty is not a tuple tycon
+      , ft_fun = \dom rng -> -- cf #8516
+          if _ccdg1_hasParam dom
+          then bmbad con wrong_arg
+          else bmplus dom rng
+
+      -- (ty arg), where head of ty is neither (->) nor a tuple constructor and
+      -- the parameter of interest does not occur in ty
+      , ft_ty_app = \_ arg -> arg
+
+      , ft_bad_app = bmbad con wrong_arg
+      , ft_forall  = \_ body -> body -- polytypes are handled elsewhere
+      }
+      where
+        caseVar = CCDG1 True IsValid
+
+
+    existential = text "must not have existential arguments"
+    wrong_arg   = text "applies a type to an argument involving the last parameter"
+               $$ text "but the applied type is not of kind * -> *"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Generating the RHS of a generic default method}
+*                                                                      *
+************************************************************************
+-}
+
+type US = Int   -- Local unique supply, just a plain Int
+type Alt = (LPat GhcPs, LHsExpr GhcPs)
+
+-- GenericKind serves to mark if a datatype derives Generic (Gen0) or
+-- Generic1 (Gen1).
+data GenericKind = Gen0 | Gen1
+
+-- as above, but with a payload of the TyCon's name for "the" parameter
+data GenericKind_ = Gen0_ | Gen1_ TyVar
+
+-- as above, but using a single datacon's name for "the" parameter
+data GenericKind_DC = Gen0_DC | Gen1_DC TyVar
+
+forgetArgVar :: GenericKind_DC -> GenericKind
+forgetArgVar Gen0_DC   = Gen0
+forgetArgVar Gen1_DC{} = Gen1
+
+-- When working only within a single datacon, "the" parameter's name should
+-- match that datacon's name for it.
+gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC
+gk2gkDC Gen0_   _ = Gen0_DC
+gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d
+
+
+-- Bindings for the Generic instance
+mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs
+mkBindsRep gk tycon =
+    unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn])
+  `unionBags`
+    unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn])
+      where
+        -- The topmost M1 (the datatype metadata) has the exact same type
+        -- across all cases of a from/to definition, and can be factored out
+        -- to save some allocations during typechecking.
+        -- See Note [Generics compilation speed tricks]
+        from_eqn = mkHsCaseAlt x_Pat $ mkM1_E
+                                       $ nlHsPar $ nlHsCase x_Expr from_matches
+        to_eqn   = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches
+
+        from_matches  = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]
+        to_matches    = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts  ]
+        loc           = srcLocSpan (getSrcLoc tycon)
+        datacons      = tyConDataCons tycon
+
+        (from01_RDR, to01_RDR) = case gk of
+                                   Gen0 -> (from_RDR,  to_RDR)
+                                   Gen1 -> (from1_RDR, to1_RDR)
+
+        -- Recurse over the sum first
+        from_alts, to_alts :: [Alt]
+        (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons
+          where gk_ = case gk of
+                  Gen0 -> Gen0_
+                  Gen1 -> ASSERT(tyvars `lengthAtLeast` 1)
+                          Gen1_ (last tyvars)
+                    where tyvars = tyConTyVars tycon
+
+--------------------------------------------------------------------------------
+-- The type synonym instance and synonym
+--       type instance Rep (D a b) = Rep_D a b
+--       type Rep_D a b = ...representation type for D ...
+--------------------------------------------------------------------------------
+
+tc_mkRepFamInsts :: GenericKind   -- Gen0 or Gen1
+                 -> TyCon         -- The type to generate representation for
+                 -> [Type]        -- The type(s) to which Generic(1) is applied
+                                  -- in the generated instance
+                 -> TcM FamInst   -- Generated representation0 coercion
+tc_mkRepFamInsts gk tycon inst_tys =
+       -- Consider the example input tycon `D`, where data D a b = D_ a
+       -- Also consider `R:DInt`, where { data family D x y :: * -> *
+       --                               ; data instance D Int a b = D_ a }
+  do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family)
+       fam_tc <- case gk of
+         Gen0 -> tcLookupTyCon repTyConName
+         Gen1 -> tcLookupTyCon rep1TyConName
+
+     ; fam_envs <- tcGetFamInstEnvs
+
+     ; let -- If the derived instance is
+           --   instance Generic (Foo x)
+           -- then:
+           --   `arg_ki` = *, `inst_ty` = Foo x :: *
+           --
+           -- If the derived instance is
+           --   instance Generic1 (Bar x :: k -> *)
+           -- then:
+           --   `arg_k` = k, `inst_ty` = Bar x :: k -> *
+           (arg_ki, inst_ty) = case (gk, inst_tys) of
+             (Gen0, [inst_t])        -> (liftedTypeKind, inst_t)
+             (Gen1, [arg_k, inst_t]) -> (arg_k,          inst_t)
+             _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys)
+
+     ; let mbFamInst         = tyConFamInst_maybe tycon
+           -- If we're examining a data family instance, we grab the parent
+           -- TyCon (ptc) and use it to determine the type arguments
+           -- (inst_args) for the data family *instance*'s type variables.
+           ptc               = maybe tycon fst mbFamInst
+           (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd
+                                 $ tcSplitTyConApp inst_ty
+
+     ; let -- `tyvars` = [a,b]
+           (tyvars, gk_) = case gk of
+             Gen0 -> (all_tyvars, Gen0_)
+             Gen1 -> ASSERT(not $ null all_tyvars)
+                     (init all_tyvars, Gen1_ $ last all_tyvars)
+             where all_tyvars = tyConTyVars tycon
+
+       -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
+     ; repTy <- tc_mkRepTy gk_ tycon arg_ki
+
+       -- `rep_name` is a name we generate for the synonym
+     ; mod <- getModule
+     ; loc <- getSrcSpanM
+     ; let tc_occ  = nameOccName (tyConName tycon)
+           rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ
+     ; rep_name <- newGlobalBinder mod rep_occ loc
+
+       -- We make sure to substitute the tyvars with their user-supplied
+       -- type arguments before generating the Rep/Rep1 instance, since some
+       -- of the tyvars might have been instantiated when deriving.
+       -- See Note [Generating a correctly typed Rep instance].
+     ; let (env_tyvars, env_inst_args)
+             = case gk_ of
+                 Gen0_ -> (tyvars, inst_args)
+                 Gen1_ last_tv
+                          -- See the "wrinkle" in
+                          -- Note [Generating a correctly typed Rep instance]
+                       -> ( last_tv : tyvars
+                          , anyTypeOfKind (tyVarKind last_tv) : inst_args )
+           env        = zipTyEnv env_tyvars env_inst_args
+           in_scope   = mkInScopeSet (tyCoVarsOfTypes inst_tys)
+           subst      = mkTvSubst in_scope env
+           repTy'     = substTy  subst repTy
+           tcv'       = tyCoVarsOfTypeList inst_ty
+           (tv', cv') = partition isTyVar tcv'
+           tvs'       = scopedSort tv'
+           cvs'       = scopedSort cv'
+           axiom      = mkSingleCoAxiom Nominal rep_name tvs' [] cvs'
+                                        fam_tc inst_tys repTy'
+
+     ; newFamInst SynFamilyInst axiom  }
+
+--------------------------------------------------------------------------------
+-- Type representation
+--------------------------------------------------------------------------------
+
+-- | See documentation of 'argTyFold'; that function uses the fields of this
+-- type to interpret the structure of a type when that type is considered as an
+-- argument to a constructor that is being represented with 'Rep1'.
+data ArgTyAlg a = ArgTyAlg
+  { ata_rec0 :: (Type -> a)
+  , ata_par1 :: a, ata_rec1 :: (Type -> a)
+  , ata_comp :: (Type -> a -> a)
+  }
+
+-- | @argTyFold@ implements a generalised and safer variant of the @arg@
+-- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@
+-- is conceptually equivalent to:
+--
+-- > arg t = case t of
+-- >   _ | isTyVar t         -> if (t == argVar) then Par1 else Par0 t
+-- >   App f [t'] |
+-- >     representable1 f &&
+-- >     t' == argVar        -> Rec1 f
+-- >   App f [t'] |
+-- >     representable1 f &&
+-- >     t' has tyvars       -> f :.: (arg t')
+-- >   _                     -> Rec0 t
+--
+-- where @argVar@ is the last type variable in the data type declaration we are
+-- finding the representation for.
+--
+-- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to
+-- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and
+-- @:.:@.
+--
+-- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for
+-- some data types. The problematic case is when @t@ is an application of a
+-- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the
+-- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in
+-- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some
+-- representable1 checks have been relaxed, and others were moved to
+-- @canDoGenerics1@.
+argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
+argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
+                            ata_par1 = mkPar1, ata_rec1 = mkRec1,
+                            ata_comp = mkComp}) =
+  -- mkRec0 is the default; use it if there is no interesting structure
+  -- (e.g. occurrences of parameters or recursive occurrences)
+  \t -> maybe (mkRec0 t) id $ go t where
+  go :: Type -> -- type to fold through
+        Maybe a -- the result (e.g. representation type), unless it's trivial
+  go t = isParam `mplus` isApp where
+
+    isParam = do -- handles parameters
+      t' <- getTyVar_maybe t
+      Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter
+             else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0
+
+    isApp = do -- handles applications
+      (phi, beta) <- tcSplitAppTy_maybe t
+
+      let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta
+
+      -- Does it have no interesting structure to represent?
+      if not interesting then Nothing
+        else -- Is the argument the parameter? Special case for mkRec1.
+          if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi
+            else mkComp phi `fmap` go beta -- It must be a composition.
+
+
+tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1
+               GenericKind_
+              -- The type to generate representation for
+            -> TyCon
+              -- The kind of the representation type's argument
+              -- See Note [Handling kinds in a Rep instance]
+            -> Kind
+               -- Generated representation0 type
+            -> TcM Type
+tc_mkRepTy gk_ tycon k =
+  do
+    d1      <- tcLookupTyCon d1TyConName
+    c1      <- tcLookupTyCon c1TyConName
+    s1      <- tcLookupTyCon s1TyConName
+    rec0    <- tcLookupTyCon rec0TyConName
+    rec1    <- tcLookupTyCon rec1TyConName
+    par1    <- tcLookupTyCon par1TyConName
+    u1      <- tcLookupTyCon u1TyConName
+    v1      <- tcLookupTyCon v1TyConName
+    plus    <- tcLookupTyCon sumTyConName
+    times   <- tcLookupTyCon prodTyConName
+    comp    <- tcLookupTyCon compTyConName
+    uAddr   <- tcLookupTyCon uAddrTyConName
+    uChar   <- tcLookupTyCon uCharTyConName
+    uDouble <- tcLookupTyCon uDoubleTyConName
+    uFloat  <- tcLookupTyCon uFloatTyConName
+    uInt    <- tcLookupTyCon uIntTyConName
+    uWord   <- tcLookupTyCon uWordTyConName
+
+    let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon
+
+    md         <- tcLookupPromDataCon metaDataDataConName
+    mc         <- tcLookupPromDataCon metaConsDataConName
+    ms         <- tcLookupPromDataCon metaSelDataConName
+    pPrefix    <- tcLookupPromDataCon prefixIDataConName
+    pInfix     <- tcLookupPromDataCon infixIDataConName
+    pLA        <- tcLookupPromDataCon leftAssociativeDataConName
+    pRA        <- tcLookupPromDataCon rightAssociativeDataConName
+    pNA        <- tcLookupPromDataCon notAssociativeDataConName
+    pSUpk      <- tcLookupPromDataCon sourceUnpackDataConName
+    pSNUpk     <- tcLookupPromDataCon sourceNoUnpackDataConName
+    pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName
+    pSLzy      <- tcLookupPromDataCon sourceLazyDataConName
+    pSStr      <- tcLookupPromDataCon sourceStrictDataConName
+    pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName
+    pDLzy      <- tcLookupPromDataCon decidedLazyDataConName
+    pDStr      <- tcLookupPromDataCon decidedStrictDataConName
+    pDUpk      <- tcLookupPromDataCon decidedUnpackDataConName
+
+    fix_env <- getFixityEnv
+
+    let mkSum' a b = mkTyConApp plus  [k,a,b]
+        mkProd a b = mkTyConApp times [k,a,b]
+        mkRec0 a   = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a
+        mkRec1 a   = mkTyConApp rec1  [k,a]
+        mkPar1     = mkTyConTy  par1
+        mkD    a   = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ]
+        mkC      a = mkTyConApp c1 [ k
+                                   , metaConsTy a
+                                   , prod (dataConInstOrigArgTys a
+                                            . mkTyVarTys . tyConTyVars $ tycon)
+                                          (dataConSrcBangs    a)
+                                          (dataConImplBangs   a)
+                                          (dataConFieldLabels a)]
+        mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a]
+
+        -- Sums and products are done in the same way for both Rep and Rep1
+        sumP [] = mkTyConApp v1 [k]
+        sumP l  = foldBal mkSum' . map mkC  $ l
+        -- The Bool is True if this constructor has labelled fields
+        prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
+        prod [] _  _  _  = mkTyConApp u1 [k]
+        prod l  sb ib fl = foldBal mkProd
+                                   [ ASSERT(null fl || lengthExceeds fl j)
+                                     arg t sb' ib' (if null fl
+                                                       then Nothing
+                                                       else Just (fl !! j))
+                                   | (t,sb',ib',j) <- zip4 l sb ib [0..] ]
+
+        arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
+        arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of
+            -- Here we previously used Par0 if t was a type variable, but we
+            -- realized that we can't always guarantee that we are wrapping-up
+            -- all type variables in Par0. So we decided to stop using Par0
+            -- altogether, and use Rec0 all the time.
+                      Gen0_        -> mkRec0 t
+                      Gen1_ argVar -> argPar argVar t
+          where
+            -- Builds argument representation for Rep1 (more complicated due to
+            -- the presence of composition).
+            argPar argVar = argTyFold argVar $ ArgTyAlg
+              {ata_rec0 = mkRec0, ata_par1 = mkPar1,
+               ata_rec1 = mkRec1, ata_comp = mkComp comp k}
+
+        tyConName_user = case tyConFamInst_maybe tycon of
+                           Just (ptycon, _) -> tyConName ptycon
+                           Nothing          -> tyConName tycon
+
+        dtName  = mkStrLitTy . occNameFS . nameOccName $ tyConName_user
+        mdName  = mkStrLitTy . moduleNameFS . moduleName
+                . nameModule . tyConName $ tycon
+        pkgName = mkStrLitTy . unitIdFS . moduleUnitId
+                . nameModule . tyConName $ tycon
+        isNT    = mkTyConTy $ if isNewTyCon tycon
+                              then promotedTrueDataCon
+                              else promotedFalseDataCon
+
+        ctName = mkStrLitTy . occNameFS . nameOccName . dataConName
+        ctFix c
+            | dataConIsInfix c
+            = case lookupFixity fix_env (dataConName c) of
+                   Fixity _ n InfixL -> buildFix n pLA
+                   Fixity _ n InfixR -> buildFix n pRA
+                   Fixity _ n InfixN -> buildFix n pNA
+            | otherwise = mkTyConTy pPrefix
+        buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc
+                                             , mkNumLitTy (fromIntegral n)]
+
+        isRec c = mkTyConTy $ if dataConFieldLabels c `lengthExceeds` 0
+                              then promotedTrueDataCon
+                              else promotedFalseDataCon
+
+        selName = mkStrLitTy . flLabel
+
+        mbSel Nothing  = mkTyConApp promotedNothingDataCon [typeSymbolKind]
+        mbSel (Just s) = mkTyConApp promotedJustDataCon
+                                    [typeSymbolKind, selName s]
+
+        metaDataTy   = mkTyConApp md [dtName, mdName, pkgName, isNT]
+        metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c]
+        metaSelTy mlbl su ss ib =
+            mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness]
+          where
+            pSUpkness = mkTyConTy $ case su of
+                                         SrcUnpack   -> pSUpk
+                                         SrcNoUnpack -> pSNUpk
+                                         NoSrcUnpack -> pNSUpkness
+
+            pSStrness = mkTyConTy $ case ss of
+                                         SrcLazy     -> pSLzy
+                                         SrcStrict   -> pSStr
+                                         NoSrcStrict -> pNSStrness
+
+            pDStrness = mkTyConTy $ case ib of
+                                         HsLazy      -> pDLzy
+                                         HsStrict    -> pDStr
+                                         HsUnpack{}  -> pDUpk
+
+    return (mkD tycon)
+
+mkComp :: TyCon -> Kind -> Type -> Type -> Type
+mkComp comp k f g
+  | k1_first  = mkTyConApp comp  [k,liftedTypeKind,f,g]
+  | otherwise = mkTyConApp comp  [liftedTypeKind,k,f,g]
+  where
+    -- Which of these is the case?
+    --     newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
+    -- or  newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
+    -- We want to instantiate with k1=k, and k2=*
+    --    Reason for k2=*: see Note [Handling kinds in a Rep instance]
+    -- But we need to know which way round!
+    k1_first = k_first == p_kind_var
+    [k_first,_,_,_,p] = tyConTyVars comp
+    Just p_kind_var = getTyVar_maybe (tyVarKind p)
+
+-- Given the TyCons for each URec-related type synonym, check to see if the
+-- given type is an unlifted type that generics understands. If so, return
+-- its representation type. Otherwise, return Rec0.
+-- See Note [Generics and unlifted types]
+mkBoxTy :: TyCon -- UAddr
+        -> TyCon -- UChar
+        -> TyCon -- UDouble
+        -> TyCon -- UFloat
+        -> TyCon -- UInt
+        -> TyCon -- UWord
+        -> TyCon -- Rec0
+        -> Kind  -- What to instantiate Rec0's kind variable with
+        -> Type
+        -> Type
+mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty
+  | ty `eqType` addrPrimTy   = mkTyConApp uAddr   [k]
+  | ty `eqType` charPrimTy   = mkTyConApp uChar   [k]
+  | ty `eqType` doublePrimTy = mkTyConApp uDouble [k]
+  | ty `eqType` floatPrimTy  = mkTyConApp uFloat  [k]
+  | ty `eqType` intPrimTy    = mkTyConApp uInt    [k]
+  | ty `eqType` wordPrimTy   = mkTyConApp uWord   [k]
+  | otherwise                = mkTyConApp rec0    [k,ty]
+
+--------------------------------------------------------------------------------
+-- Dealing with sums
+--------------------------------------------------------------------------------
+
+mkSum :: GenericKind_ -- Generic or Generic1?
+      -> US          -- Base for generating unique names
+      -> [DataCon]   -- The data constructors
+      -> ([Alt],     -- Alternatives for the T->Trep "from" function
+          [Alt])     -- Alternatives for the Trep->T "to" function
+
+-- Datatype without any constructors
+mkSum _ _ [] = ([from_alt], [to_alt])
+  where
+    from_alt = (x_Pat, nlHsCase x_Expr [])
+    to_alt   = (x_Pat, nlHsCase x_Expr [])
+               -- These M1s are meta-information for the datatype
+
+-- Datatype with at least one constructor
+mkSum gk_ us datacons =
+  -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
+ unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d
+           | (d,i) <- zip datacons [1..] ]
+
+-- Build the sum for a particular constructor
+mk1Sum :: GenericKind_DC -- Generic or Generic1?
+       -> US        -- Base for generating unique names
+       -> Int       -- The index of this constructor
+       -> Int       -- Total number of constructors
+       -> DataCon   -- The data constructor
+       -> (Alt,     -- Alternative for the T->Trep "from" function
+           Alt)     -- Alternative for the Trep->T "to" function
+mk1Sum gk_ us i n datacon = (from_alt, to_alt)
+  where
+    gk = forgetArgVar gk_
+
+    -- Existentials already excluded
+    argTys = dataConOrigArgTys datacon
+    n_args = dataConSourceArity datacon
+
+    datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys
+    datacon_vars = map fst datacon_varTys
+    us'          = us + n_args
+
+    datacon_rdr  = getRdrName datacon
+
+    from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
+    from_alt_rhs = genLR_E i n (mkProd_E gk_ us' datacon_varTys)
+
+    to_alt     = ( genLR_P i n (mkProd_P gk us' datacon_varTys)
+                 , to_alt_rhs
+                 ) -- These M1s are meta-information for the datatype
+    to_alt_rhs = case gk_ of
+      Gen0_DC        -> nlHsVarApps datacon_rdr datacon_vars
+      Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
+        where
+          argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
+            converter = argTyFold argVar $ ArgTyAlg
+              {ata_rec0 = nlHsVar . unboxRepRDR,
+               ata_par1 = nlHsVar unPar1_RDR,
+               ata_rec1 = const $ nlHsVar unRec1_RDR,
+               ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
+                                    `nlHsCompose` nlHsVar unComp1_RDR}
+
+
+-- Generates the L1/R1 sum pattern
+genLR_P :: Int -> Int -> LPat GhcPs -> LPat GhcPs
+genLR_P i n p
+  | n == 0       = error "impossible"
+  | n == 1       = p
+  | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]
+  | otherwise    = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]
+                     where m = div n 2
+
+-- Generates the L1/R1 sum expression
+genLR_E :: Int -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs
+genLR_E i n e
+  | n == 0       = error "impossible"
+  | n == 1       = e
+  | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp`
+                                            nlHsPar (genLR_E i     (div n 2) e)
+  | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp`
+                                            nlHsPar (genLR_E (i-m) (n-m)     e)
+                     where m = div n 2
+
+--------------------------------------------------------------------------------
+-- Dealing with products
+--------------------------------------------------------------------------------
+
+-- Build a product expression
+mkProd_E :: GenericKind_DC    -- Generic or Generic1?
+         -> US                -- Base for unique names
+         -> [(RdrName, Type)]
+                       -- List of variables matched on the lhs and their types
+         -> LHsExpr GhcPs   -- Resulting product expression
+mkProd_E _   _ []     = mkM1_E (nlHsVar u1DataCon_RDR)
+mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
+                     -- These M1s are meta-information for the constructor
+  where
+    appVars = map (wrapArg_E gk_) varTys
+    prod a b = prodDataCon_RDR `nlHsApps` [a,b]
+
+wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs
+wrapArg_E Gen0_DC          (var, ty) = mkM1_E $
+                            boxRepRDR ty `nlHsVarApps` [var]
+                         -- This M1 is meta-information for the selector
+wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $
+                            converter ty `nlHsApp` nlHsVar var
+                         -- This M1 is meta-information for the selector
+  where converter = argTyFold argVar $ ArgTyAlg
+          {ata_rec0 = nlHsVar . boxRepRDR,
+           ata_par1 = nlHsVar par1DataCon_RDR,
+           ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
+           ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
+                                  (nlHsVar fmap_RDR `nlHsApp` cnv)}
+
+boxRepRDR :: Type -> RdrName
+boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs
+
+unboxRepRDR :: Type -> RdrName
+unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs
+
+-- Retrieve the RDRs associated with each URec data family instance
+-- constructor. See Note [Generics and unlifted types]
+unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
+unboxedRepRDRs ty
+  | ty `eqType` addrPrimTy   = Just (uAddrDataCon_RDR,   uAddrHash_RDR)
+  | ty `eqType` charPrimTy   = Just (uCharDataCon_RDR,   uCharHash_RDR)
+  | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR)
+  | ty `eqType` floatPrimTy  = Just (uFloatDataCon_RDR,  uFloatHash_RDR)
+  | ty `eqType` intPrimTy    = Just (uIntDataCon_RDR,    uIntHash_RDR)
+  | ty `eqType` wordPrimTy   = Just (uWordDataCon_RDR,   uWordHash_RDR)
+  | otherwise          = Nothing
+
+-- Build a product pattern
+mkProd_P :: GenericKind       -- Gen0 or Gen1
+         -> US                -- Base for unique names
+         -> [(RdrName, Type)] -- List of variables to match,
+                              --   along with their types
+         -> LPat GhcPs      -- Resulting product pattern
+mkProd_P _  _ []     = mkM1_P (nlNullaryConPat u1DataCon_RDR)
+mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)
+                     -- These M1s are meta-information for the constructor
+  where
+    appVars = unzipWith (wrapArg_P gk) varTys
+    prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b]
+
+wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs
+wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v])
+                   -- This M1 is meta-information for the selector
+wrapArg_P Gen1 v _  = nlParPat $ m1DataCon_RDR `nlConVarPat` [v]
+
+mkGenericLocal :: US -> RdrName
+mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))
+
+x_RDR :: RdrName
+x_RDR = mkVarUnqual (fsLit "x")
+
+x_Expr :: LHsExpr GhcPs
+x_Expr = nlHsVar x_RDR
+
+x_Pat :: LPat GhcPs
+x_Pat = nlVarPat x_RDR
+
+mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs
+mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e
+
+mkM1_P :: LPat GhcPs -> LPat GhcPs
+mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p]
+
+nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
+nlHsCompose x y = compose_RDR `nlHsApps` [x, y]
+
+-- | Variant of foldr1 for producing balanced lists
+foldBal :: (a -> a -> a) -> [a] -> a
+foldBal op = foldBal' op (error "foldBal: empty list")
+
+foldBal' :: (a -> a -> a) -> a -> [a] -> a
+foldBal' _  x []  = x
+foldBal' _  _ [y] = y
+foldBal' op x l   = let (a,b) = splitAt (length l `div` 2) l
+                    in foldBal' op x a `op` foldBal' op x b
+
+{-
+Note [Generics and unlifted types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Normally, all constants are marked with K1/Rec0. The exception to this rule is
+when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In
+that case, we must use a data family instance of URec (from GHC.Generics) to
+mark it. As a result, before we can generate K1 or unK1, we must first check
+to see if the type is actually one of the unlifted types for which URec has a
+data family instance; if so, we generate that instead.
+
+See wiki:Commentary/Compiler/GenericDeriving#Handlingunliftedtypes for more
+details on why URec is implemented the way it is.
+
+Note [Generating a correctly typed Rep instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving
+Generic(1). That is, it derives the ellipsis in the following:
+
+    instance Generic Foo where
+      type Rep Foo = ...
+
+However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which
+a Generic(1) instance is being derived, not the fully instantiated type. As a
+result, tc_mkRepTy builds the most generalized Rep(1) instance possible using
+the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This
+can cause problems when the instance has instantiated type variables
+(see Trac #11732). As an example:
+
+    data T a = MkT a
+    deriving instance Generic (T Int)
+    ==>
+    instance Generic (T Int) where
+      type Rep (T Int) = (... (Rec0 a)) -- wrong!
+
+-XStandaloneDeriving is one way for the type variables to become instantiated.
+Another way is when Generic1 is being derived for a datatype with a visible
+kind binder, e.g.,
+
+   data P k (a :: k) = MkP k deriving Generic1
+   ==>
+   instance Generic1 (P *) where
+     type Rep1 (P *) = (... (Rec0 k)) -- wrong!
+
+See Note [Unify kinds in deriving] in TcDeriv.
+
+In any such scenario, we must prevent a discrepancy between the LHS and RHS of
+a Rep(1) instance. To do so, we create a type variable substitution that maps
+the tyConTyVars of the TyCon to their counterparts in the fully instantiated
+type. (For example, using T above as example, you'd map a :-> Int.) We then
+apply the substitution to the RHS before generating the instance.
+
+A wrinkle in all of this: when forming the type variable substitution for
+Generic1 instances, we map the last type variable of the tycon to Any. Why?
+It's because of wily data types like this one (#15012):
+
+   data T a = MkT (FakeOut a)
+   type FakeOut a = Int
+
+If we ignore a, then we'll produce the following Rep1 instance:
+
+   instance Generic1 T where
+     type Rep1 T = ... (Rec0 (FakeOut a))
+     ...
+
+Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we
+ensure that `a` is mapped to Any:
+
+   instance Generic1 T where
+     type Rep1 T = ... (Rec0 (FakeOut Any))
+     ...
+
+And now all is good.
+
+Alternatively, we could have avoided this problem by expanding all type
+synonyms on the RHSes of Rep1 instances. But we might blow up the size of
+these types even further by doing this, so we choose not to do so.
+
+Note [Handling kinds in a Rep instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because Generic1 is poly-kinded, the representation types were generalized to
+be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply
+the kind of the instance being derived to all the representation type
+constructors. For instance, if you have
+
+    data Empty (a :: k) = Empty deriving Generic1
+
+Then the generated code is now approximately (with -fprint-explicit-kinds
+syntax):
+
+    instance Generic1 k (Empty k) where
+      type Rep1 k (Empty k) = U1 k
+
+Most representation types have only one kind variable, making them easy to deal
+with. The only non-trivial case is (:.:), which is only used in Generic1
+instances:
+
+    newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) =
+        Comp1 { unComp1 :: f (g p) }
+
+Here, we do something a bit counter-intuitive: we make k1 be the kind of the
+instance being derived, and we always make k2 be *. Why *? It's because
+the code that GHC generates using (:.:) is always of the form x :.: Rec1 y
+for some types x and y. In other words, the second type to which (:.:) is
+applied always has kind k -> *, for some kind k, so k2 cannot possibly be
+anything other than * in a generated Generic1 instance.
+
+Note [Generics compilation speed tricks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Deriving Generic(1) is known to have a large constant factor during
+compilation, which contributes to noticeable compilation slowdowns when
+deriving Generic(1) for large datatypes (see Trac #5642).
+
+To ease the pain, there is a trick one can play when generating definitions for
+to(1) and from(1). If you have a datatype like:
+
+  data Letter = A | B | C | D
+
+then a naïve Generic instance for Letter would be:
+
+  instance Generic Letter where
+    type Rep Letter = D1 ('MetaData ...) ...
+
+    to (M1 (L1 (L1 (M1 U1)))) = A
+    to (M1 (L1 (R1 (M1 U1)))) = B
+    to (M1 (R1 (L1 (M1 U1)))) = C
+    to (M1 (R1 (R1 (M1 U1)))) = D
+
+    from A = M1 (L1 (L1 (M1 U1)))
+    from B = M1 (L1 (R1 (M1 U1)))
+    from C = M1 (R1 (L1 (M1 U1)))
+    from D = M1 (R1 (R1 (M1 U1)))
+
+Notice that in every LHS pattern-match of the 'to' definition, and in every RHS
+expression in the 'from' definition, the topmost constructor is M1. This
+corresponds to the datatype-specific metadata (the D1 in the Rep Letter
+instance). But this is wasteful from a typechecking perspective, since this
+definition requires GHC to typecheck an application of M1 in every single case,
+leading to an O(n) increase in the number of coercions the typechecker has to
+solve, which in turn increases allocations and degrades compilation speed.
+
+Luckily, since the topmost M1 has the exact same type across every case, we can
+factor it out reduce the typechecker's burden:
+
+  instance Generic Letter where
+    type Rep Letter = D1 ('MetaData ...) ...
+
+    to (M1 x) = case x of
+      L1 (L1 (M1 U1)) -> A
+      L1 (R1 (M1 U1)) -> B
+      R1 (L1 (M1 U1)) -> C
+      R1 (R1 (M1 U1)) -> D
+
+    from x = M1 (case x of
+      A -> L1 (L1 (M1 U1))
+      B -> L1 (R1 (M1 U1))
+      C -> R1 (L1 (M1 U1))
+      D -> R1 (R1 (M1 U1)))
+
+A simple change, but one that pays off, since it goes turns an O(n) amount of
+coercions to an O(1) amount.
+-}
diff --git a/compiler/typecheck/TcHoleErrors.hs b/compiler/typecheck/TcHoleErrors.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcHoleErrors.hs
@@ -0,0 +1,1028 @@
+module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits, HoleFit (..)
+                    , HoleFitCandidate (..), tcCheckHoleFit, tcSubsumes
+                    , withoutUnification ) where
+
+import GhcPrelude
+
+import TcRnTypes
+import TcRnMonad
+import TcMType
+import TcEvidence
+import TcType
+import Type
+import DataCon
+import Name
+import RdrName ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts )
+import PrelNames ( gHC_ERR )
+import Id
+import VarSet
+import VarEnv
+import Bag
+import ConLike          ( ConLike(..) )
+import Util
+import TcEnv (tcLookup)
+import Outputable
+import DynFlags
+import Maybes
+import FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV )
+
+import Control.Arrow ( (&&&) )
+
+import Control.Monad    ( filterM, replicateM )
+import Data.List        ( partition, sort, sortOn, nubBy )
+import Data.Graph       ( graphFromEdges, topSort )
+import Data.Function    ( on )
+
+
+import TcSimplify    ( simpl_top, runTcSDeriveds )
+import TcUnify       ( tcSubType_NC )
+
+import ExtractDocs ( extractDocs )
+import qualified Data.Map as Map
+import HsDoc           ( HsDocString, unpackHDS, DeclDocMap(..) )
+import HscTypes        ( ModIface(..) )
+import LoadIface       ( loadInterfaceForNameMaybe )
+
+import PrelInfo (knownKeyNames)
+
+
+{-
+Note [Valid hole fits include ...]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+`findValidHoleFits` returns the "Valid hole fits include ..." message.
+For example, look at the following definitions in a file called test.hs:
+
+   import Data.List (inits)
+
+   f :: [String]
+   f = _ "hello, world"
+
+The hole in `f` would generate the message:
+
+  • Found hole: _ :: [Char] -> [String]
+  • In the expression: _
+    In the expression: _ "hello, world"
+    In an equation for ‘f’: f = _ "hello, world"
+  • Relevant bindings include f :: [String] (bound at test.hs:6:1)
+    Valid hole fits include
+      lines :: String -> [String]
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘base-4.11.0.0:Data.OldList’))
+      words :: String -> [String]
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘base-4.11.0.0:Data.OldList’))
+      inits :: forall a. [a] -> [[a]]
+        with inits @Char
+        (imported from ‘Data.List’ at mpt.hs:4:19-23
+          (and originally defined in ‘base-4.11.0.0:Data.OldList’))
+      repeat :: forall a. a -> [a]
+        with repeat @String
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘GHC.List’))
+      fail :: forall (m :: * -> *). Monad m => forall a. String -> m a
+        with fail @[] @String
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘GHC.Base’))
+      return :: forall (m :: * -> *). Monad m => forall a. a -> m a
+        with return @[] @String
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘GHC.Base’))
+      pure :: forall (f :: * -> *). Applicative f => forall a. a -> f a
+        with pure @[] @String
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘GHC.Base’))
+      read :: forall a. Read a => String -> a
+        with read @[String]
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘Text.Read’))
+      mempty :: forall a. Monoid a => a
+        with mempty @([Char] -> [String])
+        (imported from ‘Prelude’ at mpt.hs:3:8-9
+          (and originally defined in ‘GHC.Base’))
+
+Valid hole fits are found by checking top level identifiers and local bindings
+in scope for whether their type can be instantiated to the the type of the hole.
+Additionally, we also need to check whether all relevant constraints are solved
+by choosing an identifier of that type as well, see Note [Relevant Constraints]
+
+Since checking for subsumption results in the side-effect of type variables
+being unified by the simplifier, we need to take care to restore them after
+to being flexible type variables after we've checked for subsumption.
+This is to avoid affecting the hole and later checks by prematurely having
+unified one of the free unification variables.
+
+When outputting, we sort the hole fits by the size of the types we'd need to
+apply by type application to the type of the fit to to make it fit. This is done
+in order to display "more relevant" suggestions first. Another option is to
+sort by building a subsumption graph of fits, i.e. a graph of which fits subsume
+what other fits, and then outputting those fits which are are subsumed by other
+fits (i.e. those more specific than other fits) first. This results in the ones
+"closest" to the type of the hole to be displayed first.
+
+To help users understand how the suggested fit works, we also display the values
+that the quantified type variables would take if that fit is used, like
+`mempty @([Char] -> [String])` and `pure @[] @String` in the example above.
+If -XTypeApplications is enabled, this can even be copied verbatim as a
+replacement for the hole.
+
+
+Note [Nested implications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+For the simplifier to be able to use any givens present in the enclosing
+implications to solve relevant constraints, we nest the wanted subsumption
+constraints and relevant constraints within the enclosing implications.
+
+As an example, let's look at the following code:
+
+  f :: Show a => a -> String
+  f x = show _
+
+The hole will result in the hole constraint:
+
+  [WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_))
+
+Here the nested implications are just one level deep, namely:
+
+  [Implic {
+      TcLevel = 2
+      Skolems = a_a1pa[sk:2]
+      No-eqs = True
+      Status = Unsolved
+      Given = $dShow_a1pc :: Show a_a1pa[sk:2]
+      Wanted =
+        WC {wc_simple =
+              [WD] __a1ph {0}:: a_a1pd[tau:2] (CHoleCan: ExprHole(_))
+              [WD] $dShow_a1pe {0}:: Show a_a1pd[tau:2] (CDictCan(psc))}
+      Binds = EvBindsVar<a1pi>
+      Needed inner = []
+      Needed outer = []
+      the type signature for:
+        f :: forall a. Show a => a -> String }]
+
+As we can see, the givens say that the information about the skolem
+`a_a1pa[sk:2]` fulfills the Show constraint.
+
+The simples are:
+
+  [[WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_)),
+    [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)]
+
+I.e. the hole `a0_a1pd[tau:2]` and the constraint that the type of the hole must
+fulfill `Show a0_a1pd[tau:2])`.
+
+So when we run the check, we need to make sure that the
+
+  [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)
+
+Constraint gets solved. When we now check for whether `x :: a0_a1pd[tau:2]` fits
+the hole in `tcCheckHoleFit`, the call to `tcSubType` will end up writing the
+meta type variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted
+constraints needed by tcSubType_NC and the relevant constraints (see
+Note [Relevant Constraints] for more details) in the nested implications, we
+can pass the information in the givens along to the simplifier. For our example,
+we end up needing to check whether the following constraints are soluble.
+
+  WC {wc_impl =
+        Implic {
+          TcLevel = 2
+          Skolems = a_a1pa[sk:2]
+          No-eqs = True
+          Status = Unsolved
+          Given = $dShow_a1pc :: Show a_a1pa[sk:2]
+          Wanted =
+            WC {wc_simple =
+                  [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)}
+          Binds = EvBindsVar<a1pl>
+          Needed inner = []
+          Needed outer = []
+          the type signature for:
+            f :: forall a. Show a => a -> String }}
+
+But since `a0_a1pd[tau:2] := a_a1pa[sk:2]` and we have from the nested
+implications that Show a_a1pa[sk:2] is a given, this is trivial, and we end up
+with a final WC of WC {}, confirming x :: a0_a1pd[tau:2] as a match.
+
+To avoid side-effects on the nested implications, we create a new EvBindsVar so
+that any changes to the ev binds during a check remains localised to that check.
+
+
+Note [Valid refinement hole fits include ...]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the `-frefinement-level-hole-fits=N` flag is given, we additionally look
+for "valid refinement hole fits"", i.e. valid hole fits with up to N
+additional holes in them.
+
+With `-frefinement-level-hole-fits=0` (the default), GHC will find all
+identifiers 'f' (top-level or nested) that will fit in the hole.
+
+With `-frefinement-level-hole-fits=1`, GHC will additionally find all
+applications 'f _' that will fit in the hole, where 'f' is an in-scope
+identifier, applied to single argument.  It will also report the type of the
+needed argument (a new hole).
+
+And similarly as the number of arguments increases
+
+As an example, let's look at the following code:
+
+  f :: [Integer] -> Integer
+  f = _
+
+with `-frefinement-level-hole-fits=1`, we'd get:
+
+  Valid refinement hole fits include
+
+    foldl1 (_ :: Integer -> Integer -> Integer)
+      with foldl1 @[] @Integer
+      where foldl1 :: forall (t :: * -> *).
+                      Foldable t =>
+                      forall a. (a -> a -> a) -> t a -> a
+    foldr1 (_ :: Integer -> Integer -> Integer)
+      with foldr1 @[] @Integer
+      where foldr1 :: forall (t :: * -> *).
+                      Foldable t =>
+                      forall a. (a -> a -> a) -> t a -> a
+    const (_ :: Integer)
+      with const @Integer @[Integer]
+      where const :: forall a b. a -> b -> a
+    ($) (_ :: [Integer] -> Integer)
+      with ($) @'GHC.Types.LiftedRep @[Integer] @Integer
+      where ($) :: forall a b. (a -> b) -> a -> b
+    fail (_ :: String)
+      with fail @((->) [Integer]) @Integer
+      where fail :: forall (m :: * -> *).
+                    Monad m =>
+                    forall a. String -> m a
+    return (_ :: Integer)
+      with return @((->) [Integer]) @Integer
+      where return :: forall (m :: * -> *). Monad m => forall a. a -> m a
+    (Some refinement hole fits suppressed;
+      use -fmax-refinement-hole-fits=N or -fno-max-refinement-hole-fits)
+
+Which are hole fits with holes in them. This allows e.g. beginners to
+discover the fold functions and similar, but also allows for advanced users
+to figure out the valid functions in the Free monad, e.g.
+
+  instance Functor f => Monad (Free f) where
+      Pure a >>= f = f a
+      Free f >>= g = Free (fmap _a f)
+
+Will output (with -frefinment-level-hole-fits=1):
+    Found hole: _a :: Free f a -> Free f b
+          Where: ‘a’, ‘b’ are rigid type variables bound by
+                  the type signature for:
+                    (>>=) :: forall a b. Free f a -> (a -> Free f b) -> Free f b
+                  at fms.hs:25:12-14
+                ‘f’ is a rigid type variable bound by
+    ...
+    Relevant bindings include
+      g :: a -> Free f b (bound at fms.hs:27:16)
+      f :: f (Free f a) (bound at fms.hs:27:10)
+      (>>=) :: Free f a -> (a -> Free f b) -> Free f b
+        (bound at fms.hs:25:12)
+    ...
+    Valid refinement hole fits include
+      ...
+      (=<<) (_ :: a -> Free f b)
+        with (=<<) @(Free f) @a @b
+        where (=<<) :: forall (m :: * -> *) a b.
+                      Monad m =>
+                      (a -> m b) -> m a -> m b
+        (imported from ‘Prelude’ at fms.hs:5:18-22
+        (and originally defined in ‘GHC.Base’))
+      ...
+
+Where `(=<<) _` is precisely the function we want (we ultimately want `>>= g`).
+
+We find these refinement suggestions by considering hole fits that don't
+fit the type of the hole, but ones that would fit if given an additional
+argument. We do this by creating a new type variable with `newOpenFlexiTyVar`
+(e.g. `t_a1/m[tau:1]`), and then considering hole fits of the type
+`t_a1/m[tau:1] -> v` where `v` is the type of the hole.
+
+Since the simplifier is free to unify this new type variable with any type, we
+can discover any identifiers that would fit if given another identifier of a
+suitable type. This is then generalized so that we can consider any number of
+additional arguments by setting the `-frefinement-level-hole-fits` flag to any
+number, and then considering hole fits like e.g. `foldl _ _` with two additional
+arguments.
+
+To make sure that the refinement hole fits are useful, we check that the types
+of the additional holes have a concrete value and not just an invented type
+variable. This eliminates suggestions such as `head (_ :: [t0 -> a]) (_ :: t0)`,
+and limits the number of less than useful refinement hole fits.
+
+Additionally, to further aid the user in their implementation, we show the
+types of the holes the binding would have to be applied to in order to work.
+In the free monad example above, this is demonstrated with
+`(=<<) (_ :: a -> Free f b)`, which tells the user that the `(=<<)` needs to
+be applied to an expression of type `a -> Free f b` in order to match.
+If -XScopedTypeVariables is enabled, this hole fit can even be copied verbatim.
+
+
+Note [Relevant Constraints]
+~~~~~~~~~~~~~~~~~~~
+
+As highlighted by Trac #14273, we need to check any relevant constraints as well
+as checking for subsumption. Relevant constraints are the simple constraints
+whose free unification variables are mentioned in the type of the hole.
+
+In the simplest case, these are all non-hole constraints in the simples, such
+as is the case in
+
+  f :: String
+  f = show _
+
+Where the simples will be :
+
+  [[WD] __a1kz {0}:: a0_a1kv[tau:1] (CHoleCan: ExprHole(_)),
+    [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)]
+
+However, when there are multiple holes, we need to be more careful. As an
+example, Let's take a look at the following code:
+
+  f :: Show a => a -> String
+  f x = show (_b (show _a))
+
+Here there are two holes, `_a` and `_b`, and the simple constraints passed to
+findValidHoleFits are:
+
+  [[WD] _a_a1pi {0}:: String
+                        -> a0_a1pd[tau:2] (CHoleCan: ExprHole(_b)),
+    [WD] _b_a1ps {0}:: a1_a1po[tau:2] (CHoleCan: ExprHole(_a)),
+    [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical),
+    [WD] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)]
+
+
+Here we have the two hole constraints for `_a` and `_b`, but also additional
+constraints that these holes must fulfill. When we are looking for a match for
+the hole `_a`, we filter the simple constraints to the "Relevant constraints",
+by throwing out all hole constraints and any constraints which do not mention
+a variable mentioned in the type of the hole. For hole `_a`, we will then
+only require that the `$dShow_a1pp` constraint is solved, since that is
+the only non-hole constraint that mentions any free type variables mentioned in
+the hole constraint for `_a`, namely `a_a1pd[tau:2]` , and similarly for the
+hole `_b` we only require that the `$dShow_a1pe` constraint is solved.
+
+Note [Leaking errors]
+~~~~~~~~~~~~~~~~~~~
+
+When considering candidates, GHC believes that we're checking for validity in
+actual source. However, As evidenced by #15321, #15007 and #15202, this can
+cause bewildering error messages. The solution here is simple: if a candidate
+would cause the type checker to error, it is not a valid hole fit, and thus it
+is discarded.
+
+-}
+
+
+data HoleFitDispConfig = HFDC { showWrap :: Bool
+                              , showWrapVars :: Bool
+                              , showType :: Bool
+                              , showProv :: Bool
+                              , showMatches :: Bool }
+
+debugHoleFitDispConfig :: HoleFitDispConfig
+debugHoleFitDispConfig = HFDC True True True False False
+
+
+-- We read the various -no-show-*-of-hole-fits flags
+-- and set the display config accordingly.
+getHoleFitDispConfig :: TcM HoleFitDispConfig
+getHoleFitDispConfig
+  = do { sWrap <- goptM Opt_ShowTypeAppOfHoleFits
+       ; sWrapVars <- goptM Opt_ShowTypeAppVarsOfHoleFits
+       ; sType <- goptM Opt_ShowTypeOfHoleFits
+       ; sProv <- goptM Opt_ShowProvOfHoleFits
+       ; sMatc <- goptM Opt_ShowMatchesOfHoleFits
+       ; return HFDC{ showWrap = sWrap, showWrapVars = sWrapVars
+                    , showProv = sProv, showType = sType
+                    , showMatches = sMatc } }
+
+-- Which sorting algorithm to use
+data SortingAlg = NoSorting      -- Do not sort the fits at all
+                | BySize         -- Sort them by the size of the match
+                | BySubsumption  -- Sort by full subsumption
+                deriving (Eq, Ord)
+
+getSortingAlg :: TcM SortingAlg
+getSortingAlg =
+    do { shouldSort <- goptM Opt_SortValidHoleFits
+       ; subsumSort <- goptM Opt_SortBySubsumHoleFits
+       ; sizeSort <- goptM Opt_SortBySizeHoleFits
+       -- We default to sizeSort unless it has been explicitly turned off
+       -- or subsumption sorting has been turned on.
+       ; return $ if not shouldSort
+                    then NoSorting
+                    else if subsumSort
+                         then BySubsumption
+                         else if sizeSort
+                              then BySize
+                              else NoSorting }
+
+
+-- | HoleFitCandidates are passed to the filter and checked whether they can be
+-- made to fit.
+data HoleFitCandidate = IdHFCand Id             -- An id, like locals.
+                      | NameHFCand Name         -- A name, like built-in syntax.
+                      | GreHFCand GlobalRdrElt  -- A global, like imported ids.
+                      deriving (Eq)
+instance Outputable HoleFitCandidate where
+  ppr = pprHoleFitCand
+
+pprHoleFitCand :: HoleFitCandidate -> SDoc
+pprHoleFitCand (IdHFCand id) = text "Id HFC: " <> ppr id
+pprHoleFitCand (NameHFCand name) = text "Name HFC: " <> ppr name
+pprHoleFitCand (GreHFCand gre) = text "Gre HFC: " <> ppr gre
+
+instance HasOccName HoleFitCandidate where
+  occName hfc = case hfc of
+                  IdHFCand id -> occName id
+                  NameHFCand name -> occName name
+                  GreHFCand gre -> occName (gre_name gre)
+
+-- | HoleFit is the type we use for valid hole fits. It contains the
+-- element that was checked, the Id of that element as found by `tcLookup`,
+-- and the refinement level of the fit, which is the number of extra argument
+-- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`).
+data HoleFit =
+  HoleFit { hfId   :: Id       -- The elements id in the TcM
+          , hfCand :: HoleFitCandidate  -- The candidate that was checked.
+          , hfType :: TcType -- The type of the id, possibly zonked.
+          , hfRefLvl :: Int  -- The number of holes in this fit.
+          , hfWrap :: [TcType] -- The wrapper for the match.
+          , hfMatches :: [TcType]  -- What the refinement variables got matched
+                                   -- with, if anything
+          , hfDoc :: Maybe HsDocString } -- Documentation of this HoleFit, if
+                                         -- available.
+
+
+hfName :: HoleFit -> Name
+hfName hf = case hfCand hf of
+              IdHFCand id -> idName id
+              NameHFCand name -> name
+              GreHFCand gre -> gre_name gre
+
+hfIsLcl :: HoleFit -> Bool
+hfIsLcl hf = case hfCand hf of
+               IdHFCand _    -> True
+               NameHFCand _  -> False
+               GreHFCand gre -> gre_lcl gre
+
+-- We define an Eq and Ord instance to be able to build a graph.
+instance Eq HoleFit where
+   (==) = (==) `on` hfId
+
+-- We compare HoleFits by their name instead of their Id, since we don't
+-- want our tests to be affected by the non-determinism of `nonDetCmpVar`,
+-- which is used to compare Ids. When comparing, we want HoleFits with a lower
+-- refinement level to come first.
+instance Ord HoleFit where
+  compare a b = cmp a b
+    where cmp  = if hfRefLvl a == hfRefLvl b
+                 then compare `on` hfName
+                 else compare `on` hfRefLvl
+
+instance Outputable HoleFit where
+    ppr = pprHoleFit debugHoleFitDispConfig
+
+-- If enabled, we go through the fits and add any associated documentation,
+-- by looking it up in the module or the environment (for local fits)
+addDocs :: [HoleFit] -> TcM [HoleFit]
+addDocs fits =
+  do { showDocs <- goptM Opt_ShowDocsOfHoleFits
+     ; if showDocs
+       then do { (_, DeclDocMap lclDocs, _) <- extractDocs <$> getGblEnv
+               ; mapM (upd lclDocs) fits }
+       else return fits }
+  where
+   msg = text "TcHoleErrors addDocs"
+   lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap })
+     = Map.lookup name dmap
+   upd lclDocs fit =
+     let name = hfName fit in
+     do { doc <- if hfIsLcl fit
+                 then pure (Map.lookup name lclDocs)
+                 else do { mbIface <- loadInterfaceForNameMaybe msg name
+                         ; return $ mbIface >>= lookupInIface name }
+        ; return $ fit {hfDoc = doc} }
+
+-- For pretty printing hole fits, we display the name and type of the fit,
+-- with added '_' to represent any extra arguments in case of a non-zero
+-- refinement level.
+pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc
+pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) hf = hang display 2 provenance
+    where name = hfName hf
+          ty = hfType hf
+          matches =  hfMatches hf
+          wrap = hfWrap hf
+          tyApp = sep $ map ((text "@" <>) . pprParendType) wrap
+          tyAppVars = sep $ punctuate comma $
+              map (\(v,t) -> ppr v <+> text "~" <+> pprParendType t) $
+                zip vars wrap
+            where
+              vars = unwrapTypeVars ty
+              -- Attempts to get all the quantified type variables in a type,
+              -- e.g.
+              -- return :: forall (m :: * -> *) Monad m => (forall a . a) -> m a
+              -- into [m, a]
+              unwrapTypeVars :: Type -> [TyVar]
+              unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of
+                                  Just (_, unfunned) -> unwrapTypeVars unfunned
+                                  _ -> []
+                where (vars, unforalled) = splitForAllTys t
+          holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) matches
+          holeDisp = if sMs then holeVs
+                     else sep $ replicate (length matches) $ text "_"
+          occDisp = pprPrefixOcc name
+          tyDisp = ppWhen sTy $ dcolon <+> ppr ty
+          has = not . null
+          wrapDisp = ppWhen (has wrap && (sWrp || sWrpVars))
+                      $ text "with" <+> if sWrp || not sTy
+                                        then occDisp <+> tyApp
+                                        else tyAppVars
+          docs = case hfDoc hf of
+                   Just d -> text "{-^" <>
+                             (vcat . map text . lines . unpackHDS) d
+                             <> text "-}"
+                   _ -> empty
+          funcInfo = ppWhen (has matches && sTy) $
+                       text "where" <+> occDisp <+> tyDisp
+          subDisp = occDisp <+> if has matches then holeDisp else tyDisp
+          display =  subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp)
+          provenance = ppWhen sProv $ parens $
+                case hfCand hf of
+                    GreHFCand gre -> pprNameProvenance gre
+                    _ -> text "bound at" <+> ppr (getSrcLoc name)
+
+getLocalBindings :: TidyEnv -> Ct -> TcM [Id]
+getLocalBindings tidy_orig ct
+ = do { (env1, _) <- zonkTidyOrigin tidy_orig (ctLocOrigin loc)
+      ; go env1 [] (removeBindingShadowing $ tcl_bndrs lcl_env) }
+  where
+    loc     = ctEvLoc (ctEvidence ct)
+    lcl_env = ctLocEnv loc
+
+    go :: TidyEnv -> [Id] -> [TcBinder] -> TcM [Id]
+    go _ sofar [] = return (reverse sofar)
+    go env sofar (tc_bndr : tc_bndrs) =
+        case tc_bndr of
+          TcIdBndr id _ -> keep_it id
+          _ -> discard_it
+     where
+        discard_it = go env sofar tc_bndrs
+        keep_it id = go env (id:sofar) tc_bndrs
+
+
+
+-- See Note [Valid hole fits include ...]
+findValidHoleFits :: TidyEnv        -- ^ The tidy_env for zonking
+                  -> [Implication]  -- ^ Enclosing implications for givens
+                  -> [Ct]
+                  -- ^ The  unsolved simple constraints in the implication for
+                  -- the hole.
+                  -> Ct -- ^ The hole constraint itself
+                  -> TcM (TidyEnv, SDoc)
+findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =
+  do { rdr_env <- getGlobalRdrEnv
+     ; lclBinds <- getLocalBindings tidy_env ct
+     ; maxVSubs <- maxValidHoleFits <$> getDynFlags
+     ; hfdc <- getHoleFitDispConfig
+     ; sortingAlg <- getSortingAlg
+     ; let findVLimit = if sortingAlg > NoSorting then Nothing else maxVSubs
+     ; refLevel <- refLevelHoleFits <$> getDynFlags
+     ; traceTc "findingValidHoleFitsFor { " $ ppr ct
+     ; traceTc "hole_lvl is:" $ ppr hole_lvl
+     ; traceTc "implics are: " $ ppr implics
+     ; traceTc "simples are: " $ ppr simples
+     ; traceTc "locals are: " $ ppr lclBinds
+     ; let (lcl, gbl) = partition gre_lcl (globalRdrEnvElts rdr_env)
+           -- We remove binding shadowings here, but only for the local level.
+           -- this is so we e.g. suggest the global fmap from the Functor class
+           -- even though there is a local definition as well, such as in the
+           -- Free monad example.
+           locals = removeBindingShadowing $
+                      map IdHFCand lclBinds ++ map GreHFCand lcl
+           globals = map GreHFCand gbl
+           syntax = map NameHFCand builtIns
+           to_check = locals ++ syntax ++ globals
+     ; (searchDiscards, subs) <-
+        tcFilterHoleFits findVLimit implics relevantCts (hole_ty, []) to_check
+     ; (tidy_env, tidy_subs) <- zonkSubs tidy_env subs
+     ; tidy_sorted_subs <- sortFits sortingAlg tidy_subs
+     ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs tidy_sorted_subs
+           vDiscards = pVDisc || searchDiscards
+     ; subs_with_docs <- addDocs limited_subs
+     ; let vMsg = ppUnless (null subs_with_docs) $
+                    hang (text "Valid hole fits include") 2 $
+                      vcat (map (pprHoleFit hfdc) subs_with_docs)
+                        $$ ppWhen vDiscards subsDiscardMsg
+     -- Refinement hole fits. See Note [Valid refinement hole fits include ...]
+     ; (tidy_env, refMsg) <- if refLevel >= Just 0 then
+         do { maxRSubs <- maxRefHoleFits <$> getDynFlags
+            -- We can use from just, since we know that Nothing >= _ is False.
+            ; let refLvls = [1..(fromJust refLevel)]
+            -- We make a new refinement type for each level of refinement, where
+            -- the level of refinement indicates number of additional arguments
+            -- to allow.
+            ; ref_tys <- mapM mkRefTy refLvls
+            ; traceTc "ref_tys are" $ ppr ref_tys
+            ; let findRLimit = if sortingAlg > NoSorting then Nothing
+                                                         else maxRSubs
+            ; refDs <- mapM (flip (tcFilterHoleFits findRLimit implics
+                                     relevantCts) to_check) ref_tys
+            ; (tidy_env, tidy_rsubs) <- zonkSubs tidy_env $ concatMap snd refDs
+            ; tidy_sorted_rsubs <- sortFits sortingAlg tidy_rsubs
+            -- For refinement substitutions we want matches
+            -- like id (_ :: t), head (_ :: [t]), asTypeOf (_ :: t),
+            -- and others in that vein to appear last, since these are
+            -- unlikely to be the most relevant fits.
+            ; (tidy_env, tidy_hole_ty) <- zonkTidyTcType tidy_env hole_ty
+            ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap
+                  (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs
+                  (pRDisc, exact_last_rfits) =
+                    possiblyDiscard maxRSubs $ not_exact ++ exact
+                  rDiscards = pRDisc || any fst refDs
+            ; rsubs_with_docs <- addDocs exact_last_rfits
+            ; return (tidy_env,
+                ppUnless (null rsubs_with_docs) $
+                  hang (text "Valid refinement hole fits include") 2 $
+                  vcat (map (pprHoleFit hfdc) rsubs_with_docs)
+                    $$ ppWhen rDiscards refSubsDiscardMsg) }
+       else return (tidy_env, empty)
+     ; traceTc "findingValidHoleFitsFor }" empty
+     ; return (tidy_env, vMsg $$ refMsg) }
+  where
+    -- We extract the type, the tcLevel and the types free variables
+    -- from from the constraint.
+    hole_ty :: TcPredType
+    hole_ty = ctPred ct
+    hole_fvs :: FV
+    hole_fvs = tyCoFVsOfType hole_ty
+    hole_lvl = ctLocLevel $ ctEvLoc $ ctEvidence ct
+
+    -- BuiltInSyntax names like (:) and []
+    builtIns :: [Name]
+    builtIns = filter isBuiltInSyntax knownKeyNames
+
+    -- We make a refinement type by adding a new type variable in front
+    -- of the type of t h hole, going from e.g. [Integer] -> Integer
+    -- to t_a1/m[tau:1] -> [Integer] -> Integer. This allows the simplifier
+    -- to unify the new type variable with any type, allowing us
+    -- to suggest a "refinement hole fit", like `(foldl1 _)` instead
+    -- of only concrete hole fits like `sum`.
+    mkRefTy :: Int -> TcM (TcType, [TcTyVar])
+    mkRefTy refLvl = (wrapWithVars &&& id) <$> newTyVars
+      where newTyVars = replicateM refLvl $ setLvl <$>
+                            (newOpenTypeKind >>= newFlexiTyVar)
+            setLvl = flip setMetaTyVarTcLevel hole_lvl
+            wrapWithVars vars = mkFunTys (map mkTyVarTy vars) hole_ty
+
+    sortFits :: SortingAlg    -- How we should sort the hole fits
+             -> [HoleFit]     -- The subs to sort
+             -> TcM [HoleFit]
+    sortFits NoSorting subs = return subs
+    sortFits BySize subs
+        = (++) <$> sortBySize (sort lclFits)
+               <*> sortBySize (sort gblFits)
+        where (lclFits, gblFits) = span hfIsLcl subs
+
+    -- To sort by subsumption, we invoke the sortByGraph function, which
+    -- builds the subsumption graph for the fits and then sorts them using a
+    -- graph sort.  Since we want locals to come first anyway, we can sort
+    -- them separately. The substitutions are already checked in local then
+    -- global order, so we can get away with using span here.
+    -- We use (<*>) to expose the parallelism, in case it becomes useful later.
+    sortFits BySubsumption subs
+        = (++) <$> sortByGraph (sort lclFits)
+               <*> sortByGraph (sort gblFits)
+        where (lclFits, gblFits) = span hfIsLcl subs
+
+    -- See Note [Relevant Constraints]
+    relevantCts :: [Ct]
+    relevantCts = if isEmptyVarSet (fvVarSet hole_fvs) then []
+                  else filter isRelevant simples
+      where ctFreeVarSet :: Ct -> VarSet
+            ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred
+            hole_fv_set = fvVarSet hole_fvs
+            anyFVMentioned :: Ct -> Bool
+            anyFVMentioned ct = not $ isEmptyVarSet $
+                                  ctFreeVarSet ct `intersectVarSet` hole_fv_set
+            -- We filter out those constraints that have no variables (since
+            -- they won't be solved by finding a type for the type variable
+            -- representing the hole) and also other holes, since we're not
+            -- trying to find hole fits for many holes at once.
+            isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct))
+                            && anyFVMentioned ct
+                            && not (isHoleCt ct)
+
+    -- We zonk the hole fits so that the output aligns with the rest
+    -- of the typed hole error message output.
+    zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])
+    zonkSubs = zonkSubs' []
+      where zonkSubs' zs env [] = return (env, reverse zs)
+            zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf
+                                           ; zonkSubs' (z:zs) env' hfs }
+            zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp}
+              = do { (env, ty') <- zonkTidyTcType env ty
+                   ; (env, m') <- zonkTidyTcTypes env m
+                   ; (env, wrp') <- zonkTidyTcTypes env wrp
+                   ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'}
+                   ; return (env, zFit ) }
+
+    -- Based on the flags, we might possibly discard some or all the
+    -- fits we've found.
+    possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit])
+    possiblyDiscard (Just max) fits = (fits `lengthExceeds` max, take max fits)
+    possiblyDiscard Nothing fits = (False, fits)
+
+    -- Sort by size uses as a measure for relevance the sizes of the
+    -- different types needed to instantiate the fit to the type of the hole.
+    -- This is much quicker than sorting by subsumption, and gives reasonable
+    -- results in most cases.
+    sortBySize :: [HoleFit] -> TcM [HoleFit]
+    sortBySize = return . sortOn sizeOfFit
+      where sizeOfFit :: HoleFit -> TypeSize
+            sizeOfFit = sizeTypes . nubBy tcEqType .  hfWrap
+
+    -- Based on a suggestion by phadej on #ghc, we can sort the found fits
+    -- by constructing a subsumption graph, and then do a topological sort of
+    -- the graph. This makes the most specific types appear first, which are
+    -- probably those most relevant. This takes a lot of work (but results in
+    -- much more useful output), and can be disabled by
+    -- '-fno-sort-valid-hole-fits'.
+    sortByGraph :: [HoleFit] -> TcM [HoleFit]
+    sortByGraph fits = go [] fits
+      where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool
+            tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty)
+              where fvs = tyCoFVsOfTypes [ht,ty]
+            go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit]
+            go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar
+                             ; return $ uncurry (++)
+                                         $ partition hfIsLcl topSorted }
+              where toV (hf, adjs) = (hf, hfId hf, map hfId adjs)
+                    (graph, fromV, _) = graphFromEdges $ map toV sofar
+                    topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph
+            go sofar (hf:hfs) =
+              do { adjs <-
+                     filterM (tcSubsumesWCloning (hfType hf) . hfType) fits
+                 ; go ((hf, adjs):sofar) hfs }
+
+-- We don't (as of yet) handle holes in types, only in expressions.
+findValidHoleFits env _ _ _ = return (env, empty)
+
+
+-- | tcFilterHoleFits filters the candidates by whether, given the implications
+-- and the relevant constraints, they can be made to match the type by
+-- running the type checker. Stops after finding limit matches.
+tcFilterHoleFits :: Maybe Int
+               -- ^ How many we should output, if limited
+               -> [Implication]
+               -- ^ Enclosing implications for givens
+               -> [Ct]
+               -- ^ Any relevant unsolved simple constraints
+               -> (TcType, [TcTyVar])
+               -- ^ The type to check for fits and a list of refinement
+               -- variables (free type variables in the type) for emulating
+               -- additional holes.
+               -> [HoleFitCandidate]
+               -- ^ The candidates to check whether fit.
+               -> TcM (Bool, [HoleFit])
+               -- ^ We return whether or not we stopped due to hitting the limit
+               -- and the fits we found.
+tcFilterHoleFits (Just 0) _ _ _ _ = return (False, []) -- Stop right away on 0
+tcFilterHoleFits limit implics relevantCts ht@(hole_ty, _) candidates =
+  do { traceTc "checkingFitsFor {" $ ppr hole_ty
+     ; (discards, subs) <- go [] emptyVarSet limit ht candidates
+     ; traceTc "checkingFitsFor }" empty
+     ; return (discards, subs) }
+  where
+    hole_fvs :: FV
+    hole_fvs = tyCoFVsOfType hole_ty
+    -- Kickoff the checking of the elements.
+    -- We iterate over the elements, checking each one in turn for whether
+    -- it fits, and adding it to the results if it does.
+    go :: [HoleFit]           -- What we've found so far.
+       -> VarSet              -- Ids we've already checked
+       -> Maybe Int           -- How many we're allowed to find, if limited
+       -> (TcType, [TcTyVar]) -- The type, and its refinement variables.
+       -> [HoleFitCandidate]  -- The elements we've yet to check.
+       -> TcM (Bool, [HoleFit])
+    go subs _ _ _ [] = return (False, reverse subs)
+    go subs _ (Just 0) _ _ = return (True, reverse subs)
+    go subs seen maxleft ty (el:elts) =
+        -- See Note [Leaking errors]
+        tryTcDiscardingErrs discard_it $
+        do { traceTc "lookingUp" $ ppr el
+           ; maybeThing <- lookup el
+           ; case maybeThing of
+               Just id | not_trivial id ->
+                       do { fits <- fitsHole ty (idType id)
+                          ; case fits of
+                              Just (wrp, matches) -> keep_it id wrp matches
+                              _ -> discard_it }
+               _ -> discard_it }
+        where
+          -- We want to filter out undefined and the likes from GHC.Err
+          not_trivial id = nameModule_maybe (idName id) /= Just gHC_ERR
+
+          lookup :: HoleFitCandidate -> TcM (Maybe Id)
+          lookup (IdHFCand id) = return (Just id)
+          lookup hfc = do { thing <- tcLookup name
+                          ; return $ case thing of
+                                       ATcId {tct_id = id} -> Just id
+                                       AGlobal (AnId id)   -> Just id
+                                       AGlobal (AConLike (RealDataCon con)) ->
+                                           Just (dataConWrapId con)
+                                       _ -> Nothing }
+            where name = case hfc of
+                           IdHFCand id -> idName id
+                           GreHFCand gre -> gre_name gre
+                           NameHFCand name -> name
+          discard_it = go subs seen maxleft ty elts
+          keep_it eid wrp ms = go (fit:subs) (extendVarSet seen eid)
+                                 ((\n -> n - 1) <$> maxleft) ty elts
+            where
+              fit = HoleFit { hfId = eid, hfCand = el, hfType = (idType eid)
+                            , hfRefLvl = length (snd ty)
+                            , hfWrap = wrp, hfMatches = ms
+                            , hfDoc = Nothing }
+
+
+
+
+    unfoldWrapper :: HsWrapper -> [Type]
+    unfoldWrapper = reverse . unfWrp'
+      where unfWrp' (WpTyApp ty) = [ty]
+            unfWrp' (WpCompose w1 w2) = unfWrp' w1 ++ unfWrp' w2
+            unfWrp' _ = []
+
+
+    -- The real work happens here, where we invoke the type checker using
+    -- tcCheckHoleFit to see whether the given type fits the hole.
+    fitsHole :: (TcType, [TcTyVar]) -- The type of the hole wrapped with the
+                                    -- refinement variables created to simulate
+                                    -- additional holes (if any), and the list
+                                    -- of those variables (possibly empty).
+                                    -- As an example: If the actual type of the
+                                    -- hole (as specified by the hole
+                                    -- constraint CHoleExpr passed to
+                                    -- findValidHoleFits) is t and we want to
+                                    -- simulate N additional holes, h_ty will
+                                    -- be  r_1 -> ... -> r_N -> t, and
+                                    -- ref_vars will be [r_1, ... , r_N].
+                                    -- In the base case with no additional
+                                    -- holes, h_ty will just be t and ref_vars
+                                    -- will be [].
+             -> TcType -- The type we're checking to whether it can be
+                       -- instantiated to the type h_ty.
+             -> TcM (Maybe ([TcType], [TcType])) -- If it is not a match, we
+                                                 -- return Nothing. Otherwise,
+                                                 -- we Just return the list of
+                                                 -- types that quantified type
+                                                 -- variables in ty would take
+                                                 -- if used in place of h_ty,
+                                                 -- and the list types of any
+                                                 -- additional holes simulated
+                                                 -- with the refinement
+                                                 -- variables in ref_vars.
+    fitsHole (h_ty, ref_vars) ty =
+    -- We wrap this with the withoutUnification to avoid having side-effects
+    -- beyond the check, but we rely on the side-effects when looking for
+    -- refinement hole fits, so we can't wrap the side-effects deeper than this.
+      withoutUnification fvs $
+      do { traceTc "checkingFitOf {" $ ppr ty
+         ; (fits, wrp) <- tcCheckHoleFit (listToBag relevantCts) implics h_ty ty
+         ; traceTc "Did it fit?" $ ppr fits
+         ; traceTc "wrap is: " $ ppr wrp
+         ; traceTc "checkingFitOf }" empty
+         ; z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp)
+         -- We'd like to avoid refinement suggestions like `id _ _` or
+         -- `head _ _`, and only suggest refinements where our all phantom
+         -- variables got unified during the checking. This can be disabled
+         -- with the `-fabstract-refinement-hole-fits` flag.
+         -- Here we do the additional handling when there are refinement
+         -- variables, i.e. zonk them to read their final value to check for
+         -- abstract refinements, and to report what the type of the simulated
+         -- holes must be for this to be a match.
+         ; if fits
+           then if null ref_vars
+                then return (Just (z_wrp_tys, []))
+                else do { let -- To be concrete matches, matches have to
+                              -- be more than just an invented type variable.
+                              fvSet = fvVarSet fvs
+                              notAbstract :: TcType -> Bool
+                              notAbstract t = case getTyVar_maybe t of
+                                                Just tv -> tv `elemVarSet` fvSet
+                                                _ -> True
+                              allConcrete = all notAbstract z_wrp_tys
+                        ; z_vars  <- zonkTcTyVars ref_vars
+                        ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars
+                        ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs
+                        ; allowAbstract <- goptM Opt_AbstractRefHoleFits
+                        ; if allowAbstract || (allFilled && allConcrete )
+                          then return $ Just (z_wrp_tys, z_vars)
+                          else return Nothing }
+           else return Nothing }
+     where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty
+
+
+subsDiscardMsg :: SDoc
+subsDiscardMsg =
+    text "(Some hole fits suppressed;" <+>
+    text "use -fmax-valid-hole-fits=N" <+>
+    text "or -fno-max-valid-hole-fits)"
+
+refSubsDiscardMsg :: SDoc
+refSubsDiscardMsg =
+    text "(Some refinement hole fits suppressed;" <+>
+    text "use -fmax-refinement-hole-fits=N" <+>
+    text "or -fno-max-refinement-hole-fits)"
+
+
+-- | Checks whether a MetaTyVar is flexible or not.
+isFlexiTyVar :: TcTyVar -> TcM Bool
+isFlexiTyVar tv | isMetaTyVar tv = isFlexi <$> readMetaTyVar tv
+isFlexiTyVar _ = return False
+
+-- | Takes a list of free variables and restores any Flexi type variables in
+-- free_vars after the action is run.
+withoutUnification :: FV -> TcM a -> TcM a
+withoutUnification free_vars action =
+  do { flexis <- filterM isFlexiTyVar fuvs
+     ; result <- action
+          -- Reset any mutated free variables
+     ; mapM_ restore flexis
+     ; return result }
+  where restore = flip writeTcRef Flexi . metaTyVarRef
+        fuvs = fvVarList free_vars
+
+-- | Reports whether first type (ty_a) subsumes the second type (ty_b),
+-- discarding any errors. Subsumption here means that the ty_b can fit into the
+-- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a.
+tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool
+tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit emptyBag [] ty_a ty_b
+
+
+-- | A tcSubsumes which takes into account relevant constraints, to fix trac
+-- #14273. This makes sure that when checking whether a type fits the hole,
+-- the type has to be subsumed by type of the hole as well as fulfill all
+-- constraints on the type of the hole.
+-- Note: The simplifier may perform unification, so make sure to restore any
+-- free type variables to avoid side-effects.
+tcCheckHoleFit :: Cts                   -- ^  Any relevant Cts to the hole.
+               -> [Implication]
+               -- ^ The nested implications of the hole with the innermost
+               -- implication first.
+               -> TcSigmaType           -- ^ The type of the hole.
+               -> TcSigmaType           -- ^ The type to check whether fits.
+               -> TcM (Bool, HsWrapper)
+               -- ^ Whether it was a match, and the wrapper from hole_ty to ty.
+tcCheckHoleFit _ _ hole_ty ty | hole_ty `eqType` ty
+    = return (True, idHsWrapper)
+tcCheckHoleFit relevantCts implics hole_ty ty = discardErrs $
+  do { -- We wrap the subtype constraint in the implications to pass along the
+       -- givens, and so we must ensure that any nested implications and skolems
+       -- end up with the correct level. The implications are ordered so that
+       -- the innermost (the one with the highest level) is first, so it
+       -- suffices to get the level of the first one (or the current level, if
+       -- there are no implications involved).
+       innermost_lvl <- case implics of
+                          [] -> getTcLevel
+                          -- imp is the innermost implication
+                          (imp:_) -> return (ic_tclvl imp)
+     ; (wrp, wanted) <- setTcLevel innermost_lvl $ captureConstraints $
+                          tcSubType_NC ExprSigCtxt ty hole_ty
+     ; traceTc "Checking hole fit {" empty
+     ; traceTc "wanteds are: " $ ppr wanted
+     ; if isEmptyWC wanted && isEmptyBag relevantCts
+       then traceTc "}" empty >> return (True, wrp)
+       else do { fresh_binds <- newTcEvBinds
+                -- The relevant constraints may contain HoleDests, so we must
+                -- take care to clone them as well (to avoid #15370).
+               ; cloned_relevants <- mapBagM cloneWanted relevantCts
+                 -- We wrap the WC in the nested implications, see
+                 -- Note [Nested Implications]
+               ; let outermost_first = reverse implics
+                     setWC = setWCAndBinds fresh_binds
+                    -- We add the cloned relevants to the wanteds generated by
+                    -- the call to tcSubType_NC, see Note [Relevant Constraints]
+                    -- There's no need to clone the wanteds, because they are
+                    -- freshly generated by `tcSubtype_NC`.
+                     w_rel_cts = addSimples wanted cloned_relevants
+                     w_givens = foldr setWC w_rel_cts outermost_first
+               ; traceTc "w_givens are: " $ ppr w_givens
+               ; rem <- runTcSDeriveds $ simpl_top w_givens
+               -- We don't want any insoluble or simple constraints left, but
+               -- solved implications are ok (and neccessary for e.g. undefined)
+               ; traceTc "rems was:" $ ppr rem
+               ; traceTc "}" empty
+               ; return (isSolvedWC rem, wrp) } }
+     where
+       setWCAndBinds :: EvBindsVar         -- Fresh ev binds var.
+                     -> Implication        -- The implication to put WC in.
+                     -> WantedConstraints  -- The WC constraints to put implic.
+                     -> WantedConstraints  -- The new constraints.
+       setWCAndBinds binds imp wc
+         = WC { wc_simple = emptyBag
+              , wc_impl = unitBag $ imp { ic_wanted = wc , ic_binds = binds } }
diff --git a/compiler/typecheck/TcHoleErrors.hs-boot b/compiler/typecheck/TcHoleErrors.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcHoleErrors.hs-boot
@@ -0,0 +1,12 @@
+-- This boot file is in place to break the loop where:
+-- + TcSimplify calls 'TcErrors.reportUnsolved',
+-- + which calls 'TcHoleErrors.findValidHoleFits`
+-- + which calls 'TcSimplify.simpl_top'
+module TcHoleErrors where
+
+import TcRnTypes  ( TcM, Ct, Implication )
+import Outputable ( SDoc )
+import VarEnv     ( TidyEnv )
+
+findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct
+                  -> TcM (TidyEnv, SDoc)
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -0,0 +1,1928 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1996-1998
+
+
+TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker
+
+This module is an extension of @HsSyn@ syntax, for use in the type
+checker.
+-}
+
+{-# LANGUAGE CPP, TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcHsSyn (
+        -- * Extracting types from HsSyn
+        hsLitType, hsLPatType, hsPatType,
+
+        -- * Other HsSyn functions
+        mkHsDictLet, mkHsApp,
+        mkHsAppTy, mkHsCaseAlt,
+        shortCutLit, hsOverLitName,
+        conLikeResTy,
+
+        -- * re-exported from TcMonad
+        TcId, TcIdSet,
+
+        -- * Zonking
+        -- | For a description of "zonking", see Note [What is zonking?]
+        -- in TcMType
+        zonkTopDecls, zonkTopExpr, zonkTopLExpr,
+        zonkTopBndrs,
+        ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv,
+        zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX,
+        zonkTyBndrs, zonkTyBndrsX,
+        zonkTcTypeToType,  zonkTcTypeToTypeX,
+        zonkTcTypesToTypes, zonkTcTypesToTypesX,
+        zonkTyVarOcc,
+        zonkCoToCo,
+        zonkEvBinds, zonkTcEvBinds,
+        zonkTcMethInfoToMethInfoX,
+        lookupTyVarOcc
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import Id
+import IdInfo
+import TcRnMonad
+import PrelNames
+import BuildTyCl ( TcMethInfo, MethInfo )
+import TcType
+import TcMType
+import TcEnv   ( tcLookupGlobalOnly )
+import TcEvidence
+import TysPrim
+import TyCon
+import TysWiredIn
+import Type
+import Coercion
+import ConLike
+import DataCon
+import HscTypes
+import Name
+import NameEnv
+import Var
+import VarEnv
+import DynFlags
+import Literal
+import BasicTypes
+import Maybes
+import SrcLoc
+import Bag
+import Outputable
+import Util
+import UniqFM
+import CoreSyn
+
+import {-# SOURCE #-} TcSplice (runTopSplice)
+
+import Control.Monad
+import Data.List  ( partition )
+import Control.Arrow ( second )
+
+{-
+************************************************************************
+*                                                                      *
+       Extracting the type from HsSyn
+*                                                                      *
+************************************************************************
+
+-}
+
+hsLPatType :: OutPat GhcTc -> Type
+hsLPatType lpat = hsPatType (unLoc lpat)
+
+hsPatType :: Pat GhcTc -> Type
+hsPatType (ParPat _ pat)                = hsLPatType pat
+hsPatType (WildPat ty)                  = ty
+hsPatType (VarPat _ lvar)               = idType (unLoc lvar)
+hsPatType (BangPat _ pat)               = hsLPatType pat
+hsPatType (LazyPat _ pat)               = hsLPatType pat
+hsPatType (LitPat _ lit)                = hsLitType lit
+hsPatType (AsPat _ var _)               = idType (unLoc var)
+hsPatType (ViewPat ty _ _)              = ty
+hsPatType (ListPat (ListPatTc ty Nothing) _)      = mkListTy ty
+hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty
+hsPatType (TuplePat tys _ bx)           = mkTupleTy bx tys
+hsPatType (SumPat tys _ _ _ )           = mkSumTy tys
+hsPatType (ConPatOut { pat_con = lcon
+                     , pat_arg_tys = tys })
+                                        = conLikeResTy (unLoc lcon) tys
+hsPatType (SigPat ty _ _)               = ty
+hsPatType (NPat ty _ _ _)               = ty
+hsPatType (NPlusKPat ty _ _ _ _ _)      = ty
+hsPatType (CoPat _ _ _ ty)              = ty
+hsPatType p                             = pprPanic "hsPatType" (ppr p)
+
+hsLitType :: HsLit (GhcPass p) -> TcType
+hsLitType (HsChar _ _)       = charTy
+hsLitType (HsCharPrim _ _)   = charPrimTy
+hsLitType (HsString _ _)     = stringTy
+hsLitType (HsStringPrim _ _) = addrPrimTy
+hsLitType (HsInt _ _)        = intTy
+hsLitType (HsIntPrim _ _)    = intPrimTy
+hsLitType (HsWordPrim _ _)   = wordPrimTy
+hsLitType (HsInt64Prim _ _)  = int64PrimTy
+hsLitType (HsWord64Prim _ _) = word64PrimTy
+hsLitType (HsInteger _ _ ty) = ty
+hsLitType (HsRat _ _ ty)     = ty
+hsLitType (HsFloatPrim _ _)  = floatPrimTy
+hsLitType (HsDoublePrim _ _) = doublePrimTy
+hsLitType (XLit p)           = pprPanic "hsLitType" (ppr p)
+
+-- Overloaded literals. Here mainly because it uses isIntTy etc
+
+shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId)
+shortCutLit dflags (HsIntegral int@(IL src neg i)) ty
+  | isIntTy ty  && inIntRange  dflags i = Just (HsLit noExt (HsInt noExt int))
+  | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i))
+  | isIntegerTy ty = Just (HsLit noExt (HsInteger src i ty))
+  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty
+        -- The 'otherwise' case is important
+        -- Consider (3 :: Float).  Syntactically it looks like an IntLit,
+        -- so we'll call shortCutIntLit, but of course it's a float
+        -- This can make a big difference for programs with a lot of
+        -- literals, compiled without -O
+
+shortCutLit _ (HsFractional f) ty
+  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim noExt f))
+  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExt f))
+  | otherwise     = Nothing
+
+shortCutLit _ (HsIsString src s) ty
+  | isStringTy ty = Just (HsLit noExt (HsString src s))
+  | otherwise     = Nothing
+
+mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc
+mkLit con lit = HsApp noExt (nlHsDataCon con) (nlHsLit lit)
+
+------------------------------
+hsOverLitName :: OverLitVal -> Name
+-- Get the canonical 'fromX' name for a particular OverLitVal
+hsOverLitName (HsIntegral {})   = fromIntegerName
+hsOverLitName (HsFractional {}) = fromRationalName
+hsOverLitName (HsIsString {})   = fromStringName
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}
+*                                                                      *
+************************************************************************
+
+The rest of the zonking is done *after* typechecking.
+The main zonking pass runs over the bindings
+
+ a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc
+ b) convert unbound TcTyVar to Void
+ c) convert each TcId to an Id by zonking its type
+
+The type variables are converted by binding mutable tyvars to immutable ones
+and then zonking as normal.
+
+The Ids are converted by binding them in the normal Tc envt; that
+way we maintain sharing; eg an Id is zonked at its binding site and they
+all occurrences of that Id point to the common zonked copy
+
+It's all pretty boring stuff, because HsSyn is such a large type, and
+the environment manipulation is tiresome.
+-}
+
+-- Confused by zonking? See Note [What is zonking?] in TcMType.
+
+-- | See Note [The ZonkEnv]
+-- Confused by zonking? See Note [What is zonking?] in TcMType.
+data ZonkEnv  -- See Note [The ZonkEnv]
+  = ZonkEnv { ze_flexi  :: ZonkFlexi
+            , ze_tv_env :: TyCoVarEnv TyCoVar
+            , ze_id_env :: IdEnv      Id
+            , ze_meta_tv_env :: TcRef (TyVarEnv Type) }
+{- Note [The ZonkEnv]
+~~~~~~~~~~~~~~~~~~~~~
+* ze_flexi :: ZonkFlexi says what to do with a
+  unification variable that is still un-unified.
+  See Note [Un-unified unification variables]
+
+* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site
+  of a tyvar or covar, we zonk the kind right away and add a mapping
+  to the env. This prevents re-zonking the kind at every
+  occurrence. But this is *just* an optimisation.
+
+* ze_id_env : IdEnv Id promotes sharing among Ids, by making all
+  occurrences of the Id point to a single zonked copy, built at the
+  binding site.
+
+  Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec.
+  In a mutually recusive group
+     rec { f = ...g...; g = ...f... }
+  we want the occurrence of g to point to the one zonked Id for g,
+  and the same for f.
+
+  Because it is knot-tied, we must be careful to consult it lazily.
+  Specifically, zonkIdOcc is not monadic.
+
+* ze_meta_tv_env: see Note [Sharing when zonking to Type]
+
+
+Notes:
+  * We must be careful never to put coercion variables (which are Ids,
+    after all) in the knot-tied ze_id_env, because coercions can
+    appear in types, and we sometimes inspect a zonked type in this
+    module.  [Question: where, precisely?]
+
+  * In zonkTyVarOcc we consult ze_tv_env in a monadic context,
+    a second reason that ze_tv_env can't be monadic.
+
+  * An obvious suggestion would be to have one VarEnv Var to
+    replace both ze_id_env and ze_tv_env, but that doesn't work
+    because of the knot-tying stuff mentioned above.
+
+Note [Un-unified unification variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What should we do if we find a Flexi unification variable?
+There are three possibilities:
+
+* DefaultFlexi: this is the common case, in situations like
+     length @alpha ([] @alpha)
+  It really doesn't matter what type we choose for alpha.  But
+  we must choose a type!  We can't leae mutable unification
+  variables floating around: after typecheck is complete, every
+  type variable occurrence must have a bindign site.
+
+  So we default it to 'Any' of the right kind.
+
+  All this works for both type and kind variables (indeed
+  the two are the same thign).
+
+* SkolemiseFlexi: is a special case for the LHS of RULES.
+  See Note [Zonking the LHS of a RULE]
+
+* RuntimeUnkFlexi: is a special case for the GHCi debugger.
+  It's a way to have a variable that is not a mutuable
+  unification variable, but doesn't have a binding site
+  either.
+-}
+
+data ZonkFlexi   -- See Note [Un-unified unification variables]
+  = DefaultFlexi    -- Default unbound unificaiton variables to Any
+  | SkolemiseFlexi  -- Skolemise unbound unification variables
+                    -- See Note [Zonking the LHS of a RULE]
+  | RuntimeUnkFlexi -- Used in the GHCi debugger
+
+instance Outputable ZonkEnv where
+  ppr (ZonkEnv { ze_id_env =  var_env}) = pprUFM var_env (vcat . map ppr)
+
+-- The EvBinds have to already be zonked, but that's usually the case.
+emptyZonkEnv :: TcM ZonkEnv
+emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi
+
+mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv
+mkEmptyZonkEnv flexi
+  = do { mtv_env_ref <- newTcRef emptyVarEnv
+       ; return (ZonkEnv { ze_flexi = flexi
+                         , ze_tv_env = emptyVarEnv
+                         , ze_id_env = emptyVarEnv
+                         , ze_meta_tv_env = mtv_env_ref }) }
+
+initZonkEnv :: (ZonkEnv -> a -> TcM b) -> a -> TcM b
+initZonkEnv do_it x = do { ze <- mkEmptyZonkEnv DefaultFlexi
+                         ; do_it ze x }
+
+-- | Extend the knot-tied environment.
+extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv
+extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids
+    -- NB: Don't look at the var to decide which env't to put it in. That
+    -- would end up knot-tying all the env'ts.
+  = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] }
+  -- Given coercion variables will actually end up here. That's OK though:
+  -- coercion variables are never looked up in the knot-tied env't, so zonking
+  -- them simply doesn't get optimised. No one gets hurt. An improvement (?)
+  -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the
+  -- recursive groups. But perhaps the time it takes to do the analysis is
+  -- more than the savings.
+
+extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
+extendZonkEnv ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) vars
+  = ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars]
+       , ze_id_env = extendVarEnvList id_env   [(id,id) | id <- ids] }
+  where
+    (tycovars, ids) = partition isTyCoVar vars
+
+extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
+extendIdZonkEnv1 ze@(ZonkEnv { ze_id_env = id_env }) id
+  = ze { ze_id_env = extendVarEnv id_env id id }
+
+extendTyZonkEnv1 :: ZonkEnv -> TyVar -> ZonkEnv
+extendTyZonkEnv1 ze@(ZonkEnv { ze_tv_env = ty_env }) tv
+  = ze { ze_tv_env = extendVarEnv ty_env tv tv }
+
+setZonkType :: ZonkEnv -> ZonkFlexi -> ZonkEnv
+setZonkType ze flexi = ze { ze_flexi = flexi }
+
+zonkEnvIds :: ZonkEnv -> TypeEnv
+zonkEnvIds (ZonkEnv { ze_id_env = id_env})
+  = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]
+  -- It's OK to use nonDetEltsUFM here because we forget the ordering
+  -- immediately by creating a TypeEnv
+
+zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id
+zonkLIdOcc env = onHasSrcSpan (zonkIdOcc env)
+
+zonkIdOcc :: ZonkEnv -> TcId -> Id
+-- Ids defined in this module should be in the envt;
+-- ignore others.  (Actually, data constructors are also
+-- not LocalVars, even when locally defined, but that is fine.)
+-- (Also foreign-imported things aren't currently in the ZonkEnv;
+--  that's ok because they don't need zonking.)
+--
+-- Actually, Template Haskell works in 'chunks' of declarations, and
+-- an earlier chunk won't be in the 'env' that the zonking phase
+-- carries around.  Instead it'll be in the tcg_gbl_env, already fully
+-- zonked.  There's no point in looking it up there (except for error
+-- checking), and it's not conveniently to hand; hence the simple
+-- 'orElse' case in the LocalVar branch.
+--
+-- Even without template splices, in module Main, the checking of
+-- 'main' is done as a separate chunk.
+zonkIdOcc (ZonkEnv { ze_id_env = id_env}) id
+  | isLocalVar id = lookupVarEnv id_env id `orElse`
+                    id
+  | otherwise     = id
+
+zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]
+zonkIdOccs env ids = map (zonkIdOcc env) ids
+
+-- zonkIdBndr is used *after* typechecking to get the Id's type
+-- to its final form.  The TyVarEnv give
+zonkIdBndr :: ZonkEnv -> TcId -> TcM Id
+zonkIdBndr env v
+  = do ty' <- zonkTcTypeToTypeX env (idType v)
+       ensureNotLevPoly ty'
+         (text "In the type of binder" <+> quotes (ppr v))
+
+       return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty'))
+
+zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
+zonkIdBndrs env ids = mapM (zonkIdBndr env) ids
+
+zonkTopBndrs :: [TcId] -> TcM [Id]
+zonkTopBndrs ids = initZonkEnv zonkIdBndrs ids
+
+zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc)
+zonkFieldOcc env (FieldOcc sel lbl)
+  = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel
+zonkFieldOcc _ (XFieldOcc _) = panic "zonkFieldOcc"
+
+zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
+zonkEvBndrsX = mapAccumLM zonkEvBndrX
+
+zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
+-- Works for dictionaries and coercions
+zonkEvBndrX env var
+  = do { var' <- zonkEvBndr env var
+       ; return (extendZonkEnv env [var'], var') }
+
+zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
+-- Works for dictionaries and coercions
+-- Does not extend the ZonkEnv
+zonkEvBndr env var
+  = do { let var_ty = varType var
+       ; ty <-
+           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}
+           zonkTcTypeToTypeX env var_ty
+       ; return (setVarType var ty) }
+
+{-
+zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm
+zonkEvVarOcc env v
+  | isCoVar v
+  = EvCoercion <$> zonkCoVarOcc env v
+  | otherwise
+  = return (EvId $ zonkIdOcc env v)
+-}
+
+zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var)
+zonkCoreBndrX env v
+  | isId v = do { v' <- zonkIdBndr env v
+                ; return (extendIdZonkEnv1 env v', v') }
+  | otherwise = zonkTyBndrX env v
+
+zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])
+zonkCoreBndrsX = mapAccumLM zonkCoreBndrX
+
+zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar])
+zonkTyBndrs = initZonkEnv zonkTyBndrsX
+
+zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])
+zonkTyBndrsX = mapAccumLM zonkTyBndrX
+
+zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)
+-- This guarantees to return a TyVar (not a TcTyVar)
+-- then we add it to the envt, so all occurrences are replaced
+zonkTyBndrX env tv
+  = ASSERT2( isImmutableTyVar tv, ppr tv <+> dcolon <+> ppr (tyVarKind tv) )
+    do { ki <- zonkTcTypeToTypeX env (tyVarKind tv)
+               -- Internal names tidy up better, for iface files.
+       ; let tv' = mkTyVar (tyVarName tv) ki
+       ; return (extendTyZonkEnv1 env tv', tv') }
+
+zonkTyVarBinders ::  [VarBndr TcTyVar vis]
+                 -> TcM (ZonkEnv, [VarBndr TyVar vis])
+zonkTyVarBinders = initZonkEnv zonkTyVarBindersX
+
+zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis]
+                             -> TcM (ZonkEnv, [VarBndr TyVar vis])
+zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX
+
+zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis
+                            -> TcM (ZonkEnv, VarBndr TyVar vis)
+-- Takes a TcTyVar and guarantees to return a TyVar
+zonkTyVarBinderX env (Bndr tv vis)
+  = do { (env', tv') <- zonkTyBndrX env tv
+       ; return (env', Bndr tv' vis) }
+
+zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc)
+zonkTopExpr e = initZonkEnv zonkExpr e
+
+zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)
+zonkTopLExpr e = initZonkEnv zonkLExpr e
+
+zonkTopDecls :: Bag EvBind
+             -> LHsBinds GhcTcId
+             -> [LRuleDecl GhcTcId] -> [LTcSpecPrag]
+             -> [LForeignDecl GhcTcId]
+             -> TcM (TypeEnv,
+                     Bag EvBind,
+                     LHsBinds GhcTc,
+                     [LForeignDecl GhcTc],
+                     [LTcSpecPrag],
+                     [LRuleDecl    GhcTc])
+zonkTopDecls ev_binds binds rules imp_specs fords
+  = do  { (env1, ev_binds') <- initZonkEnv zonkEvBinds ev_binds
+        ; (env2, binds')    <- zonkRecMonoBinds env1 binds
+                        -- Top level is implicitly recursive
+        ; rules' <- zonkRules env2 rules
+        ; specs' <- zonkLTcSpecPrags env2 imp_specs
+        ; fords' <- zonkForeignExports env2 fords
+        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }
+
+---------------------------------------------
+zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId
+               -> TcM (ZonkEnv, HsLocalBinds GhcTc)
+zonkLocalBinds env (EmptyLocalBinds x)
+  = return (env, (EmptyLocalBinds x))
+
+zonkLocalBinds _ (HsValBinds _ (ValBinds {}))
+  = panic "zonkLocalBinds" -- Not in typechecker output
+
+zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs)))
+  = do  { (env1, new_binds) <- go env binds
+        ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }
+  where
+    go env []
+      = return (env, [])
+    go env ((r,b):bs)
+      = do { (env1, b')  <- zonkRecMonoBinds env b
+           ; (env2, bs') <- go env1 bs
+           ; return (env2, (r,b'):bs') }
+
+zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do
+    new_binds <- mapM (wrapLocM zonk_ip_bind) binds
+    let
+        env1 = extendIdZonkEnvRec env
+                 [ n | (dL->L _ (IPBind _ (Right n) _)) <- new_binds]
+    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds
+    return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))
+  where
+    zonk_ip_bind (IPBind x n e)
+        = do n' <- mapIPNameTc (zonkIdBndr env) n
+             e' <- zonkLExpr env e
+             return (IPBind x n' e')
+    zonk_ip_bind (XIPBind _) = panic "zonkLocalBinds : XCIPBind"
+
+zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds _))
+  = panic "zonkLocalBinds" -- Not in typechecker output
+zonkLocalBinds _ (XHsLocalBindsLR _)
+  = panic "zonkLocalBinds" -- Not in typechecker output
+
+---------------------------------------------
+zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)
+zonkRecMonoBinds env binds
+ = fixM (\ ~(_, new_binds) -> do
+        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)
+        ; binds' <- zonkMonoBinds env1 binds
+        ; return (env1, binds') })
+
+---------------------------------------------
+zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc)
+zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds
+
+zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)
+zonk_lbind env = wrapLocM (zonk_bind env)
+
+zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc)
+zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss
+                            , pat_ext = NPatBindTc fvs ty})
+  = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended
+        ; new_grhss <- zonkGRHSs env zonkLExpr grhss
+        ; new_ty    <- zonkTcTypeToTypeX env ty
+        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss
+                       , pat_ext = NPatBindTc fvs new_ty }) }
+
+zonk_bind env (VarBind { var_ext = x
+                       , var_id = var, var_rhs = expr, var_inline = inl })
+  = do { new_var  <- zonkIdBndr env var
+       ; new_expr <- zonkLExpr env expr
+       ; return (VarBind { var_ext = x
+                         , var_id = new_var
+                         , var_rhs = new_expr
+                         , var_inline = inl }) }
+
+zonk_bind env bind@(FunBind { fun_id = (dL->L loc var)
+                            , fun_matches = ms
+                            , fun_co_fn = co_fn })
+  = do { new_var <- zonkIdBndr env var
+       ; (env1, new_co_fn) <- zonkCoFn env co_fn
+       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms
+       ; return (bind { fun_id = cL loc new_var
+                      , fun_matches = new_ms
+                      , fun_co_fn = new_co_fn }) }
+
+zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
+                        , abs_ev_binds = ev_binds
+                        , abs_exports = exports
+                        , abs_binds = val_binds
+                        , abs_sig = has_sig })
+  = ASSERT( all isImmutableTyVar tyvars )
+    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars
+       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
+       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds
+       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
+         do { let env3 = extendIdZonkEnvRec env2 $
+                         collectHsBindsBinders new_val_binds
+            ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds
+            ; new_exports   <- mapM (zonk_export env3) exports
+            ; return (new_val_binds, new_exports) }
+       ; return (AbsBinds { abs_ext = noExt
+                          , abs_tvs = new_tyvars, abs_ev_vars = new_evs
+                          , abs_ev_binds = new_ev_binds
+                          , abs_exports = new_exports, abs_binds = new_val_bind
+                          , abs_sig = has_sig }) }
+  where
+    zonk_val_bind env lbind
+      | has_sig
+      , (dL->L loc bind@(FunBind { fun_id      = (dL->L mloc mono_id)
+                                 , fun_matches = ms
+                                 , fun_co_fn   = co_fn })) <- lbind
+      = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id
+                            -- Specifically /not/ zonkIdBndr; we do not
+                            -- want to complain about a levity-polymorphic binder
+           ; (env', new_co_fn) <- zonkCoFn env co_fn
+           ; new_ms            <- zonkMatchGroup env' zonkLExpr ms
+           ; return $ cL loc $
+             bind { fun_id      = cL mloc new_mono_id
+                  , fun_matches = new_ms
+                  , fun_co_fn   = new_co_fn } }
+      | otherwise
+      = zonk_lbind env lbind   -- The normal case
+
+    zonk_export env (ABE{ abe_ext = x
+                        , abe_wrap = wrap
+                        , abe_poly = poly_id
+                        , abe_mono = mono_id
+                        , abe_prags = prags })
+        = do new_poly_id <- zonkIdBndr env poly_id
+             (_, new_wrap) <- zonkCoFn env wrap
+             new_prags <- zonkSpecPrags env prags
+             return (ABE{ abe_ext = x
+                        , abe_wrap = new_wrap
+                        , abe_poly = new_poly_id
+                        , abe_mono = zonkIdOcc env mono_id
+                        , abe_prags = new_prags })
+    zonk_export _ (XABExport _) = panic "zonk_bind: XABExport"
+
+zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id)
+                                      , psb_args = details
+                                      , psb_def = lpat
+                                      , psb_dir = dir }))
+  = do { id' <- zonkIdBndr env id
+       ; (env1, lpat') <- zonkPat env lpat
+       ; let details' = zonkPatSynDetails env1 details
+       ; (_env2, dir') <- zonkPatSynDir env1 dir
+       ; return $ PatSynBind x $
+                  bind { psb_id = cL loc id'
+                       , psb_args = details'
+                       , psb_def = lpat'
+                       , psb_dir = dir' } }
+
+zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"
+zonk_bind _ (XHsBindsLR _)                 = panic "zonk_bind"
+
+zonkPatSynDetails :: ZonkEnv
+                  -> HsPatSynDetails (Located TcId)
+                  -> HsPatSynDetails (Located Id)
+zonkPatSynDetails env (PrefixCon as)
+  = PrefixCon (map (zonkLIdOcc env) as)
+zonkPatSynDetails env (InfixCon a1 a2)
+  = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2)
+zonkPatSynDetails env (RecCon flds)
+  = RecCon (map (fmap (zonkLIdOcc env)) flds)
+
+zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId
+              -> TcM (ZonkEnv, HsPatSynDir GhcTc)
+zonkPatSynDir env Unidirectional        = return (env, Unidirectional)
+zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
+zonkPatSynDir env (ExplicitBidirectional mg) = do
+    mg' <- zonkMatchGroup env zonkLExpr mg
+    return (env, ExplicitBidirectional mg')
+
+zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
+zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
+zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps
+                                       ; return (SpecPrags ps') }
+
+zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]
+zonkLTcSpecPrags env ps
+  = mapM zonk_prag ps
+  where
+    zonk_prag (dL->L loc (SpecPrag id co_fn inl))
+        = do { (_, co_fn') <- zonkCoFn env co_fn
+             ; return (cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}
+*                                                                      *
+************************************************************************
+-}
+
+zonkMatchGroup :: ZonkEnv
+            -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
+            -> MatchGroup GhcTcId (Located (body GhcTcId))
+            -> TcM (MatchGroup GhcTc (Located (body GhcTc)))
+zonkMatchGroup env zBody (MG { mg_alts = (dL->L l ms)
+                             , mg_ext = MatchGroupTc arg_tys res_ty
+                             , mg_origin = origin })
+  = do  { ms' <- mapM (zonkMatch env zBody) ms
+        ; arg_tys' <- zonkTcTypesToTypesX env arg_tys
+        ; res_ty'  <- zonkTcTypeToTypeX env res_ty
+        ; return (MG { mg_alts = cL l ms'
+                     , mg_ext = MatchGroupTc arg_tys' res_ty'
+                     , mg_origin = origin }) }
+zonkMatchGroup _ _ (XMatchGroup {}) = panic "zonkMatchGroup"
+
+zonkMatch :: ZonkEnv
+          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
+          -> LMatch GhcTcId (Located (body GhcTcId))
+          -> TcM (LMatch GhcTc (Located (body GhcTc)))
+zonkMatch env zBody (dL->L loc match@(Match { m_pats = pats
+                                            , m_grhss = grhss }))
+  = do  { (env1, new_pats) <- zonkPats env pats
+        ; new_grhss <- zonkGRHSs env1 zBody grhss
+        ; return (cL loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
+zonkMatch _ _ (dL->L  _ (XMatch _)) = panic "zonkMatch"
+zonkMatch _ _ _ = panic "zonkMatch: Impossible Match"
+                             -- due to #15884
+
+-------------------------------------------------------------------------
+zonkGRHSs :: ZonkEnv
+          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
+          -> GRHSs GhcTcId (Located (body GhcTcId))
+          -> TcM (GRHSs GhcTc (Located (body GhcTc)))
+
+zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do
+    (new_env, new_binds) <- zonkLocalBinds env binds
+    let
+        zonk_grhs (GRHS xx guarded rhs)
+          = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded
+               new_rhs <- zBody env2 rhs
+               return (GRHS xx new_guarded new_rhs)
+        zonk_grhs (XGRHS _) = panic "zonkGRHSs"
+    new_grhss <- mapM (wrapLocM zonk_grhs) grhss
+    return (GRHSs x new_grhss (cL l new_binds))
+zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}
+*                                                                      *
+************************************************************************
+-}
+
+zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc]
+zonkLExpr  :: ZonkEnv -> LHsExpr GhcTcId   -> TcM (LHsExpr GhcTc)
+zonkExpr   :: ZonkEnv -> HsExpr GhcTcId    -> TcM (HsExpr GhcTc)
+
+zonkLExprs env exprs = mapM (zonkLExpr env) exprs
+zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr
+
+zonkExpr env (HsVar x (dL->L l id))
+  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )
+    return (HsVar x (cL l (zonkIdOcc env id)))
+
+zonkExpr _ e@(HsConLikeOut {}) = return e
+
+zonkExpr _ (HsIPVar x id)
+  = return (HsIPVar x id)
+
+zonkExpr _ e@HsOverLabel{} = return e
+
+zonkExpr env (HsLit x (HsRat e f ty))
+  = do new_ty <- zonkTcTypeToTypeX env ty
+       return (HsLit x (HsRat e f new_ty))
+
+zonkExpr _ (HsLit x lit)
+  = return (HsLit x lit)
+
+zonkExpr env (HsOverLit x lit)
+  = do  { lit' <- zonkOverLit env lit
+        ; return (HsOverLit x lit') }
+
+zonkExpr env (HsLam x matches)
+  = do new_matches <- zonkMatchGroup env zonkLExpr matches
+       return (HsLam x new_matches)
+
+zonkExpr env (HsLamCase x matches)
+  = do new_matches <- zonkMatchGroup env zonkLExpr matches
+       return (HsLamCase x new_matches)
+
+zonkExpr env (HsApp x e1 e2)
+  = do new_e1 <- zonkLExpr env e1
+       new_e2 <- zonkLExpr env e2
+       return (HsApp x new_e1 new_e2)
+
+zonkExpr env (HsAppType x e t)
+  = do new_e <- zonkLExpr env e
+       return (HsAppType x new_e t)
+       -- NB: the type is an HsType; can't zonk that!
+
+zonkExpr _ e@(HsRnBracketOut _ _ _)
+  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
+
+zonkExpr env (HsTcBracketOut x body bs)
+  = do bs' <- mapM zonk_b bs
+       return (HsTcBracketOut x body bs')
+  where
+    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e
+                                      return (PendingTcSplice n e')
+
+zonkExpr env (HsSpliceE _ (HsSplicedT s)) =
+  runTopSplice s >>= zonkExpr env
+
+zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen
+                           return (HsSpliceE x s)
+
+zonkExpr env (OpApp fixity e1 op e2)
+  = do new_e1 <- zonkLExpr env e1
+       new_op <- zonkLExpr env op
+       new_e2 <- zonkLExpr env e2
+       return (OpApp fixity new_e1 new_op new_e2)
+
+zonkExpr env (NegApp x expr op)
+  = do (env', new_op) <- zonkSyntaxExpr env op
+       new_expr <- zonkLExpr env' expr
+       return (NegApp x new_expr new_op)
+
+zonkExpr env (HsPar x e)
+  = do new_e <- zonkLExpr env e
+       return (HsPar x new_e)
+
+zonkExpr env (SectionL x expr op)
+  = do new_expr <- zonkLExpr env expr
+       new_op   <- zonkLExpr env op
+       return (SectionL x new_expr new_op)
+
+zonkExpr env (SectionR x op expr)
+  = do new_op   <- zonkLExpr env op
+       new_expr <- zonkLExpr env expr
+       return (SectionR x new_op new_expr)
+
+zonkExpr env (ExplicitTuple x tup_args boxed)
+  = do { new_tup_args <- mapM zonk_tup_arg tup_args
+       ; return (ExplicitTuple x new_tup_args boxed) }
+  where
+    zonk_tup_arg (dL->L l (Present x e)) = do { e' <- zonkLExpr env e
+                                              ; return (cL l (Present x e')) }
+    zonk_tup_arg (dL->L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t
+                                            ; return (cL l (Missing t')) }
+    zonk_tup_arg (dL->L _ (XTupArg{})) = panic "zonkExpr.XTupArg"
+    zonk_tup_arg _ = panic "zonk_tup_arg: Impossible Match"
+                             -- due to #15884
+
+
+zonkExpr env (ExplicitSum args alt arity expr)
+  = do new_args <- mapM (zonkTcTypeToTypeX env) args
+       new_expr <- zonkLExpr env expr
+       return (ExplicitSum new_args alt arity new_expr)
+
+zonkExpr env (HsCase x expr ms)
+  = do new_expr <- zonkLExpr env expr
+       new_ms <- zonkMatchGroup env zonkLExpr ms
+       return (HsCase x new_expr new_ms)
+
+zonkExpr env (HsIf x Nothing e1 e2 e3)
+  = do new_e1 <- zonkLExpr env e1
+       new_e2 <- zonkLExpr env e2
+       new_e3 <- zonkLExpr env e3
+       return (HsIf x Nothing new_e1 new_e2 new_e3)
+
+zonkExpr env (HsIf x (Just fun) e1 e2 e3)
+  = do (env1, new_fun) <- zonkSyntaxExpr env fun
+       new_e1 <- zonkLExpr env1 e1
+       new_e2 <- zonkLExpr env1 e2
+       new_e3 <- zonkLExpr env1 e3
+       return (HsIf x (Just new_fun) new_e1 new_e2 new_e3)
+
+zonkExpr env (HsMultiIf ty alts)
+  = do { alts' <- mapM (wrapLocM zonk_alt) alts
+       ; ty'   <- zonkTcTypeToTypeX env ty
+       ; return $ HsMultiIf ty' alts' }
+  where zonk_alt (GRHS x guard expr)
+          = do { (env', guard') <- zonkStmts env zonkLExpr guard
+               ; expr'          <- zonkLExpr env' expr
+               ; return $ GRHS x guard' expr' }
+        zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf"
+
+zonkExpr env (HsLet x (dL->L l binds) expr)
+  = do (new_env, new_binds) <- zonkLocalBinds env binds
+       new_expr <- zonkLExpr new_env expr
+       return (HsLet x (cL l new_binds) new_expr)
+
+zonkExpr env (HsDo ty do_or_lc (dL->L l stmts))
+  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts
+       new_ty <- zonkTcTypeToTypeX env ty
+       return (HsDo new_ty do_or_lc (cL l new_stmts))
+
+zonkExpr env (ExplicitList ty wit exprs)
+  = do (env1, new_wit) <- zonkWit env wit
+       new_ty <- zonkTcTypeToTypeX env1 ty
+       new_exprs <- zonkLExprs env1 exprs
+       return (ExplicitList new_ty new_wit new_exprs)
+   where zonkWit env Nothing    = return (env, Nothing)
+         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
+
+zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds })
+  = do  { new_con_expr <- zonkExpr env (rcon_con_expr ext)
+        ; new_rbinds   <- zonkRecFields env rbinds
+        ; return (expr { rcon_ext  = ext { rcon_con_expr = new_con_expr }
+                       , rcon_flds = new_rbinds }) }
+
+zonkExpr env (RecordUpd { rupd_flds = rbinds
+                        , rupd_expr = expr
+                        , rupd_ext = RecordUpdTc
+                            { rupd_cons = cons, rupd_in_tys = in_tys
+                            , rupd_out_tys = out_tys, rupd_wrap = req_wrap }})
+  = do  { new_expr    <- zonkLExpr env expr
+        ; new_in_tys  <- mapM (zonkTcTypeToTypeX env) in_tys
+        ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys
+        ; new_rbinds  <- zonkRecUpdFields env rbinds
+        ; (_, new_recwrap) <- zonkCoFn env req_wrap
+        ; return (RecordUpd { rupd_expr = new_expr, rupd_flds =  new_rbinds
+                            , rupd_ext = RecordUpdTc
+                                { rupd_cons = cons, rupd_in_tys = new_in_tys
+                                , rupd_out_tys = new_out_tys
+                                , rupd_wrap = new_recwrap }}) }
+
+zonkExpr env (ExprWithTySig _ e ty)
+  = do { e' <- zonkLExpr env e
+       ; return (ExprWithTySig noExt e' ty) }
+
+zonkExpr env (ArithSeq expr wit info)
+  = do (env1, new_wit) <- zonkWit env wit
+       new_expr <- zonkExpr env expr
+       new_info <- zonkArithSeq env1 info
+       return (ArithSeq new_expr new_wit new_info)
+   where zonkWit env Nothing    = return (env, Nothing)
+         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
+
+zonkExpr env (HsSCC x src lbl expr)
+  = do new_expr <- zonkLExpr env expr
+       return (HsSCC x src lbl new_expr)
+
+zonkExpr env (HsTickPragma x src info srcInfo expr)
+  = do new_expr <- zonkLExpr env expr
+       return (HsTickPragma x src info srcInfo new_expr)
+
+-- hdaume: core annotations
+zonkExpr env (HsCoreAnn x src lbl expr)
+  = do new_expr <- zonkLExpr env expr
+       return (HsCoreAnn x src lbl new_expr)
+
+-- arrow notation extensions
+zonkExpr env (HsProc x pat body)
+  = do  { (env1, new_pat) <- zonkPat env pat
+        ; new_body <- zonkCmdTop env1 body
+        ; return (HsProc x new_pat new_body) }
+
+-- StaticPointers extension
+zonkExpr env (HsStatic fvs expr)
+  = HsStatic fvs <$> zonkLExpr env expr
+
+zonkExpr env (HsWrap x co_fn expr)
+  = do (env1, new_co_fn) <- zonkCoFn env co_fn
+       new_expr <- zonkExpr env1 expr
+       return (HsWrap x new_co_fn new_expr)
+
+zonkExpr _ e@(HsUnboundVar {}) = return e
+
+zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
+
+-------------------------------------------------------------------------
+{-
+Note [Skolems in zonkSyntaxExpr]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider rebindable syntax with something like
+
+  (>>=) :: (forall x. blah) -> (forall y. blah') -> blah''
+
+The x and y become skolems that are in scope when type-checking the
+arguments to the bind. This means that we must extend the ZonkEnv with
+these skolems when zonking the arguments to the bind. But the skolems
+are different between the two arguments, and so we should theoretically
+carry around different environments to use for the different arguments.
+
+However, this becomes a logistical nightmare, especially in dealing with
+the more exotic Stmt forms. So, we simplify by making the critical
+assumption that the uniques of the skolems are different. (This assumption
+is justified by the use of newUnique in TcMType.instSkolTyCoVarX.)
+Now, we can safely just extend one environment.
+-}
+
+-- See Note [Skolems in zonkSyntaxExpr]
+zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId
+               -> TcM (ZonkEnv, SyntaxExpr GhcTc)
+zonkSyntaxExpr env (SyntaxExpr { syn_expr      = expr
+                               , syn_arg_wraps = arg_wraps
+                               , syn_res_wrap  = res_wrap })
+  = do { (env0, res_wrap')  <- zonkCoFn env res_wrap
+       ; expr'              <- zonkExpr env0 expr
+       ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps
+       ; return (env1, SyntaxExpr { syn_expr      = expr'
+                                  , syn_arg_wraps = arg_wraps'
+                                  , syn_res_wrap  = res_wrap' }) }
+
+-------------------------------------------------------------------------
+
+zonkLCmd  :: ZonkEnv -> LHsCmd GhcTcId   -> TcM (LHsCmd GhcTc)
+zonkCmd   :: ZonkEnv -> HsCmd GhcTcId    -> TcM (HsCmd GhcTc)
+
+zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd
+
+zonkCmd env (HsCmdWrap x w cmd)
+  = do { (env1, w') <- zonkCoFn env w
+       ; cmd' <- zonkCmd env1 cmd
+       ; return (HsCmdWrap x w' cmd') }
+zonkCmd env (HsCmdArrApp ty e1 e2 ho rl)
+  = do new_e1 <- zonkLExpr env e1
+       new_e2 <- zonkLExpr env e2
+       new_ty <- zonkTcTypeToTypeX env ty
+       return (HsCmdArrApp new_ty new_e1 new_e2 ho rl)
+
+zonkCmd env (HsCmdArrForm x op f fixity args)
+  = do new_op <- zonkLExpr env op
+       new_args <- mapM (zonkCmdTop env) args
+       return (HsCmdArrForm x new_op f fixity new_args)
+
+zonkCmd env (HsCmdApp x c e)
+  = do new_c <- zonkLCmd env c
+       new_e <- zonkLExpr env e
+       return (HsCmdApp x new_c new_e)
+
+zonkCmd env (HsCmdLam x matches)
+  = do new_matches <- zonkMatchGroup env zonkLCmd matches
+       return (HsCmdLam x new_matches)
+
+zonkCmd env (HsCmdPar x c)
+  = do new_c <- zonkLCmd env c
+       return (HsCmdPar x new_c)
+
+zonkCmd env (HsCmdCase x expr ms)
+  = do new_expr <- zonkLExpr env expr
+       new_ms <- zonkMatchGroup env zonkLCmd ms
+       return (HsCmdCase x new_expr new_ms)
+
+zonkCmd env (HsCmdIf x eCond ePred cThen cElse)
+  = do { (env1, new_eCond) <- zonkWit env eCond
+       ; new_ePred <- zonkLExpr env1 ePred
+       ; new_cThen <- zonkLCmd env1 cThen
+       ; new_cElse <- zonkLCmd env1 cElse
+       ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) }
+  where
+    zonkWit env Nothing  = return (env, Nothing)
+    zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w
+
+zonkCmd env (HsCmdLet x (dL->L l binds) cmd)
+  = do (new_env, new_binds) <- zonkLocalBinds env binds
+       new_cmd <- zonkLCmd new_env cmd
+       return (HsCmdLet x (cL l new_binds) new_cmd)
+
+zonkCmd env (HsCmdDo ty (dL->L l stmts))
+  = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts
+       new_ty <- zonkTcTypeToTypeX env ty
+       return (HsCmdDo new_ty (cL l new_stmts))
+
+zonkCmd _ (XCmd{}) = panic "zonkCmd"
+
+
+
+zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc)
+zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd
+
+zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> TcM (HsCmdTop GhcTc)
+zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)
+  = do new_cmd <- zonkLCmd env cmd
+       new_stack_tys <- zonkTcTypeToTypeX env stack_tys
+       new_ty <- zonkTcTypeToTypeX env ty
+       new_ids <- mapSndM (zonkExpr env) ids
+
+       MASSERT( isLiftedTypeKind (tcTypeKind new_stack_tys) )
+         -- desugarer assumes that this is not levity polymorphic...
+         -- but indeed it should always be lifted due to the typing
+         -- rules for arrows
+
+       return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)
+zonk_cmd_top _ (XCmdTop {}) = panic "zonk_cmd_top"
+
+-------------------------------------------------------------------------
+zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)
+zonkCoFn env WpHole   = return (env, WpHole)
+zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
+                                    ; (env2, c2') <- zonkCoFn env1 c2
+                                    ; return (env2, WpCompose c1' c2') }
+zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1
+                                     ; (env2, c2') <- zonkCoFn env1 c2
+                                     ; t1'         <- zonkTcTypeToTypeX env2 t1
+                                     ; return (env2, WpFun c1' c2' t1' d) }
+zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co
+                              ; return (env, WpCast co') }
+zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
+                                 ; return (env', WpEvLam ev') }
+zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg
+                                 ; return (env, WpEvApp arg') }
+zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
+                              do { (env', tv') <- zonkTyBndrX env tv
+                                 ; return (env', WpTyLam tv') }
+zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToTypeX env ty
+                                 ; return (env, WpTyApp ty') }
+zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
+                                 ; return (env1, WpLet bs') }
+
+-------------------------------------------------------------------------
+zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc)
+zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e })
+  = do  { ty' <- zonkTcTypeToTypeX env ty
+        ; e' <- zonkExpr env e
+        ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) }
+
+zonkOverLit _ XOverLit{} = panic "zonkOverLit"
+
+-------------------------------------------------------------------------
+zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc)
+
+zonkArithSeq env (From e)
+  = do new_e <- zonkLExpr env e
+       return (From new_e)
+
+zonkArithSeq env (FromThen e1 e2)
+  = do new_e1 <- zonkLExpr env e1
+       new_e2 <- zonkLExpr env e2
+       return (FromThen new_e1 new_e2)
+
+zonkArithSeq env (FromTo e1 e2)
+  = do new_e1 <- zonkLExpr env e1
+       new_e2 <- zonkLExpr env e2
+       return (FromTo new_e1 new_e2)
+
+zonkArithSeq env (FromThenTo e1 e2 e3)
+  = do new_e1 <- zonkLExpr env e1
+       new_e2 <- zonkLExpr env e2
+       new_e3 <- zonkLExpr env e3
+       return (FromThenTo new_e1 new_e2 new_e3)
+
+
+-------------------------------------------------------------------------
+zonkStmts :: ZonkEnv
+          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
+          -> [LStmt GhcTcId (Located (body GhcTcId))]
+          -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))])
+zonkStmts env _ []     = return (env, [])
+zonkStmts env zBody (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env zBody) s
+                                ; (env2, ss') <- zonkStmts env1 zBody ss
+                                ; return (env2, s' : ss') }
+
+zonkStmt :: ZonkEnv
+         -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))
+         -> Stmt GhcTcId (Located (body GhcTcId))
+         -> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc)))
+zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op)
+  = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op
+       ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
+       ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs
+       ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs
+                              , b <- bs]
+             env2 = extendIdZonkEnvRec env1 new_binders
+       ; new_mzip <- zonkExpr env2 mzip_op
+       ; return (env2
+                , ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)}
+  where
+    zonk_branch env1 (ParStmtBlock x stmts bndrs return_op)
+       = do { (env2, new_stmts)  <- zonkStmts env1 zonkLExpr stmts
+            ; (env3, new_return) <- zonkSyntaxExpr env2 return_op
+            ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs)
+                                                                   new_return) }
+    zonk_branch _ (XParStmtBlock{}) = panic "zonkStmt"
+
+zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
+                            , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id
+                            , recS_bind_fn = bind_id
+                            , recS_ext =
+                                       RecStmtTc { recS_bind_ty = bind_ty
+                                                 , recS_later_rets = later_rets
+                                                 , recS_rec_rets = rec_rets
+                                                 , recS_ret_ty = ret_ty} })
+  = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id
+       ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id
+       ; (env3, new_ret_id)  <- zonkSyntaxExpr env2 ret_id
+       ; new_bind_ty <- zonkTcTypeToTypeX env3 bind_ty
+       ; new_rvs <- zonkIdBndrs env3 rvs
+       ; new_lvs <- zonkIdBndrs env3 lvs
+       ; new_ret_ty  <- zonkTcTypeToTypeX env3 ret_ty
+       ; let env4 = extendIdZonkEnvRec env3 new_rvs
+       ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts
+        -- Zonk the ret-expressions in an envt that
+        -- has the polymorphic bindings in the envt
+       ; new_later_rets <- mapM (zonkExpr env5) later_rets
+       ; new_rec_rets <- mapM (zonkExpr env5) rec_rets
+       ; return (extendIdZonkEnvRec env3 new_lvs,     -- Only the lvs are needed
+                 RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
+                         , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
+                         , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
+                         , recS_ext = RecStmtTc
+                             { recS_bind_ty = new_bind_ty
+                             , recS_later_rets = new_later_rets
+                             , recS_rec_rets = new_rec_rets
+                             , recS_ret_ty = new_ret_ty } }) }
+
+zonkStmt env zBody (BodyStmt ty body then_op guard_op)
+  = do (env1, new_then_op)  <- zonkSyntaxExpr env then_op
+       (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op
+       new_body <- zBody env2 body
+       new_ty   <- zonkTcTypeToTypeX env2 ty
+       return (env2, BodyStmt new_ty new_body new_then_op new_guard_op)
+
+zonkStmt env zBody (LastStmt x body noret ret_op)
+  = do (env1, new_ret) <- zonkSyntaxExpr env ret_op
+       new_body <- zBody env1 body
+       return (env, LastStmt x new_body noret new_ret)
+
+zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
+                          , trS_by = by, trS_form = form, trS_using = using
+                          , trS_ret = return_op, trS_bind = bind_op
+                          , trS_ext = bind_arg_ty
+                          , trS_fmap = liftM_op })
+  = do {
+    ; (env1, bind_op') <- zonkSyntaxExpr env bind_op
+    ; bind_arg_ty' <- zonkTcTypeToTypeX env1 bind_arg_ty
+    ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts
+    ; by'        <- fmapMaybeM (zonkLExpr env2) by
+    ; using'     <- zonkLExpr env2 using
+
+    ; (env3, return_op') <- zonkSyntaxExpr env2 return_op
+    ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap
+    ; liftM_op'  <- zonkExpr env3 liftM_op
+    ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap')
+    ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
+                               , trS_by = by', trS_form = form, trS_using = using'
+                               , trS_ret = return_op', trS_bind = bind_op'
+                               , trS_ext = bind_arg_ty'
+                               , trS_fmap = liftM_op' }) }
+  where
+    zonkBinderMapEntry env  (oldBinder, newBinder) = do
+        let oldBinder' = zonkIdOcc env oldBinder
+        newBinder' <- zonkIdBndr env newBinder
+        return (oldBinder', newBinder')
+
+zonkStmt env _ (LetStmt x (dL->L l binds))
+  = do (env1, new_binds) <- zonkLocalBinds env binds
+       return (env1, LetStmt x (cL l new_binds))
+
+zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op)
+  = do  { (env1, new_bind) <- zonkSyntaxExpr env bind_op
+        ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty
+        ; new_body <- zBody env1 body
+        ; (env2, new_pat) <- zonkPat env1 pat
+        ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op
+        ; return ( env2
+                 , BindStmt new_bind_ty new_pat new_body new_bind new_fail) }
+
+-- Scopes: join > ops (in reverse order) > pats (in forward order)
+--              > rest of stmts
+zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)
+  = do  { (env1, new_mb_join)   <- zonk_join env mb_join
+        ; (env2, new_args)      <- zonk_args env1 args
+        ; new_body_ty           <- zonkTcTypeToTypeX env2 body_ty
+        ; return (env2, ApplicativeStmt new_body_ty new_args new_mb_join) }
+  where
+    zonk_join env Nothing  = return (env, Nothing)
+    zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j
+
+    get_pat (_, ApplicativeArgOne _ pat _ _) = pat
+    get_pat (_, ApplicativeArgMany _ _ _ pat) = pat
+    get_pat (_, XApplicativeArg _) = panic "zonkStmt"
+
+    replace_pat pat (op, ApplicativeArgOne x _ a isBody)
+      = (op, ApplicativeArgOne x pat a isBody)
+    replace_pat pat (op, ApplicativeArgMany x a b _)
+      = (op, ApplicativeArgMany x a b pat)
+    replace_pat _ (_, XApplicativeArg _) = panic "zonkStmt"
+
+    zonk_args env args
+      = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)
+           ; (env2, new_pats)     <- zonkPats env1 (map get_pat args)
+           ; return (env2, zipWith replace_pat new_pats (reverse new_args_rev)) }
+
+     -- these need to go backward, because if any operators are higher-rank,
+     -- later operators may introduce skolems that are in scope for earlier
+     -- arguments
+    zonk_args_rev env ((op, arg) : args)
+      = do { (env1, new_op)         <- zonkSyntaxExpr env op
+           ; new_arg                <- zonk_arg env1 arg
+           ; (env2, new_args)       <- zonk_args_rev env1 args
+           ; return (env2, (new_op, new_arg) : new_args) }
+    zonk_args_rev env [] = return (env, [])
+
+    zonk_arg env (ApplicativeArgOne x pat expr isBody)
+      = do { new_expr <- zonkLExpr env expr
+           ; return (ApplicativeArgOne x pat new_expr isBody) }
+    zonk_arg env (ApplicativeArgMany x stmts ret pat)
+      = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
+           ; new_ret           <- zonkExpr env1 ret
+           ; return (ApplicativeArgMany x new_stmts new_ret pat) }
+    zonk_arg _ (XApplicativeArg _) = panic "zonkStmt.XApplicativeArg"
+
+zonkStmt _ _ (XStmtLR _) = panic "zonkStmt"
+
+-------------------------------------------------------------------------
+zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId)
+zonkRecFields env (HsRecFields flds dd)
+  = do  { flds' <- mapM zonk_rbind flds
+        ; return (HsRecFields flds' dd) }
+  where
+    zonk_rbind (dL->L l fld)
+      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld)
+           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
+           ; return (cL l (fld { hsRecFieldLbl = new_id
+                              , hsRecFieldArg = new_expr })) }
+
+zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId]
+                 -> TcM [LHsRecUpdField GhcTcId]
+zonkRecUpdFields env = mapM zonk_rbind
+  where
+    zonk_rbind (dL->L l fld)
+      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)
+           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
+           ; return (cL l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id
+                               , hsRecFieldArg = new_expr })) }
+
+-------------------------------------------------------------------------
+mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a
+            -> TcM (Either (Located HsIPName) b)
+mapIPNameTc _ (Left x)  = return (Left x)
+mapIPNameTc f (Right x) = do r <- f x
+                             return (Right r)
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[BackSubst-Pats]{Patterns}
+*                                                                      *
+************************************************************************
+-}
+
+zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc)
+-- Extend the environment as we go, because it's possible for one
+-- pattern to bind something that is used in another (inside or
+-- to the right)
+zonkPat env pat = wrapLocSndM (zonk_pat env) pat
+
+zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc)
+zonk_pat env (ParPat x p)
+  = do  { (env', p') <- zonkPat env p
+        ; return (env', ParPat x p') }
+
+zonk_pat env (WildPat ty)
+  = do  { ty' <- zonkTcTypeToTypeX env ty
+        ; ensureNotLevPoly ty'
+            (text "In a wildcard pattern")
+        ; return (env, WildPat ty') }
+
+zonk_pat env (VarPat x (dL->L l v))
+  = do  { v' <- zonkIdBndr env v
+        ; return (extendIdZonkEnv1 env v', VarPat x (cL l v')) }
+
+zonk_pat env (LazyPat x pat)
+  = do  { (env', pat') <- zonkPat env pat
+        ; return (env',  LazyPat x pat') }
+
+zonk_pat env (BangPat x pat)
+  = do  { (env', pat') <- zonkPat env pat
+        ; return (env',  BangPat x pat') }
+
+zonk_pat env (AsPat x (dL->L loc v) pat)
+  = do  { v' <- zonkIdBndr env v
+        ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat
+        ; return (env', AsPat x (cL loc v') pat') }
+
+zonk_pat env (ViewPat ty expr pat)
+  = do  { expr' <- zonkLExpr env expr
+        ; (env', pat') <- zonkPat env pat
+        ; ty' <- zonkTcTypeToTypeX env ty
+        ; return (env', ViewPat ty' expr' pat') }
+
+zonk_pat env (ListPat (ListPatTc ty Nothing) pats)
+  = do  { ty' <- zonkTcTypeToTypeX env ty
+        ; (env', pats') <- zonkPats env pats
+        ; return (env', ListPat (ListPatTc ty' Nothing) pats') }
+
+zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats)
+  = do  { (env', wit') <- zonkSyntaxExpr env wit
+        ; ty2' <- zonkTcTypeToTypeX env' ty2
+        ; ty' <- zonkTcTypeToTypeX env' ty
+        ; (env'', pats') <- zonkPats env' pats
+        ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') }
+
+zonk_pat env (TuplePat tys pats boxed)
+  = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys
+        ; (env', pats') <- zonkPats env pats
+        ; return (env', TuplePat tys' pats' boxed) }
+
+zonk_pat env (SumPat tys pat alt arity )
+  = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys
+        ; (env', pat') <- zonkPat env pat
+        ; return (env', SumPat tys' pat' alt arity) }
+
+zonk_pat env p@(ConPatOut { pat_arg_tys = tys
+                          , pat_tvs = tyvars
+                          , pat_dicts = evs
+                          , pat_binds = binds
+                          , pat_args = args
+                          , pat_wrap = wrapper
+                          , pat_con = (dL->L _ con) })
+  = ASSERT( all isImmutableTyVar tyvars )
+    do  { new_tys <- mapM (zonkTcTypeToTypeX env) tys
+
+          -- an unboxed tuple pattern (but only an unboxed tuple pattern)
+          -- might have levity-polymorphic arguments. Check for this badness.
+        ; case con of
+            RealDataCon dc
+              | isUnboxedTupleTyCon (dataConTyCon dc)
+              -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys)
+            _ -> return ()
+
+        ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars
+          -- Must zonk the existential variables, because their
+          -- /kind/ need potential zonking.
+          -- cf typecheck/should_compile/tc221.hs
+        ; (env1, new_evs) <- zonkEvBndrsX env0 evs
+        ; (env2, new_binds) <- zonkTcEvBinds env1 binds
+        ; (env3, new_wrapper) <- zonkCoFn env2 wrapper
+        ; (env', new_args) <- zonkConStuff env3 args
+        ; return (env', p { pat_arg_tys = new_tys,
+                            pat_tvs = new_tyvars,
+                            pat_dicts = new_evs,
+                            pat_binds = new_binds,
+                            pat_args = new_args,
+                            pat_wrap = new_wrapper}) }
+  where
+    doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p
+
+zonk_pat env (LitPat x lit) = return (env, LitPat x lit)
+
+zonk_pat env (SigPat ty pat hs_ty)
+  = do  { ty' <- zonkTcTypeToTypeX env ty
+        ; (env', pat') <- zonkPat env pat
+        ; return (env', SigPat ty' pat' hs_ty) }
+
+zonk_pat env (NPat ty (dL->L l lit) mb_neg eq_expr)
+  = do  { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr
+        ; (env2, mb_neg') <- case mb_neg of
+            Nothing -> return (env1, Nothing)
+            Just n  -> second Just <$> zonkSyntaxExpr env1 n
+
+        ; lit' <- zonkOverLit env2 lit
+        ; ty' <- zonkTcTypeToTypeX env2 ty
+        ; return (env2, NPat ty' (cL l lit') mb_neg' eq_expr') }
+
+zonk_pat env (NPlusKPat ty (dL->L loc n) (dL->L l lit1) lit2 e1 e2)
+  = do  { (env1, e1') <- zonkSyntaxExpr env  e1
+        ; (env2, e2') <- zonkSyntaxExpr env1 e2
+        ; n' <- zonkIdBndr env2 n
+        ; lit1' <- zonkOverLit env2 lit1
+        ; lit2' <- zonkOverLit env2 lit2
+        ; ty' <- zonkTcTypeToTypeX env2 ty
+        ; return (extendIdZonkEnv1 env2 n',
+                  NPlusKPat ty' (cL loc n') (cL l lit1') lit2' e1' e2') }
+
+zonk_pat env (CoPat x co_fn pat ty)
+  = do { (env', co_fn') <- zonkCoFn env co_fn
+       ; (env'', pat') <- zonkPat env' (noLoc pat)
+       ; ty' <- zonkTcTypeToTypeX env'' ty
+       ; return (env'', CoPat x co_fn' (unLoc pat') ty') }
+
+zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)
+
+---------------------------
+zonkConStuff :: ZonkEnv
+             -> HsConDetails (OutPat GhcTcId) (HsRecFields id (OutPat GhcTcId))
+             -> TcM (ZonkEnv,
+                    HsConDetails (OutPat GhcTc) (HsRecFields id (OutPat GhcTc)))
+zonkConStuff env (PrefixCon pats)
+  = do  { (env', pats') <- zonkPats env pats
+        ; return (env', PrefixCon pats') }
+
+zonkConStuff env (InfixCon p1 p2)
+  = do  { (env1, p1') <- zonkPat env  p1
+        ; (env', p2') <- zonkPat env1 p2
+        ; return (env', InfixCon p1' p2') }
+
+zonkConStuff env (RecCon (HsRecFields rpats dd))
+  = do  { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)
+        ; let rpats' = zipWith (\(dL->L l rp) p' ->
+                                  cL l (rp { hsRecFieldArg = p' }))
+                               rpats pats'
+        ; return (env', RecCon (HsRecFields rpats' dd)) }
+        -- Field selectors have declared types; hence no zonking
+
+---------------------------
+zonkPats :: ZonkEnv -> [OutPat GhcTcId] -> TcM (ZonkEnv, [OutPat GhcTc])
+zonkPats env []         = return (env, [])
+zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat
+                             ; (env', pats') <- zonkPats env1 pats
+                             ; return (env', pat':pats') }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection[BackSubst-Foreign]{Foreign exports}
+*                                                                      *
+************************************************************************
+-}
+
+zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTcId]
+                   -> TcM [LForeignDecl GhcTc]
+zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls
+
+zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> TcM (ForeignDecl GhcTc)
+zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co
+                                     , fd_fe = spec })
+  = return (ForeignExport { fd_name = zonkLIdOcc env i
+                          , fd_sig_ty = undefined, fd_e_ext = co
+                          , fd_fe = spec })
+zonkForeignExport _ for_imp
+  = return for_imp     -- Foreign imports don't need zonking
+
+zonkRules :: ZonkEnv -> [LRuleDecl GhcTcId] -> TcM [LRuleDecl GhcTc]
+zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs
+
+zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> TcM (RuleDecl GhcTc)
+zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}
+                          , rd_lhs = lhs
+                          , rd_rhs = rhs })
+  = do { (env_inside, new_tm_bndrs) <- mapAccumLM zonk_tm_bndr env tm_bndrs
+
+       ; let env_lhs = setZonkType env_inside SkolemiseFlexi
+              -- See Note [Zonking the LHS of a RULE]
+
+       ; new_lhs <- zonkLExpr env_lhs    lhs
+       ; new_rhs <- zonkLExpr env_inside rhs
+
+       ; return $ rule { rd_tmvs = new_tm_bndrs
+                       , rd_lhs  = new_lhs
+                       , rd_rhs  = new_rhs } }
+  where
+   zonk_tm_bndr env (dL->L l (RuleBndr x (dL->L loc v)))
+      = do { (env', v') <- zonk_it env v
+           ; return (env', cL l (RuleBndr x (cL loc v'))) }
+   zonk_tm_bndr _ (dL->L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"
+   zonk_tm_bndr _ (dL->L _ (XRuleBndr {})) = panic "zonk_tm_bndr XRuleBndr"
+   zonk_tm_bndr _ _ = panic "zonk_tm_bndr: Impossible Match"
+                            -- due to #15884
+
+   zonk_it env v
+     | isId v     = do { v' <- zonkIdBndr env v
+                       ; return (extendIdZonkEnvRec env [v'], v') }
+     | otherwise  = ASSERT( isImmutableTyVar v)
+                    zonkTyBndrX env v
+                    -- DV: used to be return (env,v) but that is plain
+                    -- wrong because we may need to go inside the kind
+                    -- of v and zonk there!
+zonkRule _ (XRuleDecl _) = panic "zonkRule"
+
+{-
+************************************************************************
+*                                                                      *
+              Constraints and evidence
+*                                                                      *
+************************************************************************
+-}
+
+zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
+zonkEvTerm env (EvExpr e)
+  = EvExpr <$> zonkCoreExpr env e
+zonkEvTerm env (EvTypeable ty ev)
+  = EvTypeable <$> zonkTcTypeToTypeX env ty <*> zonkEvTypeable env ev
+zonkEvTerm env (EvFun { et_tvs = tvs, et_given = evs
+                      , et_binds = ev_binds, et_body = body_id })
+  = do { (env0, new_tvs) <- zonkTyBndrsX env tvs
+       ; (env1, new_evs) <- zonkEvBndrsX env0 evs
+       ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
+       ; let new_body_id = zonkIdOcc env2 body_id
+       ; return (EvFun { et_tvs = new_tvs, et_given = new_evs
+                       , et_binds = new_ev_binds, et_body = new_body_id }) }
+
+zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr
+zonkCoreExpr env (Var v)
+    | isCoVar v
+    = Coercion <$> zonkCoVarOcc env v
+    | otherwise
+    = return (Var $ zonkIdOcc env v)
+zonkCoreExpr _ (Lit l)
+    = return $ Lit l
+zonkCoreExpr env (Coercion co)
+    = Coercion <$> zonkCoToCo env co
+zonkCoreExpr env (Type ty)
+    = Type <$> zonkTcTypeToTypeX env ty
+
+zonkCoreExpr env (Cast e co)
+    = Cast <$> zonkCoreExpr env e <*> zonkCoToCo env co
+zonkCoreExpr env (Tick t e)
+    = Tick t <$> zonkCoreExpr env e -- Do we need to zonk in ticks?
+
+zonkCoreExpr env (App e1 e2)
+    = App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2
+zonkCoreExpr env (Lam v e)
+    = do { (env1, v') <- zonkCoreBndrX env v
+         ; Lam v' <$> zonkCoreExpr env1 e }
+zonkCoreExpr env (Let bind e)
+    = do (env1, bind') <- zonkCoreBind env bind
+         Let bind'<$> zonkCoreExpr env1 e
+zonkCoreExpr env (Case scrut b ty alts)
+    = do scrut' <- zonkCoreExpr env scrut
+         ty' <- zonkTcTypeToTypeX env ty
+         b' <- zonkIdBndr env b
+         let env1 = extendIdZonkEnv1 env b'
+         alts' <- mapM (zonkCoreAlt env1) alts
+         return $ Case scrut' b' ty' alts'
+
+zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt
+zonkCoreAlt env (dc, bndrs, rhs)
+    = do (env1, bndrs') <- zonkCoreBndrsX env bndrs
+         rhs' <- zonkCoreExpr env1 rhs
+         return $ (dc, bndrs', rhs')
+
+zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind)
+zonkCoreBind env (NonRec v e)
+    = do v' <- zonkIdBndr env v
+         e' <- zonkCoreExpr env e
+         let env1 = extendIdZonkEnv1 env v'
+         return (env1, NonRec v' e')
+zonkCoreBind env (Rec pairs)
+    = do (env1, pairs') <- fixM go
+         return (env1, Rec pairs')
+  where
+    go ~(_, new_pairs) = do
+         let env1 = extendIdZonkEnvRec env (map fst new_pairs)
+         pairs' <- mapM (zonkCorePair env1) pairs
+         return (env1, pairs')
+
+zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr)
+zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e
+
+zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
+zonkEvTypeable env (EvTypeableTyCon tycon e)
+  = do { e'  <- mapM (zonkEvTerm env) e
+       ; return $ EvTypeableTyCon tycon e' }
+zonkEvTypeable env (EvTypeableTyApp t1 t2)
+  = do { t1' <- zonkEvTerm env t1
+       ; t2' <- zonkEvTerm env t2
+       ; return (EvTypeableTyApp t1' t2') }
+zonkEvTypeable env (EvTypeableTrFun t1 t2)
+  = do { t1' <- zonkEvTerm env t1
+       ; t2' <- zonkEvTerm env t2
+       ; return (EvTypeableTrFun t1' t2') }
+zonkEvTypeable env (EvTypeableTyLit t1)
+  = do { t1' <- zonkEvTerm env t1
+       ; return (EvTypeableTyLit t1') }
+
+zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])
+zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs
+                            ; return (env, [EvBinds (unionManyBags bs')]) }
+
+zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
+zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs
+                          ; return (env', EvBinds bs') }
+
+zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)
+zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var
+zonk_tc_ev_binds env (EvBinds bs)    = zonkEvBinds env bs
+
+zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
+zonkEvBindsVar env (EvBindsVar { ebv_binds = ref })
+  = do { bs <- readMutVar ref
+       ; zonkEvBinds env (evBindMapBinds bs) }
+zonkEvBindsVar env (CoEvBindsVar {}) = return (env, emptyBag)
+
+zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
+zonkEvBinds env binds
+  = {-# SCC "zonkEvBinds" #-}
+    fixM (\ ~( _, new_binds) -> do
+         { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds)
+         ; binds' <- mapBagM (zonkEvBind env1) binds
+         ; return (env1, binds') })
+  where
+    collect_ev_bndrs :: Bag EvBind -> [EvVar]
+    collect_ev_bndrs = foldrBag add []
+    add (EvBind { eb_lhs = var }) vars = var : vars
+
+zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
+zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term })
+  = do { var'  <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var
+
+         -- Optimise the common case of Refl coercions
+         -- See Note [Optimise coercion zonking]
+         -- This has a very big effect on some programs (eg Trac #5030)
+
+       ; term' <- case getEqPredTys_maybe (idType var') of
+           Just (r, ty1, ty2) | ty1 `eqType` ty2
+                  -> return (evCoercion (mkTcReflCo r ty1))
+           _other -> zonkEvTerm env term
+
+       ; return (bind { eb_lhs = var', eb_rhs = term' }) }
+
+{- Note [Optimise coercion zonking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When optimising evidence binds we may come across situations where
+a coercion looks like
+      cv = ReflCo ty
+or    cv1 = cv2
+where the type 'ty' is big.  In such cases it is a waste of time to zonk both
+  * The variable on the LHS
+  * The coercion on the RHS
+Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just
+use Refl on the right, ignoring the actual coercion on the RHS.
+
+This can have a very big effect, because the constraint solver sometimes does go
+to a lot of effort to prove Refl!  (Eg when solving  10+3 = 10+3; cf Trac #5030)
+
+
+************************************************************************
+*                                                                      *
+                         Zonking types
+*                                                                      *
+************************************************************************
+-}
+
+{- Note [Sharing when zonking to Type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Problem:
+
+    In TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to
+    (Indirect zty), see Note [Sharing in zonking] in TcMType. But we
+    /can't/ do this when zonking a TcType to a Type (Trac #15552, esp
+    comment:3).  Suppose we have
+
+       alpha -> alpha
+         where
+            alpha is already unified:
+             alpha := T{tc-tycon} Int -> Int
+         and T is knot-tied
+
+    By "knot-tied" I mean that the occurrence of T is currently a TcTyCon,
+    but the global env contains a mapping "T" :-> T{knot-tied-tc}. See
+    Note [Type checking recursive type and class declarations] in
+    TcTyClsDecls.
+
+    Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow
+    the same path as Note [Sharing in zonking] in TcMType, we'll
+    update alpha to
+       alpha := T{knot-tied-tc} Int -> Int
+
+    But alas, if we encounter alpha for a /second/ time, we end up
+    looking at T{knot-tied-tc} and fall into a black hole. The whole
+    point of zonkTcTypeToType is that it produces a type full of
+    knot-tied tycons, and you must not look at the result!!
+
+    To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not
+    the same as zonkTcTypeToType. (If we distinguished TcType from
+    Type, this issue would have been a type error!)
+
+Solution: (see Trac #15552 for other variants)
+
+    One possible solution is simply not to do the short-circuiting.
+    That has less sharing, but maybe sharing is rare. And indeed,
+    that turns out to be viable from a perf point of view
+
+    But the code implements something a bit better
+
+    * ZonkEnv contains ze_meta_tv_env, which maps
+          from a MetaTyVar (unificaion variable)
+          to a Type (not a TcType)
+
+    * In zonkTyVarOcc, we check this map to see if we have zonked
+      this variable before. If so, use the previous answer; if not
+      zonk it, and extend the map.
+
+    * The map is of course stateful, held in a TcRef. (That is unlike
+      the treatment of lexically-scoped variables in ze_tv_env and
+      ze_id_env.
+
+    Is the extra work worth it.  Some non-sytematic perf measurements
+    suggest that compiler allocation is reduced overall (by 0.5% or so)
+    but compile time really doesn't change.
+-}
+
+zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType
+zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi
+                          , ze_tv_env = tv_env
+                          , ze_meta_tv_env = mtv_env_ref }) tv
+  | isTcTyVar tv
+  = case tcTyVarDetails tv of
+      SkolemTv {}    -> lookup_in_tv_env
+      RuntimeUnk {}  -> lookup_in_tv_env
+      MetaTv { mtv_ref = ref }
+        -> do { mtv_env <- readTcRef mtv_env_ref
+                -- See Note [Sharing when zonking to Type]
+              ; case lookupVarEnv mtv_env tv of
+                  Just ty -> return ty
+                  Nothing -> do { mtv_details <- readTcRef ref
+                                ; zonk_meta mtv_env ref mtv_details } }
+  | otherwise
+  = lookup_in_tv_env
+
+  where
+    lookup_in_tv_env    -- Look up in the env just as we do for Ids
+      = case lookupVarEnv tv_env tv of
+          Nothing  -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv
+          Just tv' -> return (mkTyVarTy tv')
+
+    zonk_meta mtv_env ref Flexi
+      = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv)
+           ; ty <- commitFlexi flexi tv kind
+           ; writeMetaTyVarRef tv ref ty  -- Belt and braces
+           ; finish_meta mtv_env ty }
+
+    zonk_meta mtv_env _ (Indirect ty)
+      = do { zty <- zonkTcTypeToTypeX env ty
+           ; finish_meta mtv_env zty }
+
+    finish_meta mtv_env ty
+      = do { let mtv_env' = extendVarEnv mtv_env tv ty
+           ; writeTcRef mtv_env_ref mtv_env'
+           ; return ty }
+
+lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar
+lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv
+  = lookupVarEnv tv_env tv
+
+commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type
+-- Only monadic so we can do tc-tracing
+commitFlexi flexi tv zonked_kind
+  = case flexi of
+      SkolemiseFlexi  -> return (mkTyVarTy (mkTyVar name zonked_kind))
+
+      DefaultFlexi
+        | isRuntimeRepTy zonked_kind
+        -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv)
+              ; return liftedRepTy }
+        | otherwise
+        -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv)
+              ; return (anyTypeOfKind zonked_kind) }
+
+      RuntimeUnkFlexi
+        -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv)
+              ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) }
+                        -- This is where RuntimeUnks are born:
+                        -- otherwise-unconstrained unification variables are
+                        -- turned into RuntimeUnks as they leave the
+                        -- typechecker's monad
+  where
+     name = tyVarName tv
+
+zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion
+zonkCoVarOcc (ZonkEnv { ze_tv_env = tyco_env }) cv
+  | Just cv' <- lookupVarEnv tyco_env cv  -- don't look in the knot-tied env
+  = return $ mkCoVarCo cv'
+  | otherwise
+  = do { cv' <- zonkCoVar cv; return (mkCoVarCo cv') }
+
+zonkCoHole :: ZonkEnv -> CoercionHole -> TcM Coercion
+zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
+  = do { contents <- readTcRef ref
+       ; case contents of
+           Just co -> do { co' <- zonkCoToCo env co
+                         ; checkCoercionHole cv co' }
+
+              -- This next case should happen only in the presence of
+              -- (undeferred) type errors. Originally, I put in a panic
+              -- here, but that caused too many uses of `failIfErrsM`.
+           Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole)
+                         ; when debugIsOn $
+                           whenNoErrs $
+                           MASSERT2( False
+                                   , text "Type-correct unfilled coercion hole"
+                                     <+> ppr hole )
+                         ; cv' <- zonkCoVar cv
+                         ; return $ mkCoVarCo cv' } }
+                             -- This will be an out-of-scope variable, but keeping
+                             -- this as a coercion hole led to #15787
+
+zonk_tycomapper :: TyCoMapper ZonkEnv TcM
+zonk_tycomapper = TyCoMapper
+  { tcm_smart = True   -- Establish type invariants
+  , tcm_tyvar = zonkTyVarOcc
+  , tcm_covar = zonkCoVarOcc
+  , tcm_hole  = zonkCoHole
+  , tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv
+  , tcm_tycon = zonkTcTyConToTyCon }
+
+-- Zonk a TyCon by changing a TcTyCon to a regular TyCon
+zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon
+zonkTcTyConToTyCon tc
+  | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc)
+                      ; case thing of
+                          ATyCon real_tc -> return real_tc
+                          _              -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) }
+  | otherwise    = return tc -- it's already zonked
+
+-- Confused by zonking? See Note [What is zonking?] in TcMType.
+zonkTcTypeToType :: TcType -> TcM Type
+zonkTcTypeToType = initZonkEnv zonkTcTypeToTypeX
+
+zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type
+zonkTcTypeToTypeX = mapType zonk_tycomapper
+
+zonkTcTypesToTypes :: [TcType] -> TcM [Type]
+zonkTcTypesToTypes = initZonkEnv zonkTcTypesToTypesX
+
+zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type]
+zonkTcTypesToTypesX env tys = mapM (zonkTcTypeToTypeX env) tys
+
+zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion
+zonkCoToCo = mapCoercion zonk_tycomapper
+
+zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo
+zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec)
+  = do { ty' <- zonkTcTypeToTypeX ze ty
+       ; gdm_spec' <- zonk_gdm gdm_spec
+       ; return (name, ty', gdm_spec') }
+  where
+    zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType))
+             -> TcM (Maybe (DefMethSpec (SrcSpan, Type)))
+    zonk_gdm Nothing = return Nothing
+    zonk_gdm (Just VanillaDM) = return (Just VanillaDM)
+    zonk_gdm (Just (GenericDM (loc, ty)))
+      = do { ty' <- zonkTcTypeToTypeX ze ty
+           ; return (Just (GenericDM (loc, ty'))) }
+
+---------------------------------------
+{- Note [Zonking the LHS of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also DsBinds Note [Free tyvars on rule LHS]
+
+We need to gather the type variables mentioned on the LHS so we can
+quantify over them.  Example:
+  data T a = C
+
+  foo :: T a -> Int
+  foo C = 1
+
+  {-# RULES "myrule"  foo C = 1 #-}
+
+After type checking the LHS becomes (foo alpha (C alpha)) and we do
+not want to zap the unbound meta-tyvar 'alpha' to Any, because that
+limits the applicability of the rule.  Instead, we want to quantify
+over it!
+
+We do this in two stages.
+
+* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'.  We
+  do this by using zonkTvSkolemising as the UnboundTyVarZonker in the
+  ZonkEnv.  (This is in fact the whole reason that the ZonkEnv has a
+  UnboundTyVarZonker.)
+
+* In DsBinds, we quantify over it.  See DsBinds
+  Note [Free tyvars on rule LHS]
+
+Quantifying here is awkward because (a) the data type is big and (b)
+finding the free type vars of an expression is necessarily monadic
+operation. (consider /\a -> f @ b, where b is side-effected to a)
+-}
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcHsType.hs
@@ -0,0 +1,2878 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[TcMonoType]{Typechecking user-specified @MonoTypes@}
+-}
+
+{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcHsType (
+        -- Type signatures
+        kcHsSigType, tcClassSigType,
+        tcHsSigType, tcHsSigWcType,
+        tcHsPartialSigType,
+        funsSigCtxt, addSigCtxt, pprSigCtxt,
+
+        tcHsClsInstType,
+        tcHsDeriv, tcDerivStrategy,
+        tcHsTypeApp,
+        UserTypeCtxt(..),
+        bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,
+            bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol,
+        bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,
+            bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,
+        ContextKind(..),
+
+                -- Type checking type and class decls
+        kcLookupTcTyCon, bindTyClTyVars,
+        etaExpandAlgTyCon, tcbVisibilities,
+
+          -- tyvars
+        zonkAndScopedSort,
+
+        -- Kind-checking types
+        -- No kind generalisation, no checkValidType
+        kcLHsQTyVars,
+        tcWildCardBinders,
+        tcHsLiftedType,   tcHsOpenType,
+        tcHsLiftedTypeNC, tcHsOpenTypeNC,
+        tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType,
+        tcHsMbContext, tcHsContext, tcLHsPredType, tcInferApps,
+        failIfEmitsConstraints,
+        solveEqualities, -- useful re-export
+
+        typeLevelMode, kindLevelMode,
+
+        kindGeneralize, checkExpectedKind, RequireSaturation(..),
+        reportFloatingKvs,
+
+        -- Sort-checking kinds
+        tcLHsKindSig, badKindSig,
+
+        -- Zonking and promoting
+        zonkPromoteType,
+
+        -- Pattern type signatures
+        tcHsPatSigType, tcPatSig,
+
+        -- Error messages
+        funAppCtxt, addTyConFlavCtxt
+   ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import TcRnMonad
+import TcEvidence
+import TcEnv
+import TcMType
+import TcValidity
+import TcUnify
+import TcIface
+import TcSimplify
+import TcHsSyn
+import TcErrors ( reportAllUnsolved )
+import TcType
+import Inst   ( tcInstTyBinders, tcInstTyBinder )
+import TyCoRep( TyCoBinder(..), TyBinder, tyCoBinderArgFlag )  -- Used in etaExpandAlgTyCon
+import Type
+import TysPrim
+import Coercion
+import RdrName( lookupLocalRdrOcc )
+import Var
+import VarSet
+import TyCon
+import ConLike
+import DataCon
+import Class
+import Name
+import NameSet
+import VarEnv
+import TysWiredIn
+import BasicTypes
+import SrcLoc
+import Constants ( mAX_CTUPLE_SIZE )
+import ErrUtils( MsgDoc )
+import Unique
+import UniqSet
+import Util
+import UniqSupply
+import Outputable
+import FastString
+import PrelNames hiding ( wildCardName )
+import DynFlags ( WarningFlag (Opt_WarnPartialTypeSignatures) )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Maybes
+import Data.List ( find )
+import Control.Monad
+
+{-
+        ----------------------------
+                General notes
+        ----------------------------
+
+Unlike with expressions, type-checking types both does some checking and
+desugars at the same time. This is necessary because we often want to perform
+equality checks on the types right away, and it would be incredibly painful
+to do this on un-desugared types. Luckily, desugared types are close enough
+to HsTypes to make the error messages sane.
+
+During type-checking, we perform as little validity checking as possible.
+Generally, after type-checking, you will want to do validity checking, say
+with TcValidity.checkValidType.
+
+Validity checking
+~~~~~~~~~~~~~~~~~
+Some of the validity check could in principle be done by the kind checker,
+but not all:
+
+- During desugaring, we normalise by expanding type synonyms.  Only
+  after this step can we check things like type-synonym saturation
+  e.g.  type T k = k Int
+        type S a = a
+  Then (T S) is ok, because T is saturated; (T S) expands to (S Int);
+  and then S is saturated.  This is a GHC extension.
+
+- Similarly, also a GHC extension, we look through synonyms before complaining
+  about the form of a class or instance declaration
+
+- Ambiguity checks involve functional dependencies
+
+Also, in a mutually recursive group of types, we can't look at the TyCon until we've
+finished building the loop.  So to keep things simple, we postpone most validity
+checking until step (3).
+
+%************************************************************************
+%*                                                                      *
+              Check types AND do validity checking
+*                                                                      *
+************************************************************************
+-}
+
+funsSigCtxt :: [Located Name] -> UserTypeCtxt
+-- Returns FunSigCtxt, with no redundant-context-reporting,
+-- form a list of located names
+funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False
+funsSigCtxt []              = panic "funSigCtxt"
+
+addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a
+addSigCtxt ctxt hs_ty thing_inside
+  = setSrcSpan (getLoc hs_ty) $
+    addErrCtxt (pprSigCtxt ctxt hs_ty) $
+    thing_inside
+
+pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc
+-- (pprSigCtxt ctxt <extra> <type>)
+-- prints    In the type signature for 'f':
+--              f :: <type>
+-- The <extra> is either empty or "the ambiguity check for"
+pprSigCtxt ctxt hs_ty
+  | Just n <- isSigMaybe ctxt
+  = hang (text "In the type signature:")
+       2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty)
+
+  | otherwise
+  = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)
+       2 (ppr hs_ty)
+
+tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type
+-- This one is used when we have a LHsSigWcType, but in
+-- a place where wildcards aren't allowed. The renamer has
+-- already checked this, so we can simply ignore it.
+tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)
+
+kcHsSigType :: [Located Name] -> LHsSigType GhcRn -> TcM ()
+kcHsSigType names (HsIB { hsib_body = hs_ty
+                                  , hsib_ext = sig_vars })
+  = addSigCtxt (funsSigCtxt names) hs_ty $
+    discardResult $
+    bindImplicitTKBndrs_Skol sig_vars $
+    tc_lhs_type typeLevelMode hs_ty liftedTypeKind
+
+kcHsSigType _ (XHsImplicitBndrs _) = panic "kcHsSigType"
+
+tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type
+-- Does not do validity checking
+tcClassSigType skol_info names sig_ty
+  = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $
+    tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind)
+       -- Do not zonk-to-Type, nor perform a validity check
+       -- We are in a knot with the class and associated types
+       -- Zonking and validity checking is done by tcClassDecl
+
+tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
+-- Does validity checking
+-- See Note [Recipe for checking a signature]
+tcHsSigType ctxt sig_ty
+  = addSigCtxt ctxt (hsSigType sig_ty) $
+    do { traceTc "tcHsSigType {" (ppr sig_ty)
+
+          -- Generalise here: see Note [Kind generalisation]
+       ; ty <- tc_hs_sig_type skol_info sig_ty
+                                      (expectedKindInCtxt ctxt)
+       ; ty <- zonkTcType ty
+
+       ; checkValidType ctxt ty
+       ; traceTc "end tcHsSigType }" (ppr ty)
+       ; return ty }
+  where
+    skol_info = SigTypeSkol ctxt
+
+tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn
+               -> ContextKind -> TcM Type
+-- Kind-checks/desugars an 'LHsSigType',
+--   solve equalities,
+--   and then kind-generalizes.
+-- This will never emit constraints, as it uses solveEqualities interally.
+-- No validity checking or zonking
+tc_hs_sig_type skol_info hs_sig_type ctxt_kind
+  | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type
+  = do { (tc_lvl, (wanted, (spec_tkvs, ty)))
+              <- pushTcLevelM                           $
+                 solveLocalEqualitiesX "tc_hs_sig_type" $
+                 bindImplicitTKBndrs_Skol sig_vars      $
+                 do { kind <- newExpectedKind ctxt_kind
+
+                    ; tc_lhs_type typeLevelMode hs_ty kind }
+       -- Any remaining variables (unsolved in the solveLocalEqualities)
+       -- should be in the global tyvars, and therefore won't be quantified
+
+       ; spec_tkvs <- zonkAndScopedSort spec_tkvs
+       ; let ty1 = mkSpecForAllTys spec_tkvs ty
+       ; kvs <- kindGeneralizeLocal wanted ty1
+       ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs)
+                                  tc_lvl wanted
+
+       ; return (mkInvForAllTys kvs ty1) }
+
+tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type_and_gen"
+
+tcTopLHsType :: LHsSigType GhcRn -> ContextKind -> TcM Type
+-- tcTopLHsType is used for kind-checking top-level HsType where
+--   we want to fully solve /all/ equalities, and report errors
+-- Does zonking, but not validity checking because it's used
+--   for things (like deriving and instances) that aren't
+--   ordinary types
+tcTopLHsType hs_sig_type ctxt_kind
+  | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type
+  = do { traceTc "tcTopLHsType {" (ppr hs_ty)
+       ; (spec_tkvs, ty)
+              <- pushTcLevelM_                     $
+                 solveEqualities                   $
+                 bindImplicitTKBndrs_Skol sig_vars $
+                 do { kind <- newExpectedKind ctxt_kind
+                    ; tc_lhs_type typeLevelMode hs_ty kind }
+
+       ; spec_tkvs <- zonkAndScopedSort spec_tkvs
+       ; let ty1 = mkSpecForAllTys spec_tkvs ty
+       ; kvs <- kindGeneralize ty1
+       ; final_ty <- zonkTcTypeToType (mkInvForAllTys kvs ty1)
+       ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty])
+       ; return final_ty}
+
+tcTopLHsType (XHsImplicitBndrs _) _ = panic "tcTopLHsType"
+
+-----------------
+tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], (Class, [Type], [Kind]))
+-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause
+-- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments
+-- E.g.    class C (a::*) (b::k->k)
+--         data T a b = ... deriving( C Int )
+--    returns ([k], C, [k, Int], [k->k])
+-- Return values are fully zonked
+tcHsDeriv hs_ty
+  = do { ty <- checkNoErrs $  -- Avoid redundant error report
+                              -- with "illegal deriving", below
+               tcTopLHsType hs_ty AnyKind
+       ; let (tvs, pred)    = splitForAllTys ty
+             (kind_args, _) = splitFunTys (typeKind pred)
+       ; case getClassPredTys_maybe pred of
+           Just (cls, tys) -> return (tvs, (cls, tys, kind_args))
+           Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }
+
+-- | Typecheck something within the context of a deriving strategy.
+-- This is of particular importance when the deriving strategy is @via@.
+-- For instance:
+--
+-- @
+-- deriving via (S a) instance C (T a)
+-- @
+--
+-- We need to typecheck @S a@, and moreover, we need to extend the tyvar
+-- environment with @a@ before typechecking @C (T a)@, since @S a@ quantified
+-- the type variable @a@.
+tcDerivStrategy
+  :: forall a.
+     Maybe (DerivStrategy GhcRn) -- ^ The deriving strategy
+  -> TcM ([TyVar], a) -- ^ The thing to typecheck within the context of the
+                      -- deriving strategy, which might quantify some type
+                      -- variables of its own.
+  -> TcM (Maybe (DerivStrategy GhcTc), [TyVar], a)
+     -- ^ The typechecked deriving strategy, all quantified tyvars, and
+     -- the payload of the typechecked thing.
+tcDerivStrategy mds thing_inside
+  = case mds of
+      Nothing -> boring_case Nothing
+      Just ds -> do (ds', tvs, thing) <- tc_deriv_strategy ds
+                    pure (Just ds', tvs, thing)
+  where
+    tc_deriv_strategy :: DerivStrategy GhcRn
+                      -> TcM (DerivStrategy GhcTc, [TyVar], a)
+    tc_deriv_strategy StockStrategy    = boring_case StockStrategy
+    tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy
+    tc_deriv_strategy NewtypeStrategy  = boring_case NewtypeStrategy
+    tc_deriv_strategy (ViaStrategy ty) = do
+      ty' <- checkNoErrs $
+             tcTopLHsType ty AnyKind
+      let (via_tvs, via_pred) = splitForAllTys ty'
+      tcExtendTyVarEnv via_tvs $ do
+        (thing_tvs, thing) <- thing_inside
+        pure (ViaStrategy via_pred, via_tvs ++ thing_tvs, thing)
+
+    boring_case :: mds -> TcM (mds, [TyVar], a)
+    boring_case mds = do
+      (thing_tvs, thing) <- thing_inside
+      pure (mds, thing_tvs, thing)
+
+tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt
+                -> LHsSigType GhcRn
+                -> TcM Type
+-- Like tcHsSigType, but for a class instance declaration
+tcHsClsInstType user_ctxt hs_inst_ty
+  = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $
+    do { -- Fail eagerly if tcTopLHsType fails.  We are at top level so
+         -- these constraints will never be solved later. And failing
+         -- eagerly avoids follow-on errors when checkValidInstance
+         -- sees an unsolved coercion hole
+         inst_ty <- checkNoErrs $
+                    tcTopLHsType hs_inst_ty (TheKind constraintKind)
+       ; checkValidInstance user_ctxt hs_inst_ty inst_ty
+       ; return inst_ty }
+
+----------------------------------------------
+-- | Type-check a visible type application
+tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type
+-- See Note [Recipe for checking a signature] in TcHsType
+tcHsTypeApp wc_ty kind
+  | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty
+  = do { ty <- solveLocalEqualities "tcHsTypeApp" $
+               -- We are looking at a user-written type, very like a
+               -- signature so we want to solve its equalities right now
+               unsetWOptM Opt_WarnPartialTypeSignatures $
+               setXOptM LangExt.PartialTypeSignatures $
+               -- See Note [Wildcards in visible type application]
+               tcWildCardBinders sig_wcs $ \ _ ->
+               tcCheckLHsType hs_ty kind
+       -- We must promote here. Ex:
+       --   f :: forall a. a
+       --   g = f @(forall b. Proxy b -> ()) @Int ...
+       -- After when processing the @Int, we'll have to check its kind
+       -- against the as-yet-unknown kind of b. This check causes an assertion
+       -- failure if we don't promote.
+       ; ty <- zonkPromoteType ty
+       ; checkValidType TypeAppCtxt ty
+       ; return ty }
+tcHsTypeApp (XHsWildCardBndrs _) _ = panic "tcHsTypeApp"
+
+{- Note [Wildcards in visible type application]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A HsWildCardBndrs's hswc_ext now only includes named wildcards, so any unnamed
+wildcards stay unchanged in hswc_body and when called in tcHsTypeApp, tcCheckLHsType
+will call emitWildCardHoleConstraints on them. However, this would trigger
+error/warning when an unnamed wildcard is passed in as a visible type argument,
+which we do not want because users should be able to write @_ to skip a instantiating
+a type variable variable without fuss. The solution is to switch the
+PartialTypeSignatures flags here to let the typechecker know that it's checking
+a '@_' and do not emit hole constraints on it.
+See related Note [Wildcards in visible kind application]
+and Note [The wildcard story for types] in HsTypes.hs
+
+-}
+
+{-
+************************************************************************
+*                                                                      *
+            The main kind checker: no validity checks here
+*                                                                      *
+************************************************************************
+
+        First a couple of simple wrappers for kcHsType
+-}
+
+---------------------------
+tcHsOpenType, tcHsLiftedType,
+  tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType
+-- Used for type signatures
+-- Do not do validity checking
+tcHsOpenType ty   = addTypeCtxt ty $ tcHsOpenTypeNC ty
+tcHsLiftedType ty = addTypeCtxt ty $ tcHsLiftedTypeNC ty
+
+tcHsOpenTypeNC   ty = do { ek <- newOpenTypeKind
+                         ; tc_lhs_type typeLevelMode ty ek }
+tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind
+
+-- Like tcHsType, but takes an expected kind
+tcCheckLHsType :: LHsType GhcRn -> Kind -> TcM TcType
+tcCheckLHsType hs_ty exp_kind
+  = addTypeCtxt hs_ty $
+    tc_lhs_type typeLevelMode hs_ty exp_kind
+
+tcLHsType :: LHsType GhcRn -> TcM (TcType, TcKind)
+-- Called from outside: set the context
+tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty)
+
+-- Like tcLHsType, but use it in a context where type synonyms and type families
+-- do not need to be saturated, like in a GHCi :kind call
+tcLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)
+tcLHsTypeUnsaturated ty = addTypeCtxt ty (tc_infer_lhs_type mode ty)
+  where
+    mode = allowUnsaturated typeLevelMode
+
+{-
+************************************************************************
+*                                                                      *
+      Type-checking modes
+*                                                                      *
+************************************************************************
+
+The kind-checker is parameterised by a TcTyMode, which contains some
+information about where we're checking a type.
+
+The renamer issues errors about what it can. All errors issued here must
+concern things that the renamer can't handle.
+
+-}
+
+-- | Do we require type families to be saturated?
+data RequireSaturation
+  = YesSaturation
+  | NoSaturation   -- e.g. during a call to GHCi's :kind
+
+-- | Info about the context in which we're checking a type. Currently,
+-- differentiates only between types and kinds, but this will likely
+-- grow, at least to include the distinction between patterns and
+-- not-patterns.
+data TcTyMode
+  = TcTyMode { mode_level :: TypeOrKind
+             , mode_sat   :: RequireSaturation
+             }
+ -- The mode_unsat field is solely so that type families/synonyms can be unsaturated
+ -- in GHCi :kind calls
+
+typeLevelMode :: TcTyMode
+typeLevelMode = TcTyMode { mode_level = TypeLevel, mode_sat = YesSaturation }
+
+kindLevelMode :: TcTyMode
+kindLevelMode = TcTyMode { mode_level = KindLevel, mode_sat = YesSaturation }
+
+allowUnsaturated :: TcTyMode -> TcTyMode
+allowUnsaturated mode = mode { mode_sat = NoSaturation }
+
+-- switch to kind level
+kindLevel :: TcTyMode -> TcTyMode
+kindLevel mode = mode { mode_level = KindLevel }
+
+instance Outputable RequireSaturation where
+  ppr YesSaturation = text "YesSaturation"
+  ppr NoSaturation  = text "NoSaturation"
+
+instance Outputable TcTyMode where
+  ppr = ppr . mode_level
+
+{-
+Note [Bidirectional type checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In expressions, whenever we see a polymorphic identifier, say `id`, we are
+free to instantiate it with metavariables, knowing that we can always
+re-generalize with type-lambdas when necessary. For example:
+
+  rank2 :: (forall a. a -> a) -> ()
+  x = rank2 id
+
+When checking the body of `x`, we can instantiate `id` with a metavariable.
+Then, when we're checking the application of `rank2`, we notice that we really
+need a polymorphic `id`, and then re-generalize over the unconstrained
+metavariable.
+
+In types, however, we're not so lucky, because *we cannot re-generalize*!
+There is no lambda. So, we must be careful only to instantiate at the last
+possible moment, when we're sure we're never going to want the lost polymorphism
+again. This is done in calls to tcInstTyBinders.
+
+To implement this behavior, we use bidirectional type checking, where we
+explicitly think about whether we know the kind of the type we're checking
+or not. Note that there is a difference between not knowing a kind and
+knowing a metavariable kind: the metavariables are TauTvs, and cannot become
+forall-quantified kinds. Previously (before dependent types), there were
+no higher-rank kinds, and so we could instantiate early and be sure that
+no types would have polymorphic kinds, and so we could always assume that
+the kind of a type was a fresh metavariable. Not so anymore, thus the
+need for two algorithms.
+
+For HsType forms that can never be kind-polymorphic, we implement only the
+"down" direction, where we safely assume a metavariable kind. For HsType forms
+that *can* be kind-polymorphic, we implement just the "up" (functions with
+"infer" in their name) version, as we gain nothing by also implementing the
+"down" version.
+
+Note [Future-proofing the type checker]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As discussed in Note [Bidirectional type checking], each HsType form is
+handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions
+are mutually recursive, so that either one can work for any type former.
+But, we want to make sure that our pattern-matches are complete. So,
+we have a bunch of repetitive code just so that we get warnings if we're
+missing any patterns.
+
+Note [The tcType invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(IT1) If    tc_ty = tc_hs_type hs_ty exp_kind
+      then  tcTypeKind tc_ty = exp_kind
+without any zonking needed.  The reason for this is that in
+tcInferApps we see (F ty), and we kind-check 'ty' with an
+expected-kind coming from F.  Then, to make the resulting application
+well kinded --- see Note [The well-kinded type invariant] in TcType ---
+we need the kind-checked 'ty' to have exactly the kind that F expects,
+with no funny zonking nonsense in between.
+
+The tcType invariant also applies to checkExpectedKind:
+
+(IT2) if
+        (tc_ty, _, _) = checkExpectedKind ty act_ki exp_ki
+      then
+        tcTypeKind tc_ty = exp_ki
+
+These other invariants are all necessary, too, as these functions
+are used within tc_hs_type:
+
+(IT3) If (ty, ki) <- tc_infer_hs_type ..., then tcTypeKind ty == ki.
+
+(IT4) If (ty, ki) <- tc_infer_hs_type ..., then zonk ki == ki.
+      (In other words, the result kind of tc_infer_hs_type is zonked.)
+
+(IT5) If (ty, ki) <- tcTyVar ..., then tcTypeKind ty == ki.
+
+(IT6) If (ty, ki) <- tcTyVar ..., then zonk ki == ki.
+      (In other words, the result kind of tcTyVar is zonked.)
+
+-}
+
+------------------------------------------
+-- | Check and desugar a type, returning the core type and its
+-- possibly-polymorphic kind. Much like 'tcInferRho' at the expression
+-- level.
+tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)
+tc_infer_lhs_type mode (L span ty)
+  = setSrcSpan span $
+    do { (ty', kind) <- tc_infer_hs_type mode ty
+       ; return (ty', kind) }
+
+-- | Infer the kind of a type and desugar. This is the "up" type-checker,
+-- as described in Note [Bidirectional type checking]
+tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)
+tc_infer_hs_type mode (HsParTy _ t)          = tc_infer_lhs_type mode t
+tc_infer_hs_type mode (HsTyVar _ _ (L _ tv)) = tcTyVar mode tv
+
+tc_infer_hs_type mode e@(HsAppTy {}) = tcTyApp mode e
+tc_infer_hs_type mode e@(HsAppKindTy {}) = tcTyApp mode e
+
+tc_infer_hs_type mode (HsOpTy _ lhs lhs_op@(L _ hs_op) rhs)
+  | not (hs_op `hasKey` funTyConKey)
+  = do { (op, op_kind) <- tcTyVar mode hs_op
+       ; tcTyApps mode (noLoc $ HsTyVar noExt NotPromoted lhs_op) op op_kind
+                       [HsValArg lhs, HsValArg rhs] }
+
+tc_infer_hs_type mode (HsKindSig _ ty sig)
+  = do { sig' <- tcLHsKindSig KindSigCtxt sig
+                 -- We must typecheck the kind signature, and solve all
+                 -- its equalities etc; from this point on we may do
+                 -- things like instantiate its foralls, so it needs
+                 -- to be fully determined (Trac #14904)
+       ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig')
+       ; ty' <- tc_lhs_type mode ty sig'
+       ; return (ty', sig') }
+
+-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType' to communicate
+-- the splice location to the typechecker. Here we skip over it in order to have
+-- the same kind inferred for a given expression whether it was produced from
+-- splices or not.
+--
+-- See Note [Delaying modFinalizers in untyped splices].
+tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)))
+  = tc_infer_hs_type mode ty
+
+tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty
+tc_infer_hs_type _    (XHsType (NHsCoreTy ty))
+  = do { ty <- zonkTcType ty  -- (IT3) and (IT4) of Note [The tcType invariant]
+       ; return (ty, tcTypeKind ty) }
+
+tc_infer_hs_type _ (HsExplicitListTy _ _ tys)
+  | null tys  -- this is so that we can use visible kind application with '[]
+              -- e.g ... '[] @Bool
+  = return (mkTyConTy promotedNilDataCon,
+            mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy)
+
+tc_infer_hs_type mode other_ty
+  = do { kv <- newMetaKindVar
+       ; ty' <- tc_hs_type mode other_ty kv
+       ; return (ty', kv) }
+
+------------------------------------------
+tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType
+tc_lhs_type mode (L span ty) exp_kind
+  = setSrcSpan span $
+    tc_hs_type mode ty exp_kind
+
+------------------------------------------
+tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind
+            -> TcM TcType
+tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of
+  TypeLevel ->
+    do { arg_k <- newOpenTypeKind
+       ; res_k <- newOpenTypeKind
+       ; ty1' <- tc_lhs_type mode ty1 arg_k
+       ; ty2' <- tc_lhs_type mode ty2 res_k
+       ; checkExpectedKindMode mode (ppr $ HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2')
+                           liftedTypeKind exp_kind }
+  KindLevel ->  -- no representation polymorphism in kinds. yet.
+    do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind
+       ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind
+       ; checkExpectedKindMode mode (ppr $ HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2')
+                           liftedTypeKind exp_kind }
+
+------------------------------------------
+tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
+-- See Note [The tcType invariant]
+-- See Note [Bidirectional type checking]
+
+tc_hs_type mode (HsParTy _ ty)   exp_kind = tc_lhs_type mode ty exp_kind
+tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind
+tc_hs_type _ ty@(HsBangTy _ bang _) _
+    -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),
+    -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of
+    -- bangs are invalid, so fail. (#7210, #14761)
+    = do { let bangError err = failWith $
+                 text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$
+                 text err <+> text "annotation cannot appear nested inside a type"
+         ; case bang of
+             HsSrcBang _ SrcUnpack _           -> bangError "UNPACK"
+             HsSrcBang _ SrcNoUnpack _         -> bangError "NOUNPACK"
+             HsSrcBang _ NoSrcUnpack SrcLazy   -> bangError "laziness"
+             HsSrcBang _ _ _                   -> bangError "strictness" }
+tc_hs_type _ ty@(HsRecTy {})      _
+      -- Record types (which only show up temporarily in constructor
+      -- signatures) should have been removed by now
+    = failWithTc (text "Record syntax is illegal here:" <+> ppr ty)
+
+-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType'.
+-- Here we get rid of it and add the finalizers to the global environment
+-- while capturing the local environment.
+--
+-- See Note [Delaying modFinalizers in untyped splices].
+tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty)))
+           exp_kind
+  = do addModFinalizersWithLclEnv mod_finalizers
+       tc_hs_type mode ty exp_kind
+
+-- This should never happen; type splices are expanded by the renamer
+tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind
+  = failWithTc (text "Unexpected type splice:" <+> ppr ty)
+
+---------- Functions and applications
+tc_hs_type mode (HsFunTy _ ty1 ty2) exp_kind
+  = tc_fun_type mode ty1 ty2 exp_kind
+
+tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind
+  | op `hasKey` funTyConKey
+  = tc_fun_type mode ty1 ty2 exp_kind
+
+--------- Foralls
+tc_hs_type mode forall@(HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind
+  = do { (tclvl, wanted, (tvs', ty'))
+            <- pushLevelAndCaptureConstraints $
+               bindExplicitTKBndrs_Skol hs_tvs $
+               tc_lhs_type mode ty exp_kind
+    -- Do not kind-generalise here!  See Note [Kind generalisation]
+    -- Why exp_kind?  See Note [Body kind of HsForAllTy]
+       ; let bndrs       = mkTyVarBinders Specified tvs'
+             skol_info   = ForAllSkol (ppr forall)
+             m_telescope = Just (sep (map ppr hs_tvs))
+
+       ; emitResidualTvConstraint skol_info m_telescope tvs' tclvl wanted
+
+       ; return (mkForAllTys bndrs ty') }
+
+tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind
+  | null (unLoc ctxt)
+  = tc_lhs_type mode ty exp_kind
+
+  | otherwise
+  = do { ctxt' <- tc_hs_context mode ctxt
+
+         -- See Note [Body kind of a HsQualTy]
+       ; ty' <- if tcIsConstraintKind exp_kind
+                then tc_lhs_type mode ty constraintKind
+                else do { ek <- newOpenTypeKind
+                                -- The body kind (result of the function)
+                                -- can be TYPE r, for any r, hence newOpenTypeKind
+                        ; ty' <- tc_lhs_type mode ty ek
+                        ; checkExpectedKindMode mode (ppr ty) ty' liftedTypeKind exp_kind }
+
+       ; return (mkPhiTy ctxt' ty') }
+
+--------- Lists, arrays, and tuples
+tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind
+  = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind
+       ; checkWiredInTyCon listTyCon
+       ; checkExpectedKindMode mode (ppr rn_ty) (mkListTy tau_ty) liftedTypeKind exp_kind }
+
+-- See Note [Distinguishing tuple kinds] in HsTypes
+-- See Note [Inferring tuple kinds]
+tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind
+     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)
+  | Just tup_sort <- tupKindSort_maybe exp_kind
+  = traceTc "tc_hs_type tuple" (ppr hs_tys) >>
+    tc_tuple rn_ty mode tup_sort hs_tys exp_kind
+  | otherwise
+  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)
+       ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys
+       ; kinds <- mapM zonkTcType kinds
+           -- Infer each arg type separately, because errors can be
+           -- confusing if we give them a shared kind.  Eg Trac #7410
+           -- (Either Int, Int), we do not want to get an error saying
+           -- "the second argument of a tuple should have kind *->*"
+
+       ; let (arg_kind, tup_sort)
+               = case [ (k,s) | k <- kinds
+                              , Just s <- [tupKindSort_maybe k] ] of
+                    ((k,s) : _) -> (k,s)
+                    [] -> (liftedTypeKind, BoxedTuple)
+         -- In the [] case, it's not clear what the kind is, so guess *
+
+       ; tys' <- sequence [ setSrcSpan loc $
+                            checkExpectedKindMode mode (ppr hs_ty) ty kind arg_kind
+                          | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]
+
+       ; finish_tuple rn_ty mode tup_sort tys' (map (const arg_kind) tys') exp_kind }
+
+
+tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind
+  = tc_tuple rn_ty mode tup_sort tys exp_kind
+  where
+    tup_sort = case hs_tup_sort of  -- Fourth case dealt with above
+                  HsUnboxedTuple    -> UnboxedTuple
+                  HsBoxedTuple      -> BoxedTuple
+                  HsConstraintTuple -> ConstraintTuple
+                  _                 -> panic "tc_hs_type HsTupleTy"
+
+tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind
+  = do { let arity = length hs_tys
+       ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys
+       ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds
+       ; let arg_reps = map kindRep arg_kinds
+             arg_tys  = arg_reps ++ tau_tys
+       ; checkExpectedKindMode mode (ppr rn_ty)
+                           (mkTyConApp (sumTyCon arity) arg_tys)
+                           (unboxedSumKind arg_reps)
+                           exp_kind
+       }
+
+--------- Promoted lists and tuples
+tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind
+  = do { tks <- mapM (tc_infer_lhs_type mode) tys
+       ; (taus', kind) <- unifyKinds tys tks
+       ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')
+       ; checkExpectedKindMode mode (ppr rn_ty) ty (mkListTy kind) exp_kind }
+  where
+    mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]
+    mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k]
+
+tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind
+  -- using newMetaKindVar means that we force instantiations of any polykinded
+  -- types. At first, I just used tc_infer_lhs_type, but that led to #11255.
+  = do { ks   <- replicateM arity newMetaKindVar
+       ; taus <- zipWithM (tc_lhs_type mode) tys ks
+       ; let kind_con   = tupleTyCon           Boxed arity
+             ty_con     = promotedTupleDataCon Boxed arity
+             tup_k      = mkTyConApp kind_con ks
+       ; checkExpectedKindMode mode (ppr rn_ty) (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }
+  where
+    arity = length tys
+
+--------- Constraint types
+tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind
+  = do { MASSERT( isTypeLevel (mode_level mode) )
+       ; ty' <- tc_lhs_type mode ty liftedTypeKind
+       ; let n' = mkStrLitTy $ hsIPNameFS n
+       ; ipClass <- tcLookupClass ipClassName
+       ; checkExpectedKindMode mode (ppr rn_ty) (mkClassPred ipClass [n',ty'])
+           constraintKind exp_kind }
+
+tc_hs_type mode rn_ty@(HsStarTy _ _) exp_kind
+  -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to
+  -- handle it in 'coreView' and 'tcView'.
+  = checkExpectedKindMode mode (ppr rn_ty) liftedTypeKind liftedTypeKind exp_kind
+
+--------- Literals
+tc_hs_type mode rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind
+  = do { checkWiredInTyCon typeNatKindCon
+       ; checkExpectedKindMode mode (ppr rn_ty) (mkNumLitTy n) typeNatKind exp_kind }
+
+tc_hs_type mode rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind
+  = do { checkWiredInTyCon typeSymbolKindCon
+       ; checkExpectedKindMode mode (ppr rn_ty) (mkStrLitTy s) typeSymbolKind exp_kind }
+
+--------- Potentially kind-polymorphic types: call the "up" checker
+-- See Note [Future-proofing the type checker]
+tc_hs_type mode ty@(HsTyVar {})   ek = tc_infer_hs_type_ek mode ty ek
+tc_hs_type mode ty@(HsAppTy {})   ek = tc_infer_hs_type_ek mode ty ek
+tc_hs_type mode ty@(HsAppKindTy{}) ek = tc_infer_hs_type_ek mode ty ek
+tc_hs_type mode ty@(HsOpTy {})    ek = tc_infer_hs_type_ek mode ty ek
+tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek
+tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek
+
+tc_hs_type mode wc@(HsWildCardTy _) exp_kind
+  = do { wc_ty <- tcWildCardOcc mode wc exp_kind
+       ; return (mkNakedCastTy wc_ty (mkTcNomReflCo exp_kind))
+         -- Take care here! Even though the coercion is Refl,
+         -- we still need it to establish Note [The tcType invariant]
+       }
+
+tcWildCardOcc :: TcTyMode -> HsType GhcRn -> Kind -> TcM TcType
+tcWildCardOcc mode wc exp_kind
+  = do { wc_tv <- newWildTyVar
+          -- The wildcard's kind should be an un-filled-in meta tyvar
+       ; loc <- getSrcSpanM
+       ; uniq <- newUnique
+       ; let name = mkInternalName uniq (mkTyVarOcc "_") loc
+       ; part_tysig <- xoptM LangExt.PartialTypeSignatures
+       ; warning <- woptM Opt_WarnPartialTypeSignatures
+       -- See Note [Wildcards in visible kind application]
+       ; unless (part_tysig && not warning)
+             (emitWildCardHoleConstraints [(name,wc_tv)])
+       ; checkExpectedKindMode mode (ppr wc) (mkTyVarTy wc_tv)
+                           (tyVarKind wc_tv) exp_kind }
+
+{- Note [Wildcards in visible kind application]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are cases where users might want to pass in a wildcard as a visible kind
+argument, for instance:
+
+data T :: forall k1 k2. k1 → k2 → Type where
+  MkT :: T a b
+x :: T @_ @Nat False n
+x = MkT
+
+So we should allow '@_' without emitting any hole constraints, and
+regardless of whether PartialTypeSignatures is enabled or not. But how would
+the typechecker know which '_' is being used in VKA and which is not when it
+calls emitWildCardHoleConstraints in tcHsPartialSigType on all HsWildCardBndrs?
+The solution then is to neither rename nor include unnamed wildcards in HsWildCardBndrs,
+but instead give every unnamed wildcard a fresh wild tyvar in tcWildCardOcc.
+And whenever we see a '@', we automatically turn on PartialTypeSignatures and
+turn off hole constraint warnings, and never call emitWildCardHoleConstraints
+under these conditions.
+See related Note [Wildcards in visible type application] here and
+Note [The wildcard story for types] in HsTypes.hs
+
+-}
+---------------------------
+-- | Call 'tc_infer_hs_type' and check its result against an expected kind.
+tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType
+tc_infer_hs_type_ek mode hs_ty ek
+  = do { (ty, k) <- tc_infer_hs_type mode hs_ty
+       ; checkExpectedKindMode mode (ppr hs_ty) ty k ek }
+
+---------------------------
+tupKindSort_maybe :: TcKind -> Maybe TupleSort
+tupKindSort_maybe k
+  | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'
+  | Just k'      <- tcView k            = tupKindSort_maybe k'
+  | tcIsConstraintKind k = Just ConstraintTuple
+  | tcIsLiftedTypeKind k   = Just BoxedTuple
+  | otherwise            = Nothing
+
+tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType
+tc_tuple rn_ty mode tup_sort tys exp_kind
+  = do { arg_kinds <- case tup_sort of
+           BoxedTuple      -> return (nOfThem arity liftedTypeKind)
+           UnboxedTuple    -> mapM (\_ -> newOpenTypeKind) tys
+           ConstraintTuple -> return (nOfThem arity constraintKind)
+       ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds
+       ; finish_tuple rn_ty mode tup_sort tau_tys arg_kinds exp_kind }
+  where
+    arity   = length tys
+
+finish_tuple :: HsType GhcRn
+             -> TcTyMode
+             -> TupleSort
+             -> [TcType]    -- ^ argument types
+             -> [TcKind]    -- ^ of these kinds
+             -> TcKind      -- ^ expected kind of the whole tuple
+             -> TcM TcType
+finish_tuple rn_ty mode tup_sort tau_tys tau_kinds exp_kind
+  = do { traceTc "finish_tuple" (ppr res_kind $$ ppr tau_kinds $$ ppr exp_kind)
+       ; let arg_tys  = case tup_sort of
+                   -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon
+                 UnboxedTuple    -> tau_reps ++ tau_tys
+                 BoxedTuple      -> tau_tys
+                 ConstraintTuple -> tau_tys
+       ; tycon <- case tup_sort of
+           ConstraintTuple
+             | arity > mAX_CTUPLE_SIZE
+                         -> failWith (bigConstraintTuple arity)
+             | otherwise -> tcLookupTyCon (cTupleTyConName arity)
+           BoxedTuple    -> do { let tc = tupleTyCon Boxed arity
+                               ; checkWiredInTyCon tc
+                               ; return tc }
+           UnboxedTuple  -> return (tupleTyCon Unboxed arity)
+       ; checkExpectedKindMode mode (ppr rn_ty) (mkTyConApp tycon arg_tys) res_kind exp_kind }
+  where
+    arity = length tau_tys
+    tau_reps = map kindRep tau_kinds
+    res_kind = case tup_sort of
+                 UnboxedTuple    -> unboxedTupleKind tau_reps
+                 BoxedTuple      -> liftedTypeKind
+                 ConstraintTuple -> constraintKind
+
+bigConstraintTuple :: Arity -> MsgDoc
+bigConstraintTuple arity
+  = hang (text "Constraint tuple arity too large:" <+> int arity
+          <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))
+       2 (text "Instead, use a nested tuple")
+
+---------------------------
+-- | Apply a type of a given kind to a list of arguments. This instantiates
+-- invisible parameters as necessary. Always consumes all the arguments,
+-- using matchExpectedFunKind as necessary.
+-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.-
+-- These kinds should be used to instantiate invisible kind variables;
+-- they come from an enclosing class for an associated type/data family.
+tcInferApps :: TcTyMode
+            -> LHsType GhcRn        -- ^ Function (for printing only)
+            -> TcType               -- ^ Function
+            -> TcKind               -- ^ Function kind (zonked)
+            -> [LHsTypeArg GhcRn]   -- ^ Args
+            -> TcM (TcType, TcKind) -- ^ (f args, args, result kind)
+-- Precondition: tcTypeKind fun_ty = fun_ki
+--    Reason: we will return a type application like (fun_ty arg1 ... argn),
+--            and that type must be well-kinded
+--            See Note [The tcType invariant]
+-- Postcondition: Result kind is zonked.
+tcInferApps mode orig_hs_ty fun_ty fun_ki orig_hs_args
+  = do { traceTc "tcInferApps {" (ppr orig_hs_ty $$ ppr orig_hs_args $$ ppr fun_ki)
+       ; (f_args, res_k) <- go 1 empty_subst fun_ty orig_ki_binders orig_inner_ki orig_hs_args
+       ; traceTc "tcInferApps }" empty
+       ; res_k <- zonkTcType res_k  -- Uphold (IT4) of Note [The tcType invariant]
+       ; return (f_args, res_k) }
+  where
+    empty_subst                      = mkEmptyTCvSubst $ mkInScopeSet $
+                                       tyCoVarsOfType fun_ki
+    (orig_ki_binders, orig_inner_ki) = tcSplitPiTys fun_ki
+
+    go :: Int             -- the # of the next argument
+       -> TCvSubst        -- instantiating substitution
+       -> TcType          -- function applied to some args
+       -> [TyBinder]      -- binders in function kind (both vis. and invis.)
+       -> TcKind          -- function kind body (not a Pi-type)
+       -> [LHsTypeArg GhcRn] -- un-type-checked args
+       -> TcM (TcType, TcKind)  -- same as overall return type
+
+      -- no user-written args left. We're done!
+    go _ subst fun ki_binders inner_ki []
+      = return ( fun
+               , nakedSubstTy subst $ mkPiTys ki_binders inner_ki)
+                 -- nakedSubstTy: see Note [The well-kinded type invariant]
+    go n subst fun all_kindbinder inner_ki (HsArgPar _:args)
+      = go n subst fun all_kindbinder inner_ki args
+      -- The function's kind has a binder. Is it visible or invisible?
+    go n subst fun all_kindbinder@(ki_binder:ki_binders) inner_ki
+       all_args@(arg:args)
+      | Specified <- tyCoBinderArgFlag ki_binder
+      , HsTypeArg _ ki <- arg
+         -- Invisible and specified binder with visible kind argument
+         = do { traceTc "tcInferApps (vis kind app)" (vcat [ ppr ki_binder, ppr ki
+                                                     , ppr (tyBinderType ki_binder)
+                                                     , ppr subst, ppr (tyCoBinderArgFlag ki_binder) ])
+                  ; let exp_kind = nakedSubstTy subst $ tyBinderType ki_binder
+                    -- nakedSubstTy: see Note [The well-kinded type invariant]
+                  ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty ki n) $
+                            unsetWOptM Opt_WarnPartialTypeSignatures $
+                            setXOptM LangExt.PartialTypeSignatures $
+                            -- see Note [Wildcards in visible kind application]
+                            tc_lhs_type (kindLevel mode) ki exp_kind
+                  ; traceTc "tcInferApps (vis kind app)" (ppr exp_kind)
+                  ; let subst' = extendTvSubstBinderAndInScope subst ki_binder arg'
+                  ; go (n+1) subst'
+                       (mkNakedAppTy fun arg')
+                       ki_binders inner_ki args }
+
+      | isInvisibleBinder ki_binder
+          -- Instantiate if not specified or if there is no kind application
+      = do { traceTc "tcInferApps (invis normal app)" (ppr ki_binder $$ ppr subst $$ ppr (tyCoBinderArgFlag ki_binder))
+           ; (subst', arg') <- tcInstTyBinder Nothing subst ki_binder
+           ; go n subst' (mkNakedAppTy fun arg')
+                        ki_binders inner_ki all_args }
+
+      | otherwise -- if binder is visible
+         = case arg of
+             HsValArg ty -- check the next argument
+               -> do { traceTc "tcInferApps (vis normal app)"
+                         (vcat [ ppr ki_binder
+                               , ppr ty
+                               , ppr (tyBinderType ki_binder)
+                               , ppr subst ])
+                     ; let exp_kind = nakedSubstTy subst $ tyBinderType ki_binder
+                     -- nakedSubstTy: see Note [The well-kinded type invariant]
+                     ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty ty n) $
+                               tc_lhs_type mode ty exp_kind
+                     ; traceTc "tcInferApps (vis normal app)" (ppr exp_kind)
+                     ; let subst' = extendTvSubstBinderAndInScope subst ki_binder arg'
+                     ; go (n+1) subst'
+                          (mkNakedAppTy fun arg')
+                          ki_binders inner_ki args }
+            -- error if the argument is a kind application
+             HsTypeArg _ ki -> do { traceTc "tcInferApps (error)"
+                                    (vcat [ ppr ki_binder
+                                          , ppr ki
+                                          , ppr (tyBinderType ki_binder)
+                                          , ppr subst
+                                          , ppr (isInvisibleBinder ki_binder) ])
+                                  ; ty_app_err ki $ nakedSubstTy subst $
+                                                  mkPiTys all_kindbinder inner_ki }
+
+             HsArgPar _ -> panic "tcInferApps"  -- handled in separate clause of "go"
+
+       -- We've run out of known binders in the functions's kind.
+    go n subst fun [] inner_ki all_args@(arg:args)
+      | not (null new_ki_binders)
+         -- But, after substituting, we have more binders.
+      = go n zapped_subst fun new_ki_binders new_inner_ki all_args
+
+      | otherwise
+      = case arg of
+        (HsValArg _)
+         -- Even after substituting, still no binders. Use matchExpectedFunKind
+         -> do { traceTc "tcInferApps (no binder)" (ppr new_inner_ki $$ ppr zapped_subst)
+               ; (co, arg_k, res_k) <- matchExpectedFunKind hs_ty substed_inner_ki
+               ; let new_in_scope = tyCoVarsOfTypes [arg_k, res_k]
+                     subst'       = zapped_subst `extendTCvInScopeSet` new_in_scope
+               ; go n subst'
+                    (fun `mkNakedCastTy` co)  -- See Note [The well-kinded type invariant]
+                    [mkAnonBinder arg_k]
+                    res_k all_args }
+        (HsTypeArg _ ki) -> ty_app_err ki substed_inner_ki
+        (HsArgPar _) -> go n subst fun [] inner_ki args
+      where
+        substed_inner_ki               = substTy subst inner_ki
+        (new_ki_binders, new_inner_ki) = tcSplitPiTys substed_inner_ki
+        zapped_subst                   = zapTCvSubst subst
+        hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args)
+
+    ty_app_err arg ty = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty)
+                           $$ text "to visible kind argument" <+> quotes (ppr arg)
+
+appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn
+appTypeToArg f [] = f
+appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args
+appTypeToArg f (HsTypeArg l arg : args)
+  = appTypeToArg (mkHsAppKindTy l f arg) args
+appTypeToArg f (HsArgPar _ : arg) = appTypeToArg f arg
+
+-- | Applies a type to a list of arguments.
+-- Always consumes all the arguments, using 'matchExpectedFunKind' as
+-- necessary. If you wish to apply a type to a list of HsTypes, this is
+-- your function.
+-- Used for type-checking types only.
+tcTyApps :: TcTyMode
+         -> LHsType GhcRn        -- ^ Function (for printing only)
+         -> TcType               -- ^ Function
+         -> TcKind               -- ^ Function kind (zonked)
+         -> [LHsTypeArg GhcRn]   -- ^ Args
+         -> TcM (TcType, TcKind) -- ^ (f args, result kind)   result kind is zonked
+-- Precondition: see precondition for tcInferApps
+tcTyApps mode orig_hs_ty fun_ty fun_ki args
+  = do { (ty', ki') <- tcInferApps mode orig_hs_ty fun_ty fun_ki args
+       ; return (ty' `mkNakedCastTy` mkNomReflCo ki', ki') }
+          -- The mkNakedCastTy is for (IT3) of Note [The tcType invariant]
+
+tcTyApp :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) -- only HsAppTy or HsAppKindTy
+tcTyApp mode e
+  = do { let (hs_fun_ty, hs_args) = splitHsAppTys e
+       ; (fun_ty, fun_kind) <- tc_infer_lhs_type mode hs_fun_ty
+          -- NB: (IT4) of Note [The tcType invariant] ensures that fun_kind is zonked
+       ; tcTyApps mode hs_fun_ty fun_ty fun_kind hs_args }
+--------------------------
+-- Internally-callable version of checkExpectedKind
+checkExpectedKindMode :: HasDebugCallStack
+                      => TcTyMode
+                      -> SDoc        -- type we're checking
+                      -> TcType      -- type we're checking
+                      -> TcKind      -- kind of that type
+                      -> TcKind      -- expected kind
+                      -> TcM TcType
+checkExpectedKindMode mode = checkExpectedKind (mode_sat mode)
+
+-- | This instantiates invisible arguments for the type being checked if it must
+-- be saturated and is not yet saturated. It then calls and uses the result
+-- from checkExpectedKindX to build the final type
+-- Obeys Note [The tcType invariant]
+checkExpectedKind :: HasDebugCallStack
+                  => RequireSaturation  -- ^ Do we require all type families to be saturated?
+                  -> SDoc           -- ^ type we're checking (for printing)
+                  -> TcType         -- ^ type we're checking
+                  -> TcKind         -- ^ the known kind of that type
+                  -> TcKind         -- ^ the expected kind
+                  -> TcM TcType
+checkExpectedKind sat hs_ty ty act exp
+  = do { (new_ty, new_act) <- case splitTyConApp_maybe ty of
+           Just (tc, args)
+             -- if the family tycon must be saturated and is not yet satured
+             -- If we don't do this, we get #11246
+             | YesSaturation <- sat
+             , not (mightBeUnsaturatedTyCon tc) && length args < tyConArity tc
+             -> do {
+                   -- we need to instantiate all invisible arguments up until saturation
+                   (tc_args, kind) <- tcInstTyBinders (splitPiTysInvisibleN
+                                                        (tyConArity tc - length args)
+                                                        act)
+                   ; let tc_ty = mkTyConApp tc $ args ++ tc_args
+                   ; traceTc "checkExpectedKind:satTyFam" (vcat [ ppr tc <+> dcolon <+> ppr act
+                                                   , ppr kind ])
+                   ; return (tc_ty, kind) }
+           _ -> return (ty, act)
+       ; (new_args, co_k) <- checkExpectedKindX hs_ty new_act exp
+       ; return (new_ty `mkNakedAppTys` new_args `mkNakedCastTy` co_k) }
+
+checkExpectedKindX :: HasDebugCallStack
+                   => SDoc                 -- HsType whose kind we're checking
+                   -> TcKind               -- the known kind of that type, k
+                   -> TcKind               -- the expected kind, exp_kind
+                   -> TcM ([TcType], TcCoercionN)
+    -- (the new args, the coercion)
+-- Instantiate a kind (if necessary) and then call unifyType
+--      (checkExpectedKind ty act_kind exp_kind)
+-- checks that the actual kind act_kind is compatible
+--      with the expected kind exp_kind
+checkExpectedKindX pp_hs_ty act_kind exp_kind
+  = do { -- We need to make sure that both kinds have the same number of implicit
+         -- foralls out front. If the actual kind has more, instantiate accordingly.
+         -- Otherwise, just pass the type & kind through: the errors are caught
+         -- in unifyType.
+         let n_exp_invis_bndrs = invisibleTyBndrCount exp_kind
+             n_act_invis_bndrs = invisibleTyBndrCount act_kind
+             n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs
+       ; (new_args, act_kind') <- tcInstTyBinders (splitPiTysInvisibleN n_to_inst act_kind)
+
+       ; let origin = TypeEqOrigin { uo_actual   = act_kind'
+                                   , uo_expected = exp_kind
+                                   , uo_thing    = Just pp_hs_ty
+                                   , uo_visible  = True } -- the hs_ty is visible
+
+       ; traceTc "checkExpectedKindX" $
+         vcat [ pp_hs_ty
+              , text "act_kind:" <+> ppr act_kind
+              , text "act_kind':" <+> ppr act_kind'
+              , text "exp_kind:" <+> ppr exp_kind ]
+
+       ; if act_kind' `tcEqType` exp_kind
+         then return (new_args, mkTcNomReflCo exp_kind)  -- This is very common
+         else do { co_k <- uType KindLevel origin act_kind' exp_kind
+                 ; traceTc "checkExpectedKind" (vcat [ ppr act_kind
+                                                     , ppr exp_kind
+                                                     , ppr co_k ])
+                      -- See Note [The tcType invariant]
+                ; return (new_args, co_k) } }
+
+---------------------------
+tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]
+tcHsMbContext Nothing    = return []
+tcHsMbContext (Just cxt) = tcHsContext cxt
+
+tcHsContext :: LHsContext GhcRn -> TcM [PredType]
+tcHsContext = tc_hs_context typeLevelMode
+
+tcLHsPredType :: LHsType GhcRn -> TcM PredType
+tcLHsPredType = tc_lhs_pred typeLevelMode
+
+tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType]
+tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt)
+
+tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType
+tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind
+
+---------------------------
+tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind)
+-- See Note [Type checking recursive type and class declarations]
+-- in TcTyClsDecls
+tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon
+  = do { traceTc "lk1" (ppr name)
+       ; thing <- tcLookup name
+       ; case thing of
+           ATyVar _ tv -> -- Important: zonk before returning
+                          -- We may have the application ((a::kappa) b)
+                          -- where kappa is already unified to (k1 -> k2)
+                          -- Then we want to see that arrow.  Best done
+                          -- here because we are also maintaining
+                          -- Note [The tcType invariant], so we don't just
+                          -- want to zonk the kind, leaving the TyVar
+                          -- un-zonked  (Trac #14873)
+                          do { ty <- zonkTcTyVar tv
+                             ; return (ty, tcTypeKind ty) }
+
+           ATcTyCon tc_tc
+             -> do { -- See Note [GADT kind self-reference]
+                     unless (isTypeLevel (mode_level mode))
+                            (promotionErr name TyConPE)
+                   ; check_tc tc_tc
+                   ; tc_kind <- zonkTcType (tyConKind tc_tc)
+                        -- (IT6) of Note [The tcType invariant]
+                   ; return (mkTyConTy tc_tc `mkNakedCastTy` mkNomReflCo tc_kind, tc_kind) }
+                        -- the mkNakedCastTy ensures (IT5) of Note [The tcType invariant]
+
+           AGlobal (ATyCon tc)
+             -> do { check_tc tc
+                   ; return (mkTyConTy tc, tyConKind tc) }
+
+           AGlobal (AConLike (RealDataCon dc))
+             -> do { data_kinds <- xoptM LangExt.DataKinds
+                   ; unless (data_kinds || specialPromotedDc dc) $
+                       promotionErr name NoDataKindsDC
+                   ; when (isFamInstTyCon (dataConTyCon dc)) $
+                       -- see Trac #15245
+                       promotionErr name FamDataConPE
+                   ; let (_, _, _, theta, _, _) = dataConFullSig dc
+                   ; case dc_theta_illegal_constraint theta of
+                       Just pred -> promotionErr name $
+                                    ConstrainedDataConPE pred
+                       Nothing   -> pure ()
+                   ; let tc = promoteDataCon dc
+                   ; return (mkTyConApp tc [], tyConKind tc) }
+
+           APromotionErr err -> promotionErr name err
+
+           _  -> wrongThingErr "type" thing name }
+  where
+    check_tc :: TyCon -> TcM ()
+    check_tc tc = do { data_kinds   <- xoptM LangExt.DataKinds
+                     ; unless (isTypeLevel (mode_level mode) ||
+                               data_kinds ||
+                               isKindTyCon tc) $
+                       promotionErr name NoDataKindsTC }
+
+    -- We cannot promote a data constructor with a context that contains
+    -- constraints other than equalities, so error if we find one.
+    -- See Note [Constraints handled in types] in Inst.
+    dc_theta_illegal_constraint :: ThetaType -> Maybe PredType
+    dc_theta_illegal_constraint = find go
+      where
+        go :: PredType -> Bool
+        go pred | Just tc <- tyConAppTyCon_maybe pred
+                = not $  tc `hasKey` eqTyConKey
+                      || tc `hasKey` heqTyConKey
+                | otherwise = True
+
+{-
+Note [GADT kind self-reference]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A promoted type cannot be used in the body of that type's declaration.
+Trac #11554 shows this example, which made GHC loop:
+
+  import Data.Kind
+  data P (x :: k) = Q
+  data A :: Type where
+    B :: forall (a :: A). P a -> A
+
+In order to check the constructor B, we need to have the promoted type A, but in
+order to get that promoted type, B must first be checked. To prevent looping, a
+TyConPE promotion error is given when tcTyVar checks an ATcTyCon in kind mode.
+Any ATcTyCon is a TyCon being defined in the current recursive group (see data
+type decl for TcTyThing), and all such TyCons are illegal in kinds.
+
+Trac #11962 proposes checking the head of a data declaration separately from
+its constructors. This would allow the example above to pass.
+
+Note [Body kind of a HsForAllTy]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The body of a forall is usually a type, but in principle
+there's no reason to prohibit *unlifted* types.
+In fact, GHC can itself construct a function with an
+unboxed tuple inside a for-all (via CPR analysis; see
+typecheck/should_compile/tc170).
+
+Moreover in instance heads we get forall-types with
+kind Constraint.
+
+It's tempting to check that the body kind is either * or #. But this is
+wrong. For example:
+
+  class C a b
+  newtype N = Mk Foo deriving (C a)
+
+We're doing newtype-deriving for C. But notice how `a` isn't in scope in
+the predicate `C a`. So we quantify, yielding `forall a. C a` even though
+`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but
+convenient. Bottom line: don't check for * or # here.
+
+Note [Body kind of a HsQualTy]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If ctxt is non-empty, the HsQualTy really is a /function/, so the
+kind of the result really is '*', and in that case the kind of the
+body-type can be lifted or unlifted.
+
+However, consider
+    instance Eq a => Eq [a] where ...
+or
+    f :: (Eq a => Eq [a]) => blah
+Here both body-kind of the HsQualTy is Constraint rather than *.
+Rather crudely we tell the difference by looking at exp_kind. It's
+very convenient to typecheck instance types like any other HsSigType.
+
+Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's
+better to reject in checkValidType.  If we say that the body kind
+should be '*' we risk getting TWO error messages, one saying that Eq
+[a] doens't have kind '*', and one saying that we need a Constraint to
+the left of the outer (=>).
+
+How do we figure out the right body kind?  Well, it's a bit of a
+kludge: I just look at the expected kind.  If it's Constraint, we
+must be in this instance situation context. It's a kludge because it
+wouldn't work if any unification was involved to compute that result
+kind -- but it isn't.  (The true way might be to use the 'mode'
+parameter, but that seemed like a sledgehammer to crack a nut.)
+
+Note [Inferring tuple kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,
+we try to figure out whether it's a tuple of kind * or Constraint.
+  Step 1: look at the expected kind
+  Step 2: infer argument kinds
+
+If after Step 2 it's not clear from the arguments that it's
+Constraint, then it must be *.  Once having decided that we re-check
+the Check the arguments again to give good error messages
+in eg. `(Maybe, Maybe)`
+
+Note that we will still fail to infer the correct kind in this case:
+
+  type T a = ((a,a), D a)
+  type family D :: Constraint -> Constraint
+
+While kind checking T, we do not yet know the kind of D, so we will default the
+kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.
+
+Note [Desugaring types]
+~~~~~~~~~~~~~~~~~~~~~~~
+The type desugarer is phase 2 of dealing with HsTypes.  Specifically:
+
+  * It transforms from HsType to Type
+
+  * It zonks any kinds.  The returned type should have no mutable kind
+    or type variables (hence returning Type not TcType):
+      - any unconstrained kind variables are defaulted to (Any *) just
+        as in TcHsSyn.
+      - there are no mutable type variables because we are
+        kind-checking a type
+    Reason: the returned type may be put in a TyCon or DataCon where
+    it will never subsequently be zonked.
+
+You might worry about nested scopes:
+        ..a:kappa in scope..
+            let f :: forall b. T '[a,b] -> Int
+In this case, f's type could have a mutable kind variable kappa in it;
+and we might then default it to (Any *) when dealing with f's type
+signature.  But we don't expect this to happen because we can't get a
+lexically scoped type variable with a mutable kind variable in it.  A
+delicate point, this.  If it becomes an issue we might need to
+distinguish top-level from nested uses.
+
+Moreover
+  * it cannot fail,
+  * it does no unifications
+  * it does no validity checking, except for structural matters, such as
+        (a) spurious ! annotations.
+        (b) a class used as a type
+
+Note [Kind of a type splice]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider these terms, each with TH type splice inside:
+     [| e1 :: Maybe $(..blah..) |]
+     [| e2 :: $(..blah..) |]
+When kind-checking the type signature, we'll kind-check the splice
+$(..blah..); we want to give it a kind that can fit in any context,
+as if $(..blah..) :: forall k. k.
+
+In the e1 example, the context of the splice fixes kappa to *.  But
+in the e2 example, we'll desugar the type, zonking the kind unification
+variables as we go.  When we encounter the unconstrained kappa, we
+want to default it to '*', not to (Any *).
+
+Help functions for type applications
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-}
+
+addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a
+        -- Wrap a context around only if we want to show that contexts.
+        -- Omit invisible ones and ones user's won't grok
+addTypeCtxt (L _ (HsWildCardTy _)) thing = thing   -- "In the type '_'" just isn't helpful.
+addTypeCtxt (L _ ty) thing
+  = addErrCtxt doc thing
+  where
+    doc = text "In the type" <+> quotes (ppr ty)
+
+{-
+************************************************************************
+*                                                                      *
+                Type-variable binders
+%*                                                                      *
+%************************************************************************
+
+Note [Dependent LHsQTyVars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We track (in the renamer) which explicitly bound variables in a
+LHsQTyVars are manifestly dependent; only precisely these variables
+may be used within the LHsQTyVars. We must do this so that kcLHsQTyVars
+can produce the right TyConBinders, and tell Anon vs. Required.
+
+Example   data T k1 (a:k1) (b:k2) c
+               = MkT (Proxy a) (Proxy b) (Proxy c)
+
+Here
+  (a:k1),(b:k2),(c:k3)
+       are Anon     (explicitly specified as a binder, not used
+                     in the kind of any other binder
+  k1   is Required  (explicitly specifed as a binder, but used
+                     in the kind of another binder i.e. dependently)
+  k2   is Specified (not explicitly bound, but used in the kind
+                     of another binder)
+  k3   in Inferred  (not lexically in scope at all, but inferred
+                     by kind inference)
+and
+  T :: forall {k3} k1. forall k3 -> k1 -> k2 -> k3 -> *
+
+See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility]
+in TyCoRep.
+
+kcLHsQTyVars uses the hsq_dependent field to decide whether
+k1, a, b, c should be Required or Anon.
+
+Earlier, thought it would work simply to do a free-variable check
+during kcLHsQTyVars, but this is bogus, because there may be
+unsolved equalities about. And we don't want to eagerly solve the
+equalities, because we may get further information after
+kcLHsQTyVars is called.  (Recall that kcLHsQTyVars is called
+only from getInitialKind.)
+This is what implements the rule that all variables intended to be
+dependent must be manifestly so.
+
+Sidenote: It's quite possible that later, we'll consider (t -> s)
+as a degenerate case of some (pi (x :: t) -> s) and then this will
+all get more permissive.
+
+Note [Keeping scoped variables in order: Explicit]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the user writes `forall a b c. blah`, we bring a, b, and c into
+scope and then check blah. In the process of checking blah, we might
+learn the kinds of a, b, and c, and these kinds might indicate that
+b depends on c, and thus that we should reject the user-written type.
+
+One approach to doing this would be to bring each of a, b, and c into
+scope, one at a time, creating an implication constraint and
+bumping the TcLevel for each one. This would work, because the kind
+of, say, b would be untouchable when c is in scope (and the constraint
+couldn't float out because c blocks it). However, it leads to terrible
+error messages, complaining about skolem escape. While it is indeed
+a problem of skolem escape, we can do better.
+
+Instead, our approach is to bring the block of variables into scope
+all at once, creating one implication constraint for the lot. The
+user-written variables are skolems in the implication constraint. In
+TcSimplify.setImplicationStatus, we check to make sure that the ordering
+is correct, choosing ImplicationStatus IC_BadTelescope if they aren't.
+Then, in TcErrors, we report if there is a bad telescope. This way,
+we can report a suggested ordering to the user if there is a problem.
+
+Note [Keeping scoped variables in order: Implicit]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When the user implicitly quantifies over variables (say, in a type
+signature), we need to come up with some ordering on these variables.
+This is done by bumping the TcLevel, bringing the tyvars into scope,
+and then type-checking the thing_inside. The constraints are all
+wrapped in an implication, which is then solved. Finally, we can
+zonk all the binders and then order them with scopedSort.
+
+It's critical to solve before zonking and ordering in order to uncover
+any unifications. You might worry that this eager solving could cause
+trouble elsewhere. I don't think it will. Because it will solve only
+in an increased TcLevel, it can't unify anything that was mentioned
+elsewhere. Additionally, we require that the order of implicitly
+quantified variables is manifest by the scope of these variables, so
+we're not going to learn more information later that will help order
+these variables.
+
+Note [Recipe for checking a signature]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Checking a user-written signature requires several steps:
+
+ 1. Generate constraints.
+ 2. Solve constraints.
+ 3. Zonk.
+ 4. Promote tyvars and/or kind-generalize.
+ 5. Zonk.
+ 6. Check validity.
+
+There may be some surprises in here:
+
+Step 2 is necessary for two reasons: most signatures also bring
+implicitly quantified variables into scope, and solving is necessary
+to get these in the right order (see Note [Keeping scoped variables in
+order: Implicit]). Additionally, solving is necessary in order to
+kind-generalize correctly.
+
+In Step 4, we have to deal with the fact that metatyvars generated
+in the type may have a bumped TcLevel, because explicit foralls
+raise the TcLevel. To avoid these variables from ever being visible
+in the surrounding context, we must obey the following dictum:
+
+  Every metavariable in a type must either be
+    (A) promoted
+    (B) generalized, or
+    (C) zapped to Any
+
+If a variable is generalized, then it becomes a skolem and no longer
+has a proper TcLevel. (I'm ignoring the TcLevel on a skolem here, as
+it's not really in play here.) On the other hand, if it is not
+generalized (because we're not generalizing the construct -- e.g., pattern
+sig -- or because the metavars are constrained -- see kindGeneralizeLocal)
+we need to promote to maintain (MetaTvInv) of Note [TcLevel and untouchable type variables]
+in TcType.
+
+For more about (C), see Note [Naughty quantification candidates] in TcMType.
+
+After promoting/generalizing, we need to zonk *again* because both
+promoting and generalizing fill in metavariables.
+
+To avoid the double-zonk, we do two things:
+ 1. When we're not generalizing:
+    zonkPromoteType and friends zonk and promote at the same time.
+    Accordingly, the function does steps 3-5 all at once, preventing
+    the need for multiple traversals.
+
+ 2. When we are generalizing:
+    kindGeneralize does not require a zonked type -- it zonks as it
+    gathers free variables. So this way effectively sidesteps step 3.
+-}
+
+tcWildCardBinders :: [Name]
+                  -> ([(Name, TcTyVar)] -> TcM a)
+                  -> TcM a
+tcWildCardBinders wc_names thing_inside
+  = do { wcs <- mapM (const newWildTyVar) wc_names
+       ; let wc_prs = wc_names `zip` wcs
+       ; tcExtendNameTyVarEnv wc_prs $
+         thing_inside wc_prs }
+
+newWildTyVar :: TcM TcTyVar
+-- ^ New unification variable for a wildcard
+newWildTyVar
+  = do { kind <- newMetaKindVar
+       ; uniq <- newUnique
+       ; details <- newMetaDetails TauTv
+       ; let name = mkSysTvName uniq (fsLit "_")
+             tyvar = (mkTcTyVar name kind details)
+       ; traceTc "newWildTyVar" (ppr tyvar)
+       ; return tyvar }
+
+{- *********************************************************************
+*                                                                      *
+             Kind inference for type declarations
+*                                                                      *
+********************************************************************* -}
+
+{- Note [The initial kind of a type constructor]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+kcLHsQTyVars is responsible for getting the initial kind of
+a type constructor.
+
+It has two cases:
+
+ * The TyCon has a CUSK.  In that case, find the full, final,
+   poly-kinded kind of the TyCon.  It's very like a term-level
+   binding where we have a complete type signature for the
+   function.
+
+ * It does not have a CUSK.  Find a monomorphic kind, with
+   unification variables in it; they will be generalised later.
+   It's very like a term-level binding where we do not have
+   a type signature (or, more accurately, where we have a
+   partial type signature), so we infer the type and generalise.
+-}
+
+
+------------------------------
+-- | Kind-check a 'LHsQTyVars'. If the decl under consideration has a complete,
+-- user-supplied kind signature (CUSK), generalise the result.
+-- Used in 'getInitialKind' (for tycon kinds and other kinds)
+-- and in kind-checking (but not for tycon kinds, which are checked with
+-- tcTyClDecls). See Note [CUSKs: complete user-supplied kind signatures]
+-- in HsDecls.
+--
+-- This function does not do telescope checking.
+kcLHsQTyVars :: Name              -- ^ of the thing being checked
+             -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
+             -> Bool              -- ^ True <=> the decl being checked has a CUSK
+             -> LHsQTyVars GhcRn
+             -> TcM Kind          -- ^ The result kind
+             -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon
+kcLHsQTyVars name flav cusk tvs thing_inside
+  | cusk      = kcLHsQTyVars_Cusk    name flav tvs thing_inside
+  | otherwise = kcLHsQTyVars_NonCusk name flav tvs thing_inside
+
+
+kcLHsQTyVars_Cusk, kcLHsQTyVars_NonCusk
+    :: Name              -- ^ of the thing being checked
+    -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked
+    -> LHsQTyVars GhcRn
+    -> TcM Kind          -- ^ The result kind
+    -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon
+
+------------------------------
+kcLHsQTyVars_Cusk name flav
+  user_tyvars@(HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kv_ns
+                                           , hsq_dependent = dep_names }
+                      , hsq_explicit = hs_tvs }) thing_inside
+  -- CUSK case
+  -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls
+  = addTyConFlavCtxt name flav $
+    do { (scoped_kvs, (tc_tvs, res_kind))
+           <- pushTcLevelM_                               $
+              solveEqualities                             $
+              bindImplicitTKBndrs_Q_Skol kv_ns            $
+              bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $
+              thing_inside
+
+           -- Now, because we're in a CUSK,
+           -- we quantify over the mentioned kind vars
+       ; let spec_req_tkvs = scoped_kvs ++ tc_tvs
+             all_kinds     = res_kind : map tyVarKind spec_req_tkvs
+
+       ; candidates <- candidateQTyVarsOfKinds all_kinds
+             -- 'candidates' are all the variables that we are going to
+             -- skolemise and then quantify over.  We do not include spec_req_tvs
+             -- because they are /already/ skolems
+
+       ; let inf_candidates = candidates `delCandidates` spec_req_tkvs
+
+       ; inferred <- quantifyTyVars emptyVarSet inf_candidates
+                     -- NB: 'inferred' comes back sorted in dependency order
+
+       ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs
+       ; tc_tvs     <- mapM zonkTyCoVarKind tc_tvs
+       ; res_kind   <- zonkTcType           res_kind
+
+       ; let mentioned_kv_set = candidateKindVars candidates
+             specified        = scopedSort scoped_kvs
+                                -- NB: maintain the L-R order of scoped_kvs
+
+             final_tc_binders =  mkNamedTyConBinders Inferred  inferred
+                              ++ mkNamedTyConBinders Specified specified
+                              ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs
+
+             all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)
+             tycon = mkTcTyCon name (ppr user_tyvars)
+                               final_tc_binders
+                               res_kind
+                               all_tv_prs
+                               True {- it is generalised -} flav
+         -- If the ordering from
+         -- Note [Required, Specified, and Inferred for types] in TcTyClsDecls
+         -- doesn't work, we catch it here, before an error cascade
+       ; checkValidTelescope tycon
+
+          -- If any of the specified tyvars aren't actually mentioned in a binder's
+          -- kind (or the return kind), then we're in the CUSK case from
+          -- Note [Free-floating kind vars]
+       ; let unmentioned_kvs   = filterOut (`elemVarSet` mentioned_kv_set) specified
+       ; reportFloatingKvs name flav (map binderVar final_tc_binders) unmentioned_kvs
+
+
+       ; traceTc "kcLHsQTyVars: cusk" $
+         vcat [ text "name" <+> ppr name
+              , text "kv_ns" <+> ppr kv_ns
+              , text "hs_tvs" <+> ppr hs_tvs
+              , text "dep_names" <+> ppr dep_names
+              , text "scoped_kvs" <+> ppr scoped_kvs
+              , text "tc_tvs" <+> ppr tc_tvs
+              , text "res_kind" <+> ppr res_kind
+              , text "candidates" <+> ppr candidates
+              , text "inferred" <+> ppr inferred
+              , text "specified" <+> ppr specified
+              , text "final_tc_binders" <+> ppr final_tc_binders
+              , text "mkTyConKind final_tc_bndrs res_kind"
+                <+> ppr (mkTyConKind final_tc_binders res_kind)
+              , text "all_tv_prs" <+> ppr all_tv_prs ]
+
+       ; return tycon }
+  where
+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind
+              | otherwise            = AnyKind
+
+kcLHsQTyVars_Cusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars"
+
+------------------------------
+kcLHsQTyVars_NonCusk name flav
+  user_tyvars@(HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = kv_ns
+                                           , hsq_dependent = dep_names }
+                      , hsq_explicit = hs_tvs }) thing_inside
+  -- Non_CUSK case
+  -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls
+  = do { (scoped_kvs, (tc_tvs, res_kind))
+           -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?
+           -- See Note [Inferring kinds for type declarations] in TcTyClsDecls
+           <- bindImplicitTKBndrs_Q_Tv kv_ns            $
+              bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $
+              thing_inside
+              -- Why "_Tv" not "_Skol"? See third wrinkle in
+              -- Note [Inferring kinds for type declarations] in TcTyClsDecls,
+
+       ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they
+               -- might unify with kind vars in other types in a mutually
+               -- recursive group.
+               -- See Note [Inferring kinds for type declarations] in TcTyClsDecls
+             tc_binders = zipWith mk_tc_binder hs_tvs tc_tvs
+               -- Also, note that tc_binders has the tyvars from only the
+               -- user-written tyvarbinders. See S1 in Note [How TcTyCons work]
+               -- in TcTyClsDecls
+             tycon = mkTcTyCon name (ppr user_tyvars) tc_binders res_kind
+                               (mkTyVarNamePairs (scoped_kvs ++ tc_tvs))
+                               False -- not yet generalised
+                               flav
+
+       ; traceTc "kcLHsQTyVars: not-cusk" $
+         vcat [ ppr name, ppr kv_ns, ppr hs_tvs, ppr dep_names
+              , ppr scoped_kvs
+              , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ]
+       ; return tycon }
+  where
+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind
+              | otherwise            = AnyKind
+
+    mk_tc_binder :: LHsTyVarBndr GhcRn -> TyVar -> TyConBinder
+    -- See Note [Dependent LHsQTyVars]
+    mk_tc_binder hs_tv tv
+       | hsLTyVarName hs_tv `elemNameSet` dep_names
+       = mkNamedTyConBinder Required tv
+       | otherwise
+       = mkAnonTyConBinder tv
+
+kcLHsQTyVars_NonCusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars"
+
+
+{- Note [Kind-checking tyvar binders for associated types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When kind-checking the type-variable binders for associated
+   data/newtype decls
+   family decls
+we behave specially for type variables that are already in scope;
+that is, bound by the enclosing class decl.  This is done in
+kcLHsQTyVarBndrs:
+  * The use of tcImplicitQTKBndrs
+  * The tcLookupLocal_maybe code in kc_hs_tv
+
+See Note [Associated type tyvar names] in Class and
+    Note [TyVar binders for associated decls] in HsDecls
+
+We must do the same for family instance decls, where the in-scope
+variables may be bound by the enclosing class instance decl.
+Hence the use of tcImplicitQTKBndrs in tcFamTyPatsAndGen.
+
+Note [Kind variable ordering for associated types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What should be the kind of `T` in the following example? (#15591)
+
+  class C (a :: Type) where
+    type T (x :: f a)
+
+As per Note [Ordering of implicit variables] in RnTypes, we want to quantify
+the kind variables in left-to-right order of first occurrence in order to
+support visible kind application. But we cannot perform this analysis on just
+T alone, since its variable `a` actually occurs /before/ `f` if you consider
+the fact that `a` was previously bound by the parent class `C`. That is to say,
+the kind of `T` should end up being:
+
+  T :: forall a f. f a -> Type
+
+(It wouldn't necessarily be /wrong/ if the kind ended up being, say,
+forall f a. f a -> Type, but that would not be as predictable for users of
+visible kind application.)
+
+In contrast, if `T` were redefined to be a top-level type family, like `T2`
+below:
+
+  type family T2 (x :: f (a :: Type))
+
+Then `a` first appears /after/ `f`, so the kind of `T2` should be:
+
+  T2 :: forall f a. f a -> Type
+
+In order to make this distinction, we need to know (in kcLHsQTyVars) which
+type variables have been bound by the parent class (if there is one). With
+the class-bound variables in hand, we can ensure that we always quantify
+these first.
+-}
+
+
+{- *********************************************************************
+*                                                                      *
+             Expected kinds
+*                                                                      *
+********************************************************************* -}
+
+-- | Describes the kind expected in a certain context.
+data ContextKind = TheKind Kind   -- ^ a specific kind
+                 | AnyKind        -- ^ any kind will do
+                 | OpenKind       -- ^ something of the form @TYPE _@
+
+-----------------------
+newExpectedKind :: ContextKind -> TcM Kind
+newExpectedKind (TheKind k) = return k
+newExpectedKind AnyKind     = newMetaKindVar
+newExpectedKind OpenKind    = newOpenTypeKind
+
+-----------------------
+expectedKindInCtxt :: UserTypeCtxt -> ContextKind
+-- Depending on the context, we might accept any kind (for instance, in a TH
+-- splice), or only certain kinds (like in type signatures).
+expectedKindInCtxt (TySynCtxt _)   = AnyKind
+expectedKindInCtxt ThBrackCtxt     = AnyKind
+expectedKindInCtxt (GhciCtxt {})   = AnyKind
+-- The types in a 'default' decl can have varying kinds
+-- See Note [Extended defaults]" in TcEnv
+expectedKindInCtxt DefaultDeclCtxt     = AnyKind
+expectedKindInCtxt TypeAppCtxt         = AnyKind
+expectedKindInCtxt (ForSigCtxt _)      = TheKind liftedTypeKind
+expectedKindInCtxt (InstDeclCtxt {})   = TheKind constraintKind
+expectedKindInCtxt SpecInstCtxt        = TheKind constraintKind
+expectedKindInCtxt _                   = OpenKind
+
+
+{- *********************************************************************
+*                                                                      *
+             Bringing type variables into scope
+*                                                                      *
+********************************************************************* -}
+
+--------------------------------------
+-- Implicit binders
+--------------------------------------
+
+bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv,
+  bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv
+  :: [Name]
+  -> TcM a
+  -> TcM ([TcTyVar], a)
+bindImplicitTKBndrs_Skol   = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar
+bindImplicitTKBndrs_Tv     = bindImplicitTKBndrsX newFlexiKindedTyVarTyVar
+bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedSkolemTyVar)
+bindImplicitTKBndrs_Q_Tv   = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedTyVarTyVar)
+
+bindImplicitTKBndrsX :: (Name -> TcM TcTyVar) -- new_tv function
+                    -> [Name]
+                    -> TcM a
+                    -> TcM ([TcTyVar], a)   -- these tyvars are dependency-ordered
+-- * Guarantees to call solveLocalEqualities to unify
+--   all constraints from thing_inside.
+--
+-- * Returned TcTyVars have the supplied HsTyVarBndrs,
+--   but may be in different order to the original [Name]
+--   (because of sorting to respect dependency)
+--
+-- * Returned TcTyVars have zonked kinds
+--   See Note [Keeping scoped variables in order: Implicit]
+bindImplicitTKBndrsX new_tv tv_names thing_inside
+  = do { tkvs <- mapM new_tv tv_names
+       ; result <- tcExtendTyVarEnv tkvs thing_inside
+       ; traceTc "bindImplicitTKBndrs" (ppr tv_names $$ ppr tkvs)
+       ; return (tkvs, result) }
+
+newImplicitTyVarQ :: (Name -> TcM TcTyVar) ->  Name -> TcM TcTyVar
+-- Behave like new_tv, except that if the tyvar is in scope, use it
+newImplicitTyVarQ new_tv name
+  = do { mb_tv <- tcLookupLcl_maybe name
+       ; case mb_tv of
+           Just (ATyVar _ tv) -> return tv
+           _ -> new_tv name }
+
+newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar
+newFlexiKindedTyVar new_tv name
+  = do { kind <- newMetaKindVar
+       ; new_tv name kind }
+
+newFlexiKindedSkolemTyVar :: Name -> TcM TyVar
+newFlexiKindedSkolemTyVar = newFlexiKindedTyVar newSkolemTyVar
+
+newFlexiKindedTyVarTyVar :: Name -> TcM TyVar
+newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar
+
+--------------------------------------
+-- Explicit binders
+--------------------------------------
+
+bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv
+    :: [LHsTyVarBndr GhcRn]
+    -> TcM a
+    -> TcM ([TcTyVar], a)
+
+bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr newSkolemTyVar)
+bindExplicitTKBndrs_Tv   = bindExplicitTKBndrsX (tcHsTyVarBndr newTyVarTyVar)
+
+bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv
+    :: ContextKind
+    -> [LHsTyVarBndr GhcRn]
+    -> TcM a
+    -> TcM ([TcTyVar], a)
+
+bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar)
+bindExplicitTKBndrs_Q_Tv   ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar)
+
+-- | Used during the "kind-checking" pass in TcTyClsDecls only,
+-- and even then only for data-con declarations.
+bindExplicitTKBndrsX
+    :: (HsTyVarBndr GhcRn -> TcM TcTyVar)
+    -> [LHsTyVarBndr GhcRn]
+    -> TcM a
+    -> TcM ([TcTyVar], a)
+bindExplicitTKBndrsX tc_tv hs_tvs thing_inside
+  = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs)
+       ; go hs_tvs }
+  where
+    go [] = do { res <- thing_inside
+               ; return ([], res) }
+    go (L _ hs_tv : hs_tvs)
+       = do { tv <- tc_tv hs_tv
+            ; (tvs, res) <- tcExtendTyVarEnv [tv] (go hs_tvs)
+            ; return (tv:tvs, res) }
+
+-----------------
+tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar)
+              -> HsTyVarBndr GhcRn -> TcM TcTyVar
+-- Returned TcTyVar has the same name; no cloning
+tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm))
+  = do { kind <- newMetaKindVar
+       ; new_tv tv_nm kind }
+tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind)
+  = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind
+       ; new_tv tv_nm kind }
+tcHsTyVarBndr _ (XTyVarBndr _) = panic "tcHsTyVarBndr"
+
+-----------------
+tcHsQTyVarBndr :: ContextKind
+               -> (Name -> Kind -> TcM TyVar)
+               -> HsTyVarBndr GhcRn -> TcM TcTyVar
+-- Just like tcHsTyVarBndr, but also
+--   - uses the in-scope TyVar from class, if it exists
+--   - takes a ContextKind to use for the no-sig case
+tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ (L _ tv_nm))
+  = do { mb_tv <- tcLookupLcl_maybe tv_nm
+       ; case mb_tv of
+           Just (ATyVar _ tv) -> return tv
+           _ -> do { kind <- newExpectedKind ctxt_kind
+                   ; new_tv tv_nm kind } }
+
+tcHsQTyVarBndr _ new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind)
+  = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind
+       ; mb_tv <- tcLookupLcl_maybe tv_nm
+       ; case mb_tv of
+           Just (ATyVar _ tv)
+             -> do { discardResult $ unifyKind (Just hs_tv)
+                                        kind (tyVarKind tv)
+                       -- This unify rejects:
+                       --    class C (m :: * -> *) where
+                       --      type F (m :: *) = ...
+                   ; return tv }
+
+           _ -> new_tv tv_nm kind }
+  where
+    hs_tv = HsTyVar noExt NotPromoted (noLoc tv_nm)
+            -- Used for error messages only
+
+tcHsQTyVarBndr _ _ (XTyVarBndr _) = panic "tcHsTyVarBndr"
+
+
+--------------------------------------
+-- Binding type/class variables in the
+-- kind-checking and typechecking phases
+--------------------------------------
+
+bindTyClTyVars :: Name
+               -> ([TyConBinder] -> Kind -> TcM a) -> TcM a
+-- ^ Used for the type variables of a type or class decl
+-- in the "kind checking" and "type checking" pass,
+-- but not in the initial-kind run.
+bindTyClTyVars tycon_name thing_inside
+  = do { tycon <- kcLookupTcTyCon tycon_name
+       ; let scoped_prs = tcTyConScopedTyVars tycon
+             res_kind   = tyConResKind tycon
+             binders    = tyConBinders tycon
+       ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders)
+       ; tcExtendNameTyVarEnv scoped_prs $
+         thing_inside binders res_kind }
+
+-- getInitialKind has made a suitably-shaped kind for the type or class
+-- Look it up in the local environment. This is used only for tycons
+-- that we're currently type-checking, so we're sure to find a TcTyCon.
+kcLookupTcTyCon :: Name -> TcM TcTyCon
+kcLookupTcTyCon nm
+  = do { tc_ty_thing <- tcLookup nm
+       ; return $ case tc_ty_thing of
+           ATcTyCon tc -> tc
+           _           -> pprPanic "kcLookupTcTyCon" (ppr tc_ty_thing) }
+
+
+{- *********************************************************************
+*                                                                      *
+             Kind generalisation
+*                                                                      *
+********************************************************************* -}
+
+zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]
+zonkAndScopedSort spec_tkvs
+  = do { spec_tkvs <- mapM zonkTcTyCoVarBndr spec_tkvs
+          -- Use zonkTcTyCoVarBndr because a skol_tv might be a TyVarTv
+
+       -- Do a stable topological sort, following
+       -- Note [Ordering of implicit variables] in RnTypes
+       ; return (scopedSort spec_tkvs) }
+
+kindGeneralize :: TcType -> TcM [KindVar]
+-- Quantify the free kind variables of a kind or type
+-- In the latter case the type is closed, so it has no free
+-- type variables.  So in both cases, all the free vars are kind vars
+-- Input needn't be zonked.
+-- NB: You must call solveEqualities or solveLocalEqualities before
+-- kind generalization
+--
+-- NB: this function is just a specialised version of
+--        kindGeneralizeLocal emptyWC kind_or_type
+--
+kindGeneralize kind_or_type
+  = do { kt <- zonkTcType kind_or_type
+       ; traceTc "kindGeneralise1" (ppr kt)
+       ; dvs <- candidateQTyVarsOfKind kind_or_type
+       ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked
+       ; traceTc "kindGeneralize" (vcat [ ppr kind_or_type
+                                        , ppr dvs ])
+       ; quantifyTyVars gbl_tvs dvs }
+
+-- | This variant of 'kindGeneralize' refuses to generalize over any
+-- variables free in the given WantedConstraints. Instead, it promotes
+-- these variables into an outer TcLevel. See also
+-- Note [Promoting unification variables] in TcSimplify
+kindGeneralizeLocal :: WantedConstraints -> TcType -> TcM [KindVar]
+kindGeneralizeLocal wanted kind_or_type
+  = do {
+       -- This bit is very much like decideMonoTyVars in TcSimplify,
+       -- but constraints are so much simpler in kinds, it is much
+       -- easier here. (In particular, we never quantify over a
+       -- constraint in a type.)
+       ; constrained <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)
+       ; (_, constrained) <- promoteTyVarSet constrained
+
+       ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked
+       ; let mono_tvs = gbl_tvs `unionVarSet` constrained
+
+         -- use the "Kind" variant here, as any types we see
+         -- here will already have all type variables quantified;
+         -- thus, every free variable is really a kv, never a tv.
+       ; dvs <- candidateQTyVarsOfKind kind_or_type
+
+       ; traceTc "kindGeneralizeLocal" $
+         vcat [ text "Wanted:" <+> ppr wanted
+              , text "Kind or type:" <+> ppr kind_or_type
+              , text "tcvs of wanted:" <+> pprTyVars (nonDetEltsUniqSet (tyCoVarsOfWC wanted))
+              , text "constrained:" <+> pprTyVars (nonDetEltsUniqSet constrained)
+              , text "mono_tvs:" <+> pprTyVars (nonDetEltsUniqSet mono_tvs)
+              , text "dvs:" <+> ppr dvs ]
+
+       ; quantifyTyVars mono_tvs dvs }
+
+{- Note [Levels and generalisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f x = e
+with no type signature. We are currently at level i.
+We must
+  * Push the level to level (i+1)
+  * Allocate a fresh alpha[i+1] for the result type
+  * Check that e :: alpha[i+1], gathering constraint WC
+  * Solve WC as far as possible
+  * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i]
+  * Find the free variables with level > i, in this case gamma[i]
+  * Skolemise those free variables and quantify over them, giving
+       f :: forall g. beta[i-1] -> g
+  * Emit the residiual constraint wrapped in an implication for g,
+    thus   forall g. WC
+
+All of this happens for types too.  Consider
+  f :: Int -> (forall a. Proxy a -> Int)
+
+Note [Kind generalisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do kind generalisation only at the outer level of a type signature.
+For example, consider
+  T :: forall k. k -> *
+  f :: (forall a. T a -> Int) -> Int
+When kind-checking f's type signature we generalise the kind at
+the outermost level, thus:
+  f1 :: forall k. (forall (a:k). T k a -> Int) -> Int  -- YES!
+and *not* at the inner forall:
+  f2 :: (forall k. forall (a:k). T k a -> Int) -> Int  -- NO!
+Reason: same as for HM inference on value level declarations,
+we want to infer the most general type.  The f2 type signature
+would be *less applicable* than f1, because it requires a more
+polymorphic argument.
+
+NB: There are no explicit kind variables written in f's signature.
+When there are, the renamer adds these kind variables to the list of
+variables bound by the forall, so you can indeed have a type that's
+higher-rank in its kind. But only by explicit request.
+
+Note [Kinds of quantified type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcTyVarBndrsGen quantifies over a specified list of type variables,
+*and* over the kind variables mentioned in the kinds of those tyvars.
+
+Note that we must zonk those kinds (obviously) but less obviously, we
+must return type variables whose kinds are zonked too. Example
+    (a :: k7)  where  k7 := k9 -> k9
+We must return
+    [k9, a:k9->k9]
+and NOT
+    [k9, a:k7]
+Reason: we're going to turn this into a for-all type,
+   forall k9. forall (a:k7). blah
+which the type checker will then instantiate, and instantiate does not
+look through unification variables!
+
+Hence using zonked_kinds when forming tvs'.
+
+-}
+
+-----------------------------------
+etaExpandAlgTyCon :: [TyConBinder]
+                  -> Kind
+                  -> TcM ([TyConBinder], Kind)
+-- GADT decls can have a (perhaps partial) kind signature
+--      e.g.  data T a :: * -> * -> * where ...
+-- This function makes up suitable (kinded) TyConBinders for the
+-- argument kinds.  E.g. in this case it might return
+--   ([b::*, c::*], *)
+-- Never emits constraints.
+-- It's a little trickier than you might think: see
+-- Note [TyConBinders for the result kind signature of a data type]
+etaExpandAlgTyCon tc_bndrs kind
+  = do  { loc     <- getSrcSpanM
+        ; uniqs   <- newUniqueSupply
+        ; rdr_env <- getLocalRdrEnv
+        ; let new_occs = [ occ
+                         | str <- allNameStrings
+                         , let occ = mkOccName tvName str
+                         , isNothing (lookupLocalRdrOcc rdr_env occ)
+                         -- Note [Avoid name clashes for associated data types]
+                         , not (occ `elem` lhs_occs) ]
+              new_uniqs = uniqsFromSupply uniqs
+              subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs))
+        ; return (go loc new_occs new_uniqs subst [] kind) }
+  where
+    lhs_tvs  = map binderVar tc_bndrs
+    lhs_occs = map getOccName lhs_tvs
+
+    go loc occs uniqs subst acc kind
+      = case splitPiTy_maybe kind of
+          Nothing -> (reverse acc, substTy subst kind)
+
+          Just (Anon arg, kind')
+            -> go loc occs' uniqs' subst' (tcb : acc) kind'
+            where
+              arg'   = substTy subst arg
+              tv     = mkTyVar (mkInternalName uniq occ loc) arg'
+              subst' = extendTCvInScope subst tv
+              tcb    = Bndr tv AnonTCB
+              (uniq:uniqs') = uniqs
+              (occ:occs')   = occs
+
+          Just (Named (Bndr tv vis), kind')
+            -> go loc occs uniqs subst' (tcb : acc) kind'
+            where
+              (subst', tv') = substTyVarBndr subst tv
+              tcb = Bndr tv' (NamedTCB vis)
+
+badKindSig :: Bool -> Kind -> SDoc
+badKindSig check_for_type kind
+ = hang (sep [ text "Kind signature on data type declaration has non-*"
+             , (if check_for_type then empty else text "and non-variable") <+>
+               text "return kind" ])
+        2 (ppr kind)
+
+tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]
+-- Result is in 1-1 correpondence with orig_args
+tcbVisibilities tc orig_args
+  = go (tyConKind tc) init_subst orig_args
+  where
+    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args))
+    go _ _ []
+      = []
+
+    go fun_kind subst all_args@(arg : args)
+      | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind
+      = case tcb of
+          Anon _              -> AnonTCB      : go inner_kind subst  args
+          Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args
+                 where
+                    subst' = extendTCvSubst subst tv arg
+
+      | not (isEmptyTCvSubst subst)
+      = go (substTy subst fun_kind) init_subst all_args
+
+      | otherwise
+      = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args)
+
+
+{- Note [TyConBinders for the result kind signature of a data type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given
+  data T (a::*) :: * -> forall k. k -> *
+we want to generate the extra TyConBinders for T, so we finally get
+  (a::*) (b::*) (k::*) (c::k)
+The function etaExpandAlgTyCon generates these extra TyConBinders from
+the result kind signature.
+
+We need to take care to give the TyConBinders
+  (a) OccNames that are fresh (because the TyConBinders of a TyCon
+      must have distinct OccNames
+
+  (b) Uniques that are fresh (obviously)
+
+For (a) we need to avoid clashes with the tyvars declared by
+the user before the "::"; in the above example that is 'a'.
+And also see Note [Avoid name clashes for associated data types].
+
+For (b) suppose we have
+   data T :: forall k. k -> forall k. k -> *
+where the two k's are identical even up to their uniques.  Surprisingly,
+this can happen: see Trac #14515.
+
+It's reasonably easy to solve all this; just run down the list with a
+substitution; hence the recursive 'go' function.  But it has to be
+done.
+
+Note [Avoid name clashes for associated data types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider    class C a b where
+               data D b :: * -> *
+When typechecking the decl for D, we'll invent an extra type variable
+for D, to fill out its kind.  Ideally we don't want this type variable
+to be 'a', because when pretty printing we'll get
+            class C a b where
+               data D b a0
+(NB: the tidying happens in the conversion to IfaceSyn, which happens
+as part of pretty-printing a TyThing.)
+
+That's why we look in the LocalRdrEnv to see what's in scope. This is
+important only to get nice-looking output when doing ":info C" in GHCi.
+It isn't essential for correctness.
+
+
+************************************************************************
+*                                                                      *
+             Partial signatures
+*                                                                      *
+************************************************************************
+
+-}
+
+tcHsPartialSigType
+  :: UserTypeCtxt
+  -> LHsSigWcType GhcRn       -- The type signature
+  -> TcM ( [(Name, TcTyVar)]  -- Wildcards
+         , Maybe TcType       -- Extra-constraints wildcard
+         , [Name]             -- Original tyvar names, in correspondence with ...
+         , [TcTyVar]          -- ... Implicitly and explicitly bound type variables
+         , TcThetaType        -- Theta part
+         , TcType )           -- Tau part
+-- See Note [Recipe for checking a signature]
+tcHsPartialSigType ctxt sig_ty
+  | HsWC { hswc_ext  = sig_wcs,         hswc_body = ib_ty } <- sig_ty
+  , HsIB { hsib_ext = implicit_hs_tvs
+         , hsib_body = hs_ty } <- ib_ty
+  , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty
+  = addSigCtxt ctxt hs_ty $
+    do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau)))
+            <- tcWildCardBinders sig_wcs $ \ wcs ->
+               bindImplicitTKBndrs_Tv implicit_hs_tvs       $
+               bindExplicitTKBndrs_Tv explicit_hs_tvs       $
+               do {   -- Instantiate the type-class context; but if there
+                      -- is an extra-constraints wildcard, just discard it here
+                    (theta, wcx) <- tcPartialContext hs_ctxt
+
+                  ; tau <- tcHsOpenType hs_tau
+
+                  ; return (wcs, wcx, theta, tau) }
+
+         -- We must return these separately, because all the zonking below
+         -- might change the name of a TyVarTv. This, in turn, causes trouble
+         -- in partial type signatures that bind scoped type variables, as
+         -- we bring the wrong name into scope in the function body.
+         -- Test case: partial-sigs/should_compile/LocalDefinitionBug
+       ; let tv_names = map tyVarName (implicit_tvs ++ explicit_tvs)
+
+       -- Spit out the wildcards (including the extra-constraints one)
+       -- as "hole" constraints, so that they'll be reported if necessary
+       -- See Note [Extra-constraint holes in partial type signatures]
+       ; emitWildCardHoleConstraints wcs
+
+         -- The TyVarTvs created above will sometimes have too high a TcLevel
+         -- (note that they are generated *after* bumping the level in
+         -- the tc{Im,Ex}plicitTKBndrsSig functions. Bumping the level
+         -- is still important here, because the kinds of these variables
+         -- do indeed need to have the higher level, so they can unify
+         -- with other local type variables. But, now that we've type-checked
+         -- everything (and solved equalities in the tcImplicit call)
+         -- we need to promote the TyVarTvs so we don't violate the TcLevel
+         -- invariant
+       ; implicit_tvs <- zonkAndScopedSort implicit_tvs
+       ; explicit_tvs <- mapM zonkTcTyCoVarBndr explicit_tvs
+       ; theta        <- mapM zonkTcType theta
+       ; tau          <- zonkTcType tau
+
+       ; let all_tvs = implicit_tvs ++ explicit_tvs
+
+       ; checkValidType ctxt (mkSpecForAllTys all_tvs $ mkPhiTy theta tau)
+
+       ; traceTc "tcHsPartialSigType" (ppr all_tvs)
+       ; return (wcs, wcx, tv_names, all_tvs, theta, tau) }
+
+tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPartialSigType"
+tcHsPartialSigType _ (XHsWildCardBndrs _) = panic "tcHsPartialSigType"
+
+tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType)
+tcPartialContext hs_theta
+  | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta
+  , L _ wc@(HsWildCardTy _) <- ignoreParens hs_ctxt_last
+  = do { wc_tv_ty <- tcWildCardOcc typeLevelMode wc constraintKind
+       ; theta <- mapM tcLHsPredType hs_theta1
+       ; return (theta, Just wc_tv_ty) }
+  | otherwise
+  = do { theta <- mapM tcLHsPredType hs_theta
+       ; return (theta, Nothing) }
+
+{- Note [Extra-constraint holes in partial type signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  f :: (_) => a -> a
+  f x = ...
+
+* The renamer leaves '_' untouched.
+
+* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in
+  tcWildCardBinders.
+
+* TcBinds.chooseInferredQuantifiers fills in that hole TcTyVar
+  with the inferred constraints, e.g. (Eq a, Show a)
+
+* TcErrors.mkHoleError finally reports the error.
+
+An annoying difficulty happens if there are more than 62 inferred
+constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple.
+Where do we find the TyCon?  For good reasons we only have constraint
+tuples up to 62 (see Note [How tuples work] in TysWiredIn).  So how
+can we make a 70-tuple?  This was the root cause of Trac #14217.
+
+It's incredibly tiresome, because we only need this type to fill
+in the hole, to communicate to the error reporting machinery.  Nothing
+more.  So I use a HACK:
+
+* I make an /ordinary/ tuple of the constraints, in
+  TcBinds.chooseInferredQuantifiers. This is ill-kinded because
+  ordinary tuples can't contain constraints, but it works fine. And for
+  ordinary tuples we don't have the same limit as for constraint
+  tuples (which need selectors and an assocated class).
+
+* Because it is ill-kinded, it trips an assert in writeMetaTyVar,
+  so now I disable the assertion if we are writing a type of
+  kind Constraint.  (That seldom/never normally happens so we aren't
+  losing much.)
+
+Result works fine, but it may eventually bite us.
+
+
+************************************************************************
+*                                                                      *
+      Pattern signatures (i.e signatures that occur in patterns)
+*                                                                      *
+********************************************************************* -}
+
+tcHsPatSigType :: UserTypeCtxt
+               -> LHsSigWcType GhcRn          -- The type signature
+               -> TcM ( [(Name, TcTyVar)]     -- Wildcards
+                      , [(Name, TcTyVar)]     -- The new bit of type environment, binding
+                                              -- the scoped type variables
+                      , TcType)       -- The type
+-- Used for type-checking type signatures in
+-- (a) patterns           e.g  f (x::Int) = e
+-- (b) RULE forall bndrs  e.g. forall (x::Int). f x = x
+--
+-- This may emit constraints
+-- See Note [Recipe for checking a signature]
+tcHsPatSigType ctxt sig_ty
+  | HsWC { hswc_ext = sig_wcs,   hswc_body = ib_ty } <- sig_ty
+  , HsIB { hsib_ext = sig_vars
+         , hsib_body = hs_ty } <- ib_ty
+  = addSigCtxt ctxt hs_ty $
+    do { sig_tkvs <- mapM new_implicit_tv sig_vars
+       ; (wcs, sig_ty)
+            <- solveLocalEqualities "tcHsPatSigType" $
+                 -- Always solve local equalities if possible,
+                 -- else casts get in the way of deep skolemisation
+                 -- (Trac #16033)
+               tcWildCardBinders sig_wcs  $ \ wcs ->
+               tcExtendTyVarEnv sig_tkvs                           $
+               do { sig_ty <- tcHsOpenType hs_ty
+                  ; return (wcs, sig_ty) }
+
+        ; emitWildCardHoleConstraints wcs
+
+          -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty
+          -- contains a forall). Promote these.
+          -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ...
+          -- When we instantiate x, we have to compare the kind of the argument
+          -- to a's kind, which will be a metavariable.
+        ; sig_ty <- zonkPromoteType sig_ty
+        ; checkValidType ctxt sig_ty
+
+        ; let tv_pairs = mkTyVarNamePairs sig_tkvs
+
+        ; traceTc "tcHsPatSigType" (ppr sig_vars)
+        ; return (wcs, tv_pairs, sig_ty) }
+  where
+    new_implicit_tv name = do { kind <- newMetaKindVar
+                              ; new_tv name kind }
+
+    new_tv = case ctxt of
+               RuleSigCtxt {} -> newSkolemTyVar
+               _              -> newTauTyVar
+      -- See Note [Pattern signature binders]
+
+
+tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPatSigType"
+tcHsPatSigType _ (XHsWildCardBndrs _)          = panic "tcHsPatSigType"
+
+tcPatSig :: Bool                    -- True <=> pattern binding
+         -> LHsSigWcType GhcRn
+         -> ExpSigmaType
+         -> TcM (TcType,            -- The type to use for "inside" the signature
+                 [(Name,TcTyVar)],  -- The new bit of type environment, binding
+                                    -- the scoped type variables
+                 [(Name,TcTyVar)],  -- The wildcards
+                 HsWrapper)         -- Coercion due to unification with actual ty
+                                    -- Of shape:  res_ty ~ sig_ty
+tcPatSig in_pat_bind sig res_ty
+ = do  { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig
+        -- sig_tvs are the type variables free in 'sig',
+        -- and not already in scope. These are the ones
+        -- that should be brought into scope
+
+        ; if null sig_tvs then do {
+                -- Just do the subsumption check and return
+                  wrap <- addErrCtxtM (mk_msg sig_ty) $
+                          tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty
+                ; return (sig_ty, [], sig_wcs, wrap)
+        } else do
+                -- Type signature binds at least one scoped type variable
+
+                -- A pattern binding cannot bind scoped type variables
+                -- It is more convenient to make the test here
+                -- than in the renamer
+        { when in_pat_bind (addErr (patBindSigErr sig_tvs))
+
+                -- Check that all newly-in-scope tyvars are in fact
+                -- constrained by the pattern.  This catches tiresome
+                -- cases like
+                --      type T a = Int
+                --      f :: Int -> Int
+                --      f (x :: T a) = ...
+                -- Here 'a' doesn't get a binding.  Sigh
+        ; let bad_tvs = filterOut (`elemVarSet` exactTyCoVarsOfType sig_ty)
+                                  (tyCoVarsOfTypeList sig_ty)
+        ; checkTc (null bad_tvs) (badPatTyVarTvs sig_ty bad_tvs)
+
+        -- Now do a subsumption check of the pattern signature against res_ty
+        ; wrap <- addErrCtxtM (mk_msg sig_ty) $
+                  tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty
+
+        -- Phew!
+        ; return (sig_ty, sig_tvs, sig_wcs, wrap)
+        } }
+  where
+    mk_msg sig_ty tidy_env
+       = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty
+            ; res_ty <- readExpType res_ty   -- should be filled in by now
+            ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty
+            ; let msg = vcat [ hang (text "When checking that the pattern signature:")
+                                  4 (ppr sig_ty)
+                             , nest 2 (hang (text "fits the type of its context:")
+                                          2 (ppr res_ty)) ]
+            ; return (tidy_env, msg) }
+
+patBindSigErr :: [(Name,TcTyVar)] -> SDoc
+patBindSigErr sig_tvs
+  = hang (text "You cannot bind scoped type variable" <> plural sig_tvs
+          <+> pprQuotedList (map fst sig_tvs))
+       2 (text "in a pattern binding signature")
+
+{- Note [Pattern signature binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also Note [Type variables in the type environment] in TcRnTypes.
+Consider
+
+  data T where
+    MkT :: forall a. a -> (a -> Int) -> T
+
+  f :: T -> ...
+  f (MkT x (f :: b -> c)) = <blah>
+
+Here
+ * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk',
+   It must be a skolem so that that it retains its identity, and
+   TcErrors.getSkolemInfo can thereby find the binding site for the skolem.
+
+ * The type signature pattern (f :: b -> c) makes freshs meta-tyvars
+   beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the
+   environment
+
+ * Then unification makes beta := a_sk, gamma := Int
+   That's why we must make beta and gamma a MetaTv,
+   not a SkolemTv, so that it can unify to a_sk (or Int, respectively).
+
+ * Finally, in '<blah>' we have the envt "b" :-> beta, "c" :-> gamma,
+   so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType,
+
+Another example (Trac #13881):
+   fl :: forall (l :: [a]). Sing l -> Sing l
+   fl (SNil :: Sing (l :: [y])) = SNil
+When we reach the pattern signature, 'l' is in scope from the
+outer 'forall':
+   "a" :-> a_sk :: *
+   "l" :-> l_sk :: [a_sk]
+We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check
+the pattern signature
+   Sing (l :: [y])
+That unifies y_sig := a_sk.  We return from tcHsPatSigType with
+the pair ("y" :-> y_sig).
+
+For RULE binders, though, things are a bit different (yuk).
+  RULE "foo" forall (x::a) (y::[a]).  f x y = ...
+Here this really is the binding site of the type variable so we'd like
+to use a skolem, so that we get a complaint if we unify two of them
+together.  Hence the new_tv function in tcHsPatSigType.
+
+
+************************************************************************
+*                                                                      *
+        Checking kinds
+*                                                                      *
+************************************************************************
+
+-}
+
+unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)
+unifyKinds rn_tys act_kinds
+  = do { kind <- newMetaKindVar
+       ; let check rn_ty (ty, act_kind) = checkExpectedKind YesSaturation (ppr $ unLoc rn_ty) ty act_kind kind
+       ; tys' <- zipWithM check rn_tys act_kinds
+       ; return (tys', kind) }
+
+{-
+************************************************************************
+*                                                                      *
+    Promotion
+*                                                                      *
+************************************************************************
+-}
+
+-- | Whenever a type is about to be added to the environment, it's necessary
+-- to make sure that any free meta-tyvars in the type are promoted to the
+-- current TcLevel. (They might be at a higher level due to the level-bumping
+-- in tcExplicitTKBndrs, for example.) This function both zonks *and*
+-- promotes. Why at the same time? See Note [Recipe for checking a signature]
+zonkPromoteType :: TcType -> TcM TcType
+zonkPromoteType = mapType zonkPromoteMapper ()
+
+-- cf. TcMType.zonkTcTypeMapper
+zonkPromoteMapper :: TyCoMapper () TcM
+zonkPromoteMapper = TyCoMapper { tcm_smart    = True
+                               , tcm_tyvar    = const zonkPromoteTcTyVar
+                               , tcm_covar    = const covar
+                               , tcm_hole     = const hole
+                               , tcm_tycobinder = const tybinder
+                               , tcm_tycon    = return }
+  where
+    covar cv
+      = mkCoVarCo <$> zonkPromoteTyCoVarKind cv
+
+    hole :: CoercionHole -> TcM Coercion
+    hole h
+      = do { contents <- unpackCoercionHole_maybe h
+           ; case contents of
+               Just co -> do { co <- zonkPromoteCoercion co
+                             ; checkCoercionHole cv co }
+               Nothing -> do { cv' <- zonkPromoteTyCoVarKind cv
+                             ; return $ mkHoleCo (setCoHoleCoVar h cv') } }
+      where
+        cv = coHoleCoVar h
+
+    tybinder :: TyVar -> ArgFlag -> TcM ((), TyVar)
+    tybinder tv _flag = ((), ) <$> zonkPromoteTyCoVarKind tv
+
+zonkPromoteTcTyVar :: TyCoVar -> TcM TcType
+zonkPromoteTcTyVar tv
+  | isMetaTyVar tv
+  = do { let ref = metaTyVarRef tv
+       ; contents <- readTcRef ref
+       ; case contents of
+           Flexi -> do { (_, promoted_tv) <- promoteTyVar tv
+                       ; mkTyVarTy <$> zonkPromoteTyCoVarKind promoted_tv }
+           Indirect ty -> zonkPromoteType ty }
+
+  | isTcTyVar tv && isSkolemTyVar tv  -- NB: isSkolemTyVar says "True" to pure TyVars
+  = do { tc_lvl <- getTcLevel
+       ; mkTyVarTy <$> zonkPromoteTyCoVarKind (promoteSkolem tc_lvl tv) }
+
+  | otherwise
+  = mkTyVarTy <$> zonkPromoteTyCoVarKind tv
+
+zonkPromoteTyCoVarKind :: TyCoVar -> TcM TyCoVar
+zonkPromoteTyCoVarKind = updateTyVarKindM zonkPromoteType
+
+zonkPromoteCoercion :: Coercion -> TcM Coercion
+zonkPromoteCoercion = mapCoercion zonkPromoteMapper ()
+
+{-
+************************************************************************
+*                                                                      *
+        Sort checking kinds
+*                                                                      *
+************************************************************************
+
+tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.
+It does sort checking and desugaring at the same time, in one single pass.
+-}
+
+tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind
+tcLHsKindSig ctxt hs_kind
+-- See  Note [Recipe for checking a signature] in TcHsType
+-- Result is zonked
+  = do { kind <- solveLocalEqualities "tcLHsKindSig" $
+                 tc_lhs_kind kindLevelMode hs_kind
+       ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)
+       -- No generalization, so we must promote
+       ; kind <- zonkPromoteType kind
+         -- This zonk is very important in the case of higher rank kinds
+         -- E.g. Trac #13879    f :: forall (p :: forall z (y::z). <blah>).
+         --                          <more blah>
+         --      When instantiating p's kind at occurrences of p in <more blah>
+         --      it's crucial that the kind we instantiate is fully zonked,
+         --      else we may fail to substitute properly
+
+       ; checkValidType ctxt kind
+       ; traceTc "tcLHsKindSig2" (ppr kind)
+       ; return kind }
+
+tc_lhs_kind :: TcTyMode -> LHsKind GhcRn -> TcM Kind
+tc_lhs_kind mode k
+  = addErrCtxt (text "In the kind" <+> quotes (ppr k)) $
+    tc_lhs_type (kindLevel mode) k liftedTypeKind
+
+promotionErr :: Name -> PromotionErr -> TcM a
+promotionErr name err
+  = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")
+                   2 (parens reason))
+  where
+    reason = case err of
+               ConstrainedDataConPE pred
+                              -> text "it has an unpromotable context"
+                                 <+> quotes (ppr pred)
+               FamDataConPE   -> text "it comes from a data family instance"
+               NoDataKindsTC  -> text "perhaps you intended to use DataKinds"
+               NoDataKindsDC  -> text "perhaps you intended to use DataKinds"
+               PatSynPE       -> text "pattern synonyms cannot be promoted"
+               PatSynExPE     -> sep [ text "the existential variables of a pattern synonym"
+                                     , text "signature do not scope over the pattern" ]
+               _ -> text "it is defined and used in the same recursive group"
+
+{-
+************************************************************************
+*                                                                      *
+                Scoped type variables
+*                                                                      *
+************************************************************************
+-}
+
+badPatTyVarTvs :: TcType -> [TyVar] -> SDoc
+badPatTyVarTvs sig_ty bad_tvs
+  = vcat [ fsep [text "The type variable" <> plural bad_tvs,
+                 quotes (pprWithCommas ppr bad_tvs),
+                 text "should be bound by the pattern signature" <+> quotes (ppr sig_ty),
+                 text "but are actually discarded by a type synonym" ]
+         , text "To fix this, expand the type synonym"
+         , text "[Note: I hope to lift this restriction in due course]" ]
+
+{-
+************************************************************************
+*                                                                      *
+          Error messages and such
+*                                                                      *
+************************************************************************
+-}
+
+
+{- Note [Free-floating kind vars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+  data S a = MkS (Proxy (a :: k))
+
+According to the rules around implicitly-bound kind variables,
+that k scopes over the whole declaration. The renamer grabs
+it and adds it to the hsq_implicits field of the HsQTyVars of the
+tycon.  So we get
+   S :: forall {k}. k -> Type
+
+That's fine.  But consider this variant:
+  data T = MkT (forall (a :: k). Proxy a)
+  -- from test ghci/scripts/T7873
+
+This is not an existential datatype, but a higher-rank one (the forall
+to the right of MkT). Again, 'k' scopes over the whole declaration,
+but we do not want to get
+   T :: forall {k}. Type
+Why not? Because the kind variable isn't fixed by anything. For
+a variable like k to be implicit, it needs to be mentioned in the kind
+of a tycon tyvar. But it isn't.
+
+Rejecting T depends on whether or not the datatype has a CUSK.
+
+Non-CUSK (handled in TcTyClsDecls.kcTyClGroup (generalise)):
+   When generalising the TyCon we check that every Specified 'k'
+   appears free in the kind of the TyCon; that is, in the kind of
+   one of its Required arguments, or the result kind.
+
+CUSK (handled in TcHsType.kcLHsQTyVars, the CUSK case):
+   When we determine the tycon's final, never-to-be-changed kind
+   in kcLHsQTyVars, we check to make sure all implicitly-bound kind
+   vars are indeed mentioned in a kind somewhere. If not, error.
+
+We also perform free-floating kind var analysis for type family instances
+(see #13985). Here is an interesting example:
+
+    type family   T :: k
+    type instance T = (Nothing :: Maybe a)
+
+Upon a cursory glance, it may appear that the kind variable `a` is
+free-floating above, since there are no (visible) LHS patterns in `T`. However,
+there is an *invisible* pattern due to the return kind, so inside of GHC, the
+instance looks closer to this:
+
+    type family T @k :: k
+    type instance T @(Maybe a) = (Nothing :: Maybe a)
+
+Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in
+fact not free-floating. Contrast that with this example:
+
+    type instance T = Proxy (Nothing :: Maybe a)
+
+This would looks like this inside of GHC:
+
+    type instance T @(*) = Proxy (Nothing :: Maybe a)
+
+So this time, `a` is neither bound by a visible nor invisible type pattern on
+the LHS, so it would be reported as free-floating.
+
+Finally, here's one more brain-teaser (from #9574). In the example below:
+
+    class Funct f where
+      type Codomain f :: *
+    instance Funct ('KProxy :: KProxy o) where
+      type Codomain 'KProxy = NatTr (Proxy :: o -> *)
+
+As it turns out, `o` is not free-floating in this example. That is because `o`
+bound by the kind signature of the LHS type pattern 'KProxy. To make this more
+obvious, one can also write the instance like so:
+
+    instance Funct ('KProxy :: KProxy o) where
+      type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *)
+-}
+
+-- See Note [Free-floating kind vars]
+reportFloatingKvs :: Name         -- of the tycon
+                  -> TyConFlavour -- What sort of TyCon it is
+                  -> [TcTyVar]    -- all tyvars, not necessarily zonked
+                  -> [TcTyVar]    -- floating tyvars
+                  -> TcM ()
+reportFloatingKvs tycon_name flav all_tvs bad_tvs
+  = unless (null bad_tvs) $  -- don't bother zonking if there's no error
+    do { all_tvs <- mapM zonkTcTyVarToTyVar all_tvs
+       ; bad_tvs <- mapM zonkTcTyVarToTyVar bad_tvs
+       ; let (tidy_env, tidy_all_tvs) = tidyOpenTyCoVars emptyTidyEnv all_tvs
+             tidy_bad_tvs             = map (tidyTyCoVarOcc tidy_env) bad_tvs
+       ; mapM_ (report tidy_all_tvs) tidy_bad_tvs }
+  where
+    report tidy_all_tvs tidy_bad_tv
+      = addErr $
+        vcat [ text "Kind variable" <+> quotes (ppr tidy_bad_tv) <+>
+               text "is implicitly bound in" <+> ppr flav
+             , quotes (ppr tycon_name) <> comma <+>
+               text "but does not appear as the kind of any"
+             , text "of its type variables. Perhaps you meant"
+             , text "to bind it explicitly somewhere?"
+             , ppWhen (not (null tidy_all_tvs)) $
+                 hang (text "Type variables with inferred kinds:")
+                 2 (ppr_tv_bndrs tidy_all_tvs) ]
+
+    ppr_tv_bndrs tvs = sep (map pp_tv tvs)
+    pp_tv tv         = parens (ppr tv <+> dcolon <+> ppr (tyVarKind tv))
+
+-- | If the inner action emits constraints, report them as errors and fail;
+-- otherwise, propagates the return value. Useful as a wrapper around
+-- 'tcImplicitTKBndrs', which uses solveLocalEqualities, when there won't be
+-- another chance to solve constraints
+failIfEmitsConstraints :: TcM a -> TcM a
+failIfEmitsConstraints thing_inside
+  = checkNoErrs $  -- We say that we fail if there are constraints!
+                   -- c.f same checkNoErrs in solveEqualities
+    do { (res, lie) <- captureConstraints thing_inside
+       ; reportAllUnsolved lie
+       ; return res
+       }
+
+-- | Make an appropriate message for an error in a function argument.
+-- Used for both expressions and types.
+funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc
+funAppCtxt fun arg arg_no
+  = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"),
+                    quotes (ppr fun) <> text ", namely"])
+       2 (quotes (ppr arg))
+
+-- | Add a "In the data declaration for T" or some such.
+addTyConFlavCtxt :: Name -> TyConFlavour -> TcM a -> TcM a
+addTyConFlavCtxt name flav
+  = addErrCtxt $ hsep [ text "In the", ppr flav
+                      , text "declaration for", quotes (ppr name) ]
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -0,0 +1,2131 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+TcInstDecls: Typechecking instance declarations
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import TcBinds
+import TcTyClsDecls
+import TcTyDecls ( addTyConsToGblEnv )
+import TcClassDcl( tcClassDecl2, tcATDefault,
+                   HsSigFun, mkHsSigFun, badMethodErr,
+                   findMethodBind, instantiateMethod )
+import TcSigs
+import TcRnMonad
+import TcValidity
+import TcHsSyn
+import TcMType
+import TcType
+import BuildTyCl
+import Inst
+import ClsInst( AssocInstInfo(..), isNotAssociated )
+import InstEnv
+import FamInst
+import FamInstEnv
+import TcDeriv
+import TcEnv
+import TcHsType
+import TcUnify
+import CoreSyn    ( Expr(..), mkApps, mkVarApps, mkLams )
+import MkCore     ( nO_METHOD_BINDING_ERROR_ID )
+import CoreUnfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding )
+import Type
+import TcEvidence
+import TyCon
+import CoAxiom
+import DataCon
+import ConLike
+import Class
+import Var
+import VarEnv
+import VarSet
+import Bag
+import BasicTypes
+import DynFlags
+import ErrUtils
+import FastString
+import Id
+import ListSetOps
+import Name
+import NameSet
+import Outputable
+import SrcLoc
+import Util
+import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Maybes
+import Data.List( mapAccumL )
+
+
+{-
+Typechecking instance declarations is done in two passes. The first
+pass, made by @tcInstDecls1@, collects information to be used in the
+second pass.
+
+This pre-processed info includes the as-yet-unprocessed bindings
+inside the instance declaration.  These are type-checked in the second
+pass, when the class-instance envs and GVE contain all the info from
+all the instance and value decls.  Indeed that's the reason we need
+two passes over the instance decls.
+
+
+Note [How instance declarations are translated]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is how we translate instance declarations into Core
+
+Running example:
+        class C a where
+           op1, op2 :: Ix b => a -> b -> b
+           op2 = <dm-rhs>
+
+        instance C a => C [a]
+           {-# INLINE [2] op1 #-}
+           op1 = <rhs>
+===>
+        -- Method selectors
+        op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
+        op1 = ...
+        op2 = ...
+
+        -- Default methods get the 'self' dictionary as argument
+        -- so they can call other methods at the same type
+        -- Default methods get the same type as their method selector
+        $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
+        $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
+               -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
+               -- Note [Tricky type variable scoping]
+
+        -- A top-level definition for each instance method
+        -- Here op1_i, op2_i are the "instance method Ids"
+        -- The INLINE pragma comes from the user pragma
+        {-# INLINE [2] op1_i #-}  -- From the instance decl bindings
+        op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
+        op1_i = /\a. \(d:C a).
+               let this :: C [a]
+                   this = df_i a d
+                     -- Note [Subtle interaction of recursion and overlap]
+
+                   local_op1 :: forall b. Ix b => [a] -> b -> b
+                   local_op1 = <rhs>
+                     -- Source code; run the type checker on this
+                     -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
+                     -- Note [Tricky type variable scoping]
+
+               in local_op1 a d
+
+        op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
+
+        -- The dictionary function itself
+        {-# NOINLINE CONLIKE df_i #-}   -- Never inline dictionary functions
+        df_i :: forall a. C a -> C [a]
+        df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
+                -- But see Note [Default methods in instances]
+                -- We can't apply the type checker to the default-method call
+
+        -- Use a RULE to short-circuit applications of the class ops
+        {-# RULE "op1@C[a]" forall a, d:C a.
+                            op1 [a] (df_i d) = op1_i a d #-}
+
+Note [Instances and loop breakers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Note that df_i may be mutually recursive with both op1_i and op2_i.
+  It's crucial that df_i is not chosen as the loop breaker, even
+  though op1_i has a (user-specified) INLINE pragma.
+
+* Instead the idea is to inline df_i into op1_i, which may then select
+  methods from the MkC record, and thereby break the recursion with
+  df_i, leaving a *self*-recursive op1_i.  (If op1_i doesn't call op at
+  the same type, it won't mention df_i, so there won't be recursion in
+  the first place.)
+
+* If op1_i is marked INLINE by the user there's a danger that we won't
+  inline df_i in it, and that in turn means that (since it'll be a
+  loop-breaker because df_i isn't), op1_i will ironically never be
+  inlined.  But this is OK: the recursion breaking happens by way of
+  a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
+  unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
+
+Note [ClassOp/DFun selection]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+One thing we see a lot is stuff like
+    op2 (df d1 d2)
+where 'op2' is a ClassOp and 'df' is DFun.  Now, we could inline *both*
+'op2' and 'df' to get
+     case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
+       MkD _ op2 _ _ _ -> op2
+And that will reduce to ($cop2 d1 d2) which is what we wanted.
+
+But it's tricky to make this work in practice, because it requires us to
+inline both 'op2' and 'df'.  But neither is keen to inline without having
+seen the other's result; and it's very easy to get code bloat (from the
+big intermediate) if you inline a bit too much.
+
+Instead we use a cunning trick.
+ * We arrange that 'df' and 'op2' NEVER inline.
+
+ * We arrange that 'df' is ALWAYS defined in the sylised form
+      df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
+
+ * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
+   that lists its methods.
+
+ * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
+   a suitable constructor application -- inlining df "on the fly" as it
+   were.
+
+ * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that
+   extracts the right piece iff its argument satisfies
+   exprIsConApp_maybe.  This is done in MkId mkDictSelId
+
+ * We make 'df' CONLIKE, so that shared uses still match; eg
+      let d = df d1 d2
+      in ...(op2 d)...(op1 d)...
+
+Note [Single-method classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the class has just one method (or, more accurately, just one element
+of {superclasses + methods}), then we use a different strategy.
+
+   class C a where op :: a -> a
+   instance C a => C [a] where op = <blah>
+
+We translate the class decl into a newtype, which just gives a
+top-level axiom. The "constructor" MkC expands to a cast, as does the
+class-op selector.
+
+   axiom Co:C a :: C a ~ (a->a)
+
+   op :: forall a. C a -> (a -> a)
+   op a d = d |> (Co:C a)
+
+   MkC :: forall a. (a->a) -> C a
+   MkC = /\a.\op. op |> (sym Co:C a)
+
+The clever RULE stuff doesn't work now, because ($df a d) isn't
+a constructor application, so exprIsConApp_maybe won't return
+Just <blah>.
+
+Instead, we simply rely on the fact that casts are cheap:
+
+   $df :: forall a. C a => C [a]
+   {-# INLINE df #-}  -- NB: INLINE this
+   $df = /\a. \d. MkC [a] ($cop_list a d)
+       = $cop_list |> forall a. C a -> (sym (Co:C [a]))
+
+   $cop_list :: forall a. C a => [a] -> [a]
+   $cop_list = <blah>
+
+So if we see
+   (op ($df a d))
+we'll inline 'op' and '$df', since both are simply casts, and
+good things happen.
+
+Why do we use this different strategy?  Because otherwise we
+end up with non-inlined dictionaries that look like
+    $df = $cop |> blah
+which adds an extra indirection to every use, which seems stupid.  See
+Trac #4138 for an example (although the regression reported there
+wasn't due to the indirection).
+
+There is an awkward wrinkle though: we want to be very
+careful when we have
+    instance C a => C [a] where
+      {-# INLINE op #-}
+      op = ...
+then we'll get an INLINE pragma on $cop_list but it's important that
+$cop_list only inlines when it's applied to *two* arguments (the
+dictionary and the list argument).  So we must not eta-expand $df
+above.  We ensure that this doesn't happen by putting an INLINE
+pragma on the dfun itself; after all, it ends up being just a cast.
+
+There is one more dark corner to the INLINE story, even more deeply
+buried.  Consider this (Trac #3772):
+
+    class DeepSeq a => C a where
+      gen :: Int -> a
+
+    instance C a => C [a] where
+      gen n = ...
+
+    class DeepSeq a where
+      deepSeq :: a -> b -> b
+
+    instance DeepSeq a => DeepSeq [a] where
+      {-# INLINE deepSeq #-}
+      deepSeq xs b = foldr deepSeq b xs
+
+That gives rise to these defns:
+
+    $cdeepSeq :: DeepSeq a -> [a] -> b -> b
+    -- User INLINE( 3 args )!
+    $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...
+
+    $fDeepSeq[] :: DeepSeq a -> DeepSeq [a]
+    -- DFun (with auto INLINE pragma)
+    $fDeepSeq[] a d = $cdeepSeq a d |> blah
+
+    $cp1 a d :: C a => DeepSep [a]
+    -- We don't want to eta-expand this, lest
+    -- $cdeepSeq gets inlined in it!
+    $cp1 a d = $fDeepSep[] a (scsel a d)
+
+    $fC[] :: C a => C [a]
+    -- Ordinary DFun
+    $fC[] a d = MkC ($cp1 a d) ($cgen a d)
+
+Here $cp1 is the code that generates the superclass for C [a].  The
+issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]
+and then $cdeepSeq will inline there, which is definitely wrong.  Like
+on the dfun, we solve this by adding an INLINE pragma to $cp1.
+
+Note [Subtle interaction of recursion and overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+  class C a where { op1,op2 :: a -> a }
+  instance C a => C [a] where
+    op1 x = op2 x ++ op2 x
+    op2 x = ...
+  instance C [Int] where
+    ...
+
+When type-checking the C [a] instance, we need a C [a] dictionary (for
+the call of op2).  If we look up in the instance environment, we find
+an overlap.  And in *general* the right thing is to complain (see Note
+[Overlapping instances] in InstEnv).  But in *this* case it's wrong to
+complain, because we just want to delegate to the op2 of this same
+instance.
+
+Why is this justified?  Because we generate a (C [a]) constraint in
+a context in which 'a' cannot be instantiated to anything that matches
+other overlapping instances, or else we would not be executing this
+version of op1 in the first place.
+
+It might even be a bit disguised:
+
+  nullFail :: C [a] => [a] -> [a]
+  nullFail x = op2 x ++ op2 x
+
+  instance C a => C [a] where
+    op1 x = nullFail x
+
+Precisely this is used in package 'regex-base', module Context.hs.
+See the overlapping instances for RegexContext, and the fact that they
+call 'nullFail' just like the example above.  The DoCon package also
+does the same thing; it shows up in module Fraction.hs.
+
+Conclusion: when typechecking the methods in a C [a] instance, we want to
+treat the 'a' as an *existential* type variable, in the sense described
+by Note [Binding when looking up instances].  That is why isOverlappableTyVar
+responds True to an InstSkol, which is the kind of skolem we use in
+tcInstDecl2.
+
+
+Note [Tricky type variable scoping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In our example
+        class C a where
+           op1, op2 :: Ix b => a -> b -> b
+           op2 = <dm-rhs>
+
+        instance C a => C [a]
+           {-# INLINE [2] op1 #-}
+           op1 = <rhs>
+
+note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
+in scope in <rhs>.  In particular, we must make sure that 'b' is in
+scope when typechecking <dm-rhs>.  This is achieved by subFunTys,
+which brings appropriate tyvars into scope. This happens for both
+<dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
+complained if 'b' is mentioned in <rhs>.
+
+
+
+************************************************************************
+*                                                                      *
+\subsection{Extracting instance decls}
+*                                                                      *
+************************************************************************
+
+Gather up the instance declarations from their various sources
+-}
+
+tcInstDecls1    -- Deal with both source-code and imported instance decls
+   :: [LInstDecl GhcRn]         -- Source code instance decls
+   -> TcM (TcGblEnv,            -- The full inst env
+           [InstInfo GhcRn],    -- Source-code instance decls to process;
+                                -- contains all dfuns for this module
+           [DerivInfo])         -- From data family instances
+
+tcInstDecls1 inst_decls
+  = do {    -- Do class and family instance declarations
+       ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls
+
+       ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff
+             fam_insts   = concat fam_insts_s
+             local_infos = concat local_infos_s
+
+       ; gbl_env <- addClsInsts local_infos $
+                    addFamInsts fam_insts   $
+                    getGblEnv
+
+       ; return ( gbl_env
+                , local_infos
+                , concat datafam_deriv_infos ) }
+
+-- | Use DerivInfo for data family instances (produced by tcInstDecls1),
+--   datatype declarations (TyClDecl), and standalone deriving declarations
+--   (DerivDecl) to check and process all derived class instances.
+tcInstDeclsDeriv
+  :: [DerivInfo]
+  -> [LTyClDecl GhcRn]
+  -> [LDerivDecl GhcRn]
+  -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
+tcInstDeclsDeriv datafam_deriv_infos tyclds derivds
+  = do th_stage <- getStage -- See Note [Deriving inside TH brackets]
+       if isBrackStage th_stage
+       then do { gbl_env <- getGblEnv
+               ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) }
+       else do { data_deriv_infos <- mkDerivInfos tyclds
+               ; let deriv_infos = datafam_deriv_infos ++ data_deriv_infos
+               ; (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds
+               ; return (tcg_env, bagToList info_bag, valbinds) }
+
+addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a
+addClsInsts infos thing_inside
+  = tcExtendLocalInstEnv (map iSpec infos) thing_inside
+
+addFamInsts :: [FamInst] -> TcM a -> TcM a
+-- Extend (a) the family instance envt
+--        (b) the type envt with stuff from data type decls
+addFamInsts fam_insts thing_inside
+  = tcExtendLocalFamInstEnv fam_insts $
+    tcExtendGlobalEnv axioms          $
+    do { traceTc "addFamInsts" (pprFamInsts fam_insts)
+       ; gbl_env <- addTyConsToGblEnv data_rep_tycons
+                    -- Does not add its axiom; that comes
+                    -- from adding the 'axioms' above
+       ; setGblEnv gbl_env thing_inside }
+  where
+    axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts
+    data_rep_tycons = famInstsRepTyCons fam_insts
+      -- The representation tycons for 'data instances' declarations
+
+{-
+Note [Deriving inside TH brackets]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given a declaration bracket
+  [d| data T = A | B deriving( Show ) |]
+
+there is really no point in generating the derived code for deriving(
+Show) and then type-checking it. This will happen at the call site
+anyway, and the type check should never fail!  Moreover (Trac #6005)
+the scoping of the generated code inside the bracket does not seem to
+work out.
+
+The easy solution is simply not to generate the derived instances at
+all.  (A less brutal solution would be to generate them with no
+bindings.)  This will become moot when we shift to the new TH plan, so
+the brutal solution will do.
+-}
+
+tcLocalInstDecl :: LInstDecl GhcRn
+                -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
+        -- A source-file instance declaration
+        -- Type-check all the stuff before the "where"
+        --
+        -- We check for respectable instance type, and context
+tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))
+  = do { fam_inst <- tcTyFamInstDecl NotAssociated (L loc decl)
+       ; return ([], [fam_inst], []) }
+
+tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))
+  = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated (L loc decl)
+       ; return ([], [fam_inst], maybeToList m_deriv_info) }
+
+tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
+  = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl)
+       ; return (insts, fam_insts, deriv_infos) }
+
+tcLocalInstDecl (L _ (XInstDecl _)) = panic "tcLocalInstDecl"
+
+tcClsInstDecl :: LClsInstDecl GhcRn
+              -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
+-- The returned DerivInfos are for any associated data families
+tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds
+                                  , cid_sigs = uprags, cid_tyfam_insts = ats
+                                  , cid_overlap_mode = overlap_mode
+                                  , cid_datafam_insts = adts }))
+  = setSrcSpan loc                      $
+    addErrCtxt (instDeclCtxt1 hs_ty)  $
+    do  { traceTc "tcLocalInstDecl" (ppr hs_ty)
+        ; dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty
+        ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty
+             -- NB: tcHsClsInstType does checkValidInstance
+
+        ; (subst, skol_tvs) <- tcInstSkolTyVars tyvars
+        ; let tv_skol_prs = [ (tyVarName tv, skol_tv)
+                            | (tv, skol_tv) <- tyvars `zip` skol_tvs ]
+              n_inferred = countWhile ((== Inferred) . binderArgFlag) $
+                           fst $ splitForAllVarBndrs dfun_ty
+              visible_skol_tvs = drop n_inferred skol_tvs
+
+        ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs)
+
+        -- Next, process any associated types.
+        ; (datafam_stuff, tyfam_insts)
+             <- tcExtendNameTyVarEnv tv_skol_prs $
+                do  { let mini_env   = mkVarEnv (classTyVars clas `zip` substTys subst inst_tys)
+                          mini_subst = mkTvSubst (mkInScopeSet (mkVarSet skol_tvs)) mini_env
+                          mb_info    = InClsInst { ai_class = clas
+                                                 , ai_tyvars = visible_skol_tvs
+                                                 , ai_inst_env = mini_env }
+                    ; df_stuff  <- mapAndRecoverM (tcDataFamInstDecl mb_info) adts
+                    ; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info)   ats
+
+                      -- Check for missing associated types and build them
+                      -- from their defaults (if available)
+                    ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats)
+                                        (classATItems clas)
+
+                    ; return (df_stuff, tf_insts1 ++ concat tf_insts2) }
+
+
+        -- Finally, construct the Core representation of the instance.
+        -- (This no longer includes the associated types.)
+        ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType hs_ty))
+                -- Dfun location is that of instance *header*
+
+        ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name
+                              tyvars theta clas inst_tys
+
+        ; let inst_binds = InstBindings
+                             { ib_binds = binds
+                             , ib_tyvars = map Var.varName tyvars -- Scope over bindings
+                             , ib_pragmas = uprags
+                             , ib_extensions = []
+                             , ib_derived = False }
+              inst_info = InstInfo { iSpec  = ispec, iBinds = inst_binds }
+
+              (datafam_insts, m_deriv_infos) = unzip datafam_stuff
+              deriv_infos                    = catMaybes m_deriv_infos
+              all_insts                      = tyfam_insts ++ datafam_insts
+
+         -- In hs-boot files there should be no bindings
+        ; is_boot <- tcIsHsBootOrSig
+        ; let no_binds = isEmptyLHsBinds binds && null uprags
+        ; failIfTc (is_boot && not no_binds) badBootDeclErr
+
+        ; return ( [inst_info], all_insts, deriv_infos ) }
+  where
+    defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
+                  `unionNameSet`
+                  mkNameSet (map (unLoc . feqn_tycon
+                                        . hsib_body
+                                        . dfid_eqn
+                                        . unLoc) adts)
+
+tcClsInstDecl (L _ (XClsInstDecl _)) = panic "tcClsInstDecl"
+
+{-
+************************************************************************
+*                                                                      *
+               Type family instances
+*                                                                      *
+************************************************************************
+
+Family instances are somewhat of a hybrid.  They are processed together with
+class instance heads, but can contain data constructors and hence they share a
+lot of kinding and type checking code with ordinary algebraic data types (and
+GADTs).
+-}
+
+tcTyFamInstDecl :: AssocInstInfo
+                -> LTyFamInstDecl GhcRn -> TcM FamInst
+  -- "type instance"
+  -- See Note [Associated type instances]
+tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
+  = setSrcSpan loc           $
+    tcAddTyFamInstCtxt decl  $
+    do { let fam_lname = feqn_tycon (hsib_body eqn)
+       ; fam_tc <- tcLookupLocatedTyCon fam_lname
+       ; tcFamInstDeclChecks mb_clsinfo fam_tc
+
+         -- (0) Check it's an open type family
+       ; checkTc (isTypeFamilyTyCon fam_tc)     (wrongKindOfFamily fam_tc)
+       ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc)
+
+         -- (1) do the work of verifying the synonym group
+       ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo
+                                        (L (getLoc fam_lname) eqn)
+
+
+         -- (2) check for validity
+       ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch
+       ; checkValidCoAxBranch fam_tc co_ax_branch
+
+         -- (3) construct coercion axiom
+       ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch]
+       ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch
+       ; newFamInst SynFamilyInst axiom }
+
+
+---------------------
+tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcM ()
+-- Used for both type and data families
+tcFamInstDeclChecks mb_clsinfo fam_tc
+  = do { -- Type family instances require -XTypeFamilies
+         -- and can't (currently) be in an hs-boot file
+       ; traceTc "tcFamInstDecl" (ppr fam_tc)
+       ; type_families <- xoptM LangExt.TypeFamilies
+       ; is_boot       <- tcIsHsBootOrSig   -- Are we compiling an hs-boot file?
+       ; checkTc type_families $ badFamInstDecl fam_tc
+       ; checkTc (not is_boot) $ badBootFamInstDeclErr
+
+       -- Check that it is a family TyCon, and that
+       -- oplevel type instances are not for associated types.
+       ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
+
+       ; when (isNotAssociated mb_clsinfo &&   -- Not in a class decl
+               isTyConAssoc fam_tc)            -- but an associated type
+              (addErr $ assocInClassErr fam_tc)
+       }
+
+{- Note [Associated type instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We allow this:
+  class C a where
+    type T x a
+  instance C Int where
+    type T (S y) Int = y
+    type T Z     Int = Char
+
+Note that
+  a) The variable 'x' is not bound by the class decl
+  b) 'x' is instantiated to a non-type-variable in the instance
+  c) There are several type instance decls for T in the instance
+
+All this is fine.  Of course, you can't give any *more* instances
+for (T ty Int) elsewhere, because it's an *associated* type.
+
+
+************************************************************************
+*                                                                      *
+               Data family instances
+*                                                                      *
+************************************************************************
+
+For some reason data family instances are a lot more complicated
+than type family instances
+-}
+
+tcDataFamInstDecl :: AssocInstInfo
+                  -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)
+  -- "newtype instance" and "data instance"
+tcDataFamInstDecl mb_clsinfo
+    (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = imp_vars
+                                                   , hsib_body =
+      FamEqn { feqn_bndrs  = mb_bndrs
+             , feqn_pats   = hs_pats
+             , feqn_tycon  = lfam_name@(L _ fam_name)
+             , feqn_fixity = fixity
+             , feqn_rhs    = HsDataDefn { dd_ND      = new_or_data
+                                        , dd_cType   = cType
+                                        , dd_ctxt    = hs_ctxt
+                                        , dd_cons    = hs_cons
+                                        , dd_kindSig = m_ksig
+                                        , dd_derivs  = derivs } }}}))
+  = setSrcSpan loc             $
+    tcAddDataFamInstCtxt decl  $
+    do { fam_tc <- tcLookupLocatedTyCon lfam_name
+
+       ; tcFamInstDeclChecks mb_clsinfo fam_tc
+
+       -- Check that the family declaration is for the right kind
+       ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
+       ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons
+          -- Do /not/ check that the number of patterns = tyConArity fam_tc
+          -- See [Arity of data families] in FamInstEnv
+
+       ; (qtvs, pats, res_kind, stupid_theta)
+             <- tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs
+                                fixity hs_ctxt hs_pats m_ksig hs_cons
+
+       -- Eta-reduce the axiom if possible
+       -- Quite tricky: see Note [Eta-reduction for data families]
+       ; let (eta_pats, eta_tcbs) = eta_reduce fam_tc pats
+             eta_tvs       = map binderVar eta_tcbs
+             post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs
+
+             full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs
+                            (tyCoVarsOfType (mkSpecForAllTys eta_tvs res_kind))
+                         ++ eta_tcbs
+                 -- Put the eta-removed tyvars at the end
+                 -- Remember, qtvs is in arbitrary order, except kind vars are
+                 -- first, so there is no reason to suppose that the eta_tvs
+                 -- (obtained from the pats) are at the end (Trac #11148)
+
+       -- Eta-expand the representation tycon until it has reult kind *
+       -- See also Note [Arity of data families] in FamInstEnv
+       -- NB: we can do this after eta-reducing the axiom, because if
+       --     we did it before the "extra" tvs from etaExpandAlgTyCon
+       --     would always be eta-reduced
+       ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind
+       ; checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind)
+       ; let extra_pats  = map (mkTyVarTy . binderVar) extra_tcbs
+             all_pats    = pats `chkAppend` extra_pats
+             orig_res_ty = mkTyConApp fam_tc all_pats
+             ty_binders  = full_tcbs `chkAppend` extra_tcbs
+
+       ; traceTc "tcDataFamInstDecl" $
+         vcat [ text "Fam tycon:" <+> ppr fam_tc
+              , text "Pats:" <+> ppr pats
+              , text "visibliities:" <+> ppr (tcbVisibilities fam_tc pats)
+              , text "all_pats:" <+> ppr all_pats
+              , text "ty_binders" <+> ppr ty_binders
+              , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc)
+              , text "eta_pats" <+> ppr eta_pats
+              , text "eta_tcbs" <+> ppr eta_tcbs ]
+
+       ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->
+           do { data_cons <- tcExtendTyVarEnv qtvs $
+                             -- For H98 decls, the tyvars scope
+                             -- over the data constructors
+                             tcConDecls rec_rep_tc ty_binders orig_res_ty hs_cons
+
+              ; rep_tc_name <- newFamInstTyConName lfam_name pats
+              ; axiom_name  <- newFamInstAxiomName lfam_name [pats]
+              ; tc_rhs <- case new_or_data of
+                     DataType -> return (mkDataTyConRhs data_cons)
+                     NewType  -> ASSERT( not (null data_cons) )
+                                 mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)
+
+              ; let axiom  = mkSingleCoAxiom Representational axiom_name
+                                 post_eta_qtvs eta_tvs [] fam_tc eta_pats
+                                 (mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs))
+                    parent = DataFamInstTyCon axiom fam_tc all_pats
+
+                      -- NB: Use the full ty_binders from the pats. See bullet toward
+                      -- the end of Note [Data type families] in TyCon
+                    rep_tc   = mkAlgTyCon rep_tc_name
+                                          ty_binders liftedTypeKind
+                                          (map (const Nominal) ty_binders)
+                                          (fmap unLoc cType) stupid_theta
+                                          tc_rhs parent
+                                          gadt_syntax
+                 -- We always assume that indexed types are recursive.  Why?
+                 -- (1) Due to their open nature, we can never be sure that a
+                 -- further instance might not introduce a new recursive
+                 -- dependency.  (2) They are always valid loop breakers as
+                 -- they involve a coercion.
+              ; return (rep_tc, axiom) }
+
+       -- Remember to check validity; no recursion to worry about here
+       -- Check that left-hand sides are ok (mono-types, no type families,
+       -- consistent instantiations, etc)
+       ; let ax_branch = coAxiomSingleBranch axiom
+       ; checkConsistentFamInst mb_clsinfo fam_tc ax_branch
+       ; checkValidCoAxBranch fam_tc ax_branch
+       ; checkValidTyCon rep_tc
+
+       ; let m_deriv_info = case derivs of
+               L _ []    -> Nothing
+               L _ preds ->
+                 Just $ DerivInfo { di_rep_tc  = rep_tc
+                                  , di_clauses = preds
+                                  , di_ctxt    = tcMkDataFamInstCtxt decl }
+
+       ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom
+       ; return (fam_inst, m_deriv_info) }
+  where
+    eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder])
+    -- See Note [Eta reduction for data families] in FamInstEnv
+    -- Splits the incoming patterns into two: the [TyVar]
+    -- are the patterns that can be eta-reduced away.
+    -- e.g.     T [a] Int a d c   ==>  (T [a] Int a, [d,c])
+    --
+    -- NB: quadratic algorithm, but types are small here
+    eta_reduce fam_tc pats
+        = go (reverse (zip3 pats fvs_s vis_s)) []
+        where
+          vis_s :: [TyConBndrVis]
+          vis_s = tcbVisibilities fam_tc pats
+
+          fvs_s :: [TyCoVarSet]  -- 1-1 correspondence with pats
+                                 -- Each elt is the free vars of all /earlier/ pats
+          (_, fvs_s) = mapAccumL add_fvs emptyVarSet pats
+          add_fvs fvs pat = (fvs `unionVarSet` tyCoVarsOfType pat, fvs)
+
+    go ((pat, fvs_to_the_left, tcb_vis):pats) etad_tvs
+      | Just tv <- getTyVar_maybe pat
+      , not (tv `elemVarSet` fvs_to_the_left)
+      = go pats (Bndr tv tcb_vis : etad_tvs)
+    go pats etad_tvs = (reverse (map fstOf3 pats), etad_tvs)
+
+tcDataFamInstDecl _ _ = panic "tcDataFamInstDecl"
+
+-----------------------
+tcDataFamHeader :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn]
+                -> LexicalFixity -> LHsContext GhcRn
+                -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn]
+                -> TcM ([TyVar], [Type], Kind, ThetaType)
+-- The "header" is the part other than the data constructors themselves
+-- e.g.  data instance D [a] :: * -> * where ...
+-- Here the "header" is the bit before the "where"
+tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksig hs_cons
+  = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, res_kind)))
+            <- pushTcLevelM_                                $
+               solveEqualities                              $
+               bindImplicitTKBndrs_Q_Skol imp_vars          $
+               bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $
+               do { stupid_theta <- tcHsContext hs_ctxt
+                  ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats
+                    -- Ensure that the instance is consistent with its
+                    -- parent class
+                  ; addConsistencyConstraints mb_clsinfo lhs_ty
+                  ; mapM_ (wrapLocM_ kcConDecl) hs_cons
+                  ; res_kind <- tc_kind_sig m_ksig
+                  ; lhs_ty <- checkExpectedKind YesSaturation pp_lhs lhs_ty lhs_kind res_kind
+                  ; return (stupid_theta, lhs_ty, res_kind) }
+
+       -- See TcTyClsDecls Note [Generalising in tcFamTyPatsGuts]
+       -- This code (and the stuff immediately above) is very similar
+       -- to that in tcFamTyInstEqnGuts.  Maybe we should abstract the
+       -- common code; but for the moment I concluded that it's
+       -- clearer to duplicate it.  Still, if you fix a bug here,
+       -- check there too!
+       ; let scoped_tvs = imp_tvs ++ exp_tvs
+       ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)
+       ; qtvs <- quantifyTyVars emptyVarSet dvs
+
+       -- Zonk the patterns etc into the Type world
+       ; (ze, qtvs)   <- zonkTyBndrs qtvs
+       ; lhs_ty       <- zonkTcTypeToTypeX ze lhs_ty
+       ; res_kind     <- zonkTcTypeToTypeX ze res_kind
+       ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta
+
+       -- Check that type patterns match the class instance head
+       ; let pats = unravelFamInstPats lhs_ty
+       ; return (qtvs, pats, res_kind, stupid_theta) }
+  where
+    fam_name  = tyConName fam_tc
+    data_ctxt = DataKindCtxt fam_name
+    pp_lhs    = pprHsFamInstLHS fam_name mb_bndrs hs_pats fixity hs_ctxt
+    exp_bndrs = mb_bndrs `orElse` []
+
+    -- See Note [Result kind signature for a data family instance]
+    tc_kind_sig Nothing
+      = return liftedTypeKind
+    tc_kind_sig (Just hs_kind)
+      = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind
+           ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind
+           ; lvl <- getTcLevel
+           ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs
+             -- Perhaps surprisingly, we don't need the skolemised tvs themselves
+           ; return (substTy subst inner_kind) }
+
+{- Note [Result kind signature for a data family instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The expected type might have a forall at the type. Normally, we
+can't skolemise in kinds because we don't have type-level lambda.
+But here, we're at the top-level of an instance declaration, so
+we actually have a place to put the regeneralised variables.
+Thus: skolemise away. cf. Inst.deeplySkolemise and TcUnify.tcSkolemise
+Examples in indexed-types/should_compile/T12369
+
+Note [Eta-reduction for data families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   data D :: * -> * -> * -> * -> *
+
+   data instance D [(a,b)] p q :: * -> * where
+      D1 :: blah1
+      D2 :: blah2
+
+Then we'll generate a representation data type
+  data Drep a b p q z where
+      D1 :: blah1
+      D2 :: blah2
+
+and an axiom to connect them
+  axiom AxDrep forall a b p q z. D [(a,b]] p q z = Drep a b p q z
+
+except that we'll eta-reduce the axiom to
+  axiom AxDrep forall a b. D [(a,b]] = Drep a b
+There are several fiddly subtleties lurking here
+
+* The representation tycon Drep is parameerised over the free
+  variables of the pattern, in no particular order. So there is no
+  guarantee that 'p' and 'q' will come last in Drep's parameters, and
+  in the right order.  So, if the /patterns/ of the family insatance
+  are eta-redcible, we re-order Drep's parameters to put the
+  eta-reduced type variables last.
+
+* Although we eta-reduce the axiom, we eta-/expand/ the representation
+  tycon Drep.  The kind of D says it takses four arguments, but the
+  data instance header only supplies three.  But the AlgTyCOn for Drep
+  itself must have enough TyConBinders so that its result kind is Type.
+  So, with etaExpandAlgTyCon we make up some extra TyConBinders
+
+* The result kind in the instance might be a polykind, like this:
+     data family DP a :: forall k. k -> *
+     data instance DP [b] :: forall k1 k2. (k1,k2) -> *
+
+  So in type-checking the LHS (DP Int) we need to check that it is
+  more polymorphic than the signature.  To do that we must skolemise
+  the siganture and istantiate the call of DP.  So we end up with
+     data instance DP [b] @(k1,k2) (z :: (k1,k2)) where
+
+  Note that we must parameterise the representation tycon DPrep over
+  'k1' and 'k2', as well as 'b'.
+
+  The skolemise bit is done in tc_kind_sig, while the instantiate bit
+  is done by the checkExpectedKind that immediately follows.
+
+* Very fiddly point.  When we eta-reduce to
+     axiom AxDrep forall a b. D [(a,b]] = Drep a b
+
+  we want the kind of (D [(a,b)]) to be the same as the kind of
+  (Drep a b).  This ensures that applying the axiom doesn't change the
+  kind.  Why is that hard?  Because the kind of (Drep a b) depends on
+  the TyConBndrVis on Drep's arguments. In particular do we have
+    (forall (k::*). blah) or (* -> blah)?
+
+  We must match whatever D does!  In Trac #15817 we had
+      data family X a :: forall k. * -> *   -- Note: a forall that is not used
+      data instance X Int b = MkX
+
+  So the data instance is really
+      data istance X Int @k b = MkX
+
+  The axiom will look like
+      axiom    X Int = Xrep
+
+  and it's important that XRep :: forall k * -> *, following X.
+
+  To achieve this we get the TyConBndrVis flags from tcbVisibilities,
+  and use those flags for any eta-reduced arguments.  Sigh.
+
+* The final turn of the knife is that tcbVisibilities is itself
+  tricky to sort out.  Consider
+      data family D k :: k
+  Then consider D (forall k2. k2 -> k2) Type Type
+  The visibilty flags on an application of D may affected by the arguments
+  themselves.  Heavy sigh.  But not truly hard; that's what tcbVisibilities
+  does.
+
+-}
+
+
+{- *********************************************************************
+*                                                                      *
+      Class instance declarations, pass 2
+*                                                                      *
+********************************************************************* -}
+
+tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn]
+             -> TcM (LHsBinds GhcTc)
+-- (a) From each class declaration,
+--      generate any default-method bindings
+-- (b) From each instance decl
+--      generate the dfun binding
+
+tcInstDecls2 tycl_decls inst_decls
+  = do  { -- (a) Default methods from class decls
+          let class_decls = filter (isClassDecl . unLoc) tycl_decls
+        ; dm_binds_s <- mapM tcClassDecl2 class_decls
+        ; let dm_binds = unionManyBags dm_binds_s
+
+          -- (b) instance declarations
+        ; let dm_ids = collectHsBindsBinders dm_binds
+              -- Add the default method Ids (again)
+              -- (they were arready added in TcTyDecls.tcAddImplicits)
+              -- See Note [Default methods in the type environment]
+        ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $
+                          mapM tcInstDecl2 inst_decls
+
+          -- Done
+        ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
+
+{- Note [Default methods in the type environment]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The default method Ids are already in the type environment (see Note
+[Default method Ids and Template Haskell] in TcTyDcls), BUT they
+don't have their InlinePragmas yet.  Usually that would not matter,
+because the simplifier propagates information from binding site to
+use.  But, unusually, when compiling instance decls we *copy* the
+INLINE pragma from the default method to the method for that
+particular operation (see Note [INLINE and default methods] below).
+
+So right here in tcInstDecls2 we must re-extend the type envt with
+the default method Ids replete with their INLINE pragmas.  Urk.
+-}
+
+tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc)
+            -- Returns a binding for the dfun
+tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
+  = recoverM (return emptyLHsBinds)             $
+    setSrcSpan loc                              $
+    addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
+    do {  -- Instantiate the instance decl with skolem constants
+       ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id
+       ; dfun_ev_vars <- newEvVars dfun_theta
+                     -- We instantiate the dfun_id with superSkolems.
+                     -- See Note [Subtle interaction of recursion and overlap]
+                     -- and Note [Binding when looking up instances]
+
+       ; let (clas, inst_tys) = tcSplitDFunHead inst_head
+             (class_tyvars, sc_theta, _, op_items) = classBigSig clas
+             sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta
+
+       ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta'])
+
+                      -- Deal with 'SPECIALISE instance' pragmas
+                      -- See Note [SPECIALISE instance pragmas]
+       ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
+
+         -- Typecheck superclasses and methods
+         -- See Note [Typechecking plan for instance declarations]
+       ; dfun_ev_binds_var <- newTcEvBinds
+       ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var
+       ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics))
+             <- pushTcLevelM $
+                do { (sc_ids, sc_binds, sc_implics)
+                        <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars
+                                          inst_tys dfun_ev_binds
+                                          sc_theta'
+
+                      -- Typecheck the methods
+                   ; (meth_ids, meth_binds, meth_implics)
+                        <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars
+                                     inst_tys dfun_ev_binds spec_inst_info
+                                     op_items ibinds
+
+                   ; return ( sc_ids     ++          meth_ids
+                            , sc_binds   `unionBags` meth_binds
+                            , sc_implics `unionBags` meth_implics ) }
+
+       ; imp <- newImplication
+       ; emitImplication $
+         imp { ic_tclvl  = tclvl
+             , ic_skols  = inst_tyvars
+             , ic_given  = dfun_ev_vars
+             , ic_wanted = mkImplicWC sc_meth_implics
+             , ic_binds  = dfun_ev_binds_var
+             , ic_info   = InstSkol }
+
+       -- Create the result bindings
+       ; self_dict <- newDict clas inst_tys
+       ; let class_tc      = classTyCon clas
+             [dict_constr] = tyConDataCons class_tc
+             dict_bind     = mkVarBind self_dict (L loc con_app_args)
+
+                     -- We don't produce a binding for the dict_constr; instead we
+                     -- rely on the simplifier to unfold this saturated application
+                     -- We do this rather than generate an HsCon directly, because
+                     -- it means that the special cases (e.g. dictionary with only one
+                     -- member) are dealt with by the common MkId.mkDataConWrapId
+                     -- code rather than needing to be repeated here.
+                     --    con_app_tys  = MkD ty1 ty2
+                     --    con_app_scs  = MkD ty1 ty2 sc1 sc2
+                     --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
+             con_app_tys  = mkHsWrap (mkWpTyApps inst_tys)
+                                  (HsConLikeOut noExt (RealDataCon dict_constr))
+                       -- NB: We *can* have covars in inst_tys, in the case of
+                       -- promoted GADT constructors.
+
+             con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids
+
+             app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc
+             app_to_meth fun meth_id = HsApp noExt (L loc fun)
+                                            (L loc (wrapId arg_wrapper meth_id))
+
+             inst_tv_tys = mkTyVarTys inst_tyvars
+             arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
+
+             is_newtype = isNewTyCon class_tc
+             dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids
+             dfun_spec_prags
+                | is_newtype = SpecPrags []
+                | otherwise  = SpecPrags spec_inst_prags
+                    -- Newtype dfuns just inline unconditionally,
+                    -- so don't attempt to specialise them
+
+             export = ABE { abe_ext  = noExt
+                          , abe_wrap = idHsWrapper
+                          , abe_poly = dfun_id_w_prags
+                          , abe_mono = self_dict
+                          , abe_prags = dfun_spec_prags }
+                          -- NB: see Note [SPECIALISE instance pragmas]
+             main_bind = AbsBinds { abs_ext = noExt
+                                  , abs_tvs = inst_tyvars
+                                  , abs_ev_vars = dfun_ev_vars
+                                  , abs_exports = [export]
+                                  , abs_ev_binds = []
+                                  , abs_binds = unitBag dict_bind
+                                  , abs_sig = True }
+
+       ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds)
+       }
+ where
+   dfun_id = instanceDFunId ispec
+   loc     = getSrcSpan dfun_id
+
+addDFunPrags :: DFunId -> [Id] -> DFunId
+-- DFuns need a special Unfolding and InlinePrag
+--    See Note [ClassOp/DFun selection]
+--    and Note [Single-method classes]
+-- It's easiest to create those unfoldings right here, where
+-- have all the pieces in hand, even though we are messing with
+-- Core at this point, which the typechecker doesn't usually do
+-- However we take care to build the unfolding using the TyVars from
+-- the DFunId rather than from the skolem pieces that the typechecker
+-- is messing with.
+addDFunPrags dfun_id sc_meth_ids
+ | is_newtype
+  = dfun_id `setIdUnfolding`  mkInlineUnfoldingWithArity 0 con_app
+            `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
+ | otherwise
+ = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_bndrs dict_con dict_args
+           `setInlinePragma` dfunInlinePragma
+ where
+   con_app    = mkLams dfun_bndrs $
+                mkApps (Var (dataConWrapId dict_con)) dict_args
+                 -- mkApps is OK because of the checkForLevPoly call in checkValidClass
+                 -- See Note [Levity polymorphism checking] in DsMonad
+   dict_args  = map Type inst_tys ++
+                [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids]
+
+   (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id)
+   ev_ids      = mkTemplateLocalsNum 1                    dfun_theta
+   dfun_bndrs  = dfun_tvs ++ ev_ids
+   clas_tc     = classTyCon clas
+   [dict_con]  = tyConDataCons clas_tc
+   is_newtype  = isNewTyCon clas_tc
+
+wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id)
+wrapId wrapper id = mkHsWrap wrapper (HsVar noExt (noLoc id))
+
+{- Note [Typechecking plan for instance declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For instance declarations we generate the following bindings and implication
+constraints.  Example:
+
+   instance Ord a => Ord [a] where compare = <compare-rhs>
+
+generates this:
+
+   Bindings:
+      -- Method bindings
+      $ccompare :: forall a. Ord a => a -> a -> Ordering
+      $ccompare = /\a \(d:Ord a). let <meth-ev-binds> in ...
+
+      -- Superclass bindings
+      $cp1Ord :: forall a. Ord a => Eq [a]
+      $cp1Ord = /\a \(d:Ord a). let <sc-ev-binds>
+               in dfEqList (dw :: Eq a)
+
+   Constraints:
+      forall a. Ord a =>
+                -- Method constraint
+             (forall. (empty) => <constraints from compare-rhs>)
+                -- Superclass constraint
+          /\ (forall. (empty) => dw :: Eq a)
+
+Notice that
+
+ * Per-meth/sc implication.  There is one inner implication per
+   superclass or method, with no skolem variables or givens.  The only
+   reason for this one is to gather the evidence bindings privately
+   for this superclass or method.  This implication is generated
+   by checkInstConstraints.
+
+ * Overall instance implication. There is an overall enclosing
+   implication for the whole instance declaration, with the expected
+   skolems and givens.  We need this to get the correct "redundant
+   constraint" warnings, gathering all the uses from all the methods
+   and superclasses.  See TcSimplify Note [Tracking redundant
+   constraints]
+
+ * The given constraints in the outer implication may generate
+   evidence, notably by superclass selection.  Since the method and
+   superclass bindings are top-level, we want that evidence copied
+   into *every* method or superclass definition.  (Some of it will
+   be usused in some, but dead-code elimination will drop it.)
+
+   We achieve this by putting the evidence variable for the overall
+   instance implication into the AbsBinds for each method/superclass.
+   Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses.
+   (And that in turn is why the abs_ev_binds field of AbBinds is a
+   [TcEvBinds] rather than simply TcEvBinds.
+
+   This is a bit of a hack, but works very nicely in practice.
+
+ * Note that if a method has a locally-polymorphic binding, there will
+   be yet another implication for that, generated by tcPolyCheck
+   in tcMethodBody. E.g.
+          class C a where
+            foo :: forall b. Ord b => blah
+
+
+************************************************************************
+*                                                                      *
+      Type-checking superclasses
+*                                                                      *
+************************************************************************
+-}
+
+tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType]
+               -> TcEvBinds
+               -> TcThetaType
+               -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication)
+-- Make a new top-level function binding for each superclass,
+-- something like
+--    $Ordp1 :: forall a. Ord a => Eq [a]
+--    $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d)
+--
+-- See Note [Recursive superclasses] for why this is so hard!
+-- In effect, we build a special-purpose solver for the first step
+-- of solving each superclass constraint
+tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta
+  = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..])
+       ; return (ids, listToBag binds, listToBag implics) }
+  where
+    loc = getSrcSpan dfun_id
+    size = sizeTypes inst_tys
+    tc_super (sc_pred, n)
+      = do { (sc_implic, ev_binds_var, sc_ev_tm)
+                <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred
+
+           ; sc_top_name  <- newName (mkSuperDictAuxOcc n (getOccName cls))
+           ; sc_ev_id     <- newEvVar sc_pred
+           ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm
+           ; let sc_top_ty = mkInvForAllTys tyvars (mkLamTypes dfun_evs sc_pred)
+                 sc_top_id = mkLocalId sc_top_name sc_top_ty
+                 export = ABE { abe_ext  = noExt
+                              , abe_wrap = idHsWrapper
+                              , abe_poly = sc_top_id
+                              , abe_mono = sc_ev_id
+                              , abe_prags = noSpecPrags }
+                 local_ev_binds = TcEvBinds ev_binds_var
+                 bind = AbsBinds { abs_ext      = noExt
+                                 , abs_tvs      = tyvars
+                                 , abs_ev_vars  = dfun_evs
+                                 , abs_exports  = [export]
+                                 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
+                                 , abs_binds    = emptyBag
+                                 , abs_sig      = False }
+           ; return (sc_top_id, L loc bind, sc_implic) }
+
+-------------------
+checkInstConstraints :: TcM result
+                     -> TcM (Implication, EvBindsVar, result)
+-- See Note [Typechecking plan for instance declarations]
+checkInstConstraints thing_inside
+  = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints  $
+                                    thing_inside
+
+       ; ev_binds_var <- newTcEvBinds
+       ; implic <- newImplication
+       ; let implic' = implic { ic_tclvl  = tclvl
+                              , ic_wanted = wanted
+                              , ic_binds  = ev_binds_var
+                              , ic_info   = InstSkol }
+
+       ; return (implic', ev_binds_var, result) }
+
+{-
+Note [Recursive superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Trac #3731, #4809, #5751, #5913, #6117, #6161, which all
+describe somewhat more complicated situations, but ones
+encountered in practice.
+
+See also tests tcrun020, tcrun021, tcrun033, and Trac #11427.
+
+----- THE PROBLEM --------
+The problem is that it is all too easy to create a class whose
+superclass is bottom when it should not be.
+
+Consider the following (extreme) situation:
+        class C a => D a where ...
+        instance D [a] => D [a] where ...   (dfunD)
+        instance C [a] => C [a] where ...   (dfunC)
+Although this looks wrong (assume D [a] to prove D [a]), it is only a
+more extreme case of what happens with recursive dictionaries, and it
+can, just about, make sense because the methods do some work before
+recursing.
+
+To implement the dfunD we must generate code for the superclass C [a],
+which we had better not get by superclass selection from the supplied
+argument:
+       dfunD :: forall a. D [a] -> D [a]
+       dfunD = \d::D [a] -> MkD (scsel d) ..
+
+Otherwise if we later encounter a situation where
+we have a [Wanted] dw::D [a] we might solve it thus:
+     dw := dfunD dw
+Which is all fine except that now ** the superclass C is bottom **!
+
+The instance we want is:
+       dfunD :: forall a. D [a] -> D [a]
+       dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ...
+
+----- THE SOLUTION --------
+The basic solution is simple: be very careful about using superclass
+selection to generate a superclass witness in a dictionary function
+definition.  More precisely:
+
+  Superclass Invariant: in every class dictionary,
+                        every superclass dictionary field
+                        is non-bottom
+
+To achieve the Superclass Invariant, in a dfun definition we can
+generate a guaranteed-non-bottom superclass witness from:
+  (sc1) one of the dictionary arguments itself (all non-bottom)
+  (sc2) an immediate superclass of a smaller dictionary
+  (sc3) a call of a dfun (always returns a dictionary constructor)
+
+The tricky case is (sc2).  We proceed by induction on the size of
+the (type of) the dictionary, defined by TcValidity.sizeTypes.
+Let's suppose we are building a dictionary of size 3, and
+suppose the Superclass Invariant holds of smaller dictionaries.
+Then if we have a smaller dictionary, its immediate superclasses
+will be non-bottom by induction.
+
+What does "we have a smaller dictionary" mean?  It might be
+one of the arguments of the instance, or one of its superclasses.
+Here is an example, taken from CmmExpr:
+       class Ord r => UserOfRegs r a where ...
+(i1)   instance UserOfRegs r a => UserOfRegs r (Maybe a) where
+(i2)   instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
+
+For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a),
+since it is smaller than the thing we are building (UserOfRegs r (Maybe a).
+
+But for (i2) that isn't the case, so we must add an explicit, and
+perhaps surprising, (Ord r) argument to the instance declaration.
+
+Here's another example from Trac #6161:
+
+       class       Super a => Duper a  where ...
+       class Duper (Fam a) => Foo a    where ...
+(i3)   instance Foo a => Duper (Fam a) where ...
+(i4)   instance              Foo Float where ...
+
+It would be horribly wrong to define
+   dfDuperFam :: Foo a -> Duper (Fam a)  -- from (i3)
+   dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ...
+
+   dfFooFloat :: Foo Float               -- from (i4)
+   dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ...
+
+Now the Super superclass of Duper is definitely bottom!
+
+This won't happen because when processing (i3) we can use the
+superclasses of (Foo a), which is smaller, namely Duper (Fam a).  But
+that is *not* smaller than the target so we can't take *its*
+superclasses.  As a result the program is rightly rejected, unless you
+add (Super (Fam a)) to the context of (i3).
+
+Note [Solving superclass constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+How do we ensure that every superclass witness is generated by
+one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses].
+Answer:
+
+  * Superclass "wanted" constraints have CtOrigin of (ScOrigin size)
+    where 'size' is the size of the instance declaration. e.g.
+          class C a => D a where...
+          instance blah => D [a] where ...
+    The wanted superclass constraint for C [a] has origin
+    ScOrigin size, where size = size( D [a] ).
+
+  * (sc1) When we rewrite such a wanted constraint, it retains its
+    origin.  But if we apply an instance declaration, we can set the
+    origin to (ScOrigin infinity), thus lifting any restrictions by
+    making prohibitedSuperClassSolve return False.
+
+  * (sc2) ScOrigin wanted constraints can't be solved from a
+    superclass selection, except at a smaller type.  This test is
+    implemented by TcInteract.prohibitedSuperClassSolve
+
+  * The "given" constraints of an instance decl have CtOrigin
+    GivenOrigin InstSkol.
+
+  * When we make a superclass selection from InstSkol we use
+    a SkolemInfo of (InstSC size), where 'size' is the size of
+    the constraint whose superclass we are taking.  A similarly
+    when taking the superclass of an InstSC.  This is implemented
+    in TcCanonical.newSCWorkFromFlavored
+
+Note [Silent superclass arguments] (historical interest only)
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+NB1: this note describes our *old* solution to the
+     recursive-superclass problem. I'm keeping the Note
+     for now, just as institutional memory.
+     However, the code for silent superclass arguments
+     was removed in late Dec 2014
+
+NB2: the silent-superclass solution introduced new problems
+     of its own, in the form of instance overlap.  Tests
+     SilentParametersOverlapping, T5051, and T7862 are examples
+
+NB3: the silent-superclass solution also generated tons of
+     extra dictionaries.  For example, in monad-transformer
+     code, when constructing a Monad dictionary you had to pass
+     an Applicative dictionary; and to construct that you neede
+     a Functor dictionary. Yet these extra dictionaries were
+     often never used.  Test T3064 compiled *far* faster after
+     silent superclasses were eliminated.
+
+Our solution to this problem "silent superclass arguments".  We pass
+to each dfun some ``silent superclass arguments’’, which are the
+immediate superclasses of the dictionary we are trying to
+construct. In our example:
+       dfun :: forall a. C [a] -> D [a] -> D [a]
+       dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
+Notice the extra (dc :: C [a]) argument compared to the previous version.
+
+This gives us:
+
+     -----------------------------------------------------------
+     DFun Superclass Invariant
+     ~~~~~~~~~~~~~~~~~~~~~~~~
+     In the body of a DFun, every superclass argument to the
+     returned dictionary is
+       either   * one of the arguments of the DFun,
+       or       * constant, bound at top level
+     -----------------------------------------------------------
+
+This net effect is that it is safe to treat a dfun application as
+wrapping a dictionary constructor around its arguments (in particular,
+a dfun never picks superclasses from the arguments under the
+dictionary constructor). No superclass is hidden inside a dfun
+application.
+
+The extra arguments required to satisfy the DFun Superclass Invariant
+always come first, and are called the "silent" arguments.  You can
+find out how many silent arguments there are using Id.dfunNSilent;
+and then you can just drop that number of arguments to see the ones
+that were in the original instance declaration.
+
+DFun types are built (only) by MkId.mkDictFunId, so that is where we
+decide what silent arguments are to be added.
+-}
+
+{-
+************************************************************************
+*                                                                      *
+      Type-checking an instance method
+*                                                                      *
+************************************************************************
+
+tcMethod
+- Make the method bindings, as a [(NonRec, HsBinds)], one per method
+- Remembering to use fresh Name (the instance method Name) as the binder
+- Bring the instance method Ids into scope, for the benefit of tcInstSig
+- Use sig_fn mapping instance method Name -> instance tyvars
+- Ditto prag_fn
+- Use tcValBinds to do the checking
+-}
+
+tcMethods :: DFunId -> Class
+          -> [TcTyVar] -> [EvVar]
+          -> [TcType]
+          -> TcEvBinds
+          -> ([Located TcSpecPrag], TcPragEnv)
+          -> [ClassOpItem]
+          -> InstBindings GhcRn
+          -> TcM ([Id], LHsBinds GhcTc, Bag Implication)
+        -- The returned inst_meth_ids all have types starting
+        --      forall tvs. theta => ...
+tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
+                  dfun_ev_binds (spec_inst_prags, prag_fn) op_items
+                  (InstBindings { ib_binds      = binds
+                                , ib_tyvars     = lexical_tvs
+                                , ib_pragmas    = sigs
+                                , ib_extensions = exts
+                                , ib_derived    = is_derived })
+  = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $
+       -- The lexical_tvs scope over the 'where' part
+    do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
+       ; checkMinimalDefinition
+       ; checkMethBindMembership
+       ; (ids, binds, mb_implics) <- set_exts exts $
+                                     unset_warnings_deriving $
+                                     mapAndUnzip3M tc_item op_items
+       ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }
+  where
+    set_exts :: [LangExt.Extension] -> TcM a -> TcM a
+    set_exts es thing = foldr setXOptM thing es
+
+    -- See Note [Avoid -Winaccessible-code when deriving]
+    unset_warnings_deriving :: TcM a -> TcM a
+    unset_warnings_deriving
+      | is_derived = unsetWOptM Opt_WarnInaccessibleCode
+      | otherwise  = id
+
+    hs_sig_fn = mkHsSigFun sigs
+    inst_loc  = getSrcSpan dfun_id
+
+    ----------------------
+    tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)
+    tc_item (sel_id, dm_info)
+      | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn
+      = tcMethodBody clas tyvars dfun_ev_vars inst_tys
+                              dfun_ev_binds is_derived hs_sig_fn
+                              spec_inst_prags prags
+                              sel_id user_bind bndr_loc
+      | otherwise
+      = do { traceTc "tc_def" (ppr sel_id)
+           ; tc_default sel_id dm_info }
+
+    ----------------------
+    tc_default :: Id -> DefMethInfo
+               -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
+
+    tc_default sel_id (Just (dm_name, _))
+      = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name
+           ; tcMethodBody clas tyvars dfun_ev_vars inst_tys
+                          dfun_ev_binds is_derived hs_sig_fn
+                          spec_inst_prags inline_prags
+                          sel_id meth_bind inst_loc }
+
+    tc_default sel_id Nothing     -- No default method at all
+      = do { traceTc "tc_def: warn" (ppr sel_id)
+           ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
+                                       inst_tys sel_id
+           ; dflags <- getDynFlags
+           ; let meth_bind = mkVarBind meth_id $
+                             mkLHsWrap lam_wrapper (error_rhs dflags)
+           ; return (meth_id, meth_bind, Nothing) }
+      where
+        error_rhs dflags = L inst_loc $ HsApp noExt error_fun (error_msg dflags)
+        error_fun    = L inst_loc $
+                       wrapId (mkWpTyApps
+                                [ getRuntimeRep meth_tau, meth_tau])
+                              nO_METHOD_BINDING_ERROR_ID
+        error_msg dflags = L inst_loc (HsLit noExt (HsStringPrim NoSourceText
+                                              (unsafeMkByteString (error_string dflags))))
+        meth_tau     = funResultTy (piResultTys (idType sel_id) inst_tys)
+        error_string dflags = showSDoc dflags
+                              (hcat [ppr inst_loc, vbar, ppr sel_id ])
+        lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
+
+    ----------------------
+    -- Check if one of the minimal complete definitions is satisfied
+    checkMinimalDefinition
+      = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
+        warnUnsatisfiedMinimalDefinition
+
+    methodExists meth = isJust (findMethodBind meth binds prag_fn)
+
+    ----------------------
+    -- Check if any method bindings do not correspond to the class.
+    -- See Note [Mismatched class methods and associated type families].
+    checkMethBindMembership
+      = mapM_ (addErrTc . badMethodErr clas) mismatched_meths
+      where
+        bind_nms         = map unLoc $ collectMethodBinders binds
+        cls_meth_nms     = map (idName . fst) op_items
+        mismatched_meths = bind_nms `minusList` cls_meth_nms
+
+{-
+Note [Mismatched class methods and associated type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's entirely possible for someone to put methods or associated type family
+instances inside of a class in which it doesn't belong. For instance, we'd
+want to fail if someone wrote this:
+
+  instance Eq () where
+    type Rep () = Maybe
+    compare = undefined
+
+Since neither the type family `Rep` nor the method `compare` belong to the
+class `Eq`. Normally, this is caught in the renamer when resolving RdrNames,
+since that would discover that the parent class `Eq` is incorrect.
+
+However, there is a scenario in which the renamer could fail to catch this:
+if the instance was generated through Template Haskell, as in #12387. In that
+case, Template Haskell will provide fully resolved names (e.g.,
+`GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going
+on. For this reason, we also put an extra validity check for this in the
+typechecker as a last resort.
+
+Note [Avoid -Winaccessible-code when deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-Winaccessible-code can be particularly noisy when deriving instances for
+GADTs. Consider the following example (adapted from #8128):
+
+  data T a where
+    MkT1 :: Int -> T Int
+    MkT2 :: T Bool
+    MkT3 :: T Bool
+  deriving instance Eq (T a)
+  deriving instance Ord (T a)
+
+In the derived Ord instance, GHC will generate the following code:
+
+  instance Ord (T a) where
+    compare x y
+      = case x of
+          MkT2
+            -> case y of
+                 MkT1 {} -> GT
+                 MkT2    -> EQ
+                 _       -> LT
+          ...
+
+However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2
+differ, so if -Winaccessible-code is enabled, then deriving this instance will
+result in unwelcome warnings.
+
+One conceivable approach to fixing this issue would be to change `deriving Ord`
+such that it becomes smarter about not generating unreachable cases. This,
+however, would be a highly nontrivial refactor, as we'd have to propagate
+through typing information everywhere in the algorithm that generates Ord
+instances in order to determine which cases were unreachable. This seems like
+a lot of work for minimal gain, so we have opted not to go for this approach.
+
+Instead, we take the much simpler approach of always disabling
+-Winaccessible-code for derived code. To accomplish this, we do the following:
+
+1. In tcMethods (which typechecks method bindings), disable
+   -Winaccessible-code.
+2. When creating Implications during typechecking, record the Env
+   (through ic_env) at the time of creation. Since the Env also stores
+   DynFlags, this will remember that -Winaccessible-code was disabled over
+   the scope of that implication.
+3. After typechecking comes error reporting, where GHC must decide how to
+   report inaccessible code to the user, on an Implication-by-Implication
+   basis. If an Implication's DynFlags indicate that -Winaccessible-code was
+   disabled, then don't bother reporting it. That's it!
+-}
+
+------------------------
+tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]
+             -> TcEvBinds -> Bool
+             -> HsSigFun
+             -> [LTcSpecPrag] -> [LSig GhcRn]
+             -> Id -> LHsBind GhcRn -> SrcSpan
+             -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
+tcMethodBody clas tyvars dfun_ev_vars inst_tys
+                     dfun_ev_binds is_derived
+                     sig_fn spec_inst_prags prags
+                     sel_id (L bind_loc meth_bind) bndr_loc
+  = add_meth_ctxt $
+    do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc)
+       ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $
+                                            mkMethIds clas tyvars dfun_ev_vars
+                                                      inst_tys sel_id
+
+       ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }
+                       -- Substitute the local_meth_name for the binder
+                       -- NB: the binding is always a FunBind
+
+            -- taking instance signature into account might change the type of
+            -- the local_meth_id
+       ; (meth_implic, ev_binds_var, tc_bind)
+             <- checkInstConstraints $
+                tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind)
+
+       ; global_meth_id <- addInlinePrags global_meth_id prags
+       ; spec_prags     <- tcSpecPrags global_meth_id prags
+
+        ; let specs  = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
+              export = ABE { abe_ext   = noExt
+                           , abe_poly  = global_meth_id
+                           , abe_mono  = local_meth_id
+                           , abe_wrap  = idHsWrapper
+                           , abe_prags = specs }
+
+              local_ev_binds = TcEvBinds ev_binds_var
+              full_bind = AbsBinds { abs_ext      = noExt
+                                   , abs_tvs      = tyvars
+                                   , abs_ev_vars  = dfun_ev_vars
+                                   , abs_exports  = [export]
+                                   , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
+                                   , abs_binds    = tc_bind
+                                   , abs_sig      = True }
+
+        ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }
+  where
+        -- For instance decls that come from deriving clauses
+        -- we want to print out the full source code if there's an error
+        -- because otherwise the user won't see the code at all
+    add_meth_ctxt thing
+      | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing
+      | otherwise  = thing
+
+tcMethodBodyHelp :: HsSigFun -> Id -> TcId
+                 -> LHsBind GhcRn -> TcM (LHsBinds GhcTcId)
+tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
+  | Just hs_sig_ty <- hs_sig_fn sel_name
+              -- There is a signature in the instance
+              -- See Note [Instance method signatures]
+  = do { let ctxt = FunSigCtxt sel_name True
+       ; (sig_ty, hs_wrap)
+             <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $
+                do { inst_sigs <- xoptM LangExt.InstanceSigs
+                   ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)
+                   ; sig_ty  <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty
+                   ; let local_meth_ty = idType local_meth_id
+                   ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $
+                                tcSubType_NC ctxt sig_ty local_meth_ty
+                   ; return (sig_ty, hs_wrap) }
+
+       ; inner_meth_name <- newName (nameOccName sel_name)
+       ; let inner_meth_id  = mkLocalId inner_meth_name sig_ty
+             inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id
+                                          , sig_ctxt = ctxt
+                                          , sig_loc  = getLoc (hsSigType hs_sig_ty) }
+
+
+       ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
+
+       ; let export = ABE { abe_ext   = noExt
+                          , abe_poly  = local_meth_id
+                          , abe_mono  = inner_id
+                          , abe_wrap  = hs_wrap
+                          , abe_prags = noSpecPrags }
+
+       ; return (unitBag $ L (getLoc meth_bind) $
+                 AbsBinds { abs_ext = noExt, abs_tvs = [], abs_ev_vars = []
+                          , abs_exports = [export]
+                          , abs_binds = tc_bind, abs_ev_binds = []
+                          , abs_sig = True }) }
+
+  | otherwise  -- No instance signature
+  = do { let ctxt = FunSigCtxt sel_name False
+                    -- False <=> don't report redundant constraints
+                    -- The signature is not under the users control!
+             tc_sig = completeSigFromId ctxt local_meth_id
+              -- Absent a type sig, there are no new scoped type variables here
+              -- Only the ones from the instance decl itself, which are already
+              -- in scope.  Example:
+              --      class C a where { op :: forall b. Eq b => ... }
+              --      instance C [c] where { op = <rhs> }
+              -- In <rhs>, 'c' is scope but 'b' is not!
+
+       ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind
+       ; return tc_bind }
+
+  where
+    sel_name   = idName sel_id
+    no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;
+                                -- they are all for meth_id
+
+
+------------------------
+mkMethIds :: Class -> [TcTyVar] -> [EvVar]
+          -> [TcType] -> Id -> TcM (TcId, TcId)
+             -- returns (poly_id, local_id), but ignoring any instance signature
+             -- See Note [Instance method signatures]
+mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
+  = do  { poly_meth_name  <- newName (mkClassOpAuxOcc sel_occ)
+        ; local_meth_name <- newName sel_occ
+                  -- Base the local_meth_name on the selector name, because
+                  -- type errors from tcMethodBody come from here
+        ; let poly_meth_id  = mkLocalId poly_meth_name  poly_meth_ty
+              local_meth_id = mkLocalId local_meth_name local_meth_ty
+
+        ; return (poly_meth_id, local_meth_id) }
+  where
+    sel_name      = idName sel_id
+    sel_occ       = nameOccName sel_name
+    local_meth_ty = instantiateMethod clas sel_id inst_tys
+    poly_meth_ty  = mkSpecSigmaTy tyvars theta local_meth_ty
+    theta         = map idType dfun_ev_vars
+
+methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)
+methSigCtxt sel_name sig_ty meth_ty env0
+  = do { (env1, sig_ty)  <- zonkTidyTcType env0 sig_ty
+       ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty
+       ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name))
+                      2 (vcat [ text "is more general than its signature in the class"
+                              , text "Instance sig:" <+> ppr sig_ty
+                              , text "   Class sig:" <+> ppr meth_ty ])
+       ; return (env2, msg) }
+
+misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc
+misplacedInstSig name hs_ty
+  = vcat [ hang (text "Illegal type signature in instance declaration:")
+              2 (hang (pprPrefixName name)
+                    2 (dcolon <+> ppr hs_ty))
+         , text "(Use InstanceSigs to allow this)" ]
+
+{- Note [Instance method signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With -XInstanceSigs we allow the user to supply a signature for the
+method in an instance declaration.  Here is an artificial example:
+
+       data T a = MkT a
+       instance Ord a => Ord (T a) where
+         (>) :: forall b. b -> b -> Bool
+         (>) = error "You can't compare Ts"
+
+The instance signature can be *more* polymorphic than the instantiated
+class method (in this case: Age -> Age -> Bool), but it cannot be less
+polymorphic.  Moreover, if a signature is given, the implementation
+code should match the signature, and type variables bound in the
+singature should scope over the method body.
+
+We achieve this by building a TcSigInfo for the method, whether or not
+there is an instance method signature, and using that to typecheck
+the declaration (in tcMethodBody).  That means, conveniently,
+that the type variables bound in the signature will scope over the body.
+
+What about the check that the instance method signature is more
+polymorphic than the instantiated class method type?  We just do a
+tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like
+this (for the example above
+
+ AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a]
+         , abs_exports
+             = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool
+                        , gr_lcl :: T a -> T a -> Bool }
+         , abs_binds
+             = AbsBind { abs_tvs = [], abs_ev_vars = []
+                       , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool
+                                                , gr_inner :: forall b. b -> b -> Bool }
+                       , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = []
+                                             , ..etc.. }
+               } }
+
+Wow!  Three nested AbsBinds!
+ * The outer one abstracts over the tyvars and dicts for the instance
+ * The middle one is only present if there is an instance signature,
+   and does the impedance matching for that signature
+ * The inner one is for the method binding itself against either the
+   signature from the class, or the instance signature.
+-}
+
+----------------------
+mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
+        -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id
+        -- There are two sources:
+        --   * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
+        --   * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
+        --     These ones have the dfun inside, but [perhaps surprisingly]
+        --     the correct wrapper.
+        -- See Note [Handling SPECIALISE pragmas] in TcBinds
+mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me
+  = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
+  where
+    spec_prags_from_inst
+       | isInlinePragma (idInlinePragma meth_id)
+       = []  -- Do not inherit SPECIALISE from the instance if the
+             -- method is marked INLINE, because then it'll be inlined
+             -- and the specialisation would do nothing. (Indeed it'll provoke
+             -- a warning from the desugarer
+       | otherwise
+       = [ L inst_loc (SpecPrag meth_id wrap inl)
+         | L inst_loc (SpecPrag _       wrap inl) <- spec_inst_prags]
+
+
+mkDefMethBind :: Class -> [Type] -> Id -> Name
+              -> TcM (LHsBind GhcRn, [LSig GhcRn])
+-- The is a default method (vanailla or generic) defined in the class
+-- So make a binding   op = $dmop @t1 @t2
+-- where $dmop is the name of the default method in the class,
+-- and t1,t2 are the instance types.
+-- See Note [Default methods in instances] for why we use
+-- visible type application here
+mkDefMethBind clas inst_tys sel_id dm_name
+  = do  { dflags <- getDynFlags
+        ; dm_id <- tcLookupId dm_name
+        ; let inline_prag = idInlinePragma dm_id
+              inline_prags | isAnyInlinePragma inline_prag
+                           = [noLoc (InlineSig noExt fn inline_prag)]
+                           | otherwise
+                           = []
+                 -- Copy the inline pragma (if any) from the default method
+                 -- to this version. Note [INLINE and default methods]
+
+              fn   = noLoc (idName sel_id)
+              visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys
+                                      , tyConBinderArgFlag tcb /= Inferred ]
+              rhs  = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
+              bind = noLoc $ mkTopFunBind Generated fn $
+                             [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
+
+        ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
+                   (vcat [ppr clas <+> ppr inst_tys,
+                          nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
+
+       ; return (bind, inline_prags) }
+  where
+    mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
+    mk_vta fun ty = noLoc (HsAppType noExt fun (mkEmptyWildCardBndrs $ nlHsParTy
+                                                $ noLoc $ XHsType $ NHsCoreTy ty))
+       -- NB: use visible type application
+       -- See Note [Default methods in instances]
+
+----------------------
+derivBindCtxt :: Id -> Class -> [Type ] -> SDoc
+derivBindCtxt sel_id clas tys
+   = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id)
+          , nest 2 (text "in a derived instance for"
+                    <+> quotes (pprClassPred clas tys) <> colon)
+          , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ]
+
+warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()
+warnUnsatisfiedMinimalDefinition mindef
+  = do { warn <- woptM Opt_WarnMissingMethods
+       ; warnTc (Reason Opt_WarnMissingMethods) warn message
+       }
+  where
+    message = vcat [text "No explicit implementation for"
+                   ,nest 2 $ pprBooleanFormulaNice mindef
+                   ]
+
+{-
+Note [Export helper functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We arrange to export the "helper functions" of an instance declaration,
+so that they are not subject to preInlineUnconditionally, even if their
+RHS is trivial.  Reason: they are mentioned in the DFunUnfolding of
+the dict fun as Ids, not as CoreExprs, so we can't substitute a
+non-variable for them.
+
+We could change this by making DFunUnfoldings have CoreExprs, but it
+seems a bit simpler this way.
+
+Note [Default methods in instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+
+   class Baz v x where
+      foo :: x -> x
+      foo y = <blah>
+
+   instance Baz Int Int
+
+From the class decl we get
+
+   $dmfoo :: forall v x. Baz v x => x -> x
+   $dmfoo y = <blah>
+
+Notice that the type is ambiguous.  So we use Visible Type Application
+to disambiguate:
+
+   $dBazIntInt = MkBaz fooIntInt
+   fooIntInt = $dmfoo @Int @Int
+
+Lacking VTA we'd get ambiguity errors involving the default method.  This applies
+equally to vanilla default methods (Trac #1061) and generic default methods
+(Trac #12220).
+
+Historical note: before we had VTA we had to generate
+post-type-checked code, which took a lot more code, and didn't work for
+generic default methods.
+
+Note [INLINE and default methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Default methods need special case.  They are supposed to behave rather like
+macros.  For example
+
+  class Foo a where
+    op1, op2 :: Bool -> a -> a
+
+    {-# INLINE op1 #-}
+    op1 b x = op2 (not b) x
+
+  instance Foo Int where
+    -- op1 via default method
+    op2 b x = <blah>
+
+The instance declaration should behave
+
+   just as if 'op1' had been defined with the
+   code, and INLINE pragma, from its original
+   definition.
+
+That is, just as if you'd written
+
+  instance Foo Int where
+    op2 b x = <blah>
+
+    {-# INLINE op1 #-}
+    op1 b x = op2 (not b) x
+
+So for the above example we generate:
+
+  {-# INLINE $dmop1 #-}
+  -- $dmop1 has an InlineCompulsory unfolding
+  $dmop1 d b x = op2 d (not b) x
+
+  $fFooInt = MkD $cop1 $cop2
+
+  {-# INLINE $cop1 #-}
+  $cop1 = $dmop1 $fFooInt
+
+  $cop2 = <blah>
+
+Note carefully:
+
+* We *copy* any INLINE pragma from the default method $dmop1 to the
+  instance $cop1.  Otherwise we'll just inline the former in the
+  latter and stop, which isn't what the user expected
+
+* Regardless of its pragma, we give the default method an
+  unfolding with an InlineCompulsory source. That means
+  that it'll be inlined at every use site, notably in
+  each instance declaration, such as $cop1.  This inlining
+  must happen even though
+    a) $dmop1 is not saturated in $cop1
+    b) $cop1 itself has an INLINE pragma
+
+  It's vital that $dmop1 *is* inlined in this way, to allow the mutual
+  recursion between $fooInt and $cop1 to be broken
+
+* To communicate the need for an InlineCompulsory to the desugarer
+  (which makes the Unfoldings), we use the IsDefaultMethod constructor
+  in TcSpecPrags.
+
+
+************************************************************************
+*                                                                      *
+        Specialise instance pragmas
+*                                                                      *
+************************************************************************
+
+Note [SPECIALISE instance pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+   instance (Ix a, Ix b) => Ix (a,b) where
+     {-# SPECIALISE instance Ix (Int,Int) #-}
+     range (x,y) = ...
+
+We make a specialised version of the dictionary function, AND
+specialised versions of each *method*.  Thus we should generate
+something like this:
+
+  $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
+  {-# DFUN [$crangePair, ...] #-}
+  {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}
+  $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
+
+  $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
+  {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
+  $crange da db = <blah>
+
+The SPECIALISE pragmas are acted upon by the desugarer, which generate
+
+  dii :: Ix Int
+  dii = ...
+
+  $s$dfIxPair :: Ix ((Int,Int),(Int,Int))
+  {-# DFUN [$crangePair di di, ...] #-}
+  $s$dfIxPair = Ix ($crangePair di di) (...)
+
+  {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}
+
+  $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]
+  $c$crangePair = ...specialised RHS of $crangePair...
+
+  {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
+
+Note that
+
+  * The specialised dictionary $s$dfIxPair is very much needed, in case we
+    call a function that takes a dictionary, but in a context where the
+    specialised dictionary can be used.  See Trac #7797.
+
+  * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
+    it still has a DFunUnfolding.  See Note [ClassOp/DFun selection]
+
+  * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:
+       --> {ClassOp rule for range}     $crangePair Int Int d1 d2
+       --> {SPEC rule for $crangePair}  $s$crangePair
+    or thus:
+       --> {SPEC rule for $dfIxPair}    range $s$dfIxPair
+       --> {ClassOpRule for range}      $s$crangePair
+    It doesn't matter which way.
+
+  * We want to specialise the RHS of both $dfIxPair and $crangePair,
+    but the SAME HsWrapper will do for both!  We can call tcSpecPrag
+    just once, and pass the result (in spec_inst_info) to tcMethods.
+-}
+
+tcSpecInstPrags :: DFunId -> InstBindings GhcRn
+                -> TcM ([Located TcSpecPrag], TcPragEnv)
+tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
+  = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
+                            filter isSpecInstLSig uprags
+             -- The filter removes the pragmas for methods
+       ; return (spec_inst_prags, mkPragEnv uprags binds) }
+
+------------------------------
+tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag
+tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty)
+  = addErrCtxt (spec_ctxt prag) $
+    do  { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty
+        ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty
+        ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
+  where
+    spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)
+
+tcSpecInst _  _ = panic "tcSpecInst"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Error messages}
+*                                                                      *
+************************************************************************
+-}
+
+instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
+instDeclCtxt1 hs_inst_ty
+  = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
+
+instDeclCtxt2 :: Type -> SDoc
+instDeclCtxt2 dfun_ty
+  = inst_decl_ctxt (ppr (mkClassPred cls tys))
+  where
+    (_,_,cls,tys) = tcSplitDFunTy dfun_ty
+
+inst_decl_ctxt :: SDoc -> SDoc
+inst_decl_ctxt doc = hang (text "In the instance declaration for")
+                        2 (quotes doc)
+
+badBootFamInstDeclErr :: SDoc
+badBootFamInstDeclErr
+  = text "Illegal family instance in hs-boot file"
+
+notFamily :: TyCon -> SDoc
+notFamily tycon
+  = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)
+         , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")]
+
+assocInClassErr :: TyCon -> SDoc
+assocInClassErr name
+ = text "Associated type" <+> quotes (ppr name) <+>
+   text "must be inside a class instance"
+
+badFamInstDecl :: TyCon -> SDoc
+badFamInstDecl tc_name
+  = vcat [ text "Illegal family instance for" <+>
+           quotes (ppr tc_name)
+         , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ]
+
+notOpenFamily :: TyCon -> SDoc
+notOpenFamily tc
+  = text "Illegal instance for closed family" <+> quotes (ppr tc)
diff --git a/compiler/typecheck/TcInstDcls.hs-boot b/compiler/typecheck/TcInstDcls.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcInstDcls.hs-boot
@@ -0,0 +1,16 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+
+module TcInstDcls ( tcInstDecls1 ) where
+
+import HsSyn
+import TcRnTypes
+import TcEnv( InstInfo )
+import TcDeriv
+
+-- We need this because of the mutual recursion
+-- between TcTyClsDecls and TcInstDcls
+tcInstDecls1 :: [LInstDecl GhcRn]
+             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcInteract.hs
@@ -0,0 +1,2609 @@
+{-# LANGUAGE CPP #-}
+
+module TcInteract (
+     solveSimpleGivens,   -- Solves [Ct]
+     solveSimpleWanteds,  -- Solves Cts
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+import BasicTypes ( SwapFlag(..), isSwapped,
+                    infinity, IntWithInf, intGtLimit )
+import TcCanonical
+import TcFlatten
+import TcUnify( canSolveByUnification )
+import VarSet
+import Type
+import InstEnv( DFunInstType )
+import CoAxiom( sfInteractTop, sfInteractInert )
+
+import Var
+import TcType
+import PrelNames ( coercibleTyConKey,
+                   heqTyConKey, eqTyConKey, ipClassKey )
+import CoAxiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches )
+import Class
+import TyCon
+import FunDeps
+import FamInst
+import ClsInst( InstanceWhat(..), safeOverlap )
+import FamInstEnv
+import Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX )
+
+import TcEvidence
+import Outputable
+
+import TcRnTypes
+import TcSMonad
+import Bag
+import MonadUtils ( concatMapM, foldlM )
+
+import CoreSyn
+import Data.List( partition, deleteFirstsBy )
+import SrcLoc
+import VarEnv
+
+import Control.Monad
+import Maybes( isJust )
+import Pair (Pair(..))
+import Unique( hasKey )
+import DynFlags
+import Util
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Maybe
+
+{-
+**********************************************************************
+*                                                                    *
+*                      Main Interaction Solver                       *
+*                                                                    *
+**********************************************************************
+
+Note [Basic Simplifier Plan]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+1. Pick an element from the WorkList if there exists one with depth
+   less than our context-stack depth.
+
+2. Run it down the 'stage' pipeline. Stages are:
+      - canonicalization
+      - inert reactions
+      - spontaneous reactions
+      - top-level intreactions
+   Each stage returns a StopOrContinue and may have sideffected
+   the inerts or worklist.
+
+   The threading of the stages is as follows:
+      - If (Stop) is returned by a stage then we start again from Step 1.
+      - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to
+        the next stage in the pipeline.
+4. If the element has survived (i.e. ContinueWith x) the last stage
+   then we add him in the inerts and jump back to Step 1.
+
+If in Step 1 no such element exists, we have exceeded our context-stack
+depth and will simply fail.
+
+Note [Unflatten after solving the simple wanteds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We unflatten after solving the wc_simples of an implication, and before attempting
+to float. This means that
+
+ * The fsk/fmv flatten-skolems only survive during solveSimples.  We don't
+   need to worry about them across successive passes over the constraint tree.
+   (E.g. we don't need the old ic_fsk field of an implication.
+
+ * When floating an equality outwards, we don't need to worry about floating its
+   associated flattening constraints.
+
+ * Another tricky case becomes easy: Trac #4935
+       type instance F True a b = a
+       type instance F False a b = b
+
+       [w] F c a b ~ gamma
+       (c ~ True) => a ~ gamma
+       (c ~ False) => b ~ gamma
+
+   Obviously this is soluble with gamma := F c a b, and unflattening
+   will do exactly that after solving the simple constraints and before
+   attempting the implications.  Before, when we were not unflattening,
+   we had to push Wanted funeqs in as new givens.  Yuk!
+
+   Another example that becomes easy: indexed_types/should_fail/T7786
+      [W] BuriedUnder sub k Empty ~ fsk
+      [W] Intersect fsk inv ~ s
+      [w] xxx[1] ~ s
+      [W] forall[2] . (xxx[1] ~ Empty)
+                   => Intersect (BuriedUnder sub k Empty) inv ~ Empty
+
+Note [Running plugins on unflattened wanteds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There is an annoying mismatch between solveSimpleGivens and
+solveSimpleWanteds, because the latter needs to fiddle with the inert
+set, unflatten and zonk the wanteds.  It passes the zonked wanteds
+to runTcPluginsWanteds, which produces a replacement set of wanteds,
+some additional insolubles and a flag indicating whether to go round
+the loop again.  If so, prepareInertsForImplications is used to remove
+the previous wanteds (which will still be in the inert set).  Note
+that prepareInertsForImplications will discard the insolubles, so we
+must keep track of them separately.
+-}
+
+solveSimpleGivens :: [Ct] -> TcS ()
+solveSimpleGivens givens
+  | null givens  -- Shortcut for common case
+  = return ()
+  | otherwise
+  = do { traceTcS "solveSimpleGivens {" (ppr givens)
+       ; go givens
+       ; traceTcS "End solveSimpleGivens }" empty }
+  where
+    go givens = do { solveSimples (listToBag givens)
+                   ; new_givens <- runTcPluginsGiven
+                   ; when (notNull new_givens) $
+                     go new_givens }
+
+solveSimpleWanteds :: Cts -> TcS WantedConstraints
+-- NB: 'simples' may contain /derived/ equalities, floated
+--     out from a nested implication. So don't discard deriveds!
+-- The result is not necessarily zonked
+solveSimpleWanteds simples
+  = do { traceTcS "solveSimpleWanteds {" (ppr simples)
+       ; dflags <- getDynFlags
+       ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples })
+       ; traceTcS "solveSimpleWanteds end }" $
+             vcat [ text "iterations =" <+> ppr n
+                  , text "residual =" <+> ppr wc ]
+       ; return wc }
+  where
+    go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints)
+    go n limit wc
+      | n `intGtLimit` limit
+      = failTcS (hang (text "solveSimpleWanteds: too many iterations"
+                       <+> parens (text "limit =" <+> ppr limit))
+                    2 (vcat [ text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"
+                            , text "Simples =" <+> ppr simples
+                            , text "WC ="      <+> ppr wc ]))
+
+     | isEmptyBag (wc_simple wc)
+     = return (n,wc)
+
+     | otherwise
+     = do { -- Solve
+            (unif_count, wc1) <- solve_simple_wanteds wc
+
+            -- Run plugins
+          ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1
+             -- See Note [Running plugins on unflattened wanteds]
+
+          ; if unif_count == 0 && not rerun_plugin
+            then return (n, wc2)             -- Done
+            else do { traceTcS "solveSimple going round again:" $
+                      ppr unif_count $$ ppr rerun_plugin
+                    ; go (n+1) limit wc2 } }      -- Loop
+
+
+solve_simple_wanteds :: WantedConstraints -> TcS (Int, WantedConstraints)
+-- Try solving these constraints
+-- Affects the unification state (of course) but not the inert set
+-- The result is not necessarily zonked
+solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1 })
+  = nestTcS $
+    do { solveSimples simples1
+       ; (implics2, tv_eqs, fun_eqs, others) <- getUnsolvedInerts
+       ; (unif_count, unflattened_eqs) <- reportUnifications $
+                                          unflattenWanteds tv_eqs fun_eqs
+            -- See Note [Unflatten after solving the simple wanteds]
+       ; return ( unif_count
+                , WC { wc_simple = others `andCts` unflattened_eqs
+                     , wc_impl   = implics1 `unionBags` implics2 }) }
+
+{- Note [The solveSimpleWanteds loop]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Solving a bunch of simple constraints is done in a loop,
+(the 'go' loop of 'solveSimpleWanteds'):
+  1. Try to solve them; unflattening may lead to improvement that
+     was not exploitable during solving
+  2. Try the plugin
+  3. If step 1 did improvement during unflattening; or if the plugin
+     wants to run again, go back to step 1
+
+Non-obviously, improvement can also take place during
+the unflattening that takes place in step (1). See TcFlatten,
+See Note [Unflattening can force the solver to iterate]
+-}
+
+-- The main solver loop implements Note [Basic Simplifier Plan]
+---------------------------------------------------------------
+solveSimples :: Cts -> TcS ()
+-- Returns the final InertSet in TcS
+-- Has no effect on work-list or residual-implications
+-- The constraints are initially examined in left-to-right order
+
+solveSimples cts
+  = {-# SCC "solveSimples" #-}
+    do { updWorkListTcS (\wl -> foldrBag extendWorkListCt wl cts)
+       ; solve_loop }
+  where
+    solve_loop
+      = {-# SCC "solve_loop" #-}
+        do { sel <- selectNextWorkItem
+           ; case sel of
+              Nothing -> return ()
+              Just ct -> do { runSolverPipeline thePipeline ct
+                            ; solve_loop } }
+
+-- | Extract the (inert) givens and invoke the plugins on them.
+-- Remove solved givens from the inert set and emit insolubles, but
+-- return new work produced so that 'solveSimpleGivens' can feed it back
+-- into the main solver.
+runTcPluginsGiven :: TcS [Ct]
+runTcPluginsGiven
+  = do { plugins <- getTcPlugins
+       ; if null plugins then return [] else
+    do { givens <- getInertGivens
+       ; if null givens then return [] else
+    do { p <- runTcPlugins plugins (givens,[],[])
+       ; let (solved_givens, _, _) = pluginSolvedCts p
+             insols                = pluginBadCts p
+       ; updInertCans (removeInertCts solved_givens)
+       ; updInertIrreds (\irreds -> extendCtsList irreds insols)
+       ; return (pluginNewCts p) } } }
+
+-- | Given a bag of (flattened, zonked) wanteds, invoke the plugins on
+-- them and produce an updated bag of wanteds (possibly with some new
+-- work) and a bag of insolubles.  The boolean indicates whether
+-- 'solveSimpleWanteds' should feed the updated wanteds back into the
+-- main solver.
+runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints)
+runTcPluginsWanted wc@(WC { wc_simple = simples1, wc_impl = implics1 })
+  | isEmptyBag simples1
+  = return (False, wc)
+  | otherwise
+  = do { plugins <- getTcPlugins
+       ; if null plugins then return (False, wc) else
+
+    do { given <- getInertGivens
+       ; simples1 <- zonkSimples simples1    -- Plugin requires zonked inputs
+       ; let (wanted, derived) = partition isWantedCt (bagToList simples1)
+       ; p <- runTcPlugins plugins (given, derived, wanted)
+       ; let (_, _,                solved_wanted)   = pluginSolvedCts p
+             (_, unsolved_derived, unsolved_wanted) = pluginInputCts p
+             new_wanted                             = pluginNewCts p
+             insols                                 = pluginBadCts p
+
+-- SLPJ: I'm deeply suspicious of this
+--       ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds)
+
+       ; mapM_ setEv solved_wanted
+       ; return ( notNull (pluginNewCts p)
+                , WC { wc_simple = listToBag new_wanted       `andCts`
+                                   listToBag unsolved_wanted  `andCts`
+                                   listToBag unsolved_derived `andCts`
+                                   listToBag insols
+                     , wc_impl   = implics1 } ) } }
+  where
+    setEv :: (EvTerm,Ct) -> TcS ()
+    setEv (ev,ct) = case ctEvidence ct of
+      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev
+      _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!"
+
+-- | A triple of (given, derived, wanted) constraints to pass to plugins
+type SplitCts  = ([Ct], [Ct], [Ct])
+
+-- | A solved triple of constraints, with evidence for wanteds
+type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)])
+
+-- | Represents collections of constraints generated by typechecker
+-- plugins
+data TcPluginProgress = TcPluginProgress
+    { pluginInputCts  :: SplitCts
+      -- ^ Original inputs to the plugins with solved/bad constraints
+      -- removed, but otherwise unmodified
+    , pluginSolvedCts :: SolvedCts
+      -- ^ Constraints solved by plugins
+    , pluginBadCts    :: [Ct]
+      -- ^ Constraints reported as insoluble by plugins
+    , pluginNewCts    :: [Ct]
+      -- ^ New constraints emitted by plugins
+    }
+
+getTcPlugins :: TcS [TcPluginSolver]
+getTcPlugins = do { tcg_env <- getGblEnv; return (tcg_tc_plugins tcg_env) }
+
+-- | Starting from a triple of (given, derived, wanted) constraints,
+-- invoke each of the typechecker plugins in turn and return
+--
+--  * the remaining unmodified constraints,
+--  * constraints that have been solved,
+--  * constraints that are insoluble, and
+--  * new work.
+--
+-- Note that new work generated by one plugin will not be seen by
+-- other plugins on this pass (but the main constraint solver will be
+-- re-invoked and they will see it later).  There is no check that new
+-- work differs from the original constraints supplied to the plugin:
+-- the plugin itself should perform this check if necessary.
+runTcPlugins :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress
+runTcPlugins plugins all_cts
+  = foldM do_plugin initialProgress plugins
+  where
+    do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress
+    do_plugin p solver = do
+        result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p))
+        return $ progress p result
+
+    progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress
+    progress p (TcPluginContradiction bad_cts) =
+       p { pluginInputCts = discard bad_cts (pluginInputCts p)
+         , pluginBadCts   = bad_cts ++ pluginBadCts p
+         }
+    progress p (TcPluginOk solved_cts new_cts) =
+      p { pluginInputCts  = discard (map snd solved_cts) (pluginInputCts p)
+        , pluginSolvedCts = add solved_cts (pluginSolvedCts p)
+        , pluginNewCts    = new_cts ++ pluginNewCts p
+        }
+
+    initialProgress = TcPluginProgress all_cts ([], [], []) [] []
+
+    discard :: [Ct] -> SplitCts -> SplitCts
+    discard cts (xs, ys, zs) =
+        (xs `without` cts, ys `without` cts, zs `without` cts)
+
+    without :: [Ct] -> [Ct] -> [Ct]
+    without = deleteFirstsBy eqCt
+
+    eqCt :: Ct -> Ct -> Bool
+    eqCt c c' = ctFlavour c == ctFlavour c'
+             && ctPred c `tcEqType` ctPred c'
+
+    add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts
+    add xs scs = foldl' addOne scs xs
+
+    addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts
+    addOne (givens, deriveds, wanteds) (ev,ct) = case ctEvidence ct of
+      CtGiven  {} -> (ct:givens, deriveds, wanteds)
+      CtDerived{} -> (givens, ct:deriveds, wanteds)
+      CtWanted {} -> (givens, deriveds, (ev,ct):wanteds)
+
+
+type WorkItem = Ct
+type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct)
+
+runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline
+                  -> WorkItem                   -- The work item
+                  -> TcS ()
+-- Run this item down the pipeline, leaving behind new work and inerts
+runSolverPipeline pipeline workItem
+  = do { wl <- getWorkList
+       ; inerts <- getTcSInerts
+       ; tclevel <- getTcLevel
+       ; traceTcS "----------------------------- " empty
+       ; traceTcS "Start solver pipeline {" $
+                  vcat [ text "tclevel =" <+> ppr tclevel
+                       , text "work item =" <+> ppr workItem
+                       , text "inerts =" <+> ppr inerts
+                       , text "rest of worklist =" <+> ppr wl ]
+
+       ; bumpStepCountTcS    -- One step for each constraint processed
+       ; final_res  <- run_pipeline pipeline (ContinueWith workItem)
+
+       ; case final_res of
+           Stop ev s       -> do { traceFireTcS ev s
+                                 ; traceTcS "End solver pipeline (discharged) }" empty
+                                 ; return () }
+           ContinueWith ct -> do { addInertCan ct
+                                 ; traceFireTcS (ctEvidence ct) (text "Kept as inert")
+                                 ; traceTcS "End solver pipeline (kept as inert) }" $
+                                            (text "final_item =" <+> ppr ct) }
+       }
+  where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct
+                     -> TcS (StopOrContinue Ct)
+        run_pipeline [] res        = return res
+        run_pipeline _ (Stop ev s) = return (Stop ev s)
+        run_pipeline ((stg_name,stg):stgs) (ContinueWith ct)
+          = do { traceTcS ("runStage " ++ stg_name ++ " {")
+                          (text "workitem   = " <+> ppr ct)
+               ; res <- stg ct
+               ; traceTcS ("end stage " ++ stg_name ++ " }") empty
+               ; run_pipeline stgs res }
+
+{-
+Example 1:
+  Inert:   {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given)
+  Reagent: a ~ [b] (given)
+
+React with (c~d)     ==> IR (ContinueWith (a~[b]))  True    []
+React with (F a ~ t) ==> IR (ContinueWith (a~[b]))  False   [F [b] ~ t]
+React with (b ~ Int) ==> IR (ContinueWith (a~[Int]) True    []
+
+Example 2:
+  Inert:  {c ~w d, F a ~g t, b ~w Int, a ~w ty}
+  Reagent: a ~w [b]
+
+React with (c ~w d)   ==> IR (ContinueWith (a~[b]))  True    []
+React with (F a ~g t) ==> IR (ContinueWith (a~[b]))  True    []    (can't rewrite given with wanted!)
+etc.
+
+Example 3:
+  Inert:  {a ~ Int, F Int ~ b} (given)
+  Reagent: F a ~ b (wanted)
+
+React with (a ~ Int)   ==> IR (ContinueWith (F Int ~ b)) True []
+React with (F Int ~ b) ==> IR Stop True []    -- after substituting we re-canonicalize and get nothing
+-}
+
+thePipeline :: [(String,SimplifierStage)]
+thePipeline = [ ("canonicalization",        TcCanonical.canonicalize)
+              , ("interact with inerts",    interactWithInertsStage)
+              , ("top-level reactions",     topReactionsStage) ]
+
+{-
+*********************************************************************************
+*                                                                               *
+                       The interact-with-inert Stage
+*                                                                               *
+*********************************************************************************
+
+Note [The Solver Invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We always add Givens first.  So you might think that the solver has
+the invariant
+
+   If the work-item is Given,
+   then the inert item must Given
+
+But this isn't quite true.  Suppose we have,
+    c1: [W] beta ~ [alpha], c2 : [W] blah, c3 :[W] alpha ~ Int
+After processing the first two, we get
+     c1: [G] beta ~ [alpha], c2 : [W] blah
+Now, c3 does not interact with the given c1, so when we spontaneously
+solve c3, we must re-react it with the inert set.  So we can attempt a
+reaction between inert c2 [W] and work-item c3 [G].
+
+It *is* true that [Solver Invariant]
+   If the work-item is Given,
+   AND there is a reaction
+   then the inert item must Given
+or, equivalently,
+   If the work-item is Given,
+   and the inert item is Wanted/Derived
+   then there is no reaction
+-}
+
+-- Interaction result of  WorkItem <~> Ct
+
+interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct)
+-- Precondition: if the workitem is a CTyEqCan then it will not be able to
+-- react with anything at this stage.
+
+interactWithInertsStage wi
+  = do { inerts <- getTcSInerts
+       ; let ics = inert_cans inerts
+       ; case wi of
+             CTyEqCan  {} -> interactTyVarEq ics wi
+             CFunEqCan {} -> interactFunEq   ics wi
+             CIrredCan {} -> interactIrred   ics wi
+             CDictCan  {} -> interactDict    ics wi
+             _ -> pprPanic "interactWithInerts" (ppr wi) }
+                -- CHoleCan are put straight into inert_frozen, so never get here
+                -- CNonCanonical have been canonicalised
+
+data InteractResult
+   = KeepInert   -- Keep the inert item, and solve the work item from it
+                 -- (if the latter is Wanted; just discard it if not)
+   | KeepWork    -- Keep the work item, and solve the intert item from it
+
+instance Outputable InteractResult where
+  ppr KeepInert = text "keep inert"
+  ppr KeepWork  = text "keep work-item"
+
+solveOneFromTheOther :: CtEvidence  -- Inert
+                     -> CtEvidence  -- WorkItem
+                     -> TcS InteractResult
+-- Precondition:
+-- * inert and work item represent evidence for the /same/ predicate
+--
+-- We can always solve one from the other: even if both are wanted,
+-- although we don't rewrite wanteds with wanteds, we can combine
+-- two wanteds into one by solving one from the other
+
+solveOneFromTheOther ev_i ev_w
+  | isDerived ev_w         -- Work item is Derived; just discard it
+  = return KeepInert
+
+  | isDerived ev_i     -- The inert item is Derived, we can just throw it away,
+  = return KeepWork    -- The ev_w is inert wrt earlier inert-set items,
+                       -- so it's safe to continue on from this point
+
+  | CtWanted { ctev_loc = loc_w } <- ev_w
+  , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w
+  = -- inert must be Given
+    do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w)
+       ; return KeepWork }
+
+  | CtWanted {} <- ev_w
+       -- Inert is Given or Wanted
+  = return KeepInert
+
+  -- From here on the work-item is Given
+
+  | CtWanted { ctev_loc = loc_i } <- ev_i
+  , prohibitedSuperClassSolve (ctEvLoc ev_w) loc_i
+  = do { traceTcS "prohibitedClassSolve2" (ppr ev_i $$ ppr ev_w)
+       ; return KeepInert }      -- Just discard the un-usable Given
+                                 -- This never actually happens because
+                                 -- Givens get processed first
+
+  | CtWanted {} <- ev_i
+  = return KeepWork
+
+  -- From here on both are Given
+  -- See Note [Replacement vs keeping]
+
+  | lvl_i == lvl_w
+  = do { ev_binds_var <- getTcEvBindsVar
+       ; binds <- getTcEvBindsMap ev_binds_var
+       ; return (same_level_strategy binds) }
+
+  | otherwise   -- Both are Given, levels differ
+  = return different_level_strategy
+  where
+     pred  = ctEvPred ev_i
+     loc_i = ctEvLoc ev_i
+     loc_w = ctEvLoc ev_w
+     lvl_i = ctLocLevel loc_i
+     lvl_w = ctLocLevel loc_w
+     ev_id_i = ctEvEvId ev_i
+     ev_id_w = ctEvEvId ev_w
+
+     different_level_strategy  -- Both Given
+       | isIPPred pred, lvl_w > lvl_i = KeepWork
+       | lvl_w < lvl_i                = KeepWork
+       | otherwise                    = KeepInert
+
+     same_level_strategy binds -- Both Given
+       | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i
+       = case ctLocOrigin loc_w of
+            GivenOrigin (InstSC s_w) | s_w < s_i -> KeepWork
+                                     | otherwise -> KeepInert
+            _                                    -> KeepWork
+
+       | GivenOrigin (InstSC {}) <- ctLocOrigin loc_w
+       = KeepInert
+
+       | has_binding binds ev_id_w
+       , not (has_binding binds ev_id_i)
+       , not (ev_id_i `elemVarSet` findNeededEvVars binds (unitVarSet ev_id_w))
+       = KeepWork
+
+       | otherwise
+       = KeepInert
+
+     has_binding binds ev_id = isJust (lookupEvBind binds ev_id)
+
+{-
+Note [Replacement vs keeping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we have two Given constraints both of type (C tys), say, which should
+we keep?  More subtle than you might think!
+
+  * Constraints come from different levels (different_level_strategy)
+
+      - For implicit parameters we want to keep the innermost (deepest)
+        one, so that it overrides the outer one.
+        See Note [Shadowing of Implicit Parameters]
+
+      - For everything else, we want to keep the outermost one.  Reason: that
+        makes it more likely that the inner one will turn out to be unused,
+        and can be reported as redundant.  See Note [Tracking redundant constraints]
+        in TcSimplify.
+
+        It transpires that using the outermost one is reponsible for an
+        8% performance improvement in nofib cryptarithm2, compared to
+        just rolling the dice.  I didn't investigate why.
+
+  * Constraints coming from the same level (i.e. same implication)
+
+       (a) Always get rid of InstSC ones if possible, since they are less
+           useful for solving.  If both are InstSC, choose the one with
+           the smallest TypeSize
+           See Note [Solving superclass constraints] in TcInstDcls
+
+       (b) Keep the one that has a non-trivial evidence binding.
+              Example:  f :: (Eq a, Ord a) => blah
+              then we may find [G] d3 :: Eq a
+                               [G] d2 :: Eq a
+                with bindings  d3 = sc_sel (d1::Ord a)
+            We want to discard d2 in favour of the superclass selection from
+            the Ord dictionary.
+            Why? See Note [Tracking redundant constraints] in TcSimplify again.
+
+       (c) But don't do (b) if the evidence binding depends transitively on the
+           one without a binding.  Example (with RecursiveSuperClasses)
+              class C a => D a
+              class D a => C a
+           Inert:     d1 :: C a, d2 :: D a
+           Binds:     d3 = sc_sel d2, d2 = sc_sel d1
+           Work item: d3 :: C a
+           Then it'd be ridiculous to replace d1 with d3 in the inert set!
+           Hence the findNeedEvVars test.  See Trac #14774.
+
+  * Finally, when there is still a choice, use KeepInert rather than
+    KeepWork, for two reasons:
+      - to avoid unnecessary munging of the inert set.
+      - to cut off superclass loops; see Note [Superclass loops] in TcCanonical
+
+Doing the depth-check for implicit parameters, rather than making the work item
+always override, is important.  Consider
+
+    data T a where { T1 :: (?x::Int) => T Int; T2 :: T a }
+
+    f :: (?x::a) => T a -> Int
+    f T1 = ?x
+    f T2 = 3
+
+We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add
+two new givens in the work-list:  [G] (?x::Int)
+                                  [G] (a ~ Int)
+Now consider these steps
+  - process a~Int, kicking out (?x::a)
+  - process (?x::Int), the inner given, adding to inert set
+  - process (?x::a), the outer given, overriding the inner given
+Wrong!  The depth-check ensures that the inner implicit parameter wins.
+(Actually I think that the order in which the work-list is processed means
+that this chain of events won't happen, but that's very fragile.)
+
+*********************************************************************************
+*                                                                               *
+                   interactIrred
+*                                                                               *
+*********************************************************************************
+
+Note [Multiple matching irreds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might think that it's impossible to have multiple irreds all match the
+work item; after all, interactIrred looks for matches and solves one from the
+other. However, note that interacting insoluble, non-droppable irreds does not
+do this matching. We thus might end up with several insoluble, non-droppable,
+matching irreds in the inert set. When another irred comes along that we have
+not yet labeled insoluble, we can find multiple matches. These multiple matches
+cause no harm, but it would be wrong to ASSERT that they aren't there (as we
+once had done). This problem can be tickled by typecheck/should_compile/holes.
+
+-}
+
+-- Two pieces of irreducible evidence: if their types are *exactly identical*
+-- we can rewrite them. We can never improve using this:
+-- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not
+-- mean that (ty1 ~ ty2)
+interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct)
+
+interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_insol = insoluble })
+  | insoluble  -- For insolubles, don't allow the constaint to be dropped
+               -- which can happen with solveOneFromTheOther, so that
+               -- we get distinct error messages with -fdefer-type-errors
+               -- See Note [Do not add duplicate derived insolubles]
+  , not (isDroppableCt workItem)
+  = continueWith workItem
+
+  | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w
+  , ((ct_i, swap) : _rest) <- bagToList matching_irreds
+        -- See Note [Multiple matching irreds]
+  , let ev_i = ctEvidence ct_i
+  = do { what_next <- solveOneFromTheOther ev_i ev_w
+       ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i)
+       ; case what_next of
+            KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i)
+                            ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) }
+            KeepWork ->  do { setEvBindIfWanted ev_i (swap_me swap ev_w)
+                            ; updInertIrreds (\_ -> others)
+                            ; continueWith workItem } }
+
+  | otherwise
+  = continueWith workItem
+
+  where
+    swap_me :: SwapFlag -> CtEvidence -> EvTerm
+    swap_me swap ev
+      = case swap of
+           NotSwapped -> ctEvTerm ev
+           IsSwapped  -> evCoercion (mkTcSymCo (evTermCoercion (ctEvTerm ev)))
+
+interactIrred _ wi = pprPanic "interactIrred" (ppr wi)
+
+findMatchingIrreds :: Cts -> CtEvidence -> (Bag (Ct, SwapFlag), Bag Ct)
+findMatchingIrreds irreds ev
+  | EqPred eq_rel1 lty1 rty1 <- classifyPredType pred
+    -- See Note [Solving irreducible equalities]
+  = partitionBagWith (match_eq eq_rel1 lty1 rty1) irreds
+  | otherwise
+  = partitionBagWith match_non_eq irreds
+  where
+    pred = ctEvPred ev
+    match_non_eq ct
+      | ctPred ct `tcEqTypeNoKindCheck` pred = Left (ct, NotSwapped)
+      | otherwise                            = Right ct
+
+    match_eq eq_rel1 lty1 rty1 ct
+      | EqPred eq_rel2 lty2 rty2 <- classifyPredType (ctPred ct)
+      , eq_rel1 == eq_rel2
+      , Just swap <- match_eq_help lty1 rty1 lty2 rty2
+      = Left (ct, swap)
+      | otherwise
+      = Right ct
+
+    match_eq_help lty1 rty1 lty2 rty2
+      | lty1 `tcEqTypeNoKindCheck` lty2, rty1 `tcEqTypeNoKindCheck` rty2
+      = Just NotSwapped
+      | lty1 `tcEqTypeNoKindCheck` rty2, rty1 `tcEqTypeNoKindCheck` lty2
+      = Just IsSwapped
+      | otherwise
+      = Nothing
+
+{- Note [Solving irreducible equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #14333)
+  [G] a b ~R# c d
+  [W] c d ~R# a b
+Clearly we should be able to solve this! Even though the constraints are
+not decomposable. We solve this when looking up the work-item in the
+irreducible constraints to look for an identical one.  When doing this
+lookup, findMatchingIrreds spots the equality case, and matches either
+way around. It has to return a swap-flag so we can generate evidence
+that is the right way round too.
+
+Note [Do not add duplicate derived insolubles]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general we *must* add an insoluble (Int ~ Bool) even if there is
+one such there already, because they may come from distinct call
+sites.  Not only do we want an error message for each, but with
+-fdefer-type-errors we must generate evidence for each.  But for
+*derived* insolubles, we only want to report each one once.  Why?
+
+(a) A constraint (C r s t) where r -> s, say, may generate the same fundep
+    equality many times, as the original constraint is successively rewritten.
+
+(b) Ditto the successive iterations of the main solver itself, as it traverses
+    the constraint tree. See example below.
+
+Also for *given* insolubles we may get repeated errors, as we
+repeatedly traverse the constraint tree.  These are relatively rare
+anyway, so removing duplicates seems ok.  (Alternatively we could take
+the SrcLoc into account.)
+
+Note that the test does not need to be particularly efficient because
+it is only used if the program has a type error anyway.
+
+Example of (b): assume a top-level class and instance declaration:
+
+  class D a b | a -> b
+  instance D [a] [a]
+
+Assume we have started with an implication:
+
+  forall c. Eq c => { wc_simple = D [c] c [W] }
+
+which we have simplified to:
+
+  forall c. Eq c => { wc_simple = D [c] c [W]
+                                  (c ~ [c]) [D] }
+
+For some reason, e.g. because we floated an equality somewhere else,
+we might try to re-solve this implication. If we do not do a
+dropDerivedWC, then we will end up trying to solve the following
+constraints the second time:
+
+  (D [c] c) [W]
+  (c ~ [c]) [D]
+
+which will result in two Deriveds to end up in the insoluble set:
+
+  wc_simple   = D [c] c [W]
+               (c ~ [c]) [D], (c ~ [c]) [D]
+-}
+
+{-
+*********************************************************************************
+*                                                                               *
+                   interactDict
+*                                                                               *
+*********************************************************************************
+
+Note [Shortcut solving]
+~~~~~~~~~~~~~~~~~~~~~~~
+When we interact a [W] constraint with a [G] constraint that solves it, there is
+a possibility that we could produce better code if instead we solved from a
+top-level instance declaration (See #12791, #5835). For example:
+
+    class M a b where m :: a -> b
+
+    type C a b = (Num a, M a b)
+
+    f :: C Int b => b -> Int -> Int
+    f _ x = x + 1
+
+The body of `f` requires a [W] `Num Int` instance. We could solve this
+constraint from the givens because we have `C Int b` and that provides us a
+solution for `Num Int`. This would let us produce core like the following
+(with -O2):
+
+    f :: forall b. C Int b => b -> Int -> Int
+    f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) ->
+        + @ Int
+          (GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%))
+          eta1
+          A.f1
+
+This is bad! We could do /much/ better if we solved [W] `Num Int` directly
+from the instance that we have in scope:
+
+    f :: forall b. C Int b => b -> Int -> Int
+    f = \ (@ b) _ _ (x :: Int) ->
+        case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) }
+
+** NB: It is important to emphasize that all this is purely an optimization:
+** exactly the same programs should typecheck with or without this
+** procedure.
+
+Solving fully
+~~~~~~~~~~~~~
+There is a reason why the solver does not simply try to solve such
+constraints with top-level instances. If the solver finds a relevant
+instance declaration in scope, that instance may require a context
+that can't be solved for. A good example of this is:
+
+    f :: Ord [a] => ...
+    f x = ..Need Eq [a]...
+
+If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would
+be left with the obligation to solve the constraint Eq a, which we cannot. So we
+must be conservative in our attempt to use an instance declaration to solve the
+[W] constraint we're interested in.
+
+Our rule is that we try to solve all of the instance's subgoals
+recursively all at once. Precisely: We only attempt to solve
+constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci
+are themselves class constraints of the form `C1', ... Cm' => C' t1'
+... tn'` and we only succeed if the entire tree of constraints is
+solvable from instances.
+
+An example that succeeds:
+
+    class Eq a => C a b | b -> a where
+      m :: b -> a
+
+    f :: C [Int] b => b -> Bool
+    f x = m x == []
+
+We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This
+produces the following core:
+
+    f :: forall b. C [Int] b => b -> Bool
+    f = \ (@ b) ($dC :: C [Int] b) (x :: b) ->
+        GHC.Classes.$fEq[]_$s$c==
+          (m @ [Int] @ b $dC x) (GHC.Types.[] @ Int)
+
+An example that fails:
+
+    class Eq a => C a b | b -> a where
+      m :: b -> a
+
+    f :: C [a] b => b -> Bool
+    f x = m x == []
+
+Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces:
+
+    f :: forall a b. C [a] b => b -> Bool
+    f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) ->
+        ==
+          @ [a]
+          (A.$p1C @ [a] @ b $dC)
+          (m @ [a] @ b $dC eta)
+          (GHC.Types.[] @ a)
+
+Note [Shortcut solving: type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have (Trac #13943)
+  class Take (n :: Nat) where ...
+  instance {-# OVERLAPPING #-}                    Take 0 where ..
+  instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where ..
+
+And we have [W] Take 3.  That only matches one instance so we get
+[W] Take (3-1).  Really we should now flatten to reduce the (3-1) to 2, and
+so on -- but that is reproducing yet more of the solver.  Sigh.  For now,
+we just give up (remember all this is just an optimisation).
+
+But we must not just naively try to lookup (Take (3-1)) in the
+InstEnv, or it'll (wrongly) appear not to match (Take 0) and get a
+unique match on the (Take n) instance.  That leads immediately to an
+infinite loop.  Hence the check that 'preds' have no type families
+(isTyFamFree).
+
+Note [Shortcut solving: incoherence]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This optimization relies on coherence of dictionaries to be correct. When we
+cannot assume coherence because of IncoherentInstances then this optimization
+can change the behavior of the user's code.
+
+The following four modules produce a program whose output would change depending
+on whether we apply this optimization when IncoherentInstances is in effect:
+
+#########
+    {-# LANGUAGE MultiParamTypeClasses #-}
+    module A where
+
+    class A a where
+      int :: a -> Int
+
+    class A a => C a b where
+      m :: b -> a -> a
+
+#########
+    {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
+    module B where
+
+    import A
+
+    instance A a where
+      int _ = 1
+
+    instance C a [b] where
+      m _ = id
+
+#########
+    {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}
+    {-# LANGUAGE IncoherentInstances #-}
+    module C where
+
+    import A
+
+    instance A Int where
+      int _ = 2
+
+    instance C Int [Int] where
+      m _ = id
+
+    intC :: C Int a => a -> Int -> Int
+    intC _ x = int x
+
+#########
+    module Main where
+
+    import A
+    import B
+    import C
+
+    main :: IO ()
+    main = print (intC [] (0::Int))
+
+The output of `main` if we avoid the optimization under the effect of
+IncoherentInstances is `1`. If we were to do the optimization, the output of
+`main` would be `2`.
+
+Note [Shortcut try_solve_from_instance]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The workhorse of the short-cut solver is
+    try_solve_from_instance :: (EvBindMap, DictMap CtEvidence)
+                            -> CtEvidence       -- Solve this
+                            -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
+Note that:
+
+* The CtEvidence is the goal to be solved
+
+* The MaybeT anages early failure if we find a subgoal that
+  cannot be solved from instances.
+
+* The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional
+  state that allows try_solve_from_instance to augmennt the evidence
+  bindings and inert_solved_dicts as it goes.
+
+  If it succeeds, we commit all these bindings and solved dicts to the
+  main TcS InertSet.  If not, we abandon it all entirely.
+
+Passing along the solved_dicts important for two reasons:
+
+* We need to be able to handle recursive super classes. The
+  solved_dicts state  ensures that we remember what we have already
+  tried to solve to avoid looping.
+
+* As Trac #15164 showed, it can be important to exploit sharing between
+  goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H;
+  and to solve G2 we may need H. If we don't spot this sharing we may
+  solve H twice; and if this pattern repeats we may get exponentially bad
+  behaviour.
+-}
+
+interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)
+interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })
+  | Just ev_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys
+  = -- There is a matching dictionary in the inert set
+    do { -- First to try to solve it /completely/ from top level instances
+         -- See Note [Shortcut solving]
+         dflags <- getDynFlags
+       ; short_cut_worked <- shortCutSolver dflags ev_w ev_i
+       ; if short_cut_worked
+         then stopWith ev_w "interactDict/solved from instance"
+         else
+
+    do { -- Ths short-cut solver didn't fire, so we
+         -- solve ev_w from the matching inert ev_i we found
+         what_next <- solveOneFromTheOther ev_i ev_w
+       ; traceTcS "lookupInertDict" (ppr what_next)
+       ; case what_next of
+           KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i)
+                           ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) }
+           KeepWork  -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w)
+                           ; updInertDicts $ \ ds -> delDict ds cls tys
+                           ; continueWith workItem } } }
+
+  | cls `hasKey` ipClassKey
+  , isGiven ev_w
+  = interactGivenIP inerts workItem
+
+  | otherwise
+  = do { addFunDepWork inerts ev_w cls
+       ; continueWith workItem  }
+
+interactDict _ wi = pprPanic "interactDict" (ppr wi)
+
+-- See Note [Shortcut solving]
+shortCutSolver :: DynFlags
+               -> CtEvidence -- Work item
+               -> CtEvidence -- Inert we want to try to replace
+               -> TcS Bool   -- True <=> success
+shortCutSolver dflags ev_w ev_i
+  | isWanted ev_w
+ && isGiven ev_i
+ -- We are about to solve a [W] constraint from a [G] constraint. We take
+ -- a moment to see if we can get a better solution using an instance.
+ -- Note that we only do this for the sake of performance. Exactly the same
+ -- programs should typecheck regardless of whether we take this step or
+ -- not. See Note [Shortcut solving]
+
+ && not (xopt LangExt.IncoherentInstances dflags)
+ -- If IncoherentInstances is on then we cannot rely on coherence of proofs
+ -- in order to justify this optimization: The proof provided by the
+ -- [G] constraint's superclass may be different from the top-level proof.
+ -- See Note [Shortcut solving: incoherence]
+
+ && gopt Opt_SolveConstantDicts dflags
+ -- Enabled by the -fsolve-constant-dicts flag
+  = do { ev_binds_var <- getTcEvBindsVar
+       ; ev_binds <- ASSERT2( not (isCoEvBindsVar ev_binds_var ), ppr ev_w )
+                     getTcEvBindsMap ev_binds_var
+       ; solved_dicts <- getSolvedDicts
+
+       ; mb_stuff <- runMaybeT $ try_solve_from_instance
+                                   (ev_binds, solved_dicts) ev_w
+
+       ; case mb_stuff of
+           Nothing -> return False
+           Just (ev_binds', solved_dicts')
+              -> do { setTcEvBindsMap ev_binds_var ev_binds'
+                    ; setSolvedDicts solved_dicts'
+                    ; return True } }
+
+  | otherwise
+  = return False
+  where
+    -- This `CtLoc` is used only to check the well-staged condition of any
+    -- candidate DFun. Our subgoals all have the same stage as our root
+    -- [W] constraint so it is safe to use this while solving them.
+    loc_w = ctEvLoc ev_w
+
+    try_solve_from_instance   -- See Note [Shortcut try_solve_from_instance]
+      :: (EvBindMap, DictMap CtEvidence) -> CtEvidence
+      -> MaybeT TcS (EvBindMap, DictMap CtEvidence)
+    try_solve_from_instance (ev_binds, solved_dicts) ev
+      | let pred = ctEvPred ev
+            loc  = ctEvLoc  ev
+      , ClassPred cls tys <- classifyPredType pred
+      = do { inst_res <- lift $ matchGlobalInst dflags True cls tys
+           ; case inst_res of
+               OneInst { cir_new_theta = preds
+                       , cir_mk_ev     = mk_ev
+                       , cir_what      = what }
+                 | safeOverlap what
+                 , all isTyFamFree preds  -- Note [Shortcut solving: type families]
+                 -> do { let solved_dicts' = addDict solved_dicts cls tys ev
+                             -- solved_dicts': it is important that we add our goal
+                             -- to the cache before we solve! Otherwise we may end
+                             -- up in a loop while solving recursive dictionaries.
+
+                       ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds)
+                       ; loc' <- lift $ checkInstanceOK loc what pred
+
+                       ; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds
+                                  -- Emit work for subgoals but use our local cache
+                                  -- so we can solve recursive dictionaries.
+
+                       ; let ev_tm     = mk_ev (map getEvExpr evc_vs)
+                             ev_binds' = extendEvBinds ev_binds $
+                                         mkWantedEvBind (ctEvEvId ev) ev_tm
+
+                       ; foldlM try_solve_from_instance
+                                (ev_binds', solved_dicts')
+                                (freshGoals evc_vs) }
+
+               _ -> mzero }
+      | otherwise = mzero
+
+
+    -- Use a local cache of solved dicts while emitting EvVars for new work
+    -- We bail out of the entire computation if we need to emit an EvVar for
+    -- a subgoal that isn't a ClassPred.
+    new_wanted_cached :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew
+    new_wanted_cached loc cache pty
+      | ClassPred cls tys <- classifyPredType pty
+      = lift $ case findDict cache loc_w cls tys of
+          Just ctev -> return $ Cached (ctEvExpr ctev)
+          Nothing   -> Fresh <$> newWantedNC loc pty
+      | otherwise = mzero
+
+addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS ()
+-- Add derived constraints from type-class functional dependencies.
+addFunDepWork inerts work_ev cls
+  | isImprovable work_ev
+  = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls)
+               -- No need to check flavour; fundeps work between
+               -- any pair of constraints, regardless of flavour
+               -- Importantly we don't throw workitem back in the
+               -- worklist because this can cause loops (see #5236)
+  | otherwise
+  = return ()
+  where
+    work_pred = ctEvPred work_ev
+    work_loc  = ctEvLoc work_ev
+
+    add_fds inert_ct
+      | isImprovable inert_ev
+      = do { traceTcS "addFunDepWork" (vcat
+                [ ppr work_ev
+                , pprCtLoc work_loc, ppr (isGivenLoc work_loc)
+                , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc)
+                , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) ;
+
+        emitFunDepDeriveds $
+        improveFromAnother derived_loc inert_pred work_pred
+               -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok
+               -- NB: We do create FDs for given to report insoluble equations that arise
+               -- from pairs of Givens, and also because of floating when we approximate
+               -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs
+        }
+      | otherwise
+      = return ()
+      where
+        inert_ev   = ctEvidence inert_ct
+        inert_pred = ctEvPred inert_ev
+        inert_loc  = ctEvLoc inert_ev
+        derived_loc = work_loc { ctl_depth  = ctl_depth work_loc `maxSubGoalDepth`
+                                              ctl_depth inert_loc
+                               , ctl_origin = FunDepOrigin1 work_pred  work_loc
+                                                            inert_pred inert_loc }
+
+{-
+**********************************************************************
+*                                                                    *
+                   Implicit parameters
+*                                                                    *
+**********************************************************************
+-}
+
+interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct)
+-- Work item is Given (?x:ty)
+-- See Note [Shadowing of Implicit Parameters]
+interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls
+                                          , cc_tyargs = tys@(ip_str:_) })
+  = do { updInertCans $ \cans -> cans { inert_dicts = addDict filtered_dicts cls tys workItem }
+       ; stopWith ev "Given IP" }
+  where
+    dicts           = inert_dicts inerts
+    ip_dicts        = findDictsByClass dicts cls
+    other_ip_dicts  = filterBag (not . is_this_ip) ip_dicts
+    filtered_dicts  = addDictsByClass dicts cls other_ip_dicts
+
+    -- Pick out any Given constraints for the same implicit parameter
+    is_this_ip (CDictCan { cc_ev = ev, cc_tyargs = ip_str':_ })
+       = isGiven ev && ip_str `tcEqType` ip_str'
+    is_this_ip _ = False
+
+interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi)
+
+{- Note [Shadowing of Implicit Parameters]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following example:
+
+f :: (?x :: Char) => Char
+f = let ?x = 'a' in ?x
+
+The "let ?x = ..." generates an implication constraint of the form:
+
+?x :: Char => ?x :: Char
+
+Furthermore, the signature for `f` also generates an implication
+constraint, so we end up with the following nested implication:
+
+?x :: Char => (?x :: Char => ?x :: Char)
+
+Note that the wanted (?x :: Char) constraint may be solved in
+two incompatible ways:  either by using the parameter from the
+signature, or by using the local definition.  Our intention is
+that the local definition should "shadow" the parameter of the
+signature, and we implement this as follows: when we add a new
+*given* implicit parameter to the inert set, it replaces any existing
+givens for the same implicit parameter.
+
+Similarly, consider
+   f :: (?x::a) => Bool -> a
+
+   g v = let ?x::Int = 3
+         in (f v, let ?x::Bool = True in f v)
+
+This should probably be well typed, with
+   g :: Bool -> (Int, Bool)
+
+So the inner binding for ?x::Bool *overrides* the outer one.
+
+All this works for the normal cases but it has an odd side effect in
+some pathological programs like this:
+-- This is accepted, the second parameter shadows
+f1 :: (?x :: Int, ?x :: Char) => Char
+f1 = ?x
+
+-- This is rejected, the second parameter shadows
+f2 :: (?x :: Int, ?x :: Char) => Int
+f2 = ?x
+
+Both of these are actually wrong:  when we try to use either one,
+we'll get two incompatible wanted constraints (?x :: Int, ?x :: Char),
+which would lead to an error.
+
+I can think of two ways to fix this:
+
+  1. Simply disallow multiple constraints for the same implicit
+    parameter---this is never useful, and it can be detected completely
+    syntactically.
+
+  2. Move the shadowing machinery to the location where we nest
+     implications, and add some code here that will produce an
+     error if we get multiple givens for the same implicit parameter.
+
+
+**********************************************************************
+*                                                                    *
+                   interactFunEq
+*                                                                    *
+**********************************************************************
+-}
+
+interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
+-- Try interacting the work item with the inert set
+interactFunEq inerts work_item@(CFunEqCan { cc_ev = ev, cc_fun = tc
+                                          , cc_tyargs = args, cc_fsk = fsk })
+  | Just inert_ct@(CFunEqCan { cc_ev = ev_i
+                             , cc_fsk = fsk_i })
+         <- findFunEq (inert_funeqs inerts) tc args
+  , pr@(swap_flag, upgrade_flag) <- ev_i `funEqCanDischarge` ev
+  = do { traceTcS "reactFunEq (rewrite inert item):" $
+         vcat [ text "work_item =" <+> ppr work_item
+              , text "inertItem=" <+> ppr ev_i
+              , text "(swap_flag, upgrade)" <+> ppr pr ]
+       ; if isSwapped swap_flag
+         then do {   -- Rewrite inert using work-item
+                   let work_item' | upgrade_flag = upgradeWanted work_item
+                                  | otherwise    = work_item
+                 ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args work_item'
+                      -- Do the updInertFunEqs before the reactFunEq, so that
+                      -- we don't kick out the inertItem as well as consuming it!
+                 ; reactFunEq ev fsk ev_i fsk_i
+                 ; stopWith ev "Work item rewrites inert" }
+         else do {   -- Rewrite work-item using inert
+                 ; when upgrade_flag $
+                   updInertFunEqs $ \ feqs -> insertFunEq feqs tc args
+                                                 (upgradeWanted inert_ct)
+                 ; reactFunEq ev_i fsk_i ev fsk
+                 ; stopWith ev "Inert rewrites work item" } }
+
+  | otherwise   -- Try improvement
+  = do { improveLocalFunEqs ev inerts tc args fsk
+       ; continueWith work_item }
+
+interactFunEq _ work_item = pprPanic "interactFunEq" (ppr work_item)
+
+upgradeWanted :: Ct -> Ct
+-- We are combining a [W] F tys ~ fmv1 and [D] F tys ~ fmv2
+-- so upgrade the [W] to [WD] before putting it in the inert set
+upgradeWanted ct = ct { cc_ev = upgrade_ev (cc_ev ct) }
+  where
+    upgrade_ev ev = ASSERT2( isWanted ev, ppr ct )
+                    ev { ctev_nosh = WDeriv }
+
+improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcTyVar
+                   -> TcS ()
+-- Generate derived improvement equalities, by comparing
+-- the current work item with inert CFunEqs
+-- E.g.   x + y ~ z,   x + y' ~ z   =>   [D] y ~ y'
+--
+-- See Note [FunDep and implicit parameter reactions]
+improveLocalFunEqs work_ev inerts fam_tc args fsk
+  | isGiven work_ev -- See Note [No FunEq improvement for Givens]
+    || not (isImprovable work_ev)
+  = return ()
+
+  | not (null improvement_eqns)
+  = do { traceTcS "interactFunEq improvements: " $
+         vcat [ text "Eqns:" <+> ppr improvement_eqns
+              , text "Candidates:" <+> ppr funeqs_for_tc
+              , text "Inert eqs:" <+> ppr ieqs ]
+       ; emitFunDepDeriveds improvement_eqns }
+
+  | otherwise
+  = return ()
+
+  where
+    ieqs          = inert_eqs inerts
+    funeqs        = inert_funeqs inerts
+    funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc
+    rhs           = lookupFlattenTyVar ieqs fsk
+    work_loc      = ctEvLoc work_ev
+    work_pred     = ctEvPred work_ev
+    fam_inj_info  = tyConInjectivityInfo fam_tc
+
+    --------------------
+    improvement_eqns :: [FunDepEqn CtLoc]
+    improvement_eqns
+      | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
+      =    -- Try built-in families, notably for arithmethic
+         concatMap (do_one_built_in ops) funeqs_for_tc
+
+      | Injective injective_args <- fam_inj_info
+      =    -- Try improvement from type families with injectivity annotations
+        concatMap (do_one_injective injective_args) funeqs_for_tc
+
+      | otherwise
+      = []
+
+    --------------------
+    do_one_built_in ops (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev })
+      = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs
+                                             (lookupFlattenTyVar ieqs ifsk))
+
+    do_one_built_in _ _ = pprPanic "interactFunEq 1" (ppr fam_tc)
+
+    --------------------
+    -- See Note [Type inference for type families with injectivity]
+    do_one_injective inj_args (CFunEqCan { cc_tyargs = inert_args
+                                         , cc_fsk = ifsk, cc_ev = inert_ev })
+      | isImprovable inert_ev
+      , rhs `tcEqType` lookupFlattenTyVar ieqs ifsk
+      = mk_fd_eqns inert_ev $
+            [ Pair arg iarg
+            | (arg, iarg, True) <- zip3 args inert_args inj_args ]
+      | otherwise
+      = []
+
+    do_one_injective _ _ = pprPanic "interactFunEq 2" (ppr fam_tc)
+
+    --------------------
+    mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc]
+    mk_fd_eqns inert_ev eqns
+      | null eqns  = []
+      | otherwise  = [ FDEqn { fd_qtvs = [], fd_eqs = eqns
+                             , fd_pred1 = work_pred
+                             , fd_pred2 = ctEvPred inert_ev
+                             , fd_loc   = loc } ]
+      where
+        inert_loc = ctEvLoc inert_ev
+        loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`
+                                      ctl_depth work_loc }
+
+-------------
+reactFunEq :: CtEvidence -> TcTyVar    -- From this  :: F args1 ~ fsk1
+           -> CtEvidence -> TcTyVar    -- Solve this :: F args2 ~ fsk2
+           -> TcS ()
+reactFunEq from_this fsk1 solve_this fsk2
+  = do { traceTcS "reactFunEq"
+            (vcat [ppr from_this, ppr fsk1, ppr solve_this, ppr fsk2])
+       ; dischargeFunEq solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1)
+       ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$
+                                     ppr solve_this $$ ppr fsk2) }
+
+{- Note [Type inference for type families with injectivity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have a type family with an injectivity annotation:
+    type family F a b = r | r -> b
+
+Then if we have two CFunEqCan constraints for F with the same RHS
+   F s1 t1 ~ rhs
+   F s2 t2 ~ rhs
+then we can use the injectivity to get a new Derived constraint on
+the injective argument
+  [D] t1 ~ t2
+
+That in turn can help GHC solve constraints that would otherwise require
+guessing.  For example, consider the ambiguity check for
+   f :: F Int b -> Int
+We get the constraint
+   [W] F Int b ~ F Int beta
+where beta is a unification variable.  Injectivity lets us pick beta ~ b.
+
+Injectivity information is also used at the call sites. For example:
+   g = f True
+gives rise to
+   [W] F Int b ~ Bool
+from which we can derive b.  This requires looking at the defining equations of
+a type family, ie. finding equation with a matching RHS (Bool in this example)
+and infering values of type variables (b in this example) from the LHS patterns
+of the matching equation.  For closed type families we have to perform
+additional apartness check for the selected equation to check that the selected
+is guaranteed to fire for given LHS arguments.
+
+These new constraints are simply *Derived* constraints; they have no evidence.
+We could go further and offer evidence from decomposing injective type-function
+applications, but that would require new evidence forms, and an extension to
+FC, so we don't do that right now (Dec 14).
+
+See also Note [Injective type families] in TyCon
+
+
+Note [Cache-caused loops]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+It is very dangerous to cache a rewritten wanted family equation as 'solved' in our
+solved cache (which is the default behaviour or xCtEvidence), because the interaction
+may not be contributing towards a solution. Here is an example:
+
+Initial inert set:
+  [W] g1 : F a ~ beta1
+Work item:
+  [W] g2 : F a ~ beta2
+The work item will react with the inert yielding the _same_ inert set plus:
+    (i)   Will set g2 := g1 `cast` g3
+    (ii)  Will add to our solved cache that [S] g2 : F a ~ beta2
+    (iii) Will emit [W] g3 : beta1 ~ beta2
+Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2
+and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it
+will set
+      g1 := g ; sym g3
+and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but
+remember that we have this in our solved cache, and it is ... g2! In short we
+created the evidence loop:
+
+        g2 := g1 ; g3
+        g3 := refl
+        g1 := g2 ; sym g3
+
+To avoid this situation we do not cache as solved any workitems (or inert)
+which did not really made a 'step' towards proving some goal. Solved's are
+just an optimization so we don't lose anything in terms of completeness of
+solving.
+
+
+Note [Efficient Orientation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are interacting two FunEqCans with the same LHS:
+          (inert)  ci :: (F ty ~ xi_i)
+          (work)   cw :: (F ty ~ xi_w)
+We prefer to keep the inert (else we pass the work item on down
+the pipeline, which is a bit silly).  If we keep the inert, we
+will (a) discharge 'cw'
+     (b) produce a new equality work-item (xi_w ~ xi_i)
+Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w):
+    new_work :: xi_w ~ xi_i
+    cw := ci ; sym new_work
+Why?  Consider the simplest case when xi1 is a type variable.  If
+we generate xi1~xi2, porcessing that constraint will kick out 'ci'.
+If we generate xi2~xi1, there is less chance of that happening.
+Of course it can and should still happen if xi1=a, xi1=Int, say.
+But we want to avoid it happening needlessly.
+
+Similarly, if we *can't* keep the inert item (because inert is Wanted,
+and work is Given, say), we prefer to orient the new equality (xi_i ~
+xi_w).
+
+Note [Carefully solve the right CFunEqCan]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   ---- OLD COMMENT, NOW NOT NEEDED
+   ---- because we now allow multiple
+   ---- wanted FunEqs with the same head
+Consider the constraints
+  c1 :: F Int ~ a      -- Arising from an application line 5
+  c2 :: F Int ~ Bool   -- Arising from an application line 10
+Suppose that 'a' is a unification variable, arising only from
+flattening.  So there is no error on line 5; it's just a flattening
+variable.  But there is (or might be) an error on line 10.
+
+Two ways to combine them, leaving either (Plan A)
+  c1 :: F Int ~ a      -- Arising from an application line 5
+  c3 :: a ~ Bool       -- Arising from an application line 10
+or (Plan B)
+  c2 :: F Int ~ Bool   -- Arising from an application line 10
+  c4 :: a ~ Bool       -- Arising from an application line 5
+
+Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error
+on the *totally innocent* line 5.  An example is test SimpleFail16
+where the expected/actual message comes out backwards if we use
+the wrong plan.
+
+The second is the right thing to do.  Hence the isMetaTyVarTy
+test when solving pairwise CFunEqCan.
+
+
+**********************************************************************
+*                                                                    *
+                   interactTyVarEq
+*                                                                    *
+**********************************************************************
+-}
+
+inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtFlavourRole
+                   -> Maybe ( CtEvidence  -- The evidence for the inert
+                            , SwapFlag    -- Whether we need mkSymCo
+                            , Bool)       -- True <=> keep a [D] version
+                                          --          of the [WD] constraint
+inertsCanDischarge inerts tv rhs fr
+  | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i
+                                    , cc_eq_rel = eq_rel }
+                             <- findTyEqs inerts tv
+                         , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr
+                         , rhs_i `tcEqType` rhs ]
+  =  -- Inert:     a ~ ty
+     -- Work item: a ~ ty
+    Just (ev_i, NotSwapped, keep_deriv ev_i)
+
+  | Just tv_rhs <- getTyVar_maybe rhs
+  , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i
+                                    , cc_eq_rel = eq_rel }
+                             <- findTyEqs inerts tv_rhs
+                         , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr
+                         , rhs_i `tcEqType` mkTyVarTy tv ]
+  =  -- Inert:     a ~ b
+     -- Work item: b ~ a
+     Just (ev_i, IsSwapped, keep_deriv ev_i)
+
+  | otherwise
+  = Nothing
+
+  where
+    keep_deriv ev_i
+      | Wanted WOnly  <- ctEvFlavour ev_i  -- inert is [W]
+      , (Wanted WDeriv, _) <- fr           -- work item is [WD]
+      = True   -- Keep a derived verison of the work item
+      | otherwise
+      = False  -- Work item is fully discharged
+
+interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)
+-- CTyEqCans are always consumed, so always returns Stop
+interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv
+                                          , cc_rhs = rhs
+                                          , cc_ev = ev
+                                          , cc_eq_rel = eq_rel })
+  | Just (ev_i, swapped, keep_deriv)
+       <- inertsCanDischarge inerts tv rhs (ctEvFlavour ev, eq_rel)
+  = do { setEvBindIfWanted ev $
+         evCoercion (maybeSym swapped $
+                     tcDowngradeRole (eqRelRole eq_rel)
+                                     (ctEvRole ev_i)
+                                     (ctEvCoercion ev_i))
+
+       ; let deriv_ev = CtDerived { ctev_pred = ctEvPred ev
+                                  , ctev_loc  = ctEvLoc  ev }
+       ; when keep_deriv $
+         emitWork [workItem { cc_ev = deriv_ev }]
+         -- As a Derived it might not be fully rewritten,
+         -- so we emit it as new work
+
+       ; stopWith ev "Solved from inert" }
+
+  | ReprEq <- eq_rel   -- See Note [Do not unify representational equalities]
+  = do { traceTcS "Not unifying representational equality" (ppr workItem)
+       ; continueWith workItem }
+
+  | isGiven ev         -- See Note [Touchables and givens]
+  = continueWith workItem
+
+  | otherwise
+  = do { tclvl <- getTcLevel
+       ; if canSolveByUnification tclvl tv rhs
+         then do { solveByUnification ev tv rhs
+                 ; n_kicked <- kickOutAfterUnification tv
+                 ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) }
+
+         else continueWith workItem }
+
+interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi)
+
+solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS ()
+-- Solve with the identity coercion
+-- Precondition: kind(xi) equals kind(tv)
+-- Precondition: CtEvidence is Wanted or Derived
+-- Precondition: CtEvidence is nominal
+-- Returns: workItem where
+--        workItem = the new Given constraint
+--
+-- NB: No need for an occurs check here, because solveByUnification always
+--     arises from a CTyEqCan, a *canonical* constraint.  Its invariants
+--     say that in (a ~ xi), the type variable a does not appear in xi.
+--     See TcRnTypes.Ct invariants.
+--
+-- Post: tv is unified (by side effect) with xi;
+--       we often write tv := xi
+solveByUnification wd tv xi
+  = do { let tv_ty = mkTyVarTy tv
+       ; traceTcS "Sneaky unification:" $
+                       vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi,
+                             text "Coercion:" <+> pprEq tv_ty xi,
+                             text "Left Kind is:" <+> ppr (tcTypeKind tv_ty),
+                             text "Right Kind is:" <+> ppr (tcTypeKind xi) ]
+
+       ; unifyTyVar tv xi
+       ; setEvBindIfWanted wd (evCoercion (mkTcNomReflCo xi)) }
+
+{- Note [Avoid double unifications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The spontaneous solver has to return a given which mentions the unified unification
+variable *on the left* of the equality. Here is what happens if not:
+  Original wanted:  (a ~ alpha),  (alpha ~ Int)
+We spontaneously solve the first wanted, without changing the order!
+      given : a ~ alpha      [having unified alpha := a]
+Now the second wanted comes along, but he cannot rewrite the given, so we simply continue.
+At the end we spontaneously solve that guy, *reunifying*  [alpha := Int]
+
+We avoid this problem by orienting the resulting given so that the unification
+variable is on the left.  [Note that alternatively we could attempt to
+enforce this at canonicalization]
+
+See also Note [No touchables as FunEq RHS] in TcSMonad; avoiding
+double unifications is the main reason we disallow touchable
+unification variables as RHS of type family equations: F xis ~ alpha.
+
+Note [Do not unify representational equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider   [W] alpha ~R# b
+where alpha is touchable. Should we unify alpha := b?
+
+Certainly not!  Unifying forces alpha and be to be the same; but they
+only need to be representationally equal types.
+
+For example, we might have another constraint [W] alpha ~# N b
+where
+  newtype N b = MkN b
+and we want to get alpha := N b.
+
+See also Trac #15144, which was caused by unifying a representational
+equality (in the unflattener).
+
+
+************************************************************************
+*                                                                      *
+*          Functional dependencies, instantiation of equations
+*                                                                      *
+************************************************************************
+
+When we spot an equality arising from a functional dependency,
+we now use that equality (a "wanted") to rewrite the work-item
+constraint right away.  This avoids two dangers
+
+ Danger 1: If we send the original constraint on down the pipeline
+           it may react with an instance declaration, and in delicate
+           situations (when a Given overlaps with an instance) that
+           may produce new insoluble goals: see Trac #4952
+
+ Danger 2: If we don't rewrite the constraint, it may re-react
+           with the same thing later, and produce the same equality
+           again --> termination worries.
+
+To achieve this required some refactoring of FunDeps.hs (nicer
+now!).
+
+Note [FunDep and implicit parameter reactions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Currently, our story of interacting two dictionaries (or a dictionary
+and top-level instances) for functional dependencies, and implicit
+parameters, is that we simply produce new Derived equalities.  So for example
+
+        class D a b | a -> b where ...
+    Inert:
+        d1 :g D Int Bool
+    WorkItem:
+        d2 :w D Int alpha
+
+    We generate the extra work item
+        cv :d alpha ~ Bool
+    where 'cv' is currently unused.  However, this new item can perhaps be
+    spontaneously solved to become given and react with d2,
+    discharging it in favour of a new constraint d2' thus:
+        d2' :w D Int Bool
+        d2 := d2' |> D Int cv
+    Now d2' can be discharged from d1
+
+We could be more aggressive and try to *immediately* solve the dictionary
+using those extra equalities, but that requires those equalities to carry
+evidence and derived do not carry evidence.
+
+If that were the case with the same inert set and work item we might dischard
+d2 directly:
+
+        cv :w alpha ~ Bool
+        d2 := d1 |> D Int cv
+
+But in general it's a bit painful to figure out the necessary coercion,
+so we just take the first approach. Here is a better example. Consider:
+    class C a b c | a -> b
+And:
+     [Given]  d1 : C T Int Char
+     [Wanted] d2 : C T beta Int
+In this case, it's *not even possible* to solve the wanted immediately.
+So we should simply output the functional dependency and add this guy
+[but NOT its superclasses] back in the worklist. Even worse:
+     [Given] d1 : C T Int beta
+     [Wanted] d2: C T beta Int
+Then it is solvable, but its very hard to detect this on the spot.
+
+It's exactly the same with implicit parameters, except that the
+"aggressive" approach would be much easier to implement.
+
+Note [Weird fundeps]
+~~~~~~~~~~~~~~~~~~~~
+Consider   class Het a b | a -> b where
+              het :: m (f c) -> a -> m b
+
+           class GHet (a :: * -> *) (b :: * -> *) | a -> b
+           instance            GHet (K a) (K [a])
+           instance Het a b => GHet (K a) (K b)
+
+The two instances don't actually conflict on their fundeps,
+although it's pretty strange.  So they are both accepted. Now
+try   [W] GHet (K Int) (K Bool)
+This triggers fundeps from both instance decls;
+      [D] K Bool ~ K [a]
+      [D] K Bool ~ K beta
+And there's a risk of complaining about Bool ~ [a].  But in fact
+the Wanted matches the second instance, so we never get as far
+as the fundeps.
+
+Trac #7875 is a case in point.
+-}
+
+emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS ()
+-- See Note [FunDep and implicit parameter reactions]
+emitFunDepDeriveds fd_eqns
+  = mapM_ do_one_FDEqn fd_eqns
+  where
+    do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc })
+     | null tvs  -- Common shortcut
+     = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc))
+          ; mapM_ (unifyDerived loc Nominal) eqs }
+     | otherwise
+     = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs)
+          ; subst <- instFlexi tvs  -- Takes account of kind substitution
+          ; mapM_ (do_one_eq loc subst) eqs }
+
+    do_one_eq loc subst (Pair ty1 ty2)
+       = unifyDerived loc Nominal $
+         Pair (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2)
+
+{-
+**********************************************************************
+*                                                                    *
+                       The top-reaction Stage
+*                                                                    *
+**********************************************************************
+-}
+
+topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct)
+-- The work item does not react with the inert set,
+-- so try interaction with top-level instances. Note:
+topReactionsStage work_item
+  = do { traceTcS "doTopReact" (ppr work_item)
+       ; case work_item of
+           CDictCan {}  -> do { inerts <- getTcSInerts
+                              ; doTopReactDict inerts work_item }
+           CFunEqCan {} -> doTopReactFunEq work_item
+           CIrredCan {} -> doTopReactOther work_item
+           CTyEqCan {}  -> doTopReactOther work_item
+           _  -> -- Any other work item does not react with any top-level equations
+                 continueWith work_item  }
+
+
+--------------------
+doTopReactOther :: Ct -> TcS (StopOrContinue Ct)
+-- Try local quantified constraints for
+--     CTyEqCan  e.g.  (a ~# ty)
+-- and CIrredCan e.g.  (c a)
+--
+-- Why equalities? See TcCanonical
+-- Note [Equality superclasses in quantified constraints]
+doTopReactOther work_item
+  | isGiven ev
+  = continueWith work_item
+
+  | EqPred eq_rel t1 t2 <- classifyPredType pred
+  = -- See Note [Looking up primitive equalities in quantified constraints]
+    case boxEqPred eq_rel t1 t2 of
+      Nothing -> continueWith work_item
+      Just (cls, tys)
+        -> do { res <- matchLocalInst (mkClassPred cls tys) loc
+              ; case res of
+                  OneInst { cir_mk_ev = mk_ev }
+                    -> chooseInstance work_item
+                           (res { cir_mk_ev = mk_eq_ev cls tys mk_ev })
+                    where
+                  _ -> continueWith work_item }
+
+  | otherwise
+  = do { res <- matchLocalInst pred loc
+       ; case res of
+           OneInst {} -> chooseInstance work_item res
+           _          -> continueWith work_item }
+  where
+    ev = ctEvidence work_item
+    loc  = ctEvLoc ev
+    pred = ctEvPred ev
+
+    mk_eq_ev cls tys mk_ev evs
+      = case (mk_ev evs) of
+          EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e)
+          ev       -> pprPanic "mk_eq_ev" (ppr ev)
+      where
+        [sc_id] = classSCSelIds cls
+
+{- Note [Looking up primitive equalities in quantified constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For equalities (a ~# b) look up (a ~ b), and then do a superclass
+selection. This avoids having to support quantified constraints whose
+kind is not Constraint, such as (forall a. F a ~# b)
+
+See
+ * Note [Evidence for quantified constraints] in Type
+ * Note [Equality superclasses in quantified constraints]
+   in TcCanonical
+-}
+
+--------------------
+doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct)
+doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc
+                                     , cc_tyargs = args, cc_fsk = fsk })
+
+  | fsk `elemVarSet` tyCoVarsOfTypes args
+  = no_reduction    -- See Note [FunEq occurs-check principle]
+
+  | otherwise  -- Note [Reduction for Derived CFunEqCans]
+  = do { match_res <- matchFam fam_tc args
+                           -- Look up in top-level instances, or built-in axiom
+                           -- See Note [MATCHING-SYNONYMS]
+       ; case match_res of
+           Nothing         -> no_reduction
+           Just match_info -> reduce_top_fun_eq old_ev fsk match_info }
+  where
+    no_reduction
+      = do { improveTopFunEqs old_ev fam_tc args fsk
+           ; continueWith work_item }
+
+doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w)
+
+reduce_top_fun_eq :: CtEvidence -> TcTyVar -> (TcCoercion, TcType)
+                  -> TcS (StopOrContinue Ct)
+-- We have found an applicable top-level axiom: use it to reduce
+-- Precondition: fsk is not free in rhs_ty
+reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty)
+  | not (isDerived old_ev)  -- Precondition of shortCutReduction
+  , Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty
+  , isTypeFamilyTyCon tc
+  , tc_args `lengthIs` tyConArity tc    -- Short-cut
+  = -- RHS is another type-family application
+    -- Try shortcut; see Note [Top-level reductions for type functions]
+    do { shortCutReduction old_ev fsk ax_co tc tc_args
+       ; stopWith old_ev "Fun/Top (shortcut)" }
+
+  | otherwise
+  = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty)
+           , ppr old_ev $$ ppr rhs_ty )
+           -- Guaranteed by Note [FunEq occurs-check principle]
+    do { dischargeFunEq old_ev fsk ax_co rhs_ty
+       ; traceTcS "doTopReactFunEq" $
+         vcat [ text "old_ev:" <+> ppr old_ev
+              , nest 2 (text ":=") <+> ppr ax_co ]
+       ; stopWith old_ev "Fun/Top" }
+
+improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS ()
+-- See Note [FunDep and implicit parameter reactions]
+improveTopFunEqs ev fam_tc args fsk
+  | isGiven ev            -- See Note [No FunEq improvement for Givens]
+    || not (isImprovable ev)
+  = return ()
+
+  | otherwise
+  = do { ieqs <- getInertEqs
+       ; fam_envs <- getFamInstEnvs
+       ; eqns <- improve_top_fun_eqs fam_envs fam_tc args
+                                    (lookupFlattenTyVar ieqs fsk)
+       ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr fsk
+                                          , ppr eqns ])
+       ; mapM_ (unifyDerived loc Nominal) eqns }
+  where
+    loc = ctEvLoc ev  -- ToDo: this location is wrong; it should be FunDepOrigin2
+                      -- See Trac #14778
+
+improve_top_fun_eqs :: FamInstEnvs
+                    -> TyCon -> [TcType] -> TcType
+                    -> TcS [TypeEqn]
+improve_top_fun_eqs fam_envs fam_tc args rhs_ty
+  | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc
+  = return (sfInteractTop ops args rhs_ty)
+
+  -- see Note [Type inference for type families with injectivity]
+  | isOpenTypeFamilyTyCon fam_tc
+  , Injective injective_args <- tyConInjectivityInfo fam_tc
+  , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc
+  = -- it is possible to have several compatible equations in an open type
+    -- family but we only want to derive equalities from one such equation.
+    do { let improvs = buildImprovementData fam_insts
+                           fi_tvs fi_tys fi_rhs (const Nothing)
+
+       ; traceTcS "improve_top_fun_eqs2" (ppr improvs)
+       ; concatMapM (injImproveEqns injective_args) $
+         take 1 improvs }
+
+  | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc
+  , Injective injective_args <- tyConInjectivityInfo fam_tc
+  = concatMapM (injImproveEqns injective_args) $
+    buildImprovementData (fromBranches (co_ax_branches ax))
+                         cab_tvs cab_lhs cab_rhs Just
+
+  | otherwise
+  = return []
+
+  where
+      buildImprovementData
+          :: [a]                     -- axioms for a TF (FamInst or CoAxBranch)
+          -> (a -> [TyVar])          -- get bound tyvars of an axiom
+          -> (a -> [Type])           -- get LHS of an axiom
+          -> (a -> Type)             -- get RHS of an axiom
+          -> (a -> Maybe CoAxBranch) -- Just => apartness check required
+          -> [( [Type], TCvSubst, [TyVar], Maybe CoAxBranch )]
+             -- Result:
+             -- ( [arguments of a matching axiom]
+             -- , RHS-unifying substitution
+             -- , axiom variables without substitution
+             -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] )
+      buildImprovementData axioms axiomTVs axiomLHS axiomRHS wrap =
+          [ (ax_args, subst, unsubstTvs, wrap axiom)
+          | axiom <- axioms
+          , let ax_args = axiomLHS axiom
+                ax_rhs  = axiomRHS axiom
+                ax_tvs  = axiomTVs axiom
+          , Just subst <- [tcUnifyTyWithTFs False ax_rhs rhs_ty]
+          , let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst)
+                unsubstTvs    = filter (notInSubst <&&> isTyVar) ax_tvs ]
+                   -- The order of unsubstTvs is important; it must be
+                   -- in telescope order e.g. (k:*) (a:k)
+
+      injImproveEqns :: [Bool]
+                     -> ([Type], TCvSubst, [TyCoVar], Maybe CoAxBranch)
+                     -> TcS [TypeEqn]
+      injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr)
+        = do { subst <- instFlexiX subst unsubstTvs
+                  -- If the current substitution bind [k -> *], and
+                  -- one of the un-substituted tyvars is (a::k), we'd better
+                  -- be sure to apply the current substitution to a's kind.
+                  -- Hence instFlexiX.   Trac #13135 was an example.
+
+             ; return [ Pair (substTyUnchecked subst ax_arg) arg
+                        -- NB: the ax_arg part is on the left
+                        -- see Note [Improvement orientation]
+                      | case cabr of
+                          Just cabr' -> apartnessCheck (substTys subst ax_args) cabr'
+                          _          -> True
+                      , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] }
+
+
+shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion
+                  -> TyCon -> [TcType] -> TcS ()
+-- See Note [Top-level reductions for type functions]
+-- Previously, we flattened the tc_args here, but there's no need to do so.
+-- And, if we did, this function would have all the complication of
+-- TcCanonical.canCFunEqCan. See Note [canCFunEqCan]
+shortCutReduction old_ev fsk ax_co fam_tc tc_args
+  = ASSERT( ctEvEqRel old_ev == NomEq)
+               -- ax_co :: F args ~ G tc_args
+               -- old_ev :: F args ~ fsk
+    do { new_ev <- case ctEvFlavour old_ev of
+           Given -> newGivenEvVar deeper_loc
+                         ( mkPrimEqPred (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)
+                         , evCoercion (mkTcSymCo ax_co
+                                       `mkTcTransCo` ctEvCoercion old_ev) )
+
+           Wanted {} ->
+             do { (new_ev, new_co) <- newWantedEq deeper_loc Nominal
+                                        (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)
+                ; setWantedEq (ctev_dest old_ev) $ ax_co `mkTcTransCo` new_co
+                ; return new_ev }
+
+           Derived -> pprPanic "shortCutReduction" (ppr old_ev)
+
+       ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc
+                                , cc_tyargs = tc_args, cc_fsk = fsk }
+       ; updWorkListTcS (extendWorkListFunEq new_ct) }
+  where
+    deeper_loc = bumpCtLocDepth (ctEvLoc old_ev)
+
+{- Note [Top-level reductions for type functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+c.f. Note [The flattening story] in TcFlatten
+
+Suppose we have a CFunEqCan  F tys ~ fmv/fsk, and a matching axiom.
+Here is what we do, in four cases:
+
+* Wanteds: general firing rule
+    (work item) [W]        x : F tys ~ fmv
+    instantiate axiom: ax_co : F tys ~ rhs
+
+   Then:
+      Discharge   fmv := rhs
+      Discharge   x := ax_co ; sym x2
+   This is *the* way that fmv's get unified; even though they are
+   "untouchable".
+
+   NB: Given Note [FunEq occurs-check principle], fmv does not appear
+   in tys, and hence does not appear in the instantiated RHS.  So
+   the unification can't make an infinite type.
+
+* Wanteds: short cut firing rule
+  Applies when the RHS of the axiom is another type-function application
+      (work item)        [W] x : F tys ~ fmv
+      instantiate axiom: ax_co : F tys ~ G rhs_tys
+
+  It would be a waste to create yet another fmv for (G rhs_tys).
+  Instead (shortCutReduction):
+      - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis)
+      - Add G rhs_xis ~ fmv to flat cache  (note: the same old fmv)
+      - New canonical wanted   [W] x2 : G rhs_xis ~ fmv  (CFunEqCan)
+      - Discharge x := ax_co ; G cos ; x2
+
+* Givens: general firing rule
+      (work item)        [G] g : F tys ~ fsk
+      instantiate axiom: ax_co : F tys ~ rhs
+
+   Now add non-canonical given (since rhs is not flat)
+      [G] (sym g ; ax_co) : fsk ~ rhs  (Non-canonical)
+
+* Givens: short cut firing rule
+  Applies when the RHS of the axiom is another type-function application
+      (work item)        [G] g : F tys ~ fsk
+      instantiate axiom: ax_co : F tys ~ G rhs_tys
+
+  It would be a waste to create yet another fsk for (G rhs_tys).
+  Instead (shortCutReduction):
+     - Flatten rhs_tys: flat_cos : tys ~ flat_tys
+     - Add new Canonical given
+          [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk   (CFunEqCan)
+
+Note [FunEq occurs-check principle]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+I have spent a lot of time finding a good way to deal with
+CFunEqCan constraints like
+    F (fuv, a) ~ fuv
+where flatten-skolem occurs on the LHS.  Now in principle we
+might may progress by doing a reduction, but in practice its
+hard to find examples where it is useful, and easy to find examples
+where we fall into an infinite reduction loop.  A rule that works
+very well is this:
+
+  *** FunEq occurs-check principle ***
+
+      Do not reduce a CFunEqCan
+          F tys ~ fsk
+      if fsk appears free in tys
+      Instead we treat it as stuck.
+
+Examples:
+
+* Trac #5837 has [G] a ~ TF (a,Int), with an instance
+    type instance TF (a,b) = (TF a, TF b)
+  This readily loops when solving givens.  But with the FunEq occurs
+  check principle, it rapidly gets stuck which is fine.
+
+* Trac #12444 is a good example, explained in comment:2.  We have
+    type instance F (Succ x) = Succ (F x)
+    [W] alpha ~ Succ (F alpha)
+  If we allow the reduction to happen, we get an infinite loop
+
+Note [Cached solved FunEqs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When trying to solve, say (FunExpensive big-type ~ ty), it's important
+to see if we have reduced (FunExpensive big-type) before, lest we
+simply repeat it.  Hence the lookup in inert_solved_funeqs.  Moreover
+we must use `funEqCanDischarge` because both uses might (say) be Wanteds,
+and we *still* want to save the re-computation.
+
+Note [MATCHING-SYNONYMS]
+~~~~~~~~~~~~~~~~~~~~~~~~
+When trying to match a dictionary (D tau) to a top-level instance, or a
+type family equation (F taus_1 ~ tau_2) to a top-level family instance,
+we do *not* need to expand type synonyms because the matcher will do that for us.
+
+Note [Improvement orientation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A very delicate point is the orientation of derived equalities
+arising from injectivity improvement (Trac #12522).  Suppse we have
+  type family F x = t | t -> x
+  type instance F (a, Int) = (Int, G a)
+where G is injective; and wanted constraints
+
+  [W] TF (alpha, beta) ~ fuv
+  [W] fuv ~ (Int, <some type>)
+
+The injectivity will give rise to derived constraints
+
+  [D] gamma1 ~ alpha
+  [D] Int ~ beta
+
+The fresh unification variable gamma1 comes from the fact that we
+can only do "partial improvement" here; see Section 5.2 of
+"Injective type families for Haskell" (HS'15).
+
+Now, it's very important to orient the equations this way round,
+so that the fresh unification variable will be eliminated in
+favour of alpha.  If we instead had
+   [D] alpha ~ gamma1
+then we would unify alpha := gamma1; and kick out the wanted
+constraint.  But when we grough it back in, it'd look like
+   [W] TF (gamma1, beta) ~ fuv
+and exactly the same thing would happen again!  Infinite loop.
+
+This all seems fragile, and it might seem more robust to avoid
+introducing gamma1 in the first place, in the case where the
+actual argument (alpha, beta) partly matches the improvement
+template.  But that's a bit tricky, esp when we remember that the
+kinds much match too; so it's easier to let the normal machinery
+handle it.  Instead we are careful to orient the new derived
+equality with the template on the left.  Delicate, but it works.
+
+Note [No FunEq improvement for Givens]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't do improvements (injectivity etc) for Givens. Why?
+
+* It generates Derived constraints on skolems, which don't do us
+  much good, except perhaps identify inaccessible branches.
+  (They'd be perfectly valid though.)
+
+* For type-nat stuff the derived constraints include type families;
+  e.g.  (a < b), (b < c) ==> a < c If we generate a Derived for this,
+  we'll generate a Derived/Wanted CFunEqCan; and, since the same
+  InertCans (after solving Givens) are used for each iteration, that
+  massively confused the unflattening step (TcFlatten.unflatten).
+
+  In fact it led to some infinite loops:
+     indexed-types/should_compile/T10806
+     indexed-types/should_compile/T10507
+     polykinds/T10742
+
+Note [Reduction for Derived CFunEqCans]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You may wonder if it's important to use top-level instances to
+simplify [D] CFunEqCan's.  But it is.  Here's an example (T10226).
+
+   type instance F    Int = Int
+   type instance FInv Int = Int
+
+Suppose we have to solve
+    [WD] FInv (F alpha) ~ alpha
+    [WD] F alpha ~ Int
+
+  --> flatten
+    [WD] F alpha ~ fuv0
+    [WD] FInv fuv0 ~ fuv1  -- (A)
+    [WD] fuv1 ~ alpha
+    [WD] fuv0 ~ Int        -- (B)
+
+  --> Rewwrite (A) with (B), splitting it
+    [WD] F alpha ~ fuv0
+    [W] FInv fuv0 ~ fuv1
+    [D] FInv Int ~ fuv1    -- (C)
+    [WD] fuv1 ~ alpha
+    [WD] fuv0 ~ Int
+
+  --> Reduce (C) with top-level instance
+      **** This is the key step ***
+    [WD] F alpha ~ fuv0
+    [W] FInv fuv0 ~ fuv1
+    [D] fuv1 ~ Int        -- (D)
+    [WD] fuv1 ~ alpha     -- (E)
+    [WD] fuv0 ~ Int
+
+  --> Rewrite (D) with (E)
+    [WD] F alpha ~ fuv0
+    [W] FInv fuv0 ~ fuv1
+    [D] alpha ~ Int       -- (F)
+    [WD] fuv1 ~ alpha
+    [WD] fuv0 ~ Int
+
+  --> unify (F)  alpha := Int, and that solves it
+
+Another example is indexed-types/should_compile/T10634
+-}
+
+{- *******************************************************************
+*                                                                    *
+         Top-level reaction for class constraints (CDictCan)
+*                                                                    *
+**********************************************************************-}
+
+doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct)
+-- Try to use type-class instance declarations to simplify the constraint
+doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls
+                                          , cc_tyargs = xis })
+  | isGiven ev   -- Never use instances for Given constraints
+  = do { try_fundep_improvement
+       ; continueWith work_item }
+
+  | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis   -- Cached
+  = do { setEvBindIfWanted ev (ctEvTerm solved_ev)
+       ; stopWith ev "Dict/Top (cached)" }
+
+  | otherwise  -- Wanted or Derived, but not cached
+   = do { dflags <- getDynFlags
+        ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc
+        ; case lkup_res of
+               OneInst { cir_what = what }
+                  -> do { unless (safeOverlap what) $
+                          insertSafeOverlapFailureTcS work_item
+                        ; when (isWanted ev) $ addSolvedDict ev cls xis
+                        ; chooseInstance work_item lkup_res }
+               _  ->  -- NoInstance or NotSure
+                     do { when (isImprovable ev) $
+                          try_fundep_improvement
+                        ; continueWith work_item } }
+   where
+     dict_pred   = mkClassPred cls xis
+     dict_loc    = ctEvLoc ev
+     dict_origin = ctLocOrigin dict_loc
+
+     -- We didn't solve it; so try functional dependencies with
+     -- the instance environment, and return
+     -- See also Note [Weird fundeps]
+     try_fundep_improvement
+        = do { traceTcS "try_fundeps" (ppr work_item)
+             ; instEnvs <- getInstEnvs
+             ; emitFunDepDeriveds $
+               improveFromInstEnv instEnvs mk_ct_loc dict_pred }
+
+     mk_ct_loc :: PredType   -- From instance decl
+               -> SrcSpan    -- also from instance deol
+               -> CtLoc
+     mk_ct_loc inst_pred inst_loc
+       = dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin
+                                               inst_pred inst_loc }
+
+doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)
+
+
+chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct)
+chooseInstance work_item
+               (OneInst { cir_new_theta = theta
+                        , cir_what      = what
+                        , cir_mk_ev     = mk_ev })
+  = do { traceTcS "doTopReact/found instance for" $ ppr ev
+       ; deeper_loc <- checkInstanceOK loc what pred
+       ; if isDerived ev then finish_derived deeper_loc theta
+                         else finish_wanted  deeper_loc theta mk_ev }
+  where
+     ev         = ctEvidence work_item
+     pred       = ctEvPred ev
+     loc        = ctEvLoc ev
+
+     finish_wanted :: CtLoc -> [TcPredType]
+                   -> ([EvExpr] -> EvTerm) -> TcS (StopOrContinue Ct)
+      -- Precondition: evidence term matches the predicate workItem
+     finish_wanted loc theta mk_ev
+        = do { evb <- getTcEvBindsVar
+             ; if isCoEvBindsVar evb
+               then -- See Note [Instances in no-evidence implications]
+                    continueWith work_item
+               else
+          do { evc_vars <- mapM (newWanted loc) theta
+             ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars))
+             ; emitWorkNC (freshGoals evc_vars)
+             ; stopWith ev "Dict/Top (solved wanted)" } }
+
+     finish_derived loc theta
+       = -- Use type-class instances for Deriveds, in the hope
+         -- of generating some improvements
+         -- C.f. Example 3 of Note [The improvement story]
+         -- It's easy because no evidence is involved
+         do { emitNewDeriveds loc theta
+            ; traceTcS "finish_derived" (ppr (ctl_depth loc))
+            ; stopWith ev "Dict/Top (solved derived)" }
+
+chooseInstance work_item lookup_res
+  = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res)
+
+checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc
+-- Check that it's OK to use this insstance:
+--    (a) the use is well staged in the Template Haskell sense
+--    (b) we have not recursed too deep
+-- Returns the CtLoc to used for sub-goals
+checkInstanceOK loc what pred
+  = do { checkWellStagedDFun loc what pred
+       ; checkReductionDepth deeper_loc pred
+       ; return deeper_loc }
+  where
+     deeper_loc = zap_origin (bumpCtLocDepth loc)
+     origin     = ctLocOrigin loc
+
+     zap_origin loc  -- After applying an instance we can set ScOrigin to
+                     -- infinity, so that prohibitedSuperClassSolve never fires
+       | ScOrigin {} <- origin
+       = setCtLocOrigin loc (ScOrigin infinity)
+       | otherwise
+       = loc
+
+{- Note [Instances in no-evidence implications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In Trac #15290 we had
+  [G] forall p q. Coercible p q => Coercible (m p) (m q))
+  [W] forall <no-ev> a. m (Int, IntStateT m a)
+                          ~R#
+                        m (Int, StateT Int m a)
+
+The Given is an ordinary quantified constraint; the Wanted is an implication
+equality that arises from
+  [W] (forall a. t1) ~R# (forall a. t2)
+
+But because the (t1 ~R# t2) is solved "inside a type" (under that forall a)
+we can't generate any term evidence.  So we can't actually use that
+lovely quantified constraint.  Alas!
+
+This test arranges to ignore the instance-based solution under these
+(rare) circumstances.   It's sad, but I  really don't see what else we can do.
+-}
+
+
+matchClassInst :: DynFlags -> InertSet
+               -> Class -> [Type]
+               -> CtLoc -> TcS ClsInstResult
+matchClassInst dflags inerts clas tys loc
+-- First check whether there is an in-scope Given that could
+-- match this constraint.  In that case, do not use any instance
+-- whether top level, or local quantified constraints.
+-- ee Note [Instance and Given overlap]
+  | not (xopt LangExt.IncoherentInstances dflags)
+  , not (naturallyCoherentClass clas)
+  , let matchable_givens = matchableGivens loc pred inerts
+  , not (isEmptyBag matchable_givens)
+  = do { traceTcS "Delaying instance application" $
+           vcat [ text "Work item=" <+> pprClassPred clas tys
+                , text "Potential matching givens:" <+> ppr matchable_givens ]
+       ; return NotSure }
+
+  | otherwise
+  = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr pred <+> char '{'
+       ; local_res <- matchLocalInst pred loc
+       ; case local_res of
+           OneInst {} ->  -- See Note [Local instances and incoherence]
+                do { traceTcS "} matchClassInst local match" $ ppr local_res
+                   ; return local_res }
+
+           NotSure -> -- In the NotSure case for local instances
+                      -- we don't want to try global instances
+                do { traceTcS "} matchClassInst local not sure" empty
+                   ; return local_res }
+
+           NoInstance  -- No local instances, so try global ones
+              -> do { global_res <- matchGlobalInst dflags False clas tys
+                    ; traceTcS "} matchClassInst global result" $ ppr global_res
+                    ; return global_res } }
+  where
+    pred = mkClassPred clas tys
+
+-- | If a class is "naturally coherent", then we needn't worry at all, in any
+-- way, about overlapping/incoherent instances. Just solve the thing!
+-- See Note [Naturally coherent classes]
+-- See also Note [The equality class story] in TysPrim.
+naturallyCoherentClass :: Class -> Bool
+naturallyCoherentClass cls
+  = isCTupleClass cls
+    || cls `hasKey` heqTyConKey
+    || cls `hasKey` eqTyConKey
+    || cls `hasKey` coercibleTyConKey
+
+
+{- Note [Instance and Given overlap]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Example, from the OutsideIn(X) paper:
+       instance P x => Q [x]
+       instance (x ~ y) => R y [x]
+
+       wob :: forall a b. (Q [b], R b a) => a -> Int
+
+       g :: forall a. Q [a] => [a] -> Int
+       g x = wob x
+
+From 'g' we get the impliation constraint:
+            forall a. Q [a] => (Q [beta], R beta [a])
+If we react (Q [beta]) with its top-level axiom, we end up with a
+(P beta), which we have no way of discharging. On the other hand,
+if we react R beta [a] with the top-level we get  (beta ~ a), which
+is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is
+now solvable by the given Q [a].
+
+The partial solution is that:
+  In matchClassInst (and thus in topReact), we return a matching
+  instance only when there is no Given in the inerts which is
+  unifiable to this particular dictionary.
+
+  We treat any meta-tyvar as "unifiable" for this purpose,
+  *including* untouchable ones.  But not skolems like 'a' in
+  the implication constraint above.
+
+The end effect is that, much as we do for overlapping instances, we
+delay choosing a class instance if there is a possibility of another
+instance OR a given to match our constraint later on. This fixes
+Trac #4981 and #5002.
+
+Other notes:
+
+* The check is done *first*, so that it also covers classes
+  with built-in instance solving, such as
+     - constraint tuples
+     - natural numbers
+     - Typeable
+
+* Flatten-skolems: we do not treat a flatten-skolem as unifiable
+  for this purpose.
+  E.g.   f :: Eq (F a) => [a] -> [a]
+         f xs = ....(xs==xs).....
+  Here we get [W] Eq [a], and we don't want to refrain from solving
+  it because of the given (Eq (F a)) constraint!
+
+* The given-overlap problem is arguably not easy to appear in practice
+  due to our aggressive prioritization of equality solving over other
+  constraints, but it is possible. I've added a test case in
+  typecheck/should-compile/GivenOverlapping.hs
+
+* Another "live" example is Trac #10195; another is #10177.
+
+* We ignore the overlap problem if -XIncoherentInstances is in force:
+  see Trac #6002 for a worked-out example where this makes a
+  difference.
+
+* Moreover notice that our goals here are different than the goals of
+  the top-level overlapping checks. There we are interested in
+  validating the following principle:
+
+      If we inline a function f at a site where the same global
+      instance environment is available as the instance environment at
+      the definition site of f then we should get the same behaviour.
+
+  But for the Given Overlap check our goal is just related to completeness of
+  constraint solving.
+
+* The solution is only a partial one.  Consider the above example with
+       g :: forall a. Q [a] => [a] -> Int
+       g x = let v = wob x
+             in v
+  and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most
+  general type for 'v'.  When generalising v's type we'll simplify its
+  Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we
+  will use the instance declaration after all. Trac #11948 was a case
+  in point.
+
+All of this is disgustingly delicate, so to discourage people from writing
+simplifiable class givens, we warn about signatures that contain them;
+see TcValidity Note [Simplifiable given constraints].
+
+Note [Naturally coherent classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A few built-in classes are "naturally coherent".  This term means that
+the "instance" for the class is bidirectional with its superclass(es).
+For example, consider (~~), which behaves as if it was defined like
+this:
+  class a ~# b => a ~~ b
+  instance a ~# b => a ~~ b
+(See Note [The equality types story] in TysPrim.)
+
+Faced with [W] t1 ~~ t2, it's always OK to reduce it to [W] t1 ~# t2,
+without worrying about Note [Instance and Given overlap].  Why?  Because
+if we had [G] s1 ~~ s2, then we'd get the superclass [G] s1 ~# s2, and
+so the reduction of the [W] constraint does not risk losing any solutions.
+
+On the other hand, it can be fatal to /fail/ to reduce such
+equalities, on the grounds of Note [Instance and Given overlap],
+because many good things flow from [W] t1 ~# t2.
+
+The same reasoning applies to
+
+* (~~)        heqTyCOn
+* (~)         eqTyCon
+* Coercible   coercibleTyCon
+
+And less obviously to:
+
+* Tuple classes.  For reasons described in TcSMonad
+  Note [Tuples hiding implicit parameters], we may have a constraint
+     [W] (?x::Int, C a)
+  with an exactly-matching Given constraint.  We must decompose this
+  tuple and solve the components separately, otherwise we won't solve
+  it at all!  It is perfectly safe to decompose it, because again the
+  superclasses invert the instance;  e.g.
+      class (c1, c2) => (% c1, c2 %)
+      instance (c1, c2) => (% c1, c2 %)
+  Example in Trac #14218
+
+Exammples: T5853, T10432, T5315, T9222, T2627b, T3028b
+
+PS: the term "naturally coherent" doesn't really seem helpful.
+Perhaps "invertible" or something?  I left it for now though.
+
+Note [Local instances and incoherence]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f :: forall b c. (Eq b, forall a. Eq a => Eq (c a))
+                 => c b -> Bool
+   f x = x==x
+
+We get [W] Eq (c b), and we must use the local instance to solve it.
+
+BUT that wanted also unifies with the top-level Eq [a] instance,
+and Eq (Maybe a) etc.  We want the local instance to "win", otherwise
+we can't solve the wanted at all.  So we mark it as Incohherent.
+According to Note [Rules for instance lookup] in InstEnv, that'll
+make it win even if there are other instances that unify.
+
+Moreover this is not a hack!  The evidence for this local instance
+will be constructed by GHC at a call site... from the very instances
+that unify with it here.  It is not like an incoherent user-written
+instance which might have utterly different behaviour.
+
+Consdider  f :: Eq a => blah.  If we have [W] Eq a, we certainly
+get it from the Eq a context, without worrying that there are
+lots of top-level instances that unify with [W] Eq a!  We'll use
+those instances to build evidence to pass to f. That's just the
+nullary case of what's happening here.
+-}
+
+matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult
+-- Look up the predicate in Given quantified constraints,
+-- which are effectively just local instance declarations.
+matchLocalInst pred loc
+  = do { ics <- getInertCans
+       ; case match_local_inst (inert_insts ics) of
+           ([], False) -> return NoInstance
+           ([(dfun_ev, inst_tys)], unifs)
+             | not unifs
+             -> do { let dfun_id = ctEvEvId dfun_ev
+                   ; (tys, theta) <- instDFunType dfun_id inst_tys
+                   ; return $ OneInst { cir_new_theta = theta
+                                      , cir_mk_ev     = evDFunApp dfun_id tys
+                                      , cir_what      = LocalInstance } }
+           _ -> return NotSure }
+  where
+    pred_tv_set = tyCoVarsOfType pred
+
+    match_local_inst :: [QCInst]
+                     -> ( [(CtEvidence, [DFunInstType])]
+                        , Bool )      -- True <=> Some unify but do not match
+    match_local_inst []
+      = ([], False)
+    match_local_inst (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred
+                               , qci_ev = ev })
+                     : qcis)
+      | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set)
+      , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope)
+                                        emptyTvSubstEnv qpred pred
+      , let match = (ev, map (lookupVarEnv tv_subst) qtvs)
+      = (match:matches, unif)
+
+      | otherwise
+      = ASSERT2( disjointVarSet qtv_set (tyCoVarsOfType pred)
+               , ppr qci $$ ppr pred )
+            -- ASSERT: unification relies on the
+            -- quantified variables being fresh
+        (matches, unif || this_unif)
+      where
+        qtv_set = mkVarSet qtvs
+        this_unif = mightMatchLater qpred (ctEvLoc ev) pred loc
+        (matches, unif) = match_local_inst qcis
+
diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcMType.hs
@@ -0,0 +1,2207 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Monadic type operations
+
+This module contains monadic operations over types that contain
+mutable type variables
+-}
+
+{-# LANGUAGE CPP, TupleSections, MultiWayIf #-}
+
+module TcMType (
+  TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet,
+
+  --------------------------------
+  -- Creating new mutable type variables
+  newFlexiTyVar,
+  newFlexiTyVarTy,              -- Kind -> TcM TcType
+  newFlexiTyVarTys,             -- Int -> Kind -> TcM [TcType]
+  newOpenFlexiTyVarTy, newOpenTypeKind,
+  newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel,
+  cloneMetaTyVar,
+  newFmvTyVar, newFskTyVar,
+
+  readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
+  newMetaDetails, isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar,
+
+  --------------------------------
+  -- Expected types
+  ExpType(..), ExpSigmaType, ExpRhoType,
+  mkCheckExpType,
+  newInferExpType, newInferExpTypeInst, newInferExpTypeNoInst,
+  readExpType, readExpType_maybe,
+  expTypeToType, checkingExpType_maybe, checkingExpType,
+  tauifyExpType, inferResultToType,
+
+  --------------------------------
+  -- Creating new evidence variables
+  newEvVar, newEvVars, newDict,
+  newWanted, newWanteds, newHoleCt, cloneWanted, cloneWC,
+  emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,
+  emitDerivedEqs,
+  newTcEvBinds, newNoTcEvBinds, addTcEvBind,
+
+  newCoercionHole, fillCoercionHole, isFilledCoercionHole,
+  unpackCoercionHole, unpackCoercionHole_maybe,
+  checkCoercionHole,
+
+  --------------------------------
+  -- Instantiation
+  newMetaTyVars, newMetaTyVarX, newMetaTyVarsX,
+  newMetaTyVarTyVars, newMetaTyVarTyVarX,
+  newTyVarTyVar, newTauTyVar, newSkolemTyVar, newWildCardX,
+  tcInstType,
+  tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,
+  tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,
+
+  freshenTyVarBndrs, freshenCoVarBndrsX,
+
+  --------------------------------
+  -- Zonking and tidying
+  zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin,
+  tidyEvVar, tidyCt, tidySkolemInfo,
+    zonkTcTyVar, zonkTcTyVars,
+  zonkTcTyVarToTyVar, zonkTyVarTyVarPairs,
+  zonkTyCoVarsAndFV, zonkTcTypeAndFV,
+  zonkTyCoVarsAndFVList,
+  candidateQTyVarsOfType,  candidateQTyVarsOfKind,
+  candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,
+  CandidatesQTvs(..), delCandidates, candidateKindVars,
+  skolemiseQuantifiedTyVar, defaultTyVar,
+  quantifyTyVars,
+  zonkTcTyCoVarBndr, zonkTyConBinders,
+  zonkTcType, zonkTcTypes, zonkCo,
+  zonkTyCoVarKind,
+
+  zonkEvVar, zonkWC, zonkSimples,
+  zonkId, zonkCoVar,
+  zonkCt, zonkSkolemInfo,
+
+  tcGetGlobalTyCoVars,
+
+  ------------------------------
+  -- Levity polymorphism
+  ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr
+  ) where
+
+#include "HsVersions.h"
+
+-- friends:
+import GhcPrelude
+
+import TyCoRep
+import TcType
+import Type
+import TyCon
+import Coercion
+import Class
+import Var
+
+-- others:
+import TcRnMonad        -- TcType, amongst others
+import TcEvidence
+import Id
+import Name
+import VarSet
+import TysWiredIn
+import TysPrim
+import VarEnv
+import NameEnv
+import PrelNames
+import Util
+import Outputable
+import FastString
+import Bag
+import Pair
+import UniqSet
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Maybes
+import Data.List        ( mapAccumL )
+import Control.Arrow    ( second )
+import qualified Data.Semigroup as Semi
+
+{-
+************************************************************************
+*                                                                      *
+        Kind variables
+*                                                                      *
+************************************************************************
+-}
+
+mkKindName :: Unique -> Name
+mkKindName unique = mkSystemName unique kind_var_occ
+
+kind_var_occ :: OccName -- Just one for all MetaKindVars
+                        -- They may be jiggled by tidying
+kind_var_occ = mkOccName tvName "k"
+
+newMetaKindVar :: TcM TcKind
+newMetaKindVar = do { uniq <- newUnique
+                    ; details <- newMetaDetails TauTv
+                    ; let kv = mkTcTyVar (mkKindName uniq) liftedTypeKind details
+                    ; traceTc "newMetaKindVar" (ppr kv)
+                    ; return (mkTyVarTy kv) }
+
+newMetaKindVars :: Int -> TcM [TcKind]
+newMetaKindVars n = mapM (\ _ -> newMetaKindVar) (nOfThem n ())
+
+{-
+************************************************************************
+*                                                                      *
+     Evidence variables; range over constraints we can abstract over
+*                                                                      *
+************************************************************************
+-}
+
+newEvVars :: TcThetaType -> TcM [EvVar]
+newEvVars theta = mapM newEvVar theta
+
+--------------
+
+newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar
+-- Creates new *rigid* variables for predicates
+newEvVar ty = do { name <- newSysName (predTypeOccName ty)
+                 ; return (mkLocalIdOrCoVar name ty) }
+
+newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence
+-- Deals with both equality and non-equality predicates
+newWanted orig t_or_k pty
+  = do loc <- getCtLocM orig t_or_k
+       d <- if isEqPred pty then HoleDest  <$> newCoercionHole pty
+                            else EvVarDest <$> newEvVar pty
+       return $ CtWanted { ctev_dest = d
+                         , ctev_pred = pty
+                         , ctev_nosh = WDeriv
+                         , ctev_loc = loc }
+
+newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence]
+newWanteds orig = mapM (newWanted orig Nothing)
+
+-- | Create a new 'CHoleCan' 'Ct'.
+newHoleCt :: Hole -> Id -> Type -> TcM Ct
+newHoleCt hole ev ty = do
+  loc <- getCtLocM HoleOrigin Nothing
+  pure $ CHoleCan { cc_ev = CtWanted { ctev_pred = ty
+                                     , ctev_dest = EvVarDest ev
+                                     , ctev_nosh = WDeriv
+                                     , ctev_loc  = loc }
+                  , cc_hole = hole }
+
+----------------------------------------------
+-- Cloning constraints
+----------------------------------------------
+
+cloneWanted :: Ct -> TcM Ct
+cloneWanted ct
+  | ev@(CtWanted { ctev_dest = HoleDest {}, ctev_pred = pty }) <- ctEvidence ct
+  = do { co_hole <- newCoercionHole pty
+       ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) }
+  | otherwise
+  = return ct
+
+cloneWC :: WantedConstraints -> TcM WantedConstraints
+-- Clone all the evidence bindings in
+--   a) the ic_bind field of any implications
+--   b) the CoercionHoles of any wanted constraints
+-- so that solving the WantedConstraints will not have any visible side
+-- effect, /except/ from causing unifications
+cloneWC wc@(WC { wc_simple = simples, wc_impl = implics })
+  = do { simples' <- mapBagM cloneWanted simples
+       ; implics' <- mapBagM cloneImplication implics
+       ; return (wc { wc_simple = simples', wc_impl = implics' }) }
+
+cloneImplication :: Implication -> TcM Implication
+cloneImplication implic@(Implic { ic_binds = binds, ic_wanted = inner_wanted })
+  = do { binds'        <- cloneEvBindsVar binds
+       ; inner_wanted' <- cloneWC inner_wanted
+       ; return (implic { ic_binds = binds', ic_wanted = inner_wanted' }) }
+
+----------------------------------------------
+-- Emitting constraints
+----------------------------------------------
+
+-- | Emits a new Wanted. Deals with both equalities and non-equalities.
+emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm
+emitWanted origin pty
+  = do { ev <- newWanted origin Nothing pty
+       ; emitSimple $ mkNonCanonical ev
+       ; return $ ctEvTerm ev }
+
+emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM ()
+-- Emit some new derived nominal equalities
+emitDerivedEqs origin pairs
+  | null pairs
+  = return ()
+  | otherwise
+  = do { loc <- getCtLocM origin Nothing
+       ; emitSimples (listToBag (map (mk_one loc) pairs)) }
+  where
+    mk_one loc (ty1, ty2)
+       = mkNonCanonical $
+         CtDerived { ctev_pred = mkPrimEqPred ty1 ty2
+                   , ctev_loc = loc }
+
+-- | Emits a new equality constraint
+emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion
+emitWantedEq origin t_or_k role ty1 ty2
+  = do { hole <- newCoercionHole pty
+       ; loc <- getCtLocM origin (Just t_or_k)
+       ; emitSimple $ mkNonCanonical $
+         CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole
+                  , ctev_nosh = WDeriv, ctev_loc = loc }
+       ; return (HoleCo hole) }
+  where
+    pty = mkPrimEqPredRole role ty1 ty2
+
+-- | Creates a new EvVar and immediately emits it as a Wanted.
+-- No equality predicates here.
+emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar
+emitWantedEvVar origin ty
+  = do { new_cv <- newEvVar ty
+       ; loc <- getCtLocM origin Nothing
+       ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv
+                             , ctev_pred = ty
+                             , ctev_nosh = WDeriv
+                             , ctev_loc  = loc }
+       ; emitSimple $ mkNonCanonical ctev
+       ; return new_cv }
+
+emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar]
+emitWantedEvVars orig = mapM (emitWantedEvVar orig)
+
+newDict :: Class -> [TcType] -> TcM DictId
+newDict cls tys
+  = do { name <- newSysName (mkDictOcc (getOccName cls))
+       ; return (mkLocalId name (mkClassPred cls tys)) }
+
+predTypeOccName :: PredType -> OccName
+predTypeOccName ty = case classifyPredType ty of
+    ClassPred cls _ -> mkDictOcc (getOccName cls)
+    EqPred {}       -> mkVarOccFS (fsLit "co")
+    IrredPred {}    -> mkVarOccFS (fsLit "irred")
+    ForAllPred {}   -> mkVarOccFS (fsLit "df")
+
+{-
+************************************************************************
+*                                                                      *
+        Coercion holes
+*                                                                      *
+************************************************************************
+-}
+
+newCoercionHole :: TcPredType -> TcM CoercionHole
+newCoercionHole pred_ty
+  = do { co_var <- newEvVar pred_ty
+       ; traceTc "New coercion hole:" (ppr co_var)
+       ; ref <- newMutVar Nothing
+       ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } }
+
+-- | Put a value in a coercion hole
+fillCoercionHole :: CoercionHole -> Coercion -> TcM ()
+fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co
+  = do {
+#if defined(DEBUG)
+       ; cts <- readTcRef ref
+       ; whenIsJust cts $ \old_co ->
+         pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co)
+#endif
+       ; traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co)
+       ; writeTcRef ref (Just co) }
+
+-- | Is a coercion hole filled in?
+isFilledCoercionHole :: CoercionHole -> TcM Bool
+isFilledCoercionHole (CoercionHole { ch_ref = ref }) = isJust <$> readTcRef ref
+
+-- | Retrieve the contents of a coercion hole. Panics if the hole
+-- is unfilled
+unpackCoercionHole :: CoercionHole -> TcM Coercion
+unpackCoercionHole hole
+  = do { contents <- unpackCoercionHole_maybe hole
+       ; case contents of
+           Just co -> return co
+           Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) }
+
+-- | Retrieve the contents of a coercion hole, if it is filled
+unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion)
+unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref
+
+-- | Check that a coercion is appropriate for filling a hole. (The hole
+-- itself is needed only for printing.
+-- Always returns the checked coercion, but this return value is necessary
+-- so that the input coercion is forced only when the output is forced.
+checkCoercionHole :: CoVar -> Coercion -> TcM Coercion
+checkCoercionHole cv co
+  | debugIsOn
+  = do { cv_ty <- zonkTcType (varType cv)
+                  -- co is already zonked, but cv might not be
+       ; return $
+         ASSERT2( ok cv_ty
+                , (text "Bad coercion hole" <+>
+                   ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role
+                                            , ppr cv_ty ]) )
+         co }
+  | otherwise
+  = return co
+
+  where
+    (Pair t1 t2, role) = coercionKindRole co
+    ok cv_ty | EqPred cv_rel cv_t1 cv_t2 <- classifyPredType cv_ty
+             =  t1 `eqType` cv_t1
+             && t2 `eqType` cv_t2
+             && role == eqRelRole cv_rel
+             | otherwise
+             = False
+
+{-
+************************************************************************
+*
+    Expected types
+*
+************************************************************************
+
+Note [ExpType]
+~~~~~~~~~~~~~~
+
+An ExpType is used as the "expected type" when type-checking an expression.
+An ExpType can hold a "hole" that can be filled in by the type-checker.
+This allows us to have one tcExpr that works in both checking mode and
+synthesis mode (that is, bidirectional type-checking). Previously, this
+was achieved by using ordinary unification variables, but we don't need
+or want that generality. (For example, #11397 was caused by doing the
+wrong thing with unification variables.) Instead, we observe that these
+holes should
+
+1. never be nested
+2. never appear as the type of a variable
+3. be used linearly (never be duplicated)
+
+By defining ExpType, separately from Type, we can achieve goals 1 and 2
+statically.
+
+See also [wiki:Typechecking]
+
+Note [TcLevel of ExpType]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+  data G a where
+    MkG :: G Bool
+
+  foo MkG = True
+
+This is a classic untouchable-variable / ambiguous GADT return type
+scenario. But, with ExpTypes, we'll be inferring the type of the RHS.
+And, because there is only one branch of the case, we won't trigger
+Note [Case branches must never infer a non-tau type] of TcMatches.
+We thus must track a TcLevel in an Inferring ExpType. If we try to
+fill the ExpType and find that the TcLevels don't work out, we
+fill the ExpType with a tau-tv at the low TcLevel, hopefully to
+be worked out later by some means. This is triggered in
+test gadt/gadt-escape1.
+
+-}
+
+-- actual data definition is in TcType
+
+-- | Make an 'ExpType' suitable for inferring a type of kind * or #.
+newInferExpTypeNoInst :: TcM ExpSigmaType
+newInferExpTypeNoInst = newInferExpType False
+
+newInferExpTypeInst :: TcM ExpRhoType
+newInferExpTypeInst = newInferExpType True
+
+newInferExpType :: Bool -> TcM ExpType
+newInferExpType inst
+  = do { u <- newUnique
+       ; tclvl <- getTcLevel
+       ; traceTc "newOpenInferExpType" (ppr u <+> ppr inst <+> ppr tclvl)
+       ; ref <- newMutVar Nothing
+       ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl
+                           , ir_ref = ref, ir_inst = inst })) }
+
+-- | Extract a type out of an ExpType, if one exists. But one should always
+-- exist. Unless you're quite sure you know what you're doing.
+readExpType_maybe :: ExpType -> TcM (Maybe TcType)
+readExpType_maybe (Check ty)                   = return (Just ty)
+readExpType_maybe (Infer (IR { ir_ref = ref})) = readMutVar ref
+
+-- | Extract a type out of an ExpType. Otherwise, panics.
+readExpType :: ExpType -> TcM TcType
+readExpType exp_ty
+  = do { mb_ty <- readExpType_maybe exp_ty
+       ; case mb_ty of
+           Just ty -> return ty
+           Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) }
+
+-- | Returns the expected type when in checking mode.
+checkingExpType_maybe :: ExpType -> Maybe TcType
+checkingExpType_maybe (Check ty) = Just ty
+checkingExpType_maybe _          = Nothing
+
+-- | Returns the expected type when in checking mode. Panics if in inference
+-- mode.
+checkingExpType :: String -> ExpType -> TcType
+checkingExpType _   (Check ty) = ty
+checkingExpType err et         = pprPanic "checkingExpType" (text err $$ ppr et)
+
+tauifyExpType :: ExpType -> TcM ExpType
+-- ^ Turn a (Infer hole) type into a (Check alpha),
+-- where alpha is a fresh unification variable
+tauifyExpType (Check ty)      = return (Check ty)  -- No-op for (Check ty)
+tauifyExpType (Infer inf_res) = do { ty <- inferResultToType inf_res
+                                   ; return (Check ty) }
+
+-- | Extracts the expected type if there is one, or generates a new
+-- TauTv if there isn't.
+expTypeToType :: ExpType -> TcM TcType
+expTypeToType (Check ty)      = return ty
+expTypeToType (Infer inf_res) = inferResultToType inf_res
+
+inferResultToType :: InferResult -> TcM Type
+inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl
+                      , ir_ref = ref })
+  = do { rr  <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy
+       ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr)
+             -- See Note [TcLevel of ExpType]
+       ; writeMutVar ref (Just tau)
+       ; traceTc "Forcing ExpType to be monomorphic:"
+                 (ppr u <+> text ":=" <+> ppr tau)
+       ; return tau }
+
+
+{- *********************************************************************
+*                                                                      *
+        SkolemTvs (immutable)
+*                                                                      *
+********************************************************************* -}
+
+tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar]))
+                   -- ^ How to instantiate the type variables
+           -> Id                                            -- ^ Type to instantiate
+           -> TcM ([(Name, TcTyVar)], TcThetaType, TcType)  -- ^ Result
+                -- (type vars, preds (incl equalities), rho)
+tcInstType inst_tyvars id
+  = case tcSplitForAllTys (idType id) of
+        ([],    rho) -> let     -- There may be overloading despite no type variables;
+                                --      (?x :: Int) => Int -> Int
+                                (theta, tau) = tcSplitPhiTy rho
+                            in
+                            return ([], theta, tau)
+
+        (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars
+                            ; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho)
+                                  tv_prs       = map tyVarName tyvars `zip` tyvars'
+                            ; return (tv_prs, theta, tau) }
+
+tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType)
+-- Instantiate a type signature with skolem constants.
+-- We could give them fresh names, but no need to do so
+tcSkolDFunType dfun
+  = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun
+       ; return (map snd tv_prs, theta, tau) }
+
+tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar])
+-- Make skolem constants, but do *not* give them new names, as above
+-- Moreover, make them "super skolems"; see comments with superSkolemTv
+-- see Note [Kind substitution when instantiating]
+-- Precondition: tyvars should be ordered by scoping
+tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst
+
+tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar)
+tcSuperSkolTyVar subst tv
+  = (extendTvSubstWithClone subst tv new_tv, new_tv)
+  where
+    kind   = substTyUnchecked subst (tyVarKind tv)
+    new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv
+
+-- | Given a list of @['TyVar']@, skolemize the type variables,
+-- returning a substitution mapping the original tyvars to the
+-- skolems, and the list of newly bound skolems.
+tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- See Note [Skolemising type variables]
+tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst
+
+tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- See Note [Skolemising type variables]
+tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False
+
+tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- See Note [Skolemising type variables]
+tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst
+
+tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- See Note [Skolemising type variables]
+tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst
+
+tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar]
+                          -> TcM (TCvSubst, [TcTyVar])
+-- Skolemise one level deeper, hence pushTcLevel
+-- See Note [Skolemising type variables]
+tcInstSkolTyVarsPushLevel overlappable subst tvs
+  = do { tc_lvl <- getTcLevel
+       ; let pushed_lvl = pushTcLevel tc_lvl
+       ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs }
+
+tcInstSkolTyVarsAt :: TcLevel -> Bool
+                   -> TCvSubst -> [TyVar]
+                   -> TcM (TCvSubst, [TcTyVar])
+tcInstSkolTyVarsAt lvl overlappable subst tvs
+  = freshenTyCoVarsX new_skol_tv subst tvs
+  where
+    details = SkolemTv lvl overlappable
+    new_skol_tv name kind = mkTcTyVar name kind details
+
+------------------
+freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar])
+-- ^ Give fresh uniques to a bunch of TyVars, but they stay
+--   as TyVars, rather than becoming TcTyVars
+-- Used in FamInst.newFamInst, and Inst.newClsInst
+freshenTyVarBndrs = freshenTyCoVars mkTyVar
+
+freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar])
+-- ^ Give fresh uniques to a bunch of CoVars
+-- Used in FamInst.newFamInst
+freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst
+
+------------------
+freshenTyCoVars :: (Name -> Kind -> TyCoVar)
+                -> [TyVar] -> TcM (TCvSubst, [TyCoVar])
+freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst
+
+freshenTyCoVarsX :: (Name -> Kind -> TyCoVar)
+                 -> TCvSubst -> [TyCoVar]
+                 -> TcM (TCvSubst, [TyCoVar])
+freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv)
+
+freshenTyCoVarX :: (Name -> Kind -> TyCoVar)
+                -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar)
+-- This a complete freshening operation:
+-- the skolems have a fresh unique, and a location from the monad
+-- See Note [Skolemising type variables]
+freshenTyCoVarX mk_tcv subst tycovar
+  = do { loc  <- getSrcSpanM
+       ; uniq <- newUnique
+       ; let old_name = tyVarName tycovar
+             new_name = mkInternalName uniq (getOccName old_name) loc
+             new_kind = substTyUnchecked subst (tyVarKind tycovar)
+             new_tcv  = mk_tcv new_name new_kind
+             subst1   = extendTCvSubstWithClone subst tycovar new_tcv
+       ; return (subst1, new_tcv) }
+
+{- Note [Skolemising type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The tcInstSkolTyVars family of functions instantiate a list of TyVars
+to fresh skolem TcTyVars. Important notes:
+
+a) Level allocation. We generally skolemise /before/ calling
+   pushLevelAndCaptureConstraints.  So we want their level to the level
+   of the soon-to-be-created implication, which has a level ONE HIGHER
+   than the current level.  Hence the pushTcLevel.  It feels like a
+   slight hack.
+
+b) The [TyVar] should be ordered (kind vars first)
+   See Note [Kind substitution when instantiating]
+
+c) It's a complete freshening operation: the skolems have a fresh
+   unique, and a location from the monad
+
+d) The resulting skolems are
+        non-overlappable for tcInstSkolTyVars,
+   but overlappable for tcInstSuperSkolTyVars
+   See TcDerivInfer Note [Overlap and deriving] for an example
+   of where this matters.
+
+Note [Kind substitution when instantiating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we instantiate a bunch of kind and type variables, first we
+expect them to be topologically sorted.
+Then we have to instantiate the kind variables, build a substitution
+from old variables to the new variables, then instantiate the type
+variables substituting the original kind.
+
+Exemple: If we want to instantiate
+  [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)]
+we want
+  [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)]
+instead of the buggous
+  [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)]
+
+
+************************************************************************
+*                                                                      *
+        MetaTvs (meta type variables; mutable)
+*                                                                      *
+************************************************************************
+-}
+
+{-
+Note [TyVarTv]
+~~~~~~~~~~~~
+
+A TyVarTv can unify with type *variables* only, including other TyVarTvs and
+skolems. Sometimes, they can unify with type variables that the user would
+rather keep distinct; see #11203 for an example.  So, any client of this
+function needs to either allow the TyVarTvs to unify with each other or check
+that they don't (say, with a call to findDubTyVarTvs).
+
+Before #15050 this (under the name SigTv) was used for ScopedTypeVariables in
+patterns, to make sure these type variables only refer to other type variables,
+but this restriction was dropped, and ScopedTypeVariables can now refer to full
+types (GHC Proposal 29).
+
+The remaining uses of newTyVarTyVars are
+* In kind signatures, see
+  TcTyClsDecls Note [Inferring kinds for type declarations]
+           and Note [Kind checking for GADTs]
+* In partial type signatures, see Note [Quantified variables in partial type signatures]
+-}
+
+-- see Note [TyVarTv]
+newTyVarTyVar :: Name -> Kind -> TcM TcTyVar
+newTyVarTyVar name kind
+  = do { details <- newMetaDetails TyVarTv
+       ; let tyvar = mkTcTyVar name kind details
+       ; traceTc "newTyVarTyVar" (ppr tyvar)
+       ; return tyvar }
+
+
+-- makes a new skolem tv
+newSkolemTyVar :: Name -> Kind -> TcM TcTyVar
+newSkolemTyVar name kind = do { lvl <- getTcLevel
+                              ; return (mkTcTyVar name kind (SkolemTv lvl False)) }
+
+newFskTyVar :: TcType -> TcM TcTyVar
+newFskTyVar fam_ty
+  = do { uniq <- newUnique
+       ; ref  <- newMutVar Flexi
+       ; tclvl <- getTcLevel
+       ; let details = MetaTv { mtv_info  = FlatSkolTv
+                              , mtv_ref   = ref
+                              , mtv_tclvl = tclvl }
+             name = mkMetaTyVarName uniq (fsLit "fsk")
+       ; return (mkTcTyVar name (tcTypeKind fam_ty) details) }
+
+newFmvTyVar :: TcType -> TcM TcTyVar
+-- Very like newMetaTyVar, except sets mtv_tclvl to one less
+-- so that the fmv is untouchable.
+newFmvTyVar fam_ty
+  = do { uniq <- newUnique
+       ; ref  <- newMutVar Flexi
+       ; tclvl <- getTcLevel
+       ; let details = MetaTv { mtv_info  = FlatMetaTv
+                              , mtv_ref   = ref
+                              , mtv_tclvl = tclvl }
+             name = mkMetaTyVarName uniq (fsLit "s")
+       ; return (mkTcTyVar name (tcTypeKind fam_ty) details) }
+
+newMetaDetails :: MetaInfo -> TcM TcTyVarDetails
+newMetaDetails info
+  = do { ref <- newMutVar Flexi
+       ; tclvl <- getTcLevel
+       ; return (MetaTv { mtv_info = info
+                        , mtv_ref = ref
+                        , mtv_tclvl = tclvl }) }
+
+cloneMetaTyVar :: TcTyVar -> TcM TcTyVar
+cloneMetaTyVar tv
+  = ASSERT( isTcTyVar tv )
+    do  { uniq <- newUnique
+        ; ref  <- newMutVar Flexi
+        ; let name'    = setNameUnique (tyVarName tv) uniq
+              details' = case tcTyVarDetails tv of
+                           details@(MetaTv {}) -> details { mtv_ref = ref }
+                           _ -> pprPanic "cloneMetaTyVar" (ppr tv)
+              tyvar = mkTcTyVar name' (tyVarKind tv) details'
+        ; traceTc "cloneMetaTyVar" (ppr tyvar)
+        ; return tyvar }
+
+-- Works for both type and kind variables
+readMetaTyVar :: TyVar -> TcM MetaDetails
+readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
+                      readMutVar (metaTyVarRef tyvar)
+
+isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type)
+isFilledMetaTyVar_maybe tv
+ | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv
+ = do { cts <- readTcRef ref
+      ; case cts of
+          Indirect ty -> return (Just ty)
+          Flexi       -> return Nothing }
+ | otherwise
+ = return Nothing
+
+isFilledMetaTyVar :: TyVar -> TcM Bool
+-- True of a filled-in (Indirect) meta type variable
+isFilledMetaTyVar tv = isJust <$> isFilledMetaTyVar_maybe tv
+
+isUnfilledMetaTyVar :: TyVar -> TcM Bool
+-- True of a un-filled-in (Flexi) meta type variable
+-- NB: Not the opposite of isFilledMetaTyVar
+isUnfilledMetaTyVar tv
+  | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv
+  = do  { details <- readMutVar ref
+        ; return (isFlexi details) }
+  | otherwise = return False
+
+--------------------
+-- Works with both type and kind variables
+writeMetaTyVar :: TcTyVar -> TcType -> TcM ()
+-- Write into a currently-empty MetaTyVar
+
+writeMetaTyVar tyvar ty
+  | not debugIsOn
+  = writeMetaTyVarRef tyvar (metaTyVarRef tyvar) ty
+
+-- Everything from here on only happens if DEBUG is on
+  | not (isTcTyVar tyvar)
+  = WARN( True, text "Writing to non-tc tyvar" <+> ppr tyvar )
+    return ()
+
+  | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar
+  = writeMetaTyVarRef tyvar ref ty
+
+  | otherwise
+  = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar )
+    return ()
+
+--------------------
+writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()
+-- Here the tyvar is for error checking only;
+-- the ref cell must be for the same tyvar
+writeMetaTyVarRef tyvar ref ty
+  | not debugIsOn
+  = do { traceTc "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)
+                                   <+> text ":=" <+> ppr ty)
+       ; writeTcRef ref (Indirect ty) }
+
+  -- Everything from here on only happens if DEBUG is on
+  | otherwise
+  = do { meta_details <- readMutVar ref;
+       -- Zonk kinds to allow the error check to work
+       ; zonked_tv_kind <- zonkTcType tv_kind
+       ; zonked_ty      <- zonkTcType ty
+       ; let zonked_ty_kind = tcTypeKind zonked_ty  -- Need to zonk even before typeKind;
+                                                    -- otherwise, we can panic in piResultTy
+             kind_check_ok = tcIsConstraintKind zonked_tv_kind
+                          || tcEqKind zonked_ty_kind zonked_tv_kind
+             -- Hack alert! tcIsConstraintKind: see TcHsType
+             -- Note [Extra-constraint holes in partial type signatures]
+
+             kind_msg = hang (text "Ill-kinded update to meta tyvar")
+                           2 (    ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind)
+                              <+> text ":="
+                              <+> ppr ty <+> text "::" <+> (ppr zonked_ty_kind) )
+
+       ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
+
+       -- Check for double updates
+       ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details )
+
+       -- Check for level OK
+       -- See Note [Level check when unifying]
+       ; MASSERT2( level_check_ok, level_check_msg )
+
+       -- Check Kinds ok
+       ; MASSERT2( kind_check_ok, kind_msg )
+
+       -- Do the write
+       ; writeMutVar ref (Indirect ty) }
+  where
+    tv_kind = tyVarKind tyvar
+
+    tv_lvl = tcTyVarLevel tyvar
+    ty_lvl = tcTypeLevel ty
+
+    level_check_ok  = not (ty_lvl `strictlyDeeperThan` tv_lvl)
+    level_check_msg = ppr ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty
+
+    double_upd_msg details = hang (text "Double update of meta tyvar")
+                                2 (ppr tyvar $$ ppr details)
+
+{- Note [Level check when unifying]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When unifying
+     alpha:lvl := ty
+we expect that the TcLevel of 'ty' will be <= lvl.
+However, during unflatting we do
+     fuv:l := ty:(l+1)
+which is usually wrong; hence the check isFmmvTyVar in level_check_ok.
+See Note [TcLevel assignment] in TcType.
+-}
+
+{-
+% Generating fresh variables for pattern match check
+-}
+
+
+{-
+************************************************************************
+*                                                                      *
+        MetaTvs: TauTvs
+*                                                                      *
+************************************************************************
+
+Note [Never need to instantiate coercion variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With coercion variables sloshing around in types, it might seem that we
+sometimes need to instantiate coercion variables. This would be problematic,
+because coercion variables inhabit unboxed equality (~#), and the constraint
+solver thinks in terms only of boxed equality (~). The solution is that
+we never need to instantiate coercion variables in the first place.
+
+The tyvars that we need to instantiate come from the types of functions,
+data constructors, and patterns. These will never be quantified over
+coercion variables, except for the special case of the promoted Eq#. But,
+that can't ever appear in user code, so we're safe!
+-}
+
+newTauTyVar :: Name -> Kind -> TcM TcTyVar
+newTauTyVar name kind
+  = do { details <- newMetaDetails TauTv
+       ; let tyvar = mkTcTyVar name kind details
+       ; traceTc "newTauTyVar" (ppr tyvar)
+       ; return tyvar }
+
+
+mkMetaTyVarName :: Unique -> FastString -> Name
+-- Makes a /System/ Name, which is eagerly eliminated by
+-- the unifier; see TcUnify.nicer_to_update_tv1, and
+-- TcCanonical.canEqTyVarTyVar (nicer_to_update_tv2)
+mkMetaTyVarName uniq str = mkSystemName uniq (mkTyVarOccFS str)
+
+newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
+-- Make a new meta tyvar out of thin air
+newAnonMetaTyVar meta_info kind
+  = do  { uniq <- newUnique
+        ; let name = mkMetaTyVarName uniq s
+              s = case meta_info of
+                        TauTv       -> fsLit "t"
+                        FlatMetaTv  -> fsLit "fmv"
+                        FlatSkolTv  -> fsLit "fsk"
+                        TyVarTv      -> fsLit "a"
+        ; details <- newMetaDetails meta_info
+        ; let tyvar = mkTcTyVar name kind details
+        ; traceTc "newAnonMetaTyVar" (ppr tyvar)
+        ; return tyvar }
+
+cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar
+-- Same as newAnonMetaTyVar, but use a supplied TyVar as the source of the print-name
+cloneAnonMetaTyVar info tv kind
+  = do  { uniq    <- newUnique
+        ; details <- newMetaDetails info
+        ; let name = mkSystemName uniq (getOccName tv)
+                       -- See Note [Name of an instantiated type variable]
+              tyvar = mkTcTyVar name kind details
+        ; traceTc "cloneAnonMetaTyVar" (ppr tyvar)
+        ; return tyvar }
+
+{- Note [Name of an instantiated type variable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+At the moment we give a unification variable a System Name, which
+influences the way it is tidied; see TypeRep.tidyTyVarBndr.
+-}
+
+newFlexiTyVar :: Kind -> TcM TcTyVar
+newFlexiTyVar kind = newAnonMetaTyVar TauTv kind
+
+newFlexiTyVarTy :: Kind -> TcM TcType
+newFlexiTyVarTy kind = do
+    tc_tyvar <- newFlexiTyVar kind
+    return (mkTyVarTy tc_tyvar)
+
+newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]
+newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind)
+
+newOpenTypeKind :: TcM TcKind
+newOpenTypeKind
+  = do { rr <- newFlexiTyVarTy runtimeRepTy
+       ; return (tYPE rr) }
+
+-- | Create a tyvar that can be a lifted or unlifted type.
+-- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh
+newOpenFlexiTyVarTy :: TcM TcType
+newOpenFlexiTyVarTy
+  = do { kind <- newOpenTypeKind
+       ; newFlexiTyVarTy kind }
+
+newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- Instantiate with META type variables
+-- Note that this works for a sequence of kind, type, and coercion variables
+-- variables.  Eg    [ (k:*), (a:k->k) ]
+--             Gives [ (k7:*), (a8:k7->k7) ]
+newMetaTyVars = newMetaTyVarsX emptyTCvSubst
+    -- emptyTCvSubst has an empty in-scope set, but that's fine here
+    -- Since the tyvars are freshly made, they cannot possibly be
+    -- captured by any existing for-alls.
+
+newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
+-- Just like newMetaTyVars, but start with an existing substitution.
+newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst
+
+newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
+-- Make a new unification variable tyvar whose Name and Kind come from
+-- an existing TyVar. We substitute kind variables in the kind.
+newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar
+
+newMetaTyVarTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
+newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst
+
+newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
+-- Just like newMetaTyVarX, but make a TyVarTv
+newMetaTyVarTyVarX subst tyvar = new_meta_tv_x TyVarTv subst tyvar
+
+newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
+newWildCardX subst tv
+  = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv))
+       ; return (extendTvSubstWithClone subst tv new_tv, new_tv) }
+
+new_meta_tv_x :: MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
+new_meta_tv_x info subst tv
+  = do  { new_tv <- cloneAnonMetaTyVar info tv substd_kind
+        ; let subst1 = extendTvSubstWithClone subst tv new_tv
+        ; return (subst1, new_tv) }
+  where
+    substd_kind = substTyUnchecked subst (tyVarKind tv)
+      -- NOTE: Trac #12549 is fixed so we could use
+      -- substTy here, but the tc_infer_args problem
+      -- is not yet fixed so leaving as unchecked for now.
+      -- OLD NOTE:
+      -- Unchecked because we call newMetaTyVarX from
+      -- tcInstTyBinder, which is called from tcInferApps
+      -- which does not yet take enough trouble to ensure
+      -- the in-scope set is right; e.g. Trac #12785 trips
+      -- if we use substTy here
+
+newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType
+newMetaTyVarTyAtLevel tc_lvl kind
+  = do  { uniq <- newUnique
+        ; ref  <- newMutVar Flexi
+        ; let name = mkMetaTyVarName uniq (fsLit "p")
+              details = MetaTv { mtv_info  = TauTv
+                               , mtv_ref   = ref
+                               , mtv_tclvl = tc_lvl }
+        ; return (mkTyVarTy (mkTcTyVar name kind details)) }
+
+{- *********************************************************************
+*                                                                      *
+          Finding variables to quantify over
+*                                                                      *
+********************************************************************* -}
+
+{- Note [Dependent type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In Haskell type inference we quantify over type variables; but we only
+quantify over /kind/ variables when -XPolyKinds is on.  Without -XPolyKinds
+we default the kind variables to *.
+
+So, to support this defaulting, and only for that reason, when
+collecting the free vars of a type, prior to quantifying, we must keep
+the type and kind variables separate.
+
+But what does that mean in a system where kind variables /are/ type
+variables? It's a fairly arbitrary distinction based on how the
+variables appear:
+
+  - "Kind variables" appear in the kind of some other free variable
+
+     These are the ones we default to * if -XPolyKinds is off
+
+  - "Type variables" are all free vars that are not kind variables
+
+E.g.  In the type    T k (a::k)
+      'k' is a kind variable, because it occurs in the kind of 'a',
+          even though it also appears at "top level" of the type
+      'a' is a type variable, because it doesn't
+
+We gather these variables using a CandidatesQTvs record:
+  DV { dv_kvs: Variables free in the kind of a free type variable
+               or of a forall-bound type variable
+     , dv_tvs: Variables sytactically free in the type }
+
+So:  dv_kvs            are the kind variables of the type
+     (dv_tvs - dv_kvs) are the type variable of the type
+
+Note that
+
+* A variable can occur in both.
+      T k (x::k)    The first occurrence of k makes it
+                    show up in dv_tvs, the second in dv_kvs
+
+* We include any coercion variables in the "dependent",
+  "kind-variable" set because we never quantify over them.
+
+* The "kind variables" might depend on each other; e.g
+     (k1 :: k2), (k2 :: *)
+  The "type variables" do not depend on each other; if
+  one did, it'd be classified as a kind variable!
+
+Note [CandidatesQTvs determinism and order]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Determinism: when we quantify over type variables we decide the
+  order in which they appear in the final type. Because the order of
+  type variables in the type can end up in the interface file and
+  affects some optimizations like worker-wrapper, we want this order to
+  be deterministic.
+
+  To achieve that we use deterministic sets of variables that can be
+  converted to lists in a deterministic order. For more information
+  about deterministic sets see Note [Deterministic UniqFM] in UniqDFM.
+
+* Order: as well as being deterministic, we use an
+  accumulating-parameter style for candidateQTyVarsOfType so that we
+  add variables one at a time, left to right.  That means we tend to
+  produce the variables in left-to-right order.  This is just to make
+  it bit more predicatable for the programmer.
+
+Note [Naughty quantification candidates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (#14880, dependent/should_compile/T14880-2), suppose
+we are trying to generalise this type:
+
+  forall arg. ... (alpha[tau]:arg) ...
+
+We have a metavariable alpha whose kind mentions a skolem variable
+boudn inside the very type we are generalising.
+This can arise while type-checking a user-written type signature
+(see the test case for the full code).
+
+We cannot generalise over alpha!  That would produce a type like
+  forall {a :: arg}. forall arg. ...blah...
+The fact that alpha's kind mentions arg renders it completely
+ineligible for generaliation.
+
+However, we are not going to learn any new constraints on alpha,
+because its kind isn't even in scope in the outer context.  So alpha
+is entirely unconstrained.
+
+What then should we do with alpha?  During generalization, every
+metavariable is either (A) promoted, (B) generalized, or (C) zapped
+(according again to Note [Recipe for checking a signature] in
+TcHsType).
+
+ * We can't generalise it.
+ * We can't promote it, because its kind prevents that
+ * We can't simply leave it be, because this type is about to
+   go into the typing environment (as the type of some let-bound
+   variable, say), and then chaos erupts when we try to instantiate.
+
+So, we zap it, eagerly, to Any. We don't have to do this eager zapping
+in terms (say, in `length []`) because terms are never re-examined before
+the final zonk (which zaps any lingering metavariables to Any).
+
+We do this eager zapping in candidateQTyVars, which always precedes
+generalisation, because at that moment we have a clear picture of
+what skolems are in scope.
+
+-}
+
+data CandidatesQTvs
+  -- See Note [Dependent type variables]
+  -- See Note [CandidatesQTvs determinism and order]
+  --
+  -- Invariants:
+  --   * All variables stored here are MetaTvs. No exceptions.
+  --   * All variables are fully zonked, including their kinds
+  --
+  = DV { dv_kvs :: DTyVarSet    -- "kind" metavariables (dependent)
+       , dv_tvs :: DTyVarSet    -- "type" metavariables (non-dependent)
+         -- A variable may appear in both sets
+         -- E.g.   T k (x::k)    The first occurrence of k makes it
+         --                      show up in dv_tvs, the second in dv_kvs
+         -- See Note [Dependent type variables]
+
+       , dv_cvs :: CoVarSet
+         -- These are covars. We will *not* quantify over these, but
+         -- we must make sure also not to quantify over any cv's kinds,
+         -- so we include them here as further direction for quantifyTyVars
+    }
+
+instance Semi.Semigroup CandidatesQTvs where
+   (DV { dv_kvs = kv1, dv_tvs = tv1, dv_cvs = cv1 })
+     <> (DV { dv_kvs = kv2, dv_tvs = tv2, dv_cvs = cv2 })
+          = DV { dv_kvs = kv1 `unionDVarSet` kv2
+               , dv_tvs = tv1 `unionDVarSet` tv2
+               , dv_cvs = cv1 `unionVarSet` cv2 }
+
+instance Monoid CandidatesQTvs where
+   mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet, dv_cvs = emptyVarSet }
+   mappend = (Semi.<>)
+
+instance Outputable CandidatesQTvs where
+  ppr (DV {dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs })
+    = text "DV" <+> braces (pprWithCommas id [ text "dv_kvs =" <+> ppr kvs
+                                             , text "dv_tvs =" <+> ppr tvs
+                                             , text "dv_cvs =" <+> ppr cvs ])
+
+
+candidateKindVars :: CandidatesQTvs -> TyVarSet
+candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs)
+
+-- | Gathers free variables to use as quantification candidates (in
+-- 'quantifyTyVars'). This might output the same var
+-- in both sets, if it's used in both a type and a kind.
+-- See Note [CandidatesQTvs determinism and order]
+-- See Note [Dependent type variables]
+candidateQTyVarsOfType :: TcType       -- not necessarily zonked
+                       -> TcM CandidatesQTvs
+candidateQTyVarsOfType ty = collect_cand_qtvs False emptyVarSet mempty ty
+
+-- | Like 'splitDepVarsOfType', but over a list of types
+candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs
+candidateQTyVarsOfTypes tys = foldlM (collect_cand_qtvs False emptyVarSet) mempty tys
+
+-- | Like 'candidateQTyVarsOfType', but consider every free variable
+-- to be dependent. This is appropriate when generalizing a *kind*,
+-- instead of a type. (That way, -XNoPolyKinds will default the variables
+-- to Type.)
+candidateQTyVarsOfKind :: TcKind       -- Not necessarily zonked
+                       -> TcM CandidatesQTvs
+candidateQTyVarsOfKind ty = collect_cand_qtvs True emptyVarSet mempty ty
+
+candidateQTyVarsOfKinds :: [TcKind]    -- Not necessarily zonked
+                       -> TcM CandidatesQTvs
+candidateQTyVarsOfKinds tys = foldM (collect_cand_qtvs True emptyVarSet) mempty tys
+
+delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs
+delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars
+  = DV { dv_kvs = kvs `delDVarSetList` vars
+       , dv_tvs = tvs `delDVarSetList` vars
+       , dv_cvs = cvs `delVarSetList`  vars }
+
+collect_cand_qtvs
+  :: Bool            -- True <=> consider every fv in Type to be dependent
+  -> VarSet          -- Bound variables (both locally bound and globally bound)
+  -> CandidatesQTvs  -- Accumulating parameter
+  -> Type            -- Not necessarily zonked
+  -> TcM CandidatesQTvs
+
+-- Key points:
+--   * Looks through meta-tyvars as it goes;
+--     no need to zonk in advance
+--
+--   * Needs to be monadic anyway, because it does the zap-naughty
+--     stuff; see Note [Naughty quantification candidates]
+--
+--   * Returns fully-zonked CandidateQTvs, including their kinds
+--     so that subsequent dependency analysis (to build a well
+--     scoped telescope) works correctly
+
+collect_cand_qtvs is_dep bound dvs ty
+  = go dvs ty
+  where
+    is_bound tv = tv `elemVarSet` bound
+
+    -----------------
+    go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs
+    -- Uses accumulating-parameter style
+    go dv (AppTy t1 t2)    = foldlM go dv [t1, t2]
+    go dv (TyConApp _ tys) = foldlM go dv tys
+    go dv (FunTy arg res)  = foldlM go dv [arg, res]
+    go dv (LitTy {})       = return dv
+    go dv (CastTy ty co)   = do dv1 <- go dv ty
+                                collect_cand_qtvs_co bound dv1 co
+    go dv (CoercionTy co)  = collect_cand_qtvs_co bound dv co
+
+    go dv (TyVarTy tv)
+      | is_bound tv = return dv
+      | otherwise   = do { m_contents <- isFilledMetaTyVar_maybe tv
+                         ; case m_contents of
+                             Just ind_ty -> go dv ind_ty
+                             Nothing     -> go_tv dv tv }
+
+    go dv (ForAllTy (Bndr tv _) ty)
+      = do { dv1 <- collect_cand_qtvs True bound dv (tyVarKind tv)
+           ; collect_cand_qtvs is_dep (bound `extendVarSet` tv) dv1 ty }
+
+    -----------------
+    go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv
+      | tv `elemDVarSet` kvs = return dv  -- We have met this tyvar aleady
+      | not is_dep
+      , tv `elemDVarSet` tvs = return dv  -- We have met this tyvar aleady
+      | otherwise
+      = do { tv_kind <- zonkTcType (tyVarKind tv)
+                 -- This zonk is annoying, but it is necessary, both to
+                 -- ensure that the collected candidates have zonked kinds
+                 -- (Trac #15795) and to make the naughty check
+                 -- (which comes next) works correctly
+           ; if intersectsVarSet bound (tyCoVarsOfType tv_kind)
+
+             then -- See Note [Naughty quantification candidates]
+                  do { traceTc "Zapping naughty quantifier" (pprTyVar tv)
+                     ; writeMetaTyVar tv (anyTypeOfKind tv_kind)
+                     ; collect_cand_qtvs True bound dv tv_kind }
+
+             else do { let tv' = tv `setTyVarKind` tv_kind
+                           dv' | is_dep    = dv { dv_kvs = kvs `extendDVarSet` tv' }
+                               | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' }
+                               -- See Note [Order of accumulation]
+                     ; collect_cand_qtvs True emptyVarSet dv' tv_kind } }
+
+collect_cand_qtvs_co :: VarSet -- bound variables
+                     -> CandidatesQTvs -> Coercion
+                     -> TcM CandidatesQTvs
+collect_cand_qtvs_co bound = go_co
+  where
+    go_co dv (Refl ty)             = collect_cand_qtvs True bound dv ty
+    go_co dv (GRefl _ ty mco)      = do dv1 <- collect_cand_qtvs True bound dv ty
+                                        go_mco dv1 mco
+    go_co dv (TyConAppCo _ _ cos)  = foldlM go_co dv cos
+    go_co dv (AppCo co1 co2)       = foldlM go_co dv [co1, co2]
+    go_co dv (FunCo _ co1 co2)     = foldlM go_co dv [co1, co2]
+    go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos
+    go_co dv (AxiomRuleCo _ cos)   = foldlM go_co dv cos
+    go_co dv (UnivCo prov _ t1 t2) = do dv1 <- go_prov dv prov
+                                        dv2 <- collect_cand_qtvs True bound dv1 t1
+                                        collect_cand_qtvs True bound dv2 t2
+    go_co dv (SymCo co)            = go_co dv co
+    go_co dv (TransCo co1 co2)     = foldlM go_co dv [co1, co2]
+    go_co dv (NthCo _ _ co)        = go_co dv co
+    go_co dv (LRCo _ co)           = go_co dv co
+    go_co dv (InstCo co1 co2)      = foldlM go_co dv [co1, co2]
+    go_co dv (KindCo co)           = go_co dv co
+    go_co dv (SubCo co)            = go_co dv co
+
+    go_co dv (HoleCo hole) = do m_co <- unpackCoercionHole_maybe hole
+                                case m_co of
+                                  Just co -> go_co dv co
+                                  Nothing -> go_cv dv (coHoleCoVar hole)
+
+    go_co dv (CoVarCo cv) = go_cv dv cv
+
+    go_co dv (ForAllCo tcv kind_co co)
+      = do { dv1 <- go_co dv kind_co
+           ; collect_cand_qtvs_co (bound `extendVarSet` tcv) dv1 co }
+
+    go_mco dv MRefl    = return dv
+    go_mco dv (MCo co) = go_co dv co
+
+    go_prov dv UnsafeCoerceProv    = return dv
+    go_prov dv (PhantomProv co)    = go_co dv co
+    go_prov dv (ProofIrrelProv co) = go_co dv co
+    go_prov dv (PluginProv _)      = return dv
+
+    go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs
+    go_cv dv@(DV { dv_cvs = cvs }) cv
+      | is_bound cv         = return dv
+      | cv `elemVarSet` cvs = return dv
+      | otherwise           = collect_cand_qtvs True emptyVarSet
+                                    (dv { dv_cvs = cvs `extendVarSet` cv })
+                                    (idType cv)
+
+    is_bound tv = tv `elemVarSet` bound
+
+{- Note [Order of accumulation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You might be tempted (like I was) to use unitDVarSet and mappend
+rather than extendDVarSet.  However, the union algorithm for
+deterministic sets depends on (roughly) the size of the sets. The
+elements from the smaller set end up to the right of the elements from
+the larger one. When sets are equal, the left-hand argument to
+`mappend` goes to the right of the right-hand argument.
+
+In our case, if we use unitDVarSet and mappend, we learn that the free
+variables of (a -> b -> c -> d) are [b, a, c, d], and we then quantify
+over them in that order. (The a comes after the b because we union the
+singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter,
+the size criterion works to our advantage.) This is just annoying to
+users, so I use `extendDVarSet`, which unambiguously puts the new
+element to the right.
+
+Note that the unitDVarSet/mappend implementation would not be wrong
+against any specification -- just suboptimal and confounding to users.
+-}
+
+{- *********************************************************************
+*                                                                      *
+             Quantification
+*                                                                      *
+************************************************************************
+
+Note [quantifyTyVars]
+~~~~~~~~~~~~~~~~~~~~~
+quantifyTyVars is given the free vars of a type that we
+are about to wrap in a forall.
+
+It takes these free type/kind variables (partitioned into dependent and
+non-dependent variables) and
+  1. Zonks them and remove globals and covars
+  2. Extends kvs1 with free kind vars in the kinds of tvs (removing globals)
+  3. Calls skolemiseQuantifiedTyVar on each
+
+Step (2) is often unimportant, because the kind variable is often
+also free in the type.  Eg
+     Typeable k (a::k)
+has free vars {k,a}.  But the type (see Trac #7916)
+    (f::k->*) (a::k)
+has free vars {f,a}, but we must add 'k' as well! Hence step (2).
+
+* This function distinguishes between dependent and non-dependent
+  variables only to keep correct defaulting behavior with -XNoPolyKinds.
+  With -XPolyKinds, it treats both classes of variables identically.
+
+* quantifyTyVars never quantifies over
+    - a coercion variable (or any tv mentioned in the kind of a covar)
+    - a runtime-rep variable
+
+Note [quantifyTyVars determinism]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The results of quantifyTyVars are wrapped in a forall and can end up in the
+interface file. One such example is inferred type signatures. They also affect
+the results of optimizations, for example worker-wrapper. This means that to
+get deterministic builds quantifyTyVars needs to be deterministic.
+
+To achieve this CandidatesQTvs is backed by deterministic sets which allows them
+to be later converted to a list in a deterministic order.
+
+For more information about deterministic sets see
+Note [Deterministic UniqFM] in UniqDFM.
+-}
+
+quantifyTyVars
+  :: TcTyCoVarSet     -- Global tvs; already zonked
+  -> CandidatesQTvs   -- See Note [Dependent type variables]
+                      -- Already zonked
+  -> TcM [TcTyVar]
+-- See Note [quantifyTyVars]
+-- Can be given a mixture of TcTyVars and TyVars, in the case of
+--   associated type declarations. Also accepts covars, but *never* returns any.
+quantifyTyVars gbl_tvs
+               dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs, dv_cvs = covars })
+  = do { outer_tclvl <- getTcLevel
+       ; traceTc "quantifyTyVars 1" (vcat [ppr outer_tclvl, ppr dvs, ppr gbl_tvs])
+       ; let co_tvs = closeOverKinds covars
+             mono_tvs = gbl_tvs `unionVarSet` co_tvs
+              -- NB: All variables in the kind of a covar must not be
+              -- quantified over, as we don't quantify over the covar.
+
+             dep_kvs = dVarSetElemsWellScoped $
+                       dep_tkvs `dVarSetMinusVarSet` mono_tvs
+                       -- dVarSetElemsWellScoped: put the kind variables into
+                       --    well-scoped order.
+                       --    E.g.  [k, (a::k)] not the other way roud
+
+             nondep_tvs = dVarSetElems $
+                          (nondep_tkvs `minusDVarSet` dep_tkvs)
+                           `dVarSetMinusVarSet` mono_tvs
+                 -- See Note [Dependent type variables]
+                 -- The `minus` dep_tkvs removes any kind-level vars
+                 --    e.g. T k (a::k)   Since k appear in a kind it'll
+                 --    be in dv_kvs, and is dependent. So remove it from
+                 --    dv_tvs which will also contain k
+                 -- No worry about dependent covars here;
+                 --    they are all in dep_tkvs
+                 -- NB kinds of tvs are zonked by zonkTyCoVarsAndFV
+
+       -- This block uses level numbers to decide what to quantify
+       -- and emits a warning if the two methods do not give the same answer
+       ; let dep_kvs2    = dVarSetElemsWellScoped $
+                           filterDVarSet (quantifiableTv outer_tclvl) dep_tkvs
+             nondep_tvs2 = filter (quantifiableTv outer_tclvl) $
+                           dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs)
+
+             all_ok = dep_kvs == dep_kvs2 && nondep_tvs == nondep_tvs2
+             bad_msg = hang (text "Quantification by level numbers would fail")
+                          2 (vcat [ text "Outer level =" <+> ppr outer_tclvl
+                                  , text "dep_tkvs ="    <+> ppr dep_tkvs
+                                  , text "co_vars ="     <+> vcat [ ppr cv <+> dcolon <+> ppr (varType cv)
+                                                                  | cv <- nonDetEltsUniqSet covars ]
+                                  , text "co_tvs ="      <+> ppr co_tvs
+                                  , text "dep_kvs ="     <+> ppr dep_kvs
+                                  , text "dep_kvs2 ="    <+> ppr dep_kvs2
+                                  , text "nondep_tvs ="  <+> ppr nondep_tvs
+                                  , text "nondep_tvs2 =" <+> ppr nondep_tvs2 ])
+       ; WARN( not all_ok, bad_msg ) return ()
+
+             -- In the non-PolyKinds case, default the kind variables
+             -- to *, and zonk the tyvars as usual.  Notice that this
+             -- may make quantifyTyVars return a shorter list
+             -- than it was passed, but that's ok
+       ; poly_kinds  <- xoptM LangExt.PolyKinds
+       ; dep_kvs'    <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs
+       ; nondep_tvs' <- mapMaybeM (zonk_quant False)            nondep_tvs
+       ; let final_qtvs = dep_kvs' ++ nondep_tvs'
+           -- Because of the order, any kind variables
+           -- mentioned in the kinds of the nondep_tvs'
+           -- now refer to the dep_kvs'
+
+       ; traceTc "quantifyTyVars 2"
+           (vcat [ text "globals:"    <+> ppr gbl_tvs
+                 , text "mono_tvs:"   <+> ppr mono_tvs
+                 , text "nondep:"     <+> pprTyVars nondep_tvs
+                 , text "dep:"        <+> pprTyVars dep_kvs
+                 , text "dep_kvs'"    <+> pprTyVars dep_kvs'
+                 , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ])
+
+       -- We should never quantify over coercion variables; check this
+       ; let co_vars = filter isCoVar final_qtvs
+       ; MASSERT2( null co_vars, ppr co_vars )
+
+       ; return final_qtvs }
+  where
+    -- zonk_quant returns a tyvar if it should be quantified over;
+    -- otherwise, it returns Nothing. The latter case happens for
+    --    * Kind variables, with -XNoPolyKinds: don't quantify over these
+    --    * RuntimeRep variables: we never quantify over these
+    zonk_quant default_kind tkv
+      | not (isTyVar tkv)
+      = return Nothing   -- this can happen for a covar that's associated with
+                         -- a coercion hole. Test case: typecheck/should_compile/T2494
+
+      | not (isTcTyVar tkv)  -- I don't think this can ever happen.
+                             -- Hence the assert
+      = ASSERT2( False, text "quantifying over a TyVar" <+> ppr tkv)
+        return (Just tkv)
+
+      | otherwise
+      = do { deflt_done <- defaultTyVar default_kind tkv
+           ; case deflt_done of
+               True  -> return Nothing
+               False -> do { tv <- skolemiseQuantifiedTyVar tkv
+                           ; return (Just tv) } }
+
+quantifiableTv :: TcLevel   -- Level of the context, outside the quantification
+               -> TcTyVar
+               -> Bool
+quantifiableTv outer_tclvl tcv
+  | isTcTyVar tcv  -- Might be a CoVar; change this when gather covars separtely
+  = tcTyVarLevel tcv > outer_tclvl
+  | otherwise
+  = False
+
+skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
+-- The quantified type variables often include meta type variables
+-- we want to freeze them into ordinary type variables
+-- The meta tyvar is updated to point to the new skolem TyVar.  Now any
+-- bound occurrences of the original type variable will get zonked to
+-- the immutable version.
+--
+-- We leave skolem TyVars alone; they are immutable.
+--
+-- This function is called on both kind and type variables,
+-- but kind variables *only* if PolyKinds is on.
+
+skolemiseQuantifiedTyVar tv
+  = case tcTyVarDetails tv of
+      SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv)
+                        ; return (setTyVarKind tv kind) }
+        -- It might be a skolem type variable,
+        -- for example from a user type signature
+
+      MetaTv {} -> skolemiseUnboundMetaTyVar tv
+
+      _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk
+
+defaultTyVar :: Bool      -- True <=> please default this kind variable to *
+             -> TcTyVar   -- If it's a MetaTyVar then it is unbound
+             -> TcM Bool  -- True <=> defaulted away altogether
+
+defaultTyVar default_kind tv
+  | not (isMetaTyVar tv)
+  = return False
+
+  | isTyVarTyVar tv
+    -- Do not default TyVarTvs. Doing so would violate the invariants
+    -- on TyVarTvs; see Note [Signature skolems] in TcType.
+    -- Trac #13343 is an example; #14555 is another
+    -- See Note [Inferring kinds for type declarations] in TcTyClsDecls
+  = return False
+
+
+  | isRuntimeRepVar tv  -- Do not quantify over a RuntimeRep var
+                        -- unless it is a TyVarTv, handled earlier
+  = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv)
+       ; writeMetaTyVar tv liftedRepTy
+       ; return True }
+
+  | default_kind                 -- -XNoPolyKinds and this is a kind var
+  = do { default_kind_var tv     -- so default it to * if possible
+       ; return True }
+
+  | otherwise
+  = return False
+
+  where
+    default_kind_var :: TyVar -> TcM ()
+       -- defaultKindVar is used exclusively with -XNoPolyKinds
+       -- See Note [Defaulting with -XNoPolyKinds]
+       -- It takes an (unconstrained) meta tyvar and defaults it.
+       -- Works only on vars of type *; for other kinds, it issues an error.
+    default_kind_var kv
+      | isLiftedTypeKind (tyVarKind kv)
+      = do { traceTc "Defaulting a kind var to *" (ppr kv)
+           ; writeMetaTyVar kv liftedTypeKind }
+      | otherwise
+      = addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv')
+                     , text "of kind:" <+> ppr (tyVarKind kv')
+                     , text "Perhaps enable PolyKinds or add a kind signature" ])
+      where
+        (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv
+
+skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar
+-- We have a Meta tyvar with a ref-cell inside it
+-- Skolemise it, so that we are totally out of Meta-tyvar-land
+-- We create a skolem TcTyVar, not a regular TyVar
+--   See Note [Zonking to Skolem]
+skolemiseUnboundMetaTyVar tv
+  = ASSERT2( isMetaTyVar tv, ppr tv )
+    do  { when debugIsOn (check_empty tv)
+        ; span <- getSrcSpanM    -- Get the location from "here"
+                                 -- ie where we are generalising
+        ; kind <- zonkTcType (tyVarKind tv)
+        ; let uniq        = getUnique tv
+                -- NB: Use same Unique as original tyvar. This is
+                -- convenient in reading dumps, but is otherwise inessential.
+
+              tv_name     = getOccName tv
+              final_name  = mkInternalName uniq tv_name span
+              final_tv    = mkTcTyVar final_name kind details
+
+        ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv)
+        ; writeMetaTyVar tv (mkTyVarTy final_tv)
+        ; return final_tv }
+
+  where
+    details = SkolemTv (metaTyVarTcLevel tv) False
+    check_empty tv       -- [Sept 04] Check for non-empty.
+      = when debugIsOn $  -- See note [Silly Type Synonym]
+        do { cts <- readMetaTyVar tv
+           ; case cts of
+               Flexi       -> return ()
+               Indirect ty -> WARN( True, ppr tv $$ ppr ty )
+                              return () }
+
+{- Note [Defaulting with -XNoPolyKinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+  data Compose f g a = Mk (f (g a))
+
+We infer
+
+  Compose :: forall k1 k2. (k2 -> *) -> (k1 -> k2) -> k1 -> *
+  Mk :: forall k1 k2 (f :: k2 -> *) (g :: k1 -> k2) (a :: k1).
+        f (g a) -> Compose k1 k2 f g a
+
+Now, in another module, we have -XNoPolyKinds -XDataKinds in effect.
+What does 'Mk mean? Pre GHC-8.0 with -XNoPolyKinds,
+we just defaulted all kind variables to *. But that's no good here,
+because the kind variables in 'Mk aren't of kind *, so defaulting to *
+is ill-kinded.
+
+After some debate on #11334, we decided to issue an error in this case.
+The code is in defaultKindVar.
+
+Note [What is a meta variable?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A "meta type-variable", also know as a "unification variable" is a placeholder
+introduced by the typechecker for an as-yet-unknown monotype.
+
+For example, when we see a call `reverse (f xs)`, we know that we calling
+    reverse :: forall a. [a] -> [a]
+So we know that the argument `f xs` must be a "list of something". But what is
+the "something"? We don't know until we explore the `f xs` a bit more. So we set
+out what we do know at the call of `reverse` by instantiate its type with a fresh
+meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the
+result, is `[alpha]`. The unification variable `alpha` stands for the
+as-yet-unknown type of the elements of the list.
+
+As type inference progresses we may learn more about `alpha`. For example, suppose
+`f` has the type
+    f :: forall b. b -> [Maybe b]
+Then we instantiate `f`'s type with another fresh unification variable, say
+`beta`; and equate `f`'s result type with reverse's argument type, thus
+`[alpha] ~ [Maybe beta]`.
+
+Now we can solve this equality to learn that `alpha ~ Maybe beta`, so we've
+refined our knowledge about `alpha`. And so on.
+
+If you found this Note useful, you may also want to have a look at
+Section 5 of "Practical type inference for higher rank types" (Peyton Jones,
+Vytiniotis, Weirich and Shields. J. Functional Programming. 2011).
+
+Note [What is zonking?]
+~~~~~~~~~~~~~~~~~~~~~~~
+GHC relies heavily on mutability in the typechecker for efficient operation.
+For this reason, throughout much of the type checking process meta type
+variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable
+variables (known as TcRefs).
+
+Zonking is the process of ripping out these mutable variables and replacing them
+with a real Type. This involves traversing the entire type expression, but the
+interesting part of replacing the mutable variables occurs in zonkTyVarOcc.
+
+There are two ways to zonk a Type:
+
+ * zonkTcTypeToType, which is intended to be used at the end of type-checking
+   for the final zonk. It has to deal with unfilled metavars, either by filling
+   it with a value like Any or failing (determined by the UnboundTyVarZonker
+   used).
+
+ * zonkTcType, which will happily ignore unfilled metavars. This is the
+   appropriate function to use while in the middle of type-checking.
+
+Note [Zonking to Skolem]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We used to zonk quantified type variables to regular TyVars.  However, this
+leads to problems.  Consider this program from the regression test suite:
+
+  eval :: Int -> String -> String -> String
+  eval 0 root actual = evalRHS 0 root actual
+
+  evalRHS :: Int -> a
+  evalRHS 0 root actual = eval 0 root actual
+
+It leads to the deferral of an equality (wrapped in an implication constraint)
+
+  forall a. () => ((String -> String -> String) ~ a)
+
+which is propagated up to the toplevel (see TcSimplify.tcSimplifyInferCheck).
+In the meantime `a' is zonked and quantified to form `evalRHS's signature.
+This has the *side effect* of also zonking the `a' in the deferred equality
+(which at this point is being handed around wrapped in an implication
+constraint).
+
+Finally, the equality (with the zonked `a') will be handed back to the
+simplifier by TcRnDriver.tcRnSrcDecls calling TcSimplify.tcSimplifyTop.
+If we zonk `a' with a regular type variable, we will have this regular type
+variable now floating around in the simplifier, which in many places assumes to
+only see proper TcTyVars.
+
+We can avoid this problem by zonking with a skolem.  The skolem is rigid
+(which we require for a quantified variable), but is still a TcTyVar that the
+simplifier knows how to deal with.
+
+Note [Silly Type Synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+        type C u a = u  -- Note 'a' unused
+
+        foo :: (forall a. C u a -> C u a) -> u
+        foo x = ...
+
+        bar :: Num u => u
+        bar = foo (\t -> t + t)
+
+* From the (\t -> t+t) we get type  {Num d} =>  d -> d
+  where d is fresh.
+
+* Now unify with type of foo's arg, and we get:
+        {Num (C d a)} =>  C d a -> C d a
+  where a is fresh.
+
+* Now abstract over the 'a', but float out the Num (C d a) constraint
+  because it does not 'really' mention a.  (see exactTyVarsOfType)
+  The arg to foo becomes
+        \/\a -> \t -> t+t
+
+* So we get a dict binding for Num (C d a), which is zonked to give
+        a = ()
+  [Note Sept 04: now that we are zonking quantified type variables
+  on construction, the 'a' will be frozen as a regular tyvar on
+  quantification, so the floated dict will still have type (C d a).
+  Which renders this whole note moot; happily!]
+
+* Then the \/\a abstraction has a zonked 'a' in it.
+
+All very silly.   I think its harmless to ignore the problem.  We'll end up with
+a \/\a in the final result but all the occurrences of a will be zonked to ()
+
+************************************************************************
+*                                                                      *
+              Zonking types
+*                                                                      *
+************************************************************************
+
+-}
+
+-- | @tcGetGlobalTyCoVars@ returns a fully-zonked set of *scoped* tyvars free in
+-- the environment. To improve subsequent calls to the same function it writes
+-- the zonked set back into the environment. Note that this returns all
+-- variables free in anything (term-level or type-level) in scope. We thus
+-- don't have to worry about clashes with things that are not in scope, because
+-- if they are reachable, then they'll be returned here.
+-- NB: This is closed over kinds, so it can return unification variables mentioned
+-- in the kinds of in-scope tyvars.
+tcGetGlobalTyCoVars :: TcM TcTyVarSet
+tcGetGlobalTyCoVars
+  = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv
+       ; gbl_tvs  <- readMutVar gtv_var
+       ; gbl_tvs' <- zonkTyCoVarsAndFV gbl_tvs
+       ; writeMutVar gtv_var gbl_tvs'
+       ; return gbl_tvs' }
+
+zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet
+-- Zonk a type and take its free variables
+-- With kind polymorphism it can be essential to zonk *first*
+-- so that we find the right set of free variables.  Eg
+--    forall k1. forall (a:k2). a
+-- where k2:=k1 is in the substitution.  We don't want
+-- k2 to look free in this type!
+zonkTcTypeAndFV ty
+  = tyCoVarsOfTypeDSet <$> zonkTcType ty
+
+zonkTyCoVar :: TyCoVar -> TcM TcType
+-- Works on TyVars and TcTyVars
+zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv
+               | isTyVar   tv = mkTyVarTy <$> zonkTyCoVarKind tv
+               | otherwise    = ASSERT2( isCoVar tv, ppr tv )
+                                mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv
+   -- Hackily, when typechecking type and class decls
+   -- we have TyVars in scope added (only) in
+   -- TcHsType.bindTyClTyVars, but it seems
+   -- painful to make them into TcTyVars there
+
+zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet
+zonkTyCoVarsAndFV tycovars
+  = tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars)
+  -- It's OK to use nonDetEltsUniqSet here because we immediately forget about
+  -- the ordering by turning it into a nondeterministic set and the order
+  -- of zonking doesn't matter for determinism.
+
+-- Takes a list of TyCoVars, zonks them and returns a
+-- deterministically ordered list of their free variables.
+zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar]
+zonkTyCoVarsAndFVList tycovars
+  = tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars
+
+zonkTcTyVars :: [TcTyVar] -> TcM [TcType]
+zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars
+
+-----------------  Types
+zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar
+zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv)
+                        ; return (setTyVarKind tv kind') }
+
+zonkTcTypes :: [TcType] -> TcM [TcType]
+zonkTcTypes tys = mapM zonkTcType tys
+
+{-
+************************************************************************
+*                                                                      *
+              Zonking constraints
+*                                                                      *
+************************************************************************
+-}
+
+zonkImplication :: Implication -> TcM Implication
+zonkImplication implic@(Implic { ic_skols  = skols
+                               , ic_given  = given
+                               , ic_wanted = wanted
+                               , ic_info   = info })
+  = do { skols'  <- mapM zonkTyCoVarKind skols  -- Need to zonk their kinds!
+                                                -- as Trac #7230 showed
+       ; given'  <- mapM zonkEvVar given
+       ; info'   <- zonkSkolemInfo info
+       ; wanted' <- zonkWCRec wanted
+       ; return (implic { ic_skols  = skols'
+                        , ic_given  = given'
+                        , ic_wanted = wanted'
+                        , ic_info   = info' }) }
+
+zonkEvVar :: EvVar -> TcM EvVar
+zonkEvVar var = do { ty' <- zonkTcType (varType var)
+                   ; return (setVarType var ty') }
+
+
+zonkWC :: WantedConstraints -> TcM WantedConstraints
+zonkWC wc = zonkWCRec wc
+
+zonkWCRec :: WantedConstraints -> TcM WantedConstraints
+zonkWCRec (WC { wc_simple = simple, wc_impl = implic })
+  = do { simple' <- zonkSimples simple
+       ; implic' <- mapBagM zonkImplication implic
+       ; return (WC { wc_simple = simple', wc_impl = implic' }) }
+
+zonkSimples :: Cts -> TcM Cts
+zonkSimples cts = do { cts' <- mapBagM zonkCt' cts
+                     ; traceTc "zonkSimples done:" (ppr cts')
+                     ; return cts' }
+
+zonkCt' :: Ct -> TcM Ct
+zonkCt' ct = zonkCt ct
+
+{- Note [zonkCt behaviour]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+zonkCt tries to maintain the canonical form of a Ct.  For example,
+  - a CDictCan should stay a CDictCan;
+  - a CTyEqCan should stay a CTyEqCan (if the LHS stays as a variable.).
+  - a CHoleCan should stay a CHoleCan
+  - a CIrredCan should stay a CIrredCan with its cc_insol flag intact
+
+Why?, for example:
+- For CDictCan, the @TcSimplify.expandSuperClasses@ step, which runs after the
+  simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use,
+  constraints are zonked before being passed to the plugin. This means if we
+  don't preserve a canonical form, @expandSuperClasses@ fails to expand
+  superclasses. This is what happened in Trac #11525.
+
+- For CHoleCan, once we forget that it's a hole, we can never recover that info.
+
+- For CIrredCan we want to see if a constraint is insoluble with insolubleWC
+
+NB: we do not expect to see any CFunEqCans, because zonkCt is only
+called on unflattened constraints.
+
+NB: Constraints are always re-flattened etc by the canonicaliser in
+@TcCanonical@ even if they come in as CDictCan. Only canonical constraints that
+are actually in the inert set carry all the guarantees. So it is okay if zonkCt
+creates e.g. a CDictCan where the cc_tyars are /not/ function free.
+-}
+
+zonkCt :: Ct -> TcM Ct
+zonkCt ct@(CHoleCan { cc_ev = ev })
+  = do { ev' <- zonkCtEvidence ev
+       ; return $ ct { cc_ev = ev' } }
+
+zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args })
+  = do { ev'   <- zonkCtEvidence ev
+       ; args' <- mapM zonkTcType args
+       ; return $ ct { cc_ev = ev', cc_tyargs = args' } }
+
+zonkCt ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs })
+  = do { ev'    <- zonkCtEvidence ev
+       ; tv_ty' <- zonkTcTyVar tv
+       ; case getTyVar_maybe tv_ty' of
+           Just tv' -> do { rhs' <- zonkTcType rhs
+                          ; return ct { cc_ev    = ev'
+                                      , cc_tyvar = tv'
+                                      , cc_rhs   = rhs' } }
+           Nothing  -> return (mkNonCanonical ev') }
+
+zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_insol flag
+  = do { ev' <- zonkCtEvidence ev
+       ; return (ct { cc_ev = ev' }) }
+
+zonkCt ct
+  = ASSERT( not (isCFunEqCan ct) )
+  -- We do not expect to see any CFunEqCans, because zonkCt is only called on
+  -- unflattened constraints.
+    do { fl' <- zonkCtEvidence (ctEvidence ct)
+       ; return (mkNonCanonical fl') }
+
+zonkCtEvidence :: CtEvidence -> TcM CtEvidence
+zonkCtEvidence ctev@(CtGiven { ctev_pred = pred })
+  = do { pred' <- zonkTcType pred
+       ; return (ctev { ctev_pred = pred'}) }
+zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest })
+  = do { pred' <- zonkTcType pred
+       ; let dest' = case dest of
+                       EvVarDest ev -> EvVarDest $ setVarType ev pred'
+                         -- necessary in simplifyInfer
+                       HoleDest h   -> HoleDest h
+       ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) }
+zonkCtEvidence ctev@(CtDerived { ctev_pred = pred })
+  = do { pred' <- zonkTcType pred
+       ; return (ctev { ctev_pred = pred' }) }
+
+zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo
+zonkSkolemInfo (SigSkol cx ty tv_prs)  = do { ty' <- zonkTcType ty
+                                            ; return (SigSkol cx ty' tv_prs) }
+zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys
+                                     ; return (InferSkol ntys') }
+  where
+    do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') }
+zonkSkolemInfo skol_info = return skol_info
+
+{-
+%************************************************************************
+%*                                                                      *
+\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar}
+*                                                                      *
+*              For internal use only!                                  *
+*                                                                      *
+************************************************************************
+
+-}
+
+-- zonkId is used *during* typechecking just to zonk the Id's type
+zonkId :: TcId -> TcM TcId
+zonkId id
+  = do { ty' <- zonkTcType (idType id)
+       ; return (Id.setIdType id ty') }
+
+zonkCoVar :: CoVar -> TcM CoVar
+zonkCoVar = zonkId
+
+-- | A suitable TyCoMapper for zonking a type during type-checking,
+-- before all metavars are filled in.
+zonkTcTypeMapper :: TyCoMapper () TcM
+zonkTcTypeMapper = TyCoMapper
+  { tcm_smart = True
+  , tcm_tyvar = const zonkTcTyVar
+  , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv)
+  , tcm_hole  = hole
+  , tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTyCoVarKind tv
+  , tcm_tycon = return }
+  where
+    hole :: () -> CoercionHole -> TcM Coercion
+    hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })
+      = do { contents <- readTcRef ref
+           ; case contents of
+               Just co -> do { co' <- zonkCo co
+                             ; checkCoercionHole cv co' }
+               Nothing -> do { cv' <- zonkCoVar cv
+                             ; return $ HoleCo (hole { ch_co_var = cv' }) } }
+
+-- For unbound, mutable tyvars, zonkType uses the function given to it
+-- For tyvars bound at a for-all, zonkType zonks them to an immutable
+--      type variable and zonks the kind too
+zonkTcType :: TcType -> TcM TcType
+zonkTcType = mapType zonkTcTypeMapper ()
+
+-- | "Zonk" a coercion -- really, just zonk any types in the coercion
+zonkCo :: Coercion -> TcM Coercion
+zonkCo = mapCoercion zonkTcTypeMapper ()
+
+zonkTcTyCoVarBndr :: TcTyCoVar -> TcM TcTyCoVar
+-- A tyvar binder is never a unification variable (TauTv),
+-- rather it is always a skolem. It *might* be a TyVarTv.
+-- (Because non-CUSK type declarations use TyVarTvs.)
+-- Regardless, it may have a kind
+-- that has not yet been zonked, and may include kind
+-- unification variables.
+zonkTcTyCoVarBndr tyvar
+  | isTyVarTyVar tyvar
+     -- We want to preserve the binding location of the original TyVarTv.
+     -- This is important for error messages. If we don't do this, then
+     -- we get bad locations in, e.g., typecheck/should_fail/T2688
+  = do { zonked_ty <- zonkTcTyVar tyvar
+       ; let zonked_tyvar = tcGetTyVar "zonkTcTyCoVarBndr TyVarTv" zonked_ty
+             zonked_name  = getName zonked_tyvar
+             reloc'd_name = setNameLoc zonked_name (getSrcSpan tyvar)
+       ; return (setTyVarName zonked_tyvar reloc'd_name) }
+
+  | otherwise
+  = ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar )
+    zonkTyCoVarKind tyvar
+
+zonkTyConBinders :: [TyConBinder] -> TcM [TyConBinder]
+zonkTyConBinders = mapM zonk1
+  where
+    zonk1 (Bndr tv vis)
+      = do { tv' <- zonkTcTyCoVarBndr tv
+           ; return (Bndr tv' vis) }
+
+zonkTcTyVar :: TcTyVar -> TcM TcType
+-- Simply look through all Flexis
+zonkTcTyVar tv
+  | isTcTyVar tv
+  = case tcTyVarDetails tv of
+      SkolemTv {}   -> zonk_kind_and_return
+      RuntimeUnk {} -> zonk_kind_and_return
+      MetaTv { mtv_ref = ref }
+         -> do { cts <- readMutVar ref
+               ; case cts of
+                    Flexi       -> zonk_kind_and_return
+                    Indirect ty -> do { zty <- zonkTcType ty
+                                      ; writeTcRef ref (Indirect zty)
+                                        -- See Note [Sharing in zonking]
+                                      ; return zty } }
+
+  | otherwise -- coercion variable
+  = zonk_kind_and_return
+  where
+    zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv
+                              ; return (mkTyVarTy z_tv) }
+
+-- Variant that assumes that any result of zonking is still a TyVar.
+-- Should be used only on skolems and TyVarTvs
+zonkTcTyVarToTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar
+zonkTcTyVarToTyVar tv
+  = do { ty <- zonkTcTyVar tv
+       ; let tv' = case tcGetTyVar_maybe ty of
+                     Just tv' -> tv'
+                     Nothing  -> pprPanic "zonkTcTyVarToTyVar"
+                                          (ppr tv $$ ppr ty)
+       ; return tv' }
+
+zonkTyVarTyVarPairs :: [(Name,TcTyVar)] -> TcM [(Name,TcTyVar)]
+zonkTyVarTyVarPairs prs
+  = mapM do_one prs
+  where
+    do_one (nm, tv) = do { tv' <- zonkTcTyVarToTyVar tv
+                         ; return (nm, tv') }
+
+{- Note [Sharing in zonking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+   alpha :-> beta :-> gamma :-> ty
+where the ":->" means that the unification variable has been
+filled in with Indirect. Then when zonking alpha, it'd be nice
+to short-circuit beta too, so we end up with
+   alpha :-> zty
+   beta  :-> zty
+   gamma :-> zty
+where zty is the zonked version of ty.  That way, if we come across
+beta later, we'll have less work to do.  (And indeed the same for
+alpha.)
+
+This is easily achieved: just overwrite (Indirect ty) with (Indirect
+zty).  Non-systematic perf comparisons suggest that this is a modest
+win.
+
+But c.f Note [Sharing when zonking to Type] in TcHsSyn.
+
+%************************************************************************
+%*                                                                      *
+                 Tidying
+*                                                                      *
+************************************************************************
+-}
+
+zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)
+zonkTidyTcType env ty = do { ty' <- zonkTcType ty
+                           ; return (tidyOpenType env ty') }
+
+zonkTidyTcTypes :: TidyEnv -> [TcType] -> TcM (TidyEnv, [TcType])
+zonkTidyTcTypes = zonkTidyTcTypes' []
+  where zonkTidyTcTypes' zs env [] = return (env, reverse zs)
+        zonkTidyTcTypes' zs env (ty:tys)
+          = do { (env', ty') <- zonkTidyTcType env ty
+               ; zonkTidyTcTypes' (ty':zs) env' tys }
+
+zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin)
+zonkTidyOrigin env (GivenOrigin skol_info)
+  = do { skol_info1 <- zonkSkolemInfo skol_info
+       ; let skol_info2 = tidySkolemInfo env skol_info1
+       ; return (env, GivenOrigin skol_info2) }
+zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual   = act
+                                      , uo_expected = exp })
+  = do { (env1, act') <- zonkTidyTcType env  act
+       ; (env2, exp') <- zonkTidyTcType env1 exp
+       ; return ( env2, orig { uo_actual   = act'
+                             , uo_expected = exp' }) }
+zonkTidyOrigin env (KindEqOrigin ty1 m_ty2 orig t_or_k)
+  = do { (env1, ty1')   <- zonkTidyTcType env  ty1
+       ; (env2, m_ty2') <- case m_ty2 of
+                             Just ty2 -> second Just <$> zonkTidyTcType env1 ty2
+                             Nothing  -> return (env1, Nothing)
+       ; (env3, orig')  <- zonkTidyOrigin env2 orig
+       ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) }
+zonkTidyOrigin env (FunDepOrigin1 p1 l1 p2 l2)
+  = do { (env1, p1') <- zonkTidyTcType env  p1
+       ; (env2, p2') <- zonkTidyTcType env1 p2
+       ; return (env2, FunDepOrigin1 p1' l1 p2' l2) }
+zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2)
+  = do { (env1, p1') <- zonkTidyTcType env  p1
+       ; (env2, p2') <- zonkTidyTcType env1 p2
+       ; (env3, o1') <- zonkTidyOrigin env2 o1
+       ; return (env3, FunDepOrigin2 p1' o1' p2' l2) }
+zonkTidyOrigin env orig = return (env, orig)
+
+----------------
+tidyCt :: TidyEnv -> Ct -> Ct
+-- Used only in error reporting
+-- Also converts it to non-canonical
+tidyCt env ct
+  = case ct of
+     CHoleCan { cc_ev = ev }
+       -> ct { cc_ev = tidy_ev env ev }
+     _ -> mkNonCanonical (tidy_ev env (ctEvidence ct))
+  where
+    tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence
+     -- NB: we do not tidy the ctev_evar field because we don't
+     --     show it in error messages
+    tidy_ev env ctev@(CtGiven { ctev_pred = pred })
+      = ctev { ctev_pred = tidyType env pred }
+    tidy_ev env ctev@(CtWanted { ctev_pred = pred })
+      = ctev { ctev_pred = tidyType env pred }
+    tidy_ev env ctev@(CtDerived { ctev_pred = pred })
+      = ctev { ctev_pred = tidyType env pred }
+
+----------------
+tidyEvVar :: TidyEnv -> EvVar -> EvVar
+tidyEvVar env var = setVarType var (tidyType env (varType var))
+
+----------------
+tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
+tidySkolemInfo env (DerivSkol ty)         = DerivSkol (tidyType env ty)
+tidySkolemInfo env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs
+tidySkolemInfo env (InferSkol ids)        = InferSkol (mapSnd (tidyType env) ids)
+tidySkolemInfo env (UnifyForAllSkol ty)   = UnifyForAllSkol (tidyType env ty)
+tidySkolemInfo _   info                   = info
+
+tidySigSkol :: TidyEnv -> UserTypeCtxt
+            -> TcType -> [(Name,TcTyVar)] -> SkolemInfo
+-- We need to take special care when tidying SigSkol
+-- See Note [SigSkol SkolemInfo] in TcRnTypes
+tidySigSkol env cx ty tv_prs
+  = SigSkol cx (tidy_ty env ty) tv_prs'
+  where
+    tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs
+    inst_env = mkNameEnv tv_prs'
+
+    tidy_ty env (ForAllTy (Bndr tv vis) ty)
+      = ForAllTy (Bndr tv' vis) (tidy_ty env' ty)
+      where
+        (env', tv') = tidy_tv_bndr env tv
+
+    tidy_ty env (FunTy arg res)
+      = FunTy (tidyType env arg) (tidy_ty env res)
+
+    tidy_ty env ty = tidyType env ty
+
+    tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
+    tidy_tv_bndr env@(occ_env, subst) tv
+      | Just tv' <- lookupNameEnv inst_env (tyVarName tv)
+      = ((occ_env, extendVarEnv subst tv tv'), tv')
+
+      | otherwise
+      = tidyVarBndr env tv
+
+-------------------------------------------------------------------------
+{-
+%************************************************************************
+%*                                                                      *
+             Levity polymorphism checks
+*                                                                      *
+************************************************************************
+
+See Note [Levity polymorphism checking] in DsMonad
+
+-}
+
+-- | According to the rules around representation polymorphism
+-- (see https://ghc.haskell.org/trac/ghc/wiki/NoSubKinds), no binder
+-- can have a representation-polymorphic type. This check ensures
+-- that we respect this rule. It is a bit regrettable that this error
+-- occurs in zonking, after which we should have reported all errors.
+-- But it's hard to see where else to do it, because this can be discovered
+-- only after all solving is done. And, perhaps most importantly, this
+-- isn't really a compositional property of a type system, so it's
+-- not a terrible surprise that the check has to go in an awkward spot.
+ensureNotLevPoly :: Type  -- its zonked type
+                 -> SDoc  -- where this happened
+                 -> TcM ()
+ensureNotLevPoly ty doc
+  = whenNoErrs $   -- sometimes we end up zonking bogus definitions of type
+                   -- forall a. a. See, for example, test ghci/scripts/T9140
+    checkForLevPoly doc ty
+
+  -- See Note [Levity polymorphism checking] in DsMonad
+checkForLevPoly :: SDoc -> Type -> TcM ()
+checkForLevPoly = checkForLevPolyX addErr
+
+checkForLevPolyX :: Monad m
+                 => (SDoc -> m ())  -- how to report an error
+                 -> SDoc -> Type -> m ()
+checkForLevPolyX add_err extra ty
+  | isTypeLevPoly ty
+  = add_err (formatLevPolyErr ty $$ extra)
+  | otherwise
+  = return ()
+
+formatLevPolyErr :: Type  -- levity-polymorphic type
+                 -> SDoc
+formatLevPolyErr ty
+  = hang (text "A levity-polymorphic type is not allowed here:")
+       2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty
+               , text "Kind:" <+> pprWithTYPE tidy_ki ])
+  where
+    (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty
+    tidy_ki             = tidyType tidy_env (tcTypeKind ty)
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcMatches.hs
@@ -0,0 +1,1100 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+TcMatches: Typecheck some @Matches@
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
+                   TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,
+                   tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
+                   tcDoStmt, tcGuardStmt
+       ) where
+
+import GhcPrelude
+
+import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma
+                              , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )
+
+import BasicTypes (LexicalFixity(..))
+import HsSyn
+import TcRnMonad
+import TcEnv
+import TcPat
+import TcMType
+import TcType
+import TcBinds
+import TcUnify
+import Name
+import TysWiredIn
+import Id
+import TyCon
+import TysPrim
+import TcEvidence
+import Outputable
+import Util
+import SrcLoc
+
+-- Create chunkified tuple tybes for monad comprehensions
+import MkCore
+
+import Control.Monad
+import Control.Arrow ( second )
+
+#include "HsVersions.h"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{tcMatchesFun, tcMatchesCase}
+*                                                                      *
+************************************************************************
+
+@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
+@FunMonoBind@.  The second argument is the name of the function, which
+is used in error messages.  It checks that all the equations have the
+same number of arguments before using @tcMatches@ to do the work.
+
+Note [Polymorphic expected type for tcMatchesFun]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcMatchesFun may be given a *sigma* (polymorphic) type
+so it must be prepared to use tcSkolemise to skolemise it.
+See Note [sig_tau may be polymorphic] in TcPat.
+-}
+
+tcMatchesFun :: Located Name
+             -> MatchGroup GhcRn (LHsExpr GhcRn)
+             -> ExpRhoType     -- Expected type of function
+             -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
+                                -- Returns type of body
+tcMatchesFun fn@(L _ fun_name) matches exp_ty
+  = do  {  -- Check that they all have the same no of arguments
+           -- Location is in the monad, set the caller so that
+           -- any inter-equation error messages get some vaguely
+           -- sensible location.        Note: we have to do this odd
+           -- ann-grabbing, because we don't always have annotations in
+           -- hand when we call tcMatchesFun...
+          traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
+        ; checkArgs fun_name matches
+
+        ; (wrap_gen, (wrap_fun, group))
+            <- tcSkolemiseET (FunSigCtxt fun_name True) exp_ty $ \ exp_rho ->
+                  -- Note [Polymorphic expected type for tcMatchesFun]
+               do { (matches', wrap_fun)
+                       <- matchExpectedFunTys herald arity exp_rho $
+                          \ pat_tys rhs_ty ->
+                          tcMatches match_ctxt pat_tys rhs_ty matches
+                  ; return (wrap_fun, matches') }
+        ; return (wrap_gen <.> wrap_fun, group) }
+  where
+    arity = matchGroupArity matches
+    herald = text "The equation(s) for"
+             <+> quotes (ppr fun_name) <+> text "have"
+    what = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness }
+    match_ctxt = MC { mc_what = what, mc_body = tcBody }
+    strictness
+      | [L _ match] <- unLoc $ mg_alts matches
+      , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match
+      = SrcStrict
+      | otherwise
+      = NoSrcStrict
+
+{-
+@tcMatchesCase@ doesn't do the argument-count check because the
+parser guarantees that each equation has exactly one argument.
+-}
+
+tcMatchesCase :: (Outputable (body GhcRn)) =>
+                TcMatchCtxt body                        -- Case context
+             -> TcSigmaType                             -- Type of scrutinee
+             -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives
+             -> ExpRhoType                    -- Type of whole case expressions
+             -> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
+                -- Translated alternatives
+                -- wrapper goes from MatchGroup's ty to expected ty
+
+tcMatchesCase ctxt scrut_ty matches res_ty
+  = tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches
+
+tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify
+              -> TcMatchCtxt HsExpr
+              -> MatchGroup GhcRn (LHsExpr GhcRn)
+              -> ExpRhoType   -- deeply skolemised
+              -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)
+tcMatchLambda herald match_ctxt match res_ty
+  = matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty ->
+    tcMatches match_ctxt pat_tys rhs_ty match
+  where
+    n_pats | isEmptyMatchGroup match = 1   -- must be lambda-case
+           | otherwise               = matchGroupArity match
+
+-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
+
+tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType
+           -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))
+-- Used for pattern bindings
+tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty)
+  where
+    match_ctxt = MC { mc_what = PatBindRhs,
+                      mc_body = tcBody }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{tcMatch}
+*                                                                      *
+************************************************************************
+
+Note [Case branches must never infer a non-tau type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+  case ... of
+    ... -> \(x :: forall a. a -> a) -> x
+    ... -> \y -> y
+
+Should that type-check? The problem is that, if we check the second branch
+first, then we'll get a type (b -> b) for the branches, which won't unify
+with the polytype in the first branch. If we check the first branch first,
+then everything is OK. This order-dependency is terrible. So we want only
+proper tau-types in branches (unless a sigma-type is pushed down).
+This is what expTypeToType ensures: it replaces an Infer with a fresh
+tau-type.
+
+An even trickier case looks like
+
+  f x True  = x undefined
+  f x False = x ()
+
+Here, we see that the arguments must also be non-Infer. Thus, we must
+use expTypeToType on the output of matchExpectedFunTys, not the input.
+
+But we make a special case for a one-branch case. This is so that
+
+  f = \(x :: forall a. a -> a) -> x
+
+still gets assigned a polytype.
+-}
+
+-- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the
+-- expected type into TauTvs.
+-- See Note [Case branches must never infer a non-tau type]
+tauifyMultipleMatches :: [LMatch id body]
+                      -> [ExpType] -> TcM [ExpType]
+tauifyMultipleMatches group exp_tys
+  | isSingletonMatchGroup group = return exp_tys
+  | otherwise                   = mapM tauifyExpType exp_tys
+  -- NB: In the empty-match case, this ensures we fill in the ExpType
+
+-- | Type-check a MatchGroup.
+tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body
+          -> [ExpSigmaType]      -- Expected pattern types
+          -> ExpRhoType          -- Expected result-type of the Match.
+          -> MatchGroup GhcRn (Located (body GhcRn))
+          -> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))
+
+data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module
+  = MC { mc_what :: HsMatchContext Name,  -- What kind of thing this is
+         mc_body :: Located (body GhcRn)         -- Type checker for a body of
+                                                -- an alternative
+                 -> ExpRhoType
+                 -> TcM (Located (body GhcTcId)) }
+
+tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
+                                  , mg_origin = origin })
+  = do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys)
+            -- See Note [Case branches must never infer a non-tau type]
+
+       ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
+       ; pat_tys  <- mapM readExpType pat_tys
+       ; rhs_ty   <- readExpType rhs_ty
+       ; return (MG { mg_alts = L l matches'
+                    , mg_ext = MatchGroupTc pat_tys rhs_ty
+                    , mg_origin = origin }) }
+tcMatches _ _ _ (XMatchGroup {}) = panic "tcMatches"
+
+-------------
+tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body
+        -> [ExpSigmaType]        -- Expected pattern types
+        -> ExpRhoType            -- Expected result-type of the Match.
+        -> LMatch GhcRn (Located (body GhcRn))
+        -> TcM (LMatch GhcTcId (Located (body GhcTcId)))
+
+tcMatch ctxt pat_tys rhs_ty match
+  = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
+  where
+    tc_match ctxt pat_tys rhs_ty
+             match@(Match { m_pats = pats, m_grhss = grhss })
+      = add_match_ctxt match $
+        do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
+                                tcGRHSs ctxt grhss rhs_ty
+           ; return (Match { m_ext = noExt
+                           , m_ctxt = mc_what ctxt, m_pats = pats'
+                           , m_grhss = grhss' }) }
+    tc_match  _ _ _ (XMatch _) = panic "tcMatch"
+
+        -- For (\x -> e), tcExpr has already said "In the expression \x->e"
+        -- so we don't want to add "In the lambda abstraction \x->e"
+    add_match_ctxt match thing_inside
+        = case mc_what ctxt of
+            LambdaExpr -> thing_inside
+            _          -> addErrCtxt (pprMatchInCtxt match) thing_inside
+
+-------------
+tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType
+        -> TcM (GRHSs GhcTcId (Located (body GhcTcId)))
+
+-- Notice that we pass in the full res_ty, so that we get
+-- good inference from simple things like
+--      f = \(x::forall a.a->a) -> <stuff>
+-- We used to force it to be a monotype when there was more than one guard
+-- but we don't need to do that any more
+
+tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty
+  = do  { (binds', grhss')
+            <- tcLocalBinds binds $
+               mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
+
+        ; return (GRHSs noExt grhss' (L l binds')) }
+tcGRHSs _ (XGRHSs _) _ = panic "tcGRHSs"
+
+-------------
+tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn))
+       -> TcM (GRHS GhcTcId (Located (body GhcTcId)))
+
+tcGRHS ctxt res_ty (GRHS _ guards rhs)
+  = do  { (guards', rhs')
+            <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
+               mc_body ctxt rhs
+        ; return (GRHS noExt guards' rhs') }
+  where
+    stmt_ctxt  = PatGuard (mc_what ctxt)
+tcGRHS _ _ (XGRHS _) = panic "tcGRHS"
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
+*                                                                      *
+************************************************************************
+-}
+
+tcDoStmts :: HsStmtContext Name
+          -> Located [LStmt GhcRn (LHsExpr GhcRn)]
+          -> ExpRhoType
+          -> TcM (HsExpr GhcTcId)          -- Returns a HsDo
+tcDoStmts ListComp (L l stmts) res_ty
+  = do  { res_ty <- expTypeToType res_ty
+        ; (co, elt_ty) <- matchExpectedListTy res_ty
+        ; let list_ty = mkListTy elt_ty
+        ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts
+                            (mkCheckExpType elt_ty)
+        ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
+
+tcDoStmts DoExpr (L l stmts) res_ty
+  = do  { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
+        ; res_ty <- readExpType res_ty
+        ; return (HsDo res_ty DoExpr (L l stmts')) }
+
+tcDoStmts MDoExpr (L l stmts) res_ty
+  = do  { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
+        ; res_ty <- readExpType res_ty
+        ; return (HsDo res_ty MDoExpr (L l stmts')) }
+
+tcDoStmts MonadComp (L l stmts) res_ty
+  = do  { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
+        ; res_ty <- readExpType res_ty
+        ; return (HsDo res_ty MonadComp (L l stmts')) }
+
+tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
+
+tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)
+tcBody body res_ty
+  = do  { traceTc "tcBody" (ppr res_ty)
+        ; tcMonoExpr body res_ty
+        }
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{tcStmts}
+*                                                                      *
+************************************************************************
+-}
+
+type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
+type TcCmdStmtChecker  = TcStmtChecker HsCmd  TcRhoType
+
+type TcStmtChecker body rho_type
+  =  forall thing. HsStmtContext Name
+                -> Stmt GhcRn (Located (body GhcRn))
+                -> rho_type                 -- Result type for comprehension
+                -> (rho_type -> TcM thing)  -- Checker for what follows the stmt
+                -> TcM (Stmt GhcTcId (Located (body GhcTcId)), thing)
+
+tcStmts :: (Outputable (body GhcRn)) => HsStmtContext Name
+        -> TcStmtChecker body rho_type   -- NB: higher-rank type
+        -> [LStmt GhcRn (Located (body GhcRn))]
+        -> rho_type
+        -> TcM [LStmt GhcTcId (Located (body GhcTcId))]
+tcStmts ctxt stmt_chk stmts res_ty
+  = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
+                        const (return ())
+       ; return stmts' }
+
+tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext Name
+               -> TcStmtChecker body rho_type    -- NB: higher-rank type
+               -> [LStmt GhcRn (Located (body GhcRn))]
+               -> rho_type
+               -> (rho_type -> TcM thing)
+               -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)
+
+-- Note the higher-rank type.  stmt_chk is applied at different
+-- types in the equations for tcStmts
+
+tcStmtsAndThen _ _ [] res_ty thing_inside
+  = do  { thing <- thing_inside res_ty
+        ; return ([], thing) }
+
+-- LetStmts are handled uniformly, regardless of context
+tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts)
+                                                             res_ty thing_inside
+  = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
+              tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
+        ; return (L loc (LetStmt x (L l binds')) : stmts', thing) }
+
+-- Don't set the error context for an ApplicativeStmt.  It ought to be
+-- possible to do this with a popErrCtxt in the tcStmt case for
+-- ApplicativeStmt, but it did someting strange and broke a test (ado002).
+tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
+  | ApplicativeStmt{} <- stmt
+  = do  { (stmt', (stmts', thing)) <-
+             stmt_chk ctxt stmt res_ty $ \ res_ty' ->
+               tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $
+                 thing_inside
+        ; return (L loc stmt' : stmts', thing) }
+
+  -- For the vanilla case, handle the location-setting part
+  | otherwise
+  = do  { (stmt', (stmts', thing)) <-
+                setSrcSpan loc                              $
+                addErrCtxt (pprStmtInCtxt ctxt stmt)        $
+                stmt_chk ctxt stmt res_ty                   $ \ res_ty' ->
+                popErrCtxt                                  $
+                tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $
+                thing_inside
+        ; return (L loc stmt' : stmts', thing) }
+
+---------------------------------------------------
+--              Pattern guards
+---------------------------------------------------
+
+tcGuardStmt :: TcExprStmtChecker
+tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside
+  = do  { guard' <- tcMonoExpr guard (mkCheckExpType boolTy)
+        ; thing  <- thing_inside res_ty
+        ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }
+
+tcGuardStmt ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside
+  = do  { (rhs', rhs_ty) <- tcInferSigmaNC rhs
+                                   -- Stmt has a context already
+        ; (pat', thing)  <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
+                                    pat (mkCheckExpType rhs_ty) $
+                            thing_inside res_ty
+        ; return (mkTcBindStmt pat' rhs', thing) }
+
+tcGuardStmt _ stmt _ _
+  = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
+
+
+---------------------------------------------------
+--           List comprehensions
+--               (no rebindable syntax)
+---------------------------------------------------
+
+-- Dealt with separately, rather than by tcMcStmt, because
+--   a) We have special desugaring rules for list comprehensions,
+--      which avoid creating intermediate lists.  They in turn
+--      assume that the bind/return operations are the regular
+--      polymorphic ones, and in particular don't have any
+--      coercion matching stuff in them.  It's hard to avoid the
+--      potential for non-trivial coercions in tcMcStmt
+
+tcLcStmt :: TyCon       -- The list type constructor ([])
+         -> TcExprStmtChecker
+
+tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside
+  = do { body' <- tcMonoExprNC body elt_ty
+       ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
+       ; return (LastStmt x body' noret noSyntaxExpr, thing) }
+
+-- A generator, pat <- rhs
+tcLcStmt m_tc ctxt (BindStmt _ pat rhs _ _) elt_ty thing_inside
+ = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind
+        ; rhs'   <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty])
+        ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
+                            thing_inside elt_ty
+        ; return (mkTcBindStmt pat' rhs', thing) }
+
+-- A boolean guard
+tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside
+  = do  { rhs'  <- tcMonoExpr rhs (mkCheckExpType boolTy)
+        ; thing <- thing_inside elt_ty
+        ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) }
+
+-- ParStmt: See notes with tcMcStmt
+tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside
+  = do  { (pairs', thing) <- loop bndr_stmts_s
+        ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) }
+  where
+    -- loop :: [([LStmt GhcRn], [GhcRn])]
+    --      -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)
+    loop [] = do { thing <- thing_inside elt_ty
+                 ; return ([], thing) }         -- matching in the branches
+
+    loop (ParStmtBlock x stmts names _ : pairs)
+      = do { (stmts', (ids, pairs', thing))
+                <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
+                   do { ids <- tcLookupLocalIds names
+                      ; (pairs', thing) <- loop pairs
+                      ; return (ids, pairs', thing) }
+           ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }
+    loop (XParStmtBlock{}:_) = panic "tcLcStmt"
+
+tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
+                              , trS_bndrs =  bindersMap
+                              , trS_by = by, trS_using = using }) elt_ty thing_inside
+  = do { let (bndr_names, n_bndr_names) = unzip bindersMap
+             unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
+             -- The inner 'stmts' lack a LastStmt, so the element type
+             --  passed in to tcStmtsAndThen is never looked at
+       ; (stmts', (bndr_ids, by'))
+            <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
+               { by' <- traverse tcInferSigma by
+               ; bndr_ids <- tcLookupLocalIds bndr_names
+               ; return (bndr_ids, by') }
+
+       ; let m_app ty = mkTyConApp m_tc [ty]
+
+       --------------- Typecheck the 'using' function -------------
+       -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m      (ThenForm)
+       --       :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c)))  (GroupForm)
+
+         -- n_app :: Type -> Type   -- Wraps a 'ty' into '[ty]' for GroupForm
+       ; let n_app = case form of
+                       ThenForm -> (\ty -> ty)
+                       _        -> m_app
+
+             by_arrow :: Type -> Type     -- Wraps 'ty' to '(a->t) -> ty' if the By is present
+             by_arrow = case by' of
+                          Nothing       -> \ty -> ty
+                          Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty
+
+             tup_ty        = mkBigCoreVarTupTy bndr_ids
+             poly_arg_ty   = m_app alphaTy
+             poly_res_ty   = m_app (n_app alphaTy)
+             using_poly_ty = mkInvForAllTy alphaTyVar $
+                             by_arrow $
+                             poly_arg_ty `mkFunTy` poly_res_ty
+
+       ; using' <- tcPolyExpr using using_poly_ty
+       ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
+
+             -- 'stmts' returns a result of type (m1_ty tuple_ty),
+             -- typically something like [(Int,Bool,Int)]
+             -- We don't know what tuple_ty is yet, so we use a variable
+       ; let mk_n_bndr :: Name -> TcId -> TcId
+             mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
+
+             -- Ensure that every old binder of type `b` is linked up with its
+             -- new binder which should have type `n b`
+             -- See Note [GroupStmt binder map] in HsExpr
+             n_bndr_ids  = zipWith mk_n_bndr n_bndr_names bndr_ids
+             bindersMap' = bndr_ids `zip` n_bndr_ids
+
+       -- Type check the thing in the environment with
+       -- these new binders and return the result
+       ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
+
+       ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
+                           , trS_by = fmap fst by', trS_using = final_using
+                           , trS_ret = noSyntaxExpr
+                           , trS_bind = noSyntaxExpr
+                           , trS_fmap = noExpr
+                           , trS_ext = unitTy
+                           , trS_form = form }, thing) }
+
+tcLcStmt _ _ stmt _ _
+  = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
+
+
+---------------------------------------------------
+--           Monad comprehensions
+--        (supports rebindable syntax)
+---------------------------------------------------
+
+tcMcStmt :: TcExprStmtChecker
+
+tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside
+  = do  { (body', return_op')
+            <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $
+               \ [a_ty] ->
+               tcMonoExprNC body (mkCheckExpType a_ty)
+        ; thing      <- thing_inside (panic "tcMcStmt: thing_inside")
+        ; return (LastStmt x body' noret return_op', thing) }
+
+-- Generators for monad comprehensions ( pat <- rhs )
+--
+--   [ body | q <- gen ]  ->  gen :: m a
+--                            q   ::   a
+--
+
+tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
+           -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
+  = do  { ((rhs', pat', thing, new_res_ty), bind_op')
+            <- tcSyntaxOp MCompOrigin bind_op
+                          [SynRho, SynFun SynAny SynRho] res_ty $
+               \ [rhs_ty, pat_ty, new_res_ty] ->
+               do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
+                  ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
+                                           (mkCheckExpType pat_ty) $
+                                     thing_inside (mkCheckExpType new_res_ty)
+                  ; return (rhs', pat', thing, new_res_ty) }
+
+        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
+        ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty
+
+        ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
+
+-- Boolean expressions.
+--
+--   [ body | stmts, expr ]  ->  expr :: m Bool
+--
+tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside
+  = do  { -- Deal with rebindable syntax:
+          --    guard_op :: test_ty -> rhs_ty
+          --    then_op  :: rhs_ty -> new_res_ty -> res_ty
+          -- Where test_ty is, for example, Bool
+        ; ((thing, rhs', rhs_ty, guard_op'), then_op')
+            <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $
+               \ [rhs_ty, new_res_ty] ->
+               do { (rhs', guard_op')
+                      <- tcSyntaxOp MCompOrigin guard_op [SynAny]
+                                    (mkCheckExpType rhs_ty) $
+                         \ [test_ty] ->
+                         tcMonoExpr rhs (mkCheckExpType test_ty)
+                  ; thing <- thing_inside (mkCheckExpType new_res_ty)
+                  ; return (thing, rhs', rhs_ty, guard_op') }
+        ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) }
+
+-- Grouping statements
+--
+--   [ body | stmts, then group by e using f ]
+--     ->  e :: t
+--         f :: forall a. (a -> t) -> m a -> m (m a)
+--   [ body | stmts, then group using f ]
+--     ->  f :: forall a. m a -> m (m a)
+
+-- We type [ body | (stmts, group by e using f), ... ]
+--     f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
+--
+-- We type the functions as follows:
+--     f <optional by> :: m1 (a,b,c) -> m2 (a,b,c)              (ThenForm)
+--                     :: m1 (a,b,c) -> m2 (n (a,b,c))          (GroupForm)
+--     (>>=) :: m2 (a,b,c)     -> ((a,b,c)   -> res) -> res     (ThenForm)
+--           :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res     (GroupForm)
+--
+tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
+                         , trS_by = by, trS_using = using, trS_form = form
+                         , trS_ret = return_op, trS_bind = bind_op
+                         , trS_fmap = fmap_op }) res_ty thing_inside
+  = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind
+       ; m1_ty   <- newFlexiTyVarTy star_star_kind
+       ; m2_ty   <- newFlexiTyVarTy star_star_kind
+       ; tup_ty  <- newFlexiTyVarTy liftedTypeKind
+       ; by_e_ty <- newFlexiTyVarTy liftedTypeKind  -- The type of the 'by' expression (if any)
+
+         -- n_app :: Type -> Type   -- Wraps a 'ty' into '(n ty)' for GroupForm
+       ; n_app <- case form of
+                    ThenForm -> return (\ty -> ty)
+                    _        -> do { n_ty <- newFlexiTyVarTy star_star_kind
+                                   ; return (n_ty `mkAppTy`) }
+       ; let by_arrow :: Type -> Type
+             -- (by_arrow res) produces ((alpha->e_ty) -> res)     ('by' present)
+             --                          or res                    ('by' absent)
+             by_arrow = case by of
+                          Nothing -> \res -> res
+                          Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` res
+
+             poly_arg_ty  = m1_ty `mkAppTy` alphaTy
+             using_arg_ty = m1_ty `mkAppTy` tup_ty
+             poly_res_ty  = m2_ty `mkAppTy` n_app alphaTy
+             using_res_ty = m2_ty `mkAppTy` n_app tup_ty
+             using_poly_ty = mkInvForAllTy alphaTyVar $
+                             by_arrow $
+                             poly_arg_ty `mkFunTy` poly_res_ty
+
+             -- 'stmts' returns a result of type (m1_ty tuple_ty),
+             -- typically something like [(Int,Bool,Int)]
+             -- We don't know what tuple_ty is yet, so we use a variable
+       ; let (bndr_names, n_bndr_names) = unzip bindersMap
+       ; (stmts', (bndr_ids, by', return_op')) <-
+            tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts
+                           (mkCheckExpType using_arg_ty) $ \res_ty' -> do
+                { by' <- case by of
+                           Nothing -> return Nothing
+                           Just e  -> do { e' <- tcMonoExpr e
+                                                   (mkCheckExpType by_e_ty)
+                                         ; return (Just e') }
+
+                -- Find the Ids (and hence types) of all old binders
+                ; bndr_ids <- tcLookupLocalIds bndr_names
+
+                -- 'return' is only used for the binders, so we know its type.
+                --   return :: (a,b,c,..) -> m (a,b,c,..)
+                ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op
+                                       [synKnownType (mkBigCoreVarTupTy bndr_ids)]
+                                       res_ty' $ \ _ -> return ()
+
+                ; return (bndr_ids, by', return_op') }
+
+       --------------- Typecheck the 'bind' function -------------
+       -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
+       ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+       ; (_, bind_op')  <- tcSyntaxOp MCompOrigin bind_op
+                             [ synKnownType using_res_ty
+                             , synKnownType (n_app tup_ty `mkFunTy` new_res_ty) ]
+                             res_ty $ \ _ -> return ()
+
+       --------------- Typecheck the 'fmap' function -------------
+       ; fmap_op' <- case form of
+                       ThenForm -> return noExpr
+                       _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $
+                            mkInvForAllTy alphaTyVar $
+                            mkInvForAllTy betaTyVar  $
+                            (alphaTy `mkFunTy` betaTy)
+                            `mkFunTy` (n_app alphaTy)
+                            `mkFunTy` (n_app betaTy)
+
+       --------------- Typecheck the 'using' function -------------
+       -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
+
+       ; using' <- tcPolyExpr using using_poly_ty
+       ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
+
+       --------------- Bulding the bindersMap ----------------
+       ; let mk_n_bndr :: Name -> TcId -> TcId
+             mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))
+
+             -- Ensure that every old binder of type `b` is linked up with its
+             -- new binder which should have type `n b`
+             -- See Note [GroupStmt binder map] in HsExpr
+             n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
+             bindersMap' = bndr_ids `zip` n_bndr_ids
+
+       -- Type check the thing in the environment with
+       -- these new binders and return the result
+       ; thing <- tcExtendIdEnv n_bndr_ids $
+                  thing_inside (mkCheckExpType new_res_ty)
+
+       ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
+                           , trS_by = by', trS_using = final_using
+                           , trS_ret = return_op', trS_bind = bind_op'
+                           , trS_ext = n_app tup_ty
+                           , trS_fmap = fmap_op', trS_form = form }, thing) }
+
+-- A parallel set of comprehensions
+--      [ (g x, h x) | ... ; let g v = ...
+--                   | ... ; let h v = ... ]
+--
+-- It's possible that g,h are overloaded, so we need to feed the LIE from the
+-- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
+-- Similarly if we had an existential pattern match:
+--
+--      data T = forall a. Show a => C a
+--
+--      [ (show x, show y) | ... ; C x <- ...
+--                         | ... ; C y <- ... ]
+--
+-- Then we need the LIE from (show x, show y) to be simplified against
+-- the bindings for x and y.
+--
+-- It's difficult to do this in parallel, so we rely on the renamer to
+-- ensure that g,h and x,y don't duplicate, and simply grow the environment.
+-- So the binders of the first parallel group will be in scope in the second
+-- group.  But that's fine; there's no shadowing to worry about.
+--
+-- Note: The `mzip` function will get typechecked via:
+--
+--   ParStmt [st1::t1, st2::t2, st3::t3]
+--
+--   mzip :: m st1
+--        -> (m st2 -> m st3 -> m (st2, st3))   -- recursive call
+--        -> m (st1, (st2, st3))
+--
+tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside
+  = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind
+       ; m_ty   <- newFlexiTyVarTy star_star_kind
+
+       ; let mzip_ty  = mkInvForAllTys [alphaTyVar, betaTyVar] $
+                        (m_ty `mkAppTy` alphaTy)
+                        `mkFunTy`
+                        (m_ty `mkAppTy` betaTy)
+                        `mkFunTy`
+                        (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
+       ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
+
+        -- type dummies since we don't know all binder types yet
+       ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
+                       [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ]
+
+       -- Typecheck bind:
+       ; let tup_tys  = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]
+             tuple_ty = mk_tuple_ty tup_tys
+
+       ; (((blocks', thing), inner_res_ty), bind_op')
+           <- tcSyntaxOp MCompOrigin bind_op
+                         [ synKnownType (m_ty `mkAppTy` tuple_ty)
+                         , SynFun (synKnownType tuple_ty) SynRho ] res_ty $
+              \ [inner_res_ty] ->
+              do { stuff <- loop m_ty (mkCheckExpType inner_res_ty)
+                                 tup_tys bndr_stmts_s
+                 ; return (stuff, inner_res_ty) }
+
+       ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) }
+
+  where
+    mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
+
+       -- loop :: Type                                  -- m_ty
+       --      -> ExpRhoType                            -- inner_res_ty
+       --      -> [TcType]                              -- tup_tys
+       --      -> [ParStmtBlock Name]
+       --      -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)
+    loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty
+                                   ; return ([], thing) }
+                                   -- matching in the branches
+
+    loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)
+                           (ParStmtBlock x stmts names return_op : pairs)
+      = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in
+           ; (stmts', (ids, return_op', pairs', thing))
+                <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $
+                   \m_tup_ty' ->
+                   do { ids <- tcLookupLocalIds names
+                      ; let tup_ty = mkBigCoreVarTupTy ids
+                      ; (_, return_op') <-
+                          tcSyntaxOp MCompOrigin return_op
+                                     [synKnownType tup_ty] m_tup_ty' $
+                                     \ _ -> return ()
+                      ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs
+                      ; return (ids, return_op', pairs', thing) }
+           ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) }
+    loop _ _ _ _ = panic "tcMcStmt.loop"
+
+tcMcStmt _ stmt _ _
+  = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
+
+
+---------------------------------------------------
+--           Do-notation
+--        (supports rebindable syntax)
+---------------------------------------------------
+
+tcDoStmt :: TcExprStmtChecker
+
+tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside
+  = do { body' <- tcMonoExprNC body res_ty
+       ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
+       ; return (LastStmt x body' noret noSyntaxExpr, thing) }
+
+tcDoStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside
+  = do  {       -- Deal with rebindable syntax:
+                --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
+                -- This level of generality is needed for using do-notation
+                -- in full generality; see Trac #1537
+
+          ((rhs', pat', new_res_ty, thing), bind_op')
+            <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $
+                \ [rhs_ty, pat_ty, new_res_ty] ->
+                do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
+                   ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
+                                            (mkCheckExpType pat_ty) $
+                                      thing_inside (mkCheckExpType new_res_ty)
+                   ; return (rhs', pat', new_res_ty, thing) }
+
+        -- If (but only if) the pattern can fail, typecheck the 'fail' operator
+        ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty
+
+        ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }
+
+tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside
+  = do  { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
+                                thing_inside . mkCheckExpType
+        ; ((pairs', body_ty, thing), mb_join') <- case mb_join of
+            Nothing -> (, Nothing) <$> tc_app_stmts res_ty
+            Just join_op ->
+              second Just <$>
+              (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $
+               \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty))
+
+        ; return (ApplicativeStmt body_ty pairs' mb_join', thing) }
+
+tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside
+  = do  {       -- Deal with rebindable syntax;
+                --   (>>) :: rhs_ty -> new_res_ty -> res_ty
+        ; ((rhs', rhs_ty, thing), then_op')
+            <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $
+               \ [rhs_ty, new_res_ty] ->
+               do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
+                  ; thing <- thing_inside (mkCheckExpType new_res_ty)
+                  ; return (rhs', rhs_ty, thing) }
+        ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }
+
+tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
+                       , recS_rec_ids = rec_names, recS_ret_fn = ret_op
+                       , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
+         res_ty thing_inside
+  = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
+        ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
+        ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys
+              tup_ty  = mkBigCoreTupTy tup_elt_tys
+
+        ; tcExtendIdEnv tup_ids $ do
+        { ((stmts', (ret_op', tup_rets)), stmts_ty)
+                <- tcInferInst $ \ exp_ty ->
+                   tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty ->
+                   do { tup_rets <- zipWithM tcCheckId tup_names
+                                      (map mkCheckExpType tup_elt_tys)
+                             -- Unify the types of the "final" Ids (which may
+                             -- be polymorphic) with those of "knot-tied" Ids
+                      ; (_, ret_op')
+                          <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty]
+                                        inner_res_ty $ \_ -> return ()
+                      ; return (ret_op', tup_rets) }
+
+        ; ((_, mfix_op'), mfix_res_ty)
+            <- tcInferInst $ \ exp_ty ->
+               tcSyntaxOp DoOrigin mfix_op
+                          [synKnownType (mkFunTy tup_ty stmts_ty)] exp_ty $
+               \ _ -> return ()
+
+        ; ((thing, new_res_ty), bind_op')
+            <- tcSyntaxOp DoOrigin bind_op
+                          [ synKnownType mfix_res_ty
+                          , synKnownType tup_ty `SynFun` SynRho ]
+                          res_ty $
+               \ [new_res_ty] ->
+               do { thing <- thing_inside (mkCheckExpType new_res_ty)
+                  ; return (thing, new_res_ty) }
+
+        ; let rec_ids = takeList rec_names tup_ids
+        ; later_ids <- tcLookupLocalIds later_names
+        ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
+                                 ppr later_ids <+> ppr (map idType later_ids)]
+        ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
+                          , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
+                          , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
+                          , recS_ext = RecStmtTc
+                            { recS_bind_ty = new_res_ty
+                            , recS_later_rets = []
+                            , recS_rec_rets = tup_rets
+                            , recS_ret_ty = stmts_ty} }, thing)
+        }}
+
+tcDoStmt _ stmt _ _
+  = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
+
+
+
+---------------------------------------------------
+-- MonadFail Proposal warnings
+---------------------------------------------------
+
+-- The idea behind issuing MonadFail warnings is that we add them whenever a
+-- failable pattern is encountered. However, instead of throwing a type error
+-- when the constraint cannot be satisfied, we only issue a warning in
+-- TcErrors.hs.
+
+tcMonadFailOp :: CtOrigin
+              -> LPat GhcTcId
+              -> SyntaxExpr GhcRn    -- The fail op
+              -> TcType              -- Type of the whole do-expression
+              -> TcRn (SyntaxExpr GhcTcId)  -- Typechecked fail op
+-- Get a 'fail' operator expression, to use if the pattern
+-- match fails. If the pattern is irrefutatable, just return
+-- noSyntaxExpr; it won't be used
+tcMonadFailOp orig pat fail_op res_ty
+  | isIrrefutableHsPat pat
+  = return noSyntaxExpr
+
+  | otherwise
+  = snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
+                             (mkCheckExpType res_ty) $ \_ -> return ())
+
+{-
+Note [Treat rebindable syntax first]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When typechecking
+        do { bar; ... } :: IO ()
+we want to typecheck 'bar' in the knowledge that it should be an IO thing,
+pushing info from the context into the RHS.  To do this, we check the
+rebindable syntax first, and push that information into (tcMonoExprNC rhs).
+Otherwise the error shows up when checking the rebindable syntax, and
+the expected/inferred stuff is back to front (see Trac #3613).
+
+Note [typechecking ApplicativeStmt]
+
+join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en)
+
+fresh type variables:
+   pat_ty_1..pat_ty_n
+   exp_ty_1..exp_ty_n
+   t_1..t_(n-1)
+
+body  :: body_ty
+(\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty
+pat_i :: pat_ty_i
+e_i   :: exp_ty_i
+<$>   :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1
+<*>_i :: t_(i-1) -> exp_ty_i -> t_i
+join :: tn -> res_ty
+-}
+
+tcApplicativeStmts
+  :: HsStmtContext Name
+  -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
+  -> ExpRhoType                         -- rhs_ty
+  -> (TcRhoType -> TcM t)               -- thing_inside
+  -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t)
+
+tcApplicativeStmts ctxt pairs rhs_ty thing_inside
+ = do { body_ty <- newFlexiTyVarTy liftedTypeKind
+      ; let arity = length pairs
+      ; ts <- replicateM (arity-1) $ newInferExpTypeInst
+      ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
+      ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
+      ; let fun_ty = mkFunTys pat_tys body_ty
+
+       -- NB. do the <$>,<*> operators first, we don't want type errors here
+       --     i.e. goOps before goArgs
+       -- See Note [Treat rebindable syntax first]
+      ; let (ops, args) = unzip pairs
+      ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
+
+      -- Typecheck each ApplicativeArg separately
+      -- See Note [ApplicativeDo and constraints]
+      ; args' <- mapM goArg (zip3 args pat_tys exp_tys)
+
+      -- Bring into scope all the things bound by the args,
+      -- and typecheck the thing_inside
+      -- See Note [ApplicativeDo and constraints]
+      ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $
+               thing_inside body_ty
+
+      ; return (zip ops' args', body_ty, res) }
+  where
+    goOps _ [] = return []
+    goOps t_left ((op,t_i,exp_ty) : ops)
+      = do { (_, op')
+               <- tcSyntaxOp DoOrigin op
+                             [synKnownType t_left, synKnownType exp_ty] t_i $
+                   \ _ -> return ()
+           ; t_i <- readExpType t_i
+           ; ops' <- goOps t_i ops
+           ; return (op' : ops') }
+
+    goArg :: (ApplicativeArg GhcRn, Type, Type)
+          -> TcM (ApplicativeArg GhcTcId)
+
+    goArg (ApplicativeArgOne x pat rhs isBody, pat_ty, exp_ty)
+      = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
+        addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs))   $
+        do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)
+           ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
+                          return ()
+           ; return (ApplicativeArgOne x pat' rhs' isBody) }
+
+    goArg (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty)
+      = do { (stmts', (ret',pat')) <-
+                tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $
+                \res_ty  -> do
+                  { L _ ret' <- tcMonoExprNC (noLoc ret) res_ty
+                  ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
+                                 return ()
+                  ; return (ret', pat')
+                  }
+           ; return (ApplicativeArgMany x stmts' ret' pat') }
+
+    goArg (XApplicativeArg _, _, _) = panic "tcApplicativeStmts"
+
+    get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]
+    get_arg_bndrs (ApplicativeArgOne _ pat _ _)  = collectPatBinders pat
+    get_arg_bndrs (ApplicativeArgMany _ _ _ pat) = collectPatBinders pat
+    get_arg_bndrs (XApplicativeArg _)            = panic "tcApplicativeStmts"
+
+
+{- Note [ApplicativeDo and constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+An applicative-do is supposed to take place in parallel, so
+constraints bound in one arm can't possibly be available in another
+(Trac #13242).  Our current rule is this (more details and discussion
+on the ticket). Consider
+
+   ...stmts...
+   ApplicativeStmts [arg1, arg2, ... argN]
+   ...more stmts...
+
+where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts.
+Now, we say that:
+
+* Constraints required by the argi can be solved from
+  constraint bound by ...stmts...
+
+* Constraints and existentials bound by the argi are not available
+  to solve constraints required either by argj (where i /= j),
+  or by ...more stmts....
+
+* Within the stmts of each 'argi' individually, however, constraints bound
+  by earlier stmts can be used to solve later ones.
+
+To achieve this, we just typecheck each 'argi' separately, bring all
+the variables they bind into scope, and typecheck the thing_inside.
+
+************************************************************************
+*                                                                      *
+\subsection{Errors and contexts}
+*                                                                      *
+************************************************************************
+
+@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
+number of args are used in each equation.
+-}
+
+checkArgs :: Name -> MatchGroup GhcRn body -> TcM ()
+checkArgs _ (MG { mg_alts = L _ [] })
+    = return ()
+checkArgs fun (MG { mg_alts = L _ (match1:matches) })
+    | null bad_matches
+    = return ()
+    | otherwise
+    = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+>
+                         text "have different numbers of arguments"
+                       , nest 2 (ppr (getLoc match1))
+                       , nest 2 (ppr (getLoc (head bad_matches)))])
+  where
+    n_args1 = args_in_match match1
+    bad_matches = [m | m <- matches, args_in_match m /= n_args1]
+
+    args_in_match :: LMatch GhcRn body -> Int
+    args_in_match (L _ (Match { m_pats = pats })) = length pats
+    args_in_match (L _ (XMatch _)) = panic "checkArgs"
+checkArgs _ (XMatchGroup{}) = panic "checkArgs"
diff --git a/compiler/typecheck/TcMatches.hs-boot b/compiler/typecheck/TcMatches.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcMatches.hs-boot
@@ -0,0 +1,17 @@
+module TcMatches where
+import HsSyn    ( GRHSs, MatchGroup, LHsExpr )
+import TcEvidence( HsWrapper )
+import Name     ( Name )
+import TcType   ( ExpRhoType, TcRhoType )
+import TcRnTypes( TcM )
+import SrcLoc   ( Located )
+import HsExtension ( GhcRn, GhcTcId )
+
+tcGRHSsPat    :: GRHSs GhcRn (LHsExpr GhcRn)
+              -> TcRhoType
+              -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))
+
+tcMatchesFun :: Located Name
+             -> MatchGroup GhcRn (LHsExpr GhcRn)
+             -> ExpRhoType
+             -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcPat.hs
@@ -0,0 +1,1193 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+TcPat: Typechecking patterns
+-}
+
+{-# LANGUAGE CPP, RankNTypes, TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcPat ( tcLetPat, newLetBndr, LetBndrSpec(..)
+             , tcPat, tcPat_O, tcPats
+             , addDataConStupidTheta, badFieldCon, polyPatSig ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma )
+
+import HsSyn
+import TcHsSyn
+import TcSigs( TcPragEnv, lookupPragEnv, addInlinePrags )
+import TcRnMonad
+import Inst
+import Id
+import Var
+import Name
+import RdrName
+import TcEnv
+import TcMType
+import TcValidity( arityErr )
+import Type ( pprTyVars )
+import TcType
+import TcUnify
+import TcHsType
+import TysWiredIn
+import TcEvidence
+import TyCon
+import DataCon
+import PatSyn
+import ConLike
+import PrelNames
+import BasicTypes hiding (SuccessFlag(..))
+import DynFlags
+import SrcLoc
+import VarSet
+import Util
+import Outputable
+import qualified GHC.LanguageExtensions as LangExt
+import Control.Arrow  ( second )
+import ListSetOps ( getNth )
+
+{-
+************************************************************************
+*                                                                      *
+                External interface
+*                                                                      *
+************************************************************************
+-}
+
+tcLetPat :: (Name -> Maybe TcId)
+         -> LetBndrSpec
+         -> LPat GhcRn -> ExpSigmaType
+         -> TcM a
+         -> TcM (LPat GhcTcId, a)
+tcLetPat sig_fn no_gen pat pat_ty thing_inside
+  = do { bind_lvl <- getTcLevel
+       ; let ctxt = LetPat { pc_lvl    = bind_lvl
+                           , pc_sig_fn = sig_fn
+                           , pc_new    = no_gen }
+             penv = PE { pe_lazy = True
+                       , pe_ctxt = ctxt
+                       , pe_orig = PatOrigin }
+
+       ; tc_lpat pat pat_ty penv thing_inside }
+
+-----------------
+tcPats :: HsMatchContext Name
+       -> [LPat GhcRn]            -- Patterns,
+       -> [ExpSigmaType]         --   and their types
+       -> TcM a                  --   and the checker for the body
+       -> TcM ([LPat GhcTcId], a)
+
+-- This is the externally-callable wrapper function
+-- Typecheck the patterns, extend the environment to bind the variables,
+-- do the thing inside, use any existentially-bound dictionaries to
+-- discharge parts of the returning LIE, and deal with pattern type
+-- signatures
+
+--   1. Initialise the PatState
+--   2. Check the patterns
+--   3. Check the body
+--   4. Check that no existentials escape
+
+tcPats ctxt pats pat_tys thing_inside
+  = tc_lpats penv pats pat_tys thing_inside
+  where
+    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
+
+tcPat :: HsMatchContext Name
+      -> LPat GhcRn -> ExpSigmaType
+      -> TcM a                     -- Checker for body
+      -> TcM (LPat GhcTcId, a)
+tcPat ctxt = tcPat_O ctxt PatOrigin
+
+-- | A variant of 'tcPat' that takes a custom origin
+tcPat_O :: HsMatchContext Name
+        -> CtOrigin              -- ^ origin to use if the type needs inst'ing
+        -> LPat GhcRn -> ExpSigmaType
+        -> TcM a                 -- Checker for body
+        -> TcM (LPat GhcTcId, a)
+tcPat_O ctxt orig pat pat_ty thing_inside
+  = tc_lpat pat pat_ty penv thing_inside
+  where
+    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig }
+
+
+{-
+************************************************************************
+*                                                                      *
+                PatEnv, PatCtxt, LetBndrSpec
+*                                                                      *
+************************************************************************
+-}
+
+data PatEnv
+  = PE { pe_lazy :: Bool        -- True <=> lazy context, so no existentials allowed
+       , pe_ctxt :: PatCtxt     -- Context in which the whole pattern appears
+       , pe_orig :: CtOrigin    -- origin to use if the pat_ty needs inst'ing
+       }
+
+data PatCtxt
+  = LamPat   -- Used for lambdas, case etc
+       (HsMatchContext Name)
+
+  | LetPat   -- Used only for let(rec) pattern bindings
+             -- See Note [Typing patterns in pattern bindings]
+       { pc_lvl    :: TcLevel
+                   -- Level of the binding group
+
+       , pc_sig_fn :: Name -> Maybe TcId
+                   -- Tells the expected type
+                   -- for binders with a signature
+
+       , pc_new :: LetBndrSpec
+                -- How to make a new binder
+       }        -- for binders without signatures
+
+data LetBndrSpec
+  = LetLclBndr            -- We are going to generalise, and wrap in an AbsBinds
+                          -- so clone a fresh binder for the local monomorphic Id
+
+  | LetGblBndr TcPragEnv  -- Generalisation plan is NoGen, so there isn't going
+                          -- to be an AbsBinds; So we must bind the global version
+                          -- of the binder right away.
+                          -- And here is the inline-pragma information
+
+instance Outputable LetBndrSpec where
+  ppr LetLclBndr      = text "LetLclBndr"
+  ppr (LetGblBndr {}) = text "LetGblBndr"
+
+makeLazy :: PatEnv -> PatEnv
+makeLazy penv = penv { pe_lazy = True }
+
+inPatBind :: PatEnv -> Bool
+inPatBind (PE { pe_ctxt = LetPat {} }) = True
+inPatBind (PE { pe_ctxt = LamPat {} }) = False
+
+{- *********************************************************************
+*                                                                      *
+                Binders
+*                                                                      *
+********************************************************************* -}
+
+tcPatBndr :: PatEnv -> Name -> ExpSigmaType -> TcM (HsWrapper, TcId)
+-- (coi, xp) = tcPatBndr penv x pat_ty
+-- Then coi : pat_ty ~ typeof(xp)
+--
+tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl    = bind_lvl
+                                      , pc_sig_fn = sig_fn
+                                      , pc_new    = no_gen } })
+          bndr_name exp_pat_ty
+  -- For the LetPat cases, see
+  -- Note [Typechecking pattern bindings] in TcBinds
+
+  | Just bndr_id <- sig_fn bndr_name   -- There is a signature
+  = do { wrap <- tcSubTypePat penv exp_pat_ty (idType bndr_id)
+           -- See Note [Subsumption check at pattern variables]
+       ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty)
+       ; return (wrap, bndr_id) }
+
+  | otherwise                          -- No signature
+  = do { (co, bndr_ty) <- case exp_pat_ty of
+             Check pat_ty    -> promoteTcType bind_lvl pat_ty
+             Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res )
+                                -- If we were under a constructor that bumped
+                                -- the level, we'd be in checking mode
+                                do { bndr_ty <- inferResultToType infer_res
+                                   ; return (mkTcNomReflCo bndr_ty, bndr_ty) }
+       ; bndr_id <- newLetBndr no_gen bndr_name bndr_ty
+       ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl
+                                          , ppr exp_pat_ty, ppr bndr_ty, ppr co
+                                          , ppr bndr_id ])
+       ; return (mkWpCastN co, bndr_id) }
+
+tcPatBndr _ bndr_name pat_ty
+  = do { pat_ty <- expTypeToType pat_ty
+       ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty)
+       ; return (idHsWrapper, mkLocalId bndr_name pat_ty) }
+               -- Whether or not there is a sig is irrelevant,
+               -- as this is local
+
+newLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId
+-- Make up a suitable Id for the pattern-binder.
+-- See Note [Typechecking pattern bindings], item (4) in TcBinds
+--
+-- In the polymorphic case when we are going to generalise
+--    (plan InferGen, no_gen = LetLclBndr), generate a "monomorphic version"
+--    of the Id; the original name will be bound to the polymorphic version
+--    by the AbsBinds
+-- In the monomorphic case when we are not going to generalise
+--    (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds,
+--    and we use the original name directly
+newLetBndr LetLclBndr name ty
+  = do { mono_name <- cloneLocalName name
+       ; return (mkLocalId mono_name ty) }
+newLetBndr (LetGblBndr prags) name ty
+  = addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name)
+
+tcSubTypePat :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
+-- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt
+-- Used when typechecking patterns
+tcSubTypePat penv t1 t2 = tcSubTypeET (pe_orig penv) GenSigCtxt t1 t2
+
+{- Note [Subsumption check at pattern variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we come across a variable with a type signature, we need to do a
+subsumption, not equality, check against the context type.  e.g.
+
+    data T = MkT (forall a. a->a)
+      f :: forall b. [b]->[b]
+      MkT f = blah
+
+Since 'blah' returns a value of type T, its payload is a polymorphic
+function of type (forall a. a->a).  And that's enough to bind the
+less-polymorphic function 'f', but we need some impedance matching
+to witness the instantiation.
+
+
+************************************************************************
+*                                                                      *
+                The main worker functions
+*                                                                      *
+************************************************************************
+
+Note [Nesting]
+~~~~~~~~~~~~~~
+tcPat takes a "thing inside" over which the pattern scopes.  This is partly
+so that tcPat can extend the environment for the thing_inside, but also
+so that constraints arising in the thing_inside can be discharged by the
+pattern.
+
+This does not work so well for the ErrCtxt carried by the monad: we don't
+want the error-context for the pattern to scope over the RHS.
+Hence the getErrCtxt/setErrCtxt stuff in tcMultiple
+-}
+
+--------------------
+type Checker inp out =  forall r.
+                          inp
+                       -> PatEnv
+                       -> TcM r
+                       -> TcM (out, r)
+
+tcMultiple :: Checker inp out -> Checker [inp] [out]
+tcMultiple tc_pat args penv thing_inside
+  = do  { err_ctxt <- getErrCtxt
+        ; let loop _ []
+                = do { res <- thing_inside
+                     ; return ([], res) }
+
+              loop penv (arg:args)
+                = do { (p', (ps', res))
+                                <- tc_pat arg penv $
+                                   setErrCtxt err_ctxt $
+                                   loop penv args
+                -- setErrCtxt: restore context before doing the next pattern
+                -- See note [Nesting] above
+
+                     ; return (p':ps', res) }
+
+        ; loop penv args }
+
+--------------------
+tc_lpat :: LPat GhcRn
+        -> ExpSigmaType
+        -> PatEnv
+        -> TcM a
+        -> TcM (LPat GhcTcId, a)
+tc_lpat (dL->L span pat) pat_ty penv thing_inside
+  = setSrcSpan span $
+    do  { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty)
+                                          thing_inside
+        ; return (cL span pat', res) }
+
+tc_lpats :: PatEnv
+         -> [LPat GhcRn] -> [ExpSigmaType]
+         -> TcM a
+         -> TcM ([LPat GhcTcId], a)
+tc_lpats penv pats tys thing_inside
+  = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys )
+    tcMultiple (\(p,t) -> tc_lpat p t)
+                (zipEqual "tc_lpats" pats tys)
+                penv thing_inside
+
+--------------------
+tc_pat  :: PatEnv
+        -> Pat GhcRn
+        -> ExpSigmaType  -- Fully refined result type
+        -> TcM a                -- Thing inside
+        -> TcM (Pat GhcTcId,    -- Translated pattern
+                a)              -- Result of thing inside
+
+tc_pat penv (VarPat x (dL->L l name)) pat_ty thing_inside
+  = do  { (wrap, id) <- tcPatBndr penv name pat_ty
+        ; res <- tcExtendIdEnv1 name id thing_inside
+        ; pat_ty <- readExpType pat_ty
+        ; return (mkHsWrapPat wrap (VarPat x (cL l id)) pat_ty, res) }
+
+tc_pat penv (ParPat x pat) pat_ty thing_inside
+  = do  { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
+        ; return (ParPat x pat', res) }
+
+tc_pat penv (BangPat x pat) pat_ty thing_inside
+  = do  { (pat', res) <- tc_lpat pat pat_ty penv thing_inside
+        ; return (BangPat x pat', res) }
+
+tc_pat penv (LazyPat x pat) pat_ty thing_inside
+  = do  { (pat', (res, pat_ct))
+                <- tc_lpat pat pat_ty (makeLazy penv) $
+                   captureConstraints thing_inside
+                -- Ignore refined penv', revert to penv
+
+        ; emitConstraints pat_ct
+        -- captureConstraints/extendConstraints:
+        --   see Note [Hopping the LIE in lazy patterns]
+
+        -- Check that the expected pattern type is itself lifted
+        ; pat_ty <- readExpType pat_ty
+        ; _ <- unifyType Nothing (tcTypeKind pat_ty) liftedTypeKind
+
+        ; return (LazyPat x pat', res) }
+
+tc_pat _ (WildPat _) pat_ty thing_inside
+  = do  { res <- thing_inside
+        ; pat_ty <- expTypeToType pat_ty
+        ; return (WildPat pat_ty, res) }
+
+tc_pat penv (AsPat x (dL->L nm_loc name) pat) pat_ty thing_inside
+  = do  { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)
+        ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
+                         tc_lpat pat (mkCheckExpType $ idType bndr_id)
+                                 penv thing_inside
+            -- NB: if we do inference on:
+            --          \ (y@(x::forall a. a->a)) = e
+            -- we'll fail.  The as-pattern infers a monotype for 'y', which then
+            -- fails to unify with the polymorphic type for 'x'.  This could
+            -- perhaps be fixed, but only with a bit more work.
+            --
+            -- If you fix it, don't forget the bindInstsOfPatIds!
+        ; pat_ty <- readExpType pat_ty
+        ; return (mkHsWrapPat wrap (AsPat x (cL nm_loc bndr_id) pat') pat_ty,
+                  res) }
+
+tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside
+  = do  {
+         -- Expr must have type `forall a1...aN. OPT' -> B`
+         -- where overall_pat_ty is an instance of OPT'.
+        ; (expr',expr'_inferred) <- tcInferSigma expr
+
+         -- expression must be a function
+        ; let expr_orig = lexprCtOrigin expr
+              herald    = text "A view pattern expression expects"
+        ; (expr_wrap1, [inf_arg_ty], inf_res_ty)
+            <- matchActualFunTys herald expr_orig (Just (unLoc expr)) 1 expr'_inferred
+            -- expr_wrap1 :: expr'_inferred "->" (inf_arg_ty -> inf_res_ty)
+
+         -- check that overall pattern is more polymorphic than arg type
+        ; expr_wrap2 <- tcSubTypePat penv overall_pat_ty inf_arg_ty
+            -- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty
+
+         -- pattern must have inf_res_ty
+        ; (pat', res) <- tc_lpat pat (mkCheckExpType inf_res_ty) penv thing_inside
+
+        ; overall_pat_ty <- readExpType overall_pat_ty
+        ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
+                                    overall_pat_ty inf_res_ty doc
+               -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->"
+               --                (overall_pat_ty -> inf_res_ty)
+              expr_wrap = expr_wrap2' <.> expr_wrap1
+              doc = text "When checking the view pattern function:" <+> (ppr expr)
+        ; return (ViewPat overall_pat_ty (mkLHsWrap expr_wrap expr') pat', res)}
+
+-- Type signatures in patterns
+-- See Note [Pattern coercions] below
+tc_pat penv (SigPat _ pat sig_ty) pat_ty thing_inside
+  = do  { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)
+                                                            sig_ty pat_ty
+                -- Using tcExtendNameTyVarEnv is appropriate here
+                -- because we're not really bringing fresh tyvars into scope.
+                -- We're *naming* existing tyvars. Note that it is OK for a tyvar
+                -- from an outer scope to mention one of these tyvars in its kind.
+        ; (pat', res) <- tcExtendNameTyVarEnv wcs      $
+                         tcExtendNameTyVarEnv tv_binds $
+                         tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside
+        ; pat_ty <- readExpType pat_ty
+        ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }
+
+------------------------
+-- Lists, tuples, arrays
+tc_pat penv (ListPat Nothing pats) pat_ty thing_inside
+  = do  { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty
+        ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
+                                     pats penv thing_inside
+        ; pat_ty <- readExpType pat_ty
+        ; return (mkHsWrapPat coi
+                         (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res)
+}
+
+tc_pat penv (ListPat (Just e) pats) pat_ty thing_inside
+  = do  { tau_pat_ty <- expTypeToType pat_ty
+        ; ((pats', res, elt_ty), e')
+            <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)]
+                                          SynList $
+                 \ [elt_ty] ->
+                 do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
+                                                 pats penv thing_inside
+                    ; return (pats', res, elt_ty) }
+        ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res)
+}
+
+tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside
+  = do  { let arity = length pats
+              tc = tupleTyCon boxity arity
+        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
+                                               penv pat_ty
+                     -- Unboxed tuples have RuntimeRep vars, which we discard:
+                     -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+        ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
+                                           Boxed   -> arg_tys
+        ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys)
+                                   thing_inside
+
+        ; dflags <- getDynFlags
+
+        -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
+        -- so that we can experiment with lazy tuple-matching.
+        -- This is a pretty odd place to make the switch, but
+        -- it was easy to do.
+        ; let
+              unmangled_result = TuplePat con_arg_tys pats' boxity
+                                 -- pat_ty /= pat_ty iff coi /= IdCo
+              possibly_mangled_result
+                | gopt Opt_IrrefutableTuples dflags &&
+                  isBoxed boxity      = LazyPat noExt (noLoc unmangled_result)
+                | otherwise           = unmangled_result
+
+        ; pat_ty <- readExpType pat_ty
+        ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced
+          return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
+        }
+
+tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside
+  = do  { let tc = sumTyCon arity
+        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
+                                               penv pat_ty
+        ; -- Drop levity vars, we don't care about them here
+          let con_arg_tys = drop arity arg_tys
+        ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1)))
+                                 penv thing_inside
+        ; pat_ty <- readExpType pat_ty
+        ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty
+                 , res)
+        }
+
+------------------------
+-- Data constructors
+tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside
+  = tcConPat penv con pat_ty arg_pats thing_inside
+
+------------------------
+-- Literal patterns
+tc_pat penv (LitPat x simple_lit) pat_ty thing_inside
+  = do  { let lit_ty = hsLitType simple_lit
+        ; wrap   <- tcSubTypePat penv pat_ty lit_ty
+        ; res    <- thing_inside
+        ; pat_ty <- readExpType pat_ty
+        ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty
+                 , res) }
+
+------------------------
+-- Overloaded patterns: n, and n+k
+
+-- In the case of a negative literal (the more complicated case),
+-- we get
+--
+--   case v of (-5) -> blah
+--
+-- becoming
+--
+--   if v == (negate (fromInteger 5)) then blah else ...
+--
+-- There are two bits of rebindable syntax:
+--   (==)   :: pat_ty -> neg_lit_ty -> Bool
+--   negate :: lit_ty -> neg_lit_ty
+-- where lit_ty is the type of the overloaded literal 5.
+--
+-- When there is no negation, neg_lit_ty and lit_ty are the same
+tc_pat _ (NPat _ (dL->L l over_lit) mb_neg eq) pat_ty thing_inside
+  = do  { let orig = LiteralOrigin over_lit
+        ; ((lit', mb_neg'), eq')
+            <- tcSyntaxOp orig eq [SynType pat_ty, SynAny]
+                          (mkCheckExpType boolTy) $
+               \ [neg_lit_ty] ->
+               let new_over_lit lit_ty = newOverloadedLit over_lit
+                                           (mkCheckExpType lit_ty)
+               in case mb_neg of
+                 Nothing  -> (, Nothing) <$> new_over_lit neg_lit_ty
+                 Just neg -> -- Negative literal
+                             -- The 'negate' is re-mappable syntax
+                   second Just <$>
+                   (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
+                    \ [lit_ty] -> new_over_lit lit_ty)
+
+        ; res <- thing_inside
+        ; pat_ty <- readExpType pat_ty
+        ; return (NPat pat_ty (cL l lit') mb_neg' eq', res) }
+
+{-
+Note [NPlusK patterns]
+~~~~~~~~~~~~~~~~~~~~~~
+From
+
+  case v of x + 5 -> blah
+
+we get
+
+  if v >= 5 then (\x -> blah) (v - 5) else ...
+
+There are two bits of rebindable syntax:
+  (>=) :: pat_ty -> lit1_ty -> Bool
+  (-)  :: pat_ty -> lit2_ty -> var_ty
+
+lit1_ty and lit2_ty could conceivably be different.
+var_ty is the type inferred for x, the variable in the pattern.
+
+If the pushed-down pattern type isn't a tau-type, the two pat_ty's above
+could conceivably be different specializations. But this is very much
+like the situation in Note [Case branches must be taus] in TcMatches.
+So we tauify the pat_ty before proceeding.
+
+Note that we need to type-check the literal twice, because it is used
+twice, and may be used at different types. The second HsOverLit stored in the
+AST is used for the subtraction operation.
+-}
+
+-- See Note [NPlusK patterns]
+tc_pat penv (NPlusKPat _ (dL->L nm_loc name)
+               (dL->L loc lit) _ ge minus) pat_ty
+              thing_inside
+  = do  { pat_ty <- expTypeToType pat_ty
+        ; let orig = LiteralOrigin lit
+        ; (lit1', ge')
+            <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho]
+                                  (mkCheckExpType boolTy) $
+               \ [lit1_ty] ->
+               newOverloadedLit lit (mkCheckExpType lit1_ty)
+        ; ((lit2', minus_wrap, bndr_id), minus')
+            <- tcSyntaxOpGen orig minus [synKnownType pat_ty, SynRho] SynAny $
+               \ [lit2_ty, var_ty] ->
+               do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
+                  ; (wrap, bndr_id) <- setSrcSpan nm_loc $
+                                     tcPatBndr penv name (mkCheckExpType var_ty)
+                           -- co :: var_ty ~ idType bndr_id
+
+                           -- minus_wrap is applicable to minus'
+                  ; return (lit2', wrap, bndr_id) }
+
+        -- The Report says that n+k patterns must be in Integral
+        -- but it's silly to insist on this in the RebindableSyntax case
+        ; unlessM (xoptM LangExt.RebindableSyntax) $
+          do { icls <- tcLookupClass integralClassName
+             ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
+
+        ; res <- tcExtendIdEnv1 name bndr_id thing_inside
+
+        ; let minus'' = minus' { syn_res_wrap =
+                                    minus_wrap <.> syn_res_wrap minus' }
+              pat' = NPlusKPat pat_ty (cL nm_loc bndr_id) (cL loc lit1') lit2'
+                               ge' minus''
+        ; return (pat', res) }
+
+-- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'.
+-- Here we get rid of it and add the finalizers to the global environment.
+--
+-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
+tc_pat penv (SplicePat _ (HsSpliced _ mod_finalizers (HsSplicedPat pat)))
+            pat_ty thing_inside
+  = do addModFinalizersWithLclEnv mod_finalizers
+       tc_pat penv pat pat_ty thing_inside
+
+tc_pat _ _other_pat _ _ = panic "tc_pat"        -- ConPatOut, SigPatOut
+
+
+{-
+Note [Hopping the LIE in lazy patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a lazy pattern, we must *not* discharge constraints from the RHS
+from dictionaries bound in the pattern.  E.g.
+        f ~(C x) = 3
+We can't discharge the Num constraint from dictionaries bound by
+the pattern C!
+
+So we have to make the constraints from thing_inside "hop around"
+the pattern.  Hence the captureConstraints and emitConstraints.
+
+The same thing ensures that equality constraints in a lazy match
+are not made available in the RHS of the match. For example
+        data T a where { T1 :: Int -> T Int; ... }
+        f :: T a -> Int -> a
+        f ~(T1 i) y = y
+It's obviously not sound to refine a to Int in the right
+hand side, because the argument might not match T1 at all!
+
+Finally, a lazy pattern should not bind any existential type variables
+because they won't be in scope when we do the desugaring
+
+
+************************************************************************
+*                                                                      *
+        Most of the work for constructors is here
+        (the rest is in the ConPatIn case of tc_pat)
+*                                                                      *
+************************************************************************
+
+[Pattern matching indexed data types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following declarations:
+
+  data family Map k :: * -> *
+  data instance Map (a, b) v = MapPair (Map a (Pair b v))
+
+and a case expression
+
+  case x :: Map (Int, c) w of MapPair m -> ...
+
+As explained by [Wrappers for data instance tycons] in MkIds.hs, the
+worker/wrapper types for MapPair are
+
+  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
+  $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
+
+So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is
+:R123Map, which means the straight use of boxySplitTyConApp would give a type
+error.  Hence, the smart wrapper function boxySplitTyConAppWithFamily calls
+boxySplitTyConApp with the family tycon Map instead, which gives us the family
+type list {(Int, c), w}.  To get the correct split for :R123Map, we need to
+unify the family type list {(Int, c), w} with the instance types {(a, b), v}
+(provided by tyConFamInst_maybe together with the family tycon).  This
+unification yields the substitution [a -> Int, b -> c, v -> w], which gives us
+the split arguments for the representation tycon :R123Map as {Int, c, w}
+
+In other words, boxySplitTyConAppWithFamily implicitly takes the coercion
+
+  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}
+
+moving between representation and family type into account.  To produce type
+correct Core, this coercion needs to be used to case the type of the scrutinee
+from the family to the representation type.  This is achieved by
+unwrapFamInstScrutinee using a CoPat around the result pattern.
+
+Now it might appear seem as if we could have used the previous GADT type
+refinement infrastructure of refineAlt and friends instead of the explicit
+unification and CoPat generation.  However, that would be wrong.  Why?  The
+whole point of GADT refinement is that the refinement is local to the case
+alternative.  In contrast, the substitution generated by the unification of
+the family type list and instance types needs to be propagated to the outside.
+Imagine that in the above example, the type of the scrutinee would have been
+(Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the
+substitution [x -> (a, b), v -> w].  In contrast to GADT matching, the
+instantiation of x with (a, b) must be global; ie, it must be valid in *all*
+alternatives of the case expression, whereas in the GADT case it might vary
+between alternatives.
+
+RIP GADT refinement: refinements have been replaced by the use of explicit
+equality constraints that are used in conjunction with implication constraints
+to express the local scope of GADT refinements.
+-}
+
+--      Running example:
+-- MkT :: forall a b c. (a~[b]) => b -> c -> T a
+--       with scrutinee of type (T ty)
+
+tcConPat :: PatEnv -> Located Name
+         -> ExpSigmaType           -- Type of the pattern
+         -> HsConPatDetails GhcRn -> TcM a
+         -> TcM (Pat GhcTcId, a)
+tcConPat penv con_lname@(dL->L _ con_name) pat_ty arg_pats thing_inside
+  = do  { con_like <- tcLookupConLike con_name
+        ; case con_like of
+            RealDataCon data_con -> tcDataConPat penv con_lname data_con
+                                                 pat_ty arg_pats thing_inside
+            PatSynCon pat_syn -> tcPatSynPat penv con_lname pat_syn
+                                             pat_ty arg_pats thing_inside
+        }
+
+tcDataConPat :: PatEnv -> Located Name -> DataCon
+             -> ExpSigmaType               -- Type of the pattern
+             -> HsConPatDetails GhcRn -> TcM a
+             -> TcM (Pat GhcTcId, a)
+tcDataConPat penv (dL->L con_span con_name) data_con pat_ty
+             arg_pats thing_inside
+  = do  { let tycon = dataConTyCon data_con
+                  -- For data families this is the representation tycon
+              (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
+                = dataConFullSig data_con
+              header = cL con_span (RealDataCon data_con)
+
+          -- Instantiate the constructor type variables [a->ty]
+          -- This may involve doing a family-instance coercion,
+          -- and building a wrapper
+        ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty
+        ; pat_ty <- readExpType pat_ty
+
+          -- Add the stupid theta
+        ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys
+
+        ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ arg_tys
+        ; checkExistentials ex_tvs all_arg_tys penv
+
+        ; tenv <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys
+                  -- NB: Do not use zipTvSubst!  See Trac #14154
+                  -- We want to create a well-kinded substitution, so
+                  -- that the instantiated type is well-kinded
+
+        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv ex_tvs
+                     -- Get location from monad, not from ex_tvs
+
+        ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys
+              -- pat_ty' is type of the actual constructor application
+              -- pat_ty' /= pat_ty iff coi /= IdCo
+
+              arg_tys' = substTys tenv arg_tys
+
+        ; traceTc "tcConPat" (vcat [ ppr con_name
+                                   , pprTyVars univ_tvs
+                                   , pprTyVars ex_tvs
+                                   , ppr eq_spec
+                                   , ppr theta
+                                   , pprTyVars ex_tvs'
+                                   , ppr ctxt_res_tys
+                                   , ppr arg_tys'
+                                   , ppr arg_pats ])
+        ; if null ex_tvs && null eq_spec && null theta
+          then do { -- The common case; no class bindings etc
+                    -- (see Note [Arrows and patterns])
+                    (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys'
+                                                  arg_pats penv thing_inside
+                  ; let res_pat = ConPatOut { pat_con = header,
+                                              pat_tvs = [], pat_dicts = [],
+                                              pat_binds = emptyTcEvBinds,
+                                              pat_args = arg_pats',
+                                              pat_arg_tys = ctxt_res_tys,
+                                              pat_wrap = idHsWrapper }
+
+                  ; return (mkHsWrapPat wrap res_pat pat_ty, res) }
+
+          else do   -- The general case, with existential,
+                    -- and local equality constraints
+        { let theta'     = substTheta tenv (eqSpecPreds eq_spec ++ theta)
+                           -- order is *important* as we generate the list of
+                           -- dictionary binders from theta'
+              no_equalities = not (any isNomEqPred theta')
+              skol_info = PatSkol (RealDataCon data_con) mc
+              mc = case pe_ctxt penv of
+                     LamPat mc -> mc
+                     LetPat {} -> PatBindRhs
+
+        ; gadts_on    <- xoptM LangExt.GADTs
+        ; families_on <- xoptM LangExt.TypeFamilies
+        ; checkTc (no_equalities || gadts_on || families_on)
+                  (text "A pattern match on a GADT requires the" <+>
+                   text "GADTs or TypeFamilies language extension")
+                  -- Trac #2905 decided that a *pattern-match* of a GADT
+                  -- should require the GADT language flag.
+                  -- Re TypeFamilies see also #7156
+
+        ; given <- newEvVars theta'
+        ; (ev_binds, (arg_pats', res))
+             <- checkConstraints skol_info ex_tvs' given $
+                tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside
+
+        ; let res_pat = ConPatOut { pat_con   = header,
+                                    pat_tvs   = ex_tvs',
+                                    pat_dicts = given,
+                                    pat_binds = ev_binds,
+                                    pat_args  = arg_pats',
+                                    pat_arg_tys = ctxt_res_tys,
+                                    pat_wrap  = idHsWrapper }
+        ; return (mkHsWrapPat wrap res_pat pat_ty, res)
+        } }
+
+tcPatSynPat :: PatEnv -> Located Name -> PatSyn
+            -> ExpSigmaType                -- Type of the pattern
+            -> HsConPatDetails GhcRn -> TcM a
+            -> TcM (Pat GhcTcId, a)
+tcPatSynPat penv (dL->L con_span _) pat_syn pat_ty arg_pats thing_inside
+  = do  { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn
+
+        ; (subst, univ_tvs') <- newMetaTyVars univ_tvs
+
+        ; let all_arg_tys = ty : prov_theta ++ arg_tys
+        ; checkExistentials ex_tvs all_arg_tys penv
+        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs
+        ; let ty'         = substTy tenv ty
+              arg_tys'    = substTys tenv arg_tys
+              prov_theta' = substTheta tenv prov_theta
+              req_theta'  = substTheta tenv req_theta
+
+        ; wrap <- tcSubTypePat penv pat_ty ty'
+        ; traceTc "tcPatSynPat" (ppr pat_syn $$
+                                 ppr pat_ty $$
+                                 ppr ty' $$
+                                 ppr ex_tvs' $$
+                                 ppr prov_theta' $$
+                                 ppr req_theta' $$
+                                 ppr arg_tys')
+
+        ; prov_dicts' <- newEvVars prov_theta'
+
+        ; let skol_info = case pe_ctxt penv of
+                            LamPat mc -> PatSkol (PatSynCon pat_syn) mc
+                            LetPat {} -> UnkSkol -- Doesn't matter
+
+        ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta'
+        ; traceTc "instCall" (ppr req_wrap)
+
+        ; traceTc "checkConstraints {" Outputable.empty
+        ; (ev_binds, (arg_pats', res))
+             <- checkConstraints skol_info ex_tvs' prov_dicts' $
+                tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside
+
+        ; traceTc "checkConstraints }" (ppr ev_binds)
+        ; let res_pat = ConPatOut { pat_con   = cL con_span $ PatSynCon pat_syn,
+                                    pat_tvs   = ex_tvs',
+                                    pat_dicts = prov_dicts',
+                                    pat_binds = ev_binds,
+                                    pat_args  = arg_pats',
+                                    pat_arg_tys = mkTyVarTys univ_tvs',
+                                    pat_wrap  = req_wrap }
+        ; pat_ty <- readExpType pat_ty
+        ; return (mkHsWrapPat wrap res_pat pat_ty, res) }
+
+----------------------------
+-- | Convenient wrapper for calling a matchExpectedXXX function
+matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a))
+                    -> PatEnv -> ExpSigmaType -> TcM (HsWrapper, a)
+-- See Note [Matching polytyped patterns]
+-- Returns a wrapper : pat_ty ~R inner_ty
+matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty
+  = do { pat_ty <- expTypeToType pat_ty
+       ; (wrap, pat_rho) <- topInstantiate orig pat_ty
+       ; (co, res) <- inner_match pat_rho
+       ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap)
+       ; return (mkWpCastN (mkTcSymCo co) <.> wrap, res) }
+
+----------------------------
+matchExpectedConTy :: PatEnv
+                   -> TyCon      -- The TyCon that this data
+                                 -- constructor actually returns
+                                 -- In the case of a data family this is
+                                 -- the /representation/ TyCon
+                   -> ExpSigmaType  -- The type of the pattern; in the case
+                                    -- of a data family this would mention
+                                    -- the /family/ TyCon
+                   -> TcM (HsWrapper, [TcSigmaType])
+-- See Note [Matching constructor patterns]
+-- Returns a wrapper : pat_ty "->" T ty1 ... tyn
+matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty
+  | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc
+         -- Comments refer to Note [Matching constructor patterns]
+         -- co_tc :: forall a. T [a] ~ T7 a
+  = do { pat_ty <- expTypeToType exp_pat_ty
+       ; (wrap, pat_rho) <- topInstantiate orig pat_ty
+
+       ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc)
+             -- tys = [ty1,ty2]
+
+       ; traceTc "matchExpectedConTy" (vcat [ppr data_tc,
+                                             ppr (tyConTyVars data_tc),
+                                             ppr fam_tc, ppr fam_args,
+                                             ppr exp_pat_ty,
+                                             ppr pat_ty,
+                                             ppr pat_rho, ppr wrap])
+       ; co1 <- unifyType Nothing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho
+             -- co1 : T (ty1,ty2) ~N pat_rho
+             -- could use tcSubType here... but it's the wrong way round
+             -- for actual vs. expected in error messages.
+
+       ; let tys' = mkTyVarTys tvs'
+             co2 = mkTcUnbranchedAxInstCo co_tc tys' []
+             -- co2 : T (ty1,ty2) ~R T7 ty1 ty2
+
+             full_co = mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2
+             -- full_co :: pat_rho ~R T7 ty1 ty2
+
+       ; return ( mkWpCastR full_co <.> wrap, tys') }
+
+  | otherwise
+  = do { pat_ty <- expTypeToType exp_pat_ty
+       ; (wrap, pat_rho) <- topInstantiate orig pat_ty
+       ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho
+       ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) }
+
+{-
+Note [Matching constructor patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose (coi, tys) = matchExpectedConType data_tc pat_ty
+
+ * In the simple case, pat_ty = tc tys
+
+ * If pat_ty is a polytype, we want to instantiate it
+   This is like part of a subsumption check.  Eg
+      f :: (forall a. [a]) -> blah
+      f [] = blah
+
+ * In a type family case, suppose we have
+          data family T a
+          data instance T (p,q) = A p | B q
+       Then we'll have internally generated
+              data T7 p q = A p | B q
+              axiom coT7 p q :: T (p,q) ~ T7 p q
+
+       So if pat_ty = T (ty1,ty2), we return (coi, [ty1,ty2]) such that
+           coi = coi2 . coi1 : T7 t ~ pat_ty
+           coi1 : T (ty1,ty2) ~ pat_ty
+           coi2 : T7 ty1 ty2 ~ T (ty1,ty2)
+
+   For families we do all this matching here, not in the unifier,
+   because we never want a whisper of the data_tycon to appear in
+   error messages; it's a purely internal thing
+-}
+
+tcConArgs :: ConLike -> [TcSigmaType]
+          -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc)
+
+tcConArgs con_like arg_tys (PrefixCon arg_pats) penv thing_inside
+  = do  { checkTc (con_arity == no_of_args)     -- Check correct arity
+                  (arityErr (text "constructor") con_like con_arity no_of_args)
+        ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys
+        ; (arg_pats', res) <- tcMultiple tcConArg pats_w_tys
+                                              penv thing_inside
+        ; return (PrefixCon arg_pats', res) }
+  where
+    con_arity  = conLikeArity con_like
+    no_of_args = length arg_pats
+
+tcConArgs con_like arg_tys (InfixCon p1 p2) penv thing_inside
+  = do  { checkTc (con_arity == 2)      -- Check correct arity
+                  (arityErr (text "constructor") con_like con_arity 2)
+        ; let [arg_ty1,arg_ty2] = arg_tys       -- This can't fail after the arity check
+        ; ([p1',p2'], res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)]
+                                              penv thing_inside
+        ; return (InfixCon p1' p2', res) }
+  where
+    con_arity  = conLikeArity con_like
+
+tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
+  = do  { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside
+        ; return (RecCon (HsRecFields rpats' dd), res) }
+  where
+    tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))
+                        (LHsRecField GhcTcId (LPat GhcTcId))
+    tc_field (dL->L l (HsRecField (dL->L loc
+                                    (FieldOcc sel (dL->L lr rdr))) pat pun))
+             penv thing_inside
+      = do { sel'   <- tcLookupId sel
+           ; pat_ty <- setSrcSpan loc $ find_field_ty sel
+                                          (occNameFS $ rdrNameOcc rdr)
+           ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
+           ; return (cL l (HsRecField (cL loc (FieldOcc sel' (cL lr rdr))) pat'
+                                                                    pun), res) }
+    tc_field (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) _ _
+           = panic "tcConArgs"
+    tc_field _ _ _ = panic "tc_field: Impossible Match"
+                             -- due to #15884
+
+
+    find_field_ty :: Name -> FieldLabelString -> TcM TcType
+    find_field_ty sel lbl
+        = case [ty | (fl, ty) <- field_tys, flSelector fl == sel] of
+
+                -- No matching field; chances are this field label comes from some
+                -- other record type (or maybe none).  If this happens, just fail,
+                -- otherwise we get crashes later (Trac #8570), and similar:
+                --      f (R { foo = (a,b) }) = a+b
+                -- If foo isn't one of R's fields, we don't want to crash when
+                -- typechecking the "a+b".
+           [] -> failWith (badFieldCon con_like lbl)
+
+                -- The normal case, when the field comes from the right constructor
+           (pat_ty : extras) -> do
+                traceTc "find_field" (ppr pat_ty <+> ppr extras)
+                ASSERT( null extras ) (return pat_ty)
+
+    field_tys :: [(FieldLabel, TcType)]
+    field_tys = zip (conLikeFieldLabels con_like) arg_tys
+          -- Don't use zipEqual! If the constructor isn't really a record, then
+          -- dataConFieldLabels will be empty (and each field in the pattern
+          -- will generate an error below).
+
+tcConArg :: Checker (LPat GhcRn, TcSigmaType) (LPat GhcTc)
+tcConArg (arg_pat, arg_ty) penv thing_inside
+  = tc_lpat arg_pat (mkCheckExpType arg_ty) penv thing_inside
+
+addDataConStupidTheta :: DataCon -> [TcType] -> TcM ()
+-- Instantiate the "stupid theta" of the data con, and throw
+-- the constraints into the constraint set
+addDataConStupidTheta data_con inst_tys
+  | null stupid_theta = return ()
+  | otherwise         = instStupidTheta origin inst_theta
+  where
+    origin = OccurrenceOf (dataConName data_con)
+        -- The origin should always report "occurrence of C"
+        -- even when C occurs in a pattern
+    stupid_theta = dataConStupidTheta data_con
+    univ_tvs     = dataConUnivTyVars data_con
+    tenv = zipTvSubst univ_tvs (takeList univ_tvs inst_tys)
+         -- NB: inst_tys can be longer than the univ tyvars
+         --     because the constructor might have existentials
+    inst_theta = substTheta tenv stupid_theta
+
+{-
+Note [Arrows and patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+(Oct 07) Arrow notation has the odd property that it involves
+"holes in the scope". For example:
+  expr :: Arrow a => a () Int
+  expr = proc (y,z) -> do
+          x <- term -< y
+          expr' -< x
+
+Here the 'proc (y,z)' binding scopes over the arrow tails but not the
+arrow body (e.g 'term').  As things stand (bogusly) all the
+constraints from the proc body are gathered together, so constraints
+from 'term' will be seen by the tcPat for (y,z).  But we must *not*
+bind constraints from 'term' here, because the desugarer will not make
+these bindings scope over 'term'.
+
+The Right Thing is not to confuse these constraints together. But for
+now the Easy Thing is to ensure that we do not have existential or
+GADT constraints in a 'proc', and to short-cut the constraint
+simplification for such vanilla patterns so that it binds no
+constraints. Hence the 'fast path' in tcConPat; but it's also a good
+plan for ordinary vanilla patterns to bypass the constraint
+simplification step.
+
+************************************************************************
+*                                                                      *
+                Note [Pattern coercions]
+*                                                                      *
+************************************************************************
+
+In principle, these program would be reasonable:
+
+        f :: (forall a. a->a) -> Int
+        f (x :: Int->Int) = x 3
+
+        g :: (forall a. [a]) -> Bool
+        g [] = True
+
+In both cases, the function type signature restricts what arguments can be passed
+in a call (to polymorphic ones).  The pattern type signature then instantiates this
+type.  For example, in the first case,  (forall a. a->a) <= Int -> Int, and we
+generate the translated term
+        f = \x' :: (forall a. a->a).  let x = x' Int in x 3
+
+From a type-system point of view, this is perfectly fine, but it's *very* seldom useful.
+And it requires a significant amount of code to implement, because we need to decorate
+the translated pattern with coercion functions (generated from the subsumption check
+by tcSub).
+
+So for now I'm just insisting on type *equality* in patterns.  No subsumption.
+
+Old notes about desugaring, at a time when pattern coercions were handled:
+
+A SigPat is a type coercion and must be handled one at at time.  We can't
+combine them unless the type of the pattern inside is identical, and we don't
+bother to check for that.  For example:
+
+        data T = T1 Int | T2 Bool
+        f :: (forall a. a -> a) -> T -> t
+        f (g::Int->Int)   (T1 i) = T1 (g i)
+        f (g::Bool->Bool) (T2 b) = T2 (g b)
+
+We desugar this as follows:
+
+        f = \ g::(forall a. a->a) t::T ->
+            let gi = g Int
+            in case t of { T1 i -> T1 (gi i)
+                           other ->
+            let gb = g Bool
+            in case t of { T2 b -> T2 (gb b)
+                           other -> fail }}
+
+Note that we do not treat the first column of patterns as a
+column of variables, because the coerced variables (gi, gb)
+would be of different types.  So we get rather grotty code.
+But I don't think this is a common case, and if it was we could
+doubtless improve it.
+
+Meanwhile, the strategy is:
+        * treat each SigPat coercion (always non-identity coercions)
+                as a separate block
+        * deal with the stuff inside, and then wrap a binding round
+                the result to bind the new variable (gi, gb, etc)
+
+
+************************************************************************
+*                                                                      *
+\subsection{Errors and contexts}
+*                                                                      *
+************************************************************************
+
+Note [Existential check]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Lazy patterns can't bind existentials.  They arise in two ways:
+  * Let bindings      let { C a b = e } in b
+  * Twiddle patterns  f ~(C a b) = e
+The pe_lazy field of PatEnv says whether we are inside a lazy
+pattern (perhaps deeply)
+
+See also Note [Typechecking pattern bindings] in TcBinds
+-}
+
+maybeWrapPatCtxt :: Pat GhcRn -> (TcM a -> TcM b) -> TcM a -> TcM b
+-- Not all patterns are worth pushing a context
+maybeWrapPatCtxt pat tcm thing_inside
+  | not (worth_wrapping pat) = tcm thing_inside
+  | otherwise                = addErrCtxt msg $ tcm $ popErrCtxt thing_inside
+                               -- Remember to pop before doing thing_inside
+  where
+   worth_wrapping (VarPat {}) = False
+   worth_wrapping (ParPat {}) = False
+   worth_wrapping (AsPat {})  = False
+   worth_wrapping _           = True
+   msg = hang (text "In the pattern:") 2 (ppr pat)
+
+-----------------------------------------------
+checkExistentials :: [TyVar]   -- existentials
+                  -> [Type]    -- argument types
+                  -> PatEnv -> TcM ()
+    -- See Note [Existential check]]
+    -- See Note [Arrows and patterns]
+checkExistentials ex_tvs tys _
+  | all (not . (`elemVarSet` tyCoVarsOfTypes tys)) ex_tvs = return ()
+checkExistentials _ _ (PE { pe_ctxt = LetPat {}})         = return ()
+checkExistentials _ _ (PE { pe_ctxt = LamPat ProcExpr })  = failWithTc existentialProcPat
+checkExistentials _ _ (PE { pe_lazy = True })             = failWithTc existentialLazyPat
+checkExistentials _ _ _                                   = return ()
+
+existentialLazyPat :: SDoc
+existentialLazyPat
+  = hang (text "An existential or GADT data constructor cannot be used")
+       2 (text "inside a lazy (~) pattern")
+
+existentialProcPat :: SDoc
+existentialProcPat
+  = text "Proc patterns cannot use existential or GADT data constructors"
+
+badFieldCon :: ConLike -> FieldLabelString -> SDoc
+badFieldCon con field
+  = hsep [text "Constructor" <+> quotes (ppr con),
+          text "does not have field", quotes (ppr field)]
+
+polyPatSig :: TcType -> SDoc
+polyPatSig sig_ty
+  = hang (text "Illegal polymorphic type signature in pattern:")
+       2 (ppr sig_ty)
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -0,0 +1,1199 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[TcPatSyn]{Typechecking pattern synonym declarations}
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind
+                , tcPatSynBuilderOcc, nonBidirectionalErr
+  ) where
+
+import GhcPrelude
+
+import HsSyn
+import TcPat
+import Type( tidyTyCoVarBinders, tidyTypes, tidyType )
+import TcRnMonad
+import TcSigs( emptyPragEnv, completeSigFromId )
+import TcEnv
+import TcMType
+import TcHsSyn
+import TysPrim
+import Name
+import SrcLoc
+import PatSyn
+import NameSet
+import Panic
+import Outputable
+import FastString
+import Var
+import VarEnv( emptyTidyEnv, mkInScopeSet )
+import Id
+import IdInfo( RecSelParent(..), setLevityInfoWithType )
+import TcBinds
+import BasicTypes
+import TcSimplify
+import TcUnify
+import Type( PredTree(..), EqRel(..), classifyPredType )
+import TysWiredIn
+import TcType
+import TcEvidence
+import BuildTyCl
+import VarSet
+import MkId
+import TcTyDecls
+import ConLike
+import FieldLabel
+import Bag
+import Util
+import ErrUtils
+import Data.Maybe( mapMaybe )
+import Control.Monad ( zipWithM )
+import Data.List( partition )
+
+#include "HsVersions.h"
+
+{-
+************************************************************************
+*                                                                      *
+                    Type checking a pattern synonym
+*                                                                      *
+************************************************************************
+-}
+
+tcPatSynDecl :: PatSynBind GhcRn GhcRn
+             -> Maybe TcSigInfo
+             -> TcM (LHsBinds GhcTc, TcGblEnv)
+tcPatSynDecl psb mb_sig
+  = recoverM (recoverPSB psb) $
+    case mb_sig of
+      Nothing                 -> tcInferPatSynDecl psb
+      Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi
+      _                       -> panic "tcPatSynDecl"
+
+recoverPSB :: PatSynBind GhcRn GhcRn
+           -> TcM (LHsBinds GhcTc, TcGblEnv)
+-- See Note [Pattern synonym error recovery]
+recoverPSB (PSB { psb_id = (dL->L _ name)
+                , psb_args = details })
+ = do { matcher_name <- newImplicitBinder name mkMatcherOcc
+      ; let placeholder = AConLike $ PatSynCon $
+                          mk_placeholder matcher_name
+      ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv
+      ; return (emptyBag, gbl_env) }
+  where
+    (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details
+    mk_placeholder matcher_name
+      = mkPatSyn name is_infix
+                        ([mkTyVarBinder Specified alphaTyVar], []) ([], [])
+                        [] -- Arg tys
+                        alphaTy
+                        (matcher_id, True) Nothing
+                        []  -- Field labels
+       where
+         -- The matcher_id is used only by the desugarer, so actually
+         -- and error-thunk would probably do just as well here.
+         matcher_id = mkLocalId matcher_name $
+                      mkSpecForAllTys [alphaTyVar] alphaTy
+
+recoverPSB (XPatSynBind {}) = panic "recoverPSB"
+
+{- Note [Pattern synonym error recovery]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If type inference for a pattern synonym fails, we can't continue with
+the rest of tc_patsyn_finish, because we may get knock-on errors, or
+even a crash.  E.g. from
+   pattern What = True :: Maybe
+we get a kind error; and we must stop right away (Trac #15289).
+
+We stop if there are /any/ unsolved constraints, not just insoluble
+ones; because pattern synonyms are top-level things, we will never
+solve them later if we can't solve them now.  And if we were to carry
+on, tc_patsyn_finish does zonkTcTypeToType, which defaults any
+unsolved unificatdion variables to Any, which confuses the error
+reporting no end (Trac #15685).
+
+So we use simplifyTop to completely solve the constraint, report
+any errors, throw an exception.
+
+Even in the event of such an error we can recover and carry on, just
+as we do for value bindings, provided we plug in placeholder for the
+pattern synonym: see recoverPSB.  The goal of the placeholder is not
+to cause a raft of follow-on errors.  I've used the simplest thing for
+now, but we might need to elaborate it a bit later.  (e.g.  I've given
+it zero args, which may cause knock-on errors if it is used in a
+pattern.) But it'll do for now.
+
+-}
+
+tcInferPatSynDecl :: PatSynBind GhcRn GhcRn
+                  -> TcM (LHsBinds GhcTc, TcGblEnv)
+tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details
+                       , psb_def = lpat, psb_dir = dir })
+  = addPatSynCtxt lname $
+    do { traceTc "tcInferPatSynDecl {" $ ppr name
+
+       ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
+       ; (tclvl, wanted, ((lpat', args), pat_ty))
+            <- pushLevelAndCaptureConstraints  $
+               tcInferNoInst                   $ \ exp_ty ->
+               tcPat PatSyn lpat exp_ty        $
+               mapM tcLookupId arg_names
+
+       ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'
+
+             named_taus = (name, pat_ty) : map mk_named_tau args
+             mk_named_tau arg
+               = (getName arg, mkSpecForAllTys ex_tvs (varType arg))
+               -- The mkSpecForAllTys is important (Trac #14552), albeit
+               -- slightly artifical (there is no variable with this funny type).
+               -- We do not want to quantify over variable (alpha::k)
+               -- that mention the existentially-bound type variables
+               -- ex_tvs in its kind k.
+               -- See Note [Type variables whose kind is captured]
+
+       ; (univ_tvs, req_dicts, ev_binds, residual, _)
+               <- simplifyInfer tclvl NoRestrictions [] named_taus wanted
+       ; top_ev_binds <- checkNoErrs (simplifyTop residual)
+       ; addTopEvBinds top_ev_binds $
+
+    do { prov_dicts <- mapM zonkId prov_dicts
+       ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts
+             -- Filtering: see Note [Remove redundant provided dicts]
+             (prov_theta, prov_evs)
+                 = unzip (mapMaybe mkProvEvidence filtered_prov_dicts)
+             req_theta = map evVarPred req_dicts
+
+       -- Report coercions that esacpe
+       -- See Note [Coercions that escape]
+       ; args <- mapM zonkId args
+       ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts
+                              , let bad_cos = filterDVarSet isId $
+                                              (tyCoVarsOfTypeDSet (idType arg))
+                              , not (isEmptyDVarSet bad_cos) ]
+       ; mapM_ dependentArgErr bad_args
+
+       ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)
+       ; tc_patsyn_finish lname dir is_infix lpat'
+                          (mkTyVarBinders Inferred univ_tvs
+                            , req_theta,  ev_binds, req_dicts)
+                          (mkTyVarBinders Inferred ex_tvs
+                            , mkTyVarTys ex_tvs, prov_theta, prov_evs)
+                          (map nlHsVar args, map idType args)
+                          pat_ty rec_fields } }
+tcInferPatSynDecl (XPatSynBind _) = panic "tcInferPatSynDecl"
+
+mkProvEvidence :: EvId -> Maybe (PredType, EvTerm)
+-- See Note [Equality evidence in pattern synonyms]
+mkProvEvidence ev_id
+  | EqPred r ty1 ty2 <- classifyPredType pred
+  , let k1 = tcTypeKind ty1
+        k2 = tcTypeKind ty2
+        is_homo = k1 `tcEqType` k2
+        homo_tys   = [k1, ty1, ty2]
+        hetero_tys = [k1, k2, ty1, ty2]
+  = case r of
+      ReprEq | is_homo
+             -> Just ( mkClassPred coercibleClass    homo_tys
+                     , evDataConApp coercibleDataCon homo_tys eq_con_args )
+             | otherwise -> Nothing
+      NomEq  | is_homo
+             -> Just ( mkClassPred eqClass    homo_tys
+                     , evDataConApp eqDataCon homo_tys eq_con_args )
+             | otherwise
+             -> Just ( mkClassPred heqClass    hetero_tys
+                     , evDataConApp heqDataCon hetero_tys eq_con_args )
+
+  | otherwise
+  = Just (pred, EvExpr (evId ev_id))
+  where
+    pred = evVarPred ev_id
+    eq_con_args = [evId ev_id]
+
+dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()
+-- See Note [Coercions that escape]
+dependentArgErr (arg, bad_cos)
+  = addErrTc $
+    vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"
+         , hang (text "Pattern-bound variable")
+              2 (ppr arg <+> dcolon <+> ppr (idType arg))
+         , nest 2 $
+           hang (text "has a type that mentions pattern-bound coercion"
+                 <> plural bad_co_list <> colon)
+              2 (pprWithCommas ppr bad_co_list)
+         , text "Hint: use -fprint-explicit-coercions to see the coercions"
+         , text "Probable fix: add a pattern signature" ]
+  where
+    bad_co_list = dVarSetElems bad_cos
+
+{- Note [Type variables whose kind is captured]
+~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data AST a = Sym [a]
+  class Prj s where { prj :: [a] -> Maybe (s a)
+  pattern P x <= Sym (prj -> Just x)
+
+Here we get a matcher with this type
+  $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r
+
+No problem.  But note that 's' is not fixed by the type of the
+pattern (AST a), nor is it existentially bound.  It's really only
+fixed by the type of the continuation.
+
+Trac #14552 showed that this can go wrong if the kind of 's' mentions
+existentially bound variables.  We obviously can't make a type like
+  $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r)
+                                   -> r -> r
+But neither is 's' itself existentially bound, so the forall (s::k->*)
+can't go in the inner forall either.  (What would the matcher apply
+the continuation to?)
+
+Solution: do not quantiify over any unification variable whose kind
+mentions the existentials.  We can conveniently do that by making the
+"taus" passed to simplifyInfer look like
+   forall ex_tvs. arg_ty
+
+After that, Note [Naughty quantification candidates] in TcMType takes
+over, and zonks any such naughty variables to Any.
+
+Note [Remove redundant provided dicts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Recall that
+   HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2)
+                                       => a1 :~~: a2
+(NB: technically the (k1~k2) existential dictionary is not necessary,
+but it's there at the moment.)
+
+Now consider (Trac #14394):
+   pattern Foo = HRefl
+in a non-poly-kinded module.  We don't want to get
+    pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b
+with that redundant (* ~ *).  We'd like to remove it; hence the call to
+mkMinimalWithSCs.
+
+Similarly consider
+  data S a where { MkS :: Ord a => a -> S a }
+  pattern Bam x y <- (MkS (x::a), MkS (y::a)))
+
+The pattern (Bam x y) binds two (Ord a) dictionaries, but we only
+need one.  Agian mkMimimalWithSCs removes the redundant one.
+
+Note [Equality evidence in pattern synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data X a where
+     MkX :: Eq a => [a] -> X (Maybe a)
+  pattern P x = MkG x
+
+Then there is a danger that GHC will infer
+  P :: forall a.  () =>
+       forall b. (a ~# Maybe b, Eq b) => [b] -> X a
+
+The 'builder' for P, which is called in user-code, will then
+have type
+  $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a
+
+and that is bad because (a ~# Maybe b) is not a predicate type
+(see Note [Types for coercions, predicates, and evidence] in Type)
+and is not implicitly instantiated.
+
+So in mkProvEvidence we lift (a ~# b) to (a ~ b).  Tiresome, and
+marginally less efficient, if the builder/martcher are not inlined.
+
+See also Note [Lift equality constaints when quantifying] in TcType
+
+Note [Coercions that escape]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Trac #14507 showed an example where the inferred type of the matcher
+for the pattern synonym was somethign like
+   $mSO :: forall (r :: TYPE rep) kk (a :: k).
+           TypeRep k a
+           -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r)
+           -> (Void# -> r)
+           -> r
+
+What is that co_a2sv :: Bool ~# *??  It was bound (via a superclass
+selection) by the pattern being matched; and indeed it is implicit in
+the context (Bool ~ k).  You could imagine trying to extract it like
+this:
+   $mSO :: forall (r :: TYPE rep) kk (a :: k).
+           TypeRep k a
+           -> ( co :: ((Bool :: *) ~ (k :: *)) =>
+                  let co_a2sv = sc_sel co
+                  in TypeRep Bool (a |> co_a2sv) -> r)
+           -> (Void# -> r)
+           -> r
+
+But we simply don't allow that in types.  Maybe one day but not now.
+
+How to detect this situation?  We just look for free coercion variables
+in the types of any of the arguments to the matcher.  The error message
+is not very helpful, but at least we don't get a Lint error.
+-}
+
+tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn
+                  -> TcPatSynInfo
+                  -> TcM (LHsBinds GhcTc, TcGblEnv)
+tcCheckPatSynDecl psb@PSB{ psb_id = lname@(dL->L _ name), psb_args = details
+                         , psb_def = lpat, psb_dir = dir }
+                  TPSI{ patsig_implicit_bndrs = implicit_tvs
+                      , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta
+                      , patsig_ex_bndrs   = explicit_ex_tvs,   patsig_req  = req_theta
+                      , patsig_body_ty    = sig_body_ty }
+  = addPatSynCtxt lname $
+    do { let decl_arity = length arg_names
+             (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details
+
+       ; traceTc "tcCheckPatSynDecl" $
+         vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta
+              , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ]
+
+       ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of
+                                 Right stuff  -> return stuff
+                                 Left missing -> wrongNumberOfParmsErr name decl_arity missing
+
+       -- Complain about:  pattern P :: () => forall x. x -> P x
+       -- The existential 'x' should not appear in the result type
+       -- Can't check this until we know P's arity
+       ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs
+       ; checkTc (null bad_tvs) $
+         hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma
+                   , text "namely" <+> quotes (ppr pat_ty) ])
+            2 (text "mentions existential type variable" <> plural bad_tvs
+               <+> pprQuotedList bad_tvs)
+
+         -- See Note [The pattern-synonym signature splitting rule] in TcSigs
+       ; let univ_fvs = closeOverKinds $
+                        (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs)
+             (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs
+             univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs
+             ex_bndrs   = extra_ex   ++ mkTyVarBinders Specified explicit_ex_tvs
+             univ_tvs   = binderVars univ_bndrs
+             ex_tvs     = binderVars ex_bndrs
+
+       -- Right!  Let's check the pattern against the signature
+       -- See Note [Checking against a pattern signature]
+       ; req_dicts <- newEvVars req_theta
+       ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-
+           ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )
+           pushLevelAndCaptureConstraints            $
+           tcExtendTyVarEnv univ_tvs                 $
+           tcExtendKindEnvList [(getName (binderVar ex_tv), APromotionErr PatSynExPE)
+                               | ex_tv <- extra_ex] $
+               -- See Note [Pattern synonym existentials do not scope]
+           tcPat PatSyn lpat (mkCheckExpType pat_ty) $
+           do { let in_scope    = mkInScopeSet (mkVarSet univ_tvs)
+                    empty_subst = mkEmptyTCvSubst in_scope
+              ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs
+                    -- newMetaTyVarX: see the "Existential type variables"
+                    -- part of Note [Checking against a pattern signature]
+              ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])
+              ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])
+              ; let prov_theta' = substTheta subst prov_theta
+                  -- Add univ_tvs to the in_scope set to
+                  -- satisfy the substitution invariant. There's no need to
+                  -- add 'ex_tvs' as they are already in the domain of the
+                  -- substitution.
+                  -- See also Note [The substitution invariant] in TyCoRep.
+              ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'
+              ; args'      <- zipWithM (tc_arg subst) arg_names arg_tys
+              ; return (ex_tvs', prov_dicts, args') }
+
+       ; let skol_info = SigSkol (PatSynCtxt name) pat_ty []
+                         -- The type here is a bit bogus, but we do not print
+                         -- the type for PatSynCtxt, so it doesn't matter
+                         -- See TcRnTypes Note [Skolem info for pattern synonyms]
+       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted
+
+       -- Solve the constraints now, because we are about to make a PatSyn,
+       -- which should not contain unification variables and the like (Trac #10997)
+       ; simplifyTopImplic implics
+
+       -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct
+       -- Otherwise we may get a type error when typechecking the builder,
+       -- when that should be impossible
+
+       ; traceTc "tcCheckPatSynDecl }" $ ppr name
+       ; tc_patsyn_finish lname dir is_infix lpat'
+                          (univ_bndrs, req_theta, ev_binds, req_dicts)
+                          (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)
+                          (args', arg_tys)
+                          pat_ty rec_fields }
+  where
+    tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId)
+    tc_arg subst arg_name arg_ty
+      = do {   -- Look up the variable actually bound by lpat
+               -- and check that it has the expected type
+             arg_id <- tcLookupId arg_name
+           ; wrap <- tcSubType_NC GenSigCtxt
+                                 (idType arg_id)
+                                 (substTyUnchecked subst arg_ty)
+                -- Why do we need tcSubType here?
+                -- See Note [Pattern synonyms and higher rank types]
+           ; return (mkLHsWrap wrap $ nlHsVar arg_id) }
+tcCheckPatSynDecl (XPatSynBind _) _ = panic "tcCheckPatSynDecl"
+
+{- [Pattern synonyms and higher rank types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data T = MkT (forall a. a->a)
+
+  pattern P :: (Int -> Int) -> T
+  pattern P x <- MkT x
+
+This should work.  But in the matcher we must match against MkT, and then
+instantiate its argument 'x', to get a function of type (Int -> Int).
+Equality is not enough!  Trac #13752 was an example.
+
+Note [Pattern synonym existentials do not scope]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (Trac #14498):
+  pattern SS :: forall (t :: k). () =>
+                => forall (a :: kk -> k) (n :: kk).
+                => TypeRep n -> TypeRep t
+  pattern SS n <- (App (Typeable :: TypeRep (a::kk -> k)) n)
+
+Here 'k' is implicitly bound in the signature, but (with
+-XScopedTypeVariables) it does still scope over the pattern-synonym
+definition.  But what about 'kk', which is oexistential?  It too is
+implicitly bound in the signature; should it too scope?  And if so,
+what type variable is it bound to?
+
+The trouble is that the type variable to which it is bound is itself
+only brought into scope in part the pattern, so it makes no sense for
+'kk' to scope over the whole pattern.  See the discussion on
+Trac #14498, esp comment:16ff. Here is a simpler example:
+  data T where { MkT :: x -> (x->Int) -> T }
+  pattern P :: () => forall x. x -> (x->Int) -> T
+  pattern P a b = (MkT a b, True)
+
+Here it would make no sense to mention 'x' in the True pattern,
+like this:
+  pattern P a b = (MkT a b, True :: x)
+
+The 'x' only makes sense "under" the MkT pattern. Conclusion: the
+existential type variables of a pattern-synonym signature should not
+scope.
+
+But it's not that easy to implement, because we don't know
+exactly what the existentials /are/ until we get to type checking.
+(See Note [The pattern-synonym signature splitting rule], and
+the partition of implicit_tvs in tcCheckPatSynDecl.)
+
+So we do this:
+
+- The reaner brings all the implicitly-bound kind variables into
+  scope, without trying to distinguish universal from existential
+
+- tcCheckPatSynDecl uses tcExtendKindEnvList to bind the
+  implicitly-bound existentials to
+      APromotionErr PatSynExPE
+  It's not really a promotion error, but it's a way to bind the Name
+  (which the renamer has not complained about) to something that, when
+  looked up, will cause a complaint (in this case
+  TcHsType.promotionErr)
+
+
+Note [The pattern-synonym signature splitting rule]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given a pattern signature, we must split
+     the kind-generalised variables, and
+     the implicitly-bound variables
+into universal and existential.  The rule is this
+(see discussion on Trac #11224):
+
+     The universal tyvars are the ones mentioned in
+          - univ_tvs: the user-specified (forall'd) universals
+          - req_theta
+          - res_ty
+     The existential tyvars are all the rest
+
+For example
+
+   pattern P :: () => b -> T a
+   pattern P x = ...
+
+Here 'a' is universal, and 'b' is existential.  But there is a wrinkle:
+how do we split the arg_tys from req_ty?  Consider
+
+   pattern Q :: () => b -> S c -> T a
+   pattern Q x = ...
+
+This is an odd example because Q has only one syntactic argument, and
+so presumably is defined by a view pattern matching a function.  But
+it can happen (Trac #11977, #12108).
+
+We don't know Q's arity from the pattern signature, so we have to wait
+until we see the pattern declaration itself before deciding res_ty is,
+and hence which variables are existential and which are universal.
+
+And that in turn is why TcPatSynInfo has a separate field,
+patsig_implicit_bndrs, to capture the implicitly bound type variables,
+because we don't yet know how to split them up.
+
+It's a slight compromise, because it means we don't really know the
+pattern synonym's real signature until we see its declaration.  So,
+for example, in hs-boot file, we may need to think what to do...
+(eg don't have any implicitly-bound variables).
+
+
+Note [Checking against a pattern signature]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When checking the actual supplied pattern against the pattern synonym
+signature, we need to be quite careful.
+
+----- Provided constraints
+Example
+
+    data T a where
+      MkT :: Ord a => a -> T a
+
+    pattern P :: () => Eq a => a -> [T a]
+    pattern P x = [MkT x]
+
+We must check that the (Eq a) that P claims to bind (and to
+make available to matches against P), is derivable from the
+actual pattern.  For example:
+    f (P (x::a)) = ...here (Eq a) should be available...
+And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs.
+
+----- Existential type variables
+Unusually, we instantiate the existential tyvars of the pattern with
+*meta* type variables.  For example
+
+    data S where
+      MkS :: Eq a => [a] -> S
+
+    pattern P :: () => Eq x => x -> S
+    pattern P x <- MkS x
+
+The pattern synonym conceals from its client the fact that MkS has a
+list inside it.  The client just thinks it's a type 'x'.  So we must
+unify x := [a] during type checking, and then use the instantiating type
+[a] (called ex_tys) when building the matcher.  In this case we'll get
+
+   $mP :: S -> (forall x. Ex x => x -> r) -> r -> r
+   $mP x k = case x of
+               MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a]
+                                              dl = $dfunEqList d
+                                          in k [a] dl ys
+
+All this applies when type-checking the /matching/ side of
+a pattern synonym.  What about the /building/ side?
+
+* For Unidirectional, there is no builder
+
+* For ExplicitBidirectional, the builder is completely separate
+  code, typechecked in tcPatSynBuilderBind
+
+* For ImplicitBidirectional, the builder is still typechecked in
+  tcPatSynBuilderBind, by converting the pattern to an expression and
+  typechecking it.
+
+  At one point, for ImplicitBidirectional I used TyVarTvs (instead of
+  TauTvs) in tcCheckPatSynDecl.  But (a) strengthening the check here
+  is redundant since tcPatSynBuilderBind does the job, (b) it was
+  still incomplete (TyVarTvs can unify with each other), and (c) it
+  didn't even work (Trac #13441 was accepted with
+  ExplicitBidirectional, but rejected if expressed in
+  ImplicitBidirectional form.  Conclusion: trying to be too clever is
+  a bad idea.
+-}
+
+collectPatSynArgInfo :: HsPatSynDetails (Located Name)
+                     -> ([Name], [Name], Bool)
+collectPatSynArgInfo details =
+  case details of
+    PrefixCon names      -> (map unLoc names, [], False)
+    InfixCon name1 name2 -> (map unLoc [name1, name2], [], True)
+    RecCon names         -> (vars, sels, False)
+                         where
+                            (vars, sels) = unzip (map splitRecordPatSyn names)
+  where
+    splitRecordPatSyn :: RecordPatSynField (Located Name)
+                      -> (Name, Name)
+    splitRecordPatSyn (RecordPatSynField
+                       { recordPatSynPatVar     = (dL->L _ patVar)
+                       , recordPatSynSelectorId = (dL->L _ selId) })
+      = (patVar, selId)
+
+addPatSynCtxt :: Located Name -> TcM a -> TcM a
+addPatSynCtxt (dL->L loc name) thing_inside
+  = setSrcSpan loc $
+    addErrCtxt (text "In the declaration for pattern synonym"
+                <+> quotes (ppr name)) $
+    thing_inside
+
+wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a
+wrongNumberOfParmsErr name decl_arity missing
+  = failWithTc $
+    hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")
+          <+> speakNOf decl_arity (text "argument"))
+       2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
+
+-------------------------
+-- Shared by both tcInferPatSyn and tcCheckPatSyn
+tc_patsyn_finish :: Located Name      -- ^ PatSyn Name
+                 -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)
+                 -> Bool              -- ^ Whether infix
+                 -> LPat GhcTc        -- ^ Pattern of the PatSyn
+                 -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar])
+                 -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm])
+                 -> ([LHsExpr GhcTcId], [TcType])   -- ^ Pattern arguments and
+                                                    -- types
+                 -> TcType            -- ^ Pattern type
+                 -> [Name]            -- ^ Selector names
+                 -- ^ Whether fields, empty if not record PatSyn
+                 -> TcM (LHsBinds GhcTc, TcGblEnv)
+tc_patsyn_finish lname dir is_infix lpat'
+                 (univ_tvs, req_theta, req_ev_binds, req_dicts)
+                 (ex_tvs,   ex_tys,    prov_theta,   prov_dicts)
+                 (args, arg_tys)
+                 pat_ty field_labels
+  = do { -- Zonk everything.  We are about to build a final PatSyn
+         -- so there had better be no unification variables in there
+
+         (ze, univ_tvs') <- zonkTyVarBinders univ_tvs
+       ; req_theta'      <- zonkTcTypesToTypesX ze req_theta
+       ; (ze, ex_tvs')   <- zonkTyVarBindersX ze ex_tvs
+       ; prov_theta'     <- zonkTcTypesToTypesX ze prov_theta
+       ; pat_ty'         <- zonkTcTypeToTypeX ze pat_ty
+       ; arg_tys'        <- zonkTcTypesToTypesX ze arg_tys
+
+       ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs'
+             (env2, ex_tvs)   = tidyTyCoVarBinders env1 ex_tvs'
+             req_theta  = tidyTypes env2 req_theta'
+             prov_theta = tidyTypes env2 prov_theta'
+             arg_tys    = tidyTypes env2 arg_tys'
+             pat_ty     = tidyType  env2 pat_ty'
+
+       ; traceTc "tc_patsyn_finish {" $
+           ppr (unLoc lname) $$ ppr (unLoc lpat') $$
+           ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$
+           ppr (ex_tvs, prov_theta, prov_dicts) $$
+           ppr args $$
+           ppr arg_tys $$
+           ppr pat_ty
+
+       -- Make the 'matcher'
+       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
+                                         (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)
+                                         (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)
+                                         (args, arg_tys)
+                                         pat_ty
+
+       -- Make the 'builder'
+       ; builder_id <- mkPatSynBuilderId dir lname
+                                         univ_tvs req_theta
+                                         ex_tvs   prov_theta
+                                         arg_tys pat_ty
+
+         -- TODO: Make this have the proper information
+       ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)
+                                            , flIsOverloaded = False
+                                            , flSelector = name }
+             field_labels' = map mkFieldLabel field_labels
+
+
+       -- Make the PatSyn itself
+       ; let patSyn = mkPatSyn (unLoc lname) is_infix
+                        (univ_tvs, req_theta)
+                        (ex_tvs, prov_theta)
+                        arg_tys
+                        pat_ty
+                        matcher_id builder_id
+                        field_labels'
+
+       -- Selectors
+       ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)
+             tything = AConLike (PatSynCon patSyn)
+       ; tcg_env <- tcExtendGlobalEnv [tything] $
+                    tcRecSelBinds rn_rec_sel_binds
+
+       ; traceTc "tc_patsyn_finish }" empty
+       ; return (matcher_bind, tcg_env) }
+
+{-
+************************************************************************
+*                                                                      *
+         Constructing the "matcher" Id and its binding
+*                                                                      *
+************************************************************************
+-}
+
+tcPatSynMatcher :: Located Name
+                -> LPat GhcTc
+                -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])
+                -> ([TcTyVar], [TcType], ThetaType, [EvTerm])
+                -> ([LHsExpr GhcTcId], [TcType])
+                -> TcType
+                -> TcM ((Id, Bool), LHsBinds GhcTc)
+-- See Note [Matchers and builders for pattern synonyms] in PatSyn
+tcPatSynMatcher (dL->L loc name) lpat
+                (univ_tvs, req_theta, req_ev_binds, req_dicts)
+                (ex_tvs, ex_tys, prov_theta, prov_dicts)
+                (args, arg_tys) pat_ty
+  = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc
+       ; tv_name <- newNameAt (mkTyVarOcc "r")   loc
+       ; let rr_tv  = mkTyVar rr_name runtimeRepTy
+             rr     = mkTyVarTy rr_tv
+             res_tv = mkTyVar tv_name (tYPE rr)
+             res_ty = mkTyVarTy res_tv
+             is_unlifted = null args && null prov_dicts
+             (cont_args, cont_arg_tys)
+               | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])
+               | otherwise   = (args,                 arg_tys)
+             cont_ty = mkInfSigmaTy ex_tvs prov_theta $
+                       mkFunTys cont_arg_tys res_ty
+
+             fail_ty  = mkFunTy voidPrimTy res_ty
+
+       ; matcher_name <- newImplicitBinder name mkMatcherOcc
+       ; scrutinee    <- newSysLocalId (fsLit "scrut") pat_ty
+       ; cont         <- newSysLocalId (fsLit "cont")  cont_ty
+       ; fail         <- newSysLocalId (fsLit "fail")  fail_ty
+
+       ; let matcher_tau   = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty
+             matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau
+             matcher_id    = mkExportedVanillaId matcher_name matcher_sigma
+                             -- See Note [Exported LocalIds] in Id
+
+             inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys
+             cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args
+
+             fail' = nlHsApps fail [nlHsVar voidPrimId]
+
+             args = map nlVarPat [scrutinee, cont, fail]
+             lwpat = noLoc $ WildPat pat_ty
+             cases = if isIrrefutableHsPat lpat
+                     then [mkHsCaseAlt lpat  cont']
+                     else [mkHsCaseAlt lpat  cont',
+                           mkHsCaseAlt lwpat fail']
+             body = mkLHsWrap (mkWpLet req_ev_binds) $
+                    cL (getLoc lpat) $
+                    HsCase noExt (nlHsVar scrutinee) $
+                    MG{ mg_alts = cL (getLoc lpat) cases
+                      , mg_ext = MatchGroupTc [pat_ty] res_ty
+                      , mg_origin = Generated
+                      }
+             body' = noLoc $
+                     HsLam noExt $
+                     MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr
+                                                        args body]
+                       , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty
+                       , mg_origin = Generated
+                       }
+             match = mkMatch (mkPrefixFunRhs (cL loc name)) []
+                             (mkHsLams (rr_tv:res_tv:univ_tvs)
+                                       req_dicts body')
+                             (noLoc (EmptyLocalBinds noExt))
+             mg :: MatchGroup GhcTc (LHsExpr GhcTc)
+             mg = MG{ mg_alts = cL (getLoc match) [match]
+                    , mg_ext = MatchGroupTc [] res_ty
+                    , mg_origin = Generated
+                    }
+
+       ; let bind = FunBind{ fun_ext = emptyNameSet
+                           , fun_id = cL loc matcher_id
+                           , fun_matches = mg
+                           , fun_co_fn = idHsWrapper
+                           , fun_tick = [] }
+             matcher_bind = unitBag (noLoc bind)
+
+       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))
+       ; traceTc "tcPatSynMatcher" (ppr matcher_bind)
+
+       ; return ((matcher_id, is_unlifted), matcher_bind) }
+
+mkPatSynRecSelBinds :: PatSyn
+                    -> [FieldLabel]  -- ^ Visible field labels
+                    -> [(Id, LHsBind GhcRn)]
+mkPatSynRecSelBinds ps fields
+  = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
+    | fld_lbl <- fields ]
+
+isUnidirectional :: HsPatSynDir a -> Bool
+isUnidirectional Unidirectional          = True
+isUnidirectional ImplicitBidirectional   = False
+isUnidirectional ExplicitBidirectional{} = False
+
+{-
+************************************************************************
+*                                                                      *
+         Constructing the "builder" Id
+*                                                                      *
+************************************************************************
+-}
+
+mkPatSynBuilderId :: HsPatSynDir a -> Located Name
+                  -> [TyVarBinder] -> ThetaType
+                  -> [TyVarBinder] -> ThetaType
+                  -> [Type] -> Type
+                  -> TcM (Maybe (Id, Bool))
+mkPatSynBuilderId dir (dL->L _ name)
+                  univ_bndrs req_theta ex_bndrs prov_theta
+                  arg_tys pat_ty
+  | isUnidirectional dir
+  = return Nothing
+  | otherwise
+  = do { builder_name <- newImplicitBinder name mkBuilderOcc
+       ; let theta          = req_theta ++ prov_theta
+             need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta
+             builder_sigma  = add_void need_dummy_arg $
+                              mkForAllTys univ_bndrs $
+                              mkForAllTys ex_bndrs $
+                              mkFunTys theta $
+                              mkFunTys arg_tys $
+                              pat_ty
+             builder_id     = mkExportedVanillaId builder_name builder_sigma
+              -- See Note [Exported LocalIds] in Id
+
+             builder_id'    = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id
+
+       ; return (Just (builder_id', need_dummy_arg)) }
+  where
+
+tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn
+                    -> TcM (LHsBinds GhcTc)
+-- See Note [Matchers and builders for pattern synonyms] in PatSyn
+tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name)
+                         , psb_def = lpat
+                         , psb_dir = dir
+                         , psb_args = details })
+  | isUnidirectional dir
+  = return emptyBag
+
+  | Left why <- mb_match_group       -- Can't invert the pattern
+  = setSrcSpan (getLoc lpat) $ failWithTc $
+    vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"
+                 <+> quotes (ppr name) <> colon)
+              2 why
+         , text "RHS pattern:" <+> ppr lpat ]
+
+  | Right match_group <- mb_match_group  -- Bidirectional
+  = do { patsyn <- tcLookupPatSyn name
+       ; case patSynBuilder patsyn of {
+           Nothing -> return emptyBag ;
+             -- This case happens if we found a type error in the
+             -- pattern synonym, recovered, and put a placeholder
+             -- with patSynBuilder=Nothing in the environment
+
+           Just (builder_id, need_dummy_arg) ->  -- Normal case
+    do { -- Bidirectional, so patSynBuilder returns Just
+         let match_group' | need_dummy_arg = add_dummy_arg match_group
+                          | otherwise      = match_group
+
+             bind = FunBind { fun_ext = placeHolderNamesTc
+                            , fun_id      = cL loc (idName builder_id)
+                            , fun_matches = match_group'
+                            , fun_co_fn   = idHsWrapper
+                            , fun_tick    = [] }
+
+             sig = completeSigFromId (PatSynCtxt name) builder_id
+
+       ; traceTc "tcPatSynBuilderBind {" $
+         ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id)
+       ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)
+       ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds
+       ; return builder_binds } } }
+
+  | otherwise = panic "tcPatSynBuilderBind"  -- Both cases dealt with
+  where
+    mb_match_group
+       = case dir of
+           ExplicitBidirectional explicit_mg -> Right explicit_mg
+           ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat)
+           Unidirectional -> panic "tcPatSynBuilderBind"
+
+    mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
+    mk_mg body = mkMatchGroup Generated [builder_match]
+          where
+            builder_args  = [cL loc (VarPat noExt (cL loc n))
+                            | (dL->L loc n) <- args]
+            builder_match = mkMatch (mkPrefixFunRhs (cL loc name))
+                                    builder_args body
+                                    (noLoc (EmptyLocalBinds noExt))
+
+    args = case details of
+              PrefixCon args     -> args
+              InfixCon arg1 arg2 -> [arg1, arg2]
+              RecCon args        -> map recordPatSynPatVar args
+
+    add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
+                  -> MatchGroup GhcRn (LHsExpr GhcRn)
+    add_dummy_arg mg@(MG { mg_alts =
+                           (dL->L l [dL->L loc
+                                           match@(Match { m_pats = pats })]) })
+      = mg { mg_alts = cL l [cL loc (match { m_pats = nlWildPatName : pats })] }
+    add_dummy_arg other_mg = pprPanic "add_dummy_arg" $
+                             pprMatches other_mg
+tcPatSynBuilderBind (XPatSynBind _) = panic "tcPatSynBuilderBind"
+
+tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)
+-- monadic only for failure
+tcPatSynBuilderOcc ps
+  | Just (builder_id, add_void_arg) <- builder
+  , let builder_expr = HsConLikeOut noExt (PatSynCon ps)
+        builder_ty   = idType builder_id
+  = return $
+    if add_void_arg
+    then ( builder_expr   -- still just return builder_expr; the void# arg is added
+                          -- by dsConLike in the desugarer
+         , tcFunResultTy builder_ty )
+    else (builder_expr, builder_ty)
+
+  | otherwise  -- Unidirectional
+  = nonBidirectionalErr name
+  where
+    name    = patSynName ps
+    builder = patSynBuilder ps
+
+add_void :: Bool -> Type -> Type
+add_void need_dummy_arg ty
+  | need_dummy_arg = mkFunTy voidPrimTy ty
+  | otherwise      = ty
+
+tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn
+            -> Either MsgDoc (LHsExpr GhcRn)
+-- Given a /pattern/, return an /expression/ that builds a value
+-- that matches the pattern.  E.g. if the pattern is (Just [x]),
+-- the expression is (Just [x]).  They look the same, but the
+-- input uses constructors from HsPat and the output uses constructors
+-- from HsExpr.
+--
+-- Returns (Left r) if the pattern is not invertible, for reason r.
+-- See Note [Builder for a bidirectional pattern synonym]
+tcPatToExpr name args pat = go pat
+  where
+    lhsVars = mkNameSet (map unLoc args)
+
+    -- Make a prefix con for prefix and infix patterns for simplicity
+    mkPrefixConExpr :: Located Name -> [LPat GhcRn]
+                    -> Either MsgDoc (HsExpr GhcRn)
+    mkPrefixConExpr lcon@(dL->L loc _) pats
+      = do { exprs <- mapM go pats
+           ; return (foldl' (\x y -> HsApp noExt (cL loc x) y)
+                            (HsVar noExt lcon) exprs) }
+
+    mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn)
+                    -> Either MsgDoc (HsExpr GhcRn)
+    mkRecordConExpr con fields
+      = do { exprFields <- mapM go fields
+           ; return (RecordCon noExt con exprFields) }
+
+    go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
+    go (dL->L loc p) = cL loc <$> go1 p
+
+    go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn)
+    go1 (ConPatIn con info)
+      = case info of
+          PrefixCon ps  -> mkPrefixConExpr con ps
+          InfixCon l r  -> mkPrefixConExpr con [l,r]
+          RecCon fields -> mkRecordConExpr con fields
+
+    go1 (SigPat _ pat _) = go1 (unLoc pat)
+        -- See Note [Type signatures and the builder expression]
+
+    go1 (VarPat _ (dL->L l var))
+        | var `elemNameSet` lhsVars
+        = return $ HsVar noExt (cL l var)
+        | otherwise
+        = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
+    go1 (ParPat _ pat)          = fmap (HsPar noExt) $ go pat
+    go1 p@(ListPat reb pats)
+      | Nothing <- reb = do { exprs <- mapM go pats
+                            ; return $ ExplicitList noExt Nothing exprs }
+      | otherwise                   = notInvertibleListPat p
+    go1 (TuplePat _ pats box)       = do { exprs <- mapM go pats
+                                         ; return $ ExplicitTuple noExt
+                                           (map (noLoc . (Present noExt)) exprs)
+                                                                           box }
+    go1 (SumPat _ pat alt arity)    = do { expr <- go1 (unLoc pat)
+                                         ; return $ ExplicitSum noExt alt arity
+                                                                   (noLoc expr)
+                                         }
+    go1 (LitPat _ lit)              = return $ HsLit noExt lit
+    go1 (NPat _ (dL->L _ n) mb_neg _)
+        | Just neg <- mb_neg        = return $ unLoc $ nlHsSyntaxApps neg
+                                                     [noLoc (HsOverLit noExt n)]
+        | otherwise                 = return $ HsOverLit noExt n
+    go1 (ConPatOut{})               = panic "ConPatOut in output of renamer"
+    go1 (CoPat{})                   = panic "CoPat in output of renamer"
+    go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
+                                    = go1 pat
+    go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"
+    go1 (SplicePat _ (HsSplicedT{})) = panic "Invalid splice variety"
+
+    -- The following patterns are not invertible.
+    go1 p@(BangPat {})                       = notInvertible p -- #14112
+    go1 p@(LazyPat {})                       = notInvertible p
+    go1 p@(WildPat {})                       = notInvertible p
+    go1 p@(AsPat {})                         = notInvertible p
+    go1 p@(ViewPat {})                       = notInvertible p
+    go1 p@(NPlusKPat {})                     = notInvertible p
+    go1 p@(XPat {})                          = notInvertible p
+    go1 p@(SplicePat _ (HsTypedSplice {}))   = notInvertible p
+    go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p
+    go1 p@(SplicePat _ (HsQuasiQuote {}))    = notInvertible p
+    go1 p@(SplicePat _ (XSplice {}))         = notInvertible p
+
+    notInvertible p = Left (not_invertible_msg p)
+
+    not_invertible_msg p
+      =   text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
+      $+$ hang (text "Suggestion: instead use an explicitly bidirectional"
+                <+> text "pattern synonym, e.g.")
+             2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow
+                      <+> ppr pat <+> text "where")
+                   2 (pp_name <+> pp_args <+> equals <+> text "..."))
+      where
+        pp_name = ppr name
+        pp_args = hsep (map ppr args)
+
+    -- We should really be able to invert list patterns, even when
+    -- rebindable syntax is on, but doing so involves a bit of
+    -- refactoring; see Trac #14380.  Until then we reject with a
+    -- helpful error message.
+    notInvertibleListPat p
+      = Left (vcat [ not_invertible_msg p
+                   , text "Reason: rebindable syntax is on."
+                   , text "This is fixable: add use-case to Trac #14380" ])
+
+{- Note [Builder for a bidirectional pattern synonym]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For a bidirectional pattern synonym we need to produce an /expression/
+that matches the supplied /pattern/, given values for the arguments
+of the pattern synonym.  For example
+  pattern F x y = (Just x, [y])
+The 'builder' for F looks like
+  $builderF x y = (Just x, [y])
+
+We can't always do this:
+ * Some patterns aren't invertible; e.g. view patterns
+      pattern F x = (reverse -> x:_)
+
+ * The RHS pattern might bind more variables than the pattern
+   synonym, so again we can't invert it
+      pattern F x = (x,y)
+
+ * Ditto wildcards
+      pattern F x = (x,_)
+
+
+Note [Redundant constraints for builder]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The builder can have redundant constraints, which are awkard to eliminate.
+Consider
+   pattern P = Just 34
+To match against this pattern we need (Eq a, Num a).  But to build
+(Just 34) we need only (Num a).  Fortunately instTcSigFromId sets
+sig_warn_redundant to False.
+
+************************************************************************
+*                                                                      *
+         Helper functions
+*                                                                      *
+************************************************************************
+
+Note [As-patterns in pattern synonym definitions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The rationale for rejecting as-patterns in pattern synonym definitions
+is that an as-pattern would introduce nonindependent pattern synonym
+arguments, e.g. given a pattern synonym like:
+
+        pattern K x y = x@(Just y)
+
+one could write a nonsensical function like
+
+        f (K Nothing x) = ...
+
+or
+        g (K (Just True) False) = ...
+
+Note [Type signatures and the builder expression]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   pattern L x = Left x :: Either [a] [b]
+
+In tc{Infer/Check}PatSynDecl we will check that the pattern has the
+specified type.  We check the pattern *as a pattern*, so the type
+signature is a pattern signature, and so brings 'a' and 'b' into
+scope.  But we don't have a way to bind 'a, b' in the LHS, as we do
+'x', say.  Nevertheless, the sigature may be useful to constrain
+the type.
+
+When making the binding for the *builder*, though, we don't want
+  $buildL x = Left x :: Either [a] [b]
+because that wil either mean (forall a b. Either [a] [b]), or we'll
+get a complaint that 'a' and 'b' are out of scope. (Actually the
+latter; Trac #9867.)  No, the job of the signature is done, so when
+converting the pattern to an expression (for the builder RHS) we
+simply discard the signature.
+
+Note [Record PatSyn Desugaring]
+-------------------------------
+It is important that prov_theta comes before req_theta as this ordering is used
+when desugaring record pattern synonym updates.
+
+Any change to this ordering should make sure to change deSugar/DsExpr.hs if you
+want to avoid difficult to decipher core lint errors!
+ -}
+
+
+nonBidirectionalErr :: Outputable name => name -> TcM a
+nonBidirectionalErr name = failWithTc $
+    text "non-bidirectional pattern synonym"
+    <+> quotes (ppr name) <+> text "used in an expression"
+
+-- Walk the whole pattern and for all ConPatOuts, collect the
+-- existentially-bound type variables and evidence binding variables.
+--
+-- These are used in computing the type of a pattern synonym and also
+-- in generating matcher functions, since success continuations need
+-- to be passed these pattern-bound evidences.
+tcCollectEx
+  :: LPat GhcTc
+  -> ( [TyVar]        -- Existentially-bound type variables
+                      -- in correctly-scoped order; e.g. [ k:*, x:k ]
+     , [EvVar] )      -- and evidence variables
+
+tcCollectEx pat = go pat
+  where
+    go :: LPat GhcTc -> ([TyVar], [EvVar])
+    go = go1 . unLoc
+
+    go1 :: Pat GhcTc -> ([TyVar], [EvVar])
+    go1 (LazyPat _ p)      = go p
+    go1 (AsPat _ _ p)      = go p
+    go1 (ParPat _ p)       = go p
+    go1 (BangPat _ p)      = go p
+    go1 (ListPat _ ps)     = mergeMany . map go $ ps
+    go1 (TuplePat _ ps _)  = mergeMany . map go $ ps
+    go1 (SumPat _ p _ _)   = go p
+    go1 (ViewPat _ _ p)    = go p
+    go1 con@ConPatOut{}    = merge (pat_tvs con, pat_dicts con) $
+                              goConDetails $ pat_args con
+    go1 (SigPat _ p _)     = go p
+    go1 (CoPat _ _ p _)    = go1 p
+    go1 (NPlusKPat _ n k _ geq subtract)
+      = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract
+    go1 _                   = empty
+
+    goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar])
+    goConDetails (PrefixCon ps) = mergeMany . map go $ ps
+    goConDetails (InfixCon p1 p2) = go p1 `merge` go p2
+    goConDetails (RecCon HsRecFields{ rec_flds = flds })
+      = mergeMany . map goRecFd $ flds
+
+    goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])
+    goRecFd (dL->L _ HsRecField{ hsRecFieldArg = p }) = go p
+
+    merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2)
+    mergeMany = foldr merge empty
+    empty     = ([], [])
diff --git a/compiler/typecheck/TcPatSyn.hs-boot b/compiler/typecheck/TcPatSyn.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcPatSyn.hs-boot
@@ -0,0 +1,16 @@
+module TcPatSyn where
+
+import HsSyn     ( PatSynBind, LHsBinds )
+import TcRnTypes ( TcM, TcSigInfo )
+import TcRnMonad ( TcGblEnv)
+import Outputable ( Outputable )
+import HsExtension ( GhcRn, GhcTc )
+import Data.Maybe  ( Maybe )
+
+tcPatSynDecl :: PatSynBind GhcRn GhcRn
+             -> Maybe TcSigInfo
+             -> TcM (LHsBinds GhcTc, TcGblEnv)
+
+tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)
+
+nonBidirectionalErr :: Outputable name => name -> TcM a
diff --git a/compiler/typecheck/TcPluginM.hs b/compiler/typecheck/TcPluginM.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcPluginM.hs
@@ -0,0 +1,196 @@
+{-# LANGUAGE CPP #-}
+-- | This module provides an interface for typechecker plugins to
+-- access select functions of the 'TcM', principally those to do with
+-- reading parts of the state.
+module TcPluginM (
+#if defined(GHCI)
+        -- * Basic TcPluginM functionality
+        TcPluginM,
+        tcPluginIO,
+        tcPluginTrace,
+        unsafeTcPluginTcM,
+
+        -- * Finding Modules and Names
+        FindResult(..),
+        findImportedModule,
+        lookupOrig,
+
+        -- * Looking up Names in the typechecking environment
+        tcLookupGlobal,
+        tcLookupTyCon,
+        tcLookupDataCon,
+        tcLookupClass,
+        tcLookup,
+        tcLookupId,
+
+        -- * Getting the TcM state
+        getTopEnv,
+        getEnvs,
+        getInstEnvs,
+        getFamInstEnvs,
+        matchFam,
+
+        -- * Type variables
+        newUnique,
+        newFlexiTyVar,
+        isTouchableTcPluginM,
+
+        -- * Zonking
+        zonkTcType,
+        zonkCt,
+
+        -- * Creating constraints
+        newWanted,
+        newDerived,
+        newGiven,
+        newCoercionHole,
+
+        -- * Manipulating evidence bindings
+        newEvVar,
+        setEvBind,
+        getEvBindsTcPluginM
+#endif
+    ) where
+
+#if defined(GHCI)
+import GhcPrelude
+
+import qualified TcRnMonad as TcM
+import qualified TcSMonad  as TcS
+import qualified TcEnv     as TcM
+import qualified TcMType   as TcM
+import qualified FamInst   as TcM
+import qualified IfaceEnv
+import qualified Finder
+
+import FamInstEnv ( FamInstEnv )
+import TcRnMonad  ( TcGblEnv, TcLclEnv, Ct, CtLoc, TcPluginM
+                  , unsafeTcPluginTcM, getEvBindsTcPluginM
+                  , liftIO, traceTc )
+import TcMType    ( TcTyVar, TcType )
+import TcEnv      ( TcTyThing )
+import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..)
+                  , EvExpr, EvBind, mkGivenEvBind )
+import TcRnTypes  ( CtEvidence(..) )
+import Var        ( EvVar )
+
+import Module
+import Name
+import TyCon
+import DataCon
+import Class
+import HscTypes
+import Outputable
+import Type
+import Id
+import InstEnv
+import FastString
+import Unique
+
+
+-- | Perform some IO, typically to interact with an external tool.
+tcPluginIO :: IO a -> TcPluginM a
+tcPluginIO a = unsafeTcPluginTcM (liftIO a)
+
+-- | Output useful for debugging the compiler.
+tcPluginTrace :: String -> SDoc -> TcPluginM ()
+tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)
+
+
+findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult
+findImportedModule mod_name mb_pkg = do
+    hsc_env <- getTopEnv
+    tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg
+
+lookupOrig :: Module -> OccName -> TcPluginM Name
+lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod
+
+
+tcLookupGlobal :: Name -> TcPluginM TyThing
+tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal
+
+tcLookupTyCon :: Name -> TcPluginM TyCon
+tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon
+
+tcLookupDataCon :: Name -> TcPluginM DataCon
+tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon
+
+tcLookupClass :: Name -> TcPluginM Class
+tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass
+
+tcLookup :: Name -> TcPluginM TcTyThing
+tcLookup = unsafeTcPluginTcM . TcM.tcLookup
+
+tcLookupId :: Name -> TcPluginM Id
+tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId
+
+
+getTopEnv :: TcPluginM HscEnv
+getTopEnv = unsafeTcPluginTcM TcM.getTopEnv
+
+getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)
+getEnvs = unsafeTcPluginTcM TcM.getEnvs
+
+getInstEnvs :: TcPluginM InstEnvs
+getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs
+
+getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)
+getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs
+
+matchFam :: TyCon -> [Type]
+         -> TcPluginM (Maybe (TcCoercion, TcType))
+matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args
+
+newUnique :: TcPluginM Unique
+newUnique = unsafeTcPluginTcM TcM.newUnique
+
+newFlexiTyVar :: Kind -> TcPluginM TcTyVar
+newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar
+
+isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool
+isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM
+
+-- Confused by zonking? See Note [What is zonking?] in TcMType.
+zonkTcType :: TcType -> TcPluginM TcType
+zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType
+
+zonkCt :: Ct -> TcPluginM Ct
+zonkCt = unsafeTcPluginTcM . TcM.zonkCt
+
+
+-- | Create a new wanted constraint.
+newWanted  :: CtLoc -> PredType -> TcPluginM CtEvidence
+newWanted loc pty
+  = unsafeTcPluginTcM (TcM.newWanted (TcM.ctLocOrigin loc) Nothing pty)
+
+-- | Create a new derived constraint.
+newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence
+newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc }
+
+-- | Create a new given constraint, with the supplied evidence.  This
+-- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it
+-- will panic.
+newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence
+newGiven loc pty evtm = do
+   new_ev <- newEvVar pty
+   setEvBind $ mkGivenEvBind new_ev (EvExpr evtm)
+   return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }
+
+-- | Create a fresh evidence variable.
+newEvVar :: PredType -> TcPluginM EvVar
+newEvVar = unsafeTcPluginTcM . TcM.newEvVar
+
+-- | Create a fresh coercion hole.
+newCoercionHole :: PredType -> TcPluginM CoercionHole
+newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole
+
+-- | Bind an evidence variable.  This must not be invoked from
+-- 'tcPluginInit' or 'tcPluginStop', or it will panic.
+setEvBind :: EvBind -> TcPluginM ()
+setEvBind ev_bind = do
+    tc_evbinds <- getEvBindsTcPluginM
+    unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind
+#else
+-- this dummy import is needed as a consequence of NoImplicitPrelude
+import GhcPrelude ()
+#endif
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -0,0 +1,2908 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+\section[TcRnDriver]{Typechecking a whole module}
+
+https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/TypeChecker
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcRnDriver (
+        tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,
+        tcRnImportDecls,
+        tcRnLookupRdrName,
+        getModuleInterface,
+        tcRnDeclsi,
+        isGHCiMonad,
+        runTcInteractive,    -- Used by GHC API clients (Trac #8878)
+        tcRnLookupName,
+        tcRnGetInfo,
+        tcRnModule, tcRnModuleTcRnM,
+        tcTopSrcDecls,
+        rnTopSrcDecls,
+        checkBootDecl, checkHiBootIface',
+        findExtraSigImports,
+        implicitRequirements,
+        checkUnitId,
+        mergeSignatures,
+        tcRnMergeSignatures,
+        instantiateSignature,
+        tcRnInstantiateSignature,
+        loadUnqualIfaces,
+        -- More private...
+        badReexportedBootThing,
+        checkBootDeclM,
+        missingBootThing,
+        getRenamedStuff, RenamedStuff
+    ) where
+
+import GhcPrelude
+
+import {-# SOURCE #-} TcSplice ( finishTH, runRemoteModFinalizers )
+import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )
+import IfaceEnv( externaliseName )
+import TcHsType
+import TcValidity( checkValidType )
+import TcMatches
+import Inst( deeplyInstantiate )
+import TcUnify( checkConstraints )
+import RnTypes
+import RnExpr
+import RnUtils ( HsDocContext(..) )
+import RnFixity ( lookupFixityRn )
+import MkId
+import TidyPgm    ( globaliseAndTidyId )
+import TysWiredIn ( unitTy, mkListTy )
+import Plugins
+import DynFlags
+import HsSyn
+import IfaceSyn ( ShowSub(..), showToHeader )
+import IfaceType( ShowForAllFlag(..) )
+import PatSyn( pprPatSynType )
+import PrelNames
+import PrelInfo
+import RdrName
+import TcHsSyn
+import TcExpr
+import TcRnMonad
+import TcRnExports
+import TcEvidence
+import qualified BooleanFormula as BF
+import PprTyThing( pprTyThingInContext )
+import CoreFVs( orphNamesOfFamInst )
+import FamInst
+import InstEnv
+import FamInstEnv( FamInst, pprFamInst, famInstsRepTyCons
+                 , famInstEnvElts, extendFamInstEnvList, normaliseType )
+import TcAnnotations
+import TcBinds
+import MkIface          ( coAxiomToIfaceDecl )
+import HeaderInfo       ( mkPrelImports )
+import TcDefaults
+import TcEnv
+import TcRules
+import TcForeign
+import TcInstDcls
+import TcIface
+import TcMType
+import TcType
+import TcSimplify
+import TcTyClsDecls
+import TcTypeable ( mkTypeableBinds )
+import TcBackpack
+import LoadIface
+import RnNames
+import RnEnv
+import RnSource
+import ErrUtils
+import Id
+import IdInfo( IdDetails(..) )
+import VarEnv
+import Module
+import UniqFM
+import Name
+import NameEnv
+import NameSet
+import Avail
+import TyCon
+import SrcLoc
+import HscTypes
+import ListSetOps
+import Outputable
+import ConLike
+import DataCon
+import Type
+import Class
+import BasicTypes hiding( SuccessFlag(..) )
+import CoAxiom
+import Annotations
+import Data.List ( sortBy, sort )
+import Data.Ord
+import FastString
+import Maybes
+import Util
+import Bag
+import Inst (tcGetInsts)
+import qualified GHC.LanguageExtensions as LangExt
+import Data.Data ( Data )
+import HsDumpAst
+import qualified Data.Set as S
+
+import Control.DeepSeq
+import Control.Monad
+
+#include "HsVersions.h"
+
+{-
+************************************************************************
+*                                                                      *
+        Typecheck and rename a module
+*                                                                      *
+************************************************************************
+-}
+
+-- | Top level entry point for typechecker and renamer
+tcRnModule :: HscEnv
+           -> ModSummary
+           -> Bool              -- True <=> save renamed syntax
+           -> HsParsedModule
+           -> IO (Messages, Maybe TcGblEnv)
+
+tcRnModule hsc_env mod_sum save_rn_syntax
+   parsedModule@HsParsedModule {hpm_module= (dL->L loc this_module)}
+ | RealSrcSpan real_loc <- loc
+ = withTiming (pure dflags)
+              (text "Renamer/typechecker"<+>brackets (ppr this_mod))
+              (const ()) $
+   initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
+          withTcPlugins hsc_env $
+
+          tcRnModuleTcRnM hsc_env mod_sum parsedModule pair
+
+  | otherwise
+  = return ((emptyBag, unitBag err_msg), Nothing)
+
+  where
+    hsc_src = ms_hsc_src mod_sum
+    dflags = hsc_dflags hsc_env
+    err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $
+              text "Module does not have a RealSrcSpan:" <+> ppr this_mod
+
+    this_pkg = thisPackage (hsc_dflags hsc_env)
+
+    pair :: (Module, SrcSpan)
+    pair@(this_mod,_)
+      | Just (dL->L mod_loc mod) <- hsmodName this_module
+      = (mkModule this_pkg mod, mod_loc)
+
+      | otherwise   -- 'module M where' is omitted
+      = (mAIN, srcLocSpan (srcSpanStart loc))
+
+
+
+
+tcRnModuleTcRnM :: HscEnv
+                -> ModSummary
+                -> HsParsedModule
+                -> (Module, SrcSpan)
+                -> TcRn TcGblEnv
+-- Factored out separately from tcRnModule so that a Core plugin can
+-- call the type checker directly
+tcRnModuleTcRnM hsc_env mod_sum
+                (HsParsedModule {
+                   hpm_module =
+                      (dL->L loc (HsModule maybe_mod export_ies
+                                       import_decls local_decls mod_deprec
+                                       maybe_doc_hdr)),
+                   hpm_src_files = src_files
+                })
+                (this_mod, prel_imp_loc)
+ = setSrcSpan loc $
+   do { let { explicit_mod_hdr = isJust maybe_mod
+            ; hsc_src          = ms_hsc_src mod_sum }
+      ; -- Load the hi-boot interface for this module, if any
+        -- We do this now so that the boot_names can be passed
+        -- to tcTyAndClassDecls, because the boot_names are
+        -- automatically considered to be loop breakers
+        tcg_env <- getGblEnv
+      ; boot_info <- tcHiBootIface hsc_src this_mod
+      ; setGblEnv (tcg_env { tcg_self_boot = boot_info })
+        $ do
+        { -- Deal with imports; first add implicit prelude
+          implicit_prelude <- xoptM LangExt.ImplicitPrelude
+        ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
+                               implicit_prelude import_decls }
+
+        ; whenWOptM Opt_WarnImplicitPrelude $
+             when (notNull prel_imports) $
+                addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn)
+
+        ; -- TODO This is a little skeevy; maybe handle a bit more directly
+          let { simplifyImport (dL->L _ idecl) =
+                  ( fmap sl_fs (ideclPkgQual idecl) , ideclName idecl)
+              }
+        ; raw_sig_imports <- liftIO
+                             $ findExtraSigImports hsc_env hsc_src
+                                 (moduleName this_mod)
+        ; raw_req_imports <- liftIO
+                             $ implicitRequirements hsc_env
+                                (map simplifyImport (prel_imports
+                                                     ++ import_decls))
+        ; let { mkImport (Nothing, dL->L _ mod_name) = noLoc
+                $ (simpleImportDecl mod_name)
+                  { ideclHiding = Just (False, noLoc [])}
+              ; mkImport _ = panic "mkImport" }
+        ; let { all_imports = prel_imports ++ import_decls
+                       ++ map mkImport (raw_sig_imports ++ raw_req_imports) }
+        ; -- OK now finally rename the imports
+          tcg_env <- {-# SCC "tcRnImports" #-}
+                     tcRnImports hsc_env all_imports
+
+        ; -- If the whole module is warned about or deprecated
+          -- (via mod_deprec) record that in tcg_warns. If we do thereby add
+          -- a WarnAll, it will override any subsequent deprecations added to tcg_warns
+          let { tcg_env1 = case mod_deprec of
+                             Just (dL->L _ txt) ->
+                               tcg_env {tcg_warns = WarnAll txt}
+                             Nothing            -> tcg_env
+              }
+        ; setGblEnv tcg_env1
+          $ do { -- Rename and type check the declarations
+                 traceRn "rn1a" empty
+               ; tcg_env <- if isHsBootOrSig hsc_src
+                            then tcRnHsBootDecls hsc_src local_decls
+                            else {-# SCC "tcRnSrcDecls" #-}
+                                 tcRnSrcDecls explicit_mod_hdr local_decls
+               ; setGblEnv tcg_env
+                 $ do { -- Process the export list
+                        traceRn "rn4a: before exports" empty
+                      ; tcg_env <- tcRnExports explicit_mod_hdr export_ies
+                                     tcg_env
+                      ; traceRn "rn4b: after exports" empty
+                      ; -- Check main is exported(must be after tcRnExports)
+                        checkMainExported tcg_env
+                      ; -- Compare hi-boot iface (if any) with the real thing
+                        -- Must be done after processing the exports
+                        tcg_env <- checkHiBootIface tcg_env boot_info
+                      ; -- The new type env is already available to stuff
+                        -- slurped from interface files, via
+                        -- TcEnv.setGlobalTypeEnv. It's important that this
+                        -- includes the stuff in checkHiBootIface,
+                        -- because the latter might add new bindings for
+                        -- boot_dfuns, which may be mentioned in imported
+                        -- unfoldings.
+
+                        -- Don't need to rename the Haddock documentation,
+                        -- it's not parsed by GHC anymore.
+                        tcg_env <- return (tcg_env
+                                           { tcg_doc_hdr = maybe_doc_hdr })
+                      ; -- Report unused names
+                        -- Do this /after/ typeinference, so that when reporting
+                        -- a function with no type signature we can give the
+                        -- inferred type
+                        reportUnusedNames export_ies tcg_env
+                      ; -- add extra source files to tcg_dependent_files
+                        addDependentFiles src_files
+                      ; tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env
+                      ; -- Dump output and return
+                        tcDump tcg_env
+                      ; return tcg_env }
+               }
+        }
+      }
+
+implicitPreludeWarn :: SDoc
+implicitPreludeWarn
+  = text "Module `Prelude' implicitly imported"
+
+{-
+************************************************************************
+*                                                                      *
+                Import declarations
+*                                                                      *
+************************************************************************
+-}
+
+tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv
+tcRnImports hsc_env import_decls
+  = do  { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;
+
+        ; this_mod <- getModule
+        ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
+              ; dep_mods = imp_dep_mods imports
+
+                -- We want instance declarations from all home-package
+                -- modules below this one, including boot modules, except
+                -- ourselves.  The 'except ourselves' is so that we don't
+                -- get the instances from this module's hs-boot file.  This
+                -- filtering also ensures that we don't see instances from
+                -- modules batch (@--make@) compiled before this one, but
+                -- which are not below this one.
+              ; want_instances :: ModuleName -> Bool
+              ; want_instances mod = mod `elemUFM` dep_mods
+                                   && mod /= moduleName this_mod
+              ; (home_insts, home_fam_insts) = hptInstances hsc_env
+                                                            want_instances
+              } ;
+
+                -- Record boot-file info in the EPS, so that it's
+                -- visible to loadHiBootInterface in tcRnSrcDecls,
+                -- and any other incrementally-performed imports
+        ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
+
+                -- Update the gbl env
+        ; updGblEnv ( \ gbl ->
+            gbl {
+              tcg_rdr_env      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,
+              tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
+              tcg_rn_imports   = rn_imports,
+              tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
+              tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
+                                                      home_fam_insts,
+              tcg_hpc          = hpc_info
+            }) $ do {
+
+        ; traceRn "rn1" (ppr (imp_dep_mods imports))
+                -- Fail if there are any errors so far
+                -- The error printing (if needed) takes advantage
+                -- of the tcg_env we have now set
+--      ; traceIf (text "rdr_env: " <+> ppr rdr_env)
+        ; failIfErrsM
+
+                -- Load any orphan-module (including orphan family
+                -- instance-module) interfaces, so that their rules and
+                -- instance decls will be found.  But filter out a
+                -- self hs-boot: these instances will be checked when
+                -- we define them locally.
+                -- (We don't need to load non-orphan family instance
+                -- modules until we either try to use the instances they
+                -- define, or define our own family instances, at which
+                -- point we need to check them for consistency.)
+        ; loadModuleInterfaces (text "Loading orphan modules")
+                               (filter (/= this_mod) (imp_orphs imports))
+
+                -- Check type-family consistency between imports.
+                -- See Note [The type family instance consistency story]
+        ; traceRn "rn1: checking family instance consistency {" empty
+        ; let { dir_imp_mods = moduleEnvKeys
+                             . imp_mods
+                             $ imports }
+        ; checkFamInstConsistency dir_imp_mods
+        ; traceRn "rn1: } checking family instance consistency" empty
+
+        ; getGblEnv } }
+
+{-
+************************************************************************
+*                                                                      *
+        Type-checking the top level of a module
+*                                                                      *
+************************************************************************
+-}
+
+tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
+             -> [LHsDecl GhcPs]               -- Declarations
+             -> TcM TcGblEnv
+tcRnSrcDecls explicit_mod_hdr decls
+ = do { -- Do all the declarations
+      ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls
+
+        -- Check for the 'main' declaration
+        -- Must do this inside the captureTopConstraints
+      ; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $
+                               -- always set envs *before* captureTopConstraints
+                               captureTopConstraints $
+                               checkMain explicit_mod_hdr
+
+      ; setEnvs (tcg_env, tcl_env) $ do {
+
+             --         Simplify constraints
+             --
+             -- We do this after checkMain, so that we use the type info
+             -- that checkMain adds
+             --
+             -- We do it with both global and local env in scope:
+             --  * the global env exposes the instances to simplifyTop
+             --  * the local env exposes the local Ids to simplifyTop,
+             --    so that we get better error messages (monomorphism restriction)
+      ; new_ev_binds <- {-# SCC "simplifyTop" #-}
+                        simplifyTop (lie `andWC` lie_main)
+
+        -- Emit Typeable bindings
+      ; tcg_env <- mkTypeableBinds
+
+
+      ; traceTc "Tc9" empty
+
+      ; failIfErrsM     -- Don't zonk if there have been errors
+                        -- It's a waste of time; and we may get debug warnings
+                        -- about strangely-typed TyCons!
+      ; traceTc "Tc10" empty
+
+        -- Zonk the final code.  This must be done last.
+        -- Even simplifyTop may do some unification.
+        -- This pass also warns about missing type signatures
+      ; (bind_env, ev_binds', binds', fords', imp_specs', rules')
+            <- zonkTcGblEnv new_ev_binds tcg_env
+
+        -- Finalizers must run after constraints are simplified, or some types
+        -- might not be complete when using reify (see #12777).
+        -- and also after we zonk the first time because we run typed splices
+        -- in the zonker which gives rise to the finalisers.
+      ; (tcg_env_mf, _) <- setGblEnv (clearTcGblEnv tcg_env)
+                                     run_th_modfinalizers
+      ; finishTH
+      ; traceTc "Tc11" empty
+
+      ; -- zonk the new bindings arising from running the finalisers.
+        -- This won't give rise to any more finalisers as you can't nest
+        -- finalisers inside finalisers.
+      ; (bind_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf)
+            <- zonkTcGblEnv emptyBag tcg_env_mf
+
+
+      ; let { final_type_env = plusTypeEnv (tcg_type_env tcg_env)
+                                (plusTypeEnv bind_env_mf bind_env)
+            ; tcg_env' = tcg_env_mf
+                          { tcg_binds    = binds' `unionBags` binds_mf,
+                            tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf ,
+                            tcg_imp_specs = imp_specs' ++ imp_specs_mf ,
+                            tcg_rules    = rules' ++ rules_mf ,
+                            tcg_fords    = fords' ++ fords_mf } } ;
+
+      ; setGlobalTypeEnv tcg_env' final_type_env
+
+   } }
+
+zonkTcGblEnv :: Bag EvBind -> TcGblEnv
+             -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc,
+                       [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc])
+zonkTcGblEnv new_ev_binds tcg_env =
+  let TcGblEnv {   tcg_binds     = binds,
+                   tcg_ev_binds  = cur_ev_binds,
+                   tcg_imp_specs = imp_specs,
+                   tcg_rules     = rules,
+                   tcg_fords     = fords } = tcg_env
+
+      all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
+
+  in {-# SCC "zonkTopDecls" #-}
+      zonkTopDecls all_ev_binds binds rules imp_specs fords
+
+
+-- | Remove accumulated bindings, rules and so on from TcGblEnv
+clearTcGblEnv :: TcGblEnv -> TcGblEnv
+clearTcGblEnv tcg_env
+  = tcg_env { tcg_binds    = emptyBag,
+              tcg_ev_binds = emptyBag ,
+              tcg_imp_specs = [],
+              tcg_rules    = [],
+              tcg_fords    = [] }
+
+-- | Runs TH finalizers and renames and typechecks the top-level declarations
+-- that they could introduce.
+run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)
+run_th_modfinalizers = do
+  th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
+  th_modfinalizers <- readTcRef th_modfinalizers_var
+  if null th_modfinalizers
+  then getEnvs
+  else do
+    writeTcRef th_modfinalizers_var []
+    let run_finalizer (lcl_env, f) =
+            setLclEnv lcl_env (runRemoteModFinalizers f)
+
+    (_, lie_th) <- captureTopConstraints $ mapM_ run_finalizer th_modfinalizers
+      -- Finalizers can add top-level declarations with addTopDecls, so
+      -- we have to run tc_rn_src_decls to get them
+    (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls []
+    setEnvs (tcg_env, tcl_env) $ do
+      -- Subsequent rounds of finalizers run after any new constraints are
+      -- simplified, or some types might not be complete when using reify
+      -- (see #12777).
+      new_ev_binds <- {-# SCC "simplifyTop2" #-}
+                      simplifyTop (lie_th `andWC` lie_top_decls)
+      addTopEvBinds new_ev_binds run_th_modfinalizers
+        -- addTopDecls can add declarations which add new finalizers.
+
+tc_rn_src_decls :: [LHsDecl GhcPs]
+                -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)
+-- Loops around dealing with each top level inter-splice group
+-- in turn, until it's dealt with the entire module
+-- Never emits constraints; calls captureTopConstraints internally
+tc_rn_src_decls ds
+ = {-# SCC "tc_rn_src_decls" #-}
+   do { (first_group, group_tail) <- findSplice ds
+                -- If ds is [] we get ([], Nothing)
+
+        -- Deal with decls up to, but not including, the first splice
+      ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group
+                -- rnTopSrcDecls fails if there are any errors
+
+        -- Get TH-generated top-level declarations and make sure they don't
+        -- contain any splices since we don't handle that at the moment
+        --
+        -- The plumbing here is a bit odd: see Trac #10853
+      ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
+      ; th_ds <- readTcRef th_topdecls_var
+      ; writeTcRef th_topdecls_var []
+
+      ; (tcg_env, rn_decls) <-
+            if null th_ds
+            then return (tcg_env, rn_decls)
+            else do { (th_group, th_group_tail) <- findSplice th_ds
+                    ; case th_group_tail of
+                        { Nothing -> return ()
+                        ; Just (SpliceDecl _ (dL->L loc _) _, _) ->
+                            setSrcSpan loc
+                            $ addErr (text
+                                ("Declaration splices are not "
+                                  ++ "permitted inside top-level "
+                                  ++ "declarations added with addTopDecls"))
+                        ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls"
+                        }
+                      -- Rename TH-generated top-level declarations
+                    ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env
+                        $ rnTopSrcDecls th_group
+
+                      -- Dump generated top-level declarations
+                    ; let msg = "top-level declarations added with addTopDecls"
+                    ; traceSplice
+                        $ SpliceInfo { spliceDescription = msg
+                                     , spliceIsDecl    = True
+                                     , spliceSource    = Nothing
+                                     , spliceGenerated = ppr th_rn_decls }
+                    ; return (tcg_env, appendGroups rn_decls th_rn_decls)
+                    }
+
+      -- Type check all declarations
+      -- NB: set the env **before** captureTopConstraints so that error messages
+      -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that
+      -- the captureTopConstraints must go here, not in tcRnSrcDecls.
+      ; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $
+                                      captureTopConstraints $
+                                      tcTopSrcDecls rn_decls
+
+        -- If there is no splice, we're nearly done
+      ; setEnvs (tcg_env, tcl_env) $
+        case group_tail of
+          { Nothing -> return (tcg_env, tcl_env, lie1)
+
+            -- If there's a splice, we must carry on
+          ; Just (SpliceDecl _ (dL->L loc splice) _, rest_ds) ->
+            do { recordTopLevelSpliceLoc loc
+
+                 -- Rename the splice expression, and get its supporting decls
+               ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice
+
+                 -- Glue them on the front of the remaining decls and loop
+               ; (tcg_env, tcl_env, lie2) <-
+                   setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
+                   tc_rn_src_decls (spliced_decls ++ rest_ds)
+
+               ; return (tcg_env, tcl_env, lie1 `andWC` lie2)
+               }
+          ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls"
+          }
+      }
+
+{-
+************************************************************************
+*                                                                      *
+        Compiling hs-boot source files, and
+        comparing the hi-boot interface with the real thing
+*                                                                      *
+************************************************************************
+-}
+
+tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv
+tcRnHsBootDecls hsc_src decls
+   = do { (first_group, group_tail) <- findSplice decls
+
+                -- Rename the declarations
+        ; (tcg_env, HsGroup { hs_tyclds = tycl_decls
+                            , hs_derivds = deriv_decls
+                            , hs_fords  = for_decls
+                            , hs_defds  = def_decls
+                            , hs_ruleds = rule_decls
+                            , hs_annds  = _
+                            , hs_valds
+                                 = XValBindsLR (NValBinds val_binds val_sigs) })
+              <- rnTopSrcDecls first_group
+        -- The empty list is for extra dependencies coming from .hs-boot files
+        -- See Note [Extra dependencies from .hs-boot files] in RnSource
+        ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do {
+              -- NB: setGblEnv **before** captureTopConstraints so that
+              -- if the latter reports errors, it knows what's in scope
+
+                -- Check for illegal declarations
+        ; case group_tail of
+             Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d
+             Just (XSpliceDecl _, _) -> panic "tcRnHsBootDecls"
+             Nothing                  -> return ()
+        ; mapM_ (badBootDecl hsc_src "foreign") for_decls
+        ; mapM_ (badBootDecl hsc_src "default") def_decls
+        ; mapM_ (badBootDecl hsc_src "rule")    rule_decls
+
+                -- Typecheck type/class/instance decls
+        ; traceTc "Tc2 (boot)" empty
+        ; (tcg_env, inst_infos, _deriv_binds)
+             <- tcTyClsInstDecls tycl_decls deriv_decls val_binds
+        ; setGblEnv tcg_env     $ do {
+
+        -- Emit Typeable bindings
+        ; tcg_env <- mkTypeableBinds
+        ; setGblEnv tcg_env $ do {
+
+                -- Typecheck value declarations
+        ; traceTc "Tc5" empty
+        ; val_ids <- tcHsBootSigs val_binds val_sigs
+
+                -- Wrap up
+                -- No simplification or zonking to do
+        ; traceTc "Tc7a" empty
+        ; gbl_env <- getGblEnv
+
+                -- Make the final type-env
+                -- Include the dfun_ids so that their type sigs
+                -- are written into the interface file.
+        ; let { type_env0 = tcg_type_env gbl_env
+              ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
+              ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
+              ; dfun_ids = map iDFunId inst_infos
+              }
+
+        ; setGlobalTypeEnv gbl_env type_env2
+   }}}
+   ; traceTc "boot" (ppr lie); return gbl_env }
+
+badBootDecl :: HscSource -> String -> Located decl -> TcM ()
+badBootDecl hsc_src what (dL->L loc _)
+  = addErrAt loc (char 'A' <+> text what
+      <+> text "declaration is not (currently) allowed in a"
+      <+> (case hsc_src of
+            HsBootFile -> text "hs-boot"
+            HsigFile -> text "hsig"
+            _ -> panic "badBootDecl: should be an hsig or hs-boot file")
+      <+> text "file")
+
+{-
+Once we've typechecked the body of the module, we want to compare what
+we've found (gathered in a TypeEnv) with the hi-boot details (if any).
+-}
+
+checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv
+-- Compare the hi-boot file for this module (if there is one)
+-- with the type environment we've just come up with
+-- In the common case where there is no hi-boot file, the list
+-- of boot_names is empty.
+
+checkHiBootIface tcg_env boot_info
+  | NoSelfBoot <- boot_info  -- Common case
+  = return tcg_env
+
+  | HsBootFile <- tcg_src tcg_env   -- Current module is already a hs-boot file!
+  = return tcg_env
+
+  | SelfBoot { sb_mds = boot_details } <- boot_info
+  , TcGblEnv { tcg_binds    = binds
+             , tcg_insts    = local_insts
+             , tcg_type_env = local_type_env
+             , tcg_exports  = local_exports } <- tcg_env
+  = do  { -- This code is tricky, see Note [DFun knot-tying]
+        ; dfun_prs <- checkHiBootIface' local_insts local_type_env
+                                        local_exports boot_details
+
+        -- Now add the boot-dfun bindings  $fxblah = $fblah
+        -- to (a) the type envt, and (b) the top-level bindings
+        ; let boot_dfuns = map fst dfun_prs
+              type_env'  = extendTypeEnvWithIds local_type_env boot_dfuns
+              dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
+                                     | (boot_dfun, dfun) <- dfun_prs ]
+              tcg_env_w_binds
+                = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
+
+        ; type_env' `seq`
+             -- Why the seq?  Without, we will put a TypeEnv thunk in
+             -- tcg_type_env_var.  That thunk will eventually get
+             -- forced if we are typechecking interfaces, but that
+             -- is no good if we are trying to typecheck the very
+             -- DFun we were going to put in.
+             -- TODO: Maybe setGlobalTypeEnv should be strict.
+          setGlobalTypeEnv tcg_env_w_binds type_env' }
+
+  | otherwise = panic "checkHiBootIface: unreachable code"
+
+{- Note [DFun impedance matching]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We return a list of "impedance-matching" bindings for the dfuns
+defined in the hs-boot file, such as
+          $fxEqT = $fEqT
+We need these because the module and hi-boot file might differ in
+the name it chose for the dfun: the name of a dfun is not
+uniquely determined by its type; there might be multiple dfuns
+which, individually, would map to the same name (in which case
+we have to disambiguate them.)  There's no way for the hi file
+to know exactly what disambiguation to use... without looking
+at the hi-boot file itself.
+
+In fact, the names will always differ because we always pick names
+prefixed with "$fx" for boot dfuns, and "$f" for real dfuns
+(so that this impedance matching is always possible).
+
+Note [DFun knot-tying]
+~~~~~~~~~~~~~~~~~~~~~~
+The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from
+typechecking the hi-boot file that we are presently implementing.
+Suppose we are typechecking the module A: when we typecheck the
+hi-boot file, whenever we see an identifier A.T, we knot-tie this
+identifier to the *local* type environment (via if_rec_types.)  The
+contract then is that we don't *look* at 'SelfBootInfo' until we've
+finished typechecking the module and updated the type environment with
+the new tycons and ids.
+
+This most works well, but there is one problem: DFuns!  We do not want
+to look at the mb_insts of the ModDetails in SelfBootInfo, because a
+dfun in one of those ClsInsts is gotten (in TcIface.tcIfaceInst) by a
+(lazily evaluated) lookup in the if_rec_types.  We could extend the
+type env, do a setGloblaTypeEnv etc; but that all seems very indirect.
+It is much more directly simply to extract the DFunIds from the
+md_types of the SelfBootInfo.
+
+See Trac #4003, #16038 for why we need to take care here.
+-}
+
+checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
+                  -> ModDetails -> TcM [(Id, Id)]
+-- Variant which doesn't require a full TcGblEnv; you could get the
+-- local components from another ModDetails.
+checkHiBootIface'
+        local_insts local_type_env local_exports
+        (ModDetails { md_types = boot_type_env
+                    , md_fam_insts = boot_fam_insts
+                    , md_exports = boot_exports })
+  = do  { traceTc "checkHiBootIface" $ vcat
+             [ ppr boot_type_env, ppr boot_exports]
+
+                -- Check the exports of the boot module, one by one
+        ; mapM_ check_export boot_exports
+
+                -- Check for no family instances
+        ; unless (null boot_fam_insts) $
+            panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
+                   "instances in boot files yet...")
+            -- FIXME: Why?  The actual comparison is not hard, but what would
+            --        be the equivalent to the dfun bindings returned for class
+            --        instances?  We can't easily equate tycons...
+
+                -- Check instance declarations
+                -- and generate an impedance-matching binding
+        ; mb_dfun_prs <- mapM check_cls_inst boot_dfuns
+
+        ; failIfErrsM
+
+        ; return (catMaybes mb_dfun_prs) }
+
+  where
+    boot_dfun_names = map idName boot_dfuns
+    boot_dfuns      = filter isDFunId $ typeEnvIds boot_type_env
+       -- NB: boot_dfuns is /not/ defined thus: map instanceDFunId md_insts
+       --     We don't want to look at md_insts!
+       --     Why not?  See Note [DFun knot-tying]
+
+    check_export boot_avail     -- boot_avail is exported by the boot iface
+      | name `elem` boot_dfun_names = return ()
+      | isWiredInName name          = return () -- No checking for wired-in names.  In particular,
+                                                -- 'error' is handled by a rather gross hack
+                                                -- (see comments in GHC.Err.hs-boot)
+
+        -- Check that the actual module exports the same thing
+      | not (null missing_names)
+      = addErrAt (nameSrcSpan (head missing_names))
+                 (missingBootThing True (head missing_names) "exported by")
+
+        -- If the boot module does not *define* the thing, we are done
+        -- (it simply re-exports it, and names match, so nothing further to do)
+      | isNothing mb_boot_thing = return ()
+
+        -- Check that the actual module also defines the thing, and
+        -- then compare the definitions
+      | Just real_thing <- lookupTypeEnv local_type_env name,
+        Just boot_thing <- mb_boot_thing
+      = checkBootDeclM True boot_thing real_thing
+
+      | otherwise
+      = addErrTc (missingBootThing True name "defined in")
+      where
+        name          = availName boot_avail
+        mb_boot_thing = lookupTypeEnv boot_type_env name
+        missing_names = case lookupNameEnv local_export_env name of
+                          Nothing    -> [name]
+                          Just avail -> availNames boot_avail `minusList` availNames avail
+
+    local_export_env :: NameEnv AvailInfo
+    local_export_env = availsToNameEnv local_exports
+
+    check_cls_inst :: DFunId -> TcM (Maybe (Id, Id))
+        -- Returns a pair of the boot dfun in terms of the equivalent
+        -- real dfun. Delicate (like checkBootDecl) because it depends
+        -- on the types lining up precisely even to the ordering of
+        -- the type variables in the foralls.
+    check_cls_inst boot_dfun
+      | (real_dfun : _) <- find_real_dfun boot_dfun
+      , let local_boot_dfun = Id.mkExportedVanillaId
+                                  (idName boot_dfun) (idType real_dfun)
+      = return (Just (local_boot_dfun, real_dfun))
+          -- Two tricky points here:
+          --
+          --  * The local_boot_fun should have a Name from the /boot-file/,
+          --    but type from the dfun defined in /this module/.
+          --    That ensures that the TyCon etc inside the type are
+          --    the ones defined in this module, not the ones gotten
+          --    from the hi-boot file, which may have a lot less info
+          --    (Trac #8743, comment:10).
+          --
+          --  * The DFunIds from boot_details are /GlobalIds/, because
+          --    they come from typechecking M.hi-boot.
+          --    But all bindings in this module should be for /LocalIds/,
+          --    otherwise dependency analysis fails (Trac #16038). This
+          --    is another reason for using mkExportedVanillaId, rather
+          --    that modifying boot_dfun, to make local_boot_fun.
+
+      | otherwise
+      = setSrcSpan (getLoc (getName boot_dfun)) $
+        do { traceTc "check_cls_inst" $ vcat
+                [ text "local_insts"  <+>
+                     vcat (map (ppr . idType . instanceDFunId) local_insts)
+                , text "boot_dfun_ty" <+> ppr (idType boot_dfun) ]
+
+           ; addErrTc (instMisMatch boot_dfun)
+           ; return Nothing }
+
+    find_real_dfun :: DFunId -> [DFunId]
+    find_real_dfun boot_dfun
+       = [dfun | inst <- local_insts
+               , let dfun = instanceDFunId inst
+               , idType dfun `eqType` boot_dfun_ty ]
+       where
+          boot_dfun_ty   = idType boot_dfun
+
+
+-- In general, to perform these checks we have to
+-- compare the TyThing from the .hi-boot file to the TyThing
+-- in the current source file.  We must be careful to allow alpha-renaming
+-- where appropriate, and also the boot declaration is allowed to omit
+-- constructors and class methods.
+--
+-- See rnfail055 for a good test of this stuff.
+
+-- | Compares two things for equivalence between boot-file and normal code,
+-- reporting an error if they don't match up.
+checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)
+               -> TyThing -> TyThing -> TcM ()
+checkBootDeclM is_boot boot_thing real_thing
+  = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err ->
+       addErrAt span
+                (bootMisMatch is_boot err real_thing boot_thing)
+  where
+    -- Here we use the span of the boot thing or, if it doesn't have a sensible
+    -- span, that of the real thing,
+    span
+      | let span = nameSrcSpan (getName boot_thing)
+      , isGoodSrcSpan span
+      = span
+      | otherwise
+      = nameSrcSpan (getName real_thing)
+
+-- | Compares the two things for equivalence between boot-file and normal
+-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@
+-- failure. If the difference will be apparent to the user, @Just empty@ is
+-- perfectly suitable.
+checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc
+
+checkBootDecl _ (AnId id1) (AnId id2)
+  = ASSERT(id1 == id2)
+    check (idType id1 `eqType` idType id2)
+          (text "The two types are different")
+
+checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2)
+  = checkBootTyCon is_boot tc1 tc2
+
+checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _))
+  = pprPanic "checkBootDecl" (ppr dc1)
+
+checkBootDecl _ _ _ = Just empty -- probably shouldn't happen
+
+-- | Combines two potential error messages
+andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc
+Nothing `andThenCheck` msg     = msg
+msg     `andThenCheck` Nothing = msg
+Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2)
+infixr 0 `andThenCheck`
+
+-- | If the test in the first parameter is True, succeed with @Nothing@;
+-- otherwise, return the provided check
+checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc
+checkUnless True  _ = Nothing
+checkUnless False k = k
+
+-- | Run the check provided for every pair of elements in the lists.
+-- The provided SDoc should name the element type, in the plural.
+checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc
+            -> Maybe SDoc
+checkListBy check_fun as bs whats = go [] as bs
+  where
+    herald = text "The" <+> whats <+> text "do not match"
+
+    go []   [] [] = Nothing
+    go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs))
+    go docs (x:xs) (y:ys) = case check_fun x y of
+      Just doc -> go (doc:docs) xs ys
+      Nothing  -> go docs       xs ys
+    go _    _  _ = Just (hang (herald <> colon)
+                            2 (text "There are different numbers of" <+> whats))
+
+-- | If the test in the first parameter is True, succeed with @Nothing@;
+-- otherwise, fail with the given SDoc.
+check :: Bool -> SDoc -> Maybe SDoc
+check True  _   = Nothing
+check False doc = Just doc
+
+-- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends.
+checkSuccess :: Maybe SDoc
+checkSuccess = Nothing
+
+----------------
+checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc
+checkBootTyCon is_boot tc1 tc2
+  | not (eqType (tyConKind tc1) (tyConKind tc2))
+  = Just $ text "The types have different kinds"    -- First off, check the kind
+
+  | Just c1 <- tyConClass_maybe tc1
+  , Just c2 <- tyConClass_maybe tc2
+  , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
+          = classExtraBigSig c1
+        (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
+          = classExtraBigSig c2
+  , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
+  = let
+       eqSig (id1, def_meth1) (id2, def_meth2)
+         = check (name1 == name2)
+                 (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
+                  text "are different") `andThenCheck`
+           check (eqTypeX env op_ty1 op_ty2)
+                 (text "The types of" <+> pname1 <+>
+                  text "are different") `andThenCheck`
+           if is_boot
+               then check (eqMaybeBy eqDM def_meth1 def_meth2)
+                          (text "The default methods associated with" <+> pname1 <+>
+                           text "are different")
+               else check (subDM op_ty1 def_meth1 def_meth2)
+                          (text "The default methods associated with" <+> pname1 <+>
+                           text "are not compatible")
+         where
+          name1 = idName id1
+          name2 = idName id2
+          pname1 = quotes (ppr name1)
+          pname2 = quotes (ppr name2)
+          (_, rho_ty1) = splitForAllTys (idType id1)
+          op_ty1 = funResultTy rho_ty1
+          (_, rho_ty2) = splitForAllTys (idType id2)
+          op_ty2 = funResultTy rho_ty2
+
+       eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2)
+         = checkBootTyCon is_boot tc1 tc2 `andThenCheck`
+           check (eqATDef def_ats1 def_ats2)
+                 (text "The associated type defaults differ")
+
+       eqDM (_, VanillaDM)    (_, VanillaDM)    = True
+       eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2
+       eqDM _ _ = False
+
+       -- NB: first argument is from hsig, second is from real impl.
+       -- Order of pattern matching matters.
+       subDM _ Nothing _ = True
+       subDM _ _ Nothing = False
+       -- If the hsig wrote:
+       --
+       --   f :: a -> a
+       --   default f :: a -> a
+       --
+       -- this should be validly implementable using an old-fashioned
+       -- vanilla default method.
+       subDM t1 (Just (_, GenericDM t2)) (Just (_, VanillaDM))
+        = eqTypeX env t1 t2
+       -- This case can occur when merging signatures
+       subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2))
+        = eqTypeX env t1 t2
+       subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True
+       subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2))
+        = eqTypeX env t1 t2
+
+       -- Ignore the location of the defaults
+       eqATDef Nothing             Nothing             = True
+       eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2
+       eqATDef _ _ = False
+
+       eqFD (as1,bs1) (as2,bs2) =
+         eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
+         eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
+    in
+    checkRoles roles1 roles2 `andThenCheck`
+          -- Checks kind of class
+    check (eqListBy eqFD clas_fds1 clas_fds2)
+          (text "The functional dependencies do not match") `andThenCheck`
+    checkUnless (isAbstractTyCon tc1) $
+    check (eqListBy (eqTypeX env) sc_theta1 sc_theta2)
+          (text "The class constraints do not match") `andThenCheck`
+    checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`
+    checkListBy eqAT ats1 ats2 (text "associated types") `andThenCheck`
+    check (classMinimalDef c1 `BF.implies` classMinimalDef c2)
+        (text "The MINIMAL pragmas are not compatible")
+
+  | Just syn_rhs1 <- synTyConRhs_maybe tc1
+  , Just syn_rhs2 <- synTyConRhs_maybe tc2
+  , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
+  = ASSERT(tc1 == tc2)
+    checkRoles roles1 roles2 `andThenCheck`
+    check (eqTypeX env syn_rhs1 syn_rhs2) empty   -- nothing interesting to say
+  -- This allows abstract 'data T a' to be implemented using 'type T = ...'
+  -- and abstract 'class K a' to be implement using 'type K = ...'
+  -- See Note [Synonyms implement abstract data]
+  | not is_boot -- don't support for hs-boot yet
+  , isAbstractTyCon tc1
+  , Just (tvs, ty) <- synTyConDefn_maybe tc2
+  , Just (tc2', args) <- tcSplitTyConApp_maybe ty
+  = checkSynAbsData tvs ty tc2' args
+    -- TODO: When it's a synonym implementing a class, we really
+    -- should check if the fundeps are satisfied, but
+    -- there is not an obvious way to do this for a constraint synonym.
+    -- So for now, let it all through (it won't cause segfaults, anyway).
+    -- Tracked at #12704.
+
+  -- This allows abstract 'data T :: Nat' to be implemented using
+  -- 'type T = 42' Since the kinds already match (we have checked this
+  -- upfront) all we need to check is that the implementation 'type T
+  -- = ...' defined an actual literal.  See #15138 for the case this
+  -- handles.
+  | not is_boot
+  , isAbstractTyCon tc1
+  , Just (_,ty2) <- synTyConDefn_maybe tc2
+  , isJust (isLitTy ty2)
+  = Nothing
+
+  | Just fam_flav1 <- famTyConFlav_maybe tc1
+  , Just fam_flav2 <- famTyConFlav_maybe tc2
+  = ASSERT(tc1 == tc2)
+    let eqFamFlav OpenSynFamilyTyCon   OpenSynFamilyTyCon = True
+        eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True
+        -- This case only happens for hsig merging:
+        eqFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon = True
+        eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
+        eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
+        eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
+            = eqClosedFamilyAx ax1 ax2
+        eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2
+        eqFamFlav _ _ = False
+        injInfo1 = tyConInjectivityInfo tc1
+        injInfo2 = tyConInjectivityInfo tc2
+    in
+    -- check equality of roles, family flavours and injectivity annotations
+    -- (NB: Type family roles are always nominal. But the check is
+    -- harmless enough.)
+    checkRoles roles1 roles2 `andThenCheck`
+    check (eqFamFlav fam_flav1 fam_flav2)
+        (whenPprDebug $
+            text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+>
+            text "do not match") `andThenCheck`
+    check (injInfo1 == injInfo2) (text "Injectivities do not match")
+
+  | isAlgTyCon tc1 && isAlgTyCon tc2
+  , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
+  = ASSERT(tc1 == tc2)
+    checkRoles roles1 roles2 `andThenCheck`
+    check (eqListBy (eqTypeX env)
+                     (tyConStupidTheta tc1) (tyConStupidTheta tc2))
+          (text "The datatype contexts do not match") `andThenCheck`
+    eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2)
+
+  | otherwise = Just empty   -- two very different types -- should be obvious
+  where
+    roles1 = tyConRoles tc1 -- the abstract one
+    roles2 = tyConRoles tc2
+    roles_msg = text "The roles do not match." $$
+                (text "Roles on abstract types default to" <+>
+                 quotes (text "representational") <+> text "in boot files.")
+
+    roles_subtype_msg = text "The roles are not compatible:" $$
+                        text "Main module:" <+> ppr roles2 $$
+                        text "Hsig file:" <+> ppr roles1
+
+    checkRoles r1 r2
+      | is_boot || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping]
+      = check (r1 == r2) roles_msg
+      | otherwise = check (r2 `rolesSubtypeOf` r1) roles_subtype_msg
+
+    -- Note [Role subtyping]
+    -- ~~~~~~~~~~~~~~~~~~~~~
+    -- In the current formulation of roles, role subtyping is only OK if the
+    -- "abstract" TyCon was not representationally injective.  Among the most
+    -- notable examples of non representationally injective TyCons are abstract
+    -- data, which can be implemented via newtypes (which are not
+    -- representationally injective).  The key example is
+    -- in this example from #13140:
+    --
+    --      -- In an hsig file
+    --      data T a -- abstract!
+    --      type role T nominal
+    --
+    --      -- Elsewhere
+    --      foo :: Coercible (T a) (T b) => a -> b
+    --      foo x = x
+    --
+    -- We must NOT allow foo to typecheck, because if we instantiate
+    -- T with a concrete data type with a phantom role would cause
+    -- Coercible (T a) (T b) to be provable.  Fortunately, if T is not
+    -- representationally injective, we cannot make the inference that a ~N b if
+    -- T a ~R T b.
+    --
+    -- Unconditional role subtyping would be possible if we setup
+    -- an extra set of roles saying when we can project out coercions
+    -- (we call these proj-roles); then it would NOT be valid to instantiate T
+    -- with a data type at phantom since the proj-role subtyping check
+    -- would fail.  See #13140 for more details.
+    --
+    -- One consequence of this is we get no role subtyping for non-abstract
+    -- data types in signatures. Suppose you have:
+    --
+    --      signature A where
+    --          type role T nominal
+    --          data T a = MkT
+    --
+    -- If you write this, we'll treat T as injective, and make inferences
+    -- like T a ~R T b ==> a ~N b (mkNthCo).  But if we can
+    -- subsequently replace T with one at phantom role, we would then be able to
+    -- infer things like T Int ~R T Bool which is bad news.
+    --
+    -- We could allow role subtyping here if we didn't treat *any* data types
+    -- defined in signatures as injective.  But this would be a bit surprising,
+    -- replacing a data type in a module with one in a signature could cause
+    -- your code to stop typechecking (whereas if you made the type abstract,
+    -- it is more understandable that the type checker knows less).
+    --
+    -- It would have been best if this was purely a question of defaults
+    -- (i.e., a user could explicitly ask for one behavior or another) but
+    -- the current role system isn't expressive enough to do this.
+    -- Having explict proj-roles would solve this problem.
+
+    rolesSubtypeOf [] [] = True
+    -- NB: this relation is the OPPOSITE of the subroling relation
+    rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys
+    rolesSubtypeOf _ _ = False
+
+    -- Note [Synonyms implement abstract data]
+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    -- An abstract data type or class can be implemented using a type synonym,
+    -- but ONLY if the type synonym is nullary and has no type family
+    -- applications.  This arises from two properties of skolem abstract data:
+    --
+    --    For any T (with some number of paramaters),
+    --
+    --    1. T is a valid type (it is "curryable"), and
+    --
+    --    2. T is valid in an instance head (no type families).
+    --
+    -- See also 'HowAbstract' and Note [Skolem abstract data].
+
+    -- | Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@,
+    -- check that this synonym is an acceptable implementation of @tc1@.
+    -- See Note [Synonyms implement abstract data]
+    checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc
+    checkSynAbsData tvs ty tc2' args =
+        check (null (tcTyFamInsts ty))
+              (text "Illegal type family application in implementation of abstract data.")
+                `andThenCheck`
+        check (null tvs)
+              (text "Illegal parameterized type synonym in implementation of abstract data." $$
+               text "(Try eta reducing your type synonym so that it is nullary.)")
+                `andThenCheck`
+        -- Don't report roles errors unless the type synonym is nullary
+        checkUnless (not (null tvs)) $
+            ASSERT( null roles2 )
+            -- If we have something like:
+            --
+            --  signature H where
+            --      data T a
+            --  module H where
+            --      data K a b = ...
+            --      type T = K Int
+            --
+            -- we need to drop the first role of K when comparing!
+            checkRoles roles1 (drop (length args) (tyConRoles tc2'))
+{-
+        -- Hypothetically, if we were allow to non-nullary type synonyms, here
+        -- is how you would check the roles
+        if length tvs == length roles1
+            then checkRoles roles1 roles2
+            else case tcSplitTyConApp_maybe ty of
+                    Just (tc2', args) ->
+                        checkRoles roles1 (drop (length args) (tyConRoles tc2') ++ roles2)
+                    Nothing -> Just roles_msg
+-}
+
+    eqAlgRhs _ AbstractTyCon _rhs2
+      = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon
+    eqAlgRhs _  tc1@DataTyCon{} tc2@DataTyCon{} =
+        checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")
+    eqAlgRhs _  tc1@NewTyCon{} tc2@NewTyCon{} =
+        eqCon (data_con tc1) (data_con tc2)
+    eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+>
+                           text "definition with a" <+> quotes (text "newtype") <+>
+                           text "definition")
+
+    eqCon c1 c2
+      =  check (name1 == name2)
+               (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>
+                text "differ") `andThenCheck`
+         check (dataConIsInfix c1 == dataConIsInfix c2)
+               (text "The fixities of" <+> pname1 <+>
+                text "differ") `andThenCheck`
+         check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs c2))
+               (text "The strictness annotations for" <+> pname1 <+>
+                text "differ") `andThenCheck`
+         check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2))
+               (text "The record label lists for" <+> pname1 <+>
+                text "differ") `andThenCheck`
+         check (eqType (dataConUserType c1) (dataConUserType c2))
+               (text "The types for" <+> pname1 <+> text "differ")
+      where
+        name1 = dataConName c1
+        name2 = dataConName c2
+        pname1 = quotes (ppr name1)
+        pname2 = quotes (ppr name2)
+
+    eqClosedFamilyAx Nothing Nothing  = True
+    eqClosedFamilyAx Nothing (Just _) = False
+    eqClosedFamilyAx (Just _) Nothing = False
+    eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 }))
+                     (Just (CoAxiom { co_ax_branches = branches2 }))
+      =  numBranches branches1 == numBranches branches2
+      && (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2)
+      where
+        branch_list1 = fromBranches branches1
+        branch_list2 = fromBranches branches2
+
+    eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1
+                                     , cab_lhs = lhs1, cab_rhs = rhs1 })
+                         (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2
+                                     , cab_lhs = lhs2, cab_rhs = rhs2 })
+      | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2
+      , Just env  <- eqVarBndrs env1        cvs1 cvs2
+      = eqListBy (eqTypeX env) lhs1 lhs2 &&
+        eqTypeX env rhs1 rhs2
+
+      | otherwise = False
+
+emptyRnEnv2 :: RnEnv2
+emptyRnEnv2 = mkRnEnv2 emptyInScopeSet
+
+----------------
+missingBootThing :: Bool -> Name -> String -> SDoc
+missingBootThing is_boot name what
+  = quotes (ppr name) <+> text "is exported by the"
+    <+> (if is_boot then text "hs-boot" else text "hsig")
+    <+> text "file, but not"
+    <+> text what <+> text "the module"
+
+badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc
+badReexportedBootThing dflags is_boot name name'
+  = withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $ vcat
+        [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig")
+           <+> text "file (re)exports" <+> quotes (ppr name)
+        , text "but the implementing module exports a different identifier" <+> quotes (ppr name')
+        ]
+
+bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc
+bootMisMatch is_boot extra_info real_thing boot_thing
+  = pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc
+  where
+    to_doc
+      = pprTyThingInContext $ showToHeader { ss_forall =
+                                              if is_boot
+                                                then ShowForAllMust
+                                                else ShowForAllWhen }
+
+    real_doc = to_doc real_thing
+    boot_doc = to_doc boot_thing
+
+    pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc
+    pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc
+      = vcat
+          [ ppr real_thing <+>
+            text "has conflicting definitions in the module",
+            text "and its" <+>
+              (if is_boot
+                then text "hs-boot file"
+                else text "hsig file"),
+            text "Main module:" <+> real_doc,
+              (if is_boot
+                then text "Boot file:  "
+                else text "Hsig file: ")
+                <+> boot_doc,
+            extra_info
+          ]
+
+instMisMatch :: DFunId -> SDoc
+instMisMatch dfun
+  = hang (text "instance" <+> ppr (idType dfun))
+       2 (text "is defined in the hs-boot file, but not in the module itself")
+
+{-
+************************************************************************
+*                                                                      *
+        Type-checking the top level of a module (continued)
+*                                                                      *
+************************************************************************
+-}
+
+rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn)
+-- Fails if there are any errors
+rnTopSrcDecls group
+ = do { -- Rename the source decls
+        traceRn "rn12" empty ;
+        (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
+        traceRn "rn13" empty ;
+        (tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ;
+        traceRn "rn13-plugin" empty ;
+
+        -- save the renamed syntax, if we want it
+        let { tcg_env'
+                | Just grp <- tcg_rn_decls tcg_env
+                  = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
+                | otherwise
+                   = tcg_env };
+
+                -- Dump trace of renaming part
+        rnDump rn_decls ;
+        return (tcg_env', rn_decls)
+   }
+
+tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv)
+tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
+                         hs_derivds = deriv_decls,
+                         hs_fords  = foreign_decls,
+                         hs_defds  = default_decls,
+                         hs_annds  = annotation_decls,
+                         hs_ruleds = rule_decls,
+                         hs_valds  = hs_val_binds@(XValBindsLR
+                                              (NValBinds val_binds val_sigs)) })
+ = do {         -- Type-check the type and class decls, and all imported decls
+                -- The latter come in via tycl_decls
+        traceTc "Tc2 (src)" empty ;
+
+                -- Source-language instances, including derivings,
+                -- and import the supporting declarations
+        traceTc "Tc3" empty ;
+        (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs))
+            <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;
+
+        setGblEnv tcg_env       $ do {
+
+                -- Generate Applicative/Monad proposal (AMP) warnings
+        traceTc "Tc3b" empty ;
+
+                -- Generate Semigroup/Monoid warnings
+        traceTc "Tc3c" empty ;
+        tcSemigroupWarnings ;
+
+                -- Foreign import declarations next.
+        traceTc "Tc4" empty ;
+        (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
+        tcExtendGlobalValEnv fi_ids     $ do {
+
+                -- Default declarations
+        traceTc "Tc4a" empty ;
+        default_tys <- tcDefaults default_decls ;
+        updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
+
+                -- Value declarations next.
+                -- It is important that we check the top-level value bindings
+                -- before the GHC-generated derived bindings, since the latter
+                -- may be defined in terms of the former. (For instance,
+                -- the bindings produced in a Data instance.)
+        traceTc "Tc5" empty ;
+        tc_envs <- tcTopBinds val_binds val_sigs;
+        setEnvs tc_envs $ do {
+
+                -- Now GHC-generated derived bindings, generics, and selectors
+                -- Do not generate warnings from compiler-generated code;
+                -- hence the use of discardWarnings
+        tc_envs@(tcg_env, tcl_env)
+            <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ;
+        setEnvs tc_envs $ do {  -- Environment doesn't change now
+
+                -- Second pass over class and instance declarations,
+                -- now using the kind-checked decls
+        traceTc "Tc6" empty ;
+        inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ;
+
+                -- Foreign exports
+        traceTc "Tc7" empty ;
+        (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ;
+
+                -- Annotations
+        annotations <- tcAnnotations annotation_decls ;
+
+                -- Rules
+        rules <- tcRules rule_decls ;
+
+                -- Wrap up
+        traceTc "Tc7a" empty ;
+        let { all_binds = inst_binds     `unionBags`
+                          foe_binds
+
+            ; fo_gres = fi_gres `unionBags` foe_gres
+            ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre)
+                                emptyFVs fo_gres
+
+            ; sig_names = mkNameSet (collectHsValBinders hs_val_binds)
+                          `minusNameSet` getTypeSigNames val_sigs
+
+                -- Extend the GblEnv with the (as yet un-zonked)
+                -- bindings, rules, foreign decls
+            ; tcg_env' = tcg_env { tcg_binds   = tcg_binds tcg_env `unionBags` all_binds
+                                 , tcg_sigs    = tcg_sigs tcg_env `unionNameSet` sig_names
+                                 , tcg_rules   = tcg_rules tcg_env
+                                                      ++ flattenRuleDecls rules
+                                 , tcg_anns    = tcg_anns tcg_env ++ annotations
+                                 , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations
+                                 , tcg_fords   = tcg_fords tcg_env ++ foe_decls ++ fi_decls
+                                 , tcg_dus     = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;
+                                 -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]
+
+        -- See Note [Newtype constructor usage in foreign declarations]
+        addUsedGREs (bagToList fo_gres) ;
+
+        return (tcg_env', tcl_env)
+    }}}}}}
+
+tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn"
+
+
+tcSemigroupWarnings :: TcM ()
+tcSemigroupWarnings = do
+    traceTc "tcSemigroupWarnings" empty
+    let warnFlag = Opt_WarnSemigroup
+    tcPreludeClashWarn warnFlag sappendName
+    tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName
+
+
+-- | Warn on local definitions of names that would clash with future Prelude
+-- elements.
+--
+--   A name clashes if the following criteria are met:
+--       1. It would is imported (unqualified) from Prelude
+--       2. It is locally defined in the current module
+--       3. It has the same literal name as the reference function
+--       4. It is not identical to the reference function
+tcPreludeClashWarn :: WarningFlag
+                   -> Name
+                   -> TcM ()
+tcPreludeClashWarn warnFlag name = do
+    { warn <- woptM warnFlag
+    ; when warn $ do
+    { traceTc "tcPreludeClashWarn/wouldBeImported" empty
+    -- Is the name imported (unqualified) from Prelude? (Point 4 above)
+    ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv
+    -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude
+    -- will not appear in rnImports automatically if it is set.)
+
+    -- Continue only the name is imported from Prelude
+    ; when (importedViaPrelude name rnImports) $ do
+      -- Handle 2.-4.
+    { rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv
+
+    ; let clashes :: GlobalRdrElt -> Bool
+          clashes x = isLocalDef && nameClashes && isNotInProperModule
+            where
+              isLocalDef = gre_lcl x == True
+              -- Names are identical ...
+              nameClashes = nameOccName (gre_name x) == nameOccName name
+              -- ... but not the actual definitions, because we don't want to
+              -- warn about a bad definition of e.g. <> in Data.Semigroup, which
+              -- is the (only) proper place where this should be defined
+              isNotInProperModule = gre_name x /= name
+
+          -- List of all offending definitions
+          clashingElts :: [GlobalRdrElt]
+          clashingElts = filter clashes rdrElts
+
+    ; traceTc "tcPreludeClashWarn/prelude_functions"
+                (hang (ppr name) 4 (sep [ppr clashingElts]))
+
+    ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (gre_name x)) (hsep
+              [ text "Local definition of"
+              , (quotes . ppr . nameOccName . gre_name) x
+              , text "clashes with a future Prelude name." ]
+              $$
+              text "This will become an error in a future release." )
+    ; mapM_ warn_msg clashingElts
+    }}}
+
+  where
+
+    -- Is the given name imported via Prelude?
+    --
+    -- Possible scenarios:
+    --   a) Prelude is imported implicitly, issue warnings.
+    --   b) Prelude is imported explicitly, but without mentioning the name in
+    --      question. Issue no warnings.
+    --   c) Prelude is imported hiding the name in question. Issue no warnings.
+    --   d) Qualified import of Prelude, no warnings.
+    importedViaPrelude :: Name
+                       -> [ImportDecl GhcRn]
+                       -> Bool
+    importedViaPrelude name = any importViaPrelude
+      where
+        isPrelude :: ImportDecl GhcRn -> Bool
+        isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME
+
+        -- Implicit (Prelude) import?
+        isImplicit :: ImportDecl GhcRn -> Bool
+        isImplicit = ideclImplicit
+
+        -- Unqualified import?
+        isUnqualified :: ImportDecl GhcRn -> Bool
+        isUnqualified = not . ideclQualified
+
+        -- List of explicitly imported (or hidden) Names from a single import.
+        --   Nothing -> No explicit imports
+        --   Just (False, <names>) -> Explicit import list of <names>
+        --   Just (True , <names>) -> Explicit hiding of <names>
+        importListOf :: ImportDecl GhcRn -> Maybe (Bool, [Name])
+        importListOf = fmap toImportList . ideclHiding
+          where
+            toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc))
+
+        isExplicit :: ImportDecl GhcRn -> Bool
+        isExplicit x = case importListOf x of
+            Nothing -> False
+            Just (False, explicit)
+                -> nameOccName name `elem`    map nameOccName explicit
+            Just (True, hidden)
+                -> nameOccName name `notElem` map nameOccName hidden
+
+        -- Check whether the given name would be imported (unqualified) from
+        -- an import declaration.
+        importViaPrelude :: ImportDecl GhcRn -> Bool
+        importViaPrelude x = isPrelude x
+                          && isUnqualified x
+                          && (isImplicit x || isExplicit x)
+
+
+-- Notation: is* is for classes the type is an instance of, should* for those
+--           that it should also be an instance of based on the corresponding
+--           is*.
+tcMissingParentClassWarn :: WarningFlag
+                         -> Name -- ^ Instances of this ...
+                         -> Name -- ^ should also be instances of this
+                         -> TcM ()
+tcMissingParentClassWarn warnFlag isName shouldName
+  = do { warn <- woptM warnFlag
+       ; when warn $ do
+       { traceTc "tcMissingParentClassWarn" empty
+       ; isClass'     <- tcLookupClass_maybe isName
+       ; shouldClass' <- tcLookupClass_maybe shouldName
+       ; case (isClass', shouldClass') of
+              (Just isClass, Just shouldClass) -> do
+                  { localInstances <- tcGetInsts
+                  ; let isInstance m = is_cls m == isClass
+                        isInsts = filter isInstance localInstances
+                  ; traceTc "tcMissingParentClassWarn/isInsts" (ppr isInsts)
+                  ; forM_ isInsts (checkShouldInst isClass shouldClass)
+                  }
+              (is',should') ->
+                  traceTc "tcMissingParentClassWarn/notIsShould"
+                          (hang (ppr isName <> text "/" <> ppr shouldName) 2 (
+                            (hsep [ quotes (text "Is"), text "lookup for"
+                                  , ppr isName
+                                  , text "resulted in", ppr is' ])
+                            $$
+                            (hsep [ quotes (text "Should"), text "lookup for"
+                                  , ppr shouldName
+                                  , text "resulted in", ppr should' ])))
+       }}
+  where
+    -- Check whether the desired superclass exists in a given environment.
+    checkShouldInst :: Class   -- ^ Class of existing instance
+                    -> Class   -- ^ Class there should be an instance of
+                    -> ClsInst -- ^ Existing instance
+                    -> TcM ()
+    checkShouldInst isClass shouldClass isInst
+      = do { instEnv <- tcGetInstEnvs
+           ; let (instanceMatches, shouldInsts, _)
+                    = lookupInstEnv False instEnv shouldClass (is_tys isInst)
+
+           ; traceTc "tcMissingParentClassWarn/checkShouldInst"
+                     (hang (ppr isInst) 4
+                         (sep [ppr instanceMatches, ppr shouldInsts]))
+
+           -- "<location>: Warning: <type> is an instance of <is> but not
+           -- <should>" e.g. "Foo is an instance of Monad but not Applicative"
+           ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst
+                 warnMsg (Just name:_) =
+                      addWarnAt (Reason warnFlag) instLoc $
+                           hsep [ (quotes . ppr . nameOccName) name
+                                , text "is an instance of"
+                                , (ppr . nameOccName . className) isClass
+                                , text "but not"
+                                , (ppr . nameOccName . className) shouldClass ]
+                                <> text "."
+                           $$
+                           hsep [ text "This will become an error in"
+                                , text "a future release." ]
+                 warnMsg _ = pure ()
+           ; when (null shouldInsts && null instanceMatches) $
+                  warnMsg (is_tcs isInst)
+           }
+
+    tcLookupClass_maybe :: Name -> TcM (Maybe Class)
+    tcLookupClass_maybe name = tcLookupImported_maybe name >>= \case
+        Succeeded (ATyCon tc) | cls@(Just _) <- tyConClass_maybe tc -> pure cls
+        _else -> pure Nothing
+
+
+---------------------------
+tcTyClsInstDecls :: [TyClGroup GhcRn]
+                 -> [LDerivDecl GhcRn]
+                 -> [(RecFlag, LHsBinds GhcRn)]
+                 -> TcM (TcGblEnv,            -- The full inst env
+                         [InstInfo GhcRn],    -- Source-code instance decls to
+                                              -- process; contains all dfuns for
+                                              -- this module
+                          HsValBinds GhcRn)   -- Supporting bindings for derived
+                                              -- instances
+
+tcTyClsInstDecls tycl_decls deriv_decls binds
+ = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $
+   tcAddPatSynPlaceholders (getPatSynBinds binds) $
+   do { (tcg_env, inst_info, datafam_deriv_info)
+          <- tcTyAndClassDecls tycl_decls ;
+      ; setGblEnv tcg_env $ do {
+          -- With the @TyClDecl@s and @InstDecl@s checked we're ready to
+          -- process the deriving clauses, including data family deriving
+          -- clauses discovered in @tcTyAndClassDecls@.
+          --
+          -- Careful to quit now in case there were instance errors, so that
+          -- the deriving errors don't pile up as well.
+          ; failIfErrsM
+          ; let tyclds = tycl_decls >>= group_tyclds
+          ; (tcg_env', inst_info', val_binds)
+              <- tcInstDeclsDeriv datafam_deriv_info tyclds deriv_decls
+          ; setGblEnv tcg_env' $ do {
+                failIfErrsM
+              ; pure (tcg_env', inst_info' ++ inst_info, val_binds)
+      }}}
+
+{- *********************************************************************
+*                                                                      *
+        Checking for 'main'
+*                                                                      *
+************************************************************************
+-}
+
+checkMain :: Bool  -- False => no 'module M(..) where' header at all
+          -> TcM TcGblEnv
+-- If we are in module Main, check that 'main' is defined.
+checkMain explicit_mod_hdr
+ = do   { dflags  <- getDynFlags
+        ; tcg_env <- getGblEnv
+        ; check_main dflags tcg_env explicit_mod_hdr }
+
+check_main :: DynFlags -> TcGblEnv -> Bool -> TcM TcGblEnv
+check_main dflags tcg_env explicit_mod_hdr
+ | mod /= main_mod
+ = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
+   return tcg_env
+
+ | otherwise
+ = do   { mb_main <- lookupGlobalOccRn_maybe main_fn
+                -- Check that 'main' is in scope
+                -- It might be imported from another module!
+        ; case mb_main of {
+             Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)
+                           ; complain_no_main
+                           ; return tcg_env } ;
+             Just main_name -> do
+
+        { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
+        ; let loc       = srcLocSpan (getSrcLoc main_name)
+        ; ioTyCon <- tcLookupTyCon ioTyConName
+        ; res_ty <- newFlexiTyVarTy liftedTypeKind
+        ; let io_ty = mkTyConApp ioTyCon [res_ty]
+              skol_info = SigSkol (FunSigCtxt main_name False) io_ty []
+        ; (ev_binds, main_expr)
+               <- checkConstraints skol_info [] [] $
+                  addErrCtxt mainCtxt    $
+                  tcMonoExpr (cL loc (HsVar noExt (cL loc main_name)))
+                             (mkCheckExpType io_ty)
+
+                -- See Note [Root-main Id]
+                -- Construct the binding
+                --      :Main.main :: IO res_ty = runMainIO res_ty main
+        ; run_main_id <- tcLookupId runMainIOName
+        ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN
+                                   (mkVarOccFS (fsLit "main"))
+                                   (getSrcSpan main_name)
+              ; root_main_id = Id.mkExportedVanillaId root_main_name
+                                                      (mkTyConApp ioTyCon [res_ty])
+              ; co  = mkWpTyApps [res_ty]
+              -- The ev_binds of the `main` function may contain deferred
+              -- type error when type of `main` is not `IO a`. The `ev_binds`
+              -- must be put inside `runMainIO` to ensure the deferred type
+              -- error can be emitted correctly. See Trac #13838.
+              ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $
+                        mkHsDictLet ev_binds main_expr
+              ; main_bind = mkVarBind root_main_id rhs }
+
+        ; return (tcg_env { tcg_main  = Just main_name,
+                            tcg_binds = tcg_binds tcg_env
+                                        `snocBag` main_bind,
+                            tcg_dus   = tcg_dus tcg_env
+                                        `plusDU` usesOnly (unitFV main_name)
+                        -- Record the use of 'main', so that we don't
+                        -- complain about it being defined but not used
+                 })
+    }}}
+  where
+    mod         = tcg_mod tcg_env
+    main_mod    = mainModIs dflags
+    main_fn     = getMainFun dflags
+    interactive = ghcLink dflags == LinkInMemory
+
+    complain_no_main = unless (interactive && not explicit_mod_hdr)
+                              (addErrTc noMainMsg)                  -- #12906
+        -- Without an explicit module header...
+          -- in interactive mode, don't worry about the absence of 'main'.
+          -- in other modes, add error message and go on with typechecking.
+
+    mainCtxt  = text "When checking the type of the" <+> pp_main_fn
+    noMainMsg = text "The" <+> pp_main_fn
+                <+> text "is not defined in module" <+> quotes (ppr main_mod)
+    pp_main_fn = ppMainFn main_fn
+
+-- | Get the unqualified name of the function to use as the \"main\" for the main module.
+-- Either returns the default name or the one configured on the command line with -main-is
+getMainFun :: DynFlags -> RdrName
+getMainFun dflags = case mainFunIs dflags of
+                      Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
+                      Nothing -> main_RDR_Unqual
+
+-- If we are in module Main, check that 'main' is exported.
+checkMainExported :: TcGblEnv -> TcM ()
+checkMainExported tcg_env
+  = case tcg_main tcg_env of
+      Nothing -> return () -- not the main module
+      Just main_name ->
+         do { dflags <- getDynFlags
+            ; let main_mod = mainModIs dflags
+            ; when (ghcLink dflags /= LinkInMemory) $      -- #11647
+                checkTc (main_name `elem`
+                           concatMap availNames (tcg_exports tcg_env)) $
+                   text "The" <+> ppMainFn (nameRdrName main_name) <+>
+                   text "is not exported by module" <+> quotes (ppr main_mod) }
+
+ppMainFn :: RdrName -> SDoc
+ppMainFn main_fn
+  | rdrNameOcc main_fn == mainOcc
+  = text "IO action" <+> quotes (ppr main_fn)
+  | otherwise
+  = text "main IO action" <+> quotes (ppr main_fn)
+
+mainOcc :: OccName
+mainOcc = mkVarOccFS (fsLit "main")
+
+{-
+Note [Root-main Id]
+~~~~~~~~~~~~~~~~~~~
+The function that the RTS invokes is always :Main.main, which we call
+root_main_id.  (Because GHC allows the user to have a module not
+called Main as the main module, we can't rely on the main function
+being called "Main.main".  That's why root_main_id has a fixed module
+":Main".)
+
+This is unusual: it's a LocalId whose Name has a Module from another
+module.  Tiresomely, we must filter it out again in MkIface, les we
+get two defns for 'main' in the interface file!
+
+
+*********************************************************
+*                                                       *
+                GHCi stuff
+*                                                       *
+*********************************************************
+-}
+
+runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)
+-- Initialise the tcg_inst_env with instances from all home modules.
+-- This mimics the more selective call to hptInstances in tcRnImports
+runTcInteractive hsc_env thing_inside
+  = initTcInteractive hsc_env $ withTcPlugins hsc_env $
+    do { traceTc "setInteractiveContext" $
+            vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
+                 , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)
+                 , text "ic_rn_gbl_env (LocalDef)" <+>
+                      vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt)
+                                                 , let local_gres = filter isLocalGRE gres
+                                                 , not (null local_gres) ]) ]
+
+       ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface
+                                          : dep_orphs (mi_deps iface))
+                                 (loadSrcInterface (text "runTcInteractive") m
+                                                   False mb_pkg)
+
+       ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
+            case i of                   -- force above: see #15111
+                IIModule n -> getOrphans n Nothing
+                IIDecl i ->
+                  let mb_pkg = sl_fs <$> ideclPkgQual i in
+                  getOrphans (unLoc (ideclName i)) mb_pkg
+
+       ; let imports = emptyImportAvails {
+                            imp_orphs = orphs
+                        }
+
+       ; (gbl_env, lcl_env) <- getEnvs
+       ; let gbl_env' = gbl_env {
+                           tcg_rdr_env      = ic_rn_gbl_env icxt
+                         , tcg_type_env     = type_env
+                         , tcg_inst_env     = extendInstEnvList
+                                               (extendInstEnvList (tcg_inst_env gbl_env) ic_insts)
+                                               home_insts
+                         , tcg_fam_inst_env = extendFamInstEnvList
+                                               (extendFamInstEnvList (tcg_fam_inst_env gbl_env)
+                                                                     ic_finsts)
+                                               home_fam_insts
+                         , tcg_field_env    = mkNameEnv con_fields
+                              -- setting tcg_field_env is necessary
+                              -- to make RecordWildCards work (test: ghci049)
+                         , tcg_fix_env      = ic_fix_env icxt
+                         , tcg_default      = ic_default icxt
+                              -- must calculate imp_orphs of the ImportAvails
+                              -- so that instance visibility is done correctly
+                         , tcg_imports      = imports
+                         }
+
+       ; lcl_env' <- tcExtendLocalTypeEnv lcl_env lcl_ids
+       ; setEnvs (gbl_env', lcl_env') thing_inside }
+  where
+    (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)
+
+    icxt                     = hsc_IC hsc_env
+    (ic_insts, ic_finsts)    = ic_instances icxt
+    (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt)
+
+    is_closed :: TyThing -> Either (Name, TcTyThing) TyThing
+    -- Put Ids with free type variables (always RuntimeUnks)
+    -- in the *local* type environment
+    -- See Note [Initialising the type environment for GHCi]
+    is_closed thing
+      | AnId id <- thing
+      , not (isTypeClosedLetBndr id)
+      = Left (idName id, ATcId { tct_id = id
+                               , tct_info = NotLetBound })
+      | otherwise
+      = Right thing
+
+    type_env1 = mkTypeEnvWithImplicits top_ty_things
+    type_env  = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts)
+                -- Putting the dfuns in the type_env
+                -- is just to keep Core Lint happy
+
+    con_fields = [ (dataConName c, dataConFieldLabels c)
+                 | ATyCon t <- top_ty_things
+                 , c <- tyConDataCons t ]
+
+
+{- Note [Initialising the type environment for GHCi]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Most of the Ids in ic_things, defined by the user in 'let' stmts,
+have closed types. E.g.
+   ghci> let foo x y = x && not y
+
+However the GHCi debugger creates top-level bindings for Ids whose
+types have free RuntimeUnk skolem variables, standing for unknown
+types.  If we don't register these free TyVars as global TyVars then
+the typechecker will try to quantify over them and fall over in
+skolemiseQuantifiedTyVar. so we must add any free TyVars to the
+typechecker's global TyVar set.  That is most conveniently by using
+tcExtendLocalTypeEnv, which automatically extends the global TyVar
+set.
+
+We do this by splitting out the Ids with open types, using 'is_closed'
+to do the partition.  The top-level things go in the global TypeEnv;
+the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the
+local TypeEnv.
+
+Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope
+things are already in the interactive context's GlobalRdrEnv.
+Extending the local RdrEnv isn't terrible, but it means there is an
+entry for the same Name in both global and local RdrEnvs, and that
+lead to duplicate "perhaps you meant..." suggestions (e.g. T5564).
+
+We don't bother with the tcl_th_bndrs environment either.
+-}
+
+-- | The returned [Id] is the list of new Ids bound by this statement. It can
+-- be used to extend the InteractiveContext via extendInteractiveContext.
+--
+-- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound
+-- values, coerced to ().
+tcRnStmt :: HscEnv -> GhciLStmt GhcPs
+         -> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
+tcRnStmt hsc_env rdr_stmt
+  = runTcInteractive hsc_env $ do {
+
+    -- The real work is done here
+    ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ;
+    zonked_expr <- zonkTopLExpr tc_expr ;
+    zonked_ids  <- zonkTopBndrs bound_ids ;
+
+    failIfErrsM ;  -- we can't do the next step if there are levity polymorphism errors
+                   -- test case: ghci/scripts/T13202{,a}
+
+        -- None of the Ids should be of unboxed type, because we
+        -- cast them all to HValues in the end!
+    mapM_ bad_unboxed (filter (isUnliftedType . idType) zonked_ids) ;
+
+    traceTc "tcs 1" empty ;
+    this_mod <- getModule ;
+    global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ;
+        -- Note [Interactively-bound Ids in GHCi] in HscTypes
+
+{- ---------------------------------------------
+   At one stage I removed any shadowed bindings from the type_env;
+   they are inaccessible but might, I suppose, cause a space leak if we leave them there.
+   However, with Template Haskell they aren't necessarily inaccessible.  Consider this
+   GHCi session
+         Prelude> let f n = n * 2 :: Int
+         Prelude> fName <- runQ [| f |]
+         Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
+         14
+         Prelude> let f n = n * 3 :: Int
+         Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
+   In the last line we use 'fName', which resolves to the *first* 'f'
+   in scope. If we delete it from the type env, GHCi crashes because
+   it doesn't expect that.
+
+   Hence this code is commented out
+
+-------------------------------------------------- -}
+
+    traceOptTcRn Opt_D_dump_tc
+        (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
+               text "Typechecked expr" <+> ppr zonked_expr]) ;
+
+    return (global_ids, zonked_expr, fix_env)
+    }
+  where
+    bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:",
+                                  nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
+
+{-
+--------------------------------------------------------------------------
+                Typechecking Stmts in GHCi
+
+Here is the grand plan, implemented in tcUserStmt
+
+        What you type                   The IO [HValue] that hscStmt returns
+        -------------                   ------------------------------------
+        let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
+                                        bindings: [x,y,...]
+
+        pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
+                                        bindings: [x,y,...]
+
+        expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
+          [NB: result not printed]      bindings: [it]
+
+        expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
+          result showable)              bindings: [it]
+
+        expr (of non-IO type,
+          result not showable)  ==>     error
+-}
+
+-- | A plan is an attempt to lift some code into the IO monad.
+type PlanResult = ([Id], LHsExpr GhcTc)
+type Plan = TcM PlanResult
+
+-- | Try the plans in order. If one fails (by raising an exn), try the next.
+-- If one succeeds, take it.
+runPlans :: [Plan] -> TcM PlanResult
+runPlans []     = panic "runPlans"
+runPlans [p]    = p
+runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p
+
+-- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the
+-- GHCi 'environment'.
+--
+-- By 'lift' and 'environment we mean that the code is changed to
+-- execute properly in an IO monad. See Note [Interactively-bound Ids
+-- in GHCi] in HscTypes for more details. We do this lifting by trying
+-- different ways ('plans') of lifting the code into the IO monad and
+-- type checking each plan until one succeeds.
+tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)
+
+-- An expression typed at the prompt is treated very specially
+tcUserStmt (dL->L loc (BodyStmt _ expr _ _))
+  = do  { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)
+               -- Don't try to typecheck if the renamer fails!
+        ; ghciStep <- getGhciStepIO
+        ; uniq <- newUnique
+        ; interPrintName <- getInteractivePrintName
+        ; let fresh_it  = itName uniq loc
+              matches   = [mkMatch (mkPrefixFunRhs (cL loc fresh_it)) [] rn_expr
+                                   (noLoc emptyLocalBinds)]
+              -- [it = expr]
+              the_bind  = cL loc $ (mkTopFunBind FromSource
+                                     (cL loc fresh_it) matches)
+                                         { fun_ext = fvs }
+              -- Care here!  In GHCi the expression might have
+              -- free variables, and they in turn may have free type variables
+              -- (if we are at a breakpoint, say).  We must put those free vars
+
+              -- [let it = expr]
+              let_stmt  = cL loc $ LetStmt noExt $ noLoc $ HsValBinds noExt
+                           $ XValBindsLR
+                               (NValBinds [(NonRecursive,unitBag the_bind)] [])
+
+              -- [it <- e]
+              bind_stmt = cL loc $ BindStmt noExt
+                                       (cL loc (VarPat noExt (cL loc fresh_it)))
+                                       (nlHsApp ghciStep rn_expr)
+                                       (mkRnSyntaxExpr bindIOName)
+                                       noSyntaxExpr
+
+              -- [; print it]
+              print_it  = cL loc $ BodyStmt noExt
+                                           (nlHsApp (nlHsVar interPrintName)
+                                           (nlHsVar fresh_it))
+                                           (mkRnSyntaxExpr thenIOName)
+                                                  noSyntaxExpr
+
+              -- NewA
+              no_it_a = cL loc $ BodyStmt noExt (nlHsApps bindIOName
+                                       [rn_expr , nlHsVar interPrintName])
+                                       (mkRnSyntaxExpr thenIOName)
+                                       noSyntaxExpr
+
+              no_it_b = cL loc $ BodyStmt noExt (rn_expr)
+                                       (mkRnSyntaxExpr thenIOName)
+                                       noSyntaxExpr
+
+              no_it_c = cL loc $ BodyStmt noExt
+                                      (nlHsApp (nlHsVar interPrintName) rn_expr)
+                                      (mkRnSyntaxExpr thenIOName)
+                                      noSyntaxExpr
+
+              -- See Note [GHCi Plans]
+
+              it_plans = [
+                    -- Plan A
+                    do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
+                       ; it_ty <- zonkTcType (idType it_id)
+                       ; when (isUnitTy $ it_ty) failM
+                       ; return stuff },
+
+                        -- Plan B; a naked bind statement
+                    tcGhciStmts [bind_stmt],
+
+                        -- Plan C; check that the let-binding is typeable all by itself.
+                        -- If not, fail; if so, try to print it.
+                        -- The two-step process avoids getting two errors: one from
+                        -- the expression itself, and one from the 'print it' part
+                        -- This two-step story is very clunky, alas
+                    do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
+                                --- checkNoErrs defeats the error recovery of let-bindings
+                       ; tcGhciStmts [let_stmt, print_it] } ]
+
+              -- Plans where we don't bind "it"
+              no_it_plans = [
+                    tcGhciStmts [no_it_a] ,
+                    tcGhciStmts [no_it_b] ,
+                    tcGhciStmts [no_it_c] ]
+
+        ; generate_it <- goptM Opt_NoIt
+
+        -- We disable `-fdefer-type-errors` in GHCi for naked expressions.
+        -- See Note [Deferred type errors in GHCi]
+
+        -- NB: The flag `-fdefer-type-errors` implies `-fdefer-type-holes`
+        -- and `-fdefer-out-of-scope-variables`. However the flag
+        -- `-fno-defer-type-errors` doesn't imply `-fdefer-type-holes` and
+        -- `-fno-defer-out-of-scope-variables`. Thus the later two flags
+        -- also need to be unset here.
+        ; plan <- unsetGOptM Opt_DeferTypeErrors $
+                  unsetGOptM Opt_DeferTypedHoles $
+                  unsetGOptM Opt_DeferOutOfScopeVariables $
+                    runPlans $ if generate_it
+                                 then no_it_plans
+                                 else it_plans
+
+        ; fix_env <- getFixityEnv
+        ; return (plan, fix_env) }
+
+{- Note [Deferred type errors in GHCi]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In GHCi, we ensure that type errors don't get deferred when type checking the
+naked expressions. Deferring type errors here is unhelpful because the
+expression gets evaluated right away anyway. It also would potentially emit
+two redundant type-error warnings, one from each plan.
+
+Trac #14963 reveals another bug that when deferred type errors is enabled
+in GHCi, any reference of imported/loaded variables (directly or indirectly)
+in interactively issued naked expressions will cause ghc panic. See more
+detailed dicussion in Trac #14963.
+
+The interactively issued declarations, statements, as well as the modules
+loaded into GHCi, are not affected. That means, for declaration, you could
+have
+
+    Prelude> :set -fdefer-type-errors
+    Prelude> x :: IO (); x = putStrLn True
+    <interactive>:14:26: warning: [-Wdeferred-type-errors]
+        ? Couldn't match type ‘Bool’ with ‘[Char]’
+          Expected type: String
+            Actual type: Bool
+        ? In the first argument of ‘putStrLn’, namely ‘True’
+          In the expression: putStrLn True
+          In an equation for ‘x’: x = putStrLn True
+
+But for naked expressions, you will have
+
+    Prelude> :set -fdefer-type-errors
+    Prelude> putStrLn True
+    <interactive>:2:10: error:
+        ? Couldn't match type ‘Bool’ with ‘[Char]’
+          Expected type: String
+            Actual type: Bool
+        ? In the first argument of ‘putStrLn’, namely ‘True’
+          In the expression: putStrLn True
+          In an equation for ‘it’: it = putStrLn True
+
+    Prelude> let x = putStrLn True
+    <interactive>:2:18: warning: [-Wdeferred-type-errors]
+        ? Couldn't match type ‘Bool’ with ‘[Char]’
+          Expected type: String
+            Actual type: Bool
+        ? In the first argument of ‘putStrLn’, namely ‘True’
+          In the expression: putStrLn True
+          In an equation for ‘x’: x = putStrLn True
+-}
+
+tcUserStmt rdr_stmt@(dL->L loc _)
+  = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $
+           rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do
+             fix_env <- getFixityEnv
+             return (fix_env, emptyFVs)
+            -- Don't try to typecheck if the renamer fails!
+       ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
+       ; rnDump rn_stmt ;
+
+       ; ghciStep <- getGhciStepIO
+       ; let gi_stmt
+               | (dL->L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt
+                     = cL loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2
+               | otherwise = rn_stmt
+
+       ; opt_pr_flag <- goptM Opt_PrintBindResult
+       ; let print_result_plan
+               | opt_pr_flag                         -- The flag says "print result"
+               , [v] <- collectLStmtBinders gi_stmt  -- One binder
+                           =  [mk_print_result_plan gi_stmt v]
+               | otherwise = []
+
+        -- The plans are:
+        --      [stmt; print v]         if one binder and not v::()
+        --      [stmt]                  otherwise
+       ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]])
+       ; return (plan, fix_env) }
+  where
+    mk_print_result_plan stmt v
+      = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
+           ; v_ty <- zonkTcType (idType v_id)
+           ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
+           ; return stuff }
+      where
+        print_v  = cL loc $ BodyStmt noExt (nlHsApp (nlHsVar printName)
+                                    (nlHsVar v))
+                                    (mkRnSyntaxExpr thenIOName) noSyntaxExpr
+
+{-
+Note [GHCi Plans]
+~~~~~~~~~~~~~~~~~
+When a user types an expression in the repl we try to print it in three different
+ways. Also, depending on whether -fno-it is set, we bind a variable called `it`
+which can be used to refer to the result of the expression subsequently in the repl.
+
+The normal plans are :
+  A. [it <- e; print e]     but not if it::()
+  B. [it <- e]
+  C. [let it = e; print it]
+
+When -fno-it is set, the plans are:
+  A. [e >>= print]
+  B. [e]
+  C. [let it = e in print it]
+
+The reason for -fno-it is explained in #14336. `it` can lead to the repl
+leaking memory as it is repeatedly queried.
+-}
+
+-- | Typecheck the statements given and then return the results of the
+-- statement in the form 'IO [()]'.
+tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult
+tcGhciStmts stmts
+ = do { ioTyCon <- tcLookupTyCon ioTyConName ;
+        ret_id  <- tcLookupId returnIOName ;            -- return @ IO
+        let {
+            ret_ty      = mkListTy unitTy ;
+            io_ret_ty   = mkTyConApp ioTyCon [ret_ty] ;
+            tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts
+                                         (mkCheckExpType io_ret_ty) ;
+            names = collectLStmtsBinders stmts ;
+         } ;
+
+        -- OK, we're ready to typecheck the stmts
+        traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
+        ((tc_stmts, ids), lie) <- captureTopConstraints $
+                                  tc_io_stmts $ \ _ ->
+                                  mapM tcLookupId names  ;
+                        -- Look up the names right in the middle,
+                        -- where they will all be in scope
+
+        -- Simplify the context
+        traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
+        const_binds <- checkNoErrs (simplifyInteractive lie) ;
+                -- checkNoErrs ensures that the plan fails if context redn fails
+
+        traceTc "TcRnDriver.tcGhciStmts: done" empty ;
+        let {   -- mk_return builds the expression
+                --      returnIO @ [()] [coerce () x, ..,  coerce () z]
+                --
+                -- Despite the inconvenience of building the type applications etc,
+                -- this *has* to be done in type-annotated post-typecheck form
+                -- because we are going to return a list of *polymorphic* values
+                -- coerced to type (). If we built a *source* stmt
+                --      return [coerce x, ..., coerce z]
+                -- then the type checker would instantiate x..z, and we wouldn't
+                -- get their *polymorphic* values.  (And we'd get ambiguity errs
+                -- if they were overloaded, since they aren't applied to anything.)
+            ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])
+                       (noLoc $ ExplicitList unitTy Nothing
+                                                            (map mk_item ids)) ;
+            mk_item id = let ty_args = [idType id, unitTy] in
+                         nlHsApp (nlHsTyApp unsafeCoerceId
+                                   (map getRuntimeRep ty_args ++ ty_args))
+                                 (nlHsVar id) ;
+            stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
+        } ;
+        return (ids, mkHsDictLet (EvBinds const_binds) $
+                     noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts)))
+    }
+
+-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
+getGhciStepIO :: TcM (LHsExpr GhcRn)
+getGhciStepIO = do
+    ghciTy <- getGHCiMonad
+    a_tv <- newName (mkTyVarOccFS (fsLit "a"))
+    let ghciM   = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
+        ioM     = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
+
+        step_ty = noLoc $ HsForAllTy
+                     { hst_bndrs = [noLoc $ UserTyVar noExt (noLoc a_tv)]
+                     , hst_xforall = noExt
+                     , hst_body  = nlHsFunTy ghciM ioM }
+
+        stepTy :: LHsSigWcType GhcRn
+        stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty)
+
+    return (noLoc $ ExprWithTySig noExt (nlHsVar ghciStepIoMName) stepTy)
+
+isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)
+isGHCiMonad hsc_env ty
+  = runTcInteractive hsc_env $ do
+        rdrEnv <- getGlobalRdrEnv
+        let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)
+        case occIO of
+            Just [n] -> do
+                let name = gre_name n
+                ghciClass <- tcLookupClass ghciIoClassName
+                userTyCon <- tcLookupTyCon name
+                let userTy = mkTyConApp userTyCon []
+                _ <- tcLookupInstance ghciClass [userTy]
+                return name
+
+            Just _  -> failWithTc $ text "Ambiguous type!"
+            Nothing -> failWithTc $ text ("Can't find type:" ++ ty)
+
+-- | How should we infer a type? See Note [TcRnExprMode]
+data TcRnExprMode = TM_Inst    -- ^ Instantiate the type fully (:type)
+                  | TM_NoInst  -- ^ Do not instantiate the type (:type +v)
+                  | TM_Default -- ^ Default the type eagerly (:type +d)
+
+-- | tcRnExpr just finds the type of an expression
+tcRnExpr :: HscEnv
+         -> TcRnExprMode
+         -> LHsExpr GhcPs
+         -> IO (Messages, Maybe Type)
+tcRnExpr hsc_env mode rdr_expr
+  = runTcInteractive hsc_env $
+    do {
+
+    (rn_expr, _fvs) <- rnLExpr rdr_expr ;
+    failIfErrsM ;
+
+        -- Now typecheck the expression, and generalise its type
+        -- it might have a rank-2 type (e.g. :t runST)
+    uniq <- newUnique ;
+    let { fresh_it  = itName uniq (getLoc rdr_expr)
+        ; orig = lexprCtOrigin rn_expr } ;
+    (tclvl, lie, res_ty)
+          <- pushLevelAndCaptureConstraints $
+             do { (_tc_expr, expr_ty) <- tcInferSigma rn_expr
+                ; if inst
+                  then snd <$> deeplyInstantiate orig expr_ty
+                  else return expr_ty } ;
+
+    -- Generalise
+    (qtvs, dicts, _, residual, _)
+         <- simplifyInfer tclvl infer_mode
+                          []    {- No sig vars -}
+                          [(fresh_it, res_ty)]
+                          lie ;
+
+    -- Ignore the dictionary bindings
+    _ <- perhaps_disable_default_warnings $
+         simplifyInteractive residual ;
+
+    let { all_expr_ty = mkInvForAllTys qtvs (mkLamTypes dicts res_ty) } ;
+    ty <- zonkTcType all_expr_ty ;
+
+    -- We normalise type families, so that the type of an expression is the
+    -- same as of a bound expression (TcBinds.mkInferredPolyId). See Trac
+    -- #10321 for further discussion.
+    fam_envs <- tcGetFamInstEnvs ;
+    -- normaliseType returns a coercion which we discard, so the Role is
+    -- irrelevant
+    return (snd (normaliseType fam_envs Nominal ty))
+    }
+  where
+    -- See Note [TcRnExprMode]
+    (inst, infer_mode, perhaps_disable_default_warnings) = case mode of
+      TM_Inst    -> (True,  NoRestrictions, id)
+      TM_NoInst  -> (False, NoRestrictions, id)
+      TM_Default -> (True,  EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults)
+
+--------------------------
+tcRnImportDecls :: HscEnv
+                -> [LImportDecl GhcPs]
+                -> IO (Messages, Maybe GlobalRdrEnv)
+-- Find the new chunk of GlobalRdrEnv created by this list of import
+-- decls.  In contract tcRnImports *extends* the TcGblEnv.
+tcRnImportDecls hsc_env import_decls
+ =  runTcInteractive hsc_env $
+    do { gbl_env <- updGblEnv zap_rdr_env $
+                    tcRnImports hsc_env import_decls
+       ; return (tcg_rdr_env gbl_env) }
+  where
+    zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }
+
+-- tcRnType just finds the kind of a type
+tcRnType :: HscEnv
+         -> Bool        -- Normalise the returned type
+         -> LHsType GhcPs
+         -> IO (Messages, Maybe (Type, Kind))
+tcRnType hsc_env normalise rdr_type
+  = runTcInteractive hsc_env $
+    setXOptM LangExt.PolyKinds $   -- See Note [Kind-generalise in tcRnType]
+    do { (HsWC { hswc_ext = wcs, hswc_body = rn_type }, _fvs)
+               <- rnHsWcType GHCiCtx (mkHsWildCardBndrs rdr_type)
+                  -- The type can have wild cards, but no implicit
+                  -- generalisation; e.g.   :kind (T _)
+       ; failIfErrsM
+
+        -- Now kind-check the type
+        -- It can have any rank or kind
+        -- First bring into scope any wildcards
+       ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type])
+       ; ((ty, kind), lie)  <-
+                       captureConstraints $
+                       tcWildCardBinders wcs $ \ wcs' ->
+                       do { emitWildCardHoleConstraints wcs'
+                          ; tcLHsTypeUnsaturated rn_type }
+       ; _ <- checkNoErrs (simplifyInteractive lie)
+
+       -- Do kind generalisation; see Note [Kind-generalise in tcRnType]
+       ; kind <- zonkTcType kind
+       ; kvs <- kindGeneralize kind
+       ; ty  <- zonkTcTypeToType ty
+
+       -- Do validity checking on type
+       ; checkValidType (GhciCtxt True) ty
+
+       ; ty' <- if normalise
+                then do { fam_envs <- tcGetFamInstEnvs
+                        ; let (_, ty')
+                                = normaliseType fam_envs Nominal ty
+                        ; return ty' }
+                else return ty ;
+
+       ; return (ty', mkInvForAllTys kvs (tcTypeKind ty')) }
+
+{- Note [TcRnExprMode]
+~~~~~~~~~~~~~~~~~~~~~~
+How should we infer a type when a user asks for the type of an expression e
+at the GHCi prompt? We offer 3 different possibilities, described below. Each
+considers this example, with -fprint-explicit-foralls enabled:
+
+  foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String
+  :type{,-spec,-def} foo @Int
+
+:type / TM_Inst
+
+  In this mode, we report the type that would be inferred if a variable
+  were assigned to expression e, without applying the monomorphism restriction.
+  This means we deeply instantiate the type and then regeneralize, as discussed
+  in #11376.
+
+  > :type foo @Int
+  forall {b} {f :: * -> *}. (Foldable f, Num b) => Int -> f b -> String
+
+  Note that the variables and constraints are reordered here, because this
+  is possible during regeneralization. Also note that the variables are
+  reported as Inferred instead of Specified.
+
+:type +v / TM_NoInst
+
+  This mode is for the benefit of users using TypeApplications. It does no
+  instantiation whatsoever, sometimes meaning that class constraints are not
+  solved.
+
+  > :type +v foo @Int
+  forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String
+
+  Note that Show Int is still reported, because the solver never got a chance
+  to see it.
+
+:type +d / TM_Default
+
+  This mode is for the benefit of users who wish to see instantiations of
+  generalized types, and in particular to instantiate Foldable and Traversable.
+  In this mode, any type variable that can be defaulted is defaulted. Because
+  GHCi uses -XExtendedDefaultRules, this means that Foldable and Traversable are
+  defaulted.
+
+  > :type +d foo @Int
+  Int -> [Integer] -> String
+
+  Note that this mode can sometimes lead to a type error, if a type variable is
+  used with a defaultable class but cannot actually be defaulted:
+
+  bar :: (Num a, Monoid a) => a -> a
+  > :type +d bar
+  ** error **
+
+  The error arises because GHC tries to default a but cannot find a concrete
+  type in the defaulting list that is both Num and Monoid. (If this list is
+  modified to include an element that is both Num and Monoid, the defaulting
+  would succeed, of course.)
+
+Note [Kind-generalise in tcRnType]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We switch on PolyKinds when kind-checking a user type, so that we will
+kind-generalise the type, even when PolyKinds is not otherwise on.
+This gives the right default behaviour at the GHCi prompt, where if
+you say ":k T", and T has a polymorphic kind, you'd like to see that
+polymorphism. Of course.  If T isn't kind-polymorphic you won't get
+anything unexpected, but the apparent *loss* of polymorphism, for
+types that you know are polymorphic, is quite surprising.  See Trac
+#7688 for a discussion.
+
+Note that the goal is to generalise the *kind of the type*, not
+the type itself! Example:
+  ghci> data SameKind :: k -> k -> Type
+  ghci> :k SameKind _
+
+We want to get `k -> Type`, not `Any -> Type`, which is what we would
+get without kind-generalisation. Note that `:k SameKind` is OK, as
+GHC will not instantiate SameKind here, and so we see its full kind
+of `forall k. k -> k -> Type`.
+
+************************************************************************
+*                                                                      *
+                 tcRnDeclsi
+*                                                                      *
+************************************************************************
+
+tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
+-}
+
+tcRnDeclsi :: HscEnv
+           -> [LHsDecl GhcPs]
+           -> IO (Messages, Maybe TcGblEnv)
+tcRnDeclsi hsc_env local_decls
+  = runTcInteractive hsc_env $
+    tcRnSrcDecls False local_decls
+
+externaliseAndTidyId :: Module -> Id -> TcM Id
+externaliseAndTidyId this_mod id
+  = do { name' <- externaliseName this_mod (idName id)
+       ; return (globaliseAndTidyId (setIdName id name')) }
+
+
+{-
+************************************************************************
+*                                                                      *
+        More GHCi stuff, to do with browsing and getting info
+*                                                                      *
+************************************************************************
+-}
+
+-- | ASSUMES that the module is either in the 'HomePackageTable' or is
+-- a package module with an interface on disk.  If neither of these is
+-- true, then the result will be an error indicating the interface
+-- could not be found.
+getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)
+getModuleInterface hsc_env mod
+  = runTcInteractive hsc_env $
+    loadModuleInterface (text "getModuleInterface") mod
+
+tcRnLookupRdrName :: HscEnv -> Located RdrName
+                  -> IO (Messages, Maybe [Name])
+-- ^ Find all the Names that this RdrName could mean, in GHCi
+tcRnLookupRdrName hsc_env (dL->L loc rdr_name)
+  = runTcInteractive hsc_env $
+    setSrcSpan loc           $
+    do {   -- If the identifier is a constructor (begins with an
+           -- upper-case letter), then we need to consider both
+           -- constructor and type class identifiers.
+         let rdr_names = dataTcOccs rdr_name
+       ; names_s <- mapM lookupInfoOccRn rdr_names
+       ; let names = concat names_s
+       ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name)))
+       ; return names }
+
+tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
+tcRnLookupName hsc_env name
+  = runTcInteractive hsc_env $
+    tcRnLookupName' name
+
+-- To look up a name we have to look in the local environment (tcl_lcl)
+-- as well as the global environment, which is what tcLookup does.
+-- But we also want a TyThing, so we have to convert:
+
+tcRnLookupName' :: Name -> TcRn TyThing
+tcRnLookupName' name = do
+   tcthing <- tcLookup name
+   case tcthing of
+     AGlobal thing    -> return thing
+     ATcId{tct_id=id} -> return (AnId id)
+     _ -> panic "tcRnLookupName'"
+
+tcRnGetInfo :: HscEnv
+            -> Name
+            -> IO ( Messages
+                  , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
+
+-- Used to implement :info in GHCi
+--
+-- Look up a RdrName and return all the TyThings it might be
+-- A capitalised RdrName is given to us in the DataName namespace,
+-- but we want to treat it as *both* a data constructor
+--  *and* as a type or class constructor;
+-- hence the call to dataTcOccs, and we return up to two results
+tcRnGetInfo hsc_env name
+  = runTcInteractive hsc_env $
+    do { loadUnqualIfaces hsc_env (hsc_IC hsc_env)
+           -- Load the interface for all unqualified types and classes
+           -- That way we will find all the instance declarations
+           -- (Packages have not orphan modules, and we assume that
+           --  in the home package all relevant modules are loaded.)
+
+       ; thing  <- tcRnLookupName' name
+       ; fixity <- lookupFixityRn name
+       ; (cls_insts, fam_insts) <- lookupInsts thing
+       ; let info = lookupKnownNameInfo name
+       ; return (thing, fixity, cls_insts, fam_insts, info) }
+
+
+-- Lookup all class and family instances for a type constructor.
+--
+-- This function filters all instances in the type environment, so there
+-- is a lot of duplicated work if it is called many times in the same
+-- type environment. If this becomes a problem, the NameEnv computed
+-- in GHC.getNameToInstancesIndex could be cached in TcM and both functions
+-- could be changed to consult that index.
+lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst])
+lookupInsts (ATyCon tc)
+  = do  { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs
+        ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
+                -- Load all instances for all classes that are
+                -- in the type environment (which are all the ones
+                -- we've seen in any interface file so far)
+
+          -- Return only the instances relevant to the given thing, i.e.
+          -- the instances whose head contains the thing's name.
+        ; let cls_insts =
+                 [ ispec        -- Search all
+                 | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
+                 , instIsVisible vis_mods ispec
+                 , tc_name `elemNameSet` orphNamesOfClsInst ispec ]
+        ; let fam_insts =
+                 [ fispec
+                 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
+                 , tc_name `elemNameSet` orphNamesOfFamInst fispec ]
+        ; return (cls_insts, fam_insts) }
+  where
+    tc_name     = tyConName tc
+
+lookupInsts _ = return ([],[])
+
+loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()
+-- Load the interface for everything that is in scope unqualified
+-- This is so that we can accurately report the instances for
+-- something
+loadUnqualIfaces hsc_env ictxt
+  = initIfaceTcRn $ do
+    mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
+  where
+    this_pkg = thisPackage (hsc_dflags hsc_env)
+
+    unqual_mods = [ nameModule name
+                  | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)
+                  , let name = gre_name gre
+                  , nameIsFromExternalPackage this_pkg name
+                  , isTcOcc (nameOccName name)   -- Types and classes only
+                  , unQualOK gre ]               -- In scope unqualified
+    doc = text "Need interface for module whose export(s) are in scope unqualified"
+
+
+
+{-
+************************************************************************
+*                                                                      *
+                Debugging output
+      This is what happens when you do -ddump-types
+*                                                                      *
+************************************************************************
+-}
+
+rnDump :: (Outputable a, Data a) => a -> TcRn ()
+-- Dump, with a banner, if -ddump-rn
+rnDump rn = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" (ppr rn)) }
+
+tcDump :: TcGblEnv -> TcRn ()
+tcDump env
+ = do { dflags <- getDynFlags ;
+
+        -- Dump short output if -ddump-types or -ddump-tc
+        when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
+          (traceTcRnForUser Opt_D_dump_types short_dump) ;
+
+        -- Dump bindings if -ddump-tc
+        traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump);
+
+        -- Dump bindings as an hsSyn AST if -ddump-tc-ast
+        traceOptTcRn Opt_D_dump_tc_ast (mkDumpDoc "Typechecker" ast_dump)
+   }
+  where
+    short_dump = pprTcGblEnv env
+    full_dump  = pprLHsBinds (tcg_binds env)
+        -- NB: foreign x-d's have undefined's in their types;
+        --     hence can't show the tc_fords
+    ast_dump = showAstData NoBlankSrcSpan (tcg_binds env)
+
+-- It's unpleasant having both pprModGuts and pprModDetails here
+pprTcGblEnv :: TcGblEnv -> SDoc
+pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
+                        tcg_insts     = insts,
+                        tcg_fam_insts = fam_insts,
+                        tcg_rules     = rules,
+                        tcg_imports   = imports })
+  = getPprDebug $ \debug ->
+    vcat [ ppr_types debug type_env
+         , ppr_tycons debug fam_insts type_env
+         , ppr_datacons debug type_env
+         , ppr_patsyns type_env
+         , ppr_insts insts
+         , ppr_fam_insts fam_insts
+         , ppr_rules rules
+         , text "Dependent modules:" <+>
+                pprUFM (imp_dep_mods imports) (ppr . sort)
+         , text "Dependent packages:" <+>
+                ppr (S.toList $ imp_dep_pkgs imports)]
+  where         -- The use of sort is just to reduce unnecessary
+                -- wobbling in testsuite output
+
+ppr_rules :: [LRuleDecl GhcTc] -> SDoc
+ppr_rules rules
+  = ppUnless (null rules) $
+    hang (text "RULES")
+       2 (vcat (map ppr rules))
+
+ppr_types :: Bool -> TypeEnv -> SDoc
+ppr_types debug type_env
+  = ppr_things "TYPE SIGNATURES" ppr_sig
+             (sortBy (comparing getOccName) ids)
+  where
+    ids = [id | id <- typeEnvIds type_env, want_sig id]
+    want_sig id
+      | debug     = True
+      | otherwise = hasTopUserName id
+                    && case idDetails id of
+                         VanillaId    -> True
+                         RecSelId {}  -> True
+                         ClassOpId {} -> True
+                         FCallId {}   -> True
+                         _            -> False
+             -- Data cons (workers and wrappers), pattern synonyms,
+             -- etc are suppressed (unless -dppr-debug),
+             -- because they appear elsehwere
+
+    ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
+
+ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc
+ppr_tycons debug fam_insts type_env
+  = vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons
+         , ppr_things "COERCION AXIOMS" ppr_ax
+                      (typeEnvCoAxioms type_env) ]
+  where
+    fi_tycons = famInstsRepTyCons fam_insts
+
+    tycons = sortBy (comparing getOccName) $
+             [tycon | tycon <- typeEnvTyCons type_env
+                    , want_tycon tycon]
+             -- Sort by OccName to reduce unnecessary changes
+    want_tycon tycon | debug      = True
+                     | otherwise  = isExternalName (tyConName tycon) &&
+                                    not (tycon `elem` fi_tycons)
+    ppr_tc tc
+       = vcat [ hang (ppr (tyConFlavour tc) <+> ppr tc
+                      <> braces (ppr (tyConArity tc)) <+> dcolon)
+                   2 (ppr (tidyTopType (tyConKind tc)))
+              , nest 2 $
+                ppWhen show_roles $
+                text "roles" <+> (sep (map ppr roles)) ]
+       where
+         show_roles = debug || not (all (== boring_role) roles)
+         roles = tyConRoles tc
+         boring_role | isClassTyCon tc = Nominal
+                     | otherwise       = Representational
+            -- Matches the choice in IfaceSyn, calls to pprRoles
+
+    ppr_ax ax = ppr (coAxiomToIfaceDecl ax)
+      -- We go via IfaceDecl rather than using pprCoAxiom
+      -- This way we get the full axiom (both LHS and RHS) with
+      -- wildcard binders tidied to _1, _2, etc.
+
+ppr_datacons :: Bool -> TypeEnv -> SDoc
+ppr_datacons debug type_env
+  = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs
+      -- The filter gets rid of class data constructors
+  where
+    ppr_dc dc = ppr dc <+> dcolon <+> ppr (dataConUserType dc)
+    all_dcs    = typeEnvDataCons type_env
+    wanted_dcs | debug     = all_dcs
+               | otherwise = filterOut is_cls_dc all_dcs
+    is_cls_dc dc = isClassTyCon (dataConTyCon dc)
+
+ppr_patsyns :: TypeEnv -> SDoc
+ppr_patsyns type_env
+  = ppr_things "PATTERN SYNONYMS" ppr_ps
+               (typeEnvPatSyns type_env)
+  where
+    ppr_ps ps = ppr ps <+> dcolon <+> pprPatSynType ps
+
+ppr_insts :: [ClsInst] -> SDoc
+ppr_insts ispecs
+  = ppr_things "CLASS INSTANCES" pprInstance ispecs
+
+ppr_fam_insts :: [FamInst] -> SDoc
+ppr_fam_insts fam_insts
+  = ppr_things "FAMILY INSTANCES" pprFamInst fam_insts
+
+ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc
+ppr_things herald ppr_one things
+  | null things = empty
+  | otherwise   = text herald $$ nest 2 (vcat (map ppr_one things))
+
+hasTopUserName :: NamedThing x => x -> Bool
+-- A top-level thing whose name is not "derived"
+-- Thus excluding things like $tcX, from Typeable boilerplate
+-- and C:Coll from class-dictionary data constructors
+hasTopUserName x
+  = isExternalName name && not (isDerivedOccName (nameOccName name))
+  where
+    name = getName x
+
+{-
+********************************************************************************
+
+Type Checker Plugins
+
+********************************************************************************
+-}
+
+withTcPlugins :: HscEnv -> TcM a -> TcM a
+withTcPlugins hsc_env m =
+  do let plugins = getTcPlugins (hsc_dflags hsc_env)
+     case plugins of
+       [] -> m  -- Common fast case
+       _  -> do ev_binds_var <- newTcEvBinds
+                (solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins
+                -- This ensures that tcPluginStop is called even if a type
+                -- error occurs during compilation (Fix of #10078)
+                eitherRes <- tryM $ do
+                  updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m
+                mapM_ (flip runTcPluginM ev_binds_var) stops
+                case eitherRes of
+                  Left _ -> failM
+                  Right res -> return res
+  where
+  startPlugin ev_binds_var (TcPlugin start solve stop) =
+    do s <- runTcPluginM start ev_binds_var
+       return (solve s, stop s)
+
+getTcPlugins :: DynFlags -> [TcRnMonad.TcPlugin]
+getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args)
+
+runRenamerPlugin :: TcGblEnv
+                 -> HsGroup GhcRn
+                 -> TcM (TcGblEnv, HsGroup GhcRn)
+runRenamerPlugin gbl_env hs_group = do
+    dflags <- getDynFlags
+    withPlugins dflags
+      (\p opts (e, g) -> ( mark_plugin_unsafe dflags >> renamedResultAction p opts e g))
+      (gbl_env, hs_group)
+
+
+-- XXX: should this really be a Maybe X?  Check under which circumstances this
+-- can become a Nothing and decide whether this should instead throw an
+-- exception/signal an error.
+type RenamedStuff =
+        (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
+                Maybe LHsDocString))
+
+-- | Extract the renamed information from TcGblEnv.
+getRenamedStuff :: TcGblEnv -> RenamedStuff
+getRenamedStuff tc_result
+  = fmap (\decls -> ( decls, tcg_rn_imports tc_result
+                    , tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) )
+         (tcg_rn_decls tc_result)
+
+runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv
+runTypecheckerPlugin sum hsc_env gbl_env = do
+    let dflags = hsc_dflags hsc_env
+    withPlugins dflags
+      (\p opts env -> mark_plugin_unsafe dflags
+                        >> typeCheckResultAction p opts sum env)
+      gbl_env
+
+mark_plugin_unsafe :: DynFlags -> TcM ()
+mark_plugin_unsafe dflags = recordUnsafeInfer pluginUnsafe
+  where
+    unsafeText = "Use of plugins makes the module unsafe"
+    pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan
+                                   (Outputable.text unsafeText) )
diff --git a/compiler/typecheck/TcRnDriver.hs-boot b/compiler/typecheck/TcRnDriver.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcRnDriver.hs-boot
@@ -0,0 +1,13 @@
+module TcRnDriver where
+
+import GhcPrelude
+import DynFlags (DynFlags)
+import Type (TyThing)
+import TcRnTypes (TcM)
+import Outputable (SDoc)
+import Name (Name)
+
+checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)
+               -> TyThing -> TyThing -> TcM ()
+missingBootThing :: Bool -> Name -> String -> SDoc
+badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc
diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcRnExports.hs
@@ -0,0 +1,819 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcRnExports (tcRnExports, exports_from_avail) where
+
+import GhcPrelude
+
+import HsSyn
+import PrelNames
+import RdrName
+import TcRnMonad
+import TcEnv
+import TcType
+import RnNames
+import RnEnv
+import RnUnbound ( reportUnboundName )
+import ErrUtils
+import Id
+import IdInfo
+import Module
+import Name
+import NameEnv
+import NameSet
+import Avail
+import TyCon
+import SrcLoc
+import HscTypes
+import Outputable
+import ConLike
+import DataCon
+import PatSyn
+import Maybes
+import UniqSet
+import Util (capitalise)
+import FastString (fsLit)
+
+import Control.Monad
+import DynFlags
+import RnHsDoc          ( rnHsDoc )
+import RdrHsSyn        ( setRdrNameSpace )
+import Data.Either      ( partitionEithers )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Export list processing}
+*                                                                      *
+************************************************************************
+
+Processing the export list.
+
+You might think that we should record things that appear in the export
+list as ``occurrences'' (using @addOccurrenceName@), but you'd be
+wrong.  We do check (here) that they are in scope, but there is no
+need to slurp in their actual declaration (which is what
+@addOccurrenceName@ forces).
+
+Indeed, doing so would big trouble when compiling @PrelBase@, because
+it re-exports @GHC@, which includes @takeMVar#@, whose type includes
+@ConcBase.StateAndSynchVar#@, and so on...
+
+Note [Exports of data families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose you see (Trac #5306)
+        module M where
+          import X( F )
+          data instance F Int = FInt
+What does M export?  AvailTC F [FInt]
+                  or AvailTC F [F,FInt]?
+The former is strictly right because F isn't defined in this module.
+But then you can never do an explicit import of M, thus
+    import M( F( FInt ) )
+because F isn't exported by M.  Nor can you import FInt alone from here
+    import M( FInt )
+because we don't have syntax to support that.  (It looks like an import of
+the type FInt.)
+
+At one point I implemented a compromise:
+  * When constructing exports with no export list, or with module M(
+    module M ), we add the parent to the exports as well.
+  * But not when you see module M( f ), even if f is a
+    class method with a parent.
+  * Nor when you see module M( module N ), with N /= M.
+
+But the compromise seemed too much of a hack, so we backed it out.
+You just have to use an explicit export list:
+    module M( F(..) ) where ...
+
+Note [Avails of associated data families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose you have (Trac #16077)
+
+    {-# LANGUAGE TypeFamilies #-}
+    module A (module A) where
+
+    class    C a  where { data T a }
+    instance C () where { data T () = D }
+
+Because @A@ is exported explicitly, GHC tries to produce an export list
+from the @GlobalRdrEnv@. In this case, it pulls out the following:
+
+    [ C defined at A.hs:4:1
+    , T parent:C defined at A.hs:4:23
+    , D parent:T defined at A.hs:5:35 ]
+
+If map these directly into avails, (via 'availFromGRE'), we get
+@[C{C;}, C{T;}, T{D;}]@, which eventually gets merged into @[C{C, T;}, T{D;}]@.
+That's not right, because @T{D;}@ violates the AvailTC invariant: @T@ is
+exported, but it isn't the first entry in the avail!
+
+We work around this issue by expanding GREs where the parent and child
+are both type constructors into two GRES.
+
+    T parent:C defined at A.hs:4:23
+
+      =>
+
+    [ T parent:C defined at A.hs:4:23
+    , T defined at A.hs:4:23 ]
+
+Then, we get  @[C{C;}, C{T;}, T{T;}, T{D;}]@, which eventually gets merged
+into @[C{C, T;}, T{T, D;}]@ (which satsifies the AvailTC invariant).
+-}
+
+data ExportAccum        -- The type of the accumulating parameter of
+                        -- the main worker function in rnExports
+     = ExportAccum
+        ExportOccMap           --  Tracks exported occurrence names
+        (UniqSet ModuleName)   --  Tracks (re-)exported module names
+
+emptyExportAccum :: ExportAccum
+emptyExportAccum = ExportAccum emptyOccEnv emptyUniqSet
+
+accumExports :: (ExportAccum -> x -> TcRn (Maybe (ExportAccum, y)))
+             -> [x]
+             -> TcRn [y]
+accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum
+  where f' acc x = do
+          m <- try_m (f acc x)
+          pure $ case m of
+            Right (Just (acc', y)) -> (acc', Just y)
+            _                      -> (acc, Nothing)
+
+type ExportOccMap = OccEnv (Name, IE GhcPs)
+        -- Tracks what a particular exported OccName
+        --   in an export list refers to, and which item
+        --   it came from.  It's illegal to export two distinct things
+        --   that have the same occurrence name
+
+tcRnExports :: Bool       -- False => no 'module M(..) where' header at all
+          -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list
+          -> TcGblEnv
+          -> RnM TcGblEnv
+
+        -- Complains if two distinct exports have same OccName
+        -- Warns about identical exports.
+        -- Complains about exports items not in scope
+
+tcRnExports explicit_mod exports
+          tcg_env@TcGblEnv { tcg_mod     = this_mod,
+                              tcg_rdr_env = rdr_env,
+                              tcg_imports = imports,
+                              tcg_src     = hsc_src }
+ = unsetWOptM Opt_WarnWarningsDeprecations $
+       -- Do not report deprecations arising from the export
+       -- list, to avoid bleating about re-exporting a deprecated
+       -- thing (especially via 'module Foo' export item)
+   do   {
+        -- In interactive mode, we behave as if he had
+        -- written "module Main where ..."
+        ; dflags <- getDynFlags
+        ; let is_main_mod = mainModIs dflags == this_mod
+        ; let default_main = case mainFunIs dflags of
+                 Just main_fun
+                     | is_main_mod -> mkUnqual varName (fsLit main_fun)
+                 _                 -> main_RDR_Unqual
+        ; let real_exports
+                 | explicit_mod = exports
+                 | ghcLink dflags == LinkInMemory = Nothing
+                 | otherwise
+                          = Just (noLoc [noLoc (IEVar noExt
+                                     (noLoc (IEName $ noLoc default_main)))])
+                        -- ToDo: the 'noLoc' here is unhelpful if 'main'
+                        --       turns out to be out of scope
+
+        ; let do_it = exports_from_avail real_exports rdr_env imports this_mod
+        ; (rn_exports, final_avails)
+            <- if hsc_src == HsigFile
+                then do (msgs, mb_r) <- tryTc do_it
+                        case mb_r of
+                            Just r  -> return r
+                            Nothing -> addMessages msgs >> failM
+                else checkNoErrs do_it
+        ; let final_ns     = availsToNameSetWithSelectors final_avails
+
+        ; traceRn "rnExports: Exports:" (ppr final_avails)
+
+        ; let new_tcg_env =
+                  tcg_env { tcg_exports    = final_avails,
+                             tcg_rn_exports = case tcg_rn_exports tcg_env of
+                                                Nothing -> Nothing
+                                                Just _  -> rn_exports,
+                            tcg_dus = tcg_dus tcg_env `plusDU`
+                                      usesOnly final_ns }
+        ; failIfErrsM
+        ; return new_tcg_env }
+
+exports_from_avail :: Maybe (Located [LIE GhcPs])
+                         -- ^ 'Nothing' means no explicit export list
+                   -> GlobalRdrEnv
+                   -> ImportAvails
+                         -- ^ Imported modules; this is used to test if a
+                         -- @module Foo@ export is valid (it's not valid
+                         -- if we didn't import @Foo@!)
+                   -> Module
+                   -> RnM (Maybe [(LIE GhcRn, Avails)], Avails)
+                         -- (Nothing, _) <=> no explicit export list
+                         -- if explicit export list is present it contains
+                         -- each renamed export item together with its exported
+                         -- names.
+
+exports_from_avail Nothing rdr_env _imports _this_mod
+   -- The same as (module M) where M is the current module name,
+   -- so that's how we handle it, except we also export the data family
+   -- when a data instance is exported.
+  = do {
+    ; warnMissingExportList <- woptM Opt_WarnMissingExportList
+    ; warnIfFlag Opt_WarnMissingExportList
+        warnMissingExportList
+        (missingModuleExportWarn $ moduleName _this_mod)
+    ; let avails =
+            map fix_faminst . gresToAvailInfo
+              . filter isLocalGRE . globalRdrEnvElts $ rdr_env
+    ; return (Nothing, avails) }
+  where
+    -- #11164: when we define a data instance
+    -- but not data family, re-export the family
+    -- Even though we don't check whether this is actually a data family
+    -- only data families can locally define subordinate things (`ns` here)
+    -- without locally defining (and instead importing) the parent (`n`)
+    fix_faminst (AvailTC n ns flds) =
+      let new_ns =
+            case ns of
+              [] -> [n]
+              (p:_) -> if p == n then ns else n:ns
+      in AvailTC n new_ns flds
+
+    fix_faminst avail = avail
+
+
+exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod
+  = do ie_avails <- accumExports do_litem rdr_items
+       let final_exports = nubAvails (concat (map snd ie_avails)) -- Combine families
+       return (Just ie_avails, final_exports)
+  where
+    do_litem :: ExportAccum -> LIE GhcPs
+             -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))
+    do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)
+
+    -- Maps a parent to its in-scope children
+    kids_env :: NameEnv [GlobalRdrElt]
+    kids_env = mkChildEnv (globalRdrEnvElts rdr_env)
+
+    -- See Note [Avails of associated data families]
+    expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt]
+    expand_tyty_gre (gre @ GRE { gre_name = me, gre_par = ParentIs p })
+      | isTyConName p, isTyConName me = [gre, gre{ gre_par = NoParent }]
+    expand_tyty_gre gre = [gre]
+
+    imported_modules = [ imv_name imv
+                       | xs <- moduleEnvElts $ imp_mods imports
+                       , imv <- importedByUser xs ]
+
+    exports_from_item :: ExportAccum -> LIE GhcPs
+                      -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))
+    exports_from_item (ExportAccum occs earlier_mods)
+                      (dL->L loc ie@(IEModuleContents _ lmod@(dL->L _ mod)))
+        | mod `elementOfUniqSet` earlier_mods    -- Duplicate export of M
+        = do { warnIfFlag Opt_WarnDuplicateExports True
+                          (dupModuleExport mod) ;
+               return Nothing }
+
+        | otherwise
+        = do { let { exportValid = (mod `elem` imported_modules)
+                                || (moduleName this_mod == mod)
+                   ; gre_prs     = pickGREsModExp mod (globalRdrEnvElts rdr_env)
+                   ; new_exports = [ availFromGRE gre'
+                                   | (gre, _) <- gre_prs
+                                   , gre' <- expand_tyty_gre gre ]
+                   ; all_gres    = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs
+                   ; mods        = addOneToUniqSet earlier_mods mod
+                   }
+
+             ; checkErr exportValid (moduleNotImported mod)
+             ; warnIfFlag Opt_WarnDodgyExports
+                          (exportValid && null gre_prs)
+                          (nullModuleExport mod)
+
+             ; traceRn "efa" (ppr mod $$ ppr all_gres)
+             ; addUsedGREs all_gres
+
+             ; occs' <- check_occs ie occs new_exports
+                      -- This check_occs not only finds conflicts
+                      -- between this item and others, but also
+                      -- internally within this item.  That is, if
+                      -- 'M.x' is in scope in several ways, we'll have
+                      -- several members of mod_avails with the same
+                      -- OccName.
+             ; traceRn "export_mod"
+                       (vcat [ ppr mod
+                             , ppr new_exports ])
+
+             ; return (Just ( ExportAccum occs' mods
+                            , ( cL loc (IEModuleContents noExt lmod)
+                              , new_exports))) }
+
+    exports_from_item acc@(ExportAccum occs mods) (dL->L loc ie)
+        | isDoc ie
+        = do new_ie <- lookup_doc_ie ie
+             return (Just (acc, (cL loc new_ie, [])))
+
+        | otherwise
+        = do (new_ie, avail) <- lookup_ie ie
+             if isUnboundName (ieName new_ie)
+                  then return Nothing    -- Avoid error cascade
+                  else do
+
+                    occs' <- check_occs ie occs [avail]
+
+                    return (Just ( ExportAccum occs' mods
+                                 , (cL loc new_ie, [avail])))
+
+    -------------
+    lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo)
+    lookup_ie (IEVar _ (dL->L l rdr))
+        = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
+             return (IEVar noExt (cL l (replaceWrappedName rdr name)), avail)
+
+    lookup_ie (IEThingAbs _ (dL->L l rdr))
+        = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr
+             return (IEThingAbs noExt (cL l (replaceWrappedName rdr name))
+                    , avail)
+
+    lookup_ie ie@(IEThingAll _ n')
+        = do
+            (n, avail, flds) <- lookup_ie_all ie n'
+            let name = unLoc n
+            return (IEThingAll noExt (replaceLWrappedName n' (unLoc n))
+                   , AvailTC name (name:avail) flds)
+
+
+    lookup_ie ie@(IEThingWith _ l wc sub_rdrs _)
+        = do
+            (lname, subs, avails, flds)
+              <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs
+            (_, all_avail, all_flds) <-
+              case wc of
+                NoIEWildcard -> return (lname, [], [])
+                IEWildcard _ -> lookup_ie_all ie l
+            let name = unLoc lname
+            return (IEThingWith noExt (replaceLWrappedName l name) wc subs
+                                (flds ++ (map noLoc all_flds)),
+                    AvailTC name (name : avails ++ all_avail)
+                                 (map unLoc flds ++ all_flds))
+
+
+    lookup_ie _ = panic "lookup_ie"    -- Other cases covered earlier
+
+
+    lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName]
+                   -> RnM (Located Name, [LIEWrappedName Name], [Name],
+                           [Located FieldLabel])
+    lookup_ie_with (dL->L l rdr) sub_rdrs
+        = do name <- lookupGlobalOccRn $ ieWrappedName rdr
+             (non_flds, flds) <- lookupChildrenExport name sub_rdrs
+             if isUnboundName name
+                then return (cL l name, [], [name], [])
+                else return (cL l name, non_flds
+                            , map (ieWrappedName . unLoc) non_flds
+                            , flds)
+
+    lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName
+                  -> RnM (Located Name, [Name], [FieldLabel])
+    lookup_ie_all ie (dL->L l rdr) =
+          do name <- lookupGlobalOccRn $ ieWrappedName rdr
+             let gres = findChildren kids_env name
+                 (non_flds, flds) = classifyGREs gres
+             addUsedKids (ieWrappedName rdr) gres
+             warnDodgyExports <- woptM Opt_WarnDodgyExports
+             when (null gres) $
+                  if isTyConName name
+                  then when warnDodgyExports $
+                           addWarn (Reason Opt_WarnDodgyExports)
+                                   (dodgyExportWarn name)
+                  else -- This occurs when you export T(..), but
+                       -- only import T abstractly, or T is a synonym.
+                       addErr (exportItemErr ie)
+             return (cL l name, non_flds, flds)
+
+    -------------
+    lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn)
+    lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc
+                                           return (IEGroup noExt lev rn_doc)
+    lookup_doc_ie (IEDoc _ doc)       = do rn_doc <- rnHsDoc doc
+                                           return (IEDoc noExt rn_doc)
+    lookup_doc_ie (IEDocNamed _ str)  = return (IEDocNamed noExt str)
+    lookup_doc_ie _ = panic "lookup_doc_ie"    -- Other cases covered earlier
+
+    -- In an export item M.T(A,B,C), we want to treat the uses of
+    -- A,B,C as if they were M.A, M.B, M.C
+    -- Happily pickGREs does just the right thing
+    addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM ()
+    addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres)
+
+classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])
+classifyGREs = partitionEithers . map classifyGRE
+
+classifyGRE :: GlobalRdrElt -> Either Name FieldLabel
+classifyGRE gre = case gre_par gre of
+  FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n)
+  FldParent _ (Just lbl) -> Right (FieldLabel lbl True n)
+  _                      -> Left  n
+  where
+    n = gre_name gre
+
+isDoc :: IE GhcPs -> Bool
+isDoc (IEDoc {})      = True
+isDoc (IEDocNamed {}) = True
+isDoc (IEGroup {})    = True
+isDoc _ = False
+
+-- Renaming and typechecking of exports happens after everything else has
+-- been typechecked.
+
+
+
+-- Renaming exports lists is a minefield. Five different things can appear in
+-- children export lists ( T(A, B, C) ).
+-- 1. Record selectors
+-- 2. Type constructors
+-- 3. Data constructors
+-- 4. Pattern Synonyms
+-- 5. Pattern Synonym Selectors
+--
+-- However, things get put into weird name spaces.
+-- 1. Some type constructors are parsed as variables (-.->) for example.
+-- 2. All data constructors are parsed as type constructors
+-- 3. When there is ambiguity, we default type constructors to data
+-- constructors and require the explicit `type` keyword for type
+-- constructors.
+--
+-- This function first establishes the possible namespaces that an
+-- identifier might be in (`choosePossibleNameSpaces`).
+--
+-- Then for each namespace in turn, tries to find the correct identifier
+-- there returning the first positive result or the first terminating
+-- error.
+--
+
+
+
+lookupChildrenExport :: Name -> [LIEWrappedName RdrName]
+                     -> RnM ([LIEWrappedName Name], [Located FieldLabel])
+lookupChildrenExport spec_parent rdr_items =
+  do
+    xs <- mapAndReportM doOne rdr_items
+    return $ partitionEithers xs
+    where
+        -- Pick out the possible namespaces in order of priority
+        -- This is a consequence of how the parser parses all
+        -- data constructors as type constructors.
+        choosePossibleNamespaces :: NameSpace -> [NameSpace]
+        choosePossibleNamespaces ns
+          | ns == varName = [varName, tcName]
+          | ns == tcName  = [dataName, tcName]
+          | otherwise = [ns]
+        -- Process an individual child
+        doOne :: LIEWrappedName RdrName
+              -> RnM (Either (LIEWrappedName Name) (Located FieldLabel))
+        doOne n = do
+
+          let bareName = (ieWrappedName . unLoc) n
+              lkup v = lookupSubBndrOcc_helper False True
+                        spec_parent (setRdrNameSpace bareName v)
+
+          name <-  combineChildLookupResult $ map lkup $
+                   choosePossibleNamespaces (rdrNameSpace bareName)
+          traceRn "lookupChildrenExport" (ppr name)
+          -- Default to data constructors for slightly better error
+          -- messages
+          let unboundName :: RdrName
+              unboundName = if rdrNameSpace bareName == varName
+                                then bareName
+                                else setRdrNameSpace bareName dataName
+
+          case name of
+            NameNotFound -> do { ub <- reportUnboundName unboundName
+                               ; let l = getLoc n
+                               ; return (Left (cL l (IEName (cL l ub))))}
+            FoundFL fls -> return $ Right (cL (getLoc n) fls)
+            FoundName par name -> do { checkPatSynParent spec_parent par name
+                                     ; return
+                                       $ Left (replaceLWrappedName n name) }
+            IncorrectParent p g td gs -> failWithDcErr p g td gs
+
+
+-- Note: [Typing Pattern Synonym Exports]
+-- It proved quite a challenge to precisely specify which pattern synonyms
+-- should be allowed to be bundled with which type constructors.
+-- In the end it was decided to be quite liberal in what we allow. Below is
+-- how Simon described the implementation.
+--
+-- "Personally I think we should Keep It Simple.  All this talk of
+--  satisfiability makes me shiver.  I suggest this: allow T( P ) in all
+--   situations except where `P`'s type is ''visibly incompatible'' with
+--   `T`.
+--
+--    What does "visibly incompatible" mean?  `P` is visibly incompatible
+--    with
+--     `T` if
+--       * `P`'s type is of form `... -> S t1 t2`
+--       * `S` is a data/newtype constructor distinct from `T`
+--
+--  Nothing harmful happens if we allow `P` to be exported with
+--  a type it can't possibly be useful for, but specifying a tighter
+--  relationship is very awkward as you have discovered."
+--
+-- Note that this allows *any* pattern synonym to be bundled with any
+-- datatype type constructor. For example, the following pattern `P` can be
+-- bundled with any type.
+--
+-- ```
+-- pattern P :: (A ~ f) => f
+-- ```
+--
+-- So we provide basic type checking in order to help the user out, most
+-- pattern synonyms are defined with definite type constructors, but don't
+-- actually prevent a library author completely confusing their users if
+-- they want to.
+--
+-- So, we check for exactly four things
+-- 1. The name arises from a pattern synonym definition. (Either a pattern
+--    synonym constructor or a pattern synonym selector)
+-- 2. The pattern synonym is only bundled with a datatype or newtype.
+-- 3. Check that the head of the result type constructor is an actual type
+--    constructor and not a type variable. (See above example)
+-- 4. Is so, check that this type constructor is the same as the parent
+--    type constructor.
+--
+--
+-- Note: [Types of TyCon]
+--
+-- This check appears to be overlly complicated, Richard asked why it
+-- is not simply just `isAlgTyCon`. The answer for this is that
+-- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow.
+-- (It is either a newtype or data depending on the number of methods)
+--
+
+-- | Given a resolved name in the children export list and a parent. Decide
+-- whether we are allowed to export the child with the parent.
+-- Invariant: gre_par == NoParent
+-- See note [Typing Pattern Synonym Exports]
+checkPatSynParent :: Name    -- ^ Alleged parent type constructor
+                             -- User wrote T( P, Q )
+                  -> Parent  -- The parent of P we discovered
+                  -> Name    -- ^ Either a
+                             --   a) Pattern Synonym Constructor
+                             --   b) A pattern synonym selector
+                  -> TcM ()  -- Fails if wrong parent
+checkPatSynParent _ (ParentIs {}) _
+  = return ()
+
+checkPatSynParent _ (FldParent {}) _
+  = return ()
+
+checkPatSynParent parent NoParent mpat_syn
+  | isUnboundName parent -- Avoid an error cascade
+  = return ()
+
+  | otherwise
+  = do { parent_ty_con <- tcLookupTyCon parent
+       ; mpat_syn_thing <- tcLookupGlobal mpat_syn
+
+        -- 1. Check that the Id was actually from a thing associated with patsyns
+       ; case mpat_syn_thing of
+            AnId i | isId i
+                   , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i
+                   -> handle_pat_syn (selErr i) parent_ty_con p
+
+            AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p
+
+            _ -> failWithDcErr parent mpat_syn (ppr mpat_syn) [] }
+  where
+    psErr  = exportErrCtxt "pattern synonym"
+    selErr = exportErrCtxt "pattern synonym record selector"
+
+    assocClassErr :: SDoc
+    assocClassErr = text "Pattern synonyms can be bundled only with datatypes."
+
+    handle_pat_syn :: SDoc
+                   -> TyCon      -- ^ Parent TyCon
+                   -> PatSyn     -- ^ Corresponding bundled PatSyn
+                                 --   and pretty printed origin
+                   -> TcM ()
+    handle_pat_syn doc ty_con pat_syn
+
+      -- 2. See note [Types of TyCon]
+      | not $ isTyConWithSrcDataCons ty_con
+      = addErrCtxt doc $ failWithTc assocClassErr
+
+      -- 3. Is the head a type variable?
+      | Nothing <- mtycon
+      = return ()
+      -- 4. Ok. Check they are actually the same type constructor.
+
+      | Just p_ty_con <- mtycon, p_ty_con /= ty_con
+      = addErrCtxt doc $ failWithTc typeMismatchError
+
+      -- 5. We passed!
+      | otherwise
+      = return ()
+
+      where
+        expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))
+        (_, _, _, _, _, res_ty) = patSynSig pat_syn
+        mtycon = fst <$> tcSplitTyConApp_maybe res_ty
+        typeMismatchError :: SDoc
+        typeMismatchError =
+          text "Pattern synonyms can only be bundled with matching type constructors"
+              $$ text "Couldn't match expected type of"
+              <+> quotes (ppr expected_res_ty)
+              <+> text "with actual type of"
+              <+> quotes (ppr res_ty)
+
+
+{-===========================================================================-}
+check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo]
+           -> RnM ExportOccMap
+check_occs ie occs avails
+  -- 'names' and 'fls' are the entities specified by 'ie'
+  = foldlM check occs names_with_occs
+  where
+    -- Each Name specified by 'ie', paired with the OccName used to
+    -- refer to it in the GlobalRdrEnv
+    -- (see Note [Representing fields in AvailInfo] in Avail).
+    --
+    -- We check for export clashes using the selector Name, but need
+    -- the field label OccName for presenting error messages.
+    names_with_occs = availsNamesWithOccs avails
+
+    check occs (name, occ)
+      = case lookupOccEnv occs name_occ of
+          Nothing -> return (extendOccEnv occs name_occ (name, ie))
+
+          Just (name', ie')
+            | name == name'   -- Duplicate export
+            -- But we don't want to warn if the same thing is exported
+            -- by two different module exports. See ticket #4478.
+            -> do { warnIfFlag Opt_WarnDuplicateExports
+                               (not (dupExport_ok name ie ie'))
+                               (dupExportWarn occ ie ie')
+                  ; return occs }
+
+            | otherwise    -- Same occ name but different names: an error
+            ->  do { global_env <- getGlobalRdrEnv ;
+                     addErr (exportClashErr global_env occ name' name ie' ie) ;
+                     return occs }
+      where
+        name_occ = nameOccName name
+
+
+dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool
+-- The Name is exported by both IEs. Is that ok?
+-- "No"  iff the name is mentioned explicitly in both IEs
+--        or one of the IEs mentions the name *alone*
+-- "Yes" otherwise
+--
+-- Examples of "no":  module M( f, f )
+--                    module M( fmap, Functor(..) )
+--                    module M( module Data.List, head )
+--
+-- Example of "yes"
+--    module M( module A, module B ) where
+--        import A( f )
+--        import B( f )
+--
+-- Example of "yes" (Trac #2436)
+--    module M( C(..), T(..) ) where
+--         class C a where { data T a }
+--         instance C Int where { data T Int = TInt }
+--
+-- Example of "yes" (Trac #2436)
+--    module Foo ( T ) where
+--      data family T a
+--    module Bar ( T(..), module Foo ) where
+--        import Foo
+--        data instance T Int = TInt
+
+dupExport_ok n ie1 ie2
+  = not (  single ie1 || single ie2
+        || (explicit_in ie1 && explicit_in ie2) )
+  where
+    explicit_in (IEModuleContents {}) = False                   -- module M
+    explicit_in (IEThingAll _ r)
+      = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r)  -- T(..)
+    explicit_in _              = True
+
+    single IEVar {}      = True
+    single IEThingAbs {} = True
+    single _               = False
+
+
+dupModuleExport :: ModuleName -> SDoc
+dupModuleExport mod
+  = hsep [text "Duplicate",
+          quotes (text "Module" <+> ppr mod),
+          text "in export list"]
+
+moduleNotImported :: ModuleName -> SDoc
+moduleNotImported mod
+  = hsep [text "The export item",
+          quotes (text "module" <+> ppr mod),
+          text "is not imported"]
+
+nullModuleExport :: ModuleName -> SDoc
+nullModuleExport mod
+  = hsep [text "The export item",
+          quotes (text "module" <+> ppr mod),
+          text "exports nothing"]
+
+missingModuleExportWarn :: ModuleName -> SDoc
+missingModuleExportWarn mod
+  = hsep [text "The export item",
+          quotes (text "module" <+> ppr mod),
+          text "is missing an export list"]
+
+
+dodgyExportWarn :: Name -> SDoc
+dodgyExportWarn item
+  = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn)
+
+exportErrCtxt :: Outputable o => String -> o -> SDoc
+exportErrCtxt herald exp =
+  text "In the" <+> text (herald ++ ":") <+> ppr exp
+
+
+addExportErrCtxt :: (OutputableBndrId (GhcPass p))
+                 => IE (GhcPass p) -> TcM a -> TcM a
+addExportErrCtxt ie = addErrCtxt exportCtxt
+  where
+    exportCtxt = text "In the export:" <+> ppr ie
+
+exportItemErr :: IE GhcPs -> SDoc
+exportItemErr export_item
+  = sep [ text "The export item" <+> quotes (ppr export_item),
+          text "attempts to export constructors or class methods that are not visible here" ]
+
+
+dupExportWarn :: OccName -> IE GhcPs -> IE GhcPs -> SDoc
+dupExportWarn occ_name ie1 ie2
+  = hsep [quotes (ppr occ_name),
+          text "is exported by", quotes (ppr ie1),
+          text "and",            quotes (ppr ie2)]
+
+dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc
+dcErrMsg ty_con what_is thing parents =
+          text "The type constructor" <+> quotes (ppr ty_con)
+                <+> text "is not the parent of the" <+> text what_is
+                <+> quotes thing <> char '.'
+                $$ text (capitalise what_is)
+                <> text "s can only be exported with their parent type constructor."
+                $$ (case parents of
+                      [] -> empty
+                      [_] -> text "Parent:"
+                      _  -> text "Parents:") <+> fsep (punctuate comma parents)
+
+failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a
+failWithDcErr parent thing thing_doc parents = do
+  ty_thing <- tcLookupGlobal thing
+  failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing)
+                        thing_doc (map ppr parents)
+  where
+    tyThingCategory' :: TyThing -> String
+    tyThingCategory' (AnId i)
+      | isRecordSelector i = "record selector"
+    tyThingCategory' i = tyThingCategory i
+
+
+exportClashErr :: GlobalRdrEnv -> OccName
+               -> Name -> Name
+               -> IE GhcPs -> IE GhcPs
+               -> MsgDoc
+exportClashErr global_env occ name1 name2 ie1 ie2
+  = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon
+         , ppr_export ie1' name1'
+         , ppr_export ie2' name2' ]
+  where
+    ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>
+                                       quotes (ppr_name name))
+                                    2 (pprNameProvenance (get_gre name)))
+
+    -- DuplicateRecordFields means that nameOccName might be a mangled
+    -- $sel-prefixed thing, in which case show the correct OccName alone
+    ppr_name name
+      | nameOccName name == occ = ppr name
+      | otherwise               = ppr occ
+
+    -- get_gre finds a GRE for the Name, so that we can show its provenance
+    get_gre name
+        = fromMaybe (pprPanic "exportClashErr" (ppr name))
+                    (lookupGRE_Name_OccName global_env name occ)
+    get_loc name = greSrcSpan (get_gre name)
+    (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2
+                                   then (name1, ie1, name2, ie2)
+                                   else (name2, ie2, name1, ie1)
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -0,0 +1,1987 @@
+{-
+(c) The University of Glasgow 2006
+
+
+Functions for working with the typechecker environment (setters, getters...).
+-}
+
+{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE ViewPatterns #-}
+
+
+module TcRnMonad(
+  -- * Initalisation
+  initTc, initTcWithGbl, initTcInteractive, initTcRnIf,
+
+  -- * Simple accessors
+  discardResult,
+  getTopEnv, updTopEnv, getGblEnv, updGblEnv,
+  setGblEnv, getLclEnv, updLclEnv, setLclEnv,
+  getEnvs, setEnvs,
+  xoptM, doptM, goptM, woptM,
+  setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,
+  whenDOptM, whenGOptM, whenWOptM,
+  whenXOptM, unlessXOptM,
+  getGhcMode,
+  withDoDynamicToo,
+  getEpsVar,
+  getEps,
+  updateEps, updateEps_,
+  getHpt, getEpsAndHpt,
+
+  -- * Arrow scopes
+  newArrowScope, escapeArrowScope,
+
+  -- * Unique supply
+  newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName,
+  newSysName, newSysLocalId, newSysLocalIds,
+
+  -- * Accessing input/output
+  newTcRef, readTcRef, writeTcRef, updTcRef,
+
+  -- * Debugging
+  traceTc, traceRn, traceOptTcRn, traceTcRn, traceTcRnForUser,
+  traceTcRnWithStyle,
+  getPrintUnqualified,
+  printForUserTcRn,
+  traceIf, traceHiDiffs, traceOptIf,
+  debugTc,
+
+  -- * Typechecker global environment
+  getIsGHCi, getGHCiMonad, getInteractivePrintName,
+  tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv,
+  getRdrEnvs, getImports,
+  getFixityEnv, extendFixityEnv, getRecFieldEnv,
+  getDeclaredDefaultTys,
+  addDependentFiles,
+
+  -- * Error management
+  getSrcSpanM, setSrcSpan, addLocM,
+  wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_,
+  getErrsVar, setErrsVar,
+  addErr,
+  failWith, failAt,
+  addErrAt, addErrs,
+  checkErr,
+  addMessages,
+  discardWarnings,
+
+  -- * Shared error message stuff: renamer and typechecker
+  mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
+  reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
+  try_m, tryTc,
+  askNoErrs, discardErrs, tryTcDiscardingErrs,
+  checkNoErrs, whenNoErrs,
+  ifErrsM, failIfErrsM,
+  checkTH, failTH,
+
+  -- * Context management for the type checker
+  getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,
+  addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM,
+
+  -- * Error message generation (type checker)
+  addErrTc, addErrsTc,
+  addErrTcM, mkErrTcM, mkErrTc,
+  failWithTc, failWithTcM,
+  checkTc, checkTcM,
+  failIfTc, failIfTcM,
+  warnIfFlag, warnIf, warnTc, warnTcM,
+  addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,
+  mkErrInfo,
+
+  -- * Type constraints
+  newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,
+  addTcEvBind, addTopEvBinds,
+  getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
+  chooseUniqueOccTc,
+  getConstraintVar, setConstraintVar,
+  emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
+  emitImplication, emitImplications, emitInsoluble,
+  discardConstraints, captureConstraints, tryCaptureConstraints,
+  pushLevelAndCaptureConstraints,
+  pushTcLevelM_, pushTcLevelM, pushTcLevelsM,
+  getTcLevel, setTcLevel, isTouchableTcM,
+  getLclTypeEnv, setLclTypeEnv,
+  traceTcConstraints, emitWildCardHoleConstraints,
+
+  -- * Template Haskell context
+  recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc,
+  getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage,
+  addModFinalizersWithLclEnv,
+
+  -- * Safe Haskell context
+  recordUnsafeInfer, finalSafeMode, fixSafeInstances,
+
+  -- * Stuff for the renamer's local env
+  getLocalRdrEnv, setLocalRdrEnv,
+
+  -- * Stuff for interface decls
+  mkIfLclEnv,
+  initIfaceTcRn,
+  initIfaceCheck,
+  initIfaceLcl,
+  initIfaceLclWithSubst,
+  initIfaceLoad,
+  getIfModule,
+  failIfM,
+  forkM_maybe,
+  forkM,
+  setImplicitEnvM,
+
+  withException,
+
+  -- * Stuff for cost centres.
+  ContainsCostCentreState(..), getCCIndexM,
+
+  -- * Types etc.
+  module TcRnTypes,
+  module IOEnv
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnTypes        -- Re-export all
+import IOEnv            -- Re-export all
+import TcEvidence
+
+import HsSyn hiding (LIE)
+import HscTypes
+import Module
+import RdrName
+import Name
+import Type
+
+import TcType
+import InstEnv
+import FamInstEnv
+import PrelNames
+
+import Id
+import VarSet
+import VarEnv
+import ErrUtils
+import SrcLoc
+import NameEnv
+import NameSet
+import Bag
+import Outputable
+import UniqSupply
+import DynFlags
+import FastString
+import Panic
+import Util
+import Annotations
+import BasicTypes( TopLevelFlag )
+import Maybes
+import CostCentreState
+
+import qualified GHC.LanguageExtensions as LangExt
+
+import Data.IORef
+import Control.Monad
+import Data.Set ( Set )
+import qualified Data.Set as Set
+
+import {-# SOURCE #-} TcEnv    ( tcInitTidyEnv )
+
+import qualified Data.Map as Map
+
+{-
+************************************************************************
+*                                                                      *
+                        initTc
+*                                                                      *
+************************************************************************
+-}
+
+-- | Setup the initial typechecking environment
+initTc :: HscEnv
+       -> HscSource
+       -> Bool          -- True <=> retain renamed syntax trees
+       -> Module
+       -> RealSrcSpan
+       -> TcM r
+       -> IO (Messages, Maybe r)
+                -- Nothing => error thrown by the thing inside
+                -- (error messages should have been printed already)
+
+initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
+ = do { keep_var     <- newIORef emptyNameSet ;
+        used_gre_var <- newIORef [] ;
+        th_var       <- newIORef False ;
+        th_splice_var<- newIORef False ;
+        th_locs_var  <- newIORef Set.empty ;
+        infer_var    <- newIORef (True, emptyBag) ;
+        dfun_n_var   <- newIORef emptyOccSet ;
+        type_env_var <- case hsc_type_env_var hsc_env of {
+                           Just (_mod, te_var) -> return te_var ;
+                           Nothing             -> newIORef emptyNameEnv } ;
+
+        dependent_files_var <- newIORef [] ;
+        static_wc_var       <- newIORef emptyWC ;
+        cc_st_var           <- newIORef newCostCentreState ;
+        th_topdecls_var      <- newIORef [] ;
+        th_foreign_files_var <- newIORef [] ;
+        th_topnames_var      <- newIORef emptyNameSet ;
+        th_modfinalizers_var <- newIORef [] ;
+        th_coreplugins_var <- newIORef [] ;
+        th_state_var         <- newIORef Map.empty ;
+        th_remote_state_var  <- newIORef Nothing ;
+        let {
+             dflags = hsc_dflags hsc_env ;
+
+             maybe_rn_syntax :: forall a. a -> Maybe a ;
+             maybe_rn_syntax empty_val
+                | dopt Opt_D_dump_rn_ast dflags = Just empty_val
+
+                | gopt Opt_WriteHie dflags       = Just empty_val
+
+                  -- We want to serialize the documentation in the .hi-files,
+                  -- and need to extract it from the renamed syntax first.
+                  -- See 'ExtractDocs.extractDocs'.
+                | gopt Opt_Haddock dflags       = Just empty_val
+
+                | keep_rn_syntax                = Just empty_val
+                | otherwise                     = Nothing ;
+
+             gbl_env = TcGblEnv {
+                tcg_th_topdecls      = th_topdecls_var,
+                tcg_th_foreign_files = th_foreign_files_var,
+                tcg_th_topnames      = th_topnames_var,
+                tcg_th_modfinalizers = th_modfinalizers_var,
+                tcg_th_coreplugins = th_coreplugins_var,
+                tcg_th_state         = th_state_var,
+                tcg_th_remote_state  = th_remote_state_var,
+
+                tcg_mod            = mod,
+                tcg_semantic_mod   =
+                    canonicalizeModuleIfHome dflags mod,
+                tcg_src            = hsc_src,
+                tcg_rdr_env        = emptyGlobalRdrEnv,
+                tcg_fix_env        = emptyNameEnv,
+                tcg_field_env      = emptyNameEnv,
+                tcg_default        = if moduleUnitId mod == primUnitId
+                                     then Just []  -- See Note [Default types]
+                                     else Nothing,
+                tcg_type_env       = emptyNameEnv,
+                tcg_type_env_var   = type_env_var,
+                tcg_inst_env       = emptyInstEnv,
+                tcg_fam_inst_env   = emptyFamInstEnv,
+                tcg_ann_env        = emptyAnnEnv,
+                tcg_th_used        = th_var,
+                tcg_th_splice_used = th_splice_var,
+                tcg_th_top_level_locs
+                                   = th_locs_var,
+                tcg_exports        = [],
+                tcg_imports        = emptyImportAvails,
+                tcg_used_gres     = used_gre_var,
+                tcg_dus            = emptyDUs,
+
+                tcg_rn_imports     = [],
+                tcg_rn_exports     =
+                    if hsc_src == HsigFile
+                        -- Always retain renamed syntax, so that we can give
+                        -- better errors.  (TODO: how?)
+                        then Just []
+                        else maybe_rn_syntax [],
+                tcg_rn_decls       = maybe_rn_syntax emptyRnGroup,
+                tcg_tr_module      = Nothing,
+                tcg_binds          = emptyLHsBinds,
+                tcg_imp_specs      = [],
+                tcg_sigs           = emptyNameSet,
+                tcg_ev_binds       = emptyBag,
+                tcg_warns          = NoWarnings,
+                tcg_anns           = [],
+                tcg_tcs            = [],
+                tcg_insts          = [],
+                tcg_fam_insts      = [],
+                tcg_rules          = [],
+                tcg_fords          = [],
+                tcg_patsyns        = [],
+                tcg_merged         = [],
+                tcg_dfun_n         = dfun_n_var,
+                tcg_keep           = keep_var,
+                tcg_doc_hdr        = Nothing,
+                tcg_hpc            = False,
+                tcg_main           = Nothing,
+                tcg_self_boot      = NoSelfBoot,
+                tcg_safeInfer      = infer_var,
+                tcg_dependent_files = dependent_files_var,
+                tcg_tc_plugins     = [],
+                tcg_top_loc        = loc,
+                tcg_static_wc      = static_wc_var,
+                tcg_complete_matches = [],
+                tcg_cc_st          = cc_st_var
+             } ;
+        } ;
+
+        -- OK, here's the business end!
+        initTcWithGbl hsc_env gbl_env loc do_this
+    }
+
+-- | Run a 'TcM' action in the context of an existing 'GblEnv'.
+initTcWithGbl :: HscEnv
+              -> TcGblEnv
+              -> RealSrcSpan
+              -> TcM r
+              -> IO (Messages, Maybe r)
+initTcWithGbl hsc_env gbl_env loc do_this
+ = do { tvs_var      <- newIORef emptyVarSet
+      ; lie_var      <- newIORef emptyWC
+      ; errs_var     <- newIORef (emptyBag, emptyBag)
+      ; let lcl_env = TcLclEnv {
+                tcl_errs       = errs_var,
+                tcl_loc        = loc,     -- Should be over-ridden very soon!
+                tcl_ctxt       = [],
+                tcl_rdr        = emptyLocalRdrEnv,
+                tcl_th_ctxt    = topStage,
+                tcl_th_bndrs   = emptyNameEnv,
+                tcl_arrow_ctxt = NoArrowCtxt,
+                tcl_env        = emptyNameEnv,
+                tcl_bndrs      = [],
+                tcl_tyvars     = tvs_var,
+                tcl_lie        = lie_var,
+                tcl_tclvl      = topTcLevel
+                }
+
+      ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $
+                     do { r <- tryM do_this
+                        ; case r of
+                          Right res -> return (Just res)
+                          Left _    -> return Nothing }
+
+      -- Check for unsolved constraints
+      -- If we succeed (maybe_res = Just r), there should be
+      -- no unsolved constraints.  But if we exit via an
+      -- exception (maybe_res = Nothing), we may have skipped
+      -- solving, so don't panic then (Trac #13466)
+      ; lie <- readIORef (tcl_lie lcl_env)
+      ; when (isJust maybe_res && not (isEmptyWC lie)) $
+        pprPanic "initTc: unsolved constraints" (ppr lie)
+
+        -- Collect any error messages
+      ; msgs <- readIORef (tcl_errs lcl_env)
+
+      ; let { final_res | errorsFound dflags msgs = Nothing
+                        | otherwise               = maybe_res }
+
+      ; return (msgs, final_res)
+      }
+  where dflags = hsc_dflags hsc_env
+
+initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)
+-- Initialise the type checker monad for use in GHCi
+initTcInteractive hsc_env thing_inside
+  = initTc hsc_env HsSrcFile False
+           (icInteractiveModule (hsc_IC hsc_env))
+           (realSrcLocSpan interactive_src_loc)
+           thing_inside
+  where
+    interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1
+
+{- Note [Default types]
+~~~~~~~~~~~~~~~~~~~~~~~
+The Integer type is simply not available in package ghc-prim (it is
+declared in integer-gmp).  So we set the defaulting types to (Just
+[]), meaning there are no default types, rather then Nothing, which
+means "use the default default types of Integer, Double".
+
+If you don't do this, attempted defaulting in package ghc-prim causes
+an actual crash (attempting to look up the Integer type).
+
+
+************************************************************************
+*                                                                      *
+                Initialisation
+*                                                                      *
+************************************************************************
+-}
+
+initTcRnIf :: Char              -- Tag for unique supply
+           -> HscEnv
+           -> gbl -> lcl
+           -> TcRnIf gbl lcl a
+           -> IO a
+initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside
+   = do { us     <- mkSplitUniqSupply uniq_tag ;
+        ; us_var <- newIORef us ;
+
+        ; let { env = Env { env_top = hsc_env,
+                            env_us  = us_var,
+                            env_gbl = gbl_env,
+                            env_lcl = lcl_env} }
+
+        ; runIOEnv env thing_inside
+        }
+
+{-
+************************************************************************
+*                                                                      *
+                Simple accessors
+*                                                                      *
+************************************************************************
+-}
+
+discardResult :: TcM a -> TcM ()
+discardResult a = a >> return ()
+
+getTopEnv :: TcRnIf gbl lcl HscEnv
+getTopEnv = do { env <- getEnv; return (env_top env) }
+
+updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->
+                          env { env_top = upd top })
+
+getGblEnv :: TcRnIf gbl lcl gbl
+getGblEnv = do { Env{..} <- getEnv; return env_gbl }
+
+updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->
+                          env { env_gbl = upd gbl })
+
+setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })
+
+getLclEnv :: TcRnIf gbl lcl lcl
+getLclEnv = do { Env{..} <- getEnv; return env_lcl }
+
+updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->
+                          env { env_lcl = upd lcl })
+
+setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
+setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })
+
+getEnvs :: TcRnIf gbl lcl (gbl, lcl)
+getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }
+
+setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a
+setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })
+
+-- Command-line flags
+
+xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool
+xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }
+
+doptM :: DumpFlag -> TcRnIf gbl lcl Bool
+doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }
+
+goptM :: GeneralFlag -> TcRnIf gbl lcl Bool
+goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }
+
+woptM :: WarningFlag -> TcRnIf gbl lcl Bool
+woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }
+
+setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+setXOptM flag =
+  updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag})
+
+unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetXOptM flag =
+  updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag})
+
+unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetGOptM flag =
+  updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag})
+
+unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetWOptM flag =
+  updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag})
+
+-- | Do it flag is true
+whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+whenDOptM flag thing_inside = do b <- doptM flag
+                                 when b thing_inside
+
+whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+whenGOptM flag thing_inside = do b <- goptM flag
+                                 when b thing_inside
+
+whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+whenWOptM flag thing_inside = do b <- woptM flag
+                                 when b thing_inside
+
+whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+whenXOptM flag thing_inside = do b <- xoptM flag
+                                 when b thing_inside
+
+unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
+unlessXOptM flag thing_inside = do b <- xoptM flag
+                                   unless b thing_inside
+
+getGhcMode :: TcRnIf gbl lcl GhcMode
+getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }
+
+withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+withDoDynamicToo =
+  updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->
+              top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags })
+
+getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)
+getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }
+
+getEps :: TcRnIf gbl lcl ExternalPackageState
+getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }
+
+-- | Update the external package state.  Returns the second result of the
+-- modifier function.
+--
+-- This is an atomic operation and forces evaluation of the modified EPS in
+-- order to avoid space leaks.
+updateEps :: (ExternalPackageState -> (ExternalPackageState, a))
+          -> TcRnIf gbl lcl a
+updateEps upd_fn = do
+  traceIf (text "updating EPS")
+  eps_var <- getEpsVar
+  atomicUpdMutVar' eps_var upd_fn
+
+-- | Update the external package state.
+--
+-- This is an atomic operation and forces evaluation of the modified EPS in
+-- order to avoid space leaks.
+updateEps_ :: (ExternalPackageState -> ExternalPackageState)
+           -> TcRnIf gbl lcl ()
+updateEps_ upd_fn = do
+  traceIf (text "updating EPS_")
+  eps_var <- getEpsVar
+  atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))
+
+getHpt :: TcRnIf gbl lcl HomePackageTable
+getHpt = do { env <- getTopEnv; return (hsc_HPT env) }
+
+getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)
+getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)
+                  ; return (eps, hsc_HPT env) }
+
+-- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing
+-- an exception if it is an error.
+withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a
+withException do_this = do
+    r <- do_this
+    dflags <- getDynFlags
+    case r of
+        Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err))
+        Succeeded result -> return result
+
+{-
+************************************************************************
+*                                                                      *
+                Arrow scopes
+*                                                                      *
+************************************************************************
+-}
+
+newArrowScope :: TcM a -> TcM a
+newArrowScope
+  = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }
+
+-- Return to the stored environment (from the enclosing proc)
+escapeArrowScope :: TcM a -> TcM a
+escapeArrowScope
+  = updLclEnv $ \ env ->
+    case tcl_arrow_ctxt env of
+      NoArrowCtxt       -> env
+      ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt
+                                   , tcl_lie = lie
+                                   , tcl_rdr = rdr_env }
+
+{-
+************************************************************************
+*                                                                      *
+                Unique supply
+*                                                                      *
+************************************************************************
+-}
+
+newUnique :: TcRnIf gbl lcl Unique
+newUnique
+ = do { env <- getEnv ;
+        let { u_var = env_us env } ;
+        us <- readMutVar u_var ;
+        case takeUniqFromSupply us of { (uniq, us') -> do {
+        writeMutVar u_var us' ;
+        return $! uniq }}}
+   -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving
+   -- a chain of unevaluated supplies behind.
+   -- NOTE 2: we use the uniq in the supply from the MutVar directly, and
+   -- throw away one half of the new split supply.  This is safe because this
+   -- is the only place we use that unique.  Using the other half of the split
+   -- supply is safer, but slower.
+
+newUniqueSupply :: TcRnIf gbl lcl UniqSupply
+newUniqueSupply
+ = do { env <- getEnv ;
+        let { u_var = env_us env } ;
+        us <- readMutVar u_var ;
+        case splitUniqSupply us of { (us1,us2) -> do {
+        writeMutVar u_var us1 ;
+        return us2 }}}
+
+cloneLocalName :: Name -> TcM Name
+-- Make a fresh Internal name with the same OccName and SrcSpan
+cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name)
+
+newName :: OccName -> TcM Name
+newName occ = do { loc  <- getSrcSpanM
+                 ; newNameAt occ loc }
+
+newNameAt :: OccName -> SrcSpan -> TcM Name
+newNameAt occ span
+  = do { uniq <- newUnique
+       ; return (mkInternalName uniq occ span) }
+
+newSysName :: OccName -> TcRnIf gbl lcl Name
+newSysName occ
+  = do { uniq <- newUnique
+       ; return (mkSystemName uniq occ) }
+
+newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId
+newSysLocalId fs ty
+  = do  { u <- newUnique
+        ; return (mkSysLocalOrCoVar fs u ty) }
+
+newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]
+newSysLocalIds fs tys
+  = do  { us <- newUniqueSupply
+        ; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) }
+
+instance MonadUnique (IOEnv (Env gbl lcl)) where
+        getUniqueM = newUnique
+        getUniqueSupplyM = newUniqueSupply
+
+{-
+************************************************************************
+*                                                                      *
+                Accessing input/output
+*                                                                      *
+************************************************************************
+-}
+
+newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
+newTcRef = newMutVar
+
+readTcRef :: TcRef a -> TcRnIf gbl lcl a
+readTcRef = readMutVar
+
+writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
+writeTcRef = writeMutVar
+
+updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
+-- Returns ()
+updTcRef ref fn = liftIO $ do { old <- readIORef ref
+                              ; writeIORef ref (fn old) }
+
+{-
+************************************************************************
+*                                                                      *
+                Debugging
+*                                                                      *
+************************************************************************
+-}
+
+
+-- Typechecker trace
+traceTc :: String -> SDoc -> TcRn ()
+traceTc =
+  labelledTraceOptTcRn Opt_D_dump_tc_trace
+
+-- Renamer Trace
+traceRn :: String -> SDoc -> TcRn ()
+traceRn =
+  labelledTraceOptTcRn Opt_D_dump_rn_trace
+
+-- | Trace when a certain flag is enabled. This is like `traceOptTcRn`
+-- but accepts a string as a label and formats the trace message uniformly.
+labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()
+labelledTraceOptTcRn flag herald doc = do
+   traceOptTcRn flag (formatTraceMsg herald doc)
+
+formatTraceMsg :: String -> SDoc -> SDoc
+formatTraceMsg herald doc = hang (text herald) 2 doc
+
+-- | Output a doc if the given 'DumpFlag' is set.
+--
+-- By default this logs to stdout
+-- However, if the `-ddump-to-file` flag is set,
+-- then this will dump output to a file
+--
+-- Just a wrapper for 'dumpSDoc'
+traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
+traceOptTcRn flag doc
+  = do { dflags <- getDynFlags
+       ; when (dopt flag dflags)
+              (traceTcRn flag doc)
+       }
+
+-- Certain tests (T3017, Roles3, T12763 etc.) expect part of the
+-- output generated by `-ddump-types` to be in 'PprUser' style. However,
+-- generally we want all other debugging output to use 'PprDump'
+-- style. 'traceTcRn' and 'traceTcRnForUser' help us accomplish this.
+
+-- | A wrapper around 'traceTcRnWithStyle' which uses 'PprDump' style.
+traceTcRn :: DumpFlag -> SDoc -> TcRn ()
+traceTcRn flag doc
+  = do { dflags  <- getDynFlags
+       ; printer <- getPrintUnqualified dflags
+       ; let dump_style = mkDumpStyle dflags printer
+       ; traceTcRnWithStyle dump_style dflags flag doc }
+
+-- | A wrapper around 'traceTcRnWithStyle' which uses 'PprUser' style.
+traceTcRnForUser :: DumpFlag -> SDoc -> TcRn ()
+-- Used by 'TcRnDriver.tcDump'.
+traceTcRnForUser flag doc
+  = do { dflags  <- getDynFlags
+       ; printer <- getPrintUnqualified dflags
+       ; let user_style = mkUserStyle dflags printer AllTheWay
+       ; traceTcRnWithStyle user_style dflags flag doc }
+
+traceTcRnWithStyle :: PprStyle -> DynFlags -> DumpFlag -> SDoc -> TcRn ()
+-- ^ Unconditionally dump some trace output
+--
+-- The DumpFlag is used only to set the output filename
+-- for --dump-to-file, not to decide whether or not to output
+-- That part is done by the caller
+traceTcRnWithStyle sty dflags flag doc
+  = do { real_doc <- prettyDoc dflags doc
+       ; liftIO $ dumpSDocWithStyle sty dflags flag "" real_doc }
+  where
+    -- Add current location if -dppr-debug
+    prettyDoc :: DynFlags -> SDoc -> TcRn SDoc
+    prettyDoc dflags doc = if hasPprDebug dflags
+       then do { loc  <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }
+       else return doc -- The full location is usually way too much
+
+
+getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified
+getPrintUnqualified dflags
+  = do { rdr_env <- getGlobalRdrEnv
+       ; return $ mkPrintUnqualified dflags rdr_env }
+
+-- | Like logInfoTcRn, but for user consumption
+printForUserTcRn :: SDoc -> TcRn ()
+printForUserTcRn doc
+  = do { dflags <- getDynFlags
+       ; printer <- getPrintUnqualified dflags
+       ; liftIO (printOutputForUser dflags printer doc) }
+
+{-
+traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is
+available.  Alas, they behave inconsistently with the other stuff;
+e.g. are unaffected by -dump-to-file.
+-}
+
+traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
+traceIf      = traceOptIf Opt_D_dump_if_trace
+traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
+
+
+traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
+traceOptIf flag doc
+  = whenDOptM flag $    -- No RdrEnv available, so qualify everything
+    do { dflags <- getDynFlags
+       ; liftIO (putMsg dflags doc) }
+
+{-
+************************************************************************
+*                                                                      *
+                Typechecker global environment
+*                                                                      *
+************************************************************************
+-}
+
+getIsGHCi :: TcRn Bool
+getIsGHCi = do { mod <- getModule
+               ; return (isInteractiveModule mod) }
+
+getGHCiMonad :: TcRn Name
+getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }
+
+getInteractivePrintName :: TcRn Name
+getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }
+
+tcIsHsBootOrSig :: TcRn Bool
+tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }
+
+tcIsHsig :: TcRn Bool
+tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) }
+
+tcSelfBootInfo :: TcRn SelfBootInfo
+tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }
+
+getGlobalRdrEnv :: TcRn GlobalRdrEnv
+getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }
+
+getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)
+getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }
+
+getImports :: TcRn ImportAvails
+getImports = do { env <- getGblEnv; return (tcg_imports env) }
+
+getFixityEnv :: TcRn FixityEnv
+getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }
+
+extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a
+extendFixityEnv new_bit
+  = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->
+                env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})
+
+getRecFieldEnv :: TcRn RecFieldEnv
+getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }
+
+getDeclaredDefaultTys :: TcRn (Maybe [Type])
+getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }
+
+addDependentFiles :: [FilePath] -> TcRn ()
+addDependentFiles fs = do
+  ref <- fmap tcg_dependent_files getGblEnv
+  dep_files <- readTcRef ref
+  writeTcRef ref (fs ++ dep_files)
+
+{-
+************************************************************************
+*                                                                      *
+                Error management
+*                                                                      *
+************************************************************************
+-}
+
+getSrcSpanM :: TcRn SrcSpan
+        -- Avoid clash with Name.getSrcLoc
+getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) }
+
+setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
+setSrcSpan (RealSrcSpan real_loc) thing_inside
+    = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside
+-- Don't overwrite useful info with useless:
+setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
+
+addLocM :: HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b
+addLocM fn (dL->L loc a) = setSrcSpan loc $ fn a
+
+wrapLocM :: (HasSrcSpan a, HasSrcSpan b) =>
+            (SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b
+-- wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
+wrapLocM fn (dL->L loc a) = setSrcSpan loc $ do { b <- fn a
+                                                ; return (cL loc b) }
+wrapLocFstM :: (HasSrcSpan a, HasSrcSpan b) =>
+               (SrcSpanLess a -> TcM (SrcSpanLess b,c)) -> a -> TcM (b, c)
+wrapLocFstM fn (dL->L loc a) =
+  setSrcSpan loc $ do
+    (b,c) <- fn a
+    return (cL loc b, c)
+
+wrapLocSndM :: (HasSrcSpan a, HasSrcSpan c) =>
+               (SrcSpanLess a -> TcM (b, SrcSpanLess c)) -> a -> TcM (b, c)
+wrapLocSndM fn (dL->L loc a) =
+  setSrcSpan loc $ do
+    (b,c) <- fn a
+    return (b, cL loc c)
+
+wrapLocM_ :: HasSrcSpan a =>
+             (SrcSpanLess a -> TcM ()) -> a -> TcM ()
+wrapLocM_ fn (dL->L loc a) = setSrcSpan loc (fn a)
+
+-- Reporting errors
+
+getErrsVar :: TcRn (TcRef Messages)
+getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }
+
+setErrsVar :: TcRef Messages -> TcRn a -> TcRn a
+setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })
+
+addErr :: MsgDoc -> TcRn ()
+addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }
+
+failWith :: MsgDoc -> TcRn a
+failWith msg = addErr msg >> failM
+
+failAt :: SrcSpan -> MsgDoc -> TcRn a
+failAt loc msg = addErrAt loc msg >> failM
+
+addErrAt :: SrcSpan -> MsgDoc -> TcRn ()
+-- addErrAt is mainly (exclusively?) used by the renamer, where
+-- tidying is not an issue, but it's all lazy so the extra
+-- work doesn't matter
+addErrAt loc msg = do { ctxt <- getErrCtxt
+                      ; tidy_env <- tcInitTidyEnv
+                      ; err_info <- mkErrInfo tidy_env ctxt
+                      ; addLongErrAt loc msg err_info }
+
+addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()
+addErrs msgs = mapM_ add msgs
+             where
+               add (loc,msg) = addErrAt loc msg
+
+checkErr :: Bool -> MsgDoc -> TcRn ()
+-- Add the error if the bool is False
+checkErr ok msg = unless ok (addErr msg)
+
+addMessages :: Messages -> TcRn ()
+addMessages msgs1
+  = do { errs_var <- getErrsVar ;
+         msgs0 <- readTcRef errs_var ;
+         writeTcRef errs_var (unionMessages msgs0 msgs1) }
+
+discardWarnings :: TcRn a -> TcRn a
+-- Ignore warnings inside the thing inside;
+-- used to ignore-unused-variable warnings inside derived code
+discardWarnings thing_inside
+  = do  { errs_var <- getErrsVar
+        ; (old_warns, _) <- readTcRef errs_var
+
+        ; result <- thing_inside
+
+        -- Revert warnings to old_warns
+        ; (_new_warns, new_errs) <- readTcRef errs_var
+        ; writeTcRef errs_var (old_warns, new_errs)
+
+        ; return result }
+
+{-
+************************************************************************
+*                                                                      *
+        Shared error message stuff: renamer and typechecker
+*                                                                      *
+************************************************************************
+-}
+
+mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg
+mkLongErrAt loc msg extra
+  = do { dflags <- getDynFlags ;
+         printer <- getPrintUnqualified dflags ;
+         return $ mkLongErrMsg dflags loc printer msg extra }
+
+mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg
+mkErrDocAt loc errDoc
+  = do { dflags <- getDynFlags ;
+         printer <- getPrintUnqualified dflags ;
+         return $ mkErrDoc dflags loc printer errDoc }
+
+addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
+addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
+
+reportErrors :: [ErrMsg] -> TcM ()
+reportErrors = mapM_ reportError
+
+reportError :: ErrMsg -> TcRn ()
+reportError err
+  = do { traceTc "Adding error:" (pprLocErrMsg err) ;
+         errs_var <- getErrsVar ;
+         (warns, errs) <- readTcRef errs_var ;
+         writeTcRef errs_var (warns, errs `snocBag` err) }
+
+reportWarning :: WarnReason -> ErrMsg -> TcRn ()
+reportWarning reason err
+  = do { let warn = makeIntoWarning reason err
+                    -- 'err' was built by mkLongErrMsg or something like that,
+                    -- so it's of error severity.  For a warning we downgrade
+                    -- its severity to SevWarning
+
+       ; traceTc "Adding warning:" (pprLocErrMsg warn)
+       ; errs_var <- getErrsVar
+       ; (warns, errs) <- readTcRef errs_var
+       ; writeTcRef errs_var (warns `snocBag` warn, errs) }
+
+try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
+-- Does tryM, with a debug-trace on failure
+-- If we do recover from an exception, /insoluble/ constraints
+-- (only) in 'thing' are are propagated
+try_m thing
+  = do { (mb_r, lie) <- tryCaptureConstraints thing
+       ; emitConstraints lie
+
+       -- Debug trace
+       ; case mb_r of
+            Left exn -> traceTc "tryTc/recoverM recovering from" $
+                        (text (showException exn) $$ ppr lie)
+            Right {} -> return ()
+
+       ; return mb_r }
+
+-----------------------
+recoverM :: TcRn r      -- Recovery action; do this if the main one fails
+         -> TcRn r      -- Main action: do this first;
+                        --  if it generates errors, propagate them all
+         -> TcRn r
+-- Errors in 'thing' are retained
+-- If we do recover from an exception, /insoluble/ constraints
+-- (only) in 'thing' are are propagated
+recoverM recover thing
+  = do { mb_res <- try_m thing ;
+         case mb_res of
+           Left _    -> recover
+           Right res -> return res }
+
+
+-----------------------
+
+-- | Drop elements of the input that fail, so the result
+-- list can be shorter than the argument list
+mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]
+mapAndRecoverM f = mapMaybeM (fmap rightToMaybe . try_m . f)
+
+-- | The accumulator is not updated if the action fails
+foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b
+foldAndRecoverM _ acc []     = return acc
+foldAndRecoverM f acc (x:xs) =
+                          do { mb_r <- try_m (f acc x)
+                             ; case mb_r of
+                                Left _  -> foldAndRecoverM f acc xs
+                                Right acc' -> foldAndRecoverM f acc' xs  }
+
+-- | Succeeds if applying the argument to all members of the lists succeeds,
+--   but nevertheless runs it on all arguments, to collect all errors.
+mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]
+mapAndReportM f xs = checkNoErrs (mapAndRecoverM f xs)
+
+-----------------------
+tryTc :: TcRn a -> TcRn (Messages, Maybe a)
+-- (tryTc m) executes m, and returns
+--      Just r,  if m succeeds (returning r)
+--      Nothing, if m fails
+-- It also returns all the errors and warnings accumulated by m
+-- It always succeeds (never raises an exception)
+tryTc thing_inside
+ = do { errs_var <- newTcRef emptyMessages ;
+
+        res  <- try_m $  -- Be sure to catch exceptions, so that
+                         -- we guaranteed to read the messages out
+                         -- of that brand-new errs_var!
+                setErrsVar errs_var $
+                thing_inside ;
+
+        msgs <- readTcRef errs_var ;
+
+        return (msgs, case res of
+                        Left _    -> Nothing
+                        Right val -> Just val)
+        -- The exception is always the IOEnv built-in
+        -- in exception; see IOEnv.failM
+   }
+
+-----------------------
+discardErrs :: TcRn a -> TcRn a
+-- (discardErrs m) runs m,
+--   discarding all error messages and warnings generated by m
+-- If m fails, discardErrs fails, and vice versa
+discardErrs m
+ = do { errs_var <- newTcRef emptyMessages
+      ; setErrsVar errs_var m }
+
+-----------------------
+tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
+-- (tryTcDiscardingErrs recover main) tries 'main';
+--      if 'main' succeeds with no error messages, it's the answer
+--      otherwise discard everything from 'main', including errors,
+--          and try 'recover' instead.
+tryTcDiscardingErrs recover main
+  = do  { (msgs, mb_res) <- tryTc main
+        ; dflags <- getDynFlags
+        ; case mb_res of
+            Just res | not (errorsFound dflags msgs)
+              -> -- 'main' succeeed with no error messages
+                 do { addMessages msgs  -- msgs might still have warnings
+                    ; return res }
+
+            _ -> -- 'main' failed, or produced an error message
+                 recover     -- Discard all errors and warnings entirely
+        }
+
+-----------------------
+-- (askNoErrs m) runs m
+-- If m fails,
+--    then (askNoErrs m) fails
+-- If m succeeds with result r,
+--    then (askNoErrs m) succeeds with result (r, b),
+--         where b is True iff m generated no errors
+-- Regardless of success or failure,
+--   propagate any errors/warnings generated by m
+askNoErrs :: TcRn a -> TcRn (a, Bool)
+askNoErrs m
+  = do { (msgs, mb_res) <- tryTc m
+       ; addMessages msgs  -- Always propagate errors
+       ; case mb_res of
+           Nothing  -> failM
+           Just res -> do { dflags <- getDynFlags
+                          ; let errs_found = errorsFound dflags msgs
+                          ; return (res, not errs_found) } }
+-----------------------
+checkNoErrs :: TcM r -> TcM r
+-- (checkNoErrs m) succeeds iff m succeeds and generates no errors
+-- If m fails then (checkNoErrsTc m) fails.
+-- If m succeeds, it checks whether m generated any errors messages
+--      (it might have recovered internally)
+--      If so, it fails too.
+-- Regardless, any errors generated by m are propagated to the enclosing context.
+checkNoErrs main
+  = do  { (res, no_errs) <- askNoErrs main
+        ; unless no_errs failM
+        ; return res }
+
+-----------------------
+whenNoErrs :: TcM () -> TcM ()
+whenNoErrs thing = ifErrsM (return ()) thing
+
+ifErrsM :: TcRn r -> TcRn r -> TcRn r
+--      ifErrsM bale_out normal
+-- does 'bale_out' if there are errors in errors collection
+-- otherwise does 'normal'
+ifErrsM bale_out normal
+ = do { errs_var <- getErrsVar ;
+        msgs <- readTcRef errs_var ;
+        dflags <- getDynFlags ;
+        if errorsFound dflags msgs then
+           bale_out
+        else
+           normal }
+
+failIfErrsM :: TcRn ()
+-- Useful to avoid error cascades
+failIfErrsM = ifErrsM failM (return ())
+
+checkTH :: a -> String -> TcRn ()
+checkTH _ _ = return () -- OK
+
+failTH :: Outputable a => a -> String -> TcRn x
+failTH e what  -- Raise an error in a stage-1 compiler
+  = failWithTc (vcat [ hang (char 'A' <+> text what
+                             <+> text "requires GHC with interpreter support:")
+                          2 (ppr e)
+                     , text "Perhaps you are using a stage-1 compiler?" ])
+
+
+{- *********************************************************************
+*                                                                      *
+        Context management for the type checker
+*                                                                      *
+************************************************************************
+-}
+
+getErrCtxt :: TcM [ErrCtxt]
+getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }
+
+setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a
+setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })
+
+-- | Add a fixed message to the error context. This message should not
+-- do any tidying.
+addErrCtxt :: MsgDoc -> TcM a -> TcM a
+addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))
+
+-- | Add a message to the error context. This message may do tidying.
+addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
+addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)
+
+-- | Add a fixed landmark message to the error context. A landmark
+-- message is always sure to be reported, even if there is a lot of
+-- context. It also doesn't count toward the maximum number of contexts
+-- reported.
+addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a
+addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))
+
+-- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations
+-- and tidying.
+addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a
+addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)
+
+-- Helper function for the above
+updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a
+updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->
+                           env { tcl_ctxt = upd ctxt })
+
+popErrCtxt :: TcM a -> TcM a
+popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
+
+getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
+getCtLocM origin t_or_k
+  = do { env <- getLclEnv
+       ; return (CtLoc { ctl_origin = origin
+                       , ctl_env    = env
+                       , ctl_t_or_k = t_or_k
+                       , ctl_depth  = initialSubGoalDepth }) }
+
+setCtLocM :: CtLoc -> TcM a -> TcM a
+-- Set the SrcSpan and error context from the CtLoc
+setCtLocM (CtLoc { ctl_env = lcl }) thing_inside
+  = updLclEnv (\env -> env { tcl_loc   = tcl_loc lcl
+                           , tcl_bndrs = tcl_bndrs lcl
+                           , tcl_ctxt  = tcl_ctxt lcl })
+              thing_inside
+
+{-
+************************************************************************
+*                                                                      *
+             Error message generation (type checker)
+*                                                                      *
+************************************************************************
+
+    The addErrTc functions add an error message, but do not cause failure.
+    The 'M' variants pass a TidyEnv that has already been used to
+    tidy up the message; we then use it to tidy the context messages
+-}
+
+addErrTc :: MsgDoc -> TcM ()
+addErrTc err_msg = do { env0 <- tcInitTidyEnv
+                      ; addErrTcM (env0, err_msg) }
+
+addErrsTc :: [MsgDoc] -> TcM ()
+addErrsTc err_msgs = mapM_ addErrTc err_msgs
+
+addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()
+addErrTcM (tidy_env, err_msg)
+  = do { ctxt <- getErrCtxt ;
+         loc  <- getSrcSpanM ;
+         add_err_tcm tidy_env err_msg loc ctxt }
+
+-- Return the error message, instead of reporting it straight away
+mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg
+mkErrTcM (tidy_env, err_msg)
+  = do { ctxt <- getErrCtxt ;
+         loc  <- getSrcSpanM ;
+         err_info <- mkErrInfo tidy_env ctxt ;
+         mkLongErrAt loc err_msg err_info }
+
+mkErrTc :: MsgDoc -> TcM ErrMsg
+mkErrTc msg = do { env0 <- tcInitTidyEnv
+                 ; mkErrTcM (env0, msg) }
+
+-- The failWith functions add an error message and cause failure
+
+failWithTc :: MsgDoc -> TcM a               -- Add an error message and fail
+failWithTc err_msg
+  = addErrTc err_msg >> failM
+
+failWithTcM :: (TidyEnv, MsgDoc) -> TcM a   -- Add an error message and fail
+failWithTcM local_and_msg
+  = addErrTcM local_and_msg >> failM
+
+checkTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is true
+checkTc True  _   = return ()
+checkTc False err = failWithTc err
+
+checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
+checkTcM True  _   = return ()
+checkTcM False err = failWithTcM err
+
+failIfTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is false
+failIfTc False _   = return ()
+failIfTc True  err = failWithTc err
+
+failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()
+   -- Check that the boolean is false
+failIfTcM False _   = return ()
+failIfTcM True  err = failWithTcM err
+
+
+--         Warnings have no 'M' variant, nor failure
+
+-- | Display a warning if a condition is met,
+--   and the warning is enabled
+warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn ()
+warnIfFlag warn_flag is_bad msg
+  = do { warn_on <- woptM warn_flag
+       ; when (warn_on && is_bad) $
+         addWarn (Reason warn_flag) msg }
+
+-- | Display a warning if a condition is met.
+warnIf :: Bool -> MsgDoc -> TcRn ()
+warnIf is_bad msg
+  = when is_bad (addWarn NoReason msg)
+
+-- | Display a warning if a condition is met.
+warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()
+warnTc reason warn_if_true warn_msg
+  | warn_if_true = addWarnTc reason warn_msg
+  | otherwise    = return ()
+
+-- | Display a warning if a condition is met.
+warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()
+warnTcM reason warn_if_true warn_msg
+  | warn_if_true = addWarnTcM reason warn_msg
+  | otherwise    = return ()
+
+-- | Display a warning in the current context.
+addWarnTc :: WarnReason -> MsgDoc -> TcM ()
+addWarnTc reason msg
+ = do { env0 <- tcInitTidyEnv ;
+      addWarnTcM reason (env0, msg) }
+
+-- | Display a warning in a given context.
+addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()
+addWarnTcM reason (env0, msg)
+ = do { ctxt <- getErrCtxt ;
+        err_info <- mkErrInfo env0 ctxt ;
+        add_warn reason msg err_info }
+
+-- | Display a warning for the current source location.
+addWarn :: WarnReason -> MsgDoc -> TcRn ()
+addWarn reason msg = add_warn reason msg Outputable.empty
+
+-- | Display a warning for a given source location.
+addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
+addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty
+
+-- | Display a warning, with an optional flag, for the current source
+-- location.
+add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()
+add_warn reason msg extra_info
+  = do { loc <- getSrcSpanM
+       ; add_warn_at reason loc msg extra_info }
+
+-- | Display a warning, with an optional flag, for a given location.
+add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
+add_warn_at reason loc msg extra_info
+  = do { dflags <- getDynFlags ;
+         printer <- getPrintUnqualified dflags ;
+         let { warn = mkLongWarnMsg dflags loc printer
+                                    msg extra_info } ;
+         reportWarning reason warn }
+
+
+{-
+-----------------------------------
+        Other helper functions
+-}
+
+add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan
+            -> [ErrCtxt]
+            -> TcM ()
+add_err_tcm tidy_env err_msg loc ctxt
+ = do { err_info <- mkErrInfo tidy_env ctxt ;
+        addLongErrAt loc err_msg err_info }
+
+mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
+-- Tidy the error info, trimming excessive contexts
+mkErrInfo env ctxts
+--  = do
+--       dbg <- hasPprDebug <$> getDynFlags
+--       if dbg                -- In -dppr-debug style the output
+--          then return empty  -- just becomes too voluminous
+--          else go dbg 0 env ctxts
+ = go False 0 env ctxts
+ where
+   go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
+   go _ _ _   [] = return empty
+   go dbg n env ((is_landmark, ctxt) : ctxts)
+     | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg
+     = do { (env', msg) <- ctxt env
+          ; let n' = if is_landmark then n else n+1
+          ; rest <- go dbg n' env' ctxts
+          ; return (msg $$ rest) }
+     | otherwise
+     = go dbg n env ctxts
+
+mAX_CONTEXTS :: Int     -- No more than this number of non-landmark contexts
+mAX_CONTEXTS = 3
+
+-- debugTc is useful for monadic debugging code
+
+debugTc :: TcM () -> TcM ()
+debugTc thing
+ | debugIsOn = thing
+ | otherwise = return ()
+
+{-
+************************************************************************
+*                                                                      *
+             Type constraints
+*                                                                      *
+************************************************************************
+-}
+
+addTopEvBinds :: Bag EvBind -> TcM a -> TcM a
+addTopEvBinds new_ev_binds thing_inside
+  =updGblEnv upd_env thing_inside
+  where
+    upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env
+                                               `unionBags` new_ev_binds }
+
+newTcEvBinds :: TcM EvBindsVar
+newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap
+                  ; tcvs_ref  <- newTcRef emptyVarSet
+                  ; uniq <- newUnique
+                  ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)
+                  ; return (EvBindsVar { ebv_binds = binds_ref
+                                       , ebv_tcvs = tcvs_ref
+                                       , ebv_uniq = uniq }) }
+
+-- | Creates an EvBindsVar incapable of holding any bindings. It still
+-- tracks covar usages (see comments on ebv_tcvs in TcEvidence), thus
+-- must be made monadically
+newNoTcEvBinds :: TcM EvBindsVar
+newNoTcEvBinds
+  = do { tcvs_ref  <- newTcRef emptyVarSet
+       ; uniq <- newUnique
+       ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)
+       ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref
+                              , ebv_uniq = uniq }) }
+
+cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar
+-- Clone the refs, so that any binding created when
+-- solving don't pollute the original
+cloneEvBindsVar ebv@(EvBindsVar {})
+  = do { binds_ref <- newTcRef emptyEvBindMap
+       ; tcvs_ref  <- newTcRef emptyVarSet
+       ; return (ebv { ebv_binds = binds_ref
+                     , ebv_tcvs = tcvs_ref }) }
+cloneEvBindsVar ebv@(CoEvBindsVar {})
+  = do { tcvs_ref  <- newTcRef emptyVarSet
+       ; return (ebv { ebv_tcvs = tcvs_ref }) }
+
+getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet
+getTcEvTyCoVars ev_binds_var
+  = readTcRef (ebv_tcvs ev_binds_var)
+
+getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap
+getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })
+  = readTcRef ev_ref
+getTcEvBindsMap (CoEvBindsVar {})
+  = return emptyEvBindMap
+
+setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()
+setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds
+  = writeTcRef ev_ref binds
+setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds
+  | isEmptyEvBindMap ev_binds
+  = return ()
+  | otherwise
+  = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds)
+
+addTcEvBind :: EvBindsVar -> EvBind -> TcM ()
+-- Add a binding to the TcEvBinds by side effect
+addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind
+  = do { traceTc "addTcEvBind" $ ppr u $$
+                                 ppr ev_bind
+       ; bnds <- readTcRef ev_ref
+       ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }
+addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind
+  = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u)
+
+chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
+chooseUniqueOccTc fn =
+  do { env <- getGblEnv
+     ; let dfun_n_var = tcg_dfun_n env
+     ; set <- readTcRef dfun_n_var
+     ; let occ = fn set
+     ; writeTcRef dfun_n_var (extendOccSet set occ)
+     ; return occ }
+
+getConstraintVar :: TcM (TcRef WantedConstraints)
+getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
+
+setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
+setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
+
+emitStaticConstraints :: WantedConstraints -> TcM ()
+emitStaticConstraints static_lie
+  = do { gbl_env <- getGblEnv
+       ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }
+
+emitConstraints :: WantedConstraints -> TcM ()
+emitConstraints ct
+  | isEmptyWC ct
+  = return ()
+  | otherwise
+  = do { lie_var <- getConstraintVar ;
+         updTcRef lie_var (`andWC` ct) }
+
+emitSimple :: Ct -> TcM ()
+emitSimple ct
+  = do { lie_var <- getConstraintVar ;
+         updTcRef lie_var (`addSimples` unitBag ct) }
+
+emitSimples :: Cts -> TcM ()
+emitSimples cts
+  = do { lie_var <- getConstraintVar ;
+         updTcRef lie_var (`addSimples` cts) }
+
+emitImplication :: Implication -> TcM ()
+emitImplication ct
+  = do { lie_var <- getConstraintVar ;
+         updTcRef lie_var (`addImplics` unitBag ct) }
+
+emitImplications :: Bag Implication -> TcM ()
+emitImplications ct
+  = unless (isEmptyBag ct) $
+    do { lie_var <- getConstraintVar ;
+         updTcRef lie_var (`addImplics` ct) }
+
+emitInsoluble :: Ct -> TcM ()
+emitInsoluble ct
+  = do { traceTc "emitInsoluble" (ppr ct)
+       ; lie_var <- getConstraintVar
+       ; updTcRef lie_var (`addInsols` unitBag ct) }
+
+emitInsolubles :: Cts -> TcM ()
+emitInsolubles cts
+  | isEmptyBag cts = return ()
+  | otherwise      = do { traceTc "emitInsolubles" (ppr cts)
+                        ; lie_var <- getConstraintVar
+                        ; updTcRef lie_var (`addInsols` cts) }
+
+-- | Throw out any constraints emitted by the thing_inside
+discardConstraints :: TcM a -> TcM a
+discardConstraints thing_inside = fst <$> captureConstraints thing_inside
+
+tryCaptureConstraints :: TcM a -> TcM (Either IOEnvFailure a, WantedConstraints)
+-- (captureConstraints_maybe m) runs m,
+-- and returns the type constraints it generates
+-- It never throws an exception; instead if thing_inside fails,
+--   it returns Left exn and the /insoluble/ constraints
+tryCaptureConstraints thing_inside
+  = do { lie_var <- newTcRef emptyWC
+       ; mb_res <- tryM $
+                   updLclEnv (\ env -> env { tcl_lie = lie_var }) $
+                   thing_inside
+       ; lie <- readTcRef lie_var
+
+       -- See Note [Constraints and errors]
+       ; let lie_to_keep = case mb_res of
+                             Left {}  -> insolublesOnly lie
+                             Right {} -> lie
+
+       ; return (mb_res, lie_to_keep) }
+
+captureConstraints :: TcM a -> TcM (a, WantedConstraints)
+-- (captureConstraints m) runs m, and returns the type constraints it generates
+captureConstraints thing_inside
+  = do { (mb_res, lie) <- tryCaptureConstraints thing_inside
+
+            -- See Note [Constraints and errors]
+            -- If the thing_inside threw an exception, emit the insoluble
+            -- constraints only (returned by tryCaptureConstraints)
+            -- so that they are not lost
+       ; case mb_res of
+           Left _    -> do { emitConstraints lie; failM }
+           Right res -> return (res, lie) }
+
+-- | The name says it all. The returned TcLevel is the *inner* TcLevel.
+pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
+pushLevelAndCaptureConstraints thing_inside
+  = do { env <- getLclEnv
+       ; let tclvl' = pushTcLevel (tcl_tclvl env)
+       ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl')
+       ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $
+                       captureConstraints thing_inside
+       ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl')
+       ; return (tclvl', lie, res) }
+
+pushTcLevelM_ :: TcM a -> TcM a
+pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x
+
+pushTcLevelM :: TcM a -> TcM (TcLevel, a)
+-- See Note [TcLevel assignment] in TcType
+pushTcLevelM thing_inside
+  = do { env <- getLclEnv
+       ; let tclvl' = pushTcLevel (tcl_tclvl env)
+       ; res <- setLclEnv (env { tcl_tclvl = tclvl' })
+                          thing_inside
+       ; return (tclvl', res) }
+
+-- Returns pushed TcLevel
+pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)
+pushTcLevelsM num_levels thing_inside
+  = do { env <- getLclEnv
+       ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env)
+       ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $
+                thing_inside
+       ; return (res, tclvl') }
+
+getTcLevel :: TcM TcLevel
+getTcLevel = do { env <- getLclEnv
+                ; return (tcl_tclvl env) }
+
+setTcLevel :: TcLevel -> TcM a -> TcM a
+setTcLevel tclvl thing_inside
+  = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside
+
+isTouchableTcM :: TcTyVar -> TcM Bool
+isTouchableTcM tv
+  = do { lvl <- getTcLevel
+       ; return (isTouchableMetaTyVar lvl tv) }
+
+getLclTypeEnv :: TcM TcTypeEnv
+getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
+
+setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
+-- Set the local type envt, but do *not* disturb other fields,
+-- notably the lie_var
+setLclTypeEnv lcl_env thing_inside
+  = updLclEnv upd thing_inside
+  where
+    upd env = env { tcl_env = tcl_env lcl_env,
+                    tcl_tyvars = tcl_tyvars lcl_env }
+
+traceTcConstraints :: String -> TcM ()
+traceTcConstraints msg
+  = do { lie_var <- getConstraintVar
+       ; lie     <- readTcRef lie_var
+       ; traceOptTcRn Opt_D_dump_tc_trace $
+         hang (text (msg ++ ": LIE:")) 2 (ppr lie)
+       }
+
+emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
+emitWildCardHoleConstraints wcs
+  = do { ct_loc <- getCtLocM HoleOrigin Nothing
+       ; emitInsolubles $ listToBag $
+         map (do_one ct_loc) wcs }
+  where
+    do_one :: CtLoc -> (Name, TcTyVar) -> Ct
+    do_one ct_loc (name, tv)
+       = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv
+                                      , ctev_loc  = ct_loc' }
+                  , cc_hole = TypeHole (occName name) }
+       where
+         real_span = case nameSrcSpan name of
+                           RealSrcSpan span  -> span
+                           UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"
+                                                      (ppr name <+> quotes (ftext str))
+               -- Wildcards are defined locally, and so have RealSrcSpans
+         ct_loc' = setCtLocSpan ct_loc real_span
+
+{- Note [Constraints and errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (Trac #12124):
+
+  foo :: Maybe Int
+  foo = return (case Left 3 of
+                  Left -> 1  -- Hard error here!
+                  _    -> 0)
+
+The call to 'return' will generate a (Monad m) wanted constraint; but
+then there'll be "hard error" (i.e. an exception in the TcM monad), from
+the unsaturated Left constructor pattern.
+
+We'll recover in tcPolyBinds, using recoverM.  But then the final
+tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
+un-filled-in, and will emit a misleading error message.
+
+The underlying problem is that an exception interrupts the constraint
+gathering process. Bottom line: if we have an exception, it's best
+simply to discard any gathered constraints.  Hence in 'try_m' we
+capture the constraints in a fresh variable, and only emit them into
+the surrounding context if we exit normally.  If an exception is
+raised, simply discard the collected constraints... we have a hard
+error to report.  So this capture-the-emit dance isn't as stupid as it
+looks :-).
+
+However suppose we throw an exception inside an invocation of
+captureConstraints, and discard all the constraints. Some of those
+constraints might be "variable out of scope" Hole constraints, and that
+might have been the actual original cause of the exception!  For
+example (Trac #12529):
+   f = p @ Int
+Here 'p' is out of scope, so we get an insolube Hole constraint. But
+the visible type application fails in the monad (thows an exception).
+We must not discard the out-of-scope error.
+
+So we /retain the insoluble constraints/ if there is an exception.
+Hence:
+  - insolublesOnly in tryCaptureConstraints
+  - emitConstraints in the Left case of captureConstraints
+
+Hover note that fresly-generated constraints like (Int ~ Bool), or
+((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as
+insoluble.  The constraint solver does that.  So they'll be discarded.
+That's probably ok; but see th/5358 as a not-so-good example:
+   t1 :: Int
+   t1 x = x   -- Manifestly wrong
+
+   foo = $(...raises exception...)
+We report the exception, but not the bug in t1.  Oh well.  Possible
+solution: make TcUnify.uType spot manifestly-insoluble constraints.
+
+
+************************************************************************
+*                                                                      *
+             Template Haskell context
+*                                                                      *
+************************************************************************
+-}
+
+recordThUse :: TcM ()
+recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
+
+recordThSpliceUse :: TcM ()
+recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }
+
+-- | When generating an out-of-scope error message for a variable matching a
+-- binding in a later inter-splice group, the typechecker uses the splice
+-- locations to provide details in the message about the scope of that binding.
+recordTopLevelSpliceLoc :: SrcSpan -> TcM ()
+recordTopLevelSpliceLoc (RealSrcSpan real_loc)
+  = do { env <- getGblEnv
+       ; let locs_var = tcg_th_top_level_locs env
+       ; locs0 <- readTcRef locs_var
+       ; writeTcRef locs_var (Set.insert real_loc locs0) }
+recordTopLevelSpliceLoc (UnhelpfulSpan _) = return ()
+
+getTopLevelSpliceLocs :: TcM (Set RealSrcSpan)
+getTopLevelSpliceLocs
+  = do { env <- getGblEnv
+       ; readTcRef (tcg_th_top_level_locs env) }
+
+keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set
+keepAlive name
+  = do { env <- getGblEnv
+       ; traceRn "keep alive" (ppr name)
+       ; updTcRef (tcg_keep env) (`extendNameSet` name) }
+
+getStage :: TcM ThStage
+getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
+
+getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))
+getStageAndBindLevel name
+  = do { env <- getLclEnv;
+       ; case lookupNameEnv (tcl_th_bndrs env) name of
+           Nothing                  -> return Nothing
+           Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }
+
+setStage :: ThStage -> TcM a -> TcRn a
+setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })
+
+-- | Adds the given modFinalizers to the global environment and set them to use
+-- the current local environment.
+addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()
+addModFinalizersWithLclEnv mod_finalizers
+  = do lcl_env <- getLclEnv
+       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
+       updTcRef th_modfinalizers_var $ \fins ->
+         (lcl_env, mod_finalizers) : fins
+
+{-
+************************************************************************
+*                                                                      *
+             Safe Haskell context
+*                                                                      *
+************************************************************************
+-}
+
+-- | Mark that safe inference has failed
+-- See Note [Safe Haskell Overlapping Instances Implementation]
+-- although this is used for more than just that failure case.
+recordUnsafeInfer :: WarningMessages -> TcM ()
+recordUnsafeInfer warns =
+    getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)
+
+-- | Figure out the final correct safe haskell mode
+finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode
+finalSafeMode dflags tcg_env = do
+    safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)
+    return $ case safeHaskell dflags of
+        Sf_None | safeInferOn dflags && safeInf -> Sf_Safe
+                | otherwise                     -> Sf_None
+        s -> s
+
+-- | Switch instances to safe instances if we're in Safe mode.
+fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]
+fixSafeInstances sfMode | sfMode /= Sf_Safe = id
+fixSafeInstances _ = map fixSafe
+  where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }
+                       in inst { is_flag = new_flag }
+
+{-
+************************************************************************
+*                                                                      *
+             Stuff for the renamer's local env
+*                                                                      *
+************************************************************************
+-}
+
+getLocalRdrEnv :: RnM LocalRdrEnv
+getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }
+
+setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a
+setLocalRdrEnv rdr_env thing_inside
+  = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside
+
+{-
+************************************************************************
+*                                                                      *
+             Stuff for interface decls
+*                                                                      *
+************************************************************************
+-}
+
+mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv
+mkIfLclEnv mod loc boot
+                   = IfLclEnv { if_mod     = mod,
+                                if_loc     = loc,
+                                if_boot    = boot,
+                                if_nsubst  = Nothing,
+                                if_implicits_env = Nothing,
+                                if_tv_env  = emptyFsEnv,
+                                if_id_env  = emptyFsEnv }
+
+-- | Run an 'IfG' (top-level interface monad) computation inside an existing
+-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'
+-- based on 'TcGblEnv'.
+initIfaceTcRn :: IfG a -> TcRn a
+initIfaceTcRn thing_inside
+  = do  { tcg_env <- getGblEnv
+        ; dflags <- getDynFlags
+        ; let !mod = tcg_semantic_mod tcg_env
+              -- When we are instantiating a signature, we DEFINITELY
+              -- do not want to knot tie.
+              is_instantiate = unitIdIsDefinite (thisPackage dflags) &&
+                               not (null (thisUnitIdInsts dflags))
+        ; let { if_env = IfGblEnv {
+                            if_doc = text "initIfaceTcRn",
+                            if_rec_types =
+                                if is_instantiate
+                                    then Nothing
+                                    else Just (mod, get_type_env)
+                         }
+              ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
+        ; setEnvs (if_env, ()) thing_inside }
+
+-- Used when sucking in a ModIface into a ModDetails to put in
+-- the HPT.  Notably, unlike initIfaceCheck, this does NOT use
+-- hsc_type_env_var (since we're not actually going to typecheck,
+-- so this variable will never get updated!)
+initIfaceLoad :: HscEnv -> IfG a -> IO a
+initIfaceLoad hsc_env do_this
+ = do let gbl_env = IfGblEnv {
+                        if_doc = text "initIfaceLoad",
+                        if_rec_types = Nothing
+                    }
+      initTcRnIf 'i' hsc_env gbl_env () do_this
+
+initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
+-- Used when checking the up-to-date-ness of the old Iface
+-- Initialise the environment with no useful info at all
+initIfaceCheck doc hsc_env do_this
+ = do let rec_types = case hsc_type_env_var hsc_env of
+                         Just (mod,var) -> Just (mod, readTcRef var)
+                         Nothing        -> Nothing
+          gbl_env = IfGblEnv {
+                        if_doc = text "initIfaceCheck" <+> doc,
+                        if_rec_types = rec_types
+                    }
+      initTcRnIf 'i' hsc_env gbl_env () do_this
+
+initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a
+initIfaceLcl mod loc_doc hi_boot_file thing_inside
+  = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside
+
+-- | Initialize interface typechecking, but with a 'NameShape'
+-- to apply when typechecking top-level 'OccName's (see
+-- 'lookupIfaceTop')
+initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a
+initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside
+  = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside
+
+getIfModule :: IfL Module
+getIfModule = do { env <- getLclEnv; return (if_mod env) }
+
+--------------------
+failIfM :: MsgDoc -> IfL a
+-- The Iface monad doesn't have a place to accumulate errors, so we
+-- just fall over fast if one happens; it "shouldn't happen".
+-- We use IfL here so that we can get context info out of the local env
+failIfM msg
+  = do  { env <- getLclEnv
+        ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
+        ; dflags <- getDynFlags
+        ; liftIO (putLogMsg dflags NoReason SevFatal
+                   noSrcSpan (defaultErrStyle dflags) full_msg)
+        ; failM }
+
+--------------------
+forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
+-- Run thing_inside in an interleaved thread.
+-- It shares everything with the parent thread, so this is DANGEROUS.
+--
+-- It returns Nothing if the computation fails
+--
+-- It's used for lazily type-checking interface
+-- signatures, which is pretty benign
+
+forkM_maybe doc thing_inside
+ -- NB: Don't share the mutable env_us with the interleaved thread since env_us
+ --     does not get updated atomically (e.g. in newUnique and newUniqueSupply).
+ = do { child_us <- newUniqueSupply
+      ; child_env_us <- newMutVar child_us
+        -- see Note [Masking exceptions in forkM_maybe]
+      ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $
+        do { traceIf (text "Starting fork {" <+> doc)
+           ; mb_res <- tryM $
+                       updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $
+                       thing_inside
+           ; case mb_res of
+                Right r  -> do  { traceIf (text "} ending fork" <+> doc)
+                                ; return (Just r) }
+                Left exn -> do {
+
+                    -- Bleat about errors in the forked thread, if -ddump-if-trace is on
+                    -- Otherwise we silently discard errors. Errors can legitimately
+                    -- happen when compiling interface signatures (see tcInterfaceSigs)
+                      whenDOptM Opt_D_dump_if_trace $ do
+                          dflags <- getDynFlags
+                          let msg = hang (text "forkM failed:" <+> doc)
+                                       2 (text (show exn))
+                          liftIO $ putLogMsg dflags
+                                             NoReason
+                                             SevFatal
+                                             noSrcSpan
+                                             (defaultErrStyle dflags)
+                                             msg
+
+                    ; traceIf (text "} ending fork (badly)" <+> doc)
+                    ; return Nothing }
+        }}
+
+forkM :: SDoc -> IfL a -> IfL a
+forkM doc thing_inside
+ = do   { mb_res <- forkM_maybe doc thing_inside
+        ; return (case mb_res of
+                        Nothing -> pgmError "Cannot continue after interface file error"
+                                   -- pprPanic "forkM" doc
+                        Just r  -> r) }
+
+setImplicitEnvM :: TypeEnv -> IfL a -> IfL a
+setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl
+                                     { if_implicits_env = Just tenv }) m
+
+{-
+Note [Masking exceptions in forkM_maybe]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+When using GHC-as-API it must be possible to interrupt snippets of code
+executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible
+by throwing an asynchronous interrupt to the GHC thread. However, there is a
+subtle problem: runStmt first typechecks the code before running it, and the
+exception might interrupt the type checker rather than the code. Moreover, the
+typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and
+more importantly might be inside an exception handler inside that
+unsafeInterleaveIO. If that is the case, the exception handler will rethrow the
+asynchronous exception as a synchronous exception, and the exception will end
+up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed
+discussion).  We don't currently know a general solution to this problem, but
+we can use uninterruptibleMask_ to avoid the situation.
+-}
+
+-- | Environments which track 'CostCentreState'
+class ContainsCostCentreState e where
+  extractCostCentreState :: e -> TcRef CostCentreState
+
+instance ContainsCostCentreState TcGblEnv where
+  extractCostCentreState = tcg_cc_st
+
+instance ContainsCostCentreState DsGblEnv where
+  extractCostCentreState = ds_cc_st
+
+-- | Get the next cost centre index associated with a given name.
+getCCIndexM :: (ContainsCostCentreState gbl)
+            => FastString -> TcRnIf gbl lcl CostCentreIndex
+getCCIndexM nm = do
+  env <- getGblEnv
+  let cc_st_ref = extractCostCentreState env
+  cc_st <- readTcRef cc_st_ref
+  let (idx, cc_st') = getCCIndex nm cc_st
+  writeTcRef cc_st_ref cc_st'
+  return idx
diff --git a/compiler/typecheck/TcRules.hs b/compiler/typecheck/TcRules.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcRules.hs
@@ -0,0 +1,463 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1993-1998
+
+
+TcRules: Typechecking transformation rules
+-}
+
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcRules ( tcRules ) where
+
+import GhcPrelude
+
+import HsSyn
+import TcRnTypes
+import TcRnMonad
+import TcSimplify
+import TcMType
+import TcType
+import TcHsType
+import TcExpr
+import TcEnv
+import TcUnify( buildImplicationFor )
+import TcEvidence( mkTcCoVarCo )
+import Type
+import TyCon( isTypeFamilyTyCon )
+import Id
+import Var( EvVar )
+import VarSet
+import BasicTypes       ( RuleName )
+import SrcLoc
+import Outputable
+import FastString
+import Bag
+
+{-
+Note [Typechecking rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+We *infer* the typ of the LHS, and use that type to *check* the type of
+the RHS.  That means that higher-rank rules work reasonably well. Here's
+an example (test simplCore/should_compile/rule2.hs) produced by Roman:
+
+   foo :: (forall m. m a -> m b) -> m a -> m b
+   foo f = ...
+
+   bar :: (forall m. m a -> m a) -> m a -> m a
+   bar f = ...
+
+   {-# RULES "foo/bar" foo = bar #-}
+
+He wanted the rule to typecheck.
+
+Note [TcLevel in type checking rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Bringing type variables into scope naturally bumps the TcLevel. Thus, we type
+check the term-level binders in a bumped level, and we must accordingly bump
+the level whenever these binders are in scope.
+-}
+
+tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTcId]
+tcRules decls = mapM (wrapLocM tcRuleDecls) decls
+
+tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTcId)
+tcRuleDecls (HsRules { rds_src = src
+                     , rds_rules = decls })
+   = do { tc_decls <- mapM (wrapLocM tcRule) decls
+        ; return $ HsRules { rds_ext   = noExt
+                           , rds_src   = src
+                           , rds_rules = tc_decls } }
+tcRuleDecls (XRuleDecls _) = panic "tcRuleDecls"
+
+tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId)
+tcRule (HsRule { rd_ext  = ext
+               , rd_name = rname@(L _ (_,name))
+               , rd_act  = act
+               , rd_tyvs = ty_bndrs
+               , rd_tmvs = tm_bndrs
+               , rd_lhs  = lhs
+               , rd_rhs  = rhs })
+  = addErrCtxt (ruleCtxt name)  $
+    do { traceTc "---- Rule ------" (pprFullRuleName rname)
+
+        -- Note [Typechecking rules]
+       ; (tc_lvl, stuff) <- pushTcLevelM $
+                            generateRuleConstraints ty_bndrs tm_bndrs lhs rhs
+
+       ; let (tv_bndrs, id_bndrs, lhs', lhs_wanted
+                                , rhs', rhs_wanted, rule_ty) = stuff
+
+       ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname
+                                  , ppr lhs_wanted
+                                  , ppr rhs_wanted ])
+
+       ; (lhs_evs, residual_lhs_wanted)
+            <- simplifyRule name tc_lvl lhs_wanted rhs_wanted
+
+       -- SimplfyRule Plan, step 4
+       -- Now figure out what to quantify over
+       -- c.f. TcSimplify.simplifyInfer
+       -- We quantify over any tyvars free in *either* the rule
+       --  *or* the bound variables.  The latter is important.  Consider
+       --      ss (x,(y,z)) = (x,z)
+       --      RULE:  forall v. fst (ss v) = fst v
+       -- The type of the rhs of the rule is just a, but v::(a,(b,c))
+       --
+       -- We also need to get the completely-uconstrained tyvars of
+       -- the LHS, lest they otherwise get defaulted to Any; but we do that
+       -- during zonking (see TcHsSyn.zonkRule)
+
+       ; let tpl_ids = lhs_evs ++ id_bndrs
+       ; gbls  <- tcGetGlobalTyCoVars -- Even though top level, there might be top-level
+                                      -- monomorphic bindings from the MR; test tc111
+       ; forall_tkvs <- candidateQTyVarsOfTypes $
+                        map (mkSpecForAllTys tv_bndrs) $  -- don't quantify over lexical tyvars
+                        rule_ty : map idType tpl_ids
+       ; qtkvs <- quantifyTyVars gbls forall_tkvs
+       ; traceTc "tcRule" (vcat [ pprFullRuleName rname
+                                , ppr forall_tkvs
+                                , ppr qtkvs
+                                , ppr tv_bndrs
+                                , ppr rule_ty
+                                , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ]
+                  ])
+
+       -- SimplfyRule Plan, step 5
+       -- Simplify the LHS and RHS constraints:
+       -- For the LHS constraints we must solve the remaining constraints
+       -- (a) so that we report insoluble ones
+       -- (b) so that we bind any soluble ones
+       ; let all_qtkvs = qtkvs ++ tv_bndrs
+             skol_info = RuleSkol name
+       ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info all_qtkvs
+                                         lhs_evs residual_lhs_wanted
+       ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info all_qtkvs
+                                         lhs_evs rhs_wanted
+
+       ; emitImplications (lhs_implic `unionBags` rhs_implic)
+       ; return $ HsRule { rd_ext = ext
+                         , rd_name = rname
+                         , rd_act = act
+                         , rd_tyvs = ty_bndrs -- preserved for ppr-ing
+                         , rd_tmvs = map (noLoc . RuleBndr noExt . noLoc) (all_qtkvs ++ tpl_ids)
+                         , rd_lhs  = mkHsDictLet lhs_binds lhs'
+                         , rd_rhs  = mkHsDictLet rhs_binds rhs' } }
+tcRule (XRuleDecl _) = panic "tcRule"
+
+generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]
+                        -> LHsExpr GhcRn -> LHsExpr GhcRn
+                        -> TcM ( [TyVar]
+                               , [TcId]
+                               , LHsExpr GhcTc, WantedConstraints
+                               , LHsExpr GhcTc, WantedConstraints
+                               , TcType )
+generateRuleConstraints ty_bndrs tm_bndrs lhs rhs
+  = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $
+                                                tcRuleBndrs ty_bndrs tm_bndrs
+              -- bndr_wanted constraints can include wildcard hole
+              -- constraints, which we should not forget about.
+              -- It may mention the skolem type variables bound by
+              -- the RULE.  c.f. Trac #10072
+
+       ; tcExtendTyVarEnv tv_bndrs $
+         tcExtendIdEnv    id_bndrs $
+    do { -- See Note [Solve order for RULES]
+         ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)
+       ; (rhs',            rhs_wanted) <- captureConstraints $
+                                          tcMonoExpr rhs (mkCheckExpType rule_ty)
+       ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted
+       ; return (tv_bndrs, id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } }
+
+-- See Note [TcLevel in type checking rules]
+tcRuleBndrs :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]
+            -> TcM ([TcTyVar], [Id])
+tcRuleBndrs (Just bndrs) xs
+  = do { (tys1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $
+                              tcRuleTmBndrs xs
+       ; return (tys1 ++ tys2, tms) }
+
+tcRuleBndrs Nothing xs
+  = tcRuleTmBndrs xs
+
+-- See Note [TcLevel in type checking rules]
+tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])
+tcRuleTmBndrs [] = return ([],[])
+tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs)
+  = do  { ty <- newOpenFlexiTyVarTy
+        ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs
+        ; return (tyvars, mkLocalId name ty : tmvars) }
+tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)
+--  e.g         x :: a->a
+--  The tyvar 'a' is brought into scope first, just as if you'd written
+--              a::*, x :: a->a
+--  If there's an explicit forall, the renamer would have already reported an
+--   error for each out-of-scope type variable used
+  = do  { let ctxt = RuleSigCtxt name
+        ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty
+        ; let id  = mkLocalIdOrCoVar name id_ty
+                    -- See Note [Pattern signature binders] in TcHsType
+
+              -- The type variables scope over subsequent bindings; yuk
+        ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $
+                                   tcRuleTmBndrs rule_bndrs
+        ; return (map snd tvs ++ tyvars, id : tmvars) }
+tcRuleTmBndrs (L _ (XRuleBndr _) : _) = panic "tcRuleTmBndrs"
+
+ruleCtxt :: FastString -> SDoc
+ruleCtxt name = text "When checking the transformation rule" <+>
+                doubleQuotes (ftext name)
+
+
+{-
+*********************************************************************************
+*                                                                                 *
+              Constraint simplification for rules
+*                                                                                 *
+***********************************************************************************
+
+Note [The SimplifyRule Plan]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Example.  Consider the following left-hand side of a rule
+        f (x == y) (y > z) = ...
+If we typecheck this expression we get constraints
+        d1 :: Ord a, d2 :: Eq a
+We do NOT want to "simplify" to the LHS
+        forall x::a, y::a, z::a, d1::Ord a.
+          f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ...
+Instead we want
+        forall x::a, y::a, z::a, d1::Ord a, d2::Eq a.
+          f ((==) d2 x y) ((>) d1 y z) = ...
+
+Here is another example:
+        fromIntegral :: (Integral a, Num b) => a -> b
+        {-# RULES "foo"  fromIntegral = id :: Int -> Int #-}
+In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But
+we *dont* want to get
+        forall dIntegralInt.
+           fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int
+because the scsel will mess up RULE matching.  Instead we want
+        forall dIntegralInt, dNumInt.
+          fromIntegral Int Int dIntegralInt dNumInt = id Int
+
+Even if we have
+        g (x == y) (y == z) = ..
+where the two dictionaries are *identical*, we do NOT WANT
+        forall x::a, y::a, z::a, d1::Eq a
+          f ((==) d1 x y) ((>) d1 y z) = ...
+because that will only match if the dict args are (visibly) equal.
+Instead we want to quantify over the dictionaries separately.
+
+In short, simplifyRuleLhs must *only* squash equalities, leaving
+all dicts unchanged, with absolutely no sharing.
+
+Also note that we can't solve the LHS constraints in isolation:
+Example   foo :: Ord a => a -> a
+          foo_spec :: Int -> Int
+          {-# RULE "foo"  foo = foo_spec #-}
+Here, it's the RHS that fixes the type variable
+
+HOWEVER, under a nested implication things are different
+Consider
+  f :: (forall a. Eq a => a->a) -> Bool -> ...
+  {-# RULES "foo" forall (v::forall b. Eq b => b->b).
+       f b True = ...
+    #-}
+Here we *must* solve the wanted (Eq a) from the given (Eq a)
+resulting from skolemising the argument type of g.  So we
+revert to SimplCheck when going under an implication.
+
+
+--------- So the SimplifyRule Plan is this -----------------------
+
+* Step 0: typecheck the LHS and RHS to get constraints from each
+
+* Step 1: Simplify the LHS and RHS constraints all together in one bag
+          We do this to discover all unification equalities
+
+* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take
+          advantage of those unifications
+
+* Setp 3: Partition the LHS constraints into the ones we will
+          quantify over, and the others.
+          See Note [RULE quantification over equalities]
+
+* Step 4: Decide on the type variables to quantify over
+
+* Step 5: Simplify the LHS and RHS constraints separately, using the
+          quantified constraints as givens
+
+Note [Solve order for RULES]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In step 1 above, we need to be a bit careful about solve order.
+Consider
+   f :: Int -> T Int
+   type instance T Int = Bool
+
+   RULE f 3 = True
+
+From the RULE we get
+   lhs-constraints:  T Int ~ alpha
+   rhs-constraints:  Bool ~ alpha
+where 'alpha' is the type that connects the two.  If we glom them
+all together, and solve the RHS constraint first, we might solve
+with alpha := Bool.  But then we'd end up with a RULE like
+
+    RULE: f 3 |> (co :: T Int ~ Bool) = True
+
+which is terrible.  We want
+
+    RULE: f 3 = True |> (sym co :: Bool ~ T Int)
+
+So we are careful to solve the LHS constraints first, and *then* the
+RHS constraints.  Actually much of this is done by the on-the-fly
+constraint solving, so the same order must be observed in
+tcRule.
+
+
+Note [RULE quantification over equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Deciding which equalities to quantify over is tricky:
+ * We do not want to quantify over insoluble equalities (Int ~ Bool)
+    (a) because we prefer to report a LHS type error
+    (b) because if such things end up in 'givens' we get a bogus
+        "inaccessible code" error
+
+ * But we do want to quantify over things like (a ~ F b), where
+   F is a type function.
+
+The difficulty is that it's hard to tell what is insoluble!
+So we see whether the simplification step yielded any type errors,
+and if so refrain from quantifying over *any* equalities.
+
+Note [Quantifying over coercion holes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Equality constraints from the LHS will emit coercion hole Wanteds.
+These don't have a name, so we can't quantify over them directly.
+Instead, because we really do want to quantify here, invent a new
+EvVar for the coercion, fill the hole with the invented EvVar, and
+then quantify over the EvVar. Not too tricky -- just some
+impedance matching, really.
+
+Note [Simplify cloned constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+At this stage, we're simplifying constraints only for insolubility
+and for unification. Note that all the evidence is quickly discarded.
+We use a clone of the real constraint. If we don't do this,
+then RHS coercion-hole constraints get filled in, only to get filled
+in *again* when solving the implications emitted from tcRule. That's
+terrible, so we avoid the problem by cloning the constraints.
+
+-}
+
+simplifyRule :: RuleName
+             -> TcLevel                 -- Level at which to solve the constraints
+             -> WantedConstraints       -- Constraints from LHS
+             -> WantedConstraints       -- Constraints from RHS
+             -> TcM ( [EvVar]               -- Quantify over these LHS vars
+                    , WantedConstraints)    -- Residual un-quantified LHS constraints
+-- See Note [The SimplifyRule Plan]
+-- NB: This consumes all simple constraints on the LHS, but not
+-- any LHS implication constraints.
+simplifyRule name tc_lvl lhs_wanted rhs_wanted
+  = do {
+       -- Note [The SimplifyRule Plan] step 1
+       -- First solve the LHS and *then* solve the RHS
+       -- Crucially, this performs unifications
+       -- Why clone?  See Note [Simplify cloned constraints]
+       ; lhs_clone <- cloneWC lhs_wanted
+       ; rhs_clone <- cloneWC rhs_wanted
+       ; setTcLevel tc_lvl $
+         runTcSDeriveds    $
+         do { _ <- solveWanteds lhs_clone
+            ; _ <- solveWanteds rhs_clone
+                  -- Why do them separately?
+                  -- See Note [Solve order for RULES]
+            ; return () }
+
+       -- Note [The SimplifyRule Plan] step 2
+       ; lhs_wanted <- zonkWC lhs_wanted
+       ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted
+
+       -- Note [The SimplifyRule Plan] step 3
+       ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts)
+
+       ; traceTc "simplifyRule" $
+         vcat [ text "LHS of rule" <+> doubleQuotes (ftext name)
+              , text "lhs_wanted" <+> ppr lhs_wanted
+              , text "rhs_wanted" <+> ppr rhs_wanted
+              , text "quant_cts" <+> ppr quant_cts
+              , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted
+              ]
+
+       ; return (quant_evs, residual_lhs_wanted) }
+
+  where
+    mk_quant_ev :: Ct -> TcM EvVar
+    mk_quant_ev ct
+      | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct
+      = case dest of
+          EvVarDest ev_id -> return ev_id
+          HoleDest hole   -> -- See Note [Quantifying over coercion holes]
+                             do { ev_id <- newEvVar pred
+                                ; fillCoercionHole hole (mkTcCoVarCo ev_id)
+                                ; return ev_id }
+    mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct)
+
+
+getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints)
+-- Extract all the constraints we can quantify over,
+--   also returning the depleted WantedConstraints
+--
+-- NB: we must look inside implications, because with
+--     -fdefer-type-errors we generate implications rather eagerly;
+--     see TcUnify.implicationNeeded. Not doing so caused Trac #14732.
+--
+-- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged,
+--   and attempt to solve them from the quantified constraints.  That
+--   nearly works, but fails for a constraint like (d :: Eq Int).
+--   We /do/ want to quantify over it, but the short-cut solver
+--   (see TcInteract Note [Shortcut solving]) ignores the quantified
+--   and instead solves from the top level.
+--
+--   So we must partition the WantedConstraints ourselves
+--   Not hard, but tiresome.
+
+getRuleQuantCts wc
+  = float_wc emptyVarSet wc
+  where
+    float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)
+    float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics })
+      = ( simple_yes `andCts` implic_yes
+        , WC { wc_simple = simple_no, wc_impl = implics_no })
+     where
+        (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples
+        (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs)
+                                                emptyBag implics
+
+    float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication)
+    float_implic skol_tvs yes1 imp
+      = (yes1 `andCts` yes2, imp { ic_wanted = no })
+      where
+        (yes2, no) = float_wc new_skol_tvs (ic_wanted imp)
+        new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp
+
+    rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool
+    rule_quant_ct skol_tvs ct
+      | EqPred _ t1 t2 <- classifyPredType (ctPred ct)
+      , not (ok_eq t1 t2)
+       = False        -- Note [RULE quantification over equalities]
+      | isHoleCt ct
+      = False         -- Don't quantify over type holes, obviously
+      | otherwise
+      = tyCoVarsOfCt ct `disjointVarSet` skol_tvs
+
+    ok_eq t1 t2
+       | t1 `tcEqType` t2 = False
+       | otherwise        = is_fun_app t1 || is_fun_app t2
+
+    is_fun_app ty   -- ty is of form (F tys) where F is a type function
+      = case tyConAppTyCon_maybe ty of
+          Just tc -> isTypeFamilyTyCon tc
+          Nothing -> False
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcSMonad.hs
@@ -0,0 +1,3526 @@
+{-# LANGUAGE CPP, TypeFamilies #-}
+
+-- Type definitions for the constraint solver
+module TcSMonad (
+
+    -- The work list
+    WorkList(..), isEmptyWorkList, emptyWorkList,
+    extendWorkListNonEq, extendWorkListCt,
+    extendWorkListCts, extendWorkListEq, extendWorkListFunEq,
+    appendWorkList, extendWorkListImplic,
+    selectNextWorkItem,
+    workListSize, workListWantedCount,
+    getWorkList, updWorkListTcS,
+
+    -- The TcS monad
+    TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds,
+    failTcS, warnTcS, addErrTcS,
+    runTcSEqualities,
+    nestTcS, nestImplicTcS, setEvBindsTcS,
+    checkConstraintsTcS, checkTvConstraintsTcS,
+
+    runTcPluginTcS, addUsedGRE, addUsedGREs,
+    matchGlobalInst, TcM.ClsInstResult(..),
+
+    QCInst(..),
+
+    -- Tracing etc
+    panicTcS, traceTcS,
+    traceFireTcS, bumpStepCountTcS, csTraceTcS,
+    wrapErrTcS, wrapWarnTcS,
+
+    -- Evidence creation and transformation
+    MaybeNew(..), freshGoals, isFresh, getEvExpr,
+
+    newTcEvBinds, newNoTcEvBinds,
+    newWantedEq, emitNewWantedEq,
+    newWanted, newWantedEvVar, newWantedNC, newWantedEvVarNC, newDerivedNC,
+    newBoundEvVarId,
+    unifyTyVar, unflattenFmv, reportUnifications,
+    setEvBind, setWantedEq,
+    setWantedEvTerm, setEvBindIfWanted,
+    newEvVar, newGivenEvVar, newGivenEvVars,
+    emitNewDeriveds, emitNewDerivedEq,
+    checkReductionDepth,
+    getSolvedDicts, setSolvedDicts,
+
+    getInstEnvs, getFamInstEnvs,                -- Getting the environments
+    getTopEnv, getGblEnv, getLclEnv,
+    getTcEvBindsVar, getTcLevel,
+    getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,
+    tcLookupClass, tcLookupId,
+
+    -- Inerts
+    InertSet(..), InertCans(..),
+    updInertTcS, updInertCans, updInertDicts, updInertIrreds,
+    getNoGivenEqs, setInertCans,
+    getInertEqs, getInertCans, getInertGivens,
+    getInertInsols,
+    getTcSInerts, setTcSInerts,
+    matchableGivens, prohibitedSuperClassSolve, mightMatchLater,
+    getUnsolvedInerts,
+    removeInertCts, getPendingGivenScs,
+    addInertCan, insertFunEq, addInertForAll,
+    emitWorkNC, emitWork,
+    isImprovable,
+
+    -- The Model
+    kickOutAfterUnification,
+
+    -- Inert Safe Haskell safe-overlap failures
+    addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,
+    getSafeOverlapFailures,
+
+    -- Inert CDictCans
+    DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict,
+    addDictsByClass, delDict, foldDicts, filterDicts, findDict,
+
+    -- Inert CTyEqCans
+    EqualCtList, findTyEqs, foldTyEqs, isInInertEqs,
+    lookupFlattenTyVar, lookupInertTyVar,
+
+    -- Inert solved dictionaries
+    addSolvedDict, lookupSolvedDict,
+
+    -- Irreds
+    foldIrreds,
+
+    -- The flattening cache
+    lookupFlatCache, extendFlatCache, newFlattenSkolem,            -- Flatten skolems
+    dischargeFunEq, pprKicked,
+
+    -- Inert CFunEqCans
+    updInertFunEqs, findFunEq,
+    findFunEqsByTyCon,
+
+    instDFunType,                              -- Instantiation
+
+    -- MetaTyVars
+    newFlexiTcSTy, instFlexi, instFlexiX,
+    cloneMetaTyVar, demoteUnfilledFmv,
+    tcInstSkolTyVarsX,
+
+    TcLevel,
+    isFilledMetaTyVar_maybe, isFilledMetaTyVar,
+    zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,
+    zonkTyCoVarsAndFVList,
+    zonkSimples, zonkWC,
+    zonkTyCoVarKind,
+
+    -- References
+    newTcRef, readTcRef, writeTcRef, updTcRef,
+
+    -- Misc
+    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,
+    matchFam, matchFamTcM,
+    checkWellStagedDFun,
+    pprEq                                    -- Smaller utils, re-exported from TcM
+                                             -- TODO (DV): these are only really used in the
+                                             -- instance matcher in TcSimplify. I am wondering
+                                             -- if the whole instance matcher simply belongs
+                                             -- here
+) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HscTypes
+
+import qualified Inst as TcM
+import InstEnv
+import FamInst
+import FamInstEnv
+
+import qualified TcRnMonad as TcM
+import qualified TcMType as TcM
+import qualified ClsInst as TcM( matchGlobalInst, ClsInstResult(..) )
+import qualified TcEnv as TcM
+       ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl )
+import PrelNames( heqTyConKey, eqTyConKey )
+import ClsInst( InstanceWhat(..) )
+import Kind
+import TcType
+import DynFlags
+import Type
+import Coercion
+import Unify
+
+import TcEvidence
+import Class
+import TyCon
+import TcErrors   ( solverDepthErrorTcS )
+
+import Name
+import Module ( HasModule, getModule )
+import RdrName ( GlobalRdrEnv, GlobalRdrElt )
+import qualified RnEnv as TcM
+import Var
+import VarEnv
+import VarSet
+import Outputable
+import Bag
+import UniqSupply
+import Util
+import TcRnTypes
+
+import Unique
+import UniqFM
+import UniqDFM
+import Maybes
+
+import CoreMap
+import Control.Monad
+import qualified Control.Monad.Fail as MonadFail
+import MonadUtils
+import Data.IORef
+import Data.List ( partition, mapAccumL )
+
+#if defined(DEBUG)
+import Digraph
+import UniqSet
+#endif
+
+{-
+************************************************************************
+*                                                                      *
+*                            Worklists                                *
+*  Canonical and non-canonical constraints that the simplifier has to  *
+*  work on. Including their simplification depths.                     *
+*                                                                      *
+*                                                                      *
+************************************************************************
+
+Note [WorkList priorities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A WorkList contains canonical and non-canonical items (of all flavors).
+Notice that each Ct now has a simplification depth. We may
+consider using this depth for prioritization as well in the future.
+
+As a simple form of priority queue, our worklist separates out
+
+* equalities (wl_eqs); see Note [Prioritise equalities]
+* type-function equalities (wl_funeqs)
+* all the rest (wl_rest)
+
+Note [Prioritise equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's very important to process equalities /first/:
+
+* (Efficiency)  The general reason to do so is that if we process a
+  class constraint first, we may end up putting it into the inert set
+  and then kicking it out later.  That's extra work compared to just
+  doing the equality first.
+
+* (Avoiding fundep iteration) As Trac #14723 showed, it's possible to
+  get non-termination if we
+      - Emit the Derived fundep equalities for a class constraint,
+        generating some fresh unification variables.
+      - That leads to some unification
+      - Which kicks out the class constraint
+      - Which isn't solved (because there are still some more Derived
+        equalities in the work-list), but generates yet more fundeps
+  Solution: prioritise derived equalities over class constraints
+
+* (Class equalities) We need to prioritise equalities even if they
+  are hidden inside a class constraint;
+  see Note [Prioritise class equalities]
+
+* (Kick-out) We want to apply this priority scheme to kicked-out
+  constraints too (see the call to extendWorkListCt in kick_out_rewritable
+  E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become
+  homo-kinded when kicked out, and hence we want to priotitise it.
+
+* (Derived equalities) Originally we tried to postpone processing
+  Derived equalities, in the hope that we might never need to deal
+  with them at all; but in fact we must process Derived equalities
+  eagerly, partly for the (Efficiency) reason, and more importantly
+  for (Avoiding fundep iteration).
+
+Note [Prioritise class equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We prioritise equalities in the solver (see selectWorkItem). But class
+constraints like (a ~ b) and (a ~~ b) are actually equalities too;
+see Note [The equality types story] in TysPrim.
+
+Failing to prioritise these is inefficient (more kick-outs etc).
+But, worse, it can prevent us spotting a "recursive knot" among
+Wanted constraints.  See comment:10 of Trac #12734 for a worked-out
+example.
+
+So we arrange to put these particular class constraints in the wl_eqs.
+
+  NB: since we do not currently apply the substitution to the
+  inert_solved_dicts, the knot-tying still seems a bit fragile.
+  But this makes it better.
+-}
+
+-- See Note [WorkList priorities]
+data WorkList
+  = WL { wl_eqs     :: [Ct]  -- CTyEqCan, CDictCan, CIrredCan
+                             -- Given, Wanted, and Derived
+                       -- Contains both equality constraints and their
+                       -- class-level variants (a~b) and (a~~b);
+                       -- See Note [Prioritise equalities]
+                       -- See Note [Prioritise class equalities]
+
+       , wl_funeqs  :: [Ct]
+
+       , wl_rest    :: [Ct]
+
+       , wl_implics :: Bag Implication  -- See Note [Residual implications]
+    }
+
+appendWorkList :: WorkList -> WorkList -> WorkList
+appendWorkList
+    (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1
+        , wl_implics = implics1 })
+    (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2
+        , wl_implics = implics2 })
+   = WL { wl_eqs     = eqs1     ++ eqs2
+        , wl_funeqs  = funeqs1  ++ funeqs2
+        , wl_rest    = rest1    ++ rest2
+        , wl_implics = implics1 `unionBags`   implics2 }
+
+workListSize :: WorkList -> Int
+workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest })
+  = length eqs + length funeqs + length rest
+
+workListWantedCount :: WorkList -> Int
+-- Count the things we need to solve
+-- excluding the insolubles (c.f. inert_count)
+workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest })
+  = count isWantedCt eqs + count is_wanted rest
+  where
+    is_wanted ct
+     | CIrredCan { cc_ev = ev, cc_insol = insol } <- ct
+     = not insol && isWanted ev
+     | otherwise
+     = isWantedCt ct
+
+extendWorkListEq :: Ct -> WorkList -> WorkList
+extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }
+
+extendWorkListFunEq :: Ct -> WorkList -> WorkList
+extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl }
+
+extendWorkListNonEq :: Ct -> WorkList -> WorkList
+-- Extension by non equality
+extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }
+
+extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList
+extendWorkListDeriveds evs wl
+  = extendWorkListCts (map mkNonCanonical evs) wl
+
+extendWorkListImplic :: Bag Implication -> WorkList -> WorkList
+extendWorkListImplic implics wl = wl { wl_implics = implics `unionBags` wl_implics wl }
+
+extendWorkListCt :: Ct -> WorkList -> WorkList
+-- Agnostic
+extendWorkListCt ct wl
+ = case classifyPredType (ctPred ct) of
+     EqPred NomEq ty1 _
+       | Just tc <- tcTyConAppTyCon_maybe ty1
+       , isTypeFamilyTyCon tc
+       -> extendWorkListFunEq ct wl
+
+     EqPred {}
+       -> extendWorkListEq ct wl
+
+     ClassPred cls _  -- See Note [Prioritise class equalities]
+       |  cls `hasKey` heqTyConKey
+       || cls `hasKey` eqTyConKey
+       -> extendWorkListEq ct wl
+
+     _ -> extendWorkListNonEq ct wl
+
+extendWorkListCts :: [Ct] -> WorkList -> WorkList
+-- Agnostic
+extendWorkListCts cts wl = foldr extendWorkListCt wl cts
+
+isEmptyWorkList :: WorkList -> Bool
+isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs
+                    , wl_rest = rest, wl_implics = implics })
+  = null eqs && null rest && null funeqs && isEmptyBag implics
+
+emptyWorkList :: WorkList
+emptyWorkList = WL { wl_eqs  = [], wl_rest = []
+                   , wl_funeqs = [], wl_implics = emptyBag }
+
+selectWorkItem :: WorkList -> Maybe (Ct, WorkList)
+-- See Note [Prioritise equalities]
+selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs
+                      , wl_rest = rest })
+  | ct:cts <- eqs  = Just (ct, wl { wl_eqs    = cts })
+  | ct:fes <- feqs = Just (ct, wl { wl_funeqs = fes })
+  | ct:cts <- rest = Just (ct, wl { wl_rest   = cts })
+  | otherwise      = Nothing
+
+getWorkList :: TcS WorkList
+getWorkList = do { wl_var <- getTcSWorkListRef
+                 ; wrapTcS (TcM.readTcRef wl_var) }
+
+selectNextWorkItem :: TcS (Maybe Ct)
+-- Pick which work item to do next
+-- See Note [Prioritise equalities]
+selectNextWorkItem
+  = do { wl_var <- getTcSWorkListRef
+       ; wl <- readTcRef wl_var
+       ; case selectWorkItem wl of {
+           Nothing -> return Nothing ;
+           Just (ct, new_wl) ->
+    do { -- checkReductionDepth (ctLoc ct) (ctPred ct)
+         -- This is done by TcInteract.chooseInstance
+       ; writeTcRef wl_var new_wl
+       ; return (Just ct) } } }
+
+-- Pretty printing
+instance Outputable WorkList where
+  ppr (WL { wl_eqs = eqs, wl_funeqs = feqs
+          , wl_rest = rest, wl_implics = implics })
+   = text "WL" <+> (braces $
+     vcat [ ppUnless (null eqs) $
+            text "Eqs =" <+> vcat (map ppr eqs)
+          , ppUnless (null feqs) $
+            text "Funeqs =" <+> vcat (map ppr feqs)
+          , ppUnless (null rest) $
+            text "Non-eqs =" <+> vcat (map ppr rest)
+          , ppUnless (isEmptyBag implics) $
+            ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics)))
+                       (text "(Implics omitted)")
+          ])
+
+
+{- *********************************************************************
+*                                                                      *
+                InertSet: the inert set
+*                                                                      *
+*                                                                      *
+********************************************************************* -}
+
+data InertSet
+  = IS { inert_cans :: InertCans
+              -- Canonical Given, Wanted, Derived
+              -- Sometimes called "the inert set"
+
+       , inert_fsks :: [(TcTyVar, TcType)]
+              -- A list of (fsk, ty) pairs; we add one element when we flatten
+              -- a function application in a Given constraint, creating
+              -- a new fsk in newFlattenSkolem.  When leaving a nested scope,
+              -- unflattenGivens unifies fsk := ty
+              --
+              -- We could also get this info from inert_funeqs, filtered by
+              -- level, but it seems simpler and more direct to capture the
+              -- fsk as we generate them.
+
+       , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour)
+              -- See Note [Type family equations]
+              -- If    F tys :-> (co, rhs, flav),
+              -- then  co :: F tys ~ rhs
+              --       flav is [G] or [WD]
+              --
+              -- Just a hash-cons cache for use when flattening only
+              -- These include entirely un-processed goals, so don't use
+              -- them to solve a top-level goal, else you may end up solving
+              -- (w:F ty ~ a) by setting w:=w!  We just use the flat-cache
+              -- when allocating a new flatten-skolem.
+              -- Not necessarily inert wrt top-level equations (or inert_cans)
+
+              -- NB: An ExactFunEqMap -- this doesn't match via loose types!
+
+       , inert_solved_dicts   :: DictMap CtEvidence
+              -- All Wanteds, of form ev :: C t1 .. tn
+              -- See Note [Solved dictionaries]
+              -- and Note [Do not add superclasses of solved dictionaries]
+       }
+
+instance Outputable InertSet where
+  ppr (IS { inert_cans = ics
+          , inert_fsks = ifsks
+          , inert_solved_dicts = solved_dicts })
+      = vcat [ ppr ics
+             , text "Inert fsks =" <+> ppr ifsks
+             , ppUnless (null dicts) $
+               text "Solved dicts =" <+> vcat (map ppr dicts) ]
+         where
+           dicts = bagToList (dictsToBag solved_dicts)
+
+emptyInertCans :: InertCans
+emptyInertCans
+  = IC { inert_count    = 0
+       , inert_eqs      = emptyDVarEnv
+       , inert_dicts    = emptyDicts
+       , inert_safehask = emptyDicts
+       , inert_funeqs   = emptyFunEqs
+       , inert_insts    = []
+       , inert_irreds   = emptyCts }
+
+emptyInert :: InertSet
+emptyInert
+  = IS { inert_cans         = emptyInertCans
+       , inert_fsks         = []
+       , inert_flat_cache   = emptyExactFunEqs
+       , inert_solved_dicts = emptyDictMap }
+
+
+{- Note [Solved dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we apply a top-level instance declaration, we add the "solved"
+dictionary to the inert_solved_dicts.  In general, we use it to avoid
+creating a new EvVar when we have a new goal that we have solved in
+the past.
+
+But in particular, we can use it to create *recursive* dictionaries.
+The simplest, degnerate case is
+    instance C [a] => C [a] where ...
+If we have
+    [W] d1 :: C [x]
+then we can apply the instance to get
+    d1 = $dfCList d
+    [W] d2 :: C [x]
+Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1.
+    d1 = $dfCList d
+    d2 = d1
+
+See Note [Example of recursive dictionaries]
+Other notes about solved dictionaries
+
+* See also Note [Do not add superclasses of solved dictionaries]
+
+* The inert_solved_dicts field is not rewritten by equalities,
+  so it may get out of date.
+
+* THe inert_solved_dicts are all Wanteds, never givens
+
+* We only cache dictionaries from top-level instances, not from
+  local quantified constraints.  Reason: if we cached the latter
+  we'd need to purge the cache when bringing new quantified
+  constraints into scope, because quantified constraints "shadow"
+  top-level instances.
+
+Note [Do not add superclasses of solved dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Every member of inert_solved_dicts is the result of applying a dictionary
+function, NOT of applying superclass selection to anything.
+Consider
+
+        class Ord a => C a where
+        instance Ord [a] => C [a] where ...
+
+Suppose we are trying to solve
+  [G] d1 : Ord a
+  [W] d2 : C [a]
+
+Then we'll use the instance decl to give
+
+  [G] d1 : Ord a     Solved: d2 : C [a] = $dfCList d3
+  [W] d3 : Ord [a]
+
+We must not add d4 : Ord [a] to the 'solved' set (by taking the
+superclass of d2), otherwise we'll use it to solve d3, without ever
+using d1, which would be a catastrophe.
+
+Solution: when extending the solved dictionaries, do not add superclasses.
+That's why each element of the inert_solved_dicts is the result of applying
+a dictionary function.
+
+Note [Example of recursive dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--- Example 1
+
+    data D r = ZeroD | SuccD (r (D r));
+
+    instance (Eq (r (D r))) => Eq (D r) where
+        ZeroD     == ZeroD     = True
+        (SuccD a) == (SuccD b) = a == b
+        _         == _         = False;
+
+    equalDC :: D [] -> D [] -> Bool;
+    equalDC = (==);
+
+We need to prove (Eq (D [])). Here's how we go:
+
+   [W] d1 : Eq (D [])
+By instance decl of Eq (D r):
+   [W] d2 : Eq [D []]      where   d1 = dfEqD d2
+By instance decl of Eq [a]:
+   [W] d3 : Eq (D [])      where   d2 = dfEqList d3
+                                   d1 = dfEqD d2
+Now this wanted can interact with our "solved" d1 to get:
+    d3 = d1
+
+-- Example 2:
+This code arises in the context of "Scrap Your Boilerplate with Class"
+
+    class Sat a
+    class Data ctx a
+    instance  Sat (ctx Char)             => Data ctx Char       -- dfunData1
+    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]        -- dfunData2
+
+    class Data Maybe a => Foo a
+
+    instance Foo t => Sat (Maybe t)                             -- dfunSat
+
+    instance Data Maybe a => Foo a                              -- dfunFoo1
+    instance Foo a        => Foo [a]                            -- dfunFoo2
+    instance                 Foo [Char]                         -- dfunFoo3
+
+Consider generating the superclasses of the instance declaration
+         instance Foo a => Foo [a]
+
+So our problem is this
+    [G] d0 : Foo t
+    [W] d1 : Data Maybe [t]   -- Desired superclass
+
+We may add the given in the inert set, along with its superclasses
+  Inert:
+    [G] d0 : Foo t
+    [G] d01 : Data Maybe t   -- Superclass of d0
+  WorkList
+    [W] d1 : Data Maybe [t]
+
+Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3
+  Inert:
+    [G] d0 : Foo t
+    [G] d01 : Data Maybe t   -- Superclass of d0
+  Solved:
+        d1 : Data Maybe [t]
+  WorkList:
+    [W] d2 : Sat (Maybe [t])
+    [W] d3 : Data Maybe t
+
+Now, we may simplify d2 using dfunSat; d2 := dfunSat d4
+  Inert:
+    [G] d0 : Foo t
+    [G] d01 : Data Maybe t   -- Superclass of d0
+  Solved:
+        d1 : Data Maybe [t]
+        d2 : Sat (Maybe [t])
+  WorkList:
+    [W] d3 : Data Maybe t
+    [W] d4 : Foo [t]
+
+Now, we can just solve d3 from d01; d3 := d01
+  Inert
+    [G] d0 : Foo t
+    [G] d01 : Data Maybe t   -- Superclass of d0
+  Solved:
+        d1 : Data Maybe [t]
+        d2 : Sat (Maybe [t])
+  WorkList
+    [W] d4 : Foo [t]
+
+Now, solve d4 using dfunFoo2;  d4 := dfunFoo2 d5
+  Inert
+    [G] d0  : Foo t
+    [G] d01 : Data Maybe t   -- Superclass of d0
+  Solved:
+        d1 : Data Maybe [t]
+        d2 : Sat (Maybe [t])
+        d4 : Foo [t]
+  WorkList:
+    [W] d5 : Foo t
+
+Now, d5 can be solved! d5 := d0
+
+Result
+   d1 := dfunData2 d2 d3
+   d2 := dfunSat d4
+   d3 := d01
+   d4 := dfunFoo2 d5
+   d5 := d0
+-}
+
+{- *********************************************************************
+*                                                                      *
+                InertCans: the canonical inerts
+*                                                                      *
+*                                                                      *
+********************************************************************* -}
+
+data InertCans   -- See Note [Detailed InertCans Invariants] for more
+  = IC { inert_eqs :: InertEqs
+              -- See Note [inert_eqs: the inert equalities]
+              -- All CTyEqCans; index is the LHS tyvar
+              -- Domain = skolems and untouchables; a touchable would be unified
+
+       , inert_funeqs :: FunEqMap Ct
+              -- All CFunEqCans; index is the whole family head type.
+              -- All Nominal (that's an invarint of all CFunEqCans)
+              -- LHS is fully rewritten (modulo eqCanRewrite constraints)
+              --     wrt inert_eqs
+              -- Can include all flavours, [G], [W], [WD], [D]
+              -- See Note [Type family equations]
+
+       , inert_dicts :: DictMap Ct
+              -- Dictionaries only
+              -- All fully rewritten (modulo flavour constraints)
+              --     wrt inert_eqs
+
+       , inert_insts :: [QCInst]
+
+       , inert_safehask :: DictMap Ct
+              -- Failed dictionary resolution due to Safe Haskell overlapping
+              -- instances restriction. We keep this separate from inert_dicts
+              -- as it doesn't cause compilation failure, just safe inference
+              -- failure.
+              --
+              -- ^ See Note [Safe Haskell Overlapping Instances Implementation]
+              -- in TcSimplify
+
+       , inert_irreds :: Cts
+              -- Irreducible predicates that cannot be made canonical,
+              --     and which don't interact with others (e.g.  (c a))
+              -- and insoluble predicates (e.g.  Int ~ Bool, or a ~ [a])
+
+       , inert_count :: Int
+              -- Number of Wanted goals in
+              --     inert_eqs, inert_dicts, inert_safehask, inert_irreds
+              -- Does not include insolubles
+              -- When non-zero, keep trying to solve
+       }
+
+type InertEqs    = DTyVarEnv EqualCtList
+type EqualCtList = [Ct]  -- See Note [EqualCtList invariants]
+
+{- Note [Detailed InertCans Invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The InertCans represents a collection of constraints with the following properties:
+
+  * All canonical
+
+  * No two dictionaries with the same head
+  * No two CIrreds with the same type
+
+  * Family equations inert wrt top-level family axioms
+
+  * Dictionaries have no matching top-level instance
+
+  * Given family or dictionary constraints don't mention touchable
+    unification variables
+
+  * Non-CTyEqCan constraints are fully rewritten with respect
+    to the CTyEqCan equalities (modulo canRewrite of course;
+    eg a wanted cannot rewrite a given)
+
+  * CTyEqCan equalities: see Note [Applying the inert substitution]
+                         in TcFlatten
+
+Note [EqualCtList invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    * All are equalities
+    * All these equalities have the same LHS
+    * The list is never empty
+    * No element of the list can rewrite any other
+    * Derived before Wanted
+
+From the fourth invariant it follows that the list is
+   - A single [G], or
+   - Zero or one [D] or [WD], followd by any number of [W]
+
+The Wanteds can't rewrite anything which is why we put them last
+
+Note [Type family equations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Type-family equations, CFunEqCans, of form (ev : F tys ~ ty),
+live in three places
+
+  * The work-list, of course
+
+  * The inert_funeqs are un-solved but fully processed, and in
+    the InertCans. They can be [G], [W], [WD], or [D].
+
+  * The inert_flat_cache.  This is used when flattening, to get maximal
+    sharing. Everthing in the inert_flat_cache is [G] or [WD]
+
+    It contains lots of things that are still in the work-list.
+    E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the
+        work list.  Then we flatten w1, dumping (w3: G a ~ f1) in the work
+        list.  Now if we flatten w2 before we get to w3, we still want to
+        share that (G a).
+    Because it contains work-list things, DO NOT use the flat cache to solve
+    a top-level goal.  Eg in the above example we don't want to solve w3
+    using w3 itself!
+
+The CFunEqCan Ownership Invariant:
+
+  * Each [G/W/WD] CFunEqCan has a distinct fsk or fmv
+    It "owns" that fsk/fmv, in the sense that:
+      - reducing a [W/WD] CFunEqCan fills in the fmv
+      - unflattening a [W/WD] CFunEqCan fills in the fmv
+      (in both cases unless an occurs-check would result)
+
+  * In contrast a [D] CFunEqCan does not "own" its fmv:
+      - reducing a [D] CFunEqCan does not fill in the fmv;
+        it just generates an equality
+      - unflattening ignores [D] CFunEqCans altogether
+
+
+Note [inert_eqs: the inert equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Definition [Can-rewrite relation]
+A "can-rewrite" relation between flavours, written f1 >= f2, is a
+binary relation with the following properties
+
+  (R1) >= is transitive
+  (R2) If f1 >= f, and f2 >= f,
+       then either f1 >= f2 or f2 >= f1
+
+Lemma.  If f1 >= f then f1 >= f1
+Proof.  By property (R2), with f1=f2
+
+Definition [Generalised substitution]
+A "generalised substitution" S is a set of triples (a -f-> t), where
+  a is a type variable
+  t is a type
+  f is a flavour
+such that
+  (WF1) if (a -f1-> t1) in S
+           (a -f2-> t2) in S
+        then neither (f1 >= f2) nor (f2 >= f1) hold
+  (WF2) if (a -f-> t) is in S, then t /= a
+
+Definition [Applying a generalised substitution]
+If S is a generalised substitution
+   S(f,a) = t,  if (a -fs-> t) in S, and fs >= f
+          = a,  otherwise
+Application extends naturally to types S(f,t), modulo roles.
+See Note [Flavours with roles].
+
+Theorem: S(f,a) is well defined as a function.
+Proof: Suppose (a -f1-> t1) and (a -f2-> t2) are both in S,
+               and  f1 >= f and f2 >= f
+       Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)
+
+Notation: repeated application.
+  S^0(f,t)     = t
+  S^(n+1)(f,t) = S(f, S^n(t))
+
+Definition: inert generalised substitution
+A generalised substitution S is "inert" iff
+
+  (IG1) there is an n such that
+        for every f,t, S^n(f,t) = S^(n+1)(f,t)
+
+By (IG1) we define S*(f,t) to be the result of exahaustively
+applying S(f,_) to t.
+
+----------------------------------------------------------------
+Our main invariant:
+   the inert CTyEqCans should be an inert generalised substitution
+----------------------------------------------------------------
+
+Note that inertness is not the same as idempotence.  To apply S to a
+type, you may have to apply it recursive.  But inertness does
+guarantee that this recursive use will terminate.
+
+Note [Extending the inert equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Main Theorem [Stability under extension]
+   Suppose we have a "work item"
+       a -fw-> t
+   and an inert generalised substitution S,
+   THEN the extended substitution T = S+(a -fw-> t)
+        is an inert generalised substitution
+   PROVIDED
+      (T1) S(fw,a) = a     -- LHS of work-item is a fixpoint of S(fw,_)
+      (T2) S(fw,t) = t     -- RHS of work-item is a fixpoint of S(fw,_)
+      (T3) a not in t      -- No occurs check in the work item
+
+      AND, for every (b -fs-> s) in S:
+           (K0) not (fw >= fs)
+                Reason: suppose we kick out (a -fs-> s),
+                        and add (a -fw-> t) to the inert set.
+                        The latter can't rewrite the former,
+                        so the kick-out achieved nothing
+
+           OR { (K1) not (a = b)
+                     Reason: if fw >= fs, WF1 says we can't have both
+                             a -fw-> t  and  a -fs-> s
+
+                AND (K2): guarantees inertness of the new substitution
+                    {  (K2a) not (fs >= fs)
+                    OR (K2b) fs >= fw
+                    OR (K2d) a not in s }
+
+                AND (K3) See Note [K3: completeness of solving]
+                    { (K3a) If the role of fs is nominal: s /= a
+                      (K3b) If the role of fs is representational:
+                            s is not of form (a t1 .. tn) } }
+
+
+Conditions (T1-T3) are established by the canonicaliser
+Conditions (K1-K3) are established by TcSMonad.kickOutRewritable
+
+The idea is that
+* (T1-2) are guaranteed by exhaustively rewriting the work-item
+  with S(fw,_).
+
+* T3 is guaranteed by a simple occurs-check on the work item.
+  This is done during canonicalisation, in canEqTyVar;
+  (invariant: a CTyEqCan never has an occurs check).
+
+* (K1-3) are the "kick-out" criteria.  (As stated, they are really the
+  "keep" criteria.) If the current inert S contains a triple that does
+  not satisfy (K1-3), then we remove it from S by "kicking it out",
+  and re-processing it.
+
+* Note that kicking out is a Bad Thing, because it means we have to
+  re-process a constraint.  The less we kick out, the better.
+  TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed
+  this but haven't done the empirical study to check.
+
+* Assume we have  G>=G, G>=W and that's all.  Then, when performing
+  a unification we add a new given  a -G-> ty.  But doing so does NOT require
+  us to kick out an inert wanted that mentions a, because of (K2a).  This
+  is a common case, hence good not to kick out.
+
+* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing
+  Proof: using Definition [Can-rewrite relation], fw can't rewrite anything
+         and so K0 holds.  Intuitively, since fw can't rewrite anything,
+         adding it cannot cause any loops
+  This is a common case, because Wanteds cannot rewrite Wanteds.
+  It's used to avoid even looking for constraint to kick out.
+
+* Lemma (L1): The conditions of the Main Theorem imply that there is no
+              (a -fs-> t) in S, s.t.  (fs >= fw).
+  Proof. Suppose the contrary (fs >= fw).  Then because of (T1),
+  S(fw,a)=a.  But since fs>=fw, S(fw,a) = s, hence s=a.  But now we
+  have (a -fs-> a) in S, which contradicts (WF2).
+
+* The extended substitution satisfies (WF1) and (WF2)
+  - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1).
+  - (T3) guarantees (WF2).
+
+* (K2) is about inertness.  Intuitively, any infinite chain T^0(f,t),
+  T^1(f,t), T^2(f,T).... must pass through the new work item infinitely
+  often, since the substitution without the work item is inert; and must
+  pass through at least one of the triples in S infinitely often.
+
+  - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f),
+    and hence this triple never plays a role in application S(f,a).
+    It is always safe to extend S with such a triple.
+
+    (NB: we could strengten K1) in this way too, but see K3.
+
+  - (K2b): If this holds then, by (T2), b is not in t.  So applying the
+    work item does not generate any new opportunities for applying S
+
+  - (K2c): If this holds, we can't pass through this triple infinitely
+    often, because if we did then fs>=f, fw>=f, hence by (R2)
+      * either fw>=fs, contradicting K2c
+      * or fs>=fw; so by the argument in K2b we can't have a loop
+
+  - (K2d): if a not in s, we hae no further opportunity to apply the
+    work item, similar to (K2b)
+
+  NB: Dimitrios has a PDF that does this in more detail
+
+Key lemma to make it watertight.
+  Under the conditions of the Main Theorem,
+  forall f st fw >= f, a is not in S^k(f,t), for any k
+
+Also, consider roles more carefully. See Note [Flavours with roles]
+
+Note [K3: completeness of solving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(K3) is not necessary for the extended substitution
+to be inert.  In fact K1 could be made stronger by saying
+   ... then (not (fw >= fs) or not (fs >= fs))
+But it's not enough for S to be inert; we also want completeness.
+That is, we want to be able to solve all soluble wanted equalities.
+Suppose we have
+
+   work-item   b -G-> a
+   inert-item  a -W-> b
+
+Assuming (G >= W) but not (W >= W), this fulfills all the conditions,
+so we could extend the inerts, thus:
+
+   inert-items   b -G-> a
+                 a -W-> b
+
+But if we kicked-out the inert item, we'd get
+
+   work-item     a -W-> b
+   inert-item    b -G-> a
+
+Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl.
+So we add one more clause to the kick-out criteria
+
+Another way to understand (K3) is that we treat an inert item
+        a -f-> b
+in the same way as
+        b -f-> a
+So if we kick out one, we should kick out the other.  The orientation
+is somewhat accidental.
+
+When considering roles, we also need the second clause (K3b). Consider
+
+  work-item    c -G/N-> a
+  inert-item   a -W/R-> b c
+
+The work-item doesn't get rewritten by the inert, because (>=) doesn't hold.
+But we don't kick out the inert item because not (W/R >= W/R).  So we just
+add the work item. But then, consider if we hit the following:
+
+  work-item    b -G/N-> Id
+  inert-items  a -W/R-> b c
+               c -G/N-> a
+where
+  newtype Id x = Id x
+
+For similar reasons, if we only had (K3a), we wouldn't kick the
+representational inert out. And then, we'd miss solving the inert, which
+now reduced to reflexivity.
+
+The solution here is to kick out representational inerts whenever the
+tyvar of a work item is "exposed", where exposed means being at the
+head of the top-level application chain (a t1 .. tn).  See
+TcType.isTyVarHead. This is encoded in (K3b).
+
+Beware: if we make this test succeed too often, we kick out too much,
+and the solver might loop.  Consider (Trac #14363)
+  work item:   [G] a ~R f b
+  inert item:  [G] b ~R f a
+In GHC 8.2 the completeness tests more aggressive, and kicked out
+the inert item; but no rewriting happened and there was an infinite
+loop.  All we need is to have the tyvar at the head.
+
+Note [Flavours with roles]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+The system described in Note [inert_eqs: the inert equalities]
+discusses an abstract
+set of flavours. In GHC, flavours have two components: the flavour proper,
+taken from {Wanted, Derived, Given} and the equality relation (often called
+role), taken from {NomEq, ReprEq}.
+When substituting w.r.t. the inert set,
+as described in Note [inert_eqs: the inert equalities],
+we must be careful to respect all components of a flavour.
+For example, if we have
+
+  inert set: a -G/R-> Int
+             b -G/R-> Bool
+
+  type role T nominal representational
+
+and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT
+T Int Bool. The reason is that T's first parameter has a nominal role, and
+thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of
+substitution means that the proof in Note [The inert equalities] may need
+to be revisited, but we don't think that the end conclusion is wrong.
+-}
+
+instance Outputable InertCans where
+  ppr (IC { inert_eqs = eqs
+          , inert_funeqs = funeqs, inert_dicts = dicts
+          , inert_safehask = safehask, inert_irreds = irreds
+          , inert_insts = insts
+          , inert_count = count })
+    = braces $ vcat
+      [ ppUnless (isEmptyDVarEnv eqs) $
+        text "Equalities:"
+          <+> pprCts (foldDVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs)
+      , ppUnless (isEmptyTcAppMap funeqs) $
+        text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs)
+      , ppUnless (isEmptyTcAppMap dicts) $
+        text "Dictionaries =" <+> pprCts (dictsToBag dicts)
+      , ppUnless (isEmptyTcAppMap safehask) $
+        text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)
+      , ppUnless (isEmptyCts irreds) $
+        text "Irreds =" <+> pprCts irreds
+      , ppUnless (null insts) $
+        text "Given instances =" <+> vcat (map ppr insts)
+      , text "Unsolved goals =" <+> int count
+      ]
+
+{- *********************************************************************
+*                                                                      *
+             Shadow constraints and improvement
+*                                                                      *
+************************************************************************
+
+Note [The improvement story and derived shadows]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not
+rewrite Wanteds] in TcRnTypes), we may miss some opportunities for
+solving.  Here's a classic example (indexed-types/should_fail/T4093a)
+
+    Ambiguity check for f: (Foo e ~ Maybe e) => Foo e
+
+    We get [G] Foo e ~ Maybe e
+           [W] Foo e ~ Foo ee      -- ee is a unification variable
+           [W] Foo ee ~ Maybe ee
+
+    Flatten: [G] Foo e ~ fsk
+             [G] fsk ~ Maybe e   -- (A)
+
+             [W] Foo ee ~ fmv
+             [W] fmv ~ fsk       -- (B) From Foo e ~ Foo ee
+             [W] fmv ~ Maybe ee
+
+    --> rewrite (B) with (A)
+             [W] Foo ee ~ fmv
+             [W] fmv ~ Maybe e
+             [W] fmv ~ Maybe ee
+
+    But now we appear to be stuck, since we don't rewrite Wanteds with
+    Wanteds.  This is silly because we can see that ee := e is the
+    only solution.
+
+The basic plan is
+  * generate Derived constraints that shadow Wanted constraints
+  * allow Derived to rewrite Derived
+  * in order to cause some unifications to take place
+  * that in turn solve the original Wanteds
+
+The ONLY reason for all these Derived equalities is to tell us how to
+unify a variable: that is, what Mark Jones calls "improvement".
+
+The same idea is sometimes also called "saturation"; find all the
+equalities that must hold in any solution.
+
+Or, equivalently, you can think of the derived shadows as implementing
+the "model": a non-idempotent but no-occurs-check substitution,
+reflecting *all* *Nominal* equalities (a ~N ty) that are not
+immediately soluble by unification.
+
+More specifically, here's how it works (Oct 16):
+
+* Wanted constraints are born as [WD]; this behaves like a
+  [W] and a [D] paired together.
+
+* When we are about to add a [WD] to the inert set, if it can
+  be rewritten by a [D] a ~ ty, then we split it into [W] and [D],
+  putting the latter into the work list (see maybeEmitShadow).
+
+In the example above, we get to the point where we are stuck:
+    [WD] Foo ee ~ fmv
+    [WD] fmv ~ Maybe e
+    [WD] fmv ~ Maybe ee
+
+But now when [WD] fmv ~ Maybe ee is about to be added, we'll
+split it into [W] and [D], since the inert [WD] fmv ~ Maybe e
+can rewrite it.  Then:
+    work item: [D] fmv ~ Maybe ee
+    inert:     [W] fmv ~ Maybe ee
+               [WD] fmv ~ Maybe e   -- (C)
+               [WD] Foo ee ~ fmv
+
+See Note [Splitting WD constraints].  Now the work item is rewritten
+by (C) and we soon get ee := e.
+
+Additional notes:
+
+  * The derived shadow equalities live in inert_eqs, along with
+    the Givens and Wanteds; see Note [EqualCtList invariants].
+
+  * We make Derived shadows only for Wanteds, not Givens.  So we
+    have only [G], not [GD] and [G] plus splitting.  See
+    Note [Add derived shadows only for Wanteds]
+
+  * We also get Derived equalities from functional dependencies
+    and type-function injectivity; see calls to unifyDerived.
+
+  * This splitting business applies to CFunEqCans too; and then
+    we do apply type-function reductions to the [D] CFunEqCan.
+    See Note [Reduction for Derived CFunEqCans]
+
+  * It's worth having [WD] rather than just [W] and [D] because
+    * efficiency: silly to process the same thing twice
+    * inert_funeqs, inert_dicts is a finite map keyed by
+      the type; it's inconvenient for it to map to TWO constraints
+
+Note [Splitting WD constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We are about to add a [WD] constraint to the inert set; and we
+know that the inert set has fully rewritten it.  Should we split
+it into [W] and [D], and put the [D] in the work list for further
+work?
+
+* CDictCan (C tys) or CFunEqCan (F tys ~ fsk):
+  Yes if the inert set could rewrite tys to make the class constraint,
+  or type family, fire.  That is, yes if the inert_eqs intersects
+  with the free vars of tys.  For this test we use
+  (anyRewritableTyVar True) which ignores casts and coercions in tys,
+  because rewriting the casts or coercions won't make the thing fire
+  more often.
+
+* CTyEqCan (a ~ ty): Yes if the inert set could rewrite 'a' or 'ty'.
+  We need to check both 'a' and 'ty' against the inert set:
+    - Inert set contains  [D] a ~ ty2
+      Then we want to put [D] a ~ ty in the worklist, so we'll
+      get [D] ty ~ ty2 with consequent good things
+
+    - Inert set contains [D] b ~ a, where b is in ty.
+      We can't just add [WD] a ~ ty[b] to the inert set, because
+      that breaks the inert-set invariants.  If we tried to
+      canonicalise another [D] constraint mentioning 'a', we'd
+      get an infinite loop
+
+  Moreover we must use (anyRewritableTyVar False) for the RHS,
+  because even tyvars in the casts and coercions could give
+  an infinite loop if we don't expose it
+
+* CIrredCan: Yes if the inert set can rewrite the constraint.
+  We used to think splitting irreds was unnecessary, but
+  see Note [Splitting Irred WD constraints]
+
+* Others: nothing is gained by splitting.
+
+Note [Splitting Irred WD constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Splitting Irred constraints can make a difference. Here is the
+scenario:
+
+  a[sk] :: F v     -- F is a type family
+  beta :: alpha
+
+  work item: [WD] a ~ beta
+
+This is heterogeneous, so we try flattening the kinds.
+
+  co :: F v ~ fmv
+  [WD] (a |> co) ~ beta
+
+This is still hetero, so we emit a kind equality and make the work item an
+inert Irred.
+
+  work item: [D] fmv ~ alpha
+  inert: [WD] (a |> co) ~ beta (CIrredCan)
+
+Can't make progress on the work item. Add to inert set. This kicks out the
+old inert, because a [D] can rewrite a [WD].
+
+  work item: [WD] (a |> co) ~ beta
+  inert: [D] fmv ~ alpha (CTyEqCan)
+
+Can't make progress on this work item either (although GHC tries by
+decomposing the cast and reflattening... but that doesn't make a difference),
+which is still hetero. Emit a new kind equality and add to inert set. But,
+critically, we split the Irred.
+
+  work list:
+   [D] fmv ~ alpha (CTyEqCan)
+   [D] (a |> co) ~ beta (CIrred) -- this one was split off
+  inert:
+   [W] (a |> co) ~ beta
+   [D] fmv ~ alpha
+
+We quickly solve the first work item, as it's the same as an inert.
+
+  work item: [D] (a |> co) ~ beta
+  inert:
+   [W] (a |> co) ~ beta
+   [D] fmv ~ alpha
+
+We decompose the cast, yielding
+
+  [D] a ~ beta
+
+We then flatten the kinds. The lhs kind is F v, which flattens to fmv which
+then rewrites to alpha.
+
+  co' :: F v ~ alpha
+  [D] (a |> co') ~ beta
+
+Now this equality is homo-kinded. So we swizzle it around to
+
+  [D] beta ~ (a |> co')
+
+and set beta := a |> co', and go home happy.
+
+If we don't split the Irreds, we loop. This is all dangerously subtle.
+
+This is triggered by test case typecheck/should_compile/SplitWD.
+
+Note [Examples of how Derived shadows helps completeness]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Trac #10009, a very nasty example:
+
+    f :: (UnF (F b) ~ b) => F b -> ()
+
+    g :: forall a. (UnF (F a) ~ a) => a -> ()
+    g _ = f (undefined :: F a)
+
+  For g we get [G] UnF (F a) ~ a
+               [WD] UnF (F beta) ~ beta
+               [WD] F a ~ F beta
+  Flatten:
+      [G] g1: F a ~ fsk1         fsk1 := F a
+      [G] g2: UnF fsk1 ~ fsk2    fsk2 := UnF fsk1
+      [G] g3: fsk2 ~ a
+
+      [WD] w1: F beta ~ fmv1
+      [WD] w2: UnF fmv1 ~ fmv2
+      [WD] w3: fmv2 ~ beta
+      [WD] w4: fmv1 ~ fsk1   -- From F a ~ F beta using flat-cache
+                             -- and re-orient to put meta-var on left
+
+Rewrite w2 with w4: [D] d1: UnF fsk1 ~ fmv2
+React that with g2: [D] d2: fmv2 ~ fsk2
+React that with w3: [D] beta ~ fsk2
+            and g3: [D] beta ~ a -- Hooray beta := a
+And that is enough to solve everything
+
+Note [Add derived shadows only for Wanteds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We only add shadows for Wanted constraints. That is, we have
+[WD] but not [GD]; and maybeEmitShaodw looks only at [WD]
+constraints.
+
+It does just possibly make sense ot add a derived shadow for a
+Given. If we created a Derived shadow of a Given, it could be
+rewritten by other Deriveds, and that could, conceivably, lead to a
+useful unification.
+
+But (a) I have been unable to come up with an example of this
+        happening
+    (b) see Trac #12660 for how adding the derived shadows
+        of a Given led to an infinite loop.
+    (c) It's unlikely that rewriting derived Givens will lead
+        to a unification because Givens don't mention touchable
+        unification variables
+
+For (b) there may be other ways to solve the loop, but simply
+reraining from adding derived shadows of Givens is particularly
+simple.  And it's more efficient too!
+
+Still, here's one possible reason for adding derived shadows
+for Givens.  Consider
+           work-item [G] a ~ [b], inerts has [D] b ~ a.
+If we added the derived shadow (into the work list)
+         [D] a ~ [b]
+When we process it, we'll rewrite to a ~ [a] and get an
+occurs check.  Without it we'll miss the occurs check (reporting
+inaccessible code); but that's probably OK.
+
+Note [Keep CDictCan shadows as CDictCan]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+  class C a => D a b
+and [G] D a b, [G] C a in the inert set.  Now we insert
+[D] b ~ c.  We want to kick out a derived shadow for [D] D a b,
+so we can rewrite it with the new constraint, and perhaps get
+instance reduction or other consequences.
+
+BUT we do not want to kick out a *non-canonical* (D a b). If we
+did, we would do this:
+  - rewrite it to [D] D a c, with pend_sc = True
+  - use expandSuperClasses to add C a
+  - go round again, which solves C a from the givens
+This loop goes on for ever and triggers the simpl_loop limit.
+
+Solution: kick out the CDictCan which will have pend_sc = False,
+because we've already added its superclasses.  So we won't re-add
+them.  If we forget the pend_sc flag, our cunning scheme for avoiding
+generating superclasses repeatedly will fail.
+
+See Trac #11379 for a case of this.
+
+Note [Do not do improvement for WOnly]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do improvement between two constraints (e.g. for injectivity
+or functional dependencies) only if both are "improvable". And
+we improve a constraint wrt the top-level instances only if
+it is improvable.
+
+Improvable:     [G] [WD] [D}
+Not improvable: [W]
+
+Reasons:
+
+* It's less work: fewer pairs to compare
+
+* Every [W] has a shadow [D] so nothing is lost
+
+* Consider [WD] C Int b,  where 'b' is a skolem, and
+    class C a b | a -> b
+    instance C Int Bool
+  We'll do a fundep on it and emit [D] b ~ Bool
+  That will kick out constraint [WD] C Int b
+  Then we'll split it to [W] C Int b (keep in inert)
+                     and [D] C Int b (in work list)
+  When processing the latter we'll rewrite it to
+        [D] C Int Bool
+  At that point it would be /stupid/ to interact it
+  with the inert [W] C Int b in the inert set; after all,
+  it's the very constraint from which the [D] C Int Bool
+  was split!  We can avoid this by not doing improvement
+  on [W] constraints. This came up in Trac #12860.
+-}
+
+maybeEmitShadow :: InertCans -> Ct -> TcS Ct
+-- See Note [The improvement story and derived shadows]
+maybeEmitShadow ics ct
+  | let ev = ctEvidence ct
+  , CtWanted { ctev_pred = pred, ctev_loc = loc
+             , ctev_nosh = WDeriv } <- ev
+  , shouldSplitWD (inert_eqs ics) ct
+  = do { traceTcS "Emit derived shadow" (ppr ct)
+       ; let derived_ev = CtDerived { ctev_pred = pred
+                                    , ctev_loc  = loc }
+             shadow_ct = ct { cc_ev = derived_ev }
+               -- Te shadow constraint keeps the canonical shape.
+               -- This just saves work, but is sometimes important;
+               -- see Note [Keep CDictCan shadows as CDictCan]
+       ; emitWork [shadow_ct]
+
+       ; let ev' = ev { ctev_nosh = WOnly }
+             ct' = ct { cc_ev = ev' }
+                 -- Record that it now has a shadow
+                 -- This is /the/ place we set the flag to WOnly
+       ; return ct' }
+
+  | otherwise
+  = return ct
+
+shouldSplitWD :: InertEqs -> Ct -> Bool
+-- Precondition: 'ct' is [WD], and is inert
+-- True <=> we should split ct ito [W] and [D] because
+--          the inert_eqs can make progress on the [D]
+-- See Note [Splitting WD constraints]
+
+shouldSplitWD inert_eqs (CFunEqCan { cc_tyargs = tys })
+  = should_split_match_args inert_eqs tys
+    -- We don't need to split if the tv is the RHS fsk
+
+shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys })
+  = should_split_match_args inert_eqs tys
+    -- NB True: ignore coercions
+    -- See Note [Splitting WD constraints]
+
+shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty
+                                  , cc_eq_rel = eq_rel })
+  =  tv `elemDVarEnv` inert_eqs
+  || anyRewritableTyVar False eq_rel (canRewriteTv inert_eqs) ty
+  -- NB False: do not ignore casts and coercions
+  -- See Note [Splitting WD constraints]
+
+shouldSplitWD inert_eqs (CIrredCan { cc_ev = ev })
+  = anyRewritableTyVar False (ctEvEqRel ev) (canRewriteTv inert_eqs) (ctEvPred ev)
+
+shouldSplitWD _ _ = False   -- No point in splitting otherwise
+
+should_split_match_args :: InertEqs -> [TcType] -> Bool
+-- True if the inert_eqs can rewrite anything in the argument
+-- types, ignoring casts and coercions
+should_split_match_args inert_eqs tys
+  = any (anyRewritableTyVar True NomEq (canRewriteTv inert_eqs)) tys
+    -- NB True: ignore casts coercions
+    -- See Note [Splitting WD constraints]
+
+canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool
+canRewriteTv inert_eqs eq_rel tv
+  | Just (ct : _) <- lookupDVarEnv inert_eqs tv
+  , CTyEqCan { cc_eq_rel = eq_rel1 } <- ct
+  = eq_rel1 `eqCanRewrite` eq_rel
+  | otherwise
+  = False
+
+isImprovable :: CtEvidence -> Bool
+-- See Note [Do not do improvement for WOnly]
+isImprovable (CtWanted { ctev_nosh = WOnly }) = False
+isImprovable _                                = True
+
+
+{- *********************************************************************
+*                                                                      *
+                   Inert equalities
+*                                                                      *
+********************************************************************* -}
+
+addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs
+addTyEq old_eqs tv ct
+  = extendDVarEnv_C add_eq old_eqs tv [ct]
+  where
+    add_eq old_eqs _
+      | isWantedCt ct
+      , (eq1 : eqs) <- old_eqs
+      = eq1 : ct : eqs
+      | otherwise
+      = ct : old_eqs
+
+foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b
+foldTyEqs k eqs z
+  = foldDVarEnv (\cts z -> foldr k z cts) z eqs
+
+findTyEqs :: InertCans -> TyVar -> EqualCtList
+findTyEqs icans tv = lookupDVarEnv (inert_eqs icans) tv `orElse` []
+
+delTyEq :: InertEqs -> TcTyVar -> TcType -> InertEqs
+delTyEq m tv t = modifyDVarEnv (filter (not . isThisOne)) m tv
+  where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1
+        isThisOne _                          = False
+
+lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType
+lookupInertTyVar ieqs tv
+  = case lookupDVarEnv ieqs tv of
+      Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) -> Just rhs
+      _                                                        -> Nothing
+
+lookupFlattenTyVar :: InertEqs -> TcTyVar -> TcType
+-- See Note [lookupFlattenTyVar]
+lookupFlattenTyVar ieqs ftv
+  = lookupInertTyVar ieqs ftv `orElse` mkTyVarTy ftv
+
+{- Note [lookupFlattenTyVar]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have an injective function F and
+  inert_funeqs:   F t1 ~ fsk1
+                  F t2 ~ fsk2
+  inert_eqs:      fsk1 ~ fsk2
+
+We never rewrite the RHS (cc_fsk) of a CFunEqCan.  But we /do/ want to
+get the [D] t1 ~ t2 from the injectiveness of F.  So we look up the
+cc_fsk of CFunEqCans in the inert_eqs when trying to find derived
+equalities arising from injectivity.
+-}
+
+
+{- *********************************************************************
+*                                                                      *
+                   Inert instances: inert_insts
+*                                                                      *
+********************************************************************* -}
+
+addInertForAll :: QCInst -> TcS ()
+-- Add a local Given instance, typically arising from a type signature
+addInertForAll new_qci
+  = updInertCans $ \ics ->
+    ics { inert_insts = add_qci (inert_insts ics) }
+  where
+    add_qci :: [QCInst] -> [QCInst]
+    -- See Note [Do not add duplicate quantified instances]
+    add_qci qcis | any same_qci qcis = qcis
+                 | otherwise         = new_qci : qcis
+
+    same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci))
+                                (ctEvPred (qci_ev new_qci))
+
+{- Note [Do not add duplicate quantified instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (Trac #15244):
+
+  f :: (C g, D g) => ....
+  class S g => C g where ...
+  class S g => D g where ...
+  class (forall a. Eq a => Eq (g a)) => S g where ...
+
+Then in f's RHS there are two identical quantified constraints
+available, one via the superclasses of C and one via the superclasses
+of D.  The two are identical, and it seems wrong to reject the program
+because of that. But without doing duplicate-elimination we will have
+two matching QCInsts when we try to solve constraints arising from f's
+RHS.
+
+The simplest thing is simply to eliminate duplicattes, which we do here.
+-}
+
+{- *********************************************************************
+*                                                                      *
+                  Adding an inert
+*                                                                      *
+************************************************************************
+
+Note [Adding an equality to the InertCans]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When adding an equality to the inerts:
+
+* Split [WD] into [W] and [D] if the inerts can rewrite the latter;
+  done by maybeEmitShadow.
+
+* Kick out any constraints that can be rewritten by the thing
+  we are adding.  Done by kickOutRewritable.
+
+* Note that unifying a:=ty, is like adding [G] a~ty; just use
+  kickOutRewritable with Nominal, Given.  See kickOutAfterUnification.
+
+Note [Kicking out CFunEqCan for fundeps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider:
+   New:    [D] fmv1 ~ fmv2
+   Inert:  [W] F alpha ~ fmv1
+           [W] F beta  ~ fmv2
+
+where F is injective. The new (derived) equality certainly can't
+rewrite the inerts. But we *must* kick out the first one, to get:
+
+   New:   [W] F alpha ~ fmv1
+   Inert: [W] F beta ~ fmv2
+          [D] fmv1 ~ fmv2
+
+and now improvement will discover [D] alpha ~ beta. This is important;
+eg in Trac #9587.
+
+So in kickOutRewritable we look at all the tyvars of the
+CFunEqCan, including the fsk.
+-}
+
+addInertCan :: Ct -> TcS ()  -- Constraints *other than* equalities
+-- Precondition: item /is/ canonical
+-- See Note [Adding an equality to the InertCans]
+addInertCan ct
+  = do { traceTcS "insertInertCan {" $
+         text "Trying to insert new inert item:" <+> ppr ct
+
+       ; ics <- getInertCans
+       ; ct  <- maybeEmitShadow ics ct
+       ; ics <- maybeKickOut ics ct
+       ; setInertCans (add_item ics ct)
+
+       ; traceTcS "addInertCan }" $ empty }
+
+maybeKickOut :: InertCans -> Ct -> TcS InertCans
+-- For a CTyEqCan, kick out any inert that can be rewritten by the CTyEqCan
+maybeKickOut ics ct
+  | CTyEqCan { cc_tyvar = tv, cc_ev = ev, cc_eq_rel = eq_rel } <- ct
+  = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) tv ics
+       ; return ics' }
+  | otherwise
+  = return ics
+
+add_item :: InertCans -> Ct -> InertCans
+add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys })
+  = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item }
+
+add_item ics item@(CTyEqCan { cc_tyvar = tv, cc_ev = ev })
+  = ics { inert_eqs   = addTyEq (inert_eqs ics) tv item
+        , inert_count = bumpUnsolvedCount ev (inert_count ics) }
+
+add_item ics@(IC { inert_irreds = irreds, inert_count = count })
+         item@(CIrredCan { cc_ev = ev, cc_insol = insoluble })
+  = ics { inert_irreds = irreds `Bag.snocBag` item
+        , inert_count  = if insoluble
+                         then count  -- inert_count does not include insolubles
+                         else bumpUnsolvedCount ev count }
+
+add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
+  = ics { inert_dicts = addDict (inert_dicts ics) cls tys item
+        , inert_count = bumpUnsolvedCount ev (inert_count ics) }
+
+add_item _ item
+  = pprPanic "upd_inert set: can't happen! Inserting " $
+    ppr item   -- Can't be CNonCanonical, CHoleCan,
+               -- because they only land in inert_irreds
+
+bumpUnsolvedCount :: CtEvidence -> Int -> Int
+bumpUnsolvedCount ev n | isWanted ev = n+1
+                       | otherwise   = n
+
+
+-----------------------------------------
+kickOutRewritable  :: CtFlavourRole  -- Flavour/role of the equality that
+                                      -- is being added to the inert set
+                    -> TcTyVar        -- The new equality is tv ~ ty
+                    -> InertCans
+                    -> TcS (Int, InertCans)
+kickOutRewritable new_fr new_tv ics
+  = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_tv ics
+             n_kicked = workListSize kicked_out
+
+       ; unless (n_kicked == 0) $
+         do { updWorkListTcS (appendWorkList kicked_out)
+            ; csTraceTcS $
+              hang (text "Kick out, tv =" <+> ppr new_tv)
+                 2 (vcat [ text "n-kicked =" <+> int n_kicked
+                         , text "kicked_out =" <+> ppr kicked_out
+                         , text "Residual inerts =" <+> ppr ics' ]) }
+
+       ; return (n_kicked, ics') }
+
+kick_out_rewritable :: CtFlavourRole  -- Flavour/role of the equality that
+                                      -- is being added to the inert set
+                    -> TcTyVar        -- The new equality is tv ~ ty
+                    -> InertCans
+                    -> (WorkList, InertCans)
+-- See Note [kickOutRewritable]
+kick_out_rewritable new_fr new_tv
+                    ics@(IC { inert_eqs      = tv_eqs
+                            , inert_dicts    = dictmap
+                            , inert_safehask = safehask
+                            , inert_funeqs   = funeqmap
+                            , inert_irreds   = irreds
+                            , inert_insts    = old_insts
+                            , inert_count    = n })
+  | not (new_fr `eqMayRewriteFR` new_fr)
+  = (emptyWorkList, ics)
+        -- If new_fr can't rewrite itself, it can't rewrite
+        -- anything else, so no need to kick out anything.
+        -- (This is a common case: wanteds can't rewrite wanteds)
+        -- Lemma (L2) in Note [Extending the inert equalities]
+
+  | otherwise
+  = (kicked_out, inert_cans_in)
+  where
+    inert_cans_in = IC { inert_eqs      = tv_eqs_in
+                       , inert_dicts    = dicts_in
+                       , inert_safehask = safehask   -- ??
+                       , inert_funeqs   = feqs_in
+                       , inert_irreds   = irs_in
+                       , inert_insts    = insts_in
+                       , inert_count    = n - workListWantedCount kicked_out }
+
+    kicked_out :: WorkList
+    -- NB: use extendWorkList to ensure that kicked-out equalities get priority
+    -- See Note [Prioritise equality constraints] (Kick-out).
+    -- The irreds may include non-canonical (hetero-kinded) equality
+    -- constraints, which perhaps may have become soluble after new_tv
+    -- is substituted; ditto the dictionaries, which may include (a~b)
+    -- or (a~~b) constraints.
+    kicked_out = foldrBag extendWorkListCt
+                          (emptyWorkList { wl_eqs    = tv_eqs_out
+                                         , wl_funeqs = feqs_out })
+                          ((dicts_out `andCts` irs_out)
+                            `extendCtsList` insts_out)
+
+    (tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs
+    (feqs_out,   feqs_in)   = partitionFunEqs  kick_out_ct funeqmap
+           -- See Note [Kicking out CFunEqCan for fundeps]
+    (dicts_out,  dicts_in)  = partitionDicts   kick_out_ct dictmap
+    (irs_out,    irs_in)    = partitionBag     kick_out_ct irreds
+      -- Kick out even insolubles: See Note [Rewrite insolubles]
+      -- Of course we must kick out irreducibles like (c a), in case
+      -- we can rewrite 'c' to something more useful
+
+    -- Kick-out for inert instances
+    -- See Note [Quantified constraints] in TcCanonical
+    insts_out :: [Ct]
+    insts_in  :: [QCInst]
+    (insts_out, insts_in)
+       | fr_may_rewrite (Given, NomEq)  -- All the insts are Givens
+       = partitionWith kick_out_qci old_insts
+       | otherwise
+       = ([], old_insts)
+    kick_out_qci qci
+      | let ev = qci_ev qci
+      , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci))
+      = Left (mkNonCanonical ev)
+      | otherwise
+      = Right qci
+
+    (_, new_role) = new_fr
+
+    fr_can_rewrite_ty :: EqRel -> Type -> Bool
+    fr_can_rewrite_ty role ty = anyRewritableTyVar False role
+                                                   fr_can_rewrite_tv ty
+    fr_can_rewrite_tv :: EqRel -> TyVar -> Bool
+    fr_can_rewrite_tv role tv = new_role `eqCanRewrite` role
+                             && tv == new_tv
+
+    fr_may_rewrite :: CtFlavourRole -> Bool
+    fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs
+        -- Can the new item rewrite the inert item?
+
+    kick_out_ct :: Ct -> Bool
+    -- Kick it out if the new CTyEqCan can rewrite the inert one
+    -- See Note [kickOutRewritable]
+    kick_out_ct ct | let fs@(_,role) = ctFlavourRole ct
+                   = fr_may_rewrite fs
+                   && fr_can_rewrite_ty role (ctPred ct)
+                  -- False: ignore casts and coercions
+                  -- NB: this includes the fsk of a CFunEqCan.  It can't
+                  --     actually be rewritten, but we need to kick it out
+                  --     so we get to take advantage of injectivity
+                  -- See Note [Kicking out CFunEqCan for fundeps]
+
+    kick_out_eqs :: EqualCtList -> ([Ct], DTyVarEnv EqualCtList)
+                 -> ([Ct], DTyVarEnv EqualCtList)
+    kick_out_eqs eqs (acc_out, acc_in)
+      = (eqs_out ++ acc_out, case eqs_in of
+                               []      -> acc_in
+                               (eq1:_) -> extendDVarEnv acc_in (cc_tyvar eq1) eqs_in)
+      where
+        (eqs_out, eqs_in) = partition kick_out_eq eqs
+
+    -- Implements criteria K1-K3 in Note [Extending the inert equalities]
+    kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty
+                          , cc_ev = ev, cc_eq_rel = eq_rel })
+      | not (fr_may_rewrite fs)
+      = False  -- Keep it in the inert set if the new thing can't rewrite it
+
+      -- Below here (fr_may_rewrite fs) is True
+      | tv == new_tv              = True        -- (K1)
+      | kick_out_for_inertness    = True
+      | kick_out_for_completeness = True
+      | otherwise                 = False
+
+      where
+        fs = (ctEvFlavour ev, eq_rel)
+        kick_out_for_inertness
+          =        (fs `eqMayRewriteFR` fs)       -- (K2a)
+            && not (fs `eqMayRewriteFR` new_fr)   -- (K2b)
+            && fr_can_rewrite_ty eq_rel rhs_ty    -- (K2d)
+            -- (K2c) is guaranteed by the first guard of keep_eq
+
+        kick_out_for_completeness
+          = case eq_rel of
+              NomEq  -> rhs_ty `eqType` mkTyVarTy new_tv
+              ReprEq -> isTyVarHead new_tv rhs_ty
+
+    kick_out_eq ct = pprPanic "keep_eq" (ppr ct)
+
+kickOutAfterUnification :: TcTyVar -> TcS Int
+kickOutAfterUnification new_tv
+  = do { ics <- getInertCans
+       ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)
+                                                 new_tv ics
+                     -- Given because the tv := xi is given; NomEq because
+                     -- only nominal equalities are solved by unification
+
+       ; setInertCans ics2
+       ; return n_kicked }
+
+{- Note [kickOutRewritable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See also Note [inert_eqs: the inert equalities].
+
+When we add a new inert equality (a ~N ty) to the inert set,
+we must kick out any inert items that could be rewritten by the
+new equality, to maintain the inert-set invariants.
+
+  - We want to kick out an existing inert constraint if
+    a) the new constraint can rewrite the inert one
+    b) 'a' is free in the inert constraint (so that it *will*)
+       rewrite it if we kick it out.
+
+    For (b) we use tyCoVarsOfCt, which returns the type variables /and
+    the kind variables/ that are directly visible in the type. Hence
+    we will have exposed all the rewriting we care about to make the
+    most precise kinds visible for matching classes etc. No need to
+    kick out constraints that mention type variables whose kinds
+    contain this variable!
+
+  - A Derived equality can kick out [D] constraints in inert_eqs,
+    inert_dicts, inert_irreds etc.
+
+  - We don't kick out constraints from inert_solved_dicts, and
+    inert_solved_funeqs optimistically. But when we lookup we have to
+    take the substitution into account
+
+
+Note [Rewrite insolubles]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have an insoluble alpha ~ [alpha], which is insoluble
+because an occurs check.  And then we unify alpha := [Int].  Then we
+really want to rewrite the insoluble to [Int] ~ [[Int]].  Now it can
+be decomposed.  Otherwise we end up with a "Can't match [Int] ~
+[[Int]]" which is true, but a bit confusing because the outer type
+constructors match.
+
+Similarly, if we have a CHoleCan, we'd like to rewrite it with any
+Givens, to give as informative an error messasge as possible
+(Trac #12468, #11325).
+
+Hence:
+ * In the main simlifier loops in TcSimplify (solveWanteds,
+   simpl_loop), we feed the insolubles in solveSimpleWanteds,
+   so that they get rewritten (albeit not solved).
+
+ * We kick insolubles out of the inert set, if they can be
+   rewritten (see TcSMonad.kick_out_rewritable)
+
+ * We rewrite those insolubles in TcCanonical.
+   See Note [Make sure that insolubles are fully rewritten]
+-}
+
+
+
+--------------
+addInertSafehask :: InertCans -> Ct -> InertCans
+addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })
+  = ics { inert_safehask = addDict (inert_dicts ics) cls tys item }
+
+addInertSafehask _ item
+  = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item
+
+insertSafeOverlapFailureTcS :: Ct -> TcS ()
+-- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify
+insertSafeOverlapFailureTcS item
+  = updInertCans (\ics -> addInertSafehask ics item)
+
+getSafeOverlapFailures :: TcS Cts
+-- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify
+getSafeOverlapFailures
+ = do { IC { inert_safehask = safehask } <- getInertCans
+      ; return $ foldDicts consCts safehask emptyCts }
+
+--------------
+addSolvedDict :: CtEvidence -> Class -> [Type] -> TcS ()
+-- Add a new item in the solved set of the monad
+-- See Note [Solved dictionaries]
+addSolvedDict item cls tys
+  | isIPPred (ctEvPred item)    -- Never cache "solved" implicit parameters (not sure why!)
+  = return ()
+  | otherwise
+  = do { traceTcS "updSolvedSetTcs:" $ ppr item
+       ; updInertTcS $ \ ics ->
+             ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }
+
+getSolvedDicts :: TcS (DictMap CtEvidence)
+getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) }
+
+setSolvedDicts :: DictMap CtEvidence -> TcS ()
+setSolvedDicts solved_dicts
+  = updInertTcS $ \ ics ->
+    ics { inert_solved_dicts = solved_dicts }
+
+
+{- *********************************************************************
+*                                                                      *
+                  Other inert-set operations
+*                                                                      *
+********************************************************************* -}
+
+updInertTcS :: (InertSet -> InertSet) -> TcS ()
+-- Modify the inert set with the supplied function
+updInertTcS upd_fn
+  = do { is_var <- getTcSInertsRef
+       ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var
+                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }
+
+getInertCans :: TcS InertCans
+getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) }
+
+setInertCans :: InertCans -> TcS ()
+setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }
+
+updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a
+-- Modify the inert set with the supplied function
+updRetInertCans upd_fn
+  = do { is_var <- getTcSInertsRef
+       ; wrapTcS (do { inerts <- TcM.readTcRef is_var
+                     ; let (res, cans') = upd_fn (inert_cans inerts)
+                     ; TcM.writeTcRef is_var (inerts { inert_cans = cans' })
+                     ; return res }) }
+
+updInertCans :: (InertCans -> InertCans) -> TcS ()
+-- Modify the inert set with the supplied function
+updInertCans upd_fn
+  = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }
+
+updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()
+-- Modify the inert set with the supplied function
+updInertDicts upd_fn
+  = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) }
+
+updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()
+-- Modify the inert set with the supplied function
+updInertSafehask upd_fn
+  = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }
+
+updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS ()
+-- Modify the inert set with the supplied function
+updInertFunEqs upd_fn
+  = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs ics) }
+
+updInertIrreds :: (Cts -> Cts) -> TcS ()
+-- Modify the inert set with the supplied function
+updInertIrreds upd_fn
+  = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) }
+
+getInertEqs :: TcS (DTyVarEnv EqualCtList)
+getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }
+
+getInertInsols :: TcS Cts
+-- Returns insoluble equality constraints
+-- specifically including Givens
+getInertInsols = do { inert <- getInertCans
+                    ; return (filterBag insolubleEqCt (inert_irreds inert)) }
+
+getInertGivens :: TcS [Ct]
+-- Returns the Given constraints in the inert set,
+-- with type functions *not* unflattened
+getInertGivens
+  = do { inerts <- getInertCans
+       ; let all_cts = foldDicts (:) (inert_dicts inerts)
+                     $ foldFunEqs (:) (inert_funeqs inerts)
+                     $ concat (dVarEnvElts (inert_eqs inerts))
+       ; return (filter isGivenCt all_cts) }
+
+getPendingGivenScs :: TcS [Ct]
+-- Find all inert Given dictionaries, or quantified constraints,
+--     whose cc_pend_sc flag is True
+--     and that belong to the current level
+-- Set their cc_pend_sc flag to False in the inert set, and return that Ct
+getPendingGivenScs = do { lvl <- getTcLevel
+                        ; updRetInertCans (get_sc_pending lvl) }
+
+get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)
+get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
+  = ASSERT2( all isGivenCt sc_pending, ppr sc_pending )
+       -- When getPendingScDics is called,
+       -- there are never any Wanteds in the inert set
+    (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' })
+  where
+    sc_pending = sc_pend_insts ++ sc_pend_dicts
+
+    sc_pend_dicts = foldDicts get_pending dicts []
+    dicts' = foldr add dicts sc_pend_dicts
+
+    (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts
+
+    get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True
+                                       -- but flipping the flag
+    get_pending dict dicts
+        | Just dict' <- isPendingScDict dict
+        , belongs_to_this_level (ctEvidence dict)
+        = dict' : dicts
+        | otherwise
+        = dicts
+
+    add :: Ct -> DictMap Ct -> DictMap Ct
+    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
+        = addDict dicts cls tys ct
+    add ct _ = pprPanic "getPendingScDicts" (ppr ct)
+
+    get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)
+    get_pending_inst cts qci@(QCI { qci_ev = ev })
+       | Just qci' <- isPendingScInst qci
+       , belongs_to_this_level ev
+       = (CQuantCan qci' : cts, qci')
+       | otherwise
+       = (cts, qci)
+
+    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl
+    -- We only want Givens from this level; see (3a) in
+    -- Note [The superclass story] in TcCanonical
+
+getUnsolvedInerts :: TcS ( Bag Implication
+                         , Cts     -- Tyvar eqs: a ~ ty
+                         , Cts     -- Fun eqs:   F a ~ ty
+                         , Cts )   -- All others
+-- Return all the unsolved [Wanted] or [Derived] constraints
+--
+-- Post-condition: the returned simple constraints are all fully zonked
+--                     (because they come from the inert set)
+--                 the unsolved implics may not be
+getUnsolvedInerts
+ = do { IC { inert_eqs    = tv_eqs
+           , inert_funeqs = fun_eqs
+           , inert_irreds = irreds
+           , inert_dicts  = idicts
+           } <- getInertCans
+
+      ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts
+            unsolved_fun_eqs = foldFunEqs add_if_wanted fun_eqs emptyCts
+            unsolved_irreds  = Bag.filterBag is_unsolved irreds
+            unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts
+            unsolved_others  = unsolved_irreds `unionBags` unsolved_dicts
+
+      ; implics <- getWorkListImplics
+
+      ; traceTcS "getUnsolvedInerts" $
+        vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs
+             , text "fun eqs =" <+> ppr unsolved_fun_eqs
+             , text "others =" <+> ppr unsolved_others
+             , text "implics =" <+> ppr implics ]
+
+      ; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs, unsolved_others) }
+  where
+    add_if_unsolved :: Ct -> Cts -> Cts
+    add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts
+                           | otherwise      = cts
+
+    is_unsolved ct = not (isGivenCt ct)   -- Wanted or Derived
+
+    -- For CFunEqCans we ignore the Derived ones, and keep
+    -- only the Wanteds for flattening.  The Derived ones
+    -- share a unification variable with the corresponding
+    -- Wanted, so we definitely don't want to participate
+    -- in unflattening
+    -- See Note [Type family equations]
+    add_if_wanted ct cts | isWantedCt ct = ct `consCts` cts
+                         | otherwise     = cts
+
+isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool
+-- True if (a ~N ty) is in the inert set, in either Given or Wanted
+isInInertEqs eqs tv rhs
+  = case lookupDVarEnv eqs tv of
+      Nothing  -> False
+      Just cts -> any (same_pred rhs) cts
+  where
+    same_pred rhs ct
+      | CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } <- ct
+      , NomEq <- eq_rel
+      , rhs `eqType` rhs2 = True
+      | otherwise         = False
+
+getNoGivenEqs :: TcLevel          -- TcLevel of this implication
+               -> [TcTyVar]       -- Skolems of this implication
+               -> TcS ( Bool      -- True <=> definitely no residual given equalities
+                      , Cts )     -- Insoluble equalities arising from givens
+-- See Note [When does an implication have given equalities?]
+getNoGivenEqs tclvl skol_tvs
+  = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds })
+              <- getInertCans
+       ; let has_given_eqs = foldrBag ((||) . ct_given_here) False irreds
+                          || anyDVarEnv eqs_given_here ieqs
+             insols = filterBag insolubleEqCt irreds
+                      -- Specifically includes ones that originated in some
+                      -- outer context but were refined to an insoluble by
+                      -- a local equality; so do /not/ add ct_given_here.
+
+       ; traceTcS "getNoGivenEqs" $
+         vcat [ if has_given_eqs then text "May have given equalities"
+                                 else text "No given equalities"
+              , text "Skols:" <+> ppr skol_tvs
+              , text "Inerts:" <+> ppr inerts
+              , text "Insols:" <+> ppr insols]
+       ; return (not has_given_eqs, insols) }
+  where
+    eqs_given_here :: EqualCtList -> Bool
+    eqs_given_here [ct@(CTyEqCan { cc_tyvar = tv })]
+                              -- Givens are always a sigleton
+      = not (skolem_bound_here tv) && ct_given_here ct
+    eqs_given_here _ = False
+
+    ct_given_here :: Ct -> Bool
+    -- True for a Given bound by the current implication,
+    -- i.e. the current level
+    ct_given_here ct =  isGiven ev
+                     && tclvl == ctLocLevel (ctEvLoc ev)
+        where
+          ev = ctEvidence ct
+
+    skol_tv_set = mkVarSet skol_tvs
+    skolem_bound_here tv -- See Note [Let-bound skolems]
+      = case tcTyVarDetails tv of
+          SkolemTv {} -> tv `elemVarSet` skol_tv_set
+          _           -> False
+
+-- | Returns Given constraints that might,
+-- potentially, match the given pred. This is used when checking to see if a
+-- Given might overlap with an instance. See Note [Instance and Given overlap]
+-- in TcInteract.
+matchableGivens :: CtLoc -> PredType -> InertSet -> Cts
+matchableGivens loc_w pred_w (IS { inert_cans = inert_cans })
+  = filterBag matchable_given all_relevant_givens
+  where
+    -- just look in class constraints and irreds. matchableGivens does get called
+    -- for ~R constraints, but we don't need to look through equalities, because
+    -- canonical equalities are used for rewriting. We'll only get caught by
+    -- non-canonical -- that is, irreducible -- equalities.
+    all_relevant_givens :: Cts
+    all_relevant_givens
+      | Just (clas, _) <- getClassPredTys_maybe pred_w
+      = findDictsByClass (inert_dicts inert_cans) clas
+        `unionBags` inert_irreds inert_cans
+      | otherwise
+      = inert_irreds inert_cans
+
+    matchable_given :: Ct -> Bool
+    matchable_given ct
+      | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct
+      = mightMatchLater pred_g loc_g pred_w loc_w
+
+      | otherwise
+      = False
+
+mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool
+mightMatchLater given_pred given_loc wanted_pred wanted_loc
+  =  not (prohibitedSuperClassSolve given_loc wanted_loc)
+  && isJust (tcUnifyTys bind_meta_tv [given_pred] [wanted_pred])
+  where
+    bind_meta_tv :: TcTyVar -> BindFlag
+    -- Any meta tyvar may be unified later, so we treat it as
+    -- bindable when unifying with givens. That ensures that we
+    -- conservatively assume that a meta tyvar might get unified with
+    -- something that matches the 'given', until demonstrated
+    -- otherwise.  More info in Note [Instance and Given overlap]
+    -- in TcInteract
+    bind_meta_tv tv | isMetaTyVar tv
+                    , not (isFskTyVar tv) = BindMe
+                    | otherwise           = Skolem
+
+prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool
+-- See Note [Solving superclass constraints] in TcInstDcls
+prohibitedSuperClassSolve from_loc solve_loc
+  | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc
+  , ScOrigin wanted_size <- ctLocOrigin solve_loc
+  = given_size >= wanted_size
+  | otherwise
+  = False
+
+{- Note [Unsolved Derived equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In getUnsolvedInerts, we return a derived equality from the inert_eqs
+because it is a candidate for floating out of this implication.  We
+only float equalities with a meta-tyvar on the left, so we only pull
+those out here.
+
+Note [When does an implication have given equalities?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider an implication
+   beta => alpha ~ Int
+where beta is a unification variable that has already been unified
+to () in an outer scope.  Then we can float the (alpha ~ Int) out
+just fine. So when deciding whether the givens contain an equality,
+we should canonicalise first, rather than just looking at the original
+givens (Trac #8644).
+
+So we simply look at the inert, canonical Givens and see if there are
+any equalities among them, the calculation of has_given_eqs.  There
+are some wrinkles:
+
+ * We must know which ones are bound in *this* implication and which
+   are bound further out.  We can find that out from the TcLevel
+   of the Given, which is itself recorded in the tcl_tclvl field
+   of the TcLclEnv stored in the Given (ev_given_here).
+
+   What about interactions between inner and outer givens?
+      - Outer given is rewritten by an inner given, then there must
+        have been an inner given equality, hence the “given-eq” flag
+        will be true anyway.
+
+      - Inner given rewritten by outer, retains its level (ie. The inner one)
+
+ * We must take account of *potential* equalities, like the one above:
+      beta => ...blah...
+   If we still don't know what beta is, we conservatively treat it as potentially
+   becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs.
+
+ * When flattening givens, we generate Given equalities like
+     <F [a]> : F [a] ~ f,
+   with Refl evidence, and we *don't* want those to count as an equality
+   in the givens!  After all, the entire flattening business is just an
+   internal matter, and the evidence does not mention any of the 'givens'
+   of this implication.  So we do not treat inert_funeqs as a 'given equality'.
+
+ * See Note [Let-bound skolems] for another wrinkle
+
+ * We do *not* need to worry about representational equalities, because
+   these do not affect the ability to float constraints.
+
+Note [Let-bound skolems]
+~~~~~~~~~~~~~~~~~~~~~~~~
+If   * the inert set contains a canonical Given CTyEqCan (a ~ ty)
+and  * 'a' is a skolem bound in this very implication,
+
+then:
+a) The Given is pretty much a let-binding, like
+      f :: (a ~ b->c) => a -> a
+   Here the equality constraint is like saying
+      let a = b->c in ...
+   It is not adding any new, local equality  information,
+   and hence can be ignored by has_given_eqs
+
+b) 'a' will have been completely substituted out in the inert set,
+   so we can safely discard it.  Notably, it doesn't need to be
+   returned as part of 'fsks'
+
+For an example, see Trac #9211.
+
+See also TcUnify Note [Deeper level on the left] for how we ensure
+that the right variable is on the left of the equality when both are
+tyvars.
+
+You might wonder whether the skokem really needs to be bound "in the
+very same implication" as the equuality constraint.
+(c.f. Trac #15009) Consider this:
+
+  data S a where
+    MkS :: (a ~ Int) => S a
+
+  g :: forall a. S a -> a -> blah
+  g x y = let h = \z. ( z :: Int
+                      , case x of
+                           MkS -> [y,z])
+          in ...
+
+From the type signature for `g`, we get `y::a` .  Then when when we
+encounter the `\z`, we'll assign `z :: alpha[1]`, say.  Next, from the
+body of the lambda we'll get
+
+  [W] alpha[1] ~ Int                             -- From z::Int
+  [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a   -- From [y,z]
+
+Now, suppose we decide to float `alpha ~ a` out of the implication
+and then unify `alpha := a`.  Now we are stuck!  But if treat
+`alpha ~ Int` first, and unify `alpha := Int`, all is fine.
+But we absolutely cannot float that equality or we will get stuck.
+-}
+
+removeInertCts :: [Ct] -> InertCans -> InertCans
+-- ^ Remove inert constraints from the 'InertCans', for use when a
+-- typechecker plugin wishes to discard a given.
+removeInertCts cts icans = foldl' removeInertCt icans cts
+
+removeInertCt :: InertCans -> Ct -> InertCans
+removeInertCt is ct =
+  case ct of
+
+    CDictCan  { cc_class = cl, cc_tyargs = tys } ->
+      is { inert_dicts = delDict (inert_dicts is) cl tys }
+
+    CFunEqCan { cc_fun  = tf,  cc_tyargs = tys } ->
+      is { inert_funeqs = delFunEq (inert_funeqs is) tf tys }
+
+    CTyEqCan  { cc_tyvar = x,  cc_rhs    = ty } ->
+      is { inert_eqs    = delTyEq (inert_eqs is) x ty }
+
+    CQuantCan {}     -> panic "removeInertCt: CQuantCan"
+    CIrredCan {}     -> panic "removeInertCt: CIrredEvCan"
+    CNonCanonical {} -> panic "removeInertCt: CNonCanonical"
+    CHoleCan {}      -> panic "removeInertCt: CHoleCan"
+
+
+lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour))
+lookupFlatCache fam_tc tys
+  = do { IS { inert_flat_cache = flat_cache
+            , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts
+       ; return (firstJusts [lookup_inerts inert_funeqs,
+                             lookup_flats flat_cache]) }
+  where
+    lookup_inerts inert_funeqs
+      | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk, cc_tyargs = xis })
+           <- findFunEq inert_funeqs fam_tc tys
+      , tys `eqTypes` xis   -- The lookup might find a near-match; see
+                            -- Note [Use loose types in inert set]
+      = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev)
+      | otherwise = Nothing
+
+    lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys
+
+
+lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)
+-- Is this exact predicate type cached in the solved or canonicals of the InertSet?
+lookupInInerts loc pty
+  | ClassPred cls tys <- classifyPredType pty
+  = do { inerts <- getTcSInerts
+       ; return (lookupSolvedDict inerts loc cls tys `mplus`
+                 lookupInertDict (inert_cans inerts) loc cls tys) }
+  | otherwise -- NB: No caching for equalities, IPs, holes, or errors
+  = return Nothing
+
+-- | Look up a dictionary inert. NB: the returned 'CtEvidence' might not
+-- match the input exactly. Note [Use loose types in inert set].
+lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe CtEvidence
+lookupInertDict (IC { inert_dicts = dicts }) loc cls tys
+  = case findDict dicts loc cls tys of
+      Just ct -> Just (ctEvidence ct)
+      _       -> Nothing
+
+-- | Look up a solved inert. NB: the returned 'CtEvidence' might not
+-- match the input exactly. See Note [Use loose types in inert set].
+lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence
+-- Returns just if exactly this predicate type exists in the solved.
+lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys
+  = case findDict solved loc cls tys of
+      Just ev -> Just ev
+      _       -> Nothing
+
+{- *********************************************************************
+*                                                                      *
+                   Irreds
+*                                                                      *
+********************************************************************* -}
+
+foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b
+foldIrreds k irreds z = foldrBag k z irreds
+
+
+{- *********************************************************************
+*                                                                      *
+                   TcAppMap
+*                                                                      *
+************************************************************************
+
+Note [Use loose types in inert set]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Say we know (Eq (a |> c1)) and we need (Eq (a |> c2)). One is clearly
+solvable from the other. So, we do lookup in the inert set using
+loose types, which omit the kind-check.
+
+We must be careful when using the result of a lookup because it may
+not match the requested info exactly!
+
+-}
+
+type TcAppMap a = UniqDFM (ListMap LooseTypeMap a)
+    -- Indexed by tycon then the arg types, using "loose" matching, where
+    -- we don't require kind equality. This allows, for example, (a |> co)
+    -- to match (a).
+    -- See Note [Use loose types in inert set]
+    -- Used for types and classes; hence UniqDFM
+    -- See Note [foldTM determinism] for why we use UniqDFM here
+
+isEmptyTcAppMap :: TcAppMap a -> Bool
+isEmptyTcAppMap m = isNullUDFM m
+
+emptyTcAppMap :: TcAppMap a
+emptyTcAppMap = emptyUDFM
+
+findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a
+findTcApp m u tys = do { tys_map <- lookupUDFM m u
+                       ; lookupTM tys tys_map }
+
+delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a
+delTcApp m cls tys = adjustUDFM (deleteTM tys) m cls
+
+insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a
+insertTcApp m cls tys ct = alterUDFM alter_tm m cls
+  where
+    alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))
+
+-- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b
+-- mapTcApp f = mapUDFM (mapTM f)
+
+filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct
+filterTcAppMap f m
+  = mapUDFM do_tm m
+  where
+    do_tm tm = foldTM insert_mb tm emptyTM
+    insert_mb ct tm
+       | f ct      = insertTM tys ct tm
+       | otherwise = tm
+       where
+         tys = case ct of
+                CFunEqCan { cc_tyargs = tys } -> tys
+                CDictCan  { cc_tyargs = tys } -> tys
+                _ -> pprPanic "filterTcAppMap" (ppr ct)
+
+tcAppMapToBag :: TcAppMap a -> Bag a
+tcAppMapToBag m = foldTcAppMap consBag m emptyBag
+
+foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b
+foldTcAppMap k m z = foldUDFM (foldTM k) z m
+
+
+{- *********************************************************************
+*                                                                      *
+                   DictMap
+*                                                                      *
+********************************************************************* -}
+
+
+{- Note [Tuples hiding implicit parameters]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f,g :: (?x::Int, C a) => a -> a
+   f v = let ?x = 4 in g v
+
+The call to 'g' gives rise to a Wanted constraint (?x::Int, C a).
+We must /not/ solve this from the Given (?x::Int, C a), because of
+the intervening binding for (?x::Int).  Trac #14218.
+
+We deal with this by arranging that we always fail when looking up a
+tuple constraint that hides an implicit parameter. Not that this applies
+  * both to the inert_dicts (lookupInertDict)
+  * and to the solved_dicts (looukpSolvedDict)
+An alternative would be not to extend these sets with such tuple
+constraints, but it seemed more direct to deal with the lookup.
+
+Note [Solving CallStack constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose f :: HasCallStack => blah.  Then
+
+* Each call to 'f' gives rise to
+    [W] s1 :: IP "callStack" CallStack    -- CtOrigin = OccurrenceOf f
+  with a CtOrigin that says "OccurrenceOf f".
+  Remember that HasCallStack is just shorthand for
+    IP "callStack CallStack
+  See Note [Overview of implicit CallStacks] in TcEvidence
+
+* We cannonicalise such constraints, in TcCanonical.canClassNC, by
+  pushing the call-site info on the stack, and changing the CtOrigin
+  to record that has been done.
+   Bind:  s1 = pushCallStack <site-info> s2
+   [W] s2 :: IP "callStack" CallStack   -- CtOrigin = IPOccOrigin
+
+* Then, and only then, we can solve the constraint from an enclosing
+  Given.
+
+So we must be careful /not/ to solve 's1' from the Givens.  Again,
+we ensure this by arranging that findDict always misses when looking
+up souch constraints.
+-}
+
+type DictMap a = TcAppMap a
+
+emptyDictMap :: DictMap a
+emptyDictMap = emptyTcAppMap
+
+findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a
+findDict m loc cls tys
+  | isCTupleClass cls
+  , any hasIPPred tys   -- See Note [Tuples hiding implicit parameters]
+  = Nothing
+
+  | Just {} <- isCallStackPred cls tys
+  , OccurrenceOf {} <- ctLocOrigin loc
+  = Nothing             -- See Note [Solving CallStack constraints]
+
+  | otherwise
+  = findTcApp m (getUnique cls) tys
+
+findDictsByClass :: DictMap a -> Class -> Bag a
+findDictsByClass m cls
+  | Just tm <- lookupUDFM m cls = foldTM consBag tm emptyBag
+  | otherwise                  = emptyBag
+
+delDict :: DictMap a -> Class -> [Type] -> DictMap a
+delDict m cls tys = delTcApp m (getUnique cls) tys
+
+addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a
+addDict m cls tys item = insertTcApp m (getUnique cls) tys item
+
+addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct
+addDictsByClass m cls items
+  = addToUDFM m cls (foldrBag add emptyTM items)
+  where
+    add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm
+    add ct _ = pprPanic "addDictsByClass" (ppr ct)
+
+filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct
+filterDicts f m = filterTcAppMap f m
+
+partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)
+partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts)
+  where
+    k ct (yeses, noes) | f ct      = (ct `consBag` yeses, noes)
+                       | otherwise = (yeses,              add ct noes)
+    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m
+      = addDict m cls tys ct
+    add ct _ = pprPanic "partitionDicts" (ppr ct)
+
+dictsToBag :: DictMap a -> Bag a
+dictsToBag = tcAppMapToBag
+
+foldDicts :: (a -> b -> b) -> DictMap a -> b -> b
+foldDicts = foldTcAppMap
+
+emptyDicts :: DictMap a
+emptyDicts = emptyTcAppMap
+
+
+{- *********************************************************************
+*                                                                      *
+                   FunEqMap
+*                                                                      *
+********************************************************************* -}
+
+type FunEqMap a = TcAppMap a  -- A map whose key is a (TyCon, [Type]) pair
+
+emptyFunEqs :: TcAppMap a
+emptyFunEqs = emptyTcAppMap
+
+findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a
+findFunEq m tc tys = findTcApp m (getUnique tc) tys
+
+funEqsToBag :: FunEqMap a -> Bag a
+funEqsToBag m = foldTcAppMap consBag m emptyBag
+
+findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]
+-- Get inert function equation constraints that have the given tycon
+-- in their head.  Not that the constraints remain in the inert set.
+-- We use this to check for derived interactions with built-in type-function
+-- constructors.
+findFunEqsByTyCon m tc
+  | Just tm <- lookupUDFM m tc = foldTM (:) tm []
+  | otherwise                 = []
+
+foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b
+foldFunEqs = foldTcAppMap
+
+-- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b
+-- mapFunEqs = mapTcApp
+
+-- filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct
+-- filterFunEqs = filterTcAppMap
+
+insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a
+insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val
+
+partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct)
+-- Optimise for the case where the predicate is false
+-- partitionFunEqs is called only from kick-out, and kick-out usually
+-- kicks out very few equalities, so we want to optimise for that case
+partitionFunEqs f m = (yeses, foldr del m yeses)
+  where
+    yeses = foldTcAppMap k m []
+    k ct yeses | f ct      = ct : yeses
+               | otherwise = yeses
+    del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m
+        = delFunEq m tc tys
+    del ct _ = pprPanic "partitionFunEqs" (ppr ct)
+
+delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a
+delFunEq m tc tys = delTcApp m (getUnique tc) tys
+
+------------------------------
+type ExactFunEqMap a = UniqFM (ListMap TypeMap a)
+
+emptyExactFunEqs :: ExactFunEqMap a
+emptyExactFunEqs = emptyUFM
+
+findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a
+findExactFunEq m tc tys = do { tys_map <- lookupUFM m (getUnique tc)
+                             ; lookupTM tys tys_map }
+
+insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a
+insertExactFunEq m tc tys val = alterUFM alter_tm m (getUnique tc)
+  where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM))
+
+{-
+************************************************************************
+*                                                                      *
+*              The TcS solver monad                                    *
+*                                                                      *
+************************************************************************
+
+Note [The TcS monad]
+~~~~~~~~~~~~~~~~~~~~
+The TcS monad is a weak form of the main Tc monad
+
+All you can do is
+    * fail
+    * allocate new variables
+    * fill in evidence variables
+
+Filling in a dictionary evidence variable means to create a binding
+for it, so TcS carries a mutable location where the binding can be
+added.  This is initialised from the innermost implication constraint.
+-}
+
+data TcSEnv
+  = TcSEnv {
+      tcs_ev_binds    :: EvBindsVar,
+
+      tcs_unified     :: IORef Int,
+         -- The number of unification variables we have filled
+         -- The important thing is whether it is non-zero
+
+      tcs_count     :: IORef Int, -- Global step count
+
+      tcs_inerts    :: IORef InertSet, -- Current inert set
+
+      -- The main work-list and the flattening worklist
+      -- See Note [Work list priorities] and
+      tcs_worklist  :: IORef WorkList -- Current worklist
+    }
+
+---------------
+newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }
+
+instance Functor TcS where
+  fmap f m = TcS $ fmap f . unTcS m
+
+instance Applicative TcS where
+  pure x = TcS (\_ -> return x)
+  (<*>) = ap
+
+instance Monad TcS where
+#if !MIN_VERSION_base(4,13,0)
+  fail = MonadFail.fail
+#endif
+  m >>= k   = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
+
+instance MonadFail.MonadFail TcS where
+  fail err  = TcS (\_ -> fail err)
+
+instance MonadUnique TcS where
+   getUniqueSupplyM = wrapTcS getUniqueSupplyM
+
+instance HasModule TcS where
+   getModule = wrapTcS getModule
+
+instance MonadThings TcS where
+   lookupThing n = wrapTcS (lookupThing n)
+
+-- Basic functionality
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+wrapTcS :: TcM a -> TcS a
+-- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,
+-- and TcS is supposed to have limited functionality
+wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds
+
+wrapErrTcS :: TcM a -> TcS a
+-- The thing wrapped should just fail
+-- There's no static check; it's up to the user
+-- Having a variant for each error message is too painful
+wrapErrTcS = wrapTcS
+
+wrapWarnTcS :: TcM a -> TcS a
+-- The thing wrapped should just add a warning, or no-op
+-- There's no static check; it's up to the user
+wrapWarnTcS = wrapTcS
+
+failTcS, panicTcS  :: SDoc -> TcS a
+warnTcS   :: WarningFlag -> SDoc -> TcS ()
+addErrTcS :: SDoc -> TcS ()
+failTcS      = wrapTcS . TcM.failWith
+warnTcS flag = wrapTcS . TcM.addWarn (Reason flag)
+addErrTcS    = wrapTcS . TcM.addErr
+panicTcS doc = pprPanic "TcCanonical" doc
+
+traceTcS :: String -> SDoc -> TcS ()
+traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)
+
+runTcPluginTcS :: TcPluginM a -> TcS a
+runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar
+
+instance HasDynFlags TcS where
+    getDynFlags = wrapTcS getDynFlags
+
+getGlobalRdrEnvTcS :: TcS GlobalRdrEnv
+getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv
+
+bumpStepCountTcS :: TcS ()
+bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env
+                                    ; n <- TcM.readTcRef ref
+                                    ; TcM.writeTcRef ref (n+1) }
+
+csTraceTcS :: SDoc -> TcS ()
+csTraceTcS doc
+  = wrapTcS $ csTraceTcM (return doc)
+
+traceFireTcS :: CtEvidence -> SDoc -> TcS ()
+-- Dump a rule-firing trace
+traceFireTcS ev doc
+  = TcS $ \env -> csTraceTcM $
+    do { n <- TcM.readTcRef (tcs_count env)
+       ; tclvl <- TcM.getTcLevel
+       ; return (hang (text "Step" <+> int n
+                       <> brackets (text "l:" <> ppr tclvl <> comma <>
+                                    text "d:" <> ppr (ctLocDepth (ctEvLoc ev)))
+                       <+> doc <> colon)
+                     4 (ppr ev)) }
+
+csTraceTcM :: TcM SDoc -> TcM ()
+-- Constraint-solver tracing, -ddump-cs-trace
+csTraceTcM mk_doc
+  = do { dflags <- getDynFlags
+       ; when (  dopt Opt_D_dump_cs_trace dflags
+                  || dopt Opt_D_dump_tc_trace dflags )
+              ( do { msg <- mk_doc
+                   ; TcM.traceTcRn Opt_D_dump_cs_trace msg }) }
+
+runTcS :: TcS a                -- What to run
+       -> TcM (a, EvBindMap)
+runTcS tcs
+  = do { ev_binds_var <- TcM.newTcEvBinds
+       ; res <- runTcSWithEvBinds ev_binds_var tcs
+       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
+       ; return (res, ev_binds) }
+
+-- | This variant of 'runTcS' will keep solving, even when only Deriveds
+-- are left around. It also doesn't return any evidence, as callers won't
+-- need it.
+runTcSDeriveds :: TcS a -> TcM a
+runTcSDeriveds tcs
+  = do { ev_binds_var <- TcM.newTcEvBinds
+       ; runTcSWithEvBinds ev_binds_var tcs }
+
+-- | This can deal only with equality constraints.
+runTcSEqualities :: TcS a -> TcM a
+runTcSEqualities thing_inside
+  = do { ev_binds_var <- TcM.newNoTcEvBinds
+       ; runTcSWithEvBinds ev_binds_var thing_inside }
+
+runTcSWithEvBinds :: EvBindsVar
+                  -> TcS a
+                  -> TcM a
+runTcSWithEvBinds ev_binds_var tcs
+  = do { unified_var <- TcM.newTcRef 0
+       ; step_count <- TcM.newTcRef 0
+       ; inert_var <- TcM.newTcRef emptyInert
+       ; wl_var <- TcM.newTcRef emptyWorkList
+       ; let env = TcSEnv { tcs_ev_binds      = ev_binds_var
+                          , tcs_unified       = unified_var
+                          , tcs_count         = step_count
+                          , tcs_inerts        = inert_var
+                          , tcs_worklist      = wl_var }
+
+             -- Run the computation
+       ; res <- unTcS tcs env
+
+       ; count <- TcM.readTcRef step_count
+       ; when (count > 0) $
+         csTraceTcM $ return (text "Constraint solver steps =" <+> int count)
+
+       ; unflattenGivens inert_var
+
+#if defined(DEBUG)
+       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
+       ; checkForCyclicBinds ev_binds
+#endif
+
+       ; return res }
+
+----------------------------
+#if defined(DEBUG)
+checkForCyclicBinds :: EvBindMap -> TcM ()
+checkForCyclicBinds ev_binds_map
+  | null cycles
+  = return ()
+  | null coercion_cycles
+  = TcM.traceTc "Cycle in evidence binds" $ ppr cycles
+  | otherwise
+  = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles
+  where
+    ev_binds = evBindMapBinds ev_binds_map
+
+    cycles :: [[EvBind]]
+    cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]
+
+    coercion_cycles = [c | c <- cycles, any is_co_bind c]
+    is_co_bind (EvBind { eb_lhs = b }) = isEqPred (varType b)
+
+    edges :: [ Node EvVar EvBind ]
+    edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))
+            | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]
+            -- It's OK to use nonDetEltsUFM here as
+            -- stronglyConnCompFromEdgedVertices is still deterministic even
+            -- if the edges are in nondeterministic order as explained in
+            -- Note [Deterministic SCC] in Digraph.
+#endif
+
+----------------------------
+setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a
+setEvBindsTcS ref (TcS thing_inside)
+ = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref })
+
+nestImplicTcS :: EvBindsVar
+              -> TcLevel -> TcS a
+              -> TcS a
+nestImplicTcS ref inner_tclvl (TcS thing_inside)
+  = TcS $ \ TcSEnv { tcs_unified       = unified_var
+                   , tcs_inerts        = old_inert_var
+                   , tcs_count         = count
+                   } ->
+    do { inerts <- TcM.readTcRef old_inert_var
+       ; let nest_inert = emptyInert
+                            { inert_cans = inert_cans inerts
+                            , inert_solved_dicts = inert_solved_dicts inerts }
+                              -- See Note [Do not inherit the flat cache]
+       ; new_inert_var <- TcM.newTcRef nest_inert
+       ; new_wl_var    <- TcM.newTcRef emptyWorkList
+       ; let nest_env = TcSEnv { tcs_ev_binds      = ref
+                               , tcs_unified       = unified_var
+                               , tcs_count         = count
+                               , tcs_inerts        = new_inert_var
+                               , tcs_worklist      = new_wl_var }
+       ; res <- TcM.setTcLevel inner_tclvl $
+                thing_inside nest_env
+
+       ; unflattenGivens new_inert_var
+
+#if defined(DEBUG)
+       -- Perform a check that the thing_inside did not cause cycles
+       ; ev_binds <- TcM.getTcEvBindsMap ref
+       ; checkForCyclicBinds ev_binds
+#endif
+       ; return res }
+
+{- Note [Do not inherit the flat cache]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not want to inherit the flat cache when processing nested
+implications.  Consider
+   a ~ F b, forall c. b~Int => blah
+If we have F b ~ fsk in the flat-cache, and we push that into the
+nested implication, we might miss that F b can be rewritten to F Int,
+and hence perhpas solve it.  Moreover, the fsk from outside is
+flattened out after solving the outer level, but and we don't
+do that flattening recursively.
+-}
+
+nestTcS ::  TcS a -> TcS a
+-- Use the current untouchables, augmenting the current
+-- evidence bindings, and solved dictionaries
+-- But have no effect on the InertCans, or on the inert_flat_cache
+-- (we want to inherit the latter from processing the Givens)
+nestTcS (TcS thing_inside)
+  = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->
+    do { inerts <- TcM.readTcRef inerts_var
+       ; new_inert_var <- TcM.newTcRef inerts
+       ; new_wl_var    <- TcM.newTcRef emptyWorkList
+       ; let nest_env = env { tcs_inerts   = new_inert_var
+                            , tcs_worklist = new_wl_var }
+
+       ; res <- thing_inside nest_env
+
+       ; new_inerts <- TcM.readTcRef new_inert_var
+
+       -- we want to propogate the safe haskell failures
+       ; let old_ic = inert_cans inerts
+             new_ic = inert_cans new_inerts
+             nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }
+
+       ; TcM.writeTcRef inerts_var  -- See Note [Propagate the solved dictionaries]
+                        (inerts { inert_solved_dicts = inert_solved_dicts new_inerts
+                                , inert_cans = nxt_ic })
+
+       ; return res }
+
+checkTvConstraintsTcS :: SkolemInfo
+                      -> [TcTyVar]        -- Skolems
+                      -> TcS (result, Cts)
+                      -> TcS result
+-- Just like TcUnify.checkTvConstraints, but
+--   - In the TcS monnad
+--   - The thing-inside should not put things in the work-list
+--     Instead, it returns the Wanted constraints it needs
+--   - No 'givens', and no TcEvBinds; this is type-level constraints only
+checkTvConstraintsTcS skol_info skol_tvs (TcS thing_inside)
+  = TcS $ \ tcs_env ->
+    do { let wl_panic  = pprPanic "TcSMonad.buildImplication" $
+                         ppr skol_info $$ ppr skol_tvs
+                         -- This panic checks that the thing-inside
+                         -- does not emit any work-list constraints
+             new_tcs_env = tcs_env { tcs_worklist = wl_panic }
+
+       ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $
+                                        thing_inside new_tcs_env
+
+       ; unless (null wanteds) $
+         do { ev_binds_var <- TcM.newNoTcEvBinds
+            ; imp <- newImplication
+            ; let wc = emptyWC { wc_simple = wanteds }
+                  imp' = imp { ic_tclvl  = new_tclvl
+                             , ic_skols  = skol_tvs
+                             , ic_wanted = wc
+                             , ic_binds  = ev_binds_var
+                             , ic_info   = skol_info }
+
+           -- Add the implication to the work-list
+           ; TcM.updTcRef (tcs_worklist tcs_env)
+                          (extendWorkListImplic (unitBag imp')) }
+
+      ; return res }
+
+checkConstraintsTcS :: SkolemInfo
+                    -> [TcTyVar]        -- Skolems
+                    -> [EvVar]          -- Givens
+                    -> TcS (result, Cts)
+                    -> TcS (result, TcEvBinds)
+-- Just like checkConstraintsTcS, but
+--   - In the TcS monnad
+--   - The thing-inside should not put things in the work-list
+--     Instead, it returns the Wanted constraints it needs
+--   - I did not bother to put in the fast-path for
+--     empty-skols/empty-givens, or for empty-wanteds, because
+--     this function is used only for "quantified constraints" in
+--     with both tests are pretty much guaranteed to fail
+checkConstraintsTcS skol_info skol_tvs given (TcS thing_inside)
+  = TcS $ \ tcs_env ->
+    do { let wl_panic  = pprPanic "TcSMonad.buildImplication" $
+                         ppr skol_info $$ ppr skol_tvs
+                         -- This panic checks that the thing-inside
+                         -- does not emit any work-list constraints
+             new_tcs_env = tcs_env { tcs_worklist = wl_panic }
+
+       ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $
+                                        thing_inside new_tcs_env
+
+       ; ev_binds_var <- TcM.newTcEvBinds
+       ; imp <- newImplication
+       ; let wc = emptyWC { wc_simple = wanteds }
+             imp' = imp { ic_tclvl  = new_tclvl
+                        , ic_skols  = skol_tvs
+                        , ic_given  = given
+                        , ic_wanted = wc
+                        , ic_binds  = ev_binds_var
+                        , ic_info   = skol_info }
+
+           -- Add the implication to the work-list
+       ; TcM.updTcRef (tcs_worklist tcs_env)
+                      (extendWorkListImplic (unitBag imp'))
+
+       ; return (res, TcEvBinds ev_binds_var) }
+
+{-
+Note [Propagate the solved dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's really quite important that nestTcS does not discard the solved
+dictionaries from the thing_inside.
+Consider
+   Eq [a]
+   forall b. empty =>  Eq [a]
+We solve the simple (Eq [a]), under nestTcS, and then turn our attention to
+the implications.  It's definitely fine to use the solved dictionaries on
+the inner implications, and it can make a signficant performance difference
+if you do so.
+-}
+
+-- Getters and setters of TcEnv fields
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+-- Getter of inerts and worklist
+getTcSInertsRef :: TcS (IORef InertSet)
+getTcSInertsRef = TcS (return . tcs_inerts)
+
+getTcSWorkListRef :: TcS (IORef WorkList)
+getTcSWorkListRef = TcS (return . tcs_worklist)
+
+getTcSInerts :: TcS InertSet
+getTcSInerts = getTcSInertsRef >>= readTcRef
+
+setTcSInerts :: InertSet -> TcS ()
+setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics }
+
+getWorkListImplics :: TcS (Bag Implication)
+getWorkListImplics
+  = do { wl_var <- getTcSWorkListRef
+       ; wl_curr <- readTcRef wl_var
+       ; return (wl_implics wl_curr) }
+
+updWorkListTcS :: (WorkList -> WorkList) -> TcS ()
+updWorkListTcS f
+  = do { wl_var <- getTcSWorkListRef
+       ; updTcRef wl_var f }
+
+emitWorkNC :: [CtEvidence] -> TcS ()
+emitWorkNC evs
+  | null evs
+  = return ()
+  | otherwise
+  = emitWork (map mkNonCanonical evs)
+
+emitWork :: [Ct] -> TcS ()
+emitWork cts
+  = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))
+       ; updWorkListTcS (extendWorkListCts cts) }
+
+newTcRef :: a -> TcS (TcRef a)
+newTcRef x = wrapTcS (TcM.newTcRef x)
+
+readTcRef :: TcRef a -> TcS a
+readTcRef ref = wrapTcS (TcM.readTcRef ref)
+
+writeTcRef :: TcRef a -> a -> TcS ()
+writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val)
+
+updTcRef :: TcRef a -> (a->a) -> TcS ()
+updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)
+
+getTcEvBindsVar :: TcS EvBindsVar
+getTcEvBindsVar = TcS (return . tcs_ev_binds)
+
+getTcLevel :: TcS TcLevel
+getTcLevel = wrapTcS TcM.getTcLevel
+
+getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet
+getTcEvTyCoVars ev_binds_var
+  = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var
+
+getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap
+getTcEvBindsMap ev_binds_var
+  = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var
+
+setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS ()
+setTcEvBindsMap ev_binds_var binds
+  = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds
+
+unifyTyVar :: TcTyVar -> TcType -> TcS ()
+-- Unify a meta-tyvar with a type
+-- We keep track of how many unifications have happened in tcs_unified,
+--
+-- We should never unify the same variable twice!
+unifyTyVar tv ty
+  = ASSERT2( isMetaTyVar tv, ppr tv )
+    TcS $ \ env ->
+    do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)
+       ; TcM.writeMetaTyVar tv ty
+       ; TcM.updTcRef (tcs_unified env) (+1) }
+
+reportUnifications :: TcS a -> TcS (Int, a)
+reportUnifications (TcS thing_inside)
+  = TcS $ \ env ->
+    do { inner_unified <- TcM.newTcRef 0
+       ; res <- thing_inside (env { tcs_unified = inner_unified })
+       ; n_unifs <- TcM.readTcRef inner_unified
+       ; TcM.updTcRef (tcs_unified env) (+ n_unifs)
+       ; return (n_unifs, res) }
+
+getDefaultInfo ::  TcS ([Type], (Bool, Bool))
+getDefaultInfo = wrapTcS TcM.tcGetDefaultTys
+
+-- Just get some environments needed for instance looking up and matching
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+getInstEnvs :: TcS InstEnvs
+getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs
+
+getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)
+getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs
+
+getTopEnv :: TcS HscEnv
+getTopEnv = wrapTcS $ TcM.getTopEnv
+
+getGblEnv :: TcS TcGblEnv
+getGblEnv = wrapTcS $ TcM.getGblEnv
+
+getLclEnv :: TcS TcLclEnv
+getLclEnv = wrapTcS $ TcM.getLclEnv
+
+tcLookupClass :: Name -> TcS Class
+tcLookupClass c = wrapTcS $ TcM.tcLookupClass c
+
+tcLookupId :: Name -> TcS Id
+tcLookupId n = wrapTcS $ TcM.tcLookupId n
+
+-- Setting names as used (used in the deriving of Coercible evidence)
+-- Too hackish to expose it to TcS? In that case somehow extract the used
+-- constructors from the result of solveInteract
+addUsedGREs :: [GlobalRdrElt] -> TcS ()
+addUsedGREs gres = wrapTcS  $ TcM.addUsedGREs gres
+
+addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()
+addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre
+
+
+-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()
+-- Check that we do not try to use an instance before it is available.  E.g.
+--    instance Eq T where ...
+--    f x = $( ... (\(p::T) -> p == p)... )
+-- Here we can't use the equality function from the instance in the splice
+
+checkWellStagedDFun loc what pred
+  | TopLevInstance { iw_dfun_id = dfun_id } <- what
+  , let bind_lvl = TcM.topIdLvl dfun_id
+  , bind_lvl > impLevel
+  = wrapTcS $ TcM.setCtLocM loc $
+    do { use_stage <- TcM.getStage
+       ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
+
+  | otherwise
+  = return ()    -- Fast path for common case
+  where
+    pp_thing = text "instance for" <+> quotes (ppr pred)
+
+pprEq :: TcType -> TcType -> SDoc
+pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2
+
+isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)
+isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv)
+
+isFilledMetaTyVar :: TcTyVar -> TcS Bool
+isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)
+
+zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet
+zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs)
+
+zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar]
+zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs)
+
+zonkCo :: Coercion -> TcS Coercion
+zonkCo = wrapTcS . TcM.zonkCo
+
+zonkTcType :: TcType -> TcS TcType
+zonkTcType ty = wrapTcS (TcM.zonkTcType ty)
+
+zonkTcTypes :: [TcType] -> TcS [TcType]
+zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys)
+
+zonkTcTyVar :: TcTyVar -> TcS TcType
+zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)
+
+zonkSimples :: Cts -> TcS Cts
+zonkSimples cts = wrapTcS (TcM.zonkSimples cts)
+
+zonkWC :: WantedConstraints -> TcS WantedConstraints
+zonkWC wc = wrapTcS (TcM.zonkWC wc)
+
+zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar
+zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)
+
+{- *********************************************************************
+*                                                                      *
+*                Flatten skolems                                       *
+*                                                                      *
+********************************************************************* -}
+
+newFlattenSkolem :: CtFlavour -> CtLoc
+                 -> TyCon -> [TcType]                    -- F xis
+                 -> TcS (CtEvidence, Coercion, TcTyVar)  -- [G/WD] x:: F xis ~ fsk
+newFlattenSkolem flav loc tc xis
+  = do { stuff@(ev, co, fsk) <- new_skolem
+       ; let fsk_ty = mkTyVarTy fsk
+       ; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev)
+       ; return stuff }
+  where
+    fam_ty = mkTyConApp tc xis
+
+    new_skolem
+      | Given <- flav
+      = do { fsk <- wrapTcS (TcM.newFskTyVar fam_ty)
+
+           -- Extend the inert_fsks list, for use by unflattenGivens
+           ; updInertTcS $ \is -> is { inert_fsks = (fsk, fam_ty) : inert_fsks is }
+
+           -- Construct the Refl evidence
+           ; let pred = mkPrimEqPred fam_ty (mkTyVarTy fsk)
+                 co   = mkNomReflCo fam_ty
+           ; ev  <- newGivenEvVar loc (pred, evCoercion co)
+           ; return (ev, co, fsk) }
+
+      | otherwise  -- Generate a [WD] for both Wanted and Derived
+                   -- See Note [No Derived CFunEqCans]
+      = do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty)
+           ; (ev, hole_co) <- newWantedEq loc Nominal fam_ty (mkTyVarTy fmv)
+           ; return (ev, hole_co, fmv) }
+
+----------------------------
+unflattenGivens :: IORef InertSet -> TcM ()
+-- Unflatten all the fsks created by flattening types in Given
+-- constraints. We must be sure to do this, else we end up with
+-- flatten-skolems buried in any residual Wanteds
+--
+-- NB: this is the /only/ way that a fsk (MetaDetails = FlatSkolTv)
+--     is filled in. Nothing else does so.
+--
+-- It's here (rather than in TcFlatten) because the Right Places
+-- to call it are in runTcSWithEvBinds/nestImplicTcS, where it
+-- is nicely paired with the creation an empty inert_fsks list.
+unflattenGivens inert_var
+ = do { inerts <- TcM.readTcRef inert_var
+       ; TcM.traceTc "unflattenGivens" (ppr (inert_fsks inerts))
+       ; mapM_ flatten_one (inert_fsks inerts) }
+  where
+    flatten_one (fsk, ty) = TcM.writeMetaTyVar fsk ty
+
+----------------------------
+extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS ()
+extendFlatCache tc xi_args stuff@(_, ty, fl)
+  | isGivenOrWDeriv fl  -- Maintain the invariant that inert_flat_cache
+                        -- only has [G] and [WD] CFunEqCans
+  = do { dflags <- getDynFlags
+       ; when (gopt Opt_FlatCache dflags) $
+    do { traceTcS "extendFlatCache" (vcat [ ppr tc <+> ppr xi_args
+                                          , ppr fl, ppr ty ])
+            -- 'co' can be bottom, in the case of derived items
+       ; updInertTcS $ \ is@(IS { inert_flat_cache = fc }) ->
+            is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } }
+
+  | otherwise
+  = return ()
+
+----------------------------
+unflattenFmv :: TcTyVar -> TcType -> TcS ()
+-- Fill a flatten-meta-var, simply by unifying it.
+-- This does NOT count as a unification in tcs_unified.
+unflattenFmv tv ty
+  = ASSERT2( isMetaTyVar tv, ppr tv )
+    TcS $ \ _ ->
+    do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty)
+       ; TcM.writeMetaTyVar tv ty }
+
+----------------------------
+demoteUnfilledFmv :: TcTyVar -> TcS ()
+-- If a flatten-meta-var is still un-filled,
+-- turn it into an ordinary meta-var
+demoteUnfilledFmv fmv
+  = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv
+                 ; unless is_filled $
+                   do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv)
+                      ; TcM.writeMetaTyVar fmv tv_ty } }
+
+-----------------------------
+dischargeFunEq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS ()
+-- (dischargeFunEq tv co ty)
+--     Preconditions
+--       - ev :: F tys ~ tv   is a CFunEqCan
+--       - tv is a FlatMetaTv of FlatSkolTv
+--       - co :: F tys ~ xi
+--       - fmv/fsk `notElem` xi
+--       - fmv not filled (for Wanteds)
+--
+-- Then for [W] or [WD], we actually fill in the fmv:
+--      set fmv := xi,
+--      set ev  := co
+--      kick out any inert things that are now rewritable
+--
+-- For [D], we instead emit an equality that must ultimately hold
+--      [D] xi ~ fmv
+--      Does not evaluate 'co' if 'ev' is Derived
+--
+-- For [G], emit this equality
+--     [G] (sym ev; co) :: fsk ~ xi
+
+-- See TcFlatten Note [The flattening story],
+-- especially "Ownership of fsk/fmv"
+dischargeFunEq (CtGiven { ctev_evar = old_evar, ctev_loc = loc }) fsk co xi
+  = do { new_ev <- newGivenEvVar loc ( new_pred, evCoercion new_co  )
+       ; emitWorkNC [new_ev] }
+  where
+    new_pred = mkPrimEqPred (mkTyVarTy fsk) xi
+    new_co   = mkTcSymCo (mkTcCoVarCo old_evar) `mkTcTransCo` co
+
+dischargeFunEq ev@(CtWanted { ctev_dest = dest }) fmv co xi
+  = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi )
+    do { setWantedEvTerm dest (evCoercion co)
+       ; unflattenFmv fmv xi
+       ; n_kicked <- kickOutAfterUnification fmv
+       ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ pprKicked n_kicked) }
+
+dischargeFunEq (CtDerived { ctev_loc = loc }) fmv _co xi
+  = emitNewDerivedEq loc Nominal xi (mkTyVarTy fmv)
+              -- FunEqs are always at Nominal role
+
+pprKicked :: Int -> SDoc
+pprKicked 0 = empty
+pprKicked n = parens (int n <+> text "kicked out")
+
+{- *********************************************************************
+*                                                                      *
+*                Instantiation etc.
+*                                                                      *
+********************************************************************* -}
+
+-- Instantiations
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType)
+instDFunType dfun_id inst_tys
+  = wrapTcS $ TcM.instDFunType dfun_id inst_tys
+
+newFlexiTcSTy :: Kind -> TcS TcType
+newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)
+
+cloneMetaTyVar :: TcTyVar -> TcS TcTyVar
+cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)
+
+instFlexi :: [TKVar] -> TcS TCvSubst
+instFlexi = instFlexiX emptyTCvSubst
+
+instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst
+instFlexiX subst tvs
+  = wrapTcS (foldlM instFlexiHelper subst tvs)
+
+instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst
+instFlexiHelper subst tv
+  = do { uniq <- TcM.newUnique
+       ; details <- TcM.newMetaDetails TauTv
+       ; let name = setNameUnique (tyVarName tv) uniq
+             kind = substTyUnchecked subst (tyVarKind tv)
+             ty'  = mkTyVarTy (mkTcTyVar name kind details)
+       ; TcM.traceTc "instFlexi" (ppr ty')
+       ; return (extendTvSubst subst tv ty') }
+
+matchGlobalInst :: DynFlags
+                -> Bool      -- True <=> caller is the short-cut solver
+                             -- See Note [Shortcut solving: overlap]
+                -> Class -> [Type] -> TcS TcM.ClsInstResult
+matchGlobalInst dflags short_cut cls tys
+  = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys)
+
+tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar])
+tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs
+
+-- Creating and setting evidence variables and CtFlavors
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+data MaybeNew = Fresh CtEvidence | Cached EvExpr
+
+isFresh :: MaybeNew -> Bool
+isFresh (Fresh {})  = True
+isFresh (Cached {}) = False
+
+freshGoals :: [MaybeNew] -> [CtEvidence]
+freshGoals mns = [ ctev | Fresh ctev <- mns ]
+
+getEvExpr :: MaybeNew -> EvExpr
+getEvExpr (Fresh ctev) = ctEvExpr ctev
+getEvExpr (Cached evt) = evt
+
+setEvBind :: EvBind -> TcS ()
+setEvBind ev_bind
+  = do { evb <- getTcEvBindsVar
+       ; wrapTcS $ TcM.addTcEvBind evb ev_bind }
+
+-- | Mark variables as used filling a coercion hole
+useVars :: CoVarSet -> TcS ()
+useVars co_vars
+  = do { ev_binds_var <- getTcEvBindsVar
+       ; let ref = ebv_tcvs ev_binds_var
+       ; wrapTcS $
+         do { tcvs <- TcM.readTcRef ref
+            ; let tcvs' = tcvs `unionVarSet` co_vars
+            ; TcM.writeTcRef ref tcvs' } }
+
+-- | Equalities only
+setWantedEq :: TcEvDest -> Coercion -> TcS ()
+setWantedEq (HoleDest hole) co
+  = do { useVars (coVarsOfCo co)
+       ; wrapTcS $ TcM.fillCoercionHole hole co }
+setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev)
+
+-- | Good for both equalities and non-equalities
+setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()
+setWantedEvTerm (HoleDest hole) tm
+  | Just co <- evTermCoercion_maybe tm
+  = do { useVars (coVarsOfCo co)
+       ; wrapTcS $ TcM.fillCoercionHole hole co }
+  | otherwise
+  = do { let co_var = coHoleCoVar hole
+       ; setEvBind (mkWantedEvBind co_var tm)
+       ; wrapTcS $ TcM.fillCoercionHole hole (mkTcCoVarCo co_var) }
+
+setWantedEvTerm (EvVarDest ev_id) tm
+  = setEvBind (mkWantedEvBind ev_id tm)
+
+setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()
+setEvBindIfWanted ev tm
+  = case ev of
+      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm
+      _                             -> return ()
+
+newTcEvBinds :: TcS EvBindsVar
+newTcEvBinds = wrapTcS TcM.newTcEvBinds
+
+newNoTcEvBinds :: TcS EvBindsVar
+newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds
+
+newEvVar :: TcPredType -> TcS EvVar
+newEvVar pred = wrapTcS (TcM.newEvVar pred)
+
+newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence
+-- Make a new variable of the given PredType,
+-- immediately bind it to the given term
+-- and return its CtEvidence
+-- See Note [Bind new Givens immediately] in TcRnTypes
+newGivenEvVar loc (pred, rhs)
+  = do { new_ev <- newBoundEvVarId pred rhs
+       ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }
+
+-- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the
+-- given term
+newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar
+newBoundEvVarId pred rhs
+  = do { new_ev <- newEvVar pred
+       ; setEvBind (mkGivenEvBind new_ev rhs)
+       ; return new_ev }
+
+newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]
+newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts
+
+emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion
+-- | Emit a new Wanted equality into the work-list
+emitNewWantedEq loc role ty1 ty2
+  | otherwise
+  = do { (ev, co) <- newWantedEq loc role ty1 ty2
+       ; updWorkListTcS $
+         extendWorkListEq (mkNonCanonical ev)
+       ; return co }
+
+-- | Make a new equality CtEvidence
+newWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion)
+newWantedEq loc role ty1 ty2
+  = do { hole <- wrapTcS $ TcM.newCoercionHole pty
+       ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)
+       ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole
+                           , ctev_nosh = WDeriv
+                           , ctev_loc = loc}
+                , mkHoleCo hole ) }
+  where
+    pty = mkPrimEqPredRole role ty1 ty2
+
+-- no equalities here. Use newWantedEq instead
+newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence
+-- Don't look up in the solved/inerts; we know it's not there
+newWantedEvVarNC loc pty
+  = do { new_ev <- newEvVar pty
+       ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$
+                                         pprCtLoc loc)
+       ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev
+                          , ctev_nosh = WDeriv
+                          , ctev_loc = loc })}
+
+newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew
+-- For anything except ClassPred, this is the same as newWantedEvVarNC
+newWantedEvVar loc pty
+  = do { mb_ct <- lookupInInerts loc pty
+       ; case mb_ct of
+            Just ctev
+              | not (isDerived ctev)
+              -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev
+                    ; return $ Cached (ctEvExpr ctev) }
+            _ -> do { ctev <- newWantedEvVarNC loc pty
+                    ; return (Fresh ctev) } }
+
+-- deals with both equalities and non equalities. Tries to look
+-- up non-equalities in the cache
+newWanted :: CtLoc -> PredType -> TcS MaybeNew
+newWanted loc pty
+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty
+  = Fresh . fst <$> newWantedEq loc role ty1 ty2
+  | otherwise
+  = newWantedEvVar loc pty
+
+-- deals with both equalities and non equalities. Doesn't do any cache lookups.
+newWantedNC :: CtLoc -> PredType -> TcS CtEvidence
+newWantedNC loc pty
+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty
+  = fst <$> newWantedEq loc role ty1 ty2
+  | otherwise
+  = newWantedEvVarNC loc pty
+
+emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS ()
+emitNewDeriveds loc preds
+  | null preds
+  = return ()
+  | otherwise
+  = do { evs <- mapM (newDerivedNC loc) preds
+       ; traceTcS "Emitting new deriveds" (ppr evs)
+       ; updWorkListTcS (extendWorkListDeriveds evs) }
+
+emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS ()
+-- Create new equality Derived and put it in the work list
+-- There's no caching, no lookupInInerts
+emitNewDerivedEq loc role ty1 ty2
+  = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2)
+       ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc)
+       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) }
+         -- Very important: put in the wl_eqs
+         -- See Note [Prioritise equalities] (Avoiding fundep iteration)
+
+newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence
+newDerivedNC loc pred
+  = do { -- checkReductionDepth loc pred
+       ; return (CtDerived { ctev_pred = pred, ctev_loc = loc }) }
+
+-- --------- Check done in TcInteract.selectNewWorkItem???? ---------
+-- | Checks if the depth of the given location is too much. Fails if
+-- it's too big, with an appropriate error message.
+checkReductionDepth :: CtLoc -> TcType   -- ^ type being reduced
+                    -> TcS ()
+checkReductionDepth loc ty
+  = do { dflags <- getDynFlags
+       ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $
+         wrapErrTcS $
+         solverDepthErrorTcS loc ty }
+
+matchFam :: TyCon -> [Type] -> TcS (Maybe (Coercion, TcType))
+matchFam tycon args = wrapTcS $ matchFamTcM tycon args
+
+matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (Coercion, TcType))
+-- Given (F tys) return (ty, co), where co :: F tys ~ ty
+matchFamTcM tycon args
+  = do { fam_envs <- FamInst.tcGetFamInstEnvs
+       ; let match_fam_result
+              = reduceTyFamApp_maybe fam_envs Nominal tycon args
+       ; TcM.traceTc "matchFamTcM" $
+         vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args)
+              , ppr_res match_fam_result ]
+       ; return match_fam_result }
+  where
+    ppr_res Nothing        = text "Match failed"
+    ppr_res (Just (co,ty)) = hang (text "Match succeeded:")
+                                2 (vcat [ text "Rewrites to:" <+> ppr ty
+                                        , text "Coercion:" <+> ppr co ])
+
+{-
+Note [Residual implications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The wl_implics in the WorkList are the residual implication
+constraints that are generated while solving or canonicalising the
+current worklist.  Specifically, when canonicalising
+   (forall a. t1 ~ forall a. t2)
+from which we get the implication
+   (forall a. t1 ~ t2)
+See TcSMonad.deferTcSForAllEq
+-}
diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcSigs.hs
@@ -0,0 +1,835 @@
+{-
+(c) The University of Glasgow 2006-2012
+(c) The GRASP Project, Glasgow University, 1992-2002
+
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcSigs(
+       TcSigInfo(..),
+       TcIdSigInfo(..), TcIdSigInst,
+       TcPatSynInfo(..),
+       TcSigFun,
+
+       isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName,
+       completeSigPolyId_maybe,
+
+       tcTySigs, tcUserTypeSig, completeSigFromId,
+       tcInstSig,
+
+       TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,
+       mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags
+   ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import TcHsType
+import TcRnTypes
+import TcRnMonad
+import TcType
+import TcMType
+import TcValidity ( checkValidType )
+import TcUnify( tcSkolemise, unifyType )
+import Inst( topInstantiate )
+import TcEnv( tcLookupId )
+import TcEvidence( HsWrapper, (<.>) )
+import Type( mkTyVarBinders )
+
+import DynFlags
+import Var      ( TyVar, tyVarKind )
+import Id       ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId )
+import PrelNames( mkUnboundName )
+import BasicTypes
+import Bag( foldrBag )
+import Module( getModule )
+import Name
+import NameEnv
+import Outputable
+import SrcLoc
+import Util( singleton )
+import Maybes( orElse )
+import Data.Maybe( mapMaybe )
+import Control.Monad( unless )
+
+
+{- -------------------------------------------------------------
+          Note [Overview of type signatures]
+----------------------------------------------------------------
+Type signatures, including partial signatures, are jolly tricky,
+especially on value bindings.  Here's an overview.
+
+    f :: forall a. [a] -> [a]
+    g :: forall b. _ -> b
+
+    f = ...g...
+    g = ...f...
+
+* HsSyn: a signature in a binding starts off as a TypeSig, in
+  type HsBinds.Sig
+
+* When starting a mutually recursive group, like f/g above, we
+  call tcTySig on each signature in the group.
+
+* tcTySig: Sig -> TcIdSigInfo
+  - For a /complete/ signature, like 'f' above, tcTySig kind-checks
+    the HsType, producing a Type, and wraps it in a CompleteSig, and
+    extend the type environment with this polymorphic 'f'.
+
+  - For a /partial/signature, like 'g' above, tcTySig does nothing
+    Instead it just wraps the pieces in a PartialSig, to be handled
+    later.
+
+* tcInstSig: TcIdSigInfo -> TcIdSigInst
+  In tcMonoBinds, when looking at an individual binding, we use
+  tcInstSig to instantiate the signature forall's in the signature,
+  and attribute that instantiated (monomorphic) type to the
+  binder.  You can see this in TcBinds.tcLhsId.
+
+  The instantiation does the obvious thing for complete signatures,
+  but for /partial/ signatures it starts from the HsSyn, so it
+  has to kind-check it etc: tcHsPartialSigType.  It's convenient
+  to do this at the same time as instantiation, because we can
+  make the wildcards into unification variables right away, raather
+  than somehow quantifying over them.  And the "TcLevel" of those
+  unification variables is correct because we are in tcMonoBinds.
+
+
+Note [Scoped tyvars]
+~~~~~~~~~~~~~~~~~~~~
+The -XScopedTypeVariables flag brings lexically-scoped type variables
+into scope for any explicitly forall-quantified type variables:
+        f :: forall a. a -> a
+        f x = e
+Then 'a' is in scope inside 'e'.
+
+However, we do *not* support this
+  - For pattern bindings e.g
+        f :: forall a. a->a
+        (f,g) = e
+
+Note [Binding scoped type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The type variables *brought into lexical scope* by a type signature
+may be a subset of the *quantified type variables* of the signatures,
+for two reasons:
+
+* With kind polymorphism a signature like
+    f :: forall f a. f a -> f a
+  may actually give rise to
+    f :: forall k. forall (f::k -> *) (a:k). f a -> f a
+  So the sig_tvs will be [k,f,a], but only f,a are scoped.
+  NB: the scoped ones are not necessarily the *inital* ones!
+
+* Even aside from kind polymorphism, there may be more instantiated
+  type variables than lexically-scoped ones.  For example:
+        type T a = forall b. b -> (a,b)
+        f :: forall c. T c
+  Here, the signature for f will have one scoped type variable, c,
+  but two instantiated type variables, c' and b'.
+
+However, all of this only applies to the renamer.  The typechecker
+just puts all of them into the type environment; any lexical-scope
+errors were dealt with by the renamer.
+
+-}
+
+
+{- *********************************************************************
+*                                                                      *
+             Utility functions for TcSigInfo
+*                                                                      *
+********************************************************************* -}
+
+tcIdSigName :: TcIdSigInfo -> Name
+tcIdSigName (CompleteSig { sig_bndr = id }) = idName id
+tcIdSigName (PartialSig { psig_name = n })  = n
+
+tcSigInfoName :: TcSigInfo -> Name
+tcSigInfoName (TcIdSig     idsi) = tcIdSigName idsi
+tcSigInfoName (TcPatSynSig tpsi) = patsig_name tpsi
+
+completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
+completeSigPolyId_maybe sig
+  | TcIdSig sig_info <- sig
+  , CompleteSig { sig_bndr = id } <- sig_info = Just id
+  | otherwise                                 = Nothing
+
+
+{- *********************************************************************
+*                                                                      *
+               Typechecking user signatures
+*                                                                      *
+********************************************************************* -}
+
+tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun)
+tcTySigs hs_sigs
+  = checkNoErrs $   -- See Note [Fail eagerly on bad signatures]
+    do { ty_sigs_s <- mapAndRecoverM tcTySig hs_sigs
+       ; let ty_sigs  = concat ty_sigs_s
+             poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs
+                        -- The returned [TcId] are the ones for which we have
+                        -- a complete type signature.
+                        -- See Note [Complete and partial type signatures]
+             env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs]
+       ; return (poly_ids, lookupNameEnv env) }
+
+tcTySig :: LSig GhcRn -> TcM [TcSigInfo]
+tcTySig (L _ (IdSig _ id))
+  = do { let ctxt = FunSigCtxt (idName id) False
+                    -- False: do not report redundant constraints
+                    -- The user has no control over the signature!
+             sig = completeSigFromId ctxt id
+       ; return [TcIdSig sig] }
+
+tcTySig (L loc (TypeSig _ names sig_ty))
+  = setSrcSpan loc $
+    do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name)
+                          | L _ name <- names ]
+       ; return (map TcIdSig sigs) }
+
+tcTySig (L loc (PatSynSig _ names sig_ty))
+  = setSrcSpan loc $
+    do { tpsigs <- sequence [ tcPatSynSig name sig_ty
+                            | L _ name <- names ]
+       ; return (map TcPatSynSig tpsigs) }
+
+tcTySig _ = return []
+
+
+tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name
+              -> TcM TcIdSigInfo
+-- A function or expression type signature
+-- Returns a fully quantified type signature; even the wildcards
+-- are quantified with ordinary skolems that should be instantiated
+--
+-- The SrcSpan is what to declare as the binding site of the
+-- any skolems in the signature. For function signatures we
+-- use the whole `f :: ty' signature; for expression signatures
+-- just the type part.
+--
+-- Just n  => Function type signature       name :: type
+-- Nothing => Expression type signature   <expr> :: type
+tcUserTypeSig loc hs_sig_ty mb_name
+  | isCompleteHsSig hs_sig_ty
+  = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty
+       ; return $
+         CompleteSig { sig_bndr  = mkLocalId name sigma_ty
+                     , sig_ctxt  = ctxt_T
+                     , sig_loc   = loc } }
+                       -- Location of the <type> in   f :: <type>
+
+  -- Partial sig with wildcards
+  | otherwise
+  = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty
+                       , sig_ctxt = ctxt_F, sig_loc = loc })
+  where
+    name   = case mb_name of
+               Just n  -> n
+               Nothing -> mkUnboundName (mkVarOcc "<expression>")
+    ctxt_F = case mb_name of
+               Just n  -> FunSigCtxt n False
+               Nothing -> ExprSigCtxt
+    ctxt_T = case mb_name of
+               Just n  -> FunSigCtxt n True
+               Nothing -> ExprSigCtxt
+
+
+
+completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo
+-- Used for instance methods and record selectors
+completeSigFromId ctxt id
+  = CompleteSig { sig_bndr = id
+                , sig_ctxt = ctxt
+                , sig_loc  = getSrcSpan id }
+
+isCompleteHsSig :: LHsSigWcType GhcRn -> Bool
+-- ^ If there are no wildcards, return a LHsSigType
+isCompleteHsSig (HsWC { hswc_ext  = wcs
+                      , hswc_body = HsIB { hsib_body = hs_ty } })
+   = null wcs && no_anon_wc hs_ty
+isCompleteHsSig (HsWC _ (XHsImplicitBndrs _)) = panic "isCompleteHsSig"
+isCompleteHsSig (XHsWildCardBndrs _) = panic "isCompleteHsSig"
+
+no_anon_wc :: LHsType GhcRn -> Bool
+no_anon_wc lty = go lty
+  where
+    go (L _ ty) = case ty of
+      HsWildCardTy _                 -> False
+      HsAppTy _ ty1 ty2              -> go ty1 && go ty2
+      HsAppKindTy _ ty ki            -> go ty && go ki
+      HsFunTy _ ty1 ty2              -> go ty1 && go ty2
+      HsListTy _ ty                  -> go ty
+      HsTupleTy _ _ tys              -> gos tys
+      HsSumTy _ tys                  -> gos tys
+      HsOpTy _ ty1 _ ty2             -> go ty1 && go ty2
+      HsParTy _ ty                   -> go ty
+      HsIParamTy _ _ ty              -> go ty
+      HsKindSig _ ty kind            -> go ty && go kind
+      HsDocTy _ ty _                 -> go ty
+      HsBangTy _ _ ty                -> go ty
+      HsRecTy _ flds                 -> gos $ map (cd_fld_type . unLoc) flds
+      HsExplicitListTy _ _ tys       -> gos tys
+      HsExplicitTupleTy _ tys        -> gos tys
+      HsForAllTy { hst_bndrs = bndrs
+                 , hst_body = ty } -> no_anon_wc_bndrs bndrs
+                                        && go ty
+      HsQualTy { hst_ctxt = L _ ctxt
+               , hst_body = ty }  -> gos ctxt && go ty
+      HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty
+      HsSpliceTy{} -> True
+      HsTyLit{} -> True
+      HsTyVar{} -> True
+      HsStarTy{} -> True
+      XHsType{} -> True      -- Core type, which does not have any wildcard
+
+    gos = all go
+
+no_anon_wc_bndrs :: [LHsTyVarBndr GhcRn] -> Bool
+no_anon_wc_bndrs ltvs = all (go . unLoc) ltvs
+  where
+    go (UserTyVar _ _)      = True
+    go (KindedTyVar _ _ ki) = no_anon_wc ki
+    go (XTyVarBndr{})       = panic "no_anon_wc_bndrs"
+
+{- Note [Fail eagerly on bad signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a type signature is wrong, fail immediately:
+
+ * the type sigs may bind type variables, so proceeding without them
+   can lead to a cascade of errors
+
+ * the type signature might be ambiguous, in which case checking
+   the code against the signature will give a very similar error
+   to the ambiguity error.
+
+ToDo: this means we fall over if any type sig
+is wrong (eg at the top level of the module),
+which is over-conservative
+-}
+
+{- *********************************************************************
+*                                                                      *
+        Type checking a pattern synonym signature
+*                                                                      *
+************************************************************************
+
+Note [Pattern synonym signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Pattern synonym signatures are surprisingly tricky (see Trac #11224 for example).
+In general they look like this:
+
+   pattern P :: forall univ_tvs. req_theta
+             => forall ex_tvs. prov_theta
+             => arg1 -> .. -> argn -> res_ty
+
+For parsing and renaming we treat the signature as an ordinary LHsSigType.
+
+Once we get to type checking, we decompose it into its parts, in tcPatSynSig.
+
+* Note that 'forall univ_tvs' and 'req_theta =>'
+        and 'forall ex_tvs'   and 'prov_theta =>'
+  are all optional.  We gather the pieces at the top of tcPatSynSig
+
+* Initially the implicitly-bound tyvars (added by the renamer) include both
+  universal and existential vars.
+
+* After we kind-check the pieces and convert to Types, we do kind generalisation.
+
+Note [solveEqualities in tcPatSynSig]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's important that we solve /all/ the equalities in a pattern
+synonym signature, because we are going to zonk the signature to
+a Type (not a TcType), in TcPatSyn.tc_patsyn_finish, and that
+fails if there are un-filled-in coercion variables mentioned
+in the type (Trac #15694).
+
+The best thing is simply to use solveEqualities to solve all the
+equalites, rather than leaving them in the ambient constraints
+to be solved later.  Pattern synonyms are top-level, so there's
+no problem with completely solving them.
+
+(NB: this solveEqualities wraps newImplicitTKBndrs, which itself
+does a solveLocalEqualities; so solveEqualities isn't going to
+make any further progress; it'll just report any unsolved ones,
+and fail, as it should.)
+-}
+
+tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo
+-- See Note [Pattern synonym signatures]
+-- See Note [Recipe for checking a signature] in TcHsType
+tcPatSynSig name sig_ty
+  | HsIB { hsib_ext = implicit_hs_tvs
+         , hsib_body = hs_ty }  <- sig_ty
+  , (univ_hs_tvs, hs_req,  hs_ty1)     <- splitLHsSigmaTy hs_ty
+  , (ex_hs_tvs,   hs_prov, hs_body_ty) <- splitLHsSigmaTy hs_ty1
+  = do {  traceTc "tcPatSynSig 1" (ppr sig_ty)
+       ; (implicit_tvs, (univ_tvs, (ex_tvs, (req, prov, body_ty))))
+           <- pushTcLevelM_   $
+              solveEqualities $ -- See Note [solveEqualities in tcPatSynSig]
+              bindImplicitTKBndrs_Skol implicit_hs_tvs $
+              bindExplicitTKBndrs_Skol univ_hs_tvs     $
+              bindExplicitTKBndrs_Skol ex_hs_tvs       $
+              do { req     <- tcHsContext hs_req
+                 ; prov    <- tcHsContext hs_prov
+                 ; body_ty <- tcHsOpenType hs_body_ty
+                     -- A (literal) pattern can be unlifted;
+                     -- e.g. pattern Zero <- 0#   (Trac #12094)
+                 ; return (req, prov, body_ty) }
+
+       ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvs req
+                                                 ex_tvs prov body_ty
+
+       -- Kind generalisation
+       ; kvs <- kindGeneralize ungen_patsyn_ty
+       ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty)
+
+       -- These are /signatures/ so we zonk to squeeze out any kind
+       -- unification variables.  Do this after kindGeneralize which may
+       -- default kind variables to *.
+       ; implicit_tvs <- zonkAndScopedSort implicit_tvs
+       ; univ_tvs     <- mapM zonkTyCoVarKind univ_tvs
+       ; ex_tvs       <- mapM zonkTyCoVarKind ex_tvs
+       ; req          <- zonkTcTypes req
+       ; prov         <- zonkTcTypes prov
+       ; body_ty      <- zonkTcType  body_ty
+
+       -- Skolems have TcLevels too, though they're used only for debugging.
+       -- If you don't do this, the debugging checks fail in TcPatSyn.
+       -- Test case: patsyn/should_compile/T13441
+{-
+       ; tclvl <- getTcLevel
+       ; let env0                  = mkEmptyTCvSubst $ mkInScopeSet $ mkVarSet kvs
+             (env1, implicit_tvs') = promoteSkolemsX tclvl env0 implicit_tvs
+             (env2, univ_tvs')     = promoteSkolemsX tclvl env1 univ_tvs
+             (env3, ex_tvs')       = promoteSkolemsX tclvl env2 ex_tvs
+             req'                  = substTys env3 req
+             prov'                 = substTys env3 prov
+             body_ty'              = substTy  env3 body_ty
+-}
+      ; let implicit_tvs' = implicit_tvs
+            univ_tvs'     = univ_tvs
+            ex_tvs'       = ex_tvs
+            req'          = req
+            prov'         = prov
+            body_ty'      = body_ty
+
+       -- Now do validity checking
+       ; checkValidType ctxt $
+         build_patsyn_type kvs implicit_tvs' univ_tvs' req' ex_tvs' prov' body_ty'
+
+       -- arguments become the types of binders. We thus cannot allow
+       -- levity polymorphism here
+       ; let (arg_tys, _) = tcSplitFunTys body_ty'
+       ; mapM_ (checkForLevPoly empty) arg_tys
+
+       ; traceTc "tcTySig }" $
+         vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs'
+              , text "kvs" <+> ppr_tvs kvs
+              , text "univ_tvs" <+> ppr_tvs univ_tvs'
+              , text "req" <+> ppr req'
+              , text "ex_tvs" <+> ppr_tvs ex_tvs'
+              , text "prov" <+> ppr prov'
+              , text "body_ty" <+> ppr body_ty' ]
+       ; return (TPSI { patsig_name = name
+                      , patsig_implicit_bndrs = mkTyVarBinders Inferred  kvs ++
+                                                mkTyVarBinders Specified implicit_tvs'
+                      , patsig_univ_bndrs     = univ_tvs'
+                      , patsig_req            = req'
+                      , patsig_ex_bndrs       = ex_tvs'
+                      , patsig_prov           = prov'
+                      , patsig_body_ty        = body_ty' }) }
+  where
+    ctxt = PatSynCtxt name
+
+    build_patsyn_type kvs imp univ req ex prov body
+      = mkInvForAllTys kvs $
+        mkSpecForAllTys (imp ++ univ) $
+        mkFunTys req $
+        mkSpecForAllTys ex $
+        mkFunTys prov $
+        body
+tcPatSynSig _ (XHsImplicitBndrs _) = panic "tcPatSynSig"
+
+ppr_tvs :: [TyVar] -> SDoc
+ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)
+                           | tv <- tvs])
+
+
+{- *********************************************************************
+*                                                                      *
+               Instantiating user signatures
+*                                                                      *
+********************************************************************* -}
+
+
+tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst
+-- Instantiate a type signature; only used with plan InferGen
+tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc })
+  = setSrcSpan loc $  -- Set the binding site of the tyvars
+    do { (tv_prs, theta, tau) <- tcInstType newMetaTyVarTyVars poly_id
+              -- See Note [Pattern bindings and complete signatures]
+
+       ; return (TISI { sig_inst_sig   = sig
+                      , sig_inst_skols = tv_prs
+                      , sig_inst_wcs   = []
+                      , sig_inst_wcx   = Nothing
+                      , sig_inst_theta = theta
+                      , sig_inst_tau   = tau }) }
+
+tcInstSig hs_sig@(PartialSig { psig_hs_ty = hs_ty
+                             , sig_ctxt = ctxt
+                             , sig_loc = loc })
+  = setSrcSpan loc $  -- Set the binding site of the tyvars
+    do { traceTc "Staring partial sig {" (ppr hs_sig)
+       ; (wcs, wcx, tv_names, tvs, theta, tau) <- tcHsPartialSigType ctxt hs_ty
+
+        -- Clone the quantified tyvars
+        -- Reason: we might have    f, g :: forall a. a -> _ -> a
+        --         and we want it to behave exactly as if there were
+        --         two separate signatures.  Cloning here seems like
+        --         the easiest way to do so, and is very similar to
+        --         the tcInstType in the CompleteSig case
+        -- See Trac #14643
+       ; (subst, tvs') <- newMetaTyVarTyVars tvs
+                         -- Why newMetaTyVarTyVars?  See TcBinds
+                         -- Note [Quantified variables in partial type signatures]
+       ; let tv_prs = tv_names `zip` tvs'
+             inst_sig = TISI { sig_inst_sig   = hs_sig
+                             , sig_inst_skols = tv_prs
+                             , sig_inst_wcs   = wcs
+                             , sig_inst_wcx   = wcx
+                             , sig_inst_theta = substTys subst theta
+                             , sig_inst_tau   = substTy  subst tau }
+       ; traceTc "End partial sig }" (ppr inst_sig)
+       ; return inst_sig }
+
+
+{- Note [Pattern bindings and complete signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+      data T a = MkT a a
+      f :: forall a. a->a
+      g :: forall b. b->b
+      MkT f g = MkT (\x->x) (\y->y)
+Here we'll infer a type from the pattern of 'T a', but if we feed in
+the signature types for f and g, we'll end up unifying 'a' and 'b'
+
+So we instantiate f and g's signature with TyVarTv skolems
+(newMetaTyVarTyVars) that can unify with each other.  If too much
+unification takes place, we'll find out when we do the final
+impedance-matching check in TcBinds.mkExport
+
+See Note [Signature skolems] in TcType
+
+None of this applies to a function binding with a complete
+signature, which doesn't use tcInstSig.  See TcBinds.tcPolyCheck.
+-}
+
+{- *********************************************************************
+*                                                                      *
+                   Pragmas and PragEnv
+*                                                                      *
+********************************************************************* -}
+
+type TcPragEnv = NameEnv [LSig GhcRn]
+
+emptyPragEnv :: TcPragEnv
+emptyPragEnv = emptyNameEnv
+
+lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn]
+lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` []
+
+extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv
+extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig
+
+---------------
+mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
+mkPragEnv sigs binds
+  = foldl' extendPragEnv emptyNameEnv prs
+  where
+    prs = mapMaybe get_sig sigs
+
+    get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)
+    get_sig (L l (SpecSig x lnm@(L _ nm) ty inl))
+      = Just (nm, L l $ SpecSig   x lnm ty (add_arity nm inl))
+    get_sig (L l (InlineSig x lnm@(L _ nm) inl))
+      = Just (nm, L l $ InlineSig x lnm    (add_arity nm inl))
+    get_sig (L l (SCCFunSig x st lnm@(L _ nm) str))
+      = Just (nm, L l $ SCCFunSig x st lnm str)
+    get_sig _ = Nothing
+
+    add_arity n inl_prag   -- Adjust inl_sat field to match visible arity of function
+      | Inline <- inl_inline inl_prag
+        -- add arity only for real INLINE pragmas, not INLINABLE
+      = case lookupNameEnv ar_env n of
+          Just ar -> inl_prag { inl_sat = Just ar }
+          Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n )
+                     -- There really should be a binding for every INLINE pragma
+                     inl_prag
+      | otherwise
+      = inl_prag
+
+    -- ar_env maps a local to the arity of its definition
+    ar_env :: NameEnv Arity
+    ar_env = foldrBag lhsBindArity emptyNameEnv binds
+
+lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity
+lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
+  = extendNameEnv env (unLoc id) (matchGroupArity ms)
+lhsBindArity _ env = env        -- PatBind/VarBind
+
+
+-----------------
+addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId
+addInlinePrags poly_id prags_for_me
+  | inl@(L _ prag) : inls <- inl_prags
+  = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag)
+       ; unless (null inls) (warn_multiple_inlines inl inls)
+       ; return (poly_id `setInlinePragma` prag) }
+  | otherwise
+  = return poly_id
+  where
+    inl_prags = [L loc prag | L loc (InlineSig _ _ prag) <- prags_for_me]
+
+    warn_multiple_inlines _ [] = return ()
+
+    warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls)
+       | inlinePragmaActivation prag1 == inlinePragmaActivation prag2
+       , noUserInlineSpec (inlinePragmaSpec prag1)
+       =    -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop
+            -- and inl2 is a user NOINLINE pragma; we don't want to complain
+         warn_multiple_inlines inl2 inls
+       | otherwise
+       = setSrcSpan loc $
+         addWarnTc NoReason
+                     (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)
+                       2 (vcat (text "Ignoring all but the first"
+                                : map pp_inl (inl1:inl2:inls))))
+
+    pp_inl (L loc prag) = ppr prag <+> parens (ppr loc)
+
+
+{- *********************************************************************
+*                                                                      *
+                   SPECIALISE pragmas
+*                                                                      *
+************************************************************************
+
+Note [Handling SPECIALISE pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The basic idea is this:
+
+   foo :: Num a => a -> b -> a
+   {-# SPECIALISE foo :: Int -> b -> Int #-}
+
+We check that
+   (forall a b. Num a => a -> b -> a)
+      is more polymorphic than
+   forall b. Int -> b -> Int
+(for which we could use tcSubType, but see below), generating a HsWrapper
+to connect the two, something like
+      wrap = /\b. <hole> Int b dNumInt
+This wrapper is put in the TcSpecPrag, in the ABExport record of
+the AbsBinds.
+
+
+        f :: (Eq a, Ix b) => a -> b -> Bool
+        {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
+        f = <poly_rhs>
+
+From this the typechecker generates
+
+    AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
+
+    SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
+                      -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
+
+From these we generate:
+
+    Rule:       forall p, q, (dp:Ix p), (dq:Ix q).
+                    f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
+
+    Spec bind:  f_spec = wrap_fn <poly_rhs>
+
+Note that
+
+  * The LHS of the rule may mention dictionary *expressions* (eg
+    $dfIxPair dp dq), and that is essential because the dp, dq are
+    needed on the RHS.
+
+  * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
+    can fully specialise it.
+
+
+
+From the TcSpecPrag, in DsBinds we generate a binding for f_spec and a RULE:
+
+   f_spec :: Int -> b -> Int
+   f_spec = wrap<f rhs>
+
+   RULE: forall b (d:Num b). f b d = f_spec b
+
+The RULE is generated by taking apart the HsWrapper, which is a little
+delicate, but works.
+
+Some wrinkles
+
+1. We don't use full-on tcSubType, because that does co and contra
+   variance and that in turn will generate too complex a LHS for the
+   RULE.  So we use a single invocation of skolemise /
+   topInstantiate in tcSpecWrapper.  (Actually I think that even
+   the "deeply" stuff may be too much, because it introduces lambdas,
+   though I think it can be made to work without too much trouble.)
+
+2. We need to take care with type families (Trac #5821).  Consider
+      type instance F Int = Bool
+      f :: Num a => a -> F a
+      {-# SPECIALISE foo :: Int -> Bool #-}
+
+  We *could* try to generate an f_spec with precisely the declared type:
+      f_spec :: Int -> Bool
+      f_spec = <f rhs> Int dNumInt |> co
+
+      RULE: forall d. f Int d = f_spec |> sym co
+
+  but the 'co' and 'sym co' are (a) playing no useful role, and (b) are
+  hard to generate.  At all costs we must avoid this:
+      RULE: forall d. f Int d |> co = f_spec
+  because the LHS will never match (indeed it's rejected in
+  decomposeRuleLhs).
+
+  So we simply do this:
+    - Generate a constraint to check that the specialised type (after
+      skolemiseation) is equal to the instantiated function type.
+    - But *discard* the evidence (coercion) for that constraint,
+      so that we ultimately generate the simpler code
+          f_spec :: Int -> F Int
+          f_spec = <f rhs> Int dNumInt
+
+          RULE: forall d. f Int d = f_spec
+      You can see this discarding happening in
+
+3. Note that the HsWrapper can transform *any* function with the right
+   type prefix
+       forall ab. (Eq a, Ix b) => XXX
+   regardless of XXX.  It's sort of polymorphic in XXX.  This is
+   useful: we use the same wrapper to transform each of the class ops, as
+   well as the dict.  That's what goes on in TcInstDcls.mk_meth_spec_prags
+-}
+
+tcSpecPrags :: Id -> [LSig GhcRn]
+            -> TcM [LTcSpecPrag]
+-- Add INLINE and SPECIALSE pragmas
+--    INLINE prags are added to the (polymorphic) Id directly
+--    SPECIALISE prags are passed to the desugarer via TcSpecPrags
+-- Pre-condition: the poly_id is zonked
+-- Reason: required by tcSubExp
+tcSpecPrags poly_id prag_sigs
+  = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)
+       ; unless (null bad_sigs) warn_discarded_sigs
+       ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs
+       ; return $ concatMap (\(L l ps) -> map (L l) ps) pss }
+  where
+    spec_sigs = filter isSpecLSig prag_sigs
+    bad_sigs  = filter is_bad_sig prag_sigs
+    is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s)
+
+    warn_discarded_sigs
+      = addWarnTc NoReason
+                  (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)
+                      2 (vcat (map (ppr . getLoc) bad_sigs)))
+
+--------------
+tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]
+tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)
+-- See Note [Handling SPECIALISE pragmas]
+--
+-- The Name fun_name in the SpecSig may not be the same as that of the poly_id
+-- Example: SPECIALISE for a class method: the Name in the SpecSig is
+--          for the selector Id, but the poly_id is something like $cop
+-- However we want to use fun_name in the error message, since that is
+-- what the user wrote (Trac #8537)
+  = addErrCtxt (spec_ctxt prag) $
+    do  { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))
+                 (text "SPECIALISE pragma for non-overloaded function"
+                  <+> quotes (ppr fun_name))
+                  -- Note [SPECIALISE pragmas]
+        ; spec_prags <- mapM tc_one hs_tys
+        ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags)))
+        ; return spec_prags }
+  where
+    name      = idName poly_id
+    poly_ty   = idType poly_id
+    spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)
+
+    tc_one hs_ty
+      = do { spec_ty <- tcHsSigType   (FunSigCtxt name False) hs_ty
+           ; wrap    <- tcSpecWrapper (FunSigCtxt name True)  poly_ty spec_ty
+           ; return (SpecPrag poly_id wrap inl) }
+
+tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
+
+--------------
+tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper
+-- A simpler variant of tcSubType, used for SPECIALISE pragmas
+-- See Note [Handling SPECIALISE pragmas], wrinkle 1
+tcSpecWrapper ctxt poly_ty spec_ty
+  = do { (sk_wrap, inst_wrap)
+               <- tcSkolemise ctxt spec_ty $ \ _ spec_tau ->
+                  do { (inst_wrap, tau) <- topInstantiate orig poly_ty
+                     ; _ <- unifyType Nothing spec_tau tau
+                            -- Deliberately ignore the evidence
+                            -- See Note [Handling SPECIALISE pragmas],
+                            --   wrinkle (2)
+                     ; return inst_wrap }
+       ; return (sk_wrap <.> inst_wrap) }
+  where
+    orig = SpecPragOrigin ctxt
+
+--------------
+tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag]
+-- SPECIALISE pragmas for imported things
+tcImpPrags prags
+  = do { this_mod <- getModule
+       ; dflags <- getDynFlags
+       ; if (not_specialising dflags) then
+            return []
+         else do
+            { pss <- mapAndRecoverM (wrapLocM tcImpSpec)
+                     [L loc (name,prag)
+                             | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags
+                             , not (nameIsLocalOrFrom this_mod name) ]
+            ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }
+  where
+    -- Ignore SPECIALISE pragmas for imported things
+    -- when we aren't specialising, or when we aren't generating
+    -- code.  The latter happens when Haddocking the base library;
+    -- we don't want complaints about lack of INLINABLE pragmas
+    not_specialising dflags
+      | not (gopt Opt_Specialise dflags) = True
+      | otherwise = case hscTarget dflags of
+                      HscNothing -> True
+                      HscInterpreted -> True
+                      _other         -> False
+
+tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]
+tcImpSpec (name, prag)
+ = do { id <- tcLookupId name
+      ; unless (isAnyInlinePragma (idInlinePragma id))
+               (addWarnTc NoReason (impSpecErr name))
+      ; tcSpecPrag id prag }
+
+impSpecErr :: Name -> SDoc
+impSpecErr name
+  = hang (text "You cannot SPECIALISE" <+> quotes (ppr name))
+       2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma"
+               , parens $ sep
+                   [ text "or its defining module" <+> quotes (ppr mod)
+                   , text "was compiled without -O"]])
+  where
+    mod = nameModule name
diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcSimplify.hs
@@ -0,0 +1,2646 @@
+{-# LANGUAGE CPP #-}
+
+module TcSimplify(
+       simplifyInfer, InferMode(..),
+       growThetaTyVars,
+       simplifyAmbiguityCheck,
+       simplifyDefault,
+       simplifyTop, simplifyTopImplic,
+       simplifyInteractive,
+       solveEqualities, solveLocalEqualities, solveLocalEqualitiesX,
+       simplifyWantedsTcM,
+       tcCheckSatisfiability,
+       tcNormalise,
+
+       captureTopConstraints,
+
+       simpl_top,
+
+       promoteTyVar,
+       promoteTyVarSet,
+
+       -- For Rules we need these
+       solveWanteds, solveWantedsAndDrop,
+       approximateWC, runTcSDeriveds
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Bag
+import Class         ( Class, classKey, classTyCon )
+import DynFlags      ( WarningFlag ( Opt_WarnMonomorphism )
+                     , WarnReason ( Reason )
+                     , DynFlags( solverIterations ) )
+import HsExpr        ( UnboundVar(..) )
+import Id            ( idType, mkLocalId )
+import Inst
+import ListSetOps
+import Name
+import Outputable
+import PrelInfo
+import PrelNames
+import RdrName       ( emptyGlobalRdrEnv )
+import TcErrors
+import TcEvidence
+import TcInteract
+import TcCanonical   ( makeSuperClasses, solveCallStack )
+import TcMType   as TcM
+import TcRnMonad as TcM
+import TcSMonad  as TcS
+import TcType
+import TrieMap       () -- DV: for now
+import Type
+import TysWiredIn    ( liftedRepTy )
+import Unify         ( tcMatchTyKi )
+import Util
+import Var
+import VarSet
+import UniqSet
+import BasicTypes    ( IntWithInf, intGtLimit )
+import ErrUtils      ( emptyMessages )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Data.Foldable      ( toList )
+import Data.List          ( partition )
+import Data.List.NonEmpty ( NonEmpty(..) )
+import Maybes             ( isJust )
+
+{-
+*********************************************************************************
+*                                                                               *
+*                           External interface                                  *
+*                                                                               *
+*********************************************************************************
+-}
+
+captureTopConstraints :: TcM a -> TcM (a, WantedConstraints)
+-- (captureTopConstraints m) runs m, and returns the type constraints it
+-- generates plus the constraints produced by static forms inside.
+-- If it fails with an exception, it reports any insolubles
+-- (out of scope variables) before doing so
+-- NB: bring any environments into scope before calling this, so that
+-- the reportUnsolved has access to the most complete GlobalRdrEnv
+captureTopConstraints thing_inside
+  = do { static_wc_var <- TcM.newTcRef emptyWC ;
+       ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $
+                          TcM.tryCaptureConstraints thing_inside
+       ; stWC <- TcM.readTcRef static_wc_var
+
+       -- See TcRnMonad Note [Constraints and errors]
+       -- If the thing_inside threw an exception, but generated some insoluble
+       -- constraints, report the latter before propagating the exception
+       -- Otherwise they will be lost altogether
+       ; case mb_res of
+           Right res -> return (res, lie `andWC` stWC)
+           Left {}   -> do { _ <- reportUnsolved lie; failM } }
+                -- This call to reportUnsolved is the reason
+                -- this function is here instead of TcRnMonad
+
+simplifyTopImplic :: Bag Implication -> TcM ()
+simplifyTopImplic implics
+  = do { empty_binds <- simplifyTop (mkImplicWC implics)
+
+       -- Since all the inputs are implications the returned bindings will be empty
+       ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )
+
+       ; return () }
+
+simplifyTop :: WantedConstraints -> TcM (Bag EvBind)
+-- Simplify top-level constraints
+-- Usually these will be implications,
+-- but when there is nothing to quantify we don't wrap
+-- in a degenerate implication, so we do that here instead
+simplifyTop wanteds
+  = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds
+       ; ((final_wc, unsafe_ol), binds1) <- runTcS $
+            do { final_wc <- simpl_top wanteds
+               ; unsafe_ol <- getSafeOverlapFailures
+               ; return (final_wc, unsafe_ol) }
+       ; traceTc "End simplifyTop }" empty
+
+       ; binds2 <- reportUnsolved final_wc
+
+       ; traceTc "reportUnsolved (unsafe overlapping) {" empty
+       ; unless (isEmptyCts unsafe_ol) $ do {
+           -- grab current error messages and clear, warnAllUnsolved will
+           -- update error messages which we'll grab and then restore saved
+           -- messages.
+           ; errs_var  <- getErrsVar
+           ; saved_msg <- TcM.readTcRef errs_var
+           ; TcM.writeTcRef errs_var emptyMessages
+
+           ; warnAllUnsolved $ WC { wc_simple = unsafe_ol
+                                  , wc_impl = emptyBag }
+
+           ; whyUnsafe <- fst <$> TcM.readTcRef errs_var
+           ; TcM.writeTcRef errs_var saved_msg
+           ; recordUnsafeInfer whyUnsafe
+           }
+       ; traceTc "reportUnsolved (unsafe overlapping) }" empty
+
+       ; return (evBindMapBinds binds1 `unionBags` binds2) }
+
+
+-- | Type-check a thing that emits only equality constraints, solving any
+-- constraints we can and re-emitting constraints that we can't. The thing_inside
+-- should generally bump the TcLevel to make sure that this run of the solver
+-- doesn't affect anything lying around.
+solveLocalEqualities :: String -> TcM a -> TcM a
+solveLocalEqualities callsite thing_inside
+  = do { (wanted, res) <- solveLocalEqualitiesX callsite thing_inside
+       ; emitConstraints wanted
+       ; return res }
+
+solveLocalEqualitiesX :: String -> TcM a -> TcM (WantedConstraints, a)
+solveLocalEqualitiesX callsite thing_inside
+  = do { traceTc "solveLocalEqualitiesX {" (vcat [ text "Called from" <+> text callsite ])
+
+       ; (result, wanted) <- captureConstraints thing_inside
+
+       ; traceTc "solveLocalEqualities: running solver" (ppr wanted)
+       ; residual_wanted <- runTcSEqualities (solveWanteds wanted)
+
+       ; traceTc "solveLocalEqualitiesX end }" $
+         text "residual_wanted =" <+> ppr residual_wanted
+
+       ; return (residual_wanted, result) }
+
+-- | Type-check a thing that emits only equality constraints, then
+-- solve those constraints. Fails outright if there is trouble.
+-- Use this if you're not going to get another crack at solving
+-- (because, e.g., you're checking a datatype declaration)
+solveEqualities :: TcM a -> TcM a
+solveEqualities thing_inside
+  = checkNoErrs $  -- See Note [Fail fast on kind errors]
+    do { lvl <- TcM.getTcLevel
+       ; traceTc "solveEqualities {" (text "level =" <+> ppr lvl)
+
+       ; (result, wanted) <- captureConstraints thing_inside
+
+       ; traceTc "solveEqualities: running solver" $ text "wanted = " <+> ppr wanted
+       ; final_wc <- runTcSEqualities $ simpl_top wanted
+          -- NB: Use simpl_top here so that we potentially default RuntimeRep
+          -- vars to LiftedRep. This is needed to avoid #14991.
+
+       ; traceTc "End solveEqualities }" empty
+       ; reportAllUnsolved final_wc
+       ; return result }
+
+-- | Simplify top-level constraints, but without reporting any unsolved
+-- constraints nor unsafe overlapping.
+simpl_top :: WantedConstraints -> TcS WantedConstraints
+    -- See Note [Top-level Defaulting Plan]
+simpl_top wanteds
+  = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds)
+                            -- This is where the main work happens
+       ; try_tyvar_defaulting wc_first_go }
+  where
+    try_tyvar_defaulting :: WantedConstraints -> TcS WantedConstraints
+    try_tyvar_defaulting wc
+      | isEmptyWC wc
+      = return wc
+      | otherwise
+      = do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)
+           ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs
+                   -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked
+                   -- filter isMetaTyVar: we might have runtime-skolems in GHCi,
+                   -- and we definitely don't want to try to assign to those!
+                   -- The isTyVar is needed to weed out coercion variables
+
+           ; defaulted <- mapM defaultTyVarTcS meta_tvs   -- Has unification side effects
+           ; if or defaulted
+             then do { wc_residual <- nestTcS (solveWanteds wc)
+                            -- See Note [Must simplify after defaulting]
+                     ; try_class_defaulting wc_residual }
+             else try_class_defaulting wc }     -- No defaulting took place
+
+    try_class_defaulting :: WantedConstraints -> TcS WantedConstraints
+    try_class_defaulting wc
+      | isEmptyWC wc
+      = return wc
+      | otherwise  -- See Note [When to do type-class defaulting]
+      = do { something_happened <- applyDefaultingRules wc
+                                   -- See Note [Top-level Defaulting Plan]
+           ; if something_happened
+             then do { wc_residual <- nestTcS (solveWantedsAndDrop wc)
+                     ; try_class_defaulting wc_residual }
+                  -- See Note [Overview of implicit CallStacks] in TcEvidence
+             else try_callstack_defaulting wc }
+
+    try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints
+    try_callstack_defaulting wc
+      | isEmptyWC wc
+      = return wc
+      | otherwise
+      = defaultCallStacks wc
+
+-- | Default any remaining @CallStack@ constraints to empty @CallStack@s.
+defaultCallStacks :: WantedConstraints -> TcS WantedConstraints
+-- See Note [Overview of implicit CallStacks] in TcEvidence
+defaultCallStacks wanteds
+  = do simples <- handle_simples (wc_simple wanteds)
+       mb_implics <- mapBagM handle_implic (wc_impl wanteds)
+       return (wanteds { wc_simple = simples
+                       , wc_impl = catBagMaybes mb_implics })
+
+  where
+
+  handle_simples simples
+    = catBagMaybes <$> mapBagM defaultCallStack simples
+
+  handle_implic :: Implication -> TcS (Maybe Implication)
+  -- The Maybe is because solving the CallStack constraint
+  -- may well allow us to discard the implication entirely
+  handle_implic implic
+    | isSolvedStatus (ic_status implic)
+    = return (Just implic)
+    | otherwise
+    = do { wanteds <- setEvBindsTcS (ic_binds implic) $
+                      -- defaultCallStack sets a binding, so
+                      -- we must set the correct binding group
+                      defaultCallStacks (ic_wanted implic)
+         ; setImplicationStatus (implic { ic_wanted = wanteds }) }
+
+  defaultCallStack ct
+    | ClassPred cls tys <- classifyPredType (ctPred ct)
+    , Just {} <- isCallStackPred cls tys
+    = do { solveCallStack (ctEvidence ct) EvCsEmpty
+         ; return Nothing }
+
+  defaultCallStack ct
+    = return (Just ct)
+
+
+{- Note [Fail fast on kind errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+solveEqualities is used to solve kind equalities when kind-checking
+user-written types. If solving fails we should fail outright, rather
+than just accumulate an error message, for two reasons:
+
+  * A kind-bogus type signature may cause a cascade of knock-on
+    errors if we let it pass
+
+  * More seriously, we don't have a convenient term-level place to add
+    deferred bindings for unsolved kind-equality constraints, so we
+    don't build evidence bindings (by usine reportAllUnsolved). That
+    means that we'll be left with with a type that has coercion holes
+    in it, something like
+           <type> |> co-hole
+    where co-hole is not filled in.  Eeek!  That un-filled-in
+    hole actually causes GHC to crash with "fvProv falls into a hole"
+    See Trac #11563, #11520, #11516, #11399
+
+So it's important to use 'checkNoErrs' here!
+
+Note [When to do type-class defaulting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC
+was false, on the grounds that defaulting can't help solve insoluble
+constraints.  But if we *don't* do defaulting we may report a whole
+lot of errors that would be solved by defaulting; these errors are
+quite spurious because fixing the single insoluble error means that
+defaulting happens again, which makes all the other errors go away.
+This is jolly confusing: Trac #9033.
+
+So it seems better to always do type-class defaulting.
+
+However, always doing defaulting does mean that we'll do it in
+situations like this (Trac #5934):
+   run :: (forall s. GenST s) -> Int
+   run = fromInteger 0
+We don't unify the return type of fromInteger with the given function
+type, because the latter involves foralls.  So we're left with
+    (Num alpha, alpha ~ (forall s. GenST s) -> Int)
+Now we do defaulting, get alpha := Integer, and report that we can't
+match Integer with (forall s. GenST s) -> Int.  That's not totally
+stupid, but perhaps a little strange.
+
+Another potential alternative would be to suppress *all* non-insoluble
+errors if there are *any* insoluble errors, anywhere, but that seems
+too drastic.
+
+Note [Must simplify after defaulting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We may have a deeply buried constraint
+    (t:*) ~ (a:Open)
+which we couldn't solve because of the kind incompatibility, and 'a' is free.
+Then when we default 'a' we can solve the constraint.  And we want to do
+that before starting in on type classes.  We MUST do it before reporting
+errors, because it isn't an error!  Trac #7967 was due to this.
+
+Note [Top-level Defaulting Plan]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We have considered two design choices for where/when to apply defaulting.
+   (i) Do it in SimplCheck mode only /whenever/ you try to solve some
+       simple constraints, maybe deep inside the context of implications.
+       This used to be the case in GHC 7.4.1.
+   (ii) Do it in a tight loop at simplifyTop, once all other constraints have
+        finished. This is the current story.
+
+Option (i) had many disadvantages:
+   a) Firstly, it was deep inside the actual solver.
+   b) Secondly, it was dependent on the context (Infer a type signature,
+      or Check a type signature, or Interactive) since we did not want
+      to always start defaulting when inferring (though there is an exception to
+      this, see Note [Default while Inferring]).
+   c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs:
+          f :: Int -> Bool
+          f x = const True (\y -> let w :: a -> a
+                                      w a = const a (y+1)
+                                  in w y)
+      We will get an implication constraint (for beta the type of y):
+               [untch=beta] forall a. 0 => Num beta
+      which we really cannot default /while solving/ the implication, since beta is
+      untouchable.
+
+Instead our new defaulting story is to pull defaulting out of the solver loop and
+go with option (ii), implemented at SimplifyTop. Namely:
+     - First, have a go at solving the residual constraint of the whole
+       program
+     - Try to approximate it with a simple constraint
+     - Figure out derived defaulting equations for that simple constraint
+     - Go round the loop again if you did manage to get some equations
+
+Now, that has to do with class defaulting. However there exists type variable /kind/
+defaulting. Again this is done at the top-level and the plan is:
+     - At the top-level, once you had a go at solving the constraint, do
+       figure out /all/ the touchable unification variables of the wanted constraints.
+     - Apply defaulting to their kinds
+
+More details in Note [DefaultTyVar].
+
+Note [Safe Haskell Overlapping Instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In Safe Haskell, we apply an extra restriction to overlapping instances. The
+motive is to prevent untrusted code provided by a third-party, changing the
+behavior of trusted code through type-classes. This is due to the global and
+implicit nature of type-classes that can hide the source of the dictionary.
+
+Another way to state this is: if a module M compiles without importing another
+module N, changing M to import N shouldn't change the behavior of M.
+
+Overlapping instances with type-classes can violate this principle. However,
+overlapping instances aren't always unsafe. They are just unsafe when the most
+selected dictionary comes from untrusted code (code compiled with -XSafe) and
+overlaps instances provided by other modules.
+
+In particular, in Safe Haskell at a call site with overlapping instances, we
+apply the following rule to determine if it is a 'unsafe' overlap:
+
+ 1) Most specific instance, I1, defined in an `-XSafe` compiled module.
+ 2) I1 is an orphan instance or a MPTC.
+ 3) At least one overlapped instance, Ix, is both:
+    A) from a different module than I1
+    B) Ix is not marked `OVERLAPPABLE`
+
+This is a slightly involved heuristic, but captures the situation of an
+imported module N changing the behavior of existing code. For example, if
+condition (2) isn't violated, then the module author M must depend either on a
+type-class or type defined in N.
+
+Secondly, when should these heuristics be enforced? We enforced them when the
+type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`.
+This allows `-XUnsafe` modules to operate without restriction, and for Safe
+Haskell inferrence to infer modules with unsafe overlaps as unsafe.
+
+One alternative design would be to also consider if an instance was imported as
+a `safe` import or not and only apply the restriction to instances imported
+safely. However, since instances are global and can be imported through more
+than one path, this alternative doesn't work.
+
+Note [Safe Haskell Overlapping Instances Implementation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+How is this implemented? It's complicated! So we'll step through it all:
+
+ 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where
+    we check if a particular type-class method call is safe or unsafe. We do this
+    through the return type, `ClsInstLookupResult`, where the last parameter is a
+    list of instances that are unsafe to overlap. When the method call is safe,
+    the list is null.
+
+ 2) `TcInteract.matchClassInst` -- This module drives the instance resolution
+    / dictionary generation. The return type is `ClsInstResult`, which either
+    says no instance matched, or one found, and if it was a safe or unsafe
+    overlap.
+
+ 3) `TcInteract.doTopReactDict` -- Takes a dictionary / class constraint and
+     tries to resolve it by calling (in part) `matchClassInst`. The resolving
+     mechanism has a work list (of constraints) that it process one at a time. If
+     the constraint can't be resolved, it's added to an inert set. When compiling
+     an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know
+     compilation should fail. These are handled as normal constraint resolution
+     failures from here-on (see step 6).
+
+     Otherwise, we may be inferring safety (or using `-Wunsafe`), and
+     compilation should succeed, but print warnings and/or mark the compiled module
+     as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds
+     the unsafe (but resolved!) constraint to the `inert_safehask` field of
+     `InertCans`.
+
+ 4) `TcSimplify.simplifyTop`:
+       * Call simpl_top, the top-level function for driving the simplifier for
+         constraint resolution.
+
+       * Once finished, call `getSafeOverlapFailures` to retrieve the
+         list of overlapping instances that were successfully resolved,
+         but unsafe. Remember, this is only applicable for generating warnings
+         (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy`
+         cause compilation failure by not resolving the unsafe constraint at all.
+
+       * For unresolved constraints (all types), call `TcErrors.reportUnsolved`,
+         while for resolved but unsafe overlapping dictionary constraints, call
+         `TcErrors.warnAllUnsolved`. Both functions convert constraints into a
+         warning message for the user.
+
+       * In the case of `warnAllUnsolved` for resolved, but unsafe
+         dictionary constraints, we collect the generated warning
+         message (pop it) and call `TcRnMonad.recordUnsafeInfer` to
+         mark the module we are compiling as unsafe, passing the
+         warning message along as the reason.
+
+ 5) `TcErrors.*Unsolved` -- Generates error messages for constraints by
+    actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we
+    know is the constraint that is unresolved or unsafe. For dictionary, all we
+    know is that we need a dictionary of type C, but not what instances are
+    available and how they overlap. So we once again call `lookupInstEnv` to
+    figure that out so we can generate a helpful error message.
+
+ 6) `TcRnMonad.recordUnsafeInfer` -- Save the unsafe result and reason in an
+      IORef called `tcg_safeInfer`.
+
+ 7) `HscMain.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling
+    `HscMain.markUnsafeInfer` (passing the reason along) when safe-inferrence
+    failed.
+
+Note [No defaulting in the ambiguity check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When simplifying constraints for the ambiguity check, we use
+solveWantedsAndDrop, not simpl_top, so that we do no defaulting.
+Trac #11947 was an example:
+   f :: Num a => Int -> Int
+This is ambiguous of course, but we don't want to default the
+(Num alpha) constraint to (Num Int)!  Doing so gives a defaulting
+warning, but no error.
+-}
+
+------------------
+simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM ()
+simplifyAmbiguityCheck ty wanteds
+  = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds)
+       ; (final_wc, _) <- runTcS $ solveWantedsAndDrop wanteds
+             -- NB: no defaulting!  See Note [No defaulting in the ambiguity check]
+
+       ; traceTc "End simplifyAmbiguityCheck }" empty
+
+       -- Normally report all errors; but with -XAllowAmbiguousTypes
+       -- report only insoluble ones, since they represent genuinely
+       -- inaccessible code
+       ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes
+       ; traceTc "reportUnsolved(ambig) {" empty
+       ; unless (allow_ambiguous && not (insolubleWC final_wc))
+                (discardResult (reportUnsolved final_wc))
+       ; traceTc "reportUnsolved(ambig) }" empty
+
+       ; return () }
+
+------------------
+simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)
+simplifyInteractive wanteds
+  = traceTc "simplifyInteractive" empty >>
+    simplifyTop wanteds
+
+------------------
+simplifyDefault :: ThetaType    -- Wanted; has no type variables in it
+                -> TcM ()       -- Succeeds if the constraint is soluble
+simplifyDefault theta
+  = do { traceTc "simplifyDefault" empty
+       ; wanteds  <- newWanteds DefaultOrigin theta
+       ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds))
+       ; reportAllUnsolved unsolved
+       ; return () }
+
+------------------
+tcCheckSatisfiability :: Bag EvVar -> TcM Bool
+-- Return True if satisfiable, False if definitely contradictory
+tcCheckSatisfiability given_ids
+  = do { lcl_env <- TcM.getLclEnv
+       ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env
+       ; (res, _ev_binds) <- runTcS $
+             do { traceTcS "checkSatisfiability {" (ppr given_ids)
+                ; let given_cts = mkGivens given_loc (bagToList given_ids)
+                     -- See Note [Superclasses and satisfiability]
+                ; solveSimpleGivens given_cts
+                ; insols <- getInertInsols
+                ; insols <- try_harder insols
+                ; traceTcS "checkSatisfiability }" (ppr insols)
+                ; return (isEmptyBag insols) }
+       ; return res }
+ where
+    try_harder :: Cts -> TcS Cts
+    -- Maybe we have to search up the superclass chain to find
+    -- an unsatisfiable constraint.  Example: pmcheck/T3927b.
+    -- At the moment we try just once
+    try_harder insols
+      | not (isEmptyBag insols)   -- We've found that it's definitely unsatisfiable
+      = return insols             -- Hurrah -- stop now.
+      | otherwise
+      = do { pending_given <- getPendingGivenScs
+           ; new_given <- makeSuperClasses pending_given
+           ; solveSimpleGivens new_given
+           ; getInertInsols }
+
+-- | Normalise a type as much as possible using the given constraints.
+-- See @Note [tcNormalise]@.
+tcNormalise :: Bag EvVar -> Type -> TcM Type
+tcNormalise given_ids ty
+  = do { lcl_env <- TcM.getLclEnv
+       ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env
+       ; wanted_ct <- mk_wanted_ct
+       ; (res, _ev_binds) <- runTcS $
+             do { traceTcS "tcNormalise {" (ppr given_ids)
+                ; let given_cts = mkGivens given_loc (bagToList given_ids)
+                ; solveSimpleGivens given_cts
+                ; wcs <- solveSimpleWanteds (unitBag wanted_ct)
+                  -- It's an invariant that this wc_simple will always be
+                  -- a singleton Ct, since that's what we fed in as input.
+                ; let ty' = case bagToList (wc_simple wcs) of
+                              (ct:_) -> ctEvPred (ctEvidence ct)
+                              cts    -> pprPanic "tcNormalise" (ppr cts)
+                ; traceTcS "tcNormalise }" (ppr ty')
+                ; pure ty' }
+       ; return res }
+  where
+    mk_wanted_ct :: TcM Ct
+    mk_wanted_ct = do
+      let occ = mkVarOcc "$tcNorm"
+      name <- newSysName occ
+      let ev = mkLocalId name ty
+          hole = ExprHole $ OutOfScope occ emptyGlobalRdrEnv
+      newHoleCt hole ev ty
+
+{- Note [Superclasses and satisfiability]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Expand superclasses before starting, because (Int ~ Bool), has
+(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool)
+as a superclass, and it's the latter that is insoluble.  See
+Note [The equality types story] in TysPrim.
+
+If we fail to prove unsatisfiability we (arbitrarily) try just once to
+find superclasses, using try_harder.  Reason: we might have a type
+signature
+   f :: F op (Implements push) => ..
+where F is a type function.  This happened in Trac #3972.
+
+We could do more than once but we'd have to have /some/ limit: in the
+the recursive case, we would go on forever in the common case where
+the constraints /are/ satisfiable (Trac #10592 comment:12!).
+
+For stratightforard situations without type functions the try_harder
+step does nothing.
+
+Note [tcNormalise]
+~~~~~~~~~~~~~~~~~~
+tcNormalise is a rather atypical entrypoint to the constraint solver. Whereas
+most invocations of the constraint solver are intended to simplify a set of
+constraints or to decide if a particular set of constraints is satisfiable,
+the purpose of tcNormalise is to take a type, plus some local constraints, and
+normalise the type as much as possible with respect to those constraints.
+
+Why is this useful? As one example, when coverage-checking an EmptyCase
+expression, it's possible that the type of the scrutinee will only reduce
+if some local equalities are solved for. See "Wrinkle: Local equalities"
+in Note [Type normalisation for EmptyCase] in Check.
+
+To accomplish its stated goal, tcNormalise first feeds the local constraints
+into solveSimpleGivens, then stuffs the argument type in a CHoleCan, and feeds
+that singleton Ct into solveSimpleWanteds, which reduces the type in the
+CHoleCan as much as possible with respect to the local given constraints. When
+solveSimpleWanteds is finished, we dig out the type from the CHoleCan and
+return that.
+
+***********************************************************************************
+*                                                                                 *
+*                            Inference
+*                                                                                 *
+***********************************************************************************
+
+Note [Inferring the type of a let-bound variable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f x = rhs
+
+To infer f's type we do the following:
+ * Gather the constraints for the RHS with ambient level *one more than*
+   the current one.  This is done by the call
+        pushLevelAndCaptureConstraints (tcMonoBinds...)
+   in TcBinds.tcPolyInfer
+
+ * Call simplifyInfer to simplify the constraints and decide what to
+   quantify over. We pass in the level used for the RHS constraints,
+   here called rhs_tclvl.
+
+This ensures that the implication constraint we generate, if any,
+has a strictly-increased level compared to the ambient level outside
+the let binding.
+
+-}
+
+-- | How should we choose which constraints to quantify over?
+data InferMode = ApplyMR          -- ^ Apply the monomorphism restriction,
+                                  -- never quantifying over any constraints
+               | EagerDefaulting  -- ^ See Note [TcRnExprMode] in TcRnDriver,
+                                  -- the :type +d case; this mode refuses
+                                  -- to quantify over any defaultable constraint
+               | NoRestrictions   -- ^ Quantify over any constraint that
+                                  -- satisfies TcType.pickQuantifiablePreds
+
+instance Outputable InferMode where
+  ppr ApplyMR         = text "ApplyMR"
+  ppr EagerDefaulting = text "EagerDefaulting"
+  ppr NoRestrictions  = text "NoRestrictions"
+
+simplifyInfer :: TcLevel               -- Used when generating the constraints
+              -> InferMode
+              -> [TcIdSigInst]         -- Any signatures (possibly partial)
+              -> [(Name, TcTauType)]   -- Variables to be generalised,
+                                       -- and their tau-types
+              -> WantedConstraints
+              -> TcM ([TcTyVar],    -- Quantify over these type variables
+                      [EvVar],      -- ... and these constraints (fully zonked)
+                      TcEvBinds,    -- ... binding these evidence variables
+                      WantedConstraints, -- Redidual as-yet-unsolved constraints
+                      Bool)         -- True <=> the residual constraints are insoluble
+
+simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds
+  | isEmptyWC wanteds
+   = do { -- When quantifying, we want to preserve any order of variables as they
+          -- appear in partial signatures. cf. decideQuantifiedTyVars
+          let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs
+                                          , (_,tv) <- sig_inst_skols sig ]
+              psig_theta  = [ pred | sig <- partial_sigs
+                                   , pred <- sig_inst_theta sig ]
+
+       ; gbl_tvs <- tcGetGlobalTyCoVars
+       ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus)
+       ; qtkvs <- quantifyTyVars gbl_tvs dep_vars
+       ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)
+       ; return (qtkvs, [], emptyTcEvBinds, emptyWC, False) }
+
+  | otherwise
+  = do { traceTc "simplifyInfer {"  $ vcat
+             [ text "sigs =" <+> ppr sigs
+             , text "binds =" <+> ppr name_taus
+             , text "rhs_tclvl =" <+> ppr rhs_tclvl
+             , text "infer_mode =" <+> ppr infer_mode
+             , text "(unzonked) wanted =" <+> ppr wanteds
+             ]
+
+       ; let psig_theta = concatMap sig_inst_theta partial_sigs
+
+       -- First do full-blown solving
+       -- NB: we must gather up all the bindings from doing
+       -- this solving; hence (runTcSWithEvBinds ev_binds_var).
+       -- And note that since there are nested implications,
+       -- calling solveWanteds will side-effect their evidence
+       -- bindings, so we can't just revert to the input
+       -- constraint.
+
+       ; tc_env          <- TcM.getEnv
+       ; ev_binds_var    <- TcM.newTcEvBinds
+       ; psig_theta_vars <- mapM TcM.newEvVar psig_theta
+       ; wanted_transformed_incl_derivs
+            <- setTcLevel rhs_tclvl $
+               runTcSWithEvBinds ev_binds_var $
+               do { let loc         = mkGivenLoc rhs_tclvl UnkSkol $
+                                      env_lcl tc_env
+                        psig_givens = mkGivens loc psig_theta_vars
+                  ; _ <- solveSimpleGivens psig_givens
+                         -- See Note [Add signature contexts as givens]
+                  ; solveWanteds wanteds }
+
+       -- Find quant_pred_candidates, the predicates that
+       -- we'll consider quantifying over
+       -- NB1: wanted_transformed does not include anything provable from
+       --      the psig_theta; it's just the extra bit
+       -- NB2: We do not do any defaulting when inferring a type, this can lead
+       --      to less polymorphic types, see Note [Default while Inferring]
+       ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs
+       ; let definite_error = insolubleWC wanted_transformed_incl_derivs
+                              -- See Note [Quantification with errors]
+                              -- NB: must include derived errors in this test,
+                              --     hence "incl_derivs"
+             wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs
+             quant_pred_candidates
+               | definite_error = []
+               | otherwise      = ctsPreds (approximateWC False wanted_transformed)
+
+       -- Decide what type variables and constraints to quantify
+       -- NB: quant_pred_candidates is already fully zonked
+       -- NB: bound_theta are constraints we want to quantify over,
+       --     including the psig_theta, which we always quantify over
+       -- NB: bound_theta are fully zonked
+       ; (qtvs, bound_theta, co_vars) <- decideQuantification infer_mode rhs_tclvl
+                                                     name_taus partial_sigs
+                                                     quant_pred_candidates
+       ; bound_theta_vars <- mapM TcM.newEvVar bound_theta
+
+       -- We must produce bindings for the psig_theta_vars, because we may have
+       -- used them in evidence bindings constructed by solveWanteds earlier
+       -- Easiest way to do this is to emit them as new Wanteds (Trac #14643)
+       ; ct_loc <- getCtLocM AnnOrigin Nothing
+       ; let psig_wanted = [ CtWanted { ctev_pred = idType psig_theta_var
+                                      , ctev_dest = EvVarDest psig_theta_var
+                                      , ctev_nosh = WDeriv
+                                      , ctev_loc  = ct_loc }
+                           | psig_theta_var <- psig_theta_vars ]
+
+       -- Now construct the residual constraint
+       ; residual_wanted <- mkResidualConstraints rhs_tclvl tc_env ev_binds_var
+                                 name_taus co_vars qtvs bound_theta_vars
+                                 (wanted_transformed `andWC` mkSimpleWC psig_wanted)
+
+         -- All done!
+       ; traceTc "} simplifyInfer/produced residual implication for quantification" $
+         vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates
+              , text "psig_theta =" <+> ppr psig_theta
+              , text "bound_theta =" <+> ppr bound_theta
+              , text "qtvs ="       <+> ppr qtvs
+              , text "definite_error =" <+> ppr definite_error ]
+
+       ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var
+                , residual_wanted, definite_error ) }
+         -- NB: bound_theta_vars must be fully zonked
+  where
+    partial_sigs = filter isPartialSig sigs
+
+--------------------
+mkResidualConstraints :: TcLevel -> Env TcGblEnv TcLclEnv -> EvBindsVar
+                      -> [(Name, TcTauType)]
+                      -> VarSet -> [TcTyVar] -> [EvVar]
+                      -> WantedConstraints -> TcM WantedConstraints
+-- Emit the remaining constraints from the RHS.
+-- See Note [Emitting the residual implication in simplifyInfer]
+mkResidualConstraints rhs_tclvl tc_env ev_binds_var
+                        name_taus co_vars qtvs full_theta_vars wanteds
+  | isEmptyWC wanteds
+  = return wanteds
+
+  | otherwise
+  = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds)
+       ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple
+             is_mono ct = isWantedCt ct && ctEvId ct `elemVarSet` co_vars
+
+        ; _ <- promoteTyVarSet (tyCoVarsOfCts outer_simple)
+
+        ; let inner_wanted = wanteds { wc_simple = inner_simple }
+        ; return (WC { wc_simple = outer_simple
+                     , wc_impl   = mk_implic inner_wanted })}
+  where
+    mk_implic inner_wanted
+      | isEmptyWC inner_wanted
+      = emptyBag
+      | otherwise
+      = unitBag (implicationPrototype { ic_tclvl  = rhs_tclvl
+                                      , ic_skols  = qtvs
+                                      , ic_telescope = Nothing
+                                      , ic_given  = full_theta_vars
+                                      , ic_wanted = inner_wanted
+                                      , ic_binds  = ev_binds_var
+                                      , ic_no_eqs = False
+                                      , ic_info   = skol_info
+                                      , ic_env    = tc_env })
+
+    full_theta = map idType full_theta_vars
+    skol_info  = InferSkol [ (name, mkSigmaTy [] full_theta ty)
+                           | (name, ty) <- name_taus ]
+                 -- Don't add the quantified variables here, because
+                 -- they are also bound in ic_skols and we want them
+                 -- to be tidied uniformly
+
+--------------------
+ctsPreds :: Cts -> [PredType]
+ctsPreds cts = [ ctEvPred ev | ct <- bagToList cts
+                             , let ev = ctEvidence ct ]
+
+{- Note [Emitting the residual implication in simplifyInfer]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f = e
+where f's type is inferred to be something like (a, Proxy k (Int |> co))
+and we have an as-yet-unsolved, or perhaps insoluble, constraint
+   [W] co :: Type ~ k
+We can't form types like (forall co. blah), so we can't generalise over
+the coercion variable, and hence we can't generalise over things free in
+its kind, in the case 'k'.  But we can still generalise over 'a'.  So
+we'll generalise to
+   f :: forall a. (a, Proxy k (Int |> co))
+Now we do NOT want to form the residual implication constraint
+   forall a. [W] co :: Type ~ k
+because then co's eventual binding (which will be a value binding if we
+use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose
+type mentions 'co').  Instead, just as we don't generalise over 'co', we
+should not bury its constraint inside the implication.  Instead, we must
+put it outside.
+
+That is the reason for the partitionBag in emitResidualConstraints,
+which takes the CoVars free in the inferred type, and pulls their
+constraints out.  (NB: this set of CoVars should be closed-over-kinds.)
+
+All rather subtle; see Trac #14584.
+
+Note [Add signature contexts as givens]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (Trac #11016):
+  f2 :: (?x :: Int) => _
+  f2 = ?x
+or this
+  f3 :: a ~ Bool => (a, _)
+  f3 = (True, False)
+or theis
+  f4 :: (Ord a, _) => a -> Bool
+  f4 x = x==x
+
+We'll use plan InferGen because there are holes in the type.  But:
+ * For f2 we want to have the (?x :: Int) constraint floating around
+   so that the functional dependencies kick in.  Otherwise the
+   occurrence of ?x on the RHS produces constraint (?x :: alpha), and
+   we won't unify alpha:=Int.
+ * For f3 we want the (a ~ Bool) available to solve the wanted (a ~ Bool)
+   in the RHS
+ * For f4 we want to use the (Ord a) in the signature to solve the Eq a
+   constraint.
+
+Solution: in simplifyInfer, just before simplifying the constraints
+gathered from the RHS, add Given constraints for the context of any
+type signatures.
+
+************************************************************************
+*                                                                      *
+                Quantification
+*                                                                      *
+************************************************************************
+
+Note [Deciding quantification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the monomorphism restriction does not apply, then we quantify as follows:
+
+* Step 1. Take the global tyvars, and "grow" them using the equality
+  constraints
+     E.g.  if x:alpha is in the environment, and alpha ~ [beta] (which can
+          happen because alpha is untouchable here) then do not quantify over
+          beta, because alpha fixes beta, and beta is effectively free in
+          the environment too
+
+  We also account for the monomorphism restriction; if it applies,
+  add the free vars of all the constraints.
+
+  Result is mono_tvs; we will not quantify over these.
+
+* Step 2. Default any non-mono tyvars (i.e ones that are definitely
+  not going to become further constrained), and re-simplify the
+  candidate constraints.
+
+  Motivation for re-simplification (Trac #7857): imagine we have a
+  constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are
+  not free in the envt, and instance forall (a::*) (b::*). (C a) => C
+  (a -> b) The instance doesn't match while l1,l2 are polymorphic, but
+  it will match when we default them to LiftedRep.
+
+  This is all very tiresome.
+
+* Step 3: decide which variables to quantify over, as follows:
+
+  - Take the free vars of the tau-type (zonked_tau_tvs) and "grow"
+    them using all the constraints.  These are tau_tvs_plus
+
+  - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being
+    careful to close over kinds, and to skolemise the quantified tyvars.
+    (This actually unifies each quantifies meta-tyvar with a fresh skolem.)
+
+  Result is qtvs.
+
+* Step 4: Filter the constraints using pickQuantifiablePreds and the
+  qtvs. We have to zonk the constraints first, so they "see" the
+  freshly created skolems.
+
+-}
+
+decideQuantification
+  :: InferMode
+  -> TcLevel
+  -> [(Name, TcTauType)]   -- Variables to be generalised
+  -> [TcIdSigInst]         -- Partial type signatures (if any)
+  -> [PredType]            -- Candidate theta; already zonked
+  -> TcM ( [TcTyVar]       -- Quantify over these (skolems)
+         , [PredType]      -- and this context (fully zonked)
+         , VarSet)
+-- See Note [Deciding quantification]
+decideQuantification infer_mode rhs_tclvl name_taus psigs candidates
+  = do { -- Step 1: find the mono_tvs
+       ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars infer_mode
+                                              name_taus psigs candidates
+
+       -- Step 2: default any non-mono tyvars, and re-simplify
+       -- This step may do some unification, but result candidates is zonked
+       ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates
+
+       -- Step 3: decide which kind/type variables to quantify over
+       ; qtvs <- decideQuantifiedTyVars mono_tvs name_taus psigs candidates
+
+       -- Step 4: choose which of the remaining candidate
+       --         predicates to actually quantify over
+       -- NB: decideQuantifiedTyVars turned some meta tyvars
+       -- into quantified skolems, so we have to zonk again
+       ; candidates <- TcM.zonkTcTypes candidates
+       ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs)
+       ; let quantifiable_candidates
+               = pickQuantifiablePreds (mkVarSet qtvs) candidates
+             -- NB: do /not/ run pickQuantifiablePreds over psig_theta,
+             -- because we always want to quantify over psig_theta, and not
+             -- drop any of them; e.g. CallStack constraints.  c.f Trac #14658
+
+             theta = mkMinimalBySCs id $  -- See Note [Minimize by Superclasses]
+                     (psig_theta ++ quantifiable_candidates)
+
+       ; traceTc "decideQuantification"
+           (vcat [ text "infer_mode:" <+> ppr infer_mode
+                 , text "candidates:" <+> ppr candidates
+                 , text "psig_theta:" <+> ppr psig_theta
+                 , text "mono_tvs:"   <+> ppr mono_tvs
+                 , text "co_vars:"    <+> ppr co_vars
+                 , text "qtvs:"       <+> ppr qtvs
+                 , text "theta:"      <+> ppr theta ])
+       ; return (qtvs, theta, co_vars) }
+
+------------------
+decideMonoTyVars :: InferMode
+                 -> [(Name,TcType)]
+                 -> [TcIdSigInst]
+                 -> [PredType]
+                 -> TcM (TcTyCoVarSet, [PredType], CoVarSet)
+-- Decide which tyvars and covars cannot be generalised:
+--   (a) Free in the environment
+--   (b) Mentioned in a constraint we can't generalise
+--   (c) Connected by an equality to (a) or (b)
+-- Also return CoVars that appear free in the final quatified types
+--   we can't quantify over these, and we must make sure they are in scope
+decideMonoTyVars infer_mode name_taus psigs candidates
+  = do { (no_quant, maybe_quant) <- pick infer_mode candidates
+
+       -- If possible, we quantify over partial-sig qtvs, so they are
+       -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs
+       ; psig_qtvs <- mapM zonkTcTyVarToTyVar $
+                      concatMap (map snd . sig_inst_skols) psigs
+
+       ; psig_theta <- mapM TcM.zonkTcType $
+                       concatMap sig_inst_theta psigs
+
+       ; taus <- mapM (TcM.zonkTcType . snd) name_taus
+
+       ; mono_tvs0 <- tcGetGlobalTyCoVars
+       ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta
+
+             co_vars = coVarsOfTypes (psig_tys ++ taus)
+             co_var_tvs = closeOverKinds co_vars
+               -- The co_var_tvs are tvs mentioned in the types of covars or
+               -- coercion holes. We can't quantify over these covars, so we
+               -- must include the variable in their types in the mono_tvs.
+               -- E.g.  If we can't quantify over co :: k~Type, then we can't
+               --       quantify over k either!  Hence closeOverKinds
+
+             mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs
+
+             eq_constraints = filter isEqPred candidates
+             mono_tvs2      = growThetaTyVars eq_constraints mono_tvs1
+
+             constrained_tvs = (growThetaTyVars eq_constraints
+                                               (tyCoVarsOfTypes no_quant)
+                                `minusVarSet` mono_tvs2)
+                               `delVarSetList` psig_qtvs
+             -- constrained_tvs: the tyvars that we are not going to
+             -- quantify solely because of the moonomorphism restriction
+             --
+             -- (`minusVarSet` mono_tvs1`): a type variable is only
+             --   "constrained" (so that the MR bites) if it is not
+             --   free in the environment (Trac #13785)
+             --
+             -- (`delVarSetList` psig_qtvs): if the user has explicitly
+             --   asked for quantification, then that request "wins"
+             --   over the MR.  Note: do /not/ delete psig_qtvs from
+             --   mono_tvs1, because mono_tvs1 cannot under any circumstances
+             --   be quantified (Trac #14479); see
+             --   Note [Quantification and partial signatures], Wrinkle 3, 4
+
+             mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs
+
+           -- Warn about the monomorphism restriction
+       ; warn_mono <- woptM Opt_WarnMonomorphism
+       ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $
+         warnTc (Reason Opt_WarnMonomorphism)
+                (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus)
+                mr_msg
+
+       ; traceTc "decideMonoTyVars" $ vcat
+           [ text "mono_tvs0 =" <+> ppr mono_tvs0
+           , text "mono_tvs1 =" <+> ppr mono_tvs1
+           , text "no_quant =" <+> ppr no_quant
+           , text "maybe_quant =" <+> ppr maybe_quant
+           , text "eq_constraints =" <+> ppr eq_constraints
+           , text "mono_tvs =" <+> ppr mono_tvs
+           , text "co_vars =" <+> ppr co_vars ]
+
+       ; return (mono_tvs, maybe_quant, co_vars) }
+  where
+    pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType])
+    -- Split the candidates into ones we definitely
+    -- won't quantify, and ones that we might
+    pick NoRestrictions  cand = return ([], cand)
+    pick ApplyMR         cand = return (cand, [])
+    pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings
+                                   ; return (partition (is_int_ct os) cand) }
+
+    -- For EagerDefaulting, do not quantify over
+    -- over any interactive class constraint
+    is_int_ct ovl_strings pred
+      | Just (cls, _) <- getClassPredTys_maybe pred
+      = isInteractiveClass ovl_strings cls
+      | otherwise
+      = False
+
+    pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus
+    mr_msg =
+         hang (sep [ text "The Monomorphism Restriction applies to the binding"
+                     <> plural name_taus
+                   , text "for" <+> pp_bndrs ])
+            2 (hsep [ text "Consider giving"
+                    , text (if isSingleton name_taus then "it" else "them")
+                    , text "a type signature"])
+
+-------------------
+defaultTyVarsAndSimplify :: TcLevel
+                         -> TyCoVarSet
+                         -> [PredType]          -- Assumed zonked
+                         -> TcM [PredType]      -- Guaranteed zonked
+-- Default any tyvar free in the constraints,
+-- and re-simplify in case the defaulting allows further simplification
+defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates
+  = do {  -- Promote any tyvars that we cannot generalise
+          -- See Note [Promote momomorphic tyvars]
+       ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs)
+       ; (prom, _) <- promoteTyVarSet mono_tvs
+
+       -- Default any kind/levity vars
+       ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}
+                <- candidateQTyVarsOfTypes candidates
+                -- any covars should already be handled by
+                -- the logic in decideMonoTyVars, which looks at
+                -- the constraints generated
+
+       ; poly_kinds  <- xoptM LangExt.PolyKinds
+       ; default_kvs <- mapM (default_one poly_kinds True)
+                             (dVarSetElems cand_kvs)
+       ; default_tvs <- mapM (default_one poly_kinds False)
+                             (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs))
+       ; let some_default = or default_kvs || or default_tvs
+
+       ; case () of
+           _ | some_default -> simplify_cand candidates
+             | prom         -> mapM TcM.zonkTcType candidates
+             | otherwise    -> return candidates
+       }
+  where
+    default_one poly_kinds is_kind_var tv
+      | not (isMetaTyVar tv)
+      = return False
+      | tv `elemVarSet` mono_tvs
+      = return False
+      | otherwise
+      = defaultTyVar (not poly_kinds && is_kind_var) tv
+
+    simplify_cand candidates
+      = do { clone_wanteds <- newWanteds DefaultOrigin candidates
+           ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $
+                                           simplifyWantedsTcM clone_wanteds
+              -- Discard evidence; simples is fully zonked
+
+           ; let new_candidates = ctsPreds simples
+           ; traceTc "Simplified after defaulting" $
+                      vcat [ text "Before:" <+> ppr candidates
+                           , text "After:"  <+> ppr new_candidates ]
+           ; return new_candidates }
+
+------------------
+decideQuantifiedTyVars
+   :: TyCoVarSet        -- Monomorphic tyvars
+   -> [(Name,TcType)]   -- Annotated theta and (name,tau) pairs
+   -> [TcIdSigInst]     -- Partial signatures
+   -> [PredType]        -- Candidates, zonked
+   -> TcM [TyVar]
+-- Fix what tyvars we are going to quantify over, and quantify them
+decideQuantifiedTyVars mono_tvs name_taus psigs candidates
+  = do {     -- Why psig_tys? We try to quantify over everything free in here
+             -- See Note [Quantification and partial signatures]
+             --     Wrinkles 2 and 3
+       ; psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs
+                                                  , (_,tv) <- sig_inst_skols sig ]
+       ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs
+                                                  , pred <- sig_inst_theta sig ]
+       ; tau_tys  <- mapM (TcM.zonkTcType . snd) name_taus
+       ; mono_tvs <- TcM.zonkTyCoVarsAndFV mono_tvs
+
+       ; let -- Try to quantify over variables free in these types
+             psig_tys = psig_tv_tys ++ psig_theta
+             seed_tys = psig_tys ++ tau_tys
+
+             -- Now "grow" those seeds to find ones reachable via 'candidates'
+             grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys)
+
+       -- Now we have to classify them into kind variables and type variables
+       -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars
+       --
+       -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces
+       -- them in that order, so that the final qtvs quantifies in the same
+       -- order as the partial signatures do (Trac #13524)
+       ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $
+                                                         psig_tys ++ candidates ++ tau_tys
+       ; let pick     = (`dVarSetIntersectVarSet` grown_tcvs)
+             dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs }
+
+       ; traceTc "decideQuantifiedTyVars" (vcat
+           [ text "candidates =" <+> ppr candidates
+           , text "tau_tys =" <+> ppr tau_tys
+           , text "seed_tys =" <+> ppr seed_tys
+           , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys)
+           , text "grown_tcvs =" <+> ppr grown_tcvs
+           , text "dvs =" <+> ppr dvs_plus])
+
+       ; quantifyTyVars mono_tvs dvs_plus }
+
+------------------
+growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet
+-- See Note [Growing the tau-tvs using constraints]
+growThetaTyVars theta tcvs
+  | null theta = tcvs
+  | otherwise  = transCloVarSet mk_next seed_tcvs
+  where
+    seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips
+    (ips, non_ips) = partition isIPPred theta
+                         -- See Note [Inheriting implicit parameters] in TcType
+
+    mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones
+    mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips
+    grow_one so_far pred tcvs
+       | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs
+       | otherwise                           = tcvs
+       where
+         pred_tcvs = tyCoVarsOfType pred
+
+
+{- Note [Promote momomorphic tyvars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Promote any type variables that are free in the environment.  Eg
+   f :: forall qtvs. bound_theta => zonked_tau
+The free vars of f's type become free in the envt, and hence will show
+up whenever 'f' is called.  They may currently at rhs_tclvl, but they
+had better be unifiable at the outer_tclvl!  Example: envt mentions
+alpha[1]
+           tau_ty = beta[2] -> beta[2]
+           constraints = alpha ~ [beta]
+we don't quantify over beta (since it is fixed by envt)
+so we must promote it!  The inferred type is just
+  f :: beta -> beta
+
+NB: promoteTyVar ignores coercion variables
+
+Note [Quantification and partial signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When choosing type variables to quantify, the basic plan is to
+quantify over all type variables that are
+ * free in the tau_tvs, and
+ * not forced to be monomorphic (mono_tvs),
+   for example by being free in the environment.
+
+However, in the case of a partial type signature, be doing inference
+*in the presence of a type signature*. For example:
+   f :: _ -> a
+   f x = ...
+or
+   g :: (Eq _a) => _b -> _b
+In both cases we use plan InferGen, and hence call simplifyInfer.  But
+those 'a' variables are skolems (actually TyVarTvs), and we should be
+sure to quantify over them.  This leads to several wrinkles:
+
+* Wrinkle 1.  In the case of a type error
+     f :: _ -> Maybe a
+     f x = True && x
+  The inferred type of 'f' is f :: Bool -> Bool, but there's a
+  left-over error of form (HoleCan (Maybe a ~ Bool)).  The error-reporting
+  machine expects to find a binding site for the skolem 'a', so we
+  add it to the quantified tyvars.
+
+* Wrinkle 2.  Consider the partial type signature
+     f :: (Eq _) => Int -> Int
+     f x = x
+  In normal cases that makes sense; e.g.
+     g :: Eq _a => _a -> _a
+     g x = x
+  where the signature makes the type less general than it could
+  be. But for 'f' we must therefore quantify over the user-annotated
+  constraints, to get
+     f :: forall a. Eq a => Int -> Int
+  (thereby correctly triggering an ambiguity error later).  If we don't
+  we'll end up with a strange open type
+     f :: Eq alpha => Int -> Int
+  which isn't ambiguous but is still very wrong.
+
+  Bottom line: Try to quantify over any variable free in psig_theta,
+  just like the tau-part of the type.
+
+* Wrinkle 3 (Trac #13482). Also consider
+    f :: forall a. _ => Int -> Int
+    f x = if (undefined :: a) == undefined then x else 0
+  Here we get an (Eq a) constraint, but it's not mentioned in the
+  psig_theta nor the type of 'f'.  But we still want to quantify
+  over 'a' even if the monomorphism restriction is on.
+
+* Wrinkle 4 (Trac #14479)
+    foo :: Num a => a -> a
+    foo xxx = g xxx
+      where
+        g :: forall b. Num b => _ -> b
+        g y = xxx + y
+
+  In the signature for 'g', we cannot quantify over 'b' because it turns out to
+  get unified with 'a', which is free in g's environment.  So we carefully
+  refrain from bogusly quantifying, in TcSimplify.decideMonoTyVars.  We
+  report the error later, in TcBinds.chooseInferredQuantifiers.
+
+Note [Growing the tau-tvs using constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(growThetaTyVars insts tvs) is the result of extending the set
+    of tyvars, tvs, using all conceivable links from pred
+
+E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e}
+Then growThetaTyVars preds tvs = {a,b,c}
+
+Notice that
+   growThetaTyVars is conservative       if v might be fixed by vs
+                                         => v `elem` grow(vs,C)
+
+Note [Quantification with errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we find that the RHS of the definition has some absolutely-insoluble
+constraints (including especially "variable not in scope"), we
+
+* Abandon all attempts to find a context to quantify over,
+  and instead make the function fully-polymorphic in whatever
+  type we have found
+
+* Return a flag from simplifyInfer, indicating that we found an
+  insoluble constraint.  This flag is used to suppress the ambiguity
+  check for the inferred type, which may well be bogus, and which
+  tends to obscure the real error.  This fix feels a bit clunky,
+  but I failed to come up with anything better.
+
+Reasons:
+    - Avoid downstream errors
+    - Do not perform an ambiguity test on a bogus type, which might well
+      fail spuriously, thereby obfuscating the original insoluble error.
+      Trac #14000 is an example
+
+I tried an alternative approach: simply failM, after emitting the
+residual implication constraint; the exception will be caught in
+TcBinds.tcPolyBinds, which gives all the binders in the group the type
+(forall a. a).  But that didn't work with -fdefer-type-errors, because
+the recovery from failM emits no code at all, so there is no function
+to run!   But -fdefer-type-errors aspires to produce a runnable program.
+
+NB that we must include *derived* errors in the check for insolubles.
+Example:
+    (a::*) ~ Int#
+We get an insoluble derived error *~#, and we don't want to discard
+it before doing the isInsolubleWC test!  (Trac #8262)
+
+Note [Default while Inferring]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Our current plan is that defaulting only happens at simplifyTop and
+not simplifyInfer.  This may lead to some insoluble deferred constraints.
+Example:
+
+instance D g => C g Int b
+
+constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha
+type inferred       = gamma -> gamma
+
+Now, if we try to default (alpha := Int) we will be able to refine the implication to
+  (forall b. 0 => C gamma Int b)
+which can then be simplified further to
+  (forall b. 0 => D gamma)
+Finally, we /can/ approximate this implication with (D gamma) and infer the quantified
+type:  forall g. D g => g -> g
+
+Instead what will currently happen is that we will get a quantified type
+(forall g. g -> g) and an implication:
+       forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha
+
+Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an
+unsolvable implication:
+       forall g. 0 => (forall b. 0 => D g)
+
+The concrete example would be:
+       h :: C g a s => g -> a -> ST s a
+       f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1)
+
+But it is quite tedious to do defaulting and resolve the implication constraints, and
+we have not observed code breaking because of the lack of defaulting in inference, so
+we don't do it for now.
+
+
+
+Note [Minimize by Superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we quantify over a constraint, in simplifyInfer we need to
+quantify over a constraint that is minimal in some sense: For
+instance, if the final wanted constraint is (Eq alpha, Ord alpha),
+we'd like to quantify over Ord alpha, because we can just get Eq alpha
+from superclass selection from Ord alpha. This minimization is what
+mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint
+to check the original wanted.
+
+
+Note [Avoid unnecessary constraint simplification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    -------- NB NB NB (Jun 12) -------------
+    This note not longer applies; see the notes with Trac #4361.
+    But I'm leaving it in here so we remember the issue.)
+    ----------------------------------------
+When inferring the type of a let-binding, with simplifyInfer,
+try to avoid unnecessarily simplifying class constraints.
+Doing so aids sharing, but it also helps with delicate
+situations like
+
+   instance C t => C [t] where ..
+
+   f :: C [t] => ....
+   f x = let g y = ...(constraint C [t])...
+         in ...
+When inferring a type for 'g', we don't want to apply the
+instance decl, because then we can't satisfy (C t).  So we
+just notice that g isn't quantified over 't' and partition
+the constraints before simplifying.
+
+This only half-works, but then let-generalisation only half-works.
+
+*********************************************************************************
+*                                                                                 *
+*                                 Main Simplifier                                 *
+*                                                                                 *
+***********************************************************************************
+
+-}
+
+simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints
+-- Solve the specified Wanted constraints
+-- Discard the evidence binds
+-- Discards all Derived stuff in result
+-- Postcondition: fully zonked and unflattened constraints
+simplifyWantedsTcM wanted
+  = do { traceTc "simplifyWantedsTcM {" (ppr wanted)
+       ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted))
+       ; result <- TcM.zonkWC result
+       ; traceTc "simplifyWantedsTcM }" (ppr result)
+       ; return result }
+
+solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints
+-- Since solveWanteds returns the residual WantedConstraints,
+-- it should always be called within a runTcS or something similar,
+-- Result is not zonked
+solveWantedsAndDrop wanted
+  = do { wc <- solveWanteds wanted
+       ; return (dropDerivedWC wc) }
+
+solveWanteds :: WantedConstraints -> TcS WantedConstraints
+-- so that the inert set doesn't mindlessly propagate.
+-- NB: wc_simples may be wanted /or/ derived now
+solveWanteds wc@(WC { wc_simple = simples, wc_impl = implics })
+  = do { cur_lvl <- TcS.getTcLevel
+       ; traceTcS "solveWanteds {" $
+         vcat [ text "Level =" <+> ppr cur_lvl
+              , ppr wc ]
+
+       ; wc1 <- solveSimpleWanteds simples
+                -- Any insoluble constraints are in 'simples' and so get rewritten
+                -- See Note [Rewrite insolubles] in TcSMonad
+
+       ; (floated_eqs, implics2) <- solveNestedImplications $
+                                    implics `unionBags` wc_impl wc1
+
+       ; dflags   <- getDynFlags
+       ; final_wc <- simpl_loop 0 (solverIterations dflags) floated_eqs
+                                (wc1 { wc_impl = implics2 })
+
+       ; ev_binds_var <- getTcEvBindsVar
+       ; bb <- TcS.getTcEvBindsMap ev_binds_var
+       ; traceTcS "solveWanteds }" $
+                 vcat [ text "final wc =" <+> ppr final_wc
+                      , text "current evbinds  =" <+> ppr (evBindMapBinds bb) ]
+
+       ; return final_wc }
+
+simpl_loop :: Int -> IntWithInf -> Cts
+           -> WantedConstraints -> TcS WantedConstraints
+simpl_loop n limit floated_eqs wc@(WC { wc_simple = simples })
+  | n `intGtLimit` limit
+  = do { -- Add an error (not a warning) if we blow the limit,
+         -- Typically if we blow the limit we are going to report some other error
+         -- (an unsolved constraint), and we don't want that error to suppress
+         -- the iteration limit warning!
+         addErrTcS (hang (text "solveWanteds: too many iterations"
+                   <+> parens (text "limit =" <+> ppr limit))
+                2 (vcat [ text "Unsolved:" <+> ppr wc
+                        , ppUnless (isEmptyBag floated_eqs) $
+                          text "Floated equalities:" <+> ppr floated_eqs
+                        , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"
+                  ]))
+       ; return wc }
+
+  | not (isEmptyBag floated_eqs)
+  = simplify_again n limit True (wc { wc_simple = floated_eqs `unionBags` simples })
+            -- Put floated_eqs first so they get solved first
+            -- NB: the floated_eqs may include /derived/ equalities
+            -- arising from fundeps inside an implication
+
+  | superClassesMightHelp wc
+  = -- We still have unsolved goals, and apparently no way to solve them,
+    -- so try expanding superclasses at this level, both Given and Wanted
+    do { pending_given <- getPendingGivenScs
+       ; let (pending_wanted, simples1) = getPendingWantedScs simples
+       ; if null pending_given && null pending_wanted
+           then return wc  -- After all, superclasses did not help
+           else
+    do { new_given  <- makeSuperClasses pending_given
+       ; new_wanted <- makeSuperClasses pending_wanted
+       ; solveSimpleGivens new_given -- Add the new Givens to the inert set
+       ; simplify_again n limit (null pending_given)
+         wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } }
+
+  | otherwise
+  = return wc
+
+simplify_again :: Int -> IntWithInf -> Bool
+               -> WantedConstraints -> TcS WantedConstraints
+-- We have definitely decided to have another go at solving
+-- the wanted constraints (we have tried at least once already
+simplify_again n limit no_new_given_scs
+               wc@(WC { wc_simple = simples, wc_impl = implics })
+  = do { csTraceTcS $
+         text "simpl_loop iteration=" <> int n
+         <+> (parens $ hsep [ text "no new given superclasses =" <+> ppr no_new_given_scs <> comma
+                            , int (lengthBag simples) <+> text "simples to solve" ])
+       ; traceTcS "simpl_loop: wc =" (ppr wc)
+
+       ; (unifs1, wc1) <- reportUnifications $
+                          solveSimpleWanteds $
+                          simples
+
+       -- See Note [Cutting off simpl_loop]
+       -- We have already tried to solve the nested implications once
+       -- Try again only if we have unified some meta-variables
+       -- (which is a bit like adding more givens), or we have some
+       -- new Given superclasses
+       ; let new_implics = wc_impl wc1
+       ; if unifs1 == 0       &&
+            no_new_given_scs  &&
+            isEmptyBag new_implics
+
+           then -- Do not even try to solve the implications
+                simpl_loop (n+1) limit emptyBag (wc1 { wc_impl = implics })
+
+           else -- Try to solve the implications
+                do { (floated_eqs2, implics2) <- solveNestedImplications $
+                                                 implics `unionBags` new_implics
+                   ; simpl_loop (n+1) limit floated_eqs2 (wc1 { wc_impl = implics2 })
+    } }
+
+solveNestedImplications :: Bag Implication
+                        -> TcS (Cts, Bag Implication)
+-- Precondition: the TcS inerts may contain unsolved simples which have
+-- to be converted to givens before we go inside a nested implication.
+solveNestedImplications implics
+  | isEmptyBag implics
+  = return (emptyBag, emptyBag)
+  | otherwise
+  = do { traceTcS "solveNestedImplications starting {" empty
+       ; (floated_eqs_s, unsolved_implics) <- mapAndUnzipBagM solveImplication implics
+       ; let floated_eqs = concatBag floated_eqs_s
+
+       -- ... and we are back in the original TcS inerts
+       -- Notice that the original includes the _insoluble_simples so it was safe to ignore
+       -- them in the beginning of this function.
+       ; traceTcS "solveNestedImplications end }" $
+                  vcat [ text "all floated_eqs ="  <+> ppr floated_eqs
+                       , text "unsolved_implics =" <+> ppr unsolved_implics ]
+
+       ; return (floated_eqs, catBagMaybes unsolved_implics) }
+
+solveImplication :: Implication    -- Wanted
+                 -> TcS (Cts,      -- All wanted or derived floated equalities: var = type
+                         Maybe Implication) -- Simplified implication (empty or singleton)
+-- Precondition: The TcS monad contains an empty worklist and given-only inerts
+-- which after trying to solve this implication we must restore to their original value
+solveImplication imp@(Implic { ic_tclvl  = tclvl
+                             , ic_binds  = ev_binds_var
+                             , ic_skols  = skols
+                             , ic_given  = given_ids
+                             , ic_wanted = wanteds
+                             , ic_info   = info
+                             , ic_status = status })
+  | isSolvedStatus status
+  = return (emptyCts, Just imp)  -- Do nothing
+
+  | otherwise  -- Even for IC_Insoluble it is worth doing more work
+               -- The insoluble stuff might be in one sub-implication
+               -- and other unsolved goals in another; and we want to
+               -- solve the latter as much as possible
+  = do { inerts <- getTcSInerts
+       ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts)
+
+       -- commented out; see `where` clause below
+       -- ; when debugIsOn check_tc_level
+
+         -- Solve the nested constraints
+       ; (no_given_eqs, given_insols, residual_wanted)
+            <- nestImplicTcS ev_binds_var tclvl $
+               do { let loc    = mkGivenLoc tclvl info (implicLclEnv imp)
+                        givens = mkGivens loc given_ids
+                  ; solveSimpleGivens givens
+
+                  ; residual_wanted <- solveWanteds wanteds
+                        -- solveWanteds, *not* solveWantedsAndDrop, because
+                        -- we want to retain derived equalities so we can float
+                        -- them out in floatEqualities
+
+                  ; (no_eqs, given_insols) <- getNoGivenEqs tclvl skols
+                        -- Call getNoGivenEqs /after/ solveWanteds, because
+                        -- solveWanteds can augment the givens, via expandSuperClasses,
+                        -- to reveal given superclass equalities
+
+                  ; return (no_eqs, given_insols, residual_wanted) }
+
+       ; (floated_eqs, residual_wanted)
+             <- floatEqualities skols given_ids ev_binds_var
+                                no_given_eqs residual_wanted
+
+       ; traceTcS "solveImplication 2"
+           (ppr given_insols $$ ppr residual_wanted)
+       ; let final_wanted = residual_wanted `addInsols` given_insols
+             -- Don't lose track of the insoluble givens,
+             -- which signal unreachable code; put them in ic_wanted
+
+       ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs
+                                                 , ic_wanted = final_wanted })
+
+       ; evbinds <- TcS.getTcEvBindsMap ev_binds_var
+       ; tcvs    <- TcS.getTcEvTyCoVars ev_binds_var
+       ; traceTcS "solveImplication end }" $ vcat
+             [ text "no_given_eqs =" <+> ppr no_given_eqs
+             , text "floated_eqs =" <+> ppr floated_eqs
+             , text "res_implic =" <+> ppr res_implic
+             , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds)
+             , text "implication tvcs =" <+> ppr tcvs ]
+
+       ; return (floated_eqs, res_implic) }
+
+  where
+    -- TcLevels must be strictly increasing (see (ImplicInv) in
+    -- Note [TcLevel and untouchable type variables] in TcType),
+    -- and in fact I thinkthey should always increase one level at a time.
+
+    -- Though sensible, this check causes lots of testsuite failures. It is
+    -- remaining commented out for now.
+    {-
+    check_tc_level = do { cur_lvl <- TcS.getTcLevel
+                        ; MASSERT2( tclvl == pushTcLevel cur_lvl , text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl ) }
+    -}
+
+----------------------
+setImplicationStatus :: Implication -> TcS (Maybe Implication)
+-- Finalise the implication returned from solveImplication:
+--    * Set the ic_status field
+--    * Trim the ic_wanted field to remove Derived constraints
+-- Precondition: the ic_status field is not already IC_Solved
+-- Return Nothing if we can discard the implication altogether
+setImplicationStatus implic@(Implic { ic_status     = status
+                                    , ic_info       = info
+                                    , ic_wanted     = wc
+                                    , ic_given      = givens })
+ | ASSERT2( not (isSolvedStatus status ), ppr info )
+   -- Precondition: we only set the status if it is not already solved
+   not (isSolvedWC pruned_wc)
+ = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic)
+
+      ; implic <- neededEvVars implic
+
+      ; let new_status | insolubleWC pruned_wc = IC_Insoluble
+                       | otherwise             = IC_Unsolved
+            new_implic = implic { ic_status = new_status
+                                , ic_wanted = pruned_wc }
+
+      ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic)
+
+      ; return $ Just new_implic }
+
+ | otherwise  -- Everything is solved
+              -- Set status to IC_Solved,
+              -- and compute the dead givens and outer needs
+              -- See Note [Tracking redundant constraints]
+ = do { traceTcS "setImplicationStatus(all-solved) {" (ppr implic)
+
+      ; implic@(Implic { ic_need_inner = need_inner
+                       , ic_need_outer = need_outer }) <- neededEvVars implic
+
+      ; bad_telescope <- checkBadTelescope implic
+
+      ; let dead_givens | warnRedundantGivens info
+                        = filterOut (`elemVarSet` need_inner) givens
+                        | otherwise = []   -- None to report
+
+            discard_entire_implication  -- Can we discard the entire implication?
+              =  null dead_givens           -- No warning from this implication
+              && not bad_telescope
+              && isEmptyWC pruned_wc        -- No live children
+              && isEmptyVarSet need_outer   -- No needed vars to pass up to parent
+
+            final_status
+              | bad_telescope = IC_BadTelescope
+              | otherwise     = IC_Solved { ics_dead = dead_givens }
+            final_implic = implic { ic_status = final_status
+                                  , ic_wanted = pruned_wc }
+
+      ; traceTcS "setImplicationStatus(all-solved) }" $
+        vcat [ text "discard:" <+> ppr discard_entire_implication
+             , text "new_implic:" <+> ppr final_implic ]
+
+      ; return $ if discard_entire_implication
+                 then Nothing
+                 else Just final_implic }
+ where
+   WC { wc_simple = simples, wc_impl = implics } = wc
+
+   pruned_simples = dropDerivedSimples simples
+   pruned_implics = filterBag keep_me implics
+   pruned_wc = WC { wc_simple = pruned_simples
+                  , wc_impl   = pruned_implics }
+
+   keep_me :: Implication -> Bool
+   keep_me ic
+     | IC_Solved { ics_dead = dead_givens } <- ic_status ic
+                          -- Fully solved
+     , null dead_givens   -- No redundant givens to report
+     , isEmptyBag (wc_impl (ic_wanted ic))
+           -- And no children that might have things to report
+     = False       -- Tnen we don't need to keep it
+     | otherwise
+     = True        -- Otherwise, keep it
+
+checkBadTelescope :: Implication -> TcS Bool
+-- True <=> the skolems form a bad telescope
+-- See Note [Keeping scoped variables in order: Explicit] in TcHsType
+checkBadTelescope (Implic { ic_telescope  = m_telescope
+                          , ic_skols      = skols })
+  | isJust m_telescope
+  = do{ skols <- mapM TcS.zonkTyCoVarKind skols
+      ; return (go emptyVarSet (reverse skols))}
+
+  | otherwise
+  = return False
+
+  where
+    go :: TyVarSet   -- skolems that appear *later* than the current ones
+       -> [TcTyVar]  -- ordered skolems, in reverse order
+       -> Bool       -- True <=> there is an out-of-order skolem
+    go _ [] = False
+    go later_skols (one_skol : earlier_skols)
+      | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols
+      = True
+      | otherwise
+      = go (later_skols `extendVarSet` one_skol) earlier_skols
+
+warnRedundantGivens :: SkolemInfo -> Bool
+warnRedundantGivens (SigSkol ctxt _ _)
+  = case ctxt of
+       FunSigCtxt _ warn_redundant -> warn_redundant
+       ExprSigCtxt                 -> True
+       _                           -> False
+
+  -- To think about: do we want to report redundant givens for
+  -- pattern synonyms, PatSynSigSkol? c.f Trac #9953, comment:21.
+warnRedundantGivens (InstSkol {}) = True
+warnRedundantGivens _             = False
+
+neededEvVars :: Implication -> TcS Implication
+-- Find all the evidence variables that are "needed",
+-- and delete dead evidence bindings
+--   See Note [Tracking redundant constraints]
+--   See Note [Delete dead Given evidence bindings]
+--
+--   - Start from initial_seeds (from nested implications)
+--
+--   - Add free vars of RHS of all Wanted evidence bindings
+--     and coercion variables accumulated in tcvs (all Wanted)
+--
+--   - Generate 'needed', the needed set of EvVars, by doing transitive
+--     closure through Given bindings
+--     e.g.   Needed {a,b}
+--            Given  a = sc_sel a2
+--            Then a2 is needed too
+--
+--   - Prune out all Given bindings that are not needed
+--
+--   - From the 'needed' set, delete ev_bndrs, the binders of the
+--     evidence bindings, to give the final needed variables
+--
+neededEvVars implic@(Implic { ic_given = givens
+                            , ic_binds = ev_binds_var
+                            , ic_wanted = WC { wc_impl = implics }
+                            , ic_need_inner = old_needs })
+ = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var
+      ; tcvs     <- TcS.getTcEvTyCoVars ev_binds_var
+
+      ; let seeds1        = foldrBag add_implic_seeds old_needs implics
+            seeds2        = foldEvBindMap add_wanted seeds1 ev_binds
+            seeds3        = seeds2 `unionVarSet` tcvs
+            need_inner    = findNeededEvVars ev_binds seeds3
+            live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds
+            need_outer    = foldEvBindMap del_ev_bndr need_inner live_ev_binds
+                            `delVarSetList` givens
+
+      ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds
+           -- See Note [Delete dead Given evidence bindings]
+
+      ; traceTcS "neededEvVars" $
+        vcat [ text "old_needs:" <+> ppr old_needs
+             , text "seeds3:" <+> ppr seeds3
+             , text "tcvs:" <+> ppr tcvs
+             , text "ev_binds:" <+> ppr ev_binds
+             , text "live_ev_binds:" <+> ppr live_ev_binds ]
+
+      ; return (implic { ic_need_inner = need_inner
+                       , ic_need_outer = need_outer }) }
+ where
+   add_implic_seeds (Implic { ic_need_outer = needs }) acc
+      = needs `unionVarSet` acc
+
+   needed_ev_bind needed (EvBind { eb_lhs = ev_var
+                                 , eb_is_given = is_given })
+     | is_given  = ev_var `elemVarSet` needed
+     | otherwise = True   -- Keep all wanted bindings
+
+   del_ev_bndr :: EvBind -> VarSet -> VarSet
+   del_ev_bndr (EvBind { eb_lhs = v }) needs = delVarSet needs v
+
+   add_wanted :: EvBind -> VarSet -> VarSet
+   add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs
+     | is_given  = needs  -- Add the rhs vars of the Wanted bindings only
+     | otherwise = evVarsOfTerm rhs `unionVarSet` needs
+
+
+{- Note [Delete dead Given evidence bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As a result of superclass expansion, we speculatively
+generate evidence bindings for Givens. E.g.
+   f :: (a ~ b) => a -> b -> Bool
+   f x y = ...
+We'll have
+   [G] d1 :: (a~b)
+and we'll specuatively generate the evidence binding
+   [G] d2 :: (a ~# b) = sc_sel d
+
+Now d2 is available for solving.  But it may not be needed!  Usually
+such dead superclass selections will eventually be dropped as dead
+code, but:
+
+ * It won't always be dropped (Trac #13032).  In the case of an
+   unlifted-equality superclass like d2 above, we generate
+       case heq_sc d1 of d2 -> ...
+   and we can't (in general) drop that case exrpession in case
+   d1 is bottom.  So it's technically unsound to have added it
+   in the first place.
+
+ * Simply generating all those extra superclasses can generate lots of
+   code that has to be zonked, only to be discarded later.  Better not
+   to generate it in the first place.
+
+   Moreover, if we simplify this implication more than once
+   (e.g. because we can't solve it completely on the first iteration
+   of simpl_looop), we'll generate all the same bindings AGAIN!
+
+Easy solution: take advantage of the work we are doing to track dead
+(unused) Givens, and use it to prune the Given bindings too.  This is
+all done by neededEvVars.
+
+This led to a remarkable 25% overall compiler allocation decrease in
+test T12227.
+
+But we don't get to discard all redundant equality superclasses, alas;
+see Trac #15205.
+
+Note [Tracking redundant constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With Opt_WarnRedundantConstraints, GHC can report which
+constraints of a type signature (or instance declaration) are
+redundant, and can be omitted.  Here is an overview of how it
+works:
+
+----- What is a redundant constraint?
+
+* The things that can be redundant are precisely the Given
+  constraints of an implication.
+
+* A constraint can be redundant in two different ways:
+  a) It is implied by other givens.  E.g.
+       f :: (Eq a, Ord a)     => blah   -- Eq a unnecessary
+       g :: (Eq a, a~b, Eq b) => blah   -- Either Eq a or Eq b unnecessary
+  b) It is not needed by the Wanted constraints covered by the
+     implication E.g.
+       f :: Eq a => a -> Bool
+       f x = True  -- Equality not used
+
+*  To find (a), when we have two Given constraints,
+   we must be careful to drop the one that is a naked variable (if poss).
+   So if we have
+       f :: (Eq a, Ord a) => blah
+   then we may find [G] sc_sel (d1::Ord a) :: Eq a
+                    [G] d2 :: Eq a
+   We want to discard d2 in favour of the superclass selection from
+   the Ord dictionary.  This is done by TcInteract.solveOneFromTheOther
+   See Note [Replacement vs keeping].
+
+* To find (b) we need to know which evidence bindings are 'wanted';
+  hence the eb_is_given field on an EvBind.
+
+----- How tracking works
+
+* The ic_need fields of an Implic records in-scope (given) evidence
+  variables bound by the context, that were needed to solve this
+  implication (so far).  See the declaration of Implication.
+
+* When the constraint solver finishes solving all the wanteds in
+  an implication, it sets its status to IC_Solved
+
+  - The ics_dead field, of IC_Solved, records the subset of this
+    implication's ic_given that are redundant (not needed).
+
+* We compute which evidence variables are needed by an implication
+  in setImplicationStatus.  A variable is needed if
+    a) it is free in the RHS of a Wanted EvBind,
+    b) it is free in the RHS of an EvBind whose LHS is needed,
+    c) it is in the ics_need of a nested implication.
+
+* We need to be careful not to discard an implication
+  prematurely, even one that is fully solved, because we might
+  thereby forget which variables it needs, and hence wrongly
+  report a constraint as redundant.  But we can discard it once
+  its free vars have been incorporated into its parent; or if it
+  simply has no free vars. This careful discarding is also
+  handled in setImplicationStatus.
+
+----- Reporting redundant constraints
+
+* TcErrors does the actual warning, in warnRedundantConstraints.
+
+* We don't report redundant givens for *every* implication; only
+  for those which reply True to TcSimplify.warnRedundantGivens:
+
+   - For example, in a class declaration, the default method *can*
+     use the class constraint, but it certainly doesn't *have* to,
+     and we don't want to report an error there.
+
+   - More subtly, in a function definition
+       f :: (Ord a, Ord a, Ix a) => a -> a
+       f x = rhs
+     we do an ambiguity check on the type (which would find that one
+     of the Ord a constraints was redundant), and then we check that
+     the definition has that type (which might find that both are
+     redundant).  We don't want to report the same error twice, so we
+     disable it for the ambiguity check.  Hence using two different
+     FunSigCtxts, one with the warn-redundant field set True, and the
+     other set False in
+        - TcBinds.tcSpecPrag
+        - TcBinds.tcTySig
+
+  This decision is taken in setImplicationStatus, rather than TcErrors
+  so that we can discard implication constraints that we don't need.
+  So ics_dead consists only of the *reportable* redundant givens.
+
+----- Shortcomings
+
+Consider (see Trac #9939)
+    f2 :: (Eq a, Ord a) => a -> a -> Bool
+    -- Ord a redundant, but Eq a is reported
+    f2 x y = (x == y)
+
+We report (Eq a) as redundant, whereas actually (Ord a) is.  But it's
+really not easy to detect that!
+
+
+Note [Cutting off simpl_loop]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It is very important not to iterate in simpl_loop unless there is a chance
+of progress.  Trac #8474 is a classic example:
+
+  * There's a deeply-nested chain of implication constraints.
+       ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int
+
+  * From the innermost one we get a [D] alpha ~ Int,
+    but alpha is untouchable until we get out to the outermost one
+
+  * We float [D] alpha~Int out (it is in floated_eqs), but since alpha
+    is untouchable, the solveInteract in simpl_loop makes no progress
+
+  * So there is no point in attempting to re-solve
+       ?yn:betan => [W] ?x:Int
+    via solveNestedImplications, because we'll just get the
+    same [D] again
+
+  * If we *do* re-solve, we'll get an ininite loop. It is cut off by
+    the fixed bound of 10, but solving the next takes 10*10*...*10 (ie
+    exponentially many) iterations!
+
+Conclusion: we should call solveNestedImplications only if we did
+some unification in solveSimpleWanteds; because that's the only way
+we'll get more Givens (a unification is like adding a Given) to
+allow the implication to make progress.
+-}
+
+promoteTyVar :: TcTyVar -> TcM (Bool, TcTyVar)
+-- When we float a constraint out of an implication we must restore
+-- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in TcType
+-- Return True <=> we did some promotion
+-- Also returns either the original tyvar (no promotion) or the new one
+-- See Note [Promoting unification variables]
+promoteTyVar tv
+  = do { tclvl <- TcM.getTcLevel
+       ; if (isFloatedTouchableMetaTyVar tclvl tv)
+         then do { cloned_tv <- TcM.cloneMetaTyVar tv
+                 ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl
+                 ; TcM.writeMetaTyVar tv (mkTyVarTy rhs_tv)
+                 ; return (True, rhs_tv) }
+         else return (False, tv) }
+
+-- Returns whether or not *any* tyvar is defaulted
+promoteTyVarSet :: TcTyVarSet -> TcM (Bool, TcTyVarSet)
+promoteTyVarSet tvs
+  = do { (bools, tyvars) <- mapAndUnzipM promoteTyVar (nonDetEltsUniqSet tvs)
+           -- non-determinism is OK because order of promotion doesn't matter
+
+       ; return (or bools, mkVarSet tyvars) }
+
+promoteTyVarTcS :: TcTyVar  -> TcS ()
+-- When we float a constraint out of an implication we must restore
+-- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in TcType
+-- See Note [Promoting unification variables]
+-- We don't just call promoteTyVar because we want to use unifyTyVar,
+-- not writeMetaTyVar
+promoteTyVarTcS tv
+  = do { tclvl <- TcS.getTcLevel
+       ; when (isFloatedTouchableMetaTyVar tclvl tv) $
+         do { cloned_tv <- TcS.cloneMetaTyVar tv
+            ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl
+            ; unifyTyVar tv (mkTyVarTy rhs_tv) } }
+
+-- | Like 'defaultTyVar', but in the TcS monad.
+defaultTyVarTcS :: TcTyVar -> TcS Bool
+defaultTyVarTcS the_tv
+  | isRuntimeRepVar the_tv
+  , not (isTyVarTyVar the_tv)
+    -- TyVarTvs should only be unified with a tyvar
+    -- never with a type; c.f. TcMType.defaultTyVar
+    -- and Note [Inferring kinds for type declarations] in TcTyClsDecls
+  = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)
+       ; unifyTyVar the_tv liftedRepTy
+       ; return True }
+  | otherwise
+  = return False  -- the common case
+
+approximateWC :: Bool -> WantedConstraints -> Cts
+-- Postcondition: Wanted or Derived Cts
+-- See Note [ApproximateWC]
+approximateWC float_past_equalities wc
+  = float_wc emptyVarSet wc
+  where
+    float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts
+    float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics })
+      = filterBag (is_floatable trapping_tvs) simples `unionBags`
+        do_bag (float_implic trapping_tvs) implics
+      where
+
+    float_implic :: TcTyCoVarSet -> Implication -> Cts
+    float_implic trapping_tvs imp
+      | float_past_equalities || ic_no_eqs imp
+      = float_wc new_trapping_tvs (ic_wanted imp)
+      | otherwise   -- Take care with equalities
+      = emptyCts    -- See (1) under Note [ApproximateWC]
+      where
+        new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp
+
+    do_bag :: (a -> Bag c) -> Bag a -> Bag c
+    do_bag f = foldrBag (unionBags.f) emptyBag
+
+    is_floatable skol_tvs ct
+       | isGivenCt ct     = False
+       | isHoleCt ct      = False
+       | insolubleEqCt ct = False
+       | otherwise        = tyCoVarsOfCt ct `disjointVarSet` skol_tvs
+
+{- Note [ApproximateWC]
+~~~~~~~~~~~~~~~~~~~~~~~
+approximateWC takes a constraint, typically arising from the RHS of a
+let-binding whose type we are *inferring*, and extracts from it some
+*simple* constraints that we might plausibly abstract over.  Of course
+the top-level simple constraints are plausible, but we also float constraints
+out from inside, if they are not captured by skolems.
+
+The same function is used when doing type-class defaulting (see the call
+to applyDefaultingRules) to extract constraints that that might be defaulted.
+
+There is one caveat:
+
+1.  When infering most-general types (in simplifyInfer), we do *not*
+    float anything out if the implication binds equality constraints,
+    because that defeats the OutsideIn story.  Consider
+       data T a where
+         TInt :: T Int
+         MkT :: T a
+
+       f TInt = 3::Int
+
+    We get the implication (a ~ Int => res ~ Int), where so far we've decided
+      f :: T a -> res
+    We don't want to float (res~Int) out because then we'll infer
+      f :: T a -> Int
+    which is only on of the possible types. (GHC 7.6 accidentally *did*
+    float out of such implications, which meant it would happily infer
+    non-principal types.)
+
+   HOWEVER (Trac #12797) in findDefaultableGroups we are not worried about
+   the most-general type; and we /do/ want to float out of equalities.
+   Hence the boolean flag to approximateWC.
+
+------ Historical note -----------
+There used to be a second caveat, driven by Trac #8155
+
+   2. We do not float out an inner constraint that shares a type variable
+      (transitively) with one that is trapped by a skolem.  Eg
+          forall a.  F a ~ beta, Integral beta
+      We don't want to float out (Integral beta).  Doing so would be bad
+      when defaulting, because then we'll default beta:=Integer, and that
+      makes the error message much worse; we'd get
+          Can't solve  F a ~ Integer
+      rather than
+          Can't solve  Integral (F a)
+
+      Moreover, floating out these "contaminated" constraints doesn't help
+      when generalising either. If we generalise over (Integral b), we still
+      can't solve the retained implication (forall a. F a ~ b).  Indeed,
+      arguably that too would be a harder error to understand.
+
+But this transitive closure stuff gives rise to a complex rule for
+when defaulting actually happens, and one that was never documented.
+Moreover (Trac #12923), the more complex rule is sometimes NOT what
+you want.  So I simply removed the extra code to implement the
+contamination stuff.  There was zero effect on the testsuite (not even
+#8155).
+------ End of historical note -----------
+
+
+Note [DefaultTyVar]
+~~~~~~~~~~~~~~~~~~~
+defaultTyVar is used on any un-instantiated meta type variables to
+default any RuntimeRep variables to LiftedRep.  This is important
+to ensure that instance declarations match.  For example consider
+
+     instance Show (a->b)
+     foo x = show (\_ -> True)
+
+Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r),
+and that won't match the tcTypeKind (*) in the instance decl.  See tests
+tc217 and tc175.
+
+We look only at touchable type variables. No further constraints
+are going to affect these type variables, so it's time to do it by
+hand.  However we aren't ready to default them fully to () or
+whatever, because the type-class defaulting rules have yet to run.
+
+An alternate implementation would be to emit a derived constraint setting
+the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect.
+
+Note [Promote _and_ default when inferring]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we are inferring a type, we simplify the constraint, and then use
+approximateWC to produce a list of candidate constraints.  Then we MUST
+
+  a) Promote any meta-tyvars that have been floated out by
+     approximateWC, to restore invariant (WantedInv) described in
+     Note [TcLevel and untouchable type variables] in TcType.
+
+  b) Default the kind of any meta-tyvars that are not mentioned in
+     in the environment.
+
+To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we
+have an instance (C ((x:*) -> Int)).  The instance doesn't match -- but it
+should!  If we don't solve the constraint, we'll stupidly quantify over
+(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over
+(b:*) instead of (a:OpenKind), which can lead to disaster; see Trac #7332.
+Trac #7641 is a simpler example.
+
+Note [Promoting unification variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we float an equality out of an implication we must "promote" free
+unification variables of the equality, in order to maintain Invariant
+(WantedInv) from Note [TcLevel and untouchable type variables] in
+TcType.  for the leftover implication.
+
+This is absolutely necessary. Consider the following example. We start
+with two implications and a class with a functional dependency.
+
+    class C x y | x -> y
+    instance C [a] [a]
+
+    (I1)      [untch=beta]forall b. 0 => F Int ~ [beta]
+    (I2)      [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c]
+
+We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2.
+They may react to yield that (beta := [alpha]) which can then be pushed inwards
+the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that
+(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable
+beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs:
+
+    class C x y | x -> y where
+     op :: x -> y -> ()
+
+    instance C [a] [a]
+
+    type family F a :: *
+
+    h :: F Int -> ()
+    h = undefined
+
+    data TEx where
+      TEx :: a -> TEx
+
+    f (x::beta) =
+        let g1 :: forall b. b -> ()
+            g1 _ = h [x]
+            g2 z = case z of TEx y -> (h [[undefined]], op x [y])
+        in (g1 '3', g2 undefined)
+
+
+
+*********************************************************************************
+*                                                                               *
+*                          Floating equalities                                  *
+*                                                                               *
+*********************************************************************************
+
+Note [Float Equalities out of Implications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For ordinary pattern matches (including existentials) we float
+equalities out of implications, for instance:
+     data T where
+       MkT :: Eq a => a -> T
+     f x y = case x of MkT _ -> (y::Int)
+We get the implication constraint (x::T) (y::alpha):
+     forall a. [untouchable=alpha] Eq a => alpha ~ Int
+We want to float out the equality into a scope where alpha is no
+longer untouchable, to solve the implication!
+
+But we cannot float equalities out of implications whose givens may
+yield or contain equalities:
+
+      data T a where
+        T1 :: T Int
+        T2 :: T Bool
+        T3 :: T a
+
+      h :: T a -> a -> Int
+
+      f x y = case x of
+                T1 -> y::Int
+                T2 -> y::Bool
+                T3 -> h x y
+
+We generate constraint, for (x::T alpha) and (y :: beta):
+   [untouchables = beta] (alpha ~ Int => beta ~ Int)   -- From 1st branch
+   [untouchables = beta] (alpha ~ Bool => beta ~ Bool) -- From 2nd branch
+   (alpha ~ beta)                                      -- From 3rd branch
+
+If we float the equality (beta ~ Int) outside of the first implication and
+the equality (beta ~ Bool) out of the second we get an insoluble constraint.
+But if we just leave them inside the implications, we unify alpha := beta and
+solve everything.
+
+Principle:
+    We do not want to float equalities out which may
+    need the given *evidence* to become soluble.
+
+Consequence: classes with functional dependencies don't matter (since there is
+no evidence for a fundep equality), but equality superclasses do matter (since
+they carry evidence).
+-}
+
+floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> Bool
+                -> WantedConstraints
+                -> TcS (Cts, WantedConstraints)
+-- Main idea: see Note [Float Equalities out of Implications]
+--
+-- Precondition: the wc_simple of the incoming WantedConstraints are
+--               fully zonked, so that we can see their free variables
+--
+-- Postcondition: The returned floated constraints (Cts) are only
+--                Wanted or Derived
+--
+-- Also performs some unifications (via promoteTyVar), adding to
+-- monadically-carried ty_binds. These will be used when processing
+-- floated_eqs later
+--
+-- Subtleties: Note [Float equalities from under a skolem binding]
+--             Note [Skolem escape]
+--             Note [What prevents a constraint from floating]
+floatEqualities skols given_ids ev_binds_var no_given_eqs
+                wanteds@(WC { wc_simple = simples })
+  | not no_given_eqs  -- There are some given equalities, so don't float
+  = return (emptyBag, wanteds)   -- Note [Float Equalities out of Implications]
+
+  | otherwise
+  = do { -- First zonk: the inert set (from whence they came) is fully
+         -- zonked, but unflattening may have filled in unification
+         -- variables, and we /must/ see them.  Otherwise we may float
+         -- constraints that mention the skolems!
+         simples <- TcS.zonkSimples simples
+       ; binds   <- TcS.getTcEvBindsMap ev_binds_var
+
+       -- Now we can pick the ones to float
+       -- The constraints are un-flattened and de-canonicalised
+       ; let (candidate_eqs, no_float_cts) = partitionBag is_float_eq_candidate simples
+
+             seed_skols = mkVarSet skols     `unionVarSet`
+                          mkVarSet given_ids `unionVarSet`
+                          foldrBag add_non_flt_ct emptyVarSet no_float_cts `unionVarSet`
+                          foldEvBindMap add_one_bind emptyVarSet binds
+             -- seed_skols: See Note [What prevents a constraint from floating] (1,2,3)
+             -- Include the EvIds of any non-floating constraints
+
+             extended_skols = transCloVarSet (add_captured_ev_ids candidate_eqs) seed_skols
+                 -- extended_skols contains the EvIds of all the trapped constraints
+                 -- See Note [What prevents a constraint from floating] (3)
+
+             (flt_eqs, no_flt_eqs) = partitionBag (is_floatable extended_skols)
+                                                  candidate_eqs
+
+             remaining_simples = no_float_cts `andCts` no_flt_eqs
+
+       -- Promote any unification variables mentioned in the floated equalities
+       -- See Note [Promoting unification variables]
+       ; mapM_ promoteTyVarTcS (tyCoVarsOfCtsList flt_eqs)
+
+       ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols
+                                          , text "Extended skols =" <+> ppr extended_skols
+                                          , text "Simples =" <+> ppr simples
+                                          , text "Candidate eqs =" <+> ppr candidate_eqs
+                                          , text "Floated eqs =" <+> ppr flt_eqs])
+       ; return ( flt_eqs, wanteds { wc_simple = remaining_simples } ) }
+
+  where
+    add_one_bind :: EvBind -> VarSet -> VarSet
+    add_one_bind bind acc = extendVarSet acc (evBindVar bind)
+
+    add_non_flt_ct :: Ct -> VarSet -> VarSet
+    add_non_flt_ct ct acc | isDerivedCt ct = acc
+                          | otherwise      = extendVarSet acc (ctEvId ct)
+
+    is_floatable :: VarSet -> Ct -> Bool
+    is_floatable skols ct
+      | isDerivedCt ct = not (tyCoVarsOfCt ct `intersectsVarSet` skols)
+      | otherwise      = not (ctEvId ct `elemVarSet` skols)
+
+    add_captured_ev_ids :: Cts -> VarSet -> VarSet
+    add_captured_ev_ids cts skols = foldrBag extra_skol emptyVarSet cts
+       where
+         extra_skol ct acc
+           | isDerivedCt ct                           = acc
+           | tyCoVarsOfCt ct `intersectsVarSet` skols = extendVarSet acc (ctEvId ct)
+           | otherwise                                = acc
+
+    -- Identify which equalities are candidates for floating
+    -- Float out alpha ~ ty, or ty ~ alpha which might be unified outside
+    -- See Note [Which equalities to float]
+    is_float_eq_candidate ct
+      | pred <- ctPred ct
+      , EqPred NomEq ty1 ty2 <- classifyPredType pred
+      , tcTypeKind ty1 `tcEqType` tcTypeKind ty2
+      = case (tcGetTyVar_maybe ty1, tcGetTyVar_maybe ty2) of
+          (Just tv1, _) -> float_tv_eq_candidate tv1 ty2
+          (_, Just tv2) -> float_tv_eq_candidate tv2 ty1
+          _             -> False
+      | otherwise = False
+
+    float_tv_eq_candidate tv1 ty2  -- See Note [Which equalities to float]
+      =  isMetaTyVar tv1
+      && (not (isTyVarTyVar tv1) || isTyVarTy ty2)
+
+
+{- Note [Float equalities from under a skolem binding]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Which of the simple equalities can we float out?  Obviously, only
+ones that don't mention the skolem-bound variables.  But that is
+over-eager. Consider
+   [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int
+The second constraint doesn't mention 'a'.  But if we float it,
+we'll promote gamma[2] to gamma'[1].  Now suppose that we learn that
+beta := Bool, and F a Bool = a, and G Bool _ = Int.  Then we'll
+we left with the constraint
+   [2] forall a. a ~ gamma'[1]
+which is insoluble because gamma became untouchable.
+
+Solution: float only constraints that stand a jolly good chance of
+being soluble simply by being floated, namely ones of form
+      a ~ ty
+where 'a' is a currently-untouchable unification variable, but may
+become touchable by being floated (perhaps by more than one level).
+
+We had a very complicated rule previously, but this is nice and
+simple.  (To see the notes, look at this Note in a version of
+TcSimplify prior to Oct 2014).
+
+Note [Which equalities to float]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Which equalities should we float?  We want to float ones where there
+is a decent chance that floating outwards will allow unification to
+happen.  In particular, float out equalities that are:
+
+* Of form (alpha ~# ty) or (ty ~# alpha), where
+   * alpha is a meta-tyvar.
+   * And 'alpha' is not a TyVarTv with 'ty' being a non-tyvar.  In that
+     case, floating out won't help either, and it may affect grouping
+     of error messages.
+
+* Homogeneous (both sides have the same kind). Why only homogeneous?
+  Because heterogeneous equalities have derived kind equalities.
+  See Note [Equalities with incompatible kinds] in TcCanonical.
+  If we float out a hetero equality, then it will spit out the same
+  derived kind equality again, which might create duplicate error
+  messages.
+
+  Instead, we do float out the kind equality (if it's worth floating
+  out, as above). If/when we solve it, we'll be able to rewrite the
+  original hetero equality to be homogeneous, and then perhaps make
+  progress / float it out. The duplicate error message was spotted in
+  typecheck/should_fail/T7368.
+
+* Nominal.  No point in floating (alpha ~R# ty), because we do not
+  unify representational equalities even if alpha is touchable.
+  See Note [Do not unify representational equalities] in TcInteract.
+
+Note [Skolem escape]
+~~~~~~~~~~~~~~~~~~~~
+You might worry about skolem escape with all this floating.
+For example, consider
+    [2] forall a. (a ~ F beta[2] delta,
+                   Maybe beta[2] ~ gamma[1])
+
+The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and
+solve with gamma := beta. But what if later delta:=Int, and
+  F b Int = b.
+Then we'd get a ~ beta[2], and solve to get beta:=a, and now the
+skolem has escaped!
+
+But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2]
+to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be.
+
+Note [What prevents a constraint from floating]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What /prevents/ a constraint from floating?  If it mentions one of the
+"bound variables of the implication".  What are they?
+
+The "bound variables of the implication" are
+
+  1. The skolem type variables `ic_skols`
+
+  2. The "given" evidence variables `ic_given`.  Example:
+         forall a. (co :: t1 ~# t2) =>  [W] co2 : (a ~# b |> co)
+     Here 'co' is bound
+
+  3. The binders of all evidence bindings in `ic_binds`. Example
+         forall a. (d :: t1 ~ t2)
+            EvBinds { (co :: t1 ~# t2) = superclass-sel d }
+            => [W] co2 : (a ~# b |> co)
+     Here `co` is gotten by superclass selection from `d`, and the
+     wanted constraint co2 must not float.
+
+  4. And the evidence variable of any equality constraint (incl
+     Wanted ones) whose type mentions a bound variable.  Example:
+        forall k. [W] co1 :: t1 ~# t2 |> co2
+                  [W] co2 :: k ~# *
+     Here, since `k` is bound, so is `co2` and hence so is `co1`.
+
+Here (1,2,3) are handled by the "seed_skols" calculation, and
+(4) is done by the transCloVarSet call.
+
+The possible dependence on givens, and evidence bindings, is more
+subtle than we'd realised at first.  See Trac #14584.
+
+
+*********************************************************************************
+*                                                                               *
+*                          Defaulting and disambiguation                        *
+*                                                                               *
+*********************************************************************************
+-}
+
+applyDefaultingRules :: WantedConstraints -> TcS Bool
+-- True <=> I did some defaulting, by unifying a meta-tyvar
+-- Input WantedConstraints are not necessarily zonked
+
+applyDefaultingRules wanteds
+  | isEmptyWC wanteds
+  = return False
+  | otherwise
+  = do { info@(default_tys, _) <- getDefaultInfo
+       ; wanteds               <- TcS.zonkWC wanteds
+
+       ; let groups = findDefaultableGroups info wanteds
+
+       ; traceTcS "applyDefaultingRules {" $
+                  vcat [ text "wanteds =" <+> ppr wanteds
+                       , text "groups  =" <+> ppr groups
+                       , text "info    =" <+> ppr info ]
+
+       ; something_happeneds <- mapM (disambigGroup default_tys) groups
+
+       ; traceTcS "applyDefaultingRules }" (ppr something_happeneds)
+
+       ; return (or something_happeneds) }
+
+findDefaultableGroups
+    :: ( [Type]
+       , (Bool,Bool) )     -- (Overloaded strings, extended default rules)
+    -> WantedConstraints   -- Unsolved (wanted or derived)
+    -> [(TyVar, [Ct])]
+findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
+  | null default_tys
+  = []
+  | otherwise
+  = [ (tv, map fstOf3 group)
+    | group'@((_,_,tv) :| _) <- unary_groups
+    , let group = toList group'
+    , defaultable_tyvar tv
+    , defaultable_classes (map sndOf3 group) ]
+  where
+    simples                = approximateWC True wanteds
+    (unaries, non_unaries) = partitionWith find_unary (bagToList simples)
+    unary_groups           = equivClasses cmp_tv unaries
+
+    unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints
+    unaries      :: [(Ct, Class, TcTyVar)]          -- (C tv) constraints
+    non_unaries  :: [Ct]                            -- and *other* constraints
+
+        -- Finds unary type-class constraints
+        -- But take account of polykinded classes like Typeable,
+        -- which may look like (Typeable * (a:*))   (Trac #8931)
+    find_unary :: Ct -> Either (Ct, Class, TyVar) Ct
+    find_unary cc
+        | Just (cls,tys)   <- getClassPredTys_maybe (ctPred cc)
+        , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys
+              -- Ignore invisible arguments for this purpose
+        , Just tv <- tcGetTyVar_maybe ty
+        , isMetaTyVar tv  -- We might have runtime-skolems in GHCi, and
+                          -- we definitely don't want to try to assign to those!
+        = Left (cc, cls, tv)
+    find_unary cc = Right cc  -- Non unary or non dictionary
+
+    bad_tvs :: TcTyCoVarSet  -- TyVars mentioned by non-unaries
+    bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries
+
+    cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2
+
+    defaultable_tyvar :: TcTyVar -> Bool
+    defaultable_tyvar tv
+        = let b1 = isTyConableTyVar tv  -- Note [Avoiding spurious errors]
+              b2 = not (tv `elemVarSet` bad_tvs)
+          in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults]
+
+    defaultable_classes :: [Class] -> Bool
+    defaultable_classes clss
+        | extended_defaults = any (isInteractiveClass ovl_strings) clss
+        | otherwise         = all is_std_class clss && (any (isNumClass ovl_strings) clss)
+
+    -- is_std_class adds IsString to the standard numeric classes,
+    -- when -foverloaded-strings is enabled
+    is_std_class cls = isStandardClass cls ||
+                       (ovl_strings && (cls `hasKey` isStringClassKey))
+
+------------------------------
+disambigGroup :: [Type]            -- The default types
+              -> (TcTyVar, [Ct])   -- All classes of the form (C a)
+                                   --  sharing same type variable
+              -> TcS Bool   -- True <=> something happened, reflected in ty_binds
+
+disambigGroup [] _
+  = return False
+disambigGroup (default_ty:default_tys) group@(the_tv, wanteds)
+  = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ])
+       ; fake_ev_binds_var <- TcS.newTcEvBinds
+       ; tclvl             <- TcS.getTcLevel
+       ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group
+
+       ; if success then
+             -- Success: record the type variable binding, and return
+             do { unifyTyVar the_tv default_ty
+                ; wrapWarnTcS $ warnDefaulting wanteds default_ty
+                ; traceTcS "disambigGroup succeeded }" (ppr default_ty)
+                ; return True }
+         else
+             -- Failure: try with the next type
+             do { traceTcS "disambigGroup failed, will try other default types }"
+                           (ppr default_ty)
+                ; disambigGroup default_tys group } }
+  where
+    try_group
+      | Just subst <- mb_subst
+      = do { lcl_env <- TcS.getLclEnv
+           ; tc_lvl <- TcS.getTcLevel
+           ; let loc = mkGivenLoc tc_lvl UnkSkol lcl_env
+           ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred)
+                                wanteds
+           ; fmap isEmptyWC $
+             solveSimpleWanteds $ listToBag $
+             map mkNonCanonical wanted_evs }
+
+      | otherwise
+      = return False
+
+    the_ty   = mkTyVarTy the_tv
+    mb_subst = tcMatchTyKi the_ty default_ty
+      -- Make sure the kinds match too; hence this call to tcMatchTyKi
+      -- E.g. suppose the only constraint was (Typeable k (a::k))
+      -- With the addition of polykinded defaulting we also want to reject
+      -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here.
+
+-- In interactive mode, or with -XExtendedDefaultRules,
+-- we default Show a to Show () to avoid graututious errors on "show []"
+isInteractiveClass :: Bool   -- -XOverloadedStrings?
+                   -> Class -> Bool
+isInteractiveClass ovl_strings cls
+    = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys)
+
+    -- isNumClass adds IsString to the standard numeric classes,
+    -- when -foverloaded-strings is enabled
+isNumClass :: Bool   -- -XOverloadedStrings?
+           -> Class -> Bool
+isNumClass ovl_strings cls
+  = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey))
+
+
+{-
+Note [Avoiding spurious errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When doing the unification for defaulting, we check for skolem
+type variables, and simply don't default them.  For example:
+   f = (*)      -- Monomorphic
+   g :: Num a => a -> a
+   g x = f x x
+Here, we get a complaint when checking the type signature for g,
+that g isn't polymorphic enough; but then we get another one when
+dealing with the (Num a) context arising from f's definition;
+we try to unify a with Int (to default it), but find that it's
+already been unified with the rigid variable from g's type sig.
+
+Note [Multi-parameter defaults]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+With -XExtendedDefaultRules, we default only based on single-variable
+constraints, but do not exclude from defaulting any type variables which also
+appear in multi-variable constraints. This means that the following will
+default properly:
+
+   default (Integer, Double)
+
+   class A b (c :: Symbol) where
+      a :: b -> Proxy c
+
+   instance A Integer c where a _ = Proxy
+
+   main = print (a 5 :: Proxy "5")
+
+Note that if we change the above instance ("instance A Integer") to
+"instance A Double", we get an error:
+
+   No instance for (A Integer "5")
+
+This is because the first defaulted type (Integer) has successfully satisfied
+its single-parameter constraints (in this case Num).
+-}
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcSplice.hs
@@ -0,0 +1,2195 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+TcSplice: Template Haskell splices
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module TcSplice(
+     tcSpliceExpr, tcTypedBracket, tcUntypedBracket,
+--     runQuasiQuoteExpr, runQuasiQuotePat,
+--     runQuasiQuoteDecl, runQuasiQuoteType,
+     runAnnotation,
+
+     runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,
+     tcTopSpliceExpr, lookupThName_maybe,
+     defaultRunMeta, runMeta', runRemoteModFinalizers,
+     finishTH, runTopSplice
+      ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import Annotations
+import Finder
+import Name
+import TcRnMonad
+import TcType
+
+import Outputable
+import TcExpr
+import SrcLoc
+import THNames
+import TcUnify
+import TcEnv
+import Coercion( etaExpandCoAxBranch )
+import FileCleanup ( newTempName, TempFileLifetime(..) )
+
+import Control.Monad
+
+import GHCi.Message
+import GHCi.RemoteTypes
+import GHCi
+import HscMain
+        -- These imports are the reason that TcSplice
+        -- is very high up the module hierarchy
+import FV
+import RnSplice( traceSplice, SpliceInfo(..))
+import RdrName
+import HscTypes
+import Convert
+import RnExpr
+import RnEnv
+import RnUtils ( HsDocContext(..) )
+import RnFixity ( lookupFixityRn_help )
+import RnTypes
+import TcHsSyn
+import TcSimplify
+import Type
+import NameSet
+import TcMType
+import TcHsType
+import TcIface
+import TyCoRep
+import FamInst
+import FamInstEnv
+import InstEnv
+import Inst
+import NameEnv
+import PrelNames
+import TysWiredIn
+import OccName
+import Hooks
+import Var
+import Module
+import LoadIface
+import Class
+import TyCon
+import CoAxiom
+import PatSyn
+import ConLike
+import DataCon
+import TcEvidence( TcEvBinds(..) )
+import Id
+import IdInfo
+import DsExpr
+import DsMonad
+import GHC.Serialized
+import ErrUtils
+import Util
+import Unique
+import VarSet
+import Data.List        ( find )
+import Data.Maybe
+import FastString
+import BasicTypes hiding( SuccessFlag(..) )
+import Maybes( MaybeErr(..) )
+import DynFlags
+import Panic
+import Lexeme
+import qualified EnumSet
+import Plugins
+import Bag
+
+import qualified Language.Haskell.TH as TH
+-- THSyntax gives access to internal functions and data types
+import qualified Language.Haskell.TH.Syntax as TH
+
+-- Because GHC.Desugar might not be in the base library of the bootstrapping compiler
+import GHC.Desugar      ( AnnotationWrapper(..) )
+
+import Control.Exception
+import Data.Binary
+import Data.Binary.Get
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as LB
+import Data.Dynamic  ( fromDynamic, toDyn )
+import qualified Data.Map as Map
+import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep )
+import Data.Data (Data)
+import Data.Proxy    ( Proxy (..) )
+import GHC.Exts         ( unsafeCoerce# )
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Main interface + stubs for the non-GHCI case
+*                                                                      *
+************************************************************************
+-}
+
+tcTypedBracket   :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)
+tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType
+                 -> TcM (HsExpr GhcTcId)
+tcSpliceExpr     :: HsSplice GhcRn  -> ExpRhoType -> TcM (HsExpr GhcTcId)
+        -- None of these functions add constraints to the LIE
+
+-- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)
+-- runQuasiQuotePat  :: HsQuasiQuote RdrName -> RnM (LPat RdrName)
+-- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName)
+-- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]
+
+runAnnotation     :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
+{-
+************************************************************************
+*                                                                      *
+\subsection{Quoting an expression}
+*                                                                      *
+************************************************************************
+-}
+
+-- See Note [How brackets and nested splices are handled]
+-- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)
+tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty
+  = addErrCtxt (quotationCtxtDoc brack) $
+    do { cur_stage <- getStage
+       ; ps_ref <- newMutVar []
+       ; lie_var <- getConstraintVar   -- Any constraints arising from nested splices
+                                       -- should get thrown into the constraint set
+                                       -- from outside the bracket
+
+       -- Typecheck expr to make sure it is valid,
+       -- Throw away the typechecked expression but return its type.
+       -- We'll typecheck it again when we splice it in somewhere
+       ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $
+                                tcInferRhoNC expr
+                                -- NC for no context; tcBracket does that
+
+       ; meta_ty <- tcTExpTy expr_ty
+       ; ps' <- readMutVar ps_ref
+       ; texpco <- tcLookupId unsafeTExpCoerceName
+       ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")
+                       rn_expr
+                       (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])
+                                      (noLoc (HsTcBracketOut noExt brack ps'))))
+                       meta_ty res_ty }
+tcTypedBracket _ other_brack _
+  = pprPanic "tcTypedBracket" (ppr other_brack)
+
+-- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId)
+tcUntypedBracket rn_expr brack ps res_ty
+  = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)
+       ; ps' <- mapM tcPendingSplice ps
+       ; meta_ty <- tcBrackTy brack
+       ; traceTc "tc_bracket done untyped" (ppr meta_ty)
+       ; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket")
+                       rn_expr (HsTcBracketOut noExt brack ps') meta_ty res_ty }
+
+---------------
+tcBrackTy :: HsBracket GhcRn -> TcM TcType
+tcBrackTy (VarBr {})  = tcMetaTy nameTyConName
+                                           -- Result type is Var (not Q-monadic)
+tcBrackTy (ExpBr {})  = tcMetaTy expQTyConName  -- Result type is ExpQ (= Q Exp)
+tcBrackTy (TypBr {})  = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)
+tcBrackTy (DecBrG {}) = tcMetaTy decsQTyConName -- Result type is Q [Dec]
+tcBrackTy (PatBr {})  = tcMetaTy patQTyConName  -- Result type is PatQ (= Q Pat)
+tcBrackTy (DecBrL {})   = panic "tcBrackTy: Unexpected DecBrL"
+tcBrackTy (TExpBr {})   = panic "tcUntypedBracket: Unexpected TExpBr"
+tcBrackTy (XBracket {}) = panic "tcUntypedBracket: Unexpected XBracket"
+
+---------------
+tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice
+tcPendingSplice (PendingRnSplice flavour splice_name expr)
+  = do { res_ty <- tcMetaTy meta_ty_name
+       ; expr' <- tcMonoExpr expr (mkCheckExpType res_ty)
+       ; return (PendingTcSplice splice_name expr') }
+  where
+     meta_ty_name = case flavour of
+                       UntypedExpSplice  -> expQTyConName
+                       UntypedPatSplice  -> patQTyConName
+                       UntypedTypeSplice -> typeQTyConName
+                       UntypedDeclSplice -> decsQTyConName
+
+---------------
+-- Takes a tau and returns the type Q (TExp tau)
+tcTExpTy :: TcType -> TcM TcType
+tcTExpTy exp_ty
+  = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)
+       ; q    <- tcLookupTyCon qTyConName
+       ; texp <- tcLookupTyCon tExpTyConName
+       ; return (mkTyConApp q [mkTyConApp texp [exp_ty]]) }
+  where
+    err_msg ty
+      = vcat [ text "Illegal polytype:" <+> ppr ty
+             , text "The type of a Typed Template Haskell expression must" <+>
+               text "not have any quantification." ]
+
+quotationCtxtDoc :: HsBracket GhcRn -> SDoc
+quotationCtxtDoc br_body
+  = hang (text "In the Template Haskell quotation")
+         2 (ppr br_body)
+
+
+  -- The whole of the rest of the file is the else-branch (ie stage2 only)
+
+{-
+Note [How top-level splices are handled]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Top-level splices (those not inside a [| .. |] quotation bracket) are handled
+very straightforwardly:
+
+  1. tcTopSpliceExpr: typecheck the body e of the splice $(e)
+
+  2. runMetaT: desugar, compile, run it, and convert result back to
+     HsSyn RdrName (of the appropriate flavour, eg HsType RdrName,
+     HsExpr RdrName etc)
+
+  3. treat the result as if that's what you saw in the first place
+     e.g for HsType, rename and kind-check
+         for HsExpr, rename and type-check
+
+     (The last step is different for decls, because they can *only* be
+      top-level: we return the result of step 2.)
+
+Note [How brackets and nested splices are handled]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Nested splices (those inside a [| .. |] quotation bracket),
+are treated quite differently.
+
+Remember, there are two forms of bracket
+         typed   [|| e ||]
+   and untyped   [|  e  |]
+
+The life cycle of a typed bracket:
+   * Starts as HsBracket
+
+   * When renaming:
+        * Set the ThStage to (Brack s RnPendingTyped)
+        * Rename the body
+        * Result is still a HsBracket
+
+   * When typechecking:
+        * Set the ThStage to (Brack s (TcPending ps_var lie_var))
+        * Typecheck the body, and throw away the elaborated result
+        * Nested splices (which must be typed) are typechecked, and
+          the results accumulated in ps_var; their constraints
+          accumulate in lie_var
+        * Result is a HsTcBracketOut rn_brack pending_splices
+          where rn_brack is the incoming renamed bracket
+
+The life cycle of a un-typed bracket:
+   * Starts as HsBracket
+
+   * When renaming:
+        * Set the ThStage to (Brack s (RnPendingUntyped ps_var))
+        * Rename the body
+        * Nested splices (which must be untyped) are renamed, and the
+          results accumulated in ps_var
+        * Result is still (HsRnBracketOut rn_body pending_splices)
+
+   * When typechecking a HsRnBracketOut
+        * Typecheck the pending_splices individually
+        * Ignore the body of the bracket; just check that the context
+          expects a bracket of that type (e.g. a [p| pat |] bracket should
+          be in a context needing a (Q Pat)
+        * Result is a HsTcBracketOut rn_brack pending_splices
+          where rn_brack is the incoming renamed bracket
+
+
+In both cases, desugaring happens like this:
+  * HsTcBracketOut is desugared by DsMeta.dsBracket.  It
+
+      a) Extends the ds_meta environment with the PendingSplices
+         attached to the bracket
+
+      b) Converts the quoted (HsExpr Name) to a CoreExpr that, when
+         run, will produce a suitable TH expression/type/decl.  This
+         is why we leave the *renamed* expression attached to the bracket:
+         the quoted expression should not be decorated with all the goop
+         added by the type checker
+
+  * Each splice carries a unique Name, called a "splice point", thus
+    ${n}(e).  The name is initialised to an (Unqual "splice") when the
+    splice is created; the renamer gives it a unique.
+
+  * When DsMeta (used to desugar the body of the bracket) comes across
+    a splice, it looks up the splice's Name, n, in the ds_meta envt,
+    to find an (HsExpr Id) that should be substituted for the splice;
+    it just desugars it to get a CoreExpr (DsMeta.repSplice).
+
+Example:
+    Source:       f = [| Just $(g 3) |]
+      The [| |] part is a HsBracket
+
+    Typechecked:  f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
+      The [| |] part is a HsBracketOut, containing *renamed*
+        (not typechecked) expression
+      The "s7" is the "splice point"; the (g Int 3) part
+        is a typechecked expression
+
+    Desugared:    f = do { s7 <- g Int 3
+                         ; return (ConE "Data.Maybe.Just" s7) }
+
+
+Note [Template Haskell state diagram]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here are the ThStages, s, their corresponding level numbers
+(the result of (thLevel s)), and their state transitions.
+The top level of the program is stage Comp:
+
+     Start here
+         |
+         V
+      -----------     $      ------------   $
+      |  Comp   | ---------> |  Splice  | -----|
+      |   1     |            |    0     | <----|
+      -----------            ------------
+        ^     |                ^      |
+      $ |     | [||]         $ |      | [||]
+        |     v                |      v
+   --------------          ----------------
+   | Brack Comp |          | Brack Splice |
+   |     2      |          |      1       |
+   --------------          ----------------
+
+* Normal top-level declarations start in state Comp
+       (which has level 1).
+  Annotations start in state Splice, since they are
+       treated very like a splice (only without a '$')
+
+* Code compiled in state Splice (and only such code)
+  will be *run at compile time*, with the result replacing
+  the splice
+
+* The original paper used level -1 instead of 0, etc.
+
+* The original paper did not allow a splice within a
+  splice, but there is no reason not to. This is the
+  $ transition in the top right.
+
+Note [Template Haskell levels]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* Imported things are impLevel (= 0)
+
+* However things at level 0 are not *necessarily* imported.
+      eg  $( \b -> ... )   here b is bound at level 0
+
+* In GHCi, variables bound by a previous command are treated
+  as impLevel, because we have bytecode for them.
+
+* Variables are bound at the "current level"
+
+* The current level starts off at outerLevel (= 1)
+
+* The level is decremented by splicing $(..)
+               incremented by brackets [| |]
+               incremented by name-quoting 'f
+
+When a variable is used, we compare
+        bind:  binding level, and
+        use:   current level at usage site
+
+  Generally
+        bind > use      Always error (bound later than used)
+                        [| \x -> $(f x) |]
+
+        bind = use      Always OK (bound same stage as used)
+                        [| \x -> $(f [| x |]) |]
+
+        bind < use      Inside brackets, it depends
+                        Inside splice, OK
+                        Inside neither, OK
+
+  For (bind < use) inside brackets, there are three cases:
+    - Imported things   OK      f = [| map |]
+    - Top-level things  OK      g = [| f |]
+    - Non-top-level     Only if there is a liftable instance
+                                h = \(x:Int) -> [| x |]
+
+  To track top-level-ness we use the ThBindEnv in TcLclEnv
+
+  For example:
+           f = ...
+           g1 = $(map ...)         is OK
+           g2 = $(f ...)           is not OK; because we havn't compiled f yet
+
+-}
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Splicing an expression}
+*                                                                      *
+************************************************************************
+-}
+
+tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty
+  = addErrCtxt (spliceCtxtDoc splice) $
+    setSrcSpan (getLoc expr)    $ do
+    { stage <- getStage
+    ; case stage of
+          Splice {}            -> tcTopSplice expr res_ty
+          Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty
+          RunSplice _          ->
+            -- See Note [RunSplice ThLevel] in "TcRnTypes".
+            pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++
+                      "running another splice") (ppr splice)
+          Comp                 -> tcTopSplice expr res_ty
+    }
+tcSpliceExpr splice _
+  = pprPanic "tcSpliceExpr" (ppr splice)
+
+{- Note [Collecting modFinalizers in typed splices]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local
+environment (see Note [Delaying modFinalizers in untyped splices] in
+"RnSplice"). Thus after executing the splice, we move the finalizers to the
+finalizer list in the global environment and set them to use the current local
+environment (with 'addModFinalizersWithLclEnv').
+
+-}
+
+tcNestedSplice :: ThStage -> PendingStuff -> Name
+                -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+    -- See Note [How brackets and nested splices are handled]
+    -- A splice inside brackets
+tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty
+  = do { res_ty <- expTypeToType res_ty
+       ; meta_exp_ty <- tcTExpTy res_ty
+       ; expr' <- setStage pop_stage $
+                  setConstraintVar lie_var $
+                  tcMonoExpr expr (mkCheckExpType meta_exp_ty)
+       ; untypeq <- tcLookupId unTypeQName
+       ; let expr'' = mkHsApp (nlHsTyApp untypeq [res_ty]) expr'
+       ; ps <- readMutVar ps_var
+       ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)
+
+       -- The returned expression is ignored; it's in the pending splices
+       ; return (panic "tcSpliceExpr") }
+
+tcNestedSplice _ _ splice_name _ _
+  = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name)
+
+tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
+tcTopSplice expr res_ty
+  = do { -- Typecheck the expression,
+         -- making sure it has type Q (T res_ty)
+         res_ty <- expTypeToType res_ty
+       ; meta_exp_ty <- tcTExpTy res_ty
+       ; q_expr <- tcTopSpliceExpr Typed $
+                          tcMonoExpr expr (mkCheckExpType meta_exp_ty)
+       ; lcl_env <- getLclEnv
+       ; let delayed_splice
+              = DelayedSplice lcl_env expr res_ty q_expr
+       ; return (HsSpliceE noExt (HsSplicedT delayed_splice))
+
+       }
+
+
+-- This is called in the zonker
+-- See Note [Running typed splices in the zonker]
+runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
+runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)
+  = setLclEnv lcl_env $ do {
+         zonked_ty <- zonkTcType res_ty
+       ; zonked_q_expr <- zonkTopLExpr q_expr
+        -- See Note [Collecting modFinalizers in typed splices].
+       ; modfinalizers_ref <- newTcRef []
+         -- Run the expression
+       ; expr2 <- setStage (RunSplice modfinalizers_ref) $
+                    runMetaE zonked_q_expr
+       ; mod_finalizers <- readTcRef modfinalizers_ref
+       ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers
+       -- We use orig_expr here and not q_expr when tracing as a call to
+       -- unsafeTExpCoerce is added to the original expression by the
+       -- typechecker when typed quotes are type checked.
+       ; traceSplice (SpliceInfo { spliceDescription = "expression"
+                                 , spliceIsDecl      = False
+                                 , spliceSource      = Just orig_expr
+                                 , spliceGenerated   = ppr expr2 })
+        -- Rename and typecheck the spliced-in expression,
+        -- making sure it has type res_ty
+        -- These steps should never fail; this is a *typed* splice
+       ; (res, wcs) <-
+            captureConstraints $
+              addErrCtxt (spliceResultDoc zonked_q_expr) $ do
+                { (exp3, _fvs) <- rnLExpr expr2
+                ; tcMonoExpr exp3 (mkCheckExpType zonked_ty)}
+       ; ev <- simplifyTop wcs
+       ; return $ unLoc (mkHsDictLet (EvBinds ev) res)
+       }
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Error messages}
+*                                                                      *
+************************************************************************
+-}
+
+spliceCtxtDoc :: HsSplice GhcRn -> SDoc
+spliceCtxtDoc splice
+  = hang (text "In the Template Haskell splice")
+         2 (pprSplice splice)
+
+spliceResultDoc :: LHsExpr GhcTc -> SDoc
+spliceResultDoc expr
+  = sep [ text "In the result of the splice:"
+        , nest 2 (char '$' <> ppr expr)
+        , text "To see what the splice expanded to, use -ddump-splices"]
+
+-------------------
+tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)
+-- Note [How top-level splices are handled]
+-- Type check an expression that is the body of a top-level splice
+--   (the caller will compile and run it)
+-- Note that set the level to Splice, regardless of the original level,
+-- before typechecking the expression.  For example:
+--      f x = $( ...$(g 3) ... )
+-- The recursive call to tcPolyExpr will simply expand the
+-- inner escape before dealing with the outer one
+
+tcTopSpliceExpr isTypedSplice tc_action
+  = checkNoErrs $  -- checkNoErrs: must not try to run the thing
+                   -- if the type checker fails!
+    unsetGOptM Opt_DeferTypeErrors $
+                   -- Don't defer type errors.  Not only are we
+                   -- going to run this code, but we do an unsafe
+                   -- coerce, so we get a seg-fault if, say we
+                   -- splice a type into a place where an expression
+                   -- is expected (Trac #7276)
+    setStage (Splice isTypedSplice) $
+    do {    -- Typecheck the expression
+         (expr', wanted) <- captureConstraints tc_action
+       ; const_binds     <- simplifyTop wanted
+
+          -- Zonk it and tie the knot of dictionary bindings
+       ; return $ mkHsDictLet (EvBinds const_binds) expr' }
+
+{-
+************************************************************************
+*                                                                      *
+        Annotations
+*                                                                      *
+************************************************************************
+-}
+
+runAnnotation target expr = do
+    -- Find the classes we want instances for in order to call toAnnotationWrapper
+    loc <- getSrcSpanM
+    data_class <- tcLookupClass dataClassName
+    to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName
+
+    -- Check the instances we require live in another module (we want to execute it..)
+    -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr
+    -- also resolves the LIE constraints to detect e.g. instance ambiguity
+    zonked_wrapped_expr' <- zonkTopLExpr =<< tcTopSpliceExpr Untyped (
+           do { (expr', expr_ty) <- tcInferRhoNC expr
+                -- We manually wrap the typechecked expression in a call to toAnnotationWrapper
+                -- By instantiating the call >here< it gets registered in the
+                -- LIE consulted by tcTopSpliceExpr
+                -- and hence ensures the appropriate dictionary is bound by const_binds
+              ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]
+              ; let specialised_to_annotation_wrapper_expr
+                      = L loc (mkHsWrap wrapper
+                                 (HsVar noExt (L loc to_annotation_wrapper_id)))
+              ; return (L loc (HsApp noExt
+                                specialised_to_annotation_wrapper_expr expr'))
+                                })
+
+    -- Run the appropriately wrapped expression to get the value of
+    -- the annotation and its dictionaries. The return value is of
+    -- type AnnotationWrapper by construction, so this conversion is
+    -- safe
+    serialized <- runMetaAW zonked_wrapped_expr'
+    return Annotation {
+               ann_target = target,
+               ann_value = serialized
+           }
+
+convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized)
+convertAnnotationWrapper fhv = do
+  dflags <- getDynFlags
+  if gopt Opt_ExternalInterpreter dflags
+    then do
+      Right <$> runTH THAnnWrapper fhv
+    else do
+      annotation_wrapper <- liftIO $ wormhole dflags fhv
+      return $ Right $
+        case unsafeCoerce# annotation_wrapper of
+           AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->
+               -- Got the value and dictionaries: build the serialized value and
+               -- call it a day. We ensure that we seq the entire serialized value
+               -- in order that any errors in the user-written code for the
+               -- annotation are exposed at this point.  This is also why we are
+               -- doing all this stuff inside the context of runMeta: it has the
+               -- facilities to deal with user error in a meta-level expression
+               seqSerialized serialized `seq` serialized
+
+-- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
+seqSerialized :: Serialized -> ()
+seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Running an expression}
+*                                                                      *
+************************************************************************
+-}
+
+runQuasi :: TH.Q a -> TcM a
+runQuasi act = TH.runQ act
+
+runRemoteModFinalizers :: ThModFinalizers -> TcM ()
+runRemoteModFinalizers (ThModFinalizers finRefs) = do
+  dflags <- getDynFlags
+  let withForeignRefs [] f = f []
+      withForeignRefs (x : xs) f = withForeignRef x $ \r ->
+        withForeignRefs xs $ \rs -> f (r : rs)
+  if gopt Opt_ExternalInterpreter dflags then do
+    hsc_env <- env_top <$> getEnv
+    withIServ hsc_env $ \i -> do
+      tcg <- getGblEnv
+      th_state <- readTcRef (tcg_th_remote_state tcg)
+      case th_state of
+        Nothing -> return () -- TH was not started, nothing to do
+        Just fhv -> do
+          liftIO $ withForeignRef fhv $ \st ->
+            withForeignRefs finRefs $ \qrefs ->
+              writeIServ i (putMessage (RunModFinalizers st qrefs))
+          () <- runRemoteTH i []
+          readQResult i
+  else do
+    qs <- liftIO (withForeignRefs finRefs $ mapM localRef)
+    runQuasi $ sequence_ qs
+
+runQResult
+  :: (a -> String)
+  -> (SrcSpan -> a -> b)
+  -> (ForeignHValue -> TcM a)
+  -> SrcSpan
+  -> ForeignHValue {- TH.Q a -}
+  -> TcM b
+runQResult show_th f runQ expr_span hval
+  = do { th_result <- runQ hval
+       ; traceTc "Got TH result:" (text (show_th th_result))
+       ; return (f expr_span th_result) }
+
+
+-----------------
+runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn)
+        -> LHsExpr GhcTc
+        -> TcM hs_syn
+runMeta unwrap e
+  = do { h <- getHooked runMetaHook defaultRunMeta
+       ; unwrap h e }
+
+defaultRunMeta :: MetaHook TcM
+defaultRunMeta (MetaE r)
+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp)
+defaultRunMeta (MetaP r)
+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat)
+defaultRunMeta (MetaT r)
+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType)
+defaultRunMeta (MetaD r)
+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec)
+defaultRunMeta (MetaAW r)
+  = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper)
+    -- We turn off showing the code in meta-level exceptions because doing so exposes
+    -- the toAnnotationWrapper function that we slap around the user's code
+
+----------------
+runMetaAW :: LHsExpr GhcTc         -- Of type AnnotationWrapper
+          -> TcM Serialized
+runMetaAW = runMeta metaRequestAW
+
+runMetaE :: LHsExpr GhcTc          -- Of type (Q Exp)
+         -> TcM (LHsExpr GhcPs)
+runMetaE = runMeta metaRequestE
+
+runMetaP :: LHsExpr GhcTc          -- Of type (Q Pat)
+         -> TcM (LPat GhcPs)
+runMetaP = runMeta metaRequestP
+
+runMetaT :: LHsExpr GhcTc          -- Of type (Q Type)
+         -> TcM (LHsType GhcPs)
+runMetaT = runMeta metaRequestT
+
+runMetaD :: LHsExpr GhcTc          -- Of type Q [Dec]
+         -> TcM [LHsDecl GhcPs]
+runMetaD = runMeta metaRequestD
+
+---------------
+runMeta' :: Bool                 -- Whether code should be printed in the exception message
+         -> (hs_syn -> SDoc)                                    -- how to print the code
+         -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn))        -- How to run x
+         -> LHsExpr GhcTc        -- Of type x; typically x = Q TH.Exp, or
+                                 --    something like that
+         -> TcM hs_syn           -- Of type t
+runMeta' show_code ppr_hs run_and_convert expr
+  = do  { traceTc "About to run" (ppr expr)
+        ; recordThSpliceUse -- seems to be the best place to do this,
+                            -- we catch all kinds of splices and annotations.
+
+        -- Check that we've had no errors of any sort so far.
+        -- For example, if we found an error in an earlier defn f, but
+        -- recovered giving it type f :: forall a.a, it'd be very dodgy
+        -- to carry ont.  Mind you, the staging restrictions mean we won't
+        -- actually run f, but it still seems wrong. And, more concretely,
+        -- see Trac #5358 for an example that fell over when trying to
+        -- reify a function with a "?" kind in it.  (These don't occur
+        -- in type-correct programs.
+        ; failIfErrsM
+
+        -- run plugins
+        ; hsc_env <- getTopEnv
+        ; expr' <- withPlugins (hsc_dflags hsc_env) spliceRunAction expr
+
+        -- Desugar
+        ; ds_expr <- initDsTc (dsLExpr expr')
+        -- Compile and link it; might fail if linking fails
+        ; src_span <- getSrcSpanM
+        ; traceTc "About to run (desugared)" (ppr ds_expr)
+        ; either_hval <- tryM $ liftIO $
+                         HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
+        ; case either_hval of {
+            Left exn   -> fail_with_exn "compile and link" exn ;
+            Right hval -> do
+
+        {       -- Coerce it to Q t, and run it
+
+                -- Running might fail if it throws an exception of any kind (hence tryAllM)
+                -- including, say, a pattern-match exception in the code we are running
+                --
+                -- We also do the TH -> HS syntax conversion inside the same
+                -- exception-cacthing thing so that if there are any lurking
+                -- exceptions in the data structure returned by hval, we'll
+                -- encounter them inside the try
+                --
+                -- See Note [Exceptions in TH]
+          let expr_span = getLoc expr
+        ; either_tval <- tryAllM $
+                         setSrcSpan expr_span $ -- Set the span so that qLocation can
+                                                -- see where this splice is
+             do { mb_result <- run_and_convert expr_span hval
+                ; case mb_result of
+                    Left err     -> failWithTc err
+                    Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)
+                                       ; return $! result } }
+
+        ; case either_tval of
+            Right v -> return v
+            Left se -> case fromException se of
+                         Just IOEnvFailure -> failM -- Error already in Tc monad
+                         _ -> fail_with_exn "run" se -- Exception
+        }}}
+  where
+    -- see Note [Concealed TH exceptions]
+    fail_with_exn :: Exception e => String -> e -> TcM a
+    fail_with_exn phase exn = do
+        exn_msg <- liftIO $ Panic.safeShowException exn
+        let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",
+                        nest 2 (text exn_msg),
+                        if show_code then text "Code:" <+> ppr expr else empty]
+        failWithTc msg
+
+{-
+Note [Running typed splices in the zonker]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+See #15471 for the full discussion.
+
+For many years typed splices were run immediately after they were type checked
+however, this is too early as it means to zonk some type variables before
+they can be unified with type variables in the surrounding context.
+
+For example,
+
+```
+module A where
+
+test_foo :: forall a . Q (TExp (a -> a))
+test_foo = [|| id ||]
+
+module B where
+
+import A
+
+qux = $$(test_foo)
+```
+
+We would expect `qux` to have inferred type `forall a . a -> a` but if
+we run the splices too early the unified variables are zonked to `Any`. The
+inferred type is the unusable `Any -> Any`.
+
+To run the splice, we must compile `test_foo` all the way to byte code.
+But at the moment when the type checker is looking at the splice, test_foo
+has type `Q (TExp (alpha -> alpha))` and we
+certainly can't compile code involving unification variables!
+
+We could default `alpha` to `Any` but then we infer `qux :: Any -> Any`
+which definitely is not what we want.  Moreover, if we had
+  qux = [$$(test_foo), (\x -> x +1::Int)]
+then `alpha` would have to be `Int`.
+
+Conclusion: we must defer taking decisions about `alpha` until the
+typechecker is done; and *then* we can run the splice.  It's fine to do it
+later, because we know it'll produce type-correct code.
+
+Deferring running the splice until later, in the zonker, means that the
+unification variables propagate upwards from the splice into the surrounding
+context and are unified correctly.
+
+This is implemented by storing the arguments we need for running the splice
+in a `DelayedSplice`. In the zonker, the arguments are passed to
+`TcSplice.runTopSplice` and the expression inserted into the AST as normal.
+
+
+
+Note [Exceptions in TH]
+~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have something like this
+        $( f 4 )
+where
+        f :: Int -> Q [Dec]
+        f n | n>3       = fail "Too many declarations"
+            | otherwise = ...
+
+The 'fail' is a user-generated failure, and should be displayed as a
+perfectly ordinary compiler error message, not a panic or anything
+like that.  Here's how it's processed:
+
+  * 'fail' is the monad fail.  The monad instance for Q in TH.Syntax
+    effectively transforms (fail s) to
+        qReport True s >> fail
+    where 'qReport' comes from the Quasi class and fail from its monad
+    superclass.
+
+  * The TcM monad is an instance of Quasi (see TcSplice), and it implements
+    (qReport True s) by using addErr to add an error message to the bag of errors.
+    The 'fail' in TcM raises an IOEnvFailure exception
+
+ * 'qReport' forces the message to ensure any exception hidden in unevaluated
+   thunk doesn't get into the bag of errors. Otherwise the following splice
+   will triger panic (Trac #8987):
+        $(fail undefined)
+   See also Note [Concealed TH exceptions]
+
+  * So, when running a splice, we catch all exceptions; then for
+        - an IOEnvFailure exception, we assume the error is already
+                in the error-bag (above)
+        - other errors, we add an error to the bag
+    and then fail
+
+Note [Concealed TH exceptions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When displaying the error message contained in an exception originated from TH
+code, we need to make sure that the error message itself does not contain an
+exception.  For example, when executing the following splice:
+
+    $( error ("foo " ++ error "bar") )
+
+the message for the outer exception is a thunk which will throw the inner
+exception when evaluated.
+
+For this reason, we display the message of a TH exception using the
+'safeShowException' function, which recursively catches any exception thrown
+when showing an error message.
+
+
+To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
+-}
+
+instance TH.Quasi TcM where
+  qNewName s = do { u <- newUnique
+                  ; let i = getKey u
+                  ; return (TH.mkNameU s i) }
+
+  -- 'msg' is forced to ensure exceptions don't escape,
+  -- see Note [Exceptions in TH]
+  qReport True msg  = seqList msg $ addErr  (text msg)
+  qReport False msg = seqList msg $ addWarn NoReason (text msg)
+
+  qLocation = do { m <- getModule
+                 ; l <- getSrcSpanM
+                 ; r <- case l of
+                        UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
+                                                    (ppr l)
+                        RealSrcSpan s -> return s
+                 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
+                                  , TH.loc_module   = moduleNameString (moduleName m)
+                                  , TH.loc_package  = unitIdString (moduleUnitId m)
+                                  , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
+                                  , TH.loc_end = (srcSpanEndLine   r, srcSpanEndCol   r) }) }
+
+  qLookupName       = lookupName
+  qReify            = reify
+  qReifyFixity nm   = lookupThName nm >>= reifyFixity
+  qReifyInstances   = reifyInstances
+  qReifyRoles       = reifyRoles
+  qReifyAnnotations = reifyAnnotations
+  qReifyModule      = reifyModule
+  qReifyConStrictness nm = do { nm' <- lookupThName nm
+                              ; dc  <- tcLookupDataCon nm'
+                              ; let bangs = dataConImplBangs dc
+                              ; return (map reifyDecidedStrictness bangs) }
+
+        -- For qRecover, discard error messages if
+        -- the recovery action is chosen.  Otherwise
+        -- we'll only fail higher up.
+  qRecover recover main = tryTcDiscardingErrs recover main
+
+  qAddDependentFile fp = do
+    ref <- fmap tcg_dependent_files getGblEnv
+    dep_files <- readTcRef ref
+    writeTcRef ref (fp:dep_files)
+
+  qAddTempFile suffix = do
+    dflags <- getDynFlags
+    liftIO $ newTempName dflags TFL_GhcSession suffix
+
+  qAddTopDecls thds = do
+      l <- getSrcSpanM
+      let either_hval = convertToHsDecls l thds
+      ds <- case either_hval of
+              Left exn -> failWithTc $
+                hang (text "Error in a declaration passed to addTopDecls:")
+                   2 exn
+              Right ds -> return ds
+      mapM_ (checkTopDecl . unLoc) ds
+      th_topdecls_var <- fmap tcg_th_topdecls getGblEnv
+      updTcRef th_topdecls_var (\topds -> ds ++ topds)
+    where
+      checkTopDecl :: HsDecl GhcPs -> TcM ()
+      checkTopDecl (ValD _ binds)
+        = mapM_ bindName (collectHsBindBinders binds)
+      checkTopDecl (SigD _ _)
+        = return ()
+      checkTopDecl (AnnD _ _)
+        = return ()
+      checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name }))
+        = bindName name
+      checkTopDecl _
+        = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"
+
+      bindName :: RdrName -> TcM ()
+      bindName (Exact n)
+        = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
+             ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)
+             }
+
+      bindName name =
+          addErr $
+          hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU."))
+             2 (text "Probable cause: you used mkName instead of newName to generate a binding.")
+
+  qAddForeignFilePath lang fp = do
+    var <- fmap tcg_th_foreign_files getGblEnv
+    updTcRef var ((lang, fp) :)
+
+  qAddModFinalizer fin = do
+      r <- liftIO $ mkRemoteRef fin
+      fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
+      addModFinalizerRef fref
+
+  qAddCorePlugin plugin = do
+      hsc_env <- env_top <$> getEnv
+      r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin)
+      let err = hang
+            (text "addCorePlugin: invalid plugin module "
+               <+> text (show plugin)
+            )
+            2
+            (text "Plugins in the current package can't be specified.")
+      case r of
+        Found {} -> addErr err
+        FoundMultiple {} -> addErr err
+        _ -> return ()
+      th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
+      updTcRef th_coreplugins_var (plugin:)
+
+  qGetQ :: forall a. Typeable a => TcM (Maybe a)
+  qGetQ = do
+      th_state_var <- fmap tcg_th_state getGblEnv
+      th_state <- readTcRef th_state_var
+      -- See #10596 for why we use a scoped type variable here.
+      return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)
+
+  qPutQ x = do
+      th_state_var <- fmap tcg_th_state getGblEnv
+      updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)
+
+  qIsExtEnabled = xoptM
+
+  qExtsEnabled =
+    EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv
+
+-- | Adds a mod finalizer reference to the local environment.
+addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM ()
+addModFinalizerRef finRef = do
+    th_stage <- getStage
+    case th_stage of
+      RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :)
+      -- This case happens only if a splice is executed and the caller does
+      -- not set the 'ThStage' to 'RunSplice' to collect finalizers.
+      -- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
+      _ ->
+        pprPanic "addModFinalizer was called when no finalizers were collected"
+                 (ppr th_stage)
+
+-- | Releases the external interpreter state.
+finishTH :: TcM ()
+finishTH = do
+  dflags <- getDynFlags
+  when (gopt Opt_ExternalInterpreter dflags) $ do
+    tcg <- getGblEnv
+    writeTcRef (tcg_th_remote_state tcg) Nothing
+
+runTHExp :: ForeignHValue -> TcM TH.Exp
+runTHExp = runTH THExp
+
+runTHPat :: ForeignHValue -> TcM TH.Pat
+runTHPat = runTH THPat
+
+runTHType :: ForeignHValue -> TcM TH.Type
+runTHType = runTH THType
+
+runTHDec :: ForeignHValue -> TcM [TH.Dec]
+runTHDec = runTH THDec
+
+runTH :: Binary a => THResultType -> ForeignHValue -> TcM a
+runTH ty fhv = do
+  hsc_env <- env_top <$> getEnv
+  dflags <- getDynFlags
+  if not (gopt Opt_ExternalInterpreter dflags)
+    then do
+       -- Run it in the local TcM
+      hv <- liftIO $ wormhole dflags fhv
+      r <- runQuasi (unsafeCoerce# hv :: TH.Q a)
+      return r
+    else
+      -- Run it on the server.  For an overview of how TH works with
+      -- Remote GHCi, see Note [Remote Template Haskell] in
+      -- libraries/ghci/GHCi/TH.hs.
+      withIServ hsc_env $ \i -> do
+        rstate <- getTHState i
+        loc <- TH.qLocation
+        liftIO $
+          withForeignRef rstate $ \state_hv ->
+          withForeignRef fhv $ \q_hv ->
+            writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc)))
+        runRemoteTH i []
+        bs <- readQResult i
+        return $! runGet get (LB.fromStrict bs)
+
+
+-- | communicate with a remotely-running TH computation until it finishes.
+-- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.
+runRemoteTH
+  :: IServ
+  -> [Messages]   --  saved from nested calls to qRecover
+  -> TcM ()
+runRemoteTH iserv recovers = do
+  THMsg msg <- liftIO $ readIServ iserv getTHMessage
+  case msg of
+    RunTHDone -> return ()
+    StartRecover -> do -- Note [TH recover with -fexternal-interpreter]
+      v <- getErrsVar
+      msgs <- readTcRef v
+      writeTcRef v emptyMessages
+      runRemoteTH iserv (msgs : recovers)
+    EndRecover caught_error -> do
+      let (prev_msgs@(prev_warns,prev_errs), rest) = case recovers of
+             [] -> panic "EndRecover"
+             a : b -> (a,b)
+      v <- getErrsVar
+      (warn_msgs,_) <- readTcRef v
+      -- keep the warnings only if there were no errors
+      writeTcRef v $ if caught_error
+        then prev_msgs
+        else (prev_warns `unionBags` warn_msgs, prev_errs)
+      runRemoteTH iserv rest
+    _other -> do
+      r <- handleTHMessage msg
+      liftIO $ writeIServ iserv (put r)
+      runRemoteTH iserv recovers
+
+-- | Read a value of type QResult from the iserv
+readQResult :: Binary a => IServ -> TcM a
+readQResult i = do
+  qr <- liftIO $ readIServ i get
+  case qr of
+    QDone a -> return a
+    QException str -> liftIO $ throwIO (ErrorCall str)
+    QFail str -> fail str
+
+{- Note [TH recover with -fexternal-interpreter]
+
+Recover is slightly tricky to implement.
+
+The meaning of "recover a b" is
+ - Do a
+   - If it finished with no errors, then keep the warnings it generated
+   - If it failed, discard any messages it generated, and do b
+
+Note that "failed" here can mean either
+  (1) threw an exception (failTc)
+  (2) generated an error message (addErrTcM)
+
+The messages are managed by GHC in the TcM monad, whereas the
+exception-handling is done in the ghc-iserv process, so we have to
+coordinate between the two.
+
+On the server:
+  - emit a StartRecover message
+  - run "a; FailIfErrs" inside a try
+  - emit an (EndRecover x) message, where x = True if "a; FailIfErrs" failed
+  - if "a; FailIfErrs" failed, run "b"
+
+Back in GHC, when we receive:
+
+  FailIfErrrs
+    failTc if there are any error messages (= failIfErrsM)
+  StartRecover
+    save the current messages and start with an empty set.
+  EndRecover caught_error
+    Restore the previous messages,
+    and merge in the new messages if caught_error is false.
+-}
+
+-- | Retrieve (or create, if it hasn't been created already), the
+-- remote TH state.  The TH state is a remote reference to an IORef
+-- QState living on the server, and we have to pass this to each RunTH
+-- call we make.
+--
+-- The TH state is stored in tcg_th_remote_state in the TcGblEnv.
+--
+getTHState :: IServ -> TcM (ForeignRef (IORef QState))
+getTHState i = do
+  tcg <- getGblEnv
+  th_state <- readTcRef (tcg_th_remote_state tcg)
+  case th_state of
+    Just rhv -> return rhv
+    Nothing -> do
+      hsc_env <- env_top <$> getEnv
+      fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH
+      writeTcRef (tcg_th_remote_state tcg) (Just fhv)
+      return fhv
+
+wrapTHResult :: TcM a -> TcM (THResult a)
+wrapTHResult tcm = do
+  e <- tryM tcm   -- only catch 'fail', treat everything else as catastrophic
+  case e of
+    Left e -> return (THException (show e))
+    Right a -> return (THComplete a)
+
+handleTHMessage :: THMessage a -> TcM a
+handleTHMessage msg = case msg of
+  NewName a -> wrapTHResult $ TH.qNewName a
+  Report b str -> wrapTHResult $ TH.qReport b str
+  LookupName b str -> wrapTHResult $ TH.qLookupName b str
+  Reify n -> wrapTHResult $ TH.qReify n
+  ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n
+  ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts
+  ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n
+  ReifyAnnotations lookup tyrep ->
+    wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)
+  ReifyModule m -> wrapTHResult $ TH.qReifyModule m
+  ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm
+  AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f
+  AddTempFile s -> wrapTHResult $ TH.qAddTempFile s
+  AddModFinalizer r -> do
+    hsc_env <- env_top <$> getEnv
+    wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef
+  AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
+  AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
+  AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
+  IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
+  ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
+  FailIfErrs -> wrapTHResult failIfErrsM
+  _ -> panic ("handleTHMessage: unexpected message " ++ show msg)
+
+getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]]
+getAnnotationsByTypeRep th_name tyrep
+  = do { name <- lookupThAnnLookup th_name
+       ; topEnv <- getTopEnv
+       ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
+       ; tcg <- getGblEnv
+       ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep
+       ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep
+       ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
+
+{-
+************************************************************************
+*                                                                      *
+            Instance Testing
+*                                                                      *
+************************************************************************
+-}
+
+reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec]
+reifyInstances th_nm th_tys
+   = addErrCtxt (text "In the argument of reifyInstances:"
+                 <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $
+     do { loc <- getSrcSpanM
+        ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys)
+          -- #9262 says to bring vars into scope, like in HsForAllTy case
+          -- of rnHsTyKi
+        ; let tv_rdrs = freeKiTyVarsAllVars (extractHsTyRdrTyVars rdr_ty)
+          -- Rename  to HsType Name
+        ; ((tv_names, rn_ty), _fvs)
+            <- checkNoErrs $ -- If there are out-of-scope Names here, then we
+                             -- must error before proceeding to typecheck the
+                             -- renamed type, as that will result in GHC
+                             -- internal errors (#13837).
+               bindLRdrNames tv_rdrs $ \ tv_names ->
+               do { (rn_ty, fvs) <- rnLHsType doc rdr_ty
+                  ; return ((tv_names, rn_ty), fvs) }
+        ; (_tvs, ty)
+            <- pushTcLevelM_   $
+               solveEqualities $ -- Avoid error cascade if there are unsolved
+               bindImplicitTKBndrs_Skol tv_names $
+               fst <$> tcLHsType rn_ty
+        ; ty <- zonkTcTypeToType ty
+                -- Substitute out the meta type variables
+                -- In particular, the type might have kind
+                -- variables inside it (Trac #7477)
+
+        ; traceTc "reifyInstances" (ppr ty $$ ppr (tcTypeKind ty))
+        ; case splitTyConApp_maybe ty of   -- This expands any type synonyms
+            Just (tc, tys)                 -- See Trac #7910
+               | Just cls <- tyConClass_maybe tc
+               -> do { inst_envs <- tcGetInstEnvs
+                     ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys
+                     ; traceTc "reifyInstances1" (ppr matches)
+                     ; reifyClassInstances cls (map fst matches ++ unifies) }
+               | isOpenFamilyTyCon tc
+               -> do { inst_envs <- tcGetFamInstEnvs
+                     ; let matches = lookupFamInstEnv inst_envs tc tys
+                     ; traceTc "reifyInstances2" (ppr matches)
+                     ; reifyFamilyInstances tc (map fim_instance matches) }
+            _  -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty))
+                               2 (text "is not a class constraint or type family application")) }
+  where
+    doc = ClassInstanceCtx
+    bale_out msg = failWithTc msg
+
+    cvt :: SrcSpan -> TH.Type -> TcM (LHsType GhcPs)
+    cvt loc th_ty = case convertToHsType loc th_ty of
+                      Left msg -> failWithTc msg
+                      Right ty -> return ty
+
+{-
+************************************************************************
+*                                                                      *
+                        Reification
+*                                                                      *
+************************************************************************
+-}
+
+lookupName :: Bool      -- True  <=> type namespace
+                        -- False <=> value namespace
+           -> String -> TcM (Maybe TH.Name)
+lookupName is_type_name s
+  = do { lcl_env <- getLocalRdrEnv
+       ; case lookupLocalRdrEnv lcl_env rdr_name of
+           Just n  -> return (Just (reifyName n))
+           Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name
+                         ; return (fmap reifyName mb_nm) } }
+  where
+    th_name = TH.mkName s       -- Parses M.x into a base of 'x' and a module of 'M'
+
+    occ_fs :: FastString
+    occ_fs = mkFastString (TH.nameBase th_name)
+
+    occ :: OccName
+    occ | is_type_name
+        = if isLexVarSym occ_fs || isLexCon occ_fs
+                             then mkTcOccFS    occ_fs
+                             else mkTyVarOccFS occ_fs
+        | otherwise
+        = if isLexCon occ_fs then mkDataOccFS occ_fs
+                             else mkVarOccFS  occ_fs
+
+    rdr_name = case TH.nameModule th_name of
+                 Nothing  -> mkRdrUnqual occ
+                 Just mod -> mkRdrQual (mkModuleName mod) occ
+
+getThing :: TH.Name -> TcM TcTyThing
+getThing th_name
+  = do  { name <- lookupThName th_name
+        ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)
+        ; tcLookupTh name }
+        -- ToDo: this tcLookup could fail, which would give a
+        --       rather unhelpful error message
+  where
+    ppr_ns (TH.Name _ (TH.NameG TH.DataName  _pkg _mod)) = text "data"
+    ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
+    ppr_ns (TH.Name _ (TH.NameG TH.VarName   _pkg _mod)) = text "var"
+    ppr_ns _ = panic "reify/ppr_ns"
+
+reify :: TH.Name -> TcM TH.Info
+reify th_name
+  = do  { traceTc "reify 1" (text (TH.showName th_name))
+        ; thing <- getThing th_name
+        ; traceTc "reify 2" (ppr thing)
+        ; reifyThing thing }
+
+lookupThName :: TH.Name -> TcM Name
+lookupThName th_name = do
+    mb_name <- lookupThName_maybe th_name
+    case mb_name of
+        Nothing   -> failWithTc (notInScope th_name)
+        Just name -> return name
+
+lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
+lookupThName_maybe th_name
+  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)
+          -- Pick the first that works
+          -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A
+        ; return (listToMaybe names) }
+  where
+    lookup rdr_name
+        = do {  -- Repeat much of lookupOccRn, because we want
+                -- to report errors in a TH-relevant way
+             ; rdr_env <- getLocalRdrEnv
+             ; case lookupLocalRdrEnv rdr_env rdr_name of
+                 Just name -> return (Just name)
+                 Nothing   -> lookupGlobalOccRn_maybe rdr_name }
+
+tcLookupTh :: Name -> TcM TcTyThing
+-- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
+-- it gives a reify-related error message on failure, whereas in the normal
+-- tcLookup, failure is a bug.
+tcLookupTh name
+  = do  { (gbl_env, lcl_env) <- getEnvs
+        ; case lookupNameEnv (tcl_env lcl_env) name of {
+                Just thing -> return thing;
+                Nothing    ->
+
+          case lookupNameEnv (tcg_type_env gbl_env) name of {
+                Just thing -> return (AGlobal thing);
+                Nothing    ->
+
+          -- EZY: I don't think this choice matters, no TH in signatures!
+          if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name
+          then  -- It's defined in this module
+                failWithTc (notInEnv name)
+
+          else
+     do { mb_thing <- tcLookupImported_maybe name
+        ; case mb_thing of
+            Succeeded thing -> return (AGlobal thing)
+            Failed msg      -> failWithTc msg
+    }}}}
+
+notInScope :: TH.Name -> SDoc
+notInScope th_name = quotes (text (TH.pprint th_name)) <+>
+                     text "is not in scope at a reify"
+        -- Ugh! Rather an indirect way to display the name
+
+notInEnv :: Name -> SDoc
+notInEnv name = quotes (ppr name) <+>
+                     text "is not in the type environment at a reify"
+
+------------------------------
+reifyRoles :: TH.Name -> TcM [TH.Role]
+reifyRoles th_name
+  = do { thing <- getThing th_name
+       ; case thing of
+           AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))
+           _ -> failWithTc (text "No roles associated with" <+> (ppr thing))
+       }
+  where
+    reify_role Nominal          = TH.NominalR
+    reify_role Representational = TH.RepresentationalR
+    reify_role Phantom          = TH.PhantomR
+
+------------------------------
+reifyThing :: TcTyThing -> TcM TH.Info
+-- The only reason this is monadic is for error reporting,
+-- which in turn is mainly for the case when TH can't express
+-- some random GHC extension
+
+reifyThing (AGlobal (AnId id))
+  = do  { ty <- reifyType (idType id)
+        ; let v = reifyName id
+        ; case idDetails id of
+            ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls))
+            RecSelId{sel_tycon=RecSelData tc}
+                          -> return (TH.VarI (reifySelector id tc) ty Nothing)
+            _             -> return (TH.VarI     v ty Nothing)
+    }
+
+reifyThing (AGlobal (ATyCon tc))   = reifyTyCon tc
+reifyThing (AGlobal (AConLike (RealDataCon dc)))
+  = do  { let name = dataConName dc
+        ; ty <- reifyType (idType (dataConWrapId dc))
+        ; return (TH.DataConI (reifyName name) ty
+                              (reifyName (dataConOrigTyCon dc)))
+        }
+
+reifyThing (AGlobal (AConLike (PatSynCon ps)))
+  = do { let name = reifyName ps
+       ; ty <- reifyPatSynType (patSynSig ps)
+       ; return (TH.PatSynI name ty) }
+
+reifyThing (ATcId {tct_id = id})
+  = do  { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
+                                        -- though it may be incomplete
+        ; ty2 <- reifyType ty1
+        ; return (TH.VarI (reifyName id) ty2 Nothing) }
+
+reifyThing (ATyVar tv tv1)
+  = do { ty1 <- zonkTcTyVar tv1
+       ; ty2 <- reifyType ty1
+       ; return (TH.TyVarI (reifyName tv) ty2) }
+
+reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)
+
+-------------------------------------------
+reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn
+reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs
+                                 , cab_lhs = lhs
+                                 , cab_rhs = rhs })
+            -- remove kind patterns (#8884)
+  = do { tvs' <- reifyTyVarsToMaybe tvs
+       ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
+       ; lhs' <- reifyTypes lhs_types_only
+       ; annot_th_lhs <- zipWith3M annotThType (mkIsPolyTvs fam_tvs)
+                                   lhs_types_only lhs'
+       ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs
+       ; rhs'  <- reifyType rhs
+       ; return (TH.TySynEqn tvs' lhs_type rhs') }
+  where
+    fam_tvs = tyConVisibleTyVars fam_tc
+
+reifyTyCon :: TyCon -> TcM TH.Info
+reifyTyCon tc
+  | Just cls <- tyConClass_maybe tc
+  = reifyClass cls
+
+  | isFunTyCon tc
+  = return (TH.PrimTyConI (reifyName tc) 2                False)
+
+  | isPrimTyCon tc
+  = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnliftedTyCon tc))
+
+  | isTypeFamilyTyCon tc
+  = do { let tvs      = tyConTyVars tc
+             res_kind = tyConResKind tc
+             resVar   = famTcResVar tc
+
+       ; kind' <- reifyKind res_kind
+       ; let (resultSig, injectivity) =
+                 case resVar of
+                   Nothing   -> (TH.KindSig kind', Nothing)
+                   Just name ->
+                     let thName   = reifyName name
+                         injAnnot = tyConInjectivityInfo tc
+                         sig = TH.TyVarSig (TH.KindedTV thName kind')
+                         inj = case injAnnot of
+                                 NotInjective -> Nothing
+                                 Injective ms ->
+                                     Just (TH.InjectivityAnn thName injRHS)
+                                   where
+                                     injRHS = map (reifyName . tyVarName)
+                                                  (filterByList ms tvs)
+                     in (sig, inj)
+       ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
+       ; let tfHead =
+               TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity
+       ; if isOpenTypeFamilyTyCon tc
+         then do { fam_envs <- tcGetFamInstEnvs
+                 ; instances <- reifyFamilyInstances tc
+                                  (familyInstances fam_envs tc)
+                 ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) }
+         else do { eqns <-
+                     case isClosedSynFamilyTyConWithAxiom_maybe tc of
+                       Just ax -> mapM (reifyAxBranch tc) $
+                                  fromBranches $ coAxiomBranches ax
+                       Nothing -> return []
+                 ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns)
+                      []) } }
+
+  | isDataFamilyTyCon tc
+  = do { let res_kind = tyConResKind tc
+
+       ; kind' <- fmap Just (reifyKind res_kind)
+
+       ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
+       ; fam_envs <- tcGetFamInstEnvs
+       ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc)
+       ; return (TH.FamilyI
+                       (TH.DataFamilyD (reifyName tc) tvs' kind') instances) }
+
+  | Just (_, rhs) <- synTyConDefn_maybe tc  -- Vanilla type synonym
+  = do { rhs' <- reifyType rhs
+       ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)
+       ; return (TH.TyConI
+                   (TH.TySynD (reifyName tc) tvs' rhs'))
+       }
+
+  | otherwise
+  = do  { cxt <- reifyCxt (tyConStupidTheta tc)
+        ; let tvs      = tyConTyVars tc
+              dataCons = tyConDataCons tc
+              isGadt   = isGadtSyntaxTyCon tc
+        ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons
+        ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc)
+        ; let name = reifyName tc
+              deriv = []        -- Don't know about deriving
+              decl | isNewTyCon tc =
+                       TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv
+                   | otherwise     =
+                       TH.DataD    cxt name r_tvs Nothing       cons  deriv
+        ; return (TH.TyConI decl) }
+
+reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con
+reifyDataCon isGadtDataCon tys dc
+  = do { let -- used for H98 data constructors
+             (ex_tvs, theta, arg_tys)
+                 = dataConInstSig dc tys
+             -- used for GADTs data constructors
+             g_user_tvs' = dataConUserTyVars dc
+             (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty')
+                 = dataConFullSig dc
+             (srcUnpks, srcStricts)
+                 = mapAndUnzip reifySourceBang (dataConSrcBangs dc)
+             dcdBangs  = zipWith TH.Bang srcUnpks srcStricts
+             fields    = dataConFieldLabels dc
+             name      = reifyName dc
+             -- Universal tvs present in eq_spec need to be filtered out, as
+             -- they will not appear anywhere in the type.
+             eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec)
+
+       ; (univ_subst, _)
+              -- See Note [Freshen reified GADT constructors' universal tyvars]
+           <- freshenTyVarBndrs $
+              filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs
+       ; let (tvb_subst, g_user_tvs) = substTyVarBndrs univ_subst g_user_tvs'
+             g_theta   = substTys tvb_subst g_theta'
+             g_arg_tys = substTys tvb_subst g_arg_tys'
+             g_res_ty  = substTy  tvb_subst g_res_ty'
+
+       ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)
+
+       ; main_con <-
+           if | not (null fields) && not isGadtDataCon ->
+                  return $ TH.RecC name (zip3 (map reifyFieldLabel fields)
+                                         dcdBangs r_arg_tys)
+              | not (null fields) -> do
+                  { res_ty <- reifyType g_res_ty
+                  ; return $ TH.RecGadtC [name]
+                                     (zip3 (map (reifyName . flSelector) fields)
+                                      dcdBangs r_arg_tys) res_ty }
+                -- We need to check not isGadtDataCon here because GADT
+                -- constructors can be declared infix.
+                -- See Note [Infix GADT constructors] in TcTyClsDecls.
+              | dataConIsInfix dc && not isGadtDataCon ->
+                  ASSERT( arg_tys `lengthIs` 2 ) do
+                  { let [r_a1, r_a2] = r_arg_tys
+                        [s1,   s2]   = dcdBangs
+                  ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }
+              | isGadtDataCon -> do
+                  { res_ty <- reifyType g_res_ty
+                  ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty }
+              | otherwise ->
+                  return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)
+
+       ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta)
+                               | otherwise     = ASSERT( all isTyVar ex_tvs )
+                                                 -- no covars for haskell syntax
+                                                 (ex_tvs, theta)
+             ret_con | null ex_tvs' && null theta' = return main_con
+                     | otherwise                   = do
+                         { cxt <- reifyCxt theta'
+                         ; ex_tvs'' <- reifyTyVars ex_tvs'
+                         ; return (TH.ForallC ex_tvs'' cxt main_con) }
+       ; ASSERT( arg_tys `equalLength` dcdBangs )
+         ret_con }
+
+{-
+Note [Freshen reified GADT constructors' universal tyvars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose one were to reify this GADT:
+
+  data a :~: b where
+    Refl :: forall a b. (a ~ b) => a :~: b
+
+We ought to be careful here about the uniques we give to the occurrences of `a`
+and `b` in this definition. That is because in the original DataCon, all uses
+of `a` and `b` have the same unique, since `a` and `b` are both universally
+quantified type variables--that is, they are used in both the (:~:) tycon as
+well as in the constructor type signature. But when we turn the DataCon
+definition into the reified one, the `a` and `b` in the constructor type
+signature becomes differently scoped than the `a` and `b` in `data a :~: b`.
+
+While it wouldn't technically be *wrong* per se to re-use the same uniques for
+`a` and `b` across these two different scopes, it's somewhat annoying for end
+users of Template Haskell, since they wouldn't be able to rely on the
+assumption that all TH names have globally distinct uniques (#13885). For this
+reason, we freshen the universally quantified tyvars that go into the reified
+GADT constructor type signature to give them distinct uniques from their
+counterparts in the tycon.
+-}
+
+------------------------------
+reifyClass :: Class -> TcM TH.Info
+reifyClass cls
+  = do  { cxt <- reifyCxt theta
+        ; inst_envs <- tcGetInstEnvs
+        ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)
+        ; assocTys <- concatMapM reifyAT ats
+        ; ops <- concatMapM reify_op op_stuff
+        ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls))
+        ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)
+        ; return (TH.ClassI dec insts) }
+  where
+    (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls
+    fds' = map reifyFunDep fds
+    reify_op (op, def_meth)
+      = do { let (_, _, ty) = tcSplitMethodTy (idType op)
+               -- Use tcSplitMethodTy to get rid of the extraneous class
+               -- variables and predicates at the beginning of op's type
+               -- (see #15551).
+           ; ty' <- reifyType ty
+           ; let nm' = reifyName op
+           ; case def_meth of
+                Just (_, GenericDM gdm_ty) ->
+                  do { gdm_ty' <- reifyType gdm_ty
+                     ; return [TH.SigD nm' ty', TH.DefaultSigD nm' gdm_ty'] }
+                _ -> return [TH.SigD nm' ty'] }
+
+    reifyAT :: ClassATItem -> TcM [TH.Dec]
+    reifyAT (ATI tycon def) = do
+      tycon' <- reifyTyCon tycon
+      case tycon' of
+        TH.FamilyI dec _ -> do
+          let (tyName, tyArgs) = tfNames dec
+          (dec :) <$> maybe (return [])
+                            (fmap (:[]) . reifyDefImpl tyName tyArgs . fst)
+                            def
+        _ -> pprPanic "reifyAT" (text (show tycon'))
+
+    reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec
+    reifyDefImpl n args ty =
+      TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args))
+                                  <$> reifyType ty
+
+    tfNames :: TH.Dec -> (TH.Name, [TH.Name])
+    tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _))
+      = (n, map bndrName args)
+    tfNames d = pprPanic "tfNames" (text (show d))
+
+    bndrName :: TH.TyVarBndr -> TH.Name
+    bndrName (TH.PlainTV n)    = n
+    bndrName (TH.KindedTV n _) = n
+
+------------------------------
+-- | Annotate (with TH.SigT) a type if the first parameter is True
+-- and if the type contains a free variable.
+-- This is used to annotate type patterns for poly-kinded tyvars in
+-- reifying class and type instances. See #8953 and th/T8953.
+annotThType :: Bool   -- True <=> annotate
+            -> TyCoRep.Type -> TH.Type -> TcM TH.Type
+  -- tiny optimization: if the type is annotated, don't annotate again.
+annotThType _    _  th_ty@(TH.SigT {}) = return th_ty
+annotThType True ty th_ty
+  | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty
+  = do { let ki = tcTypeKind ty
+       ; th_ki <- reifyKind ki
+       ; return (TH.SigT th_ty th_ki) }
+annotThType _    _ th_ty = return th_ty
+
+-- | For every type variable in the input,
+-- report whether or not the tv is poly-kinded. This is used to eventually
+-- feed into 'annotThType'.
+mkIsPolyTvs :: [TyVar] -> [Bool]
+mkIsPolyTvs = map is_poly_tv
+  where
+    is_poly_tv tv = not $
+                    isEmptyVarSet $
+                    filterVarSet isTyVar $
+                    tyCoVarsOfType $
+                    tyVarKind tv
+
+------------------------------
+reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]
+reifyClassInstances cls insts
+  = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts
+  where
+    tvs = tyConVisibleTyVars (classTyCon cls)
+
+reifyClassInstance :: [Bool]  -- True <=> the corresponding tv is poly-kinded
+                              -- includes only *visible* tvs
+                   -> ClsInst -> TcM TH.Dec
+reifyClassInstance is_poly_tvs i
+  = do { cxt <- reifyCxt theta
+       ; let vis_types = filterOutInvisibleTypes cls_tc types
+       ; thtypes <- reifyTypes vis_types
+       ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes
+       ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes
+       ; return $ (TH.InstanceD over cxt head_ty []) }
+  where
+     (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
+     cls_tc   = classTyCon cls
+     dfun     = instanceDFunId i
+     over     = case overlapMode (is_flag i) of
+                  NoOverlap _     -> Nothing
+                  Overlappable _  -> Just TH.Overlappable
+                  Overlapping _   -> Just TH.Overlapping
+                  Overlaps _      -> Just TH.Overlaps
+                  Incoherent _    -> Just TH.Incoherent
+
+------------------------------
+reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]
+reifyFamilyInstances fam_tc fam_insts
+  = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts
+  where
+    fam_tvs = tyConVisibleTyVars fam_tc
+
+reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
+                              -- includes only *visible* tvs
+                    -> FamInst -> TcM TH.Dec
+reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor
+                                         , fi_axiom = ax
+                                         , fi_fam = fam })
+  | let fam_tc = coAxiomTyCon ax
+        branch = coAxiomSingleBranch ax
+  , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch
+  = case flavor of
+      SynFamilyInst ->
+               -- remove kind patterns (#8884)
+        do { th_tvs <- reifyTyVarsToMaybe tvs
+           ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
+           ; th_lhs <- reifyTypes lhs_types_only
+           ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only
+                                                   th_lhs
+           ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs
+           ; th_rhs <- reifyType rhs
+           ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) }
+
+      DataFamilyInst rep_tc ->
+        do { let -- eta-expand lhs types, because sometimes data/newtype
+                 -- instances are eta-reduced; See Trac #9692
+                 -- See Note [Eta reduction for data families] in FamInstEnv
+                 (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch
+                 fam'     = reifyName fam
+                 dataCons = tyConDataCons rep_tc
+                 isGadt   = isGadtSyntaxTyCon rep_tc
+           ; th_tvs <- reifyTyVarsToMaybe ee_tvs
+           ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons
+           ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs
+           ; th_tys <- reifyTypes types_only
+           ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys
+           ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys
+           ; return $
+               if isNewTyCon rep_tc
+               then TH.NewtypeInstD [] th_tvs lhs_type Nothing (head cons) []
+               else TH.DataInstD    [] th_tvs lhs_type Nothing       cons  []
+           }
+
+------------------------------
+reifyType :: TyCoRep.Type -> TcM TH.Type
+-- Monadic only because of failure
+reifyType ty                | tcIsLiftedTypeKind ty = return TH.StarT
+  -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it
+  -- with Constraint (#14869).
+reifyType ty@(ForAllTy {})  = reify_for_all ty
+reifyType (LitTy t)         = do { r <- reifyTyLit t; return (TH.LitT r) }
+reifyType (TyVarTy tv)      = return (TH.VarT (reifyName tv))
+reifyType (TyConApp tc tys) = reify_tc_app tc tys   -- Do not expand type synonyms here
+reifyType ty@(AppTy {})     = do
+  let (ty_head, ty_args) = splitAppTys ty
+  ty_head' <- reifyType ty_head
+  ty_args' <- reifyTypes (filter_out_invisible_args ty_head ty_args)
+  pure $ mkThAppTs ty_head' ty_args'
+  where
+    -- Make sure to filter out any invisible arguments. For instance, if you
+    -- reify the following:
+    --
+    --   newtype T (f :: forall a. a -> Type) = MkT (f Bool)
+    --
+    -- Then you should receive back `f Bool`, not `f Type Bool`, since the
+    -- `Type` argument is invisible (#15792).
+    filter_out_invisible_args :: Type -> [Type] -> [Type]
+    filter_out_invisible_args ty_head ty_args =
+      filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args)
+                   ty_args
+reifyType ty@(FunTy t1 t2)
+  | isPredTy t1 = reify_for_all ty  -- Types like ((?x::Int) => Char -> Char)
+  | otherwise   = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
+reifyType (CastTy t _)      = reifyType t -- Casts are ignored in TH
+reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty)
+
+reify_for_all :: TyCoRep.Type -> TcM TH.Type
+reify_for_all ty
+  = do { cxt' <- reifyCxt cxt;
+       ; tau' <- reifyType tau
+       ; tvs' <- reifyTyVars tvs
+       ; return (TH.ForallT tvs' cxt' tau') }
+  where
+    (tvs, cxt, tau) = tcSplitSigmaTy ty
+
+reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit
+reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)
+reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))
+
+reifyTypes :: [Type] -> TcM [TH.Type]
+reifyTypes = mapM reifyType
+
+reifyPatSynType
+  :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type
+-- reifies a pattern synonym's type and returns its *complete* type
+-- signature; see NOTE [Pattern synonym signatures and Template
+-- Haskell]
+reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy)
+  = do { univTyVars' <- reifyTyVars univTyVars
+       ; req'        <- reifyCxt req
+       ; exTyVars'   <- reifyTyVars exTyVars
+       ; prov'       <- reifyCxt prov
+       ; tau'        <- reifyType (mkFunTys argTys resTy)
+       ; return $ TH.ForallT univTyVars' req'
+                $ TH.ForallT exTyVars' prov' tau' }
+
+reifyKind :: Kind -> TcM TH.Kind
+reifyKind = reifyType
+
+reifyCxt :: [PredType] -> TcM [TH.Pred]
+reifyCxt   = mapM reifyType
+
+reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
+reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
+
+reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr]
+reifyTyVars tvs = mapM reify_tv tvs
+  where
+    -- even if the kind is *, we need to include a kind annotation,
+    -- in case a poly-kind would be inferred without the annotation.
+    -- See #8953 or test th/T8953
+    reify_tv tv = TH.KindedTV name <$> reifyKind kind
+      where
+        kind = tyVarKind tv
+        name = reifyName tv
+
+reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr])
+reifyTyVarsToMaybe []  = pure Nothing
+reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys
+
+{-
+Note [Kind annotations on TyConApps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A poly-kinded tycon sometimes needs a kind annotation to be unambiguous.
+For example:
+
+   type family F a :: k
+   type instance F Int  = (Proxy :: * -> *)
+   type instance F Bool = (Proxy :: (* -> *) -> *)
+
+It's hard to figure out where these annotations should appear, so we do this:
+Suppose we have a tycon application (T ty1 ... tyn). Assuming that T is not
+oversatured (more on this later), we can assume T's declaration is of the form
+T (tvb1 :: s1) ... (tvbn :: sn) :: p. If any kind variable that
+is free in p is not free in an injective position in tvb1 ... tvbn,
+then we put on a kind annotation, since we would not otherwise be able to infer
+the kind of the whole tycon application.
+
+The injective positions in a tyvar binder are the injective positions in the
+kind of its tyvar, provided the tyvar binder is either:
+
+* Anonymous. For example, in the promoted data constructor '(:):
+
+    '(:) :: forall a. a -> [a] -> [a]
+
+  The second and third tyvar binders (of kinds `a` and `[a]`) are both
+  anonymous, so if we had '(:) 'True '[], then the inferred kinds of 'True and
+  '[] would contribute to the inferred kind of '(:) 'True '[].
+* Has required visibility. For example, in the type family:
+
+    type family Wurble k (a :: k) :: k
+    Wurble :: forall k -> k -> k
+
+  The first tyvar binder (of kind `forall k`) has required visibility, so if
+  we had Wurble (Maybe a) Nothing, then the inferred kind of Maybe a would
+  contribute to the inferred kind of Wurble (Maybe a) Nothing.
+
+An injective position in a type is one that does not occur as an argument to
+a non-injective type constructor (e.g., non-injective type families). See
+injectiveVarsOfType.
+
+How can be sure that this is correct? That is, how can we be sure that in the
+event that we leave off a kind annotation, that one could infer the kind of the
+tycon application from its arguments? It's essentially a proof by induction: if
+we can infer the kinds of every subtree of a type, then the whole tycon
+application will have an inferrable kind--unless, of course, the remainder of
+the tycon application's kind has uninstantiated kind variables.
+
+An earlier implementation of this algorithm only checked if p contained any
+free variables. But this was unsatisfactory, since a datatype like this:
+
+  data Foo = Foo (Proxy '[False, True])
+
+Would be reified like this:
+
+  data Foo = Foo (Proxy ('(:) False ('(:) True ('[] :: [Bool])
+                                     :: [Bool]) :: [Bool]))
+
+Which has a rather excessive amount of kind annotations. With the current
+algorithm, we instead reify Foo to this:
+
+  data Foo = Foo (Proxy ('(:) False ('(:) True ('[] :: [Bool]))))
+
+Since in the case of '[], the kind p is [a], and there are no arguments in the
+kind of '[]. On the other hand, in the case of '(:) True '[], the kind p is
+(forall a. [a]), but a occurs free in the first and second arguments of the
+full kind of '(:), which is (forall a. a -> [a] -> [a]). (See Trac #14060.)
+
+What happens if T is oversaturated? That is, if T's kind has fewer than n
+arguments, in the case that the concrete application instantiates a result
+kind variable with an arrow kind? If we run out of arguments, we do not attach
+a kind annotation. This should be a rare case, indeed. Here is an example:
+
+   data T1 :: k1 -> k2 -> *
+   data T2 :: k1 -> k2 -> *
+
+   type family G (a :: k) :: k
+   type instance G T1 = T2
+
+   type instance F Char = (G T1 Bool :: (* -> *) -> *)   -- F from above
+
+Here G's kind is (forall k. k -> k), and the desugared RHS of that last
+instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to
+the algorithm above, there are 3 arguments to G so we should peel off 3
+arguments in G's kind. But G's kind has only two arguments. This is the
+rare special case, and we choose not to annotate the application of G with
+a kind signature. After all, we needn't do this, since that instance would
+be reified as:
+
+   type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool
+
+So the kind of G isn't ambiguous anymore due to the explicit kind annotation
+on its argument. See #8953 and test th/T8953.
+-}
+
+reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type
+reify_tc_app tc tys
+  = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys)
+       ; maybe_sig_t (mkThAppTs r_tc tys') }
+  where
+    arity       = tyConArity tc
+    tc_binders  = tyConBinders tc
+    tc_res_kind = tyConResKind tc
+
+    r_tc | isUnboxedSumTyCon tc           = TH.UnboxedSumT (arity `div` 2)
+         | isUnboxedTupleTyCon tc         = TH.UnboxedTupleT (arity `div` 2)
+         | isPromotedTupleTyCon tc        = TH.PromotedTupleT (arity `div` 2)
+             -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
+         | isTupleTyCon tc                = if isPromotedDataCon tc
+                                            then TH.PromotedTupleT arity
+                                            else TH.TupleT arity
+         | tc `hasKey` constraintKindTyConKey
+                                          = TH.ConstraintT
+         | tc `hasKey` funTyConKey        = TH.ArrowT
+         | tc `hasKey` listTyConKey       = TH.ListT
+         | tc `hasKey` nilDataConKey      = TH.PromotedNilT
+         | tc `hasKey` consDataConKey     = TH.PromotedConsT
+         | tc `hasKey` heqTyConKey        = TH.EqualityT
+         | tc `hasKey` eqPrimTyConKey     = TH.EqualityT
+         | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon)
+         | isPromotedDataCon tc           = TH.PromotedT (reifyName tc)
+         | otherwise                      = TH.ConT (reifyName tc)
+
+    -- See Note [Kind annotations on TyConApps]
+    maybe_sig_t th_type
+      | needs_kind_sig
+      = do { let full_kind = tcTypeKind (mkTyConApp tc tys)
+           ; th_full_kind <- reifyKind full_kind
+           ; return (TH.SigT th_type th_full_kind) }
+      | otherwise
+      = return th_type
+
+    needs_kind_sig
+      | GT <- compareLength tys tc_binders
+      = False
+      | otherwise
+      = let (dropped_binders, remaining_binders)
+              = splitAtList  tys tc_binders
+            result_kind  = mkTyConKind remaining_binders tc_res_kind
+            result_vars  = tyCoVarsOfType result_kind
+            dropped_vars = fvVarSet $
+                           mapUnionFV injectiveVarsOfBinder dropped_binders
+
+        in not (subVarSet result_vars dropped_vars)
+
+------------------------------
+reifyName :: NamedThing n => n -> TH.Name
+reifyName thing
+  | isExternalName name = mk_varg pkg_str mod_str occ_str
+  | otherwise           = TH.mkNameU occ_str (getKey (getUnique name))
+        -- Many of the things we reify have local bindings, and
+        -- NameL's aren't supposed to appear in binding positions, so
+        -- we use NameU.  When/if we start to reify nested things, that
+        -- have free variables, we may need to generate NameL's for them.
+  where
+    name    = getName thing
+    mod     = ASSERT( isExternalName name ) nameModule name
+    pkg_str = unitIdString (moduleUnitId mod)
+    mod_str = moduleNameString (moduleName mod)
+    occ_str = occNameString occ
+    occ     = nameOccName name
+    mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
+            | OccName.isVarOcc  occ = TH.mkNameG_v
+            | OccName.isTcOcc   occ = TH.mkNameG_tc
+            | otherwise             = pprPanic "reifyName" (ppr name)
+
+-- See Note [Reifying field labels]
+reifyFieldLabel :: FieldLabel -> TH.Name
+reifyFieldLabel fl
+  | flIsOverloaded fl
+              = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str))
+  | otherwise = TH.mkNameG_v pkg_str mod_str occ_str
+  where
+    name    = flSelector fl
+    mod     = ASSERT( isExternalName name ) nameModule name
+    pkg_str = unitIdString (moduleUnitId mod)
+    mod_str = moduleNameString (moduleName mod)
+    occ_str = unpackFS (flLabel fl)
+
+reifySelector :: Id -> TyCon -> TH.Name
+reifySelector id tc
+  = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of
+      Just fl -> reifyFieldLabel fl
+      Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc)
+
+------------------------------
+reifyFixity :: Name -> TcM (Maybe TH.Fixity)
+reifyFixity name
+  = do { (found, fix) <- lookupFixityRn_help name
+       ; return (if found then Just (conv_fix fix) else Nothing) }
+    where
+      conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d)
+      conv_dir BasicTypes.InfixR = TH.InfixR
+      conv_dir BasicTypes.InfixL = TH.InfixL
+      conv_dir BasicTypes.InfixN = TH.InfixN
+
+reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness
+reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness
+reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack
+reifyUnpackedness SrcUnpack   = TH.SourceUnpack
+
+reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness
+reifyStrictness NoSrcStrict = TH.NoSourceStrictness
+reifyStrictness SrcStrict   = TH.SourceStrict
+reifyStrictness SrcLazy     = TH.SourceLazy
+
+reifySourceBang :: DataCon.HsSrcBang
+                -> (TH.SourceUnpackedness, TH.SourceStrictness)
+reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s)
+
+reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness
+reifyDecidedStrictness HsLazy     = TH.DecidedLazy
+reifyDecidedStrictness HsStrict   = TH.DecidedStrict
+reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack
+
+------------------------------
+lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
+lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)
+lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))
+  = return $ ModuleTarget $
+    mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn)
+
+reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]
+reifyAnnotations th_name
+  = do { name <- lookupThAnnLookup th_name
+       ; topEnv <- getTopEnv
+       ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing
+       ; tcg <- getGblEnv
+       ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name
+       ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name
+       ; return (selectedEpsHptAnns ++ selectedTcgAnns) }
+
+------------------------------
+modToTHMod :: Module -> TH.Module
+modToTHMod m = TH.Module (TH.PkgName $ unitIdString  $ moduleUnitId m)
+                         (TH.ModName $ moduleNameString $ moduleName m)
+
+reifyModule :: TH.Module -> TcM TH.ModuleInfo
+reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do
+  this_mod <- getModule
+  let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString)
+  if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod
+    where
+      reifyThisModule = do
+        usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports
+        return $ TH.ModuleInfo usages
+
+      reifyFromIface reifMod = do
+        iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod
+        let usages = [modToTHMod m | usage <- mi_usages iface,
+                                     Just m <- [usageToModule (moduleUnitId reifMod) usage] ]
+        return $ TH.ModuleInfo usages
+
+      usageToModule :: UnitId -> Usage -> Maybe Module
+      usageToModule _ (UsageFile {}) = Nothing
+      usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn
+      usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m
+      usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m
+
+------------------------------
+mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type
+mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys
+
+noTH :: PtrString -> SDoc -> TcM a
+noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+>
+                                text "in Template Haskell:",
+                             nest 2 d])
+
+ppr_th :: TH.Ppr a => a -> SDoc
+ppr_th x = text (TH.pprint x)
+
+{-
+Note [Reifying field labels]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When reifying a datatype declared with DuplicateRecordFields enabled, we want
+the reified names of the fields to be labels rather than selector functions.
+That is, we want (reify ''T) and (reify 'foo) to produce
+
+    data T = MkT { foo :: Int }
+    foo :: T -> Int
+
+rather than
+
+    data T = MkT { $sel:foo:MkT :: Int }
+    $sel:foo:MkT :: T -> Int
+
+because otherwise TH code that uses the field names as strings will silently do
+the wrong thing.  Thus we use the field label (e.g. foo) as the OccName, rather
+than the selector (e.g. $sel:foo:MkT).  Since the Orig name M.foo isn't in the
+environment, NameG can't be used to represent such fields.  Instead,
+reifyFieldLabel uses NameQ.
+
+However, this means that extracting the field name from the output of reify, and
+trying to reify it again, may fail with an ambiguity error if there are multiple
+such fields defined in the module (see the test case
+overloadedrecflds/should_fail/T11103.hs).  The "proper" fix requires changes to
+the TH AST to make it able to represent duplicate record fields.
+-}
diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcSplice.hs-boot
@@ -0,0 +1,46 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcSplice where
+
+import GhcPrelude
+import Name
+import HsExpr   ( PendingRnSplice, DelayedSplice )
+import TcRnTypes( TcM , SpliceType )
+import TcType   ( ExpRhoType )
+import Annotations ( Annotation, CoreAnnTarget )
+import HsExtension ( GhcTcId, GhcRn, GhcPs, GhcTc )
+
+import HsSyn      ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat,
+                    LHsDecl, ThModFinalizers )
+import qualified Language.Haskell.TH as TH
+
+tcSpliceExpr :: HsSplice GhcRn
+             -> ExpRhoType
+             -> TcM (HsExpr GhcTcId)
+
+tcUntypedBracket :: HsExpr GhcRn
+                 -> HsBracket GhcRn
+                 -> [PendingRnSplice]
+                 -> ExpRhoType
+                 -> TcM (HsExpr GhcTcId)
+tcTypedBracket :: HsExpr GhcRn
+               -> HsBracket GhcRn
+               -> ExpRhoType
+               -> TcM (HsExpr GhcTcId)
+
+runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)
+
+runAnnotation     :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation
+
+tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)
+
+runMetaE :: LHsExpr GhcTcId -> TcM (LHsExpr GhcPs)
+runMetaP :: LHsExpr GhcTcId -> TcM (LPat GhcPs)
+runMetaT :: LHsExpr GhcTcId -> TcM (LHsType GhcPs)
+runMetaD :: LHsExpr GhcTcId -> TcM [LHsDecl GhcPs]
+
+lookupThName_maybe :: TH.Name -> TcM (Maybe Name)
+runQuasi :: TH.Q a -> TcM a
+runRemoteModFinalizers :: ThModFinalizers -> TcM ()
+finishTH :: TcM ()
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -0,0 +1,3869 @@
+{-
+(c) The University of Glasgow 2006
+(c) The AQUA Project, Glasgow University, 1996-1998
+
+
+TcTyClsDecls: Typecheck type and class declarations
+-}
+
+{-# LANGUAGE CPP, TupleSections, MultiWayIf #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcTyClsDecls (
+        tcTyAndClassDecls,
+
+        -- Functions used by TcInstDcls to check
+        -- data/type family instance declarations
+        kcConDecl, tcConDecls, dataDeclChecks, checkValidTyCon,
+        tcFamTyPats, tcTyFamInstEqn,
+        tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
+        unravelFamInstPats, addConsistencyConstraints,
+        wrongKindOfFamily
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import HscTypes
+import BuildTyCl
+import TcRnMonad
+import TcEnv
+import TcValidity
+import TcHsSyn
+import TcTyDecls
+import TcClassDcl
+import {-# SOURCE #-} TcInstDcls( tcInstDecls1 )
+import TcDeriv (DerivInfo)
+import TcHsType
+import ClsInst( AssocInstInfo(..) )
+import Inst( tcInstTyBinders )
+import TcMType
+import TysWiredIn ( unitTy )
+import TcType
+import RnEnv( lookupConstructorFields )
+import FamInst
+import FamInstEnv
+import Coercion
+import Type
+import TyCoRep   -- for checkValidRoles
+import Class
+import CoAxiom
+import TyCon
+import DataCon
+import Id
+import Var
+import VarEnv
+import VarSet
+import Module
+import Name
+import NameSet
+import NameEnv
+import Outputable
+import Maybes
+import Unify
+import Util
+import SrcLoc
+import ListSetOps
+import DynFlags
+import Unique
+import ConLike( ConLike(..) )
+import BasicTypes
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Data.List
+import Data.List.NonEmpty ( NonEmpty(..) )
+import qualified Data.Set as Set
+
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Type checking for type and class declarations}
+*                                                                      *
+************************************************************************
+
+Note [Grouping of type and class declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly
+connected component of mutually dependent types and classes. We kind check and
+type check each group separately to enhance kind polymorphism. Take the
+following example:
+
+  type Id a = a
+  data X = X (Id Int)
+
+If we were to kind check the two declarations together, we would give Id the
+kind * -> *, since we apply it to an Int in the definition of X. But we can do
+better than that, since Id really is kind polymorphic, and should get kind
+forall (k::*). k -> k. Since it does not depend on anything else, it can be
+kind-checked by itself, hence getting the most general kind. We then kind check
+X, which works fine because we then know the polymorphic kind of Id, and simply
+instantiate k to *.
+
+Note [Check role annotations in a second pass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Role inference potentially depends on the types of all of the datacons declared
+in a mutually recursive group. The validity of a role annotation, in turn,
+depends on the result of role inference. Because the types of datacons might
+be ill-formed (see #7175 and Note [Checking GADT return types]) we must check
+*all* the tycons in a group for validity before checking *any* of the roles.
+Thus, we take two passes over the resulting tycons, first checking for general
+validity and then checking for valid role annotations.
+-}
+
+tcTyAndClassDecls :: [TyClGroup GhcRn]      -- Mutually-recursive groups in
+                                            -- dependency order
+                  -> TcM ( TcGblEnv         -- Input env extended by types and
+                                            -- classes
+                                            -- and their implicit Ids,DataCons
+                         , [InstInfo GhcRn] -- Source-code instance decls info
+                         , [DerivInfo]      -- data family deriving info
+                         )
+-- Fails if there are any errors
+tcTyAndClassDecls tyclds_s
+  -- The code recovers internally, but if anything gave rise to
+  -- an error we'd better stop now, to avoid a cascade
+  -- Type check each group in dependency order folding the global env
+  = checkNoErrs $ fold_env [] [] tyclds_s
+  where
+    fold_env :: [InstInfo GhcRn]
+             -> [DerivInfo]
+             -> [TyClGroup GhcRn]
+             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
+    fold_env inst_info deriv_info []
+      = do { gbl_env <- getGblEnv
+           ; return (gbl_env, inst_info, deriv_info) }
+    fold_env inst_info deriv_info (tyclds:tyclds_s)
+      = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds
+           ; setGblEnv tcg_env $
+               -- remaining groups are typechecked in the extended global env.
+             fold_env (inst_info' ++ inst_info)
+                      (deriv_info' ++ deriv_info)
+                      tyclds_s }
+
+tcTyClGroup :: TyClGroup GhcRn
+            -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
+-- Typecheck one strongly-connected component of type, class, and instance decls
+-- See Note [TyClGroups and dependency analysis] in HsDecls
+tcTyClGroup (TyClGroup { group_tyclds = tyclds
+                       , group_roles  = roles
+                       , group_instds = instds })
+  = do { let role_annots = mkRoleAnnotEnv roles
+
+           -- Step 1: Typecheck the type/class declarations
+       ; traceTc "---- tcTyClGroup ---- {" empty
+       ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))
+       ; tyclss <- tcTyClDecls tyclds role_annots
+
+           -- Step 1.5: Make sure we don't have any type synonym cycles
+       ; traceTc "Starting synonym cycle check" (ppr tyclss)
+       ; this_uid <- fmap thisPackage getDynFlags
+       ; checkSynCycles this_uid tyclss tyclds
+       ; traceTc "Done synonym cycle check" (ppr tyclss)
+
+           -- Step 2: Perform the validity check on those types/classes
+           -- We can do this now because we are done with the recursive knot
+           -- Do it before Step 3 (adding implicit things) because the latter
+           -- expects well-formed TyCons
+       ; traceTc "Starting validity check" (ppr tyclss)
+       ; tyclss <- concatMapM checkValidTyCl tyclss
+       ; traceTc "Done validity check" (ppr tyclss)
+       ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss
+           -- See Note [Check role annotations in a second pass]
+
+       ; traceTc "---- end tcTyClGroup ---- }" empty
+
+           -- Step 3: Add the implicit things;
+           -- we want them in the environment because
+           -- they may be mentioned in interface files
+       ; gbl_env <- addTyConsToGblEnv tyclss
+
+           -- Step 4: check instance declarations
+       ; setGblEnv gbl_env $
+         tcInstDecls1 instds }
+
+tcTyClGroup (XTyClGroup _) = panic "tcTyClGroup"
+
+tcTyClDecls :: [LTyClDecl GhcRn] -> RoleAnnotEnv -> TcM [TyCon]
+tcTyClDecls tyclds role_annots
+  = tcExtendKindEnv promotion_err_env $   --- See Note [Type environment evolution]
+    do {    -- Step 1: kind-check this group and returns the final
+            -- (possibly-polymorphic) kind of each TyCon and Class
+            -- See Note [Kind checking for type and class decls]
+         tc_tycons <- kcTyClGroup tyclds
+       ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))
+
+            -- Step 2: type-check all groups together, returning
+            -- the final TyCons and Classes
+            --
+            -- NB: We have to be careful here to NOT eagerly unfold
+            -- type synonyms, as we have not tested for type synonym
+            -- loops yet and could fall into a black hole.
+       ; fixM $ \ ~rec_tyclss -> do
+           { tcg_env <- getGblEnv
+           ; let roles = inferRoles (tcg_src tcg_env) role_annots rec_tyclss
+
+                 -- Populate environment with knot-tied ATyCon for TyCons
+                 -- NB: if the decls mention any ill-staged data cons
+                 -- (see Note [Recursion and promoting data constructors])
+                 -- we will have failed already in kcTyClGroup, so no worries here
+           ; tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $
+
+                 -- Also extend the local type envt with bindings giving
+                 -- a TcTyCon for each each knot-tied TyCon or Class
+                 -- See Note [Type checking recursive type and class declarations]
+                 -- and Note [Type environment evolution]
+             tcExtendKindEnvWithTyCons tc_tycons $
+
+                 -- Kind and type check declarations for this group
+               mapM (tcTyClDecl roles) tyclds
+           } }
+  where
+    promotion_err_env = mkPromotionErrorEnv tyclds
+    ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma
+                                  , ppr (tyConBinders tc) <> comma
+                                  , ppr (tyConResKind tc)
+                                  , ppr (isTcTyCon tc) ])
+
+zipRecTyClss :: [TcTyCon]
+             -> [TyCon]           -- Knot-tied
+             -> [(Name,TyThing)]
+-- Build a name-TyThing mapping for the TyCons bound by decls
+-- being careful not to look at the knot-tied [TyThing]
+-- The TyThings in the result list must have a visible ATyCon,
+-- because typechecking types (in, say, tcTyClDecl) looks at
+-- this outer constructor
+zipRecTyClss tc_tycons rec_tycons
+  = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ]
+  where
+    rec_tc_env :: NameEnv TyCon
+    rec_tc_env = foldr add_tc emptyNameEnv rec_tycons
+
+    add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
+    add_tc tc env = foldr add_one_tc env (tc : tyConATs tc)
+
+    add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon
+    add_one_tc tc env = extendNameEnv env (tyConName tc) tc
+
+    get name = case lookupNameEnv rec_tc_env name of
+                 Just tc -> tc
+                 other   -> pprPanic "zipRecTyClss" (ppr name <+> ppr other)
+
+{-
+************************************************************************
+*                                                                      *
+                Kind checking
+*                                                                      *
+************************************************************************
+
+Note [Kind checking for type and class decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Kind checking is done thus:
+
+   1. Make up a kind variable for each parameter of the declarations,
+      and extend the kind environment (which is in the TcLclEnv)
+
+   2. Kind check the declarations
+
+We need to kind check all types in the mutually recursive group
+before we know the kind of the type variables.  For example:
+
+  class C a where
+     op :: D b => a -> b -> b
+
+  class D c where
+     bop :: (Monad c) => ...
+
+Here, the kind of the locally-polymorphic type variable "b"
+depends on *all the uses of class D*.  For example, the use of
+Monad c in bop's type signature means that D must have kind Type->Type.
+
+Note: we don't treat type synonyms specially (we used to, in the past);
+in particular, even if we have a type synonym cycle, we still kind check
+it normally, and test for cycles later (checkSynCycles).  The reason
+we can get away with this is because we have more systematic TYPE r
+inference, which means that we can do unification between kinds that
+aren't lifted (this historically was not true.)
+
+The downside of not directly reading off the kinds off the RHS of
+type synonyms in topological order is that we don't transparently
+support making synonyms of types with higher-rank kinds.  But
+you can always specify a CUSK directly to make this work out.
+See tc269 for an example.
+
+Note [Skip decls with CUSKs in kcLTyClDecl]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+    data T (a :: *) = MkT (S a)   -- Has CUSK
+    data S a = MkS (T Int) (S a)  -- No CUSK
+
+Via getInitialKinds we get
+  T :: * -> *
+  S :: kappa -> *
+
+Then we call kcTyClDecl on each decl in the group, to constrain the
+kind unification variables.  BUT we /skip/ the RHS of any decl with
+a CUSK.  Here we skip the RHS of T, so we eventually get
+  S :: forall k. k -> *
+
+This gets us more polymorphism than we would otherwise get, similar
+(but implemented strangely differently from) the treatment of type
+signatures in value declarations.
+
+Open type families
+~~~~~~~~~~~~~~~~~~
+This treatment of type synonyms only applies to Haskell 98-style synonyms.
+General type functions can be recursive, and hence, appear in `alg_decls'.
+
+The kind of an open type family is solely determinded by its kind signature;
+hence, only kind signatures participate in the construction of the initial
+kind environment (as constructed by `getInitialKind'). In fact, we ignore
+instances of families altogether in the following. However, we need to include
+the kinds of *associated* families into the construction of the initial kind
+environment. (This is handled by `allDecls').
+
+See also Note [Kind checking recursive type and class declarations]
+
+Note [How TcTyCons work]
+~~~~~~~~~~~~~~~~~~~~~~~~
+TcTyCons are used for two distinct purposes
+
+1.  When recovering from a type error in a type declaration,
+    we want to put the erroneous TyCon in the environment in a
+    way that won't lead to more errors.  We use a TcTyCon for this;
+    see makeRecoveryTyCon.
+
+2.  When checking a type/class declaration (in module TcTyClsDecls), we come
+    upon knowledge of the eventual tycon in bits and pieces.
+
+      S1) First, we use getInitialKinds to look over the user-provided
+          kind signature of a tycon (including, for example, the number
+          of parameters written to the tycon) to get an initial shape of
+          the tycon's kind.  We record that shape in a TcTyCon.
+
+          For CUSK tycons, the TcTyCon has the final, generalised kind.
+          For non-CUSK tycons, the TcTyCon has as its tyConBinders only
+          the explicit arguments given -- no kind variables, etc.
+
+      S2) Then, using these initial kinds, we kind-check the body of the
+          tycon (class methods, data constructors, etc.), filling in the
+          metavariables in the tycon's initial kind.
+
+      S3) We then generalize to get the (non-CUSK) tycon's final, fixed
+          kind. Finally, once this has happened for all tycons in a
+          mutually recursive group, we can desugar the lot.
+
+    For convenience, we store partially-known tycons in TcTyCons, which
+    might store meta-variables. These TcTyCons are stored in the local
+    environment in TcTyClsDecls, until the real full TyCons can be created
+    during desugaring. A desugared program should never have a TcTyCon.
+
+3.  In a TcTyCon, everything is zonked after the kind-checking pass (S2).
+
+4.  tyConScopedTyVars.  A challenging piece in all of this is that we
+    end up taking three separate passes over every declaration:
+      - one in getInitialKind (this pass look only at the head, not the body)
+      - one in kcTyClDecls (to kind-check the body)
+      - a final one in tcTyClDecls (to desugar)
+
+    In the latter two passes, we need to connect the user-written type
+    variables in an LHsQTyVars with the variables in the tycon's
+    inferred kind. Because the tycon might not have a CUSK, this
+    matching up is, in general, quite hard to do.  (Look through the
+    git history between Dec 2015 and Apr 2016 for
+    TcHsType.splitTelescopeTvs!)
+
+    Instead of trying, we just store the list of type variables to
+    bring into scope, in the tyConScopedTyVars field of the TcTyCon.
+    These tyvars are brought into scope in TcHsType.bindTyClTyVars.
+
+    In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather
+    than just [TcTyVar]?  Consider these mutually-recursive decls
+       data T (a :: k1) b = MkT (S a b)
+       data S (c :: k2) d = MkS (T c d)
+    We start with k1 bound to kappa1, and k2 to kappa2; so initially
+    in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But
+    then kappa1 and kappa2 get unified; so after the zonking in
+    'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ.
+
+See also Note [Type checking recursive type and class declarations].
+
+Note [Type environment evolution]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As we typecheck a group of declarations the type environment evolves.
+Consider for example:
+  data B (a :: Type) = MkB (Proxy 'MkB)
+
+We do the following steps:
+
+  1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the
+     type env with promotion errors
+            B   :-> TyConPE
+            MkB :-> DataConPE
+
+  2. kcTyCLGruup
+      - Do getInitialKinds, which will signal a promotion
+        error if B is used in any of the kinds needed to initialse
+        B's kind (e.g. (a :: Type)) here
+
+      - Extend the type env with these initial kinds (monomorphic for
+        decls that lack a CUSK)
+            B :-> TcTyCon <initial kind>
+        (thereby overriding the B :-> TyConPE binding)
+        and do kcLTyClDecl on each decl to get equality constraints on
+        all those inital kinds
+
+      - Generalise the inital kind, making a poly-kinded TcTyCon
+
+  3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded
+     TcTyCons, again overriding the promotion-error bindings.
+
+     But note that the data constructor promotion errors are still in place
+     so that (in our example) a use of MkB will sitll be signalled as
+     an error.
+
+  4. Typecheck the decls.
+
+  5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons
+
+
+Note [Missed opportunity to retain higher-rank kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In 'kcTyClGroup', there is a missed opportunity to make kind
+inference work in a few more cases.  The idea is analogous
+to Note [Single function non-recursive binding special-case]:
+
+     * If we have an SCC with a single decl, which is non-recursive,
+       instead of creating a unification variable representing the
+       kind of the decl and unifying it with the rhs, we can just
+       read the type directly of the rhs.
+
+     * Furthermore, we can update our SCC analysis to ignore
+       dependencies on declarations which have CUSKs: we don't
+       have to kind-check these all at once, since we can use
+       the CUSK to initialize the kind environment.
+
+Unfortunately this requires reworking a bit of the code in
+'kcLTyClDecl' so I've decided to punt unless someone shouts about it.
+
+Note [Don't process associated types in kcLHsQTyVars]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Previously, we processed associated types in the thing_inside in kcLHsQTyVars,
+but this was wrong -- we want to do ATs sepearately.
+The consequence for not doing it this way is #15142:
+
+  class ListTuple (tuple :: Type) (as :: [(k, Type)]) where
+    type ListToTuple as :: Type
+
+We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify
+kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring
+`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't
+unified with Type. And then, when we generalize the kind of ListToTuple (which
+indeed has a CUSK, according to the rules), we skolemize the free metavariable
+kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple,
+because the solveEqualities in kcLHsQTyVars is at TcLevel 1 and so kappa[1]
+will unify with Type.
+
+Bottom line: as associated types should have no effect on a CUSK enclosing class,
+we move processing them to a separate action, run after the outer kind has
+been generalized.
+
+-}
+
+kcTyClGroup :: [LTyClDecl GhcRn] -> TcM [TcTyCon]
+
+-- Kind check this group, kind generalize, and return the resulting local env
+-- This binds the TyCons and Classes of the group, but not the DataCons
+-- See Note [Kind checking for type and class decls]
+-- and Note [Inferring kinds for type declarations]
+kcTyClGroup decls
+  = do  { mod <- getModule
+        ; traceTc "---- kcTyClGroup ---- {"
+                  (text "module" <+> ppr mod $$ vcat (map ppr decls))
+
+          -- Kind checking;
+          --    1. Bind kind variables for decls
+          --    2. Kind-check decls
+          --    3. Generalise the inferred kinds
+          -- See Note [Kind checking for type and class decls]
+
+        ; let (cusk_decls, no_cusk_decls)
+                 = partition (hsDeclHasCusk . unLoc) decls
+
+        ; poly_cusk_tcs <- getInitialKinds True cusk_decls
+
+        ; mono_tcs
+            <- tcExtendKindEnvWithTyCons poly_cusk_tcs $
+               pushTcLevelM_   $  -- We are going to kind-generalise, so
+                                  -- unification variables in here must
+                                  -- be one level in
+               solveEqualities $
+               do {  -- Step 1: Bind kind variables for all decls
+                    mono_tcs <- getInitialKinds False no_cusk_decls
+
+                  ; traceTc "kcTyClGroup: initial kinds" $
+                    ppr_tc_kinds mono_tcs
+
+                    -- Step 2: Set extended envt, kind-check the decls
+                    -- NB: the environment extension overrides the tycon
+                    --     promotion-errors bindings
+                    --     See Note [Type environment evolution]
+                  ; tcExtendKindEnvWithTyCons mono_tcs $
+                    mapM_ kcLTyClDecl no_cusk_decls
+
+                  ; return mono_tcs }
+
+        -- Step 3: generalisation
+        -- Finally, go through each tycon and give it its final kind,
+        -- with all the required, specified, and inferred variables
+        -- in order.
+        ; poly_no_cusk_tcs <- mapAndReportM generaliseTcTyCon mono_tcs
+
+        ; let poly_tcs = poly_cusk_tcs ++ poly_no_cusk_tcs
+        ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs)
+        ; return poly_tcs }
+
+  where
+    ppr_tc_kinds tcs = vcat (map pp_tc tcs)
+    pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)
+
+generaliseTcTyCon :: TcTyCon -> TcM TcTyCon
+generaliseTcTyCon tc
+  -- See Note [Required, Specified, and Inferred for types]
+  = setSrcSpan (getSrcSpan tc) $
+    addTyConCtxt tc $
+    do { let tc_name     = tyConName tc
+             tc_flav     = tyConFlavour tc
+             tc_res_kind = tyConResKind tc
+             tc_tvs      = tyConTyVars  tc
+             user_tyvars = tcTyConUserTyVars tc  -- ToDo: nuke
+
+             (scoped_tv_names, scoped_tvs) = unzip (tcTyConScopedTyVars tc)
+             -- NB: scoped_tvs includes both specified and required (tc_tvs)
+             -- ToDo: Is this a good idea?
+
+       -- Step 1: find all the variables we want to quantify over,
+       --         including Inferred, Specfied, and Required
+       ; dvs <- candidateQTyVarsOfKinds $
+                (tc_res_kind : map tyVarKind scoped_tvs)
+       ; tc_tvs      <- mapM zonkTcTyVarToTyVar tc_tvs
+       ; let full_dvs = dvs { dv_tvs = mkDVarSet tc_tvs }
+
+       -- Step 2: quantify, mainly meaning skolemise the free variables
+       ; qtkvs <- quantifyTyVars emptyVarSet full_dvs
+                  -- Returned 'qtkvs' are scope-sorted and skolemised
+
+       -- Step 3: find the final identity of the Specified and Required tc_tvs
+       -- (remember they all started as TyVarTvs).
+       -- They have been skolemised by quantifyTyVars.
+       ; scoped_tvs  <- mapM zonkTcTyVarToTyVar scoped_tvs
+       ; tc_tvs      <- mapM zonkTcTyVarToTyVar tc_tvs
+       ; tc_res_kind <- zonkTcType tc_res_kind
+
+       ; traceTc "Generalise kind pre" $
+         vcat [ text "tycon =" <+> ppr tc
+              , text "tc_tvs =" <+> pprTyVars tc_tvs
+              , text "scoped_tvs =" <+> pprTyVars scoped_tvs ]
+
+       -- Step 4: Find the Specified and Inferred variables
+       -- First, delete the Required tc_tvs from qtkvs; then
+       -- partition by whether they are scoped (if so, Specified)
+       ; let qtkv_set      = mkVarSet qtkvs
+             tc_tv_set     = mkVarSet tc_tvs
+             specified     = scopedSort $
+                             [ tv | tv <- scoped_tvs
+                                  , not (tv `elemVarSet` tc_tv_set)
+                                  , tv `elemVarSet` qtkv_set ]
+                             -- NB: maintain the L-R order of scoped_tvs
+             spec_req_set  = mkVarSet specified `unionVarSet` tc_tv_set
+             inferred      = filterOut (`elemVarSet` spec_req_set) qtkvs
+
+       -- Step 5: Make the TyConBinders.
+             dep_fv_set     = candidateKindVars dvs
+             inferred_tcbs  = mkNamedTyConBinders Inferred inferred
+             specified_tcbs = mkNamedTyConBinders Specified specified
+             required_tcbs  = map (mkRequiredTyConBinder dep_fv_set) tc_tvs
+
+       -- Step 6: Assemble the final list.
+             final_tcbs = concat [ inferred_tcbs
+                                 , specified_tcbs
+                                 , required_tcbs ]
+
+             scoped_tv_pairs = scoped_tv_names `zip` scoped_tvs
+
+       -- Step 7: Make the result TcTyCon
+             tycon = mkTcTyCon tc_name user_tyvars final_tcbs tc_res_kind
+                            scoped_tv_pairs
+                            True {- it's generalised now -}
+                            (tyConFlavour tc)
+
+       ; traceTc "Generalise kind" $
+         vcat [ text "tycon =" <+> ppr tc
+              , text "tc_tvs =" <+> pprTyVars tc_tvs
+              , text "tc_res_kind =" <+> ppr tc_res_kind
+              , text "scoped_tvs =" <+> pprTyVars scoped_tvs
+              , text "inferred =" <+> pprTyVars inferred
+              , text "specified =" <+> pprTyVars specified
+              , text "required_tcbs =" <+> ppr required_tcbs
+              , text "final_tcbs =" <+> ppr final_tcbs ]
+
+       -- Step 8: check for floating kind vars
+       -- See Note [Free-floating kind vars]
+       -- They are easily identified by the fact that they
+       -- have not been skolemised by quantifyTyVars
+       ; let floating_specified = filter isTyVarTyVar scoped_tvs
+       ; reportFloatingKvs tc_name tc_flav
+                           scoped_tvs floating_specified
+
+       -- Step 9: Check for duplicates
+       -- E.g. data SameKind (a::k) (b::k)
+       --      data T (a::k1) (b::k2) = MkT (SameKind a b)
+       -- Here k1 and k2 start as TyVarTvs, and get unified with each other
+       ; mapM_ report_sig_tv_err (findDupTyVarTvs scoped_tv_pairs)
+
+       -- Step 10: Check for validity.
+       -- We do this here because we're about to put the tycon into
+       -- the environment, and we don't want anything malformed in the
+       -- environment.
+       ; checkValidTelescope tycon
+
+       ; return tycon }
+  where
+    report_sig_tv_err (n1, n2)
+      = setSrcSpan (getSrcSpan n2) $
+        addErrTc (text "Couldn't match" <+> quotes (ppr n1)
+                        <+> text "with" <+> quotes (ppr n2))
+
+{- Note [Required, Specified, and Inferred for types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Each forall'd type variable in a type or kind is one of
+
+  * Required: an argument must be provided at every call site
+
+  * Specified: the argument can be inferred at call sites, but
+    may be instantiated with visible type/kind application
+
+  * Inferred: the must be inferred at call sites; it
+    is unavailable for use with visible type/kind application.
+
+Why have Inferred at all? Because we just can't make user-facing
+promises about the ordering of some variables. These might swizzle
+around even between minor released. By forbidding visible type
+application, we ensure users aren't caught unawares.
+
+Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.
+
+The question for this Note is this:
+   given a TyClDecl, how are its quantified type variables classified?
+Much of the debate is memorialized in #15743.
+
+Here is our design choice. When inferring the ordering of variables
+for a TyCl declaration (that is, for those variables that he user
+has not specified the order with an explicit `forall`), we use the
+following order:
+
+ 1. Inferred variables
+ 2. Specified variables; in the left-to-right order in which
+    the user wrote them, modified by scopedSort (see below)
+    to put them in depdendency order.
+ 3. Required variables before a top-level ::
+ 4. All variables after a top-level ::
+
+If this ordering does not make a valid telescope, we reject the definition.
+
+Example:
+  data SameKind :: k -> k -> *
+  data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)
+
+For X:
+  - a, c, d, x are Required; they are explicitly listed by the user
+    as the positional arguments of Bad
+  - b is Specified; it appears explicitly in a kind signature
+  - k, the kind of a, is Inferred; it is not mentioned explicitly at all
+
+Putting variables in the order Inferred, Specified, Required
+gives us this telescope:
+  Inferred:  k
+  Specified: b : Proxy a
+  Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d)
+
+But this order is ill-scoped, because b's kind mentions a, which occurs
+after b in the telescope. So we reject Bad.
+
+Associated types
+~~~~~~~~~~~~~~~~
+For associated types everything above is determined by the
+associated-type declaration alone, ignoring the class header.
+Here is an example (Trac #15592)
+  class C (a :: k) b where
+    type F (x :: b a)
+
+In the kind of C, 'k' is Specified.  But what about F?
+In the kind of F,
+
+ * Should k be Inferred or Specified?  It's Specified for C,
+   but not mentioned in F's declaration.
+
+ * In which order should the Specified variables a and b occur?
+   It's clearly 'a' then 'b' in C's declaration, but the L-R ordering
+   in F's declaration is 'b' then 'a'.
+
+In both cases we make the choice by looking at F's declaration alone,
+so it gets the kind
+   F :: forall {k}. forall b a. b a -> Type
+
+How it works
+~~~~~~~~~~~~
+These design choices are implemented by two completely different code
+paths for
+
+  * Declarations with a compulete user-specified kind signature (CUSK)
+    Handed by the CUSK case of kcLHsQTyVars.
+
+  * Declarations without a CUSK are handled by kcTyClDecl; see
+    Note [Inferring kinds for type declarations].
+
+Note that neither code path worries about point (4) above, as this
+is nicely handled by not mangling the res_kind. (Mangling res_kinds is done
+*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.)
+
+We can tell Inferred apart from Specified by looking at the scoped
+tyvars; Specified are always included there.
+
+Design alternatives
+~~~~~~~~~~~~~~~~~~~
+
+* For associated types we considered putting the class variables
+  before the local variables, in a nod to the treatment for class
+  methods. But it got too compilicated; see Trac #15592, comment:21ff.
+
+* We rigidly require the ordering above, even though we could be much more
+  permissive. Relevant musings are at
+  https://ghc.haskell.org/trac/ghc/ticket/15743#comment:7
+  The bottom line conclusion is that, if the user wants a different ordering,
+  then can specify it themselves, and it is better to be predictable and dumb
+  than clever and capricious.
+
+  I (Richard) conjecture we could be fully permissive, allowing all classes
+  of variables to intermix. We would have to augment ScopedSort to refuse to
+  reorder Required variables (or check that it wouldn't have). But this would
+  allow more programs. See #15743 for examples. Interestingly, Idris seems
+  to allow this intermixing. The intermixing would be fully specified, in that
+  we can be sure that inference wouldn't change between versions. However,
+  would users be able to predict it? That I cannot answer.
+
+Test cases (and tickets) relevant to these design decisions
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+  T15591*
+  T15592*
+  T15743*
+
+Note [Inferring kinds for type declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This note deals with /inference/ for type declarations
+that do not have a CUSK.  Consider
+  data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x)
+  data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y)
+
+We do kind inference as follows:
+
+* Step 1: Assign initial monomorophic kinds to S, T
+          S :: kk1 -> * -> kk2 -> *
+          T :: kk3 -> * -> kk4 -> *
+  Here kk1 etc are TyVarTvs: that is, unification variables that
+  are allowed to unify only with other type variables. See
+  Note [Signature skolems] in TcType
+
+* Step 2: Extend the environment with a TcTyCon for S and T, with
+  these monomophic kinds.  Now kind-check the declarations, and solve
+  the resulting equalities.  The goal here is to discover constraints
+  on all these unification variables.
+
+  Here we find that kk1 := kk3, and kk2 := kk4.
+
+  This is why we can't use skolems for kk1 etc; they have to
+  unify with each other.
+
+* Step 3. Generalise each TyCon in turn (generaliseTcTyCon).
+  We find the free variables of the kind, skolemise them,
+  sort them out into Inferred/Required/Specified (see the above
+  Note [Required, Specified, and Inferred for types]),
+  and perform some validity checks.
+
+  This makes the utterly-final TyConBinders for the TyCon
+
+  All this is very similar at the level of terms: see TcBinds
+  Note [Quantified variables in partial type signatures]
+
+* Step 4.  Extend the type environment with a TcTyCon for S and T, now
+  with their utterly-final polymorphic kinds (needed for recursive
+  occurrences of S, T).  Now typecheck the declarations, and build the
+  final AlgTyCOn for S and T resp.
+
+The first three steps are in kcTyClGroup;
+the fourth is in tcTyClDecls.
+
+There are some wrinkles
+
+* Do not default TyVarTvs.  We always want to kind-generalise over
+  TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is
+  not allowed to unify with a type; it must stand for a type
+  variable. Hence the check in TcSimplify.defaultTyVarTcS, and
+  TcMType.defaultTyVar.  Here's another example (Trac #14555):
+     data Exp :: [TYPE rep] -> TYPE rep -> Type where
+        Lam :: Exp (a:xs) b -> Exp xs (a -> b)
+  We want to kind-generalise over the 'rep' variable.
+  Trac #14563 is another example.
+
+* Duplicate type variables. Consider Trac #11203
+    data SameKind :: k -> k -> *
+    data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)
+  Here we will unify k1 with k2, but this time doing so is an error,
+  because k1 and k2 are bound in the same declaration.
+
+  We spot this during validity checking (findDupTyVarTvs),
+  in generaliseTcTyCon.
+
+* Required arguments.  Even the Required arguments should be made
+  into TyVarTvs, not skolems.  Consider
+    data T k (a :: k)
+  Here, k is a Required, dependent variable. For uniformity, it is helpful
+  to have k be a TyVarTv, in parallel with other dependent variables.
+
+* Duplicate skolemisation is expected.  When generalising in Step 3,
+  we may find that one of the variables we want to quantify has
+  already been skolemised.  For example, suppose we have already
+  generalise S. When we come to T we'll find that kk1 (now the same as
+  kk3) has already been skolemised.
+
+  That's fine -- but it means that
+    a) when collecting quantification candidates, in
+       candidateQTyVarsOfKind, we must collect skolems
+    b) quantifyTyVars should be a no-op on such a skolem
+-}
+
+--------------
+tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a
+tcExtendKindEnvWithTyCons tcs
+  = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ]
+
+--------------
+mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv
+-- Maps each tycon/datacon to a suitable promotion error
+--    tc :-> APromotionErr TyConPE
+--    dc :-> APromotionErr RecDataConPE
+--    See Note [Recursion and promoting data constructors]
+
+mkPromotionErrorEnv decls
+  = foldr (plusNameEnv . mk_prom_err_env . unLoc)
+          emptyNameEnv decls
+
+mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv
+mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats })
+  = unitNameEnv nm (APromotionErr ClassPE)
+    `plusNameEnv`
+    mkNameEnv [ (name, APromotionErr TyConPE)
+              | (dL->L _ (FamilyDecl { fdLName = (dL->L _ name) })) <- ats ]
+
+mk_prom_err_env (DataDecl { tcdLName = (dL->L _ name)
+                          , tcdDataDefn = HsDataDefn { dd_cons = cons } })
+  = unitNameEnv name (APromotionErr TyConPE)
+    `plusNameEnv`
+    mkNameEnv [ (con, APromotionErr RecDataConPE)
+              | (dL->L _ con') <- cons
+              , (dL->L _ con)  <- getConNames con' ]
+
+mk_prom_err_env decl
+  = unitNameEnv (tcdName decl) (APromotionErr TyConPE)
+    -- Works for family declarations too
+
+--------------
+getInitialKinds :: Bool -> [LTyClDecl GhcRn] -> TcM [TcTyCon]
+-- Returns a TcTyCon for each TyCon bound by the decls,
+-- each with its initial kind
+
+getInitialKinds cusk decls
+  = do { traceTc "getInitialKinds {" empty
+       ; tcs <- concatMapM (addLocM (getInitialKind cusk)) decls
+       ; traceTc "getInitialKinds done }" empty
+       ; return tcs }
+
+getInitialKind :: Bool -> TyClDecl GhcRn -> TcM [TcTyCon]
+-- Allocate a fresh kind variable for each TyCon and Class
+-- For each tycon, return a TcTyCon with kind k
+-- where k is the kind of tc, derived from the LHS
+--         of the definition (and probably including
+--         kind unification variables)
+--      Example: data T a b = ...
+--      return (T, kv1 -> kv2 -> kv3)
+--
+-- This pass deals with (ie incorporates into the kind it produces)
+--   * The kind signatures on type-variable binders
+--   * The result kinds signature on a TyClDecl
+--
+-- No family instances are passed to getInitialKinds
+
+getInitialKind cusk
+    (ClassDecl { tcdLName = dL->L _ name
+               , tcdTyVars = ktvs
+               , tcdATs = ats })
+  = do { tycon <- kcLHsQTyVars name ClassFlavour cusk ktvs $
+                  return constraintKind
+       ; let parent_tv_prs = tcTyConScopedTyVars tycon
+            -- See Note [Don't process associated types in kcLHsQTyVars]
+       ; inner_tcs <- tcExtendNameTyVarEnv parent_tv_prs $
+                      getFamDeclInitialKinds (Just tycon) ats
+       ; return (tycon : inner_tcs) }
+
+getInitialKind cusk
+    (DataDecl { tcdLName = dL->L _ name
+              , tcdTyVars = ktvs
+              , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
+                                         , dd_ND = new_or_data } })
+  = do  { let flav = newOrDataToFlavour new_or_data
+        ; tc <- kcLHsQTyVars name flav cusk ktvs $
+                case m_sig of
+                   Just ksig -> tcLHsKindSig (DataKindCtxt name) ksig
+                   Nothing   -> return liftedTypeKind
+        ; return [tc] }
+
+getInitialKind _ (FamDecl { tcdFam = decl })
+  = do { tc <- getFamDeclInitialKind Nothing decl
+       ; return [tc] }
+
+getInitialKind cusk (SynDecl { tcdLName = dL->L _ name
+                             , tcdTyVars = ktvs
+                             , tcdRhs = rhs })
+  = do  { tycon <- kcLHsQTyVars name TypeSynonymFlavour cusk ktvs $
+                   case kind_annotation rhs of
+                     Just ksig -> tcLHsKindSig (TySynKindCtxt name) ksig
+                     Nothing   -> newMetaKindVar
+        ; return [tycon] }
+  where
+    -- Keep this synchronized with 'hsDeclHasCusk'.
+    kind_annotation (dL->L _ ty) = case ty of
+        HsParTy _ lty     -> kind_annotation lty
+        HsKindSig _ _ k   -> Just k
+        _                 -> Nothing
+
+getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "getInitialKind"
+getInitialKind _ (XTyClDecl _) = panic "getInitialKind"
+
+---------------------------------
+getFamDeclInitialKinds
+  :: Maybe TcTyCon -- ^ Enclosing class TcTyCon, if any
+  -> [LFamilyDecl GhcRn]
+  -> TcM [TcTyCon]
+getFamDeclInitialKinds mb_parent_tycon decls
+  = mapM (addLocM (getFamDeclInitialKind mb_parent_tycon)) decls
+
+getFamDeclInitialKind
+  :: Maybe TcTyCon -- ^ Enclosing class TcTyCon, if any
+  -> FamilyDecl GhcRn
+  -> TcM TcTyCon
+getFamDeclInitialKind mb_parent_tycon
+    decl@(FamilyDecl { fdLName     = (dL->L _ name)
+                     , fdTyVars    = ktvs
+                     , fdResultSig = (dL->L _ resultSig)
+                     , fdInfo      = info })
+  = kcLHsQTyVars name flav cusk ktvs $
+    case resultSig of
+      KindSig _ ki                              -> tcLHsKindSig ctxt ki
+      TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki
+      _ -- open type families have * return kind by default
+        | tcFlavourIsOpen flav              -> return liftedTypeKind
+               -- closed type families have their return kind inferred
+               -- by default
+        | otherwise                         -> newMetaKindVar
+  where
+    mb_cusk = tcTyConIsPoly <$> mb_parent_tycon
+    cusk    = famDeclHasCusk mb_cusk decl
+    flav  = case info of
+      DataFamily         -> DataFamilyFlavour mb_parent_tycon
+      OpenTypeFamily     -> OpenTypeFamilyFlavour mb_parent_tycon
+      ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon )
+                            ClosedTypeFamilyFlavour
+    ctxt  = TyFamResKindCtxt name
+getFamDeclInitialKind _ (XFamilyDecl _) = panic "getFamDeclInitialKind"
+
+------------------------------------------------------------------------
+kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()
+  -- See Note [Kind checking for type and class decls]
+kcLTyClDecl (dL->L loc decl)
+  = setSrcSpan loc $
+    tcAddDeclCtxt decl $
+    do { traceTc "kcTyClDecl {" (ppr tc_name)
+       ; kcTyClDecl decl
+       ; traceTc "kcTyClDecl done }" (ppr tc_name) }
+  where
+    tc_name = tyClDeclLName decl
+
+kcTyClDecl :: TyClDecl GhcRn -> TcM ()
+-- This function is used solely for its side effect on kind variables
+-- NB kind signatures on the type variables and
+--    result kind signature have already been dealt with
+--    by getInitialKind, so we can ignore them here.
+
+kcTyClDecl (DataDecl { tcdLName    = (dL->L _ name)
+                     , tcdDataDefn = defn })
+  | HsDataDefn { dd_cons = cons@((dL->L _ (ConDeclGADT {})) : _)
+               , dd_ctxt = (dL->L _ []) } <- defn
+  = mapM_ (wrapLocM_ kcConDecl) cons
+    -- hs_tvs and dd_kindSig already dealt with in getInitialKind
+    -- This must be a GADT-style decl,
+    --        (see invariants of DataDefn declaration)
+    -- so (a) we don't need to bring the hs_tvs into scope, because the
+    --        ConDecls bind all their own variables
+    --    (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it
+
+  | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } <- defn
+  = bindTyClTyVars name $ \ _ _ ->
+    do  { _ <- tcHsContext ctxt
+        ; mapM_ (wrapLocM_ kcConDecl) cons }
+
+kcTyClDecl (SynDecl { tcdLName = dL->L _ name, tcdRhs = rhs })
+  = bindTyClTyVars name $ \ _ res_kind ->
+    discardResult $ tcCheckLHsType rhs res_kind
+        -- NB: check against the result kind that we allocated
+        -- in getInitialKinds.
+
+kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name)
+                      , tcdCtxt = ctxt, tcdSigs = sigs })
+  = bindTyClTyVars name $ \ _ _ ->
+    do  { _ <- tcHsContext ctxt
+        ; mapM_ (wrapLocM_ kc_sig) sigs }
+  where
+    kc_sig (ClassOpSig _ _ nms op_ty) = kcHsSigType nms op_ty
+    kc_sig _                          = return ()
+
+kcTyClDecl (FamDecl _ (FamilyDecl { fdLName  = (dL->L _ fam_tc_name)
+                                  , fdInfo   = fd_info }))
+-- closed type families look at their equations, but other families don't
+-- do anything here
+  = case fd_info of
+      ClosedTypeFamily (Just eqns) ->
+        do { fam_tc <- kcLookupTcTyCon fam_tc_name
+           ; mapM_ (kcTyFamInstEqn fam_tc) eqns }
+      _ -> return ()
+kcTyClDecl (FamDecl _ (XFamilyDecl _))              = panic "kcTyClDecl"
+kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "kcTyClDecl"
+kcTyClDecl (XTyClDecl _)                            = panic "kcTyClDecl"
+
+-------------------
+kcConDecl :: ConDecl GhcRn -> TcM ()
+kcConDecl (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
+                      , con_mb_cxt = ex_ctxt, con_args = args })
+  = addErrCtxt (dataConCtxtName [name]) $
+    discardResult                   $
+    bindExplicitTKBndrs_Skol ex_tvs $
+    do { _ <- tcHsMbContext ex_ctxt
+       ; traceTc "kcConDecl {" (ppr name $$ ppr args)
+       ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args)
+       ; traceTc "kcConDecl }" (ppr name)
+       }
+              -- We don't need to check the telescope here, because that's
+              -- done in tcConDecl
+
+kcConDecl (ConDeclGADT { con_names = names
+                       , con_qvars = qtvs, con_mb_cxt = cxt
+                       , con_args = args, con_res_ty = res_ty })
+  | HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = implicit_tkv_nms }
+           , hsq_explicit = explicit_tkv_nms } <- qtvs
+  = -- Even though the data constructor's type is closed, we
+    -- must still kind-check the type, because that may influence
+    -- the inferred kind of the /type/ constructor.  Example:
+    --    data T f a where
+    --      MkT :: f a -> T f a
+    -- If we don't look at MkT we won't get the correct kind
+    -- for the type constructor T
+    addErrCtxt (dataConCtxtName names) $
+    discardResult $
+    bindImplicitTKBndrs_Tv implicit_tkv_nms $
+    bindExplicitTKBndrs_Tv explicit_tkv_nms $
+        -- Why "_Tv"?  See Note [Kind-checking for GADTs]
+    do { _ <- tcHsMbContext cxt
+       ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args)
+       ; _ <- tcHsOpenType res_ty
+       ; return () }
+kcConDecl (XConDecl _) = panic "kcConDecl"
+kcConDecl (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _) = panic "kcConDecl"
+
+{-
+Note [Recursion and promoting data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't want to allow promotion in a strongly connected component
+when kind checking.
+
+Consider:
+  data T f = K (f (K Any))
+
+When kind checking the `data T' declaration the local env contains the
+mappings:
+  T -> ATcTyCon <some initial kind>
+  K -> APromotionErr
+
+APromotionErr is only used for DataCons, and only used during type checking
+in tcTyClGroup.
+
+Note [Kind-checking for GADTs]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+  data Proxy a where
+    MkProxy1 :: forall k (b :: k). Proxy b
+    MkProxy2 :: forall j (c :: j). Proxy c
+
+It seems reasonable that this should be accepted. But something very strange
+is going on here: when we're kind-checking this declaration, we need to unify
+the kind of `a` with k and j -- even though k and j's scopes are local to the type of
+MkProxy{1,2}. The best approach we've come up with is to use TyVarTvs during
+the kind-checking pass. First off, note that it's OK if the kind-checking pass
+is too permissive: we'll snag the problems in the type-checking pass later.
+(This extra permissiveness might happen with something like
+
+  data SameKind :: k -> k -> Type
+  data Bad a where
+    MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b)
+
+which would be accepted if k1 and k2 were TyVarTvs. This is correctly rejected
+in the second pass, though. Test case: polykinds/TyVarTvKinds3)
+Recall that the kind-checking pass exists solely to collect constraints
+on the kinds and to power unification.
+
+To achieve the use of TyVarTvs, we must be careful to use specialized functions
+that produce TyVarTvs, not ordinary skolems. This is why we need
+kcExplicitTKBndrs and kcImplicitTKBndrs in TcHsType, separate from their
+tc... variants.
+
+The drawback of this approach is sometimes it will accept a definition that
+a (hypothetical) declarative specification would likely reject. As a general
+rule, we don't want to allow polymorphic recursion without a CUSK. Indeed,
+the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs
+approach allows a limited form of polymorphic recursion *without* a CUSK.
+
+To wit:
+  data T a = forall k (b :: k). MkT (T b) Int
+  (test case: dependent/should_compile/T14066a)
+
+Note that this is polymorphically recursive, with the recursive occurrence
+of T used at a kind other than a's kind. The approach outlined here accepts
+this definition, because this kind is still a kind variable (and so the
+TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a
+way to describe exactly what declarations will be accepted and which will
+be rejected (without a CUSK). However, the accepted definitions are indeed
+well-kinded and any rejected definitions would be accepted with a CUSK,
+and so this wrinkle need not cause anyone to lose sleep.
+
+************************************************************************
+*                                                                      *
+\subsection{Type checking}
+*                                                                      *
+************************************************************************
+
+Note [Type checking recursive type and class declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+At this point we have completed *kind-checking* of a mutually
+recursive group of type/class decls (done in kcTyClGroup). However,
+we discarded the kind-checked types (eg RHSs of data type decls);
+note that kcTyClDecl returns ().  There are two reasons:
+
+  * It's convenient, because we don't have to rebuild a
+    kinded HsDecl (a fairly elaborate type)
+
+  * It's necessary, because after kind-generalisation, the
+    TyCons/Classes may now be kind-polymorphic, and hence need
+    to be given kind arguments.
+
+Example:
+       data T f a = MkT (f a) (T f a)
+During kind-checking, we give T the kind T :: k1 -> k2 -> *
+and figure out constraints on k1, k2 etc. Then we generalise
+to get   T :: forall k. (k->*) -> k -> *
+So now the (T f a) in the RHS must be elaborated to (T k f a).
+
+However, during tcTyClDecl of T (above) we will be in a recursive
+"knot". So we aren't allowed to look at the TyCon T itself; we are only
+allowed to put it (lazily) in the returned structures.  But when
+kind-checking the RHS of T's decl, we *do* need to know T's kind (so
+that we can correctly elaboarate (T k f a).  How can we get T's kind
+without looking at T?  Delicate answer: during tcTyClDecl, we extend
+
+  *Global* env with T -> ATyCon (the (not yet built) final TyCon for T)
+  *Local*  env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T)
+
+Then:
+
+  * During TcHsType.tcTyVar we look in the *local* env, to get the
+    fully-known, not knot-tied TcTyCon for T.
+
+  * Then, in TcHsSyn.zonkTcTypeToType (and zonkTcTyCon in particular)
+    we look in the *global* env to get the TyCon.
+
+This fancy footwork (with two bindings for T) is only necessary for the
+TyCons or Classes of this recursive group.  Earlier, finished groups,
+live in the global env only.
+
+See also Note [Kind checking recursive type and class declarations]
+
+Note [Kind checking recursive type and class declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Before we can type-check the decls, we must kind check them. This
+is done by establishing an "initial kind", which is a rather uninformed
+guess at a tycon's kind (by counting arguments, mainly) and then
+using this initial kind for recursive occurrences.
+
+The initial kind is stored in exactly the same way during
+kind-checking as it is during type-checking (Note [Type checking
+recursive type and class declarations]): in the *local* environment,
+with ATcTyCon. But we still must store *something* in the *global*
+environment. Even though we discard the result of kind-checking, we
+sometimes need to produce error messages. These error messages will
+want to refer to the tycons being checked, except that they don't
+exist yet, and it would be Terribly Annoying to get the error messages
+to refer back to HsSyn. So we create a TcTyCon and put it in the
+global env. This tycon can print out its name and knows its kind, but
+any other action taken on it will panic. Note that TcTyCons are *not*
+knot-tied, unlike the rather valid but knot-tied ones that occur
+during type-checking.
+
+Note [Declarations for wired-in things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For wired-in things we simply ignore the declaration
+and take the wired-in information.  That avoids complications.
+e.g. the need to make the data constructor worker name for
+     a constraint tuple match the wired-in one
+-}
+
+tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM TyCon
+tcTyClDecl roles_info (dL->L loc decl)
+  | Just thing <- wiredInNameTyThing_maybe (tcdName decl)
+  = case thing of -- See Note [Declarations for wired-in things]
+      ATyCon tc -> return tc
+      _ -> pprPanic "tcTyClDecl" (ppr thing)
+
+  | otherwise
+  = setSrcSpan loc $ tcAddDeclCtxt decl $
+    do { traceTc "---- tcTyClDecl ---- {" (ppr decl)
+       ; tc <- tcTyClDecl1 Nothing roles_info decl
+       ; traceTc "---- tcTyClDecl end ---- }" (ppr tc)
+       ; return tc }
+
+  -- "type family" declarations
+tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM TyCon
+tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd })
+  = tcFamDecl1 parent fd
+
+  -- "type" synonym declaration
+tcTyClDecl1 _parent roles_info
+            (SynDecl { tcdLName = (dL->L _ tc_name)
+                     , tcdRhs   = rhs })
+  = ASSERT( isNothing _parent )
+    bindTyClTyVars tc_name $ \ binders res_kind ->
+    tcTySynRhs roles_info tc_name binders res_kind rhs
+
+  -- "data/newtype" declaration
+tcTyClDecl1 _parent roles_info
+            (DataDecl { tcdLName = (dL->L _ tc_name)
+                      , tcdDataDefn = defn })
+  = ASSERT( isNothing _parent )
+    bindTyClTyVars tc_name $ \ tycon_binders res_kind ->
+    tcDataDefn roles_info tc_name tycon_binders res_kind defn
+
+tcTyClDecl1 _parent roles_info
+            (ClassDecl { tcdLName = (dL->L _ class_name)
+                       , tcdCtxt = hs_ctxt
+                       , tcdMeths = meths
+                       , tcdFDs = fundeps
+                       , tcdSigs = sigs
+                       , tcdATs = ats
+                       , tcdATDefs = at_defs })
+  = ASSERT( isNothing _parent )
+    do { clas <- tcClassDecl1 roles_info class_name hs_ctxt
+                              meths fundeps sigs ats at_defs
+       ; return (classTyCon clas) }
+
+tcTyClDecl1 _ _ (XTyClDecl _) = panic "tcTyClDecl1"
+
+
+{- *********************************************************************
+*                                                                      *
+          Class declarations
+*                                                                      *
+********************************************************************* -}
+
+tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn
+             -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn]
+             -> [LFamilyDecl GhcRn] -> [LTyFamDefltEqn GhcRn]
+             -> TcM Class
+tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs
+  = fixM $ \ clas ->
+    -- We need the knot because 'clas' is passed into tcClassATs
+    bindTyClTyVars class_name $ \ binders res_kind ->
+    do { MASSERT2( tcIsConstraintKind res_kind
+                 , ppr class_name $$ ppr res_kind )
+       ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)
+       ; let tycon_name = class_name        -- We use the same name
+             roles = roles_info tycon_name  -- for TyCon and Class
+
+       ; (ctxt, fds, sig_stuff, at_stuff)
+            <- pushTcLevelM_   $
+               solveEqualities $
+               do { ctxt <- tcHsContext hs_ctxt
+                  ; fds  <- mapM (addLocM tc_fundep) fundeps
+                  ; sig_stuff <- tcClassSigs class_name sigs meths
+                  ; at_stuff  <- tcClassATs class_name clas ats at_defs
+                  ; return (ctxt, fds, sig_stuff, at_stuff) }
+
+       -- The solveEqualities will report errors for any
+       -- unsolved equalities, so these zonks should not encounter
+       -- any unfilled coercion variables unless there is such an error
+       -- The zonk also squeeze out the TcTyCons, and converts
+       -- Skolems to tyvars.
+       ; ze        <- emptyZonkEnv
+       ; ctxt      <- zonkTcTypesToTypesX ze ctxt
+       ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff
+         -- ToDo: do we need to zonk at_stuff?
+
+       -- TODO: Allow us to distinguish between abstract class,
+       -- and concrete class with no methods (maybe by
+       -- specifying a trailing where or not
+
+       ; mindef <- tcClassMinimalDef class_name sigs sig_stuff
+       ; is_boot <- tcIsHsBootOrSig
+       ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff
+                  = Nothing
+                  | otherwise
+                  = Just (ctxt, at_stuff, sig_stuff, mindef)
+
+       ; clas <- buildClass class_name binders roles fds body
+       ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$
+                                ppr fds)
+       ; return clas }
+  where
+    tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;
+                                ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ;
+                                ; return (tvs1', tvs2') }
+
+
+{- Note [Associated type defaults]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The following is an example of associated type defaults:
+             class C a where
+               data D a
+
+               type F a b :: *
+               type F a b = [a]        -- Default
+
+Note that we can get default definitions only for type families, not data
+families.
+-}
+
+tcClassATs :: Name                   -- The class name (not knot-tied)
+           -> Class                  -- The class parent of this associated type
+           -> [LFamilyDecl GhcRn]    -- Associated types.
+           -> [LTyFamDefltEqn GhcRn] -- Associated type defaults.
+           -> TcM [ClassATItem]
+tcClassATs class_name cls ats at_defs
+  = do {  -- Complain about associated type defaults for non associated-types
+         sequence_ [ failWithTc (badATErr class_name n)
+                   | n <- map at_def_tycon at_defs
+                   , not (n `elemNameSet` at_names) ]
+       ; mapM tc_at ats }
+  where
+    at_def_tycon :: LTyFamDefltEqn GhcRn -> Name
+    at_def_tycon (dL->L _ eqn) = unLoc (feqn_tycon eqn)
+
+    at_fam_name :: LFamilyDecl GhcRn -> Name
+    at_fam_name (dL->L _ decl) = unLoc (fdLName decl)
+
+    at_names = mkNameSet (map at_fam_name ats)
+
+    at_defs_map :: NameEnv [LTyFamDefltEqn GhcRn]
+    -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs'
+    at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv
+                                          (at_def_tycon at_def) [at_def])
+                        emptyNameEnv at_defs
+
+    tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at
+                  ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)
+                                  `orElse` []
+                  ; atd <- tcDefaultAssocDecl fam_tc at_defs
+                  ; return (ATI fam_tc atd) }
+
+-------------------------
+tcDefaultAssocDecl :: TyCon                    -- ^ Family TyCon (not knot-tied)
+                   -> [LTyFamDefltEqn GhcRn]        -- ^ Defaults
+                   -> TcM (Maybe (KnotTied Type, SrcSpan))   -- ^ Type checked RHS
+tcDefaultAssocDecl _ []
+  = return Nothing  -- No default declaration
+
+tcDefaultAssocDecl _ (d1:_:_)
+  = failWithTc (text "More than one default declaration for"
+                <+> ppr (feqn_tycon (unLoc d1)))
+
+tcDefaultAssocDecl fam_tc [dL->L loc (FamEqn { feqn_tycon = L _ tc_name
+                                             , feqn_pats = hs_tvs
+                                             , feqn_rhs = hs_rhs_ty })]
+  | HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = imp_vars}
+           , hsq_explicit = exp_vars } <- hs_tvs
+  = -- See Note [Type-checking default assoc decls]
+    setSrcSpan loc $
+    tcAddFamInstCtxt (text "default type instance") tc_name $
+    do { traceTc "tcDefaultAssocDecl" (ppr tc_name)
+       ; let fam_tc_name = tyConName fam_tc
+             fam_arity = length (tyConVisibleTyVars fam_tc)
+
+       -- Kind of family check
+       ; ASSERT( fam_tc_name == tc_name )
+         checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
+
+       -- Arity check
+       ; checkTc (exp_vars `lengthIs` fam_arity)
+                 (wrongNumberOfParmsErr fam_arity)
+
+       -- Typecheck RHS
+       ; let hs_pats = map (HsValArg . hsLTyVarBndrToType) exp_vars
+
+          -- NB: Use tcFamTyPats, not bindTyClTyVars. The latter expects to get
+          -- the LHsQTyVars used for declaring a tycon, but the names here
+          -- are different.
+
+          -- You might think we should pass in some AssocInstInfo, as we're looking
+          -- at an associated type. But this would be wrong, because an associated
+          -- type default LHS can mention *different* type variables than the
+          -- enclosing class. So it's treated more as a freestanding beast.
+       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated
+                                                    imp_vars exp_vars
+                                                    hs_pats hs_rhs_ty
+
+         -- See Note [Type-checking default assoc decls]
+       ; traceTc "tcDefault" (vcat [ppr (tyConTyVars fam_tc), ppr qtvs, ppr pats])
+       ; case tcMatchTys pats (mkTyVarTys (tyConTyVars fam_tc)) of
+           Just subst -> return (Just (substTyUnchecked subst rhs_ty, loc) )
+           Nothing    -> failWithTc (defaultAssocKindErr fam_tc)
+           -- We check for well-formedness and validity later,
+           -- in checkValidClass
+     }
+tcDefaultAssocDecl _ [dL->L _ (XFamEqn _)] = panic "tcDefaultAssocDecl"
+tcDefaultAssocDecl _ [dL->L _ (FamEqn _ _ _ (XLHsQTyVars _) _ _)]
+  = panic "tcDefaultAssocDecl"
+tcDefaultAssocDecl _ [_]
+  = panic "tcDefaultAssocDecl: Impossible Match" -- due to #15884
+
+
+{- Note [Type-checking default assoc decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this default declaration for an associated type
+
+   class C a where
+      type F (a :: k) b :: *
+      type F x y = Proxy x -> y
+
+Note that the class variable 'a' doesn't scope over the default assoc
+decl (rather oddly I think), and (less oddly) neither does the second
+argument 'b' of the associated type 'F', or the kind variable 'k'.
+Instead, the default decl is treated more like a top-level type
+instance.
+
+However we store the default rhs (Proxy x -> y) in F's TyCon, using
+F's own type variables, so we need to convert it to (Proxy a -> b).
+We do this by calling tcMatchTys to match them up.  This also ensures
+that x's kind matches a's and similarly for y and b.  The error
+message isn't great, mind you.  (Trac #11361 was caused by not doing a
+proper tcMatchTys here.)
+
+Recall also that the left-hand side of an associated type family
+default is always just variables -- no tycons here. Accordingly,
+the patterns used in the tcMatchTys won't actually be knot-tied,
+even though we're in the knot. This is too delicate for my taste,
+but it works.
+
+-}
+
+{- *********************************************************************
+*                                                                      *
+          Type family declarations
+*                                                                      *
+********************************************************************* -}
+
+tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon
+tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info
+                              , fdLName = tc_lname@(dL->L _ tc_name)
+                              , fdResultSig = (dL->L _ sig)
+                              , fdTyVars = user_tyvars
+                              , fdInjectivityAnn = inj })
+  | DataFamily <- fam_info
+  = bindTyClTyVars tc_name $ \ binders res_kind -> do
+  { traceTc "data family:" (ppr tc_name)
+  ; checkFamFlag tc_name
+
+  -- Check that the result kind is OK
+  -- We allow things like
+  --   data family T (a :: Type) :: forall k. k -> Type
+  -- We treat T as having arity 1, but result kind forall k. k -> Type
+  -- But we want to check that the result kind finishes in
+  --   Type or a kind-variable
+  -- For the latter, consider
+  --   data family D a :: forall k. Type -> k
+  ; let (_, final_res_kind) = splitPiTys res_kind
+  ; checkTc (tcIsLiftedTypeKind final_res_kind
+             || isJust (tcGetCastedTyVar_maybe final_res_kind))
+            (badKindSig False res_kind)
+
+  ; tc_rep_name <- newTyConRepName tc_name
+  ; let tycon = mkFamilyTyCon tc_name binders
+                              res_kind
+                              (resultVariableName sig)
+                              (DataFamilyTyCon tc_rep_name)
+                              parent NotInjective
+  ; return tycon }
+
+  | OpenTypeFamily <- fam_info
+  = bindTyClTyVars tc_name $ \ binders res_kind -> do
+  { traceTc "open type family:" (ppr tc_name)
+  ; checkFamFlag tc_name
+  ; inj' <- tcInjectivity binders inj
+  ; let tycon = mkFamilyTyCon tc_name binders res_kind
+                               (resultVariableName sig) OpenSynFamilyTyCon
+                               parent inj'
+  ; return tycon }
+
+  | ClosedTypeFamily mb_eqns <- fam_info
+  = -- Closed type families are a little tricky, because they contain the definition
+    -- of both the type family and the equations for a CoAxiom.
+    do { traceTc "Closed type family:" (ppr tc_name)
+         -- the variables in the header scope only over the injectivity
+         -- declaration but this is not involved here
+       ; (inj', binders, res_kind)
+            <- bindTyClTyVars tc_name $ \ binders res_kind ->
+               do { inj' <- tcInjectivity binders inj
+                  ; return (inj', binders, res_kind) }
+
+       ; checkFamFlag tc_name -- make sure we have -XTypeFamilies
+
+         -- If Nothing, this is an abstract family in a hs-boot file;
+         -- but eqns might be empty in the Just case as well
+       ; case mb_eqns of
+           Nothing   ->
+               return $ mkFamilyTyCon tc_name binders res_kind
+                                      (resultVariableName sig)
+                                      AbstractClosedSynFamilyTyCon parent
+                                      inj'
+           Just eqns -> do {
+
+         -- Process the equations, creating CoAxBranches
+       ; let tc_fam_tc = mkTcTyCon tc_name (ppr user_tyvars) binders res_kind
+                                   [] False {- this doesn't matter here -}
+                                   ClosedTypeFamilyFlavour
+
+       ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns
+         -- Do not attempt to drop equations dominated by earlier
+         -- ones here; in the case of mutual recursion with a data
+         -- type, we get a knot-tying failure.  Instead we check
+         -- for this afterwards, in TcValidity.checkValidCoAxiom
+         -- Example: tc265
+
+         -- Create a CoAxiom, with the correct src location.
+       ; co_ax_name <- newFamInstAxiomName tc_lname []
+
+       ; let mb_co_ax
+              | null eqns = Nothing   -- mkBranchedCoAxiom fails on empty list
+              | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches)
+
+             fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig)
+                      (ClosedSynFamilyTyCon mb_co_ax) parent inj'
+
+         -- We check for instance validity later, when doing validity
+         -- checking for the tycon. Exception: checking equations
+         -- overlap done by dropDominatedAxioms
+       ; return fam_tc } }
+
+  | otherwise = panic "tcFamInst1"  -- Silence pattern-exhaustiveness checker
+tcFamDecl1 _ (XFamilyDecl _) = panic "tcFamDecl1"
+
+-- | Maybe return a list of Bools that say whether a type family was declared
+-- injective in the corresponding type arguments. Length of the list is equal to
+-- the number of arguments (including implicit kind/coercion arguments).
+-- True on position
+-- N means that a function is injective in its Nth argument. False means it is
+-- not.
+tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn)
+              -> TcM Injectivity
+tcInjectivity _ Nothing
+  = return NotInjective
+
+  -- User provided an injectivity annotation, so for each tyvar argument we
+  -- check whether a type family was declared injective in that argument. We
+  -- return a list of Bools, where True means that corresponding type variable
+  -- was mentioned in lInjNames (type family is injective in that argument) and
+  -- False means that it was not mentioned in lInjNames (type family is not
+  -- injective in that type variable). We also extend injectivity information to
+  -- kind variables, so if a user declares:
+  --
+  --   type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a
+  --
+  -- then we mark both `a` and `k1` as injective.
+  -- NB: the return kind is considered to be *input* argument to a type family.
+  -- Since injectivity allows to infer input arguments from the result in theory
+  -- we should always mark the result kind variable (`k3` in this example) as
+  -- injective.  The reason is that result type has always an assigned kind and
+  -- therefore we can always infer the result kind if we know the result type.
+  -- But this does not seem to be useful in any way so we don't do it.  (Another
+  -- reason is that the implementation would not be straightforward.)
+tcInjectivity tcbs (Just (dL->L loc (InjectivityAnn _ lInjNames)))
+  = setSrcSpan loc $
+    do { let tvs = binderVars tcbs
+       ; dflags <- getDynFlags
+       ; checkTc (xopt LangExt.TypeFamilyDependencies dflags)
+                 (text "Illegal injectivity annotation" $$
+                  text "Use TypeFamilyDependencies to allow this")
+       ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames
+       ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds
+       ; let inj_ktvs = filterVarSet isTyVar $  -- no injective coercion vars
+                        closeOverKinds (mkVarSet inj_tvs)
+       ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs
+       ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs
+                                       , ppr inj_ktvs, ppr inj_bools ])
+       ; return $ Injective inj_bools }
+
+tcTySynRhs :: RolesInfo
+           -> Name
+           -> [TyConBinder] -> Kind
+           -> LHsType GhcRn -> TcM TyCon
+tcTySynRhs roles_info tc_name binders res_kind hs_ty
+  = do { env <- getLclEnv
+       ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))
+       ; rhs_ty <- pushTcLevelM_   $
+                   solveEqualities $
+                   tcCheckLHsType hs_ty res_kind
+       ; rhs_ty <- zonkTcTypeToType rhs_ty
+       ; let roles = roles_info tc_name
+             tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty
+       ; return tycon }
+
+tcDataDefn :: RolesInfo -> Name
+           -> [TyConBinder] -> Kind
+           -> HsDataDefn GhcRn -> TcM TyCon
+  -- NB: not used for newtype/data instances (whether associated or not)
+tcDataDefn roles_info
+           tc_name tycon_binders res_kind
+           (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
+                       , dd_ctxt = ctxt
+                       , dd_kindSig = mb_ksig  -- Already in tc's kind
+                                               -- via getInitialKinds
+                       , dd_cons = cons })
+ =  do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons
+
+       ; tcg_env <- getGblEnv
+       ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind
+
+       ; let hsc_src = tcg_src tcg_env
+       ; unless (mk_permissive_kind hsc_src cons) $
+         checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind)
+
+       ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt
+       ; stupid_theta    <- zonkTcTypesToTypes stupid_tc_theta
+       ; kind_signatures <- xoptM LangExt.KindSignatures
+
+             -- Check that we don't use kind signatures without Glasgow extensions
+       ; when (isJust mb_ksig) $
+         checkTc (kind_signatures) (badSigTyDecl tc_name)
+
+       ; tycon <- fixM $ \ tycon -> do
+             { let final_bndrs = tycon_binders `chkAppend` extra_bndrs
+                   res_ty      = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs))
+                   roles       = roles_info tc_name
+
+             ; data_cons <- tcConDecls tycon final_bndrs res_ty cons
+             ; tc_rhs    <- mk_tc_rhs hsc_src tycon data_cons
+             ; tc_rep_nm <- newTyConRepName tc_name
+             ; return (mkAlgTyCon tc_name
+                                  final_bndrs
+                                  final_res_kind
+                                  roles
+                                  (fmap unLoc cType)
+                                  stupid_theta tc_rhs
+                                  (VanillaAlgTyCon tc_rep_nm)
+                                  gadt_syntax) }
+       ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs)
+       ; return tycon }
+  where
+    -- Abstract data types in hsig files can have arbitrary kinds,
+    -- because they may be implemented by type synonyms
+    -- (which themselves can have arbitrary kinds, not just *)
+    mk_permissive_kind HsigFile [] = True
+    mk_permissive_kind _ _ = False
+
+    -- In hs-boot, a 'data' declaration with no constructors
+    -- indicates a nominally distinct abstract data type.
+    mk_tc_rhs HsBootFile _ []
+      = return AbstractTyCon
+
+    mk_tc_rhs HsigFile _ [] -- ditto
+      = return AbstractTyCon
+
+    mk_tc_rhs _ tycon data_cons
+      = case new_or_data of
+          DataType -> return (mkDataTyConRhs data_cons)
+          NewType  -> ASSERT( not (null data_cons) )
+                      mkNewTyConRhs tc_name tycon (head data_cons)
+tcDataDefn _ _ _ _ (XHsDataDefn _) = panic "tcDataDefn"
+
+
+-------------------------
+kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()
+-- Used for the equations of a closed type family only
+-- Not used for data/type instances
+kcTyFamInstEqn tc_fam_tc
+    (dL->L loc (HsIB { hsib_ext = imp_vars
+                     , hsib_body = FamEqn { feqn_tycon = dL->L _ eqn_tc_name
+                                          , feqn_bndrs = mb_expl_bndrs
+                                          , feqn_pats  = hs_pats
+                                          , feqn_rhs   = hs_rhs_ty }}))
+  = setSrcSpan loc $
+    do { traceTc "kcTyFamInstEqn" (vcat
+           [ text "tc_name ="    <+> ppr eqn_tc_name
+           , text "fam_tc ="     <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc)
+           , text "hsib_vars ="  <+> ppr imp_vars
+           , text "feqn_bndrs =" <+> ppr mb_expl_bndrs
+           , text "feqn_pats ="  <+> ppr hs_pats ])
+          -- this check reports an arity error instead of a kind error; easier for user
+       ; let vis_pats = numVisibleArgs hs_pats
+       ; checkTc (vis_pats == vis_arity) $
+                  wrongNumberOfParmsErr vis_arity
+       ; discardResult $
+         bindImplicitTKBndrs_Q_Tv imp_vars $
+         bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $
+         do { (_, res_kind) <- tcFamTyPats tc_fam_tc hs_pats
+            ; tcCheckLHsType hs_rhs_ty res_kind }
+             -- Why "_Tv" here?  Consider (Trac #14066
+             --  type family Bar x y where
+             --      Bar (x :: a) (y :: b) = Int
+             --      Bar (x :: c) (y :: d) = Bool
+             -- During kind-checkig, a,b,c,d should be TyVarTvs and unify appropriately
+    }
+  where
+    vis_arity = length (tyConVisibleTyVars tc_fam_tc)
+
+kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs _)) = panic "kcTyFamInstEqn"
+kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn _))) = panic "kcTyFamInstEqn"
+kcTyFamInstEqn _ _ = panic "kcTyFamInstEqn: Impossible Match" -- due to #15884
+
+
+--------------------------
+tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn
+               -> TcM (KnotTied CoAxBranch)
+-- Needs to be here, not in TcInstDcls, because closed families
+-- (typechecked here) have TyFamInstEqns
+
+tcTyFamInstEqn fam_tc mb_clsinfo
+    (dL->L loc (HsIB { hsib_ext = imp_vars
+                 , hsib_body = FamEqn { feqn_tycon  = L _ eqn_tc_name
+                                      , feqn_bndrs  = mb_expl_bndrs
+                                      , feqn_pats   = hs_pats
+                                      , feqn_rhs    = hs_rhs_ty }}))
+  = ASSERT( getName fam_tc == eqn_tc_name )
+    setSrcSpan loc $
+    do {
+       -- First, check the arity of visible arguments
+       -- If we wait until validity checking, we'll get kind errors
+       -- below when an arity error will be much easier to understand.
+       ; let vis_arity = length (tyConVisibleTyVars fam_tc)
+             vis_pats  = numVisibleArgs hs_pats
+       ; checkTc (vis_pats == vis_arity) $
+         wrongNumberOfParmsErr vis_arity
+
+       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo
+                                      imp_vars (mb_expl_bndrs `orElse` [])
+                                      hs_pats hs_rhs_ty
+
+       -- Don't print results they may be knot-tied
+       -- (tcFamInstEqnGuts zonks to Type)
+       ; return (mkCoAxBranch qtvs [] [] pats rhs_ty
+                              (map (const Nominal) qtvs)
+                              loc) }
+
+tcTyFamInstEqn _ _ _ = panic "tcTyFamInstEqn"
+
+{-
+Kind check type patterns and kind annotate the embedded type variables.
+     type instance F [a] = rhs
+
+ * Here we check that a type instance matches its kind signature, but we do
+   not check whether there is a pattern for each type index; the latter
+   check is only required for type synonym instances.
+
+Note [Instantiating a family tycon]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's possible that kind-checking the result of a family tycon applied to
+its patterns will instantiate the tycon further. For example, we might
+have
+
+  type family F :: k where
+    F = Int
+    F = Maybe
+
+After checking (F :: forall k. k) (with no visible patterns), we still need
+to instantiate the k. With data family instances, this problem can be even
+more intricate, due to Note [Arity of data families] in FamInstEnv. See
+indexed-types/should_compile/T12369 for an example.
+
+So, the kind-checker must return the new skolems and args (that is, Type
+or (Type -> Type) for the equations above) and the instantiated kind.
+
+Note [Generalising in tcFamTyPatsGuts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have something like
+  type instance forall (a::k) b. F t1 t2 = rhs
+
+Then  imp_vars = [k], exp_bndrs = [a::k, b]
+
+We want to quantify over
+  * k, a, and b  (all user-specified)
+  * and any inferred free kind vars from
+      - the kinds of k, a, b
+      - the types t1, t2
+
+However, unlike a type signature like
+  f :: forall (a::k). blah
+
+we do /not/ care about the Inferred/Specified designation
+or order for the final quantified tyvars.  Type-family
+instances are not invoked directly in Haskell source code,
+so visible type application etc plays no role.
+
+So, the simple thing is
+   - gather candiates from [k, a, b] and pats
+   - quantify over them
+
+Hence the sligtly mysterious call:
+    candidateQTyVarsOfTypes (pats ++ mkTyVarTys scoped_tvs)
+
+Simple, neat, but a little non-obvious!
+-}
+
+--------------------------
+tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo
+                   -> [Name] -> [LHsTyVarBndr GhcRn]  -- Implicit and explicicit binder
+                   -> HsTyPats GhcRn                  -- Patterns
+                   -> LHsType GhcRn                   -- RHS
+                   -> TcM ([TyVar], [TcType], TcType)      -- (tyvars, pats, rhs)
+-- Used only for type families, not data families
+tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty
+  = do { traceTc "tcTyFamInstEqnGuts {" (vcat [ ppr fam_tc <+> ppr hs_pats ])
+
+       -- By now, for type families (but not data families) we should
+       -- have checked that the number of patterns matches tyConArity
+
+       -- This code is closely related to the code
+       -- in TcHsType.kcLHsQTyVars_Cusk
+       ; (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty)))
+               <- pushTcLevelM_                                $
+                  solveEqualities                              $
+                  bindImplicitTKBndrs_Q_Skol imp_vars          $
+                  bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $
+                  do { (lhs_ty, rhs_kind) <- tc_lhs
+                       -- Ensure that the instance is consistent with its
+                       -- parent class (#16008)
+                     ; addConsistencyConstraints mb_clsinfo lhs_ty
+                     ; rhs_ty <- tcCheckLHsType hs_rhs_ty rhs_kind
+                     ; return (lhs_ty, rhs_ty) }
+
+       -- See Note [Generalising in tcFamTyPatsGuts]
+       -- This code (and the stuff immediately above) is very similar
+       -- to that in tcDataFamHeader.  Maybe we should abstract the
+       -- common code; but for the moment I concluded that it's
+       -- clearer to duplicate it.  Still, if you fix a bug here,
+       -- check there too!
+       ; let scoped_tvs = imp_tvs ++ exp_tvs
+       ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)
+       ; qtvs <- quantifyTyVars emptyVarSet dvs
+
+       ; (ze, qtvs) <- zonkTyBndrs qtvs
+       ; lhs_ty     <- zonkTcTypeToTypeX ze lhs_ty
+       ; rhs_ty     <- zonkTcTypeToTypeX ze rhs_ty
+
+       ; let pats = unravelFamInstPats lhs_ty
+             -- Note that we do this after solveEqualities
+             -- so that any strange coercions inside lhs_ty
+             -- have been solved before we attempt to unravel it
+       ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs)
+       ; return (qtvs, pats, rhs_ty) }
+  where
+    tc_lhs | null hs_pats  -- See Note [Apparently-nullary families]
+           = do { (args, rhs_kind) <- tcInstTyBinders $
+                                      splitPiTysInvisibleN (tyConArity fam_tc)
+                                                           (tyConKind  fam_tc)
+                ; return (mkTyConApp fam_tc args, rhs_kind) }
+           | otherwise
+           = tcFamTyPats fam_tc hs_pats
+
+{- Note [Apparently-nullary families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  type family F :: k -> *
+
+This really means
+  type family F @k :: k -> *
+
+That is, the family has arity 1, and can match on the kind. So it's
+not really a nullary family.   NB that
+  type famly F2 :: forall k. k -> *
+is quite different and really does have arity 0.
+
+Returning to F we might have
+  type instannce F = Maybe
+which instantaite 'k' to '*' and really means
+  type instannce F @* = Maybe
+
+Conclusion: in this odd case where there are no LHS patterns, we
+should instantiate any invisible foralls in F's kind, to saturate
+its arity (but no more).  This is what happens in tc_lhs in
+tcTyFamInstEqnGuts.
+
+If there are any visible patterns, then the first will force
+instantiation of any Inferred quantifiers for F -- remember,
+Inferred quantifiers always come first.
+-}
+
+
+-----------------
+tcFamTyPats :: TyCon
+            -> HsTyPats GhcRn                -- Patterns
+            -> TcM (TcType, TcKind)          -- (lhs_type, lhs_kind)
+-- Used for both type and data families
+tcFamTyPats fam_tc hs_pats
+  = do { traceTc "tcFamTyPats {" $
+         vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind
+              , text "arity:" <+> ppr fam_arity
+              , text "kind:" <+> ppr fam_kind ]
+
+       ; let fun_ty = mkTyConApp fam_tc []
+
+       ; (fam_app, res_kind) <- unsetWOptM Opt_WarnPartialTypeSignatures $
+                                setXOptM LangExt.PartialTypeSignatures $
+                                -- See Note [Wildcards in family instances] in
+                                -- RnSource.hs
+                                tcInferApps typeLevelMode lhs_fun fun_ty
+                                            fam_kind hs_pats
+
+       ; traceTc "End tcFamTyPats }" $
+         vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind
+              , text "res_kind:" <+> ppr res_kind ]
+
+       ; return (fam_app, res_kind) }
+  where
+    fam_name  = tyConName fam_tc
+    fam_arity = tyConArity fam_tc
+    fam_kind  = tyConKind fam_tc
+    lhs_fun   = noLoc (HsTyVar noExt NotPromoted (noLoc fam_name))
+
+unravelFamInstPats :: TcType -> [TcType]
+-- Decompose fam_app to get the argument patterns
+--
+-- We expect fam_app to look like (F t1 .. tn)
+-- tcInferApps is capable of returning ((F ty1 |> co) ty2),
+-- but that can't happen here because we already checked the
+-- arity of F matches the number of pattern
+unravelFamInstPats fam_app
+  = case splitTyConApp_maybe fam_app of
+      Just (_, pats) -> pats
+      Nothing        -> WARN( True, bad_lhs fam_app ) []
+        -- The Nothing case cannot happen for type families, because
+        -- we don't call unravelFamInstPats until we've solved the
+        -- equalities.  For data families I wasn't quite as convinced
+        -- so I've let it as a warning rather than a panic.
+  where
+    bad_lhs fam_app
+      = hang (text "Ill-typed LHS of family instance")
+           2 (debugPprType fam_app)
+
+addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM ()
+-- In the corresponding positions of the class and type-family,
+-- ensure the the family argument is the same as the class argument
+--   E.g    class C a b c d where
+--             F c x y a :: Type
+-- Here the first  arg of F should be the same as the third of C
+--  and the fourth arg of F should be the same as the first of C
+--
+-- We emit /Derived/ constraints (a bit like fundeps) to encourage
+-- unification to happen, but without actually reporting errors.
+-- If, despite the efforts, corresponding positions do not match,
+-- checkConsistentFamInst will complain
+addConsistencyConstraints mb_clsinfo fam_app
+  | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo
+  , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app
+  = do { let eqs = [ (cls_ty, pat)
+                   | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats
+                   , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ]
+       ; traceTc "addConsistencyConstraints" (ppr eqs)
+       ; emitDerivedEqs AssocFamPatOrigin eqs }
+    -- Improve inference
+    -- Any mis-match is reports by checkConsistentFamInst
+  | otherwise
+  = return ()
+
+{- Note [Constraints in patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+NB: This isn't the whole story. See comment in tcFamTyPats.
+
+At first glance, it seems there is a complicated story to tell in tcFamTyPats
+around constraint solving. After all, type family patterns can now do
+GADT pattern-matching, which is jolly complicated. But, there's a key fact
+which makes this all simple: everything is at top level! There cannot
+be untouchable type variables. There can't be weird interaction between
+case branches. There can't be global skolems.
+
+This means that the semantics of type-level GADT matching is a little
+different than term level. If we have
+
+  data G a where
+    MkGBool :: G Bool
+
+And then
+
+  type family F (a :: G k) :: k
+  type instance F MkGBool = True
+
+we get
+
+  axF : F Bool (MkGBool <Bool>) ~ True
+
+Simple! No casting on the RHS, because we can affect the kind parameter
+to F.
+
+If we ever introduce local type families, this all gets a lot more
+complicated, and will end up looking awfully like term-level GADT
+pattern-matching.
+
+
+** The new story **
+
+Here is really what we want:
+
+The matcher really can't deal with covars in arbitrary spots in coercions.
+But it can deal with covars that are arguments to GADT data constructors.
+So we somehow want to allow covars only in precisely those spots, then use
+them as givens when checking the RHS. TODO (RAE): Implement plan.
+
+
+Note [Quantifying over family patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We need to quantify over two different lots of kind variables:
+
+First, the ones that come from the kinds of the tyvar args of
+tcTyVarBndrsKindGen, as usual
+  data family Dist a
+
+  -- Proxy :: forall k. k -> *
+  data instance Dist (Proxy a) = DP
+  -- Generates  data DistProxy = DP
+  --            ax8 k (a::k) :: Dist * (Proxy k a) ~ DistProxy k a
+  -- The 'k' comes from the tcTyVarBndrsKindGen (a::k)
+
+Second, the ones that come from the kind argument of the type family
+which we pick up using the (tyCoVarsOfTypes typats) in the result of
+the thing_inside of tcHsTyvarBndrsGen.
+  -- Any :: forall k. k
+  data instance Dist Any = DA
+  -- Generates  data DistAny k = DA
+  --            ax7 k :: Dist k (Any k) ~ DistAny k
+  -- The 'k' comes from kindGeneralizeKinds (Any k)
+
+Note [Quantified kind variables of a family pattern]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider   type family KindFam (p :: k1) (q :: k1)
+           data T :: Maybe k1 -> k2 -> *
+           type instance KindFam (a :: Maybe k) b = T a b -> Int
+The HsBSig for the family patterns will be ([k], [a])
+
+Then in the family instance we want to
+  * Bring into scope [ "k" -> k:*, "a" -> a:k ]
+  * Kind-check the RHS
+  * Quantify the type instance over k and k', as well as a,b, thus
+       type instance [k, k', a:Maybe k, b:k']
+                     KindFam (Maybe k) k' a b = T k k' a b -> Int
+
+Notice that in the third step we quantify over all the visibly-mentioned
+type variables (a,b), but also over the implicitly mentioned kind variables
+(k, k').  In this case one is bound explicitly but often there will be
+none. The role of the kind signature (a :: Maybe k) is to add a constraint
+that 'a' must have that kind, and to bring 'k' into scope.
+
+
+
+************************************************************************
+*                                                                      *
+               Data types
+*                                                                      *
+************************************************************************
+-}
+
+dataDeclChecks :: Name -> NewOrData
+               -> LHsContext GhcRn -> [LConDecl GhcRn]
+               -> TcM Bool
+dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons
+  = do {   -- Check that we don't use GADT syntax in H98 world
+         gadtSyntax_ok <- xoptM LangExt.GADTSyntax
+       ; let gadt_syntax = consUseGadtSyntax cons
+       ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name)
+
+           -- Check that the stupid theta is empty for a GADT-style declaration
+       ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name)
+
+         -- Check that a newtype has exactly one constructor
+         -- Do this before checking for empty data decls, so that
+         -- we don't suggest -XEmptyDataDecls for newtypes
+       ; checkTc (new_or_data == DataType || isSingleton cons)
+                (newtypeConError tc_name (length cons))
+
+         -- Check that there's at least one condecl,
+         -- or else we're reading an hs-boot file, or -XEmptyDataDecls
+       ; empty_data_decls <- xoptM LangExt.EmptyDataDecls
+       ; is_boot <- tcIsHsBootOrSig  -- Are we compiling an hs-boot file?
+       ; checkTc (not (null cons) || empty_data_decls || is_boot)
+                 (emptyConDeclsErr tc_name)
+       ; return gadt_syntax }
+
+
+-----------------------------------
+consUseGadtSyntax :: [LConDecl a] -> Bool
+consUseGadtSyntax ((dL->L _ (ConDeclGADT {})) : _) = True
+consUseGadtSyntax _                                = False
+                 -- All constructors have same shape
+
+-----------------------------------
+tcConDecls :: KnotTied TyCon -> [KnotTied TyConBinder] -> KnotTied Type
+           -> [LConDecl GhcRn] -> TcM [DataCon]
+  -- Why both the tycon tyvars and binders? Because the tyvars
+  -- have all the names and the binders have the visibilities.
+tcConDecls rep_tycon tmpl_bndrs res_tmpl
+  = concatMapM $ addLocM $
+    tcConDecl rep_tycon (mkTyConTagMap rep_tycon) tmpl_bndrs res_tmpl
+    -- It's important that we pay for tag allocation here, once per TyCon,
+    -- See Note [Constructor tag allocation], fixes #14657
+
+tcConDecl :: KnotTied TyCon          -- Representation tycon. Knot-tied!
+          -> NameEnv ConTag
+          -> [KnotTied TyConBinder] -> KnotTied Type
+                 -- Return type template (with its template tyvars)
+                 --    (tvs, T tys), where T is the family TyCon
+          -> ConDecl GhcRn
+          -> TcM [DataCon]
+
+tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl
+          (ConDeclH98 { con_name = name
+                      , con_ex_tvs = explicit_tkv_nms
+                      , con_mb_cxt = hs_ctxt
+                      , con_args = hs_args })
+  = addErrCtxt (dataConCtxtName [name]) $
+    do { -- NB: the tyvars from the declaration header are in scope
+
+         -- Get hold of the existential type variables
+         -- e.g. data T a = forall k (b::k) f. MkT a (f b)
+         -- Here tmpl_bndrs = {a}
+         --      hs_qvars = HsQTvs { hsq_implicit = {k}
+         --                        , hsq_explicit = {f,b} }
+
+       ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ])
+
+       ; (exp_tvs, (ctxt, arg_tys, field_lbls, stricts))
+           <- pushTcLevelM_                             $
+              solveEqualities                           $
+              bindExplicitTKBndrs_Skol explicit_tkv_nms $
+              do { ctxt <- tcHsMbContext hs_ctxt
+                 ; btys <- tcConArgs hs_args
+                 ; field_lbls <- lookupConstructorFields (unLoc name)
+                 ; let (arg_tys, stricts) = unzip btys
+                 ; return (ctxt, arg_tys, field_lbls, stricts)
+                 }
+
+         -- exp_tvs have explicit, user-written binding sites
+         -- the kvs below are those kind variables entirely unmentioned by the user
+         --   and discovered only by generalization
+
+       ; kvs <- kindGeneralize (mkSpecForAllTys (binderVars tmpl_bndrs) $
+                                mkSpecForAllTys exp_tvs $
+                                mkFunTys ctxt $
+                                mkFunTys arg_tys $
+                                unitTy)
+                 -- That type is a lie, of course. (It shouldn't end in ()!)
+                 -- And we could construct a proper result type from the info
+                 -- at hand. But the result would mention only the tmpl_tvs,
+                 -- and so it just creates more work to do it right. Really,
+                 -- we're only doing this to find the right kind variables to
+                 -- quantify over, and this type is fine for that purpose.
+
+             -- Zonk to Types
+       ; (ze, qkvs)      <- zonkTyBndrs kvs
+       ; (ze, user_qtvs) <- zonkTyBndrsX ze exp_tvs
+       ; arg_tys         <- zonkTcTypesToTypesX ze arg_tys
+       ; ctxt            <- zonkTcTypesToTypesX ze ctxt
+
+       ; fam_envs <- tcGetFamInstEnvs
+
+       -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here
+       ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)
+       ; let
+           univ_tvbs = tyConTyVarBinders tmpl_bndrs
+           univ_tvs  = binderVars univ_tvbs
+           ex_tvbs   = mkTyVarBinders Inferred qkvs ++
+                       mkTyVarBinders Specified user_qtvs
+           ex_tvs    = qkvs ++ user_qtvs
+           -- For H98 datatypes, the user-written tyvar binders are precisely
+           -- the universals followed by the existentials.
+           -- See Note [DataCon user type variable binders] in DataCon.
+           user_tvbs = univ_tvbs ++ ex_tvbs
+           buildOneDataCon (dL->L _ name) = do
+             { is_infix <- tcConIsInfixH98 name hs_args
+             ; rep_nm   <- newTyConRepName name
+
+             ; buildDataCon fam_envs name is_infix rep_nm
+                            stricts Nothing field_lbls
+                            univ_tvs ex_tvs user_tvbs
+                            [{- no eq_preds -}] ctxt arg_tys
+                            res_tmpl rep_tycon tag_map
+                  -- NB:  we put data_tc, the type constructor gotten from the
+                  --      constructor type signature into the data constructor;
+                  --      that way checkValidDataCon can complain if it's wrong.
+             }
+       ; traceTc "tcConDecl 2" (ppr name)
+       ; mapM buildOneDataCon [name]
+       }
+
+tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl
+          (ConDeclGADT { con_names = names
+                       , con_qvars = qtvs
+                       , con_mb_cxt = cxt, con_args = hs_args
+                       , con_res_ty = hs_res_ty })
+  | HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = implicit_tkv_nms }
+           , hsq_explicit = explicit_tkv_nms } <- qtvs
+  = addErrCtxt (dataConCtxtName names) $
+    do { traceTc "tcConDecl 1 gadt" (ppr names)
+       ; let ((dL->L _ name) : _) = names
+
+       ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))
+           <- pushTcLevelM_    $  -- We are going to generalise
+              solveEqualities  $  -- We won't get another crack, and we don't
+                                  -- want an error cascade
+              bindImplicitTKBndrs_Skol implicit_tkv_nms $
+              bindExplicitTKBndrs_Skol explicit_tkv_nms $
+              do { ctxt <- tcHsMbContext cxt
+                 ; btys <- tcConArgs hs_args
+                 ; res_ty <- tcHsLiftedType hs_res_ty
+                 ; field_lbls <- lookupConstructorFields name
+                 ; let (arg_tys, stricts) = unzip btys
+                 ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)
+                 }
+       ; imp_tvs <- zonkAndScopedSort imp_tvs
+       ; let user_tvs = imp_tvs ++ exp_tvs
+
+       ; tkvs <- kindGeneralize (mkSpecForAllTys user_tvs $
+                                 mkFunTys ctxt $
+                                 mkFunTys arg_tys $
+                                 res_ty)
+
+             -- Zonk to Types
+       ; (ze, tkvs)     <- zonkTyBndrs tkvs
+       ; (ze, user_tvs) <- zonkTyBndrsX ze user_tvs
+       ; arg_tys <- zonkTcTypesToTypesX ze arg_tys
+       ; ctxt    <- zonkTcTypesToTypesX ze ctxt
+       ; res_ty  <- zonkTcTypeToTypeX   ze res_ty
+
+       ; let (univ_tvs, ex_tvs, tkvs', user_tvs', eq_preds, arg_subst)
+               = rejigConRes tmpl_bndrs res_tmpl tkvs user_tvs res_ty
+             -- NB: this is a /lazy/ binding, so we pass six thunks to
+             --     buildDataCon without yet forcing the guards in rejigConRes
+             -- See Note [Checking GADT return types]
+
+             -- Compute the user-written tyvar binders. These have the same
+             -- tyvars as univ_tvs/ex_tvs, but perhaps in a different order.
+             -- See Note [DataCon user type variable binders] in DataCon.
+             tkv_bndrs      = mkTyVarBinders Inferred  tkvs'
+             user_tv_bndrs  = mkTyVarBinders Specified user_tvs'
+             all_user_bndrs = tkv_bndrs ++ user_tv_bndrs
+
+             ctxt'      = substTys arg_subst ctxt
+             arg_tys'   = substTys arg_subst arg_tys
+             res_ty'    = substTy  arg_subst res_ty
+
+
+       ; fam_envs <- tcGetFamInstEnvs
+
+       -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here
+       ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)
+       ; let
+           buildOneDataCon (dL->L _ name) = do
+             { is_infix <- tcConIsInfixGADT name hs_args
+             ; rep_nm   <- newTyConRepName name
+
+             ; buildDataCon fam_envs name is_infix
+                            rep_nm
+                            stricts Nothing field_lbls
+                            univ_tvs ex_tvs all_user_bndrs eq_preds
+                            ctxt' arg_tys' res_ty' rep_tycon tag_map
+                  -- NB:  we put data_tc, the type constructor gotten from the
+                  --      constructor type signature into the data constructor;
+                  --      that way checkValidDataCon can complain if it's wrong.
+             }
+       ; traceTc "tcConDecl 2" (ppr names)
+       ; mapM buildOneDataCon names
+       }
+tcConDecl _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _)
+  = panic "tcConDecl"
+tcConDecl _ _ _ _ (XConDecl _) = panic "tcConDecl"
+
+tcConIsInfixH98 :: Name
+             -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
+             -> TcM Bool
+tcConIsInfixH98 _   details
+  = case details of
+           InfixCon {}  -> return True
+           _            -> return False
+
+tcConIsInfixGADT :: Name
+             -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])
+             -> TcM Bool
+tcConIsInfixGADT con details
+  = case details of
+           InfixCon {}  -> return True
+           RecCon {}    -> return False
+           PrefixCon arg_tys           -- See Note [Infix GADT constructors]
+               | isSymOcc (getOccName con)
+               , [_ty1,_ty2] <- arg_tys
+                  -> do { fix_env <- getFixityEnv
+                        ; return (con `elemNameEnv` fix_env) }
+               | otherwise -> return False
+
+tcConArgs :: HsConDeclDetails GhcRn
+          -> TcM [(TcType, HsSrcBang)]
+tcConArgs (PrefixCon btys)
+  = mapM tcConArg btys
+tcConArgs (InfixCon bty1 bty2)
+  = do { bty1' <- tcConArg bty1
+       ; bty2' <- tcConArg bty2
+       ; return [bty1', bty2'] }
+tcConArgs (RecCon fields)
+  = mapM tcConArg btys
+  where
+    -- We need a one-to-one mapping from field_names to btys
+    combined = map (\(dL->L _ f) -> (cd_fld_names f,cd_fld_type f))
+                   (unLoc fields)
+    explode (ns,ty) = zip ns (repeat ty)
+    exploded = concatMap explode combined
+    (_,btys) = unzip exploded
+
+
+tcConArg :: LHsType GhcRn -> TcM (TcType, HsSrcBang)
+tcConArg bty
+  = do  { traceTc "tcConArg 1" (ppr bty)
+        ; arg_ty <- tcHsOpenType (getBangType bty)
+             -- Newtypes can't have unboxed types, but we check
+             -- that in checkValidDataCon; this tcConArg stuff
+             -- doesn't happen for GADT-style declarations
+        ; traceTc "tcConArg 2" (ppr bty)
+        ; return (arg_ty, getBangStrictness bty) }
+
+{-
+Note [Infix GADT constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We do not currently have syntax to declare an infix constructor in GADT syntax,
+but it makes a (small) difference to the Show instance.  So as a slightly
+ad-hoc solution, we regard a GADT data constructor as infix if
+  a) it is an operator symbol
+  b) it has two arguments
+  c) there is a fixity declaration for it
+For example:
+   infix 6 (:--:)
+   data T a where
+     (:--:) :: t1 -> t2 -> T Int
+
+
+Note [Checking GADT return types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There is a delicacy around checking the return types of a datacon. The
+central problem is dealing with a declaration like
+
+  data T a where
+    MkT :: T a -> Q a
+
+Note that the return type of MkT is totally bogus. When creating the T
+tycon, we also need to create the MkT datacon, which must have a "rejigged"
+return type. That is, the MkT datacon's type must be transformed to have
+a uniform return type with explicit coercions for GADT-like type parameters.
+This rejigging is what rejigConRes does. The problem is, though, that checking
+that the return type is appropriate is much easier when done over *Type*,
+not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully
+defined yet.
+
+So, we want to make rejigConRes lazy and then check the validity of
+the return type in checkValidDataCon.  To do this we /always/ return a
+6-tuple from rejigConRes (so that we can compute the return type from it, which
+checkValidDataCon needs), but the first three fields may be bogus if
+the return type isn't valid (the last equation for rejigConRes).
+
+This is better than an earlier solution which reduced the number of
+errors reported in one pass.  See Trac #7175, and #10836.
+-}
+
+-- Example
+--   data instance T (b,c) where
+--      TI :: forall e. e -> T (e,e)
+--
+-- The representation tycon looks like this:
+--   data :R7T b c where
+--      TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1
+-- In this case orig_res_ty = T (e,e)
+
+rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type    -- Template for result type; e.g.
+                                  -- data instance T [a] b c ...
+                                  --      gives template ([a,b,c], T [a] b c)
+                                  -- Type must be of kind *!
+            -> [TyVar]            -- The constructor's inferred type variables
+            -> [TyVar]            -- The constructor's user-written, specified
+                                  -- type variables
+            -> KnotTied Type      -- res_ty type must be of kind *
+            -> ([TyVar],          -- Universal
+                [TyVar],          -- Existential (distinct OccNames from univs)
+                [TyVar],          -- The constructor's rejigged, user-written,
+                                  -- inferred type variables
+                [TyVar],          -- The constructor's rejigged, user-written,
+                                  -- specified type variables
+                [EqSpec],      -- Equality predicates
+                TCvSubst)      -- Substitution to apply to argument types
+        -- We don't check that the TyCon given in the ResTy is
+        -- the same as the parent tycon, because checkValidDataCon will do it
+-- NB: All arguments may potentially be knot-tied
+rejigConRes tmpl_bndrs res_tmpl dc_inferred_tvs dc_specified_tvs res_ty
+        -- E.g.  data T [a] b c where
+        --         MkT :: forall x y z. T [(x,y)] z z
+        -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs
+        --     (NB: unlike the H98 case, the dc_tvs are not all existential)
+        -- Then we generate
+        --      Univ tyvars     Eq-spec
+        --          a              a~(x,y)
+        --          b              b~z
+        --          z
+        -- Existentials are the leftover type vars: [x,y]
+        -- The user-written type variables are what is listed in the forall:
+        --   [x, y, z] (all specified). We must rejig these as well.
+        --   See Note [DataCon user type variable binders] in DataCon.
+        -- So we return ( [a,b,z], [x,y]
+        --              , [], [x,y,z]
+        --              , [a~(x,y),b~z], <arg-subst> )
+  | Just subst <- ASSERT( isLiftedTypeKind (tcTypeKind res_ty) )
+                  ASSERT( isLiftedTypeKind (tcTypeKind res_tmpl) )
+                  tcMatchTy res_tmpl res_ty
+  = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst
+        raw_ex_tvs = dc_tvs `minusList` univ_tvs
+        (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs
+
+        -- After rejigging the existential tyvars, the resulting substitution
+        -- gives us exactly what we need to rejig the user-written tyvars,
+        -- since the dcUserTyVarBinders invariant guarantees that the
+        -- substitution has *all* the tyvars in its domain.
+        -- See Note [DataCon user type variable binders] in DataCon.
+        subst_user_tvs = map (getTyVar "rejigConRes" . substTyVar arg_subst)
+        substed_inferred_tvs  = subst_user_tvs dc_inferred_tvs
+        substed_specified_tvs = subst_user_tvs dc_specified_tvs
+
+        substed_eqs = map (substEqSpec arg_subst) raw_eqs
+    in
+    (univ_tvs, substed_ex_tvs, substed_inferred_tvs, substed_specified_tvs,
+     substed_eqs, arg_subst)
+
+  | otherwise
+        -- If the return type of the data constructor doesn't match the parent
+        -- type constructor, or the arity is wrong, the tcMatchTy will fail
+        --    e.g   data T a b where
+        --            T1 :: Maybe a   -- Wrong tycon
+        --            T2 :: T [a]     -- Wrong arity
+        -- We are detect that later, in checkValidDataCon, but meanwhile
+        -- we must do *something*, not just crash.  So we do something simple
+        -- albeit bogus, relying on checkValidDataCon to check the
+        --  bad-result-type error before seeing that the other fields look odd
+        -- See Note [Checking GADT return types]
+  = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, dc_inferred_tvs, dc_specified_tvs,
+     [], emptyTCvSubst)
+  where
+    dc_tvs   = dc_inferred_tvs ++ dc_specified_tvs
+    tmpl_tvs = binderVars tmpl_bndrs
+
+{- Note [mkGADTVars]
+~~~~~~~~~~~~~~~~~~~~
+Running example:
+
+data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where
+  MkT :: forall (x1 : *) (y :: x1) (z :: *).
+         T x1 * (Proxy (y :: x1), z) z
+
+We need the rejigged type to be
+
+  MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2).
+         forall (y :: x1) (z :: *).
+         (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z)
+      => T x1 k2 a b
+
+You might naively expect that z should become a universal tyvar,
+not an existential. (After all, x1 becomes a universal tyvar.)
+But z has kind * while b has kind k2, so the return type
+   T x1 k2 a z
+is ill-kinded.  Another way to say it is this: the universal
+tyvars must have exactly the same kinds as the tyConTyVars.
+
+So we need an existential tyvar and a heterogeneous equality
+constraint. (The b ~ z is a bit redundant with the k2 ~ * that
+comes before in that b ~ z implies k2 ~ *. I'm sure we could do
+some analysis that could eliminate k2 ~ *. But we don't do this
+yet.)
+
+The data con signature has already been fully kind-checked.
+The return type
+
+  T x1 * (Proxy (y :: x1), z) z
+becomes
+  qtkvs    = [x1 :: *, y :: x1, z :: *]
+  res_tmpl = T x1 * (Proxy x1 y, z) z
+
+We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We
+know this match will succeed because of the validity check (actually done
+later, but laziness saves us -- see Note [Checking GADT return types]).
+Thus, we get
+
+  subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z }
+
+Now, we need to figure out what the GADT equalities should be. In this case,
+we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a
+renaming. The others should be GADT equalities. We also need to make
+sure that the universally-quantified variables of the datacon match up
+with the tyvars of the tycon, as required for Core context well-formedness.
+(This last bit is why we have to rejig at all!)
+
+`choose` walks down the tycon tyvars, figuring out what to do with each one.
+It carries two substitutions:
+  - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables
+    mentioned in the datacon signature.
+  - r_sub's domain is *result* tyvars, names written by the programmer in
+    the datacon signature. The final rejigged type will use these names, but
+    the subst is still needed because sometimes the printed name of these variables
+    is different. (See choose_tv_name, below.)
+
+Before explaining the details of `choose`, let's just look at its operation
+on our example:
+
+  choose [] [] {} {} [k1, k2, a, b]
+  -->          -- first branch of `case` statement
+  choose
+    univs:    [x1 :: *]
+    eq_spec:  []
+    t_sub:    {k1 |-> x1}
+    r_sub:    {x1 |-> x1}
+    t_tvs:    [k2, a, b]
+  -->          -- second branch of `case` statement
+  choose
+    univs:    [k2 :: *, x1 :: *]
+    eq_spec:  [k2 ~ *]
+    t_sub:    {k1 |-> x1, k2 |-> k2}
+    r_sub:    {x1 |-> x1}
+    t_tvs:    [a, b]
+  -->          -- second branch of `case` statement
+  choose
+    univs:    [a :: k2, k2 :: *, x1 :: *]
+    eq_spec:  [ a ~ (Proxy x1 y, z)
+              , k2 ~ * ]
+    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a}
+    r_sub:    {x1 |-> x1}
+    t_tvs:    [b]
+  -->          -- second branch of `case` statement
+  choose
+    univs:    [b :: k2, a :: k2, k2 :: *, x1 :: *]
+    eq_spec:  [ b ~ z
+              , a ~ (Proxy x1 y, z)
+              , k2 ~ * ]
+    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z}
+    r_sub:    {x1 |-> x1}
+    t_tvs:    []
+  -->          -- end of recursion
+  ( [x1 :: *, k2 :: *, a :: k2, b :: k2]
+  , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z]
+  , {x1 |-> x1} )
+
+`choose` looks up each tycon tyvar in the matching (it *must* be matched!).
+
+* If it finds a bare result tyvar (the first branch of the `case`
+  statement), it checks to make sure that the result tyvar isn't yet
+  in the list of univ_tvs.  If it is in that list, then we have a
+  repeated variable in the return type, and we in fact need a GADT
+  equality.
+
+* It then checks to make sure that the kind of the result tyvar
+  matches the kind of the template tyvar. This check is what forces
+  `z` to be existential, as it should be, explained above.
+
+* Assuming no repeated variables or kind-changing, we wish to use the
+  variable name given in the datacon signature (that is, `x1` not
+  `k1`), not the tycon signature (which may have been made up by
+  GHC). So, we add a mapping from the tycon tyvar to the result tyvar
+  to t_sub.
+
+* If we discover that a mapping in `subst` gives us a non-tyvar (the
+  second branch of the `case` statement), then we have a GADT equality
+  to create.  We create a fresh equality, but we don't extend any
+  substitutions. The template variable substitution is meant for use
+  in universal tyvar kinds, and these shouldn't be affected by any
+  GADT equalities.
+
+This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways
+of simplifying it:
+
+1) The first branch of the `case` statement is really an optimization, used
+in order to get fewer GADT equalities. It might be possible to make a GADT
+equality for *every* univ. tyvar, even if the equality is trivial, and then
+either deal with the bigger type or somehow reduce it later.
+
+2) This algorithm strives to use the names for type variables as specified
+by the user in the datacon signature. If we always used the tycon tyvar
+names, for example, this would be simplified. This change would almost
+certainly degrade error messages a bit, though.
+-}
+
+-- ^ From information about a source datacon definition, extract out
+-- what the universal variables and the GADT equalities should be.
+-- See Note [mkGADTVars].
+mkGADTVars :: [TyVar]    -- ^ The tycon vars
+           -> [TyVar]    -- ^ The datacon vars
+           -> TCvSubst   -- ^ The matching between the template result type
+                         -- and the actual result type
+           -> ( [TyVar]
+              , [EqSpec]
+              , TCvSubst ) -- ^ The univ. variables, the GADT equalities,
+                           -- and a subst to apply to the GADT equalities
+                           -- and existentials.
+mkGADTVars tmpl_tvs dc_tvs subst
+  = choose [] [] empty_subst empty_subst tmpl_tvs
+  where
+    in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs)
+               `unionInScope` getTCvInScope subst
+    empty_subst = mkEmptyTCvSubst in_scope
+
+    choose :: [TyVar]           -- accumulator of univ tvs, reversed
+           -> [EqSpec]          -- accumulator of GADT equalities, reversed
+           -> TCvSubst          -- template substitution
+           -> TCvSubst          -- res. substitution
+           -> [TyVar]           -- template tvs (the univ tvs passed in)
+           -> ( [TyVar]         -- the univ_tvs
+              , [EqSpec]        -- GADT equalities
+              , TCvSubst )       -- a substitution to fix kinds in ex_tvs
+
+    choose univs eqs _t_sub r_sub []
+      = (reverse univs, reverse eqs, r_sub)
+    choose univs eqs t_sub r_sub (t_tv:t_tvs)
+      | Just r_ty <- lookupTyVar subst t_tv
+      = case getTyVar_maybe r_ty of
+          Just r_tv
+            |  not (r_tv `elem` univs)
+            ,  tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv))
+            -> -- simple, well-kinded variable substitution.
+               choose (r_tv:univs) eqs
+                      (extendTvSubst t_sub t_tv r_ty')
+                      (extendTvSubst r_sub r_tv r_ty')
+                      t_tvs
+            where
+              r_tv1  = setTyVarName r_tv (choose_tv_name r_tv t_tv)
+              r_ty'  = mkTyVarTy r_tv1
+
+               -- Not a simple substitution: make an equality predicate
+          _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs)
+                      (extendTvSubst t_sub t_tv (mkTyVarTy t_tv'))
+                         -- We've updated the kind of t_tv,
+                         -- so add it to t_sub (Trac #14162)
+                      r_sub t_tvs
+            where
+              t_tv' = updateTyVarKind (substTy t_sub) t_tv
+
+      | otherwise
+      = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst)
+
+      -- choose an appropriate name for a univ tyvar.
+      -- This *must* preserve the Unique of the result tv, so that we
+      -- can detect repeated variables. It prefers user-specified names
+      -- over system names. A result variable with a system name can
+      -- happen with GHC-generated implicit kind variables.
+    choose_tv_name :: TyVar -> TyVar -> Name
+    choose_tv_name r_tv t_tv
+      | isSystemName r_tv_name
+      = setNameUnique t_tv_name (getUnique r_tv_name)
+
+      | otherwise
+      = r_tv_name
+
+      where
+        r_tv_name = getName r_tv
+        t_tv_name = getName t_tv
+
+{-
+Note [Substitution in template variables kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+data G (a :: Maybe k) where
+  MkG :: G Nothing
+
+With explicit kind variables
+
+data G k (a :: Maybe k) where
+  MkG :: G k1 (Nothing k1)
+
+Note how k1 is distinct from k. So, when we match the template
+`G k a` against `G k1 (Nothing k1)`, we get a subst
+[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two
+mappings, we surely don't want to add (k, k1) to the list of
+GADT equalities -- that would be overly complex and would create
+more untouchable variables than we need. So, when figuring out
+which tyvars are GADT-like and which aren't (the fundamental
+job of `choose`), we want to treat `k` as *not* GADT-like.
+Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1)
+instead of (a :: Maybe k). This is the reason for dealing
+with a substitution in here.
+
+However, we do not *always* want to substitute. Consider
+
+data H (a :: k) where
+  MkH :: H Int
+
+With explicit kind variables:
+
+data H k (a :: k) where
+  MkH :: H * Int
+
+Here, we have a kind-indexed GADT. The subst in question is
+[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s
+kind, because that would give a constructor with the type
+
+MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a
+
+The problem here is that a's kind is wrong -- it needs to be k, not *!
+So, if the matching for a variable is anything but another bare variable,
+we drop the mapping from the substitution before proceeding. This
+was not an issue before kind-indexed GADTs because this case could
+never happen.
+
+************************************************************************
+*                                                                      *
+                Validity checking
+*                                                                      *
+************************************************************************
+
+Validity checking is done once the mutually-recursive knot has been
+tied, so we can look at things freely.
+-}
+
+checkValidTyCl :: TyCon -> TcM [TyCon]
+-- The returned list is either a singleton (if valid)
+-- or a list of "fake tycons" (if not); the fake tycons
+-- include any implicits, like promoted data constructors
+-- See Note [Recover from validity error]
+checkValidTyCl tc
+  = setSrcSpan (getSrcSpan tc) $
+    addTyConCtxt tc $
+    recoverM recovery_code
+             (do { traceTc "Starting validity for tycon" (ppr tc)
+                 ; checkValidTyCon tc
+                 ; traceTc "Done validity for tycon" (ppr tc)
+                 ; return [tc] })
+  where
+    recovery_code -- See Note [Recover from validity error]
+      = do { traceTc "Aborted validity for tycon" (ppr tc)
+           ; return (concatMap mk_fake_tc $
+                     ATyCon tc : implicitTyConThings tc) }
+
+    mk_fake_tc (ATyCon tc)
+      | isClassTyCon tc = [tc]   -- Ugh! Note [Recover from validity error]
+      | otherwise       = [makeRecoveryTyCon tc]
+    mk_fake_tc (AConLike (RealDataCon dc))
+                        = [makeRecoveryTyCon (promoteDataCon dc)]
+    mk_fake_tc _        = []
+
+{- Note [Recover from validity error]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We recover from a validity error in a type or class, which allows us
+to report multiple validity errors. In the failure case we return a
+TyCon of the right kind, but with no interesting behaviour
+(makeRecoveryTyCon). Why?  Suppose we have
+   type T a = Fun
+where Fun is a type family of arity 1.  The RHS is invalid, but we
+want to go on checking validity of subsequent type declarations.
+So we replace T with an abstract TyCon which will do no harm.
+See indexed-types/should_fail/BadSock and Trac #10896
+
+Some notes:
+
+* We must make fakes for promoted DataCons too. Consider (Trac #15215)
+      data T a = MkT ...
+      data S a = ...T...MkT....
+  If there is an error in the definition of 'T' we add a "fake type
+  constructor" to the type environment, so that we can continue to
+  typecheck 'S'.  But we /were not/ adding a fake anything for 'MkT'
+  and so there was an internal error when we met 'MkT' in the body of
+  'S'.
+
+* Painfully, we *don't* want to do this for classes.
+  Consider tcfail041:
+     class (?x::Int) => C a where ...
+     instance C Int
+  The class is invalid because of the superclass constraint.  But
+  we still want it to look like a /class/, else the instance bleats
+  that the instance is mal-formed because it hasn't got a class in
+  the head.
+
+  This is really bogus; now we have in scope a Class that is invalid
+  in some way, with unknown downstream consequences.  A better
+  alterantive might be to make a fake class TyCon.  A job for another day.
+-}
+
+-------------------------
+-- For data types declared with record syntax, we require
+-- that each constructor that has a field 'f'
+--      (a) has the same result type
+--      (b) has the same type for 'f'
+-- module alpha conversion of the quantified type variables
+-- of the constructor.
+--
+-- Note that we allow existentials to match because the
+-- fields can never meet. E.g
+--      data T where
+--        T1 { f1 :: b, f2 :: a, f3 ::Int } :: T
+--        T2 { f1 :: c, f2 :: c, f3 ::Int } :: T
+-- Here we do not complain about f1,f2 because they are existential
+
+checkValidTyCon :: TyCon -> TcM ()
+checkValidTyCon tc
+  | isPrimTyCon tc   -- Happens when Haddock'ing GHC.Prim
+  = return ()
+
+  | otherwise
+  = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc))
+       ; if | Just cl <- tyConClass_maybe tc
+              -> checkValidClass cl
+
+            | Just syn_rhs <- synTyConRhs_maybe tc
+              -> do { checkValidType syn_ctxt syn_rhs
+                    ; checkTySynRhs syn_ctxt syn_rhs }
+
+            | Just fam_flav <- famTyConFlav_maybe tc
+              -> case fam_flav of
+               { ClosedSynFamilyTyCon (Just ax)
+                   -> tcAddClosedTypeFamilyDeclCtxt tc $
+                      checkValidCoAxiom ax
+               ; ClosedSynFamilyTyCon Nothing   -> return ()
+               ; AbstractClosedSynFamilyTyCon ->
+                 do { hsBoot <- tcIsHsBootOrSig
+                    ; checkTc hsBoot $
+                      text "You may define an abstract closed type family" $$
+                      text "only in a .hs-boot file" }
+               ; DataFamilyTyCon {}           -> return ()
+               ; OpenSynFamilyTyCon           -> return ()
+               ; BuiltInSynFamTyCon _         -> return () }
+
+             | otherwise -> do
+               { -- Check the context on the data decl
+                 traceTc "cvtc1" (ppr tc)
+               ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
+
+               ; traceTc "cvtc2" (ppr tc)
+
+               ; dflags          <- getDynFlags
+               ; existential_ok  <- xoptM LangExt.ExistentialQuantification
+               ; gadt_ok         <- xoptM LangExt.GADTs
+               ; let ex_ok = existential_ok || gadt_ok
+                     -- Data cons can have existential context
+               ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons
+               ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc)
+
+                -- Check that fields with the same name share a type
+               ; mapM_ check_fields groups }}
+  where
+    syn_ctxt  = TySynCtxt name
+    name      = tyConName tc
+    data_cons = tyConDataCons tc
+
+    groups = equivClasses cmp_fld (concatMap get_fields data_cons)
+    cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2
+    get_fields con = dataConFieldLabels con `zip` repeat con
+        -- dataConFieldLabels may return the empty list, which is fine
+
+    -- See Note [GADT record selectors] in TcTyDecls
+    -- We must check (a) that the named field has the same
+    --                   type in each constructor
+    --               (b) that those constructors have the same result type
+    --
+    -- However, the constructors may have differently named type variable
+    -- and (worse) we don't know how the correspond to each other.  E.g.
+    --     C1 :: forall a b. { f :: a, g :: b } -> T a b
+    --     C2 :: forall d c. { f :: c, g :: c } -> T c d
+    --
+    -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's
+    -- result type against other candidates' types BOTH WAYS ROUND.
+    -- If they magically agrees, take the substitution and
+    -- apply them to the latter ones, and see if they match perfectly.
+    check_fields ((label, con1) :| other_fields)
+        -- These fields all have the same name, but are from
+        -- different constructors in the data type
+        = recoverM (return ()) $ mapM_ checkOne other_fields
+                -- Check that all the fields in the group have the same type
+                -- NB: this check assumes that all the constructors of a given
+                -- data type use the same type variables
+        where
+        (_, _, _, res1) = dataConSig con1
+        fty1 = dataConFieldType con1 lbl
+        lbl = flLabel label
+
+        checkOne (_, con2)    -- Do it both ways to ensure they are structurally identical
+            = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2
+                 ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 }
+            where
+                (_, _, _, res2) = dataConSig con2
+                fty2 = dataConFieldType con2 lbl
+
+checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM ()
+-- Checks the partial record field selector, and warns.
+-- See Note [Checking partial record field]
+checkPartialRecordField all_cons fld
+  = setSrcSpan loc $
+      warnIfFlag Opt_WarnPartialFields
+        (not is_exhaustive && not (startsWithUnderscore occ_name))
+        (sep [text "Use of partial record field selector" <> colon,
+              nest 2 $ quotes (ppr occ_name)])
+  where
+    sel_name = flSelector fld
+    loc    = getSrcSpan sel_name
+    occ_name = getOccName sel_name
+
+    (cons_with_field, cons_without_field) = partition has_field all_cons
+    has_field con = fld `elem` (dataConFieldLabels con)
+    is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field
+
+    con1 = ASSERT( not (null cons_with_field) ) head cons_with_field
+    (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1
+    eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)
+    inst_tys = substTyVars eq_subst univ_tvs
+
+checkFieldCompat :: FieldLabelString -> DataCon -> DataCon
+                 -> Type -> Type -> Type -> Type -> TcM ()
+checkFieldCompat fld con1 con2 res1 res2 fty1 fty2
+  = do  { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
+        ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }
+  where
+    mb_subst1 = tcMatchTy res1 res2
+    mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2
+
+-------------------------------
+checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()
+checkValidDataCon dflags existential_ok tc con
+  = setSrcSpan (getSrcSpan con)  $
+    addErrCtxt (dataConCtxt con) $
+    do  { -- Check that the return type of the data constructor
+          -- matches the type constructor; eg reject this:
+          --   data T a where { MkT :: Bogus a }
+          -- It's important to do this first:
+          --  see Note [Checking GADT return types]
+          --  and c.f. Note [Check role annotations in a second pass]
+          let tc_tvs      = tyConTyVars tc
+              res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
+              orig_res_ty = dataConOrigResTy con
+        ; traceTc "checkValidDataCon" (vcat
+              [ ppr con, ppr tc, ppr tc_tvs
+              , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl)
+              , ppr orig_res_ty <+> dcolon <+> ppr (tcTypeKind orig_res_ty)])
+
+
+        ; checkTc (isJust (tcMatchTy res_ty_tmpl
+                                     orig_res_ty))
+                  (badDataConTyCon con res_ty_tmpl orig_res_ty)
+            -- Note that checkTc aborts if it finds an error. This is
+            -- critical to avoid panicking when we call dataConUserType
+            -- on an un-rejiggable datacon!
+
+        ; traceTc "checkValidDataCon 2" (ppr (dataConUserType con))
+
+          -- Check that the result type is a *monotype*
+          --  e.g. reject this:   MkT :: T (forall a. a->a)
+          -- Reason: it's really the argument of an equality constraint
+        ; checkValidMonoType orig_res_ty
+
+          -- Check all argument types for validity
+        ; checkValidType ctxt (dataConUserType con)
+        ; mapM_ (checkForLevPoly empty)
+                (dataConOrigArgTys con)
+
+          -- Extra checks for newtype data constructors
+        ; when (isNewTyCon tc) (checkNewDataCon con)
+
+          -- Check that existentials are allowed if they are used
+        ; checkTc (existential_ok || isVanillaDataCon con)
+                  (badExistential con)
+
+          -- Check that UNPACK pragmas and bangs work out
+          -- E.g.  reject   data T = MkT {-# UNPACK #-} Int     -- No "!"
+          --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack
+        ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]
+
+          -- Check the dcUserTyVarBinders invariant
+          -- See Note [DataCon user type variable binders] in DataCon
+          -- checked here because we sometimes build invalid DataCons before
+          -- erroring above here
+        ; when debugIsOn $
+          do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con
+                   user_tvs                       = dataConUserTyVars con
+                   user_tvbs_invariant
+                     =    Set.fromList (filterEqSpec eq_spec univs ++ exs)
+                       == Set.fromList user_tvs
+             ; WARN( not user_tvbs_invariant
+                       , vcat ([ ppr con
+                               , ppr univs
+                               , ppr exs
+                               , ppr eq_spec
+                               , ppr user_tvs ])) return () }
+
+        ; traceTc "Done validity of data con" $
+          vcat [ ppr con
+               , text "Datacon user type:" <+> ppr (dataConUserType con)
+               , text "Datacon rep type:" <+> ppr (dataConRepType con)
+               , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con))
+               , case tyConFamInst_maybe (dataConTyCon con) of
+                   Nothing -> text "not family"
+                   Just (f, _) -> ppr (tyConBinders f) ]
+    }
+  where
+    ctxt = ConArgCtxt (dataConName con)
+
+    check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()
+    check_bang (HsSrcBang _ _ SrcLazy) _ n
+      | not (xopt LangExt.StrictData dflags)
+      = addErrTc
+          (bad_bang n (text "Lazy annotation (~) without StrictData"))
+    check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n
+      | isSrcUnpacked want_unpack, not is_strict
+      = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))
+      | isSrcUnpacked want_unpack
+      , case rep_bang of { HsUnpack {} -> False; _ -> True }
+      -- If not optimising, we don't unpack (rep_bang is never
+      -- HsUnpack), so don't complain!  This happens, e.g., in Haddock.
+      -- See dataConSrcToImplBang.
+      , not (gopt Opt_OmitInterfacePragmas dflags)
+      -- When typechecking an indefinite package in Backpack, we
+      -- may attempt to UNPACK an abstract type.  The test here will
+      -- conclude that this is unusable, but it might become usable
+      -- when we actually fill in the abstract type.  As such, don't
+      -- warn in this case (it gives users the wrong idea about whether
+      -- or not UNPACK on abstract types is supported; it is!)
+      , unitIdIsDefinite (thisPackage dflags)
+      = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))
+      where
+        is_strict = case strict_mark of
+                      NoSrcStrict -> xopt LangExt.StrictData dflags
+                      bang        -> isSrcStrict bang
+
+    check_bang _ _ _
+      = return ()
+
+    bad_bang n herald
+      = hang herald 2 (text "on the" <+> speakNth n
+                       <+> text "argument of" <+> quotes (ppr con))
+-------------------------------
+checkNewDataCon :: DataCon -> TcM ()
+-- Further checks for the data constructor of a newtype
+checkNewDataCon con
+  = do  { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))
+              -- One argument
+
+        ; checkTc (not (isUnliftedType arg_ty1)) $
+          text "A newtype cannot have an unlifted argument type"
+
+        ; check_con (null eq_spec) $
+          text "A newtype constructor must have a return type of form T a1 ... an"
+                -- Return type is (T a b c)
+
+        ; check_con (null theta) $
+          text "A newtype constructor cannot have a context in its type"
+
+        ; check_con (null ex_tvs) $
+          text "A newtype constructor cannot have existential type variables"
+                -- No existentials
+
+        ; checkTc (all ok_bang (dataConSrcBangs con))
+                  (newtypeStrictError con)
+                -- No strictness annotations
+    }
+  where
+    (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)
+      = dataConFullSig con
+    check_con what msg
+       = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con))
+
+    (arg_ty1 : _) = arg_tys
+
+    ok_bang (HsSrcBang _ _ SrcStrict) = False
+    ok_bang (HsSrcBang _ _ SrcLazy)   = False
+    ok_bang _                         = True
+
+-------------------------------
+checkValidClass :: Class -> TcM ()
+checkValidClass cls
+  = do  { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods
+        ; multi_param_type_classes  <- xoptM LangExt.MultiParamTypeClasses
+        ; nullary_type_classes      <- xoptM LangExt.NullaryTypeClasses
+        ; fundep_classes            <- xoptM LangExt.FunctionalDependencies
+        ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses
+
+        -- Check that the class is unary, unless multiparameter type classes
+        -- are enabled; also recognize deprecated nullary type classes
+        -- extension (subsumed by multiparameter type classes, Trac #8993)
+        ; checkTc (multi_param_type_classes || cls_arity == 1 ||
+                    (nullary_type_classes && cls_arity == 0))
+                  (classArityErr cls_arity cls)
+        ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)
+
+        -- Check the super-classes
+        ; checkValidTheta (ClassSCCtxt (className cls)) theta
+
+          -- Now check for cyclic superclasses
+          -- If there are superclass cycles, checkClassCycleErrs bails.
+        ; unless undecidable_super_classes $
+          case checkClassCycles cls of
+             Just err -> setSrcSpan (getSrcSpan cls) $
+                         addErrTc err
+             Nothing  -> return ()
+
+        -- Check the class operations.
+        -- But only if there have been no earlier errors
+        -- See Note [Abort when superclass cycle is detected]
+        ; whenNoErrs $
+          mapM_ (check_op constrained_class_methods) op_stuff
+
+        -- Check the associated type defaults are well-formed and instantiated
+        ; mapM_ check_at at_stuff  }
+  where
+    (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls
+    cls_arity = length (tyConVisibleTyVars (classTyCon cls))
+       -- Ignore invisible variables
+    cls_tv_set = mkVarSet tyvars
+
+    check_op constrained_class_methods (sel_id, dm)
+      = setSrcSpan (getSrcSpan sel_id) $
+        addErrCtxt (classOpCtxt sel_id op_ty) $ do
+        { traceTc "class op type" (ppr op_ty)
+        ; checkValidType ctxt op_ty
+                -- This implements the ambiguity check, among other things
+                -- Example: tc223
+                --   class Error e => Game b mv e | b -> mv e where
+                --      newBoard :: MonadState b m => m ()
+                -- Here, MonadState has a fundep m->b, so newBoard is fine
+
+           -- a method cannot be levity polymorphic, as we have to store the
+           -- method in a dictionary
+           -- example of what this prevents:
+           --   class BoundedX (a :: TYPE r) where minBound :: a
+           -- See Note [Levity polymorphism checking] in DsMonad
+        ; checkForLevPoly empty tau1
+
+        ; unless constrained_class_methods $
+          mapM_ check_constraint (tail (cls_pred:op_theta))
+
+        ; check_dm ctxt sel_id cls_pred tau2 dm
+        }
+        where
+          ctxt    = FunSigCtxt op_name True -- Report redundant class constraints
+          op_name = idName sel_id
+          op_ty   = idType sel_id
+          (_,cls_pred,tau1) = tcSplitMethodTy op_ty
+          -- See Note [Splitting nested sigma types in class type signatures]
+          (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1
+
+          check_constraint :: TcPredType -> TcM ()
+          check_constraint pred -- See Note [Class method constraints]
+            = when (not (isEmptyVarSet pred_tvs) &&
+                    pred_tvs `subVarSet` cls_tv_set)
+                   (addErrTc (badMethPred sel_id pred))
+            where
+              pred_tvs = tyCoVarsOfType pred
+
+    check_at (ATI fam_tc m_dflt_rhs)
+      = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)
+                     (noClassTyVarErr cls fam_tc)
+                        -- Check that the associated type mentions at least
+                        -- one of the class type variables
+                        -- The check is disabled for nullary type classes,
+                        -- since there is no possible ambiguity (Trac #10020)
+
+             -- Check that any default declarations for associated types are valid
+           ; whenIsJust m_dflt_rhs $ \ (rhs, loc) ->
+             setSrcSpan loc $
+             tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $
+             checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs }
+        where
+          fam_tvs = tyConTyVars fam_tc
+
+    check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM ()
+    -- Check validity of the /top-level/ generic-default type
+    -- E.g for   class C a where
+    --             default op :: forall b. (a~b) => blah
+    -- we do not want to do an ambiguity check on a type with
+    -- a free TyVar 'a' (Trac #11608).  See TcType
+    -- Note [TyVars and TcTyVars during type checking] in TcType
+    -- Hence the mkDefaultMethodType to close the type.
+    check_dm ctxt sel_id vanilla_cls_pred vanilla_tau
+             (Just (dm_name, dm_spec@(GenericDM dm_ty)))
+      = setSrcSpan (getSrcSpan dm_name) $ do
+            -- We have carefully set the SrcSpan on the generic
+            -- default-method Name to be that of the generic
+            -- default type signature
+
+          -- First, we check that that the method's default type signature
+          -- aligns with the non-default type signature.
+          -- See Note [Default method type signatures must align]
+          let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls
+              -- Note that the second field of this tuple contains the context
+              -- of the default type signature, making it apparent that we
+              -- ignore method contexts completely when validity-checking
+              -- default type signatures. See the end of
+              -- Note [Default method type signatures must align]
+              -- to learn why this is OK.
+              --
+              -- See also
+              -- Note [Splitting nested sigma types in class type signatures]
+              -- for an explanation of why we don't use tcSplitSigmaTy here.
+              (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty
+
+              -- Given this class definition:
+              --
+              --  class C a b where
+              --    op         :: forall p q. (Ord a, D p q)
+              --               => a -> b -> p -> (a, b)
+              --    default op :: forall r s. E r
+              --               => a -> b -> s -> (a, b)
+              --
+              -- We want to match up two types of the form:
+              --
+              --   Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb)
+              --   Default type sig: C a  b  => a  -> b  -> s -> (a,  b)
+              --
+              -- Notice that the two type signatures can be quantified over
+              -- different class type variables! Therefore, it's important that
+              -- we include the class predicate parts to match up a with aa and
+              -- b with bb.
+              vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau
+              dm_phi_ty      = mkPhiTy [cls_pred] dm_tau
+
+          traceTc "check_dm" $ vcat
+              [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty
+              , text "dm_phi_ty"      <+> ppr dm_phi_ty ]
+
+          -- Actually checking that the types align is done with a call to
+          -- tcMatchTys. We need to get a match in both directions to rule
+          -- out degenerate cases like these:
+          --
+          --  class Foo a where
+          --    foo1         :: a -> b
+          --    default foo1 :: a -> Int
+          --
+          --    foo2         :: a -> Int
+          --    default foo2 :: a -> b
+          unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty]
+                                      [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $
+               hang (text "The default type signature for"
+                     <+> ppr sel_id <> colon)
+                 2 (ppr dm_ty)
+            $$ (text "does not match its corresponding"
+                <+> text "non-default type signature")
+
+          -- Now do an ambiguity check on the default type signature.
+          checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec)
+    check_dm _ _ _ _ _ = return ()
+
+checkFamFlag :: Name -> TcM ()
+-- Check that we don't use families without -XTypeFamilies
+-- The parser won't even parse them, but I suppose a GHC API
+-- client might have a go!
+checkFamFlag tc_name
+  = do { idx_tys <- xoptM LangExt.TypeFamilies
+       ; checkTc idx_tys err_msg }
+  where
+    err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))
+                 2 (text "Enable TypeFamilies to allow indexed type families")
+
+{- Note [Class method constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Haskell 2010 is supposed to reject
+  class C a where
+    op :: Eq a => a -> a
+where the method type constrains only the class variable(s).  (The extension
+-XConstrainedClassMethods switches off this check.)  But regardless
+we should not reject
+  class C a where
+    op :: (?x::Int) => a -> a
+as pointed out in Trac #11793. So the test here rejects the program if
+  * -XConstrainedClassMethods is off
+  * the tyvars of the constraint are non-empty
+  * all the tyvars are class tyvars, none are locally quantified
+
+Note [Abort when superclass cycle is detected]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must avoid doing the ambiguity check for the methods (in
+checkValidClass.check_op) when there are already errors accumulated.
+This is because one of the errors may be a superclass cycle, and
+superclass cycles cause canonicalization to loop. Here is a
+representative example:
+
+  class D a => C a where
+    meth :: D a => ()
+  class C a => D a
+
+This fixes Trac #9415, #9739
+
+Note [Default method type signatures must align]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+GHC enforces the invariant that a class method's default type signature
+must "align" with that of the method's non-default type signature, as per
+GHC Trac #12918. For instance, if you have:
+
+  class Foo a where
+    bar :: forall b. Context => a -> b
+
+Then a default type signature for bar must be alpha equivalent to
+(forall b. a -> b). That is, the types must be the same modulo differences in
+contexts. So the following would be acceptable default type signatures:
+
+    default bar :: forall b. Context1 => a -> b
+    default bar :: forall x. Context2 => a -> x
+
+But the following are NOT acceptable default type signatures:
+
+    default bar :: forall b. b -> a
+    default bar :: forall x. x
+    default bar :: a -> Int
+
+Note that a is bound by the class declaration for Foo itself, so it is
+not allowed to differ in the default type signature.
+
+The default type signature (default bar :: a -> Int) deserves special mention,
+since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To
+write this, you need to declare the default type signature like so:
+
+    default bar :: forall b. (b ~ Int). a -> b
+
+As noted in #12918, there are several reasons to do this:
+
+1. It would make no sense to have a type that was flat-out incompatible with
+   the non-default type signature. For instance, if you had:
+
+     class Foo a where
+       bar :: a -> Int
+       default bar :: a -> Bool
+
+   Then that would always fail in an instance declaration. So this check
+   nips such cases in the bud before they have the chance to produce
+   confusing error messages.
+
+2. Internally, GHC uses TypeApplications to instantiate the default method in
+   an instance. See Note [Default methods in instances] in TcInstDcls.
+   Thus, GHC needs to know exactly what the universally quantified type
+   variables are, and when instantiated that way, the default method's type
+   must match the expected type.
+
+3. Aesthetically, by only allowing the default type signature to differ in its
+   context, we are making it more explicit the ways in which the default type
+   signature is less polymorphic than the non-default type signature.
+
+You might be wondering: why are the contexts allowed to be different, but not
+the rest of the type signature? That's because default implementations often
+rely on assumptions that the more general, non-default type signatures do not.
+For instance, in the Enum class declaration:
+
+    class Enum a where
+      enum :: [a]
+      default enum :: (Generic a, GEnum (Rep a)) => [a]
+      enum = map to genum
+
+    class GEnum f where
+      genum :: [f a]
+
+The default implementation for enum only works for types that are instances of
+Generic, and for which their generic Rep type is an instance of GEnum. But
+clearly enum doesn't _have_ to use this implementation, so naturally, the
+context for enum is allowed to be different to accomodate this. As a result,
+when we validity-check default type signatures, we ignore contexts completely.
+
+Note that when checking whether two type signatures match, we must take care to
+split as many foralls as it takes to retrieve the tau types we which to check.
+See Note [Splitting nested sigma types in class type signatures].
+
+Note [Splitting nested sigma types in class type signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this type synonym and class definition:
+
+  type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t
+
+  class Each s t a b where
+    each         ::                                      Traversal s t a b
+    default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b
+
+It might seem obvious that the tau types in both type signatures for `each`
+are the same, but actually getting GHC to conclude this is surprisingly tricky.
+That is because in general, the form of a class method's non-default type
+signature is:
+
+  forall a. C a => forall d. D d => E a b
+
+And the general form of a default type signature is:
+
+  forall f. F f => E a f -- The variable `a` comes from the class
+
+So it you want to get the tau types in each type signature, you might find it
+reasonable to call tcSplitSigmaTy twice on the non-default type signature, and
+call it once on the default type signature. For most classes and methods, this
+will work, but Each is a bit of an exceptional case. The way `each` is written,
+it doesn't quantify any additional type variables besides those of the Each
+class itself, so the non-default type signature for `each` is actually this:
+
+  forall s t a b. Each s t a b => Traversal s t a b
+
+Notice that there _appears_ to only be one forall. But there's actually another
+forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy
+twice, you'll also go under the forall in Traversal! That is, you'll end up
+with:
+
+  (a -> f b) -> s -> f t
+
+A problem arises because you only call tcSplitSigmaTy once on the default type
+signature for `each`, which gives you
+
+  Traversal s t a b
+
+Or, equivalently:
+
+  forall f. Applicative f => (a -> f b) -> s -> f t
+
+This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will
+say that the tau types for `each` are not equal.
+
+A solution to this problem is to use tcSplitNestedSigmaTys instead of
+tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it
+sees until it can't go any further, so if you called it on the default type
+signature for `each`, it would return (a -> f b) -> s -> f t like we desired.
+
+Note [Checking partial record field]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This check checks the partial record field selector, and warns (Trac #7169).
+
+For example:
+
+  data T a = A { m1 :: a, m2 :: a } | B { m1 :: a }
+
+The function 'm2' is partial record field, and will fail when it is applied to
+'B'. The warning identifies such partial fields. The check is performed at the
+declaration of T, not at the call-sites of m2.
+
+The warning can be suppressed by prefixing the field-name with an underscore.
+For example:
+
+  data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a }
+
+************************************************************************
+*                                                                      *
+                Checking role validity
+*                                                                      *
+************************************************************************
+-}
+
+checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM ()
+checkValidRoleAnnots role_annots tc
+  | isTypeSynonymTyCon tc = check_no_roles
+  | isFamilyTyCon tc      = check_no_roles
+  | isAlgTyCon tc         = check_roles
+  | otherwise             = return ()
+  where
+    -- Role annotations are given only on *explicit* variables,
+    -- but a tycon stores roles for all variables.
+    -- So, we drop the implicit roles (which are all Nominal, anyway).
+    name                   = tyConName tc
+    roles                  = tyConRoles tc
+    (vis_roles, vis_vars)  = unzip $ mapMaybe pick_vis $
+                             zip roles (tyConBinders tc)
+    role_annot_decl_maybe  = lookupRoleAnnot role_annots name
+
+    pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar)
+    pick_vis (role, tvb)
+      | isVisibleTyConBinder tvb = Just (role, binderVar tvb)
+      | otherwise                = Nothing
+
+    check_roles
+      = whenIsJust role_annot_decl_maybe $
+          \decl@(dL->L loc (RoleAnnotDecl _ _ the_role_annots)) ->
+          addRoleAnnotCtxt name $
+          setSrcSpan loc $ do
+          { role_annots_ok <- xoptM LangExt.RoleAnnotations
+          ; checkTc role_annots_ok $ needXRoleAnnotations tc
+          ; checkTc (vis_vars `equalLength` the_role_annots)
+                    (wrongNumberOfRoles vis_vars decl)
+          ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles
+          -- Representational or phantom roles for class parameters
+          -- quickly lead to incoherence. So, we require
+          -- IncoherentInstances to have them. See #8773, #14292
+          ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances
+          ; checkTc (  incoherent_roles_ok
+                    || (not $ isClassTyCon tc)
+                    || (all (== Nominal) vis_roles))
+                    incoherentRoles
+
+          ; lint <- goptM Opt_DoCoreLinting
+          ; when lint $ checkValidRoles tc }
+
+    check_no_roles
+      = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl
+
+checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()
+checkRoleAnnot _  (dL->L _ Nothing)   _  = return ()
+checkRoleAnnot tv (dL->L _ (Just r1)) r2
+  = when (r1 /= r2) $
+    addErrTc $ badRoleAnnot (tyVarName tv) r1 r2
+checkRoleAnnot _ _ _ = panic "checkRoleAnnot: Impossible Match" -- due to #15884
+
+-- This is a double-check on the role inference algorithm. It is only run when
+-- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls
+checkValidRoles :: TyCon -> TcM ()
+-- If you edit this function, you may need to update the GHC formalism
+-- See Note [GHC Formalism] in CoreLint
+checkValidRoles tc
+  | isAlgTyCon tc
+    -- tyConDataCons returns an empty list for data families
+  = mapM_ check_dc_roles (tyConDataCons tc)
+  | Just rhs <- synTyConRhs_maybe tc
+  = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs
+  | otherwise
+  = return ()
+  where
+    check_dc_roles datacon
+      = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc))
+           ; mapM_ (check_ty_roles role_env Representational) $
+                    eqSpecPreds eq_spec ++ theta ++ arg_tys }
+                    -- See Note [Role-checking data constructor arguments] in TcTyDecls
+      where
+        (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)
+          = dataConFullSig datacon
+        univ_roles = zipVarEnv univ_tvs (tyConRoles tc)
+              -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs
+        ex_roles   = mkVarEnv (map (, Nominal) ex_tvs)
+        role_env   = univ_roles `plusVarEnv` ex_roles
+
+    check_ty_roles env role ty
+      | Just ty' <- coreView ty -- #14101
+      = check_ty_roles env role ty'
+
+    check_ty_roles env role (TyVarTy tv)
+      = case lookupVarEnv env tv of
+          Just role' -> unless (role' `ltRole` role || role' == role) $
+                        report_error $ text "type variable" <+> quotes (ppr tv) <+>
+                                       text "cannot have role" <+> ppr role <+>
+                                       text "because it was assigned role" <+> ppr role'
+          Nothing    -> report_error $ text "type variable" <+> quotes (ppr tv) <+>
+                                       text "missing in environment"
+
+    check_ty_roles env Representational (TyConApp tc tys)
+      = let roles' = tyConRoles tc in
+        zipWithM_ (maybe_check_ty_roles env) roles' tys
+
+    check_ty_roles env Nominal (TyConApp _ tys)
+      = mapM_ (check_ty_roles env Nominal) tys
+
+    check_ty_roles _   Phantom ty@(TyConApp {})
+      = pprPanic "check_ty_roles" (ppr ty)
+
+    check_ty_roles env role (AppTy ty1 ty2)
+      =  check_ty_roles env role    ty1
+      >> check_ty_roles env Nominal ty2
+
+    check_ty_roles env role (FunTy ty1 ty2)
+      =  check_ty_roles env role ty1
+      >> check_ty_roles env role ty2
+
+    check_ty_roles env role (ForAllTy (Bndr tv _) ty)
+      =  check_ty_roles env Nominal (tyVarKind tv)
+      >> check_ty_roles (extendVarEnv env tv Nominal) role ty
+
+    check_ty_roles _   _    (LitTy {}) = return ()
+
+    check_ty_roles env role (CastTy t _)
+      = check_ty_roles env role t
+
+    check_ty_roles _   role (CoercionTy co)
+      = unless (role == Phantom) $
+        report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role
+
+    maybe_check_ty_roles env role ty
+      = when (role == Nominal || role == Representational) $
+        check_ty_roles env role ty
+
+    report_error doc
+      = addErrTc $ vcat [text "Internal error in role inference:",
+                         doc,
+                         text "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug"]
+
+{-
+************************************************************************
+*                                                                      *
+                Error messages
+*                                                                      *
+************************************************************************
+-}
+
+tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a
+tcAddTyFamInstCtxt decl
+  = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)
+
+tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc
+tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn =
+                            HsIB { hsib_body = eqn }})
+  = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")
+                    (unLoc (feqn_tycon eqn))
+tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs _))
+  = panic "tcMkDataFamInstCtxt"
+
+tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a
+tcAddDataFamInstCtxt decl
+  = addErrCtxt (tcMkDataFamInstCtxt decl)
+
+tcMkFamInstCtxt :: SDoc -> Name -> SDoc
+tcMkFamInstCtxt flavour tycon
+  = hsep [ text "In the" <+> flavour <+> text "declaration for"
+         , quotes (ppr tycon) ]
+
+tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a
+tcAddFamInstCtxt flavour tycon thing_inside
+  = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside
+
+tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a
+tcAddClosedTypeFamilyDeclCtxt tc
+  = addErrCtxt ctxt
+  where
+    ctxt = text "In the equations for closed type family" <+>
+           quotes (ppr tc)
+
+resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc
+resultTypeMisMatch field_name con1 con2
+  = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,
+                text "have a common field" <+> quotes (ppr field_name) <> comma],
+          nest 2 $ text "but have different result types"]
+
+fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc
+fieldTypeMisMatch field_name con1 con2
+  = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,
+         text "give different types for field", quotes (ppr field_name)]
+
+dataConCtxtName :: [Located Name] -> SDoc
+dataConCtxtName [con]
+   = text "In the definition of data constructor" <+> quotes (ppr con)
+dataConCtxtName con
+   = text "In the definition of data constructors" <+> interpp'SP con
+
+dataConCtxt :: Outputable a => a -> SDoc
+dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con)
+
+classOpCtxt :: Var -> Type -> SDoc
+classOpCtxt sel_id tau = sep [text "When checking the class method:",
+                              nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)]
+
+classArityErr :: Int -> Class -> SDoc
+classArityErr n cls
+    | n == 0 = mkErr "No" "no-parameter"
+    | otherwise = mkErr "Too many" "multi-parameter"
+  where
+    mkErr howMany allowWhat =
+        vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls),
+              parens (text ("Enable MultiParamTypeClasses to allow "
+                                    ++ allowWhat ++ " classes"))]
+
+classFunDepsErr :: Class -> SDoc
+classFunDepsErr cls
+  = vcat [text "Fundeps in class" <+> quotes (ppr cls),
+          parens (text "Enable FunctionalDependencies to allow fundeps")]
+
+badMethPred :: Id -> TcPredType -> SDoc
+badMethPred sel_id pred
+  = vcat [ hang (text "Constraint" <+> quotes (ppr pred)
+                 <+> text "in the type of" <+> quotes (ppr sel_id))
+              2 (text "constrains only the class type variables")
+         , text "Enable ConstrainedClassMethods to allow it" ]
+
+noClassTyVarErr :: Class -> TyCon -> SDoc
+noClassTyVarErr clas fam_tc
+  = sep [ text "The associated type" <+> quotes (ppr fam_tc)
+        , text "mentions none of the type or kind variables of the class" <+>
+                quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))]
+
+badDataConTyCon :: DataCon -> Type -> Type -> SDoc
+badDataConTyCon data_con res_ty_tmpl actual_res_ty
+  | ASSERT( all isTyVar actual_ex_tvs )
+    tcIsForAllTy actual_res_ty
+  = nested_foralls_contexts_suggestion
+  | isJust (tcSplitPredFunTy_maybe actual_res_ty)
+  = nested_foralls_contexts_suggestion
+  | otherwise
+  = hang (text "Data constructor" <+> quotes (ppr data_con) <+>
+                text "returns type" <+> quotes (ppr actual_res_ty))
+       2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl))
+  where
+    -- This suggestion is useful for suggesting how to correct code like what
+    -- was reported in Trac #12087:
+    --
+    --   data F a where
+    --     MkF :: Ord a => Eq a => a -> F a
+    --
+    -- Although nested foralls or contexts are allowed in function type
+    -- signatures, it is much more difficult to engineer GADT constructor type
+    -- signatures to allow something similar, so we error in the latter case.
+    -- Nevertheless, we can at least suggest how a user might reshuffle their
+    -- exotic GADT constructor type signature so that GHC will accept.
+    nested_foralls_contexts_suggestion =
+      text "GADT constructor type signature cannot contain nested"
+      <+> quotes forAllLit <> text "s or contexts"
+      $+$ hang (text "Suggestion: instead use this type signature:")
+             2 (ppr (dataConName data_con) <+> dcolon <+> ppr suggested_ty)
+
+    -- To construct a type that GHC would accept (suggested_ty), we:
+    --
+    -- 1) Find the existentially quantified type variables and the class
+    --    predicates from the datacon. (NB: We don't need the universally
+    --    quantified type variables, since rejigConRes won't substitute them in
+    --    the result type if it fails, as in this scenario.)
+    -- 2) Split apart the return type (which is headed by a forall or a
+    --    context) using tcSplitNestedSigmaTys, collecting the type variables
+    --    and class predicates we find, as well as the rho type lurking
+    --    underneath the nested foralls and contexts.
+    -- 3) Smash together the type variables and class predicates from 1) and
+    --    2), and prepend them to the rho type from 2).
+    actual_ex_tvs = dataConExTyCoVars data_con
+    actual_theta  = dataConTheta data_con
+    (actual_res_tvs, actual_res_theta, actual_res_rho)
+      = tcSplitNestedSigmaTys actual_res_ty
+    suggested_ty = mkSpecForAllTys (actual_ex_tvs ++ actual_res_tvs) $
+                   mkFunTys (actual_theta ++ actual_res_theta)
+                   actual_res_rho
+
+badGadtDecl :: Name -> SDoc
+badGadtDecl tc_name
+  = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)
+         , nest 2 (parens $ text "Enable the GADTs extension to allow this") ]
+
+badExistential :: DataCon -> SDoc
+badExistential con
+  = hang (text "Data constructor" <+> quotes (ppr con) <+>
+                text "has existential type variables, a context, or a specialised result type")
+       2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con)
+               , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])
+
+badStupidTheta :: Name -> SDoc
+badStupidTheta tc_name
+  = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name)
+
+newtypeConError :: Name -> Int -> SDoc
+newtypeConError tycon n
+  = sep [text "A newtype must have exactly one constructor,",
+         nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ]
+
+newtypeStrictError :: DataCon -> SDoc
+newtypeStrictError con
+  = sep [text "A newtype constructor cannot have a strictness annotation,",
+         nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"]
+
+newtypeFieldErr :: DataCon -> Int -> SDoc
+newtypeFieldErr con_name n_flds
+  = sep [text "The constructor of a newtype must have exactly one field",
+         nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds]
+
+badSigTyDecl :: Name -> SDoc
+badSigTyDecl tc_name
+  = vcat [ text "Illegal kind signature" <+>
+           quotes (ppr tc_name)
+         , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ]
+
+emptyConDeclsErr :: Name -> SDoc
+emptyConDeclsErr tycon
+  = sep [quotes (ppr tycon) <+> text "has no constructors",
+         nest 2 $ text "(EmptyDataDecls permits this)"]
+
+wrongKindOfFamily :: TyCon -> SDoc
+wrongKindOfFamily family
+  = text "Wrong category of family instance; declaration was for a"
+    <+> kindOfFamily
+  where
+    kindOfFamily | isTypeFamilyTyCon family = text "type family"
+                 | isDataFamilyTyCon family = text "data family"
+                 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)
+
+-- | Produce an error for oversaturated type family equations with too many
+-- required arguments.
+-- See Note [Oversaturated type family equations] in TcValidity.
+wrongNumberOfParmsErr :: Arity -> SDoc
+wrongNumberOfParmsErr max_args
+  = text "Number of parameters must match family declaration; expected"
+    <+> ppr max_args
+
+defaultAssocKindErr :: TyCon -> SDoc
+defaultAssocKindErr fam_tc
+  = text "Kind mis-match on LHS of default declaration for"
+    <+> quotes (ppr fam_tc)
+
+badRoleAnnot :: Name -> Role -> Role -> SDoc
+badRoleAnnot var annot inferred
+  = hang (text "Role mismatch on variable" <+> ppr var <> colon)
+       2 (sep [ text "Annotation says", ppr annot
+              , text "but role", ppr inferred
+              , text "is required" ])
+
+wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc
+wrongNumberOfRoles tyvars d@(dL->L _ (RoleAnnotDecl _ _ annots))
+  = hang (text "Wrong number of roles listed in role annotation;" $$
+          text "Expected" <+> (ppr $ length tyvars) <> comma <+>
+          text "got" <+> (ppr $ length annots) <> colon)
+       2 (ppr d)
+wrongNumberOfRoles _ (dL->L _ (XRoleAnnotDecl _)) = panic "wrongNumberOfRoles"
+wrongNumberOfRoles _ _ = panic "wrongNumberOfRoles: Impossible Match"
+                         -- due to #15884
+
+
+illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()
+illegalRoleAnnotDecl (dL->L loc (RoleAnnotDecl _ tycon _))
+  = setErrCtxt [] $
+    setSrcSpan loc $
+    addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$
+              text "they are allowed only for datatypes and classes.")
+illegalRoleAnnotDecl (dL->L _ (XRoleAnnotDecl _)) = panic "illegalRoleAnnotDecl"
+illegalRoleAnnotDecl _ = panic "illegalRoleAnnotDecl: Impossible Match"
+                         -- due to #15884
+
+needXRoleAnnotations :: TyCon -> SDoc
+needXRoleAnnotations tc
+  = text "Illegal role annotation for" <+> ppr tc <> char ';' $$
+    text "did you intend to use RoleAnnotations?"
+
+incoherentRoles :: SDoc
+incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+>
+                   text "for class parameters can lead to incoherence.") $$
+                  (text "Use IncoherentInstances to allow this; bad role found")
+
+addTyConCtxt :: TyCon -> TcM a -> TcM a
+addTyConCtxt tc = addTyConFlavCtxt name flav
+  where
+    name = getName tc
+    flav = tyConFlavour tc
+
+addRoleAnnotCtxt :: Name -> TcM a -> TcM a
+addRoleAnnotCtxt name
+  = addErrCtxt $
+    text "while checking a role annotation for" <+> quotes (ppr name)
diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -0,0 +1,1033 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1999
+
+
+Analysis functions over data types.  Specifically, detecting recursive types.
+
+This stuff is only used for source-code decls; it's recorded in interface
+files for imported data types.
+-}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module TcTyDecls(
+        RolesInfo,
+        inferRoles,
+        checkSynCycles,
+        checkClassCycles,
+
+        -- * Implicits
+        addTyConsToGblEnv, mkDefaultMethodType,
+
+        -- * Record selectors
+        tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector
+    ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import TcRnMonad
+import TcEnv
+import TcBinds( tcValBinds, addTypecheckedBinds )
+import TyCoRep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) )
+import TcType
+import TysWiredIn( unitTy )
+import MkCore( rEC_SEL_ERROR_ID )
+import HsSyn
+import Class
+import Type
+import HscTypes
+import TyCon
+import ConLike
+import DataCon
+import Name
+import NameEnv
+import NameSet hiding (unitFV)
+import RdrName ( mkVarUnqual )
+import Id
+import IdInfo
+import VarEnv
+import VarSet
+import Coercion ( ltRole )
+import BasicTypes
+import SrcLoc
+import Unique ( mkBuiltinUnique )
+import Outputable
+import Util
+import Maybes
+import Bag
+import FastString
+import FV
+import Module
+
+import Control.Monad
+
+{-
+************************************************************************
+*                                                                      *
+        Cycles in type synonym declarations
+*                                                                      *
+************************************************************************
+-}
+
+synonymTyConsOfType :: Type -> [TyCon]
+-- Does not look through type synonyms at all
+-- Return a list of synonym tycons
+-- Keep this synchronized with 'expandTypeSynonyms'
+synonymTyConsOfType ty
+  = nameEnvElts (go ty)
+  where
+     go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
+     go (TyConApp tc tys)         = go_tc tc `plusNameEnv` go_s tys
+     go (LitTy _)                 = emptyNameEnv
+     go (TyVarTy _)               = emptyNameEnv
+     go (AppTy a b)               = go a `plusNameEnv` go b
+     go (FunTy a b)               = go a `plusNameEnv` go b
+     go (ForAllTy _ ty)           = go ty
+     go (CastTy ty co)            = go ty `plusNameEnv` go_co co
+     go (CoercionTy co)           = go_co co
+
+     -- Note [TyCon cycles through coercions?!]
+     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+     -- Although, in principle, it's possible for a type synonym loop
+     -- could go through a coercion (since a coercion can refer to
+     -- a TyCon or Type), it doesn't seem possible to actually construct
+     -- a Haskell program which tickles this case.  Here is an example
+     -- program which causes a coercion:
+     --
+     --   type family Star where
+     --       Star = Type
+     --
+     --   data T :: Star -> Type
+     --   data S :: forall (a :: Type). T a -> Type
+     --
+     -- Here, the application 'T a' must first coerce a :: Type to a :: Star,
+     -- witnessed by the type family.  But if we now try to make Type refer
+     -- to a type synonym which in turn refers to Star, we'll run into
+     -- trouble: we're trying to define and use the type constructor
+     -- in the same recursive group.  Possibly this restriction will be
+     -- lifted in the future but for now, this code is "just for completeness
+     -- sake".
+     go_mco MRefl    = emptyNameEnv
+     go_mco (MCo co) = go_co co
+
+     go_co (Refl ty)              = go ty
+     go_co (GRefl _ ty mco)       = go ty `plusNameEnv` go_mco mco
+     go_co (TyConAppCo _ tc cs)   = go_tc tc `plusNameEnv` go_co_s cs
+     go_co (AppCo co co')         = go_co co `plusNameEnv` go_co co'
+     go_co (ForAllCo _ co co')    = go_co co `plusNameEnv` go_co co'
+     go_co (FunCo _ co co')       = go_co co `plusNameEnv` go_co co'
+     go_co (CoVarCo _)            = emptyNameEnv
+     go_co (HoleCo {})            = emptyNameEnv
+     go_co (AxiomInstCo _ _ cs)   = go_co_s cs
+     go_co (UnivCo p _ ty ty')    = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty'
+     go_co (SymCo co)             = go_co co
+     go_co (TransCo co co')       = go_co co `plusNameEnv` go_co co'
+     go_co (NthCo _ _ co)         = go_co co
+     go_co (LRCo _ co)            = go_co co
+     go_co (InstCo co co')        = go_co co `plusNameEnv` go_co co'
+     go_co (KindCo co)            = go_co co
+     go_co (SubCo co)             = go_co co
+     go_co (AxiomRuleCo _ cs)     = go_co_s cs
+
+     go_prov UnsafeCoerceProv     = emptyNameEnv
+     go_prov (PhantomProv co)     = go_co co
+     go_prov (ProofIrrelProv co)  = go_co co
+     go_prov (PluginProv _)       = emptyNameEnv
+
+     go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc
+              | otherwise             = emptyNameEnv
+     go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys
+     go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos
+
+-- | A monad for type synonym cycle checking, which keeps
+-- track of the TyCons which are known to be acyclic, or
+-- a failure message reporting that a cycle was found.
+newtype SynCycleM a = SynCycleM {
+    runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }
+
+type SynCycleState = NameSet
+
+instance Functor SynCycleM where
+    fmap = liftM
+
+instance Applicative SynCycleM where
+    pure x = SynCycleM $ \state -> Right (x, state)
+    (<*>) = ap
+
+instance Monad SynCycleM where
+    m >>= f = SynCycleM $ \state ->
+        case runSynCycleM m state of
+            Right (x, state') ->
+                runSynCycleM (f x) state'
+            Left err -> Left err
+
+failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
+failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err)
+
+-- | Test if a 'Name' is acyclic, short-circuiting if we've
+-- seen it already.
+checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM ()
+checkNameIsAcyclic n m = SynCycleM $ \s ->
+    if n `elemNameSet` s
+        then Right ((), s) -- short circuit
+        else case runSynCycleM m s of
+                Right ((), s') -> Right ((), extendNameSet s' n)
+                Left err -> Left err
+
+-- | Checks if any of the passed in 'TyCon's have cycles.
+-- Takes the 'UnitId' of the home package (as we can avoid
+-- checking those TyCons: cycles never go through foreign packages) and
+-- the corresponding @LTyClDecl Name@ for each 'TyCon', so we
+-- can give better error messages.
+checkSynCycles :: UnitId -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
+checkSynCycles this_uid tcs tyclds = do
+    case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of
+        Left (loc, err) -> setSrcSpan loc $ failWithTc err
+        Right _  -> return ()
+  where
+    -- Try our best to print the LTyClDecl for locally defined things
+    lcl_decls = mkNameEnv (zip (map tyConName tcs) tyclds)
+
+    -- Short circuit if we've already seen this Name and concluded
+    -- it was acyclic.
+    go :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()
+    go so_far seen_tcs tc =
+        checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc
+
+    -- Expand type synonyms, complaining if you find the same
+    -- type synonym a second time.
+    go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()
+    go' so_far seen_tcs tc
+        | n `elemNameSet` so_far
+            = failSynCycleM (getSrcSpan (head seen_tcs)) $
+                  sep [ text "Cycle in type synonym declarations:"
+                      , nest 2 (vcat (map ppr_decl seen_tcs)) ]
+        -- Optimization: we don't allow cycles through external packages,
+        -- so once we find a non-local name we are guaranteed to not
+        -- have a cycle.
+        --
+        -- This won't hold once we get recursive packages with Backpack,
+        -- but for now it's fine.
+        | not (isHoleModule mod ||
+               moduleUnitId mod == this_uid ||
+               isInteractiveModule mod)
+            = return ()
+        | Just ty <- synTyConRhs_maybe tc =
+            go_ty (extendNameSet so_far (tyConName tc)) (tc:seen_tcs) ty
+        | otherwise = return ()
+      where
+        n = tyConName tc
+        mod = nameModule n
+        ppr_decl tc =
+          case lookupNameEnv lcl_decls n of
+            Just (dL->L loc decl) -> ppr loc <> colon <+> ppr decl
+            Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n
+                       <+> text "from external module"
+         where
+          n = tyConName tc
+
+    go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM ()
+    go_ty so_far seen_tcs ty =
+        mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty)
+
+{- Note [Superclass cycle check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The superclass cycle check for C decides if we can statically
+guarantee that expanding C's superclass cycles transitively is
+guaranteed to terminate.  This is a Haskell98 requirement,
+but one that we lift with -XUndecidableSuperClasses.
+
+The worry is that a superclass cycle could make the type checker loop.
+More precisely, with a constraint (Given or Wanted)
+    C ty1 .. tyn
+one approach is to instantiate all of C's superclasses, transitively.
+We can only do so if that set is finite.
+
+This potential loop occurs only through superclasses.  This, for
+example, is fine
+  class C a where
+    op :: C b => a -> b -> b
+even though C's full definition uses C.
+
+Making the check static also makes it conservative.  Eg
+  type family F a
+  class F a => C a
+Here an instance of (F a) might mention C:
+  type instance F [a] = C a
+and now we'd have a loop.
+
+The static check works like this, starting with C
+  * Look at C's superclass predicates
+  * If any is a type-function application,
+    or is headed by a type variable, fail
+  * If any has C at the head, fail
+  * If any has a type class D at the head,
+    make the same test with D
+
+A tricky point is: what if there is a type variable at the head?
+Consider this:
+   class f (C f) => C f
+   class c       => Id c
+and now expand superclasses for constraint (C Id):
+     C Id
+ --> Id (C Id)
+ --> C Id
+ --> ....
+Each step expands superclasses one layer, and clearly does not terminate.
+-}
+
+checkClassCycles :: Class -> Maybe SDoc
+-- Nothing  <=> ok
+-- Just err <=> possible cycle error
+checkClassCycles cls
+  = do { (definite_cycle, err) <- go (unitNameSet (getName cls))
+                                     cls (mkTyVarTys (classTyVars cls))
+       ; let herald | definite_cycle = text "Superclass cycle for"
+                    | otherwise      = text "Potential superclass cycle for"
+       ; return (vcat [ herald <+> quotes (ppr cls)
+                      , nest 2 err, hint]) }
+  where
+    hint = text "Use UndecidableSuperClasses to accept this"
+
+    -- Expand superclasses starting with (C a b), complaining
+    -- if you find the same class a second time, or a type function
+    -- or predicate headed by a type variable
+    --
+    -- NB: this code duplicates TcType.transSuperClasses, but
+    --     with more error message generation clobber
+    -- Make sure the two stay in sync.
+    go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)
+    go so_far cls tys = firstJusts $
+                        map (go_pred so_far) $
+                        immSuperClasses cls tys
+
+    go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc)
+       -- Nothing <=> ok
+       -- Just (True, err)  <=> definite cycle
+       -- Just (False, err) <=> possible cycle
+    go_pred so_far pred  -- NB: tcSplitTyConApp looks through synonyms
+       | Just (tc, tys) <- tcSplitTyConApp_maybe pred
+       = go_tc so_far pred tc tys
+       | hasTyVarHead pred
+       = Just (False, hang (text "one of whose superclass constraints is headed by a type variable:")
+                         2 (quotes (ppr pred)))
+       | otherwise
+       = Nothing
+
+    go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)
+    go_tc so_far pred tc tys
+      | isFamilyTyCon tc
+      = Just (False, hang (text "one of whose superclass constraints is headed by a type family:")
+                        2 (quotes (ppr pred)))
+      | Just cls <- tyConClass_maybe tc
+      = go_cls so_far cls tys
+      | otherwise   -- Equality predicate, for example
+      = Nothing
+
+    go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)
+    go_cls so_far cls tys
+       | cls_nm `elemNameSet` so_far
+       = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls))
+       | isCTupleClass cls
+       = go so_far cls tys
+       | otherwise
+       = do { (b,err) <- go  (so_far `extendNameSet` cls_nm) cls tys
+          ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls)
+                       $$ err) }
+       where
+         cls_nm = getName cls
+
+{-
+************************************************************************
+*                                                                      *
+        Role inference
+*                                                                      *
+************************************************************************
+
+Note [Role inference]
+~~~~~~~~~~~~~~~~~~~~~
+The role inference algorithm datatype definitions to infer the roles on the
+parameters. Although these roles are stored in the tycons, we can perform this
+algorithm on the built tycons, as long as we don't peek at an as-yet-unknown
+roles field! Ah, the magic of laziness.
+
+First, we choose appropriate initial roles. For families and classes, roles
+(including initial roles) are N. For datatypes, we start with the role in the
+role annotation (if any), or otherwise use Phantom. This is done in
+initialRoleEnv1.
+
+The function irGroup then propagates role information until it reaches a
+fixpoint, preferring N over (R or P) and R over P. To aid in this, we have a
+monad RoleM, which is a combination reader and state monad. In its state are
+the current RoleEnv, which gets updated by role propagation, and an update
+bit, which we use to know whether or not we've reached the fixpoint. The
+environment of RoleM contains the tycon whose parameters we are inferring, and
+a VarEnv from parameters to their positions, so we can update the RoleEnv.
+Between tycons, this reader information is missing; it is added by
+addRoleInferenceInfo.
+
+There are two kinds of tycons to consider: algebraic ones (excluding classes)
+and type synonyms. (Remember, families don't participate -- all their parameters
+are N.) An algebraic tycon processes each of its datacons, in turn. Note that
+a datacon's universally quantified parameters might be different from the parent
+tycon's parameters, so we use the datacon's univ parameters in the mapping from
+vars to positions. Note also that we don't want to infer roles for existentials
+(they're all at N, too), so we put them in the set of local variables. As an
+optimisation, we skip any tycons whose roles are already all Nominal, as there
+nowhere else for them to go. For synonyms, we just analyse their right-hand sides.
+
+irType walks through a type, looking for uses of a variable of interest and
+propagating role information. Because anything used under a phantom position
+is at phantom and anything used under a nominal position is at nominal, the
+irType function can assume that anything it sees is at representational. (The
+other possibilities are pruned when they're encountered.)
+
+The rest of the code is just plumbing.
+
+How do we know that this algorithm is correct? It should meet the following
+specification:
+
+Let Z be a role context -- a mapping from variables to roles. The following
+rules define the property (Z |- t : r), where t is a type and r is a role:
+
+Z(a) = r'        r' <= r
+------------------------- RCVar
+Z |- a : r
+
+---------- RCConst
+Z |- T : r               -- T is a type constructor
+
+Z |- t1 : r
+Z |- t2 : N
+-------------- RCApp
+Z |- t1 t2 : r
+
+forall i<=n. (r_i is R or N) implies Z |- t_i : r_i
+roles(T) = r_1 .. r_n
+---------------------------------------------------- RCDApp
+Z |- T t_1 .. t_n : R
+
+Z, a:N |- t : r
+---------------------- RCAll
+Z |- forall a:k.t : r
+
+
+We also have the following rules:
+
+For all datacon_i in type T, where a_1 .. a_n are universally quantified
+and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p,
+then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R,
+then roles(T) = r_1 .. r_n
+
+roles(->) = R, R
+roles(~#) = N, N
+
+With -dcore-lint on, the output of this algorithm is checked in checkValidRoles,
+called from checkValidTycon.
+
+Note [Role-checking data constructor arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+  data T a where
+    MkT :: Eq b => F a -> (a->a) -> T (G a)
+
+Then we want to check the roles at which 'a' is used
+in MkT's type.  We want to work on the user-written type,
+so we need to take into account
+  * the arguments:   (F a) and (a->a)
+  * the context:     C a b
+  * the result type: (G a)   -- this is in the eq_spec
+
+
+Note [Coercions in role inference]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Is (t |> co1) representationally equal to (t |> co2)? Of course they are! Changing
+the kind of a type is totally irrelevant to the representation of that type. So,
+we want to totally ignore coercions when doing role inference. This includes omitting
+any type variables that appear in nominal positions but only within coercions.
+-}
+
+type RolesInfo = Name -> [Role]
+
+type RoleEnv = NameEnv [Role]        -- from tycon names to roles
+
+-- This, and any of the functions it calls, must *not* look at the roles
+-- field of a tycon we are inferring roles about!
+-- See Note [Role inference]
+inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role]
+inferRoles hsc_src annots tycons
+  = let role_env  = initialRoleEnv hsc_src annots tycons
+        role_env' = irGroup role_env tycons in
+    \name -> case lookupNameEnv role_env' name of
+      Just roles -> roles
+      Nothing    -> pprPanic "inferRoles" (ppr name)
+
+initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv
+initialRoleEnv hsc_src annots = extendNameEnvList emptyNameEnv .
+                                map (initialRoleEnv1 hsc_src annots)
+
+initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role])
+initialRoleEnv1 hsc_src annots_env tc
+  | isFamilyTyCon tc      = (name, map (const Nominal) bndrs)
+  | isAlgTyCon tc         = (name, default_roles)
+  | isTypeSynonymTyCon tc = (name, default_roles)
+  | otherwise             = pprPanic "initialRoleEnv1" (ppr tc)
+  where name         = tyConName tc
+        bndrs        = tyConBinders tc
+        argflags     = map tyConBinderArgFlag bndrs
+        num_exps     = count isVisibleArgFlag argflags
+
+          -- if the number of annotations in the role annotation decl
+          -- is wrong, just ignore it. We check this in the validity check.
+        role_annots
+          = case lookupRoleAnnot annots_env name of
+              Just (dL->L _ (RoleAnnotDecl _ _ annots))
+                | annots `lengthIs` num_exps -> map unLoc annots
+              _                              -> replicate num_exps Nothing
+        default_roles = build_default_roles argflags role_annots
+
+        build_default_roles (argf : argfs) (m_annot : ras)
+          | isVisibleArgFlag argf
+          = (m_annot `orElse` default_role) : build_default_roles argfs ras
+        build_default_roles (_argf : argfs) ras
+          = Nominal : build_default_roles argfs ras
+        build_default_roles [] [] = []
+        build_default_roles _ _ = pprPanic "initialRoleEnv1 (2)"
+                                           (vcat [ppr tc, ppr role_annots])
+
+        default_role
+          | isClassTyCon tc               = Nominal
+          -- Note [Default roles for abstract TyCons in hs-boot/hsig]
+          | HsBootFile <- hsc_src
+          , isAbstractTyCon tc            = Representational
+          | HsigFile   <- hsc_src
+          , isAbstractTyCon tc            = Nominal
+          | otherwise                     = Phantom
+
+-- Note [Default roles for abstract TyCons in hs-boot/hsig]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- What should the default role for an abstract TyCon be?
+--
+-- Originally, we inferred phantom role for abstract TyCons
+-- in hs-boot files, because the type variables were never used.
+--
+-- This was silly, because the role of the abstract TyCon
+-- was required to match the implementation, and the roles of
+-- data types are almost never phantom.  Thus, in ticket #9204,
+-- the default was changed so be representational (the most common case).  If
+-- the implementing data type was actually nominal, you'd get an easy
+-- to understand error, and add the role annotation yourself.
+--
+-- Then Backpack was added, and with it we added role *subtyping*
+-- the matching judgment: if an abstract TyCon has a nominal
+-- parameter, it's OK to implement it with a representational
+-- parameter.  But now, the representational default is not a good
+-- one, because you should *only* request representational if
+-- you're planning to do coercions. To be maximally flexible
+-- with what data types you will accept, you want the default
+-- for hsig files is nominal.  We don't allow role subtyping
+-- with hs-boot files (it's good practice to give an exactly
+-- accurate role here, because any types that use the abstract
+-- type will propagate the role information.)
+
+irGroup :: RoleEnv -> [TyCon] -> RoleEnv
+irGroup env tcs
+  = let (env', update) = runRoleM env $ mapM_ irTyCon tcs in
+    if update
+    then irGroup env' tcs
+    else env'
+
+irTyCon :: TyCon -> RoleM ()
+irTyCon tc
+  | isAlgTyCon tc
+  = do { old_roles <- lookupRoles tc
+       ; unless (all (== Nominal) old_roles) $  -- also catches data families,
+                                                -- which don't want or need role inference
+         irTcTyVars tc $
+         do { mapM_ (irType emptyVarSet) (tyConStupidTheta tc)  -- See #8958
+            ; whenIsJust (tyConClass_maybe tc) irClass
+            ; mapM_ irDataCon (visibleDataCons $ algTyConRhs tc) }}
+
+  | Just ty <- synTyConRhs_maybe tc
+  = irTcTyVars tc $
+    irType emptyVarSet ty
+
+  | otherwise
+  = return ()
+
+-- any type variable used in an associated type must be Nominal
+irClass :: Class -> RoleM ()
+irClass cls
+  = mapM_ ir_at (classATs cls)
+  where
+    cls_tvs    = classTyVars cls
+    cls_tv_set = mkVarSet cls_tvs
+
+    ir_at at_tc
+      = mapM_ (updateRole Nominal) nvars
+      where nvars = filter (`elemVarSet` cls_tv_set) $ tyConTyVars at_tc
+
+-- See Note [Role inference]
+irDataCon :: DataCon -> RoleM ()
+irDataCon datacon
+  = setRoleInferenceVars univ_tvs $
+    irExTyVars ex_tvs $ \ ex_var_set ->
+    mapM_ (irType ex_var_set)
+          (map tyVarKind ex_tvs ++ eqSpecPreds eq_spec ++ theta ++ arg_tys)
+      -- See Note [Role-checking data constructor arguments]
+  where
+    (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)
+      = dataConFullSig datacon
+
+irType :: VarSet -> Type -> RoleM ()
+irType = go
+  where
+    go lcls ty                 | Just ty' <- coreView ty -- #14101
+                               = go lcls ty'
+    go lcls (TyVarTy tv)       = unless (tv `elemVarSet` lcls) $
+                                 updateRole Representational tv
+    go lcls (AppTy t1 t2)      = go lcls t1 >> markNominal lcls t2
+    go lcls (TyConApp tc tys)  = do { roles <- lookupRolesX tc
+                                    ; zipWithM_ (go_app lcls) roles tys }
+    go lcls (ForAllTy tvb ty)  = do { let tv = binderVar tvb
+                                          lcls' = extendVarSet lcls tv
+                                    ; markNominal lcls (tyVarKind tv)
+                                    ; go lcls' ty }
+    go lcls (FunTy arg res)    = go lcls arg >> go lcls res
+    go _    (LitTy {})         = return ()
+      -- See Note [Coercions in role inference]
+    go lcls (CastTy ty _)      = go lcls ty
+    go _    (CoercionTy _)     = return ()
+
+    go_app _ Phantom _ = return ()                 -- nothing to do here
+    go_app lcls Nominal ty = markNominal lcls ty  -- all vars below here are N
+    go_app lcls Representational ty = go lcls ty
+
+irTcTyVars :: TyCon -> RoleM a -> RoleM a
+irTcTyVars tc thing
+  = setRoleInferenceTc (tyConName tc) $ go (tyConTyVars tc)
+  where
+    go []       = thing
+    go (tv:tvs) = do { markNominal emptyVarSet (tyVarKind tv)
+                     ; addRoleInferenceVar tv $ go tvs }
+
+irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a
+irExTyVars orig_tvs thing = go emptyVarSet orig_tvs
+  where
+    go lcls []       = thing lcls
+    go lcls (tv:tvs) = do { markNominal lcls (tyVarKind tv)
+                          ; go (extendVarSet lcls tv) tvs }
+
+markNominal :: TyVarSet   -- local variables
+            -> Type -> RoleM ()
+markNominal lcls ty = let nvars = fvVarList (FV.delFVs lcls $ get_ty_vars ty) in
+                      mapM_ (updateRole Nominal) nvars
+  where
+     -- get_ty_vars gets all the tyvars (no covars!) from a type *without*
+     -- recurring into coercions. Recall: coercions are totally ignored during
+     -- role inference. See [Coercions in role inference]
+    get_ty_vars :: Type -> FV
+    get_ty_vars (TyVarTy tv)      = unitFV tv
+    get_ty_vars (AppTy t1 t2)     = get_ty_vars t1 `unionFV` get_ty_vars t2
+    get_ty_vars (FunTy t1 t2)     = get_ty_vars t1 `unionFV` get_ty_vars t2
+    get_ty_vars (TyConApp _ tys)  = mapUnionFV get_ty_vars tys
+    get_ty_vars (ForAllTy tvb ty) = tyCoFVsBndr tvb (get_ty_vars ty)
+    get_ty_vars (LitTy {})        = emptyFV
+    get_ty_vars (CastTy ty _)     = get_ty_vars ty
+    get_ty_vars (CoercionTy _)    = emptyFV
+
+-- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps
+lookupRolesX :: TyCon -> RoleM [Role]
+lookupRolesX tc
+  = do { roles <- lookupRoles tc
+       ; return $ roles ++ repeat Nominal }
+
+-- gets the roles either from the environment or the tycon
+lookupRoles :: TyCon -> RoleM [Role]
+lookupRoles tc
+  = do { env <- getRoleEnv
+       ; case lookupNameEnv env (tyConName tc) of
+           Just roles -> return roles
+           Nothing    -> return $ tyConRoles tc }
+
+-- tries to update a role; won't ever update a role "downwards"
+updateRole :: Role -> TyVar -> RoleM ()
+updateRole role tv
+  = do { var_ns <- getVarNs
+       ; name <- getTyConName
+       ; case lookupVarEnv var_ns tv of
+           Nothing -> pprPanic "updateRole" (ppr name $$ ppr tv $$ ppr var_ns)
+           Just n  -> updateRoleEnv name n role }
+
+-- the state in the RoleM monad
+data RoleInferenceState = RIS { role_env  :: RoleEnv
+                              , update    :: Bool }
+
+-- the environment in the RoleM monad
+type VarPositions = VarEnv Int
+
+-- See [Role inference]
+newtype RoleM a = RM { unRM :: Maybe Name -- of the tycon
+                            -> VarPositions
+                            -> Int          -- size of VarPositions
+                            -> RoleInferenceState
+                            -> (a, RoleInferenceState) }
+
+instance Functor RoleM where
+    fmap = liftM
+
+instance Applicative RoleM where
+    pure x = RM $ \_ _ _ state -> (x, state)
+    (<*>) = ap
+
+instance Monad RoleM where
+  a >>= f  = RM $ \m_info vps nvps state ->
+                  let (a', state') = unRM a m_info vps nvps state in
+                  unRM (f a') m_info vps nvps state'
+
+runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool)
+runRoleM env thing = (env', update)
+  where RIS { role_env = env', update = update }
+          = snd $ unRM thing Nothing emptyVarEnv 0 state
+        state = RIS { role_env  = env
+                    , update    = False }
+
+setRoleInferenceTc :: Name -> RoleM a -> RoleM a
+setRoleInferenceTc name thing = RM $ \m_name vps nvps state ->
+                                ASSERT( isNothing m_name )
+                                ASSERT( isEmptyVarEnv vps )
+                                ASSERT( nvps == 0 )
+                                unRM thing (Just name) vps nvps state
+
+addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a
+addRoleInferenceVar tv thing
+  = RM $ \m_name vps nvps state ->
+    ASSERT( isJust m_name )
+    unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state
+
+setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a
+setRoleInferenceVars tvs thing
+  = RM $ \m_name _vps _nvps state ->
+    ASSERT( isJust m_name )
+    unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars")
+         state
+
+getRoleEnv :: RoleM RoleEnv
+getRoleEnv = RM $ \_ _ _ state@(RIS { role_env = env }) -> (env, state)
+
+getVarNs :: RoleM VarPositions
+getVarNs = RM $ \_ vps _ state -> (vps, state)
+
+getTyConName :: RoleM Name
+getTyConName = RM $ \m_name _ _ state ->
+                    case m_name of
+                      Nothing   -> panic "getTyConName"
+                      Just name -> (name, state)
+
+updateRoleEnv :: Name -> Int -> Role -> RoleM ()
+updateRoleEnv name n role
+  = RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((),
+         case lookupNameEnv role_env name of
+           Nothing -> pprPanic "updateRoleEnv" (ppr name)
+           Just roles -> let (before, old_role : after) = splitAt n roles in
+                         if role `ltRole` old_role
+                         then let roles' = before ++ role : after
+                                  role_env' = extendNameEnv role_env name roles' in
+                              RIS { role_env = role_env', update = True }
+                         else state )
+
+
+{- *********************************************************************
+*                                                                      *
+                Building implicits
+*                                                                      *
+********************************************************************* -}
+
+addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv
+-- Given a [TyCon], add to the TcGblEnv
+--   * extend the TypeEnv with the tycons
+--   * extend the TypeEnv with their implicitTyThings
+--   * extend the TypeEnv with any default method Ids
+--   * add bindings for record selectors
+addTyConsToGblEnv tyclss
+  = tcExtendTyConEnv tyclss                    $
+    tcExtendGlobalEnvImplicit implicit_things  $
+    tcExtendGlobalValEnv def_meth_ids          $
+    do { traceTc "tcAddTyCons" $ vcat
+            [ text "tycons" <+> ppr tyclss
+            , text "implicits" <+> ppr implicit_things ]
+       ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss)
+       ; return gbl_env }
+ where
+   implicit_things = concatMap implicitTyConThings tyclss
+   def_meth_ids    = mkDefaultMethodIds tyclss
+
+mkDefaultMethodIds :: [TyCon] -> [Id]
+-- We want to put the default-method Ids (both vanilla and generic)
+-- into the type environment so that they are found when we typecheck
+-- the filled-in default methods of each instance declaration
+-- See Note [Default method Ids and Template Haskell]
+mkDefaultMethodIds tycons
+  = [ mkExportedVanillaId dm_name (mkDefaultMethodType cls sel_id dm_spec)
+    | tc <- tycons
+    , Just cls <- [tyConClass_maybe tc]
+    , (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ]
+
+mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type
+-- Returns the top-level type of the default method
+mkDefaultMethodType _ sel_id VanillaDM        = idType sel_id
+mkDefaultMethodType cls _   (GenericDM dm_ty) = mkSigmaTy tv_bndrs [pred] dm_ty
+   where
+     pred      = mkClassPred cls (mkTyVarTys (binderVars cls_bndrs))
+     cls_bndrs = tyConBinders (classTyCon cls)
+     tv_bndrs  = tyConTyVarBinders cls_bndrs
+     -- NB: the Class doesn't have TyConBinders; we reach into its
+     --     TyCon to get those.  We /do/ need the TyConBinders because
+     --     we need the correct visibility: these default methods are
+     --     used in code generated by the fill-in for missing
+     --     methods in instances (TcInstDcls.mkDefMethBind), and
+     --     then typechecked.  So we need the right visibilty info
+     --     (Trac #13998)
+
+{-
+************************************************************************
+*                                                                      *
+                Building record selectors
+*                                                                      *
+************************************************************************
+-}
+
+{-
+Note [Default method Ids and Template Haskell]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (Trac #4169):
+   class Numeric a where
+     fromIntegerNum :: a
+     fromIntegerNum = ...
+
+   ast :: Q [Dec]
+   ast = [d| instance Numeric Int |]
+
+When we typecheck 'ast' we have done the first pass over the class decl
+(in tcTyClDecls), but we have not yet typechecked the default-method
+declarations (because they can mention value declarations).  So we
+must bring the default method Ids into scope first (so they can be seen
+when typechecking the [d| .. |] quote, and typecheck them later.
+-}
+
+{-
+************************************************************************
+*                                                                      *
+                Building record selectors
+*                                                                      *
+************************************************************************
+-}
+
+tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
+tcRecSelBinds sel_bind_prs
+  = tcExtendGlobalValEnv [sel_id | (dL->L _ (IdSig _ sel_id)) <- sigs] $
+    do { (rec_sel_binds, tcg_env) <- discardWarnings $
+                                     tcValBinds TopLevel binds sigs getGblEnv
+       ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) }
+  where
+    sigs = [ cL loc (IdSig noExt sel_id)   | (sel_id, _) <- sel_bind_prs
+                                          , let loc = getSrcSpan sel_id ]
+    binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs]
+
+mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]
+-- NB We produce *un-typechecked* bindings, rather like 'deriving'
+--    This makes life easier, because the later type checking will add
+--    all necessary type abstractions and applications
+mkRecSelBinds tycons
+  = map mkRecSelBind [ (tc,fld) | tc <- tycons
+                                , fld <- tyConFieldLabels tc ]
+
+mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn)
+mkRecSelBind (tycon, fl)
+  = mkOneRecordSelector all_cons (RecSelData tycon) fl
+  where
+    all_cons = map RealDataCon (tyConDataCons tycon)
+
+mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel
+                    -> (Id, LHsBind GhcRn)
+mkOneRecordSelector all_cons idDetails fl
+  = (sel_id, cL loc sel_bind)
+  where
+    loc      = getSrcSpan sel_name
+    lbl      = flLabel fl
+    sel_name = flSelector fl
+
+    sel_id = mkExportedLocalId rec_details sel_name sel_ty
+    rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty }
+
+    -- Find a representative constructor, con1
+    cons_w_field = conLikesWithFields all_cons [lbl]
+    con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
+
+    -- Selector type; Note [Polymorphic selectors]
+    field_ty   = conLikeFieldType con1 lbl
+    data_tvs   = tyCoVarsOfTypesWellScoped inst_tys
+    data_tv_set= mkVarSet data_tvs
+    is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set)
+    (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
+    sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]
+           | otherwise  = mkSpecForAllTys data_tvs          $
+                          mkPhiTy (conLikeStupidTheta con1) $   -- Urgh!
+                          mkFunTy data_ty                   $
+                          mkSpecForAllTys field_tvs         $
+                          mkPhiTy field_theta               $
+                          -- req_theta is empty for normal DataCon
+                          mkPhiTy req_theta                 $
+                          field_tau
+
+    -- Make the binding: sel (C2 { fld = x }) = x
+    --                   sel (C7 { fld = x }) = x
+    --    where cons_w_field = [C2,C7]
+    sel_bind = mkTopFunBind Generated sel_lname alts
+      where
+        alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname)
+                                           [] unit_rhs]
+             | otherwise =  map mk_match cons_w_field ++ deflt
+    mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)
+                                 [cL loc (mk_sel_pat con)]
+                                 (cL loc (HsVar noExt (cL loc field_var)))
+    mk_sel_pat con = ConPatIn (cL loc (getName con)) (RecCon rec_fields)
+    rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
+    rec_field  = noLoc (HsRecField
+                        { hsRecFieldLbl
+                           = cL loc (FieldOcc sel_name
+                                     (cL loc $ mkVarUnqual lbl))
+                        , hsRecFieldArg
+                           = cL loc (VarPat noExt (cL loc field_var))
+                        , hsRecPun = False })
+    sel_lname = cL loc sel_name
+    field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc
+
+    -- Add catch-all default case unless the case is exhaustive
+    -- We do this explicitly so that we get a nice error message that
+    -- mentions this particular record selector
+    deflt | all dealt_with all_cons = []
+          | otherwise = [mkSimpleMatch CaseAlt
+                            [cL loc (WildPat noExt)]
+                            (mkHsApp (cL loc (HsVar noExt
+                                         (cL loc (getName rEC_SEL_ERROR_ID))))
+                                     (cL loc (HsLit noExt msg_lit)))]
+
+        -- Do not add a default case unless there are unmatched
+        -- constructors.  We must take account of GADTs, else we
+        -- get overlap warning messages from the pattern-match checker
+        -- NB: we need to pass type args for the *representation* TyCon
+        --     to dataConCannotMatch, hence the calculation of inst_tys
+        --     This matters in data families
+        --              data instance T Int a where
+        --                 A :: { fld :: Int } -> T Int Bool
+        --                 B :: { fld :: Int } -> T Int Char
+    dealt_with :: ConLike -> Bool
+    dealt_with (PatSynCon _) = False -- We can't predict overlap
+    dealt_with con@(RealDataCon dc) =
+      con `elem` cons_w_field || dataConCannotMatch inst_tys dc
+
+    (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1
+
+    eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)
+    inst_tys = substTyVars eq_subst univ_tvs
+
+    unit_rhs = mkLHsTupleExpr []
+    msg_lit = HsStringPrim NoSourceText (fastStringToByteString lbl)
+
+{-
+Note [Polymorphic selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We take care to build the type of a polymorphic selector in the right
+order, so that visible type application works.
+
+  data Ord a => T a = MkT { field :: forall b. (Num a, Show b) => (a, b) }
+
+We want
+
+  field :: forall a. Ord a => T a -> forall b. (Num a, Show b) => (a, b)
+
+Note [Naughty record selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A "naughty" field is one for which we can't define a record
+selector, because an existential type variable would escape.  For example:
+        data T = forall a. MkT { x,y::a }
+We obviously can't define
+        x (MkT v _) = v
+Nevertheless we *do* put a RecSelId into the type environment
+so that if the user tries to use 'x' as a selector we can bleat
+helpfully, rather than saying unhelpfully that 'x' is not in scope.
+Hence the sel_naughty flag, to identify record selectors that don't really exist.
+
+In general, a field is "naughty" if its type mentions a type variable that
+isn't in the result type of the constructor.  Note that this *allows*
+GADT record selectors (Note [GADT record selectors]) whose types may look
+like     sel :: T [a] -> a
+
+For naughty selectors we make a dummy binding
+   sel = ()
+so that the later type-check will add them to the environment, and they'll be
+exported.  The function is never called, because the typechecker spots the
+sel_naughty field.
+
+Note [GADT record selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For GADTs, we require that all constructors with a common field 'f' have the same
+result type (modulo alpha conversion).  [Checked in TcTyClsDecls.checkValidTyCon]
+E.g.
+        data T where
+          T1 { f :: Maybe a } :: T [a]
+          T2 { f :: Maybe a, y :: b  } :: T [a]
+          T3 :: T Int
+
+and now the selector takes that result type as its argument:
+   f :: forall a. T [a] -> Maybe a
+
+Details: the "real" types of T1,T2 are:
+   T1 :: forall r a.   (r~[a]) => a -> T r
+   T2 :: forall r a b. (r~[a]) => a -> b -> T r
+
+So the selector loooks like this:
+   f :: forall a. T [a] -> Maybe a
+   f (a:*) (t:T [a])
+     = case t of
+         T1 c   (g:[a]~[c]) (v:Maybe c)       -> v `cast` Maybe (right (sym g))
+         T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g))
+         T3 -> error "T3 does not have field f"
+
+Note the forall'd tyvars of the selector are just the free tyvars
+of the result type; there may be other tyvars in the constructor's
+type (e.g. 'b' in T2).
+
+Note the need for casts in the result!
+
+Note [Selector running example]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's OK to combine GADTs and type families.  Here's a running example:
+
+        data instance T [a] where
+          T1 { fld :: b } :: T [Maybe b]
+
+The representation type looks like this
+        data :R7T a where
+          T1 { fld :: b } :: :R7T (Maybe b)
+
+and there's coercion from the family type to the representation type
+        :CoR7T a :: T [a] ~ :R7T a
+
+The selector we want for fld looks like this:
+
+        fld :: forall b. T [Maybe b] -> b
+        fld = /\b. \(d::T [Maybe b]).
+              case d `cast` :CoR7T (Maybe b) of
+                T1 (x::b) -> x
+
+The scrutinee of the case has type :R7T (Maybe b), which can be
+gotten by appying the eq_spec to the univ_tvs of the data con.
+
+-}
diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcTypeNats.hs
@@ -0,0 +1,992 @@
+{-# LANGUAGE LambdaCase #-}
+
+module TcTypeNats
+  ( typeNatTyCons
+  , typeNatCoAxiomRules
+  , BuiltInSynFamily(..)
+
+    -- If you define a new built-in type family, make sure to export its TyCon
+    -- from here as well.
+    -- See Note [Adding built-in type families]
+  , typeNatAddTyCon
+  , typeNatMulTyCon
+  , typeNatExpTyCon
+  , typeNatLeqTyCon
+  , typeNatSubTyCon
+  , typeNatDivTyCon
+  , typeNatModTyCon
+  , typeNatLogTyCon
+  , typeNatCmpTyCon
+  , typeSymbolCmpTyCon
+  , typeSymbolAppendTyCon
+  ) where
+
+import GhcPrelude
+
+import Type
+import Pair
+import TcType     ( TcType, tcEqType )
+import TyCon      ( TyCon, FamTyConFlav(..), mkFamilyTyCon
+                  , Injectivity(..) )
+import Coercion   ( Role(..) )
+import TcRnTypes  ( Xi )
+import CoAxiom    ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn )
+import Name       ( Name, BuiltInSyntax(..) )
+import TysWiredIn
+import TysPrim    ( mkTemplateAnonTyConBinders )
+import PrelNames  ( gHC_TYPELITS
+                  , gHC_TYPENATS
+                  , typeNatAddTyFamNameKey
+                  , typeNatMulTyFamNameKey
+                  , typeNatExpTyFamNameKey
+                  , typeNatLeqTyFamNameKey
+                  , typeNatSubTyFamNameKey
+                  , typeNatDivTyFamNameKey
+                  , typeNatModTyFamNameKey
+                  , typeNatLogTyFamNameKey
+                  , typeNatCmpTyFamNameKey
+                  , typeSymbolCmpTyFamNameKey
+                  , typeSymbolAppendFamNameKey
+                  )
+import FastString ( FastString
+                  , fsLit, nilFS, nullFS, unpackFS, mkFastString, appendFS
+                  )
+import qualified Data.Map as Map
+import Data.Maybe ( isJust )
+import Control.Monad ( guard )
+import Data.List  ( isPrefixOf, isSuffixOf )
+
+{-
+Note [Type-level literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are currently two forms of type-level literals: natural numbers, and
+symbols (even though this module is named TcTypeNats, it covers both).
+
+Type-level literals are supported by CoAxiomRules (conditional axioms), which
+power the built-in type families (see Note [Adding built-in type families]).
+Currently, all built-in type families are for the express purpose of supporting
+type-level literals.
+
+See also the Wiki page:
+
+    https://ghc.haskell.org/trac/ghc/wiki/TypeNats
+
+Note [Adding built-in type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are a few steps to adding a built-in type family:
+
+* Adding a unique for the type family TyCon
+
+  These go in PrelNames. It will likely be of the form
+  @myTyFamNameKey = mkPreludeTyConUnique xyz@, where @xyz@ is a number that
+  has not been chosen before in PrelNames. There are several examples already
+  in PrelNames—see, for instance, typeNatAddTyFamNameKey.
+
+* Adding the type family TyCon itself
+
+  This goes in TcTypeNats. There are plenty of examples of how to define
+  these—see, for instance, typeNatAddTyCon.
+
+  Once your TyCon has been defined, be sure to:
+
+  - Export it from TcTypeNats. (Not doing so caused #14632.)
+  - Include it in the typeNatTyCons list, defined in TcTypeNats.
+
+* Exposing associated type family axioms
+
+  When defining the type family TyCon, you will need to define an axiom for
+  the type family in general (see, for instance, axAddDef), and perhaps other
+  auxiliary axioms for special cases of the type family (see, for instance,
+  axAdd0L and axAdd0R).
+
+  After you have defined all of these axioms, be sure to include them in the
+  typeNatCoAxiomRules list, defined in TcTypeNats.
+  (Not doing so caused #14934.)
+
+* Define the type family somewhere
+
+  Finally, you will need to define the type family somewhere, likely in @base@.
+  Currently, all of the built-in type families are defined in GHC.TypeLits or
+  GHC.TypeNats, so those are likely candidates.
+
+  Since the behavior of your built-in type family is specified in TcTypeNats,
+  you should give an open type family definition with no instances, like so:
+
+    type family MyTypeFam (m :: Nat) (n :: Nat) :: Nat
+
+  Changing the argument and result kinds as appropriate.
+
+* Update the relevant test cases
+
+  The GHC test suite will likely need to be updated after you add your built-in
+  type family. For instance:
+
+  - The T9181 test prints the :browse contents of GHC.TypeLits, so if you added
+    a test there, the expected output of T9181 will need to change.
+  - The TcTypeNatSimple and TcTypeSymbolSimple tests have compile-time unit
+    tests, as well as TcTypeNatSimpleRun and TcTypeSymbolSimpleRun, which have
+    runtime unit tests. Consider adding further unit tests to those if your
+    built-in type family deals with Nats or Symbols, respectively.
+-}
+
+{-------------------------------------------------------------------------------
+Built-in type constructors for functions on type-level nats
+-}
+
+-- The list of built-in type family TyCons that GHC uses.
+-- If you define a built-in type family, make sure to add it to this list.
+-- See Note [Adding built-in type families]
+typeNatTyCons :: [TyCon]
+typeNatTyCons =
+  [ typeNatAddTyCon
+  , typeNatMulTyCon
+  , typeNatExpTyCon
+  , typeNatLeqTyCon
+  , typeNatSubTyCon
+  , typeNatDivTyCon
+  , typeNatModTyCon
+  , typeNatLogTyCon
+  , typeNatCmpTyCon
+  , typeSymbolCmpTyCon
+  , typeSymbolAppendTyCon
+  ]
+
+typeNatAddTyCon :: TyCon
+typeNatAddTyCon = mkTypeNatFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamAdd
+    , sfInteractTop   = interactTopAdd
+    , sfInteractInert = interactInertAdd
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "+")
+            typeNatAddTyFamNameKey typeNatAddTyCon
+
+typeNatSubTyCon :: TyCon
+typeNatSubTyCon = mkTypeNatFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamSub
+    , sfInteractTop   = interactTopSub
+    , sfInteractInert = interactInertSub
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "-")
+            typeNatSubTyFamNameKey typeNatSubTyCon
+
+typeNatMulTyCon :: TyCon
+typeNatMulTyCon = mkTypeNatFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamMul
+    , sfInteractTop   = interactTopMul
+    , sfInteractInert = interactInertMul
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "*")
+            typeNatMulTyFamNameKey typeNatMulTyCon
+
+typeNatDivTyCon :: TyCon
+typeNatDivTyCon = mkTypeNatFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamDiv
+    , sfInteractTop   = interactTopDiv
+    , sfInteractInert = interactInertDiv
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Div")
+            typeNatDivTyFamNameKey typeNatDivTyCon
+
+typeNatModTyCon :: TyCon
+typeNatModTyCon = mkTypeNatFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamMod
+    , sfInteractTop   = interactTopMod
+    , sfInteractInert = interactInertMod
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod")
+            typeNatModTyFamNameKey typeNatModTyCon
+
+
+
+
+
+typeNatExpTyCon :: TyCon
+typeNatExpTyCon = mkTypeNatFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamExp
+    , sfInteractTop   = interactTopExp
+    , sfInteractInert = interactInertExp
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "^")
+                typeNatExpTyFamNameKey typeNatExpTyCon
+
+typeNatLogTyCon :: TyCon
+typeNatLogTyCon = mkTypeNatFunTyCon1 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamLog
+    , sfInteractTop   = interactTopLog
+    , sfInteractInert = interactInertLog
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2")
+            typeNatLogTyFamNameKey typeNatLogTyCon
+
+
+
+typeNatLeqTyCon :: TyCon
+typeNatLeqTyCon =
+  mkFamilyTyCon name
+    (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])
+    boolTy
+    Nothing
+    (BuiltInSynFamTyCon ops)
+    Nothing
+    NotInjective
+
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "<=?")
+                typeNatLeqTyFamNameKey typeNatLeqTyCon
+  ops = BuiltInSynFamily
+    { sfMatchFam      = matchFamLeq
+    , sfInteractTop   = interactTopLeq
+    , sfInteractInert = interactInertLeq
+    }
+
+typeNatCmpTyCon :: TyCon
+typeNatCmpTyCon =
+  mkFamilyTyCon name
+    (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])
+    orderingKind
+    Nothing
+    (BuiltInSynFamTyCon ops)
+    Nothing
+    NotInjective
+
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "CmpNat")
+                typeNatCmpTyFamNameKey typeNatCmpTyCon
+  ops = BuiltInSynFamily
+    { sfMatchFam      = matchFamCmpNat
+    , sfInteractTop   = interactTopCmpNat
+    , sfInteractInert = \_ _ _ _ -> []
+    }
+
+typeSymbolCmpTyCon :: TyCon
+typeSymbolCmpTyCon =
+  mkFamilyTyCon name
+    (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ])
+    orderingKind
+    Nothing
+    (BuiltInSynFamTyCon ops)
+    Nothing
+    NotInjective
+
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpSymbol")
+                typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon
+  ops = BuiltInSynFamily
+    { sfMatchFam      = matchFamCmpSymbol
+    , sfInteractTop   = interactTopCmpSymbol
+    , sfInteractInert = \_ _ _ _ -> []
+    }
+
+typeSymbolAppendTyCon :: TyCon
+typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name
+  BuiltInSynFamily
+    { sfMatchFam      = matchFamAppendSymbol
+    , sfInteractTop   = interactTopAppendSymbol
+    , sfInteractInert = interactInertAppendSymbol
+    }
+  where
+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "AppendSymbol")
+                typeSymbolAppendFamNameKey typeSymbolAppendTyCon
+
+
+
+-- Make a unary built-in constructor of kind: Nat -> Nat
+mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon
+mkTypeNatFunTyCon1 op tcb =
+  mkFamilyTyCon op
+    (mkTemplateAnonTyConBinders [ typeNatKind ])
+    typeNatKind
+    Nothing
+    (BuiltInSynFamTyCon tcb)
+    Nothing
+    NotInjective
+
+
+-- Make a binary built-in constructor of kind: Nat -> Nat -> Nat
+mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon
+mkTypeNatFunTyCon2 op tcb =
+  mkFamilyTyCon op
+    (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])
+    typeNatKind
+    Nothing
+    (BuiltInSynFamTyCon tcb)
+    Nothing
+    NotInjective
+
+-- Make a binary built-in constructor of kind: Symbol -> Symbol -> Symbol
+mkTypeSymbolFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon
+mkTypeSymbolFunTyCon2 op tcb =
+  mkFamilyTyCon op
+    (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ])
+    typeSymbolKind
+    Nothing
+    (BuiltInSynFamTyCon tcb)
+    Nothing
+    NotInjective
+
+
+{-------------------------------------------------------------------------------
+Built-in rules axioms
+-------------------------------------------------------------------------------}
+
+-- If you add additional rules, please remember to add them to
+-- `typeNatCoAxiomRules` also.
+-- See Note [Adding built-in type families]
+axAddDef
+  , axMulDef
+  , axExpDef
+  , axLeqDef
+  , axCmpNatDef
+  , axCmpSymbolDef
+  , axAppendSymbolDef
+  , axAdd0L
+  , axAdd0R
+  , axMul0L
+  , axMul0R
+  , axMul1L
+  , axMul1R
+  , axExp1L
+  , axExp0R
+  , axExp1R
+  , axLeqRefl
+  , axCmpNatRefl
+  , axCmpSymbolRefl
+  , axLeq0L
+  , axSubDef
+  , axSub0R
+  , axAppendSymbol0R
+  , axAppendSymbol0L
+  , axDivDef
+  , axDiv1
+  , axModDef
+  , axMod1
+  , axLogDef
+  :: CoAxiomRule
+
+axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon $
+              \x y -> Just $ num (x + y)
+
+axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon $
+              \x y -> Just $ num (x * y)
+
+axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon $
+              \x y -> Just $ num (x ^ y)
+
+axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon $
+              \x y -> Just $ bool (x <= y)
+
+axCmpNatDef   = mkBinAxiom "CmpNatDef" typeNatCmpTyCon
+              $ \x y -> Just $ ordering (compare x y)
+
+axCmpSymbolDef =
+  CoAxiomRule
+    { coaxrName      = fsLit "CmpSymbolDef"
+    , coaxrAsmpRoles = [Nominal, Nominal]
+    , coaxrRole      = Nominal
+    , coaxrProves    = \cs ->
+        do [Pair s1 s2, Pair t1 t2] <- return cs
+           s2' <- isStrLitTy s2
+           t2' <- isStrLitTy t2
+           return (mkTyConApp typeSymbolCmpTyCon [s1,t1] ===
+                   ordering (compare s2' t2')) }
+
+axAppendSymbolDef = CoAxiomRule
+    { coaxrName      = fsLit "AppendSymbolDef"
+    , coaxrAsmpRoles = [Nominal, Nominal]
+    , coaxrRole      = Nominal
+    , coaxrProves    = \cs ->
+        do [Pair s1 s2, Pair t1 t2] <- return cs
+           s2' <- isStrLitTy s2
+           t2' <- isStrLitTy t2
+           let z = mkStrLitTy (appendFS s2' t2')
+           return (mkTyConApp typeSymbolAppendTyCon [s1, t1] === z)
+    }
+
+axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon $
+              \x y -> fmap num (minus x y)
+
+axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon $
+              \x y -> do guard (y /= 0)
+                         return (num (div x y))
+
+axModDef = mkBinAxiom "ModDef" typeNatModTyCon $
+              \x y -> do guard (y /= 0)
+                         return (num (mod x y))
+
+axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon $
+              \x -> do (a,_) <- genLog x 2
+                       return (num a)
+
+axAdd0L     = mkAxiom1 "Add0L"    $ \(Pair s t) -> (num 0 .+. s) === t
+axAdd0R     = mkAxiom1 "Add0R"    $ \(Pair s t) -> (s .+. num 0) === t
+axSub0R     = mkAxiom1 "Sub0R"    $ \(Pair s t) -> (s .-. num 0) === t
+axMul0L     = mkAxiom1 "Mul0L"    $ \(Pair s _) -> (num 0 .*. s) === num 0
+axMul0R     = mkAxiom1 "Mul0R"    $ \(Pair s _) -> (s .*. num 0) === num 0
+axMul1L     = mkAxiom1 "Mul1L"    $ \(Pair s t) -> (num 1 .*. s) === t
+axMul1R     = mkAxiom1 "Mul1R"    $ \(Pair s t) -> (s .*. num 1) === t
+axDiv1      = mkAxiom1 "Div1"     $ \(Pair s t) -> (tDiv s (num 1) === t)
+axMod1      = mkAxiom1 "Mod1"     $ \(Pair s _) -> (tMod s (num 1) === num 0)
+                                    -- XXX: Shouldn't we check that _ is 0?
+axExp1L     = mkAxiom1 "Exp1L"    $ \(Pair s _) -> (num 1 .^. s) === num 1
+axExp0R     = mkAxiom1 "Exp0R"    $ \(Pair s _) -> (s .^. num 0) === num 1
+axExp1R     = mkAxiom1 "Exp1R"    $ \(Pair s t) -> (s .^. num 1) === t
+axLeqRefl   = mkAxiom1 "LeqRefl"  $ \(Pair s _) -> (s <== s) === bool True
+axCmpNatRefl    = mkAxiom1 "CmpNatRefl"
+                $ \(Pair s _) -> (cmpNat s s) === ordering EQ
+axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl"
+                $ \(Pair s _) -> (cmpSymbol s s) === ordering EQ
+axLeq0L     = mkAxiom1 "Leq0L"    $ \(Pair s _) -> (num 0 <== s) === bool True
+axAppendSymbol0R  = mkAxiom1 "Concat0R"
+            $ \(Pair s t) -> (mkStrLitTy nilFS `appendSymbol` s) === t
+axAppendSymbol0L  = mkAxiom1 "Concat0L"
+            $ \(Pair s t) -> (s `appendSymbol` mkStrLitTy nilFS) === t
+
+-- The list of built-in type family axioms that GHC uses.
+-- If you define new axioms, make sure to include them in this list.
+-- See Note [Adding built-in type families]
+typeNatCoAxiomRules :: Map.Map FastString CoAxiomRule
+typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x))
+  [ axAddDef
+  , axMulDef
+  , axExpDef
+  , axLeqDef
+  , axCmpNatDef
+  , axCmpSymbolDef
+  , axAppendSymbolDef
+  , axAdd0L
+  , axAdd0R
+  , axMul0L
+  , axMul0R
+  , axMul1L
+  , axMul1R
+  , axExp1L
+  , axExp0R
+  , axExp1R
+  , axLeqRefl
+  , axCmpNatRefl
+  , axCmpSymbolRefl
+  , axLeq0L
+  , axSubDef
+  , axSub0R
+  , axAppendSymbol0R
+  , axAppendSymbol0L
+  , axDivDef
+  , axDiv1
+  , axModDef
+  , axMod1
+  , axLogDef
+  ]
+
+
+
+{-------------------------------------------------------------------------------
+Various utilities for making axioms and types
+-------------------------------------------------------------------------------}
+
+(.+.) :: Type -> Type -> Type
+s .+. t = mkTyConApp typeNatAddTyCon [s,t]
+
+(.-.) :: Type -> Type -> Type
+s .-. t = mkTyConApp typeNatSubTyCon [s,t]
+
+(.*.) :: Type -> Type -> Type
+s .*. t = mkTyConApp typeNatMulTyCon [s,t]
+
+tDiv :: Type -> Type -> Type
+tDiv s t = mkTyConApp typeNatDivTyCon [s,t]
+
+tMod :: Type -> Type -> Type
+tMod s t = mkTyConApp typeNatModTyCon [s,t]
+
+(.^.) :: Type -> Type -> Type
+s .^. t = mkTyConApp typeNatExpTyCon [s,t]
+
+(<==) :: Type -> Type -> Type
+s <== t = mkTyConApp typeNatLeqTyCon [s,t]
+
+cmpNat :: Type -> Type -> Type
+cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t]
+
+cmpSymbol :: Type -> Type -> Type
+cmpSymbol s t = mkTyConApp typeSymbolCmpTyCon [s,t]
+
+appendSymbol :: Type -> Type -> Type
+appendSymbol s t = mkTyConApp typeSymbolAppendTyCon [s, t]
+
+(===) :: Type -> Type -> Pair Type
+x === y = Pair x y
+
+num :: Integer -> Type
+num = mkNumLitTy
+
+bool :: Bool -> Type
+bool b = if b then mkTyConApp promotedTrueDataCon []
+              else mkTyConApp promotedFalseDataCon []
+
+isBoolLitTy :: Type -> Maybe Bool
+isBoolLitTy tc =
+  do (tc,[]) <- splitTyConApp_maybe tc
+     case () of
+       _ | tc == promotedFalseDataCon -> return False
+         | tc == promotedTrueDataCon  -> return True
+         | otherwise                   -> Nothing
+
+orderingKind :: Kind
+orderingKind = mkTyConApp orderingTyCon []
+
+ordering :: Ordering -> Type
+ordering o =
+  case o of
+    LT -> mkTyConApp promotedLTDataCon []
+    EQ -> mkTyConApp promotedEQDataCon []
+    GT -> mkTyConApp promotedGTDataCon []
+
+isOrderingLitTy :: Type -> Maybe Ordering
+isOrderingLitTy tc =
+  do (tc1,[]) <- splitTyConApp_maybe tc
+     case () of
+       _ | tc1 == promotedLTDataCon -> return LT
+         | tc1 == promotedEQDataCon -> return EQ
+         | tc1 == promotedGTDataCon -> return GT
+         | otherwise                -> Nothing
+
+known :: (Integer -> Bool) -> TcType -> Bool
+known p x = case isNumLitTy x of
+              Just a  -> p a
+              Nothing -> False
+
+
+mkUnAxiom :: String -> TyCon -> (Integer -> Maybe Type) -> CoAxiomRule
+mkUnAxiom str tc f =
+  CoAxiomRule
+    { coaxrName      = fsLit str
+    , coaxrAsmpRoles = [Nominal]
+    , coaxrRole      = Nominal
+    , coaxrProves    = \cs ->
+        do [Pair s1 s2] <- return cs
+           s2' <- isNumLitTy s2
+           z   <- f s2'
+           return (mkTyConApp tc [s1] === z)
+    }
+
+
+
+-- For the definitional axioms
+mkBinAxiom :: String -> TyCon ->
+              (Integer -> Integer -> Maybe Type) -> CoAxiomRule
+mkBinAxiom str tc f =
+  CoAxiomRule
+    { coaxrName      = fsLit str
+    , coaxrAsmpRoles = [Nominal, Nominal]
+    , coaxrRole      = Nominal
+    , coaxrProves    = \cs ->
+        do [Pair s1 s2, Pair t1 t2] <- return cs
+           s2' <- isNumLitTy s2
+           t2' <- isNumLitTy t2
+           z   <- f s2' t2'
+           return (mkTyConApp tc [s1,t1] === z)
+    }
+
+
+
+mkAxiom1 :: String -> (TypeEqn -> TypeEqn) -> CoAxiomRule
+mkAxiom1 str f =
+  CoAxiomRule
+    { coaxrName      = fsLit str
+    , coaxrAsmpRoles = [Nominal]
+    , coaxrRole      = Nominal
+    , coaxrProves    = \case [eqn] -> Just (f eqn)
+                             _     -> Nothing
+    }
+
+
+{-------------------------------------------------------------------------------
+Evaluation
+-------------------------------------------------------------------------------}
+
+matchFamAdd :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamAdd [s,t]
+  | Just 0 <- mbX = Just (axAdd0L, [t], t)
+  | Just 0 <- mbY = Just (axAdd0R, [s], s)
+  | Just x <- mbX, Just y <- mbY =
+    Just (axAddDef, [s,t], num (x + y))
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamAdd _ = Nothing
+
+matchFamSub :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamSub [s,t]
+  | Just 0 <- mbY = Just (axSub0R, [s], s)
+  | Just x <- mbX, Just y <- mbY, Just z <- minus x y =
+    Just (axSubDef, [s,t], num z)
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamSub _ = Nothing
+
+matchFamMul :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamMul [s,t]
+  | Just 0 <- mbX = Just (axMul0L, [t], num 0)
+  | Just 0 <- mbY = Just (axMul0R, [s], num 0)
+  | Just 1 <- mbX = Just (axMul1L, [t], t)
+  | Just 1 <- mbY = Just (axMul1R, [s], s)
+  | Just x <- mbX, Just y <- mbY =
+    Just (axMulDef, [s,t], num (x * y))
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamMul _ = Nothing
+
+matchFamDiv :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamDiv [s,t]
+  | Just 1 <- mbY = Just (axDiv1, [s], s)
+  | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axDivDef, [s,t], num (div x y))
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamDiv _ = Nothing
+
+matchFamMod :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamMod [s,t]
+  | Just 1 <- mbY = Just (axMod1, [s], num 0)
+  | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axModDef, [s,t], num (mod x y))
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamMod _ = Nothing
+
+
+
+matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamExp [s,t]
+  | Just 0 <- mbY = Just (axExp0R, [s], num 1)
+  | Just 1 <- mbX = Just (axExp1L, [t], num 1)
+  | Just 1 <- mbY = Just (axExp1R, [s], s)
+  | Just x <- mbX, Just y <- mbY =
+    Just (axExpDef, [s,t], num (x ^ y))
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamExp _ = Nothing
+
+matchFamLog :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamLog [s]
+  | Just x <- mbX, Just (n,_) <- genLog x 2 = Just (axLogDef, [s], num n)
+  where mbX = isNumLitTy s
+matchFamLog _ = Nothing
+
+
+matchFamLeq :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamLeq [s,t]
+  | Just 0 <- mbX = Just (axLeq0L, [t], bool True)
+  | Just x <- mbX, Just y <- mbY =
+    Just (axLeqDef, [s,t], bool (x <= y))
+  | tcEqType s t  = Just (axLeqRefl, [s], bool True)
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamLeq _ = Nothing
+
+matchFamCmpNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamCmpNat [s,t]
+  | Just x <- mbX, Just y <- mbY =
+    Just (axCmpNatDef, [s,t], ordering (compare x y))
+  | tcEqType s t = Just (axCmpNatRefl, [s], ordering EQ)
+  where mbX = isNumLitTy s
+        mbY = isNumLitTy t
+matchFamCmpNat _ = Nothing
+
+matchFamCmpSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamCmpSymbol [s,t]
+  | Just x <- mbX, Just y <- mbY =
+    Just (axCmpSymbolDef, [s,t], ordering (compare x y))
+  | tcEqType s t = Just (axCmpSymbolRefl, [s], ordering EQ)
+  where mbX = isStrLitTy s
+        mbY = isStrLitTy t
+matchFamCmpSymbol _ = Nothing
+
+matchFamAppendSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)
+matchFamAppendSymbol [s,t]
+  | Just x <- mbX, nullFS x = Just (axAppendSymbol0R, [t], t)
+  | Just y <- mbY, nullFS y = Just (axAppendSymbol0L, [s], s)
+  | Just x <- mbX, Just y <- mbY =
+    Just (axAppendSymbolDef, [s,t], mkStrLitTy (appendFS x y))
+  where
+  mbX = isStrLitTy s
+  mbY = isStrLitTy t
+matchFamAppendSymbol _ = Nothing
+
+{-------------------------------------------------------------------------------
+Interact with axioms
+-------------------------------------------------------------------------------}
+
+interactTopAdd :: [Xi] -> Xi -> [Pair Type]
+interactTopAdd [s,t] r
+  | Just 0 <- mbZ = [ s === num 0, t === num 0 ]                          -- (s + t ~ 0) => (s ~ 0, t ~ 0)
+  | Just x <- mbX, Just z <- mbZ, Just y <- minus z x = [t === num y]     -- (5 + t ~ 8) => (t ~ 3)
+  | Just y <- mbY, Just z <- mbZ, Just x <- minus z y = [s === num x]     -- (s + 5 ~ 8) => (s ~ 3)
+  where
+  mbX = isNumLitTy s
+  mbY = isNumLitTy t
+  mbZ = isNumLitTy r
+interactTopAdd _ _ = []
+
+{-
+Note [Weakened interaction rule for subtraction]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A simpler interaction here might be:
+
+  `s - t ~ r` --> `t + r ~ s`
+
+This would enable us to reuse all the code for addition.
+Unfortunately, this works a little too well at the moment.
+Consider the following example:
+
+    0 - 5 ~ r --> 5 + r ~ 0 --> (5 = 0, r = 0)
+
+This (correctly) spots that the constraint cannot be solved.
+
+However, this may be a problem if the constraint did not
+need to be solved in the first place!  Consider the following example:
+
+f :: Proxy (If (5 <=? 0) (0 - 5) (5 - 0)) -> Proxy 5
+f = id
+
+Currently, GHC is strict while evaluating functions, so this does not
+work, because even though the `If` should evaluate to `5 - 0`, we
+also evaluate the "then" branch which generates the constraint `0 - 5 ~ r`,
+which fails.
+
+So, for the time being, we only add an improvement when the RHS is a constant,
+which happens to work OK for the moment, although clearly we need to do
+something more general.
+-}
+interactTopSub :: [Xi] -> Xi -> [Pair Type]
+interactTopSub [s,t] r
+  | Just z <- mbZ = [ s === (num z .+. t) ]         -- (s - t ~ 5) => (5 + t ~ s)
+  where
+  mbZ = isNumLitTy r
+interactTopSub _ _ = []
+
+
+
+
+
+interactTopMul :: [Xi] -> Xi -> [Pair Type]
+interactTopMul [s,t] r
+  | Just 1 <- mbZ = [ s === num 1, t === num 1 ]                        -- (s * t ~ 1)  => (s ~ 1, t ~ 1)
+  | Just x <- mbX, Just z <- mbZ, Just y <- divide z x = [t === num y]  -- (3 * t ~ 15) => (t ~ 5)
+  | Just y <- mbY, Just z <- mbZ, Just x <- divide z y = [s === num x]  -- (s * 3 ~ 15) => (s ~ 5)
+  where
+  mbX = isNumLitTy s
+  mbY = isNumLitTy t
+  mbZ = isNumLitTy r
+interactTopMul _ _ = []
+
+interactTopDiv :: [Xi] -> Xi -> [Pair Type]
+interactTopDiv _ _ = []   -- I can't think of anything...
+
+interactTopMod :: [Xi] -> Xi -> [Pair Type]
+interactTopMod _ _ = []   -- I can't think of anything...
+
+interactTopExp :: [Xi] -> Xi -> [Pair Type]
+interactTopExp [s,t] r
+  | Just 0 <- mbZ = [ s === num 0 ]                                       -- (s ^ t ~ 0) => (s ~ 0)
+  | Just x <- mbX, Just z <- mbZ, Just y <- logExact  z x = [t === num y] -- (2 ^ t ~ 8) => (t ~ 3)
+  | Just y <- mbY, Just z <- mbZ, Just x <- rootExact z y = [s === num x] -- (s ^ 2 ~ 9) => (s ~ 3)
+  where
+  mbX = isNumLitTy s
+  mbY = isNumLitTy t
+  mbZ = isNumLitTy r
+interactTopExp _ _ = []
+
+interactTopLog :: [Xi] -> Xi -> [Pair Type]
+interactTopLog _ _ = []   -- I can't think of anything...
+
+
+
+interactTopLeq :: [Xi] -> Xi -> [Pair Type]
+interactTopLeq [s,t] r
+  | Just 0 <- mbY, Just True <- mbZ = [ s === num 0 ]                     -- (s <= 0) => (s ~ 0)
+  where
+  mbY = isNumLitTy t
+  mbZ = isBoolLitTy r
+interactTopLeq _ _ = []
+
+interactTopCmpNat :: [Xi] -> Xi -> [Pair Type]
+interactTopCmpNat [s,t] r
+  | Just EQ <- isOrderingLitTy r = [ s === t ]
+interactTopCmpNat _ _ = []
+
+interactTopCmpSymbol :: [Xi] -> Xi -> [Pair Type]
+interactTopCmpSymbol [s,t] r
+  | Just EQ <- isOrderingLitTy r = [ s === t ]
+interactTopCmpSymbol _ _ = []
+
+interactTopAppendSymbol :: [Xi] -> Xi -> [Pair Type]
+interactTopAppendSymbol [s,t] r
+  -- (AppendSymbol a b ~ "") => (a ~ "", b ~ "")
+  | Just z <- mbZ, nullFS z =
+    [s === mkStrLitTy nilFS, t === mkStrLitTy nilFS ]
+
+  -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar")
+  | Just x <- fmap unpackFS mbX, Just z <- fmap unpackFS mbZ, x `isPrefixOf` z =
+    [ t === mkStrLitTy (mkFastString $ drop (length x) z) ]
+
+  -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo")
+  | Just y <- fmap unpackFS mbY, Just z <- fmap unpackFS mbZ, y `isSuffixOf` z =
+    [ t === mkStrLitTy (mkFastString $ take (length z - length y) z) ]
+
+  where
+  mbX = isStrLitTy s
+  mbY = isStrLitTy t
+  mbZ = isStrLitTy r
+
+interactTopAppendSymbol _ _ = []
+
+{-------------------------------------------------------------------------------
+Interaction with inerts
+-------------------------------------------------------------------------------}
+
+interactInertAdd :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertAdd [x1,y1] z1 [x2,y2] z2
+  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]
+  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]
+  where sameZ = tcEqType z1 z2
+interactInertAdd _ _ _ _ = []
+
+interactInertSub :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertSub [x1,y1] z1 [x2,y2] z2
+  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]
+  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]
+  where sameZ = tcEqType z1 z2
+interactInertSub _ _ _ _ = []
+
+interactInertMul :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertMul [x1,y1] z1 [x2,y2] z2
+  | sameZ && known (/= 0) x1 && tcEqType x1 x2 = [ y1 === y2 ]
+  | sameZ && known (/= 0) y1 && tcEqType y1 y2 = [ x1 === x2 ]
+  where sameZ   = tcEqType z1 z2
+
+interactInertMul _ _ _ _ = []
+
+interactInertDiv :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertDiv _ _ _ _ = []
+
+interactInertMod :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertMod _ _ _ _ = []
+
+interactInertExp :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertExp [x1,y1] z1 [x2,y2] z2
+  | sameZ && known (> 1) x1 && tcEqType x1 x2 = [ y1 === y2 ]
+  | sameZ && known (> 0) y1 && tcEqType y1 y2 = [ x1 === x2 ]
+  where sameZ = tcEqType z1 z2
+
+interactInertExp _ _ _ _ = []
+
+interactInertLog :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertLog _ _ _ _ = []
+
+
+interactInertLeq :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertLeq [x1,y1] z1 [x2,y2] z2
+  | bothTrue && tcEqType x1 y2 && tcEqType y1 x2 = [ x1 === y1 ]
+  | bothTrue && tcEqType y1 x2                 = [ (x1 <== y2) === bool True ]
+  | bothTrue && tcEqType y2 x1                 = [ (x2 <== y1) === bool True ]
+  where bothTrue = isJust $ do True <- isBoolLitTy z1
+                               True <- isBoolLitTy z2
+                               return ()
+
+interactInertLeq _ _ _ _ = []
+
+
+interactInertAppendSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]
+interactInertAppendSymbol [x1,y1] z1 [x2,y2] z2
+  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]
+  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]
+  where sameZ = tcEqType z1 z2
+interactInertAppendSymbol _ _ _ _ = []
+
+
+
+{- -----------------------------------------------------------------------------
+These inverse functions are used for simplifying propositions using
+concrete natural numbers.
+----------------------------------------------------------------------------- -}
+
+-- | Subtract two natural numbers.
+minus :: Integer -> Integer -> Maybe Integer
+minus x y = if x >= y then Just (x - y) else Nothing
+
+-- | Compute the exact logarithm of a natural number.
+-- The logarithm base is the second argument.
+logExact :: Integer -> Integer -> Maybe Integer
+logExact x y = do (z,True) <- genLog x y
+                  return z
+
+
+-- | Divide two natural numbers.
+divide :: Integer -> Integer -> Maybe Integer
+divide _ 0  = Nothing
+divide x y  = case divMod x y of
+                (a,0) -> Just a
+                _     -> Nothing
+
+-- | Compute the exact root of a natural number.
+-- The second argument specifies which root we are computing.
+rootExact :: Integer -> Integer -> Maybe Integer
+rootExact x y = do (z,True) <- genRoot x y
+                   return z
+
+
+
+{- | Compute the n-th root of a natural number, rounded down to
+the closest natural number.  The boolean indicates if the result
+is exact (i.e., True means no rounding was done, False means rounded down).
+The second argument specifies which root we are computing. -}
+genRoot :: Integer -> Integer -> Maybe (Integer, Bool)
+genRoot _  0    = Nothing
+genRoot x0 1    = Just (x0, True)
+genRoot x0 root = Just (search 0 (x0+1))
+  where
+  search from to = let x = from + div (to - from) 2
+                       a = x ^ root
+                   in case compare a x0 of
+                        EQ              -> (x, True)
+                        LT | x /= from  -> search x to
+                           | otherwise  -> (from, False)
+                        GT | x /= to    -> search from x
+                           | otherwise  -> (from, False)
+
+{- | Compute the logarithm of a number in the given base, rounded down to the
+closest integer.  The boolean indicates if we the result is exact
+(i.e., True means no rounding happened, False means we rounded down).
+The logarithm base is the second argument. -}
+genLog :: Integer -> Integer -> Maybe (Integer, Bool)
+genLog x 0    = if x == 1 then Just (0, True) else Nothing
+genLog _ 1    = Nothing
+genLog 0 _    = Nothing
+genLog x base = Just (exactLoop 0 x)
+  where
+  exactLoop s i
+    | i == 1     = (s,True)
+    | i < base   = (s,False)
+    | otherwise  =
+        let s1 = s + 1
+        in s1 `seq` case divMod i base of
+                      (j,r)
+                        | r == 0    -> exactLoop s1 j
+                        | otherwise -> (underLoop s1 j, False)
+
+  underLoop s i
+    | i < base  = s
+    | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base)
diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcTypeable.hs
@@ -0,0 +1,714 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1999
+-}
+
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module TcTypeable(mkTypeableBinds) where
+
+
+import GhcPrelude
+
+import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) )
+import TcBinds( addTypecheckedBinds )
+import IfaceEnv( newGlobalBinder )
+import TyCoRep( Type(..), TyLit(..) )
+import TcEnv
+import TcEvidence ( mkWpTyApps )
+import TcRnMonad
+import HscTypes ( lookupId )
+import PrelNames
+import TysPrim ( primTyCons )
+import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon
+                  , vecCountTyCon, vecElemTyCon
+                  , nilDataCon, consDataCon )
+import Name
+import Id
+import Type
+import TyCon
+import DataCon
+import Module
+import HsSyn
+import DynFlags
+import Bag
+import Var ( VarBndr(..) )
+import CoreMap
+import Constants
+import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)
+import Outputable
+import FastString ( FastString, mkFastString, fsLit )
+
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Class (lift)
+import Data.Maybe ( isJust )
+import Data.Word( Word64 )
+
+{- Note [Grand plan for Typeable]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The overall plan is this:
+
+1. Generate a binding for each module p:M
+   (done in TcTypeable by mkModIdBindings)
+       M.$trModule :: GHC.Types.Module
+       M.$trModule = Module "p" "M"
+   ("tr" is short for "type representation"; see GHC.Types)
+
+   We might want to add the filename too.
+   This can be used for the lightweight stack-tracing stuff too
+
+   Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv
+
+2. Generate a binding for every data type declaration T in module M,
+       M.$tcT :: GHC.Types.TyCon
+       M.$tcT = TyCon ...fingerprint info...
+                      $trModule
+                      "T"
+                      0#
+                      kind_rep
+
+   Here 0# is the number of arguments expected by the tycon to fully determine
+   its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a
+   recipe for computing the kind of an instantiation of the tycon (see
+   Note [Representing TyCon kinds: KindRep] later in this file for details).
+
+   We define (in TyCon)
+
+        type TyConRepName = Name
+
+   to use for these M.$tcT "tycon rep names". Note that these must be
+   treated as "never exported" names by Backpack (see
+   Note [Handling never-exported TyThings under Backpack]). Consequently
+   they get slightly special treatment in RnModIface.rnIfaceDecl.
+
+3. Record the TyConRepName in T's TyCon, including for promoted
+   data and type constructors, and kinds like * and #.
+
+   The TyConRepName is not an "implicit Id".  It's more like a record
+   selector: the TyCon knows its name but you have to go to the
+   interface file to find its type, value, etc
+
+4. Solve Typeable constraints.  This is done by a custom Typeable solver,
+   currently in TcInteract, that use M.$tcT so solve (Typeable T).
+
+There are many wrinkles:
+
+* The timing of when we produce this bindings is rather important: they must be
+  defined after the rest of the module has been typechecked since we need to be
+  able to lookup Module and TyCon in the type environment and we may be
+  currently compiling GHC.Types (where they are defined).
+
+* GHC.Prim doesn't have any associated object code, so we need to put the
+  representations for types defined in this module elsewhere. We chose this
+  place to be GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for
+  injecting the bindings for the GHC.Prim representions when compiling
+  GHC.Types.
+
+* TyCon.tyConRepModOcc is responsible for determining where to find
+  the representation binding for a given type. This is where we handle
+  the special case for GHC.Prim.
+
+* To save space and reduce dependencies, we need use quite low-level
+  representations for TyCon and Module.  See GHC.Types
+  Note [Runtime representation of modules and tycons]
+
+* The KindReps can unfortunately get quite large. Moreover, the simplifier will
+  float out various pieces of them, resulting in numerous top-level bindings.
+  Consequently we mark the KindRep bindings as noinline, ensuring that the
+  float-outs don't make it into the interface file. This is important since
+  there is generally little benefit to inlining KindReps and they would
+  otherwise strongly affect compiler performance.
+
+* In general there are lots of things of kind *, * -> *, and * -> * -> *. To
+  reduce the number of bindings we need to produce, we generate their KindReps
+  once in GHC.Types. These are referred to as "built-in" KindReps below.
+
+* Even though KindReps aren't inlined, this scheme still has more of an effect on
+  compilation time than I'd like. This is especially true in the case of
+  families of type constructors (e.g. tuples and unboxed sums). The problem is
+  particularly bad in the case of sums, since each arity-N tycon brings with it
+  N promoted datacons, each with a KindRep whose size also scales with N.
+  Consequently we currently simply don't allow sums to be Typeable.
+
+  In general we might consider moving some or all of this generation logic back
+  to the solver since the performance hit we take in doing this at
+  type-definition time is non-trivial and Typeable isn't very widely used. This
+  is discussed in #13261.
+
+-}
+
+-- | Generate the Typeable bindings for a module. This is the only
+-- entry-point of this module and is invoked by the typechecker driver in
+-- 'tcRnSrcDecls'.
+--
+-- See Note [Grand plan for Typeable] in TcTypeable.
+mkTypeableBinds :: TcM TcGblEnv
+mkTypeableBinds
+  = do { -- Create a binding for $trModule.
+         -- Do this before processing any data type declarations,
+         -- which need tcg_tr_module to be initialised
+       ; tcg_env <- mkModIdBindings
+         -- Now we can generate the TyCon representations...
+         -- First we handle the primitive TyCons if we are compiling GHC.Types
+       ; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos
+
+         -- Then we produce bindings for the user-defined types in this module.
+       ; setGblEnv tcg_env $
+    do { mod <- getModule
+       ; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env)
+             mod_id = case tcg_tr_module tcg_env of  -- Should be set by now
+                        Just mod_id -> mod_id
+                        Nothing     -> pprPanic "tcMkTypeableBinds" (ppr tycons)
+       ; traceTc "mkTypeableBinds" (ppr tycons)
+       ; this_mod_todos <- todoForTyCons mod mod_id tycons
+       ; mkTypeRepTodoBinds (this_mod_todos : prim_todos)
+       } }
+  where
+    needs_typeable_binds tc
+      | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon]
+      = False
+      | otherwise =
+          isAlgTyCon tc
+       || isDataFamilyTyCon tc
+       || isClassTyCon tc
+
+
+{- *********************************************************************
+*                                                                      *
+            Building top-level binding for $trModule
+*                                                                      *
+********************************************************************* -}
+
+mkModIdBindings :: TcM TcGblEnv
+mkModIdBindings
+  = do { mod <- getModule
+       ; loc <- getSrcSpanM
+       ; mod_nm        <- newGlobalBinder mod (mkVarOcc "$trModule") loc
+       ; trModuleTyCon <- tcLookupTyCon trModuleTyConName
+       ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon [])
+       ; mod_bind      <- mkVarBind mod_id <$> mkModIdRHS mod
+
+       ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv
+       ; return (tcg_env { tcg_tr_module = Just mod_id }
+                 `addTypecheckedBinds` [unitBag mod_bind]) }
+
+mkModIdRHS :: Module -> TcM (LHsExpr GhcTc)
+mkModIdRHS mod
+  = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName
+       ; trNameLit <- mkTrNameLit
+       ; return $ nlHsDataCon trModuleDataCon
+                  `nlHsApp` trNameLit (unitIdFS (moduleUnitId mod))
+                  `nlHsApp` trNameLit (moduleNameFS (moduleName mod))
+       }
+
+{- *********************************************************************
+*                                                                      *
+                Building type-representation bindings
+*                                                                      *
+********************************************************************* -}
+
+-- | Information we need about a 'TyCon' to generate its representation. We
+-- carry the 'Id' in order to share it between the generation of the @TyCon@ and
+-- @KindRep@ bindings.
+data TypeableTyCon
+    = TypeableTyCon
+      { tycon        :: !TyCon
+      , tycon_rep_id :: !Id
+      }
+
+-- | A group of 'TyCon's in need of type-rep bindings.
+data TypeRepTodo
+    = TypeRepTodo
+      { mod_rep_expr    :: LHsExpr GhcTc    -- ^ Module's typerep binding
+      , pkg_fingerprint :: !Fingerprint     -- ^ Package name fingerprint
+      , mod_fingerprint :: !Fingerprint     -- ^ Module name fingerprint
+      , todo_tycons     :: [TypeableTyCon]
+        -- ^ The 'TyCon's in need of bindings kinds
+      }
+    | ExportedKindRepsTodo [(Kind, Id)]
+      -- ^ Build exported 'KindRep' bindings for the given set of kinds.
+
+todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo
+todoForTyCons mod mod_id tycons = do
+    trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName
+    let mk_rep_id :: TyConRepName -> Id
+        mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy
+
+    let typeable_tycons :: [TypeableTyCon]
+        typeable_tycons =
+            [ TypeableTyCon { tycon = tc''
+                            , tycon_rep_id = mk_rep_id rep_name
+                            }
+            | tc     <- tycons
+            , tc'    <- tc : tyConATs tc
+              -- We need type representations for any associated types
+            , let promoted = map promoteDataCon (tyConDataCons tc')
+            , tc''   <- tc' : promoted
+              -- Don't make bindings for data-family instance tycons.
+              -- Do, however, make them for their promoted datacon (see #13915).
+            , not $ isFamInstTyCon tc''
+            , Just rep_name <- pure $ tyConRepName_maybe tc''
+            , typeIsTypeable $ dropForAlls $ tyConKind tc''
+            ]
+    return TypeRepTodo { mod_rep_expr    = nlHsVar mod_id
+                       , pkg_fingerprint = pkg_fpr
+                       , mod_fingerprint = mod_fpr
+                       , todo_tycons     = typeable_tycons
+                       }
+  where
+    mod_fpr = fingerprintString $ moduleNameString $ moduleName mod
+    pkg_fpr = fingerprintString $ unitIdString $ moduleUnitId mod
+
+todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo
+todoForExportedKindReps kinds = do
+    trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName
+    let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy)
+    return $ ExportedKindRepsTodo $ map mkId kinds
+
+-- | Generate TyCon bindings for a set of type constructors
+mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
+mkTypeRepTodoBinds [] = getGblEnv
+mkTypeRepTodoBinds todos
+  = do { stuff <- collect_stuff
+
+         -- First extend the type environment with all of the bindings
+         -- which we are going to produce since we may need to refer to them
+         -- while generating kind representations (namely, when we want to
+         -- represent a TyConApp in a kind, we must be able to look up the
+         -- TyCon associated with the applied type constructor).
+       ; let produced_bndrs :: [Id]
+             produced_bndrs = [ tycon_rep_id
+                              | todo@(TypeRepTodo{}) <- todos
+                              , TypeableTyCon {..} <- todo_tycons todo
+                              ] ++
+                              [ rep_id
+                              | ExportedKindRepsTodo kinds <- todos
+                              , (_, rep_id) <- kinds
+                              ]
+       ; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv
+
+       ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc]
+             mk_binds todo@(TypeRepTodo {}) =
+                 mapM (mkTyConRepBinds stuff todo) (todo_tycons todo)
+             mk_binds (ExportedKindRepsTodo kinds) =
+                 mkExportedKindReps stuff kinds >> return []
+
+       ; (gbl_env, binds) <- setGblEnv gbl_env
+                             $ runKindRepM (mapM mk_binds todos)
+       ; return $ gbl_env `addTypecheckedBinds` concat binds }
+
+-- | Generate bindings for the type representation of a wired-in 'TyCon's
+-- defined by the virtual "GHC.Prim" module. This is where we inject the
+-- representation bindings for these primitive types into "GHC.Types"
+--
+-- See Note [Grand plan for Typeable] in this module.
+mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo])
+mkPrimTypeableTodos
+  = do { mod <- getModule
+       ; if mod == gHC_TYPES
+           then do { -- Build Module binding for GHC.Prim
+                     trModuleTyCon <- tcLookupTyCon trModuleTyConName
+                   ; let ghc_prim_module_id =
+                             mkExportedVanillaId trGhcPrimModuleName
+                                                 (mkTyConTy trModuleTyCon)
+
+                   ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id
+                                             <$> mkModIdRHS gHC_PRIM
+
+                     -- Extend our environment with above
+                   ; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id]
+                                                     getGblEnv
+                   ; let gbl_env' = gbl_env `addTypecheckedBinds`
+                                    [unitBag ghc_prim_module_bind]
+
+                     -- Build TypeRepTodos for built-in KindReps
+                   ; todo1 <- todoForExportedKindReps builtInKindReps
+                     -- Build TypeRepTodos for types in GHC.Prim
+                   ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id
+                                            ghcPrimTypeableTyCons
+                   ; return ( gbl_env' , [todo1, todo2])
+                   }
+           else do gbl_env <- getGblEnv
+                   return (gbl_env, [])
+       }
+
+-- | This is the list of primitive 'TyCon's for which we must generate bindings
+-- in "GHC.Types". This should include all types defined in "GHC.Prim".
+--
+-- The majority of the types we need here are contained in 'primTyCons'.
+-- However, not all of them: in particular unboxed tuples are absent since we
+-- don't want to include them in the original name cache. See
+-- Note [Built-in syntax and the OrigNameCache] in IfaceEnv for more.
+ghcPrimTypeableTyCons :: [TyCon]
+ghcPrimTypeableTyCons = concat
+    [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon, funTyCon ]
+    , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE]
+    , map sumTyCon [2..mAX_SUM_SIZE]
+    , primTyCons
+    ]
+
+data TypeableStuff
+    = Stuff { dflags         :: DynFlags
+            , trTyConDataCon :: DataCon         -- ^ of @TyCon@
+            , trNameLit      :: FastString -> LHsExpr GhcTc
+                                                -- ^ To construct @TrName@s
+              -- The various TyCon and DataCons of KindRep
+            , kindRepTyCon           :: TyCon
+            , kindRepTyConAppDataCon :: DataCon
+            , kindRepVarDataCon      :: DataCon
+            , kindRepAppDataCon      :: DataCon
+            , kindRepFunDataCon      :: DataCon
+            , kindRepTYPEDataCon     :: DataCon
+            , kindRepTypeLitSDataCon :: DataCon
+            , typeLitSymbolDataCon   :: DataCon
+            , typeLitNatDataCon      :: DataCon
+            }
+
+-- | Collect various tidbits which we'll need to generate TyCon representations.
+collect_stuff :: TcM TypeableStuff
+collect_stuff = do
+    dflags <- getDynFlags
+    trTyConDataCon         <- tcLookupDataCon trTyConDataConName
+    kindRepTyCon           <- tcLookupTyCon   kindRepTyConName
+    kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName
+    kindRepVarDataCon      <- tcLookupDataCon kindRepVarDataConName
+    kindRepAppDataCon      <- tcLookupDataCon kindRepAppDataConName
+    kindRepFunDataCon      <- tcLookupDataCon kindRepFunDataConName
+    kindRepTYPEDataCon     <- tcLookupDataCon kindRepTYPEDataConName
+    kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName
+    typeLitSymbolDataCon   <- tcLookupDataCon typeLitSymbolDataConName
+    typeLitNatDataCon      <- tcLookupDataCon typeLitNatDataConName
+    trNameLit              <- mkTrNameLit
+    return Stuff {..}
+
+-- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we
+-- can save the work of repeating lookups when constructing many TyCon
+-- representations.
+mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc)
+mkTrNameLit = do
+    trNameSDataCon <- tcLookupDataCon trNameSDataConName
+    let trNameLit :: FastString -> LHsExpr GhcTc
+        trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon
+                       `nlHsApp` nlHsLit (mkHsStringPrimLit fs)
+    return trNameLit
+
+-- | Make Typeable bindings for the given 'TyCon'.
+mkTyConRepBinds :: TypeableStuff -> TypeRepTodo
+                -> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
+mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..})
+  = do -- Make a KindRep
+       let (bndrs, kind) = splitForAllVarBndrs (tyConKind tycon)
+       liftTc $ traceTc "mkTyConKindRepBinds"
+                        (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind)
+       let ctx = mkDeBruijnContext (map binderVar bndrs)
+       kind_rep <- getKindRep stuff ctx kind
+
+       -- Make the TyCon binding
+       let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep
+           tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs
+       return $ unitBag tycon_rep_bind
+
+-- | Here is where we define the set of Typeable types. These exclude type
+-- families and polytypes.
+tyConIsTypeable :: TyCon -> Bool
+tyConIsTypeable tc =
+       isJust (tyConRepName_maybe tc)
+    && typeIsTypeable (dropForAlls $ tyConKind tc)
+      -- Ensure that the kind of the TyCon, with its initial foralls removed,
+      -- is representable (e.g. has no higher-rank polymorphism or type
+      -- synonyms).
+
+-- | Is a particular 'Type' representable by @Typeable@? Here we look for
+-- polytypes and types containing casts (which may be, for instance, a type
+-- family).
+typeIsTypeable :: Type -> Bool
+-- We handle types of the form (TYPE rep) specifically to avoid
+-- looping on (tyConIsTypeable RuntimeRep)
+typeIsTypeable ty
+  | Just ty' <- coreView ty         = typeIsTypeable ty'
+typeIsTypeable ty
+  | isJust (kindRep_maybe ty)       = True
+typeIsTypeable (TyVarTy _)          = True
+typeIsTypeable (AppTy a b)          = typeIsTypeable a && typeIsTypeable b
+typeIsTypeable (FunTy a b)          = typeIsTypeable a && typeIsTypeable b
+typeIsTypeable (TyConApp tc args)   = tyConIsTypeable tc
+                                   && all typeIsTypeable args
+typeIsTypeable (ForAllTy{})         = False
+typeIsTypeable (LitTy _)            = True
+typeIsTypeable (CastTy{})           = False
+typeIsTypeable (CoercionTy{})       = False
+
+-- | Maps kinds to 'KindRep' bindings. This binding may either be defined in
+-- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing')
+-- or a binding which we generated in the current module (in which case it will
+-- be 'Just' the RHS of the binding).
+type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc))
+
+-- | A monad within which we will generate 'KindRep's. Here we keep an
+-- environment containing 'KindRep's which we've already generated so we can
+-- re-use them opportunistically.
+newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a }
+                   deriving (Functor, Applicative, Monad)
+
+liftTc :: TcRn a -> KindRepM a
+liftTc = KindRepM . lift
+
+-- | We generate @KindRep@s for a few common kinds in @GHC.Types@ so that they
+-- can be reused across modules.
+builtInKindReps :: [(Kind, Name)]
+builtInKindReps =
+    [ (star, starKindRepName)
+    , (mkFunTy star star, starArrStarKindRepName)
+    , (mkFunTys [star, star] star, starArrStarArrStarKindRepName)
+    ]
+  where
+    star = liftedTypeKind
+
+initialKindRepEnv :: TcRn KindRepEnv
+initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps
+  where
+    add_kind_rep acc (k,n) = do
+        id <- tcLookupId n
+        return $! extendTypeMap acc k (id, Nothing)
+
+-- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's.
+mkExportedKindReps :: TypeableStuff
+                   -> [(Kind, Id)]  -- ^ the kinds to generate bindings for
+                   -> KindRepM ()
+mkExportedKindReps stuff@(Stuff {..}) = mapM_ kindrep_binding
+  where
+    empty_scope = mkDeBruijnContext []
+
+    kindrep_binding :: (Kind, Id) -> KindRepM ()
+    kindrep_binding (kind, rep_bndr) = do
+        -- We build the binding manually here instead of using mkKindRepRhs
+        -- since the latter would find the built-in 'KindRep's in the
+        -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv').
+        rhs <- mkKindRepRhs stuff empty_scope kind
+        addKindRepBind empty_scope kind rep_bndr rhs
+
+addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM ()
+addKindRepBind in_scope k bndr rhs =
+    KindRepM $ modify' $
+    \env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs)
+
+-- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking
+-- environment.
+runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a)
+runKindRepM (KindRepM action) = do
+    kindRepEnv <- initialKindRepEnv
+    (res, reps_env) <- runStateT action kindRepEnv
+    let rep_binds = foldTypeMap to_bind_pair [] reps_env
+        to_bind_pair (bndr, Just rhs) rest = (bndr, rhs) : rest
+        to_bind_pair (_, Nothing) rest = rest
+    tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv
+    let binds = map (uncurry mkVarBind) rep_binds
+        tcg_env' = tcg_env `addTypecheckedBinds` [listToBag binds]
+    return (tcg_env', res)
+
+-- | Produce or find a 'KindRep' for the given kind.
+getKindRep :: TypeableStuff -> CmEnv  -- ^ in-scope kind variables
+           -> Kind   -- ^ the kind we want a 'KindRep' for
+           -> KindRepM (LHsExpr GhcTc)
+getKindRep stuff@(Stuff {..}) in_scope = go
+  where
+    go :: Kind -> KindRepM (LHsExpr GhcTc)
+    go = KindRepM . StateT . go'
+
+    go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)
+    go' k env
+        -- Look through type synonyms
+      | Just k' <- tcView k = go' k' env
+
+        -- We've already generated the needed KindRep
+      | Just (id, _) <- lookupTypeMapWithScope env in_scope k
+      = return (nlHsVar id, env)
+
+        -- We need to construct a new KindRep binding
+      | otherwise
+      = do -- Place a NOINLINE pragma on KindReps since they tend to be quite
+           -- large and bloat interface files.
+           rep_bndr <- (`setInlinePragma` neverInlinePragma)
+                   <$> newSysLocalId (fsLit "$krep") (mkTyConTy kindRepTyCon)
+
+           -- do we need to tie a knot here?
+           flip runStateT env $ unKindRepM $ do
+               rhs <- mkKindRepRhs stuff in_scope k
+               addKindRepBind in_scope k rep_bndr rhs
+               return $ nlHsVar rep_bndr
+
+-- | Construct the right-hand-side of the 'KindRep' for the given 'Kind' and
+-- in-scope kind variable set.
+mkKindRepRhs :: TypeableStuff
+             -> CmEnv       -- ^ in-scope kind variables
+             -> Kind        -- ^ the kind we want a 'KindRep' for
+             -> KindRepM (LHsExpr GhcTc) -- ^ RHS expression
+mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep
+  where
+    new_kind_rep k
+        -- We handle (TYPE LiftedRep) etc separately to make it
+        -- clear to consumers (e.g. serializers) that there is
+        -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep)
+      | not (tcIsConstraintKind k)    -- Typeable respects the Constraint/* distinction
+                                      -- so do not follow the special case here
+      , Just arg <- kindRep_maybe k
+      , Just (tc, []) <- splitTyConApp_maybe arg
+      , Just dc <- isPromotedDataCon_maybe tc
+      = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc
+
+    new_kind_rep (TyVarTy v)
+      | Just idx <- lookupCME in_scope v
+      = return $ nlHsDataCon kindRepVarDataCon
+                 `nlHsApp` nlHsIntLit (fromIntegral idx)
+      | otherwise
+      = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v)
+
+    new_kind_rep (AppTy t1 t2)
+      = do rep1 <- getKindRep stuff in_scope t1
+           rep2 <- getKindRep stuff in_scope t2
+           return $ nlHsDataCon kindRepAppDataCon
+                    `nlHsApp` rep1 `nlHsApp` rep2
+
+    new_kind_rep k@(TyConApp tc tys)
+      | Just rep_name <- tyConRepName_maybe tc
+      = do rep_id <- liftTc $ lookupId rep_name
+           tys' <- mapM (getKindRep stuff in_scope) tys
+           return $ nlHsDataCon kindRepTyConAppDataCon
+                    `nlHsApp` nlHsVar rep_id
+                    `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys'
+      | otherwise
+      = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k)
+
+    new_kind_rep (ForAllTy (Bndr var _) ty)
+      = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty)
+
+    new_kind_rep (FunTy t1 t2)
+      = do rep1 <- getKindRep stuff in_scope t1
+           rep2 <- getKindRep stuff in_scope t2
+           return $ nlHsDataCon kindRepFunDataCon
+                    `nlHsApp` rep1 `nlHsApp` rep2
+
+    new_kind_rep (LitTy (NumTyLit n))
+      = return $ nlHsDataCon kindRepTypeLitSDataCon
+                 `nlHsApp` nlHsDataCon typeLitNatDataCon
+                 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n)
+
+    new_kind_rep (LitTy (StrTyLit s))
+      = return $ nlHsDataCon kindRepTypeLitSDataCon
+                 `nlHsApp` nlHsDataCon typeLitSymbolDataCon
+                 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s)
+
+    new_kind_rep (CastTy ty co)
+      = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co)
+
+    new_kind_rep (CoercionTy co)
+      = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co)
+
+-- | Produce the right-hand-side of a @TyCon@ representation.
+mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo
+                   -> TyCon      -- ^ the 'TyCon' we are producing a binding for
+                   -> LHsExpr GhcTc -- ^ its 'KindRep'
+                   -> LHsExpr GhcTc
+mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep
+  =           nlHsDataCon trTyConDataCon
+    `nlHsApp` nlHsLit (word64 dflags high)
+    `nlHsApp` nlHsLit (word64 dflags low)
+    `nlHsApp` mod_rep_expr todo
+    `nlHsApp` trNameLit (mkFastString tycon_str)
+    `nlHsApp` nlHsLit (int n_kind_vars)
+    `nlHsApp` kind_rep
+  where
+    n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon)
+    tycon_str = add_tick (occNameString (getOccName tycon))
+    add_tick s | isPromotedDataCon tycon = '\'' : s
+               | otherwise               = s
+
+    -- This must match the computation done in
+    -- Data.Typeable.Internal.mkTyConFingerprint.
+    Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo
+                                                   , mod_fingerprint todo
+                                                   , fingerprintString tycon_str
+                                                   ]
+
+    int :: Int -> HsLit GhcTc
+    int n = HsIntPrim (SourceText $ show n) (toInteger n)
+
+word64 :: DynFlags -> Word64 -> HsLit GhcTc
+word64 dflags n
+  | wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n)
+  | otherwise             = HsWordPrim   NoSourceText (toInteger n)
+
+{-
+Note [Representing TyCon kinds: KindRep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+One of the operations supported by Typeable is typeRepKind,
+
+    typeRepKind :: TypeRep (a :: k) -> TypeRep k
+
+Implementing this is a bit tricky for poly-kinded types like
+
+    data Proxy (a :: k) :: Type
+    -- Proxy :: forall k. k -> Type
+
+The TypeRep encoding of `Proxy Type Int` looks like this:
+
+    $tcProxy :: GHC.Types.TyCon
+    $trInt   :: TypeRep Int
+    TrType   :: TypeRep Type
+
+    $trProxyType :: TypeRep (Proxy Type :: Type -> Type)
+    $trProxyType = TrTyCon $tcProxy
+                           [TrType]  -- kind variable instantiation
+                           (tyConKind $tcProxy [TrType]) -- The TypeRep of
+                                                         -- Type -> Type
+
+    $trProxy :: TypeRep (Proxy Type Int)
+    $trProxy = TrApp $trProxyType $trInt TrType
+
+    $tkProxy :: GHC.Types.KindRep
+    $tkProxy = KindRepFun (KindRepVar 0)
+                          (KindRepTyConApp (KindRepTYPE LiftedRep) [])
+
+Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent
+polymorphic types.  So instead
+
+ * $trProxyType uses 'TrTyCon' to apply Proxy to (the representations)
+   of all its kind arguments. We can't represent a tycon that is
+   applied to only some of its kind arguments.
+
+ * In $tcProxy, the GHC.Types.TyCon structure for Proxy, we store a
+   GHC.Types.KindRep, which represents the polymorphic kind of Proxy
+       Proxy :: forall k. k->Type
+
+ * A KindRep is just a recipe that we can instantiate with the
+   argument kinds, using Data.Typeable.Internal.tyConKind and
+   store in the relevant 'TypeRep' constructor.
+
+   Data.Typeable.Internal.typeRepKind looks up the stored kinds.
+
+ * In a KindRep, the kind variables are represented by 0-indexed
+   de Bruijn numbers:
+
+    type KindBndr = Int   -- de Bruijn index
+
+    data KindRep = KindRepTyConApp TyCon [KindRep]
+                 | KindRepVar !KindBndr
+                 | KindRepApp KindRep KindRep
+                 | KindRepFun KindRep KindRep
+                 ...
+-}
+
+mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc
+mkList ty = foldr consApp (nilExpr ty)
+  where
+    cons = consExpr ty
+    consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc
+    consApp x xs = cons `nlHsApp` x `nlHsApp` xs
+
+    nilExpr :: Type -> LHsExpr GhcTc
+    nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon)
+
+    consExpr :: Type -> LHsExpr GhcTc
+    consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon)
diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcUnify.hs
@@ -0,0 +1,2238 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+
+
+Type subsumption and unification
+-}
+
+{-# LANGUAGE CPP, MultiWayIf, TupleSections, ScopedTypeVariables #-}
+
+module TcUnify (
+  -- Full-blown subsumption
+  tcWrapResult, tcWrapResultO, tcSkolemise, tcSkolemiseET,
+  tcSubTypeHR, tcSubTypeO, tcSubType_NC, tcSubTypeDS,
+  tcSubTypeDS_NC_O, tcSubTypeET,
+  checkConstraints, checkTvConstraints,
+  buildImplicationFor, emitResidualTvConstraint,
+
+  -- Various unifications
+  unifyType, unifyKind,
+  uType, promoteTcType,
+  swapOverTyVars, canSolveByUnification,
+
+  --------------------------------
+  -- Holes
+  tcInferInst, tcInferNoInst,
+  matchExpectedListTy,
+  matchExpectedTyConApp,
+  matchExpectedAppTy,
+  matchExpectedFunTys,
+  matchActualFunTys, matchActualFunTysPart,
+  matchExpectedFunKind,
+
+  metaTyVarUpdateOK, occCheckForErrors, OccCheckResult(..)
+
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import HsSyn
+import TyCoRep
+import TcMType
+import TcRnMonad
+import TcType
+import Type
+import Coercion
+import TcEvidence
+import Name( isSystemName )
+import Inst
+import TyCon
+import TysWiredIn
+import TysPrim( tYPE )
+import Var
+import VarSet
+import VarEnv
+import ErrUtils
+import DynFlags
+import BasicTypes
+import Bag
+import Util
+import qualified GHC.LanguageExtensions as LangExt
+import Outputable
+
+import Control.Monad
+import Control.Arrow ( second )
+
+{-
+************************************************************************
+*                                                                      *
+             matchExpected functions
+*                                                                      *
+************************************************************************
+
+Note [Herald for matchExpectedFunTys]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The 'herald' always looks like:
+   "The equation(s) for 'f' have"
+   "The abstraction (\x.e) takes"
+   "The section (+ x) expects"
+   "The function 'f' is applied to"
+
+This is used to construct a message of form
+
+   The abstraction `\Just 1 -> ...' takes two arguments
+   but its type `Maybe a -> a' has only one
+
+   The equation(s) for `f' have two arguments
+   but its type `Maybe a -> a' has only one
+
+   The section `(f 3)' requires 'f' to take two arguments
+   but its type `Int -> Int' has only one
+
+   The function 'f' is applied to two arguments
+   but its type `Int -> Int' has only one
+
+When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the
+picture, we have a choice in deciding whether to count the type applications as
+proper arguments:
+
+   The function 'f' is applied to one visible type argument
+     and two value arguments
+   but its type `forall a. a -> a` has only one visible type argument
+     and one value argument
+
+Or whether to include the type applications as part of the herald itself:
+
+   The expression 'f @Int' is applied to two arguments
+   but its type `Int -> Int` has only one
+
+The latter is easier to implement and is arguably easier to understand, so we
+choose to implement that option.
+
+Note [matchExpectedFunTys]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+matchExpectedFunTys checks that a sigma has the form
+of an n-ary function.  It passes the decomposed type to the
+thing_inside, and returns a wrapper to coerce between the two types
+
+It's used wherever a language construct must have a functional type,
+namely:
+        A lambda expression
+        A function definition
+     An operator section
+
+This function must be written CPS'd because it needs to fill in the
+ExpTypes produced for arguments before it can fill in the ExpType
+passed in.
+
+-}
+
+-- Use this one when you have an "expected" type.
+matchExpectedFunTys :: forall a.
+                       SDoc   -- See Note [Herald for matchExpectedFunTys]
+                    -> Arity
+                    -> ExpRhoType  -- deeply skolemised
+                    -> ([ExpSigmaType] -> ExpRhoType -> TcM a)
+                          -- must fill in these ExpTypes here
+                    -> TcM (a, HsWrapper)
+-- If    matchExpectedFunTys n ty = (_, wrap)
+-- then  wrap : (t1 -> ... -> tn -> ty_r) ~> ty,
+--   where [t1, ..., tn], ty_r are passed to the thing_inside
+matchExpectedFunTys herald arity orig_ty thing_inside
+  = case orig_ty of
+      Check ty -> go [] arity ty
+      _        -> defer [] arity orig_ty
+  where
+    go acc_arg_tys 0 ty
+      = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType ty)
+           ; return (result, idHsWrapper) }
+
+    go acc_arg_tys n ty
+      | Just ty' <- tcView ty = go acc_arg_tys n ty'
+
+    go acc_arg_tys n (FunTy arg_ty res_ty)
+      = ASSERT( not (isPredTy arg_ty) )
+        do { (result, wrap_res) <- go (mkCheckExpType arg_ty : acc_arg_tys)
+                                      (n-1) res_ty
+           ; return ( result
+                    , mkWpFun idHsWrapper wrap_res arg_ty res_ty doc ) }
+      where
+        doc = text "When inferring the argument type of a function with type" <+>
+              quotes (ppr orig_ty)
+
+    go acc_arg_tys n ty@(TyVarTy tv)
+      | isMetaTyVar tv
+      = do { cts <- readMetaTyVar tv
+           ; case cts of
+               Indirect ty' -> go acc_arg_tys n ty'
+               Flexi        -> defer acc_arg_tys n (mkCheckExpType ty) }
+
+       -- In all other cases we bale out into ordinary unification
+       -- However unlike the meta-tyvar case, we are sure that the
+       -- number of arguments doesn't match arity of the original
+       -- type, so we can add a bit more context to the error message
+       -- (cf Trac #7869).
+       --
+       -- It is not always an error, because specialized type may have
+       -- different arity, for example:
+       --
+       -- > f1 = f2 'a'
+       -- > f2 :: Monad m => m Bool
+       -- > f2 = undefined
+       --
+       -- But in that case we add specialized type into error context
+       -- anyway, because it may be useful. See also Trac #9605.
+    go acc_arg_tys n ty = addErrCtxtM mk_ctxt $
+                          defer acc_arg_tys n (mkCheckExpType ty)
+
+    ------------
+    defer :: [ExpSigmaType] -> Arity -> ExpRhoType -> TcM (a, HsWrapper)
+    defer acc_arg_tys n fun_ty
+      = do { more_arg_tys <- replicateM n newInferExpTypeNoInst
+           ; res_ty       <- newInferExpTypeInst
+           ; result       <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty
+           ; more_arg_tys <- mapM readExpType more_arg_tys
+           ; res_ty       <- readExpType res_ty
+           ; let unif_fun_ty = mkFunTys more_arg_tys res_ty
+           ; wrap <- tcSubTypeDS AppOrigin GenSigCtxt unif_fun_ty fun_ty
+                         -- Not a good origin at all :-(
+           ; return (result, wrap) }
+
+    ------------
+    mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc)
+    mk_ctxt env = do { (env', ty) <- zonkTidyTcType env orig_tc_ty
+                     ; let (args, _) = tcSplitFunTys ty
+                           n_actual = length args
+                           (env'', orig_ty') = tidyOpenType env' orig_tc_ty
+                     ; return ( env''
+                              , mk_fun_tys_msg orig_ty' ty n_actual arity herald) }
+      where
+        orig_tc_ty = checkingExpType "matchExpectedFunTys" orig_ty
+            -- this is safe b/c we're called from "go"
+
+-- Like 'matchExpectedFunTys', but used when you have an "actual" type,
+-- for example in function application
+matchActualFunTys :: SDoc   -- See Note [Herald for matchExpectedFunTys]
+                  -> CtOrigin
+                  -> Maybe (HsExpr GhcRn)   -- the thing with type TcSigmaType
+                  -> Arity
+                  -> TcSigmaType
+                  -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
+-- If    matchActualFunTys n ty = (wrap, [t1,..,tn], ty_r)
+-- then  wrap : ty ~> (t1 -> ... -> tn -> ty_r)
+matchActualFunTys herald ct_orig mb_thing arity ty
+  = matchActualFunTysPart herald ct_orig mb_thing arity ty [] arity
+
+-- | Variant of 'matchActualFunTys' that works when supplied only part
+-- (that is, to the right of some arrows) of the full function type
+matchActualFunTysPart :: SDoc -- See Note [Herald for matchExpectedFunTys]
+                      -> CtOrigin
+                      -> Maybe (HsExpr GhcRn)  -- the thing with type TcSigmaType
+                      -> Arity
+                      -> TcSigmaType
+                      -> [TcSigmaType] -- reversed args. See (*) below.
+                      -> Arity   -- overall arity of the function, for errs
+                      -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
+matchActualFunTysPart herald ct_orig mb_thing arity orig_ty
+                      orig_old_args full_arity
+  = go arity orig_old_args orig_ty
+-- Does not allocate unnecessary meta variables: if the input already is
+-- a function, we just take it apart.  Not only is this efficient,
+-- it's important for higher rank: the argument might be of form
+--              (forall a. ty) -> other
+-- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd
+-- hide the forall inside a meta-variable
+
+-- (*) Sometimes it's necessary to call matchActualFunTys with only part
+-- (that is, to the right of some arrows) of the type of the function in
+-- question. (See TcExpr.tcArgs.) This argument is the reversed list of
+-- arguments already seen (that is, not part of the TcSigmaType passed
+-- in elsewhere).
+
+  where
+    -- This function has a bizarre mechanic: it accumulates arguments on
+    -- the way down and also builds an argument list on the way up. Why:
+    -- 1. The returns args list and the accumulated args list might be different.
+    --    The accumulated args include all the arg types for the function,
+    --    including those from before this function was called. The returned
+    --    list should include only those arguments produced by this call of
+    --    matchActualFunTys
+    --
+    -- 2. The HsWrapper can be built only on the way up. It seems (more)
+    --    bizarre to build the HsWrapper but not the arg_tys.
+    --
+    -- Refactoring is welcome.
+    go :: Arity
+       -> [TcSigmaType] -- accumulator of arguments (reversed)
+       -> TcSigmaType   -- the remainder of the type as we're processing
+       -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)
+    go 0 _ ty = return (idHsWrapper, [], ty)
+
+    go n acc_args ty
+      | not (null tvs && null theta)
+      = do { (wrap1, rho) <- topInstantiate ct_orig ty
+           ; (wrap2, arg_tys, res_ty) <- go n acc_args rho
+           ; return (wrap2 <.> wrap1, arg_tys, res_ty) }
+      where
+        (tvs, theta, _) = tcSplitSigmaTy ty
+
+    go n acc_args ty
+      | Just ty' <- tcView ty = go n acc_args ty'
+
+    go n acc_args (FunTy arg_ty res_ty)
+      = ASSERT( not (isPredTy arg_ty) )
+        do { (wrap_res, tys, ty_r) <- go (n-1) (arg_ty : acc_args) res_ty
+           ; return ( mkWpFun idHsWrapper wrap_res arg_ty ty_r doc
+                    , arg_ty : tys, ty_r ) }
+      where
+        doc = text "When inferring the argument type of a function with type" <+>
+              quotes (ppr orig_ty)
+
+    go n acc_args ty@(TyVarTy tv)
+      | isMetaTyVar tv
+      = do { cts <- readMetaTyVar tv
+           ; case cts of
+               Indirect ty' -> go n acc_args ty'
+               Flexi        -> defer n ty }
+
+       -- In all other cases we bale out into ordinary unification
+       -- However unlike the meta-tyvar case, we are sure that the
+       -- number of arguments doesn't match arity of the original
+       -- type, so we can add a bit more context to the error message
+       -- (cf Trac #7869).
+       --
+       -- It is not always an error, because specialized type may have
+       -- different arity, for example:
+       --
+       -- > f1 = f2 'a'
+       -- > f2 :: Monad m => m Bool
+       -- > f2 = undefined
+       --
+       -- But in that case we add specialized type into error context
+       -- anyway, because it may be useful. See also Trac #9605.
+    go n acc_args ty = addErrCtxtM (mk_ctxt (reverse acc_args) ty) $
+                       defer n ty
+
+    ------------
+    defer n fun_ty
+      = do { arg_tys <- replicateM n newOpenFlexiTyVarTy
+           ; res_ty  <- newOpenFlexiTyVarTy
+           ; let unif_fun_ty = mkFunTys arg_tys res_ty
+           ; co <- unifyType mb_thing fun_ty unif_fun_ty
+           ; return (mkWpCastN co, arg_tys, res_ty) }
+
+    ------------
+    mk_ctxt :: [TcSigmaType] -> TcSigmaType -> TidyEnv -> TcM (TidyEnv, MsgDoc)
+    mk_ctxt arg_tys res_ty env
+      = do { let ty = mkFunTys arg_tys res_ty
+           ; (env1, zonked) <- zonkTidyTcType env ty
+                   -- zonking might change # of args
+           ; let (zonked_args, _) = tcSplitFunTys zonked
+                 n_actual         = length zonked_args
+                 (env2, unzonked) = tidyOpenType env1 ty
+           ; return ( env2
+                    , mk_fun_tys_msg unzonked zonked n_actual full_arity herald) }
+
+mk_fun_tys_msg :: TcType  -- the full type passed in (unzonked)
+               -> TcType  -- the full type passed in (zonked)
+               -> Arity   -- the # of args found
+               -> Arity   -- the # of args wanted
+               -> SDoc    -- overall herald
+               -> SDoc
+mk_fun_tys_msg full_ty ty n_args full_arity herald
+  = herald <+> speakNOf full_arity (text "argument") <> comma $$
+    if n_args == full_arity
+      then text "its type is" <+> quotes (pprType full_ty) <>
+           comma $$
+           text "it is specialized to" <+> quotes (pprType ty)
+      else sep [text "but its type" <+> quotes (pprType ty),
+                if n_args == 0 then text "has none"
+                else text "has only" <+> speakN n_args]
+
+----------------------
+matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType)
+-- Special case for lists
+matchExpectedListTy exp_ty
+ = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty
+      ; return (co, elt_ty) }
+
+---------------------
+matchExpectedTyConApp :: TyCon                -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> *
+                      -> TcRhoType            -- orig_ty
+                      -> TcM (TcCoercionN,    -- T k1 k2 k3 a b c ~N orig_ty
+                              [TcSigmaType])  -- Element types, k1 k2 k3 a b c
+
+-- It's used for wired-in tycons, so we call checkWiredInTyCon
+-- Precondition: never called with FunTyCon
+-- Precondition: input type :: *
+-- Postcondition: (T k1 k2 k3 a b c) is well-kinded
+
+matchExpectedTyConApp tc orig_ty
+  = ASSERT(tc /= funTyCon) go orig_ty
+  where
+    go ty
+       | Just ty' <- tcView ty
+       = go ty'
+
+    go ty@(TyConApp tycon args)
+       | tc == tycon  -- Common case
+       = return (mkTcNomReflCo ty, args)
+
+    go (TyVarTy tv)
+       | isMetaTyVar tv
+       = do { cts <- readMetaTyVar tv
+            ; case cts of
+                Indirect ty -> go ty
+                Flexi       -> defer }
+
+    go _ = defer
+
+    -- If the common case does not occur, instantiate a template
+    -- T k1 .. kn t1 .. tm, and unify with the original type
+    -- Doing it this way ensures that the types we return are
+    -- kind-compatible with T.  For example, suppose we have
+    --       matchExpectedTyConApp T (f Maybe)
+    -- where data T a = MkT a
+    -- Then we don't want to instantiate T's data constructors with
+    --    (a::*) ~ Maybe
+    -- because that'll make types that are utterly ill-kinded.
+    -- This happened in Trac #7368
+    defer
+      = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc)
+           ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs)
+           ; let args = mkTyVarTys arg_tvs
+                 tc_template = mkTyConApp tc args
+           ; co <- unifyType Nothing tc_template orig_ty
+           ; return (co, args) }
+
+----------------------
+matchExpectedAppTy :: TcRhoType                         -- orig_ty
+                   -> TcM (TcCoercion,                   -- m a ~N orig_ty
+                           (TcSigmaType, TcSigmaType))  -- Returns m, a
+-- If the incoming type is a mutable type variable of kind k, then
+-- matchExpectedAppTy returns a new type variable (m: * -> k); note the *.
+
+matchExpectedAppTy orig_ty
+  = go orig_ty
+  where
+    go ty
+      | Just ty' <- tcView ty = go ty'
+
+      | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
+      = return (mkTcNomReflCo orig_ty, (fun_ty, arg_ty))
+
+    go (TyVarTy tv)
+      | isMetaTyVar tv
+      = do { cts <- readMetaTyVar tv
+           ; case cts of
+               Indirect ty -> go ty
+               Flexi       -> defer }
+
+    go _ = defer
+
+    -- Defer splitting by generating an equality constraint
+    defer
+      = do { ty1 <- newFlexiTyVarTy kind1
+           ; ty2 <- newFlexiTyVarTy kind2
+           ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty
+           ; return (co, (ty1, ty2)) }
+
+    orig_kind = tcTypeKind orig_ty
+    kind1 = mkFunTy liftedTypeKind orig_kind
+    kind2 = liftedTypeKind    -- m :: * -> k
+                              -- arg type :: *
+
+{-
+************************************************************************
+*                                                                      *
+                Subsumption checking
+*                                                                      *
+************************************************************************
+
+Note [Subsumption checking: tcSubType]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+All the tcSubType calls have the form
+                tcSubType actual_ty expected_ty
+which checks
+                actual_ty <= expected_ty
+
+That is, that a value of type actual_ty is acceptable in
+a place expecting a value of type expected_ty.  I.e. that
+
+    actual ty   is more polymorphic than   expected_ty
+
+It returns a coercion function
+        co_fn :: actual_ty ~ expected_ty
+which takes an HsExpr of type actual_ty into one of type
+expected_ty.
+
+These functions do not actually check for subsumption. They check if
+expected_ty is an appropriate annotation to use for something of type
+actual_ty. This difference matters when thinking about visible type
+application. For example,
+
+   forall a. a -> forall b. b -> b
+      DOES NOT SUBSUME
+   forall a b. a -> b -> b
+
+because the type arguments appear in a different order. (Neither does
+it work the other way around.) BUT, these types are appropriate annotations
+for one another. Because the user directs annotations, it's OK if some
+arguments shuffle around -- after all, it's what the user wants.
+Bottom line: none of this changes with visible type application.
+
+There are a number of wrinkles (below).
+
+Notice that Wrinkle 1 and 2 both require eta-expansion, which technically
+may increase termination.  We just put up with this, in exchange for getting
+more predictable type inference.
+
+Wrinkle 1: Note [Deep skolemisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want   (forall a. Int -> a -> a)  <=  (Int -> forall a. a->a)
+(see section 4.6 of "Practical type inference for higher rank types")
+So we must deeply-skolemise the RHS before we instantiate the LHS.
+
+That is why tc_sub_type starts with a call to tcSkolemise (which does the
+deep skolemisation), and then calls the DS variant (which assumes
+that expected_ty is deeply skolemised)
+
+Wrinkle 2: Note [Co/contra-variance of subsumption checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider  g :: (Int -> Int) -> Int
+  f1 :: (forall a. a -> a) -> Int
+  f1 = g
+
+  f2 :: (forall a. a -> a) -> Int
+  f2 x = g x
+f2 will typecheck, and it would be odd/fragile if f1 did not.
+But f1 will only typecheck if we have that
+    (Int->Int) -> Int  <=  (forall a. a->a) -> Int
+And that is only true if we do the full co/contravariant thing
+in the subsumption check.  That happens in the FunTy case of
+tcSubTypeDS_NC_O, and is the sole reason for the WpFun form of
+HsWrapper.
+
+Another powerful reason for doing this co/contra stuff is visible
+in Trac #9569, involving instantiation of constraint variables,
+and again involving eta-expansion.
+
+Wrinkle 3: Note [Higher rank types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider tc150:
+  f y = \ (x::forall a. a->a). blah
+The following happens:
+* We will infer the type of the RHS, ie with a res_ty = alpha.
+* Then the lambda will split  alpha := beta -> gamma.
+* And then we'll check tcSubType IsSwapped beta (forall a. a->a)
+
+So it's important that we unify beta := forall a. a->a, rather than
+skolemising the type.
+-}
+
+
+-- | Call this variant when you are in a higher-rank situation and
+-- you know the right-hand type is deeply skolemised.
+tcSubTypeHR :: CtOrigin               -- ^ of the actual type
+            -> Maybe (HsExpr GhcRn)   -- ^ If present, it has type ty_actual
+            -> TcSigmaType -> ExpRhoType -> TcM HsWrapper
+tcSubTypeHR orig = tcSubTypeDS_NC_O orig GenSigCtxt
+
+------------------------
+tcSubTypeET :: CtOrigin -> UserTypeCtxt
+            -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper
+-- If wrap = tc_sub_type_et t1 t2
+--    => wrap :: t1 ~> t2
+tcSubTypeET orig ctxt (Check ty_actual) ty_expected
+  = tc_sub_tc_type eq_orig orig ctxt ty_actual ty_expected
+  where
+    eq_orig = TypeEqOrigin { uo_actual   = ty_expected
+                           , uo_expected = ty_actual
+                           , uo_thing    = Nothing
+                           , uo_visible  = True }
+
+tcSubTypeET _ _ (Infer inf_res) ty_expected
+  = ASSERT2( not (ir_inst inf_res), ppr inf_res $$ ppr ty_expected )
+      -- An (Infer inf_res) ExpSigmaType passed into tcSubTypeET never
+      -- has the ir_inst field set.  Reason: in patterns (which is what
+      -- tcSubTypeET is used for) do not aggressively instantiate
+    do { co <- fill_infer_result ty_expected inf_res
+               -- Since ir_inst is false, we can skip fillInferResult
+               -- and go straight to fill_infer_result
+
+       ; return (mkWpCastN (mkTcSymCo co)) }
+
+------------------------
+tcSubTypeO :: CtOrigin      -- ^ of the actual type
+           -> UserTypeCtxt  -- ^ of the expected type
+           -> TcSigmaType
+           -> ExpRhoType
+           -> TcM HsWrapper
+tcSubTypeO orig ctxt ty_actual ty_expected
+  = addSubTypeCtxt ty_actual ty_expected $
+    do { traceTc "tcSubTypeDS_O" (vcat [ pprCtOrigin orig
+                                       , pprUserTypeCtxt ctxt
+                                       , ppr ty_actual
+                                       , ppr ty_expected ])
+       ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected }
+
+addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a
+addSubTypeCtxt ty_actual ty_expected thing_inside
+ | isRhoTy ty_actual        -- If there is no polymorphism involved, the
+ , isRhoExpTy ty_expected   -- TypeEqOrigin stuff (added by the _NC functions)
+ = thing_inside             -- gives enough context by itself
+ | otherwise
+ = addErrCtxtM mk_msg thing_inside
+  where
+    mk_msg tidy_env
+      = do { (tidy_env, ty_actual)   <- zonkTidyTcType tidy_env ty_actual
+                   -- might not be filled if we're debugging. ugh.
+           ; mb_ty_expected          <- readExpType_maybe ty_expected
+           ; (tidy_env, ty_expected) <- case mb_ty_expected of
+                                          Just ty -> second mkCheckExpType <$>
+                                                     zonkTidyTcType tidy_env ty
+                                          Nothing -> return (tidy_env, ty_expected)
+           ; ty_expected             <- readExpType ty_expected
+           ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected
+           ; let msg = vcat [ hang (text "When checking that:")
+                                 4 (ppr ty_actual)
+                            , nest 2 (hang (text "is more polymorphic than:")
+                                         2 (ppr ty_expected)) ]
+           ; return (tidy_env, msg) }
+
+---------------
+-- The "_NC" variants do not add a typechecker-error context;
+-- the caller is assumed to do that
+
+tcSubType_NC :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
+-- Checks that actual <= expected
+-- Returns HsWrapper :: actual ~ expected
+tcSubType_NC ctxt ty_actual ty_expected
+  = do { traceTc "tcSubType_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])
+       ; tc_sub_tc_type origin origin ctxt ty_actual ty_expected }
+  where
+    origin = TypeEqOrigin { uo_actual   = ty_actual
+                          , uo_expected = ty_expected
+                          , uo_thing    = Nothing
+                          , uo_visible  = True }
+
+tcSubTypeDS :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> ExpRhoType -> TcM HsWrapper
+-- Just like tcSubType, but with the additional precondition that
+-- ty_expected is deeply skolemised (hence "DS")
+tcSubTypeDS orig ctxt ty_actual ty_expected
+  = addSubTypeCtxt ty_actual ty_expected $
+    do { traceTc "tcSubTypeDS_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])
+       ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected }
+
+tcSubTypeDS_NC_O :: CtOrigin   -- origin used for instantiation only
+                 -> UserTypeCtxt
+                 -> Maybe (HsExpr GhcRn)
+                 -> TcSigmaType -> ExpRhoType -> TcM HsWrapper
+-- Just like tcSubType, but with the additional precondition that
+-- ty_expected is deeply skolemised
+tcSubTypeDS_NC_O inst_orig ctxt m_thing ty_actual ty_expected
+  = case ty_expected of
+      Infer inf_res -> fillInferResult inst_orig ty_actual inf_res
+      Check ty      -> tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty
+         where
+           eq_orig = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty
+                                  , uo_thing  = ppr <$> m_thing
+                                  , uo_visible = True }
+
+---------------
+tc_sub_tc_type :: CtOrigin   -- used when calling uType
+               -> CtOrigin   -- used when instantiating
+               -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
+-- If wrap = tc_sub_type t1 t2
+--    => wrap :: t1 ~> t2
+tc_sub_tc_type eq_orig inst_orig ctxt ty_actual ty_expected
+  | definitely_poly ty_expected      -- See Note [Don't skolemise unnecessarily]
+  , not (possibly_poly ty_actual)
+  = do { traceTc "tc_sub_tc_type (drop to equality)" $
+         vcat [ text "ty_actual   =" <+> ppr ty_actual
+              , text "ty_expected =" <+> ppr ty_expected ]
+       ; mkWpCastN <$>
+         uType TypeLevel eq_orig ty_actual ty_expected }
+
+  | otherwise   -- This is the general case
+  = do { traceTc "tc_sub_tc_type (general case)" $
+         vcat [ text "ty_actual   =" <+> ppr ty_actual
+              , text "ty_expected =" <+> ppr ty_expected ]
+       ; (sk_wrap, inner_wrap) <- tcSkolemise ctxt ty_expected $
+                                                   \ _ sk_rho ->
+                                  tc_sub_type_ds eq_orig inst_orig ctxt
+                                                 ty_actual sk_rho
+       ; return (sk_wrap <.> inner_wrap) }
+  where
+    possibly_poly ty
+      | isForAllTy ty                        = True
+      | Just (_, res) <- splitFunTy_maybe ty = possibly_poly res
+      | otherwise                            = False
+      -- NB *not* tcSplitFunTy, because here we want
+      -- to decompose type-class arguments too
+
+    definitely_poly ty
+      | (tvs, theta, tau) <- tcSplitSigmaTy ty
+      , (tv:_) <- tvs
+      , null theta
+      , isInsolubleOccursCheck NomEq tv tau
+      = True
+      | otherwise
+      = False
+
+{- Note [Don't skolemise unnecessarily]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are trying to solve
+    (Char->Char) <= (forall a. a->a)
+We could skolemise the 'forall a', and then complain
+that (Char ~ a) is insoluble; but that's a pretty obscure
+error.  It's better to say that
+    (Char->Char) ~ (forall a. a->a)
+fails.
+
+So roughly:
+ * if the ty_expected has an outermost forall
+      (i.e. skolemisation is the next thing we'd do)
+ * and the ty_actual has no top-level polymorphism (but looking deeply)
+then we can revert to simple equality.  But we need to be careful.
+These examples are all fine:
+
+ * (Char -> forall a. a->a) <= (forall a. Char -> a -> a)
+      Polymorphism is buried in ty_actual
+
+ * (Char->Char) <= (forall a. Char -> Char)
+      ty_expected isn't really polymorphic
+
+ * (Char->Char) <= (forall a. (a~Char) => a -> a)
+      ty_expected isn't really polymorphic
+
+ * (Char->Char) <= (forall a. F [a] Char -> Char)
+                   where type instance F [x] t = t
+     ty_expected isn't really polymorphic
+
+If we prematurely go to equality we'll reject a program we should
+accept (e.g. Trac #13752).  So the test (which is only to improve
+error message) is very conservative:
+ * ty_actual is /definitely/ monomorphic
+ * ty_expected is /definitely/ polymorphic
+-}
+
+---------------
+tc_sub_type_ds :: CtOrigin    -- used when calling uType
+               -> CtOrigin    -- used when instantiating
+               -> UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper
+-- If wrap = tc_sub_type_ds t1 t2
+--    => wrap :: t1 ~> t2
+-- Here is where the work actually happens!
+-- Precondition: ty_expected is deeply skolemised
+tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected
+  = do { traceTc "tc_sub_type_ds" $
+         vcat [ text "ty_actual   =" <+> ppr ty_actual
+              , text "ty_expected =" <+> ppr ty_expected ]
+       ; go ty_actual ty_expected }
+  where
+    go ty_a ty_e | Just ty_a' <- tcView ty_a = go ty_a' ty_e
+                 | Just ty_e' <- tcView ty_e = go ty_a  ty_e'
+
+    go (TyVarTy tv_a) ty_e
+      = do { lookup_res <- lookupTcTyVar tv_a
+           ; case lookup_res of
+               Filled ty_a' ->
+                 do { traceTc "tcSubTypeDS_NC_O following filled act meta-tyvar:"
+                        (ppr tv_a <+> text "-->" <+> ppr ty_a')
+                    ; tc_sub_type_ds eq_orig inst_orig ctxt ty_a' ty_e }
+               Unfilled _   -> unify }
+
+    -- Historical note (Sept 16): there was a case here for
+    --    go ty_a (TyVarTy alpha)
+    -- which, in the impredicative case unified  alpha := ty_a
+    -- where th_a is a polytype.  Not only is this probably bogus (we
+    -- simply do not have decent story for impredicative types), but it
+    -- caused Trac #12616 because (also bizarrely) 'deriving' code had
+    -- -XImpredicativeTypes on.  I deleted the entire case.
+
+    go (FunTy act_arg act_res) (FunTy exp_arg exp_res)
+      | not (isPredTy act_arg)
+      , not (isPredTy exp_arg)
+      = -- See Note [Co/contra-variance of subsumption checking]
+        do { res_wrap <- tc_sub_type_ds eq_orig inst_orig  ctxt       act_res exp_res
+           ; arg_wrap <- tc_sub_tc_type eq_orig given_orig GenSigCtxt exp_arg act_arg
+                         -- GenSigCtxt: See Note [Setting the argument context]
+           ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res doc) }
+               -- arg_wrap :: exp_arg ~> act_arg
+               -- res_wrap :: act-res ~> exp_res
+      where
+        given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg [])
+        doc = text "When checking that" <+> quotes (ppr ty_actual) <+>
+              text "is more polymorphic than" <+> quotes (ppr ty_expected)
+
+    go ty_a ty_e
+      | let (tvs, theta, _) = tcSplitSigmaTy ty_a
+      , not (null tvs && null theta)
+      = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a
+           ; body_wrap <- tc_sub_type_ds
+                            (eq_orig { uo_actual = in_rho
+                                     , uo_expected = ty_expected })
+                            inst_orig ctxt in_rho ty_e
+           ; return (body_wrap <.> in_wrap) }
+
+      | otherwise   -- Revert to unification
+      = inst_and_unify
+         -- It's still possible that ty_actual has nested foralls. Instantiate
+         -- these, as there's no way unification will succeed with them in.
+         -- See typecheck/should_compile/T11305 for an example of when this
+         -- is important. The problem is that we're checking something like
+         --  a -> forall b. b -> b     <=   alpha beta gamma
+         -- where we end up with alpha := (->)
+
+    inst_and_unify = do { (wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual
+
+                           -- if we haven't recurred through an arrow, then
+                           -- the eq_orig will list ty_actual. In this case,
+                           -- we want to update the origin to reflect the
+                           -- instantiation. If we *have* recurred through
+                           -- an arrow, it's better not to update.
+                        ; let eq_orig' = case eq_orig of
+                                TypeEqOrigin { uo_actual   = orig_ty_actual }
+                                  |  orig_ty_actual `tcEqType` ty_actual
+                                  ,  not (isIdHsWrapper wrap)
+                                  -> eq_orig { uo_actual = rho_a }
+                                _ -> eq_orig
+
+                        ; cow <- uType TypeLevel eq_orig' rho_a ty_expected
+                        ; return (mkWpCastN cow <.> wrap) }
+
+
+     -- use versions without synonyms expanded
+    unify = mkWpCastN <$> uType TypeLevel eq_orig ty_actual ty_expected
+
+{- Note [Settting the argument context]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider we are doing the ambiguity check for the (bogus)
+  f :: (forall a b. C b => a -> a) -> Int
+
+We'll call
+   tcSubType ((forall a b. C b => a->a) -> Int )
+             ((forall a b. C b => a->a) -> Int )
+
+with a UserTypeCtxt of (FunSigCtxt "f").  Then we'll do the co/contra thing
+on the argument type of the (->) -- and at that point we want to switch
+to a UserTypeCtxt of GenSigCtxt.  Why?
+
+* Error messages.  If we stick with FunSigCtxt we get errors like
+     * Could not deduce: C b
+       from the context: C b0
+        bound by the type signature for:
+            f :: forall a b. C b => a->a
+  But of course f does not have that type signature!
+  Example tests: T10508, T7220a, Simple14
+
+* Implications. We may decide to build an implication for the whole
+  ambiguity check, but we don't need one for each level within it,
+  and TcUnify.alwaysBuildImplication checks the UserTypeCtxt.
+  See Note [When to build an implication]
+-}
+
+-----------------
+-- needs both un-type-checked (for origins) and type-checked (for wrapping)
+-- expressions
+tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType
+             -> TcM (HsExpr GhcTcId)
+tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr
+
+-- | Sometimes we don't have a @HsExpr Name@ to hand, and this is more
+-- convenient.
+tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType
+               -> TcM (HsExpr GhcTcId)
+tcWrapResultO orig rn_expr expr actual_ty res_ty
+  = do { traceTc "tcWrapResult" (vcat [ text "Actual:  " <+> ppr actual_ty
+                                      , text "Expected:" <+> ppr res_ty ])
+       ; cow <- tcSubTypeDS_NC_O orig GenSigCtxt
+                                 (Just rn_expr) actual_ty res_ty
+       ; return (mkHsWrap cow expr) }
+
+
+{- **********************************************************************
+%*                                                                      *
+            ExpType functions: tcInfer, fillInferResult
+%*                                                                      *
+%********************************************************************* -}
+
+-- | Infer a type using a fresh ExpType
+-- See also Note [ExpType] in TcMType
+-- Does not attempt to instantiate the inferred type
+tcInferNoInst :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
+tcInferNoInst = tcInfer False
+
+tcInferInst :: (ExpRhoType -> TcM a) -> TcM (a, TcRhoType)
+tcInferInst = tcInfer True
+
+tcInfer :: Bool -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)
+tcInfer instantiate tc_check
+  = do { res_ty <- newInferExpType instantiate
+       ; result <- tc_check res_ty
+       ; res_ty <- readExpType res_ty
+       ; return (result, res_ty) }
+
+fillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper
+-- If wrap = fillInferResult t1 t2
+--    => wrap :: t1 ~> t2
+-- See Note [Deep instantiation of InferResult]
+fillInferResult orig ty inf_res@(IR { ir_inst = instantiate_me })
+  | instantiate_me
+  = do { (wrap, rho) <- deeplyInstantiate orig ty
+       ; co <- fill_infer_result rho inf_res
+       ; return (mkWpCastN co <.> wrap) }
+
+  | otherwise
+  = do { co <- fill_infer_result ty inf_res
+       ; return (mkWpCastN co) }
+
+fill_infer_result :: TcType -> InferResult -> TcM TcCoercionN
+-- If wrap = fill_infer_result t1 t2
+--    => wrap :: t1 ~> t2
+fill_infer_result orig_ty (IR { ir_uniq = u, ir_lvl = res_lvl
+                            , ir_ref = ref })
+  = do { (ty_co, ty_to_fill_with) <- promoteTcType res_lvl orig_ty
+
+       ; traceTc "Filling ExpType" $
+         ppr u <+> text ":=" <+> ppr ty_to_fill_with
+
+       ; when debugIsOn (check_hole ty_to_fill_with)
+
+       ; writeTcRef ref (Just ty_to_fill_with)
+
+       ; return ty_co }
+  where
+    check_hole ty   -- Debug check only
+      = do { let ty_lvl = tcTypeLevel ty
+           ; MASSERT2( not (ty_lvl `strictlyDeeperThan` res_lvl),
+                       ppr u $$ ppr res_lvl $$ ppr ty_lvl $$
+                       ppr ty <+> dcolon <+> ppr (tcTypeKind ty) $$ ppr orig_ty )
+           ; cts <- readTcRef ref
+           ; case cts of
+               Just already_there -> pprPanic "writeExpType"
+                                       (vcat [ ppr u
+                                             , ppr ty
+                                             , ppr already_there ])
+               Nothing -> return () }
+
+{- Note [Deep instantiation of InferResult]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In some cases we want to deeply instantiate before filling in
+an InferResult, and in some cases not.  That's why InferReult
+has the ir_inst flag.
+
+* ir_inst = True: deeply instantiate
+
+  Consider
+    f x = (*)
+  We want to instantiate the type of (*) before returning, else we
+  will infer the type
+    f :: forall {a}. a -> forall b. Num b => b -> b -> b
+  This is surely confusing for users.
+
+  And worse, the monomorphism restriction won't work properly. The MR is
+  dealt with in simplifyInfer, and simplifyInfer has no way of
+  instantiating. This could perhaps be worked around, but it may be
+  hard to know even when instantiation should happen.
+
+  Another reason.  Consider
+       f :: (?x :: Int) => a -> a
+       g y = let ?x = 3::Int in f
+  Here want to instantiate f's type so that the ?x::Int constraint
+  gets discharged by the enclosing implicit-parameter binding.
+
+* ir_inst = False: do not instantiate
+
+  Consider this (which uses visible type application):
+
+    (let { f :: forall a. a -> a; f x = x } in f) @Int
+
+  We'll call TcExpr.tcInferFun to infer the type of the (let .. in f)
+  And we don't want to instantite the type of 'f' when we reach it,
+  else the outer visible type application won't work
+-}
+
+{- *********************************************************************
+*                                                                      *
+              Promoting types
+*                                                                      *
+********************************************************************* -}
+
+promoteTcType :: TcLevel -> TcType -> TcM (TcCoercion, TcType)
+-- See Note [Promoting a type]
+-- promoteTcType level ty = (co, ty')
+--   * Returns ty'  whose max level is just 'level'
+--             and  whose kind is ~# to the kind of 'ty'
+--             and  whose kind has form TYPE rr
+--   * and co :: ty ~ ty'
+--   * and emits constraints to justify the coercion
+promoteTcType dest_lvl ty
+  = do { cur_lvl <- getTcLevel
+       ; if (cur_lvl `sameDepthAs` dest_lvl)
+         then dont_promote_it
+         else promote_it }
+  where
+    promote_it :: TcM (TcCoercion, TcType)
+    promote_it  -- Emit a constraint  (alpha :: TYPE rr) ~ ty
+                -- where alpha and rr are fresh and from level dest_lvl
+      = do { rr      <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy
+           ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr)
+           ; let eq_orig = TypeEqOrigin { uo_actual   = ty
+                                        , uo_expected = prom_ty
+                                        , uo_thing    = Nothing
+                                        , uo_visible  = False }
+
+           ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty
+           ; return (co, prom_ty) }
+
+    dont_promote_it :: TcM (TcCoercion, TcType)
+    dont_promote_it  -- Check that ty :: TYPE rr, for some (fresh) rr
+      = do { res_kind <- newOpenTypeKind
+           ; let ty_kind = tcTypeKind ty
+                 kind_orig = TypeEqOrigin { uo_actual   = ty_kind
+                                          , uo_expected = res_kind
+                                          , uo_thing    = Nothing
+                                          , uo_visible  = False }
+           ; ki_co <- uType KindLevel kind_orig (tcTypeKind ty) res_kind
+           ; let co = mkTcGReflRightCo Nominal ty ki_co
+           ; return (co, ty `mkCastTy` ki_co) }
+
+{- Note [Promoting a type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider (Trac #12427)
+
+  data T where
+    MkT :: (Int -> Int) -> a -> T
+
+  h y = case y of MkT v w -> v
+
+We'll infer the RHS type with an expected type ExpType of
+  (IR { ir_lvl = l, ir_ref = ref, ... )
+where 'l' is the TcLevel of the RHS of 'h'.  Then the MkT pattern
+match will increase the level, so we'll end up in tcSubType, trying to
+unify the type of v,
+  v :: Int -> Int
+with the expected type.  But this attempt takes place at level (l+1),
+rightly so, since v's type could have mentioned existential variables,
+(like w's does) and we want to catch that.
+
+So we
+  - create a new meta-var alpha[l+1]
+  - fill in the InferRes ref cell 'ref' with alpha
+  - emit an equality constraint, thus
+        [W] alpha[l+1] ~ (Int -> Int)
+
+That constraint will float outwards, as it should, unless v's
+type mentions a skolem-captured variable.
+
+This approach fails if v has a higher rank type; see
+Note [Promotion and higher rank types]
+
+
+Note [Promotion and higher rank types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If v had a higher-rank type, say v :: (forall a. a->a) -> Int,
+then we'd emit an equality
+        [W] alpha[l+1] ~ ((forall a. a->a) -> Int)
+which will sadly fail because we can't unify a unification variable
+with a polytype.  But there is nothing really wrong with the program
+here.
+
+We could just about solve this by "promote the type" of v, to expose
+its polymorphic "shape" while still leaving constraints that will
+prevent existential escape.  But we must be careful!  Exposing
+the "shape" of the type is precisely what we must NOT do under
+a GADT pattern match!  So in this case we might promote the type
+to
+        (forall a. a->a) -> alpha[l+1]
+and emit the constraint
+        [W] alpha[l+1] ~ Int
+Now the promoted type can fill the ref cell, while the emitted
+equality can float or not, according to the usual rules.
+
+But that's not quite right!  We are exposing the arrow! We could
+deal with that too:
+        (forall a. mu[l+1] a a) -> alpha[l+1]
+with constraints
+        [W] alpha[l+1] ~ Int
+        [W] mu[l+1] ~ (->)
+Here we abstract over the '->' inside the forall, in case that
+is subject to an equality constraint from a GADT match.
+
+Note that we kept the outer (->) because that's part of
+the polymorphic "shape".  And because of impredicativity,
+GADT matches can't give equalities that affect polymorphic
+shape.
+
+This reasoning just seems too complicated, so I decided not
+to do it.  These higher-rank notes are just here to record
+the thinking.
+-}
+
+{- *********************************************************************
+*                                                                      *
+                    Generalisation
+*                                                                      *
+********************************************************************* -}
+
+-- | Take an "expected type" and strip off quantifiers to expose the
+-- type underneath, binding the new skolems for the @thing_inside@.
+-- The returned 'HsWrapper' has type @specific_ty -> expected_ty@.
+tcSkolemise :: UserTypeCtxt -> TcSigmaType
+            -> ([TcTyVar] -> TcType -> TcM result)
+         -- ^ These are only ever used for scoped type variables.
+            -> TcM (HsWrapper, result)
+        -- ^ The expression has type: spec_ty -> expected_ty
+
+tcSkolemise ctxt expected_ty thing_inside
+   -- We expect expected_ty to be a forall-type
+   -- If not, the call is a no-op
+  = do  { traceTc "tcSkolemise" Outputable.empty
+        ; (wrap, tv_prs, given, rho') <- deeplySkolemise expected_ty
+
+        ; lvl <- getTcLevel
+        ; when debugIsOn $
+              traceTc "tcSkolemise" $ vcat [
+                ppr lvl,
+                text "expected_ty" <+> ppr expected_ty,
+                text "inst tyvars" <+> ppr tv_prs,
+                text "given"       <+> ppr given,
+                text "inst type"   <+> ppr rho' ]
+
+        -- Generally we must check that the "forall_tvs" havn't been constrained
+        -- The interesting bit here is that we must include the free variables
+        -- of the expected_ty.  Here's an example:
+        --       runST (newVar True)
+        -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
+        -- for (newVar True), with s fresh.  Then we unify with the runST's arg type
+        -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
+        -- So now s' isn't unconstrained because it's linked to a.
+        --
+        -- However [Oct 10] now that the untouchables are a range of
+        -- TcTyVars, all this is handled automatically with no need for
+        -- extra faffing around
+
+        ; let tvs' = map snd tv_prs
+              skol_info = SigSkol ctxt expected_ty tv_prs
+
+        ; (ev_binds, result) <- checkConstraints skol_info tvs' given $
+                                thing_inside tvs' rho'
+
+        ; return (wrap <.> mkWpLet ev_binds, result) }
+          -- The ev_binds returned by checkConstraints is very
+          -- often empty, in which case mkWpLet is a no-op
+
+-- | Variant of 'tcSkolemise' that takes an ExpType
+tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType
+              -> (ExpRhoType -> TcM result)
+              -> TcM (HsWrapper, result)
+tcSkolemiseET _ et@(Infer {}) thing_inside
+  = (idHsWrapper, ) <$> thing_inside et
+tcSkolemiseET ctxt (Check ty) thing_inside
+  = tcSkolemise ctxt ty $ \_ -> thing_inside . mkCheckExpType
+
+checkConstraints :: SkolemInfo
+                 -> [TcTyVar]           -- Skolems
+                 -> [EvVar]             -- Given
+                 -> TcM result
+                 -> TcM (TcEvBinds, result)
+
+checkConstraints skol_info skol_tvs given thing_inside
+  = do { implication_needed <- implicationNeeded skol_info skol_tvs given
+
+       ; if implication_needed
+         then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside
+                 ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted
+                 ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs)
+                 ; emitImplications implics
+                 ; return (ev_binds, result) }
+
+         else -- Fast path.  We check every function argument with
+              -- tcPolyExpr, which uses tcSkolemise and hence checkConstraints.
+              -- So this fast path is well-exercised
+              do { res <- thing_inside
+                 ; return (emptyTcEvBinds, res) } }
+
+checkTvConstraints :: SkolemInfo
+                   -> Maybe SDoc  -- User-written telescope, if present
+                   -> TcM ([TcTyVar], result)
+                   -> TcM ([TcTyVar], result)
+
+checkTvConstraints skol_info m_telescope thing_inside
+  = do { (tclvl, wanted, (skol_tvs, result))
+             <- pushLevelAndCaptureConstraints thing_inside
+
+       ; emitResidualTvConstraint skol_info m_telescope
+                                  skol_tvs tclvl wanted
+
+       ; return (skol_tvs, result) }
+
+emitResidualTvConstraint :: SkolemInfo -> Maybe SDoc -> [TcTyVar]
+                         -> TcLevel -> WantedConstraints -> TcM ()
+emitResidualTvConstraint skol_info m_telescope skol_tvs tclvl wanted
+  | isEmptyWC wanted
+  = return ()
+  | otherwise
+  = do { ev_binds <- newNoTcEvBinds
+       ; implic   <- newImplication
+       ; emitImplication $
+         implic { ic_tclvl     = tclvl
+                , ic_skols     = skol_tvs
+                , ic_no_eqs    = True
+                , ic_telescope = m_telescope
+                , ic_wanted    = wanted
+                , ic_binds     = ev_binds
+                , ic_info      = skol_info } }
+
+implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool
+-- See Note [When to build an implication]
+implicationNeeded skol_info skol_tvs given
+  | null skol_tvs
+  , null given
+  , not (alwaysBuildImplication skol_info)
+  = -- Empty skolems and givens
+    do { tc_lvl <- getTcLevel
+       ; if not (isTopTcLevel tc_lvl)  -- No implication needed if we are
+         then return False             -- already inside an implication
+         else
+    do { dflags <- getDynFlags       -- If any deferral can happen,
+                                     -- we must build an implication
+       ; return (gopt Opt_DeferTypeErrors dflags ||
+                 gopt Opt_DeferTypedHoles dflags ||
+                 gopt Opt_DeferOutOfScopeVariables dflags) } }
+
+  | otherwise     -- Non-empty skolems or givens
+  = return True   -- Definitely need an implication
+
+alwaysBuildImplication :: SkolemInfo -> Bool
+-- See Note [When to build an implication]
+alwaysBuildImplication _ = False
+
+{-  Commmented out for now while I figure out about error messages.
+    See Trac #14185
+
+alwaysBuildImplication (SigSkol ctxt _ _)
+  = case ctxt of
+      FunSigCtxt {} -> True  -- RHS of a binding with a signature
+      _             -> False
+alwaysBuildImplication (RuleSkol {})      = True
+alwaysBuildImplication (InstSkol {})      = True
+alwaysBuildImplication (FamInstSkol {})   = True
+alwaysBuildImplication _                  = False
+-}
+
+buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar]
+                   -> [EvVar] -> WantedConstraints
+                   -> TcM (Bag Implication, TcEvBinds)
+buildImplicationFor tclvl skol_info skol_tvs given wanted
+  | isEmptyWC wanted && null given
+             -- Optimisation : if there are no wanteds, and no givens
+             -- don't generate an implication at all.
+             -- Reason for the (null given): we don't want to lose
+             -- the "inaccessible alternative" error check
+  = return (emptyBag, emptyTcEvBinds)
+
+  | otherwise
+  = ASSERT2( all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs, ppr skol_tvs )
+      -- Why allow TyVarTvs? Because implicitly declared kind variables in
+      -- non-CUSK type declarations are TyVarTvs, and we need to bring them
+      -- into scope as a skolem in an implication. This is OK, though,
+      -- because TyVarTvs will always remain tyvars, even after unification.
+    do { ev_binds_var <- newTcEvBinds
+       ; implic <- newImplication
+       ; let implic' = implic { ic_tclvl  = tclvl
+                              , ic_skols  = skol_tvs
+                              , ic_given  = given
+                              , ic_wanted = wanted
+                              , ic_binds  = ev_binds_var
+                              , ic_info   = skol_info }
+
+       ; return (unitBag implic', TcEvBinds ev_binds_var) }
+
+{- Note [When to build an implication]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have some 'skolems' and some 'givens', and we are
+considering whether to wrap the constraints in their scope into an
+implication.  We must /always/ so if either 'skolems' or 'givens' are
+non-empty.  But what if both are empty?  You might think we could
+always drop the implication.  Other things being equal, the fewer
+implications the better.  Less clutter and overhead.  But we must
+take care:
+
+* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors,
+  we'll make a /term-level/ evidence binding for 'g = error "blah"'.
+  We must have an EvBindsVar those bindings!, otherwise they end up as
+  top-level unlifted bindings, which are verboten. This only matters
+  at top level, so we check for that
+  See also Note [Deferred errors for coercion holes] in TcErrors.
+  cf Trac #14149 for an example of what goes wrong.
+
+* If you have
+     f :: Int;  f = f_blah
+     g :: Bool; g = g_blah
+  If we don't build an implication for f or g (no tyvars, no givens),
+  the constraints for f_blah and g_blah are solved together.  And that
+  can yield /very/ confusing error messages, because we can get
+      [W] C Int b1    -- from f_blah
+      [W] C Int b2    -- from g_blan
+  and fundpes can yield [D] b1 ~ b2, even though the two functions have
+  literally nothing to do with each other.  Trac #14185 is an example.
+  Building an implication keeps them separage.
+-}
+
+{-
+************************************************************************
+*                                                                      *
+                Boxy unification
+*                                                                      *
+************************************************************************
+
+The exported functions are all defined as versions of some
+non-exported generic functions.
+-}
+
+unifyType :: Maybe (HsExpr GhcRn)   -- ^ If present, has type 'ty1'
+          -> TcTauType -> TcTauType -> TcM TcCoercionN
+-- Actual and expected types
+-- Returns a coercion : ty1 ~ ty2
+unifyType thing ty1 ty2 = traceTc "utype" (ppr ty1 $$ ppr ty2 $$ ppr thing) >>
+                          uType TypeLevel origin ty1 ty2
+  where
+    origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2
+                          , uo_thing  = ppr <$> thing
+                          , uo_visible = True } -- always called from a visible context
+
+unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN
+unifyKind thing ty1 ty2 = traceTc "ukind" (ppr ty1 $$ ppr ty2 $$ ppr thing) >>
+                          uType KindLevel origin ty1 ty2
+  where origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2
+                              , uo_thing  = ppr <$> thing
+                              , uo_visible = True } -- also always from a visible context
+
+---------------
+
+{-
+%************************************************************************
+%*                                                                      *
+                 uType and friends
+%*                                                                      *
+%************************************************************************
+
+uType is the heart of the unifier.
+-}
+
+uType, uType_defer
+  :: TypeOrKind
+  -> CtOrigin
+  -> TcType    -- ty1 is the *actual* type
+  -> TcType    -- ty2 is the *expected* type
+  -> TcM CoercionN
+
+--------------
+-- It is always safe to defer unification to the main constraint solver
+-- See Note [Deferred unification]
+uType_defer t_or_k origin ty1 ty2
+  = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2
+
+       -- Error trace only
+       -- NB. do *not* call mkErrInfo unless tracing is on,
+       --     because it is hugely expensive (#5631)
+       ; whenDOptM Opt_D_dump_tc_trace $ do
+            { ctxt <- getErrCtxt
+            ; doc <- mkErrInfo emptyTidyEnv ctxt
+            ; traceTc "utype_defer" (vcat [ debugPprType ty1
+                                          , debugPprType ty2
+                                          , pprCtOrigin origin
+                                          , doc])
+            ; traceTc "utype_defer2" (ppr co)
+            }
+       ; return co }
+
+--------------
+uType t_or_k origin orig_ty1 orig_ty2
+  = do { tclvl <- getTcLevel
+       ; traceTc "u_tys" $ vcat
+              [ text "tclvl" <+> ppr tclvl
+              , sep [ ppr orig_ty1, text "~", ppr orig_ty2]
+              , pprCtOrigin origin]
+       ; co <- go orig_ty1 orig_ty2
+       ; if isReflCo co
+            then traceTc "u_tys yields no coercion" Outputable.empty
+            else traceTc "u_tys yields coercion:" (ppr co)
+       ; return co }
+  where
+    go :: TcType -> TcType -> TcM CoercionN
+        -- The arguments to 'go' are always semantically identical
+        -- to orig_ty{1,2} except for looking through type synonyms
+
+     -- Unwrap casts before looking for variables. This way, we can easily
+     -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we
+     -- didn't do it this way, and then the unification above was deferred.
+    go (CastTy t1 co1) t2
+      = do { co_tys <- uType t_or_k origin t1 t2
+           ; return (mkCoherenceLeftCo Nominal t1 co1 co_tys) }
+
+    go t1 (CastTy t2 co2)
+      = do { co_tys <- uType t_or_k origin t1 t2
+           ; return (mkCoherenceRightCo Nominal t2 co2 co_tys) }
+
+        -- Variables; go for uVar
+        -- Note that we pass in *original* (before synonym expansion),
+        -- so that type variables tend to get filled in with
+        -- the most informative version of the type
+    go (TyVarTy tv1) ty2
+      = do { lookup_res <- lookupTcTyVar tv1
+           ; case lookup_res of
+               Filled ty1   -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1)
+                                  ; go ty1 ty2 }
+               Unfilled _ -> uUnfilledVar origin t_or_k NotSwapped tv1 ty2 }
+    go ty1 (TyVarTy tv2)
+      = do { lookup_res <- lookupTcTyVar tv2
+           ; case lookup_res of
+               Filled ty2   -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2)
+                                  ; go ty1 ty2 }
+               Unfilled _ -> uUnfilledVar origin t_or_k IsSwapped tv2 ty1 }
+
+      -- See Note [Expanding synonyms during unification]
+    go ty1@(TyConApp tc1 []) (TyConApp tc2 [])
+      | tc1 == tc2
+      = return $ mkNomReflCo ty1
+
+        -- See Note [Expanding synonyms during unification]
+        --
+        -- Also NB that we recurse to 'go' so that we don't push a
+        -- new item on the origin stack. As a result if we have
+        --   type Foo = Int
+        -- and we try to unify  Foo ~ Bool
+        -- we'll end up saying "can't match Foo with Bool"
+        -- rather than "can't match "Int with Bool".  See Trac #4535.
+    go ty1 ty2
+      | Just ty1' <- tcView ty1 = go ty1' ty2
+      | Just ty2' <- tcView ty2 = go ty1  ty2'
+
+        -- Functions (or predicate functions) just check the two parts
+    go (FunTy fun1 arg1) (FunTy fun2 arg2)
+      = do { co_l <- uType t_or_k origin fun1 fun2
+           ; co_r <- uType t_or_k origin arg1 arg2
+           ; return $ mkFunCo Nominal co_l co_r }
+
+        -- Always defer if a type synonym family (type function)
+        -- is involved.  (Data families behave rigidly.)
+    go ty1@(TyConApp tc1 _) ty2
+      | isTypeFamilyTyCon tc1 = defer ty1 ty2
+    go ty1 ty2@(TyConApp tc2 _)
+      | isTypeFamilyTyCon tc2 = defer ty1 ty2
+
+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+      -- See Note [Mismatched type lists and application decomposition]
+      | tc1 == tc2, equalLength tys1 tys2
+      = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 )
+        do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2
+           ; return $ mkTyConAppCo Nominal tc1 cos }
+      where
+        origins' = map (\is_vis -> if is_vis then origin else toInvisibleOrigin origin)
+                       (tcTyConVisibilities tc1)
+
+    go (LitTy m) ty@(LitTy n)
+      | m == n
+      = return $ mkNomReflCo ty
+
+        -- See Note [Care with type applications]
+        -- Do not decompose FunTy against App;
+        -- it's often a type error, so leave it for the constraint solver
+    go (AppTy s1 t1) (AppTy s2 t2)
+      = go_app (isNextArgVisible s1) s1 t1 s2 t2
+
+    go (AppTy s1 t1) (TyConApp tc2 ts2)
+      | Just (ts2', t2') <- snocView ts2
+      = ASSERT( mightBeUnsaturatedTyCon tc2 )
+        go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'
+
+    go (TyConApp tc1 ts1) (AppTy s2 t2)
+      | Just (ts1', t1') <- snocView ts1
+      = ASSERT( mightBeUnsaturatedTyCon tc1 )
+        go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2
+
+    go (CoercionTy co1) (CoercionTy co2)
+      = do { let ty1 = coercionType co1
+                 ty2 = coercionType co2
+           ; kco <- uType KindLevel
+                          (KindEqOrigin orig_ty1 (Just orig_ty2) origin
+                                        (Just t_or_k))
+                          ty1 ty2
+           ; return $ mkProofIrrelCo Nominal kco co1 co2 }
+
+        -- Anything else fails
+        -- E.g. unifying for-all types, which is relative unusual
+    go ty1 ty2 = defer ty1 ty2
+
+    ------------------
+    defer ty1 ty2   -- See Note [Check for equality before deferring]
+      | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1)
+      | otherwise          = uType_defer t_or_k origin ty1 ty2
+
+    ------------------
+    go_app vis s1 t1 s2 t2
+      = do { co_s <- uType t_or_k origin s1 s2
+           ; let arg_origin
+                   | vis       = origin
+                   | otherwise = toInvisibleOrigin origin
+           ; co_t <- uType t_or_k arg_origin t1 t2
+           ; return $ mkAppCo co_s co_t }
+
+{- Note [Check for equality before deferring]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Particularly in ambiguity checks we can get equalities like (ty ~ ty).
+If ty involves a type function we may defer, which isn't very sensible.
+An egregious example of this was in test T9872a, which has a type signature
+       Proxy :: Proxy (Solutions Cubes)
+Doing the ambiguity check on this signature generates the equality
+   Solutions Cubes ~ Solutions Cubes
+and currently the constraint solver normalises both sides at vast cost.
+This little short-cut in 'defer' helps quite a bit.
+
+Note [Care with type applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note: type applications need a bit of care!
+They can match FunTy and TyConApp, so use splitAppTy_maybe
+NB: we've already dealt with type variables and Notes,
+so if one type is an App the other one jolly well better be too
+
+Note [Mismatched type lists and application decomposition]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we find two TyConApps, you might think that the argument lists
+are guaranteed equal length.  But they aren't. Consider matching
+        w (T x) ~ Foo (T x y)
+We do match (w ~ Foo) first, but in some circumstances we simply create
+a deferred constraint; and then go ahead and match (T x ~ T x y).
+This came up in Trac #3950.
+
+So either
+   (a) either we must check for identical argument kinds
+       when decomposing applications,
+
+   (b) or we must be prepared for ill-kinded unification sub-problems
+
+Currently we adopt (b) since it seems more robust -- no need to maintain
+a global invariant.
+
+Note [Expanding synonyms during unification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We expand synonyms during unification, but:
+ * We expand *after* the variable case so that we tend to unify
+   variables with un-expanded type synonym. This just makes it
+   more likely that the inferred types will mention type synonyms
+   understandable to the user
+
+ * Similarly, we expand *after* the CastTy case, just in case the
+   CastTy wraps a variable.
+
+ * We expand *before* the TyConApp case.  For example, if we have
+      type Phantom a = Int
+   and are unifying
+      Phantom Int ~ Phantom Char
+   it is *wrong* to unify Int and Char.
+
+ * The problem case immediately above can happen only with arguments
+   to the tycon. So we check for nullary tycons *before* expanding.
+   This is particularly helpful when checking (* ~ *), because * is
+   now a type synonym.
+
+Note [Deferred Unification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically,
+and yet its consistency is undetermined. Previously, there was no way to still
+make it consistent. So a mismatch error was issued.
+
+Now these unifications are deferred until constraint simplification, where type
+family instances and given equations may (or may not) establish the consistency.
+Deferred unifications are of the form
+                F ... ~ ...
+or              x ~ ...
+where F is a type function and x is a type variable.
+E.g.
+        id :: x ~ y => x -> y
+        id e = e
+
+involves the unification x = y. It is deferred until we bring into account the
+context x ~ y to establish that it holds.
+
+If available, we defer original types (rather than those where closed type
+synonyms have already been expanded via tcCoreView).  This is, as usual, to
+improve error messages.
+
+
+************************************************************************
+*                                                                      *
+                 uVar and friends
+*                                                                      *
+************************************************************************
+
+@uVar@ is called when at least one of the types being unified is a
+variable.  It does {\em not} assume that the variable is a fixed point
+of the substitution; rather, notice that @uVar@ (defined below) nips
+back into @uTys@ if it turns out that the variable is already bound.
+-}
+
+----------
+uUnfilledVar :: CtOrigin
+             -> TypeOrKind
+             -> SwapFlag
+             -> TcTyVar        -- Tyvar 1
+             -> TcTauType      -- Type 2
+             -> TcM Coercion
+-- "Unfilled" means that the variable is definitely not a filled-in meta tyvar
+--            It might be a skolem, or untouchable, or meta
+
+uUnfilledVar origin t_or_k swapped tv1 ty2
+  = do { ty2 <- zonkTcType ty2
+             -- Zonk to expose things to the
+             -- occurs check, and so that if ty2
+             -- looks like a type variable then it
+             -- /is/ a type variable
+       ; uUnfilledVar1 origin t_or_k swapped tv1 ty2 }
+
+----------
+uUnfilledVar1 :: CtOrigin
+              -> TypeOrKind
+              -> SwapFlag
+              -> TcTyVar        -- Tyvar 1
+              -> TcTauType      -- Type 2, zonked
+              -> TcM Coercion
+uUnfilledVar1 origin t_or_k swapped tv1 ty2
+  | Just tv2 <- tcGetTyVar_maybe ty2
+  = go tv2
+
+  | otherwise
+  = uUnfilledVar2 origin t_or_k swapped tv1 ty2
+
+  where
+    -- 'go' handles the case where both are
+    -- tyvars so we might want to swap
+    go tv2 | tv1 == tv2  -- Same type variable => no-op
+           = return (mkNomReflCo (mkTyVarTy tv1))
+
+           | swapOverTyVars tv1 tv2   -- Distinct type variables
+           = uUnfilledVar2 origin t_or_k (flipSwap swapped)
+                           tv2 (mkTyVarTy tv1)
+
+           | otherwise
+           = uUnfilledVar2 origin t_or_k swapped tv1 ty2
+
+----------
+uUnfilledVar2 :: CtOrigin
+              -> TypeOrKind
+              -> SwapFlag
+              -> TcTyVar        -- Tyvar 1
+              -> TcTauType      -- Type 2, zonked
+              -> TcM Coercion
+uUnfilledVar2 origin t_or_k swapped tv1 ty2
+  = do { dflags  <- getDynFlags
+       ; cur_lvl <- getTcLevel
+       ; go dflags cur_lvl }
+  where
+    go dflags cur_lvl
+      | canSolveByUnification cur_lvl tv1 ty2
+      , Just ty2' <- metaTyVarUpdateOK dflags tv1 ty2
+      = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2') (tyVarKind tv1)
+           ; traceTc "uUnfilledVar2 ok" $
+             vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)
+                  , ppr ty2 <+> dcolon <+> ppr (tcTypeKind  ty2)
+                  , ppr (isTcReflCo co_k), ppr co_k ]
+
+           ; if isTcReflCo co_k  -- only proceed if the kinds matched.
+
+             then do { writeMetaTyVar tv1 ty2'
+                     ; return (mkTcNomReflCo ty2') }
+
+             else defer } -- This cannot be solved now.  See TcCanonical
+                          -- Note [Equalities with incompatible kinds]
+
+      | otherwise
+      = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2)
+               -- Occurs check or an untouchable: just defer
+               -- NB: occurs check isn't necessarily fatal:
+               --     eg tv1 occured in type family parameter
+            ; defer }
+
+    ty1 = mkTyVarTy tv1
+    kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k)
+
+    defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2
+
+swapOverTyVars :: TcTyVar -> TcTyVar -> Bool
+swapOverTyVars tv1 tv2
+  -- Level comparison: see Note [TyVar/TyVar orientation]
+  | lvl1 `strictlyDeeperThan` lvl2 = False
+  | lvl2 `strictlyDeeperThan` lvl1 = True
+
+  -- Priority: see Note [TyVar/TyVar orientation]
+  | pri1 > pri2 = False
+  | pri2 > pri1 = True
+
+  -- Names: see Note [TyVar/TyVar orientation]
+  | isSystemName tv2_name, not (isSystemName tv1_name) = True
+
+  | otherwise = False
+
+  where
+    lvl1 = tcTyVarLevel tv1
+    lvl2 = tcTyVarLevel tv2
+    pri1 = lhsPriority tv1
+    pri2 = lhsPriority tv2
+    tv1_name = Var.varName tv1
+    tv2_name = Var.varName tv2
+
+
+lhsPriority :: TcTyVar -> Int
+-- Higher => more important to be on the LHS
+-- See Note [TyVar/TyVar orientation]
+lhsPriority tv
+  = ASSERT2( isTyVar tv, ppr tv)
+    case tcTyVarDetails tv of
+      RuntimeUnk  -> 0
+      SkolemTv {} -> 0
+      MetaTv { mtv_info = info } -> case info of
+                                     FlatSkolTv -> 1
+                                     TyVarTv    -> 2
+                                     TauTv      -> 3
+                                     FlatMetaTv -> 4
+{- Note [TyVar/TyVar orientation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given (a ~ b), should we orient the CTyEqCan as (a~b) or (b~a)?
+This is a surprisingly tricky question!
+
+First note: only swap if you have to!
+   See Note [Avoid unnecessary swaps]
+
+So we look for a positive reason to swap, using a three-step test:
+
+* Level comparison. If 'a' has deeper level than 'b',
+  put 'a' on the left.  See Note [Deeper level on the left]
+
+* Priority.  If the levels are the same, look at what kind of
+  type variable it is, using 'lhsPriority'
+
+  - FlatMetaTv: Always put on the left.
+    See Note [Fmv Orientation Invariant]
+    NB: FlatMetaTvs always have the current level, never an
+        outer one.  So nothing can be deeper than a FlatMetaTv
+
+
+  - TyVarTv/TauTv: if we have  tyv_tv ~ tau_tv, put tau_tv
+                   on the left because there are fewer
+                   restrictions on updating TauTvs
+
+  - TyVarTv/TauTv:  put on the left either
+     a) Because it's touchable and can be unified, or
+     b) Even if it's not touchable, TcSimplify.floatEqualities
+        looks for meta tyvars on the left
+
+  - FlatSkolTv: Put on the left in preference to a SkolemTv
+                See Note [Eliminate flat-skols]
+
+* Names. If the level and priority comparisons are all
+  equal, try to eliminate a TyVars with a System Name in
+  favour of ones with a Name derived from a user type signature
+
+* Age.  At one point in the past we tried to break any remaining
+  ties by eliminating the younger type variable, based on their
+  Uniques.  See Note [Eliminate younger unification variables]
+  (which also explains why we don't do this any more)
+
+Note [Deeper level on the left]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The most important thing is that we want to put tyvars with
+the deepest level on the left.  The reason to do so differs for
+Wanteds and Givens, but either way, deepest wins!  Simple.
+
+* Wanteds.  Putting the deepest variable on the left maximise the
+  chances that it's a touchable meta-tyvar which can be solved.
+
+* Givens. Suppose we have something like
+     forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2]
+
+  If we orient the Given a[2] on the left, we'll rewrite the Wanted to
+  (beta[1] ~ b[1]), and that can float out of the implication.
+  Otherwise it can't.  By putting the deepest variable on the left
+  we maximise our changes of eliminating skolem capture.
+
+  See also TcSMonad Note [Let-bound skolems] for another reason
+  to orient with the deepest skolem on the left.
+
+  IMPORTANT NOTE: this test does a level-number comparison on
+  skolems, so it's important that skolems have (accurate) level
+  numbers.
+
+See Trac #15009 for an further analysis of why "deepest on the left"
+is a good plan.
+
+Note [Fmv Orientation Invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   * We always orient a constraint
+        fmv ~ alpha
+     with fmv on the left, even if alpha is
+     a touchable unification variable
+
+Reason: doing it the other way round would unify alpha:=fmv, but that
+really doesn't add any info to alpha.  But a later constraint alpha ~
+Int might unlock everything.  Comment:9 of #12526 gives a detailed
+example.
+
+WARNING: I've gone to and fro on this one several times.
+I'm now pretty sure that unifying alpha:=fmv is a bad idea!
+So orienting with fmvs on the left is a good thing.
+
+This example comes from IndTypesPerfMerge. (Others include
+T10226, T10009.)
+    From the ambiguity check for
+      f :: (F a ~ a) => a
+    we get:
+          [G] F a ~ a
+          [WD] F alpha ~ alpha, alpha ~ a
+
+    From Givens we get
+          [G] F a ~ fsk, fsk ~ a
+
+    Now if we flatten we get
+          [WD] alpha ~ fmv, F alpha ~ fmv, alpha ~ a
+
+    Now, if we unified alpha := fmv, we'd get
+          [WD] F fmv ~ fmv, [WD] fmv ~ a
+    And now we are stuck.
+
+So instead the Fmv Orientation Invariant puts the fmv on the
+left, giving
+      [WD] fmv ~ alpha, [WD] F alpha ~ fmv, [WD] alpha ~ a
+
+    Now we get alpha:=a, and everything works out
+
+Note [Eliminate flat-skols]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have  [G] Num (F [a])
+then we flatten to
+     [G] Num fsk
+     [G] F [a] ~ fsk
+where fsk is a flatten-skolem (FlatSkolTv). Suppose we have
+      type instance F [a] = a
+then we'll reduce the second constraint to
+     [G] a ~ fsk
+and then replace all uses of 'a' with fsk.  That's bad because
+in error messages instead of saying 'a' we'll say (F [a]).  In all
+places, including those where the programmer wrote 'a' in the first
+place.  Very confusing!  See Trac #7862.
+
+Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate
+the fsk.
+
+Note [Avoid unnecessary swaps]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we swap without actually improving matters, we can get an infinite loop.
+Consider
+    work item:  a ~ b
+   inert item:  b ~ c
+We canonicalise the work-item to (a ~ c).  If we then swap it before
+adding to the inert set, we'll add (c ~ a), and therefore kick out the
+inert guy, so we get
+   new work item:  b ~ c
+   inert item:     c ~ a
+And now the cycle just repeats
+
+Note [Eliminate younger unification variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Given a choice of unifying
+     alpha := beta   or   beta := alpha
+we try, if possible, to eliminate the "younger" one, as determined
+by `ltUnique`.  Reason: the younger one is less likely to appear free in
+an existing inert constraint, and hence we are less likely to be forced
+into kicking out and rewriting inert constraints.
+
+This is a performance optimisation only.  It turns out to fix
+Trac #14723 all by itself, but clearly not reliably so!
+
+It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars).
+But, to my surprise, it didn't seem to make any significant difference
+to the compiler's performance, so I didn't take it any further.  Still
+it seemed to too nice to discard altogether, so I'm leaving these
+notes.  SLPJ Jan 18.
+-}
+
+-- @trySpontaneousSolve wi@ solves equalities where one side is a
+-- touchable unification variable.
+-- Returns True <=> spontaneous solve happened
+canSolveByUnification :: TcLevel -> TcTyVar -> TcType -> Bool
+canSolveByUnification tclvl tv xi
+  | isTouchableMetaTyVar tclvl tv
+  = case metaTyVarInfo tv of
+      TyVarTv -> is_tyvar xi
+      _       -> True
+
+  | otherwise    -- Untouchable
+  = False
+  where
+    is_tyvar xi
+      = case tcGetTyVar_maybe xi of
+          Nothing -> False
+          Just tv -> case tcTyVarDetails tv of
+                       MetaTv { mtv_info = info }
+                                   -> case info of
+                                        TyVarTv -> True
+                                        _       -> False
+                       SkolemTv {} -> True
+                       RuntimeUnk  -> True
+
+{- Note [Prevent unification with type families]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We prevent unification with type families because of an uneasy compromise.
+It's perfectly sound to unify with type families, and it even improves the
+error messages in the testsuite. It also modestly improves performance, at
+least in some cases. But it's disastrous for test case perf/compiler/T3064.
+Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a.
+What do we do? Do we reduce F? Or do we use the given? Hard to know what's
+best. GHC reduces. This is a disaster for T3064, where the type's size
+spirals out of control during reduction. (We're not helped by the fact that
+the flattener re-flattens all the arguments every time around.) If we prevent
+unification with type families, then the solver happens to use the equality
+before expanding the type family.
+
+It would be lovely in the future to revisit this problem and remove this
+extra, unnecessary check. But we retain it for now as it seems to work
+better in practice.
+
+Note [Refactoring hazard: checkTauTvUpdate]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+I (Richard E.) have a sad story about refactoring this code, retained here
+to prevent others (or a future me!) from falling into the same traps.
+
+It all started with #11407, which was caused by the fact that the TyVarTy
+case of defer_me didn't look in the kind. But it seemed reasonable to
+simply remove the defer_me check instead.
+
+It referred to two Notes (since removed) that were out of date, and the
+fast_check code in occurCheckExpand seemed to do just about the same thing as
+defer_me. The one piece that defer_me did that wasn't repeated by
+occurCheckExpand was the type-family check. (See Note [Prevent unification
+with type families].) So I checked the result of occurCheckExpand for any
+type family occurrences and deferred if there were any. This was done
+in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 .
+
+This approach turned out not to be performant, because the expanded
+type was bigger than the original type, and tyConsOfType (needed to
+see if there are any type family occurrences) looks through type
+synonyms. So it then struck me that we could dispense with the
+defer_me check entirely. This simplified the code nicely, and it cut
+the allocations in T5030 by half. But, as documented in Note [Prevent
+unification with type families], this destroyed performance in
+T3064. Regardless, I missed this regression and the change was
+committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d .
+
+Bottom lines:
+ * defer_me is back, but now fixed w.r.t. #11407.
+ * Tread carefully before you start to refactor here. There can be
+   lots of hard-to-predict consequences.
+
+Note [Type synonyms and the occur check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally speaking we try to update a variable with type synonyms not
+expanded, which improves later error messages, unless looking
+inside a type synonym may help resolve a spurious occurs check
+error. Consider:
+          type A a = ()
+
+          f :: (A a -> a -> ()) -> ()
+          f = \ _ -> ()
+
+          x :: ()
+          x = f (\ x p -> p x)
+
+We will eventually get a constraint of the form t ~ A t. The ok function above will
+properly expand the type (A t) to just (), which is ok to be unified with t. If we had
+unified with the original type A t, we would lead the type checker into an infinite loop.
+
+Hence, if the occurs check fails for a type synonym application, then (and *only* then),
+the ok function expands the synonym to detect opportunities for occurs check success using
+the underlying definition of the type synonym.
+
+The same applies later on in the constraint interaction code; see TcInteract,
+function @occ_check_ok@.
+
+Note [Non-TcTyVars in TcUnify]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Because the same code is now shared between unifying types and unifying
+kinds, we sometimes will see proper TyVars floating around the unifier.
+Example (from test case polykinds/PolyKinds12):
+
+    type family Apply (f :: k1 -> k2) (x :: k1) :: k2
+    type instance Apply g y = g y
+
+When checking the instance declaration, we first *kind-check* the LHS
+and RHS, discovering that the instance really should be
+
+    type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y
+
+During this kind-checking, all the tyvars will be TcTyVars. Then, however,
+as a second pass, we desugar the RHS (which is done in functions prefixed
+with "tc" in TcTyClsDecls"). By this time, all the kind-vars are proper
+TyVars, not TcTyVars, get some kind unification must happen.
+
+Thus, we always check if a TyVar is a TcTyVar before asking if it's a
+meta-tyvar.
+
+This used to not be necessary for type-checking (that is, before * :: *)
+because expressions get desugared via an algorithm separate from
+type-checking (with wrappers, etc.). Types get desugared very differently,
+causing this wibble in behavior seen here.
+-}
+
+data LookupTyVarResult  -- The result of a lookupTcTyVar call
+  = Unfilled TcTyVarDetails     -- SkolemTv or virgin MetaTv
+  | Filled   TcType
+
+lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult
+lookupTcTyVar tyvar
+  | MetaTv { mtv_ref = ref } <- details
+  = do { meta_details <- readMutVar ref
+       ; case meta_details of
+           Indirect ty -> return (Filled ty)
+           Flexi -> do { is_touchable <- isTouchableTcM tyvar
+                             -- Note [Unifying untouchables]
+                       ; if is_touchable then
+                            return (Unfilled details)
+                         else
+                            return (Unfilled vanillaSkolemTv) } }
+  | otherwise
+  = return (Unfilled details)
+  where
+    details = tcTyVarDetails tyvar
+
+{-
+Note [Unifying untouchables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We treat an untouchable type variable as if it was a skolem.  That
+ensures it won't unify with anything.  It's a slight hack, because
+we return a made-up TcTyVarDetails, but I think it works smoothly.
+-}
+
+-- | Breaks apart a function kind into its pieces.
+matchExpectedFunKind :: Outputable fun
+                     => fun             -- ^ type, only for errors
+                     -> TcKind          -- ^ function kind
+                     -> TcM (Coercion, TcKind, TcKind)
+                                  -- ^ co :: old_kind ~ arg -> res
+matchExpectedFunKind hs_ty = go
+  where
+    go k | Just k' <- tcView k = go k'
+
+    go k@(TyVarTy kvar)
+      | isMetaTyVar kvar
+      = do { maybe_kind <- readMetaTyVar kvar
+           ; case maybe_kind of
+                Indirect fun_kind -> go fun_kind
+                Flexi ->             defer k }
+
+    go k@(FunTy arg res) = return (mkNomReflCo k, arg, res)
+    go other             = defer other
+
+    defer k
+      = do { arg_kind <- newMetaKindVar
+           ; res_kind <- newMetaKindVar
+           ; let new_fun = mkFunTy arg_kind res_kind
+                 origin  = TypeEqOrigin { uo_actual   = k
+                                        , uo_expected = new_fun
+                                        , uo_thing    = Just (ppr hs_ty)
+                                        , uo_visible  = True
+                                        }
+           ; co <- uType KindLevel origin k new_fun
+           ; return (co, arg_kind, res_kind) }
+
+
+{- *********************************************************************
+*                                                                      *
+                 Occurrence checking
+*                                                                      *
+********************************************************************* -}
+
+
+{-  Note [Occurrence checking: look inside kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are considering unifying
+   (alpha :: *)  ~  Int -> (beta :: alpha -> alpha)
+This may be an error (what is that alpha doing inside beta's kind?),
+but we must not make the mistake of actually unifying or we'll
+build an infinite data structure.  So when looking for occurrences
+of alpha in the rhs, we must look in the kinds of type variables
+that occur there.
+
+NB: we may be able to remove the problem via expansion; see
+    Note [Occurs check expansion].  So we have to try that.
+
+Note [Checking for foralls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unless we have -XImpredicativeTypes (which is a totally unsupported
+feature), we do not want to unify
+    alpha ~ (forall a. a->a) -> Int
+So we look for foralls hidden inside the type, and it's convenient
+to do that at the same time as the occurs check (which looks for
+occurrences of alpha).
+
+However, it's not just a question of looking for foralls /anywhere/!
+Consider
+   (alpha :: forall k. k->*)  ~  (beta :: forall k. k->*)
+This is legal; e.g. dependent/should_compile/T11635.
+
+We don't want to reject it because of the forall in beta's kind,
+but (see Note [Occurrence checking: look inside kinds]) we do
+need to look in beta's kind.  So we carry a flag saying if a 'forall'
+is OK, and sitch the flag on when stepping inside a kind.
+
+Why is it OK?  Why does it not count as impredicative polymorphism?
+The reason foralls are bad is because we reply on "seeing" foralls
+when doing implicit instantiation.  But the forall inside the kind is
+fine.  We'll generate a kind equality constraint
+  (forall k. k->*) ~ (forall k. k->*)
+to check that the kinds of lhs and rhs are compatible.  If alpha's
+kind had instead been
+  (alpha :: kappa)
+then this kind equality would rightly complain about unifying kappa
+with (forall k. k->*)
+
+-}
+
+data OccCheckResult a
+  = OC_OK a
+  | OC_Bad     -- Forall or type family
+  | OC_Occurs
+
+instance Functor OccCheckResult where
+      fmap = liftM
+
+instance Applicative OccCheckResult where
+      pure = OC_OK
+      (<*>) = ap
+
+instance Monad OccCheckResult where
+  OC_OK x    >>= k = k x
+  OC_Bad     >>= _ = OC_Bad
+  OC_Occurs  >>= _ = OC_Occurs
+
+occCheckForErrors :: DynFlags -> TcTyVar -> Type -> OccCheckResult ()
+-- Just for error-message generation; so we return OccCheckResult
+-- so the caller can report the right kind of error
+-- Check whether
+--   a) the given variable occurs in the given type.
+--   b) there is a forall in the type (unless we have -XImpredicativeTypes)
+occCheckForErrors dflags tv ty
+  = case preCheck dflags True tv ty of
+      OC_OK _   -> OC_OK ()
+      OC_Bad    -> OC_Bad
+      OC_Occurs -> case occCheckExpand [tv] ty of
+                     Nothing -> OC_Occurs
+                     Just _  -> OC_OK ()
+
+----------------
+metaTyVarUpdateOK :: DynFlags
+                  -> TcTyVar             -- tv :: k1
+                  -> TcType              -- ty :: k2
+                  -> Maybe TcType        -- possibly-expanded ty
+-- (metaTyFVarUpdateOK tv ty)
+-- We are about to update the meta-tyvar tv with ty
+-- Check (a) that tv doesn't occur in ty (occurs check)
+--       (b) that ty does not have any foralls
+--           (in the impredicative case), or type functions
+--
+-- We have two possible outcomes:
+-- (1) Return the type to update the type variable with,
+--        [we know the update is ok]
+-- (2) Return Nothing,
+--        [the update might be dodgy]
+--
+-- Note that "Nothing" does not mean "definite error".  For example
+--   type family F a
+--   type instance F Int = Int
+-- consider
+--   a ~ F a
+-- This is perfectly reasonable, if we later get a ~ Int.  For now, though,
+-- we return Nothing, leaving it to the later constraint simplifier to
+-- sort matters out.
+--
+-- See Note [Refactoring hazard: checkTauTvUpdate]
+
+metaTyVarUpdateOK dflags tv ty
+  = case preCheck dflags False tv ty of
+         -- False <=> type families not ok
+         -- See Note [Prevent unification with type families]
+      OC_OK _   -> Just ty
+      OC_Bad    -> Nothing  -- forall or type function
+      OC_Occurs -> occCheckExpand [tv] ty
+
+preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> OccCheckResult ()
+-- A quick check for
+--   (a) a forall type (unless -XImpredivativeTypes)
+--   (b) a type family
+--   (c) an occurrence of the type variable (occurs check)
+--
+-- For (a) and (b) we check only the top level of the type, NOT
+-- inside the kinds of variables it mentions.  But for (c) we do
+-- look in the kinds of course.
+
+preCheck dflags ty_fam_ok tv ty
+  = fast_check ty
+  where
+    details          = tcTyVarDetails tv
+    impredicative_ok = canUnifyWithPolyType dflags details
+
+    ok :: OccCheckResult ()
+    ok = OC_OK ()
+
+    fast_check :: TcType -> OccCheckResult ()
+    fast_check (TyVarTy tv')
+      | tv == tv' = OC_Occurs
+      | otherwise = fast_check_occ (tyVarKind tv')
+           -- See Note [Occurrence checking: look inside kinds]
+
+    fast_check (TyConApp tc tys)
+      | bad_tc tc              = OC_Bad
+      | otherwise              = mapM fast_check tys >> ok
+    fast_check (LitTy {})      = ok
+    fast_check (FunTy a r)     = fast_check a   >> fast_check r
+    fast_check (AppTy fun arg) = fast_check fun >> fast_check arg
+    fast_check (CastTy ty co)  = fast_check ty  >> fast_check_co co
+    fast_check (CoercionTy co) = fast_check_co co
+    fast_check (ForAllTy (Bndr tv' _) ty)
+       | not impredicative_ok = OC_Bad
+       | tv == tv'            = ok
+       | otherwise = do { fast_check_occ (tyVarKind tv')
+                        ; fast_check_occ ty }
+       -- Under a forall we look only for occurrences of
+       -- the type variable
+
+     -- For kinds, we only do an occurs check; we do not worry
+     -- about type families or foralls
+     -- See Note [Checking for foralls]
+    fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = OC_Occurs
+                     | otherwise                        = ok
+
+     -- For coercions, we are only doing an occurs check here;
+     -- no bother about impredicativity in coercions, as they're
+     -- inferred
+    fast_check_co co | tv `elemVarSet` tyCoVarsOfCo co = OC_Occurs
+                     | otherwise                       = ok
+
+    bad_tc :: TyCon -> Bool
+    bad_tc tc
+      | not (impredicative_ok || isTauTyCon tc)     = True
+      | not (ty_fam_ok        || isFamFreeTyCon tc) = True
+      | otherwise                                   = False
+
+canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> Bool
+canUnifyWithPolyType dflags details
+  = case details of
+      MetaTv { mtv_info = TyVarTv }    -> False
+      MetaTv { mtv_info = TauTv }      -> xopt LangExt.ImpredicativeTypes dflags
+      _other                           -> True
+          -- We can have non-meta tyvars in given constraints
diff --git a/compiler/typecheck/TcUnify.hs-boot b/compiler/typecheck/TcUnify.hs-boot
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcUnify.hs-boot
@@ -0,0 +1,15 @@
+module TcUnify where
+
+import GhcPrelude
+import TcType      ( TcTauType )
+import TcRnTypes   ( TcM )
+import TcEvidence  ( TcCoercion )
+import HsExpr      ( HsExpr )
+import HsTypes     ( HsType )
+import HsExtension ( GhcRn )
+
+-- This boot file exists only to tie the knot between
+--              TcUnify and Inst
+
+unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion
+unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion
diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
new file mode 100644
--- /dev/null
+++ b/compiler/typecheck/TcValidity.hs
@@ -0,0 +1,2657 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+
+{-# LANGUAGE CPP, TupleSections, ViewPatterns #-}
+
+module TcValidity (
+  Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
+  checkValidTheta,
+  checkValidInstance, checkValidInstHead, validDerivPred,
+  checkTySynRhs,
+  checkValidCoAxiom, checkValidCoAxBranch,
+  checkValidTyFamEqn, checkConsistentFamInst,
+  badATErr, arityErr,
+  checkValidTelescope,
+  allDistinctTyVars
+  ) where
+
+#include "HsVersions.h"
+
+import GhcPrelude
+
+import Maybes
+
+-- friends:
+import TcUnify    ( tcSubType_NC )
+import TcSimplify ( simplifyAmbiguityCheck )
+import ClsInst    ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) )
+import TyCoRep
+import TcType hiding ( sizeType, sizeTypes )
+import TysWiredIn ( heqTyConName, eqTyConName, coercibleTyConName )
+import PrelNames
+import Type
+import Unify      ( tcMatchTyX_BM, BindFlag(..) )
+import Coercion
+import CoAxiom
+import Class
+import TyCon
+
+-- others:
+import IfaceType( pprIfaceType, pprIfaceTypeApp )
+import ToIface( toIfaceType, toIfaceTyCon, toIfaceTcArgs )
+import HsSyn            -- HsType
+import TcRnMonad        -- TcType, amongst others
+import TcEnv       ( tcInitTidyEnv, tcInitOpenTidyEnv )
+import FunDeps
+import FamInstEnv  ( isDominatedBy, injectiveBranches,
+                     InjectivityCheckResult(..) )
+import FamInst     ( makeInjectivityErrors )
+import Name
+import VarEnv
+import VarSet
+import Var         ( VarBndr(..), mkTyVar )
+import Id          ( idType, idName )
+import FV
+import ErrUtils
+import DynFlags
+import Util
+import ListSetOps
+import SrcLoc
+import Outputable
+import Unique      ( mkAlphaTyVarUnique )
+import Bag         ( emptyBag )
+import qualified GHC.LanguageExtensions as LangExt
+
+import Control.Monad
+import Data.Foldable
+import Data.List        ( (\\), nub )
+import qualified Data.List.NonEmpty as NE
+
+{-
+************************************************************************
+*                                                                      *
+          Checking for ambiguity
+*                                                                      *
+************************************************************************
+
+Note [The ambiguity check for type signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+checkAmbiguity is a check on *user-supplied type signatures*.  It is
+*purely* there to report functions that cannot possibly be called.  So for
+example we want to reject:
+   f :: C a => Int
+The idea is there can be no legal calls to 'f' because every call will
+give rise to an ambiguous constraint.  We could soundly omit the
+ambiguity check on type signatures entirely, at the expense of
+delaying ambiguity errors to call sites.  Indeed, the flag
+-XAllowAmbiguousTypes switches off the ambiguity check.
+
+What about things like this:
+   class D a b | a -> b where ..
+   h :: D Int b => Int
+The Int may well fix 'b' at the call site, so that signature should
+not be rejected.  Moreover, using *visible* fundeps is too
+conservative.  Consider
+   class X a b where ...
+   class D a b | a -> b where ...
+   instance D a b => X [a] b where...
+   h :: X a b => a -> a
+Here h's type looks ambiguous in 'b', but here's a legal call:
+   ...(h [True])...
+That gives rise to a (X [Bool] beta) constraint, and using the
+instance means we need (D Bool beta) and that fixes 'beta' via D's
+fundep!
+
+Behind all these special cases there is a simple guiding principle.
+Consider
+
+  f :: <type>
+  f = ...blah...
+
+  g :: <type>
+  g = f
+
+You would think that the definition of g would surely typecheck!
+After all f has exactly the same type, and g=f. But in fact f's type
+is instantiated and the instantiated constraints are solved against
+the originals, so in the case an ambiguous type it won't work.
+Consider our earlier example f :: C a => Int.  Then in g's definition,
+we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a),
+and fail.
+
+So in fact we use this as our *definition* of ambiguity.  We use a
+very similar test for *inferred* types, to ensure that they are
+unambiguous. See Note [Impedance matching] in TcBinds.
+
+This test is very conveniently implemented by calling
+    tcSubType <type> <type>
+This neatly takes account of the functional dependecy stuff above,
+and implicit parameter (see Note [Implicit parameters and ambiguity]).
+And this is what checkAmbiguity does.
+
+What about this, though?
+   g :: C [a] => Int
+Is every call to 'g' ambiguous?  After all, we might have
+   instance C [a] where ...
+at the call site.  So maybe that type is ok!  Indeed even f's
+quintessentially ambiguous type might, just possibly be callable:
+with -XFlexibleInstances we could have
+  instance C a where ...
+and now a call could be legal after all!  Well, we'll reject this
+unless the instance is available *here*.
+
+Note [When to call checkAmbiguity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We call checkAmbiguity
+   (a) on user-specified type signatures
+   (b) in checkValidType
+
+Conncerning (b), you might wonder about nested foralls.  What about
+    f :: forall b. (forall a. Eq a => b) -> b
+The nested forall is ambiguous.  Originally we called checkAmbiguity
+in the forall case of check_type, but that had two bad consequences:
+  * We got two error messages about (Eq b) in a nested forall like this:
+       g :: forall a. Eq a => forall b. Eq b => a -> a
+  * If we try to check for ambiguity of a nested forall like
+    (forall a. Eq a => b), the implication constraint doesn't bind
+    all the skolems, which results in "No skolem info" in error
+    messages (see Trac #10432).
+
+To avoid this, we call checkAmbiguity once, at the top, in checkValidType.
+(I'm still a bit worried about unbound skolems when the type mentions
+in-scope type variables.)
+
+In fact, because of the co/contra-variance implemented in tcSubType,
+this *does* catch function f above. too.
+
+Concerning (a) the ambiguity check is only used for *user* types, not
+for types coming from inteface files.  The latter can legitimately
+have ambiguous types. Example
+
+   class S a where s :: a -> (Int,Int)
+   instance S Char where s _ = (1,1)
+   f:: S a => [a] -> Int -> (Int,Int)
+   f (_::[a]) x = (a*x,b)
+        where (a,b) = s (undefined::a)
+
+Here the worker for f gets the type
+        fw :: forall a. S a => Int -> (# Int, Int #)
+
+
+Note [Implicit parameters and ambiguity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Only a *class* predicate can give rise to ambiguity
+An *implicit parameter* cannot.  For example:
+        foo :: (?x :: [a]) => Int
+        foo = length ?x
+is fine.  The call site will supply a particular 'x'
+
+Furthermore, the type variables fixed by an implicit parameter
+propagate to the others.  E.g.
+        foo :: (Show a, ?x::[a]) => Int
+        foo = show (?x++?x)
+The type of foo looks ambiguous.  But it isn't, because at a call site
+we might have
+        let ?x = 5::Int in foo
+and all is well.  In effect, implicit parameters are, well, parameters,
+so we can take their type variables into account as part of the
+"tau-tvs" stuff.  This is done in the function 'FunDeps.grow'.
+-}
+
+checkAmbiguity :: UserTypeCtxt -> Type -> TcM ()
+checkAmbiguity ctxt ty
+  | wantAmbiguityCheck ctxt
+  = do { traceTc "Ambiguity check for" (ppr ty)
+         -- Solve the constraints eagerly because an ambiguous type
+         -- can cause a cascade of further errors.  Since the free
+         -- tyvars are skolemised, we can safely use tcSimplifyTop
+       ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes
+       ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $
+                            captureConstraints $
+                            tcSubType_NC ctxt ty ty
+       ; simplifyAmbiguityCheck ty wanted
+
+       ; traceTc "Done ambiguity check for" (ppr ty) }
+
+  | otherwise
+  = return ()
+ where
+   mk_msg allow_ambiguous
+     = vcat [ text "In the ambiguity check for" <+> what
+            , ppUnless allow_ambiguous ambig_msg ]
+   ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes"
+   what | Just n <- isSigMaybe ctxt = quotes (ppr n)
+        | otherwise                 = pprUserTypeCtxt ctxt
+
+wantAmbiguityCheck :: UserTypeCtxt -> Bool
+wantAmbiguityCheck ctxt
+  = case ctxt of  -- See Note [When we don't check for ambiguity]
+      GhciCtxt {}  -> False
+      TySynCtxt {} -> False
+      TypeAppCtxt  -> False
+      _            -> True
+
+checkUserTypeError :: Type -> TcM ()
+-- Check to see if the type signature mentions "TypeError blah"
+-- anywhere in it, and fail if so.
+--
+-- Very unsatisfactorily (Trac #11144) we need to tidy the type
+-- because it may have come from an /inferred/ signature, not a
+-- user-supplied one.  This is really only a half-baked fix;
+-- the other errors in checkValidType don't do tidying, and so
+-- may give bad error messages when given an inferred type.
+checkUserTypeError = check
+  where
+  check ty
+    | Just msg     <- userTypeError_maybe ty  = fail_with msg
+    | Just (_,ts)  <- splitTyConApp_maybe ty  = mapM_ check ts
+    | Just (t1,t2) <- splitAppTy_maybe ty     = check t1 >> check t2
+    | Just (_,t1)  <- splitForAllTy_maybe ty  = check t1
+    | otherwise                               = return ()
+
+  fail_with msg = do { env0 <- tcInitTidyEnv
+                     ; let (env1, tidy_msg) = tidyOpenType env0 msg
+                     ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) }
+
+
+{- Note [When we don't check for ambiguity]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a few places we do not want to check a user-specified type for ambiguity
+
+* GhciCtxt: Allow ambiguous types in GHCi's :kind command
+  E.g.   type family T a :: *  -- T :: forall k. k -> *
+  Then :k T should work in GHCi, not complain that
+  (T k) is ambiguous!
+
+* TySynCtxt: type T a b = C a b => blah
+  It may be that when we /use/ T, we'll give an 'a' or 'b' that somehow
+  cure the ambiguity.  So we defer the ambiguity check to the use site.
+
+  There is also an implementation reason (Trac #11608).  In the RHS of
+  a type synonym we don't (currently) instantiate 'a' and 'b' with
+  TcTyVars before calling checkValidType, so we get asertion failures
+  from doing an ambiguity check on a type with TyVars in it.  Fixing this
+  would not be hard, but let's wait till there's a reason.
+
+* TypeAppCtxt: visible type application
+     f @ty
+  No need to check ty for ambiguity
+
+
+************************************************************************
+*                                                                      *
+          Checking validity of a user-defined type
+*                                                                      *
+************************************************************************
+
+When dealing with a user-written type, we first translate it from an HsType
+to a Type, performing kind checking, and then check various things that should
+be true about it.  We don't want to perform these checks at the same time
+as the initial translation because (a) they are unnecessary for interface-file
+types and (b) when checking a mutually recursive group of type and class decls,
+we can't "look" at the tycons/classes yet.  Also, the checks are rather
+diverse, and used to really mess up the other code.
+
+One thing we check for is 'rank'.
+
+        Rank 0:         monotypes (no foralls)
+        Rank 1:         foralls at the front only, Rank 0 inside
+        Rank 2:         foralls at the front, Rank 1 on left of fn arrow,
+
+        basic ::= tyvar | T basic ... basic
+
+        r2  ::= forall tvs. cxt => r2a
+        r2a ::= r1 -> r2a | basic
+        r1  ::= forall tvs. cxt => r0
+        r0  ::= r0 -> r0 | basic
+
+Another thing is to check that type synonyms are saturated.
+This might not necessarily show up in kind checking.
+        type A i = i
+        data T k = MkT (k Int)
+        f :: T A        -- BAD!
+-}
+
+checkValidType :: UserTypeCtxt -> Type -> TcM ()
+-- Checks that a user-written type is valid for the given context
+-- Assumes argument is fully zonked
+-- Not used for instance decls; checkValidInstance instead
+checkValidType ctxt ty
+  = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty))
+       ; rankn_flag  <- xoptM LangExt.RankNTypes
+       ; impred_flag <- xoptM LangExt.ImpredicativeTypes
+       ; let gen_rank :: Rank -> Rank
+             gen_rank r | rankn_flag = ArbitraryRank
+                        | otherwise  = r
+
+             rank1 = gen_rank r1
+             rank0 = gen_rank r0
+
+             r0 = rankZeroMonoType
+             r1 = LimitedRank True r0
+
+             rank
+               = case ctxt of
+                 DefaultDeclCtxt-> MustBeMonoType
+                 ResSigCtxt     -> MustBeMonoType
+                 PatSigCtxt     -> rank0
+                 RuleSigCtxt _  -> rank1
+                 TySynCtxt _    -> rank0
+
+                 ExprSigCtxt    -> rank1
+                 KindSigCtxt    -> rank1
+                 TypeAppCtxt | impred_flag -> ArbitraryRank
+                             | otherwise   -> tyConArgMonoType
+                    -- Normally, ImpredicativeTypes is handled in check_arg_type,
+                    -- but visible type applications don't go through there.
+                    -- So we do this check here.
+
+                 FunSigCtxt {}  -> rank1
+                 InfSigCtxt _   -> ArbitraryRank        -- Inferred type
+                 ConArgCtxt _   -> rank1 -- We are given the type of the entire
+                                         -- constructor, hence rank 1
+                 PatSynCtxt _   -> rank1
+
+                 ForSigCtxt _   -> rank1
+                 SpecInstCtxt   -> rank1
+                 ThBrackCtxt    -> rank1
+                 GhciCtxt {}    -> ArbitraryRank
+
+                 TyVarBndrKindCtxt _ -> rank0
+                 DataKindCtxt _      -> rank1
+                 TySynKindCtxt _     -> rank1
+                 TyFamResKindCtxt _  -> rank1
+
+                 _              -> panic "checkValidType"
+                                          -- Can't happen; not used for *user* sigs
+
+       ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty)
+       ; expand <- initialExpandMode
+       ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt
+                             , ve_rank = rank, ve_expand = expand }
+
+       -- Check the internal validity of the type itself
+       -- Fail if bad things happen, else we misleading
+       -- (and more complicated) errors in checkAmbiguity
+       ; checkNoErrs $
+         do { check_type ve ty
+            ; checkUserTypeError ty
+            ; traceTc "done ct" (ppr ty) }
+
+       -- Check for ambiguous types.  See Note [When to call checkAmbiguity]
+       -- NB: this will happen even for monotypes, but that should be cheap;
+       --     and there may be nested foralls for the subtype test to examine
+       ; checkAmbiguity ctxt ty
+
+       ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) }
+
+checkValidMonoType :: Type -> TcM ()
+-- Assumes argument is fully zonked
+checkValidMonoType ty
+  = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty)
+       ; expand <- initialExpandMode
+       ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = SigmaCtxt
+                             , ve_rank = MustBeMonoType, ve_expand = expand }
+       ; check_type ve ty }
+
+checkTySynRhs :: UserTypeCtxt -> TcType -> TcM ()
+checkTySynRhs ctxt ty
+  | tcReturnsConstraintKind actual_kind
+  = do { ck <- xoptM LangExt.ConstraintKinds
+       ; if ck
+         then  when (tcIsConstraintKind actual_kind)
+                    (do { dflags <- getDynFlags
+                        ; expand <- initialExpandMode
+                        ; check_pred_ty emptyTidyEnv dflags ctxt expand ty })
+         else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) }
+
+  | otherwise
+  = return ()
+  where
+    actual_kind = tcTypeKind ty
+
+{-
+Note [Higher rank types]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Technically
+            Int -> forall a. a->a
+is still a rank-1 type, but it's not Haskell 98 (Trac #5957).  So the
+validity checker allow a forall after an arrow only if we allow it
+before -- that is, with Rank2Types or RankNTypes
+-}
+
+data Rank = ArbitraryRank         -- Any rank ok
+
+          | LimitedRank   -- Note [Higher rank types]
+                 Bool     -- Forall ok at top
+                 Rank     -- Use for function arguments
+
+          | MonoType SDoc   -- Monotype, with a suggestion of how it could be a polytype
+
+          | MustBeMonoType  -- Monotype regardless of flags
+
+instance Outputable Rank where
+  ppr ArbitraryRank  = text "ArbitraryRank"
+  ppr (LimitedRank top_forall_ok r)
+                     = text "LimitedRank" <+> ppr top_forall_ok
+                                          <+> parens (ppr r)
+  ppr (MonoType msg) = text "MonoType" <+> parens msg
+  ppr MustBeMonoType = text "MustBeMonoType"
+
+rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank
+rankZeroMonoType   = MonoType (text "Perhaps you intended to use RankNTypes")
+tyConArgMonoType   = MonoType (text "GHC doesn't yet support impredicative polymorphism")
+synArgMonoType     = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms")
+constraintMonoType = MonoType (vcat [ text "A constraint must be a monotype"
+                                    , text "Perhaps you intended to use QuantifiedConstraints" ])
+
+funArgResRank :: Rank -> (Rank, Rank)             -- Function argument and result
+funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank)
+funArgResRank other_rank               = (other_rank, other_rank)
+
+forAllAllowed :: Rank -> Bool
+forAllAllowed ArbitraryRank             = True
+forAllAllowed (LimitedRank forall_ok _) = forall_ok
+forAllAllowed _                         = False
+
+constraintsAllowed :: UserTypeCtxt -> Bool
+-- We don't allow constraints in kinds
+constraintsAllowed (TyVarBndrKindCtxt {}) = False
+constraintsAllowed (DataKindCtxt {})      = False
+constraintsAllowed (TySynKindCtxt {})     = False
+constraintsAllowed (TyFamResKindCtxt {})  = False
+constraintsAllowed _ = True
+
+{-
+Note [Correctness and performance of type synonym validity checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the type A arg1 arg2, where A is a type synonym. How should we check
+this type for validity? We have three distinct choices, corresponding to the
+three constructors of ExpandMode:
+
+1. Expand the application of A, and check the resulting type (`Expand`).
+2. Don't expand the application of A. Only check the arguments (`NoExpand`).
+3. Check the arguments *and* check the expanded type (`Both`).
+
+It's tempting to think that we could always just pick choice (3), but this
+results in serious performance issues when checking a type like in the
+signature for `f` below:
+
+  type S = ...
+  f :: S (S (S (S (S (S ....(S Int)...))))
+
+When checking the type of `f`, we'll check the outer `S` application with and
+without expansion, and in *each* of those checks, we'll check the next `S`
+application with and without expansion... the result is exponential blowup! So
+clearly we don't want to use `Both` 100% of the time.
+
+On the other hand, neither is it correct to use exclusively `Expand` or
+exclusively `NoExpand` 100% of the time:
+
+* If one always expands, then one can miss erroneous programs like the one in
+  the `tcfail129` test case:
+
+    type Foo a = String -> Maybe a
+    type Bar m = m Int
+    blah = undefined :: Bar Foo
+
+  If we expand `Bar Foo` immediately, we'll miss the fact that the `Foo` type
+  synonyms is unsaturated.
+* If one never expands and only checks the arguments, then one can miss
+  erroneous programs like the one in Trac #16059:
+
+    type Foo b = Eq b => b
+    f :: forall b (a :: Foo b). Int
+
+  The kind of `a` contains a constraint, which is illegal, but this will only
+  be caught if `Foo b` is expanded.
+
+Therefore, it's impossible to have these validity checks be simultaneously
+correct and performant if one sticks exclusively to a single `ExpandMode`. In
+that case, the solution is to vary the `ExpandMode`s! In more detail:
+
+1. When we start validity checking, we start with `Expand` if
+   LiberalTypeSynonyms is enabled (see Note [Liberal type synonyms] for why we
+   do this), and we start with `Both` otherwise. The `initialExpandMode`
+   function is responsible for this.
+2. When expanding an application of a type synonym (in `check_syn_tc_app`), we
+   determine which things to check based on the current `ExpandMode` argument.
+   Importantly, if the current mode is `Both`, then we check the arguments in
+   `NoExpand` mode and check the expanded type in `Both` mode.
+
+   Switching to `NoExpand` when checking the arguments is vital to avoid
+   exponential blowup. One consequence of this choice is that if you have
+   the following type synonym in one module (with RankNTypes enabled):
+
+     {-# LANGUAGE RankNTypes #-}
+     module A where
+     type A = forall a. a
+
+   And you define the following in a separate module *without* RankNTypes
+   enabled:
+
+     module B where
+
+     import A
+
+     type Const a b = a
+     f :: Const Int A -> Int
+
+   Then `f` will be accepted, even though `A` (which is technically a rank-n
+   type) appears in its type. We view this as an acceptable compromise, since
+   `A` never appears in the type of `f` post-expansion. If `A` _did_ appear in
+   a type post-expansion, such as in the following variant:
+
+     g :: Const A A -> Int
+
+   Then that would be rejected unless RankNTypes were enabled.
+-}
+
+-- | When validity-checking an application of a type synonym, should we
+-- check the arguments, check the expanded type, or both?
+-- See Note [Correctness and performance of type synonym validity checking]
+data ExpandMode
+  = Expand   -- ^ Only check the expanded type.
+  | NoExpand -- ^ Only check the arguments.
+  | Both     -- ^ Check both the arguments and the expanded type.
+
+instance Outputable ExpandMode where
+  ppr e = text $ case e of
+                   Expand   -> "Expand"
+                   NoExpand -> "NoExpand"
+                   Both     -> "Both"
+
+-- | If @LiberalTypeSynonyms@ is enabled, we start in 'Expand' mode for the
+-- reasons explained in @Note [Liberal type synonyms]@. Otherwise, we start
+-- in 'Both' mode.
+initialExpandMode :: TcM ExpandMode
+initialExpandMode = do
+  liberal_flag <- xoptM LangExt.LiberalTypeSynonyms
+  pure $ if liberal_flag then Expand else Both
+
+-- | Information about a type being validity-checked.
+data ValidityEnv = ValidityEnv
+  { ve_tidy_env :: TidyEnv
+  , ve_ctxt     :: UserTypeCtxt
+  , ve_rank     :: Rank
+  , ve_expand   :: ExpandMode }
+
+instance Outputable ValidityEnv where
+  ppr (ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt
+                  , ve_rank = rank, ve_expand = expand }) =
+    hang (text "ValidityEnv")
+       2 (vcat [ text "ve_tidy_env" <+> ppr env
+               , text "ve_ctxt"     <+> pprUserTypeCtxt ctxt
+               , text "ve_rank"     <+> ppr rank
+               , text "ve_expand"   <+> ppr expand ])
+
+----------------------------------------
+check_type :: ValidityEnv -> Type -> TcM ()
+-- The args say what the *type context* requires, independent
+-- of *flag* settings.  You test the flag settings at usage sites.
+--
+-- Rank is allowed rank for function args
+-- Rank 0 means no for-alls anywhere
+
+check_type _ (TyVarTy _) = return ()
+
+check_type ve (AppTy ty1 ty2)
+  = do  { check_type ve ty1
+        ; check_arg_type False ve ty2 }
+
+check_type ve ty@(TyConApp tc tys)
+  | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
+  = check_syn_tc_app ve ty tc tys
+  | isUnboxedTupleTyCon tc = check_ubx_tuple ve ty tys
+  | otherwise              = mapM_ (check_arg_type False ve) tys
+
+check_type _ (LitTy {}) = return ()
+
+check_type ve (CastTy ty _) = check_type ve ty
+
+-- Check for rank-n types, such as (forall x. x -> x) or (Show x => x).
+--
+-- Critically, this case must come *after* the case for TyConApp.
+-- See Note [Liberal type synonyms].
+check_type ve@(ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt
+                          , ve_rank = rank, ve_expand = expand }) ty
+  | not (null tvbs && null theta)
+  = do  { traceTc "check_type" (ppr ty $$ ppr (forAllAllowed rank))
+        ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty)
+                -- Reject e.g. (Maybe (?x::Int => Int)),
+                -- with a decent error message
+
+        ; checkTcM (null theta || constraintsAllowed ctxt)
+                   (constraintTyErr env ty)
+                -- Reject forall (a :: Eq b => b). blah
+                -- In a kind signature we don't allow constraints
+
+        ; check_valid_theta env' SigmaCtxt expand theta
+                -- Allow     type T = ?x::Int => Int -> Int
+                -- but not   type T = ?x::Int
+
+        ; check_type (ve{ve_tidy_env = env'}) tau
+                -- Allow foralls to right of arrow
+
+        ; checkTcM (not (any (`elemVarSet` tyCoVarsOfType phi_kind) tvs))
+                   (forAllEscapeErr env' ty tau_kind)
+        }
+  where
+    (tvbs, phi)  = tcSplitForAllVarBndrs ty
+    (theta, tau) = tcSplitPhiTy phi
+
+    tvs          = binderVars tvbs
+    (env', _)    = tidyVarBndrs env tvs
+
+    tau_kind              = tcTypeKind tau
+    phi_kind | null theta = tau_kind
+             | otherwise  = liftedTypeKind
+        -- If there are any constraints, the kind is *. (#11405)
+
+check_type (ve@ValidityEnv{ve_rank = rank}) (FunTy arg_ty res_ty)
+  = do  { check_type (ve{ve_rank = arg_rank}) arg_ty
+        ; check_type (ve{ve_rank = res_rank}) res_ty }
+  where
+    (arg_rank, res_rank) = funArgResRank rank
+
+check_type _ ty = pprPanic "check_type" (ppr ty)
+
+----------------------------------------
+check_syn_tc_app :: ValidityEnv
+                 -> KindOrType -> TyCon -> [KindOrType] -> TcM ()
+-- Used for type synonyms and type synonym families,
+-- which must be saturated,
+-- but not data families, which need not be saturated
+check_syn_tc_app (ve@ValidityEnv{ ve_ctxt = ctxt, ve_expand = expand })
+                 ty tc tys
+  | tys `lengthAtLeast` tc_arity   -- Saturated
+       -- Check that the synonym has enough args
+       -- This applies equally to open and closed synonyms
+       -- It's OK to have an *over-applied* type synonym
+       --      data Tree a b = ...
+       --      type Foo a = Tree [a]
+       --      f :: Foo a b -> ...
+  = case expand of
+      _ |  isTypeFamilyTyCon tc
+        -> check_args_only expand
+      -- See Note [Correctness and performance of type synonym validity
+      --           checking]
+      Expand   -> check_expansion_only expand
+      NoExpand -> check_args_only expand
+      Both     -> check_args_only NoExpand *> check_expansion_only Both
+
+  | GhciCtxt True <- ctxt  -- Accept outermost under-saturated type synonym or
+                           -- type family constructors in GHCi :kind commands.
+                           -- See Note [Unsaturated type synonyms in GHCi]
+  = check_args_only expand
+
+  | otherwise
+  = failWithTc (tyConArityErr tc tys)
+  where
+    tc_arity  = tyConArity tc
+
+    check_arg :: ExpandMode -> KindOrType -> TcM ()
+    check_arg expand =
+      check_arg_type (isTypeSynonymTyCon tc) (ve{ve_expand = expand})
+
+    check_args_only, check_expansion_only :: ExpandMode -> TcM ()
+    check_args_only expand = mapM_ (check_arg expand) tys
+    check_expansion_only expand =
+      case tcView ty of
+         Just ty' -> let syn_tc = fst $ tcRepSplitTyConApp ty
+                         err_ctxt = text "In the expansion of type synonym"
+                                    <+> quotes (ppr syn_tc)
+                     in addErrCtxt err_ctxt $
+                        check_type (ve{ve_expand = expand}) ty'
+         Nothing  -> pprPanic "check_syn_tc_app" (ppr ty)
+
+{-
+Note [Unsaturated type synonyms in GHCi]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Generally speaking, GHC disallows unsaturated uses of type synonyms or type
+families. For instance, if one defines `type Const a b = a`, then GHC will not
+permit using `Const` unless it is applied to (at least) two arguments. There is
+an exception to this rule, however: GHCi's :kind command. For instance, it
+is quite common to look up the kind of a type constructor like so:
+
+  λ> :kind Const
+  Const :: j -> k -> j
+  λ> :kind Const Int
+  Const Int :: k -> Type
+
+Strictly speaking, the two uses of `Const` above are unsaturated, but this
+is an extremely benign (and useful) example of unsaturation, so we allow it
+here as a special case.
+
+That being said, we do not allow unsaturation carte blanche in GHCi. Otherwise,
+this GHCi interaction would be possible:
+
+  λ> newtype Fix f = MkFix (f (Fix f))
+  λ> type Id a = a
+  λ> :kind Fix Id
+  Fix Id :: Type
+
+This is rather dodgy, so we move to disallow this. We only permit unsaturated
+synonyms in GHCi if they are *top-level*—that is, if the synonym is the
+outermost type being applied. This allows `Const` and `Const Int` in the
+first example, but not `Fix Id` in the second example, as `Id` is not the
+outermost type being applied (`Fix` is).
+
+We track this outermost property in the GhciCtxt constructor of UserTypeCtxt.
+A field of True in GhciCtxt indicates that we're in an outermost position. Any
+time we invoke `check_arg` to check the validity of an argument, we switch the
+field to False.
+-}
+
+----------------------------------------
+check_ubx_tuple :: ValidityEnv -> KindOrType -> [KindOrType] -> TcM ()
+check_ubx_tuple (ve@ValidityEnv{ve_tidy_env = env}) ty tys
+  = do  { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples
+        ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty)
+
+        ; impred <- xoptM LangExt.ImpredicativeTypes
+        ; let rank' = if impred then ArbitraryRank else tyConArgMonoType
+                -- c.f. check_arg_type
+                -- However, args are allowed to be unlifted, or
+                -- more unboxed tuples, so can't use check_arg_ty
+        ; mapM_ (check_type (ve{ve_rank = rank'})) tys }
+
+----------------------------------------
+check_arg_type
+  :: Bool -- ^ Is this the argument to a type synonym?
+  -> ValidityEnv -> KindOrType -> TcM ()
+-- The sort of type that can instantiate a type variable,
+-- or be the argument of a type constructor.
+-- Not an unboxed tuple, but now *can* be a forall (since impredicativity)
+-- Other unboxed types are very occasionally allowed as type
+-- arguments depending on the kind of the type constructor
+--
+-- For example, we want to reject things like:
+--
+--      instance Ord a => Ord (forall s. T s a)
+-- and
+--      g :: T s (forall b.b)
+--
+-- NB: unboxed tuples can have polymorphic or unboxed args.
+--     This happens in the workers for functions returning
+--     product types with polymorphic components.
+--     But not in user code.
+-- Anyway, they are dealt with by a special case in check_tau_type
+
+check_arg_type _ _ (CoercionTy {}) = return ()
+
+check_arg_type type_syn (ve@ValidityEnv{ve_ctxt = ctxt, ve_rank = rank}) ty
+  = do  { impred <- xoptM LangExt.ImpredicativeTypes
+        ; let rank' = case rank of          -- Predictive => must be monotype
+                        -- Rank-n arguments to type synonyms are OK, provided
+                        -- that LiberalTypeSynonyms is enabled.
+                        _ | type_syn       -> synArgMonoType
+                        MustBeMonoType     -> MustBeMonoType  -- Monotype, regardless
+                        _other | impred    -> ArbitraryRank
+                               | otherwise -> tyConArgMonoType
+                        -- Make sure that MustBeMonoType is propagated,
+                        -- so that we don't suggest -XImpredicativeTypes in
+                        --    (Ord (forall a.a)) => a -> a
+                        -- and so that if it Must be a monotype, we check that it is!
+              ctxt' :: UserTypeCtxt
+              ctxt'
+                | GhciCtxt _ <- ctxt = GhciCtxt False
+                    -- When checking an argument, set the field of GhciCtxt to
+                    -- False to indicate that we are no longer in an outermost
+                    -- position (and thus unsaturated synonyms are no longer
+                    -- allowed).
+                    -- See Note [Unsaturated type synonyms in GHCi]
+                | otherwise          = ctxt
+
+        ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty }
+
+----------------------------------------
+forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc)
+forAllTyErr env rank ty
+   = ( env
+     , vcat [ hang herald 2 (ppr_tidy env ty)
+            , suggestion ] )
+  where
+    (tvs, _theta, _tau) = tcSplitSigmaTy ty
+    herald | null tvs  = text "Illegal qualified type:"
+           | otherwise = text "Illegal polymorphic type:"
+    suggestion = case rank of
+                   LimitedRank {} -> text "Perhaps you intended to use RankNTypes"
+                   MonoType d     -> d
+                   _              -> Outputable.empty -- Polytype is always illegal
+
+forAllEscapeErr :: TidyEnv -> Type -> Kind -> (TidyEnv, SDoc)
+forAllEscapeErr env ty tau_kind
+  = ( env
+    , hang (vcat [ text "Quantified type's kind mentions quantified type variable"
+                 , text "(skolem escape)" ])
+         2 (vcat [ text "   type:" <+> ppr_tidy env ty
+                 , text "of kind:" <+> ppr_tidy env tau_kind ]) )
+
+ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
+ubxArgTyErr env ty
+  = ( env, vcat [ sep [ text "Illegal unboxed tuple type as function argument:"
+                      , ppr_tidy env ty ]
+                , text "Perhaps you intended to use UnboxedTuples" ] )
+
+constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
+constraintTyErr env ty
+  = (env, text "Illegal constraint in a kind:" <+> ppr_tidy env ty)
+
+{-
+Note [Liberal type synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If -XLiberalTypeSynonyms is on, expand closed type synonyms *before*
+doing validity checking.  This allows us to instantiate a synonym defn
+with a for-all type, or with a partially-applied type synonym.
+        e.g.   type T a b = a
+               type S m   = m ()
+               f :: S (T Int)
+Here, T is partially applied, so it's illegal in H98.  But if you
+expand S first, then T we get just
+               f :: Int
+which is fine.
+
+IMPORTANT: suppose T is a type synonym.  Then we must do validity
+checking on an appliation (T ty1 ty2)
+
+        *either* before expansion (i.e. check ty1, ty2)
+        *or* after expansion (i.e. expand T ty1 ty2, and then check)
+        BUT NOT BOTH
+
+If we do both, we get exponential behaviour!!
+
+  data TIACons1 i r c = c i ::: r c
+  type TIACons2 t x = TIACons1 t (TIACons1 t x)
+  type TIACons3 t x = TIACons2 t (TIACons1 t x)
+  type TIACons4 t x = TIACons2 t (TIACons2 t x)
+  type TIACons7 t x = TIACons4 t (TIACons3 t x)
+
+The order in which you do validity checking is also somewhat delicate. Consider
+the `check_type` function, which drives the validity checking for unsaturated
+uses of type synonyms. There is a special case for rank-n types, such as
+(forall x. x -> x) or (Show x => x), since those require at least one language
+extension to use. It used to be the case that this case came before every other
+case, but this can lead to bugs. Imagine you have this scenario (from #15954):
+
+  type A a = Int
+  type B (a :: Type -> Type) = forall x. x -> x
+  type C = B A
+
+If the rank-n case came first, then in the process of checking for `forall`s
+or contexts, we would expand away `B A` to `forall x. x -> x`. This is because
+the functions that split apart `forall`s/contexts
+(tcSplitForAllVarBndrs/tcSplitPhiTy) expand type synonyms! If `B A` is expanded
+away to `forall x. x -> x` before the actually validity checks occur, we will
+have completely obfuscated the fact that we had an unsaturated application of
+the `A` type synonym.
+
+We have since learned from our mistakes and now put this rank-n case /after/
+the case for TyConApp, which ensures that an unsaturated `A` TyConApp will be
+caught properly. But be careful! We can't make the rank-n case /last/ either,
+as the FunTy case must came after the rank-n case. Otherwise, something like
+(Eq a => Int) would be treated as a function type (FunTy), which just
+wouldn't do.
+
+************************************************************************
+*                                                                      *
+\subsection{Checking a theta or source type}
+*                                                                      *
+************************************************************************
+
+Note [Implicit parameters in instance decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Implicit parameters _only_ allowed in type signatures; not in instance
+decls, superclasses etc. The reason for not allowing implicit params in
+instances is a bit subtle.  If we allowed
+  instance (?x::Int, Eq a) => Foo [a] where ...
+then when we saw
+     (e :: (?x::Int) => t)
+it would be unclear how to discharge all the potential uses of the ?x
+in e.  For example, a constraint Foo [Int] might come out of e, and
+applying the instance decl would show up two uses of ?x.  Trac #8912.
+-}
+
+checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM ()
+-- Assumes argument is fully zonked
+checkValidTheta ctxt theta
+  = addErrCtxtM (checkThetaCtxt ctxt theta) $
+    do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta)
+       ; expand <- initialExpandMode
+       ; check_valid_theta env ctxt expand theta }
+
+-------------------------
+check_valid_theta :: TidyEnv -> UserTypeCtxt -> ExpandMode
+                  -> [PredType] -> TcM ()
+check_valid_theta _ _ _ []
+  = return ()
+check_valid_theta env ctxt expand theta
+  = do { dflags <- getDynFlags
+       ; warnTcM (Reason Opt_WarnDuplicateConstraints)
+                 (wopt Opt_WarnDuplicateConstraints dflags && notNull dups)
+                 (dupPredWarn env dups)
+       ; traceTc "check_valid_theta" (ppr theta)
+       ; mapM_ (check_pred_ty env dflags ctxt expand) theta }
+  where
+    (_,dups) = removeDups nonDetCmpType theta
+    -- It's OK to use nonDetCmpType because dups only appears in the
+    -- warning
+
+-------------------------
+{- Note [Validity checking for constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We look through constraint synonyms so that we can see the underlying
+constraint(s).  For example
+   type Foo = ?x::Int
+   instance Foo => C T
+We should reject the instance because it has an implicit parameter in
+the context.
+
+But we record, in 'under_syn', whether we have looked under a synonym
+to avoid requiring language extensions at the use site.  Main example
+(Trac #9838):
+
+   {-# LANGUAGE ConstraintKinds #-}
+   module A where
+      type EqShow a = (Eq a, Show a)
+
+   module B where
+      import A
+      foo :: EqShow a => a -> String
+
+We don't want to require ConstraintKinds in module B.
+-}
+
+check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> ExpandMode
+              -> PredType -> TcM ()
+-- Check the validity of a predicate in a signature
+-- See Note [Validity checking for constraints]
+check_pred_ty env dflags ctxt expand pred
+  = do { check_type ve pred
+       ; check_pred_help False env dflags ctxt pred }
+  where
+    rank | xopt LangExt.QuantifiedConstraints dflags
+         = ArbitraryRank
+         | otherwise
+         = constraintMonoType
+
+    ve :: ValidityEnv
+    ve = ValidityEnv{ ve_tidy_env = env
+                    , ve_ctxt     = SigmaCtxt
+                    , ve_rank     = rank
+                    , ve_expand   = expand }
+
+check_pred_help :: Bool    -- True <=> under a type synonym
+                -> TidyEnv
+                -> DynFlags -> UserTypeCtxt
+                -> PredType -> TcM ()
+check_pred_help under_syn env dflags ctxt pred
+  | Just pred' <- tcView pred  -- Switch on under_syn when going under a
+                                 -- synonym (Trac #9838, yuk)
+  = check_pred_help True env dflags ctxt pred'
+
+  | otherwise  -- A bit like classifyPredType, but not the same
+               -- E.g. we treat (~) like (~#); and we look inside tuples
+  = case classifyPredType pred of
+      ClassPred cls tys
+        | isCTupleClass cls   -> check_tuple_pred under_syn env dflags ctxt pred tys
+        | otherwise           -> check_class_pred env dflags ctxt pred cls tys
+
+      EqPred NomEq _ _  -> -- a ~# b
+                           check_eq_pred env dflags pred
+
+      EqPred ReprEq _ _ -> -- Ugh!  When inferring types we may get
+                           -- f :: (a ~R# b) => blha
+                           -- And we want to treat that like (Coercible a b)
+                           -- We should probably check argument shapes, but we
+                           -- didn't do so before, so I'm leaving it for now
+                           return ()
+
+      ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head
+      IrredPred {}            -> check_irred_pred under_syn env dflags ctxt pred
+
+check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM ()
+check_eq_pred env dflags pred
+  =         -- Equational constraints are valid in all contexts if type
+            -- families are permitted
+    checkTcM (xopt LangExt.TypeFamilies dflags
+              || xopt LangExt.GADTs dflags)
+             (eqPredTyErr env pred)
+
+check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt
+                 -> PredType -> ThetaType -> PredType -> TcM ()
+check_quant_pred env dflags _ctxt pred theta head_pred
+  = addErrCtxt (text "In the quantified constraint" <+> quotes (ppr pred)) $
+    do { -- Check the instance head
+         case classifyPredType head_pred of
+            ClassPred cls tys -> checkValidInstHead SigmaCtxt cls tys
+                                 -- SigmaCtxt tells checkValidInstHead that
+                                 -- this is the head of a quantified constraint
+            IrredPred {}      | hasTyVarHead head_pred
+                              -> return ()
+            _                 -> failWithTcM (badQuantHeadErr env pred)
+
+         -- Check for termination
+       ; unless (xopt LangExt.UndecidableInstances dflags) $
+         checkInstTermination theta head_pred
+    }
+
+check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM ()
+check_tuple_pred under_syn env dflags ctxt pred ts
+  = do { -- See Note [ConstraintKinds in predicates]
+         checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags)
+                  (predTupleErr env pred)
+       ; mapM_ (check_pred_help under_syn env dflags ctxt) ts }
+    -- This case will not normally be executed because without
+    -- -XConstraintKinds tuple types are only kind-checked as *
+
+check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM ()
+check_irred_pred under_syn env dflags ctxt pred
+    -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint
+    -- where X is a type function
+  = do { -- If it looks like (x t1 t2), require ConstraintKinds
+         --   see Note [ConstraintKinds in predicates]
+         -- But (X t1 t2) is always ok because we just require ConstraintKinds
+         -- at the definition site (Trac #9838)
+        failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags)
+                                && hasTyVarHead pred)
+                  (predIrredErr env pred)
+
+         -- Make sure it is OK to have an irred pred in this context
+         -- See Note [Irreducible predicates in superclasses]
+       ; failIfTcM (is_superclass ctxt
+                    && not (xopt LangExt.UndecidableInstances dflags)
+                    && has_tyfun_head pred)
+                   (predSuperClassErr env pred) }
+  where
+    is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False }
+    has_tyfun_head ty
+      = case tcSplitTyConApp_maybe ty of
+          Just (tc, _) -> isTypeFamilyTyCon tc
+          Nothing      -> False
+
+{- Note [ConstraintKinds in predicates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Don't check for -XConstraintKinds under a type synonym, because that
+was done at the type synonym definition site; see Trac #9838
+e.g.   module A where
+          type C a = (Eq a, Ix a)   -- Needs -XConstraintKinds
+       module B where
+          import A
+          f :: C a => a -> a        -- Does *not* need -XConstraintKinds
+
+Note [Irreducible predicates in superclasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Allowing type-family calls in class superclasses is somewhat dangerous
+because we can write:
+
+ type family Fooish x :: * -> Constraint
+ type instance Fooish () = Foo
+ class Fooish () a => Foo a where
+
+This will cause the constraint simplifier to loop because every time we canonicalise a
+(Foo a) class constraint we add a (Fooish () a) constraint which will be immediately
+solved to add+canonicalise another (Foo a) constraint.  -}
+
+-------------------------
+check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt
+                 -> PredType -> Class -> [TcType] -> TcM ()
+check_class_pred env dflags ctxt pred cls tys
+  |  cls `hasKey` heqTyConKey   -- (~) and (~~) are classified as classes,
+  || cls `hasKey` eqTyConKey    -- but here we want to treat them as equalities
+  = -- pprTrace "check_class" (ppr cls) $
+    check_eq_pred env dflags pred
+
+  | isIPClass cls
+  = do { check_arity
+       ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) }
+
+  | otherwise     -- Includes Coercible
+  = do { check_arity
+       ; checkSimplifiableClassConstraint env dflags ctxt cls tys
+       ; checkTcM arg_tys_ok (predTyVarErr env pred) }
+  where
+    check_arity = checkTc (tys `lengthIs` classArity cls)
+                          (tyConArityErr (classTyCon cls) tys)
+
+    -- Check the arguments of a class constraint
+    flexible_contexts = xopt LangExt.FlexibleContexts     dflags
+    undecidable_ok    = xopt LangExt.UndecidableInstances dflags
+    arg_tys_ok = case ctxt of
+        SpecInstCtxt -> True    -- {-# SPECIALISE instance Eq (T Int) #-} is fine
+        InstDeclCtxt {} -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys
+                                -- Further checks on head and theta
+                                -- in checkInstTermination
+        _               -> checkValidClsArgs flexible_contexts cls tys
+
+checkSimplifiableClassConstraint :: TidyEnv -> DynFlags -> UserTypeCtxt
+                                 -> Class -> [TcType] -> TcM ()
+-- See Note [Simplifiable given constraints]
+checkSimplifiableClassConstraint env dflags ctxt cls tys
+  | not (wopt Opt_WarnSimplifiableClassConstraints dflags)
+  = return ()
+  | xopt LangExt.MonoLocalBinds dflags
+  = return ()
+
+  | DataTyCtxt {} <- ctxt   -- Don't do this check for the "stupid theta"
+  = return ()               -- of a data type declaration
+
+  | cls `hasKey` coercibleTyConKey
+  = return ()   -- Oddly, we treat (Coercible t1 t2) as unconditionally OK
+                -- matchGlobalInst will reply "yes" because we can reduce
+                -- (Coercible a b) to (a ~R# b)
+
+  | otherwise
+  = do { result <- matchGlobalInst dflags False cls tys
+       ; case result of
+           OneInst { cir_what = what }
+              -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints)
+                                   (simplifiable_constraint_warn what)
+           _          -> return () }
+  where
+    pred = mkClassPred cls tys
+
+    simplifiable_constraint_warn :: InstanceWhat -> SDoc
+    simplifiable_constraint_warn what
+     = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env pred))
+                    <+> text "matches")
+                 2 (ppr_what what)
+            , hang (text "This makes type inference for inner bindings fragile;")
+                 2 (text "either use MonoLocalBinds, or simplify it using the instance") ]
+
+    ppr_what BuiltinInstance = text "a built-in instance"
+    ppr_what LocalInstance   = text "a locally-quantified instance"
+    ppr_what (TopLevInstance { iw_dfun_id = dfun })
+      = hang (text "instance" <+> pprSigmaType (idType dfun))
+           2 (text "--" <+> pprDefinedAt (idName dfun))
+
+
+{- Note [Simplifiable given constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A type signature like
+   f :: Eq [(a,b)] => a -> b
+is very fragile, for reasons described at length in TcInteract
+Note [Instance and Given overlap].  As that Note discusses, for the
+most part the clever stuff in TcInteract means that we don't use a
+top-level instance if a local Given might fire, so there is no
+fragility. But if we /infer/ the type of a local let-binding, things
+can go wrong (Trac #11948 is an example, discussed in the Note).
+
+So this warning is switched on only if we have NoMonoLocalBinds; in
+that case the warning discourages users from writing simplifiable
+class constraints.
+
+The warning only fires if the constraint in the signature
+matches the top-level instances in only one way, and with no
+unifiers -- that is, under the same circumstances that
+TcInteract.matchInstEnv fires an interaction with the top
+level instances.  For example (Trac #13526), consider
+
+  instance {-# OVERLAPPABLE #-} Eq (T a) where ...
+  instance                   Eq (T Char) where ..
+  f :: Eq (T a) => ...
+
+We don't want to complain about this, even though the context
+(Eq (T a)) matches an instance, because the user may be
+deliberately deferring the choice so that the Eq (T Char)
+has a chance to fire when 'f' is called.  And the fragility
+only matters when there's a risk that the instance might
+fire instead of the local 'given'; and there is no such
+risk in this case.  Just use the same rules as for instance
+firing!
+-}
+
+-------------------------
+okIPCtxt :: UserTypeCtxt -> Bool
+  -- See Note [Implicit parameters in instance decls]
+okIPCtxt (FunSigCtxt {})        = True
+okIPCtxt (InfSigCtxt {})        = True
+okIPCtxt ExprSigCtxt            = True
+okIPCtxt TypeAppCtxt            = True
+okIPCtxt PatSigCtxt             = True
+okIPCtxt ResSigCtxt             = True
+okIPCtxt GenSigCtxt             = True
+okIPCtxt (ConArgCtxt {})        = True
+okIPCtxt (ForSigCtxt {})        = True  -- ??
+okIPCtxt ThBrackCtxt            = True
+okIPCtxt (GhciCtxt {})          = True
+okIPCtxt SigmaCtxt              = True
+okIPCtxt (DataTyCtxt {})        = True
+okIPCtxt (PatSynCtxt {})        = True
+okIPCtxt (TySynCtxt {})         = True   -- e.g.   type Blah = ?x::Int
+                                         -- Trac #11466
+
+okIPCtxt (KindSigCtxt {})       = False
+okIPCtxt (ClassSCCtxt {})       = False
+okIPCtxt (InstDeclCtxt {})      = False
+okIPCtxt (SpecInstCtxt {})      = False
+okIPCtxt (RuleSigCtxt {})       = False
+okIPCtxt DefaultDeclCtxt        = False
+okIPCtxt DerivClauseCtxt        = False
+okIPCtxt (TyVarBndrKindCtxt {}) = False
+okIPCtxt (DataKindCtxt {})      = False
+okIPCtxt (TySynKindCtxt {})     = False
+okIPCtxt (TyFamResKindCtxt {})  = False
+
+{-
+Note [Kind polymorphic type classes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+MultiParam check:
+
+    class C f where...   -- C :: forall k. k -> Constraint
+    instance C Maybe where...
+
+  The dictionary gets type [C * Maybe] even if it's not a MultiParam
+  type class.
+
+Flexibility check:
+
+    class C f where...   -- C :: forall k. k -> Constraint
+    data D a = D a
+    instance C D where
+
+  The dictionary gets type [C * (D *)]. IA0_TODO it should be
+  generalized actually.
+-}
+
+checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc)
+checkThetaCtxt ctxt theta env
+  = return ( env
+           , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta)
+                  , text "While checking" <+> pprUserTypeCtxt ctxt ] )
+
+eqPredTyErr, predTupleErr, predIrredErr,
+   predSuperClassErr, badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)
+badQuantHeadErr env pred
+  = ( env
+    , hang (text "Quantified predicate must have a class or type variable head:")
+         2 (ppr_tidy env pred) )
+eqPredTyErr  env pred
+  = ( env
+    , text "Illegal equational constraint" <+> ppr_tidy env pred $$
+      parens (text "Use GADTs or TypeFamilies to permit this") )
+predTupleErr env pred
+  = ( env
+    , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred)
+         2 (parens constraintKindsMsg) )
+predIrredErr env pred
+  = ( env
+    , hang (text "Illegal constraint:" <+> ppr_tidy env pred)
+         2 (parens constraintKindsMsg) )
+predSuperClassErr env pred
+  = ( env
+    , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred)
+            <+> text "in a superclass context")
+         2 (parens undecidableMsg) )
+
+predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)
+predTyVarErr env pred
+  = (env
+    , vcat [ hang (text "Non type-variable argument")
+                2 (text "in the constraint:" <+> ppr_tidy env pred)
+           , parens (text "Use FlexibleContexts to permit this") ])
+
+badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc)
+badIPPred env pred
+  = ( env
+    , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) )
+
+constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
+constraintSynErr env kind
+  = ( env
+    , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind))
+         2 (parens constraintKindsMsg) )
+
+dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc)
+dupPredWarn env dups
+  = ( env
+    , text "Duplicate constraint" <> plural primaryDups <> text ":"
+      <+> pprWithCommas (ppr_tidy env) primaryDups )
+  where
+    primaryDups = map NE.head dups
+
+tyConArityErr :: TyCon -> [TcType] -> SDoc
+-- For type-constructor arity errors, be careful to report
+-- the number of /visible/ arguments required and supplied,
+-- ignoring the /invisible/ arguments, which the user does not see.
+-- (e.g. Trac #10516)
+tyConArityErr tc tks
+  = arityErr (ppr (tyConFlavour tc)) (tyConName tc)
+             tc_type_arity tc_type_args
+  where
+    vis_tks = filterOutInvisibleTypes tc tks
+
+    -- tc_type_arity = number of *type* args expected
+    -- tc_type_args  = number of *type* args encountered
+    tc_type_arity = count isVisibleTyConBinder (tyConBinders tc)
+    tc_type_args  = length vis_tks
+
+arityErr :: Outputable a => SDoc -> a -> Int -> Int -> SDoc
+arityErr what name n m
+  = hsep [ text "The" <+> what, quotes (ppr name), text "should have",
+           n_arguments <> comma, text "but has been given",
+           if m==0 then text "none" else int m]
+    where
+        n_arguments | n == 0 = text "no arguments"
+                    | n == 1 = text "1 argument"
+                    | True   = hsep [int n, text "arguments"]
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Checking for a decent instance head type}
+*                                                                      *
+************************************************************************
+
+@checkValidInstHead@ checks the type {\em and} its syntactic constraints:
+it must normally look like: @instance Foo (Tycon a b c ...) ...@
+
+The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
+flag is on, or (2)~the instance is imported (they must have been
+compiled elsewhere). In these cases, we let them go through anyway.
+
+We can also have instances for functions: @instance Foo (a -> b) ...@.
+-}
+
+checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()
+checkValidInstHead ctxt clas cls_args
+  = do { dflags   <- getDynFlags
+       ; is_boot  <- tcIsHsBootOrSig
+       ; is_sig   <- tcIsHsig
+       ; check_valid_inst_head dflags is_boot is_sig ctxt clas cls_args
+       }
+
+{-
+
+Note [Instances of built-in classes in signature files]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+User defined instances for KnownNat, KnownSymbol and Typeable are
+disallowed -- they are generated when needed by GHC itself on-the-fly.
+
+However, if they occur in a Backpack signature file, they have an
+entirely different meaning. Suppose in M.hsig we see
+
+  signature M where
+    data T :: Nat
+    instance KnownNat T
+
+That says that any module satisfying M.hsig must provide a KnownNat
+instance for T.  We absolultely need that instance when compiling a
+module that imports M.hsig: see Trac #15379 and
+Note [Fabricating Evidence for Literals in Backpack] in ClsInst.
+
+Hence, checkValidInstHead accepts a user-written instance declaration
+in hsig files, where `is_sig` is True.
+
+-}
+
+check_valid_inst_head :: DynFlags -> Bool -> Bool
+                      -> UserTypeCtxt -> Class -> [Type] -> TcM ()
+-- Wow!  There are a surprising number of ad-hoc special cases here.
+check_valid_inst_head dflags is_boot is_sig ctxt clas cls_args
+
+  -- If not in an hs-boot file, abstract classes cannot have instances
+  | isAbstractClass clas
+  , not is_boot
+  = failWithTc abstract_class_msg
+
+  -- For Typeable, don't complain about instances for
+  -- standalone deriving; they are no-ops, and we warn about
+  -- it in TcDeriv.deriveStandalone.
+  | clas_nm == typeableClassName
+  , not is_sig
+    -- Note [Instances of built-in classes in signature files]
+  , hand_written_bindings
+  = failWithTc rejected_class_msg
+
+  -- Handwritten instances of KnownNat/KnownSymbol class
+  -- are always forbidden (#12837)
+  | clas_nm `elem` [ knownNatClassName, knownSymbolClassName ]
+  , not is_sig
+    -- Note [Instances of built-in classes in signature files]
+  , hand_written_bindings
+  = failWithTc rejected_class_msg
+
+  -- For the most part we don't allow
+  -- instances for (~), (~~), or Coercible;
+  -- but we DO want to allow them in quantified constraints:
+  --   f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m...
+  | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName ]
+  , not quantified_constraint
+  = failWithTc rejected_class_msg
+
+  -- Check for hand-written Generic instances (disallowed in Safe Haskell)
+  | clas_nm `elem` genericClassNames
+  , hand_written_bindings
+  =  do { failIfTc (safeLanguageOn dflags) gen_inst_err
+        ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) }
+
+  | clas_nm == hasFieldClassName
+  = checkHasFieldInst clas cls_args
+
+  | isCTupleClass clas
+  = failWithTc tuple_class_msg
+
+  -- Check language restrictions on the args to the class
+  | check_h98_arg_shape
+  , Just msg <- mb_ty_args_msg
+  = failWithTc (instTypeErr clas cls_args msg)
+
+  | otherwise
+  = checkValidTypePats (classTyCon clas) cls_args
+  where
+    clas_nm = getName clas
+    ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
+
+    hand_written_bindings
+        = case ctxt of
+            InstDeclCtxt stand_alone -> not stand_alone
+            SpecInstCtxt             -> False
+            DerivClauseCtxt          -> False
+            _                        -> True
+
+    check_h98_arg_shape = case ctxt of
+                            SpecInstCtxt    -> False
+                            DerivClauseCtxt -> False
+                            SigmaCtxt       -> False
+                            _               -> True
+        -- SigmaCtxt: once we are in quantified-constraint land, we
+        -- aren't so picky about enforcing H98-language restrictions
+        -- E.g. we want to allow a head like Coercible (m a) (m b)
+
+
+    -- When we are looking at the head of a quantified constraint,
+    -- check_quant_pred sets ctxt to SigmaCtxt
+    quantified_constraint = case ctxt of
+                              SigmaCtxt -> True
+                              _         -> False
+
+    head_type_synonym_msg = parens (
+                text "All instance types must be of the form (T t1 ... tn)" $$
+                text "where T is not a synonym." $$
+                text "Use TypeSynonymInstances if you want to disable this.")
+
+    head_type_args_tyvars_msg = parens (vcat [
+                text "All instance types must be of the form (T a1 ... an)",
+                text "where a1 ... an are *distinct type variables*,",
+                text "and each type variable appears at most once in the instance head.",
+                text "Use FlexibleInstances if you want to disable this."])
+
+    head_one_type_msg = parens $
+                        text "Only one type can be given in an instance head." $$
+                        text "Use MultiParamTypeClasses if you want to allow more, or zero."
+
+    rejected_class_msg = text "Class" <+> quotes (ppr clas_nm)
+                         <+> text "does not support user-specified instances"
+    tuple_class_msg    = text "You can't specify an instance for a tuple constraint"
+
+    gen_inst_err = rejected_class_msg $$ nest 2 (text "(in Safe Haskell)")
+
+    abstract_class_msg = text "Cannot define instance for abstract class"
+                         <+> quotes (ppr clas_nm)
+
+    mb_ty_args_msg
+      | not (xopt LangExt.TypeSynonymInstances dflags)
+      , not (all tcInstHeadTyNotSynonym ty_args)
+      = Just head_type_synonym_msg
+
+      | not (xopt LangExt.FlexibleInstances dflags)
+      , not (all tcInstHeadTyAppAllTyVars ty_args)
+      = Just head_type_args_tyvars_msg
+
+      | length ty_args /= 1
+      , not (xopt LangExt.MultiParamTypeClasses dflags)
+      , not (xopt LangExt.NullaryTypeClasses dflags && null ty_args)
+      = Just head_one_type_msg
+
+      | otherwise
+      = Nothing
+
+tcInstHeadTyNotSynonym :: Type -> Bool
+-- Used in Haskell-98 mode, for the argument types of an instance head
+-- These must not be type synonyms, but everywhere else type synonyms
+-- are transparent, so we need a special function here
+tcInstHeadTyNotSynonym ty
+  = case ty of  -- Do not use splitTyConApp,
+                -- because that expands synonyms!
+        TyConApp tc _ -> not (isTypeSynonymTyCon tc)
+        _ -> True
+
+tcInstHeadTyAppAllTyVars :: Type -> Bool
+-- Used in Haskell-98 mode, for the argument types of an instance head
+-- These must be a constructor applied to type variable arguments
+-- or a type-level literal.
+-- But we allow kind instantiations.
+tcInstHeadTyAppAllTyVars ty
+  | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty)
+  = ok (filterOutInvisibleTypes tc tys)  -- avoid kinds
+  | LitTy _ <- ty = True  -- accept type literals (Trac #13833)
+  | otherwise
+  = False
+  where
+        -- Check that all the types are type variables,
+        -- and that each is distinct
+    ok tys = equalLength tvs tys && hasNoDups tvs
+           where
+             tvs = mapMaybe tcGetTyVar_maybe tys
+
+dropCasts :: Type -> Type
+-- See Note [Casts during validity checking]
+-- This function can turn a well-kinded type into an ill-kinded
+-- one, so I've kept it local to this module
+-- To consider: drop only HoleCo casts
+dropCasts (CastTy ty _)     = dropCasts ty
+dropCasts (AppTy t1 t2)     = mkAppTy (dropCasts t1) (dropCasts t2)
+dropCasts (FunTy t1 t2)     = mkFunTy (dropCasts t1) (dropCasts t2)
+dropCasts (TyConApp tc tys) = mkTyConApp tc (map dropCasts tys)
+dropCasts (ForAllTy b ty)   = ForAllTy (dropCastsB b) (dropCasts ty)
+dropCasts ty                = ty  -- LitTy, TyVarTy, CoercionTy
+
+dropCastsB :: TyVarBinder -> TyVarBinder
+dropCastsB b = b   -- Don't bother in the kind of a forall
+
+instTypeErr :: Class -> [Type] -> SDoc -> SDoc
+instTypeErr cls tys msg
+  = hang (hang (text "Illegal instance declaration for")
+             2 (quotes (pprClassPred cls tys)))
+       2 msg
+
+-- | See Note [Validity checking of HasField instances]
+checkHasFieldInst :: Class -> [Type] -> TcM ()
+checkHasFieldInst cls tys@[_k_ty, x_ty, r_ty, _a_ty] =
+  case splitTyConApp_maybe r_ty of
+    Nothing -> whoops (text "Record data type must be specified")
+    Just (tc, _)
+      | isFamilyTyCon tc
+                  -> whoops (text "Record data type may not be a data family")
+      | otherwise -> case isStrLitTy x_ty of
+       Just lbl
+         | isJust (lookupTyConFieldLabel lbl tc)
+                     -> whoops (ppr tc <+> text "already has a field"
+                                       <+> quotes (ppr lbl))
+         | otherwise -> return ()
+       Nothing
+         | null (tyConFieldLabels tc) -> return ()
+         | otherwise -> whoops (ppr tc <+> text "has fields")
+  where
+    whoops = addErrTc . instTypeErr cls tys
+checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys)
+
+{- Note [Casts during validity checking]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the (bogus)
+     instance Eq Char#
+We elaborate to  'Eq (Char# |> UnivCo(hole))'  where the hole is an
+insoluble equality constraint for * ~ #.  We'll report the insoluble
+constraint separately, but we don't want to *also* complain that Eq is
+not applied to a type constructor.  So we look gaily look through
+CastTys here.
+
+Another example:  Eq (Either a).  Then we actually get a cast in
+the middle:
+   Eq ((Either |> g) a)
+
+
+Note [Validity checking of HasField instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The HasField class has magic constraint solving behaviour (see Note
+[HasField instances] in TcInteract).  However, we permit users to
+declare their own instances, provided they do not clash with the
+built-in behaviour.  In particular, we forbid:
+
+  1. `HasField _ r _` where r is a variable
+
+  2. `HasField _ (T ...) _` if T is a data family
+     (because it might have fields introduced later)
+
+  3. `HasField x (T ...) _` where x is a variable,
+      if T has any fields at all
+
+  4. `HasField "foo" (T ...) _` if T has a "foo" field
+
+The usual functional dependency checks also apply.
+
+
+Note [Valid 'deriving' predicate]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+validDerivPred checks for OK 'deriving' context.  See Note [Exotic
+derived instance contexts] in TcDeriv.  However the predicate is
+here because it uses sizeTypes, fvTypes.
+
+It checks for three things
+
+  * No repeated variables (hasNoDups fvs)
+
+  * No type constructors.  This is done by comparing
+        sizeTypes tys == length (fvTypes tys)
+    sizeTypes counts variables and constructors; fvTypes returns variables.
+    So if they are the same, there must be no constructors.  But there
+    might be applications thus (f (g x)).
+
+    Note that tys only includes the visible arguments of the class type
+    constructor. Including the non-visible arguments can cause the following,
+    perfectly valid instance to be rejected:
+       class Category (cat :: k -> k -> *) where ...
+       newtype T (c :: * -> * -> *) a b = MkT (c a b)
+       instance Category c => Category (T c) where ...
+    since the first argument to Category is a non-visible *, which sizeTypes
+    would count as a constructor! See Trac #11833.
+
+  * Also check for a bizarre corner case, when the derived instance decl
+    would look like
+       instance C a b => D (T a) where ...
+    Note that 'b' isn't a parameter of T.  This gives rise to all sorts of
+    problems; in particular, it's hard to compare solutions for equality
+    when finding the fixpoint, and that means the inferContext loop does
+    not converge.  See Trac #5287.
+
+Note [Equality class instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We can't have users writing instances for the equality classes. But we
+still need to be able to write instances for them ourselves. So we allow
+instances only in the defining module.
+
+-}
+
+validDerivPred :: TyVarSet -> PredType -> Bool
+-- See Note [Valid 'deriving' predicate]
+validDerivPred tv_set pred
+  = case classifyPredType pred of
+       ClassPred cls tys -> cls `hasKey` typeableClassKey
+                -- Typeable constraints are bigger than they appear due
+                -- to kind polymorphism, but that's OK
+                       || check_tys cls tys
+       EqPred {}       -> False  -- reject equality constraints
+       _               -> True   -- Non-class predicates are ok
+  where
+    check_tys cls tys
+              = hasNoDups fvs
+                   -- use sizePred to ignore implicit args
+                && lengthIs fvs (sizePred pred)
+                && all (`elemVarSet` tv_set) fvs
+      where tys' = filterOutInvisibleTypes (classTyCon cls) tys
+            fvs  = fvTypes tys'
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Checking instance for termination}
+*                                                                      *
+************************************************************************
+-}
+
+{- Note [Instances and constraint synonyms]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Currently, we don't allow instances for constraint synonyms at all.
+Consider these (Trac #13267):
+  type C1 a = Show (a -> Bool)
+  instance C1 Int where    -- I1
+    show _ = "ur"
+
+This elicits "show is not a (visible) method of class C1", which isn't
+a great message. But it comes from the renamer, so it's hard to improve.
+
+This needs a bit more care:
+  type C2 a = (Show a, Show Int)
+  instance C2 Int           -- I2
+
+If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose
+the instance head, we'll expand the synonym on fly, and it'll look like
+  instance (%,%) (Show Int, Show Int)
+and we /really/ don't want that.  So we carefully do /not/ expand
+synonyms, by matching on TyConApp directly.
+-}
+
+checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM ()
+checkValidInstance ctxt hs_type ty
+  | not is_tc_app
+  = failWithTc (hang (text "Instance head is not headed by a class:")
+                   2 ( ppr tau))
+
+  | isNothing mb_cls
+  = failWithTc (vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc)
+                     , text "A class instance must be for a class" ])
+
+  | not arity_ok
+  = failWithTc (text "Arity mis-match in instance head")
+
+  | otherwise
+  = do  { setSrcSpan head_loc $
+          checkValidInstHead ctxt clas inst_tys
+
+        ; traceTc "checkValidInstance {" (ppr ty)
+
+        ; env0 <- tcInitTidyEnv
+        ; expand <- initialExpandMode
+        ; check_valid_theta env0 ctxt expand theta
+
+        -- The Termination and Coverate Conditions
+        -- Check that instance inference will terminate (if we care)
+        -- For Haskell 98 this will already have been done by checkValidTheta,
+        -- but as we may be using other extensions we need to check.
+        --
+        -- Note that the Termination Condition is *more conservative* than
+        -- the checkAmbiguity test we do on other type signatures
+        --   e.g.  Bar a => Bar Int is ambiguous, but it also fails
+        --   the termination condition, because 'a' appears more often
+        --   in the constraint than in the head
+        ; undecidable_ok <- xoptM LangExt.UndecidableInstances
+        ; if undecidable_ok
+          then checkAmbiguity ctxt ty
+          else checkInstTermination theta tau
+
+        ; traceTc "cvi 2" (ppr ty)
+
+        ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of
+            IsValid      -> return ()   -- Check succeeded
+            NotValid msg -> addErrTc (instTypeErr clas inst_tys msg)
+
+        ; traceTc "End checkValidInstance }" empty
+
+        ; return () }
+  where
+    (_tvs, theta, tau)   = tcSplitSigmaTy ty
+    is_tc_app            = case tau of { TyConApp {} -> True; _ -> False }
+    TyConApp tc inst_tys = tau   -- See Note [Instances and constraint synonyms]
+    mb_cls               = tyConClass_maybe tc
+    Just clas            = mb_cls
+    arity_ok             = inst_tys `lengthIs` classArity clas
+
+        -- The location of the "head" of the instance
+    head_loc = getLoc (getLHsInstDeclHead hs_type)
+
+{-
+Note [Paterson conditions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Termination test: the so-called "Paterson conditions" (see Section 5 of
+"Understanding functional dependencies via Constraint Handling Rules,
+JFP Jan 2007).
+
+We check that each assertion in the context satisfies:
+ (1) no variable has more occurrences in the assertion than in the head, and
+ (2) the assertion has fewer constructors and variables (taken together
+     and counting repetitions) than the head.
+This is only needed with -fglasgow-exts, as Haskell 98 restrictions
+(which have already been checked) guarantee termination.
+
+The underlying idea is that
+
+    for any ground substitution, each assertion in the
+    context has fewer type constructors than the head.
+-}
+
+checkInstTermination :: ThetaType -> TcPredType -> TcM ()
+-- See Note [Paterson conditions]
+checkInstTermination theta head_pred
+  = check_preds emptyVarSet theta
+  where
+   head_fvs  = fvType head_pred
+   head_size = sizeType head_pred
+
+   check_preds :: VarSet -> [PredType] -> TcM ()
+   check_preds foralld_tvs preds = mapM_ (check foralld_tvs) preds
+
+   check :: VarSet -> PredType -> TcM ()
+   check foralld_tvs pred
+     = case classifyPredType pred of
+         EqPred {}    -> return ()  -- See Trac #4200.
+         IrredPred {} -> check2 foralld_tvs pred (sizeType pred)
+         ClassPred cls tys
+           | isTerminatingClass cls
+           -> return ()
+
+           | isCTupleClass cls  -- Look inside tuple predicates; Trac #8359
+           -> check_preds foralld_tvs tys
+
+           | otherwise          -- Other ClassPreds
+           -> check2 foralld_tvs pred bogus_size
+           where
+              bogus_size = 1 + sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys)
+                               -- See Note [Invisible arguments and termination]
+
+         ForAllPred tvs _ head_pred'
+           -> check (foralld_tvs `extendVarSetList` binderVars tvs) head_pred'
+              -- Termination of the quantified predicate itself is checked
+              -- when the predicates are individually checked for validity
+
+   check2 foralld_tvs pred pred_size
+     | not (null bad_tvs)     = failWithTc (noMoreMsg bad_tvs what (ppr head_pred))
+     | not (isTyFamFree pred) = failWithTc (nestedMsg what)
+     | pred_size >= head_size = failWithTc (smallerMsg what (ppr head_pred))
+     | otherwise              = return ()
+     -- isTyFamFree: see Note [Type families in instance contexts]
+     where
+        what    = text "constraint" <+> quotes (ppr pred)
+        bad_tvs = filterOut (`elemVarSet` foralld_tvs) (fvType pred)
+                  \\ head_fvs
+
+smallerMsg :: SDoc -> SDoc -> SDoc
+smallerMsg what inst_head
+  = vcat [ hang (text "The" <+> what)
+              2 (sep [ text "is no smaller than"
+                     , text "the instance head" <+> quotes inst_head ])
+         , parens undecidableMsg ]
+
+noMoreMsg :: [TcTyVar] -> SDoc -> SDoc -> SDoc
+noMoreMsg tvs what inst_head
+  = vcat [ hang (text "Variable" <> plural tvs1 <+> quotes (pprWithCommas ppr tvs1)
+                <+> occurs <+> text "more often")
+              2 (sep [ text "in the" <+> what
+                     , text "than in the instance head" <+> quotes inst_head ])
+         , parens undecidableMsg ]
+  where
+   tvs1   = nub tvs
+   occurs = if isSingleton tvs1 then text "occurs"
+                               else text "occur"
+
+undecidableMsg, constraintKindsMsg :: SDoc
+undecidableMsg     = text "Use UndecidableInstances to permit this"
+constraintKindsMsg = text "Use ConstraintKinds to permit this"
+
+{- Note [Type families in instance contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Are these OK?
+  type family F a
+  instance F a    => C (Maybe [a]) where ...
+  intance C (F a) => C [[[a]]]     where ...
+
+No: the type family in the instance head might blow up to an
+arbitrarily large type, depending on how 'a' is instantiated.
+So we require UndecidableInstances if we have a type family
+in the instance head.  Trac #15172.
+
+Note [Invisible arguments and termination]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When checking the ​Paterson conditions for termination an instance
+declaration, we check for the number of "constructors and variables"
+in the instance head and constraints. Question: Do we look at
+
+ * All the arguments, visible or invisible?
+ * Just the visible arguments?
+
+I think both will ensure termination, provided we are consistent.
+Currently we are /not/ consistent, which is really a bug.  It's
+described in Trac #15177, which contains a number of examples.
+The suspicious bits are the calls to filterOutInvisibleTypes.
+-}
+
+
+{-
+************************************************************************
+*                                                                      *
+        Checking type instance well-formedness and termination
+*                                                                      *
+************************************************************************
+-}
+
+checkValidCoAxiom :: CoAxiom Branched -> TcM ()
+checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })
+  = do { mapM_ (checkValidCoAxBranch fam_tc) branch_list
+       ; foldlM_ check_branch_compat [] branch_list }
+  where
+    branch_list = fromBranches branches
+    injectivity = tyConInjectivityInfo fam_tc
+
+    check_branch_compat :: [CoAxBranch]    -- previous branches in reverse order
+                        -> CoAxBranch      -- current branch
+                        -> TcM [CoAxBranch]-- current branch : previous branches
+    -- Check for
+    --   (a) this branch is dominated by previous ones
+    --   (b) failure of injectivity
+    check_branch_compat prev_branches cur_branch
+      | cur_branch `isDominatedBy` prev_branches
+      = do { addWarnAt NoReason (coAxBranchSpan cur_branch) $
+             inaccessibleCoAxBranch fam_tc cur_branch
+           ; return prev_branches }
+      | otherwise
+      = do { check_injectivity prev_branches cur_branch
+           ; return (cur_branch : prev_branches) }
+
+     -- Injectivity check: check whether a new (CoAxBranch) can extend
+     -- already checked equations without violating injectivity
+     -- annotation supplied by the user.
+     -- See Note [Verifying injectivity annotation] in FamInstEnv
+    check_injectivity prev_branches cur_branch
+      | Injective inj <- injectivity
+      = do { let conflicts =
+                     fst $ foldl' (gather_conflicts inj prev_branches cur_branch)
+                                 ([], 0) prev_branches
+           ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err)
+                   (makeInjectivityErrors ax cur_branch inj conflicts) }
+      | otherwise
+      = return ()
+
+    gather_conflicts inj prev_branches cur_branch (acc, n) branch
+               -- n is 0-based index of branch in prev_branches
+      = case injectiveBranches inj cur_branch branch of
+          InjectivityUnified ax1 ax2
+            | ax1 `isDominatedBy` (replace_br prev_branches n ax2)
+                -> (acc, n + 1)
+            | otherwise
+                -> (branch : acc, n + 1)
+          InjectivityAccepted -> (acc, n + 1)
+
+    -- Replace n-th element in the list. Assumes 0-based indexing.
+    replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch]
+    replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs
+
+
+-- Check that a "type instance" is well-formed (which includes decidability
+-- unless -XUndecidableInstances is given).
+--
+checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM ()
+checkValidCoAxBranch fam_tc
+                    (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
+                                , cab_lhs = typats
+                                , cab_rhs = rhs, cab_loc = loc })
+  = setSrcSpan loc $
+    checkValidTyFamEqn fam_tc (tvs++cvs) typats rhs
+
+-- | Do validity checks on a type family equation, including consistency
+-- with any enclosing class instance head, termination, and lack of
+-- polytypes.
+checkValidTyFamEqn :: TyCon   -- ^ of the type family
+                   -> [Var]   -- ^ Bound variables in the equation
+                   -> [Type]  -- ^ Type patterns
+                   -> Type    -- ^ Rhs
+                   -> TcM ()
+checkValidTyFamEqn fam_tc qvs typats rhs
+  = do { checkValidFamPats fam_tc qvs typats rhs
+
+         -- The argument patterns, and RHS, are all boxed tau types
+         -- E.g  Reject type family F (a :: k1) :: k2
+         --             type instance F (forall a. a->a) = ...
+         --             type instance F Int#             = ...
+         --             type instance F Int              = forall a. a->a
+         --             type instance F Int              = Int#
+         -- See Trac #9357
+       ; checkValidMonoType rhs
+
+         -- We have a decidable instance unless otherwise permitted
+       ; undecidable_ok <- xoptM LangExt.UndecidableInstances
+       ; traceTc "checkVTFE" (ppr fam_tc $$ ppr rhs $$ ppr (tcTyFamInsts rhs))
+       ; unless undecidable_ok $
+         mapM_ addErrTc (checkFamInstRhs fam_tc typats (tcTyFamInsts rhs)) }
+
+-- Make sure that each type family application is
+--   (1) strictly smaller than the lhs,
+--   (2) mentions no type variable more often than the lhs, and
+--   (3) does not contain any further type family instances.
+--
+checkFamInstRhs :: TyCon -> [Type]         -- LHS
+                -> [(TyCon, [Type])]       -- type family calls in RHS
+                -> [MsgDoc]
+checkFamInstRhs lhs_tc lhs_tys famInsts
+  = mapMaybe check famInsts
+  where
+   lhs_size  = sizeTyConAppArgs lhs_tc lhs_tys
+   inst_head = pprType (TyConApp lhs_tc lhs_tys)
+   lhs_fvs   = fvTypes lhs_tys
+   check (tc, tys)
+      | not (all isTyFamFree tys) = Just (nestedMsg what)
+      | not (null bad_tvs)        = Just (noMoreMsg bad_tvs what inst_head)
+      | lhs_size <= fam_app_size  = Just (smallerMsg what inst_head)
+      | otherwise                 = Nothing
+      where
+        what = text "type family application"
+               <+> quotes (pprType (TyConApp tc tys))
+        fam_app_size = sizeTyConAppArgs tc tys
+        bad_tvs      = fvTypes tys \\ lhs_fvs
+                       -- The (\\) is list difference; e.g.
+                       --   [a,b,a,a] \\ [a,a] = [b,a]
+                       -- So we are counting repetitions
+
+checkValidFamPats :: TyCon -> [Var]
+                  -> [Type]   -- ^ patterns
+                  -> Type     -- ^ RHS
+                  -> TcM ()
+-- Patterns in a 'type instance' or 'data instance' decl should
+-- a) Shoule contain no type family applications
+--    (vanilla synonyms are fine, though)
+-- b) For associated types, are consistently instantiated
+checkValidFamPats fam_tc qvs pats rhs
+  = do { checkValidTypePats fam_tc pats
+
+         -- Check for things used on the right but not bound on the left
+       ; checkFamPatBinders fam_tc qvs pats rhs
+
+       ; traceTc "checkValidFamPats" (ppr fam_tc <+> ppr pats)
+       }
+
+-----------------
+checkFamPatBinders :: TyCon
+                   -> [TcTyVar]   -- Bound on LHS of family instance
+                   -> [TcType]    -- LHS patterns
+                   -> Type        -- RHS
+                   -> TcM ()
+-- We do these binder checks now, in tcFamTyPatsAndGen, rather
+-- than later, in checkValidFamEqn, for two reasons:
+--   - We have the implicitly and explicitly
+--     bound type variables conveniently to hand
+--   - If implicit variables are out of scope it may
+--     cause a crash; notably in tcConDecl in tcDataFamInstDecl
+checkFamPatBinders fam_tc qtvs pats rhs
+  = do { traceTc "checkFamPatBinders" $
+         vcat [ debugPprType (mkTyConApp fam_tc pats)
+              , ppr (mkTyConApp fam_tc pats)
+              , text "qtvs:" <+> ppr qtvs
+              , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs)
+              , text "pat_tvs:" <+> ppr pat_tvs
+              , text "exact_pat_tvs:" <+> ppr exact_pat_tvs ]
+
+         -- Check for implicitly-bound tyvars, mentioned on the
+         -- RHS but not bound on the LHS
+         --    data T            = MkT (forall (a::k). blah)
+         --    data family D Int = MkD (forall (a::k). blah)
+         -- In both cases, 'k' is not bound on the LHS, but is used on the RHS
+         -- We catch the former in kcLHsQTyVars, and the latter right here
+       ; check_tvs bad_rhs_tvs (text "mentioned in the RHS")
+                               (text "bound on the LHS of")
+
+         -- Check for explicitly forall'd variable that is not bound on LHS
+         --    data instance forall a.  T Int = MkT Int
+         -- See Note [Unused explicitly bound variables in a family pattern]
+       ; check_tvs bad_qtvs (text "bound by a forall")
+                            (text "used in")
+
+         -- Check for oversaturated visible kind arguments in a type family
+         -- equation.
+         -- See Note [Oversaturated type family equations]
+       ; when (isTypeFamilyTyCon fam_tc) $
+           case drop (tyConArity fam_tc) pats of
+             [] -> pure ()
+             spec_arg:_ ->
+               addErr $ text "Illegal oversaturated visible kind argument:"
+                    <+> quotes (char '@' <> pprParendType spec_arg) }
+  where
+    pat_tvs       = tyCoVarsOfTypes pats
+    exact_pat_tvs = exactTyCoVarsOfTypes pats
+    rhs_fvs       = tyCoFVsOfType rhs
+    used_tvs      = pat_tvs `unionVarSet` fvVarSet rhs_fvs
+    bad_qtvs      = filterOut (`elemVarSet` used_tvs) qtvs
+                    -- Bound but not used at all
+    bad_rhs_tvs   = filterOut (`elemVarSet` exact_pat_tvs) (fvVarList rhs_fvs)
+                    -- Used on RHS but not bound on LHS
+    dodgy_tvs     = pat_tvs `minusVarSet` exact_pat_tvs
+
+    check_tvs tvs what what2
+      = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $
+        hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs
+              <+> isOrAre tvs <+> what <> comma)
+           2 (vcat [ text "but not" <+> what2 <+> text "the family instance"
+                   , mk_extra tvs ])
+
+    -- mk_extra: Trac #7536: give a decent error message for
+    --         type T a = Int
+    --         type instance F (T a) = a
+    mk_extra tvs = ppWhen (any (`elemVarSet` dodgy_tvs) tvs) $
+                   hang (text "The real LHS (expanding synonyms) is:")
+                      2 (pprTypeApp fam_tc (map expandTypeSynonyms pats))
+
+
+-- | Checks for occurrences of type families in class instances and type/data
+-- family instances.
+checkValidTypePats :: TyCon -> [Type] -> TcM ()
+checkValidTypePats tc pat_ty_args = do
+  -- Check that each of pat_ty_args is a monotype.
+  -- One could imagine generalising to allow
+  --      instance C (forall a. a->a)
+  -- but we don't know what all the consequences might be.
+  traverse_ checkValidMonoType pat_ty_args
+
+  -- Ensure that no type family instances occur a type pattern
+  case tcTyConAppTyFamInstsAndVis tc pat_ty_args of
+    [] -> pure ()
+    ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $
+      ty_fam_inst_illegal_err tf_is_invis_arg (mkTyConApp tf_tc tf_args)
+  where
+    inst_ty = mkTyConApp tc pat_ty_args
+
+    ty_fam_inst_illegal_err :: Bool -> Type -> SDoc
+    ty_fam_inst_illegal_err invis_arg ty
+      = pprWithExplicitKindsWhen invis_arg $
+        hang (text "Illegal type synonym family application"
+                <+> quotes (ppr ty) <+> text "in instance" <> colon)
+           2 (ppr inst_ty)
+
+-- Error messages
+
+inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc
+inaccessibleCoAxBranch fam_tc cur_branch
+  = text "Type family instance equation is overlapped:" $$
+    nest 2 (pprCoAxBranchUser fam_tc cur_branch)
+
+nestedMsg :: SDoc -> SDoc
+nestedMsg what
+  = sep [ text "Illegal nested" <+> what
+        , parens undecidableMsg ]
+
+badATErr :: Name -> Name -> SDoc
+badATErr clas op
+  = hsep [text "Class", quotes (ppr clas),
+          text "does not have an associated type", quotes (ppr op)]
+
+
+-------------------------
+checkConsistentFamInst :: AssocInstInfo
+                       -> TyCon     -- ^ Family tycon
+                       -> CoAxBranch
+                       -> TcM ()
+-- See Note [Checking consistent instantiation]
+
+checkConsistentFamInst NotAssociated _ _
+  = return ()
+
+checkConsistentFamInst (InClsInst { ai_class = clas
+                                  , ai_tyvars = inst_tvs
+                                  , ai_inst_env = mini_env })
+                       fam_tc branch
+  = do { traceTc "checkConsistentFamInst" (vcat [ ppr inst_tvs
+                                                , ppr arg_triples
+                                                , ppr mini_env
+                                                , ppr ax_tvs
+                                                , ppr ax_arg_tys
+                                                , ppr arg_triples ])
+       -- Check that the associated type indeed comes from this class
+       -- See [Mismatched class methods and associated type families]
+       -- in TcInstDecls.
+       ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc)
+                 (badATErr (className clas) (tyConName fam_tc))
+
+       ; check_match arg_triples
+       }
+  where
+    (ax_tvs, ax_arg_tys, _) = etaExpandCoAxBranch branch
+
+    arg_triples :: [(Type,Type, ArgFlag)]
+    arg_triples = [ (cls_arg_ty, at_arg_ty, vis)
+                  | (fam_tc_tv, vis, at_arg_ty)
+                       <- zip3 (tyConTyVars fam_tc)
+                               (tyConArgFlags fam_tc ax_arg_tys)
+                               ax_arg_tys
+                  , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ]
+
+    pp_wrong_at_arg vis
+      = pprWithExplicitKindsWhen (isInvisibleArgFlag vis) $
+        vcat [ text "Type indexes must match class instance head"
+             , text "Expected:" <+> pp_expected_ty
+             , text "  Actual:" <+> pp_actual_ty ]
+
+    -- Fiddling around to arrange that wildcards unconditionally print as "_"
+    -- We only need to print the LHS, not the RHS at all
+    -- See Note [Printing conflicts with class header]
+    (tidy_env1, _) = tidyVarBndrs emptyTidyEnv inst_tvs
+    (tidy_env2, _) = tidyCoAxBndrsForUser tidy_env1 (ax_tvs \\ inst_tvs)
+
+    pp_expected_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $
+                     toIfaceTcArgs fam_tc $
+                     [ case lookupVarEnv mini_env at_tv of
+                         Just cls_arg_ty -> tidyType tidy_env2 cls_arg_ty
+                         Nothing         -> mk_wildcard at_tv
+                     | at_tv <- tyConTyVars fam_tc ]
+
+    pp_actual_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $
+                   toIfaceTcArgs fam_tc $
+                   tidyTypes tidy_env2 ax_arg_tys
+
+    mk_wildcard at_tv = mkTyVarTy (mkTyVar tv_name (tyVarKind at_tv))
+    tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOcc "_") noSrcSpan
+
+    -- For check_match, bind_me, see
+    -- Note [Matching in the consistent-instantation check]
+    check_match :: [(Type,Type,ArgFlag)] -> TcM ()
+    check_match triples = go emptyTCvSubst emptyTCvSubst triples
+
+    go _ _ [] = return ()
+    go lr_subst rl_subst ((ty1,ty2,vis):triples)
+      | Just lr_subst1 <- tcMatchTyX_BM bind_me lr_subst ty1 ty2
+      , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1
+      = go lr_subst1 rl_subst1 triples
+      | otherwise
+      = addErrTc (pp_wrong_at_arg vis)
+
+    -- The /scoped/ type variables from the class-instance header
+    -- should not be alpha-renamed.  Inferred ones can be.
+    no_bind_set = mkVarSet inst_tvs
+    bind_me tv | tv `elemVarSet` no_bind_set = Skolem
+               | otherwise                   = BindMe
+
+
+{- Note [Matching in the consistent-instantation check]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Matching the class-instance header to family-instance tyvars is
+tricker than it sounds.  Consider (Trac #13972)
+    class C (a :: k) where
+      type T k :: Type
+    instance C Left where
+      type T (a -> Either a b) = Int
+
+Here there are no lexically-scoped variables from (C Left).
+Yet the real class-instance header is   C @(p -> Either @p @q)) (Left @p @q)
+while the type-family instance is       T (a -> Either @a @b)
+So we allow alpha-renaming of variables that don't come
+from the class-instance header.
+
+We track the lexically-scoped type variables from the
+class-instance header in ai_tyvars.
+
+Here's another example (Trac #14045a)
+    class C (a :: k) where
+      data S (a :: k)
+    instance C (z :: Bool) where
+      data S :: Bool -> Type where
+
+Again, there is no lexical connection, but we will get
+   class-instance header:   C @Bool (z::Bool)
+   family instance          S @Bool (a::Bool)
+
+When looking for mis-matches, we check left-to-right,
+kinds first.  If we look at types first, we'll fail to
+suggest -fprint-explicit-kinds for a mis-match with
+      T @k    vs    T @Type
+somewhere deep inside the type
+
+Note [Checking consistent instantiation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+See Trac #11450 for background discussion on this check.
+
+  class C a b where
+    type T a x b
+
+With this class decl, if we have an instance decl
+  instance C ty1 ty2 where ...
+then the type instance must look like
+     type T ty1 v ty2 = ...
+with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'.
+For example:
+
+  instance C [p] Int
+    type T [p] y Int = (p,y,y)
+
+Note that
+
+* We used to allow completely different bound variables in the
+  associated type instance; e.g.
+    instance C [p] Int
+      type T [q] y Int = ...
+  But from GHC 8.2 onwards, we don't.  It's much simpler this way.
+  See Trac #11450.
+
+* When the class variable isn't used on the RHS of the type instance,
+  it's tempting to allow wildcards, thus
+    instance C [p] Int
+      type T [_] y Int = (y,y)
+  But it's awkward to do the test, and it doesn't work if the
+  variable is repeated:
+    instance C (p,p) Int
+      type T (_,_) y Int = (y,y)
+  Even though 'p' is not used on the RHS, we still need to use 'p'
+  on the LHS to establish the repeated pattern.  So to keep it simple
+  we just require equality.
+
+* For variables in associated type families that are not bound by the class
+  itself, we do _not_ check if they are over-specific. In other words,
+  it's perfectly acceptable to have an instance like this:
+
+    instance C [p] Int where
+      type T [p] (Maybe x) Int = x
+
+  While the first and third arguments to T are required to be exactly [p] and
+  Int, respectively, since they are bound by C, the second argument is allowed
+  to be more specific than just a type variable. Furthermore, it is permissible
+  to define multiple equations for T that differ only in the non-class-bound
+  argument:
+
+    instance C [p] Int where
+      type T [p] (Maybe x)    Int = x
+      type T [p] (Either x y) Int = x -> y
+
+  We once considered requiring that non-class-bound variables in associated
+  type family instances be instantiated with distinct type variables. However,
+  that requirement proved too restrictive in practice, as there were examples
+  of extremely simple associated type family instances that this check would
+  reject, and fixing them required tiresome boilerplate in the form of
+  auxiliary type families. For instance, you would have to define the above
+  example as:
+
+    instance C [p] Int where
+      type T [p] x Int = CAux x
+
+    type family CAux x where
+      CAux (Maybe x)    = x
+      CAux (Either x y) = x -> y
+
+  We decided that this restriction wasn't buying us much, so we opted not
+  to pursue that design (see also GHC Trac #13398).
+
+Implementation
+  * Form the mini-envt from the class type variables a,b
+    to the instance decl types [p],Int:   [a->[p], b->Int]
+
+  * Look at the tyvars a,x,b of the type family constructor T
+    (it shares tyvars with the class C)
+
+  * Apply the mini-evnt to them, and check that the result is
+    consistent with the instance types [p] y Int. (where y can be any type, as
+    it is not scoped over the class type variables.
+
+We make all the instance type variables scope over the
+type instances, of course, which picks up non-obvious kinds.  Eg
+   class Foo (a :: k) where
+      type F a
+   instance Foo (b :: k -> k) where
+      type F b = Int
+Here the instance is kind-indexed and really looks like
+      type F (k->k) (b::k->k) = Int
+But if the 'b' didn't scope, we would make F's instance too
+poly-kinded.
+
+Note [Printing conflicts with class header]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's remarkably painful to give a decent error message for conflicts
+with the class header.  Consider
+   clase C b where
+     type F a b c
+   instance C [b] where
+     type F x Int _ _ = ...
+
+Here we want to report a conflict between
+    Expected: F _ [b] _
+    Actual:   F x Int _ _
+
+But if the type instance shadows the class variable like this
+(rename/should_fail/T15828):
+   instance C [b] where
+     type forall b. F x (Tree b) _ _ = ...
+
+then we must use a fresh variable name
+    Expected: F _ [b] _
+    Actual:   F x [b1] _ _
+
+Notice that:
+  - We want to print an underscore in the "Expected" type in
+    positions where the class header has no influence over the
+    parameter.  Hence the fancy footwork in pp_expected_ty
+
+  - Although the binders in the axiom are aready tidy, we must
+    re-tidy them to get a fresh variable name when we shadow
+
+  - The (ax_tvs \\ inst_tvs) is to avoid tidying one of the
+    class-instance variables a second time, from 'a' to 'a1' say.
+    Remember, the ax_tvs of the axiom share identity with the
+    class-instance variables, inst_tvs..
+
+  - We use tidyCoAxBndrsForUser to get underscores rather than
+    _1, _2, etc in the axiom tyvars; see the definition of
+    tidyCoAxBndrsForUser
+
+This all seems absurdly complicated.
+
+Note [Unused explicitly bound variables in a family pattern]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Why is 'unusedExplicitForAllErr' not just a warning?
+
+Consider the following examples:
+
+  type instance F a = Maybe b
+  type instance forall b. F a = Bool
+  type instance forall b. F a = Maybe b
+
+In every case, b is a type variable not determined by the LHS pattern. The
+first is caught by the renamer, but we catch the last two here. Perhaps one
+could argue that the second should be accepted, albeit with a warning, but
+consider the fact that in a type family instance, there is no way to interact
+with such a varable. At least with @x :: forall a. Int@ we can use visibile
+type application, like @x \@Bool 1@. (Of course it does nothing, but it is
+permissible.) In the type family case, the only sensible explanation is that
+the user has made a mistake -- thus we throw an error.
+
+Note [Oversaturated type family equations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Type family tycons have very rigid arities. We want to reject something like
+this:
+
+  type family Foo :: Type -> Type where
+    Foo x = ...
+
+Because Foo has arity zero (i.e., it doesn't bind anything to the left of the
+double colon), we want to disallow any equation for Foo that has more than zero
+arguments, such as `Foo x = ...`. The algorithm here is pretty simple: if an
+equation has more arguments than the arity of the type family, reject.
+
+Things get trickier when visible kind application enters the picture. Consider
+the following example:
+
+  type family Bar (x :: j) :: forall k. Either j k where
+    Bar 5 @Symbol = ...
+
+The arity of Bar is two, since it binds two variables, `j` and `x`. But even
+though Bar's equation has two arguments, it's still invalid. Imagine the same
+equation in Core:
+
+    Bar Nat 5 Symbol = ...
+
+Here, it becomes apparent that Bar is actually taking /three/ arguments! So
+we can't just rely on a simple counting argument to reject
+`Bar 5 @Symbol = ...`, since it only has two user-written arguments.
+Moreover, there's one explicit argument (5) and one visible kind argument
+(@Symbol), which matches up perfectly with the fact that Bar has one required
+binder (x) and one specified binder (j), so that's not a valid way to detect
+oversaturation either.
+
+To solve this problem in a robust way, we do the following:
+
+1. When kind-checking, we count the number of user-written *required*
+   arguments and check if there is an equal number of required tycon binders.
+   If not, reject. (See `wrongNumberOfParmsErr` in TcTyClsDecls.)
+
+   We perform this step during kind-checking, not during validity checking,
+   since we can give better error messages if we catch it early.
+2. When validity checking, take all of the (Core) type patterns from on
+   equation, drop the first n of them (where n is the arity of the type family
+   tycon), and check if there are any types leftover. If so, reject.
+
+   Why does this work? We know that after dropping the first n type patterns,
+   none of the leftover types can be required arguments, since step (1) would
+   have already caught that. Moreover, the only places where visible kind
+   applications should be allowed are in the first n types, since those are the
+   only arguments that can correspond to binding forms. Therefore, the
+   remaining arguments must correspond to oversaturated uses of visible kind
+   applications, which are precisely what we want to reject.
+
+Note that we only perform this check for type families, and not for data
+families. This is because it is perfectly acceptable to oversaturate data
+family instance equations: see Note [Arity of data families] in FamInstEnv.
+
+************************************************************************
+*                                                                      *
+   Telescope checking
+*                                                                      *
+************************************************************************
+
+Note [Bad telescopes]
+~~~~~~~~~~~~~~~~~~~~~
+Now that we can mix type and kind variables, there are an awful lot of
+ways to shoot yourself in the foot. Here are some.
+
+  data SameKind :: k -> k -> *   -- just to force unification
+
+1.  data T1 a k (b :: k) (x :: SameKind a b)
+
+The problem here is that we discover that a and b should have the same
+kind. But this kind mentions k, which is bound *after* a.
+(Testcase: dependent/should_fail/BadTelescope)
+
+2.  data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)
+
+Note that b is not bound. Yet its kind mentions a. Because we have
+a nice rule that all implicitly bound variables come before others,
+this is bogus.
+
+To catch these errors, we call checkValidTelescope during kind-checking
+datatype declarations. See also
+Note [Required, Specified, and Inferred for types] in TcTyClsDecls.
+
+Note [Keeping scoped variables in order: Explicit] discusses how this
+check works for `forall x y z.` written in a type.
+
+-}
+
+-- | Check a list of binders to see if they make a valid telescope.
+-- The key property we're checking for is scoping. For example:
+-- > data SameKind :: k -> k -> *
+-- > data X a k (b :: k) (c :: SameKind a b)
+-- Kind inference says that a's kind should be k. But that's impossible,
+-- because k isn't in scope when a is bound. This check has to come before
+-- general validity checking, because once we kind-generalise, this sort
+-- of problem is harder to spot (as we'll generalise over the unbound
+-- k in a's type.)
+--
+-- See Note [Generalisation for type constructors] in TcTyClsDecls for
+--     data type declarations
+-- and Note [Keeping scoped variables in order: Explicit] in TcHsType
+--     for foralls
+checkValidTelescope :: TyCon -> TcM ()
+checkValidTelescope tc
+  = unless (null bad_tcbs) $ addErr $
+    vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped")
+              2 (text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc))
+         , extra
+         , hang (text "Perhaps try this order instead:")
+              2 (pprTyVars sorted_tidied_tvs) ]
+  where
+    ppr_untidy ty = pprIfaceType (toIfaceType ty)
+    tcbs = tyConBinders tc
+    tvs = binderVars tcbs
+    (_, sorted_tidied_tvs) = tidyVarBndrs emptyTidyEnv (scopedSort tvs)
+
+    (_, bad_tcbs) = foldl add_one (mkVarSet tvs, []) tcbs
+
+    add_one :: (TyVarSet, [TyConBinder])
+            -> TyConBinder -> (TyVarSet, [TyConBinder])
+    add_one (bad_bndrs, acc) tvb
+      | fkvs `intersectsVarSet` bad_bndrs = (bad', tvb : acc)
+      | otherwise                         = (bad', acc)
+      where
+        tv = binderVar tvb
+        fkvs = tyCoVarsOfType (tyVarKind tv)
+        bad' = bad_bndrs `delVarSet` tv
+
+    inferred_tvs  = [ binderVar tcb
+                    | tcb <- tcbs, Inferred == tyConBinderArgFlag tcb ]
+    specified_tvs = [ binderVar tcb
+                    | tcb <- tcbs, Specified == tyConBinderArgFlag tcb ]
+
+    pp_inf  = parens (text "namely:" <+> pprTyVars inferred_tvs)
+    pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs)
+
+    extra
+      | null inferred_tvs && null specified_tvs
+      = empty
+      | null inferred_tvs
+      = hang (text "NB: Specified variables")
+           2 (sep [pp_spec, text "always come first"])
+      | null specified_tvs
+      = hang (text "NB: Inferred variables")
+           2 (sep [pp_inf, text "always come first"])
+      | otherwise
+      = hang (text "NB: Inferred variables")
+           2 (vcat [ sep [ pp_inf, text "always come first"]
+                   , sep [text "then Specified variables", pp_spec]])
+
+{-
+************************************************************************
+*                                                                      *
+\subsection{Auxiliary functions}
+*                                                                      *
+************************************************************************
+-}
+
+-- Free variables of a type, retaining repetitions, and expanding synonyms
+-- This ignores coercions, as coercions aren't user-written
+fvType :: Type -> [TyCoVar]
+fvType ty | Just exp_ty <- tcView ty = fvType exp_ty
+fvType (TyVarTy tv)          = [tv]
+fvType (TyConApp _ tys)      = fvTypes tys
+fvType (LitTy {})            = []
+fvType (AppTy fun arg)       = fvType fun ++ fvType arg
+fvType (FunTy arg res)       = fvType arg ++ fvType res
+fvType (ForAllTy (Bndr tv _) ty)
+  = fvType (tyVarKind tv) ++
+    filter (/= tv) (fvType ty)
+fvType (CastTy ty _)         = fvType ty
+fvType (CoercionTy {})       = []
+
+fvTypes :: [Type] -> [TyVar]
+fvTypes tys                = concat (map fvType tys)
+
+sizeType :: Type -> Int
+-- Size of a type: the number of variables and constructors
+sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty
+sizeType (TyVarTy {})      = 1
+sizeType (TyConApp tc tys) = 1 + sizeTyConAppArgs tc tys
+sizeType (LitTy {})        = 1
+sizeType (AppTy fun arg)   = sizeType fun + sizeType arg
+sizeType (FunTy arg res)   = sizeType arg + sizeType res + 1
+sizeType (ForAllTy _ ty)   = sizeType ty
+sizeType (CastTy ty _)     = sizeType ty
+sizeType (CoercionTy _)    = 0
+
+sizeTypes :: [Type] -> Int
+sizeTypes = foldr ((+) . sizeType) 0
+
+sizeTyConAppArgs :: TyCon -> [Type] -> Int
+sizeTyConAppArgs _tc tys = sizeTypes tys -- (filterOutInvisibleTypes tc tys)
+                           -- See Note [Invisible arguments and termination]
+
+-- Size of a predicate
+--
+-- We are considering whether class constraints terminate.
+-- Equality constraints and constraints for the implicit
+-- parameter class always terminate so it is safe to say "size 0".
+-- See Trac #4200.
+sizePred :: PredType -> Int
+sizePred ty = goClass ty
+  where
+    goClass p = go (classifyPredType p)
+
+    go (ClassPred cls tys')
+      | isTerminatingClass cls = 0
+      | otherwise = sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys')
+                    -- The filtering looks bogus
+                    -- See Note [Invisible arguments and termination]
+    go (EqPred {})           = 0
+    go (IrredPred ty)        = sizeType ty
+    go (ForAllPred _ _ pred) = goClass pred
+
+-- | When this says "True", ignore this class constraint during
+-- a termination check
+isTerminatingClass :: Class -> Bool
+isTerminatingClass cls
+  = isIPClass cls    -- Implicit parameter constraints always terminate because
+                     -- there are no instances for them --- they are only solved
+                     -- by "local instances" in expressions
+    || cls `hasKey` typeableClassKey
+    || cls `hasKey` coercibleTyConKey
+    || cls `hasKey` eqTyConKey
+    || cls `hasKey` heqTyConKey
+
+-- | Tidy before printing a type
+ppr_tidy :: TidyEnv -> Type -> SDoc
+ppr_tidy env ty = pprType (tidyType env ty)
+
+allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool
+-- (allDistinctTyVars tvs tys) returns True if tys are
+-- a) all tyvars
+-- b) all distinct
+-- c) disjoint from tvs
+allDistinctTyVars _    [] = True
+allDistinctTyVars tkvs (ty : tys)
+  = case getTyVar_maybe ty of
+      Nothing -> False
+      Just tv | tv `elemVarSet` tkvs -> False
+              | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys
diff --git a/compiler/utils/AsmUtils.hs b/compiler/utils/AsmUtils.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/AsmUtils.hs
@@ -0,0 +1,20 @@
+-- | Various utilities used in generating assembler.
+--
+-- These are used not only by the native code generator, but also by the
+-- "DriverPipeline".
+module AsmUtils
+    ( sectionType
+    ) where
+
+import GhcPrelude
+
+import Platform
+import Outputable
+
+-- | Generate a section type (e.g. @\@progbits@). See #13937.
+sectionType :: String -- ^ section type
+            -> SDoc   -- ^ pretty assembler fragment
+sectionType ty = sdocWithPlatform $ \platform ->
+    case platformArch platform of
+      ArchARM{} -> char '%' <> text ty
+      _         -> char '@' <> text ty
diff --git a/compiler/utils/GraphBase.hs b/compiler/utils/GraphBase.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/GraphBase.hs
@@ -0,0 +1,107 @@
+
+-- | Types for the general graph colorer.
+module GraphBase (
+        Triv,
+        Graph (..),
+        initGraph,
+        graphMapModify,
+
+        Node  (..),     newNode,
+)
+
+
+where
+
+import GhcPrelude
+
+import UniqSet
+import UniqFM
+
+
+-- | A fn to check if a node is trivially colorable
+--      For graphs who's color classes are disjoint then a node is 'trivially colorable'
+--      when it has less neighbors and exclusions than available colors for that node.
+--
+--      For graph's who's color classes overlap, ie some colors alias other colors, then
+--      this can be a bit more tricky. There is a general way to calculate this, but
+--      it's likely be too slow for use in the code. The coloring algorithm takes
+--      a canned function which can be optimised by the user to be specific to the
+--      specific graph being colored.
+--
+--      for details, see  "A Generalised Algorithm for Graph-Coloring Register Allocation"
+--                              Smith, Ramsey, Holloway - PLDI 2004.
+--
+type Triv k cls color
+        =  cls                  -- the class of the node we're trying to color.
+        -> UniqSet k            -- the node's neighbors.
+        -> UniqSet color        -- the node's exclusions.
+        -> Bool
+
+
+-- | The Interference graph.
+--      There used to be more fields, but they were turfed out in a previous revision.
+--      maybe we'll want more later..
+--
+data Graph k cls color
+        = Graph {
+        -- | All active nodes in the graph.
+          graphMap              :: UniqFM (Node k cls color)  }
+
+
+-- | An empty graph.
+initGraph :: Graph k cls color
+initGraph
+        = Graph
+        { graphMap              = emptyUFM }
+
+
+-- | Modify the finite map holding the nodes in the graph.
+graphMapModify
+        :: (UniqFM (Node k cls color) -> UniqFM (Node k cls color))
+        -> Graph k cls color -> Graph k cls color
+
+graphMapModify f graph
+        = graph { graphMap      = f (graphMap graph) }
+
+
+
+-- | Graph nodes.
+--      Represents a thing that can conflict with another thing.
+--      For the register allocater the nodes represent registers.
+--
+data Node k cls color
+        = Node {
+        -- | A unique identifier for this node.
+          nodeId                :: k
+
+        -- | The class of this node,
+        --      determines the set of colors that can be used.
+        , nodeClass             :: cls
+
+        -- | The color of this node, if any.
+        , nodeColor             :: Maybe color
+
+        -- | Neighbors which must be colored differently to this node.
+        , nodeConflicts         :: UniqSet k
+
+        -- | Colors that cannot be used by this node.
+        , nodeExclusions        :: UniqSet color
+
+        -- | Colors that this node would prefer to be, in decending order.
+        , nodePreference        :: [color]
+
+        -- | Neighbors that this node would like to be colored the same as.
+        , nodeCoalesce          :: UniqSet k }
+
+
+-- | An empty node.
+newNode :: k -> cls -> Node k cls color
+newNode k cls
+        = Node
+        { nodeId                = k
+        , nodeClass             = cls
+        , nodeColor             = Nothing
+        , nodeConflicts         = emptyUniqSet
+        , nodeExclusions        = emptyUniqSet
+        , nodePreference        = []
+        , nodeCoalesce          = emptyUniqSet }
diff --git a/compiler/utils/GraphColor.hs b/compiler/utils/GraphColor.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/GraphColor.hs
@@ -0,0 +1,373 @@
+-- | Graph Coloring.
+--      This is a generic graph coloring library, abstracted over the type of
+--      the node keys, nodes and colors.
+--
+
+module GraphColor (
+        module GraphBase,
+        module GraphOps,
+        module GraphPpr,
+        colorGraph
+)
+
+where
+
+import GhcPrelude
+
+import GraphBase
+import GraphOps
+import GraphPpr
+
+import Unique
+import UniqFM
+import UniqSet
+import Outputable
+
+import Data.Maybe
+import Data.List
+
+
+-- | Try to color a graph with this set of colors.
+--      Uses Chaitin's algorithm to color the graph.
+--      The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes
+--      are pushed onto a stack and removed from the graph.
+--      Once this process is complete the graph can be colored by removing nodes from
+--      the stack (ie in reverse order) and assigning them colors different to their neighbors.
+--
+colorGraph
+        :: ( Uniquable  k, Uniquable cls,  Uniquable  color
+           , Eq cls, Ord k
+           , Outputable k, Outputable cls, Outputable color)
+        => Bool                         -- ^ whether to do iterative coalescing
+        -> Int                          -- ^ how many times we've tried to color this graph so far.
+        -> UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
+        -> Triv   k cls color           -- ^ fn to decide whether a node is trivially colorable.
+        -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
+        -> Graph  k cls color           -- ^ the graph to color.
+
+        -> ( Graph k cls color          -- the colored graph.
+           , UniqSet k                  -- the set of nodes that we couldn't find a color for.
+           , UniqFM  k )                -- map of regs (r1 -> r2) that were coalesced
+                                        --       r1 should be replaced by r2 in the source
+
+colorGraph iterative spinCount colors triv spill graph0
+ = let
+        -- If we're not doing iterative coalescing then do an aggressive coalescing first time
+        --      around and then conservative coalescing for subsequent passes.
+        --
+        --      Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if
+        --      there is a lot of register pressure and we do it on every round then it can make the
+        --      graph less colorable and prevent the algorithm from converging in a sensible number
+        --      of cycles.
+        --
+        (graph_coalesced, kksCoalesce1)
+         = if iterative
+                then (graph0, [])
+                else if spinCount == 0
+                        then coalesceGraph True  triv graph0
+                        else coalesceGraph False triv graph0
+
+        -- run the scanner to slurp out all the trivially colorable nodes
+        --      (and do coalescing if iterative coalescing is enabled)
+        (ksTriv, ksProblems, kksCoalesce2)
+                = colorScan iterative triv spill graph_coalesced
+
+        -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business.
+        --      We need to apply all the coalescences found by the scanner to the original
+        --      graph before doing assignColors.
+        --
+        --      Because we've got the whole, non-pruned graph here we turn on aggressive coalecing
+        --      to force all the (conservative) coalescences found during scanning.
+        --
+        (graph_scan_coalesced, _)
+                = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2
+
+        -- color the trivially colorable nodes
+        --      during scanning, keys of triv nodes were added to the front of the list as they were found
+        --      this colors them in the reverse order, as required by the algorithm.
+        (graph_triv, ksNoTriv)
+                = assignColors colors graph_scan_coalesced ksTriv
+
+        -- try and color the problem nodes
+        --      problem nodes are the ones that were left uncolored because they weren't triv.
+        --      theres a change we can color them here anyway.
+        (graph_prob, ksNoColor)
+                = assignColors colors graph_triv ksProblems
+
+        -- if the trivially colorable nodes didn't color then something is probably wrong
+        --      with the provided triv function.
+        --
+   in   if not $ null ksNoTriv
+         then   pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty
+                        (  empty
+                        $$ text "ksTriv    = " <> ppr ksTriv
+                        $$ text "ksNoTriv  = " <> ppr ksNoTriv
+                        $$ text "colors    = " <> ppr colors
+                        $$ empty
+                        $$ dotGraph (\_ -> text "white") triv graph_triv)
+
+         else   ( graph_prob
+                , mkUniqSet ksNoColor   -- the nodes that didn't color (spills)
+                , if iterative
+                        then (listToUFM kksCoalesce2)
+                        else (listToUFM kksCoalesce1))
+
+
+-- | Scan through the conflict graph separating out trivially colorable and
+--      potentially uncolorable (problem) nodes.
+--
+--      Checking whether a node is trivially colorable or not is a reasonably expensive operation,
+--      so after a triv node is found and removed from the graph it's no good to return to the 'start'
+--      of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable.
+--
+--      To ward against this, during each pass through the graph we collect up a list of triv nodes
+--      that were found, and only remove them once we've finished the pass. The more nodes we can delete
+--      at once the more likely it is that nodes we've already checked will become trivially colorable
+--      for the next pass.
+--
+--      TODO:   add work lists to finding triv nodes is easier.
+--              If we've just scanned the graph, and removed triv nodes, then the only
+--              nodes that we need to rescan are the ones we've removed edges from.
+
+colorScan
+        :: ( Uniquable k, Uniquable cls, Uniquable color
+           , Ord k,       Eq cls
+           , Outputable k, Outputable cls)
+        => Bool                         -- ^ whether to do iterative coalescing
+        -> Triv k cls color             -- ^ fn to decide whether a node is trivially colorable
+        -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.
+        -> Graph k cls color            -- ^ the graph to scan
+
+        -> ([k], [k], [(k, k)])         --  triv colorable nodes, problem nodes, pairs of nodes to coalesce
+
+colorScan iterative triv spill graph
+        = colorScan_spin iterative triv spill graph [] [] []
+
+colorScan_spin
+        :: ( Uniquable k, Uniquable cls, Uniquable color
+           , Ord k,       Eq cls
+           , Outputable k, Outputable cls)
+        => Bool
+        -> Triv k cls color
+        -> (Graph k cls color -> k)
+        -> Graph k cls color
+        -> [k]
+        -> [k]
+        -> [(k, k)]
+        -> ([k], [k], [(k, k)])
+
+colorScan_spin iterative triv spill graph
+        ksTriv ksSpill kksCoalesce
+
+        -- if the graph is empty then we're done
+        | isNullUFM $ graphMap graph
+        = (ksTriv, ksSpill, reverse kksCoalesce)
+
+        -- Simplify:
+        --      Look for trivially colorable nodes.
+        --      If we can find some then remove them from the graph and go back for more.
+        --
+        | nsTrivFound@(_:_)
+                <-  scanGraph   (\node -> triv  (nodeClass node) (nodeConflicts node) (nodeExclusions node)
+
+                                  -- for iterative coalescing we only want non-move related
+                                  --    nodes here
+                                  && (not iterative || isEmptyUniqSet (nodeCoalesce node)))
+                        $ graph
+
+        , ksTrivFound   <- map nodeId nsTrivFound
+        , graph2        <- foldr (\k g -> let Just g' = delNode k g
+                                          in  g')
+                                graph ksTrivFound
+
+        = colorScan_spin iterative triv spill graph2
+                (ksTrivFound ++ ksTriv)
+                ksSpill
+                kksCoalesce
+
+        -- Coalesce:
+        --      If we're doing iterative coalescing and no triv nodes are available
+        --      then it's time for a coalescing pass.
+        | iterative
+        = case coalesceGraph False triv graph of
+
+                -- we were able to coalesce something
+                --      go back to Simplify and see if this frees up more nodes to be trivially colorable.
+                (graph2, kksCoalesceFound@(_:_))
+                 -> colorScan_spin iterative triv spill graph2
+                        ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce)
+
+                -- Freeze:
+                -- nothing could be coalesced (or was triv),
+                --      time to choose a node to freeze and give up on ever coalescing it.
+                (graph2, [])
+                 -> case freezeOneInGraph graph2 of
+
+                        -- we were able to freeze something
+                        --      hopefully this will free up something for Simplify
+                        (graph3, True)
+                         -> colorScan_spin iterative triv spill graph3
+                                ksTriv ksSpill kksCoalesce
+
+                        -- we couldn't find something to freeze either
+                        --      time for a spill
+                        (graph3, False)
+                         -> colorScan_spill iterative triv spill graph3
+                                ksTriv ksSpill kksCoalesce
+
+        -- spill time
+        | otherwise
+        = colorScan_spill iterative triv spill graph
+                ksTriv ksSpill kksCoalesce
+
+
+-- Select:
+-- we couldn't find any triv nodes or things to freeze or coalesce,
+--      and the graph isn't empty yet.. We'll have to choose a spill
+--      candidate and leave it uncolored.
+--
+colorScan_spill
+        :: ( Uniquable k, Uniquable cls, Uniquable color
+           , Ord k,       Eq cls
+           , Outputable k, Outputable cls)
+        => Bool
+        -> Triv k cls color
+        -> (Graph k cls color -> k)
+        -> Graph k cls color
+        -> [k]
+        -> [k]
+        -> [(k, k)]
+        -> ([k], [k], [(k, k)])
+
+colorScan_spill iterative triv spill graph
+        ksTriv ksSpill kksCoalesce
+
+ = let  kSpill          = spill graph
+        Just graph'     = delNode kSpill graph
+   in   colorScan_spin iterative triv spill graph'
+                ksTriv (kSpill : ksSpill) kksCoalesce
+
+
+-- | Try to assign a color to all these nodes.
+
+assignColors
+        :: ( Uniquable k, Uniquable cls, Uniquable color
+           , Outputable cls)
+        => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
+        -> Graph k cls color            -- ^ the graph
+        -> [k]                          -- ^ nodes to assign a color to.
+        -> ( Graph k cls color          -- the colored graph
+           , [k])                       -- the nodes that didn't color.
+
+assignColors colors graph ks
+        = assignColors' colors graph [] ks
+
+ where  assignColors' _ graph prob []
+                = (graph, prob)
+
+        assignColors' colors graph prob (k:ks)
+         = case assignColor colors k graph of
+
+                -- couldn't color this node
+                Nothing         -> assignColors' colors graph (k : prob) ks
+
+                -- this node colored ok, so do the rest
+                Just graph'     -> assignColors' colors graph' prob ks
+
+
+        assignColor colors u graph
+                | Just c        <- selectColor colors graph u
+                = Just (setColor u c graph)
+
+                | otherwise
+                = Nothing
+
+
+
+-- | Select a color for a certain node
+--      taking into account preferences, neighbors and exclusions.
+--      returns Nothing if no color can be assigned to this node.
+--
+selectColor
+        :: ( Uniquable k, Uniquable cls, Uniquable color
+           , Outputable cls)
+        => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).
+        -> Graph k cls color            -- ^ the graph
+        -> k                            -- ^ key of the node to select a color for.
+        -> Maybe color
+
+selectColor colors graph u
+ = let  -- lookup the node
+        Just node       = lookupNode graph u
+
+        -- lookup the available colors for the class of this node.
+        colors_avail
+         = case lookupUFM colors (nodeClass node) of
+                Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node))
+                Just cs -> cs
+
+        -- find colors we can't use because they're already being used
+        --      by a node that conflicts with this one.
+        Just nsConflicts
+                        = sequence
+                        $ map (lookupNode graph)
+                        $ nonDetEltsUniqSet
+                        $ nodeConflicts node
+                        -- See Note [Unique Determinism and code generation]
+
+        colors_conflict = mkUniqSet
+                        $ catMaybes
+                        $ map nodeColor nsConflicts
+
+        -- the prefs of our neighbors
+        colors_neighbor_prefs
+                        = mkUniqSet
+                        $ concat $ map nodePreference nsConflicts
+
+        -- colors that are still valid for us
+        colors_ok_ex    = minusUniqSet colors_avail (nodeExclusions node)
+        colors_ok       = minusUniqSet colors_ok_ex colors_conflict
+
+        -- the colors that we prefer, and are still ok
+        colors_ok_pref  = intersectUniqSets
+                                (mkUniqSet $ nodePreference node) colors_ok
+
+        -- the colors that we could choose while being nice to our neighbors
+        colors_ok_nice  = minusUniqSet
+                                colors_ok colors_neighbor_prefs
+
+        -- the best of all possible worlds..
+        colors_ok_pref_nice
+                        = intersectUniqSets
+                                colors_ok_nice colors_ok_pref
+
+        -- make the decision
+        chooseColor
+
+                -- everyone is happy, yay!
+                | not $ isEmptyUniqSet colors_ok_pref_nice
+                , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice)
+                                        (nodePreference node)
+                = Just c
+
+                -- we've got one of our preferences
+                | not $ isEmptyUniqSet colors_ok_pref
+                , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref)
+                                        (nodePreference node)
+                = Just c
+
+                -- it wasn't a preference, but it was still ok
+                | not $ isEmptyUniqSet colors_ok
+                , c : _         <- nonDetEltsUniqSet colors_ok
+                -- See Note [Unique Determinism and code generation]
+                = Just c
+
+                -- no colors were available for us this time.
+                --      looks like we're going around the loop again..
+                | otherwise
+                = Nothing
+
+   in   chooseColor
+
+
+
diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/GraphOps.hs
@@ -0,0 +1,680 @@
+-- | Basic operations on graphs.
+--
+
+module GraphOps (
+        addNode,        delNode,        getNode,       lookupNode,     modNode,
+        size,
+        union,
+        addConflict,    delConflict,    addConflicts,
+        addCoalesce,    delCoalesce,
+        addExclusion,   addExclusions,
+        addPreference,
+        coalesceNodes,  coalesceGraph,
+        freezeNode,     freezeOneInGraph, freezeAllInGraph,
+        scanGraph,
+        setColor,
+        validateGraph,
+        slurpNodeConflictCount
+)
+where
+
+import GhcPrelude
+
+import GraphBase
+
+import Outputable
+import Unique
+import UniqSet
+import UniqFM
+
+import Data.List        hiding (union)
+import Data.Maybe
+
+-- | Lookup a node from the graph.
+lookupNode
+        :: Uniquable k
+        => Graph k cls color
+        -> k -> Maybe (Node  k cls color)
+
+lookupNode graph k
+        = lookupUFM (graphMap graph) k
+
+
+-- | Get a node from the graph, throwing an error if it's not there
+getNode
+        :: Uniquable k
+        => Graph k cls color
+        -> k -> Node k cls color
+
+getNode graph k
+ = case lookupUFM (graphMap graph) k of
+        Just node       -> node
+        Nothing         -> panic "ColorOps.getNode: not found"
+
+
+-- | Add a node to the graph, linking up its edges
+addNode :: Uniquable k
+        => k -> Node k cls color
+        -> Graph k cls color -> Graph k cls color
+
+addNode k node graph
+ = let
+        -- add back conflict edges from other nodes to this one
+        map_conflict =
+          nonDetFoldUniqSet
+            -- It's OK to use nonDetFoldUFM here because the
+            -- operation is commutative
+            (adjustUFM_C (\n -> n { nodeConflicts =
+                                      addOneToUniqSet (nodeConflicts n) k}))
+            (graphMap graph)
+            (nodeConflicts node)
+
+        -- add back coalesce edges from other nodes to this one
+        map_coalesce =
+          nonDetFoldUniqSet
+            -- It's OK to use nonDetFoldUFM here because the
+            -- operation is commutative
+            (adjustUFM_C (\n -> n { nodeCoalesce =
+                                      addOneToUniqSet (nodeCoalesce n) k}))
+            map_conflict
+            (nodeCoalesce node)
+
+  in    graph
+        { graphMap      = addToUFM map_coalesce k node}
+
+
+-- | Delete a node and all its edges from the graph.
+delNode :: (Uniquable k)
+        => k -> Graph k cls color -> Maybe (Graph k cls color)
+
+delNode k graph
+        | Just node     <- lookupNode graph k
+        = let   -- delete conflict edges from other nodes to this one.
+                graph1  = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph
+                        $ nonDetEltsUniqSet (nodeConflicts node)
+
+                -- delete coalesce edge from other nodes to this one.
+                graph2  = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1
+                        $ nonDetEltsUniqSet (nodeCoalesce node)
+                        -- See Note [Unique Determinism and code generation]
+
+                -- delete the node
+                graph3  = graphMapModify (\fm -> delFromUFM fm k) graph2
+
+          in    Just graph3
+
+        | otherwise
+        = Nothing
+
+
+-- | Modify a node in the graph.
+--      returns Nothing if the node isn't present.
+--
+modNode :: Uniquable k
+        => (Node k cls color -> Node k cls color)
+        -> k -> Graph k cls color -> Maybe (Graph k cls color)
+
+modNode f k graph
+ = case lookupNode graph k of
+        Just Node{}
+         -> Just
+         $  graphMapModify
+                 (\fm   -> let  Just node       = lookupUFM fm k
+                                node'           = f node
+                           in   addToUFM fm k node')
+                graph
+
+        Nothing -> Nothing
+
+
+-- | Get the size of the graph, O(n)
+size    :: Graph k cls color -> Int
+
+size graph
+        = sizeUFM $ graphMap graph
+
+
+-- | Union two graphs together.
+union   :: Graph k cls color -> Graph k cls color -> Graph k cls color
+
+union   graph1 graph2
+        = Graph
+        { graphMap              = plusUFM (graphMap graph1) (graphMap graph2) }
+
+
+-- | Add a conflict between nodes to the graph, creating the nodes required.
+--      Conflicts are virtual regs which need to be colored differently.
+addConflict
+        :: Uniquable k
+        => (k, cls) -> (k, cls)
+        -> Graph k cls color -> Graph k cls color
+
+addConflict (u1, c1) (u2, c2)
+ = let  addNeighbor u c u'
+                = adjustWithDefaultUFM
+                        (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })
+                        (newNode u c)  { nodeConflicts = unitUniqSet u' }
+                        u
+
+   in   graphMapModify
+        ( addNeighbor u1 c1 u2
+        . addNeighbor u2 c2 u1)
+
+
+-- | Delete a conflict edge. k1 -> k2
+--      returns Nothing if the node isn't in the graph
+delConflict
+        :: Uniquable k
+        => k -> k
+        -> Graph k cls color -> Maybe (Graph k cls color)
+
+delConflict k1 k2
+        = modNode
+                (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })
+                k1
+
+
+-- | Add some conflicts to the graph, creating nodes if required.
+--      All the nodes in the set are taken to conflict with each other.
+addConflicts
+        :: Uniquable k
+        => UniqSet k -> (k -> cls)
+        -> Graph k cls color -> Graph k cls color
+
+addConflicts conflicts getClass
+
+        -- just a single node, but no conflicts, create the node anyway.
+        | (u : [])      <- nonDetEltsUniqSet conflicts
+        = graphMapModify
+        $ adjustWithDefaultUFM
+                id
+                (newNode u (getClass u))
+                u
+
+        | otherwise
+        = graphMapModify
+        $ \fm -> foldl' (\g u  -> addConflictSet1 u getClass conflicts g) fm
+                $ nonDetEltsUniqSet conflicts
+                -- See Note [Unique Determinism and code generation]
+
+
+addConflictSet1 :: Uniquable k
+                => k -> (k -> cls) -> UniqSet k
+                -> UniqFM (Node k cls color)
+                -> UniqFM (Node k cls color)
+addConflictSet1 u getClass set
+ = case delOneFromUniqSet set u of
+    set' -> adjustWithDefaultUFM
+                (\node -> node                  { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )
+                (newNode u (getClass u))        { nodeConflicts = set' }
+                u
+
+
+-- | Add an exclusion to the graph, creating nodes if required.
+--      These are extra colors that the node cannot use.
+addExclusion
+        :: (Uniquable k, Uniquable color)
+        => k -> (k -> cls) -> color
+        -> Graph k cls color -> Graph k cls color
+
+addExclusion u getClass color
+        = graphMapModify
+        $ adjustWithDefaultUFM
+                (\node -> node                  { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })
+                (newNode u (getClass u))        { nodeExclusions = unitUniqSet color }
+                u
+
+addExclusions
+        :: (Uniquable k, Uniquable color)
+        => k -> (k -> cls) -> [color]
+        -> Graph k cls color -> Graph k cls color
+
+addExclusions u getClass colors graph
+        = foldr (addExclusion u getClass) graph colors
+
+
+-- | Add a coalescence edge to the graph, creating nodes if requried.
+--      It is considered adventageous to assign the same color to nodes in a coalesence.
+addCoalesce
+        :: Uniquable k
+        => (k, cls) -> (k, cls)
+        -> Graph k cls color -> Graph k cls color
+
+addCoalesce (u1, c1) (u2, c2)
+ = let  addCoalesce u c u'
+         =      adjustWithDefaultUFM
+                        (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })
+                        (newNode u c)  { nodeCoalesce = unitUniqSet u' }
+                        u
+
+   in   graphMapModify
+        ( addCoalesce u1 c1 u2
+        . addCoalesce u2 c2 u1)
+
+
+-- | Delete a coalescence edge (k1 -> k2) from the graph.
+delCoalesce
+        :: Uniquable k
+        => k -> k
+        -> Graph k cls color    -> Maybe (Graph k cls color)
+
+delCoalesce k1 k2
+        = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })
+                k1
+
+
+-- | Add a color preference to the graph, creating nodes if required.
+--      The most recently added preference is the most prefered.
+--      The algorithm tries to assign a node it's prefered color if possible.
+--
+addPreference
+        :: Uniquable k
+        => (k, cls) -> color
+        -> Graph k cls color -> Graph k cls color
+
+addPreference (u, c) color
+        = graphMapModify
+        $ adjustWithDefaultUFM
+                (\node -> node { nodePreference = color : (nodePreference node) })
+                (newNode u c)  { nodePreference = [color] }
+                u
+
+
+-- | Do aggressive coalescing on this graph.
+--      returns the new graph and the list of pairs of nodes that got coalesced together.
+--      for each pair, the resulting node will have the least key and be second in the pair.
+--
+coalesceGraph
+        :: (Uniquable k, Ord k, Eq cls, Outputable k)
+        => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
+                                --      less colorable (aggressive coalescing)
+        -> Triv k cls color
+        -> Graph k cls color
+        -> ( Graph k cls color
+           , [(k, k)])          -- pairs of nodes that were coalesced, in the order that the
+                                --      coalescing was applied.
+
+coalesceGraph aggressive triv graph
+        = coalesceGraph' aggressive triv graph []
+
+coalesceGraph'
+        :: (Uniquable k, Ord k, Eq cls, Outputable k)
+        => Bool
+        -> Triv k cls color
+        -> Graph k cls color
+        -> [(k, k)]
+        -> ( Graph k cls color
+           , [(k, k)])
+coalesceGraph' aggressive triv graph kkPairsAcc
+ = let
+        -- find all the nodes that have coalescence edges
+        cNodes  = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))
+                $ nonDetEltsUFM $ graphMap graph
+                -- See Note [Unique Determinism and code generation]
+
+        -- build a list of pairs of keys for node's we'll try and coalesce
+        --      every pair of nodes will appear twice in this list
+        --      ie [(k1, k2), (k2, k1) ... ]
+        --      This is ok, GrapOps.coalesceNodes handles this and it's convenient for
+        --      build a list of what nodes get coalesced together for later on.
+        --
+        cList   = [ (nodeId node1, k2)
+                        | node1 <- cNodes
+                        , k2    <- nonDetEltsUniqSet $ nodeCoalesce node1 ]
+                        -- See Note [Unique Determinism and code generation]
+
+        -- do the coalescing, returning the new graph and a list of pairs of keys
+        --      that got coalesced together.
+        (graph', mPairs)
+                = mapAccumL (coalesceNodes aggressive triv) graph cList
+
+        -- keep running until there are no more coalesces can be found
+   in   case catMaybes mPairs of
+         []     -> (graph', reverse kkPairsAcc)
+         pairs  -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc)
+
+
+-- | Coalesce this pair of nodes unconditionally \/ aggressively.
+--      The resulting node is the one with the least key.
+--
+--      returns: Just    the pair of keys if the nodes were coalesced
+--                       the second element of the pair being the least one
+--
+--               Nothing if either of the nodes weren't in the graph
+
+coalesceNodes
+        :: (Uniquable k, Ord k, Eq cls)
+        => Bool                 -- ^ If True, coalesce nodes even if this might make the graph
+                                --      less colorable (aggressive coalescing)
+        -> Triv  k cls color
+        -> Graph k cls color
+        -> (k, k)               -- ^ keys of the nodes to be coalesced
+        -> (Graph k cls color, Maybe (k, k))
+
+coalesceNodes aggressive triv graph (k1, k2)
+        | (kMin, kMax)  <- if k1 < k2
+                                then (k1, k2)
+                                else (k2, k1)
+
+        -- the nodes being coalesced must be in the graph
+        , Just nMin     <- lookupNode graph kMin
+        , Just nMax     <- lookupNode graph kMax
+
+        -- can't coalesce conflicting modes
+        , not $ elementOfUniqSet kMin (nodeConflicts nMax)
+        , not $ elementOfUniqSet kMax (nodeConflicts nMin)
+
+        -- can't coalesce the same node
+        , nodeId nMin /= nodeId nMax
+
+        = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
+
+        -- don't do the coalescing after all
+        | otherwise
+        = (graph, Nothing)
+
+coalesceNodes_merge
+        :: (Uniquable k, Eq cls)
+        => Bool
+        -> Triv  k cls color
+        -> Graph k cls color
+        -> k -> k
+        -> Node k cls color
+        -> Node k cls color
+        -> (Graph k cls color, Maybe (k, k))
+
+coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax
+
+        -- sanity checks
+        | nodeClass nMin /= nodeClass nMax
+        = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes."
+
+        | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))
+        = error "GraphOps.coalesceNodes: can't coalesce colored nodes."
+
+        ---
+        | otherwise
+        = let
+                -- the new node gets all the edges from its two components
+                node    =
+                 Node   { nodeId                = kMin
+                        , nodeClass             = nodeClass nMin
+                        , nodeColor             = Nothing
+
+                        -- nodes don't conflict with themselves..
+                        , nodeConflicts
+                                = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))
+                                        `delOneFromUniqSet` kMin
+                                        `delOneFromUniqSet` kMax
+
+                        , nodeExclusions        = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)
+                        , nodePreference        = nodePreference nMin ++ nodePreference nMax
+
+                        -- nodes don't coalesce with themselves..
+                        , nodeCoalesce
+                                = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))
+                                        `delOneFromUniqSet` kMin
+                                        `delOneFromUniqSet` kMax
+                        }
+
+          in    coalesceNodes_check aggressive triv graph kMin kMax node
+
+coalesceNodes_check
+        :: Uniquable k
+        => Bool
+        -> Triv  k cls color
+        -> Graph k cls color
+        -> k -> k
+        -> Node k cls color
+        -> (Graph k cls color, Maybe (k, k))
+
+coalesceNodes_check aggressive triv graph kMin kMax node
+
+        -- Unless we're coalescing aggressively, if the result node is not trivially
+        --      colorable then don't do the coalescing.
+        | not aggressive
+        , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
+        = (graph, Nothing)
+
+        | otherwise
+        = let -- delete the old nodes from the graph and add the new one
+                Just graph1     = delNode kMax graph
+                Just graph2     = delNode kMin graph1
+                graph3          = addNode kMin node graph2
+
+          in    (graph3, Just (kMax, kMin))
+
+
+-- | Freeze a node
+--      This is for the iterative coalescer.
+--      By freezing a node we give up on ever coalescing it.
+--      Move all its coalesce edges into the frozen set - and update
+--      back edges from other nodes.
+--
+freezeNode
+        :: Uniquable k
+        => k                    -- ^ key of the node to freeze
+        -> Graph k cls color    -- ^ the graph
+        -> Graph k cls color    -- ^ graph with that node frozen
+
+freezeNode k
+  = graphMapModify
+  $ \fm ->
+    let -- freeze all the edges in the node to be frozen
+        Just node = lookupUFM fm k
+        node'   = node
+                { nodeCoalesce          = emptyUniqSet }
+
+        fm1     = addToUFM fm k node'
+
+        -- update back edges pointing to this node
+        freezeEdge k node
+         = if elementOfUniqSet k (nodeCoalesce node)
+                then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k }
+                else node       -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set"
+                                -- If the edge isn't actually in the coelesce set then just ignore it.
+
+        fm2     = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1
+                    -- It's OK to use nonDetFoldUFM here because the operation
+                    -- is commutative
+                        $ nodeCoalesce node
+
+    in  fm2
+
+
+-- | Freeze one node in the graph
+--      This if for the iterative coalescer.
+--      Look for a move related node of low degree and freeze it.
+--
+--      We probably don't need to scan the whole graph looking for the node of absolute
+--      lowest degree. Just sample the first few and choose the one with the lowest
+--      degree out of those. Also, we don't make any distinction between conflicts of different
+--      classes.. this is just a heuristic, after all.
+--
+--      IDEA:   freezing a node might free it up for Simplify.. would be good to check for triv
+--              right here, and add it to a worklist if known triv\/non-move nodes.
+--
+freezeOneInGraph
+        :: (Uniquable k)
+        => Graph k cls color
+        -> ( Graph k cls color          -- the new graph
+           , Bool )                     -- whether we found a node to freeze
+
+freezeOneInGraph graph
+ = let  compareNodeDegree n1 n2
+                = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2)
+
+        candidates
+                = sortBy compareNodeDegree
+                $ take 5        -- 5 isn't special, it's just a small number.
+                $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph
+
+   in   case candidates of
+
+         -- there wasn't anything available to freeze
+         []     -> (graph, False)
+
+         -- we found something to freeze
+         (n : _)
+          -> ( freezeNode (nodeId n) graph
+             , True)
+
+
+-- | Freeze all the nodes in the graph
+--      for debugging the iterative allocator.
+--
+freezeAllInGraph
+        :: (Uniquable k)
+        => Graph k cls color
+        -> Graph k cls color
+
+freezeAllInGraph graph
+        = foldr freezeNode graph
+                $ map nodeId
+                $ nonDetEltsUFM $ graphMap graph
+                -- See Note [Unique Determinism and code generation]
+
+
+-- | Find all the nodes in the graph that meet some criteria
+--
+scanGraph
+        :: (Node k cls color -> Bool)
+        -> Graph k cls color
+        -> [Node k cls color]
+
+scanGraph match graph
+        = filter match $ nonDetEltsUFM $ graphMap graph
+          -- See Note [Unique Determinism and code generation]
+
+
+-- | validate the internal structure of a graph
+--      all its edges should point to valid nodes
+--      If they don't then throw an error
+--
+validateGraph
+        :: (Uniquable k, Outputable k, Eq color)
+        => SDoc                         -- ^ extra debugging info to display on error
+        -> Bool                         -- ^ whether this graph is supposed to be colored.
+        -> Graph k cls color            -- ^ graph to validate
+        -> Graph k cls color            -- ^ validated graph
+
+validateGraph doc isColored graph
+
+        -- Check that all edges point to valid nodes.
+        | edges         <- unionManyUniqSets
+                                (  (map nodeConflicts       $ nonDetEltsUFM $ graphMap graph)
+                                ++ (map nodeCoalesce        $ nonDetEltsUFM $ graphMap graph))
+
+        , nodes         <- mkUniqSet $ map nodeId $ nonDetEltsUFM $ graphMap graph
+        , badEdges      <- minusUniqSet edges nodes
+        , not $ isEmptyUniqSet badEdges
+        = pprPanic "GraphOps.validateGraph"
+                (  text "Graph has edges that point to non-existent nodes"
+                $$ text "  bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr)
+                $$ doc )
+
+        -- Check that no conflicting nodes have the same color
+        | badNodes      <- filter (not . (checkNode graph))
+                        $ nonDetEltsUFM $ graphMap graph
+                           -- See Note [Unique Determinism and code generation]
+        , not $ null badNodes
+        = pprPanic "GraphOps.validateGraph"
+                (  text "Node has same color as one of it's conflicts"
+                $$ text "  bad nodes: " <> hcat (map (ppr . nodeId) badNodes)
+                $$ doc)
+
+        -- If this is supposed to be a colored graph,
+        --      check that all nodes have a color.
+        | isColored
+        , badNodes      <- filter (\n -> isNothing $ nodeColor n)
+                        $  nonDetEltsUFM $ graphMap graph
+        , not $ null badNodes
+        = pprPanic "GraphOps.validateGraph"
+                (  text "Supposably colored graph has uncolored nodes."
+                $$ text "  uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes)
+                $$ doc )
+
+
+        -- graph looks ok
+        | otherwise
+        = graph
+
+
+-- | If this node is colored, check that all the nodes which
+--      conflict with it have different colors.
+checkNode
+        :: (Uniquable k, Eq color)
+        => Graph k cls color
+        -> Node  k cls color
+        -> Bool                 -- ^ True if this node is ok
+
+checkNode graph node
+        | Just color            <- nodeColor node
+        , Just neighbors        <- sequence $ map (lookupNode graph)
+                                $  nonDetEltsUniqSet $ nodeConflicts node
+            -- See Note [Unique Determinism and code generation]
+
+        , neighbourColors       <- catMaybes $ map nodeColor neighbors
+        , elem color neighbourColors
+        = False
+
+        | otherwise
+        = True
+
+
+
+-- | Slurp out a map of how many nodes had a certain number of conflict neighbours
+
+slurpNodeConflictCount
+        :: Graph k cls color
+        -> UniqFM (Int, Int)    -- ^ (conflict neighbours, num nodes with that many conflicts)
+
+slurpNodeConflictCount graph
+        = addListToUFM_C
+                (\(c1, n1) (_, n2) -> (c1, n1 + n2))
+                emptyUFM
+        $ map   (\node
+                  -> let count  = sizeUniqSet $ nodeConflicts node
+                     in  (count, (count, 1)))
+        $ nonDetEltsUFM
+        -- See Note [Unique Determinism and code generation]
+        $ graphMap graph
+
+
+-- | Set the color of a certain node
+setColor
+        :: Uniquable k
+        => k -> color
+        -> Graph k cls color -> Graph k cls color
+
+setColor u color
+        = graphMapModify
+        $ adjustUFM_C
+                (\n -> n { nodeColor = Just color })
+                u
+
+
+{-# INLINE adjustWithDefaultUFM #-}
+adjustWithDefaultUFM
+        :: Uniquable k
+        => (a -> a) -> a -> k
+        -> UniqFM a -> UniqFM a
+
+adjustWithDefaultUFM f def k map
+        = addToUFM_C
+                (\old _ -> f old)
+                map
+                k def
+
+-- Argument order different from UniqFM's adjustUFM
+{-# INLINE adjustUFM_C #-}
+adjustUFM_C
+        :: Uniquable k
+        => (a -> a)
+        -> k -> UniqFM a -> UniqFM a
+
+adjustUFM_C f k map
+ = case lookupUFM map k of
+        Nothing -> map
+        Just a  -> addToUFM map k (f a)
+
diff --git a/compiler/utils/GraphPpr.hs b/compiler/utils/GraphPpr.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/GraphPpr.hs
@@ -0,0 +1,173 @@
+
+-- | Pretty printing of graphs.
+
+module GraphPpr (
+        dumpGraph,
+        dotGraph
+)
+where
+
+import GhcPrelude
+
+import GraphBase
+
+import Outputable
+import Unique
+import UniqSet
+import UniqFM
+
+import Data.List
+import Data.Maybe
+
+
+-- | Pretty print a graph in a somewhat human readable format.
+dumpGraph
+        :: (Outputable k, Outputable color)
+        => Graph k cls color -> SDoc
+
+dumpGraph graph
+        =  text "Graph"
+        $$ pprUFM (graphMap graph) (vcat . map dumpNode)
+
+dumpNode
+        :: (Outputable k, Outputable color)
+        => Node k cls color -> SDoc
+
+dumpNode node
+        =  text "Node " <> ppr (nodeId node)
+        $$ text "conflicts "
+                <> parens (int (sizeUniqSet $ nodeConflicts node))
+                <> text " = "
+                <> ppr (nodeConflicts node)
+
+        $$ text "exclusions "
+                <> parens (int (sizeUniqSet $ nodeExclusions node))
+                <> text " = "
+                <> ppr (nodeExclusions node)
+
+        $$ text "coalesce "
+                <> parens (int (sizeUniqSet $ nodeCoalesce node))
+                <> text " = "
+                <> ppr (nodeCoalesce node)
+
+        $$ space
+
+
+
+-- | Pretty print a graph in graphviz .dot format.
+--      Conflicts get solid edges.
+--      Coalescences get dashed edges.
+dotGraph
+        :: ( Uniquable k
+           , Outputable k, Outputable cls, Outputable color)
+        => (color -> SDoc)  -- ^ What graphviz color to use for each node color
+                            --  It's usually safe to return X11 style colors here,
+                            --  ie "red", "green" etc or a hex triplet #aaff55 etc
+        -> Triv k cls color
+        -> Graph k cls color -> SDoc
+
+dotGraph colorMap triv graph
+ = let  nodes   = nonDetEltsUFM $ graphMap graph
+                  -- See Note [Unique Determinism and code generation]
+   in   vcat
+                (  [ text "graph G {" ]
+                ++ map (dotNode colorMap triv) nodes
+                ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes)
+                ++ [ text "}"
+                   , space ])
+
+
+dotNode :: ( Outputable k, Outputable cls, Outputable color)
+        => (color -> SDoc)
+        -> Triv k cls color
+        -> Node k cls color -> SDoc
+
+dotNode colorMap triv node
+ = let  name    = ppr $ nodeId node
+        cls     = ppr $ nodeClass node
+
+        excludes
+                = hcat $ punctuate space
+                $ map (\n -> text "-" <> ppr n)
+                $ nonDetEltsUniqSet $ nodeExclusions node
+                -- See Note [Unique Determinism and code generation]
+
+        preferences
+                = hcat $ punctuate space
+                $ map (\n -> text "+" <> ppr n)
+                $ nodePreference node
+
+        expref  = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)]
+                        then empty
+                        else text "\\n" <> (excludes <+> preferences)
+
+        -- if the node has been colored then show that,
+        --      otherwise indicate whether it looks trivially colorable.
+        color
+                | Just c        <- nodeColor node
+                = text "\\n(" <> ppr c <> text ")"
+
+                | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)
+                = text "\\n(" <> text "triv" <> text ")"
+
+                | otherwise
+                = text "\\n(" <> text "spill?" <> text ")"
+
+        label   =  name <> text " :: " <> cls
+                <> expref
+                <> color
+
+        pcolorC = case nodeColor node of
+                        Nothing -> text "style=filled fillcolor=white"
+                        Just c  -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c)
+
+
+        pout    = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]"
+                <> space <> doubleQuotes name
+                <> text ";"
+
+ in     pout
+
+
+-- | Nodes in the graph are doubly linked, but we only want one edge for each
+--      conflict if the graphviz graph. Traverse over the graph, but make sure
+--      to only print the edges for each node once.
+
+dotNodeEdges
+        :: ( Uniquable k
+           , Outputable k)
+        => UniqSet k
+        -> Node k cls color
+        -> (UniqSet k, Maybe SDoc)
+
+dotNodeEdges visited node
+        | elementOfUniqSet (nodeId node) visited
+        = ( visited
+          , Nothing)
+
+        | otherwise
+        = let   dconflicts
+                        = map (dotEdgeConflict (nodeId node))
+                        $ nonDetEltsUniqSet
+                        -- See Note [Unique Determinism and code generation]
+                        $ minusUniqSet (nodeConflicts node) visited
+
+                dcoalesces
+                        = map (dotEdgeCoalesce (nodeId node))
+                        $ nonDetEltsUniqSet
+                        -- See Note [Unique Determinism and code generation]
+                        $ minusUniqSet (nodeCoalesce node) visited
+
+                out     =  vcat dconflicts
+                        $$ vcat dcoalesces
+
+          in    ( addOneToUniqSet visited (nodeId node)
+                , Just out)
+
+        where   dotEdgeConflict u1 u2
+                        = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)
+                        <> text ";"
+
+                dotEdgeCoalesce u1 u2
+                        = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)
+                        <> space <> text "[ style = dashed ];"
diff --git a/compiler/utils/ListT.hs b/compiler/utils/ListT.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/ListT.hs
@@ -0,0 +1,80 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+-------------------------------------------------------------------------
+-- |
+-- Module      : Control.Monad.Logic
+-- Copyright   : (c) Dan Doel
+-- License     : BSD3
+--
+-- Maintainer  : dan.doel@gmail.com
+-- Stability   : experimental
+-- Portability : non-portable (multi-parameter type classes)
+--
+-- A backtracking, logic programming monad.
+--
+--    Adapted from the paper
+--    /Backtracking, Interleaving, and Terminating
+--        Monad Transformers/, by
+--    Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, Amr Sabry
+--    (<http://www.cs.rutgers.edu/~ccshan/logicprog/ListT-icfp2005.pdf>).
+-------------------------------------------------------------------------
+
+module ListT (
+    ListT(..),
+    runListT,
+    select,
+    fold
+  ) where
+
+import GhcPrelude
+
+import Control.Applicative
+
+import Control.Monad
+import Control.Monad.Fail as MonadFail
+
+-------------------------------------------------------------------------
+-- | A monad transformer for performing backtracking computations
+-- layered over another monad 'm'
+newtype ListT m a =
+    ListT { unListT :: forall r. (a -> m r -> m r) -> m r -> m r }
+
+select :: Monad m => [a] -> ListT m a
+select xs = foldr (<|>) mzero (map pure xs)
+
+fold :: ListT m a -> (a -> m r -> m r) -> m r -> m r
+fold = runListT
+
+-------------------------------------------------------------------------
+-- | Runs a ListT computation with the specified initial success and
+-- failure continuations.
+runListT :: ListT m a -> (a -> m r -> m r) -> m r -> m r
+runListT = unListT
+
+instance Functor (ListT f) where
+    fmap f lt = ListT $ \sk fk -> unListT lt (sk . f) fk
+
+instance Applicative (ListT f) where
+    pure a = ListT $ \sk fk -> sk a fk
+    f <*> a = ListT $ \sk fk -> unListT f (\g fk' -> unListT a (sk . g) fk') fk
+
+instance Alternative (ListT f) where
+    empty = ListT $ \_ fk -> fk
+    f1 <|> f2 = ListT $ \sk fk -> unListT f1 sk (unListT f2 sk fk)
+
+instance Monad (ListT m) where
+    m >>= f = ListT $ \sk fk -> unListT m (\a fk' -> unListT (f a) sk fk') fk
+#if !MIN_VERSION_base(4,13,0)
+    fail = MonadFail.fail
+#endif
+
+instance MonadFail.MonadFail (ListT m) where
+    fail _ = ListT $ \_ fk -> fk
+
+instance MonadPlus (ListT m) where
+    mzero = ListT $ \_ fk -> fk
+    m1 `mplus` m2 = ListT $ \sk fk -> unListT m1 sk (unListT m2 sk fk)
diff --git a/compiler/utils/State.hs b/compiler/utils/State.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/State.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE UnboxedTuples #-}
+
+module State where
+
+import GhcPrelude
+
+newtype State s a = State { runState' :: s -> (# a, s #) }
+
+instance Functor (State s) where
+    fmap f m  = State $ \s -> case runState' m s of
+                              (# r, s' #) -> (# f r, s' #)
+
+instance Applicative (State s) where
+   pure x   = State $ \s -> (# x, s #)
+   m <*> n  = State $ \s -> case runState' m s of
+                            (# f, s' #) -> case runState' n s' of
+                                           (# x, s'' #) -> (# f x, s'' #)
+
+instance Monad (State s) where
+    m >>= n  = State $ \s -> case runState' m s of
+                             (# r, s' #) -> runState' (n r) s'
+
+get :: State s s
+get = State $ \s -> (# s, s #)
+
+gets :: (s -> a) -> State s a
+gets f = State $ \s -> (# f s, s #)
+
+put :: s -> State s ()
+put s' = State $ \_ -> (# (), s' #)
+
+modify :: (s -> s) -> State s ()
+modify f = State $ \s -> (# (), f s #)
+
+
+evalState :: State s a -> s -> a
+evalState s i = case runState' s i of
+                (# a, _ #) -> a
+
+
+execState :: State s a -> s -> s
+execState s i = case runState' s i of
+                (# _, s' #) -> s'
+
+
+runState :: State s a -> s -> (a, s)
+runState s i = case runState' s i of
+               (# a, s' #) -> (a, s')
diff --git a/compiler/utils/Stream.hs b/compiler/utils/Stream.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/Stream.hs
@@ -0,0 +1,106 @@
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2012
+--
+-- Monadic streams
+--
+-- -----------------------------------------------------------------------------
+module Stream (
+    Stream(..), yield, liftIO,
+    collect, fromList,
+    Stream.map, Stream.mapM, Stream.mapAccumL
+  ) where
+
+import GhcPrelude
+
+import Control.Monad
+
+-- |
+-- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence
+-- of elements of type @a@ followed by a result of type @b@.
+--
+-- More concretely, a value of type @Stream m a b@ can be run using @runStream@
+-- in the Monad @m@, and it delivers either
+--
+--  * the final result: @Left b@, or
+--  * @Right (a,str)@, where @a@ is the next element in the stream, and @str@
+--    is a computation to get the rest of the stream.
+--
+-- Stream is itself a Monad, and provides an operation 'yield' that
+-- produces a new element of the stream.  This makes it convenient to turn
+-- existing monadic computations into streams.
+--
+-- The idea is that Stream is useful for making a monadic computation
+-- that produces values from time to time.  This can be used for
+-- knitting together two complex monadic operations, so that the
+-- producer does not have to produce all its values before the
+-- consumer starts consuming them.  We make the producer into a
+-- Stream, and the consumer pulls on the stream each time it wants a
+-- new value.
+--
+newtype Stream m a b = Stream { runStream :: m (Either b (a, Stream m a b)) }
+
+instance Monad f => Functor (Stream f a) where
+  fmap = liftM
+
+instance Monad m => Applicative (Stream m a) where
+  pure a = Stream (return (Left a))
+  (<*>) = ap
+
+instance Monad m => Monad (Stream m a) where
+
+  Stream m >>= k = Stream $ do
+                r <- m
+                case r of
+                  Left b        -> runStream (k b)
+                  Right (a,str) -> return (Right (a, str >>= k))
+
+yield :: Monad m => a -> Stream m a ()
+yield a = Stream (return (Right (a, return ())))
+
+liftIO :: IO a -> Stream IO b a
+liftIO io = Stream $ io >>= return . Left
+
+-- | Turn a Stream into an ordinary list, by demanding all the elements.
+collect :: Monad m => Stream m a () -> m [a]
+collect str = go str []
+ where
+  go str acc = do
+    r <- runStream str
+    case r of
+      Left () -> return (reverse acc)
+      Right (a, str') -> go str' (a:acc)
+
+-- | Turn a list into a 'Stream', by yielding each element in turn.
+fromList :: Monad m => [a] -> Stream m a ()
+fromList = mapM_ yield
+
+-- | Apply a function to each element of a 'Stream', lazily
+map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x
+map f str = Stream $ do
+   r <- runStream str
+   case r of
+     Left x -> return (Left x)
+     Right (a, str') -> return (Right (f a, Stream.map f str'))
+
+-- | Apply a monadic operation to each element of a 'Stream', lazily
+mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x
+mapM f str = Stream $ do
+   r <- runStream str
+   case r of
+     Left x -> return (Left x)
+     Right (a, str') -> do
+        b <- f a
+        return (Right (b, Stream.mapM f str'))
+
+-- | analog of the list-based 'mapAccumL' on Streams.  This is a simple
+-- way to map over a Stream while carrying some state around.
+mapAccumL :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a ()
+          -> Stream m b c
+mapAccumL f c str = Stream $ do
+  r <- runStream str
+  case r of
+    Left  () -> return (Left c)
+    Right (a, str') -> do
+      (c',b) <- f c a
+      return (Right (b, mapAccumL f c' str'))
diff --git a/compiler/utils/UnVarGraph.hs b/compiler/utils/UnVarGraph.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/UnVarGraph.hs
@@ -0,0 +1,145 @@
+{-
+
+Copyright (c) 2014 Joachim Breitner
+
+A data structure for undirected graphs of variables
+(or in plain terms: Sets of unordered pairs of numbers)
+
+
+This is very specifically tailored for the use in CallArity. In particular it
+stores the graph as a union of complete and complete bipartite graph, which
+would be very expensive to store as sets of edges or as adjanceny lists.
+
+It does not normalize the graphs. This means that g `unionUnVarGraph` g is
+equal to g, but twice as expensive and large.
+
+-}
+module UnVarGraph
+    ( UnVarSet
+    , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets
+    , delUnVarSet
+    , elemUnVarSet, isEmptyUnVarSet
+    , UnVarGraph
+    , emptyUnVarGraph
+    , unionUnVarGraph, unionUnVarGraphs
+    , completeGraph, completeBipartiteGraph
+    , neighbors
+    , hasLoopAt
+    , delNode
+    ) where
+
+import GhcPrelude
+
+import Id
+import VarEnv
+import UniqFM
+import Outputable
+import Bag
+import Unique
+
+import qualified Data.IntSet as S
+
+-- We need a type for sets of variables (UnVarSet).
+-- We do not use VarSet, because for that we need to have the actual variable
+-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.
+-- Therefore, use a IntSet directly (which is likely also a bit more efficient).
+
+-- Set of uniques, i.e. for adjancet nodes
+newtype UnVarSet = UnVarSet (S.IntSet)
+    deriving Eq
+
+k :: Var -> Int
+k v = getKey (getUnique v)
+
+emptyUnVarSet :: UnVarSet
+emptyUnVarSet = UnVarSet S.empty
+
+elemUnVarSet :: Var -> UnVarSet -> Bool
+elemUnVarSet v (UnVarSet s) = k v `S.member` s
+
+
+isEmptyUnVarSet :: UnVarSet -> Bool
+isEmptyUnVarSet (UnVarSet s) = S.null s
+
+delUnVarSet :: UnVarSet -> Var -> UnVarSet
+delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s
+
+mkUnVarSet :: [Var] -> UnVarSet
+mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs
+
+varEnvDom :: VarEnv a -> UnVarSet
+varEnvDom ae = UnVarSet $ ufmToSet_Directly ae
+
+unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
+unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)
+
+unionUnVarSets :: [UnVarSet] -> UnVarSet
+unionUnVarSets = foldr unionUnVarSet emptyUnVarSet
+
+instance Outputable UnVarSet where
+    ppr (UnVarSet s) = braces $
+        hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]
+
+
+-- The graph type. A list of complete bipartite graphs
+data Gen = CBPG UnVarSet UnVarSet -- complete bipartite
+         | CG   UnVarSet          -- complete
+newtype UnVarGraph = UnVarGraph (Bag Gen)
+
+emptyUnVarGraph :: UnVarGraph
+emptyUnVarGraph = UnVarGraph emptyBag
+
+unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph
+{-
+Premature optimisation, it seems.
+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
+    | s1 == s3 && s2 == s4
+    = pprTrace "unionUnVarGraph fired" empty $
+      completeGraph (s1 `unionUnVarSet` s2)
+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
+    | s2 == s3 && s1 == s4
+    = pprTrace "unionUnVarGraph fired2" empty $
+      completeGraph (s1 `unionUnVarSet` s2)
+-}
+unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2)
+    = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $
+      UnVarGraph (g1 `unionBags` g2)
+
+unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph
+unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph
+
+-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }
+completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph
+completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2
+
+completeGraph :: UnVarSet -> UnVarGraph
+completeGraph s = prune $ UnVarGraph $ unitBag $ CG s
+
+neighbors :: UnVarGraph -> Var -> UnVarSet
+neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g
+  where go (CG s)       = (if v `elemUnVarSet` s then [s] else [])
+        go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++
+                          (if v `elemUnVarSet` s2 then [s1] else [])
+
+-- hasLoopAt G v <=> v--v ∈ G
+hasLoopAt :: UnVarGraph -> Var -> Bool
+hasLoopAt (UnVarGraph g) v = any go $ bagToList g
+  where go (CG s)       = v `elemUnVarSet` s
+        go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2
+
+
+delNode :: UnVarGraph -> Var -> UnVarGraph
+delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g
+  where go (CG s)       = CG (s `delUnVarSet` v)
+        go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v)
+
+prune :: UnVarGraph -> UnVarGraph
+prune (UnVarGraph g) = UnVarGraph $ filterBag go g
+  where go (CG s)       = not (isEmptyUnVarSet s)
+        go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2)
+
+instance Outputable Gen where
+    ppr (CG s)       = ppr s  <> char '²'
+    ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2
+instance Outputable UnVarGraph where
+    ppr (UnVarGraph g) = ppr g
diff --git a/compiler/utils/UniqMap.hs b/compiler/utils/UniqMap.hs
new file mode 100644
--- /dev/null
+++ b/compiler/utils/UniqMap.hs
@@ -0,0 +1,206 @@
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# OPTIONS_GHC -Wall #-}
+
+-- Like 'UniqFM', these are maps for keys which are Uniquable.
+-- Unlike 'UniqFM', these maps also remember their keys, which
+-- makes them a much better drop in replacement for 'Data.Map.Map'.
+--
+-- Key preservation is right-biased.
+module UniqMap (
+    UniqMap,
+    emptyUniqMap,
+    isNullUniqMap,
+    unitUniqMap,
+    listToUniqMap,
+    listToUniqMap_C,
+    addToUniqMap,
+    addListToUniqMap,
+    addToUniqMap_C,
+    addToUniqMap_Acc,
+    alterUniqMap,
+    addListToUniqMap_C,
+    adjustUniqMap,
+    delFromUniqMap,
+    delListFromUniqMap,
+    plusUniqMap,
+    plusUniqMap_C,
+    plusMaybeUniqMap_C,
+    plusUniqMapList,
+    minusUniqMap,
+    intersectUniqMap,
+    disjointUniqMap,
+    mapUniqMap,
+    filterUniqMap,
+    partitionUniqMap,
+    sizeUniqMap,
+    elemUniqMap,
+    lookupUniqMap,
+    lookupWithDefaultUniqMap,
+    anyUniqMap,
+    allUniqMap,
+    -- Non-deterministic functions omitted
+) where
+
+import GhcPrelude
+
+import UniqFM
+
+import Unique
+import Outputable
+
+import Data.Semigroup as Semi ( Semigroup(..) )
+import Data.Coerce
+import Data.Maybe
+import Data.Data
+
+-- | Maps indexed by 'Uniquable' keys
+newtype UniqMap k a = UniqMap (UniqFM (k, a))
+    deriving (Data, Eq, Functor)
+type role UniqMap nominal representational
+
+instance Semigroup (UniqMap k a) where
+  (<>) = plusUniqMap
+
+instance Monoid (UniqMap k a) where
+    mempty = emptyUniqMap
+    mappend = (Semi.<>)
+
+instance (Outputable k, Outputable a) => Outputable (UniqMap k a) where
+    ppr (UniqMap m) =
+        brackets $ fsep $ punctuate comma $
+        [ ppr k <+> text "->" <+> ppr v
+        | (k, v) <- eltsUFM m ]
+
+liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a)
+liftC f (_, v) (k', v') = (k', f v v')
+
+emptyUniqMap :: UniqMap k a
+emptyUniqMap = UniqMap emptyUFM
+
+isNullUniqMap :: UniqMap k a -> Bool
+isNullUniqMap (UniqMap m) = isNullUFM m
+
+unitUniqMap :: Uniquable k => k -> a -> UniqMap k a
+unitUniqMap k v = UniqMap (unitUFM k (k, v))
+
+listToUniqMap :: Uniquable k => [(k,a)] -> UniqMap k a
+listToUniqMap kvs = UniqMap (listToUFM [ (k,(k,v)) | (k,v) <- kvs])
+
+listToUniqMap_C :: Uniquable k => (a -> a -> a) -> [(k,a)] -> UniqMap k a
+listToUniqMap_C f kvs = UniqMap $
+    listToUFM_C (liftC f) [ (k,(k,v)) | (k,v) <- kvs]
+
+addToUniqMap :: Uniquable k => UniqMap k a -> k -> a -> UniqMap k a
+addToUniqMap (UniqMap m) k v = UniqMap $ addToUFM m k (k, v)
+
+addListToUniqMap :: Uniquable k => UniqMap k a -> [(k,a)] -> UniqMap k a
+addListToUniqMap (UniqMap m) kvs = UniqMap $
+    addListToUFM m [(k,(k,v)) | (k,v) <- kvs]
+
+addToUniqMap_C :: Uniquable k
+               => (a -> a -> a)
+               -> UniqMap k a
+               -> k
+               -> a
+               -> UniqMap k a
+addToUniqMap_C f (UniqMap m) k v = UniqMap $
+    addToUFM_C (liftC f) m k (k, v)
+
+addToUniqMap_Acc :: Uniquable k
+                 => (b -> a -> a)
+                 -> (b -> a)
+                 -> UniqMap k a
+                 -> k
+                 -> b
+                 -> UniqMap k a
+addToUniqMap_Acc exi new (UniqMap m) k0 v0 = UniqMap $
+    addToUFM_Acc (\b (k, v) -> (k, exi b v))
+                 (\b -> (k0, new b))
+                 m k0 v0
+
+alterUniqMap :: Uniquable k
+             => (Maybe a -> Maybe a)
+             -> UniqMap k a
+             -> k
+             -> UniqMap k a
+alterUniqMap f (UniqMap m) k = UniqMap $
+    alterUFM (fmap (k,) . f . fmap snd) m k
+
+addListToUniqMap_C
+    :: Uniquable k
+    => (a -> a -> a)
+    -> UniqMap k a
+    -> [(k, a)]
+    -> UniqMap k a
+addListToUniqMap_C f (UniqMap m) kvs = UniqMap $
+    addListToUFM_C (liftC f) m
+        [(k,(k,v)) | (k,v) <- kvs]
+
+adjustUniqMap
+    :: Uniquable k
+    => (a -> a)
+    -> UniqMap k a
+    -> k
+    -> UniqMap k a
+adjustUniqMap f (UniqMap m) k = UniqMap $
+    adjustUFM (\(_,v) -> (k,f v)) m k
+
+delFromUniqMap :: Uniquable k => UniqMap k a -> k -> UniqMap k a
+delFromUniqMap (UniqMap m) k = UniqMap $ delFromUFM m k
+
+delListFromUniqMap :: Uniquable k => UniqMap k a -> [k] -> UniqMap k a
+delListFromUniqMap (UniqMap m) ks = UniqMap $ delListFromUFM m ks
+
+plusUniqMap :: UniqMap k a -> UniqMap k a -> UniqMap k a
+plusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ plusUFM m1 m2
+
+plusUniqMap_C :: (a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a
+plusUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $
+    plusUFM_C (liftC f) m1 m2
+
+plusMaybeUniqMap_C :: (a -> a -> Maybe a) -> UniqMap k a -> UniqMap k a -> UniqMap k a
+plusMaybeUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $
+    plusMaybeUFM_C (\(_, v) (k', v') -> fmap (k',) (f v v')) m1 m2
+
+plusUniqMapList :: [UniqMap k a] -> UniqMap k a
+plusUniqMapList xs = UniqMap $ plusUFMList (coerce xs)
+
+minusUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a
+minusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ minusUFM m1 m2
+
+intersectUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a
+intersectUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM m1 m2
+
+disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool
+disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2
+
+mapUniqMap :: (a -> b) -> UniqMap k a -> UniqMap k b
+mapUniqMap f (UniqMap m) = UniqMap $ mapUFM (fmap f) m -- (,) k instance
+
+filterUniqMap :: (a -> Bool) -> UniqMap k a -> UniqMap k a
+filterUniqMap f (UniqMap m) = UniqMap $ filterUFM (f . snd) m
+
+partitionUniqMap :: (a -> Bool) -> UniqMap k a -> (UniqMap k a, UniqMap k a)
+partitionUniqMap f (UniqMap m) =
+    coerce $ partitionUFM (f . snd) m
+
+sizeUniqMap :: UniqMap k a -> Int
+sizeUniqMap (UniqMap m) = sizeUFM m
+
+elemUniqMap :: Uniquable k => k -> UniqMap k a -> Bool
+elemUniqMap k (UniqMap m) = elemUFM k m
+
+lookupUniqMap :: Uniquable k => UniqMap k a -> k -> Maybe a
+lookupUniqMap (UniqMap m) k = fmap snd (lookupUFM m k)
+
+lookupWithDefaultUniqMap :: Uniquable k => UniqMap k a -> a -> k -> a
+lookupWithDefaultUniqMap (UniqMap m) a k = fromMaybe a (fmap snd (lookupUFM m k))
+
+anyUniqMap :: (a -> Bool) -> UniqMap k a -> Bool
+anyUniqMap f (UniqMap m) = anyUFM (f . snd) m
+
+allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool
+allUniqMap f (UniqMap m) = allUFM (f . snd) m
diff --git a/compiler/utils/md5.h b/compiler/utils/md5.h
new file mode 100644
--- /dev/null
+++ b/compiler/utils/md5.h
@@ -0,0 +1,18 @@
+/* MD5 message digest */
+#pragma once
+
+#include "HsFFI.h"
+
+typedef HsWord32 word32;
+typedef HsWord8  byte;
+
+struct MD5Context {
+        word32 buf[4];
+        word32 bytes[2];
+        word32 in[16];
+};
+
+void MD5Init(struct MD5Context *context);
+void MD5Update(struct MD5Context *context, byte const *buf, int len);
+void MD5Final(byte digest[16], struct MD5Context *context);
+void MD5Transform(word32 buf[4], word32 const in[16]);
diff --git a/ghc-lib.cabal b/ghc-lib.cabal
--- a/ghc-lib.cabal
+++ b/ghc-lib.cabal
@@ -1,905 +1,690 @@
-cabal-version: 2.0
-build-type: Simple
-name: ghc-lib
-version: 0.20221201
-license: BSD3
-license-file: LICENSE
-category: Development
-author: The GHC Team and Digital Asset
-maintainer: Digital Asset
-synopsis: The GHC API, decoupled from GHC versions
-description: A package equivalent to the @ghc@ package, but which can be loaded on many compiler versions.
-homepage: https://github.com/digital-asset/ghc-lib
-bug-reports: https://github.com/digital-asset/ghc-lib/issues
-data-dir: ghc-lib/stage0/lib
-data-files:
-    settings
-    llvm-targets
-    llvm-passes
-extra-source-files:
-    ghc-lib/stage0/rts/build/include/ghcautoconf.h
-    ghc-lib/stage0/rts/build/include/ghcplatform.h
-    ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h
-    ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl
-    ghc-lib/stage0/compiler/build/primop-code-size.hs-incl
-    ghc-lib/stage0/compiler/build/primop-commutable.hs-incl
-    ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl
-    ghc-lib/stage0/compiler/build/primop-fixity.hs-incl
-    ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl
-    ghc-lib/stage0/compiler/build/primop-list.hs-incl
-    ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl
-    ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl
-    ghc-lib/stage0/compiler/build/primop-strictness.hs-incl
-    ghc-lib/stage0/compiler/build/primop-tag.hs-incl
-    ghc-lib/stage0/compiler/build/primop-vector-tycons.hs-incl
-    ghc-lib/stage0/compiler/build/primop-vector-tys-exports.hs-incl
-    ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl
-    ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl
-    ghc-lib/stage0/compiler/build/primop-docs.hs-incl
-    ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs
-    rts/include/ghcconfig.h
-    compiler/MachRegs.h
-    compiler/CodeGen.Platform.h
-    compiler/Bytecodes.h
-    compiler/ClosureTypes.h
-    compiler/FunTypes.h
-    compiler/Unique.h
-    compiler/ghc-llvm-version.h
-source-repository head
-    type: git
-    location: git@github.com:digital-asset/ghc-lib.git
-
-library
-    default-language:   Haskell2010
-    exposed: False
-    include-dirs:
-        rts/include
-        ghc-lib/stage0/lib
-        ghc-lib/stage0/compiler/build
-        compiler
-    ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS
-    cc-options: -DTHREADED_RTS
-    cpp-options:  -DTHREADED_RTS
-    if !os(windows)
-        build-depends: unix
-    else
-        build-depends: Win32
-    build-depends:
-        base > 4.16 && < 4.18,
-        ghc-prim > 0.2 && < 0.10,
-        bytestring >= 0.10 && < 0.12,
-        time >= 1.4 && < 1.13,
-        exceptions == 0.10.*,
-        parsec,
-        containers >= 0.5 && < 0.7,
-        binary == 0.8.*,
-        filepath >= 1 && < 1.5,
-        directory >= 1 && < 1.4,
-        array >= 0.1 && < 0.6,
-        deepseq >= 1.4 && < 1.5,
-        pretty == 1.1.*,
-        transformers == 0.5.*,
-        process >= 1 && < 1.7,
-        stm,
-        rts,
-        hpc == 0.6.*,
-        ghc-lib-parser == 0.20221201
-    build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4
-    other-extensions:
-        BangPatterns
-        CPP
-        DataKinds
-        DefaultSignatures
-        DeriveDataTypeable
-        DeriveFoldable
-        DeriveFunctor
-        DeriveGeneric
-        DeriveTraversable
-        DisambiguateRecordFields
-        ExistentialQuantification
-        ExplicitForAll
-        FlexibleContexts
-        FlexibleInstances
-        GADTs
-        GeneralizedNewtypeDeriving
-        InstanceSigs
-        MagicHash
-        MultiParamTypeClasses
-        NamedFieldPuns
-        NondecreasingIndentation
-        RankNTypes
-        RecordWildCards
-        RoleAnnotations
-        ScopedTypeVariables
-        StandaloneDeriving
-        Trustworthy
-        TupleSections
-        TypeFamilies
-        TypeSynonymInstances
-        UnboxedTuples
-        UndecidableInstances
-    default-extensions:
-        BangPatterns
-        ImplicitPrelude
-        MonoLocalBinds
-        NoImplicitPrelude
-        ScopedTypeVariables
-        TypeOperators
-    hs-source-dirs:
-        ghc-lib/stage0/libraries/ghc-boot/build
-        ghc-lib/stage0/compiler/build
-        libraries/template-haskell
-        libraries/ghc-boot
-        libraries/ghci
-        compiler
-    autogen-modules:
-        Paths_ghc_lib
-    reexported-modules:
-        GHC.BaseDir,
-        GHC.Builtin.Names,
-        GHC.Builtin.PrimOps,
-        GHC.Builtin.PrimOps.Ids,
-        GHC.Builtin.Types,
-        GHC.Builtin.Types.Prim,
-        GHC.Builtin.Uniques,
-        GHC.ByteCode.Types,
-        GHC.Cmm,
-        GHC.Cmm.BlockId,
-        GHC.Cmm.CLabel,
-        GHC.Cmm.Dataflow.Block,
-        GHC.Cmm.Dataflow.Collections,
-        GHC.Cmm.Dataflow.Graph,
-        GHC.Cmm.Dataflow.Label,
-        GHC.Cmm.Expr,
-        GHC.Cmm.MachOp,
-        GHC.Cmm.Node,
-        GHC.Cmm.Reg,
-        GHC.Cmm.Switch,
-        GHC.Cmm.Type,
-        GHC.CmmToAsm.CFG.Weight,
-        GHC.CmmToLlvm.Config,
-        GHC.Core,
-        GHC.Core.Class,
-        GHC.Core.Coercion,
-        GHC.Core.Coercion.Axiom,
-        GHC.Core.Coercion.Opt,
-        GHC.Core.ConLike,
-        GHC.Core.DataCon,
-        GHC.Core.FVs,
-        GHC.Core.FamInstEnv,
-        GHC.Core.InstEnv,
-        GHC.Core.Lint,
-        GHC.Core.Lint.Interactive,
-        GHC.Core.Make,
-        GHC.Core.Map.Expr,
-        GHC.Core.Map.Type,
-        GHC.Core.Multiplicity,
-        GHC.Core.Opt.Arity,
-        GHC.Core.Opt.CallerCC,
-        GHC.Core.Opt.ConstantFold,
-        GHC.Core.Opt.Monad,
-        GHC.Core.Opt.OccurAnal,
-        GHC.Core.Opt.Pipeline.Types,
-        GHC.Core.Opt.Simplify,
-        GHC.Core.Opt.Simplify.Env,
-        GHC.Core.Opt.Simplify.Iteration,
-        GHC.Core.Opt.Simplify.Monad,
-        GHC.Core.Opt.Simplify.Utils,
-        GHC.Core.Opt.Stats,
-        GHC.Core.PatSyn,
-        GHC.Core.Ppr,
-        GHC.Core.Predicate,
-        GHC.Core.Reduction,
-        GHC.Core.RoughMap,
-        GHC.Core.Rules,
-        GHC.Core.Rules.Config,
-        GHC.Core.Seq,
-        GHC.Core.SimpleOpt,
-        GHC.Core.Stats,
-        GHC.Core.Subst,
-        GHC.Core.Tidy,
-        GHC.Core.TyCo.Compare,
-        GHC.Core.TyCo.FVs,
-        GHC.Core.TyCo.Ppr,
-        GHC.Core.TyCo.Rep,
-        GHC.Core.TyCo.Subst,
-        GHC.Core.TyCo.Tidy,
-        GHC.Core.TyCon,
-        GHC.Core.TyCon.Env,
-        GHC.Core.TyCon.RecWalk,
-        GHC.Core.Type,
-        GHC.Core.Unfold,
-        GHC.Core.Unfold.Make,
-        GHC.Core.Unify,
-        GHC.Core.UsageEnv,
-        GHC.Core.Utils,
-        GHC.CoreToIface,
-        GHC.Data.Bag,
-        GHC.Data.Bool,
-        GHC.Data.BooleanFormula,
-        GHC.Data.EnumSet,
-        GHC.Data.FastMutInt,
-        GHC.Data.FastString,
-        GHC.Data.FastString.Env,
-        GHC.Data.FiniteMap,
-        GHC.Data.Graph.Directed,
-        GHC.Data.Graph.UnVar,
-        GHC.Data.IOEnv,
-        GHC.Data.List.Infinite,
-        GHC.Data.List.SetOps,
-        GHC.Data.Maybe,
-        GHC.Data.OrdList,
-        GHC.Data.Pair,
-        GHC.Data.ShortText,
-        GHC.Data.SizedSeq,
-        GHC.Data.SmallArray,
-        GHC.Data.Stream,
-        GHC.Data.Strict,
-        GHC.Data.StringBuffer,
-        GHC.Data.TrieMap,
-        GHC.Data.Unboxed,
-        GHC.Driver.Backend,
-        GHC.Driver.Backend.Internal,
-        GHC.Driver.Backpack.Syntax,
-        GHC.Driver.CmdLine,
-        GHC.Driver.Config,
-        GHC.Driver.Config.Core.Lint,
-        GHC.Driver.Config.Diagnostic,
-        GHC.Driver.Config.Logger,
-        GHC.Driver.Config.Parser,
-        GHC.Driver.Env,
-        GHC.Driver.Env.KnotVars,
-        GHC.Driver.Env.Types,
-        GHC.Driver.Errors,
-        GHC.Driver.Errors.Ppr,
-        GHC.Driver.Errors.Types,
-        GHC.Driver.Flags,
-        GHC.Driver.Hooks,
-        GHC.Driver.LlvmConfigCache,
-        GHC.Driver.Monad,
-        GHC.Driver.Phases,
-        GHC.Driver.Pipeline.Monad,
-        GHC.Driver.Pipeline.Phases,
-        GHC.Driver.Plugins,
-        GHC.Driver.Plugins.External,
-        GHC.Driver.Ppr,
-        GHC.Driver.Session,
-        GHC.Exts.Heap,
-        GHC.Exts.Heap.ClosureTypes,
-        GHC.Exts.Heap.Closures,
-        GHC.Exts.Heap.Constants,
-        GHC.Exts.Heap.FFIClosures,
-        GHC.Exts.Heap.FFIClosures_ProfilingDisabled,
-        GHC.Exts.Heap.FFIClosures_ProfilingEnabled,
-        GHC.Exts.Heap.InfoTable,
-        GHC.Exts.Heap.InfoTable.Types,
-        GHC.Exts.Heap.InfoTableProf,
-        GHC.Exts.Heap.ProfInfo.PeekProfInfo,
-        GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled,
-        GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled,
-        GHC.Exts.Heap.ProfInfo.Types,
-        GHC.Exts.Heap.Utils,
-        GHC.ForeignSrcLang,
-        GHC.ForeignSrcLang.Type,
-        GHC.Hs,
-        GHC.Hs.Binds,
-        GHC.Hs.Decls,
-        GHC.Hs.Doc,
-        GHC.Hs.DocString,
-        GHC.Hs.Dump,
-        GHC.Hs.Expr,
-        GHC.Hs.Extension,
-        GHC.Hs.ImpExp,
-        GHC.Hs.Instances,
-        GHC.Hs.Lit,
-        GHC.Hs.Pat,
-        GHC.Hs.Type,
-        GHC.Hs.Utils,
-        GHC.HsToCore.Errors.Ppr,
-        GHC.HsToCore.Errors.Types,
-        GHC.HsToCore.Pmc.Ppr,
-        GHC.HsToCore.Pmc.Solver.Types,
-        GHC.HsToCore.Pmc.Types,
-        GHC.Iface.Ext.Fields,
-        GHC.Iface.Recomp.Binary,
-        GHC.Iface.Syntax,
-        GHC.Iface.Type,
-        GHC.LanguageExtensions,
-        GHC.LanguageExtensions.Type,
-        GHC.Lexeme,
-        GHC.Linker.Static.Utils,
-        GHC.Linker.Types,
-        GHC.Parser,
-        GHC.Parser.Annotation,
-        GHC.Parser.CharClass,
-        GHC.Parser.Errors.Basic,
-        GHC.Parser.Errors.Ppr,
-        GHC.Parser.Errors.Types,
-        GHC.Parser.HaddockLex,
-        GHC.Parser.Header,
-        GHC.Parser.Lexer,
-        GHC.Parser.PostProcess,
-        GHC.Parser.PostProcess.Haddock,
-        GHC.Parser.Types,
-        GHC.Platform,
-        GHC.Platform.AArch64,
-        GHC.Platform.ARM,
-        GHC.Platform.ArchOS,
-        GHC.Platform.Constants,
-        GHC.Platform.NoRegs,
-        GHC.Platform.PPC,
-        GHC.Platform.Profile,
-        GHC.Platform.RISCV64,
-        GHC.Platform.Reg,
-        GHC.Platform.Reg.Class,
-        GHC.Platform.Regs,
-        GHC.Platform.S390X,
-        GHC.Platform.Wasm32,
-        GHC.Platform.Ways,
-        GHC.Platform.X86,
-        GHC.Platform.X86_64,
-        GHC.Prelude,
-        GHC.Prelude.Basic,
-        GHC.Runtime.Context,
-        GHC.Runtime.Eval.Types,
-        GHC.Runtime.Heap.Layout,
-        GHC.Runtime.Interpreter,
-        GHC.Runtime.Interpreter.Types,
-        GHC.Serialized,
-        GHC.Settings,
-        GHC.Settings.Config,
-        GHC.Settings.Constants,
-        GHC.Settings.Utils,
-        GHC.Stg.InferTags.TagSig,
-        GHC.Stg.Syntax,
-        GHC.StgToCmm.Config,
-        GHC.StgToCmm.Types,
-        GHC.SysTools.BaseDir,
-        GHC.SysTools.Terminal,
-        GHC.Tc.Errors.Hole.FitTypes,
-        GHC.Tc.Errors.Ppr,
-        GHC.Tc.Errors.Types,
-        GHC.Tc.Solver.InertSet,
-        GHC.Tc.Solver.Types,
-        GHC.Tc.Types,
-        GHC.Tc.Types.Constraint,
-        GHC.Tc.Types.Evidence,
-        GHC.Tc.Types.Origin,
-        GHC.Tc.Types.Rank,
-        GHC.Tc.Utils.TcType,
-        GHC.Types.Annotations,
-        GHC.Types.Avail,
-        GHC.Types.Basic,
-        GHC.Types.BreakInfo,
-        GHC.Types.CompleteMatch,
-        GHC.Types.CostCentre,
-        GHC.Types.CostCentre.State,
-        GHC.Types.Cpr,
-        GHC.Types.Demand,
-        GHC.Types.Error,
-        GHC.Types.Error.Codes,
-        GHC.Types.FieldLabel,
-        GHC.Types.Fixity,
-        GHC.Types.Fixity.Env,
-        GHC.Types.ForeignCall,
-        GHC.Types.ForeignStubs,
-        GHC.Types.Hint,
-        GHC.Types.Hint.Ppr,
-        GHC.Types.HpcInfo,
-        GHC.Types.IPE,
-        GHC.Types.Id,
-        GHC.Types.Id.Info,
-        GHC.Types.Id.Make,
-        GHC.Types.Literal,
-        GHC.Types.Meta,
-        GHC.Types.Name,
-        GHC.Types.Name.Cache,
-        GHC.Types.Name.Env,
-        GHC.Types.Name.Occurrence,
-        GHC.Types.Name.Ppr,
-        GHC.Types.Name.Reader,
-        GHC.Types.Name.Set,
-        GHC.Types.PkgQual,
-        GHC.Types.ProfAuto,
-        GHC.Types.RepType,
-        GHC.Types.SafeHaskell,
-        GHC.Types.SourceError,
-        GHC.Types.SourceFile,
-        GHC.Types.SourceText,
-        GHC.Types.SrcLoc,
-        GHC.Types.Target,
-        GHC.Types.Tickish,
-        GHC.Types.TyThing,
-        GHC.Types.TypeEnv,
-        GHC.Types.Unique,
-        GHC.Types.Unique.DFM,
-        GHC.Types.Unique.DSet,
-        GHC.Types.Unique.FM,
-        GHC.Types.Unique.Map,
-        GHC.Types.Unique.SDFM,
-        GHC.Types.Unique.Set,
-        GHC.Types.Unique.Supply,
-        GHC.Types.Var,
-        GHC.Types.Var.Env,
-        GHC.Types.Var.Set,
-        GHC.UniqueSubdir,
-        GHC.Unit,
-        GHC.Unit.Database,
-        GHC.Unit.Env,
-        GHC.Unit.External,
-        GHC.Unit.Finder.Types,
-        GHC.Unit.Home,
-        GHC.Unit.Home.ModInfo,
-        GHC.Unit.Info,
-        GHC.Unit.Module,
-        GHC.Unit.Module.Deps,
-        GHC.Unit.Module.Env,
-        GHC.Unit.Module.Graph,
-        GHC.Unit.Module.Imported,
-        GHC.Unit.Module.Location,
-        GHC.Unit.Module.ModDetails,
-        GHC.Unit.Module.ModGuts,
-        GHC.Unit.Module.ModIface,
-        GHC.Unit.Module.ModSummary,
-        GHC.Unit.Module.Status,
-        GHC.Unit.Module.Warnings,
-        GHC.Unit.Module.WholeCoreBindings,
-        GHC.Unit.Parser,
-        GHC.Unit.Ppr,
-        GHC.Unit.State,
-        GHC.Unit.Types,
-        GHC.Utils.Binary,
-        GHC.Utils.Binary.Typeable,
-        GHC.Utils.BufHandle,
-        GHC.Utils.CliOption,
-        GHC.Utils.Constants,
-        GHC.Utils.Encoding,
-        GHC.Utils.Encoding.UTF8,
-        GHC.Utils.Error,
-        GHC.Utils.Exception,
-        GHC.Utils.FV,
-        GHC.Utils.Fingerprint,
-        GHC.Utils.GlobalVars,
-        GHC.Utils.IO.Unsafe,
-        GHC.Utils.Json,
-        GHC.Utils.Lexeme,
-        GHC.Utils.Logger,
-        GHC.Utils.Misc,
-        GHC.Utils.Monad,
-        GHC.Utils.Monad.State.Strict,
-        GHC.Utils.Outputable,
-        GHC.Utils.Panic,
-        GHC.Utils.Panic.Plain,
-        GHC.Utils.Ppr,
-        GHC.Utils.Ppr.Colour,
-        GHC.Utils.TmpFs,
-        GHC.Utils.Trace,
-        GHC.Version,
-        GHCi.BinaryArray,
-        GHCi.BreakArray,
-        GHCi.FFI,
-        GHCi.Message,
-        GHCi.RemoteTypes,
-        GHCi.ResolvedBCO,
-        GHCi.TH.Binary,
-        Language.Haskell.Syntax,
-        Language.Haskell.Syntax.Basic,
-        Language.Haskell.Syntax.Binds,
-        Language.Haskell.Syntax.Concrete,
-        Language.Haskell.Syntax.Decls,
-        Language.Haskell.Syntax.Expr,
-        Language.Haskell.Syntax.Extension,
-        Language.Haskell.Syntax.ImpExp,
-        Language.Haskell.Syntax.Lit,
-        Language.Haskell.Syntax.Module.Name,
-        Language.Haskell.Syntax.Pat,
-        Language.Haskell.Syntax.Type,
-        Language.Haskell.TH,
-        Language.Haskell.TH.LanguageExtensions,
-        Language.Haskell.TH.Lib,
-        Language.Haskell.TH.Lib.Internal,
-        Language.Haskell.TH.Lib.Map,
-        Language.Haskell.TH.Ppr,
-        Language.Haskell.TH.PprLib,
-        Language.Haskell.TH.Syntax
-    exposed-modules:
-        Paths_ghc_lib
-        GHC
-        GHC.Builtin.Names.TH
-        GHC.Builtin.PrimOps.Casts
-        GHC.Builtin.Types.Literals
-        GHC.Builtin.Utils
-        GHC.ByteCode.Asm
-        GHC.ByteCode.InfoTable
-        GHC.ByteCode.Instr
-        GHC.ByteCode.Linker
-        GHC.Cmm.CallConv
-        GHC.Cmm.CommonBlockElim
-        GHC.Cmm.Config
-        GHC.Cmm.ContFlowOpt
-        GHC.Cmm.Dataflow
-        GHC.Cmm.DebugBlock
-        GHC.Cmm.Dominators
-        GHC.Cmm.Graph
-        GHC.Cmm.Info
-        GHC.Cmm.Info.Build
-        GHC.Cmm.InitFini
-        GHC.Cmm.LRegSet
-        GHC.Cmm.LayoutStack
-        GHC.Cmm.Lexer
-        GHC.Cmm.Lint
-        GHC.Cmm.Liveness
-        GHC.Cmm.Opt
-        GHC.Cmm.Parser
-        GHC.Cmm.Parser.Config
-        GHC.Cmm.Parser.Monad
-        GHC.Cmm.Pipeline
-        GHC.Cmm.ProcPoint
-        GHC.Cmm.Reducibility
-        GHC.Cmm.Sink
-        GHC.Cmm.Switch.Implement
-        GHC.Cmm.Utils
-        GHC.CmmToAsm
-        GHC.CmmToAsm.AArch64
-        GHC.CmmToAsm.AArch64.CodeGen
-        GHC.CmmToAsm.AArch64.Cond
-        GHC.CmmToAsm.AArch64.Instr
-        GHC.CmmToAsm.AArch64.Ppr
-        GHC.CmmToAsm.AArch64.RegInfo
-        GHC.CmmToAsm.AArch64.Regs
-        GHC.CmmToAsm.BlockLayout
-        GHC.CmmToAsm.CFG
-        GHC.CmmToAsm.CFG.Dominators
-        GHC.CmmToAsm.CPrim
-        GHC.CmmToAsm.Config
-        GHC.CmmToAsm.Dwarf
-        GHC.CmmToAsm.Dwarf.Constants
-        GHC.CmmToAsm.Dwarf.Types
-        GHC.CmmToAsm.Format
-        GHC.CmmToAsm.Instr
-        GHC.CmmToAsm.Monad
-        GHC.CmmToAsm.PIC
-        GHC.CmmToAsm.PPC
-        GHC.CmmToAsm.PPC.CodeGen
-        GHC.CmmToAsm.PPC.Cond
-        GHC.CmmToAsm.PPC.Instr
-        GHC.CmmToAsm.PPC.Ppr
-        GHC.CmmToAsm.PPC.RegInfo
-        GHC.CmmToAsm.PPC.Regs
-        GHC.CmmToAsm.Ppr
-        GHC.CmmToAsm.Reg.Graph
-        GHC.CmmToAsm.Reg.Graph.Base
-        GHC.CmmToAsm.Reg.Graph.Coalesce
-        GHC.CmmToAsm.Reg.Graph.Spill
-        GHC.CmmToAsm.Reg.Graph.SpillClean
-        GHC.CmmToAsm.Reg.Graph.SpillCost
-        GHC.CmmToAsm.Reg.Graph.Stats
-        GHC.CmmToAsm.Reg.Graph.TrivColorable
-        GHC.CmmToAsm.Reg.Graph.X86
-        GHC.CmmToAsm.Reg.Linear
-        GHC.CmmToAsm.Reg.Linear.AArch64
-        GHC.CmmToAsm.Reg.Linear.Base
-        GHC.CmmToAsm.Reg.Linear.FreeRegs
-        GHC.CmmToAsm.Reg.Linear.JoinToTargets
-        GHC.CmmToAsm.Reg.Linear.PPC
-        GHC.CmmToAsm.Reg.Linear.StackMap
-        GHC.CmmToAsm.Reg.Linear.State
-        GHC.CmmToAsm.Reg.Linear.Stats
-        GHC.CmmToAsm.Reg.Linear.X86
-        GHC.CmmToAsm.Reg.Linear.X86_64
-        GHC.CmmToAsm.Reg.Liveness
-        GHC.CmmToAsm.Reg.Target
-        GHC.CmmToAsm.Reg.Utils
-        GHC.CmmToAsm.Types
-        GHC.CmmToAsm.Utils
-        GHC.CmmToAsm.Wasm
-        GHC.CmmToAsm.Wasm.Asm
-        GHC.CmmToAsm.Wasm.FromCmm
-        GHC.CmmToAsm.Wasm.Types
-        GHC.CmmToAsm.Wasm.Utils
-        GHC.CmmToAsm.X86
-        GHC.CmmToAsm.X86.CodeGen
-        GHC.CmmToAsm.X86.Cond
-        GHC.CmmToAsm.X86.Instr
-        GHC.CmmToAsm.X86.Ppr
-        GHC.CmmToAsm.X86.RegInfo
-        GHC.CmmToAsm.X86.Regs
-        GHC.CmmToC
-        GHC.CmmToLlvm
-        GHC.CmmToLlvm.Base
-        GHC.CmmToLlvm.CodeGen
-        GHC.CmmToLlvm.Data
-        GHC.CmmToLlvm.Mangler
-        GHC.CmmToLlvm.Ppr
-        GHC.CmmToLlvm.Regs
-        GHC.Core.LateCC
-        GHC.Core.Opt.CSE
-        GHC.Core.Opt.CallArity
-        GHC.Core.Opt.CprAnal
-        GHC.Core.Opt.DmdAnal
-        GHC.Core.Opt.Exitify
-        GHC.Core.Opt.FloatIn
-        GHC.Core.Opt.FloatOut
-        GHC.Core.Opt.LiberateCase
-        GHC.Core.Opt.Pipeline
-        GHC.Core.Opt.SetLevels
-        GHC.Core.Opt.SpecConstr
-        GHC.Core.Opt.Specialise
-        GHC.Core.Opt.StaticArgs
-        GHC.Core.Opt.WorkWrap
-        GHC.Core.Opt.WorkWrap.Utils
-        GHC.Core.TyCon.Set
-        GHC.CoreToStg
-        GHC.CoreToStg.Prep
-        GHC.Data.Bitmap
-        GHC.Data.Graph.Base
-        GHC.Data.Graph.Collapse
-        GHC.Data.Graph.Color
-        GHC.Data.Graph.Inductive.Graph
-        GHC.Data.Graph.Inductive.PatriciaTree
-        GHC.Data.Graph.Ops
-        GHC.Data.Graph.Ppr
-        GHC.Data.UnionFind
-        GHC.Driver.Backpack
-        GHC.Driver.CodeOutput
-        GHC.Driver.Config.Cmm
-        GHC.Driver.Config.Cmm.Parser
-        GHC.Driver.Config.CmmToAsm
-        GHC.Driver.Config.CmmToLlvm
-        GHC.Driver.Config.Core.Lint.Interactive
-        GHC.Driver.Config.Core.Opt.Arity
-        GHC.Driver.Config.Core.Opt.LiberateCase
-        GHC.Driver.Config.Core.Opt.Simplify
-        GHC.Driver.Config.Core.Opt.WorkWrap
-        GHC.Driver.Config.Core.Rules
-        GHC.Driver.Config.CoreToStg
-        GHC.Driver.Config.CoreToStg.Prep
-        GHC.Driver.Config.Finder
-        GHC.Driver.Config.HsToCore
-        GHC.Driver.Config.HsToCore.Ticks
-        GHC.Driver.Config.HsToCore.Usage
-        GHC.Driver.Config.Stg.Debug
-        GHC.Driver.Config.Stg.Lift
-        GHC.Driver.Config.Stg.Pipeline
-        GHC.Driver.Config.Stg.Ppr
-        GHC.Driver.Config.StgToCmm
-        GHC.Driver.Config.StgToJS
-        GHC.Driver.Config.Tidy
-        GHC.Driver.GenerateCgIPEStub
-        GHC.Driver.Main
-        GHC.Driver.Make
-        GHC.Driver.MakeFile
-        GHC.Driver.Pipeline
-        GHC.Driver.Pipeline.Execute
-        GHC.Driver.Pipeline.LogQueue
-        GHC.HandleEncoding
-        GHC.Hs.Stats
-        GHC.Hs.Syn.Type
-        GHC.HsToCore
-        GHC.HsToCore.Arrows
-        GHC.HsToCore.Binds
-        GHC.HsToCore.Breakpoints
-        GHC.HsToCore.Coverage
-        GHC.HsToCore.Docs
-        GHC.HsToCore.Expr
-        GHC.HsToCore.Foreign.C
-        GHC.HsToCore.Foreign.Call
-        GHC.HsToCore.Foreign.Decl
-        GHC.HsToCore.Foreign.JavaScript
-        GHC.HsToCore.Foreign.Prim
-        GHC.HsToCore.Foreign.Utils
-        GHC.HsToCore.GuardedRHSs
-        GHC.HsToCore.ListComp
-        GHC.HsToCore.Match
-        GHC.HsToCore.Match.Constructor
-        GHC.HsToCore.Match.Literal
-        GHC.HsToCore.Monad
-        GHC.HsToCore.Pmc
-        GHC.HsToCore.Pmc.Check
-        GHC.HsToCore.Pmc.Desugar
-        GHC.HsToCore.Pmc.Solver
-        GHC.HsToCore.Pmc.Utils
-        GHC.HsToCore.Quote
-        GHC.HsToCore.Ticks
-        GHC.HsToCore.Types
-        GHC.HsToCore.Usage
-        GHC.HsToCore.Utils
-        GHC.Iface.Binary
-        GHC.Iface.Env
-        GHC.Iface.Errors
-        GHC.Iface.Ext.Ast
-        GHC.Iface.Ext.Binary
-        GHC.Iface.Ext.Debug
-        GHC.Iface.Ext.Types
-        GHC.Iface.Ext.Utils
-        GHC.Iface.Load
-        GHC.Iface.Make
-        GHC.Iface.Recomp
-        GHC.Iface.Recomp.Flags
-        GHC.Iface.Rename
-        GHC.Iface.Tidy
-        GHC.Iface.Tidy.StaticPtrTable
-        GHC.IfaceToCore
-        GHC.JS.Make
-        GHC.JS.Ppr
-        GHC.JS.Syntax
-        GHC.JS.Transform
-        GHC.Linker
-        GHC.Linker.Dynamic
-        GHC.Linker.ExtraObj
-        GHC.Linker.Loader
-        GHC.Linker.MacOS
-        GHC.Linker.Static
-        GHC.Linker.Unit
-        GHC.Linker.Windows
-        GHC.Llvm
-        GHC.Llvm.MetaData
-        GHC.Llvm.Ppr
-        GHC.Llvm.Syntax
-        GHC.Llvm.Types
-        GHC.Parser.Utils
-        GHC.Platform.Host
-        GHC.Plugins
-        GHC.Rename.Bind
-        GHC.Rename.Doc
-        GHC.Rename.Env
-        GHC.Rename.Expr
-        GHC.Rename.Fixity
-        GHC.Rename.HsType
-        GHC.Rename.Module
-        GHC.Rename.Names
-        GHC.Rename.Pat
-        GHC.Rename.Splice
-        GHC.Rename.Unbound
-        GHC.Rename.Utils
-        GHC.Runtime.Debugger
-        GHC.Runtime.Eval
-        GHC.Runtime.Heap.Inspect
-        GHC.Runtime.Loader
-        GHC.Settings.IO
-        GHC.Stg.BcPrep
-        GHC.Stg.CSE
-        GHC.Stg.Debug
-        GHC.Stg.FVs
-        GHC.Stg.InferTags
-        GHC.Stg.InferTags.Rewrite
-        GHC.Stg.InferTags.Types
-        GHC.Stg.Lift
-        GHC.Stg.Lift.Analysis
-        GHC.Stg.Lift.Config
-        GHC.Stg.Lift.Monad
-        GHC.Stg.Lint
-        GHC.Stg.Pipeline
-        GHC.Stg.Stats
-        GHC.Stg.Subst
-        GHC.Stg.Unarise
-        GHC.Stg.Utils
-        GHC.StgToByteCode
-        GHC.StgToCmm
-        GHC.StgToCmm.ArgRep
-        GHC.StgToCmm.Bind
-        GHC.StgToCmm.CgUtils
-        GHC.StgToCmm.Closure
-        GHC.StgToCmm.DataCon
-        GHC.StgToCmm.Env
-        GHC.StgToCmm.Expr
-        GHC.StgToCmm.ExtCode
-        GHC.StgToCmm.Foreign
-        GHC.StgToCmm.Heap
-        GHC.StgToCmm.Hpc
-        GHC.StgToCmm.InfoTableProv
-        GHC.StgToCmm.Layout
-        GHC.StgToCmm.Lit
-        GHC.StgToCmm.Monad
-        GHC.StgToCmm.Prim
-        GHC.StgToCmm.Prof
-        GHC.StgToCmm.Sequel
-        GHC.StgToCmm.TagCheck
-        GHC.StgToCmm.Ticky
-        GHC.StgToCmm.Utils
-        GHC.StgToJS
-        GHC.StgToJS.Apply
-        GHC.StgToJS.Arg
-        GHC.StgToJS.Closure
-        GHC.StgToJS.CodeGen
-        GHC.StgToJS.CoreUtils
-        GHC.StgToJS.DataCon
-        GHC.StgToJS.Deps
-        GHC.StgToJS.Expr
-        GHC.StgToJS.ExprCtx
-        GHC.StgToJS.FFI
-        GHC.StgToJS.Heap
-        GHC.StgToJS.Ids
-        GHC.StgToJS.Linker.Linker
-        GHC.StgToJS.Linker.Types
-        GHC.StgToJS.Linker.Utils
-        GHC.StgToJS.Literal
-        GHC.StgToJS.Monad
-        GHC.StgToJS.Object
-        GHC.StgToJS.Prim
-        GHC.StgToJS.Printer
-        GHC.StgToJS.Profiling
-        GHC.StgToJS.Regs
-        GHC.StgToJS.Rts.Rts
-        GHC.StgToJS.Rts.Types
-        GHC.StgToJS.Sinker
-        GHC.StgToJS.Stack
-        GHC.StgToJS.StaticPtr
-        GHC.StgToJS.StgUtils
-        GHC.StgToJS.Symbols
-        GHC.StgToJS.Types
-        GHC.StgToJS.Utils
-        GHC.SysTools
-        GHC.SysTools.Ar
-        GHC.SysTools.Cpp
-        GHC.SysTools.Elf
-        GHC.SysTools.Info
-        GHC.SysTools.Process
-        GHC.SysTools.Tasks
-        GHC.Tc.Deriv
-        GHC.Tc.Deriv.Functor
-        GHC.Tc.Deriv.Generate
-        GHC.Tc.Deriv.Generics
-        GHC.Tc.Deriv.Infer
-        GHC.Tc.Deriv.Utils
-        GHC.Tc.Errors
-        GHC.Tc.Errors.Hole
-        GHC.Tc.Gen.Annotation
-        GHC.Tc.Gen.App
-        GHC.Tc.Gen.Arrow
-        GHC.Tc.Gen.Bind
-        GHC.Tc.Gen.Default
-        GHC.Tc.Gen.Export
-        GHC.Tc.Gen.Expr
-        GHC.Tc.Gen.Foreign
-        GHC.Tc.Gen.Head
-        GHC.Tc.Gen.HsType
-        GHC.Tc.Gen.Match
-        GHC.Tc.Gen.Pat
-        GHC.Tc.Gen.Rule
-        GHC.Tc.Gen.Sig
-        GHC.Tc.Gen.Splice
-        GHC.Tc.Instance.Class
-        GHC.Tc.Instance.Family
-        GHC.Tc.Instance.FunDeps
-        GHC.Tc.Instance.Typeable
-        GHC.Tc.Module
-        GHC.Tc.Plugin
-        GHC.Tc.Solver
-        GHC.Tc.Solver.Canonical
-        GHC.Tc.Solver.Interact
-        GHC.Tc.Solver.Monad
-        GHC.Tc.Solver.Rewrite
-        GHC.Tc.TyCl
-        GHC.Tc.TyCl.Build
-        GHC.Tc.TyCl.Class
-        GHC.Tc.TyCl.Instance
-        GHC.Tc.TyCl.PatSyn
-        GHC.Tc.TyCl.Utils
-        GHC.Tc.Types.EvTerm
-        GHC.Tc.Utils.Backpack
-        GHC.Tc.Utils.Concrete
-        GHC.Tc.Utils.Env
-        GHC.Tc.Utils.Instantiate
-        GHC.Tc.Utils.Monad
-        GHC.Tc.Utils.TcMType
-        GHC.Tc.Utils.Unify
-        GHC.Tc.Utils.Zonk
-        GHC.Tc.Validity
-        GHC.ThToHs
-        GHC.Types.Name.Shape
-        GHC.Types.TyThing.Ppr
-        GHC.Types.Unique.MemoFun
-        GHC.Unit.Finder
-        GHC.Utils.Asm
-        GHC.Wasm.ControlFlow
-        GHC.Wasm.ControlFlow.FromCmm
-        GHCi.CreateBCO
-        GHCi.InfoTable
-        GHCi.ObjLink
-        GHCi.Run
-        GHCi.Signals
-        GHCi.StaticPtrTable
-        GHCi.TH
-        Language.Haskell.TH.CodeDo
-        Language.Haskell.TH.Quote
+cabal-version: >=1.22
+build-type: Simple
+name: ghc-lib
+version: 8.8.0.20190424
+license: BSD3
+license-file: LICENSE
+category: Development
+author: The GHC Team and Digital Asset
+maintainer: Digital Asset
+synopsis: The GHC API, decoupled from GHC versions
+description: A package equivalent to the @ghc@ package, but which can be loaded on many compiler versions.
+homepage: https://github.com/digital-asset/ghc-lib
+bug-reports: https://github.com/digital-asset/ghc-lib/issues
+data-dir: ghc-lib/stage1/lib
+data-files:
+    settings
+    llvm-targets
+    llvm-passes
+    platformConstants
+extra-source-files:
+    ghc-lib/generated/ghcautoconf.h
+    ghc-lib/generated/ghcplatform.h
+    ghc-lib/generated/ghcversion.h
+    ghc-lib/generated/DerivedConstants.h
+    ghc-lib/generated/GHCConstantsHaskellExports.hs
+    ghc-lib/generated/GHCConstantsHaskellType.hs
+    ghc-lib/generated/GHCConstantsHaskellWrappers.hs
+    ghc-lib/stage1/compiler/build/ghc_boot_platform.h
+    ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl
+    ghc-lib/stage1/compiler/build/primop-code-size.hs-incl
+    ghc-lib/stage1/compiler/build/primop-commutable.hs-incl
+    ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl
+    ghc-lib/stage1/compiler/build/primop-fixity.hs-incl
+    ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl
+    ghc-lib/stage1/compiler/build/primop-list.hs-incl
+    ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl
+    ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl
+    ghc-lib/stage1/compiler/build/primop-strictness.hs-incl
+    ghc-lib/stage1/compiler/build/primop-tag.hs-incl
+    ghc-lib/stage1/compiler/build/primop-vector-tycons.hs-incl
+    ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl
+    ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl
+    ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl
+    includes/*.h
+    includes/CodeGen.Platform.hs
+    includes/rts/*.h
+    includes/rts/storage/*.h
+    includes/rts/prof/*.h
+    compiler/nativeGen/*.h
+    compiler/utils/*.h
+    compiler/*.h
+tested-with: GHC==8.6.3, GHC==8.4.3
+source-repository head
+    type: git
+    location: git@github.com:digital-asset/ghc-lib.git
+
+library
+    default-language:   Haskell2010
+    default-extensions: NoImplicitPrelude
+    include-dirs:
+        ghc-lib/generated
+        ghc-lib/stage1/compiler/build
+        compiler
+        compiler/utils
+    ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS
+    cc-options: -DTHREADED_RTS
+    cpp-options: -DSTAGE=2 -DTHREADED_RTS -DGHCI -DGHC_IN_GHCI
+    if !os(windows)
+        build-depends: unix
+    else
+        build-depends: Win32
+    build-depends:
+        ghc-prim > 0.2 && < 0.6,
+        base >= 4.11 && < 4.14,
+        containers >= 0.5 && < 0.7,
+        bytestring >= 0.9 && < 0.11,
+        binary == 0.8.*,
+        filepath >= 1 && < 1.5,
+        directory >= 1 && < 1.4,
+        array >= 0.1 && < 0.6,
+        deepseq >= 1.4 && < 1.5,
+        pretty == 1.1.*,
+        time >= 1.4 && < 1.10,
+        transformers == 0.5.*,
+        process >= 1 && < 1.7,
+        hpc == 0.6.*,
+        ghc-lib-parser == 8.8.0.20190424
+    build-tools: alex >= 3.1, happy >= 1.19.4
+    other-extensions:
+        BangPatterns
+        CPP
+        DataKinds
+        DefaultSignatures
+        DeriveDataTypeable
+        DeriveFoldable
+        DeriveFunctor
+        DeriveGeneric
+        DeriveTraversable
+        DisambiguateRecordFields
+        ExistentialQuantification
+        ExplicitForAll
+        FlexibleContexts
+        FlexibleInstances
+        GADTs
+        GeneralizedNewtypeDeriving
+        InstanceSigs
+        MagicHash
+        MultiParamTypeClasses
+        NamedFieldPuns
+        NondecreasingIndentation
+        RankNTypes
+        RecordWildCards
+        RoleAnnotations
+        ScopedTypeVariables
+        StandaloneDeriving
+        Trustworthy
+        TupleSections
+        TypeFamilies
+        TypeSynonymInstances
+        UnboxedTuples
+        UndecidableInstances
+    hs-source-dirs:
+        compiler
+        compiler/backpack
+        compiler/cmm
+        compiler/codeGen
+        compiler/coreSyn
+        compiler/deSugar
+        compiler/ghci
+        compiler/hieFile
+        compiler/hsSyn
+        compiler/iface
+        compiler/llvmGen
+        compiler/main
+        compiler/nativeGen
+        compiler/prelude
+        compiler/profiling
+        compiler/rename
+        compiler/simplCore
+        compiler/simplStg
+        compiler/specialise
+        compiler/stgSyn
+        compiler/stranal
+        compiler/typecheck
+        compiler/utils
+        ghc-lib/stage1/compiler/build
+        libraries/ghc-boot
+        libraries/ghci
+        libraries/template-haskell
+    autogen-modules:
+        Paths_ghc_lib
+    reexported-modules:
+        Annotations,
+        ApiAnnotation,
+        Avail,
+        Bag,
+        BasicTypes,
+        BinFingerprint,
+        Binary,
+        BkpSyn,
+        BooleanFormula,
+        BufWrite,
+        ByteCodeTypes,
+        Class,
+        CmdLineParser,
+        CmmType,
+        CoAxiom,
+        Coercion,
+        ConLike,
+        Config,
+        Constants,
+        CoreArity,
+        CoreFVs,
+        CoreMap,
+        CoreMonad,
+        CoreOpt,
+        CoreSeq,
+        CoreStats,
+        CoreSubst,
+        CoreSyn,
+        CoreTidy,
+        CoreUnfold,
+        CoreUtils,
+        CostCentre,
+        CostCentreState,
+        Ctype,
+        DataCon,
+        Demand,
+        Digraph,
+        DriverPhases,
+        DynFlags,
+        Encoding,
+        EnumSet,
+        ErrUtils,
+        Exception,
+        FV,
+        FamInstEnv,
+        FastFunctions,
+        FastMutInt,
+        FastString,
+        FastStringEnv,
+        FieldLabel,
+        FileCleanup,
+        Fingerprint,
+        FiniteMap,
+        ForeignCall,
+        GHC.Exts.Heap,
+        GHC.Exts.Heap.ClosureTypes,
+        GHC.Exts.Heap.Closures,
+        GHC.Exts.Heap.Constants,
+        GHC.Exts.Heap.InfoTable,
+        GHC.Exts.Heap.InfoTable.Types,
+        GHC.Exts.Heap.InfoTableProf,
+        GHC.Exts.Heap.Utils,
+        GHC.ForeignSrcLang,
+        GHC.ForeignSrcLang.Type,
+        GHC.LanguageExtensions,
+        GHC.LanguageExtensions.Type,
+        GHC.Lexeme,
+        GHC.PackageDb,
+        GHC.Serialized,
+        GHCi.BreakArray,
+        GHCi.FFI,
+        GHCi.Message,
+        GHCi.RemoteTypes,
+        GHCi.TH.Binary,
+        GhcMonad,
+        GhcPrelude,
+        HaddockUtils,
+        HeaderInfo,
+        Hooks,
+        HsBinds,
+        HsDecls,
+        HsDoc,
+        HsExpr,
+        HsExtension,
+        HsImpExp,
+        HsInstances,
+        HsLit,
+        HsPat,
+        HsSyn,
+        HsTypes,
+        HsUtils,
+        HscTypes,
+        IOEnv,
+        Id,
+        IdInfo,
+        IfaceSyn,
+        IfaceType,
+        InstEnv,
+        InteractiveEvalTypes,
+        Json,
+        Kind,
+        KnownUniques,
+        Language.Haskell.TH,
+        Language.Haskell.TH.LanguageExtensions,
+        Language.Haskell.TH.Lib,
+        Language.Haskell.TH.Lib.Internal,
+        Language.Haskell.TH.Lib.Map,
+        Language.Haskell.TH.Ppr,
+        Language.Haskell.TH.PprLib,
+        Language.Haskell.TH.Syntax,
+        Lexeme,
+        Lexer,
+        ListSetOps,
+        Literal,
+        Maybes,
+        MkCore,
+        MkId,
+        Module,
+        MonadUtils,
+        Name,
+        NameCache,
+        NameEnv,
+        NameSet,
+        OccName,
+        OccurAnal,
+        OptCoercion,
+        OrdList,
+        Outputable,
+        PackageConfig,
+        Packages,
+        Pair,
+        Panic,
+        Parser,
+        PatSyn,
+        PipelineMonad,
+        PlaceHolder,
+        Platform,
+        PlatformConstants,
+        Plugins,
+        PmExpr,
+        PprColour,
+        PprCore,
+        PrelNames,
+        PrelRules,
+        Pretty,
+        PrimOp,
+        RdrHsSyn,
+        RdrName,
+        RepType,
+        Rules,
+        SizedSeq,
+        SrcLoc,
+        StringBuffer,
+        SysTools.BaseDir,
+        SysTools.Terminal,
+        TcEvidence,
+        TcRnTypes,
+        TcType,
+        ToIface,
+        TrieMap,
+        TyCoRep,
+        TyCon,
+        Type,
+        TysPrim,
+        TysWiredIn,
+        Unify,
+        UniqDFM,
+        UniqDSet,
+        UniqFM,
+        UniqSet,
+        UniqSupply,
+        Unique,
+        Util,
+        Var,
+        VarEnv,
+        VarSet
+    exposed-modules:
+        Paths_ghc_lib
+        Ar
+        AsmCodeGen
+        AsmUtils
+        BinIface
+        Bitmap
+        BlockId
+        BlockLayout
+        BuildTyCl
+        ByteCodeAsm
+        ByteCodeGen
+        ByteCodeInstr
+        ByteCodeItbls
+        ByteCodeLink
+        CFG
+        CLabel
+        CPrim
+        CSE
+        CallArity
+        CgUtils
+        Check
+        ClsInst
+        Cmm
+        CmmBuildInfoTables
+        CmmCallConv
+        CmmCommonBlockElim
+        CmmContFlowOpt
+        CmmExpr
+        CmmImplementSwitchPlans
+        CmmInfo
+        CmmLayoutStack
+        CmmLex
+        CmmLint
+        CmmLive
+        CmmMachOp
+        CmmMonad
+        CmmNode
+        CmmOpt
+        CmmParse
+        CmmPipeline
+        CmmProcPoint
+        CmmSink
+        CmmSwitch
+        CmmUtils
+        CodeGen.Platform
+        CodeGen.Platform.ARM
+        CodeGen.Platform.ARM64
+        CodeGen.Platform.NoRegs
+        CodeGen.Platform.PPC
+        CodeGen.Platform.SPARC
+        CodeGen.Platform.X86
+        CodeGen.Platform.X86_64
+        CodeOutput
+        Convert
+        CoreLint
+        CorePrep
+        CoreToStg
+        Coverage
+        Debug
+        Debugger
+        Desugar
+        DmdAnal
+        DriverBkp
+        DriverMkDepend
+        DriverPipeline
+        DsArrows
+        DsBinds
+        DsCCall
+        DsExpr
+        DsForeign
+        DsGRHSs
+        DsListComp
+        DsMeta
+        DsMonad
+        DsUsage
+        DsUtils
+        Dwarf
+        Dwarf.Constants
+        Dwarf.Types
+        DynamicLoading
+        Elf
+        Exitify
+        ExtractDocs
+        FamInst
+        Finder
+        FlagChecker
+        FloatIn
+        FloatOut
+        Format
+        FunDeps
+        GHC
+        GHC.HandleEncoding
+        GHCi
+        GHCi.BinaryArray
+        GHCi.CreateBCO
+        GHCi.InfoTable
+        GHCi.ObjLink
+        GHCi.ResolvedBCO
+        GHCi.Run
+        GHCi.Signals
+        GHCi.StaticPtrTable
+        GHCi.TH
+        GhcMake
+        GhcPlugins
+        GraphBase
+        GraphColor
+        GraphOps
+        GraphPpr
+        HieAst
+        HieBin
+        HieDebug
+        HieTypes
+        HieUtils
+        Hoopl.Block
+        Hoopl.Collections
+        Hoopl.Dataflow
+        Hoopl.Graph
+        Hoopl.Label
+        HsDumpAst
+        HscMain
+        HscStats
+        IfaceEnv
+        Inst
+        Instruction
+        InteractiveEval
+        Language.Haskell.TH.Quote
+        LiberateCase
+        Linker
+        ListT
+        Llvm
+        Llvm.AbsSyn
+        Llvm.MetaData
+        Llvm.PpLlvm
+        Llvm.Types
+        LlvmCodeGen
+        LlvmCodeGen.Base
+        LlvmCodeGen.CodeGen
+        LlvmCodeGen.Data
+        LlvmCodeGen.Ppr
+        LlvmCodeGen.Regs
+        LlvmMangler
+        LoadIface
+        Match
+        MatchCon
+        MatchLit
+        MkGraph
+        MkIface
+        NCGMonad
+        NameShape
+        PIC
+        PPC.CodeGen
+        PPC.Cond
+        PPC.Instr
+        PPC.Ppr
+        PPC.RegInfo
+        PPC.Regs
+        PprBase
+        PprC
+        PprCmm
+        PprCmmDecl
+        PprCmmExpr
+        PprTyThing
+        PrelInfo
+        ProfInit
+        Reg
+        RegAlloc.Graph.ArchBase
+        RegAlloc.Graph.ArchX86
+        RegAlloc.Graph.Coalesce
+        RegAlloc.Graph.Main
+        RegAlloc.Graph.Spill
+        RegAlloc.Graph.SpillClean
+        RegAlloc.Graph.SpillCost
+        RegAlloc.Graph.Stats
+        RegAlloc.Graph.TrivColorable
+        RegAlloc.Linear.Base
+        RegAlloc.Linear.FreeRegs
+        RegAlloc.Linear.JoinToTargets
+        RegAlloc.Linear.Main
+        RegAlloc.Linear.PPC.FreeRegs
+        RegAlloc.Linear.SPARC.FreeRegs
+        RegAlloc.Linear.StackMap
+        RegAlloc.Linear.State
+        RegAlloc.Linear.Stats
+        RegAlloc.Linear.X86.FreeRegs
+        RegAlloc.Linear.X86_64.FreeRegs
+        RegAlloc.Liveness
+        RegClass
+        RnBinds
+        RnEnv
+        RnExpr
+        RnFixity
+        RnHsDoc
+        RnModIface
+        RnNames
+        RnPat
+        RnSource
+        RnSplice
+        RnTypes
+        RnUnbound
+        RnUtils
+        RtClosureInspect
+        SAT
+        SMRep
+        SPARC.AddrMode
+        SPARC.Base
+        SPARC.CodeGen
+        SPARC.CodeGen.Amode
+        SPARC.CodeGen.Base
+        SPARC.CodeGen.CondCode
+        SPARC.CodeGen.Expand
+        SPARC.CodeGen.Gen32
+        SPARC.CodeGen.Gen64
+        SPARC.CodeGen.Sanity
+        SPARC.Cond
+        SPARC.Imm
+        SPARC.Instr
+        SPARC.Ppr
+        SPARC.Regs
+        SPARC.ShortcutJump
+        SPARC.Stack
+        SetLevels
+        SimplCore
+        SimplEnv
+        SimplMonad
+        SimplStg
+        SimplUtils
+        Simplify
+        SpecConstr
+        Specialise
+        State
+        StaticPtrTable
+        StgCmm
+        StgCmmArgRep
+        StgCmmBind
+        StgCmmClosure
+        StgCmmCon
+        StgCmmEnv
+        StgCmmExpr
+        StgCmmExtCode
+        StgCmmForeign
+        StgCmmHeap
+        StgCmmHpc
+        StgCmmLayout
+        StgCmmMonad
+        StgCmmPrim
+        StgCmmProf
+        StgCmmTicky
+        StgCmmUtils
+        StgCse
+        StgFVs
+        StgLiftLams
+        StgLiftLams.Analysis
+        StgLiftLams.LiftM
+        StgLiftLams.Transformation
+        StgLint
+        StgStats
+        StgSubst
+        StgSyn
+        Stream
+        SysTools
+        SysTools.ExtraObj
+        SysTools.Info
+        SysTools.Process
+        SysTools.Tasks
+        THNames
+        TargetReg
+        TcAnnotations
+        TcArrows
+        TcBackpack
+        TcBinds
+        TcCanonical
+        TcClassDcl
+        TcDefaults
+        TcDeriv
+        TcDerivInfer
+        TcDerivUtils
+        TcEnv
+        TcErrors
+        TcEvTerm
+        TcExpr
+        TcFlatten
+        TcForeign
+        TcGenDeriv
+        TcGenFunctor
+        TcGenGenerics
+        TcHoleErrors
+        TcHsSyn
+        TcHsType
+        TcIface
+        TcInstDcls
+        TcInteract
+        TcMType
+        TcMatches
+        TcPat
+        TcPatSyn
+        TcPluginM
+        TcRnDriver
+        TcRnExports
+        TcRnMonad
+        TcRules
+        TcSMonad
+        TcSigs
+        TcSimplify
+        TcSplice
+        TcTyClsDecls
+        TcTyDecls
+        TcTypeNats
+        TcTypeable
+        TcUnify
+        TcValidity
+        TidyPgm
+        TmOracle
+        UnVarGraph
+        UnariseStg
+        UniqMap
+        WorkWrap
+        WwLib
+        X86.CodeGen
+        X86.Cond
+        X86.Instr
+        X86.Ppr
+        X86.RegInfo
+        X86.Regs
+
+executable ghc-lib
+    default-language:   Haskell2010
+    if !os(windows)
+        build-depends: unix
+    else
+        build-depends: Win32
+    build-depends:
+        base == 4.*, array, bytestring, directory, process, filepath,
+        containers, deepseq, ghc-prim, haskeline, time, transformers,
+        ghc-lib
+    hs-source-dirs: ghc
+    ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS
+    cc-options: -DTHREADED_RTS
+    cpp-options: -DGHCI -DTHREADED_RTS -DGHC_LOADED_INTO_GHCI
+    other-modules:
+        GHCi.Leak
+        GHCi.UI
+        GHCi.UI.Info
+        GHCi.UI.Monad
+        GHCi.UI.Tags
+    other-extensions:
+        BangPatterns
+        CPP
+        FlexibleInstances
+        LambdaCase
+        MagicHash
+        MultiWayIf
+        NondecreasingIndentation
+        OverloadedStrings
+        RankNTypes
+        RecordWildCards
+        ScopedTypeVariables
+        TupleSections
+        UnboxedTuples
+        ViewPatterns
+    default-extensions: NoImplicitPrelude
+    main-is: Main.hs
diff --git a/ghc-lib/generated/DerivedConstants.h b/ghc-lib/generated/DerivedConstants.h
new file mode 100644
--- /dev/null
+++ b/ghc-lib/generated/DerivedConstants.h
@@ -0,0 +1,554 @@
+/* This file is created automatically.  Do not edit by hand.*/
+
+#define CONTROL_GROUP_CONST_291 291
+#define STD_HDR_SIZE 1
+#define PROF_HDR_SIZE 2
+#define BLOCK_SIZE 4096
+#define MBLOCK_SIZE 1048576
+#define BLOCKS_PER_MBLOCK 252
+#define TICKY_BIN_COUNT 9
+#define OFFSET_StgRegTable_rR1 0
+#define OFFSET_StgRegTable_rR2 8
+#define OFFSET_StgRegTable_rR3 16
+#define OFFSET_StgRegTable_rR4 24
+#define OFFSET_StgRegTable_rR5 32
+#define OFFSET_StgRegTable_rR6 40
+#define OFFSET_StgRegTable_rR7 48
+#define OFFSET_StgRegTable_rR8 56
+#define OFFSET_StgRegTable_rR9 64
+#define OFFSET_StgRegTable_rR10 72
+#define OFFSET_StgRegTable_rF1 80
+#define OFFSET_StgRegTable_rF2 84
+#define OFFSET_StgRegTable_rF3 88
+#define OFFSET_StgRegTable_rF4 92
+#define OFFSET_StgRegTable_rF5 96
+#define OFFSET_StgRegTable_rF6 100
+#define OFFSET_StgRegTable_rD1 104
+#define OFFSET_StgRegTable_rD2 112
+#define OFFSET_StgRegTable_rD3 120
+#define OFFSET_StgRegTable_rD4 128
+#define OFFSET_StgRegTable_rD5 136
+#define OFFSET_StgRegTable_rD6 144
+#define OFFSET_StgRegTable_rXMM1 152
+#define OFFSET_StgRegTable_rXMM2 168
+#define OFFSET_StgRegTable_rXMM3 184
+#define OFFSET_StgRegTable_rXMM4 200
+#define OFFSET_StgRegTable_rXMM5 216
+#define OFFSET_StgRegTable_rXMM6 232
+#define OFFSET_StgRegTable_rYMM1 248
+#define OFFSET_StgRegTable_rYMM2 280
+#define OFFSET_StgRegTable_rYMM3 312
+#define OFFSET_StgRegTable_rYMM4 344
+#define OFFSET_StgRegTable_rYMM5 376
+#define OFFSET_StgRegTable_rYMM6 408
+#define OFFSET_StgRegTable_rZMM1 440
+#define OFFSET_StgRegTable_rZMM2 504
+#define OFFSET_StgRegTable_rZMM3 568
+#define OFFSET_StgRegTable_rZMM4 632
+#define OFFSET_StgRegTable_rZMM5 696
+#define OFFSET_StgRegTable_rZMM6 760
+#define OFFSET_StgRegTable_rL1 824
+#define OFFSET_StgRegTable_rSp 832
+#define OFFSET_StgRegTable_rSpLim 840
+#define OFFSET_StgRegTable_rHp 848
+#define OFFSET_StgRegTable_rHpLim 856
+#define OFFSET_StgRegTable_rCCCS 864
+#define OFFSET_StgRegTable_rCurrentTSO 872
+#define OFFSET_StgRegTable_rCurrentNursery 888
+#define OFFSET_StgRegTable_rHpAlloc 904
+#define OFFSET_StgRegTable_rRet 912
+#define REP_StgRegTable_rRet b64
+#define StgRegTable_rRet(__ptr__) REP_StgRegTable_rRet[__ptr__+OFFSET_StgRegTable_rRet]
+#define OFFSET_StgRegTable_rNursery 880
+#define REP_StgRegTable_rNursery b64
+#define StgRegTable_rNursery(__ptr__) REP_StgRegTable_rNursery[__ptr__+OFFSET_StgRegTable_rNursery]
+#define OFFSET_stgEagerBlackholeInfo -24
+#define OFFSET_stgGCEnter1 -16
+#define OFFSET_stgGCFun -8
+#define OFFSET_Capability_r 24
+#define OFFSET_Capability_lock 1096
+#define OFFSET_Capability_no 944
+#define REP_Capability_no b32
+#define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no]
+#define OFFSET_Capability_mut_lists 1016
+#define REP_Capability_mut_lists b64
+#define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]
+#define OFFSET_Capability_context_switch 1064
+#define REP_Capability_context_switch b32
+#define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]
+#define OFFSET_Capability_interrupt 1068
+#define REP_Capability_interrupt b32
+#define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]
+#define OFFSET_Capability_sparks 1200
+#define REP_Capability_sparks b64
+#define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]
+#define OFFSET_Capability_total_allocated 1072
+#define REP_Capability_total_allocated b64
+#define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]
+#define OFFSET_Capability_weak_ptr_list_hd 1048
+#define REP_Capability_weak_ptr_list_hd b64
+#define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]
+#define OFFSET_Capability_weak_ptr_list_tl 1056
+#define REP_Capability_weak_ptr_list_tl b64
+#define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl]
+#define OFFSET_bdescr_start 0
+#define REP_bdescr_start b64
+#define bdescr_start(__ptr__) REP_bdescr_start[__ptr__+OFFSET_bdescr_start]
+#define OFFSET_bdescr_free 8
+#define REP_bdescr_free b64
+#define bdescr_free(__ptr__) REP_bdescr_free[__ptr__+OFFSET_bdescr_free]
+#define OFFSET_bdescr_blocks 48
+#define REP_bdescr_blocks b32
+#define bdescr_blocks(__ptr__) REP_bdescr_blocks[__ptr__+OFFSET_bdescr_blocks]
+#define OFFSET_bdescr_gen_no 40
+#define REP_bdescr_gen_no b16
+#define bdescr_gen_no(__ptr__) REP_bdescr_gen_no[__ptr__+OFFSET_bdescr_gen_no]
+#define OFFSET_bdescr_link 16
+#define REP_bdescr_link b64
+#define bdescr_link(__ptr__) REP_bdescr_link[__ptr__+OFFSET_bdescr_link]
+#define OFFSET_bdescr_flags 46
+#define REP_bdescr_flags b16
+#define bdescr_flags(__ptr__) REP_bdescr_flags[__ptr__+OFFSET_bdescr_flags]
+#define SIZEOF_generation 384
+#define OFFSET_generation_n_new_large_words 56
+#define REP_generation_n_new_large_words b64
+#define generation_n_new_large_words(__ptr__) REP_generation_n_new_large_words[__ptr__+OFFSET_generation_n_new_large_words]
+#define OFFSET_generation_weak_ptr_list 112
+#define REP_generation_weak_ptr_list b64
+#define generation_weak_ptr_list(__ptr__) REP_generation_weak_ptr_list[__ptr__+OFFSET_generation_weak_ptr_list]
+#define SIZEOF_CostCentreStack 96
+#define OFFSET_CostCentreStack_ccsID 0
+#define REP_CostCentreStack_ccsID b64
+#define CostCentreStack_ccsID(__ptr__) REP_CostCentreStack_ccsID[__ptr__+OFFSET_CostCentreStack_ccsID]
+#define OFFSET_CostCentreStack_mem_alloc 72
+#define REP_CostCentreStack_mem_alloc b64
+#define CostCentreStack_mem_alloc(__ptr__) REP_CostCentreStack_mem_alloc[__ptr__+OFFSET_CostCentreStack_mem_alloc]
+#define OFFSET_CostCentreStack_scc_count 48
+#define REP_CostCentreStack_scc_count b64
+#define CostCentreStack_scc_count(__ptr__) REP_CostCentreStack_scc_count[__ptr__+OFFSET_CostCentreStack_scc_count]
+#define OFFSET_CostCentreStack_prevStack 16
+#define REP_CostCentreStack_prevStack b64
+#define CostCentreStack_prevStack(__ptr__) REP_CostCentreStack_prevStack[__ptr__+OFFSET_CostCentreStack_prevStack]
+#define OFFSET_CostCentre_ccID 0
+#define REP_CostCentre_ccID b64
+#define CostCentre_ccID(__ptr__) REP_CostCentre_ccID[__ptr__+OFFSET_CostCentre_ccID]
+#define OFFSET_CostCentre_link 56
+#define REP_CostCentre_link b64
+#define CostCentre_link(__ptr__) REP_CostCentre_link[__ptr__+OFFSET_CostCentre_link]
+#define OFFSET_StgHeader_info 0
+#define REP_StgHeader_info b64
+#define StgHeader_info(__ptr__) REP_StgHeader_info[__ptr__+OFFSET_StgHeader_info]
+#define OFFSET_StgHeader_ccs 8
+#define REP_StgHeader_ccs b64
+#define StgHeader_ccs(__ptr__) REP_StgHeader_ccs[__ptr__+OFFSET_StgHeader_ccs]
+#define OFFSET_StgHeader_ldvw 16
+#define REP_StgHeader_ldvw b64
+#define StgHeader_ldvw(__ptr__) REP_StgHeader_ldvw[__ptr__+OFFSET_StgHeader_ldvw]
+#define SIZEOF_StgSMPThunkHeader 8
+#define OFFSET_StgClosure_payload 0
+#define StgClosure_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgClosure_payload + WDS(__ix__)]
+#define OFFSET_StgEntCounter_allocs 48
+#define REP_StgEntCounter_allocs b64
+#define StgEntCounter_allocs(__ptr__) REP_StgEntCounter_allocs[__ptr__+OFFSET_StgEntCounter_allocs]
+#define OFFSET_StgEntCounter_allocd 16
+#define REP_StgEntCounter_allocd b64
+#define StgEntCounter_allocd(__ptr__) REP_StgEntCounter_allocd[__ptr__+OFFSET_StgEntCounter_allocd]
+#define OFFSET_StgEntCounter_registeredp 0
+#define REP_StgEntCounter_registeredp b64
+#define StgEntCounter_registeredp(__ptr__) REP_StgEntCounter_registeredp[__ptr__+OFFSET_StgEntCounter_registeredp]
+#define OFFSET_StgEntCounter_link 56
+#define REP_StgEntCounter_link b64
+#define StgEntCounter_link(__ptr__) REP_StgEntCounter_link[__ptr__+OFFSET_StgEntCounter_link]
+#define OFFSET_StgEntCounter_entry_count 40
+#define REP_StgEntCounter_entry_count b64
+#define StgEntCounter_entry_count(__ptr__) REP_StgEntCounter_entry_count[__ptr__+OFFSET_StgEntCounter_entry_count]
+#define SIZEOF_StgUpdateFrame_NoHdr 8
+#define SIZEOF_StgUpdateFrame (SIZEOF_StgHeader+8)
+#define SIZEOF_StgCatchFrame_NoHdr 16
+#define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16)
+#define SIZEOF_StgStopFrame_NoHdr 0
+#define SIZEOF_StgStopFrame (SIZEOF_StgHeader+0)
+#define SIZEOF_StgMutArrPtrs_NoHdr 16
+#define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16)
+#define OFFSET_StgMutArrPtrs_ptrs 0
+#define REP_StgMutArrPtrs_ptrs b64
+#define StgMutArrPtrs_ptrs(__ptr__) REP_StgMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_ptrs]
+#define OFFSET_StgMutArrPtrs_size 8
+#define REP_StgMutArrPtrs_size b64
+#define StgMutArrPtrs_size(__ptr__) REP_StgMutArrPtrs_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_size]
+#define SIZEOF_StgSmallMutArrPtrs_NoHdr 8
+#define SIZEOF_StgSmallMutArrPtrs (SIZEOF_StgHeader+8)
+#define OFFSET_StgSmallMutArrPtrs_ptrs 0
+#define REP_StgSmallMutArrPtrs_ptrs b64
+#define StgSmallMutArrPtrs_ptrs(__ptr__) REP_StgSmallMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgSmallMutArrPtrs_ptrs]
+#define SIZEOF_StgArrBytes_NoHdr 8
+#define SIZEOF_StgArrBytes (SIZEOF_StgHeader+8)
+#define OFFSET_StgArrBytes_bytes 0
+#define REP_StgArrBytes_bytes b64
+#define StgArrBytes_bytes(__ptr__) REP_StgArrBytes_bytes[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_bytes]
+#define OFFSET_StgArrBytes_payload 8
+#define StgArrBytes_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_payload + WDS(__ix__)]
+#define OFFSET_StgTSO__link 0
+#define REP_StgTSO__link b64
+#define StgTSO__link(__ptr__) REP_StgTSO__link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO__link]
+#define OFFSET_StgTSO_global_link 8
+#define REP_StgTSO_global_link b64
+#define StgTSO_global_link(__ptr__) REP_StgTSO_global_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_global_link]
+#define OFFSET_StgTSO_what_next 24
+#define REP_StgTSO_what_next b16
+#define StgTSO_what_next(__ptr__) REP_StgTSO_what_next[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_what_next]
+#define OFFSET_StgTSO_why_blocked 26
+#define REP_StgTSO_why_blocked b16
+#define StgTSO_why_blocked(__ptr__) REP_StgTSO_why_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_why_blocked]
+#define OFFSET_StgTSO_block_info 32
+#define REP_StgTSO_block_info b64
+#define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info]
+#define OFFSET_StgTSO_blocked_exceptions 80
+#define REP_StgTSO_blocked_exceptions b64
+#define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions]
+#define OFFSET_StgTSO_id 40
+#define REP_StgTSO_id b32
+#define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id]
+#define OFFSET_StgTSO_cap 64
+#define REP_StgTSO_cap b64
+#define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap]
+#define OFFSET_StgTSO_saved_errno 44
+#define REP_StgTSO_saved_errno b32
+#define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno]
+#define OFFSET_StgTSO_trec 72
+#define REP_StgTSO_trec b64
+#define StgTSO_trec(__ptr__) REP_StgTSO_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_trec]
+#define OFFSET_StgTSO_flags 28
+#define REP_StgTSO_flags b32
+#define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags]
+#define OFFSET_StgTSO_dirty 48
+#define REP_StgTSO_dirty b32
+#define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty]
+#define OFFSET_StgTSO_bq 88
+#define REP_StgTSO_bq b64
+#define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq]
+#define OFFSET_StgTSO_alloc_limit 96
+#define REP_StgTSO_alloc_limit b64
+#define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit]
+#define OFFSET_StgTSO_cccs 112
+#define REP_StgTSO_cccs b64
+#define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs]
+#define OFFSET_StgTSO_stackobj 16
+#define REP_StgTSO_stackobj b64
+#define StgTSO_stackobj(__ptr__) REP_StgTSO_stackobj[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_stackobj]
+#define OFFSET_StgStack_sp 8
+#define REP_StgStack_sp b64
+#define StgStack_sp(__ptr__) REP_StgStack_sp[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_sp]
+#define OFFSET_StgStack_stack 16
+#define OFFSET_StgStack_stack_size 0
+#define REP_StgStack_stack_size b32
+#define StgStack_stack_size(__ptr__) REP_StgStack_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_stack_size]
+#define OFFSET_StgStack_dirty 4
+#define REP_StgStack_dirty b32
+#define StgStack_dirty(__ptr__) REP_StgStack_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_dirty]
+#define SIZEOF_StgTSOProfInfo 8
+#define OFFSET_StgUpdateFrame_updatee 0
+#define REP_StgUpdateFrame_updatee b64
+#define StgUpdateFrame_updatee(__ptr__) REP_StgUpdateFrame_updatee[__ptr__+SIZEOF_StgHeader+OFFSET_StgUpdateFrame_updatee]
+#define OFFSET_StgCatchFrame_handler 8
+#define REP_StgCatchFrame_handler b64
+#define StgCatchFrame_handler(__ptr__) REP_StgCatchFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_handler]
+#define OFFSET_StgCatchFrame_exceptions_blocked 0
+#define REP_StgCatchFrame_exceptions_blocked b64
+#define StgCatchFrame_exceptions_blocked(__ptr__) REP_StgCatchFrame_exceptions_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_exceptions_blocked]
+#define SIZEOF_StgPAP_NoHdr 16
+#define SIZEOF_StgPAP (SIZEOF_StgHeader+16)
+#define OFFSET_StgPAP_n_args 4
+#define REP_StgPAP_n_args b32
+#define StgPAP_n_args(__ptr__) REP_StgPAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_n_args]
+#define OFFSET_StgPAP_fun 8
+#define REP_StgPAP_fun gcptr
+#define StgPAP_fun(__ptr__) REP_StgPAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_fun]
+#define OFFSET_StgPAP_arity 0
+#define REP_StgPAP_arity b32
+#define StgPAP_arity(__ptr__) REP_StgPAP_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_arity]
+#define OFFSET_StgPAP_payload 16
+#define StgPAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_payload + WDS(__ix__)]
+#define SIZEOF_StgAP_NoThunkHdr 16
+#define SIZEOF_StgAP_NoHdr 24
+#define SIZEOF_StgAP (SIZEOF_StgHeader+24)
+#define OFFSET_StgAP_n_args 12
+#define REP_StgAP_n_args b32
+#define StgAP_n_args(__ptr__) REP_StgAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_n_args]
+#define OFFSET_StgAP_fun 16
+#define REP_StgAP_fun gcptr
+#define StgAP_fun(__ptr__) REP_StgAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_fun]
+#define OFFSET_StgAP_payload 24
+#define StgAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_payload + WDS(__ix__)]
+#define SIZEOF_StgAP_STACK_NoThunkHdr 16
+#define SIZEOF_StgAP_STACK_NoHdr 24
+#define SIZEOF_StgAP_STACK (SIZEOF_StgHeader+24)
+#define OFFSET_StgAP_STACK_size 8
+#define REP_StgAP_STACK_size b64
+#define StgAP_STACK_size(__ptr__) REP_StgAP_STACK_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_size]
+#define OFFSET_StgAP_STACK_fun 16
+#define REP_StgAP_STACK_fun gcptr
+#define StgAP_STACK_fun(__ptr__) REP_StgAP_STACK_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_fun]
+#define OFFSET_StgAP_STACK_payload 24
+#define StgAP_STACK_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_payload + WDS(__ix__)]
+#define SIZEOF_StgSelector_NoThunkHdr 8
+#define SIZEOF_StgSelector_NoHdr 16
+#define SIZEOF_StgSelector (SIZEOF_StgHeader+16)
+#define OFFSET_StgInd_indirectee 0
+#define REP_StgInd_indirectee gcptr
+#define StgInd_indirectee(__ptr__) REP_StgInd_indirectee[__ptr__+SIZEOF_StgHeader+OFFSET_StgInd_indirectee]
+#define SIZEOF_StgMutVar_NoHdr 8
+#define SIZEOF_StgMutVar (SIZEOF_StgHeader+8)
+#define OFFSET_StgMutVar_var 0
+#define REP_StgMutVar_var b64
+#define StgMutVar_var(__ptr__) REP_StgMutVar_var[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutVar_var]
+#define SIZEOF_StgAtomicallyFrame_NoHdr 16
+#define SIZEOF_StgAtomicallyFrame (SIZEOF_StgHeader+16)
+#define OFFSET_StgAtomicallyFrame_code 0
+#define REP_StgAtomicallyFrame_code b64
+#define StgAtomicallyFrame_code(__ptr__) REP_StgAtomicallyFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_code]
+#define OFFSET_StgAtomicallyFrame_result 8
+#define REP_StgAtomicallyFrame_result b64
+#define StgAtomicallyFrame_result(__ptr__) REP_StgAtomicallyFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_result]
+#define OFFSET_StgTRecHeader_enclosing_trec 0
+#define REP_StgTRecHeader_enclosing_trec b64
+#define StgTRecHeader_enclosing_trec(__ptr__) REP_StgTRecHeader_enclosing_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTRecHeader_enclosing_trec]
+#define SIZEOF_StgCatchSTMFrame_NoHdr 16
+#define SIZEOF_StgCatchSTMFrame (SIZEOF_StgHeader+16)
+#define OFFSET_StgCatchSTMFrame_handler 8
+#define REP_StgCatchSTMFrame_handler b64
+#define StgCatchSTMFrame_handler(__ptr__) REP_StgCatchSTMFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_handler]
+#define OFFSET_StgCatchSTMFrame_code 0
+#define REP_StgCatchSTMFrame_code b64
+#define StgCatchSTMFrame_code(__ptr__) REP_StgCatchSTMFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_code]
+#define SIZEOF_StgCatchRetryFrame_NoHdr 24
+#define SIZEOF_StgCatchRetryFrame (SIZEOF_StgHeader+24)
+#define OFFSET_StgCatchRetryFrame_running_alt_code 0
+#define REP_StgCatchRetryFrame_running_alt_code b64
+#define StgCatchRetryFrame_running_alt_code(__ptr__) REP_StgCatchRetryFrame_running_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_running_alt_code]
+#define OFFSET_StgCatchRetryFrame_first_code 8
+#define REP_StgCatchRetryFrame_first_code b64
+#define StgCatchRetryFrame_first_code(__ptr__) REP_StgCatchRetryFrame_first_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_first_code]
+#define OFFSET_StgCatchRetryFrame_alt_code 16
+#define REP_StgCatchRetryFrame_alt_code b64
+#define StgCatchRetryFrame_alt_code(__ptr__) REP_StgCatchRetryFrame_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_alt_code]
+#define OFFSET_StgTVarWatchQueue_closure 0
+#define REP_StgTVarWatchQueue_closure b64
+#define StgTVarWatchQueue_closure(__ptr__) REP_StgTVarWatchQueue_closure[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_closure]
+#define OFFSET_StgTVarWatchQueue_next_queue_entry 8
+#define REP_StgTVarWatchQueue_next_queue_entry b64
+#define StgTVarWatchQueue_next_queue_entry(__ptr__) REP_StgTVarWatchQueue_next_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_next_queue_entry]
+#define OFFSET_StgTVarWatchQueue_prev_queue_entry 16
+#define REP_StgTVarWatchQueue_prev_queue_entry b64
+#define StgTVarWatchQueue_prev_queue_entry(__ptr__) REP_StgTVarWatchQueue_prev_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_prev_queue_entry]
+#define SIZEOF_StgTVar_NoHdr 24
+#define SIZEOF_StgTVar (SIZEOF_StgHeader+24)
+#define OFFSET_StgTVar_current_value 0
+#define REP_StgTVar_current_value b64
+#define StgTVar_current_value(__ptr__) REP_StgTVar_current_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_current_value]
+#define OFFSET_StgTVar_first_watch_queue_entry 8
+#define REP_StgTVar_first_watch_queue_entry b64
+#define StgTVar_first_watch_queue_entry(__ptr__) REP_StgTVar_first_watch_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_first_watch_queue_entry]
+#define OFFSET_StgTVar_num_updates 16
+#define REP_StgTVar_num_updates b64
+#define StgTVar_num_updates(__ptr__) REP_StgTVar_num_updates[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_num_updates]
+#define SIZEOF_StgWeak_NoHdr 40
+#define SIZEOF_StgWeak (SIZEOF_StgHeader+40)
+#define OFFSET_StgWeak_link 32
+#define REP_StgWeak_link b64
+#define StgWeak_link(__ptr__) REP_StgWeak_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_link]
+#define OFFSET_StgWeak_key 8
+#define REP_StgWeak_key b64
+#define StgWeak_key(__ptr__) REP_StgWeak_key[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_key]
+#define OFFSET_StgWeak_value 16
+#define REP_StgWeak_value b64
+#define StgWeak_value(__ptr__) REP_StgWeak_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_value]
+#define OFFSET_StgWeak_finalizer 24
+#define REP_StgWeak_finalizer b64
+#define StgWeak_finalizer(__ptr__) REP_StgWeak_finalizer[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_finalizer]
+#define OFFSET_StgWeak_cfinalizers 0
+#define REP_StgWeak_cfinalizers b64
+#define StgWeak_cfinalizers(__ptr__) REP_StgWeak_cfinalizers[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_cfinalizers]
+#define SIZEOF_StgCFinalizerList_NoHdr 40
+#define SIZEOF_StgCFinalizerList (SIZEOF_StgHeader+40)
+#define OFFSET_StgCFinalizerList_link 0
+#define REP_StgCFinalizerList_link b64
+#define StgCFinalizerList_link(__ptr__) REP_StgCFinalizerList_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_link]
+#define OFFSET_StgCFinalizerList_fptr 8
+#define REP_StgCFinalizerList_fptr b64
+#define StgCFinalizerList_fptr(__ptr__) REP_StgCFinalizerList_fptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_fptr]
+#define OFFSET_StgCFinalizerList_ptr 16
+#define REP_StgCFinalizerList_ptr b64
+#define StgCFinalizerList_ptr(__ptr__) REP_StgCFinalizerList_ptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_ptr]
+#define OFFSET_StgCFinalizerList_eptr 24
+#define REP_StgCFinalizerList_eptr b64
+#define StgCFinalizerList_eptr(__ptr__) REP_StgCFinalizerList_eptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_eptr]
+#define OFFSET_StgCFinalizerList_flag 32
+#define REP_StgCFinalizerList_flag b64
+#define StgCFinalizerList_flag(__ptr__) REP_StgCFinalizerList_flag[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_flag]
+#define SIZEOF_StgMVar_NoHdr 24
+#define SIZEOF_StgMVar (SIZEOF_StgHeader+24)
+#define OFFSET_StgMVar_head 0
+#define REP_StgMVar_head b64
+#define StgMVar_head(__ptr__) REP_StgMVar_head[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_head]
+#define OFFSET_StgMVar_tail 8
+#define REP_StgMVar_tail b64
+#define StgMVar_tail(__ptr__) REP_StgMVar_tail[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_tail]
+#define OFFSET_StgMVar_value 16
+#define REP_StgMVar_value b64
+#define StgMVar_value(__ptr__) REP_StgMVar_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_value]
+#define SIZEOF_StgMVarTSOQueue_NoHdr 16
+#define SIZEOF_StgMVarTSOQueue (SIZEOF_StgHeader+16)
+#define OFFSET_StgMVarTSOQueue_link 0
+#define REP_StgMVarTSOQueue_link b64
+#define StgMVarTSOQueue_link(__ptr__) REP_StgMVarTSOQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_link]
+#define OFFSET_StgMVarTSOQueue_tso 8
+#define REP_StgMVarTSOQueue_tso b64
+#define StgMVarTSOQueue_tso(__ptr__) REP_StgMVarTSOQueue_tso[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_tso]
+#define SIZEOF_StgBCO_NoHdr 32
+#define SIZEOF_StgBCO (SIZEOF_StgHeader+32)
+#define OFFSET_StgBCO_instrs 0
+#define REP_StgBCO_instrs b64
+#define StgBCO_instrs(__ptr__) REP_StgBCO_instrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_instrs]
+#define OFFSET_StgBCO_literals 8
+#define REP_StgBCO_literals b64
+#define StgBCO_literals(__ptr__) REP_StgBCO_literals[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_literals]
+#define OFFSET_StgBCO_ptrs 16
+#define REP_StgBCO_ptrs b64
+#define StgBCO_ptrs(__ptr__) REP_StgBCO_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_ptrs]
+#define OFFSET_StgBCO_arity 24
+#define REP_StgBCO_arity b32
+#define StgBCO_arity(__ptr__) REP_StgBCO_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_arity]
+#define OFFSET_StgBCO_size 28
+#define REP_StgBCO_size b32
+#define StgBCO_size(__ptr__) REP_StgBCO_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_size]
+#define OFFSET_StgBCO_bitmap 32
+#define StgBCO_bitmap(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_bitmap + WDS(__ix__)]
+#define SIZEOF_StgStableName_NoHdr 8
+#define SIZEOF_StgStableName (SIZEOF_StgHeader+8)
+#define OFFSET_StgStableName_sn 0
+#define REP_StgStableName_sn b64
+#define StgStableName_sn(__ptr__) REP_StgStableName_sn[__ptr__+SIZEOF_StgHeader+OFFSET_StgStableName_sn]
+#define SIZEOF_StgBlockingQueue_NoHdr 32
+#define SIZEOF_StgBlockingQueue (SIZEOF_StgHeader+32)
+#define OFFSET_StgBlockingQueue_bh 8
+#define REP_StgBlockingQueue_bh b64
+#define StgBlockingQueue_bh(__ptr__) REP_StgBlockingQueue_bh[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_bh]
+#define OFFSET_StgBlockingQueue_owner 16
+#define REP_StgBlockingQueue_owner b64
+#define StgBlockingQueue_owner(__ptr__) REP_StgBlockingQueue_owner[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_owner]
+#define OFFSET_StgBlockingQueue_queue 24
+#define REP_StgBlockingQueue_queue b64
+#define StgBlockingQueue_queue(__ptr__) REP_StgBlockingQueue_queue[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_queue]
+#define OFFSET_StgBlockingQueue_link 0
+#define REP_StgBlockingQueue_link b64
+#define StgBlockingQueue_link(__ptr__) REP_StgBlockingQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_link]
+#define SIZEOF_MessageBlackHole_NoHdr 24
+#define SIZEOF_MessageBlackHole (SIZEOF_StgHeader+24)
+#define OFFSET_MessageBlackHole_link 0
+#define REP_MessageBlackHole_link b64
+#define MessageBlackHole_link(__ptr__) REP_MessageBlackHole_link[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_link]
+#define OFFSET_MessageBlackHole_tso 8
+#define REP_MessageBlackHole_tso b64
+#define MessageBlackHole_tso(__ptr__) REP_MessageBlackHole_tso[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_tso]
+#define OFFSET_MessageBlackHole_bh 16
+#define REP_MessageBlackHole_bh b64
+#define MessageBlackHole_bh(__ptr__) REP_MessageBlackHole_bh[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_bh]
+#define SIZEOF_StgCompactNFData_NoHdr 64
+#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+64)
+#define OFFSET_StgCompactNFData_totalW 0
+#define REP_StgCompactNFData_totalW b64
+#define StgCompactNFData_totalW(__ptr__) REP_StgCompactNFData_totalW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_totalW]
+#define OFFSET_StgCompactNFData_autoBlockW 8
+#define REP_StgCompactNFData_autoBlockW b64
+#define StgCompactNFData_autoBlockW(__ptr__) REP_StgCompactNFData_autoBlockW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_autoBlockW]
+#define OFFSET_StgCompactNFData_nursery 32
+#define REP_StgCompactNFData_nursery b64
+#define StgCompactNFData_nursery(__ptr__) REP_StgCompactNFData_nursery[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_nursery]
+#define OFFSET_StgCompactNFData_last 40
+#define REP_StgCompactNFData_last b64
+#define StgCompactNFData_last(__ptr__) REP_StgCompactNFData_last[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_last]
+#define OFFSET_StgCompactNFData_hp 16
+#define REP_StgCompactNFData_hp b64
+#define StgCompactNFData_hp(__ptr__) REP_StgCompactNFData_hp[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hp]
+#define OFFSET_StgCompactNFData_hpLim 24
+#define REP_StgCompactNFData_hpLim b64
+#define StgCompactNFData_hpLim(__ptr__) REP_StgCompactNFData_hpLim[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hpLim]
+#define OFFSET_StgCompactNFData_hash 48
+#define REP_StgCompactNFData_hash b64
+#define StgCompactNFData_hash(__ptr__) REP_StgCompactNFData_hash[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hash]
+#define OFFSET_StgCompactNFData_result 56
+#define REP_StgCompactNFData_result b64
+#define StgCompactNFData_result(__ptr__) REP_StgCompactNFData_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_result]
+#define SIZEOF_StgCompactNFDataBlock 24
+#define OFFSET_StgCompactNFDataBlock_self 0
+#define REP_StgCompactNFDataBlock_self b64
+#define StgCompactNFDataBlock_self(__ptr__) REP_StgCompactNFDataBlock_self[__ptr__+OFFSET_StgCompactNFDataBlock_self]
+#define OFFSET_StgCompactNFDataBlock_owner 8
+#define REP_StgCompactNFDataBlock_owner b64
+#define StgCompactNFDataBlock_owner(__ptr__) REP_StgCompactNFDataBlock_owner[__ptr__+OFFSET_StgCompactNFDataBlock_owner]
+#define OFFSET_StgCompactNFDataBlock_next 16
+#define REP_StgCompactNFDataBlock_next b64
+#define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]
+#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 269
+#define REP_RtsFlags_ProfFlags_showCCSOnException b8
+#define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]
+#define OFFSET_RtsFlags_DebugFlags_apply 210
+#define REP_RtsFlags_DebugFlags_apply b8
+#define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]
+#define OFFSET_RtsFlags_DebugFlags_sanity 206
+#define REP_RtsFlags_DebugFlags_sanity b8
+#define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]
+#define OFFSET_RtsFlags_DebugFlags_weak 202
+#define REP_RtsFlags_DebugFlags_weak b8
+#define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak]
+#define OFFSET_RtsFlags_GcFlags_initialStkSize 16
+#define REP_RtsFlags_GcFlags_initialStkSize b32
+#define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize]
+#define OFFSET_RtsFlags_MiscFlags_tickInterval 176
+#define REP_RtsFlags_MiscFlags_tickInterval b64
+#define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval]
+#define SIZEOF_StgFunInfoExtraFwd 32
+#define OFFSET_StgFunInfoExtraFwd_slow_apply 24
+#define REP_StgFunInfoExtraFwd_slow_apply b64
+#define StgFunInfoExtraFwd_slow_apply(__ptr__) REP_StgFunInfoExtraFwd_slow_apply[__ptr__+OFFSET_StgFunInfoExtraFwd_slow_apply]
+#define OFFSET_StgFunInfoExtraFwd_fun_type 0
+#define REP_StgFunInfoExtraFwd_fun_type b32
+#define StgFunInfoExtraFwd_fun_type(__ptr__) REP_StgFunInfoExtraFwd_fun_type[__ptr__+OFFSET_StgFunInfoExtraFwd_fun_type]
+#define OFFSET_StgFunInfoExtraFwd_arity 4
+#define REP_StgFunInfoExtraFwd_arity b32
+#define StgFunInfoExtraFwd_arity(__ptr__) REP_StgFunInfoExtraFwd_arity[__ptr__+OFFSET_StgFunInfoExtraFwd_arity]
+#define OFFSET_StgFunInfoExtraFwd_bitmap 16
+#define REP_StgFunInfoExtraFwd_bitmap b64
+#define StgFunInfoExtraFwd_bitmap(__ptr__) REP_StgFunInfoExtraFwd_bitmap[__ptr__+OFFSET_StgFunInfoExtraFwd_bitmap]
+#define SIZEOF_StgFunInfoExtraRev 24
+#define OFFSET_StgFunInfoExtraRev_slow_apply_offset 0
+#define REP_StgFunInfoExtraRev_slow_apply_offset b32
+#define StgFunInfoExtraRev_slow_apply_offset(__ptr__) REP_StgFunInfoExtraRev_slow_apply_offset[__ptr__+OFFSET_StgFunInfoExtraRev_slow_apply_offset]
+#define OFFSET_StgFunInfoExtraRev_fun_type 16
+#define REP_StgFunInfoExtraRev_fun_type b32
+#define StgFunInfoExtraRev_fun_type(__ptr__) REP_StgFunInfoExtraRev_fun_type[__ptr__+OFFSET_StgFunInfoExtraRev_fun_type]
+#define OFFSET_StgFunInfoExtraRev_arity 20
+#define REP_StgFunInfoExtraRev_arity b32
+#define StgFunInfoExtraRev_arity(__ptr__) REP_StgFunInfoExtraRev_arity[__ptr__+OFFSET_StgFunInfoExtraRev_arity]
+#define OFFSET_StgFunInfoExtraRev_bitmap 8
+#define REP_StgFunInfoExtraRev_bitmap b64
+#define StgFunInfoExtraRev_bitmap(__ptr__) REP_StgFunInfoExtraRev_bitmap[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap]
+#define OFFSET_StgFunInfoExtraRev_bitmap_offset 8
+#define REP_StgFunInfoExtraRev_bitmap_offset b32
+#define StgFunInfoExtraRev_bitmap_offset(__ptr__) REP_StgFunInfoExtraRev_bitmap_offset[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap_offset]
+#define OFFSET_StgLargeBitmap_size 0
+#define REP_StgLargeBitmap_size b64
+#define StgLargeBitmap_size(__ptr__) REP_StgLargeBitmap_size[__ptr__+OFFSET_StgLargeBitmap_size]
+#define OFFSET_StgLargeBitmap_bitmap 8
+#define SIZEOF_snEntry 24
+#define OFFSET_snEntry_sn_obj 16
+#define REP_snEntry_sn_obj b64
+#define snEntry_sn_obj(__ptr__) REP_snEntry_sn_obj[__ptr__+OFFSET_snEntry_sn_obj]
+#define OFFSET_snEntry_addr 0
+#define REP_snEntry_addr b64
+#define snEntry_addr(__ptr__) REP_snEntry_addr[__ptr__+OFFSET_snEntry_addr]
+#define SIZEOF_spEntry 8
+#define OFFSET_spEntry_addr 0
+#define REP_spEntry_addr b64
+#define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr]
diff --git a/ghc-lib/generated/GHCConstantsHaskellExports.hs b/ghc-lib/generated/GHCConstantsHaskellExports.hs
new file mode 100644
--- /dev/null
+++ b/ghc-lib/generated/GHCConstantsHaskellExports.hs
@@ -0,0 +1,125 @@
+    cONTROL_GROUP_CONST_291,
+    sTD_HDR_SIZE,
+    pROF_HDR_SIZE,
+    bLOCK_SIZE,
+    bLOCKS_PER_MBLOCK,
+    tICKY_BIN_COUNT,
+    oFFSET_StgRegTable_rR1,
+    oFFSET_StgRegTable_rR2,
+    oFFSET_StgRegTable_rR3,
+    oFFSET_StgRegTable_rR4,
+    oFFSET_StgRegTable_rR5,
+    oFFSET_StgRegTable_rR6,
+    oFFSET_StgRegTable_rR7,
+    oFFSET_StgRegTable_rR8,
+    oFFSET_StgRegTable_rR9,
+    oFFSET_StgRegTable_rR10,
+    oFFSET_StgRegTable_rF1,
+    oFFSET_StgRegTable_rF2,
+    oFFSET_StgRegTable_rF3,
+    oFFSET_StgRegTable_rF4,
+    oFFSET_StgRegTable_rF5,
+    oFFSET_StgRegTable_rF6,
+    oFFSET_StgRegTable_rD1,
+    oFFSET_StgRegTable_rD2,
+    oFFSET_StgRegTable_rD3,
+    oFFSET_StgRegTable_rD4,
+    oFFSET_StgRegTable_rD5,
+    oFFSET_StgRegTable_rD6,
+    oFFSET_StgRegTable_rXMM1,
+    oFFSET_StgRegTable_rXMM2,
+    oFFSET_StgRegTable_rXMM3,
+    oFFSET_StgRegTable_rXMM4,
+    oFFSET_StgRegTable_rXMM5,
+    oFFSET_StgRegTable_rXMM6,
+    oFFSET_StgRegTable_rYMM1,
+    oFFSET_StgRegTable_rYMM2,
+    oFFSET_StgRegTable_rYMM3,
+    oFFSET_StgRegTable_rYMM4,
+    oFFSET_StgRegTable_rYMM5,
+    oFFSET_StgRegTable_rYMM6,
+    oFFSET_StgRegTable_rZMM1,
+    oFFSET_StgRegTable_rZMM2,
+    oFFSET_StgRegTable_rZMM3,
+    oFFSET_StgRegTable_rZMM4,
+    oFFSET_StgRegTable_rZMM5,
+    oFFSET_StgRegTable_rZMM6,
+    oFFSET_StgRegTable_rL1,
+    oFFSET_StgRegTable_rSp,
+    oFFSET_StgRegTable_rSpLim,
+    oFFSET_StgRegTable_rHp,
+    oFFSET_StgRegTable_rHpLim,
+    oFFSET_StgRegTable_rCCCS,
+    oFFSET_StgRegTable_rCurrentTSO,
+    oFFSET_StgRegTable_rCurrentNursery,
+    oFFSET_StgRegTable_rHpAlloc,
+    oFFSET_stgEagerBlackholeInfo,
+    oFFSET_stgGCEnter1,
+    oFFSET_stgGCFun,
+    oFFSET_Capability_r,
+    oFFSET_bdescr_start,
+    oFFSET_bdescr_free,
+    oFFSET_bdescr_blocks,
+    oFFSET_bdescr_flags,
+    sIZEOF_CostCentreStack,
+    oFFSET_CostCentreStack_mem_alloc,
+    oFFSET_CostCentreStack_scc_count,
+    oFFSET_StgHeader_ccs,
+    oFFSET_StgHeader_ldvw,
+    sIZEOF_StgSMPThunkHeader,
+    oFFSET_StgEntCounter_allocs,
+    oFFSET_StgEntCounter_allocd,
+    oFFSET_StgEntCounter_registeredp,
+    oFFSET_StgEntCounter_link,
+    oFFSET_StgEntCounter_entry_count,
+    sIZEOF_StgUpdateFrame_NoHdr,
+    sIZEOF_StgMutArrPtrs_NoHdr,
+    oFFSET_StgMutArrPtrs_ptrs,
+    oFFSET_StgMutArrPtrs_size,
+    sIZEOF_StgSmallMutArrPtrs_NoHdr,
+    oFFSET_StgSmallMutArrPtrs_ptrs,
+    sIZEOF_StgArrBytes_NoHdr,
+    oFFSET_StgArrBytes_bytes,
+    oFFSET_StgTSO_alloc_limit,
+    oFFSET_StgTSO_cccs,
+    oFFSET_StgTSO_stackobj,
+    oFFSET_StgStack_sp,
+    oFFSET_StgStack_stack,
+    oFFSET_StgUpdateFrame_updatee,
+    oFFSET_StgFunInfoExtraFwd_arity,
+    sIZEOF_StgFunInfoExtraRev,
+    oFFSET_StgFunInfoExtraRev_arity,
+    mAX_SPEC_SELECTEE_SIZE,
+    mAX_SPEC_AP_SIZE,
+    mIN_PAYLOAD_SIZE,
+    mIN_INTLIKE,
+    mAX_INTLIKE,
+    mIN_CHARLIKE,
+    mAX_CHARLIKE,
+    mUT_ARR_PTRS_CARD_BITS,
+    mAX_Vanilla_REG,
+    mAX_Float_REG,
+    mAX_Double_REG,
+    mAX_Long_REG,
+    mAX_XMM_REG,
+    mAX_Real_Vanilla_REG,
+    mAX_Real_Float_REG,
+    mAX_Real_Double_REG,
+    mAX_Real_XMM_REG,
+    mAX_Real_Long_REG,
+    rESERVED_C_STACK_BYTES,
+    rESERVED_STACK_WORDS,
+    aP_STACK_SPLIM,
+    wORD_SIZE,
+    dOUBLE_SIZE,
+    cINT_SIZE,
+    cLONG_SIZE,
+    cLONG_LONG_SIZE,
+    bITMAP_BITS_SHIFT,
+    tAG_BITS,
+    wORDS_BIGENDIAN,
+    dYNAMIC_BY_DEFAULT,
+    lDV_SHIFT,
+    iLDV_CREATE_MASK,
+    iLDV_STATE_CREATE,
+    iLDV_STATE_USE,
diff --git a/ghc-lib/generated/GHCConstantsHaskellType.hs b/ghc-lib/generated/GHCConstantsHaskellType.hs
new file mode 100644
--- /dev/null
+++ b/ghc-lib/generated/GHCConstantsHaskellType.hs
@@ -0,0 +1,134 @@
+data PlatformConstants = PlatformConstants {
+    pc_platformConstants :: ()
+    , pc_CONTROL_GROUP_CONST_291 :: Int
+    , pc_STD_HDR_SIZE :: Int
+    , pc_PROF_HDR_SIZE :: Int
+    , pc_BLOCK_SIZE :: Int
+    , pc_BLOCKS_PER_MBLOCK :: Int
+    , pc_TICKY_BIN_COUNT :: Int
+    , pc_OFFSET_StgRegTable_rR1 :: Int
+    , pc_OFFSET_StgRegTable_rR2 :: Int
+    , pc_OFFSET_StgRegTable_rR3 :: Int
+    , pc_OFFSET_StgRegTable_rR4 :: Int
+    , pc_OFFSET_StgRegTable_rR5 :: Int
+    , pc_OFFSET_StgRegTable_rR6 :: Int
+    , pc_OFFSET_StgRegTable_rR7 :: Int
+    , pc_OFFSET_StgRegTable_rR8 :: Int
+    , pc_OFFSET_StgRegTable_rR9 :: Int
+    , pc_OFFSET_StgRegTable_rR10 :: Int
+    , pc_OFFSET_StgRegTable_rF1 :: Int
+    , pc_OFFSET_StgRegTable_rF2 :: Int
+    , pc_OFFSET_StgRegTable_rF3 :: Int
+    , pc_OFFSET_StgRegTable_rF4 :: Int
+    , pc_OFFSET_StgRegTable_rF5 :: Int
+    , pc_OFFSET_StgRegTable_rF6 :: Int
+    , pc_OFFSET_StgRegTable_rD1 :: Int
+    , pc_OFFSET_StgRegTable_rD2 :: Int
+    , pc_OFFSET_StgRegTable_rD3 :: Int
+    , pc_OFFSET_StgRegTable_rD4 :: Int
+    , pc_OFFSET_StgRegTable_rD5 :: Int
+    , pc_OFFSET_StgRegTable_rD6 :: Int
+    , pc_OFFSET_StgRegTable_rXMM1 :: Int
+    , pc_OFFSET_StgRegTable_rXMM2 :: Int
+    , pc_OFFSET_StgRegTable_rXMM3 :: Int
+    , pc_OFFSET_StgRegTable_rXMM4 :: Int
+    , pc_OFFSET_StgRegTable_rXMM5 :: Int
+    , pc_OFFSET_StgRegTable_rXMM6 :: Int
+    , pc_OFFSET_StgRegTable_rYMM1 :: Int
+    , pc_OFFSET_StgRegTable_rYMM2 :: Int
+    , pc_OFFSET_StgRegTable_rYMM3 :: Int
+    , pc_OFFSET_StgRegTable_rYMM4 :: Int
+    , pc_OFFSET_StgRegTable_rYMM5 :: Int
+    , pc_OFFSET_StgRegTable_rYMM6 :: Int
+    , pc_OFFSET_StgRegTable_rZMM1 :: Int
+    , pc_OFFSET_StgRegTable_rZMM2 :: Int
+    , pc_OFFSET_StgRegTable_rZMM3 :: Int
+    , pc_OFFSET_StgRegTable_rZMM4 :: Int
+    , pc_OFFSET_StgRegTable_rZMM5 :: Int
+    , pc_OFFSET_StgRegTable_rZMM6 :: Int
+    , pc_OFFSET_StgRegTable_rL1 :: Int
+    , pc_OFFSET_StgRegTable_rSp :: Int
+    , pc_OFFSET_StgRegTable_rSpLim :: Int
+    , pc_OFFSET_StgRegTable_rHp :: Int
+    , pc_OFFSET_StgRegTable_rHpLim :: Int
+    , pc_OFFSET_StgRegTable_rCCCS :: Int
+    , pc_OFFSET_StgRegTable_rCurrentTSO :: Int
+    , pc_OFFSET_StgRegTable_rCurrentNursery :: Int
+    , pc_OFFSET_StgRegTable_rHpAlloc :: Int
+    , pc_OFFSET_stgEagerBlackholeInfo :: Int
+    , pc_OFFSET_stgGCEnter1 :: Int
+    , pc_OFFSET_stgGCFun :: Int
+    , pc_OFFSET_Capability_r :: Int
+    , pc_OFFSET_bdescr_start :: Int
+    , pc_OFFSET_bdescr_free :: Int
+    , pc_OFFSET_bdescr_blocks :: Int
+    , pc_OFFSET_bdescr_flags :: Int
+    , pc_SIZEOF_CostCentreStack :: Int
+    , pc_OFFSET_CostCentreStack_mem_alloc :: Int
+    , pc_REP_CostCentreStack_mem_alloc :: Int
+    , pc_OFFSET_CostCentreStack_scc_count :: Int
+    , pc_REP_CostCentreStack_scc_count :: Int
+    , pc_OFFSET_StgHeader_ccs :: Int
+    , pc_OFFSET_StgHeader_ldvw :: Int
+    , pc_SIZEOF_StgSMPThunkHeader :: Int
+    , pc_OFFSET_StgEntCounter_allocs :: Int
+    , pc_REP_StgEntCounter_allocs :: Int
+    , pc_OFFSET_StgEntCounter_allocd :: Int
+    , pc_REP_StgEntCounter_allocd :: Int
+    , pc_OFFSET_StgEntCounter_registeredp :: Int
+    , pc_OFFSET_StgEntCounter_link :: Int
+    , pc_OFFSET_StgEntCounter_entry_count :: Int
+    , pc_SIZEOF_StgUpdateFrame_NoHdr :: Int
+    , pc_SIZEOF_StgMutArrPtrs_NoHdr :: Int
+    , pc_OFFSET_StgMutArrPtrs_ptrs :: Int
+    , pc_OFFSET_StgMutArrPtrs_size :: Int
+    , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: Int
+    , pc_OFFSET_StgSmallMutArrPtrs_ptrs :: Int
+    , pc_SIZEOF_StgArrBytes_NoHdr :: Int
+    , pc_OFFSET_StgArrBytes_bytes :: Int
+    , pc_OFFSET_StgTSO_alloc_limit :: Int
+    , pc_OFFSET_StgTSO_cccs :: Int
+    , pc_OFFSET_StgTSO_stackobj :: Int
+    , pc_OFFSET_StgStack_sp :: Int
+    , pc_OFFSET_StgStack_stack :: Int
+    , pc_OFFSET_StgUpdateFrame_updatee :: Int
+    , pc_OFFSET_StgFunInfoExtraFwd_arity :: Int
+    , pc_REP_StgFunInfoExtraFwd_arity :: Int
+    , pc_SIZEOF_StgFunInfoExtraRev :: Int
+    , pc_OFFSET_StgFunInfoExtraRev_arity :: Int
+    , pc_REP_StgFunInfoExtraRev_arity :: Int
+    , pc_MAX_SPEC_SELECTEE_SIZE :: Int
+    , pc_MAX_SPEC_AP_SIZE :: Int
+    , pc_MIN_PAYLOAD_SIZE :: Int
+    , pc_MIN_INTLIKE :: Int
+    , pc_MAX_INTLIKE :: Int
+    , pc_MIN_CHARLIKE :: Int
+    , pc_MAX_CHARLIKE :: Int
+    , pc_MUT_ARR_PTRS_CARD_BITS :: Int
+    , pc_MAX_Vanilla_REG :: Int
+    , pc_MAX_Float_REG :: Int
+    , pc_MAX_Double_REG :: Int
+    , pc_MAX_Long_REG :: Int
+    , pc_MAX_XMM_REG :: Int
+    , pc_MAX_Real_Vanilla_REG :: Int
+    , pc_MAX_Real_Float_REG :: Int
+    , pc_MAX_Real_Double_REG :: Int
+    , pc_MAX_Real_XMM_REG :: Int
+    , pc_MAX_Real_Long_REG :: Int
+    , pc_RESERVED_C_STACK_BYTES :: Int
+    , pc_RESERVED_STACK_WORDS :: Int
+    , pc_AP_STACK_SPLIM :: Int
+    , pc_WORD_SIZE :: Int
+    , pc_DOUBLE_SIZE :: Int
+    , pc_CINT_SIZE :: Int
+    , pc_CLONG_SIZE :: Int
+    , pc_CLONG_LONG_SIZE :: Int
+    , pc_BITMAP_BITS_SHIFT :: Int
+    , pc_TAG_BITS :: Int
+    , pc_WORDS_BIGENDIAN :: Bool
+    , pc_DYNAMIC_BY_DEFAULT :: Bool
+    , pc_LDV_SHIFT :: Int
+    , pc_ILDV_CREATE_MASK :: Integer
+    , pc_ILDV_STATE_CREATE :: Integer
+    , pc_ILDV_STATE_USE :: Integer
+  } deriving Read
diff --git a/ghc-lib/generated/GHCConstantsHaskellWrappers.hs b/ghc-lib/generated/GHCConstantsHaskellWrappers.hs
new file mode 100644
--- /dev/null
+++ b/ghc-lib/generated/GHCConstantsHaskellWrappers.hs
@@ -0,0 +1,250 @@
+cONTROL_GROUP_CONST_291 :: DynFlags -> Int
+cONTROL_GROUP_CONST_291 dflags = pc_CONTROL_GROUP_CONST_291 (sPlatformConstants (settings dflags))
+sTD_HDR_SIZE :: DynFlags -> Int
+sTD_HDR_SIZE dflags = pc_STD_HDR_SIZE (sPlatformConstants (settings dflags))
+pROF_HDR_SIZE :: DynFlags -> Int
+pROF_HDR_SIZE dflags = pc_PROF_HDR_SIZE (sPlatformConstants (settings dflags))
+bLOCK_SIZE :: DynFlags -> Int
+bLOCK_SIZE dflags = pc_BLOCK_SIZE (sPlatformConstants (settings dflags))
+bLOCKS_PER_MBLOCK :: DynFlags -> Int
+bLOCKS_PER_MBLOCK dflags = pc_BLOCKS_PER_MBLOCK (sPlatformConstants (settings dflags))
+tICKY_BIN_COUNT :: DynFlags -> Int
+tICKY_BIN_COUNT dflags = pc_TICKY_BIN_COUNT (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR1 :: DynFlags -> Int
+oFFSET_StgRegTable_rR1 dflags = pc_OFFSET_StgRegTable_rR1 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR2 :: DynFlags -> Int
+oFFSET_StgRegTable_rR2 dflags = pc_OFFSET_StgRegTable_rR2 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR3 :: DynFlags -> Int
+oFFSET_StgRegTable_rR3 dflags = pc_OFFSET_StgRegTable_rR3 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR4 :: DynFlags -> Int
+oFFSET_StgRegTable_rR4 dflags = pc_OFFSET_StgRegTable_rR4 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR5 :: DynFlags -> Int
+oFFSET_StgRegTable_rR5 dflags = pc_OFFSET_StgRegTable_rR5 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR6 :: DynFlags -> Int
+oFFSET_StgRegTable_rR6 dflags = pc_OFFSET_StgRegTable_rR6 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR7 :: DynFlags -> Int
+oFFSET_StgRegTable_rR7 dflags = pc_OFFSET_StgRegTable_rR7 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR8 :: DynFlags -> Int
+oFFSET_StgRegTable_rR8 dflags = pc_OFFSET_StgRegTable_rR8 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR9 :: DynFlags -> Int
+oFFSET_StgRegTable_rR9 dflags = pc_OFFSET_StgRegTable_rR9 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rR10 :: DynFlags -> Int
+oFFSET_StgRegTable_rR10 dflags = pc_OFFSET_StgRegTable_rR10 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rF1 :: DynFlags -> Int
+oFFSET_StgRegTable_rF1 dflags = pc_OFFSET_StgRegTable_rF1 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rF2 :: DynFlags -> Int
+oFFSET_StgRegTable_rF2 dflags = pc_OFFSET_StgRegTable_rF2 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rF3 :: DynFlags -> Int
+oFFSET_StgRegTable_rF3 dflags = pc_OFFSET_StgRegTable_rF3 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rF4 :: DynFlags -> Int
+oFFSET_StgRegTable_rF4 dflags = pc_OFFSET_StgRegTable_rF4 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rF5 :: DynFlags -> Int
+oFFSET_StgRegTable_rF5 dflags = pc_OFFSET_StgRegTable_rF5 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rF6 :: DynFlags -> Int
+oFFSET_StgRegTable_rF6 dflags = pc_OFFSET_StgRegTable_rF6 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rD1 :: DynFlags -> Int
+oFFSET_StgRegTable_rD1 dflags = pc_OFFSET_StgRegTable_rD1 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rD2 :: DynFlags -> Int
+oFFSET_StgRegTable_rD2 dflags = pc_OFFSET_StgRegTable_rD2 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rD3 :: DynFlags -> Int
+oFFSET_StgRegTable_rD3 dflags = pc_OFFSET_StgRegTable_rD3 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rD4 :: DynFlags -> Int
+oFFSET_StgRegTable_rD4 dflags = pc_OFFSET_StgRegTable_rD4 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rD5 :: DynFlags -> Int
+oFFSET_StgRegTable_rD5 dflags = pc_OFFSET_StgRegTable_rD5 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rD6 :: DynFlags -> Int
+oFFSET_StgRegTable_rD6 dflags = pc_OFFSET_StgRegTable_rD6 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rXMM1 :: DynFlags -> Int
+oFFSET_StgRegTable_rXMM1 dflags = pc_OFFSET_StgRegTable_rXMM1 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rXMM2 :: DynFlags -> Int
+oFFSET_StgRegTable_rXMM2 dflags = pc_OFFSET_StgRegTable_rXMM2 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rXMM3 :: DynFlags -> Int
+oFFSET_StgRegTable_rXMM3 dflags = pc_OFFSET_StgRegTable_rXMM3 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rXMM4 :: DynFlags -> Int
+oFFSET_StgRegTable_rXMM4 dflags = pc_OFFSET_StgRegTable_rXMM4 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rXMM5 :: DynFlags -> Int
+oFFSET_StgRegTable_rXMM5 dflags = pc_OFFSET_StgRegTable_rXMM5 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rXMM6 :: DynFlags -> Int
+oFFSET_StgRegTable_rXMM6 dflags = pc_OFFSET_StgRegTable_rXMM6 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rYMM1 :: DynFlags -> Int
+oFFSET_StgRegTable_rYMM1 dflags = pc_OFFSET_StgRegTable_rYMM1 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rYMM2 :: DynFlags -> Int
+oFFSET_StgRegTable_rYMM2 dflags = pc_OFFSET_StgRegTable_rYMM2 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rYMM3 :: DynFlags -> Int
+oFFSET_StgRegTable_rYMM3 dflags = pc_OFFSET_StgRegTable_rYMM3 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rYMM4 :: DynFlags -> Int
+oFFSET_StgRegTable_rYMM4 dflags = pc_OFFSET_StgRegTable_rYMM4 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rYMM5 :: DynFlags -> Int
+oFFSET_StgRegTable_rYMM5 dflags = pc_OFFSET_StgRegTable_rYMM5 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rYMM6 :: DynFlags -> Int
+oFFSET_StgRegTable_rYMM6 dflags = pc_OFFSET_StgRegTable_rYMM6 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rZMM1 :: DynFlags -> Int
+oFFSET_StgRegTable_rZMM1 dflags = pc_OFFSET_StgRegTable_rZMM1 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rZMM2 :: DynFlags -> Int
+oFFSET_StgRegTable_rZMM2 dflags = pc_OFFSET_StgRegTable_rZMM2 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rZMM3 :: DynFlags -> Int
+oFFSET_StgRegTable_rZMM3 dflags = pc_OFFSET_StgRegTable_rZMM3 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rZMM4 :: DynFlags -> Int
+oFFSET_StgRegTable_rZMM4 dflags = pc_OFFSET_StgRegTable_rZMM4 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rZMM5 :: DynFlags -> Int
+oFFSET_StgRegTable_rZMM5 dflags = pc_OFFSET_StgRegTable_rZMM5 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rZMM6 :: DynFlags -> Int
+oFFSET_StgRegTable_rZMM6 dflags = pc_OFFSET_StgRegTable_rZMM6 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rL1 :: DynFlags -> Int
+oFFSET_StgRegTable_rL1 dflags = pc_OFFSET_StgRegTable_rL1 (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rSp :: DynFlags -> Int
+oFFSET_StgRegTable_rSp dflags = pc_OFFSET_StgRegTable_rSp (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rSpLim :: DynFlags -> Int
+oFFSET_StgRegTable_rSpLim dflags = pc_OFFSET_StgRegTable_rSpLim (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rHp :: DynFlags -> Int
+oFFSET_StgRegTable_rHp dflags = pc_OFFSET_StgRegTable_rHp (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rHpLim :: DynFlags -> Int
+oFFSET_StgRegTable_rHpLim dflags = pc_OFFSET_StgRegTable_rHpLim (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rCCCS :: DynFlags -> Int
+oFFSET_StgRegTable_rCCCS dflags = pc_OFFSET_StgRegTable_rCCCS (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rCurrentTSO :: DynFlags -> Int
+oFFSET_StgRegTable_rCurrentTSO dflags = pc_OFFSET_StgRegTable_rCurrentTSO (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rCurrentNursery :: DynFlags -> Int
+oFFSET_StgRegTable_rCurrentNursery dflags = pc_OFFSET_StgRegTable_rCurrentNursery (sPlatformConstants (settings dflags))
+oFFSET_StgRegTable_rHpAlloc :: DynFlags -> Int
+oFFSET_StgRegTable_rHpAlloc dflags = pc_OFFSET_StgRegTable_rHpAlloc (sPlatformConstants (settings dflags))
+oFFSET_stgEagerBlackholeInfo :: DynFlags -> Int
+oFFSET_stgEagerBlackholeInfo dflags = pc_OFFSET_stgEagerBlackholeInfo (sPlatformConstants (settings dflags))
+oFFSET_stgGCEnter1 :: DynFlags -> Int
+oFFSET_stgGCEnter1 dflags = pc_OFFSET_stgGCEnter1 (sPlatformConstants (settings dflags))
+oFFSET_stgGCFun :: DynFlags -> Int
+oFFSET_stgGCFun dflags = pc_OFFSET_stgGCFun (sPlatformConstants (settings dflags))
+oFFSET_Capability_r :: DynFlags -> Int
+oFFSET_Capability_r dflags = pc_OFFSET_Capability_r (sPlatformConstants (settings dflags))
+oFFSET_bdescr_start :: DynFlags -> Int
+oFFSET_bdescr_start dflags = pc_OFFSET_bdescr_start (sPlatformConstants (settings dflags))
+oFFSET_bdescr_free :: DynFlags -> Int
+oFFSET_bdescr_free dflags = pc_OFFSET_bdescr_free (sPlatformConstants (settings dflags))
+oFFSET_bdescr_blocks :: DynFlags -> Int
+oFFSET_bdescr_blocks dflags = pc_OFFSET_bdescr_blocks (sPlatformConstants (settings dflags))
+oFFSET_bdescr_flags :: DynFlags -> Int
+oFFSET_bdescr_flags dflags = pc_OFFSET_bdescr_flags (sPlatformConstants (settings dflags))
+sIZEOF_CostCentreStack :: DynFlags -> Int
+sIZEOF_CostCentreStack dflags = pc_SIZEOF_CostCentreStack (sPlatformConstants (settings dflags))
+oFFSET_CostCentreStack_mem_alloc :: DynFlags -> Int
+oFFSET_CostCentreStack_mem_alloc dflags = pc_OFFSET_CostCentreStack_mem_alloc (sPlatformConstants (settings dflags))
+oFFSET_CostCentreStack_scc_count :: DynFlags -> Int
+oFFSET_CostCentreStack_scc_count dflags = pc_OFFSET_CostCentreStack_scc_count (sPlatformConstants (settings dflags))
+oFFSET_StgHeader_ccs :: DynFlags -> Int
+oFFSET_StgHeader_ccs dflags = pc_OFFSET_StgHeader_ccs (sPlatformConstants (settings dflags))
+oFFSET_StgHeader_ldvw :: DynFlags -> Int
+oFFSET_StgHeader_ldvw dflags = pc_OFFSET_StgHeader_ldvw (sPlatformConstants (settings dflags))
+sIZEOF_StgSMPThunkHeader :: DynFlags -> Int
+sIZEOF_StgSMPThunkHeader dflags = pc_SIZEOF_StgSMPThunkHeader (sPlatformConstants (settings dflags))
+oFFSET_StgEntCounter_allocs :: DynFlags -> Int
+oFFSET_StgEntCounter_allocs dflags = pc_OFFSET_StgEntCounter_allocs (sPlatformConstants (settings dflags))
+oFFSET_StgEntCounter_allocd :: DynFlags -> Int
+oFFSET_StgEntCounter_allocd dflags = pc_OFFSET_StgEntCounter_allocd (sPlatformConstants (settings dflags))
+oFFSET_StgEntCounter_registeredp :: DynFlags -> Int
+oFFSET_StgEntCounter_registeredp dflags = pc_OFFSET_StgEntCounter_registeredp (sPlatformConstants (settings dflags))
+oFFSET_StgEntCounter_link :: DynFlags -> Int
+oFFSET_StgEntCounter_link dflags = pc_OFFSET_StgEntCounter_link (sPlatformConstants (settings dflags))
+oFFSET_StgEntCounter_entry_count :: DynFlags -> Int
+oFFSET_StgEntCounter_entry_count dflags = pc_OFFSET_StgEntCounter_entry_count (sPlatformConstants (settings dflags))
+sIZEOF_StgUpdateFrame_NoHdr :: DynFlags -> Int
+sIZEOF_StgUpdateFrame_NoHdr dflags = pc_SIZEOF_StgUpdateFrame_NoHdr (sPlatformConstants (settings dflags))
+sIZEOF_StgMutArrPtrs_NoHdr :: DynFlags -> Int
+sIZEOF_StgMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgMutArrPtrs_NoHdr (sPlatformConstants (settings dflags))
+oFFSET_StgMutArrPtrs_ptrs :: DynFlags -> Int
+oFFSET_StgMutArrPtrs_ptrs dflags = pc_OFFSET_StgMutArrPtrs_ptrs (sPlatformConstants (settings dflags))
+oFFSET_StgMutArrPtrs_size :: DynFlags -> Int
+oFFSET_StgMutArrPtrs_size dflags = pc_OFFSET_StgMutArrPtrs_size (sPlatformConstants (settings dflags))
+sIZEOF_StgSmallMutArrPtrs_NoHdr :: DynFlags -> Int
+sIZEOF_StgSmallMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (sPlatformConstants (settings dflags))
+oFFSET_StgSmallMutArrPtrs_ptrs :: DynFlags -> Int
+oFFSET_StgSmallMutArrPtrs_ptrs dflags = pc_OFFSET_StgSmallMutArrPtrs_ptrs (sPlatformConstants (settings dflags))
+sIZEOF_StgArrBytes_NoHdr :: DynFlags -> Int
+sIZEOF_StgArrBytes_NoHdr dflags = pc_SIZEOF_StgArrBytes_NoHdr (sPlatformConstants (settings dflags))
+oFFSET_StgArrBytes_bytes :: DynFlags -> Int
+oFFSET_StgArrBytes_bytes dflags = pc_OFFSET_StgArrBytes_bytes (sPlatformConstants (settings dflags))
+oFFSET_StgTSO_alloc_limit :: DynFlags -> Int
+oFFSET_StgTSO_alloc_limit dflags = pc_OFFSET_StgTSO_alloc_limit (sPlatformConstants (settings dflags))
+oFFSET_StgTSO_cccs :: DynFlags -> Int
+oFFSET_StgTSO_cccs dflags = pc_OFFSET_StgTSO_cccs (sPlatformConstants (settings dflags))
+oFFSET_StgTSO_stackobj :: DynFlags -> Int
+oFFSET_StgTSO_stackobj dflags = pc_OFFSET_StgTSO_stackobj (sPlatformConstants (settings dflags))
+oFFSET_StgStack_sp :: DynFlags -> Int
+oFFSET_StgStack_sp dflags = pc_OFFSET_StgStack_sp (sPlatformConstants (settings dflags))
+oFFSET_StgStack_stack :: DynFlags -> Int
+oFFSET_StgStack_stack dflags = pc_OFFSET_StgStack_stack (sPlatformConstants (settings dflags))
+oFFSET_StgUpdateFrame_updatee :: DynFlags -> Int
+oFFSET_StgUpdateFrame_updatee dflags = pc_OFFSET_StgUpdateFrame_updatee (sPlatformConstants (settings dflags))
+oFFSET_StgFunInfoExtraFwd_arity :: DynFlags -> Int
+oFFSET_StgFunInfoExtraFwd_arity dflags = pc_OFFSET_StgFunInfoExtraFwd_arity (sPlatformConstants (settings dflags))
+sIZEOF_StgFunInfoExtraRev :: DynFlags -> Int
+sIZEOF_StgFunInfoExtraRev dflags = pc_SIZEOF_StgFunInfoExtraRev (sPlatformConstants (settings dflags))
+oFFSET_StgFunInfoExtraRev_arity :: DynFlags -> Int
+oFFSET_StgFunInfoExtraRev_arity dflags = pc_OFFSET_StgFunInfoExtraRev_arity (sPlatformConstants (settings dflags))
+mAX_SPEC_SELECTEE_SIZE :: DynFlags -> Int
+mAX_SPEC_SELECTEE_SIZE dflags = pc_MAX_SPEC_SELECTEE_SIZE (sPlatformConstants (settings dflags))
+mAX_SPEC_AP_SIZE :: DynFlags -> Int
+mAX_SPEC_AP_SIZE dflags = pc_MAX_SPEC_AP_SIZE (sPlatformConstants (settings dflags))
+mIN_PAYLOAD_SIZE :: DynFlags -> Int
+mIN_PAYLOAD_SIZE dflags = pc_MIN_PAYLOAD_SIZE (sPlatformConstants (settings dflags))
+mIN_INTLIKE :: DynFlags -> Int
+mIN_INTLIKE dflags = pc_MIN_INTLIKE (sPlatformConstants (settings dflags))
+mAX_INTLIKE :: DynFlags -> Int
+mAX_INTLIKE dflags = pc_MAX_INTLIKE (sPlatformConstants (settings dflags))
+mIN_CHARLIKE :: DynFlags -> Int
+mIN_CHARLIKE dflags = pc_MIN_CHARLIKE (sPlatformConstants (settings dflags))
+mAX_CHARLIKE :: DynFlags -> Int
+mAX_CHARLIKE dflags = pc_MAX_CHARLIKE (sPlatformConstants (settings dflags))
+mUT_ARR_PTRS_CARD_BITS :: DynFlags -> Int
+mUT_ARR_PTRS_CARD_BITS dflags = pc_MUT_ARR_PTRS_CARD_BITS (sPlatformConstants (settings dflags))
+mAX_Vanilla_REG :: DynFlags -> Int
+mAX_Vanilla_REG dflags = pc_MAX_Vanilla_REG (sPlatformConstants (settings dflags))
+mAX_Float_REG :: DynFlags -> Int
+mAX_Float_REG dflags = pc_MAX_Float_REG (sPlatformConstants (settings dflags))
+mAX_Double_REG :: DynFlags -> Int
+mAX_Double_REG dflags = pc_MAX_Double_REG (sPlatformConstants (settings dflags))
+mAX_Long_REG :: DynFlags -> Int
+mAX_Long_REG dflags = pc_MAX_Long_REG (sPlatformConstants (settings dflags))
+mAX_XMM_REG :: DynFlags -> Int
+mAX_XMM_REG dflags = pc_MAX_XMM_REG (sPlatformConstants (settings dflags))
+mAX_Real_Vanilla_REG :: DynFlags -> Int
+mAX_Real_Vanilla_REG dflags = pc_MAX_Real_Vanilla_REG (sPlatformConstants (settings dflags))
+mAX_Real_Float_REG :: DynFlags -> Int
+mAX_Real_Float_REG dflags = pc_MAX_Real_Float_REG (sPlatformConstants (settings dflags))
+mAX_Real_Double_REG :: DynFlags -> Int
+mAX_Real_Double_REG dflags = pc_MAX_Real_Double_REG (sPlatformConstants (settings dflags))
+mAX_Real_XMM_REG :: DynFlags -> Int
+mAX_Real_XMM_REG dflags = pc_MAX_Real_XMM_REG (sPlatformConstants (settings dflags))
+mAX_Real_Long_REG :: DynFlags -> Int
+mAX_Real_Long_REG dflags = pc_MAX_Real_Long_REG (sPlatformConstants (settings dflags))
+rESERVED_C_STACK_BYTES :: DynFlags -> Int
+rESERVED_C_STACK_BYTES dflags = pc_RESERVED_C_STACK_BYTES (sPlatformConstants (settings dflags))
+rESERVED_STACK_WORDS :: DynFlags -> Int
+rESERVED_STACK_WORDS dflags = pc_RESERVED_STACK_WORDS (sPlatformConstants (settings dflags))
+aP_STACK_SPLIM :: DynFlags -> Int
+aP_STACK_SPLIM dflags = pc_AP_STACK_SPLIM (sPlatformConstants (settings dflags))
+wORD_SIZE :: DynFlags -> Int
+wORD_SIZE dflags = pc_WORD_SIZE (sPlatformConstants (settings dflags))
+dOUBLE_SIZE :: DynFlags -> Int
+dOUBLE_SIZE dflags = pc_DOUBLE_SIZE (sPlatformConstants (settings dflags))
+cINT_SIZE :: DynFlags -> Int
+cINT_SIZE dflags = pc_CINT_SIZE (sPlatformConstants (settings dflags))
+cLONG_SIZE :: DynFlags -> Int
+cLONG_SIZE dflags = pc_CLONG_SIZE (sPlatformConstants (settings dflags))
+cLONG_LONG_SIZE :: DynFlags -> Int
+cLONG_LONG_SIZE dflags = pc_CLONG_LONG_SIZE (sPlatformConstants (settings dflags))
+bITMAP_BITS_SHIFT :: DynFlags -> Int
+bITMAP_BITS_SHIFT dflags = pc_BITMAP_BITS_SHIFT (sPlatformConstants (settings dflags))
+tAG_BITS :: DynFlags -> Int
+tAG_BITS dflags = pc_TAG_BITS (sPlatformConstants (settings dflags))
+wORDS_BIGENDIAN :: DynFlags -> Bool
+wORDS_BIGENDIAN dflags = pc_WORDS_BIGENDIAN (sPlatformConstants (settings dflags))
+dYNAMIC_BY_DEFAULT :: DynFlags -> Bool
+dYNAMIC_BY_DEFAULT dflags = pc_DYNAMIC_BY_DEFAULT (sPlatformConstants (settings dflags))
+lDV_SHIFT :: DynFlags -> Int
+lDV_SHIFT dflags = pc_LDV_SHIFT (sPlatformConstants (settings dflags))
+iLDV_CREATE_MASK :: DynFlags -> Integer
+iLDV_CREATE_MASK dflags = pc_ILDV_CREATE_MASK (sPlatformConstants (settings dflags))
+iLDV_STATE_CREATE :: DynFlags -> Integer
+iLDV_STATE_CREATE dflags = pc_ILDV_STATE_CREATE (sPlatformConstants (settings dflags))
+iLDV_STATE_USE :: DynFlags -> Integer
+iLDV_STATE_USE dflags = pc_ILDV_STATE_USE (sPlatformConstants (settings dflags))
diff --git a/ghc-lib/generated/ghcautoconf.h b/ghc-lib/generated/ghcautoconf.h
new file mode 100644
--- /dev/null
+++ b/ghc-lib/generated/ghcautoconf.h
@@ -0,0 +1,542 @@
+#ifndef __GHCAUTOCONF_H__
+#define __GHCAUTOCONF_H__
+/* mk/config.h.  Generated from config.h.in by configure.  */
+/* mk/config.h.in.  Generated from configure.ac by autoheader.  */
+
+/* Define if building universal (internal helper macro) */
+/* #undef AC_APPLE_UNIVERSAL_BUILD */
+
+/* The alignment of a `char'. */
+#define ALIGNMENT_CHAR 1
+
+/* The alignment of a `double'. */
+#define ALIGNMENT_DOUBLE 8
+
+/* The alignment of a `float'. */
+#define ALIGNMENT_FLOAT 4
+
+/* The alignment of a `int'. */
+#define ALIGNMENT_INT 4
+
+/* The alignment of a `int16_t'. */
+#define ALIGNMENT_INT16_T 2
+
+/* The alignment of a `int32_t'. */
+#define ALIGNMENT_INT32_T 4
+
+/* The alignment of a `int64_t'. */
+#define ALIGNMENT_INT64_T 8
+
+/* The alignment of a `int8_t'. */
+#define ALIGNMENT_INT8_T 1
+
+/* The alignment of a `long'. */
+#define ALIGNMENT_LONG 8
+
+/* The alignment of a `long long'. */
+#define ALIGNMENT_LONG_LONG 8
+
+/* The alignment of a `short'. */
+#define ALIGNMENT_SHORT 2
+
+/* The alignment of a `uint16_t'. */
+#define ALIGNMENT_UINT16_T 2
+
+/* The alignment of a `uint32_t'. */
+#define ALIGNMENT_UINT32_T 4
+
+/* The alignment of a `uint64_t'. */
+#define ALIGNMENT_UINT64_T 8
+
+/* The alignment of a `uint8_t'. */
+#define ALIGNMENT_UINT8_T 1
+
+/* The alignment of a `unsigned char'. */
+#define ALIGNMENT_UNSIGNED_CHAR 1
+
+/* The alignment of a `unsigned int'. */
+#define ALIGNMENT_UNSIGNED_INT 4
+
+/* The alignment of a `unsigned long'. */
+#define ALIGNMENT_UNSIGNED_LONG 8
+
+/* The alignment of a `unsigned long long'. */
+#define ALIGNMENT_UNSIGNED_LONG_LONG 8
+
+/* The alignment of a `unsigned short'. */
+#define ALIGNMENT_UNSIGNED_SHORT 2
+
+/* The alignment of a `void *'. */
+#define ALIGNMENT_VOID_P 8
+
+/* Define to 1 if __thread is supported */
+#define CC_SUPPORTS_TLS 1
+
+/* Define to one of `_getb67', `GETB67', `getb67' for Cray-2 and Cray-YMP
+   systems. This function is required for `alloca.c' support on those systems.
+   */
+/* #undef CRAY_STACKSEG_END */
+
+/* Define to 1 if using `alloca.c'. */
+/* #undef C_ALLOCA */
+
+/* Define to 1 if your processor stores words of floats with the most
+   significant byte first */
+/* #undef FLOAT_WORDS_BIGENDIAN */
+
+/* Has visibility hidden */
+#define HAS_VISIBILITY_HIDDEN 1
+
+/* Define to 1 if you have `alloca', as a function or macro. */
+#define HAVE_ALLOCA 1
+
+/* Define to 1 if you have <alloca.h> and it should be used (not on Ultrix).
+   */
+#define HAVE_ALLOCA_H 1
+
+/* Define to 1 if you have the <bfd.h> header file. */
+/* #undef HAVE_BFD_H */
+
+/* Does GCC support __atomic primitives? */
+#define HAVE_C11_ATOMICS $CONF_GCC_SUPPORTS__ATOMICS
+
+/* Define to 1 if you have the `clock_gettime' function. */
+#define HAVE_CLOCK_GETTIME 1
+
+/* Define to 1 if you have the `ctime_r' function. */
+#define HAVE_CTIME_R 1
+
+/* Define to 1 if you have the <ctype.h> header file. */
+#define HAVE_CTYPE_H 1
+
+/* Define to 1 if you have the declaration of `ctime_r', and to 0 if you
+   don't. */
+#define HAVE_DECL_CTIME_R 1
+
+/* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you
+   don't. */
+/* #undef HAVE_DECL_MADV_DONTNEED */
+
+/* Define to 1 if you have the declaration of `MADV_FREE', and to 0 if you
+   don't. */
+/* #undef HAVE_DECL_MADV_FREE */
+
+/* Define to 1 if you have the declaration of `MAP_NORESERVE', and to 0 if you
+   don't. */
+/* #undef HAVE_DECL_MAP_NORESERVE */
+
+/* Define to 1 if you have the <dirent.h> header file. */
+#define HAVE_DIRENT_H 1
+
+/* Define to 1 if you have the <dlfcn.h> header file. */
+#define HAVE_DLFCN_H 1
+
+/* Define to 1 if you have the <errno.h> header file. */
+#define HAVE_ERRNO_H 1
+
+/* Define to 1 if you have the `eventfd' function. */
+/* #undef HAVE_EVENTFD */
+
+/* Define to 1 if you have the <fcntl.h> header file. */
+#define HAVE_FCNTL_H 1
+
+/* Define to 1 if you have the <ffi.h> header file. */
+/* #undef HAVE_FFI_H */
+
+/* Define to 1 if you have the `fork' function. */
+#define HAVE_FORK 1
+
+/* Define to 1 if you have the `getclock' function. */
+/* #undef HAVE_GETCLOCK */
+
+/* Define to 1 if you have the `GetModuleFileName' function. */
+/* #undef HAVE_GETMODULEFILENAME */
+
+/* Define to 1 if you have the `getrusage' function. */
+#define HAVE_GETRUSAGE 1
+
+/* Define to 1 if you have the `gettimeofday' function. */
+#define HAVE_GETTIMEOFDAY 1
+
+/* Define to 1 if you have the <grp.h> header file. */
+#define HAVE_GRP_H 1
+
+/* Define to 1 if you have the <inttypes.h> header file. */
+#define HAVE_INTTYPES_H 1
+
+/* Define to 1 if you have the `bfd' library (-lbfd). */
+/* #undef HAVE_LIBBFD */
+
+/* Define to 1 if you have the `dl' library (-ldl). */
+#define HAVE_LIBDL 1
+
+/* Define to 1 if you have libffi. */
+/* #undef HAVE_LIBFFI */
+
+/* Define to 1 if you have the `iberty' library (-liberty). */
+/* #undef HAVE_LIBIBERTY */
+
+/* Define to 1 if you need to link with libm */
+#define HAVE_LIBM 1
+
+/* Define to 1 if you have libnuma */
+#define HAVE_LIBNUMA 0
+
+/* Define to 1 if you have the `pthread' library (-lpthread). */
+#define HAVE_LIBPTHREAD 1
+
+/* Define to 1 if you have the `rt' library (-lrt). */
+/* #undef HAVE_LIBRT */
+
+/* Define to 1 if you have the <limits.h> header file. */
+#define HAVE_LIMITS_H 1
+
+/* Define to 1 if you have the <locale.h> header file. */
+#define HAVE_LOCALE_H 1
+
+/* Define to 1 if the system has the type `long long'. */
+#define HAVE_LONG_LONG 1
+
+/* Define to 1 if you have the <memory.h> header file. */
+#define HAVE_MEMORY_H 1
+
+/* Define to 1 if you have the mingwex library. */
+/* #undef HAVE_MINGWEX */
+
+/* Define to 1 if you have the <nlist.h> header file. */
+#define HAVE_NLIST_H 1
+
+/* Define to 1 if you have the <numaif.h> header file. */
+/* #undef HAVE_NUMAIF_H */
+
+/* Define to 1 if you have the <numa.h> header file. */
+/* #undef HAVE_NUMA_H */
+
+/* Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC). */
+#define HAVE_PRINTF_LDBLSTUB 0
+
+/* Define to 1 if you have the <pthread.h> header file. */
+#define HAVE_PTHREAD_H 1
+
+/* Define to 1 if you have the glibc version of pthread_setname_np */
+/* #undef HAVE_PTHREAD_SETNAME_NP */
+
+/* Define to 1 if you have the <pwd.h> header file. */
+#define HAVE_PWD_H 1
+
+/* Define to 1 if you have the <sched.h> header file. */
+#define HAVE_SCHED_H 1
+
+/* Define to 1 if you have the `sched_setaffinity' function. */
+/* #undef HAVE_SCHED_SETAFFINITY */
+
+/* Define to 1 if you have the `setitimer' function. */
+#define HAVE_SETITIMER 1
+
+/* Define to 1 if you have the `setlocale' function. */
+#define HAVE_SETLOCALE 1
+
+/* Define to 1 if you have the `siginterrupt' function. */
+#define HAVE_SIGINTERRUPT 1
+
+/* Define to 1 if you have the <signal.h> header file. */
+#define HAVE_SIGNAL_H 1
+
+/* Define to 1 if you have the <stdint.h> header file. */
+#define HAVE_STDINT_H 1
+
+/* Define to 1 if you have the <stdlib.h> header file. */
+#define HAVE_STDLIB_H 1
+
+/* Define to 1 if you have the <strings.h> header file. */
+#define HAVE_STRINGS_H 1
+
+/* Define to 1 if you have the <string.h> header file. */
+#define HAVE_STRING_H 1
+
+/* Define to 1 if Apple-style dead-stripping is supported. */
+#define HAVE_SUBSECTIONS_VIA_SYMBOLS 1
+
+/* Define to 1 if you have the `sysconf' function. */
+#define HAVE_SYSCONF 1
+
+/* Define to 1 if you have the <sys/cpuset.h> header file. */
+/* #undef HAVE_SYS_CPUSET_H */
+
+/* Define to 1 if you have the <sys/eventfd.h> header file. */
+/* #undef HAVE_SYS_EVENTFD_H */
+
+/* Define to 1 if you have the <sys/mman.h> header file. */
+#define HAVE_SYS_MMAN_H 1
+
+/* Define to 1 if you have the <sys/param.h> header file. */
+#define HAVE_SYS_PARAM_H 1
+
+/* Define to 1 if you have the <sys/resource.h> header file. */
+#define HAVE_SYS_RESOURCE_H 1
+
+/* Define to 1 if you have the <sys/select.h> header file. */
+#define HAVE_SYS_SELECT_H 1
+
+/* Define to 1 if you have the <sys/stat.h> header file. */
+#define HAVE_SYS_STAT_H 1
+
+/* Define to 1 if you have the <sys/timeb.h> header file. */
+#define HAVE_SYS_TIMEB_H 1
+
+/* Define to 1 if you have the <sys/timerfd.h> header file. */
+/* #undef HAVE_SYS_TIMERFD_H */
+
+/* Define to 1 if you have the <sys/timers.h> header file. */
+/* #undef HAVE_SYS_TIMERS_H */
+
+/* Define to 1 if you have the <sys/times.h> header file. */
+#define HAVE_SYS_TIMES_H 1
+
+/* Define to 1 if you have the <sys/time.h> header file. */
+#define HAVE_SYS_TIME_H 1
+
+/* Define to 1 if you have the <sys/types.h> header file. */
+#define HAVE_SYS_TYPES_H 1
+
+/* Define to 1 if you have the <sys/utsname.h> header file. */
+#define HAVE_SYS_UTSNAME_H 1
+
+/* Define to 1 if you have the <sys/wait.h> header file. */
+#define HAVE_SYS_WAIT_H 1
+
+/* Define to 1 if you have the <termios.h> header file. */
+#define HAVE_TERMIOS_H 1
+
+/* Define to 1 if you have the `timer_settime' function. */
+/* #undef HAVE_TIMER_SETTIME */
+
+/* Define to 1 if you have the `times' function. */
+#define HAVE_TIMES 1
+
+/* Define to 1 if you have the <time.h> header file. */
+#define HAVE_TIME_H 1
+
+/* Define to 1 if you have the <unistd.h> header file. */
+#define HAVE_UNISTD_H 1
+
+/* Define to 1 if you have the <utime.h> header file. */
+#define HAVE_UTIME_H 1
+
+/* Define to 1 if you have the `vfork' function. */
+#define HAVE_VFORK 1
+
+/* Define to 1 if you have the <vfork.h> header file. */
+/* #undef HAVE_VFORK_H */
+
+/* Define to 1 if you have the <windows.h> header file. */
+/* #undef HAVE_WINDOWS_H */
+
+/* Define to 1 if you have the `WinExec' function. */
+/* #undef HAVE_WINEXEC */
+
+/* Define to 1 if you have the <winsock.h> header file. */
+/* #undef HAVE_WINSOCK_H */
+
+/* Define to 1 if `fork' works. */
+#define HAVE_WORKING_FORK 1
+
+/* Define to 1 if `vfork' works. */
+#define HAVE_WORKING_VFORK 1
+
+/* Define to 1 if C symbols have a leading underscore added by the compiler.
+   */
+#define LEADING_UNDERSCORE 1
+
+/* Define 1 if we need to link code using pthreads with -lpthread */
+#define NEED_PTHREAD_LIB 0
+
+/* Define to the address where bug reports for this package should be sent. */
+/* #undef PACKAGE_BUGREPORT */
+
+/* Define to the full name of this package. */
+/* #undef PACKAGE_NAME */
+
+/* Define to the full name and version of this package. */
+/* #undef PACKAGE_STRING */
+
+/* Define to the one symbol short name of this package. */
+/* #undef PACKAGE_TARNAME */
+
+/* Define to the home page for this package. */
+/* #undef PACKAGE_URL */
+
+/* Define to the version of this package. */
+/* #undef PACKAGE_VERSION */
+
+/* Use mmap in the runtime linker */
+#define RTS_LINKER_USE_MMAP 1
+
+/* The size of `char', as computed by sizeof. */
+#define SIZEOF_CHAR 1
+
+/* The size of `double', as computed by sizeof. */
+#define SIZEOF_DOUBLE 8
+
+/* The size of `float', as computed by sizeof. */
+#define SIZEOF_FLOAT 4
+
+/* The size of `int', as computed by sizeof. */
+#define SIZEOF_INT 4
+
+/* The size of `int16_t', as computed by sizeof. */
+#define SIZEOF_INT16_T 2
+
+/* The size of `int32_t', as computed by sizeof. */
+#define SIZEOF_INT32_T 4
+
+/* The size of `int64_t', as computed by sizeof. */
+#define SIZEOF_INT64_T 8
+
+/* The size of `int8_t', as computed by sizeof. */
+#define SIZEOF_INT8_T 1
+
+/* The size of `long', as computed by sizeof. */
+#define SIZEOF_LONG 8
+
+/* The size of `long long', as computed by sizeof. */
+#define SIZEOF_LONG_LONG 8
+
+/* The size of `short', as computed by sizeof. */
+#define SIZEOF_SHORT 2
+
+/* The size of `uint16_t', as computed by sizeof. */
+#define SIZEOF_UINT16_T 2
+
+/* The size of `uint32_t', as computed by sizeof. */
+#define SIZEOF_UINT32_T 4
+
+/* The size of `uint64_t', as computed by sizeof. */
+#define SIZEOF_UINT64_T 8
+
+/* The size of `uint8_t', as computed by sizeof. */
+#define SIZEOF_UINT8_T 1
+
+/* The size of `unsigned char', as computed by sizeof. */
+#define SIZEOF_UNSIGNED_CHAR 1
+
+/* The size of `unsigned int', as computed by sizeof. */
+#define SIZEOF_UNSIGNED_INT 4
+
+/* The size of `unsigned long', as computed by sizeof. */
+#define SIZEOF_UNSIGNED_LONG 8
+
+/* The size of `unsigned long long', as computed by sizeof. */
+#define SIZEOF_UNSIGNED_LONG_LONG 8
+
+/* The size of `unsigned short', as computed by sizeof. */
+#define SIZEOF_UNSIGNED_SHORT 2
+
+/* The size of `void *', as computed by sizeof. */
+#define SIZEOF_VOID_P 8
+
+/* If using the C implementation of alloca, define if you know the
+   direction of stack growth for your system; otherwise it will be
+   automatically deduced at runtime.
+	STACK_DIRECTION > 0 => grows toward higher addresses
+	STACK_DIRECTION < 0 => grows toward lower addresses
+	STACK_DIRECTION = 0 => direction of growth unknown */
+/* #undef STACK_DIRECTION */
+
+/* Define to 1 if you have the ANSI C header files. */
+#define STDC_HEADERS 1
+
+/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */
+#define TIME_WITH_SYS_TIME 1
+
+/* Enable single heap address space support */
+#define USE_LARGE_ADDRESS_SPACE 1
+
+/* Set to 1 to use libdw */
+#define USE_LIBDW 0
+
+/* Enable extensions on AIX 3, Interix.  */
+#ifndef _ALL_SOURCE
+# define _ALL_SOURCE 1
+#endif
+/* Enable GNU extensions on systems that have them.  */
+#ifndef _GNU_SOURCE
+# define _GNU_SOURCE 1
+#endif
+/* Enable threading extensions on Solaris.  */
+#ifndef _POSIX_PTHREAD_SEMANTICS
+# define _POSIX_PTHREAD_SEMANTICS 1
+#endif
+/* Enable extensions on HP NonStop.  */
+#ifndef _TANDEM_SOURCE
+# define _TANDEM_SOURCE 1
+#endif
+/* Enable general extensions on Solaris.  */
+#ifndef __EXTENSIONS__
+# define __EXTENSIONS__ 1
+#endif
+
+
+/* Define to 1 if we can use timer_create(CLOCK_REALTIME,...) */
+/* #undef USE_TIMER_CREATE */
+
+/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most
+   significant byte first (like Motorola and SPARC, unlike Intel). */
+#if defined AC_APPLE_UNIVERSAL_BUILD
+# if defined __BIG_ENDIAN__
+#  define WORDS_BIGENDIAN 1
+# endif
+#else
+# ifndef WORDS_BIGENDIAN
+/* #  undef WORDS_BIGENDIAN */
+# endif
+#endif
+
+/* Enable large inode numbers on Mac OS X 10.5.  */
+#ifndef _DARWIN_USE_64_BIT_INODE
+# define _DARWIN_USE_64_BIT_INODE 1
+#endif
+
+/* Number of bits in a file offset, on hosts where this is settable. */
+/* #undef _FILE_OFFSET_BITS */
+
+/* Define for large files, on AIX-style hosts. */
+/* #undef _LARGE_FILES */
+
+/* Define to 1 if on MINIX. */
+/* #undef _MINIX */
+
+/* Define to 2 if the system does not provide POSIX.1 features except with
+   this defined. */
+/* #undef _POSIX_1_SOURCE */
+
+/* Define to 1 if you need to in order for `stat' and other things to work. */
+/* #undef _POSIX_SOURCE */
+
+/* ARM pre v6 */
+/* #undef arm_HOST_ARCH_PRE_ARMv6 */
+
+/* ARM pre v7 */
+/* #undef arm_HOST_ARCH_PRE_ARMv7 */
+
+/* Define to empty if `const' does not conform to ANSI C. */
+/* #undef const */
+
+/* Define to `int' if <sys/types.h> does not define. */
+/* #undef pid_t */
+
+/* The supported LLVM version number */
+#define sUPPORTED_LLVM_VERSION (7,0)
+
+/* Define to `unsigned int' if <sys/types.h> does not define. */
+/* #undef size_t */
+
+/* Define as `fork' if `vfork' does not work. */
+/* #undef vfork */
+
+#define TABLES_NEXT_TO_CODE 1
+
+#define llvm_CC_FLAVOR 1
+
+#define clang_CC_FLAVOR 1
+#endif /* __GHCAUTOCONF_H__ */
diff --git a/ghc-lib/generated/ghcplatform.h b/ghc-lib/generated/ghcplatform.h
new file mode 100644
--- /dev/null
+++ b/ghc-lib/generated/ghcplatform.h
@@ -0,0 +1,34 @@
+#ifndef __GHCPLATFORM_H__
+#define __GHCPLATFORM_H__
+
+#define BuildPlatform_TYPE  x86_64_apple_darwin
+#define HostPlatform_TYPE   x86_64_apple_darwin
+
+#define x86_64_apple_darwin_BUILD 1
+#define x86_64_apple_darwin_HOST 1
+
+#define x86_64_BUILD_ARCH 1
+#define x86_64_HOST_ARCH 1
+#define BUILD_ARCH "x86_64"
+#define HOST_ARCH "x86_64"
+
+#define darwin_BUILD_OS 1
+#define darwin_HOST_OS 1
+#define BUILD_OS "darwin"
+#define HOST_OS "darwin"
+
+#define apple_BUILD_VENDOR 1
+#define apple_HOST_VENDOR 1
+#define BUILD_VENDOR "apple"
+#define HOST_VENDOR "apple"
+
+/* These TARGET macros are for backwards compatibility... DO NOT USE! */
+#define TargetPlatform_TYPE x86_64_apple_darwin
+#define x86_64_apple_darwin_TARGET 1
+#define x86_64_TARGET_ARCH 1
+#define TARGET_ARCH "x86_64"
+#define darwin_TARGET_OS 1
+#define TARGET_OS "darwin"
+#define apple_TARGET_VENDOR 1
+
+#endif /* __GHCPLATFORM_H__ */
diff --git a/ghc-lib/generated/ghcversion.h b/ghc-lib/generated/ghcversion.h
new file mode 100644
--- /dev/null
+++ b/ghc-lib/generated/ghcversion.h
@@ -0,0 +1,19 @@
+#ifndef __GHCVERSION_H__
+#define __GHCVERSION_H__
+
+#ifndef __GLASGOW_HASKELL__
+# define __GLASGOW_HASKELL__ 808
+#endif
+
+#define __GLASGOW_HASKELL_PATCHLEVEL1__ 0
+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190424
+
+#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\
+   ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \
+   ((ma)*100+(mi)) == __GLASGOW_HASKELL__    \
+          && (pl1) <  __GLASGOW_HASKELL_PATCHLEVEL1__ || \
+   ((ma)*100+(mi)) == __GLASGOW_HASKELL__    \
+          && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__ \
+          && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ )
+
+#endif /* __GHCVERSION_H__ */
diff --git a/ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs b/ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs
+++ /dev/null
@@ -1,302 +0,0 @@
-module GHC.Platform.Constants where
-
-import Prelude
-import Data.Char
-
-data PlatformConstants = PlatformConstants {
-      pc_CONTROL_GROUP_CONST_291 :: {-# UNPACK #-} !Int,
-      pc_STD_HDR_SIZE :: {-# UNPACK #-} !Int,
-      pc_PROF_HDR_SIZE :: {-# UNPACK #-} !Int,
-      pc_BLOCK_SIZE :: {-# UNPACK #-} !Int,
-      pc_BLOCKS_PER_MBLOCK :: {-# UNPACK #-} !Int,
-      pc_TICKY_BIN_COUNT :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rR1 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rR2 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rR3 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rR4 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rR5 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rR6 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rR7 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rR8 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rR9 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rR10 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rF1 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rF2 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rF3 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rF4 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rF5 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rF6 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rD1 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rD2 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rD3 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rD4 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rD5 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rD6 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rXMM1 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rXMM2 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rXMM3 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rXMM4 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rXMM5 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rXMM6 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rYMM1 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rYMM2 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rYMM3 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rYMM4 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rYMM5 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rYMM6 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rZMM1 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rZMM2 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rZMM3 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rZMM4 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rZMM5 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rZMM6 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rL1 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rSp :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rSpLim :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rHp :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rHpLim :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rCCCS :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rCurrentTSO :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rCurrentNursery :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgRegTable_rHpAlloc :: {-# UNPACK #-} !Int,
-      pc_OFFSET_stgEagerBlackholeInfo :: {-# UNPACK #-} !Int,
-      pc_OFFSET_stgGCEnter1 :: {-# UNPACK #-} !Int,
-      pc_OFFSET_stgGCFun :: {-# UNPACK #-} !Int,
-      pc_OFFSET_Capability_r :: {-# UNPACK #-} !Int,
-      pc_OFFSET_bdescr_start :: {-# UNPACK #-} !Int,
-      pc_OFFSET_bdescr_free :: {-# UNPACK #-} !Int,
-      pc_OFFSET_bdescr_blocks :: {-# UNPACK #-} !Int,
-      pc_OFFSET_bdescr_flags :: {-# UNPACK #-} !Int,
-      pc_SIZEOF_CostCentreStack :: {-# UNPACK #-} !Int,
-      pc_OFFSET_CostCentreStack_mem_alloc :: {-# UNPACK #-} !Int,
-      pc_REP_CostCentreStack_mem_alloc :: {-# UNPACK #-} !Int,
-      pc_OFFSET_CostCentreStack_scc_count :: {-# UNPACK #-} !Int,
-      pc_REP_CostCentreStack_scc_count :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgHeader_ccs :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgHeader_ldvw :: {-# UNPACK #-} !Int,
-      pc_SIZEOF_StgSMPThunkHeader :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgEntCounter_allocs :: {-# UNPACK #-} !Int,
-      pc_REP_StgEntCounter_allocs :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgEntCounter_allocd :: {-# UNPACK #-} !Int,
-      pc_REP_StgEntCounter_allocd :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgEntCounter_registeredp :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgEntCounter_link :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgEntCounter_entry_count :: {-# UNPACK #-} !Int,
-      pc_SIZEOF_StgUpdateFrame_NoHdr :: {-# UNPACK #-} !Int,
-      pc_SIZEOF_StgMutArrPtrs_NoHdr :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgMutArrPtrs_ptrs :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgMutArrPtrs_size :: {-# UNPACK #-} !Int,
-      pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgSmallMutArrPtrs_ptrs :: {-# UNPACK #-} !Int,
-      pc_SIZEOF_StgArrBytes_NoHdr :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgArrBytes_bytes :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgTSO_alloc_limit :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgTSO_cccs :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgTSO_stackobj :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgStack_sp :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgStack_stack :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgUpdateFrame_updatee :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgFunInfoExtraFwd_arity :: {-# UNPACK #-} !Int,
-      pc_REP_StgFunInfoExtraFwd_arity :: {-# UNPACK #-} !Int,
-      pc_SIZEOF_StgFunInfoExtraRev :: {-# UNPACK #-} !Int,
-      pc_OFFSET_StgFunInfoExtraRev_arity :: {-# UNPACK #-} !Int,
-      pc_REP_StgFunInfoExtraRev_arity :: {-# UNPACK #-} !Int,
-      pc_MAX_SPEC_SELECTEE_SIZE :: {-# UNPACK #-} !Int,
-      pc_MAX_SPEC_AP_SIZE :: {-# UNPACK #-} !Int,
-      pc_MIN_PAYLOAD_SIZE :: {-# UNPACK #-} !Int,
-      pc_MIN_INTLIKE :: {-# UNPACK #-} !Int,
-      pc_MAX_INTLIKE :: {-# UNPACK #-} !Int,
-      pc_MIN_CHARLIKE :: {-# UNPACK #-} !Int,
-      pc_MAX_CHARLIKE :: {-# UNPACK #-} !Int,
-      pc_MUT_ARR_PTRS_CARD_BITS :: {-# UNPACK #-} !Int,
-      pc_MAX_Vanilla_REG :: {-# UNPACK #-} !Int,
-      pc_MAX_Float_REG :: {-# UNPACK #-} !Int,
-      pc_MAX_Double_REG :: {-# UNPACK #-} !Int,
-      pc_MAX_Long_REG :: {-# UNPACK #-} !Int,
-      pc_MAX_XMM_REG :: {-# UNPACK #-} !Int,
-      pc_MAX_Real_Vanilla_REG :: {-# UNPACK #-} !Int,
-      pc_MAX_Real_Float_REG :: {-# UNPACK #-} !Int,
-      pc_MAX_Real_Double_REG :: {-# UNPACK #-} !Int,
-      pc_MAX_Real_XMM_REG :: {-# UNPACK #-} !Int,
-      pc_MAX_Real_Long_REG :: {-# UNPACK #-} !Int,
-      pc_RESERVED_C_STACK_BYTES :: {-# UNPACK #-} !Int,
-      pc_RESERVED_STACK_WORDS :: {-# UNPACK #-} !Int,
-      pc_AP_STACK_SPLIM :: {-# UNPACK #-} !Int,
-      pc_WORD_SIZE :: {-# UNPACK #-} !Int,
-      pc_CINT_SIZE :: {-# UNPACK #-} !Int,
-      pc_CLONG_SIZE :: {-# UNPACK #-} !Int,
-      pc_CLONG_LONG_SIZE :: {-# UNPACK #-} !Int,
-      pc_BITMAP_BITS_SHIFT :: {-# UNPACK #-} !Int,
-      pc_TAG_BITS :: {-# UNPACK #-} !Int,
-      pc_LDV_SHIFT :: {-# UNPACK #-} !Int,
-      pc_ILDV_CREATE_MASK :: !Integer,
-      pc_ILDV_STATE_CREATE :: !Integer,
-      pc_ILDV_STATE_USE :: !Integer,
-      pc_USE_INLINE_SRT_FIELD :: !Bool
-  } deriving (Show, Read, Eq, Ord)
-
-
-parseConstantsHeader :: FilePath -> IO PlatformConstants
-parseConstantsHeader fp = do
-  s <- readFile fp
-  let def = "#define HS_CONSTANTS \""
-      find [] xs = xs
-      find _  [] = error $ "GHC couldn't find the RTS constants ("++def++") in " ++ fp ++ ": the RTS package you are trying to use is perhaps for another GHC version" ++
-                               "(e.g. you are using the wrong package database) or the package database is broken.\n"
-      find (d:ds) (x:xs)
-        | d == x    = find ds xs
-        | otherwise = find def xs
-
-      readVal' :: Bool -> Integer -> String -> [Integer]
-      readVal' n     c (x:xs) = case x of
-        '"' -> [if n then negate c else c]
-        '-' -> readVal' True c xs
-        ',' -> (if n then negate c else c) : readVal' False 0 xs
-        _   -> readVal' n (c*10 + fromIntegral (ord x - ord '0')) xs
-      readVal' n     c []     = [if n then negate c else c]
-
-      readVal = readVal' False 0
-
-  return $! case readVal (find def s) of
-    [v0,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15
-     ,v16,v17,v18,v19,v20,v21,v22,v23,v24,v25,v26,v27,v28,v29,v30,v31
-     ,v32,v33,v34,v35,v36,v37,v38,v39,v40,v41,v42,v43,v44,v45,v46,v47
-     ,v48,v49,v50,v51,v52,v53,v54,v55,v56,v57,v58,v59,v60,v61,v62,v63
-     ,v64,v65,v66,v67,v68,v69,v70,v71,v72,v73,v74,v75,v76,v77,v78,v79
-     ,v80,v81,v82,v83,v84,v85,v86,v87,v88,v89,v90,v91,v92,v93,v94,v95
-     ,v96,v97,v98,v99,v100,v101,v102,v103,v104,v105,v106,v107,v108,v109,v110,v111
-     ,v112,v113,v114,v115,v116,v117,v118,v119,v120,v121,v122,v123,v124,v125,v126,v127
-     ,v128
-     ] -> PlatformConstants
-            { pc_CONTROL_GROUP_CONST_291 = fromIntegral v0
-            , pc_STD_HDR_SIZE = fromIntegral v1
-            , pc_PROF_HDR_SIZE = fromIntegral v2
-            , pc_BLOCK_SIZE = fromIntegral v3
-            , pc_BLOCKS_PER_MBLOCK = fromIntegral v4
-            , pc_TICKY_BIN_COUNT = fromIntegral v5
-            , pc_OFFSET_StgRegTable_rR1 = fromIntegral v6
-            , pc_OFFSET_StgRegTable_rR2 = fromIntegral v7
-            , pc_OFFSET_StgRegTable_rR3 = fromIntegral v8
-            , pc_OFFSET_StgRegTable_rR4 = fromIntegral v9
-            , pc_OFFSET_StgRegTable_rR5 = fromIntegral v10
-            , pc_OFFSET_StgRegTable_rR6 = fromIntegral v11
-            , pc_OFFSET_StgRegTable_rR7 = fromIntegral v12
-            , pc_OFFSET_StgRegTable_rR8 = fromIntegral v13
-            , pc_OFFSET_StgRegTable_rR9 = fromIntegral v14
-            , pc_OFFSET_StgRegTable_rR10 = fromIntegral v15
-            , pc_OFFSET_StgRegTable_rF1 = fromIntegral v16
-            , pc_OFFSET_StgRegTable_rF2 = fromIntegral v17
-            , pc_OFFSET_StgRegTable_rF3 = fromIntegral v18
-            , pc_OFFSET_StgRegTable_rF4 = fromIntegral v19
-            , pc_OFFSET_StgRegTable_rF5 = fromIntegral v20
-            , pc_OFFSET_StgRegTable_rF6 = fromIntegral v21
-            , pc_OFFSET_StgRegTable_rD1 = fromIntegral v22
-            , pc_OFFSET_StgRegTable_rD2 = fromIntegral v23
-            , pc_OFFSET_StgRegTable_rD3 = fromIntegral v24
-            , pc_OFFSET_StgRegTable_rD4 = fromIntegral v25
-            , pc_OFFSET_StgRegTable_rD5 = fromIntegral v26
-            , pc_OFFSET_StgRegTable_rD6 = fromIntegral v27
-            , pc_OFFSET_StgRegTable_rXMM1 = fromIntegral v28
-            , pc_OFFSET_StgRegTable_rXMM2 = fromIntegral v29
-            , pc_OFFSET_StgRegTable_rXMM3 = fromIntegral v30
-            , pc_OFFSET_StgRegTable_rXMM4 = fromIntegral v31
-            , pc_OFFSET_StgRegTable_rXMM5 = fromIntegral v32
-            , pc_OFFSET_StgRegTable_rXMM6 = fromIntegral v33
-            , pc_OFFSET_StgRegTable_rYMM1 = fromIntegral v34
-            , pc_OFFSET_StgRegTable_rYMM2 = fromIntegral v35
-            , pc_OFFSET_StgRegTable_rYMM3 = fromIntegral v36
-            , pc_OFFSET_StgRegTable_rYMM4 = fromIntegral v37
-            , pc_OFFSET_StgRegTable_rYMM5 = fromIntegral v38
-            , pc_OFFSET_StgRegTable_rYMM6 = fromIntegral v39
-            , pc_OFFSET_StgRegTable_rZMM1 = fromIntegral v40
-            , pc_OFFSET_StgRegTable_rZMM2 = fromIntegral v41
-            , pc_OFFSET_StgRegTable_rZMM3 = fromIntegral v42
-            , pc_OFFSET_StgRegTable_rZMM4 = fromIntegral v43
-            , pc_OFFSET_StgRegTable_rZMM5 = fromIntegral v44
-            , pc_OFFSET_StgRegTable_rZMM6 = fromIntegral v45
-            , pc_OFFSET_StgRegTable_rL1 = fromIntegral v46
-            , pc_OFFSET_StgRegTable_rSp = fromIntegral v47
-            , pc_OFFSET_StgRegTable_rSpLim = fromIntegral v48
-            , pc_OFFSET_StgRegTable_rHp = fromIntegral v49
-            , pc_OFFSET_StgRegTable_rHpLim = fromIntegral v50
-            , pc_OFFSET_StgRegTable_rCCCS = fromIntegral v51
-            , pc_OFFSET_StgRegTable_rCurrentTSO = fromIntegral v52
-            , pc_OFFSET_StgRegTable_rCurrentNursery = fromIntegral v53
-            , pc_OFFSET_StgRegTable_rHpAlloc = fromIntegral v54
-            , pc_OFFSET_stgEagerBlackholeInfo = fromIntegral v55
-            , pc_OFFSET_stgGCEnter1 = fromIntegral v56
-            , pc_OFFSET_stgGCFun = fromIntegral v57
-            , pc_OFFSET_Capability_r = fromIntegral v58
-            , pc_OFFSET_bdescr_start = fromIntegral v59
-            , pc_OFFSET_bdescr_free = fromIntegral v60
-            , pc_OFFSET_bdescr_blocks = fromIntegral v61
-            , pc_OFFSET_bdescr_flags = fromIntegral v62
-            , pc_SIZEOF_CostCentreStack = fromIntegral v63
-            , pc_OFFSET_CostCentreStack_mem_alloc = fromIntegral v64
-            , pc_REP_CostCentreStack_mem_alloc = fromIntegral v65
-            , pc_OFFSET_CostCentreStack_scc_count = fromIntegral v66
-            , pc_REP_CostCentreStack_scc_count = fromIntegral v67
-            , pc_OFFSET_StgHeader_ccs = fromIntegral v68
-            , pc_OFFSET_StgHeader_ldvw = fromIntegral v69
-            , pc_SIZEOF_StgSMPThunkHeader = fromIntegral v70
-            , pc_OFFSET_StgEntCounter_allocs = fromIntegral v71
-            , pc_REP_StgEntCounter_allocs = fromIntegral v72
-            , pc_OFFSET_StgEntCounter_allocd = fromIntegral v73
-            , pc_REP_StgEntCounter_allocd = fromIntegral v74
-            , pc_OFFSET_StgEntCounter_registeredp = fromIntegral v75
-            , pc_OFFSET_StgEntCounter_link = fromIntegral v76
-            , pc_OFFSET_StgEntCounter_entry_count = fromIntegral v77
-            , pc_SIZEOF_StgUpdateFrame_NoHdr = fromIntegral v78
-            , pc_SIZEOF_StgMutArrPtrs_NoHdr = fromIntegral v79
-            , pc_OFFSET_StgMutArrPtrs_ptrs = fromIntegral v80
-            , pc_OFFSET_StgMutArrPtrs_size = fromIntegral v81
-            , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = fromIntegral v82
-            , pc_OFFSET_StgSmallMutArrPtrs_ptrs = fromIntegral v83
-            , pc_SIZEOF_StgArrBytes_NoHdr = fromIntegral v84
-            , pc_OFFSET_StgArrBytes_bytes = fromIntegral v85
-            , pc_OFFSET_StgTSO_alloc_limit = fromIntegral v86
-            , pc_OFFSET_StgTSO_cccs = fromIntegral v87
-            , pc_OFFSET_StgTSO_stackobj = fromIntegral v88
-            , pc_OFFSET_StgStack_sp = fromIntegral v89
-            , pc_OFFSET_StgStack_stack = fromIntegral v90
-            , pc_OFFSET_StgUpdateFrame_updatee = fromIntegral v91
-            , pc_OFFSET_StgFunInfoExtraFwd_arity = fromIntegral v92
-            , pc_REP_StgFunInfoExtraFwd_arity = fromIntegral v93
-            , pc_SIZEOF_StgFunInfoExtraRev = fromIntegral v94
-            , pc_OFFSET_StgFunInfoExtraRev_arity = fromIntegral v95
-            , pc_REP_StgFunInfoExtraRev_arity = fromIntegral v96
-            , pc_MAX_SPEC_SELECTEE_SIZE = fromIntegral v97
-            , pc_MAX_SPEC_AP_SIZE = fromIntegral v98
-            , pc_MIN_PAYLOAD_SIZE = fromIntegral v99
-            , pc_MIN_INTLIKE = fromIntegral v100
-            , pc_MAX_INTLIKE = fromIntegral v101
-            , pc_MIN_CHARLIKE = fromIntegral v102
-            , pc_MAX_CHARLIKE = fromIntegral v103
-            , pc_MUT_ARR_PTRS_CARD_BITS = fromIntegral v104
-            , pc_MAX_Vanilla_REG = fromIntegral v105
-            , pc_MAX_Float_REG = fromIntegral v106
-            , pc_MAX_Double_REG = fromIntegral v107
-            , pc_MAX_Long_REG = fromIntegral v108
-            , pc_MAX_XMM_REG = fromIntegral v109
-            , pc_MAX_Real_Vanilla_REG = fromIntegral v110
-            , pc_MAX_Real_Float_REG = fromIntegral v111
-            , pc_MAX_Real_Double_REG = fromIntegral v112
-            , pc_MAX_Real_XMM_REG = fromIntegral v113
-            , pc_MAX_Real_Long_REG = fromIntegral v114
-            , pc_RESERVED_C_STACK_BYTES = fromIntegral v115
-            , pc_RESERVED_STACK_WORDS = fromIntegral v116
-            , pc_AP_STACK_SPLIM = fromIntegral v117
-            , pc_WORD_SIZE = fromIntegral v118
-            , pc_CINT_SIZE = fromIntegral v119
-            , pc_CLONG_SIZE = fromIntegral v120
-            , pc_CLONG_LONG_SIZE = fromIntegral v121
-            , pc_BITMAP_BITS_SHIFT = fromIntegral v122
-            , pc_TAG_BITS = fromIntegral v123
-            , pc_LDV_SHIFT = fromIntegral v124
-            , pc_ILDV_CREATE_MASK = v125
-            , pc_ILDV_STATE_CREATE = v126
-            , pc_ILDV_STATE_USE = v127
-            , pc_USE_INLINE_SRT_FIELD = 0 < v128
-            }
-    _ -> error "Invalid platform constants"
-
diff --git a/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl b/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl
+++ /dev/null
@@ -1,257 +0,0 @@
-primOpCanFail Int8QuotOp = True
-primOpCanFail Int8RemOp = True
-primOpCanFail Int8QuotRemOp = True
-primOpCanFail Word8QuotOp = True
-primOpCanFail Word8RemOp = True
-primOpCanFail Word8QuotRemOp = True
-primOpCanFail Int16QuotOp = True
-primOpCanFail Int16RemOp = True
-primOpCanFail Int16QuotRemOp = True
-primOpCanFail Word16QuotOp = True
-primOpCanFail Word16RemOp = True
-primOpCanFail Word16QuotRemOp = True
-primOpCanFail Int32QuotOp = True
-primOpCanFail Int32RemOp = True
-primOpCanFail Int32QuotRemOp = True
-primOpCanFail Word32QuotOp = True
-primOpCanFail Word32RemOp = True
-primOpCanFail Word32QuotRemOp = True
-primOpCanFail Int64QuotOp = True
-primOpCanFail Int64RemOp = True
-primOpCanFail Word64QuotOp = True
-primOpCanFail Word64RemOp = True
-primOpCanFail IntQuotOp = True
-primOpCanFail IntRemOp = True
-primOpCanFail IntQuotRemOp = True
-primOpCanFail WordQuotOp = True
-primOpCanFail WordRemOp = True
-primOpCanFail WordQuotRemOp = True
-primOpCanFail WordQuotRem2Op = True
-primOpCanFail DoubleDivOp = True
-primOpCanFail DoubleLogOp = True
-primOpCanFail DoubleLog1POp = True
-primOpCanFail DoubleAsinOp = True
-primOpCanFail DoubleAcosOp = True
-primOpCanFail FloatDivOp = True
-primOpCanFail FloatLogOp = True
-primOpCanFail FloatLog1POp = True
-primOpCanFail FloatAsinOp = True
-primOpCanFail FloatAcosOp = True
-primOpCanFail ReadArrayOp = True
-primOpCanFail WriteArrayOp = True
-primOpCanFail IndexArrayOp = True
-primOpCanFail CopyArrayOp = True
-primOpCanFail CopyMutableArrayOp = True
-primOpCanFail CloneArrayOp = True
-primOpCanFail CloneMutableArrayOp = True
-primOpCanFail FreezeArrayOp = True
-primOpCanFail ThawArrayOp = True
-primOpCanFail CasArrayOp = True
-primOpCanFail ReadSmallArrayOp = True
-primOpCanFail WriteSmallArrayOp = True
-primOpCanFail IndexSmallArrayOp = True
-primOpCanFail CopySmallArrayOp = True
-primOpCanFail CopySmallMutableArrayOp = True
-primOpCanFail CloneSmallArrayOp = True
-primOpCanFail CloneSmallMutableArrayOp = True
-primOpCanFail FreezeSmallArrayOp = True
-primOpCanFail ThawSmallArrayOp = True
-primOpCanFail CasSmallArrayOp = True
-primOpCanFail IndexByteArrayOp_Char = True
-primOpCanFail IndexByteArrayOp_WideChar = True
-primOpCanFail IndexByteArrayOp_Int = True
-primOpCanFail IndexByteArrayOp_Word = True
-primOpCanFail IndexByteArrayOp_Addr = True
-primOpCanFail IndexByteArrayOp_Float = True
-primOpCanFail IndexByteArrayOp_Double = True
-primOpCanFail IndexByteArrayOp_StablePtr = True
-primOpCanFail IndexByteArrayOp_Int8 = True
-primOpCanFail IndexByteArrayOp_Int16 = True
-primOpCanFail IndexByteArrayOp_Int32 = True
-primOpCanFail IndexByteArrayOp_Int64 = True
-primOpCanFail IndexByteArrayOp_Word8 = True
-primOpCanFail IndexByteArrayOp_Word16 = True
-primOpCanFail IndexByteArrayOp_Word32 = True
-primOpCanFail IndexByteArrayOp_Word64 = True
-primOpCanFail IndexByteArrayOp_Word8AsChar = True
-primOpCanFail IndexByteArrayOp_Word8AsWideChar = True
-primOpCanFail IndexByteArrayOp_Word8AsInt = True
-primOpCanFail IndexByteArrayOp_Word8AsWord = True
-primOpCanFail IndexByteArrayOp_Word8AsAddr = True
-primOpCanFail IndexByteArrayOp_Word8AsFloat = True
-primOpCanFail IndexByteArrayOp_Word8AsDouble = True
-primOpCanFail IndexByteArrayOp_Word8AsStablePtr = True
-primOpCanFail IndexByteArrayOp_Word8AsInt16 = True
-primOpCanFail IndexByteArrayOp_Word8AsInt32 = True
-primOpCanFail IndexByteArrayOp_Word8AsInt64 = True
-primOpCanFail IndexByteArrayOp_Word8AsWord16 = True
-primOpCanFail IndexByteArrayOp_Word8AsWord32 = True
-primOpCanFail IndexByteArrayOp_Word8AsWord64 = True
-primOpCanFail ReadByteArrayOp_Char = True
-primOpCanFail ReadByteArrayOp_WideChar = True
-primOpCanFail ReadByteArrayOp_Int = True
-primOpCanFail ReadByteArrayOp_Word = True
-primOpCanFail ReadByteArrayOp_Addr = True
-primOpCanFail ReadByteArrayOp_Float = True
-primOpCanFail ReadByteArrayOp_Double = True
-primOpCanFail ReadByteArrayOp_StablePtr = True
-primOpCanFail ReadByteArrayOp_Int8 = True
-primOpCanFail ReadByteArrayOp_Int16 = True
-primOpCanFail ReadByteArrayOp_Int32 = True
-primOpCanFail ReadByteArrayOp_Int64 = True
-primOpCanFail ReadByteArrayOp_Word8 = True
-primOpCanFail ReadByteArrayOp_Word16 = True
-primOpCanFail ReadByteArrayOp_Word32 = True
-primOpCanFail ReadByteArrayOp_Word64 = True
-primOpCanFail ReadByteArrayOp_Word8AsChar = True
-primOpCanFail ReadByteArrayOp_Word8AsWideChar = True
-primOpCanFail ReadByteArrayOp_Word8AsInt = True
-primOpCanFail ReadByteArrayOp_Word8AsWord = True
-primOpCanFail ReadByteArrayOp_Word8AsAddr = True
-primOpCanFail ReadByteArrayOp_Word8AsFloat = True
-primOpCanFail ReadByteArrayOp_Word8AsDouble = True
-primOpCanFail ReadByteArrayOp_Word8AsStablePtr = True
-primOpCanFail ReadByteArrayOp_Word8AsInt16 = True
-primOpCanFail ReadByteArrayOp_Word8AsInt32 = True
-primOpCanFail ReadByteArrayOp_Word8AsInt64 = True
-primOpCanFail ReadByteArrayOp_Word8AsWord16 = True
-primOpCanFail ReadByteArrayOp_Word8AsWord32 = True
-primOpCanFail ReadByteArrayOp_Word8AsWord64 = True
-primOpCanFail WriteByteArrayOp_Char = True
-primOpCanFail WriteByteArrayOp_WideChar = True
-primOpCanFail WriteByteArrayOp_Int = True
-primOpCanFail WriteByteArrayOp_Word = True
-primOpCanFail WriteByteArrayOp_Addr = True
-primOpCanFail WriteByteArrayOp_Float = True
-primOpCanFail WriteByteArrayOp_Double = True
-primOpCanFail WriteByteArrayOp_StablePtr = True
-primOpCanFail WriteByteArrayOp_Int8 = True
-primOpCanFail WriteByteArrayOp_Int16 = True
-primOpCanFail WriteByteArrayOp_Int32 = True
-primOpCanFail WriteByteArrayOp_Int64 = True
-primOpCanFail WriteByteArrayOp_Word8 = True
-primOpCanFail WriteByteArrayOp_Word16 = True
-primOpCanFail WriteByteArrayOp_Word32 = True
-primOpCanFail WriteByteArrayOp_Word64 = True
-primOpCanFail WriteByteArrayOp_Word8AsChar = True
-primOpCanFail WriteByteArrayOp_Word8AsWideChar = True
-primOpCanFail WriteByteArrayOp_Word8AsInt = True
-primOpCanFail WriteByteArrayOp_Word8AsWord = True
-primOpCanFail WriteByteArrayOp_Word8AsAddr = True
-primOpCanFail WriteByteArrayOp_Word8AsFloat = True
-primOpCanFail WriteByteArrayOp_Word8AsDouble = True
-primOpCanFail WriteByteArrayOp_Word8AsStablePtr = True
-primOpCanFail WriteByteArrayOp_Word8AsInt16 = True
-primOpCanFail WriteByteArrayOp_Word8AsInt32 = True
-primOpCanFail WriteByteArrayOp_Word8AsInt64 = True
-primOpCanFail WriteByteArrayOp_Word8AsWord16 = True
-primOpCanFail WriteByteArrayOp_Word8AsWord32 = True
-primOpCanFail WriteByteArrayOp_Word8AsWord64 = True
-primOpCanFail CompareByteArraysOp = True
-primOpCanFail CopyByteArrayOp = True
-primOpCanFail CopyMutableByteArrayOp = True
-primOpCanFail CopyByteArrayToAddrOp = True
-primOpCanFail CopyMutableByteArrayToAddrOp = True
-primOpCanFail CopyAddrToByteArrayOp = True
-primOpCanFail SetByteArrayOp = True
-primOpCanFail AtomicReadByteArrayOp_Int = True
-primOpCanFail AtomicWriteByteArrayOp_Int = True
-primOpCanFail CasByteArrayOp_Int = True
-primOpCanFail CasByteArrayOp_Int8 = True
-primOpCanFail CasByteArrayOp_Int16 = True
-primOpCanFail CasByteArrayOp_Int32 = True
-primOpCanFail CasByteArrayOp_Int64 = True
-primOpCanFail FetchAddByteArrayOp_Int = True
-primOpCanFail FetchSubByteArrayOp_Int = True
-primOpCanFail FetchAndByteArrayOp_Int = True
-primOpCanFail FetchNandByteArrayOp_Int = True
-primOpCanFail FetchOrByteArrayOp_Int = True
-primOpCanFail FetchXorByteArrayOp_Int = True
-primOpCanFail IndexOffAddrOp_Char = True
-primOpCanFail IndexOffAddrOp_WideChar = True
-primOpCanFail IndexOffAddrOp_Int = True
-primOpCanFail IndexOffAddrOp_Word = True
-primOpCanFail IndexOffAddrOp_Addr = True
-primOpCanFail IndexOffAddrOp_Float = True
-primOpCanFail IndexOffAddrOp_Double = True
-primOpCanFail IndexOffAddrOp_StablePtr = True
-primOpCanFail IndexOffAddrOp_Int8 = True
-primOpCanFail IndexOffAddrOp_Int16 = True
-primOpCanFail IndexOffAddrOp_Int32 = True
-primOpCanFail IndexOffAddrOp_Int64 = True
-primOpCanFail IndexOffAddrOp_Word8 = True
-primOpCanFail IndexOffAddrOp_Word16 = True
-primOpCanFail IndexOffAddrOp_Word32 = True
-primOpCanFail IndexOffAddrOp_Word64 = True
-primOpCanFail ReadOffAddrOp_Char = True
-primOpCanFail ReadOffAddrOp_WideChar = True
-primOpCanFail ReadOffAddrOp_Int = True
-primOpCanFail ReadOffAddrOp_Word = True
-primOpCanFail ReadOffAddrOp_Addr = True
-primOpCanFail ReadOffAddrOp_Float = True
-primOpCanFail ReadOffAddrOp_Double = True
-primOpCanFail ReadOffAddrOp_StablePtr = True
-primOpCanFail ReadOffAddrOp_Int8 = True
-primOpCanFail ReadOffAddrOp_Int16 = True
-primOpCanFail ReadOffAddrOp_Int32 = True
-primOpCanFail ReadOffAddrOp_Int64 = True
-primOpCanFail ReadOffAddrOp_Word8 = True
-primOpCanFail ReadOffAddrOp_Word16 = True
-primOpCanFail ReadOffAddrOp_Word32 = True
-primOpCanFail ReadOffAddrOp_Word64 = True
-primOpCanFail WriteOffAddrOp_Char = True
-primOpCanFail WriteOffAddrOp_WideChar = True
-primOpCanFail WriteOffAddrOp_Int = True
-primOpCanFail WriteOffAddrOp_Word = True
-primOpCanFail WriteOffAddrOp_Addr = True
-primOpCanFail WriteOffAddrOp_Float = True
-primOpCanFail WriteOffAddrOp_Double = True
-primOpCanFail WriteOffAddrOp_StablePtr = True
-primOpCanFail WriteOffAddrOp_Int8 = True
-primOpCanFail WriteOffAddrOp_Int16 = True
-primOpCanFail WriteOffAddrOp_Int32 = True
-primOpCanFail WriteOffAddrOp_Int64 = True
-primOpCanFail WriteOffAddrOp_Word8 = True
-primOpCanFail WriteOffAddrOp_Word16 = True
-primOpCanFail WriteOffAddrOp_Word32 = True
-primOpCanFail WriteOffAddrOp_Word64 = True
-primOpCanFail InterlockedExchange_Addr = True
-primOpCanFail InterlockedExchange_Word = True
-primOpCanFail CasAddrOp_Addr = True
-primOpCanFail CasAddrOp_Word = True
-primOpCanFail CasAddrOp_Word8 = True
-primOpCanFail CasAddrOp_Word16 = True
-primOpCanFail CasAddrOp_Word32 = True
-primOpCanFail CasAddrOp_Word64 = True
-primOpCanFail FetchAddAddrOp_Word = True
-primOpCanFail FetchSubAddrOp_Word = True
-primOpCanFail FetchAndAddrOp_Word = True
-primOpCanFail FetchNandAddrOp_Word = True
-primOpCanFail FetchOrAddrOp_Word = True
-primOpCanFail FetchXorAddrOp_Word = True
-primOpCanFail AtomicReadAddrOp_Word = True
-primOpCanFail AtomicWriteAddrOp_Word = True
-primOpCanFail AtomicModifyMutVar2Op = True
-primOpCanFail AtomicModifyMutVar_Op = True
-primOpCanFail RaiseOp = True
-primOpCanFail RaiseUnderflowOp = True
-primOpCanFail RaiseOverflowOp = True
-primOpCanFail RaiseDivZeroOp = True
-primOpCanFail ReallyUnsafePtrEqualityOp = True
-primOpCanFail (VecInsertOp _ _ _) = True
-primOpCanFail (VecDivOp _ _ _) = True
-primOpCanFail (VecQuotOp _ _ _) = True
-primOpCanFail (VecRemOp _ _ _) = True
-primOpCanFail (VecIndexByteArrayOp _ _ _) = True
-primOpCanFail (VecReadByteArrayOp _ _ _) = True
-primOpCanFail (VecWriteByteArrayOp _ _ _) = True
-primOpCanFail (VecIndexOffAddrOp _ _ _) = True
-primOpCanFail (VecReadOffAddrOp _ _ _) = True
-primOpCanFail (VecWriteOffAddrOp _ _ _) = True
-primOpCanFail (VecIndexScalarByteArrayOp _ _ _) = True
-primOpCanFail (VecReadScalarByteArrayOp _ _ _) = True
-primOpCanFail (VecWriteScalarByteArrayOp _ _ _) = True
-primOpCanFail (VecIndexScalarOffAddrOp _ _ _) = True
-primOpCanFail (VecReadScalarOffAddrOp _ _ _) = True
-primOpCanFail (VecWriteScalarOffAddrOp _ _ _) = True
-primOpCanFail _ = False
diff --git a/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl b/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-code-size.hs-incl
+++ /dev/null
@@ -1,72 +0,0 @@
-primOpCodeSize OrdOp = 0
-primOpCodeSize Int8ToWord8Op = 0
-primOpCodeSize Word8ToInt8Op = 0
-primOpCodeSize Int16ToWord16Op = 0
-primOpCodeSize Word16ToInt16Op = 0
-primOpCodeSize Int32ToWord32Op = 0
-primOpCodeSize Word32ToInt32Op = 0
-primOpCodeSize Int64ToWord64Op = 0
-primOpCodeSize Word64ToInt64Op = 0
-primOpCodeSize IntAddCOp = 2
-primOpCodeSize IntSubCOp = 2
-primOpCodeSize ChrOp = 0
-primOpCodeSize IntToWordOp = 0
-primOpCodeSize WordAddCOp = 2
-primOpCodeSize WordSubCOp = 2
-primOpCodeSize WordAdd2Op = 2
-primOpCodeSize WordToIntOp = 0
-primOpCodeSize DoubleExpOp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleExpM1Op =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleLogOp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleLog1POp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleSqrtOp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleSinOp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleCosOp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleTanOp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleAsinOp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleAcosOp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleAtanOp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleSinhOp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleCoshOp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleTanhOp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleAsinhOp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleAcoshOp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoubleAtanhOp =  primOpCodeSizeForeignCall 
-primOpCodeSize DoublePowerOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatExpOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatExpM1Op =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatLogOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatLog1POp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatSqrtOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatSinOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatCosOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatTanOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatAsinOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatAcosOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatAtanOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatSinhOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatCoshOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatTanhOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatAsinhOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatAcoshOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatAtanhOp =  primOpCodeSizeForeignCall 
-primOpCodeSize FloatPowerOp =  primOpCodeSizeForeignCall 
-primOpCodeSize WriteArrayOp = 2
-primOpCodeSize CopyByteArrayOp =  primOpCodeSizeForeignCall + 4
-primOpCodeSize CopyMutableByteArrayOp =  primOpCodeSizeForeignCall + 4 
-primOpCodeSize CopyByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4
-primOpCodeSize CopyMutableByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4
-primOpCodeSize CopyAddrToByteArrayOp =  primOpCodeSizeForeignCall + 4
-primOpCodeSize SetByteArrayOp =  primOpCodeSizeForeignCall + 4 
-primOpCodeSize AddrToIntOp = 0
-primOpCodeSize IntToAddrOp = 0
-primOpCodeSize WriteMutVarOp =  primOpCodeSizeForeignCall 
-primOpCodeSize RaiseUnderflowOp =  primOpCodeSizeForeignCall 
-primOpCodeSize RaiseOverflowOp =  primOpCodeSizeForeignCall 
-primOpCodeSize RaiseDivZeroOp =  primOpCodeSizeForeignCall 
-primOpCodeSize TouchOp =  0 
-primOpCodeSize ParOp =  primOpCodeSizeForeignCall 
-primOpCodeSize SparkOp =  primOpCodeSizeForeignCall 
-primOpCodeSize AddrToAnyOp = 0
-primOpCodeSize AnyToAddrOp = 0
-primOpCodeSize _ =  primOpCodeSizeDefault 
diff --git a/ghc-lib/stage0/compiler/build/primop-commutable.hs-incl b/ghc-lib/stage0/compiler/build/primop-commutable.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-commutable.hs-incl
+++ /dev/null
@@ -1,58 +0,0 @@
-commutableOp CharEqOp = True
-commutableOp CharNeOp = True
-commutableOp Int8AddOp = True
-commutableOp Int8MulOp = True
-commutableOp Word8AddOp = True
-commutableOp Word8MulOp = True
-commutableOp Word8AndOp = True
-commutableOp Word8OrOp = True
-commutableOp Word8XorOp = True
-commutableOp Int16AddOp = True
-commutableOp Int16MulOp = True
-commutableOp Word16AddOp = True
-commutableOp Word16MulOp = True
-commutableOp Word16AndOp = True
-commutableOp Word16OrOp = True
-commutableOp Word16XorOp = True
-commutableOp Int32AddOp = True
-commutableOp Int32MulOp = True
-commutableOp Word32AddOp = True
-commutableOp Word32MulOp = True
-commutableOp Word32AndOp = True
-commutableOp Word32OrOp = True
-commutableOp Word32XorOp = True
-commutableOp Int64AddOp = True
-commutableOp Int64MulOp = True
-commutableOp Word64AddOp = True
-commutableOp Word64MulOp = True
-commutableOp Word64AndOp = True
-commutableOp Word64OrOp = True
-commutableOp Word64XorOp = True
-commutableOp IntAddOp = True
-commutableOp IntMulOp = True
-commutableOp IntMulMayOfloOp = True
-commutableOp IntAndOp = True
-commutableOp IntOrOp = True
-commutableOp IntXorOp = True
-commutableOp IntAddCOp = True
-commutableOp IntEqOp = True
-commutableOp IntNeOp = True
-commutableOp WordAddOp = True
-commutableOp WordAddCOp = True
-commutableOp WordAdd2Op = True
-commutableOp WordMulOp = True
-commutableOp WordMul2Op = True
-commutableOp WordAndOp = True
-commutableOp WordOrOp = True
-commutableOp WordXorOp = True
-commutableOp DoubleEqOp = True
-commutableOp DoubleNeOp = True
-commutableOp DoubleAddOp = True
-commutableOp DoubleMulOp = True
-commutableOp FloatEqOp = True
-commutableOp FloatNeOp = True
-commutableOp FloatAddOp = True
-commutableOp FloatMulOp = True
-commutableOp (VecAddOp _ _ _) = True
-commutableOp (VecMulOp _ _ _) = True
-commutableOp _ = False
diff --git a/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl b/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl
+++ /dev/null
@@ -1,694 +0,0 @@
-data PrimOp
-   = CharGtOp
-   | CharGeOp
-   | CharEqOp
-   | CharNeOp
-   | CharLtOp
-   | CharLeOp
-   | OrdOp
-   | Int8ToIntOp
-   | IntToInt8Op
-   | Int8NegOp
-   | Int8AddOp
-   | Int8SubOp
-   | Int8MulOp
-   | Int8QuotOp
-   | Int8RemOp
-   | Int8QuotRemOp
-   | Int8SllOp
-   | Int8SraOp
-   | Int8SrlOp
-   | Int8ToWord8Op
-   | Int8EqOp
-   | Int8GeOp
-   | Int8GtOp
-   | Int8LeOp
-   | Int8LtOp
-   | Int8NeOp
-   | Word8ToWordOp
-   | WordToWord8Op
-   | Word8AddOp
-   | Word8SubOp
-   | Word8MulOp
-   | Word8QuotOp
-   | Word8RemOp
-   | Word8QuotRemOp
-   | Word8AndOp
-   | Word8OrOp
-   | Word8XorOp
-   | Word8NotOp
-   | Word8SllOp
-   | Word8SrlOp
-   | Word8ToInt8Op
-   | Word8EqOp
-   | Word8GeOp
-   | Word8GtOp
-   | Word8LeOp
-   | Word8LtOp
-   | Word8NeOp
-   | Int16ToIntOp
-   | IntToInt16Op
-   | Int16NegOp
-   | Int16AddOp
-   | Int16SubOp
-   | Int16MulOp
-   | Int16QuotOp
-   | Int16RemOp
-   | Int16QuotRemOp
-   | Int16SllOp
-   | Int16SraOp
-   | Int16SrlOp
-   | Int16ToWord16Op
-   | Int16EqOp
-   | Int16GeOp
-   | Int16GtOp
-   | Int16LeOp
-   | Int16LtOp
-   | Int16NeOp
-   | Word16ToWordOp
-   | WordToWord16Op
-   | Word16AddOp
-   | Word16SubOp
-   | Word16MulOp
-   | Word16QuotOp
-   | Word16RemOp
-   | Word16QuotRemOp
-   | Word16AndOp
-   | Word16OrOp
-   | Word16XorOp
-   | Word16NotOp
-   | Word16SllOp
-   | Word16SrlOp
-   | Word16ToInt16Op
-   | Word16EqOp
-   | Word16GeOp
-   | Word16GtOp
-   | Word16LeOp
-   | Word16LtOp
-   | Word16NeOp
-   | Int32ToIntOp
-   | IntToInt32Op
-   | Int32NegOp
-   | Int32AddOp
-   | Int32SubOp
-   | Int32MulOp
-   | Int32QuotOp
-   | Int32RemOp
-   | Int32QuotRemOp
-   | Int32SllOp
-   | Int32SraOp
-   | Int32SrlOp
-   | Int32ToWord32Op
-   | Int32EqOp
-   | Int32GeOp
-   | Int32GtOp
-   | Int32LeOp
-   | Int32LtOp
-   | Int32NeOp
-   | Word32ToWordOp
-   | WordToWord32Op
-   | Word32AddOp
-   | Word32SubOp
-   | Word32MulOp
-   | Word32QuotOp
-   | Word32RemOp
-   | Word32QuotRemOp
-   | Word32AndOp
-   | Word32OrOp
-   | Word32XorOp
-   | Word32NotOp
-   | Word32SllOp
-   | Word32SrlOp
-   | Word32ToInt32Op
-   | Word32EqOp
-   | Word32GeOp
-   | Word32GtOp
-   | Word32LeOp
-   | Word32LtOp
-   | Word32NeOp
-   | Int64ToIntOp
-   | IntToInt64Op
-   | Int64NegOp
-   | Int64AddOp
-   | Int64SubOp
-   | Int64MulOp
-   | Int64QuotOp
-   | Int64RemOp
-   | Int64SllOp
-   | Int64SraOp
-   | Int64SrlOp
-   | Int64ToWord64Op
-   | Int64EqOp
-   | Int64GeOp
-   | Int64GtOp
-   | Int64LeOp
-   | Int64LtOp
-   | Int64NeOp
-   | Word64ToWordOp
-   | WordToWord64Op
-   | Word64AddOp
-   | Word64SubOp
-   | Word64MulOp
-   | Word64QuotOp
-   | Word64RemOp
-   | Word64AndOp
-   | Word64OrOp
-   | Word64XorOp
-   | Word64NotOp
-   | Word64SllOp
-   | Word64SrlOp
-   | Word64ToInt64Op
-   | Word64EqOp
-   | Word64GeOp
-   | Word64GtOp
-   | Word64LeOp
-   | Word64LtOp
-   | Word64NeOp
-   | IntAddOp
-   | IntSubOp
-   | IntMulOp
-   | IntMul2Op
-   | IntMulMayOfloOp
-   | IntQuotOp
-   | IntRemOp
-   | IntQuotRemOp
-   | IntAndOp
-   | IntOrOp
-   | IntXorOp
-   | IntNotOp
-   | IntNegOp
-   | IntAddCOp
-   | IntSubCOp
-   | IntGtOp
-   | IntGeOp
-   | IntEqOp
-   | IntNeOp
-   | IntLtOp
-   | IntLeOp
-   | ChrOp
-   | IntToWordOp
-   | IntToFloatOp
-   | IntToDoubleOp
-   | WordToFloatOp
-   | WordToDoubleOp
-   | IntSllOp
-   | IntSraOp
-   | IntSrlOp
-   | WordAddOp
-   | WordAddCOp
-   | WordSubCOp
-   | WordAdd2Op
-   | WordSubOp
-   | WordMulOp
-   | WordMul2Op
-   | WordQuotOp
-   | WordRemOp
-   | WordQuotRemOp
-   | WordQuotRem2Op
-   | WordAndOp
-   | WordOrOp
-   | WordXorOp
-   | WordNotOp
-   | WordSllOp
-   | WordSrlOp
-   | WordToIntOp
-   | WordGtOp
-   | WordGeOp
-   | WordEqOp
-   | WordNeOp
-   | WordLtOp
-   | WordLeOp
-   | PopCnt8Op
-   | PopCnt16Op
-   | PopCnt32Op
-   | PopCnt64Op
-   | PopCntOp
-   | Pdep8Op
-   | Pdep16Op
-   | Pdep32Op
-   | Pdep64Op
-   | PdepOp
-   | Pext8Op
-   | Pext16Op
-   | Pext32Op
-   | Pext64Op
-   | PextOp
-   | Clz8Op
-   | Clz16Op
-   | Clz32Op
-   | Clz64Op
-   | ClzOp
-   | Ctz8Op
-   | Ctz16Op
-   | Ctz32Op
-   | Ctz64Op
-   | CtzOp
-   | BSwap16Op
-   | BSwap32Op
-   | BSwap64Op
-   | BSwapOp
-   | BRev8Op
-   | BRev16Op
-   | BRev32Op
-   | BRev64Op
-   | BRevOp
-   | Narrow8IntOp
-   | Narrow16IntOp
-   | Narrow32IntOp
-   | Narrow8WordOp
-   | Narrow16WordOp
-   | Narrow32WordOp
-   | DoubleGtOp
-   | DoubleGeOp
-   | DoubleEqOp
-   | DoubleNeOp
-   | DoubleLtOp
-   | DoubleLeOp
-   | DoubleAddOp
-   | DoubleSubOp
-   | DoubleMulOp
-   | DoubleDivOp
-   | DoubleNegOp
-   | DoubleFabsOp
-   | DoubleToIntOp
-   | DoubleToFloatOp
-   | DoubleExpOp
-   | DoubleExpM1Op
-   | DoubleLogOp
-   | DoubleLog1POp
-   | DoubleSqrtOp
-   | DoubleSinOp
-   | DoubleCosOp
-   | DoubleTanOp
-   | DoubleAsinOp
-   | DoubleAcosOp
-   | DoubleAtanOp
-   | DoubleSinhOp
-   | DoubleCoshOp
-   | DoubleTanhOp
-   | DoubleAsinhOp
-   | DoubleAcoshOp
-   | DoubleAtanhOp
-   | DoublePowerOp
-   | DoubleDecode_2IntOp
-   | DoubleDecode_Int64Op
-   | FloatGtOp
-   | FloatGeOp
-   | FloatEqOp
-   | FloatNeOp
-   | FloatLtOp
-   | FloatLeOp
-   | FloatAddOp
-   | FloatSubOp
-   | FloatMulOp
-   | FloatDivOp
-   | FloatNegOp
-   | FloatFabsOp
-   | FloatToIntOp
-   | FloatExpOp
-   | FloatExpM1Op
-   | FloatLogOp
-   | FloatLog1POp
-   | FloatSqrtOp
-   | FloatSinOp
-   | FloatCosOp
-   | FloatTanOp
-   | FloatAsinOp
-   | FloatAcosOp
-   | FloatAtanOp
-   | FloatSinhOp
-   | FloatCoshOp
-   | FloatTanhOp
-   | FloatAsinhOp
-   | FloatAcoshOp
-   | FloatAtanhOp
-   | FloatPowerOp
-   | FloatToDoubleOp
-   | FloatDecode_IntOp
-   | NewArrayOp
-   | ReadArrayOp
-   | WriteArrayOp
-   | SizeofArrayOp
-   | SizeofMutableArrayOp
-   | IndexArrayOp
-   | UnsafeFreezeArrayOp
-   | UnsafeThawArrayOp
-   | CopyArrayOp
-   | CopyMutableArrayOp
-   | CloneArrayOp
-   | CloneMutableArrayOp
-   | FreezeArrayOp
-   | ThawArrayOp
-   | CasArrayOp
-   | NewSmallArrayOp
-   | ShrinkSmallMutableArrayOp_Char
-   | ReadSmallArrayOp
-   | WriteSmallArrayOp
-   | SizeofSmallArrayOp
-   | SizeofSmallMutableArrayOp
-   | GetSizeofSmallMutableArrayOp
-   | IndexSmallArrayOp
-   | UnsafeFreezeSmallArrayOp
-   | UnsafeThawSmallArrayOp
-   | CopySmallArrayOp
-   | CopySmallMutableArrayOp
-   | CloneSmallArrayOp
-   | CloneSmallMutableArrayOp
-   | FreezeSmallArrayOp
-   | ThawSmallArrayOp
-   | CasSmallArrayOp
-   | NewByteArrayOp_Char
-   | NewPinnedByteArrayOp_Char
-   | NewAlignedPinnedByteArrayOp_Char
-   | MutableByteArrayIsPinnedOp
-   | ByteArrayIsPinnedOp
-   | ByteArrayContents_Char
-   | MutableByteArrayContents_Char
-   | ShrinkMutableByteArrayOp_Char
-   | ResizeMutableByteArrayOp_Char
-   | UnsafeFreezeByteArrayOp
-   | SizeofByteArrayOp
-   | SizeofMutableByteArrayOp
-   | GetSizeofMutableByteArrayOp
-   | IndexByteArrayOp_Char
-   | IndexByteArrayOp_WideChar
-   | IndexByteArrayOp_Int
-   | IndexByteArrayOp_Word
-   | IndexByteArrayOp_Addr
-   | IndexByteArrayOp_Float
-   | IndexByteArrayOp_Double
-   | IndexByteArrayOp_StablePtr
-   | IndexByteArrayOp_Int8
-   | IndexByteArrayOp_Int16
-   | IndexByteArrayOp_Int32
-   | IndexByteArrayOp_Int64
-   | IndexByteArrayOp_Word8
-   | IndexByteArrayOp_Word16
-   | IndexByteArrayOp_Word32
-   | IndexByteArrayOp_Word64
-   | IndexByteArrayOp_Word8AsChar
-   | IndexByteArrayOp_Word8AsWideChar
-   | IndexByteArrayOp_Word8AsInt
-   | IndexByteArrayOp_Word8AsWord
-   | IndexByteArrayOp_Word8AsAddr
-   | IndexByteArrayOp_Word8AsFloat
-   | IndexByteArrayOp_Word8AsDouble
-   | IndexByteArrayOp_Word8AsStablePtr
-   | IndexByteArrayOp_Word8AsInt16
-   | IndexByteArrayOp_Word8AsInt32
-   | IndexByteArrayOp_Word8AsInt64
-   | IndexByteArrayOp_Word8AsWord16
-   | IndexByteArrayOp_Word8AsWord32
-   | IndexByteArrayOp_Word8AsWord64
-   | ReadByteArrayOp_Char
-   | ReadByteArrayOp_WideChar
-   | ReadByteArrayOp_Int
-   | ReadByteArrayOp_Word
-   | ReadByteArrayOp_Addr
-   | ReadByteArrayOp_Float
-   | ReadByteArrayOp_Double
-   | ReadByteArrayOp_StablePtr
-   | ReadByteArrayOp_Int8
-   | ReadByteArrayOp_Int16
-   | ReadByteArrayOp_Int32
-   | ReadByteArrayOp_Int64
-   | ReadByteArrayOp_Word8
-   | ReadByteArrayOp_Word16
-   | ReadByteArrayOp_Word32
-   | ReadByteArrayOp_Word64
-   | ReadByteArrayOp_Word8AsChar
-   | ReadByteArrayOp_Word8AsWideChar
-   | ReadByteArrayOp_Word8AsInt
-   | ReadByteArrayOp_Word8AsWord
-   | ReadByteArrayOp_Word8AsAddr
-   | ReadByteArrayOp_Word8AsFloat
-   | ReadByteArrayOp_Word8AsDouble
-   | ReadByteArrayOp_Word8AsStablePtr
-   | ReadByteArrayOp_Word8AsInt16
-   | ReadByteArrayOp_Word8AsInt32
-   | ReadByteArrayOp_Word8AsInt64
-   | ReadByteArrayOp_Word8AsWord16
-   | ReadByteArrayOp_Word8AsWord32
-   | ReadByteArrayOp_Word8AsWord64
-   | WriteByteArrayOp_Char
-   | WriteByteArrayOp_WideChar
-   | WriteByteArrayOp_Int
-   | WriteByteArrayOp_Word
-   | WriteByteArrayOp_Addr
-   | WriteByteArrayOp_Float
-   | WriteByteArrayOp_Double
-   | WriteByteArrayOp_StablePtr
-   | WriteByteArrayOp_Int8
-   | WriteByteArrayOp_Int16
-   | WriteByteArrayOp_Int32
-   | WriteByteArrayOp_Int64
-   | WriteByteArrayOp_Word8
-   | WriteByteArrayOp_Word16
-   | WriteByteArrayOp_Word32
-   | WriteByteArrayOp_Word64
-   | WriteByteArrayOp_Word8AsChar
-   | WriteByteArrayOp_Word8AsWideChar
-   | WriteByteArrayOp_Word8AsInt
-   | WriteByteArrayOp_Word8AsWord
-   | WriteByteArrayOp_Word8AsAddr
-   | WriteByteArrayOp_Word8AsFloat
-   | WriteByteArrayOp_Word8AsDouble
-   | WriteByteArrayOp_Word8AsStablePtr
-   | WriteByteArrayOp_Word8AsInt16
-   | WriteByteArrayOp_Word8AsInt32
-   | WriteByteArrayOp_Word8AsInt64
-   | WriteByteArrayOp_Word8AsWord16
-   | WriteByteArrayOp_Word8AsWord32
-   | WriteByteArrayOp_Word8AsWord64
-   | CompareByteArraysOp
-   | CopyByteArrayOp
-   | CopyMutableByteArrayOp
-   | CopyByteArrayToAddrOp
-   | CopyMutableByteArrayToAddrOp
-   | CopyAddrToByteArrayOp
-   | SetByteArrayOp
-   | AtomicReadByteArrayOp_Int
-   | AtomicWriteByteArrayOp_Int
-   | CasByteArrayOp_Int
-   | CasByteArrayOp_Int8
-   | CasByteArrayOp_Int16
-   | CasByteArrayOp_Int32
-   | CasByteArrayOp_Int64
-   | FetchAddByteArrayOp_Int
-   | FetchSubByteArrayOp_Int
-   | FetchAndByteArrayOp_Int
-   | FetchNandByteArrayOp_Int
-   | FetchOrByteArrayOp_Int
-   | FetchXorByteArrayOp_Int
-   | AddrAddOp
-   | AddrSubOp
-   | AddrRemOp
-   | AddrToIntOp
-   | IntToAddrOp
-   | AddrGtOp
-   | AddrGeOp
-   | AddrEqOp
-   | AddrNeOp
-   | AddrLtOp
-   | AddrLeOp
-   | IndexOffAddrOp_Char
-   | IndexOffAddrOp_WideChar
-   | IndexOffAddrOp_Int
-   | IndexOffAddrOp_Word
-   | IndexOffAddrOp_Addr
-   | IndexOffAddrOp_Float
-   | IndexOffAddrOp_Double
-   | IndexOffAddrOp_StablePtr
-   | IndexOffAddrOp_Int8
-   | IndexOffAddrOp_Int16
-   | IndexOffAddrOp_Int32
-   | IndexOffAddrOp_Int64
-   | IndexOffAddrOp_Word8
-   | IndexOffAddrOp_Word16
-   | IndexOffAddrOp_Word32
-   | IndexOffAddrOp_Word64
-   | ReadOffAddrOp_Char
-   | ReadOffAddrOp_WideChar
-   | ReadOffAddrOp_Int
-   | ReadOffAddrOp_Word
-   | ReadOffAddrOp_Addr
-   | ReadOffAddrOp_Float
-   | ReadOffAddrOp_Double
-   | ReadOffAddrOp_StablePtr
-   | ReadOffAddrOp_Int8
-   | ReadOffAddrOp_Int16
-   | ReadOffAddrOp_Int32
-   | ReadOffAddrOp_Int64
-   | ReadOffAddrOp_Word8
-   | ReadOffAddrOp_Word16
-   | ReadOffAddrOp_Word32
-   | ReadOffAddrOp_Word64
-   | WriteOffAddrOp_Char
-   | WriteOffAddrOp_WideChar
-   | WriteOffAddrOp_Int
-   | WriteOffAddrOp_Word
-   | WriteOffAddrOp_Addr
-   | WriteOffAddrOp_Float
-   | WriteOffAddrOp_Double
-   | WriteOffAddrOp_StablePtr
-   | WriteOffAddrOp_Int8
-   | WriteOffAddrOp_Int16
-   | WriteOffAddrOp_Int32
-   | WriteOffAddrOp_Int64
-   | WriteOffAddrOp_Word8
-   | WriteOffAddrOp_Word16
-   | WriteOffAddrOp_Word32
-   | WriteOffAddrOp_Word64
-   | InterlockedExchange_Addr
-   | InterlockedExchange_Word
-   | CasAddrOp_Addr
-   | CasAddrOp_Word
-   | CasAddrOp_Word8
-   | CasAddrOp_Word16
-   | CasAddrOp_Word32
-   | CasAddrOp_Word64
-   | FetchAddAddrOp_Word
-   | FetchSubAddrOp_Word
-   | FetchAndAddrOp_Word
-   | FetchNandAddrOp_Word
-   | FetchOrAddrOp_Word
-   | FetchXorAddrOp_Word
-   | AtomicReadAddrOp_Word
-   | AtomicWriteAddrOp_Word
-   | NewMutVarOp
-   | ReadMutVarOp
-   | WriteMutVarOp
-   | AtomicModifyMutVar2Op
-   | AtomicModifyMutVar_Op
-   | CasMutVarOp
-   | CatchOp
-   | RaiseOp
-   | RaiseUnderflowOp
-   | RaiseOverflowOp
-   | RaiseDivZeroOp
-   | RaiseIOOp
-   | MaskAsyncExceptionsOp
-   | MaskUninterruptibleOp
-   | UnmaskAsyncExceptionsOp
-   | MaskStatus
-   | NewPromptTagOp
-   | PromptOp
-   | Control0Op
-   | AtomicallyOp
-   | RetryOp
-   | CatchRetryOp
-   | CatchSTMOp
-   | NewTVarOp
-   | ReadTVarOp
-   | ReadTVarIOOp
-   | WriteTVarOp
-   | NewMVarOp
-   | TakeMVarOp
-   | TryTakeMVarOp
-   | PutMVarOp
-   | TryPutMVarOp
-   | ReadMVarOp
-   | TryReadMVarOp
-   | IsEmptyMVarOp
-   | NewIOPortOp
-   | ReadIOPortOp
-   | WriteIOPortOp
-   | DelayOp
-   | WaitReadOp
-   | WaitWriteOp
-   | ForkOp
-   | ForkOnOp
-   | KillThreadOp
-   | YieldOp
-   | MyThreadIdOp
-   | LabelThreadOp
-   | IsCurrentThreadBoundOp
-   | NoDuplicateOp
-   | GetThreadLabelOp
-   | ThreadStatusOp
-   | ListThreadsOp
-   | MkWeakOp
-   | MkWeakNoFinalizerOp
-   | AddCFinalizerToWeakOp
-   | DeRefWeakOp
-   | FinalizeWeakOp
-   | TouchOp
-   | MakeStablePtrOp
-   | DeRefStablePtrOp
-   | EqStablePtrOp
-   | MakeStableNameOp
-   | StableNameToIntOp
-   | CompactNewOp
-   | CompactResizeOp
-   | CompactContainsOp
-   | CompactContainsAnyOp
-   | CompactGetFirstBlockOp
-   | CompactGetNextBlockOp
-   | CompactAllocateBlockOp
-   | CompactFixupPointersOp
-   | CompactAdd
-   | CompactAddWithSharing
-   | CompactSize
-   | ReallyUnsafePtrEqualityOp
-   | ParOp
-   | SparkOp
-   | SeqOp
-   | GetSparkOp
-   | NumSparks
-   | KeepAliveOp
-   | DataToTagOp
-   | TagToEnumOp
-   | AddrToAnyOp
-   | AnyToAddrOp
-   | MkApUpd0_Op
-   | NewBCOOp
-   | UnpackClosureOp
-   | ClosureSizeOp
-   | GetApStackValOp
-   | GetCCSOfOp
-   | GetCurrentCCSOp
-   | ClearCCSOp
-   | WhereFromOp
-   | TraceEventOp
-   | TraceEventBinaryOp
-   | TraceMarkerOp
-   | SetThreadAllocationCounter
-   | VecBroadcastOp PrimOpVecCat Length Width
-   | VecPackOp PrimOpVecCat Length Width
-   | VecUnpackOp PrimOpVecCat Length Width
-   | VecInsertOp PrimOpVecCat Length Width
-   | VecAddOp PrimOpVecCat Length Width
-   | VecSubOp PrimOpVecCat Length Width
-   | VecMulOp PrimOpVecCat Length Width
-   | VecDivOp PrimOpVecCat Length Width
-   | VecQuotOp PrimOpVecCat Length Width
-   | VecRemOp PrimOpVecCat Length Width
-   | VecNegOp PrimOpVecCat Length Width
-   | VecIndexByteArrayOp PrimOpVecCat Length Width
-   | VecReadByteArrayOp PrimOpVecCat Length Width
-   | VecWriteByteArrayOp PrimOpVecCat Length Width
-   | VecIndexOffAddrOp PrimOpVecCat Length Width
-   | VecReadOffAddrOp PrimOpVecCat Length Width
-   | VecWriteOffAddrOp PrimOpVecCat Length Width
-   | VecIndexScalarByteArrayOp PrimOpVecCat Length Width
-   | VecReadScalarByteArrayOp PrimOpVecCat Length Width
-   | VecWriteScalarByteArrayOp PrimOpVecCat Length Width
-   | VecIndexScalarOffAddrOp PrimOpVecCat Length Width
-   | VecReadScalarOffAddrOp PrimOpVecCat Length Width
-   | VecWriteScalarOffAddrOp PrimOpVecCat Length Width
-   | PrefetchByteArrayOp3
-   | PrefetchMutableByteArrayOp3
-   | PrefetchAddrOp3
-   | PrefetchValueOp3
-   | PrefetchByteArrayOp2
-   | PrefetchMutableByteArrayOp2
-   | PrefetchAddrOp2
-   | PrefetchValueOp2
-   | PrefetchByteArrayOp1
-   | PrefetchMutableByteArrayOp1
-   | PrefetchAddrOp1
-   | PrefetchValueOp1
-   | PrefetchByteArrayOp0
-   | PrefetchMutableByteArrayOp0
-   | PrefetchAddrOp0
-   | PrefetchValueOp0
diff --git a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl
+++ /dev/null
@@ -1,976 +0,0 @@
-primOpDocs =
-  [ ("*#","Low word of signed integer multiply.")
-  , ("timesInt2#","Return a triple (isHighNeeded,high,low) where high and low are respectively\n   the high and low bits of the double-word result. isHighNeeded is a cheap way\n   to test if the high word is a sign-extension of the low word (isHighNeeded =\n   0#) or not (isHighNeeded = 1#).")
-  , ("mulIntMayOflo#","Return non-zero if there is any possibility that the upper word of a\n    signed integer multiply might contain useful information.  Return\n    zero only if you are completely sure that no overflow can occur.\n    On a 32-bit platform, the recommended implementation is to do a\n    32 x 32 -> 64 signed multiply, and subtract result[63:32] from\n    (result[31] >>signed 31).  If this is zero, meaning that the\n    upper word is merely a sign extension of the lower one, no\n    overflow can occur.\n\n    On a 64-bit platform it is not always possible to\n    acquire the top 64 bits of the result.  Therefore, a recommended\n    implementation is to take the absolute value of both operands, and\n    return 0 iff bits[63:31] of them are zero, since that means that their\n    magnitudes fit within 31 bits, so the magnitude of the product must fit\n    into 62 bits.\n\n    If in doubt, return non-zero, but do make an effort to create the\n    correct answer for small args, since otherwise the performance of\n    @(*) :: Integer -> Integer -> Integer@ will be poor.\n   ")
-  , ("quotInt#","Rounds towards zero. The behavior is undefined if the second argument is\n    zero.\n   ")
-  , ("remInt#","Satisfies @('quotInt#' x y) '*#' y '+#' ('remInt#' x y) == x@. The\n    behavior is undefined if the second argument is zero.\n   ")
-  , ("quotRemInt#","Rounds towards zero.")
-  , ("andI#","Bitwise \"and\".")
-  , ("orI#","Bitwise \"or\".")
-  , ("xorI#","Bitwise \"xor\".")
-  , ("notI#","Bitwise \"not\", also known as the binary complement.")
-  , ("negateInt#","Unary negation.\n    Since the negative 'Int#' range extends one further than the\n    positive range, 'negateInt#' of the most negative number is an\n    identity operation. This way, 'negateInt#' is always its own inverse.")
-  , ("addIntC#","Add signed integers reporting overflow.\n          First member of result is the sum truncated to an 'Int#';\n          second member is zero if the true sum fits in an 'Int#',\n          nonzero if overflow occurred (the sum is either too large\n          or too small to fit in an 'Int#').")
-  , ("subIntC#","Subtract signed integers reporting overflow.\n          First member of result is the difference truncated to an 'Int#';\n          second member is zero if the true difference fits in an 'Int#',\n          nonzero if overflow occurred (the difference is either too large\n          or too small to fit in an 'Int#').")
-  , ("int2Float#","Convert an 'Int#' to the corresponding 'Float#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'int2Float#' 1# == 1.0#@")
-  , ("int2Double#","Convert an 'Int#' to the corresponding 'Double#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'int2Double#' 1# == 1.0##@")
-  , ("word2Float#","Convert an 'Word#' to the corresponding 'Float#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'word2Float#' 1## == 1.0#@")
-  , ("word2Double#","Convert an 'Word#' to the corresponding 'Double#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'word2Double#' 1## == 1.0##@")
-  , ("uncheckedIShiftL#","Shift left.  Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")
-  , ("uncheckedIShiftRA#","Shift right arithmetic.  Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")
-  , ("uncheckedIShiftRL#","Shift right logical.  Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")
-  , ("addWordC#","Add unsigned integers reporting overflow.\n          The first element of the pair is the result.  The second element is\n          the carry flag, which is nonzero on overflow. See also 'plusWord2#'.")
-  , ("subWordC#","Subtract unsigned integers reporting overflow.\n          The first element of the pair is the result.  The second element is\n          the carry flag, which is nonzero on overflow.")
-  , ("plusWord2#","Add unsigned integers, with the high part (carry) in the first\n          component of the returned pair and the low part in the second\n          component of the pair. See also 'addWordC#'.")
-  , ("quotRemWord2#"," Takes high word of dividend, then low word of dividend, then divisor.\n           Requires that high word < divisor.")
-  , ("uncheckedShiftL#","Shift left logical.   Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")
-  , ("uncheckedShiftRL#","Shift right logical.   Result undefined if shift  amount is not\n          in the range 0 to word size - 1 inclusive.")
-  , ("popCnt8#","Count the number of set bits in the lower 8 bits of a word.")
-  , ("popCnt16#","Count the number of set bits in the lower 16 bits of a word.")
-  , ("popCnt32#","Count the number of set bits in the lower 32 bits of a word.")
-  , ("popCnt64#","Count the number of set bits in a 64-bit word.")
-  , ("popCnt#","Count the number of set bits in a word.")
-  , ("pdep8#","Deposit bits to lower 8 bits of a word at locations specified by a mask.")
-  , ("pdep16#","Deposit bits to lower 16 bits of a word at locations specified by a mask.")
-  , ("pdep32#","Deposit bits to lower 32 bits of a word at locations specified by a mask.")
-  , ("pdep64#","Deposit bits to a word at locations specified by a mask.")
-  , ("pdep#","Deposit bits to a word at locations specified by a mask.")
-  , ("pext8#","Extract bits from lower 8 bits of a word at locations specified by a mask.")
-  , ("pext16#","Extract bits from lower 16 bits of a word at locations specified by a mask.")
-  , ("pext32#","Extract bits from lower 32 bits of a word at locations specified by a mask.")
-  , ("pext64#","Extract bits from a word at locations specified by a mask.")
-  , ("pext#","Extract bits from a word at locations specified by a mask.")
-  , ("clz8#","Count leading zeros in the lower 8 bits of a word.")
-  , ("clz16#","Count leading zeros in the lower 16 bits of a word.")
-  , ("clz32#","Count leading zeros in the lower 32 bits of a word.")
-  , ("clz64#","Count leading zeros in a 64-bit word.")
-  , ("clz#","Count leading zeros in a word.")
-  , ("ctz8#","Count trailing zeros in the lower 8 bits of a word.")
-  , ("ctz16#","Count trailing zeros in the lower 16 bits of a word.")
-  , ("ctz32#","Count trailing zeros in the lower 32 bits of a word.")
-  , ("ctz64#","Count trailing zeros in a 64-bit word.")
-  , ("ctz#","Count trailing zeros in a word.")
-  , ("byteSwap16#","Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. ")
-  , ("byteSwap32#","Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. ")
-  , ("byteSwap64#","Swap bytes in a 64 bits of a word.")
-  , ("byteSwap#","Swap bytes in a word.")
-  , ("bitReverse8#","Reverse the order of the bits in a 8-bit word.")
-  , ("bitReverse16#","Reverse the order of the bits in a 16-bit word.")
-  , ("bitReverse32#","Reverse the order of the bits in a 32-bit word.")
-  , ("bitReverse64#","Reverse the order of the bits in a 64-bit word.")
-  , ("bitReverse#","Reverse the order of the bits in a word.")
-  , ("double2Int#","Truncates a 'Double#' value to the nearest 'Int#'.\n    Results are undefined if the truncation if truncation yields\n    a value outside the range of 'Int#'.")
-  , ("**##","Exponentiation.")
-  , ("decodeDouble_2Int#","Convert to integer.\n    First component of the result is -1 or 1, indicating the sign of the\n    mantissa. The next two are the high and low 32 bits of the mantissa\n    respectively, and the last is the exponent.")
-  , ("decodeDouble_Int64#","Decode 'Double#' into mantissa and base-2 exponent.")
-  , ("float2Int#","Truncates a 'Float#' value to the nearest 'Int#'.\n    Results are undefined if the truncation if truncation yields\n    a value outside the range of 'Int#'.")
-  , ("decodeFloat_Int#","Convert to integers.\n    First 'Int#' in result is the mantissa; second is the exponent.")
-  , ("newArray#","Create a new mutable array with the specified number of elements,\n    in the specified state thread,\n    with each element containing the specified initial value.")
-  , ("readArray#","Read from specified index of mutable array. Result is not yet evaluated.")
-  , ("writeArray#","Write to specified index of mutable array.")
-  , ("sizeofArray#","Return the number of elements in the array.")
-  , ("sizeofMutableArray#","Return the number of elements in the array.")
-  , ("indexArray#","Read from the specified index of an immutable array. The result is packaged\n    into an unboxed unary tuple; the result itself is not yet\n    evaluated. Pattern matching on the tuple forces the indexing of the\n    array to happen but does not evaluate the element itself. Evaluating\n    the thunk prevents additional thunks from building up on the\n    heap. Avoiding these thunks, in turn, reduces references to the\n    argument array, allowing it to be garbage collected more promptly.")
-  , ("unsafeFreezeArray#","Make a mutable array immutable, without copying.")
-  , ("unsafeThawArray#","Make an immutable array mutable, without copying.")
-  , ("copyArray#","Given a source array, an offset into the source array, a\n   destination array, an offset into the destination array, and a\n   number of elements to copy, copy the elements from the source array\n   to the destination array. Both arrays must fully contain the\n   specified ranges, but this is not checked. The two arrays must not\n   be the same array in different states, but this is not checked\n   either.")
-  , ("copyMutableArray#","Given a source array, an offset into the source array, a\n   destination array, an offset into the destination array, and a\n   number of elements to copy, copy the elements from the source array\n   to the destination array. Both arrays must fully contain the\n   specified ranges, but this is not checked. In the case where\n   the source and destination are the same array the source and\n   destination regions may overlap.")
-  , ("cloneArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")
-  , ("cloneMutableArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")
-  , ("freezeArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")
-  , ("thawArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")
-  , ("casArray#","Given an array, an offset, the expected old value, and\n    the new value, perform an atomic compare and swap (i.e. write the new\n    value if the current value and the old value are the same pointer).\n    Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns\n    the element at the offset after the operation completes. This means that\n    on a success the new value is returned, and on a failure the actual old\n    value (not the expected one) is returned. Implies a full memory barrier.\n    The use of a pointer equality on a boxed value makes this function harder\n    to use correctly than 'casIntArray#'. All of the difficulties\n    of using 'reallyUnsafePtrEquality#' correctly apply to\n    'casArray#' as well.\n   ")
-  , ("newSmallArray#","Create a new mutable array with the specified number of elements,\n    in the specified state thread,\n    with each element containing the specified initial value.")
-  , ("shrinkSmallMutableArray#","Shrink mutable array to new specified size, in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by 'getSizeofSmallMutableArray#'.")
-  , ("readSmallArray#","Read from specified index of mutable array. Result is not yet evaluated.")
-  , ("writeSmallArray#","Write to specified index of mutable array.")
-  , ("sizeofSmallArray#","Return the number of elements in the array.")
-  , ("sizeofSmallMutableArray#","Return the number of elements in the array. Note that this is deprecated\n   as it is unsafe in the presence of shrink and resize operations on the\n   same small mutable array.")
-  , ("getSizeofSmallMutableArray#","Return the number of elements in the array.")
-  , ("indexSmallArray#","Read from specified index of immutable array. Result is packaged into\n    an unboxed singleton; the result itself is not yet evaluated.")
-  , ("unsafeFreezeSmallArray#","Make a mutable array immutable, without copying.")
-  , ("unsafeThawSmallArray#","Make an immutable array mutable, without copying.")
-  , ("copySmallArray#","Given a source array, an offset into the source array, a\n   destination array, an offset into the destination array, and a\n   number of elements to copy, copy the elements from the source array\n   to the destination array. Both arrays must fully contain the\n   specified ranges, but this is not checked. The two arrays must not\n   be the same array in different states, but this is not checked\n   either.")
-  , ("copySmallMutableArray#","Given a source array, an offset into the source array, a\n   destination array, an offset into the destination array, and a\n   number of elements to copy, copy the elements from the source array\n   to the destination array. The source and destination arrays can\n   refer to the same array. Both arrays must fully contain the\n   specified ranges, but this is not checked.\n   The regions are allowed to overlap, although this is only possible when the same\n   array is provided as both the source and the destination. ")
-  , ("cloneSmallArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")
-  , ("cloneSmallMutableArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")
-  , ("freezeSmallArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")
-  , ("thawSmallArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")
-  , ("casSmallArray#","Unsafe, machine-level atomic compare and swap on an element within an array.\n    See the documentation of 'casArray#'.")
-  , ("ByteArray#","\n  A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap,\n  which is not scanned for pointers during garbage collection.\n\n  It is created by freezing a 'MutableByteArray#' with 'unsafeFreezeByteArray#'.\n  Freezing is essentially a no-op, as 'MutableByteArray#' and 'ByteArray#' share the same heap structure under the hood.\n\n  The immutable and mutable variants are commonly used for scenarios requiring high-performance data structures,\n  like @Text@, @Primitive Vector@, @Unboxed Array@, and @ShortByteString@.\n\n  Another application of fundamental importance is 'Integer', which is backed by 'ByteArray#'.\n\n  The representation on the heap of a Byte Array is:\n\n  > +------------+-----------------+-----------------------+\n  > |            |                 |                       |\n  > |   HEADER   | SIZE (in bytes) |       PAYLOAD         |\n  > |            |                 |                       |\n  > +------------+-----------------+-----------------------+\n\n  To obtain a pointer to actual payload (e.g., for FFI purposes) use 'byteArrayContents#' or 'mutableByteArrayContents#'.\n\n  Alternatively, enabling the @UnliftedFFITypes@ extension\n  allows to mention 'ByteArray#' and 'MutableByteArray#' in FFI type signatures directly.\n")
-  , ("MutableByteArray#"," A mutable 'ByteAray#'. It can be created in three ways:\n\n  * 'newByteArray#': Create an unpinned array.\n  * 'newPinnedByteArray#': This will create a pinned array,\n  * 'newAlignedPinnedByteArray#': This will create a pinned array, with a custom alignment.\n\n  Unpinned arrays can be moved around during garbage collection, so you must not store or pass pointers to these values\n  if there is a chance for the garbage collector to kick in. That said, even unpinned arrays can be passed to unsafe FFI calls,\n  because no garbage collection happens during these unsafe calls\n  (see [Guaranteed Call Safety](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#guaranteed-call-safety)\n  in the GHC Manual). For safe FFI calls, byte arrays must be not only pinned, but also kept alive by means of the keepAlive# function\n  for the duration of a call (that's because garbage collection cannot move a pinned array, but is free to scrap it altogether).\n")
-  , ("newByteArray#","Create a new mutable byte array of specified size (in bytes), in\n    the specified state thread. The size of the memory underlying the\n    array will be rounded up to the platform's word size.")
-  , ("newPinnedByteArray#","Like 'newByteArray#' but GC guarantees not to move it.")
-  , ("newAlignedPinnedByteArray#","Like 'newPinnedByteArray#' but allow specifying an arbitrary\n    alignment, which must be a power of two.")
-  , ("isMutableByteArrayPinned#","Determine whether a 'MutableByteArray#' is guaranteed not to move\n   during GC.")
-  , ("isByteArrayPinned#","Determine whether a 'ByteArray#' is guaranteed not to move during GC.")
-  , ("byteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!")
-  , ("mutableByteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!")
-  , ("shrinkMutableByteArray#","Shrink mutable byte array to new specified size (in bytes), in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by 'getSizeofMutableByteArray#'.")
-  , ("resizeMutableByteArray#","Resize (unpinned) mutable byte array to new specified size (in bytes).\n    The returned 'MutableByteArray#' is either the original\n    'MutableByteArray#' resized in-place or, if not possible, a newly\n    allocated (unpinned) 'MutableByteArray#' (with the original content\n    copied over).\n\n    To avoid undefined behaviour, the original 'MutableByteArray#' shall\n    not be accessed anymore after a 'resizeMutableByteArray#' has been\n    performed.  Moreover, no reference to the old one should be kept in order\n    to allow garbage collection of the original 'MutableByteArray#' in\n    case a new 'MutableByteArray#' had to be allocated.")
-  , ("unsafeFreezeByteArray#","Make a mutable byte array immutable, without copying.")
-  , ("sizeofByteArray#","Return the size of the array in bytes.")
-  , ("sizeofMutableByteArray#","Return the size of the array in bytes. Note that this is deprecated as it is\n   unsafe in the presence of shrink and resize operations on the same mutable byte\n   array.")
-  , ("getSizeofMutableByteArray#","Return the number of elements in the array.")
-  , ("indexCharArray#","Read a 8-bit character; offset in bytes.")
-  , ("indexWideCharArray#","Read a 32-bit character; offset in 4-byte words.")
-  , ("indexIntArray#","Read a word-sized integer; offset in machine words.")
-  , ("indexWordArray#","Read a word-sized unsigned integer; offset in machine words.")
-  , ("indexAddrArray#","Read a machine address; offset in machine words.")
-  , ("indexFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.")
-  , ("indexDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.")
-  , ("indexStablePtrArray#","Read a 'StablePtr#' value; offset in machine words.")
-  , ("indexInt8Array#","Read a 8-bit signed integer; offset in bytes.")
-  , ("indexInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.")
-  , ("indexInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.")
-  , ("indexInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.")
-  , ("indexWord8Array#","Read a 8-bit unsigned integer; offset in bytes.")
-  , ("indexWord16Array#","Read a 16-bit unsigned integer; offset in 2-byte words.")
-  , ("indexWord32Array#","Read a 32-bit unsigned integer; offset in 4-byte words.")
-  , ("indexWord64Array#","Read a 64-bit unsigned integer; offset in 8-byte words.")
-  , ("indexWord8ArrayAsChar#","Read a 8-bit character; offset in bytes.")
-  , ("indexWord8ArrayAsWideChar#","Read a 32-bit character; offset in bytes.")
-  , ("indexWord8ArrayAsInt#","Read a word-sized integer; offset in bytes.")
-  , ("indexWord8ArrayAsWord#","Read a word-sized unsigned integer; offset in bytes.")
-  , ("indexWord8ArrayAsAddr#","Read a machine address; offset in bytes.")
-  , ("indexWord8ArrayAsFloat#","Read a single-precision floating-point value; offset in bytes.")
-  , ("indexWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.")
-  , ("indexWord8ArrayAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.")
-  , ("indexWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.")
-  , ("indexWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.")
-  , ("indexWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.")
-  , ("indexWord8ArrayAsWord16#","Read a 16-bit unsigned integer; offset in bytes.")
-  , ("indexWord8ArrayAsWord32#","Read a 32-bit unsigned integer; offset in bytes.")
-  , ("indexWord8ArrayAsWord64#","Read a 64-bit unsigned integer; offset in bytes.")
-  , ("readCharArray#","Read a 8-bit character; offset in bytes.")
-  , ("readWideCharArray#","Read a 32-bit character; offset in 4-byte words.")
-  , ("readIntArray#","Read a word-sized integer; offset in machine words.")
-  , ("readWordArray#","Read a word-sized unsigned integer; offset in machine words.")
-  , ("readAddrArray#","Read a machine address; offset in machine words.")
-  , ("readFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.")
-  , ("readDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.")
-  , ("readStablePtrArray#","Read a 'StablePtr#' value; offset in machine words.")
-  , ("readInt8Array#","Read a 8-bit signed integer; offset in bytes.")
-  , ("readInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.")
-  , ("readInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.")
-  , ("readInt64Array#","Read a 64-bit signed integer; offset in 8-byte words.")
-  , ("readWord8Array#","Read a 8-bit unsigned integer; offset in bytes.")
-  , ("readWord16Array#","Read a 16-bit unsigned integer; offset in 2-byte words.")
-  , ("readWord32Array#","Read a 32-bit unsigned integer; offset in 4-byte words.")
-  , ("readWord64Array#","Read a 64-bit unsigned integer; offset in 8-byte words.")
-  , ("readWord8ArrayAsChar#","Read a 8-bit character; offset in bytes.")
-  , ("readWord8ArrayAsWideChar#","Read a 32-bit character; offset in bytes.")
-  , ("readWord8ArrayAsInt#","Read a word-sized integer; offset in bytes.")
-  , ("readWord8ArrayAsWord#","Read a word-sized unsigned integer; offset in bytes.")
-  , ("readWord8ArrayAsAddr#","Read a machine address; offset in bytes.")
-  , ("readWord8ArrayAsFloat#","Read a single-precision floating-point value; offset in bytes.")
-  , ("readWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.")
-  , ("readWord8ArrayAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.")
-  , ("readWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.")
-  , ("readWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.")
-  , ("readWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.")
-  , ("readWord8ArrayAsWord16#","Read a 16-bit unsigned integer; offset in bytes.")
-  , ("readWord8ArrayAsWord32#","Read a 32-bit unsigned integer; offset in bytes.")
-  , ("readWord8ArrayAsWord64#","Read a 64-bit unsigned integer; offset in bytes.")
-  , ("writeCharArray#","Write a 8-bit character; offset in bytes.")
-  , ("writeWideCharArray#","Write a 32-bit character; offset in 4-byte words.")
-  , ("writeIntArray#","Write a word-sized integer; offset in machine words.")
-  , ("writeWordArray#","Write a word-sized unsigned integer; offset in machine words.")
-  , ("writeAddrArray#","Write a machine address; offset in machine words.")
-  , ("writeFloatArray#","Write a single-precision floating-point value; offset in 4-byte words.")
-  , ("writeDoubleArray#","Write a double-precision floating-point value; offset in 8-byte words.")
-  , ("writeStablePtrArray#","Write a 'StablePtr#' value; offset in machine words.")
-  , ("writeInt8Array#","Write a 8-bit signed integer; offset in bytes.")
-  , ("writeInt16Array#","Write a 16-bit signed integer; offset in 2-byte words.")
-  , ("writeInt32Array#","Write a 32-bit signed integer; offset in 4-byte words.")
-  , ("writeInt64Array#","Write a 64-bit signed integer; offset in 8-byte words.")
-  , ("writeWord8Array#","Write a 8-bit unsigned integer; offset in bytes.")
-  , ("writeWord16Array#","Write a 16-bit unsigned integer; offset in 2-byte words.")
-  , ("writeWord32Array#","Write a 32-bit unsigned integer; offset in 4-byte words.")
-  , ("writeWord64Array#","Write a 64-bit unsigned integer; offset in 8-byte words.")
-  , ("writeWord8ArrayAsChar#","Write a 8-bit character; offset in bytes.")
-  , ("writeWord8ArrayAsWideChar#","Write a 32-bit character; offset in bytes.")
-  , ("writeWord8ArrayAsInt#","Write a word-sized integer; offset in bytes.")
-  , ("writeWord8ArrayAsWord#","Write a word-sized unsigned integer; offset in bytes.")
-  , ("writeWord8ArrayAsAddr#","Write a machine address; offset in bytes.")
-  , ("writeWord8ArrayAsFloat#","Write a single-precision floating-point value; offset in bytes.")
-  , ("writeWord8ArrayAsDouble#","Write a double-precision floating-point value; offset in bytes.")
-  , ("writeWord8ArrayAsStablePtr#","Write a 'StablePtr#' value; offset in bytes.")
-  , ("writeWord8ArrayAsInt16#","Write a 16-bit signed integer; offset in bytes.")
-  , ("writeWord8ArrayAsInt32#","Write a 32-bit signed integer; offset in bytes.")
-  , ("writeWord8ArrayAsInt64#","Write a 64-bit signed integer; offset in bytes.")
-  , ("writeWord8ArrayAsWord16#","Write a 16-bit unsigned integer; offset in bytes.")
-  , ("writeWord8ArrayAsWord32#","Write a 32-bit unsigned integer; offset in bytes.")
-  , ("writeWord8ArrayAsWord64#","Write a 64-bit unsigned integer; offset in bytes.")
-  , ("compareByteArrays#","@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares\n    @n@ bytes starting at offset @src1_ofs@ in the first\n    'ByteArray#' @src1@ to the range of @n@ bytes\n    (i.e. same length) starting at offset @src2_ofs@ of the second\n    'ByteArray#' @src2@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  Returns an 'Int#'\n    less than, equal to, or greater than zero if the range is found,\n    respectively, to be byte-wise lexicographically less than, to\n    match, or be greater than the second range.")
-  , ("copyByteArray#","@'copyByteArray#' src src_ofs dst dst_ofs n@ copies the range\n   starting at offset @src_ofs@ of length @n@ from the\n   'ByteArray#' @src@ to the 'MutableByteArray#' @dst@\n   starting at offset @dst_ofs@.  Both arrays must fully contain\n   the specified ranges, but this is not checked.  The two arrays must\n   not be the same array in different states, but this is not checked\n   either.")
-  , ("copyMutableByteArray#","Copy a range of the first MutableByteArray\\# to the specified region in the second MutableByteArray\\#.\n   Both arrays must fully contain the specified ranges, but this is not checked. The regions are\n   allowed to overlap, although this is only possible when the same array is provided\n   as both the source and the destination.")
-  , ("copyByteArrayToAddr#","Copy a range of the ByteArray\\# to the memory range starting at the Addr\\#.\n   The ByteArray\\# and the memory region at Addr\\# must fully contain the\n   specified ranges, but this is not checked. The Addr\\# must not point into the\n   ByteArray\\# (e.g. if the ByteArray\\# were pinned), but this is not checked\n   either.")
-  , ("copyMutableByteArrayToAddr#","Copy a range of the MutableByteArray\\# to the memory range starting at the\n   Addr\\#. The MutableByteArray\\# and the memory region at Addr\\# must fully\n   contain the specified ranges, but this is not checked. The Addr\\# must not\n   point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were\n   pinned), but this is not checked either.")
-  , ("copyAddrToByteArray#","Copy a memory range starting at the Addr\\# to the specified range in the\n   MutableByteArray\\#. The memory region at Addr\\# and the ByteArray\\# must fully\n   contain the specified ranges, but this is not checked. The Addr\\# must not\n   point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were pinned),\n   but this is not checked either.")
-  , ("setByteArray#","@'setByteArray#' ba off len c@ sets the byte range @[off, off+len)@ of\n   the 'MutableByteArray#' to the byte @c@.")
-  , ("atomicReadIntArray#","Given an array and an offset in machine words, read an element. The\n    index is assumed to be in bounds. Implies a full memory barrier.")
-  , ("atomicWriteIntArray#","Given an array and an offset in machine words, write an element. The\n    index is assumed to be in bounds. Implies a full memory barrier.")
-  , ("casIntArray#","Given an array, an offset in machine words, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")
-  , ("casInt8Array#","Given an array, an offset in bytes, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")
-  , ("casInt16Array#","Given an array, an offset in 16 bit units, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")
-  , ("casInt32Array#","Given an array, an offset in 32 bit units, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")
-  , ("casInt64Array#","Given an array, an offset in 64 bit units, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")
-  , ("fetchAddIntArray#","Given an array, and offset in machine words, and a value to add,\n    atomically add the value to the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")
-  , ("fetchSubIntArray#","Given an array, and offset in machine words, and a value to subtract,\n    atomically subtract the value from the element. Returns the value of\n    the element before the operation. Implies a full memory barrier.")
-  , ("fetchAndIntArray#","Given an array, and offset in machine words, and a value to AND,\n    atomically AND the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")
-  , ("fetchNandIntArray#","Given an array, and offset in machine words, and a value to NAND,\n    atomically NAND the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")
-  , ("fetchOrIntArray#","Given an array, and offset in machine words, and a value to OR,\n    atomically OR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")
-  , ("fetchXorIntArray#","Given an array, and offset in machine words, and a value to XOR,\n    atomically XOR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")
-  , ("Addr#"," An arbitrary machine address assumed to point outside\n         the garbage-collected heap. ")
-  , ("nullAddr#"," The null address. ")
-  , ("minusAddr#","Result is meaningless if two 'Addr#'s are so far apart that their\n         difference doesn't fit in an 'Int#'.")
-  , ("remAddr#","Return the remainder when the 'Addr#' arg, treated like an 'Int#',\n          is divided by the 'Int#' arg.")
-  , ("addr2Int#","Coerce directly from address to int.")
-  , ("int2Addr#","Coerce directly from int to address.")
-  , ("indexCharOffAddr#","Reads 8-bit character; offset in bytes.")
-  , ("indexWideCharOffAddr#","Reads 31-bit character; offset in 4-byte words.")
-  , ("readCharOffAddr#","Reads 8-bit character; offset in bytes.")
-  , ("readWideCharOffAddr#","Reads 31-bit character; offset in 4-byte words.")
-  , ("atomicExchangeAddrAddr#","The atomic exchange operation. Atomically exchanges the value at the first address\n    with the Addr# given as second argument. Implies a read barrier.")
-  , ("atomicExchangeWordAddr#","The atomic exchange operation. Atomically exchanges the value at the address\n    with the given value. Returns the old value. Implies a read barrier.")
-  , ("atomicCasAddrAddr#"," Compare and swap on a word-sized memory location.\n\n     Use as: \\s -> atomicCasAddrAddr# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")
-  , ("atomicCasWordAddr#"," Compare and swap on a word-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")
-  , ("atomicCasWord8Addr#"," Compare and swap on a 8 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr8# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")
-  , ("atomicCasWord16Addr#"," Compare and swap on a 16 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr16# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")
-  , ("atomicCasWord32Addr#"," Compare and swap on a 32 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr32# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")
-  , ("atomicCasWord64Addr#"," Compare and swap on a 64 bit-sized and aligned memory location.\n\n     Use as: \\s -> atomicCasWordAddr64# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")
-  , ("fetchAddWordAddr#","Given an address, and a value to add,\n    atomically add the value to the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")
-  , ("fetchSubWordAddr#","Given an address, and a value to subtract,\n    atomically subtract the value from the element. Returns the value of\n    the element before the operation. Implies a full memory barrier.")
-  , ("fetchAndWordAddr#","Given an address, and a value to AND,\n    atomically AND the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")
-  , ("fetchNandWordAddr#","Given an address, and a value to NAND,\n    atomically NAND the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")
-  , ("fetchOrWordAddr#","Given an address, and a value to OR,\n    atomically OR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")
-  , ("fetchXorWordAddr#","Given an address, and a value to XOR,\n    atomically XOR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")
-  , ("atomicReadWordAddr#","Given an address, read a machine word.  Implies a full memory barrier.")
-  , ("atomicWriteWordAddr#","Given an address, write a machine word. Implies a full memory barrier.")
-  , ("MutVar#","A 'MutVar#' behaves like a single-element mutable array.")
-  , ("newMutVar#","Create 'MutVar#' with specified initial value in specified state thread.")
-  , ("readMutVar#","Read contents of 'MutVar#'. Result is not yet evaluated.")
-  , ("writeMutVar#","Write contents of 'MutVar#'.")
-  , ("atomicModifyMutVar2#"," Modify the contents of a 'MutVar#', returning the previous\n     contents and the result of applying the given function to the\n     previous contents. Note that this isn't strictly\n     speaking the correct type for this function; it should really be\n     @'MutVar#' s a -> (a -> (a,b)) -> 'State#' s -> (# 'State#' s, a, (a, b) #)@,\n     but we don't know about pairs here. ")
-  , ("atomicModifyMutVar_#"," Modify the contents of a 'MutVar#', returning the previous\n     contents and the result of applying the given function to the\n     previous contents. ")
-  , ("casMutVar#"," Compare-and-swap: perform a pointer equality test between\n     the first value passed to this function and the value\n     stored inside the 'MutVar#'. If the pointers are equal,\n     replace the stored value with the second value passed to this\n     function, otherwise do nothing.\n     Returns the final value stored inside the 'MutVar#'.\n     The 'Int#' indicates whether a swap took place,\n     with @1#@ meaning that we didn't swap, and @0#@\n     that we did.\n     Implies a full memory barrier.\n     Because the comparison is done on the level of pointers,\n     all of the difficulties of using\n     'reallyUnsafePtrEquality#' correctly apply to\n     'casMutVar#' as well.\n   ")
-  , ("catch#"," @'catch#' k handler s@ evaluates @k s@, invoking @handler@ on any exceptions\n     thrown.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")
-  , ("maskAsyncExceptions#"," @'maskAsyncExceptions#' k s@ evaluates @k s@ such that asynchronous\n     exceptions are deferred until after evaluation has finished.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")
-  , ("maskUninterruptible#"," @'maskUninterruptible#' k s@ evaluates @k s@ such that asynchronous\n     exceptions are deferred until after evaluation has finished.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")
-  , ("unmaskAsyncExceptions#"," @'unmaskAsyncUninterruptible#' k s@ evaluates @k s@ such that asynchronous\n     exceptions are unmasked.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")
-  , ("PromptTag#"," See \"GHC.Prim#continuations\". ")
-  , ("newPromptTag#"," See \"GHC.Prim#continuations\". ")
-  , ("prompt#"," See \"GHC.Prim#continuations\". ")
-  , ("control0#"," See \"GHC.Prim#continuations\". ")
-  , ("newTVar#","Create a new 'TVar#' holding a specified initial value.")
-  , ("readTVar#","Read contents of 'TVar#' inside an STM transaction,\n    i.e. within a call to 'atomically#'.\n    Does not force evaluation of the result.")
-  , ("readTVarIO#","Read contents of 'TVar#' outside an STM transaction.\n   Does not force evaluation of the result.")
-  , ("writeTVar#","Write contents of 'TVar#'.")
-  , ("MVar#"," A shared mutable variable (/not/ the same as a 'MutVar#'!).\n        (Note: in a non-concurrent implementation, @('MVar#' a)@ can be\n        represented by @('MutVar#' (Maybe a))@.) ")
-  , ("newMVar#","Create new 'MVar#'; initially empty.")
-  , ("takeMVar#","If 'MVar#' is empty, block until it becomes full.\n   Then remove and return its contents, and set it empty.")
-  , ("tryTakeMVar#","If 'MVar#' is empty, immediately return with integer 0 and value undefined.\n   Otherwise, return with integer 1 and contents of 'MVar#', and set 'MVar#' empty.")
-  , ("putMVar#","If 'MVar#' is full, block until it becomes empty.\n   Then store value arg as its new contents.")
-  , ("tryPutMVar#","If 'MVar#' is full, immediately return with integer 0.\n    Otherwise, store value arg as 'MVar#''s new contents, and return with integer 1.")
-  , ("readMVar#","If 'MVar#' is empty, block until it becomes full.\n   Then read its contents without modifying the MVar, without possibility\n   of intervention from other threads.")
-  , ("tryReadMVar#","If 'MVar#' is empty, immediately return with integer 0 and value undefined.\n   Otherwise, return with integer 1 and contents of 'MVar#'.")
-  , ("isEmptyMVar#","Return 1 if 'MVar#' is empty; 0 otherwise.")
-  , ("IOPort#"," A shared I/O port is almost the same as an 'MVar#'.\n        The main difference is that IOPort has no deadlock detection or\n        deadlock breaking code that forcibly releases the lock. ")
-  , ("newIOPort#","Create new 'IOPort#'; initially empty.")
-  , ("readIOPort#","If 'IOPort#' is empty, block until it becomes full.\n   Then remove and return its contents, and set it empty.\n   Throws an 'IOPortException' if another thread is already\n   waiting to read this 'IOPort#'.")
-  , ("writeIOPort#","If 'IOPort#' is full, immediately return with integer 0,\n    throwing an 'IOPortException'.\n    Otherwise, store value arg as 'IOPort#''s new contents,\n    and return with integer 1. ")
-  , ("delay#","Sleep specified number of microseconds.")
-  , ("waitRead#","Block until input is available on specified file descriptor.")
-  , ("waitWrite#","Block until output is possible on specified file descriptor.")
-  , ("State#"," 'State#' is the primitive, unlifted type of states.  It has\n        one type parameter, thus @'State#' 'RealWorld'@, or @'State#' s@,\n        where s is a type variable. The only purpose of the type parameter\n        is to keep different state threads separate.  It is represented by\n        nothing at all. ")
-  , ("RealWorld"," 'RealWorld' is deeply magical.  It is /primitive/, but it is not\n        /unlifted/ (hence @ptrArg@).  We never manipulate values of type\n        'RealWorld'; it's only used in the type system, to parameterise 'State#'. ")
-  , ("ThreadId#","(In a non-concurrent implementation, this can be a singleton\n        type, whose (unique) value is returned by 'myThreadId#'.  The\n        other operations can be omitted.)")
-  , ("labelThread#","Set the label of the given thread. The @ByteArray#@ should contain\n    a UTF-8-encoded string.")
-  , ("threadLabel#","Get the label of the given thread.\n    Morally of type @ThreadId# -> IO (Maybe ByteArray#)@, with a @1#@ tag\n    denoting @Just@.\n\n    @since 0.10")
-  , ("threadStatus#","Get the status of the given thread. Result is\n    @(ThreadStatus, Capability, Locked)@ where\n    @ThreadStatus@ is one of the status constants defined in\n    @rts/Constants.h@, @Capability@ is the number of\n    the capability which currently owns the thread, and\n    @Locked@ is a boolean indicating whether the\n    thread is bound to that capability.\n\n    @since 0.9")
-  , ("listThreads#"," Returns an array of the threads started by the program. Note that this\n     threads which have finished execution may or may not be present in this\n     list, depending upon whether they have been collected by the garbage collector.\n\n     @since 0.10")
-  , ("mkWeak#"," @'mkWeak#' k v finalizer s@ creates a weak reference to value @k@,\n     with an associated reference to some value @v@. If @k@ is still\n     alive then @v@ can be retrieved using 'deRefWeak#'. Note that\n     the type of @k@ must be represented by a pointer (i.e. of kind\n     @'TYPE' ''LiftedRep' or @'TYPE' ''UnliftedRep'@). ")
-  , ("addCFinalizerToWeak#"," @'addCFinalizerToWeak#' fptr ptr flag eptr w@ attaches a C\n     function pointer @fptr@ to a weak pointer @w@ as a finalizer. If\n     @flag@ is zero, @fptr@ will be called with one argument,\n     @ptr@. Otherwise, it will be called with two arguments,\n     @eptr@ and @ptr@. 'addCFinalizerToWeak#' returns\n     1 on success, or 0 if @w@ is already dead. ")
-  , ("finalizeWeak#"," Finalize a weak pointer. The return value is an unboxed tuple\n     containing the new state of the world and an \"unboxed Maybe\",\n     represented by an 'Int#' and a (possibly invalid) finalization\n     action. An 'Int#' of @1@ indicates that the finalizer is valid. The\n     return value @b@ from the finalizer should be ignored. ")
-  , ("compactNew#"," Create a new CNF with a single compact block. The argument is\n     the capacity of the compact block (in bytes, not words).\n     The capacity is rounded up to a multiple of the allocator block size\n     and is capped to one mega block. ")
-  , ("compactResize#"," Set the new allocation size of the CNF. This value (in bytes)\n     determines the capacity of each compact block in the CNF. It\n     does not retroactively affect existing compact blocks in the CNF. ")
-  , ("compactContains#"," Returns 1\\# if the object is contained in the CNF, 0\\# otherwise. ")
-  , ("compactContainsAny#"," Returns 1\\# if the object is in any CNF at all, 0\\# otherwise. ")
-  , ("compactGetFirstBlock#"," Returns the address and the utilized size (in bytes) of the\n     first compact block of a CNF.")
-  , ("compactGetNextBlock#"," Given a CNF and the address of one its compact blocks, returns the\n     next compact block and its utilized size, or 'nullAddr#' if the\n     argument was the last compact block in the CNF. ")
-  , ("compactAllocateBlock#"," Attempt to allocate a compact block with the capacity (in\n     bytes) given by the first argument. The 'Addr#' is a pointer\n     to previous compact block of the CNF or 'nullAddr#' to create a\n     new CNF with a single compact block.\n\n     The resulting block is not known to the GC until\n     'compactFixupPointers#' is called on it, and care must be taken\n     so that the address does not escape or memory will be leaked.\n   ")
-  , ("compactFixupPointers#"," Given the pointer to the first block of a CNF and the\n     address of the root object in the old address space, fix up\n     the internal pointers inside the CNF to account for\n     a different position in memory than when it was serialized.\n     This method must be called exactly once after importing\n     a serialized CNF. It returns the new CNF and the new adjusted\n     root address. ")
-  , ("compactAdd#"," Recursively add a closure and its transitive closure to a\n     'Compact#' (a CNF), evaluating any unevaluated components\n     at the same time. Note: 'compactAdd#' is not thread-safe, so\n     only one thread may call 'compactAdd#' with a particular\n     'Compact#' at any given time. The primop does not\n     enforce any mutual exclusion; the caller is expected to\n     arrange this. ")
-  , ("compactAddWithSharing#"," Like 'compactAdd#', but retains sharing and cycles\n   during compaction. ")
-  , ("compactSize#"," Return the total capacity (in bytes) of all the compact blocks\n     in the CNF. ")
-  , ("reallyUnsafePtrEquality#"," Returns @1#@ if the given pointers are equal and @0#@ otherwise. ")
-  , ("numSparks#"," Returns the number of sparks in the local spark pool. ")
-  , ("keepAlive#"," @'keepAlive#' x s k@ keeps the value @x@ alive during the execution\n     of the computation @k@.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")
-  , ("dataToTag#"," Evaluates the argument and returns the tag of the result.\n     Tags are Zero-indexed; the first constructor has tag zero. ")
-  , ("BCO"," Primitive bytecode type. ")
-  , ("addrToAny#"," Convert an 'Addr#' to a followable Any type. ")
-  , ("anyToAddr#"," Retrieve the address of any Haskell value. This is\n     essentially an 'unsafeCoerce#', but if implemented as such\n     the core lint pass complains and fails to compile.\n     As a primop, it is opaque to core/stg, and only appears\n     in cmm (where the copy propagation pass will get rid of it).\n     Note that \"a\" must be a value, not a thunk! It's too late\n     for strictness analysis to enforce this, so you're on your\n     own to guarantee this. Also note that 'Addr#' is not a GC\n     pointer - up to you to guarantee that it does not become\n     a dangling pointer immediately after you get it.")
-  , ("mkApUpd0#"," Wrap a BCO in a @AP_UPD@ thunk which will be updated with the value of\n     the BCO when evaluated. ")
-  , ("newBCO#"," @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The\n     resulting object encodes a function of the given arity with the instructions\n     encoded in @instrs@, and a static reference table usage bitmap given by\n     @bitmap@. ")
-  , ("unpackClosure#"," @'unpackClosure#' closure@ copies the closure and pointers in the\n     payload of the given closure into two new arrays, and returns a pointer to\n     the first word of the closure's info table, a non-pointer array for the raw\n     bytes of the closure, and a pointer array for the pointers in the payload. ")
-  , ("closureSize#"," @'closureSize#' closure@ returns the size of the given closure in\n     machine words. ")
-  , ("getCurrentCCS#"," Returns the current 'CostCentreStack' (value is @NULL@ if\n     not profiling).  Takes a dummy argument which can be used to\n     avoid the call to 'getCurrentCCS#' being floated out by the\n     simplifier, which would result in an uninformative stack\n     (\"CAF\"). ")
-  , ("clearCCS#"," Run the supplied IO action with an empty CCS.  For example, this\n     is used by the interpreter to run an interpreted computation\n     without the call stack showing that it was invoked from GHC. ")
-  , ("whereFrom#"," Returns the @InfoProvEnt @ for the info table of the given object\n     (value is @NULL@ if the table does not exist or there is no information\n     about the closure).")
-  , ("FUN","The builtin function type, written in infix form as @a % m -> b@.\n   Values of this type are functions taking inputs of type @a@ and\n   producing outputs of type @b@. The multiplicity of the input is\n   @m@.\n\n   Note that @'FUN' m a b@ permits representation polymorphism in both\n   @a@ and @b@, so that types like @'Int#' -> 'Int#'@ can still be\n   well-kinded.\n  ")
-  , ("realWorld#"," The token used in the implementation of the IO monad as a state monad.\n     It does not pass any information at runtime.\n     See also 'GHC.Magic.runRW#'. ")
-  , ("void#"," This is an alias for the unboxed unit tuple constructor.\n     In earlier versions of GHC, 'void#' was a value\n     of the primitive type 'Void#', which is now defined to be @(# #)@.\n   ")
-  , ("Proxy#"," The type constructor 'Proxy#' is used to bear witness to some\n   type variable. It's used when you want to pass around proxy values\n   for doing things like modelling type applications. A 'Proxy#'\n   is not only unboxed, it also has a polymorphic kind, and has no\n   runtime representation, being totally free. ")
-  , ("proxy#"," Witness for an unboxed 'Proxy#' value, which has no runtime\n   representation. ")
-  , ("seq"," The value of @'seq' a b@ is bottom if @a@ is bottom, and\n     otherwise equal to @b@. In other words, it evaluates the first\n     argument @a@ to weak head normal form (WHNF). 'seq' is usually\n     introduced to improve performance by avoiding unneeded laziness.\n\n     A note on evaluation order: the expression @'seq' a b@ does\n     /not/ guarantee that @a@ will be evaluated before @b@.\n     The only guarantee given by 'seq' is that the both @a@\n     and @b@ will be evaluated before 'seq' returns a value.\n     In particular, this means that @b@ may be evaluated before\n     @a@. If you need to guarantee a specific order of evaluation,\n     you must use the function 'pseq' from the \"parallel\" package. ")
-  , ("unsafeCoerce#"," The function 'unsafeCoerce#' allows you to side-step the typechecker entirely. That\n        is, it allows you to coerce any type into any other type. If you use this function,\n        you had better get it right, otherwise segmentation faults await. It is generally\n        used when you want to write a program that you know is well-typed, but where Haskell's\n        type system is not expressive enough to prove that it is well typed.\n\n        The following uses of 'unsafeCoerce#' are supposed to work (i.e. not lead to\n        spurious compile-time or run-time crashes):\n\n         * Casting any lifted type to 'Any'\n\n         * Casting 'Any' back to the real type\n\n         * Casting an unboxed type to another unboxed type of the same size.\n           (Casting between floating-point and integral types does not work.\n           See the \"GHC.Float\" module for functions to do work.)\n\n         * Casting between two types that have the same runtime representation.  One case is when\n           the two types differ only in \"phantom\" type parameters, for example\n           @'Ptr' 'Int'@ to @'Ptr' 'Float'@, or @['Int']@ to @['Float']@ when the list is\n           known to be empty.  Also, a @newtype@ of a type @T@ has the same representation\n           at runtime as @T@.\n\n        Other uses of 'unsafeCoerce#' are undefined.  In particular, you should not use\n        'unsafeCoerce#' to cast a T to an algebraic data type D, unless T is also\n        an algebraic data type.  For example, do not cast @'Int'->'Int'@ to 'Bool', even if\n        you later cast that 'Bool' back to @'Int'->'Int'@ before applying it.  The reasons\n        have to do with GHC's internal representation details (for the cognoscenti, data values\n        can be entered but function closures cannot).  If you want a safe type to cast things\n        to, use 'Any', which is not an algebraic data type.\n\n        ")
-  , ("traceEvent#"," Emits an event via the RTS tracing framework.  The contents\n     of the event is the zero-terminated byte string passed as the first\n     argument.  The event will be emitted either to the @.eventlog@ file,\n     or to stderr, depending on the runtime RTS flags. ")
-  , ("traceBinaryEvent#"," Emits an event via the RTS tracing framework.  The contents\n     of the event is the binary object passed as the first argument with\n     the given length passed as the second argument. The event will be\n     emitted to the @.eventlog@ file. ")
-  , ("traceMarker#"," Emits a marker event via the RTS tracing framework.  The contents\n     of the event is the zero-terminated byte string passed as the first\n     argument.  The event will be emitted either to the @.eventlog@ file,\n     or to stderr, depending on the runtime RTS flags. ")
-  , ("setThreadAllocationCounter#"," Sets the allocation counter for the current thread to the given value. ")
-  , ("StackSnapshot#"," Haskell representation of a @StgStack*@ that was created (cloned)\n     with a function in \"GHC.Stack.CloneStack\". Please check the\n     documentation in that module for more detailed explanations. ")
-  , ("coerce"," The function 'coerce' allows you to safely convert between values of\n     types that have the same representation with no run-time overhead. In the\n     simplest case you can use it instead of a newtype constructor, to go from\n     the newtype's concrete type to the abstract type. But it also works in\n     more complicated settings, e.g. converting a list of newtypes to a list of\n     concrete types.\n\n     This function is representation-polymorphic, but the\n     'RuntimeRep' type argument is marked as 'Inferred', meaning\n     that it is not available for visible type application. This means\n     the typechecker will accept @'coerce' @'Int' @Age 42@.\n   ")
-  , ("broadcastInt8X16#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastInt16X8#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastInt32X4#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastInt64X2#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastInt8X32#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastInt16X16#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastInt32X8#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastInt64X4#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastInt8X64#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastInt16X32#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastInt32X16#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastInt64X8#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastWord8X16#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastWord16X8#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastWord32X4#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastWord64X2#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastWord8X32#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastWord16X16#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastWord32X8#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastWord64X4#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastWord8X64#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastWord16X32#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastWord32X16#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastWord64X8#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastFloatX4#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastDoubleX2#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastFloatX8#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastDoubleX4#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastFloatX16#"," Broadcast a scalar to all elements of a vector. ")
-  , ("broadcastDoubleX8#"," Broadcast a scalar to all elements of a vector. ")
-  , ("packInt8X16#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packInt16X8#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packInt32X4#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packInt64X2#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packInt8X32#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packInt16X16#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packInt32X8#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packInt64X4#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packInt8X64#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packInt16X32#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packInt32X16#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packInt64X8#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packWord8X16#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packWord16X8#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packWord32X4#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packWord64X2#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packWord8X32#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packWord16X16#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packWord32X8#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packWord64X4#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packWord8X64#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packWord16X32#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packWord32X16#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packWord64X8#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packFloatX4#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packDoubleX2#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packFloatX8#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packDoubleX4#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packFloatX16#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("packDoubleX8#"," Pack the elements of an unboxed tuple into a vector. ")
-  , ("unpackInt8X16#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackInt16X8#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackInt32X4#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackInt64X2#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackInt8X32#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackInt16X16#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackInt32X8#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackInt64X4#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackInt8X64#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackInt16X32#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackInt32X16#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackInt64X8#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackWord8X16#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackWord16X8#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackWord32X4#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackWord64X2#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackWord8X32#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackWord16X16#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackWord32X8#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackWord64X4#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackWord8X64#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackWord16X32#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackWord32X16#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackWord64X8#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackFloatX4#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackDoubleX2#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackFloatX8#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackDoubleX4#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackFloatX16#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("unpackDoubleX8#"," Unpack the elements of a vector into an unboxed tuple. #")
-  , ("insertInt8X16#"," Insert a scalar at the given position in a vector. ")
-  , ("insertInt16X8#"," Insert a scalar at the given position in a vector. ")
-  , ("insertInt32X4#"," Insert a scalar at the given position in a vector. ")
-  , ("insertInt64X2#"," Insert a scalar at the given position in a vector. ")
-  , ("insertInt8X32#"," Insert a scalar at the given position in a vector. ")
-  , ("insertInt16X16#"," Insert a scalar at the given position in a vector. ")
-  , ("insertInt32X8#"," Insert a scalar at the given position in a vector. ")
-  , ("insertInt64X4#"," Insert a scalar at the given position in a vector. ")
-  , ("insertInt8X64#"," Insert a scalar at the given position in a vector. ")
-  , ("insertInt16X32#"," Insert a scalar at the given position in a vector. ")
-  , ("insertInt32X16#"," Insert a scalar at the given position in a vector. ")
-  , ("insertInt64X8#"," Insert a scalar at the given position in a vector. ")
-  , ("insertWord8X16#"," Insert a scalar at the given position in a vector. ")
-  , ("insertWord16X8#"," Insert a scalar at the given position in a vector. ")
-  , ("insertWord32X4#"," Insert a scalar at the given position in a vector. ")
-  , ("insertWord64X2#"," Insert a scalar at the given position in a vector. ")
-  , ("insertWord8X32#"," Insert a scalar at the given position in a vector. ")
-  , ("insertWord16X16#"," Insert a scalar at the given position in a vector. ")
-  , ("insertWord32X8#"," Insert a scalar at the given position in a vector. ")
-  , ("insertWord64X4#"," Insert a scalar at the given position in a vector. ")
-  , ("insertWord8X64#"," Insert a scalar at the given position in a vector. ")
-  , ("insertWord16X32#"," Insert a scalar at the given position in a vector. ")
-  , ("insertWord32X16#"," Insert a scalar at the given position in a vector. ")
-  , ("insertWord64X8#"," Insert a scalar at the given position in a vector. ")
-  , ("insertFloatX4#"," Insert a scalar at the given position in a vector. ")
-  , ("insertDoubleX2#"," Insert a scalar at the given position in a vector. ")
-  , ("insertFloatX8#"," Insert a scalar at the given position in a vector. ")
-  , ("insertDoubleX4#"," Insert a scalar at the given position in a vector. ")
-  , ("insertFloatX16#"," Insert a scalar at the given position in a vector. ")
-  , ("insertDoubleX8#"," Insert a scalar at the given position in a vector. ")
-  , ("plusInt8X16#"," Add two vectors element-wise. ")
-  , ("plusInt16X8#"," Add two vectors element-wise. ")
-  , ("plusInt32X4#"," Add two vectors element-wise. ")
-  , ("plusInt64X2#"," Add two vectors element-wise. ")
-  , ("plusInt8X32#"," Add two vectors element-wise. ")
-  , ("plusInt16X16#"," Add two vectors element-wise. ")
-  , ("plusInt32X8#"," Add two vectors element-wise. ")
-  , ("plusInt64X4#"," Add two vectors element-wise. ")
-  , ("plusInt8X64#"," Add two vectors element-wise. ")
-  , ("plusInt16X32#"," Add two vectors element-wise. ")
-  , ("plusInt32X16#"," Add two vectors element-wise. ")
-  , ("plusInt64X8#"," Add two vectors element-wise. ")
-  , ("plusWord8X16#"," Add two vectors element-wise. ")
-  , ("plusWord16X8#"," Add two vectors element-wise. ")
-  , ("plusWord32X4#"," Add two vectors element-wise. ")
-  , ("plusWord64X2#"," Add two vectors element-wise. ")
-  , ("plusWord8X32#"," Add two vectors element-wise. ")
-  , ("plusWord16X16#"," Add two vectors element-wise. ")
-  , ("plusWord32X8#"," Add two vectors element-wise. ")
-  , ("plusWord64X4#"," Add two vectors element-wise. ")
-  , ("plusWord8X64#"," Add two vectors element-wise. ")
-  , ("plusWord16X32#"," Add two vectors element-wise. ")
-  , ("plusWord32X16#"," Add two vectors element-wise. ")
-  , ("plusWord64X8#"," Add two vectors element-wise. ")
-  , ("plusFloatX4#"," Add two vectors element-wise. ")
-  , ("plusDoubleX2#"," Add two vectors element-wise. ")
-  , ("plusFloatX8#"," Add two vectors element-wise. ")
-  , ("plusDoubleX4#"," Add two vectors element-wise. ")
-  , ("plusFloatX16#"," Add two vectors element-wise. ")
-  , ("plusDoubleX8#"," Add two vectors element-wise. ")
-  , ("minusInt8X16#"," Subtract two vectors element-wise. ")
-  , ("minusInt16X8#"," Subtract two vectors element-wise. ")
-  , ("minusInt32X4#"," Subtract two vectors element-wise. ")
-  , ("minusInt64X2#"," Subtract two vectors element-wise. ")
-  , ("minusInt8X32#"," Subtract two vectors element-wise. ")
-  , ("minusInt16X16#"," Subtract two vectors element-wise. ")
-  , ("minusInt32X8#"," Subtract two vectors element-wise. ")
-  , ("minusInt64X4#"," Subtract two vectors element-wise. ")
-  , ("minusInt8X64#"," Subtract two vectors element-wise. ")
-  , ("minusInt16X32#"," Subtract two vectors element-wise. ")
-  , ("minusInt32X16#"," Subtract two vectors element-wise. ")
-  , ("minusInt64X8#"," Subtract two vectors element-wise. ")
-  , ("minusWord8X16#"," Subtract two vectors element-wise. ")
-  , ("minusWord16X8#"," Subtract two vectors element-wise. ")
-  , ("minusWord32X4#"," Subtract two vectors element-wise. ")
-  , ("minusWord64X2#"," Subtract two vectors element-wise. ")
-  , ("minusWord8X32#"," Subtract two vectors element-wise. ")
-  , ("minusWord16X16#"," Subtract two vectors element-wise. ")
-  , ("minusWord32X8#"," Subtract two vectors element-wise. ")
-  , ("minusWord64X4#"," Subtract two vectors element-wise. ")
-  , ("minusWord8X64#"," Subtract two vectors element-wise. ")
-  , ("minusWord16X32#"," Subtract two vectors element-wise. ")
-  , ("minusWord32X16#"," Subtract two vectors element-wise. ")
-  , ("minusWord64X8#"," Subtract two vectors element-wise. ")
-  , ("minusFloatX4#"," Subtract two vectors element-wise. ")
-  , ("minusDoubleX2#"," Subtract two vectors element-wise. ")
-  , ("minusFloatX8#"," Subtract two vectors element-wise. ")
-  , ("minusDoubleX4#"," Subtract two vectors element-wise. ")
-  , ("minusFloatX16#"," Subtract two vectors element-wise. ")
-  , ("minusDoubleX8#"," Subtract two vectors element-wise. ")
-  , ("timesInt8X16#"," Multiply two vectors element-wise. ")
-  , ("timesInt16X8#"," Multiply two vectors element-wise. ")
-  , ("timesInt32X4#"," Multiply two vectors element-wise. ")
-  , ("timesInt64X2#"," Multiply two vectors element-wise. ")
-  , ("timesInt8X32#"," Multiply two vectors element-wise. ")
-  , ("timesInt16X16#"," Multiply two vectors element-wise. ")
-  , ("timesInt32X8#"," Multiply two vectors element-wise. ")
-  , ("timesInt64X4#"," Multiply two vectors element-wise. ")
-  , ("timesInt8X64#"," Multiply two vectors element-wise. ")
-  , ("timesInt16X32#"," Multiply two vectors element-wise. ")
-  , ("timesInt32X16#"," Multiply two vectors element-wise. ")
-  , ("timesInt64X8#"," Multiply two vectors element-wise. ")
-  , ("timesWord8X16#"," Multiply two vectors element-wise. ")
-  , ("timesWord16X8#"," Multiply two vectors element-wise. ")
-  , ("timesWord32X4#"," Multiply two vectors element-wise. ")
-  , ("timesWord64X2#"," Multiply two vectors element-wise. ")
-  , ("timesWord8X32#"," Multiply two vectors element-wise. ")
-  , ("timesWord16X16#"," Multiply two vectors element-wise. ")
-  , ("timesWord32X8#"," Multiply two vectors element-wise. ")
-  , ("timesWord64X4#"," Multiply two vectors element-wise. ")
-  , ("timesWord8X64#"," Multiply two vectors element-wise. ")
-  , ("timesWord16X32#"," Multiply two vectors element-wise. ")
-  , ("timesWord32X16#"," Multiply two vectors element-wise. ")
-  , ("timesWord64X8#"," Multiply two vectors element-wise. ")
-  , ("timesFloatX4#"," Multiply two vectors element-wise. ")
-  , ("timesDoubleX2#"," Multiply two vectors element-wise. ")
-  , ("timesFloatX8#"," Multiply two vectors element-wise. ")
-  , ("timesDoubleX4#"," Multiply two vectors element-wise. ")
-  , ("timesFloatX16#"," Multiply two vectors element-wise. ")
-  , ("timesDoubleX8#"," Multiply two vectors element-wise. ")
-  , ("divideFloatX4#"," Divide two vectors element-wise. ")
-  , ("divideDoubleX2#"," Divide two vectors element-wise. ")
-  , ("divideFloatX8#"," Divide two vectors element-wise. ")
-  , ("divideDoubleX4#"," Divide two vectors element-wise. ")
-  , ("divideFloatX16#"," Divide two vectors element-wise. ")
-  , ("divideDoubleX8#"," Divide two vectors element-wise. ")
-  , ("quotInt8X16#"," Rounds towards zero element-wise. ")
-  , ("quotInt16X8#"," Rounds towards zero element-wise. ")
-  , ("quotInt32X4#"," Rounds towards zero element-wise. ")
-  , ("quotInt64X2#"," Rounds towards zero element-wise. ")
-  , ("quotInt8X32#"," Rounds towards zero element-wise. ")
-  , ("quotInt16X16#"," Rounds towards zero element-wise. ")
-  , ("quotInt32X8#"," Rounds towards zero element-wise. ")
-  , ("quotInt64X4#"," Rounds towards zero element-wise. ")
-  , ("quotInt8X64#"," Rounds towards zero element-wise. ")
-  , ("quotInt16X32#"," Rounds towards zero element-wise. ")
-  , ("quotInt32X16#"," Rounds towards zero element-wise. ")
-  , ("quotInt64X8#"," Rounds towards zero element-wise. ")
-  , ("quotWord8X16#"," Rounds towards zero element-wise. ")
-  , ("quotWord16X8#"," Rounds towards zero element-wise. ")
-  , ("quotWord32X4#"," Rounds towards zero element-wise. ")
-  , ("quotWord64X2#"," Rounds towards zero element-wise. ")
-  , ("quotWord8X32#"," Rounds towards zero element-wise. ")
-  , ("quotWord16X16#"," Rounds towards zero element-wise. ")
-  , ("quotWord32X8#"," Rounds towards zero element-wise. ")
-  , ("quotWord64X4#"," Rounds towards zero element-wise. ")
-  , ("quotWord8X64#"," Rounds towards zero element-wise. ")
-  , ("quotWord16X32#"," Rounds towards zero element-wise. ")
-  , ("quotWord32X16#"," Rounds towards zero element-wise. ")
-  , ("quotWord64X8#"," Rounds towards zero element-wise. ")
-  , ("remInt8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remInt16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remInt32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remInt64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remInt8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remInt16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remInt32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remInt64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remInt8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remInt16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remInt32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remInt64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remWord8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remWord16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remWord32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remWord64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remWord8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remWord16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remWord32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remWord64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remWord8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remWord16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remWord32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("remWord64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")
-  , ("negateInt8X16#"," Negate element-wise. ")
-  , ("negateInt16X8#"," Negate element-wise. ")
-  , ("negateInt32X4#"," Negate element-wise. ")
-  , ("negateInt64X2#"," Negate element-wise. ")
-  , ("negateInt8X32#"," Negate element-wise. ")
-  , ("negateInt16X16#"," Negate element-wise. ")
-  , ("negateInt32X8#"," Negate element-wise. ")
-  , ("negateInt64X4#"," Negate element-wise. ")
-  , ("negateInt8X64#"," Negate element-wise. ")
-  , ("negateInt16X32#"," Negate element-wise. ")
-  , ("negateInt32X16#"," Negate element-wise. ")
-  , ("negateInt64X8#"," Negate element-wise. ")
-  , ("negateFloatX4#"," Negate element-wise. ")
-  , ("negateDoubleX2#"," Negate element-wise. ")
-  , ("negateFloatX8#"," Negate element-wise. ")
-  , ("negateDoubleX4#"," Negate element-wise. ")
-  , ("negateFloatX16#"," Negate element-wise. ")
-  , ("negateDoubleX8#"," Negate element-wise. ")
-  , ("indexInt8X16Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexInt16X8Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexInt32X4Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexInt64X2Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexInt8X32Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexInt16X16Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexInt32X8Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexInt64X4Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexInt8X64Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexInt16X32Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexInt32X16Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexInt64X8Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexWord8X16Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexWord16X8Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexWord32X4Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexWord64X2Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexWord8X32Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexWord16X16Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexWord32X8Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexWord64X4Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexWord8X64Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexWord16X32Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexWord32X16Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexWord64X8Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexFloatX4Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexDoubleX2Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexFloatX8Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexDoubleX4Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexFloatX16Array#"," Read a vector from specified index of immutable array. ")
-  , ("indexDoubleX8Array#"," Read a vector from specified index of immutable array. ")
-  , ("readInt8X16Array#"," Read a vector from specified index of mutable array. ")
-  , ("readInt16X8Array#"," Read a vector from specified index of mutable array. ")
-  , ("readInt32X4Array#"," Read a vector from specified index of mutable array. ")
-  , ("readInt64X2Array#"," Read a vector from specified index of mutable array. ")
-  , ("readInt8X32Array#"," Read a vector from specified index of mutable array. ")
-  , ("readInt16X16Array#"," Read a vector from specified index of mutable array. ")
-  , ("readInt32X8Array#"," Read a vector from specified index of mutable array. ")
-  , ("readInt64X4Array#"," Read a vector from specified index of mutable array. ")
-  , ("readInt8X64Array#"," Read a vector from specified index of mutable array. ")
-  , ("readInt16X32Array#"," Read a vector from specified index of mutable array. ")
-  , ("readInt32X16Array#"," Read a vector from specified index of mutable array. ")
-  , ("readInt64X8Array#"," Read a vector from specified index of mutable array. ")
-  , ("readWord8X16Array#"," Read a vector from specified index of mutable array. ")
-  , ("readWord16X8Array#"," Read a vector from specified index of mutable array. ")
-  , ("readWord32X4Array#"," Read a vector from specified index of mutable array. ")
-  , ("readWord64X2Array#"," Read a vector from specified index of mutable array. ")
-  , ("readWord8X32Array#"," Read a vector from specified index of mutable array. ")
-  , ("readWord16X16Array#"," Read a vector from specified index of mutable array. ")
-  , ("readWord32X8Array#"," Read a vector from specified index of mutable array. ")
-  , ("readWord64X4Array#"," Read a vector from specified index of mutable array. ")
-  , ("readWord8X64Array#"," Read a vector from specified index of mutable array. ")
-  , ("readWord16X32Array#"," Read a vector from specified index of mutable array. ")
-  , ("readWord32X16Array#"," Read a vector from specified index of mutable array. ")
-  , ("readWord64X8Array#"," Read a vector from specified index of mutable array. ")
-  , ("readFloatX4Array#"," Read a vector from specified index of mutable array. ")
-  , ("readDoubleX2Array#"," Read a vector from specified index of mutable array. ")
-  , ("readFloatX8Array#"," Read a vector from specified index of mutable array. ")
-  , ("readDoubleX4Array#"," Read a vector from specified index of mutable array. ")
-  , ("readFloatX16Array#"," Read a vector from specified index of mutable array. ")
-  , ("readDoubleX8Array#"," Read a vector from specified index of mutable array. ")
-  , ("writeInt8X16Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeInt16X8Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeInt32X4Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeInt64X2Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeInt8X32Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeInt16X16Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeInt32X8Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeInt64X4Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeInt8X64Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeInt16X32Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeInt32X16Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeInt64X8Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeWord8X16Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeWord16X8Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeWord32X4Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeWord64X2Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeWord8X32Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeWord16X16Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeWord32X8Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeWord64X4Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeWord8X64Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeWord16X32Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeWord32X16Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeWord64X8Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeFloatX4Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeDoubleX2Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeFloatX8Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeDoubleX4Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeFloatX16Array#"," Write a vector to specified index of mutable array. ")
-  , ("writeDoubleX8Array#"," Write a vector to specified index of mutable array. ")
-  , ("indexInt8X16OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexInt16X8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexInt32X4OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexInt64X2OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexInt8X32OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexInt16X16OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexInt32X8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexInt64X4OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexInt8X64OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexInt16X32OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexInt32X16OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexInt64X8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexWord8X16OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexWord16X8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexWord32X4OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexWord64X2OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexWord8X32OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexWord16X16OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexWord32X8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexWord64X4OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexWord8X64OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexWord16X32OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexWord32X16OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexWord64X8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexFloatX4OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexDoubleX2OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexFloatX8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexDoubleX4OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexFloatX16OffAddr#"," Reads vector; offset in bytes. ")
-  , ("indexDoubleX8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readInt8X16OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readInt16X8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readInt32X4OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readInt64X2OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readInt8X32OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readInt16X16OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readInt32X8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readInt64X4OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readInt8X64OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readInt16X32OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readInt32X16OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readInt64X8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readWord8X16OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readWord16X8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readWord32X4OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readWord64X2OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readWord8X32OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readWord16X16OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readWord32X8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readWord64X4OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readWord8X64OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readWord16X32OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readWord32X16OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readWord64X8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readFloatX4OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readDoubleX2OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readFloatX8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readDoubleX4OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readFloatX16OffAddr#"," Reads vector; offset in bytes. ")
-  , ("readDoubleX8OffAddr#"," Reads vector; offset in bytes. ")
-  , ("writeInt8X16OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeInt16X8OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeInt32X4OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeInt64X2OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeInt8X32OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeInt16X16OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeInt32X8OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeInt64X4OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeInt8X64OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeInt16X32OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeInt32X16OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeInt64X8OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeWord8X16OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeWord16X8OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeWord32X4OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeWord64X2OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeWord8X32OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeWord16X16OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeWord32X8OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeWord64X4OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeWord8X64OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeWord16X32OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeWord32X16OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeWord64X8OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeFloatX4OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeDoubleX2OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeFloatX8OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeDoubleX4OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeFloatX16OffAddr#"," Write vector; offset in bytes. ")
-  , ("writeDoubleX8OffAddr#"," Write vector; offset in bytes. ")
-  , ("indexInt8ArrayAsInt8X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexInt16ArrayAsInt16X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexInt32ArrayAsInt32X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexInt64ArrayAsInt64X2#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexInt8ArrayAsInt8X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexInt16ArrayAsInt16X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexInt32ArrayAsInt32X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexInt64ArrayAsInt64X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexInt8ArrayAsInt8X64#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexInt16ArrayAsInt16X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexInt32ArrayAsInt32X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexInt64ArrayAsInt64X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexWord8ArrayAsWord8X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexWord16ArrayAsWord16X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexWord32ArrayAsWord32X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexWord64ArrayAsWord64X2#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexWord8ArrayAsWord8X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexWord16ArrayAsWord16X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexWord32ArrayAsWord32X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexWord64ArrayAsWord64X4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexWord8ArrayAsWord8X64#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexWord16ArrayAsWord16X32#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexWord32ArrayAsWord32X16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexWord64ArrayAsWord64X8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexFloatArrayAsFloatX4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexDoubleArrayAsDoubleX2#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexFloatArrayAsFloatX8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexDoubleArrayAsDoubleX4#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexFloatArrayAsFloatX16#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("indexDoubleArrayAsDoubleX8#"," Read a vector from specified index of immutable array of scalars; offset is in scalar elements. ")
-  , ("readInt8ArrayAsInt8X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readInt16ArrayAsInt16X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readInt32ArrayAsInt32X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readInt64ArrayAsInt64X2#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readInt8ArrayAsInt8X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readInt16ArrayAsInt16X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readInt32ArrayAsInt32X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readInt64ArrayAsInt64X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readInt8ArrayAsInt8X64#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readInt16ArrayAsInt16X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readInt32ArrayAsInt32X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readInt64ArrayAsInt64X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readWord8ArrayAsWord8X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readWord16ArrayAsWord16X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readWord32ArrayAsWord32X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readWord64ArrayAsWord64X2#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readWord8ArrayAsWord8X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readWord16ArrayAsWord16X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readWord32ArrayAsWord32X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readWord64ArrayAsWord64X4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readWord8ArrayAsWord8X64#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readWord16ArrayAsWord16X32#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readWord32ArrayAsWord32X16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readWord64ArrayAsWord64X8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readFloatArrayAsFloatX4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readDoubleArrayAsDoubleX2#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readFloatArrayAsFloatX8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readDoubleArrayAsDoubleX4#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readFloatArrayAsFloatX16#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("readDoubleArrayAsDoubleX8#"," Read a vector from specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeInt8ArrayAsInt8X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeInt16ArrayAsInt16X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeInt32ArrayAsInt32X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeInt64ArrayAsInt64X2#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeInt8ArrayAsInt8X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeInt16ArrayAsInt16X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeInt32ArrayAsInt32X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeInt64ArrayAsInt64X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeInt8ArrayAsInt8X64#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeInt16ArrayAsInt16X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeInt32ArrayAsInt32X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeInt64ArrayAsInt64X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeWord8ArrayAsWord8X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeWord16ArrayAsWord16X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeWord32ArrayAsWord32X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeWord64ArrayAsWord64X2#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeWord8ArrayAsWord8X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeWord16ArrayAsWord16X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeWord32ArrayAsWord32X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeWord64ArrayAsWord64X4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeWord8ArrayAsWord8X64#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeWord16ArrayAsWord16X32#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeWord32ArrayAsWord32X16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeWord64ArrayAsWord64X8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeFloatArrayAsFloatX4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeDoubleArrayAsDoubleX2#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeFloatArrayAsFloatX8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeDoubleArrayAsDoubleX4#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeFloatArrayAsFloatX16#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("writeDoubleArrayAsDoubleX8#"," Write a vector to specified index of mutable array of scalars; offset is in scalar elements. ")
-  , ("indexInt8OffAddrAsInt8X16#"," Reads vector; offset in scalar elements. ")
-  , ("indexInt16OffAddrAsInt16X8#"," Reads vector; offset in scalar elements. ")
-  , ("indexInt32OffAddrAsInt32X4#"," Reads vector; offset in scalar elements. ")
-  , ("indexInt64OffAddrAsInt64X2#"," Reads vector; offset in scalar elements. ")
-  , ("indexInt8OffAddrAsInt8X32#"," Reads vector; offset in scalar elements. ")
-  , ("indexInt16OffAddrAsInt16X16#"," Reads vector; offset in scalar elements. ")
-  , ("indexInt32OffAddrAsInt32X8#"," Reads vector; offset in scalar elements. ")
-  , ("indexInt64OffAddrAsInt64X4#"," Reads vector; offset in scalar elements. ")
-  , ("indexInt8OffAddrAsInt8X64#"," Reads vector; offset in scalar elements. ")
-  , ("indexInt16OffAddrAsInt16X32#"," Reads vector; offset in scalar elements. ")
-  , ("indexInt32OffAddrAsInt32X16#"," Reads vector; offset in scalar elements. ")
-  , ("indexInt64OffAddrAsInt64X8#"," Reads vector; offset in scalar elements. ")
-  , ("indexWord8OffAddrAsWord8X16#"," Reads vector; offset in scalar elements. ")
-  , ("indexWord16OffAddrAsWord16X8#"," Reads vector; offset in scalar elements. ")
-  , ("indexWord32OffAddrAsWord32X4#"," Reads vector; offset in scalar elements. ")
-  , ("indexWord64OffAddrAsWord64X2#"," Reads vector; offset in scalar elements. ")
-  , ("indexWord8OffAddrAsWord8X32#"," Reads vector; offset in scalar elements. ")
-  , ("indexWord16OffAddrAsWord16X16#"," Reads vector; offset in scalar elements. ")
-  , ("indexWord32OffAddrAsWord32X8#"," Reads vector; offset in scalar elements. ")
-  , ("indexWord64OffAddrAsWord64X4#"," Reads vector; offset in scalar elements. ")
-  , ("indexWord8OffAddrAsWord8X64#"," Reads vector; offset in scalar elements. ")
-  , ("indexWord16OffAddrAsWord16X32#"," Reads vector; offset in scalar elements. ")
-  , ("indexWord32OffAddrAsWord32X16#"," Reads vector; offset in scalar elements. ")
-  , ("indexWord64OffAddrAsWord64X8#"," Reads vector; offset in scalar elements. ")
-  , ("indexFloatOffAddrAsFloatX4#"," Reads vector; offset in scalar elements. ")
-  , ("indexDoubleOffAddrAsDoubleX2#"," Reads vector; offset in scalar elements. ")
-  , ("indexFloatOffAddrAsFloatX8#"," Reads vector; offset in scalar elements. ")
-  , ("indexDoubleOffAddrAsDoubleX4#"," Reads vector; offset in scalar elements. ")
-  , ("indexFloatOffAddrAsFloatX16#"," Reads vector; offset in scalar elements. ")
-  , ("indexDoubleOffAddrAsDoubleX8#"," Reads vector; offset in scalar elements. ")
-  , ("readInt8OffAddrAsInt8X16#"," Reads vector; offset in scalar elements. ")
-  , ("readInt16OffAddrAsInt16X8#"," Reads vector; offset in scalar elements. ")
-  , ("readInt32OffAddrAsInt32X4#"," Reads vector; offset in scalar elements. ")
-  , ("readInt64OffAddrAsInt64X2#"," Reads vector; offset in scalar elements. ")
-  , ("readInt8OffAddrAsInt8X32#"," Reads vector; offset in scalar elements. ")
-  , ("readInt16OffAddrAsInt16X16#"," Reads vector; offset in scalar elements. ")
-  , ("readInt32OffAddrAsInt32X8#"," Reads vector; offset in scalar elements. ")
-  , ("readInt64OffAddrAsInt64X4#"," Reads vector; offset in scalar elements. ")
-  , ("readInt8OffAddrAsInt8X64#"," Reads vector; offset in scalar elements. ")
-  , ("readInt16OffAddrAsInt16X32#"," Reads vector; offset in scalar elements. ")
-  , ("readInt32OffAddrAsInt32X16#"," Reads vector; offset in scalar elements. ")
-  , ("readInt64OffAddrAsInt64X8#"," Reads vector; offset in scalar elements. ")
-  , ("readWord8OffAddrAsWord8X16#"," Reads vector; offset in scalar elements. ")
-  , ("readWord16OffAddrAsWord16X8#"," Reads vector; offset in scalar elements. ")
-  , ("readWord32OffAddrAsWord32X4#"," Reads vector; offset in scalar elements. ")
-  , ("readWord64OffAddrAsWord64X2#"," Reads vector; offset in scalar elements. ")
-  , ("readWord8OffAddrAsWord8X32#"," Reads vector; offset in scalar elements. ")
-  , ("readWord16OffAddrAsWord16X16#"," Reads vector; offset in scalar elements. ")
-  , ("readWord32OffAddrAsWord32X8#"," Reads vector; offset in scalar elements. ")
-  , ("readWord64OffAddrAsWord64X4#"," Reads vector; offset in scalar elements. ")
-  , ("readWord8OffAddrAsWord8X64#"," Reads vector; offset in scalar elements. ")
-  , ("readWord16OffAddrAsWord16X32#"," Reads vector; offset in scalar elements. ")
-  , ("readWord32OffAddrAsWord32X16#"," Reads vector; offset in scalar elements. ")
-  , ("readWord64OffAddrAsWord64X8#"," Reads vector; offset in scalar elements. ")
-  , ("readFloatOffAddrAsFloatX4#"," Reads vector; offset in scalar elements. ")
-  , ("readDoubleOffAddrAsDoubleX2#"," Reads vector; offset in scalar elements. ")
-  , ("readFloatOffAddrAsFloatX8#"," Reads vector; offset in scalar elements. ")
-  , ("readDoubleOffAddrAsDoubleX4#"," Reads vector; offset in scalar elements. ")
-  , ("readFloatOffAddrAsFloatX16#"," Reads vector; offset in scalar elements. ")
-  , ("readDoubleOffAddrAsDoubleX8#"," Reads vector; offset in scalar elements. ")
-  , ("writeInt8OffAddrAsInt8X16#"," Write vector; offset in scalar elements. ")
-  , ("writeInt16OffAddrAsInt16X8#"," Write vector; offset in scalar elements. ")
-  , ("writeInt32OffAddrAsInt32X4#"," Write vector; offset in scalar elements. ")
-  , ("writeInt64OffAddrAsInt64X2#"," Write vector; offset in scalar elements. ")
-  , ("writeInt8OffAddrAsInt8X32#"," Write vector; offset in scalar elements. ")
-  , ("writeInt16OffAddrAsInt16X16#"," Write vector; offset in scalar elements. ")
-  , ("writeInt32OffAddrAsInt32X8#"," Write vector; offset in scalar elements. ")
-  , ("writeInt64OffAddrAsInt64X4#"," Write vector; offset in scalar elements. ")
-  , ("writeInt8OffAddrAsInt8X64#"," Write vector; offset in scalar elements. ")
-  , ("writeInt16OffAddrAsInt16X32#"," Write vector; offset in scalar elements. ")
-  , ("writeInt32OffAddrAsInt32X16#"," Write vector; offset in scalar elements. ")
-  , ("writeInt64OffAddrAsInt64X8#"," Write vector; offset in scalar elements. ")
-  , ("writeWord8OffAddrAsWord8X16#"," Write vector; offset in scalar elements. ")
-  , ("writeWord16OffAddrAsWord16X8#"," Write vector; offset in scalar elements. ")
-  , ("writeWord32OffAddrAsWord32X4#"," Write vector; offset in scalar elements. ")
-  , ("writeWord64OffAddrAsWord64X2#"," Write vector; offset in scalar elements. ")
-  , ("writeWord8OffAddrAsWord8X32#"," Write vector; offset in scalar elements. ")
-  , ("writeWord16OffAddrAsWord16X16#"," Write vector; offset in scalar elements. ")
-  , ("writeWord32OffAddrAsWord32X8#"," Write vector; offset in scalar elements. ")
-  , ("writeWord64OffAddrAsWord64X4#"," Write vector; offset in scalar elements. ")
-  , ("writeWord8OffAddrAsWord8X64#"," Write vector; offset in scalar elements. ")
-  , ("writeWord16OffAddrAsWord16X32#"," Write vector; offset in scalar elements. ")
-  , ("writeWord32OffAddrAsWord32X16#"," Write vector; offset in scalar elements. ")
-  , ("writeWord64OffAddrAsWord64X8#"," Write vector; offset in scalar elements. ")
-  , ("writeFloatOffAddrAsFloatX4#"," Write vector; offset in scalar elements. ")
-  , ("writeDoubleOffAddrAsDoubleX2#"," Write vector; offset in scalar elements. ")
-  , ("writeFloatOffAddrAsFloatX8#"," Write vector; offset in scalar elements. ")
-  , ("writeDoubleOffAddrAsDoubleX4#"," Write vector; offset in scalar elements. ")
-  , ("writeFloatOffAddrAsFloatX16#"," Write vector; offset in scalar elements. ")
-  , ("writeDoubleOffAddrAsDoubleX8#"," Write vector; offset in scalar elements. ")
-  ]
diff --git a/ghc-lib/stage0/compiler/build/primop-fixity.hs-incl b/ghc-lib/stage0/compiler/build/primop-fixity.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-fixity.hs-incl
+++ /dev/null
@@ -1,20 +0,0 @@
-primOpFixity IntAddOp = Just (Fixity NoSourceText 6 InfixL)
-primOpFixity IntSubOp = Just (Fixity NoSourceText 6 InfixL)
-primOpFixity IntMulOp = Just (Fixity NoSourceText 7 InfixL)
-primOpFixity IntGtOp = Just (Fixity NoSourceText 4 InfixN)
-primOpFixity IntGeOp = Just (Fixity NoSourceText 4 InfixN)
-primOpFixity IntEqOp = Just (Fixity NoSourceText 4 InfixN)
-primOpFixity IntNeOp = Just (Fixity NoSourceText 4 InfixN)
-primOpFixity IntLtOp = Just (Fixity NoSourceText 4 InfixN)
-primOpFixity IntLeOp = Just (Fixity NoSourceText 4 InfixN)
-primOpFixity DoubleGtOp = Just (Fixity NoSourceText 4 InfixN)
-primOpFixity DoubleGeOp = Just (Fixity NoSourceText 4 InfixN)
-primOpFixity DoubleEqOp = Just (Fixity NoSourceText 4 InfixN)
-primOpFixity DoubleNeOp = Just (Fixity NoSourceText 4 InfixN)
-primOpFixity DoubleLtOp = Just (Fixity NoSourceText 4 InfixN)
-primOpFixity DoubleLeOp = Just (Fixity NoSourceText 4 InfixN)
-primOpFixity DoubleAddOp = Just (Fixity NoSourceText 6 InfixL)
-primOpFixity DoubleSubOp = Just (Fixity NoSourceText 6 InfixL)
-primOpFixity DoubleMulOp = Just (Fixity NoSourceText 7 InfixL)
-primOpFixity DoubleDivOp = Just (Fixity NoSourceText 7 InfixL)
-primOpFixity _ = Nothing
diff --git a/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl b/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl
+++ /dev/null
@@ -1,256 +0,0 @@
-primOpHasSideEffects NewArrayOp = True
-primOpHasSideEffects ReadArrayOp = True
-primOpHasSideEffects WriteArrayOp = True
-primOpHasSideEffects UnsafeFreezeArrayOp = True
-primOpHasSideEffects UnsafeThawArrayOp = True
-primOpHasSideEffects CopyArrayOp = True
-primOpHasSideEffects CopyMutableArrayOp = True
-primOpHasSideEffects CloneArrayOp = True
-primOpHasSideEffects CloneMutableArrayOp = True
-primOpHasSideEffects FreezeArrayOp = True
-primOpHasSideEffects ThawArrayOp = True
-primOpHasSideEffects CasArrayOp = True
-primOpHasSideEffects NewSmallArrayOp = True
-primOpHasSideEffects ShrinkSmallMutableArrayOp_Char = True
-primOpHasSideEffects ReadSmallArrayOp = True
-primOpHasSideEffects WriteSmallArrayOp = True
-primOpHasSideEffects UnsafeFreezeSmallArrayOp = True
-primOpHasSideEffects UnsafeThawSmallArrayOp = True
-primOpHasSideEffects CopySmallArrayOp = True
-primOpHasSideEffects CopySmallMutableArrayOp = True
-primOpHasSideEffects CloneSmallArrayOp = True
-primOpHasSideEffects CloneSmallMutableArrayOp = True
-primOpHasSideEffects FreezeSmallArrayOp = True
-primOpHasSideEffects ThawSmallArrayOp = True
-primOpHasSideEffects CasSmallArrayOp = True
-primOpHasSideEffects NewByteArrayOp_Char = True
-primOpHasSideEffects NewPinnedByteArrayOp_Char = True
-primOpHasSideEffects NewAlignedPinnedByteArrayOp_Char = True
-primOpHasSideEffects ShrinkMutableByteArrayOp_Char = True
-primOpHasSideEffects ResizeMutableByteArrayOp_Char = True
-primOpHasSideEffects UnsafeFreezeByteArrayOp = True
-primOpHasSideEffects ReadByteArrayOp_Char = True
-primOpHasSideEffects ReadByteArrayOp_WideChar = True
-primOpHasSideEffects ReadByteArrayOp_Int = True
-primOpHasSideEffects ReadByteArrayOp_Word = True
-primOpHasSideEffects ReadByteArrayOp_Addr = True
-primOpHasSideEffects ReadByteArrayOp_Float = True
-primOpHasSideEffects ReadByteArrayOp_Double = True
-primOpHasSideEffects ReadByteArrayOp_StablePtr = True
-primOpHasSideEffects ReadByteArrayOp_Int8 = True
-primOpHasSideEffects ReadByteArrayOp_Int16 = True
-primOpHasSideEffects ReadByteArrayOp_Int32 = True
-primOpHasSideEffects ReadByteArrayOp_Int64 = True
-primOpHasSideEffects ReadByteArrayOp_Word8 = True
-primOpHasSideEffects ReadByteArrayOp_Word16 = True
-primOpHasSideEffects ReadByteArrayOp_Word32 = True
-primOpHasSideEffects ReadByteArrayOp_Word64 = True
-primOpHasSideEffects ReadByteArrayOp_Word8AsChar = True
-primOpHasSideEffects ReadByteArrayOp_Word8AsWideChar = True
-primOpHasSideEffects ReadByteArrayOp_Word8AsInt = True
-primOpHasSideEffects ReadByteArrayOp_Word8AsWord = True
-primOpHasSideEffects ReadByteArrayOp_Word8AsAddr = True
-primOpHasSideEffects ReadByteArrayOp_Word8AsFloat = True
-primOpHasSideEffects ReadByteArrayOp_Word8AsDouble = True
-primOpHasSideEffects ReadByteArrayOp_Word8AsStablePtr = True
-primOpHasSideEffects ReadByteArrayOp_Word8AsInt16 = True
-primOpHasSideEffects ReadByteArrayOp_Word8AsInt32 = True
-primOpHasSideEffects ReadByteArrayOp_Word8AsInt64 = True
-primOpHasSideEffects ReadByteArrayOp_Word8AsWord16 = True
-primOpHasSideEffects ReadByteArrayOp_Word8AsWord32 = True
-primOpHasSideEffects ReadByteArrayOp_Word8AsWord64 = True
-primOpHasSideEffects WriteByteArrayOp_Char = True
-primOpHasSideEffects WriteByteArrayOp_WideChar = True
-primOpHasSideEffects WriteByteArrayOp_Int = True
-primOpHasSideEffects WriteByteArrayOp_Word = True
-primOpHasSideEffects WriteByteArrayOp_Addr = True
-primOpHasSideEffects WriteByteArrayOp_Float = True
-primOpHasSideEffects WriteByteArrayOp_Double = True
-primOpHasSideEffects WriteByteArrayOp_StablePtr = True
-primOpHasSideEffects WriteByteArrayOp_Int8 = True
-primOpHasSideEffects WriteByteArrayOp_Int16 = True
-primOpHasSideEffects WriteByteArrayOp_Int32 = True
-primOpHasSideEffects WriteByteArrayOp_Int64 = True
-primOpHasSideEffects WriteByteArrayOp_Word8 = True
-primOpHasSideEffects WriteByteArrayOp_Word16 = True
-primOpHasSideEffects WriteByteArrayOp_Word32 = True
-primOpHasSideEffects WriteByteArrayOp_Word64 = True
-primOpHasSideEffects WriteByteArrayOp_Word8AsChar = True
-primOpHasSideEffects WriteByteArrayOp_Word8AsWideChar = True
-primOpHasSideEffects WriteByteArrayOp_Word8AsInt = True
-primOpHasSideEffects WriteByteArrayOp_Word8AsWord = True
-primOpHasSideEffects WriteByteArrayOp_Word8AsAddr = True
-primOpHasSideEffects WriteByteArrayOp_Word8AsFloat = True
-primOpHasSideEffects WriteByteArrayOp_Word8AsDouble = True
-primOpHasSideEffects WriteByteArrayOp_Word8AsStablePtr = True
-primOpHasSideEffects WriteByteArrayOp_Word8AsInt16 = True
-primOpHasSideEffects WriteByteArrayOp_Word8AsInt32 = True
-primOpHasSideEffects WriteByteArrayOp_Word8AsInt64 = True
-primOpHasSideEffects WriteByteArrayOp_Word8AsWord16 = True
-primOpHasSideEffects WriteByteArrayOp_Word8AsWord32 = True
-primOpHasSideEffects WriteByteArrayOp_Word8AsWord64 = True
-primOpHasSideEffects CopyByteArrayOp = True
-primOpHasSideEffects CopyMutableByteArrayOp = True
-primOpHasSideEffects CopyByteArrayToAddrOp = True
-primOpHasSideEffects CopyMutableByteArrayToAddrOp = True
-primOpHasSideEffects CopyAddrToByteArrayOp = True
-primOpHasSideEffects SetByteArrayOp = True
-primOpHasSideEffects AtomicReadByteArrayOp_Int = True
-primOpHasSideEffects AtomicWriteByteArrayOp_Int = True
-primOpHasSideEffects CasByteArrayOp_Int = True
-primOpHasSideEffects CasByteArrayOp_Int8 = True
-primOpHasSideEffects CasByteArrayOp_Int16 = True
-primOpHasSideEffects CasByteArrayOp_Int32 = True
-primOpHasSideEffects CasByteArrayOp_Int64 = True
-primOpHasSideEffects FetchAddByteArrayOp_Int = True
-primOpHasSideEffects FetchSubByteArrayOp_Int = True
-primOpHasSideEffects FetchAndByteArrayOp_Int = True
-primOpHasSideEffects FetchNandByteArrayOp_Int = True
-primOpHasSideEffects FetchOrByteArrayOp_Int = True
-primOpHasSideEffects FetchXorByteArrayOp_Int = True
-primOpHasSideEffects ReadOffAddrOp_Char = True
-primOpHasSideEffects ReadOffAddrOp_WideChar = True
-primOpHasSideEffects ReadOffAddrOp_Int = True
-primOpHasSideEffects ReadOffAddrOp_Word = True
-primOpHasSideEffects ReadOffAddrOp_Addr = True
-primOpHasSideEffects ReadOffAddrOp_Float = True
-primOpHasSideEffects ReadOffAddrOp_Double = True
-primOpHasSideEffects ReadOffAddrOp_StablePtr = True
-primOpHasSideEffects ReadOffAddrOp_Int8 = True
-primOpHasSideEffects ReadOffAddrOp_Int16 = True
-primOpHasSideEffects ReadOffAddrOp_Int32 = True
-primOpHasSideEffects ReadOffAddrOp_Int64 = True
-primOpHasSideEffects ReadOffAddrOp_Word8 = True
-primOpHasSideEffects ReadOffAddrOp_Word16 = True
-primOpHasSideEffects ReadOffAddrOp_Word32 = True
-primOpHasSideEffects ReadOffAddrOp_Word64 = True
-primOpHasSideEffects WriteOffAddrOp_Char = True
-primOpHasSideEffects WriteOffAddrOp_WideChar = True
-primOpHasSideEffects WriteOffAddrOp_Int = True
-primOpHasSideEffects WriteOffAddrOp_Word = True
-primOpHasSideEffects WriteOffAddrOp_Addr = True
-primOpHasSideEffects WriteOffAddrOp_Float = True
-primOpHasSideEffects WriteOffAddrOp_Double = True
-primOpHasSideEffects WriteOffAddrOp_StablePtr = True
-primOpHasSideEffects WriteOffAddrOp_Int8 = True
-primOpHasSideEffects WriteOffAddrOp_Int16 = True
-primOpHasSideEffects WriteOffAddrOp_Int32 = True
-primOpHasSideEffects WriteOffAddrOp_Int64 = True
-primOpHasSideEffects WriteOffAddrOp_Word8 = True
-primOpHasSideEffects WriteOffAddrOp_Word16 = True
-primOpHasSideEffects WriteOffAddrOp_Word32 = True
-primOpHasSideEffects WriteOffAddrOp_Word64 = True
-primOpHasSideEffects InterlockedExchange_Addr = True
-primOpHasSideEffects InterlockedExchange_Word = True
-primOpHasSideEffects CasAddrOp_Addr = True
-primOpHasSideEffects CasAddrOp_Word = True
-primOpHasSideEffects CasAddrOp_Word8 = True
-primOpHasSideEffects CasAddrOp_Word16 = True
-primOpHasSideEffects CasAddrOp_Word32 = True
-primOpHasSideEffects CasAddrOp_Word64 = True
-primOpHasSideEffects FetchAddAddrOp_Word = True
-primOpHasSideEffects FetchSubAddrOp_Word = True
-primOpHasSideEffects FetchAndAddrOp_Word = True
-primOpHasSideEffects FetchNandAddrOp_Word = True
-primOpHasSideEffects FetchOrAddrOp_Word = True
-primOpHasSideEffects FetchXorAddrOp_Word = True
-primOpHasSideEffects AtomicReadAddrOp_Word = True
-primOpHasSideEffects AtomicWriteAddrOp_Word = True
-primOpHasSideEffects NewMutVarOp = True
-primOpHasSideEffects ReadMutVarOp = True
-primOpHasSideEffects WriteMutVarOp = True
-primOpHasSideEffects AtomicModifyMutVar2Op = True
-primOpHasSideEffects AtomicModifyMutVar_Op = True
-primOpHasSideEffects CasMutVarOp = True
-primOpHasSideEffects CatchOp = True
-primOpHasSideEffects RaiseIOOp = True
-primOpHasSideEffects MaskAsyncExceptionsOp = True
-primOpHasSideEffects MaskUninterruptibleOp = True
-primOpHasSideEffects UnmaskAsyncExceptionsOp = True
-primOpHasSideEffects MaskStatus = True
-primOpHasSideEffects NewPromptTagOp = True
-primOpHasSideEffects PromptOp = True
-primOpHasSideEffects Control0Op = True
-primOpHasSideEffects AtomicallyOp = True
-primOpHasSideEffects RetryOp = True
-primOpHasSideEffects CatchRetryOp = True
-primOpHasSideEffects CatchSTMOp = True
-primOpHasSideEffects NewTVarOp = True
-primOpHasSideEffects ReadTVarOp = True
-primOpHasSideEffects ReadTVarIOOp = True
-primOpHasSideEffects WriteTVarOp = True
-primOpHasSideEffects NewMVarOp = True
-primOpHasSideEffects TakeMVarOp = True
-primOpHasSideEffects TryTakeMVarOp = True
-primOpHasSideEffects PutMVarOp = True
-primOpHasSideEffects TryPutMVarOp = True
-primOpHasSideEffects ReadMVarOp = True
-primOpHasSideEffects TryReadMVarOp = True
-primOpHasSideEffects IsEmptyMVarOp = True
-primOpHasSideEffects NewIOPortOp = True
-primOpHasSideEffects ReadIOPortOp = True
-primOpHasSideEffects WriteIOPortOp = True
-primOpHasSideEffects DelayOp = True
-primOpHasSideEffects WaitReadOp = True
-primOpHasSideEffects WaitWriteOp = True
-primOpHasSideEffects ForkOp = True
-primOpHasSideEffects ForkOnOp = True
-primOpHasSideEffects KillThreadOp = True
-primOpHasSideEffects YieldOp = True
-primOpHasSideEffects MyThreadIdOp = True
-primOpHasSideEffects LabelThreadOp = True
-primOpHasSideEffects IsCurrentThreadBoundOp = True
-primOpHasSideEffects NoDuplicateOp = True
-primOpHasSideEffects ThreadStatusOp = True
-primOpHasSideEffects ListThreadsOp = True
-primOpHasSideEffects MkWeakOp = True
-primOpHasSideEffects MkWeakNoFinalizerOp = True
-primOpHasSideEffects AddCFinalizerToWeakOp = True
-primOpHasSideEffects DeRefWeakOp = True
-primOpHasSideEffects FinalizeWeakOp = True
-primOpHasSideEffects TouchOp = True
-primOpHasSideEffects MakeStablePtrOp = True
-primOpHasSideEffects DeRefStablePtrOp = True
-primOpHasSideEffects EqStablePtrOp = True
-primOpHasSideEffects MakeStableNameOp = True
-primOpHasSideEffects CompactNewOp = True
-primOpHasSideEffects CompactResizeOp = True
-primOpHasSideEffects CompactAllocateBlockOp = True
-primOpHasSideEffects CompactFixupPointersOp = True
-primOpHasSideEffects CompactAdd = True
-primOpHasSideEffects CompactAddWithSharing = True
-primOpHasSideEffects CompactSize = True
-primOpHasSideEffects ParOp = True
-primOpHasSideEffects SparkOp = True
-primOpHasSideEffects GetSparkOp = True
-primOpHasSideEffects NumSparks = True
-primOpHasSideEffects NewBCOOp = True
-primOpHasSideEffects TraceEventOp = True
-primOpHasSideEffects TraceEventBinaryOp = True
-primOpHasSideEffects TraceMarkerOp = True
-primOpHasSideEffects SetThreadAllocationCounter = True
-primOpHasSideEffects (VecReadByteArrayOp _ _ _) = True
-primOpHasSideEffects (VecWriteByteArrayOp _ _ _) = True
-primOpHasSideEffects (VecReadOffAddrOp _ _ _) = True
-primOpHasSideEffects (VecWriteOffAddrOp _ _ _) = True
-primOpHasSideEffects (VecReadScalarByteArrayOp _ _ _) = True
-primOpHasSideEffects (VecWriteScalarByteArrayOp _ _ _) = True
-primOpHasSideEffects (VecReadScalarOffAddrOp _ _ _) = True
-primOpHasSideEffects (VecWriteScalarOffAddrOp _ _ _) = True
-primOpHasSideEffects PrefetchByteArrayOp3 = True
-primOpHasSideEffects PrefetchMutableByteArrayOp3 = True
-primOpHasSideEffects PrefetchAddrOp3 = True
-primOpHasSideEffects PrefetchValueOp3 = True
-primOpHasSideEffects PrefetchByteArrayOp2 = True
-primOpHasSideEffects PrefetchMutableByteArrayOp2 = True
-primOpHasSideEffects PrefetchAddrOp2 = True
-primOpHasSideEffects PrefetchValueOp2 = True
-primOpHasSideEffects PrefetchByteArrayOp1 = True
-primOpHasSideEffects PrefetchMutableByteArrayOp1 = True
-primOpHasSideEffects PrefetchAddrOp1 = True
-primOpHasSideEffects PrefetchValueOp1 = True
-primOpHasSideEffects PrefetchByteArrayOp0 = True
-primOpHasSideEffects PrefetchMutableByteArrayOp0 = True
-primOpHasSideEffects PrefetchAddrOp0 = True
-primOpHasSideEffects PrefetchValueOp0 = True
-primOpHasSideEffects _ = False
diff --git a/ghc-lib/stage0/compiler/build/primop-list.hs-incl b/ghc-lib/stage0/compiler/build/primop-list.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-list.hs-incl
+++ /dev/null
@@ -1,1313 +0,0 @@
-   [CharGtOp
-   , CharGeOp
-   , CharEqOp
-   , CharNeOp
-   , CharLtOp
-   , CharLeOp
-   , OrdOp
-   , Int8ToIntOp
-   , IntToInt8Op
-   , Int8NegOp
-   , Int8AddOp
-   , Int8SubOp
-   , Int8MulOp
-   , Int8QuotOp
-   , Int8RemOp
-   , Int8QuotRemOp
-   , Int8SllOp
-   , Int8SraOp
-   , Int8SrlOp
-   , Int8ToWord8Op
-   , Int8EqOp
-   , Int8GeOp
-   , Int8GtOp
-   , Int8LeOp
-   , Int8LtOp
-   , Int8NeOp
-   , Word8ToWordOp
-   , WordToWord8Op
-   , Word8AddOp
-   , Word8SubOp
-   , Word8MulOp
-   , Word8QuotOp
-   , Word8RemOp
-   , Word8QuotRemOp
-   , Word8AndOp
-   , Word8OrOp
-   , Word8XorOp
-   , Word8NotOp
-   , Word8SllOp
-   , Word8SrlOp
-   , Word8ToInt8Op
-   , Word8EqOp
-   , Word8GeOp
-   , Word8GtOp
-   , Word8LeOp
-   , Word8LtOp
-   , Word8NeOp
-   , Int16ToIntOp
-   , IntToInt16Op
-   , Int16NegOp
-   , Int16AddOp
-   , Int16SubOp
-   , Int16MulOp
-   , Int16QuotOp
-   , Int16RemOp
-   , Int16QuotRemOp
-   , Int16SllOp
-   , Int16SraOp
-   , Int16SrlOp
-   , Int16ToWord16Op
-   , Int16EqOp
-   , Int16GeOp
-   , Int16GtOp
-   , Int16LeOp
-   , Int16LtOp
-   , Int16NeOp
-   , Word16ToWordOp
-   , WordToWord16Op
-   , Word16AddOp
-   , Word16SubOp
-   , Word16MulOp
-   , Word16QuotOp
-   , Word16RemOp
-   , Word16QuotRemOp
-   , Word16AndOp
-   , Word16OrOp
-   , Word16XorOp
-   , Word16NotOp
-   , Word16SllOp
-   , Word16SrlOp
-   , Word16ToInt16Op
-   , Word16EqOp
-   , Word16GeOp
-   , Word16GtOp
-   , Word16LeOp
-   , Word16LtOp
-   , Word16NeOp
-   , Int32ToIntOp
-   , IntToInt32Op
-   , Int32NegOp
-   , Int32AddOp
-   , Int32SubOp
-   , Int32MulOp
-   , Int32QuotOp
-   , Int32RemOp
-   , Int32QuotRemOp
-   , Int32SllOp
-   , Int32SraOp
-   , Int32SrlOp
-   , Int32ToWord32Op
-   , Int32EqOp
-   , Int32GeOp
-   , Int32GtOp
-   , Int32LeOp
-   , Int32LtOp
-   , Int32NeOp
-   , Word32ToWordOp
-   , WordToWord32Op
-   , Word32AddOp
-   , Word32SubOp
-   , Word32MulOp
-   , Word32QuotOp
-   , Word32RemOp
-   , Word32QuotRemOp
-   , Word32AndOp
-   , Word32OrOp
-   , Word32XorOp
-   , Word32NotOp
-   , Word32SllOp
-   , Word32SrlOp
-   , Word32ToInt32Op
-   , Word32EqOp
-   , Word32GeOp
-   , Word32GtOp
-   , Word32LeOp
-   , Word32LtOp
-   , Word32NeOp
-   , Int64ToIntOp
-   , IntToInt64Op
-   , Int64NegOp
-   , Int64AddOp
-   , Int64SubOp
-   , Int64MulOp
-   , Int64QuotOp
-   , Int64RemOp
-   , Int64SllOp
-   , Int64SraOp
-   , Int64SrlOp
-   , Int64ToWord64Op
-   , Int64EqOp
-   , Int64GeOp
-   , Int64GtOp
-   , Int64LeOp
-   , Int64LtOp
-   , Int64NeOp
-   , Word64ToWordOp
-   , WordToWord64Op
-   , Word64AddOp
-   , Word64SubOp
-   , Word64MulOp
-   , Word64QuotOp
-   , Word64RemOp
-   , Word64AndOp
-   , Word64OrOp
-   , Word64XorOp
-   , Word64NotOp
-   , Word64SllOp
-   , Word64SrlOp
-   , Word64ToInt64Op
-   , Word64EqOp
-   , Word64GeOp
-   , Word64GtOp
-   , Word64LeOp
-   , Word64LtOp
-   , Word64NeOp
-   , IntAddOp
-   , IntSubOp
-   , IntMulOp
-   , IntMul2Op
-   , IntMulMayOfloOp
-   , IntQuotOp
-   , IntRemOp
-   , IntQuotRemOp
-   , IntAndOp
-   , IntOrOp
-   , IntXorOp
-   , IntNotOp
-   , IntNegOp
-   , IntAddCOp
-   , IntSubCOp
-   , IntGtOp
-   , IntGeOp
-   , IntEqOp
-   , IntNeOp
-   , IntLtOp
-   , IntLeOp
-   , ChrOp
-   , IntToWordOp
-   , IntToFloatOp
-   , IntToDoubleOp
-   , WordToFloatOp
-   , WordToDoubleOp
-   , IntSllOp
-   , IntSraOp
-   , IntSrlOp
-   , WordAddOp
-   , WordAddCOp
-   , WordSubCOp
-   , WordAdd2Op
-   , WordSubOp
-   , WordMulOp
-   , WordMul2Op
-   , WordQuotOp
-   , WordRemOp
-   , WordQuotRemOp
-   , WordQuotRem2Op
-   , WordAndOp
-   , WordOrOp
-   , WordXorOp
-   , WordNotOp
-   , WordSllOp
-   , WordSrlOp
-   , WordToIntOp
-   , WordGtOp
-   , WordGeOp
-   , WordEqOp
-   , WordNeOp
-   , WordLtOp
-   , WordLeOp
-   , PopCnt8Op
-   , PopCnt16Op
-   , PopCnt32Op
-   , PopCnt64Op
-   , PopCntOp
-   , Pdep8Op
-   , Pdep16Op
-   , Pdep32Op
-   , Pdep64Op
-   , PdepOp
-   , Pext8Op
-   , Pext16Op
-   , Pext32Op
-   , Pext64Op
-   , PextOp
-   , Clz8Op
-   , Clz16Op
-   , Clz32Op
-   , Clz64Op
-   , ClzOp
-   , Ctz8Op
-   , Ctz16Op
-   , Ctz32Op
-   , Ctz64Op
-   , CtzOp
-   , BSwap16Op
-   , BSwap32Op
-   , BSwap64Op
-   , BSwapOp
-   , BRev8Op
-   , BRev16Op
-   , BRev32Op
-   , BRev64Op
-   , BRevOp
-   , Narrow8IntOp
-   , Narrow16IntOp
-   , Narrow32IntOp
-   , Narrow8WordOp
-   , Narrow16WordOp
-   , Narrow32WordOp
-   , DoubleGtOp
-   , DoubleGeOp
-   , DoubleEqOp
-   , DoubleNeOp
-   , DoubleLtOp
-   , DoubleLeOp
-   , DoubleAddOp
-   , DoubleSubOp
-   , DoubleMulOp
-   , DoubleDivOp
-   , DoubleNegOp
-   , DoubleFabsOp
-   , DoubleToIntOp
-   , DoubleToFloatOp
-   , DoubleExpOp
-   , DoubleExpM1Op
-   , DoubleLogOp
-   , DoubleLog1POp
-   , DoubleSqrtOp
-   , DoubleSinOp
-   , DoubleCosOp
-   , DoubleTanOp
-   , DoubleAsinOp
-   , DoubleAcosOp
-   , DoubleAtanOp
-   , DoubleSinhOp
-   , DoubleCoshOp
-   , DoubleTanhOp
-   , DoubleAsinhOp
-   , DoubleAcoshOp
-   , DoubleAtanhOp
-   , DoublePowerOp
-   , DoubleDecode_2IntOp
-   , DoubleDecode_Int64Op
-   , FloatGtOp
-   , FloatGeOp
-   , FloatEqOp
-   , FloatNeOp
-   , FloatLtOp
-   , FloatLeOp
-   , FloatAddOp
-   , FloatSubOp
-   , FloatMulOp
-   , FloatDivOp
-   , FloatNegOp
-   , FloatFabsOp
-   , FloatToIntOp
-   , FloatExpOp
-   , FloatExpM1Op
-   , FloatLogOp
-   , FloatLog1POp
-   , FloatSqrtOp
-   , FloatSinOp
-   , FloatCosOp
-   , FloatTanOp
-   , FloatAsinOp
-   , FloatAcosOp
-   , FloatAtanOp
-   , FloatSinhOp
-   , FloatCoshOp
-   , FloatTanhOp
-   , FloatAsinhOp
-   , FloatAcoshOp
-   , FloatAtanhOp
-   , FloatPowerOp
-   , FloatToDoubleOp
-   , FloatDecode_IntOp
-   , NewArrayOp
-   , ReadArrayOp
-   , WriteArrayOp
-   , SizeofArrayOp
-   , SizeofMutableArrayOp
-   , IndexArrayOp
-   , UnsafeFreezeArrayOp
-   , UnsafeThawArrayOp
-   , CopyArrayOp
-   , CopyMutableArrayOp
-   , CloneArrayOp
-   , CloneMutableArrayOp
-   , FreezeArrayOp
-   , ThawArrayOp
-   , CasArrayOp
-   , NewSmallArrayOp
-   , ShrinkSmallMutableArrayOp_Char
-   , ReadSmallArrayOp
-   , WriteSmallArrayOp
-   , SizeofSmallArrayOp
-   , SizeofSmallMutableArrayOp
-   , GetSizeofSmallMutableArrayOp
-   , IndexSmallArrayOp
-   , UnsafeFreezeSmallArrayOp
-   , UnsafeThawSmallArrayOp
-   , CopySmallArrayOp
-   , CopySmallMutableArrayOp
-   , CloneSmallArrayOp
-   , CloneSmallMutableArrayOp
-   , FreezeSmallArrayOp
-   , ThawSmallArrayOp
-   , CasSmallArrayOp
-   , NewByteArrayOp_Char
-   , NewPinnedByteArrayOp_Char
-   , NewAlignedPinnedByteArrayOp_Char
-   , MutableByteArrayIsPinnedOp
-   , ByteArrayIsPinnedOp
-   , ByteArrayContents_Char
-   , MutableByteArrayContents_Char
-   , ShrinkMutableByteArrayOp_Char
-   , ResizeMutableByteArrayOp_Char
-   , UnsafeFreezeByteArrayOp
-   , SizeofByteArrayOp
-   , SizeofMutableByteArrayOp
-   , GetSizeofMutableByteArrayOp
-   , IndexByteArrayOp_Char
-   , IndexByteArrayOp_WideChar
-   , IndexByteArrayOp_Int
-   , IndexByteArrayOp_Word
-   , IndexByteArrayOp_Addr
-   , IndexByteArrayOp_Float
-   , IndexByteArrayOp_Double
-   , IndexByteArrayOp_StablePtr
-   , IndexByteArrayOp_Int8
-   , IndexByteArrayOp_Int16
-   , IndexByteArrayOp_Int32
-   , IndexByteArrayOp_Int64
-   , IndexByteArrayOp_Word8
-   , IndexByteArrayOp_Word16
-   , IndexByteArrayOp_Word32
-   , IndexByteArrayOp_Word64
-   , IndexByteArrayOp_Word8AsChar
-   , IndexByteArrayOp_Word8AsWideChar
-   , IndexByteArrayOp_Word8AsInt
-   , IndexByteArrayOp_Word8AsWord
-   , IndexByteArrayOp_Word8AsAddr
-   , IndexByteArrayOp_Word8AsFloat
-   , IndexByteArrayOp_Word8AsDouble
-   , IndexByteArrayOp_Word8AsStablePtr
-   , IndexByteArrayOp_Word8AsInt16
-   , IndexByteArrayOp_Word8AsInt32
-   , IndexByteArrayOp_Word8AsInt64
-   , IndexByteArrayOp_Word8AsWord16
-   , IndexByteArrayOp_Word8AsWord32
-   , IndexByteArrayOp_Word8AsWord64
-   , ReadByteArrayOp_Char
-   , ReadByteArrayOp_WideChar
-   , ReadByteArrayOp_Int
-   , ReadByteArrayOp_Word
-   , ReadByteArrayOp_Addr
-   , ReadByteArrayOp_Float
-   , ReadByteArrayOp_Double
-   , ReadByteArrayOp_StablePtr
-   , ReadByteArrayOp_Int8
-   , ReadByteArrayOp_Int16
-   , ReadByteArrayOp_Int32
-   , ReadByteArrayOp_Int64
-   , ReadByteArrayOp_Word8
-   , ReadByteArrayOp_Word16
-   , ReadByteArrayOp_Word32
-   , ReadByteArrayOp_Word64
-   , ReadByteArrayOp_Word8AsChar
-   , ReadByteArrayOp_Word8AsWideChar
-   , ReadByteArrayOp_Word8AsInt
-   , ReadByteArrayOp_Word8AsWord
-   , ReadByteArrayOp_Word8AsAddr
-   , ReadByteArrayOp_Word8AsFloat
-   , ReadByteArrayOp_Word8AsDouble
-   , ReadByteArrayOp_Word8AsStablePtr
-   , ReadByteArrayOp_Word8AsInt16
-   , ReadByteArrayOp_Word8AsInt32
-   , ReadByteArrayOp_Word8AsInt64
-   , ReadByteArrayOp_Word8AsWord16
-   , ReadByteArrayOp_Word8AsWord32
-   , ReadByteArrayOp_Word8AsWord64
-   , WriteByteArrayOp_Char
-   , WriteByteArrayOp_WideChar
-   , WriteByteArrayOp_Int
-   , WriteByteArrayOp_Word
-   , WriteByteArrayOp_Addr
-   , WriteByteArrayOp_Float
-   , WriteByteArrayOp_Double
-   , WriteByteArrayOp_StablePtr
-   , WriteByteArrayOp_Int8
-   , WriteByteArrayOp_Int16
-   , WriteByteArrayOp_Int32
-   , WriteByteArrayOp_Int64
-   , WriteByteArrayOp_Word8
-   , WriteByteArrayOp_Word16
-   , WriteByteArrayOp_Word32
-   , WriteByteArrayOp_Word64
-   , WriteByteArrayOp_Word8AsChar
-   , WriteByteArrayOp_Word8AsWideChar
-   , WriteByteArrayOp_Word8AsInt
-   , WriteByteArrayOp_Word8AsWord
-   , WriteByteArrayOp_Word8AsAddr
-   , WriteByteArrayOp_Word8AsFloat
-   , WriteByteArrayOp_Word8AsDouble
-   , WriteByteArrayOp_Word8AsStablePtr
-   , WriteByteArrayOp_Word8AsInt16
-   , WriteByteArrayOp_Word8AsInt32
-   , WriteByteArrayOp_Word8AsInt64
-   , WriteByteArrayOp_Word8AsWord16
-   , WriteByteArrayOp_Word8AsWord32
-   , WriteByteArrayOp_Word8AsWord64
-   , CompareByteArraysOp
-   , CopyByteArrayOp
-   , CopyMutableByteArrayOp
-   , CopyByteArrayToAddrOp
-   , CopyMutableByteArrayToAddrOp
-   , CopyAddrToByteArrayOp
-   , SetByteArrayOp
-   , AtomicReadByteArrayOp_Int
-   , AtomicWriteByteArrayOp_Int
-   , CasByteArrayOp_Int
-   , CasByteArrayOp_Int8
-   , CasByteArrayOp_Int16
-   , CasByteArrayOp_Int32
-   , CasByteArrayOp_Int64
-   , FetchAddByteArrayOp_Int
-   , FetchSubByteArrayOp_Int
-   , FetchAndByteArrayOp_Int
-   , FetchNandByteArrayOp_Int
-   , FetchOrByteArrayOp_Int
-   , FetchXorByteArrayOp_Int
-   , AddrAddOp
-   , AddrSubOp
-   , AddrRemOp
-   , AddrToIntOp
-   , IntToAddrOp
-   , AddrGtOp
-   , AddrGeOp
-   , AddrEqOp
-   , AddrNeOp
-   , AddrLtOp
-   , AddrLeOp
-   , IndexOffAddrOp_Char
-   , IndexOffAddrOp_WideChar
-   , IndexOffAddrOp_Int
-   , IndexOffAddrOp_Word
-   , IndexOffAddrOp_Addr
-   , IndexOffAddrOp_Float
-   , IndexOffAddrOp_Double
-   , IndexOffAddrOp_StablePtr
-   , IndexOffAddrOp_Int8
-   , IndexOffAddrOp_Int16
-   , IndexOffAddrOp_Int32
-   , IndexOffAddrOp_Int64
-   , IndexOffAddrOp_Word8
-   , IndexOffAddrOp_Word16
-   , IndexOffAddrOp_Word32
-   , IndexOffAddrOp_Word64
-   , ReadOffAddrOp_Char
-   , ReadOffAddrOp_WideChar
-   , ReadOffAddrOp_Int
-   , ReadOffAddrOp_Word
-   , ReadOffAddrOp_Addr
-   , ReadOffAddrOp_Float
-   , ReadOffAddrOp_Double
-   , ReadOffAddrOp_StablePtr
-   , ReadOffAddrOp_Int8
-   , ReadOffAddrOp_Int16
-   , ReadOffAddrOp_Int32
-   , ReadOffAddrOp_Int64
-   , ReadOffAddrOp_Word8
-   , ReadOffAddrOp_Word16
-   , ReadOffAddrOp_Word32
-   , ReadOffAddrOp_Word64
-   , WriteOffAddrOp_Char
-   , WriteOffAddrOp_WideChar
-   , WriteOffAddrOp_Int
-   , WriteOffAddrOp_Word
-   , WriteOffAddrOp_Addr
-   , WriteOffAddrOp_Float
-   , WriteOffAddrOp_Double
-   , WriteOffAddrOp_StablePtr
-   , WriteOffAddrOp_Int8
-   , WriteOffAddrOp_Int16
-   , WriteOffAddrOp_Int32
-   , WriteOffAddrOp_Int64
-   , WriteOffAddrOp_Word8
-   , WriteOffAddrOp_Word16
-   , WriteOffAddrOp_Word32
-   , WriteOffAddrOp_Word64
-   , InterlockedExchange_Addr
-   , InterlockedExchange_Word
-   , CasAddrOp_Addr
-   , CasAddrOp_Word
-   , CasAddrOp_Word8
-   , CasAddrOp_Word16
-   , CasAddrOp_Word32
-   , CasAddrOp_Word64
-   , FetchAddAddrOp_Word
-   , FetchSubAddrOp_Word
-   , FetchAndAddrOp_Word
-   , FetchNandAddrOp_Word
-   , FetchOrAddrOp_Word
-   , FetchXorAddrOp_Word
-   , AtomicReadAddrOp_Word
-   , AtomicWriteAddrOp_Word
-   , NewMutVarOp
-   , ReadMutVarOp
-   , WriteMutVarOp
-   , AtomicModifyMutVar2Op
-   , AtomicModifyMutVar_Op
-   , CasMutVarOp
-   , CatchOp
-   , RaiseOp
-   , RaiseUnderflowOp
-   , RaiseOverflowOp
-   , RaiseDivZeroOp
-   , RaiseIOOp
-   , MaskAsyncExceptionsOp
-   , MaskUninterruptibleOp
-   , UnmaskAsyncExceptionsOp
-   , MaskStatus
-   , NewPromptTagOp
-   , PromptOp
-   , Control0Op
-   , AtomicallyOp
-   , RetryOp
-   , CatchRetryOp
-   , CatchSTMOp
-   , NewTVarOp
-   , ReadTVarOp
-   , ReadTVarIOOp
-   , WriteTVarOp
-   , NewMVarOp
-   , TakeMVarOp
-   , TryTakeMVarOp
-   , PutMVarOp
-   , TryPutMVarOp
-   , ReadMVarOp
-   , TryReadMVarOp
-   , IsEmptyMVarOp
-   , NewIOPortOp
-   , ReadIOPortOp
-   , WriteIOPortOp
-   , DelayOp
-   , WaitReadOp
-   , WaitWriteOp
-   , ForkOp
-   , ForkOnOp
-   , KillThreadOp
-   , YieldOp
-   , MyThreadIdOp
-   , LabelThreadOp
-   , IsCurrentThreadBoundOp
-   , NoDuplicateOp
-   , GetThreadLabelOp
-   , ThreadStatusOp
-   , ListThreadsOp
-   , MkWeakOp
-   , MkWeakNoFinalizerOp
-   , AddCFinalizerToWeakOp
-   , DeRefWeakOp
-   , FinalizeWeakOp
-   , TouchOp
-   , MakeStablePtrOp
-   , DeRefStablePtrOp
-   , EqStablePtrOp
-   , MakeStableNameOp
-   , StableNameToIntOp
-   , CompactNewOp
-   , CompactResizeOp
-   , CompactContainsOp
-   , CompactContainsAnyOp
-   , CompactGetFirstBlockOp
-   , CompactGetNextBlockOp
-   , CompactAllocateBlockOp
-   , CompactFixupPointersOp
-   , CompactAdd
-   , CompactAddWithSharing
-   , CompactSize
-   , ReallyUnsafePtrEqualityOp
-   , ParOp
-   , SparkOp
-   , SeqOp
-   , GetSparkOp
-   , NumSparks
-   , KeepAliveOp
-   , DataToTagOp
-   , TagToEnumOp
-   , AddrToAnyOp
-   , AnyToAddrOp
-   , MkApUpd0_Op
-   , NewBCOOp
-   , UnpackClosureOp
-   , ClosureSizeOp
-   , GetApStackValOp
-   , GetCCSOfOp
-   , GetCurrentCCSOp
-   , ClearCCSOp
-   , WhereFromOp
-   , TraceEventOp
-   , TraceEventBinaryOp
-   , TraceMarkerOp
-   , SetThreadAllocationCounter
-   , (VecBroadcastOp IntVec 16 W8)
-   , (VecBroadcastOp IntVec 8 W16)
-   , (VecBroadcastOp IntVec 4 W32)
-   , (VecBroadcastOp IntVec 2 W64)
-   , (VecBroadcastOp IntVec 32 W8)
-   , (VecBroadcastOp IntVec 16 W16)
-   , (VecBroadcastOp IntVec 8 W32)
-   , (VecBroadcastOp IntVec 4 W64)
-   , (VecBroadcastOp IntVec 64 W8)
-   , (VecBroadcastOp IntVec 32 W16)
-   , (VecBroadcastOp IntVec 16 W32)
-   , (VecBroadcastOp IntVec 8 W64)
-   , (VecBroadcastOp WordVec 16 W8)
-   , (VecBroadcastOp WordVec 8 W16)
-   , (VecBroadcastOp WordVec 4 W32)
-   , (VecBroadcastOp WordVec 2 W64)
-   , (VecBroadcastOp WordVec 32 W8)
-   , (VecBroadcastOp WordVec 16 W16)
-   , (VecBroadcastOp WordVec 8 W32)
-   , (VecBroadcastOp WordVec 4 W64)
-   , (VecBroadcastOp WordVec 64 W8)
-   , (VecBroadcastOp WordVec 32 W16)
-   , (VecBroadcastOp WordVec 16 W32)
-   , (VecBroadcastOp WordVec 8 W64)
-   , (VecBroadcastOp FloatVec 4 W32)
-   , (VecBroadcastOp FloatVec 2 W64)
-   , (VecBroadcastOp FloatVec 8 W32)
-   , (VecBroadcastOp FloatVec 4 W64)
-   , (VecBroadcastOp FloatVec 16 W32)
-   , (VecBroadcastOp FloatVec 8 W64)
-   , (VecPackOp IntVec 16 W8)
-   , (VecPackOp IntVec 8 W16)
-   , (VecPackOp IntVec 4 W32)
-   , (VecPackOp IntVec 2 W64)
-   , (VecPackOp IntVec 32 W8)
-   , (VecPackOp IntVec 16 W16)
-   , (VecPackOp IntVec 8 W32)
-   , (VecPackOp IntVec 4 W64)
-   , (VecPackOp IntVec 64 W8)
-   , (VecPackOp IntVec 32 W16)
-   , (VecPackOp IntVec 16 W32)
-   , (VecPackOp IntVec 8 W64)
-   , (VecPackOp WordVec 16 W8)
-   , (VecPackOp WordVec 8 W16)
-   , (VecPackOp WordVec 4 W32)
-   , (VecPackOp WordVec 2 W64)
-   , (VecPackOp WordVec 32 W8)
-   , (VecPackOp WordVec 16 W16)
-   , (VecPackOp WordVec 8 W32)
-   , (VecPackOp WordVec 4 W64)
-   , (VecPackOp WordVec 64 W8)
-   , (VecPackOp WordVec 32 W16)
-   , (VecPackOp WordVec 16 W32)
-   , (VecPackOp WordVec 8 W64)
-   , (VecPackOp FloatVec 4 W32)
-   , (VecPackOp FloatVec 2 W64)
-   , (VecPackOp FloatVec 8 W32)
-   , (VecPackOp FloatVec 4 W64)
-   , (VecPackOp FloatVec 16 W32)
-   , (VecPackOp FloatVec 8 W64)
-   , (VecUnpackOp IntVec 16 W8)
-   , (VecUnpackOp IntVec 8 W16)
-   , (VecUnpackOp IntVec 4 W32)
-   , (VecUnpackOp IntVec 2 W64)
-   , (VecUnpackOp IntVec 32 W8)
-   , (VecUnpackOp IntVec 16 W16)
-   , (VecUnpackOp IntVec 8 W32)
-   , (VecUnpackOp IntVec 4 W64)
-   , (VecUnpackOp IntVec 64 W8)
-   , (VecUnpackOp IntVec 32 W16)
-   , (VecUnpackOp IntVec 16 W32)
-   , (VecUnpackOp IntVec 8 W64)
-   , (VecUnpackOp WordVec 16 W8)
-   , (VecUnpackOp WordVec 8 W16)
-   , (VecUnpackOp WordVec 4 W32)
-   , (VecUnpackOp WordVec 2 W64)
-   , (VecUnpackOp WordVec 32 W8)
-   , (VecUnpackOp WordVec 16 W16)
-   , (VecUnpackOp WordVec 8 W32)
-   , (VecUnpackOp WordVec 4 W64)
-   , (VecUnpackOp WordVec 64 W8)
-   , (VecUnpackOp WordVec 32 W16)
-   , (VecUnpackOp WordVec 16 W32)
-   , (VecUnpackOp WordVec 8 W64)
-   , (VecUnpackOp FloatVec 4 W32)
-   , (VecUnpackOp FloatVec 2 W64)
-   , (VecUnpackOp FloatVec 8 W32)
-   , (VecUnpackOp FloatVec 4 W64)
-   , (VecUnpackOp FloatVec 16 W32)
-   , (VecUnpackOp FloatVec 8 W64)
-   , (VecInsertOp IntVec 16 W8)
-   , (VecInsertOp IntVec 8 W16)
-   , (VecInsertOp IntVec 4 W32)
-   , (VecInsertOp IntVec 2 W64)
-   , (VecInsertOp IntVec 32 W8)
-   , (VecInsertOp IntVec 16 W16)
-   , (VecInsertOp IntVec 8 W32)
-   , (VecInsertOp IntVec 4 W64)
-   , (VecInsertOp IntVec 64 W8)
-   , (VecInsertOp IntVec 32 W16)
-   , (VecInsertOp IntVec 16 W32)
-   , (VecInsertOp IntVec 8 W64)
-   , (VecInsertOp WordVec 16 W8)
-   , (VecInsertOp WordVec 8 W16)
-   , (VecInsertOp WordVec 4 W32)
-   , (VecInsertOp WordVec 2 W64)
-   , (VecInsertOp WordVec 32 W8)
-   , (VecInsertOp WordVec 16 W16)
-   , (VecInsertOp WordVec 8 W32)
-   , (VecInsertOp WordVec 4 W64)
-   , (VecInsertOp WordVec 64 W8)
-   , (VecInsertOp WordVec 32 W16)
-   , (VecInsertOp WordVec 16 W32)
-   , (VecInsertOp WordVec 8 W64)
-   , (VecInsertOp FloatVec 4 W32)
-   , (VecInsertOp FloatVec 2 W64)
-   , (VecInsertOp FloatVec 8 W32)
-   , (VecInsertOp FloatVec 4 W64)
-   , (VecInsertOp FloatVec 16 W32)
-   , (VecInsertOp FloatVec 8 W64)
-   , (VecAddOp IntVec 16 W8)
-   , (VecAddOp IntVec 8 W16)
-   , (VecAddOp IntVec 4 W32)
-   , (VecAddOp IntVec 2 W64)
-   , (VecAddOp IntVec 32 W8)
-   , (VecAddOp IntVec 16 W16)
-   , (VecAddOp IntVec 8 W32)
-   , (VecAddOp IntVec 4 W64)
-   , (VecAddOp IntVec 64 W8)
-   , (VecAddOp IntVec 32 W16)
-   , (VecAddOp IntVec 16 W32)
-   , (VecAddOp IntVec 8 W64)
-   , (VecAddOp WordVec 16 W8)
-   , (VecAddOp WordVec 8 W16)
-   , (VecAddOp WordVec 4 W32)
-   , (VecAddOp WordVec 2 W64)
-   , (VecAddOp WordVec 32 W8)
-   , (VecAddOp WordVec 16 W16)
-   , (VecAddOp WordVec 8 W32)
-   , (VecAddOp WordVec 4 W64)
-   , (VecAddOp WordVec 64 W8)
-   , (VecAddOp WordVec 32 W16)
-   , (VecAddOp WordVec 16 W32)
-   , (VecAddOp WordVec 8 W64)
-   , (VecAddOp FloatVec 4 W32)
-   , (VecAddOp FloatVec 2 W64)
-   , (VecAddOp FloatVec 8 W32)
-   , (VecAddOp FloatVec 4 W64)
-   , (VecAddOp FloatVec 16 W32)
-   , (VecAddOp FloatVec 8 W64)
-   , (VecSubOp IntVec 16 W8)
-   , (VecSubOp IntVec 8 W16)
-   , (VecSubOp IntVec 4 W32)
-   , (VecSubOp IntVec 2 W64)
-   , (VecSubOp IntVec 32 W8)
-   , (VecSubOp IntVec 16 W16)
-   , (VecSubOp IntVec 8 W32)
-   , (VecSubOp IntVec 4 W64)
-   , (VecSubOp IntVec 64 W8)
-   , (VecSubOp IntVec 32 W16)
-   , (VecSubOp IntVec 16 W32)
-   , (VecSubOp IntVec 8 W64)
-   , (VecSubOp WordVec 16 W8)
-   , (VecSubOp WordVec 8 W16)
-   , (VecSubOp WordVec 4 W32)
-   , (VecSubOp WordVec 2 W64)
-   , (VecSubOp WordVec 32 W8)
-   , (VecSubOp WordVec 16 W16)
-   , (VecSubOp WordVec 8 W32)
-   , (VecSubOp WordVec 4 W64)
-   , (VecSubOp WordVec 64 W8)
-   , (VecSubOp WordVec 32 W16)
-   , (VecSubOp WordVec 16 W32)
-   , (VecSubOp WordVec 8 W64)
-   , (VecSubOp FloatVec 4 W32)
-   , (VecSubOp FloatVec 2 W64)
-   , (VecSubOp FloatVec 8 W32)
-   , (VecSubOp FloatVec 4 W64)
-   , (VecSubOp FloatVec 16 W32)
-   , (VecSubOp FloatVec 8 W64)
-   , (VecMulOp IntVec 16 W8)
-   , (VecMulOp IntVec 8 W16)
-   , (VecMulOp IntVec 4 W32)
-   , (VecMulOp IntVec 2 W64)
-   , (VecMulOp IntVec 32 W8)
-   , (VecMulOp IntVec 16 W16)
-   , (VecMulOp IntVec 8 W32)
-   , (VecMulOp IntVec 4 W64)
-   , (VecMulOp IntVec 64 W8)
-   , (VecMulOp IntVec 32 W16)
-   , (VecMulOp IntVec 16 W32)
-   , (VecMulOp IntVec 8 W64)
-   , (VecMulOp WordVec 16 W8)
-   , (VecMulOp WordVec 8 W16)
-   , (VecMulOp WordVec 4 W32)
-   , (VecMulOp WordVec 2 W64)
-   , (VecMulOp WordVec 32 W8)
-   , (VecMulOp WordVec 16 W16)
-   , (VecMulOp WordVec 8 W32)
-   , (VecMulOp WordVec 4 W64)
-   , (VecMulOp WordVec 64 W8)
-   , (VecMulOp WordVec 32 W16)
-   , (VecMulOp WordVec 16 W32)
-   , (VecMulOp WordVec 8 W64)
-   , (VecMulOp FloatVec 4 W32)
-   , (VecMulOp FloatVec 2 W64)
-   , (VecMulOp FloatVec 8 W32)
-   , (VecMulOp FloatVec 4 W64)
-   , (VecMulOp FloatVec 16 W32)
-   , (VecMulOp FloatVec 8 W64)
-   , (VecDivOp FloatVec 4 W32)
-   , (VecDivOp FloatVec 2 W64)
-   , (VecDivOp FloatVec 8 W32)
-   , (VecDivOp FloatVec 4 W64)
-   , (VecDivOp FloatVec 16 W32)
-   , (VecDivOp FloatVec 8 W64)
-   , (VecQuotOp IntVec 16 W8)
-   , (VecQuotOp IntVec 8 W16)
-   , (VecQuotOp IntVec 4 W32)
-   , (VecQuotOp IntVec 2 W64)
-   , (VecQuotOp IntVec 32 W8)
-   , (VecQuotOp IntVec 16 W16)
-   , (VecQuotOp IntVec 8 W32)
-   , (VecQuotOp IntVec 4 W64)
-   , (VecQuotOp IntVec 64 W8)
-   , (VecQuotOp IntVec 32 W16)
-   , (VecQuotOp IntVec 16 W32)
-   , (VecQuotOp IntVec 8 W64)
-   , (VecQuotOp WordVec 16 W8)
-   , (VecQuotOp WordVec 8 W16)
-   , (VecQuotOp WordVec 4 W32)
-   , (VecQuotOp WordVec 2 W64)
-   , (VecQuotOp WordVec 32 W8)
-   , (VecQuotOp WordVec 16 W16)
-   , (VecQuotOp WordVec 8 W32)
-   , (VecQuotOp WordVec 4 W64)
-   , (VecQuotOp WordVec 64 W8)
-   , (VecQuotOp WordVec 32 W16)
-   , (VecQuotOp WordVec 16 W32)
-   , (VecQuotOp WordVec 8 W64)
-   , (VecRemOp IntVec 16 W8)
-   , (VecRemOp IntVec 8 W16)
-   , (VecRemOp IntVec 4 W32)
-   , (VecRemOp IntVec 2 W64)
-   , (VecRemOp IntVec 32 W8)
-   , (VecRemOp IntVec 16 W16)
-   , (VecRemOp IntVec 8 W32)
-   , (VecRemOp IntVec 4 W64)
-   , (VecRemOp IntVec 64 W8)
-   , (VecRemOp IntVec 32 W16)
-   , (VecRemOp IntVec 16 W32)
-   , (VecRemOp IntVec 8 W64)
-   , (VecRemOp WordVec 16 W8)
-   , (VecRemOp WordVec 8 W16)
-   , (VecRemOp WordVec 4 W32)
-   , (VecRemOp WordVec 2 W64)
-   , (VecRemOp WordVec 32 W8)
-   , (VecRemOp WordVec 16 W16)
-   , (VecRemOp WordVec 8 W32)
-   , (VecRemOp WordVec 4 W64)
-   , (VecRemOp WordVec 64 W8)
-   , (VecRemOp WordVec 32 W16)
-   , (VecRemOp WordVec 16 W32)
-   , (VecRemOp WordVec 8 W64)
-   , (VecNegOp IntVec 16 W8)
-   , (VecNegOp IntVec 8 W16)
-   , (VecNegOp IntVec 4 W32)
-   , (VecNegOp IntVec 2 W64)
-   , (VecNegOp IntVec 32 W8)
-   , (VecNegOp IntVec 16 W16)
-   , (VecNegOp IntVec 8 W32)
-   , (VecNegOp IntVec 4 W64)
-   , (VecNegOp IntVec 64 W8)
-   , (VecNegOp IntVec 32 W16)
-   , (VecNegOp IntVec 16 W32)
-   , (VecNegOp IntVec 8 W64)
-   , (VecNegOp FloatVec 4 W32)
-   , (VecNegOp FloatVec 2 W64)
-   , (VecNegOp FloatVec 8 W32)
-   , (VecNegOp FloatVec 4 W64)
-   , (VecNegOp FloatVec 16 W32)
-   , (VecNegOp FloatVec 8 W64)
-   , (VecIndexByteArrayOp IntVec 16 W8)
-   , (VecIndexByteArrayOp IntVec 8 W16)
-   , (VecIndexByteArrayOp IntVec 4 W32)
-   , (VecIndexByteArrayOp IntVec 2 W64)
-   , (VecIndexByteArrayOp IntVec 32 W8)
-   , (VecIndexByteArrayOp IntVec 16 W16)
-   , (VecIndexByteArrayOp IntVec 8 W32)
-   , (VecIndexByteArrayOp IntVec 4 W64)
-   , (VecIndexByteArrayOp IntVec 64 W8)
-   , (VecIndexByteArrayOp IntVec 32 W16)
-   , (VecIndexByteArrayOp IntVec 16 W32)
-   , (VecIndexByteArrayOp IntVec 8 W64)
-   , (VecIndexByteArrayOp WordVec 16 W8)
-   , (VecIndexByteArrayOp WordVec 8 W16)
-   , (VecIndexByteArrayOp WordVec 4 W32)
-   , (VecIndexByteArrayOp WordVec 2 W64)
-   , (VecIndexByteArrayOp WordVec 32 W8)
-   , (VecIndexByteArrayOp WordVec 16 W16)
-   , (VecIndexByteArrayOp WordVec 8 W32)
-   , (VecIndexByteArrayOp WordVec 4 W64)
-   , (VecIndexByteArrayOp WordVec 64 W8)
-   , (VecIndexByteArrayOp WordVec 32 W16)
-   , (VecIndexByteArrayOp WordVec 16 W32)
-   , (VecIndexByteArrayOp WordVec 8 W64)
-   , (VecIndexByteArrayOp FloatVec 4 W32)
-   , (VecIndexByteArrayOp FloatVec 2 W64)
-   , (VecIndexByteArrayOp FloatVec 8 W32)
-   , (VecIndexByteArrayOp FloatVec 4 W64)
-   , (VecIndexByteArrayOp FloatVec 16 W32)
-   , (VecIndexByteArrayOp FloatVec 8 W64)
-   , (VecReadByteArrayOp IntVec 16 W8)
-   , (VecReadByteArrayOp IntVec 8 W16)
-   , (VecReadByteArrayOp IntVec 4 W32)
-   , (VecReadByteArrayOp IntVec 2 W64)
-   , (VecReadByteArrayOp IntVec 32 W8)
-   , (VecReadByteArrayOp IntVec 16 W16)
-   , (VecReadByteArrayOp IntVec 8 W32)
-   , (VecReadByteArrayOp IntVec 4 W64)
-   , (VecReadByteArrayOp IntVec 64 W8)
-   , (VecReadByteArrayOp IntVec 32 W16)
-   , (VecReadByteArrayOp IntVec 16 W32)
-   , (VecReadByteArrayOp IntVec 8 W64)
-   , (VecReadByteArrayOp WordVec 16 W8)
-   , (VecReadByteArrayOp WordVec 8 W16)
-   , (VecReadByteArrayOp WordVec 4 W32)
-   , (VecReadByteArrayOp WordVec 2 W64)
-   , (VecReadByteArrayOp WordVec 32 W8)
-   , (VecReadByteArrayOp WordVec 16 W16)
-   , (VecReadByteArrayOp WordVec 8 W32)
-   , (VecReadByteArrayOp WordVec 4 W64)
-   , (VecReadByteArrayOp WordVec 64 W8)
-   , (VecReadByteArrayOp WordVec 32 W16)
-   , (VecReadByteArrayOp WordVec 16 W32)
-   , (VecReadByteArrayOp WordVec 8 W64)
-   , (VecReadByteArrayOp FloatVec 4 W32)
-   , (VecReadByteArrayOp FloatVec 2 W64)
-   , (VecReadByteArrayOp FloatVec 8 W32)
-   , (VecReadByteArrayOp FloatVec 4 W64)
-   , (VecReadByteArrayOp FloatVec 16 W32)
-   , (VecReadByteArrayOp FloatVec 8 W64)
-   , (VecWriteByteArrayOp IntVec 16 W8)
-   , (VecWriteByteArrayOp IntVec 8 W16)
-   , (VecWriteByteArrayOp IntVec 4 W32)
-   , (VecWriteByteArrayOp IntVec 2 W64)
-   , (VecWriteByteArrayOp IntVec 32 W8)
-   , (VecWriteByteArrayOp IntVec 16 W16)
-   , (VecWriteByteArrayOp IntVec 8 W32)
-   , (VecWriteByteArrayOp IntVec 4 W64)
-   , (VecWriteByteArrayOp IntVec 64 W8)
-   , (VecWriteByteArrayOp IntVec 32 W16)
-   , (VecWriteByteArrayOp IntVec 16 W32)
-   , (VecWriteByteArrayOp IntVec 8 W64)
-   , (VecWriteByteArrayOp WordVec 16 W8)
-   , (VecWriteByteArrayOp WordVec 8 W16)
-   , (VecWriteByteArrayOp WordVec 4 W32)
-   , (VecWriteByteArrayOp WordVec 2 W64)
-   , (VecWriteByteArrayOp WordVec 32 W8)
-   , (VecWriteByteArrayOp WordVec 16 W16)
-   , (VecWriteByteArrayOp WordVec 8 W32)
-   , (VecWriteByteArrayOp WordVec 4 W64)
-   , (VecWriteByteArrayOp WordVec 64 W8)
-   , (VecWriteByteArrayOp WordVec 32 W16)
-   , (VecWriteByteArrayOp WordVec 16 W32)
-   , (VecWriteByteArrayOp WordVec 8 W64)
-   , (VecWriteByteArrayOp FloatVec 4 W32)
-   , (VecWriteByteArrayOp FloatVec 2 W64)
-   , (VecWriteByteArrayOp FloatVec 8 W32)
-   , (VecWriteByteArrayOp FloatVec 4 W64)
-   , (VecWriteByteArrayOp FloatVec 16 W32)
-   , (VecWriteByteArrayOp FloatVec 8 W64)
-   , (VecIndexOffAddrOp IntVec 16 W8)
-   , (VecIndexOffAddrOp IntVec 8 W16)
-   , (VecIndexOffAddrOp IntVec 4 W32)
-   , (VecIndexOffAddrOp IntVec 2 W64)
-   , (VecIndexOffAddrOp IntVec 32 W8)
-   , (VecIndexOffAddrOp IntVec 16 W16)
-   , (VecIndexOffAddrOp IntVec 8 W32)
-   , (VecIndexOffAddrOp IntVec 4 W64)
-   , (VecIndexOffAddrOp IntVec 64 W8)
-   , (VecIndexOffAddrOp IntVec 32 W16)
-   , (VecIndexOffAddrOp IntVec 16 W32)
-   , (VecIndexOffAddrOp IntVec 8 W64)
-   , (VecIndexOffAddrOp WordVec 16 W8)
-   , (VecIndexOffAddrOp WordVec 8 W16)
-   , (VecIndexOffAddrOp WordVec 4 W32)
-   , (VecIndexOffAddrOp WordVec 2 W64)
-   , (VecIndexOffAddrOp WordVec 32 W8)
-   , (VecIndexOffAddrOp WordVec 16 W16)
-   , (VecIndexOffAddrOp WordVec 8 W32)
-   , (VecIndexOffAddrOp WordVec 4 W64)
-   , (VecIndexOffAddrOp WordVec 64 W8)
-   , (VecIndexOffAddrOp WordVec 32 W16)
-   , (VecIndexOffAddrOp WordVec 16 W32)
-   , (VecIndexOffAddrOp WordVec 8 W64)
-   , (VecIndexOffAddrOp FloatVec 4 W32)
-   , (VecIndexOffAddrOp FloatVec 2 W64)
-   , (VecIndexOffAddrOp FloatVec 8 W32)
-   , (VecIndexOffAddrOp FloatVec 4 W64)
-   , (VecIndexOffAddrOp FloatVec 16 W32)
-   , (VecIndexOffAddrOp FloatVec 8 W64)
-   , (VecReadOffAddrOp IntVec 16 W8)
-   , (VecReadOffAddrOp IntVec 8 W16)
-   , (VecReadOffAddrOp IntVec 4 W32)
-   , (VecReadOffAddrOp IntVec 2 W64)
-   , (VecReadOffAddrOp IntVec 32 W8)
-   , (VecReadOffAddrOp IntVec 16 W16)
-   , (VecReadOffAddrOp IntVec 8 W32)
-   , (VecReadOffAddrOp IntVec 4 W64)
-   , (VecReadOffAddrOp IntVec 64 W8)
-   , (VecReadOffAddrOp IntVec 32 W16)
-   , (VecReadOffAddrOp IntVec 16 W32)
-   , (VecReadOffAddrOp IntVec 8 W64)
-   , (VecReadOffAddrOp WordVec 16 W8)
-   , (VecReadOffAddrOp WordVec 8 W16)
-   , (VecReadOffAddrOp WordVec 4 W32)
-   , (VecReadOffAddrOp WordVec 2 W64)
-   , (VecReadOffAddrOp WordVec 32 W8)
-   , (VecReadOffAddrOp WordVec 16 W16)
-   , (VecReadOffAddrOp WordVec 8 W32)
-   , (VecReadOffAddrOp WordVec 4 W64)
-   , (VecReadOffAddrOp WordVec 64 W8)
-   , (VecReadOffAddrOp WordVec 32 W16)
-   , (VecReadOffAddrOp WordVec 16 W32)
-   , (VecReadOffAddrOp WordVec 8 W64)
-   , (VecReadOffAddrOp FloatVec 4 W32)
-   , (VecReadOffAddrOp FloatVec 2 W64)
-   , (VecReadOffAddrOp FloatVec 8 W32)
-   , (VecReadOffAddrOp FloatVec 4 W64)
-   , (VecReadOffAddrOp FloatVec 16 W32)
-   , (VecReadOffAddrOp FloatVec 8 W64)
-   , (VecWriteOffAddrOp IntVec 16 W8)
-   , (VecWriteOffAddrOp IntVec 8 W16)
-   , (VecWriteOffAddrOp IntVec 4 W32)
-   , (VecWriteOffAddrOp IntVec 2 W64)
-   , (VecWriteOffAddrOp IntVec 32 W8)
-   , (VecWriteOffAddrOp IntVec 16 W16)
-   , (VecWriteOffAddrOp IntVec 8 W32)
-   , (VecWriteOffAddrOp IntVec 4 W64)
-   , (VecWriteOffAddrOp IntVec 64 W8)
-   , (VecWriteOffAddrOp IntVec 32 W16)
-   , (VecWriteOffAddrOp IntVec 16 W32)
-   , (VecWriteOffAddrOp IntVec 8 W64)
-   , (VecWriteOffAddrOp WordVec 16 W8)
-   , (VecWriteOffAddrOp WordVec 8 W16)
-   , (VecWriteOffAddrOp WordVec 4 W32)
-   , (VecWriteOffAddrOp WordVec 2 W64)
-   , (VecWriteOffAddrOp WordVec 32 W8)
-   , (VecWriteOffAddrOp WordVec 16 W16)
-   , (VecWriteOffAddrOp WordVec 8 W32)
-   , (VecWriteOffAddrOp WordVec 4 W64)
-   , (VecWriteOffAddrOp WordVec 64 W8)
-   , (VecWriteOffAddrOp WordVec 32 W16)
-   , (VecWriteOffAddrOp WordVec 16 W32)
-   , (VecWriteOffAddrOp WordVec 8 W64)
-   , (VecWriteOffAddrOp FloatVec 4 W32)
-   , (VecWriteOffAddrOp FloatVec 2 W64)
-   , (VecWriteOffAddrOp FloatVec 8 W32)
-   , (VecWriteOffAddrOp FloatVec 4 W64)
-   , (VecWriteOffAddrOp FloatVec 16 W32)
-   , (VecWriteOffAddrOp FloatVec 8 W64)
-   , (VecIndexScalarByteArrayOp IntVec 16 W8)
-   , (VecIndexScalarByteArrayOp IntVec 8 W16)
-   , (VecIndexScalarByteArrayOp IntVec 4 W32)
-   , (VecIndexScalarByteArrayOp IntVec 2 W64)
-   , (VecIndexScalarByteArrayOp IntVec 32 W8)
-   , (VecIndexScalarByteArrayOp IntVec 16 W16)
-   , (VecIndexScalarByteArrayOp IntVec 8 W32)
-   , (VecIndexScalarByteArrayOp IntVec 4 W64)
-   , (VecIndexScalarByteArrayOp IntVec 64 W8)
-   , (VecIndexScalarByteArrayOp IntVec 32 W16)
-   , (VecIndexScalarByteArrayOp IntVec 16 W32)
-   , (VecIndexScalarByteArrayOp IntVec 8 W64)
-   , (VecIndexScalarByteArrayOp WordVec 16 W8)
-   , (VecIndexScalarByteArrayOp WordVec 8 W16)
-   , (VecIndexScalarByteArrayOp WordVec 4 W32)
-   , (VecIndexScalarByteArrayOp WordVec 2 W64)
-   , (VecIndexScalarByteArrayOp WordVec 32 W8)
-   , (VecIndexScalarByteArrayOp WordVec 16 W16)
-   , (VecIndexScalarByteArrayOp WordVec 8 W32)
-   , (VecIndexScalarByteArrayOp WordVec 4 W64)
-   , (VecIndexScalarByteArrayOp WordVec 64 W8)
-   , (VecIndexScalarByteArrayOp WordVec 32 W16)
-   , (VecIndexScalarByteArrayOp WordVec 16 W32)
-   , (VecIndexScalarByteArrayOp WordVec 8 W64)
-   , (VecIndexScalarByteArrayOp FloatVec 4 W32)
-   , (VecIndexScalarByteArrayOp FloatVec 2 W64)
-   , (VecIndexScalarByteArrayOp FloatVec 8 W32)
-   , (VecIndexScalarByteArrayOp FloatVec 4 W64)
-   , (VecIndexScalarByteArrayOp FloatVec 16 W32)
-   , (VecIndexScalarByteArrayOp FloatVec 8 W64)
-   , (VecReadScalarByteArrayOp IntVec 16 W8)
-   , (VecReadScalarByteArrayOp IntVec 8 W16)
-   , (VecReadScalarByteArrayOp IntVec 4 W32)
-   , (VecReadScalarByteArrayOp IntVec 2 W64)
-   , (VecReadScalarByteArrayOp IntVec 32 W8)
-   , (VecReadScalarByteArrayOp IntVec 16 W16)
-   , (VecReadScalarByteArrayOp IntVec 8 W32)
-   , (VecReadScalarByteArrayOp IntVec 4 W64)
-   , (VecReadScalarByteArrayOp IntVec 64 W8)
-   , (VecReadScalarByteArrayOp IntVec 32 W16)
-   , (VecReadScalarByteArrayOp IntVec 16 W32)
-   , (VecReadScalarByteArrayOp IntVec 8 W64)
-   , (VecReadScalarByteArrayOp WordVec 16 W8)
-   , (VecReadScalarByteArrayOp WordVec 8 W16)
-   , (VecReadScalarByteArrayOp WordVec 4 W32)
-   , (VecReadScalarByteArrayOp WordVec 2 W64)
-   , (VecReadScalarByteArrayOp WordVec 32 W8)
-   , (VecReadScalarByteArrayOp WordVec 16 W16)
-   , (VecReadScalarByteArrayOp WordVec 8 W32)
-   , (VecReadScalarByteArrayOp WordVec 4 W64)
-   , (VecReadScalarByteArrayOp WordVec 64 W8)
-   , (VecReadScalarByteArrayOp WordVec 32 W16)
-   , (VecReadScalarByteArrayOp WordVec 16 W32)
-   , (VecReadScalarByteArrayOp WordVec 8 W64)
-   , (VecReadScalarByteArrayOp FloatVec 4 W32)
-   , (VecReadScalarByteArrayOp FloatVec 2 W64)
-   , (VecReadScalarByteArrayOp FloatVec 8 W32)
-   , (VecReadScalarByteArrayOp FloatVec 4 W64)
-   , (VecReadScalarByteArrayOp FloatVec 16 W32)
-   , (VecReadScalarByteArrayOp FloatVec 8 W64)
-   , (VecWriteScalarByteArrayOp IntVec 16 W8)
-   , (VecWriteScalarByteArrayOp IntVec 8 W16)
-   , (VecWriteScalarByteArrayOp IntVec 4 W32)
-   , (VecWriteScalarByteArrayOp IntVec 2 W64)
-   , (VecWriteScalarByteArrayOp IntVec 32 W8)
-   , (VecWriteScalarByteArrayOp IntVec 16 W16)
-   , (VecWriteScalarByteArrayOp IntVec 8 W32)
-   , (VecWriteScalarByteArrayOp IntVec 4 W64)
-   , (VecWriteScalarByteArrayOp IntVec 64 W8)
-   , (VecWriteScalarByteArrayOp IntVec 32 W16)
-   , (VecWriteScalarByteArrayOp IntVec 16 W32)
-   , (VecWriteScalarByteArrayOp IntVec 8 W64)
-   , (VecWriteScalarByteArrayOp WordVec 16 W8)
-   , (VecWriteScalarByteArrayOp WordVec 8 W16)
-   , (VecWriteScalarByteArrayOp WordVec 4 W32)
-   , (VecWriteScalarByteArrayOp WordVec 2 W64)
-   , (VecWriteScalarByteArrayOp WordVec 32 W8)
-   , (VecWriteScalarByteArrayOp WordVec 16 W16)
-   , (VecWriteScalarByteArrayOp WordVec 8 W32)
-   , (VecWriteScalarByteArrayOp WordVec 4 W64)
-   , (VecWriteScalarByteArrayOp WordVec 64 W8)
-   , (VecWriteScalarByteArrayOp WordVec 32 W16)
-   , (VecWriteScalarByteArrayOp WordVec 16 W32)
-   , (VecWriteScalarByteArrayOp WordVec 8 W64)
-   , (VecWriteScalarByteArrayOp FloatVec 4 W32)
-   , (VecWriteScalarByteArrayOp FloatVec 2 W64)
-   , (VecWriteScalarByteArrayOp FloatVec 8 W32)
-   , (VecWriteScalarByteArrayOp FloatVec 4 W64)
-   , (VecWriteScalarByteArrayOp FloatVec 16 W32)
-   , (VecWriteScalarByteArrayOp FloatVec 8 W64)
-   , (VecIndexScalarOffAddrOp IntVec 16 W8)
-   , (VecIndexScalarOffAddrOp IntVec 8 W16)
-   , (VecIndexScalarOffAddrOp IntVec 4 W32)
-   , (VecIndexScalarOffAddrOp IntVec 2 W64)
-   , (VecIndexScalarOffAddrOp IntVec 32 W8)
-   , (VecIndexScalarOffAddrOp IntVec 16 W16)
-   , (VecIndexScalarOffAddrOp IntVec 8 W32)
-   , (VecIndexScalarOffAddrOp IntVec 4 W64)
-   , (VecIndexScalarOffAddrOp IntVec 64 W8)
-   , (VecIndexScalarOffAddrOp IntVec 32 W16)
-   , (VecIndexScalarOffAddrOp IntVec 16 W32)
-   , (VecIndexScalarOffAddrOp IntVec 8 W64)
-   , (VecIndexScalarOffAddrOp WordVec 16 W8)
-   , (VecIndexScalarOffAddrOp WordVec 8 W16)
-   , (VecIndexScalarOffAddrOp WordVec 4 W32)
-   , (VecIndexScalarOffAddrOp WordVec 2 W64)
-   , (VecIndexScalarOffAddrOp WordVec 32 W8)
-   , (VecIndexScalarOffAddrOp WordVec 16 W16)
-   , (VecIndexScalarOffAddrOp WordVec 8 W32)
-   , (VecIndexScalarOffAddrOp WordVec 4 W64)
-   , (VecIndexScalarOffAddrOp WordVec 64 W8)
-   , (VecIndexScalarOffAddrOp WordVec 32 W16)
-   , (VecIndexScalarOffAddrOp WordVec 16 W32)
-   , (VecIndexScalarOffAddrOp WordVec 8 W64)
-   , (VecIndexScalarOffAddrOp FloatVec 4 W32)
-   , (VecIndexScalarOffAddrOp FloatVec 2 W64)
-   , (VecIndexScalarOffAddrOp FloatVec 8 W32)
-   , (VecIndexScalarOffAddrOp FloatVec 4 W64)
-   , (VecIndexScalarOffAddrOp FloatVec 16 W32)
-   , (VecIndexScalarOffAddrOp FloatVec 8 W64)
-   , (VecReadScalarOffAddrOp IntVec 16 W8)
-   , (VecReadScalarOffAddrOp IntVec 8 W16)
-   , (VecReadScalarOffAddrOp IntVec 4 W32)
-   , (VecReadScalarOffAddrOp IntVec 2 W64)
-   , (VecReadScalarOffAddrOp IntVec 32 W8)
-   , (VecReadScalarOffAddrOp IntVec 16 W16)
-   , (VecReadScalarOffAddrOp IntVec 8 W32)
-   , (VecReadScalarOffAddrOp IntVec 4 W64)
-   , (VecReadScalarOffAddrOp IntVec 64 W8)
-   , (VecReadScalarOffAddrOp IntVec 32 W16)
-   , (VecReadScalarOffAddrOp IntVec 16 W32)
-   , (VecReadScalarOffAddrOp IntVec 8 W64)
-   , (VecReadScalarOffAddrOp WordVec 16 W8)
-   , (VecReadScalarOffAddrOp WordVec 8 W16)
-   , (VecReadScalarOffAddrOp WordVec 4 W32)
-   , (VecReadScalarOffAddrOp WordVec 2 W64)
-   , (VecReadScalarOffAddrOp WordVec 32 W8)
-   , (VecReadScalarOffAddrOp WordVec 16 W16)
-   , (VecReadScalarOffAddrOp WordVec 8 W32)
-   , (VecReadScalarOffAddrOp WordVec 4 W64)
-   , (VecReadScalarOffAddrOp WordVec 64 W8)
-   , (VecReadScalarOffAddrOp WordVec 32 W16)
-   , (VecReadScalarOffAddrOp WordVec 16 W32)
-   , (VecReadScalarOffAddrOp WordVec 8 W64)
-   , (VecReadScalarOffAddrOp FloatVec 4 W32)
-   , (VecReadScalarOffAddrOp FloatVec 2 W64)
-   , (VecReadScalarOffAddrOp FloatVec 8 W32)
-   , (VecReadScalarOffAddrOp FloatVec 4 W64)
-   , (VecReadScalarOffAddrOp FloatVec 16 W32)
-   , (VecReadScalarOffAddrOp FloatVec 8 W64)
-   , (VecWriteScalarOffAddrOp IntVec 16 W8)
-   , (VecWriteScalarOffAddrOp IntVec 8 W16)
-   , (VecWriteScalarOffAddrOp IntVec 4 W32)
-   , (VecWriteScalarOffAddrOp IntVec 2 W64)
-   , (VecWriteScalarOffAddrOp IntVec 32 W8)
-   , (VecWriteScalarOffAddrOp IntVec 16 W16)
-   , (VecWriteScalarOffAddrOp IntVec 8 W32)
-   , (VecWriteScalarOffAddrOp IntVec 4 W64)
-   , (VecWriteScalarOffAddrOp IntVec 64 W8)
-   , (VecWriteScalarOffAddrOp IntVec 32 W16)
-   , (VecWriteScalarOffAddrOp IntVec 16 W32)
-   , (VecWriteScalarOffAddrOp IntVec 8 W64)
-   , (VecWriteScalarOffAddrOp WordVec 16 W8)
-   , (VecWriteScalarOffAddrOp WordVec 8 W16)
-   , (VecWriteScalarOffAddrOp WordVec 4 W32)
-   , (VecWriteScalarOffAddrOp WordVec 2 W64)
-   , (VecWriteScalarOffAddrOp WordVec 32 W8)
-   , (VecWriteScalarOffAddrOp WordVec 16 W16)
-   , (VecWriteScalarOffAddrOp WordVec 8 W32)
-   , (VecWriteScalarOffAddrOp WordVec 4 W64)
-   , (VecWriteScalarOffAddrOp WordVec 64 W8)
-   , (VecWriteScalarOffAddrOp WordVec 32 W16)
-   , (VecWriteScalarOffAddrOp WordVec 16 W32)
-   , (VecWriteScalarOffAddrOp WordVec 8 W64)
-   , (VecWriteScalarOffAddrOp FloatVec 4 W32)
-   , (VecWriteScalarOffAddrOp FloatVec 2 W64)
-   , (VecWriteScalarOffAddrOp FloatVec 8 W32)
-   , (VecWriteScalarOffAddrOp FloatVec 4 W64)
-   , (VecWriteScalarOffAddrOp FloatVec 16 W32)
-   , (VecWriteScalarOffAddrOp FloatVec 8 W64)
-   , PrefetchByteArrayOp3
-   , PrefetchMutableByteArrayOp3
-   , PrefetchAddrOp3
-   , PrefetchValueOp3
-   , PrefetchByteArrayOp2
-   , PrefetchMutableByteArrayOp2
-   , PrefetchAddrOp2
-   , PrefetchValueOp2
-   , PrefetchByteArrayOp1
-   , PrefetchMutableByteArrayOp1
-   , PrefetchAddrOp1
-   , PrefetchValueOp1
-   , PrefetchByteArrayOp0
-   , PrefetchMutableByteArrayOp0
-   , PrefetchAddrOp0
-   , PrefetchValueOp0
-   ]
diff --git a/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl b/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl
+++ /dev/null
@@ -1,112 +0,0 @@
-primOpOutOfLine DoubleDecode_2IntOp = True
-primOpOutOfLine DoubleDecode_Int64Op = True
-primOpOutOfLine FloatDecode_IntOp = True
-primOpOutOfLine NewArrayOp = True
-primOpOutOfLine UnsafeThawArrayOp = True
-primOpOutOfLine CopyArrayOp = True
-primOpOutOfLine CopyMutableArrayOp = True
-primOpOutOfLine CloneArrayOp = True
-primOpOutOfLine CloneMutableArrayOp = True
-primOpOutOfLine FreezeArrayOp = True
-primOpOutOfLine ThawArrayOp = True
-primOpOutOfLine CasArrayOp = True
-primOpOutOfLine NewSmallArrayOp = True
-primOpOutOfLine ShrinkSmallMutableArrayOp_Char = True
-primOpOutOfLine UnsafeThawSmallArrayOp = True
-primOpOutOfLine CopySmallArrayOp = True
-primOpOutOfLine CopySmallMutableArrayOp = True
-primOpOutOfLine CloneSmallArrayOp = True
-primOpOutOfLine CloneSmallMutableArrayOp = True
-primOpOutOfLine FreezeSmallArrayOp = True
-primOpOutOfLine ThawSmallArrayOp = True
-primOpOutOfLine CasSmallArrayOp = True
-primOpOutOfLine NewByteArrayOp_Char = True
-primOpOutOfLine NewPinnedByteArrayOp_Char = True
-primOpOutOfLine NewAlignedPinnedByteArrayOp_Char = True
-primOpOutOfLine MutableByteArrayIsPinnedOp = True
-primOpOutOfLine ByteArrayIsPinnedOp = True
-primOpOutOfLine ShrinkMutableByteArrayOp_Char = True
-primOpOutOfLine ResizeMutableByteArrayOp_Char = True
-primOpOutOfLine NewMutVarOp = True
-primOpOutOfLine AtomicModifyMutVar2Op = True
-primOpOutOfLine AtomicModifyMutVar_Op = True
-primOpOutOfLine CasMutVarOp = True
-primOpOutOfLine CatchOp = True
-primOpOutOfLine RaiseOp = True
-primOpOutOfLine RaiseUnderflowOp = True
-primOpOutOfLine RaiseOverflowOp = True
-primOpOutOfLine RaiseDivZeroOp = True
-primOpOutOfLine RaiseIOOp = True
-primOpOutOfLine MaskAsyncExceptionsOp = True
-primOpOutOfLine MaskUninterruptibleOp = True
-primOpOutOfLine UnmaskAsyncExceptionsOp = True
-primOpOutOfLine MaskStatus = True
-primOpOutOfLine NewPromptTagOp = True
-primOpOutOfLine PromptOp = True
-primOpOutOfLine Control0Op = True
-primOpOutOfLine AtomicallyOp = True
-primOpOutOfLine RetryOp = True
-primOpOutOfLine CatchRetryOp = True
-primOpOutOfLine CatchSTMOp = True
-primOpOutOfLine NewTVarOp = True
-primOpOutOfLine ReadTVarOp = True
-primOpOutOfLine ReadTVarIOOp = True
-primOpOutOfLine WriteTVarOp = True
-primOpOutOfLine NewMVarOp = True
-primOpOutOfLine TakeMVarOp = True
-primOpOutOfLine TryTakeMVarOp = True
-primOpOutOfLine PutMVarOp = True
-primOpOutOfLine TryPutMVarOp = True
-primOpOutOfLine ReadMVarOp = True
-primOpOutOfLine TryReadMVarOp = True
-primOpOutOfLine IsEmptyMVarOp = True
-primOpOutOfLine NewIOPortOp = True
-primOpOutOfLine ReadIOPortOp = True
-primOpOutOfLine WriteIOPortOp = True
-primOpOutOfLine DelayOp = True
-primOpOutOfLine WaitReadOp = True
-primOpOutOfLine WaitWriteOp = True
-primOpOutOfLine ForkOp = True
-primOpOutOfLine ForkOnOp = True
-primOpOutOfLine KillThreadOp = True
-primOpOutOfLine YieldOp = True
-primOpOutOfLine LabelThreadOp = True
-primOpOutOfLine IsCurrentThreadBoundOp = True
-primOpOutOfLine NoDuplicateOp = True
-primOpOutOfLine GetThreadLabelOp = True
-primOpOutOfLine ThreadStatusOp = True
-primOpOutOfLine ListThreadsOp = True
-primOpOutOfLine MkWeakOp = True
-primOpOutOfLine MkWeakNoFinalizerOp = True
-primOpOutOfLine AddCFinalizerToWeakOp = True
-primOpOutOfLine DeRefWeakOp = True
-primOpOutOfLine FinalizeWeakOp = True
-primOpOutOfLine MakeStablePtrOp = True
-primOpOutOfLine DeRefStablePtrOp = True
-primOpOutOfLine MakeStableNameOp = True
-primOpOutOfLine CompactNewOp = True
-primOpOutOfLine CompactResizeOp = True
-primOpOutOfLine CompactContainsOp = True
-primOpOutOfLine CompactContainsAnyOp = True
-primOpOutOfLine CompactGetFirstBlockOp = True
-primOpOutOfLine CompactGetNextBlockOp = True
-primOpOutOfLine CompactAllocateBlockOp = True
-primOpOutOfLine CompactFixupPointersOp = True
-primOpOutOfLine CompactAdd = True
-primOpOutOfLine CompactAddWithSharing = True
-primOpOutOfLine CompactSize = True
-primOpOutOfLine GetSparkOp = True
-primOpOutOfLine NumSparks = True
-primOpOutOfLine KeepAliveOp = True
-primOpOutOfLine MkApUpd0_Op = True
-primOpOutOfLine NewBCOOp = True
-primOpOutOfLine UnpackClosureOp = True
-primOpOutOfLine ClosureSizeOp = True
-primOpOutOfLine GetApStackValOp = True
-primOpOutOfLine ClearCCSOp = True
-primOpOutOfLine WhereFromOp = True
-primOpOutOfLine TraceEventOp = True
-primOpOutOfLine TraceEventBinaryOp = True
-primOpOutOfLine TraceMarkerOp = True
-primOpOutOfLine SetThreadAllocationCounter = True
-primOpOutOfLine _ = False
diff --git a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl b/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl
+++ /dev/null
@@ -1,1312 +0,0 @@
-primOpInfo CharGtOp = mkCompare (fsLit "gtChar#") charPrimTy
-primOpInfo CharGeOp = mkCompare (fsLit "geChar#") charPrimTy
-primOpInfo CharEqOp = mkCompare (fsLit "eqChar#") charPrimTy
-primOpInfo CharNeOp = mkCompare (fsLit "neChar#") charPrimTy
-primOpInfo CharLtOp = mkCompare (fsLit "ltChar#") charPrimTy
-primOpInfo CharLeOp = mkCompare (fsLit "leChar#") charPrimTy
-primOpInfo OrdOp = mkGenPrimOp (fsLit "ord#")  [] [charPrimTy] (intPrimTy)
-primOpInfo Int8ToIntOp = mkGenPrimOp (fsLit "int8ToInt#")  [] [int8PrimTy] (intPrimTy)
-primOpInfo IntToInt8Op = mkGenPrimOp (fsLit "intToInt8#")  [] [intPrimTy] (int8PrimTy)
-primOpInfo Int8NegOp = mkGenPrimOp (fsLit "negateInt8#")  [] [int8PrimTy] (int8PrimTy)
-primOpInfo Int8AddOp = mkGenPrimOp (fsLit "plusInt8#")  [] [int8PrimTy, int8PrimTy] (int8PrimTy)
-primOpInfo Int8SubOp = mkGenPrimOp (fsLit "subInt8#")  [] [int8PrimTy, int8PrimTy] (int8PrimTy)
-primOpInfo Int8MulOp = mkGenPrimOp (fsLit "timesInt8#")  [] [int8PrimTy, int8PrimTy] (int8PrimTy)
-primOpInfo Int8QuotOp = mkGenPrimOp (fsLit "quotInt8#")  [] [int8PrimTy, int8PrimTy] (int8PrimTy)
-primOpInfo Int8RemOp = mkGenPrimOp (fsLit "remInt8#")  [] [int8PrimTy, int8PrimTy] (int8PrimTy)
-primOpInfo Int8QuotRemOp = mkGenPrimOp (fsLit "quotRemInt8#")  [] [int8PrimTy, int8PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy]))
-primOpInfo Int8SllOp = mkGenPrimOp (fsLit "uncheckedShiftLInt8#")  [] [int8PrimTy, intPrimTy] (int8PrimTy)
-primOpInfo Int8SraOp = mkGenPrimOp (fsLit "uncheckedShiftRAInt8#")  [] [int8PrimTy, intPrimTy] (int8PrimTy)
-primOpInfo Int8SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRLInt8#")  [] [int8PrimTy, intPrimTy] (int8PrimTy)
-primOpInfo Int8ToWord8Op = mkGenPrimOp (fsLit "int8ToWord8#")  [] [int8PrimTy] (word8PrimTy)
-primOpInfo Int8EqOp = mkCompare (fsLit "eqInt8#") int8PrimTy
-primOpInfo Int8GeOp = mkCompare (fsLit "geInt8#") int8PrimTy
-primOpInfo Int8GtOp = mkCompare (fsLit "gtInt8#") int8PrimTy
-primOpInfo Int8LeOp = mkCompare (fsLit "leInt8#") int8PrimTy
-primOpInfo Int8LtOp = mkCompare (fsLit "ltInt8#") int8PrimTy
-primOpInfo Int8NeOp = mkCompare (fsLit "neInt8#") int8PrimTy
-primOpInfo Word8ToWordOp = mkGenPrimOp (fsLit "word8ToWord#")  [] [word8PrimTy] (wordPrimTy)
-primOpInfo WordToWord8Op = mkGenPrimOp (fsLit "wordToWord8#")  [] [wordPrimTy] (word8PrimTy)
-primOpInfo Word8AddOp = mkGenPrimOp (fsLit "plusWord8#")  [] [word8PrimTy, word8PrimTy] (word8PrimTy)
-primOpInfo Word8SubOp = mkGenPrimOp (fsLit "subWord8#")  [] [word8PrimTy, word8PrimTy] (word8PrimTy)
-primOpInfo Word8MulOp = mkGenPrimOp (fsLit "timesWord8#")  [] [word8PrimTy, word8PrimTy] (word8PrimTy)
-primOpInfo Word8QuotOp = mkGenPrimOp (fsLit "quotWord8#")  [] [word8PrimTy, word8PrimTy] (word8PrimTy)
-primOpInfo Word8RemOp = mkGenPrimOp (fsLit "remWord8#")  [] [word8PrimTy, word8PrimTy] (word8PrimTy)
-primOpInfo Word8QuotRemOp = mkGenPrimOp (fsLit "quotRemWord8#")  [] [word8PrimTy, word8PrimTy] ((mkTupleTy Unboxed [word8PrimTy, word8PrimTy]))
-primOpInfo Word8AndOp = mkGenPrimOp (fsLit "andWord8#")  [] [word8PrimTy, word8PrimTy] (word8PrimTy)
-primOpInfo Word8OrOp = mkGenPrimOp (fsLit "orWord8#")  [] [word8PrimTy, word8PrimTy] (word8PrimTy)
-primOpInfo Word8XorOp = mkGenPrimOp (fsLit "xorWord8#")  [] [word8PrimTy, word8PrimTy] (word8PrimTy)
-primOpInfo Word8NotOp = mkGenPrimOp (fsLit "notWord8#")  [] [word8PrimTy] (word8PrimTy)
-primOpInfo Word8SllOp = mkGenPrimOp (fsLit "uncheckedShiftLWord8#")  [] [word8PrimTy, intPrimTy] (word8PrimTy)
-primOpInfo Word8SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRLWord8#")  [] [word8PrimTy, intPrimTy] (word8PrimTy)
-primOpInfo Word8ToInt8Op = mkGenPrimOp (fsLit "word8ToInt8#")  [] [word8PrimTy] (int8PrimTy)
-primOpInfo Word8EqOp = mkCompare (fsLit "eqWord8#") word8PrimTy
-primOpInfo Word8GeOp = mkCompare (fsLit "geWord8#") word8PrimTy
-primOpInfo Word8GtOp = mkCompare (fsLit "gtWord8#") word8PrimTy
-primOpInfo Word8LeOp = mkCompare (fsLit "leWord8#") word8PrimTy
-primOpInfo Word8LtOp = mkCompare (fsLit "ltWord8#") word8PrimTy
-primOpInfo Word8NeOp = mkCompare (fsLit "neWord8#") word8PrimTy
-primOpInfo Int16ToIntOp = mkGenPrimOp (fsLit "int16ToInt#")  [] [int16PrimTy] (intPrimTy)
-primOpInfo IntToInt16Op = mkGenPrimOp (fsLit "intToInt16#")  [] [intPrimTy] (int16PrimTy)
-primOpInfo Int16NegOp = mkGenPrimOp (fsLit "negateInt16#")  [] [int16PrimTy] (int16PrimTy)
-primOpInfo Int16AddOp = mkGenPrimOp (fsLit "plusInt16#")  [] [int16PrimTy, int16PrimTy] (int16PrimTy)
-primOpInfo Int16SubOp = mkGenPrimOp (fsLit "subInt16#")  [] [int16PrimTy, int16PrimTy] (int16PrimTy)
-primOpInfo Int16MulOp = mkGenPrimOp (fsLit "timesInt16#")  [] [int16PrimTy, int16PrimTy] (int16PrimTy)
-primOpInfo Int16QuotOp = mkGenPrimOp (fsLit "quotInt16#")  [] [int16PrimTy, int16PrimTy] (int16PrimTy)
-primOpInfo Int16RemOp = mkGenPrimOp (fsLit "remInt16#")  [] [int16PrimTy, int16PrimTy] (int16PrimTy)
-primOpInfo Int16QuotRemOp = mkGenPrimOp (fsLit "quotRemInt16#")  [] [int16PrimTy, int16PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy]))
-primOpInfo Int16SllOp = mkGenPrimOp (fsLit "uncheckedShiftLInt16#")  [] [int16PrimTy, intPrimTy] (int16PrimTy)
-primOpInfo Int16SraOp = mkGenPrimOp (fsLit "uncheckedShiftRAInt16#")  [] [int16PrimTy, intPrimTy] (int16PrimTy)
-primOpInfo Int16SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRLInt16#")  [] [int16PrimTy, intPrimTy] (int16PrimTy)
-primOpInfo Int16ToWord16Op = mkGenPrimOp (fsLit "int16ToWord16#")  [] [int16PrimTy] (word16PrimTy)
-primOpInfo Int16EqOp = mkCompare (fsLit "eqInt16#") int16PrimTy
-primOpInfo Int16GeOp = mkCompare (fsLit "geInt16#") int16PrimTy
-primOpInfo Int16GtOp = mkCompare (fsLit "gtInt16#") int16PrimTy
-primOpInfo Int16LeOp = mkCompare (fsLit "leInt16#") int16PrimTy
-primOpInfo Int16LtOp = mkCompare (fsLit "ltInt16#") int16PrimTy
-primOpInfo Int16NeOp = mkCompare (fsLit "neInt16#") int16PrimTy
-primOpInfo Word16ToWordOp = mkGenPrimOp (fsLit "word16ToWord#")  [] [word16PrimTy] (wordPrimTy)
-primOpInfo WordToWord16Op = mkGenPrimOp (fsLit "wordToWord16#")  [] [wordPrimTy] (word16PrimTy)
-primOpInfo Word16AddOp = mkGenPrimOp (fsLit "plusWord16#")  [] [word16PrimTy, word16PrimTy] (word16PrimTy)
-primOpInfo Word16SubOp = mkGenPrimOp (fsLit "subWord16#")  [] [word16PrimTy, word16PrimTy] (word16PrimTy)
-primOpInfo Word16MulOp = mkGenPrimOp (fsLit "timesWord16#")  [] [word16PrimTy, word16PrimTy] (word16PrimTy)
-primOpInfo Word16QuotOp = mkGenPrimOp (fsLit "quotWord16#")  [] [word16PrimTy, word16PrimTy] (word16PrimTy)
-primOpInfo Word16RemOp = mkGenPrimOp (fsLit "remWord16#")  [] [word16PrimTy, word16PrimTy] (word16PrimTy)
-primOpInfo Word16QuotRemOp = mkGenPrimOp (fsLit "quotRemWord16#")  [] [word16PrimTy, word16PrimTy] ((mkTupleTy Unboxed [word16PrimTy, word16PrimTy]))
-primOpInfo Word16AndOp = mkGenPrimOp (fsLit "andWord16#")  [] [word16PrimTy, word16PrimTy] (word16PrimTy)
-primOpInfo Word16OrOp = mkGenPrimOp (fsLit "orWord16#")  [] [word16PrimTy, word16PrimTy] (word16PrimTy)
-primOpInfo Word16XorOp = mkGenPrimOp (fsLit "xorWord16#")  [] [word16PrimTy, word16PrimTy] (word16PrimTy)
-primOpInfo Word16NotOp = mkGenPrimOp (fsLit "notWord16#")  [] [word16PrimTy] (word16PrimTy)
-primOpInfo Word16SllOp = mkGenPrimOp (fsLit "uncheckedShiftLWord16#")  [] [word16PrimTy, intPrimTy] (word16PrimTy)
-primOpInfo Word16SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRLWord16#")  [] [word16PrimTy, intPrimTy] (word16PrimTy)
-primOpInfo Word16ToInt16Op = mkGenPrimOp (fsLit "word16ToInt16#")  [] [word16PrimTy] (int16PrimTy)
-primOpInfo Word16EqOp = mkCompare (fsLit "eqWord16#") word16PrimTy
-primOpInfo Word16GeOp = mkCompare (fsLit "geWord16#") word16PrimTy
-primOpInfo Word16GtOp = mkCompare (fsLit "gtWord16#") word16PrimTy
-primOpInfo Word16LeOp = mkCompare (fsLit "leWord16#") word16PrimTy
-primOpInfo Word16LtOp = mkCompare (fsLit "ltWord16#") word16PrimTy
-primOpInfo Word16NeOp = mkCompare (fsLit "neWord16#") word16PrimTy
-primOpInfo Int32ToIntOp = mkGenPrimOp (fsLit "int32ToInt#")  [] [int32PrimTy] (intPrimTy)
-primOpInfo IntToInt32Op = mkGenPrimOp (fsLit "intToInt32#")  [] [intPrimTy] (int32PrimTy)
-primOpInfo Int32NegOp = mkGenPrimOp (fsLit "negateInt32#")  [] [int32PrimTy] (int32PrimTy)
-primOpInfo Int32AddOp = mkGenPrimOp (fsLit "plusInt32#")  [] [int32PrimTy, int32PrimTy] (int32PrimTy)
-primOpInfo Int32SubOp = mkGenPrimOp (fsLit "subInt32#")  [] [int32PrimTy, int32PrimTy] (int32PrimTy)
-primOpInfo Int32MulOp = mkGenPrimOp (fsLit "timesInt32#")  [] [int32PrimTy, int32PrimTy] (int32PrimTy)
-primOpInfo Int32QuotOp = mkGenPrimOp (fsLit "quotInt32#")  [] [int32PrimTy, int32PrimTy] (int32PrimTy)
-primOpInfo Int32RemOp = mkGenPrimOp (fsLit "remInt32#")  [] [int32PrimTy, int32PrimTy] (int32PrimTy)
-primOpInfo Int32QuotRemOp = mkGenPrimOp (fsLit "quotRemInt32#")  [] [int32PrimTy, int32PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy]))
-primOpInfo Int32SllOp = mkGenPrimOp (fsLit "uncheckedShiftLInt32#")  [] [int32PrimTy, intPrimTy] (int32PrimTy)
-primOpInfo Int32SraOp = mkGenPrimOp (fsLit "uncheckedShiftRAInt32#")  [] [int32PrimTy, intPrimTy] (int32PrimTy)
-primOpInfo Int32SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRLInt32#")  [] [int32PrimTy, intPrimTy] (int32PrimTy)
-primOpInfo Int32ToWord32Op = mkGenPrimOp (fsLit "int32ToWord32#")  [] [int32PrimTy] (word32PrimTy)
-primOpInfo Int32EqOp = mkCompare (fsLit "eqInt32#") int32PrimTy
-primOpInfo Int32GeOp = mkCompare (fsLit "geInt32#") int32PrimTy
-primOpInfo Int32GtOp = mkCompare (fsLit "gtInt32#") int32PrimTy
-primOpInfo Int32LeOp = mkCompare (fsLit "leInt32#") int32PrimTy
-primOpInfo Int32LtOp = mkCompare (fsLit "ltInt32#") int32PrimTy
-primOpInfo Int32NeOp = mkCompare (fsLit "neInt32#") int32PrimTy
-primOpInfo Word32ToWordOp = mkGenPrimOp (fsLit "word32ToWord#")  [] [word32PrimTy] (wordPrimTy)
-primOpInfo WordToWord32Op = mkGenPrimOp (fsLit "wordToWord32#")  [] [wordPrimTy] (word32PrimTy)
-primOpInfo Word32AddOp = mkGenPrimOp (fsLit "plusWord32#")  [] [word32PrimTy, word32PrimTy] (word32PrimTy)
-primOpInfo Word32SubOp = mkGenPrimOp (fsLit "subWord32#")  [] [word32PrimTy, word32PrimTy] (word32PrimTy)
-primOpInfo Word32MulOp = mkGenPrimOp (fsLit "timesWord32#")  [] [word32PrimTy, word32PrimTy] (word32PrimTy)
-primOpInfo Word32QuotOp = mkGenPrimOp (fsLit "quotWord32#")  [] [word32PrimTy, word32PrimTy] (word32PrimTy)
-primOpInfo Word32RemOp = mkGenPrimOp (fsLit "remWord32#")  [] [word32PrimTy, word32PrimTy] (word32PrimTy)
-primOpInfo Word32QuotRemOp = mkGenPrimOp (fsLit "quotRemWord32#")  [] [word32PrimTy, word32PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy]))
-primOpInfo Word32AndOp = mkGenPrimOp (fsLit "andWord32#")  [] [word32PrimTy, word32PrimTy] (word32PrimTy)
-primOpInfo Word32OrOp = mkGenPrimOp (fsLit "orWord32#")  [] [word32PrimTy, word32PrimTy] (word32PrimTy)
-primOpInfo Word32XorOp = mkGenPrimOp (fsLit "xorWord32#")  [] [word32PrimTy, word32PrimTy] (word32PrimTy)
-primOpInfo Word32NotOp = mkGenPrimOp (fsLit "notWord32#")  [] [word32PrimTy] (word32PrimTy)
-primOpInfo Word32SllOp = mkGenPrimOp (fsLit "uncheckedShiftLWord32#")  [] [word32PrimTy, intPrimTy] (word32PrimTy)
-primOpInfo Word32SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRLWord32#")  [] [word32PrimTy, intPrimTy] (word32PrimTy)
-primOpInfo Word32ToInt32Op = mkGenPrimOp (fsLit "word32ToInt32#")  [] [word32PrimTy] (int32PrimTy)
-primOpInfo Word32EqOp = mkCompare (fsLit "eqWord32#") word32PrimTy
-primOpInfo Word32GeOp = mkCompare (fsLit "geWord32#") word32PrimTy
-primOpInfo Word32GtOp = mkCompare (fsLit "gtWord32#") word32PrimTy
-primOpInfo Word32LeOp = mkCompare (fsLit "leWord32#") word32PrimTy
-primOpInfo Word32LtOp = mkCompare (fsLit "ltWord32#") word32PrimTy
-primOpInfo Word32NeOp = mkCompare (fsLit "neWord32#") word32PrimTy
-primOpInfo Int64ToIntOp = mkGenPrimOp (fsLit "int64ToInt#")  [] [int64PrimTy] (intPrimTy)
-primOpInfo IntToInt64Op = mkGenPrimOp (fsLit "intToInt64#")  [] [intPrimTy] (int64PrimTy)
-primOpInfo Int64NegOp = mkGenPrimOp (fsLit "negateInt64#")  [] [int64PrimTy] (int64PrimTy)
-primOpInfo Int64AddOp = mkGenPrimOp (fsLit "plusInt64#")  [] [int64PrimTy, int64PrimTy] (int64PrimTy)
-primOpInfo Int64SubOp = mkGenPrimOp (fsLit "subInt64#")  [] [int64PrimTy, int64PrimTy] (int64PrimTy)
-primOpInfo Int64MulOp = mkGenPrimOp (fsLit "timesInt64#")  [] [int64PrimTy, int64PrimTy] (int64PrimTy)
-primOpInfo Int64QuotOp = mkGenPrimOp (fsLit "quotInt64#")  [] [int64PrimTy, int64PrimTy] (int64PrimTy)
-primOpInfo Int64RemOp = mkGenPrimOp (fsLit "remInt64#")  [] [int64PrimTy, int64PrimTy] (int64PrimTy)
-primOpInfo Int64SllOp = mkGenPrimOp (fsLit "uncheckedIShiftL64#")  [] [int64PrimTy, intPrimTy] (int64PrimTy)
-primOpInfo Int64SraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA64#")  [] [int64PrimTy, intPrimTy] (int64PrimTy)
-primOpInfo Int64SrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL64#")  [] [int64PrimTy, intPrimTy] (int64PrimTy)
-primOpInfo Int64ToWord64Op = mkGenPrimOp (fsLit "int64ToWord64#")  [] [int64PrimTy] (word64PrimTy)
-primOpInfo Int64EqOp = mkCompare (fsLit "eqInt64#") int64PrimTy
-primOpInfo Int64GeOp = mkCompare (fsLit "geInt64#") int64PrimTy
-primOpInfo Int64GtOp = mkCompare (fsLit "gtInt64#") int64PrimTy
-primOpInfo Int64LeOp = mkCompare (fsLit "leInt64#") int64PrimTy
-primOpInfo Int64LtOp = mkCompare (fsLit "ltInt64#") int64PrimTy
-primOpInfo Int64NeOp = mkCompare (fsLit "neInt64#") int64PrimTy
-primOpInfo Word64ToWordOp = mkGenPrimOp (fsLit "word64ToWord#")  [] [word64PrimTy] (wordPrimTy)
-primOpInfo WordToWord64Op = mkGenPrimOp (fsLit "wordToWord64#")  [] [wordPrimTy] (word64PrimTy)
-primOpInfo Word64AddOp = mkGenPrimOp (fsLit "plusWord64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)
-primOpInfo Word64SubOp = mkGenPrimOp (fsLit "subWord64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)
-primOpInfo Word64MulOp = mkGenPrimOp (fsLit "timesWord64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)
-primOpInfo Word64QuotOp = mkGenPrimOp (fsLit "quotWord64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)
-primOpInfo Word64RemOp = mkGenPrimOp (fsLit "remWord64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)
-primOpInfo Word64AndOp = mkGenPrimOp (fsLit "and64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)
-primOpInfo Word64OrOp = mkGenPrimOp (fsLit "or64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)
-primOpInfo Word64XorOp = mkGenPrimOp (fsLit "xor64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)
-primOpInfo Word64NotOp = mkGenPrimOp (fsLit "not64#")  [] [word64PrimTy] (word64PrimTy)
-primOpInfo Word64SllOp = mkGenPrimOp (fsLit "uncheckedShiftL64#")  [] [word64PrimTy, intPrimTy] (word64PrimTy)
-primOpInfo Word64SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL64#")  [] [word64PrimTy, intPrimTy] (word64PrimTy)
-primOpInfo Word64ToInt64Op = mkGenPrimOp (fsLit "word64ToInt64#")  [] [word64PrimTy] (int64PrimTy)
-primOpInfo Word64EqOp = mkCompare (fsLit "eqWord64#") word64PrimTy
-primOpInfo Word64GeOp = mkCompare (fsLit "geWord64#") word64PrimTy
-primOpInfo Word64GtOp = mkCompare (fsLit "gtWord64#") word64PrimTy
-primOpInfo Word64LeOp = mkCompare (fsLit "leWord64#") word64PrimTy
-primOpInfo Word64LtOp = mkCompare (fsLit "ltWord64#") word64PrimTy
-primOpInfo Word64NeOp = mkCompare (fsLit "neWord64#") word64PrimTy
-primOpInfo IntAddOp = mkGenPrimOp (fsLit "+#")  [] [intPrimTy, intPrimTy] (intPrimTy)
-primOpInfo IntSubOp = mkGenPrimOp (fsLit "-#")  [] [intPrimTy, intPrimTy] (intPrimTy)
-primOpInfo IntMulOp = mkGenPrimOp (fsLit "*#")  [] [intPrimTy, intPrimTy] (intPrimTy)
-primOpInfo IntMul2Op = mkGenPrimOp (fsLit "timesInt2#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy]))
-primOpInfo IntMulMayOfloOp = mkGenPrimOp (fsLit "mulIntMayOflo#")  [] [intPrimTy, intPrimTy] (intPrimTy)
-primOpInfo IntQuotOp = mkGenPrimOp (fsLit "quotInt#")  [] [intPrimTy, intPrimTy] (intPrimTy)
-primOpInfo IntRemOp = mkGenPrimOp (fsLit "remInt#")  [] [intPrimTy, intPrimTy] (intPrimTy)
-primOpInfo IntQuotRemOp = mkGenPrimOp (fsLit "quotRemInt#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
-primOpInfo IntAndOp = mkGenPrimOp (fsLit "andI#")  [] [intPrimTy, intPrimTy] (intPrimTy)
-primOpInfo IntOrOp = mkGenPrimOp (fsLit "orI#")  [] [intPrimTy, intPrimTy] (intPrimTy)
-primOpInfo IntXorOp = mkGenPrimOp (fsLit "xorI#")  [] [intPrimTy, intPrimTy] (intPrimTy)
-primOpInfo IntNotOp = mkGenPrimOp (fsLit "notI#")  [] [intPrimTy] (intPrimTy)
-primOpInfo IntNegOp = mkGenPrimOp (fsLit "negateInt#")  [] [intPrimTy] (intPrimTy)
-primOpInfo IntAddCOp = mkGenPrimOp (fsLit "addIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
-primOpInfo IntSubCOp = mkGenPrimOp (fsLit "subIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
-primOpInfo IntGtOp = mkCompare (fsLit ">#") intPrimTy
-primOpInfo IntGeOp = mkCompare (fsLit ">=#") intPrimTy
-primOpInfo IntEqOp = mkCompare (fsLit "==#") intPrimTy
-primOpInfo IntNeOp = mkCompare (fsLit "/=#") intPrimTy
-primOpInfo IntLtOp = mkCompare (fsLit "<#") intPrimTy
-primOpInfo IntLeOp = mkCompare (fsLit "<=#") intPrimTy
-primOpInfo ChrOp = mkGenPrimOp (fsLit "chr#")  [] [intPrimTy] (charPrimTy)
-primOpInfo IntToWordOp = mkGenPrimOp (fsLit "int2Word#")  [] [intPrimTy] (wordPrimTy)
-primOpInfo IntToFloatOp = mkGenPrimOp (fsLit "int2Float#")  [] [intPrimTy] (floatPrimTy)
-primOpInfo IntToDoubleOp = mkGenPrimOp (fsLit "int2Double#")  [] [intPrimTy] (doublePrimTy)
-primOpInfo WordToFloatOp = mkGenPrimOp (fsLit "word2Float#")  [] [wordPrimTy] (floatPrimTy)
-primOpInfo WordToDoubleOp = mkGenPrimOp (fsLit "word2Double#")  [] [wordPrimTy] (doublePrimTy)
-primOpInfo IntSllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#")  [] [intPrimTy, intPrimTy] (intPrimTy)
-primOpInfo IntSraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#")  [] [intPrimTy, intPrimTy] (intPrimTy)
-primOpInfo IntSrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#")  [] [intPrimTy, intPrimTy] (intPrimTy)
-primOpInfo WordAddOp = mkGenPrimOp (fsLit "plusWord#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo WordAddCOp = mkGenPrimOp (fsLit "addWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))
-primOpInfo WordSubCOp = mkGenPrimOp (fsLit "subWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))
-primOpInfo WordAdd2Op = mkGenPrimOp (fsLit "plusWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))
-primOpInfo WordSubOp = mkGenPrimOp (fsLit "minusWord#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo WordMulOp = mkGenPrimOp (fsLit "timesWord#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo WordMul2Op = mkGenPrimOp (fsLit "timesWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))
-primOpInfo WordQuotOp = mkGenPrimOp (fsLit "quotWord#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo WordRemOp = mkGenPrimOp (fsLit "remWord#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo WordQuotRemOp = mkGenPrimOp (fsLit "quotRemWord#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))
-primOpInfo WordQuotRem2Op = mkGenPrimOp (fsLit "quotRemWord2#")  [] [wordPrimTy, wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))
-primOpInfo WordAndOp = mkGenPrimOp (fsLit "and#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo WordOrOp = mkGenPrimOp (fsLit "or#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo WordXorOp = mkGenPrimOp (fsLit "xor#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo WordNotOp = mkGenPrimOp (fsLit "not#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo WordSllOp = mkGenPrimOp (fsLit "uncheckedShiftL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)
-primOpInfo WordSrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)
-primOpInfo WordToIntOp = mkGenPrimOp (fsLit "word2Int#")  [] [wordPrimTy] (intPrimTy)
-primOpInfo WordGtOp = mkCompare (fsLit "gtWord#") wordPrimTy
-primOpInfo WordGeOp = mkCompare (fsLit "geWord#") wordPrimTy
-primOpInfo WordEqOp = mkCompare (fsLit "eqWord#") wordPrimTy
-primOpInfo WordNeOp = mkCompare (fsLit "neWord#") wordPrimTy
-primOpInfo WordLtOp = mkCompare (fsLit "ltWord#") wordPrimTy
-primOpInfo WordLeOp = mkCompare (fsLit "leWord#") wordPrimTy
-primOpInfo PopCnt8Op = mkGenPrimOp (fsLit "popCnt8#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo PopCnt16Op = mkGenPrimOp (fsLit "popCnt16#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo PopCnt32Op = mkGenPrimOp (fsLit "popCnt32#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo PopCnt64Op = mkGenPrimOp (fsLit "popCnt64#")  [] [word64PrimTy] (wordPrimTy)
-primOpInfo PopCntOp = mkGenPrimOp (fsLit "popCnt#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo Pdep8Op = mkGenPrimOp (fsLit "pdep8#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo Pdep16Op = mkGenPrimOp (fsLit "pdep16#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo Pdep32Op = mkGenPrimOp (fsLit "pdep32#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo Pdep64Op = mkGenPrimOp (fsLit "pdep64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)
-primOpInfo PdepOp = mkGenPrimOp (fsLit "pdep#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo Pext8Op = mkGenPrimOp (fsLit "pext8#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo Pext16Op = mkGenPrimOp (fsLit "pext16#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo Pext32Op = mkGenPrimOp (fsLit "pext32#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo Pext64Op = mkGenPrimOp (fsLit "pext64#")  [] [word64PrimTy, word64PrimTy] (word64PrimTy)
-primOpInfo PextOp = mkGenPrimOp (fsLit "pext#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
-primOpInfo Clz8Op = mkGenPrimOp (fsLit "clz8#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo Clz16Op = mkGenPrimOp (fsLit "clz16#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo Clz32Op = mkGenPrimOp (fsLit "clz32#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo Clz64Op = mkGenPrimOp (fsLit "clz64#")  [] [word64PrimTy] (wordPrimTy)
-primOpInfo ClzOp = mkGenPrimOp (fsLit "clz#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo Ctz8Op = mkGenPrimOp (fsLit "ctz8#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo Ctz16Op = mkGenPrimOp (fsLit "ctz16#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo Ctz32Op = mkGenPrimOp (fsLit "ctz32#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo Ctz64Op = mkGenPrimOp (fsLit "ctz64#")  [] [word64PrimTy] (wordPrimTy)
-primOpInfo CtzOp = mkGenPrimOp (fsLit "ctz#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo BSwap16Op = mkGenPrimOp (fsLit "byteSwap16#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo BSwap32Op = mkGenPrimOp (fsLit "byteSwap32#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo BSwap64Op = mkGenPrimOp (fsLit "byteSwap64#")  [] [word64PrimTy] (word64PrimTy)
-primOpInfo BSwapOp = mkGenPrimOp (fsLit "byteSwap#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo BRev8Op = mkGenPrimOp (fsLit "bitReverse8#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo BRev16Op = mkGenPrimOp (fsLit "bitReverse16#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo BRev32Op = mkGenPrimOp (fsLit "bitReverse32#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo BRev64Op = mkGenPrimOp (fsLit "bitReverse64#")  [] [word64PrimTy] (word64PrimTy)
-primOpInfo BRevOp = mkGenPrimOp (fsLit "bitReverse#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo Narrow8IntOp = mkGenPrimOp (fsLit "narrow8Int#")  [] [intPrimTy] (intPrimTy)
-primOpInfo Narrow16IntOp = mkGenPrimOp (fsLit "narrow16Int#")  [] [intPrimTy] (intPrimTy)
-primOpInfo Narrow32IntOp = mkGenPrimOp (fsLit "narrow32Int#")  [] [intPrimTy] (intPrimTy)
-primOpInfo Narrow8WordOp = mkGenPrimOp (fsLit "narrow8Word#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo Narrow16WordOp = mkGenPrimOp (fsLit "narrow16Word#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo Narrow32WordOp = mkGenPrimOp (fsLit "narrow32Word#")  [] [wordPrimTy] (wordPrimTy)
-primOpInfo DoubleGtOp = mkCompare (fsLit ">##") doublePrimTy
-primOpInfo DoubleGeOp = mkCompare (fsLit ">=##") doublePrimTy
-primOpInfo DoubleEqOp = mkCompare (fsLit "==##") doublePrimTy
-primOpInfo DoubleNeOp = mkCompare (fsLit "/=##") doublePrimTy
-primOpInfo DoubleLtOp = mkCompare (fsLit "<##") doublePrimTy
-primOpInfo DoubleLeOp = mkCompare (fsLit "<=##") doublePrimTy
-primOpInfo DoubleAddOp = mkGenPrimOp (fsLit "+##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)
-primOpInfo DoubleSubOp = mkGenPrimOp (fsLit "-##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)
-primOpInfo DoubleMulOp = mkGenPrimOp (fsLit "*##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)
-primOpInfo DoubleDivOp = mkGenPrimOp (fsLit "/##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)
-primOpInfo DoubleNegOp = mkGenPrimOp (fsLit "negateDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleFabsOp = mkGenPrimOp (fsLit "fabsDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleToIntOp = mkGenPrimOp (fsLit "double2Int#")  [] [doublePrimTy] (intPrimTy)
-primOpInfo DoubleToFloatOp = mkGenPrimOp (fsLit "double2Float#")  [] [doublePrimTy] (floatPrimTy)
-primOpInfo DoubleExpOp = mkGenPrimOp (fsLit "expDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleExpM1Op = mkGenPrimOp (fsLit "expm1Double#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleLogOp = mkGenPrimOp (fsLit "logDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleLog1POp = mkGenPrimOp (fsLit "log1pDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleSqrtOp = mkGenPrimOp (fsLit "sqrtDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleSinOp = mkGenPrimOp (fsLit "sinDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleCosOp = mkGenPrimOp (fsLit "cosDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleTanOp = mkGenPrimOp (fsLit "tanDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleAsinOp = mkGenPrimOp (fsLit "asinDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleAcosOp = mkGenPrimOp (fsLit "acosDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleAtanOp = mkGenPrimOp (fsLit "atanDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleSinhOp = mkGenPrimOp (fsLit "sinhDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleCoshOp = mkGenPrimOp (fsLit "coshDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleTanhOp = mkGenPrimOp (fsLit "tanhDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleAsinhOp = mkGenPrimOp (fsLit "asinhDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleAcoshOp = mkGenPrimOp (fsLit "acoshDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoubleAtanhOp = mkGenPrimOp (fsLit "atanhDouble#")  [] [doublePrimTy] (doublePrimTy)
-primOpInfo DoublePowerOp = mkGenPrimOp (fsLit "**##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy)
-primOpInfo DoubleDecode_2IntOp = mkGenPrimOp (fsLit "decodeDouble_2Int#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, wordPrimTy, wordPrimTy, intPrimTy]))
-primOpInfo DoubleDecode_Int64Op = mkGenPrimOp (fsLit "decodeDouble_Int64#")  [] [doublePrimTy] ((mkTupleTy Unboxed [int64PrimTy, intPrimTy]))
-primOpInfo FloatGtOp = mkCompare (fsLit "gtFloat#") floatPrimTy
-primOpInfo FloatGeOp = mkCompare (fsLit "geFloat#") floatPrimTy
-primOpInfo FloatEqOp = mkCompare (fsLit "eqFloat#") floatPrimTy
-primOpInfo FloatNeOp = mkCompare (fsLit "neFloat#") floatPrimTy
-primOpInfo FloatLtOp = mkCompare (fsLit "ltFloat#") floatPrimTy
-primOpInfo FloatLeOp = mkCompare (fsLit "leFloat#") floatPrimTy
-primOpInfo FloatAddOp = mkGenPrimOp (fsLit "plusFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)
-primOpInfo FloatSubOp = mkGenPrimOp (fsLit "minusFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)
-primOpInfo FloatMulOp = mkGenPrimOp (fsLit "timesFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)
-primOpInfo FloatDivOp = mkGenPrimOp (fsLit "divideFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)
-primOpInfo FloatNegOp = mkGenPrimOp (fsLit "negateFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatFabsOp = mkGenPrimOp (fsLit "fabsFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatToIntOp = mkGenPrimOp (fsLit "float2Int#")  [] [floatPrimTy] (intPrimTy)
-primOpInfo FloatExpOp = mkGenPrimOp (fsLit "expFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatExpM1Op = mkGenPrimOp (fsLit "expm1Float#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatLogOp = mkGenPrimOp (fsLit "logFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatLog1POp = mkGenPrimOp (fsLit "log1pFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatSqrtOp = mkGenPrimOp (fsLit "sqrtFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatSinOp = mkGenPrimOp (fsLit "sinFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatCosOp = mkGenPrimOp (fsLit "cosFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatTanOp = mkGenPrimOp (fsLit "tanFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatAsinOp = mkGenPrimOp (fsLit "asinFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatAcosOp = mkGenPrimOp (fsLit "acosFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatAtanOp = mkGenPrimOp (fsLit "atanFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatSinhOp = mkGenPrimOp (fsLit "sinhFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatCoshOp = mkGenPrimOp (fsLit "coshFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatTanhOp = mkGenPrimOp (fsLit "tanhFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatAsinhOp = mkGenPrimOp (fsLit "asinhFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatAcoshOp = mkGenPrimOp (fsLit "acoshFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatAtanhOp = mkGenPrimOp (fsLit "atanhFloat#")  [] [floatPrimTy] (floatPrimTy)
-primOpInfo FloatPowerOp = mkGenPrimOp (fsLit "powerFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy)
-primOpInfo FloatToDoubleOp = mkGenPrimOp (fsLit "float2Double#")  [] [floatPrimTy] (doublePrimTy)
-primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#")  [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
-primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy]))
-primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))
-primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy] (intPrimTy)
-primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy] (intPrimTy)
-primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy, intPrimTy] ((mkTupleTy Unboxed [levPolyAlphaTy]))
-primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy levPolyAlphaTy]))
-primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy]))
-primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy levPolyAlphaTy)
-primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy]))
-primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy levPolyAlphaTy]))
-primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkArrayPrimTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy levPolyAlphaTy]))
-primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy]))
-primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy]))
-primOpInfo ShrinkSmallMutableArrayOp_Char = mkGenPrimOp (fsLit "shrinkSmallMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))
-primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy] (intPrimTy)
-primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy] (intPrimTy)
-primOpInfo GetSizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "getSizeofSmallMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy, intPrimTy] ((mkTupleTy Unboxed [levPolyAlphaTy]))
-primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy levPolyAlphaTy]))
-primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy]))
-primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy levPolyAlphaTy)
-primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy]))
-primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy levPolyAlphaTy]))
-primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [mkSmallArrayPrimTy levPolyAlphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy]))
-primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkSmallMutableArrayPrimTy deltaTy levPolyAlphaTy, intPrimTy, levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy]))
-primOpInfo NewByteArrayOp_Char = mkGenPrimOp (fsLit "newByteArray#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))
-primOpInfo NewPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newPinnedByteArray#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))
-primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#")  [deltaTyVarSpec] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))
-primOpInfo MutableByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isMutableByteArrayPinned#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)
-primOpInfo ByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isByteArrayPinned#")  [] [byteArrayPrimTy] (intPrimTy)
-primOpInfo ByteArrayContents_Char = mkGenPrimOp (fsLit "byteArrayContents#")  [] [byteArrayPrimTy] (addrPrimTy)
-primOpInfo MutableByteArrayContents_Char = mkGenPrimOp (fsLit "mutableByteArrayContents#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy] (addrPrimTy)
-primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo ResizeMutableByteArrayOp_Char = mkGenPrimOp (fsLit "resizeMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))
-primOpInfo UnsafeFreezeByteArrayOp = mkGenPrimOp (fsLit "unsafeFreezeByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))
-primOpInfo SizeofByteArrayOp = mkGenPrimOp (fsLit "sizeofByteArray#")  [] [byteArrayPrimTy] (intPrimTy)
-primOpInfo SizeofMutableByteArrayOp = mkGenPrimOp (fsLit "sizeofMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)
-primOpInfo GetSizeofMutableByteArrayOp = mkGenPrimOp (fsLit "getSizeofMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo IndexByteArrayOp_Char = mkGenPrimOp (fsLit "indexCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)
-primOpInfo IndexByteArrayOp_WideChar = mkGenPrimOp (fsLit "indexWideCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)
-primOpInfo IndexByteArrayOp_Int = mkGenPrimOp (fsLit "indexIntArray#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
-primOpInfo IndexByteArrayOp_Word = mkGenPrimOp (fsLit "indexWordArray#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
-primOpInfo IndexByteArrayOp_Addr = mkGenPrimOp (fsLit "indexAddrArray#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)
-primOpInfo IndexByteArrayOp_Float = mkGenPrimOp (fsLit "indexFloatArray#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)
-primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)
-primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#")  [alphaTyVarSpec] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)
-primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#")  [] [byteArrayPrimTy, intPrimTy] (int8PrimTy)
-primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#")  [] [byteArrayPrimTy, intPrimTy] (int16PrimTy)
-primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#")  [] [byteArrayPrimTy, intPrimTy] (int32PrimTy)
-primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#")  [] [byteArrayPrimTy, intPrimTy] (int64PrimTy)
-primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#")  [] [byteArrayPrimTy, intPrimTy] (word8PrimTy)
-primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#")  [] [byteArrayPrimTy, intPrimTy] (word16PrimTy)
-primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#")  [] [byteArrayPrimTy, intPrimTy] (word32PrimTy)
-primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#")  [] [byteArrayPrimTy, intPrimTy] (word64PrimTy)
-primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)
-primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)
-primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
-primOpInfo IndexByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8ArrayAsWord#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
-primOpInfo IndexByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "indexWord8ArrayAsAddr#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)
-primOpInfo IndexByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "indexWord8ArrayAsFloat#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)
-primOpInfo IndexByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8ArrayAsDouble#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)
-primOpInfo IndexByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "indexWord8ArrayAsStablePtr#")  [alphaTyVarSpec] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)
-primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#")  [] [byteArrayPrimTy, intPrimTy] (int16PrimTy)
-primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#")  [] [byteArrayPrimTy, intPrimTy] (int32PrimTy)
-primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#")  [] [byteArrayPrimTy, intPrimTy] (int64PrimTy)
-primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#")  [] [byteArrayPrimTy, intPrimTy] (word16PrimTy)
-primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#")  [] [byteArrayPrimTy, intPrimTy] (word32PrimTy)
-primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#")  [] [byteArrayPrimTy, intPrimTy] (word64PrimTy)
-primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
-primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
-primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo ReadByteArrayOp_Word = mkGenPrimOp (fsLit "readWordArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
-primOpInfo ReadByteArrayOp_Addr = mkGenPrimOp (fsLit "readAddrArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
-primOpInfo ReadByteArrayOp_Float = mkGenPrimOp (fsLit "readFloatArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))
-primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))
-primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#")  [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))
-primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy]))
-primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy]))
-primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))
-primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy]))
-primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy]))
-primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy]))
-primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))
-primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy]))
-primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
-primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
-primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo ReadByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8ArrayAsWord#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
-primOpInfo ReadByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "readWord8ArrayAsAddr#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
-primOpInfo ReadByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "readWord8ArrayAsFloat#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))
-primOpInfo ReadByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8ArrayAsDouble#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))
-primOpInfo ReadByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "readWord8ArrayAsStablePtr#")  [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))
-primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy]))
-primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))
-primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy]))
-primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy]))
-primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))
-primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy]))
-primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word = mkGenPrimOp (fsLit "writeWordArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Addr = mkGenPrimOp (fsLit "writeAddrArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Float = mkGenPrimOp (fsLit "writeFloatArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#")  [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8ArrayAsWord#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "writeWord8ArrayAsAddr#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "writeWord8ArrayAsFloat#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8ArrayAsDouble#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "writeWord8ArrayAsStablePtr#")  [deltaTyVarSpec, alphaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#")  [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy)
-primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#")  [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#")  [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#")  [deltaTyVarSpec] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo CasByteArrayOp_Int8 = mkGenPrimOp (fsLit "casInt8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8PrimTy, int8PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy]))
-primOpInfo CasByteArrayOp_Int16 = mkGenPrimOp (fsLit "casInt16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16PrimTy, int16PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy]))
-primOpInfo CasByteArrayOp_Int32 = mkGenPrimOp (fsLit "casInt32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32PrimTy, int32PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))
-primOpInfo CasByteArrayOp_Int64 = mkGenPrimOp (fsLit "casInt64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64PrimTy, int64PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy]))
-primOpInfo FetchAddByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAddIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo FetchSubByteArrayOp_Int = mkGenPrimOp (fsLit "fetchSubIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo FetchAndByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAndIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo FetchNandByteArrayOp_Int = mkGenPrimOp (fsLit "fetchNandIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo FetchOrByteArrayOp_Int = mkGenPrimOp (fsLit "fetchOrIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo FetchXorByteArrayOp_Int = mkGenPrimOp (fsLit "fetchXorIntArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)
-primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#")  [] [addrPrimTy, addrPrimTy] (intPrimTy)
-primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)
-primOpInfo AddrToIntOp = mkGenPrimOp (fsLit "addr2Int#")  [] [addrPrimTy] (intPrimTy)
-primOpInfo IntToAddrOp = mkGenPrimOp (fsLit "int2Addr#")  [] [intPrimTy] (addrPrimTy)
-primOpInfo AddrGtOp = mkCompare (fsLit "gtAddr#") addrPrimTy
-primOpInfo AddrGeOp = mkCompare (fsLit "geAddr#") addrPrimTy
-primOpInfo AddrEqOp = mkCompare (fsLit "eqAddr#") addrPrimTy
-primOpInfo AddrNeOp = mkCompare (fsLit "neAddr#") addrPrimTy
-primOpInfo AddrLtOp = mkCompare (fsLit "ltAddr#") addrPrimTy
-primOpInfo AddrLeOp = mkCompare (fsLit "leAddr#") addrPrimTy
-primOpInfo IndexOffAddrOp_Char = mkGenPrimOp (fsLit "indexCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)
-primOpInfo IndexOffAddrOp_WideChar = mkGenPrimOp (fsLit "indexWideCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)
-primOpInfo IndexOffAddrOp_Int = mkGenPrimOp (fsLit "indexIntOffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)
-primOpInfo IndexOffAddrOp_Word = mkGenPrimOp (fsLit "indexWordOffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)
-primOpInfo IndexOffAddrOp_Addr = mkGenPrimOp (fsLit "indexAddrOffAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)
-primOpInfo IndexOffAddrOp_Float = mkGenPrimOp (fsLit "indexFloatOffAddr#")  [] [addrPrimTy, intPrimTy] (floatPrimTy)
-primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#")  [] [addrPrimTy, intPrimTy] (doublePrimTy)
-primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#")  [alphaTyVarSpec] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)
-primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#")  [] [addrPrimTy, intPrimTy] (int8PrimTy)
-primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#")  [] [addrPrimTy, intPrimTy] (int16PrimTy)
-primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#")  [] [addrPrimTy, intPrimTy] (int32PrimTy)
-primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#")  [] [addrPrimTy, intPrimTy] (int64PrimTy)
-primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#")  [] [addrPrimTy, intPrimTy] (word8PrimTy)
-primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#")  [] [addrPrimTy, intPrimTy] (word16PrimTy)
-primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#")  [] [addrPrimTy, intPrimTy] (word32PrimTy)
-primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#")  [] [addrPrimTy, intPrimTy] (word64PrimTy)
-primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
-primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
-primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo ReadOffAddrOp_Word = mkGenPrimOp (fsLit "readWordOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
-primOpInfo ReadOffAddrOp_Addr = mkGenPrimOp (fsLit "readAddrOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
-primOpInfo ReadOffAddrOp_Float = mkGenPrimOp (fsLit "readFloatOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))
-primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))
-primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#")  [deltaTyVarSpec, alphaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))
-primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8PrimTy]))
-primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy]))
-primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))
-primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy]))
-primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy]))
-primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy]))
-primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))
-primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy]))
-primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteOffAddrOp_Word = mkGenPrimOp (fsLit "writeWordOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteOffAddrOp_Addr = mkGenPrimOp (fsLit "writeAddrOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteOffAddrOp_Float = mkGenPrimOp (fsLit "writeFloatOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#")  [alphaTyVarSpec, deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo InterlockedExchange_Addr = mkGenPrimOp (fsLit "atomicExchangeAddrAddr#")  [deltaTyVarSpec] [addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
-primOpInfo InterlockedExchange_Word = mkGenPrimOp (fsLit "atomicExchangeWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
-primOpInfo CasAddrOp_Addr = mkGenPrimOp (fsLit "atomicCasAddrAddr#")  [deltaTyVarSpec] [addrPrimTy, addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
-primOpInfo CasAddrOp_Word = mkGenPrimOp (fsLit "atomicCasWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
-primOpInfo CasAddrOp_Word8 = mkGenPrimOp (fsLit "atomicCasWord8Addr#")  [deltaTyVarSpec] [addrPrimTy, word8PrimTy, word8PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8PrimTy]))
-primOpInfo CasAddrOp_Word16 = mkGenPrimOp (fsLit "atomicCasWord16Addr#")  [deltaTyVarSpec] [addrPrimTy, word16PrimTy, word16PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy]))
-primOpInfo CasAddrOp_Word32 = mkGenPrimOp (fsLit "atomicCasWord32Addr#")  [deltaTyVarSpec] [addrPrimTy, word32PrimTy, word32PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))
-primOpInfo CasAddrOp_Word64 = mkGenPrimOp (fsLit "atomicCasWord64Addr#")  [deltaTyVarSpec] [addrPrimTy, word64PrimTy, word64PrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy]))
-primOpInfo FetchAddAddrOp_Word = mkGenPrimOp (fsLit "fetchAddWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
-primOpInfo FetchSubAddrOp_Word = mkGenPrimOp (fsLit "fetchSubWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
-primOpInfo FetchAndAddrOp_Word = mkGenPrimOp (fsLit "fetchAndWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
-primOpInfo FetchNandAddrOp_Word = mkGenPrimOp (fsLit "fetchNandWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
-primOpInfo FetchOrAddrOp_Word = mkGenPrimOp (fsLit "fetchOrWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
-primOpInfo FetchXorAddrOp_Word = mkGenPrimOp (fsLit "fetchXorWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
-primOpInfo AtomicReadAddrOp_Word = mkGenPrimOp (fsLit "atomicReadWordAddr#")  [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
-primOpInfo AtomicWriteAddrOp_Word = mkGenPrimOp (fsLit "atomicWriteWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy levPolyAlphaTy]))
-primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))
-primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#")  [deltaTyVarSpec, alphaTyVarSpec, gammaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy]))
-primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#")  [deltaTyVarSpec, alphaTyVarSpec] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTyMany (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy]))
-primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMutVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy]))
-primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#")  [runtimeRep1TyVarInf, levity2TyVarInf, openAlphaTyVarSpec, levPolyBetaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), (mkVisFunTyMany (levPolyBetaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))
-primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#")  [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy] (openBetaTy)
-primOpInfo RaiseUnderflowOp = mkGenPrimOp (fsLit "raiseUnderflow#")  [runtimeRep2TyVarInf, openBetaTyVarSpec] [(mkTupleTy Unboxed [])] (openBetaTy)
-primOpInfo RaiseOverflowOp = mkGenPrimOp (fsLit "raiseOverflow#")  [runtimeRep2TyVarInf, openBetaTyVarSpec] [(mkTupleTy Unboxed [])] (openBetaTy)
-primOpInfo RaiseDivZeroOp = mkGenPrimOp (fsLit "raiseDivZero#")  [runtimeRep2TyVarInf, openBetaTyVarSpec] [(mkTupleTy Unboxed [])] (openBetaTy)
-primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#")  [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openBetaTy]))
-primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#")  [runtimeRep1TyVarInf, openAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))
-primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#")  [runtimeRep1TyVarInf, openAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))
-primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#")  [runtimeRep1TyVarInf, openAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))
-primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
-primOpInfo NewPromptTagOp = mkGenPrimOp (fsLit "newPromptTag#")  [alphaTyVarSpec] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkPromptTagPrimTy alphaTy]))
-primOpInfo PromptOp = mkGenPrimOp (fsLit "prompt#")  [alphaTyVarSpec] [mkPromptTagPrimTy alphaTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
-primOpInfo Control0Op = mkGenPrimOp (fsLit "control0#")  [runtimeRep2TyVarInf, alphaTyVarSpec, openBetaTyVarSpec] [mkPromptTagPrimTy alphaTy, (mkVisFunTyMany ((mkVisFunTyMany ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openBetaTy])))) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy])))))) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openBetaTy]))
-primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))
-primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))
-primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))), (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))
-primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, betaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))), (mkVisFunTyMany (betaTy) ((mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))
-primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy levPolyAlphaTy]))
-primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkTVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))
-primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkTVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))
-primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkTVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy levPolyAlphaTy]))
-primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))
-primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy]))
-primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))
-primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, levPolyAlphaTy]))
-primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkMVarPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo NewIOPortOp = mkGenPrimOp (fsLit "newIOPort#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkIOPortPrimTy deltaTy levPolyAlphaTy]))
-primOpInfo ReadIOPortOp = mkGenPrimOp (fsLit "readIOPort#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkIOPortPrimTy deltaTy levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, levPolyAlphaTy]))
-primOpInfo WriteIOPortOp = mkGenPrimOp (fsLit "writeIOPort#")  [levity1TyVarInf, deltaTyVarSpec, levPolyAlphaTyVarSpec] [mkIOPortPrimTy deltaTy levPolyAlphaTy, levPolyAlphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#")  [deltaTyVarSpec] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#")  [runtimeRep1TyVarInf, openAlphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))
-primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#")  [runtimeRep1TyVarInf, openAlphaTyVarSpec] [intPrimTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, openAlphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))
-primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#")  [alphaTyVarSpec] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
-primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#")  [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
-primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))
-primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#")  [] [threadIdPrimTy, byteArrayPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
-primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
-primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#")  [deltaTyVarSpec] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo GetThreadLabelOp = mkGenPrimOp (fsLit "threadLabel#")  [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, byteArrayPrimTy]))
-primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#")  [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy]))
-primOpInfo ListThreadsOp = mkGenPrimOp (fsLit "listThreads#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkArrayPrimTy threadIdPrimTy]))
-primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#")  [levity1TyVarInf, levity2TyVarInf, levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec, gammaTyVarSpec] [levPolyAlphaTy, levPolyBetaTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy levPolyBetaTy]))
-primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#")  [levity1TyVarInf, levity2TyVarInf, levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec] [levPolyAlphaTy, levPolyBetaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy levPolyBetaTy]))
-primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#")  [levity2TyVarInf, levPolyBetaTyVarSpec] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy levPolyBetaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
-primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkWeakPrimTy levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, levPolyAlphaTy]))
-primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#")  [levity1TyVarInf, levPolyAlphaTyVarSpec, betaTyVarSpec] [mkWeakPrimTy levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))]))
-primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
-primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy levPolyAlphaTy]))
-primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStablePtrPrimTy levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, levPolyAlphaTy]))
-primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStablePtrPrimTy levPolyAlphaTy, mkStablePtrPrimTy levPolyAlphaTy] (intPrimTy)
-primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStableNamePrimTy levPolyAlphaTy]))
-primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [mkStableNamePrimTy levPolyAlphaTy] (intPrimTy)
-primOpInfo CompactNewOp = mkGenPrimOp (fsLit "compactNew#")  [] [wordPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy]))
-primOpInfo CompactResizeOp = mkGenPrimOp (fsLit "compactResize#")  [] [compactPrimTy, wordPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
-primOpInfo CompactContainsOp = mkGenPrimOp (fsLit "compactContains#")  [alphaTyVarSpec] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
-primOpInfo CompactContainsAnyOp = mkGenPrimOp (fsLit "compactContainsAny#")  [alphaTyVarSpec] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
-primOpInfo CompactGetFirstBlockOp = mkGenPrimOp (fsLit "compactGetFirstBlock#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))
-primOpInfo CompactGetNextBlockOp = mkGenPrimOp (fsLit "compactGetNextBlock#")  [] [compactPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))
-primOpInfo CompactAllocateBlockOp = mkGenPrimOp (fsLit "compactAllocateBlock#")  [] [wordPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))
-primOpInfo CompactFixupPointersOp = mkGenPrimOp (fsLit "compactFixupPointers#")  [] [addrPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy, addrPrimTy]))
-primOpInfo CompactAdd = mkGenPrimOp (fsLit "compactAdd#")  [alphaTyVarSpec] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
-primOpInfo CompactAddWithSharing = mkGenPrimOp (fsLit "compactAddWithSharing#")  [alphaTyVarSpec] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
-primOpInfo CompactSize = mkGenPrimOp (fsLit "compactSize#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, wordPrimTy]))
-primOpInfo ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#")  [levity1TyVarInf, levity2TyVarInf, levPolyAlphaTyVarSpec, levPolyBetaTyVarSpec] [levPolyAlphaTy, levPolyBetaTy] (intPrimTy)
-primOpInfo ParOp = mkGenPrimOp (fsLit "par#")  [alphaTyVarSpec] [alphaTy] (intPrimTy)
-primOpInfo SparkOp = mkGenPrimOp (fsLit "spark#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
-primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
-primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#")  [deltaTyVarSpec, alphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))
-primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#")  [deltaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
-primOpInfo KeepAliveOp = mkGenPrimOp (fsLit "keepAlive#")  [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy realWorldTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) (openBetaTy))] (openBetaTy)
-primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#")  [alphaTyVarSpec] [alphaTy] (intPrimTy)
-primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#")  [alphaTyVarSpec] [intPrimTy] (alphaTy)
-primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [addrPrimTy] ((mkTupleTy Unboxed [levPolyAlphaTy]))
-primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#")  [alphaTyVarSpec] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))
-primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#")  [alphaTyVarSpec] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy]))
-primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#")  [alphaTyVarSpec, deltaTyVarSpec] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy]))
-primOpInfo UnpackClosureOp = mkGenPrimOp (fsLit "unpackClosure#")  [alphaTyVarSpec, betaTyVarSpec] [alphaTy] ((mkTupleTy Unboxed [addrPrimTy, byteArrayPrimTy, mkArrayPrimTy betaTy]))
-primOpInfo ClosureSizeOp = mkGenPrimOp (fsLit "closureSize#")  [alphaTyVarSpec] [alphaTy] (intPrimTy)
-primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#")  [alphaTyVarSpec, betaTyVarSpec] [alphaTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, betaTy]))
-primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
-primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
-primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#")  [deltaTyVarSpec, alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
-primOpInfo WhereFromOp = mkGenPrimOp (fsLit "whereFrom#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
-primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#")  [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#")  [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#")  [] [int64PrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
-primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#")  [] [int8PrimTy] (int8X16PrimTy)
-primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#")  [] [int16PrimTy] (int16X8PrimTy)
-primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#")  [] [int32PrimTy] (int32X4PrimTy)
-primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#")  [] [int64PrimTy] (int64X2PrimTy)
-primOpInfo (VecBroadcastOp IntVec 32 W8) = mkGenPrimOp (fsLit "broadcastInt8X32#")  [] [int8PrimTy] (int8X32PrimTy)
-primOpInfo (VecBroadcastOp IntVec 16 W16) = mkGenPrimOp (fsLit "broadcastInt16X16#")  [] [int16PrimTy] (int16X16PrimTy)
-primOpInfo (VecBroadcastOp IntVec 8 W32) = mkGenPrimOp (fsLit "broadcastInt32X8#")  [] [int32PrimTy] (int32X8PrimTy)
-primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#")  [] [int64PrimTy] (int64X4PrimTy)
-primOpInfo (VecBroadcastOp IntVec 64 W8) = mkGenPrimOp (fsLit "broadcastInt8X64#")  [] [int8PrimTy] (int8X64PrimTy)
-primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#")  [] [int16PrimTy] (int16X32PrimTy)
-primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#")  [] [int32PrimTy] (int32X16PrimTy)
-primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#")  [] [int64PrimTy] (int64X8PrimTy)
-primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#")  [] [word8PrimTy] (word8X16PrimTy)
-primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#")  [] [word16PrimTy] (word16X8PrimTy)
-primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#")  [] [word32PrimTy] (word32X4PrimTy)
-primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#")  [] [word64PrimTy] (word64X2PrimTy)
-primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#")  [] [word8PrimTy] (word8X32PrimTy)
-primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#")  [] [word16PrimTy] (word16X16PrimTy)
-primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#")  [] [word32PrimTy] (word32X8PrimTy)
-primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#")  [] [word64PrimTy] (word64X4PrimTy)
-primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#")  [] [word8PrimTy] (word8X64PrimTy)
-primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#")  [] [word16PrimTy] (word16X32PrimTy)
-primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#")  [] [word32PrimTy] (word32X16PrimTy)
-primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#")  [] [word64PrimTy] (word64X8PrimTy)
-primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#")  [] [floatPrimTy] (floatX4PrimTy)
-primOpInfo (VecBroadcastOp FloatVec 2 W64) = mkGenPrimOp (fsLit "broadcastDoubleX2#")  [] [doublePrimTy] (doubleX2PrimTy)
-primOpInfo (VecBroadcastOp FloatVec 8 W32) = mkGenPrimOp (fsLit "broadcastFloatX8#")  [] [floatPrimTy] (floatX8PrimTy)
-primOpInfo (VecBroadcastOp FloatVec 4 W64) = mkGenPrimOp (fsLit "broadcastDoubleX4#")  [] [doublePrimTy] (doubleX4PrimTy)
-primOpInfo (VecBroadcastOp FloatVec 16 W32) = mkGenPrimOp (fsLit "broadcastFloatX16#")  [] [floatPrimTy] (floatX16PrimTy)
-primOpInfo (VecBroadcastOp FloatVec 8 W64) = mkGenPrimOp (fsLit "broadcastDoubleX8#")  [] [doublePrimTy] (doubleX8PrimTy)
-primOpInfo (VecPackOp IntVec 16 W8) = mkGenPrimOp (fsLit "packInt8X16#")  [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X16PrimTy)
-primOpInfo (VecPackOp IntVec 8 W16) = mkGenPrimOp (fsLit "packInt16X8#")  [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X8PrimTy)
-primOpInfo (VecPackOp IntVec 4 W32) = mkGenPrimOp (fsLit "packInt32X4#")  [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X4PrimTy)
-primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#")  [] [(mkTupleTy Unboxed [int64PrimTy, int64PrimTy])] (int64X2PrimTy)
-primOpInfo (VecPackOp IntVec 32 W8) = mkGenPrimOp (fsLit "packInt8X32#")  [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X32PrimTy)
-primOpInfo (VecPackOp IntVec 16 W16) = mkGenPrimOp (fsLit "packInt16X16#")  [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X16PrimTy)
-primOpInfo (VecPackOp IntVec 8 W32) = mkGenPrimOp (fsLit "packInt32X8#")  [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X8PrimTy)
-primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#")  [] [(mkTupleTy Unboxed [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy])] (int64X4PrimTy)
-primOpInfo (VecPackOp IntVec 64 W8) = mkGenPrimOp (fsLit "packInt8X64#")  [] [(mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy])] (int8X64PrimTy)
-primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#")  [] [(mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy])] (int16X32PrimTy)
-primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#")  [] [(mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy])] (int32X16PrimTy)
-primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#")  [] [(mkTupleTy Unboxed [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy])] (int64X8PrimTy)
-primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#")  [] [(mkTupleTy Unboxed [word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy])] (word8X16PrimTy)
-primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#")  [] [(mkTupleTy Unboxed [word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy])] (word16X8PrimTy)
-primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#")  [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X4PrimTy)
-primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#")  [] [(mkTupleTy Unboxed [word64PrimTy, word64PrimTy])] (word64X2PrimTy)
-primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#")  [] [(mkTupleTy Unboxed [word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy])] (word8X32PrimTy)
-primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#")  [] [(mkTupleTy Unboxed [word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy])] (word16X16PrimTy)
-primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#")  [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X8PrimTy)
-primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#")  [] [(mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])] (word64X4PrimTy)
-primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#")  [] [(mkTupleTy Unboxed [word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy])] (word8X64PrimTy)
-primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#")  [] [(mkTupleTy Unboxed [word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy])] (word16X32PrimTy)
-primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#")  [] [(mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy])] (word32X16PrimTy)
-primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#")  [] [(mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy])] (word64X8PrimTy)
-primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy)
-primOpInfo (VecPackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "packDoubleX2#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy])] (doubleX2PrimTy)
-primOpInfo (VecPackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "packFloatX8#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX8PrimTy)
-primOpInfo (VecPackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "packDoubleX4#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX4PrimTy)
-primOpInfo (VecPackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "packFloatX16#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX16PrimTy)
-primOpInfo (VecPackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "packDoubleX8#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX8PrimTy)
-primOpInfo (VecUnpackOp IntVec 16 W8) = mkGenPrimOp (fsLit "unpackInt8X16#")  [] [int8X16PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy]))
-primOpInfo (VecUnpackOp IntVec 8 W16) = mkGenPrimOp (fsLit "unpackInt16X8#")  [] [int16X8PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy]))
-primOpInfo (VecUnpackOp IntVec 4 W32) = mkGenPrimOp (fsLit "unpackInt32X4#")  [] [int32X4PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy]))
-primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#")  [] [int64X2PrimTy] ((mkTupleTy Unboxed [int64PrimTy, int64PrimTy]))
-primOpInfo (VecUnpackOp IntVec 32 W8) = mkGenPrimOp (fsLit "unpackInt8X32#")  [] [int8X32PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy]))
-primOpInfo (VecUnpackOp IntVec 16 W16) = mkGenPrimOp (fsLit "unpackInt16X16#")  [] [int16X16PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy]))
-primOpInfo (VecUnpackOp IntVec 8 W32) = mkGenPrimOp (fsLit "unpackInt32X8#")  [] [int32X8PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy]))
-primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#")  [] [int64X4PrimTy] ((mkTupleTy Unboxed [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy]))
-primOpInfo (VecUnpackOp IntVec 64 W8) = mkGenPrimOp (fsLit "unpackInt8X64#")  [] [int8X64PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy, int8PrimTy]))
-primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#")  [] [int16X32PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy, int16PrimTy]))
-primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#")  [] [int32X16PrimTy] ((mkTupleTy Unboxed [int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy, int32PrimTy]))
-primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#")  [] [int64X8PrimTy] ((mkTupleTy Unboxed [int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy, int64PrimTy]))
-primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#")  [] [word8X16PrimTy] ((mkTupleTy Unboxed [word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy]))
-primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#")  [] [word16X8PrimTy] ((mkTupleTy Unboxed [word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy]))
-primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#")  [] [word32X4PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy]))
-primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#")  [] [word64X2PrimTy] ((mkTupleTy Unboxed [word64PrimTy, word64PrimTy]))
-primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#")  [] [word8X32PrimTy] ((mkTupleTy Unboxed [word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy]))
-primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#")  [] [word16X16PrimTy] ((mkTupleTy Unboxed [word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy]))
-primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#")  [] [word32X8PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy]))
-primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#")  [] [word64X4PrimTy] ((mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy]))
-primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#")  [] [word8X64PrimTy] ((mkTupleTy Unboxed [word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy, word8PrimTy]))
-primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#")  [] [word16X32PrimTy] ((mkTupleTy Unboxed [word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy, word16PrimTy]))
-primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#")  [] [word32X16PrimTy] ((mkTupleTy Unboxed [word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy, word32PrimTy]))
-primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#")  [] [word64X8PrimTy] ((mkTupleTy Unboxed [word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy, word64PrimTy]))
-primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#")  [] [floatX4PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))
-primOpInfo (VecUnpackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "unpackDoubleX2#")  [] [doubleX2PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy]))
-primOpInfo (VecUnpackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "unpackFloatX8#")  [] [floatX8PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))
-primOpInfo (VecUnpackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "unpackDoubleX4#")  [] [doubleX4PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))
-primOpInfo (VecUnpackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "unpackFloatX16#")  [] [floatX16PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))
-primOpInfo (VecUnpackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "unpackDoubleX8#")  [] [doubleX8PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))
-primOpInfo (VecInsertOp IntVec 16 W8) = mkGenPrimOp (fsLit "insertInt8X16#")  [] [int8X16PrimTy, int8PrimTy, intPrimTy] (int8X16PrimTy)
-primOpInfo (VecInsertOp IntVec 8 W16) = mkGenPrimOp (fsLit "insertInt16X8#")  [] [int16X8PrimTy, int16PrimTy, intPrimTy] (int16X8PrimTy)
-primOpInfo (VecInsertOp IntVec 4 W32) = mkGenPrimOp (fsLit "insertInt32X4#")  [] [int32X4PrimTy, int32PrimTy, intPrimTy] (int32X4PrimTy)
-primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#")  [] [int64X2PrimTy, int64PrimTy, intPrimTy] (int64X2PrimTy)
-primOpInfo (VecInsertOp IntVec 32 W8) = mkGenPrimOp (fsLit "insertInt8X32#")  [] [int8X32PrimTy, int8PrimTy, intPrimTy] (int8X32PrimTy)
-primOpInfo (VecInsertOp IntVec 16 W16) = mkGenPrimOp (fsLit "insertInt16X16#")  [] [int16X16PrimTy, int16PrimTy, intPrimTy] (int16X16PrimTy)
-primOpInfo (VecInsertOp IntVec 8 W32) = mkGenPrimOp (fsLit "insertInt32X8#")  [] [int32X8PrimTy, int32PrimTy, intPrimTy] (int32X8PrimTy)
-primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#")  [] [int64X4PrimTy, int64PrimTy, intPrimTy] (int64X4PrimTy)
-primOpInfo (VecInsertOp IntVec 64 W8) = mkGenPrimOp (fsLit "insertInt8X64#")  [] [int8X64PrimTy, int8PrimTy, intPrimTy] (int8X64PrimTy)
-primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#")  [] [int16X32PrimTy, int16PrimTy, intPrimTy] (int16X32PrimTy)
-primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#")  [] [int32X16PrimTy, int32PrimTy, intPrimTy] (int32X16PrimTy)
-primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#")  [] [int64X8PrimTy, int64PrimTy, intPrimTy] (int64X8PrimTy)
-primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#")  [] [word8X16PrimTy, word8PrimTy, intPrimTy] (word8X16PrimTy)
-primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#")  [] [word16X8PrimTy, word16PrimTy, intPrimTy] (word16X8PrimTy)
-primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#")  [] [word32X4PrimTy, word32PrimTy, intPrimTy] (word32X4PrimTy)
-primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#")  [] [word64X2PrimTy, word64PrimTy, intPrimTy] (word64X2PrimTy)
-primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#")  [] [word8X32PrimTy, word8PrimTy, intPrimTy] (word8X32PrimTy)
-primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#")  [] [word16X16PrimTy, word16PrimTy, intPrimTy] (word16X16PrimTy)
-primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#")  [] [word32X8PrimTy, word32PrimTy, intPrimTy] (word32X8PrimTy)
-primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#")  [] [word64X4PrimTy, word64PrimTy, intPrimTy] (word64X4PrimTy)
-primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#")  [] [word8X64PrimTy, word8PrimTy, intPrimTy] (word8X64PrimTy)
-primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#")  [] [word16X32PrimTy, word16PrimTy, intPrimTy] (word16X32PrimTy)
-primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#")  [] [word32X16PrimTy, word32PrimTy, intPrimTy] (word32X16PrimTy)
-primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#")  [] [word64X8PrimTy, word64PrimTy, intPrimTy] (word64X8PrimTy)
-primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#")  [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy)
-primOpInfo (VecInsertOp FloatVec 2 W64) = mkGenPrimOp (fsLit "insertDoubleX2#")  [] [doubleX2PrimTy, doublePrimTy, intPrimTy] (doubleX2PrimTy)
-primOpInfo (VecInsertOp FloatVec 8 W32) = mkGenPrimOp (fsLit "insertFloatX8#")  [] [floatX8PrimTy, floatPrimTy, intPrimTy] (floatX8PrimTy)
-primOpInfo (VecInsertOp FloatVec 4 W64) = mkGenPrimOp (fsLit "insertDoubleX4#")  [] [doubleX4PrimTy, doublePrimTy, intPrimTy] (doubleX4PrimTy)
-primOpInfo (VecInsertOp FloatVec 16 W32) = mkGenPrimOp (fsLit "insertFloatX16#")  [] [floatX16PrimTy, floatPrimTy, intPrimTy] (floatX16PrimTy)
-primOpInfo (VecInsertOp FloatVec 8 W64) = mkGenPrimOp (fsLit "insertDoubleX8#")  [] [doubleX8PrimTy, doublePrimTy, intPrimTy] (doubleX8PrimTy)
-primOpInfo (VecAddOp IntVec 16 W8) = mkGenPrimOp (fsLit "plusInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)
-primOpInfo (VecAddOp IntVec 8 W16) = mkGenPrimOp (fsLit "plusInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)
-primOpInfo (VecAddOp IntVec 4 W32) = mkGenPrimOp (fsLit "plusInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)
-primOpInfo (VecAddOp IntVec 2 W64) = mkGenPrimOp (fsLit "plusInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)
-primOpInfo (VecAddOp IntVec 32 W8) = mkGenPrimOp (fsLit "plusInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)
-primOpInfo (VecAddOp IntVec 16 W16) = mkGenPrimOp (fsLit "plusInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)
-primOpInfo (VecAddOp IntVec 8 W32) = mkGenPrimOp (fsLit "plusInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)
-primOpInfo (VecAddOp IntVec 4 W64) = mkGenPrimOp (fsLit "plusInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)
-primOpInfo (VecAddOp IntVec 64 W8) = mkGenPrimOp (fsLit "plusInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)
-primOpInfo (VecAddOp IntVec 32 W16) = mkGenPrimOp (fsLit "plusInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)
-primOpInfo (VecAddOp IntVec 16 W32) = mkGenPrimOp (fsLit "plusInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)
-primOpInfo (VecAddOp IntVec 8 W64) = mkGenPrimOp (fsLit "plusInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)
-primOpInfo (VecAddOp WordVec 16 W8) = mkGenPrimOp (fsLit "plusWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)
-primOpInfo (VecAddOp WordVec 8 W16) = mkGenPrimOp (fsLit "plusWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)
-primOpInfo (VecAddOp WordVec 4 W32) = mkGenPrimOp (fsLit "plusWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)
-primOpInfo (VecAddOp WordVec 2 W64) = mkGenPrimOp (fsLit "plusWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)
-primOpInfo (VecAddOp WordVec 32 W8) = mkGenPrimOp (fsLit "plusWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)
-primOpInfo (VecAddOp WordVec 16 W16) = mkGenPrimOp (fsLit "plusWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)
-primOpInfo (VecAddOp WordVec 8 W32) = mkGenPrimOp (fsLit "plusWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)
-primOpInfo (VecAddOp WordVec 4 W64) = mkGenPrimOp (fsLit "plusWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)
-primOpInfo (VecAddOp WordVec 64 W8) = mkGenPrimOp (fsLit "plusWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)
-primOpInfo (VecAddOp WordVec 32 W16) = mkGenPrimOp (fsLit "plusWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)
-primOpInfo (VecAddOp WordVec 16 W32) = mkGenPrimOp (fsLit "plusWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)
-primOpInfo (VecAddOp WordVec 8 W64) = mkGenPrimOp (fsLit "plusWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)
-primOpInfo (VecAddOp FloatVec 4 W32) = mkGenPrimOp (fsLit "plusFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)
-primOpInfo (VecAddOp FloatVec 2 W64) = mkGenPrimOp (fsLit "plusDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)
-primOpInfo (VecAddOp FloatVec 8 W32) = mkGenPrimOp (fsLit "plusFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)
-primOpInfo (VecAddOp FloatVec 4 W64) = mkGenPrimOp (fsLit "plusDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)
-primOpInfo (VecAddOp FloatVec 16 W32) = mkGenPrimOp (fsLit "plusFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)
-primOpInfo (VecAddOp FloatVec 8 W64) = mkGenPrimOp (fsLit "plusDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)
-primOpInfo (VecSubOp IntVec 16 W8) = mkGenPrimOp (fsLit "minusInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)
-primOpInfo (VecSubOp IntVec 8 W16) = mkGenPrimOp (fsLit "minusInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)
-primOpInfo (VecSubOp IntVec 4 W32) = mkGenPrimOp (fsLit "minusInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)
-primOpInfo (VecSubOp IntVec 2 W64) = mkGenPrimOp (fsLit "minusInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)
-primOpInfo (VecSubOp IntVec 32 W8) = mkGenPrimOp (fsLit "minusInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)
-primOpInfo (VecSubOp IntVec 16 W16) = mkGenPrimOp (fsLit "minusInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)
-primOpInfo (VecSubOp IntVec 8 W32) = mkGenPrimOp (fsLit "minusInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)
-primOpInfo (VecSubOp IntVec 4 W64) = mkGenPrimOp (fsLit "minusInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)
-primOpInfo (VecSubOp IntVec 64 W8) = mkGenPrimOp (fsLit "minusInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)
-primOpInfo (VecSubOp IntVec 32 W16) = mkGenPrimOp (fsLit "minusInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)
-primOpInfo (VecSubOp IntVec 16 W32) = mkGenPrimOp (fsLit "minusInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)
-primOpInfo (VecSubOp IntVec 8 W64) = mkGenPrimOp (fsLit "minusInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)
-primOpInfo (VecSubOp WordVec 16 W8) = mkGenPrimOp (fsLit "minusWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)
-primOpInfo (VecSubOp WordVec 8 W16) = mkGenPrimOp (fsLit "minusWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)
-primOpInfo (VecSubOp WordVec 4 W32) = mkGenPrimOp (fsLit "minusWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)
-primOpInfo (VecSubOp WordVec 2 W64) = mkGenPrimOp (fsLit "minusWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)
-primOpInfo (VecSubOp WordVec 32 W8) = mkGenPrimOp (fsLit "minusWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)
-primOpInfo (VecSubOp WordVec 16 W16) = mkGenPrimOp (fsLit "minusWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)
-primOpInfo (VecSubOp WordVec 8 W32) = mkGenPrimOp (fsLit "minusWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)
-primOpInfo (VecSubOp WordVec 4 W64) = mkGenPrimOp (fsLit "minusWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)
-primOpInfo (VecSubOp WordVec 64 W8) = mkGenPrimOp (fsLit "minusWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)
-primOpInfo (VecSubOp WordVec 32 W16) = mkGenPrimOp (fsLit "minusWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)
-primOpInfo (VecSubOp WordVec 16 W32) = mkGenPrimOp (fsLit "minusWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)
-primOpInfo (VecSubOp WordVec 8 W64) = mkGenPrimOp (fsLit "minusWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)
-primOpInfo (VecSubOp FloatVec 4 W32) = mkGenPrimOp (fsLit "minusFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)
-primOpInfo (VecSubOp FloatVec 2 W64) = mkGenPrimOp (fsLit "minusDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)
-primOpInfo (VecSubOp FloatVec 8 W32) = mkGenPrimOp (fsLit "minusFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)
-primOpInfo (VecSubOp FloatVec 4 W64) = mkGenPrimOp (fsLit "minusDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)
-primOpInfo (VecSubOp FloatVec 16 W32) = mkGenPrimOp (fsLit "minusFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)
-primOpInfo (VecSubOp FloatVec 8 W64) = mkGenPrimOp (fsLit "minusDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)
-primOpInfo (VecMulOp IntVec 16 W8) = mkGenPrimOp (fsLit "timesInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)
-primOpInfo (VecMulOp IntVec 8 W16) = mkGenPrimOp (fsLit "timesInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)
-primOpInfo (VecMulOp IntVec 4 W32) = mkGenPrimOp (fsLit "timesInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)
-primOpInfo (VecMulOp IntVec 2 W64) = mkGenPrimOp (fsLit "timesInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)
-primOpInfo (VecMulOp IntVec 32 W8) = mkGenPrimOp (fsLit "timesInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)
-primOpInfo (VecMulOp IntVec 16 W16) = mkGenPrimOp (fsLit "timesInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)
-primOpInfo (VecMulOp IntVec 8 W32) = mkGenPrimOp (fsLit "timesInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)
-primOpInfo (VecMulOp IntVec 4 W64) = mkGenPrimOp (fsLit "timesInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)
-primOpInfo (VecMulOp IntVec 64 W8) = mkGenPrimOp (fsLit "timesInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)
-primOpInfo (VecMulOp IntVec 32 W16) = mkGenPrimOp (fsLit "timesInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)
-primOpInfo (VecMulOp IntVec 16 W32) = mkGenPrimOp (fsLit "timesInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)
-primOpInfo (VecMulOp IntVec 8 W64) = mkGenPrimOp (fsLit "timesInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)
-primOpInfo (VecMulOp WordVec 16 W8) = mkGenPrimOp (fsLit "timesWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)
-primOpInfo (VecMulOp WordVec 8 W16) = mkGenPrimOp (fsLit "timesWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)
-primOpInfo (VecMulOp WordVec 4 W32) = mkGenPrimOp (fsLit "timesWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)
-primOpInfo (VecMulOp WordVec 2 W64) = mkGenPrimOp (fsLit "timesWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)
-primOpInfo (VecMulOp WordVec 32 W8) = mkGenPrimOp (fsLit "timesWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)
-primOpInfo (VecMulOp WordVec 16 W16) = mkGenPrimOp (fsLit "timesWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)
-primOpInfo (VecMulOp WordVec 8 W32) = mkGenPrimOp (fsLit "timesWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)
-primOpInfo (VecMulOp WordVec 4 W64) = mkGenPrimOp (fsLit "timesWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)
-primOpInfo (VecMulOp WordVec 64 W8) = mkGenPrimOp (fsLit "timesWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)
-primOpInfo (VecMulOp WordVec 32 W16) = mkGenPrimOp (fsLit "timesWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)
-primOpInfo (VecMulOp WordVec 16 W32) = mkGenPrimOp (fsLit "timesWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)
-primOpInfo (VecMulOp WordVec 8 W64) = mkGenPrimOp (fsLit "timesWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)
-primOpInfo (VecMulOp FloatVec 4 W32) = mkGenPrimOp (fsLit "timesFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)
-primOpInfo (VecMulOp FloatVec 2 W64) = mkGenPrimOp (fsLit "timesDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)
-primOpInfo (VecMulOp FloatVec 8 W32) = mkGenPrimOp (fsLit "timesFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)
-primOpInfo (VecMulOp FloatVec 4 W64) = mkGenPrimOp (fsLit "timesDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)
-primOpInfo (VecMulOp FloatVec 16 W32) = mkGenPrimOp (fsLit "timesFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)
-primOpInfo (VecMulOp FloatVec 8 W64) = mkGenPrimOp (fsLit "timesDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)
-primOpInfo (VecDivOp FloatVec 4 W32) = mkGenPrimOp (fsLit "divideFloatX4#")  [] [floatX4PrimTy, floatX4PrimTy] (floatX4PrimTy)
-primOpInfo (VecDivOp FloatVec 2 W64) = mkGenPrimOp (fsLit "divideDoubleX2#")  [] [doubleX2PrimTy, doubleX2PrimTy] (doubleX2PrimTy)
-primOpInfo (VecDivOp FloatVec 8 W32) = mkGenPrimOp (fsLit "divideFloatX8#")  [] [floatX8PrimTy, floatX8PrimTy] (floatX8PrimTy)
-primOpInfo (VecDivOp FloatVec 4 W64) = mkGenPrimOp (fsLit "divideDoubleX4#")  [] [doubleX4PrimTy, doubleX4PrimTy] (doubleX4PrimTy)
-primOpInfo (VecDivOp FloatVec 16 W32) = mkGenPrimOp (fsLit "divideFloatX16#")  [] [floatX16PrimTy, floatX16PrimTy] (floatX16PrimTy)
-primOpInfo (VecDivOp FloatVec 8 W64) = mkGenPrimOp (fsLit "divideDoubleX8#")  [] [doubleX8PrimTy, doubleX8PrimTy] (doubleX8PrimTy)
-primOpInfo (VecQuotOp IntVec 16 W8) = mkGenPrimOp (fsLit "quotInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)
-primOpInfo (VecQuotOp IntVec 8 W16) = mkGenPrimOp (fsLit "quotInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)
-primOpInfo (VecQuotOp IntVec 4 W32) = mkGenPrimOp (fsLit "quotInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)
-primOpInfo (VecQuotOp IntVec 2 W64) = mkGenPrimOp (fsLit "quotInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)
-primOpInfo (VecQuotOp IntVec 32 W8) = mkGenPrimOp (fsLit "quotInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)
-primOpInfo (VecQuotOp IntVec 16 W16) = mkGenPrimOp (fsLit "quotInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)
-primOpInfo (VecQuotOp IntVec 8 W32) = mkGenPrimOp (fsLit "quotInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)
-primOpInfo (VecQuotOp IntVec 4 W64) = mkGenPrimOp (fsLit "quotInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)
-primOpInfo (VecQuotOp IntVec 64 W8) = mkGenPrimOp (fsLit "quotInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)
-primOpInfo (VecQuotOp IntVec 32 W16) = mkGenPrimOp (fsLit "quotInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)
-primOpInfo (VecQuotOp IntVec 16 W32) = mkGenPrimOp (fsLit "quotInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)
-primOpInfo (VecQuotOp IntVec 8 W64) = mkGenPrimOp (fsLit "quotInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)
-primOpInfo (VecQuotOp WordVec 16 W8) = mkGenPrimOp (fsLit "quotWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)
-primOpInfo (VecQuotOp WordVec 8 W16) = mkGenPrimOp (fsLit "quotWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)
-primOpInfo (VecQuotOp WordVec 4 W32) = mkGenPrimOp (fsLit "quotWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)
-primOpInfo (VecQuotOp WordVec 2 W64) = mkGenPrimOp (fsLit "quotWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)
-primOpInfo (VecQuotOp WordVec 32 W8) = mkGenPrimOp (fsLit "quotWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)
-primOpInfo (VecQuotOp WordVec 16 W16) = mkGenPrimOp (fsLit "quotWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)
-primOpInfo (VecQuotOp WordVec 8 W32) = mkGenPrimOp (fsLit "quotWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)
-primOpInfo (VecQuotOp WordVec 4 W64) = mkGenPrimOp (fsLit "quotWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)
-primOpInfo (VecQuotOp WordVec 64 W8) = mkGenPrimOp (fsLit "quotWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)
-primOpInfo (VecQuotOp WordVec 32 W16) = mkGenPrimOp (fsLit "quotWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)
-primOpInfo (VecQuotOp WordVec 16 W32) = mkGenPrimOp (fsLit "quotWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)
-primOpInfo (VecQuotOp WordVec 8 W64) = mkGenPrimOp (fsLit "quotWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)
-primOpInfo (VecRemOp IntVec 16 W8) = mkGenPrimOp (fsLit "remInt8X16#")  [] [int8X16PrimTy, int8X16PrimTy] (int8X16PrimTy)
-primOpInfo (VecRemOp IntVec 8 W16) = mkGenPrimOp (fsLit "remInt16X8#")  [] [int16X8PrimTy, int16X8PrimTy] (int16X8PrimTy)
-primOpInfo (VecRemOp IntVec 4 W32) = mkGenPrimOp (fsLit "remInt32X4#")  [] [int32X4PrimTy, int32X4PrimTy] (int32X4PrimTy)
-primOpInfo (VecRemOp IntVec 2 W64) = mkGenPrimOp (fsLit "remInt64X2#")  [] [int64X2PrimTy, int64X2PrimTy] (int64X2PrimTy)
-primOpInfo (VecRemOp IntVec 32 W8) = mkGenPrimOp (fsLit "remInt8X32#")  [] [int8X32PrimTy, int8X32PrimTy] (int8X32PrimTy)
-primOpInfo (VecRemOp IntVec 16 W16) = mkGenPrimOp (fsLit "remInt16X16#")  [] [int16X16PrimTy, int16X16PrimTy] (int16X16PrimTy)
-primOpInfo (VecRemOp IntVec 8 W32) = mkGenPrimOp (fsLit "remInt32X8#")  [] [int32X8PrimTy, int32X8PrimTy] (int32X8PrimTy)
-primOpInfo (VecRemOp IntVec 4 W64) = mkGenPrimOp (fsLit "remInt64X4#")  [] [int64X4PrimTy, int64X4PrimTy] (int64X4PrimTy)
-primOpInfo (VecRemOp IntVec 64 W8) = mkGenPrimOp (fsLit "remInt8X64#")  [] [int8X64PrimTy, int8X64PrimTy] (int8X64PrimTy)
-primOpInfo (VecRemOp IntVec 32 W16) = mkGenPrimOp (fsLit "remInt16X32#")  [] [int16X32PrimTy, int16X32PrimTy] (int16X32PrimTy)
-primOpInfo (VecRemOp IntVec 16 W32) = mkGenPrimOp (fsLit "remInt32X16#")  [] [int32X16PrimTy, int32X16PrimTy] (int32X16PrimTy)
-primOpInfo (VecRemOp IntVec 8 W64) = mkGenPrimOp (fsLit "remInt64X8#")  [] [int64X8PrimTy, int64X8PrimTy] (int64X8PrimTy)
-primOpInfo (VecRemOp WordVec 16 W8) = mkGenPrimOp (fsLit "remWord8X16#")  [] [word8X16PrimTy, word8X16PrimTy] (word8X16PrimTy)
-primOpInfo (VecRemOp WordVec 8 W16) = mkGenPrimOp (fsLit "remWord16X8#")  [] [word16X8PrimTy, word16X8PrimTy] (word16X8PrimTy)
-primOpInfo (VecRemOp WordVec 4 W32) = mkGenPrimOp (fsLit "remWord32X4#")  [] [word32X4PrimTy, word32X4PrimTy] (word32X4PrimTy)
-primOpInfo (VecRemOp WordVec 2 W64) = mkGenPrimOp (fsLit "remWord64X2#")  [] [word64X2PrimTy, word64X2PrimTy] (word64X2PrimTy)
-primOpInfo (VecRemOp WordVec 32 W8) = mkGenPrimOp (fsLit "remWord8X32#")  [] [word8X32PrimTy, word8X32PrimTy] (word8X32PrimTy)
-primOpInfo (VecRemOp WordVec 16 W16) = mkGenPrimOp (fsLit "remWord16X16#")  [] [word16X16PrimTy, word16X16PrimTy] (word16X16PrimTy)
-primOpInfo (VecRemOp WordVec 8 W32) = mkGenPrimOp (fsLit "remWord32X8#")  [] [word32X8PrimTy, word32X8PrimTy] (word32X8PrimTy)
-primOpInfo (VecRemOp WordVec 4 W64) = mkGenPrimOp (fsLit "remWord64X4#")  [] [word64X4PrimTy, word64X4PrimTy] (word64X4PrimTy)
-primOpInfo (VecRemOp WordVec 64 W8) = mkGenPrimOp (fsLit "remWord8X64#")  [] [word8X64PrimTy, word8X64PrimTy] (word8X64PrimTy)
-primOpInfo (VecRemOp WordVec 32 W16) = mkGenPrimOp (fsLit "remWord16X32#")  [] [word16X32PrimTy, word16X32PrimTy] (word16X32PrimTy)
-primOpInfo (VecRemOp WordVec 16 W32) = mkGenPrimOp (fsLit "remWord32X16#")  [] [word32X16PrimTy, word32X16PrimTy] (word32X16PrimTy)
-primOpInfo (VecRemOp WordVec 8 W64) = mkGenPrimOp (fsLit "remWord64X8#")  [] [word64X8PrimTy, word64X8PrimTy] (word64X8PrimTy)
-primOpInfo (VecNegOp IntVec 16 W8) = mkGenPrimOp (fsLit "negateInt8X16#")  [] [int8X16PrimTy] (int8X16PrimTy)
-primOpInfo (VecNegOp IntVec 8 W16) = mkGenPrimOp (fsLit "negateInt16X8#")  [] [int16X8PrimTy] (int16X8PrimTy)
-primOpInfo (VecNegOp IntVec 4 W32) = mkGenPrimOp (fsLit "negateInt32X4#")  [] [int32X4PrimTy] (int32X4PrimTy)
-primOpInfo (VecNegOp IntVec 2 W64) = mkGenPrimOp (fsLit "negateInt64X2#")  [] [int64X2PrimTy] (int64X2PrimTy)
-primOpInfo (VecNegOp IntVec 32 W8) = mkGenPrimOp (fsLit "negateInt8X32#")  [] [int8X32PrimTy] (int8X32PrimTy)
-primOpInfo (VecNegOp IntVec 16 W16) = mkGenPrimOp (fsLit "negateInt16X16#")  [] [int16X16PrimTy] (int16X16PrimTy)
-primOpInfo (VecNegOp IntVec 8 W32) = mkGenPrimOp (fsLit "negateInt32X8#")  [] [int32X8PrimTy] (int32X8PrimTy)
-primOpInfo (VecNegOp IntVec 4 W64) = mkGenPrimOp (fsLit "negateInt64X4#")  [] [int64X4PrimTy] (int64X4PrimTy)
-primOpInfo (VecNegOp IntVec 64 W8) = mkGenPrimOp (fsLit "negateInt8X64#")  [] [int8X64PrimTy] (int8X64PrimTy)
-primOpInfo (VecNegOp IntVec 32 W16) = mkGenPrimOp (fsLit "negateInt16X32#")  [] [int16X32PrimTy] (int16X32PrimTy)
-primOpInfo (VecNegOp IntVec 16 W32) = mkGenPrimOp (fsLit "negateInt32X16#")  [] [int32X16PrimTy] (int32X16PrimTy)
-primOpInfo (VecNegOp IntVec 8 W64) = mkGenPrimOp (fsLit "negateInt64X8#")  [] [int64X8PrimTy] (int64X8PrimTy)
-primOpInfo (VecNegOp FloatVec 4 W32) = mkGenPrimOp (fsLit "negateFloatX4#")  [] [floatX4PrimTy] (floatX4PrimTy)
-primOpInfo (VecNegOp FloatVec 2 W64) = mkGenPrimOp (fsLit "negateDoubleX2#")  [] [doubleX2PrimTy] (doubleX2PrimTy)
-primOpInfo (VecNegOp FloatVec 8 W32) = mkGenPrimOp (fsLit "negateFloatX8#")  [] [floatX8PrimTy] (floatX8PrimTy)
-primOpInfo (VecNegOp FloatVec 4 W64) = mkGenPrimOp (fsLit "negateDoubleX4#")  [] [doubleX4PrimTy] (doubleX4PrimTy)
-primOpInfo (VecNegOp FloatVec 16 W32) = mkGenPrimOp (fsLit "negateFloatX16#")  [] [floatX16PrimTy] (floatX16PrimTy)
-primOpInfo (VecNegOp FloatVec 8 W64) = mkGenPrimOp (fsLit "negateDoubleX8#")  [] [doubleX8PrimTy] (doubleX8PrimTy)
-primOpInfo (VecIndexByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)
-primOpInfo (VecIndexByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)
-primOpInfo (VecIndexByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)
-primOpInfo (VecIndexByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)
-primOpInfo (VecIndexByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)
-primOpInfo (VecIndexByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)
-primOpInfo (VecIndexByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)
-primOpInfo (VecIndexByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)
-primOpInfo (VecIndexByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)
-primOpInfo (VecIndexByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)
-primOpInfo (VecIndexByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)
-primOpInfo (VecIndexByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)
-primOpInfo (VecIndexByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)
-primOpInfo (VecIndexByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)
-primOpInfo (VecIndexByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)
-primOpInfo (VecIndexByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)
-primOpInfo (VecIndexByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)
-primOpInfo (VecIndexByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)
-primOpInfo (VecIndexByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)
-primOpInfo (VecIndexByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)
-primOpInfo (VecIndexByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)
-primOpInfo (VecIndexByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)
-primOpInfo (VecIndexByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)
-primOpInfo (VecIndexByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)
-primOpInfo (VecIndexByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)
-primOpInfo (VecIndexByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)
-primOpInfo (VecIndexByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)
-primOpInfo (VecIndexByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)
-primOpInfo (VecIndexByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)
-primOpInfo (VecIndexByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)
-primOpInfo (VecReadByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))
-primOpInfo (VecReadByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))
-primOpInfo (VecReadByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))
-primOpInfo (VecReadByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))
-primOpInfo (VecReadByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))
-primOpInfo (VecReadByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))
-primOpInfo (VecReadByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))
-primOpInfo (VecReadByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))
-primOpInfo (VecReadByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))
-primOpInfo (VecReadByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))
-primOpInfo (VecReadByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))
-primOpInfo (VecReadByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))
-primOpInfo (VecReadByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))
-primOpInfo (VecReadByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))
-primOpInfo (VecReadByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))
-primOpInfo (VecReadByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))
-primOpInfo (VecReadByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))
-primOpInfo (VecReadByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))
-primOpInfo (VecReadByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))
-primOpInfo (VecReadByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))
-primOpInfo (VecReadByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))
-primOpInfo (VecReadByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))
-primOpInfo (VecReadByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))
-primOpInfo (VecReadByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))
-primOpInfo (VecReadByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))
-primOpInfo (VecReadByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))
-primOpInfo (VecReadByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))
-primOpInfo (VecReadByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))
-primOpInfo (VecReadByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))
-primOpInfo (VecReadByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))
-primOpInfo (VecWriteByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8Array#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecIndexOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)
-primOpInfo (VecIndexOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)
-primOpInfo (VecIndexOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)
-primOpInfo (VecIndexOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)
-primOpInfo (VecIndexOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)
-primOpInfo (VecIndexOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)
-primOpInfo (VecIndexOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)
-primOpInfo (VecIndexOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)
-primOpInfo (VecIndexOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)
-primOpInfo (VecIndexOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)
-primOpInfo (VecIndexOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)
-primOpInfo (VecIndexOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)
-primOpInfo (VecIndexOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)
-primOpInfo (VecIndexOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)
-primOpInfo (VecIndexOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)
-primOpInfo (VecIndexOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)
-primOpInfo (VecIndexOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)
-primOpInfo (VecIndexOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)
-primOpInfo (VecIndexOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)
-primOpInfo (VecIndexOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)
-primOpInfo (VecIndexOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)
-primOpInfo (VecIndexOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)
-primOpInfo (VecIndexOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)
-primOpInfo (VecIndexOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)
-primOpInfo (VecIndexOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)
-primOpInfo (VecIndexOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)
-primOpInfo (VecIndexOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)
-primOpInfo (VecIndexOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)
-primOpInfo (VecIndexOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)
-primOpInfo (VecIndexOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)
-primOpInfo (VecReadOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))
-primOpInfo (VecReadOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))
-primOpInfo (VecReadOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))
-primOpInfo (VecReadOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))
-primOpInfo (VecReadOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))
-primOpInfo (VecReadOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))
-primOpInfo (VecReadOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))
-primOpInfo (VecReadOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))
-primOpInfo (VecReadOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))
-primOpInfo (VecReadOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))
-primOpInfo (VecReadOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))
-primOpInfo (VecReadOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))
-primOpInfo (VecReadOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))
-primOpInfo (VecReadOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))
-primOpInfo (VecReadOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))
-primOpInfo (VecReadOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))
-primOpInfo (VecReadOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))
-primOpInfo (VecReadOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))
-primOpInfo (VecReadOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))
-primOpInfo (VecReadOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))
-primOpInfo (VecReadOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))
-primOpInfo (VecReadOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))
-primOpInfo (VecReadOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))
-primOpInfo (VecReadOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))
-primOpInfo (VecReadOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))
-primOpInfo (VecReadOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))
-primOpInfo (VecReadOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))
-primOpInfo (VecReadOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))
-primOpInfo (VecReadOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))
-primOpInfo (VecReadOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))
-primOpInfo (VecWriteOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X16#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X8#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X4#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X2#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X32#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X16#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X8#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X4#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X64#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X32#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X16#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X8#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X16#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X8#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X4#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X2#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X32#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X16#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X8#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X4#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X64#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X32#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X16#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X8#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX4#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX2#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX8#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX4#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX16#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)
-primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX8#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)
-primOpInfo (VecReadScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X2#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X2#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX2#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))
-primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))
-primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X2#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X2#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X64#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X32#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX2#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX4#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX16#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX8#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X16#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X8#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X4#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X2#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X32#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X16#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X8#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X4#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X64#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X32#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X16#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X8#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X16#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X8#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X4#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X2#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X32#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X16#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X8#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X4#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X64#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X32#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X16#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X8#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX4#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX2#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX8#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX4#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX16#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)
-primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX8#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)
-primOpInfo (VecReadScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X2#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X64#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X2#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X64#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX2#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))
-primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))
-primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X2#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X64#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X2#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X64#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX2#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX4#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX8#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchByteArrayOp3 = mkGenPrimOp (fsLit "prefetchByteArray3#")  [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchMutableByteArrayOp3 = mkGenPrimOp (fsLit "prefetchMutableByteArray3#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchAddrOp3 = mkGenPrimOp (fsLit "prefetchAddr3#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchValueOp3 = mkGenPrimOp (fsLit "prefetchValue3#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchByteArrayOp2 = mkGenPrimOp (fsLit "prefetchByteArray2#")  [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchMutableByteArrayOp2 = mkGenPrimOp (fsLit "prefetchMutableByteArray2#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchAddrOp2 = mkGenPrimOp (fsLit "prefetchAddr2#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchValueOp2 = mkGenPrimOp (fsLit "prefetchValue2#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchByteArrayOp1 = mkGenPrimOp (fsLit "prefetchByteArray1#")  [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchMutableByteArrayOp1 = mkGenPrimOp (fsLit "prefetchMutableByteArray1#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchAddrOp1 = mkGenPrimOp (fsLit "prefetchAddr1#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchValueOp1 = mkGenPrimOp (fsLit "prefetchValue1#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchByteArrayOp0 = mkGenPrimOp (fsLit "prefetchByteArray0#")  [deltaTyVarSpec] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchMutableByteArrayOp0 = mkGenPrimOp (fsLit "prefetchMutableByteArray0#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchAddrOp0 = mkGenPrimOp (fsLit "prefetchAddr0#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
-primOpInfo PrefetchValueOp0 = mkGenPrimOp (fsLit "prefetchValue0#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
diff --git a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl b/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl
+++ /dev/null
@@ -1,29 +0,0 @@
-primOpStrictness CatchOp =  \ _arity -> mkClosedDmdSig [ lazyApply1Dmd
-                                                 , lazyApply2Dmd
-                                                 , topDmd] topDiv 
-primOpStrictness RaiseOp =  \ _arity -> mkClosedDmdSig [topDmd] botDiv 
-primOpStrictness RaiseUnderflowOp =  \ _arity -> mkClosedDmdSig [topDmd] botDiv 
-primOpStrictness RaiseOverflowOp =  \ _arity -> mkClosedDmdSig [topDmd] botDiv 
-primOpStrictness RaiseDivZeroOp =  \ _arity -> mkClosedDmdSig [topDmd] botDiv 
-primOpStrictness RaiseIOOp =  \ _arity -> mkClosedDmdSig [topDmd, topDmd] exnDiv 
-primOpStrictness MaskAsyncExceptionsOp =  \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv 
-primOpStrictness MaskUninterruptibleOp =  \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv 
-primOpStrictness UnmaskAsyncExceptionsOp =  \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv 
-primOpStrictness PromptOp =  \ _arity -> mkClosedDmdSig [topDmd, strictOnceApply1Dmd, topDmd] topDiv 
-primOpStrictness Control0Op =  \ _arity -> mkClosedDmdSig [topDmd, lazyApply2Dmd, topDmd] topDiv 
-primOpStrictness AtomicallyOp =  \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv 
-primOpStrictness RetryOp =  \ _arity -> mkClosedDmdSig [topDmd] botDiv 
-primOpStrictness CatchRetryOp =  \ _arity -> mkClosedDmdSig [ lazyApply1Dmd
-                                                 , lazyApply1Dmd
-                                                 , topDmd ] topDiv 
-primOpStrictness CatchSTMOp =  \ _arity -> mkClosedDmdSig [ lazyApply1Dmd
-                                                 , lazyApply2Dmd
-                                                 , topDmd ] topDiv 
-primOpStrictness ForkOp =  \ _arity -> mkClosedDmdSig [ lazyApply1Dmd
-                                              , topDmd ] topDiv 
-primOpStrictness ForkOnOp =  \ _arity -> mkClosedDmdSig [ topDmd
-                                              , lazyApply1Dmd
-                                              , topDmd ] topDiv 
-primOpStrictness KeepAliveOp =  \ _arity -> mkClosedDmdSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv 
-primOpStrictness DataToTagOp =  \ _arity -> mkClosedDmdSig [evalDmd] topDiv 
-primOpStrictness _ =  \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv 
diff --git a/ghc-lib/stage0/compiler/build/primop-tag.hs-incl b/ghc-lib/stage0/compiler/build/primop-tag.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-tag.hs-incl
+++ /dev/null
@@ -1,1315 +0,0 @@
-maxPrimOpTag :: Int
-maxPrimOpTag = 1311
-primOpTag :: PrimOp -> Int
-primOpTag CharGtOp = 0
-primOpTag CharGeOp = 1
-primOpTag CharEqOp = 2
-primOpTag CharNeOp = 3
-primOpTag CharLtOp = 4
-primOpTag CharLeOp = 5
-primOpTag OrdOp = 6
-primOpTag Int8ToIntOp = 7
-primOpTag IntToInt8Op = 8
-primOpTag Int8NegOp = 9
-primOpTag Int8AddOp = 10
-primOpTag Int8SubOp = 11
-primOpTag Int8MulOp = 12
-primOpTag Int8QuotOp = 13
-primOpTag Int8RemOp = 14
-primOpTag Int8QuotRemOp = 15
-primOpTag Int8SllOp = 16
-primOpTag Int8SraOp = 17
-primOpTag Int8SrlOp = 18
-primOpTag Int8ToWord8Op = 19
-primOpTag Int8EqOp = 20
-primOpTag Int8GeOp = 21
-primOpTag Int8GtOp = 22
-primOpTag Int8LeOp = 23
-primOpTag Int8LtOp = 24
-primOpTag Int8NeOp = 25
-primOpTag Word8ToWordOp = 26
-primOpTag WordToWord8Op = 27
-primOpTag Word8AddOp = 28
-primOpTag Word8SubOp = 29
-primOpTag Word8MulOp = 30
-primOpTag Word8QuotOp = 31
-primOpTag Word8RemOp = 32
-primOpTag Word8QuotRemOp = 33
-primOpTag Word8AndOp = 34
-primOpTag Word8OrOp = 35
-primOpTag Word8XorOp = 36
-primOpTag Word8NotOp = 37
-primOpTag Word8SllOp = 38
-primOpTag Word8SrlOp = 39
-primOpTag Word8ToInt8Op = 40
-primOpTag Word8EqOp = 41
-primOpTag Word8GeOp = 42
-primOpTag Word8GtOp = 43
-primOpTag Word8LeOp = 44
-primOpTag Word8LtOp = 45
-primOpTag Word8NeOp = 46
-primOpTag Int16ToIntOp = 47
-primOpTag IntToInt16Op = 48
-primOpTag Int16NegOp = 49
-primOpTag Int16AddOp = 50
-primOpTag Int16SubOp = 51
-primOpTag Int16MulOp = 52
-primOpTag Int16QuotOp = 53
-primOpTag Int16RemOp = 54
-primOpTag Int16QuotRemOp = 55
-primOpTag Int16SllOp = 56
-primOpTag Int16SraOp = 57
-primOpTag Int16SrlOp = 58
-primOpTag Int16ToWord16Op = 59
-primOpTag Int16EqOp = 60
-primOpTag Int16GeOp = 61
-primOpTag Int16GtOp = 62
-primOpTag Int16LeOp = 63
-primOpTag Int16LtOp = 64
-primOpTag Int16NeOp = 65
-primOpTag Word16ToWordOp = 66
-primOpTag WordToWord16Op = 67
-primOpTag Word16AddOp = 68
-primOpTag Word16SubOp = 69
-primOpTag Word16MulOp = 70
-primOpTag Word16QuotOp = 71
-primOpTag Word16RemOp = 72
-primOpTag Word16QuotRemOp = 73
-primOpTag Word16AndOp = 74
-primOpTag Word16OrOp = 75
-primOpTag Word16XorOp = 76
-primOpTag Word16NotOp = 77
-primOpTag Word16SllOp = 78
-primOpTag Word16SrlOp = 79
-primOpTag Word16ToInt16Op = 80
-primOpTag Word16EqOp = 81
-primOpTag Word16GeOp = 82
-primOpTag Word16GtOp = 83
-primOpTag Word16LeOp = 84
-primOpTag Word16LtOp = 85
-primOpTag Word16NeOp = 86
-primOpTag Int32ToIntOp = 87
-primOpTag IntToInt32Op = 88
-primOpTag Int32NegOp = 89
-primOpTag Int32AddOp = 90
-primOpTag Int32SubOp = 91
-primOpTag Int32MulOp = 92
-primOpTag Int32QuotOp = 93
-primOpTag Int32RemOp = 94
-primOpTag Int32QuotRemOp = 95
-primOpTag Int32SllOp = 96
-primOpTag Int32SraOp = 97
-primOpTag Int32SrlOp = 98
-primOpTag Int32ToWord32Op = 99
-primOpTag Int32EqOp = 100
-primOpTag Int32GeOp = 101
-primOpTag Int32GtOp = 102
-primOpTag Int32LeOp = 103
-primOpTag Int32LtOp = 104
-primOpTag Int32NeOp = 105
-primOpTag Word32ToWordOp = 106
-primOpTag WordToWord32Op = 107
-primOpTag Word32AddOp = 108
-primOpTag Word32SubOp = 109
-primOpTag Word32MulOp = 110
-primOpTag Word32QuotOp = 111
-primOpTag Word32RemOp = 112
-primOpTag Word32QuotRemOp = 113
-primOpTag Word32AndOp = 114
-primOpTag Word32OrOp = 115
-primOpTag Word32XorOp = 116
-primOpTag Word32NotOp = 117
-primOpTag Word32SllOp = 118
-primOpTag Word32SrlOp = 119
-primOpTag Word32ToInt32Op = 120
-primOpTag Word32EqOp = 121
-primOpTag Word32GeOp = 122
-primOpTag Word32GtOp = 123
-primOpTag Word32LeOp = 124
-primOpTag Word32LtOp = 125
-primOpTag Word32NeOp = 126
-primOpTag Int64ToIntOp = 127
-primOpTag IntToInt64Op = 128
-primOpTag Int64NegOp = 129
-primOpTag Int64AddOp = 130
-primOpTag Int64SubOp = 131
-primOpTag Int64MulOp = 132
-primOpTag Int64QuotOp = 133
-primOpTag Int64RemOp = 134
-primOpTag Int64SllOp = 135
-primOpTag Int64SraOp = 136
-primOpTag Int64SrlOp = 137
-primOpTag Int64ToWord64Op = 138
-primOpTag Int64EqOp = 139
-primOpTag Int64GeOp = 140
-primOpTag Int64GtOp = 141
-primOpTag Int64LeOp = 142
-primOpTag Int64LtOp = 143
-primOpTag Int64NeOp = 144
-primOpTag Word64ToWordOp = 145
-primOpTag WordToWord64Op = 146
-primOpTag Word64AddOp = 147
-primOpTag Word64SubOp = 148
-primOpTag Word64MulOp = 149
-primOpTag Word64QuotOp = 150
-primOpTag Word64RemOp = 151
-primOpTag Word64AndOp = 152
-primOpTag Word64OrOp = 153
-primOpTag Word64XorOp = 154
-primOpTag Word64NotOp = 155
-primOpTag Word64SllOp = 156
-primOpTag Word64SrlOp = 157
-primOpTag Word64ToInt64Op = 158
-primOpTag Word64EqOp = 159
-primOpTag Word64GeOp = 160
-primOpTag Word64GtOp = 161
-primOpTag Word64LeOp = 162
-primOpTag Word64LtOp = 163
-primOpTag Word64NeOp = 164
-primOpTag IntAddOp = 165
-primOpTag IntSubOp = 166
-primOpTag IntMulOp = 167
-primOpTag IntMul2Op = 168
-primOpTag IntMulMayOfloOp = 169
-primOpTag IntQuotOp = 170
-primOpTag IntRemOp = 171
-primOpTag IntQuotRemOp = 172
-primOpTag IntAndOp = 173
-primOpTag IntOrOp = 174
-primOpTag IntXorOp = 175
-primOpTag IntNotOp = 176
-primOpTag IntNegOp = 177
-primOpTag IntAddCOp = 178
-primOpTag IntSubCOp = 179
-primOpTag IntGtOp = 180
-primOpTag IntGeOp = 181
-primOpTag IntEqOp = 182
-primOpTag IntNeOp = 183
-primOpTag IntLtOp = 184
-primOpTag IntLeOp = 185
-primOpTag ChrOp = 186
-primOpTag IntToWordOp = 187
-primOpTag IntToFloatOp = 188
-primOpTag IntToDoubleOp = 189
-primOpTag WordToFloatOp = 190
-primOpTag WordToDoubleOp = 191
-primOpTag IntSllOp = 192
-primOpTag IntSraOp = 193
-primOpTag IntSrlOp = 194
-primOpTag WordAddOp = 195
-primOpTag WordAddCOp = 196
-primOpTag WordSubCOp = 197
-primOpTag WordAdd2Op = 198
-primOpTag WordSubOp = 199
-primOpTag WordMulOp = 200
-primOpTag WordMul2Op = 201
-primOpTag WordQuotOp = 202
-primOpTag WordRemOp = 203
-primOpTag WordQuotRemOp = 204
-primOpTag WordQuotRem2Op = 205
-primOpTag WordAndOp = 206
-primOpTag WordOrOp = 207
-primOpTag WordXorOp = 208
-primOpTag WordNotOp = 209
-primOpTag WordSllOp = 210
-primOpTag WordSrlOp = 211
-primOpTag WordToIntOp = 212
-primOpTag WordGtOp = 213
-primOpTag WordGeOp = 214
-primOpTag WordEqOp = 215
-primOpTag WordNeOp = 216
-primOpTag WordLtOp = 217
-primOpTag WordLeOp = 218
-primOpTag PopCnt8Op = 219
-primOpTag PopCnt16Op = 220
-primOpTag PopCnt32Op = 221
-primOpTag PopCnt64Op = 222
-primOpTag PopCntOp = 223
-primOpTag Pdep8Op = 224
-primOpTag Pdep16Op = 225
-primOpTag Pdep32Op = 226
-primOpTag Pdep64Op = 227
-primOpTag PdepOp = 228
-primOpTag Pext8Op = 229
-primOpTag Pext16Op = 230
-primOpTag Pext32Op = 231
-primOpTag Pext64Op = 232
-primOpTag PextOp = 233
-primOpTag Clz8Op = 234
-primOpTag Clz16Op = 235
-primOpTag Clz32Op = 236
-primOpTag Clz64Op = 237
-primOpTag ClzOp = 238
-primOpTag Ctz8Op = 239
-primOpTag Ctz16Op = 240
-primOpTag Ctz32Op = 241
-primOpTag Ctz64Op = 242
-primOpTag CtzOp = 243
-primOpTag BSwap16Op = 244
-primOpTag BSwap32Op = 245
-primOpTag BSwap64Op = 246
-primOpTag BSwapOp = 247
-primOpTag BRev8Op = 248
-primOpTag BRev16Op = 249
-primOpTag BRev32Op = 250
-primOpTag BRev64Op = 251
-primOpTag BRevOp = 252
-primOpTag Narrow8IntOp = 253
-primOpTag Narrow16IntOp = 254
-primOpTag Narrow32IntOp = 255
-primOpTag Narrow8WordOp = 256
-primOpTag Narrow16WordOp = 257
-primOpTag Narrow32WordOp = 258
-primOpTag DoubleGtOp = 259
-primOpTag DoubleGeOp = 260
-primOpTag DoubleEqOp = 261
-primOpTag DoubleNeOp = 262
-primOpTag DoubleLtOp = 263
-primOpTag DoubleLeOp = 264
-primOpTag DoubleAddOp = 265
-primOpTag DoubleSubOp = 266
-primOpTag DoubleMulOp = 267
-primOpTag DoubleDivOp = 268
-primOpTag DoubleNegOp = 269
-primOpTag DoubleFabsOp = 270
-primOpTag DoubleToIntOp = 271
-primOpTag DoubleToFloatOp = 272
-primOpTag DoubleExpOp = 273
-primOpTag DoubleExpM1Op = 274
-primOpTag DoubleLogOp = 275
-primOpTag DoubleLog1POp = 276
-primOpTag DoubleSqrtOp = 277
-primOpTag DoubleSinOp = 278
-primOpTag DoubleCosOp = 279
-primOpTag DoubleTanOp = 280
-primOpTag DoubleAsinOp = 281
-primOpTag DoubleAcosOp = 282
-primOpTag DoubleAtanOp = 283
-primOpTag DoubleSinhOp = 284
-primOpTag DoubleCoshOp = 285
-primOpTag DoubleTanhOp = 286
-primOpTag DoubleAsinhOp = 287
-primOpTag DoubleAcoshOp = 288
-primOpTag DoubleAtanhOp = 289
-primOpTag DoublePowerOp = 290
-primOpTag DoubleDecode_2IntOp = 291
-primOpTag DoubleDecode_Int64Op = 292
-primOpTag FloatGtOp = 293
-primOpTag FloatGeOp = 294
-primOpTag FloatEqOp = 295
-primOpTag FloatNeOp = 296
-primOpTag FloatLtOp = 297
-primOpTag FloatLeOp = 298
-primOpTag FloatAddOp = 299
-primOpTag FloatSubOp = 300
-primOpTag FloatMulOp = 301
-primOpTag FloatDivOp = 302
-primOpTag FloatNegOp = 303
-primOpTag FloatFabsOp = 304
-primOpTag FloatToIntOp = 305
-primOpTag FloatExpOp = 306
-primOpTag FloatExpM1Op = 307
-primOpTag FloatLogOp = 308
-primOpTag FloatLog1POp = 309
-primOpTag FloatSqrtOp = 310
-primOpTag FloatSinOp = 311
-primOpTag FloatCosOp = 312
-primOpTag FloatTanOp = 313
-primOpTag FloatAsinOp = 314
-primOpTag FloatAcosOp = 315
-primOpTag FloatAtanOp = 316
-primOpTag FloatSinhOp = 317
-primOpTag FloatCoshOp = 318
-primOpTag FloatTanhOp = 319
-primOpTag FloatAsinhOp = 320
-primOpTag FloatAcoshOp = 321
-primOpTag FloatAtanhOp = 322
-primOpTag FloatPowerOp = 323
-primOpTag FloatToDoubleOp = 324
-primOpTag FloatDecode_IntOp = 325
-primOpTag NewArrayOp = 326
-primOpTag ReadArrayOp = 327
-primOpTag WriteArrayOp = 328
-primOpTag SizeofArrayOp = 329
-primOpTag SizeofMutableArrayOp = 330
-primOpTag IndexArrayOp = 331
-primOpTag UnsafeFreezeArrayOp = 332
-primOpTag UnsafeThawArrayOp = 333
-primOpTag CopyArrayOp = 334
-primOpTag CopyMutableArrayOp = 335
-primOpTag CloneArrayOp = 336
-primOpTag CloneMutableArrayOp = 337
-primOpTag FreezeArrayOp = 338
-primOpTag ThawArrayOp = 339
-primOpTag CasArrayOp = 340
-primOpTag NewSmallArrayOp = 341
-primOpTag ShrinkSmallMutableArrayOp_Char = 342
-primOpTag ReadSmallArrayOp = 343
-primOpTag WriteSmallArrayOp = 344
-primOpTag SizeofSmallArrayOp = 345
-primOpTag SizeofSmallMutableArrayOp = 346
-primOpTag GetSizeofSmallMutableArrayOp = 347
-primOpTag IndexSmallArrayOp = 348
-primOpTag UnsafeFreezeSmallArrayOp = 349
-primOpTag UnsafeThawSmallArrayOp = 350
-primOpTag CopySmallArrayOp = 351
-primOpTag CopySmallMutableArrayOp = 352
-primOpTag CloneSmallArrayOp = 353
-primOpTag CloneSmallMutableArrayOp = 354
-primOpTag FreezeSmallArrayOp = 355
-primOpTag ThawSmallArrayOp = 356
-primOpTag CasSmallArrayOp = 357
-primOpTag NewByteArrayOp_Char = 358
-primOpTag NewPinnedByteArrayOp_Char = 359
-primOpTag NewAlignedPinnedByteArrayOp_Char = 360
-primOpTag MutableByteArrayIsPinnedOp = 361
-primOpTag ByteArrayIsPinnedOp = 362
-primOpTag ByteArrayContents_Char = 363
-primOpTag MutableByteArrayContents_Char = 364
-primOpTag ShrinkMutableByteArrayOp_Char = 365
-primOpTag ResizeMutableByteArrayOp_Char = 366
-primOpTag UnsafeFreezeByteArrayOp = 367
-primOpTag SizeofByteArrayOp = 368
-primOpTag SizeofMutableByteArrayOp = 369
-primOpTag GetSizeofMutableByteArrayOp = 370
-primOpTag IndexByteArrayOp_Char = 371
-primOpTag IndexByteArrayOp_WideChar = 372
-primOpTag IndexByteArrayOp_Int = 373
-primOpTag IndexByteArrayOp_Word = 374
-primOpTag IndexByteArrayOp_Addr = 375
-primOpTag IndexByteArrayOp_Float = 376
-primOpTag IndexByteArrayOp_Double = 377
-primOpTag IndexByteArrayOp_StablePtr = 378
-primOpTag IndexByteArrayOp_Int8 = 379
-primOpTag IndexByteArrayOp_Int16 = 380
-primOpTag IndexByteArrayOp_Int32 = 381
-primOpTag IndexByteArrayOp_Int64 = 382
-primOpTag IndexByteArrayOp_Word8 = 383
-primOpTag IndexByteArrayOp_Word16 = 384
-primOpTag IndexByteArrayOp_Word32 = 385
-primOpTag IndexByteArrayOp_Word64 = 386
-primOpTag IndexByteArrayOp_Word8AsChar = 387
-primOpTag IndexByteArrayOp_Word8AsWideChar = 388
-primOpTag IndexByteArrayOp_Word8AsInt = 389
-primOpTag IndexByteArrayOp_Word8AsWord = 390
-primOpTag IndexByteArrayOp_Word8AsAddr = 391
-primOpTag IndexByteArrayOp_Word8AsFloat = 392
-primOpTag IndexByteArrayOp_Word8AsDouble = 393
-primOpTag IndexByteArrayOp_Word8AsStablePtr = 394
-primOpTag IndexByteArrayOp_Word8AsInt16 = 395
-primOpTag IndexByteArrayOp_Word8AsInt32 = 396
-primOpTag IndexByteArrayOp_Word8AsInt64 = 397
-primOpTag IndexByteArrayOp_Word8AsWord16 = 398
-primOpTag IndexByteArrayOp_Word8AsWord32 = 399
-primOpTag IndexByteArrayOp_Word8AsWord64 = 400
-primOpTag ReadByteArrayOp_Char = 401
-primOpTag ReadByteArrayOp_WideChar = 402
-primOpTag ReadByteArrayOp_Int = 403
-primOpTag ReadByteArrayOp_Word = 404
-primOpTag ReadByteArrayOp_Addr = 405
-primOpTag ReadByteArrayOp_Float = 406
-primOpTag ReadByteArrayOp_Double = 407
-primOpTag ReadByteArrayOp_StablePtr = 408
-primOpTag ReadByteArrayOp_Int8 = 409
-primOpTag ReadByteArrayOp_Int16 = 410
-primOpTag ReadByteArrayOp_Int32 = 411
-primOpTag ReadByteArrayOp_Int64 = 412
-primOpTag ReadByteArrayOp_Word8 = 413
-primOpTag ReadByteArrayOp_Word16 = 414
-primOpTag ReadByteArrayOp_Word32 = 415
-primOpTag ReadByteArrayOp_Word64 = 416
-primOpTag ReadByteArrayOp_Word8AsChar = 417
-primOpTag ReadByteArrayOp_Word8AsWideChar = 418
-primOpTag ReadByteArrayOp_Word8AsInt = 419
-primOpTag ReadByteArrayOp_Word8AsWord = 420
-primOpTag ReadByteArrayOp_Word8AsAddr = 421
-primOpTag ReadByteArrayOp_Word8AsFloat = 422
-primOpTag ReadByteArrayOp_Word8AsDouble = 423
-primOpTag ReadByteArrayOp_Word8AsStablePtr = 424
-primOpTag ReadByteArrayOp_Word8AsInt16 = 425
-primOpTag ReadByteArrayOp_Word8AsInt32 = 426
-primOpTag ReadByteArrayOp_Word8AsInt64 = 427
-primOpTag ReadByteArrayOp_Word8AsWord16 = 428
-primOpTag ReadByteArrayOp_Word8AsWord32 = 429
-primOpTag ReadByteArrayOp_Word8AsWord64 = 430
-primOpTag WriteByteArrayOp_Char = 431
-primOpTag WriteByteArrayOp_WideChar = 432
-primOpTag WriteByteArrayOp_Int = 433
-primOpTag WriteByteArrayOp_Word = 434
-primOpTag WriteByteArrayOp_Addr = 435
-primOpTag WriteByteArrayOp_Float = 436
-primOpTag WriteByteArrayOp_Double = 437
-primOpTag WriteByteArrayOp_StablePtr = 438
-primOpTag WriteByteArrayOp_Int8 = 439
-primOpTag WriteByteArrayOp_Int16 = 440
-primOpTag WriteByteArrayOp_Int32 = 441
-primOpTag WriteByteArrayOp_Int64 = 442
-primOpTag WriteByteArrayOp_Word8 = 443
-primOpTag WriteByteArrayOp_Word16 = 444
-primOpTag WriteByteArrayOp_Word32 = 445
-primOpTag WriteByteArrayOp_Word64 = 446
-primOpTag WriteByteArrayOp_Word8AsChar = 447
-primOpTag WriteByteArrayOp_Word8AsWideChar = 448
-primOpTag WriteByteArrayOp_Word8AsInt = 449
-primOpTag WriteByteArrayOp_Word8AsWord = 450
-primOpTag WriteByteArrayOp_Word8AsAddr = 451
-primOpTag WriteByteArrayOp_Word8AsFloat = 452
-primOpTag WriteByteArrayOp_Word8AsDouble = 453
-primOpTag WriteByteArrayOp_Word8AsStablePtr = 454
-primOpTag WriteByteArrayOp_Word8AsInt16 = 455
-primOpTag WriteByteArrayOp_Word8AsInt32 = 456
-primOpTag WriteByteArrayOp_Word8AsInt64 = 457
-primOpTag WriteByteArrayOp_Word8AsWord16 = 458
-primOpTag WriteByteArrayOp_Word8AsWord32 = 459
-primOpTag WriteByteArrayOp_Word8AsWord64 = 460
-primOpTag CompareByteArraysOp = 461
-primOpTag CopyByteArrayOp = 462
-primOpTag CopyMutableByteArrayOp = 463
-primOpTag CopyByteArrayToAddrOp = 464
-primOpTag CopyMutableByteArrayToAddrOp = 465
-primOpTag CopyAddrToByteArrayOp = 466
-primOpTag SetByteArrayOp = 467
-primOpTag AtomicReadByteArrayOp_Int = 468
-primOpTag AtomicWriteByteArrayOp_Int = 469
-primOpTag CasByteArrayOp_Int = 470
-primOpTag CasByteArrayOp_Int8 = 471
-primOpTag CasByteArrayOp_Int16 = 472
-primOpTag CasByteArrayOp_Int32 = 473
-primOpTag CasByteArrayOp_Int64 = 474
-primOpTag FetchAddByteArrayOp_Int = 475
-primOpTag FetchSubByteArrayOp_Int = 476
-primOpTag FetchAndByteArrayOp_Int = 477
-primOpTag FetchNandByteArrayOp_Int = 478
-primOpTag FetchOrByteArrayOp_Int = 479
-primOpTag FetchXorByteArrayOp_Int = 480
-primOpTag AddrAddOp = 481
-primOpTag AddrSubOp = 482
-primOpTag AddrRemOp = 483
-primOpTag AddrToIntOp = 484
-primOpTag IntToAddrOp = 485
-primOpTag AddrGtOp = 486
-primOpTag AddrGeOp = 487
-primOpTag AddrEqOp = 488
-primOpTag AddrNeOp = 489
-primOpTag AddrLtOp = 490
-primOpTag AddrLeOp = 491
-primOpTag IndexOffAddrOp_Char = 492
-primOpTag IndexOffAddrOp_WideChar = 493
-primOpTag IndexOffAddrOp_Int = 494
-primOpTag IndexOffAddrOp_Word = 495
-primOpTag IndexOffAddrOp_Addr = 496
-primOpTag IndexOffAddrOp_Float = 497
-primOpTag IndexOffAddrOp_Double = 498
-primOpTag IndexOffAddrOp_StablePtr = 499
-primOpTag IndexOffAddrOp_Int8 = 500
-primOpTag IndexOffAddrOp_Int16 = 501
-primOpTag IndexOffAddrOp_Int32 = 502
-primOpTag IndexOffAddrOp_Int64 = 503
-primOpTag IndexOffAddrOp_Word8 = 504
-primOpTag IndexOffAddrOp_Word16 = 505
-primOpTag IndexOffAddrOp_Word32 = 506
-primOpTag IndexOffAddrOp_Word64 = 507
-primOpTag ReadOffAddrOp_Char = 508
-primOpTag ReadOffAddrOp_WideChar = 509
-primOpTag ReadOffAddrOp_Int = 510
-primOpTag ReadOffAddrOp_Word = 511
-primOpTag ReadOffAddrOp_Addr = 512
-primOpTag ReadOffAddrOp_Float = 513
-primOpTag ReadOffAddrOp_Double = 514
-primOpTag ReadOffAddrOp_StablePtr = 515
-primOpTag ReadOffAddrOp_Int8 = 516
-primOpTag ReadOffAddrOp_Int16 = 517
-primOpTag ReadOffAddrOp_Int32 = 518
-primOpTag ReadOffAddrOp_Int64 = 519
-primOpTag ReadOffAddrOp_Word8 = 520
-primOpTag ReadOffAddrOp_Word16 = 521
-primOpTag ReadOffAddrOp_Word32 = 522
-primOpTag ReadOffAddrOp_Word64 = 523
-primOpTag WriteOffAddrOp_Char = 524
-primOpTag WriteOffAddrOp_WideChar = 525
-primOpTag WriteOffAddrOp_Int = 526
-primOpTag WriteOffAddrOp_Word = 527
-primOpTag WriteOffAddrOp_Addr = 528
-primOpTag WriteOffAddrOp_Float = 529
-primOpTag WriteOffAddrOp_Double = 530
-primOpTag WriteOffAddrOp_StablePtr = 531
-primOpTag WriteOffAddrOp_Int8 = 532
-primOpTag WriteOffAddrOp_Int16 = 533
-primOpTag WriteOffAddrOp_Int32 = 534
-primOpTag WriteOffAddrOp_Int64 = 535
-primOpTag WriteOffAddrOp_Word8 = 536
-primOpTag WriteOffAddrOp_Word16 = 537
-primOpTag WriteOffAddrOp_Word32 = 538
-primOpTag WriteOffAddrOp_Word64 = 539
-primOpTag InterlockedExchange_Addr = 540
-primOpTag InterlockedExchange_Word = 541
-primOpTag CasAddrOp_Addr = 542
-primOpTag CasAddrOp_Word = 543
-primOpTag CasAddrOp_Word8 = 544
-primOpTag CasAddrOp_Word16 = 545
-primOpTag CasAddrOp_Word32 = 546
-primOpTag CasAddrOp_Word64 = 547
-primOpTag FetchAddAddrOp_Word = 548
-primOpTag FetchSubAddrOp_Word = 549
-primOpTag FetchAndAddrOp_Word = 550
-primOpTag FetchNandAddrOp_Word = 551
-primOpTag FetchOrAddrOp_Word = 552
-primOpTag FetchXorAddrOp_Word = 553
-primOpTag AtomicReadAddrOp_Word = 554
-primOpTag AtomicWriteAddrOp_Word = 555
-primOpTag NewMutVarOp = 556
-primOpTag ReadMutVarOp = 557
-primOpTag WriteMutVarOp = 558
-primOpTag AtomicModifyMutVar2Op = 559
-primOpTag AtomicModifyMutVar_Op = 560
-primOpTag CasMutVarOp = 561
-primOpTag CatchOp = 562
-primOpTag RaiseOp = 563
-primOpTag RaiseUnderflowOp = 564
-primOpTag RaiseOverflowOp = 565
-primOpTag RaiseDivZeroOp = 566
-primOpTag RaiseIOOp = 567
-primOpTag MaskAsyncExceptionsOp = 568
-primOpTag MaskUninterruptibleOp = 569
-primOpTag UnmaskAsyncExceptionsOp = 570
-primOpTag MaskStatus = 571
-primOpTag NewPromptTagOp = 572
-primOpTag PromptOp = 573
-primOpTag Control0Op = 574
-primOpTag AtomicallyOp = 575
-primOpTag RetryOp = 576
-primOpTag CatchRetryOp = 577
-primOpTag CatchSTMOp = 578
-primOpTag NewTVarOp = 579
-primOpTag ReadTVarOp = 580
-primOpTag ReadTVarIOOp = 581
-primOpTag WriteTVarOp = 582
-primOpTag NewMVarOp = 583
-primOpTag TakeMVarOp = 584
-primOpTag TryTakeMVarOp = 585
-primOpTag PutMVarOp = 586
-primOpTag TryPutMVarOp = 587
-primOpTag ReadMVarOp = 588
-primOpTag TryReadMVarOp = 589
-primOpTag IsEmptyMVarOp = 590
-primOpTag NewIOPortOp = 591
-primOpTag ReadIOPortOp = 592
-primOpTag WriteIOPortOp = 593
-primOpTag DelayOp = 594
-primOpTag WaitReadOp = 595
-primOpTag WaitWriteOp = 596
-primOpTag ForkOp = 597
-primOpTag ForkOnOp = 598
-primOpTag KillThreadOp = 599
-primOpTag YieldOp = 600
-primOpTag MyThreadIdOp = 601
-primOpTag LabelThreadOp = 602
-primOpTag IsCurrentThreadBoundOp = 603
-primOpTag NoDuplicateOp = 604
-primOpTag GetThreadLabelOp = 605
-primOpTag ThreadStatusOp = 606
-primOpTag ListThreadsOp = 607
-primOpTag MkWeakOp = 608
-primOpTag MkWeakNoFinalizerOp = 609
-primOpTag AddCFinalizerToWeakOp = 610
-primOpTag DeRefWeakOp = 611
-primOpTag FinalizeWeakOp = 612
-primOpTag TouchOp = 613
-primOpTag MakeStablePtrOp = 614
-primOpTag DeRefStablePtrOp = 615
-primOpTag EqStablePtrOp = 616
-primOpTag MakeStableNameOp = 617
-primOpTag StableNameToIntOp = 618
-primOpTag CompactNewOp = 619
-primOpTag CompactResizeOp = 620
-primOpTag CompactContainsOp = 621
-primOpTag CompactContainsAnyOp = 622
-primOpTag CompactGetFirstBlockOp = 623
-primOpTag CompactGetNextBlockOp = 624
-primOpTag CompactAllocateBlockOp = 625
-primOpTag CompactFixupPointersOp = 626
-primOpTag CompactAdd = 627
-primOpTag CompactAddWithSharing = 628
-primOpTag CompactSize = 629
-primOpTag ReallyUnsafePtrEqualityOp = 630
-primOpTag ParOp = 631
-primOpTag SparkOp = 632
-primOpTag SeqOp = 633
-primOpTag GetSparkOp = 634
-primOpTag NumSparks = 635
-primOpTag KeepAliveOp = 636
-primOpTag DataToTagOp = 637
-primOpTag TagToEnumOp = 638
-primOpTag AddrToAnyOp = 639
-primOpTag AnyToAddrOp = 640
-primOpTag MkApUpd0_Op = 641
-primOpTag NewBCOOp = 642
-primOpTag UnpackClosureOp = 643
-primOpTag ClosureSizeOp = 644
-primOpTag GetApStackValOp = 645
-primOpTag GetCCSOfOp = 646
-primOpTag GetCurrentCCSOp = 647
-primOpTag ClearCCSOp = 648
-primOpTag WhereFromOp = 649
-primOpTag TraceEventOp = 650
-primOpTag TraceEventBinaryOp = 651
-primOpTag TraceMarkerOp = 652
-primOpTag SetThreadAllocationCounter = 653
-primOpTag (VecBroadcastOp IntVec 16 W8) = 654
-primOpTag (VecBroadcastOp IntVec 8 W16) = 655
-primOpTag (VecBroadcastOp IntVec 4 W32) = 656
-primOpTag (VecBroadcastOp IntVec 2 W64) = 657
-primOpTag (VecBroadcastOp IntVec 32 W8) = 658
-primOpTag (VecBroadcastOp IntVec 16 W16) = 659
-primOpTag (VecBroadcastOp IntVec 8 W32) = 660
-primOpTag (VecBroadcastOp IntVec 4 W64) = 661
-primOpTag (VecBroadcastOp IntVec 64 W8) = 662
-primOpTag (VecBroadcastOp IntVec 32 W16) = 663
-primOpTag (VecBroadcastOp IntVec 16 W32) = 664
-primOpTag (VecBroadcastOp IntVec 8 W64) = 665
-primOpTag (VecBroadcastOp WordVec 16 W8) = 666
-primOpTag (VecBroadcastOp WordVec 8 W16) = 667
-primOpTag (VecBroadcastOp WordVec 4 W32) = 668
-primOpTag (VecBroadcastOp WordVec 2 W64) = 669
-primOpTag (VecBroadcastOp WordVec 32 W8) = 670
-primOpTag (VecBroadcastOp WordVec 16 W16) = 671
-primOpTag (VecBroadcastOp WordVec 8 W32) = 672
-primOpTag (VecBroadcastOp WordVec 4 W64) = 673
-primOpTag (VecBroadcastOp WordVec 64 W8) = 674
-primOpTag (VecBroadcastOp WordVec 32 W16) = 675
-primOpTag (VecBroadcastOp WordVec 16 W32) = 676
-primOpTag (VecBroadcastOp WordVec 8 W64) = 677
-primOpTag (VecBroadcastOp FloatVec 4 W32) = 678
-primOpTag (VecBroadcastOp FloatVec 2 W64) = 679
-primOpTag (VecBroadcastOp FloatVec 8 W32) = 680
-primOpTag (VecBroadcastOp FloatVec 4 W64) = 681
-primOpTag (VecBroadcastOp FloatVec 16 W32) = 682
-primOpTag (VecBroadcastOp FloatVec 8 W64) = 683
-primOpTag (VecPackOp IntVec 16 W8) = 684
-primOpTag (VecPackOp IntVec 8 W16) = 685
-primOpTag (VecPackOp IntVec 4 W32) = 686
-primOpTag (VecPackOp IntVec 2 W64) = 687
-primOpTag (VecPackOp IntVec 32 W8) = 688
-primOpTag (VecPackOp IntVec 16 W16) = 689
-primOpTag (VecPackOp IntVec 8 W32) = 690
-primOpTag (VecPackOp IntVec 4 W64) = 691
-primOpTag (VecPackOp IntVec 64 W8) = 692
-primOpTag (VecPackOp IntVec 32 W16) = 693
-primOpTag (VecPackOp IntVec 16 W32) = 694
-primOpTag (VecPackOp IntVec 8 W64) = 695
-primOpTag (VecPackOp WordVec 16 W8) = 696
-primOpTag (VecPackOp WordVec 8 W16) = 697
-primOpTag (VecPackOp WordVec 4 W32) = 698
-primOpTag (VecPackOp WordVec 2 W64) = 699
-primOpTag (VecPackOp WordVec 32 W8) = 700
-primOpTag (VecPackOp WordVec 16 W16) = 701
-primOpTag (VecPackOp WordVec 8 W32) = 702
-primOpTag (VecPackOp WordVec 4 W64) = 703
-primOpTag (VecPackOp WordVec 64 W8) = 704
-primOpTag (VecPackOp WordVec 32 W16) = 705
-primOpTag (VecPackOp WordVec 16 W32) = 706
-primOpTag (VecPackOp WordVec 8 W64) = 707
-primOpTag (VecPackOp FloatVec 4 W32) = 708
-primOpTag (VecPackOp FloatVec 2 W64) = 709
-primOpTag (VecPackOp FloatVec 8 W32) = 710
-primOpTag (VecPackOp FloatVec 4 W64) = 711
-primOpTag (VecPackOp FloatVec 16 W32) = 712
-primOpTag (VecPackOp FloatVec 8 W64) = 713
-primOpTag (VecUnpackOp IntVec 16 W8) = 714
-primOpTag (VecUnpackOp IntVec 8 W16) = 715
-primOpTag (VecUnpackOp IntVec 4 W32) = 716
-primOpTag (VecUnpackOp IntVec 2 W64) = 717
-primOpTag (VecUnpackOp IntVec 32 W8) = 718
-primOpTag (VecUnpackOp IntVec 16 W16) = 719
-primOpTag (VecUnpackOp IntVec 8 W32) = 720
-primOpTag (VecUnpackOp IntVec 4 W64) = 721
-primOpTag (VecUnpackOp IntVec 64 W8) = 722
-primOpTag (VecUnpackOp IntVec 32 W16) = 723
-primOpTag (VecUnpackOp IntVec 16 W32) = 724
-primOpTag (VecUnpackOp IntVec 8 W64) = 725
-primOpTag (VecUnpackOp WordVec 16 W8) = 726
-primOpTag (VecUnpackOp WordVec 8 W16) = 727
-primOpTag (VecUnpackOp WordVec 4 W32) = 728
-primOpTag (VecUnpackOp WordVec 2 W64) = 729
-primOpTag (VecUnpackOp WordVec 32 W8) = 730
-primOpTag (VecUnpackOp WordVec 16 W16) = 731
-primOpTag (VecUnpackOp WordVec 8 W32) = 732
-primOpTag (VecUnpackOp WordVec 4 W64) = 733
-primOpTag (VecUnpackOp WordVec 64 W8) = 734
-primOpTag (VecUnpackOp WordVec 32 W16) = 735
-primOpTag (VecUnpackOp WordVec 16 W32) = 736
-primOpTag (VecUnpackOp WordVec 8 W64) = 737
-primOpTag (VecUnpackOp FloatVec 4 W32) = 738
-primOpTag (VecUnpackOp FloatVec 2 W64) = 739
-primOpTag (VecUnpackOp FloatVec 8 W32) = 740
-primOpTag (VecUnpackOp FloatVec 4 W64) = 741
-primOpTag (VecUnpackOp FloatVec 16 W32) = 742
-primOpTag (VecUnpackOp FloatVec 8 W64) = 743
-primOpTag (VecInsertOp IntVec 16 W8) = 744
-primOpTag (VecInsertOp IntVec 8 W16) = 745
-primOpTag (VecInsertOp IntVec 4 W32) = 746
-primOpTag (VecInsertOp IntVec 2 W64) = 747
-primOpTag (VecInsertOp IntVec 32 W8) = 748
-primOpTag (VecInsertOp IntVec 16 W16) = 749
-primOpTag (VecInsertOp IntVec 8 W32) = 750
-primOpTag (VecInsertOp IntVec 4 W64) = 751
-primOpTag (VecInsertOp IntVec 64 W8) = 752
-primOpTag (VecInsertOp IntVec 32 W16) = 753
-primOpTag (VecInsertOp IntVec 16 W32) = 754
-primOpTag (VecInsertOp IntVec 8 W64) = 755
-primOpTag (VecInsertOp WordVec 16 W8) = 756
-primOpTag (VecInsertOp WordVec 8 W16) = 757
-primOpTag (VecInsertOp WordVec 4 W32) = 758
-primOpTag (VecInsertOp WordVec 2 W64) = 759
-primOpTag (VecInsertOp WordVec 32 W8) = 760
-primOpTag (VecInsertOp WordVec 16 W16) = 761
-primOpTag (VecInsertOp WordVec 8 W32) = 762
-primOpTag (VecInsertOp WordVec 4 W64) = 763
-primOpTag (VecInsertOp WordVec 64 W8) = 764
-primOpTag (VecInsertOp WordVec 32 W16) = 765
-primOpTag (VecInsertOp WordVec 16 W32) = 766
-primOpTag (VecInsertOp WordVec 8 W64) = 767
-primOpTag (VecInsertOp FloatVec 4 W32) = 768
-primOpTag (VecInsertOp FloatVec 2 W64) = 769
-primOpTag (VecInsertOp FloatVec 8 W32) = 770
-primOpTag (VecInsertOp FloatVec 4 W64) = 771
-primOpTag (VecInsertOp FloatVec 16 W32) = 772
-primOpTag (VecInsertOp FloatVec 8 W64) = 773
-primOpTag (VecAddOp IntVec 16 W8) = 774
-primOpTag (VecAddOp IntVec 8 W16) = 775
-primOpTag (VecAddOp IntVec 4 W32) = 776
-primOpTag (VecAddOp IntVec 2 W64) = 777
-primOpTag (VecAddOp IntVec 32 W8) = 778
-primOpTag (VecAddOp IntVec 16 W16) = 779
-primOpTag (VecAddOp IntVec 8 W32) = 780
-primOpTag (VecAddOp IntVec 4 W64) = 781
-primOpTag (VecAddOp IntVec 64 W8) = 782
-primOpTag (VecAddOp IntVec 32 W16) = 783
-primOpTag (VecAddOp IntVec 16 W32) = 784
-primOpTag (VecAddOp IntVec 8 W64) = 785
-primOpTag (VecAddOp WordVec 16 W8) = 786
-primOpTag (VecAddOp WordVec 8 W16) = 787
-primOpTag (VecAddOp WordVec 4 W32) = 788
-primOpTag (VecAddOp WordVec 2 W64) = 789
-primOpTag (VecAddOp WordVec 32 W8) = 790
-primOpTag (VecAddOp WordVec 16 W16) = 791
-primOpTag (VecAddOp WordVec 8 W32) = 792
-primOpTag (VecAddOp WordVec 4 W64) = 793
-primOpTag (VecAddOp WordVec 64 W8) = 794
-primOpTag (VecAddOp WordVec 32 W16) = 795
-primOpTag (VecAddOp WordVec 16 W32) = 796
-primOpTag (VecAddOp WordVec 8 W64) = 797
-primOpTag (VecAddOp FloatVec 4 W32) = 798
-primOpTag (VecAddOp FloatVec 2 W64) = 799
-primOpTag (VecAddOp FloatVec 8 W32) = 800
-primOpTag (VecAddOp FloatVec 4 W64) = 801
-primOpTag (VecAddOp FloatVec 16 W32) = 802
-primOpTag (VecAddOp FloatVec 8 W64) = 803
-primOpTag (VecSubOp IntVec 16 W8) = 804
-primOpTag (VecSubOp IntVec 8 W16) = 805
-primOpTag (VecSubOp IntVec 4 W32) = 806
-primOpTag (VecSubOp IntVec 2 W64) = 807
-primOpTag (VecSubOp IntVec 32 W8) = 808
-primOpTag (VecSubOp IntVec 16 W16) = 809
-primOpTag (VecSubOp IntVec 8 W32) = 810
-primOpTag (VecSubOp IntVec 4 W64) = 811
-primOpTag (VecSubOp IntVec 64 W8) = 812
-primOpTag (VecSubOp IntVec 32 W16) = 813
-primOpTag (VecSubOp IntVec 16 W32) = 814
-primOpTag (VecSubOp IntVec 8 W64) = 815
-primOpTag (VecSubOp WordVec 16 W8) = 816
-primOpTag (VecSubOp WordVec 8 W16) = 817
-primOpTag (VecSubOp WordVec 4 W32) = 818
-primOpTag (VecSubOp WordVec 2 W64) = 819
-primOpTag (VecSubOp WordVec 32 W8) = 820
-primOpTag (VecSubOp WordVec 16 W16) = 821
-primOpTag (VecSubOp WordVec 8 W32) = 822
-primOpTag (VecSubOp WordVec 4 W64) = 823
-primOpTag (VecSubOp WordVec 64 W8) = 824
-primOpTag (VecSubOp WordVec 32 W16) = 825
-primOpTag (VecSubOp WordVec 16 W32) = 826
-primOpTag (VecSubOp WordVec 8 W64) = 827
-primOpTag (VecSubOp FloatVec 4 W32) = 828
-primOpTag (VecSubOp FloatVec 2 W64) = 829
-primOpTag (VecSubOp FloatVec 8 W32) = 830
-primOpTag (VecSubOp FloatVec 4 W64) = 831
-primOpTag (VecSubOp FloatVec 16 W32) = 832
-primOpTag (VecSubOp FloatVec 8 W64) = 833
-primOpTag (VecMulOp IntVec 16 W8) = 834
-primOpTag (VecMulOp IntVec 8 W16) = 835
-primOpTag (VecMulOp IntVec 4 W32) = 836
-primOpTag (VecMulOp IntVec 2 W64) = 837
-primOpTag (VecMulOp IntVec 32 W8) = 838
-primOpTag (VecMulOp IntVec 16 W16) = 839
-primOpTag (VecMulOp IntVec 8 W32) = 840
-primOpTag (VecMulOp IntVec 4 W64) = 841
-primOpTag (VecMulOp IntVec 64 W8) = 842
-primOpTag (VecMulOp IntVec 32 W16) = 843
-primOpTag (VecMulOp IntVec 16 W32) = 844
-primOpTag (VecMulOp IntVec 8 W64) = 845
-primOpTag (VecMulOp WordVec 16 W8) = 846
-primOpTag (VecMulOp WordVec 8 W16) = 847
-primOpTag (VecMulOp WordVec 4 W32) = 848
-primOpTag (VecMulOp WordVec 2 W64) = 849
-primOpTag (VecMulOp WordVec 32 W8) = 850
-primOpTag (VecMulOp WordVec 16 W16) = 851
-primOpTag (VecMulOp WordVec 8 W32) = 852
-primOpTag (VecMulOp WordVec 4 W64) = 853
-primOpTag (VecMulOp WordVec 64 W8) = 854
-primOpTag (VecMulOp WordVec 32 W16) = 855
-primOpTag (VecMulOp WordVec 16 W32) = 856
-primOpTag (VecMulOp WordVec 8 W64) = 857
-primOpTag (VecMulOp FloatVec 4 W32) = 858
-primOpTag (VecMulOp FloatVec 2 W64) = 859
-primOpTag (VecMulOp FloatVec 8 W32) = 860
-primOpTag (VecMulOp FloatVec 4 W64) = 861
-primOpTag (VecMulOp FloatVec 16 W32) = 862
-primOpTag (VecMulOp FloatVec 8 W64) = 863
-primOpTag (VecDivOp FloatVec 4 W32) = 864
-primOpTag (VecDivOp FloatVec 2 W64) = 865
-primOpTag (VecDivOp FloatVec 8 W32) = 866
-primOpTag (VecDivOp FloatVec 4 W64) = 867
-primOpTag (VecDivOp FloatVec 16 W32) = 868
-primOpTag (VecDivOp FloatVec 8 W64) = 869
-primOpTag (VecQuotOp IntVec 16 W8) = 870
-primOpTag (VecQuotOp IntVec 8 W16) = 871
-primOpTag (VecQuotOp IntVec 4 W32) = 872
-primOpTag (VecQuotOp IntVec 2 W64) = 873
-primOpTag (VecQuotOp IntVec 32 W8) = 874
-primOpTag (VecQuotOp IntVec 16 W16) = 875
-primOpTag (VecQuotOp IntVec 8 W32) = 876
-primOpTag (VecQuotOp IntVec 4 W64) = 877
-primOpTag (VecQuotOp IntVec 64 W8) = 878
-primOpTag (VecQuotOp IntVec 32 W16) = 879
-primOpTag (VecQuotOp IntVec 16 W32) = 880
-primOpTag (VecQuotOp IntVec 8 W64) = 881
-primOpTag (VecQuotOp WordVec 16 W8) = 882
-primOpTag (VecQuotOp WordVec 8 W16) = 883
-primOpTag (VecQuotOp WordVec 4 W32) = 884
-primOpTag (VecQuotOp WordVec 2 W64) = 885
-primOpTag (VecQuotOp WordVec 32 W8) = 886
-primOpTag (VecQuotOp WordVec 16 W16) = 887
-primOpTag (VecQuotOp WordVec 8 W32) = 888
-primOpTag (VecQuotOp WordVec 4 W64) = 889
-primOpTag (VecQuotOp WordVec 64 W8) = 890
-primOpTag (VecQuotOp WordVec 32 W16) = 891
-primOpTag (VecQuotOp WordVec 16 W32) = 892
-primOpTag (VecQuotOp WordVec 8 W64) = 893
-primOpTag (VecRemOp IntVec 16 W8) = 894
-primOpTag (VecRemOp IntVec 8 W16) = 895
-primOpTag (VecRemOp IntVec 4 W32) = 896
-primOpTag (VecRemOp IntVec 2 W64) = 897
-primOpTag (VecRemOp IntVec 32 W8) = 898
-primOpTag (VecRemOp IntVec 16 W16) = 899
-primOpTag (VecRemOp IntVec 8 W32) = 900
-primOpTag (VecRemOp IntVec 4 W64) = 901
-primOpTag (VecRemOp IntVec 64 W8) = 902
-primOpTag (VecRemOp IntVec 32 W16) = 903
-primOpTag (VecRemOp IntVec 16 W32) = 904
-primOpTag (VecRemOp IntVec 8 W64) = 905
-primOpTag (VecRemOp WordVec 16 W8) = 906
-primOpTag (VecRemOp WordVec 8 W16) = 907
-primOpTag (VecRemOp WordVec 4 W32) = 908
-primOpTag (VecRemOp WordVec 2 W64) = 909
-primOpTag (VecRemOp WordVec 32 W8) = 910
-primOpTag (VecRemOp WordVec 16 W16) = 911
-primOpTag (VecRemOp WordVec 8 W32) = 912
-primOpTag (VecRemOp WordVec 4 W64) = 913
-primOpTag (VecRemOp WordVec 64 W8) = 914
-primOpTag (VecRemOp WordVec 32 W16) = 915
-primOpTag (VecRemOp WordVec 16 W32) = 916
-primOpTag (VecRemOp WordVec 8 W64) = 917
-primOpTag (VecNegOp IntVec 16 W8) = 918
-primOpTag (VecNegOp IntVec 8 W16) = 919
-primOpTag (VecNegOp IntVec 4 W32) = 920
-primOpTag (VecNegOp IntVec 2 W64) = 921
-primOpTag (VecNegOp IntVec 32 W8) = 922
-primOpTag (VecNegOp IntVec 16 W16) = 923
-primOpTag (VecNegOp IntVec 8 W32) = 924
-primOpTag (VecNegOp IntVec 4 W64) = 925
-primOpTag (VecNegOp IntVec 64 W8) = 926
-primOpTag (VecNegOp IntVec 32 W16) = 927
-primOpTag (VecNegOp IntVec 16 W32) = 928
-primOpTag (VecNegOp IntVec 8 W64) = 929
-primOpTag (VecNegOp FloatVec 4 W32) = 930
-primOpTag (VecNegOp FloatVec 2 W64) = 931
-primOpTag (VecNegOp FloatVec 8 W32) = 932
-primOpTag (VecNegOp FloatVec 4 W64) = 933
-primOpTag (VecNegOp FloatVec 16 W32) = 934
-primOpTag (VecNegOp FloatVec 8 W64) = 935
-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 936
-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 937
-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 938
-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 939
-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 940
-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 941
-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 942
-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 943
-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 944
-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 945
-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 946
-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 947
-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 948
-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 949
-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 950
-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 951
-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 952
-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 953
-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 954
-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 955
-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 956
-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 957
-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 958
-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 959
-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 960
-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 961
-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 962
-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 963
-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 964
-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 965
-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 966
-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 967
-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 968
-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 969
-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 970
-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 971
-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 972
-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 973
-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 974
-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 975
-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 976
-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 977
-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 978
-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 979
-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 980
-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 981
-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 982
-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 983
-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 984
-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 985
-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 986
-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 987
-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 988
-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 989
-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 990
-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 991
-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 992
-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 993
-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 994
-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 995
-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 996
-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 997
-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 998
-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 999
-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 1000
-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 1001
-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 1002
-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 1003
-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 1004
-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 1005
-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 1006
-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 1007
-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1008
-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1009
-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1010
-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1011
-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1012
-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1013
-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1014
-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1015
-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1016
-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1017
-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1018
-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1019
-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1020
-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1021
-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1022
-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1023
-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1024
-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1025
-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1026
-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1027
-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1028
-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1029
-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1030
-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1031
-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1032
-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1033
-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1034
-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1035
-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1036
-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1037
-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1038
-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1039
-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1040
-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1041
-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1042
-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1043
-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1044
-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1045
-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1046
-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1047
-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1048
-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1049
-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1050
-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1051
-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1052
-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1053
-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1054
-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1055
-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1056
-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1057
-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1058
-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1059
-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1060
-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1061
-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1062
-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1063
-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1064
-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1065
-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1066
-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1067
-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1068
-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1069
-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1070
-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1071
-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1072
-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1073
-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1074
-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1075
-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1076
-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1077
-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1078
-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1079
-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1080
-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1081
-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1082
-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1083
-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1084
-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1085
-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1086
-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1087
-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1088
-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1089
-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1090
-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1091
-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1092
-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1093
-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1094
-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1095
-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1096
-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1097
-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1098
-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1099
-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1100
-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1101
-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1102
-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1103
-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1104
-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1105
-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1106
-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1107
-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1108
-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1109
-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1110
-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1111
-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1112
-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1113
-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1114
-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1115
-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1116
-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1117
-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1118
-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1119
-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1120
-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1121
-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1122
-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1123
-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1124
-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1125
-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1126
-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1127
-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1128
-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1129
-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1130
-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1131
-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1132
-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1133
-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1134
-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1135
-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1136
-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1137
-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1138
-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1139
-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1140
-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1141
-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1142
-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1143
-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1144
-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1145
-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1146
-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1147
-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1148
-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1149
-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1150
-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1151
-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1152
-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1153
-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1154
-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1155
-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1156
-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1157
-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1158
-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1159
-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1160
-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1161
-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1162
-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1163
-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1164
-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1165
-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1166
-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1167
-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1168
-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1169
-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1170
-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1171
-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1172
-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1173
-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1174
-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1175
-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1176
-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1177
-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1178
-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1179
-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1180
-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1181
-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1182
-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1183
-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1184
-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1185
-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1186
-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1187
-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1188
-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1189
-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1190
-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1191
-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1192
-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1193
-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1194
-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1195
-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1196
-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1197
-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1198
-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1199
-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1200
-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1201
-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1202
-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1203
-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1204
-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1205
-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1206
-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1207
-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1208
-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1209
-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1210
-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1211
-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1212
-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1213
-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1214
-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1215
-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1216
-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1217
-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1218
-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1219
-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1220
-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1221
-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1222
-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1223
-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1224
-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1225
-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1226
-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1227
-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1228
-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1229
-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1230
-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1231
-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1232
-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1233
-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1234
-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1235
-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1236
-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1237
-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1238
-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1239
-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1240
-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1241
-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1242
-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1243
-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1244
-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1245
-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1246
-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1247
-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1248
-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1249
-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1250
-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1251
-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1252
-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1253
-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1254
-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1255
-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1256
-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1257
-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1258
-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1259
-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1260
-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1261
-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1262
-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1263
-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1264
-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1265
-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1266
-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1267
-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1268
-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1269
-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1270
-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1271
-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1272
-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1273
-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1274
-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1275
-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1276
-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1277
-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1278
-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1279
-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1280
-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1281
-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1282
-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1283
-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1284
-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1285
-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1286
-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1287
-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1288
-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1289
-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1290
-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1291
-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1292
-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1293
-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1294
-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1295
-primOpTag PrefetchByteArrayOp3 = 1296
-primOpTag PrefetchMutableByteArrayOp3 = 1297
-primOpTag PrefetchAddrOp3 = 1298
-primOpTag PrefetchValueOp3 = 1299
-primOpTag PrefetchByteArrayOp2 = 1300
-primOpTag PrefetchMutableByteArrayOp2 = 1301
-primOpTag PrefetchAddrOp2 = 1302
-primOpTag PrefetchValueOp2 = 1303
-primOpTag PrefetchByteArrayOp1 = 1304
-primOpTag PrefetchMutableByteArrayOp1 = 1305
-primOpTag PrefetchAddrOp1 = 1306
-primOpTag PrefetchValueOp1 = 1307
-primOpTag PrefetchByteArrayOp0 = 1308
-primOpTag PrefetchMutableByteArrayOp0 = 1309
-primOpTag PrefetchAddrOp0 = 1310
-primOpTag PrefetchValueOp0 = 1311
diff --git a/ghc-lib/stage0/compiler/build/primop-vector-tycons.hs-incl b/ghc-lib/stage0/compiler/build/primop-vector-tycons.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-vector-tycons.hs-incl
+++ /dev/null
@@ -1,30 +0,0 @@
-    , int8X16PrimTyCon
-    , int16X8PrimTyCon
-    , int32X4PrimTyCon
-    , int64X2PrimTyCon
-    , int8X32PrimTyCon
-    , int16X16PrimTyCon
-    , int32X8PrimTyCon
-    , int64X4PrimTyCon
-    , int8X64PrimTyCon
-    , int16X32PrimTyCon
-    , int32X16PrimTyCon
-    , int64X8PrimTyCon
-    , word8X16PrimTyCon
-    , word16X8PrimTyCon
-    , word32X4PrimTyCon
-    , word64X2PrimTyCon
-    , word8X32PrimTyCon
-    , word16X16PrimTyCon
-    , word32X8PrimTyCon
-    , word64X4PrimTyCon
-    , word8X64PrimTyCon
-    , word16X32PrimTyCon
-    , word32X16PrimTyCon
-    , word64X8PrimTyCon
-    , floatX4PrimTyCon
-    , doubleX2PrimTyCon
-    , floatX8PrimTyCon
-    , doubleX4PrimTyCon
-    , floatX16PrimTyCon
-    , doubleX8PrimTyCon
diff --git a/ghc-lib/stage0/compiler/build/primop-vector-tys-exports.hs-incl b/ghc-lib/stage0/compiler/build/primop-vector-tys-exports.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-vector-tys-exports.hs-incl
+++ /dev/null
@@ -1,30 +0,0 @@
-        int8X16PrimTy, int8X16PrimTyCon,
-        int16X8PrimTy, int16X8PrimTyCon,
-        int32X4PrimTy, int32X4PrimTyCon,
-        int64X2PrimTy, int64X2PrimTyCon,
-        int8X32PrimTy, int8X32PrimTyCon,
-        int16X16PrimTy, int16X16PrimTyCon,
-        int32X8PrimTy, int32X8PrimTyCon,
-        int64X4PrimTy, int64X4PrimTyCon,
-        int8X64PrimTy, int8X64PrimTyCon,
-        int16X32PrimTy, int16X32PrimTyCon,
-        int32X16PrimTy, int32X16PrimTyCon,
-        int64X8PrimTy, int64X8PrimTyCon,
-        word8X16PrimTy, word8X16PrimTyCon,
-        word16X8PrimTy, word16X8PrimTyCon,
-        word32X4PrimTy, word32X4PrimTyCon,
-        word64X2PrimTy, word64X2PrimTyCon,
-        word8X32PrimTy, word8X32PrimTyCon,
-        word16X16PrimTy, word16X16PrimTyCon,
-        word32X8PrimTy, word32X8PrimTyCon,
-        word64X4PrimTy, word64X4PrimTyCon,
-        word8X64PrimTy, word8X64PrimTyCon,
-        word16X32PrimTy, word16X32PrimTyCon,
-        word32X16PrimTy, word32X16PrimTyCon,
-        word64X8PrimTy, word64X8PrimTyCon,
-        floatX4PrimTy, floatX4PrimTyCon,
-        doubleX2PrimTy, doubleX2PrimTyCon,
-        floatX8PrimTy, floatX8PrimTyCon,
-        doubleX4PrimTy, doubleX4PrimTyCon,
-        floatX16PrimTy, floatX16PrimTyCon,
-        doubleX8PrimTy, doubleX8PrimTyCon,
diff --git a/ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl b/ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl
+++ /dev/null
@@ -1,180 +0,0 @@
-int8X16PrimTyConName :: Name
-int8X16PrimTyConName = mkPrimTc (fsLit "Int8X16#") int8X16PrimTyConKey int8X16PrimTyCon
-int8X16PrimTy :: Type
-int8X16PrimTy = mkTyConTy int8X16PrimTyCon
-int8X16PrimTyCon :: TyCon
-int8X16PrimTyCon = pcPrimTyCon0 int8X16PrimTyConName (TyConApp vecRepDataConTyCon [vec16DataConTy, int8ElemRepDataConTy])
-int16X8PrimTyConName :: Name
-int16X8PrimTyConName = mkPrimTc (fsLit "Int16X8#") int16X8PrimTyConKey int16X8PrimTyCon
-int16X8PrimTy :: Type
-int16X8PrimTy = mkTyConTy int16X8PrimTyCon
-int16X8PrimTyCon :: TyCon
-int16X8PrimTyCon = pcPrimTyCon0 int16X8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, int16ElemRepDataConTy])
-int32X4PrimTyConName :: Name
-int32X4PrimTyConName = mkPrimTc (fsLit "Int32X4#") int32X4PrimTyConKey int32X4PrimTyCon
-int32X4PrimTy :: Type
-int32X4PrimTy = mkTyConTy int32X4PrimTyCon
-int32X4PrimTyCon :: TyCon
-int32X4PrimTyCon = pcPrimTyCon0 int32X4PrimTyConName (TyConApp vecRepDataConTyCon [vec4DataConTy, int32ElemRepDataConTy])
-int64X2PrimTyConName :: Name
-int64X2PrimTyConName = mkPrimTc (fsLit "Int64X2#") int64X2PrimTyConKey int64X2PrimTyCon
-int64X2PrimTy :: Type
-int64X2PrimTy = mkTyConTy int64X2PrimTyCon
-int64X2PrimTyCon :: TyCon
-int64X2PrimTyCon = pcPrimTyCon0 int64X2PrimTyConName (TyConApp vecRepDataConTyCon [vec2DataConTy, int64ElemRepDataConTy])
-int8X32PrimTyConName :: Name
-int8X32PrimTyConName = mkPrimTc (fsLit "Int8X32#") int8X32PrimTyConKey int8X32PrimTyCon
-int8X32PrimTy :: Type
-int8X32PrimTy = mkTyConTy int8X32PrimTyCon
-int8X32PrimTyCon :: TyCon
-int8X32PrimTyCon = pcPrimTyCon0 int8X32PrimTyConName (TyConApp vecRepDataConTyCon [vec32DataConTy, int8ElemRepDataConTy])
-int16X16PrimTyConName :: Name
-int16X16PrimTyConName = mkPrimTc (fsLit "Int16X16#") int16X16PrimTyConKey int16X16PrimTyCon
-int16X16PrimTy :: Type
-int16X16PrimTy = mkTyConTy int16X16PrimTyCon
-int16X16PrimTyCon :: TyCon
-int16X16PrimTyCon = pcPrimTyCon0 int16X16PrimTyConName (TyConApp vecRepDataConTyCon [vec16DataConTy, int16ElemRepDataConTy])
-int32X8PrimTyConName :: Name
-int32X8PrimTyConName = mkPrimTc (fsLit "Int32X8#") int32X8PrimTyConKey int32X8PrimTyCon
-int32X8PrimTy :: Type
-int32X8PrimTy = mkTyConTy int32X8PrimTyCon
-int32X8PrimTyCon :: TyCon
-int32X8PrimTyCon = pcPrimTyCon0 int32X8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, int32ElemRepDataConTy])
-int64X4PrimTyConName :: Name
-int64X4PrimTyConName = mkPrimTc (fsLit "Int64X4#") int64X4PrimTyConKey int64X4PrimTyCon
-int64X4PrimTy :: Type
-int64X4PrimTy = mkTyConTy int64X4PrimTyCon
-int64X4PrimTyCon :: TyCon
-int64X4PrimTyCon = pcPrimTyCon0 int64X4PrimTyConName (TyConApp vecRepDataConTyCon [vec4DataConTy, int64ElemRepDataConTy])
-int8X64PrimTyConName :: Name
-int8X64PrimTyConName = mkPrimTc (fsLit "Int8X64#") int8X64PrimTyConKey int8X64PrimTyCon
-int8X64PrimTy :: Type
-int8X64PrimTy = mkTyConTy int8X64PrimTyCon
-int8X64PrimTyCon :: TyCon
-int8X64PrimTyCon = pcPrimTyCon0 int8X64PrimTyConName (TyConApp vecRepDataConTyCon [vec64DataConTy, int8ElemRepDataConTy])
-int16X32PrimTyConName :: Name
-int16X32PrimTyConName = mkPrimTc (fsLit "Int16X32#") int16X32PrimTyConKey int16X32PrimTyCon
-int16X32PrimTy :: Type
-int16X32PrimTy = mkTyConTy int16X32PrimTyCon
-int16X32PrimTyCon :: TyCon
-int16X32PrimTyCon = pcPrimTyCon0 int16X32PrimTyConName (TyConApp vecRepDataConTyCon [vec32DataConTy, int16ElemRepDataConTy])
-int32X16PrimTyConName :: Name
-int32X16PrimTyConName = mkPrimTc (fsLit "Int32X16#") int32X16PrimTyConKey int32X16PrimTyCon
-int32X16PrimTy :: Type
-int32X16PrimTy = mkTyConTy int32X16PrimTyCon
-int32X16PrimTyCon :: TyCon
-int32X16PrimTyCon = pcPrimTyCon0 int32X16PrimTyConName (TyConApp vecRepDataConTyCon [vec16DataConTy, int32ElemRepDataConTy])
-int64X8PrimTyConName :: Name
-int64X8PrimTyConName = mkPrimTc (fsLit "Int64X8#") int64X8PrimTyConKey int64X8PrimTyCon
-int64X8PrimTy :: Type
-int64X8PrimTy = mkTyConTy int64X8PrimTyCon
-int64X8PrimTyCon :: TyCon
-int64X8PrimTyCon = pcPrimTyCon0 int64X8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, int64ElemRepDataConTy])
-word8X16PrimTyConName :: Name
-word8X16PrimTyConName = mkPrimTc (fsLit "Word8X16#") word8X16PrimTyConKey word8X16PrimTyCon
-word8X16PrimTy :: Type
-word8X16PrimTy = mkTyConTy word8X16PrimTyCon
-word8X16PrimTyCon :: TyCon
-word8X16PrimTyCon = pcPrimTyCon0 word8X16PrimTyConName (TyConApp vecRepDataConTyCon [vec16DataConTy, word8ElemRepDataConTy])
-word16X8PrimTyConName :: Name
-word16X8PrimTyConName = mkPrimTc (fsLit "Word16X8#") word16X8PrimTyConKey word16X8PrimTyCon
-word16X8PrimTy :: Type
-word16X8PrimTy = mkTyConTy word16X8PrimTyCon
-word16X8PrimTyCon :: TyCon
-word16X8PrimTyCon = pcPrimTyCon0 word16X8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, word16ElemRepDataConTy])
-word32X4PrimTyConName :: Name
-word32X4PrimTyConName = mkPrimTc (fsLit "Word32X4#") word32X4PrimTyConKey word32X4PrimTyCon
-word32X4PrimTy :: Type
-word32X4PrimTy = mkTyConTy word32X4PrimTyCon
-word32X4PrimTyCon :: TyCon
-word32X4PrimTyCon = pcPrimTyCon0 word32X4PrimTyConName (TyConApp vecRepDataConTyCon [vec4DataConTy, word32ElemRepDataConTy])
-word64X2PrimTyConName :: Name
-word64X2PrimTyConName = mkPrimTc (fsLit "Word64X2#") word64X2PrimTyConKey word64X2PrimTyCon
-word64X2PrimTy :: Type
-word64X2PrimTy = mkTyConTy word64X2PrimTyCon
-word64X2PrimTyCon :: TyCon
-word64X2PrimTyCon = pcPrimTyCon0 word64X2PrimTyConName (TyConApp vecRepDataConTyCon [vec2DataConTy, word64ElemRepDataConTy])
-word8X32PrimTyConName :: Name
-word8X32PrimTyConName = mkPrimTc (fsLit "Word8X32#") word8X32PrimTyConKey word8X32PrimTyCon
-word8X32PrimTy :: Type
-word8X32PrimTy = mkTyConTy word8X32PrimTyCon
-word8X32PrimTyCon :: TyCon
-word8X32PrimTyCon = pcPrimTyCon0 word8X32PrimTyConName (TyConApp vecRepDataConTyCon [vec32DataConTy, word8ElemRepDataConTy])
-word16X16PrimTyConName :: Name
-word16X16PrimTyConName = mkPrimTc (fsLit "Word16X16#") word16X16PrimTyConKey word16X16PrimTyCon
-word16X16PrimTy :: Type
-word16X16PrimTy = mkTyConTy word16X16PrimTyCon
-word16X16PrimTyCon :: TyCon
-word16X16PrimTyCon = pcPrimTyCon0 word16X16PrimTyConName (TyConApp vecRepDataConTyCon [vec16DataConTy, word16ElemRepDataConTy])
-word32X8PrimTyConName :: Name
-word32X8PrimTyConName = mkPrimTc (fsLit "Word32X8#") word32X8PrimTyConKey word32X8PrimTyCon
-word32X8PrimTy :: Type
-word32X8PrimTy = mkTyConTy word32X8PrimTyCon
-word32X8PrimTyCon :: TyCon
-word32X8PrimTyCon = pcPrimTyCon0 word32X8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, word32ElemRepDataConTy])
-word64X4PrimTyConName :: Name
-word64X4PrimTyConName = mkPrimTc (fsLit "Word64X4#") word64X4PrimTyConKey word64X4PrimTyCon
-word64X4PrimTy :: Type
-word64X4PrimTy = mkTyConTy word64X4PrimTyCon
-word64X4PrimTyCon :: TyCon
-word64X4PrimTyCon = pcPrimTyCon0 word64X4PrimTyConName (TyConApp vecRepDataConTyCon [vec4DataConTy, word64ElemRepDataConTy])
-word8X64PrimTyConName :: Name
-word8X64PrimTyConName = mkPrimTc (fsLit "Word8X64#") word8X64PrimTyConKey word8X64PrimTyCon
-word8X64PrimTy :: Type
-word8X64PrimTy = mkTyConTy word8X64PrimTyCon
-word8X64PrimTyCon :: TyCon
-word8X64PrimTyCon = pcPrimTyCon0 word8X64PrimTyConName (TyConApp vecRepDataConTyCon [vec64DataConTy, word8ElemRepDataConTy])
-word16X32PrimTyConName :: Name
-word16X32PrimTyConName = mkPrimTc (fsLit "Word16X32#") word16X32PrimTyConKey word16X32PrimTyCon
-word16X32PrimTy :: Type
-word16X32PrimTy = mkTyConTy word16X32PrimTyCon
-word16X32PrimTyCon :: TyCon
-word16X32PrimTyCon = pcPrimTyCon0 word16X32PrimTyConName (TyConApp vecRepDataConTyCon [vec32DataConTy, word16ElemRepDataConTy])
-word32X16PrimTyConName :: Name
-word32X16PrimTyConName = mkPrimTc (fsLit "Word32X16#") word32X16PrimTyConKey word32X16PrimTyCon
-word32X16PrimTy :: Type
-word32X16PrimTy = mkTyConTy word32X16PrimTyCon
-word32X16PrimTyCon :: TyCon
-word32X16PrimTyCon = pcPrimTyCon0 word32X16PrimTyConName (TyConApp vecRepDataConTyCon [vec16DataConTy, word32ElemRepDataConTy])
-word64X8PrimTyConName :: Name
-word64X8PrimTyConName = mkPrimTc (fsLit "Word64X8#") word64X8PrimTyConKey word64X8PrimTyCon
-word64X8PrimTy :: Type
-word64X8PrimTy = mkTyConTy word64X8PrimTyCon
-word64X8PrimTyCon :: TyCon
-word64X8PrimTyCon = pcPrimTyCon0 word64X8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, word64ElemRepDataConTy])
-floatX4PrimTyConName :: Name
-floatX4PrimTyConName = mkPrimTc (fsLit "FloatX4#") floatX4PrimTyConKey floatX4PrimTyCon
-floatX4PrimTy :: Type
-floatX4PrimTy = mkTyConTy floatX4PrimTyCon
-floatX4PrimTyCon :: TyCon
-floatX4PrimTyCon = pcPrimTyCon0 floatX4PrimTyConName (TyConApp vecRepDataConTyCon [vec4DataConTy, floatElemRepDataConTy])
-doubleX2PrimTyConName :: Name
-doubleX2PrimTyConName = mkPrimTc (fsLit "DoubleX2#") doubleX2PrimTyConKey doubleX2PrimTyCon
-doubleX2PrimTy :: Type
-doubleX2PrimTy = mkTyConTy doubleX2PrimTyCon
-doubleX2PrimTyCon :: TyCon
-doubleX2PrimTyCon = pcPrimTyCon0 doubleX2PrimTyConName (TyConApp vecRepDataConTyCon [vec2DataConTy, doubleElemRepDataConTy])
-floatX8PrimTyConName :: Name
-floatX8PrimTyConName = mkPrimTc (fsLit "FloatX8#") floatX8PrimTyConKey floatX8PrimTyCon
-floatX8PrimTy :: Type
-floatX8PrimTy = mkTyConTy floatX8PrimTyCon
-floatX8PrimTyCon :: TyCon
-floatX8PrimTyCon = pcPrimTyCon0 floatX8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, floatElemRepDataConTy])
-doubleX4PrimTyConName :: Name
-doubleX4PrimTyConName = mkPrimTc (fsLit "DoubleX4#") doubleX4PrimTyConKey doubleX4PrimTyCon
-doubleX4PrimTy :: Type
-doubleX4PrimTy = mkTyConTy doubleX4PrimTyCon
-doubleX4PrimTyCon :: TyCon
-doubleX4PrimTyCon = pcPrimTyCon0 doubleX4PrimTyConName (TyConApp vecRepDataConTyCon [vec4DataConTy, doubleElemRepDataConTy])
-floatX16PrimTyConName :: Name
-floatX16PrimTyConName = mkPrimTc (fsLit "FloatX16#") floatX16PrimTyConKey floatX16PrimTyCon
-floatX16PrimTy :: Type
-floatX16PrimTy = mkTyConTy floatX16PrimTyCon
-floatX16PrimTyCon :: TyCon
-floatX16PrimTyCon = pcPrimTyCon0 floatX16PrimTyConName (TyConApp vecRepDataConTyCon [vec16DataConTy, floatElemRepDataConTy])
-doubleX8PrimTyConName :: Name
-doubleX8PrimTyConName = mkPrimTc (fsLit "DoubleX8#") doubleX8PrimTyConKey doubleX8PrimTyCon
-doubleX8PrimTy :: Type
-doubleX8PrimTy = mkTyConTy doubleX8PrimTyCon
-doubleX8PrimTyCon :: TyCon
-doubleX8PrimTyCon = pcPrimTyCon0 doubleX8PrimTyConName (TyConApp vecRepDataConTyCon [vec8DataConTy, doubleElemRepDataConTy])
diff --git a/ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl b/ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl
deleted file mode 100644
--- a/ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl
+++ /dev/null
@@ -1,60 +0,0 @@
-int8X16PrimTyConKey :: Unique
-int8X16PrimTyConKey = mkPreludeTyConUnique 300
-int16X8PrimTyConKey :: Unique
-int16X8PrimTyConKey = mkPreludeTyConUnique 301
-int32X4PrimTyConKey :: Unique
-int32X4PrimTyConKey = mkPreludeTyConUnique 302
-int64X2PrimTyConKey :: Unique
-int64X2PrimTyConKey = mkPreludeTyConUnique 303
-int8X32PrimTyConKey :: Unique
-int8X32PrimTyConKey = mkPreludeTyConUnique 304
-int16X16PrimTyConKey :: Unique
-int16X16PrimTyConKey = mkPreludeTyConUnique 305
-int32X8PrimTyConKey :: Unique
-int32X8PrimTyConKey = mkPreludeTyConUnique 306
-int64X4PrimTyConKey :: Unique
-int64X4PrimTyConKey = mkPreludeTyConUnique 307
-int8X64PrimTyConKey :: Unique
-int8X64PrimTyConKey = mkPreludeTyConUnique 308
-int16X32PrimTyConKey :: Unique
-int16X32PrimTyConKey = mkPreludeTyConUnique 309
-int32X16PrimTyConKey :: Unique
-int32X16PrimTyConKey = mkPreludeTyConUnique 310
-int64X8PrimTyConKey :: Unique
-int64X8PrimTyConKey = mkPreludeTyConUnique 311
-word8X16PrimTyConKey :: Unique
-word8X16PrimTyConKey = mkPreludeTyConUnique 312
-word16X8PrimTyConKey :: Unique
-word16X8PrimTyConKey = mkPreludeTyConUnique 313
-word32X4PrimTyConKey :: Unique
-word32X4PrimTyConKey = mkPreludeTyConUnique 314
-word64X2PrimTyConKey :: Unique
-word64X2PrimTyConKey = mkPreludeTyConUnique 315
-word8X32PrimTyConKey :: Unique
-word8X32PrimTyConKey = mkPreludeTyConUnique 316
-word16X16PrimTyConKey :: Unique
-word16X16PrimTyConKey = mkPreludeTyConUnique 317
-word32X8PrimTyConKey :: Unique
-word32X8PrimTyConKey = mkPreludeTyConUnique 318
-word64X4PrimTyConKey :: Unique
-word64X4PrimTyConKey = mkPreludeTyConUnique 319
-word8X64PrimTyConKey :: Unique
-word8X64PrimTyConKey = mkPreludeTyConUnique 320
-word16X32PrimTyConKey :: Unique
-word16X32PrimTyConKey = mkPreludeTyConUnique 321
-word32X16PrimTyConKey :: Unique
-word32X16PrimTyConKey = mkPreludeTyConUnique 322
-word64X8PrimTyConKey :: Unique
-word64X8PrimTyConKey = mkPreludeTyConUnique 323
-floatX4PrimTyConKey :: Unique
-floatX4PrimTyConKey = mkPreludeTyConUnique 324
-doubleX2PrimTyConKey :: Unique
-doubleX2PrimTyConKey = mkPreludeTyConUnique 325
-floatX8PrimTyConKey :: Unique
-floatX8PrimTyConKey = mkPreludeTyConUnique 326
-doubleX4PrimTyConKey :: Unique
-doubleX4PrimTyConKey = mkPreludeTyConUnique 327
-floatX16PrimTyConKey :: Unique
-floatX16PrimTyConKey = mkPreludeTyConUnique 328
-doubleX8PrimTyConKey :: Unique
-doubleX8PrimTyConKey = mkPreludeTyConUnique 329
diff --git a/ghc-lib/stage0/lib/llvm-passes b/ghc-lib/stage0/lib/llvm-passes
deleted file mode 100644
--- a/ghc-lib/stage0/lib/llvm-passes
+++ /dev/null
@@ -1,5 +0,0 @@
-[
-(0, "-mem2reg -globalopt -lower-expect"),
-(1, "-O1 -globalopt"),
-(2, "-O2")
-]
diff --git a/ghc-lib/stage0/lib/llvm-targets b/ghc-lib/stage0/lib/llvm-targets
deleted file mode 100644
--- a/ghc-lib/stage0/lib/llvm-targets
+++ /dev/null
@@ -1,61 +0,0 @@
-[("i386-unknown-windows", ("e-m:x-p:32:32-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", ""))
-,("i686-unknown-windows", ("e-m:x-p:32:32-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", ""))
-,("x86_64-unknown-windows", ("e-m:w-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
-,("arm-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align"))
-,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))
-,("arm-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))
-,("armv6-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))
-,("armv6-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))
-,("armv6l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))
-,("armv6l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))
-,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
-,("armv7-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
-,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
-,("armv7a-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
-,("armv7a-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
-,("armv7a-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
-,("armv7l-unknown-linux-gnueabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
-,("armv7l-unknown-linux-musleabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
-,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
-,("armv7l-unknown-linux-musleabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
-,("aarch64-unknown-linux-gnu", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
-,("aarch64-unknown-linux-musl", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
-,("aarch64-unknown-linux", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
-,("aarch64_be-unknown-linux-gnu", ("E-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
-,("aarch64_be-unknown-linux-musl", ("E-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
-,("aarch64_be-unknown-linux", ("E-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
-,("i386-unknown-linux-gnu", ("e-m:e-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))
-,("i386-unknown-linux-musl", ("e-m:e-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))
-,("i386-unknown-linux", ("e-m:e-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))
-,("i686-unknown-linux-gnu", ("e-m:e-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))
-,("i686-unknown-linux-musl", ("e-m:e-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))
-,("i686-unknown-linux", ("e-m:e-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))
-,("x86_64-unknown-linux-gnu", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
-,("x86_64-unknown-linux-musl", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
-,("x86_64-unknown-linux", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
-,("x86_64-unknown-linux-android", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+sse4.2 +popcnt +cx16"))
-,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+fpregs +vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -crypto -fp16fml"))
-,("aarch64-unknown-linux-android", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
-,("armv7a-unknown-linux-androideabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+fpregs +vfp2 +vfp2sp +vfp3 +vfp3d16 +vfp3d16sp +vfp3sp -fp16 -vfp4 -vfp4d16 -vfp4d16sp -vfp4sp -fp-armv8 -fp-armv8d16 -fp-armv8d16sp -fp-armv8sp -fullfp16 +fp64 +d32 +neon -crypto -fp16fml"))
-,("powerpc64le-unknown-linux-gnu", ("e-m:e-i64:64-n32:64", "ppc64le", ""))
-,("powerpc64le-unknown-linux-musl", ("e-m:e-i64:64-n32:64", "ppc64le", "+secure-plt"))
-,("powerpc64le-unknown-linux", ("e-m:e-i64:64-n32:64", "ppc64le", ""))
-,("s390x-ibm-linux", ("E-m:e-i1:8:16-i8:8:16-i64:64-f128:64-a:8:16-n32:64", "z10", ""))
-,("riscv64-unknown-linux-gnu", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+m +a +f +d +c +relax"))
-,("riscv64-unknown-linux", ("e-m:e-p:64:64-i64:64-i128:128-n64-S128", "", "+m +a +f +d +c +relax"))
-,("i386-apple-darwin", ("e-m:o-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:128-n8:16:32-S128", "penryn", ""))
-,("x86_64-apple-darwin", ("e-m:o-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "penryn", ""))
-,("arm64-apple-darwin", ("e-m:o-i64:64-i128:128-n32:64-S128", "generic", "+v8.3a +fp-armv8 +neon +crc +crypto +fullfp16 +ras +lse +rdm +rcpc +zcm +zcz +sha2 +aes"))
-,("armv7-apple-ios", ("e-m:o-p:32:32-Fi8-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32", "generic", ""))
-,("aarch64-apple-ios", ("e-m:o-i64:64-i128:128-n32:64-S128", "apple-a7", "+fp-armv8 +neon +crypto +zcm +zcz +sha2 +aes"))
-,("i386-apple-ios", ("e-m:o-p:32:32-p270:32:32-p271:32:32-p272:64:64-f64:32:64-f80:128-n8:16:32-S128", "yonah", ""))
-,("x86_64-apple-ios", ("e-m:o-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "core2", ""))
-,("amd64-portbld-freebsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
-,("x86_64-unknown-freebsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
-,("aarch64-unknown-freebsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
-,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))
-,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align"))
-,("aarch64-unknown-netbsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
-,("x86_64-unknown-openbsd", ("e-m:e-p270:32:32-p271:32:32-p272:64:64-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+retpoline-indirect-calls +retpoline-indirect-branches"))
-,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-Fi8-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align"))
-]
diff --git a/ghc-lib/stage0/lib/settings b/ghc-lib/stage0/lib/settings
deleted file mode 100644
--- a/ghc-lib/stage0/lib/settings
+++ /dev/null
@@ -1,52 +0,0 @@
-[("GCC extra via C opts", "")
-,("C compiler command", "/usr/bin/gcc")
-,("C compiler flags", "--target=x86_64-apple-darwin ")
-,("C++ compiler command", "/usr/bin/g++")
-,("C++ compiler flags", "--target=x86_64-apple-darwin ")
-,("C compiler link flags", "--target=x86_64-apple-darwin  ")
-,("C compiler supports -no-pie", "NO")
-,("Haskell CPP command", "/usr/bin/gcc")
-,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")
-,("ld command", "ld")
-,("ld flags", "")
-,("ld supports compact unwind", "YES")
-,("ld supports filelist", "YES")
-,("ld is GNU ld", "NO")
-,("Merge objects command", "ld")
-,("Merge objects flags", "-r")
-,("ar command", "/usr/bin/ar")
-,("ar flags", "qcls")
-,("ar supports at file", "NO")
-,("ar supports -L", "NO")
-,("ranlib command", "/usr/bin/ranlib")
-,("otool command", "otool")
-,("install_name_tool command", "install_name_tool")
-,("touch command", "touch")
-,("dllwrap command", "/bin/false")
-,("windres command", "/bin/false")
-,("unlit command", "$topdir/bin/unlit")
-,("cross compiling", "NO")
-,("target platform string", "x86_64-apple-darwin")
-,("target os", "OSDarwin")
-,("target arch", "ArchX86_64")
-,("target word size", "8")
-,("target word big endian", "NO")
-,("target has GNU nonexec stack", "NO")
-,("target has .ident directive", "YES")
-,("target has subsections via symbols", "YES")
-,("target has RTS linker", "YES")
-,("target has libm", "YES")
-,("Unregisterised", "NO")
-,("LLVM target", "x86_64-apple-darwin")
-,("LLVM llc command", "llc")
-,("LLVM opt command", "opt")
-,("LLVM clang command", "clang")
-,("Use inplace MinGW toolchain", "NO")
-,("Use interpreter", "YES")
-,("Support SMP", "YES")
-,("RTS ways", "v")
-,("Tables next to code", "YES")
-,("Leading underscore", "YES")
-,("Use LibFFI", "NO")
-,("RTS expects libdw", "NO")
-]
diff --git a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs
deleted file mode 100644
--- a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs
+++ /dev/null
@@ -1,12 +0,0 @@
-module GHC.Platform.Host where
-
-import GHC.Platform.ArchOS
-
-hostPlatformArch :: Arch
-hostPlatformArch = ArchX86_64
-
-hostPlatformOS   :: OS
-hostPlatformOS   = OSDarwin
-
-hostPlatformArchOS :: ArchOS
-hostPlatformArchOS = ArchOS hostPlatformArch hostPlatformOS
diff --git a/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h b/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h
deleted file mode 100644
--- a/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h
+++ /dev/null
@@ -1,580 +0,0 @@
-/* This file is created automatically.  Do not edit by hand.*/
-
-#define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,64,8,16,8,0,72,56,8,16,0,8,8,0,8,0,104,120,16,8,16,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976,1"
-#define CONTROL_GROUP_CONST_291 291
-#define STD_HDR_SIZE 1
-#define PROF_HDR_SIZE 2
-#define STACK_DIRTY 1
-#define BLOCK_SIZE 4096
-#define MBLOCK_SIZE 1048576
-#define BLOCKS_PER_MBLOCK 252
-#define TICKY_BIN_COUNT 9
-#define OFFSET_StgRegTable_rR1 0
-#define OFFSET_StgRegTable_rR2 8
-#define OFFSET_StgRegTable_rR3 16
-#define OFFSET_StgRegTable_rR4 24
-#define OFFSET_StgRegTable_rR5 32
-#define OFFSET_StgRegTable_rR6 40
-#define OFFSET_StgRegTable_rR7 48
-#define OFFSET_StgRegTable_rR8 56
-#define OFFSET_StgRegTable_rR9 64
-#define OFFSET_StgRegTable_rR10 72
-#define OFFSET_StgRegTable_rF1 80
-#define OFFSET_StgRegTable_rF2 84
-#define OFFSET_StgRegTable_rF3 88
-#define OFFSET_StgRegTable_rF4 92
-#define OFFSET_StgRegTable_rF5 96
-#define OFFSET_StgRegTable_rF6 100
-#define OFFSET_StgRegTable_rD1 104
-#define OFFSET_StgRegTable_rD2 112
-#define OFFSET_StgRegTable_rD3 120
-#define OFFSET_StgRegTable_rD4 128
-#define OFFSET_StgRegTable_rD5 136
-#define OFFSET_StgRegTable_rD6 144
-#define OFFSET_StgRegTable_rXMM1 152
-#define OFFSET_StgRegTable_rXMM2 168
-#define OFFSET_StgRegTable_rXMM3 184
-#define OFFSET_StgRegTable_rXMM4 200
-#define OFFSET_StgRegTable_rXMM5 216
-#define OFFSET_StgRegTable_rXMM6 232
-#define OFFSET_StgRegTable_rYMM1 248
-#define OFFSET_StgRegTable_rYMM2 280
-#define OFFSET_StgRegTable_rYMM3 312
-#define OFFSET_StgRegTable_rYMM4 344
-#define OFFSET_StgRegTable_rYMM5 376
-#define OFFSET_StgRegTable_rYMM6 408
-#define OFFSET_StgRegTable_rZMM1 440
-#define OFFSET_StgRegTable_rZMM2 504
-#define OFFSET_StgRegTable_rZMM3 568
-#define OFFSET_StgRegTable_rZMM4 632
-#define OFFSET_StgRegTable_rZMM5 696
-#define OFFSET_StgRegTable_rZMM6 760
-#define OFFSET_StgRegTable_rL1 824
-#define OFFSET_StgRegTable_rSp 832
-#define OFFSET_StgRegTable_rSpLim 840
-#define OFFSET_StgRegTable_rHp 848
-#define OFFSET_StgRegTable_rHpLim 856
-#define OFFSET_StgRegTable_rCCCS 864
-#define OFFSET_StgRegTable_rCurrentTSO 872
-#define OFFSET_StgRegTable_rCurrentNursery 888
-#define OFFSET_StgRegTable_rHpAlloc 904
-#define OFFSET_StgRegTable_rRet 912
-#define REP_StgRegTable_rRet b64
-#define StgRegTable_rRet(__ptr__) REP_StgRegTable_rRet[__ptr__+OFFSET_StgRegTable_rRet]
-#define OFFSET_StgRegTable_rNursery 880
-#define REP_StgRegTable_rNursery b64
-#define StgRegTable_rNursery(__ptr__) REP_StgRegTable_rNursery[__ptr__+OFFSET_StgRegTable_rNursery]
-#define OFFSET_stgEagerBlackholeInfo -24
-#define OFFSET_stgGCEnter1 -16
-#define OFFSET_stgGCFun -8
-#define OFFSET_Capability_r 24
-#define OFFSET_Capability_lock 1216
-#define OFFSET_Capability_no 944
-#define REP_Capability_no b32
-#define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no]
-#define OFFSET_Capability_mut_lists 1016
-#define REP_Capability_mut_lists b64
-#define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]
-#define OFFSET_Capability_context_switch 1184
-#define REP_Capability_context_switch b32
-#define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]
-#define OFFSET_Capability_interrupt 1188
-#define REP_Capability_interrupt b32
-#define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]
-#define OFFSET_Capability_sparks 1320
-#define REP_Capability_sparks b64
-#define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]
-#define OFFSET_Capability_total_allocated 1192
-#define REP_Capability_total_allocated b64
-#define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]
-#define OFFSET_Capability_weak_ptr_list_hd 1168
-#define REP_Capability_weak_ptr_list_hd b64
-#define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]
-#define OFFSET_Capability_weak_ptr_list_tl 1176
-#define REP_Capability_weak_ptr_list_tl b64
-#define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl]
-#define OFFSET_bdescr_start 0
-#define REP_bdescr_start b64
-#define bdescr_start(__ptr__) REP_bdescr_start[__ptr__+OFFSET_bdescr_start]
-#define OFFSET_bdescr_free 8
-#define REP_bdescr_free b64
-#define bdescr_free(__ptr__) REP_bdescr_free[__ptr__+OFFSET_bdescr_free]
-#define OFFSET_bdescr_blocks 48
-#define REP_bdescr_blocks b32
-#define bdescr_blocks(__ptr__) REP_bdescr_blocks[__ptr__+OFFSET_bdescr_blocks]
-#define OFFSET_bdescr_gen_no 40
-#define REP_bdescr_gen_no b16
-#define bdescr_gen_no(__ptr__) REP_bdescr_gen_no[__ptr__+OFFSET_bdescr_gen_no]
-#define OFFSET_bdescr_link 16
-#define REP_bdescr_link b64
-#define bdescr_link(__ptr__) REP_bdescr_link[__ptr__+OFFSET_bdescr_link]
-#define OFFSET_bdescr_flags 46
-#define REP_bdescr_flags b16
-#define bdescr_flags(__ptr__) REP_bdescr_flags[__ptr__+OFFSET_bdescr_flags]
-#define SIZEOF_generation 368
-#define OFFSET_generation_n_new_large_words 56
-#define REP_generation_n_new_large_words b64
-#define generation_n_new_large_words(__ptr__) REP_generation_n_new_large_words[__ptr__+OFFSET_generation_n_new_large_words]
-#define OFFSET_generation_weak_ptr_list 112
-#define REP_generation_weak_ptr_list b64
-#define generation_weak_ptr_list(__ptr__) REP_generation_weak_ptr_list[__ptr__+OFFSET_generation_weak_ptr_list]
-#define SIZEOF_CostCentreStack 96
-#define OFFSET_CostCentreStack_ccsID 0
-#define REP_CostCentreStack_ccsID b64
-#define CostCentreStack_ccsID(__ptr__) REP_CostCentreStack_ccsID[__ptr__+OFFSET_CostCentreStack_ccsID]
-#define OFFSET_CostCentreStack_mem_alloc 72
-#define REP_CostCentreStack_mem_alloc b64
-#define CostCentreStack_mem_alloc(__ptr__) REP_CostCentreStack_mem_alloc[__ptr__+OFFSET_CostCentreStack_mem_alloc]
-#define OFFSET_CostCentreStack_scc_count 48
-#define REP_CostCentreStack_scc_count b64
-#define CostCentreStack_scc_count(__ptr__) REP_CostCentreStack_scc_count[__ptr__+OFFSET_CostCentreStack_scc_count]
-#define OFFSET_CostCentreStack_prevStack 16
-#define REP_CostCentreStack_prevStack b64
-#define CostCentreStack_prevStack(__ptr__) REP_CostCentreStack_prevStack[__ptr__+OFFSET_CostCentreStack_prevStack]
-#define OFFSET_CostCentre_ccID 0
-#define REP_CostCentre_ccID b64
-#define CostCentre_ccID(__ptr__) REP_CostCentre_ccID[__ptr__+OFFSET_CostCentre_ccID]
-#define OFFSET_CostCentre_link 56
-#define REP_CostCentre_link b64
-#define CostCentre_link(__ptr__) REP_CostCentre_link[__ptr__+OFFSET_CostCentre_link]
-#define OFFSET_StgHeader_info 0
-#define REP_StgHeader_info b64
-#define StgHeader_info(__ptr__) REP_StgHeader_info[__ptr__+OFFSET_StgHeader_info]
-#define OFFSET_StgHeader_ccs 8
-#define REP_StgHeader_ccs b64
-#define StgHeader_ccs(__ptr__) REP_StgHeader_ccs[__ptr__+OFFSET_StgHeader_ccs]
-#define OFFSET_StgHeader_ldvw 16
-#define REP_StgHeader_ldvw b64
-#define StgHeader_ldvw(__ptr__) REP_StgHeader_ldvw[__ptr__+OFFSET_StgHeader_ldvw]
-#define SIZEOF_StgSMPThunkHeader 8
-#define OFFSET_StgClosure_payload 0
-#define StgClosure_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgClosure_payload + WDS(__ix__)]
-#define OFFSET_StgEntCounter_allocs 64
-#define REP_StgEntCounter_allocs b64
-#define StgEntCounter_allocs(__ptr__) REP_StgEntCounter_allocs[__ptr__+OFFSET_StgEntCounter_allocs]
-#define OFFSET_StgEntCounter_allocd 16
-#define REP_StgEntCounter_allocd b64
-#define StgEntCounter_allocd(__ptr__) REP_StgEntCounter_allocd[__ptr__+OFFSET_StgEntCounter_allocd]
-#define OFFSET_StgEntCounter_registeredp 0
-#define REP_StgEntCounter_registeredp b64
-#define StgEntCounter_registeredp(__ptr__) REP_StgEntCounter_registeredp[__ptr__+OFFSET_StgEntCounter_registeredp]
-#define OFFSET_StgEntCounter_link 72
-#define REP_StgEntCounter_link b64
-#define StgEntCounter_link(__ptr__) REP_StgEntCounter_link[__ptr__+OFFSET_StgEntCounter_link]
-#define OFFSET_StgEntCounter_entry_count 56
-#define REP_StgEntCounter_entry_count b64
-#define StgEntCounter_entry_count(__ptr__) REP_StgEntCounter_entry_count[__ptr__+OFFSET_StgEntCounter_entry_count]
-#define SIZEOF_StgUpdateFrame_NoHdr 8
-#define SIZEOF_StgUpdateFrame (SIZEOF_StgHeader+8)
-#define SIZEOF_StgCatchFrame_NoHdr 16
-#define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16)
-#define SIZEOF_StgStopFrame_NoHdr 0
-#define SIZEOF_StgStopFrame (SIZEOF_StgHeader+0)
-#define SIZEOF_StgDeadThreadFrame_NoHdr 8
-#define SIZEOF_StgDeadThreadFrame (SIZEOF_StgHeader+8)
-#define OFFSET_StgDeadThreadFrame_result 0
-#define REP_StgDeadThreadFrame_result b64
-#define StgDeadThreadFrame_result(__ptr__) REP_StgDeadThreadFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgDeadThreadFrame_result]
-#define SIZEOF_StgMutArrPtrs_NoHdr 16
-#define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16)
-#define OFFSET_StgMutArrPtrs_ptrs 0
-#define REP_StgMutArrPtrs_ptrs b64
-#define StgMutArrPtrs_ptrs(__ptr__) REP_StgMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_ptrs]
-#define OFFSET_StgMutArrPtrs_size 8
-#define REP_StgMutArrPtrs_size b64
-#define StgMutArrPtrs_size(__ptr__) REP_StgMutArrPtrs_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_size]
-#define SIZEOF_StgSmallMutArrPtrs_NoHdr 8
-#define SIZEOF_StgSmallMutArrPtrs (SIZEOF_StgHeader+8)
-#define OFFSET_StgSmallMutArrPtrs_ptrs 0
-#define REP_StgSmallMutArrPtrs_ptrs b64
-#define StgSmallMutArrPtrs_ptrs(__ptr__) REP_StgSmallMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgSmallMutArrPtrs_ptrs]
-#define SIZEOF_StgArrBytes_NoHdr 8
-#define SIZEOF_StgArrBytes (SIZEOF_StgHeader+8)
-#define OFFSET_StgArrBytes_bytes 0
-#define REP_StgArrBytes_bytes b64
-#define StgArrBytes_bytes(__ptr__) REP_StgArrBytes_bytes[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_bytes]
-#define OFFSET_StgArrBytes_payload 8
-#define StgArrBytes_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_payload + WDS(__ix__)]
-#define OFFSET_StgTSO__link 0
-#define REP_StgTSO__link b64
-#define StgTSO__link(__ptr__) REP_StgTSO__link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO__link]
-#define OFFSET_StgTSO_global_link 8
-#define REP_StgTSO_global_link b64
-#define StgTSO_global_link(__ptr__) REP_StgTSO_global_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_global_link]
-#define OFFSET_StgTSO_what_next 24
-#define REP_StgTSO_what_next b16
-#define StgTSO_what_next(__ptr__) REP_StgTSO_what_next[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_what_next]
-#define OFFSET_StgTSO_why_blocked 26
-#define REP_StgTSO_why_blocked b16
-#define StgTSO_why_blocked(__ptr__) REP_StgTSO_why_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_why_blocked]
-#define OFFSET_StgTSO_block_info 32
-#define REP_StgTSO_block_info b64
-#define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info]
-#define OFFSET_StgTSO_blocked_exceptions 88
-#define REP_StgTSO_blocked_exceptions b64
-#define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions]
-#define OFFSET_StgTSO_id 40
-#define REP_StgTSO_id b64
-#define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id]
-#define OFFSET_StgTSO_cap 64
-#define REP_StgTSO_cap b64
-#define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap]
-#define OFFSET_StgTSO_saved_errno 48
-#define REP_StgTSO_saved_errno b32
-#define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno]
-#define OFFSET_StgTSO_trec 72
-#define REP_StgTSO_trec b64
-#define StgTSO_trec(__ptr__) REP_StgTSO_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_trec]
-#define OFFSET_StgTSO_flags 28
-#define REP_StgTSO_flags b32
-#define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags]
-#define OFFSET_StgTSO_dirty 52
-#define REP_StgTSO_dirty b32
-#define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty]
-#define OFFSET_StgTSO_bq 96
-#define REP_StgTSO_bq b64
-#define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq]
-#define OFFSET_StgTSO_label 80
-#define REP_StgTSO_label b64
-#define StgTSO_label(__ptr__) REP_StgTSO_label[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_label]
-#define OFFSET_StgTSO_alloc_limit 104
-#define REP_StgTSO_alloc_limit b64
-#define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit]
-#define OFFSET_StgTSO_cccs 120
-#define REP_StgTSO_cccs b64
-#define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs]
-#define OFFSET_StgTSO_stackobj 16
-#define REP_StgTSO_stackobj b64
-#define StgTSO_stackobj(__ptr__) REP_StgTSO_stackobj[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_stackobj]
-#define OFFSET_StgStack_sp 8
-#define REP_StgStack_sp b64
-#define StgStack_sp(__ptr__) REP_StgStack_sp[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_sp]
-#define OFFSET_StgStack_stack 16
-#define OFFSET_StgStack_stack_size 0
-#define REP_StgStack_stack_size b32
-#define StgStack_stack_size(__ptr__) REP_StgStack_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_stack_size]
-#define OFFSET_StgStack_dirty 4
-#define REP_StgStack_dirty b8
-#define StgStack_dirty(__ptr__) REP_StgStack_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_dirty]
-#define SIZEOF_StgTSOProfInfo 8
-#define OFFSET_StgUpdateFrame_updatee 0
-#define REP_StgUpdateFrame_updatee b64
-#define StgUpdateFrame_updatee(__ptr__) REP_StgUpdateFrame_updatee[__ptr__+SIZEOF_StgHeader+OFFSET_StgUpdateFrame_updatee]
-#define OFFSET_StgCatchFrame_handler 8
-#define REP_StgCatchFrame_handler b64
-#define StgCatchFrame_handler(__ptr__) REP_StgCatchFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_handler]
-#define OFFSET_StgCatchFrame_exceptions_blocked 0
-#define REP_StgCatchFrame_exceptions_blocked b64
-#define StgCatchFrame_exceptions_blocked(__ptr__) REP_StgCatchFrame_exceptions_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_exceptions_blocked]
-#define SIZEOF_StgPAP_NoHdr 16
-#define SIZEOF_StgPAP (SIZEOF_StgHeader+16)
-#define OFFSET_StgPAP_n_args 4
-#define REP_StgPAP_n_args b32
-#define StgPAP_n_args(__ptr__) REP_StgPAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_n_args]
-#define OFFSET_StgPAP_fun 8
-#define REP_StgPAP_fun gcptr
-#define StgPAP_fun(__ptr__) REP_StgPAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_fun]
-#define OFFSET_StgPAP_arity 0
-#define REP_StgPAP_arity b32
-#define StgPAP_arity(__ptr__) REP_StgPAP_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_arity]
-#define OFFSET_StgPAP_payload 16
-#define StgPAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_payload + WDS(__ix__)]
-#define SIZEOF_StgAP_NoThunkHdr 16
-#define SIZEOF_StgAP_NoHdr 24
-#define SIZEOF_StgAP (SIZEOF_StgHeader+24)
-#define OFFSET_StgAP_n_args 12
-#define REP_StgAP_n_args b32
-#define StgAP_n_args(__ptr__) REP_StgAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_n_args]
-#define OFFSET_StgAP_fun 16
-#define REP_StgAP_fun gcptr
-#define StgAP_fun(__ptr__) REP_StgAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_fun]
-#define OFFSET_StgAP_payload 24
-#define StgAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_payload + WDS(__ix__)]
-#define SIZEOF_StgAP_STACK_NoThunkHdr 16
-#define SIZEOF_StgAP_STACK_NoHdr 24
-#define SIZEOF_StgAP_STACK (SIZEOF_StgHeader+24)
-#define OFFSET_StgAP_STACK_size 8
-#define REP_StgAP_STACK_size b64
-#define StgAP_STACK_size(__ptr__) REP_StgAP_STACK_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_size]
-#define OFFSET_StgAP_STACK_fun 16
-#define REP_StgAP_STACK_fun gcptr
-#define StgAP_STACK_fun(__ptr__) REP_StgAP_STACK_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_fun]
-#define OFFSET_StgAP_STACK_payload 24
-#define StgAP_STACK_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_payload + WDS(__ix__)]
-#define SIZEOF_StgContinuation_NoHdr 24
-#define SIZEOF_StgContinuation (SIZEOF_StgHeader+24)
-#define OFFSET_StgContinuation_apply_mask_frame 0
-#define REP_StgContinuation_apply_mask_frame b64
-#define StgContinuation_apply_mask_frame(__ptr__) REP_StgContinuation_apply_mask_frame[__ptr__+SIZEOF_StgHeader+OFFSET_StgContinuation_apply_mask_frame]
-#define OFFSET_StgContinuation_mask_frame_offset 8
-#define REP_StgContinuation_mask_frame_offset b64
-#define StgContinuation_mask_frame_offset(__ptr__) REP_StgContinuation_mask_frame_offset[__ptr__+SIZEOF_StgHeader+OFFSET_StgContinuation_mask_frame_offset]
-#define OFFSET_StgContinuation_stack_size 16
-#define REP_StgContinuation_stack_size b64
-#define StgContinuation_stack_size(__ptr__) REP_StgContinuation_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgContinuation_stack_size]
-#define OFFSET_StgContinuation_stack 24
-#define StgContinuation_stack(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgContinuation_stack + WDS(__ix__)]
-#define SIZEOF_StgSelector_NoThunkHdr 8
-#define SIZEOF_StgSelector_NoHdr 16
-#define SIZEOF_StgSelector (SIZEOF_StgHeader+16)
-#define OFFSET_StgInd_indirectee 0
-#define REP_StgInd_indirectee gcptr
-#define StgInd_indirectee(__ptr__) REP_StgInd_indirectee[__ptr__+SIZEOF_StgHeader+OFFSET_StgInd_indirectee]
-#define SIZEOF_StgMutVar_NoHdr 8
-#define SIZEOF_StgMutVar (SIZEOF_StgHeader+8)
-#define OFFSET_StgMutVar_var 0
-#define REP_StgMutVar_var b64
-#define StgMutVar_var(__ptr__) REP_StgMutVar_var[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutVar_var]
-#define SIZEOF_StgAtomicallyFrame_NoHdr 16
-#define SIZEOF_StgAtomicallyFrame (SIZEOF_StgHeader+16)
-#define OFFSET_StgAtomicallyFrame_code 0
-#define REP_StgAtomicallyFrame_code b64
-#define StgAtomicallyFrame_code(__ptr__) REP_StgAtomicallyFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_code]
-#define OFFSET_StgAtomicallyFrame_result 8
-#define REP_StgAtomicallyFrame_result b64
-#define StgAtomicallyFrame_result(__ptr__) REP_StgAtomicallyFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_result]
-#define OFFSET_StgTRecHeader_enclosing_trec 0
-#define REP_StgTRecHeader_enclosing_trec b64
-#define StgTRecHeader_enclosing_trec(__ptr__) REP_StgTRecHeader_enclosing_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTRecHeader_enclosing_trec]
-#define SIZEOF_StgCatchSTMFrame_NoHdr 16
-#define SIZEOF_StgCatchSTMFrame (SIZEOF_StgHeader+16)
-#define OFFSET_StgCatchSTMFrame_handler 8
-#define REP_StgCatchSTMFrame_handler b64
-#define StgCatchSTMFrame_handler(__ptr__) REP_StgCatchSTMFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_handler]
-#define OFFSET_StgCatchSTMFrame_code 0
-#define REP_StgCatchSTMFrame_code b64
-#define StgCatchSTMFrame_code(__ptr__) REP_StgCatchSTMFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_code]
-#define SIZEOF_StgCatchRetryFrame_NoHdr 24
-#define SIZEOF_StgCatchRetryFrame (SIZEOF_StgHeader+24)
-#define OFFSET_StgCatchRetryFrame_running_alt_code 0
-#define REP_StgCatchRetryFrame_running_alt_code b64
-#define StgCatchRetryFrame_running_alt_code(__ptr__) REP_StgCatchRetryFrame_running_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_running_alt_code]
-#define OFFSET_StgCatchRetryFrame_first_code 8
-#define REP_StgCatchRetryFrame_first_code b64
-#define StgCatchRetryFrame_first_code(__ptr__) REP_StgCatchRetryFrame_first_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_first_code]
-#define OFFSET_StgCatchRetryFrame_alt_code 16
-#define REP_StgCatchRetryFrame_alt_code b64
-#define StgCatchRetryFrame_alt_code(__ptr__) REP_StgCatchRetryFrame_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_alt_code]
-#define OFFSET_StgTVarWatchQueue_closure 0
-#define REP_StgTVarWatchQueue_closure b64
-#define StgTVarWatchQueue_closure(__ptr__) REP_StgTVarWatchQueue_closure[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_closure]
-#define OFFSET_StgTVarWatchQueue_next_queue_entry 8
-#define REP_StgTVarWatchQueue_next_queue_entry b64
-#define StgTVarWatchQueue_next_queue_entry(__ptr__) REP_StgTVarWatchQueue_next_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_next_queue_entry]
-#define OFFSET_StgTVarWatchQueue_prev_queue_entry 16
-#define REP_StgTVarWatchQueue_prev_queue_entry b64
-#define StgTVarWatchQueue_prev_queue_entry(__ptr__) REP_StgTVarWatchQueue_prev_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_prev_queue_entry]
-#define SIZEOF_StgTVar_NoHdr 24
-#define SIZEOF_StgTVar (SIZEOF_StgHeader+24)
-#define OFFSET_StgTVar_current_value 0
-#define REP_StgTVar_current_value b64
-#define StgTVar_current_value(__ptr__) REP_StgTVar_current_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_current_value]
-#define OFFSET_StgTVar_first_watch_queue_entry 8
-#define REP_StgTVar_first_watch_queue_entry b64
-#define StgTVar_first_watch_queue_entry(__ptr__) REP_StgTVar_first_watch_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_first_watch_queue_entry]
-#define OFFSET_StgTVar_num_updates 16
-#define REP_StgTVar_num_updates b64
-#define StgTVar_num_updates(__ptr__) REP_StgTVar_num_updates[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_num_updates]
-#define SIZEOF_StgWeak_NoHdr 40
-#define SIZEOF_StgWeak (SIZEOF_StgHeader+40)
-#define OFFSET_StgWeak_link 32
-#define REP_StgWeak_link b64
-#define StgWeak_link(__ptr__) REP_StgWeak_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_link]
-#define OFFSET_StgWeak_key 8
-#define REP_StgWeak_key b64
-#define StgWeak_key(__ptr__) REP_StgWeak_key[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_key]
-#define OFFSET_StgWeak_value 16
-#define REP_StgWeak_value b64
-#define StgWeak_value(__ptr__) REP_StgWeak_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_value]
-#define OFFSET_StgWeak_finalizer 24
-#define REP_StgWeak_finalizer b64
-#define StgWeak_finalizer(__ptr__) REP_StgWeak_finalizer[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_finalizer]
-#define OFFSET_StgWeak_cfinalizers 0
-#define REP_StgWeak_cfinalizers b64
-#define StgWeak_cfinalizers(__ptr__) REP_StgWeak_cfinalizers[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_cfinalizers]
-#define SIZEOF_StgCFinalizerList_NoHdr 40
-#define SIZEOF_StgCFinalizerList (SIZEOF_StgHeader+40)
-#define OFFSET_StgCFinalizerList_link 0
-#define REP_StgCFinalizerList_link b64
-#define StgCFinalizerList_link(__ptr__) REP_StgCFinalizerList_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_link]
-#define OFFSET_StgCFinalizerList_fptr 8
-#define REP_StgCFinalizerList_fptr b64
-#define StgCFinalizerList_fptr(__ptr__) REP_StgCFinalizerList_fptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_fptr]
-#define OFFSET_StgCFinalizerList_ptr 16
-#define REP_StgCFinalizerList_ptr b64
-#define StgCFinalizerList_ptr(__ptr__) REP_StgCFinalizerList_ptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_ptr]
-#define OFFSET_StgCFinalizerList_eptr 24
-#define REP_StgCFinalizerList_eptr b64
-#define StgCFinalizerList_eptr(__ptr__) REP_StgCFinalizerList_eptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_eptr]
-#define OFFSET_StgCFinalizerList_flag 32
-#define REP_StgCFinalizerList_flag b64
-#define StgCFinalizerList_flag(__ptr__) REP_StgCFinalizerList_flag[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_flag]
-#define SIZEOF_StgMVar_NoHdr 24
-#define SIZEOF_StgMVar (SIZEOF_StgHeader+24)
-#define OFFSET_StgMVar_head 0
-#define REP_StgMVar_head b64
-#define StgMVar_head(__ptr__) REP_StgMVar_head[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_head]
-#define OFFSET_StgMVar_tail 8
-#define REP_StgMVar_tail b64
-#define StgMVar_tail(__ptr__) REP_StgMVar_tail[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_tail]
-#define OFFSET_StgMVar_value 16
-#define REP_StgMVar_value b64
-#define StgMVar_value(__ptr__) REP_StgMVar_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_value]
-#define SIZEOF_StgMVarTSOQueue_NoHdr 16
-#define SIZEOF_StgMVarTSOQueue (SIZEOF_StgHeader+16)
-#define OFFSET_StgMVarTSOQueue_link 0
-#define REP_StgMVarTSOQueue_link b64
-#define StgMVarTSOQueue_link(__ptr__) REP_StgMVarTSOQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_link]
-#define OFFSET_StgMVarTSOQueue_tso 8
-#define REP_StgMVarTSOQueue_tso b64
-#define StgMVarTSOQueue_tso(__ptr__) REP_StgMVarTSOQueue_tso[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_tso]
-#define SIZEOF_StgBCO_NoHdr 32
-#define SIZEOF_StgBCO (SIZEOF_StgHeader+32)
-#define OFFSET_StgBCO_instrs 0
-#define REP_StgBCO_instrs b64
-#define StgBCO_instrs(__ptr__) REP_StgBCO_instrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_instrs]
-#define OFFSET_StgBCO_literals 8
-#define REP_StgBCO_literals b64
-#define StgBCO_literals(__ptr__) REP_StgBCO_literals[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_literals]
-#define OFFSET_StgBCO_ptrs 16
-#define REP_StgBCO_ptrs b64
-#define StgBCO_ptrs(__ptr__) REP_StgBCO_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_ptrs]
-#define OFFSET_StgBCO_arity 24
-#define REP_StgBCO_arity b32
-#define StgBCO_arity(__ptr__) REP_StgBCO_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_arity]
-#define OFFSET_StgBCO_size 28
-#define REP_StgBCO_size b32
-#define StgBCO_size(__ptr__) REP_StgBCO_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_size]
-#define OFFSET_StgBCO_bitmap 32
-#define StgBCO_bitmap(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_bitmap + WDS(__ix__)]
-#define SIZEOF_StgStableName_NoHdr 8
-#define SIZEOF_StgStableName (SIZEOF_StgHeader+8)
-#define OFFSET_StgStableName_sn 0
-#define REP_StgStableName_sn b64
-#define StgStableName_sn(__ptr__) REP_StgStableName_sn[__ptr__+SIZEOF_StgHeader+OFFSET_StgStableName_sn]
-#define SIZEOF_StgBlockingQueue_NoHdr 32
-#define SIZEOF_StgBlockingQueue (SIZEOF_StgHeader+32)
-#define OFFSET_StgBlockingQueue_bh 8
-#define REP_StgBlockingQueue_bh b64
-#define StgBlockingQueue_bh(__ptr__) REP_StgBlockingQueue_bh[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_bh]
-#define OFFSET_StgBlockingQueue_owner 16
-#define REP_StgBlockingQueue_owner b64
-#define StgBlockingQueue_owner(__ptr__) REP_StgBlockingQueue_owner[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_owner]
-#define OFFSET_StgBlockingQueue_queue 24
-#define REP_StgBlockingQueue_queue b64
-#define StgBlockingQueue_queue(__ptr__) REP_StgBlockingQueue_queue[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_queue]
-#define OFFSET_StgBlockingQueue_link 0
-#define REP_StgBlockingQueue_link b64
-#define StgBlockingQueue_link(__ptr__) REP_StgBlockingQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_link]
-#define SIZEOF_MessageBlackHole_NoHdr 24
-#define SIZEOF_MessageBlackHole (SIZEOF_StgHeader+24)
-#define OFFSET_MessageBlackHole_link 0
-#define REP_MessageBlackHole_link b64
-#define MessageBlackHole_link(__ptr__) REP_MessageBlackHole_link[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_link]
-#define OFFSET_MessageBlackHole_tso 8
-#define REP_MessageBlackHole_tso b64
-#define MessageBlackHole_tso(__ptr__) REP_MessageBlackHole_tso[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_tso]
-#define OFFSET_MessageBlackHole_bh 16
-#define REP_MessageBlackHole_bh b64
-#define MessageBlackHole_bh(__ptr__) REP_MessageBlackHole_bh[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_bh]
-#define SIZEOF_StgCompactNFData_NoHdr 72
-#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+72)
-#define OFFSET_StgCompactNFData_totalW 0
-#define REP_StgCompactNFData_totalW b64
-#define StgCompactNFData_totalW(__ptr__) REP_StgCompactNFData_totalW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_totalW]
-#define OFFSET_StgCompactNFData_autoBlockW 8
-#define REP_StgCompactNFData_autoBlockW b64
-#define StgCompactNFData_autoBlockW(__ptr__) REP_StgCompactNFData_autoBlockW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_autoBlockW]
-#define OFFSET_StgCompactNFData_nursery 32
-#define REP_StgCompactNFData_nursery b64
-#define StgCompactNFData_nursery(__ptr__) REP_StgCompactNFData_nursery[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_nursery]
-#define OFFSET_StgCompactNFData_last 40
-#define REP_StgCompactNFData_last b64
-#define StgCompactNFData_last(__ptr__) REP_StgCompactNFData_last[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_last]
-#define OFFSET_StgCompactNFData_hp 16
-#define REP_StgCompactNFData_hp b64
-#define StgCompactNFData_hp(__ptr__) REP_StgCompactNFData_hp[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hp]
-#define OFFSET_StgCompactNFData_hpLim 24
-#define REP_StgCompactNFData_hpLim b64
-#define StgCompactNFData_hpLim(__ptr__) REP_StgCompactNFData_hpLim[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hpLim]
-#define OFFSET_StgCompactNFData_hash 48
-#define REP_StgCompactNFData_hash b64
-#define StgCompactNFData_hash(__ptr__) REP_StgCompactNFData_hash[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hash]
-#define OFFSET_StgCompactNFData_result 56
-#define REP_StgCompactNFData_result b64
-#define StgCompactNFData_result(__ptr__) REP_StgCompactNFData_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_result]
-#define SIZEOF_StgCompactNFDataBlock 24
-#define OFFSET_StgCompactNFDataBlock_self 0
-#define REP_StgCompactNFDataBlock_self b64
-#define StgCompactNFDataBlock_self(__ptr__) REP_StgCompactNFDataBlock_self[__ptr__+OFFSET_StgCompactNFDataBlock_self]
-#define OFFSET_StgCompactNFDataBlock_owner 8
-#define REP_StgCompactNFDataBlock_owner b64
-#define StgCompactNFDataBlock_owner(__ptr__) REP_StgCompactNFDataBlock_owner[__ptr__+OFFSET_StgCompactNFDataBlock_owner]
-#define OFFSET_StgCompactNFDataBlock_next 16
-#define REP_StgCompactNFDataBlock_next b64
-#define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]
-#define OFFSET_RtsFlags_ProfFlags_doHeapProfile 280
-#define REP_RtsFlags_ProfFlags_doHeapProfile b32
-#define RtsFlags_ProfFlags_doHeapProfile(__ptr__) REP_RtsFlags_ProfFlags_doHeapProfile[__ptr__+OFFSET_RtsFlags_ProfFlags_doHeapProfile]
-#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 301
-#define REP_RtsFlags_ProfFlags_showCCSOnException b8
-#define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]
-#define OFFSET_RtsFlags_DebugFlags_apply 245
-#define REP_RtsFlags_DebugFlags_apply b8
-#define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]
-#define OFFSET_RtsFlags_DebugFlags_sanity 239
-#define REP_RtsFlags_DebugFlags_sanity b8
-#define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]
-#define OFFSET_RtsFlags_DebugFlags_weak 234
-#define REP_RtsFlags_DebugFlags_weak b8
-#define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak]
-#define OFFSET_RtsFlags_GcFlags_initialStkSize 16
-#define REP_RtsFlags_GcFlags_initialStkSize b32
-#define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize]
-#define OFFSET_RtsFlags_MiscFlags_tickInterval 200
-#define REP_RtsFlags_MiscFlags_tickInterval b64
-#define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval]
-#define SIZEOF_StgFunInfoExtraFwd 32
-#define OFFSET_StgFunInfoExtraFwd_slow_apply 24
-#define REP_StgFunInfoExtraFwd_slow_apply b64
-#define StgFunInfoExtraFwd_slow_apply(__ptr__) REP_StgFunInfoExtraFwd_slow_apply[__ptr__+OFFSET_StgFunInfoExtraFwd_slow_apply]
-#define OFFSET_StgFunInfoExtraFwd_fun_type 0
-#define REP_StgFunInfoExtraFwd_fun_type b32
-#define StgFunInfoExtraFwd_fun_type(__ptr__) REP_StgFunInfoExtraFwd_fun_type[__ptr__+OFFSET_StgFunInfoExtraFwd_fun_type]
-#define OFFSET_StgFunInfoExtraFwd_arity 4
-#define REP_StgFunInfoExtraFwd_arity b32
-#define StgFunInfoExtraFwd_arity(__ptr__) REP_StgFunInfoExtraFwd_arity[__ptr__+OFFSET_StgFunInfoExtraFwd_arity]
-#define OFFSET_StgFunInfoExtraFwd_bitmap 16
-#define REP_StgFunInfoExtraFwd_bitmap b64
-#define StgFunInfoExtraFwd_bitmap(__ptr__) REP_StgFunInfoExtraFwd_bitmap[__ptr__+OFFSET_StgFunInfoExtraFwd_bitmap]
-#define SIZEOF_StgFunInfoExtraRev 24
-#define OFFSET_StgFunInfoExtraRev_slow_apply_offset 0
-#define REP_StgFunInfoExtraRev_slow_apply_offset b32
-#define StgFunInfoExtraRev_slow_apply_offset(__ptr__) REP_StgFunInfoExtraRev_slow_apply_offset[__ptr__+OFFSET_StgFunInfoExtraRev_slow_apply_offset]
-#define OFFSET_StgFunInfoExtraRev_fun_type 16
-#define REP_StgFunInfoExtraRev_fun_type b32
-#define StgFunInfoExtraRev_fun_type(__ptr__) REP_StgFunInfoExtraRev_fun_type[__ptr__+OFFSET_StgFunInfoExtraRev_fun_type]
-#define OFFSET_StgFunInfoExtraRev_arity 20
-#define REP_StgFunInfoExtraRev_arity b32
-#define StgFunInfoExtraRev_arity(__ptr__) REP_StgFunInfoExtraRev_arity[__ptr__+OFFSET_StgFunInfoExtraRev_arity]
-#define OFFSET_StgFunInfoExtraRev_bitmap 8
-#define REP_StgFunInfoExtraRev_bitmap b64
-#define StgFunInfoExtraRev_bitmap(__ptr__) REP_StgFunInfoExtraRev_bitmap[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap]
-#define OFFSET_StgFunInfoExtraRev_bitmap_offset 8
-#define REP_StgFunInfoExtraRev_bitmap_offset b32
-#define StgFunInfoExtraRev_bitmap_offset(__ptr__) REP_StgFunInfoExtraRev_bitmap_offset[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap_offset]
-#define OFFSET_StgLargeBitmap_size 0
-#define REP_StgLargeBitmap_size b64
-#define StgLargeBitmap_size(__ptr__) REP_StgLargeBitmap_size[__ptr__+OFFSET_StgLargeBitmap_size]
-#define OFFSET_StgLargeBitmap_bitmap 8
-#define SIZEOF_snEntry 24
-#define OFFSET_snEntry_sn_obj 16
-#define REP_snEntry_sn_obj b64
-#define snEntry_sn_obj(__ptr__) REP_snEntry_sn_obj[__ptr__+OFFSET_snEntry_sn_obj]
-#define OFFSET_snEntry_addr 0
-#define REP_snEntry_addr b64
-#define snEntry_addr(__ptr__) REP_snEntry_addr[__ptr__+OFFSET_snEntry_addr]
-#define SIZEOF_spEntry 8
-#define OFFSET_spEntry_addr 0
-#define REP_spEntry_addr b64
-#define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr]
diff --git a/ghc-lib/stage0/rts/build/include/ghcautoconf.h b/ghc-lib/stage0/rts/build/include/ghcautoconf.h
deleted file mode 100644
--- a/ghc-lib/stage0/rts/build/include/ghcautoconf.h
+++ /dev/null
@@ -1,648 +0,0 @@
-#if !defined(__GHCAUTOCONF_H__)
-#define __GHCAUTOCONF_H__
-/* mk/config.h.  Generated from config.h.in by configure.  */
-/* mk/config.h.in.  Generated from configure.ac by autoheader.  */
-
-/* Define if building universal (internal helper macro) */
-/* #undef AC_APPLE_UNIVERSAL_BUILD */
-
-/* The alignment of a `char'. */
-#define ALIGNMENT_CHAR 1
-
-/* The alignment of a `double'. */
-#define ALIGNMENT_DOUBLE 8
-
-/* The alignment of a `float'. */
-#define ALIGNMENT_FLOAT 4
-
-/* The alignment of a `int'. */
-#define ALIGNMENT_INT 4
-
-/* The alignment of a `int16_t'. */
-#define ALIGNMENT_INT16_T 2
-
-/* The alignment of a `int32_t'. */
-#define ALIGNMENT_INT32_T 4
-
-/* The alignment of a `int64_t'. */
-#define ALIGNMENT_INT64_T 8
-
-/* The alignment of a `int8_t'. */
-#define ALIGNMENT_INT8_T 1
-
-/* The alignment of a `long'. */
-#define ALIGNMENT_LONG 8
-
-/* The alignment of a `long long'. */
-#define ALIGNMENT_LONG_LONG 8
-
-/* The alignment of a `short'. */
-#define ALIGNMENT_SHORT 2
-
-/* The alignment of a `uint16_t'. */
-#define ALIGNMENT_UINT16_T 2
-
-/* The alignment of a `uint32_t'. */
-#define ALIGNMENT_UINT32_T 4
-
-/* The alignment of a `uint64_t'. */
-#define ALIGNMENT_UINT64_T 8
-
-/* The alignment of a `uint8_t'. */
-#define ALIGNMENT_UINT8_T 1
-
-/* The alignment of a `unsigned char'. */
-#define ALIGNMENT_UNSIGNED_CHAR 1
-
-/* The alignment of a `unsigned int'. */
-#define ALIGNMENT_UNSIGNED_INT 4
-
-/* The alignment of a `unsigned long'. */
-#define ALIGNMENT_UNSIGNED_LONG 8
-
-/* The alignment of a `unsigned long long'. */
-#define ALIGNMENT_UNSIGNED_LONG_LONG 8
-
-/* The alignment of a `unsigned short'. */
-#define ALIGNMENT_UNSIGNED_SHORT 2
-
-/* The alignment of a `void *'. */
-#define ALIGNMENT_VOID_P 8
-
-/* Define (to 1) if C compiler has an LLVM back end */
-#define CC_LLVM_BACKEND 1
-
-/* Define to 1 if __thread is supported */
-#define CC_SUPPORTS_TLS 1
-
-/* Define to 1 if using 'alloca.c'. */
-/* #undef C_ALLOCA */
-
-/* Enable Native I/O manager as default. */
-/* #undef DEFAULT_NATIVE_IO_MANAGER */
-
-/* Define to 1 if your processor stores words of floats with the most
-   significant byte first */
-/* #undef FLOAT_WORDS_BIGENDIAN */
-
-/* Has musttail */
-#define HAS_MUSTTAIL 1
-
-/* Has visibility hidden */
-#define HAS_VISIBILITY_HIDDEN 1
-
-/* Define to 1 if you have 'alloca', as a function or macro. */
-#define HAVE_ALLOCA 1
-
-/* Define to 1 if <alloca.h> works. */
-#define HAVE_ALLOCA_H 1
-
-/* Define to 1 if you have the <bfd.h> header file. */
-/* #undef HAVE_BFD_H */
-
-/* Does C compiler support __atomic primitives? */
-#define HAVE_C11_ATOMICS 1
-
-/* Define to 1 if you have the `clock_gettime' function. */
-#define HAVE_CLOCK_GETTIME 1
-
-/* Define to 1 if you have the `ctime_r' function. */
-#define HAVE_CTIME_R 1
-
-/* Define to 1 if you have the <ctype.h> header file. */
-#define HAVE_CTYPE_H 1
-
-/* Define to 1 if you have the declaration of `ctime_r', and to 0 if you
-   don't. */
-#define HAVE_DECL_CTIME_R 1
-
-/* Define to 1 if you have the declaration of `environ', and to 0 if you
-   don't. */
-#define HAVE_DECL_ENVIRON 0
-
-/* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you
-   don't. */
-/* #undef HAVE_DECL_MADV_DONTNEED */
-
-/* Define to 1 if you have the declaration of `MADV_FREE', and to 0 if you
-   don't. */
-/* #undef HAVE_DECL_MADV_FREE */
-
-/* Define to 1 if you have the declaration of `MAP_NORESERVE', and to 0 if you
-   don't. */
-/* #undef HAVE_DECL_MAP_NORESERVE */
-
-/* Define to 1 if you have the declaration of `program_invocation_short_name',
-   and to 0 if you don't. */
-#define HAVE_DECL_PROGRAM_INVOCATION_SHORT_NAME 0
-
-/* Define to 1 if you have the <dirent.h> header file. */
-#define HAVE_DIRENT_H 1
-
-/* Define to 1 if you have the <dlfcn.h> header file. */
-#define HAVE_DLFCN_H 1
-
-/* Define to 1 if you have the `dlinfo' function. */
-/* #undef HAVE_DLINFO */
-
-/* Define to 1 if you have the <elfutils/libdw.h> header file. */
-/* #undef HAVE_ELFUTILS_LIBDW_H */
-
-/* Define to 1 if you have the <errno.h> header file. */
-#define HAVE_ERRNO_H 1
-
-/* Define to 1 if you have the `eventfd' function. */
-/* #undef HAVE_EVENTFD */
-
-/* Define to 1 if you have the <fcntl.h> header file. */
-#define HAVE_FCNTL_H 1
-
-/* Define to 1 if you have the <ffi.h> header file. */
-/* #undef HAVE_FFI_H */
-
-/* Define to 1 if you have the `fork' function. */
-#define HAVE_FORK 1
-
-/* Define to 1 if you have the `getclock' function. */
-/* #undef HAVE_GETCLOCK */
-
-/* Define to 1 if you have the `GetModuleFileName' function. */
-/* #undef HAVE_GETMODULEFILENAME */
-
-/* Define to 1 if you have the `getpid' function. */
-#define HAVE_GETPID 1
-
-/* Define to 1 if you have the `getrusage' function. */
-#define HAVE_GETRUSAGE 1
-
-/* Define to 1 if you have the `gettimeofday' function. */
-#define HAVE_GETTIMEOFDAY 1
-
-/* Define to 1 if you have the `getuid' function. */
-#define HAVE_GETUID 1
-
-/* Define to 1 if you have the <grp.h> header file. */
-#define HAVE_GRP_H 1
-
-/* Define to 1 if you have the <inttypes.h> header file. */
-#define HAVE_INTTYPES_H 1
-
-/* Define to 1 if you have the `bfd' library (-lbfd). */
-/* #undef HAVE_LIBBFD */
-
-/* Define to 1 if you have the `dl' library (-ldl). */
-#define HAVE_LIBDL 1
-
-/* Define to 1 if you have the `iberty' library (-liberty). */
-/* #undef HAVE_LIBIBERTY */
-
-/* Define to 1 if you need to link with libm */
-#define HAVE_LIBM 1
-
-/* Define to 1 if you have libnuma */
-#define HAVE_LIBNUMA 0
-
-/* Define to 1 if you have the `pthread' library (-lpthread). */
-#define HAVE_LIBPTHREAD 1
-
-/* Define to 1 if you have the `rt' library (-lrt). */
-/* #undef HAVE_LIBRT */
-
-/* Define to 1 if you have the <limits.h> header file. */
-#define HAVE_LIMITS_H 1
-
-/* Define to 1 if you have the <locale.h> header file. */
-#define HAVE_LOCALE_H 1
-
-/* Define to 1 if the system has the type `long long'. */
-#define HAVE_LONG_LONG 1
-
-/* Define to 1 if you have the mingwex library. */
-/* #undef HAVE_MINGWEX */
-
-/* Define to 1 if you have the <minix/config.h> header file. */
-/* #undef HAVE_MINIX_CONFIG_H */
-
-/* Define to 1 if you have the <nlist.h> header file. */
-#define HAVE_NLIST_H 1
-
-/* Define to 1 if you have the <numaif.h> header file. */
-/* #undef HAVE_NUMAIF_H */
-
-/* Define to 1 if you have the <numa.h> header file. */
-/* #undef HAVE_NUMA_H */
-
-/* Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC). */
-#define HAVE_PRINTF_LDBLSTUB 0
-
-/* Define to 1 if you have the `pthread_condattr_setclock' function. */
-/* #undef HAVE_PTHREAD_CONDATTR_SETCLOCK */
-
-/* Define to 1 if you have the <pthread.h> header file. */
-#define HAVE_PTHREAD_H 1
-
-/* Define to 1 if you have the <pthread_np.h> header file. */
-/* #undef HAVE_PTHREAD_NP_H */
-
-/* Define to 1 if you have the glibc version of pthread_setname_np */
-/* #undef HAVE_PTHREAD_SETNAME_NP */
-
-/* Define to 1 if you have the Darwin version of pthread_setname_np */
-#define HAVE_PTHREAD_SETNAME_NP_DARWIN 1
-
-/* Define to 1 if you have the NetBSD version of pthread_setname_np */
-/* #undef HAVE_PTHREAD_SETNAME_NP_NETBSD */
-
-/* Define to 1 if you have pthread_set_name_np */
-/* #undef HAVE_PTHREAD_SET_NAME_NP */
-
-/* Define to 1 if you have the <pwd.h> header file. */
-#define HAVE_PWD_H 1
-
-/* Define to 1 if you have the `raise' function. */
-#define HAVE_RAISE 1
-
-/* Define to 1 if you have the `sched_getaffinity' function. */
-/* #undef HAVE_SCHED_GETAFFINITY */
-
-/* Define to 1 if you have the <sched.h> header file. */
-#define HAVE_SCHED_H 1
-
-/* Define to 1 if you have the `sched_setaffinity' function. */
-/* #undef HAVE_SCHED_SETAFFINITY */
-
-/* Define to 1 if you have the `setitimer' function. */
-#define HAVE_SETITIMER 1
-
-/* Define to 1 if you have the `setlocale' function. */
-#define HAVE_SETLOCALE 1
-
-/* Define to 1 if you have the `siginterrupt' function. */
-#define HAVE_SIGINTERRUPT 1
-
-/* Define to 1 if you have the <signal.h> header file. */
-#define HAVE_SIGNAL_H 1
-
-/* Define to 1 if you have the <stdint.h> header file. */
-#define HAVE_STDINT_H 1
-
-/* Define to 1 if you have the <stdio.h> header file. */
-#define HAVE_STDIO_H 1
-
-/* Define to 1 if you have the <stdlib.h> header file. */
-#define HAVE_STDLIB_H 1
-
-/* Define to 1 if you have the <strings.h> header file. */
-#define HAVE_STRINGS_H 1
-
-/* Define to 1 if you have the <string.h> header file. */
-#define HAVE_STRING_H 1
-
-/* Define to 1 if Apple-style dead-stripping is supported. */
-#define HAVE_SUBSECTIONS_VIA_SYMBOLS 1
-
-/* Define to 1 if you have the `sysconf' function. */
-#define HAVE_SYSCONF 1
-
-/* Define to 1 if you have libffi. */
-/* #undef HAVE_SYSTEM_LIBFFI */
-
-/* Define to 1 if you have the <sys/cpuset.h> header file. */
-/* #undef HAVE_SYS_CPUSET_H */
-
-/* Define to 1 if you have the <sys/eventfd.h> header file. */
-/* #undef HAVE_SYS_EVENTFD_H */
-
-/* Define to 1 if you have the <sys/mman.h> header file. */
-#define HAVE_SYS_MMAN_H 1
-
-/* Define to 1 if you have the <sys/param.h> header file. */
-#define HAVE_SYS_PARAM_H 1
-
-/* Define to 1 if you have the <sys/resource.h> header file. */
-#define HAVE_SYS_RESOURCE_H 1
-
-/* Define to 1 if you have the <sys/select.h> header file. */
-#define HAVE_SYS_SELECT_H 1
-
-/* Define to 1 if you have the <sys/stat.h> header file. */
-#define HAVE_SYS_STAT_H 1
-
-/* Define to 1 if you have the <sys/timeb.h> header file. */
-#define HAVE_SYS_TIMEB_H 1
-
-/* Define to 1 if you have the <sys/timerfd.h> header file. */
-/* #undef HAVE_SYS_TIMERFD_H */
-
-/* Define to 1 if you have the <sys/timers.h> header file. */
-/* #undef HAVE_SYS_TIMERS_H */
-
-/* Define to 1 if you have the <sys/times.h> header file. */
-#define HAVE_SYS_TIMES_H 1
-
-/* Define to 1 if you have the <sys/time.h> header file. */
-#define HAVE_SYS_TIME_H 1
-
-/* Define to 1 if you have the <sys/types.h> header file. */
-#define HAVE_SYS_TYPES_H 1
-
-/* Define to 1 if you have the <sys/utsname.h> header file. */
-#define HAVE_SYS_UTSNAME_H 1
-
-/* Define to 1 if you have the <sys/wait.h> header file. */
-#define HAVE_SYS_WAIT_H 1
-
-/* Define to 1 if you have the <termios.h> header file. */
-#define HAVE_TERMIOS_H 1
-
-/* Define to 1 if you have the `timer_settime' function. */
-/* #undef HAVE_TIMER_SETTIME */
-
-/* Define to 1 if you have the `times' function. */
-#define HAVE_TIMES 1
-
-/* Define to 1 if you have the <unistd.h> header file. */
-#define HAVE_UNISTD_H 1
-
-/* Define to 1 if you have the `uselocale' function. */
-#define HAVE_USELOCALE 1
-
-/* Define to 1 if you have the <utime.h> header file. */
-#define HAVE_UTIME_H 1
-
-/* Define to 1 if you have the `vfork' function. */
-#define HAVE_VFORK 1
-
-/* Define to 1 if you have the <vfork.h> header file. */
-/* #undef HAVE_VFORK_H */
-
-/* Define to 1 if you have the <wchar.h> header file. */
-#define HAVE_WCHAR_H 1
-
-/* Define to 1 if you have the <windows.h> header file. */
-/* #undef HAVE_WINDOWS_H */
-
-/* Define to 1 if you have the `WinExec' function. */
-/* #undef HAVE_WINEXEC */
-
-/* Define to 1 if you have the <winsock.h> header file. */
-/* #undef HAVE_WINSOCK_H */
-
-/* Define to 1 if `fork' works. */
-#define HAVE_WORKING_FORK 1
-
-/* Define to 1 if `vfork' works. */
-#define HAVE_WORKING_VFORK 1
-
-/* Define to 1 if C symbols have a leading underscore added by the compiler.
-   */
-#define LEADING_UNDERSCORE 1
-
-/* Define to 1 if we need -latomic. */
-#define NEED_ATOMIC_LIB 0
-
-/* Define 1 if we need to link code using pthreads with -lpthread */
-#define NEED_PTHREAD_LIB 0
-
-/* Define to the address where bug reports for this package should be sent. */
-/* #undef PACKAGE_BUGREPORT */
-
-/* Define to the full name of this package. */
-/* #undef PACKAGE_NAME */
-
-/* Define to the full name and version of this package. */
-/* #undef PACKAGE_STRING */
-
-/* Define to the one symbol short name of this package. */
-/* #undef PACKAGE_TARNAME */
-
-/* Define to the home page for this package. */
-/* #undef PACKAGE_URL */
-
-/* Define to the version of this package. */
-/* #undef PACKAGE_VERSION */
-
-/* Use mmap in the runtime linker */
-#define RTS_LINKER_USE_MMAP 1
-
-/* The size of `char', as computed by sizeof. */
-#define SIZEOF_CHAR 1
-
-/* The size of `double', as computed by sizeof. */
-#define SIZEOF_DOUBLE 8
-
-/* The size of `float', as computed by sizeof. */
-#define SIZEOF_FLOAT 4
-
-/* The size of `int', as computed by sizeof. */
-#define SIZEOF_INT 4
-
-/* The size of `int16_t', as computed by sizeof. */
-#define SIZEOF_INT16_T 2
-
-/* The size of `int32_t', as computed by sizeof. */
-#define SIZEOF_INT32_T 4
-
-/* The size of `int64_t', as computed by sizeof. */
-#define SIZEOF_INT64_T 8
-
-/* The size of `int8_t', as computed by sizeof. */
-#define SIZEOF_INT8_T 1
-
-/* The size of `long', as computed by sizeof. */
-#define SIZEOF_LONG 8
-
-/* The size of `long long', as computed by sizeof. */
-#define SIZEOF_LONG_LONG 8
-
-/* The size of `short', as computed by sizeof. */
-#define SIZEOF_SHORT 2
-
-/* The size of `uint16_t', as computed by sizeof. */
-#define SIZEOF_UINT16_T 2
-
-/* The size of `uint32_t', as computed by sizeof. */
-#define SIZEOF_UINT32_T 4
-
-/* The size of `uint64_t', as computed by sizeof. */
-#define SIZEOF_UINT64_T 8
-
-/* The size of `uint8_t', as computed by sizeof. */
-#define SIZEOF_UINT8_T 1
-
-/* The size of `unsigned char', as computed by sizeof. */
-#define SIZEOF_UNSIGNED_CHAR 1
-
-/* The size of `unsigned int', as computed by sizeof. */
-#define SIZEOF_UNSIGNED_INT 4
-
-/* The size of `unsigned long', as computed by sizeof. */
-#define SIZEOF_UNSIGNED_LONG 8
-
-/* The size of `unsigned long long', as computed by sizeof. */
-#define SIZEOF_UNSIGNED_LONG_LONG 8
-
-/* The size of `unsigned short', as computed by sizeof. */
-#define SIZEOF_UNSIGNED_SHORT 2
-
-/* The size of `void *', as computed by sizeof. */
-#define SIZEOF_VOID_P 8
-
-/* If using the C implementation of alloca, define if you know the
-   direction of stack growth for your system; otherwise it will be
-   automatically deduced at runtime.
-	STACK_DIRECTION > 0 => grows toward higher addresses
-	STACK_DIRECTION < 0 => grows toward lower addresses
-	STACK_DIRECTION = 0 => direction of growth unknown */
-/* #undef STACK_DIRECTION */
-
-/* Define to 1 if all of the C90 standard headers exist (not just the ones
-   required in a freestanding environment). This macro is provided for
-   backward compatibility; new code need not use it. */
-#define STDC_HEADERS 1
-
-/* Define to 1 if info tables are laid out next to code */
-#define TABLES_NEXT_TO_CODE 1
-
-/* Compile-in ASSERTs in all ways. */
-/* #undef USE_ASSERTS_ALL_WAYS */
-
-/* Enable single heap address space support */
-#define USE_LARGE_ADDRESS_SPACE 1
-
-/* Set to 1 to use libdw */
-#define USE_LIBDW 0
-
-/* Enable extensions on AIX 3, Interix.  */
-#ifndef _ALL_SOURCE
-# define _ALL_SOURCE 1
-#endif
-/* Enable general extensions on macOS.  */
-#ifndef _DARWIN_C_SOURCE
-# define _DARWIN_C_SOURCE 1
-#endif
-/* Enable general extensions on Solaris.  */
-#ifndef __EXTENSIONS__
-# define __EXTENSIONS__ 1
-#endif
-/* Enable GNU extensions on systems that have them.  */
-#ifndef _GNU_SOURCE
-# define _GNU_SOURCE 1
-#endif
-/* Enable X/Open compliant socket functions that do not require linking
-   with -lxnet on HP-UX 11.11.  */
-#ifndef _HPUX_ALT_XOPEN_SOCKET_API
-# define _HPUX_ALT_XOPEN_SOCKET_API 1
-#endif
-/* Identify the host operating system as Minix.
-   This macro does not affect the system headers' behavior.
-   A future release of Autoconf may stop defining this macro.  */
-#ifndef _MINIX
-/* # undef _MINIX */
-#endif
-/* Enable general extensions on NetBSD.
-   Enable NetBSD compatibility extensions on Minix.  */
-#ifndef _NETBSD_SOURCE
-# define _NETBSD_SOURCE 1
-#endif
-/* Enable OpenBSD compatibility extensions on NetBSD.
-   Oddly enough, this does nothing on OpenBSD.  */
-#ifndef _OPENBSD_SOURCE
-# define _OPENBSD_SOURCE 1
-#endif
-/* Define to 1 if needed for POSIX-compatible behavior.  */
-#ifndef _POSIX_SOURCE
-/* # undef _POSIX_SOURCE */
-#endif
-/* Define to 2 if needed for POSIX-compatible behavior.  */
-#ifndef _POSIX_1_SOURCE
-/* # undef _POSIX_1_SOURCE */
-#endif
-/* Enable POSIX-compatible threading on Solaris.  */
-#ifndef _POSIX_PTHREAD_SEMANTICS
-# define _POSIX_PTHREAD_SEMANTICS 1
-#endif
-/* Enable extensions specified by ISO/IEC TS 18661-5:2014.  */
-#ifndef __STDC_WANT_IEC_60559_ATTRIBS_EXT__
-# define __STDC_WANT_IEC_60559_ATTRIBS_EXT__ 1
-#endif
-/* Enable extensions specified by ISO/IEC TS 18661-1:2014.  */
-#ifndef __STDC_WANT_IEC_60559_BFP_EXT__
-# define __STDC_WANT_IEC_60559_BFP_EXT__ 1
-#endif
-/* Enable extensions specified by ISO/IEC TS 18661-2:2015.  */
-#ifndef __STDC_WANT_IEC_60559_DFP_EXT__
-# define __STDC_WANT_IEC_60559_DFP_EXT__ 1
-#endif
-/* Enable extensions specified by ISO/IEC TS 18661-4:2015.  */
-#ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__
-# define __STDC_WANT_IEC_60559_FUNCS_EXT__ 1
-#endif
-/* Enable extensions specified by ISO/IEC TS 18661-3:2015.  */
-#ifndef __STDC_WANT_IEC_60559_TYPES_EXT__
-# define __STDC_WANT_IEC_60559_TYPES_EXT__ 1
-#endif
-/* Enable extensions specified by ISO/IEC TR 24731-2:2010.  */
-#ifndef __STDC_WANT_LIB_EXT2__
-# define __STDC_WANT_LIB_EXT2__ 1
-#endif
-/* Enable extensions specified by ISO/IEC 24747:2009.  */
-#ifndef __STDC_WANT_MATH_SPEC_FUNCS__
-# define __STDC_WANT_MATH_SPEC_FUNCS__ 1
-#endif
-/* Enable extensions on HP NonStop.  */
-#ifndef _TANDEM_SOURCE
-# define _TANDEM_SOURCE 1
-#endif
-/* Enable X/Open extensions.  Define to 500 only if necessary
-   to make mbstate_t available.  */
-#ifndef _XOPEN_SOURCE
-/* # undef _XOPEN_SOURCE */
-#endif
-
-
-/* Define to 1 if we can use timer_create(CLOCK_REALTIME,...) */
-/* #undef USE_TIMER_CREATE */
-
-/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most
-   significant byte first (like Motorola and SPARC, unlike Intel). */
-#if defined AC_APPLE_UNIVERSAL_BUILD
-# if defined __BIG_ENDIAN__
-#  define WORDS_BIGENDIAN 1
-# endif
-#else
-# ifndef WORDS_BIGENDIAN
-/* #  undef WORDS_BIGENDIAN */
-# endif
-#endif
-
-/* Number of bits in a file offset, on hosts where this is settable. */
-/* #undef _FILE_OFFSET_BITS */
-
-/* Define for large files, on AIX-style hosts. */
-/* #undef _LARGE_FILES */
-
-/* ARM pre v6 */
-/* #undef arm_HOST_ARCH_PRE_ARMv6 */
-
-/* ARM pre v7 */
-/* #undef arm_HOST_ARCH_PRE_ARMv7 */
-
-/* Define to empty if `const' does not conform to ANSI C. */
-/* #undef const */
-
-/* Define as a signed integer type capable of holding a process identifier. */
-/* #undef pid_t */
-
-/* The maximum supported LLVM version number */
-#define sUPPORTED_LLVM_VERSION_MAX (15)
-
-/* The minimum supported LLVM version number */
-#define sUPPORTED_LLVM_VERSION_MIN (10)
-
-/* Define to `unsigned int' if <sys/types.h> does not define. */
-/* #undef size_t */
-
-/* Define as `fork' if `vfork' does not work. */
-/* #undef vfork */
-#endif /* __GHCAUTOCONF_H__ */
diff --git a/ghc-lib/stage0/rts/build/include/ghcplatform.h b/ghc-lib/stage0/rts/build/include/ghcplatform.h
deleted file mode 100644
--- a/ghc-lib/stage0/rts/build/include/ghcplatform.h
+++ /dev/null
@@ -1,26 +0,0 @@
-#if !defined(__GHCPLATFORM_H__)
-#define __GHCPLATFORM_H__
-
-#define BuildPlatform_TYPE  x86_64_apple_darwin
-#define HostPlatform_TYPE   x86_64_apple_darwin
-
-#define x86_64_apple_darwin_BUILD 1
-#define x86_64_apple_darwin_HOST 1
-
-#define x86_64_BUILD_ARCH 1
-#define x86_64_HOST_ARCH 1
-#define BUILD_ARCH "x86_64"
-#define HOST_ARCH "x86_64"
-
-#define darwin_BUILD_OS 1
-#define darwin_HOST_OS 1
-#define BUILD_OS "darwin"
-#define HOST_OS "darwin"
-
-#define apple_BUILD_VENDOR 1
-#define apple_HOST_VENDOR 1
-#define BUILD_VENDOR "apple"
-#define HOST_VENDOR "apple"
-
-
-#endif /* __GHCPLATFORM_H__ */
diff --git a/ghc-lib/stage1/compiler/build/ghc_boot_platform.h b/ghc-lib/stage1/compiler/build/ghc_boot_platform.h
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/ghc_boot_platform.h
@@ -0,0 +1,34 @@
+#ifndef __PLATFORM_H__
+#define __PLATFORM_H__
+
+#define BuildPlatform_NAME  "x86_64-apple-darwin"
+#define HostPlatform_NAME   "x86_64-apple-darwin"
+#define TargetPlatform_NAME "x86_64-apple-darwin"
+
+#define x86_64_apple_darwin_BUILD 1
+#define x86_64_apple_darwin_HOST 1
+#define x86_64_apple_darwin_TARGET 1
+
+#define x86_64_BUILD_ARCH 1
+#define x86_64_HOST_ARCH 1
+#define x86_64_TARGET_ARCH 1
+#define BUILD_ARCH "x86_64"
+#define HOST_ARCH "x86_64"
+#define TARGET_ARCH "x86_64"
+#define LLVM_TARGET "x86_64-apple-darwin"
+
+#define darwin_BUILD_OS 1
+#define darwin_HOST_OS 1
+#define darwin_TARGET_OS 1
+#define BUILD_OS "darwin"
+#define HOST_OS "darwin"
+#define TARGET_OS "darwin"
+
+#define apple_BUILD_VENDOR 1
+#define apple_HOST_VENDOR 1
+#define apple_TARGET_VENDOR  1
+#define BUILD_VENDOR "apple"
+#define HOST_VENDOR "apple"
+#define TARGET_VENDOR "apple"
+
+#endif /* __PLATFORM_H__ */
diff --git a/ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl b/ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl
@@ -0,0 +1,231 @@
+primOpCanFail IntQuotOp = True
+primOpCanFail IntRemOp = True
+primOpCanFail IntQuotRemOp = True
+primOpCanFail Int8QuotOp = True
+primOpCanFail Int8RemOp = True
+primOpCanFail Int8QuotRemOp = True
+primOpCanFail Word8QuotOp = True
+primOpCanFail Word8RemOp = True
+primOpCanFail Word8QuotRemOp = True
+primOpCanFail Int16QuotOp = True
+primOpCanFail Int16RemOp = True
+primOpCanFail Int16QuotRemOp = True
+primOpCanFail Word16QuotOp = True
+primOpCanFail Word16RemOp = True
+primOpCanFail Word16QuotRemOp = True
+primOpCanFail WordQuotOp = True
+primOpCanFail WordRemOp = True
+primOpCanFail WordQuotRemOp = True
+primOpCanFail WordQuotRem2Op = True
+primOpCanFail DoubleDivOp = True
+primOpCanFail DoubleLogOp = True
+primOpCanFail DoubleAsinOp = True
+primOpCanFail DoubleAcosOp = True
+primOpCanFail FloatDivOp = True
+primOpCanFail FloatLogOp = True
+primOpCanFail FloatAsinOp = True
+primOpCanFail FloatAcosOp = True
+primOpCanFail ReadArrayOp = True
+primOpCanFail WriteArrayOp = True
+primOpCanFail IndexArrayOp = True
+primOpCanFail CopyArrayOp = True
+primOpCanFail CopyMutableArrayOp = True
+primOpCanFail CloneArrayOp = True
+primOpCanFail CloneMutableArrayOp = True
+primOpCanFail FreezeArrayOp = True
+primOpCanFail ThawArrayOp = True
+primOpCanFail ReadSmallArrayOp = True
+primOpCanFail WriteSmallArrayOp = True
+primOpCanFail IndexSmallArrayOp = True
+primOpCanFail CopySmallArrayOp = True
+primOpCanFail CopySmallMutableArrayOp = True
+primOpCanFail CloneSmallArrayOp = True
+primOpCanFail CloneSmallMutableArrayOp = True
+primOpCanFail FreezeSmallArrayOp = True
+primOpCanFail ThawSmallArrayOp = True
+primOpCanFail IndexByteArrayOp_Char = True
+primOpCanFail IndexByteArrayOp_WideChar = True
+primOpCanFail IndexByteArrayOp_Int = True
+primOpCanFail IndexByteArrayOp_Word = True
+primOpCanFail IndexByteArrayOp_Addr = True
+primOpCanFail IndexByteArrayOp_Float = True
+primOpCanFail IndexByteArrayOp_Double = True
+primOpCanFail IndexByteArrayOp_StablePtr = True
+primOpCanFail IndexByteArrayOp_Int8 = True
+primOpCanFail IndexByteArrayOp_Int16 = True
+primOpCanFail IndexByteArrayOp_Int32 = True
+primOpCanFail IndexByteArrayOp_Int64 = True
+primOpCanFail IndexByteArrayOp_Word8 = True
+primOpCanFail IndexByteArrayOp_Word16 = True
+primOpCanFail IndexByteArrayOp_Word32 = True
+primOpCanFail IndexByteArrayOp_Word64 = True
+primOpCanFail IndexByteArrayOp_Word8AsChar = True
+primOpCanFail IndexByteArrayOp_Word8AsWideChar = True
+primOpCanFail IndexByteArrayOp_Word8AsAddr = True
+primOpCanFail IndexByteArrayOp_Word8AsFloat = True
+primOpCanFail IndexByteArrayOp_Word8AsDouble = True
+primOpCanFail IndexByteArrayOp_Word8AsStablePtr = True
+primOpCanFail IndexByteArrayOp_Word8AsInt16 = True
+primOpCanFail IndexByteArrayOp_Word8AsInt32 = True
+primOpCanFail IndexByteArrayOp_Word8AsInt64 = True
+primOpCanFail IndexByteArrayOp_Word8AsInt = True
+primOpCanFail IndexByteArrayOp_Word8AsWord16 = True
+primOpCanFail IndexByteArrayOp_Word8AsWord32 = True
+primOpCanFail IndexByteArrayOp_Word8AsWord64 = True
+primOpCanFail IndexByteArrayOp_Word8AsWord = True
+primOpCanFail ReadByteArrayOp_Char = True
+primOpCanFail ReadByteArrayOp_WideChar = True
+primOpCanFail ReadByteArrayOp_Int = True
+primOpCanFail ReadByteArrayOp_Word = True
+primOpCanFail ReadByteArrayOp_Addr = True
+primOpCanFail ReadByteArrayOp_Float = True
+primOpCanFail ReadByteArrayOp_Double = True
+primOpCanFail ReadByteArrayOp_StablePtr = True
+primOpCanFail ReadByteArrayOp_Int8 = True
+primOpCanFail ReadByteArrayOp_Int16 = True
+primOpCanFail ReadByteArrayOp_Int32 = True
+primOpCanFail ReadByteArrayOp_Int64 = True
+primOpCanFail ReadByteArrayOp_Word8 = True
+primOpCanFail ReadByteArrayOp_Word16 = True
+primOpCanFail ReadByteArrayOp_Word32 = True
+primOpCanFail ReadByteArrayOp_Word64 = True
+primOpCanFail ReadByteArrayOp_Word8AsChar = True
+primOpCanFail ReadByteArrayOp_Word8AsWideChar = True
+primOpCanFail ReadByteArrayOp_Word8AsAddr = True
+primOpCanFail ReadByteArrayOp_Word8AsFloat = True
+primOpCanFail ReadByteArrayOp_Word8AsDouble = True
+primOpCanFail ReadByteArrayOp_Word8AsStablePtr = True
+primOpCanFail ReadByteArrayOp_Word8AsInt16 = True
+primOpCanFail ReadByteArrayOp_Word8AsInt32 = True
+primOpCanFail ReadByteArrayOp_Word8AsInt64 = True
+primOpCanFail ReadByteArrayOp_Word8AsInt = True
+primOpCanFail ReadByteArrayOp_Word8AsWord16 = True
+primOpCanFail ReadByteArrayOp_Word8AsWord32 = True
+primOpCanFail ReadByteArrayOp_Word8AsWord64 = True
+primOpCanFail ReadByteArrayOp_Word8AsWord = True
+primOpCanFail WriteByteArrayOp_Char = True
+primOpCanFail WriteByteArrayOp_WideChar = True
+primOpCanFail WriteByteArrayOp_Int = True
+primOpCanFail WriteByteArrayOp_Word = True
+primOpCanFail WriteByteArrayOp_Addr = True
+primOpCanFail WriteByteArrayOp_Float = True
+primOpCanFail WriteByteArrayOp_Double = True
+primOpCanFail WriteByteArrayOp_StablePtr = True
+primOpCanFail WriteByteArrayOp_Int8 = True
+primOpCanFail WriteByteArrayOp_Int16 = True
+primOpCanFail WriteByteArrayOp_Int32 = True
+primOpCanFail WriteByteArrayOp_Int64 = True
+primOpCanFail WriteByteArrayOp_Word8 = True
+primOpCanFail WriteByteArrayOp_Word16 = True
+primOpCanFail WriteByteArrayOp_Word32 = True
+primOpCanFail WriteByteArrayOp_Word64 = True
+primOpCanFail WriteByteArrayOp_Word8AsChar = True
+primOpCanFail WriteByteArrayOp_Word8AsWideChar = True
+primOpCanFail WriteByteArrayOp_Word8AsAddr = True
+primOpCanFail WriteByteArrayOp_Word8AsFloat = True
+primOpCanFail WriteByteArrayOp_Word8AsDouble = True
+primOpCanFail WriteByteArrayOp_Word8AsStablePtr = True
+primOpCanFail WriteByteArrayOp_Word8AsInt16 = True
+primOpCanFail WriteByteArrayOp_Word8AsInt32 = True
+primOpCanFail WriteByteArrayOp_Word8AsInt64 = True
+primOpCanFail WriteByteArrayOp_Word8AsInt = True
+primOpCanFail WriteByteArrayOp_Word8AsWord16 = True
+primOpCanFail WriteByteArrayOp_Word8AsWord32 = True
+primOpCanFail WriteByteArrayOp_Word8AsWord64 = True
+primOpCanFail WriteByteArrayOp_Word8AsWord = True
+primOpCanFail CompareByteArraysOp = True
+primOpCanFail CopyByteArrayOp = True
+primOpCanFail CopyMutableByteArrayOp = True
+primOpCanFail CopyByteArrayToAddrOp = True
+primOpCanFail CopyMutableByteArrayToAddrOp = True
+primOpCanFail CopyAddrToByteArrayOp = True
+primOpCanFail SetByteArrayOp = True
+primOpCanFail AtomicReadByteArrayOp_Int = True
+primOpCanFail AtomicWriteByteArrayOp_Int = True
+primOpCanFail CasByteArrayOp_Int = True
+primOpCanFail FetchAddByteArrayOp_Int = True
+primOpCanFail FetchSubByteArrayOp_Int = True
+primOpCanFail FetchAndByteArrayOp_Int = True
+primOpCanFail FetchNandByteArrayOp_Int = True
+primOpCanFail FetchOrByteArrayOp_Int = True
+primOpCanFail FetchXorByteArrayOp_Int = True
+primOpCanFail IndexArrayArrayOp_ByteArray = True
+primOpCanFail IndexArrayArrayOp_ArrayArray = True
+primOpCanFail ReadArrayArrayOp_ByteArray = True
+primOpCanFail ReadArrayArrayOp_MutableByteArray = True
+primOpCanFail ReadArrayArrayOp_ArrayArray = True
+primOpCanFail ReadArrayArrayOp_MutableArrayArray = True
+primOpCanFail WriteArrayArrayOp_ByteArray = True
+primOpCanFail WriteArrayArrayOp_MutableByteArray = True
+primOpCanFail WriteArrayArrayOp_ArrayArray = True
+primOpCanFail WriteArrayArrayOp_MutableArrayArray = True
+primOpCanFail CopyArrayArrayOp = True
+primOpCanFail CopyMutableArrayArrayOp = True
+primOpCanFail IndexOffAddrOp_Char = True
+primOpCanFail IndexOffAddrOp_WideChar = True
+primOpCanFail IndexOffAddrOp_Int = True
+primOpCanFail IndexOffAddrOp_Word = True
+primOpCanFail IndexOffAddrOp_Addr = True
+primOpCanFail IndexOffAddrOp_Float = True
+primOpCanFail IndexOffAddrOp_Double = True
+primOpCanFail IndexOffAddrOp_StablePtr = True
+primOpCanFail IndexOffAddrOp_Int8 = True
+primOpCanFail IndexOffAddrOp_Int16 = True
+primOpCanFail IndexOffAddrOp_Int32 = True
+primOpCanFail IndexOffAddrOp_Int64 = True
+primOpCanFail IndexOffAddrOp_Word8 = True
+primOpCanFail IndexOffAddrOp_Word16 = True
+primOpCanFail IndexOffAddrOp_Word32 = True
+primOpCanFail IndexOffAddrOp_Word64 = True
+primOpCanFail ReadOffAddrOp_Char = True
+primOpCanFail ReadOffAddrOp_WideChar = True
+primOpCanFail ReadOffAddrOp_Int = True
+primOpCanFail ReadOffAddrOp_Word = True
+primOpCanFail ReadOffAddrOp_Addr = True
+primOpCanFail ReadOffAddrOp_Float = True
+primOpCanFail ReadOffAddrOp_Double = True
+primOpCanFail ReadOffAddrOp_StablePtr = True
+primOpCanFail ReadOffAddrOp_Int8 = True
+primOpCanFail ReadOffAddrOp_Int16 = True
+primOpCanFail ReadOffAddrOp_Int32 = True
+primOpCanFail ReadOffAddrOp_Int64 = True
+primOpCanFail ReadOffAddrOp_Word8 = True
+primOpCanFail ReadOffAddrOp_Word16 = True
+primOpCanFail ReadOffAddrOp_Word32 = True
+primOpCanFail ReadOffAddrOp_Word64 = True
+primOpCanFail WriteOffAddrOp_Char = True
+primOpCanFail WriteOffAddrOp_WideChar = True
+primOpCanFail WriteOffAddrOp_Int = True
+primOpCanFail WriteOffAddrOp_Word = True
+primOpCanFail WriteOffAddrOp_Addr = True
+primOpCanFail WriteOffAddrOp_Float = True
+primOpCanFail WriteOffAddrOp_Double = True
+primOpCanFail WriteOffAddrOp_StablePtr = True
+primOpCanFail WriteOffAddrOp_Int8 = True
+primOpCanFail WriteOffAddrOp_Int16 = True
+primOpCanFail WriteOffAddrOp_Int32 = True
+primOpCanFail WriteOffAddrOp_Int64 = True
+primOpCanFail WriteOffAddrOp_Word8 = True
+primOpCanFail WriteOffAddrOp_Word16 = True
+primOpCanFail WriteOffAddrOp_Word32 = True
+primOpCanFail WriteOffAddrOp_Word64 = True
+primOpCanFail AtomicModifyMutVar2Op = True
+primOpCanFail AtomicModifyMutVar_Op = True
+primOpCanFail ReallyUnsafePtrEqualityOp = True
+primOpCanFail (VecInsertOp _ _ _) = True
+primOpCanFail (VecDivOp _ _ _) = True
+primOpCanFail (VecQuotOp _ _ _) = True
+primOpCanFail (VecRemOp _ _ _) = True
+primOpCanFail (VecIndexByteArrayOp _ _ _) = True
+primOpCanFail (VecReadByteArrayOp _ _ _) = True
+primOpCanFail (VecWriteByteArrayOp _ _ _) = True
+primOpCanFail (VecIndexOffAddrOp _ _ _) = True
+primOpCanFail (VecReadOffAddrOp _ _ _) = True
+primOpCanFail (VecWriteOffAddrOp _ _ _) = True
+primOpCanFail (VecIndexScalarByteArrayOp _ _ _) = True
+primOpCanFail (VecReadScalarByteArrayOp _ _ _) = True
+primOpCanFail (VecWriteScalarByteArrayOp _ _ _) = True
+primOpCanFail (VecIndexScalarOffAddrOp _ _ _) = True
+primOpCanFail (VecReadScalarOffAddrOp _ _ _) = True
+primOpCanFail (VecWriteScalarOffAddrOp _ _ _) = True
+primOpCanFail _ = False
diff --git a/ghc-lib/stage1/compiler/build/primop-code-size.hs-incl b/ghc-lib/stage1/compiler/build/primop-code-size.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-code-size.hs-incl
@@ -0,0 +1,57 @@
+primOpCodeSize OrdOp = 0
+primOpCodeSize IntAddCOp = 2
+primOpCodeSize IntSubCOp = 2
+primOpCodeSize ChrOp = 0
+primOpCodeSize Int2WordOp = 0
+primOpCodeSize WordAddCOp = 2
+primOpCodeSize WordSubCOp = 2
+primOpCodeSize WordAdd2Op = 2
+primOpCodeSize Word2IntOp = 0
+primOpCodeSize DoubleExpOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleLogOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleSqrtOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleSinOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleCosOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleTanOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleAsinOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleAcosOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleAtanOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleSinhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleCoshOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleTanhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleAsinhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleAcoshOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoubleAtanhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize DoublePowerOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatExpOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatLogOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatSqrtOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatSinOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatCosOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatTanOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatAsinOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatAcosOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatAtanOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatSinhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatCoshOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatTanhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatAsinhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatAcoshOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatAtanhOp =  primOpCodeSizeForeignCall 
+primOpCodeSize FloatPowerOp =  primOpCodeSizeForeignCall 
+primOpCodeSize WriteArrayOp = 2
+primOpCodeSize CopyByteArrayOp =  primOpCodeSizeForeignCall + 4
+primOpCodeSize CopyMutableByteArrayOp =  primOpCodeSizeForeignCall + 4 
+primOpCodeSize CopyByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4
+primOpCodeSize CopyMutableByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4
+primOpCodeSize CopyAddrToByteArrayOp =  primOpCodeSizeForeignCall + 4
+primOpCodeSize SetByteArrayOp =  primOpCodeSizeForeignCall + 4 
+primOpCodeSize Addr2IntOp = 0
+primOpCodeSize Int2AddrOp = 0
+primOpCodeSize WriteMutVarOp =  primOpCodeSizeForeignCall 
+primOpCodeSize TouchOp =  0 
+primOpCodeSize ParOp =  primOpCodeSizeForeignCall 
+primOpCodeSize SparkOp =  primOpCodeSizeForeignCall 
+primOpCodeSize AddrToAnyOp = 0
+primOpCodeSize AnyToAddrOp = 0
+primOpCodeSize _ =  primOpCodeSizeDefault 
diff --git a/ghc-lib/stage1/compiler/build/primop-commutable.hs-incl b/ghc-lib/stage1/compiler/build/primop-commutable.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-commutable.hs-incl
@@ -0,0 +1,38 @@
+commutableOp CharEqOp = True
+commutableOp CharNeOp = True
+commutableOp IntAddOp = True
+commutableOp IntMulOp = True
+commutableOp IntMulMayOfloOp = True
+commutableOp AndIOp = True
+commutableOp OrIOp = True
+commutableOp XorIOp = True
+commutableOp IntAddCOp = True
+commutableOp IntEqOp = True
+commutableOp IntNeOp = True
+commutableOp Int8AddOp = True
+commutableOp Int8MulOp = True
+commutableOp Word8AddOp = True
+commutableOp Word8MulOp = True
+commutableOp Int16AddOp = True
+commutableOp Int16MulOp = True
+commutableOp Word16AddOp = True
+commutableOp Word16MulOp = True
+commutableOp WordAddOp = True
+commutableOp WordAddCOp = True
+commutableOp WordAdd2Op = True
+commutableOp WordMulOp = True
+commutableOp WordMul2Op = True
+commutableOp AndOp = True
+commutableOp OrOp = True
+commutableOp XorOp = True
+commutableOp DoubleEqOp = True
+commutableOp DoubleNeOp = True
+commutableOp DoubleAddOp = True
+commutableOp DoubleMulOp = True
+commutableOp FloatEqOp = True
+commutableOp FloatNeOp = True
+commutableOp FloatAddOp = True
+commutableOp FloatMulOp = True
+commutableOp (VecAddOp _ _ _) = True
+commutableOp (VecMulOp _ _ _) = True
+commutableOp _ = False
diff --git a/ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl b/ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl
@@ -0,0 +1,574 @@
+data PrimOp
+   = CharGtOp
+   | CharGeOp
+   | CharEqOp
+   | CharNeOp
+   | CharLtOp
+   | CharLeOp
+   | OrdOp
+   | IntAddOp
+   | IntSubOp
+   | IntMulOp
+   | IntMulMayOfloOp
+   | IntQuotOp
+   | IntRemOp
+   | IntQuotRemOp
+   | AndIOp
+   | OrIOp
+   | XorIOp
+   | NotIOp
+   | IntNegOp
+   | IntAddCOp
+   | IntSubCOp
+   | IntGtOp
+   | IntGeOp
+   | IntEqOp
+   | IntNeOp
+   | IntLtOp
+   | IntLeOp
+   | ChrOp
+   | Int2WordOp
+   | Int2FloatOp
+   | Int2DoubleOp
+   | Word2FloatOp
+   | Word2DoubleOp
+   | ISllOp
+   | ISraOp
+   | ISrlOp
+   | Int8Extend
+   | Int8Narrow
+   | Int8NegOp
+   | Int8AddOp
+   | Int8SubOp
+   | Int8MulOp
+   | Int8QuotOp
+   | Int8RemOp
+   | Int8QuotRemOp
+   | Int8EqOp
+   | Int8GeOp
+   | Int8GtOp
+   | Int8LeOp
+   | Int8LtOp
+   | Int8NeOp
+   | Word8Extend
+   | Word8Narrow
+   | Word8NotOp
+   | Word8AddOp
+   | Word8SubOp
+   | Word8MulOp
+   | Word8QuotOp
+   | Word8RemOp
+   | Word8QuotRemOp
+   | Word8EqOp
+   | Word8GeOp
+   | Word8GtOp
+   | Word8LeOp
+   | Word8LtOp
+   | Word8NeOp
+   | Int16Extend
+   | Int16Narrow
+   | Int16NegOp
+   | Int16AddOp
+   | Int16SubOp
+   | Int16MulOp
+   | Int16QuotOp
+   | Int16RemOp
+   | Int16QuotRemOp
+   | Int16EqOp
+   | Int16GeOp
+   | Int16GtOp
+   | Int16LeOp
+   | Int16LtOp
+   | Int16NeOp
+   | Word16Extend
+   | Word16Narrow
+   | Word16NotOp
+   | Word16AddOp
+   | Word16SubOp
+   | Word16MulOp
+   | Word16QuotOp
+   | Word16RemOp
+   | Word16QuotRemOp
+   | Word16EqOp
+   | Word16GeOp
+   | Word16GtOp
+   | Word16LeOp
+   | Word16LtOp
+   | Word16NeOp
+   | WordAddOp
+   | WordAddCOp
+   | WordSubCOp
+   | WordAdd2Op
+   | WordSubOp
+   | WordMulOp
+   | WordMul2Op
+   | WordQuotOp
+   | WordRemOp
+   | WordQuotRemOp
+   | WordQuotRem2Op
+   | AndOp
+   | OrOp
+   | XorOp
+   | NotOp
+   | SllOp
+   | SrlOp
+   | Word2IntOp
+   | WordGtOp
+   | WordGeOp
+   | WordEqOp
+   | WordNeOp
+   | WordLtOp
+   | WordLeOp
+   | PopCnt8Op
+   | PopCnt16Op
+   | PopCnt32Op
+   | PopCnt64Op
+   | PopCntOp
+   | Pdep8Op
+   | Pdep16Op
+   | Pdep32Op
+   | Pdep64Op
+   | PdepOp
+   | Pext8Op
+   | Pext16Op
+   | Pext32Op
+   | Pext64Op
+   | PextOp
+   | Clz8Op
+   | Clz16Op
+   | Clz32Op
+   | Clz64Op
+   | ClzOp
+   | Ctz8Op
+   | Ctz16Op
+   | Ctz32Op
+   | Ctz64Op
+   | CtzOp
+   | BSwap16Op
+   | BSwap32Op
+   | BSwap64Op
+   | BSwapOp
+   | Narrow8IntOp
+   | Narrow16IntOp
+   | Narrow32IntOp
+   | Narrow8WordOp
+   | Narrow16WordOp
+   | Narrow32WordOp
+   | DoubleGtOp
+   | DoubleGeOp
+   | DoubleEqOp
+   | DoubleNeOp
+   | DoubleLtOp
+   | DoubleLeOp
+   | DoubleAddOp
+   | DoubleSubOp
+   | DoubleMulOp
+   | DoubleDivOp
+   | DoubleNegOp
+   | DoubleFabsOp
+   | Double2IntOp
+   | Double2FloatOp
+   | DoubleExpOp
+   | DoubleLogOp
+   | DoubleSqrtOp
+   | DoubleSinOp
+   | DoubleCosOp
+   | DoubleTanOp
+   | DoubleAsinOp
+   | DoubleAcosOp
+   | DoubleAtanOp
+   | DoubleSinhOp
+   | DoubleCoshOp
+   | DoubleTanhOp
+   | DoubleAsinhOp
+   | DoubleAcoshOp
+   | DoubleAtanhOp
+   | DoublePowerOp
+   | DoubleDecode_2IntOp
+   | DoubleDecode_Int64Op
+   | FloatGtOp
+   | FloatGeOp
+   | FloatEqOp
+   | FloatNeOp
+   | FloatLtOp
+   | FloatLeOp
+   | FloatAddOp
+   | FloatSubOp
+   | FloatMulOp
+   | FloatDivOp
+   | FloatNegOp
+   | FloatFabsOp
+   | Float2IntOp
+   | FloatExpOp
+   | FloatLogOp
+   | FloatSqrtOp
+   | FloatSinOp
+   | FloatCosOp
+   | FloatTanOp
+   | FloatAsinOp
+   | FloatAcosOp
+   | FloatAtanOp
+   | FloatSinhOp
+   | FloatCoshOp
+   | FloatTanhOp
+   | FloatAsinhOp
+   | FloatAcoshOp
+   | FloatAtanhOp
+   | FloatPowerOp
+   | Float2DoubleOp
+   | FloatDecode_IntOp
+   | NewArrayOp
+   | SameMutableArrayOp
+   | ReadArrayOp
+   | WriteArrayOp
+   | SizeofArrayOp
+   | SizeofMutableArrayOp
+   | IndexArrayOp
+   | UnsafeFreezeArrayOp
+   | UnsafeThawArrayOp
+   | CopyArrayOp
+   | CopyMutableArrayOp
+   | CloneArrayOp
+   | CloneMutableArrayOp
+   | FreezeArrayOp
+   | ThawArrayOp
+   | CasArrayOp
+   | NewSmallArrayOp
+   | SameSmallMutableArrayOp
+   | ReadSmallArrayOp
+   | WriteSmallArrayOp
+   | SizeofSmallArrayOp
+   | SizeofSmallMutableArrayOp
+   | IndexSmallArrayOp
+   | UnsafeFreezeSmallArrayOp
+   | UnsafeThawSmallArrayOp
+   | CopySmallArrayOp
+   | CopySmallMutableArrayOp
+   | CloneSmallArrayOp
+   | CloneSmallMutableArrayOp
+   | FreezeSmallArrayOp
+   | ThawSmallArrayOp
+   | CasSmallArrayOp
+   | NewByteArrayOp_Char
+   | NewPinnedByteArrayOp_Char
+   | NewAlignedPinnedByteArrayOp_Char
+   | MutableByteArrayIsPinnedOp
+   | ByteArrayIsPinnedOp
+   | ByteArrayContents_Char
+   | SameMutableByteArrayOp
+   | ShrinkMutableByteArrayOp_Char
+   | ResizeMutableByteArrayOp_Char
+   | UnsafeFreezeByteArrayOp
+   | SizeofByteArrayOp
+   | SizeofMutableByteArrayOp
+   | GetSizeofMutableByteArrayOp
+   | IndexByteArrayOp_Char
+   | IndexByteArrayOp_WideChar
+   | IndexByteArrayOp_Int
+   | IndexByteArrayOp_Word
+   | IndexByteArrayOp_Addr
+   | IndexByteArrayOp_Float
+   | IndexByteArrayOp_Double
+   | IndexByteArrayOp_StablePtr
+   | IndexByteArrayOp_Int8
+   | IndexByteArrayOp_Int16
+   | IndexByteArrayOp_Int32
+   | IndexByteArrayOp_Int64
+   | IndexByteArrayOp_Word8
+   | IndexByteArrayOp_Word16
+   | IndexByteArrayOp_Word32
+   | IndexByteArrayOp_Word64
+   | IndexByteArrayOp_Word8AsChar
+   | IndexByteArrayOp_Word8AsWideChar
+   | IndexByteArrayOp_Word8AsAddr
+   | IndexByteArrayOp_Word8AsFloat
+   | IndexByteArrayOp_Word8AsDouble
+   | IndexByteArrayOp_Word8AsStablePtr
+   | IndexByteArrayOp_Word8AsInt16
+   | IndexByteArrayOp_Word8AsInt32
+   | IndexByteArrayOp_Word8AsInt64
+   | IndexByteArrayOp_Word8AsInt
+   | IndexByteArrayOp_Word8AsWord16
+   | IndexByteArrayOp_Word8AsWord32
+   | IndexByteArrayOp_Word8AsWord64
+   | IndexByteArrayOp_Word8AsWord
+   | ReadByteArrayOp_Char
+   | ReadByteArrayOp_WideChar
+   | ReadByteArrayOp_Int
+   | ReadByteArrayOp_Word
+   | ReadByteArrayOp_Addr
+   | ReadByteArrayOp_Float
+   | ReadByteArrayOp_Double
+   | ReadByteArrayOp_StablePtr
+   | ReadByteArrayOp_Int8
+   | ReadByteArrayOp_Int16
+   | ReadByteArrayOp_Int32
+   | ReadByteArrayOp_Int64
+   | ReadByteArrayOp_Word8
+   | ReadByteArrayOp_Word16
+   | ReadByteArrayOp_Word32
+   | ReadByteArrayOp_Word64
+   | ReadByteArrayOp_Word8AsChar
+   | ReadByteArrayOp_Word8AsWideChar
+   | ReadByteArrayOp_Word8AsAddr
+   | ReadByteArrayOp_Word8AsFloat
+   | ReadByteArrayOp_Word8AsDouble
+   | ReadByteArrayOp_Word8AsStablePtr
+   | ReadByteArrayOp_Word8AsInt16
+   | ReadByteArrayOp_Word8AsInt32
+   | ReadByteArrayOp_Word8AsInt64
+   | ReadByteArrayOp_Word8AsInt
+   | ReadByteArrayOp_Word8AsWord16
+   | ReadByteArrayOp_Word8AsWord32
+   | ReadByteArrayOp_Word8AsWord64
+   | ReadByteArrayOp_Word8AsWord
+   | WriteByteArrayOp_Char
+   | WriteByteArrayOp_WideChar
+   | WriteByteArrayOp_Int
+   | WriteByteArrayOp_Word
+   | WriteByteArrayOp_Addr
+   | WriteByteArrayOp_Float
+   | WriteByteArrayOp_Double
+   | WriteByteArrayOp_StablePtr
+   | WriteByteArrayOp_Int8
+   | WriteByteArrayOp_Int16
+   | WriteByteArrayOp_Int32
+   | WriteByteArrayOp_Int64
+   | WriteByteArrayOp_Word8
+   | WriteByteArrayOp_Word16
+   | WriteByteArrayOp_Word32
+   | WriteByteArrayOp_Word64
+   | WriteByteArrayOp_Word8AsChar
+   | WriteByteArrayOp_Word8AsWideChar
+   | WriteByteArrayOp_Word8AsAddr
+   | WriteByteArrayOp_Word8AsFloat
+   | WriteByteArrayOp_Word8AsDouble
+   | WriteByteArrayOp_Word8AsStablePtr
+   | WriteByteArrayOp_Word8AsInt16
+   | WriteByteArrayOp_Word8AsInt32
+   | WriteByteArrayOp_Word8AsInt64
+   | WriteByteArrayOp_Word8AsInt
+   | WriteByteArrayOp_Word8AsWord16
+   | WriteByteArrayOp_Word8AsWord32
+   | WriteByteArrayOp_Word8AsWord64
+   | WriteByteArrayOp_Word8AsWord
+   | CompareByteArraysOp
+   | CopyByteArrayOp
+   | CopyMutableByteArrayOp
+   | CopyByteArrayToAddrOp
+   | CopyMutableByteArrayToAddrOp
+   | CopyAddrToByteArrayOp
+   | SetByteArrayOp
+   | AtomicReadByteArrayOp_Int
+   | AtomicWriteByteArrayOp_Int
+   | CasByteArrayOp_Int
+   | FetchAddByteArrayOp_Int
+   | FetchSubByteArrayOp_Int
+   | FetchAndByteArrayOp_Int
+   | FetchNandByteArrayOp_Int
+   | FetchOrByteArrayOp_Int
+   | FetchXorByteArrayOp_Int
+   | NewArrayArrayOp
+   | SameMutableArrayArrayOp
+   | UnsafeFreezeArrayArrayOp
+   | SizeofArrayArrayOp
+   | SizeofMutableArrayArrayOp
+   | IndexArrayArrayOp_ByteArray
+   | IndexArrayArrayOp_ArrayArray
+   | ReadArrayArrayOp_ByteArray
+   | ReadArrayArrayOp_MutableByteArray
+   | ReadArrayArrayOp_ArrayArray
+   | ReadArrayArrayOp_MutableArrayArray
+   | WriteArrayArrayOp_ByteArray
+   | WriteArrayArrayOp_MutableByteArray
+   | WriteArrayArrayOp_ArrayArray
+   | WriteArrayArrayOp_MutableArrayArray
+   | CopyArrayArrayOp
+   | CopyMutableArrayArrayOp
+   | AddrAddOp
+   | AddrSubOp
+   | AddrRemOp
+   | Addr2IntOp
+   | Int2AddrOp
+   | AddrGtOp
+   | AddrGeOp
+   | AddrEqOp
+   | AddrNeOp
+   | AddrLtOp
+   | AddrLeOp
+   | IndexOffAddrOp_Char
+   | IndexOffAddrOp_WideChar
+   | IndexOffAddrOp_Int
+   | IndexOffAddrOp_Word
+   | IndexOffAddrOp_Addr
+   | IndexOffAddrOp_Float
+   | IndexOffAddrOp_Double
+   | IndexOffAddrOp_StablePtr
+   | IndexOffAddrOp_Int8
+   | IndexOffAddrOp_Int16
+   | IndexOffAddrOp_Int32
+   | IndexOffAddrOp_Int64
+   | IndexOffAddrOp_Word8
+   | IndexOffAddrOp_Word16
+   | IndexOffAddrOp_Word32
+   | IndexOffAddrOp_Word64
+   | ReadOffAddrOp_Char
+   | ReadOffAddrOp_WideChar
+   | ReadOffAddrOp_Int
+   | ReadOffAddrOp_Word
+   | ReadOffAddrOp_Addr
+   | ReadOffAddrOp_Float
+   | ReadOffAddrOp_Double
+   | ReadOffAddrOp_StablePtr
+   | ReadOffAddrOp_Int8
+   | ReadOffAddrOp_Int16
+   | ReadOffAddrOp_Int32
+   | ReadOffAddrOp_Int64
+   | ReadOffAddrOp_Word8
+   | ReadOffAddrOp_Word16
+   | ReadOffAddrOp_Word32
+   | ReadOffAddrOp_Word64
+   | WriteOffAddrOp_Char
+   | WriteOffAddrOp_WideChar
+   | WriteOffAddrOp_Int
+   | WriteOffAddrOp_Word
+   | WriteOffAddrOp_Addr
+   | WriteOffAddrOp_Float
+   | WriteOffAddrOp_Double
+   | WriteOffAddrOp_StablePtr
+   | WriteOffAddrOp_Int8
+   | WriteOffAddrOp_Int16
+   | WriteOffAddrOp_Int32
+   | WriteOffAddrOp_Int64
+   | WriteOffAddrOp_Word8
+   | WriteOffAddrOp_Word16
+   | WriteOffAddrOp_Word32
+   | WriteOffAddrOp_Word64
+   | NewMutVarOp
+   | ReadMutVarOp
+   | WriteMutVarOp
+   | SameMutVarOp
+   | AtomicModifyMutVar2Op
+   | AtomicModifyMutVar_Op
+   | CasMutVarOp
+   | CatchOp
+   | RaiseOp
+   | RaiseIOOp
+   | MaskAsyncExceptionsOp
+   | MaskUninterruptibleOp
+   | UnmaskAsyncExceptionsOp
+   | MaskStatus
+   | AtomicallyOp
+   | RetryOp
+   | CatchRetryOp
+   | CatchSTMOp
+   | NewTVarOp
+   | ReadTVarOp
+   | ReadTVarIOOp
+   | WriteTVarOp
+   | SameTVarOp
+   | NewMVarOp
+   | TakeMVarOp
+   | TryTakeMVarOp
+   | PutMVarOp
+   | TryPutMVarOp
+   | ReadMVarOp
+   | TryReadMVarOp
+   | SameMVarOp
+   | IsEmptyMVarOp
+   | DelayOp
+   | WaitReadOp
+   | WaitWriteOp
+   | ForkOp
+   | ForkOnOp
+   | KillThreadOp
+   | YieldOp
+   | MyThreadIdOp
+   | LabelThreadOp
+   | IsCurrentThreadBoundOp
+   | NoDuplicateOp
+   | ThreadStatusOp
+   | MkWeakOp
+   | MkWeakNoFinalizerOp
+   | AddCFinalizerToWeakOp
+   | DeRefWeakOp
+   | FinalizeWeakOp
+   | TouchOp
+   | MakeStablePtrOp
+   | DeRefStablePtrOp
+   | EqStablePtrOp
+   | MakeStableNameOp
+   | EqStableNameOp
+   | StableNameToIntOp
+   | CompactNewOp
+   | CompactResizeOp
+   | CompactContainsOp
+   | CompactContainsAnyOp
+   | CompactGetFirstBlockOp
+   | CompactGetNextBlockOp
+   | CompactAllocateBlockOp
+   | CompactFixupPointersOp
+   | CompactAdd
+   | CompactAddWithSharing
+   | CompactSize
+   | ReallyUnsafePtrEqualityOp
+   | ParOp
+   | SparkOp
+   | SeqOp
+   | GetSparkOp
+   | NumSparks
+   | DataToTagOp
+   | TagToEnumOp
+   | AddrToAnyOp
+   | AnyToAddrOp
+   | MkApUpd0_Op
+   | NewBCOOp
+   | UnpackClosureOp
+   | GetApStackValOp
+   | GetCCSOfOp
+   | GetCurrentCCSOp
+   | ClearCCSOp
+   | TraceEventOp
+   | TraceEventBinaryOp
+   | TraceMarkerOp
+   | GetThreadAllocationCounter
+   | SetThreadAllocationCounter
+   | VecBroadcastOp PrimOpVecCat Length Width
+   | VecPackOp PrimOpVecCat Length Width
+   | VecUnpackOp PrimOpVecCat Length Width
+   | VecInsertOp PrimOpVecCat Length Width
+   | VecAddOp PrimOpVecCat Length Width
+   | VecSubOp PrimOpVecCat Length Width
+   | VecMulOp PrimOpVecCat Length Width
+   | VecDivOp PrimOpVecCat Length Width
+   | VecQuotOp PrimOpVecCat Length Width
+   | VecRemOp PrimOpVecCat Length Width
+   | VecNegOp PrimOpVecCat Length Width
+   | VecIndexByteArrayOp PrimOpVecCat Length Width
+   | VecReadByteArrayOp PrimOpVecCat Length Width
+   | VecWriteByteArrayOp PrimOpVecCat Length Width
+   | VecIndexOffAddrOp PrimOpVecCat Length Width
+   | VecReadOffAddrOp PrimOpVecCat Length Width
+   | VecWriteOffAddrOp PrimOpVecCat Length Width
+   | VecIndexScalarByteArrayOp PrimOpVecCat Length Width
+   | VecReadScalarByteArrayOp PrimOpVecCat Length Width
+   | VecWriteScalarByteArrayOp PrimOpVecCat Length Width
+   | VecIndexScalarOffAddrOp PrimOpVecCat Length Width
+   | VecReadScalarOffAddrOp PrimOpVecCat Length Width
+   | VecWriteScalarOffAddrOp PrimOpVecCat Length Width
+   | PrefetchByteArrayOp3
+   | PrefetchMutableByteArrayOp3
+   | PrefetchAddrOp3
+   | PrefetchValueOp3
+   | PrefetchByteArrayOp2
+   | PrefetchMutableByteArrayOp2
+   | PrefetchAddrOp2
+   | PrefetchValueOp2
+   | PrefetchByteArrayOp1
+   | PrefetchMutableByteArrayOp1
+   | PrefetchAddrOp1
+   | PrefetchValueOp1
+   | PrefetchByteArrayOp0
+   | PrefetchMutableByteArrayOp0
+   | PrefetchAddrOp0
+   | PrefetchValueOp0
diff --git a/ghc-lib/stage1/compiler/build/primop-fixity.hs-incl b/ghc-lib/stage1/compiler/build/primop-fixity.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-fixity.hs-incl
@@ -0,0 +1,20 @@
+primOpFixity IntAddOp = Just (Fixity NoSourceText 6 InfixL)
+primOpFixity IntSubOp = Just (Fixity NoSourceText 6 InfixL)
+primOpFixity IntMulOp = Just (Fixity NoSourceText 7 InfixL)
+primOpFixity IntGtOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity IntGeOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity IntEqOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity IntNeOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity IntLtOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity IntLeOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity DoubleGtOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity DoubleGeOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity DoubleEqOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity DoubleNeOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity DoubleLtOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity DoubleLeOp = Just (Fixity NoSourceText 4 InfixN)
+primOpFixity DoubleAddOp = Just (Fixity NoSourceText 6 InfixL)
+primOpFixity DoubleSubOp = Just (Fixity NoSourceText 6 InfixL)
+primOpFixity DoubleMulOp = Just (Fixity NoSourceText 7 InfixL)
+primOpFixity DoubleDivOp = Just (Fixity NoSourceText 7 InfixL)
+primOpFixity _ = Nothing
diff --git a/ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl b/ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl
@@ -0,0 +1,242 @@
+primOpHasSideEffects NewArrayOp = True
+primOpHasSideEffects ReadArrayOp = True
+primOpHasSideEffects WriteArrayOp = True
+primOpHasSideEffects UnsafeFreezeArrayOp = True
+primOpHasSideEffects UnsafeThawArrayOp = True
+primOpHasSideEffects CopyArrayOp = True
+primOpHasSideEffects CopyMutableArrayOp = True
+primOpHasSideEffects CloneArrayOp = True
+primOpHasSideEffects CloneMutableArrayOp = True
+primOpHasSideEffects FreezeArrayOp = True
+primOpHasSideEffects ThawArrayOp = True
+primOpHasSideEffects CasArrayOp = True
+primOpHasSideEffects NewSmallArrayOp = True
+primOpHasSideEffects ReadSmallArrayOp = True
+primOpHasSideEffects WriteSmallArrayOp = True
+primOpHasSideEffects UnsafeFreezeSmallArrayOp = True
+primOpHasSideEffects UnsafeThawSmallArrayOp = True
+primOpHasSideEffects CopySmallArrayOp = True
+primOpHasSideEffects CopySmallMutableArrayOp = True
+primOpHasSideEffects CloneSmallArrayOp = True
+primOpHasSideEffects CloneSmallMutableArrayOp = True
+primOpHasSideEffects FreezeSmallArrayOp = True
+primOpHasSideEffects ThawSmallArrayOp = True
+primOpHasSideEffects CasSmallArrayOp = True
+primOpHasSideEffects NewByteArrayOp_Char = True
+primOpHasSideEffects NewPinnedByteArrayOp_Char = True
+primOpHasSideEffects NewAlignedPinnedByteArrayOp_Char = True
+primOpHasSideEffects ShrinkMutableByteArrayOp_Char = True
+primOpHasSideEffects ResizeMutableByteArrayOp_Char = True
+primOpHasSideEffects UnsafeFreezeByteArrayOp = True
+primOpHasSideEffects ReadByteArrayOp_Char = True
+primOpHasSideEffects ReadByteArrayOp_WideChar = True
+primOpHasSideEffects ReadByteArrayOp_Int = True
+primOpHasSideEffects ReadByteArrayOp_Word = True
+primOpHasSideEffects ReadByteArrayOp_Addr = True
+primOpHasSideEffects ReadByteArrayOp_Float = True
+primOpHasSideEffects ReadByteArrayOp_Double = True
+primOpHasSideEffects ReadByteArrayOp_StablePtr = True
+primOpHasSideEffects ReadByteArrayOp_Int8 = True
+primOpHasSideEffects ReadByteArrayOp_Int16 = True
+primOpHasSideEffects ReadByteArrayOp_Int32 = True
+primOpHasSideEffects ReadByteArrayOp_Int64 = True
+primOpHasSideEffects ReadByteArrayOp_Word8 = True
+primOpHasSideEffects ReadByteArrayOp_Word16 = True
+primOpHasSideEffects ReadByteArrayOp_Word32 = True
+primOpHasSideEffects ReadByteArrayOp_Word64 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsChar = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsWideChar = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsAddr = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsFloat = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsDouble = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsStablePtr = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsInt16 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsInt32 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsInt64 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsInt = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsWord16 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsWord32 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsWord64 = True
+primOpHasSideEffects ReadByteArrayOp_Word8AsWord = True
+primOpHasSideEffects WriteByteArrayOp_Char = True
+primOpHasSideEffects WriteByteArrayOp_WideChar = True
+primOpHasSideEffects WriteByteArrayOp_Int = True
+primOpHasSideEffects WriteByteArrayOp_Word = True
+primOpHasSideEffects WriteByteArrayOp_Addr = True
+primOpHasSideEffects WriteByteArrayOp_Float = True
+primOpHasSideEffects WriteByteArrayOp_Double = True
+primOpHasSideEffects WriteByteArrayOp_StablePtr = True
+primOpHasSideEffects WriteByteArrayOp_Int8 = True
+primOpHasSideEffects WriteByteArrayOp_Int16 = True
+primOpHasSideEffects WriteByteArrayOp_Int32 = True
+primOpHasSideEffects WriteByteArrayOp_Int64 = True
+primOpHasSideEffects WriteByteArrayOp_Word8 = True
+primOpHasSideEffects WriteByteArrayOp_Word16 = True
+primOpHasSideEffects WriteByteArrayOp_Word32 = True
+primOpHasSideEffects WriteByteArrayOp_Word64 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsChar = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsWideChar = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsAddr = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsFloat = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsDouble = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsStablePtr = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsInt16 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsInt32 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsInt64 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsInt = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsWord16 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsWord32 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsWord64 = True
+primOpHasSideEffects WriteByteArrayOp_Word8AsWord = True
+primOpHasSideEffects CopyByteArrayOp = True
+primOpHasSideEffects CopyMutableByteArrayOp = True
+primOpHasSideEffects CopyByteArrayToAddrOp = True
+primOpHasSideEffects CopyMutableByteArrayToAddrOp = True
+primOpHasSideEffects CopyAddrToByteArrayOp = True
+primOpHasSideEffects SetByteArrayOp = True
+primOpHasSideEffects AtomicReadByteArrayOp_Int = True
+primOpHasSideEffects AtomicWriteByteArrayOp_Int = True
+primOpHasSideEffects CasByteArrayOp_Int = True
+primOpHasSideEffects FetchAddByteArrayOp_Int = True
+primOpHasSideEffects FetchSubByteArrayOp_Int = True
+primOpHasSideEffects FetchAndByteArrayOp_Int = True
+primOpHasSideEffects FetchNandByteArrayOp_Int = True
+primOpHasSideEffects FetchOrByteArrayOp_Int = True
+primOpHasSideEffects FetchXorByteArrayOp_Int = True
+primOpHasSideEffects NewArrayArrayOp = True
+primOpHasSideEffects UnsafeFreezeArrayArrayOp = True
+primOpHasSideEffects ReadArrayArrayOp_ByteArray = True
+primOpHasSideEffects ReadArrayArrayOp_MutableByteArray = True
+primOpHasSideEffects ReadArrayArrayOp_ArrayArray = True
+primOpHasSideEffects ReadArrayArrayOp_MutableArrayArray = True
+primOpHasSideEffects WriteArrayArrayOp_ByteArray = True
+primOpHasSideEffects WriteArrayArrayOp_MutableByteArray = True
+primOpHasSideEffects WriteArrayArrayOp_ArrayArray = True
+primOpHasSideEffects WriteArrayArrayOp_MutableArrayArray = True
+primOpHasSideEffects CopyArrayArrayOp = True
+primOpHasSideEffects CopyMutableArrayArrayOp = True
+primOpHasSideEffects ReadOffAddrOp_Char = True
+primOpHasSideEffects ReadOffAddrOp_WideChar = True
+primOpHasSideEffects ReadOffAddrOp_Int = True
+primOpHasSideEffects ReadOffAddrOp_Word = True
+primOpHasSideEffects ReadOffAddrOp_Addr = True
+primOpHasSideEffects ReadOffAddrOp_Float = True
+primOpHasSideEffects ReadOffAddrOp_Double = True
+primOpHasSideEffects ReadOffAddrOp_StablePtr = True
+primOpHasSideEffects ReadOffAddrOp_Int8 = True
+primOpHasSideEffects ReadOffAddrOp_Int16 = True
+primOpHasSideEffects ReadOffAddrOp_Int32 = True
+primOpHasSideEffects ReadOffAddrOp_Int64 = True
+primOpHasSideEffects ReadOffAddrOp_Word8 = True
+primOpHasSideEffects ReadOffAddrOp_Word16 = True
+primOpHasSideEffects ReadOffAddrOp_Word32 = True
+primOpHasSideEffects ReadOffAddrOp_Word64 = True
+primOpHasSideEffects WriteOffAddrOp_Char = True
+primOpHasSideEffects WriteOffAddrOp_WideChar = True
+primOpHasSideEffects WriteOffAddrOp_Int = True
+primOpHasSideEffects WriteOffAddrOp_Word = True
+primOpHasSideEffects WriteOffAddrOp_Addr = True
+primOpHasSideEffects WriteOffAddrOp_Float = True
+primOpHasSideEffects WriteOffAddrOp_Double = True
+primOpHasSideEffects WriteOffAddrOp_StablePtr = True
+primOpHasSideEffects WriteOffAddrOp_Int8 = True
+primOpHasSideEffects WriteOffAddrOp_Int16 = True
+primOpHasSideEffects WriteOffAddrOp_Int32 = True
+primOpHasSideEffects WriteOffAddrOp_Int64 = True
+primOpHasSideEffects WriteOffAddrOp_Word8 = True
+primOpHasSideEffects WriteOffAddrOp_Word16 = True
+primOpHasSideEffects WriteOffAddrOp_Word32 = True
+primOpHasSideEffects WriteOffAddrOp_Word64 = True
+primOpHasSideEffects NewMutVarOp = True
+primOpHasSideEffects ReadMutVarOp = True
+primOpHasSideEffects WriteMutVarOp = True
+primOpHasSideEffects AtomicModifyMutVar2Op = True
+primOpHasSideEffects AtomicModifyMutVar_Op = True
+primOpHasSideEffects CasMutVarOp = True
+primOpHasSideEffects CatchOp = True
+primOpHasSideEffects RaiseOp = True
+primOpHasSideEffects RaiseIOOp = True
+primOpHasSideEffects MaskAsyncExceptionsOp = True
+primOpHasSideEffects MaskUninterruptibleOp = True
+primOpHasSideEffects UnmaskAsyncExceptionsOp = True
+primOpHasSideEffects MaskStatus = True
+primOpHasSideEffects AtomicallyOp = True
+primOpHasSideEffects RetryOp = True
+primOpHasSideEffects CatchRetryOp = True
+primOpHasSideEffects CatchSTMOp = True
+primOpHasSideEffects NewTVarOp = True
+primOpHasSideEffects ReadTVarOp = True
+primOpHasSideEffects ReadTVarIOOp = True
+primOpHasSideEffects WriteTVarOp = True
+primOpHasSideEffects NewMVarOp = True
+primOpHasSideEffects TakeMVarOp = True
+primOpHasSideEffects TryTakeMVarOp = True
+primOpHasSideEffects PutMVarOp = True
+primOpHasSideEffects TryPutMVarOp = True
+primOpHasSideEffects ReadMVarOp = True
+primOpHasSideEffects TryReadMVarOp = True
+primOpHasSideEffects IsEmptyMVarOp = True
+primOpHasSideEffects DelayOp = True
+primOpHasSideEffects WaitReadOp = True
+primOpHasSideEffects WaitWriteOp = True
+primOpHasSideEffects ForkOp = True
+primOpHasSideEffects ForkOnOp = True
+primOpHasSideEffects KillThreadOp = True
+primOpHasSideEffects YieldOp = True
+primOpHasSideEffects MyThreadIdOp = True
+primOpHasSideEffects LabelThreadOp = True
+primOpHasSideEffects IsCurrentThreadBoundOp = True
+primOpHasSideEffects NoDuplicateOp = True
+primOpHasSideEffects ThreadStatusOp = True
+primOpHasSideEffects MkWeakOp = True
+primOpHasSideEffects MkWeakNoFinalizerOp = True
+primOpHasSideEffects AddCFinalizerToWeakOp = True
+primOpHasSideEffects DeRefWeakOp = True
+primOpHasSideEffects FinalizeWeakOp = True
+primOpHasSideEffects TouchOp = True
+primOpHasSideEffects MakeStablePtrOp = True
+primOpHasSideEffects DeRefStablePtrOp = True
+primOpHasSideEffects EqStablePtrOp = True
+primOpHasSideEffects MakeStableNameOp = True
+primOpHasSideEffects CompactNewOp = True
+primOpHasSideEffects CompactResizeOp = True
+primOpHasSideEffects CompactAllocateBlockOp = True
+primOpHasSideEffects CompactFixupPointersOp = True
+primOpHasSideEffects CompactAdd = True
+primOpHasSideEffects CompactAddWithSharing = True
+primOpHasSideEffects CompactSize = True
+primOpHasSideEffects ParOp = True
+primOpHasSideEffects SparkOp = True
+primOpHasSideEffects GetSparkOp = True
+primOpHasSideEffects NumSparks = True
+primOpHasSideEffects NewBCOOp = True
+primOpHasSideEffects TraceEventOp = True
+primOpHasSideEffects TraceEventBinaryOp = True
+primOpHasSideEffects TraceMarkerOp = True
+primOpHasSideEffects GetThreadAllocationCounter = True
+primOpHasSideEffects SetThreadAllocationCounter = True
+primOpHasSideEffects (VecReadByteArrayOp _ _ _) = True
+primOpHasSideEffects (VecWriteByteArrayOp _ _ _) = True
+primOpHasSideEffects (VecReadOffAddrOp _ _ _) = True
+primOpHasSideEffects (VecWriteOffAddrOp _ _ _) = True
+primOpHasSideEffects (VecReadScalarByteArrayOp _ _ _) = True
+primOpHasSideEffects (VecWriteScalarByteArrayOp _ _ _) = True
+primOpHasSideEffects (VecReadScalarOffAddrOp _ _ _) = True
+primOpHasSideEffects (VecWriteScalarOffAddrOp _ _ _) = True
+primOpHasSideEffects PrefetchByteArrayOp3 = True
+primOpHasSideEffects PrefetchMutableByteArrayOp3 = True
+primOpHasSideEffects PrefetchAddrOp3 = True
+primOpHasSideEffects PrefetchValueOp3 = True
+primOpHasSideEffects PrefetchByteArrayOp2 = True
+primOpHasSideEffects PrefetchMutableByteArrayOp2 = True
+primOpHasSideEffects PrefetchAddrOp2 = True
+primOpHasSideEffects PrefetchValueOp2 = True
+primOpHasSideEffects PrefetchByteArrayOp1 = True
+primOpHasSideEffects PrefetchMutableByteArrayOp1 = True
+primOpHasSideEffects PrefetchAddrOp1 = True
+primOpHasSideEffects PrefetchValueOp1 = True
+primOpHasSideEffects PrefetchByteArrayOp0 = True
+primOpHasSideEffects PrefetchMutableByteArrayOp0 = True
+primOpHasSideEffects PrefetchAddrOp0 = True
+primOpHasSideEffects PrefetchValueOp0 = True
+primOpHasSideEffects _ = False
diff --git a/ghc-lib/stage1/compiler/build/primop-list.hs-incl b/ghc-lib/stage1/compiler/build/primop-list.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-list.hs-incl
@@ -0,0 +1,1193 @@
+   [CharGtOp
+   , CharGeOp
+   , CharEqOp
+   , CharNeOp
+   , CharLtOp
+   , CharLeOp
+   , OrdOp
+   , IntAddOp
+   , IntSubOp
+   , IntMulOp
+   , IntMulMayOfloOp
+   , IntQuotOp
+   , IntRemOp
+   , IntQuotRemOp
+   , AndIOp
+   , OrIOp
+   , XorIOp
+   , NotIOp
+   , IntNegOp
+   , IntAddCOp
+   , IntSubCOp
+   , IntGtOp
+   , IntGeOp
+   , IntEqOp
+   , IntNeOp
+   , IntLtOp
+   , IntLeOp
+   , ChrOp
+   , Int2WordOp
+   , Int2FloatOp
+   , Int2DoubleOp
+   , Word2FloatOp
+   , Word2DoubleOp
+   , ISllOp
+   , ISraOp
+   , ISrlOp
+   , Int8Extend
+   , Int8Narrow
+   , Int8NegOp
+   , Int8AddOp
+   , Int8SubOp
+   , Int8MulOp
+   , Int8QuotOp
+   , Int8RemOp
+   , Int8QuotRemOp
+   , Int8EqOp
+   , Int8GeOp
+   , Int8GtOp
+   , Int8LeOp
+   , Int8LtOp
+   , Int8NeOp
+   , Word8Extend
+   , Word8Narrow
+   , Word8NotOp
+   , Word8AddOp
+   , Word8SubOp
+   , Word8MulOp
+   , Word8QuotOp
+   , Word8RemOp
+   , Word8QuotRemOp
+   , Word8EqOp
+   , Word8GeOp
+   , Word8GtOp
+   , Word8LeOp
+   , Word8LtOp
+   , Word8NeOp
+   , Int16Extend
+   , Int16Narrow
+   , Int16NegOp
+   , Int16AddOp
+   , Int16SubOp
+   , Int16MulOp
+   , Int16QuotOp
+   , Int16RemOp
+   , Int16QuotRemOp
+   , Int16EqOp
+   , Int16GeOp
+   , Int16GtOp
+   , Int16LeOp
+   , Int16LtOp
+   , Int16NeOp
+   , Word16Extend
+   , Word16Narrow
+   , Word16NotOp
+   , Word16AddOp
+   , Word16SubOp
+   , Word16MulOp
+   , Word16QuotOp
+   , Word16RemOp
+   , Word16QuotRemOp
+   , Word16EqOp
+   , Word16GeOp
+   , Word16GtOp
+   , Word16LeOp
+   , Word16LtOp
+   , Word16NeOp
+   , WordAddOp
+   , WordAddCOp
+   , WordSubCOp
+   , WordAdd2Op
+   , WordSubOp
+   , WordMulOp
+   , WordMul2Op
+   , WordQuotOp
+   , WordRemOp
+   , WordQuotRemOp
+   , WordQuotRem2Op
+   , AndOp
+   , OrOp
+   , XorOp
+   , NotOp
+   , SllOp
+   , SrlOp
+   , Word2IntOp
+   , WordGtOp
+   , WordGeOp
+   , WordEqOp
+   , WordNeOp
+   , WordLtOp
+   , WordLeOp
+   , PopCnt8Op
+   , PopCnt16Op
+   , PopCnt32Op
+   , PopCnt64Op
+   , PopCntOp
+   , Pdep8Op
+   , Pdep16Op
+   , Pdep32Op
+   , Pdep64Op
+   , PdepOp
+   , Pext8Op
+   , Pext16Op
+   , Pext32Op
+   , Pext64Op
+   , PextOp
+   , Clz8Op
+   , Clz16Op
+   , Clz32Op
+   , Clz64Op
+   , ClzOp
+   , Ctz8Op
+   , Ctz16Op
+   , Ctz32Op
+   , Ctz64Op
+   , CtzOp
+   , BSwap16Op
+   , BSwap32Op
+   , BSwap64Op
+   , BSwapOp
+   , Narrow8IntOp
+   , Narrow16IntOp
+   , Narrow32IntOp
+   , Narrow8WordOp
+   , Narrow16WordOp
+   , Narrow32WordOp
+   , DoubleGtOp
+   , DoubleGeOp
+   , DoubleEqOp
+   , DoubleNeOp
+   , DoubleLtOp
+   , DoubleLeOp
+   , DoubleAddOp
+   , DoubleSubOp
+   , DoubleMulOp
+   , DoubleDivOp
+   , DoubleNegOp
+   , DoubleFabsOp
+   , Double2IntOp
+   , Double2FloatOp
+   , DoubleExpOp
+   , DoubleLogOp
+   , DoubleSqrtOp
+   , DoubleSinOp
+   , DoubleCosOp
+   , DoubleTanOp
+   , DoubleAsinOp
+   , DoubleAcosOp
+   , DoubleAtanOp
+   , DoubleSinhOp
+   , DoubleCoshOp
+   , DoubleTanhOp
+   , DoubleAsinhOp
+   , DoubleAcoshOp
+   , DoubleAtanhOp
+   , DoublePowerOp
+   , DoubleDecode_2IntOp
+   , DoubleDecode_Int64Op
+   , FloatGtOp
+   , FloatGeOp
+   , FloatEqOp
+   , FloatNeOp
+   , FloatLtOp
+   , FloatLeOp
+   , FloatAddOp
+   , FloatSubOp
+   , FloatMulOp
+   , FloatDivOp
+   , FloatNegOp
+   , FloatFabsOp
+   , Float2IntOp
+   , FloatExpOp
+   , FloatLogOp
+   , FloatSqrtOp
+   , FloatSinOp
+   , FloatCosOp
+   , FloatTanOp
+   , FloatAsinOp
+   , FloatAcosOp
+   , FloatAtanOp
+   , FloatSinhOp
+   , FloatCoshOp
+   , FloatTanhOp
+   , FloatAsinhOp
+   , FloatAcoshOp
+   , FloatAtanhOp
+   , FloatPowerOp
+   , Float2DoubleOp
+   , FloatDecode_IntOp
+   , NewArrayOp
+   , SameMutableArrayOp
+   , ReadArrayOp
+   , WriteArrayOp
+   , SizeofArrayOp
+   , SizeofMutableArrayOp
+   , IndexArrayOp
+   , UnsafeFreezeArrayOp
+   , UnsafeThawArrayOp
+   , CopyArrayOp
+   , CopyMutableArrayOp
+   , CloneArrayOp
+   , CloneMutableArrayOp
+   , FreezeArrayOp
+   , ThawArrayOp
+   , CasArrayOp
+   , NewSmallArrayOp
+   , SameSmallMutableArrayOp
+   , ReadSmallArrayOp
+   , WriteSmallArrayOp
+   , SizeofSmallArrayOp
+   , SizeofSmallMutableArrayOp
+   , IndexSmallArrayOp
+   , UnsafeFreezeSmallArrayOp
+   , UnsafeThawSmallArrayOp
+   , CopySmallArrayOp
+   , CopySmallMutableArrayOp
+   , CloneSmallArrayOp
+   , CloneSmallMutableArrayOp
+   , FreezeSmallArrayOp
+   , ThawSmallArrayOp
+   , CasSmallArrayOp
+   , NewByteArrayOp_Char
+   , NewPinnedByteArrayOp_Char
+   , NewAlignedPinnedByteArrayOp_Char
+   , MutableByteArrayIsPinnedOp
+   , ByteArrayIsPinnedOp
+   , ByteArrayContents_Char
+   , SameMutableByteArrayOp
+   , ShrinkMutableByteArrayOp_Char
+   , ResizeMutableByteArrayOp_Char
+   , UnsafeFreezeByteArrayOp
+   , SizeofByteArrayOp
+   , SizeofMutableByteArrayOp
+   , GetSizeofMutableByteArrayOp
+   , IndexByteArrayOp_Char
+   , IndexByteArrayOp_WideChar
+   , IndexByteArrayOp_Int
+   , IndexByteArrayOp_Word
+   , IndexByteArrayOp_Addr
+   , IndexByteArrayOp_Float
+   , IndexByteArrayOp_Double
+   , IndexByteArrayOp_StablePtr
+   , IndexByteArrayOp_Int8
+   , IndexByteArrayOp_Int16
+   , IndexByteArrayOp_Int32
+   , IndexByteArrayOp_Int64
+   , IndexByteArrayOp_Word8
+   , IndexByteArrayOp_Word16
+   , IndexByteArrayOp_Word32
+   , IndexByteArrayOp_Word64
+   , IndexByteArrayOp_Word8AsChar
+   , IndexByteArrayOp_Word8AsWideChar
+   , IndexByteArrayOp_Word8AsAddr
+   , IndexByteArrayOp_Word8AsFloat
+   , IndexByteArrayOp_Word8AsDouble
+   , IndexByteArrayOp_Word8AsStablePtr
+   , IndexByteArrayOp_Word8AsInt16
+   , IndexByteArrayOp_Word8AsInt32
+   , IndexByteArrayOp_Word8AsInt64
+   , IndexByteArrayOp_Word8AsInt
+   , IndexByteArrayOp_Word8AsWord16
+   , IndexByteArrayOp_Word8AsWord32
+   , IndexByteArrayOp_Word8AsWord64
+   , IndexByteArrayOp_Word8AsWord
+   , ReadByteArrayOp_Char
+   , ReadByteArrayOp_WideChar
+   , ReadByteArrayOp_Int
+   , ReadByteArrayOp_Word
+   , ReadByteArrayOp_Addr
+   , ReadByteArrayOp_Float
+   , ReadByteArrayOp_Double
+   , ReadByteArrayOp_StablePtr
+   , ReadByteArrayOp_Int8
+   , ReadByteArrayOp_Int16
+   , ReadByteArrayOp_Int32
+   , ReadByteArrayOp_Int64
+   , ReadByteArrayOp_Word8
+   , ReadByteArrayOp_Word16
+   , ReadByteArrayOp_Word32
+   , ReadByteArrayOp_Word64
+   , ReadByteArrayOp_Word8AsChar
+   , ReadByteArrayOp_Word8AsWideChar
+   , ReadByteArrayOp_Word8AsAddr
+   , ReadByteArrayOp_Word8AsFloat
+   , ReadByteArrayOp_Word8AsDouble
+   , ReadByteArrayOp_Word8AsStablePtr
+   , ReadByteArrayOp_Word8AsInt16
+   , ReadByteArrayOp_Word8AsInt32
+   , ReadByteArrayOp_Word8AsInt64
+   , ReadByteArrayOp_Word8AsInt
+   , ReadByteArrayOp_Word8AsWord16
+   , ReadByteArrayOp_Word8AsWord32
+   , ReadByteArrayOp_Word8AsWord64
+   , ReadByteArrayOp_Word8AsWord
+   , WriteByteArrayOp_Char
+   , WriteByteArrayOp_WideChar
+   , WriteByteArrayOp_Int
+   , WriteByteArrayOp_Word
+   , WriteByteArrayOp_Addr
+   , WriteByteArrayOp_Float
+   , WriteByteArrayOp_Double
+   , WriteByteArrayOp_StablePtr
+   , WriteByteArrayOp_Int8
+   , WriteByteArrayOp_Int16
+   , WriteByteArrayOp_Int32
+   , WriteByteArrayOp_Int64
+   , WriteByteArrayOp_Word8
+   , WriteByteArrayOp_Word16
+   , WriteByteArrayOp_Word32
+   , WriteByteArrayOp_Word64
+   , WriteByteArrayOp_Word8AsChar
+   , WriteByteArrayOp_Word8AsWideChar
+   , WriteByteArrayOp_Word8AsAddr
+   , WriteByteArrayOp_Word8AsFloat
+   , WriteByteArrayOp_Word8AsDouble
+   , WriteByteArrayOp_Word8AsStablePtr
+   , WriteByteArrayOp_Word8AsInt16
+   , WriteByteArrayOp_Word8AsInt32
+   , WriteByteArrayOp_Word8AsInt64
+   , WriteByteArrayOp_Word8AsInt
+   , WriteByteArrayOp_Word8AsWord16
+   , WriteByteArrayOp_Word8AsWord32
+   , WriteByteArrayOp_Word8AsWord64
+   , WriteByteArrayOp_Word8AsWord
+   , CompareByteArraysOp
+   , CopyByteArrayOp
+   , CopyMutableByteArrayOp
+   , CopyByteArrayToAddrOp
+   , CopyMutableByteArrayToAddrOp
+   , CopyAddrToByteArrayOp
+   , SetByteArrayOp
+   , AtomicReadByteArrayOp_Int
+   , AtomicWriteByteArrayOp_Int
+   , CasByteArrayOp_Int
+   , FetchAddByteArrayOp_Int
+   , FetchSubByteArrayOp_Int
+   , FetchAndByteArrayOp_Int
+   , FetchNandByteArrayOp_Int
+   , FetchOrByteArrayOp_Int
+   , FetchXorByteArrayOp_Int
+   , NewArrayArrayOp
+   , SameMutableArrayArrayOp
+   , UnsafeFreezeArrayArrayOp
+   , SizeofArrayArrayOp
+   , SizeofMutableArrayArrayOp
+   , IndexArrayArrayOp_ByteArray
+   , IndexArrayArrayOp_ArrayArray
+   , ReadArrayArrayOp_ByteArray
+   , ReadArrayArrayOp_MutableByteArray
+   , ReadArrayArrayOp_ArrayArray
+   , ReadArrayArrayOp_MutableArrayArray
+   , WriteArrayArrayOp_ByteArray
+   , WriteArrayArrayOp_MutableByteArray
+   , WriteArrayArrayOp_ArrayArray
+   , WriteArrayArrayOp_MutableArrayArray
+   , CopyArrayArrayOp
+   , CopyMutableArrayArrayOp
+   , AddrAddOp
+   , AddrSubOp
+   , AddrRemOp
+   , Addr2IntOp
+   , Int2AddrOp
+   , AddrGtOp
+   , AddrGeOp
+   , AddrEqOp
+   , AddrNeOp
+   , AddrLtOp
+   , AddrLeOp
+   , IndexOffAddrOp_Char
+   , IndexOffAddrOp_WideChar
+   , IndexOffAddrOp_Int
+   , IndexOffAddrOp_Word
+   , IndexOffAddrOp_Addr
+   , IndexOffAddrOp_Float
+   , IndexOffAddrOp_Double
+   , IndexOffAddrOp_StablePtr
+   , IndexOffAddrOp_Int8
+   , IndexOffAddrOp_Int16
+   , IndexOffAddrOp_Int32
+   , IndexOffAddrOp_Int64
+   , IndexOffAddrOp_Word8
+   , IndexOffAddrOp_Word16
+   , IndexOffAddrOp_Word32
+   , IndexOffAddrOp_Word64
+   , ReadOffAddrOp_Char
+   , ReadOffAddrOp_WideChar
+   , ReadOffAddrOp_Int
+   , ReadOffAddrOp_Word
+   , ReadOffAddrOp_Addr
+   , ReadOffAddrOp_Float
+   , ReadOffAddrOp_Double
+   , ReadOffAddrOp_StablePtr
+   , ReadOffAddrOp_Int8
+   , ReadOffAddrOp_Int16
+   , ReadOffAddrOp_Int32
+   , ReadOffAddrOp_Int64
+   , ReadOffAddrOp_Word8
+   , ReadOffAddrOp_Word16
+   , ReadOffAddrOp_Word32
+   , ReadOffAddrOp_Word64
+   , WriteOffAddrOp_Char
+   , WriteOffAddrOp_WideChar
+   , WriteOffAddrOp_Int
+   , WriteOffAddrOp_Word
+   , WriteOffAddrOp_Addr
+   , WriteOffAddrOp_Float
+   , WriteOffAddrOp_Double
+   , WriteOffAddrOp_StablePtr
+   , WriteOffAddrOp_Int8
+   , WriteOffAddrOp_Int16
+   , WriteOffAddrOp_Int32
+   , WriteOffAddrOp_Int64
+   , WriteOffAddrOp_Word8
+   , WriteOffAddrOp_Word16
+   , WriteOffAddrOp_Word32
+   , WriteOffAddrOp_Word64
+   , NewMutVarOp
+   , ReadMutVarOp
+   , WriteMutVarOp
+   , SameMutVarOp
+   , AtomicModifyMutVar2Op
+   , AtomicModifyMutVar_Op
+   , CasMutVarOp
+   , CatchOp
+   , RaiseOp
+   , RaiseIOOp
+   , MaskAsyncExceptionsOp
+   , MaskUninterruptibleOp
+   , UnmaskAsyncExceptionsOp
+   , MaskStatus
+   , AtomicallyOp
+   , RetryOp
+   , CatchRetryOp
+   , CatchSTMOp
+   , NewTVarOp
+   , ReadTVarOp
+   , ReadTVarIOOp
+   , WriteTVarOp
+   , SameTVarOp
+   , NewMVarOp
+   , TakeMVarOp
+   , TryTakeMVarOp
+   , PutMVarOp
+   , TryPutMVarOp
+   , ReadMVarOp
+   , TryReadMVarOp
+   , SameMVarOp
+   , IsEmptyMVarOp
+   , DelayOp
+   , WaitReadOp
+   , WaitWriteOp
+   , ForkOp
+   , ForkOnOp
+   , KillThreadOp
+   , YieldOp
+   , MyThreadIdOp
+   , LabelThreadOp
+   , IsCurrentThreadBoundOp
+   , NoDuplicateOp
+   , ThreadStatusOp
+   , MkWeakOp
+   , MkWeakNoFinalizerOp
+   , AddCFinalizerToWeakOp
+   , DeRefWeakOp
+   , FinalizeWeakOp
+   , TouchOp
+   , MakeStablePtrOp
+   , DeRefStablePtrOp
+   , EqStablePtrOp
+   , MakeStableNameOp
+   , EqStableNameOp
+   , StableNameToIntOp
+   , CompactNewOp
+   , CompactResizeOp
+   , CompactContainsOp
+   , CompactContainsAnyOp
+   , CompactGetFirstBlockOp
+   , CompactGetNextBlockOp
+   , CompactAllocateBlockOp
+   , CompactFixupPointersOp
+   , CompactAdd
+   , CompactAddWithSharing
+   , CompactSize
+   , ReallyUnsafePtrEqualityOp
+   , ParOp
+   , SparkOp
+   , SeqOp
+   , GetSparkOp
+   , NumSparks
+   , DataToTagOp
+   , TagToEnumOp
+   , AddrToAnyOp
+   , AnyToAddrOp
+   , MkApUpd0_Op
+   , NewBCOOp
+   , UnpackClosureOp
+   , GetApStackValOp
+   , GetCCSOfOp
+   , GetCurrentCCSOp
+   , ClearCCSOp
+   , TraceEventOp
+   , TraceEventBinaryOp
+   , TraceMarkerOp
+   , GetThreadAllocationCounter
+   , SetThreadAllocationCounter
+   , (VecBroadcastOp IntVec 16 W8)
+   , (VecBroadcastOp IntVec 8 W16)
+   , (VecBroadcastOp IntVec 4 W32)
+   , (VecBroadcastOp IntVec 2 W64)
+   , (VecBroadcastOp IntVec 32 W8)
+   , (VecBroadcastOp IntVec 16 W16)
+   , (VecBroadcastOp IntVec 8 W32)
+   , (VecBroadcastOp IntVec 4 W64)
+   , (VecBroadcastOp IntVec 64 W8)
+   , (VecBroadcastOp IntVec 32 W16)
+   , (VecBroadcastOp IntVec 16 W32)
+   , (VecBroadcastOp IntVec 8 W64)
+   , (VecBroadcastOp WordVec 16 W8)
+   , (VecBroadcastOp WordVec 8 W16)
+   , (VecBroadcastOp WordVec 4 W32)
+   , (VecBroadcastOp WordVec 2 W64)
+   , (VecBroadcastOp WordVec 32 W8)
+   , (VecBroadcastOp WordVec 16 W16)
+   , (VecBroadcastOp WordVec 8 W32)
+   , (VecBroadcastOp WordVec 4 W64)
+   , (VecBroadcastOp WordVec 64 W8)
+   , (VecBroadcastOp WordVec 32 W16)
+   , (VecBroadcastOp WordVec 16 W32)
+   , (VecBroadcastOp WordVec 8 W64)
+   , (VecBroadcastOp FloatVec 4 W32)
+   , (VecBroadcastOp FloatVec 2 W64)
+   , (VecBroadcastOp FloatVec 8 W32)
+   , (VecBroadcastOp FloatVec 4 W64)
+   , (VecBroadcastOp FloatVec 16 W32)
+   , (VecBroadcastOp FloatVec 8 W64)
+   , (VecPackOp IntVec 16 W8)
+   , (VecPackOp IntVec 8 W16)
+   , (VecPackOp IntVec 4 W32)
+   , (VecPackOp IntVec 2 W64)
+   , (VecPackOp IntVec 32 W8)
+   , (VecPackOp IntVec 16 W16)
+   , (VecPackOp IntVec 8 W32)
+   , (VecPackOp IntVec 4 W64)
+   , (VecPackOp IntVec 64 W8)
+   , (VecPackOp IntVec 32 W16)
+   , (VecPackOp IntVec 16 W32)
+   , (VecPackOp IntVec 8 W64)
+   , (VecPackOp WordVec 16 W8)
+   , (VecPackOp WordVec 8 W16)
+   , (VecPackOp WordVec 4 W32)
+   , (VecPackOp WordVec 2 W64)
+   , (VecPackOp WordVec 32 W8)
+   , (VecPackOp WordVec 16 W16)
+   , (VecPackOp WordVec 8 W32)
+   , (VecPackOp WordVec 4 W64)
+   , (VecPackOp WordVec 64 W8)
+   , (VecPackOp WordVec 32 W16)
+   , (VecPackOp WordVec 16 W32)
+   , (VecPackOp WordVec 8 W64)
+   , (VecPackOp FloatVec 4 W32)
+   , (VecPackOp FloatVec 2 W64)
+   , (VecPackOp FloatVec 8 W32)
+   , (VecPackOp FloatVec 4 W64)
+   , (VecPackOp FloatVec 16 W32)
+   , (VecPackOp FloatVec 8 W64)
+   , (VecUnpackOp IntVec 16 W8)
+   , (VecUnpackOp IntVec 8 W16)
+   , (VecUnpackOp IntVec 4 W32)
+   , (VecUnpackOp IntVec 2 W64)
+   , (VecUnpackOp IntVec 32 W8)
+   , (VecUnpackOp IntVec 16 W16)
+   , (VecUnpackOp IntVec 8 W32)
+   , (VecUnpackOp IntVec 4 W64)
+   , (VecUnpackOp IntVec 64 W8)
+   , (VecUnpackOp IntVec 32 W16)
+   , (VecUnpackOp IntVec 16 W32)
+   , (VecUnpackOp IntVec 8 W64)
+   , (VecUnpackOp WordVec 16 W8)
+   , (VecUnpackOp WordVec 8 W16)
+   , (VecUnpackOp WordVec 4 W32)
+   , (VecUnpackOp WordVec 2 W64)
+   , (VecUnpackOp WordVec 32 W8)
+   , (VecUnpackOp WordVec 16 W16)
+   , (VecUnpackOp WordVec 8 W32)
+   , (VecUnpackOp WordVec 4 W64)
+   , (VecUnpackOp WordVec 64 W8)
+   , (VecUnpackOp WordVec 32 W16)
+   , (VecUnpackOp WordVec 16 W32)
+   , (VecUnpackOp WordVec 8 W64)
+   , (VecUnpackOp FloatVec 4 W32)
+   , (VecUnpackOp FloatVec 2 W64)
+   , (VecUnpackOp FloatVec 8 W32)
+   , (VecUnpackOp FloatVec 4 W64)
+   , (VecUnpackOp FloatVec 16 W32)
+   , (VecUnpackOp FloatVec 8 W64)
+   , (VecInsertOp IntVec 16 W8)
+   , (VecInsertOp IntVec 8 W16)
+   , (VecInsertOp IntVec 4 W32)
+   , (VecInsertOp IntVec 2 W64)
+   , (VecInsertOp IntVec 32 W8)
+   , (VecInsertOp IntVec 16 W16)
+   , (VecInsertOp IntVec 8 W32)
+   , (VecInsertOp IntVec 4 W64)
+   , (VecInsertOp IntVec 64 W8)
+   , (VecInsertOp IntVec 32 W16)
+   , (VecInsertOp IntVec 16 W32)
+   , (VecInsertOp IntVec 8 W64)
+   , (VecInsertOp WordVec 16 W8)
+   , (VecInsertOp WordVec 8 W16)
+   , (VecInsertOp WordVec 4 W32)
+   , (VecInsertOp WordVec 2 W64)
+   , (VecInsertOp WordVec 32 W8)
+   , (VecInsertOp WordVec 16 W16)
+   , (VecInsertOp WordVec 8 W32)
+   , (VecInsertOp WordVec 4 W64)
+   , (VecInsertOp WordVec 64 W8)
+   , (VecInsertOp WordVec 32 W16)
+   , (VecInsertOp WordVec 16 W32)
+   , (VecInsertOp WordVec 8 W64)
+   , (VecInsertOp FloatVec 4 W32)
+   , (VecInsertOp FloatVec 2 W64)
+   , (VecInsertOp FloatVec 8 W32)
+   , (VecInsertOp FloatVec 4 W64)
+   , (VecInsertOp FloatVec 16 W32)
+   , (VecInsertOp FloatVec 8 W64)
+   , (VecAddOp IntVec 16 W8)
+   , (VecAddOp IntVec 8 W16)
+   , (VecAddOp IntVec 4 W32)
+   , (VecAddOp IntVec 2 W64)
+   , (VecAddOp IntVec 32 W8)
+   , (VecAddOp IntVec 16 W16)
+   , (VecAddOp IntVec 8 W32)
+   , (VecAddOp IntVec 4 W64)
+   , (VecAddOp IntVec 64 W8)
+   , (VecAddOp IntVec 32 W16)
+   , (VecAddOp IntVec 16 W32)
+   , (VecAddOp IntVec 8 W64)
+   , (VecAddOp WordVec 16 W8)
+   , (VecAddOp WordVec 8 W16)
+   , (VecAddOp WordVec 4 W32)
+   , (VecAddOp WordVec 2 W64)
+   , (VecAddOp WordVec 32 W8)
+   , (VecAddOp WordVec 16 W16)
+   , (VecAddOp WordVec 8 W32)
+   , (VecAddOp WordVec 4 W64)
+   , (VecAddOp WordVec 64 W8)
+   , (VecAddOp WordVec 32 W16)
+   , (VecAddOp WordVec 16 W32)
+   , (VecAddOp WordVec 8 W64)
+   , (VecAddOp FloatVec 4 W32)
+   , (VecAddOp FloatVec 2 W64)
+   , (VecAddOp FloatVec 8 W32)
+   , (VecAddOp FloatVec 4 W64)
+   , (VecAddOp FloatVec 16 W32)
+   , (VecAddOp FloatVec 8 W64)
+   , (VecSubOp IntVec 16 W8)
+   , (VecSubOp IntVec 8 W16)
+   , (VecSubOp IntVec 4 W32)
+   , (VecSubOp IntVec 2 W64)
+   , (VecSubOp IntVec 32 W8)
+   , (VecSubOp IntVec 16 W16)
+   , (VecSubOp IntVec 8 W32)
+   , (VecSubOp IntVec 4 W64)
+   , (VecSubOp IntVec 64 W8)
+   , (VecSubOp IntVec 32 W16)
+   , (VecSubOp IntVec 16 W32)
+   , (VecSubOp IntVec 8 W64)
+   , (VecSubOp WordVec 16 W8)
+   , (VecSubOp WordVec 8 W16)
+   , (VecSubOp WordVec 4 W32)
+   , (VecSubOp WordVec 2 W64)
+   , (VecSubOp WordVec 32 W8)
+   , (VecSubOp WordVec 16 W16)
+   , (VecSubOp WordVec 8 W32)
+   , (VecSubOp WordVec 4 W64)
+   , (VecSubOp WordVec 64 W8)
+   , (VecSubOp WordVec 32 W16)
+   , (VecSubOp WordVec 16 W32)
+   , (VecSubOp WordVec 8 W64)
+   , (VecSubOp FloatVec 4 W32)
+   , (VecSubOp FloatVec 2 W64)
+   , (VecSubOp FloatVec 8 W32)
+   , (VecSubOp FloatVec 4 W64)
+   , (VecSubOp FloatVec 16 W32)
+   , (VecSubOp FloatVec 8 W64)
+   , (VecMulOp IntVec 16 W8)
+   , (VecMulOp IntVec 8 W16)
+   , (VecMulOp IntVec 4 W32)
+   , (VecMulOp IntVec 2 W64)
+   , (VecMulOp IntVec 32 W8)
+   , (VecMulOp IntVec 16 W16)
+   , (VecMulOp IntVec 8 W32)
+   , (VecMulOp IntVec 4 W64)
+   , (VecMulOp IntVec 64 W8)
+   , (VecMulOp IntVec 32 W16)
+   , (VecMulOp IntVec 16 W32)
+   , (VecMulOp IntVec 8 W64)
+   , (VecMulOp WordVec 16 W8)
+   , (VecMulOp WordVec 8 W16)
+   , (VecMulOp WordVec 4 W32)
+   , (VecMulOp WordVec 2 W64)
+   , (VecMulOp WordVec 32 W8)
+   , (VecMulOp WordVec 16 W16)
+   , (VecMulOp WordVec 8 W32)
+   , (VecMulOp WordVec 4 W64)
+   , (VecMulOp WordVec 64 W8)
+   , (VecMulOp WordVec 32 W16)
+   , (VecMulOp WordVec 16 W32)
+   , (VecMulOp WordVec 8 W64)
+   , (VecMulOp FloatVec 4 W32)
+   , (VecMulOp FloatVec 2 W64)
+   , (VecMulOp FloatVec 8 W32)
+   , (VecMulOp FloatVec 4 W64)
+   , (VecMulOp FloatVec 16 W32)
+   , (VecMulOp FloatVec 8 W64)
+   , (VecDivOp FloatVec 4 W32)
+   , (VecDivOp FloatVec 2 W64)
+   , (VecDivOp FloatVec 8 W32)
+   , (VecDivOp FloatVec 4 W64)
+   , (VecDivOp FloatVec 16 W32)
+   , (VecDivOp FloatVec 8 W64)
+   , (VecQuotOp IntVec 16 W8)
+   , (VecQuotOp IntVec 8 W16)
+   , (VecQuotOp IntVec 4 W32)
+   , (VecQuotOp IntVec 2 W64)
+   , (VecQuotOp IntVec 32 W8)
+   , (VecQuotOp IntVec 16 W16)
+   , (VecQuotOp IntVec 8 W32)
+   , (VecQuotOp IntVec 4 W64)
+   , (VecQuotOp IntVec 64 W8)
+   , (VecQuotOp IntVec 32 W16)
+   , (VecQuotOp IntVec 16 W32)
+   , (VecQuotOp IntVec 8 W64)
+   , (VecQuotOp WordVec 16 W8)
+   , (VecQuotOp WordVec 8 W16)
+   , (VecQuotOp WordVec 4 W32)
+   , (VecQuotOp WordVec 2 W64)
+   , (VecQuotOp WordVec 32 W8)
+   , (VecQuotOp WordVec 16 W16)
+   , (VecQuotOp WordVec 8 W32)
+   , (VecQuotOp WordVec 4 W64)
+   , (VecQuotOp WordVec 64 W8)
+   , (VecQuotOp WordVec 32 W16)
+   , (VecQuotOp WordVec 16 W32)
+   , (VecQuotOp WordVec 8 W64)
+   , (VecRemOp IntVec 16 W8)
+   , (VecRemOp IntVec 8 W16)
+   , (VecRemOp IntVec 4 W32)
+   , (VecRemOp IntVec 2 W64)
+   , (VecRemOp IntVec 32 W8)
+   , (VecRemOp IntVec 16 W16)
+   , (VecRemOp IntVec 8 W32)
+   , (VecRemOp IntVec 4 W64)
+   , (VecRemOp IntVec 64 W8)
+   , (VecRemOp IntVec 32 W16)
+   , (VecRemOp IntVec 16 W32)
+   , (VecRemOp IntVec 8 W64)
+   , (VecRemOp WordVec 16 W8)
+   , (VecRemOp WordVec 8 W16)
+   , (VecRemOp WordVec 4 W32)
+   , (VecRemOp WordVec 2 W64)
+   , (VecRemOp WordVec 32 W8)
+   , (VecRemOp WordVec 16 W16)
+   , (VecRemOp WordVec 8 W32)
+   , (VecRemOp WordVec 4 W64)
+   , (VecRemOp WordVec 64 W8)
+   , (VecRemOp WordVec 32 W16)
+   , (VecRemOp WordVec 16 W32)
+   , (VecRemOp WordVec 8 W64)
+   , (VecNegOp IntVec 16 W8)
+   , (VecNegOp IntVec 8 W16)
+   , (VecNegOp IntVec 4 W32)
+   , (VecNegOp IntVec 2 W64)
+   , (VecNegOp IntVec 32 W8)
+   , (VecNegOp IntVec 16 W16)
+   , (VecNegOp IntVec 8 W32)
+   , (VecNegOp IntVec 4 W64)
+   , (VecNegOp IntVec 64 W8)
+   , (VecNegOp IntVec 32 W16)
+   , (VecNegOp IntVec 16 W32)
+   , (VecNegOp IntVec 8 W64)
+   , (VecNegOp FloatVec 4 W32)
+   , (VecNegOp FloatVec 2 W64)
+   , (VecNegOp FloatVec 8 W32)
+   , (VecNegOp FloatVec 4 W64)
+   , (VecNegOp FloatVec 16 W32)
+   , (VecNegOp FloatVec 8 W64)
+   , (VecIndexByteArrayOp IntVec 16 W8)
+   , (VecIndexByteArrayOp IntVec 8 W16)
+   , (VecIndexByteArrayOp IntVec 4 W32)
+   , (VecIndexByteArrayOp IntVec 2 W64)
+   , (VecIndexByteArrayOp IntVec 32 W8)
+   , (VecIndexByteArrayOp IntVec 16 W16)
+   , (VecIndexByteArrayOp IntVec 8 W32)
+   , (VecIndexByteArrayOp IntVec 4 W64)
+   , (VecIndexByteArrayOp IntVec 64 W8)
+   , (VecIndexByteArrayOp IntVec 32 W16)
+   , (VecIndexByteArrayOp IntVec 16 W32)
+   , (VecIndexByteArrayOp IntVec 8 W64)
+   , (VecIndexByteArrayOp WordVec 16 W8)
+   , (VecIndexByteArrayOp WordVec 8 W16)
+   , (VecIndexByteArrayOp WordVec 4 W32)
+   , (VecIndexByteArrayOp WordVec 2 W64)
+   , (VecIndexByteArrayOp WordVec 32 W8)
+   , (VecIndexByteArrayOp WordVec 16 W16)
+   , (VecIndexByteArrayOp WordVec 8 W32)
+   , (VecIndexByteArrayOp WordVec 4 W64)
+   , (VecIndexByteArrayOp WordVec 64 W8)
+   , (VecIndexByteArrayOp WordVec 32 W16)
+   , (VecIndexByteArrayOp WordVec 16 W32)
+   , (VecIndexByteArrayOp WordVec 8 W64)
+   , (VecIndexByteArrayOp FloatVec 4 W32)
+   , (VecIndexByteArrayOp FloatVec 2 W64)
+   , (VecIndexByteArrayOp FloatVec 8 W32)
+   , (VecIndexByteArrayOp FloatVec 4 W64)
+   , (VecIndexByteArrayOp FloatVec 16 W32)
+   , (VecIndexByteArrayOp FloatVec 8 W64)
+   , (VecReadByteArrayOp IntVec 16 W8)
+   , (VecReadByteArrayOp IntVec 8 W16)
+   , (VecReadByteArrayOp IntVec 4 W32)
+   , (VecReadByteArrayOp IntVec 2 W64)
+   , (VecReadByteArrayOp IntVec 32 W8)
+   , (VecReadByteArrayOp IntVec 16 W16)
+   , (VecReadByteArrayOp IntVec 8 W32)
+   , (VecReadByteArrayOp IntVec 4 W64)
+   , (VecReadByteArrayOp IntVec 64 W8)
+   , (VecReadByteArrayOp IntVec 32 W16)
+   , (VecReadByteArrayOp IntVec 16 W32)
+   , (VecReadByteArrayOp IntVec 8 W64)
+   , (VecReadByteArrayOp WordVec 16 W8)
+   , (VecReadByteArrayOp WordVec 8 W16)
+   , (VecReadByteArrayOp WordVec 4 W32)
+   , (VecReadByteArrayOp WordVec 2 W64)
+   , (VecReadByteArrayOp WordVec 32 W8)
+   , (VecReadByteArrayOp WordVec 16 W16)
+   , (VecReadByteArrayOp WordVec 8 W32)
+   , (VecReadByteArrayOp WordVec 4 W64)
+   , (VecReadByteArrayOp WordVec 64 W8)
+   , (VecReadByteArrayOp WordVec 32 W16)
+   , (VecReadByteArrayOp WordVec 16 W32)
+   , (VecReadByteArrayOp WordVec 8 W64)
+   , (VecReadByteArrayOp FloatVec 4 W32)
+   , (VecReadByteArrayOp FloatVec 2 W64)
+   , (VecReadByteArrayOp FloatVec 8 W32)
+   , (VecReadByteArrayOp FloatVec 4 W64)
+   , (VecReadByteArrayOp FloatVec 16 W32)
+   , (VecReadByteArrayOp FloatVec 8 W64)
+   , (VecWriteByteArrayOp IntVec 16 W8)
+   , (VecWriteByteArrayOp IntVec 8 W16)
+   , (VecWriteByteArrayOp IntVec 4 W32)
+   , (VecWriteByteArrayOp IntVec 2 W64)
+   , (VecWriteByteArrayOp IntVec 32 W8)
+   , (VecWriteByteArrayOp IntVec 16 W16)
+   , (VecWriteByteArrayOp IntVec 8 W32)
+   , (VecWriteByteArrayOp IntVec 4 W64)
+   , (VecWriteByteArrayOp IntVec 64 W8)
+   , (VecWriteByteArrayOp IntVec 32 W16)
+   , (VecWriteByteArrayOp IntVec 16 W32)
+   , (VecWriteByteArrayOp IntVec 8 W64)
+   , (VecWriteByteArrayOp WordVec 16 W8)
+   , (VecWriteByteArrayOp WordVec 8 W16)
+   , (VecWriteByteArrayOp WordVec 4 W32)
+   , (VecWriteByteArrayOp WordVec 2 W64)
+   , (VecWriteByteArrayOp WordVec 32 W8)
+   , (VecWriteByteArrayOp WordVec 16 W16)
+   , (VecWriteByteArrayOp WordVec 8 W32)
+   , (VecWriteByteArrayOp WordVec 4 W64)
+   , (VecWriteByteArrayOp WordVec 64 W8)
+   , (VecWriteByteArrayOp WordVec 32 W16)
+   , (VecWriteByteArrayOp WordVec 16 W32)
+   , (VecWriteByteArrayOp WordVec 8 W64)
+   , (VecWriteByteArrayOp FloatVec 4 W32)
+   , (VecWriteByteArrayOp FloatVec 2 W64)
+   , (VecWriteByteArrayOp FloatVec 8 W32)
+   , (VecWriteByteArrayOp FloatVec 4 W64)
+   , (VecWriteByteArrayOp FloatVec 16 W32)
+   , (VecWriteByteArrayOp FloatVec 8 W64)
+   , (VecIndexOffAddrOp IntVec 16 W8)
+   , (VecIndexOffAddrOp IntVec 8 W16)
+   , (VecIndexOffAddrOp IntVec 4 W32)
+   , (VecIndexOffAddrOp IntVec 2 W64)
+   , (VecIndexOffAddrOp IntVec 32 W8)
+   , (VecIndexOffAddrOp IntVec 16 W16)
+   , (VecIndexOffAddrOp IntVec 8 W32)
+   , (VecIndexOffAddrOp IntVec 4 W64)
+   , (VecIndexOffAddrOp IntVec 64 W8)
+   , (VecIndexOffAddrOp IntVec 32 W16)
+   , (VecIndexOffAddrOp IntVec 16 W32)
+   , (VecIndexOffAddrOp IntVec 8 W64)
+   , (VecIndexOffAddrOp WordVec 16 W8)
+   , (VecIndexOffAddrOp WordVec 8 W16)
+   , (VecIndexOffAddrOp WordVec 4 W32)
+   , (VecIndexOffAddrOp WordVec 2 W64)
+   , (VecIndexOffAddrOp WordVec 32 W8)
+   , (VecIndexOffAddrOp WordVec 16 W16)
+   , (VecIndexOffAddrOp WordVec 8 W32)
+   , (VecIndexOffAddrOp WordVec 4 W64)
+   , (VecIndexOffAddrOp WordVec 64 W8)
+   , (VecIndexOffAddrOp WordVec 32 W16)
+   , (VecIndexOffAddrOp WordVec 16 W32)
+   , (VecIndexOffAddrOp WordVec 8 W64)
+   , (VecIndexOffAddrOp FloatVec 4 W32)
+   , (VecIndexOffAddrOp FloatVec 2 W64)
+   , (VecIndexOffAddrOp FloatVec 8 W32)
+   , (VecIndexOffAddrOp FloatVec 4 W64)
+   , (VecIndexOffAddrOp FloatVec 16 W32)
+   , (VecIndexOffAddrOp FloatVec 8 W64)
+   , (VecReadOffAddrOp IntVec 16 W8)
+   , (VecReadOffAddrOp IntVec 8 W16)
+   , (VecReadOffAddrOp IntVec 4 W32)
+   , (VecReadOffAddrOp IntVec 2 W64)
+   , (VecReadOffAddrOp IntVec 32 W8)
+   , (VecReadOffAddrOp IntVec 16 W16)
+   , (VecReadOffAddrOp IntVec 8 W32)
+   , (VecReadOffAddrOp IntVec 4 W64)
+   , (VecReadOffAddrOp IntVec 64 W8)
+   , (VecReadOffAddrOp IntVec 32 W16)
+   , (VecReadOffAddrOp IntVec 16 W32)
+   , (VecReadOffAddrOp IntVec 8 W64)
+   , (VecReadOffAddrOp WordVec 16 W8)
+   , (VecReadOffAddrOp WordVec 8 W16)
+   , (VecReadOffAddrOp WordVec 4 W32)
+   , (VecReadOffAddrOp WordVec 2 W64)
+   , (VecReadOffAddrOp WordVec 32 W8)
+   , (VecReadOffAddrOp WordVec 16 W16)
+   , (VecReadOffAddrOp WordVec 8 W32)
+   , (VecReadOffAddrOp WordVec 4 W64)
+   , (VecReadOffAddrOp WordVec 64 W8)
+   , (VecReadOffAddrOp WordVec 32 W16)
+   , (VecReadOffAddrOp WordVec 16 W32)
+   , (VecReadOffAddrOp WordVec 8 W64)
+   , (VecReadOffAddrOp FloatVec 4 W32)
+   , (VecReadOffAddrOp FloatVec 2 W64)
+   , (VecReadOffAddrOp FloatVec 8 W32)
+   , (VecReadOffAddrOp FloatVec 4 W64)
+   , (VecReadOffAddrOp FloatVec 16 W32)
+   , (VecReadOffAddrOp FloatVec 8 W64)
+   , (VecWriteOffAddrOp IntVec 16 W8)
+   , (VecWriteOffAddrOp IntVec 8 W16)
+   , (VecWriteOffAddrOp IntVec 4 W32)
+   , (VecWriteOffAddrOp IntVec 2 W64)
+   , (VecWriteOffAddrOp IntVec 32 W8)
+   , (VecWriteOffAddrOp IntVec 16 W16)
+   , (VecWriteOffAddrOp IntVec 8 W32)
+   , (VecWriteOffAddrOp IntVec 4 W64)
+   , (VecWriteOffAddrOp IntVec 64 W8)
+   , (VecWriteOffAddrOp IntVec 32 W16)
+   , (VecWriteOffAddrOp IntVec 16 W32)
+   , (VecWriteOffAddrOp IntVec 8 W64)
+   , (VecWriteOffAddrOp WordVec 16 W8)
+   , (VecWriteOffAddrOp WordVec 8 W16)
+   , (VecWriteOffAddrOp WordVec 4 W32)
+   , (VecWriteOffAddrOp WordVec 2 W64)
+   , (VecWriteOffAddrOp WordVec 32 W8)
+   , (VecWriteOffAddrOp WordVec 16 W16)
+   , (VecWriteOffAddrOp WordVec 8 W32)
+   , (VecWriteOffAddrOp WordVec 4 W64)
+   , (VecWriteOffAddrOp WordVec 64 W8)
+   , (VecWriteOffAddrOp WordVec 32 W16)
+   , (VecWriteOffAddrOp WordVec 16 W32)
+   , (VecWriteOffAddrOp WordVec 8 W64)
+   , (VecWriteOffAddrOp FloatVec 4 W32)
+   , (VecWriteOffAddrOp FloatVec 2 W64)
+   , (VecWriteOffAddrOp FloatVec 8 W32)
+   , (VecWriteOffAddrOp FloatVec 4 W64)
+   , (VecWriteOffAddrOp FloatVec 16 W32)
+   , (VecWriteOffAddrOp FloatVec 8 W64)
+   , (VecIndexScalarByteArrayOp IntVec 16 W8)
+   , (VecIndexScalarByteArrayOp IntVec 8 W16)
+   , (VecIndexScalarByteArrayOp IntVec 4 W32)
+   , (VecIndexScalarByteArrayOp IntVec 2 W64)
+   , (VecIndexScalarByteArrayOp IntVec 32 W8)
+   , (VecIndexScalarByteArrayOp IntVec 16 W16)
+   , (VecIndexScalarByteArrayOp IntVec 8 W32)
+   , (VecIndexScalarByteArrayOp IntVec 4 W64)
+   , (VecIndexScalarByteArrayOp IntVec 64 W8)
+   , (VecIndexScalarByteArrayOp IntVec 32 W16)
+   , (VecIndexScalarByteArrayOp IntVec 16 W32)
+   , (VecIndexScalarByteArrayOp IntVec 8 W64)
+   , (VecIndexScalarByteArrayOp WordVec 16 W8)
+   , (VecIndexScalarByteArrayOp WordVec 8 W16)
+   , (VecIndexScalarByteArrayOp WordVec 4 W32)
+   , (VecIndexScalarByteArrayOp WordVec 2 W64)
+   , (VecIndexScalarByteArrayOp WordVec 32 W8)
+   , (VecIndexScalarByteArrayOp WordVec 16 W16)
+   , (VecIndexScalarByteArrayOp WordVec 8 W32)
+   , (VecIndexScalarByteArrayOp WordVec 4 W64)
+   , (VecIndexScalarByteArrayOp WordVec 64 W8)
+   , (VecIndexScalarByteArrayOp WordVec 32 W16)
+   , (VecIndexScalarByteArrayOp WordVec 16 W32)
+   , (VecIndexScalarByteArrayOp WordVec 8 W64)
+   , (VecIndexScalarByteArrayOp FloatVec 4 W32)
+   , (VecIndexScalarByteArrayOp FloatVec 2 W64)
+   , (VecIndexScalarByteArrayOp FloatVec 8 W32)
+   , (VecIndexScalarByteArrayOp FloatVec 4 W64)
+   , (VecIndexScalarByteArrayOp FloatVec 16 W32)
+   , (VecIndexScalarByteArrayOp FloatVec 8 W64)
+   , (VecReadScalarByteArrayOp IntVec 16 W8)
+   , (VecReadScalarByteArrayOp IntVec 8 W16)
+   , (VecReadScalarByteArrayOp IntVec 4 W32)
+   , (VecReadScalarByteArrayOp IntVec 2 W64)
+   , (VecReadScalarByteArrayOp IntVec 32 W8)
+   , (VecReadScalarByteArrayOp IntVec 16 W16)
+   , (VecReadScalarByteArrayOp IntVec 8 W32)
+   , (VecReadScalarByteArrayOp IntVec 4 W64)
+   , (VecReadScalarByteArrayOp IntVec 64 W8)
+   , (VecReadScalarByteArrayOp IntVec 32 W16)
+   , (VecReadScalarByteArrayOp IntVec 16 W32)
+   , (VecReadScalarByteArrayOp IntVec 8 W64)
+   , (VecReadScalarByteArrayOp WordVec 16 W8)
+   , (VecReadScalarByteArrayOp WordVec 8 W16)
+   , (VecReadScalarByteArrayOp WordVec 4 W32)
+   , (VecReadScalarByteArrayOp WordVec 2 W64)
+   , (VecReadScalarByteArrayOp WordVec 32 W8)
+   , (VecReadScalarByteArrayOp WordVec 16 W16)
+   , (VecReadScalarByteArrayOp WordVec 8 W32)
+   , (VecReadScalarByteArrayOp WordVec 4 W64)
+   , (VecReadScalarByteArrayOp WordVec 64 W8)
+   , (VecReadScalarByteArrayOp WordVec 32 W16)
+   , (VecReadScalarByteArrayOp WordVec 16 W32)
+   , (VecReadScalarByteArrayOp WordVec 8 W64)
+   , (VecReadScalarByteArrayOp FloatVec 4 W32)
+   , (VecReadScalarByteArrayOp FloatVec 2 W64)
+   , (VecReadScalarByteArrayOp FloatVec 8 W32)
+   , (VecReadScalarByteArrayOp FloatVec 4 W64)
+   , (VecReadScalarByteArrayOp FloatVec 16 W32)
+   , (VecReadScalarByteArrayOp FloatVec 8 W64)
+   , (VecWriteScalarByteArrayOp IntVec 16 W8)
+   , (VecWriteScalarByteArrayOp IntVec 8 W16)
+   , (VecWriteScalarByteArrayOp IntVec 4 W32)
+   , (VecWriteScalarByteArrayOp IntVec 2 W64)
+   , (VecWriteScalarByteArrayOp IntVec 32 W8)
+   , (VecWriteScalarByteArrayOp IntVec 16 W16)
+   , (VecWriteScalarByteArrayOp IntVec 8 W32)
+   , (VecWriteScalarByteArrayOp IntVec 4 W64)
+   , (VecWriteScalarByteArrayOp IntVec 64 W8)
+   , (VecWriteScalarByteArrayOp IntVec 32 W16)
+   , (VecWriteScalarByteArrayOp IntVec 16 W32)
+   , (VecWriteScalarByteArrayOp IntVec 8 W64)
+   , (VecWriteScalarByteArrayOp WordVec 16 W8)
+   , (VecWriteScalarByteArrayOp WordVec 8 W16)
+   , (VecWriteScalarByteArrayOp WordVec 4 W32)
+   , (VecWriteScalarByteArrayOp WordVec 2 W64)
+   , (VecWriteScalarByteArrayOp WordVec 32 W8)
+   , (VecWriteScalarByteArrayOp WordVec 16 W16)
+   , (VecWriteScalarByteArrayOp WordVec 8 W32)
+   , (VecWriteScalarByteArrayOp WordVec 4 W64)
+   , (VecWriteScalarByteArrayOp WordVec 64 W8)
+   , (VecWriteScalarByteArrayOp WordVec 32 W16)
+   , (VecWriteScalarByteArrayOp WordVec 16 W32)
+   , (VecWriteScalarByteArrayOp WordVec 8 W64)
+   , (VecWriteScalarByteArrayOp FloatVec 4 W32)
+   , (VecWriteScalarByteArrayOp FloatVec 2 W64)
+   , (VecWriteScalarByteArrayOp FloatVec 8 W32)
+   , (VecWriteScalarByteArrayOp FloatVec 4 W64)
+   , (VecWriteScalarByteArrayOp FloatVec 16 W32)
+   , (VecWriteScalarByteArrayOp FloatVec 8 W64)
+   , (VecIndexScalarOffAddrOp IntVec 16 W8)
+   , (VecIndexScalarOffAddrOp IntVec 8 W16)
+   , (VecIndexScalarOffAddrOp IntVec 4 W32)
+   , (VecIndexScalarOffAddrOp IntVec 2 W64)
+   , (VecIndexScalarOffAddrOp IntVec 32 W8)
+   , (VecIndexScalarOffAddrOp IntVec 16 W16)
+   , (VecIndexScalarOffAddrOp IntVec 8 W32)
+   , (VecIndexScalarOffAddrOp IntVec 4 W64)
+   , (VecIndexScalarOffAddrOp IntVec 64 W8)
+   , (VecIndexScalarOffAddrOp IntVec 32 W16)
+   , (VecIndexScalarOffAddrOp IntVec 16 W32)
+   , (VecIndexScalarOffAddrOp IntVec 8 W64)
+   , (VecIndexScalarOffAddrOp WordVec 16 W8)
+   , (VecIndexScalarOffAddrOp WordVec 8 W16)
+   , (VecIndexScalarOffAddrOp WordVec 4 W32)
+   , (VecIndexScalarOffAddrOp WordVec 2 W64)
+   , (VecIndexScalarOffAddrOp WordVec 32 W8)
+   , (VecIndexScalarOffAddrOp WordVec 16 W16)
+   , (VecIndexScalarOffAddrOp WordVec 8 W32)
+   , (VecIndexScalarOffAddrOp WordVec 4 W64)
+   , (VecIndexScalarOffAddrOp WordVec 64 W8)
+   , (VecIndexScalarOffAddrOp WordVec 32 W16)
+   , (VecIndexScalarOffAddrOp WordVec 16 W32)
+   , (VecIndexScalarOffAddrOp WordVec 8 W64)
+   , (VecIndexScalarOffAddrOp FloatVec 4 W32)
+   , (VecIndexScalarOffAddrOp FloatVec 2 W64)
+   , (VecIndexScalarOffAddrOp FloatVec 8 W32)
+   , (VecIndexScalarOffAddrOp FloatVec 4 W64)
+   , (VecIndexScalarOffAddrOp FloatVec 16 W32)
+   , (VecIndexScalarOffAddrOp FloatVec 8 W64)
+   , (VecReadScalarOffAddrOp IntVec 16 W8)
+   , (VecReadScalarOffAddrOp IntVec 8 W16)
+   , (VecReadScalarOffAddrOp IntVec 4 W32)
+   , (VecReadScalarOffAddrOp IntVec 2 W64)
+   , (VecReadScalarOffAddrOp IntVec 32 W8)
+   , (VecReadScalarOffAddrOp IntVec 16 W16)
+   , (VecReadScalarOffAddrOp IntVec 8 W32)
+   , (VecReadScalarOffAddrOp IntVec 4 W64)
+   , (VecReadScalarOffAddrOp IntVec 64 W8)
+   , (VecReadScalarOffAddrOp IntVec 32 W16)
+   , (VecReadScalarOffAddrOp IntVec 16 W32)
+   , (VecReadScalarOffAddrOp IntVec 8 W64)
+   , (VecReadScalarOffAddrOp WordVec 16 W8)
+   , (VecReadScalarOffAddrOp WordVec 8 W16)
+   , (VecReadScalarOffAddrOp WordVec 4 W32)
+   , (VecReadScalarOffAddrOp WordVec 2 W64)
+   , (VecReadScalarOffAddrOp WordVec 32 W8)
+   , (VecReadScalarOffAddrOp WordVec 16 W16)
+   , (VecReadScalarOffAddrOp WordVec 8 W32)
+   , (VecReadScalarOffAddrOp WordVec 4 W64)
+   , (VecReadScalarOffAddrOp WordVec 64 W8)
+   , (VecReadScalarOffAddrOp WordVec 32 W16)
+   , (VecReadScalarOffAddrOp WordVec 16 W32)
+   , (VecReadScalarOffAddrOp WordVec 8 W64)
+   , (VecReadScalarOffAddrOp FloatVec 4 W32)
+   , (VecReadScalarOffAddrOp FloatVec 2 W64)
+   , (VecReadScalarOffAddrOp FloatVec 8 W32)
+   , (VecReadScalarOffAddrOp FloatVec 4 W64)
+   , (VecReadScalarOffAddrOp FloatVec 16 W32)
+   , (VecReadScalarOffAddrOp FloatVec 8 W64)
+   , (VecWriteScalarOffAddrOp IntVec 16 W8)
+   , (VecWriteScalarOffAddrOp IntVec 8 W16)
+   , (VecWriteScalarOffAddrOp IntVec 4 W32)
+   , (VecWriteScalarOffAddrOp IntVec 2 W64)
+   , (VecWriteScalarOffAddrOp IntVec 32 W8)
+   , (VecWriteScalarOffAddrOp IntVec 16 W16)
+   , (VecWriteScalarOffAddrOp IntVec 8 W32)
+   , (VecWriteScalarOffAddrOp IntVec 4 W64)
+   , (VecWriteScalarOffAddrOp IntVec 64 W8)
+   , (VecWriteScalarOffAddrOp IntVec 32 W16)
+   , (VecWriteScalarOffAddrOp IntVec 16 W32)
+   , (VecWriteScalarOffAddrOp IntVec 8 W64)
+   , (VecWriteScalarOffAddrOp WordVec 16 W8)
+   , (VecWriteScalarOffAddrOp WordVec 8 W16)
+   , (VecWriteScalarOffAddrOp WordVec 4 W32)
+   , (VecWriteScalarOffAddrOp WordVec 2 W64)
+   , (VecWriteScalarOffAddrOp WordVec 32 W8)
+   , (VecWriteScalarOffAddrOp WordVec 16 W16)
+   , (VecWriteScalarOffAddrOp WordVec 8 W32)
+   , (VecWriteScalarOffAddrOp WordVec 4 W64)
+   , (VecWriteScalarOffAddrOp WordVec 64 W8)
+   , (VecWriteScalarOffAddrOp WordVec 32 W16)
+   , (VecWriteScalarOffAddrOp WordVec 16 W32)
+   , (VecWriteScalarOffAddrOp WordVec 8 W64)
+   , (VecWriteScalarOffAddrOp FloatVec 4 W32)
+   , (VecWriteScalarOffAddrOp FloatVec 2 W64)
+   , (VecWriteScalarOffAddrOp FloatVec 8 W32)
+   , (VecWriteScalarOffAddrOp FloatVec 4 W64)
+   , (VecWriteScalarOffAddrOp FloatVec 16 W32)
+   , (VecWriteScalarOffAddrOp FloatVec 8 W64)
+   , PrefetchByteArrayOp3
+   , PrefetchMutableByteArrayOp3
+   , PrefetchAddrOp3
+   , PrefetchValueOp3
+   , PrefetchByteArrayOp2
+   , PrefetchMutableByteArrayOp2
+   , PrefetchAddrOp2
+   , PrefetchValueOp2
+   , PrefetchByteArrayOp1
+   , PrefetchMutableByteArrayOp1
+   , PrefetchAddrOp1
+   , PrefetchValueOp1
+   , PrefetchByteArrayOp0
+   , PrefetchMutableByteArrayOp0
+   , PrefetchAddrOp0
+   , PrefetchValueOp0
+   ]
diff --git a/ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl b/ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl
@@ -0,0 +1,101 @@
+primOpOutOfLine DoubleDecode_2IntOp = True
+primOpOutOfLine DoubleDecode_Int64Op = True
+primOpOutOfLine FloatDecode_IntOp = True
+primOpOutOfLine NewArrayOp = True
+primOpOutOfLine UnsafeThawArrayOp = True
+primOpOutOfLine CopyArrayOp = True
+primOpOutOfLine CopyMutableArrayOp = True
+primOpOutOfLine CloneArrayOp = True
+primOpOutOfLine CloneMutableArrayOp = True
+primOpOutOfLine FreezeArrayOp = True
+primOpOutOfLine ThawArrayOp = True
+primOpOutOfLine CasArrayOp = True
+primOpOutOfLine NewSmallArrayOp = True
+primOpOutOfLine UnsafeThawSmallArrayOp = True
+primOpOutOfLine CopySmallArrayOp = True
+primOpOutOfLine CopySmallMutableArrayOp = True
+primOpOutOfLine CloneSmallArrayOp = True
+primOpOutOfLine CloneSmallMutableArrayOp = True
+primOpOutOfLine FreezeSmallArrayOp = True
+primOpOutOfLine ThawSmallArrayOp = True
+primOpOutOfLine CasSmallArrayOp = True
+primOpOutOfLine NewByteArrayOp_Char = True
+primOpOutOfLine NewPinnedByteArrayOp_Char = True
+primOpOutOfLine NewAlignedPinnedByteArrayOp_Char = True
+primOpOutOfLine MutableByteArrayIsPinnedOp = True
+primOpOutOfLine ByteArrayIsPinnedOp = True
+primOpOutOfLine ShrinkMutableByteArrayOp_Char = True
+primOpOutOfLine ResizeMutableByteArrayOp_Char = True
+primOpOutOfLine NewArrayArrayOp = True
+primOpOutOfLine CopyArrayArrayOp = True
+primOpOutOfLine CopyMutableArrayArrayOp = True
+primOpOutOfLine NewMutVarOp = True
+primOpOutOfLine AtomicModifyMutVar2Op = True
+primOpOutOfLine AtomicModifyMutVar_Op = True
+primOpOutOfLine CasMutVarOp = True
+primOpOutOfLine CatchOp = True
+primOpOutOfLine RaiseOp = True
+primOpOutOfLine RaiseIOOp = True
+primOpOutOfLine MaskAsyncExceptionsOp = True
+primOpOutOfLine MaskUninterruptibleOp = True
+primOpOutOfLine UnmaskAsyncExceptionsOp = True
+primOpOutOfLine MaskStatus = True
+primOpOutOfLine AtomicallyOp = True
+primOpOutOfLine RetryOp = True
+primOpOutOfLine CatchRetryOp = True
+primOpOutOfLine CatchSTMOp = True
+primOpOutOfLine NewTVarOp = True
+primOpOutOfLine ReadTVarOp = True
+primOpOutOfLine ReadTVarIOOp = True
+primOpOutOfLine WriteTVarOp = True
+primOpOutOfLine NewMVarOp = True
+primOpOutOfLine TakeMVarOp = True
+primOpOutOfLine TryTakeMVarOp = True
+primOpOutOfLine PutMVarOp = True
+primOpOutOfLine TryPutMVarOp = True
+primOpOutOfLine ReadMVarOp = True
+primOpOutOfLine TryReadMVarOp = True
+primOpOutOfLine IsEmptyMVarOp = True
+primOpOutOfLine DelayOp = True
+primOpOutOfLine WaitReadOp = True
+primOpOutOfLine WaitWriteOp = True
+primOpOutOfLine ForkOp = True
+primOpOutOfLine ForkOnOp = True
+primOpOutOfLine KillThreadOp = True
+primOpOutOfLine YieldOp = True
+primOpOutOfLine LabelThreadOp = True
+primOpOutOfLine IsCurrentThreadBoundOp = True
+primOpOutOfLine NoDuplicateOp = True
+primOpOutOfLine ThreadStatusOp = True
+primOpOutOfLine MkWeakOp = True
+primOpOutOfLine MkWeakNoFinalizerOp = True
+primOpOutOfLine AddCFinalizerToWeakOp = True
+primOpOutOfLine DeRefWeakOp = True
+primOpOutOfLine FinalizeWeakOp = True
+primOpOutOfLine MakeStablePtrOp = True
+primOpOutOfLine DeRefStablePtrOp = True
+primOpOutOfLine MakeStableNameOp = True
+primOpOutOfLine CompactNewOp = True
+primOpOutOfLine CompactResizeOp = True
+primOpOutOfLine CompactContainsOp = True
+primOpOutOfLine CompactContainsAnyOp = True
+primOpOutOfLine CompactGetFirstBlockOp = True
+primOpOutOfLine CompactGetNextBlockOp = True
+primOpOutOfLine CompactAllocateBlockOp = True
+primOpOutOfLine CompactFixupPointersOp = True
+primOpOutOfLine CompactAdd = True
+primOpOutOfLine CompactAddWithSharing = True
+primOpOutOfLine CompactSize = True
+primOpOutOfLine GetSparkOp = True
+primOpOutOfLine NumSparks = True
+primOpOutOfLine MkApUpd0_Op = True
+primOpOutOfLine NewBCOOp = True
+primOpOutOfLine UnpackClosureOp = True
+primOpOutOfLine GetApStackValOp = True
+primOpOutOfLine ClearCCSOp = True
+primOpOutOfLine TraceEventOp = True
+primOpOutOfLine TraceEventBinaryOp = True
+primOpOutOfLine TraceMarkerOp = True
+primOpOutOfLine GetThreadAllocationCounter = True
+primOpOutOfLine SetThreadAllocationCounter = True
+primOpOutOfLine _ = False
diff --git a/ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl b/ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl
@@ -0,0 +1,1192 @@
+primOpInfo CharGtOp = mkCompare (fsLit "gtChar#") charPrimTy
+primOpInfo CharGeOp = mkCompare (fsLit "geChar#") charPrimTy
+primOpInfo CharEqOp = mkCompare (fsLit "eqChar#") charPrimTy
+primOpInfo CharNeOp = mkCompare (fsLit "neChar#") charPrimTy
+primOpInfo CharLtOp = mkCompare (fsLit "ltChar#") charPrimTy
+primOpInfo CharLeOp = mkCompare (fsLit "leChar#") charPrimTy
+primOpInfo OrdOp = mkGenPrimOp (fsLit "ord#")  [] [charPrimTy] (intPrimTy)
+primOpInfo IntAddOp = mkDyadic (fsLit "+#") intPrimTy
+primOpInfo IntSubOp = mkDyadic (fsLit "-#") intPrimTy
+primOpInfo IntMulOp = mkDyadic (fsLit "*#") intPrimTy
+primOpInfo IntMulMayOfloOp = mkDyadic (fsLit "mulIntMayOflo#") intPrimTy
+primOpInfo IntQuotOp = mkDyadic (fsLit "quotInt#") intPrimTy
+primOpInfo IntRemOp = mkDyadic (fsLit "remInt#") intPrimTy
+primOpInfo IntQuotRemOp = mkGenPrimOp (fsLit "quotRemInt#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
+primOpInfo AndIOp = mkDyadic (fsLit "andI#") intPrimTy
+primOpInfo OrIOp = mkDyadic (fsLit "orI#") intPrimTy
+primOpInfo XorIOp = mkDyadic (fsLit "xorI#") intPrimTy
+primOpInfo NotIOp = mkMonadic (fsLit "notI#") intPrimTy
+primOpInfo IntNegOp = mkMonadic (fsLit "negateInt#") intPrimTy
+primOpInfo IntAddCOp = mkGenPrimOp (fsLit "addIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
+primOpInfo IntSubCOp = mkGenPrimOp (fsLit "subIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
+primOpInfo IntGtOp = mkCompare (fsLit ">#") intPrimTy
+primOpInfo IntGeOp = mkCompare (fsLit ">=#") intPrimTy
+primOpInfo IntEqOp = mkCompare (fsLit "==#") intPrimTy
+primOpInfo IntNeOp = mkCompare (fsLit "/=#") intPrimTy
+primOpInfo IntLtOp = mkCompare (fsLit "<#") intPrimTy
+primOpInfo IntLeOp = mkCompare (fsLit "<=#") intPrimTy
+primOpInfo ChrOp = mkGenPrimOp (fsLit "chr#")  [] [intPrimTy] (charPrimTy)
+primOpInfo Int2WordOp = mkGenPrimOp (fsLit "int2Word#")  [] [intPrimTy] (wordPrimTy)
+primOpInfo Int2FloatOp = mkGenPrimOp (fsLit "int2Float#")  [] [intPrimTy] (floatPrimTy)
+primOpInfo Int2DoubleOp = mkGenPrimOp (fsLit "int2Double#")  [] [intPrimTy] (doublePrimTy)
+primOpInfo Word2FloatOp = mkGenPrimOp (fsLit "word2Float#")  [] [wordPrimTy] (floatPrimTy)
+primOpInfo Word2DoubleOp = mkGenPrimOp (fsLit "word2Double#")  [] [wordPrimTy] (doublePrimTy)
+primOpInfo ISllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#")  [] [intPrimTy, intPrimTy] (intPrimTy)
+primOpInfo ISraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#")  [] [intPrimTy, intPrimTy] (intPrimTy)
+primOpInfo ISrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#")  [] [intPrimTy, intPrimTy] (intPrimTy)
+primOpInfo Int8Extend = mkGenPrimOp (fsLit "extendInt8#")  [] [int8PrimTy] (intPrimTy)
+primOpInfo Int8Narrow = mkGenPrimOp (fsLit "narrowInt8#")  [] [intPrimTy] (int8PrimTy)
+primOpInfo Int8NegOp = mkMonadic (fsLit "negateInt8#") int8PrimTy
+primOpInfo Int8AddOp = mkDyadic (fsLit "plusInt8#") int8PrimTy
+primOpInfo Int8SubOp = mkDyadic (fsLit "subInt8#") int8PrimTy
+primOpInfo Int8MulOp = mkDyadic (fsLit "timesInt8#") int8PrimTy
+primOpInfo Int8QuotOp = mkDyadic (fsLit "quotInt8#") int8PrimTy
+primOpInfo Int8RemOp = mkDyadic (fsLit "remInt8#") int8PrimTy
+primOpInfo Int8QuotRemOp = mkGenPrimOp (fsLit "quotRemInt8#")  [] [int8PrimTy, int8PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy]))
+primOpInfo Int8EqOp = mkCompare (fsLit "eqInt8#") int8PrimTy
+primOpInfo Int8GeOp = mkCompare (fsLit "geInt8#") int8PrimTy
+primOpInfo Int8GtOp = mkCompare (fsLit "gtInt8#") int8PrimTy
+primOpInfo Int8LeOp = mkCompare (fsLit "leInt8#") int8PrimTy
+primOpInfo Int8LtOp = mkCompare (fsLit "ltInt8#") int8PrimTy
+primOpInfo Int8NeOp = mkCompare (fsLit "neInt8#") int8PrimTy
+primOpInfo Word8Extend = mkGenPrimOp (fsLit "extendWord8#")  [] [word8PrimTy] (wordPrimTy)
+primOpInfo Word8Narrow = mkGenPrimOp (fsLit "narrowWord8#")  [] [wordPrimTy] (word8PrimTy)
+primOpInfo Word8NotOp = mkMonadic (fsLit "notWord8#") word8PrimTy
+primOpInfo Word8AddOp = mkDyadic (fsLit "plusWord8#") word8PrimTy
+primOpInfo Word8SubOp = mkDyadic (fsLit "subWord8#") word8PrimTy
+primOpInfo Word8MulOp = mkDyadic (fsLit "timesWord8#") word8PrimTy
+primOpInfo Word8QuotOp = mkDyadic (fsLit "quotWord8#") word8PrimTy
+primOpInfo Word8RemOp = mkDyadic (fsLit "remWord8#") word8PrimTy
+primOpInfo Word8QuotRemOp = mkGenPrimOp (fsLit "quotRemWord8#")  [] [word8PrimTy, word8PrimTy] ((mkTupleTy Unboxed [word8PrimTy, word8PrimTy]))
+primOpInfo Word8EqOp = mkCompare (fsLit "eqWord8#") word8PrimTy
+primOpInfo Word8GeOp = mkCompare (fsLit "geWord8#") word8PrimTy
+primOpInfo Word8GtOp = mkCompare (fsLit "gtWord8#") word8PrimTy
+primOpInfo Word8LeOp = mkCompare (fsLit "leWord8#") word8PrimTy
+primOpInfo Word8LtOp = mkCompare (fsLit "ltWord8#") word8PrimTy
+primOpInfo Word8NeOp = mkCompare (fsLit "neWord8#") word8PrimTy
+primOpInfo Int16Extend = mkGenPrimOp (fsLit "extendInt16#")  [] [int16PrimTy] (intPrimTy)
+primOpInfo Int16Narrow = mkGenPrimOp (fsLit "narrowInt16#")  [] [intPrimTy] (int16PrimTy)
+primOpInfo Int16NegOp = mkMonadic (fsLit "negateInt16#") int16PrimTy
+primOpInfo Int16AddOp = mkDyadic (fsLit "plusInt16#") int16PrimTy
+primOpInfo Int16SubOp = mkDyadic (fsLit "subInt16#") int16PrimTy
+primOpInfo Int16MulOp = mkDyadic (fsLit "timesInt16#") int16PrimTy
+primOpInfo Int16QuotOp = mkDyadic (fsLit "quotInt16#") int16PrimTy
+primOpInfo Int16RemOp = mkDyadic (fsLit "remInt16#") int16PrimTy
+primOpInfo Int16QuotRemOp = mkGenPrimOp (fsLit "quotRemInt16#")  [] [int16PrimTy, int16PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy]))
+primOpInfo Int16EqOp = mkCompare (fsLit "eqInt16#") int16PrimTy
+primOpInfo Int16GeOp = mkCompare (fsLit "geInt16#") int16PrimTy
+primOpInfo Int16GtOp = mkCompare (fsLit "gtInt16#") int16PrimTy
+primOpInfo Int16LeOp = mkCompare (fsLit "leInt16#") int16PrimTy
+primOpInfo Int16LtOp = mkCompare (fsLit "ltInt16#") int16PrimTy
+primOpInfo Int16NeOp = mkCompare (fsLit "neInt16#") int16PrimTy
+primOpInfo Word16Extend = mkGenPrimOp (fsLit "extendWord16#")  [] [word16PrimTy] (wordPrimTy)
+primOpInfo Word16Narrow = mkGenPrimOp (fsLit "narrowWord16#")  [] [wordPrimTy] (word16PrimTy)
+primOpInfo Word16NotOp = mkMonadic (fsLit "notWord16#") word16PrimTy
+primOpInfo Word16AddOp = mkDyadic (fsLit "plusWord16#") word16PrimTy
+primOpInfo Word16SubOp = mkDyadic (fsLit "subWord16#") word16PrimTy
+primOpInfo Word16MulOp = mkDyadic (fsLit "timesWord16#") word16PrimTy
+primOpInfo Word16QuotOp = mkDyadic (fsLit "quotWord16#") word16PrimTy
+primOpInfo Word16RemOp = mkDyadic (fsLit "remWord16#") word16PrimTy
+primOpInfo Word16QuotRemOp = mkGenPrimOp (fsLit "quotRemWord16#")  [] [word16PrimTy, word16PrimTy] ((mkTupleTy Unboxed [word16PrimTy, word16PrimTy]))
+primOpInfo Word16EqOp = mkCompare (fsLit "eqWord16#") word16PrimTy
+primOpInfo Word16GeOp = mkCompare (fsLit "geWord16#") word16PrimTy
+primOpInfo Word16GtOp = mkCompare (fsLit "gtWord16#") word16PrimTy
+primOpInfo Word16LeOp = mkCompare (fsLit "leWord16#") word16PrimTy
+primOpInfo Word16LtOp = mkCompare (fsLit "ltWord16#") word16PrimTy
+primOpInfo Word16NeOp = mkCompare (fsLit "neWord16#") word16PrimTy
+primOpInfo WordAddOp = mkDyadic (fsLit "plusWord#") wordPrimTy
+primOpInfo WordAddCOp = mkGenPrimOp (fsLit "addWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))
+primOpInfo WordSubCOp = mkGenPrimOp (fsLit "subWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))
+primOpInfo WordAdd2Op = mkGenPrimOp (fsLit "plusWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))
+primOpInfo WordSubOp = mkDyadic (fsLit "minusWord#") wordPrimTy
+primOpInfo WordMulOp = mkDyadic (fsLit "timesWord#") wordPrimTy
+primOpInfo WordMul2Op = mkGenPrimOp (fsLit "timesWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))
+primOpInfo WordQuotOp = mkDyadic (fsLit "quotWord#") wordPrimTy
+primOpInfo WordRemOp = mkDyadic (fsLit "remWord#") wordPrimTy
+primOpInfo WordQuotRemOp = mkGenPrimOp (fsLit "quotRemWord#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))
+primOpInfo WordQuotRem2Op = mkGenPrimOp (fsLit "quotRemWord2#")  [] [wordPrimTy, wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))
+primOpInfo AndOp = mkDyadic (fsLit "and#") wordPrimTy
+primOpInfo OrOp = mkDyadic (fsLit "or#") wordPrimTy
+primOpInfo XorOp = mkDyadic (fsLit "xor#") wordPrimTy
+primOpInfo NotOp = mkMonadic (fsLit "not#") wordPrimTy
+primOpInfo SllOp = mkGenPrimOp (fsLit "uncheckedShiftL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo Word2IntOp = mkGenPrimOp (fsLit "word2Int#")  [] [wordPrimTy] (intPrimTy)
+primOpInfo WordGtOp = mkCompare (fsLit "gtWord#") wordPrimTy
+primOpInfo WordGeOp = mkCompare (fsLit "geWord#") wordPrimTy
+primOpInfo WordEqOp = mkCompare (fsLit "eqWord#") wordPrimTy
+primOpInfo WordNeOp = mkCompare (fsLit "neWord#") wordPrimTy
+primOpInfo WordLtOp = mkCompare (fsLit "ltWord#") wordPrimTy
+primOpInfo WordLeOp = mkCompare (fsLit "leWord#") wordPrimTy
+primOpInfo PopCnt8Op = mkMonadic (fsLit "popCnt8#") wordPrimTy
+primOpInfo PopCnt16Op = mkMonadic (fsLit "popCnt16#") wordPrimTy
+primOpInfo PopCnt32Op = mkMonadic (fsLit "popCnt32#") wordPrimTy
+primOpInfo PopCnt64Op = mkGenPrimOp (fsLit "popCnt64#")  [] [wordPrimTy] (wordPrimTy)
+primOpInfo PopCntOp = mkMonadic (fsLit "popCnt#") wordPrimTy
+primOpInfo Pdep8Op = mkDyadic (fsLit "pdep8#") wordPrimTy
+primOpInfo Pdep16Op = mkDyadic (fsLit "pdep16#") wordPrimTy
+primOpInfo Pdep32Op = mkDyadic (fsLit "pdep32#") wordPrimTy
+primOpInfo Pdep64Op = mkGenPrimOp (fsLit "pdep64#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
+primOpInfo PdepOp = mkDyadic (fsLit "pdep#") wordPrimTy
+primOpInfo Pext8Op = mkDyadic (fsLit "pext8#") wordPrimTy
+primOpInfo Pext16Op = mkDyadic (fsLit "pext16#") wordPrimTy
+primOpInfo Pext32Op = mkDyadic (fsLit "pext32#") wordPrimTy
+primOpInfo Pext64Op = mkGenPrimOp (fsLit "pext64#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)
+primOpInfo PextOp = mkDyadic (fsLit "pext#") wordPrimTy
+primOpInfo Clz8Op = mkMonadic (fsLit "clz8#") wordPrimTy
+primOpInfo Clz16Op = mkMonadic (fsLit "clz16#") wordPrimTy
+primOpInfo Clz32Op = mkMonadic (fsLit "clz32#") wordPrimTy
+primOpInfo Clz64Op = mkGenPrimOp (fsLit "clz64#")  [] [wordPrimTy] (wordPrimTy)
+primOpInfo ClzOp = mkMonadic (fsLit "clz#") wordPrimTy
+primOpInfo Ctz8Op = mkMonadic (fsLit "ctz8#") wordPrimTy
+primOpInfo Ctz16Op = mkMonadic (fsLit "ctz16#") wordPrimTy
+primOpInfo Ctz32Op = mkMonadic (fsLit "ctz32#") wordPrimTy
+primOpInfo Ctz64Op = mkGenPrimOp (fsLit "ctz64#")  [] [wordPrimTy] (wordPrimTy)
+primOpInfo CtzOp = mkMonadic (fsLit "ctz#") wordPrimTy
+primOpInfo BSwap16Op = mkMonadic (fsLit "byteSwap16#") wordPrimTy
+primOpInfo BSwap32Op = mkMonadic (fsLit "byteSwap32#") wordPrimTy
+primOpInfo BSwap64Op = mkMonadic (fsLit "byteSwap64#") wordPrimTy
+primOpInfo BSwapOp = mkMonadic (fsLit "byteSwap#") wordPrimTy
+primOpInfo Narrow8IntOp = mkMonadic (fsLit "narrow8Int#") intPrimTy
+primOpInfo Narrow16IntOp = mkMonadic (fsLit "narrow16Int#") intPrimTy
+primOpInfo Narrow32IntOp = mkMonadic (fsLit "narrow32Int#") intPrimTy
+primOpInfo Narrow8WordOp = mkMonadic (fsLit "narrow8Word#") wordPrimTy
+primOpInfo Narrow16WordOp = mkMonadic (fsLit "narrow16Word#") wordPrimTy
+primOpInfo Narrow32WordOp = mkMonadic (fsLit "narrow32Word#") wordPrimTy
+primOpInfo DoubleGtOp = mkCompare (fsLit ">##") doublePrimTy
+primOpInfo DoubleGeOp = mkCompare (fsLit ">=##") doublePrimTy
+primOpInfo DoubleEqOp = mkCompare (fsLit "==##") doublePrimTy
+primOpInfo DoubleNeOp = mkCompare (fsLit "/=##") doublePrimTy
+primOpInfo DoubleLtOp = mkCompare (fsLit "<##") doublePrimTy
+primOpInfo DoubleLeOp = mkCompare (fsLit "<=##") doublePrimTy
+primOpInfo DoubleAddOp = mkDyadic (fsLit "+##") doublePrimTy
+primOpInfo DoubleSubOp = mkDyadic (fsLit "-##") doublePrimTy
+primOpInfo DoubleMulOp = mkDyadic (fsLit "*##") doublePrimTy
+primOpInfo DoubleDivOp = mkDyadic (fsLit "/##") doublePrimTy
+primOpInfo DoubleNegOp = mkMonadic (fsLit "negateDouble#") doublePrimTy
+primOpInfo DoubleFabsOp = mkMonadic (fsLit "fabsDouble#") doublePrimTy
+primOpInfo Double2IntOp = mkGenPrimOp (fsLit "double2Int#")  [] [doublePrimTy] (intPrimTy)
+primOpInfo Double2FloatOp = mkGenPrimOp (fsLit "double2Float#")  [] [doublePrimTy] (floatPrimTy)
+primOpInfo DoubleExpOp = mkMonadic (fsLit "expDouble#") doublePrimTy
+primOpInfo DoubleLogOp = mkMonadic (fsLit "logDouble#") doublePrimTy
+primOpInfo DoubleSqrtOp = mkMonadic (fsLit "sqrtDouble#") doublePrimTy
+primOpInfo DoubleSinOp = mkMonadic (fsLit "sinDouble#") doublePrimTy
+primOpInfo DoubleCosOp = mkMonadic (fsLit "cosDouble#") doublePrimTy
+primOpInfo DoubleTanOp = mkMonadic (fsLit "tanDouble#") doublePrimTy
+primOpInfo DoubleAsinOp = mkMonadic (fsLit "asinDouble#") doublePrimTy
+primOpInfo DoubleAcosOp = mkMonadic (fsLit "acosDouble#") doublePrimTy
+primOpInfo DoubleAtanOp = mkMonadic (fsLit "atanDouble#") doublePrimTy
+primOpInfo DoubleSinhOp = mkMonadic (fsLit "sinhDouble#") doublePrimTy
+primOpInfo DoubleCoshOp = mkMonadic (fsLit "coshDouble#") doublePrimTy
+primOpInfo DoubleTanhOp = mkMonadic (fsLit "tanhDouble#") doublePrimTy
+primOpInfo DoubleAsinhOp = mkMonadic (fsLit "asinhDouble#") doublePrimTy
+primOpInfo DoubleAcoshOp = mkMonadic (fsLit "acoshDouble#") doublePrimTy
+primOpInfo DoubleAtanhOp = mkMonadic (fsLit "atanhDouble#") doublePrimTy
+primOpInfo DoublePowerOp = mkDyadic (fsLit "**##") doublePrimTy
+primOpInfo DoubleDecode_2IntOp = mkGenPrimOp (fsLit "decodeDouble_2Int#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, wordPrimTy, wordPrimTy, intPrimTy]))
+primOpInfo DoubleDecode_Int64Op = mkGenPrimOp (fsLit "decodeDouble_Int64#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
+primOpInfo FloatGtOp = mkCompare (fsLit "gtFloat#") floatPrimTy
+primOpInfo FloatGeOp = mkCompare (fsLit "geFloat#") floatPrimTy
+primOpInfo FloatEqOp = mkCompare (fsLit "eqFloat#") floatPrimTy
+primOpInfo FloatNeOp = mkCompare (fsLit "neFloat#") floatPrimTy
+primOpInfo FloatLtOp = mkCompare (fsLit "ltFloat#") floatPrimTy
+primOpInfo FloatLeOp = mkCompare (fsLit "leFloat#") floatPrimTy
+primOpInfo FloatAddOp = mkDyadic (fsLit "plusFloat#") floatPrimTy
+primOpInfo FloatSubOp = mkDyadic (fsLit "minusFloat#") floatPrimTy
+primOpInfo FloatMulOp = mkDyadic (fsLit "timesFloat#") floatPrimTy
+primOpInfo FloatDivOp = mkDyadic (fsLit "divideFloat#") floatPrimTy
+primOpInfo FloatNegOp = mkMonadic (fsLit "negateFloat#") floatPrimTy
+primOpInfo FloatFabsOp = mkMonadic (fsLit "fabsFloat#") floatPrimTy
+primOpInfo Float2IntOp = mkGenPrimOp (fsLit "float2Int#")  [] [floatPrimTy] (intPrimTy)
+primOpInfo FloatExpOp = mkMonadic (fsLit "expFloat#") floatPrimTy
+primOpInfo FloatLogOp = mkMonadic (fsLit "logFloat#") floatPrimTy
+primOpInfo FloatSqrtOp = mkMonadic (fsLit "sqrtFloat#") floatPrimTy
+primOpInfo FloatSinOp = mkMonadic (fsLit "sinFloat#") floatPrimTy
+primOpInfo FloatCosOp = mkMonadic (fsLit "cosFloat#") floatPrimTy
+primOpInfo FloatTanOp = mkMonadic (fsLit "tanFloat#") floatPrimTy
+primOpInfo FloatAsinOp = mkMonadic (fsLit "asinFloat#") floatPrimTy
+primOpInfo FloatAcosOp = mkMonadic (fsLit "acosFloat#") floatPrimTy
+primOpInfo FloatAtanOp = mkMonadic (fsLit "atanFloat#") floatPrimTy
+primOpInfo FloatSinhOp = mkMonadic (fsLit "sinhFloat#") floatPrimTy
+primOpInfo FloatCoshOp = mkMonadic (fsLit "coshFloat#") floatPrimTy
+primOpInfo FloatTanhOp = mkMonadic (fsLit "tanhFloat#") floatPrimTy
+primOpInfo FloatAsinhOp = mkMonadic (fsLit "asinhFloat#") floatPrimTy
+primOpInfo FloatAcoshOp = mkMonadic (fsLit "acoshFloat#") floatPrimTy
+primOpInfo FloatAtanhOp = mkMonadic (fsLit "atanhFloat#") floatPrimTy
+primOpInfo FloatPowerOp = mkDyadic (fsLit "powerFloat#") floatPrimTy
+primOpInfo Float2DoubleOp = mkGenPrimOp (fsLit "float2Double#")  [] [floatPrimTy] (doublePrimTy)
+primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#")  [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
+primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#")  [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo SameMutableArrayOp = mkGenPrimOp (fsLit "sameMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)
+primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy] (intPrimTy)
+primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)
+primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy]))
+primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy]))
+primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy alphaTy)
+primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy]))
+primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))
+primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#")  [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo SameSmallMutableArrayOp = mkGenPrimOp (fsLit "sameSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)
+primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy] (intPrimTy)
+primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)
+primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy]))
+primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy]))
+primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy alphaTy)
+primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy]))
+primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))
+primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))
+primOpInfo NewByteArrayOp_Char = mkGenPrimOp (fsLit "newByteArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))
+primOpInfo NewPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newPinnedByteArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))
+primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#")  [deltaTyVar] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))
+primOpInfo MutableByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isMutableByteArrayPinned#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)
+primOpInfo ByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isByteArrayPinned#")  [] [byteArrayPrimTy] (intPrimTy)
+primOpInfo ByteArrayContents_Char = mkGenPrimOp (fsLit "byteArrayContents#")  [] [byteArrayPrimTy] (addrPrimTy)
+primOpInfo SameMutableByteArrayOp = mkGenPrimOp (fsLit "sameMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy] (intPrimTy)
+primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo ResizeMutableByteArrayOp_Char = mkGenPrimOp (fsLit "resizeMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))
+primOpInfo UnsafeFreezeByteArrayOp = mkGenPrimOp (fsLit "unsafeFreezeByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))
+primOpInfo SizeofByteArrayOp = mkGenPrimOp (fsLit "sizeofByteArray#")  [] [byteArrayPrimTy] (intPrimTy)
+primOpInfo SizeofMutableByteArrayOp = mkGenPrimOp (fsLit "sizeofMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)
+primOpInfo GetSizeofMutableByteArrayOp = mkGenPrimOp (fsLit "getSizeofMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo IndexByteArrayOp_Char = mkGenPrimOp (fsLit "indexCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)
+primOpInfo IndexByteArrayOp_WideChar = mkGenPrimOp (fsLit "indexWideCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)
+primOpInfo IndexByteArrayOp_Int = mkGenPrimOp (fsLit "indexIntArray#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Word = mkGenPrimOp (fsLit "indexWordArray#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Addr = mkGenPrimOp (fsLit "indexAddrArray#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)
+primOpInfo IndexByteArrayOp_Float = mkGenPrimOp (fsLit "indexFloatArray#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)
+primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)
+primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#")  [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)
+primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "indexWord8ArrayAsAddr#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "indexWord8ArrayAsFloat#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8ArrayAsDouble#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)
+primOpInfo IndexByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "indexWord8ArrayAsStablePtr#")  [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)
+primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8ArrayAsWord#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
+primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
+primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Word = mkGenPrimOp (fsLit "readWordArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Addr = mkGenPrimOp (fsLit "readAddrArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
+primOpInfo ReadByteArrayOp_Float = mkGenPrimOp (fsLit "readFloatArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))
+primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))
+primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))
+primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "readWord8ArrayAsAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "readWord8ArrayAsFloat#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8ArrayAsDouble#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "readWord8ArrayAsStablePtr#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))
+primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8ArrayAsWord#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word = mkGenPrimOp (fsLit "writeWordArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Addr = mkGenPrimOp (fsLit "writeAddrArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Float = mkGenPrimOp (fsLit "writeFloatArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "writeWord8ArrayAsAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "writeWord8ArrayAsFloat#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8ArrayAsDouble#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "writeWord8ArrayAsStablePtr#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8ArrayAsWord#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#")  [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy)
+primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#")  [deltaTyVar] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo FetchAddByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAddIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo FetchSubByteArrayOp_Int = mkGenPrimOp (fsLit "fetchSubIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo FetchAndByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAndIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo FetchNandByteArrayOp_Int = mkGenPrimOp (fsLit "fetchNandIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo FetchOrByteArrayOp_Int = mkGenPrimOp (fsLit "fetchOrIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo FetchXorByteArrayOp_Int = mkGenPrimOp (fsLit "fetchXorIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo NewArrayArrayOp = mkGenPrimOp (fsLit "newArrayArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy]))
+primOpInfo SameMutableArrayArrayOp = mkGenPrimOp (fsLit "sameMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy] (intPrimTy)
+primOpInfo UnsafeFreezeArrayArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy]))
+primOpInfo SizeofArrayArrayOp = mkGenPrimOp (fsLit "sizeofArrayArray#")  [] [mkArrayArrayPrimTy] (intPrimTy)
+primOpInfo SizeofMutableArrayArrayOp = mkGenPrimOp (fsLit "sizeofMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy] (intPrimTy)
+primOpInfo IndexArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "indexByteArrayArray#")  [] [mkArrayArrayPrimTy, intPrimTy] (byteArrayPrimTy)
+primOpInfo IndexArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "indexArrayArrayArray#")  [] [mkArrayArrayPrimTy, intPrimTy] (mkArrayArrayPrimTy)
+primOpInfo ReadArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "readByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))
+primOpInfo ReadArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "readMutableByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))
+primOpInfo ReadArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "readArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy]))
+primOpInfo ReadArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "readMutableArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy]))
+primOpInfo WriteArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "writeByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "writeMutableByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "writeArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkArrayArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "writeMutableArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopyArrayArrayOp = mkGenPrimOp (fsLit "copyArrayArray#")  [deltaTyVar] [mkArrayArrayPrimTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo CopyMutableArrayArrayOp = mkGenPrimOp (fsLit "copyMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)
+primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#")  [] [addrPrimTy, addrPrimTy] (intPrimTy)
+primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)
+primOpInfo Addr2IntOp = mkGenPrimOp (fsLit "addr2Int#")  [] [addrPrimTy] (intPrimTy)
+primOpInfo Int2AddrOp = mkGenPrimOp (fsLit "int2Addr#")  [] [intPrimTy] (addrPrimTy)
+primOpInfo AddrGtOp = mkCompare (fsLit "gtAddr#") addrPrimTy
+primOpInfo AddrGeOp = mkCompare (fsLit "geAddr#") addrPrimTy
+primOpInfo AddrEqOp = mkCompare (fsLit "eqAddr#") addrPrimTy
+primOpInfo AddrNeOp = mkCompare (fsLit "neAddr#") addrPrimTy
+primOpInfo AddrLtOp = mkCompare (fsLit "ltAddr#") addrPrimTy
+primOpInfo AddrLeOp = mkCompare (fsLit "leAddr#") addrPrimTy
+primOpInfo IndexOffAddrOp_Char = mkGenPrimOp (fsLit "indexCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)
+primOpInfo IndexOffAddrOp_WideChar = mkGenPrimOp (fsLit "indexWideCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)
+primOpInfo IndexOffAddrOp_Int = mkGenPrimOp (fsLit "indexIntOffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexOffAddrOp_Word = mkGenPrimOp (fsLit "indexWordOffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexOffAddrOp_Addr = mkGenPrimOp (fsLit "indexAddrOffAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)
+primOpInfo IndexOffAddrOp_Float = mkGenPrimOp (fsLit "indexFloatOffAddr#")  [] [addrPrimTy, intPrimTy] (floatPrimTy)
+primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#")  [] [addrPrimTy, intPrimTy] (doublePrimTy)
+primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#")  [alphaTyVar] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)
+primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)
+primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)
+primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
+primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))
+primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadOffAddrOp_Word = mkGenPrimOp (fsLit "readWordOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadOffAddrOp_Addr = mkGenPrimOp (fsLit "readAddrOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
+primOpInfo ReadOffAddrOp_Float = mkGenPrimOp (fsLit "readFloatOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))
+primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))
+primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#")  [deltaTyVar, alphaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))
+primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))
+primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Word = mkGenPrimOp (fsLit "writeWordOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Addr = mkGenPrimOp (fsLit "writeAddrOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Float = mkGenPrimOp (fsLit "writeFloatOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#")  [alphaTyVar, deltaTyVar] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy alphaTy]))
+primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo SameMutVarOp = mkGenPrimOp (fsLit "sameMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkMutVarPrimTy deltaTy alphaTy] (intPrimTy)
+primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#")  [deltaTyVar, alphaTyVar, gammaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkFunTy (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy]))
+primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkFunTy (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy]))
+primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))
+primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#")  [alphaTyVar, betaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkFunTy (betaTy) ((mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#")  [betaTyVar, runtimeRep1TyVar, openAlphaTyVar] [betaTy] (openAlphaTy)
+primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#")  [alphaTyVar, betaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy]))
+primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
+primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#")  [alphaTyVar] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#")  [alphaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#")  [alphaTyVar, betaTyVar] [(mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkFunTy (betaTy) ((mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy alphaTy]))
+primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo SameTVarOp = mkGenPrimOp (fsLit "sameTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkTVarPrimTy deltaTy alphaTy] (intPrimTy)
+primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#")  [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy alphaTy]))
+primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))
+primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))
+primOpInfo SameMVarOp = mkGenPrimOp (fsLit "sameMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkMVarPrimTy deltaTy alphaTy] (intPrimTy)
+primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))
+primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#")  [alphaTyVar] [intPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))
+primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#")  [alphaTyVar] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
+primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#")  [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
+primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))
+primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#")  [] [threadIdPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
+primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
+primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#")  [deltaTyVar] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#")  [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar, gammaTyVar] [openAlphaTy, betaTy, (mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))
+primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar] [openAlphaTy, betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))
+primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#")  [betaTyVar] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
+primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#")  [alphaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, alphaTy]))
+primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#")  [alphaTyVar, betaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))]))
+primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#")  [runtimeRep1TyVar, openAlphaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
+primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy alphaTy]))
+primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#")  [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#")  [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy alphaTy] (intPrimTy)
+primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy]))
+primOpInfo EqStableNameOp = mkGenPrimOp (fsLit "eqStableName#")  [alphaTyVar, betaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy] (intPrimTy)
+primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#")  [alphaTyVar] [mkStableNamePrimTy alphaTy] (intPrimTy)
+primOpInfo CompactNewOp = mkGenPrimOp (fsLit "compactNew#")  [] [wordPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy]))
+primOpInfo CompactResizeOp = mkGenPrimOp (fsLit "compactResize#")  [] [compactPrimTy, wordPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
+primOpInfo CompactContainsOp = mkGenPrimOp (fsLit "compactContains#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
+primOpInfo CompactContainsAnyOp = mkGenPrimOp (fsLit "compactContainsAny#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
+primOpInfo CompactGetFirstBlockOp = mkGenPrimOp (fsLit "compactGetFirstBlock#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))
+primOpInfo CompactGetNextBlockOp = mkGenPrimOp (fsLit "compactGetNextBlock#")  [] [compactPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))
+primOpInfo CompactAllocateBlockOp = mkGenPrimOp (fsLit "compactAllocateBlock#")  [] [wordPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))
+primOpInfo CompactFixupPointersOp = mkGenPrimOp (fsLit "compactFixupPointers#")  [] [addrPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy, addrPrimTy]))
+primOpInfo CompactAdd = mkGenPrimOp (fsLit "compactAdd#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo CompactAddWithSharing = mkGenPrimOp (fsLit "compactAddWithSharing#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))
+primOpInfo CompactSize = mkGenPrimOp (fsLit "compactSize#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, wordPrimTy]))
+primOpInfo ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#")  [alphaTyVar] [alphaTy, alphaTy] (intPrimTy)
+primOpInfo ParOp = mkGenPrimOp (fsLit "par#")  [alphaTyVar] [alphaTy] (intPrimTy)
+primOpInfo SparkOp = mkGenPrimOp (fsLit "spark#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#")  [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))
+primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#")  [deltaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))
+primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#")  [alphaTyVar] [alphaTy] (intPrimTy)
+primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#")  [alphaTyVar] [intPrimTy] (alphaTy)
+primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#")  [alphaTyVar] [addrPrimTy] ((mkTupleTy Unboxed [alphaTy]))
+primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))
+primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#")  [alphaTyVar] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy]))
+primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#")  [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy]))
+primOpInfo UnpackClosureOp = mkGenPrimOp (fsLit "unpackClosure#")  [alphaTyVar, betaTyVar] [alphaTy] ((mkTupleTy Unboxed [addrPrimTy, byteArrayPrimTy, mkArrayPrimTy betaTy]))
+primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#")  [alphaTyVar, betaTyVar] [alphaTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, betaTy]))
+primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
+primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))
+primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#")  [deltaTyVar, alphaTyVar] [(mkFunTy (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))
+primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo GetThreadAllocationCounter = mkGenPrimOp (fsLit "getThreadAllocationCounter#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))
+primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#")  [] [intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)
+primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#")  [] [intPrimTy] (int8X16PrimTy)
+primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#")  [] [intPrimTy] (int16X8PrimTy)
+primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#")  [] [intPrimTy] (int32X4PrimTy)
+primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#")  [] [intPrimTy] (int64X2PrimTy)
+primOpInfo (VecBroadcastOp IntVec 32 W8) = mkGenPrimOp (fsLit "broadcastInt8X32#")  [] [intPrimTy] (int8X32PrimTy)
+primOpInfo (VecBroadcastOp IntVec 16 W16) = mkGenPrimOp (fsLit "broadcastInt16X16#")  [] [intPrimTy] (int16X16PrimTy)
+primOpInfo (VecBroadcastOp IntVec 8 W32) = mkGenPrimOp (fsLit "broadcastInt32X8#")  [] [intPrimTy] (int32X8PrimTy)
+primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#")  [] [intPrimTy] (int64X4PrimTy)
+primOpInfo (VecBroadcastOp IntVec 64 W8) = mkGenPrimOp (fsLit "broadcastInt8X64#")  [] [intPrimTy] (int8X64PrimTy)
+primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#")  [] [intPrimTy] (int16X32PrimTy)
+primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#")  [] [intPrimTy] (int32X16PrimTy)
+primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#")  [] [intPrimTy] (int64X8PrimTy)
+primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#")  [] [wordPrimTy] (word8X16PrimTy)
+primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#")  [] [wordPrimTy] (word16X8PrimTy)
+primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#")  [] [wordPrimTy] (word32X4PrimTy)
+primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#")  [] [wordPrimTy] (word64X2PrimTy)
+primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#")  [] [wordPrimTy] (word8X32PrimTy)
+primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#")  [] [wordPrimTy] (word16X16PrimTy)
+primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#")  [] [wordPrimTy] (word32X8PrimTy)
+primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#")  [] [wordPrimTy] (word64X4PrimTy)
+primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#")  [] [wordPrimTy] (word8X64PrimTy)
+primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#")  [] [wordPrimTy] (word16X32PrimTy)
+primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#")  [] [wordPrimTy] (word32X16PrimTy)
+primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#")  [] [wordPrimTy] (word64X8PrimTy)
+primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#")  [] [floatPrimTy] (floatX4PrimTy)
+primOpInfo (VecBroadcastOp FloatVec 2 W64) = mkGenPrimOp (fsLit "broadcastDoubleX2#")  [] [doublePrimTy] (doubleX2PrimTy)
+primOpInfo (VecBroadcastOp FloatVec 8 W32) = mkGenPrimOp (fsLit "broadcastFloatX8#")  [] [floatPrimTy] (floatX8PrimTy)
+primOpInfo (VecBroadcastOp FloatVec 4 W64) = mkGenPrimOp (fsLit "broadcastDoubleX4#")  [] [doublePrimTy] (doubleX4PrimTy)
+primOpInfo (VecBroadcastOp FloatVec 16 W32) = mkGenPrimOp (fsLit "broadcastFloatX16#")  [] [floatPrimTy] (floatX16PrimTy)
+primOpInfo (VecBroadcastOp FloatVec 8 W64) = mkGenPrimOp (fsLit "broadcastDoubleX8#")  [] [doublePrimTy] (doubleX8PrimTy)
+primOpInfo (VecPackOp IntVec 16 W8) = mkGenPrimOp (fsLit "packInt8X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X16PrimTy)
+primOpInfo (VecPackOp IntVec 8 W16) = mkGenPrimOp (fsLit "packInt16X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X8PrimTy)
+primOpInfo (VecPackOp IntVec 4 W32) = mkGenPrimOp (fsLit "packInt32X4#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X4PrimTy)
+primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy])] (int64X2PrimTy)
+primOpInfo (VecPackOp IntVec 32 W8) = mkGenPrimOp (fsLit "packInt8X32#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X32PrimTy)
+primOpInfo (VecPackOp IntVec 16 W16) = mkGenPrimOp (fsLit "packInt16X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X16PrimTy)
+primOpInfo (VecPackOp IntVec 8 W32) = mkGenPrimOp (fsLit "packInt32X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X8PrimTy)
+primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X4PrimTy)
+primOpInfo (VecPackOp IntVec 64 W8) = mkGenPrimOp (fsLit "packInt8X64#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X64PrimTy)
+primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X32PrimTy)
+primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X16PrimTy)
+primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X8PrimTy)
+primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X16PrimTy)
+primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X8PrimTy)
+primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X4PrimTy)
+primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy])] (word64X2PrimTy)
+primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X32PrimTy)
+primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X16PrimTy)
+primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X8PrimTy)
+primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X4PrimTy)
+primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X64PrimTy)
+primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X32PrimTy)
+primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X16PrimTy)
+primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X8PrimTy)
+primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy)
+primOpInfo (VecPackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "packDoubleX2#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy])] (doubleX2PrimTy)
+primOpInfo (VecPackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "packFloatX8#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX8PrimTy)
+primOpInfo (VecPackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "packDoubleX4#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX4PrimTy)
+primOpInfo (VecPackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "packFloatX16#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX16PrimTy)
+primOpInfo (VecPackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "packDoubleX8#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX8PrimTy)
+primOpInfo (VecUnpackOp IntVec 16 W8) = mkGenPrimOp (fsLit "unpackInt8X16#")  [] [int8X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 8 W16) = mkGenPrimOp (fsLit "unpackInt16X8#")  [] [int16X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 4 W32) = mkGenPrimOp (fsLit "unpackInt32X4#")  [] [int32X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#")  [] [int64X2PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 32 W8) = mkGenPrimOp (fsLit "unpackInt8X32#")  [] [int8X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 16 W16) = mkGenPrimOp (fsLit "unpackInt16X16#")  [] [int16X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 8 W32) = mkGenPrimOp (fsLit "unpackInt32X8#")  [] [int32X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#")  [] [int64X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 64 W8) = mkGenPrimOp (fsLit "unpackInt8X64#")  [] [int8X64PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#")  [] [int16X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#")  [] [int32X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#")  [] [int64X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))
+primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#")  [] [word8X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#")  [] [word16X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#")  [] [word32X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#")  [] [word64X2PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#")  [] [word8X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#")  [] [word16X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#")  [] [word32X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#")  [] [word64X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#")  [] [word8X64PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#")  [] [word16X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#")  [] [word32X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#")  [] [word64X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))
+primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#")  [] [floatX4PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))
+primOpInfo (VecUnpackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "unpackDoubleX2#")  [] [doubleX2PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy]))
+primOpInfo (VecUnpackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "unpackFloatX8#")  [] [floatX8PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))
+primOpInfo (VecUnpackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "unpackDoubleX4#")  [] [doubleX4PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))
+primOpInfo (VecUnpackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "unpackFloatX16#")  [] [floatX16PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))
+primOpInfo (VecUnpackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "unpackDoubleX8#")  [] [doubleX8PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))
+primOpInfo (VecInsertOp IntVec 16 W8) = mkGenPrimOp (fsLit "insertInt8X16#")  [] [int8X16PrimTy, intPrimTy, intPrimTy] (int8X16PrimTy)
+primOpInfo (VecInsertOp IntVec 8 W16) = mkGenPrimOp (fsLit "insertInt16X8#")  [] [int16X8PrimTy, intPrimTy, intPrimTy] (int16X8PrimTy)
+primOpInfo (VecInsertOp IntVec 4 W32) = mkGenPrimOp (fsLit "insertInt32X4#")  [] [int32X4PrimTy, intPrimTy, intPrimTy] (int32X4PrimTy)
+primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#")  [] [int64X2PrimTy, intPrimTy, intPrimTy] (int64X2PrimTy)
+primOpInfo (VecInsertOp IntVec 32 W8) = mkGenPrimOp (fsLit "insertInt8X32#")  [] [int8X32PrimTy, intPrimTy, intPrimTy] (int8X32PrimTy)
+primOpInfo (VecInsertOp IntVec 16 W16) = mkGenPrimOp (fsLit "insertInt16X16#")  [] [int16X16PrimTy, intPrimTy, intPrimTy] (int16X16PrimTy)
+primOpInfo (VecInsertOp IntVec 8 W32) = mkGenPrimOp (fsLit "insertInt32X8#")  [] [int32X8PrimTy, intPrimTy, intPrimTy] (int32X8PrimTy)
+primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#")  [] [int64X4PrimTy, intPrimTy, intPrimTy] (int64X4PrimTy)
+primOpInfo (VecInsertOp IntVec 64 W8) = mkGenPrimOp (fsLit "insertInt8X64#")  [] [int8X64PrimTy, intPrimTy, intPrimTy] (int8X64PrimTy)
+primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#")  [] [int16X32PrimTy, intPrimTy, intPrimTy] (int16X32PrimTy)
+primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#")  [] [int32X16PrimTy, intPrimTy, intPrimTy] (int32X16PrimTy)
+primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#")  [] [int64X8PrimTy, intPrimTy, intPrimTy] (int64X8PrimTy)
+primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#")  [] [word8X16PrimTy, wordPrimTy, intPrimTy] (word8X16PrimTy)
+primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#")  [] [word16X8PrimTy, wordPrimTy, intPrimTy] (word16X8PrimTy)
+primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#")  [] [word32X4PrimTy, wordPrimTy, intPrimTy] (word32X4PrimTy)
+primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#")  [] [word64X2PrimTy, wordPrimTy, intPrimTy] (word64X2PrimTy)
+primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#")  [] [word8X32PrimTy, wordPrimTy, intPrimTy] (word8X32PrimTy)
+primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#")  [] [word16X16PrimTy, wordPrimTy, intPrimTy] (word16X16PrimTy)
+primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#")  [] [word32X8PrimTy, wordPrimTy, intPrimTy] (word32X8PrimTy)
+primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#")  [] [word64X4PrimTy, wordPrimTy, intPrimTy] (word64X4PrimTy)
+primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#")  [] [word8X64PrimTy, wordPrimTy, intPrimTy] (word8X64PrimTy)
+primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#")  [] [word16X32PrimTy, wordPrimTy, intPrimTy] (word16X32PrimTy)
+primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#")  [] [word32X16PrimTy, wordPrimTy, intPrimTy] (word32X16PrimTy)
+primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#")  [] [word64X8PrimTy, wordPrimTy, intPrimTy] (word64X8PrimTy)
+primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#")  [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy)
+primOpInfo (VecInsertOp FloatVec 2 W64) = mkGenPrimOp (fsLit "insertDoubleX2#")  [] [doubleX2PrimTy, doublePrimTy, intPrimTy] (doubleX2PrimTy)
+primOpInfo (VecInsertOp FloatVec 8 W32) = mkGenPrimOp (fsLit "insertFloatX8#")  [] [floatX8PrimTy, floatPrimTy, intPrimTy] (floatX8PrimTy)
+primOpInfo (VecInsertOp FloatVec 4 W64) = mkGenPrimOp (fsLit "insertDoubleX4#")  [] [doubleX4PrimTy, doublePrimTy, intPrimTy] (doubleX4PrimTy)
+primOpInfo (VecInsertOp FloatVec 16 W32) = mkGenPrimOp (fsLit "insertFloatX16#")  [] [floatX16PrimTy, floatPrimTy, intPrimTy] (floatX16PrimTy)
+primOpInfo (VecInsertOp FloatVec 8 W64) = mkGenPrimOp (fsLit "insertDoubleX8#")  [] [doubleX8PrimTy, doublePrimTy, intPrimTy] (doubleX8PrimTy)
+primOpInfo (VecAddOp IntVec 16 W8) = mkDyadic (fsLit "plusInt8X16#") int8X16PrimTy
+primOpInfo (VecAddOp IntVec 8 W16) = mkDyadic (fsLit "plusInt16X8#") int16X8PrimTy
+primOpInfo (VecAddOp IntVec 4 W32) = mkDyadic (fsLit "plusInt32X4#") int32X4PrimTy
+primOpInfo (VecAddOp IntVec 2 W64) = mkDyadic (fsLit "plusInt64X2#") int64X2PrimTy
+primOpInfo (VecAddOp IntVec 32 W8) = mkDyadic (fsLit "plusInt8X32#") int8X32PrimTy
+primOpInfo (VecAddOp IntVec 16 W16) = mkDyadic (fsLit "plusInt16X16#") int16X16PrimTy
+primOpInfo (VecAddOp IntVec 8 W32) = mkDyadic (fsLit "plusInt32X8#") int32X8PrimTy
+primOpInfo (VecAddOp IntVec 4 W64) = mkDyadic (fsLit "plusInt64X4#") int64X4PrimTy
+primOpInfo (VecAddOp IntVec 64 W8) = mkDyadic (fsLit "plusInt8X64#") int8X64PrimTy
+primOpInfo (VecAddOp IntVec 32 W16) = mkDyadic (fsLit "plusInt16X32#") int16X32PrimTy
+primOpInfo (VecAddOp IntVec 16 W32) = mkDyadic (fsLit "plusInt32X16#") int32X16PrimTy
+primOpInfo (VecAddOp IntVec 8 W64) = mkDyadic (fsLit "plusInt64X8#") int64X8PrimTy
+primOpInfo (VecAddOp WordVec 16 W8) = mkDyadic (fsLit "plusWord8X16#") word8X16PrimTy
+primOpInfo (VecAddOp WordVec 8 W16) = mkDyadic (fsLit "plusWord16X8#") word16X8PrimTy
+primOpInfo (VecAddOp WordVec 4 W32) = mkDyadic (fsLit "plusWord32X4#") word32X4PrimTy
+primOpInfo (VecAddOp WordVec 2 W64) = mkDyadic (fsLit "plusWord64X2#") word64X2PrimTy
+primOpInfo (VecAddOp WordVec 32 W8) = mkDyadic (fsLit "plusWord8X32#") word8X32PrimTy
+primOpInfo (VecAddOp WordVec 16 W16) = mkDyadic (fsLit "plusWord16X16#") word16X16PrimTy
+primOpInfo (VecAddOp WordVec 8 W32) = mkDyadic (fsLit "plusWord32X8#") word32X8PrimTy
+primOpInfo (VecAddOp WordVec 4 W64) = mkDyadic (fsLit "plusWord64X4#") word64X4PrimTy
+primOpInfo (VecAddOp WordVec 64 W8) = mkDyadic (fsLit "plusWord8X64#") word8X64PrimTy
+primOpInfo (VecAddOp WordVec 32 W16) = mkDyadic (fsLit "plusWord16X32#") word16X32PrimTy
+primOpInfo (VecAddOp WordVec 16 W32) = mkDyadic (fsLit "plusWord32X16#") word32X16PrimTy
+primOpInfo (VecAddOp WordVec 8 W64) = mkDyadic (fsLit "plusWord64X8#") word64X8PrimTy
+primOpInfo (VecAddOp FloatVec 4 W32) = mkDyadic (fsLit "plusFloatX4#") floatX4PrimTy
+primOpInfo (VecAddOp FloatVec 2 W64) = mkDyadic (fsLit "plusDoubleX2#") doubleX2PrimTy
+primOpInfo (VecAddOp FloatVec 8 W32) = mkDyadic (fsLit "plusFloatX8#") floatX8PrimTy
+primOpInfo (VecAddOp FloatVec 4 W64) = mkDyadic (fsLit "plusDoubleX4#") doubleX4PrimTy
+primOpInfo (VecAddOp FloatVec 16 W32) = mkDyadic (fsLit "plusFloatX16#") floatX16PrimTy
+primOpInfo (VecAddOp FloatVec 8 W64) = mkDyadic (fsLit "plusDoubleX8#") doubleX8PrimTy
+primOpInfo (VecSubOp IntVec 16 W8) = mkDyadic (fsLit "minusInt8X16#") int8X16PrimTy
+primOpInfo (VecSubOp IntVec 8 W16) = mkDyadic (fsLit "minusInt16X8#") int16X8PrimTy
+primOpInfo (VecSubOp IntVec 4 W32) = mkDyadic (fsLit "minusInt32X4#") int32X4PrimTy
+primOpInfo (VecSubOp IntVec 2 W64) = mkDyadic (fsLit "minusInt64X2#") int64X2PrimTy
+primOpInfo (VecSubOp IntVec 32 W8) = mkDyadic (fsLit "minusInt8X32#") int8X32PrimTy
+primOpInfo (VecSubOp IntVec 16 W16) = mkDyadic (fsLit "minusInt16X16#") int16X16PrimTy
+primOpInfo (VecSubOp IntVec 8 W32) = mkDyadic (fsLit "minusInt32X8#") int32X8PrimTy
+primOpInfo (VecSubOp IntVec 4 W64) = mkDyadic (fsLit "minusInt64X4#") int64X4PrimTy
+primOpInfo (VecSubOp IntVec 64 W8) = mkDyadic (fsLit "minusInt8X64#") int8X64PrimTy
+primOpInfo (VecSubOp IntVec 32 W16) = mkDyadic (fsLit "minusInt16X32#") int16X32PrimTy
+primOpInfo (VecSubOp IntVec 16 W32) = mkDyadic (fsLit "minusInt32X16#") int32X16PrimTy
+primOpInfo (VecSubOp IntVec 8 W64) = mkDyadic (fsLit "minusInt64X8#") int64X8PrimTy
+primOpInfo (VecSubOp WordVec 16 W8) = mkDyadic (fsLit "minusWord8X16#") word8X16PrimTy
+primOpInfo (VecSubOp WordVec 8 W16) = mkDyadic (fsLit "minusWord16X8#") word16X8PrimTy
+primOpInfo (VecSubOp WordVec 4 W32) = mkDyadic (fsLit "minusWord32X4#") word32X4PrimTy
+primOpInfo (VecSubOp WordVec 2 W64) = mkDyadic (fsLit "minusWord64X2#") word64X2PrimTy
+primOpInfo (VecSubOp WordVec 32 W8) = mkDyadic (fsLit "minusWord8X32#") word8X32PrimTy
+primOpInfo (VecSubOp WordVec 16 W16) = mkDyadic (fsLit "minusWord16X16#") word16X16PrimTy
+primOpInfo (VecSubOp WordVec 8 W32) = mkDyadic (fsLit "minusWord32X8#") word32X8PrimTy
+primOpInfo (VecSubOp WordVec 4 W64) = mkDyadic (fsLit "minusWord64X4#") word64X4PrimTy
+primOpInfo (VecSubOp WordVec 64 W8) = mkDyadic (fsLit "minusWord8X64#") word8X64PrimTy
+primOpInfo (VecSubOp WordVec 32 W16) = mkDyadic (fsLit "minusWord16X32#") word16X32PrimTy
+primOpInfo (VecSubOp WordVec 16 W32) = mkDyadic (fsLit "minusWord32X16#") word32X16PrimTy
+primOpInfo (VecSubOp WordVec 8 W64) = mkDyadic (fsLit "minusWord64X8#") word64X8PrimTy
+primOpInfo (VecSubOp FloatVec 4 W32) = mkDyadic (fsLit "minusFloatX4#") floatX4PrimTy
+primOpInfo (VecSubOp FloatVec 2 W64) = mkDyadic (fsLit "minusDoubleX2#") doubleX2PrimTy
+primOpInfo (VecSubOp FloatVec 8 W32) = mkDyadic (fsLit "minusFloatX8#") floatX8PrimTy
+primOpInfo (VecSubOp FloatVec 4 W64) = mkDyadic (fsLit "minusDoubleX4#") doubleX4PrimTy
+primOpInfo (VecSubOp FloatVec 16 W32) = mkDyadic (fsLit "minusFloatX16#") floatX16PrimTy
+primOpInfo (VecSubOp FloatVec 8 W64) = mkDyadic (fsLit "minusDoubleX8#") doubleX8PrimTy
+primOpInfo (VecMulOp IntVec 16 W8) = mkDyadic (fsLit "timesInt8X16#") int8X16PrimTy
+primOpInfo (VecMulOp IntVec 8 W16) = mkDyadic (fsLit "timesInt16X8#") int16X8PrimTy
+primOpInfo (VecMulOp IntVec 4 W32) = mkDyadic (fsLit "timesInt32X4#") int32X4PrimTy
+primOpInfo (VecMulOp IntVec 2 W64) = mkDyadic (fsLit "timesInt64X2#") int64X2PrimTy
+primOpInfo (VecMulOp IntVec 32 W8) = mkDyadic (fsLit "timesInt8X32#") int8X32PrimTy
+primOpInfo (VecMulOp IntVec 16 W16) = mkDyadic (fsLit "timesInt16X16#") int16X16PrimTy
+primOpInfo (VecMulOp IntVec 8 W32) = mkDyadic (fsLit "timesInt32X8#") int32X8PrimTy
+primOpInfo (VecMulOp IntVec 4 W64) = mkDyadic (fsLit "timesInt64X4#") int64X4PrimTy
+primOpInfo (VecMulOp IntVec 64 W8) = mkDyadic (fsLit "timesInt8X64#") int8X64PrimTy
+primOpInfo (VecMulOp IntVec 32 W16) = mkDyadic (fsLit "timesInt16X32#") int16X32PrimTy
+primOpInfo (VecMulOp IntVec 16 W32) = mkDyadic (fsLit "timesInt32X16#") int32X16PrimTy
+primOpInfo (VecMulOp IntVec 8 W64) = mkDyadic (fsLit "timesInt64X8#") int64X8PrimTy
+primOpInfo (VecMulOp WordVec 16 W8) = mkDyadic (fsLit "timesWord8X16#") word8X16PrimTy
+primOpInfo (VecMulOp WordVec 8 W16) = mkDyadic (fsLit "timesWord16X8#") word16X8PrimTy
+primOpInfo (VecMulOp WordVec 4 W32) = mkDyadic (fsLit "timesWord32X4#") word32X4PrimTy
+primOpInfo (VecMulOp WordVec 2 W64) = mkDyadic (fsLit "timesWord64X2#") word64X2PrimTy
+primOpInfo (VecMulOp WordVec 32 W8) = mkDyadic (fsLit "timesWord8X32#") word8X32PrimTy
+primOpInfo (VecMulOp WordVec 16 W16) = mkDyadic (fsLit "timesWord16X16#") word16X16PrimTy
+primOpInfo (VecMulOp WordVec 8 W32) = mkDyadic (fsLit "timesWord32X8#") word32X8PrimTy
+primOpInfo (VecMulOp WordVec 4 W64) = mkDyadic (fsLit "timesWord64X4#") word64X4PrimTy
+primOpInfo (VecMulOp WordVec 64 W8) = mkDyadic (fsLit "timesWord8X64#") word8X64PrimTy
+primOpInfo (VecMulOp WordVec 32 W16) = mkDyadic (fsLit "timesWord16X32#") word16X32PrimTy
+primOpInfo (VecMulOp WordVec 16 W32) = mkDyadic (fsLit "timesWord32X16#") word32X16PrimTy
+primOpInfo (VecMulOp WordVec 8 W64) = mkDyadic (fsLit "timesWord64X8#") word64X8PrimTy
+primOpInfo (VecMulOp FloatVec 4 W32) = mkDyadic (fsLit "timesFloatX4#") floatX4PrimTy
+primOpInfo (VecMulOp FloatVec 2 W64) = mkDyadic (fsLit "timesDoubleX2#") doubleX2PrimTy
+primOpInfo (VecMulOp FloatVec 8 W32) = mkDyadic (fsLit "timesFloatX8#") floatX8PrimTy
+primOpInfo (VecMulOp FloatVec 4 W64) = mkDyadic (fsLit "timesDoubleX4#") doubleX4PrimTy
+primOpInfo (VecMulOp FloatVec 16 W32) = mkDyadic (fsLit "timesFloatX16#") floatX16PrimTy
+primOpInfo (VecMulOp FloatVec 8 W64) = mkDyadic (fsLit "timesDoubleX8#") doubleX8PrimTy
+primOpInfo (VecDivOp FloatVec 4 W32) = mkDyadic (fsLit "divideFloatX4#") floatX4PrimTy
+primOpInfo (VecDivOp FloatVec 2 W64) = mkDyadic (fsLit "divideDoubleX2#") doubleX2PrimTy
+primOpInfo (VecDivOp FloatVec 8 W32) = mkDyadic (fsLit "divideFloatX8#") floatX8PrimTy
+primOpInfo (VecDivOp FloatVec 4 W64) = mkDyadic (fsLit "divideDoubleX4#") doubleX4PrimTy
+primOpInfo (VecDivOp FloatVec 16 W32) = mkDyadic (fsLit "divideFloatX16#") floatX16PrimTy
+primOpInfo (VecDivOp FloatVec 8 W64) = mkDyadic (fsLit "divideDoubleX8#") doubleX8PrimTy
+primOpInfo (VecQuotOp IntVec 16 W8) = mkDyadic (fsLit "quotInt8X16#") int8X16PrimTy
+primOpInfo (VecQuotOp IntVec 8 W16) = mkDyadic (fsLit "quotInt16X8#") int16X8PrimTy
+primOpInfo (VecQuotOp IntVec 4 W32) = mkDyadic (fsLit "quotInt32X4#") int32X4PrimTy
+primOpInfo (VecQuotOp IntVec 2 W64) = mkDyadic (fsLit "quotInt64X2#") int64X2PrimTy
+primOpInfo (VecQuotOp IntVec 32 W8) = mkDyadic (fsLit "quotInt8X32#") int8X32PrimTy
+primOpInfo (VecQuotOp IntVec 16 W16) = mkDyadic (fsLit "quotInt16X16#") int16X16PrimTy
+primOpInfo (VecQuotOp IntVec 8 W32) = mkDyadic (fsLit "quotInt32X8#") int32X8PrimTy
+primOpInfo (VecQuotOp IntVec 4 W64) = mkDyadic (fsLit "quotInt64X4#") int64X4PrimTy
+primOpInfo (VecQuotOp IntVec 64 W8) = mkDyadic (fsLit "quotInt8X64#") int8X64PrimTy
+primOpInfo (VecQuotOp IntVec 32 W16) = mkDyadic (fsLit "quotInt16X32#") int16X32PrimTy
+primOpInfo (VecQuotOp IntVec 16 W32) = mkDyadic (fsLit "quotInt32X16#") int32X16PrimTy
+primOpInfo (VecQuotOp IntVec 8 W64) = mkDyadic (fsLit "quotInt64X8#") int64X8PrimTy
+primOpInfo (VecQuotOp WordVec 16 W8) = mkDyadic (fsLit "quotWord8X16#") word8X16PrimTy
+primOpInfo (VecQuotOp WordVec 8 W16) = mkDyadic (fsLit "quotWord16X8#") word16X8PrimTy
+primOpInfo (VecQuotOp WordVec 4 W32) = mkDyadic (fsLit "quotWord32X4#") word32X4PrimTy
+primOpInfo (VecQuotOp WordVec 2 W64) = mkDyadic (fsLit "quotWord64X2#") word64X2PrimTy
+primOpInfo (VecQuotOp WordVec 32 W8) = mkDyadic (fsLit "quotWord8X32#") word8X32PrimTy
+primOpInfo (VecQuotOp WordVec 16 W16) = mkDyadic (fsLit "quotWord16X16#") word16X16PrimTy
+primOpInfo (VecQuotOp WordVec 8 W32) = mkDyadic (fsLit "quotWord32X8#") word32X8PrimTy
+primOpInfo (VecQuotOp WordVec 4 W64) = mkDyadic (fsLit "quotWord64X4#") word64X4PrimTy
+primOpInfo (VecQuotOp WordVec 64 W8) = mkDyadic (fsLit "quotWord8X64#") word8X64PrimTy
+primOpInfo (VecQuotOp WordVec 32 W16) = mkDyadic (fsLit "quotWord16X32#") word16X32PrimTy
+primOpInfo (VecQuotOp WordVec 16 W32) = mkDyadic (fsLit "quotWord32X16#") word32X16PrimTy
+primOpInfo (VecQuotOp WordVec 8 W64) = mkDyadic (fsLit "quotWord64X8#") word64X8PrimTy
+primOpInfo (VecRemOp IntVec 16 W8) = mkDyadic (fsLit "remInt8X16#") int8X16PrimTy
+primOpInfo (VecRemOp IntVec 8 W16) = mkDyadic (fsLit "remInt16X8#") int16X8PrimTy
+primOpInfo (VecRemOp IntVec 4 W32) = mkDyadic (fsLit "remInt32X4#") int32X4PrimTy
+primOpInfo (VecRemOp IntVec 2 W64) = mkDyadic (fsLit "remInt64X2#") int64X2PrimTy
+primOpInfo (VecRemOp IntVec 32 W8) = mkDyadic (fsLit "remInt8X32#") int8X32PrimTy
+primOpInfo (VecRemOp IntVec 16 W16) = mkDyadic (fsLit "remInt16X16#") int16X16PrimTy
+primOpInfo (VecRemOp IntVec 8 W32) = mkDyadic (fsLit "remInt32X8#") int32X8PrimTy
+primOpInfo (VecRemOp IntVec 4 W64) = mkDyadic (fsLit "remInt64X4#") int64X4PrimTy
+primOpInfo (VecRemOp IntVec 64 W8) = mkDyadic (fsLit "remInt8X64#") int8X64PrimTy
+primOpInfo (VecRemOp IntVec 32 W16) = mkDyadic (fsLit "remInt16X32#") int16X32PrimTy
+primOpInfo (VecRemOp IntVec 16 W32) = mkDyadic (fsLit "remInt32X16#") int32X16PrimTy
+primOpInfo (VecRemOp IntVec 8 W64) = mkDyadic (fsLit "remInt64X8#") int64X8PrimTy
+primOpInfo (VecRemOp WordVec 16 W8) = mkDyadic (fsLit "remWord8X16#") word8X16PrimTy
+primOpInfo (VecRemOp WordVec 8 W16) = mkDyadic (fsLit "remWord16X8#") word16X8PrimTy
+primOpInfo (VecRemOp WordVec 4 W32) = mkDyadic (fsLit "remWord32X4#") word32X4PrimTy
+primOpInfo (VecRemOp WordVec 2 W64) = mkDyadic (fsLit "remWord64X2#") word64X2PrimTy
+primOpInfo (VecRemOp WordVec 32 W8) = mkDyadic (fsLit "remWord8X32#") word8X32PrimTy
+primOpInfo (VecRemOp WordVec 16 W16) = mkDyadic (fsLit "remWord16X16#") word16X16PrimTy
+primOpInfo (VecRemOp WordVec 8 W32) = mkDyadic (fsLit "remWord32X8#") word32X8PrimTy
+primOpInfo (VecRemOp WordVec 4 W64) = mkDyadic (fsLit "remWord64X4#") word64X4PrimTy
+primOpInfo (VecRemOp WordVec 64 W8) = mkDyadic (fsLit "remWord8X64#") word8X64PrimTy
+primOpInfo (VecRemOp WordVec 32 W16) = mkDyadic (fsLit "remWord16X32#") word16X32PrimTy
+primOpInfo (VecRemOp WordVec 16 W32) = mkDyadic (fsLit "remWord32X16#") word32X16PrimTy
+primOpInfo (VecRemOp WordVec 8 W64) = mkDyadic (fsLit "remWord64X8#") word64X8PrimTy
+primOpInfo (VecNegOp IntVec 16 W8) = mkMonadic (fsLit "negateInt8X16#") int8X16PrimTy
+primOpInfo (VecNegOp IntVec 8 W16) = mkMonadic (fsLit "negateInt16X8#") int16X8PrimTy
+primOpInfo (VecNegOp IntVec 4 W32) = mkMonadic (fsLit "negateInt32X4#") int32X4PrimTy
+primOpInfo (VecNegOp IntVec 2 W64) = mkMonadic (fsLit "negateInt64X2#") int64X2PrimTy
+primOpInfo (VecNegOp IntVec 32 W8) = mkMonadic (fsLit "negateInt8X32#") int8X32PrimTy
+primOpInfo (VecNegOp IntVec 16 W16) = mkMonadic (fsLit "negateInt16X16#") int16X16PrimTy
+primOpInfo (VecNegOp IntVec 8 W32) = mkMonadic (fsLit "negateInt32X8#") int32X8PrimTy
+primOpInfo (VecNegOp IntVec 4 W64) = mkMonadic (fsLit "negateInt64X4#") int64X4PrimTy
+primOpInfo (VecNegOp IntVec 64 W8) = mkMonadic (fsLit "negateInt8X64#") int8X64PrimTy
+primOpInfo (VecNegOp IntVec 32 W16) = mkMonadic (fsLit "negateInt16X32#") int16X32PrimTy
+primOpInfo (VecNegOp IntVec 16 W32) = mkMonadic (fsLit "negateInt32X16#") int32X16PrimTy
+primOpInfo (VecNegOp IntVec 8 W64) = mkMonadic (fsLit "negateInt64X8#") int64X8PrimTy
+primOpInfo (VecNegOp FloatVec 4 W32) = mkMonadic (fsLit "negateFloatX4#") floatX4PrimTy
+primOpInfo (VecNegOp FloatVec 2 W64) = mkMonadic (fsLit "negateDoubleX2#") doubleX2PrimTy
+primOpInfo (VecNegOp FloatVec 8 W32) = mkMonadic (fsLit "negateFloatX8#") floatX8PrimTy
+primOpInfo (VecNegOp FloatVec 4 W64) = mkMonadic (fsLit "negateDoubleX4#") doubleX4PrimTy
+primOpInfo (VecNegOp FloatVec 16 W32) = mkMonadic (fsLit "negateFloatX16#") floatX16PrimTy
+primOpInfo (VecNegOp FloatVec 8 W64) = mkMonadic (fsLit "negateDoubleX8#") doubleX8PrimTy
+primOpInfo (VecIndexByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)
+primOpInfo (VecIndexByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)
+primOpInfo (VecIndexByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)
+primOpInfo (VecIndexByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)
+primOpInfo (VecIndexByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)
+primOpInfo (VecIndexByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)
+primOpInfo (VecIndexByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)
+primOpInfo (VecIndexByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)
+primOpInfo (VecIndexByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)
+primOpInfo (VecReadByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))
+primOpInfo (VecReadByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))
+primOpInfo (VecReadByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))
+primOpInfo (VecReadByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))
+primOpInfo (VecReadByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))
+primOpInfo (VecReadByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))
+primOpInfo (VecReadByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))
+primOpInfo (VecReadByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))
+primOpInfo (VecReadByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))
+primOpInfo (VecWriteByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecIndexOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)
+primOpInfo (VecIndexOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)
+primOpInfo (VecIndexOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)
+primOpInfo (VecIndexOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)
+primOpInfo (VecIndexOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)
+primOpInfo (VecIndexOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)
+primOpInfo (VecIndexOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)
+primOpInfo (VecIndexOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)
+primOpInfo (VecIndexOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)
+primOpInfo (VecReadOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))
+primOpInfo (VecReadOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))
+primOpInfo (VecReadOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))
+primOpInfo (VecReadOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))
+primOpInfo (VecReadOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))
+primOpInfo (VecReadOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))
+primOpInfo (VecReadOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))
+primOpInfo (VecReadOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))
+primOpInfo (VecReadOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))
+primOpInfo (VecWriteOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X16#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X8#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X4#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X2#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X32#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X16#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X8#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X4#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X64#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X32#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X16#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X8#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X16#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X8#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X4#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X2#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X32#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X16#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X8#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X4#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X64#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X32#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X16#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X8#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX4#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX2#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX8#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX4#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX16#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)
+primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX8#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)
+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))
+primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))
+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X16#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X8#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X4#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X2#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X32#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X16#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X8#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X4#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X64#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X32#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X16#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X8#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X16#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X8#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X4#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X2#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X32#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X16#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X8#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X4#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X64#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X32#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X16#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X8#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX4#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX2#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX8#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX4#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX16#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)
+primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX8#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)
+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))
+primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))
+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX2#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX16#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchByteArrayOp3 = mkGenPrimOp (fsLit "prefetchByteArray3#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchMutableByteArrayOp3 = mkGenPrimOp (fsLit "prefetchMutableByteArray3#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchAddrOp3 = mkGenPrimOp (fsLit "prefetchAddr3#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchValueOp3 = mkGenPrimOp (fsLit "prefetchValue3#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchByteArrayOp2 = mkGenPrimOp (fsLit "prefetchByteArray2#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchMutableByteArrayOp2 = mkGenPrimOp (fsLit "prefetchMutableByteArray2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchAddrOp2 = mkGenPrimOp (fsLit "prefetchAddr2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchValueOp2 = mkGenPrimOp (fsLit "prefetchValue2#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchByteArrayOp1 = mkGenPrimOp (fsLit "prefetchByteArray1#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchMutableByteArrayOp1 = mkGenPrimOp (fsLit "prefetchMutableByteArray1#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchAddrOp1 = mkGenPrimOp (fsLit "prefetchAddr1#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchValueOp1 = mkGenPrimOp (fsLit "prefetchValue1#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchByteArrayOp0 = mkGenPrimOp (fsLit "prefetchByteArray0#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchMutableByteArrayOp0 = mkGenPrimOp (fsLit "prefetchMutableByteArray0#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchAddrOp0 = mkGenPrimOp (fsLit "prefetchAddr0#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+primOpInfo PrefetchValueOp0 = mkGenPrimOp (fsLit "prefetchValue0#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
diff --git a/ghc-lib/stage1/compiler/build/primop-strictness.hs-incl b/ghc-lib/stage1/compiler/build/primop-strictness.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-strictness.hs-incl
@@ -0,0 +1,22 @@
+primOpStrictness CatchOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd
+                                                 , lazyApply2Dmd
+                                                 , topDmd] topRes 
+primOpStrictness RaiseOp =  \ _arity -> mkClosedStrictSig [topDmd] exnRes 
+primOpStrictness RaiseIOOp =  \ _arity -> mkClosedStrictSig [topDmd, topDmd] exnRes 
+primOpStrictness MaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes 
+primOpStrictness MaskUninterruptibleOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes 
+primOpStrictness UnmaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes 
+primOpStrictness AtomicallyOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes 
+primOpStrictness RetryOp =  \ _arity -> mkClosedStrictSig [topDmd] exnRes 
+primOpStrictness CatchRetryOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd
+                                                 , lazyApply1Dmd
+                                                 , topDmd ] topRes 
+primOpStrictness CatchSTMOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd
+                                                 , lazyApply2Dmd
+                                                 , topDmd ] topRes 
+primOpStrictness DataToTagOp =  \ _arity -> mkClosedStrictSig [evalDmd] topRes 
+primOpStrictness PrefetchValueOp3 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes 
+primOpStrictness PrefetchValueOp2 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes 
+primOpStrictness PrefetchValueOp1 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes 
+primOpStrictness PrefetchValueOp0 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes 
+primOpStrictness _ =  \ arity -> mkClosedStrictSig (replicate arity topDmd) topRes 
diff --git a/ghc-lib/stage1/compiler/build/primop-tag.hs-incl b/ghc-lib/stage1/compiler/build/primop-tag.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-tag.hs-incl
@@ -0,0 +1,1195 @@
+maxPrimOpTag :: Int
+maxPrimOpTag = 1192
+primOpTag :: PrimOp -> Int
+primOpTag CharGtOp = 1
+primOpTag CharGeOp = 2
+primOpTag CharEqOp = 3
+primOpTag CharNeOp = 4
+primOpTag CharLtOp = 5
+primOpTag CharLeOp = 6
+primOpTag OrdOp = 7
+primOpTag IntAddOp = 8
+primOpTag IntSubOp = 9
+primOpTag IntMulOp = 10
+primOpTag IntMulMayOfloOp = 11
+primOpTag IntQuotOp = 12
+primOpTag IntRemOp = 13
+primOpTag IntQuotRemOp = 14
+primOpTag AndIOp = 15
+primOpTag OrIOp = 16
+primOpTag XorIOp = 17
+primOpTag NotIOp = 18
+primOpTag IntNegOp = 19
+primOpTag IntAddCOp = 20
+primOpTag IntSubCOp = 21
+primOpTag IntGtOp = 22
+primOpTag IntGeOp = 23
+primOpTag IntEqOp = 24
+primOpTag IntNeOp = 25
+primOpTag IntLtOp = 26
+primOpTag IntLeOp = 27
+primOpTag ChrOp = 28
+primOpTag Int2WordOp = 29
+primOpTag Int2FloatOp = 30
+primOpTag Int2DoubleOp = 31
+primOpTag Word2FloatOp = 32
+primOpTag Word2DoubleOp = 33
+primOpTag ISllOp = 34
+primOpTag ISraOp = 35
+primOpTag ISrlOp = 36
+primOpTag Int8Extend = 37
+primOpTag Int8Narrow = 38
+primOpTag Int8NegOp = 39
+primOpTag Int8AddOp = 40
+primOpTag Int8SubOp = 41
+primOpTag Int8MulOp = 42
+primOpTag Int8QuotOp = 43
+primOpTag Int8RemOp = 44
+primOpTag Int8QuotRemOp = 45
+primOpTag Int8EqOp = 46
+primOpTag Int8GeOp = 47
+primOpTag Int8GtOp = 48
+primOpTag Int8LeOp = 49
+primOpTag Int8LtOp = 50
+primOpTag Int8NeOp = 51
+primOpTag Word8Extend = 52
+primOpTag Word8Narrow = 53
+primOpTag Word8NotOp = 54
+primOpTag Word8AddOp = 55
+primOpTag Word8SubOp = 56
+primOpTag Word8MulOp = 57
+primOpTag Word8QuotOp = 58
+primOpTag Word8RemOp = 59
+primOpTag Word8QuotRemOp = 60
+primOpTag Word8EqOp = 61
+primOpTag Word8GeOp = 62
+primOpTag Word8GtOp = 63
+primOpTag Word8LeOp = 64
+primOpTag Word8LtOp = 65
+primOpTag Word8NeOp = 66
+primOpTag Int16Extend = 67
+primOpTag Int16Narrow = 68
+primOpTag Int16NegOp = 69
+primOpTag Int16AddOp = 70
+primOpTag Int16SubOp = 71
+primOpTag Int16MulOp = 72
+primOpTag Int16QuotOp = 73
+primOpTag Int16RemOp = 74
+primOpTag Int16QuotRemOp = 75
+primOpTag Int16EqOp = 76
+primOpTag Int16GeOp = 77
+primOpTag Int16GtOp = 78
+primOpTag Int16LeOp = 79
+primOpTag Int16LtOp = 80
+primOpTag Int16NeOp = 81
+primOpTag Word16Extend = 82
+primOpTag Word16Narrow = 83
+primOpTag Word16NotOp = 84
+primOpTag Word16AddOp = 85
+primOpTag Word16SubOp = 86
+primOpTag Word16MulOp = 87
+primOpTag Word16QuotOp = 88
+primOpTag Word16RemOp = 89
+primOpTag Word16QuotRemOp = 90
+primOpTag Word16EqOp = 91
+primOpTag Word16GeOp = 92
+primOpTag Word16GtOp = 93
+primOpTag Word16LeOp = 94
+primOpTag Word16LtOp = 95
+primOpTag Word16NeOp = 96
+primOpTag WordAddOp = 97
+primOpTag WordAddCOp = 98
+primOpTag WordSubCOp = 99
+primOpTag WordAdd2Op = 100
+primOpTag WordSubOp = 101
+primOpTag WordMulOp = 102
+primOpTag WordMul2Op = 103
+primOpTag WordQuotOp = 104
+primOpTag WordRemOp = 105
+primOpTag WordQuotRemOp = 106
+primOpTag WordQuotRem2Op = 107
+primOpTag AndOp = 108
+primOpTag OrOp = 109
+primOpTag XorOp = 110
+primOpTag NotOp = 111
+primOpTag SllOp = 112
+primOpTag SrlOp = 113
+primOpTag Word2IntOp = 114
+primOpTag WordGtOp = 115
+primOpTag WordGeOp = 116
+primOpTag WordEqOp = 117
+primOpTag WordNeOp = 118
+primOpTag WordLtOp = 119
+primOpTag WordLeOp = 120
+primOpTag PopCnt8Op = 121
+primOpTag PopCnt16Op = 122
+primOpTag PopCnt32Op = 123
+primOpTag PopCnt64Op = 124
+primOpTag PopCntOp = 125
+primOpTag Pdep8Op = 126
+primOpTag Pdep16Op = 127
+primOpTag Pdep32Op = 128
+primOpTag Pdep64Op = 129
+primOpTag PdepOp = 130
+primOpTag Pext8Op = 131
+primOpTag Pext16Op = 132
+primOpTag Pext32Op = 133
+primOpTag Pext64Op = 134
+primOpTag PextOp = 135
+primOpTag Clz8Op = 136
+primOpTag Clz16Op = 137
+primOpTag Clz32Op = 138
+primOpTag Clz64Op = 139
+primOpTag ClzOp = 140
+primOpTag Ctz8Op = 141
+primOpTag Ctz16Op = 142
+primOpTag Ctz32Op = 143
+primOpTag Ctz64Op = 144
+primOpTag CtzOp = 145
+primOpTag BSwap16Op = 146
+primOpTag BSwap32Op = 147
+primOpTag BSwap64Op = 148
+primOpTag BSwapOp = 149
+primOpTag Narrow8IntOp = 150
+primOpTag Narrow16IntOp = 151
+primOpTag Narrow32IntOp = 152
+primOpTag Narrow8WordOp = 153
+primOpTag Narrow16WordOp = 154
+primOpTag Narrow32WordOp = 155
+primOpTag DoubleGtOp = 156
+primOpTag DoubleGeOp = 157
+primOpTag DoubleEqOp = 158
+primOpTag DoubleNeOp = 159
+primOpTag DoubleLtOp = 160
+primOpTag DoubleLeOp = 161
+primOpTag DoubleAddOp = 162
+primOpTag DoubleSubOp = 163
+primOpTag DoubleMulOp = 164
+primOpTag DoubleDivOp = 165
+primOpTag DoubleNegOp = 166
+primOpTag DoubleFabsOp = 167
+primOpTag Double2IntOp = 168
+primOpTag Double2FloatOp = 169
+primOpTag DoubleExpOp = 170
+primOpTag DoubleLogOp = 171
+primOpTag DoubleSqrtOp = 172
+primOpTag DoubleSinOp = 173
+primOpTag DoubleCosOp = 174
+primOpTag DoubleTanOp = 175
+primOpTag DoubleAsinOp = 176
+primOpTag DoubleAcosOp = 177
+primOpTag DoubleAtanOp = 178
+primOpTag DoubleSinhOp = 179
+primOpTag DoubleCoshOp = 180
+primOpTag DoubleTanhOp = 181
+primOpTag DoubleAsinhOp = 182
+primOpTag DoubleAcoshOp = 183
+primOpTag DoubleAtanhOp = 184
+primOpTag DoublePowerOp = 185
+primOpTag DoubleDecode_2IntOp = 186
+primOpTag DoubleDecode_Int64Op = 187
+primOpTag FloatGtOp = 188
+primOpTag FloatGeOp = 189
+primOpTag FloatEqOp = 190
+primOpTag FloatNeOp = 191
+primOpTag FloatLtOp = 192
+primOpTag FloatLeOp = 193
+primOpTag FloatAddOp = 194
+primOpTag FloatSubOp = 195
+primOpTag FloatMulOp = 196
+primOpTag FloatDivOp = 197
+primOpTag FloatNegOp = 198
+primOpTag FloatFabsOp = 199
+primOpTag Float2IntOp = 200
+primOpTag FloatExpOp = 201
+primOpTag FloatLogOp = 202
+primOpTag FloatSqrtOp = 203
+primOpTag FloatSinOp = 204
+primOpTag FloatCosOp = 205
+primOpTag FloatTanOp = 206
+primOpTag FloatAsinOp = 207
+primOpTag FloatAcosOp = 208
+primOpTag FloatAtanOp = 209
+primOpTag FloatSinhOp = 210
+primOpTag FloatCoshOp = 211
+primOpTag FloatTanhOp = 212
+primOpTag FloatAsinhOp = 213
+primOpTag FloatAcoshOp = 214
+primOpTag FloatAtanhOp = 215
+primOpTag FloatPowerOp = 216
+primOpTag Float2DoubleOp = 217
+primOpTag FloatDecode_IntOp = 218
+primOpTag NewArrayOp = 219
+primOpTag SameMutableArrayOp = 220
+primOpTag ReadArrayOp = 221
+primOpTag WriteArrayOp = 222
+primOpTag SizeofArrayOp = 223
+primOpTag SizeofMutableArrayOp = 224
+primOpTag IndexArrayOp = 225
+primOpTag UnsafeFreezeArrayOp = 226
+primOpTag UnsafeThawArrayOp = 227
+primOpTag CopyArrayOp = 228
+primOpTag CopyMutableArrayOp = 229
+primOpTag CloneArrayOp = 230
+primOpTag CloneMutableArrayOp = 231
+primOpTag FreezeArrayOp = 232
+primOpTag ThawArrayOp = 233
+primOpTag CasArrayOp = 234
+primOpTag NewSmallArrayOp = 235
+primOpTag SameSmallMutableArrayOp = 236
+primOpTag ReadSmallArrayOp = 237
+primOpTag WriteSmallArrayOp = 238
+primOpTag SizeofSmallArrayOp = 239
+primOpTag SizeofSmallMutableArrayOp = 240
+primOpTag IndexSmallArrayOp = 241
+primOpTag UnsafeFreezeSmallArrayOp = 242
+primOpTag UnsafeThawSmallArrayOp = 243
+primOpTag CopySmallArrayOp = 244
+primOpTag CopySmallMutableArrayOp = 245
+primOpTag CloneSmallArrayOp = 246
+primOpTag CloneSmallMutableArrayOp = 247
+primOpTag FreezeSmallArrayOp = 248
+primOpTag ThawSmallArrayOp = 249
+primOpTag CasSmallArrayOp = 250
+primOpTag NewByteArrayOp_Char = 251
+primOpTag NewPinnedByteArrayOp_Char = 252
+primOpTag NewAlignedPinnedByteArrayOp_Char = 253
+primOpTag MutableByteArrayIsPinnedOp = 254
+primOpTag ByteArrayIsPinnedOp = 255
+primOpTag ByteArrayContents_Char = 256
+primOpTag SameMutableByteArrayOp = 257
+primOpTag ShrinkMutableByteArrayOp_Char = 258
+primOpTag ResizeMutableByteArrayOp_Char = 259
+primOpTag UnsafeFreezeByteArrayOp = 260
+primOpTag SizeofByteArrayOp = 261
+primOpTag SizeofMutableByteArrayOp = 262
+primOpTag GetSizeofMutableByteArrayOp = 263
+primOpTag IndexByteArrayOp_Char = 264
+primOpTag IndexByteArrayOp_WideChar = 265
+primOpTag IndexByteArrayOp_Int = 266
+primOpTag IndexByteArrayOp_Word = 267
+primOpTag IndexByteArrayOp_Addr = 268
+primOpTag IndexByteArrayOp_Float = 269
+primOpTag IndexByteArrayOp_Double = 270
+primOpTag IndexByteArrayOp_StablePtr = 271
+primOpTag IndexByteArrayOp_Int8 = 272
+primOpTag IndexByteArrayOp_Int16 = 273
+primOpTag IndexByteArrayOp_Int32 = 274
+primOpTag IndexByteArrayOp_Int64 = 275
+primOpTag IndexByteArrayOp_Word8 = 276
+primOpTag IndexByteArrayOp_Word16 = 277
+primOpTag IndexByteArrayOp_Word32 = 278
+primOpTag IndexByteArrayOp_Word64 = 279
+primOpTag IndexByteArrayOp_Word8AsChar = 280
+primOpTag IndexByteArrayOp_Word8AsWideChar = 281
+primOpTag IndexByteArrayOp_Word8AsAddr = 282
+primOpTag IndexByteArrayOp_Word8AsFloat = 283
+primOpTag IndexByteArrayOp_Word8AsDouble = 284
+primOpTag IndexByteArrayOp_Word8AsStablePtr = 285
+primOpTag IndexByteArrayOp_Word8AsInt16 = 286
+primOpTag IndexByteArrayOp_Word8AsInt32 = 287
+primOpTag IndexByteArrayOp_Word8AsInt64 = 288
+primOpTag IndexByteArrayOp_Word8AsInt = 289
+primOpTag IndexByteArrayOp_Word8AsWord16 = 290
+primOpTag IndexByteArrayOp_Word8AsWord32 = 291
+primOpTag IndexByteArrayOp_Word8AsWord64 = 292
+primOpTag IndexByteArrayOp_Word8AsWord = 293
+primOpTag ReadByteArrayOp_Char = 294
+primOpTag ReadByteArrayOp_WideChar = 295
+primOpTag ReadByteArrayOp_Int = 296
+primOpTag ReadByteArrayOp_Word = 297
+primOpTag ReadByteArrayOp_Addr = 298
+primOpTag ReadByteArrayOp_Float = 299
+primOpTag ReadByteArrayOp_Double = 300
+primOpTag ReadByteArrayOp_StablePtr = 301
+primOpTag ReadByteArrayOp_Int8 = 302
+primOpTag ReadByteArrayOp_Int16 = 303
+primOpTag ReadByteArrayOp_Int32 = 304
+primOpTag ReadByteArrayOp_Int64 = 305
+primOpTag ReadByteArrayOp_Word8 = 306
+primOpTag ReadByteArrayOp_Word16 = 307
+primOpTag ReadByteArrayOp_Word32 = 308
+primOpTag ReadByteArrayOp_Word64 = 309
+primOpTag ReadByteArrayOp_Word8AsChar = 310
+primOpTag ReadByteArrayOp_Word8AsWideChar = 311
+primOpTag ReadByteArrayOp_Word8AsAddr = 312
+primOpTag ReadByteArrayOp_Word8AsFloat = 313
+primOpTag ReadByteArrayOp_Word8AsDouble = 314
+primOpTag ReadByteArrayOp_Word8AsStablePtr = 315
+primOpTag ReadByteArrayOp_Word8AsInt16 = 316
+primOpTag ReadByteArrayOp_Word8AsInt32 = 317
+primOpTag ReadByteArrayOp_Word8AsInt64 = 318
+primOpTag ReadByteArrayOp_Word8AsInt = 319
+primOpTag ReadByteArrayOp_Word8AsWord16 = 320
+primOpTag ReadByteArrayOp_Word8AsWord32 = 321
+primOpTag ReadByteArrayOp_Word8AsWord64 = 322
+primOpTag ReadByteArrayOp_Word8AsWord = 323
+primOpTag WriteByteArrayOp_Char = 324
+primOpTag WriteByteArrayOp_WideChar = 325
+primOpTag WriteByteArrayOp_Int = 326
+primOpTag WriteByteArrayOp_Word = 327
+primOpTag WriteByteArrayOp_Addr = 328
+primOpTag WriteByteArrayOp_Float = 329
+primOpTag WriteByteArrayOp_Double = 330
+primOpTag WriteByteArrayOp_StablePtr = 331
+primOpTag WriteByteArrayOp_Int8 = 332
+primOpTag WriteByteArrayOp_Int16 = 333
+primOpTag WriteByteArrayOp_Int32 = 334
+primOpTag WriteByteArrayOp_Int64 = 335
+primOpTag WriteByteArrayOp_Word8 = 336
+primOpTag WriteByteArrayOp_Word16 = 337
+primOpTag WriteByteArrayOp_Word32 = 338
+primOpTag WriteByteArrayOp_Word64 = 339
+primOpTag WriteByteArrayOp_Word8AsChar = 340
+primOpTag WriteByteArrayOp_Word8AsWideChar = 341
+primOpTag WriteByteArrayOp_Word8AsAddr = 342
+primOpTag WriteByteArrayOp_Word8AsFloat = 343
+primOpTag WriteByteArrayOp_Word8AsDouble = 344
+primOpTag WriteByteArrayOp_Word8AsStablePtr = 345
+primOpTag WriteByteArrayOp_Word8AsInt16 = 346
+primOpTag WriteByteArrayOp_Word8AsInt32 = 347
+primOpTag WriteByteArrayOp_Word8AsInt64 = 348
+primOpTag WriteByteArrayOp_Word8AsInt = 349
+primOpTag WriteByteArrayOp_Word8AsWord16 = 350
+primOpTag WriteByteArrayOp_Word8AsWord32 = 351
+primOpTag WriteByteArrayOp_Word8AsWord64 = 352
+primOpTag WriteByteArrayOp_Word8AsWord = 353
+primOpTag CompareByteArraysOp = 354
+primOpTag CopyByteArrayOp = 355
+primOpTag CopyMutableByteArrayOp = 356
+primOpTag CopyByteArrayToAddrOp = 357
+primOpTag CopyMutableByteArrayToAddrOp = 358
+primOpTag CopyAddrToByteArrayOp = 359
+primOpTag SetByteArrayOp = 360
+primOpTag AtomicReadByteArrayOp_Int = 361
+primOpTag AtomicWriteByteArrayOp_Int = 362
+primOpTag CasByteArrayOp_Int = 363
+primOpTag FetchAddByteArrayOp_Int = 364
+primOpTag FetchSubByteArrayOp_Int = 365
+primOpTag FetchAndByteArrayOp_Int = 366
+primOpTag FetchNandByteArrayOp_Int = 367
+primOpTag FetchOrByteArrayOp_Int = 368
+primOpTag FetchXorByteArrayOp_Int = 369
+primOpTag NewArrayArrayOp = 370
+primOpTag SameMutableArrayArrayOp = 371
+primOpTag UnsafeFreezeArrayArrayOp = 372
+primOpTag SizeofArrayArrayOp = 373
+primOpTag SizeofMutableArrayArrayOp = 374
+primOpTag IndexArrayArrayOp_ByteArray = 375
+primOpTag IndexArrayArrayOp_ArrayArray = 376
+primOpTag ReadArrayArrayOp_ByteArray = 377
+primOpTag ReadArrayArrayOp_MutableByteArray = 378
+primOpTag ReadArrayArrayOp_ArrayArray = 379
+primOpTag ReadArrayArrayOp_MutableArrayArray = 380
+primOpTag WriteArrayArrayOp_ByteArray = 381
+primOpTag WriteArrayArrayOp_MutableByteArray = 382
+primOpTag WriteArrayArrayOp_ArrayArray = 383
+primOpTag WriteArrayArrayOp_MutableArrayArray = 384
+primOpTag CopyArrayArrayOp = 385
+primOpTag CopyMutableArrayArrayOp = 386
+primOpTag AddrAddOp = 387
+primOpTag AddrSubOp = 388
+primOpTag AddrRemOp = 389
+primOpTag Addr2IntOp = 390
+primOpTag Int2AddrOp = 391
+primOpTag AddrGtOp = 392
+primOpTag AddrGeOp = 393
+primOpTag AddrEqOp = 394
+primOpTag AddrNeOp = 395
+primOpTag AddrLtOp = 396
+primOpTag AddrLeOp = 397
+primOpTag IndexOffAddrOp_Char = 398
+primOpTag IndexOffAddrOp_WideChar = 399
+primOpTag IndexOffAddrOp_Int = 400
+primOpTag IndexOffAddrOp_Word = 401
+primOpTag IndexOffAddrOp_Addr = 402
+primOpTag IndexOffAddrOp_Float = 403
+primOpTag IndexOffAddrOp_Double = 404
+primOpTag IndexOffAddrOp_StablePtr = 405
+primOpTag IndexOffAddrOp_Int8 = 406
+primOpTag IndexOffAddrOp_Int16 = 407
+primOpTag IndexOffAddrOp_Int32 = 408
+primOpTag IndexOffAddrOp_Int64 = 409
+primOpTag IndexOffAddrOp_Word8 = 410
+primOpTag IndexOffAddrOp_Word16 = 411
+primOpTag IndexOffAddrOp_Word32 = 412
+primOpTag IndexOffAddrOp_Word64 = 413
+primOpTag ReadOffAddrOp_Char = 414
+primOpTag ReadOffAddrOp_WideChar = 415
+primOpTag ReadOffAddrOp_Int = 416
+primOpTag ReadOffAddrOp_Word = 417
+primOpTag ReadOffAddrOp_Addr = 418
+primOpTag ReadOffAddrOp_Float = 419
+primOpTag ReadOffAddrOp_Double = 420
+primOpTag ReadOffAddrOp_StablePtr = 421
+primOpTag ReadOffAddrOp_Int8 = 422
+primOpTag ReadOffAddrOp_Int16 = 423
+primOpTag ReadOffAddrOp_Int32 = 424
+primOpTag ReadOffAddrOp_Int64 = 425
+primOpTag ReadOffAddrOp_Word8 = 426
+primOpTag ReadOffAddrOp_Word16 = 427
+primOpTag ReadOffAddrOp_Word32 = 428
+primOpTag ReadOffAddrOp_Word64 = 429
+primOpTag WriteOffAddrOp_Char = 430
+primOpTag WriteOffAddrOp_WideChar = 431
+primOpTag WriteOffAddrOp_Int = 432
+primOpTag WriteOffAddrOp_Word = 433
+primOpTag WriteOffAddrOp_Addr = 434
+primOpTag WriteOffAddrOp_Float = 435
+primOpTag WriteOffAddrOp_Double = 436
+primOpTag WriteOffAddrOp_StablePtr = 437
+primOpTag WriteOffAddrOp_Int8 = 438
+primOpTag WriteOffAddrOp_Int16 = 439
+primOpTag WriteOffAddrOp_Int32 = 440
+primOpTag WriteOffAddrOp_Int64 = 441
+primOpTag WriteOffAddrOp_Word8 = 442
+primOpTag WriteOffAddrOp_Word16 = 443
+primOpTag WriteOffAddrOp_Word32 = 444
+primOpTag WriteOffAddrOp_Word64 = 445
+primOpTag NewMutVarOp = 446
+primOpTag ReadMutVarOp = 447
+primOpTag WriteMutVarOp = 448
+primOpTag SameMutVarOp = 449
+primOpTag AtomicModifyMutVar2Op = 450
+primOpTag AtomicModifyMutVar_Op = 451
+primOpTag CasMutVarOp = 452
+primOpTag CatchOp = 453
+primOpTag RaiseOp = 454
+primOpTag RaiseIOOp = 455
+primOpTag MaskAsyncExceptionsOp = 456
+primOpTag MaskUninterruptibleOp = 457
+primOpTag UnmaskAsyncExceptionsOp = 458
+primOpTag MaskStatus = 459
+primOpTag AtomicallyOp = 460
+primOpTag RetryOp = 461
+primOpTag CatchRetryOp = 462
+primOpTag CatchSTMOp = 463
+primOpTag NewTVarOp = 464
+primOpTag ReadTVarOp = 465
+primOpTag ReadTVarIOOp = 466
+primOpTag WriteTVarOp = 467
+primOpTag SameTVarOp = 468
+primOpTag NewMVarOp = 469
+primOpTag TakeMVarOp = 470
+primOpTag TryTakeMVarOp = 471
+primOpTag PutMVarOp = 472
+primOpTag TryPutMVarOp = 473
+primOpTag ReadMVarOp = 474
+primOpTag TryReadMVarOp = 475
+primOpTag SameMVarOp = 476
+primOpTag IsEmptyMVarOp = 477
+primOpTag DelayOp = 478
+primOpTag WaitReadOp = 479
+primOpTag WaitWriteOp = 480
+primOpTag ForkOp = 481
+primOpTag ForkOnOp = 482
+primOpTag KillThreadOp = 483
+primOpTag YieldOp = 484
+primOpTag MyThreadIdOp = 485
+primOpTag LabelThreadOp = 486
+primOpTag IsCurrentThreadBoundOp = 487
+primOpTag NoDuplicateOp = 488
+primOpTag ThreadStatusOp = 489
+primOpTag MkWeakOp = 490
+primOpTag MkWeakNoFinalizerOp = 491
+primOpTag AddCFinalizerToWeakOp = 492
+primOpTag DeRefWeakOp = 493
+primOpTag FinalizeWeakOp = 494
+primOpTag TouchOp = 495
+primOpTag MakeStablePtrOp = 496
+primOpTag DeRefStablePtrOp = 497
+primOpTag EqStablePtrOp = 498
+primOpTag MakeStableNameOp = 499
+primOpTag EqStableNameOp = 500
+primOpTag StableNameToIntOp = 501
+primOpTag CompactNewOp = 502
+primOpTag CompactResizeOp = 503
+primOpTag CompactContainsOp = 504
+primOpTag CompactContainsAnyOp = 505
+primOpTag CompactGetFirstBlockOp = 506
+primOpTag CompactGetNextBlockOp = 507
+primOpTag CompactAllocateBlockOp = 508
+primOpTag CompactFixupPointersOp = 509
+primOpTag CompactAdd = 510
+primOpTag CompactAddWithSharing = 511
+primOpTag CompactSize = 512
+primOpTag ReallyUnsafePtrEqualityOp = 513
+primOpTag ParOp = 514
+primOpTag SparkOp = 515
+primOpTag SeqOp = 516
+primOpTag GetSparkOp = 517
+primOpTag NumSparks = 518
+primOpTag DataToTagOp = 519
+primOpTag TagToEnumOp = 520
+primOpTag AddrToAnyOp = 521
+primOpTag AnyToAddrOp = 522
+primOpTag MkApUpd0_Op = 523
+primOpTag NewBCOOp = 524
+primOpTag UnpackClosureOp = 525
+primOpTag GetApStackValOp = 526
+primOpTag GetCCSOfOp = 527
+primOpTag GetCurrentCCSOp = 528
+primOpTag ClearCCSOp = 529
+primOpTag TraceEventOp = 530
+primOpTag TraceEventBinaryOp = 531
+primOpTag TraceMarkerOp = 532
+primOpTag GetThreadAllocationCounter = 533
+primOpTag SetThreadAllocationCounter = 534
+primOpTag (VecBroadcastOp IntVec 16 W8) = 535
+primOpTag (VecBroadcastOp IntVec 8 W16) = 536
+primOpTag (VecBroadcastOp IntVec 4 W32) = 537
+primOpTag (VecBroadcastOp IntVec 2 W64) = 538
+primOpTag (VecBroadcastOp IntVec 32 W8) = 539
+primOpTag (VecBroadcastOp IntVec 16 W16) = 540
+primOpTag (VecBroadcastOp IntVec 8 W32) = 541
+primOpTag (VecBroadcastOp IntVec 4 W64) = 542
+primOpTag (VecBroadcastOp IntVec 64 W8) = 543
+primOpTag (VecBroadcastOp IntVec 32 W16) = 544
+primOpTag (VecBroadcastOp IntVec 16 W32) = 545
+primOpTag (VecBroadcastOp IntVec 8 W64) = 546
+primOpTag (VecBroadcastOp WordVec 16 W8) = 547
+primOpTag (VecBroadcastOp WordVec 8 W16) = 548
+primOpTag (VecBroadcastOp WordVec 4 W32) = 549
+primOpTag (VecBroadcastOp WordVec 2 W64) = 550
+primOpTag (VecBroadcastOp WordVec 32 W8) = 551
+primOpTag (VecBroadcastOp WordVec 16 W16) = 552
+primOpTag (VecBroadcastOp WordVec 8 W32) = 553
+primOpTag (VecBroadcastOp WordVec 4 W64) = 554
+primOpTag (VecBroadcastOp WordVec 64 W8) = 555
+primOpTag (VecBroadcastOp WordVec 32 W16) = 556
+primOpTag (VecBroadcastOp WordVec 16 W32) = 557
+primOpTag (VecBroadcastOp WordVec 8 W64) = 558
+primOpTag (VecBroadcastOp FloatVec 4 W32) = 559
+primOpTag (VecBroadcastOp FloatVec 2 W64) = 560
+primOpTag (VecBroadcastOp FloatVec 8 W32) = 561
+primOpTag (VecBroadcastOp FloatVec 4 W64) = 562
+primOpTag (VecBroadcastOp FloatVec 16 W32) = 563
+primOpTag (VecBroadcastOp FloatVec 8 W64) = 564
+primOpTag (VecPackOp IntVec 16 W8) = 565
+primOpTag (VecPackOp IntVec 8 W16) = 566
+primOpTag (VecPackOp IntVec 4 W32) = 567
+primOpTag (VecPackOp IntVec 2 W64) = 568
+primOpTag (VecPackOp IntVec 32 W8) = 569
+primOpTag (VecPackOp IntVec 16 W16) = 570
+primOpTag (VecPackOp IntVec 8 W32) = 571
+primOpTag (VecPackOp IntVec 4 W64) = 572
+primOpTag (VecPackOp IntVec 64 W8) = 573
+primOpTag (VecPackOp IntVec 32 W16) = 574
+primOpTag (VecPackOp IntVec 16 W32) = 575
+primOpTag (VecPackOp IntVec 8 W64) = 576
+primOpTag (VecPackOp WordVec 16 W8) = 577
+primOpTag (VecPackOp WordVec 8 W16) = 578
+primOpTag (VecPackOp WordVec 4 W32) = 579
+primOpTag (VecPackOp WordVec 2 W64) = 580
+primOpTag (VecPackOp WordVec 32 W8) = 581
+primOpTag (VecPackOp WordVec 16 W16) = 582
+primOpTag (VecPackOp WordVec 8 W32) = 583
+primOpTag (VecPackOp WordVec 4 W64) = 584
+primOpTag (VecPackOp WordVec 64 W8) = 585
+primOpTag (VecPackOp WordVec 32 W16) = 586
+primOpTag (VecPackOp WordVec 16 W32) = 587
+primOpTag (VecPackOp WordVec 8 W64) = 588
+primOpTag (VecPackOp FloatVec 4 W32) = 589
+primOpTag (VecPackOp FloatVec 2 W64) = 590
+primOpTag (VecPackOp FloatVec 8 W32) = 591
+primOpTag (VecPackOp FloatVec 4 W64) = 592
+primOpTag (VecPackOp FloatVec 16 W32) = 593
+primOpTag (VecPackOp FloatVec 8 W64) = 594
+primOpTag (VecUnpackOp IntVec 16 W8) = 595
+primOpTag (VecUnpackOp IntVec 8 W16) = 596
+primOpTag (VecUnpackOp IntVec 4 W32) = 597
+primOpTag (VecUnpackOp IntVec 2 W64) = 598
+primOpTag (VecUnpackOp IntVec 32 W8) = 599
+primOpTag (VecUnpackOp IntVec 16 W16) = 600
+primOpTag (VecUnpackOp IntVec 8 W32) = 601
+primOpTag (VecUnpackOp IntVec 4 W64) = 602
+primOpTag (VecUnpackOp IntVec 64 W8) = 603
+primOpTag (VecUnpackOp IntVec 32 W16) = 604
+primOpTag (VecUnpackOp IntVec 16 W32) = 605
+primOpTag (VecUnpackOp IntVec 8 W64) = 606
+primOpTag (VecUnpackOp WordVec 16 W8) = 607
+primOpTag (VecUnpackOp WordVec 8 W16) = 608
+primOpTag (VecUnpackOp WordVec 4 W32) = 609
+primOpTag (VecUnpackOp WordVec 2 W64) = 610
+primOpTag (VecUnpackOp WordVec 32 W8) = 611
+primOpTag (VecUnpackOp WordVec 16 W16) = 612
+primOpTag (VecUnpackOp WordVec 8 W32) = 613
+primOpTag (VecUnpackOp WordVec 4 W64) = 614
+primOpTag (VecUnpackOp WordVec 64 W8) = 615
+primOpTag (VecUnpackOp WordVec 32 W16) = 616
+primOpTag (VecUnpackOp WordVec 16 W32) = 617
+primOpTag (VecUnpackOp WordVec 8 W64) = 618
+primOpTag (VecUnpackOp FloatVec 4 W32) = 619
+primOpTag (VecUnpackOp FloatVec 2 W64) = 620
+primOpTag (VecUnpackOp FloatVec 8 W32) = 621
+primOpTag (VecUnpackOp FloatVec 4 W64) = 622
+primOpTag (VecUnpackOp FloatVec 16 W32) = 623
+primOpTag (VecUnpackOp FloatVec 8 W64) = 624
+primOpTag (VecInsertOp IntVec 16 W8) = 625
+primOpTag (VecInsertOp IntVec 8 W16) = 626
+primOpTag (VecInsertOp IntVec 4 W32) = 627
+primOpTag (VecInsertOp IntVec 2 W64) = 628
+primOpTag (VecInsertOp IntVec 32 W8) = 629
+primOpTag (VecInsertOp IntVec 16 W16) = 630
+primOpTag (VecInsertOp IntVec 8 W32) = 631
+primOpTag (VecInsertOp IntVec 4 W64) = 632
+primOpTag (VecInsertOp IntVec 64 W8) = 633
+primOpTag (VecInsertOp IntVec 32 W16) = 634
+primOpTag (VecInsertOp IntVec 16 W32) = 635
+primOpTag (VecInsertOp IntVec 8 W64) = 636
+primOpTag (VecInsertOp WordVec 16 W8) = 637
+primOpTag (VecInsertOp WordVec 8 W16) = 638
+primOpTag (VecInsertOp WordVec 4 W32) = 639
+primOpTag (VecInsertOp WordVec 2 W64) = 640
+primOpTag (VecInsertOp WordVec 32 W8) = 641
+primOpTag (VecInsertOp WordVec 16 W16) = 642
+primOpTag (VecInsertOp WordVec 8 W32) = 643
+primOpTag (VecInsertOp WordVec 4 W64) = 644
+primOpTag (VecInsertOp WordVec 64 W8) = 645
+primOpTag (VecInsertOp WordVec 32 W16) = 646
+primOpTag (VecInsertOp WordVec 16 W32) = 647
+primOpTag (VecInsertOp WordVec 8 W64) = 648
+primOpTag (VecInsertOp FloatVec 4 W32) = 649
+primOpTag (VecInsertOp FloatVec 2 W64) = 650
+primOpTag (VecInsertOp FloatVec 8 W32) = 651
+primOpTag (VecInsertOp FloatVec 4 W64) = 652
+primOpTag (VecInsertOp FloatVec 16 W32) = 653
+primOpTag (VecInsertOp FloatVec 8 W64) = 654
+primOpTag (VecAddOp IntVec 16 W8) = 655
+primOpTag (VecAddOp IntVec 8 W16) = 656
+primOpTag (VecAddOp IntVec 4 W32) = 657
+primOpTag (VecAddOp IntVec 2 W64) = 658
+primOpTag (VecAddOp IntVec 32 W8) = 659
+primOpTag (VecAddOp IntVec 16 W16) = 660
+primOpTag (VecAddOp IntVec 8 W32) = 661
+primOpTag (VecAddOp IntVec 4 W64) = 662
+primOpTag (VecAddOp IntVec 64 W8) = 663
+primOpTag (VecAddOp IntVec 32 W16) = 664
+primOpTag (VecAddOp IntVec 16 W32) = 665
+primOpTag (VecAddOp IntVec 8 W64) = 666
+primOpTag (VecAddOp WordVec 16 W8) = 667
+primOpTag (VecAddOp WordVec 8 W16) = 668
+primOpTag (VecAddOp WordVec 4 W32) = 669
+primOpTag (VecAddOp WordVec 2 W64) = 670
+primOpTag (VecAddOp WordVec 32 W8) = 671
+primOpTag (VecAddOp WordVec 16 W16) = 672
+primOpTag (VecAddOp WordVec 8 W32) = 673
+primOpTag (VecAddOp WordVec 4 W64) = 674
+primOpTag (VecAddOp WordVec 64 W8) = 675
+primOpTag (VecAddOp WordVec 32 W16) = 676
+primOpTag (VecAddOp WordVec 16 W32) = 677
+primOpTag (VecAddOp WordVec 8 W64) = 678
+primOpTag (VecAddOp FloatVec 4 W32) = 679
+primOpTag (VecAddOp FloatVec 2 W64) = 680
+primOpTag (VecAddOp FloatVec 8 W32) = 681
+primOpTag (VecAddOp FloatVec 4 W64) = 682
+primOpTag (VecAddOp FloatVec 16 W32) = 683
+primOpTag (VecAddOp FloatVec 8 W64) = 684
+primOpTag (VecSubOp IntVec 16 W8) = 685
+primOpTag (VecSubOp IntVec 8 W16) = 686
+primOpTag (VecSubOp IntVec 4 W32) = 687
+primOpTag (VecSubOp IntVec 2 W64) = 688
+primOpTag (VecSubOp IntVec 32 W8) = 689
+primOpTag (VecSubOp IntVec 16 W16) = 690
+primOpTag (VecSubOp IntVec 8 W32) = 691
+primOpTag (VecSubOp IntVec 4 W64) = 692
+primOpTag (VecSubOp IntVec 64 W8) = 693
+primOpTag (VecSubOp IntVec 32 W16) = 694
+primOpTag (VecSubOp IntVec 16 W32) = 695
+primOpTag (VecSubOp IntVec 8 W64) = 696
+primOpTag (VecSubOp WordVec 16 W8) = 697
+primOpTag (VecSubOp WordVec 8 W16) = 698
+primOpTag (VecSubOp WordVec 4 W32) = 699
+primOpTag (VecSubOp WordVec 2 W64) = 700
+primOpTag (VecSubOp WordVec 32 W8) = 701
+primOpTag (VecSubOp WordVec 16 W16) = 702
+primOpTag (VecSubOp WordVec 8 W32) = 703
+primOpTag (VecSubOp WordVec 4 W64) = 704
+primOpTag (VecSubOp WordVec 64 W8) = 705
+primOpTag (VecSubOp WordVec 32 W16) = 706
+primOpTag (VecSubOp WordVec 16 W32) = 707
+primOpTag (VecSubOp WordVec 8 W64) = 708
+primOpTag (VecSubOp FloatVec 4 W32) = 709
+primOpTag (VecSubOp FloatVec 2 W64) = 710
+primOpTag (VecSubOp FloatVec 8 W32) = 711
+primOpTag (VecSubOp FloatVec 4 W64) = 712
+primOpTag (VecSubOp FloatVec 16 W32) = 713
+primOpTag (VecSubOp FloatVec 8 W64) = 714
+primOpTag (VecMulOp IntVec 16 W8) = 715
+primOpTag (VecMulOp IntVec 8 W16) = 716
+primOpTag (VecMulOp IntVec 4 W32) = 717
+primOpTag (VecMulOp IntVec 2 W64) = 718
+primOpTag (VecMulOp IntVec 32 W8) = 719
+primOpTag (VecMulOp IntVec 16 W16) = 720
+primOpTag (VecMulOp IntVec 8 W32) = 721
+primOpTag (VecMulOp IntVec 4 W64) = 722
+primOpTag (VecMulOp IntVec 64 W8) = 723
+primOpTag (VecMulOp IntVec 32 W16) = 724
+primOpTag (VecMulOp IntVec 16 W32) = 725
+primOpTag (VecMulOp IntVec 8 W64) = 726
+primOpTag (VecMulOp WordVec 16 W8) = 727
+primOpTag (VecMulOp WordVec 8 W16) = 728
+primOpTag (VecMulOp WordVec 4 W32) = 729
+primOpTag (VecMulOp WordVec 2 W64) = 730
+primOpTag (VecMulOp WordVec 32 W8) = 731
+primOpTag (VecMulOp WordVec 16 W16) = 732
+primOpTag (VecMulOp WordVec 8 W32) = 733
+primOpTag (VecMulOp WordVec 4 W64) = 734
+primOpTag (VecMulOp WordVec 64 W8) = 735
+primOpTag (VecMulOp WordVec 32 W16) = 736
+primOpTag (VecMulOp WordVec 16 W32) = 737
+primOpTag (VecMulOp WordVec 8 W64) = 738
+primOpTag (VecMulOp FloatVec 4 W32) = 739
+primOpTag (VecMulOp FloatVec 2 W64) = 740
+primOpTag (VecMulOp FloatVec 8 W32) = 741
+primOpTag (VecMulOp FloatVec 4 W64) = 742
+primOpTag (VecMulOp FloatVec 16 W32) = 743
+primOpTag (VecMulOp FloatVec 8 W64) = 744
+primOpTag (VecDivOp FloatVec 4 W32) = 745
+primOpTag (VecDivOp FloatVec 2 W64) = 746
+primOpTag (VecDivOp FloatVec 8 W32) = 747
+primOpTag (VecDivOp FloatVec 4 W64) = 748
+primOpTag (VecDivOp FloatVec 16 W32) = 749
+primOpTag (VecDivOp FloatVec 8 W64) = 750
+primOpTag (VecQuotOp IntVec 16 W8) = 751
+primOpTag (VecQuotOp IntVec 8 W16) = 752
+primOpTag (VecQuotOp IntVec 4 W32) = 753
+primOpTag (VecQuotOp IntVec 2 W64) = 754
+primOpTag (VecQuotOp IntVec 32 W8) = 755
+primOpTag (VecQuotOp IntVec 16 W16) = 756
+primOpTag (VecQuotOp IntVec 8 W32) = 757
+primOpTag (VecQuotOp IntVec 4 W64) = 758
+primOpTag (VecQuotOp IntVec 64 W8) = 759
+primOpTag (VecQuotOp IntVec 32 W16) = 760
+primOpTag (VecQuotOp IntVec 16 W32) = 761
+primOpTag (VecQuotOp IntVec 8 W64) = 762
+primOpTag (VecQuotOp WordVec 16 W8) = 763
+primOpTag (VecQuotOp WordVec 8 W16) = 764
+primOpTag (VecQuotOp WordVec 4 W32) = 765
+primOpTag (VecQuotOp WordVec 2 W64) = 766
+primOpTag (VecQuotOp WordVec 32 W8) = 767
+primOpTag (VecQuotOp WordVec 16 W16) = 768
+primOpTag (VecQuotOp WordVec 8 W32) = 769
+primOpTag (VecQuotOp WordVec 4 W64) = 770
+primOpTag (VecQuotOp WordVec 64 W8) = 771
+primOpTag (VecQuotOp WordVec 32 W16) = 772
+primOpTag (VecQuotOp WordVec 16 W32) = 773
+primOpTag (VecQuotOp WordVec 8 W64) = 774
+primOpTag (VecRemOp IntVec 16 W8) = 775
+primOpTag (VecRemOp IntVec 8 W16) = 776
+primOpTag (VecRemOp IntVec 4 W32) = 777
+primOpTag (VecRemOp IntVec 2 W64) = 778
+primOpTag (VecRemOp IntVec 32 W8) = 779
+primOpTag (VecRemOp IntVec 16 W16) = 780
+primOpTag (VecRemOp IntVec 8 W32) = 781
+primOpTag (VecRemOp IntVec 4 W64) = 782
+primOpTag (VecRemOp IntVec 64 W8) = 783
+primOpTag (VecRemOp IntVec 32 W16) = 784
+primOpTag (VecRemOp IntVec 16 W32) = 785
+primOpTag (VecRemOp IntVec 8 W64) = 786
+primOpTag (VecRemOp WordVec 16 W8) = 787
+primOpTag (VecRemOp WordVec 8 W16) = 788
+primOpTag (VecRemOp WordVec 4 W32) = 789
+primOpTag (VecRemOp WordVec 2 W64) = 790
+primOpTag (VecRemOp WordVec 32 W8) = 791
+primOpTag (VecRemOp WordVec 16 W16) = 792
+primOpTag (VecRemOp WordVec 8 W32) = 793
+primOpTag (VecRemOp WordVec 4 W64) = 794
+primOpTag (VecRemOp WordVec 64 W8) = 795
+primOpTag (VecRemOp WordVec 32 W16) = 796
+primOpTag (VecRemOp WordVec 16 W32) = 797
+primOpTag (VecRemOp WordVec 8 W64) = 798
+primOpTag (VecNegOp IntVec 16 W8) = 799
+primOpTag (VecNegOp IntVec 8 W16) = 800
+primOpTag (VecNegOp IntVec 4 W32) = 801
+primOpTag (VecNegOp IntVec 2 W64) = 802
+primOpTag (VecNegOp IntVec 32 W8) = 803
+primOpTag (VecNegOp IntVec 16 W16) = 804
+primOpTag (VecNegOp IntVec 8 W32) = 805
+primOpTag (VecNegOp IntVec 4 W64) = 806
+primOpTag (VecNegOp IntVec 64 W8) = 807
+primOpTag (VecNegOp IntVec 32 W16) = 808
+primOpTag (VecNegOp IntVec 16 W32) = 809
+primOpTag (VecNegOp IntVec 8 W64) = 810
+primOpTag (VecNegOp FloatVec 4 W32) = 811
+primOpTag (VecNegOp FloatVec 2 W64) = 812
+primOpTag (VecNegOp FloatVec 8 W32) = 813
+primOpTag (VecNegOp FloatVec 4 W64) = 814
+primOpTag (VecNegOp FloatVec 16 W32) = 815
+primOpTag (VecNegOp FloatVec 8 W64) = 816
+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 817
+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 818
+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 819
+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 820
+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 821
+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 822
+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 823
+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 824
+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 825
+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 826
+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 827
+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 828
+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 829
+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 830
+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 831
+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 832
+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 833
+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 834
+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 835
+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 836
+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 837
+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 838
+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 839
+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 840
+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 841
+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 842
+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 843
+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 844
+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 845
+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 846
+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 847
+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 848
+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 849
+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 850
+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 851
+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 852
+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 853
+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 854
+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 855
+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 856
+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 857
+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 858
+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 859
+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 860
+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 861
+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 862
+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 863
+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 864
+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 865
+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 866
+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 867
+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 868
+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 869
+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 870
+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 871
+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 872
+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 873
+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 874
+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 875
+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 876
+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 877
+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 878
+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 879
+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 880
+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 881
+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 882
+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 883
+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 884
+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 885
+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 886
+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 887
+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 888
+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 889
+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 890
+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 891
+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 892
+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 893
+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 894
+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 895
+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 896
+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 897
+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 898
+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 899
+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 900
+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 901
+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 902
+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 903
+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 904
+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 905
+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 906
+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 907
+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 908
+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 909
+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 910
+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 911
+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 912
+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 913
+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 914
+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 915
+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 916
+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 917
+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 918
+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 919
+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 920
+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 921
+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 922
+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 923
+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 924
+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 925
+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 926
+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 927
+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 928
+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 929
+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 930
+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 931
+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 932
+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 933
+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 934
+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 935
+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 936
+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 937
+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 938
+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 939
+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 940
+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 941
+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 942
+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 943
+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 944
+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 945
+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 946
+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 947
+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 948
+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 949
+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 950
+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 951
+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 952
+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 953
+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 954
+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 955
+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 956
+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 957
+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 958
+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 959
+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 960
+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 961
+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 962
+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 963
+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 964
+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 965
+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 966
+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 967
+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 968
+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 969
+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 970
+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 971
+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 972
+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 973
+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 974
+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 975
+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 976
+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 977
+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 978
+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 979
+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 980
+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 981
+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 982
+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 983
+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 984
+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 985
+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 986
+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 987
+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 988
+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 989
+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 990
+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 991
+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 992
+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 993
+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 994
+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 995
+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 996
+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 997
+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 998
+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 999
+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1000
+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1001
+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1002
+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1003
+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1004
+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1005
+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1006
+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1007
+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1008
+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1009
+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1010
+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1011
+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1012
+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1013
+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1014
+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1015
+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1016
+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1017
+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1018
+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1019
+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1020
+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1021
+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1022
+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1023
+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1024
+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1025
+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1026
+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1027
+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1028
+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1029
+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1030
+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1031
+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1032
+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1033
+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1034
+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1035
+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1036
+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1037
+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1038
+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1039
+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1040
+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1041
+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1042
+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1043
+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1044
+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1045
+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1046
+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1047
+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1048
+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1049
+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1050
+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1051
+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1052
+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1053
+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1054
+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1055
+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1056
+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1057
+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1058
+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1059
+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1060
+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1061
+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1062
+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1063
+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1064
+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1065
+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1066
+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1067
+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1068
+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1069
+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1070
+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1071
+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1072
+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1073
+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1074
+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1075
+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1076
+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1077
+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1078
+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1079
+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1080
+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1081
+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1082
+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1083
+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1084
+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1085
+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1086
+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1087
+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1088
+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1089
+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1090
+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1091
+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1092
+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1093
+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1094
+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1095
+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1096
+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1097
+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1098
+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1099
+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1100
+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1101
+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1102
+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1103
+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1104
+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1105
+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1106
+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1107
+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1108
+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1109
+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1110
+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1111
+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1112
+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1113
+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1114
+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1115
+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1116
+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1117
+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1118
+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1119
+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1120
+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1121
+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1122
+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1123
+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1124
+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1125
+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1126
+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1127
+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1128
+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1129
+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1130
+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1131
+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1132
+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1133
+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1134
+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1135
+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1136
+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1137
+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1138
+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1139
+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1140
+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1141
+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1142
+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1143
+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1144
+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1145
+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1146
+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1147
+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1148
+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1149
+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1150
+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1151
+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1152
+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1153
+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1154
+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1155
+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1156
+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1157
+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1158
+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1159
+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1160
+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1161
+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1162
+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1163
+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1164
+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1165
+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1166
+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1167
+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1168
+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1169
+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1170
+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1171
+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1172
+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1173
+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1174
+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1175
+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1176
+primOpTag PrefetchByteArrayOp3 = 1177
+primOpTag PrefetchMutableByteArrayOp3 = 1178
+primOpTag PrefetchAddrOp3 = 1179
+primOpTag PrefetchValueOp3 = 1180
+primOpTag PrefetchByteArrayOp2 = 1181
+primOpTag PrefetchMutableByteArrayOp2 = 1182
+primOpTag PrefetchAddrOp2 = 1183
+primOpTag PrefetchValueOp2 = 1184
+primOpTag PrefetchByteArrayOp1 = 1185
+primOpTag PrefetchMutableByteArrayOp1 = 1186
+primOpTag PrefetchAddrOp1 = 1187
+primOpTag PrefetchValueOp1 = 1188
+primOpTag PrefetchByteArrayOp0 = 1189
+primOpTag PrefetchMutableByteArrayOp0 = 1190
+primOpTag PrefetchAddrOp0 = 1191
+primOpTag PrefetchValueOp0 = 1192
diff --git a/ghc-lib/stage1/compiler/build/primop-vector-tycons.hs-incl b/ghc-lib/stage1/compiler/build/primop-vector-tycons.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-vector-tycons.hs-incl
@@ -0,0 +1,30 @@
+    , int8X16PrimTyCon
+    , int16X8PrimTyCon
+    , int32X4PrimTyCon
+    , int64X2PrimTyCon
+    , int8X32PrimTyCon
+    , int16X16PrimTyCon
+    , int32X8PrimTyCon
+    , int64X4PrimTyCon
+    , int8X64PrimTyCon
+    , int16X32PrimTyCon
+    , int32X16PrimTyCon
+    , int64X8PrimTyCon
+    , word8X16PrimTyCon
+    , word16X8PrimTyCon
+    , word32X4PrimTyCon
+    , word64X2PrimTyCon
+    , word8X32PrimTyCon
+    , word16X16PrimTyCon
+    , word32X8PrimTyCon
+    , word64X4PrimTyCon
+    , word8X64PrimTyCon
+    , word16X32PrimTyCon
+    , word32X16PrimTyCon
+    , word64X8PrimTyCon
+    , floatX4PrimTyCon
+    , doubleX2PrimTyCon
+    , floatX8PrimTyCon
+    , doubleX4PrimTyCon
+    , floatX16PrimTyCon
+    , doubleX8PrimTyCon
diff --git a/ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl b/ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl
@@ -0,0 +1,30 @@
+        int8X16PrimTy, int8X16PrimTyCon,
+        int16X8PrimTy, int16X8PrimTyCon,
+        int32X4PrimTy, int32X4PrimTyCon,
+        int64X2PrimTy, int64X2PrimTyCon,
+        int8X32PrimTy, int8X32PrimTyCon,
+        int16X16PrimTy, int16X16PrimTyCon,
+        int32X8PrimTy, int32X8PrimTyCon,
+        int64X4PrimTy, int64X4PrimTyCon,
+        int8X64PrimTy, int8X64PrimTyCon,
+        int16X32PrimTy, int16X32PrimTyCon,
+        int32X16PrimTy, int32X16PrimTyCon,
+        int64X8PrimTy, int64X8PrimTyCon,
+        word8X16PrimTy, word8X16PrimTyCon,
+        word16X8PrimTy, word16X8PrimTyCon,
+        word32X4PrimTy, word32X4PrimTyCon,
+        word64X2PrimTy, word64X2PrimTyCon,
+        word8X32PrimTy, word8X32PrimTyCon,
+        word16X16PrimTy, word16X16PrimTyCon,
+        word32X8PrimTy, word32X8PrimTyCon,
+        word64X4PrimTy, word64X4PrimTyCon,
+        word8X64PrimTy, word8X64PrimTyCon,
+        word16X32PrimTy, word16X32PrimTyCon,
+        word32X16PrimTy, word32X16PrimTyCon,
+        word64X8PrimTy, word64X8PrimTyCon,
+        floatX4PrimTy, floatX4PrimTyCon,
+        doubleX2PrimTy, doubleX2PrimTyCon,
+        floatX8PrimTy, floatX8PrimTyCon,
+        doubleX4PrimTy, doubleX4PrimTyCon,
+        floatX16PrimTy, floatX16PrimTyCon,
+        doubleX8PrimTy, doubleX8PrimTyCon,
diff --git a/ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl b/ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl
@@ -0,0 +1,180 @@
+int8X16PrimTyConName :: Name
+int8X16PrimTyConName = mkPrimTc (fsLit "Int8X16#") int8X16PrimTyConKey int8X16PrimTyCon
+int8X16PrimTy :: Type
+int8X16PrimTy = mkTyConTy int8X16PrimTyCon
+int8X16PrimTyCon :: TyCon
+int8X16PrimTyCon = pcPrimTyCon0 int8X16PrimTyConName (VecRep 16 Int8ElemRep)
+int16X8PrimTyConName :: Name
+int16X8PrimTyConName = mkPrimTc (fsLit "Int16X8#") int16X8PrimTyConKey int16X8PrimTyCon
+int16X8PrimTy :: Type
+int16X8PrimTy = mkTyConTy int16X8PrimTyCon
+int16X8PrimTyCon :: TyCon
+int16X8PrimTyCon = pcPrimTyCon0 int16X8PrimTyConName (VecRep 8 Int16ElemRep)
+int32X4PrimTyConName :: Name
+int32X4PrimTyConName = mkPrimTc (fsLit "Int32X4#") int32X4PrimTyConKey int32X4PrimTyCon
+int32X4PrimTy :: Type
+int32X4PrimTy = mkTyConTy int32X4PrimTyCon
+int32X4PrimTyCon :: TyCon
+int32X4PrimTyCon = pcPrimTyCon0 int32X4PrimTyConName (VecRep 4 Int32ElemRep)
+int64X2PrimTyConName :: Name
+int64X2PrimTyConName = mkPrimTc (fsLit "Int64X2#") int64X2PrimTyConKey int64X2PrimTyCon
+int64X2PrimTy :: Type
+int64X2PrimTy = mkTyConTy int64X2PrimTyCon
+int64X2PrimTyCon :: TyCon
+int64X2PrimTyCon = pcPrimTyCon0 int64X2PrimTyConName (VecRep 2 Int64ElemRep)
+int8X32PrimTyConName :: Name
+int8X32PrimTyConName = mkPrimTc (fsLit "Int8X32#") int8X32PrimTyConKey int8X32PrimTyCon
+int8X32PrimTy :: Type
+int8X32PrimTy = mkTyConTy int8X32PrimTyCon
+int8X32PrimTyCon :: TyCon
+int8X32PrimTyCon = pcPrimTyCon0 int8X32PrimTyConName (VecRep 32 Int8ElemRep)
+int16X16PrimTyConName :: Name
+int16X16PrimTyConName = mkPrimTc (fsLit "Int16X16#") int16X16PrimTyConKey int16X16PrimTyCon
+int16X16PrimTy :: Type
+int16X16PrimTy = mkTyConTy int16X16PrimTyCon
+int16X16PrimTyCon :: TyCon
+int16X16PrimTyCon = pcPrimTyCon0 int16X16PrimTyConName (VecRep 16 Int16ElemRep)
+int32X8PrimTyConName :: Name
+int32X8PrimTyConName = mkPrimTc (fsLit "Int32X8#") int32X8PrimTyConKey int32X8PrimTyCon
+int32X8PrimTy :: Type
+int32X8PrimTy = mkTyConTy int32X8PrimTyCon
+int32X8PrimTyCon :: TyCon
+int32X8PrimTyCon = pcPrimTyCon0 int32X8PrimTyConName (VecRep 8 Int32ElemRep)
+int64X4PrimTyConName :: Name
+int64X4PrimTyConName = mkPrimTc (fsLit "Int64X4#") int64X4PrimTyConKey int64X4PrimTyCon
+int64X4PrimTy :: Type
+int64X4PrimTy = mkTyConTy int64X4PrimTyCon
+int64X4PrimTyCon :: TyCon
+int64X4PrimTyCon = pcPrimTyCon0 int64X4PrimTyConName (VecRep 4 Int64ElemRep)
+int8X64PrimTyConName :: Name
+int8X64PrimTyConName = mkPrimTc (fsLit "Int8X64#") int8X64PrimTyConKey int8X64PrimTyCon
+int8X64PrimTy :: Type
+int8X64PrimTy = mkTyConTy int8X64PrimTyCon
+int8X64PrimTyCon :: TyCon
+int8X64PrimTyCon = pcPrimTyCon0 int8X64PrimTyConName (VecRep 64 Int8ElemRep)
+int16X32PrimTyConName :: Name
+int16X32PrimTyConName = mkPrimTc (fsLit "Int16X32#") int16X32PrimTyConKey int16X32PrimTyCon
+int16X32PrimTy :: Type
+int16X32PrimTy = mkTyConTy int16X32PrimTyCon
+int16X32PrimTyCon :: TyCon
+int16X32PrimTyCon = pcPrimTyCon0 int16X32PrimTyConName (VecRep 32 Int16ElemRep)
+int32X16PrimTyConName :: Name
+int32X16PrimTyConName = mkPrimTc (fsLit "Int32X16#") int32X16PrimTyConKey int32X16PrimTyCon
+int32X16PrimTy :: Type
+int32X16PrimTy = mkTyConTy int32X16PrimTyCon
+int32X16PrimTyCon :: TyCon
+int32X16PrimTyCon = pcPrimTyCon0 int32X16PrimTyConName (VecRep 16 Int32ElemRep)
+int64X8PrimTyConName :: Name
+int64X8PrimTyConName = mkPrimTc (fsLit "Int64X8#") int64X8PrimTyConKey int64X8PrimTyCon
+int64X8PrimTy :: Type
+int64X8PrimTy = mkTyConTy int64X8PrimTyCon
+int64X8PrimTyCon :: TyCon
+int64X8PrimTyCon = pcPrimTyCon0 int64X8PrimTyConName (VecRep 8 Int64ElemRep)
+word8X16PrimTyConName :: Name
+word8X16PrimTyConName = mkPrimTc (fsLit "Word8X16#") word8X16PrimTyConKey word8X16PrimTyCon
+word8X16PrimTy :: Type
+word8X16PrimTy = mkTyConTy word8X16PrimTyCon
+word8X16PrimTyCon :: TyCon
+word8X16PrimTyCon = pcPrimTyCon0 word8X16PrimTyConName (VecRep 16 Word8ElemRep)
+word16X8PrimTyConName :: Name
+word16X8PrimTyConName = mkPrimTc (fsLit "Word16X8#") word16X8PrimTyConKey word16X8PrimTyCon
+word16X8PrimTy :: Type
+word16X8PrimTy = mkTyConTy word16X8PrimTyCon
+word16X8PrimTyCon :: TyCon
+word16X8PrimTyCon = pcPrimTyCon0 word16X8PrimTyConName (VecRep 8 Word16ElemRep)
+word32X4PrimTyConName :: Name
+word32X4PrimTyConName = mkPrimTc (fsLit "Word32X4#") word32X4PrimTyConKey word32X4PrimTyCon
+word32X4PrimTy :: Type
+word32X4PrimTy = mkTyConTy word32X4PrimTyCon
+word32X4PrimTyCon :: TyCon
+word32X4PrimTyCon = pcPrimTyCon0 word32X4PrimTyConName (VecRep 4 Word32ElemRep)
+word64X2PrimTyConName :: Name
+word64X2PrimTyConName = mkPrimTc (fsLit "Word64X2#") word64X2PrimTyConKey word64X2PrimTyCon
+word64X2PrimTy :: Type
+word64X2PrimTy = mkTyConTy word64X2PrimTyCon
+word64X2PrimTyCon :: TyCon
+word64X2PrimTyCon = pcPrimTyCon0 word64X2PrimTyConName (VecRep 2 Word64ElemRep)
+word8X32PrimTyConName :: Name
+word8X32PrimTyConName = mkPrimTc (fsLit "Word8X32#") word8X32PrimTyConKey word8X32PrimTyCon
+word8X32PrimTy :: Type
+word8X32PrimTy = mkTyConTy word8X32PrimTyCon
+word8X32PrimTyCon :: TyCon
+word8X32PrimTyCon = pcPrimTyCon0 word8X32PrimTyConName (VecRep 32 Word8ElemRep)
+word16X16PrimTyConName :: Name
+word16X16PrimTyConName = mkPrimTc (fsLit "Word16X16#") word16X16PrimTyConKey word16X16PrimTyCon
+word16X16PrimTy :: Type
+word16X16PrimTy = mkTyConTy word16X16PrimTyCon
+word16X16PrimTyCon :: TyCon
+word16X16PrimTyCon = pcPrimTyCon0 word16X16PrimTyConName (VecRep 16 Word16ElemRep)
+word32X8PrimTyConName :: Name
+word32X8PrimTyConName = mkPrimTc (fsLit "Word32X8#") word32X8PrimTyConKey word32X8PrimTyCon
+word32X8PrimTy :: Type
+word32X8PrimTy = mkTyConTy word32X8PrimTyCon
+word32X8PrimTyCon :: TyCon
+word32X8PrimTyCon = pcPrimTyCon0 word32X8PrimTyConName (VecRep 8 Word32ElemRep)
+word64X4PrimTyConName :: Name
+word64X4PrimTyConName = mkPrimTc (fsLit "Word64X4#") word64X4PrimTyConKey word64X4PrimTyCon
+word64X4PrimTy :: Type
+word64X4PrimTy = mkTyConTy word64X4PrimTyCon
+word64X4PrimTyCon :: TyCon
+word64X4PrimTyCon = pcPrimTyCon0 word64X4PrimTyConName (VecRep 4 Word64ElemRep)
+word8X64PrimTyConName :: Name
+word8X64PrimTyConName = mkPrimTc (fsLit "Word8X64#") word8X64PrimTyConKey word8X64PrimTyCon
+word8X64PrimTy :: Type
+word8X64PrimTy = mkTyConTy word8X64PrimTyCon
+word8X64PrimTyCon :: TyCon
+word8X64PrimTyCon = pcPrimTyCon0 word8X64PrimTyConName (VecRep 64 Word8ElemRep)
+word16X32PrimTyConName :: Name
+word16X32PrimTyConName = mkPrimTc (fsLit "Word16X32#") word16X32PrimTyConKey word16X32PrimTyCon
+word16X32PrimTy :: Type
+word16X32PrimTy = mkTyConTy word16X32PrimTyCon
+word16X32PrimTyCon :: TyCon
+word16X32PrimTyCon = pcPrimTyCon0 word16X32PrimTyConName (VecRep 32 Word16ElemRep)
+word32X16PrimTyConName :: Name
+word32X16PrimTyConName = mkPrimTc (fsLit "Word32X16#") word32X16PrimTyConKey word32X16PrimTyCon
+word32X16PrimTy :: Type
+word32X16PrimTy = mkTyConTy word32X16PrimTyCon
+word32X16PrimTyCon :: TyCon
+word32X16PrimTyCon = pcPrimTyCon0 word32X16PrimTyConName (VecRep 16 Word32ElemRep)
+word64X8PrimTyConName :: Name
+word64X8PrimTyConName = mkPrimTc (fsLit "Word64X8#") word64X8PrimTyConKey word64X8PrimTyCon
+word64X8PrimTy :: Type
+word64X8PrimTy = mkTyConTy word64X8PrimTyCon
+word64X8PrimTyCon :: TyCon
+word64X8PrimTyCon = pcPrimTyCon0 word64X8PrimTyConName (VecRep 8 Word64ElemRep)
+floatX4PrimTyConName :: Name
+floatX4PrimTyConName = mkPrimTc (fsLit "FloatX4#") floatX4PrimTyConKey floatX4PrimTyCon
+floatX4PrimTy :: Type
+floatX4PrimTy = mkTyConTy floatX4PrimTyCon
+floatX4PrimTyCon :: TyCon
+floatX4PrimTyCon = pcPrimTyCon0 floatX4PrimTyConName (VecRep 4 FloatElemRep)
+doubleX2PrimTyConName :: Name
+doubleX2PrimTyConName = mkPrimTc (fsLit "DoubleX2#") doubleX2PrimTyConKey doubleX2PrimTyCon
+doubleX2PrimTy :: Type
+doubleX2PrimTy = mkTyConTy doubleX2PrimTyCon
+doubleX2PrimTyCon :: TyCon
+doubleX2PrimTyCon = pcPrimTyCon0 doubleX2PrimTyConName (VecRep 2 DoubleElemRep)
+floatX8PrimTyConName :: Name
+floatX8PrimTyConName = mkPrimTc (fsLit "FloatX8#") floatX8PrimTyConKey floatX8PrimTyCon
+floatX8PrimTy :: Type
+floatX8PrimTy = mkTyConTy floatX8PrimTyCon
+floatX8PrimTyCon :: TyCon
+floatX8PrimTyCon = pcPrimTyCon0 floatX8PrimTyConName (VecRep 8 FloatElemRep)
+doubleX4PrimTyConName :: Name
+doubleX4PrimTyConName = mkPrimTc (fsLit "DoubleX4#") doubleX4PrimTyConKey doubleX4PrimTyCon
+doubleX4PrimTy :: Type
+doubleX4PrimTy = mkTyConTy doubleX4PrimTyCon
+doubleX4PrimTyCon :: TyCon
+doubleX4PrimTyCon = pcPrimTyCon0 doubleX4PrimTyConName (VecRep 4 DoubleElemRep)
+floatX16PrimTyConName :: Name
+floatX16PrimTyConName = mkPrimTc (fsLit "FloatX16#") floatX16PrimTyConKey floatX16PrimTyCon
+floatX16PrimTy :: Type
+floatX16PrimTy = mkTyConTy floatX16PrimTyCon
+floatX16PrimTyCon :: TyCon
+floatX16PrimTyCon = pcPrimTyCon0 floatX16PrimTyConName (VecRep 16 FloatElemRep)
+doubleX8PrimTyConName :: Name
+doubleX8PrimTyConName = mkPrimTc (fsLit "DoubleX8#") doubleX8PrimTyConKey doubleX8PrimTyCon
+doubleX8PrimTy :: Type
+doubleX8PrimTy = mkTyConTy doubleX8PrimTyCon
+doubleX8PrimTyCon :: TyCon
+doubleX8PrimTyCon = pcPrimTyCon0 doubleX8PrimTyConName (VecRep 8 DoubleElemRep)
diff --git a/ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl b/ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl
@@ -0,0 +1,60 @@
+int8X16PrimTyConKey :: Unique
+int8X16PrimTyConKey = mkPreludeTyConUnique 300
+int16X8PrimTyConKey :: Unique
+int16X8PrimTyConKey = mkPreludeTyConUnique 301
+int32X4PrimTyConKey :: Unique
+int32X4PrimTyConKey = mkPreludeTyConUnique 302
+int64X2PrimTyConKey :: Unique
+int64X2PrimTyConKey = mkPreludeTyConUnique 303
+int8X32PrimTyConKey :: Unique
+int8X32PrimTyConKey = mkPreludeTyConUnique 304
+int16X16PrimTyConKey :: Unique
+int16X16PrimTyConKey = mkPreludeTyConUnique 305
+int32X8PrimTyConKey :: Unique
+int32X8PrimTyConKey = mkPreludeTyConUnique 306
+int64X4PrimTyConKey :: Unique
+int64X4PrimTyConKey = mkPreludeTyConUnique 307
+int8X64PrimTyConKey :: Unique
+int8X64PrimTyConKey = mkPreludeTyConUnique 308
+int16X32PrimTyConKey :: Unique
+int16X32PrimTyConKey = mkPreludeTyConUnique 309
+int32X16PrimTyConKey :: Unique
+int32X16PrimTyConKey = mkPreludeTyConUnique 310
+int64X8PrimTyConKey :: Unique
+int64X8PrimTyConKey = mkPreludeTyConUnique 311
+word8X16PrimTyConKey :: Unique
+word8X16PrimTyConKey = mkPreludeTyConUnique 312
+word16X8PrimTyConKey :: Unique
+word16X8PrimTyConKey = mkPreludeTyConUnique 313
+word32X4PrimTyConKey :: Unique
+word32X4PrimTyConKey = mkPreludeTyConUnique 314
+word64X2PrimTyConKey :: Unique
+word64X2PrimTyConKey = mkPreludeTyConUnique 315
+word8X32PrimTyConKey :: Unique
+word8X32PrimTyConKey = mkPreludeTyConUnique 316
+word16X16PrimTyConKey :: Unique
+word16X16PrimTyConKey = mkPreludeTyConUnique 317
+word32X8PrimTyConKey :: Unique
+word32X8PrimTyConKey = mkPreludeTyConUnique 318
+word64X4PrimTyConKey :: Unique
+word64X4PrimTyConKey = mkPreludeTyConUnique 319
+word8X64PrimTyConKey :: Unique
+word8X64PrimTyConKey = mkPreludeTyConUnique 320
+word16X32PrimTyConKey :: Unique
+word16X32PrimTyConKey = mkPreludeTyConUnique 321
+word32X16PrimTyConKey :: Unique
+word32X16PrimTyConKey = mkPreludeTyConUnique 322
+word64X8PrimTyConKey :: Unique
+word64X8PrimTyConKey = mkPreludeTyConUnique 323
+floatX4PrimTyConKey :: Unique
+floatX4PrimTyConKey = mkPreludeTyConUnique 324
+doubleX2PrimTyConKey :: Unique
+doubleX2PrimTyConKey = mkPreludeTyConUnique 325
+floatX8PrimTyConKey :: Unique
+floatX8PrimTyConKey = mkPreludeTyConUnique 326
+doubleX4PrimTyConKey :: Unique
+doubleX4PrimTyConKey = mkPreludeTyConUnique 327
+floatX16PrimTyConKey :: Unique
+floatX16PrimTyConKey = mkPreludeTyConUnique 328
+doubleX8PrimTyConKey :: Unique
+doubleX8PrimTyConKey = mkPreludeTyConUnique 329
diff --git a/ghc-lib/stage1/lib/llvm-passes b/ghc-lib/stage1/lib/llvm-passes
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/lib/llvm-passes
@@ -0,0 +1,5 @@
+[
+(0, "-mem2reg -globalopt"),
+(1, "-O1 -globalopt"),
+(2, "-O2")
+]
diff --git a/ghc-lib/stage1/lib/llvm-targets b/ghc-lib/stage1/lib/llvm-targets
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/lib/llvm-targets
@@ -0,0 +1,31 @@
+[("i386-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", ""))
+,("i686-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", ""))
+,("x86_64-unknown-windows", ("e-m:w-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
+,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))
+,("armv6-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))
+,("armv6l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))
+,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
+,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
+,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
+,("aarch64-unknown-linux-gnu", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
+,("aarch64-unknown-linux", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
+,("i386-unknown-linux-gnu", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))
+,("i386-unknown-linux", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))
+,("x86_64-unknown-linux-gnu", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
+,("x86_64-unknown-linux", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
+,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))
+,("aarch64-unknown-linux-android", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
+,("powerpc64le-unknown-linux", ("e-m:e-i64:64-n32:64", "ppc64le", ""))
+,("amd64-portbld-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
+,("x86_64-unknown-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))
+,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align"))
+,("i386-apple-darwin", ("e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128", "yonah", ""))
+,("x86_64-apple-darwin", ("e-m:o-i64:64-f80:128-n8:16:32:64-S128", "core2", ""))
+,("armv7-apple-ios", ("e-m:o-p:32:32-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32", "generic", ""))
+,("aarch64-apple-ios", ("e-m:o-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
+,("i386-apple-ios", ("e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128", "yonah", ""))
+,("x86_64-apple-ios", ("e-m:o-i64:64-f80:128-n8:16:32:64-S128", "core2", ""))
+,("aarch64-unknown-freebsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))
+,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))
+,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align"))
+]
diff --git a/ghc-lib/stage1/lib/platformConstants b/ghc-lib/stage1/lib/platformConstants
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/lib/platformConstants
@@ -0,0 +1,134 @@
+PlatformConstants {
+    pc_platformConstants = ()
+    , pc_CONTROL_GROUP_CONST_291 = 291
+    , pc_STD_HDR_SIZE = 1
+    , pc_PROF_HDR_SIZE = 2
+    , pc_BLOCK_SIZE = 4096
+    , pc_BLOCKS_PER_MBLOCK = 252
+    , pc_TICKY_BIN_COUNT = 9
+    , pc_OFFSET_StgRegTable_rR1 = 0
+    , pc_OFFSET_StgRegTable_rR2 = 8
+    , pc_OFFSET_StgRegTable_rR3 = 16
+    , pc_OFFSET_StgRegTable_rR4 = 24
+    , pc_OFFSET_StgRegTable_rR5 = 32
+    , pc_OFFSET_StgRegTable_rR6 = 40
+    , pc_OFFSET_StgRegTable_rR7 = 48
+    , pc_OFFSET_StgRegTable_rR8 = 56
+    , pc_OFFSET_StgRegTable_rR9 = 64
+    , pc_OFFSET_StgRegTable_rR10 = 72
+    , pc_OFFSET_StgRegTable_rF1 = 80
+    , pc_OFFSET_StgRegTable_rF2 = 84
+    , pc_OFFSET_StgRegTable_rF3 = 88
+    , pc_OFFSET_StgRegTable_rF4 = 92
+    , pc_OFFSET_StgRegTable_rF5 = 96
+    , pc_OFFSET_StgRegTable_rF6 = 100
+    , pc_OFFSET_StgRegTable_rD1 = 104
+    , pc_OFFSET_StgRegTable_rD2 = 112
+    , pc_OFFSET_StgRegTable_rD3 = 120
+    , pc_OFFSET_StgRegTable_rD4 = 128
+    , pc_OFFSET_StgRegTable_rD5 = 136
+    , pc_OFFSET_StgRegTable_rD6 = 144
+    , pc_OFFSET_StgRegTable_rXMM1 = 152
+    , pc_OFFSET_StgRegTable_rXMM2 = 168
+    , pc_OFFSET_StgRegTable_rXMM3 = 184
+    , pc_OFFSET_StgRegTable_rXMM4 = 200
+    , pc_OFFSET_StgRegTable_rXMM5 = 216
+    , pc_OFFSET_StgRegTable_rXMM6 = 232
+    , pc_OFFSET_StgRegTable_rYMM1 = 248
+    , pc_OFFSET_StgRegTable_rYMM2 = 280
+    , pc_OFFSET_StgRegTable_rYMM3 = 312
+    , pc_OFFSET_StgRegTable_rYMM4 = 344
+    , pc_OFFSET_StgRegTable_rYMM5 = 376
+    , pc_OFFSET_StgRegTable_rYMM6 = 408
+    , pc_OFFSET_StgRegTable_rZMM1 = 440
+    , pc_OFFSET_StgRegTable_rZMM2 = 504
+    , pc_OFFSET_StgRegTable_rZMM3 = 568
+    , pc_OFFSET_StgRegTable_rZMM4 = 632
+    , pc_OFFSET_StgRegTable_rZMM5 = 696
+    , pc_OFFSET_StgRegTable_rZMM6 = 760
+    , pc_OFFSET_StgRegTable_rL1 = 824
+    , pc_OFFSET_StgRegTable_rSp = 832
+    , pc_OFFSET_StgRegTable_rSpLim = 840
+    , pc_OFFSET_StgRegTable_rHp = 848
+    , pc_OFFSET_StgRegTable_rHpLim = 856
+    , pc_OFFSET_StgRegTable_rCCCS = 864
+    , pc_OFFSET_StgRegTable_rCurrentTSO = 872
+    , pc_OFFSET_StgRegTable_rCurrentNursery = 888
+    , pc_OFFSET_StgRegTable_rHpAlloc = 904
+    , pc_OFFSET_stgEagerBlackholeInfo = -24
+    , pc_OFFSET_stgGCEnter1 = -16
+    , pc_OFFSET_stgGCFun = -8
+    , pc_OFFSET_Capability_r = 24
+    , pc_OFFSET_bdescr_start = 0
+    , pc_OFFSET_bdescr_free = 8
+    , pc_OFFSET_bdescr_blocks = 48
+    , pc_OFFSET_bdescr_flags = 46
+    , pc_SIZEOF_CostCentreStack = 96
+    , pc_OFFSET_CostCentreStack_mem_alloc = 72
+    , pc_REP_CostCentreStack_mem_alloc = 8
+    , pc_OFFSET_CostCentreStack_scc_count = 48
+    , pc_REP_CostCentreStack_scc_count = 8
+    , pc_OFFSET_StgHeader_ccs = 8
+    , pc_OFFSET_StgHeader_ldvw = 16
+    , pc_SIZEOF_StgSMPThunkHeader = 8
+    , pc_OFFSET_StgEntCounter_allocs = 48
+    , pc_REP_StgEntCounter_allocs = 8
+    , pc_OFFSET_StgEntCounter_allocd = 16
+    , pc_REP_StgEntCounter_allocd = 8
+    , pc_OFFSET_StgEntCounter_registeredp = 0
+    , pc_OFFSET_StgEntCounter_link = 56
+    , pc_OFFSET_StgEntCounter_entry_count = 40
+    , pc_SIZEOF_StgUpdateFrame_NoHdr = 8
+    , pc_SIZEOF_StgMutArrPtrs_NoHdr = 16
+    , pc_OFFSET_StgMutArrPtrs_ptrs = 0
+    , pc_OFFSET_StgMutArrPtrs_size = 8
+    , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 8
+    , pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0
+    , pc_SIZEOF_StgArrBytes_NoHdr = 8
+    , pc_OFFSET_StgArrBytes_bytes = 0
+    , pc_OFFSET_StgTSO_alloc_limit = 96
+    , pc_OFFSET_StgTSO_cccs = 112
+    , pc_OFFSET_StgTSO_stackobj = 16
+    , pc_OFFSET_StgStack_sp = 8
+    , pc_OFFSET_StgStack_stack = 16
+    , pc_OFFSET_StgUpdateFrame_updatee = 0
+    , pc_OFFSET_StgFunInfoExtraFwd_arity = 4
+    , pc_REP_StgFunInfoExtraFwd_arity = 4
+    , pc_SIZEOF_StgFunInfoExtraRev = 24
+    , pc_OFFSET_StgFunInfoExtraRev_arity = 20
+    , pc_REP_StgFunInfoExtraRev_arity = 4
+    , pc_MAX_SPEC_SELECTEE_SIZE = 15
+    , pc_MAX_SPEC_AP_SIZE = 7
+    , pc_MIN_PAYLOAD_SIZE = 1
+    , pc_MIN_INTLIKE = -16
+    , pc_MAX_INTLIKE = 16
+    , pc_MIN_CHARLIKE = 0
+    , pc_MAX_CHARLIKE = 255
+    , pc_MUT_ARR_PTRS_CARD_BITS = 7
+    , pc_MAX_Vanilla_REG = 10
+    , pc_MAX_Float_REG = 6
+    , pc_MAX_Double_REG = 6
+    , pc_MAX_Long_REG = 1
+    , pc_MAX_XMM_REG = 6
+    , pc_MAX_Real_Vanilla_REG = 6
+    , pc_MAX_Real_Float_REG = 6
+    , pc_MAX_Real_Double_REG = 6
+    , pc_MAX_Real_XMM_REG = 6
+    , pc_MAX_Real_Long_REG = 0
+    , pc_RESERVED_C_STACK_BYTES = 16384
+    , pc_RESERVED_STACK_WORDS = 21
+    , pc_AP_STACK_SPLIM = 1024
+    , pc_WORD_SIZE = 8
+    , pc_DOUBLE_SIZE = 8
+    , pc_CINT_SIZE = 4
+    , pc_CLONG_SIZE = 8
+    , pc_CLONG_LONG_SIZE = 8
+    , pc_BITMAP_BITS_SHIFT = 6
+    , pc_TAG_BITS = 3
+    , pc_WORDS_BIGENDIAN = False
+    , pc_DYNAMIC_BY_DEFAULT = False
+    , pc_LDV_SHIFT = 30
+    , pc_ILDV_CREATE_MASK = 1152921503533105152
+    , pc_ILDV_STATE_CREATE = 0
+    , pc_ILDV_STATE_USE = 1152921504606846976
+  }
diff --git a/ghc-lib/stage1/lib/settings b/ghc-lib/stage1/lib/settings
new file mode 100644
--- /dev/null
+++ b/ghc-lib/stage1/lib/settings
@@ -0,0 +1,36 @@
+[("GCC extra via C opts", " -fwrapv -fno-builtin"),
+ ("C compiler command", "gcc"),
+ ("C compiler flags", ""),
+ ("C compiler link flags", " "),
+ ("C compiler supports -no-pie", "NO"),
+ ("Haskell CPP command","gcc"),
+ ("Haskell CPP flags","-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs"),
+ ("ld command", "ld"),
+ ("ld flags", ""),
+ ("ld supports compact unwind", "YES"),
+ ("ld supports build-id", "NO"),
+ ("ld supports filelist", "YES"),
+ ("ld is GNU ld", "NO"),
+ ("ar command", "ar"),
+ ("ar flags", "qcls"),
+ ("ar supports at file", "NO"),
+ ("ranlib command", "ranlib"),
+ ("touch command", "touch"),
+ ("dllwrap command", "/bin/false"),
+ ("windres command", "/bin/false"),
+ ("libtool command", "libtool"),
+ ("perl command", "/usr/bin/perl"),
+ ("cross compiling", "NO"),
+ ("target os", "OSDarwin"),
+ ("target arch", "ArchX86_64"),
+ ("target word size", "8"),
+ ("target has GNU nonexec stack", "False"),
+ ("target has .ident directive", "True"),
+ ("target has subsections via symbols", "True"),
+ ("target has RTS linker", "YES"),
+ ("Unregisterised", "NO"),
+ ("LLVM llc command", "llc"),
+ ("LLVM opt command", "opt"),
+ ("LLVM clang command", "clang")
+ ]
+
diff --git a/ghc/GHCi/Leak.hs b/ghc/GHCi/Leak.hs
new file mode 100644
--- /dev/null
+++ b/ghc/GHCi/Leak.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE RecordWildCards, LambdaCase, MagicHash, UnboxedTuples #-}
+module GHCi.Leak
+  ( LeakIndicators
+  , getLeakIndicators
+  , checkLeakIndicators
+  ) where
+
+import Control.Monad
+import Data.Bits
+import DynFlags ( sTargetPlatform )
+import Foreign.Ptr (ptrToIntPtr, intPtrToPtr)
+import GHC
+import GHC.Exts (anyToAddr#)
+import GHC.Ptr (Ptr (..))
+import GHC.Types (IO (..))
+import HscTypes
+import Outputable
+import Platform (target32Bit)
+import Prelude
+import System.Mem
+import System.Mem.Weak
+import UniqDFM
+
+-- Checking for space leaks in GHCi. See #15111, and the
+-- -fghci-leak-check flag.
+
+data LeakIndicators = LeakIndicators [LeakModIndicators]
+
+data LeakModIndicators = LeakModIndicators
+  { leakMod :: Weak HomeModInfo
+  , leakIface :: Weak ModIface
+  , leakDetails :: Weak ModDetails
+  , leakLinkable :: Maybe (Weak Linkable)
+  }
+
+-- | Grab weak references to some of the data structures representing
+-- the currently loaded modules.
+getLeakIndicators :: HscEnv -> IO LeakIndicators
+getLeakIndicators HscEnv{..} =
+  fmap LeakIndicators $
+    forM (eltsUDFM hsc_HPT) $ \hmi@HomeModInfo{..} -> do
+      leakMod <- mkWeakPtr hmi Nothing
+      leakIface <- mkWeakPtr hm_iface Nothing
+      leakDetails <- mkWeakPtr hm_details Nothing
+      leakLinkable <- mapM (`mkWeakPtr` Nothing) hm_linkable
+      return $ LeakModIndicators{..}
+
+-- | Look at the LeakIndicators collected by an earlier call to
+-- `getLeakIndicators`, and print messasges if any of them are still
+-- alive.
+checkLeakIndicators :: DynFlags -> LeakIndicators -> IO ()
+checkLeakIndicators dflags (LeakIndicators leakmods)  = do
+  performGC
+  forM_ leakmods $ \LeakModIndicators{..} -> do
+    deRefWeak leakMod >>= \case
+      Nothing -> return ()
+      Just hmi ->
+        report ("HomeModInfo for " ++
+          showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi)
+    deRefWeak leakIface >>= report "ModIface"
+    deRefWeak leakDetails >>= report "ModDetails"
+    forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable"
+ where
+  report :: String -> Maybe a -> IO ()
+  report _ Nothing = return ()
+  report msg (Just a) = do
+    addr <- IO (\s -> case anyToAddr# a s of
+                        (# s', addr #) -> (# s', Ptr addr #)) :: IO (Ptr ())
+    putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " ++
+              show (maskTagBits addr))
+
+  tagBits
+    | target32Bit (sTargetPlatform (settings dflags)) = 2
+    | otherwise = 3
+
+  maskTagBits :: Ptr a -> Ptr a
+  maskTagBits p = intPtrToPtr (ptrToIntPtr p .&. complement (shiftL 1 tagBits - 1))
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
new file mode 100644
--- /dev/null
+++ b/ghc/GHCi/UI.hs
@@ -0,0 +1,3994 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-# OPTIONS -fno-cse #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
+
+-----------------------------------------------------------------------------
+--
+-- GHC Interactive User Interface
+--
+-- (c) The GHC Team 2005-2006
+--
+-----------------------------------------------------------------------------
+
+module GHCi.UI (
+        interactiveUI,
+        GhciSettings(..),
+        defaultGhciSettings,
+        ghciCommands,
+        ghciWelcomeMsg
+    ) where
+
+#include "HsVersions.h"
+
+-- GHCi
+import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' )
+import GHCi.UI.Monad hiding ( args, runStmt )
+import GHCi.UI.Tags
+import GHCi.UI.Info
+import Debugger
+
+-- The GHC interface
+import GHCi
+import GHCi.RemoteTypes
+import GHCi.BreakArray
+import DynFlags
+import ErrUtils hiding (traceCmd)
+import Finder
+import GhcMonad ( modifySession )
+import qualified GHC
+import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),
+             TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
+             GetDocsFailure(..),
+             getModuleGraph, handleSourceError )
+import HscMain (hscParseDeclsWithLocation, hscParseStmtWithLocation)
+import HsImpExp
+import HsSyn
+import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
+                  setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc )
+import Module
+import Name
+import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,
+                  listVisibleModuleNames, pprFlag )
+import IfaceSyn ( showToHeader )
+import PprTyThing
+import PrelNames
+import RdrName ( getGRE_NameQualifier_maybes, getRdrName )
+import SrcLoc
+import qualified Lexer
+
+import StringBuffer
+import Outputable hiding ( printForUser, printForUserPartWay )
+
+import DynamicLoading ( initializePlugins )
+
+-- Other random utilities
+import BasicTypes hiding ( isTopLevel )
+import Config
+import Digraph
+import Encoding
+import FastString
+import Linker
+import Maybes ( orElse, expectJust )
+import NameSet
+import Panic hiding ( showException )
+import Util
+import qualified GHC.LanguageExtensions as LangExt
+import Bag (unitBag)
+
+-- Haskell Libraries
+import System.Console.Haskeline as Haskeline
+
+import Control.Applicative hiding (empty)
+import Control.DeepSeq (deepseq)
+import Control.Monad as Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+
+import Data.Array
+import qualified Data.ByteString.Char8 as BS
+import Data.Char
+import Data.Function
+import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
+import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
+                   partition, sort, sortBy )
+import qualified Data.Set as S
+import Data.Maybe
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Time.LocalTime ( getZonedTime )
+import Data.Time.Format ( formatTime, defaultTimeLocale )
+import Data.Version ( showVersion )
+import Prelude hiding ((<>))
+
+import Exception hiding (catch)
+import Foreign hiding (void)
+import GHC.Stack hiding (SrcLoc(..))
+
+import System.Directory
+import System.Environment
+import System.Exit ( exitWith, ExitCode(..) )
+import System.FilePath
+import System.Info
+import System.IO
+import System.IO.Error
+import System.IO.Unsafe ( unsafePerformIO )
+import System.Process
+import Text.Printf
+import Text.Read ( readMaybe )
+import Text.Read.Lex (isSymbolChar)
+
+import Unsafe.Coerce
+
+#if !defined(mingw32_HOST_OS)
+import System.Posix hiding ( getEnv )
+#else
+import qualified System.Win32
+#endif
+
+import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
+import GHC.IO.Handle ( hFlushAll )
+import GHC.TopHandler ( topHandler )
+
+import GHCi.Leak
+
+-----------------------------------------------------------------------------
+
+data GhciSettings = GhciSettings {
+        availableCommands :: [Command],
+        shortHelpText     :: String,
+        fullHelpText      :: String,
+        defPrompt         :: PromptFunction,
+        defPromptCont     :: PromptFunction
+    }
+
+defaultGhciSettings :: GhciSettings
+defaultGhciSettings =
+    GhciSettings {
+        availableCommands = ghciCommands,
+        shortHelpText     = defShortHelpText,
+        defPrompt         = default_prompt,
+        defPromptCont     = default_prompt_cont,
+        fullHelpText      = defFullHelpText
+    }
+
+ghciWelcomeMsg :: String
+ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
+                 ": https://www.haskell.org/ghc/  :? for help"
+
+ghciCommands :: [Command]
+ghciCommands = map mkCmd [
+  -- Hugs users are accustomed to :e, so make sure it doesn't overlap
+  ("?",         keepGoing help,                 noCompletion),
+  ("add",       keepGoingPaths addModule,       completeFilename),
+  ("abandon",   keepGoing abandonCmd,           noCompletion),
+  ("break",     keepGoing breakCmd,             completeIdentifier),
+  ("back",      keepGoing backCmd,              noCompletion),
+  ("browse",    keepGoing' (browseCmd False),   completeModule),
+  ("browse!",   keepGoing' (browseCmd True),    completeModule),
+  ("cd",        keepGoing' changeDirectory,     completeFilename),
+  ("check",     keepGoing' checkModule,         completeHomeModule),
+  ("continue",  keepGoing continueCmd,          noCompletion),
+  ("cmd",       keepGoing cmdCmd,               completeExpression),
+  ("ctags",     keepGoing createCTagsWithLineNumbersCmd, completeFilename),
+  ("ctags!",    keepGoing createCTagsWithRegExesCmd, completeFilename),
+  ("def",       keepGoing (defineMacro False),  completeExpression),
+  ("def!",      keepGoing (defineMacro True),   completeExpression),
+  ("delete",    keepGoing deleteCmd,            noCompletion),
+  ("doc",       keepGoing' docCmd,              completeIdentifier),
+  ("edit",      keepGoing' editFile,            completeFilename),
+  ("etags",     keepGoing createETagsFileCmd,   completeFilename),
+  ("force",     keepGoing forceCmd,             completeExpression),
+  ("forward",   keepGoing forwardCmd,           noCompletion),
+  ("help",      keepGoing help,                 noCompletion),
+  ("history",   keepGoing historyCmd,           noCompletion),
+  ("info",      keepGoing' (info False),        completeIdentifier),
+  ("info!",     keepGoing' (info True),         completeIdentifier),
+  ("issafe",    keepGoing' isSafeCmd,           completeModule),
+  ("kind",      keepGoing' (kindOfType False),  completeIdentifier),
+  ("kind!",     keepGoing' (kindOfType True),   completeIdentifier),
+  ("load",      keepGoingPaths loadModule_,     completeHomeModuleOrFile),
+  ("load!",     keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),
+  ("list",      keepGoing' listCmd,             noCompletion),
+  ("module",    keepGoing moduleCmd,            completeSetModule),
+  ("main",      keepGoing runMain,              completeFilename),
+  ("print",     keepGoing printCmd,             completeExpression),
+  ("quit",      quit,                           noCompletion),
+  ("reload",    keepGoing' reloadModule,        noCompletion),
+  ("reload!",   keepGoing' reloadModuleDefer,   noCompletion),
+  ("run",       keepGoing runRun,               completeFilename),
+  ("script",    keepGoing' scriptCmd,           completeFilename),
+  ("set",       keepGoing setCmd,               completeSetOptions),
+  ("seti",      keepGoing setiCmd,              completeSeti),
+  ("show",      keepGoing showCmd,              completeShowOptions),
+  ("showi",     keepGoing showiCmd,             completeShowiOptions),
+  ("sprint",    keepGoing sprintCmd,            completeExpression),
+  ("step",      keepGoing stepCmd,              completeIdentifier),
+  ("steplocal", keepGoing stepLocalCmd,         completeIdentifier),
+  ("stepmodule",keepGoing stepModuleCmd,        completeIdentifier),
+  ("type",      keepGoing' typeOfExpr,          completeExpression),
+  ("trace",     keepGoing traceCmd,             completeExpression),
+  ("unadd",     keepGoingPaths unAddModule,     completeFilename),
+  ("undef",     keepGoing undefineMacro,        completeMacro),
+  ("unset",     keepGoing unsetOptions,         completeSetOptions),
+  ("where",     keepGoing whereCmd,             noCompletion)
+  ] ++ map mkCmdHidden [ -- hidden commands
+  ("all-types", keepGoing' allTypesCmd),
+  ("complete",  keepGoing completeCmd),
+  ("loc-at",    keepGoing' locAtCmd),
+  ("type-at",   keepGoing' typeAtCmd),
+  ("uses",      keepGoing' usesCmd)
+  ]
+ where
+  mkCmd (n,a,c) = Command { cmdName = n
+                          , cmdAction = a
+                          , cmdHidden = False
+                          , cmdCompletionFunc = c
+                          }
+
+  mkCmdHidden (n,a) = Command { cmdName = n
+                              , cmdAction = a
+                              , cmdHidden = True
+                              , cmdCompletionFunc = noCompletion
+                              }
+
+-- We initialize readline (in the interactiveUI function) to use
+-- word_break_chars as the default set of completion word break characters.
+-- This can be overridden for a particular command (for example, filename
+-- expansion shouldn't consider '/' to be a word break) by setting the third
+-- entry in the Command tuple above.
+--
+-- NOTE: in order for us to override the default correctly, any custom entry
+-- must be a SUBSET of word_break_chars.
+word_break_chars :: String
+word_break_chars = spaces ++ specials ++ symbols
+
+symbols, specials, spaces :: String
+symbols = "!#$%&*+/<=>?@\\^|-~"
+specials = "(),;[]`{}"
+spaces = " \t\n"
+
+flagWordBreakChars :: String
+flagWordBreakChars = " \t\n"
+
+
+keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
+keepGoing a str = keepGoing' (lift . a) str
+
+keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
+keepGoing' a str = a str >> return False
+
+keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
+keepGoingPaths a str
+ = do case toArgs str of
+          Left err -> liftIO $ hPutStrLn stderr err
+          Right args -> a args
+      return False
+
+defShortHelpText :: String
+defShortHelpText = "use :? for help.\n"
+
+defFullHelpText :: String
+defFullHelpText =
+  " Commands available from the prompt:\n" ++
+  "\n" ++
+  "   <statement>                 evaluate/run <statement>\n" ++
+  "   :                           repeat last command\n" ++
+  "   :{\\n ..lines.. \\n:}\\n       multiline command\n" ++
+  "   :add [*]<module> ...        add module(s) to the current target set\n" ++
+  "   :browse[!] [[*]<mod>]       display the names defined by module <mod>\n" ++
+  "                               (!: more details; *: all top-level names)\n" ++
+  "   :cd <dir>                   change directory to <dir>\n" ++
+  "   :cmd <expr>                 run the commands returned by <expr>::IO String\n" ++
+  "   :complete <dom> [<rng>] <s> list completions for partial input string\n" ++
+  "   :ctags[!] [<file>]          create tags file <file> for Vi (default: \"tags\")\n" ++
+  "                               (!: use regex instead of line number)\n" ++
+  "   :def <cmd> <expr>           define command :<cmd> (later defined command has\n" ++
+  "                               precedence, ::<cmd> is always a builtin command)\n" ++
+  "   :doc <name>                 display docs for the given name (experimental)\n" ++
+  "   :edit <file>                edit file\n" ++
+  "   :edit                       edit last module\n" ++
+  "   :etags [<file>]             create tags file <file> for Emacs (default: \"TAGS\")\n" ++
+  "   :help, :?                   display this list of commands\n" ++
+  "   :info[!] [<name> ...]       display information about the given names\n" ++
+  "                               (!: do not filter instances)\n" ++
+  "   :issafe [<mod>]             display safe haskell information of module <mod>\n" ++
+  "   :kind[!] <type>             show the kind of <type>\n" ++
+  "                               (!: also print the normalised type)\n" ++
+  "   :load[!] [*]<module> ...    load module(s) and their dependents\n" ++
+  "                               (!: defer type errors)\n" ++
+  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
+  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
+  "   :quit                       exit GHCi\n" ++
+  "   :reload[!]                  reload the current module set\n" ++
+  "                               (!: defer type errors)\n" ++
+  "   :run function [<arguments> ...] run the function with the given arguments\n" ++
+  "   :script <file>              run the script <file>\n" ++
+  "   :type <expr>                show the type of <expr>\n" ++
+  "   :type +d <expr>             show the type of <expr>, defaulting type variables\n" ++
+  "   :type +v <expr>             show the type of <expr>, with its specified tyvars\n" ++
+  "   :unadd <module> ...         remove module(s) from the current target set\n" ++
+  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
+  "   :!<command>                 run the shell command <command>\n" ++
+  "\n" ++
+  " -- Commands for debugging:\n" ++
+  "\n" ++
+  "   :abandon                    at a breakpoint, abandon current computation\n" ++
+  "   :back [<n>]                 go back in the history N steps (after :trace)\n" ++
+  "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
+  "   :break <name>               set a breakpoint on the specified function\n" ++
+  "   :continue                   resume after a breakpoint\n" ++
+  "   :delete <number>            delete the specified breakpoint\n" ++
+  "   :delete *                   delete all breakpoints\n" ++
+  "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
+  "   :forward [<n>]              go forward in the history N step s(after :back)\n" ++
+  "   :history [<n>]              after :trace, show the execution history\n" ++
+  "   :list                       show the source code around current breakpoint\n" ++
+  "   :list <identifier>          show the source code for <identifier>\n" ++
+  "   :list [<module>] <line>     show the source code around line number <line>\n" ++
+  "   :print [<name> ...]         show a value without forcing its computation\n" ++
+  "   :sprint [<name> ...]        simplified version of :print\n" ++
+  "   :step                       single-step after stopping at a breakpoint\n"++
+  "   :step <expr>                single-step into <expr>\n"++
+  "   :steplocal                  single-step within the current top-level binding\n"++
+  "   :stepmodule                 single-step restricted to the current module\n"++
+  "   :trace                      trace after stopping at a breakpoint\n"++
+  "   :trace <expr>               evaluate <expr> with tracing on (see :history)\n"++
+
+  "\n" ++
+  " -- Commands for changing settings:\n" ++
+  "\n" ++
+  "   :set <option> ...           set options\n" ++
+  "   :seti <option> ...          set options for interactive evaluation only\n" ++
+  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
+  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
+  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
+  "   :set prompt-cont <prompt>   set the continuation prompt used in GHCi\n" ++
+  "   :set prompt-function <expr> set the function to handle the prompt\n" ++
+  "   :set prompt-cont-function <expr>" ++
+                     "set the function to handle the continuation prompt\n" ++
+  "   :set editor <cmd>           set the command used for :edit\n" ++
+  "   :set stop [<n>] <cmd>       set the command to run when a breakpoint is hit\n" ++
+  "   :unset <option> ...         unset options\n" ++
+  "\n" ++
+  "  Options for ':set' and ':unset':\n" ++
+  "\n" ++
+  "    +m            allow multiline commands\n" ++
+  "    +r            revert top-level expressions after each evaluation\n" ++
+  "    +s            print timing/memory stats after each evaluation\n" ++
+  "    +t            print type after evaluation\n" ++
+  "    +c            collect type/location info after loading modules\n" ++
+  "    -<flags>      most GHC command line flags can also be set here\n" ++
+  "                         (eg. -v2, -XFlexibleInstances, etc.)\n" ++
+  "                    for GHCi-specific flags, see User's Guide,\n"++
+  "                    Flag reference, Interactive-mode options\n" ++
+  "\n" ++
+  " -- Commands for displaying information:\n" ++
+  "\n" ++
+  "   :show bindings              show the current bindings made at the prompt\n" ++
+  "   :show breaks                show the active breakpoints\n" ++
+  "   :show context               show the breakpoint context\n" ++
+  "   :show imports               show the current imports\n" ++
+  "   :show linker                show current linker state\n" ++
+  "   :show modules               show the currently loaded modules\n" ++
+  "   :show packages              show the currently active package flags\n" ++
+  "   :show paths                 show the currently active search paths\n" ++
+  "   :show language              show the currently active language flags\n" ++
+  "   :show targets               show the current set of targets\n" ++
+  "   :show <setting>             show value of <setting>, which is one of\n" ++
+  "                                  [args, prog, editor, stop]\n" ++
+  "   :showi language             show language flags for interactive evaluation\n" ++
+  "\n"
+
+findEditor :: IO String
+findEditor = do
+  getEnv "EDITOR"
+    `catchIO` \_ -> do
+#if defined(mingw32_HOST_OS)
+        win <- System.Win32.getWindowsDirectory
+        return (win </> "notepad.exe")
+#else
+        return ""
+#endif
+
+default_progname, default_stop :: String
+default_progname = "<interactive>"
+default_stop = ""
+
+default_prompt, default_prompt_cont :: PromptFunction
+default_prompt = generatePromptFunctionFromString "%s> "
+default_prompt_cont = generatePromptFunctionFromString "%s| "
+
+default_args :: [String]
+default_args = []
+
+interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
+              -> Ghc ()
+interactiveUI config srcs maybe_exprs = do
+   -- HACK! If we happen to get into an infinite loop (eg the user
+   -- types 'let x=x in x' at the prompt), then the thread will block
+   -- on a blackhole, and become unreachable during GC.  The GC will
+   -- detect that it is unreachable and send it the NonTermination
+   -- exception.  However, since the thread is unreachable, everything
+   -- it refers to might be finalized, including the standard Handles.
+   -- This sounds like a bug, but we don't have a good solution right
+   -- now.
+   _ <- liftIO $ newStablePtr stdin
+   _ <- liftIO $ newStablePtr stdout
+   _ <- liftIO $ newStablePtr stderr
+
+    -- Initialise buffering for the *interpreted* I/O system
+   (nobuffering, flush) <- initInterpBuffering
+
+   -- The initial set of DynFlags used for interactive evaluation is the same
+   -- as the global DynFlags, plus -XExtendedDefaultRules and
+   -- -XNoMonomorphismRestriction.
+   -- See note [Changing language extensions for interactive evaluation] #10857
+   dflags <- getDynFlags
+   let dflags' = (xopt_set_unlessExplSpec
+                      LangExt.ExtendedDefaultRules xopt_set)
+               . (xopt_set_unlessExplSpec
+                      LangExt.MonomorphismRestriction xopt_unset)
+               $ dflags
+   GHC.setInteractiveDynFlags dflags'
+
+   lastErrLocationsRef <- liftIO $ newIORef []
+   progDynFlags <- GHC.getProgramDynFlags
+   _ <- GHC.setProgramDynFlags $
+      -- Ensure we don't override the user's log action lest we break
+      -- -ddump-json (#14078)
+      progDynFlags { log_action = ghciLogAction (log_action progDynFlags)
+                                                lastErrLocationsRef }
+
+   when (isNothing maybe_exprs) $ do
+        -- Only for GHCi (not runghc and ghc -e):
+
+        -- Turn buffering off for the compiled program's stdout/stderr
+        turnOffBuffering_ nobuffering
+        -- Turn buffering off for GHCi's stdout
+        liftIO $ hFlush stdout
+        liftIO $ hSetBuffering stdout NoBuffering
+        -- We don't want the cmd line to buffer any input that might be
+        -- intended for the program, so unbuffer stdin.
+        liftIO $ hSetBuffering stdin NoBuffering
+        liftIO $ hSetBuffering stderr NoBuffering
+#if defined(mingw32_HOST_OS)
+        -- On Unix, stdin will use the locale encoding.  The IO library
+        -- doesn't do this on Windows (yet), so for now we use UTF-8,
+        -- for consistency with GHC 6.10 and to make the tests work.
+        liftIO $ hSetEncoding stdin utf8
+#endif
+
+   default_editor <- liftIO $ findEditor
+   eval_wrapper <- mkEvalWrapper default_progname default_args
+   let prelude_import = simpleImportDecl preludeModuleName
+   startGHCi (runGHCi srcs maybe_exprs)
+        GHCiState{ progname           = default_progname,
+                   args               = default_args,
+                   evalWrapper        = eval_wrapper,
+                   prompt             = defPrompt config,
+                   prompt_cont        = defPromptCont config,
+                   stop               = default_stop,
+                   editor             = default_editor,
+                   options            = [],
+                   -- We initialize line number as 0, not 1, because we use
+                   -- current line number while reporting errors which is
+                   -- incremented after reading a line.
+                   line_number        = 0,
+                   break_ctr          = 0,
+                   breaks             = [],
+                   tickarrays         = emptyModuleEnv,
+                   ghci_commands      = availableCommands config,
+                   ghci_macros        = [],
+                   last_command       = Nothing,
+                   cmd_wrapper        = (cmdSuccess =<<),
+                   cmdqueue           = [],
+                   remembered_ctx     = [],
+                   transient_ctx      = [],
+                   extra_imports      = [],
+                   prelude_imports    = [prelude_import],
+                   ghc_e              = isJust maybe_exprs,
+                   short_help         = shortHelpText config,
+                   long_help          = fullHelpText config,
+                   lastErrorLocations = lastErrLocationsRef,
+                   mod_infos          = M.empty,
+                   flushStdHandles    = flush,
+                   noBuffering        = nobuffering
+                 }
+
+   return ()
+
+{-
+Note [Changing language extensions for interactive evaluation]
+--------------------------------------------------------------
+GHCi maintains two sets of options:
+
+- The "loading options" apply when loading modules
+- The "interactive options" apply when evaluating expressions and commands
+    typed at the GHCi prompt.
+
+The loading options are mostly created in ghc/Main.hs:main' from the command
+line flags. In the function ghc/GHCi/UI.hs:interactiveUI the loading options
+are copied to the interactive options.
+
+These interactive options (but not the loading options!) are supplemented
+unconditionally by setting ExtendedDefaultRules ON and
+MonomorphismRestriction OFF. The unconditional setting of these options
+eventually overwrite settings already specified at the command line.
+
+Therefore instead of unconditionally setting ExtendedDefaultRules and
+NoMonomorphismRestriction for the interactive options, we use the function
+'xopt_set_unlessExplSpec' to first check whether the extension has already
+specified at the command line.
+
+The ghci config file has not yet been processed.
+-}
+
+resetLastErrorLocations :: GHCi ()
+resetLastErrorLocations = do
+    st <- getGHCiState
+    liftIO $ writeIORef (lastErrorLocations st) []
+
+ghciLogAction :: LogAction -> IORef [(FastString, Int)] ->  LogAction
+ghciLogAction old_log_action lastErrLocations
+              dflags flag severity srcSpan style msg = do
+    old_log_action dflags flag severity srcSpan style msg
+    case severity of
+        SevError -> case srcSpan of
+            RealSrcSpan rsp -> modifyIORef lastErrLocations
+                (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])
+            _ -> return ()
+        _ -> return ()
+
+withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
+withGhcAppData right left = do
+    either_dir <- tryIO (getAppUserDataDirectory "ghc")
+    case either_dir of
+        Right dir ->
+            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
+               right dir
+        _ -> left
+
+runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
+runGHCi paths maybe_exprs = do
+  dflags <- getDynFlags
+  let
+   ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
+
+   current_dir = return (Just ".ghci")
+
+   app_user_dir = liftIO $ withGhcAppData
+                    (\dir -> return (Just (dir </> "ghci.conf")))
+                    (return Nothing)
+
+   home_dir = do
+    either_dir <- liftIO $ tryIO (getEnv "HOME")
+    case either_dir of
+      Right home -> return (Just (home </> ".ghci"))
+      _ -> return Nothing
+
+   canonicalizePath' :: FilePath -> IO (Maybe FilePath)
+   canonicalizePath' fp = liftM Just (canonicalizePath fp)
+                `catchIO` \_ -> return Nothing
+
+   sourceConfigFile :: FilePath -> GHCi ()
+   sourceConfigFile file = do
+     exists <- liftIO $ doesFileExist file
+     when exists $ do
+       either_hdl <- liftIO $ tryIO (openFile file ReadMode)
+       case either_hdl of
+         Left _e   -> return ()
+         -- NOTE: this assumes that runInputT won't affect the terminal;
+         -- can we assume this will always be the case?
+         -- This would be a good place for runFileInputT.
+         Right hdl ->
+             do runInputTWithPrefs defaultPrefs defaultSettings $
+                          runCommands $ fileLoop hdl
+                liftIO (hClose hdl `catchIO` \_ -> return ())
+                -- Don't print a message if this is really ghc -e (#11478).
+                -- Also, let the user silence the message with -v0
+                -- (the default verbosity in GHCi is 1).
+                when (isNothing maybe_exprs && verbosity dflags > 0) $
+                  liftIO $ putStrLn ("Loaded GHCi configuration from " ++ file)
+
+  --
+
+  setGHCContextFromGHCiState
+
+  dot_cfgs <- if ignore_dot_ghci then return [] else do
+    dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ]
+    liftIO $ filterM checkFileAndDirPerms dot_files
+  mdot_cfgs <- liftIO $ mapM canonicalizePath' dot_cfgs
+
+  let arg_cfgs = reverse $ ghciScripts dflags
+    -- -ghci-script are collected in reverse order
+    -- We don't require that a script explicitly added by -ghci-script
+    -- is owned by the current user. (#6017)
+  mapM_ sourceConfigFile $ nub $ (catMaybes mdot_cfgs) ++ arg_cfgs
+    -- nub, because we don't want to read .ghci twice if the CWD is $HOME.
+
+  -- Perform a :load for files given on the GHCi command line
+  -- When in -e mode, if the load fails then we want to stop
+  -- immediately rather than going on to evaluate the expression.
+  when (not (null paths)) $ do
+     ok <- ghciHandle (\e -> do showException e; return Failed) $
+                -- TODO: this is a hack.
+                runInputTWithPrefs defaultPrefs defaultSettings $
+                    loadModule paths
+     when (isJust maybe_exprs && failed ok) $
+        liftIO (exitWith (ExitFailure 1))
+
+  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)
+
+  -- if verbosity is greater than 0, or we are connected to a
+  -- terminal, display the prompt in the interactive loop.
+  is_tty <- liftIO (hIsTerminalDevice stdin)
+  let show_prompt = verbosity dflags > 0 || is_tty
+
+  -- reset line number
+  modifyGHCiState $ \st -> st{line_number=0}
+
+  case maybe_exprs of
+        Nothing ->
+          do
+            -- enter the interactive loop
+            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
+        Just exprs -> do
+            -- just evaluate the expression we were given
+            enqueueCommands exprs
+            let hdle e = do st <- getGHCiState
+                            -- flush the interpreter's stdout/stderr on exit (#3890)
+                            flushInterpBuffers
+                            -- Jump through some hoops to get the
+                            -- current progname in the exception text:
+                            -- <progname>: <exception>
+                            liftIO $ withProgName (progname st)
+                                   $ topHandler e
+                                   -- this used to be topHandlerFastExit, see #2228
+            runInputTWithPrefs defaultPrefs defaultSettings $ do
+                -- make `ghc -e` exit nonzero on invalid input, see Trac #7962
+                _ <- runCommands' hdle
+                     (Just $ hdle (toException $ ExitFailure 1) >> return ())
+                     (return Nothing)
+                return ()
+
+  -- and finally, exit
+  liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
+
+runGHCiInput :: InputT GHCi a -> GHCi a
+runGHCiInput f = do
+    dflags <- getDynFlags
+    let ghciHistory = gopt Opt_GhciHistory dflags
+    let localGhciHistory = gopt Opt_LocalGhciHistory dflags
+    currentDirectory <- liftIO $ getCurrentDirectory
+
+    histFile <- case (ghciHistory, localGhciHistory) of
+      (True, True) -> return (Just (currentDirectory </> ".ghci_history"))
+      (True, _) -> liftIO $ withGhcAppData
+        (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing)
+      _ -> return Nothing
+
+    runInputT
+        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
+        f
+
+-- | How to get the next input line from the user
+nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
+nextInputLine show_prompt is_tty
+  | is_tty = do
+    prmpt <- if show_prompt then lift mkPrompt else return ""
+    r <- getInputLine prmpt
+    incrementLineNo
+    return r
+  | otherwise = do
+    when show_prompt $ lift mkPrompt >>= liftIO . putStr
+    fileLoop stdin
+
+-- NOTE: We only read .ghci files if they are owned by the current user,
+-- and aren't world writable (files owned by root are ok, see #9324).
+-- Otherwise, we could be accidentally running code planted by
+-- a malicious third party.
+
+-- Furthermore, We only read ./.ghci if . is owned by the current user
+-- and isn't writable by anyone else.  I think this is sufficient: we
+-- don't need to check .. and ../.. etc. because "."  always refers to
+-- the same directory while a process is running.
+
+checkFileAndDirPerms :: FilePath -> IO Bool
+checkFileAndDirPerms file = do
+  file_ok <- checkPerms file
+  -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will
+  -- print some confusing and useless warnings in some cases (e.g. in
+  -- travis). Note that we can't add a test for this, as all ghci tests should
+  -- run with -ignore-dot-ghci, which means we never get here.
+  if file_ok then checkPerms (getDirectory file) else return False
+  where
+  getDirectory f = case takeDirectory f of
+    "" -> "."
+    d -> d
+
+checkPerms :: FilePath -> IO Bool
+#if defined(mingw32_HOST_OS)
+checkPerms _ = return True
+#else
+checkPerms file =
+  handleIO (\_ -> return False) $ do
+    st <- getFileStatus file
+    me <- getRealUserID
+    let mode = System.Posix.fileMode st
+        ok = (fileOwner st == me || fileOwner st == 0) &&
+             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&
+             otherWriteMode /= mode `intersectFileModes` otherWriteMode
+    unless ok $
+      -- #8248: Improving warning to include a possible fix.
+      putStrLn $ "*** WARNING: " ++ file ++
+                 " is writable by someone else, IGNORING!" ++
+                 "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"
+    return ok
+#endif
+
+incrementLineNo :: InputT GHCi ()
+incrementLineNo = modifyGHCiState incLineNo
+  where
+    incLineNo st = st { line_number = line_number st + 1 }
+
+fileLoop :: Handle -> InputT GHCi (Maybe String)
+fileLoop hdl = do
+   l <- liftIO $ tryIO $ hGetLine hdl
+   case l of
+        Left e | isEOFError e              -> return Nothing
+               | -- as we share stdin with the program, the program
+                 -- might have already closed it, so we might get a
+                 -- handle-closed exception. We therefore catch that
+                 -- too.
+                 isIllegalOperation e      -> return Nothing
+               | InvalidArgument <- etype  -> return Nothing
+               | otherwise                 -> liftIO $ ioError e
+                where etype = ioeGetErrorType e
+                -- treat InvalidArgument in the same way as EOF:
+                -- this can happen if the user closed stdin, or
+                -- perhaps did getContents which closes stdin at
+                -- EOF.
+        Right l' -> do
+           incrementLineNo
+           return (Just l')
+
+formatCurrentTime :: String -> IO String
+formatCurrentTime format =
+  getZonedTime >>= return . (formatTime defaultTimeLocale format)
+
+getUserName :: IO String
+getUserName = do
+#if defined(mingw32_HOST_OS)
+  getEnv "USERNAME"
+    `catchIO` \e -> do
+      putStrLn $ show e
+      return ""
+#else
+  getLoginName
+#endif
+
+getInfoForPrompt :: GHCi (SDoc, [String], Int)
+getInfoForPrompt = do
+  st <- getGHCiState
+  imports <- GHC.getContext
+  resumes <- GHC.getResumeContext
+
+  context_bit <-
+        case resumes of
+            [] -> return empty
+            r:_ -> do
+                let ix = GHC.resumeHistoryIx r
+                if ix == 0
+                   then return (brackets (ppr (GHC.resumeSpan r)) <> space)
+                   else do
+                        let hist = GHC.resumeHistory r !! (ix-1)
+                        pan <- GHC.getHistorySpan hist
+                        return (brackets (ppr (negate ix) <> char ':'
+                                          <+> ppr pan) <> space)
+
+  let
+        dots | _:rs <- resumes, not (null rs) = text "... "
+             | otherwise = empty
+
+        rev_imports = reverse imports -- rightmost are the most recent
+
+        myIdeclName d | Just m <- ideclAs d = unLoc m
+                      | otherwise           = unLoc (ideclName d)
+
+        modules_names =
+             ['*':(moduleNameString m) | IIModule m <- rev_imports] ++
+             [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]
+        line = 1 + line_number st
+
+  return (dots <> context_bit, modules_names, line)
+
+parseCallEscape :: String -> (String, String)
+parseCallEscape s
+  | not (all isSpace beforeOpen) = ("", "")
+  | null sinceOpen               = ("", "")
+  | null sinceClosed             = ("", "")
+  | null cmd                     = ("", "")
+  | otherwise                    = (cmd, tail sinceClosed)
+  where
+    (beforeOpen, sinceOpen) = span (/='(') s
+    (cmd, sinceClosed) = span (/=')') (tail sinceOpen)
+
+checkPromptStringForErrors :: String -> Maybe String
+checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =
+  case parseCallEscape xs of
+    ("", "") -> Just ("Incorrect %call syntax. " ++
+                      "Should be %call(a command and arguments).")
+    (_, afterClosed) -> checkPromptStringForErrors afterClosed
+checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs
+checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs
+checkPromptStringForErrors "" = Nothing
+
+generatePromptFunctionFromString :: String -> PromptFunction
+generatePromptFunctionFromString promptS modules_names line =
+        processString promptS
+  where
+        processString :: String -> GHCi SDoc
+        processString ('%':'s':xs) =
+            liftM2 (<>) (return modules_list) (processString xs)
+            where
+              modules_list = hsep $ map text modules_names
+        processString ('%':'l':xs) =
+            liftM2 (<>) (return $ ppr line) (processString xs)
+        processString ('%':'d':xs) =
+            liftM2 (<>) (liftM text formatted_time) (processString xs)
+            where
+              formatted_time = liftIO $ formatCurrentTime "%a %b %d"
+        processString ('%':'t':xs) =
+            liftM2 (<>) (liftM text formatted_time) (processString xs)
+            where
+              formatted_time = liftIO $ formatCurrentTime "%H:%M:%S"
+        processString ('%':'T':xs) = do
+            liftM2 (<>) (liftM text formatted_time) (processString xs)
+            where
+              formatted_time = liftIO $ formatCurrentTime "%I:%M:%S"
+        processString ('%':'@':xs) = do
+            liftM2 (<>) (liftM text formatted_time) (processString xs)
+            where
+              formatted_time = liftIO $ formatCurrentTime "%I:%M %P"
+        processString ('%':'A':xs) = do
+            liftM2 (<>) (liftM text formatted_time) (processString xs)
+            where
+              formatted_time = liftIO $ formatCurrentTime "%H:%M"
+        processString ('%':'u':xs) =
+            liftM2 (<>) (liftM text user_name) (processString xs)
+            where
+              user_name = liftIO $ getUserName
+        processString ('%':'w':xs) =
+            liftM2 (<>) (liftM text current_directory) (processString xs)
+            where
+              current_directory = liftIO $ getCurrentDirectory
+        processString ('%':'o':xs) =
+            liftM ((text os) <>) (processString xs)
+        processString ('%':'a':xs) =
+            liftM ((text arch) <>) (processString xs)
+        processString ('%':'N':xs) =
+            liftM ((text compilerName) <>) (processString xs)
+        processString ('%':'V':xs) =
+            liftM ((text $ showVersion compilerVersion) <>) (processString xs)
+        processString ('%':'c':'a':'l':'l':xs) = do
+            respond <- liftIO $ do
+                (code, out, err) <-
+                    readProcessWithExitCode
+                    (head list_words) (tail list_words) ""
+                    `catchIO` \e -> return (ExitFailure 1, "", show e)
+                case code of
+                    ExitSuccess -> return out
+                    _ -> do
+                        hPutStrLn stderr err
+                        return ""
+            liftM ((text respond) <>) (processString afterClosed)
+            where
+              (cmd, afterClosed) = parseCallEscape xs
+              list_words = words cmd
+        processString ('%':'%':xs) =
+            liftM ((char '%') <>) (processString xs)
+        processString (x:xs) =
+            liftM (char x <>) (processString xs)
+        processString "" =
+            return empty
+
+mkPrompt :: GHCi String
+mkPrompt = do
+  st <- getGHCiState
+  dflags <- getDynFlags
+  (context, modules_names, line) <- getInfoForPrompt
+
+  prompt_string <- (prompt st) modules_names line
+  let prompt_doc = context <> prompt_string
+
+  return (showSDoc dflags prompt_doc)
+
+queryQueue :: GHCi (Maybe String)
+queryQueue = do
+  st <- getGHCiState
+  case cmdqueue st of
+    []   -> return Nothing
+    c:cs -> do setGHCiState st{ cmdqueue = cs }
+               return (Just c)
+
+-- Reconfigurable pretty-printing Ticket #5461
+installInteractivePrint :: Maybe String -> Bool -> GHCi ()
+installInteractivePrint Nothing _  = return ()
+installInteractivePrint (Just ipFun) exprmode = do
+  ok <- trySuccess $ do
+                names <- GHC.parseName ipFun
+                let name = case names of
+                             name':_ -> name'
+                             [] -> panic "installInteractivePrint"
+                modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
+                                      in he{hsc_IC = new_ic})
+                return Succeeded
+
+  when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))
+
+-- | The main read-eval-print loop
+runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
+runCommands gCmd = runCommands' handler Nothing gCmd >> return ()
+
+runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
+             -> Maybe (GHCi ()) -- ^ Source error handler
+             -> InputT GHCi (Maybe String)
+             -> InputT GHCi (Maybe Bool)
+         -- We want to return () here, but have to return (Maybe Bool)
+         -- because gmask is not polymorphic enough: we want to use
+         -- unmask at two different types.
+runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do
+    b <- ghandle (\e -> case fromException e of
+                          Just UserInterrupt -> return $ Just False
+                          _ -> case fromException e of
+                                 Just ghce ->
+                                   do liftIO (print (ghce :: GhcException))
+                                      return Nothing
+                                 _other ->
+                                   liftIO (Exception.throwIO e))
+            (unmask $ runOneCommand eh gCmd)
+    case b of
+      Nothing -> return Nothing
+      Just success -> do
+        unless success $ maybe (return ()) lift sourceErrorHandler
+        unmask $ runCommands' eh sourceErrorHandler gCmd
+
+-- | Evaluate a single line of user input (either :<command> or Haskell code).
+-- A result of Nothing means there was no more input to process.
+-- Otherwise the result is Just b where b is True if the command succeeded;
+-- this is relevant only to ghc -e, which will exit with status 1
+-- if the command was unsuccessful. GHCi will continue in either case.
+runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
+            -> InputT GHCi (Maybe Bool)
+runOneCommand eh gCmd = do
+  -- run a previously queued command if there is one, otherwise get new
+  -- input from user
+  mb_cmd0 <- noSpace (lift queryQueue)
+  mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0
+  case mb_cmd1 of
+    Nothing -> return Nothing
+    Just c  -> do
+      st <- getGHCiState
+      ghciHandle (\e -> lift $ eh e >>= return . Just) $
+        handleSourceError printErrorAndFail $
+          cmd_wrapper st $ doCommand c
+               -- source error's are handled by runStmt
+               -- is the handler necessary here?
+  where
+    printErrorAndFail err = do
+        GHC.printException err
+        return $ Just False     -- Exit ghc -e, but not GHCi
+
+    noSpace q = q >>= maybe (return Nothing)
+                            (\c -> case removeSpaces c of
+                                     ""   -> noSpace q
+                                     ":{" -> multiLineCmd q
+                                     _    -> return (Just c) )
+    multiLineCmd q = do
+      st <- getGHCiState
+      let p = prompt st
+      setGHCiState st{ prompt = prompt_cont st }
+      mb_cmd <- collectCommand q "" `GHC.gfinally`
+                modifyGHCiState (\st' -> st' { prompt = p })
+      return mb_cmd
+    -- we can't use removeSpaces for the sublines here, so
+    -- multiline commands are somewhat more brittle against
+    -- fileformat errors (such as \r in dos input on unix),
+    -- we get rid of any extra spaces for the ":}" test;
+    -- we also avoid silent failure if ":}" is not found;
+    -- and since there is no (?) valid occurrence of \r (as
+    -- opposed to its String representation, "\r") inside a
+    -- ghci command, we replace any such with ' ' (argh:-(
+    collectCommand q c = q >>=
+      maybe (liftIO (ioError collectError))
+            (\l->if removeSpaces l == ":}"
+                 then return (Just c)
+                 else collectCommand q (c ++ "\n" ++ map normSpace l))
+      where normSpace '\r' = ' '
+            normSpace   x  = x
+    -- SDM (2007-11-07): is userError the one to use here?
+    collectError = userError "unterminated multiline command :{ .. :}"
+
+    -- | Handle a line of input
+    doCommand :: String -> InputT GHCi CommandResult
+
+    -- command
+    doCommand stmt | stmt'@(':' : cmd) <- removeSpaces stmt = do
+      (stats, result) <- runWithStats (const Nothing) $ specialCommand cmd
+      let processResult True = Nothing
+          processResult False = Just True
+      return $ CommandComplete stmt' (processResult <$> result) stats
+
+    -- haskell
+    doCommand stmt = do
+      -- if 'stmt' was entered via ':{' it will contain '\n's
+      let stmt_nl_cnt = length [ () | '\n' <- stmt ]
+      ml <- lift $ isOptionSet Multiline
+      if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input
+        then do
+          fst_line_num <- line_number <$> getGHCiState
+          mb_stmt <- checkInputForLayout stmt gCmd
+          case mb_stmt of
+            Nothing -> return CommandIncomplete
+            Just ml_stmt -> do
+              -- temporarily compensate line-number for multi-line input
+              (stats, result) <- runAndPrintStats runAllocs $ lift $
+                runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion
+              return $
+                CommandComplete ml_stmt (Just . runSuccess <$> result) stats
+        else do -- single line input and :{ - multiline input
+          last_line_num <- line_number <$> getGHCiState
+          -- reconstruct first line num from last line num and stmt
+          let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)
+                           | otherwise = last_line_num -- single line input
+              stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]
+              stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines
+          -- temporarily compensate line-number for multi-line input
+          (stats, result) <- runAndPrintStats runAllocs $ lift $
+            runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion
+          return $ CommandComplete stmt' (Just . runSuccess <$> result) stats
+
+    -- runStmt wrapper for temporarily overridden line-number
+    runStmtWithLineNum :: Int -> String -> SingleStep
+                       -> GHCi (Maybe GHC.ExecResult)
+    runStmtWithLineNum lnum stmt step = do
+        st0 <- getGHCiState
+        setGHCiState st0 { line_number = lnum }
+        result <- runStmt stmt step
+        -- restore original line_number
+        getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }
+        return result
+
+    -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'
+    dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s
+                            , all isSpace l0 = dropLeadingWhiteLines r
+                            | otherwise = s
+
+
+-- #4316
+-- lex the input.  If there is an unclosed layout context, request input
+checkInputForLayout :: String -> InputT GHCi (Maybe String)
+                    -> InputT GHCi (Maybe String)
+checkInputForLayout stmt getStmt = do
+   dflags' <- getDynFlags
+   let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule
+   st0 <- getGHCiState
+   let buf'   =  stringToStringBuffer stmt
+       loc    = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1
+       pstate = Lexer.mkPState dflags buf' loc
+   case Lexer.unP goToEnd pstate of
+     (Lexer.POk _ False) -> return $ Just stmt
+     _other              -> do
+       st1 <- getGHCiState
+       let p = prompt st1
+       setGHCiState st1{ prompt = prompt_cont st1 }
+       mb_stmt <- ghciHandle (\ex -> case fromException ex of
+                            Just UserInterrupt -> return Nothing
+                            _ -> case fromException ex of
+                                 Just ghce ->
+                                   do liftIO (print (ghce :: GhcException))
+                                      return Nothing
+                                 _other -> liftIO (Exception.throwIO ex))
+                     getStmt
+       modifyGHCiState (\st' -> st' { prompt = p })
+       -- the recursive call does not recycle parser state
+       -- as we use a new string buffer
+       case mb_stmt of
+         Nothing  -> return Nothing
+         Just str -> if str == ""
+           then return $ Just stmt
+           else do
+             checkInputForLayout (stmt++"\n"++str) getStmt
+     where goToEnd = do
+             eof <- Lexer.nextIsEOF
+             if eof
+               then Lexer.activeContext
+               else Lexer.lexer False return >> goToEnd
+
+enqueueCommands :: [String] -> GHCi ()
+enqueueCommands cmds = do
+  -- make sure we force any exceptions in the commands while we're
+  -- still inside the exception handler, otherwise bad things will
+  -- happen (see #10501)
+  cmds `deepseq` return ()
+  modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st }
+
+-- | Entry point to execute some haskell code from user.
+-- The return value True indicates success, as in `runOneCommand`.
+runStmt :: String -> SingleStep -> GHCi (Maybe GHC.ExecResult)
+runStmt input step = do
+  dflags <- GHC.getInteractiveDynFlags
+  -- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes`
+  -- and `-fdefer-out-of-scope-variables` for **naked expressions**. The
+  -- declarations and statements are not affected.
+  -- See Note [Deferred type errors in GHCi] in typecheck/TcRnDriver.hs
+  st <- getGHCiState
+  let source = progname st
+  let line = line_number st
+
+  if | GHC.isStmt dflags input -> do
+         hsc_env <- GHC.getSession
+         mb_stmt <- liftIO (runInteractiveHsc hsc_env (hscParseStmtWithLocation source line input))
+         case mb_stmt of
+           Nothing ->
+             -- empty statement / comment
+             return (Just exec_complete)
+           Just stmt ->
+             run_stmt stmt
+
+     | GHC.isImport dflags input -> run_import
+
+     -- Every import declaration should be handled by `run_import`. As GHCi
+     -- in general only accepts one command at a time, we simply throw an
+     -- exception when the input contains multiple commands of which at least
+     -- one is an import command (see #10663).
+     | GHC.hasImport dflags input -> throwGhcException
+       (CmdLineError "error: expecting a single import declaration")
+
+     -- Otherwise assume a declaration (or a list of declarations)
+     -- Note: `GHC.isDecl` returns False on input like
+     -- `data Infix a b = a :@: b; infixl 4 :@:`
+     -- and should therefore not be used here.
+     | otherwise -> do
+         hsc_env <- GHC.getSession
+         decls <- liftIO (hscParseDeclsWithLocation hsc_env source line input)
+         run_decls decls
+  where
+    exec_complete = GHC.ExecComplete (Right []) 0
+
+    run_import = do
+      addImportToContext input
+      return (Just exec_complete)
+
+    run_stmt :: GhciLStmt GhcPs -> GHCi (Maybe GHC.ExecResult)
+    run_stmt stmt = do
+           m_result <- GhciMonad.runStmt stmt input step
+           case m_result of
+               Nothing     -> return Nothing
+               Just result -> Just <$> afterRunStmt (const True) result
+
+    -- `x = y` (a declaration) should be treated as `let x = y` (a statement).
+    -- The reason is because GHCi wasn't designed to support `x = y`, but then
+    -- b98ff3 (#7253) added support for it, except it did not do a good job and
+    -- caused problems like:
+    --
+    --  - not adding the binders defined this way in the necessary places caused
+    --    `x = y` to not work in some cases (#12091).
+    --  - some GHCi command crashed after `x = y` (#15721)
+    --  - warning generation did not work for `x = y` (#11606)
+    --  - because `x = y` is a declaration (instead of a statement) differences
+    --    in generated code caused confusion (#16089)
+    --
+    -- Instead of dealing with all these problems individually here we fix this
+    -- mess by just treating `x = y` as `let x = y`.
+    run_decls :: [LHsDecl GhcPs] -> GHCi (Maybe GHC.ExecResult)
+    -- Only turn `FunBind` and `VarBind` into statements, other bindings
+    -- (e.g. `PatBind`) need to stay as decls.
+    run_decls [L l (ValD _ bind@FunBind{})] = run_stmt (mk_stmt l bind)
+    run_decls [L l (ValD _ bind@VarBind{})] = run_stmt (mk_stmt l bind)
+    -- Note that any `x = y` declarations below will be run as declarations
+    -- instead of statements (e.g. `...; x = y; ...`)
+    run_decls decls = do
+      -- In the new IO library, read handles buffer data even if the Handle
+      -- is set to NoBuffering.  This causes problems for GHCi where there
+      -- are really two stdin Handles.  So we flush any bufferred data in
+      -- GHCi's stdin Handle here (only relevant if stdin is attached to
+      -- a file, otherwise the read buffer can't be flushed).
+      _ <- liftIO $ tryIO $ hFlushAll stdin
+      m_result <- GhciMonad.runDecls' decls
+      forM m_result $ \result ->
+        afterRunStmt (const True) (GHC.ExecComplete (Right result) 0)
+
+    mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs
+    mk_stmt loc bind =
+      let l = L loc
+      in l (LetStmt noExt (l (HsValBinds noExt (ValBinds noExt (unitBag (l bind)) []))))
+
+-- | Clean up the GHCi environment after a statement has run
+afterRunStmt :: (SrcSpan -> Bool) -> GHC.ExecResult -> GHCi GHC.ExecResult
+afterRunStmt step_here run_result = do
+  resumes <- GHC.getResumeContext
+  case run_result of
+     GHC.ExecComplete{..} ->
+       case execResult of
+          Left ex -> liftIO $ Exception.throwIO ex
+          Right names -> do
+            show_types <- isOptionSet ShowType
+            when show_types $ printTypeOfNames names
+     GHC.ExecBreak names mb_info
+         | isNothing  mb_info ||
+           step_here (GHC.resumeSpan $ head resumes) -> do
+               mb_id_loc <- toBreakIdAndLocation mb_info
+               let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
+               if (null bCmd)
+                 then printStoppedAtBreakInfo (head resumes) names
+                 else enqueueCommands [bCmd]
+               -- run the command set with ":set stop <cmd>"
+               st <- getGHCiState
+               enqueueCommands [stop st]
+               return ()
+         | otherwise -> resume step_here GHC.SingleStep >>=
+                        afterRunStmt step_here >> return ()
+
+  flushInterpBuffers
+  withSignalHandlers $ do
+     b <- isOptionSet RevertCAFs
+     when b revertCAFs
+
+  return run_result
+
+runSuccess :: Maybe GHC.ExecResult -> Bool
+runSuccess run_result
+  | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True
+  | otherwise = False
+
+runAllocs :: Maybe GHC.ExecResult -> Maybe Integer
+runAllocs m = do
+  res <- m
+  case res of
+    GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)
+    _ -> Nothing
+
+toBreakIdAndLocation ::
+  Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
+toBreakIdAndLocation Nothing = return Nothing
+toBreakIdAndLocation (Just inf) = do
+  let md = GHC.breakInfo_module inf
+      nm = GHC.breakInfo_number inf
+  st <- getGHCiState
+  return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
+                                  breakModule loc == md,
+                                  breakTick loc == nm ]
+
+printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
+printStoppedAtBreakInfo res names = do
+  printForUser $ pprStopped res
+  --  printTypeOfNames session names
+  let namesSorted = sortBy compareNames names
+  tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
+  docs <- mapM pprTypeAndContents [i | AnId i <- tythings]
+  printForUserPartWay $ vcat docs
+
+printTypeOfNames :: [Name] -> GHCi ()
+printTypeOfNames names
+ = mapM_ (printTypeOfName ) $ sortBy compareNames names
+
+compareNames :: Name -> Name -> Ordering
+n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
+    where compareWith n = (getOccString n, getSrcSpan n)
+
+printTypeOfName :: Name -> GHCi ()
+printTypeOfName n
+   = do maybe_tything <- GHC.lookupName n
+        case maybe_tything of
+            Nothing    -> return ()
+            Just thing -> printTyThing thing
+
+
+data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand
+
+-- | Entry point for execution a ':<command>' input from user
+specialCommand :: String -> InputT GHCi Bool
+specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
+specialCommand str = do
+  let (cmd,rest) = break isSpace str
+  maybe_cmd <- lift $ lookupCommand cmd
+  htxt <- short_help <$> getGHCiState
+  case maybe_cmd of
+    GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)
+    BadCommand ->
+      do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
+                           ++ htxt)
+         return False
+    NoLastCommand ->
+      do liftIO $ hPutStr stdout ("there is no last command to perform\n"
+                           ++ htxt)
+         return False
+
+shellEscape :: String -> GHCi Bool
+shellEscape str = liftIO (system str >> return False)
+
+lookupCommand :: String -> GHCi (MaybeCommand)
+lookupCommand "" = do
+  st <- getGHCiState
+  case last_command st of
+      Just c -> return $ GotCommand c
+      Nothing -> return NoLastCommand
+lookupCommand str = do
+  mc <- lookupCommand' str
+  modifyGHCiState (\st -> st { last_command = mc })
+  return $ case mc of
+           Just c -> GotCommand c
+           Nothing -> BadCommand
+
+lookupCommand' :: String -> GHCi (Maybe Command)
+lookupCommand' ":" = return Nothing
+lookupCommand' str' = do
+  macros    <- ghci_macros <$> getGHCiState
+  ghci_cmds <- ghci_commands <$> getGHCiState
+
+  let ghci_cmds_nohide = filter (not . cmdHidden) ghci_cmds
+
+  let (str, xcmds) = case str' of
+          ':' : rest -> (rest, [])     -- "::" selects a builtin command
+          _          -> (str', macros) -- otherwise include macros in lookup
+
+      lookupExact  s = find $ (s ==)           . cmdName
+      lookupPrefix s = find $ (s `isPrefixOf`) . cmdName
+
+      -- hidden commands can only be matched exact
+      builtinPfxMatch = lookupPrefix str ghci_cmds_nohide
+
+  -- first, look for exact match (while preferring macros); then, look
+  -- for first prefix match (preferring builtins), *unless* a macro
+  -- overrides the builtin; see #8305 for motivation
+  return $ lookupExact str xcmds <|>
+           lookupExact str ghci_cmds <|>
+           (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>
+           builtinPfxMatch <|>
+           lookupPrefix str xcmds
+
+getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
+getCurrentBreakSpan = do
+  resumes <- GHC.getResumeContext
+  case resumes of
+    [] -> return Nothing
+    (r:_) -> do
+        let ix = GHC.resumeHistoryIx r
+        if ix == 0
+           then return (Just (GHC.resumeSpan r))
+           else do
+                let hist = GHC.resumeHistory r !! (ix-1)
+                pan <- GHC.getHistorySpan hist
+                return (Just pan)
+
+getCallStackAtCurrentBreakpoint :: GHCi (Maybe [String])
+getCallStackAtCurrentBreakpoint = do
+  resumes <- GHC.getResumeContext
+  case resumes of
+    [] -> return Nothing
+    (r:_) -> do
+       hsc_env <- GHC.getSession
+       Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r))
+
+getCurrentBreakModule :: GHCi (Maybe Module)
+getCurrentBreakModule = do
+  resumes <- GHC.getResumeContext
+  case resumes of
+    [] -> return Nothing
+    (r:_) -> do
+        let ix = GHC.resumeHistoryIx r
+        if ix == 0
+           then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
+           else do
+                let hist = GHC.resumeHistory r !! (ix-1)
+                return $ Just $ GHC.getHistoryModule  hist
+
+-----------------------------------------------------------------------------
+--
+-- Commands
+--
+-----------------------------------------------------------------------------
+
+noArgs :: GHCi () -> String -> GHCi ()
+noArgs m "" = m
+noArgs _ _  = liftIO $ putStrLn "This command takes no arguments"
+
+withSandboxOnly :: String -> GHCi () -> GHCi ()
+withSandboxOnly cmd this = do
+   dflags <- getDynFlags
+   if not (gopt Opt_GhciSandbox dflags)
+      then printForUser (text cmd <+>
+                         ptext (sLit "is not supported with -fno-ghci-sandbox"))
+      else this
+
+-----------------------------------------------------------------------------
+-- :help
+
+help :: String -> GHCi ()
+help _ = do
+    txt <- long_help `fmap` getGHCiState
+    liftIO $ putStr txt
+
+-----------------------------------------------------------------------------
+-- :info
+
+info :: Bool -> String -> InputT GHCi ()
+info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
+info allInfo s  = handleSourceError GHC.printException $ do
+    unqual <- GHC.getPrintUnqual
+    dflags <- getDynFlags
+    sdocs  <- mapM (infoThing allInfo) (words s)
+    mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs
+
+infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc
+infoThing allInfo str = do
+    names     <- GHC.parseName str
+    mb_stuffs <- mapM (GHC.getInfo allInfo) names
+    let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)
+                                     (catMaybes mb_stuffs)
+    return $ vcat (intersperse (text "") $ map pprInfo filtered)
+
+  -- Filter out names whose parent is also there Good
+  -- example is '[]', which is both a type and data
+  -- constructor in the same type
+filterOutChildren :: (a -> TyThing) -> [a] -> [a]
+filterOutChildren get_thing xs
+  = filterOut has_parent xs
+  where
+    all_names = mkNameSet (map (getName . get_thing) xs)
+    has_parent x = case tyThingParent_maybe (get_thing x) of
+                     Just p  -> getName p `elemNameSet` all_names
+                     Nothing -> False
+
+pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc
+pprInfo (thing, fixity, cls_insts, fam_insts, docs)
+  =  docs
+  $$ pprTyThingInContextLoc thing
+  $$ show_fixity
+  $$ vcat (map GHC.pprInstance cls_insts)
+  $$ vcat (map GHC.pprFamInst  fam_insts)
+  where
+    show_fixity
+        | fixity == GHC.defaultFixity = empty
+        | otherwise                   = ppr fixity <+> pprInfixName (GHC.getName thing)
+
+-----------------------------------------------------------------------------
+-- :main
+
+runMain :: String -> GHCi ()
+runMain s = case toArgs s of
+            Left err   -> liftIO (hPutStrLn stderr err)
+            Right args ->
+                do dflags <- getDynFlags
+                   let main = fromMaybe "main" (mainFunIs dflags)
+                   -- Wrap the main function in 'void' to discard its value instead
+                   -- of printing it (#9086). See Haskell 2010 report Chapter 5.
+                   doWithArgs args $ "Control.Monad.void (" ++ main ++ ")"
+
+-----------------------------------------------------------------------------
+-- :run
+
+runRun :: String -> GHCi ()
+runRun s = case toCmdArgs s of
+           Left err          -> liftIO (hPutStrLn stderr err)
+           Right (cmd, args) -> doWithArgs args cmd
+
+doWithArgs :: [String] -> String -> GHCi ()
+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
+                                       show args ++ " (" ++ cmd ++ ")"]
+
+-----------------------------------------------------------------------------
+-- :cd
+
+changeDirectory :: String -> InputT GHCi ()
+changeDirectory "" = do
+  -- :cd on its own changes to the user's home directory
+  either_dir <- liftIO $ tryIO getHomeDirectory
+  case either_dir of
+     Left _e -> return ()
+     Right dir -> changeDirectory dir
+changeDirectory dir = do
+  graph <- GHC.getModuleGraph
+  when (not (null $ GHC.mgModSummaries graph)) $
+        liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
+  GHC.setTargets []
+  _ <- GHC.load LoadAllTargets
+  lift $ setContextAfterLoad False []
+  GHC.workingDirectoryChanged
+  dir' <- expandPath dir
+  liftIO $ setCurrentDirectory dir'
+  dflags <- getDynFlags
+  -- With -fexternal-interpreter, we have to change the directory of the subprocess too.
+  -- (this gives consistent behaviour with and without -fexternal-interpreter)
+  when (gopt Opt_ExternalInterpreter dflags) $ do
+    hsc_env <- GHC.getSession
+    fhv <- compileGHCiExpr $
+      "System.Directory.setCurrentDirectory " ++ show dir'
+    liftIO $ evalIO hsc_env fhv
+
+trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
+trySuccess act =
+    handleSourceError (\e -> do GHC.printException e
+                                return Failed) $ do
+      act
+
+-----------------------------------------------------------------------------
+-- :edit
+
+editFile :: String -> InputT GHCi ()
+editFile str =
+  do file <- if null str then lift chooseEditFile else expandPath str
+     st <- getGHCiState
+     errs <- liftIO $ readIORef $ lastErrorLocations st
+     let cmd = editor st
+     when (null cmd)
+       $ throwGhcException (CmdLineError "editor not set, use :set editor")
+     lineOpt <- liftIO $ do
+         let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2)
+              `catchIO` (\_ -> return False)
+
+         curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs
+         return $ case curFileErrs of
+             (_, line):_ -> " +" ++ show line
+             _ -> ""
+     let cmdArgs = ' ':(file ++ lineOpt)
+     code <- liftIO $ system (cmd ++ cmdArgs)
+
+     when (code == ExitSuccess)
+       $ reloadModule ""
+
+-- The user didn't specify a file so we pick one for them.
+-- Our strategy is to pick the first module that failed to load,
+-- or otherwise the first target.
+--
+-- XXX: Can we figure out what happened if the depndecy analysis fails
+--      (e.g., because the porgrammeer mistyped the name of a module)?
+-- XXX: Can we figure out the location of an error to pass to the editor?
+-- XXX: if we could figure out the list of errors that occured during the
+-- last load/reaload, then we could start the editor focused on the first
+-- of those.
+chooseEditFile :: GHCi String
+chooseEditFile =
+  do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
+
+     graph <- GHC.getModuleGraph
+     failed_graph <-
+       GHC.mkModuleGraph <$> filterM hasFailed (GHC.mgModSummaries graph)
+     let order g  = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
+         pick xs  = case xs of
+                      x : _ -> GHC.ml_hs_file (GHC.ms_location x)
+                      _     -> Nothing
+
+     case pick (order failed_graph) of
+       Just file -> return file
+       Nothing   ->
+         do targets <- GHC.getTargets
+            case msum (map fromTarget targets) of
+              Just file -> return file
+              Nothing   -> throwGhcException (CmdLineError "No files to edit.")
+
+  where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
+        fromTarget _ = Nothing -- when would we get a module target?
+
+
+-----------------------------------------------------------------------------
+-- :def
+
+defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
+defineMacro _ (':':_) =
+  liftIO $ putStrLn "macro name cannot start with a colon"
+defineMacro overwrite s = do
+  let (macro_name, definition) = break isSpace s
+  macros <- ghci_macros <$> getGHCiState
+  let defined = map cmdName macros
+  if null macro_name
+        then if null defined
+                then liftIO $ putStrLn "no macros defined"
+                else liftIO $ putStr ("the following macros are defined:\n" ++
+                                      unlines defined)
+        else do
+  if (not overwrite && macro_name `elem` defined)
+        then throwGhcException (CmdLineError
+                ("macro '" ++ macro_name ++ "' is already defined"))
+        else do
+
+  -- compile the expression
+  handleSourceError GHC.printException $ do
+    step <- getGhciStepIO
+    expr <- GHC.parseExpr definition
+    -- > ghciStepIO . definition :: String -> IO String
+    let stringTy = nlHsTyVar stringTy_RDR
+        ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
+        body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)
+                                   `mkHsApp` (nlHsPar expr)
+        tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)
+        new_expr = L (getLoc expr) $ ExprWithTySig noExt body tySig
+    hv <- GHC.compileParsedExprRemote new_expr
+
+    let newCmd = Command { cmdName = macro_name
+                         , cmdAction = lift . runMacro hv
+                         , cmdHidden = False
+                         , cmdCompletionFunc = noCompletion
+                         }
+
+    -- later defined macros have precedence
+    modifyGHCiState $ \s ->
+        let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
+        in s { ghci_macros = newCmd : filtered }
+
+runMacro :: GHC.ForeignHValue{-String -> IO String-} -> String -> GHCi Bool
+runMacro fun s = do
+  hsc_env <- GHC.getSession
+  str <- liftIO $ evalStringToIOString hsc_env fun s
+  enqueueCommands (lines str)
+  return False
+
+
+-----------------------------------------------------------------------------
+-- :undef
+
+undefineMacro :: String -> GHCi ()
+undefineMacro str = mapM_ undef (words str)
+ where undef macro_name = do
+        cmds <- ghci_macros <$> getGHCiState
+        if (macro_name `notElem` map cmdName cmds)
+           then throwGhcException (CmdLineError
+                ("macro '" ++ macro_name ++ "' is not defined"))
+           else do
+            -- This is a tad racy but really, it's a shell
+            modifyGHCiState $ \s ->
+                s { ghci_macros = filter ((/= macro_name) . cmdName)
+                                         (ghci_macros s) }
+
+
+-----------------------------------------------------------------------------
+-- :cmd
+
+cmdCmd :: String -> GHCi ()
+cmdCmd str = handleSourceError GHC.printException $ do
+    step <- getGhciStepIO
+    expr <- GHC.parseExpr str
+    -- > ghciStepIO str :: IO String
+    let new_expr = step `mkHsApp` expr
+    hv <- GHC.compileParsedExprRemote new_expr
+
+    hsc_env <- GHC.getSession
+    cmds <- liftIO $ evalString hsc_env hv
+    enqueueCommands (lines cmds)
+
+-- | Generate a typed ghciStepIO expression
+-- @ghciStepIO :: Ty String -> IO String@.
+getGhciStepIO :: GHCi (LHsExpr GhcPs)
+getGhciStepIO = do
+  ghciTyConName <- GHC.getGHCiMonad
+  let stringTy = nlHsTyVar stringTy_RDR
+      ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy
+      ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy
+      body = nlHsVar (getRdrName ghciStepIoMName)
+      tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)
+  return $ noLoc $ ExprWithTySig noExt body tySig
+
+-----------------------------------------------------------------------------
+-- :check
+
+checkModule :: String -> InputT GHCi ()
+checkModule m = do
+  let modl = GHC.mkModuleName m
+  ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
+          r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
+          dflags <- getDynFlags
+          liftIO $ putStrLn $ showSDoc dflags $
+           case GHC.moduleInfo r of
+             cm | Just scope <- GHC.modInfoTopLevelScope cm ->
+                let
+                    (loc, glob) = ASSERT( all isExternalName scope )
+                                  partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
+                in
+                        (text "global names: " <+> ppr glob) $$
+                        (text "local  names: " <+> ppr loc)
+             _ -> empty
+          return True
+  afterLoad (successIf ok) False
+
+-----------------------------------------------------------------------------
+-- :doc
+
+docCmd :: String -> InputT GHCi ()
+docCmd "" =
+  throwGhcException (CmdLineError "syntax: ':doc <thing-you-want-docs-for>'")
+docCmd s  = do
+  -- TODO: Maybe also get module headers for module names
+  names <- GHC.parseName s
+  e_docss <- mapM GHC.getDocs names
+  sdocs <- mapM (either handleGetDocsFailure (pure . pprDocs)) e_docss
+  let sdocs' = vcat (intersperse (text "") sdocs)
+  unqual <- GHC.getPrintUnqual
+  dflags <- getDynFlags
+  (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs'
+
+-- TODO: also print arg docs.
+pprDocs :: (Maybe HsDocString, Map Int HsDocString) -> SDoc
+pprDocs (mb_decl_docs, _arg_docs) =
+  maybe
+    (text "<has no documentation>")
+    (text . unpackHDS)
+    mb_decl_docs
+
+handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m SDoc
+handleGetDocsFailure no_docs = do
+  dflags <- getDynFlags
+  let msg = showPpr dflags no_docs
+  throwGhcException $ case no_docs of
+    NameHasNoModule {} -> Sorry msg
+    NoDocsInIface {} -> InstallationError msg
+    InteractiveName -> ProgramError msg
+
+-----------------------------------------------------------------------------
+-- :load, :add, :reload
+
+-- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets
+-- '-fdefer-type-errors' again if it has not been set before.
+wrapDeferTypeErrors :: InputT GHCi a -> InputT GHCi a
+wrapDeferTypeErrors load =
+  gbracket
+    (do
+      -- Force originalFlags to avoid leaking the associated HscEnv
+      !originalFlags <- getDynFlags
+      void $ GHC.setProgramDynFlags $
+         setGeneralFlag' Opt_DeferTypeErrors originalFlags
+      return originalFlags)
+    (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)
+    (\_ -> load)
+
+loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
+loadModule fs = do
+  (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs)
+  either (liftIO . Exception.throwIO) return result
+
+-- | @:load@ command
+loadModule_ :: [FilePath] -> InputT GHCi ()
+loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))
+
+loadModuleDefer :: [FilePath] -> InputT GHCi ()
+loadModuleDefer = wrapDeferTypeErrors . loadModule_
+
+loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
+loadModule' files = do
+  let (filenames, phases) = unzip files
+  exp_filenames <- mapM expandPath filenames
+  let files' = zip exp_filenames phases
+  targets <- mapM (uncurry GHC.guessTarget) files'
+
+  -- NOTE: we used to do the dependency anal first, so that if it
+  -- fails we didn't throw away the current set of modules.  This would
+  -- require some re-working of the GHC interface, so we'll leave it
+  -- as a ToDo for now.
+
+  hsc_env <- GHC.getSession
+
+  -- Grab references to the currently loaded modules so that we can
+  -- see if they leak.
+  let !dflags = hsc_dflags hsc_env
+  leak_indicators <- if gopt Opt_GhciLeakCheck dflags
+    then liftIO $ getLeakIndicators hsc_env
+    else return (panic "no leak indicators")
+
+  -- unload first
+  _ <- GHC.abandonAll
+  lift discardActiveBreakPoints
+  GHC.setTargets []
+  _ <- GHC.load LoadAllTargets
+
+  GHC.setTargets targets
+  success <- doLoadAndCollectInfo False LoadAllTargets
+  when (gopt Opt_GhciLeakCheck dflags) $
+    liftIO $ checkLeakIndicators dflags leak_indicators
+  return success
+
+-- | @:add@ command
+addModule :: [FilePath] -> InputT GHCi ()
+addModule files = do
+  lift revertCAFs -- always revert CAFs on load/add.
+  files' <- mapM expandPath files
+  targets <- mapM (\m -> GHC.guessTarget m Nothing) files'
+  targets' <- filterM checkTarget targets
+  -- remove old targets with the same id; e.g. for :add *M
+  mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets' ]
+  mapM_ GHC.addTarget targets'
+  _ <- doLoadAndCollectInfo False LoadAllTargets
+  return ()
+  where
+    checkTarget :: Target -> InputT GHCi Bool
+    checkTarget (Target (TargetModule m) _ _) = checkTargetModule m
+    checkTarget (Target (TargetFile f _) _ _) = liftIO $ checkTargetFile f
+
+    checkTargetModule :: ModuleName -> InputT GHCi Bool
+    checkTargetModule m = do
+      hsc_env <- GHC.getSession
+      result <- liftIO $
+        Finder.findImportedModule hsc_env m (Just (fsLit "this"))
+      case result of
+        Found _ _ -> return True
+        _ -> (liftIO $ putStrLn $
+          "Module " ++ moduleNameString m ++ " not found") >> return False
+
+    checkTargetFile :: String -> IO Bool
+    checkTargetFile f = do
+      exists <- (doesFileExist f) :: IO Bool
+      unless exists $ putStrLn $ "File " ++ f ++ " not found"
+      return exists
+
+-- | @:unadd@ command
+unAddModule :: [FilePath] -> InputT GHCi ()
+unAddModule files = do
+  files' <- mapM expandPath files
+  targets <- mapM (\m -> GHC.guessTarget m Nothing) files'
+  mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
+  _ <- doLoadAndCollectInfo False LoadAllTargets
+  return ()
+
+-- | @:reload@ command
+reloadModule :: String -> InputT GHCi ()
+reloadModule m = void $ doLoadAndCollectInfo True loadTargets
+  where
+    loadTargets | null m    = LoadAllTargets
+                | otherwise = LoadUpTo (GHC.mkModuleName m)
+
+reloadModuleDefer :: String -> InputT GHCi ()
+reloadModuleDefer = wrapDeferTypeErrors . reloadModule
+
+-- | Load/compile targets and (optionally) collect module-info
+--
+-- This collects the necessary SrcSpan annotated type information (via
+-- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,
+-- and @:uses@ commands.
+--
+-- Meta-info collection is not enabled by default and needs to be
+-- enabled explicitly via @:set +c@.  The reason is that collecting
+-- the type-information for all sub-spans can be quite expensive, and
+-- since those commands are designed to be used by editors and
+-- tooling, it's useless to collect this data for normal GHCi
+-- sessions.
+doLoadAndCollectInfo :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag
+doLoadAndCollectInfo retain_context howmuch = do
+  doCollectInfo <- lift (isOptionSet CollectInfo)
+
+  doLoad retain_context howmuch >>= \case
+    Succeeded | doCollectInfo -> do
+      mod_summaries <- GHC.mgModSummaries <$> getModuleGraph
+      loaded <- filterM GHC.isLoaded $ map GHC.ms_mod_name mod_summaries
+      v <- mod_infos <$> getGHCiState
+      !newInfos <- collectInfo v loaded
+      modifyGHCiState (\st -> st { mod_infos = newInfos })
+      return Succeeded
+    flag -> return flag
+
+doLoad :: Bool -> LoadHowMuch -> InputT GHCi SuccessFlag
+doLoad retain_context howmuch = do
+  -- turn off breakpoints before we load: we can't turn them off later, because
+  -- the ModBreaks will have gone away.
+  lift discardActiveBreakPoints
+
+  lift resetLastErrorLocations
+  -- Enable buffering stdout and stderr as we're compiling. Keeping these
+  -- handles unbuffered will just slow the compilation down, especially when
+  -- compiling in parallel.
+  gbracket (liftIO $ do hSetBuffering stdout LineBuffering
+                        hSetBuffering stderr LineBuffering)
+           (\_ ->
+            liftIO $ do hSetBuffering stdout NoBuffering
+                        hSetBuffering stderr NoBuffering) $ \_ -> do
+      ok <- trySuccess $ GHC.load howmuch
+      afterLoad ok retain_context
+      return ok
+
+
+afterLoad :: SuccessFlag
+          -> Bool   -- keep the remembered_ctx, as far as possible (:reload)
+          -> InputT GHCi ()
+afterLoad ok retain_context = do
+  lift revertCAFs  -- always revert CAFs on load.
+  lift discardTickArrays
+  loaded_mods <- getLoadedModules
+  modulesLoadedMsg ok loaded_mods
+  lift $ setContextAfterLoad retain_context loaded_mods
+
+setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi ()
+setContextAfterLoad keep_ctxt [] = do
+  setContextKeepingPackageModules keep_ctxt []
+setContextAfterLoad keep_ctxt ms = do
+  -- load a target if one is available, otherwise load the topmost module.
+  targets <- GHC.getTargets
+  case [ m | Just m <- map (findTarget ms) targets ] of
+        []    ->
+          let graph = GHC.mkModuleGraph ms
+              graph' = flattenSCCs (GHC.topSortModuleGraph True graph Nothing)
+          in load_this (last graph')
+        (m:_) ->
+          load_this m
+ where
+   findTarget mds t
+    = case filter (`matches` t) mds of
+        []    -> Nothing
+        (m:_) -> Just m
+
+   summary `matches` Target (TargetModule m) _ _
+        = GHC.ms_mod_name summary == m
+   summary `matches` Target (TargetFile f _) _ _
+        | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'
+   _ `matches` _
+        = False
+
+   load_this summary | m <- GHC.ms_mod summary = do
+        is_interp <- GHC.moduleIsInterpreted m
+        dflags <- getDynFlags
+        let star_ok = is_interp && not (safeLanguageOn dflags)
+              -- We import the module with a * iff
+              --   - it is interpreted, and
+              --   - -XSafe is off (it doesn't allow *-imports)
+        let new_ctx | star_ok   = [mkIIModule (GHC.moduleName m)]
+                    | otherwise = [mkIIDecl   (GHC.moduleName m)]
+        setContextKeepingPackageModules keep_ctxt new_ctx
+
+
+-- | Keep any package modules (except Prelude) when changing the context.
+setContextKeepingPackageModules
+        :: Bool                 -- True  <=> keep all of remembered_ctx
+                                -- False <=> just keep package imports
+        -> [InteractiveImport]  -- new context
+        -> GHCi ()
+
+setContextKeepingPackageModules keep_ctx trans_ctx = do
+
+  st <- getGHCiState
+  let rem_ctx = remembered_ctx st
+  new_rem_ctx <- if keep_ctx then return rem_ctx
+                             else keepPackageImports rem_ctx
+  setGHCiState st{ remembered_ctx = new_rem_ctx,
+                   transient_ctx  = filterSubsumed new_rem_ctx trans_ctx }
+  setGHCContextFromGHCiState
+
+-- | Filters a list of 'InteractiveImport', clearing out any home package
+-- imports so only imports from external packages are preserved.  ('IIModule'
+-- counts as a home package import, because we are only able to bring a
+-- full top-level into scope when the source is available.)
+keepPackageImports :: [InteractiveImport] -> GHCi [InteractiveImport]
+keepPackageImports = filterM is_pkg_import
+  where
+     is_pkg_import :: InteractiveImport -> GHCi Bool
+     is_pkg_import (IIModule _) = return False
+     is_pkg_import (IIDecl d)
+         = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)
+              case e :: Either SomeException Module of
+                Left _  -> return False
+                Right m -> return (not (isHomeModule m))
+        where
+          mod_name = unLoc (ideclName d)
+
+
+modulesLoadedMsg :: SuccessFlag -> [GHC.ModSummary] -> InputT GHCi ()
+modulesLoadedMsg ok mods = do
+  dflags <- getDynFlags
+  unqual <- GHC.getPrintUnqual
+
+  msg <- if gopt Opt_ShowLoadedModules dflags
+         then do
+               mod_names <- mapM mod_name mods
+               let mod_commas
+                     | null mods = text "none."
+                     | otherwise = hsep (punctuate comma mod_names) <> text "."
+               return $ status <> text ", modules loaded:" <+> mod_commas
+         else do
+               return $ status <> text ","
+                    <+> speakNOf (length mods) (text "module") <+> "loaded."
+
+  when (verbosity dflags > 0) $
+     liftIO $ putStrLn $ showSDocForUser dflags unqual msg
+  where
+    status = case ok of
+                  Failed    -> text "Failed"
+                  Succeeded -> text "Ok"
+
+    mod_name mod = do
+        is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod
+        return $ if is_interpreted
+                 then ppr (GHC.ms_mod mod)
+                 else ppr (GHC.ms_mod mod)
+                      <+> parens (text $ normalise $ msObjFilePath mod)
+                      -- Fix #9887
+
+-- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors
+-- and printing 'throwE' strings to 'stderr'
+runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()
+runExceptGhcMonad act = handleSourceError GHC.printException $
+                        either handleErr pure =<<
+                        runExceptT act
+  where
+    handleErr sdoc = do
+        dflags <- getDynFlags
+        liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc
+
+-- | Inverse of 'runExceptT' for \"pure\" computations
+-- (c.f. 'except' for 'Except')
+exceptT :: Applicative m => Either e a -> ExceptT e m a
+exceptT = ExceptT . pure
+
+-----------------------------------------------------------------------------
+-- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.
+
+typeOfExpr :: String -> InputT GHCi ()
+typeOfExpr str = handleSourceError GHC.printException $ do
+    let (mode, expr_str) = case break isSpace str of
+          ("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest)
+          ("+v", rest) -> (GHC.TM_NoInst,  dropWhile isSpace rest)
+          _            -> (GHC.TM_Inst,    str)
+    ty <- GHC.exprType mode expr_str
+    printForUser $ sep [text expr_str, nest 2 (dcolon <+> pprTypeForUser ty)]
+
+-----------------------------------------------------------------------------
+-- | @:type-at@ command
+
+typeAtCmd :: String -> InputT GHCi ()
+typeAtCmd str = runExceptGhcMonad $ do
+    (span',sample) <- exceptT $ parseSpanArg str
+    infos      <- mod_infos <$> getGHCiState
+    (info, ty) <- findType infos span' sample
+    lift $ printForUserModInfo (modinfoInfo info)
+                               (sep [text sample,nest 2 (dcolon <+> ppr ty)])
+
+-----------------------------------------------------------------------------
+-- | @:uses@ command
+
+usesCmd :: String -> InputT GHCi ()
+usesCmd str = runExceptGhcMonad $ do
+    (span',sample) <- exceptT $ parseSpanArg str
+    infos  <- mod_infos <$> getGHCiState
+    uses   <- findNameUses infos span' sample
+    forM_ uses (liftIO . putStrLn . showSrcSpan)
+
+-----------------------------------------------------------------------------
+-- | @:loc-at@ command
+
+locAtCmd :: String -> InputT GHCi ()
+locAtCmd str = runExceptGhcMonad $ do
+    (span',sample) <- exceptT $ parseSpanArg str
+    infos    <- mod_infos <$> getGHCiState
+    (_,_,sp) <- findLoc infos span' sample
+    liftIO . putStrLn . showSrcSpan $ sp
+
+-----------------------------------------------------------------------------
+-- | @:all-types@ command
+
+allTypesCmd :: String -> InputT GHCi ()
+allTypesCmd _ = runExceptGhcMonad $ do
+    infos <- mod_infos <$> getGHCiState
+    forM_ (M.elems infos) $ \mi ->
+        forM_ (modinfoSpans mi) (lift . printSpan)
+  where
+    printSpan span'
+      | Just ty <- spaninfoType span' = do
+        df <- getDynFlags
+        let tyInfo = unwords . words $
+                     showSDocForUser df alwaysQualify (pprTypeForUser ty)
+        liftIO . putStrLn $
+            showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo
+      | otherwise = return ()
+
+-----------------------------------------------------------------------------
+-- Helpers for locAtCmd/typeAtCmd/usesCmd
+
+-- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>
+parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)
+parseSpanArg s = do
+    (fp,s0) <- readAsString (skipWs s)
+    s0'     <- skipWs1 s0
+    (sl,s1) <- readAsInt s0'
+    s1'     <- skipWs1 s1
+    (sc,s2) <- readAsInt s1'
+    s2'     <- skipWs1 s2
+    (el,s3) <- readAsInt s2'
+    s3'     <- skipWs1 s3
+    (ec,s4) <- readAsInt s3'
+
+    trailer <- case s4 of
+        [] -> Right ""
+        _  -> skipWs1 s4
+
+    let fs    = mkFastString fp
+        span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)
+                              (mkRealSrcLoc fs el ec)
+
+    return (span',trailer)
+  where
+    readAsInt :: String -> Either SDoc (Int,String)
+    readAsInt "" = Left "Premature end of string while expecting Int"
+    readAsInt s0 = case reads s0 of
+        [s_rest] -> Right s_rest
+        _        -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")
+
+    readAsString :: String -> Either SDoc (String,String)
+    readAsString s0
+      | '"':_ <- s0 = case reads s0 of
+          [s_rest] -> Right s_rest
+          _        -> leftRes
+      | s_rest@(_:_,_) <- breakWs s0 = Right s_rest
+      | otherwise = leftRes
+      where
+        leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")
+
+    skipWs1 :: String -> Either SDoc String
+    skipWs1 (c:cs) | isWs c = Right (skipWs cs)
+    skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))
+
+    isWs    = (`elem` [' ','\t'])
+    skipWs  = dropWhile isWs
+    breakWs = break isWs
+
+
+-- | Pretty-print \"real\" 'SrcSpan's as
+-- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@
+-- while simply unpacking 'UnhelpfulSpan's
+showSrcSpan :: SrcSpan -> String
+showSrcSpan (UnhelpfulSpan s)  = unpackFS s
+showSrcSpan (RealSrcSpan spn)  = showRealSrcSpan spn
+
+-- | Variant of 'showSrcSpan' for 'RealSrcSpan's
+showRealSrcSpan :: RealSrcSpan -> String
+showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc
+                             , ")-(", show el, ",", show ec, ")"
+                             ]
+  where
+    fp = unpackFS (srcSpanFile spn)
+    sl = srcSpanStartLine spn
+    sc = srcSpanStartCol  spn
+    el = srcSpanEndLine   spn
+    ec = srcSpanEndCol    spn
+
+-----------------------------------------------------------------------------
+-- | @:kind@ command
+
+kindOfType :: Bool -> String -> InputT GHCi ()
+kindOfType norm str = handleSourceError GHC.printException $ do
+    (ty, kind) <- GHC.typeKind norm str
+    printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind
+                        , ppWhen norm $ equals <+> pprTypeForUser ty ]
+
+-----------------------------------------------------------------------------
+-- :quit
+
+quit :: String -> InputT GHCi Bool
+quit _ = return True
+
+
+-----------------------------------------------------------------------------
+-- :script
+
+-- running a script file #1363
+
+scriptCmd :: String -> InputT GHCi ()
+scriptCmd ws = do
+  case words ws of
+    [s]    -> runScript s
+    _      -> throwGhcException (CmdLineError "syntax:  :script <filename>")
+
+runScript :: String    -- ^ filename
+           -> InputT GHCi ()
+runScript filename = do
+  filename' <- expandPath filename
+  either_script <- liftIO $ tryIO (openFile filename' ReadMode)
+  case either_script of
+    Left _err    -> throwGhcException (CmdLineError $ "IO error:  \""++filename++"\" "
+                      ++(ioeGetErrorString _err))
+    Right script -> do
+      st <- getGHCiState
+      let prog = progname st
+          line = line_number st
+      setGHCiState st{progname=filename',line_number=0}
+      scriptLoop script
+      liftIO $ hClose script
+      new_st <- getGHCiState
+      setGHCiState new_st{progname=prog,line_number=line}
+  where scriptLoop script = do
+          res <- runOneCommand handler $ fileLoop script
+          case res of
+            Nothing -> return ()
+            Just s  -> if s
+              then scriptLoop script
+              else return ()
+
+-----------------------------------------------------------------------------
+-- :issafe
+
+-- Displaying Safe Haskell properties of a module
+
+isSafeCmd :: String -> InputT GHCi ()
+isSafeCmd m =
+    case words m of
+        [s] | looksLikeModuleName s -> do
+            md <- lift $ lookupModule s
+            isSafeModule md
+        [] -> do md <- guessCurrentModule "issafe"
+                 isSafeModule md
+        _ -> throwGhcException (CmdLineError "syntax:  :issafe <module>")
+
+isSafeModule :: Module -> InputT GHCi ()
+isSafeModule m = do
+    mb_mod_info <- GHC.getModuleInfo m
+    when (isNothing mb_mod_info)
+         (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)
+
+    dflags <- getDynFlags
+    let iface = GHC.modInfoIface $ fromJust mb_mod_info
+    when (isNothing iface)
+         (throwGhcException $ CmdLineError $ "can't load interface file for module: " ++
+                                    (GHC.moduleNameString $ GHC.moduleName m))
+
+    (msafe, pkgs) <- GHC.moduleTrustReqs m
+    let trust  = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface
+        pkg    = if packageTrusted dflags m then "trusted" else "untrusted"
+        (good, bad) = tallyPkgs dflags pkgs
+
+    -- print info to user...
+    liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"
+    liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")
+    when (not $ S.null good)
+         (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++
+                        (intercalate ", " $ map (showPpr dflags) (S.toList good)))
+    case msafe && S.null bad of
+        True -> liftIO $ putStrLn $ mname ++ " is trusted!"
+        False -> do
+            when (not $ null bad)
+                 (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
+                            ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))
+            liftIO $ putStrLn $ mname ++ " is NOT trusted!"
+
+  where
+    mname = GHC.moduleNameString $ GHC.moduleName m
+
+    packageTrusted dflags md
+        | thisPackage dflags == moduleUnitId md = True
+        | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)
+
+    tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)
+                          | otherwise = S.partition part deps
+        where part pkg = trusted $ getInstalledPackageDetails dflags pkg
+
+-----------------------------------------------------------------------------
+-- :browse
+
+-- Browsing a module's contents
+
+browseCmd :: Bool -> String -> InputT GHCi ()
+browseCmd bang m =
+  case words m of
+    ['*':s] | looksLikeModuleName s -> do
+        md <- lift $ wantInterpretedModule s
+        browseModule bang md False
+    [s] | looksLikeModuleName s -> do
+        md <- lift $ lookupModule s
+        browseModule bang md True
+    [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")
+             browseModule bang md True
+    _ -> throwGhcException (CmdLineError "syntax:  :browse <module>")
+
+guessCurrentModule :: String -> InputT GHCi Module
+-- Guess which module the user wants to browse.  Pick
+-- modules that are interpreted first.  The most
+-- recently-added module occurs last, it seems.
+guessCurrentModule cmd
+  = do imports <- GHC.getContext
+       when (null imports) $ throwGhcException $
+          CmdLineError (':' : cmd ++ ": no current module")
+       case (head imports) of
+          IIModule m -> GHC.findModule m Nothing
+          IIDecl d   -> GHC.findModule (unLoc (ideclName d))
+                                       (fmap sl_fs $ ideclPkgQual d)
+
+-- without bang, show items in context of their parents and omit children
+-- with bang, show class methods and data constructors separately, and
+--            indicate import modules, to aid qualifying unqualified names
+-- with sorted, sort items alphabetically
+browseModule :: Bool -> Module -> Bool -> InputT GHCi ()
+browseModule bang modl exports_only = do
+  -- :browse reports qualifiers wrt current context
+  unqual <- GHC.getPrintUnqual
+
+  mb_mod_info <- GHC.getModuleInfo modl
+  case mb_mod_info of
+    Nothing -> throwGhcException (CmdLineError ("unknown module: " ++
+                                GHC.moduleNameString (GHC.moduleName modl)))
+    Just mod_info -> do
+        dflags <- getDynFlags
+        let names
+               | exports_only = GHC.modInfoExports mod_info
+               | otherwise    = GHC.modInfoTopLevelScope mod_info
+                                `orElse` []
+
+                -- sort alphabetically name, but putting locally-defined
+                -- identifiers first. We would like to improve this; see #1799.
+            sorted_names = loc_sort local ++ occ_sort external
+                where
+                (local,external) = ASSERT( all isExternalName names )
+                                   partition ((==modl) . nameModule) names
+                occ_sort = sortBy (compare `on` nameOccName)
+                -- try to sort by src location. If the first name in our list
+                -- has a good source location, then they all should.
+                loc_sort ns
+                      | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)
+                      = sortBy (compare `on` nameSrcSpan) ns
+                      | otherwise
+                      = occ_sort ns
+
+        mb_things <- mapM GHC.lookupName sorted_names
+        let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
+
+        rdr_env <- GHC.getGRE
+
+        let things | bang      = catMaybes mb_things
+                   | otherwise = filtered_things
+            pretty | bang      = pprTyThing showToHeader
+                   | otherwise = pprTyThingInContext showToHeader
+
+            labels  [] = text "-- not currently imported"
+            labels  l  = text $ intercalate "\n" $ map qualifier l
+
+            qualifier :: Maybe [ModuleName] -> String
+            qualifier  = maybe "-- defined locally"
+                             (("-- imported via "++) . intercalate ", "
+                               . map GHC.moduleNameString)
+            importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env
+
+            modNames :: [[Maybe [ModuleName]]]
+            modNames   = map (importInfo . GHC.getName) things
+
+            -- annotate groups of imports with their import modules
+            -- the default ordering is somewhat arbitrary, so we group
+            -- by header and sort groups; the names themselves should
+            -- really come in order of source appearance.. (trac #1799)
+            annotate mts = concatMap (\(m,ts)->labels m:ts)
+                         $ sortBy cmpQualifiers $ grp mts
+              where cmpQualifiers =
+                      compare `on` (map (fmap (map moduleNameFS)) . fst)
+            grp []            = []
+            grp mts@((m,_):_) = (m,map snd g) : grp ng
+              where (g,ng) = partition ((==m).fst) mts
+
+        let prettyThings, prettyThings' :: [SDoc]
+            prettyThings = map pretty things
+            prettyThings' | bang      = annotate $ zip modNames prettyThings
+                          | otherwise = prettyThings
+        liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')
+        -- ToDo: modInfoInstances currently throws an exception for
+        -- package modules.  When it works, we can do this:
+        --        $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
+
+
+-----------------------------------------------------------------------------
+-- :module
+
+-- Setting the module context.  For details on context handling see
+-- "remembered_ctx" and "transient_ctx" in GhciMonad.
+
+moduleCmd :: String -> GHCi ()
+moduleCmd str
+  | all sensible strs = cmd
+  | otherwise = throwGhcException (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")
+  where
+    (cmd, strs) =
+        case str of
+          '+':stuff -> rest addModulesToContext   stuff
+          '-':stuff -> rest remModulesFromContext stuff
+          stuff     -> rest setContext            stuff
+
+    rest op stuff = (op as bs, stuffs)
+       where (as,bs) = partitionWith starred stuffs
+             stuffs  = words stuff
+
+    sensible ('*':m) = looksLikeModuleName m
+    sensible m       = looksLikeModuleName m
+
+    starred ('*':m) = Left  (GHC.mkModuleName m)
+    starred m       = Right (GHC.mkModuleName m)
+
+
+-- -----------------------------------------------------------------------------
+-- Four ways to manipulate the context:
+--   (a) :module +<stuff>:     addModulesToContext
+--   (b) :module -<stuff>:     remModulesFromContext
+--   (c) :module <stuff>:      setContext
+--   (d) import <module>...:   addImportToContext
+
+addModulesToContext :: [ModuleName] -> [ModuleName] -> GHCi ()
+addModulesToContext starred unstarred = restoreContextOnFailure $ do
+   addModulesToContext_ starred unstarred
+
+addModulesToContext_ :: [ModuleName] -> [ModuleName] -> GHCi ()
+addModulesToContext_ starred unstarred = do
+   mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)
+   setGHCContextFromGHCiState
+
+remModulesFromContext :: [ModuleName] -> [ModuleName] -> GHCi ()
+remModulesFromContext  starred unstarred = do
+   -- we do *not* call restoreContextOnFailure here.  If the user
+   -- is trying to fix up a context that contains errors by removing
+   -- modules, we don't want GHC to silently put them back in again.
+   mapM_ rm (starred ++ unstarred)
+   setGHCContextFromGHCiState
+ where
+   rm :: ModuleName -> GHCi ()
+   rm str = do
+     m <- moduleName <$> lookupModuleName str
+     let filt = filter ((/=) m . iiModuleName)
+     modifyGHCiState $ \st ->
+        st { remembered_ctx = filt (remembered_ctx st)
+           , transient_ctx  = filt (transient_ctx st) }
+
+setContext :: [ModuleName] -> [ModuleName] -> GHCi ()
+setContext starred unstarred = restoreContextOnFailure $ do
+  modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }
+                                -- delete the transient context
+  addModulesToContext_ starred unstarred
+
+addImportToContext :: String -> GHCi ()
+addImportToContext str = restoreContextOnFailure $ do
+  idecl <- GHC.parseImportDecl str
+  addII (IIDecl idecl)   -- #5836
+  setGHCContextFromGHCiState
+
+-- Util used by addImportToContext and addModulesToContext
+addII :: InteractiveImport -> GHCi ()
+addII iidecl = do
+  checkAdd iidecl
+  modifyGHCiState $ \st ->
+     st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)
+        , transient_ctx = filter (not . (iidecl `iiSubsumes`))
+                                 (transient_ctx st)
+        }
+
+-- Sometimes we can't tell whether an import is valid or not until
+-- we finally call 'GHC.setContext'.  e.g.
+--
+--   import System.IO (foo)
+--
+-- will fail because System.IO does not export foo.  In this case we
+-- don't want to store the import in the context permanently, so we
+-- catch the failure from 'setGHCContextFromGHCiState' and set the
+-- context back to what it was.
+--
+-- See #6007
+--
+restoreContextOnFailure :: GHCi a -> GHCi a
+restoreContextOnFailure do_this = do
+  st <- getGHCiState
+  let rc = remembered_ctx st; tc = transient_ctx st
+  do_this `gonException` (modifyGHCiState $ \st' ->
+     st' { remembered_ctx = rc, transient_ctx = tc })
+
+-- -----------------------------------------------------------------------------
+-- Validate a module that we want to add to the context
+
+checkAdd :: InteractiveImport -> GHCi ()
+checkAdd ii = do
+  dflags <- getDynFlags
+  let safe = safeLanguageOn dflags
+  case ii of
+    IIModule modname
+       | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"
+       | otherwise -> wantInterpretedModuleName modname >> return ()
+
+    IIDecl d -> do
+       let modname = unLoc (ideclName d)
+           pkgqual = ideclPkgQual d
+       m <- GHC.lookupModule modname (fmap sl_fs pkgqual)
+       when safe $ do
+           t <- GHC.isModuleTrusted m
+           when (not t) $ throwGhcException $ ProgramError $ ""
+
+-- -----------------------------------------------------------------------------
+-- Update the GHC API's view of the context
+
+-- | Sets the GHC context from the GHCi state.  The GHC context is
+-- always set this way, we never modify it incrementally.
+--
+-- We ignore any imports for which the ModuleName does not currently
+-- exist.  This is so that the remembered_ctx can contain imports for
+-- modules that are not currently loaded, perhaps because we just did
+-- a :reload and encountered errors.
+--
+-- Prelude is added if not already present in the list.  Therefore to
+-- override the implicit Prelude import you can say 'import Prelude ()'
+-- at the prompt, just as in Haskell source.
+--
+setGHCContextFromGHCiState :: GHCi ()
+setGHCContextFromGHCiState = do
+  st <- getGHCiState
+      -- re-use checkAdd to check whether the module is valid.  If the
+      -- module does not exist, we do *not* want to print an error
+      -- here, we just want to silently keep the module in the context
+      -- until such time as the module reappears again.  So we ignore
+      -- the actual exception thrown by checkAdd, using tryBool to
+      -- turn it into a Bool.
+  iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)
+
+  prel_iidecls <- getImplicitPreludeImports iidecls
+  valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls
+
+  extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st))
+
+  GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls
+
+
+getImplicitPreludeImports :: [InteractiveImport] -> GHCi [InteractiveImport]
+getImplicitPreludeImports iidecls = do
+  dflags <- GHC.getInteractiveDynFlags
+     -- allow :seti to override -XNoImplicitPrelude
+  st <- getGHCiState
+
+  -- We add the prelude imports if there are no *-imports, and we also
+  -- allow each prelude import to be subsumed by another explicit import
+  -- of the same module.  This means that you can override the prelude import
+  -- with "import Prelude hiding (map)", for example.
+  let prel_iidecls =
+         if xopt LangExt.ImplicitPrelude dflags && not (any isIIModule iidecls)
+            then [ IIDecl imp
+                 | imp <- prelude_imports st
+                 , not (any (sameImpModule imp) iidecls) ]
+            else []
+
+  return prel_iidecls
+
+-- -----------------------------------------------------------------------------
+-- Utils on InteractiveImport
+
+mkIIModule :: ModuleName -> InteractiveImport
+mkIIModule = IIModule
+
+mkIIDecl :: ModuleName -> InteractiveImport
+mkIIDecl = IIDecl . simpleImportDecl
+
+iiModules :: [InteractiveImport] -> [ModuleName]
+iiModules is = [m | IIModule m <- is]
+
+isIIModule :: InteractiveImport -> Bool
+isIIModule (IIModule _) = True
+isIIModule _ = False
+
+iiModuleName :: InteractiveImport -> ModuleName
+iiModuleName (IIModule m) = m
+iiModuleName (IIDecl d)   = unLoc (ideclName d)
+
+preludeModuleName :: ModuleName
+preludeModuleName = GHC.mkModuleName "Prelude"
+
+sameImpModule :: ImportDecl GhcPs -> InteractiveImport -> Bool
+sameImpModule _ (IIModule _) = False -- we only care about imports here
+sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp)
+
+addNotSubsumed :: InteractiveImport
+               -> [InteractiveImport] -> [InteractiveImport]
+addNotSubsumed i is
+  | any (`iiSubsumes` i) is = is
+  | otherwise               = i : filter (not . (i `iiSubsumes`)) is
+
+-- | @filterSubsumed is js@ returns the elements of @js@ not subsumed
+-- by any of @is@.
+filterSubsumed :: [InteractiveImport] -> [InteractiveImport]
+               -> [InteractiveImport]
+filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js
+
+-- | Returns True if the left import subsumes the right one.  Doesn't
+-- need to be 100% accurate, conservatively returning False is fine.
+-- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in
+-- plusProv will ensue (#5904))
+--
+-- Note that an IIModule does not necessarily subsume an IIDecl,
+-- because e.g. a module might export a name that is only available
+-- qualified within the module itself.
+--
+-- Note that 'import M' does not necessarily subsume 'import M(foo)',
+-- because M might not export foo and we want an error to be produced
+-- in that case.
+--
+iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool
+iiSubsumes (IIModule m1) (IIModule m2) = m1==m2
+iiSubsumes (IIDecl d1) (IIDecl d2)      -- A bit crude
+  =  unLoc (ideclName d1) == unLoc (ideclName d2)
+     && ideclAs d1 == ideclAs d2
+     && (not (ideclQualified d1) || ideclQualified d2)
+     && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)
+  where
+     _                    `hidingSubsumes` Just (False,L _ []) = True
+     Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)
+                                                           = all (`elem` xs) ys
+     h1                   `hidingSubsumes` h2              = h1 == h2
+iiSubsumes _ _ = False
+
+
+----------------------------------------------------------------------------
+-- :set
+
+-- set options in the interpreter.  Syntax is exactly the same as the
+-- ghc command line, except that certain options aren't available (-C,
+-- -E etc.)
+--
+-- This is pretty fragile: most options won't work as expected.  ToDo:
+-- figure out which ones & disallow them.
+
+setCmd :: String -> GHCi ()
+setCmd ""   = showOptions False
+setCmd "-a" = showOptions True
+setCmd str
+  = case getCmd str of
+    Right ("args",    rest) ->
+        case toArgs rest of
+            Left err -> liftIO (hPutStrLn stderr err)
+            Right args -> setArgs args
+    Right ("prog",    rest) ->
+        case toArgs rest of
+            Right [prog] -> setProg prog
+            _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")
+
+    Right ("prompt",           rest) ->
+        setPromptString setPrompt (dropWhile isSpace rest)
+                        "syntax: set prompt <string>"
+    Right ("prompt-function",  rest) ->
+        setPromptFunc setPrompt $ dropWhile isSpace rest
+    Right ("prompt-cont",          rest) ->
+        setPromptString setPromptCont (dropWhile isSpace rest)
+                        "syntax: :set prompt-cont <string>"
+    Right ("prompt-cont-function", rest) ->
+        setPromptFunc setPromptCont $ dropWhile isSpace rest
+
+    Right ("editor",  rest) -> setEditor  $ dropWhile isSpace rest
+    Right ("stop",    rest) -> setStop    $ dropWhile isSpace rest
+    _ -> case toArgs str of
+         Left err -> liftIO (hPutStrLn stderr err)
+         Right wds -> setOptions wds
+
+setiCmd :: String -> GHCi ()
+setiCmd ""   = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False
+setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True
+setiCmd str  =
+  case toArgs str of
+    Left err -> liftIO (hPutStrLn stderr err)
+    Right wds -> newDynFlags True wds
+
+showOptions :: Bool -> GHCi ()
+showOptions show_all
+  = do st <- getGHCiState
+       dflags <- getDynFlags
+       let opts = options st
+       liftIO $ putStrLn (showSDoc dflags (
+              text "options currently set: " <>
+              if null opts
+                   then text "none."
+                   else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
+           ))
+       getDynFlags >>= liftIO . showDynFlags show_all
+
+
+showDynFlags :: Bool -> DynFlags -> IO ()
+showDynFlags show_all dflags = do
+  showLanguages' show_all dflags
+  putStrLn $ showSDoc dflags $
+     text "GHCi-specific dynamic flag settings:" $$
+         nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))
+  putStrLn $ showSDoc dflags $
+     text "other dynamic, non-language, flag settings:" $$
+         nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))
+  putStrLn $ showSDoc dflags $
+     text "warning settings:" $$
+         nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))
+  where
+        setting prefix noPrefix test flag
+          | quiet     = empty
+          | is_on     = text prefix <> text name
+          | otherwise = text noPrefix <> text name
+          where name = flagSpecName flag
+                f = flagSpecFlag flag
+                is_on = test f dflags
+                quiet = not show_all && test f default_dflags == is_on
+
+        llvmConfig = (llvmTargets dflags, llvmPasses dflags)
+
+        default_dflags = defaultDynFlags (settings dflags) llvmConfig
+
+        (ghciFlags,others)  = partition (\f -> flagSpecFlag f `elem` flgs)
+                                        DynFlags.fFlags
+        flgs = [ Opt_PrintExplicitForalls
+               , Opt_PrintExplicitKinds
+               , Opt_PrintUnicodeSyntax
+               , Opt_PrintBindResult
+               , Opt_BreakOnException
+               , Opt_BreakOnError
+               , Opt_PrintEvldWithShow
+               ]
+
+setArgs, setOptions :: [String] -> GHCi ()
+setProg, setEditor, setStop :: String -> GHCi ()
+
+setArgs args = do
+  st <- getGHCiState
+  wrapper <- mkEvalWrapper (progname st) args
+  setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }
+
+setProg prog = do
+  st <- getGHCiState
+  wrapper <- mkEvalWrapper prog (GhciMonad.args st)
+  setGHCiState st { progname = prog, evalWrapper = wrapper }
+
+setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })
+
+setStop str@(c:_) | isDigit c
+  = do let (nm_str,rest) = break (not.isDigit) str
+           nm = read nm_str
+       st <- getGHCiState
+       let old_breaks = breaks st
+       if all ((/= nm) . fst) old_breaks
+              then printForUser (text "Breakpoint" <+> ppr nm <+>
+                                 text "does not exist")
+              else do
+       let new_breaks = map fn old_breaks
+           fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })
+                      | otherwise = (i,loc)
+       setGHCiState st{ breaks = new_breaks }
+setStop cmd = modifyGHCiState (\st -> st { stop = cmd })
+
+setPrompt :: PromptFunction -> GHCi ()
+setPrompt v = modifyGHCiState (\st -> st {prompt = v})
+
+setPromptCont :: PromptFunction -> GHCi ()
+setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})
+
+setPromptFunc :: (PromptFunction -> GHCi ()) -> String -> GHCi ()
+setPromptFunc fSetPrompt s = do
+    -- We explicitly annotate the type of the expression to ensure
+    -- that unsafeCoerce# is passed the exact type necessary rather
+    -- than a more general one
+    let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String"
+    (HValue funValue) <- GHC.compileExpr exprStr
+    fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue)
+    where
+      convertToPromptFunction :: ([String] -> Int -> IO String)
+                              -> PromptFunction
+      convertToPromptFunction func = (\mods line -> liftIO $
+                                       liftM text (func mods line))
+
+setPromptString :: (PromptFunction -> GHCi ()) -> String -> String -> GHCi ()
+setPromptString fSetPrompt value err = do
+  if null value
+    then liftIO $ hPutStrLn stderr $ err
+    else case value of
+           ('\"':_) ->
+             case reads value of
+               [(value', xs)] | all isSpace xs ->
+                 setParsedPromptString fSetPrompt value'
+               _ -> liftIO $ hPutStrLn stderr
+                             "Can't parse prompt string. Use Haskell syntax."
+           _ ->
+             setParsedPromptString fSetPrompt value
+
+setParsedPromptString :: (PromptFunction -> GHCi ()) ->  String -> GHCi ()
+setParsedPromptString fSetPrompt s = do
+  case (checkPromptStringForErrors s) of
+    Just err ->
+      liftIO $ hPutStrLn stderr err
+    Nothing ->
+      fSetPrompt $ generatePromptFunctionFromString s
+
+setOptions wds =
+   do -- first, deal with the GHCi opts (+s, +t, etc.)
+      let (plus_opts, minus_opts)  = partitionWith isPlus wds
+      mapM_ setOpt plus_opts
+      -- then, dynamic flags
+      when (not (null minus_opts)) $ newDynFlags False minus_opts
+
+newDynFlags :: Bool -> [String] -> GHCi ()
+newDynFlags interactive_only minus_opts = do
+      let lopts = map noLoc minus_opts
+
+      idflags0 <- GHC.getInteractiveDynFlags
+      (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts
+
+      liftIO $ handleFlagWarnings idflags1 warns
+      when (not $ null leftovers)
+           (throwGhcException . CmdLineError
+            $ "Some flags have not been recognized: "
+            ++ (concat . intersperse ", " $ map unLoc leftovers))
+
+      when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do
+          liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
+      -- Load any new plugins
+      hsc_env0 <- GHC.getSession
+      idflags2 <- liftIO (initializePlugins hsc_env0 idflags1)
+      GHC.setInteractiveDynFlags idflags2
+      installInteractivePrint (interactivePrint idflags1) False
+
+      dflags0 <- getDynFlags
+
+      when (not interactive_only) $ do
+        (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts
+        new_pkgs <- GHC.setProgramDynFlags dflags1
+
+        -- if the package flags changed, reset the context and link
+        -- the new packages.
+        hsc_env <- GHC.getSession
+        let dflags2 = hsc_dflags hsc_env
+        when (packageFlagsChanged dflags2 dflags0) $ do
+          when (verbosity dflags2 > 0) $
+            liftIO . putStrLn $
+              "package flags have changed, resetting and loading new packages..."
+          GHC.setTargets []
+          _ <- GHC.load LoadAllTargets
+          liftIO $ linkPackages hsc_env new_pkgs
+          -- package flags changed, we can't re-use any of the old context
+          setContextAfterLoad False []
+          -- and copy the package state to the interactive DynFlags
+          idflags <- GHC.getInteractiveDynFlags
+          GHC.setInteractiveDynFlags
+              idflags{ pkgState = pkgState dflags2
+                     , pkgDatabase = pkgDatabase dflags2
+                     , packageFlags = packageFlags dflags2 }
+
+        let ld0length   = length $ ldInputs dflags0
+            fmrk0length = length $ cmdlineFrameworks dflags0
+
+            newLdInputs     = drop ld0length (ldInputs dflags2)
+            newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)
+
+            hsc_env' = hsc_env { hsc_dflags =
+                         dflags2 { ldInputs = newLdInputs
+                                 , cmdlineFrameworks = newCLFrameworks } }
+
+        when (not (null newLdInputs && null newCLFrameworks)) $
+          liftIO $ linkCmdLineLibs hsc_env'
+
+      return ()
+
+
+unsetOptions :: String -> GHCi ()
+unsetOptions str
+  =   -- first, deal with the GHCi opts (+s, +t, etc.)
+     let opts = words str
+         (minus_opts, rest1) = partition isMinus opts
+         (plus_opts, rest2)  = partitionWith isPlus rest1
+         (other_opts, rest3) = partition (`elem` map fst defaulters) rest2
+
+         defaulters =
+           [ ("args"   , setArgs default_args)
+           , ("prog"   , setProg default_progname)
+           , ("prompt"     , setPrompt default_prompt)
+           , ("prompt-cont", setPromptCont default_prompt_cont)
+           , ("editor" , liftIO findEditor >>= setEditor)
+           , ("stop"   , setStop default_stop)
+           ]
+
+         no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
+         no_flag ('-':'X':rest) = return ("-XNo" ++ rest)
+         no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))
+
+     in if (not (null rest3))
+           then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))
+           else do
+             mapM_ (fromJust.flip lookup defaulters) other_opts
+
+             mapM_ unsetOpt plus_opts
+
+             no_flags <- mapM no_flag minus_opts
+             when (not (null no_flags)) $ newDynFlags False no_flags
+
+isMinus :: String -> Bool
+isMinus ('-':_) = True
+isMinus _ = False
+
+isPlus :: String -> Either String String
+isPlus ('+':opt) = Left opt
+isPlus other     = Right other
+
+setOpt, unsetOpt :: String -> GHCi ()
+
+setOpt str
+  = case strToGHCiOpt str of
+        Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
+        Just o  -> setOption o
+
+unsetOpt str
+  = case strToGHCiOpt str of
+        Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))
+        Just o  -> unsetOption o
+
+strToGHCiOpt :: String -> (Maybe GHCiOption)
+strToGHCiOpt "m" = Just Multiline
+strToGHCiOpt "s" = Just ShowTiming
+strToGHCiOpt "t" = Just ShowType
+strToGHCiOpt "r" = Just RevertCAFs
+strToGHCiOpt "c" = Just CollectInfo
+strToGHCiOpt _   = Nothing
+
+optToStr :: GHCiOption -> String
+optToStr Multiline  = "m"
+optToStr ShowTiming = "s"
+optToStr ShowType   = "t"
+optToStr RevertCAFs = "r"
+optToStr CollectInfo = "c"
+
+
+-- ---------------------------------------------------------------------------
+-- :show
+
+showCmd :: String -> GHCi ()
+showCmd ""   = showOptions False
+showCmd "-a" = showOptions True
+showCmd str = do
+    st <- getGHCiState
+    dflags <- getDynFlags
+
+    let lookupCmd :: String -> Maybe (GHCi ())
+        lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds
+
+        -- (show in help?, command name, action)
+        action :: String -> GHCi () -> (Bool, String, GHCi ())
+        action name m = (True, name, m)
+
+        hidden :: String -> GHCi () -> (Bool, String, GHCi ())
+        hidden name m = (False, name, m)
+
+        cmds =
+            [ action "args"       $ liftIO $ putStrLn (show (GhciMonad.args st))
+            , action "prog"       $ liftIO $ putStrLn (show (progname st))
+            , action "editor"     $ liftIO $ putStrLn (show (editor st))
+            , action "stop"       $ liftIO $ putStrLn (show (stop st))
+            , action "imports"    $ showImports
+            , action "modules"    $ showModules
+            , action "bindings"   $ showBindings
+            , action "linker"     $ getDynFlags >>= liftIO . showLinkerState
+            , action "breaks"     $ showBkptTable
+            , action "context"    $ showContext
+            , action "packages"   $ showPackages
+            , action "paths"      $ showPaths
+            , action "language"   $ showLanguages
+            , hidden "languages"  $ showLanguages -- backwards compat
+            , hidden "lang"       $ showLanguages -- useful abbreviation
+            , action "targets"    $ showTargets
+            ]
+
+    case words str of
+      [w] | Just action <- lookupCmd w -> action
+
+      _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]
+           in throwGhcException $ CmdLineError $ showSDoc dflags
+              $ hang (text "syntax:") 4
+              $ hang (text ":show") 6
+              $ brackets (fsep $ punctuate (text " |") helpCmds)
+
+showiCmd :: String -> GHCi ()
+showiCmd str = do
+  case words str of
+        ["languages"]  -> showiLanguages -- backwards compat
+        ["language"]   -> showiLanguages
+        ["lang"]       -> showiLanguages -- useful abbreviation
+        _ -> throwGhcException (CmdLineError ("syntax:  :showi language"))
+
+showImports :: GHCi ()
+showImports = do
+  st <- getGHCiState
+  dflags <- getDynFlags
+  let rem_ctx   = reverse (remembered_ctx st)
+      trans_ctx = transient_ctx st
+
+      show_one (IIModule star_m)
+          = ":module +*" ++ moduleNameString star_m
+      show_one (IIDecl imp) = showPpr dflags imp
+
+  prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)
+
+  let show_prel p = show_one p ++ " -- implicit"
+      show_extra p = show_one (IIDecl p) ++ " -- fixed"
+
+      trans_comment s = s ++ " -- added automatically" :: String
+  --
+  liftIO $ mapM_ putStrLn (map show_one rem_ctx ++
+                           map (trans_comment . show_one) trans_ctx ++
+                           map show_prel prel_iidecls ++
+                           map show_extra (extra_imports st))
+
+showModules :: GHCi ()
+showModules = do
+  loaded_mods <- getLoadedModules
+        -- we want *loaded* modules only, see #1734
+  let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)
+  mapM_ show_one loaded_mods
+
+getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]
+getLoadedModules = do
+  graph <- GHC.getModuleGraph
+  filterM (GHC.isLoaded . GHC.ms_mod_name) (GHC.mgModSummaries graph)
+
+showBindings :: GHCi ()
+showBindings = do
+    bindings <- GHC.getBindings
+    (insts, finsts) <- GHC.getInsts
+    let idocs  = map GHC.pprInstanceHdr insts
+        fidocs = map GHC.pprFamInst finsts
+        binds = filter (not . isDerivedOccName . getOccName) bindings -- #12525
+        -- See Note [Filter bindings]
+    docs <- mapM makeDoc (reverse binds)
+                  -- reverse so the new ones come last
+    mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)
+  where
+    makeDoc (AnId i) = pprTypeAndContents i
+    makeDoc tt = do
+        mb_stuff <- GHC.getInfo False (getName tt)
+        return $ maybe (text "") pprTT mb_stuff
+
+    pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc
+    pprTT (thing, fixity, _cls_insts, _fam_insts, _docs)
+      = pprTyThing showToHeader thing
+        $$ show_fixity
+      where
+        show_fixity
+            | fixity == GHC.defaultFixity  = empty
+            | otherwise                    = ppr fixity <+> ppr (GHC.getName thing)
+
+
+printTyThing :: TyThing -> GHCi ()
+printTyThing tyth = printForUser (pprTyThing showToHeader tyth)
+
+{-
+Note [Filter bindings]
+~~~~~~~~~~~~~~~~~~~~~~
+
+If we don't filter the bindings returned by the function GHC.getBindings,
+then the :show bindings command will also show unwanted bound names,
+internally generated by GHC, eg:
+    $tcFoo :: GHC.Types.TyCon = _
+    $trModule :: GHC.Types.Module = _ .
+
+The filter was introduced as a fix for Trac #12525 [1]. Comment:1 [2] to this
+ticket contains an analysis of the situation and suggests the solution
+implemented above.
+
+The same filter was also implemented to fix Trac #11051 [3]. See the
+Note [What to show to users] in compiler/main/InteractiveEval.hs
+
+[1] https://ghc.haskell.org/trac/ghc/ticket/12525
+[2] https://ghc.haskell.org/trac/ghc/ticket/12525#comment:1
+[3] https://ghc.haskell.org/trac/ghc/ticket/11051
+-}
+
+
+showBkptTable :: GHCi ()
+showBkptTable = do
+  st <- getGHCiState
+  printForUser $ prettyLocations (breaks st)
+
+showContext :: GHCi ()
+showContext = do
+   resumes <- GHC.getResumeContext
+   printForUser $ vcat (map pp_resume (reverse resumes))
+  where
+   pp_resume res =
+        ptext (sLit "--> ") <> text (GHC.resumeStmt res)
+        $$ nest 2 (pprStopped res)
+
+pprStopped :: GHC.Resume -> SDoc
+pprStopped res =
+  ptext (sLit "Stopped in")
+    <+> ((case mb_mod_name of
+           Nothing -> empty
+           Just mod_name -> text (moduleNameString mod_name) <> char '.')
+         <> text (GHC.resumeDecl res))
+    <> char ',' <+> ppr (GHC.resumeSpan res)
+ where
+  mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res
+
+showPackages :: GHCi ()
+showPackages = do
+  dflags <- getDynFlags
+  let pkg_flags = packageFlags dflags
+  liftIO $ putStrLn $ showSDoc dflags $
+    text ("active package flags:"++if null pkg_flags then " none" else "") $$
+      nest 2 (vcat (map pprFlag pkg_flags))
+
+showPaths :: GHCi ()
+showPaths = do
+  dflags <- getDynFlags
+  liftIO $ do
+    cwd <- getCurrentDirectory
+    putStrLn $ showSDoc dflags $
+      text "current working directory: " $$
+        nest 2 (text cwd)
+    let ipaths = importPaths dflags
+    putStrLn $ showSDoc dflags $
+      text ("module import search paths:"++if null ipaths then " none" else "") $$
+        nest 2 (vcat (map text ipaths))
+
+showLanguages :: GHCi ()
+showLanguages = getDynFlags >>= liftIO . showLanguages' False
+
+showiLanguages :: GHCi ()
+showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False
+
+showLanguages' :: Bool -> DynFlags -> IO ()
+showLanguages' show_all dflags =
+  putStrLn $ showSDoc dflags $ vcat
+     [ text "base language is: " <>
+         case language dflags of
+           Nothing          -> text "Haskell2010"
+           Just Haskell98   -> text "Haskell98"
+           Just Haskell2010 -> text "Haskell2010"
+     , (if show_all then text "all active language options:"
+                    else text "with the following modifiers:") $$
+          nest 2 (vcat (map (setting xopt) DynFlags.xFlags))
+     ]
+  where
+   setting test flag
+          | quiet     = empty
+          | is_on     = text "-X" <> text name
+          | otherwise = text "-XNo" <> text name
+          where name = flagSpecName flag
+                f = flagSpecFlag flag
+                is_on = test f dflags
+                quiet = not show_all && test f default_dflags == is_on
+
+   llvmConfig = (llvmTargets dflags, llvmPasses dflags)
+
+   default_dflags =
+       defaultDynFlags (settings dflags) llvmConfig `lang_set`
+         case language dflags of
+           Nothing -> Just Haskell2010
+           other   -> other
+
+showTargets :: GHCi ()
+showTargets = mapM_ showTarget =<< GHC.getTargets
+  where
+    showTarget :: Target -> GHCi ()
+    showTarget (Target (TargetFile f _) _ _) = liftIO (putStrLn f)
+    showTarget (Target (TargetModule m) _ _) =
+      liftIO (putStrLn $ moduleNameString m)
+
+-- -----------------------------------------------------------------------------
+-- Completion
+
+completeCmd :: String -> GHCi ()
+completeCmd argLine0 = case parseLine argLine0 of
+    Just ("repl", resultRange, left) -> do
+        (unusedLine,compls) <- ghciCompleteWord (reverse left,"")
+        let compls' = takeRange resultRange compls
+        liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]
+        forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do
+            liftIO $ print r
+    _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")
+  where
+    parseLine argLine
+        | null argLine = Nothing
+        | null rest1   = Nothing
+        | otherwise    = (,,) dom <$> resRange <*> s
+      where
+        (dom, rest1) = breakSpace argLine
+        (rng, rest2) = breakSpace rest1
+        resRange | head rest1 == '"' = parseRange ""
+                 | otherwise         = parseRange rng
+        s | head rest1 == '"' = readMaybe rest1 :: Maybe String
+          | otherwise         = readMaybe rest2
+        breakSpace = fmap (dropWhile isSpace) . break isSpace
+
+    takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub
+
+    -- syntax: [n-][m] with semantics "drop (n-1) . take m"
+    parseRange :: String -> Maybe (Maybe Int,Maybe Int)
+    parseRange s = case span isDigit s of
+                   (_, "") ->
+                       -- upper limit only
+                       Just (Nothing, bndRead s)
+                   (s1, '-' : s2)
+                    | all isDigit s2 ->
+                       Just (bndRead s1, bndRead s2)
+                   _ ->
+                       Nothing
+      where
+        bndRead x = if null x then Nothing else Just (read x)
+
+
+
+completeGhciCommand, completeMacro, completeIdentifier, completeModule,
+    completeSetModule, completeSeti, completeShowiOptions,
+    completeHomeModule, completeSetOptions, completeShowOptions,
+    completeHomeModuleOrFile, completeExpression
+    :: CompletionFunc GHCi
+
+-- | Provide completions for last word in a given string.
+--
+-- Takes a tuple of two strings.  First string is a reversed line to be
+-- completed.  Second string is likely unused, 'completeCmd' always passes an
+-- empty string as second item in tuple.
+ghciCompleteWord :: CompletionFunc GHCi
+ghciCompleteWord line@(left,_) = case firstWord of
+    -- If given string starts with `:` colon, and there is only one following
+    -- word then provide REPL command completions.  If there is more than one
+    -- word complete either filename or builtin ghci commands or macros.
+    ':':cmd     | null rest     -> completeGhciCommand line
+                | otherwise     -> do
+                        completion <- lookupCompletion cmd
+                        completion line
+    -- If given string starts with `import` keyword provide module name
+    -- completions
+    "import"    -> completeModule line
+    -- otherwise provide identifier completions
+    _           -> completeExpression line
+  where
+    (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left
+    lookupCompletion ('!':_) = return completeFilename
+    lookupCompletion c = do
+        maybe_cmd <- lookupCommand' c
+        case maybe_cmd of
+            Just cmd -> return (cmdCompletionFunc cmd)
+            Nothing  -> return completeFilename
+
+completeGhciCommand = wrapCompleter " " $ \w -> do
+  macros <- ghci_macros <$> getGHCiState
+  cmds   <- ghci_commands `fmap` getGHCiState
+  let macro_names = map (':':) . map cmdName $ macros
+  let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds
+  let{ candidates = case w of
+      ':' : ':' : _ -> map (':':) command_names
+      _ -> nub $ macro_names ++ command_names }
+  return $ filter (w `isPrefixOf`) candidates
+
+completeMacro = wrapIdentCompleter $ \w -> do
+  cmds <- ghci_macros <$> getGHCiState
+  return (filter (w `isPrefixOf`) (map cmdName cmds))
+
+completeIdentifier line@(left, _) =
+  -- Note: `left` is a reversed input
+  case left of
+    (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line
+    _                      -> wrapIdentCompleter complete line
+  where
+    complete w = do
+      rdrs <- GHC.getRdrNamesInScope
+      dflags <- GHC.getSessionDynFlags
+      return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))
+
+completeModule = wrapIdentCompleter $ \w -> do
+  dflags <- GHC.getSessionDynFlags
+  let pkg_mods = allVisibleModules dflags
+  loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
+  return $ filter (w `isPrefixOf`)
+        $ map (showPpr dflags) $ loaded_mods ++ pkg_mods
+
+completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
+  dflags <- GHC.getSessionDynFlags
+  modules <- case m of
+    Just '-' -> do
+      imports <- GHC.getContext
+      return $ map iiModuleName imports
+    _ -> do
+      let pkg_mods = allVisibleModules dflags
+      loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
+      return $ loaded_mods ++ pkg_mods
+  return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules
+
+completeHomeModule = wrapIdentCompleter listHomeModules
+
+listHomeModules :: String -> GHCi [String]
+listHomeModules w = do
+    g <- GHC.getModuleGraph
+    let home_mods = map GHC.ms_mod_name (GHC.mgModSummaries g)
+    dflags <- getDynFlags
+    return $ sort $ filter (w `isPrefixOf`)
+            $ map (showPpr dflags) home_mods
+
+completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do
+  return (filter (w `isPrefixOf`) opts)
+    where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":
+                 "prompt-cont-function":"editor":"stop":flagList
+          flagList = map head $ group $ sort allNonDeprecatedFlags
+
+completeSeti = wrapCompleter flagWordBreakChars $ \w -> do
+  return (filter (w `isPrefixOf`) flagList)
+    where flagList = map head $ group $ sort allNonDeprecatedFlags
+
+completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do
+  return (filter (w `isPrefixOf`) opts)
+    where opts = ["args", "prog", "editor", "stop",
+                     "modules", "bindings", "linker", "breaks",
+                     "context", "packages", "paths", "language", "imports"]
+
+completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do
+  return (filter (w `isPrefixOf`) ["language"])
+
+completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars
+                $ unionComplete (fmap (map simpleCompletion) . listHomeModules)
+                            listFiles
+
+unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
+unionComplete f1 f2 line = do
+  cs1 <- f1 line
+  cs2 <- f2 line
+  return (cs1 ++ cs2)
+
+wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi
+wrapCompleter breakChars fun = completeWord Nothing breakChars
+    $ fmap (map simpleCompletion . nubSort) . fun
+
+wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi
+wrapIdentCompleter = wrapCompleter word_break_chars
+
+wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi
+wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars
+    $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)
+ where
+  getModifier = find (`elem` modifChars)
+
+-- | Return a list of visible module names for autocompletion.
+-- (NB: exposed != visible)
+allVisibleModules :: DynFlags -> [ModuleName]
+allVisibleModules dflags = listVisibleModuleNames dflags
+
+completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
+                        completeIdentifier
+
+
+-- -----------------------------------------------------------------------------
+-- commands for debugger
+
+sprintCmd, printCmd, forceCmd :: String -> GHCi ()
+sprintCmd = pprintCommand False False
+printCmd  = pprintCommand True False
+forceCmd  = pprintCommand False True
+
+pprintCommand :: Bool -> Bool -> String -> GHCi ()
+pprintCommand bind force str = do
+  pprintClosureCommand bind force str
+
+stepCmd :: String -> GHCi ()
+stepCmd arg = withSandboxOnly ":step" $ step arg
+  where
+  step []         = doContinue (const True) GHC.SingleStep
+  step expression = runStmt expression GHC.SingleStep >> return ()
+
+stepLocalCmd :: String -> GHCi ()
+stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
+  where
+  step expr
+   | not (null expr) = stepCmd expr
+   | otherwise = do
+      mb_span <- getCurrentBreakSpan
+      case mb_span of
+        Nothing  -> stepCmd []
+        Just loc -> do
+           md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule
+           current_toplevel_decl <- enclosingTickSpan md loc
+           doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep
+
+stepModuleCmd :: String -> GHCi ()
+stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
+  where
+  step expr
+   | not (null expr) = stepCmd expr
+   | otherwise = do
+      mb_span <- getCurrentBreakSpan
+      case mb_span of
+        Nothing  -> stepCmd []
+        Just pan -> do
+           let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span
+           doContinue f GHC.SingleStep
+
+-- | Returns the span of the largest tick containing the srcspan given
+enclosingTickSpan :: Module -> SrcSpan -> GHCi RealSrcSpan
+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"
+enclosingTickSpan md (RealSrcSpan src) = do
+  ticks <- getTickArray md
+  let line = srcSpanStartLine src
+  ASSERT(inRange (bounds ticks) line) do
+  let enclosing_spans = [ pan | (_,pan) <- ticks ! line
+                               , realSrcSpanEnd pan >= realSrcSpanEnd src]
+  return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans
+ where
+
+leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
+leftmostLargestRealSrcSpan a b =
+  (realSrcSpanStart a `compare` realSrcSpanStart b)
+     `thenCmp`
+  (realSrcSpanEnd b `compare` realSrcSpanEnd a)
+
+traceCmd :: String -> GHCi ()
+traceCmd arg
+  = withSandboxOnly ":trace" $ tr arg
+  where
+  tr []         = doContinue (const True) GHC.RunAndLogSteps
+  tr expression = runStmt expression GHC.RunAndLogSteps >> return ()
+
+continueCmd :: String -> GHCi ()
+continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion
+
+-- doContinue :: SingleStep -> GHCi ()
+doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
+doContinue pre step = do
+  runResult <- resume pre step
+  _ <- afterRunStmt pre runResult
+  return ()
+
+abandonCmd :: String -> GHCi ()
+abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do
+  b <- GHC.abandon -- the prompt will change to indicate the new context
+  when (not b) $ liftIO $ putStrLn "There is no computation running."
+
+deleteCmd :: String -> GHCi ()
+deleteCmd argLine = withSandboxOnly ":delete" $ do
+   deleteSwitch $ words argLine
+   where
+   deleteSwitch :: [String] -> GHCi ()
+   deleteSwitch [] =
+      liftIO $ putStrLn "The delete command requires at least one argument."
+   -- delete all break points
+   deleteSwitch ("*":_rest) = discardActiveBreakPoints
+   deleteSwitch idents = do
+      mapM_ deleteOneBreak idents
+      where
+      deleteOneBreak :: String -> GHCi ()
+      deleteOneBreak str
+         | all isDigit str = deleteBreak (read str)
+         | otherwise = return ()
+
+historyCmd :: String -> GHCi ()
+historyCmd arg
+  | null arg        = history 20
+  | all isDigit arg = history (read arg)
+  | otherwise       = liftIO $ putStrLn "Syntax:  :history [num]"
+  where
+  history num = do
+    resumes <- GHC.getResumeContext
+    case resumes of
+      [] -> liftIO $ putStrLn "Not stopped at a breakpoint"
+      (r:_) -> do
+        let hist = GHC.resumeHistory r
+            (took,rest) = splitAt num hist
+        case hist of
+          [] -> liftIO $ putStrLn $
+                   "Empty history. Perhaps you forgot to use :trace?"
+          _  -> do
+                 pans <- mapM GHC.getHistorySpan took
+                 let nums  = map (printf "-%-3d:") [(1::Int)..]
+                     names = map GHC.historyEnclosingDecls took
+                 printForUser (vcat(zipWith3
+                                 (\x y z -> x <+> y <+> z)
+                                 (map text nums)
+                                 (map (bold . hcat . punctuate colon . map text) names)
+                                 (map (parens . ppr) pans)))
+                 liftIO $ putStrLn $ if null rest then "<end of history>" else "..."
+
+bold :: SDoc -> SDoc
+bold c | do_bold   = text start_bold <> c <> text end_bold
+       | otherwise = c
+
+backCmd :: String -> GHCi ()
+backCmd arg
+  | null arg        = back 1
+  | all isDigit arg = back (read arg)
+  | otherwise       = liftIO $ putStrLn "Syntax:  :back [num]"
+  where
+  back num = withSandboxOnly ":back" $ do
+      (names, _, pan, _) <- GHC.back num
+      printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan
+      printTypeOfNames names
+       -- run the command set with ":set stop <cmd>"
+      st <- getGHCiState
+      enqueueCommands [stop st]
+
+forwardCmd :: String -> GHCi ()
+forwardCmd arg
+  | null arg        = forward 1
+  | all isDigit arg = forward (read arg)
+  | otherwise       = liftIO $ putStrLn "Syntax:  :back [num]"
+  where
+  forward num = withSandboxOnly ":forward" $ do
+      (names, ix, pan, _) <- GHC.forward num
+      printForUser $ (if (ix == 0)
+                        then ptext (sLit "Stopped at")
+                        else ptext (sLit "Logged breakpoint at")) <+> ppr pan
+      printTypeOfNames names
+       -- run the command set with ":set stop <cmd>"
+      st <- getGHCiState
+      enqueueCommands [stop st]
+
+-- handle the "break" command
+breakCmd :: String -> GHCi ()
+breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine
+
+breakSwitch :: [String] -> GHCi ()
+breakSwitch [] = do
+   liftIO $ putStrLn "The break command requires at least one argument."
+breakSwitch (arg1:rest)
+   | looksLikeModuleName arg1 && not (null rest) = do
+        md <- wantInterpretedModule arg1
+        breakByModule md rest
+   | all isDigit arg1 = do
+        imports <- GHC.getContext
+        case iiModules imports of
+           (mn : _) -> do
+              md <- lookupModuleName mn
+              breakByModuleLine md (read arg1) rest
+           [] -> do
+              liftIO $ putStrLn "No modules are loaded with debugging support."
+   | otherwise = do -- try parsing it as an identifier
+        wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
+        maybe_info <- GHC.getModuleInfo (GHC.nameModule name)
+        case maybe_info of
+          Nothing -> noCanDo name (ptext (sLit "cannot get module info"))
+          Just minf ->
+               ASSERT( isExternalName name )
+                    findBreakAndSet (GHC.nameModule name) $
+                       findBreakForBind name (GHC.modInfoModBreaks minf)
+       where
+          noCanDo n why = printForUser $
+                text "cannot set breakpoint on " <> ppr n <> text ": " <> why
+
+breakByModule :: Module -> [String] -> GHCi ()
+breakByModule md (arg1:rest)
+   | all isDigit arg1 = do  -- looks like a line number
+        breakByModuleLine md (read arg1) rest
+breakByModule _ _
+   = breakSyntax
+
+breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
+breakByModuleLine md line args
+   | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line
+   | [col] <- args, all isDigit col =
+        findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)
+   | otherwise = breakSyntax
+
+breakSyntax :: a
+breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
+
+findBreakAndSet :: Module -> (TickArray -> [(Int, RealSrcSpan)]) -> GHCi ()
+findBreakAndSet md lookupTickTree = do
+   tickArray <- getTickArray md
+   (breakArray, _) <- getModBreak md
+   case lookupTickTree tickArray of
+      []  -> liftIO $ putStrLn $ "No breakpoints found at that location."
+      some -> mapM_ (breakAt breakArray) some
+ where
+   breakAt breakArray (tick, pan) = do
+         setBreakFlag True breakArray tick
+         (alreadySet, nm) <-
+               recordBreak $ BreakLocation
+                       { breakModule = md
+                       , breakLoc = RealSrcSpan pan
+                       , breakTick = tick
+                       , onBreakCmd = ""
+                       }
+         printForUser $
+            text "Breakpoint " <> ppr nm <>
+            if alreadySet
+               then text " was already set at " <> ppr pan
+               else text " activated at " <> ppr pan
+
+-- When a line number is specified, the current policy for choosing
+-- the best breakpoint is this:
+--    - the leftmost complete subexpression on the specified line, or
+--    - the leftmost subexpression starting on the specified line, or
+--    - the rightmost subexpression enclosing the specified line
+--
+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)
+findBreakByLine line arr
+  | not (inRange (bounds arr) line) = Nothing
+  | otherwise =
+    listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd)  comp)   `mplus`
+    listToMaybe (sortBy (compare `on` snd) incomp) `mplus`
+    listToMaybe (sortBy (flip compare `on` snd) ticks)
+  where
+        ticks = arr ! line
+
+        starts_here = [ (ix,pan) | (ix, pan) <- ticks,
+                        GHC.srcSpanStartLine pan == line ]
+
+        (comp, incomp) = partition ends_here starts_here
+            where ends_here (_,pan) = GHC.srcSpanEndLine pan == line
+
+-- The aim is to find the breakpoints for all the RHSs of the
+-- equations corresponding to a binding.  So we find all breakpoints
+-- for
+--   (a) this binder only (not a nested declaration)
+--   (b) that do not have an enclosing breakpoint
+findBreakForBind :: Name -> GHC.ModBreaks -> TickArray
+                 -> [(BreakIndex,RealSrcSpan)]
+findBreakForBind name modbreaks _ = filter (not . enclosed) ticks
+  where
+    ticks = [ (index, span)
+            | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),
+              n == occNameString (nameOccName name),
+              RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ]
+    enclosed (_,sp0) = any subspan ticks
+      where subspan (_,sp) = sp /= sp0 &&
+                         realSrcSpanStart sp <= realSrcSpanStart sp0 &&
+                         realSrcSpanEnd sp0 <= realSrcSpanEnd sp
+
+findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
+                 -> Maybe (BreakIndex,RealSrcSpan)
+findBreakByCoord mb_file (line, col) arr
+  | not (inRange (bounds arr) line) = Nothing
+  | otherwise =
+    listToMaybe (sortBy (flip compare `on` snd) contains ++
+                 sortBy (compare `on` snd) after_here)
+  where
+        ticks = arr ! line
+
+        -- the ticks that span this coordinate
+        contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col),
+                            is_correct_file pan ]
+
+        is_correct_file pan
+                 | Just f <- mb_file = GHC.srcSpanFile pan == f
+                 | otherwise         = True
+
+        after_here = [ tick | tick@(_,pan) <- ticks,
+                              GHC.srcSpanStartLine pan == line,
+                              GHC.srcSpanStartCol pan >= col ]
+
+-- For now, use ANSI bold on terminals that we know support it.
+-- Otherwise, we add a line of carets under the active expression instead.
+-- In particular, on Windows and when running the testsuite (which sets
+-- TERM to vt100 for other reasons) we get carets.
+-- We really ought to use a proper termcap/terminfo library.
+do_bold :: Bool
+do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
+    where mTerm = System.Environment.getEnv "TERM"
+                  `catchIO` \_ -> return "TERM not set"
+
+start_bold :: String
+start_bold = "\ESC[1m"
+end_bold :: String
+end_bold   = "\ESC[0m"
+
+-----------------------------------------------------------------------------
+-- :where
+
+whereCmd :: String -> GHCi ()
+whereCmd = noArgs $ do
+  mstrs <- getCallStackAtCurrentBreakpoint
+  case mstrs of
+    Nothing -> return ()
+    Just strs -> liftIO $ putStrLn (renderStack strs)
+
+-----------------------------------------------------------------------------
+-- :list
+
+listCmd :: String -> InputT GHCi ()
+listCmd c = listCmd' c
+
+listCmd' :: String -> InputT GHCi ()
+listCmd' "" = do
+   mb_span <- lift getCurrentBreakSpan
+   case mb_span of
+      Nothing ->
+          printForUser $ text "Not stopped at a breakpoint; nothing to list"
+      Just (RealSrcSpan pan) ->
+          listAround pan True
+      Just pan@(UnhelpfulSpan _) ->
+          do resumes <- GHC.getResumeContext
+             case resumes of
+                 [] -> panic "No resumes"
+                 (r:_) ->
+                     do let traceIt = case GHC.resumeHistory r of
+                                      [] -> text "rerunning with :trace,"
+                                      _ -> empty
+                            doWhat = traceIt <+> text ":back then :list"
+                        printForUser (text "Unable to list source for" <+>
+                                      ppr pan
+                                   $$ text "Try" <+> doWhat)
+listCmd' str = list2 (words str)
+
+list2 :: [String] -> InputT GHCi ()
+list2 [arg] | all isDigit arg = do
+    imports <- GHC.getContext
+    case iiModules imports of
+        [] -> liftIO $ putStrLn "No module to list"
+        (mn : _) -> do
+          md <- lift $ lookupModuleName mn
+          listModuleLine md (read arg)
+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
+        md <- wantInterpretedModule arg1
+        listModuleLine md (read arg2)
+list2 [arg] = do
+        wantNameFromInterpretedModule noCanDo arg $ \name -> do
+        let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
+        case loc of
+            RealSrcLoc l ->
+               do tickArray <- ASSERT( isExternalName name )
+                               lift $ getTickArray (GHC.nameModule name)
+                  let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))
+                                        (GHC.srcLocLine l, GHC.srcLocCol l)
+                                        tickArray
+                  case mb_span of
+                    Nothing       -> listAround (realSrcLocSpan l) False
+                    Just (_, pan) -> listAround pan False
+            UnhelpfulLoc _ ->
+                  noCanDo name $ text "can't find its location: " <>
+                                 ppr loc
+    where
+        noCanDo n why = printForUser $
+            text "cannot list source code for " <> ppr n <> text ": " <> why
+list2  _other =
+        liftIO $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"
+
+listModuleLine :: Module -> Int -> InputT GHCi ()
+listModuleLine modl line = do
+   graph <- GHC.getModuleGraph
+   let this = GHC.mgLookupModule graph modl
+   case this of
+     Nothing -> panic "listModuleLine"
+     Just summ -> do
+           let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
+               loc = mkRealSrcLoc (mkFastString (filename)) line 0
+           listAround (realSrcLocSpan loc) False
+
+-- | list a section of a source file around a particular SrcSpan.
+-- If the highlight flag is True, also highlight the span using
+-- start_bold\/end_bold.
+
+-- GHC files are UTF-8, so we can implement this by:
+-- 1) read the file in as a BS and syntax highlight it as before
+-- 2) convert the BS to String using utf-string, and write it out.
+-- It would be better if we could convert directly between UTF-8 and the
+-- console encoding, of course.
+listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m ()
+listAround pan do_highlight = do
+      contents <- liftIO $ BS.readFile (unpackFS file)
+      -- Drop carriage returns to avoid duplicates, see #9367.
+      let ls  = BS.split '\n' $ BS.filter (/= '\r') contents
+          ls' = take (line2 - line1 + 1 + pad_before + pad_after) $
+                        drop (line1 - 1 - pad_before) $ ls
+          fst_line = max 1 (line1 - pad_before)
+          line_nos = [ fst_line .. ]
+
+          highlighted | do_highlight = zipWith highlight line_nos ls'
+                      | otherwise    = [\p -> BS.concat[p,l] | l <- ls']
+
+          bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]
+          prefixed = zipWith ($) highlighted bs_line_nos
+          output   = BS.intercalate (BS.pack "\n") prefixed
+
+      let utf8Decoded = utf8DecodeByteString output
+      liftIO $ putStrLn utf8Decoded
+  where
+        file  = GHC.srcSpanFile pan
+        line1 = GHC.srcSpanStartLine pan
+        col1  = GHC.srcSpanStartCol pan - 1
+        line2 = GHC.srcSpanEndLine pan
+        col2  = GHC.srcSpanEndCol pan - 1
+
+        pad_before | line1 == 1 = 0
+                   | otherwise  = 1
+        pad_after = 1
+
+        highlight | do_bold   = highlight_bold
+                  | otherwise = highlight_carets
+
+        highlight_bold no line prefix
+          | no == line1 && no == line2
+          = let (a,r) = BS.splitAt col1 line
+                (b,c) = BS.splitAt (col2-col1) r
+            in
+            BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
+          | no == line1
+          = let (a,b) = BS.splitAt col1 line in
+            BS.concat [prefix, a, BS.pack start_bold, b]
+          | no == line2
+          = let (a,b) = BS.splitAt col2 line in
+            BS.concat [prefix, a, BS.pack end_bold, b]
+          | otherwise   = BS.concat [prefix, line]
+
+        highlight_carets no line prefix
+          | no == line1 && no == line2
+          = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
+                                         BS.replicate (col2-col1) '^']
+          | no == line1
+          = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
+                                         prefix, line]
+          | no == line2
+          = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
+                                         BS.pack "^^"]
+          | otherwise   = BS.concat [prefix, line]
+         where
+           indent = BS.pack ("  " ++ replicate (length (show no)) ' ')
+           nl = BS.singleton '\n'
+
+
+-- --------------------------------------------------------------------------
+-- Tick arrays
+
+getTickArray :: Module -> GHCi TickArray
+getTickArray modl = do
+   st <- getGHCiState
+   let arrmap = tickarrays st
+   case lookupModuleEnv arrmap modl of
+      Just arr -> return arr
+      Nothing  -> do
+        (_breakArray, ticks) <- getModBreak modl
+        let arr = mkTickArray (assocs ticks)
+        setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
+        return arr
+
+discardTickArrays :: GHCi ()
+discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})
+
+mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
+mkTickArray ticks
+  = accumArray (flip (:)) [] (1, max_line)
+        [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ]
+    where
+        max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ]
+        srcSpanLines pan = [ GHC.srcSpanStartLine pan ..  GHC.srcSpanEndLine pan ]
+
+-- don't reset the counter back to zero?
+discardActiveBreakPoints :: GHCi ()
+discardActiveBreakPoints = do
+   st <- getGHCiState
+   mapM_ (turnOffBreak.snd) (breaks st)
+   setGHCiState $ st { breaks = [] }
+
+deleteBreak :: Int -> GHCi ()
+deleteBreak identity = do
+   st <- getGHCiState
+   let oldLocations    = breaks st
+       (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
+   if null this
+      then printForUser (text "Breakpoint" <+> ppr identity <+>
+                         text "does not exist")
+      else do
+           mapM_ (turnOffBreak.snd) this
+           setGHCiState $ st { breaks = rest }
+
+turnOffBreak :: BreakLocation -> GHCi ()
+turnOffBreak loc = do
+  (arr, _) <- getModBreak (breakModule loc)
+  hsc_env <- GHC.getSession
+  liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False
+
+getModBreak :: Module -> GHCi (ForeignRef BreakArray, Array Int SrcSpan)
+getModBreak m = do
+   mod_info      <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m
+   let modBreaks  = GHC.modInfoModBreaks mod_info
+   let arr        = GHC.modBreaks_flags modBreaks
+   let ticks      = GHC.modBreaks_locs  modBreaks
+   return (arr, ticks)
+
+setBreakFlag :: Bool -> ForeignRef BreakArray -> Int -> GHCi ()
+setBreakFlag toggle arr i = do
+  hsc_env <- GHC.getSession
+  liftIO $ enableBreakpoint hsc_env arr i toggle
+
+-- ---------------------------------------------------------------------------
+-- User code exception handling
+
+-- This is the exception handler for exceptions generated by the
+-- user's code and exceptions coming from children sessions;
+-- it normally just prints out the exception.  The
+-- handler must be recursive, in case showing the exception causes
+-- more exceptions to be raised.
+--
+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,
+-- raising another exception.  We therefore don't put the recursive
+-- handler arond the flushing operation, so if stderr is closed
+-- GHCi will just die gracefully rather than going into an infinite loop.
+handler :: SomeException -> GHCi Bool
+
+handler exception = do
+  flushInterpBuffers
+  withSignalHandlers $
+     ghciHandle handler (showException exception >> return False)
+
+showException :: SomeException -> GHCi ()
+showException se =
+  liftIO $ case fromException se of
+           -- omit the location for CmdLineError:
+           Just (CmdLineError s)    -> putException s
+           -- ditto:
+           Just other_ghc_ex        -> putException (show other_ghc_ex)
+           Nothing                  ->
+               case fromException se of
+               Just UserInterrupt -> putException "Interrupted."
+               _                  -> putException ("*** Exception: " ++ show se)
+  where
+    putException = hPutStrLn stderr
+
+
+-----------------------------------------------------------------------------
+-- recursive exception handlers
+
+-- Don't forget to unblock async exceptions in the handler, or if we're
+-- in an exception loop (eg. let a = error a in a) the ^C exception
+-- may never be delivered.  Thanks to Marcin for pointing out the bug.
+
+ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a
+ghciHandle h m = gmask $ \restore -> do
+                 -- Force dflags to avoid leaking the associated HscEnv
+                 !dflags <- getDynFlags
+                 gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)
+
+ghciTry :: GHCi a -> GHCi (Either SomeException a)
+ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
+
+tryBool :: GHCi a -> GHCi Bool
+tryBool m = do
+    r <- ghciTry m
+    case r of
+      Left _  -> return False
+      Right _ -> return True
+
+-- ----------------------------------------------------------------------------
+-- Utils
+
+lookupModule :: GHC.GhcMonad m => String -> m Module
+lookupModule mName = lookupModuleName (GHC.mkModuleName mName)
+
+lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module
+lookupModuleName mName = GHC.lookupModule mName Nothing
+
+isHomeModule :: Module -> Bool
+isHomeModule m = GHC.moduleUnitId m == mainUnitId
+
+-- TODO: won't work if home dir is encoded.
+-- (changeDirectory may not work either in that case.)
+expandPath :: MonadIO m => String -> InputT m String
+expandPath = liftIO . expandPathIO
+
+expandPathIO :: String -> IO String
+expandPathIO p =
+  case dropWhile isSpace p of
+   ('~':d) -> do
+        tilde <- getHomeDirectory -- will fail if HOME not defined
+        return (tilde ++ '/':d)
+   other ->
+        return other
+
+wantInterpretedModule :: GHC.GhcMonad m => String -> m Module
+wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)
+
+wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
+wantInterpretedModuleName modname = do
+   modl <- lookupModuleName modname
+   let str = moduleNameString modname
+   dflags <- getDynFlags
+   when (GHC.moduleUnitId modl /= thisPackage dflags) $
+      throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
+   is_interpreted <- GHC.moduleIsInterpreted modl
+   when (not is_interpreted) $
+       throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
+   return modl
+
+wantNameFromInterpretedModule :: GHC.GhcMonad m
+                              => (Name -> SDoc -> m ())
+                              -> String
+                              -> (Name -> m ())
+                              -> m ()
+wantNameFromInterpretedModule noCanDo str and_then =
+  handleSourceError GHC.printException $ do
+   names <- GHC.parseName str
+   case names of
+      []    -> return ()
+      (n:_) -> do
+            let modl = ASSERT( isExternalName n ) GHC.nameModule n
+            if not (GHC.isExternalName n)
+               then noCanDo n $ ppr n <>
+                                text " is not defined in an interpreted module"
+               else do
+            is_interpreted <- GHC.moduleIsInterpreted modl
+            if not is_interpreted
+               then noCanDo n $ text "module " <> ppr modl <>
+                                text " is not interpreted"
+               else and_then n
diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs
new file mode 100644
--- /dev/null
+++ b/ghc/GHCi/UI/Info.hs
@@ -0,0 +1,379 @@
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns        #-}
+
+-- | Get information on modules, expressions, and identifiers
+module GHCi.UI.Info
+    ( ModInfo(..)
+    , SpanInfo(..)
+    , spanInfoFromRealSrcSpan
+    , collectInfo
+    , findLoc
+    , findNameUses
+    , findType
+    , getModInfo
+    ) where
+
+import           Control.Exception
+import           Control.Monad
+import           Control.Monad.Trans.Class
+import           Control.Monad.Trans.Except
+import           Control.Monad.Trans.Maybe
+import           Data.Data
+import           Data.Function
+import           Data.List
+import           Data.Map.Strict   (Map)
+import qualified Data.Map.Strict   as M
+import           Data.Maybe
+import           Data.Time
+import           Prelude           hiding (mod,(<>))
+import           System.Directory
+
+import qualified CoreUtils
+import           Desugar
+import           DynFlags (HasDynFlags(..))
+import           FastString
+import           GHC
+import           GhcMonad
+import           Name
+import           NameSet
+import           Outputable
+import           SrcLoc
+import           TcHsSyn
+import           Var
+
+-- | Info about a module. This information is generated every time a
+-- module is loaded.
+data ModInfo = ModInfo
+    { modinfoSummary    :: !ModSummary
+      -- ^ Summary generated by GHC. Can be used to access more
+      -- information about the module.
+    , modinfoSpans      :: [SpanInfo]
+      -- ^ Generated set of information about all spans in the
+      -- module that correspond to some kind of identifier for
+      -- which there will be type info and/or location info.
+    , modinfoInfo       :: !ModuleInfo
+      -- ^ Again, useful from GHC for accessing information
+      -- (exports, instances, scope) from a module.
+    , modinfoLastUpdate :: !UTCTime
+      -- ^ The timestamp of the file used to generate this record.
+    }
+
+-- | Type of some span of source code. Most of these fields are
+-- unboxed but Haddock doesn't show that.
+data SpanInfo = SpanInfo
+    { spaninfoSrcSpan   :: {-# UNPACK #-} !RealSrcSpan
+      -- ^ The span we associate information with
+    , spaninfoType      :: !(Maybe Type)
+      -- ^ The 'Type' associated with the span
+    , spaninfoVar       :: !(Maybe Id)
+      -- ^ The actual 'Var' associated with the span, if
+      -- any. This can be useful for accessing a variety of
+      -- information about the identifier such as module,
+      -- locality, definition location, etc.
+    }
+
+-- | Test whether second span is contained in (or equal to) first span.
+-- This is basically 'containsSpan' for 'SpanInfo'
+containsSpanInfo :: SpanInfo -> SpanInfo -> Bool
+containsSpanInfo = containsSpan `on` spaninfoSrcSpan
+
+-- | Filter all 'SpanInfo' which are contained in 'SpanInfo'
+spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]
+spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'
+
+-- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a
+-- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'
+-- respectively)
+spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo
+spanInfoFromRealSrcSpan spn mty mvar =
+    SpanInfo spn mty mvar
+
+-- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs
+-- only a 'RealSrcSpan'
+spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo
+spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing
+
+-- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'
+srcSpanFilePath :: RealSrcSpan -> FilePath
+srcSpanFilePath = unpackFS . srcSpanFile
+
+-- | Try to find the location of the given identifier at the given
+-- position in the module.
+findLoc :: GhcMonad m
+        => Map ModuleName ModInfo
+        -> RealSrcSpan
+        -> String
+        -> ExceptT SDoc m (ModInfo,Name,SrcSpan)
+findLoc infos span0 string = do
+    name  <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
+             guessModule infos (srcSpanFilePath span0)
+
+    info  <- maybeToExceptT "No module info for current file! Try loading it?" $
+             MaybeT $ pure $ M.lookup name infos
+
+    name' <- findName infos span0 info string
+
+    case getSrcSpan name' of
+        UnhelpfulSpan{} -> do
+            throwE ("Found a name, but no location information." <+>
+                    "The module is:" <+>
+                    maybe "<unknown>" (ppr . moduleName)
+                          (nameModule_maybe name'))
+
+        span' -> return (info,name',span')
+
+-- | Find any uses of the given identifier in the codebase.
+findNameUses :: (GhcMonad m)
+             => Map ModuleName ModInfo
+             -> RealSrcSpan
+             -> String
+             -> ExceptT SDoc m [SrcSpan]
+findNameUses infos span0 string =
+    locToSpans <$> findLoc infos span0 string
+  where
+    locToSpans (modinfo,name',span') =
+        stripSurrounding (span' : map toSrcSpan spans)
+      where
+        toSrcSpan = RealSrcSpan . spaninfoSrcSpan
+        spans = filter ((== Just name') . fmap getName . spaninfoVar)
+                       (modinfoSpans modinfo)
+
+-- | Filter out redundant spans which surround/contain other spans.
+stripSurrounding :: [SrcSpan] -> [SrcSpan]
+stripSurrounding xs = filter (not . isRedundant) xs
+  where
+    isRedundant x = any (x `strictlyContains`) xs
+
+    (RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)
+         = s1 /= s2 && s1 `containsSpan` s2
+    _                `strictlyContains` _ = False
+
+-- | Try to resolve the name located at the given position, or
+-- otherwise resolve based on the current module's scope.
+findName :: GhcMonad m
+         => Map ModuleName ModInfo
+         -> RealSrcSpan
+         -> ModInfo
+         -> String
+         -> ExceptT SDoc m Name
+findName infos span0 mi string =
+    case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of
+      Nothing -> tryExternalModuleResolution
+      Just name ->
+        case getSrcSpan name of
+          UnhelpfulSpan {} -> tryExternalModuleResolution
+          RealSrcSpan   {} -> return (getName name)
+  where
+    tryExternalModuleResolution =
+      case find (matchName $ mkFastString string)
+                (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of
+        Nothing -> throwE "Couldn't resolve to any modules."
+        Just imported -> resolveNameFromModule infos imported
+
+    matchName :: FastString -> Name -> Bool
+    matchName str name =
+      str ==
+      occNameFS (getOccName name)
+
+-- | Try to resolve the name from another (loaded) module's exports.
+resolveNameFromModule :: GhcMonad m
+                      => Map ModuleName ModInfo
+                      -> Name
+                      -> ExceptT SDoc m Name
+resolveNameFromModule infos name = do
+     modL <- maybe (throwE $ "No module for" <+> ppr name) return $
+             nameModule_maybe name
+
+     info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <>
+                            ppr modL)) return $
+             M.lookup (moduleName modL) infos
+
+     maybe (throwE "No matching export in any local modules.") return $
+         find (matchName name) (modInfoExports (modinfoInfo info))
+  where
+    matchName :: Name -> Name -> Bool
+    matchName x y = occNameFS (getOccName x) ==
+                    occNameFS (getOccName y)
+
+-- | Try to resolve the type display from the given span.
+resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var
+resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $
+                        reverse spans' `spaninfosWithin` si
+
+-- | Try to find the type of the given span.
+findType :: GhcMonad m
+         => Map ModuleName ModInfo
+         -> RealSrcSpan
+         -> String
+         -> ExceptT SDoc m (ModInfo, Type)
+findType infos span0 string = do
+    name  <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $
+             guessModule infos (srcSpanFilePath span0)
+
+    info  <- maybeToExceptT "No module info for current file! Try loading it?" $
+             MaybeT $ pure $ M.lookup name infos
+
+    case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of
+        Nothing -> (,) info <$> lift (exprType TM_Inst string)
+        Just ty -> return (info, ty)
+  where
+    -- | Try to resolve the type display from the given span.
+    resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type
+    resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $
+                            reverse spans' `spaninfosWithin` si
+
+-- | Guess a module name from a file path.
+guessModule :: GhcMonad m
+            => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
+guessModule infos fp = do
+    target <- lift $ guessTarget fp Nothing
+    case targetId target of
+        TargetModule mn  -> return mn
+        TargetFile fp' _ -> guessModule' fp'
+  where
+    guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName
+    guessModule' fp' = case findModByFp fp' of
+        Just mn -> return mn
+        Nothing -> do
+            fp'' <- liftIO (makeRelativeToCurrentDirectory fp')
+
+            target' <- lift $ guessTarget fp'' Nothing
+            case targetId target' of
+                TargetModule mn -> return mn
+                _               -> MaybeT . pure $ findModByFp fp''
+
+    findModByFp :: FilePath -> Maybe ModuleName
+    findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)
+      where
+        mifp :: (ModuleName, ModInfo) -> Maybe FilePath
+        mifp = ml_hs_file . ms_location . modinfoSummary . snd
+
+
+-- | Collect type info data for the loaded modules.
+collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]
+               -> m (Map ModuleName ModInfo)
+collectInfo ms loaded = do
+    df <- getDynFlags
+    liftIO (filterM cacheInvalid loaded) >>= \case
+        [] -> return ms
+        invalidated -> do
+            liftIO (putStrLn ("Collecting type info for " ++
+                              show (length invalidated) ++
+                              " module(s) ... "))
+
+            foldM (go df) ms invalidated
+  where
+    go df m name = do { info <- getModInfo name; return (M.insert name info m) }
+                   `gcatch`
+                   (\(e :: SomeException) -> do
+                         liftIO $ putStrLn
+                                $ showSDocForUser df alwaysQualify
+                                $ "Error while getting type info from" <+>
+                                  ppr name <> ":" <+> text (show e)
+                         return m)
+
+    cacheInvalid name = case M.lookup name ms of
+        Nothing -> return True
+        Just mi -> do
+            let fp = srcFilePath (modinfoSummary mi)
+                last' = modinfoLastUpdate mi
+            current <- getModificationTime fp
+            exists <- doesFileExist fp
+            if exists
+                then return $ current /= last'
+                else return True
+
+-- | Get the source file path from a ModSummary.
+-- If the .hs file is missing, and the .o file exists,
+-- we return the .o file path.
+srcFilePath :: ModSummary -> FilePath
+srcFilePath modSum = fromMaybe obj_fp src_fp
+    where
+        src_fp = ml_hs_file ms_loc
+        obj_fp = ml_obj_file ms_loc
+        ms_loc = ms_location modSum
+
+-- | Get info about the module: summary, types, etc.
+getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo
+getModInfo name = do
+    m <- getModSummary name
+    p <- parseModule m
+    typechecked <- typecheckModule p
+    allTypes <- processAllTypeCheckedModule typechecked
+    let i = tm_checked_module_info typechecked
+    ts <- liftIO $ getModificationTime $ srcFilePath m
+    return (ModInfo m allTypes i ts)
+
+-- | Get ALL source spans in the module.
+processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule
+                            -> m [SpanInfo]
+processAllTypeCheckedModule tcm = do
+    bts <- mapM getTypeLHsBind $ listifyAllSpans tcs
+    ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs
+    pts <- mapM getTypeLPat    $ listifyAllSpans tcs
+    return $ mapMaybe toSpanInfo
+           $ sortBy cmpSpan
+           $ catMaybes (bts ++ ets ++ pts)
+  where
+    tcs = tm_typechecked_source tcm
+
+    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's
+    getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
+    getTypeLHsBind (dL->L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _})
+        = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))
+    getTypeLHsBind _ = pure Nothing
+
+    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's
+    getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
+    getTypeLHsExpr e = do
+        hs_env  <- getSession
+        (_,mbe) <- liftIO $ deSugarExpr hs_env e
+        return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe
+      where
+        mid :: Maybe Id
+        mid | HsVar _ (dL->L _ i) <- unwrapVar (unLoc e) = Just i
+            | otherwise                                  = Nothing
+
+        unwrapVar (HsWrap _ _ var) = var
+        unwrapVar e'               = e'
+
+    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's
+    getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))
+    getTypeLPat (dL->L spn pat) =
+        pure (Just (getMaybeId pat,spn,hsPatType pat))
+      where
+        getMaybeId (VarPat _ (dL->L _ vid)) = Just vid
+        getMaybeId _                        = Nothing
+
+    -- | Get ALL source spans in the source.
+    listifyAllSpans :: (HasSrcSpan a , Typeable a) => TypecheckedSource -> [a]
+    listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))
+      where
+        p (dL->L spn _) = isGoodSrcSpan spn
+
+    -- | Variant of @syb@'s @everything@ (which summarises all nodes
+    -- in top-down, left-to-right order) with a stop-condition on 'NameSet's
+    everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r
+    everythingAllSpans k z f x
+      | (False `mkQ` (const True :: NameSet -> Bool)) x = z
+      | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)
+
+    cmpSpan (_,a,_) (_,b,_)
+      | a `isSubspanOf` b = LT
+      | b `isSubspanOf` a = GT
+      | otherwise         = EQ
+
+    -- | Pretty print the types into a 'SpanInfo'.
+    toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo
+    toSpanInfo (n,RealSrcSpan spn,typ)
+        = Just $ spanInfoFromRealSrcSpan spn (Just typ) n
+    toSpanInfo _ = Nothing
+
+-- helper stolen from @syb@ package
+type GenericQ r = forall a. Data a => a -> r
+
+mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
+(r `mkQ` br) a = maybe r br (cast a)
diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs
new file mode 100644
--- /dev/null
+++ b/ghc/GHCi/UI/Monad.hs
@@ -0,0 +1,522 @@
+{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}
+{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
+
+-----------------------------------------------------------------------------
+--
+-- Monadery code used in InteractiveUI
+--
+-- (c) The GHC Team 2005-2006
+--
+-----------------------------------------------------------------------------
+
+module GHCi.UI.Monad (
+        GHCi(..), startGHCi,
+        GHCiState(..), setGHCiState, getGHCiState, modifyGHCiState,
+        GHCiOption(..), isOptionSet, setOption, unsetOption,
+        Command(..), CommandResult(..), cmdSuccess,
+        PromptFunction,
+        BreakLocation(..),
+        TickArray,
+        getDynFlags,
+
+        runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs,
+        ActionStats(..), runAndPrintStats, runWithStats, printStats,
+
+        printForUserNeverQualify, printForUserModInfo,
+        printForUser, printForUserPartWay, prettyLocations,
+
+        compileGHCiExpr,
+        initInterpBuffering,
+        turnOffBuffering, turnOffBuffering_,
+        flushInterpBuffers,
+        mkEvalWrapper
+    ) where
+
+#include "HsVersions.h"
+
+import GHCi.UI.Info (ModInfo)
+import qualified GHC
+import GhcMonad         hiding (liftIO)
+import Outputable       hiding (printForUser, printForUserPartWay)
+import qualified Outputable
+import DynFlags
+import FastString
+import HscTypes
+import SrcLoc
+import Module
+import GHCi
+import GHCi.RemoteTypes
+import HsSyn (ImportDecl, GhcPs, GhciLStmt, LHsDecl)
+import Util
+
+import Exception
+import Numeric
+import Data.Array
+import Data.IORef
+import Data.Time
+import System.Environment
+import System.IO
+import Control.Monad
+import Prelude hiding ((<>))
+
+import System.Console.Haskeline (CompletionFunc, InputT)
+import qualified System.Console.Haskeline as Haskeline
+import Control.Monad.Trans.Class
+import Control.Monad.IO.Class
+import Data.Map.Strict (Map)
+import qualified GHC.LanguageExtensions as LangExt
+
+-----------------------------------------------------------------------------
+-- GHCi monad
+
+data GHCiState = GHCiState
+     {
+        progname       :: String,
+        args           :: [String],
+        evalWrapper    :: ForeignHValue, -- ^ of type @IO a -> IO a@
+        prompt         :: PromptFunction,
+        prompt_cont    :: PromptFunction,
+        editor         :: String,
+        stop           :: String,
+        options        :: [GHCiOption],
+        line_number    :: !Int,         -- ^ input line
+        break_ctr      :: !Int,
+        breaks         :: ![(Int, BreakLocation)],
+        tickarrays     :: ModuleEnv TickArray,
+            -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,
+            -- so that we don't rebuild it each time the user sets
+            -- a breakpoint.
+        ghci_commands  :: [Command],
+            -- ^ available ghci commands
+        ghci_macros    :: [Command],
+            -- ^ user-defined macros
+        last_command   :: Maybe Command,
+            -- ^ @:@ at the GHCi prompt repeats the last command, so we
+            -- remember it here
+        cmd_wrapper    :: InputT GHCi CommandResult -> InputT GHCi (Maybe Bool),
+            -- ^ The command wrapper is run for each command or statement.
+            -- The 'Bool' value denotes whether the command is successful and
+            -- 'Nothing' means to exit GHCi.
+        cmdqueue       :: [String],
+
+        remembered_ctx :: [InteractiveImport],
+            -- ^ The imports that the user has asked for, via import
+            -- declarations and :module commands.  This list is
+            -- persistent over :reloads (but any imports for modules
+            -- that are not loaded are temporarily ignored).  After a
+            -- :load, all the home-package imports are stripped from
+            -- this list.
+            --
+            -- See bugs #2049, #1873, #1360
+
+        transient_ctx  :: [InteractiveImport],
+            -- ^ An import added automatically after a :load, usually of
+            -- the most recently compiled module.  May be empty if
+            -- there are no modules loaded.  This list is replaced by
+            -- :load, :reload, and :add.  In between it may be modified
+            -- by :module.
+
+        extra_imports  :: [ImportDecl GhcPs],
+            -- ^ These are "always-on" imports, added to the
+            -- context regardless of what other imports we have.
+            -- This is useful for adding imports that are required
+            -- by setGHCiMonad.  Be careful adding things here:
+            -- you can create ambiguities if these imports overlap
+            -- with other things in scope.
+            --
+            -- NB. although this is not currently used by GHCi itself,
+            -- it was added to support other front-ends that are based
+            -- on the GHCi code.  Potentially we could also expose
+            -- this functionality via GHCi commands.
+
+        prelude_imports :: [ImportDecl GhcPs],
+            -- ^ These imports are added to the context when
+            -- -XImplicitPrelude is on and we don't have a *-module
+            -- in the context.  They can also be overridden by another
+            -- import for the same module, e.g.
+            -- "import Prelude hiding (map)"
+
+        ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)
+
+        short_help :: String,
+            -- ^ help text to display to a user
+        long_help  :: String,
+        lastErrorLocations :: IORef [(FastString, Int)],
+
+        mod_infos  :: !(Map ModuleName ModInfo),
+
+        flushStdHandles :: ForeignHValue,
+            -- ^ @hFlush stdout; hFlush stderr@ in the interpreter
+        noBuffering :: ForeignHValue
+            -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr
+     }
+
+type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]
+
+-- | A GHCi command
+data Command
+   = Command
+   { cmdName           :: String
+     -- ^ Name of GHCi command (e.g. "exit")
+   , cmdAction         :: String -> InputT GHCi Bool
+     -- ^ The 'Bool' value denotes whether to exit GHCi
+   , cmdHidden         :: Bool
+     -- ^ Commands which are excluded from default completion
+     -- and @:help@ summary. This is usually set for commands not
+     -- useful for interactive use but rather for IDEs.
+   , cmdCompletionFunc :: CompletionFunc GHCi
+     -- ^ 'CompletionFunc' for arguments
+   }
+
+data CommandResult
+   = CommandComplete
+   { cmdInput :: String
+   , cmdResult :: Either SomeException (Maybe Bool)
+   , cmdStats :: ActionStats
+   }
+   | CommandIncomplete
+     -- ^ Unterminated multiline command
+   deriving Show
+
+cmdSuccess :: Haskeline.MonadException m => CommandResult -> m (Maybe Bool)
+cmdSuccess CommandComplete{ cmdResult = Left e } = liftIO $ throwIO e
+cmdSuccess CommandComplete{ cmdResult = Right r } = return r
+cmdSuccess CommandIncomplete = return $ Just True
+
+type PromptFunction = [String]
+                   -> Int
+                   -> GHCi SDoc
+
+data GHCiOption
+        = ShowTiming            -- show time/allocs after evaluation
+        | ShowType              -- show the type of expressions
+        | RevertCAFs            -- revert CAFs after every evaluation
+        | Multiline             -- use multiline commands
+        | CollectInfo           -- collect and cache information about
+                                -- modules after load
+        deriving Eq
+
+data BreakLocation
+   = BreakLocation
+   { breakModule :: !GHC.Module
+   , breakLoc    :: !SrcSpan
+   , breakTick   :: {-# UNPACK #-} !Int
+   , onBreakCmd  :: String
+   }
+
+instance Eq BreakLocation where
+  loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
+                 breakTick loc1   == breakTick loc2
+
+prettyLocations :: [(Int, BreakLocation)] -> SDoc
+prettyLocations []   = text "No active breakpoints."
+prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
+
+instance Outputable BreakLocation where
+   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
+                if null (onBreakCmd loc)
+                   then Outputable.empty
+                   else doubleQuotes (text (onBreakCmd loc))
+
+recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
+recordBreak brkLoc = do
+   st <- getGHCiState
+   let oldActiveBreaks = breaks st
+   -- don't store the same break point twice
+   case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
+     (nm:_) -> return (True, nm)
+     [] -> do
+      let oldCounter = break_ctr st
+          newCounter = oldCounter + 1
+      setGHCiState $ st { break_ctr = newCounter,
+                          breaks = (oldCounter, brkLoc) : oldActiveBreaks
+                        }
+      return (False, oldCounter)
+
+newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
+
+reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
+reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
+
+reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
+reifyGHCi f = GHCi f'
+  where
+    -- f' :: IORef GHCiState -> Ghc a
+    f' gs = reifyGhc (f'' gs)
+    -- f'' :: IORef GHCiState -> Session -> IO a
+    f'' gs s = f (s, gs)
+
+startGHCi :: GHCi a -> GHCiState -> Ghc a
+startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
+
+instance Functor GHCi where
+    fmap = liftM
+
+instance Applicative GHCi where
+    pure a = GHCi $ \_ -> pure a
+    (<*>) = ap
+
+instance Monad GHCi where
+  (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
+
+class HasGhciState m where
+    getGHCiState    :: m GHCiState
+    setGHCiState    :: GHCiState -> m ()
+    modifyGHCiState :: (GHCiState -> GHCiState) -> m ()
+
+instance HasGhciState GHCi where
+    getGHCiState      = GHCi $ \r -> liftIO $ readIORef r
+    setGHCiState s    = GHCi $ \r -> liftIO $ writeIORef r s
+    modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f
+
+instance (MonadTrans t, Monad m, HasGhciState m) => HasGhciState (t m) where
+    getGHCiState    = lift getGHCiState
+    setGHCiState    = lift . setGHCiState
+    modifyGHCiState = lift . modifyGHCiState
+
+liftGhc :: Ghc a -> GHCi a
+liftGhc m = GHCi $ \_ -> m
+
+instance MonadIO GHCi where
+  liftIO = liftGhc . liftIO
+
+instance HasDynFlags GHCi where
+  getDynFlags = getSessionDynFlags
+
+instance GhcMonad GHCi where
+  setSession s' = liftGhc $ setSession s'
+  getSession    = liftGhc $ getSession
+
+instance HasDynFlags (InputT GHCi) where
+  getDynFlags = lift getDynFlags
+
+instance GhcMonad (InputT GHCi) where
+  setSession = lift . setSession
+  getSession = lift getSession
+
+instance ExceptionMonad GHCi where
+  gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
+  gmask f =
+      GHCi $ \s -> gmask $ \io_restore ->
+                             let
+                                g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')
+                             in
+                                unGHCi (f g_restore) s
+
+instance Haskeline.MonadException Ghc where
+  controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
+                    run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)
+                    in fmap (flip unGhc s) $ f run'
+
+instance Haskeline.MonadException GHCi where
+  controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let
+                    run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)
+                    in fmap (flip unGHCi s) $ f run'
+
+instance ExceptionMonad (InputT GHCi) where
+  gcatch = Haskeline.catch
+  gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)
+
+isOptionSet :: GHCiOption -> GHCi Bool
+isOptionSet opt
+ = do st <- getGHCiState
+      return (opt `elem` options st)
+
+setOption :: GHCiOption -> GHCi ()
+setOption opt
+ = do st <- getGHCiState
+      setGHCiState (st{ options = opt : filter (/= opt) (options st) })
+
+unsetOption :: GHCiOption -> GHCi ()
+unsetOption opt
+ = do st <- getGHCiState
+      setGHCiState (st{ options = filter (/= opt) (options st) })
+
+printForUserNeverQualify :: GhcMonad m => SDoc -> m ()
+printForUserNeverQualify doc = do
+  dflags <- getDynFlags
+  liftIO $ Outputable.printForUser dflags stdout neverQualify doc
+
+printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()
+printForUserModInfo info doc = do
+  dflags <- getDynFlags
+  mUnqual <- GHC.mkPrintUnqualifiedForModule info
+  unqual <- maybe GHC.getPrintUnqual return mUnqual
+  liftIO $ Outputable.printForUser dflags stdout unqual doc
+
+printForUser :: GhcMonad m => SDoc -> m ()
+printForUser doc = do
+  unqual <- GHC.getPrintUnqual
+  dflags <- getDynFlags
+  liftIO $ Outputable.printForUser dflags stdout unqual doc
+
+printForUserPartWay :: SDoc -> GHCi ()
+printForUserPartWay doc = do
+  unqual <- GHC.getPrintUnqual
+  dflags <- getDynFlags
+  liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc
+
+-- | Run a single Haskell expression
+runStmt :: GhciLStmt GhcPs -> String -> GHC.SingleStep -> GHCi (Maybe GHC.ExecResult)
+runStmt stmt stmt_text step = do
+  st <- getGHCiState
+  GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do
+    let opts = GHC.execOptions
+                  { GHC.execSourceFile = progname st
+                  , GHC.execLineNumber = line_number st
+                  , GHC.execSingleStep = step
+                  , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))
+                                                   (EvalThis fhv) }
+    Just <$> GHC.execStmt' stmt stmt_text opts
+
+runDecls :: String -> GHCi (Maybe [GHC.Name])
+runDecls decls = do
+  st <- getGHCiState
+  reifyGHCi $ \x ->
+    withProgName (progname st) $
+    withArgs (args st) $
+      reflectGHCi x $ do
+        GHC.handleSourceError (\e -> do GHC.printException e;
+                                        return Nothing) $ do
+          r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls
+          return (Just r)
+
+runDecls' :: [LHsDecl GhcPs] -> GHCi (Maybe [GHC.Name])
+runDecls' decls = do
+  st <- getGHCiState
+  reifyGHCi $ \x ->
+    withProgName (progname st) $
+    withArgs (args st) $
+    reflectGHCi x $
+      GHC.handleSourceError
+        (\e -> do GHC.printException e;
+                  return Nothing)
+        (Just <$> GHC.runParsedDecls decls)
+
+resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.ExecResult
+resume canLogSpan step = do
+  st <- getGHCiState
+  reifyGHCi $ \x ->
+    withProgName (progname st) $
+    withArgs (args st) $
+      reflectGHCi x $ do
+        GHC.resumeExec canLogSpan step
+
+-- --------------------------------------------------------------------------
+-- timing & statistics
+
+data ActionStats = ActionStats
+  { actionAllocs :: Maybe Integer
+  , actionElapsedTime :: Double
+  } deriving Show
+
+runAndPrintStats
+  :: (a -> Maybe Integer)
+  -> InputT GHCi a
+  -> InputT GHCi (ActionStats, Either SomeException a)
+runAndPrintStats getAllocs action = do
+  result <- runWithStats getAllocs action
+  case result of
+    (stats, Right{}) -> do
+      showTiming <- lift $ isOptionSet ShowTiming
+      when showTiming $ do
+        dflags  <- getDynFlags
+        liftIO $ printStats dflags stats
+    _ -> return ()
+  return result
+
+runWithStats
+  :: ExceptionMonad m
+  => (a -> Maybe Integer) -> m a -> m (ActionStats, Either SomeException a)
+runWithStats getAllocs action = do
+  t0 <- liftIO getCurrentTime
+  result <- gtry action
+  let allocs = either (const Nothing) getAllocs result
+  t1 <- liftIO getCurrentTime
+  let elapsedTime = realToFrac $ t1 `diffUTCTime` t0
+  return (ActionStats allocs elapsedTime, result)
+
+printStats :: DynFlags -> ActionStats -> IO ()
+printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}
+   = do let secs_str = showFFloat (Just 2) secs
+        putStrLn (showSDoc dflags (
+                 parens (text (secs_str "") <+> text "secs" <> comma <+>
+                         case mallocs of
+                           Nothing -> empty
+                           Just allocs ->
+                             text (separateThousands allocs) <+> text "bytes")))
+  where
+    separateThousands n = reverse . sep . reverse . show $ n
+      where sep n'
+              | n' `lengthAtMost` 3 = n'
+              | otherwise           = take 3 n' ++ "," ++ sep (drop 3 n')
+
+-----------------------------------------------------------------------------
+-- reverting CAFs
+
+revertCAFs :: GHCi ()
+revertCAFs = do
+  liftIO rts_revertCAFs
+  s <- getGHCiState
+  when (not (ghc_e s)) turnOffBuffering
+     -- Have to turn off buffering again, because we just
+     -- reverted stdout, stderr & stdin to their defaults.
+
+foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
+        -- Make it "safe", just in case
+
+-----------------------------------------------------------------------------
+-- To flush buffers for the *interpreted* computation we need
+-- to refer to *its* stdout/stderr handles
+
+-- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly
+initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)
+initInterpBuffering = do
+  nobuf <- compileGHCiExpr $
+   "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " ++
+       " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " ++
+       " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"
+  flush <- compileGHCiExpr $
+   "do { System.IO.hFlush System.IO.stdout; " ++
+       " System.IO.hFlush System.IO.stderr }"
+  return (nobuf, flush)
+
+-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter
+flushInterpBuffers :: GHCi ()
+flushInterpBuffers = do
+  st <- getGHCiState
+  hsc_env <- GHC.getSession
+  liftIO $ evalIO hsc_env (flushStdHandles st)
+
+-- | Turn off buffering for stdin, stdout, and stderr in the interpreter
+turnOffBuffering :: GHCi ()
+turnOffBuffering = do
+  st <- getGHCiState
+  turnOffBuffering_ (noBuffering st)
+
+turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()
+turnOffBuffering_ fhv = do
+  hsc_env <- getSession
+  liftIO $ evalIO hsc_env fhv
+
+mkEvalWrapper :: GhcMonad m => String -> [String] ->  m ForeignHValue
+mkEvalWrapper progname args =
+  compileGHCiExpr $
+    "\\m -> System.Environment.withProgName " ++ show progname ++
+    "(System.Environment.withArgs " ++ show args ++ " m)"
+
+compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue
+compileGHCiExpr expr =
+  withTempSession mkTempSession $ GHC.compileExprRemote expr
+  where
+    mkTempSession hsc_env = hsc_env
+      { hsc_dflags = (hsc_dflags hsc_env)
+          -- RebindableSyntax can wreak havoc with GHCi in several ways
+          -- (see #13385 and #14342 for examples), so we take care to disable it
+          -- for the duration of running expressions that are internal to GHCi.
+          `xopt_unset` LangExt.RebindableSyntax
+          -- We heavily depend on -fimplicit-import-qualified to compile expr
+          -- with fully qualified names without imports.
+          `gopt_set` Opt_ImplicitImportQualified
+      }
diff --git a/ghc/GHCi/UI/Tags.hs b/ghc/GHCi/UI/Tags.hs
new file mode 100644
--- /dev/null
+++ b/ghc/GHCi/UI/Tags.hs
@@ -0,0 +1,216 @@
+-----------------------------------------------------------------------------
+--
+-- GHCi's :ctags and :etags commands
+--
+-- (c) The GHC Team 2005-2007
+--
+-----------------------------------------------------------------------------
+
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+module GHCi.UI.Tags (
+  createCTagsWithLineNumbersCmd,
+  createCTagsWithRegExesCmd,
+  createETagsFileCmd
+) where
+
+import Exception
+import GHC
+import GHCi.UI.Monad
+import Outputable
+
+-- ToDo: figure out whether we need these, and put something appropriate
+-- into the GHC API instead
+import Name (nameOccName)
+import OccName (pprOccName)
+import ConLike
+import MonadUtils
+
+import Control.Monad
+import Data.Function
+import Data.List
+import Data.Maybe
+import Data.Ord
+import DriverPhases
+import Panic
+import Prelude
+import System.Directory
+import System.IO
+import System.IO.Error
+
+-----------------------------------------------------------------------------
+-- create tags file for currently loaded modules.
+
+createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,
+  createETagsFileCmd :: String -> GHCi ()
+
+createCTagsWithLineNumbersCmd ""   =
+  ghciCreateTagsFile CTagsWithLineNumbers "tags"
+createCTagsWithLineNumbersCmd file =
+  ghciCreateTagsFile CTagsWithLineNumbers file
+
+createCTagsWithRegExesCmd ""   =
+  ghciCreateTagsFile CTagsWithRegExes "tags"
+createCTagsWithRegExesCmd file =
+  ghciCreateTagsFile CTagsWithRegExes file
+
+createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"
+createETagsFileCmd file  = ghciCreateTagsFile ETags file
+
+data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes
+
+ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
+ghciCreateTagsFile kind file = do
+  createTagsFile kind file
+
+-- ToDo:
+--      - remove restriction that all modules must be interpreted
+--        (problem: we don't know source locations for entities unless
+--        we compiled the module.
+--
+--      - extract createTagsFile so it can be used from the command-line
+--        (probably need to fix first problem before this is useful).
+--
+createTagsFile :: TagsKind -> FilePath -> GHCi ()
+createTagsFile tagskind tagsFile = do
+  graph <- GHC.getModuleGraph
+  mtags <- mapM listModuleTags (map GHC.ms_mod $ GHC.mgModSummaries graph)
+  either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags
+  case either_res of
+    Left e  -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e
+    Right _ -> return ()
+
+
+listModuleTags :: GHC.Module -> GHCi [TagInfo]
+listModuleTags m = do
+  is_interpreted <- GHC.moduleIsInterpreted m
+  -- should we just skip these?
+  when (not is_interpreted) $
+    let mName = GHC.moduleNameString (GHC.moduleName m) in
+    throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))
+  mbModInfo <- GHC.getModuleInfo m
+  case mbModInfo of
+    Nothing -> return []
+    Just mInfo -> do
+       dflags <- getDynFlags
+       mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo
+       let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual
+       let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo
+       let localNames = filter ((m==) . nameModule) names
+       mbTyThings <- mapM GHC.lookupName localNames
+       return $! [ tagInfo dflags unqual exported kind name realLoc
+                     | tyThing <- catMaybes mbTyThings
+                     , let name = getName tyThing
+                     , let exported = GHC.modInfoIsExportedName mInfo name
+                     , let kind = tyThing2TagKind tyThing
+                     , let loc = srcSpanStart (nameSrcSpan name)
+                     , RealSrcLoc realLoc <- [loc]
+                     ]
+
+  where
+    tyThing2TagKind (AnId _)                 = 'v'
+    tyThing2TagKind (AConLike RealDataCon{}) = 'd'
+    tyThing2TagKind (AConLike PatSynCon{})   = 'p'
+    tyThing2TagKind (ATyCon _)               = 't'
+    tyThing2TagKind (ACoAxiom _)             = 'x'
+
+
+data TagInfo = TagInfo
+  { tagExported :: Bool -- is tag exported
+  , tagKind :: Char   -- tag kind
+  , tagName :: String -- tag name
+  , tagFile :: String -- file name
+  , tagLine :: Int    -- line number
+  , tagCol :: Int     -- column number
+  , tagSrcInfo :: Maybe (String,Integer)  -- source code line and char offset
+  }
+
+
+-- get tag info, for later translation into Vim or Emacs style
+tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc
+        -> TagInfo
+tagInfo dflags unqual exported kind name loc
+    = TagInfo exported kind
+        (showSDocForUser dflags unqual $ pprOccName (nameOccName name))
+        (showSDocForUser dflags unqual $ ftext (srcLocFile loc))
+        (srcLocLine loc) (srcLocCol loc) Nothing
+
+-- throw an exception when someone tries to overwrite existing source file (fix for #10989)
+writeTagsSafely :: FilePath -> String -> IO ()
+writeTagsSafely file str = do
+    dfe <- doesFileExist file
+    if dfe && isSourceFilename file
+        then throwGhcException (CmdLineError (file ++ " is existing source file. " ++
+             "Please specify another file name to store tags data"))
+        else writeFile file str
+
+collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
+-- ctags style with the Ex expression being just the line number, Vim et al
+collateAndWriteTags CTagsWithLineNumbers file tagInfos = do
+  let tags = unlines $ sort $ map showCTag tagInfos
+  tryIO (writeTagsSafely file tags)
+
+-- ctags style with the Ex expression being a regex searching the line, Vim et al
+collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al
+  tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos
+  let tags = unlines $ sort $ map showCTag $concat tagInfoGroups
+  tryIO (writeTagsSafely file tags)
+
+collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
+  tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos
+  let tagGroups = map processGroup tagInfoGroups
+  tryIO (writeTagsSafely file $ concat tagGroups)
+
+  where
+    processGroup [] = throwGhcException (CmdLineError "empty tag file group??")
+    processGroup group@(tagInfo:_) =
+      let tags = unlines $ map showETag group in
+      "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags
+
+
+makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]
+makeTagGroupsWithSrcInfo tagInfos = do
+  let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos
+  mapM addTagSrcInfo groups
+
+  where
+    addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")
+    addTagSrcInfo group@(tagInfo:_) = do
+      file <- readFile $tagFile tagInfo
+      let sortedGroup = sortBy (comparing tagLine) group
+      return $ perFile sortedGroup 1 0 $ lines file
+
+    perFile allTags@(tag:tags) cnt pos allLs@(l:ls)
+     | tagLine tag > cnt =
+         perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls
+     | tagLine tag == cnt =
+         tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs
+    perFile _ _ _ _ = []
+
+
+-- ctags format, for Vim et al
+showCTag :: TagInfo -> String
+showCTag ti =
+  tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" ++
+    tagKind ti : ( if tagExported ti then "" else "\tfile:" )
+
+  where
+    tagCmd =
+      case tagSrcInfo ti of
+        Nothing -> show $tagLine ti
+        Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"
+
+      where
+        escapeSlashes '/' r = '\\' : '/' : r
+        escapeSlashes '\\' r = '\\' : '\\' : r
+        escapeSlashes c r = c : r
+
+
+-- etags format, for Emacs/XEmacs
+showETag :: TagInfo -> String
+showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,
+                  tagSrcInfo = Just (srcLine,charPos) }
+    =  take (colNo - 1) srcLine ++ tag
+    ++ "\x7f" ++ tag
+    ++ "\x01" ++ show lineNo
+    ++ "," ++ show charPos
+showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
diff --git a/ghc/Main.hs b/ghc/Main.hs
new file mode 100644
--- /dev/null
+++ b/ghc/Main.hs
@@ -0,0 +1,964 @@
+{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-}
+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
+
+-----------------------------------------------------------------------------
+--
+-- GHC Driver program
+--
+-- (c) The University of Glasgow 2005
+--
+-----------------------------------------------------------------------------
+
+module Main (main) where
+
+-- The official GHC API
+import qualified GHC
+import GHC              ( -- DynFlags(..), HscTarget(..),
+                          -- GhcMode(..), GhcLink(..),
+                          Ghc, GhcMonad(..),
+                          LoadHowMuch(..) )
+import CmdLineParser
+
+-- Implementations of the various modes (--show-iface, mkdependHS. etc.)
+import LoadIface        ( showIface )
+import HscMain          ( newHscEnv )
+import DriverPipeline   ( oneShot, compileFile )
+import DriverMkDepend   ( doMkDependHS )
+import DriverBkp   ( doBackpack )
+#if defined(GHCI)
+import GHCi.UI          ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
+#endif
+
+-- Frontend plugins
+#if defined(GHCI)
+import DynamicLoading   ( loadFrontendPlugin )
+import Plugins
+#else
+import DynamicLoading   ( pluginError )
+#endif
+import Module           ( ModuleName )
+
+
+-- Various other random stuff that we need
+import GHC.HandleEncoding
+import Config
+import Constants
+import HscTypes
+import Packages         ( pprPackages, pprPackagesSimple )
+import DriverPhases
+import BasicTypes       ( failed )
+import DynFlags hiding (WarnReason(..))
+import ErrUtils
+import FastString
+import Outputable
+import SrcLoc
+import Util
+import Panic
+import UniqSupply
+import MonadUtils       ( liftIO )
+import DynamicLoading   ( initializePlugins )
+
+-- Imports for --abi-hash
+import LoadIface           ( loadUserInterface )
+import Module              ( mkModuleName )
+import Finder              ( findImportedModule, cannotFindModule )
+import TcRnMonad           ( initIfaceCheck )
+import Binary              ( openBinMem, put_ )
+import BinFingerprint      ( fingerprintBinMem )
+
+-- Standard Haskell libraries
+import System.IO
+import System.Environment
+import System.Exit
+import System.FilePath
+import Control.Monad
+import Data.Char
+import Data.List
+import Data.Maybe
+import Prelude
+
+-----------------------------------------------------------------------------
+-- ToDo:
+
+-- time commands when run with -v
+-- user ways
+-- Win32 support: proper signal handling
+-- reading the package configuration file is too slow
+-- -K<size>
+
+-----------------------------------------------------------------------------
+-- GHC's command-line interface
+
+main :: IO ()
+main = do
+   initGCStatistics -- See Note [-Bsymbolic and hooks]
+   hSetBuffering stdout LineBuffering
+   hSetBuffering stderr LineBuffering
+
+   configureHandleEncoding
+   GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
+    -- 1. extract the -B flag from the args
+    argv0 <- getArgs
+
+    let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0
+        mbMinusB | null minusB_args = Nothing
+                 | otherwise = Just (drop 2 (last minusB_args))
+
+    let argv2 = map (mkGeneralLocated "on the commandline") argv1
+
+    -- 2. Parse the "mode" flags (--make, --interactive etc.)
+    (mode, argv3, flagWarnings) <- parseModeFlags argv2
+
+    -- If all we want to do is something like showing the version number
+    -- then do it now, before we start a GHC session etc. This makes
+    -- getting basic information much more resilient.
+
+    -- In particular, if we wait until later before giving the version
+    -- number then bootstrapping gets confused, as it tries to find out
+    -- what version of GHC it's using before package.conf exists, so
+    -- starting the session fails.
+    case mode of
+        Left preStartupMode ->
+            do case preStartupMode of
+                   ShowSupportedExtensions   -> showSupportedExtensions
+                   ShowVersion               -> showVersion
+                   ShowNumVersion            -> putStrLn cProjectVersion
+                   ShowOptions isInteractive -> showOptions isInteractive
+        Right postStartupMode ->
+            -- start our GHC session
+            GHC.runGhc mbMinusB $ do
+
+            dflags <- GHC.getSessionDynFlags
+
+            case postStartupMode of
+                Left preLoadMode ->
+                    liftIO $ do
+                        case preLoadMode of
+                            ShowInfo               -> showInfo dflags
+                            ShowGhcUsage           -> showGhcUsage  dflags
+                            ShowGhciUsage          -> showGhciUsage dflags
+                            PrintWithDynFlags f    -> putStrLn (f dflags)
+                Right postLoadMode ->
+                    main' postLoadMode dflags argv3 flagWarnings
+
+main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]
+      -> Ghc ()
+main' postLoadMode dflags0 args flagWarnings = do
+  -- set the default GhcMode, HscTarget and GhcLink.  The HscTarget
+  -- can be further adjusted on a module by module basis, using only
+  -- the -fvia-C and -fasm flags.  If the default HscTarget is not
+  -- HscC or HscAsm, -fvia-C and -fasm have no effect.
+  let dflt_target = hscTarget dflags0
+      (mode, lang, link)
+         = case postLoadMode of
+               DoInteractive   -> (CompManager, HscInterpreted, LinkInMemory)
+               DoEval _        -> (CompManager, HscInterpreted, LinkInMemory)
+               DoMake          -> (CompManager, dflt_target,    LinkBinary)
+               DoBackpack      -> (CompManager, dflt_target,    LinkBinary)
+               DoMkDependHS    -> (MkDepend,    dflt_target,    LinkBinary)
+               DoAbiHash       -> (OneShot,     dflt_target,    LinkBinary)
+               _               -> (OneShot,     dflt_target,    LinkBinary)
+
+  let dflags1 = dflags0{ ghcMode   = mode,
+                         hscTarget = lang,
+                         ghcLink   = link,
+                         verbosity = case postLoadMode of
+                                         DoEval _ -> 0
+                                         _other   -> 1
+                        }
+
+      -- turn on -fimplicit-import-qualified for GHCi now, so that it
+      -- can be overriden from the command-line
+      -- XXX: this should really be in the interactive DynFlags, but
+      -- we don't set that until later in interactiveUI
+      -- We also set -fignore-optim-changes and -fignore-hpc-changes,
+      -- which are program-level options. Again, this doesn't really
+      -- feel like the right place to handle this, but we don't have
+      -- a great story for the moment.
+      dflags2  | DoInteractive <- postLoadMode = def_ghci_flags
+               | DoEval _      <- postLoadMode = def_ghci_flags
+               | otherwise                     = dflags1
+        where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified
+                                       `gopt_set` Opt_IgnoreOptimChanges
+                                       `gopt_set` Opt_IgnoreHpcChanges
+
+        -- The rest of the arguments are "dynamic"
+        -- Leftover ones are presumably files
+  (dflags3, fileish_args, dynamicFlagWarnings) <-
+      GHC.parseDynamicFlags dflags2 args
+
+  let dflags4 = case lang of
+                HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->
+                    let platform = targetPlatform dflags3
+                        dflags3a = updateWays $ dflags3 { ways = interpWays }
+                        dflags3b = foldl gopt_set dflags3a
+                                 $ concatMap (wayGeneralFlags platform)
+                                             interpWays
+                        dflags3c = foldl gopt_unset dflags3b
+                                 $ concatMap (wayUnsetGeneralFlags platform)
+                                             interpWays
+                    in dflags3c
+                _ ->
+                    dflags3
+
+  GHC.prettyPrintGhcErrors dflags4 $ do
+
+  let flagWarnings' = flagWarnings ++ dynamicFlagWarnings
+
+  handleSourceError (\e -> do
+       GHC.printException e
+       liftIO $ exitWith (ExitFailure 1)) $ do
+         liftIO $ handleFlagWarnings dflags4 flagWarnings'
+
+  liftIO $ showBanner postLoadMode dflags4
+
+  let
+     -- To simplify the handling of filepaths, we normalise all filepaths right
+     -- away. Note the asymmetry of FilePath.normalise:
+     --    Linux:   p/q -> p/q; p\q -> p\q
+     --    Windows: p/q -> p\q; p\q -> p\q
+     -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs
+     -- to -foo.hs. We have to re-prepend the current directory.
+    normalise_hyp fp
+        | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp
+        | otherwise                           = nfp
+        where
+#if defined(mingw32_HOST_OS)
+          strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp
+#else
+          strt_dot_sl = "./" `isPrefixOf` fp
+#endif
+          cur_dir = '.' : [pathSeparator]
+          nfp = normalise fp
+    normal_fileish_paths = map (normalise_hyp . unLoc) fileish_args
+    (srcs, objs)         = partition_args normal_fileish_paths [] []
+
+    dflags5 = dflags4 { ldInputs = map (FileOption "") objs
+                                   ++ ldInputs dflags4 }
+
+  -- we've finished manipulating the DynFlags, update the session
+  _ <- GHC.setSessionDynFlags dflags5
+  dflags6 <- GHC.getSessionDynFlags
+  hsc_env <- GHC.getSession
+
+        ---------------- Display configuration -----------
+  case verbosity dflags6 of
+    v | v == 4 -> liftIO $ dumpPackagesSimple dflags6
+      | v >= 5 -> liftIO $ dumpPackages dflags6
+      | otherwise -> return ()
+
+  liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)
+        ---------------- Final sanity checking -----------
+  liftIO $ checkOptions postLoadMode dflags6 srcs objs
+
+  ---------------- Do the business -----------
+  handleSourceError (\e -> do
+       GHC.printException e
+       liftIO $ exitWith (ExitFailure 1)) $ do
+    case postLoadMode of
+       ShowInterface f        -> liftIO $ doShowIface dflags6 f
+       DoMake                 -> doMake srcs
+       DoMkDependHS           -> doMkDependHS (map fst srcs)
+       StopBefore p           -> liftIO (oneShot hsc_env p srcs)
+       DoInteractive          -> ghciUI hsc_env dflags6 srcs Nothing
+       DoEval exprs           -> ghciUI hsc_env dflags6 srcs $ Just $
+                                   reverse exprs
+       DoAbiHash              -> abiHash (map fst srcs)
+       ShowPackages           -> liftIO $ showPackages dflags6
+       DoFrontend f           -> doFrontend f srcs
+       DoBackpack             -> doBackpack (map fst srcs)
+
+  liftIO $ dumpFinalStats dflags6
+
+ghciUI :: HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String]
+       -> Ghc ()
+#if !defined(GHCI)
+ghciUI _ _ _ _ =
+  throwGhcException (CmdLineError "not built for interactive use")
+#else
+ghciUI hsc_env dflags0 srcs maybe_expr = do
+  dflags1 <- liftIO (initializePlugins hsc_env dflags0)
+  _ <- GHC.setSessionDynFlags dflags1
+  interactiveUI defaultGhciSettings srcs maybe_expr
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Splitting arguments into source files and object files.  This is where we
+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source
+-- file indicating the phase specified by the -x option in force, if any.
+
+partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
+               -> ([(String, Maybe Phase)], [String])
+partition_args [] srcs objs = (reverse srcs, reverse objs)
+partition_args ("-x":suff:args) srcs objs
+  | "none" <- suff      = partition_args args srcs objs
+  | StopLn <- phase     = partition_args args srcs (slurp ++ objs)
+  | otherwise           = partition_args rest (these_srcs ++ srcs) objs
+        where phase = startPhase suff
+              (slurp,rest) = break (== "-x") args
+              these_srcs = zip slurp (repeat (Just phase))
+partition_args (arg:args) srcs objs
+  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
+  | otherwise               = partition_args args srcs (arg:objs)
+
+    {-
+      We split out the object files (.o, .dll) and add them
+      to ldInputs for use by the linker.
+
+      The following things should be considered compilation manager inputs:
+
+       - haskell source files (strings ending in .hs, .lhs or other
+         haskellish extension),
+
+       - module names (not forgetting hierarchical module names),
+
+       - things beginning with '-' are flags that were not recognised by
+         the flag parser, and we want them to generate errors later in
+         checkOptions, so we class them as source files (#5921)
+
+       - and finally we consider everything without an extension to be
+         a comp manager input, as shorthand for a .hs or .lhs filename.
+
+      Everything else is considered to be a linker object, and passed
+      straight through to the linker.
+    -}
+looks_like_an_input :: String -> Bool
+looks_like_an_input m =  isSourceFilename m
+                      || looksLikeModuleName m
+                      || "-" `isPrefixOf` m
+                      || not (hasExtension m)
+
+-- -----------------------------------------------------------------------------
+-- Option sanity checks
+
+-- | Ensure sanity of options.
+--
+-- Throws 'UsageError' or 'CmdLineError' if not.
+checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()
+     -- Final sanity checking before kicking off a compilation (pipeline).
+checkOptions mode dflags srcs objs = do
+     -- Complain about any unknown flags
+   let unknown_opts = [ f | (f@('-':_), _) <- srcs ]
+   when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
+
+   when (notNull (filter wayRTSOnly (ways dflags))
+         && isInterpretiveMode mode) $
+        hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")
+
+        -- -prof and --interactive are not a good combination
+   when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)
+         && isInterpretiveMode mode
+         && not (gopt Opt_ExternalInterpreter dflags)) $
+      do throwGhcException (UsageError
+              "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")
+        -- -ohi sanity check
+   if (isJust (outputHi dflags) &&
+      (isCompManagerMode mode || srcs `lengthExceeds` 1))
+        then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")
+        else do
+
+        -- -o sanity checking
+   if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)
+         && not (isLinkMode mode))
+        then throwGhcException (UsageError "can't apply -o to multiple source files")
+        else do
+
+   let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)
+
+   when (not_linking && not (null objs)) $
+        hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)
+
+        -- Check that there are some input files
+        -- (except in the interactive case)
+   if null srcs && (null objs || not_linking) && needsInputsMode mode
+        then throwGhcException (UsageError "no input files")
+        else do
+
+   case mode of
+      StopBefore HCc | hscTarget dflags /= HscC
+        -> throwGhcException $ UsageError $
+           "the option -C is only available with an unregisterised GHC"
+      _ -> return ()
+
+     -- Verify that output files point somewhere sensible.
+   verifyOutputFiles dflags
+
+-- Compiler output options
+
+-- Called to verify that the output files point somewhere valid.
+--
+-- The assumption is that the directory portion of these output
+-- options will have to exist by the time 'verifyOutputFiles'
+-- is invoked.
+--
+-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if
+-- they don't exist, so don't check for those here (#2278).
+verifyOutputFiles :: DynFlags -> IO ()
+verifyOutputFiles dflags = do
+  let ofile = outputFile dflags
+  when (isJust ofile) $ do
+     let fn = fromJust ofile
+     flg <- doesDirNameExist fn
+     when (not flg) (nonExistentDir "-o" fn)
+  let ohi = outputHi dflags
+  when (isJust ohi) $ do
+     let hi = fromJust ohi
+     flg <- doesDirNameExist hi
+     when (not flg) (nonExistentDir "-ohi" hi)
+ where
+   nonExistentDir flg dir =
+     throwGhcException (CmdLineError ("error: directory portion of " ++
+                             show dir ++ " does not exist (used with " ++
+                             show flg ++ " option.)"))
+
+-----------------------------------------------------------------------------
+-- GHC modes of operation
+
+type Mode = Either PreStartupMode PostStartupMode
+type PostStartupMode = Either PreLoadMode PostLoadMode
+
+data PreStartupMode
+  = ShowVersion                          -- ghc -V/--version
+  | ShowNumVersion                       -- ghc --numeric-version
+  | ShowSupportedExtensions              -- ghc --supported-extensions
+  | ShowOptions Bool {- isInteractive -} -- ghc --show-options
+
+showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode
+showVersionMode             = mkPreStartupMode ShowVersion
+showNumVersionMode          = mkPreStartupMode ShowNumVersion
+showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
+showOptionsMode             = mkPreStartupMode (ShowOptions False)
+
+mkPreStartupMode :: PreStartupMode -> Mode
+mkPreStartupMode = Left
+
+isShowVersionMode :: Mode -> Bool
+isShowVersionMode (Left ShowVersion) = True
+isShowVersionMode _ = False
+
+isShowNumVersionMode :: Mode -> Bool
+isShowNumVersionMode (Left ShowNumVersion) = True
+isShowNumVersionMode _ = False
+
+data PreLoadMode
+  = ShowGhcUsage                           -- ghc -?
+  | ShowGhciUsage                          -- ghci -?
+  | ShowInfo                               -- ghc --info
+  | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
+
+showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
+showGhcUsageMode = mkPreLoadMode ShowGhcUsage
+showGhciUsageMode = mkPreLoadMode ShowGhciUsage
+showInfoMode = mkPreLoadMode ShowInfo
+
+printSetting :: String -> Mode
+printSetting k = mkPreLoadMode (PrintWithDynFlags f)
+    where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
+                   $ lookup k (compilerInfo dflags)
+
+mkPreLoadMode :: PreLoadMode -> Mode
+mkPreLoadMode = Right . Left
+
+isShowGhcUsageMode :: Mode -> Bool
+isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
+isShowGhcUsageMode _ = False
+
+isShowGhciUsageMode :: Mode -> Bool
+isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
+isShowGhciUsageMode _ = False
+
+data PostLoadMode
+  = ShowInterface FilePath  -- ghc --show-iface
+  | DoMkDependHS            -- ghc -M
+  | StopBefore Phase        -- ghc -E | -C | -S
+                            -- StopBefore StopLn is the default
+  | DoMake                  -- ghc --make
+  | DoBackpack              -- ghc --backpack foo.bkp
+  | DoInteractive           -- ghc --interactive
+  | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
+  | DoAbiHash               -- ghc --abi-hash
+  | ShowPackages            -- ghc --show-packages
+  | DoFrontend ModuleName   -- ghc --frontend Plugin.Module
+
+doMkDependHSMode, doMakeMode, doInteractiveMode,
+  doAbiHashMode, showPackagesMode :: Mode
+doMkDependHSMode = mkPostLoadMode DoMkDependHS
+doMakeMode = mkPostLoadMode DoMake
+doInteractiveMode = mkPostLoadMode DoInteractive
+doAbiHashMode = mkPostLoadMode DoAbiHash
+showPackagesMode = mkPostLoadMode ShowPackages
+
+showInterfaceMode :: FilePath -> Mode
+showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
+
+stopBeforeMode :: Phase -> Mode
+stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
+
+doEvalMode :: String -> Mode
+doEvalMode str = mkPostLoadMode (DoEval [str])
+
+doFrontendMode :: String -> Mode
+doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))
+
+doBackpackMode :: Mode
+doBackpackMode = mkPostLoadMode DoBackpack
+
+mkPostLoadMode :: PostLoadMode -> Mode
+mkPostLoadMode = Right . Right
+
+isDoInteractiveMode :: Mode -> Bool
+isDoInteractiveMode (Right (Right DoInteractive)) = True
+isDoInteractiveMode _ = False
+
+isStopLnMode :: Mode -> Bool
+isStopLnMode (Right (Right (StopBefore StopLn))) = True
+isStopLnMode _ = False
+
+isDoMakeMode :: Mode -> Bool
+isDoMakeMode (Right (Right DoMake)) = True
+isDoMakeMode _ = False
+
+isDoEvalMode :: Mode -> Bool
+isDoEvalMode (Right (Right (DoEval _))) = True
+isDoEvalMode _ = False
+
+#if defined(GHCI)
+isInteractiveMode :: PostLoadMode -> Bool
+isInteractiveMode DoInteractive = True
+isInteractiveMode _             = False
+#endif
+
+-- isInterpretiveMode: byte-code compiler involved
+isInterpretiveMode :: PostLoadMode -> Bool
+isInterpretiveMode DoInteractive = True
+isInterpretiveMode (DoEval _)    = True
+isInterpretiveMode _             = False
+
+needsInputsMode :: PostLoadMode -> Bool
+needsInputsMode DoMkDependHS    = True
+needsInputsMode (StopBefore _)  = True
+needsInputsMode DoMake          = True
+needsInputsMode _               = False
+
+-- True if we are going to attempt to link in this mode.
+-- (we might not actually link, depending on the GhcLink flag)
+isLinkMode :: PostLoadMode -> Bool
+isLinkMode (StopBefore StopLn) = True
+isLinkMode DoMake              = True
+isLinkMode DoInteractive       = True
+isLinkMode (DoEval _)          = True
+isLinkMode _                   = False
+
+isCompManagerMode :: PostLoadMode -> Bool
+isCompManagerMode DoMake        = True
+isCompManagerMode DoInteractive = True
+isCompManagerMode (DoEval _)    = True
+isCompManagerMode _             = False
+
+-- -----------------------------------------------------------------------------
+-- Parsing the mode flag
+
+parseModeFlags :: [Located String]
+               -> IO (Mode,
+                      [Located String],
+                      [Warn])
+parseModeFlags args = do
+  let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
+          runCmdLine (processArgs mode_flags args)
+                     (Nothing, [], [])
+      mode = case mModeFlag of
+             Nothing     -> doMakeMode
+             Just (m, _) -> m
+
+  -- See Note [Handling errors when parsing commandline flags]
+  unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $
+      map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2
+
+  return (mode, flags' ++ leftover, warns)
+
+type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
+  -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
+  -- so we collect the new ones and return them.
+
+mode_flags :: [Flag ModeM]
+mode_flags =
+  [  ------- help / version ----------------------------------------------
+    defFlag "?"                     (PassFlag (setMode showGhcUsageMode))
+  , defFlag "-help"                 (PassFlag (setMode showGhcUsageMode))
+  , defFlag "V"                     (PassFlag (setMode showVersionMode))
+  , defFlag "-version"              (PassFlag (setMode showVersionMode))
+  , defFlag "-numeric-version"      (PassFlag (setMode showNumVersionMode))
+  , defFlag "-info"                 (PassFlag (setMode showInfoMode))
+  , defFlag "-show-options"         (PassFlag (setMode showOptionsMode))
+  , defFlag "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))
+  , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
+  , defFlag "-show-packages"        (PassFlag (setMode showPackagesMode))
+  ] ++
+  [ defFlag k'                      (PassFlag (setMode (printSetting k)))
+  | k <- ["Project version",
+          "Project Git commit id",
+          "Booter version",
+          "Stage",
+          "Build platform",
+          "Host platform",
+          "Target platform",
+          "Have interpreter",
+          "Object splitting supported",
+          "Have native code generator",
+          "Support SMP",
+          "Unregisterised",
+          "Tables next to code",
+          "RTS ways",
+          "Leading underscore",
+          "Debug on",
+          "LibDir",
+          "Global Package DB",
+          "C compiler flags",
+          "C compiler link flags",
+          "ld flags"],
+    let k' = "-print-" ++ map (replaceSpace . toLower) k
+        replaceSpace ' ' = '-'
+        replaceSpace c   = c
+  ] ++
+      ------- interfaces ----------------------------------------------------
+  [ defFlag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)
+                                               "--show-iface"))
+
+      ------- primary modes ------------------------------------------------
+  , defFlag "c"            (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
+                                               addFlag "-no-link" f))
+  , defFlag "M"            (PassFlag (setMode doMkDependHSMode))
+  , defFlag "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))
+  , defFlag "C"            (PassFlag (setMode (stopBeforeMode HCc)))
+  , defFlag "S"            (PassFlag (setMode (stopBeforeMode (As False))))
+  , defFlag "-make"        (PassFlag (setMode doMakeMode))
+  , defFlag "-backpack"    (PassFlag (setMode doBackpackMode))
+  , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))
+  , defFlag "-abi-hash"    (PassFlag (setMode doAbiHashMode))
+  , defFlag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
+  , defFlag "-frontend"    (SepArg   (\s -> setMode (doFrontendMode s) "-frontend"))
+  ]
+
+setMode :: Mode -> String -> EwM ModeM ()
+setMode newMode newFlag = liftEwM $ do
+    (mModeFlag, errs, flags') <- getCmdLineState
+    let (modeFlag', errs') =
+            case mModeFlag of
+            Nothing -> ((newMode, newFlag), errs)
+            Just (oldMode, oldFlag) ->
+                case (oldMode, newMode) of
+                    -- -c/--make are allowed together, and mean --make -no-link
+                    _ |  isStopLnMode oldMode && isDoMakeMode newMode
+                      || isStopLnMode newMode && isDoMakeMode oldMode ->
+                      ((doMakeMode, "--make"), [])
+
+                    -- If we have both --help and --interactive then we
+                    -- want showGhciUsage
+                    _ | isShowGhcUsageMode oldMode &&
+                        isDoInteractiveMode newMode ->
+                            ((showGhciUsageMode, oldFlag), [])
+                      | isShowGhcUsageMode newMode &&
+                        isDoInteractiveMode oldMode ->
+                            ((showGhciUsageMode, newFlag), [])
+
+                    -- If we have both -e and --interactive then -e always wins
+                    _ | isDoEvalMode oldMode &&
+                        isDoInteractiveMode newMode ->
+                            ((oldMode, oldFlag), [])
+                      | isDoEvalMode newMode &&
+                        isDoInteractiveMode oldMode ->
+                            ((newMode, newFlag), [])
+
+                    -- Otherwise, --help/--version/--numeric-version always win
+                      | isDominantFlag oldMode -> ((oldMode, oldFlag), [])
+                      | isDominantFlag newMode -> ((newMode, newFlag), [])
+                    -- We need to accumulate eval flags like "-e foo -e bar"
+                    (Right (Right (DoEval esOld)),
+                     Right (Right (DoEval [eNew]))) ->
+                        ((Right (Right (DoEval (eNew : esOld))), oldFlag),
+                         errs)
+                    -- Saying e.g. --interactive --interactive is OK
+                    _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
+
+                    -- --interactive and --show-options are used together
+                    (Right (Right DoInteractive), Left (ShowOptions _)) ->
+                      ((Left (ShowOptions True),
+                        "--interactive --show-options"), errs)
+                    (Left (ShowOptions _), (Right (Right DoInteractive))) ->
+                      ((Left (ShowOptions True),
+                        "--show-options --interactive"), errs)
+                    -- Otherwise, complain
+                    _ -> let err = flagMismatchErr oldFlag newFlag
+                         in ((oldMode, oldFlag), err : errs)
+    putCmdLineState (Just modeFlag', errs', flags')
+  where isDominantFlag f = isShowGhcUsageMode   f ||
+                           isShowGhciUsageMode  f ||
+                           isShowVersionMode    f ||
+                           isShowNumVersionMode f
+
+flagMismatchErr :: String -> String -> String
+flagMismatchErr oldFlag newFlag
+    = "cannot use `" ++ oldFlag ++  "' with `" ++ newFlag ++ "'"
+
+addFlag :: String -> String -> EwM ModeM ()
+addFlag s flag = liftEwM $ do
+  (m, e, flags') <- getCmdLineState
+  putCmdLineState (m, e, mkGeneralLocated loc s : flags')
+    where loc = "addFlag by " ++ flag ++ " on the commandline"
+
+-- ----------------------------------------------------------------------------
+-- Run --make mode
+
+doMake :: [(String,Maybe Phase)] -> Ghc ()
+doMake srcs  = do
+    let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs
+
+    hsc_env <- GHC.getSession
+
+    -- if we have no haskell sources from which to do a dependency
+    -- analysis, then just do one-shot compilation and/or linking.
+    -- This means that "ghc Foo.o Bar.o -o baz" links the program as
+    -- we expect.
+    if (null hs_srcs)
+       then liftIO (oneShot hsc_env StopLn srcs)
+       else do
+
+    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
+                 non_hs_srcs
+    dflags <- GHC.getSessionDynFlags
+    let dflags' = dflags { ldInputs = map (FileOption "") o_files
+                                      ++ ldInputs dflags }
+    _ <- GHC.setSessionDynFlags dflags'
+
+    targets <- mapM (uncurry GHC.guessTarget) hs_srcs
+    GHC.setTargets targets
+    ok_flag <- GHC.load LoadAllTargets
+
+    when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
+    return ()
+
+
+-- ---------------------------------------------------------------------------
+-- --show-iface mode
+
+doShowIface :: DynFlags -> FilePath -> IO ()
+doShowIface dflags file = do
+  hsc_env <- newHscEnv dflags
+  showIface hsc_env file
+
+-- ---------------------------------------------------------------------------
+-- Various banners and verbosity output.
+
+showBanner :: PostLoadMode -> DynFlags -> IO ()
+showBanner _postLoadMode dflags = do
+   let verb = verbosity dflags
+
+#if defined(GHCI)
+   -- Show the GHCi banner
+   when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg
+#endif
+
+   -- Display details of the configuration in verbose mode
+   when (verb >= 2) $
+    do hPutStr stderr "Glasgow Haskell Compiler, Version "
+       hPutStr stderr cProjectVersion
+       hPutStr stderr ", stage "
+       hPutStr stderr cStage
+       hPutStr stderr " booted by GHC version "
+       hPutStrLn stderr cBooterVersion
+
+-- We print out a Read-friendly string, but a prettier one than the
+-- Show instance gives us
+showInfo :: DynFlags -> IO ()
+showInfo dflags = do
+        let sq x = " [" ++ x ++ "\n ]"
+        putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags
+
+showSupportedExtensions :: IO ()
+showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions
+
+showVersion :: IO ()
+showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
+
+showOptions :: Bool -> IO ()
+showOptions isInteractive = putStr (unlines availableOptions)
+    where
+      availableOptions = concat [
+        flagsForCompletion isInteractive,
+        map ('-':) (getFlagNames mode_flags)
+        ]
+      getFlagNames opts         = map flagName opts
+
+showGhcUsage :: DynFlags -> IO ()
+showGhcUsage = showUsage False
+
+showGhciUsage :: DynFlags -> IO ()
+showGhciUsage = showUsage True
+
+showUsage :: Bool -> DynFlags -> IO ()
+showUsage ghci dflags = do
+  let usage_path = if ghci then ghciUsagePath dflags
+                           else ghcUsagePath dflags
+  usage <- readFile usage_path
+  dump usage
+  where
+     dump ""          = return ()
+     dump ('$':'$':s) = putStr progName >> dump s
+     dump (c:s)       = putChar c >> dump s
+
+dumpFinalStats :: DynFlags -> IO ()
+dumpFinalStats dflags =
+  when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags
+
+dumpFastStringStats :: DynFlags -> IO ()
+dumpFastStringStats dflags = do
+  segments <- getFastStringTable
+  let buckets = concat segments
+      bucketsPerSegment = map length segments
+      entriesPerBucket = map length buckets
+      entries = sum entriesPerBucket
+      hasZ = sum $ map (length . filter hasZEncoding) buckets
+      msg = text "FastString stats:" $$ nest 4 (vcat
+        [ text "segments:         " <+> int (length segments)
+        , text "buckets:          " <+> int (sum bucketsPerSegment)
+        , text "entries:          " <+> int entries
+        , text "largest segment:  " <+> int (maximum bucketsPerSegment)
+        , text "smallest segment: " <+> int (minimum bucketsPerSegment)
+        , text "longest bucket:   " <+> int (maximum entriesPerBucket)
+        , text "has z-encoding:   " <+> (hasZ `pcntOf` entries)
+        ])
+        -- we usually get more "has z-encoding" than "z-encoded", because
+        -- when we z-encode a string it might hash to the exact same string,
+        -- which is not counted as "z-encoded".  Only strings whose
+        -- Z-encoding is different from the original string are counted in
+        -- the "z-encoded" total.
+  putMsg dflags msg
+  where
+   x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%'
+
+showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()
+showPackages       dflags = putStrLn (showSDoc dflags (pprPackages dflags))
+dumpPackages       dflags = putMsg dflags (pprPackages dflags)
+dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)
+
+-- -----------------------------------------------------------------------------
+-- Frontend plugin support
+
+doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()
+#if !defined(GHCI)
+doFrontend modname _ = pluginError [modname]
+#else
+doFrontend modname srcs = do
+    hsc_env <- getSession
+    frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname
+    frontend frontend_plugin
+      (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs
+#endif
+
+-- -----------------------------------------------------------------------------
+-- ABI hash support
+
+{-
+        ghc --abi-hash Data.Foo System.Bar
+
+Generates a combined hash of the ABI for modules Data.Foo and
+System.Bar.  The modules must already be compiled, and appropriate -i
+options may be necessary in order to find the .hi files.
+
+This is used by Cabal for generating the ComponentId for a
+package.  The ComponentId must change when the visible ABI of
+the package chagnes, so during registration Cabal calls ghc --abi-hash
+to get a hash of the package's ABI.
+-}
+
+-- | Print ABI hash of input modules.
+--
+-- The resulting hash is the MD5 of the GHC version used (Trac #5328,
+-- see 'hiVersion') and of the existing ABI hash from each module (see
+-- 'mi_mod_hash').
+abiHash :: [String] -- ^ List of module names
+        -> Ghc ()
+abiHash strs = do
+  hsc_env <- getSession
+  let dflags = hsc_dflags hsc_env
+
+  liftIO $ do
+
+  let find_it str = do
+         let modname = mkModuleName str
+         r <- findImportedModule hsc_env modname Nothing
+         case r of
+           Found _ m -> return m
+           _error    -> throwGhcException $ CmdLineError $ showSDoc dflags $
+                          cannotFindModule dflags modname r
+
+  mods <- mapM find_it strs
+
+  let get_iface modl = loadUserInterface False (text "abiHash") modl
+  ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods
+
+  bh <- openBinMem (3*1024) -- just less than a block
+  put_ bh hiVersion
+    -- package hashes change when the compiler version changes (for now)
+    -- see #5328
+  mapM_ (put_ bh . mi_mod_hash) ifaces
+  f <- fingerprintBinMem bh
+
+  putStrLn (showPpr dflags f)
+
+-- -----------------------------------------------------------------------------
+-- Util
+
+unknownFlagsErr :: [String] -> a
+unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs
+  where
+    oneError f =
+        "unrecognised flag: " ++ f ++ "\n" ++
+        (case match f (nubSort allNonDeprecatedFlags) of
+            [] -> ""
+            suggs -> "did you mean one of:\n" ++ unlines (map ("  " ++) suggs))
+    -- fixes #11789
+    -- If the flag contains '=',
+    -- this uses both the whole and the left side of '=' for comparing.
+    match f allFlags
+        | elem '=' f =
+              let (flagsWithEq, flagsWithoutEq) = partition (elem '=') allFlags
+                  fName = takeWhile (/= '=') f
+              in (fuzzyMatch f flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)
+        | otherwise = fuzzyMatch f allFlags
+
+{- Note [-Bsymbolic and hooks]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-Bsymbolic is a flag that prevents the binding of references to global
+symbols to symbols outside the shared library being compiled (see `man
+ld`). When dynamically linking, we don't use -Bsymbolic on the RTS
+package: that is because we want hooks to be overridden by the user,
+we don't want to constrain them to the RTS package.
+
+Unfortunately this seems to have broken somehow on OS X: as a result,
+defaultHooks (in hschooks.c) is not called, which does not initialize
+the GC stats. As a result, this breaks things like `:set +s` in GHCi
+(#8754). As a hacky workaround, we instead call 'defaultHooks'
+directly to initalize the flags in the RTS.
+
+A byproduct of this, I believe, is that hooks are likely broken on OS
+X when dynamically linking. But this probably doesn't affect most
+people since we're linking GHC dynamically, but most things themselves
+link statically.
+-}
+
+-- If GHC_LOADED_INTO_GHCI is not set when GHC is loaded into GHCi, then
+-- running it causes an error like this:
+--
+-- Loading temp shared object failed:
+-- /tmp/ghc13836_0/libghc_1872.so: undefined symbol: initGCStatistics
+--
+-- Skipping the foreign call fixes this problem, and the outer GHCi
+-- should have already made this call anyway.
+#if defined(GHC_LOADED_INTO_GHCI)
+initGCStatistics :: IO ()
+initGCStatistics = return ()
+#else
+foreign import ccall safe "initGCStatistics"
+  initGCStatistics :: IO ()
+#endif
diff --git a/includes/Cmm.h b/includes/Cmm.h
new file mode 100644
--- /dev/null
+++ b/includes/Cmm.h
@@ -0,0 +1,931 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2004-2013
+ *
+ * This file is included at the top of all .cmm source files (and
+ * *only* .cmm files).  It defines a collection of useful macros for
+ * making .cmm code a bit less error-prone to write, and a bit easier
+ * on the eye for the reader.
+ *
+ * For the syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
+ *
+ * Accessing fields of structures defined in the RTS header files is
+ * done via automatically-generated macros in DerivedConstants.h.  For
+ * example, where previously we used
+ *
+ *          CurrentTSO->what_next = x
+ *
+ * in C-- we now use
+ *
+ *          StgTSO_what_next(CurrentTSO) = x
+ *
+ * where the StgTSO_what_next() macro is automatically generated by
+ * mkDerivedConstants.c.  If you need to access a field that doesn't
+ * already have a macro, edit that file (it's pretty self-explanatory).
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/*
+ * In files that are included into both C and C-- (and perhaps
+ * Haskell) sources, we sometimes need to conditionally compile bits
+ * depending on the language.  CMINUSMINUS==1 in .cmm sources:
+ */
+#define CMINUSMINUS 1
+
+#include "ghcconfig.h"
+
+/* -----------------------------------------------------------------------------
+   Types
+
+   The following synonyms for C-- types are declared here:
+
+     I8, I16, I32, I64    MachRep-style names for convenience
+
+     W_                   is shorthand for the word type (== StgWord)
+     F_                   shorthand for float  (F_ == StgFloat == C's float)
+     D_                   shorthand for double (D_ == StgDouble == C's double)
+
+     CInt                 has the same size as an int in C on this platform
+     CLong                has the same size as a long in C on this platform
+     CBool                has the same size as a bool in C on this platform
+
+  --------------------------------------------------------------------------- */
+
+#define I8  bits8
+#define I16 bits16
+#define I32 bits32
+#define I64 bits64
+#define P_  gcptr
+
+#if SIZEOF_VOID_P == 4
+#define W_ bits32
+/* Maybe it's better to include MachDeps.h */
+#define TAG_BITS                2
+#elif SIZEOF_VOID_P == 8
+#define W_ bits64
+/* Maybe it's better to include MachDeps.h */
+#define TAG_BITS                3
+#else
+#error Unknown word size
+#endif
+
+/*
+ * The RTS must sometimes UNTAG a pointer before dereferencing it.
+ * See the wiki page Commentary/Rts/HaskellExecution/PointerTagging
+ */
+#define TAG_MASK ((1 << TAG_BITS) - 1)
+#define UNTAG(p) (p & ~TAG_MASK)
+#define GETTAG(p) (p & TAG_MASK)
+
+#if SIZEOF_INT == 4
+#define CInt bits32
+#elif SIZEOF_INT == 8
+#define CInt bits64
+#else
+#error Unknown int size
+#endif
+
+#if SIZEOF_LONG == 4
+#define CLong bits32
+#elif SIZEOF_LONG == 8
+#define CLong bits64
+#else
+#error Unknown long size
+#endif
+
+#define CBool bits8
+
+#define F_   float32
+#define D_   float64
+#define L_   bits64
+#define V16_ bits128
+#define V32_ bits256
+#define V64_ bits512
+
+#define SIZEOF_StgDouble 8
+#define SIZEOF_StgWord64 8
+
+/* -----------------------------------------------------------------------------
+   Misc useful stuff
+   -------------------------------------------------------------------------- */
+
+#define ccall foreign "C"
+
+#define NULL (0::W_)
+
+#define STRING(name,str)                        \
+  section "rodata" {                            \
+        name : bits8[] str;                     \
+  }                                             \
+
+#if defined(TABLES_NEXT_TO_CODE)
+#define RET_LBL(f) f##_info
+#else
+#define RET_LBL(f) f##_ret
+#endif
+
+#if defined(TABLES_NEXT_TO_CODE)
+#define ENTRY_LBL(f) f##_info
+#else
+#define ENTRY_LBL(f) f##_entry
+#endif
+
+/* -----------------------------------------------------------------------------
+   Byte/word macros
+
+   Everything in C-- is in byte offsets (well, most things).  We use
+   some macros to allow us to express offsets in words and to try to
+   avoid byte/word confusion.
+   -------------------------------------------------------------------------- */
+
+#define SIZEOF_W  SIZEOF_VOID_P
+#define W_MASK    (SIZEOF_W-1)
+
+#if SIZEOF_W == 4
+#define W_SHIFT 2
+#elif SIZEOF_W == 8
+#define W_SHIFT 3
+#endif
+
+/* Converting quantities of words to bytes */
+#define WDS(n) ((n)*SIZEOF_W)
+
+/*
+ * Converting quantities of bytes to words
+ * NB. these work on *unsigned* values only
+ */
+#define BYTES_TO_WDS(n) ((n) / SIZEOF_W)
+#define ROUNDUP_BYTES_TO_WDS(n) (((n) + SIZEOF_W - 1) / SIZEOF_W)
+
+/* TO_W_(n) converts n to W_ type from a smaller type */
+#if SIZEOF_W == 4
+#define TO_I64(x) %sx64(x)
+#define TO_W_(x) %sx32(x)
+#define HALF_W_(x) %lobits16(x)
+#elif SIZEOF_W == 8
+#define TO_I64(x) (x)
+#define TO_W_(x) %sx64(x)
+#define HALF_W_(x) %lobits32(x)
+#endif
+
+#if SIZEOF_INT == 4 && SIZEOF_W == 8
+#define W_TO_INT(x) %lobits32(x)
+#elif SIZEOF_INT == SIZEOF_W
+#define W_TO_INT(x) (x)
+#endif
+
+#if SIZEOF_LONG == 4 && SIZEOF_W == 8
+#define W_TO_LONG(x) %lobits32(x)
+#elif SIZEOF_LONG == SIZEOF_W
+#define W_TO_LONG(x) (x)
+#endif
+
+/* -----------------------------------------------------------------------------
+   Atomic memory operations.
+   -------------------------------------------------------------------------- */
+
+#if SIZEOF_W == 4
+#define cmpxchgW cmpxchg32
+#elif SIZEOF_W == 8
+#define cmpxchgW cmpxchg64
+#endif
+
+/* -----------------------------------------------------------------------------
+   Heap/stack access, and adjusting the heap/stack pointers.
+   -------------------------------------------------------------------------- */
+
+#define Sp(n)  W_[Sp + WDS(n)]
+#define Hp(n)  W_[Hp + WDS(n)]
+
+#define Sp_adj(n) Sp = Sp + WDS(n)  /* pronounced "spadge" */
+#define Hp_adj(n) Hp = Hp + WDS(n)
+
+/* -----------------------------------------------------------------------------
+   Assertions and Debuggery
+   -------------------------------------------------------------------------- */
+
+#if defined(DEBUG)
+#define ASSERT(predicate)                       \
+        if (predicate) {                        \
+            /*null*/;                           \
+        } else {                                \
+            foreign "C" _assertFail(__FILE__, __LINE__) never returns; \
+        }
+#else
+#define ASSERT(p) /* nothing */
+#endif
+
+#if defined(DEBUG)
+#define DEBUG_ONLY(s) s
+#else
+#define DEBUG_ONLY(s) /* nothing */
+#endif
+
+/*
+ * The IF_DEBUG macro is useful for debug messages that depend on one
+ * of the RTS debug options.  For example:
+ *
+ *   IF_DEBUG(RtsFlags_DebugFlags_apply,
+ *      foreign "C" fprintf(stderr, stg_ap_0_ret_str));
+ *
+ * Note the syntax is slightly different to the C version of this macro.
+ */
+#if defined(DEBUG)
+#define IF_DEBUG(c,s)  if (RtsFlags_DebugFlags_##c(RtsFlags) != 0::CBool) { s; }
+#else
+#define IF_DEBUG(c,s)  /* nothing */
+#endif
+
+/* -----------------------------------------------------------------------------
+   Entering
+
+   It isn't safe to "enter" every closure.  Functions in particular
+   have no entry code as such; their entry point contains the code to
+   apply the function.
+
+   ToDo: range should end in N_CLOSURE_TYPES-1, not N_CLOSURE_TYPES,
+   but switch doesn't allow us to use exprs there yet.
+
+   If R1 points to a tagged object it points either to
+   * A constructor.
+   * A function with arity <= TAG_MASK.
+   In both cases the right thing to do is to return.
+   Note: it is rather lucky that we can use the tag bits to do this
+         for both objects. Maybe it points to a brittle design?
+
+   Indirections can contain tagged pointers, so their tag is checked.
+   -------------------------------------------------------------------------- */
+
+#if defined(PROFILING)
+
+// When profiling, we cannot shortcut ENTER() by checking the tag,
+// because LDV profiling relies on entering closures to mark them as
+// "used".
+
+#define LOAD_INFO(ret,x)                        \
+    info = %INFO_PTR(UNTAG(x));
+
+#define UNTAG_IF_PROF(x) UNTAG(x)
+
+#else
+
+#define LOAD_INFO(ret,x)                        \
+  if (GETTAG(x) != 0) {                         \
+      ret(x);                                   \
+  }                                             \
+  info = %INFO_PTR(x);
+
+#define UNTAG_IF_PROF(x) (x) /* already untagged */
+
+#endif
+
+// We need two versions of ENTER():
+//  - ENTER(x) takes the closure as an argument and uses return(),
+//    for use in civilized code where the stack is handled by GHC
+//
+//  - ENTER_NOSTACK() where the closure is in R1, and returns are
+//    explicit jumps, for use when we are doing the stack management
+//    ourselves.
+
+#if defined(PROFILING)
+// See Note [Evaluating functions with profiling] in rts/Apply.cmm
+#define ENTER(x) jump stg_ap_0_fast(x);
+#else
+#define ENTER(x) ENTER_(return,x)
+#endif
+
+#define ENTER_R1() ENTER_(RET_R1,R1)
+
+#define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1]
+
+#define ENTER_(ret,x)                                   \
+ again:                                                 \
+  W_ info;                                              \
+  LOAD_INFO(ret,x)                                       \
+  switch [INVALID_OBJECT .. N_CLOSURE_TYPES]            \
+         (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) {       \
+  case                                                  \
+    IND,                                                \
+    IND_STATIC:                                         \
+   {                                                    \
+      x = StgInd_indirectee(x);                         \
+      goto again;                                       \
+   }                                                    \
+  case                                                  \
+    FUN,                                                \
+    FUN_1_0,                                            \
+    FUN_0_1,                                            \
+    FUN_2_0,                                            \
+    FUN_1_1,                                            \
+    FUN_0_2,                                            \
+    FUN_STATIC,                                         \
+    BCO,                                                \
+    PAP:                                                \
+   {                                                    \
+       ret(x);                                          \
+   }                                                    \
+  default:                                              \
+   {                                                    \
+       x = UNTAG_IF_PROF(x);                            \
+       jump %ENTRY_CODE(info) (x);                      \
+   }                                                    \
+  }
+
+// The FUN cases almost never happen: a pointer to a non-static FUN
+// should always be tagged.  This unfortunately isn't true for the
+// interpreter right now, which leaves untagged FUNs on the stack.
+
+/* -----------------------------------------------------------------------------
+   Constants.
+   -------------------------------------------------------------------------- */
+
+#include "rts/Constants.h"
+#include "DerivedConstants.h"
+#include "rts/storage/ClosureTypes.h"
+#include "rts/storage/FunTypes.h"
+#include "rts/OSThreads.h"
+
+/*
+ * Need MachRegs, because some of the RTS code is conditionally
+ * compiled based on REG_R1, REG_R2, etc.
+ */
+#include "stg/RtsMachRegs.h"
+
+#include "rts/prof/LDV.h"
+
+#undef BLOCK_SIZE
+#undef MBLOCK_SIZE
+#include "rts/storage/Block.h"  /* For Bdescr() */
+
+
+#define MyCapability()  (BaseReg - OFFSET_Capability_r)
+
+/* -------------------------------------------------------------------------
+   Info tables
+   ------------------------------------------------------------------------- */
+
+#if defined(PROFILING)
+#define PROF_HDR_FIELDS(w_,hdr1,hdr2)          \
+  w_ hdr1,                                     \
+  w_ hdr2,
+#else
+#define PROF_HDR_FIELDS(w_,hdr1,hdr2) /* nothing */
+#endif
+
+/* -------------------------------------------------------------------------
+   Allocation and garbage collection
+   ------------------------------------------------------------------------- */
+
+/*
+ * ALLOC_PRIM is for allocating memory on the heap for a primitive
+ * object.  It is used all over PrimOps.cmm.
+ *
+ * We make the simplifying assumption that the "admin" part of a
+ * primitive closure is just the header when calculating sizes for
+ * ticky-ticky.  It's not clear whether eg. the size field of an array
+ * should be counted as "admin", or the various fields of a BCO.
+ */
+#define ALLOC_PRIM(bytes)                                       \
+   HP_CHK_GEN_TICKY(bytes);                                     \
+   TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0);  \
+   CCCS_ALLOC(bytes);
+
+#define HEAP_CHECK(bytes,failure)                       \
+    TICK_BUMP(HEAP_CHK_ctr);                            \
+    Hp = Hp + (bytes);                                  \
+    if (Hp > HpLim) { HpAlloc = (bytes); failure; }     \
+    TICK_ALLOC_HEAP_NOCTR(bytes);
+
+#define ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,failure)           \
+    HEAP_CHECK(bytes,failure)                                   \
+    TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \
+    CCCS_ALLOC(bytes);
+
+#define ALLOC_PRIM_(bytes,fun)                                  \
+    ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM(fun));
+
+#define ALLOC_PRIM_P(bytes,fun,arg)                             \
+    ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_P(fun,arg));
+
+#define ALLOC_PRIM_N(bytes,fun,arg)                             \
+    ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_N(fun,arg));
+
+/* CCS_ALLOC wants the size in words, because ccs->mem_alloc is in words */
+#define CCCS_ALLOC(__alloc) CCS_ALLOC(BYTES_TO_WDS(__alloc), CCCS)
+
+#define HP_CHK_GEN_TICKY(bytes)                 \
+   HP_CHK_GEN(bytes);                           \
+   TICK_ALLOC_HEAP_NOCTR(bytes);
+
+#define HP_CHK_P(bytes, fun, arg)               \
+   HEAP_CHECK(bytes, GC_PRIM_P(fun,arg))
+
+// TODO I'm not seeing where ALLOC_P_TICKY is used; can it be removed?
+//         -NSF March 2013
+#define ALLOC_P_TICKY(bytes, fun, arg)          \
+   HP_CHK_P(bytes);                             \
+   TICK_ALLOC_HEAP_NOCTR(bytes);
+
+#define CHECK_GC()                                                      \
+  (bdescr_link(CurrentNursery) == NULL ||                               \
+   generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim]))
+
+// allocate() allocates from the nursery, so we check to see
+// whether the nursery is nearly empty in any function that uses
+// allocate() - this includes many of the primops.
+//
+// HACK alert: the __L__ stuff is here to coax the common-block
+// eliminator into commoning up the call stg_gc_noregs() with the same
+// code that gets generated by a STK_CHK_GEN() in the same proc.  We
+// also need an if (0) { goto __L__; } so that the __L__ label isn't
+// optimised away by the control-flow optimiser prior to common-block
+// elimination (it will be optimised away later).
+//
+// This saves some code in gmp-wrappers.cmm where we have lots of
+// MAYBE_GC() in the same proc as STK_CHK_GEN().
+//
+#define MAYBE_GC(retry)                         \
+    if (CHECK_GC()) {                           \
+        HpAlloc = 0;                            \
+        goto __L__;                             \
+  __L__:                                        \
+        call stg_gc_noregs();                   \
+        goto retry;                             \
+   }                                            \
+   if (0) { goto __L__; }
+
+#define GC_PRIM(fun)                            \
+        jump stg_gc_prim(fun);
+
+// Version of GC_PRIM for use in low-level Cmm.  We can call
+// stg_gc_prim, because it takes one argument and therefore has a
+// platform-independent calling convention (Note [Syntax of .cmm
+// files] in CmmParse.y).
+#define GC_PRIM_LL(fun)                         \
+        R1 = fun;                               \
+        jump stg_gc_prim [R1];
+
+// We pass the fun as the second argument, because the arg is
+// usually already in the first argument position (R1), so this
+// avoids moving it to a different register / stack slot.
+#define GC_PRIM_N(fun,arg)                      \
+        jump stg_gc_prim_n(arg,fun);
+
+#define GC_PRIM_P(fun,arg)                      \
+        jump stg_gc_prim_p(arg,fun);
+
+#define GC_PRIM_P_LL(fun,arg)                   \
+        R1 = arg;                               \
+        R2 = fun;                               \
+        jump stg_gc_prim_p_ll [R1,R2];
+
+#define GC_PRIM_PP(fun,arg1,arg2)               \
+        jump stg_gc_prim_pp(arg1,arg2,fun);
+
+#define MAYBE_GC_(fun)                          \
+    if (CHECK_GC()) {                           \
+        HpAlloc = 0;                            \
+        GC_PRIM(fun)                            \
+   }
+
+#define MAYBE_GC_N(fun,arg)                     \
+    if (CHECK_GC()) {                           \
+        HpAlloc = 0;                            \
+        GC_PRIM_N(fun,arg)                      \
+   }
+
+#define MAYBE_GC_P(fun,arg)                     \
+    if (CHECK_GC()) {                           \
+        HpAlloc = 0;                            \
+        GC_PRIM_P(fun,arg)                      \
+   }
+
+#define MAYBE_GC_PP(fun,arg1,arg2)              \
+    if (CHECK_GC()) {                           \
+        HpAlloc = 0;                            \
+        GC_PRIM_PP(fun,arg1,arg2)               \
+   }
+
+#define STK_CHK_LL(n, fun)                      \
+    TICK_BUMP(STK_CHK_ctr);                     \
+    if (Sp - (n) < SpLim) {                     \
+        GC_PRIM_LL(fun)                         \
+    }
+
+#define STK_CHK_P_LL(n, fun, arg)               \
+    TICK_BUMP(STK_CHK_ctr);                     \
+    if (Sp - (n) < SpLim) {                     \
+        GC_PRIM_P_LL(fun,arg)                   \
+    }
+
+#define STK_CHK_PP(n, fun, arg1, arg2)          \
+    TICK_BUMP(STK_CHK_ctr);                     \
+    if (Sp - (n) < SpLim) {                     \
+        GC_PRIM_PP(fun,arg1,arg2)               \
+    }
+
+#define STK_CHK_ENTER(n, closure)               \
+    TICK_BUMP(STK_CHK_ctr);                     \
+    if (Sp - (n) < SpLim) {                     \
+        jump __stg_gc_enter_1(closure);         \
+    }
+
+// A funky heap check used by AutoApply.cmm
+
+#define HP_CHK_NP_ASSIGN_SP0(size,f)                    \
+    HEAP_CHECK(size, Sp(0) = f; jump __stg_gc_enter_1 [R1];)
+
+/* -----------------------------------------------------------------------------
+   Closure headers
+   -------------------------------------------------------------------------- */
+
+/*
+ * This is really ugly, since we don't do the rest of StgHeader this
+ * way.  The problem is that values from DerivedConstants.h cannot be
+ * dependent on the way (SMP, PROF etc.).  For SIZEOF_StgHeader we get
+ * the value from GHC, but it seems like too much trouble to do that
+ * for StgThunkHeader.
+ */
+#define SIZEOF_StgThunkHeader SIZEOF_StgHeader+SIZEOF_StgSMPThunkHeader
+
+#define StgThunk_payload(__ptr__,__ix__) \
+    W_[__ptr__+SIZEOF_StgThunkHeader+ WDS(__ix__)]
+
+/* -----------------------------------------------------------------------------
+   Closures
+   -------------------------------------------------------------------------- */
+
+/* The offset of the payload of an array */
+#define BYTE_ARR_CTS(arr)  ((arr) + SIZEOF_StgArrBytes)
+
+/* The number of words allocated in an array payload */
+#define BYTE_ARR_WDS(arr) ROUNDUP_BYTES_TO_WDS(StgArrBytes_bytes(arr))
+
+/* Getting/setting the info pointer of a closure */
+#define SET_INFO(p,info) StgHeader_info(p) = info
+#define GET_INFO(p) StgHeader_info(p)
+
+/* Determine the size of an ordinary closure from its info table */
+#define sizeW_fromITBL(itbl) \
+  SIZEOF_StgHeader + WDS(%INFO_PTRS(itbl)) + WDS(%INFO_NPTRS(itbl))
+
+/* NB. duplicated from InfoTables.h! */
+#define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK)
+#define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT)
+
+/* Debugging macros */
+#define LOOKS_LIKE_INFO_PTR(p)                                  \
+   ((p) != NULL &&                                              \
+    LOOKS_LIKE_INFO_PTR_NOT_NULL(p))
+
+#define LOOKS_LIKE_INFO_PTR_NOT_NULL(p)                         \
+   ( (TO_W_(%INFO_TYPE(%STD_INFO(p))) != INVALID_OBJECT) &&     \
+     (TO_W_(%INFO_TYPE(%STD_INFO(p))) <  N_CLOSURE_TYPES))
+
+#define LOOKS_LIKE_CLOSURE_PTR(p) (LOOKS_LIKE_INFO_PTR(GET_INFO(UNTAG(p))))
+
+/*
+ * The layout of the StgFunInfoExtra part of an info table changes
+ * depending on TABLES_NEXT_TO_CODE.  So we define field access
+ * macros which use the appropriate version here:
+ */
+#if defined(TABLES_NEXT_TO_CODE)
+/*
+ * when TABLES_NEXT_TO_CODE, slow_apply is stored as an offset
+ * instead of the normal pointer.
+ */
+
+#define StgFunInfoExtra_slow_apply(fun_info)    \
+        (TO_W_(StgFunInfoExtraRev_slow_apply_offset(fun_info))    \
+               + (fun_info) + SIZEOF_StgFunInfoExtraRev + SIZEOF_StgInfoTable)
+
+#define StgFunInfoExtra_fun_type(i)   StgFunInfoExtraRev_fun_type(i)
+#define StgFunInfoExtra_arity(i)      StgFunInfoExtraRev_arity(i)
+#define StgFunInfoExtra_bitmap(i)     StgFunInfoExtraRev_bitmap(i)
+#else
+#define StgFunInfoExtra_slow_apply(i) StgFunInfoExtraFwd_slow_apply(i)
+#define StgFunInfoExtra_fun_type(i)   StgFunInfoExtraFwd_fun_type(i)
+#define StgFunInfoExtra_arity(i)      StgFunInfoExtraFwd_arity(i)
+#define StgFunInfoExtra_bitmap(i)     StgFunInfoExtraFwd_bitmap(i)
+#endif
+
+#define mutArrCardMask ((1 << MUT_ARR_PTRS_CARD_BITS) - 1)
+#define mutArrPtrCardDown(i) ((i) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrCardUp(i)   (((i) + mutArrCardMask) >> MUT_ARR_PTRS_CARD_BITS)
+#define mutArrPtrsCardWords(n) ROUNDUP_BYTES_TO_WDS(mutArrPtrCardUp(n))
+
+#if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG))
+#define OVERWRITING_CLOSURE_SIZE(c, size) foreign "C" overwritingClosureSize(c "ptr", size)
+#define OVERWRITING_CLOSURE(c) foreign "C" overwritingClosure(c "ptr")
+#define OVERWRITING_CLOSURE_OFS(c,n) foreign "C" overwritingClosureOfs(c "ptr", n)
+#else
+#define OVERWRITING_CLOSURE_SIZE(c, size) /* nothing */
+#define OVERWRITING_CLOSURE(c) /* nothing */
+#define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */
+#endif
+
+#if defined(THREADED_RTS)
+#define prim_write_barrier prim %write_barrier()
+#else
+#define prim_write_barrier /* nothing */
+#endif
+
+/* -----------------------------------------------------------------------------
+   Ticky macros
+   -------------------------------------------------------------------------- */
+
+#if defined(TICKY_TICKY)
+#define TICK_BUMP_BY(ctr,n) CLong[ctr] = CLong[ctr] + n
+#else
+#define TICK_BUMP_BY(ctr,n) /* nothing */
+#endif
+
+#define TICK_BUMP(ctr)      TICK_BUMP_BY(ctr,1)
+
+#define TICK_ENT_DYN_IND()              TICK_BUMP(ENT_DYN_IND_ctr)
+#define TICK_ENT_DYN_THK()              TICK_BUMP(ENT_DYN_THK_ctr)
+#define TICK_ENT_VIA_NODE()             TICK_BUMP(ENT_VIA_NODE_ctr)
+#define TICK_ENT_STATIC_IND()           TICK_BUMP(ENT_STATIC_IND_ctr)
+#define TICK_ENT_PERM_IND()             TICK_BUMP(ENT_PERM_IND_ctr)
+#define TICK_ENT_PAP()                  TICK_BUMP(ENT_PAP_ctr)
+#define TICK_ENT_AP()                   TICK_BUMP(ENT_AP_ctr)
+#define TICK_ENT_AP_STACK()             TICK_BUMP(ENT_AP_STACK_ctr)
+#define TICK_ENT_BH()                   TICK_BUMP(ENT_BH_ctr)
+#define TICK_ENT_LNE()                  TICK_BUMP(ENT_LNE_ctr)
+#define TICK_UNKNOWN_CALL()             TICK_BUMP(UNKNOWN_CALL_ctr)
+#define TICK_UPDF_PUSHED()              TICK_BUMP(UPDF_PUSHED_ctr)
+#define TICK_CATCHF_PUSHED()            TICK_BUMP(CATCHF_PUSHED_ctr)
+#define TICK_UPDF_OMITTED()             TICK_BUMP(UPDF_OMITTED_ctr)
+#define TICK_UPD_NEW_IND()              TICK_BUMP(UPD_NEW_IND_ctr)
+#define TICK_UPD_NEW_PERM_IND()         TICK_BUMP(UPD_NEW_PERM_IND_ctr)
+#define TICK_UPD_OLD_IND()              TICK_BUMP(UPD_OLD_IND_ctr)
+#define TICK_UPD_OLD_PERM_IND()         TICK_BUMP(UPD_OLD_PERM_IND_ctr)
+
+#define TICK_SLOW_CALL_FUN_TOO_FEW()    TICK_BUMP(SLOW_CALL_FUN_TOO_FEW_ctr)
+#define TICK_SLOW_CALL_FUN_CORRECT()    TICK_BUMP(SLOW_CALL_FUN_CORRECT_ctr)
+#define TICK_SLOW_CALL_FUN_TOO_MANY()   TICK_BUMP(SLOW_CALL_FUN_TOO_MANY_ctr)
+#define TICK_SLOW_CALL_PAP_TOO_FEW()    TICK_BUMP(SLOW_CALL_PAP_TOO_FEW_ctr)
+#define TICK_SLOW_CALL_PAP_CORRECT()    TICK_BUMP(SLOW_CALL_PAP_CORRECT_ctr)
+#define TICK_SLOW_CALL_PAP_TOO_MANY()   TICK_BUMP(SLOW_CALL_PAP_TOO_MANY_ctr)
+
+#define TICK_SLOW_CALL_fast_v16()       TICK_BUMP(SLOW_CALL_fast_v16_ctr)
+#define TICK_SLOW_CALL_fast_v()         TICK_BUMP(SLOW_CALL_fast_v_ctr)
+#define TICK_SLOW_CALL_fast_p()         TICK_BUMP(SLOW_CALL_fast_p_ctr)
+#define TICK_SLOW_CALL_fast_pv()        TICK_BUMP(SLOW_CALL_fast_pv_ctr)
+#define TICK_SLOW_CALL_fast_pp()        TICK_BUMP(SLOW_CALL_fast_pp_ctr)
+#define TICK_SLOW_CALL_fast_ppv()       TICK_BUMP(SLOW_CALL_fast_ppv_ctr)
+#define TICK_SLOW_CALL_fast_ppp()       TICK_BUMP(SLOW_CALL_fast_ppp_ctr)
+#define TICK_SLOW_CALL_fast_pppv()      TICK_BUMP(SLOW_CALL_fast_pppv_ctr)
+#define TICK_SLOW_CALL_fast_pppp()      TICK_BUMP(SLOW_CALL_fast_pppp_ctr)
+#define TICK_SLOW_CALL_fast_ppppp()     TICK_BUMP(SLOW_CALL_fast_ppppp_ctr)
+#define TICK_SLOW_CALL_fast_pppppp()    TICK_BUMP(SLOW_CALL_fast_pppppp_ctr)
+#define TICK_VERY_SLOW_CALL()           TICK_BUMP(VERY_SLOW_CALL_ctr)
+
+/* NOTE: TICK_HISTO_BY and TICK_HISTO
+   currently have no effect.
+   The old code for it didn't typecheck and I
+   just commented it out to get ticky to work.
+   - krc 1/2007 */
+
+#define TICK_HISTO_BY(histo,n,i) /* nothing */
+
+#define TICK_HISTO(histo,n) TICK_HISTO_BY(histo,n,1)
+
+/* An unboxed tuple with n components. */
+#define TICK_RET_UNBOXED_TUP(n)                 \
+  TICK_BUMP(RET_UNBOXED_TUP_ctr++);             \
+  TICK_HISTO(RET_UNBOXED_TUP,n)
+
+/*
+ * A slow call with n arguments.  In the unevald case, this call has
+ * already been counted once, so don't count it again.
+ */
+#define TICK_SLOW_CALL(n)                       \
+  TICK_BUMP(SLOW_CALL_ctr);                     \
+  TICK_HISTO(SLOW_CALL,n)
+
+/*
+ * This slow call was found to be to an unevaluated function; undo the
+ * ticks we did in TICK_SLOW_CALL.
+ */
+#define TICK_SLOW_CALL_UNEVALD(n)               \
+  TICK_BUMP(SLOW_CALL_UNEVALD_ctr);             \
+  TICK_BUMP_BY(SLOW_CALL_ctr,-1);               \
+  TICK_HISTO_BY(SLOW_CALL,n,-1);
+
+/* Updating a closure with a new CON */
+#define TICK_UPD_CON_IN_NEW(n)                  \
+  TICK_BUMP(UPD_CON_IN_NEW_ctr);                \
+  TICK_HISTO(UPD_CON_IN_NEW,n)
+
+#define TICK_ALLOC_HEAP_NOCTR(bytes)            \
+    TICK_BUMP(ALLOC_RTS_ctr);                   \
+    TICK_BUMP_BY(ALLOC_RTS_tot,bytes)
+
+/* -----------------------------------------------------------------------------
+   Saving and restoring STG registers
+
+   STG registers must be saved around a C call, just in case the STG
+   register is mapped to a caller-saves machine register.  Normally we
+   don't need to worry about this the code generator has already
+   loaded any live STG registers into variables for us, but in
+   hand-written low-level Cmm code where we don't know which registers
+   are live, we might have to save them all.
+   -------------------------------------------------------------------------- */
+
+#define SAVE_STGREGS                            \
+    W_ r1, r2, r3,  r4,  r5,  r6,  r7,  r8;     \
+    F_ f1, f2, f3, f4, f5, f6;                  \
+    D_ d1, d2, d3, d4, d5, d6;                  \
+    L_ l1;                                      \
+                                                \
+    r1 = R1;                                    \
+    r2 = R2;                                    \
+    r3 = R3;                                    \
+    r4 = R4;                                    \
+    r5 = R5;                                    \
+    r6 = R6;                                    \
+    r7 = R7;                                    \
+    r8 = R8;                                    \
+                                                \
+    f1 = F1;                                    \
+    f2 = F2;                                    \
+    f3 = F3;                                    \
+    f4 = F4;                                    \
+    f5 = F5;                                    \
+    f6 = F6;                                    \
+                                                \
+    d1 = D1;                                    \
+    d2 = D2;                                    \
+    d3 = D3;                                    \
+    d4 = D4;                                    \
+    d5 = D5;                                    \
+    d6 = D6;                                    \
+                                                \
+    l1 = L1;
+
+
+#define RESTORE_STGREGS                         \
+    R1 = r1;                                    \
+    R2 = r2;                                    \
+    R3 = r3;                                    \
+    R4 = r4;                                    \
+    R5 = r5;                                    \
+    R6 = r6;                                    \
+    R7 = r7;                                    \
+    R8 = r8;                                    \
+                                                \
+    F1 = f1;                                    \
+    F2 = f2;                                    \
+    F3 = f3;                                    \
+    F4 = f4;                                    \
+    F5 = f5;                                    \
+    F6 = f6;                                    \
+                                                \
+    D1 = d1;                                    \
+    D2 = d2;                                    \
+    D3 = d3;                                    \
+    D4 = d4;                                    \
+    D5 = d5;                                    \
+    D6 = d6;                                    \
+                                                \
+    L1 = l1;
+
+/* -----------------------------------------------------------------------------
+   Misc junk
+   -------------------------------------------------------------------------- */
+
+#define NO_TREC                   stg_NO_TREC_closure
+#define END_TSO_QUEUE             stg_END_TSO_QUEUE_closure
+#define STM_AWOKEN                stg_STM_AWOKEN_closure
+
+#define recordMutableCap(p, gen)                                        \
+  W_ __bd;                                                              \
+  W_ mut_list;                                                          \
+  mut_list = Capability_mut_lists(MyCapability()) + WDS(gen);           \
+ __bd = W_[mut_list];                                                   \
+  if (bdescr_free(__bd) >= bdescr_start(__bd) + BLOCK_SIZE) {           \
+      W_ __new_bd;                                                      \
+      ("ptr" __new_bd) = foreign "C" allocBlock_lock();                 \
+      bdescr_link(__new_bd) = __bd;                                     \
+      __bd = __new_bd;                                                  \
+      W_[mut_list] = __bd;                                              \
+  }                                                                     \
+  W_ free;                                                              \
+  free = bdescr_free(__bd);                                             \
+  W_[free] = p;                                                         \
+  bdescr_free(__bd) = free + WDS(1);
+
+#define recordMutable(p)                                        \
+      P_ __p;                                                   \
+      W_ __bd;                                                  \
+      W_ __gen;                                                 \
+      __p = p;                                                  \
+      __bd = Bdescr(__p);                                       \
+      __gen = TO_W_(bdescr_gen_no(__bd));                       \
+      if (__gen > 0) { recordMutableCap(__p, __gen); }
+
+/* -----------------------------------------------------------------------------
+   Arrays
+   -------------------------------------------------------------------------- */
+
+/* Complete function body for the clone family of (mutable) array ops.
+   Defined as a macro to avoid function call overhead or code
+   duplication. */
+#define cloneArray(info, src, offset, n)                       \
+    W_ words, size;                                            \
+    gcptr dst, dst_p, src_p;                                   \
+                                                               \
+    again: MAYBE_GC(again);                                    \
+                                                               \
+    size = n + mutArrPtrsCardWords(n);                         \
+    words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size;         \
+    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \
+    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);       \
+                                                               \
+    SET_HDR(dst, info, CCCS);                                  \
+    StgMutArrPtrs_ptrs(dst) = n;                               \
+    StgMutArrPtrs_size(dst) = size;                            \
+                                                               \
+    dst_p = dst + SIZEOF_StgMutArrPtrs;                        \
+    src_p = src + SIZEOF_StgMutArrPtrs + WDS(offset);          \
+    prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W);        \
+                                                               \
+    return (dst);
+
+#define copyArray(src, src_off, dst, dst_off, n)                  \
+  W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes;               \
+                                                                  \
+    if ((n) != 0) {                                               \
+        SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);          \
+                                                                  \
+        dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs;               \
+        dst_p = dst_elems_p + WDS(dst_off);                       \
+        src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off);      \
+        bytes = WDS(n);                                           \
+                                                                  \
+        prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);              \
+                                                                  \
+        dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \
+        setCards(dst_cards_p, dst_off, n);                        \
+    }                                                             \
+                                                                  \
+    return ();
+
+#define copyMutableArray(src, src_off, dst, dst_off, n)           \
+  W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes;               \
+                                                                  \
+    if ((n) != 0) {                                               \
+        SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);          \
+                                                                  \
+        dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs;               \
+        dst_p = dst_elems_p + WDS(dst_off);                       \
+        src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off);      \
+        bytes = WDS(n);                                           \
+                                                                  \
+        if ((src) == (dst)) {                                     \
+            prim %memmove(dst_p, src_p, bytes, SIZEOF_W);         \
+        } else {                                                  \
+            prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);          \
+        }                                                         \
+                                                                  \
+        dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \
+        setCards(dst_cards_p, dst_off, n);                        \
+    }                                                             \
+                                                                  \
+    return ();
+
+/*
+ * Set the cards in the cards table pointed to by dst_cards_p for an
+ * update to n elements, starting at element dst_off.
+ */
+#define setCards(dst_cards_p, dst_off, n)                      \
+    W_ __start_card, __end_card, __cards;                      \
+    __start_card = mutArrPtrCardDown(dst_off);                 \
+    __end_card = mutArrPtrCardDown((dst_off) + (n) - 1);       \
+    __cards = __end_card - __start_card + 1;                   \
+    prim %memset((dst_cards_p) + __start_card, 1, __cards, 1);
+
+/* Complete function body for the clone family of small (mutable)
+   array ops. Defined as a macro to avoid function call overhead or
+   code duplication. */
+#define cloneSmallArray(info, src, offset, n)                  \
+    W_ words, size;                                            \
+    gcptr dst, dst_p, src_p;                                   \
+                                                               \
+    again: MAYBE_GC(again);                                    \
+                                                               \
+    words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + n;       \
+    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \
+    TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(n), 0);     \
+                                                               \
+    SET_HDR(dst, info, CCCS);                                  \
+    StgSmallMutArrPtrs_ptrs(dst) = n;                          \
+                                                               \
+    dst_p = dst + SIZEOF_StgSmallMutArrPtrs;                   \
+    src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(offset);     \
+    prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W);        \
+                                                               \
+    return (dst);
diff --git a/includes/CodeGen.Platform.hs b/includes/CodeGen.Platform.hs
new file mode 100644
--- /dev/null
+++ b/includes/CodeGen.Platform.hs
@@ -0,0 +1,1141 @@
+
+import CmmExpr
+#if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \
+    || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc))
+import Panic
+#endif
+import Reg
+
+#include "ghcautoconf.h"
+#include "stg/MachRegs.h"
+
+#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)
+
+# if defined(MACHREGS_i386)
+#  define eax 0
+#  define ebx 1
+#  define ecx 2
+#  define edx 3
+#  define esi 4
+#  define edi 5
+#  define ebp 6
+#  define esp 7
+# endif
+
+# if defined(MACHREGS_x86_64)
+#  define rax   0
+#  define rbx   1
+#  define rcx   2
+#  define rdx   3
+#  define rsi   4
+#  define rdi   5
+#  define rbp   6
+#  define rsp   7
+#  define r8    8
+#  define r9    9
+#  define r10   10
+#  define r11   11
+#  define r12   12
+#  define r13   13
+#  define r14   14
+#  define r15   15
+# endif
+
+# define fake0 16
+# define fake1 17
+# define fake2 18
+# define fake3 19
+# define fake4 20
+# define fake5 21
+
+-- N.B. XMM, YMM, and ZMM are all aliased to the same hardware registers hence
+-- being assigned the same RegNos.
+# define xmm0  24
+# define xmm1  25
+# define xmm2  26
+# define xmm3  27
+# define xmm4  28
+# define xmm5  29
+# define xmm6  30
+# define xmm7  31
+# define xmm8  32
+# define xmm9  33
+# define xmm10 34
+# define xmm11 35
+# define xmm12 36
+# define xmm13 37
+# define xmm14 38
+# define xmm15 39
+
+# define ymm0  24
+# define ymm1  25
+# define ymm2  26
+# define ymm3  27
+# define ymm4  28
+# define ymm5  29
+# define ymm6  30
+# define ymm7  31
+# define ymm8  32
+# define ymm9  33
+# define ymm10 34
+# define ymm11 35
+# define ymm12 36
+# define ymm13 37
+# define ymm14 38
+# define ymm15 39
+
+# define zmm0  24
+# define zmm1  25
+# define zmm2  26
+# define zmm3  27
+# define zmm4  28
+# define zmm5  29
+# define zmm6  30
+# define zmm7  31
+# define zmm8  32
+# define zmm9  33
+# define zmm10 34
+# define zmm11 35
+# define zmm12 36
+# define zmm13 37
+# define zmm14 38
+# define zmm15 39
+
+-- Note: these are only needed for ARM/ARM64 because globalRegMaybe is now used in CmmSink.hs.
+-- Since it's only used to check 'isJust', the actual values don't matter, thus
+-- I'm not sure if these are the correct numberings.
+-- Normally, the register names are just stringified as part of the REG() macro
+
+#elif defined(MACHREGS_powerpc) || defined(MACHREGS_arm) \
+    || defined(MACHREGS_aarch64)
+
+# define r0 0
+# define r1 1
+# define r2 2
+# define r3 3
+# define r4 4
+# define r5 5
+# define r6 6
+# define r7 7
+# define r8 8
+# define r9 9
+# define r10 10
+# define r11 11
+# define r12 12
+# define r13 13
+# define r14 14
+# define r15 15
+# define r16 16
+# define r17 17
+# define r18 18
+# define r19 19
+# define r20 20
+# define r21 21
+# define r22 22
+# define r23 23
+# define r24 24
+# define r25 25
+# define r26 26
+# define r27 27
+# define r28 28
+# define r29 29
+# define r30 30
+# define r31 31
+
+-- See note above. These aren't actually used for anything except satisfying the compiler for globalRegMaybe
+-- so I'm unsure if they're the correct numberings, should they ever be attempted to be used in the NCG.
+#if defined(MACHREGS_aarch64) || defined(MACHREGS_arm)
+# define s0 32
+# define s1 33
+# define s2 34
+# define s3 35
+# define s4 36
+# define s5 37
+# define s6 38
+# define s7 39
+# define s8 40
+# define s9 41
+# define s10 42
+# define s11 43
+# define s12 44
+# define s13 45
+# define s14 46
+# define s15 47
+# define s16 48
+# define s17 49
+# define s18 50
+# define s19 51
+# define s20 52
+# define s21 53
+# define s22 54
+# define s23 55
+# define s24 56
+# define s25 57
+# define s26 58
+# define s27 59
+# define s28 60
+# define s29 61
+# define s30 62
+# define s31 63
+
+# define d0 32
+# define d1 33
+# define d2 34
+# define d3 35
+# define d4 36
+# define d5 37
+# define d6 38
+# define d7 39
+# define d8 40
+# define d9 41
+# define d10 42
+# define d11 43
+# define d12 44
+# define d13 45
+# define d14 46
+# define d15 47
+# define d16 48
+# define d17 49
+# define d18 50
+# define d19 51
+# define d20 52
+# define d21 53
+# define d22 54
+# define d23 55
+# define d24 56
+# define d25 57
+# define d26 58
+# define d27 59
+# define d28 60
+# define d29 61
+# define d30 62
+# define d31 63
+#endif
+
+# if defined(MACHREGS_darwin)
+#  define f0  32
+#  define f1  33
+#  define f2  34
+#  define f3  35
+#  define f4  36
+#  define f5  37
+#  define f6  38
+#  define f7  39
+#  define f8  40
+#  define f9  41
+#  define f10 42
+#  define f11 43
+#  define f12 44
+#  define f13 45
+#  define f14 46
+#  define f15 47
+#  define f16 48
+#  define f17 49
+#  define f18 50
+#  define f19 51
+#  define f20 52
+#  define f21 53
+#  define f22 54
+#  define f23 55
+#  define f24 56
+#  define f25 57
+#  define f26 58
+#  define f27 59
+#  define f28 60
+#  define f29 61
+#  define f30 62
+#  define f31 63
+# else
+#  define fr0  32
+#  define fr1  33
+#  define fr2  34
+#  define fr3  35
+#  define fr4  36
+#  define fr5  37
+#  define fr6  38
+#  define fr7  39
+#  define fr8  40
+#  define fr9  41
+#  define fr10 42
+#  define fr11 43
+#  define fr12 44
+#  define fr13 45
+#  define fr14 46
+#  define fr15 47
+#  define fr16 48
+#  define fr17 49
+#  define fr18 50
+#  define fr19 51
+#  define fr20 52
+#  define fr21 53
+#  define fr22 54
+#  define fr23 55
+#  define fr24 56
+#  define fr25 57
+#  define fr26 58
+#  define fr27 59
+#  define fr28 60
+#  define fr29 61
+#  define fr30 62
+#  define fr31 63
+# endif
+
+#elif defined(MACHREGS_sparc)
+
+# define g0  0
+# define g1  1
+# define g2  2
+# define g3  3
+# define g4  4
+# define g5  5
+# define g6  6
+# define g7  7
+
+# define o0  8
+# define o1  9
+# define o2  10
+# define o3  11
+# define o4  12
+# define o5  13
+# define o6  14
+# define o7  15
+
+# define l0  16
+# define l1  17
+# define l2  18
+# define l3  19
+# define l4  20
+# define l5  21
+# define l6  22
+# define l7  23
+
+# define i0  24
+# define i1  25
+# define i2  26
+# define i3  27
+# define i4  28
+# define i5  29
+# define i6  30
+# define i7  31
+
+# define f0  32
+# define f1  33
+# define f2  34
+# define f3  35
+# define f4  36
+# define f5  37
+# define f6  38
+# define f7  39
+# define f8  40
+# define f9  41
+# define f10 42
+# define f11 43
+# define f12 44
+# define f13 45
+# define f14 46
+# define f15 47
+# define f16 48
+# define f17 49
+# define f18 50
+# define f19 51
+# define f20 52
+# define f21 53
+# define f22 54
+# define f23 55
+# define f24 56
+# define f25 57
+# define f26 58
+# define f27 59
+# define f28 60
+# define f29 61
+# define f30 62
+# define f31 63
+
+#endif
+
+callerSaves :: GlobalReg -> Bool
+#if defined(CALLER_SAVES_Base)
+callerSaves BaseReg           = True
+#endif
+#if defined(CALLER_SAVES_R1)
+callerSaves (VanillaReg 1 _)  = True
+#endif
+#if defined(CALLER_SAVES_R2)
+callerSaves (VanillaReg 2 _)  = True
+#endif
+#if defined(CALLER_SAVES_R3)
+callerSaves (VanillaReg 3 _)  = True
+#endif
+#if defined(CALLER_SAVES_R4)
+callerSaves (VanillaReg 4 _)  = True
+#endif
+#if defined(CALLER_SAVES_R5)
+callerSaves (VanillaReg 5 _)  = True
+#endif
+#if defined(CALLER_SAVES_R6)
+callerSaves (VanillaReg 6 _)  = True
+#endif
+#if defined(CALLER_SAVES_R7)
+callerSaves (VanillaReg 7 _)  = True
+#endif
+#if defined(CALLER_SAVES_R8)
+callerSaves (VanillaReg 8 _)  = True
+#endif
+#if defined(CALLER_SAVES_R9)
+callerSaves (VanillaReg 9 _)  = True
+#endif
+#if defined(CALLER_SAVES_R10)
+callerSaves (VanillaReg 10 _) = True
+#endif
+#if defined(CALLER_SAVES_F1)
+callerSaves (FloatReg 1)      = True
+#endif
+#if defined(CALLER_SAVES_F2)
+callerSaves (FloatReg 2)      = True
+#endif
+#if defined(CALLER_SAVES_F3)
+callerSaves (FloatReg 3)      = True
+#endif
+#if defined(CALLER_SAVES_F4)
+callerSaves (FloatReg 4)      = True
+#endif
+#if defined(CALLER_SAVES_F5)
+callerSaves (FloatReg 5)      = True
+#endif
+#if defined(CALLER_SAVES_F6)
+callerSaves (FloatReg 6)      = True
+#endif
+#if defined(CALLER_SAVES_D1)
+callerSaves (DoubleReg 1)     = True
+#endif
+#if defined(CALLER_SAVES_D2)
+callerSaves (DoubleReg 2)     = True
+#endif
+#if defined(CALLER_SAVES_D3)
+callerSaves (DoubleReg 3)     = True
+#endif
+#if defined(CALLER_SAVES_D4)
+callerSaves (DoubleReg 4)     = True
+#endif
+#if defined(CALLER_SAVES_D5)
+callerSaves (DoubleReg 5)     = True
+#endif
+#if defined(CALLER_SAVES_D6)
+callerSaves (DoubleReg 6)     = True
+#endif
+#if defined(CALLER_SAVES_L1)
+callerSaves (LongReg 1)       = True
+#endif
+#if defined(CALLER_SAVES_Sp)
+callerSaves Sp                = True
+#endif
+#if defined(CALLER_SAVES_SpLim)
+callerSaves SpLim             = True
+#endif
+#if defined(CALLER_SAVES_Hp)
+callerSaves Hp                = True
+#endif
+#if defined(CALLER_SAVES_HpLim)
+callerSaves HpLim             = True
+#endif
+#if defined(CALLER_SAVES_CCCS)
+callerSaves CCCS              = True
+#endif
+#if defined(CALLER_SAVES_CurrentTSO)
+callerSaves CurrentTSO        = True
+#endif
+#if defined(CALLER_SAVES_CurrentNursery)
+callerSaves CurrentNursery    = True
+#endif
+callerSaves _                 = False
+
+activeStgRegs :: [GlobalReg]
+activeStgRegs = [
+#if defined(REG_Base)
+    BaseReg
+#endif
+#if defined(REG_Sp)
+    ,Sp
+#endif
+#if defined(REG_Hp)
+    ,Hp
+#endif
+#if defined(REG_R1)
+    ,VanillaReg 1 VGcPtr
+#endif
+#if defined(REG_R2)
+    ,VanillaReg 2 VGcPtr
+#endif
+#if defined(REG_R3)
+    ,VanillaReg 3 VGcPtr
+#endif
+#if defined(REG_R4)
+    ,VanillaReg 4 VGcPtr
+#endif
+#if defined(REG_R5)
+    ,VanillaReg 5 VGcPtr
+#endif
+#if defined(REG_R6)
+    ,VanillaReg 6 VGcPtr
+#endif
+#if defined(REG_R7)
+    ,VanillaReg 7 VGcPtr
+#endif
+#if defined(REG_R8)
+    ,VanillaReg 8 VGcPtr
+#endif
+#if defined(REG_R9)
+    ,VanillaReg 9 VGcPtr
+#endif
+#if defined(REG_R10)
+    ,VanillaReg 10 VGcPtr
+#endif
+#if defined(REG_SpLim)
+    ,SpLim
+#endif
+#if MAX_REAL_XMM_REG != 0
+#if defined(REG_F1)
+    ,FloatReg 1
+#endif
+#if defined(REG_D1)
+    ,DoubleReg 1
+#endif
+#if defined(REG_XMM1)
+    ,XmmReg 1
+#endif
+#if defined(REG_YMM1)
+    ,YmmReg 1
+#endif
+#if defined(REG_ZMM1)
+    ,ZmmReg 1
+#endif
+#if defined(REG_F2)
+    ,FloatReg 2
+#endif
+#if defined(REG_D2)
+    ,DoubleReg 2
+#endif
+#if defined(REG_XMM2)
+    ,XmmReg 2
+#endif
+#if defined(REG_YMM2)
+    ,YmmReg 2
+#endif
+#if defined(REG_ZMM2)
+    ,ZmmReg 2
+#endif
+#if defined(REG_F3)
+    ,FloatReg 3
+#endif
+#if defined(REG_D3)
+    ,DoubleReg 3
+#endif
+#if defined(REG_XMM3)
+    ,XmmReg 3
+#endif
+#if defined(REG_YMM3)
+    ,YmmReg 3
+#endif
+#if defined(REG_ZMM3)
+    ,ZmmReg 3
+#endif
+#if defined(REG_F4)
+    ,FloatReg 4
+#endif
+#if defined(REG_D4)
+    ,DoubleReg 4
+#endif
+#if defined(REG_XMM4)
+    ,XmmReg 4
+#endif
+#if defined(REG_YMM4)
+    ,YmmReg 4
+#endif
+#if defined(REG_ZMM4)
+    ,ZmmReg 4
+#endif
+#if defined(REG_F5)
+    ,FloatReg 5
+#endif
+#if defined(REG_D5)
+    ,DoubleReg 5
+#endif
+#if defined(REG_XMM5)
+    ,XmmReg 5
+#endif
+#if defined(REG_YMM5)
+    ,YmmReg 5
+#endif
+#if defined(REG_ZMM5)
+    ,ZmmReg 5
+#endif
+#if defined(REG_F6)
+    ,FloatReg 6
+#endif
+#if defined(REG_D6)
+    ,DoubleReg 6
+#endif
+#if defined(REG_XMM6)
+    ,XmmReg 6
+#endif
+#if defined(REG_YMM6)
+    ,YmmReg 6
+#endif
+#if defined(REG_ZMM6)
+    ,ZmmReg 6
+#endif
+#else /* MAX_REAL_XMM_REG == 0 */
+#if defined(REG_F1)
+    ,FloatReg 1
+#endif
+#if defined(REG_F2)
+    ,FloatReg 2
+#endif
+#if defined(REG_F3)
+    ,FloatReg 3
+#endif
+#if defined(REG_F4)
+    ,FloatReg 4
+#endif
+#if defined(REG_F5)
+    ,FloatReg 5
+#endif
+#if defined(REG_F6)
+    ,FloatReg 6
+#endif
+#if defined(REG_D1)
+    ,DoubleReg 1
+#endif
+#if defined(REG_D2)
+    ,DoubleReg 2
+#endif
+#if defined(REG_D3)
+    ,DoubleReg 3
+#endif
+#if defined(REG_D4)
+    ,DoubleReg 4
+#endif
+#if defined(REG_D5)
+    ,DoubleReg 5
+#endif
+#if defined(REG_D6)
+    ,DoubleReg 6
+#endif
+#endif /* MAX_REAL_XMM_REG == 0 */
+    ]
+
+haveRegBase :: Bool
+#if defined(REG_Base)
+haveRegBase = True
+#else
+haveRegBase = False
+#endif
+
+--  | Returns 'Nothing' if this global register is not stored
+-- in a real machine register, otherwise returns @'Just' reg@, where
+-- reg is the machine register it is stored in.
+globalRegMaybe :: GlobalReg -> Maybe RealReg
+#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \
+    || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc) \
+    || defined(MACHREGS_arm) || defined(MACHREGS_aarch64)
+# if defined(REG_Base)
+globalRegMaybe BaseReg                  = Just (RealRegSingle REG_Base)
+# endif
+# if defined(REG_R1)
+globalRegMaybe (VanillaReg 1 _)         = Just (RealRegSingle REG_R1)
+# endif
+# if defined(REG_R2)
+globalRegMaybe (VanillaReg 2 _)         = Just (RealRegSingle REG_R2)
+# endif
+# if defined(REG_R3)
+globalRegMaybe (VanillaReg 3 _)         = Just (RealRegSingle REG_R3)
+# endif
+# if defined(REG_R4)
+globalRegMaybe (VanillaReg 4 _)         = Just (RealRegSingle REG_R4)
+# endif
+# if defined(REG_R5)
+globalRegMaybe (VanillaReg 5 _)         = Just (RealRegSingle REG_R5)
+# endif
+# if defined(REG_R6)
+globalRegMaybe (VanillaReg 6 _)         = Just (RealRegSingle REG_R6)
+# endif
+# if defined(REG_R7)
+globalRegMaybe (VanillaReg 7 _)         = Just (RealRegSingle REG_R7)
+# endif
+# if defined(REG_R8)
+globalRegMaybe (VanillaReg 8 _)         = Just (RealRegSingle REG_R8)
+# endif
+# if defined(REG_R9)
+globalRegMaybe (VanillaReg 9 _)         = Just (RealRegSingle REG_R9)
+# endif
+# if defined(REG_R10)
+globalRegMaybe (VanillaReg 10 _)        = Just (RealRegSingle REG_R10)
+# endif
+# if defined(REG_F1)
+globalRegMaybe (FloatReg 1)             = Just (RealRegSingle REG_F1)
+# endif
+# if defined(REG_F2)
+globalRegMaybe (FloatReg 2)             = Just (RealRegSingle REG_F2)
+# endif
+# if defined(REG_F3)
+globalRegMaybe (FloatReg 3)             = Just (RealRegSingle REG_F3)
+# endif
+# if defined(REG_F4)
+globalRegMaybe (FloatReg 4)             = Just (RealRegSingle REG_F4)
+# endif
+# if defined(REG_F5)
+globalRegMaybe (FloatReg 5)             = Just (RealRegSingle REG_F5)
+# endif
+# if defined(REG_F6)
+globalRegMaybe (FloatReg 6)             = Just (RealRegSingle REG_F6)
+# endif
+# if defined(REG_D1)
+globalRegMaybe (DoubleReg 1)            =
+#  if defined(MACHREGS_sparc)
+                                          Just (RealRegPair REG_D1 (REG_D1 + 1))
+#  else
+                                          Just (RealRegSingle REG_D1)
+#  endif
+# endif
+# if defined(REG_D2)
+globalRegMaybe (DoubleReg 2)            =
+#  if defined(MACHREGS_sparc)
+                                          Just (RealRegPair REG_D2 (REG_D2 + 1))
+#  else
+                                          Just (RealRegSingle REG_D2)
+#  endif
+# endif
+# if defined(REG_D3)
+globalRegMaybe (DoubleReg 3)            =
+#  if defined(MACHREGS_sparc)
+                                          Just (RealRegPair REG_D3 (REG_D3 + 1))
+#  else
+                                          Just (RealRegSingle REG_D3)
+#  endif
+# endif
+# if defined(REG_D4)
+globalRegMaybe (DoubleReg 4)            =
+#  if defined(MACHREGS_sparc)
+                                          Just (RealRegPair REG_D4 (REG_D4 + 1))
+#  else
+                                          Just (RealRegSingle REG_D4)
+#  endif
+# endif
+# if defined(REG_D5)
+globalRegMaybe (DoubleReg 5)            =
+#  if defined(MACHREGS_sparc)
+                                          Just (RealRegPair REG_D5 (REG_D5 + 1))
+#  else
+                                          Just (RealRegSingle REG_D5)
+#  endif
+# endif
+# if defined(REG_D6)
+globalRegMaybe (DoubleReg 6)            =
+#  if defined(MACHREGS_sparc)
+                                          Just (RealRegPair REG_D6 (REG_D6 + 1))
+#  else
+                                          Just (RealRegSingle REG_D6)
+#  endif
+# endif
+# if MAX_REAL_XMM_REG != 0
+#  if defined(REG_XMM1)
+globalRegMaybe (XmmReg 1)               = Just (RealRegSingle REG_XMM1)
+#  endif
+#  if defined(REG_XMM2)
+globalRegMaybe (XmmReg 2)               = Just (RealRegSingle REG_XMM2)
+#  endif
+#  if defined(REG_XMM3)
+globalRegMaybe (XmmReg 3)               = Just (RealRegSingle REG_XMM3)
+#  endif
+#  if defined(REG_XMM4)
+globalRegMaybe (XmmReg 4)               = Just (RealRegSingle REG_XMM4)
+#  endif
+#  if defined(REG_XMM5)
+globalRegMaybe (XmmReg 5)               = Just (RealRegSingle REG_XMM5)
+#  endif
+#  if defined(REG_XMM6)
+globalRegMaybe (XmmReg 6)               = Just (RealRegSingle REG_XMM6)
+#  endif
+# endif
+# if defined(MAX_REAL_YMM_REG) && MAX_REAL_YMM_REG != 0
+#  if defined(REG_YMM1)
+globalRegMaybe (YmmReg 1)               = Just (RealRegSingle REG_YMM1)
+#  endif
+#  if defined(REG_YMM2)
+globalRegMaybe (YmmReg 2)               = Just (RealRegSingle REG_YMM2)
+#  endif
+#  if defined(REG_YMM3)
+globalRegMaybe (YmmReg 3)               = Just (RealRegSingle REG_YMM3)
+#  endif
+#  if defined(REG_YMM4)
+globalRegMaybe (YmmReg 4)               = Just (RealRegSingle REG_YMM4)
+#  endif
+#  if defined(REG_YMM5)
+globalRegMaybe (YmmReg 5)               = Just (RealRegSingle REG_YMM5)
+#  endif
+#  if defined(REG_YMM6)
+globalRegMaybe (YmmReg 6)               = Just (RealRegSingle REG_YMM6)
+#  endif
+# endif
+# if defined(MAX_REAL_ZMM_REG) && MAX_REAL_ZMM_REG != 0
+#  if defined(REG_ZMM1)
+globalRegMaybe (ZmmReg 1)               = Just (RealRegSingle REG_ZMM1)
+#  endif
+#  if defined(REG_ZMM2)
+globalRegMaybe (ZmmReg 2)               = Just (RealRegSingle REG_ZMM2)
+#  endif
+#  if defined(REG_ZMM3)
+globalRegMaybe (ZmmReg 3)               = Just (RealRegSingle REG_ZMM3)
+#  endif
+#  if defined(REG_ZMM4)
+globalRegMaybe (ZmmReg 4)               = Just (RealRegSingle REG_ZMM4)
+#  endif
+#  if defined(REG_ZMM5)
+globalRegMaybe (ZmmReg 5)               = Just (RealRegSingle REG_ZMM5)
+#  endif
+#  if defined(REG_ZMM6)
+globalRegMaybe (ZmmReg 6)               = Just (RealRegSingle REG_ZMM6)
+#  endif
+# endif
+# if defined(REG_Sp)
+globalRegMaybe Sp                       = Just (RealRegSingle REG_Sp)
+# endif
+# if defined(REG_Lng1)
+globalRegMaybe (LongReg 1)              = Just (RealRegSingle REG_Lng1)
+# endif
+# if defined(REG_Lng2)
+globalRegMaybe (LongReg 2)              = Just (RealRegSingle REG_Lng2)
+# endif
+# if defined(REG_SpLim)
+globalRegMaybe SpLim                    = Just (RealRegSingle REG_SpLim)
+# endif
+# if defined(REG_Hp)
+globalRegMaybe Hp                       = Just (RealRegSingle REG_Hp)
+# endif
+# if defined(REG_HpLim)
+globalRegMaybe HpLim                    = Just (RealRegSingle REG_HpLim)
+# endif
+# if defined(REG_CurrentTSO)
+globalRegMaybe CurrentTSO               = Just (RealRegSingle REG_CurrentTSO)
+# endif
+# if defined(REG_CurrentNursery)
+globalRegMaybe CurrentNursery           = Just (RealRegSingle REG_CurrentNursery)
+# endif
+# if defined(REG_MachSp)
+globalRegMaybe MachSp                   = Just (RealRegSingle REG_MachSp)
+# endif
+globalRegMaybe _                        = Nothing
+#elif defined(MACHREGS_NO_REGS)
+globalRegMaybe _ = Nothing
+#else
+globalRegMaybe = panic "globalRegMaybe not defined for this platform"
+#endif
+
+freeReg :: RegNo -> Bool
+
+#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)
+
+# if defined(MACHREGS_i386)
+freeReg esp = False -- %esp is the C stack pointer
+freeReg esi = False -- Note [esi/edi/ebp not allocatable]
+freeReg edi = False
+freeReg ebp = False
+# endif
+# if defined(MACHREGS_x86_64)
+freeReg rsp = False  --        %rsp is the C stack pointer
+# endif
+
+{-
+Note [esi/edi/ebp not allocatable]
+
+%esi is mapped to R1, so %esi would normally be allocatable while it
+is not being used for R1.  However, %esi has no 8-bit version on x86,
+and the linear register allocator is not sophisticated enough to
+handle this irregularity (we need more RegClasses).  The
+graph-colouring allocator also cannot handle this - it was designed
+with more flexibility in mind, but the current implementation is
+restricted to the same set of classes as the linear allocator.
+
+Hence, on x86 esi, edi and ebp are treated as not allocatable.
+-}
+
+-- split patterns in two functions to prevent overlaps
+freeReg r         = freeRegBase r
+
+freeRegBase :: RegNo -> Bool
+# if defined(REG_Base)
+freeRegBase REG_Base  = False
+# endif
+# if defined(REG_Sp)
+freeRegBase REG_Sp    = False
+# endif
+# if defined(REG_SpLim)
+freeRegBase REG_SpLim = False
+# endif
+# if defined(REG_Hp)
+freeRegBase REG_Hp    = False
+# endif
+# if defined(REG_HpLim)
+freeRegBase REG_HpLim = False
+# endif
+-- All other regs are considered to be "free", because we can track
+-- their liveness accurately.
+freeRegBase _ = True
+
+#elif defined(MACHREGS_powerpc)
+
+freeReg 0 = False -- Used by code setting the back chain pointer
+                  -- in stack reallocations on Linux.
+                  -- Moreover r0 is not usable in all insns.
+freeReg 1 = False -- The Stack Pointer
+-- most ELF PowerPC OSes use r2 as a TOC pointer
+freeReg 2 = False
+freeReg 13 = False -- reserved for system thread ID on 64 bit
+-- at least linux in -fPIC relies on r30 in PLT stubs
+freeReg 30 = False
+{- TODO: reserve r13 on 64 bit systems only and r30 on 32 bit respectively.
+   For now we use r30 on 64 bit and r13 on 32 bit as a temporary register
+   in stack handling code. See compiler/nativeGen/PPC/Instr.hs.
+
+   Later we might want to reserve r13 and r30 only where it is required.
+   Then use r12 as temporary register, which is also what the C ABI does.
+-}
+
+# if defined(REG_Base)
+freeReg REG_Base  = False
+# endif
+# if defined(REG_R1)
+freeReg REG_R1    = False
+# endif
+# if defined(REG_R2)
+freeReg REG_R2    = False
+# endif
+# if defined(REG_R3)
+freeReg REG_R3    = False
+# endif
+# if defined(REG_R4)
+freeReg REG_R4    = False
+# endif
+# if defined(REG_R5)
+freeReg REG_R5    = False
+# endif
+# if defined(REG_R6)
+freeReg REG_R6    = False
+# endif
+# if defined(REG_R7)
+freeReg REG_R7    = False
+# endif
+# if defined(REG_R8)
+freeReg REG_R8    = False
+# endif
+# if defined(REG_R9)
+freeReg REG_R9    = False
+# endif
+# if defined(REG_R10)
+freeReg REG_R10   = False
+# endif
+# if defined(REG_F1)
+freeReg REG_F1    = False
+# endif
+# if defined(REG_F2)
+freeReg REG_F2    = False
+# endif
+# if defined(REG_F3)
+freeReg REG_F3    = False
+# endif
+# if defined(REG_F4)
+freeReg REG_F4    = False
+# endif
+# if defined(REG_F5)
+freeReg REG_F5    = False
+# endif
+# if defined(REG_F6)
+freeReg REG_F6    = False
+# endif
+# if defined(REG_D1)
+freeReg REG_D1    = False
+# endif
+# if defined(REG_D2)
+freeReg REG_D2    = False
+# endif
+# if defined(REG_D3)
+freeReg REG_D3    = False
+# endif
+# if defined(REG_D4)
+freeReg REG_D4    = False
+# endif
+# if defined(REG_D5)
+freeReg REG_D5    = False
+# endif
+# if defined(REG_D6)
+freeReg REG_D6    = False
+# endif
+# if defined(REG_Sp)
+freeReg REG_Sp    = False
+# endif
+# if defined(REG_Su)
+freeReg REG_Su    = False
+# endif
+# if defined(REG_SpLim)
+freeReg REG_SpLim = False
+# endif
+# if defined(REG_Hp)
+freeReg REG_Hp    = False
+# endif
+# if defined(REG_HpLim)
+freeReg REG_HpLim = False
+# endif
+freeReg _ = True
+
+#elif defined(MACHREGS_sparc)
+
+-- SPARC regs used by the OS / ABI
+-- %g0(r0) is always zero
+freeReg g0  = False
+
+-- %g5(r5) - %g7(r7)
+--  are reserved for the OS
+freeReg g5  = False
+freeReg g6  = False
+freeReg g7  = False
+
+-- %o6(r14)
+--  is the C stack pointer
+freeReg o6  = False
+
+-- %o7(r15)
+--  holds the C return address
+freeReg o7  = False
+
+-- %i6(r30)
+--  is the C frame pointer
+freeReg i6  = False
+
+-- %i7(r31)
+--  is used for C return addresses
+freeReg i7  = False
+
+-- %f0(r32) - %f1(r32)
+--  are C floating point return regs
+freeReg f0  = False
+freeReg f1  = False
+
+{-
+freeReg regNo
+    -- don't release high half of double regs
+    | regNo >= f0
+    , regNo <  NCG_FirstFloatReg
+    , regNo `mod` 2 /= 0
+    = False
+-}
+
+# if defined(REG_Base)
+freeReg REG_Base  = False
+# endif
+# if defined(REG_R1)
+freeReg REG_R1    = False
+# endif
+# if defined(REG_R2)
+freeReg REG_R2    = False
+# endif
+# if defined(REG_R3)
+freeReg REG_R3    = False
+# endif
+# if defined(REG_R4)
+freeReg REG_R4    = False
+# endif
+# if defined(REG_R5)
+freeReg REG_R5    = False
+# endif
+# if defined(REG_R6)
+freeReg REG_R6    = False
+# endif
+# if defined(REG_R7)
+freeReg REG_R7    = False
+# endif
+# if defined(REG_R8)
+freeReg REG_R8    = False
+# endif
+# if defined(REG_R9)
+freeReg REG_R9    = False
+# endif
+# if defined(REG_R10)
+freeReg REG_R10   = False
+# endif
+# if defined(REG_F1)
+freeReg REG_F1    = False
+# endif
+# if defined(REG_F2)
+freeReg REG_F2    = False
+# endif
+# if defined(REG_F3)
+freeReg REG_F3    = False
+# endif
+# if defined(REG_F4)
+freeReg REG_F4    = False
+# endif
+# if defined(REG_F5)
+freeReg REG_F5    = False
+# endif
+# if defined(REG_F6)
+freeReg REG_F6    = False
+# endif
+# if defined(REG_D1)
+freeReg REG_D1    = False
+# endif
+# if defined(REG_D1_2)
+freeReg REG_D1_2  = False
+# endif
+# if defined(REG_D2)
+freeReg REG_D2    = False
+# endif
+# if defined(REG_D2_2)
+freeReg REG_D2_2  = False
+# endif
+# if defined(REG_D3)
+freeReg REG_D3    = False
+# endif
+# if defined(REG_D3_2)
+freeReg REG_D3_2  = False
+# endif
+# if defined(REG_D4)
+freeReg REG_D4    = False
+# endif
+# if defined(REG_D4_2)
+freeReg REG_D4_2  = False
+# endif
+# if defined(REG_D5)
+freeReg REG_D5    = False
+# endif
+# if defined(REG_D5_2)
+freeReg REG_D5_2  = False
+# endif
+# if defined(REG_D6)
+freeReg REG_D6    = False
+# endif
+# if defined(REG_D6_2)
+freeReg REG_D6_2  = False
+# endif
+# if defined(REG_Sp)
+freeReg REG_Sp    = False
+# endif
+# if defined(REG_Su)
+freeReg REG_Su    = False
+# endif
+# if defined(REG_SpLim)
+freeReg REG_SpLim = False
+# endif
+# if defined(REG_Hp)
+freeReg REG_Hp    = False
+# endif
+# if defined(REG_HpLim)
+freeReg REG_HpLim = False
+# endif
+freeReg _ = True
+
+#else
+
+freeReg = panic "freeReg not defined for this platform"
+
+#endif
+
diff --git a/includes/HsFFI.h b/includes/HsFFI.h
new file mode 100644
--- /dev/null
+++ b/includes/HsFFI.h
@@ -0,0 +1,141 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2000
+ *
+ * A mapping for Haskell types to C types, including the corresponding bounds.
+ * Intended to be used in conjuction with the FFI.
+ *
+ * WARNING: Keep this file and StgTypes.h in synch!
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+/* get types from GHC's runtime system */
+#include "ghcconfig.h"
+#include "stg/Types.h"
+
+/* get limits for floating point types */
+#include <float.h>
+
+typedef StgChar                 HsChar;
+typedef StgInt                  HsInt;
+typedef StgInt8                 HsInt8;
+typedef StgInt16                HsInt16;
+typedef StgInt32                HsInt32;
+typedef StgInt64                HsInt64;
+typedef StgWord                 HsWord;
+typedef StgWord8                HsWord8;
+typedef StgWord16               HsWord16;
+typedef StgWord32               HsWord32;
+typedef StgWord64               HsWord64;
+typedef StgFloat                HsFloat;
+typedef StgDouble               HsDouble;
+typedef StgInt                  HsBool;
+typedef void*                   HsPtr;          /* this should better match StgAddr */
+typedef void                    (*HsFunPtr)(void); /* this should better match StgAddr */
+typedef void*                   HsStablePtr;
+
+/* this should correspond to the type of StgChar in StgTypes.h */
+#define HS_CHAR_MIN             0
+#define HS_CHAR_MAX             0x10FFFF
+
+/* is it true or not?  */
+#define HS_BOOL_FALSE           0
+#define HS_BOOL_TRUE            1
+
+#define HS_BOOL_MIN             HS_BOOL_FALSE
+#define HS_BOOL_MAX             HS_BOOL_TRUE
+
+
+#define HS_INT_MIN              STG_INT_MIN
+#define HS_INT_MAX              STG_INT_MAX
+#define HS_WORD_MAX             STG_WORD_MAX
+
+#define HS_INT8_MIN             STG_INT8_MIN
+#define HS_INT8_MAX             STG_INT8_MAX
+#define HS_INT16_MIN            STG_INT16_MIN
+#define HS_INT16_MAX            STG_INT16_MAX
+#define HS_INT32_MIN            STG_INT32_MIN
+#define HS_INT32_MAX            STG_INT32_MAX
+#define HS_INT64_MIN            STG_INT64_MIN
+#define HS_INT64_MAX            STG_INT64_MAX
+#define HS_WORD8_MAX            STG_WORD8_MAX
+#define HS_WORD16_MAX           STG_WORD16_MAX
+#define HS_WORD32_MAX           STG_WORD32_MAX
+#define HS_WORD64_MAX           STG_WORD64_MAX
+
+#define HS_FLOAT_RADIX          FLT_RADIX
+#define HS_FLOAT_ROUNDS         FLT_ROUNDS
+#define HS_FLOAT_EPSILON        FLT_EPSILON
+#define HS_FLOAT_DIG            FLT_DIG
+#define HS_FLOAT_MANT_DIG       FLT_MANT_DIG
+#define HS_FLOAT_MIN            FLT_MIN
+#define HS_FLOAT_MIN_EXP        FLT_MIN_EXP
+#define HS_FLOAT_MIN_10_EXP     FLT_MIN_10_EXP
+#define HS_FLOAT_MAX            FLT_MAX
+#define HS_FLOAT_MAX_EXP        FLT_MAX_EXP
+#define HS_FLOAT_MAX_10_EXP     FLT_MAX_10_EXP
+
+#define HS_DOUBLE_RADIX         DBL_RADIX
+#define HS_DOUBLE_ROUNDS        DBL_ROUNDS
+#define HS_DOUBLE_EPSILON       DBL_EPSILON
+#define HS_DOUBLE_DIG           DBL_DIG
+#define HS_DOUBLE_MANT_DIG      DBL_MANT_DIG
+#define HS_DOUBLE_MIN           DBL_MIN
+#define HS_DOUBLE_MIN_EXP       DBL_MIN_EXP
+#define HS_DOUBLE_MIN_10_EXP    DBL_MIN_10_EXP
+#define HS_DOUBLE_MAX           DBL_MAX
+#define HS_DOUBLE_MAX_EXP       DBL_MAX_EXP
+#define HS_DOUBLE_MAX_10_EXP    DBL_MAX_10_EXP
+
+extern void hs_init     (int *argc, char **argv[]);
+extern void hs_exit     (void);
+extern void hs_exit_nowait(void);
+extern void hs_set_argv (int argc, char *argv[]);
+extern void hs_thread_done (void);
+
+extern void hs_perform_gc (void);
+
+// Lock the stable pointer table. The table must be unlocked
+// again before calling any Haskell functions, even if those
+// functions do not manipulate stable pointers. The Haskell
+// garbage collector will not be able to run until this lock
+// is released! It is also forbidden to call hs_free_fun_ptr
+// or any stable pointer-related FFI functions other than
+// hs_free_stable_ptr_unsafe while the table is locked.
+extern void hs_lock_stable_ptr_table (void);
+
+// A deprecated synonym.
+extern void hs_lock_stable_tables (void);
+
+// Unlock the stable pointer table.
+extern void hs_unlock_stable_ptr_table (void);
+
+// A deprecated synonym.
+extern void hs_unlock_stable_tables (void);
+
+// Free a stable pointer assuming that the stable pointer
+// table is already locked.
+extern void hs_free_stable_ptr_unsafe (HsStablePtr sp);
+
+extern void hs_free_stable_ptr (HsStablePtr sp);
+extern void hs_free_fun_ptr    (HsFunPtr fp);
+
+extern StgPtr hs_spt_lookup(StgWord64 key1, StgWord64 key2);
+extern int hs_spt_keys(StgPtr keys[], int szKeys);
+extern int hs_spt_key_count (void);
+
+extern void hs_try_putmvar (int capability, HsStablePtr sp);
+
+/* -------------------------------------------------------------------------- */
+
+
+
+#if defined(__cplusplus)
+}
+#endif
diff --git a/includes/MachDeps.h b/includes/MachDeps.h
new file mode 100644
--- /dev/null
+++ b/includes/MachDeps.h
@@ -0,0 +1,123 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2002
+ *
+ * Definitions that characterise machine specific properties of basic
+ * types (C & Haskell) of a target platform.
+ *
+ * NB: Keep in sync with HsFFI.h and StgTypes.h.
+ * NB: THIS FILE IS INCLUDED IN HASKELL SOURCE!
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* Don't allow stage1 (cross-)compiler embed assumptions about target
+ * platform. When ghc-stage1 is being built by ghc-stage0 is should not
+ * refer to target defines. A few past examples:
+ *  - https://ghc.haskell.org/trac/ghc/ticket/13491
+ *  - https://phabricator.haskell.org/D3122
+ *  - https://phabricator.haskell.org/D3405
+ *
+ * In those cases code change assumed target defines like SIZEOF_HSINT
+ * are applied to host platform, not target platform.
+ *
+ * So what should be used instead in STAGE=1?
+ *
+ * To get host's equivalent of SIZEOF_HSINT you can use Bits instances:
+ *    Data.Bits.finiteBitSize (0 :: Int)
+ *
+ * To get target's values it is preferred to use runtime target
+ * configuration from 'targetPlatform :: DynFlags -> Platform'
+ * record. A few wrappers are already defined and used throughout GHC:
+ *    wORD_SIZE :: DynFlags -> Int
+ *    wORD_SIZE dflags = pc_WORD_SIZE (sPlatformConstants (settings dflags))
+ *
+ * Hence we hide these macros from -DSTAGE=1
+ */
+#if !defined(STAGE) || STAGE >= 2
+
+/* Sizes of C types come from here... */
+#include "ghcautoconf.h"
+
+/* Sizes of Haskell types follow.  These sizes correspond to:
+ *   - the number of bytes in the primitive type (eg. Int#)
+ *   - the number of bytes in the external representation (eg. HsInt)
+ *   - the scale offset used by writeFooOffAddr#
+ *
+ * In the heap, the type may take up more space: eg. SIZEOF_INT8 == 1,
+ * but it takes up SIZEOF_HSWORD (4 or 8) bytes in the heap.
+ */
+
+#define SIZEOF_HSCHAR           SIZEOF_WORD32
+#define ALIGNMENT_HSCHAR        ALIGNMENT_WORD32
+
+#define SIZEOF_HSINT            SIZEOF_VOID_P
+#define ALIGNMENT_HSINT         ALIGNMENT_VOID_P
+
+#define SIZEOF_HSWORD           SIZEOF_VOID_P
+#define ALIGNMENT_HSWORD        ALIGNMENT_VOID_P
+
+#define SIZEOF_HSDOUBLE         SIZEOF_DOUBLE
+#define ALIGNMENT_HSDOUBLE      ALIGNMENT_DOUBLE
+
+#define SIZEOF_HSFLOAT          SIZEOF_FLOAT
+#define ALIGNMENT_HSFLOAT       ALIGNMENT_FLOAT
+
+#define SIZEOF_HSPTR            SIZEOF_VOID_P
+#define ALIGNMENT_HSPTR         ALIGNMENT_VOID_P
+
+#define SIZEOF_HSFUNPTR         SIZEOF_VOID_P
+#define ALIGNMENT_HSFUNPTR      ALIGNMENT_VOID_P
+
+#define SIZEOF_HSSTABLEPTR      SIZEOF_VOID_P
+#define ALIGNMENT_HSSTABLEPTR   ALIGNMENT_VOID_P
+
+#define SIZEOF_INT8             SIZEOF_INT8_T
+#define ALIGNMENT_INT8          ALIGNMENT_INT8_T
+
+#define SIZEOF_WORD8            SIZEOF_UINT8_T
+#define ALIGNMENT_WORD8         ALIGNMENT_UINT8_T
+
+#define SIZEOF_INT16            SIZEOF_INT16_T
+#define ALIGNMENT_INT16         ALIGNMENT_INT16_T
+
+#define SIZEOF_WORD16           SIZEOF_UINT16_T
+#define ALIGNMENT_WORD16        ALIGNMENT_UINT16_T
+
+#define SIZEOF_INT32            SIZEOF_INT32_T
+#define ALIGNMENT_INT32         ALIGNMENT_INT32_T
+
+#define SIZEOF_WORD32           SIZEOF_UINT32_T
+#define ALIGNMENT_WORD32        ALIGNMENT_UINT32_T
+
+#define SIZEOF_INT64            SIZEOF_INT64_T
+#define ALIGNMENT_INT64         ALIGNMENT_INT64_T
+
+#define SIZEOF_WORD64           SIZEOF_UINT64_T
+#define ALIGNMENT_WORD64        ALIGNMENT_UINT64_T
+
+#if !defined(WORD_SIZE_IN_BITS)
+#if SIZEOF_HSWORD == 4
+#define WORD_SIZE_IN_BITS       32
+#define WORD_SIZE_IN_BITS_FLOAT 32.0
+#else
+#define WORD_SIZE_IN_BITS       64
+#define WORD_SIZE_IN_BITS_FLOAT 64.0
+#endif
+#endif
+
+#if !defined(TAG_BITS)
+#if SIZEOF_HSWORD == 4
+#define TAG_BITS                2
+#else
+#define TAG_BITS                3
+#endif
+#endif
+
+#define TAG_MASK ((1 << TAG_BITS) - 1)
+
+#endif /* !defined(STAGE) || STAGE >= 2 */
diff --git a/includes/Rts.h b/includes/Rts.h
new file mode 100644
--- /dev/null
+++ b/includes/Rts.h
@@ -0,0 +1,311 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * RTS external APIs.  This file declares everything that the GHC RTS
+ * exposes externally.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+/* We include windows.h very early, as on Win64 the CONTEXT type has
+   fields "R8", "R9" and "R10", which goes bad if we've already
+   #define'd those names for our own purposes (in stg/Regs.h) */
+#if defined(HAVE_WINDOWS_H)
+#include <windows.h>
+#endif
+
+#if !defined(IN_STG_CODE)
+#define IN_STG_CODE 0
+#endif
+#include "Stg.h"
+
+#include "HsFFI.h"
+#include "RtsAPI.h"
+
+// Turn off inlining when debugging - it obfuscates things
+#if defined(DEBUG)
+# undef  STATIC_INLINE
+# define STATIC_INLINE static
+#endif
+
+#include "rts/Types.h"
+#include "rts/Time.h"
+
+#if __GNUC__ >= 3
+#define ATTRIBUTE_ALIGNED(n) __attribute__((aligned(n)))
+#else
+#define ATTRIBUTE_ALIGNED(n) /*nothing*/
+#endif
+
+// Symbols that are extern, but private to the RTS, are declared
+// with visibility "hidden" to hide them outside the RTS shared
+// library.
+#if defined(HAS_VISIBILITY_HIDDEN)
+#define RTS_PRIVATE  GNUC3_ATTRIBUTE(visibility("hidden"))
+#else
+#define RTS_PRIVATE  /* disabled: RTS_PRIVATE */
+#endif
+
+#if __GNUC__ >= 4
+#define RTS_UNLIKELY(p) __builtin_expect((p),0)
+#else
+#define RTS_UNLIKELY(p) p
+#endif
+
+/* __builtin_unreachable is supported since GNU C 4.5 */
+#if __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 5)
+#define RTS_UNREACHABLE __builtin_unreachable()
+#else
+#define RTS_UNREACHABLE abort()
+#endif
+
+/* Fix for mingw stat problem (done here so it's early enough) */
+#if defined(mingw32_HOST_OS)
+#define __MSVCRT__ 1
+#endif
+
+/* Needed to get the macro version of errno on some OSs, and also to
+   get prototypes for the _r versions of C library functions. */
+#if !defined(_REENTRANT)
+#define _REENTRANT 1
+#endif
+
+/*
+ * We often want to know the size of something in units of an
+ * StgWord... (rounded up, of course!)
+ */
+#define ROUNDUP_BYTES_TO_WDS(n) (((n) + sizeof(W_) - 1) / sizeof(W_))
+
+#define sizeofW(t) ROUNDUP_BYTES_TO_WDS(sizeof(t))
+
+/* -----------------------------------------------------------------------------
+   Assertions and Debuggery
+
+   CHECK(p)   evaluates p and terminates with an error if p is false
+   ASSERT(p)  like CHECK(p) if DEBUG is on, otherwise a no-op
+   -------------------------------------------------------------------------- */
+
+void _assertFail(const char *filename, unsigned int linenum)
+   GNUC3_ATTRIBUTE(__noreturn__);
+
+#define CHECK(predicate)                        \
+        if (predicate)                          \
+            /*null*/;                           \
+        else                                    \
+            _assertFail(__FILE__, __LINE__)
+
+#define CHECKM(predicate, msg, ...)             \
+        if (predicate)                          \
+            /*null*/;                           \
+        else                                    \
+            barf(msg, ##__VA_ARGS__)
+
+#if !defined(DEBUG)
+#define ASSERT(predicate) /* nothing */
+#define ASSERTM(predicate,msg,...) /* nothing */
+#else
+#define ASSERT(predicate) CHECK(predicate)
+#define ASSERTM(predicate,msg,...) CHECKM(predicate,msg,##__VA_ARGS__)
+#endif /* DEBUG */
+
+/*
+ * Use this on the RHS of macros which expand to nothing
+ * to make sure that the macro can be used in a context which
+ * demands a non-empty statement.
+ */
+
+#define doNothing() do { } while (0)
+
+#if defined(DEBUG)
+#define USED_IF_DEBUG
+#define USED_IF_NOT_DEBUG STG_UNUSED
+#else
+#define USED_IF_DEBUG STG_UNUSED
+#define USED_IF_NOT_DEBUG
+#endif
+
+#if defined(THREADED_RTS)
+#define USED_IF_THREADS
+#define USED_IF_NOT_THREADS STG_UNUSED
+#else
+#define USED_IF_THREADS STG_UNUSED
+#define USED_IF_NOT_THREADS
+#endif
+
+#define FMT_SizeT    "zu"
+#define FMT_HexSizeT "zx"
+
+/* -----------------------------------------------------------------------------
+   Include everything STG-ish
+   -------------------------------------------------------------------------- */
+
+/* System headers: stdlib.h is needed so that we can use NULL.  It must
+ * come after MachRegs.h, because stdlib.h might define some inline
+ * functions which may only be defined after register variables have
+ * been declared.
+ */
+#include <stdlib.h>
+
+#include "rts/Config.h"
+
+/* Global constraints */
+#include "rts/Constants.h"
+
+/* Profiling information */
+#include "rts/prof/CCS.h"
+#include "rts/prof/LDV.h"
+
+/* Parallel information */
+#include "rts/OSThreads.h"
+#include "rts/SpinLock.h"
+
+#include "rts/Messages.h"
+#include "rts/Threads.h"
+
+/* Storage format definitions */
+#include "rts/storage/FunTypes.h"
+#include "rts/storage/InfoTables.h"
+#include "rts/storage/Closures.h"
+#include "rts/storage/Heap.h"
+#include "rts/storage/ClosureTypes.h"
+#include "rts/storage/TSO.h"
+#include "stg/MiscClosures.h" /* InfoTables, closures etc. defined in the RTS */
+#include "rts/storage/Block.h"
+#include "rts/storage/ClosureMacros.h"
+#include "rts/storage/MBlock.h"
+#include "rts/storage/GC.h"
+
+/* Other RTS external APIs */
+#include "rts/Parallel.h"
+#include "rts/Signals.h"
+#include "rts/BlockSignals.h"
+#include "rts/Hpc.h"
+#include "rts/Flags.h"
+#include "rts/Adjustor.h"
+#include "rts/FileLock.h"
+#include "rts/GetTime.h"
+#include "rts/Globals.h"
+#include "rts/IOManager.h"
+#include "rts/Linker.h"
+#include "rts/Ticky.h"
+#include "rts/Timer.h"
+#include "rts/StablePtr.h"
+#include "rts/StableName.h"
+#include "rts/TTY.h"
+#include "rts/Utils.h"
+#include "rts/PrimFloat.h"
+#include "rts/Main.h"
+#include "rts/Profiling.h"
+#include "rts/StaticPtrTable.h"
+#include "rts/Libdw.h"
+#include "rts/LibdwPool.h"
+
+/* Misc stuff without a home */
+DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell */
+DLL_IMPORT_RTS extern int    prog_argc;
+DLL_IMPORT_RTS extern char  *prog_name;
+
+void reportStackOverflow(StgTSO* tso);
+void reportHeapOverflow(void);
+
+void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__);
+
+#if !defined(mingw32_HOST_OS)
+int stg_sig_install (int, int, void *);
+#endif
+
+/* -----------------------------------------------------------------------------
+   Ways
+   -------------------------------------------------------------------------- */
+
+// Returns non-zero if the RTS is a profiling version
+int rts_isProfiled(void);
+
+// Returns non-zero if the RTS is a dynamically-linked version
+int rts_isDynamic(void);
+
+/* -----------------------------------------------------------------------------
+   RTS Exit codes
+   -------------------------------------------------------------------------- */
+
+/* 255 is allegedly used by dynamic linkers to report linking failure */
+#define EXIT_INTERNAL_ERROR 254
+#define EXIT_DEADLOCK       253
+#define EXIT_INTERRUPTED    252
+#define EXIT_HEAPOVERFLOW   251
+#define EXIT_KILLED         250
+
+/* -----------------------------------------------------------------------------
+   Miscellaneous garbage
+   -------------------------------------------------------------------------- */
+
+#if defined(DEBUG)
+#define TICK_VAR(arity) \
+  extern StgInt SLOW_CALLS_##arity; \
+  extern StgInt RIGHT_ARITY_##arity; \
+  extern StgInt TAGGED_PTR_##arity;
+
+extern StgInt TOTAL_CALLS;
+
+TICK_VAR(1)
+TICK_VAR(2)
+#endif
+
+/* -----------------------------------------------------------------------------
+   Assertions and Debuggery
+   -------------------------------------------------------------------------- */
+
+#define IF_RTSFLAGS(c,s)  if (RtsFlags.c) { s; } doNothing()
+
+#if defined(DEBUG)
+#if IN_STG_CODE
+#define IF_DEBUG(c,s)  if (RtsFlags[0].DebugFlags.c) { s; } doNothing()
+#else
+#define IF_DEBUG(c,s)  if (RtsFlags.DebugFlags.c) { s; } doNothing()
+#endif
+#else
+#define IF_DEBUG(c,s)  doNothing()
+#endif
+
+#if defined(DEBUG)
+#define DEBUG_ONLY(s) s
+#else
+#define DEBUG_ONLY(s) doNothing()
+#endif
+
+#if defined(DEBUG)
+#define DEBUG_IS_ON   1
+#else
+#define DEBUG_IS_ON   0
+#endif
+
+/* -----------------------------------------------------------------------------
+   Useful macros and inline functions
+   -------------------------------------------------------------------------- */
+
+#if defined(__GNUC__)
+#define SUPPORTS_TYPEOF
+#endif
+
+#if defined(SUPPORTS_TYPEOF)
+#define stg_min(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _a : _b; })
+#define stg_max(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _b : _a; })
+#else
+#define stg_min(a,b) ((a) <= (b) ? (a) : (b))
+#define stg_max(a,b) ((a) <= (b) ? (b) : (a))
+#endif
+
+/* -------------------------------------------------------------------------- */
+
+#if defined(__cplusplus)
+}
+#endif
diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h
new file mode 100644
--- /dev/null
+++ b/includes/RtsAPI.h
@@ -0,0 +1,487 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * API for invoking Haskell functions via the RTS
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * --------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(__cplusplus)
+extern "C" {
+#endif
+
+#include "HsFFI.h"
+#include "rts/Time.h"
+#include "rts/EventLogWriter.h"
+
+/*
+ * Running the scheduler
+ */
+typedef enum {
+    NoStatus,    /* not finished yet */
+    Success,     /* completed successfully */
+    Killed,      /* uncaught exception */
+    Interrupted, /* stopped in response to a call to interruptStgRts */
+    HeapExhausted /* out of memory */
+} SchedulerStatus;
+
+typedef struct StgClosure_ *HaskellObj;
+
+/*
+ * An abstract type representing the token returned by rts_lock() and
+ * used when allocating objects and threads in the RTS.
+ */
+typedef struct Capability_ Capability;
+
+/*
+ * The public view of a Capability: we can be sure it starts with
+ * these two components (but it may have more private fields).
+ */
+typedef struct CapabilityPublic_ {
+    StgFunTable f;
+    StgRegTable r;
+} CapabilityPublic;
+
+/* ----------------------------------------------------------------------------
+   RTS configuration settings, for passing to hs_init_ghc()
+   ------------------------------------------------------------------------- */
+
+typedef enum {
+    RtsOptsNone,         // +RTS causes an error
+    RtsOptsIgnore,       // Ignore command line arguments
+    RtsOptsIgnoreAll,    // Ignore command line and Environment arguments
+    RtsOptsSafeOnly,     // safe RTS options allowed; others cause an error
+    RtsOptsAll           // all RTS options allowed
+  } RtsOptsEnabledEnum;
+
+struct GCDetails_;
+
+// The RtsConfig struct is passed (by value) to hs_init_ghc().  The
+// reason for using a struct is extensibility: we can add more
+// fields to this later without breaking existing client code.
+typedef struct {
+
+    // Whether to interpret +RTS options on the command line
+    RtsOptsEnabledEnum rts_opts_enabled;
+
+    // Whether to give RTS flag suggestions
+    HsBool rts_opts_suggestions;
+
+    // additional RTS options
+    const char *rts_opts;
+
+    // True if GHC was not passed -no-hs-main
+    HsBool rts_hs_main;
+
+    // Whether to retain CAFs (default: false)
+    HsBool keep_cafs;
+
+    // Writer a for eventlog.
+    const EventLogWriter *eventlog_writer;
+
+    // Called before processing command-line flags, so that default
+    // settings for RtsFlags can be provided.
+    void (* defaultsHook) (void);
+
+    // Called just before exiting
+    void (* onExitHook) (void);
+
+    // Called on a stack overflow, before exiting
+    void (* stackOverflowHook) (W_ stack_size);
+
+    // Called on heap overflow, before exiting
+    void (* outOfHeapHook) (W_ request_size, W_ heap_size);
+
+    // Called when malloc() fails, before exiting
+    void (* mallocFailHook) (W_ request_size /* in bytes */, const char *msg);
+
+    // Called for every GC
+    void (* gcDoneHook) (const struct GCDetails_ *stats);
+
+    // Called when GC sync takes too long (+RTS --long-gc-sync=<time>)
+    void (* longGCSync) (uint32_t this_cap, Time time_ns);
+    void (* longGCSyncEnd) (Time time_ns);
+} RtsConfig;
+
+// Clients should start with defaultRtsConfig and then customise it.
+// Bah, I really wanted this to be a const struct value, but it seems
+// you can't do that in C (it generates code).
+extern const RtsConfig defaultRtsConfig;
+
+/* -----------------------------------------------------------------------------
+   Statistics
+   -------------------------------------------------------------------------- */
+
+//
+// Stats about a single GC
+//
+typedef struct GCDetails_ {
+    // The generation number of this GC
+  uint32_t gen;
+    // Number of threads used in this GC
+  uint32_t threads;
+    // Number of bytes allocated since the previous GC
+  uint64_t allocated_bytes;
+    // Total amount of live data in the heap (incliudes large + compact data).
+    // Updated after every GC. Data in uncollected generations (in minor GCs)
+    // are considered live.
+  uint64_t live_bytes;
+    // Total amount of live data in large objects
+  uint64_t large_objects_bytes;
+    // Total amount of live data in compact regions
+  uint64_t compact_bytes;
+    // Total amount of slop (wasted memory)
+  uint64_t slop_bytes;
+    // Total amount of memory in use by the RTS
+  uint64_t mem_in_use_bytes;
+    // Total amount of data copied during this GC
+  uint64_t copied_bytes;
+    // In parallel GC, the max amount of data copied by any one thread
+  uint64_t par_max_copied_bytes;
+  // In parallel GC, the amount of balanced data copied by all threads
+  uint64_t par_balanced_copied_bytes;
+    // The time elapsed during synchronisation before GC
+  Time sync_elapsed_ns;
+    // The CPU time used during GC itself
+  Time cpu_ns;
+    // The time elapsed during GC itself
+  Time elapsed_ns;
+} GCDetails;
+
+//
+// Stats about the RTS currently, and since the start of execution
+//
+typedef struct _RTSStats {
+
+  // -----------------------------------
+  // Cumulative stats about memory use
+
+    // Total number of GCs
+  uint32_t gcs;
+    // Total number of major (oldest generation) GCs
+  uint32_t major_gcs;
+    // Total bytes allocated
+  uint64_t allocated_bytes;
+    // Maximum live data (including large objects + compact regions) in the
+    // heap. Updated after a major GC.
+  uint64_t max_live_bytes;
+    // Maximum live data in large objects
+  uint64_t max_large_objects_bytes;
+    // Maximum live data in compact regions
+  uint64_t max_compact_bytes;
+    // Maximum slop
+  uint64_t max_slop_bytes;
+    // Maximum memory in use by the RTS
+  uint64_t max_mem_in_use_bytes;
+    // Sum of live bytes across all major GCs.  Divided by major_gcs
+    // gives the average live data over the lifetime of the program.
+  uint64_t cumulative_live_bytes;
+    // Sum of copied_bytes across all GCs
+  uint64_t copied_bytes;
+    // Sum of copied_bytes across all parallel GCs
+  uint64_t par_copied_bytes;
+    // Sum of par_max_copied_bytes across all parallel GCs
+  uint64_t cumulative_par_max_copied_bytes;
+    // Sum of par_balanced_copied_byes across all parallel GCs.
+  uint64_t cumulative_par_balanced_copied_bytes;
+
+  // -----------------------------------
+  // Cumulative stats about time use
+  // (we use signed values here because due to inaccuracies in timers
+  // the values can occasionally go slightly negative)
+
+    // Total CPU time used by the init phase
+  Time init_cpu_ns;
+    // Total elapsed time used by the init phase
+  Time init_elapsed_ns;
+    // Total CPU time used by the mutator
+  Time mutator_cpu_ns;
+    // Total elapsed time used by the mutator
+  Time mutator_elapsed_ns;
+    // Total CPU time used by the GC
+  Time gc_cpu_ns;
+    // Total elapsed time used by the GC
+  Time gc_elapsed_ns;
+    // Total CPU time (at the previous GC)
+  Time cpu_ns;
+    // Total elapsed time (at the previous GC)
+  Time elapsed_ns;
+
+  // -----------------------------------
+  // Stats about the most recent GC
+
+  GCDetails gc;
+
+  // -----------------------------------
+  // Internal Counters
+
+    // The number of times a GC thread spun on its 'gc_spin' lock.
+    // Will be zero if the rts was not built with PROF_SPIN
+  uint64_t gc_spin_spin;
+    // The number of times a GC thread yielded on its 'gc_spin' lock.
+    // Will be zero if the rts was not built with PROF_SPIN
+  uint64_t gc_spin_yield;
+    // The number of times a GC thread spun on its 'mut_spin' lock.
+    // Will be zero if the rts was not built with PROF_SPIN
+  uint64_t mut_spin_spin;
+    // The number of times a GC thread yielded on its 'mut_spin' lock.
+    // Will be zero if the rts was not built with PROF_SPIN
+  uint64_t mut_spin_yield;
+    // The number of times a GC thread has checked for work across all parallel
+    // GCs
+  uint64_t any_work;
+    // The number of times a GC thread has checked for work and found none
+    // across all parallel GCs
+  uint64_t no_work;
+    // The number of times a GC thread has iterated it's outer loop across all
+    // parallel GCs
+  uint64_t scav_find_work;
+} RTSStats;
+
+void getRTSStats (RTSStats *s);
+int getRTSStatsEnabled (void);
+
+// Returns the total number of bytes allocated since the start of the program.
+// TODO: can we remove this?
+uint64_t getAllocations (void);
+
+/* ----------------------------------------------------------------------------
+   Starting up and shutting down the Haskell RTS.
+   ------------------------------------------------------------------------- */
+
+/* DEPRECATED, use hs_init() or hs_init_ghc() instead  */
+extern void startupHaskell         ( int argc, char *argv[],
+                                     void (*init_root)(void) );
+
+/* DEPRECATED, use hs_exit() instead  */
+extern void shutdownHaskell        ( void );
+
+/* Like hs_init(), but allows rtsopts. For more complicated usage,
+ * use hs_init_ghc. */
+extern void hs_init_with_rtsopts (int *argc, char **argv[]);
+
+/*
+ * GHC-specific version of hs_init() that allows specifying whether
+ * +RTS ... -RTS options are allowed or not (default: only "safe"
+ * options are allowed), and allows passing an option string that is
+ * to be interpreted by the RTS only, not passed to the program.
+ */
+extern void hs_init_ghc (int *argc, char **argv[],   // program arguments
+                         RtsConfig rts_config);      // RTS configuration
+
+extern void shutdownHaskellAndExit (int exitCode, int fastExit)
+    GNUC3_ATTRIBUTE(__noreturn__);
+
+#if !defined(mingw32_HOST_OS)
+extern void shutdownHaskellAndSignal (int sig, int fastExit)
+     GNUC3_ATTRIBUTE(__noreturn__);
+#endif
+
+extern void getProgArgv            ( int *argc, char **argv[] );
+extern void setProgArgv            ( int argc, char *argv[] );
+extern void getFullProgArgv        ( int *argc, char **argv[] );
+extern void setFullProgArgv        ( int argc, char *argv[] );
+extern void freeFullProgArgv       ( void ) ;
+
+/* exit() override */
+extern void (*exitFn)(int);
+
+/* ----------------------------------------------------------------------------
+   Locking.
+
+   You have to surround all access to the RtsAPI with these calls.
+   ------------------------------------------------------------------------- */
+
+// acquires a token which may be used to create new objects and
+// evaluate them.
+Capability *rts_lock (void);
+
+// releases the token acquired with rts_lock().
+void rts_unlock (Capability *token);
+
+// If you are in a context where you know you have a current capability but
+// do not know what it is, then use this to get it. Basically this only
+// applies to "unsafe" foreign calls (as unsafe foreign calls are made with
+// the capability held).
+//
+// WARNING: There is *no* guarantee this returns anything sensible (eg NULL)
+// when there is no current capability.
+Capability *rts_unsafeGetMyCapability (void);
+
+/* ----------------------------------------------------------------------------
+   Which cpu should the OS thread and Haskell thread run on?
+
+   1. Run the current thread on the given capability:
+     rts_setInCallCapability(cap, 0);
+
+   2. Run the current thread on the given capability and set the cpu affinity
+      for this thread:
+     rts_setInCallCapability(cap, 1);
+
+   3. Run the current thread on the given numa node:
+     rts_pinThreadToNumaNode(node);
+
+   4. Run the current thread on the given capability and on the given numa node:
+     rts_setInCallCapability(cap, 0);
+     rts_pinThreadToNumaNode(cap);
+   ------------------------------------------------------------------------- */
+
+// Specify the Capability that the current OS thread should run on when it calls
+// into Haskell.  The actual capability will be calculated as the supplied
+// value modulo the number of enabled Capabilities.
+//
+// Note that the thread may still be migrated by the RTS scheduler, but that
+// will only happen if there are multiple threads running on one Capability and
+// another Capability is free.
+//
+// If affinity is non-zero, the current thread will be bound to
+// specific CPUs according to the prevailing affinity policy for the
+// specified capability, set by either +RTS -qa or +RTS --numa.
+void rts_setInCallCapability (int preferred_capability, int affinity);
+
+// Specify the CPU Node that the current OS thread should run on when it calls
+// into Haskell. The argument can be either a node number or capability number.
+// The actual node will be calculated as the supplied value modulo the number
+// of numa nodes.
+void rts_pinThreadToNumaNode (int node);
+
+/* ----------------------------------------------------------------------------
+   Building Haskell objects from C datatypes.
+   ------------------------------------------------------------------------- */
+HaskellObj   rts_mkChar       ( Capability *, HsChar   c );
+HaskellObj   rts_mkInt        ( Capability *, HsInt    i );
+HaskellObj   rts_mkInt8       ( Capability *, HsInt8   i );
+HaskellObj   rts_mkInt16      ( Capability *, HsInt16  i );
+HaskellObj   rts_mkInt32      ( Capability *, HsInt32  i );
+HaskellObj   rts_mkInt64      ( Capability *, HsInt64  i );
+HaskellObj   rts_mkWord       ( Capability *, HsWord   w );
+HaskellObj   rts_mkWord8      ( Capability *, HsWord8  w );
+HaskellObj   rts_mkWord16     ( Capability *, HsWord16 w );
+HaskellObj   rts_mkWord32     ( Capability *, HsWord32 w );
+HaskellObj   rts_mkWord64     ( Capability *, HsWord64 w );
+HaskellObj   rts_mkPtr        ( Capability *, HsPtr    a );
+HaskellObj   rts_mkFunPtr     ( Capability *, HsFunPtr a );
+HaskellObj   rts_mkFloat      ( Capability *, HsFloat  f );
+HaskellObj   rts_mkDouble     ( Capability *, HsDouble f );
+HaskellObj   rts_mkStablePtr  ( Capability *, HsStablePtr s );
+HaskellObj   rts_mkBool       ( Capability *, HsBool   b );
+HaskellObj   rts_mkString     ( Capability *, char    *s );
+
+HaskellObj   rts_apply        ( Capability *, HaskellObj, HaskellObj );
+
+/* ----------------------------------------------------------------------------
+   Deconstructing Haskell objects
+   ------------------------------------------------------------------------- */
+HsChar       rts_getChar      ( HaskellObj );
+HsInt        rts_getInt       ( HaskellObj );
+HsInt8       rts_getInt8      ( HaskellObj );
+HsInt16      rts_getInt16     ( HaskellObj );
+HsInt32      rts_getInt32     ( HaskellObj );
+HsInt64      rts_getInt64     ( HaskellObj );
+HsWord       rts_getWord      ( HaskellObj );
+HsWord8      rts_getWord8     ( HaskellObj );
+HsWord16     rts_getWord16    ( HaskellObj );
+HsWord32     rts_getWord32    ( HaskellObj );
+HsWord64     rts_getWord64    ( HaskellObj );
+HsPtr        rts_getPtr       ( HaskellObj );
+HsFunPtr     rts_getFunPtr    ( HaskellObj );
+HsFloat      rts_getFloat     ( HaskellObj );
+HsDouble     rts_getDouble    ( HaskellObj );
+HsStablePtr  rts_getStablePtr ( HaskellObj );
+HsBool       rts_getBool      ( HaskellObj );
+
+/* ----------------------------------------------------------------------------
+   Evaluating Haskell expressions
+
+   The versions ending in '_' allow you to specify an initial stack size.
+   Note that these calls may cause Garbage Collection, so all HaskellObj
+   references are rendered invalid by these calls.
+
+   All of these functions take a (Capability **) - there is a
+   Capability pointer both input and output.  We use an inout
+   parameter because this is less error-prone for the client than a
+   return value - the client could easily forget to use the return
+   value, whereas incorrectly using an inout parameter will usually
+   result in a type error.
+   ------------------------------------------------------------------------- */
+
+void rts_eval (/* inout */ Capability **,
+               /* in    */ HaskellObj p,
+               /* out */   HaskellObj *ret);
+
+void rts_eval_ (/* inout */ Capability **,
+                /* in    */ HaskellObj p,
+                /* in    */ unsigned int stack_size,
+                /* out   */ HaskellObj *ret);
+
+void rts_evalIO (/* inout */ Capability **,
+                 /* in    */ HaskellObj p,
+                 /* out */   HaskellObj *ret);
+
+void rts_evalStableIOMain (/* inout */ Capability **,
+                           /* in    */ HsStablePtr s,
+                           /* out */   HsStablePtr *ret);
+
+void rts_evalStableIO (/* inout */ Capability **,
+                       /* in    */ HsStablePtr s,
+                       /* out */   HsStablePtr *ret);
+
+void rts_evalLazyIO (/* inout */ Capability **,
+                     /* in    */ HaskellObj p,
+                     /* out */   HaskellObj *ret);
+
+void rts_evalLazyIO_ (/* inout */ Capability **,
+                      /* in    */ HaskellObj p,
+                      /* in    */ unsigned int stack_size,
+                      /* out   */ HaskellObj *ret);
+
+void rts_checkSchedStatus (char* site, Capability *);
+
+SchedulerStatus rts_getSchedStatus (Capability *cap);
+
+/*
+ * The RTS allocates some thread-local data when you make a call into
+ * Haskell using one of the rts_eval() functions.  This data is not
+ * normally freed until hs_exit().  If you want to free it earlier
+ * than this, perhaps because the thread is about to exit, then call
+ * rts_done() from the thread.
+ *
+ * It is safe to make more rts_eval() calls after calling rts_done(),
+ * but the next one will cause allocation of the thread-local memory
+ * again.
+ */
+void rts_done (void);
+
+/* --------------------------------------------------------------------------
+   Wrapper closures
+
+   These are used by foreign export and foreign import "wrapper" stubs.
+   ----------------------------------------------------------------------- */
+
+// When producing Windows DLLs the we need to know which symbols are in the
+//      local package/DLL vs external ones.
+//
+//      Note that RtsAPI.h is also included by foreign export stubs in
+//      the base package itself.
+//
+#if defined(COMPILING_WINDOWS_DLL) && !defined(COMPILING_BASE_PACKAGE)
+__declspec(dllimport) extern StgWord base_GHCziTopHandler_runIO_closure[];
+__declspec(dllimport) extern StgWord base_GHCziTopHandler_runNonIO_closure[];
+#else
+extern StgWord base_GHCziTopHandler_runIO_closure[];
+extern StgWord base_GHCziTopHandler_runNonIO_closure[];
+#endif
+
+#define runIO_closure     base_GHCziTopHandler_runIO_closure
+#define runNonIO_closure  base_GHCziTopHandler_runNonIO_closure
+
+/* ------------------------------------------------------------------------ */
+
+#if defined(__cplusplus)
+}
+#endif
diff --git a/includes/Stg.h b/includes/Stg.h
new file mode 100644
--- /dev/null
+++ b/includes/Stg.h
@@ -0,0 +1,599 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Top-level include file for everything required when compiling .hc
+ * code.  NOTE: in .hc files, Stg.h must be included *before* any
+ * other headers, because we define some register variables which must
+ * be done before any inline functions are defined (some system
+ * headers have been known to define the odd inline function).
+ *
+ * We generally try to keep as little visible as possible when
+ * compiling .hc files.  So for example the definitions of the
+ * InfoTable structs, closure structs and other RTS types are not
+ * visible here.  The compiler knows enough about the representations
+ * of these types to generate code which manipulates them directly
+ * with pointer arithmetic.
+ *
+ * In ordinary C code, do not #include this file directly: #include
+ * "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#if !(__STDC_VERSION__ >= 199901L) && !(__cplusplus >= 201103L)
+# error __STDC_VERSION__ does not advertise C99, C++11 or later
+#endif
+
+/*
+ * If we are compiling a .hc file, then we want all the register
+ * variables.  This is the what happens if you #include "Stg.h" first:
+ * we assume this is a .hc file, and set IN_STG_CODE==1, which later
+ * causes the register variables to be enabled in stg/Regs.h.
+ *
+ * If instead "Rts.h" is included first, then we are compiling a
+ * vanilla C file.  Everything from Stg.h is provided, except that
+ * IN_STG_CODE is not defined, and the register variables will not be
+ * active.
+ */
+#if !defined(IN_STG_CODE)
+# define IN_STG_CODE 1
+
+// Turn on C99 for .hc code.  This gives us the INFINITY and NAN
+// constants from math.h, which we occasionally need to use in .hc (#1861)
+# define _ISOC99_SOURCE
+
+// We need _BSD_SOURCE so that math.h defines things like gamma
+// on Linux
+# define _BSD_SOURCE
+
+// On AIX we need _BSD defined, otherwise <math.h> includes <stdlib.h>
+# if defined(_AIX)
+#  define _BSD 1
+# endif
+
+// '_BSD_SOURCE' is deprecated since glibc-2.20
+// in favour of '_DEFAULT_SOURCE'
+# define _DEFAULT_SOURCE
+#endif
+
+#if IN_STG_CODE == 0 || defined(llvm_CC_FLAVOR)
+// C compilers that use an LLVM back end (clang or llvm-gcc) do not
+// correctly support global register variables so we make sure that
+// we do not declare them for these compilers.
+# define NO_GLOBAL_REG_DECLS    /* don't define fixed registers */
+#endif
+
+/* Configuration */
+#include "ghcconfig.h"
+
+/* The code generator calls the math functions directly in .hc code.
+   NB. after configuration stuff above, because this sets #defines
+   that depend on config info, such as __USE_FILE_OFFSET64 */
+#include <math.h>
+
+// On Solaris, we don't get the INFINITY and NAN constants unless we
+// #define _STDC_C99, and we can't do that unless we also use -std=c99,
+// because _STDC_C99 causes the headers to use C99 syntax (e.g. restrict).
+// We aren't ready for -std=c99 yet, so define INFINITY/NAN by hand using
+// the gcc builtins.
+#if !defined(INFINITY)
+#if defined(__GNUC__)
+#define INFINITY __builtin_inf()
+#else
+#error No definition for INFINITY
+#endif
+#endif
+
+#if !defined(NAN)
+#if defined(__GNUC__)
+#define NAN __builtin_nan("")
+#else
+#error No definition for NAN
+#endif
+#endif
+
+/* -----------------------------------------------------------------------------
+   Useful definitions
+   -------------------------------------------------------------------------- */
+
+/*
+ * The C backend likes to refer to labels by just mentioning their
+ * names.  However, when a symbol is declared as a variable in C, the
+ * C compiler will implicitly dereference it when it occurs in source.
+ * So we must subvert this behaviour for .hc files by declaring
+ * variables as arrays, which eliminates the implicit dereference.
+ */
+#if IN_STG_CODE
+#define RTS_VAR(x) (x)[]
+#define RTS_DEREF(x) (*(x))
+#else
+#define RTS_VAR(x) x
+#define RTS_DEREF(x) x
+#endif
+
+/* bit macros
+ */
+#define BITS_PER_BYTE 8
+#define BITS_IN(x) (BITS_PER_BYTE * sizeof(x))
+
+/* Compute offsets of struct fields
+ */
+#define STG_FIELD_OFFSET(s_type, field) ((StgWord)&(((s_type*)0)->field))
+
+/*
+ * 'Portable' inlining:
+ * INLINE_HEADER is for inline functions in header files (macros)
+ * STATIC_INLINE is for inline functions in source files
+ * EXTERN_INLINE is for functions that we want to inline sometimes
+ * (we also compile a static version of the function; see Inlines.c)
+ */
+
+// We generally assume C99 semantics albeit these two definitions work fine even
+// when gnu90 semantics are active (i.e. when __GNUC_GNU_INLINE__ is defined or
+// when a GCC older than 4.2 is used)
+//
+// The problem, however, is with 'extern inline' whose semantics significantly
+// differs between gnu90 and C99
+#define INLINE_HEADER static inline
+#define STATIC_INLINE static inline
+
+// Figure out whether `__attributes__((gnu_inline))` is needed
+// to force gnu90-style 'external inline' semantics.
+#if defined(FORCE_GNU_INLINE)
+// disable auto-detection since HAVE_GNU_INLINE has been defined externally
+#elif defined(__GNUC_GNU_INLINE__) && __GNUC__ == 4 && __GNUC_MINOR__ == 2
+// GCC 4.2.x didn't properly support C99 inline semantics (GCC 4.3 was the first
+// release to properly support C99 inline semantics), and therefore warned when
+// using 'extern inline' while in C99 mode unless `__attributes__((gnu_inline))`
+// was explicitly set.
+# define FORCE_GNU_INLINE 1
+#endif
+
+#if defined(FORCE_GNU_INLINE)
+// Force compiler into gnu90 semantics
+# if defined(KEEP_INLINES)
+#  define EXTERN_INLINE inline __attribute__((gnu_inline))
+# else
+#  define EXTERN_INLINE extern inline __attribute__((gnu_inline))
+# endif
+#elif defined(__GNUC_GNU_INLINE__)
+// we're currently in gnu90 inline mode by default and
+// __attribute__((gnu_inline)) may not be supported, so better leave it off
+# if defined(KEEP_INLINES)
+#  define EXTERN_INLINE inline
+# else
+#  define EXTERN_INLINE extern inline
+# endif
+#else
+// Assume C99 semantics (yes, this curiously results in swapped definitions!)
+// This is the preferred branch, and at some point we may drop support for
+// compilers not supporting C99 semantics altogether.
+# if defined(KEEP_INLINES)
+#  define EXTERN_INLINE extern inline
+# else
+#  define EXTERN_INLINE inline
+# endif
+#endif
+
+
+/*
+ * GCC attributes
+ */
+#if defined(__GNUC__)
+#define GNU_ATTRIBUTE(at) __attribute__((at))
+#else
+#define GNU_ATTRIBUTE(at)
+#endif
+
+#if __GNUC__ >= 3
+#define GNUC3_ATTRIBUTE(at) __attribute__((at))
+#else
+#define GNUC3_ATTRIBUTE(at)
+#endif
+
+/* Used to mark a switch case that falls-through */
+#if (defined(__GNUC__) && __GNUC__ >= 7)
+// N.B. Don't enable fallthrough annotations when compiling with Clang.
+// Apparently clang doesn't enable implicitly fallthrough warnings by default
+// http://llvm.org/viewvc/llvm-project?revision=167655&view=revision
+// when compiling C and the attribute cause warnings of their own (#16019).
+#define FALLTHROUGH GNU_ATTRIBUTE(fallthrough)
+#else
+#define FALLTHROUGH ((void)0)
+#endif /* __GNUC__ >= 7 */
+
+#if !defined(DEBUG) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3))
+#define GNUC_ATTR_HOT __attribute__((hot))
+#else
+#define GNUC_ATTR_HOT /* nothing */
+#endif
+
+#define STG_UNUSED    GNUC3_ATTRIBUTE(__unused__)
+
+/* Prevent functions from being optimized.
+   See Note [Windows Stack allocations] */
+#if defined(__clang__)
+#define STG_NO_OPTIMIZE __attribute__((optnone))
+#elif defined(__GNUC__) || defined(__GNUG__)
+#define STG_NO_OPTIMIZE __attribute__((optimize("O0")))
+#else
+#define STG_NO_OPTIMIZE /* nothing */
+#endif
+
+/* -----------------------------------------------------------------------------
+   Global type definitions
+   -------------------------------------------------------------------------- */
+
+#include "MachDeps.h"
+#include "stg/Types.h"
+
+/* -----------------------------------------------------------------------------
+   Shorthand forms
+   -------------------------------------------------------------------------- */
+
+typedef StgChar      C_;
+typedef StgWord      W_;
+typedef StgWord*  P_;
+typedef StgInt    I_;
+typedef StgWord StgWordArray[];
+typedef StgFunPtr       F_;
+
+/* byte arrays (and strings): */
+#define EB_(X)    extern const char X[]
+#define IB_(X)    static const char X[]
+/* static (non-heap) closures (requires alignment for pointer tagging): */
+#define EC_(X)    extern       StgWordArray (X) GNU_ATTRIBUTE(aligned (8))
+#define IC_(X)    static       StgWordArray (X) GNU_ATTRIBUTE(aligned (8))
+/* writable data (does not require alignment): */
+#define ERW_(X)   extern       StgWordArray (X)
+#define IRW_(X)   static       StgWordArray (X)
+/* read-only data (does not require alignment): */
+#define ERO_(X)   extern const StgWordArray (X)
+#define IRO_(X)   static const StgWordArray (X)
+/* stg-native functions: */
+#define IF_(f)    static StgFunPtr GNUC3_ATTRIBUTE(used) f(void)
+#define FN_(f)           StgFunPtr f(void)
+#define EF_(f)           StgFunPtr f(void) /* External Cmm functions */
+/* foreign functions: */
+#define EFF_(f)   void f() /* See Note [External function prototypes] */
+
+/* Note [External function prototypes]  See Trac #8965, #11395
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In generated C code we need to distinct between two types
+of external symbols:
+1.  Cmm functions declared by 'EF_' macro (External Functions)
+2.    C functions declared by 'EFF_' macro (External Foreign Functions)
+
+Cmm functions are simple as they are internal to GHC.
+
+C functions are trickier:
+
+The external-function macro EFF_(F) used to be defined as
+    extern StgFunPtr f(void)
+i.e a function of zero arguments.  On most platforms this doesn't
+matter very much: calls to these functions put the parameters in the
+usual places anyway, and (with the exception of varargs) things just
+work.
+
+However, the ELFv2 ABI on ppc64 optimises stack allocation
+(http://gcc.gnu.org/ml/gcc-patches/2013-11/msg01149.html): a call to a
+function that has a prototype, is not varargs, and receives all parameters
+in registers rather than on the stack does not require the caller to
+allocate an argument save area.  The incorrect prototypes cause GCC to
+believe that all functions declared this way can be called without an
+argument save area, but if the callee has sufficiently many arguments then
+it will expect that area to be present, and will thus corrupt the caller's
+stack.  This happens in particular with calls to runInteractiveProcess in
+libraries/process/cbits/runProcess.c, and led to Trac #8965.
+
+The simplest fix appears to be to declare these external functions with an
+unspecified argument list rather than a void argument list.  This is no
+worse for platforms that don't care either way, and allows a successful
+bootstrap of GHC 7.8 on little-endian Linux ppc64 (which uses the ELFv2
+ABI).
+
+Another case is m68k ABI where 'void*' return type is returned by 'a0'
+register while 'long' return type is returned by 'd0'. Thus we trick
+external prototype return neither of these types to workaround #11395.
+*/
+
+
+/* -----------------------------------------------------------------------------
+   Tail calls
+   -------------------------------------------------------------------------- */
+
+#define JMP_(cont) return((StgFunPtr)(cont))
+
+/* -----------------------------------------------------------------------------
+   Other Stg stuff...
+   -------------------------------------------------------------------------- */
+
+#include "stg/DLL.h"
+#include "stg/RtsMachRegs.h"
+#include "stg/Regs.h"
+#include "stg/Ticky.h"
+
+#if IN_STG_CODE
+/*
+ * This is included later for RTS sources, after definitions of
+ * StgInfoTable, StgClosure and so on.
+ */
+#include "stg/MiscClosures.h"
+#endif
+
+#include "stg/Prim.h" /* ghc-prim fallbacks */
+#include "stg/SMP.h" // write_barrier() inline is required
+
+/* -----------------------------------------------------------------------------
+   Moving Floats and Doubles
+
+   ASSIGN_FLT is for assigning a float to memory (usually the
+              stack/heap).  The memory address is guaranteed to be
+         StgWord aligned (currently == sizeof(void *)).
+
+   PK_FLT     is for pulling a float out of memory.  The memory is
+              guaranteed to be StgWord aligned.
+   -------------------------------------------------------------------------- */
+
+INLINE_HEADER void     ASSIGN_FLT (W_ [], StgFloat);
+INLINE_HEADER StgFloat    PK_FLT     (W_ []);
+
+#if ALIGNMENT_FLOAT <= ALIGNMENT_VOID_P
+
+INLINE_HEADER void     ASSIGN_FLT(W_ p_dest[], StgFloat src) { *(StgFloat *)p_dest = src; }
+INLINE_HEADER StgFloat PK_FLT    (W_ p_src[])                { return *(StgFloat *)p_src; }
+
+#else  /* ALIGNMENT_FLOAT > ALIGNMENT_UNSIGNED_INT */
+
+INLINE_HEADER void ASSIGN_FLT(W_ p_dest[], StgFloat src)
+{
+    float_thing y;
+    y.f = src;
+    *p_dest = y.fu;
+}
+
+INLINE_HEADER StgFloat PK_FLT(W_ p_src[])
+{
+    float_thing y;
+    y.fu = *p_src;
+    return(y.f);
+}
+
+#endif /* ALIGNMENT_FLOAT > ALIGNMENT_VOID_P */
+
+#if ALIGNMENT_DOUBLE <= ALIGNMENT_VOID_P
+
+INLINE_HEADER void     ASSIGN_DBL (W_ [], StgDouble);
+INLINE_HEADER StgDouble   PK_DBL     (W_ []);
+
+INLINE_HEADER void      ASSIGN_DBL(W_ p_dest[], StgDouble src) { *(StgDouble *)p_dest = src; }
+INLINE_HEADER StgDouble PK_DBL    (W_ p_src[])                 { return *(StgDouble *)p_src; }
+
+#else /* ALIGNMENT_DOUBLE > ALIGNMENT_VOID_P */
+
+/* Sparc uses two floating point registers to hold a double.  We can
+ * write ASSIGN_DBL and PK_DBL by directly accessing the registers
+ * independently - unfortunately this code isn't writable in C, we
+ * have to use inline assembler.
+ */
+#if defined(sparc_HOST_ARCH)
+
+#define ASSIGN_DBL(dst0,src) \
+    { StgPtr dst = (StgPtr)(dst0); \
+      __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \
+   "=m" (((P_)(dst))[1]) : "f" (src)); \
+    }
+
+#define PK_DBL(src0) \
+    ( { StgPtr src = (StgPtr)(src0); \
+        register double d; \
+      __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \
+   "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \
+    } )
+
+#else /* ! sparc_HOST_ARCH */
+
+INLINE_HEADER void     ASSIGN_DBL (W_ [], StgDouble);
+INLINE_HEADER StgDouble   PK_DBL     (W_ []);
+
+typedef struct
+  { StgWord dhi;
+    StgWord dlo;
+  } unpacked_double;
+
+typedef union
+  { StgDouble d;
+    unpacked_double du;
+  } double_thing;
+
+INLINE_HEADER void ASSIGN_DBL(W_ p_dest[], StgDouble src)
+{
+    double_thing y;
+    y.d = src;
+    p_dest[0] = y.du.dhi;
+    p_dest[1] = y.du.dlo;
+}
+
+/* GCC also works with this version, but it generates
+   the same code as the previous one, and is not ANSI
+
+#define ASSIGN_DBL( p_dest, src ) \
+   *p_dest = ((double_thing) src).du.dhi; \
+   *(p_dest+1) = ((double_thing) src).du.dlo \
+*/
+
+INLINE_HEADER StgDouble PK_DBL(W_ p_src[])
+{
+    double_thing y;
+    y.du.dhi = p_src[0];
+    y.du.dlo = p_src[1];
+    return(y.d);
+}
+
+#endif /* ! sparc_HOST_ARCH */
+
+#endif /* ALIGNMENT_DOUBLE > ALIGNMENT_UNSIGNED_INT */
+
+
+/* -----------------------------------------------------------------------------
+   Moving 64-bit quantities around
+
+   ASSIGN_Word64      assign an StgWord64/StgInt64 to a memory location
+   PK_Word64          load an StgWord64/StgInt64 from a amemory location
+
+   In both cases the memory location might not be 64-bit aligned.
+   -------------------------------------------------------------------------- */
+
+#if SIZEOF_HSWORD == 4
+
+typedef struct
+  { StgWord dhi;
+    StgWord dlo;
+  } unpacked_double_word;
+
+typedef union
+  { StgInt64 i;
+    unpacked_double_word iu;
+  } int64_thing;
+
+typedef union
+  { StgWord64 w;
+    unpacked_double_word wu;
+  } word64_thing;
+
+INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)
+{
+    word64_thing y;
+    y.w = src;
+    p_dest[0] = y.wu.dhi;
+    p_dest[1] = y.wu.dlo;
+}
+
+INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])
+{
+    word64_thing y;
+    y.wu.dhi = p_src[0];
+    y.wu.dlo = p_src[1];
+    return(y.w);
+}
+
+INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)
+{
+    int64_thing y;
+    y.i = src;
+    p_dest[0] = y.iu.dhi;
+    p_dest[1] = y.iu.dlo;
+}
+
+INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])
+{
+    int64_thing y;
+    y.iu.dhi = p_src[0];
+    y.iu.dlo = p_src[1];
+    return(y.i);
+}
+
+#elif SIZEOF_VOID_P == 8
+
+INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)
+{
+   p_dest[0] = src;
+}
+
+INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])
+{
+    return p_src[0];
+}
+
+INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)
+{
+    p_dest[0] = src;
+}
+
+INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])
+{
+    return p_src[0];
+}
+
+#endif /* SIZEOF_HSWORD == 4 */
+
+/* -----------------------------------------------------------------------------
+   Integer multiply with overflow
+   -------------------------------------------------------------------------- */
+
+/* Multiply with overflow checking.
+ *
+ * This is tricky - the usual sign rules for add/subtract don't apply.
+ *
+ * On 32-bit machines we use gcc's 'long long' types, finding
+ * overflow with some careful bit-twiddling.
+ *
+ * On 64-bit machines where gcc's 'long long' type is also 64-bits,
+ * we use a crude approximation, testing whether either operand is
+ * larger than 32-bits; if neither is, then we go ahead with the
+ * multiplication.
+ *
+ * Return non-zero if there is any possibility that the signed multiply
+ * of a and b might overflow.  Return zero only if you are absolutely sure
+ * that it won't overflow.  If in doubt, return non-zero.
+ */
+
+#if SIZEOF_VOID_P == 4
+
+#if defined(WORDS_BIGENDIAN)
+#define RTS_CARRY_IDX__ 0
+#define RTS_REM_IDX__  1
+#else
+#define RTS_CARRY_IDX__ 1
+#define RTS_REM_IDX__ 0
+#endif
+
+typedef union {
+    StgInt64 l;
+    StgInt32 i[2];
+} long_long_u ;
+
+#define mulIntMayOflo(a,b)       \
+({                                              \
+  StgInt32 r, c;           \
+  long_long_u z;           \
+  z.l = (StgInt64)a * (StgInt64)b;     \
+  r = z.i[RTS_REM_IDX__];        \
+  c = z.i[RTS_CARRY_IDX__];         \
+  if (c == 0 || c == -1) {       \
+    c = ((StgWord)((a^b) ^ r))         \
+      >> (BITS_IN (I_) - 1);        \
+  }                  \
+  c;                                            \
+})
+
+/* Careful: the carry calculation above is extremely delicate.  Make sure
+ * you test it thoroughly after changing it.
+ */
+
+#else
+
+/* Approximate version when we don't have long arithmetic (on 64-bit archs) */
+
+/* If we have n-bit words then we have n-1 bits after accounting for the
+ * sign bit, so we can fit the result of multiplying 2 (n-1)/2-bit numbers */
+#define HALF_POS_INT  (((I_)1) << ((BITS_IN (I_) - 1) / 2))
+#define HALF_NEG_INT  (-HALF_POS_INT)
+
+#define mulIntMayOflo(a,b)       \
+({                                              \
+  I_ c;              \
+  if ((I_)a <= HALF_NEG_INT || a >= HALF_POS_INT    \
+      || (I_)b <= HALF_NEG_INT || b >= HALF_POS_INT) {\
+    c = 1;              \
+  } else {              \
+    c = 0;              \
+  }                  \
+  c;                                            \
+})
+#endif
diff --git a/includes/ghcconfig.h b/includes/ghcconfig.h
new file mode 100644
--- /dev/null
+++ b/includes/ghcconfig.h
@@ -0,0 +1,4 @@
+#pragma once
+
+#include "ghcautoconf.h"
+#include "ghcplatform.h"
diff --git a/includes/rts/Adjustor.h b/includes/rts/Adjustor.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Adjustor.h
@@ -0,0 +1,22 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Adjustor API
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/* Creating and destroying an adjustor thunk */
+void* createAdjustor (int cconv, 
+                      StgStablePtr hptr,
+                      StgFunPtr wptr,
+                      char *typeString);
+
+void freeHaskellFunctionPtr (void* ptr);
diff --git a/includes/rts/BlockSignals.h b/includes/rts/BlockSignals.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/BlockSignals.h
@@ -0,0 +1,34 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * RTS signal handling 
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* Used by runProcess() in the process package
+ */
+
+/*
+ * Function: blockUserSignals()
+ *
+ * Temporarily block the delivery of further console events. Needed to
+ * avoid race conditions when GCing the queue of outstanding handlers or
+ * when emptying the queue by running the handlers.
+ * 
+ */
+void blockUserSignals(void);
+
+/*
+ * Function: unblockUserSignals()
+ *
+ * The inverse of blockUserSignals(); re-enable the deliver of console events.
+ */
+void unblockUserSignals(void);
diff --git a/includes/rts/Bytecodes.h b/includes/rts/Bytecodes.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Bytecodes.h
@@ -0,0 +1,106 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Bytecode definitions.
+ *
+ * ---------------------------------------------------------------------------*/
+
+/* --------------------------------------------------------------------------
+ * Instructions
+ *
+ * Notes:
+ * o CASEFAIL is generated by the compiler whenever it tests an "irrefutable"
+ *   pattern which fails.  If we don't see too many of these, we could
+ *   optimise out the redundant test.
+ * ------------------------------------------------------------------------*/
+
+/* NOTE:
+
+   THIS FILE IS INCLUDED IN HASKELL SOURCES (ghc/compiler/ghci/ByteCodeAsm.hs).
+   DO NOT PUT C-SPECIFIC STUFF IN HERE!
+
+   I hope that's clear :-)
+*/
+
+#define bci_STKCHECK  			1
+#define bci_PUSH_L    			2
+#define bci_PUSH_LL   			3
+#define bci_PUSH_LLL  			4
+#define bci_PUSH8                       5
+#define bci_PUSH16                      6
+#define bci_PUSH32                      7
+#define bci_PUSH8_W                     8
+#define bci_PUSH16_W                    9
+#define bci_PUSH32_W                    10
+#define bci_PUSH_G    			11
+#define bci_PUSH_ALTS  			12
+#define bci_PUSH_ALTS_P			13
+#define bci_PUSH_ALTS_N			14
+#define bci_PUSH_ALTS_F			15
+#define bci_PUSH_ALTS_D			16
+#define bci_PUSH_ALTS_L			17
+#define bci_PUSH_ALTS_V			18
+#define bci_PUSH_PAD8                   19
+#define bci_PUSH_PAD16                  20
+#define bci_PUSH_PAD32                  21
+#define bci_PUSH_UBX8                   22
+#define bci_PUSH_UBX16                  23
+#define bci_PUSH_UBX32                  24
+#define bci_PUSH_UBX  			25
+#define bci_PUSH_APPLY_N		26
+#define bci_PUSH_APPLY_F		27
+#define bci_PUSH_APPLY_D		28
+#define bci_PUSH_APPLY_L		29
+#define bci_PUSH_APPLY_V		30
+#define bci_PUSH_APPLY_P		31
+#define bci_PUSH_APPLY_PP		32
+#define bci_PUSH_APPLY_PPP		33
+#define bci_PUSH_APPLY_PPPP		34
+#define bci_PUSH_APPLY_PPPPP		35
+#define bci_PUSH_APPLY_PPPPPP		36
+/* #define bci_PUSH_APPLY_PPPPPPP		37 */
+#define bci_SLIDE     			38
+#define bci_ALLOC_AP   			39
+#define bci_ALLOC_AP_NOUPD		40
+#define bci_ALLOC_PAP  			41
+#define bci_MKAP      			42
+#define bci_MKPAP      			43
+#define bci_UNPACK    			44
+#define bci_PACK      			45
+#define bci_TESTLT_I   			46
+#define bci_TESTEQ_I  			47
+#define bci_TESTLT_F  			48
+#define bci_TESTEQ_F  			49
+#define bci_TESTLT_D  			50
+#define bci_TESTEQ_D  			51
+#define bci_TESTLT_P  			52
+#define bci_TESTEQ_P  			53
+#define bci_CASEFAIL  			54
+#define bci_JMP       			55
+#define bci_CCALL     			56
+#define bci_SWIZZLE   			57
+#define bci_ENTER     			58
+#define bci_RETURN    			59
+#define bci_RETURN_P 			60
+#define bci_RETURN_N 			61
+#define bci_RETURN_F 			62
+#define bci_RETURN_D 			63
+#define bci_RETURN_L 			64
+#define bci_RETURN_V 			65
+#define bci_BRK_FUN			66
+#define bci_TESTLT_W   			67
+#define bci_TESTEQ_W  			68
+/* If you need to go past 255 then you will run into the flags */
+
+/* If you need to go below 0x0100 then you will run into the instructions */
+#define bci_FLAG_LARGE_ARGS     0x8000
+
+/* If a BCO definitely requires less than this many words of stack,
+   don't include an explicit STKCHECK insn in it.  The interpreter
+   will check for this many words of stack before running each BCO,
+   rendering an explicit check unnecessary in the majority of
+   cases. */
+#define INTERP_STACK_CHECK_THRESH  50
+
+/*-------------------------------------------------------------------------*/
diff --git a/includes/rts/Config.h b/includes/rts/Config.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Config.h
@@ -0,0 +1,48 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Rts settings.
+ *
+ * NOTE: assumes #include "ghcconfig.h"
+ * 
+ * NB: THIS FILE IS INCLUDED IN NON-C CODE AND DATA!  #defines only please.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(TICKY_TICKY) && defined(THREADED_RTS)
+#error TICKY_TICKY is incompatible with THREADED_RTS
+#endif
+
+/*
+ * Whether the runtime system will use libbfd for debugging purposes.
+ */
+#if defined(DEBUG) && defined(HAVE_BFD_H) && defined(HAVE_LIBBFD) && !defined(_WIN32)
+#define USING_LIBBFD 1
+#endif
+
+/* DEBUG implies TRACING and TICKY_TICKY  */
+#if defined(DEBUG)
+#if !defined(TRACING)
+#define TRACING
+#endif
+#if !defined(TICKY_TICKY)
+#define TICKY_TICKY
+#endif
+#endif
+
+
+/* -----------------------------------------------------------------------------
+   Signals - supported on non-PAR versions of the runtime.  See RtsSignals.h.
+   -------------------------------------------------------------------------- */
+
+#define RTS_USER_SIGNALS 1
+
+/* Profile spin locks */
+
+#define PROF_SPIN
diff --git a/includes/rts/Constants.h b/includes/rts/Constants.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Constants.h
@@ -0,0 +1,332 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Constants
+ *
+ * NOTE: this information is used by both the compiler and the RTS.
+ * Some of it is tweakable, and some of it must be kept up to date
+ * with various other parts of the system.
+ *
+ * Constants which are derived automatically from other definitions in
+ * the system (eg. structure sizes) are generated into the file
+ * DerivedConstants.h by a C program (mkDerivedConstantsHdr).
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/* -----------------------------------------------------------------------------
+   Minimum closure sizes
+
+   This is the minimum number of words in the payload of a
+   heap-allocated closure, so that the closure has enough room to be
+   overwritten with a forwarding pointer during garbage collection.
+   -------------------------------------------------------------------------- */
+
+#define MIN_PAYLOAD_SIZE 1
+
+/* -----------------------------------------------------------------------------
+   Constants to do with specialised closure types.
+   -------------------------------------------------------------------------- */
+
+/* We have some pre-compiled selector thunks defined in rts/StgStdThunks.hc.
+ * This constant defines the highest selectee index that we can replace with a
+ * reference to the pre-compiled code.
+ */
+
+#define MAX_SPEC_SELECTEE_SIZE 15
+
+/* Vector-apply thunks.  These thunks just push their free variables
+ * on the stack and enter the first one.  They're a bit like PAPs, but
+ * don't have a dynamic size.  We've pre-compiled a few to save
+ * space.
+ */
+
+#define MAX_SPEC_AP_SIZE       7
+
+/* Specialised FUN/THUNK/CONSTR closure types */
+
+#define MAX_SPEC_THUNK_SIZE    2
+#define MAX_SPEC_FUN_SIZE      2
+#define MAX_SPEC_CONSTR_SIZE   2
+
+/* Range of built-in table of static small int-like and char-like closures.
+ *
+ *   NB. This corresponds with the number of actual INTLIKE/CHARLIKE
+ *   closures defined in rts/StgMiscClosures.cmm.
+ */
+#define MAX_INTLIKE             16
+#define MIN_INTLIKE             (-16)
+
+#define MAX_CHARLIKE            255
+#define MIN_CHARLIKE            0
+
+/* Each byte in the card table for an StgMutaArrPtrs covers
+ * (1<<MUT_ARR_PTRS_CARD_BITS) elements in the array.  To find a good
+ * value for this, I used the benchmarks nofib/gc/hash,
+ * nofib/gc/graph, and nofib/gc/gc_bench.
+ */
+#define MUT_ARR_PTRS_CARD_BITS 7
+
+/* -----------------------------------------------------------------------------
+   STG Registers.
+
+   Note that in MachRegs.h we define how many of these registers are
+   *real* machine registers, and not just offsets in the Register Table.
+   -------------------------------------------------------------------------- */
+
+#define MAX_VANILLA_REG 10
+#define MAX_FLOAT_REG   6
+#define MAX_DOUBLE_REG  6
+#define MAX_LONG_REG    1
+#define MAX_XMM_REG     6
+
+/* -----------------------------------------------------------------------------
+   Semi-Tagging constants
+
+   Old Comments about this stuff:
+
+   Tags for indirection nodes and ``other'' (probably unevaluated) nodes;
+   normal-form values of algebraic data types will have tags 0, 1, ...
+
+   @INFO_IND_TAG@ is different from @INFO_OTHER_TAG@ just so we can count
+   how often we bang into indirection nodes; that's all.  (WDP 95/11)
+
+   ToDo: find out if we need any of this.
+   -------------------------------------------------------------------------- */
+
+#define INFO_OTHER_TAG          (-1)
+#define INFO_IND_TAG            (-2)
+#define INFO_FIRST_TAG          0
+
+/* -----------------------------------------------------------------------------
+   How much C stack to reserve for local temporaries when in the STG
+   world.  Used in StgCRun.c.
+   -------------------------------------------------------------------------- */
+
+#define RESERVED_C_STACK_BYTES (2048 * SIZEOF_LONG)
+
+/* -----------------------------------------------------------------------------
+   How large is the stack frame saved by StgRun?
+   world.  Used in StgCRun.c.
+
+   The size has to be enough to save the registers (see StgCRun)
+   plus padding if the result is not 16 byte aligned.
+   See the Note [Stack Alignment on X86] in StgCRun.c for details.
+
+   -------------------------------------------------------------------------- */
+#if defined(x86_64_HOST_ARCH)
+#  if defined(mingw32_HOST_OS)
+#    define STG_RUN_STACK_FRAME_SIZE 144
+#  else
+#    define STG_RUN_STACK_FRAME_SIZE 48
+#  endif
+#endif
+
+/* -----------------------------------------------------------------------------
+   StgRun related labels shared between StgCRun.c and StgStartup.cmm.
+   -------------------------------------------------------------------------- */
+
+#if defined(LEADING_UNDERSCORE)
+#define STG_RUN "_StgRun"
+#define STG_RUN_JMP _StgRunJmp
+#define STG_RETURN "_StgReturn"
+#else
+#define STG_RUN "StgRun"
+#define STG_RUN_JMP StgRunJmp
+#define STG_RETURN "StgReturn"
+#endif
+
+/* -----------------------------------------------------------------------------
+   How much Haskell stack space to reserve for the saving of registers
+   etc. in the case of a stack/heap overflow.
+
+   This must be large enough to accommodate the largest stack frame
+   pushed in one of the heap check fragments in HeapStackCheck.hc
+   (ie. currently the generic heap checks - 3 words for StgRetDyn,
+   18 words for the saved registers, see StgMacros.h).
+   -------------------------------------------------------------------------- */
+
+#define RESERVED_STACK_WORDS 21
+
+/* -----------------------------------------------------------------------------
+   The limit on the size of the stack check performed when we enter an
+   AP_STACK, in words.  See raiseAsync() and bug #1466.
+   -------------------------------------------------------------------------- */
+
+#define AP_STACK_SPLIM 1024
+
+/* -----------------------------------------------------------------------------
+   Storage manager constants
+   -------------------------------------------------------------------------- */
+
+/* The size of a block (2^BLOCK_SHIFT bytes) */
+#define BLOCK_SHIFT  12
+
+/* The size of a megablock (2^MBLOCK_SHIFT bytes) */
+#define MBLOCK_SHIFT   20
+
+/* -----------------------------------------------------------------------------
+   Bitmap/size fields (used in info tables)
+   -------------------------------------------------------------------------- */
+
+/* In a 32-bit bitmap field, we use 5 bits for the size, and 27 bits
+ * for the bitmap.  If the bitmap requires more than 27 bits, then we
+ * store it in a separate array, and leave a pointer in the bitmap
+ * field.  On a 64-bit machine, the sizes are extended accordingly.
+ */
+#if SIZEOF_VOID_P == 4
+#define BITMAP_SIZE_MASK     0x1f
+#define BITMAP_BITS_SHIFT    5
+#elif SIZEOF_VOID_P == 8
+#define BITMAP_SIZE_MASK     0x3f
+#define BITMAP_BITS_SHIFT    6
+#else
+#error unknown SIZEOF_VOID_P
+#endif
+
+/* -----------------------------------------------------------------------------
+   Lag/Drag/Void constants
+   -------------------------------------------------------------------------- */
+
+/*
+  An LDV word is divided into 3 parts: state bits (LDV_STATE_MASK), creation
+  time bits (LDV_CREATE_MASK), and last use time bits (LDV_LAST_MASK).
+ */
+#if SIZEOF_VOID_P == 8
+#define LDV_SHIFT               30
+#define LDV_STATE_MASK          0x1000000000000000
+#define LDV_CREATE_MASK         0x0FFFFFFFC0000000
+#define LDV_LAST_MASK           0x000000003FFFFFFF
+#define LDV_STATE_CREATE        0x0000000000000000
+#define LDV_STATE_USE           0x1000000000000000
+#else
+#define LDV_SHIFT               15
+#define LDV_STATE_MASK          0x40000000
+#define LDV_CREATE_MASK         0x3FFF8000
+#define LDV_LAST_MASK           0x00007FFF
+#define LDV_STATE_CREATE        0x00000000
+#define LDV_STATE_USE           0x40000000
+#endif /* SIZEOF_VOID_P */
+
+/* -----------------------------------------------------------------------------
+   TSO related constants
+   -------------------------------------------------------------------------- */
+
+/*
+ * Constants for the what_next field of a TSO, which indicates how it
+ * is to be run.
+ */
+#define ThreadRunGHC    1       /* return to address on top of stack */
+#define ThreadInterpret 2       /* interpret this thread */
+#define ThreadKilled    3       /* thread has died, don't run it */
+#define ThreadComplete  4       /* thread has finished */
+
+/*
+ * Constants for the why_blocked field of a TSO
+ * NB. keep these in sync with GHC/Conc/Sync.hs: threadStatus
+ */
+#define NotBlocked          0
+#define BlockedOnMVar       1
+#define BlockedOnMVarRead   14 /* TODO: renumber me, see #9003 */
+#define BlockedOnBlackHole  2
+#define BlockedOnRead       3
+#define BlockedOnWrite      4
+#define BlockedOnDelay      5
+#define BlockedOnSTM        6
+
+/* Win32 only: */
+#define BlockedOnDoProc     7
+
+/* Only relevant for THREADED_RTS: */
+#define BlockedOnCCall      10
+#define BlockedOnCCall_Interruptible 11
+   /* same as above but permit killing the worker thread */
+
+/* Involved in a message sent to tso->msg_cap */
+#define BlockedOnMsgThrowTo 12
+
+/* The thread is not on any run queues, but can be woken up
+   by tryWakeupThread() */
+#define ThreadMigrating     13
+
+/* WARNING WARNING top number is BlockedOnMVarRead 14, not 13!! */
+
+/*
+ * These constants are returned to the scheduler by a thread that has
+ * stopped for one reason or another.  See typedef StgThreadReturnCode
+ * in TSO.h.
+ */
+#define HeapOverflow   1                /* might also be StackOverflow */
+#define StackOverflow  2
+#define ThreadYielding 3
+#define ThreadBlocked  4
+#define ThreadFinished 5
+
+/*
+ * Flags for the tso->flags field.
+ */
+
+/*
+ * TSO_LOCKED is set when a TSO is locked to a particular Capability.
+ */
+#define TSO_LOCKED  2
+
+/*
+ * TSO_BLOCKEX: the TSO is blocking exceptions
+ *
+ * TSO_INTERRUPTIBLE: the TSO can be interrupted if it blocks
+ * interruptibly (eg. with BlockedOnMVar).
+ *
+ * TSO_STOPPED_ON_BREAKPOINT: the thread is currently stopped in a breakpoint
+ */
+#define TSO_BLOCKEX       4
+#define TSO_INTERRUPTIBLE 8
+#define TSO_STOPPED_ON_BREAKPOINT 16
+
+/*
+ * Used by the sanity checker to check whether TSOs are on the correct
+ * mutable list.
+ */
+#define TSO_MARKED 64
+
+/*
+ * Used to communicate between stackSqueeze() and
+ * threadStackOverflow() that a thread's stack was squeezed and the
+ * stack may not need to be expanded.
+ */
+#define TSO_SQUEEZED 128
+
+/*
+ * Enables the AllocationLimitExceeded exception when the thread's
+ * allocation limit goes negative.
+ */
+#define TSO_ALLOC_LIMIT 256
+
+/*
+ * The number of times we spin in a spin lock before yielding (see
+ * #3758).  To tune this value, use the benchmark in #3758: run the
+ * server with -N2 and the client both on a dual-core.  Also make sure
+ * that the chosen value doesn't slow down any of the parallel
+ * benchmarks in nofib/parallel.
+ */
+#define SPIN_COUNT 1000
+
+/* -----------------------------------------------------------------------------
+   Spare workers per Capability in the threaded RTS
+
+   No more than MAX_SPARE_WORKERS will be kept in the thread pool
+   associated with each Capability.
+   -------------------------------------------------------------------------- */
+
+#define MAX_SPARE_WORKERS 6
+
+/*
+ * The maximum number of NUMA nodes we support.  This is a fixed limit so that
+ * we can have static arrays of this size in the RTS for speed.
+ */
+#define MAX_NUMA_NODES 16
diff --git a/includes/rts/EventLogFormat.h b/includes/rts/EventLogFormat.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/EventLogFormat.h
@@ -0,0 +1,264 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2008-2009
+ *
+ * Event log format
+ *
+ * The log format is designed to be extensible: old tools should be
+ * able to parse (but not necessarily understand all of) new versions
+ * of the format, and new tools will be able to understand old log
+ * files.
+ *
+ * Each event has a specific format.  If you add new events, give them
+ * new numbers: we never re-use old event numbers.
+ *
+ * - The format is endian-independent: all values are represented in
+ *    bigendian order.
+ *
+ * - The format is extensible:
+ *
+ *    - The header describes each event type and its length.  Tools
+ *      that don't recognise a particular event type can skip those events.
+ *
+ *    - There is room for extra information in the event type
+ *      specification, which can be ignored by older tools.
+ *
+ *    - Events can have extra information added, but existing fields
+ *      cannot be changed.  Tools should ignore extra fields at the
+ *      end of the event record.
+ *
+ *    - Old event type ids are never re-used; just take a new identifier.
+ *
+ *
+ * The format
+ * ----------
+ *
+ * log : EVENT_HEADER_BEGIN
+ *       EventType*
+ *       EVENT_HEADER_END
+ *       EVENT_DATA_BEGIN
+ *       Event*
+ *       EVENT_DATA_END
+ *
+ * EventType :
+ *       EVENT_ET_BEGIN
+ *       Word16         -- unique identifier for this event
+ *       Int16          -- >=0  size of the event in bytes (minus the header)
+ *                      -- -1   variable size
+ *       Word32         -- length of the next field in bytes
+ *       Word8*         -- string describing the event
+ *       Word32         -- length of the next field in bytes
+ *       Word8*         -- extra info (for future extensions)
+ *       EVENT_ET_END
+ *
+ * Event :
+ *       Word16         -- event_type
+ *       Word64         -- time (nanosecs)
+ *       [Word16]       -- length of the rest (for variable-sized events only)
+ *       ... extra event-specific info ...
+ *
+ *
+ * To add a new event
+ * ------------------
+ *
+ *  - In this file:
+ *    - give it a new number, add a new #define EVENT_XXX below
+ *  - In EventLog.c
+ *    - add it to the EventDesc array
+ *    - emit the event type in initEventLogging()
+ *    - emit the new event in postEvent_()
+ *    - generate the event itself by calling postEvent() somewhere
+ *  - In the Haskell code to parse the event log file:
+ *    - add types and code to read the new event
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/*
+ * Markers for begin/end of the Header.
+ */
+#define EVENT_HEADER_BEGIN    0x68647262 /* 'h' 'd' 'r' 'b' */
+#define EVENT_HEADER_END      0x68647265 /* 'h' 'd' 'r' 'e' */
+
+#define EVENT_DATA_BEGIN      0x64617462 /* 'd' 'a' 't' 'b' */
+#define EVENT_DATA_END        0xffff
+
+/*
+ * Markers for begin/end of the list of Event Types in the Header.
+ * Header, Event Type, Begin = hetb
+ * Header, Event Type, End = hete
+ */
+#define EVENT_HET_BEGIN       0x68657462 /* 'h' 'e' 't' 'b' */
+#define EVENT_HET_END         0x68657465 /* 'h' 'e' 't' 'e' */
+
+#define EVENT_ET_BEGIN        0x65746200 /* 'e' 't' 'b' 0 */
+#define EVENT_ET_END          0x65746500 /* 'e' 't' 'e' 0 */
+
+/*
+ * Types of event
+ */
+#define EVENT_CREATE_THREAD        0 /* (thread)               */
+#define EVENT_RUN_THREAD           1 /* (thread)               */
+#define EVENT_STOP_THREAD          2 /* (thread, status, blockinfo) */
+#define EVENT_THREAD_RUNNABLE      3 /* (thread)               */
+#define EVENT_MIGRATE_THREAD       4 /* (thread, new_cap)      */
+/* 5, 6, 7 deprecated */
+#define EVENT_THREAD_WAKEUP        8 /* (thread, other_cap)    */
+#define EVENT_GC_START             9 /* ()                     */
+#define EVENT_GC_END              10 /* ()                     */
+#define EVENT_REQUEST_SEQ_GC      11 /* ()                     */
+#define EVENT_REQUEST_PAR_GC      12 /* ()                     */
+/* 13, 14 deprecated */
+#define EVENT_CREATE_SPARK_THREAD 15 /* (spark_thread)         */
+#define EVENT_LOG_MSG             16 /* (message ...)          */
+/* 17 deprecated */
+#define EVENT_BLOCK_MARKER        18 /* (size, end_time, capability) */
+#define EVENT_USER_MSG            19 /* (message ...)          */
+#define EVENT_GC_IDLE             20 /* () */
+#define EVENT_GC_WORK             21 /* () */
+#define EVENT_GC_DONE             22 /* () */
+/* 23, 24 used by eden */
+#define EVENT_CAPSET_CREATE       25 /* (capset, capset_type)  */
+#define EVENT_CAPSET_DELETE       26 /* (capset)               */
+#define EVENT_CAPSET_ASSIGN_CAP   27 /* (capset, cap)          */
+#define EVENT_CAPSET_REMOVE_CAP   28 /* (capset, cap)          */
+/* the RTS identifier is in the form of "GHC-version rts_way"  */
+#define EVENT_RTS_IDENTIFIER      29 /* (capset, name_version_string) */
+/* the vectors in these events are null separated strings             */
+#define EVENT_PROGRAM_ARGS        30 /* (capset, commandline_vector)  */
+#define EVENT_PROGRAM_ENV         31 /* (capset, environment_vector)  */
+#define EVENT_OSPROCESS_PID       32 /* (capset, pid)          */
+#define EVENT_OSPROCESS_PPID      33 /* (capset, parent_pid)   */
+#define EVENT_SPARK_COUNTERS      34 /* (crt,dud,ovf,cnv,gcd,fiz,rem) */
+#define EVENT_SPARK_CREATE        35 /* ()                     */
+#define EVENT_SPARK_DUD           36 /* ()                     */
+#define EVENT_SPARK_OVERFLOW      37 /* ()                     */
+#define EVENT_SPARK_RUN           38 /* ()                     */
+#define EVENT_SPARK_STEAL         39 /* (victim_cap)           */
+#define EVENT_SPARK_FIZZLE        40 /* ()                     */
+#define EVENT_SPARK_GC            41 /* ()                     */
+#define EVENT_INTERN_STRING       42 /* (string, id) {not used by ghc} */
+#define EVENT_WALL_CLOCK_TIME     43 /* (capset, unix_epoch_seconds, nanoseconds) */
+#define EVENT_THREAD_LABEL        44 /* (thread, name_string)  */
+#define EVENT_CAP_CREATE          45 /* (cap)                  */
+#define EVENT_CAP_DELETE          46 /* (cap)                  */
+#define EVENT_CAP_DISABLE         47 /* (cap)                  */
+#define EVENT_CAP_ENABLE          48 /* (cap)                  */
+#define EVENT_HEAP_ALLOCATED      49 /* (heap_capset, alloc_bytes) */
+#define EVENT_HEAP_SIZE           50 /* (heap_capset, size_bytes) */
+#define EVENT_HEAP_LIVE           51 /* (heap_capset, live_bytes) */
+#define EVENT_HEAP_INFO_GHC       52 /* (heap_capset, n_generations,
+                                         max_heap_size, alloc_area_size,
+                                         mblock_size, block_size) */
+#define EVENT_GC_STATS_GHC        53 /* (heap_capset, generation,
+                                         copied_bytes, slop_bytes, frag_bytes,
+                                         par_n_threads,
+                                         par_max_copied,
+                                         par_tot_copied, par_balanced_copied) */
+#define EVENT_GC_GLOBAL_SYNC      54 /* ()                     */
+#define EVENT_TASK_CREATE         55 /* (taskID, cap, tid)       */
+#define EVENT_TASK_MIGRATE        56 /* (taskID, cap, new_cap)   */
+#define EVENT_TASK_DELETE         57 /* (taskID)                 */
+#define EVENT_USER_MARKER         58 /* (marker_name) */
+#define EVENT_HACK_BUG_T9003      59 /* Hack: see trac #9003 */
+
+/* Range 60 - 80 is used by eden for parallel tracing
+ * see http://www.mathematik.uni-marburg.de/~eden/
+ */
+
+/* Range 100 - 139 is reserved for Mercury. */
+
+/* Range 140 - 159 is reserved for Perf events. */
+
+/* Range 160 - 180 is reserved for cost-centre heap profiling events. */
+
+#define EVENT_HEAP_PROF_BEGIN              160
+#define EVENT_HEAP_PROF_COST_CENTRE        161
+#define EVENT_HEAP_PROF_SAMPLE_BEGIN       162
+#define EVENT_HEAP_PROF_SAMPLE_COST_CENTRE 163
+#define EVENT_HEAP_PROF_SAMPLE_STRING      164
+
+#define EVENT_USER_BINARY_MSG              181
+
+/*
+ * The highest event code +1 that ghc itself emits. Note that some event
+ * ranges higher than this are reserved but not currently emitted by ghc.
+ * This must match the size of the EventDesc[] array in EventLog.c
+ */
+#define NUM_GHC_EVENT_TAGS        182
+
+#if 0  /* DEPRECATED EVENTS: */
+/* we don't actually need to record the thread, it's implicit */
+#define EVENT_RUN_SPARK            5 /* (thread)               */
+#define EVENT_STEAL_SPARK          6 /* (thread, victim_cap)   */
+/* shutdown replaced by EVENT_CAP_DELETE */
+#define EVENT_SHUTDOWN             7 /* ()                     */
+/* ghc changed how it handles sparks so these are no longer applicable */
+#define EVENT_CREATE_SPARK        13 /* (cap, thread) */
+#define EVENT_SPARK_TO_THREAD     14 /* (cap, thread, spark_thread) */
+#define EVENT_STARTUP             17 /* (num_capabilities)     */
+/* these are used by eden but are replaced by new alternatives for ghc */
+#define EVENT_VERSION             23 /* (version_string) */
+#define EVENT_PROGRAM_INVOCATION  24 /* (commandline_string) */
+#endif
+
+/*
+ * Status values for EVENT_STOP_THREAD
+ *
+ * 1-5 are the StgRun return values (from includes/Constants.h):
+ *
+ * #define HeapOverflow   1
+ * #define StackOverflow  2
+ * #define ThreadYielding 3
+ * #define ThreadBlocked  4
+ * #define ThreadFinished 5
+ * #define ForeignCall                  6
+ * #define BlockedOnMVar                7
+ * #define BlockedOnBlackHole           8
+ * #define BlockedOnRead                9
+ * #define BlockedOnWrite               10
+ * #define BlockedOnDelay               11
+ * #define BlockedOnSTM                 12
+ * #define BlockedOnDoProc              13
+ * #define BlockedOnCCall               -- not used (see ForeignCall)
+ * #define BlockedOnCCall_NoUnblockExc  -- not used (see ForeignCall)
+ * #define BlockedOnMsgThrowTo          16
+ */
+#define THREAD_SUSPENDED_FOREIGN_CALL 6
+
+/*
+ * Capset type values for EVENT_CAPSET_CREATE
+ */
+#define CAPSET_TYPE_CUSTOM      1  /* reserved for end-user applications */
+#define CAPSET_TYPE_OSPROCESS   2  /* caps belong to the same OS process */
+#define CAPSET_TYPE_CLOCKDOMAIN 3  /* caps share a local clock/time      */
+
+/*
+ * Heap profile breakdown types. See EVENT_HEAP_PROF_BEGIN.
+ */
+typedef enum {
+    HEAP_PROF_BREAKDOWN_COST_CENTRE = 0x1,
+    HEAP_PROF_BREAKDOWN_MODULE,
+    HEAP_PROF_BREAKDOWN_CLOSURE_DESCR,
+    HEAP_PROF_BREAKDOWN_TYPE_DESCR,
+    HEAP_PROF_BREAKDOWN_RETAINER,
+    HEAP_PROF_BREAKDOWN_BIOGRAPHY,
+    HEAP_PROF_BREAKDOWN_CLOSURE_TYPE
+} HeapProfBreakdown;
+
+#if !defined(EVENTLOG_CONSTANTS_ONLY)
+
+typedef StgWord16 EventTypeNum;
+typedef StgWord64 EventTimestamp; /* in nanoseconds */
+typedef StgWord32 EventThreadID;
+typedef StgWord16 EventCapNo;
+typedef StgWord16 EventPayloadSize; /* variable-size events */
+typedef StgWord16 EventThreadStatus; /* status for EVENT_STOP_THREAD */
+typedef StgWord32 EventCapsetID;
+typedef StgWord16 EventCapsetType;   /* types for EVENT_CAPSET_CREATE */
+typedef StgWord64 EventTaskId;         /* for EVENT_TASK_* */
+typedef StgWord64 EventKernelThreadId; /* for EVENT_TASK_CREATE */
+
+#define EVENT_PAYLOAD_SIZE_MAX STG_WORD16_MAX
+#endif
diff --git a/includes/rts/EventLogWriter.h b/includes/rts/EventLogWriter.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/EventLogWriter.h
@@ -0,0 +1,40 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2008-2017
+ *
+ * Support for fast binary event logging.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include <stddef.h>
+#include <stdbool.h>
+
+/*
+ *  Abstraction for writing eventlog data.
+ */
+typedef struct {
+    // Initialize an EventLogWriter (may be NULL)
+    void (* initEventLogWriter) (void);
+
+    // Write a series of events
+    bool (* writeEventLog) (void *eventlog, size_t eventlog_size);
+
+    // Flush possibly existing buffers (may be NULL)
+    void (* flushEventLog) (void);
+
+    // Close an initialized EventLogOutput (may be NULL)
+    void (* stopEventLogWriter) (void);
+} EventLogWriter;
+
+/*
+ * An EventLogWriter which writes eventlogs to
+ * a file `program.eventlog`.
+ */
+extern const EventLogWriter FileEventLogWriter;
diff --git a/includes/rts/FileLock.h b/includes/rts/FileLock.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/FileLock.h
@@ -0,0 +1,19 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2007-2009
+ *
+ * File locking support as required by Haskell
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include "Stg.h"
+
+int  lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing);
+int  unlockFile(int fd);
diff --git a/includes/rts/Flags.h b/includes/rts/Flags.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Flags.h
@@ -0,0 +1,289 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Datatypes that holds the command-line flag settings.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include <stdio.h>
+#include <stdint.h>
+#include <stdbool.h>
+#include "stg/Types.h"
+#include "Time.h"
+
+/* For defaults, see the @initRtsFlagsDefaults@ routine. */
+
+/* Note [Synchronization of flags and base APIs]
+ *
+ * We provide accessors to RTS flags in base. (GHC.RTS module)
+ * The API should be updated whenever RTS flags are modified.
+ */
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _GC_FLAGS {
+    FILE   *statsFile;
+    uint32_t  giveStats;
+#define NO_GC_STATS	 0
+#define COLLECT_GC_STATS 1
+#define ONELINE_GC_STATS 2
+#define SUMMARY_GC_STATS 3
+#define VERBOSE_GC_STATS 4
+
+    uint32_t     maxStkSize;         /* in *words* */
+    uint32_t     initialStkSize;     /* in *words* */
+    uint32_t     stkChunkSize;       /* in *words* */
+    uint32_t     stkChunkBufferSize; /* in *words* */
+
+    uint32_t     maxHeapSize;        /* in *blocks* */
+    uint32_t     minAllocAreaSize;   /* in *blocks* */
+    uint32_t     largeAllocLim;      /* in *blocks* */
+    uint32_t     nurseryChunkSize;   /* in *blocks* */
+    uint32_t     minOldGenSize;      /* in *blocks* */
+    uint32_t     heapSizeSuggestion; /* in *blocks* */
+    bool heapSizeSuggestionAuto;
+    double  oldGenFactor;
+    double  pcFreeHeap;
+
+    uint32_t     generations;
+    bool squeezeUpdFrames;
+
+    bool compact;		/* True <=> "compact all the time" */
+    double  compactThreshold;
+
+    bool sweep;		/* use "mostly mark-sweep" instead of copying
+                                 * for the oldest generation */
+    bool ringBell;
+
+    Time    idleGCDelayTime;    /* units: TIME_RESOLUTION */
+    bool doIdleGC;
+
+    Time    longGCSync;         /* units: TIME_RESOLUTION */
+
+    StgWord heapBase;           /* address to ask the OS for memory */
+
+    StgWord allocLimitGrace;    /* units: *blocks*
+                                 * After an AllocationLimitExceeded
+                                 * exception has been raised, how much
+                                 * extra space is given to the thread
+                                 * to handle the exception before we
+                                 * raise it again.
+                                 */
+    StgWord heapLimitGrace;     /* units: *blocks*
+                                 * After a HeapOverflow exception has
+                                 * been raised, how much extra space is
+                                 * given to the thread to handle the
+                                 * exception before we raise it again.
+                                 */
+
+    bool numa;                   /* Use NUMA */
+    StgWord numaMask;
+} GC_FLAGS;
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _DEBUG_FLAGS {
+    /* flags to control debugging output & extra checking in various subsystems */
+    bool scheduler;      /* 's' */
+    bool interpreter;    /* 'i' */
+    bool weak;           /* 'w' */
+    bool gccafs;         /* 'G' */
+    bool gc;             /* 'g' */
+    bool block_alloc;    /* 'b' */
+    bool sanity;         /* 'S'   warning: might be expensive! */
+    bool stable;         /* 't' */
+    bool prof;           /* 'p' */
+    bool linker;         /* 'l'   the object linker */
+    bool apply;          /* 'a' */
+    bool stm;            /* 'm' */
+    bool squeeze;        /* 'z'  stack squeezing & lazy blackholing */
+    bool hpc;            /* 'c' coverage */
+    bool sparks;         /* 'r' */
+    bool numa;           /* '--debug-numa' */
+    bool compact;        /* 'C' */
+} DEBUG_FLAGS;
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _COST_CENTRE_FLAGS {
+    uint32_t    doCostCentres;
+# define COST_CENTRES_NONE      0
+# define COST_CENTRES_SUMMARY	1
+# define COST_CENTRES_VERBOSE	2 /* incl. serial time profile */
+# define COST_CENTRES_ALL	3
+# define COST_CENTRES_JSON      4
+
+    int	    profilerTicks;   /* derived */
+    int	    msecsPerTick;    /* derived */
+    char const *outputFileNameStem;
+} COST_CENTRE_FLAGS;
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _PROFILING_FLAGS {
+    uint32_t doHeapProfile;
+# define NO_HEAP_PROFILING	0	/* N.B. Used as indexes into arrays */
+# define HEAP_BY_CCS		1
+# define HEAP_BY_MOD		2
+# define HEAP_BY_DESCR		4
+# define HEAP_BY_TYPE		5
+# define HEAP_BY_RETAINER       6
+# define HEAP_BY_LDV            7
+
+# define HEAP_BY_CLOSURE_TYPE   8
+
+    Time        heapProfileInterval; /* time between samples */
+    uint32_t    heapProfileIntervalTicks; /* ticks between samples (derived) */
+    bool        includeTSOs;
+
+
+    bool		showCCSOnException;
+
+    uint32_t    maxRetainerSetSize;
+
+    uint32_t    ccsLength;
+
+    const char*         modSelector;
+    const char*         descrSelector;
+    const char*         typeSelector;
+    const char*         ccSelector;
+    const char*         ccsSelector;
+    const char*         retainerSelector;
+    const char*         bioSelector;
+
+} PROFILING_FLAGS;
+
+#define TRACE_NONE      0
+#define TRACE_EVENTLOG  1
+#define TRACE_STDERR    2
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _TRACE_FLAGS {
+    int tracing;
+    bool timestamp;      /* show timestamp in stderr output */
+    bool scheduler;      /* trace scheduler events */
+    bool gc;             /* trace GC events */
+    bool sparks_sampled; /* trace spark events by a sampled method */
+    bool sparks_full;    /* trace spark events 100% accurately */
+    bool user;           /* trace user events (emitted from Haskell code) */
+    char *trace_output;  /* output filename for eventlog */
+} TRACE_FLAGS;
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _CONCURRENT_FLAGS {
+    Time ctxtSwitchTime;         /* units: TIME_RESOLUTION */
+    int ctxtSwitchTicks;         /* derived */
+} CONCURRENT_FLAGS;
+
+/*
+ * The tickInterval is the time interval between "ticks", ie.
+ * timer signals (see Timer.{c,h}).  It is the frequency at
+ * which we sample CCCS for profiling.
+ *
+ * It is changed by the +RTS -V<secs> flag.
+ */
+#define DEFAULT_TICK_INTERVAL USToTime(10000)
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _MISC_FLAGS {
+    Time    tickInterval;        /* units: TIME_RESOLUTION */
+    bool install_signal_handlers;
+    bool install_seh_handlers;
+    bool generate_dump_file;
+    bool generate_stack_trace;
+    bool machineReadable;
+    bool internalCounters;       /* See Note [Internal Counter Stats] */
+    StgWord linkerMemBase;       /* address to ask the OS for memory
+                                  * for the linker, NULL ==> off */
+} MISC_FLAGS;
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _PAR_FLAGS {
+  uint32_t       nCapabilities;  /* number of threads to run simultaneously */
+  bool           migrate;        /* migrate threads between capabilities */
+  uint32_t       maxLocalSparks;
+  bool           parGcEnabled;   /* enable parallel GC */
+  uint32_t       parGcGen;       /* do parallel GC in this generation
+                                  * and higher only */
+  bool           parGcLoadBalancingEnabled;
+                                 /* enable load-balancing in the
+                                  * parallel GC */
+  uint32_t       parGcLoadBalancingGen;
+                                 /* do load-balancing in this
+                                  * generation and higher only */
+
+  uint32_t       parGcNoSyncWithIdle;
+                                 /* if a Capability has been idle for
+                                  * this many GCs, do not try to wake
+                                  * it up when doing a
+                                  * non-load-balancing parallel GC.
+                                  * (zero disables) */
+
+  uint32_t       parGcThreads;
+                                 /* Use this many threads for parallel
+                                  * GC (default: use all nNodes). */
+
+  bool           setAffinity;    /* force thread affinity with CPUs */
+} PAR_FLAGS;
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _TICKY_FLAGS {
+    bool showTickyStats;
+    FILE   *tickyFile;
+} TICKY_FLAGS;
+
+/* Put them together: */
+
+/* See Note [Synchronization of flags and base APIs] */
+typedef struct _RTS_FLAGS {
+    /* The first portion of RTS_FLAGS is invariant. */
+    GC_FLAGS	      GcFlags;
+    CONCURRENT_FLAGS  ConcFlags;
+    MISC_FLAGS        MiscFlags;
+    DEBUG_FLAGS	      DebugFlags;
+    COST_CENTRE_FLAGS CcFlags;
+    PROFILING_FLAGS   ProfFlags;
+    TRACE_FLAGS       TraceFlags;
+    TICKY_FLAGS	      TickyFlags;
+    PAR_FLAGS	      ParFlags;
+} RTS_FLAGS;
+
+#if defined(COMPILING_RTS_MAIN)
+extern DLLIMPORT RTS_FLAGS RtsFlags;
+#elif IN_STG_CODE
+/* Hack because the C code generator can't generate '&label'. */
+extern RTS_FLAGS RtsFlags[];
+#else
+extern RTS_FLAGS RtsFlags;
+#endif
+
+/*
+ * The printf formats are here, so we are less likely to make
+ * overly-long filenames (with disastrous results).  No more than 128
+ * chars, please!
+ */
+
+#define STATS_FILENAME_MAXLEN	128
+
+#define GR_FILENAME_FMT		"%0.124s.gr"
+#define HP_FILENAME_FMT		"%0.124s.hp"
+#define LIFE_FILENAME_FMT	"%0.122s.life"
+#define PROF_FILENAME_FMT	"%0.122s.prof"
+#define PROF_FILENAME_FMT_GUM	"%0.118s.%03d.prof"
+#define QP_FILENAME_FMT		"%0.124s.qp"
+#define STAT_FILENAME_FMT	"%0.122s.stat"
+#define TICKY_FILENAME_FMT	"%0.121s.ticky"
+#define TIME_FILENAME_FMT	"%0.122s.time"
+#define TIME_FILENAME_FMT_GUM	"%0.118s.%03d.time"
+
+/* an "int" so as to match normal "argc" */
+/* Now defined in Stg.h (lib/std/cbits need these too.)
+extern int     prog_argc;
+extern char  **prog_argv;
+*/
+extern int      rts_argc;  /* ditto */
+extern char   **rts_argv;
diff --git a/includes/rts/GetTime.h b/includes/rts/GetTime.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/GetTime.h
@@ -0,0 +1,16 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1995-2009
+ *
+ * Interface to the RTS time
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+StgWord64 getMonotonicNSec (void);
diff --git a/includes/rts/Globals.h b/includes/rts/Globals.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Globals.h
@@ -0,0 +1,36 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2006-2009
+ *
+ * The RTS stores some "global" values on behalf of libraries, so that
+ * some libraries can ensure that certain top-level things are shared
+ * even when multiple versions of the library are loaded.  e.g. see
+ * Data.Typeable and GHC.Conc.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#define mkStoreAccessorPrototype(name)                                  \
+    StgStablePtr                                                        \
+    getOrSet##name(StgStablePtr ptr);
+
+mkStoreAccessorPrototype(GHCConcSignalSignalHandlerStore)
+mkStoreAccessorPrototype(GHCConcWindowsPendingDelaysStore)
+mkStoreAccessorPrototype(GHCConcWindowsIOManagerThreadStore)
+mkStoreAccessorPrototype(GHCConcWindowsProddingStore)
+mkStoreAccessorPrototype(SystemEventThreadEventManagerStore)
+mkStoreAccessorPrototype(SystemEventThreadIOManagerThreadStore)
+mkStoreAccessorPrototype(SystemTimerThreadEventManagerStore)
+mkStoreAccessorPrototype(SystemTimerThreadIOManagerThreadStore)
+mkStoreAccessorPrototype(LibHSghcFastStringTable)
+mkStoreAccessorPrototype(LibHSghcPersistentLinkerState)
+mkStoreAccessorPrototype(LibHSghcInitLinkerDone)
+mkStoreAccessorPrototype(LibHSghcGlobalDynFlags)
+mkStoreAccessorPrototype(LibHSghcStaticOptions)
+mkStoreAccessorPrototype(LibHSghcStaticOptionsReady)
diff --git a/includes/rts/Hpc.h b/includes/rts/Hpc.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Hpc.h
@@ -0,0 +1,34 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2008-2009
+ *
+ * Haskell Program Coverage
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+// Simple linked list of modules
+typedef struct _HpcModuleInfo {
+  char *modName;                // name of module
+  StgWord32 tickCount;          // number of ticks
+  StgWord32 hashNo;             // Hash number for this module's mix info
+  StgWord64 *tixArr;            // tix Array; local for this module
+  bool from_file;               // data was read from the .tix file
+  struct _HpcModuleInfo *next;
+} HpcModuleInfo;
+
+void hs_hpc_module (char *modName,
+                    StgWord32 modCount,
+                    StgWord32 modHashNo,
+                    StgWord64 *tixArr);
+
+HpcModuleInfo * hs_hpc_rootModule (void);
+
+void startupHpc(void);
+void exitHpc(void);
diff --git a/includes/rts/IOManager.h b/includes/rts/IOManager.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/IOManager.h
@@ -0,0 +1,43 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * IO Manager functionality in the RTS
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+#if defined(mingw32_HOST_OS)
+
+int  rts_InstallConsoleEvent ( int action, StgStablePtr *handler );
+void rts_ConsoleHandlerDone  ( int ev );
+extern StgInt console_handler;
+
+void *   getIOManagerEvent  (void);
+HsWord32 readIOManagerEvent (void);
+void     sendIOManagerEvent (HsWord32 event);
+
+#else
+
+void     setIOManagerControlFd   (uint32_t cap_no, int fd);
+void     setTimerManagerControlFd(int fd);
+void     setIOManagerWakeupFd   (int fd);
+
+#endif
+
+//
+// Communicating with the IO manager thread (see GHC.Conc).
+// Posix implementation in posix/Signals.c
+// Win32 implementation in win32/ThrIOManager.c
+//
+void ioManagerWakeup (void);
+#if defined(THREADED_RTS)
+void ioManagerDie (void);
+void ioManagerStart (void);
+#endif
diff --git a/includes/rts/Libdw.h b/includes/rts/Libdw.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Libdw.h
@@ -0,0 +1,97 @@
+/* ---------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2014-2015
+ *
+ * Producing DWARF-based stacktraces with libdw.
+ *
+ * --------------------------------------------------------------------------*/
+
+#pragma once
+
+// for FILE
+#include <stdio.h>
+
+// Chunk capacity
+// This is rather arbitrary
+#define BACKTRACE_CHUNK_SZ 256
+
+/*
+ * Note [Chunked stack representation]
+ * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ *
+ * Consider the stack,
+ *     main                   calls                        (bottom of stack)
+ *       func1                which in turn calls
+ *         func2              which calls
+ *          func3             which calls
+ *            func4           which calls
+ *              func5         which calls
+ *                func6       which calls
+ *                  func7     which requests a backtrace   (top of stack)
+ *
+ * This would produce the Backtrace (using a smaller chunk size of three for
+ * illustrative purposes),
+ *
+ * Backtrace     /----> Chunk         /----> Chunk         /----> Chunk
+ * last --------/       next --------/       next --------/       next
+ * n_frames=8           n_frames=2           n_frames=3           n_frames=3
+ *                      ~~~~~~~~~~           ~~~~~~~~~~           ~~~~~~~~~~
+ *                      func1                func4                func7
+ *                      main                 func3                func6
+ *                                           func2                func5
+ *
+ */
+
+/* A chunk of code addresses from an execution stack
+ *
+ * The first address in this list corresponds to the stack frame
+ * nearest to the "top" of the stack.
+ */
+typedef struct BacktraceChunk_ {
+    StgWord n_frames;                      // number of frames in this chunk
+    struct BacktraceChunk_ *next;          // the chunk following this one
+    StgPtr frames[BACKTRACE_CHUNK_SZ];     // the code addresses from the
+                                           // frames
+} __attribute__((packed)) BacktraceChunk;
+
+/* A chunked list of code addresses from an execution stack
+ *
+ * This structure is optimized for append operations since we append O(stack
+ * depth) times yet typically only traverse the stack trace once. Consequently,
+ * the "top" stack frame (that is, the one where we started unwinding) can be
+ * found in the last chunk. Yes, this is a bit inconsistent with the ordering
+ * within a chunk. See Note [Chunked stack representation] for a depiction.
+ */
+typedef struct Backtrace_ {
+    StgWord n_frames;        // Total number of frames in the backtrace
+    BacktraceChunk *last;    // The first chunk of frames (corresponding to the
+                             // bottom of the stack)
+} Backtrace;
+
+/* Various information describing the location of an address */
+typedef struct Location_ {
+    const char *object_file;
+    const char *function;
+
+    // lineno and colno are only valid if source_file /= NULL
+    const char *source_file;
+    StgWord32 lineno;
+    StgWord32 colno;
+} __attribute__((packed)) Location;
+
+struct LibdwSession_;
+typedef struct LibdwSession_ LibdwSession;
+
+/* Free a backtrace */
+void backtraceFree(Backtrace *bt);
+
+/* Request a backtrace of the current stack state.
+ * May return NULL if a backtrace can't be acquired. */
+Backtrace *libdwGetBacktrace(LibdwSession *session);
+
+/* Lookup Location information for the given address.
+ * Returns 0 if successful, 1 if address could not be found. */
+int libdwLookupLocation(LibdwSession *session, Location *loc, StgPtr pc);
+
+/* Pretty-print a backtrace to the given FILE */
+void libdwPrintBacktrace(LibdwSession *session, FILE *file, Backtrace *bt);
diff --git a/includes/rts/LibdwPool.h b/includes/rts/LibdwPool.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/LibdwPool.h
@@ -0,0 +1,19 @@
+/* ---------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2015-2016
+ *
+ * A pool of libdw sessions
+ *
+ * --------------------------------------------------------------------------*/
+
+#pragma once
+
+/* Claim a session from the pool */
+LibdwSession *libdwPoolTake(void);
+
+/* Return a session to the pool */
+void libdwPoolRelease(LibdwSession *sess);
+
+/* Free any sessions in the pool forcing a reload of any loaded debug
+ * information */
+void libdwPoolClear(void);
diff --git a/includes/rts/Linker.h b/includes/rts/Linker.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Linker.h
@@ -0,0 +1,101 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2009
+ *
+ * RTS Object Linker
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(mingw32_HOST_OS)
+typedef wchar_t pathchar;
+#define PATH_FMT "ls"
+#else
+typedef char    pathchar;
+#define PATH_FMT "s"
+#endif
+
+/* Initialize the object linker. Equivalent to initLinker_(1). */
+void initLinker (void);
+
+/* Initialize the object linker.
+ * The retain_cafs argument is:
+ *
+ *   non-zero => Retain CAFs unconditionally in linked Haskell code.
+ *               Note that this prevents any code from being unloaded.
+ *               It should not be necessary unless you are GHCi or
+ *               hs-plugins, which needs to be able call any function
+ *               in the compiled code.
+ *
+ *   zero     => Do not retain CAFs.  Everything reachable from foreign
+ *               exports will be retained, due to the StablePtrs
+ *               created by the module initialisation code.  unloadObj
+ *               frees these StablePtrs, which will allow the CAFs to
+ *               be GC'd and the code to be removed.
+ */
+void initLinker_ (int retain_cafs);
+
+/* insert a symbol in the hash table */
+HsInt insertSymbol(pathchar* obj_name, char* key, void* data);
+
+/* lookup a symbol in the hash table */
+void *lookupSymbol( char *lbl );
+
+/* See Linker.c Note [runtime-linker-phases] */
+typedef enum {
+    OBJECT_LOADED,
+    OBJECT_NEEDED,
+    OBJECT_RESOLVED,
+    OBJECT_UNLOADED,
+    OBJECT_DONT_RESOLVE,
+    OBJECT_NOT_LOADED     /* The object was either never loaded or has been
+                             fully unloaded */
+} OStatus;
+
+/* check object load status */
+OStatus getObjectLoadStatus( pathchar *path );
+
+/* delete an object from the pool */
+HsInt unloadObj( pathchar *path );
+
+/* purge an object's symbols from the symbol table, but don't unload it */
+HsInt purgeObj( pathchar *path );
+
+/* add an obj (populate the global symbol table, but don't resolve yet) */
+HsInt loadObj( pathchar *path );
+
+/* add an arch (populate the global symbol table, but don't resolve yet) */
+HsInt loadArchive( pathchar *path );
+
+/* resolve all the currently unlinked objects in memory */
+HsInt resolveObjs( void );
+
+/* load a dynamic library */
+const char *addDLL( pathchar* dll_name );
+
+/* add a path to the library search path */
+HsPtr addLibrarySearchPath(pathchar* dll_path);
+
+/* removes a directory from the search path,
+   path must have been added using addLibrarySearchPath */
+HsBool removeLibrarySearchPath(HsPtr dll_path_index);
+
+/* give a warning about missing Windows patches that would make
+   the linker work better */
+void warnMissingKBLibraryPaths( void );
+
+/* -----------------------------------------------------------------------------
+* Searches the system directories to determine if there is a system DLL that
+* satisfies the given name. This prevent GHCi from linking against a static
+* library if a DLL is available.
+*/
+pathchar* findSystemLibrary(pathchar* dll_name);
+
+/* called by the initialization code for a module, not a user API */
+StgStablePtr foreignExportStablePtr (StgPtr p);
diff --git a/includes/rts/Main.h b/includes/rts/Main.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Main.h
@@ -0,0 +1,18 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2009
+ *
+ * Entry point for standalone Haskell programs.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* -----------------------------------------------------------------------------
+ * The entry point for Haskell programs that use a Haskell main function
+ * -------------------------------------------------------------------------- */
+
+int hs_main (int argc, char *argv[],     // program args
+             StgClosure *main_closure,   // closure for Main.main
+             RtsConfig rts_config)       // RTS configuration
+   GNUC3_ATTRIBUTE(__noreturn__);
diff --git a/includes/rts/Messages.h b/includes/rts/Messages.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Messages.h
@@ -0,0 +1,104 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Message API for use inside the RTS.  All messages generated by the
+ * RTS should go through one of the functions declared here, and we
+ * also provide hooks so that messages from the RTS can be redirected
+ * as appropriate.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include <stdarg.h>
+
+#if defined(mingw32_HOST_OS)
+/* On Win64, if we say "printf" then gcc thinks we are going to use
+   MS format specifiers like %I64d rather than %llu */
+#define PRINTF gnu_printf
+#else
+/* However, on OS X, "gnu_printf" isn't recognised */
+#define PRINTF printf
+#endif
+
+/* -----------------------------------------------------------------------------
+ * Message generation
+ * -------------------------------------------------------------------------- */
+
+/*
+ * A fatal internal error: this is for errors that probably indicate
+ * bugs in the RTS or compiler.  We normally output bug reporting
+ * instructions along with the error message.
+ *
+ * barf() invokes (*fatalInternalErrorFn)().  This function is not
+ * expected to return.
+ */
+void barf(const char *s, ...)
+   GNUC3_ATTRIBUTE(__noreturn__)
+   GNUC3_ATTRIBUTE(format(PRINTF, 1, 2));
+
+void vbarf(const char *s, va_list ap)
+   GNUC3_ATTRIBUTE(__noreturn__);
+
+// declared in Rts.h:
+// extern void _assertFail(const char *filename, unsigned int linenum)
+//    GNUC3_ATTRIBUTE(__noreturn__);
+
+/*
+ * An error condition which is caused by and/or can be corrected by
+ * the user.
+ *
+ * errorBelch() invokes (*errorMsgFn)().
+ */
+void errorBelch(const char *s, ...)
+   GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));
+
+void verrorBelch(const char *s, va_list ap);
+
+/*
+ * An error condition which is caused by and/or can be corrected by
+ * the user, and which has an associated error condition reported
+ * by the system (in errno on Unix, and GetLastError() on Windows).
+ * The system error message is appended to the message generated
+ * from the supplied format string.
+ *
+ * sysErrorBelch() invokes (*sysErrorMsgFn)().
+ */
+void sysErrorBelch(const char *s, ...)
+   GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));
+
+void vsysErrorBelch(const char *s, va_list ap);
+
+/*
+ * A debugging message.  Debugging messages are generated either as a
+ * virtue of having DEBUG turned on, or by being explicitly selected
+ * via RTS options (eg. +RTS -Ds).
+ *
+ * debugBelch() invokes (*debugMsgFn)().
+ */
+void debugBelch(const char *s, ...)
+   GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));
+
+void vdebugBelch(const char *s, va_list ap);
+
+
+/* Hooks for redirecting message generation: */
+
+typedef void RtsMsgFunction(const char *, va_list);
+
+extern RtsMsgFunction *fatalInternalErrorFn;
+extern RtsMsgFunction *debugMsgFn;
+extern RtsMsgFunction *errorMsgFn;
+
+/* Default stdio implementation of the message hooks: */
+
+extern RtsMsgFunction rtsFatalInternalErrorFn;
+extern RtsMsgFunction rtsDebugMsgFn;
+extern RtsMsgFunction rtsErrorMsgFn;
+extern RtsMsgFunction rtsSysErrorMsgFn;
diff --git a/includes/rts/OSThreads.h b/includes/rts/OSThreads.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/OSThreads.h
@@ -0,0 +1,258 @@
+/* ---------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2001-2009
+ *
+ * Accessing OS threads functionality in a (mostly) OS-independent
+ * manner.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * --------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(HAVE_PTHREAD_H) && !defined(mingw32_HOST_OS)
+
+#if defined(CMINUSMINUS)
+
+#define OS_ACQUIRE_LOCK(mutex) foreign "C" pthread_mutex_lock(mutex)
+#define OS_RELEASE_LOCK(mutex) foreign "C" pthread_mutex_unlock(mutex)
+#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */
+
+#else
+
+#include <pthread.h>
+#include <errno.h>
+
+typedef pthread_cond_t  Condition;
+typedef pthread_mutex_t Mutex;
+typedef pthread_t       OSThreadId;
+typedef pthread_key_t   ThreadLocalKey;
+
+#define OSThreadProcAttr /* nothing */
+
+#define INIT_COND_VAR       PTHREAD_COND_INITIALIZER
+
+#if defined(LOCK_DEBUG)
+#define LOCK_DEBUG_BELCH(what, mutex) \
+  debugBelch("%s(0x%p) %s %d\n", what, mutex, __FILE__, __LINE__)
+#else
+#define LOCK_DEBUG_BELCH(what, mutex) /* nothing */
+#endif
+
+/* Always check the result of lock and unlock. */
+#define OS_ACQUIRE_LOCK(mutex) \
+  LOCK_DEBUG_BELCH("ACQUIRE_LOCK", mutex); \
+  if (pthread_mutex_lock(mutex) == EDEADLK) { \
+    barf("multiple ACQUIRE_LOCK: %s %d", __FILE__,__LINE__); \
+  }
+
+// Returns zero if the lock was acquired.
+EXTERN_INLINE int TRY_ACQUIRE_LOCK(pthread_mutex_t *mutex);
+EXTERN_INLINE int TRY_ACQUIRE_LOCK(pthread_mutex_t *mutex)
+{
+    LOCK_DEBUG_BELCH("TRY_ACQUIRE_LOCK", mutex);
+    return pthread_mutex_trylock(mutex);
+}
+
+#define OS_RELEASE_LOCK(mutex) \
+  LOCK_DEBUG_BELCH("RELEASE_LOCK", mutex); \
+  if (pthread_mutex_unlock(mutex) != 0) { \
+    barf("RELEASE_LOCK: I do not own this lock: %s %d", __FILE__,__LINE__); \
+  }
+
+// Note: this assertion calls pthread_mutex_lock() on a mutex that
+// is already held by the calling thread.  The mutex should therefore
+// have been created with PTHREAD_MUTEX_ERRORCHECK, otherwise this
+// assertion will hang.  We always initialise mutexes with
+// PTHREAD_MUTEX_ERRORCHECK when DEBUG is on (see rts/posix/OSThreads.h).
+#define OS_ASSERT_LOCK_HELD(mutex) ASSERT(pthread_mutex_lock(mutex) == EDEADLK)
+
+#endif // CMINUSMINUS
+
+# elif defined(HAVE_WINDOWS_H)
+
+#if defined(CMINUSMINUS)
+
+/* We jump through a hoop here to get a CCall EnterCriticalSection
+   and LeaveCriticalSection, as that's what C-- wants. */
+
+#define OS_ACQUIRE_LOCK(mutex) foreign "stdcall" EnterCriticalSection(mutex)
+#define OS_RELEASE_LOCK(mutex) foreign "stdcall" LeaveCriticalSection(mutex)
+#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */
+
+#else
+
+#include <windows.h>
+
+typedef HANDLE Condition;
+typedef DWORD OSThreadId;
+// don't be tempted to use HANDLE as the OSThreadId: there can be
+// many HANDLES to a given thread, so comparison would not work.
+typedef DWORD ThreadLocalKey;
+
+#define OSThreadProcAttr __stdcall
+
+#define INIT_COND_VAR  0
+
+// We have a choice for implementing Mutexes on Windows.  Standard
+// Mutexes are kernel objects that require kernel calls to
+// acquire/release, whereas CriticalSections are spin-locks that block
+// in the kernel after spinning for a configurable number of times.
+// CriticalSections are *much* faster, so we use those.  The Mutex
+// implementation is left here for posterity.
+#define USE_CRITICAL_SECTIONS 1
+
+#if USE_CRITICAL_SECTIONS
+
+typedef CRITICAL_SECTION Mutex;
+
+#if defined(LOCK_DEBUG)
+
+#define OS_ACQUIRE_LOCK(mutex) \
+  debugBelch("ACQUIRE_LOCK(0x%p) %s %d\n", mutex,__FILE__,__LINE__); \
+  EnterCriticalSection(mutex)
+#define OS_RELEASE_LOCK(mutex) \
+  debugBelch("RELEASE_LOCK(0x%p) %s %d\n", mutex,__FILE__,__LINE__); \
+  LeaveCriticalSection(mutex)
+#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */
+
+#else
+
+#define OS_ACQUIRE_LOCK(mutex)      EnterCriticalSection(mutex)
+#define TRY_ACQUIRE_LOCK(mutex)  (TryEnterCriticalSection(mutex) == 0)
+#define OS_RELEASE_LOCK(mutex)      LeaveCriticalSection(mutex)
+
+// I don't know how to do this.  TryEnterCriticalSection() doesn't do
+// the right thing.
+#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */
+
+#endif
+
+#else
+
+typedef HANDLE Mutex;
+
+// casting to (Mutex *) here required due to use in .cmm files where
+// the argument has (void *) type.
+#define OS_ACQUIRE_LOCK(mutex)                                     \
+    if (WaitForSingleObject(*((Mutex *)mutex),INFINITE) == WAIT_FAILED) { \
+        barf("WaitForSingleObject: %d", GetLastError());        \
+    }
+
+#define OS_RELEASE_LOCK(mutex)                             \
+    if (ReleaseMutex(*((Mutex *)mutex)) == 0) {         \
+        barf("ReleaseMutex: %d", GetLastError());       \
+    }
+
+#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */
+#endif
+
+#endif // CMINUSMINUS
+
+# elif defined(THREADED_RTS)
+#  error "Threads not supported"
+# endif
+
+
+#if !defined(CMINUSMINUS)
+//
+// General thread operations
+//
+extern OSThreadId osThreadId      ( void );
+extern void shutdownThread        ( void )   GNUC3_ATTRIBUTE(__noreturn__);
+extern void yieldThread           ( void );
+
+typedef void* OSThreadProcAttr OSThreadProc(void *);
+
+extern int  createOSThread        ( OSThreadId* tid, char *name,
+                                    OSThreadProc *startProc, void *param);
+extern bool osThreadIsAlive       ( OSThreadId id );
+extern void interruptOSThread     (OSThreadId id);
+
+//
+// Condition Variables
+//
+extern void initCondition         ( Condition* pCond );
+extern void closeCondition        ( Condition* pCond );
+extern bool broadcastCondition    ( Condition* pCond );
+extern bool signalCondition       ( Condition* pCond );
+extern bool waitCondition         ( Condition* pCond, Mutex* pMut );
+
+//
+// Mutexes
+//
+extern void initMutex             ( Mutex* pMut );
+extern void closeMutex            ( Mutex* pMut );
+
+//
+// Thread-local storage
+//
+void  newThreadLocalKey (ThreadLocalKey *key);
+void *getThreadLocalVar (ThreadLocalKey *key);
+void  setThreadLocalVar (ThreadLocalKey *key, void *value);
+void  freeThreadLocalKey (ThreadLocalKey *key);
+
+// Processors and affinity
+void setThreadAffinity (uint32_t n, uint32_t m);
+void setThreadNode (uint32_t node);
+void releaseThreadNode (void);
+#endif // !CMINUSMINUS
+
+#if defined(THREADED_RTS)
+
+#define ACQUIRE_LOCK(l) OS_ACQUIRE_LOCK(l)
+#define RELEASE_LOCK(l) OS_RELEASE_LOCK(l)
+#define ASSERT_LOCK_HELD(l) OS_ASSERT_LOCK_HELD(l)
+
+#else
+
+#define ACQUIRE_LOCK(l)
+#define RELEASE_LOCK(l)
+#define ASSERT_LOCK_HELD(l)
+
+#endif /* defined(THREADED_RTS) */
+
+#if !defined(CMINUSMINUS)
+//
+// Support for forkOS (defined regardless of THREADED_RTS, but does
+// nothing when !THREADED_RTS).
+//
+int forkOS_createThread ( HsStablePtr entry );
+
+//
+// Free any global resources created in OSThreads.
+//
+void freeThreadingResources(void);
+
+//
+// Returns the number of processor cores in the machine
+//
+uint32_t getNumberOfProcessors (void);
+
+//
+// Support for getting at the kernel thread Id for tracing/profiling.
+//
+// This stuff is optional and only used for tracing/profiling purposes, to
+// match up thread ids recorded by other tools. For example, on Linux and OSX
+// the pthread_t type is not the same as the kernel thread id, and system
+// profiling tools like Linux perf, and OSX's DTrace use the kernel thread Id.
+// So if we want to match up RTS tasks with kernel threads recorded by these
+// tools then we need to know the kernel thread Id, and this must be a separate
+// type from the OSThreadId.
+//
+// If the feature cannot be supported on an OS, it is OK to always return 0.
+// In particular it would almost certaily be meaningless on systems not using
+// a 1:1 threading model.
+
+// We use a common serialisable representation on all OSs
+// This is ok for Windows, OSX and Linux.
+typedef StgWord64 KernelThreadId;
+
+// Get the current kernel thread id
+KernelThreadId kernelThreadId (void);
+
+#endif /* CMINUSMINUS */
diff --git a/includes/rts/Parallel.h b/includes/rts/Parallel.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Parallel.h
@@ -0,0 +1,16 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Parallelism-related functionality
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+StgInt newSpark (StgRegTable *reg, StgClosure *p);
diff --git a/includes/rts/PrimFloat.h b/includes/rts/PrimFloat.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/PrimFloat.h
@@ -0,0 +1,17 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Primitive floating-point operations
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+StgDouble __int_encodeDouble (I_ j, I_ e);
+StgFloat  __int_encodeFloat (I_ j, I_ e);
+StgDouble __word_encodeDouble (W_ j, I_ e);
+StgFloat  __word_encodeFloat (W_ j, I_ e);
diff --git a/includes/rts/Profiling.h b/includes/rts/Profiling.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Profiling.h
@@ -0,0 +1,17 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2017-2018
+ *
+ * Cost-centre profiling API
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+void registerCcList(CostCentre **cc_list);
+void registerCcsList(CostCentreStack **cc_list);
diff --git a/includes/rts/Signals.h b/includes/rts/Signals.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Signals.h
@@ -0,0 +1,23 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * RTS signal handling 
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* NB. #included in Haskell code, no prototypes in here. */
+
+/* arguments to stg_sig_install() */
+#define STG_SIG_DFL   (-1)
+#define STG_SIG_IGN   (-2)
+#define STG_SIG_ERR   (-3)
+#define STG_SIG_HAN   (-4)
+#define STG_SIG_RST   (-5)
diff --git a/includes/rts/SpinLock.h b/includes/rts/SpinLock.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/SpinLock.h
@@ -0,0 +1,116 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2006-2009
+ *
+ * Spin locks
+ *
+ * These are simple spin-only locks as opposed to Mutexes which
+ * probably spin for a while before blocking in the kernel.  We use
+ * these when we are sure that all our threads are actively running on
+ * a CPU, eg. in the GC.
+ *
+ * TODO: measure whether we really need these, or whether Mutexes
+ * would do (and be a bit safer if a CPU becomes loaded).
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+#if defined(THREADED_RTS)
+
+#if defined(PROF_SPIN)
+typedef struct SpinLock_
+{
+    StgWord   lock;
+    StgWord64 spin;  // incremented every time we spin in ACQUIRE_SPIN_LOCK
+    StgWord64 yield; // incremented every time we yield in ACQUIRE_SPIN_LOCK
+} SpinLock;
+#else
+typedef StgWord SpinLock;
+#endif
+
+#if defined(PROF_SPIN)
+
+// PROF_SPIN enables counting the number of times we spin on a lock
+
+// acquire spin lock
+INLINE_HEADER void ACQUIRE_SPIN_LOCK(SpinLock * p)
+{
+    StgWord32 r = 0;
+    uint32_t i;
+    do {
+        for (i = 0; i < SPIN_COUNT; i++) {
+            r = cas((StgVolatilePtr)&(p->lock), 1, 0);
+            if (r != 0) return;
+            p->spin++;
+            busy_wait_nop();
+        }
+        p->yield++;
+        yieldThread();
+    } while (1);
+}
+
+// release spin lock
+INLINE_HEADER void RELEASE_SPIN_LOCK(SpinLock * p)
+{
+    write_barrier();
+    p->lock = 1;
+}
+
+// initialise spin lock
+INLINE_HEADER void initSpinLock(SpinLock * p)
+{
+    write_barrier();
+    p->lock = 1;
+    p->spin = 0;
+    p->yield = 0;
+}
+
+#else
+
+// acquire spin lock
+INLINE_HEADER void ACQUIRE_SPIN_LOCK(SpinLock * p)
+{
+    StgWord32 r = 0;
+    uint32_t i;
+    do {
+        for (i = 0; i < SPIN_COUNT; i++) {
+            r = cas((StgVolatilePtr)p, 1, 0);
+            if (r != 0) return;
+            busy_wait_nop();
+        }
+        yieldThread();
+    } while (1);
+}
+
+// release spin lock
+INLINE_HEADER void RELEASE_SPIN_LOCK(SpinLock * p)
+{
+    write_barrier();
+    (*p) = 1;
+}
+
+// init spin lock
+INLINE_HEADER void initSpinLock(SpinLock * p)
+{
+    write_barrier();
+    (*p) = 1;
+}
+
+#endif /* PROF_SPIN */
+
+#else /* !THREADED_RTS */
+
+// Using macros here means we don't have to ensure the argument is in scope
+#define ACQUIRE_SPIN_LOCK(p) /* nothing */
+#define RELEASE_SPIN_LOCK(p) /* nothing */
+
+INLINE_HEADER void initSpinLock(void * p STG_UNUSED)
+{ /* nothing */ }
+
+#endif /* THREADED_RTS */
diff --git a/includes/rts/StableName.h b/includes/rts/StableName.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/StableName.h
@@ -0,0 +1,32 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Stable Names
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* -----------------------------------------------------------------------------
+   PRIVATE from here.
+   -------------------------------------------------------------------------- */
+
+typedef struct {
+    StgPtr  addr;        // Haskell object when entry is in use, next free
+                         // entry (NULL when this is the last free entry)
+                         // otherwise. May be NULL temporarily during GC (when
+                         // pointee dies).
+
+    StgPtr  old;         // Old Haskell object, used during GC
+
+    StgClosure *sn_obj;  // The StableName object, or NULL when the entry is
+                         // free
+} snEntry;
+
+extern DLL_IMPORT_RTS snEntry *stable_name_table;
diff --git a/includes/rts/StablePtr.h b/includes/rts/StablePtr.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/StablePtr.h
@@ -0,0 +1,35 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * Stable Pointers
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+EXTERN_INLINE StgPtr deRefStablePtr (StgStablePtr stable_ptr);
+StgStablePtr getStablePtr  (StgPtr p);
+
+/* -----------------------------------------------------------------------------
+   PRIVATE from here.
+   -------------------------------------------------------------------------- */
+
+typedef struct {
+    StgPtr addr;         // Haskell object when entry is in use, next free
+                         // entry (NULL when this is the last free entry)
+                         // otherwise.
+} spEntry;
+
+extern DLL_IMPORT_RTS spEntry *stable_ptr_table;
+
+EXTERN_INLINE
+StgPtr deRefStablePtr(StgStablePtr sp)
+{
+    return stable_ptr_table[(StgWord)sp].addr;
+}
diff --git a/includes/rts/StaticPtrTable.h b/includes/rts/StaticPtrTable.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/StaticPtrTable.h
@@ -0,0 +1,44 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2008-2009
+ *
+ * Initialization of the Static Pointer Table
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/** Inserts an entry in the Static Pointer Table.
+ *
+ * The key is a fingerprint computed from the static pointer and the spe_closure
+ * is a pointer to the closure defining the table entry.
+ *
+ * A stable pointer to the closure is made to prevent it from being garbage
+ * collected while the entry exists on the table.
+ *
+ * This function is called from the code generated by
+ * compiler/deSugar/StaticPtrTable.sptInitCode
+ *
+ * */
+void hs_spt_insert (StgWord64 key[2],void* spe_closure);
+
+/** Inserts an entry for a StgTablePtr in the Static Pointer Table.
+ *
+ * This function is called from the GHCi interpreter to insert
+ * SPT entries for bytecode objects.
+ *
+ * */
+void hs_spt_insert_stableptr(StgWord64 key[2], StgStablePtr *entry);
+
+/** Removes an entry from the Static Pointer Table.
+ *
+ * This function is called from the code generated by
+ * compiler/deSugar/StaticPtrTable.sptInitCode
+ *
+ * */
+void hs_spt_remove (StgWord64 key[2]);
diff --git a/includes/rts/TTY.h b/includes/rts/TTY.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/TTY.h
@@ -0,0 +1,17 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2009
+ *
+ * POSIX TTY-related functionality
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+void* __hscore_get_saved_termios(int fd);
+void  __hscore_set_saved_termios(int fd, void* ts);
diff --git a/includes/rts/Threads.h b/includes/rts/Threads.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Threads.h
@@ -0,0 +1,74 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team 1998-2009
+ *
+ * External API for the scheduler.  For most uses, the functions in
+ * RtsAPI.h should be enough.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(HAVE_SYS_TYPES_H)
+#include <sys/types.h>
+#endif
+
+//
+// Creating threads
+//
+StgTSO *createThread (Capability *cap, W_ stack_size);
+
+void scheduleWaitThread (/* in    */ StgTSO *tso,
+                         /* out   */ HaskellObj* ret,
+                         /* inout */ Capability **cap);
+
+StgTSO *createGenThread       (Capability *cap, W_ stack_size,
+                               StgClosure *closure);
+StgTSO *createIOThread        (Capability *cap, W_ stack_size,
+                               StgClosure *closure);
+StgTSO *createStrictIOThread  (Capability *cap, W_ stack_size,
+                               StgClosure *closure);
+
+// Suspending/resuming threads around foreign calls
+void *        suspendThread (StgRegTable *, bool interruptible);
+StgRegTable * resumeThread  (void *);
+
+//
+// Thread operations from Threads.c
+//
+int     cmp_thread                       (StgPtr tso1, StgPtr tso2);
+int     rts_getThreadId                  (StgPtr tso);
+void    rts_enableThreadAllocationLimit  (StgPtr tso);
+void    rts_disableThreadAllocationLimit (StgPtr tso);
+
+#if !defined(mingw32_HOST_OS)
+pid_t  forkProcess     (HsStablePtr *entry);
+#else
+pid_t  forkProcess     (HsStablePtr *entry)
+    GNU_ATTRIBUTE(__noreturn__);
+#endif
+
+HsBool rtsSupportsBoundThreads (void);
+
+// The number of Capabilities.
+// ToDo: I would like this to be private to the RTS and instead expose a
+// function getNumCapabilities(), but it is used in compiler/cbits/genSym.c
+extern unsigned int n_capabilities;
+
+// The number of Capabilities that are not disabled
+extern uint32_t enabled_capabilities;
+
+#if !IN_STG_CODE
+extern Capability MainCapability;
+#endif
+
+//
+// Change the number of capabilities (only supports increasing the
+// current value at the moment).
+//
+extern void setNumCapabilities (uint32_t new_);
diff --git a/includes/rts/Ticky.h b/includes/rts/Ticky.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Ticky.h
@@ -0,0 +1,32 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * TICKY_TICKY types
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* -----------------------------------------------------------------------------
+   The StgEntCounter type - needed regardless of TICKY_TICKY
+   -------------------------------------------------------------------------- */
+
+typedef struct _StgEntCounter {
+  /* Using StgWord for everything, because both the C and asm code
+     generators make trouble if you try to pack things tighter */
+    StgWord     registeredp;    /* 0 == no, 1 == yes */
+    StgInt      arity;          /* arity (static info) */
+    StgInt      allocd;         /* # allocation of this closure */
+                                /* (rest of args are in registers) */
+    char        *str;           /* name of the thing */
+    char        *arg_kinds;     /* info about the args types */
+    StgInt      entry_count;    /* Trips to fast entry code */
+    StgInt      allocs;         /* number of allocations by this fun */
+    struct _StgEntCounter *link;/* link to chain them all together */
+} StgEntCounter;
diff --git a/includes/rts/Time.h b/includes/rts/Time.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Time.h
@@ -0,0 +1,44 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * Time values in the RTS
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * --------------------------------------------------------------------------*/
+
+#pragma once
+
+// For most time values in the RTS we use a fixed resolution of nanoseconds,
+// normalising the time we get from platform-dependent APIs to this
+// resolution.
+#define TIME_RESOLUTION 1000000000
+typedef int64_t Time;
+
+#define TIME_MAX HS_INT64_MAX
+
+#if TIME_RESOLUTION == 1000000000
+// I'm being lazy, but it's awkward to define fully general versions of these
+#define TimeToMS(t)      ((t) / 1000000)
+#define TimeToUS(t)      ((t) / 1000)
+#define TimeToNS(t)      (t)
+#define MSToTime(t)      ((Time)(t) * 1000000)
+#define USToTime(t)      ((Time)(t) * 1000)
+#define NSToTime(t)      ((Time)(t))
+#else
+#error Fix TimeToNS(), TimeToUS() etc.
+#endif
+
+#define SecondsToTime(t) ((Time)(t) * TIME_RESOLUTION)
+#define TimeToSeconds(t) ((t) / TIME_RESOLUTION)
+
+// Use instead of SecondsToTime() when we have a floating-point
+// seconds value, to avoid truncating it.
+INLINE_HEADER Time fsecondsToTime (double t)
+{
+    return (Time)(t * TIME_RESOLUTION);
+}
+
+Time getProcessElapsedTime (void);
diff --git a/includes/rts/Timer.h b/includes/rts/Timer.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Timer.h
@@ -0,0 +1,18 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1995-2009
+ *
+ * Interface to the RTS timer signal (uses OS-dependent Ticker.h underneath)
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+void startTimer (void);
+void stopTimer  (void);
+int rtsTimerSignal (void);
diff --git a/includes/rts/Types.h b/includes/rts/Types.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Types.h
@@ -0,0 +1,31 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * RTS-specific types.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include <stddef.h>
+#include <stdbool.h>
+
+// Deprecated, use uint32_t instead.
+typedef unsigned int nat __attribute__((deprecated));  /* uint32_t */
+
+/* ullong (64|128-bit) type: only include if needed (not ANSI) */
+#if defined(__GNUC__)
+#define LL(x) (x##LL)
+#else
+#define LL(x) (x##L)
+#endif
+
+typedef struct StgClosure_   StgClosure;
+typedef struct StgInfoTable_ StgInfoTable;
+typedef struct StgTSO_       StgTSO;
diff --git a/includes/rts/Utils.h b/includes/rts/Utils.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/Utils.h
@@ -0,0 +1,16 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * RTS external APIs.  This file declares everything that the GHC RTS
+ * exposes externally.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* Alternate to raise(3) for threaded rts, for BSD-based OSes */
+int genericRaise(int sig);
diff --git a/includes/rts/prof/CCS.h b/includes/rts/prof/CCS.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/prof/CCS.h
@@ -0,0 +1,226 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2009-2012
+ *
+ * Macros for profiling operations in STG code
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* -----------------------------------------------------------------------------
+ * Data Structures
+ * ---------------------------------------------------------------------------*/
+/*
+ * Note [struct alignment]
+ * NB. be careful to avoid unwanted padding between fields, by
+ * putting the 8-byte fields on an 8-byte boundary.  Padding can
+ * vary between C compilers, and we don't take into account any
+ * possible padding when generating CCS and CC decls in the code
+ * generator (compiler/codeGen/StgCmmProf.hs).
+ */
+
+typedef struct CostCentre_ {
+    StgInt ccID;              // Unique Id, allocated by the RTS
+
+    char * label;
+    char * module;
+    char * srcloc;
+
+    // used for accumulating costs at the end of the run...
+    StgWord64 mem_alloc;      // align 8 (Note [struct alignment])
+    StgWord   time_ticks;
+
+    StgBool is_caf;           // true <=> CAF cost centre
+
+    struct CostCentre_ *link;
+} CostCentre;
+
+typedef struct CostCentreStack_ {
+    StgInt ccsID;               // unique ID, allocated by the RTS
+
+    CostCentre *cc;             // Cost centre at the top of the stack
+
+    struct CostCentreStack_ *prevStack;   // parent
+    struct IndexTable_      *indexTable;  // children
+    struct CostCentreStack_ *root;        // root of stack
+    StgWord    depth;           // number of items in the stack
+
+    StgWord64  scc_count;       // Count of times this CCS is entered
+                                // align 8 (Note [struct alignment])
+
+    StgWord    selected;        // is this CCS shown in the heap
+                                // profile? (zero if excluded via -hc
+                                // -hm etc.)
+
+    StgWord    time_ticks;      // number of time ticks accumulated by
+                                // this CCS
+
+    StgWord64  mem_alloc;       // mem allocated by this CCS
+                                // align 8 (Note [struct alignment])
+
+    StgWord64  inherited_alloc; // sum of mem_alloc over all children
+                                // (calculated at the end)
+                                // align 8 (Note [struct alignment])
+
+    StgWord    inherited_ticks; // sum of time_ticks over all children
+                                // (calculated at the end)
+} CostCentreStack;
+
+
+/* -----------------------------------------------------------------------------
+ * Start and stop the profiling timer.  These can be called from
+ * Haskell to restrict the profile to portion(s) of the execution.
+ * See the module GHC.Profiling.
+ * ---------------------------------------------------------------------------*/
+
+void stopProfTimer      ( void );
+void startProfTimer     ( void );
+
+/* -----------------------------------------------------------------------------
+ * The rest is PROFILING only...
+ * ---------------------------------------------------------------------------*/
+
+#if defined(PROFILING)
+
+/* -----------------------------------------------------------------------------
+ * Constants
+ * ---------------------------------------------------------------------------*/
+
+#define EMPTY_STACK NULL
+#define EMPTY_TABLE NULL
+
+/* Constants used to set is_caf flag on CostCentres */
+#define CC_IS_CAF      true
+#define CC_NOT_CAF     false
+/* -----------------------------------------------------------------------------
+ * Data Structures
+ * ---------------------------------------------------------------------------*/
+
+// IndexTable is the list of children of a CCS. (Alternatively it is a
+// cache of the results of pushing onto a CCS, so that the second and
+// subsequent times we push a certain CC on a CCS we get the same
+// result).
+
+typedef struct IndexTable_ {
+    // Just a linked list of (cc, ccs) pairs, where the `ccs` is the result of
+    // pushing `cc` to the owner of the index table (another CostCentreStack).
+    CostCentre *cc;
+    CostCentreStack *ccs;
+    struct IndexTable_ *next;
+    // back_edge is true when `cc` is already in the stack, so pushing it
+    // truncates or drops (see RECURSION_DROPS and RECURSION_TRUNCATES in
+    // Profiling.c).
+    bool back_edge;
+} IndexTable;
+
+
+/* -----------------------------------------------------------------------------
+   Pre-defined cost centres and cost centre stacks
+   -------------------------------------------------------------------------- */
+
+#if IN_STG_CODE
+
+extern StgWord CC_MAIN[];
+extern StgWord CCS_MAIN[];      // Top CCS
+
+extern StgWord CC_SYSTEM[];
+extern StgWord CCS_SYSTEM[];    // RTS costs
+
+extern StgWord CC_GC[];
+extern StgWord CCS_GC[];         // Garbage collector costs
+
+extern StgWord CC_OVERHEAD[];
+extern StgWord CCS_OVERHEAD[];   // Profiling overhead
+
+extern StgWord CC_DONT_CARE[];
+extern StgWord CCS_DONT_CARE[];  // CCS attached to static constructors
+
+#else
+
+extern CostCentre      CC_MAIN[];
+extern CostCentreStack CCS_MAIN[];      // Top CCS
+
+extern CostCentre      CC_SYSTEM[];
+extern CostCentreStack CCS_SYSTEM[];    // RTS costs
+
+extern CostCentre      CC_GC[];
+extern CostCentreStack CCS_GC[];         // Garbage collector costs
+
+extern CostCentre      CC_OVERHEAD[];
+extern CostCentreStack CCS_OVERHEAD[];   // Profiling overhead
+
+extern CostCentre      CC_DONT_CARE[];
+extern CostCentreStack CCS_DONT_CARE[];  // shouldn't ever get set
+
+extern CostCentre      CC_PINNED[];
+extern CostCentreStack CCS_PINNED[];     // pinned memory
+
+extern CostCentre      CC_IDLE[];
+extern CostCentreStack CCS_IDLE[];       // capability is idle
+
+#endif /* IN_STG_CODE */
+
+extern unsigned int RTS_VAR(era);
+
+/* -----------------------------------------------------------------------------
+ * Functions
+ * ---------------------------------------------------------------------------*/
+
+CostCentreStack * pushCostCentre (CostCentreStack *, CostCentre *);
+void              enterFunCCS    (StgRegTable *reg, CostCentreStack *);
+CostCentre *mkCostCentre (char *label, char *module, char *srcloc);
+
+extern CostCentre * RTS_VAR(CC_LIST);               // registered CC list
+
+/* -----------------------------------------------------------------------------
+ * Declaring Cost Centres & Cost Centre Stacks.
+ * -------------------------------------------------------------------------- */
+
+# define CC_DECLARE(cc_ident,name,mod,loc,caf,is_local)  \
+     is_local CostCentre cc_ident[1]                     \
+       = {{ .ccID       = 0,                             \
+            .label      = name,                          \
+            .module     = mod,                           \
+            .srcloc     = loc,                           \
+            .time_ticks = 0,                             \
+            .mem_alloc  = 0,                             \
+            .link       = 0,                             \
+            .is_caf     = caf                            \
+         }};
+
+# define CCS_DECLARE(ccs_ident,cc_ident,is_local)        \
+     is_local CostCentreStack ccs_ident[1]               \
+       = {{ .ccsID               = 0,                    \
+            .cc                  = cc_ident,             \
+            .prevStack           = NULL,                 \
+            .indexTable          = NULL,                 \
+            .root                = NULL,                 \
+            .depth               = 0,                    \
+            .selected            = 0,                    \
+            .scc_count           = 0,                    \
+            .time_ticks          = 0,                    \
+            .mem_alloc           = 0,                    \
+            .inherited_ticks     = 0,                    \
+            .inherited_alloc     = 0                     \
+       }};
+
+/* -----------------------------------------------------------------------------
+ * Time / Allocation Macros
+ * ---------------------------------------------------------------------------*/
+
+/* eliminate profiling overhead from allocation costs */
+#define CCS_ALLOC(ccs, size) (ccs)->mem_alloc += ((size)-sizeofW(StgProfHeader))
+#define ENTER_CCS_THUNK(cap,p) cap->r.rCCCS = p->header.prof.ccs
+
+#else /* !PROFILING */
+
+#define CCS_ALLOC(ccs, amount) doNothing()
+#define ENTER_CCS_THUNK(cap,p) doNothing()
+
+#endif /* PROFILING */
diff --git a/includes/rts/prof/LDV.h b/includes/rts/prof/LDV.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/prof/LDV.h
@@ -0,0 +1,44 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow, 2009
+ *
+ * Lag/Drag/Void profiling.
+ *
+ * Do not #include this file directly: #include "Rts.h" instead.
+ *
+ * To understand the structure of the RTS headers, see the wiki:
+ *   http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#if defined(PROFILING)
+
+/* retrieves the LDV word from closure c */
+#define LDVW(c)                 (((StgClosure *)(c))->header.prof.hp.ldvw)
+
+/*
+ * Stores the creation time for closure c.
+ * This macro is called at the very moment of closure creation.
+ *
+ * NOTE: this initializes LDVW(c) to zero, which ensures that there
+ * is no conflict between retainer profiling and LDV profiling,
+ * because retainer profiling also expects LDVW(c) to be initialised
+ * to zero.
+ */
+
+#if defined(CMINUSMINUS)
+
+#else
+
+#define LDV_RECORD_CREATE(c)   \
+  LDVW((c)) = ((StgWord)RTS_DEREF(era) << LDV_SHIFT) | LDV_STATE_CREATE
+
+#endif
+
+#else  /* !PROFILING */
+
+#define LDV_RECORD_CREATE(c)   /* nothing */
+
+#endif /* PROFILING */
diff --git a/includes/rts/storage/Block.h b/includes/rts/storage/Block.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/Block.h
@@ -0,0 +1,341 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-1999
+ *
+ * Block structure for the storage manager
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include "ghcconfig.h"
+
+/* The actual block and megablock-size constants are defined in
+ * includes/Constants.h, all constants here are derived from these.
+ */
+
+/* Block related constants (BLOCK_SHIFT is defined in Constants.h) */
+
+#if SIZEOF_LONG == SIZEOF_VOID_P
+#define UNIT 1UL
+#elif SIZEOF_LONG_LONG == SIZEOF_VOID_P
+#define UNIT 1ULL
+#else
+#error "Size of pointer is suspicious."
+#endif
+
+#if defined(CMINUSMINUS)
+#define BLOCK_SIZE   (1<<BLOCK_SHIFT)
+#else
+#define BLOCK_SIZE   (UNIT<<BLOCK_SHIFT)
+// Note [integer overflow]
+#endif
+
+#define BLOCK_SIZE_W (BLOCK_SIZE/sizeof(W_))
+#define BLOCK_MASK   (BLOCK_SIZE-1)
+
+#define BLOCK_ROUND_UP(p)   (((W_)(p)+BLOCK_SIZE-1) & ~BLOCK_MASK)
+#define BLOCK_ROUND_DOWN(p) ((void *) ((W_)(p) & ~BLOCK_MASK))
+
+/* Megablock related constants (MBLOCK_SHIFT is defined in Constants.h) */
+
+#if defined(CMINUSMINUS)
+#define MBLOCK_SIZE    (1<<MBLOCK_SHIFT)
+#else
+#define MBLOCK_SIZE    (UNIT<<MBLOCK_SHIFT)
+// Note [integer overflow]
+#endif
+
+#define MBLOCK_SIZE_W  (MBLOCK_SIZE/sizeof(W_))
+#define MBLOCK_MASK    (MBLOCK_SIZE-1)
+
+#define MBLOCK_ROUND_UP(p)   ((void *)(((W_)(p)+MBLOCK_SIZE-1) & ~MBLOCK_MASK))
+#define MBLOCK_ROUND_DOWN(p) ((void *)((W_)(p) & ~MBLOCK_MASK ))
+
+/* The largest size an object can be before we give it a block of its
+ * own and treat it as an immovable object during GC, expressed as a
+ * fraction of BLOCK_SIZE.
+ */
+#define LARGE_OBJECT_THRESHOLD ((uint32_t)(BLOCK_SIZE * 8 / 10))
+
+/*
+ * Note [integer overflow]
+ *
+ * The UL suffix in BLOCK_SIZE and MBLOCK_SIZE promotes the expression
+ * to an unsigned long, which means that expressions involving these
+ * will be promoted to unsigned long, which makes integer overflow
+ * less likely.  Historically, integer overflow in expressions like
+ *    (n * BLOCK_SIZE)
+ * where n is int or unsigned int, have caused obscure segfaults in
+ * programs that use large amounts of memory (e.g. #7762, #5086).
+ */
+
+/* -----------------------------------------------------------------------------
+ * Block descriptor.  This structure *must* be the right length, so we
+ * can do pointer arithmetic on pointers to it.
+ */
+
+/* The block descriptor is 64 bytes on a 64-bit machine, and 32-bytes
+ * on a 32-bit machine.
+ */
+
+// Note: fields marked with [READ ONLY] must not be modified by the
+// client of the block allocator API.  All other fields can be
+// freely modified.
+
+#if !defined(CMINUSMINUS)
+typedef struct bdescr_ {
+
+    StgPtr start;              // [READ ONLY] start addr of memory
+
+    StgPtr free;               // First free byte of memory.
+                               // allocGroup() sets this to the value of start.
+                               // NB. during use this value should lie
+                               // between start and start + blocks *
+                               // BLOCK_SIZE.  Values outside this
+                               // range are reserved for use by the
+                               // block allocator.  In particular, the
+                               // value (StgPtr)(-1) is used to
+                               // indicate that a block is unallocated.
+
+    struct bdescr_ *link;      // used for chaining blocks together
+
+    union {
+        struct bdescr_ *back;  // used (occasionally) for doubly-linked lists
+        StgWord *bitmap;       // bitmap for marking GC
+        StgPtr  scan;          // scan pointer for copying GC
+    } u;
+
+    struct generation_ *gen;   // generation
+
+    StgWord16 gen_no;          // gen->no, cached
+    StgWord16 dest_no;         // number of destination generation
+    StgWord16 node;            // which memory node does this block live on?
+
+    StgWord16 flags;           // block flags, see below
+
+    StgWord32 blocks;          // [READ ONLY] no. of blocks in a group
+                               // (if group head, 0 otherwise)
+
+#if SIZEOF_VOID_P == 8
+    StgWord32 _padding[3];
+#else
+    StgWord32 _padding[0];
+#endif
+} bdescr;
+#endif
+
+#if SIZEOF_VOID_P == 8
+#define BDESCR_SIZE  0x40
+#define BDESCR_MASK  0x3f
+#define BDESCR_SHIFT 6
+#else
+#define BDESCR_SIZE  0x20
+#define BDESCR_MASK  0x1f
+#define BDESCR_SHIFT 5
+#endif
+
+/* Block contains objects evacuated during this GC */
+#define BF_EVACUATED 1
+/* Block is a large object */
+#define BF_LARGE     2
+/* Block is pinned */
+#define BF_PINNED    4
+/* Block is to be marked, not copied */
+#define BF_MARKED    8
+/* Block is executable */
+#define BF_EXEC      32
+/* Block contains only a small amount of live data */
+#define BF_FRAGMENTED 64
+/* we know about this block (for finding leaks) */
+#define BF_KNOWN     128
+/* Block was swept in the last generation */
+#define BF_SWEPT     256
+/* Block is part of a Compact */
+#define BF_COMPACT   512
+/* Maximum flag value (do not define anything higher than this!) */
+#define BF_FLAG_MAX  (1 << 15)
+
+/* Finding the block descriptor for a given block -------------------------- */
+
+#if defined(CMINUSMINUS)
+
+#define Bdescr(p) \
+    ((((p) &  MBLOCK_MASK & ~BLOCK_MASK) >> (BLOCK_SHIFT-BDESCR_SHIFT)) \
+     | ((p) & ~MBLOCK_MASK))
+
+#else
+
+EXTERN_INLINE bdescr *Bdescr(StgPtr p);
+EXTERN_INLINE bdescr *Bdescr(StgPtr p)
+{
+  return (bdescr *)
+    ((((W_)p &  MBLOCK_MASK & ~BLOCK_MASK) >> (BLOCK_SHIFT-BDESCR_SHIFT))
+     | ((W_)p & ~MBLOCK_MASK)
+     );
+}
+
+#endif
+
+/* Useful Macros ------------------------------------------------------------ */
+
+/* Offset of first real data block in a megablock */
+
+#define FIRST_BLOCK_OFF \
+   ((W_)BLOCK_ROUND_UP(BDESCR_SIZE * (MBLOCK_SIZE / BLOCK_SIZE)))
+
+/* First data block in a given megablock */
+
+#define FIRST_BLOCK(m) ((void *)(FIRST_BLOCK_OFF + (W_)(m)))
+
+/* Last data block in a given megablock */
+
+#define LAST_BLOCK(m)  ((void *)(MBLOCK_SIZE-BLOCK_SIZE + (W_)(m)))
+
+/* First real block descriptor in a megablock */
+
+#define FIRST_BDESCR(m) \
+   ((bdescr *)((FIRST_BLOCK_OFF>>(BLOCK_SHIFT-BDESCR_SHIFT)) + (W_)(m)))
+
+/* Last real block descriptor in a megablock */
+
+#define LAST_BDESCR(m) \
+  ((bdescr *)(((MBLOCK_SIZE-BLOCK_SIZE)>>(BLOCK_SHIFT-BDESCR_SHIFT)) + (W_)(m)))
+
+/* Number of usable blocks in a megablock */
+
+#if !defined(CMINUSMINUS) // already defined in DerivedConstants.h
+#define BLOCKS_PER_MBLOCK ((MBLOCK_SIZE - FIRST_BLOCK_OFF) / BLOCK_SIZE)
+#endif
+
+/* How many blocks in this megablock group */
+
+#define MBLOCK_GROUP_BLOCKS(n) \
+   (BLOCKS_PER_MBLOCK + (n-1) * (MBLOCK_SIZE / BLOCK_SIZE))
+
+/* Compute the required size of a megablock group */
+
+#define BLOCKS_TO_MBLOCKS(n) \
+   (1 + (W_)MBLOCK_ROUND_UP((n-BLOCKS_PER_MBLOCK) * BLOCK_SIZE) / MBLOCK_SIZE)
+
+
+#if !defined(CMINUSMINUS)
+/* to the end... */
+
+/* Double-linked block lists: --------------------------------------------- */
+
+INLINE_HEADER void
+dbl_link_onto(bdescr *bd, bdescr **list)
+{
+  bd->link = *list;
+  bd->u.back = NULL;
+  if (*list) {
+    (*list)->u.back = bd; /* double-link the list */
+  }
+  *list = bd;
+}
+
+INLINE_HEADER void
+dbl_link_remove(bdescr *bd, bdescr **list)
+{
+    if (bd->u.back) {
+        bd->u.back->link = bd->link;
+    } else {
+        *list = bd->link;
+    }
+    if (bd->link) {
+        bd->link->u.back = bd->u.back;
+    }
+}
+
+INLINE_HEADER void
+dbl_link_insert_after(bdescr *bd, bdescr *after)
+{
+    bd->link = after->link;
+    bd->u.back = after;
+    if (after->link) {
+        after->link->u.back = bd;
+    }
+    after->link = bd;
+}
+
+INLINE_HEADER void
+dbl_link_replace(bdescr *new_, bdescr *old, bdescr **list)
+{
+    new_->link = old->link;
+    new_->u.back = old->u.back;
+    if (old->link) {
+        old->link->u.back = new_;
+    }
+    if (old->u.back) {
+        old->u.back->link = new_;
+    } else {
+        *list = new_;
+    }
+}
+
+/* Initialisation ---------------------------------------------------------- */
+
+extern void initBlockAllocator(void);
+
+/* Allocation -------------------------------------------------------------- */
+
+bdescr *allocGroup(W_ n);
+
+EXTERN_INLINE bdescr* allocBlock(void);
+EXTERN_INLINE bdescr* allocBlock(void)
+{
+    return allocGroup(1);
+}
+
+bdescr *allocGroupOnNode(uint32_t node, W_ n);
+
+EXTERN_INLINE bdescr* allocBlockOnNode(uint32_t node);
+EXTERN_INLINE bdescr* allocBlockOnNode(uint32_t node)
+{
+    return allocGroupOnNode(node,1);
+}
+
+// versions that take the storage manager lock for you:
+bdescr *allocGroup_lock(W_ n);
+bdescr *allocBlock_lock(void);
+
+bdescr *allocGroupOnNode_lock(uint32_t node, W_ n);
+bdescr *allocBlockOnNode_lock(uint32_t node);
+
+/* De-Allocation ----------------------------------------------------------- */
+
+void freeGroup(bdescr *p);
+void freeChain(bdescr *p);
+
+// versions that take the storage manager lock for you:
+void freeGroup_lock(bdescr *p);
+void freeChain_lock(bdescr *p);
+
+bdescr * splitBlockGroup (bdescr *bd, uint32_t blocks);
+
+/* Round a value to megablocks --------------------------------------------- */
+
+// We want to allocate an object around a given size, round it up or
+// down to the nearest size that will fit in an mblock group.
+INLINE_HEADER StgWord
+round_to_mblocks(StgWord words)
+{
+    if (words > BLOCKS_PER_MBLOCK * BLOCK_SIZE_W) {
+        // first, ignore the gap at the beginning of the first mblock by
+        // adding it to the total words.  Then we can pretend we're
+        // dealing in a uniform unit of megablocks.
+        words += FIRST_BLOCK_OFF/sizeof(W_);
+
+        if ((words % MBLOCK_SIZE_W) < (MBLOCK_SIZE_W / 2)) {
+            words = (words / MBLOCK_SIZE_W) * MBLOCK_SIZE_W;
+        } else {
+            words = ((words / MBLOCK_SIZE_W) + 1) * MBLOCK_SIZE_W;
+        }
+
+        words -= FIRST_BLOCK_OFF/sizeof(W_);
+    }
+    return words;
+}
+
+#endif /* !CMINUSMINUS */
diff --git a/includes/rts/storage/ClosureMacros.h b/includes/rts/storage/ClosureMacros.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/ClosureMacros.h
@@ -0,0 +1,587 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2012
+ *
+ * Macros for building and manipulating closures
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/* -----------------------------------------------------------------------------
+   Info tables are slammed up against the entry code, and the label
+   for the info table is at the *end* of the table itself.  This
+   inline function adjusts an info pointer to point to the beginning
+   of the table, so we can use standard C structure indexing on it.
+
+   Note: this works for SRT info tables as long as you don't want to
+   access the SRT, since they are laid out the same with the SRT
+   pointer as the first word in the table.
+
+   NOTES ABOUT MANGLED C VS. MINI-INTERPRETER:
+
+   A couple of definitions:
+
+       "info pointer"    The first word of the closure.  Might point
+                         to either the end or the beginning of the
+                         info table, depending on whether we're using
+                         the mini interpreter or not.  GET_INFO(c)
+                         retrieves the info pointer of a closure.
+
+       "info table"      The info table structure associated with a
+                         closure.  This is always a pointer to the
+                         beginning of the structure, so we can
+                         use standard C structure indexing to pull out
+                         the fields.  get_itbl(c) returns a pointer to
+                         the info table for closure c.
+
+   An address of the form xxxx_info points to the end of the info
+   table or the beginning of the info table depending on whether we're
+   mangling or not respectively.  So,
+
+         c->header.info = xxx_info
+
+   makes absolute sense, whether mangling or not.
+
+   -------------------------------------------------------------------------- */
+
+INLINE_HEADER void SET_INFO(StgClosure *c, const StgInfoTable *info) {
+    c->header.info = info;
+}
+INLINE_HEADER const StgInfoTable *GET_INFO(StgClosure *c) {
+    return c->header.info;
+}
+
+#define GET_ENTRY(c)  (ENTRY_CODE(GET_INFO(c)))
+
+#if defined(TABLES_NEXT_TO_CODE)
+EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info);
+EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgInfoTable *)info - 1;}
+EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info);
+EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgRetInfoTable *)info - 1;}
+INLINE_HEADER StgFunInfoTable *FUN_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgFunInfoTable *)info - 1;}
+INLINE_HEADER StgThunkInfoTable *THUNK_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgThunkInfoTable *)info - 1;}
+INLINE_HEADER StgConInfoTable *CON_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgConInfoTable *)info - 1;}
+INLINE_HEADER StgFunInfoTable *itbl_to_fun_itbl(const StgInfoTable *i) {return (StgFunInfoTable *)(i + 1) - 1;}
+INLINE_HEADER StgRetInfoTable *itbl_to_ret_itbl(const StgInfoTable *i) {return (StgRetInfoTable *)(i + 1) - 1;}
+INLINE_HEADER StgThunkInfoTable *itbl_to_thunk_itbl(const StgInfoTable *i) {return (StgThunkInfoTable *)(i + 1) - 1;}
+INLINE_HEADER StgConInfoTable *itbl_to_con_itbl(const StgInfoTable *i) {return (StgConInfoTable *)(i + 1) - 1;}
+#else
+EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info);
+EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgInfoTable *)info;}
+EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info);
+EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgRetInfoTable *)info;}
+INLINE_HEADER StgFunInfoTable *FUN_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgFunInfoTable *)info;}
+INLINE_HEADER StgThunkInfoTable *THUNK_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgThunkInfoTable *)info;}
+INLINE_HEADER StgConInfoTable *CON_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgConInfoTable *)info;}
+INLINE_HEADER StgFunInfoTable *itbl_to_fun_itbl(const StgInfoTable *i) {return (StgFunInfoTable *)i;}
+INLINE_HEADER StgRetInfoTable *itbl_to_ret_itbl(const StgInfoTable *i) {return (StgRetInfoTable *)i;}
+INLINE_HEADER StgThunkInfoTable *itbl_to_thunk_itbl(const StgInfoTable *i) {return (StgThunkInfoTable *)i;}
+INLINE_HEADER StgConInfoTable *itbl_to_con_itbl(const StgInfoTable *i) {return (StgConInfoTable *)i;}
+#endif
+
+EXTERN_INLINE const StgInfoTable *get_itbl(const StgClosure *c);
+EXTERN_INLINE const StgInfoTable *get_itbl(const StgClosure *c)
+{
+   return INFO_PTR_TO_STRUCT(c->header.info);
+}
+
+EXTERN_INLINE const StgRetInfoTable *get_ret_itbl(const StgClosure *c);
+EXTERN_INLINE const StgRetInfoTable *get_ret_itbl(const StgClosure *c)
+{
+   return RET_INFO_PTR_TO_STRUCT(c->header.info);
+}
+
+INLINE_HEADER const StgFunInfoTable *get_fun_itbl(const StgClosure *c)
+{
+   return FUN_INFO_PTR_TO_STRUCT(c->header.info);
+}
+
+INLINE_HEADER const StgThunkInfoTable *get_thunk_itbl(const StgClosure *c)
+{
+   return THUNK_INFO_PTR_TO_STRUCT(c->header.info);
+}
+
+INLINE_HEADER const StgConInfoTable *get_con_itbl(const StgClosure *c)
+{
+   return CON_INFO_PTR_TO_STRUCT((c)->header.info);
+}
+
+INLINE_HEADER StgHalfWord GET_TAG(const StgClosure *con)
+{
+    return get_itbl(con)->srt;
+}
+
+/* -----------------------------------------------------------------------------
+   Macros for building closures
+   -------------------------------------------------------------------------- */
+
+#if defined(PROFILING)
+#if defined(DEBUG_RETAINER)
+/*
+  For the sake of debugging, we take the safest way for the moment. Actually, this
+  is useful to check the sanity of heap before beginning retainer profiling.
+  flip is defined in RetainerProfile.c, and declared as extern in RetainerProfile.h.
+  Note: change those functions building Haskell objects from C datatypes, i.e.,
+  all rts_mk???() functions in RtsAPI.c, as well.
+ */
+#define SET_PROF_HDR(c,ccs_)            \
+        ((c)->header.prof.ccs = ccs_, (c)->header.prof.hp.rs = (retainerSet *)((StgWord)NULL | flip))
+#else
+/*
+  For retainer profiling only: we do not have to set (c)->header.prof.hp.rs to
+  NULL | flip (flip is defined in RetainerProfile.c) because even when flip
+  is 1, rs is invalid and will be initialized to NULL | flip later when
+  the closure *c is visited.
+ */
+/*
+#define SET_PROF_HDR(c,ccs_)            \
+        ((c)->header.prof.ccs = ccs_, (c)->header.prof.hp.rs = NULL)
+ */
+/*
+  The following macro works for both retainer profiling and LDV profiling:
+  for retainer profiling, ldvTime remains 0, so rs fields are initialized to 0.
+  See the invariants on ldvTime.
+ */
+#define SET_PROF_HDR(c,ccs_)            \
+        ((c)->header.prof.ccs = ccs_,   \
+        LDV_RECORD_CREATE((c)))
+#endif /* DEBUG_RETAINER */
+#else
+#define SET_PROF_HDR(c,ccs)
+#endif
+
+#define SET_HDR(c,_info,ccs)                            \
+   {                                                    \
+        (c)->header.info = _info;                       \
+        SET_PROF_HDR((StgClosure *)(c),ccs);            \
+   }
+
+#define SET_ARR_HDR(c,info,costCentreStack,n_bytes)     \
+   SET_HDR(c,info,costCentreStack);                     \
+   (c)->bytes = n_bytes;
+
+// Use when changing a closure from one kind to another
+#define OVERWRITE_INFO(c, new_info)                             \
+    OVERWRITING_CLOSURE((StgClosure *)(c));                     \
+    SET_INFO((StgClosure *)(c), (new_info));                    \
+    LDV_RECORD_CREATE(c);
+
+/* -----------------------------------------------------------------------------
+   How to get hold of the static link field for a static closure.
+   -------------------------------------------------------------------------- */
+
+/* These are hard-coded. */
+#define THUNK_STATIC_LINK(p) (&(p)->payload[1])
+#define IND_STATIC_LINK(p)   (&(p)->payload[1])
+
+INLINE_HEADER StgClosure **
+STATIC_LINK(const StgInfoTable *info, StgClosure *p)
+{
+    switch (info->type) {
+    case THUNK_STATIC:
+        return THUNK_STATIC_LINK(p);
+    case IND_STATIC:
+        return IND_STATIC_LINK(p);
+    default:
+        return &(p)->payload[info->layout.payload.ptrs +
+                             info->layout.payload.nptrs];
+    }
+}
+
+/* -----------------------------------------------------------------------------
+   INTLIKE and CHARLIKE closures.
+   -------------------------------------------------------------------------- */
+
+INLINE_HEADER P_ CHARLIKE_CLOSURE(int n) {
+    return (P_)&stg_CHARLIKE_closure[(n)-MIN_CHARLIKE];
+}
+INLINE_HEADER P_ INTLIKE_CLOSURE(int n) {
+    return (P_)&stg_INTLIKE_closure[(n)-MIN_INTLIKE];
+}
+
+/* ----------------------------------------------------------------------------
+   Macros for untagging and retagging closure pointers
+   For more information look at the comments in Cmm.h
+   ------------------------------------------------------------------------- */
+
+static inline StgWord
+GET_CLOSURE_TAG(const StgClosure * p)
+{
+    return (StgWord)p & TAG_MASK;
+}
+
+static inline StgClosure *
+UNTAG_CLOSURE(StgClosure * p)
+{
+    return (StgClosure*)((StgWord)p & ~TAG_MASK);
+}
+
+static inline const StgClosure *
+UNTAG_CONST_CLOSURE(const StgClosure * p)
+{
+    return (const StgClosure*)((StgWord)p & ~TAG_MASK);
+}
+
+static inline StgClosure *
+TAG_CLOSURE(StgWord tag,StgClosure * p)
+{
+    return (StgClosure*)((StgWord)p | tag);
+}
+
+/* -----------------------------------------------------------------------------
+   Forwarding pointers
+   -------------------------------------------------------------------------- */
+
+#define IS_FORWARDING_PTR(p) ((((StgWord)p) & 1) != 0)
+#define MK_FORWARDING_PTR(p) (((StgWord)p) | 1)
+#define UN_FORWARDING_PTR(p) (((StgWord)p) - 1)
+
+/* -----------------------------------------------------------------------------
+   DEBUGGING predicates for pointers
+
+   LOOKS_LIKE_INFO_PTR(p)    returns False if p is definitely not an info ptr
+   LOOKS_LIKE_CLOSURE_PTR(p) returns False if p is definitely not a closure ptr
+
+   These macros are complete but not sound.  That is, they might
+   return false positives.  Do not rely on them to distinguish info
+   pointers from closure pointers, for example.
+
+   We don't use address-space predicates these days, for portability
+   reasons, and the fact that code/data can be scattered about the
+   address space in a dynamically-linked environment.  Our best option
+   is to look at the alleged info table and see whether it seems to
+   make sense...
+   -------------------------------------------------------------------------- */
+
+INLINE_HEADER bool LOOKS_LIKE_INFO_PTR_NOT_NULL (StgWord p)
+{
+    StgInfoTable *info = INFO_PTR_TO_STRUCT((StgInfoTable *)p);
+    return info->type != INVALID_OBJECT && info->type < N_CLOSURE_TYPES;
+}
+
+INLINE_HEADER bool LOOKS_LIKE_INFO_PTR (StgWord p)
+{
+    return p && (IS_FORWARDING_PTR(p) || LOOKS_LIKE_INFO_PTR_NOT_NULL(p));
+}
+
+INLINE_HEADER bool LOOKS_LIKE_CLOSURE_PTR (const void *p)
+{
+    return LOOKS_LIKE_INFO_PTR((StgWord)
+            (UNTAG_CONST_CLOSURE((const StgClosure *)(p)))->header.info);
+}
+
+/* -----------------------------------------------------------------------------
+   Macros for calculating the size of a closure
+   -------------------------------------------------------------------------- */
+
+EXTERN_INLINE StgOffset PAP_sizeW   ( uint32_t n_args );
+EXTERN_INLINE StgOffset PAP_sizeW   ( uint32_t n_args )
+{ return sizeofW(StgPAP) + n_args; }
+
+EXTERN_INLINE StgOffset AP_sizeW   ( uint32_t n_args );
+EXTERN_INLINE StgOffset AP_sizeW   ( uint32_t n_args )
+{ return sizeofW(StgAP) + n_args; }
+
+EXTERN_INLINE StgOffset AP_STACK_sizeW ( uint32_t size );
+EXTERN_INLINE StgOffset AP_STACK_sizeW ( uint32_t size )
+{ return sizeofW(StgAP_STACK) + size; }
+
+EXTERN_INLINE StgOffset CONSTR_sizeW( uint32_t p, uint32_t np );
+EXTERN_INLINE StgOffset CONSTR_sizeW( uint32_t p, uint32_t np )
+{ return sizeofW(StgHeader) + p + np; }
+
+EXTERN_INLINE StgOffset THUNK_SELECTOR_sizeW ( void );
+EXTERN_INLINE StgOffset THUNK_SELECTOR_sizeW ( void )
+{ return sizeofW(StgSelector); }
+
+EXTERN_INLINE StgOffset BLACKHOLE_sizeW ( void );
+EXTERN_INLINE StgOffset BLACKHOLE_sizeW ( void )
+{ return sizeofW(StgInd); } // a BLACKHOLE is a kind of indirection
+
+/* --------------------------------------------------------------------------
+   Sizes of closures
+   ------------------------------------------------------------------------*/
+
+EXTERN_INLINE StgOffset sizeW_fromITBL( const StgInfoTable* itbl );
+EXTERN_INLINE StgOffset sizeW_fromITBL( const StgInfoTable* itbl )
+{ return sizeofW(StgClosure)
+       + sizeofW(StgPtr)  * itbl->layout.payload.ptrs
+       + sizeofW(StgWord) * itbl->layout.payload.nptrs; }
+
+EXTERN_INLINE StgOffset thunk_sizeW_fromITBL( const StgInfoTable* itbl );
+EXTERN_INLINE StgOffset thunk_sizeW_fromITBL( const StgInfoTable* itbl )
+{ return sizeofW(StgThunk)
+       + sizeofW(StgPtr)  * itbl->layout.payload.ptrs
+       + sizeofW(StgWord) * itbl->layout.payload.nptrs; }
+
+EXTERN_INLINE StgOffset ap_stack_sizeW( StgAP_STACK* x );
+EXTERN_INLINE StgOffset ap_stack_sizeW( StgAP_STACK* x )
+{ return AP_STACK_sizeW(x->size); }
+
+EXTERN_INLINE StgOffset ap_sizeW( StgAP* x );
+EXTERN_INLINE StgOffset ap_sizeW( StgAP* x )
+{ return AP_sizeW(x->n_args); }
+
+EXTERN_INLINE StgOffset pap_sizeW( StgPAP* x );
+EXTERN_INLINE StgOffset pap_sizeW( StgPAP* x )
+{ return PAP_sizeW(x->n_args); }
+
+EXTERN_INLINE StgWord arr_words_words( StgArrBytes* x);
+EXTERN_INLINE StgWord arr_words_words( StgArrBytes* x)
+{ return ROUNDUP_BYTES_TO_WDS(x->bytes); }
+
+EXTERN_INLINE StgOffset arr_words_sizeW( StgArrBytes* x );
+EXTERN_INLINE StgOffset arr_words_sizeW( StgArrBytes* x )
+{ return sizeofW(StgArrBytes) + arr_words_words(x); }
+
+EXTERN_INLINE StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x );
+EXTERN_INLINE StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x )
+{ return sizeofW(StgMutArrPtrs) + x->size; }
+
+EXTERN_INLINE StgOffset small_mut_arr_ptrs_sizeW( StgSmallMutArrPtrs* x );
+EXTERN_INLINE StgOffset small_mut_arr_ptrs_sizeW( StgSmallMutArrPtrs* x )
+{ return sizeofW(StgSmallMutArrPtrs) + x->ptrs; }
+
+EXTERN_INLINE StgWord stack_sizeW ( StgStack *stack );
+EXTERN_INLINE StgWord stack_sizeW ( StgStack *stack )
+{ return sizeofW(StgStack) + stack->stack_size; }
+
+EXTERN_INLINE StgWord bco_sizeW ( StgBCO *bco );
+EXTERN_INLINE StgWord bco_sizeW ( StgBCO *bco )
+{ return bco->size; }
+
+EXTERN_INLINE StgWord compact_nfdata_full_sizeW ( StgCompactNFData *str );
+EXTERN_INLINE StgWord compact_nfdata_full_sizeW ( StgCompactNFData *str )
+{ return str->totalW; }
+
+/*
+ * TODO: Consider to switch return type from 'uint32_t' to 'StgWord' #8742
+ *
+ * (Also for 'closure_sizeW' below)
+ */
+EXTERN_INLINE uint32_t
+closure_sizeW_ (const StgClosure *p, const StgInfoTable *info);
+EXTERN_INLINE uint32_t
+closure_sizeW_ (const StgClosure *p, const StgInfoTable *info)
+{
+    switch (info->type) {
+    case THUNK_0_1:
+    case THUNK_1_0:
+        return sizeofW(StgThunk) + 1;
+    case FUN_0_1:
+    case CONSTR_0_1:
+    case FUN_1_0:
+    case CONSTR_1_0:
+        return sizeofW(StgHeader) + 1;
+    case THUNK_0_2:
+    case THUNK_1_1:
+    case THUNK_2_0:
+        return sizeofW(StgThunk) + 2;
+    case FUN_0_2:
+    case CONSTR_0_2:
+    case FUN_1_1:
+    case CONSTR_1_1:
+    case FUN_2_0:
+    case CONSTR_2_0:
+        return sizeofW(StgHeader) + 2;
+    case THUNK:
+        return thunk_sizeW_fromITBL(info);
+    case THUNK_SELECTOR:
+        return THUNK_SELECTOR_sizeW();
+    case AP_STACK:
+        return ap_stack_sizeW((StgAP_STACK *)p);
+    case AP:
+        return ap_sizeW((StgAP *)p);
+    case PAP:
+        return pap_sizeW((StgPAP *)p);
+    case IND:
+        return sizeofW(StgInd);
+    case ARR_WORDS:
+        return arr_words_sizeW((StgArrBytes *)p);
+    case MUT_ARR_PTRS_CLEAN:
+    case MUT_ARR_PTRS_DIRTY:
+    case MUT_ARR_PTRS_FROZEN_CLEAN:
+    case MUT_ARR_PTRS_FROZEN_DIRTY:
+        return mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
+    case SMALL_MUT_ARR_PTRS_CLEAN:
+    case SMALL_MUT_ARR_PTRS_DIRTY:
+    case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:
+    case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:
+        return small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs*)p);
+    case TSO:
+        return sizeofW(StgTSO);
+    case STACK:
+        return stack_sizeW((StgStack*)p);
+    case BCO:
+        return bco_sizeW((StgBCO *)p);
+    case TREC_CHUNK:
+        return sizeofW(StgTRecChunk);
+    default:
+        return sizeW_fromITBL(info);
+    }
+}
+
+// The definitive way to find the size, in words, of a heap-allocated closure
+EXTERN_INLINE uint32_t closure_sizeW (const StgClosure *p);
+EXTERN_INLINE uint32_t closure_sizeW (const StgClosure *p)
+{
+    return closure_sizeW_(p, get_itbl(p));
+}
+
+/* -----------------------------------------------------------------------------
+   Sizes of stack frames
+   -------------------------------------------------------------------------- */
+
+EXTERN_INLINE StgWord stack_frame_sizeW( StgClosure *frame );
+EXTERN_INLINE StgWord stack_frame_sizeW( StgClosure *frame )
+{
+    const StgRetInfoTable *info;
+
+    info = get_ret_itbl(frame);
+    switch (info->i.type) {
+
+    case RET_FUN:
+        return sizeofW(StgRetFun) + ((StgRetFun *)frame)->size;
+
+    case RET_BIG:
+        return 1 + GET_LARGE_BITMAP(&info->i)->size;
+
+    case RET_BCO:
+        return 2 + BCO_BITMAP_SIZE((StgBCO *)((P_)frame)[1]);
+
+    default:
+        return 1 + BITMAP_SIZE(info->i.layout.bitmap);
+    }
+}
+
+/* -----------------------------------------------------------------------------
+   StgMutArrPtrs macros
+
+   An StgMutArrPtrs has a card table to indicate which elements are
+   dirty for the generational GC.  The card table is an array of
+   bytes, where each byte covers (1 << MUT_ARR_PTRS_CARD_BITS)
+   elements.  The card table is directly after the array data itself.
+   -------------------------------------------------------------------------- */
+
+// The number of card bytes needed
+INLINE_HEADER W_ mutArrPtrsCards (W_ elems)
+{
+    return (W_)((elems + (1 << MUT_ARR_PTRS_CARD_BITS) - 1)
+                           >> MUT_ARR_PTRS_CARD_BITS);
+}
+
+// The number of words in the card table
+INLINE_HEADER W_ mutArrPtrsCardTableSize (W_ elems)
+{
+    return ROUNDUP_BYTES_TO_WDS(mutArrPtrsCards(elems));
+}
+
+// The address of the card for a particular card number
+INLINE_HEADER StgWord8 *mutArrPtrsCard (StgMutArrPtrs *a, W_ n)
+{
+    return ((StgWord8 *)&(a->payload[a->ptrs]) + n);
+}
+
+/* -----------------------------------------------------------------------------
+   Replacing a closure with a different one.  We must call
+   OVERWRITING_CLOSURE(p) on the old closure that is about to be
+   overwritten.
+
+   Note [zeroing slop]
+
+   In some scenarios we write zero words into "slop"; memory that is
+   left unoccupied after we overwrite a closure in the heap with a
+   smaller closure.
+
+   Zeroing slop is required for:
+
+    - full-heap sanity checks (DEBUG, and +RTS -DS)
+    - LDV profiling (PROFILING, and +RTS -hb)
+
+   Zeroing slop must be disabled for:
+
+    - THREADED_RTS with +RTS -N2 and greater, because we cannot
+      overwrite slop when another thread might be reading it.
+
+   Hence, slop is zeroed when either:
+
+    - PROFILING && era <= 0 (LDV is on)
+    - !THREADED_RTS && DEBUG
+
+   And additionally:
+
+    - LDV profiling and +RTS -N2 are incompatible
+    - full-heap sanity checks are disabled for THREADED_RTS
+
+   -------------------------------------------------------------------------- */
+
+#if defined(PROFILING)
+#define ZERO_SLOP_FOR_LDV_PROF 1
+#else
+#define ZERO_SLOP_FOR_LDV_PROF 0
+#endif
+
+#if defined(DEBUG) && !defined(THREADED_RTS)
+#define ZERO_SLOP_FOR_SANITY_CHECK 1
+#else
+#define ZERO_SLOP_FOR_SANITY_CHECK 0
+#endif
+
+#if ZERO_SLOP_FOR_LDV_PROF || ZERO_SLOP_FOR_SANITY_CHECK
+#define OVERWRITING_CLOSURE(c) overwritingClosure(c)
+#define OVERWRITING_CLOSURE_OFS(c,n) overwritingClosureOfs(c,n)
+#else
+#define OVERWRITING_CLOSURE(c) /* nothing */
+#define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */
+#endif
+
+#if defined(PROFILING)
+void LDV_recordDead (const StgClosure *c, uint32_t size);
+#endif
+
+EXTERN_INLINE void overwritingClosure_ (StgClosure *p,
+                                        uint32_t offset /* in words */,
+                                        uint32_t size /* closure size, in words */);
+EXTERN_INLINE void overwritingClosure_ (StgClosure *p, uint32_t offset, uint32_t size)
+{
+#if ZERO_SLOP_FOR_LDV_PROF && !ZERO_SLOP_FOR_SANITY_CHECK
+    // see Note [zeroing slop], also #8402
+    if (era <= 0) return;
+#endif
+
+    // For LDV profiling, we need to record the closure as dead
+#if defined(PROFILING)
+    LDV_recordDead(p, size);
+#endif
+
+    for (uint32_t i = offset; i < size; i++) {
+        ((StgWord *)p)[i] = 0;
+    }
+}
+
+EXTERN_INLINE void overwritingClosure (StgClosure *p);
+EXTERN_INLINE void overwritingClosure (StgClosure *p)
+{
+    overwritingClosure_(p, sizeofW(StgThunkHeader), closure_sizeW(p));
+}
+
+// Version of 'overwritingClosure' which overwrites only a suffix of a
+// closure.  The offset is expressed in words relative to 'p' and shall
+// be less than or equal to closure_sizeW(p), and usually at least as
+// large as the respective thunk header.
+//
+// Note: As this calls LDV_recordDead() you have to call LDV_RECORD()
+//       on the final state of the closure at the call-site
+EXTERN_INLINE void overwritingClosureOfs (StgClosure *p, uint32_t offset);
+EXTERN_INLINE void overwritingClosureOfs (StgClosure *p, uint32_t offset)
+{
+    overwritingClosure_(p, offset, closure_sizeW(p));
+}
+
+// Version of 'overwritingClosure' which takes closure size as argument.
+EXTERN_INLINE void overwritingClosureSize (StgClosure *p, uint32_t size /* in words */);
+EXTERN_INLINE void overwritingClosureSize (StgClosure *p, uint32_t size)
+{
+    overwritingClosure_(p, sizeofW(StgThunkHeader), size);
+}
diff --git a/includes/rts/storage/ClosureTypes.h b/includes/rts/storage/ClosureTypes.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/ClosureTypes.h
@@ -0,0 +1,86 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2005
+ *
+ * Closure Type Constants: out here because the native code generator
+ * needs to get at them.
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/*
+ * WARNING WARNING WARNING
+ *
+ * If you add or delete any closure types, don't forget to update the following,
+ *   - the closure flags table in rts/ClosureFlags.c
+ *   - isRetainer in rts/RetainerProfile.c
+ *   - the closure_type_names list in rts/Printer.c
+ */
+
+/* Object tag 0 raises an internal error */
+#define INVALID_OBJECT                0
+#define CONSTR                        1
+#define CONSTR_1_0                    2
+#define CONSTR_0_1                    3
+#define CONSTR_2_0                    4
+#define CONSTR_1_1                    5
+#define CONSTR_0_2                    6
+#define CONSTR_NOCAF                  7
+#define FUN                           8
+#define FUN_1_0                       9
+#define FUN_0_1                       10
+#define FUN_2_0                       11
+#define FUN_1_1                       12
+#define FUN_0_2                       13
+#define FUN_STATIC                    14
+#define THUNK                         15
+#define THUNK_1_0                     16
+#define THUNK_0_1                     17
+#define THUNK_2_0                     18
+#define THUNK_1_1                     19
+#define THUNK_0_2                     20
+#define THUNK_STATIC                  21
+#define THUNK_SELECTOR                22
+#define BCO                           23
+#define AP                            24
+#define PAP                           25
+#define AP_STACK                      26
+#define IND                           27
+#define IND_STATIC                    28
+#define RET_BCO                       29
+#define RET_SMALL                     30
+#define RET_BIG                       31
+#define RET_FUN                       32
+#define UPDATE_FRAME                  33
+#define CATCH_FRAME                   34
+#define UNDERFLOW_FRAME               35
+#define STOP_FRAME                    36
+#define BLOCKING_QUEUE                37
+#define BLACKHOLE                     38
+#define MVAR_CLEAN                    39
+#define MVAR_DIRTY                    40
+#define TVAR                          41
+#define ARR_WORDS                     42
+#define MUT_ARR_PTRS_CLEAN            43
+#define MUT_ARR_PTRS_DIRTY            44
+#define MUT_ARR_PTRS_FROZEN_DIRTY     45
+#define MUT_ARR_PTRS_FROZEN_CLEAN     46
+#define MUT_VAR_CLEAN                 47
+#define MUT_VAR_DIRTY                 48
+#define WEAK                          49
+#define PRIM                          50
+#define MUT_PRIM                      51
+#define TSO                           52
+#define STACK                         53
+#define TREC_CHUNK                    54
+#define ATOMICALLY_FRAME              55
+#define CATCH_RETRY_FRAME             56
+#define CATCH_STM_FRAME               57
+#define WHITEHOLE                     58
+#define SMALL_MUT_ARR_PTRS_CLEAN      59
+#define SMALL_MUT_ARR_PTRS_DIRTY      60
+#define SMALL_MUT_ARR_PTRS_FROZEN_DIRTY 61
+#define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62
+#define COMPACT_NFDATA                63
+#define N_CLOSURE_TYPES               64
diff --git a/includes/rts/storage/Closures.h b/includes/rts/storage/Closures.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/Closures.h
@@ -0,0 +1,470 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * Closures
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/*
+ * The Layout of a closure header depends on which kind of system we're
+ * compiling for: profiling, parallel, ticky, etc.
+ */
+
+/* -----------------------------------------------------------------------------
+   The profiling header
+   -------------------------------------------------------------------------- */
+
+typedef struct {
+  CostCentreStack *ccs;
+  union {
+    struct _RetainerSet *rs;  /* Retainer Set */
+    StgWord ldvw;             /* Lag/Drag/Void Word */
+  } hp;
+} StgProfHeader;
+
+/* -----------------------------------------------------------------------------
+   The SMP header
+
+   A thunk has a padding word to take the updated value.  This is so
+   that the update doesn't overwrite the payload, so we can avoid
+   needing to lock the thunk during entry and update.
+
+   Note: this doesn't apply to THUNK_STATICs, which have no payload.
+
+   Note: we leave this padding word in all ways, rather than just SMP,
+   so that we don't have to recompile all our libraries for SMP.
+   -------------------------------------------------------------------------- */
+
+typedef struct {
+    StgWord pad;
+} StgSMPThunkHeader;
+
+/* -----------------------------------------------------------------------------
+   The full fixed-size closure header
+
+   The size of the fixed header is the sum of the optional parts plus a single
+   word for the entry code pointer.
+   -------------------------------------------------------------------------- */
+
+typedef struct {
+    const StgInfoTable* info;
+#if defined(PROFILING)
+    StgProfHeader         prof;
+#endif
+} StgHeader;
+
+typedef struct {
+    const StgInfoTable* info;
+#if defined(PROFILING)
+    StgProfHeader         prof;
+#endif
+    StgSMPThunkHeader     smp;
+} StgThunkHeader;
+
+#define THUNK_EXTRA_HEADER_W (sizeofW(StgThunkHeader)-sizeofW(StgHeader))
+
+/* -----------------------------------------------------------------------------
+   Closure Types
+
+   For any given closure type (defined in InfoTables.h), there is a
+   corresponding structure defined below.  The name of the structure
+   is obtained by concatenating the closure type with '_closure'
+   -------------------------------------------------------------------------- */
+
+/* All closures follow the generic format */
+
+typedef struct StgClosure_ {
+    StgHeader   header;
+    struct StgClosure_ *payload[];
+} *StgClosurePtr; // StgClosure defined in rts/Types.h
+
+typedef struct {
+    StgThunkHeader  header;
+    struct StgClosure_ *payload[];
+} StgThunk;
+
+typedef struct {
+    StgThunkHeader   header;
+    StgClosure *selectee;
+} StgSelector;
+
+typedef struct {
+    StgHeader   header;
+    StgHalfWord arity;          /* zero if it is an AP */
+    StgHalfWord n_args;
+    StgClosure *fun;            /* really points to a fun */
+    StgClosure *payload[];
+} StgPAP;
+
+typedef struct {
+    StgThunkHeader   header;
+    StgHalfWord arity;          /* zero if it is an AP */
+    StgHalfWord n_args;
+    StgClosure *fun;            /* really points to a fun */
+    StgClosure *payload[];
+} StgAP;
+
+typedef struct {
+    StgThunkHeader   header;
+    StgWord     size;                    /* number of words in payload */
+    StgClosure *fun;
+    StgClosure *payload[]; /* contains a chunk of *stack* */
+} StgAP_STACK;
+
+typedef struct {
+    StgHeader   header;
+    StgClosure *indirectee;
+} StgInd;
+
+typedef struct {
+    StgHeader     header;
+    StgClosure   *indirectee;
+    StgClosure   *static_link; // See Note [CAF lists]
+    const StgInfoTable *saved_info;
+        // `saved_info` also used for the link field for `debug_caf_list`,
+        // see `newCAF` and Note [CAF lists] in rts/sm/Storage.h.
+} StgIndStatic;
+
+typedef struct StgBlockingQueue_ {
+    StgHeader   header;
+    struct StgBlockingQueue_ *link;
+        // here so it looks like an IND, to be able to skip the queue without
+        // deleting it (done in wakeBlockingQueue())
+    StgClosure *bh;  // the BLACKHOLE
+    StgTSO     *owner;
+    struct MessageBlackHole_ *queue;
+        // holds TSOs blocked on `bh`
+} StgBlockingQueue;
+
+typedef struct {
+    StgHeader  header;
+    StgWord    bytes;
+    StgWord    payload[];
+} StgArrBytes;
+
+typedef struct {
+    StgHeader   header;
+    StgWord     ptrs;
+    StgWord     size; // ptrs plus card table
+    StgClosure *payload[];
+    // see also: StgMutArrPtrs macros in ClosureMacros.h
+} StgMutArrPtrs;
+
+typedef struct {
+    StgHeader   header;
+    StgWord     ptrs;
+    StgClosure *payload[];
+} StgSmallMutArrPtrs;
+
+typedef struct {
+    StgHeader   header;
+    StgClosure *var;
+} StgMutVar;
+
+typedef struct _StgUpdateFrame {
+    StgHeader  header;
+    StgClosure *updatee;
+} StgUpdateFrame;
+
+typedef struct {
+    StgHeader  header;
+    StgWord    exceptions_blocked;
+    StgClosure *handler;
+} StgCatchFrame;
+
+typedef struct {
+    const StgInfoTable* info;
+    struct StgStack_ *next_chunk;
+} StgUnderflowFrame;
+
+typedef struct {
+    StgHeader  header;
+} StgStopFrame;
+
+typedef struct {
+  StgHeader header;
+  StgWord data;
+} StgIntCharlikeClosure;
+
+/* statically allocated */
+typedef struct {
+  StgHeader  header;
+} StgRetry;
+
+typedef struct _StgStableName {
+  StgHeader      header;
+  StgWord        sn;
+} StgStableName;
+
+typedef struct _StgWeak {       /* Weak v */
+  StgHeader header;
+  StgClosure *cfinalizers;
+  StgClosure *key;
+  StgClosure *value;            /* v */
+  StgClosure *finalizer;
+  struct _StgWeak *link;
+} StgWeak;
+
+typedef struct _StgCFinalizerList {
+  StgHeader header;
+  StgClosure *link;
+  void (*fptr)(void);
+  void *ptr;
+  void *eptr;
+  StgWord flag; /* has environment (0 or 1) */
+} StgCFinalizerList;
+
+/* Byte code objects.  These are fixed size objects with pointers to
+ * four arrays, designed so that a BCO can be easily "re-linked" to
+ * other BCOs, to facilitate GHC's intelligent recompilation.  The
+ * array of instructions is static and not re-generated when the BCO
+ * is re-linked, but the other 3 arrays will be regenerated.
+ *
+ * A BCO represents either a function or a stack frame.  In each case,
+ * it needs a bitmap to describe to the garbage collector the
+ * pointerhood of its arguments/free variables respectively, and in
+ * the case of a function it also needs an arity.  These are stored
+ * directly in the BCO, rather than in the instrs array, for two
+ * reasons:
+ * (a) speed: we need to get at the bitmap info quickly when
+ *     the GC is examining APs and PAPs that point to this BCO
+ * (b) a subtle interaction with the compacting GC.  In compacting
+ *     GC, the info that describes the size/layout of a closure
+ *     cannot be in an object more than one level of indirection
+ *     away from the current object, because of the order in
+ *     which pointers are updated to point to their new locations.
+ */
+
+typedef struct {
+    StgHeader      header;
+    StgArrBytes   *instrs;      /* a pointer to an ArrWords */
+    StgArrBytes   *literals;    /* a pointer to an ArrWords */
+    StgMutArrPtrs *ptrs;        /* a pointer to a  MutArrPtrs */
+    StgHalfWord   arity;        /* arity of this BCO */
+    StgHalfWord   size;         /* size of this BCO (in words) */
+    StgWord       bitmap[];  /* an StgLargeBitmap */
+} StgBCO;
+
+#define BCO_BITMAP(bco)      ((StgLargeBitmap *)((StgBCO *)(bco))->bitmap)
+#define BCO_BITMAP_SIZE(bco) (BCO_BITMAP(bco)->size)
+#define BCO_BITMAP_BITS(bco) (BCO_BITMAP(bco)->bitmap)
+#define BCO_BITMAP_SIZEW(bco) ((BCO_BITMAP_SIZE(bco) + BITS_IN(StgWord) - 1) \
+                                / BITS_IN(StgWord))
+
+/* A function return stack frame: used when saving the state for a
+ * garbage collection at a function entry point.  The function
+ * arguments are on the stack, and we also save the function (its
+ * info table describes the pointerhood of the arguments).
+ *
+ * The stack frame size is also cached in the frame for convenience.
+ *
+ * The only RET_FUN is stg_gc_fun, which is created by __stg_gc_fun,
+ * both in HeapStackCheck.cmm.
+ */
+typedef struct {
+    const StgInfoTable* info;
+    StgWord        size;
+    StgClosure *   fun;
+    StgClosure *   payload[];
+} StgRetFun;
+
+/* Concurrent communication objects */
+
+typedef struct StgMVarTSOQueue_ {
+    StgHeader                header;
+    struct StgMVarTSOQueue_ *link;
+    struct StgTSO_          *tso;
+} StgMVarTSOQueue;
+
+typedef struct {
+    StgHeader                header;
+    struct StgMVarTSOQueue_ *head;
+    struct StgMVarTSOQueue_ *tail;
+    StgClosure*              value;
+} StgMVar;
+
+
+/* STM data structures
+ *
+ *  StgTVar defines the only type that can be updated through the STM
+ *  interface.
+ *
+ *  Note that various optimisations may be possible in order to use less
+ *  space for these data structures at the cost of more complexity in the
+ *  implementation:
+ *
+ *   - In StgTVar, current_value and first_watch_queue_entry could be held in
+ *     the same field: if any thread is waiting then its expected_value for
+ *     the tvar is the current value.
+ *
+ *   - In StgTRecHeader, it might be worthwhile having separate chunks
+ *     of read-only and read-write locations.  This would save a
+ *     new_value field in the read-only locations.
+ *
+ *   - In StgAtomicallyFrame, we could combine the waiting bit into
+ *     the header (maybe a different info tbl for a waiting transaction).
+ *     This means we can specialise the code for the atomically frame
+ *     (it immediately switches on frame->waiting anyway).
+ */
+
+typedef struct StgTRecHeader_ StgTRecHeader;
+
+typedef struct StgTVarWatchQueue_ {
+  StgHeader                  header;
+  StgClosure                *closure; // StgTSO
+  struct StgTVarWatchQueue_ *next_queue_entry;
+  struct StgTVarWatchQueue_ *prev_queue_entry;
+} StgTVarWatchQueue;
+
+typedef struct {
+  StgHeader                  header;
+  StgClosure                *volatile current_value;
+  StgTVarWatchQueue         *volatile first_watch_queue_entry;
+  StgInt                     volatile num_updates;
+} StgTVar;
+
+/* new_value == expected_value for read-only accesses */
+/* new_value is a StgTVarWatchQueue entry when trec in state TREC_WAITING */
+typedef struct {
+  StgTVar                   *tvar;
+  StgClosure                *expected_value;
+  StgClosure                *new_value;
+#if defined(THREADED_RTS)
+  StgInt                     num_updates;
+#endif
+} TRecEntry;
+
+#define TREC_CHUNK_NUM_ENTRIES 16
+
+typedef struct StgTRecChunk_ {
+  StgHeader                  header;
+  struct StgTRecChunk_      *prev_chunk;
+  StgWord                    next_entry_idx;
+  TRecEntry                  entries[TREC_CHUNK_NUM_ENTRIES];
+} StgTRecChunk;
+
+typedef enum {
+  TREC_ACTIVE,        /* Transaction in progress, outcome undecided */
+  TREC_CONDEMNED,     /* Transaction in progress, inconsistent / out of date reads */
+  TREC_COMMITTED,     /* Transaction has committed, now updating tvars */
+  TREC_ABORTED,       /* Transaction has aborted, now reverting tvars */
+  TREC_WAITING,       /* Transaction currently waiting */
+} TRecState;
+
+struct StgTRecHeader_ {
+  StgHeader                  header;
+  struct StgTRecHeader_     *enclosing_trec;
+  StgTRecChunk              *current_chunk;
+  TRecState                  state;
+};
+
+typedef struct {
+  StgHeader   header;
+  StgClosure *code;
+  StgClosure *result;
+} StgAtomicallyFrame;
+
+typedef struct {
+  StgHeader   header;
+  StgClosure *code;
+  StgClosure *handler;
+} StgCatchSTMFrame;
+
+typedef struct {
+  StgHeader      header;
+  StgWord        running_alt_code;
+  StgClosure    *first_code;
+  StgClosure    *alt_code;
+} StgCatchRetryFrame;
+
+/* ----------------------------------------------------------------------------
+   Messages
+   ------------------------------------------------------------------------- */
+
+typedef struct Message_ {
+    StgHeader        header;
+    struct Message_ *link;
+} Message;
+
+typedef struct MessageWakeup_ {
+    StgHeader header;
+    Message  *link;
+    StgTSO   *tso;
+} MessageWakeup;
+
+typedef struct MessageThrowTo_ {
+    StgHeader   header;
+    struct MessageThrowTo_ *link;
+    StgTSO     *source;
+    StgTSO     *target;
+    StgClosure *exception;
+} MessageThrowTo;
+
+typedef struct MessageBlackHole_ {
+    StgHeader   header;
+    struct MessageBlackHole_ *link;
+        // here so it looks like an IND, to be able to skip the message without
+        // deleting it (done in throwToMsg())
+    StgTSO     *tso;
+    StgClosure *bh;
+} MessageBlackHole;
+
+/* ----------------------------------------------------------------------------
+   Compact Regions
+   ------------------------------------------------------------------------- */
+
+//
+// A compact region is a list of blocks.  Each block starts with an
+// StgCompactNFDataBlock structure, and the list is chained through the next
+// field of these structs.  (the link field of the bdescr is used to chain
+// together multiple compact region on the compact_objects field of a
+// generation).
+//
+// See Note [Compact Normal Forms] for details
+//
+typedef struct StgCompactNFDataBlock_ {
+    struct StgCompactNFDataBlock_ *self;
+       // the address of this block this is copied over to the
+       // receiving end when serializing a compact, so the receiving
+       // end can allocate the block at best as it can, and then
+       // verify if pointer adjustment is needed or not by comparing
+       // self with the actual address; the same data is sent over as
+       // SerializedCompact metadata, but having it here simplifies
+       // the fixup implementation.
+    struct StgCompactNFData_ *owner;
+       // the closure who owns this block (used in objectGetCompact)
+    struct StgCompactNFDataBlock_ *next;
+       // chain of blocks used for serialization and freeing
+} StgCompactNFDataBlock;
+
+//
+// This is the Compact# primitive object.
+//
+typedef struct StgCompactNFData_ {
+    StgHeader header;
+      // for sanity and other checks in practice, nothing should ever
+      // need the compact info pointer (we don't even need fwding
+      // pointers because it's a large object)
+    StgWord totalW;
+      // Total number of words in all blocks in the compact
+    StgWord autoBlockW;
+      // size of automatically appended blocks
+    StgPtr hp, hpLim;
+      // the beginning and end of the free area in the nursery block.  This is
+      // just a convenience so that we can avoid multiple indirections through
+      // the nursery pointer below during compaction.
+    StgCompactNFDataBlock *nursery;
+      // where to (try to) allocate from when appending
+    StgCompactNFDataBlock *last;
+      // the last block of the chain (to know where to append new
+      // blocks for resize)
+    struct hashtable *hash;
+      // the hash table for the current compaction, or NULL if
+      // there's no (sharing-preserved) compaction in progress.
+    StgClosure *result;
+      // Used temporarily to store the result of compaction.  Doesn't need to be
+      // a GC root.
+} StgCompactNFData;
diff --git a/includes/rts/storage/FunTypes.h b/includes/rts/storage/FunTypes.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/FunTypes.h
@@ -0,0 +1,54 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 2002
+ *
+ * Things for functions.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/* generic - function comes with a small bitmap */
+#define ARG_GEN      0   
+
+/* generic - function comes with a large bitmap */
+#define ARG_GEN_BIG  1
+
+/* BCO - function is really a BCO */
+#define ARG_BCO      2
+
+/*
+ * Specialised function types: bitmaps and calling sequences
+ * for these functions are pre-generated: see ghc/utils/genapply and
+ * generated code in ghc/rts/AutoApply.cmm.
+ *
+ *  NOTE: other places to change if you change this table:
+ *       - utils/genapply/Main.hs: stackApplyTypes
+ *       - compiler/codeGen/StgCmmLayout.hs: stdPattern
+ */
+#define ARG_NONE     3 
+#define ARG_N        4  
+#define ARG_P        5 
+#define ARG_F        6 
+#define ARG_D        7 
+#define ARG_L        8 
+#define ARG_V16      9 
+#define ARG_V32      10
+#define ARG_V64      11
+#define ARG_NN       12 
+#define ARG_NP       13
+#define ARG_PN       14
+#define ARG_PP       15
+#define ARG_NNN      16
+#define ARG_NNP      17
+#define ARG_NPN      18
+#define ARG_NPP      19
+#define ARG_PNN      20
+#define ARG_PNP      21
+#define ARG_PPN      22
+#define ARG_PPP      23
+#define ARG_PPPP     24
+#define ARG_PPPPP    25
+#define ARG_PPPPPP   26
+#define ARG_PPPPPPP  27
+#define ARG_PPPPPPPP 28
diff --git a/includes/rts/storage/GC.h b/includes/rts/storage/GC.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/GC.h
@@ -0,0 +1,248 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2004
+ *
+ * External Storage Manger Interface
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include <stddef.h>
+#include "rts/OSThreads.h"
+
+/* -----------------------------------------------------------------------------
+ * Generational GC
+ *
+ * We support an arbitrary number of generations.  Notes (in no particular
+ * order):
+ *
+ *       - Objects "age" in the nursery for one GC cycle before being promoted
+ *         to the next generation.  There is no aging in other generations.
+ *
+ *       - generation 0 is the allocation area.  It is given
+ *         a fixed set of blocks during initialisation, and these blocks
+ *         normally stay in G0S0.  In parallel execution, each
+ *         Capability has its own nursery.
+ *
+ *       - during garbage collection, each generation which is an
+ *         evacuation destination (i.e. all generations except G0) is
+ *         allocated a to-space.  evacuated objects are allocated into
+ *         the generation's to-space until GC is finished, when the
+ *         original generations's contents may be freed and replaced
+ *         by the to-space.
+ *
+ *       - the mutable-list is per-generation.  G0 doesn't have one
+ *         (since every garbage collection collects at least G0).
+ *
+ *       - block descriptors contain a pointer to the generation that
+ *         the block belongs to, for convenience.
+ *
+ *       - static objects are stored in per-generation lists.  See GC.c for
+ *         details of how we collect CAFs in the generational scheme.
+ *
+ *       - large objects are per-generation, and are promoted in the
+ *         same way as small objects.
+ *
+ * ------------------------------------------------------------------------- */
+
+// A count of blocks needs to store anything up to the size of memory
+// divided by the block size.  The safest thing is therefore to use a
+// type that can store the full range of memory addresses,
+// ie. StgWord.  Note that we have had some tricky int overflows in a
+// couple of cases caused by using ints rather than longs (e.g. #5086)
+
+typedef StgWord memcount;
+
+typedef struct nursery_ {
+    bdescr *       blocks;
+    memcount       n_blocks;
+} nursery;
+
+// Nursery invariants:
+//
+//  - cap->r.rNursery points to the nursery for this capability
+//
+//  - cap->r.rCurrentNursery points to the block in the nursery that we are
+//    currently allocating into.  While in Haskell the current heap pointer is
+//    in Hp, outside Haskell it is stored in cap->r.rCurrentNursery->free.
+//
+//  - the blocks *after* cap->rCurrentNursery in the chain are empty
+//    (although their bd->free pointers have not been updated to
+//    reflect that)
+//
+//  - the blocks *before* cap->rCurrentNursery have been used.  Except
+//    for rCurrentAlloc.
+//
+//  - cap->r.rCurrentAlloc is either NULL, or it points to a block in
+//    the nursery *before* cap->r.rCurrentNursery.
+//
+// See also Note [allocation accounting] to understand how total
+// memory allocation is tracked.
+
+typedef struct generation_ {
+    uint32_t       no;                  // generation number
+
+    bdescr *       blocks;              // blocks in this gen
+    memcount       n_blocks;            // number of blocks
+    memcount       n_words;             // number of used words
+
+    bdescr *       large_objects;       // large objects (doubly linked)
+    memcount       n_large_blocks;      // no. of blocks used by large objs
+    memcount       n_large_words;       // no. of words used by large objs
+    memcount       n_new_large_words;   // words of new large objects
+                                        // (for doYouWantToGC())
+
+    bdescr *       compact_objects;     // compact objects chain
+                                        // the second block in each compact is
+                                        // linked from the closure object, while
+                                        // the second compact object in the
+                                        // chain is linked from bd->link (like
+                                        // large objects)
+    memcount       n_compact_blocks;    // no. of blocks used by all compacts
+    bdescr *       compact_blocks_in_import; // compact objects being imported
+                                             // (not known to the GC because
+                                             // potentially invalid, but we
+                                             // need to keep track of them
+                                             // to avoid assertions in Sanity)
+                                             // this is a list shaped like compact_objects
+    memcount       n_compact_blocks_in_import; // no. of blocks used by compacts
+                                               // being imported
+
+    // Max blocks to allocate in this generation before collecting it. Collect
+    // this generation when
+    //
+    //     n_blocks + n_large_blocks + n_compact_blocks > max_blocks
+    //
+    memcount       max_blocks;
+
+    StgTSO *       threads;             // threads in this gen
+                                        // linked via global_link
+    StgWeak *      weak_ptr_list;       // weak pointers in this gen
+
+    struct generation_ *to;             // destination gen for live objects
+
+    // stats information
+    uint32_t collections;
+    uint32_t par_collections;
+    uint32_t failed_promotions;         // Currently unused
+
+    // ------------------------------------
+    // Fields below are used during GC only
+
+#if defined(THREADED_RTS)
+    char pad[128];                      // make sure the following is
+                                        // on a separate cache line.
+    SpinLock     sync;                  // lock for large_objects
+                                        //    and scavenged_large_objects
+#endif
+
+    int          mark;                  // mark (not copy)? (old gen only)
+    int          compact;               // compact (not sweep)? (old gen only)
+
+    // During GC, if we are collecting this gen, blocks and n_blocks
+    // are copied into the following two fields.  After GC, these blocks
+    // are freed.
+    bdescr *     old_blocks;            // bdescr of first from-space block
+    memcount     n_old_blocks;         // number of blocks in from-space
+    memcount     live_estimate;         // for sweeping: estimate of live data
+
+    bdescr *     scavenged_large_objects;  // live large objs after GC (d-link)
+    memcount     n_scavenged_large_blocks; // size (not count) of above
+
+    bdescr *     live_compact_objects;  // live compact objs after GC (d-link)
+    memcount     n_live_compact_blocks; // size (not count) of above
+
+    bdescr *     bitmap;                // bitmap for compacting collection
+
+    StgTSO *     old_threads;
+    StgWeak *    old_weak_ptr_list;
+} generation;
+
+extern generation * generations;
+extern generation * g0;
+extern generation * oldest_gen;
+
+/* -----------------------------------------------------------------------------
+   Generic allocation
+
+   StgPtr allocate(Capability *cap, W_ n)
+                                Allocates memory from the nursery in
+                                the current Capability.
+
+   StgPtr allocatePinned(Capability *cap, W_ n)
+                                Allocates a chunk of contiguous store
+                                n words long, which is at a fixed
+                                address (won't be moved by GC).
+                                Returns a pointer to the first word.
+                                Always succeeds.
+
+                                NOTE: the GC can't in general handle
+                                pinned objects, so allocatePinned()
+                                can only be used for ByteArrays at the
+                                moment.
+
+                                Don't forget to TICK_ALLOC_XXX(...)
+                                after calling allocate or
+                                allocatePinned, for the
+                                benefit of the ticky-ticky profiler.
+
+   -------------------------------------------------------------------------- */
+
+StgPtr  allocate          ( Capability *cap, W_ n );
+StgPtr  allocateMightFail ( Capability *cap, W_ n );
+StgPtr  allocatePinned    ( Capability *cap, W_ n );
+
+/* memory allocator for executable memory */
+typedef void* AdjustorWritable;
+typedef void* AdjustorExecutable;
+
+AdjustorWritable allocateExec(W_ len, AdjustorExecutable *exec_addr);
+void flushExec(W_ len, AdjustorExecutable exec_addr);
+#if defined(ios_HOST_OS)
+AdjustorWritable execToWritable(AdjustorExecutable exec);
+#endif
+void             freeExec (AdjustorExecutable p);
+
+// Used by GC checks in external .cmm code:
+extern W_ large_alloc_lim;
+
+/* -----------------------------------------------------------------------------
+   Performing Garbage Collection
+   -------------------------------------------------------------------------- */
+
+void performGC(void);
+void performMajorGC(void);
+
+/* -----------------------------------------------------------------------------
+   The CAF table - used to let us revert CAFs in GHCi
+   -------------------------------------------------------------------------- */
+
+StgInd *newCAF         (StgRegTable *reg, StgIndStatic *caf);
+StgInd *newRetainedCAF (StgRegTable *reg, StgIndStatic *caf);
+StgInd *newGCdCAF      (StgRegTable *reg, StgIndStatic *caf);
+void revertCAFs (void);
+
+// Request that all CAFs are retained indefinitely.
+// (preferably use RtsConfig.keep_cafs instead)
+void setKeepCAFs (void);
+
+/* -----------------------------------------------------------------------------
+   This is the write barrier for MUT_VARs, a.k.a. IORefs.  A
+   MUT_VAR_CLEAN object is not on the mutable list; a MUT_VAR_DIRTY
+   is.  When written to, a MUT_VAR_CLEAN turns into a MUT_VAR_DIRTY
+   and is put on the mutable list.
+   -------------------------------------------------------------------------- */
+
+void dirty_MUT_VAR(StgRegTable *reg, StgClosure *p);
+
+/* set to disable CAF garbage collection in GHCi. */
+/* (needed when dynamic libraries are used). */
+extern bool keepCAFs;
+
+INLINE_HEADER void initBdescr(bdescr *bd, generation *gen, generation *dest)
+{
+    bd->gen     = gen;
+    bd->gen_no  = gen->no;
+    bd->dest_no = dest->no;
+}
diff --git a/includes/rts/storage/Heap.h b/includes/rts/storage/Heap.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/Heap.h
@@ -0,0 +1,18 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The University of Glasgow 2006-2017
+ *
+ * Introspection into GHC's heap representation
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+#include "rts/storage/Closures.h"
+
+StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure);
+
+void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs
+                        , StgClosure *fun, StgClosure **payload, StgWord size);
+
+StgWord heap_view_closureSize(StgClosure *closure);
diff --git a/includes/rts/storage/InfoTables.h b/includes/rts/storage/InfoTables.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/InfoTables.h
@@ -0,0 +1,405 @@
+/* ----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2002
+ *
+ * Info Tables
+ *
+ * -------------------------------------------------------------------------- */
+
+#pragma once
+
+/* ----------------------------------------------------------------------------
+   Relative pointers
+
+   Several pointer fields in info tables are expressed as offsets
+   relative to the info pointer, so that we can generate
+   position-independent code.
+
+   Note [x86-64-relative]
+   There is a complication on the x86_64 platform, where pointers are
+   64 bits, but the tools don't support 64-bit relative relocations.
+   However, the default memory model (small) ensures that all symbols
+   have values in the lower 2Gb of the address space, so offsets all
+   fit in 32 bits.  Hence we can use 32-bit offset fields.
+
+   Somewhere between binutils-2.16.1 and binutils-2.16.91.0.6,
+   support for 64-bit PC-relative relocations was added, so maybe this
+   hackery can go away sometime.
+   ------------------------------------------------------------------------- */
+
+#if defined(x86_64_TARGET_ARCH)
+#define OFFSET_FIELD(n) StgHalfInt n; StgHalfWord __pad_##n
+#else
+#define OFFSET_FIELD(n) StgInt n
+#endif
+
+/* -----------------------------------------------------------------------------
+   Profiling info
+   -------------------------------------------------------------------------- */
+
+typedef struct {
+#if !defined(TABLES_NEXT_TO_CODE)
+    char *closure_type;
+    char *closure_desc;
+#else
+    OFFSET_FIELD(closure_type_off);
+    OFFSET_FIELD(closure_desc_off);
+#endif
+} StgProfInfo;
+
+/* -----------------------------------------------------------------------------
+   Closure flags
+   -------------------------------------------------------------------------- */
+
+/* The type flags provide quick access to certain properties of a closure. */
+
+#define _HNF (1<<0)  /* head normal form?    */
+#define _BTM (1<<1)  /* uses info->layout.bitmap */
+#define _NS  (1<<2)  /* non-sparkable        */
+#define _THU (1<<3)  /* thunk?               */
+#define _MUT (1<<4)  /* mutable?             */
+#define _UPT (1<<5)  /* unpointed?           */
+#define _SRT (1<<6)  /* has an SRT?          */
+#define _IND (1<<7)  /* is an indirection?   */
+
+#define isMUTABLE(flags)   ((flags) &_MUT)
+#define isBITMAP(flags)    ((flags) &_BTM)
+#define isTHUNK(flags)     ((flags) &_THU)
+#define isUNPOINTED(flags) ((flags) &_UPT)
+#define hasSRT(flags)      ((flags) &_SRT)
+
+extern StgWord16 closure_flags[];
+
+#define closureFlags(c)         (closure_flags[get_itbl \
+                                    (UNTAG_CONST_CLOSURE(c))->type])
+
+#define closure_HNF(c)          (  closureFlags(c) & _HNF)
+#define closure_BITMAP(c)       (  closureFlags(c) & _BTM)
+#define closure_NON_SPARK(c)    ( (closureFlags(c) & _NS))
+#define closure_SHOULD_SPARK(c) (!(closureFlags(c) & _NS))
+#define closure_THUNK(c)        (  closureFlags(c) & _THU)
+#define closure_MUTABLE(c)      (  closureFlags(c) & _MUT)
+#define closure_UNPOINTED(c)    (  closureFlags(c) & _UPT)
+#define closure_SRT(c)          (  closureFlags(c) & _SRT)
+#define closure_IND(c)          (  closureFlags(c) & _IND)
+
+/* same as above but for info-ptr rather than closure */
+#define ipFlags(ip)             (closure_flags[ip->type])
+
+#define ip_HNF(ip)               (  ipFlags(ip) & _HNF)
+#define ip_BITMAP(ip)            (  ipFlags(ip) & _BTM)
+#define ip_SHOULD_SPARK(ip)      (!(ipFlags(ip) & _NS))
+#define ip_THUNK(ip)             (  ipFlags(ip) & _THU)
+#define ip_MUTABLE(ip)           (  ipFlags(ip) & _MUT)
+#define ip_UNPOINTED(ip)         (  ipFlags(ip) & _UPT)
+#define ip_SRT(ip)               (  ipFlags(ip) & _SRT)
+#define ip_IND(ip)               (  ipFlags(ip) & _IND)
+
+/* -----------------------------------------------------------------------------
+   Bitmaps
+
+   These are used to describe the pointerhood of a sequence of words
+   (usually on the stack) to the garbage collector.  The two primary
+   uses are for stack frames, and functions (where we need to describe
+   the layout of a PAP to the GC).
+
+   In these bitmaps: 0 == ptr, 1 == non-ptr.
+   -------------------------------------------------------------------------- */
+
+/*
+ * Small bitmaps:  for a small bitmap, we store the size and bitmap in
+ * the same word, using the following macros.  If the bitmap doesn't
+ * fit in a single word, we use a pointer to an StgLargeBitmap below.
+ */
+#define MK_SMALL_BITMAP(size,bits) (((bits)<<BITMAP_BITS_SHIFT) | (size))
+
+#define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK)
+#define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT)
+
+/*
+ * A large bitmap.
+ */
+typedef struct {
+  StgWord size;
+  StgWord bitmap[];
+} StgLargeBitmap;
+
+/* ----------------------------------------------------------------------------
+   Info Tables
+   ------------------------------------------------------------------------- */
+
+/*
+ * Stuff describing the closure layout.  Well, actually, it might
+ * contain the selector index for a THUNK_SELECTOR.  This union is one
+ * word long.
+ */
+typedef union {
+    struct {                    /* Heap closure payload layout: */
+        StgHalfWord ptrs;       /* number of pointers */
+        StgHalfWord nptrs;      /* number of non-pointers */
+    } payload;
+
+    StgWord bitmap;               /* word-sized bit pattern describing */
+                                  /*  a stack frame: see below */
+
+#if !defined(TABLES_NEXT_TO_CODE)
+    StgLargeBitmap* large_bitmap; /* pointer to large bitmap structure */
+#else
+    OFFSET_FIELD(large_bitmap_offset);  /* offset from info table to large bitmap structure */
+#endif
+
+    StgWord selector_offset;      /* used in THUNK_SELECTORs */
+
+} StgClosureInfo;
+
+
+#if defined(x86_64_TARGET_ARCH) && defined(TABLES_NEXT_TO_CODE)
+// On x86_64 we can fit a pointer offset in half a word, so put the SRT offset
+// in the info->srt field directly.
+//
+// See the section "Referring to an SRT from the info table" in
+// Note [SRTs] in CmmBuildInfoTables.hs
+#define USE_INLINE_SRT_FIELD
+#endif
+
+#if defined(USE_INLINE_SRT_FIELD)
+// offset to the SRT / closure, or zero if there's no SRT
+typedef StgHalfInt StgSRTField;
+#else
+// non-zero if there is an SRT, the offset is in the optional srt field.
+typedef StgHalfWord StgSRTField;
+#endif
+
+
+/*
+ * The "standard" part of an info table.  Every info table has this bit.
+ */
+typedef struct StgInfoTable_ {
+
+#if !defined(TABLES_NEXT_TO_CODE)
+    StgFunPtr       entry;      /* pointer to the entry code */
+#endif
+
+#if defined(PROFILING)
+    StgProfInfo     prof;
+#endif
+
+    StgClosureInfo  layout;     /* closure layout info (one word) */
+
+    StgHalfWord     type;       /* closure type */
+    StgSRTField     srt;
+       /* In a CONSTR:
+            - the constructor tag
+          In a FUN/THUNK
+            - if USE_INLINE_SRT_FIELD
+              - offset to the SRT (or zero if no SRT)
+            - otherwise
+              - non-zero if there is an SRT, offset is in srt_offset
+       */
+
+#if defined(TABLES_NEXT_TO_CODE)
+    StgCode         code[];
+#endif
+} *StgInfoTablePtr; // StgInfoTable defined in rts/Types.h
+
+
+/* -----------------------------------------------------------------------------
+   Function info tables
+
+   This is the general form of function info tables.  The compiler
+   will omit some of the fields in common cases:
+
+   -  If fun_type is not ARG_GEN or ARG_GEN_BIG, then the slow_apply
+      and bitmap fields may be left out (they are at the end, so omitting
+      them doesn't affect the layout).
+
+   -  If has_srt (in the std info table part) is zero, then the srt
+      field needn't be set.  This only applies if the slow_apply and
+      bitmap fields have also been omitted.
+   -------------------------------------------------------------------------- */
+
+/*
+   Note [Encoding static reference tables]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+   As static reference tables appear frequently in code, we use a special
+   compact encoding for the common case of a module defining only a few CAFs: We
+   produce one table containing a list of CAFs in the module and then include a
+   bitmap in each info table describing which entries of this table the closure
+   references.
+ */
+
+typedef struct StgFunInfoExtraRev_ {
+    OFFSET_FIELD(slow_apply_offset); /* apply to args on the stack */
+    union {
+        StgWord bitmap;
+        OFFSET_FIELD(bitmap_offset);    /* arg ptr/nonptr bitmap */
+    } b;
+#if !defined(USE_INLINE_SRT_FIELD)
+    OFFSET_FIELD(srt_offset);   /* pointer to the SRT closure */
+#endif
+    StgHalfWord    fun_type;    /* function type */
+    StgHalfWord    arity;       /* function arity */
+} StgFunInfoExtraRev;
+
+typedef struct StgFunInfoExtraFwd_ {
+    StgHalfWord    fun_type;    /* function type */
+    StgHalfWord    arity;       /* function arity */
+    StgClosure    *srt;         /* pointer to the SRT closure */
+    union { /* union for compat. with TABLES_NEXT_TO_CODE version */
+        StgWord        bitmap;  /* arg ptr/nonptr bitmap */
+    } b;
+    StgFun         *slow_apply; /* apply to args on the stack */
+} StgFunInfoExtraFwd;
+
+typedef struct {
+#if defined(TABLES_NEXT_TO_CODE)
+    StgFunInfoExtraRev f;
+    StgInfoTable i;
+#else
+    StgInfoTable i;
+    StgFunInfoExtraFwd f;
+#endif
+} StgFunInfoTable;
+
+// canned bitmap for each arg type, indexed by constants in FunTypes.h
+extern const StgWord stg_arg_bitmaps[];
+
+/* -----------------------------------------------------------------------------
+   Return info tables
+   -------------------------------------------------------------------------- */
+
+/*
+ * When info tables are laid out backwards, we can omit the SRT
+ * pointer iff has_srt is zero.
+ */
+
+typedef struct {
+#if defined(TABLES_NEXT_TO_CODE)
+#if !defined(USE_INLINE_SRT_FIELD)
+    OFFSET_FIELD(srt_offset);   /* offset to the SRT closure */
+#endif
+    StgInfoTable i;
+#else
+    StgInfoTable i;
+    StgClosure  *srt;           /* pointer to the SRT closure */
+#endif
+} StgRetInfoTable;
+
+/* -----------------------------------------------------------------------------
+   Thunk info tables
+   -------------------------------------------------------------------------- */
+
+/*
+ * When info tables are laid out backwards, we can omit the SRT
+ * pointer iff has_srt is zero.
+ */
+
+typedef struct StgThunkInfoTable_ {
+#if defined(TABLES_NEXT_TO_CODE)
+#if !defined(USE_INLINE_SRT_FIELD)
+    OFFSET_FIELD(srt_offset);   /* offset to the SRT closure */
+#endif
+    StgInfoTable i;
+#else
+    StgInfoTable i;
+    StgClosure  *srt;           /* pointer to the SRT closure */
+#endif
+} StgThunkInfoTable;
+
+/* -----------------------------------------------------------------------------
+   Constructor info tables
+   -------------------------------------------------------------------------- */
+
+typedef struct StgConInfoTable_ {
+#if !defined(TABLES_NEXT_TO_CODE)
+    StgInfoTable i;
+#endif
+
+#if defined(TABLES_NEXT_TO_CODE)
+    OFFSET_FIELD(con_desc); // the name of the data constructor
+                            // as: Package:Module.Name
+#else
+    char *con_desc;
+#endif
+
+#if defined(TABLES_NEXT_TO_CODE)
+    StgInfoTable i;
+#endif
+} StgConInfoTable;
+
+
+/* -----------------------------------------------------------------------------
+   Accessor macros for fields that might be offsets (C version)
+   -------------------------------------------------------------------------- */
+
+/*
+ * GET_SRT(info)
+ * info must be a Stg[Ret|Thunk]InfoTable* (an info table that has a SRT)
+ */
+#if defined(TABLES_NEXT_TO_CODE)
+#if defined(x86_64_TARGET_ARCH)
+#define GET_SRT(info) \
+  ((StgClosure*) (((StgWord) ((info)+1)) + (info)->i.srt))
+#else
+#define GET_SRT(info) \
+  ((StgClosure*) (((StgWord) ((info)+1)) + (info)->srt_offset))
+#endif
+#else // !TABLES_NEXT_TO_CODE
+#define GET_SRT(info) ((info)->srt)
+#endif
+
+/*
+ * GET_CON_DESC(info)
+ * info must be a StgConInfoTable*.
+ */
+#if defined(TABLES_NEXT_TO_CODE)
+#define GET_CON_DESC(info) \
+            ((const char *)((StgWord)((info)+1) + (info->con_desc)))
+#else
+#define GET_CON_DESC(info) ((const char *)(info)->con_desc)
+#endif
+
+/*
+ * GET_FUN_SRT(info)
+ * info must be a StgFunInfoTable*
+ */
+#if defined(TABLES_NEXT_TO_CODE)
+#if defined(x86_64_TARGET_ARCH)
+#define GET_FUN_SRT(info) \
+  ((StgClosure*) (((StgWord) ((info)+1)) + (info)->i.srt))
+#else
+#define GET_FUN_SRT(info) \
+  ((StgClosure*) (((StgWord) ((info)+1)) + (info)->f.srt_offset))
+#endif
+#else
+#define GET_FUN_SRT(info) ((info)->f.srt)
+#endif
+
+#if defined(TABLES_NEXT_TO_CODE)
+#define GET_LARGE_BITMAP(info) ((StgLargeBitmap*) (((StgWord) ((info)+1)) \
+                                        + (info)->layout.large_bitmap_offset))
+#else
+#define GET_LARGE_BITMAP(info) ((info)->layout.large_bitmap)
+#endif
+
+#if defined(TABLES_NEXT_TO_CODE)
+#define GET_FUN_LARGE_BITMAP(info) ((StgLargeBitmap*) (((StgWord) ((info)+1)) \
+                                        + (info)->f.b.bitmap_offset))
+#else
+#define GET_FUN_LARGE_BITMAP(info) ((StgLargeBitmap*) ((info)->f.b.bitmap))
+#endif
+
+/*
+ * GET_PROF_TYPE, GET_PROF_DESC
+ */
+#if defined(TABLES_NEXT_TO_CODE)
+#define GET_PROF_TYPE(info) ((char *)((StgWord)((info)+1) + (info->prof.closure_type_off)))
+#else
+#define GET_PROF_TYPE(info) ((info)->prof.closure_type)
+#endif
+#if defined(TABLES_NEXT_TO_CODE)
+#define GET_PROF_DESC(info) ((char *)((StgWord)((info)+1) + (info->prof.closure_desc_off)))
+#else
+#define GET_PROF_DESC(info) ((info)->prof.closure_desc)
+#endif
diff --git a/includes/rts/storage/MBlock.h b/includes/rts/storage/MBlock.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/MBlock.h
@@ -0,0 +1,32 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2008
+ *
+ * MegaBlock Allocator interface.
+ *
+ * See wiki commentary at
+ *  http://ghc.haskell.org/trac/ghc/wiki/Commentary/HeapAlloced
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+extern W_ peak_mblocks_allocated;
+extern W_ mblocks_allocated;
+
+extern void initMBlocks(void);
+extern void * getMBlock(void);
+extern void * getMBlocks(uint32_t n);
+extern void * getMBlockOnNode(uint32_t node);
+extern void * getMBlocksOnNode(uint32_t node, uint32_t n);
+extern void freeMBlocks(void *addr, uint32_t n);
+extern void releaseFreeMemory(void);
+extern void freeAllMBlocks(void);
+
+extern void *getFirstMBlock(void **state);
+extern void *getNextMBlock(void **state, void *mblock);
+
+#if defined(THREADED_RTS)
+// needed for HEAP_ALLOCED below
+extern SpinLock gc_alloc_block_sync;
+#endif
diff --git a/includes/rts/storage/TSO.h b/includes/rts/storage/TSO.h
new file mode 100644
--- /dev/null
+++ b/includes/rts/storage/TSO.h
@@ -0,0 +1,261 @@
+/* -----------------------------------------------------------------------------
+ *
+ * (c) The GHC Team, 1998-2009
+ *
+ * The definitions for Thread State Objects.
+ *
+ * ---------------------------------------------------------------------------*/
+
+#pragma once
+
+/*
+ * PROFILING info in a TSO
+ */
+typedef struct {
+  CostCentreStack *cccs;       /* thread's current CCS */
+} StgTSOProfInfo;
+
+/*
+ * There is no TICKY info in a TSO at this time.
+ */
+
+/*
+ * Thread IDs are 32 bits.
+ */
+typedef StgWord32 StgThreadID;
+
+#define tsoLocked(tso) ((tso)->flags & TSO_LOCKED)
+
+/*
+ * Type returned after running a thread.  Values of this type
+ * include HeapOverflow, StackOverflow etc.  See Constants.h for the
+ * full list.
+ */
+typedef unsigned int StgThreadReturnCode;
+
+#if defined(mingw32_HOST_OS)
+/* results from an async I/O request + its request ID. */
+typedef struct {
+  unsigned int reqID;
+  int          len;
+  int          errCode;
+} StgAsyncIOResult;
+#endif
+
+/* Reason for thread being blocked. See comment above struct StgTso_. */
+typedef union {
+  StgClosure *closure;
+  StgTSO *prev; // a back-link when the TSO is on the run queue (NotBlocked)
+  struct MessageBlackHole_ *bh;
+  struct MessageThrowTo_ *throwto;
+  struct MessageWakeup_  *wakeup;
+  StgInt fd;    /* StgInt instead of int, so that it's the same size as the ptrs */
+#if defined(mingw32_HOST_OS)
+  StgAsyncIOResult *async_result;
+#endif
+#if !defined(THREADED_RTS)
+  StgWord target;
+    // Only for the non-threaded RTS: the target time for a thread
+    // blocked in threadDelay, in units of 1ms.  This is a
+    // compromise: we don't want to take up much space in the TSO.  If
+    // you want better resolution for threadDelay, use -threaded.
+#endif
+} StgTSOBlockInfo;
+
+
+/*
+ * TSOs live on the heap, and therefore look just like heap objects.
+ * Large TSOs will live in their own "block group" allocated by the
+ * storage manager, and won't be copied during garbage collection.
+ */
+
+/*
+ * Threads may be blocked for several reasons.  A blocked thread will
+ * have the reason in the why_blocked field of the TSO, and some
+ * further info (such as the closure the thread is blocked on, or the
+ * file descriptor if the thread is waiting on I/O) in the block_info
+ * field.
+ */
+
+typedef struct StgTSO_ {
+    StgHeader               header;
+
+    /* The link field, for linking threads together in lists (e.g. the
+       run queue on a Capability.
+    */
+    struct StgTSO_*         _link;
+    /*
+      Currently used for linking TSOs on:
+      * cap->run_queue_{hd,tl}
+      * (non-THREADED_RTS); the blocked_queue
+      * and pointing to the next chunk for a ThreadOldStack
+
+       NOTE!!!  do not modify _link directly, it is subject to
+       a write barrier for generational GC.  Instead use the
+       setTSOLink() function.  Exceptions to this rule are:
+
+       * setting the link field to END_TSO_QUEUE
+       * setting the link field of the currently running TSO, as it
+         will already be dirty.
+    */
+
+    struct StgTSO_*         global_link;    // Links threads on the
+                                            // generation->threads lists
+
+    /*
+     * The thread's stack
+     */
+    struct StgStack_       *stackobj;
+
+    /*
+     * The tso->dirty flag indicates that this TSO's stack should be
+     * scanned during garbage collection.  It also indicates that this
+     * TSO is on the mutable list.
+     *
+     * NB. The dirty flag gets a word to itself, so that it can be set
+     * safely by multiple threads simultaneously (the flags field is
+     * not safe for this purpose; see #3429).  It is harmless for the
+     * TSO to be on the mutable list multiple times.
+     *
+     * tso->dirty is set by dirty_TSO(), and unset by the garbage
+     * collector (only).
+     */
+
+    StgWord16               what_next;      // Values defined in Constants.h
+    StgWord16               why_blocked;    // Values defined in Constants.h
+    StgWord32               flags;          // Values defined in Constants.h
+    StgTSOBlockInfo         block_info;
+    StgThreadID             id;
+    StgWord32               saved_errno;
+    StgWord32               dirty;          /* non-zero => dirty */
+    struct InCall_*         bound;
+    struct Capability_*     cap;
+
+    struct StgTRecHeader_ * trec;       /* STM transaction record */
+
+    /*
+     * A list of threads blocked on this TSO waiting to throw exceptions.
+    */
+    struct MessageThrowTo_ * blocked_exceptions;
+
+    /*
+     * A list of StgBlockingQueue objects, representing threads
+     * blocked on thunks that are under evaluation by this thread.
+    */
+    struct StgBlockingQueue_ *bq;
+
+    /*
+     * The allocation limit for this thread, which is updated as the
+     * thread allocates.  If the value drops below zero, and
+     * TSO_ALLOC_LIMIT is set in flags, we raise an exception in the
+     * thread, and give the thread a little more space to handle the
+     * exception before we raise the exception again.
+     *
+     * This is an integer, because we might update it in a place where
+     * it isn't convenient to raise the exception, so we want it to
+     * stay negative until we get around to checking it.
+     *
+     * Use only PK_Int64/ASSIGN_Int64 macros to get/set the value of alloc_limit
+     * in C code otherwise you will cause alignment issues on SPARC
+     */
+    StgInt64  alloc_limit;     /* in bytes */
+
+    /*
+     * sum of the sizes of all stack chunks (in words), used to decide
+     * whether to throw the StackOverflow exception when the stack
+     * overflows, or whether to just chain on another stack chunk.
+     *
+     * Note that this overestimates the real stack size, because each
+     * chunk will have a gap at the end, of +RTS -kb<size> words.
+     * This means stack overflows are not entirely accurate, because
+     * the more gaps there are, the sooner the stack will run into the
+     * hard +RTS -K<size> limit.
+     */
+    StgWord32  tot_stack_size;
+
+#if defined(TICKY_TICKY)
+    /* TICKY-specific stuff would go here. */
+#endif
+#if defined(PROFILING)
+    StgTSOProfInfo prof;
+#endif
+#if defined(mingw32_HOST_OS)
+    StgWord32 saved_winerror;
+#endif
+
+} *StgTSOPtr; // StgTSO defined in rts/Types.h
+
+typedef struct StgStack_ {
+    StgHeader  header;
+    StgWord32  stack_size;     // stack size in *words*
+    StgWord32  dirty;          // non-zero => dirty
+    StgPtr     sp;             // current stack pointer
+    StgWord    stack[];
+} StgStack;
+
+// Calculate SpLim from a TSO (reads tso->stackobj, but no fields from
+// the stackobj itself).
+INLINE_HEADER StgPtr tso_SpLim (StgTSO* tso)
+{
+    return tso->stackobj->stack + RESERVED_STACK_WORDS;
+}
+
+/* -----------------------------------------------------------------------------
+   functions
+   -------------------------------------------------------------------------- */
+
+void dirty_TSO  (Capability *cap, StgTSO *tso);
+void setTSOLink (Capability *cap, StgTSO *tso, StgTSO *target);
+void setTSOPrev (Capability *cap, StgTSO *tso, StgTSO *target);
+
+void dirty_STACK (Capability *cap, StgStack *stack);
+
+/* -----------------------------------------------------------------------------
+   Invariants:
+
+   An active thread has the following properties:
+
+      tso->stack < tso->sp < tso->stack+tso->stack_size
+      tso->stack_size <= tso->max_stack_size
+
+      RESERVED_STACK_WORDS is large enough for any heap-check or
+      stack-check failure.
+
+      The size of the TSO struct plus the stack is either
+        (a) smaller than a block, or
+        (b) a multiple of BLOCK_SIZE
+
+        tso->why_blocked       tso->block_info      location
+        ----------------------------------------------------------------------
+        NotBlocked             END_TSO_QUEUE        runnable_queue, or running
+
+        BlockedOnBlackHole     MessageBlackHole *   TSO->bq
+
+        BlockedOnMVar          the MVAR             the MVAR's queue
+
+        BlockedOnSTM           END_TSO_QUEUE        STM wait queue(s)
+        BlockedOnSTM           STM_AWOKEN           run queue
+
+        BlockedOnMsgThrowTo    MessageThrowTo *     TSO->blocked_exception
+
+        BlockedOnRead          NULL                 blocked_queue
+        BlockedOnWrite         NULL                 blocked_queue
+        BlockedOnDelay         NULL                 blocked_queue
+
+      tso->link == END_TSO_QUEUE, if the thread is currently running.
+
+   A zombie thread has the following properties:
+
+      tso->what_next == ThreadComplete or ThreadKilled
+      tso->link     ==  (could be on some queue somewhere)
+      tso->sp       ==  tso->stack + tso->stack_size - 1 (i.e. top stack word)
+      tso->sp[0]    ==  return value of thread, if what_next == ThreadComplete,
+                        exception             , if what_next == ThreadKilled
+
+      (tso->sp is left pointing at the top word on the stack so that
+      the return value or exception will be retained by a GC).
+
+ ---------------------------------------------------------------------------- */
+
+/* this is the NIL ptr for a TSO queue (e.g. runnable queue) */
+#define END_TSO_QUEUE  ((StgTSO *)(void*)&stg_END_TSO_QUEUE_closure)
diff --git a/libraries/ghc-boot/GHC/HandleEncoding.hs b/libraries/ghc-boot/GHC/HandleEncoding.hs
--- a/libraries/ghc-boot/GHC/HandleEncoding.hs
+++ b/libraries/ghc-boot/GHC/HandleEncoding.hs
@@ -10,8 +10,8 @@
 -- GHC produces output regardless of OS.
 configureHandleEncoding :: IO ()
 configureHandleEncoding = do
-   mb_val <- lookupEnv "GHC_CHARENC"
-   case mb_val of
+   env <- getEnvironment
+   case lookup "GHC_CHARENC" env of
     Just "UTF-8" -> do
      hSetEncoding stdout utf8
      hSetEncoding stderr utf8
diff --git a/libraries/ghci/GHCi/BinaryArray.hs b/libraries/ghci/GHCi/BinaryArray.hs
new file mode 100644
--- /dev/null
+++ b/libraries/ghci/GHCi/BinaryArray.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-}
+-- | Efficient serialisation for GHCi Instruction arrays
+--
+-- Author: Ben Gamari
+--
+module GHCi.BinaryArray(putArray, getArray) where
+
+import Prelude
+import Foreign.Ptr
+import Data.Binary
+import Data.Binary.Put (putBuilder)
+import qualified Data.Binary.Get.Internal as Binary
+import qualified Data.ByteString.Builder as BB
+import qualified Data.ByteString.Builder.Internal as BB
+import qualified Data.Array.Base as A
+import qualified Data.Array.IO.Internals as A
+import qualified Data.Array.Unboxed as A
+import GHC.Exts
+import GHC.IO
+
+-- | An efficient serialiser of 'A.UArray'.
+putArray :: Binary i => A.UArray i a -> Put
+putArray (A.UArray l u _ arr#) = do
+    put l
+    put u
+    putBuilder $ byteArrayBuilder arr#
+
+byteArrayBuilder :: ByteArray# -> BB.Builder
+byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#))
+  where
+    go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a
+    go !inStart !inEnd k (BB.BufferRange outStart outEnd)
+      -- There is enough room in this output buffer to write all remaining array
+      -- contents
+      | inRemaining <= outRemaining = do
+          copyByteArrayToAddr arr# inStart outStart inRemaining
+          k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd)
+      -- There is only enough space for a fraction of the remaining contents
+      | otherwise = do
+          copyByteArrayToAddr arr# inStart outStart outRemaining
+          let !inStart' = inStart + outRemaining
+          return $! BB.bufferFull 1 outEnd (go inStart' inEnd k)
+      where
+        inRemaining  = inEnd - inStart
+        outRemaining = outEnd `minusPtr` outStart
+
+    copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()
+    copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) =
+        IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of
+                     s' -> (# s', () #)
+
+-- | An efficient deserialiser of 'A.UArray'.
+getArray :: (Binary i, A.Ix i, A.MArray A.IOUArray a IO) => Get (A.UArray i a)
+getArray = do
+    l <- get
+    u <- get
+    arr@(A.IOUArray (A.STUArray _ _ _ arr#)) <-
+        return $ unsafeDupablePerformIO $ A.newArray_ (l,u)
+    let go 0 _ = return ()
+        go !remaining !off = do
+            Binary.readNWith n $ \ptr ->
+              copyAddrToByteArray ptr arr# off n
+            go (remaining - n) (off + n)
+          where n = min chunkSize remaining
+    go (I# (sizeofMutableByteArray# arr#)) 0
+    return $! unsafeDupablePerformIO $ unsafeFreezeIOUArray arr
+  where
+    chunkSize = 10*1024
+
+    copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld
+                        -> Int -> Int -> IO ()
+    copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) =
+        IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of
+                     s' -> (# s', () #)
+
+-- this is inexplicably not exported in currently released array versions
+unsafeFreezeIOUArray :: A.IOUArray ix e -> IO (A.UArray ix e)
+unsafeFreezeIOUArray (A.IOUArray marr) = stToIO (A.unsafeFreezeSTUArray marr)
diff --git a/libraries/ghci/GHCi/CreateBCO.hs b/libraries/ghci/GHCi/CreateBCO.hs
--- a/libraries/ghci/GHCi/CreateBCO.hs
+++ b/libraries/ghci/GHCi/CreateBCO.hs
@@ -5,8 +5,6 @@
 {-# LANGUAGE MagicHash #-}
 {-# LANGUAGE UnboxedTuples #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE CPP #-}
 
 --
 --  (c) The University of Glasgow 2002-2006
@@ -19,13 +17,12 @@
 import GHCi.ResolvedBCO
 import GHCi.RemoteTypes
 import GHCi.BreakArray
-import GHC.Data.SizedSeq
+import SizedSeq
 
 import System.IO (fixIO)
 import Control.Monad
 import Data.Array.Base
 import Foreign hiding (newArray)
-import Unsafe.Coerce (unsafeCoerce)
 import GHC.Arr          ( Array(..) )
 import GHC.Exts
 import GHC.IO
@@ -47,15 +44,7 @@
                 , "mixed endianness setup is not supported!"
                 ])
 createBCO arr bco
-   = 
-#if MIN_VERSION_ghc_prim(0, 7, 0)
-     do linked_bco <- linkBCO' arr bco
-#else
-     do BCO bco# <- linkBCO' arr bco
-#endif
-
-        -- Note [Updatable CAF BCOs]
-        -- ~~~~~~~~~~~~~~~~~~~~~~~~~
+   = do BCO bco# <- linkBCO' arr bco
         -- Why do we need mkApUpd0 here?  Otherwise top-level
         -- interpreted CAFs don't get updated after evaluation.  A
         -- top-level BCO will evaluate itself and return its value
@@ -68,17 +57,9 @@
         --   (c) An AP is always fully saturated, so we *can't* wrap
         --       non-zero arity BCOs in an AP thunk.
         --
-        -- See #17424.
         if (resolvedBCOArity bco > 0)
-           
-#if MIN_VERSION_ghc_prim(0, 7, 0)
-           then return (HValue (unsafeCoerce linked_bco))
-           else case mkApUpd0# linked_bco of { (# final_bco #) ->
-#else
            then return (HValue (unsafeCoerce# bco#))
            else case mkApUpd0# bco# of { (# final_bco #) ->
-#endif
-
                   return (HValue final_bco) }
 
 
@@ -121,15 +102,8 @@
     fill (ResolvedBCOStaticPtr r) i = do
       writePtrsArrayPtr i (fromRemotePtr r)  marr
     fill (ResolvedBCOPtrBCO bco) i = do
-      
-#if MIN_VERSION_ghc_prim(0, 7, 0)
-      bco <- linkBCO' arr bco
-      writePtrsArrayBCO i bco marr
-#else
       BCO bco# <- linkBCO' arr bco
       writePtrsArrayBCO i bco# marr
-#endif
-
     fill (ResolvedBCOPtrBreakArray r) i = do
       BA mba <- localRef r
       writePtrsArrayMBA i mba marr
@@ -154,47 +128,25 @@
 -- without making a thunk turns out to be surprisingly tricky.
 {-# NOINLINE writeArrayAddr# #-}
 writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s
-#if defined(js_HOST_ARCH)
--- Addr# isn't coercible with Any with the JS backend.
-writeArrayAddr# = error "writeArrayAddr#: currently unsupported with the JS backend"
-#else
 writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s
-#endif
 
-
-#if MIN_VERSION_ghc_prim(0, 7, 0)
-writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO ()
-#else
 writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO ()
-#endif
-
 writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s ->
   case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #)
 
-
-#if MIN_VERSION_ghc_prim(0, 7, 0)
-writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()
-#else
 data BCO = BCO BCO#
-writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()
-#endif
 
+writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()
 writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s ->
   case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #)
 
 newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
 newBCO instrs lits ptrs arity bitmap = IO $ \s ->
-  
-#if MIN_VERSION_ghc_prim(0, 7, 0)
-  newBCO# instrs lits ptrs arity bitmap s
-#else
   case newBCO# instrs lits ptrs arity bitmap s of
     (# s1, bco #) -> (# s1, BCO bco #)
-#endif
 
-
 {- Note [BCO empty array]
-   ~~~~~~~~~~~~~~~~~~~~~~
+
 Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free:
 they are 2-word heap objects.  So let's make a single empty array and
 share it between all BCOs.
diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc
--- a/libraries/ghci/GHCi/InfoTable.hsc
+++ b/libraries/ghci/GHCi/InfoTable.hsc
@@ -10,53 +10,58 @@
 --
 module GHCi.InfoTable
   (
+#ifdef GHCI
     mkConInfoTable
+#endif
   ) where
 
-import Prelude hiding (fail) -- See note [Why do we import Prelude here?]
-
+import Prelude -- See note [Why do we import Prelude here?]
+#ifdef GHCI
 import Foreign
 import Foreign.C
 import GHC.Ptr
 import GHC.Exts
 import GHC.Exts.Heap
-import Data.ByteString (ByteString)
-import Control.Monad.Fail
-import qualified Data.ByteString as BS
-import GHC.Platform.Host (hostPlatformArch)
-import GHC.Platform.ArchOS
+#endif
 
+ghciTablesNextToCode :: Bool
+#ifdef TABLES_NEXT_TO_CODE
+ghciTablesNextToCode = True
+#else
+ghciTablesNextToCode = False
+#endif
+
+#ifdef GHCI /* To end */
 -- NOTE: Must return a pointer acceptable for use in the header of a closure.
--- If tables_next_to_code is enabled, then it must point the 'code' field.
+-- If tables_next_to_code is enabled, then it must point the the 'code' field.
 -- Otherwise, it should point to the start of the StgInfoTable.
 mkConInfoTable
-   :: Bool    -- TABLES_NEXT_TO_CODE
-   -> Int     -- ptr words
+   :: Int     -- ptr words
    -> Int     -- non-ptr words
    -> Int     -- constr tag
    -> Int     -- pointer tag
-   -> ByteString  -- con desc
+   -> [Word8]  -- con desc
    -> IO (Ptr StgInfoTable)
-      -- resulting info table is allocated with allocateExecPage(), and
-      -- should be freed with freeExecPage().
+      -- resulting info table is allocated with allocateExec(), and
+      -- should be freed with freeExec().
 
-mkConInfoTable tables_next_to_code ptr_words nonptr_words tag ptrtag con_desc = do
-  let entry_addr = interpConstrEntry !! ptrtag
-  code' <- if tables_next_to_code
-    then Just <$> mkJumpToAddr entry_addr
-    else pure Nothing
-  let
+mkConInfoTable ptr_words nonptr_words tag ptrtag con_desc =
+  castFunPtrToPtr <$> newExecConItbl itbl con_desc
+  where
+     entry_addr = interpConstrEntry !! ptrtag
+     code' = mkJumpToAddr entry_addr
      itbl  = StgInfoTable {
-                 entry = if tables_next_to_code
+                 entry = if ghciTablesNextToCode
                          then Nothing
                          else Just entry_addr,
                  ptrs  = fromIntegral ptr_words,
                  nptrs = fromIntegral nonptr_words,
                  tipe  = CONSTR,
                  srtlen = fromIntegral tag,
-                 code  = code'
+                 code  = if ghciTablesNextToCode
+                         then Just code'
+                         else Nothing
               }
-  castFunPtrToPtr <$> newExecConItbl tables_next_to_code itbl con_desc
 
 
 -- -----------------------------------------------------------------------------
@@ -65,9 +70,71 @@
 funPtrToInt :: FunPtr a -> Int
 funPtrToInt (FunPtr a) = I## (addr2Int## a)
 
-mkJumpToAddr :: MonadFail m => EntryFunPtr-> m ItblCodes
-mkJumpToAddr a = case hostPlatformArch of
-    ArchPPC -> pure $
+data Arch = ArchSPARC
+          | ArchPPC
+          | ArchX86
+          | ArchX86_64
+          | ArchAlpha
+          | ArchARM
+          | ArchARM64
+          | ArchPPC64
+          | ArchPPC64LE
+          | ArchUnknown
+ deriving Show
+
+platform :: Arch
+platform =
+#if defined(sparc_HOST_ARCH)
+       ArchSPARC
+#elif defined(powerpc_HOST_ARCH)
+       ArchPPC
+#elif defined(i386_HOST_ARCH)
+       ArchX86
+#elif defined(x86_64_HOST_ARCH)
+       ArchX86_64
+#elif defined(alpha_HOST_ARCH)
+       ArchAlpha
+#elif defined(arm_HOST_ARCH)
+       ArchARM
+#elif defined(aarch64_HOST_ARCH)
+       ArchARM64
+#elif defined(powerpc64_HOST_ARCH)
+       ArchPPC64
+#elif defined(powerpc64le_HOST_ARCH)
+       ArchPPC64LE
+#else
+#    if defined(TABLES_NEXT_TO_CODE)
+#        error Unimplemented architecture
+#    else
+       ArchUnknown
+#    endif
+#endif
+
+mkJumpToAddr :: EntryFunPtr -> ItblCodes
+mkJumpToAddr a = case platform of
+    ArchSPARC ->
+        -- After some consideration, we'll try this, where
+        -- 0x55555555 stands in for the address to jump to.
+        -- According to includes/rts/MachRegs.h, %g3 is very
+        -- likely indeed to be baggable.
+        --
+        --   0000 07155555              sethi   %hi(0x55555555), %g3
+        --   0004 8610E155              or      %g3, %lo(0x55555555), %g3
+        --   0008 81C0C000              jmp     %g3
+        --   000c 01000000              nop
+
+        let w32 = fromIntegral (funPtrToInt a)
+
+            hi22, lo10 :: Word32 -> Word32
+            lo10 x = x .&. 0x3FF
+            hi22 x = (x `shiftR` 10) .&. 0x3FFFF
+
+        in Right [ 0x07000000 .|. (hi22 w32),
+                   0x8610E000 .|. (lo10 w32),
+                   0x81C0C000,
+                   0x01000000 ]
+
+    ArchPPC ->
         -- We'll use r12, for no particular reason.
         -- 0xDEADBEEF stands for the address:
         -- 3D80DEAD lis r12,0xDEAD
@@ -82,7 +149,7 @@
                    0x618C0000 .|. lo16 w32,
                    0x7D8903A6, 0x4E800420 ]
 
-    ArchX86 -> pure $
+    ArchX86 ->
         -- Let the address to jump to be 0xWWXXYYZZ.
         -- Generate   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax
         -- which is
@@ -97,7 +164,7 @@
         in
             Left insnBytes
 
-    ArchX86_64 -> pure $
+    ArchX86_64 ->
         -- Generates:
         --      jmpq *.L1(%rip)
         --      .align 8
@@ -121,7 +188,7 @@
         in
             Left insnBytes
 
-    ArchAlpha -> pure $
+    ArchAlpha ->
         let w64 = fromIntegral (funPtrToInt a) :: Word64
         in Right [ 0xc3800000      -- br   at, .+4
                  , 0xa79c000c      -- ldq  at, 12(at)
@@ -130,7 +197,7 @@
                  , fromIntegral (w64 .&. 0x0000FFFF)
                  , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]
 
-    ArchARM {} -> pure $
+    ArchARM { } ->
         -- Generates Arm sequence,
         --      ldr r1, [pc, #0]
         --      bx r1
@@ -144,7 +211,7 @@
                 , 0x11, 0xff, 0x2f, 0xe1
                 , byte0 w32, byte1 w32, byte2 w32, byte3 w32]
 
-    ArchAArch64 {} -> pure $
+    ArchARM64 { } ->
         -- Generates:
         --
         --      ldr     x1, label
@@ -160,8 +227,7 @@
                 , 0xd61f0020
                 , fromIntegral w64
                 , fromIntegral (w64 `shiftR` 32) ]
-
-    ArchPPC_64 ELF_V1 -> pure $
+    ArchPPC64 ->
         -- We use the compiler's register r12 to read the function
         -- descriptor and the linker's register r11 as a temporary
         -- register to hold the function entry point.
@@ -187,7 +253,7 @@
                   0xE96C0010,
                   0x4E800420]
 
-    ArchPPC_64 ELF_V2 -> pure $
+    ArchPPC64LE ->
         -- The ABI requires r12 to point to the function's entry point.
         -- We use the medium code model where code resides in the first
         -- two gigabytes, so loading a non-negative32 bit address
@@ -205,34 +271,10 @@
                    0x618C0000 .|. lo16 w32,
                    0x7D8903A6, 0x4E800420 ]
 
-    ArchS390X -> pure $
-        -- Let 0xAABBCCDDEEFFGGHH be the address to jump to.
-        -- The following code loads the address into scratch
-        -- register r1 and jumps to it.
-        --
-        --    0:   C0 1E AA BB CC DD       llihf   %r1,0xAABBCCDD
-        --    6:   C0 19 EE FF GG HH       iilf    %r1,0xEEFFGGHH
-        --   12:   07 F1                   br      %r1
-
-        let w64 = fromIntegral (funPtrToInt a) :: Word64
-        in Left [ 0xC0, 0x1E, byte7 w64, byte6 w64, byte5 w64, byte4 w64,
-                  0xC0, 0x19, byte3 w64, byte2 w64, byte1 w64, byte0 w64,
-                  0x07, 0xF1 ]
-
-    ArchRISCV64 -> pure $
-        let w64 = fromIntegral (funPtrToInt a) :: Word64
-        in Right [ 0x00000297          -- auipc t0,0
-                 , 0x01053283          -- ld    t0,16(t0)
-                 , 0x00028067          -- jr    t0
-                 , 0x00000013          -- nop
-                 , fromIntegral w64
-                 , fromIntegral (w64 `shiftR` 32) ]
-
-    arch ->
-      -- The arch isn't supported. You either need to add your architecture as a
-      -- distinct case, or use non-TABLES_NEXT_TO_CODE mode.
-      fail $ "mkJumpToAddr: arch is not supported with TABLES_NEXT_TO_CODE ("
-             ++ show arch ++ ")"
+    -- This code must not be called. You either need to
+    -- add your architecture as a distinct case or
+    -- use non-TABLES_NEXT_TO_CODE mode
+    ArchUnknown -> error "mkJumpToAddr: ArchUnknown is unsupported"
 
 byte0 :: (Integral w) => w -> Word8
 byte0 w = fromIntegral w
@@ -277,66 +319,38 @@
 
 
 pokeConItbl
-  :: Bool -> Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
+  :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable
   -> IO ()
-pokeConItbl tables_next_to_code wr_ptr _ex_ptr itbl = do
-  if tables_next_to_code
-    then do
-      -- Write the offset to the con_desc from the end of the standard InfoTable
-      -- at the first byte.
-      let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)
-      (#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset
-    else do
-      -- Write the con_desc address after the end of the info table.
-      -- Use itblSize because CPP will not pick up PROFILING when calculating
-      -- the offset.
-      pokeByteOff wr_ptr itblSize (conDesc itbl)
+pokeConItbl wr_ptr _ex_ptr itbl = do
+#if defined(TABLES_NEXT_TO_CODE)
+  -- Write the offset to the con_desc from the end of the standard InfoTable
+  -- at the first byte.
+  let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)
+  (#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset
+#else
+  -- Write the con_desc address after the end of the info table.
+  -- Use itblSize because CPP will not pick up PROFILING when calculating
+  -- the offset.
+  pokeByteOff wr_ptr itblSize (conDesc itbl)
+#endif
   pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl)
 
-sizeOfEntryCode :: MonadFail m => Bool -> m Int
-sizeOfEntryCode tables_next_to_code
-  | not tables_next_to_code = pure 0
-  | otherwise = do
-     code' <- mkJumpToAddr undefined
-     pure $ case code' of
-       Left  (xs :: [Word8])  -> sizeOf (undefined :: Word8)  * length xs
-       Right (xs :: [Word32]) -> sizeOf (undefined :: Word32) * length xs
+sizeOfEntryCode :: Int
+sizeOfEntryCode
+  | not ghciTablesNextToCode = 0
+  | otherwise =
+     case mkJumpToAddr undefined of
+       Left  xs -> sizeOf (head xs) * length xs
+       Right xs -> sizeOf (head xs) * length xs
 
 -- Note: Must return proper pointer for use in a closure
-#if MIN_VERSION_rts(1,0,1)
-newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())
-newExecConItbl tables_next_to_code obj con_desc = do
-    sz0 <- sizeOfEntryCode tables_next_to_code
-    let lcon_desc = BS.length con_desc + 1{- null terminator -}
-        -- SCARY
-        -- This size represents the number of bytes in an StgConInfoTable.
-        sz = fromIntegral $ conInfoTableSizeB + sz0
-            -- Note: we need to allocate the conDesc string next to the info
-            -- table, because on a 64-bit platform we reference this string
-            -- with a 32-bit offset relative to the info table, so if we
-            -- allocated the string separately it might be out of range.
-
-    ex_ptr <- fillExecBuffer (sz + fromIntegral lcon_desc) $ \wr_ptr ex_ptr -> do
-        let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
-                                    , infoTable = obj }
-        pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo
-        BS.useAsCStringLen con_desc $ \(src, len) ->
-            copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len
-        let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)
-        poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)
-
-    pure $ if tables_next_to_code
-      then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB
-      else castPtrToFunPtr ex_ptr
-#else
-newExecConItbl :: Bool -> StgInfoTable -> ByteString -> IO (FunPtr ())
-newExecConItbl tables_next_to_code obj con_desc
+newExecConItbl :: StgInfoTable -> [Word8] -> IO (FunPtr ())
+newExecConItbl obj con_desc
    = alloca $ \pcode -> do
-        sz0 <- sizeOfEntryCode tables_next_to_code
-        let lcon_desc = BS.length con_desc + 1{- null terminator -}
+        let lcon_desc = length con_desc + 1{- null terminator -}
             -- SCARY
             -- This size represents the number of bytes in an StgConInfoTable.
-            sz = fromIntegral $ conInfoTableSizeB + sz0
+            sz = fromIntegral (conInfoTableSizeB + sizeOfEntryCode)
                -- Note: we need to allocate the conDesc string next to the info
                -- table, because on a 64-bit platform we reference this string
                -- with a 32-bit offset relative to the info table, so if we
@@ -345,60 +359,14 @@
         ex_ptr <- peek pcode
         let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz
                                     , infoTable = obj }
-        pokeConItbl tables_next_to_code wr_ptr ex_ptr cinfo
-        BS.useAsCStringLen con_desc $ \(src, len) ->
-            copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len
-        let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)
-        poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)
+        pokeConItbl wr_ptr ex_ptr cinfo
+        pokeArray0 0 (castPtr wr_ptr `plusPtr` fromIntegral sz) con_desc
         _flushExec sz ex_ptr -- Cache flush (if needed)
-        pure $ if tables_next_to_code
-          then castPtrToFunPtr $ ex_ptr `plusPtr` conInfoTableSizeB
-          else castPtrToFunPtr ex_ptr
-#endif
-
--- | Allocate a buffer of a given size, use the given action to fill it with
--- data, and mark it as executable. The action is given a writable pointer and
--- the executable pointer. Returns a pointer to the executable code.
-#if MIN_VERSION_rts(1,0,1)
-fillExecBuffer :: CSize -> (Ptr a -> Ptr a -> IO ()) -> IO (Ptr a)
-#endif
-
-#if MIN_VERSION_rts(1,0,2)
-
-data ExecPage
-
-foreign import ccall unsafe "allocateExecPage"
-  _allocateExecPage :: IO (Ptr ExecPage)
-
-foreign import ccall unsafe "freezeExecPage"
-  _freezeExecPage :: Ptr ExecPage -> IO ()
-
-fillExecBuffer sz cont
-    -- we can only allocate single pages. This assumes a 4k page size which
-    -- isn't strictly correct but is a reasonable conservative lower bound.
-  | sz > 4096 = fail "withExecBuffer: Too large"
-  | otherwise = do
-        pg <- _allocateExecPage
-        cont (castPtr pg) (castPtr pg)
-        _freezeExecPage pg
-        return (castPtr pg)
-
-#elif MIN_VERSION_rts(1,0,1)
-
-foreign import ccall unsafe "allocateExec"
-  _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)
-
-foreign import ccall unsafe "flushExec"
-  _flushExec :: CUInt -> Ptr a -> IO ()
-
-fillExecBuffer sz cont = alloca $ \pcode -> do
-    wr_ptr <- _allocateExec (fromIntegral sz) pcode
-    ex_ptr <- peek pcode
-    cont wr_ptr ex_ptr
-    _flushExec (fromIntegral sz) ex_ptr -- Cache flush (if needed)
-    return (ex_ptr)
-
+#if defined(TABLES_NEXT_TO_CODE)
+        return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB))
 #else
+        return (castPtrToFunPtr ex_ptr)
+#endif
 
 foreign import ccall unsafe "allocateExec"
   _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)
@@ -406,9 +374,6 @@
 foreign import ccall unsafe "flushExec"
   _flushExec :: CUInt -> Ptr a -> IO ()
 
-
-#endif
-
 -- -----------------------------------------------------------------------------
 -- Constants and config
 
@@ -417,3 +382,4 @@
 
 conInfoTableSizeB :: Int
 conInfoTableSizeB = wORD_SIZE + itblSize
+#endif /* GHCI */
diff --git a/libraries/ghci/GHCi/ResolvedBCO.hs b/libraries/ghci/GHCi/ResolvedBCO.hs
new file mode 100644
--- /dev/null
+++ b/libraries/ghci/GHCi/ResolvedBCO.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,
+    BangPatterns, CPP #-}
+module GHCi.ResolvedBCO
+  ( ResolvedBCO(..)
+  , ResolvedBCOPtr(..)
+  , isLittleEndian
+  ) where
+
+import Prelude -- See note [Why do we import Prelude here?]
+import SizedSeq
+import GHCi.RemoteTypes
+import GHCi.BreakArray
+
+import Data.Array.Unboxed
+import Data.Binary
+import GHC.Generics
+import GHCi.BinaryArray
+
+
+#include "MachDeps.h"
+
+isLittleEndian :: Bool
+#if defined(WORDS_BIGENDIAN)
+isLittleEndian = True
+#else
+isLittleEndian = False
+#endif
+
+-- -----------------------------------------------------------------------------
+-- ResolvedBCO
+
+-- | A 'ResolvedBCO' is one in which all the 'Name' references have been
+-- resolved to actual addresses or 'RemoteHValues'.
+--
+-- Note, all arrays are zero-indexed (we assume this when
+-- serializing/deserializing)
+data ResolvedBCO
+   = ResolvedBCO {
+        resolvedBCOIsLE   :: Bool,
+        resolvedBCOArity  :: {-# UNPACK #-} !Int,
+        resolvedBCOInstrs :: UArray Int Word16,         -- insns
+        resolvedBCOBitmap :: UArray Int Word64,         -- bitmap
+        resolvedBCOLits   :: UArray Int Word64,         -- non-ptrs
+        resolvedBCOPtrs   :: (SizedSeq ResolvedBCOPtr)  -- ptrs
+   }
+   deriving (Generic, Show)
+
+-- | The Binary instance for ResolvedBCOs.
+--
+-- Note, that we do encode the endianness, however there is no support for mixed
+-- endianness setups.  This is primarily to ensure that ghc and iserv share the
+-- same endianness.
+instance Binary ResolvedBCO where
+  put ResolvedBCO{..} = do
+    put resolvedBCOIsLE
+    put resolvedBCOArity
+    putArray resolvedBCOInstrs
+    putArray resolvedBCOBitmap
+    putArray resolvedBCOLits
+    put resolvedBCOPtrs
+  get = ResolvedBCO
+        <$> get <*> get <*> getArray <*> getArray <*> getArray <*> get
+
+data ResolvedBCOPtr
+  = ResolvedBCORef {-# UNPACK #-} !Int
+      -- ^ reference to the Nth BCO in the current set
+  | ResolvedBCOPtr {-# UNPACK #-} !(RemoteRef HValue)
+      -- ^ reference to a previously created BCO
+  | ResolvedBCOStaticPtr {-# UNPACK #-} !(RemotePtr ())
+      -- ^ reference to a static ptr
+  | ResolvedBCOPtrBCO ResolvedBCO
+      -- ^ a nested BCO
+  | ResolvedBCOPtrBreakArray {-# UNPACK #-} !(RemoteRef BreakArray)
+      -- ^ Resolves to the MutableArray# inside the BreakArray
+  deriving (Generic, Show)
+
+instance Binary ResolvedBCOPtr
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
--- a/libraries/ghci/GHCi/Run.hs
+++ b/libraries/ghci/GHCi/Run.hs
@@ -6,7 +6,7 @@
 -- Execute GHCi messages.
 --
 -- For details on Remote GHCi, see Note [Remote GHCi] in
--- compiler/GHC/Runtime/Interpreter.hs.
+-- compiler/ghci/GHCi.hs.
 --
 module GHCi.Run
   ( run, redirectInterrupts
@@ -32,7 +32,7 @@
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Unsafe as B
 import GHC.Exts
-import qualified GHC.Exts.Heap as Heap
+import GHC.Exts.Heap
 import GHC.Stack
 import Foreign hiding (void)
 import Foreign.C
@@ -44,13 +44,9 @@
 -- -----------------------------------------------------------------------------
 -- Implement messages
 
-foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
-        -- Make it "safe", just in case
-
 run :: Message a -> IO a
 run m = case m of
   InitLinker -> initObjLinker RetainCAFs
-  RtsRevertCAFs -> rts_revertCAFs
   LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str
   LookupClosure str -> lookupClosure str
   LoadDLL str -> loadDLL str
@@ -73,15 +69,15 @@
   MkCostCentres mod ccs -> mkCostCentres mod ccs
   CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)
   NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz
-  SetupBreakpoint ref ix cnt -> do
-    arr <- localRef ref;
-    _ <- setupBreakpoint arr ix cnt
+  EnableBreakpoint ref ix b -> do
+    arr <- localRef ref
+    _ <- if b then setBreakOn arr ix else setBreakOff arr ix
     return ()
   BreakpointStatus ref ix -> do
     arr <- localRef ref; r <- getBreak arr ix
     case r of
       Nothing -> return False
-      Just w -> return (w == 0)
+      Just w -> return (w /= 0)
   GetBreakpointVar ref ix -> do
     aps <- localRef ref
     mapM mkRemoteRef =<< getIdValFromApStack aps ix
@@ -89,14 +85,13 @@
   MallocStrings bss -> mapM mkString0 bss
   PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res
   FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)
-  MkConInfoTable tc ptrs nptrs tag ptrtag desc ->
-    toRemotePtr <$> mkConInfoTable tc ptrs nptrs tag ptrtag desc
+  MkConInfoTable ptrs nptrs tag ptrtag desc ->
+    toRemotePtr <$> mkConInfoTable ptrs nptrs tag ptrtag desc
   StartTH -> startTH
   GetClosure ref -> do
-    clos <- Heap.getClosureData =<< localRef ref
-    mapM (\(Heap.Box x) -> mkRemoteRef (HValue x)) clos
-  Seq ref -> doSeq ref
-  ResumeSeq ref -> resumeSeq ref
+    clos <- getClosureData =<< localRef ref
+    mapM (\(Box x) -> mkRemoteRef (HValue x)) clos
+  Seq ref -> tryEval (void $ evaluate =<< localRef ref)
   _other -> error "GHCi.Run.run"
 
 evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])
@@ -131,37 +126,6 @@
     r <- (unsafeCoerce io :: String -> IO String) str
     evaluate (force r)
 
--- | Process the Seq message to force a value.                       #2950
--- If during this processing a breakpoint is hit, return
--- an EvalBreak value in the EvalStatus to the UI process,
--- otherwise return an EvalComplete.
--- The UI process has more and therefore also can show more
--- information about the breakpoint than the current iserv
--- process.
-doSeq :: RemoteRef a -> IO (EvalStatus ())
-doSeq ref = do
-    sandboxIO evalOptsSeq $ do
-      _ <- (void $ evaluate =<< localRef ref)
-      return ()
-
--- | Process a ResumeSeq message. Continue the :force processing     #2950
--- after a breakpoint.
-resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus ())
-resumeSeq hvref = do
-    ResumeContext{..} <- localRef hvref
-    withBreakAction evalOptsSeq resumeBreakMVar resumeStatusMVar $
-      mask_ $ do
-        putMVar resumeBreakMVar () -- this awakens the stopped thread...
-        redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar
-
-evalOptsSeq :: EvalOpts
-evalOptsSeq = EvalOpts
-              { useSandboxThread = True
-              , singleStep = False
-              , breakOnException = False
-              , breakOnError = False
-              }
-
 -- When running a computation, we redirect ^C exceptions to the running
 -- thread.  ToDo: we might want a way to continue even if the target
 -- thread doesn't die when it receives the exception... "this thread
@@ -250,10 +214,10 @@
 
 measureAlloc :: IO (EvalResult a) -> IO (EvalStatus a)
 measureAlloc io = do
-  setAllocationCounter 0                                 -- #16012
+  setAllocationCounter maxBound
   a <- io
   ctr <- getAllocationCounter
-  let allocs = negate $ fromIntegral ctr
+  let allocs = fromIntegral (maxBound::Int64) - fromIntegral ctr
   return (EvalComplete allocs a)
 
 -- Exceptions can't be marshaled because they're dynamically typed, so
diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs
--- a/libraries/ghci/GHCi/TH.hs
+++ b/libraries/ghci/GHCi/TH.hs
@@ -13,13 +13,13 @@
   ) where
 
 {- Note [Remote Template Haskell]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
 Here is an overview of how TH works with -fexternal-interpreter.
 
 Initialisation
 ~~~~~~~~~~~~~~
 
-GHC sends a StartTH message to the server (see GHC.Tc.Gen.Splice.getTHState):
+GHC sends a StartTH message to the server (see TcSplice.getTHState):
 
    StartTH :: Message (RemoteRef (IORef QState))
 
@@ -79,15 +79,16 @@
 After typechecking
 ~~~~~~~~~~~~~~~~~~
 
-GHC sends a FinishTH message to the server (see GHC.Tc.Gen.Splice.finishTH).
+GHC sends a FinishTH message to the server (see TcSplice.finishTH).
 The server runs any finalizers that were added by addModuleFinalizer.
 
 
 Other Notes on TH / Remote GHCi
 
-  * Note [Remote GHCi] in compiler/GHC/Runtime/Interpreter.hs
-  * Note [External GHCi pointers] in compiler/GHC/Runtime/Interpreter.hs
-  * Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
+  * Note [Remote GHCi] in compiler/ghci/GHCi.hs
+  * Note [External GHCi pointers] in compiler/ghci/GHCi.hs
+  * Note [TH recover with -fexternal-interpreter] in
+    compiler/typecheck/TcSplice.hs
 -}
 
 import Prelude -- See note [Why do we import Prelude here?]
@@ -96,6 +97,7 @@
 import GHC.Serialized
 
 import Control.Exception
+import qualified Control.Monad.Fail as Fail
 import Control.Monad.IO.Class (MonadIO (..))
 import Data.Binary
 import Data.Binary.Put
@@ -142,8 +144,11 @@
     do (m', s')  <- runGHCiQ m s
        (a,  s'') <- runGHCiQ (f m') s'
        return (a, s'')
+#if !MIN_VERSION_base(4,13,0)
+  fail = Fail.fail
+#endif
 
-instance MonadFail GHCiQ where
+instance Fail.MonadFail GHCiQ where
   fail err  = GHCiQ $ \s -> throwIO (GHCiQException s err)
 
 getState :: GHCiQ QState
@@ -167,7 +172,7 @@
   qNewName str = ghcCmd (NewName str)
   qReport isError msg = ghcCmd (Report isError msg)
 
-  -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
+  -- See Note [TH recover with -fexternal-interpreter] in TcSplice
   qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do
     remoteTHCall (qsPipe s) StartRecover
     e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s
@@ -178,7 +183,6 @@
   qLookupName isType occ = ghcCmd (LookupName isType occ)
   qReify name = ghcCmd (Reify name)
   qReifyFixity name = ghcCmd (ReifyFixity name)
-  qReifyType name = ghcCmd (ReifyType name)
   qReifyInstances name tys = ghcCmd (ReifyInstances name tys)
   qReifyRoles name = ghcCmd (ReifyRoles name)
 
@@ -194,7 +198,6 @@
   qReifyModule m = ghcCmd (ReifyModule m)
   qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
   qLocation = fromMaybe noLoc . qsLocation <$> getState
-  qGetPackageRoot        = ghcCmd GetPackageRoot
   qAddDependentFile file = ghcCmd (AddDependentFile file)
   qAddTempFile suffix = ghcCmd (AddTempFile suffix)
   qAddTopDecls decls = ghcCmd (AddTopDecls decls)
@@ -210,8 +213,6 @@
     return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
   qIsExtEnabled x = ghcCmd (IsExtEnabled x)
   qExtsEnabled = ghcCmd ExtsEnabled
-  qPutDoc l s = ghcCmd (PutDoc l s)
-  qGetDoc l = ghcCmd (GetDoc l)
 
 -- | The implementation of the 'StartTH' message: create
 -- a new IORef QState, and return a RemoteRef to it.
@@ -264,7 +265,7 @@
 runTHQ
   :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a
   -> IO ByteString
-runTHQ pipe rstate mb_loc ghciq = do
+runTHQ pipe@Pipe{..} rstate mb_loc ghciq = do
   qstateref <- localRef rstate
   qstate <- readIORef qstateref
   let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
diff --git a/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs b/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs
deleted file mode 100644
--- a/libraries/template-haskell/Language/Haskell/TH/CodeDo.hs
+++ /dev/null
@@ -1,22 +0,0 @@
--- | This module exists to work nicely with the QualifiedDo
--- extension.
---
--- @
--- import qualified Language.Haskell.TH.CodeDo as Code
---
--- myExample :: Monad m => Code m a -> Code m a -> Code m a
--- myExample opt1 opt2 =
---   Code.do
---    x <- someSideEffect               -- This one is of type `M Bool`
---    if x then opt1 else opt2
--- @
-module Language.Haskell.TH.CodeDo((>>=), (>>)) where
-
-import Language.Haskell.TH.Syntax
-import Prelude(Monad)
-
--- | Module over monad operator for 'Code'
-(>>=) :: Monad m => m a -> (a -> Code m b) -> Code m b
-(>>=) = bindCode
-(>>) :: Monad m => m a -> Code m b -> Code m b
-(>>)  = bindCode_
diff --git a/libraries/template-haskell/Language/Haskell/TH/Quote.hs b/libraries/template-haskell/Language/Haskell/TH/Quote.hs
--- a/libraries/template-haskell/Language/Haskell/TH/Quote.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Quote.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RankNTypes, ScopedTypeVariables, Safe #-}
+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
 {- |
 Module : Language.Haskell.TH.Quote
 Description : Quasi-quoting support for Template Haskell
diff --git a/rts/include/ghcconfig.h b/rts/include/ghcconfig.h
deleted file mode 100644
--- a/rts/include/ghcconfig.h
+++ /dev/null
@@ -1,4 +0,0 @@
-#pragma once
-
-#include "ghcautoconf.h"
-#include "ghcplatform.h"